[ { "path": "ClassUtils.pas", "content": "unit ClassUtils;\r\n\r\ninterface\r\n\r\nuses Windows, Classes, SysUtils, StrUtils, XMLDoc, XMLIntf, Graphics, GdiPlus, GdiPlusHelpers, Collections.Dictionaries;\r\n\r\nconst\r\n EIndexError: String = 'List index error: %d';\r\n\r\ntype\r\n TStringArray = Array of String;\r\n\r\n TGradientInfo = class(TObject)\r\n private\r\n FColor: TColor;\r\n FBrush: IGPBrush;\r\n FPen: IGPPen;\r\n FGrList: array of TGPColor;\r\n\r\n procedure Init(const AHeight: Integer; const ADelta: Byte);\r\n procedure InitGrList(const AHeight: Integer; const ADelta: Byte);\r\n public\r\n constructor Create(const AColor: TColor; const AHeight: Integer; const ADelta: Byte = 50);\r\n destructor Destroy; override;\r\n\r\n property Color: TColor read FColor;\r\n property Brush: IGPBrush read FBrush;\r\n property Pen: IGPPen read FPen;\r\n end;\r\n\r\n TGradientInfoList = class(TObjectDictionary)\r\n private\r\n class var\r\n _GradientInfoList: TGradientInfoList;\r\n public\r\n class function GetGradientInfo(const AColor: TColor; const AHeight: Integer): TGradientInfo;\r\n end;\r\n\r\nprocedure DrawVGradientRect(const GP: IGPGraphics; const Rect: TGPRect; const Color: TColor);\r\nprocedure DrawHInterval(const GP: IGPGraphics; const Rect: TGPRect; const Color: TColor);\r\n\r\nfunction GPRect(const Left, Top, Right, Bottom: Integer): TGPRect; inline;\r\n\r\nprocedure RGBToHSV(const Color: TColor; var h, s, v: Integer);\r\nfunction HSV2RGB(const h, s, v: Integer): TColor;\r\n\r\nprocedure ClearStringList(SL: TStringList);\r\nprocedure FreeStringList(var SL: TStringList);\r\n\r\nprocedure ClearList(L: TList);\r\nprocedure FreeList(var L: TList);\r\n\r\nfunction IncPointer(Ptr: Pointer; Offset: Integer): Pointer; inline;\r\n\r\nprocedure SplitStr(const Str: String; const Delimiter: Char; var StrList: TStringArray);\r\n\r\nfunction GetXMLValue(const ParentNode: IXMLNode; const NodeName: String): String;\r\nprocedure SetXMLValue(const ParentNode: IXMLNode; const NodeName, NodeValue: String);\r\n\r\nfunction GetXMLChildNode(const ParentNode: IXMLNode; const NodeName: String; const AutoCreate: LongBool = True): IXMLNode;\r\n\r\nfunction Compare(var Value1, Value2: UInt64): Integer; overload; inline;\r\nfunction Compare(var Value1, Value2: Int64): Integer; overload; inline;\r\nfunction Compare(var Value1, Value2: NativeInt): Integer; overload; inline;\r\nfunction Compare(var Value1, Value2: NativeUInt): Integer; overload; inline;\r\n\r\nfunction Compare(var Value1, Value2: String; const EmptyRes: Integer): Integer; overload;\r\nfunction CompareNumberStr(const Value1, Value2: String): Integer;\r\n\r\nfunction PercentStr(const Count, All: UInt64): String;\r\n\r\nimplementation\r\n\r\nuses Math;\r\n\r\nfunction PercentStr(const Count, All: UInt64): String;\r\nvar\r\n Res: Integer;\r\nbegin\r\n if All > 0 then\r\n Res := Round(100 * Count / All)\r\n else\r\n Res := 0;\r\n\r\n Result := '(' + IntToStr(Res) + '%)';\r\nend;\r\n\r\n\r\n{ TGradientInfo }\r\n\r\nconstructor TGradientInfo.Create(const AColor: TColor; const AHeight: Integer; const ADelta: Byte = 50);\r\nbegin\r\n inherited Create;\r\n\r\n FColor := AColor;\r\n Init(AHeight, ADelta);\r\n InitGrList(AHeight, ADelta);\r\nend;\r\n\r\ndestructor TGradientInfo.Destroy;\r\nbegin\r\n FBrush := nil;\r\n FPen := nil;\r\n\r\n inherited;\r\nend;\r\n\r\nprocedure TGradientInfo.Init(const AHeight: Integer; const ADelta: Byte);\r\nvar\r\n C1, C2: TGPColor;\r\n H, S, V: Integer;\r\n R: TGPRect;\r\nbegin\r\n RGBToHSV(FColor, H, S, V);\r\n\r\n C1 := TGPColor.Create(HSV2RGB(H, S, V + ADelta));\r\n C1.Alpha := $C0;\r\n\r\n C2 := TGPColor.Create(HSV2RGB(H, S, V - ADelta));\r\n C2.Alpha := $C0;\r\n\r\n R := TGPRect.Create(Rect(0, 0, 1, AHeight + 2));\r\n\r\n FBrush := TGPLinearGradientBrush.Create(R, C1, C2, LinearGradientModeVertical);\r\n\r\n FPen := TGPPen.Create(Brush);\r\n FPen.Alignment := PenAlignmentInset;\r\nend;\r\n\r\nprocedure TGradientInfo.InitGrList(const AHeight: Integer; const ADelta: Byte);\r\nvar\r\n I: Integer;\r\n H, S, V: Integer;\r\n StartColor: TColor;\r\n EndColor: TColor;\r\n LStartRGB, LEndRGB: TColor;\r\n DeltaR: Double;\r\n DeltaG: Double;\r\n DeltaB: Double;\r\n DeltaColor: TColor;\r\nbegin\r\n SetLength(FGrList, AHeight);\r\n\r\n if AHeight = 0 then Exit;\r\n\r\n RGBToHSV(Color, H, S, V);\r\n\r\n StartColor := HSV2RGB(H, S, V + ADelta);\r\n EndColor := HSV2RGB(H, S, V - ADelta);\r\n\r\n LStartRGB := ColorToRGB(StartColor);\r\n LEndRGB := ColorToRGB(EndColor);\r\n\r\n DeltaR := (GetRValue(LEndRGB) - GetRValue(LStartRGB)) / AHeight;\r\n DeltaG := (GetGValue(LEndRGB) - GetGValue(LStartRGB)) / AHeight;\r\n DeltaB := (GetBValue(LEndRGB) - GetBValue(LStartRGB)) / AHeight;\r\n\r\n for I := 0 to AHeight - 1 do\r\n begin\r\n DeltaColor := RGB(\r\n GetRValue(LStartRGB) + Round(I * DeltaR),\r\n GetGValue(LStartRGB) + Round(I * DeltaG),\r\n GetBValue(LStartRGB) + Round(I * DeltaB)\r\n );\r\n\r\n FGrList[I] := TGPColor.Create(DeltaColor);\r\n end;\r\nend;\r\n\r\nfunction CompareNumberStr(const Value1, Value2: String): Integer;\r\nbegin\r\n Result := Length(Value1) - Length(Value2);\r\n if Result = 0 then\r\n Result := CompareStr(Value1, Value2);\r\nend;\r\n\r\nfunction Compare(var Value1, Value2: String; const EmptyRes: Integer): Integer;\r\nbegin\r\n if (Value1 <> '') and (Value2 <> '') then\r\n Result := CompareText(Value1, Value2)\r\n else\r\n begin\r\n if (Value1 = '') and (Value2 <> '') then\r\n Result := EmptyRes\r\n else\r\n if (Value1 <> '') and (Value2 = '') then\r\n Result := -EmptyRes\r\n else\r\n Result := 0;\r\n end;\r\nend;\r\n\r\nprocedure DrawVGradientRect(const GP: IGPGraphics; const Rect: TGPRect; const Color: TColor);\r\nvar\r\n GrInfo: TGradientInfo;\r\nbegin\r\n GrInfo := TGradientInfoList.GetGradientInfo(Color, Rect.Height);\r\n\r\n if Rect.Width <> 0 then\r\n GP.FillRectangle(GrInfo.Brush, Rect)\r\n else\r\n GP.DrawLine(GrInfo.Pen, Rect.Left, Rect.Top, Rect.Left, Rect.Bottom - 1);\r\nend;\r\n\r\nprocedure DrawHInterval(const GP: IGPGraphics; const Rect: TGPRect; const Color: TColor);\r\nvar\r\n Brush: IGPBrush;\r\n C: TGPColor;\r\nbegin\r\n if Rect.Width <> 0 then\r\n begin\r\n C := TGPColor.Create(Color);\r\n C.Alpha := $20;\r\n Brush := TGPSolidBrush.Create(C);\r\n GP.FillRectangle(Brush, Rect);\r\n end;\r\nend;\r\n\r\nfunction GPRect(const Left, Top, Right, Bottom: Integer): TGPRect;\r\nbegin\r\n Result.Initialize(Left, Top, Right - Left, Bottom - Top);\r\nend;\r\n\r\n(*\r\nprocedure DrawVGradientRect(Canvas: TCanvas; const Rect: TRect; const StartColor, EndColor: TColor);\r\nvar\r\n I: Integer;\r\n R: TRect;\r\n LStartRGB, LEndRGB: TColor;\r\n LSteps: Integer;\r\n DeltaR: Double;\r\n DeltaG: Double;\r\n DeltaB: Double;\r\n DeltaColor: TColor;\r\nbegin\r\n LSteps := Rect.Bottom - Rect.Top;\r\n if LSteps = 0 then Exit;\r\n\r\n LStartRGB := ColorToRGB(StartColor);\r\n LEndRGB := ColorToRGB(EndColor);\r\n\r\n DeltaR := (GetRValue(LEndRGB) - GetRValue(LStartRGB)) / LSteps;\r\n DeltaG := (GetGValue(LEndRGB) - GetGValue(LStartRGB)) / LSteps;\r\n DeltaB := (GetBValue(LEndRGB) - GetBValue(LStartRGB)) / LSteps;\r\n\r\n R.Left := Rect.Left;\r\n R.Right := Rect.Right;\r\n\r\n Canvas.Pen.Style := psSolid;\r\n\r\n for I := 0 to LSteps - 1 do\r\n begin\r\n R.Top := Rect.Top + I;\r\n\r\n DeltaColor := RGB(\r\n GetRValue(LStartRGB) + Round(I * DeltaR),\r\n GetGValue(LStartRGB) + Round(I * DeltaG),\r\n GetBValue(LStartRGB) + Round(I * DeltaB)\r\n );\r\n\r\n if R.Left = R.Right then\r\n begin\r\n Canvas.Pixels[R.Left, R.Top] := DeltaColor;\r\n end\r\n else\r\n begin\r\n Canvas.Pen.Color := DeltaColor;\r\n Canvas.MoveTo(R.Left, R.Top);\r\n Canvas.LineTo(R.Right, R.Top);\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure DrawVGradientRect2(Canvas: TCanvas; const Rect: TRect; const Color: TColor; const Delta: Byte = 50);\r\nvar\r\n H, S, V: Integer;\r\n C1, C2: TColor;\r\nbegin\r\n RGBToHSV(Color, H, S, V);\r\n\r\n C1 := HSV2RGB(H, S, V + Delta);\r\n C2 := HSV2RGB(H, S, V - Delta);\r\n\r\n DrawVGradientRect(Canvas, Rect, C1, C2);\r\nend;\r\n*)\r\n\r\nfunction Compare(var Value1, Value2: Int64): Integer;\r\nbegin\r\n Result := Value1 - Value2;\r\nend;\r\n\r\nfunction Compare(var Value1, Value2: UInt64): Integer;\r\nbegin\r\n Result := Int64(Value1) - Int64(Value2);\r\nend;\r\n\r\nfunction Compare(var Value1, Value2: NativeInt): Integer;\r\nbegin\r\n Result := Value1 - Value2;\r\nend;\r\n\r\nfunction Compare(var Value1, Value2: NativeUInt): Integer;\r\nbegin\r\n Result := NativeInt(Value1) - NativeInt(Value2);\r\nend;\r\n\r\n// h=[0..360] s,v=[0..255]\r\nprocedure RGBToHSV(const Color: TColor; var h, s, v: Integer);\r\nvar\r\n Delta: Integer;\r\n MinRGB, MaxRGB: Integer;\r\n r, g, b: Byte;\r\nbegin\r\n r := GetRValue(Color);\r\n g := GetGValue(Color);\r\n b := GetBValue(Color);\r\n\r\n MinRGB := Min(r, Min(g, b));\r\n MaxRGB := Max(r, Max(g, b));\r\n\r\n v := MaxRGB;\r\n Delta := MaxRGB - MinRGB;\r\n\r\n if MaxRGB = 0 then\r\n s := 0\r\n else\r\n s := (255 * Delta) div MaxRGB;\r\n\r\n if s = 0 then\r\n h := 0\r\n else\r\n begin\r\n if r = MaxRGB then\r\n h := (60 * (g - b)) div Delta\r\n else\r\n if g = MaxRGB then\r\n h := 120 + (60 * (b - r)) div Delta\r\n else\r\n h := 240 + (60 * (r - g)) div Delta;\r\n\r\n if h < 0 then\r\n h := h + 360;\r\n end;\r\nend;\r\n\r\nfunction HSV2RGB(const h, s, v: Integer): TColor;\r\nvar\r\n Hi: Integer;\r\n f, p, q, t: Double;\r\n r, g, b: Double;\r\n sf, vf: Double;\r\n hf: Integer;\r\nbegin\r\n sf := Max(0, Min(255, s));\r\n vf := Max(0, Min(255, v));\r\n hf := Max(0, Min(360, h));\r\n\r\n sf := sf / 255;\r\n vf := vf / 255;\r\n\r\n f := hf / 60 - (hf div 60);\r\n p := vf * (1 - sf);\r\n q := vf * (1 - f * sf);\r\n t := vf * (1 - (1 - f) * sf);\r\n\r\n Hi := (hf div 60) mod 6;\r\n case Hi of\r\n 0: begin r := vf; g := t; b := p; end;\r\n 1: begin r := q; g := vf; b := p; end;\r\n 2: begin r := p; g := vf; b := t; end;\r\n 3: begin r := p; g := q; b := vf; end;\r\n 4: begin r := t; g := p; b := vf; end;\r\n 5: begin r := vf; g := p; b := q; end;\r\n else\r\n begin r := 0; g := 0; b := 0; end;\r\n end;\r\n\r\n Result := RGB(Round(r * 255), Round(g * 255), Round(b * 255));\r\nend;\r\n\r\n\r\nprocedure SetXMLValue(const ParentNode: IXMLNode; const NodeName, NodeValue: String);\r\nbegin\r\n if Assigned(ParentNode) then\r\n ParentNode.ChildValues[AnsiLowerCase(NodeName)] := NodeValue;\r\nend;\r\n\r\nfunction GetXMLChildNode(const ParentNode: IXMLNode; const NodeName: String; const AutoCreate: LongBool = True): IXMLNode;\r\nbegin\r\n Result := nil;\r\n\r\n if Assigned(ParentNode) then\r\n begin\r\n Result := ParentNode.ChildNodes.FindNode(AnsiLowerCase(NodeName));\r\n if not Assigned(Result) and AutoCreate then\r\n Result := ParentNode.AddChild(NodeName);\r\n end;\r\nend;\r\n\r\nfunction GetXMLValue(const ParentNode: IXMLNode; const NodeName: String): String;\r\nvar\r\n ResNode: IXMLNode;\r\nbegin\r\n Result := '';\r\n if Assigned(ParentNode) then\r\n begin\r\n ResNode := ParentNode.ChildNodes.FindNode(AnsiLowerCase(NodeName));\r\n if Assigned(ResNode) and ResNode.IsTextElement then\r\n Result := ResNode.Text;\r\n end;\r\nend;\r\n\r\nprocedure SplitStr(const Str: String; const Delimiter: Char; var StrList: TStringArray);\r\nvar\r\n SL: TStringList;\r\n I: Integer;\r\nbegin\r\n SL := TStringList.Create;\r\n try\r\n SL.Delimiter := Delimiter;\r\n SL.StrictDelimiter;\r\n SL.Duplicates := dupAccept;\r\n\r\n SL.DelimitedText := Str;\r\n\r\n SetLength(StrList, SL.Count);\r\n for I := 0 to SL.Count - 1 do\r\n StrList[I] := SL.Strings[I];\r\n finally\r\n FreeAndNil(SL);\r\n end;\r\nend;\r\n\r\nfunction IncPointer(Ptr: Pointer; Offset: Integer): Pointer;\r\nbegin\r\n Result := Pointer(Integer(Ptr) + Offset);\r\nend;\r\n\r\nprocedure ClearStringList(SL: TStringList);\r\nvar\r\n I: Integer;\r\n Obj: TObject;\r\nbegin\r\n if SL = nil then Exit;\r\n\r\n for I := 0 to SL.Count - 1 do\r\n begin\r\n Obj := SL.Objects[I];\r\n if Obj <> nil then\r\n begin\r\n SL.Objects[I] := nil;\r\n FreeAndNil(Obj);\r\n end;\r\n end;\r\n\r\n SL.Clear;\r\nend;\r\n\r\nprocedure FreeStringList(var SL: TStringList);\r\nbegin\r\n ClearStringList(SL);\r\n FreeAndNil(SL);\r\nend;\r\n\r\nprocedure ClearList(L: TList);\r\nvar\r\n I: Integer;\r\n Obj: TObject;\r\nbegin\r\n if L = nil then Exit;\r\n \r\n for I := 0 to L.Count - 1 do\r\n begin\r\n Obj := L[I];\r\n if Obj <> nil then\r\n begin\r\n L[I] := nil;\r\n FreeAndNil(Obj);\r\n end;\r\n end;\r\n\r\n L.Clear;\r\nend;\r\n\r\nprocedure FreeList(var L: TList);\r\nbegin\r\n ClearList(L);\r\n FreeAndNil(L);\r\nend;\r\n\r\n{ TGradientInfoList }\r\n\r\nclass function TGradientInfoList.GetGradientInfo(const AColor: TColor;\r\n const AHeight: Integer): TGradientInfo;\r\nbegin\r\n if not _GradientInfoList.TryGetValue(AColor, Result) then\r\n begin\r\n Result := TGradientInfo.Create(AColor, AHeight);\r\n _GradientInfoList.AddOrSetValue(AColor, Result);\r\n end;\r\nend;\r\n\r\ninitialization\r\n TGradientInfoList._GradientInfoList := TGradientInfoList.Create;\r\n TGradientInfoList._GradientInfoList.OwnsValues := True;\r\n\r\nfinalization\r\n FreeAndNil(TGradientInfoList._GradientInfoList);\r\nend.\r\n\r\n" }, { "path": "CollectList.inc", "content": "{ TCollectList }\r\n\r\nfunction TCollectList.Add: PData;\r\nvar\r\n Idx: Cardinal;\r\n Seg, Offset: Integer;\r\nbegin\r\n Idx := Count;\r\n IndexToSegment(Idx, Seg, Offset);\r\n CheckSeg(Seg);\r\n FCount := Idx + 1;\r\n\r\n Result := @FSegList[Seg][Offset];\r\n\r\n FillChar(Result^, SizeOf(T), 0);\r\nend;\r\n\r\nprocedure TCollectList.CheckSeg(const Seg: Integer);\r\nbegin\r\n if Length(FSegList) <= Seg then\r\n begin\r\n SetLength(FSegList, Seg + 1);\r\n SetLength(FSegList[Seg], FSegSize);\r\n end;\r\nend;\r\n\r\nprocedure TCollectList.Clear;\r\nbegin\r\n FCount := 0;\r\n SetLength(FSegList, 0);\r\nend;\r\n\r\nconstructor TCollectList.Create;\r\nbegin\r\n inherited;\r\n\r\n FCount := 0;\r\n FLock := TCriticalSection.Create;\r\n FSegSize := _SEGMENT_SIZE div SizeOf(T);\r\n SetLength(FSegList, 0);\r\nend;\r\n\r\ndestructor TCollectList.Destroy;\r\nbegin\r\n Clear;\r\n\r\n FreeAndNil(FLock);\r\n\r\n inherited;\r\nend;\r\n\r\nfunction TCollectList.GetItem(const Index: Cardinal): PData;\r\nvar\r\n Seg, Offset: Integer;\r\nbegin\r\n if IndexToSegment(Index, Seg, Offset) then\r\n Result := @FSegList[Seg][Offset]\r\n else\r\n RaiseError(@EIndexError, [Index]);\r\nend;\r\n\r\nfunction TCollectList.IndexToSegment(const Index: Cardinal; var Seg, Offset: Integer): Boolean;\r\nbegin\r\n Result := Index < Count;\r\n\r\n Seg := Index div FSegSize;\r\n Offset := Index mod FSegSize;\r\nend;\r\n\r\nprocedure TCollectList.RaiseError(Msg: PString; const Args: Array of const);\r\nbegin\r\n raise TCollectListError.CreateFmt(Msg^, Args);\r\nend;\r\n\r\nprocedure TCollectList.Lock;\r\nbegin\r\n FLock.Enter;\r\nend;\r\n\r\nprocedure TCollectList.UnLock;\r\nbegin\r\n FLock.Leave;\r\nend;\r\n" }, { "path": "CollectList.pas", "content": "unit CollectList;\r\n\r\ninterface\r\n\r\nuses Classes, SysUtils, SyncObjs, ClassUtils;\r\n\r\nconst\r\n _DEF_SEGMENT_SIZE = 16 * 1024;\r\n _SEG_LIST_GROW = 16;\r\n\r\ntype\r\n TSegment = Array of T;\r\n\r\n TSegList = Array of TSegment;\r\n\r\n TCollectListError = class(Exception);\r\n\r\n PData = Pointer;\r\n\r\n TBaseCollectList = class\r\n private\r\n FCount: Integer;\r\n FAddCount: Integer;\r\n FLock: TMREWSync;\r\n protected\r\n FSegLength: Integer;\r\n\r\n function GetItem(const Index: Integer): PData; virtual; abstract;\r\n procedure CheckSeg(const Seg: Integer); virtual; abstract;\r\n\r\n function IndexToSegment(const Index: Integer; var Seg, Offset: Integer): LongBool;\r\n procedure RaiseError(Msg: PString; const Args: Array of const);\r\n public\r\n constructor Create;\r\n destructor Destroy; override;\r\n\r\n function Add: PData; virtual;\r\n procedure Commit; virtual;\r\n procedure Clear; virtual;\r\n\r\n procedure BeginRead; inline;\r\n procedure EndRead; inline;\r\n procedure BeginWrite; inline;\r\n procedure EndWrite; inline;\r\n\r\n property Count: Integer read FCount;\r\n property Items[const Index: Integer]: PData read GetItem; default;\r\n property Lock: TMREWSync read FLock;\r\n end;\r\n\r\n TCollectList = class(TBaseCollectList)\r\n private\r\n FSegList: TSegList;\r\n protected\r\n function GetItem(const Index: Integer): PData; override;\r\n procedure CheckSeg(const Seg: Integer); override;\r\n public\r\n constructor Create(const SegSize: Integer = _DEF_SEGMENT_SIZE);\r\n destructor Destroy; override;\r\n\r\n function Add: PData; override;\r\n procedure Clear; override;\r\n end;\r\n\r\n //XE6 bug? default AtomicIncrement gives an AV!\r\n function AtomicIncrement(var Target: Integer; Increment: Integer): Integer; overload;\r\n function AtomicIncrement(var Target: Integer): Integer; overload;\r\n\r\nimplementation\r\n\r\nuses\r\n Winapi.Windows;\r\n\r\n{ TBaseCollectList }\r\n\r\nfunction AtomicIncrement(var Target: Integer; Increment: Integer): Integer; overload; inline;\r\nbegin\r\n Result := InterlockedExchangeAdd(Target, Increment);\r\nend;\r\n\r\nfunction AtomicIncrement(var Target: Integer): Integer; overload; inline;\r\nbegin\r\n Result := InterlockedIncrement(Target);\r\nend;\r\n\r\nfunction TBaseCollectList.Add: PData;\r\nbegin\r\n Result := Nil;\r\n AtomicIncrement(FAddCount);\r\nend;\r\n\r\nprocedure TBaseCollectList.Clear;\r\nbegin\r\n FCount := 0;\r\nend;\r\n\r\nprocedure TBaseCollectList.Commit;\r\nbegin\r\n BeginWrite;\r\n AtomicIncrement(FCount, FAddCount);\r\n AtomicExchange(FAddCount, 0);\r\n EndWrite;\r\nend;\r\n\r\nconstructor TBaseCollectList.Create;\r\nbegin\r\n inherited;\r\n\r\n FCount := 0;\r\n FLock := TMREWSync.Create;\r\nend;\r\n\r\ndestructor TBaseCollectList.Destroy;\r\nbegin\r\n Clear;\r\n FreeAndNil(FLock);\r\n\r\n inherited;\r\nend;\r\n\r\nprocedure TBaseCollectList.BeginRead;\r\nbegin\r\n FLock.BeginRead;\r\nend;\r\n\r\nprocedure TBaseCollectList.BeginWrite;\r\nbegin\r\n FLock.BeginWrite;\r\nend;\r\n\r\nprocedure TBaseCollectList.RaiseError(Msg: PString; const Args: array of const);\r\nbegin\r\n raise TCollectListError.CreateFmt(Msg^, Args);\r\nend;\r\n\r\nprocedure TBaseCollectList.EndRead;\r\nbegin\r\n FLock.EndRead;\r\nend;\r\n\r\nprocedure TBaseCollectList.EndWrite;\r\nbegin\r\n FLock.EndWrite;\r\nend;\r\n\r\nfunction TBaseCollectList.IndexToSegment(const Index: Integer; var Seg, Offset: Integer): LongBool;\r\nbegin\r\n Result := (Index < FCount) and (Index >= 0);\r\n\r\n Seg := Index div FSegLength;\r\n Offset := Index mod FSegLength;\r\nend;\r\n\r\n{ TCollectList }\r\n\r\nfunction TCollectList.Add: PData;\r\nvar\r\n Seg, Offset: Integer;\r\n NextIdx: Integer;\r\nbegin\r\n BeginRead;\r\n\r\n // \r\n NextIdx := FCount + AtomicIncrement(FAddCount) - 1;\r\n\r\n // \r\n IndexToSegment(NextIdx, Seg, Offset);\r\n CheckSeg(Seg);\r\n\r\n // \r\n Result := @FSegList[Seg][Offset];\r\n\r\n EndRead;\r\n\r\n FillChar(Result^, SizeOf(T), 0);\r\n //Initialize(T(Result^));\r\nend;\r\n\r\nprocedure TCollectList.CheckSeg(const Seg: Integer);\r\nbegin\r\n //BeginRead;\r\n\r\n if Length(FSegList) <= Seg then\r\n begin\r\n BeginWrite;\r\n SetLength(FSegList, Seg + _SEG_LIST_GROW);\r\n SetLength(FSegList[Seg], FSegLength);\r\n EndWrite;\r\n end;\r\n\r\n if Length(FSegList[Seg]) = 0 then\r\n begin\r\n BeginWrite;\r\n SetLength(FSegList[Seg], FSegLength);\r\n EndWrite;\r\n end;\r\n\r\n //EndRead;\r\nend;\r\n\r\nprocedure TCollectList.Clear;\r\nbegin\r\n BeginWrite;\r\n inherited Clear;\r\n SetLength(FSegList, 0);\r\n EndWrite;\r\nend;\r\n\r\nconstructor TCollectList.Create(const SegSize: Integer = _DEF_SEGMENT_SIZE);\r\nbegin\r\n inherited Create;\r\n\r\n FSegLength := SegSize div SizeOf(T);\r\n SetLength(FSegList, 0);\r\nend;\r\n\r\ndestructor TCollectList.Destroy;\r\nbegin\r\n Clear;\r\n\r\n inherited;\r\nend;\r\n\r\nfunction TCollectList.GetItem(const Index: Integer): PData;\r\nvar\r\n Seg, Offset: Integer;\r\nbegin\r\n Result := nil;\r\n\r\n if IndexToSegment(Index, Seg, Offset) then\r\n begin\r\n BeginRead;\r\n Result := @FSegList[Seg][Offset];\r\n EndRead;\r\n end\r\n else\r\n RaiseError(@EIndexError, [Index]);\r\nend;\r\n\r\nend.\r\n" }, { "path": "CollectListIntf.inc", "content": "const\r\n _SEGMENT_SIZE = 16 * 1024;\r\n\r\ntype\r\n TSegment = Array of T;\r\n\r\n TSegList = Array of TSegment;\r\n\r\n TCollectListError = class(Exception);\r\n\r\n PData = Pointer;\r\n\r\n TCollectList = class\r\n private\r\n FCount: Cardinal;\r\n FSegSize: Cardinal;\r\n FLock: TCriticalSection;\r\n FSegList: TSegList;\r\n function GetItem(const Index: Cardinal): PData;\r\n procedure CheckSeg(const Seg: Integer);\r\n protected\r\n function IndexToSegment(const Index: Cardinal; var Seg, Offset: Integer): Boolean;\r\n procedure RaiseError(Msg: PString; const Args: Array of const);\r\n public\r\n\r\n constructor Create;\r\n destructor Destroy; override;\r\n\r\n function Add: PData;\r\n\r\n procedure Clear;\r\n\r\n procedure Lock;\r\n procedure UnLock;\r\n\r\n property Count: Cardinal read FCount;\r\n property Items[const Index: Cardinal]: PData read GetItem; default;\r\n end;\r\n" }, { "path": "Collections/Collections.Bags.pas", "content": "(*\r\n* Copyright (c) 2009-2012, Ciobanu Alexandru\r\n* All rights reserved.\r\n*\r\n* Redistribution and use in source and binary forms, with or without\r\n* modification, are permitted provided that the following conditions are met:\r\n* * Redistributions of source code must retain the above copyright\r\n* notice, this list of conditions and the following disclaimer.\r\n* * Redistributions in binary form must reproduce the above copyright\r\n* notice, this list of conditions and the following disclaimer in the\r\n* documentation and/or other materials provided with the distribution.\r\n* * Neither the name of the nor the\r\n* names of its contributors may be used to endorse or promote products\r\n* derived from this software without specific prior written permission.\r\n*\r\n* THIS SOFTWARE IS PROVIDED BY THE AUTHOR ''AS IS'' AND ANY\r\n* EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED\r\n* WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE\r\n* DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY\r\n* DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES\r\n* (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;\r\n* LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND\r\n* ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT\r\n* (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS\r\n* SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.\r\n*)\r\n\r\nunit Collections.Bags;\r\ninterface\r\nuses SysUtils,\r\n Generics.Defaults,\r\n Generics.Collections,\r\n Collections.Base,\r\n Collections.Dictionaries;\r\n\r\ntype\r\n /// The abstract base class for all bag collections.\r\n /// This base class introduces and implements all bag operations. Specific bag implementations must\r\n /// override only one method in order to create the specific dictionary type that is going to hold the element to weight associations.\r\n TAbstractBag = class(TCollection, IBag)\r\n private type\r\n {$REGION 'Internal Types'}\r\n TEnumerator = class(TAbstractEnumerator)\r\n private\r\n FCurrentWeight: NativeInt;\r\n FDictionaryEnumerator: IEnumerator>;\r\n public\r\n function TryMoveNext(out ACurrent: T): Boolean; override;\r\n end;\r\n {$ENDREGION}\r\n\r\n private var\r\n FDictionary: IDictionary;\r\n FKnownCount: NativeInt;\r\n\r\n protected\r\n /// Specifies the internal dictionary used to store the element to weight associations.\r\n /// The value of this property is nil only when the object is still being created.\r\n /// A new dictionary whose keys are the bag's elements and the values are the weights associated with\r\n /// those elements.\r\n property Dictionary: IDictionary read FDictionary;\r\n\r\n /// Returns the number of elements in the bag.\r\n /// A positive value specifying the number of elements in the bag.\r\n /// The count of a bag is calculated by taking each element multiplied by its weight. For example, if the bag only contains one element\r\n /// with weight 10, then the size of the bag is 10.\r\n function GetCount(): NativeInt; override;\r\n\r\n /// Returns the weight of an element in the bag.\r\n /// The element to return the weight for.\r\n /// A positive number specifying the weight of the requested element.\r\n /// If the value is not found in the bag, a zero weight is assumed.\r\n function GetWeight(const AValue: T): NativeUInt;\r\n\r\n /// Sets the weight of an element in the bag.\r\n /// The element to set the weight for.\r\n /// The new weight to set.\r\n /// If the value is not found in the bag, this method acts like an Add operation; otherwise\r\n /// the weight of the stored item is adjusted accordingly.\r\n procedure SetWeight(const AValue: T; const AWeight: NativeUInt);\r\n\r\n /// Called when the map needs to initialize its internal dictionary.\r\n /// The rule set describing the elements.\r\n /// This method creates a hash-based dictionary used as the underlying back-end for the bag.\r\n function CreateDictionary(const ARules: TRules): IDictionary; virtual; abstract;\r\n public\r\n /// Creates a new bag collection.\r\n /// A rule set describing the elements in the bag.\r\n constructor Create(const ARules: TRules);\r\n\r\n /// Clears the contents of the bag.\r\n procedure Clear(); override;\r\n\r\n /// Adds an element into the bag with a weight of 1.\r\n /// The value to add.\r\n procedure Add(const AValue: T); override;\r\n\r\n /// Adds an element to the bag.\r\n /// The element to add.\r\n /// The weight of the element.\r\n /// If the bag already contains the given value, its stored weight is incremented to by .\r\n /// If the value of is zero, nothing happens.\r\n procedure AddWeight(const AValue: T; const AWeight: NativeUInt = 1);\r\n\r\n /// Decreases the weight for an element by 1.\r\n /// The value to decrese weight for.\r\n procedure Remove(const AValue: T); override;\r\n\r\n /// Removes an element from the bag.\r\n /// The value to remove.\r\n /// The weight to remove.\r\n /// This method decreses the weight of the stored item by . If the resulting weight is less\r\n /// than zero or zero, the element is removed from the bag. If is zero, nothing happens.\r\n procedure RemoveWeight(const AValue: T; const AWeight: NativeUInt = 1);\r\n\r\n /// Removes an element from the bag.\r\n /// The value to remove.\r\n /// This method completely removes an item from the bag ignoring its stored weight. Nothing happens if the given value\r\n /// is not in the bag to begin with.\r\n procedure RemoveAllWeight(const AValue: T);\r\n\r\n /// Checks whether the bag contains an element with at least the weight of 1.\r\n /// The value to check for.\r\n /// True if the condition is met; False otherwise.\r\n function Contains(const AValue: T): Boolean; override;\r\n\r\n /// Checks whether the bag contains an element with at least the required weight.\r\n /// The value to check.\r\n /// The smallest allowed weight.\r\n /// True if the condition is met; False otherwise.\r\n /// This method checks whether the bag contains the given value and that the contained value has at least the\r\n /// given weight.\r\n function ContainsWeight(const AValue: T; const AWeight: NativeUInt = 1): Boolean;\r\n\r\n /// Sets or gets the weight of an item in the bag.\r\n /// The value.\r\n /// If the value is not found in the bag, this method acts like an Add operation; otherwise\r\n /// the weight of the stored item is adjusted.\r\n property Weights[const AValue: T]: NativeUInt read GetWeight write SetWeight; default;\r\n\r\n /// Returns the number of elements in the bag.\r\n /// A positive value specifying the number of elements in the bag.\r\n /// The count of a bag is calculated by taking each element multiplied by its weight. For example, if the bag only contains one element\r\n /// with weight 10, then the size of the bag is 10.\r\n property Count: NativeInt read FKnownCount;\r\n\r\n /// Returns a new enumerator object used to enumerate this bag.\r\n /// This method is usually called by compiler-generated code. Its purpose is to create an enumerator\r\n /// object that is used to actually traverse the bag.\r\n /// An enumerator object.\r\n function GetEnumerator(): IEnumerator; override;\r\n\r\n /// Copies the values stored in the bag to a given array.\r\n /// An array where to copy the contents of the bag.\r\n /// The index into the array at which the copying begins.\r\n /// This method assumes that has enough space to hold the contents of the bag.\r\n /// is out of bounds.\r\n /// The array is not long enough.\r\n procedure CopyTo(var AArray: array of T; const AStartIndex: NativeInt); overload; override;\r\n\r\n /// Checks whether the bag is empty.\r\n /// True if the bag is empty; False otherwise.\r\n /// This method is the recommended way of detecting if the bag is empty.\r\n function Empty(): Boolean; override;\r\n\r\n /// Returns the biggest element.\r\n /// An element from the bag considered to have the biggest value.\r\n /// The bag is empty.\r\n function Max(): T; override;\r\n\r\n /// Returns the smallest element.\r\n /// An element from the bag considered to have the smallest value.\r\n /// The bag is empty.\r\n function Min(): T; override;\r\n\r\n /// Returns the first element.\r\n /// The first element in the bag.\r\n /// The bag is empty.\r\n function First(): T; override;\r\n\r\n /// Returns the first element or a default, if the bag is empty.\r\n /// The default value returned if the bag is empty.\r\n /// The first element in the bag if the bag is not empty; otherwise is returned.\r\n function FirstOrDefault(const ADefault: T): T; override;\r\n\r\n /// Returns the last element.\r\n /// The last element in the bag.\r\n /// The bag is empty.\r\n function Last(): T; override;\r\n\r\n /// Returns the last element or a default, if the bag is empty.\r\n /// The default value returned if the bag is empty.\r\n /// The last element in the bag if the bag is not empty; otherwise is returned.\r\n function LastOrDefault(const ADefault: T): T; override;\r\n\r\n /// Returns the single element stored in the bag.\r\n /// The element in the bag.\r\n /// This method checks whether the bag contains just one element, in which case it is returned.\r\n /// The bag is empty.\r\n /// There is more than one element in the bag.\r\n function Single(): T; override;\r\n\r\n /// Returns the single element stored in the bag, or a default value.\r\n /// The default value returned if there are less or more elements in the bag.\r\n /// The element in the bag if the condition is satisfied; is returned otherwise.\r\n /// This method checks whether the bag contains just one element, in which case it is returned. Otherwise\r\n /// the value in is returned.\r\n function SingleOrDefault(const ADefault: T): T; override;\r\n\r\n /// Checks whether at least one element in the bag satisfies a given predicate.\r\n /// The predicate to check for each element.\r\n /// True if at least one element satisfies a given predicate; False otherwise.\r\n /// This method traverses the whole bag and checks the value of the predicate for each element. This method\r\n /// stops on the first element for which the predicate returns True. The logical equivalent of this operation is \"OR\".\r\n /// is nil.\r\n function Any(const APredicate: TPredicate): Boolean; override;\r\n\r\n /// Checks that all elements in the bag satisfy a given predicate.\r\n /// The predicate to check for each element.\r\n /// True if all elements satisfy a given predicate; False otherwise.\r\n /// This method traverses the whole bag and checks the value of the predicate for each element. This method\r\n /// stops on the first element for which the predicate returns False. The logical equivalent of this operation is \"AND\".\r\n /// is nil.\r\n function All(const APredicate: TPredicate): Boolean; override;\r\n end;\r\n\r\ntype\r\n /// The generic bag collection.\r\n /// This particular bag implementation uses a hash-based dictionary to store its element to weight associations.\r\n TBag = class(TAbstractBag)\r\n private var\r\n FInitialCapacity: NativeInt;\r\n\r\n protected\r\n /// Called when the bag needs to initialize its internal dictionary.\r\n /// The rule set describing the bag's elements.\r\n /// This method creates a hash-based dictionary used as the underlying back-end for the bag.\r\n function CreateDictionary(const ARules: TRules): IDictionary; override;\r\n public\r\n /// Creates a new bag collection.\r\n /// This constructor requests the default rule set. Call the overloaded constructor if\r\n /// specific a set of rules need to be passed.\r\n constructor Create(); overload;\r\n\r\n /// Creates a new bag collection.\r\n /// A rule set describing the elements in the bag.\r\n constructor Create(const ARules: TRules); overload;\r\n\r\n /// Creates a new bag collection.\r\n /// A rule set describing the elements in the bag.\r\n /// The stack's initial capacity.\r\n constructor Create(const ARules: TRules; const AInitialCapacity: NativeInt); overload;\r\n\r\n end;\r\n\r\n /// The generic bag collection designed to store objects.\r\n /// This particular bag implementation uses a hash-based dictionary to store its element to weight associations.\r\n TObjectBag = class(TBag)\r\n private\r\n FOwnsObjects: Boolean;\r\n\r\n protected\r\n /// Frees the object that was removed from the collection.\r\n /// The object that was removed from the collection.\r\n /// This method will only free the removed element if OwnsObjects property is set to True;\r\n /// otherwise it will simply be ignored.\r\n procedure HandleElementRemoved(const AElement: T); override;\r\n\r\n public\r\n /// Specifies whether this bag owns the elements stored in it.\r\n /// True if the bag owns its elements; False otherwise.\r\n /// This property specifies the way the bag controls the life-time of its elements.\r\n property OwnsObjects: Boolean read FOwnsObjects write FOwnsObjects;\r\n end;\r\n\r\ntype\r\n /// The generic sorted bag collection.\r\n /// This particular bag implementation uses an AVL-based dictionary to store its element to weight associations.\r\n TSortedBag = class(TAbstractBag)\r\n private var\r\n FAscendingSort: Boolean;\r\n\r\n protected\r\n /// Called when the bag needs to initialize its internal dictionary.\r\n /// The rule set describing the bag's elements.\r\n /// This method creates an AVL-based dictionary used as the underlying back-end for the bag.\r\n function CreateDictionary(const ARules: TRules): IDictionary; override;\r\n public\r\n /// Creates a new bag collection.\r\n /// This constructor requests the default rule set. Call the overloaded constructor if\r\n /// specific a set of rules need to be passed. The elements are stored in ascending order.\r\n constructor Create(); overload;\r\n\r\n /// Creates a new bag collection.\r\n /// A rule set describing the elements in the bag.\r\n /// The elements are stored in ascending order.\r\n constructor Create(const ARules: TRules); overload;\r\n\r\n /// Creates a new bag collection.\r\n /// Pass in a value of True if the elements should be kept in ascending order.\r\n /// Pass in False for descending order.\r\n /// A rule set describing the elements in the bag.\r\n constructor Create(const ARules: TRules; const AAscending: Boolean); overload;\r\n end;\r\n\r\n /// The generic sorted bag collection designed to store objects.\r\n /// This particular bag implementation uses an AVL-based dictionary to store its element to weight associations.\r\n TObjectSortedBag = class(TSortedBag)\r\n private\r\n FOwnsObjects: Boolean;\r\n\r\n protected\r\n /// Frees the object that was removed from the collection.\r\n /// The object that was removed from the collection.\r\n /// This method will only free the removed element if OwnsObjects property is set to True;\r\n /// otherwise it will simply be ignored.\r\n procedure HandleElementRemoved(const AElement: T); override;\r\n\r\n public\r\n /// Specifies whether this bag owns the elements stored in it.\r\n /// True if the bag owns its elements; False otherwise.\r\n /// This property specifies the way the bag controls the life-time of its elements.\r\n property OwnsObjects: Boolean read FOwnsObjects write FOwnsObjects;\r\n end;\r\n\r\nimplementation\r\n\r\n{ TAbstractBag }\r\n\r\nprocedure TAbstractBag.Add(const AValue: T);\r\nbegin\r\n AddWeight(AValue, 1);\r\nend;\r\n\r\nprocedure TAbstractBag.AddWeight(const AValue: T; const AWeight: NativeUInt);\r\nvar\r\n LOldCount: NativeUInt;\r\nbegin\r\n { Check count > 0 }\r\n if AWeight = 0 then\r\n Exit;\r\n\r\n { Add or update count }\r\n if FDictionary.TryGetValue(AValue, LOldCount) then\r\n FDictionary[AValue] := LOldCount + AWeight\r\n else\r\n FDictionary.Add(AValue, AWeight);\r\n\r\n Inc(FKnownCount, AWeight);\r\n NotifyCollectionChanged();\r\nend;\r\n\r\nfunction TAbstractBag.All(const APredicate: TPredicate): Boolean;\r\nbegin\r\n { Use TDictionary's Keys }\r\n Result := FDictionary.Keys.All(APredicate);\r\nend;\r\n\r\nfunction TAbstractBag.Any(const APredicate: TPredicate): Boolean;\r\nbegin\r\n { Use TDictionary's Keys }\r\n Result := FDictionary.Keys.Any(APredicate);\r\nend;\r\n\r\nprocedure TAbstractBag.Clear;\r\nbegin\r\n if Assigned(FDictionary) then\r\n begin\r\n { Simply clear the dictionary }\r\n FDictionary.Clear();\r\n\r\n FKnownCount := 0;\r\n NotifyCollectionChanged();\r\n end;\r\nend;\r\n\r\nfunction TAbstractBag.Contains(const AValue: T): Boolean;\r\nbegin\r\n Result := ContainsWeight(AValue, 1);\r\nend;\r\n\r\nfunction TAbstractBag.ContainsWeight(const AValue: T; const AWeight: NativeUInt): Boolean;\r\nvar\r\n LInCount: NativeUInt;\r\nbegin\r\n { Check count > 0 }\r\n if AWeight = 0 then\r\n Exit(true);\r\n\r\n { Check the counts in the bag }\r\n Result := (FDictionary.TryGetValue(AValue, LInCount)) and (LInCount >= AWeight);\r\nend;\r\n\r\nprocedure TAbstractBag.CopyTo(var AArray: array of T; const AStartIndex: NativeInt);\r\nvar\r\n LTempArray: array of TPair;\r\n I, X, Y: NativeInt;\r\nbegin\r\n if (AStartIndex >= Length(AArray)) or (AStartIndex < 0) then\r\n ExceptionHelper.Throw_ArgumentOutOfRangeError('AStartIndex');\r\n\r\n { Check for indexes }\r\n if (Length(AArray) - AStartIndex) < Count then\r\n ExceptionHelper.Throw_ArgumentOutOfSpaceError('AArray');\r\n\r\n { Nothing to do? }\r\n if Count = 0 then\r\n Exit;\r\n\r\n { Initialize the temporary array }\r\n SetLength(LTempArray, FDictionary.Count);\r\n FDictionary.CopyTo(LTempArray);\r\n\r\n X := AStartIndex;\r\n\r\n { OK! Now let's simply copy }\r\n for I := 0 to Length(LTempArray) - 1 do\r\n begin\r\n { Copy one value for a number of counts }\r\n for Y := 0 to LTempArray[I].Value - 1 do\r\n begin\r\n AArray[X] := LTempArray[I].Key;\r\n Inc(X);\r\n end;\r\n end;\r\nend;\r\n\r\nconstructor TAbstractBag.Create(const ARules: TRules);\r\nbegin\r\n inherited Create(ARules);\r\n FDictionary := CreateDictionary(ElementRules);\r\nend;\r\n\r\nfunction TAbstractBag.Empty: Boolean;\r\nbegin\r\n Result := (FKnownCount = 0);\r\nend;\r\n\r\nfunction TAbstractBag.First: T;\r\nbegin\r\n { Use TDictionary's Keys }\r\n Result := FDictionary.Keys.First();\r\nend;\r\n\r\nfunction TAbstractBag.FirstOrDefault(const ADefault: T): T;\r\nbegin\r\n { Use TDictionary's Keys }\r\n Result := FDictionary.Keys.FirstOrDefault(ADefault);\r\nend;\r\n\r\nfunction TAbstractBag.Last: T;\r\nbegin\r\n { Use TDictionary's Keys }\r\n Result := FDictionary.Keys.Last();\r\nend;\r\n\r\nfunction TAbstractBag.LastOrDefault(const ADefault: T): T;\r\nbegin\r\n { Use TDictionary's Keys }\r\n Result := FDictionary.Keys.LastOrDefault(ADefault);\r\nend;\r\n\r\nfunction TAbstractBag.Max: T;\r\nbegin\r\n { Use TDictionary's Keys }\r\n Result := FDictionary.Keys.Max();\r\nend;\r\n\r\nfunction TAbstractBag.Min: T;\r\nbegin\r\n { Use TDictionary's Keys }\r\n Result := FDictionary.Keys.Min();\r\nend;\r\n\r\nfunction TAbstractBag.GetCount: NativeInt;\r\nbegin\r\n { Dictionary knows the real count }\r\n Result := FKnownCount;\r\nend;\r\n\r\nfunction TAbstractBag.GetWeight(const AValue: T): NativeUInt;\r\nbegin\r\n { Get the count }\r\n if not FDictionary.TryGetValue(AValue, Result) then\r\n Result := 0;\r\nend;\r\n\r\nfunction TAbstractBag.GetEnumerator: IEnumerator;\r\nvar\r\n LEnumerator: TEnumerator;\r\nbegin\r\n LEnumerator := TEnumerator.Create(Self);\r\n LEnumerator.FDictionaryEnumerator := FDictionary.GetEnumerator();\r\n Result := LEnumerator;\r\nend;\r\n\r\nprocedure TAbstractBag.RemoveWeight(const AValue: T; const AWeight: NativeUInt);\r\nvar\r\n LOldCount: NativeUInt;\r\nbegin\r\n { Check count > 0 }\r\n if AWeight = 0 then\r\n Exit;\r\n\r\n { Check that the key os present in the dictionary first }\r\n if not FDictionary.TryGetValue(AValue, LOldCount) then\r\n Exit;\r\n\r\n if LOldCount < AWeight then\r\n LOldCount := 0\r\n else\r\n LOldCount := LOldCount - AWeight;\r\n\r\n { Update the counts }\r\n if LOldCount = 0 then\r\n FDictionary.Remove(AValue)\r\n else\r\n FDictionary[AValue] := LOldCount;\r\n\r\n Dec(FKnownCount, AWeight);\r\n NotifyCollectionChanged();\r\nend;\r\n\r\nprocedure TAbstractBag.Remove(const AValue: T);\r\nbegin\r\n RemoveWeight(AValue, 1);\r\nend;\r\n\r\nprocedure TAbstractBag.RemoveAllWeight(const AValue: T);\r\nvar\r\n LOldCount: NativeUInt;\r\nbegin\r\n { Check that the key is present in the dictionary first }\r\n if not FDictionary.TryGetValue(AValue, LOldCount) then\r\n Exit;\r\n\r\n FDictionary.Remove(AValue);\r\n\r\n Dec(FKnownCount, LOldCount);\r\n NotifyCollectionChanged();\r\nend;\r\n\r\nprocedure TAbstractBag.SetWeight(const AValue: T; const AWeight: NativeUInt);\r\nvar\r\n LOldValue: NativeUInt;\r\nbegin\r\n { Check count > 0 }\r\n if Count = 0 then\r\n Exit;\r\n\r\n if FDictionary.ContainsKey(AValue) then\r\n begin\r\n LOldValue := FDictionary[AValue];\r\n FDictionary[AValue] := AWeight;\r\n end else\r\n begin\r\n LOldValue := 0;\r\n FDictionary.Add(AValue, AWeight);\r\n end;\r\n\r\n { Change the counts }\r\n FKnownCount := FKnownCount - NativeInt(LOldValue + AWeight);\r\n NotifyCollectionChanged();\r\nend;\r\n\r\nfunction TAbstractBag.Single: T;\r\nbegin\r\n { Use TDictionary's Keys }\r\n Result := FDictionary.Keys.Single();\r\nend;\r\n\r\nfunction TAbstractBag.SingleOrDefault(const ADefault: T): T;\r\nbegin\r\n { Use TDictionary's Keys }\r\n Result := FDictionary.Keys.SingleOrDefault(ADefault);\r\nend;\r\n\r\n{ TAbstractBag.TEnumerator }\r\n\r\nfunction TAbstractBag.TEnumerator.TryMoveNext(out ACurrent: T): Boolean;\r\nbegin\r\n { Repeat until something happens }\r\n while True do\r\n begin\r\n if FCurrentWeight > 0 then\r\n begin\r\n { Decrease the count of the bag item }\r\n Dec(FCurrentWeight);\r\n Result := True;\r\n Break;\r\n end else\r\n begin\r\n Result := FDictionaryEnumerator.MoveNext();\r\n if Result then\r\n FCurrentWeight := FDictionaryEnumerator.Current.Value\r\n else\r\n Break;\r\n end;\r\n end;\r\n\r\n if Result then\r\n ACurrent := FDictionaryEnumerator.Current.Key;\r\nend;\r\n\r\n{ TBag }\r\n\r\nconstructor TBag.Create(const ARules: TRules; const AInitialCapacity: NativeInt);\r\nbegin\r\n FInitialCapacity := AInitialCapacity;\r\n inherited Create(ARules);\r\nend;\r\n\r\nconstructor TBag.Create;\r\nbegin\r\n Create(TRules.Default, CDefaultSize);\r\nend;\r\n\r\nconstructor TBag.Create(const ARules: TRules);\r\nbegin\r\n Create(ARules, CDefaultSize);\r\nend;\r\n\r\nfunction TBag.CreateDictionary(const ARules: TRules): IDictionary;\r\nvar\r\n LNewCapacity: NativeInt;\r\n LDictionary: TDictionary;\r\nbegin\r\n { Create a simple dictionary }\r\n if FInitialCapacity <= 0 then\r\n LNewCapacity := CDefaultSize\r\n else\r\n LNewCapacity := FInitialCapacity;\r\n\r\n LDictionary := TDictionary.Create(ARules, TRules.Default, LNewCapacity);\r\n LDictionary.KeyRemoveNotification := NotifyElementRemoved;\r\n\r\n Result := LDictionary;\r\nend;\r\n\r\n{ TObjectBag }\r\n\r\nprocedure TObjectBag.HandleElementRemoved(const AElement: T);\r\nbegin\r\n if FOwnsObjects then\r\n TObject(AElement).Free;\r\nend;\r\n\r\n{ TSortedBag }\r\n\r\nconstructor TSortedBag.Create;\r\nbegin\r\n Create(TRules.Default, True);\r\nend;\r\n\r\nconstructor TSortedBag.Create(const ARules: TRules);\r\nbegin\r\n Create(ARules, True);\r\nend;\r\n\r\nfunction TSortedBag.CreateDictionary(const ARules: TRules): IDictionary;\r\nvar\r\n LDictionary: TSortedDictionary;\r\nbegin\r\n { Create a sorted dictionary }\r\n LDictionary := TSortedDictionary.Create(ARules, TRules.Default, FAscendingSort);\r\n LDictionary.KeyRemoveNotification := NotifyElementRemoved;\r\n\r\n Result := LDictionary;\r\nend;\r\n\r\nconstructor TSortedBag.Create(const ARules: TRules; const AAscending: Boolean);\r\nbegin\r\n { Call upper constructor }\r\n FAscendingSort := AAscending;\r\n inherited Create(ARules);\r\nend;\r\n\r\n{ TObjectSortedBag }\r\n\r\nprocedure TObjectSortedBag.HandleElementRemoved(const AElement: T);\r\nbegin\r\n if FOwnsObjects then\r\n TObject(AElement).Free;\r\nend;\r\n\r\nend.\r\n\r\n" }, { "path": "Collections/Collections.Base.pas", "content": "(*\r\n* Copyright (c) 2008-2012, Ciobanu Alexandru\r\n* All rights reserved.\r\n*\r\n* Redistribution and use in source and binary forms, with or without\r\n* modification, are permitted provided that the following conditions are met:\r\n* * Redistributions of source code must retain the above copyright\r\n* notice, this list of conditions and the following disclaimer.\r\n* * Redistributions in binary form must reproduce the above copyright\r\n* notice, this list of conditions and the following disclaimer in the\r\n* documentation and/or other materials provided with the distribution.\r\n* * Neither the name of the nor the\r\n* names of its contributors may be used to endorse or promote products\r\n* derived from this software without specific prior written permission.\r\n*\r\n* THIS SOFTWARE IS PROVIDED BY THE AUTHOR ''AS IS'' AND ANY\r\n* EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED\r\n* WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE\r\n* DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY\r\n* DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES\r\n* (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;\r\n* LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND\r\n* ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT\r\n* (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS\r\n* SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.\r\n*)\r\n\r\nunit Collections.Base;\r\ninterface\r\nuses\r\n SysUtils,\r\n TypInfo,\r\n Rtti,\r\n Collections.Dynamic,\r\n Generics.Collections,\r\n Generics.Defaults;\r\n\r\n{$REGION 'Base Collection Interfaces'}\r\ntype\r\n /// The predicate that accepts two input values.\r\n /// The first argument.\r\n /// The second argument.\r\n /// A boolean value that indicates the result of the logical predicate.\r\n TPredicate = reference to function(Arg1: T1; Arg2: T2): Boolean;\r\n\r\n TBalanceAct = (baStart, baLeft, baRight, baLoop, baEnd);\r\n\r\n /// Base interface describing all enumerators in this package.\r\n /// Collections.Base.IEnumerator<T> is implemented by\r\n /// all enumerator objects in this package.\r\n IEnumerator = interface\r\n /// Returns the current element of the enumerated collection.\r\n /// Collections.Base.IEnumerator<T>.GetCurrent is the\r\n /// getter method for the Collections.Base.IEnumerator<T>.Current\r\n /// property. Use the property to obtain the element instead.\r\n /// The current element of the enumerated collection.\r\n function GetCurrent(): T;\r\n\r\n /// Moves the enumerator to the next element of the collection.\r\n /// Collections.Base.IEnumerator<T>.MoveNext is usually\r\n /// called by compiler-generated code. Its purpose is to move the \"pointer\" to the next element in the collection\r\n /// (if there are elements left). Also note that many enumerator implementations may throw various exceptions if the\r\n /// enumerated collections were changed in the meantime.\r\n /// True if the enumerator successfully selected the next element; False if there are\r\n /// no more elements to be enumerated.\r\n function MoveNext(): Boolean;\r\n\r\n /// Returns the current element of the traversed collection.\r\n /// Collections.Base.IEnumerator<T>.Current can only return a\r\n /// valid element if Collections.Base.IEnumerator<T>.MoveNext was\r\n /// priorly called and returned True; otherwise the behavior of this property is undefined. Note that many enumerator implementations\r\n /// may throw exceptions if the collection was changed in the meantime.\r\n /// \r\n /// The current element of the enumerator collection.\r\n property Current: T read GetCurrent;\r\n end;\r\n\r\n /// Base interface describing all enumerable collections in this package.\r\n /// Collections.Base.IEnumerable<T> is implemented by all\r\n /// enumerable collections in this package.\r\n IEnumerable = interface\r\n /// Returns a Collections.Base.IEnumerator<T> interface that is used\r\n /// to enumerate the collection.\r\n /// Collections.Base.IEnumerable<T>.MoveNext is usually\r\n /// called by compiler-generated code. Its purpose is to create an enumerator object that is used to actually traverse\r\n /// the collections.\r\n /// Note that many collections generate enumerators that depend on the state of the collection. If the collection is changed\r\n /// after the Collections.Base.IEnumerator<T> had been obtained,\r\n /// Collections.Base.ECollectionChangedException is thrown.\r\n /// The Collections.Base.IEnumerator<T> interface.\r\n function GetEnumerator(): IEnumerator;\r\n end;\r\n\r\n /// A special record designed to hold both a comparer and an equality\r\n /// comparer. All collections require this type in order to function properly.\r\n /// The collection provided in this package provides extended functionality (Enex), which\r\n /// implies comparing values in many circumstances, which requires the presence of the comparer.\r\n /// Some collections need an additional equality comparer. This type is meant to provide both\r\n /// on the need basis.\r\n TRules = record\r\n private\r\n FComparer: IComparer;\r\n FEqComparer: IEqualityComparer;\r\n\r\n public\r\n /// Initializes a rule set with the given comparers.\r\n /// The comparer.\r\n /// The equality comparer.\r\n /// A rule set initialized with the provided comparers.\r\n /// if is nil.\r\n /// if is nil.\r\n class function Create(const AComparer: IComparer; const AEqualityComparer: IEqualityComparer): TRules; static;\r\n\r\n /// Initializes a rule set with a given custom comparer.\r\n /// The custom comparer.\r\n /// A rule set initialized with the custom comparer.\r\n /// if is nil.\r\n class function Custom(const AComparer: TCustomComparer): TRules; static;\r\n\r\n /// Initializes a rule set using default comparers.\r\n /// A rule set initialized with the default comparers.\r\n class function Default: TRules; static;\r\n end;\r\n\r\n /// Base interface inherited by all specific collection interfaces.\r\n /// This interface defines a set of traits common to all collections implemented in this package.\r\n IContainer = interface(IEnumerable)\r\n /// Returns the current version of the collection.\r\n /// An integer value specifying the current \"structural version\" of the collection.\r\n /// This function returns a number that is modified by the implementing collection each time\r\n /// the collection changes. This version can be used to identify if a collection has chnaged since last time it was used\r\n /// in a specific piece of code.\r\n function Version(): NativeInt;\r\n\r\n /// Returns the number of elements in the collection.\r\n /// A positive value specifying the number of elements in the collection.\r\n /// For associative collections such as dictionaries or multimaps, this value represents the\r\n /// number of key-value pairs stored in the collection. A call to this method can be costly because some\r\n /// collections cannot detect the number of stored elements directly, resorting to enumerating themselves.\r\n function GetCount(): NativeInt;\r\n\r\n /// Checks whether the collection is empty.\r\n /// True if the collection is empty; False otherwise.\r\n /// This method is the recommended way of detecting if the collection is empty. It is optimized\r\n /// in most collections to offer a fast response.\r\n function Empty(): Boolean;\r\n\r\n /// Returns the single element stored in the collection.\r\n /// The element in the collection.\r\n /// This method checks whether the collection contains just one element, in which case it is returned.\r\n /// The collection is empty.\r\n /// There is more than one element in the collection.\r\n function Single(): T;\r\n\r\n /// Returns the single element stored in the collection, or a default value.\r\n /// The default value returned if there is less or more elements in the collection.\r\n /// The element in the collection if the condition is satisfied; is returned otherwise.\r\n /// This method checks whether the collection contains just one element, in which case it is returned. Otherwise\r\n /// the value in is returned.\r\n function SingleOrDefault(const ADefault: T): T;\r\n\r\n /// Copies the values stored in the collection to a given array.\r\n /// An array where to copy the contents of the collection.\r\n /// This method assumes that has enough space to hold the contents of the collection.\r\n /// The array is not long enough.\r\n procedure CopyTo(var AArray: array of T); overload;\r\n\r\n /// Copies the values stored in the collection to a given array.\r\n /// An array where to copy the contents of the collection.\r\n /// The index into the array at which the copying begins.\r\n /// This method assumes that has enough space to hold the contents of the collection.\r\n /// is out of bounds.\r\n /// The array is not long enough.\r\n procedure CopyTo(var AArray: array of T; const AStartIndex: NativeInt); overload;\r\n\r\n /// Creates a new Delphi array with the contents of the collection.\r\n /// The length of the new array is equal to the value of the Count property.\r\n function ToArray(): TArray;\r\n\r\n /// Specifies the number of elements in the collection.\r\n /// A positive value specifying the number of elements in the collection.\r\n /// For associative collections such as dictionaries or multimaps, this value represents the\r\n /// number of key-value pairs stored in the collection. Accesing this property can be costly because some\r\n /// collections cannot detect the number of stored elements directly, resorting to enumerating themselves.\r\n property Count: NativeInt read GetCount;\r\n end;\r\n\r\n { Pre-declarations }\r\n IList = interface;\r\n ISet = interface;\r\n IDictionary = interface;\r\n ISequence = interface;\r\n IGrouping = interface;\r\n\r\n /// Offers an extended set of Enex operations.\r\n /// This type is exposed by Enex collections, and serves simply as a bridge between the interfaces\r\n /// and some advanced operations that require parameterized methods. For example, expressions such as\r\n /// List.Op.Select<Integer> are based on this type.\r\n TEnexExtOps = record\r\n private\r\n FRules: TRules;\r\n FInstance: Pointer;\r\n FKeepAlive: IInterface;\r\n\r\n public\r\n /// Represents a \"select\" operation.\r\n /// A selector method invoked for each element in the collection.\r\n /// A rule set representing the elements in the output collection.\r\n /// A new collection containing the selected values.\r\n /// This method is used when it is required to select values related to the ones in the operated collection.\r\n /// For example, you can select a collection of integers where each integer is a field of a class in the original collection.\r\n /// is nil.\r\n /// is nil.\r\n function Select(const ASelector: TFunc; const ARules: TRules): ISequence; overload;\r\n\r\n /// Represents a \"select\" operation.\r\n /// A selector method invoked for each element in the collection.\r\n /// A new collection containing the selected values.\r\n /// This method is used when it is required to select values related to the ones in the operated collection.\r\n /// For example, you can select a collection of integers where each integer is a field of a class in the original collection.\r\n /// is nil.\r\n function Select(const ASelector: TFunc): ISequence; overload;\r\n\r\n{$IF CompilerVersion > 21}\r\n /// Represents a \"select\" operation.\r\n /// A record or class field/property name that will be selected.\r\n /// A new collection containing the selected values.\r\n /// This method will only work for classes and record types!\r\n /// is not a real member of record or class.\r\n /// The collection's elements are not objects ore records.\r\n function Select(const AMemberName: string): ISequence; overload;\r\n\r\n /// Represents a \"select\" operation.\r\n /// A record or class field/property name that will be selected.\r\n /// A new collection containing the selected values represented as Rtti TValues.\r\n /// This method will only work for classes and record types!\r\n /// is not a real member of record or class.\r\n /// The collection's elements are not objects ore records.\r\n function Select(const AMemberName: string): ISequence; overload;\r\n\r\n /// Represents a \"select\" operation.\r\n /// A record or class field/property names that will be selected.\r\n /// A new collection containing the selected values represented as a view.\r\n /// This method will only work for classes and record types! The resulting view contains the selected members.\r\n /// is not a real member of record or class.\r\n /// The collection's elements are not objects ore records.\r\n function Select(const AMemberNames: array of string): ISequence; overload;\r\n{$IFEND}\r\n\r\n /// Represents a \"where, select object\" operation.\r\n /// A new collection containing the selected values.\r\n /// This method can be used on a collection containing objects. The operation involves two steps,\r\n /// where and select. First, each object is checked to be derived from TOut. If that is true, it is then\r\n /// cast to TOut. The result of the operation is a new collection that contains only the objects of a given\r\n /// class. For example, AList.Op.Select<TMyObject> results in a new collection that only contains\r\n /// \"TMyObject\" instances.\r\n /// The collection's elements are not objects.\r\n function Select(): ISequence; overload;\r\n\r\n /// Groups all elements in the collection by a given key.\r\n /// The selector function. Returns the key (based on each collection element) that serves for grouping purposes.\r\n /// A collection of grouping collections.\r\n /// is nil.\r\n /// This operation will call for each element in the collection and retrieve a \"key\". Using this key,\r\n /// the elements are grouped into new collections called groupings. The result of this operation is a collection of groupings. Each grouping\r\n /// contains the elements from the original collection that have the same group and a key (which is the group value used).\r\n function GroupBy(const ASelector: TFunc): ISequence>; overload;\r\n\r\n /// Orders the collection based on selector method.\r\n /// The selector function. Returns the key (based on each collection element) that serves for ordering purposes.\r\n /// The resulting ordered collection.\r\n /// is nil.\r\n /// This operation will call for each element in the collection and retrieve a \"key\". Using this key,\r\n /// the elements are ordered into a new collection.\r\n function OrderBy(const ASelector: TFunc): ISequence; overload;\r\n\r\n /// Orders the collection based on selector method.\r\n /// The selector function for the first key. Returns the key (based on each collection element) that serves for ordering purposes.\r\n /// The selector function for the second key. Returns the key (based on each collection element) that serves for ordering purposes.\r\n /// The resulting ordered collection.\r\n /// is nil.\r\n /// is nil.\r\n /// This operation will call each for elements in the collection and retrieve the ordering \"keys\". Using these keys,\r\n /// the elements are ordered into a new collection.\r\n function OrderBy(const ASelector1: TFunc; const ASelector2: TFunc): ISequence; overload;\r\n\r\n /// Orders the collection based on selector method.\r\n /// The selector function for the first key. Returns the key (based on each collection element) that serves for ordering purposes.\r\n /// The selector function for the second key. Returns the key (based on each collection element) that serves for ordering purposes.\r\n /// The selector function for the third key. Returns the key (based on each collection element) that serves for ordering purposes.\r\n /// The resulting ordered collection.\r\n /// is nil.\r\n /// is nil.\r\n /// is nil.\r\n /// This operation will call each for elements in the collection and retrieve the ordering \"keys\". Using these keys,\r\n /// the elements are ordered into a new collection.\r\n function OrderBy(const ASelector1: TFunc; const ASelector2: TFunc;\r\n const ASelector3: TFunc): ISequence; overload;\r\n\r\n /// Orders the collection based on selector method.\r\n /// The selector function for the first key. Returns the key (based on each collection element) that serves for ordering purposes.\r\n /// The selector function for the second key. Returns the key (based on each collection element) that serves for ordering purposes.\r\n /// The selector function for the third key. Returns the key (based on each collection element) that serves for ordering purposes.\r\n /// The selector function for the fourth key. Returns the key (based on each collection element) that serves for ordering purposes.\r\n /// The resulting ordered collection.\r\n /// is nil.\r\n /// is nil.\r\n /// is nil.\r\n /// is nil.\r\n /// This operation will call each for elements in the collection and retrieve the ordering \"keys\". Using these keys,\r\n /// the elements are ordered into a new collection.\r\n function OrderBy(const ASelector1: TFunc; const ASelector2: TFunc;\r\n const ASelector3: TFunc; const ASelector4: TFunc): ISequence; overload;\r\n\r\n /// Orders the collection based on selector method.\r\n /// The selector function for the first key. Returns the key (based on each collection element) that serves for ordering purposes.\r\n /// The selector function for the second key. Returns the key (based on each collection element) that serves for ordering purposes.\r\n /// The selector function for the third key. Returns the key (based on each collection element) that serves for ordering purposes.\r\n /// The selector function for the fourth key. Returns the key (based on each collection element) that serves for ordering purposes.\r\n /// The selector function for the fifth key. Returns the key (based on each collection element) that serves for ordering purposes.\r\n /// The resulting ordered collection.\r\n /// is nil.\r\n /// is nil.\r\n /// is nil.\r\n /// is nil.\r\n /// is nil.\r\n /// This operation will call each for elements in the collection and retrieve the ordering \"keys\". Using these keys,\r\n /// the elements are ordered into a new collection.\r\n function OrderBy(const ASelector1: TFunc; const ASelector2: TFunc;\r\n const ASelector3: TFunc; const ASelector4: TFunc; const ASelector5: TFunc): ISequence; overload;\r\n\r\n /// Joins this sequence with another enumerable collection using a common key.\r\n /// The inner collection to join with.\r\n /// The selector function for the key of this collection.\r\n /// The selector function for the key of the inner collection.\r\n /// The selector function that combines the result.\r\n /// The resulting joined collection.\r\n /// is nil.\r\n /// This operation will enumerate the collection and extract the key for each element. For each key it will try to\r\n /// pair up the element with elements in the AInner collection. This function can also be considered an \"INNER JOIN\" where the elements in the outer\r\n /// collection are paired up with elements in the inner collection by the means of a common key (provided by the selector functions).\r\n function Join(const AInner: IEnumerable; const AKeySelector: TFunc;\r\n const AInnerKeySelector: TFunc; const AResultSelector: TFunc): ISequence; overload;\r\n\r\n /// Joins ang groups this sequence with another enumerable collection using a common key.\r\n /// The inner collection to join with.\r\n /// The selector function for the key of this collection.\r\n /// The selector function for the key of the inner collection.\r\n /// The selector function that combines the result.\r\n /// The resulting joined collection.\r\n /// is nil.\r\n /// This operation will enumerate the collection and extract the key for each element. For each key it will try to\r\n /// pair up the element with elements in the AInner collection; and generate a group of elements.\r\n function GroupJoin(const AInner: IEnumerable; const AKeySelector: TFunc;\r\n const AInnerKeySelector: TFunc; const AResultSelector: TFunc, TResult>): ISequence; overload;\r\n end;\r\n\r\n /// Base sequence interface inherited by all specific collection interfaces.\r\n /// This interface defines a set of traits common to all collections implemented in this package. It also introduces\r\n /// a large set of extended operations that can be performed on any collection that supports enumerability.\r\n ISequence = interface(IContainer)\r\n /// Checks whether the elements in this collection are equal to the elements in another collection.\r\n /// The collection to compare to.\r\n /// True if the collections are equal; False if the collections are different.\r\n /// This method checks that each element at position X in this collection is equal to an element at position X in\r\n /// the provided collection. If the number of elements in both collections is different, then the collections are considered different.\r\n /// Note that comparison of element is done using the rule set used by this collection. This means that comparing this collection\r\n /// to another one might yield a different result than comparing the other collection to this one.\r\n /// is nil.\r\n function EqualsTo(const ACollection: IEnumerable): Boolean;\r\n\r\n /// Creates a new list containing the elements of this collection.\r\n /// A list containing the elements copied from this collection.\r\n /// This method also copies the rule set of this collection. Be careful if the rule set\r\n /// performs cleanup on the elements.\r\n function ToList(): IList;\r\n\r\n /// Creates a new set containing the elements of this collection.\r\n /// A set containing the elements copied from this collection.\r\n /// This method also copies the rule set of this collection. Be careful if the rule set\r\n /// performs cleanup on the elements.\r\n function ToSet(): ISet;\r\n\r\n /// Returns the biggest element.\r\n /// An element from the collection considered to have the biggest value.\r\n /// The collection is empty.\r\n function Max(): T;\r\n\r\n /// Returns the smallest element.\r\n /// An element from the collection considered to have the smallest value.\r\n /// The collection is empty.\r\n function Min(): T;\r\n\r\n /// Returns the first element.\r\n /// The first element in the collection.\r\n /// The collection is empty.\r\n function First(): T;\r\n\r\n /// Returns the first element or a default if the collection is empty.\r\n /// The default value returned if the collection is empty.\r\n /// The first element in the collection if the collection is not empty; otherwise is returned.\r\n function FirstOrDefault(const ADefault: T): T;\r\n\r\n /// Returns the first element that satisfies the given predicate.\r\n /// The predicate to use.\r\n /// The first element that satisfies the given predicate.\r\n /// The collection is empty.\r\n /// No elements satisfy the predicate.\r\n /// is nil.\r\n function FirstWhere(const APredicate: TPredicate): T;\r\n\r\n /// Returns the first element that satisfies the given predicate or a default value.\r\n /// The predicate to use.\r\n /// The default value.\r\n /// The first element that satisfies the given predicate; otherwise.\r\n /// is nil.\r\n function FirstWhereOrDefault(const APredicate: TPredicate; const ADefault: T): T;\r\n\r\n /// Returns the first element that does not satisfy the given predicate.\r\n /// The predicate to use.\r\n /// The first element that does not satisfy the given predicate.\r\n /// The collection is empty.\r\n /// No elements that do not satisfy the predicate.\r\n /// is nil.\r\n function FirstWhereNot(const APredicate: TPredicate): T;\r\n\r\n /// Returns the first element that does not satisfy the given predicate or a default value.\r\n /// The predicate to use.\r\n /// The default value.\r\n /// The first element that does not satisfy the given predicate; otherwise.\r\n /// is nil.\r\n function FirstWhereNotOrDefault(const APredicate: TPredicate; const ADefault: T): T;\r\n\r\n /// Returns the first element lower than a given value.\r\n /// The value to compare against.\r\n /// The first element that satisfies the given condition.\r\n /// The collection is empty.\r\n /// No elements satisfy the condition.\r\n function FirstWhereLower(const ABound: T): T;\r\n\r\n /// Returns the first element lower than a given value or a default.\r\n /// The value to compare against.\r\n /// The default value.\r\n /// The first element that satisfies the given condition; otherwise.\r\n /// The collection is empty.\r\n /// No elements satisfy the condition.\r\n function FirstWhereLowerOrDefault(const ABound: T; const ADefault: T): T;\r\n\r\n /// Returns the first element lower than or equal to a given value.\r\n /// The value to compare against.\r\n /// The first element that satisfies the given condition.\r\n /// The collection is empty.\r\n /// No elements satisfy the condition.\r\n function FirstWhereLowerOrEqual(const ABound: T): T;\r\n\r\n /// Returns the first element lower than or equal to a given value or a default.\r\n /// The value to compare against.\r\n /// The default value.\r\n /// The first element that satisfies the given condition; otherwise.\r\n /// The collection is empty.\r\n /// No elements satisfy the condition.\r\n function FirstWhereLowerOrEqualOrDefault(const ABound: T; const ADefault: T): T;\r\n\r\n /// Returns the first element greater than a given value.\r\n /// The value to compare against.\r\n /// The first element that satisfies the given condition.\r\n /// The collection is empty.\r\n /// No elements satisfy the condition.\r\n function FirstWhereGreater(const ABound: T): T;\r\n\r\n /// Returns the first element greater than a given value or a default.\r\n /// The value to compare against.\r\n /// The default value.\r\n /// The first element that satisfies the given condition; otherwise.\r\n /// The collection is empty.\r\n /// No elements satisfy the condition.\r\n function FirstWhereGreaterOrDefault(const ABound: T; const ADefault: T): T;\r\n\r\n /// Returns the first element greater than or equal to a given value.\r\n /// The value to compare against.\r\n /// The first element that satisfies the given condition.\r\n /// The collection is empty.\r\n /// No elements satisfy the condition.\r\n function FirstWhereGreaterOrEqual(const ABound: T): T;\r\n\r\n /// Returns the first element greater than or equal to a given value or a default.\r\n /// The value to compare against.\r\n /// The default value.\r\n /// The first element that satisfies the given condition; otherwise.\r\n /// The collection is empty.\r\n /// No elements satisfy the condition.\r\n function FirstWhereGreaterOrEqualOrDefault(const ABound: T; const ADefault: T): T;\r\n\r\n /// Returns the first element situated within the given bounds.\r\n /// The lower bound.\r\n /// The higher bound.\r\n /// The first element that satisfies the given condition.\r\n /// The collection is empty.\r\n /// No elements satisfy the condition.\r\n function FirstWhereBetween(const ALower, AHigher: T): T;\r\n\r\n /// Returns the first element situated within the given bounds or a default.\r\n /// The lower bound.\r\n /// The higher bound.\r\n /// The default value.\r\n /// The first element that satisfies the given condition; otherwise.\r\n /// The collection is empty.\r\n /// No elements satisfy the condition.\r\n function FirstWhereBetweenOrDefault(const ALower, AHigher: T; const ADefault: T): T;\r\n\r\n /// Returns the last element.\r\n /// The last element in the collection.\r\n /// The collection is empty.\r\n function Last(): T;\r\n\r\n /// Returns the last element or a default if the collection is empty.\r\n /// The default value returned if the collection is empty.\r\n /// The last element in the collection if the collection is not empty; otherwise is returned.\r\n function LastOrDefault(const ADefault: T): T;\r\n\r\n /// Aggregates a value based on the collection's elements.\r\n /// The aggregator method.\r\n /// A value that contains the collection's aggregated value.\r\n /// This method returns the first element if the collection only has one element. Otherwise,\r\n /// is invoked for each two elements (first and second; then the result of the first two\r\n /// and the third, and so on). The simplest example of aggregation is the \"sum\" operation where you can obtain the sum of all\r\n /// elements in the value.\r\n /// is nil.\r\n /// The collection is empty.\r\n function Aggregate(const AAggregator: TFunc): T;\r\n\r\n /// Aggregates a value based on the collection's elements.\r\n /// The aggregator method.\r\n /// The default value returned if the collection is empty.\r\n /// A value that contains the collection's aggregated value. If the collection is empty, is returned.\r\n /// This method returns the first element if the collection only has one element. Otherwise,\r\n /// is invoked for each two elements (first and second; then the result of the first two\r\n /// and the third, and so on). The simplest example of aggregation is the \"sum\" operation where you can obtain the sum of all\r\n /// elements in the value.\r\n /// is nil.\r\n function AggregateOrDefault(const AAggregator: TFunc; const ADefault: T): T;\r\n\r\n /// Returns the element at a given position.\r\n /// The index from which to return the element.\r\n /// The element at the specified position.\r\n /// This method is slow for collections that cannot reference their elements by indexes; for example: linked lists\r\n /// The collection is empty.\r\n /// is out of bounds.\r\n function ElementAt(const AIndex: NativeInt): T;\r\n\r\n /// Returns the element at a given position.\r\n /// The index from which to return the element.\r\n /// The default value returned if the collection is empty.\r\n /// The element at the specified position if the collection is not empty and the position is not out of bounds; otherwise\r\n /// the value of is returned.\r\n /// This method is slow for collections that cannot reference their elements by indexes; for example: linked lists\r\n function ElementAtOrDefault(const AIndex: NativeInt; const ADefault: T): T;\r\n\r\n /// Check whether at least one element in the collection satisfies a given predicate.\r\n /// The predicate to check for each element.\r\n /// True if the at least one element satisfies a given predicate; False otherwise.\r\n /// This method traverses the whole collection and checks the value of the predicate for each element. This method\r\n /// stops on the first element for which the predicate returns True. The logical equivalent of this operation is \"OR\".\r\n /// is nil.\r\n function Any(const APredicate: TPredicate): Boolean;\r\n\r\n /// Checks that all elements in the collection satisfies a given predicate.\r\n /// The predicate to check for each element.\r\n /// True if all elements satisfy a given predicate; False otherwise.\r\n /// This method traverses the whole collection and checks the value of the predicate for each element. This method\r\n /// stops on the first element for which the predicate returns False. The logical equivalent of this operation is \"AND\".\r\n /// is nil.\r\n function All(const APredicate: TPredicate): Boolean;\r\n\r\n /// Selects only the elements that satisfy a given rule.\r\n /// The predicate that represents the rule.\r\n /// A new collection that contains only the elements that satisfy the given rule.\r\n /// is nil.\r\n function Where(const APredicate: TPredicate): ISequence;\r\n\r\n /// Selects only the elements that do not satisfy a given rule.\r\n /// The predicate that represents the rule.\r\n /// A new collection that contains only the elements that do not satisfy the given rule.\r\n /// is nil.\r\n function WhereNot(const APredicate: TPredicate): ISequence;\r\n\r\n /// Selects only the elements that are less than a given value.\r\n /// The element to compare against.\r\n /// A new collection that contains only the elements that satisfy the relationship.\r\n function WhereLower(const ABound: T): ISequence;\r\n\r\n /// Selects only the elements that are less than or equal to a given value.\r\n /// The element to compare against.\r\n /// A new collection that contains only the elements that satisfy the relationship.\r\n function WhereLowerOrEqual(const ABound: T): ISequence;\r\n\r\n /// Selects only the elements that are greater than a given value.\r\n /// The element to compare against.\r\n /// A new collection that contains only the elements that satisfy the relationship.\r\n function WhereGreater(const ABound: T): ISequence;\r\n\r\n /// Selects only the elements that are greater than or equal to a given value.\r\n /// The element to compare against.\r\n /// A new collection that contains only the elements that satisfy the relationship.\r\n function WhereGreaterOrEqual(const ABound: T): ISequence;\r\n\r\n /// Selects only the elements whose values are contained whithin a given interval.\r\n /// The lower bound.\r\n /// The upper bound.\r\n /// A new collection that contains only the elements that satisfy the relationship.\r\n /// The elements that are equal to the lower or upper bounds, are also included.\r\n function WhereBetween(const ALower, AHigher: T): ISequence;\r\n\r\n /// Selects all the elements from the collection excluding duplicates.\r\n /// A new collection that contains the distinct elements.\r\n function Distinct(): ISequence;\r\n\r\n /// Returns a new ordered collection that contains the elements from this collection.\r\n /// Specifies whether the elements are ordered ascending or descending.\r\n /// A new ordered collection.\r\n function Ordered(const AAscending: Boolean = true): ISequence; overload;\r\n\r\n /// Returns a new ordered collection that contains the elements from this collection.\r\n /// The comparison method.\r\n /// A new ordered collection.\r\n /// is nil.\r\n function Ordered(const ASortProc: TComparison): ISequence; overload;\r\n\r\n /// Revereses the contents of the collection.\r\n /// A new collection that contains the elements from this collection but in reverse order.\r\n function Reversed(): ISequence;\r\n\r\n /// Concatenates this collection with another collection.\r\n /// A collection to concatenate.\r\n /// A new collection that contains the elements from this collection followed by elements\r\n /// from the given collection.\r\n /// is nil.\r\n function Concat(const ACollection: ISequence): ISequence;\r\n\r\n /// Creates a new collection that contains the elements from both collections taken a single time.\r\n /// The collection to unify with.\r\n /// A new collection that contains the elements from this collection followed by elements\r\n /// from the given collection except the elements that already are present in this collection. This operation can be seen as\r\n /// a \"concat\" operation followed by a \"distinct\" operation. \r\n /// is nil.\r\n function Union(const ACollection: ISequence): ISequence;\r\n\r\n /// Creates a new collection that contains the elements from this collection minus the ones in the given collection.\r\n /// The collection to exclude.\r\n /// A new collection that contains the elements from this collection minus the those elements that are common between\r\n /// this and the given collection.\r\n /// is nil.\r\n function Exclude(const ACollection: ISequence): ISequence;\r\n\r\n /// Creates a new collection that contains the elements that are present in both collections.\r\n /// The collection to interset with.\r\n /// A new collection that contains the elements that are common to both collections.\r\n /// is nil.\r\n function Intersect(const ACollection: ISequence): ISequence;\r\n\r\n /// Select the elements that whose indexes are located in the given range.\r\n /// The lower bound.\r\n /// The upper bound.\r\n /// A new collection that contains the elements whose indexes in this collection are locate between \r\n /// and . Note that this method does not check the indexes. This means that a bad combination of parameters will\r\n /// simply result in an empty or incorrect result.\r\n function Range(const AStart, AEnd: NativeInt): ISequence;\r\n\r\n /// Selects only a given amount of elements.\r\n /// The number of elements to select.\r\n /// A new collection that contains only the first elements.\r\n /// is zero.\r\n function Take(const ACount: NativeInt): ISequence;\r\n\r\n /// Selects all the elements from the collection while a given rule is satisfied.\r\n /// The rule to satisfy.\r\n /// A new collection that contains the selected elements.\r\n /// This method selects all elements from the collection while the given rule is satisfied.\r\n /// is nil.\r\n function TakeWhile(const APredicate: TPredicate): ISequence;\r\n\r\n /// Selects all the elements from the collection while elements are lower than a given value.\r\n /// The value to check against.\r\n /// A new collection that contains the selected elements.\r\n /// This method selects all elements from the collection while the given rule is satisfied.\r\n function TakeWhileLower(const ABound: T): ISequence;\r\n\r\n /// Selects all the elements from the collection while elements are lower than\r\n /// or equals to a given value.\r\n /// The value to check against.\r\n /// A new collection that contains the selected elements.\r\n /// This method selects all elements from the collection while the given rule is satisfied.\r\n function TakeWhileLowerOrEqual(const ABound: T): ISequence;\r\n\r\n /// Selects all the elements from the collection while elements are greater than\r\n /// a given value.\r\n /// The value to check against.\r\n /// A new collection that contains the selected elements.\r\n /// This method selects all elements from the collection while the given rule is satisfied.\r\n function TakeWhileGreater(const ABound: T): ISequence;\r\n\r\n /// Selects all the elements from the collection while elements are greater than\r\n /// or equals to a given value.\r\n /// The value to check against.\r\n /// A new collection that contains the selected elements.\r\n /// This method selects all elements from the collection while the given rule is satisfied.\r\n function TakeWhileGreaterOrEqual(const ABound: T): ISequence;\r\n\r\n /// Selects all the elements from the collection while elements are between a given range of values.\r\n /// The lower bound.\r\n /// The higher bound.\r\n /// A new collection that contains the selected elements.\r\n /// This method selects all elements from the collection while the given rule is satisfied.\r\n function TakeWhileBetween(const ALower, AHigher: T): ISequence;\r\n\r\n /// Skips a given amount of elements.\r\n /// The number of elements to skip.\r\n /// A new collection that contains the elements that were not skipped.\r\n /// is zero.\r\n function Skip(const ACount: NativeInt): ISequence;\r\n\r\n /// Skips all the elements from the collection while a given rule is satisfied.\r\n /// The rule to satisfy.\r\n /// A new collection that contains the elements that were not skipped.\r\n /// is nil.\r\n function SkipWhile(const APredicate: TPredicate): ISequence;\r\n\r\n /// Skips all the elements from the collection while elements are lower than a given value.\r\n /// The value to check.\r\n /// A new collection that contains the elements that were not skipped.\r\n function SkipWhileLower(const ABound: T): ISequence;\r\n\r\n /// Skips all the elements from the collection while elements are lower than or equal to a given value.\r\n /// The value to check.\r\n /// A new collection that contains the elements that were not skipped.\r\n function SkipWhileLowerOrEqual(const ABound: T): ISequence;\r\n\r\n /// Skips all the elements from the collection while elements are greater than a given value.\r\n /// The value to check.\r\n /// A new collection that contains the elements that were not skipped.\r\n function SkipWhileGreater(const ABound: T): ISequence;\r\n\r\n /// Skips all the elements from the collection while elements are greater than or equal to a given value.\r\n /// The value to check.\r\n /// A new collection that contains the elements that were not skipped.\r\n function SkipWhileGreaterOrEqual(const ABound: T): ISequence;\r\n\r\n /// Skips all the elements from the collection while elements are between a given range of values.\r\n /// The lower bound.\r\n /// The higher bound.\r\n /// A new collection that contains the elements that were not skipped.\r\n function SkipWhileBetween(const ALower, AHigher: T): ISequence;\r\n\r\n /// Exposes a type that provides extended Enex operations such as \"select\".\r\n /// A record that exposes more Enex operations that otherwise would be impossible.\r\n function Op: TEnexExtOps;\r\n end;\r\n\r\n /// Enex collection that is presumed to be grouped by a certain key.\r\n IGrouping = interface(ISequence)\r\n /// Returns the key under which all elements in this collection are grouped.\r\n /// The key of this grouping.\r\n function GetKey(): TKey;\r\n\r\n /// Returns the key under which all elements in this collection are grouped.\r\n /// The key of this grouping.\r\n property Key: TKey read GetKey;\r\n end;\r\n\r\n /// Specifies a set of methods specific to all simple (non-associative) collections.\r\n /// This collection exposes operations such as Add or Clear that need to be implemented\r\n /// in almost every class out there.\r\n ICollection = interface(ISequence)\r\n /// Clears the contents of this collection.\r\n procedure Clear();\r\n\r\n /// Adds an element to this collection.\r\n /// The value to add.\r\n /// Where exactly the element is added is unspecified and depends on the implementing collection.\r\n procedure Add(const AValue: T);\r\n\r\n /// Adds all the elements from a collection to this collection.\r\n /// The values to add.\r\n /// Where exactly the elements are added is unspecified and depends on the implementing collection.\r\n /// is nil.\r\n procedure AddAll(const ACollection: IEnumerable);\r\n\r\n /// Removes an element from this collection.\r\n /// The value to remove. If there is no such element in the collection, nothing happens.\r\n procedure Remove(const AValue: T); overload;\r\n\r\n /// Removes all the elements from a collection that are also found in this collection.\r\n /// The values to remove.\r\n /// is nil.\r\n procedure RemoveAll(const ACollection: IEnumerable);\r\n\r\n /// Checks whether a specified element is contained in this collection.\r\n /// The value to check for.\r\n /// True if the value was found in the collection; False otherwise.\r\n function Contains(const AValue: T): Boolean; overload;\r\n\r\n /// Checks whether all the elements from a specified collection are contained in this collection.\r\n /// The value to check for.\r\n /// True if the values were found in the collection; False otherwise.\r\n function ContainsAll(const ACollection: IEnumerable): Boolean;\r\n end;\r\n\r\n /// Base Enex (Extended enumerable) interface inherited by all specific associative collection interfaces.\r\n /// This interface defines a set of traits common to all associative collections implemented in this package. It also introduces\r\n /// a large se of extended operations that can pe performed on any collection that supports enumerability.\r\n IAssociation = interface(IContainer>)\r\n /// Creates a new dictionary containing the elements of this collection.\r\n /// A dictionary containing the elements copied from this collection.\r\n /// This method also copies the rule sets of this collection. Be careful if the rule set\r\n /// performs cleanup on the elements.\r\n /// The collection contains more than\r\n /// one key-value pair with the same key.\r\n function ToDictionary(): IDictionary;\r\n\r\n /// Returns the value associated with the given key.\r\n /// The key for which to return the associated value.\r\n /// The value associated with the given key.\r\n /// No such key in the collection.\r\n function ValueForKey(const AKey: TKey): TValue;\r\n\r\n /// Checks whether the collection contains a given key-value pair.\r\n /// The key part of the pair.\r\n /// The value part of the pair.\r\n /// True if the given key-value pair exists; False otherwise.\r\n function KeyHasValue(const AKey: TKey; const AValue: TValue): Boolean;\r\n\r\n /// Returns the biggest key.\r\n /// The biggest key stored in the collection.\r\n /// The collection is empty.\r\n function MaxKey(): TKey;\r\n\r\n /// Returns the smallest key.\r\n /// The smallest key stored in the collection.\r\n /// The collection is empty.\r\n function MinKey(): TKey;\r\n\r\n /// Returns the biggest value.\r\n /// The biggest value stored in the collection.\r\n /// The collection is empty.\r\n function MaxValue(): TValue;\r\n\r\n /// Returns the smallest value.\r\n /// The smallest value stored in the collection.\r\n /// The collection is empty.\r\n function MinValue(): TValue;\r\n\r\n /// Returns an Enex collection that contains only the keys.\r\n /// An Enex collection that contains all the keys stored in the collection.\r\n function SelectKeys(): ISequence;\r\n\r\n /// Returns a Enex collection that contains only the values.\r\n /// An Enex collection that contains all the values stored in the collection.\r\n function SelectValues(): ISequence;\r\n\r\n /// Specifies the collection that contains only the keys.\r\n /// An Enex collection that contains all the keys stored in the collection.\r\n property Keys: ISequence read SelectKeys;\r\n\r\n /// Specifies the collection that contains only the values.\r\n /// An Enex collection that contains all the values stored in the collection.\r\n property Values: ISequence read SelectValues;\r\n\r\n /// Selects all the key-value pairs from the collection excluding the duplicates by key.\r\n /// A new collection that contains the distinct pairs.\r\n function DistinctByKeys(): IAssociation;\r\n\r\n /// Selects all the key-value pairs from the collection excluding the duplicates by value.\r\n /// A new collection that contains the distinct pairs.\r\n function DistinctByValues(): IAssociation;\r\n\r\n /// Checks whether this collection includes the key-value pairs in another collection.\r\n /// The collection to check against.\r\n /// True if this collection includes the elements in another; False otherwise.\r\n function Includes(const ACollection: IEnumerable>): Boolean;\r\n\r\n /// Selects only the key-value pairs that satisfy a given rule.\r\n /// The predicate that represents the rule.\r\n /// A new collection that contains only the pairs that satisfy the given rule.\r\n /// is nil.\r\n function Where(const APredicate: TPredicate): IAssociation;\r\n\r\n /// Selects only the key-value pairs that do not satisfy a given rule.\r\n /// The predicate that represents the rule.\r\n /// A new collection that contains only the pairs that do not satisfy the given rule.\r\n /// is nil.\r\n function WhereNot(const APredicate: TPredicate): IAssociation;\r\n\r\n /// Selects only the key-value pairs whose keys are less than a given value.\r\n /// The value to compare against.\r\n /// A new collection that contains only the pairs that satisfy the relationship.\r\n function WhereKeyLower(const ABound: TKey): IAssociation;\r\n\r\n /// Selects only the key-value pairs whose keys are less than or equal to a given value.\r\n /// The value to compare against.\r\n /// A new collection that contains only the pairs that satisfy the relationship.\r\n function WhereKeyLowerOrEqual(const ABound: TKey): IAssociation;\r\n\r\n /// Selects only the key-value pairs whose keys are greater than a given value.\r\n /// The value to compare against.\r\n /// A new collection that contains only the pairs that satisfy the relationship.\r\n function WhereKeyGreater(const ABound: TKey): IAssociation;\r\n\r\n /// Selects only the key-value pairs whose keys are greater than or equal to a given value.\r\n /// The value to compare against.\r\n /// A new collection that contains only the pairs that satisfy the relationship.\r\n function WhereKeyGreaterOrEqual(const ABound: TKey): IAssociation;\r\n\r\n /// Selects only the key-value pairs whose keys are are contained whithin a given interval.\r\n /// The lower bound.\r\n /// The upper bound.\r\n /// A new collection that contains only the pairs that satisfy the relationship.\r\n function WhereKeyBetween(const ALower, AHigher: TKey): IAssociation;\r\n\r\n /// Selects only the key-value pairs whose values are less than a given value.\r\n /// The value to compare against.\r\n /// A new collection that contains only the pairs that satisfy the relationship.\r\n function WhereValueLower(const ABound: TValue): IAssociation;\r\n\r\n /// Selects only the key-value pairs whose values are less than or equal to a given value.\r\n /// The value to compare against.\r\n /// A new collection that contains only the pairs that satisfy the relationship.\r\n function WhereValueLowerOrEqual(const ABound: TValue): IAssociation;\r\n\r\n /// Selects only the key-value pairs whose values are greater than a given value.\r\n /// The value to compare against.\r\n /// A new collection that contains only the pairs that satisfy the relationship.\r\n function WhereValueGreater(const ABound: TValue): IAssociation;\r\n\r\n /// Selects only the key-value pairs whose values are greater than or equal to a given value.\r\n /// The value to compare against.\r\n /// A new collection that contains only the pairs that satisfy the relationship.\r\n function WhereValueGreaterOrEqual(const ABound: TValue): IAssociation;\r\n\r\n /// Selects only the key-value pairs whose values are are contained whithin a given interval.\r\n /// The lower bound.\r\n /// The upper bound.\r\n /// A new collection that contains only the pairs that satisfy the relationship.\r\n function WhereValueBetween(const ALower, AHigher: TValue): IAssociation;\r\n end;\r\n\r\n /// The Enex interface that defines the behavior of a stack.\r\n /// This interface is implemented by all collections that provide the functionality of a stack.\r\n IStack = interface(ICollection)\r\n /// Pushes an element to the top of the stack.\r\n /// The value to push.\r\n procedure Push(const AValue: T);\r\n\r\n /// Retrieves the element from the top of the stack.\r\n /// The value at the top of the stack.\r\n /// This method removes the element from the top of the stack.\r\n /// The stack is empty.\r\n function Pop(): T;\r\n\r\n /// Reads the element from the top of the stack.\r\n /// The value at the top of the stack.\r\n /// This method does not remove the element from the top of the stack. It merely reads it's value.\r\n /// The stack is empty.\r\n function Peek(): T;\r\n end;\r\n\r\n /// The Enex interface that defines the behavior of a queue.\r\n /// This interface is implemented by all collections that provide the functionality of a queue.\r\n IQueue = interface(ICollection)\r\n /// Appends an element to the head of the queue.\r\n /// The value to append.\r\n procedure Enqueue(const AValue: T);\r\n\r\n /// Retrieves the element from the bottom of the queue.\r\n /// The value at the bottom of the queue.\r\n /// This method removes the element from the bottom of the queue.\r\n /// The queue is empty.\r\n function Dequeue(): T;\r\n\r\n /// Reads the element from the bottom of the queue.\r\n /// The value at the bottom of the queue.\r\n /// This method does not remove the element from the bottom of the queue. It merely reads it's value.\r\n /// The queue is empty.\r\n function Peek(): T;\r\n end;\r\n\r\n /// The Enex interface that defines the behavior of a priority queue.\r\n /// This interface is implemented by all collections that provide the functionality of a priority queue.\r\n IPriorityQueue = interface(IAssociation)\r\n /// Clears the contents of the priority queue.\r\n procedure Clear();\r\n\r\n /// Adds an element to the priority queue.\r\n /// The value to append.\r\n /// The lowest possible priority of the element is assumed. This means that the element is appended to the top of the queue.\r\n procedure Enqueue(const AValue: TValue); overload;\r\n\r\n /// Adds an element to the priority queue.\r\n /// The value to add.\r\n /// The priority of the value.\r\n /// The given priority is used to calculate the position of the value in the queue. Based on the priority the element might occupy any\r\n /// given position (for example it might even end up at the bottom position).\r\n procedure Enqueue(const AValue: TValue; const APriority: TPriority); overload;\r\n\r\n /// Retrieves the element from the bottom of the priority queue.\r\n /// The value at the bottom of the priority queue.\r\n /// This method removes the element from the bottom of the priority queue.\r\n /// The queue is empty.\r\n function Dequeue(): TValue;\r\n\r\n /// Reads the element from the bottom of the priority queue.\r\n /// The value at the bottom of the priority queue.\r\n /// This method does not remove the element from the bottom of the priority queue. It merely reads it's value.\r\n /// The queue is empty.\r\n function Peek(): TValue;\r\n\r\n /// Checks whether the priority queue contains a given value.\r\n /// The value to check.\r\n /// True if the value was found in the queue; False otherwise.\r\n function Contains(const AValue: TValue): Boolean;\r\n end;\r\n\r\n /// The Enex interface that defines the behavior of a set.\r\n /// This interface is implemented by all collections that provide the functionality of a set.\r\n ISet = interface(ICollection)\r\n end;\r\n\r\n /// The Enex interface that defines the behavior of a sorted set.\r\n /// This interface is implemented by all collections that provide the functionality of a sorted set.\r\n ISortedSet = interface(ISet)\r\n /// Returns the biggest set element.\r\n /// An element from the set considered to have the biggest value.\r\n /// The set is empty.\r\n function Max(): T;\r\n\r\n /// Returns the smallest set element.\r\n /// An element from the set considered to have the smallest value.\r\n /// The set is empty.\r\n function Min(): T;\r\n end;\r\n\r\n /// The Enex interface that defines the behavior of a bag.\r\n /// This interface is implemented by all collections that provide the functionality of a bag.\r\n IBag = interface(ISet)\r\n /// Adds an element to the bag.\r\n /// The element to add.\r\n /// The weight of the element.\r\n /// If the bag already contains the given value, it's stored weight is incremented to by .\r\n /// If the value of is zero, nothing happens.\r\n procedure AddWeight(const AValue: T; const AWeight: NativeUInt);\r\n\r\n /// Removes an element from the bag.\r\n /// The value to remove.\r\n /// The weight to remove.\r\n /// This method decreses the weight of the stored item by . If the resulting weight is less\r\n /// than zero or zero, the element is removed for the bag. If is zero, nothing happens.\r\n procedure RemoveWeight(const AValue: T; const AWeight: NativeUInt);\r\n\r\n /// Removes an element from the bag.\r\n /// The value to remove.\r\n /// This method completely removes an item from the bag ignoring it's stored weight. Nothing happens if the given value\r\n /// is not in the bag to begin with.\r\n procedure RemoveAllWeight(const AValue: T);\r\n\r\n /// Checks whether the bag contains an element with at least the required weight.\r\n /// The value to check.\r\n /// The smallest allowed weight.\r\n /// True if the condition is met; False otherwise.\r\n /// This method checks whether the bag contains the given value and that the contained value has at least the\r\n /// given weight.\r\n function ContainsWeight(const AValue: T; const AWeight: NativeUInt): Boolean;\r\n\r\n /// Returns the weight of an element.\r\n /// The value to check.\r\n /// The weight of the value.\r\n /// If the value is not found in the bag, zero is returned.\r\n function GetWeight(const AValue: T): NativeUInt;\r\n\r\n /// Sets the weight of an element.\r\n /// The value to set the weight for.\r\n /// The new weight.\r\n /// If the value is not found in the bag, this method acts like an Add operation; otherwise\r\n /// the weight of the stored item is adjusted.\r\n procedure SetWeight(const AValue: T; const AWeight: NativeUInt);\r\n\r\n /// Sets or gets the weight of an item in the bag.\r\n /// The value.\r\n /// If the value is not found in the bag, this method acts like an Add operation; otherwise\r\n /// the weight of the stored item is adjusted.\r\n property Weights[const AValue: T]: NativeUInt read GetWeight write SetWeight; default;\r\n end;\r\n\r\n /// The Enex interface that defines the behavior of a list.\r\n /// This interface is implemented by all collections that provide the functionality of a list.\r\n IList = interface(ICollection)\r\n /// Inserts an element into the list.\r\n /// The index to insert to.\r\n /// The value to insert.\r\n /// All elements starting with are moved to the right by one and then\r\n /// is placed at position .\r\n /// is out of bounds.\r\n procedure Insert(const AIndex: NativeInt; const AValue: T); overload;\r\n\r\n /// Inserts the elements of a collection into the list.\r\n /// The index to insert to.\r\n /// The values to insert.\r\n /// All elements starting with are moved to the right by the length of\r\n /// and then is placed at position .\r\n /// is out of bounds.\r\n /// is nil.\r\n procedure InsertAll(const AIndex: NativeInt; const ACollection: IEnumerable); overload;\r\n\r\n /// Removes an element from the list at a given index.\r\n /// The index from which to remove the element.\r\n /// This method removes the specified element and moves all following elements to the left by one.\r\n /// is out of bounds.\r\n procedure RemoveAt(const AIndex: NativeInt);\r\n\r\n /// Extracts an element from the list at a given index.\r\n /// The index from which to extract the element.\r\n /// This method removes the specified element and moves all following elements to the left by one.\r\n /// The removed element is returned to the caller.\r\n /// is out of bounds.\r\n function ExtractAt(const AIndex: NativeInt): T;\r\n\r\n /// Searches for the first appearance of a given element in this list.\r\n /// The value to search for.\r\n /// -1 if the value was not found; otherwise a positive value indicating the index of the value.\r\n function IndexOf(const AValue: T): NativeInt;\r\n\r\n /// Searches for the last appearance of a given element in this list.\r\n /// The value to search for.\r\n /// -1 if the value was not found; otherwise a positive value indicating the index of the value.\r\n function LastIndexOf(const AValue: T): NativeInt;\r\n\r\n /// Returns the item at a given index.\r\n /// The index in the list.\r\n /// The element at the specified position.\r\n /// is out of bounds.\r\n function GetItem(const AIndex: NativeInt): T;\r\n\r\n /// Sets the item at a given index.\r\n /// The index in the list.\r\n /// The new value.\r\n /// is out of bounds.\r\n procedure SetItem(const AIndex: NativeInt; const AValue: T);\r\n\r\n /// Returns the item at a given index.\r\n /// The index in the collection.\r\n /// The element at the specified position.\r\n /// is out of bounds.\r\n property Items[const AIndex: NativeInt]: T read GetItem write SetItem; default;\r\n end;\r\n\r\n /// The Enex interface that defines the behavior of a linked list.\r\n /// This interface is implemented by all collections that provide the functionality of a linked list.\r\n ILinkedList = interface(IList)\r\n /// Appends an element to the back of list.\r\n /// The value to append.\r\n /// This method is functionally identical to Add. Classes that implement this interface can simply\r\n /// alias this method to Add.\r\n procedure AddLast(const AValue: T); overload;\r\n\r\n /// Appends the elements from a collection to the back of the list.\r\n /// The values to append.\r\n /// This method is functionally identical to Add. Classes that implement this interface can simply\r\n /// alias this method to Add.\r\n /// is nil.\r\n procedure AddAllLast(const ACollection: IEnumerable); overload;\r\n\r\n /// Appends an element to the front of the list.\r\n /// The value to append.\r\n procedure AddFirst(const AValue: T); overload;\r\n\r\n /// Appends the elements from a collection to the back of the list.\r\n /// The values to append.\r\n /// is nil.\r\n procedure AddAllFirst(const ACollection: IEnumerable); overload;\r\n\r\n /// Removes the first element of the list.\r\n /// The list is empty.\r\n procedure RemoveFirst();\r\n\r\n /// Removes the last element of the list.\r\n /// The list is empty.\r\n procedure RemoveLast();\r\n\r\n /// Extracts the first element of the list.\r\n /// The first element of the list.\r\n /// The list is empty.\r\n function ExtractFirst(): T;\r\n\r\n /// Removes the last element of the list.\r\n /// The last element of the list.\r\n /// The list is empty.\r\n function ExtractLast(): T;\r\n\r\n /// Returns the first element of the list.\r\n /// The first element of the list.\r\n /// This method is functionally identical to First method exposed by the Enex intarfaces. It is provided here for consistency only.\r\n /// The list is empty.\r\n function First(): T;\r\n\r\n /// Returns the last element of the list.\r\n /// The last element of the list.\r\n /// This method is functionally identical to Last method exposed by the Enex intarfaces. It is provided here for consistency only.\r\n /// The list is empty.\r\n function Last(): T;\r\n end;\r\n\r\n /// The Enex interface that defines the basic behavior of all map-like collections.\r\n /// This interface is inherited by all interfaces that provide map-like functionality.\r\n IMap = interface(IAssociation)\r\n /// Clears the contents of the map.\r\n procedure Clear();\r\n\r\n{$IF CompilerVersion > 21}\r\n /// Adds a key-value pair to the map.\r\n /// The key-value pair to add.\r\n /// The map already contains a pair with the given key.\r\n procedure Add(const APair: TPair); overload;\r\n\r\n /// Adds a collection of key-value pairs to the map.\r\n /// The collection to add.\r\n /// The map already contains a pair with the given key.\r\n /// is nil.\r\n procedure AddAll(const ACollection: IEnumerable>); overload;\r\n{$IFEND}\r\n\r\n /// Adds a key-value pair to the map.\r\n /// The key of pair.\r\n /// The value associated with the key.\r\n /// The map already contains a pair with the given key.\r\n procedure Add(const AKey: TKey; const AValue: TValue); overload;\r\n\r\n /// Removes a key-value pair using a given key.\r\n /// The key of pair.\r\n /// If the specified key was not found in the map, nothing happens.\r\n procedure Remove(const AKey: TKey);\r\n\r\n /// Checks whether the map contains a key-value pair identified by the given key.\r\n /// The key to check for.\r\n /// True if the map contains a pair identified by the given key; False otherwise.\r\n function ContainsKey(const AKey: TKey): Boolean;\r\n\r\n /// Checks whether the map contains a key-value pair that contains a given value.\r\n /// The value to check for.\r\n /// True if the map contains a pair containing the given value; False otherwise.\r\n /// This operation should be avoided. Its perfomance is poor is most map implementations.\r\n function ContainsValue(const AValue: TValue): Boolean;\r\n end;\r\n\r\n /// The Enex interface that defines the behavior of a dictionary.\r\n /// This interface is implemented by all collections that provide the functionality of a dictionary.\r\n IDictionary = interface(IMap)\r\n /// Extracts a value using a given key.\r\n /// The key of the associated value.\r\n /// The value associated with the key.\r\n /// This function is identical to Remove but will return the stored value. If there is no pair with the given key, an exception is raised.\r\n /// The is not part of the dictionary.\r\n function Extract(const AKey: TKey): TValue;\r\n\r\n /// Tries to obtain the value associated with a given key.\r\n /// The key for which to try to retreive the value.\r\n /// The found value (if the result is True).\r\n /// True if the dictionary contains a value for the given key; False otherwise.\r\n function TryGetValue(const AKey: TKey; out AFoundValue: TValue): Boolean;\r\n\r\n /// Returns the value associated with the given key.\r\n /// The key for which to try to retreive the value.\r\n /// The value associated with the key.\r\n /// The key is not found in the dictionary.\r\n function GetValue(const AKey: TKey): TValue;\r\n\r\n /// Sets the value for a given key.\r\n /// The key for which to set the value.\r\n /// The value to set.\r\n /// If the dictionary does not contain the key, this method acts like Add; otherwise the\r\n /// value of the specified key is modified.\r\n procedure SetValue(const AKey: TKey; const AValue: TValue);\r\n\r\n /// Gets or sets the value for a given key.\r\n /// The key for to operate on.\r\n /// The value associated with the key.\r\n /// If the dictionary does not contain the key, this method acts like Add if assignment is done to this property;\r\n /// otherwise the value of the specified key is modified.\r\n /// Trying to read the value of a key that is\r\n /// not found in the dictionary.\r\n property Items[const AKey: TKey]: TValue read GetValue write SetValue; default;\r\n end;\r\n\r\n /// The Enex interface that defines the behavior of a bidirectional dictionary.\r\n /// This interface is implemented by all collections that provide the functionality of a bidirectional dictionary. In a\r\n /// bidirectional dictionary, both the key and the value are treated as \"keys\".\r\n IBidiDictionary = interface(IMap)\r\n /// Extracts a value using a given key.\r\n /// The key of the associated value.\r\n /// The value associated with the key.\r\n /// This function is identical to RemoveKey but will return the stored value. If there is no pair with the given key, an exception is raised.\r\n /// The is not part of the map.\r\n function ExtractValueForKey(const AKey: TKey): TValue;\r\n\r\n /// Extracts a key using a given value.\r\n /// The value of the associated key.\r\n /// The key associated with the value.\r\n /// This function is identical to RemoveValue but will return the stored key. If there is no pair with the given value, an exception is raised.\r\n /// The is not part of the map.\r\n function ExtractKeyForValue(const AValue: TValue): TKey;\r\n\r\n /// Removes a key-value pair using a given key.\r\n /// The key (and its associated value) to remove.\r\n procedure RemoveValueForKey(const AKey: TKey);\r\n\r\n /// Removes a key-value pair using a given value.\r\n /// The value (and its associated key) to remove.\r\n procedure RemoveKeyForValue(const AValue: TValue);\r\n\r\n /// Removes a specific key-value combination.\r\n /// The key to remove.\r\n /// The value to remove.\r\n /// This method only remove a key-value combination if that combination actually exists in the dictionary.\r\n /// If the key is associated with another value, nothing happens.\r\n procedure RemovePair(const AKey: TKey; const AValue: TValue); overload;\r\n\r\n{$IF CompilerVersion > 21}\r\n /// Removes a key-value combination.\r\n /// The pair to remove.\r\n /// This method only remove a key-value combination if that combination actually exists in the dictionary.\r\n /// If the key is associated with another value, nothing happens.\r\n procedure RemovePair(const APair: TPair); overload;\r\n{$IFEND}\r\n\r\n /// Checks whether the map contains the given key-value combination.\r\n /// The key associated with the value.\r\n /// The value associated with the key.\r\n /// True if the dictionary contains the given association; False otherwise.\r\n function ContainsPair(const AKey: TKey; const AValue: TValue): Boolean; overload;\r\n\r\n{$IF CompilerVersion > 21}\r\n /// Checks whether the map contains a given key-value combination.\r\n /// The key-value pair combination.\r\n /// True if the dictionary contains the given association; False otherwise.\r\n function ContainsPair(const APair: TPair): Boolean; overload;\r\n{$IFEND}\r\n\r\n /// Tries to obtain the value associated with a given key.\r\n /// The key for which to try to retreive the value.\r\n /// The found value (if the result is True).\r\n /// True if the dictionary contains a value for the given key; False otherwise.\r\n function TryGetValueForKey(const AKey: TKey; out AFoundValue: TValue): Boolean;\r\n\r\n /// Returns the value associated with a key.\r\n /// The key for which to obtain the associated value.\r\n /// The associated value.\r\n /// The key is not found in the collection.\r\n function GetValueForKey(const AKey: TKey): TValue;\r\n\r\n /// Sets the value for a given key.\r\n /// The key for which to set the value.\r\n /// The value to set.\r\n /// If the dictionary does not contain the key, this method acts like Add; otherwise the\r\n /// value of the specified key is modified.\r\n /// The new value is already used by another key.\r\n procedure SetValueForKey(const AKey: TKey; const AValue: TValue);\r\n\r\n /// Returns the value associated with a key.\r\n /// The key for which to obtain the associated value.\r\n /// The associated value.\r\n /// The key is not found in the collection.\r\n property ByKey[const AKey: TKey]: TValue read GetValueForKey write SetValueForKey;\r\n\r\n /// Tries to obtain the key associated with a given value.\r\n /// The value for which to try to retreive the key.\r\n /// The found key (if the result is True).\r\n /// True if the dictionary contains a key for the given value; False otherwise.\r\n function TryGetKeyForValue(const AValue: TValue; out AFoundKey: TKey): Boolean;\r\n\r\n /// Returns the key associated with a value.\r\n /// The value for which to obtain the associated key.\r\n /// The associated key.\r\n /// The value is not found in the collection.\r\n function GetKeyForValue(const AValue: TValue): TKey;\r\n\r\n /// Sets the key for a given value.\r\n /// The value for which to set the key.\r\n /// The key to set.\r\n /// If the dictionary does not contain the value, this method acts like Add; otherwise the\r\n /// key of the specified value is modified.\r\n /// The new key is already used by another value.\r\n procedure SetKeyForValue(const AValue: TValue; const AKey: TKey);\r\n\r\n /// Returns the key associated with a value.\r\n /// The value for which to obtain the associated key.\r\n /// The associated key.\r\n /// The value is not found in the collection.\r\n property ByValue[const AValue: TValue]: TKey read GetKeyForValue write SetKeyForValue;\r\n end;\r\n\r\n /// The Enex interface that defines the behavior of a bidirectional multi-map.\r\n /// This interface is implemented by all collections that provide the functionality of a bidirectional multi-map. In a\r\n /// bidirectional multi-map, both the key and the value are treated as \"keys\".\r\n IBidiMap = interface(IMap)\r\n /// Removes a key-value pair using a given key.\r\n /// The key (and its associated values) to remove.\r\n /// This method removes all the values that are associated with the given key. The rule set's cleanup\r\n /// routines are used to cleanup the values that are dropped from the map.\r\n procedure RemoveValuesForKey(const AKey: TKey);\r\n\r\n /// Removes a key-value pair using a given value.\r\n /// The value (and its associated keys) to remove.\r\n /// This method removes all the keys that are associated with the given value. The rule set's cleanup\r\n /// routines are used to cleanup the keys that are dropped from the map.\r\n procedure RemoveKeysForValue(const AValue: TValue);\r\n\r\n /// Removes a specific key-value combination.\r\n /// The key to remove.\r\n /// The value to remove.\r\n /// This method only remove a key-value combination if that combination actually exists in the dictionary.\r\n /// If the key is associated with another value, nothing happens.\r\n procedure RemovePair(const AKey: TKey; const AValue: TValue); overload;\r\n\r\n{$IF CompilerVersion > 21}\r\n /// Removes a key-value combination.\r\n /// The pair to remove.\r\n /// This method only remove a key-value combination if that combination actually exists in the dictionary.\r\n /// If the key is associated with another value, nothing happens.\r\n procedure RemovePair(const APair: TPair); overload;\r\n{$IFEND}\r\n\r\n /// Checks whether the map contains the given key-value combination.\r\n /// The key associated with the value.\r\n /// The value associated with the key.\r\n /// True if the map contains the given association; False otherwise.\r\n function ContainsPair(const AKey: TKey; const AValue: TValue): Boolean; overload;\r\n\r\n{$IF CompilerVersion > 21}\r\n /// Checks whether the map contains a given key-value combination.\r\n /// The key-value pair combination.\r\n /// True if the map contains the given association; False otherwise.\r\n function ContainsPair(const APair: TPair): Boolean; overload;\r\n{$IFEND}\r\n\r\n /// Returns the collection of values associated with a key.\r\n /// The key for which to obtain the associated values.\r\n /// An Enex collection that contains the values associated with this key.\r\n /// The key is not found in the collection.\r\n function GetValuesByKey(const AKey: TKey): ISequence;\r\n\r\n /// Returns the collection of values associated with a key.\r\n /// The key for which to obtain the associated values.\r\n /// An Enex collection that contains the values associated with this key.\r\n /// The key is not found in the collection.\r\n property ByKey[const AKey: TKey]: ISequence read GetValuesByKey;\r\n\r\n /// Returns the collection of keys associated with a value.\r\n /// The value for which to obtain the associated keys.\r\n /// An Enex collection that contains the values associated with this key.\r\n /// The value is not found in the collection.\r\n function GetKeysByValue(const AValue: TValue): ISequence;\r\n\r\n /// Returns the collection of keys associated with a value.\r\n /// The value for which to obtain the associated keys.\r\n /// An Enex collection that contains the values associated with this key.\r\n /// The value is not found in the collection.\r\n property ByValue[const AValue: TValue]: ISequence read GetKeysByValue;\r\n end;\r\n\r\n /// The Enex interface that defines the behavior of a multi-map.\r\n /// This interface is implemented by all collections that provide the functionality of a multi-map. In a\r\n /// multi-map, a key is associated with multiple values, not just one.\r\n IMultiMap = interface(IMap)\r\n /// Extracts all values using their key.\r\n /// The key of the associated values.\r\n /// A collection of values associated with the key.\r\n /// This function is identical to RemoveKey but will return the associated values. If there is no given key, an exception is raised.\r\n /// The is not part of the map.\r\n function ExtractValues(const AKey: TKey): ISequence;\r\n\r\n /// Removes a key-value pair using a given key and value.\r\n /// The key associated with the value.\r\n /// The value to remove.\r\n /// A multi-map allows storing multiple values for a given key. This method allows removing only the\r\n /// specified value from the collection of values associated with the given key.\r\n procedure RemovePair(const AKey: TKey; const AValue: TValue); overload;\r\n\r\n{$IF CompilerVersion > 21}\r\n /// Removes a key-value pair using a given key and value.\r\n /// The key and its associated value to remove.\r\n /// A multi-map allows storing multiple values for a given key. This method allows removing only the\r\n /// specified value from the collection of values associated with the given key.\r\n procedure RemovePair(const APair: TPair); overload;\r\n{$IFEND}\r\n\r\n /// Checks whether the multi-map contains a given key-value combination.\r\n /// The key associated with the value.\r\n /// The value associated with the key.\r\n /// True if the map contains the given association; False otherwise.\r\n function ContainsPair(const AKey: TKey; const AValue: TValue): Boolean; overload;\r\n\r\n{$IF CompilerVersion > 21}\r\n /// Checks whether the multi-map contains a given key-value combination.\r\n /// The key-value pair to check for.\r\n /// True if the map contains the given association; False otherwise.\r\n function ContainsPair(const APair: TPair): Boolean; overload;\r\n{$IFEND}\r\n /// Returns the collection of values associated with a key.\r\n /// The key for which to obtain the associated values.\r\n /// An Enex collection that contains the values associated with this key.\r\n /// The key is not found in the collection.\r\n function GetValues(const AKey: TKey): ISequence;\r\n\r\n /// Returns the collection of values associated with a key.\r\n /// The key for which to obtain the associated values.\r\n /// An Enex collection that contains the values associated with this key.\r\n /// The key is not found in the collection.\r\n property Items[const AKey: TKey]: ISequence read GetValues; default;\r\n\r\n /// Tries to extract the collection of values associated with a key.\r\n /// The key for which to obtain the associated values.\r\n /// The Enex collection that stores the associated values.\r\n /// True if the key exists in the collection; False otherwise;\r\n function TryGetValues(const AKey: TKey; out AValues: ISequence): Boolean; overload;\r\n\r\n /// Tries to extract the collection of values associated with a key.\r\n /// The key for which to obtain the associated values.\r\n /// The associated collection if the key if valid; an empty collection otherwise.\r\n function TryGetValues(const AKey: TKey): ISequence; overload;\r\n end;\r\n\r\n /// A special interface implemented by collections that support the concept of capacity.\r\n /// This interface specifies a set of method that allow controlling the capactity of a collection.\r\n IDynamic = interface\r\n /// Returns the current capacity.\r\n /// A positive number that specifies the number of elements that the collection can hold before it\r\n /// needs to grow again.\r\n /// The value of this method is greater or equal to the amount of elements in the collection. If this value\r\n /// if greater then the number of elements, it means that the collection has some extra capacity to operate upon.\r\n function GetCapacity(): NativeInt;\r\n\r\n /// Removes the excess capacity from the collection.\r\n /// This method can be called manually to force the collection to drop the extra capacity it might hold. For example,\r\n /// after performing some massive operations on a big list, call this method to ensure that all extra memory held by the\r\n /// collection is released.\r\n procedure Shrink();\r\n\r\n /// Forces the collection to increase its capacity.\r\n /// Call this method to force the collection to increase its capacity ahead of time. Manually adjusting the capacity\r\n /// can be useful in certain situations. Each collection specifies its \"growing\" strategy. Most collections grow by a factor of two\r\n /// (New Capacity = Old Capacity * 2).\r\n procedure Grow();\r\n\r\n /// Specifies the current capacity.\r\n /// A positive number that specifies the number of elements that the collection can hold before it\r\n /// needs to grow again.\r\n /// The value of this property is greater or equal to the amount of elements in the collection. If this value\r\n /// if greater then the number of elements, it means that the collection has some extra capacity to operate upon.\r\n property Capacity: NativeInt read GetCapacity;\r\n end;\r\n\r\n{$ENDREGION}\r\n\r\n{$REGION 'Base Collection Classes'}\r\ntype\r\n{$HINTS OFF}\r\n /// Base for all reference counted objects in this package.\r\n /// Collections.Base.TRefCountedObject is designed to be used as a base class for all\r\n /// objects that implement interfaces and require reference counting.\r\n TRefCountedObject = class abstract(TInterfacedObject, IInterface)\r\n private\r\n FKeepAliveList: TArray;\r\n FInConstruction: Boolean;\r\n\r\n protected\r\n /// Registers a reference counted object as as keep-alive for this object.\r\n /// The object to keep alive.\r\n /// If is nil nothing happens. Otherwise, this object is\r\n /// checked to have a positive reference count. If that is the case, a new interface reference is requested\r\n /// and registered internally, preventing the object from being destroyed prematurely.\r\n /// if trying to keep alive self.\r\n procedure KeepObjectAlive(const AObject: TRefCountedObject);\r\n\r\n /// Unregisters a reference counted object from the keep-alive list.\r\n /// The object to unregister.\r\n /// Specifies whether to free the object if its reference reaches is zero.\r\n /// If is nil nothing happens. Otherwise, this object is\r\n /// checked to have a positive reference count. If that is the case, the help reference is released.\r\n /// if trying to release self.\r\n procedure ReleaseObject(const AObject: TRefCountedObject;\r\n const AFreeObject: Boolean = false);\r\n\r\n /// Extract an interafce reference for this object.\r\n /// If the reference count is zero, then no reference is extracted.\r\n /// An interface reference or nil.\r\n function ExtractReference(): IInterface;\r\n\r\n /// Specifies whether the object is currently being constructed.\r\n /// True if the object is in construction; False otherwise.\r\n property Constructing: Boolean read FInConstruction;\r\n public\r\n /// Initializes the internals of the Collections.Base.TRefCountedObject objects.\r\n /// Do not call this method directly. It is part of the object creation process.\r\n class function NewInstance: TObject; override;\r\n\r\n /// Initializes the internals of the Collections.Base.TRefCountedObject objects.\r\n /// Do not call this method directly. It is part of the object creation process.\r\n procedure AfterConstruction; override;\r\n end;\r\n{$HINTS ON}\r\n\r\n /// Procedural type used by collections to insert custom remove notification code\r\n /// into inner collections.\r\n /// The value being removed.\r\n TRemoveNotification = reference to procedure(const AValue: T);\r\n\r\n /// Non-generic base class for all collections.\r\n /// This class provides some basics like version management and count retrieval.\r\n TAbstractContainer = class abstract(TRefCountedObject)\r\n private\r\n FVersion: NativeInt;\r\n FLock: TMREWSync;\r\n FThreadSafe: LongBool;\r\n protected\r\n procedure SetThreadSafe(const Value: LongBool); virtual;\r\n\r\n /// Returns the number of elements in the collection.\r\n /// A positive value specifying the number of elements in the collection.\r\n /// A call to this method can be costly because some\r\n /// collections cannot detect the number of stored elements directly, resorting to enumerating themselves.\r\n function GetCount(): NativeInt; virtual; abstract;\r\n\r\n /// Call this method to notify the collection that it was modified.\r\n /// This method must be called by descending classes in order to update the version of the collection.\r\n procedure NotifyCollectionChanged(); virtual;\r\n public\r\n const CDefaultSize = 32;\r\n\r\n constructor Create(const AThreadSafe: LongBool = False);\r\n destructor Destroy; override;\r\n\r\n /// Returns the current version of the collection.\r\n /// An integer value specifying the current \"structural version\" of the collection.\r\n /// This function returns a number that is modified by the implementing collection each time\r\n /// the collection changes. This version can be used to identify if a collection has chnaged since last time it was used\r\n /// in a specific piece of code.\r\n function Version(): NativeInt; virtual;\r\n\r\n /// Checks whether the collection is empty.\r\n /// True if the collection is empty; False otherwise.\r\n /// This method is the recommended way of detecting if the collection is empty. It is optimized\r\n /// in most collections to offer a fast response.\r\n function Empty(): Boolean; virtual; abstract;\r\n\r\n /// Specifies the number of elements in the collection.\r\n /// A positive value specifying the number of elements in the collection.\r\n /// Accesing this property can be costly because some\r\n /// collections cannot detect the number of stored elements directly, resorting to enumerating themselves.\r\n property Count: NativeInt read GetCount;\r\n\r\n procedure LockForRead; inline;\r\n procedure UnLockForRead; inline;\r\n\r\n procedure LockForWrite; inline;\r\n procedure UnLockForWrite; inline;\r\n\r\n property Lock: TMREWSync read FLock;\r\n property ThreadSafe: LongBool read FThreadSafe write SetThreadSafe;\r\n end;\r\n\r\n /// Base class for all collections.\r\n /// All collections are derived from this base class. It implements most Enex operations based on\r\n /// enumerability .\r\n TAbstractContainer = class abstract(TAbstractContainer, IContainer, IEnumerable)\r\n protected\r\n /// Returns the number of elements in the collection.\r\n /// A positive value specifying the number of elements in the collection.\r\n /// A call to this method can be costly because some\r\n /// collections cannot detect the number of stored elements directly, resorting to enumerating themselves.\r\n function GetCount(): NativeInt; override;\r\n public\r\n /// Checks whether the collection is empty.\r\n /// True if the collection is empty; False otherwise.\r\n /// This method is the recommended way of detecting if the collection is empty. It is optimized\r\n /// in most collections to offer a fast response.\r\n function Empty(): Boolean; override;\r\n\r\n /// Returns the single element stored in the collection.\r\n /// The element in collection.\r\n /// This method checks if the collection contains just one element, in which case it is returned.\r\n /// The collection is empty.\r\n /// There is more than one element in the collection.\r\n function Single(): T; virtual;\r\n\r\n /// Returns the single element stored in the collection, or a default value.\r\n /// The default value returned if there is less or more elements in the collection.\r\n /// The element in the collection if the condition is satisfied; is returned otherwise.\r\n /// This method checks if the collection contains just one element, in which case it is returned. Otherwise\r\n /// the value in is returned.\r\n function SingleOrDefault(const ADefault: T): T; virtual;\r\n\r\n /// Copies the values stored in the collection to a given array.\r\n /// An array where to copy the contents of the collection.\r\n /// This method assumes that has enough space to hold the contents of the collection.\r\n /// There array is not long enough.\r\n procedure CopyTo(var AArray: array of T); overload;\r\n\r\n /// Copies the values stored in the collection to a given array.\r\n /// An array where to copy the contents of the collection.\r\n /// The index into the array at which the copying begins.\r\n /// This method assumes that has enough space to hold the contents of the collection.\r\n /// is out of bounds.\r\n /// There array is not long enough.\r\n procedure CopyTo(var AArray: array of T; const AStartIndex: NativeInt); overload; virtual;\r\n\r\n /// Creates a new Delphi array with the contents of the collection.\r\n /// The length of the new array is equal to the value of Count property.\r\n function ToArray(): TArray; virtual;\r\n\r\n /// Returns a new enumerator object used to enumerate the collection.\r\n /// This method is usually called by compiler generated code. It's purpose is to create an enumerator\r\n /// object that is used to actually traverse the collection.\r\n /// Note that many collections generate enumerators that depend on the state of the collection. If the collection is changed\r\n /// after the enumerator has been obtained, the enumerator is considered invalid. All subsequent operations on that enumerator\r\n /// will throw exceptions.\r\n /// An enumerator object.\r\n function GetEnumerator(): IEnumerator; virtual; abstract;\r\n\r\n /// Specifies the number of elements in the collection.\r\n /// A positive value specifying the number of elements in the collection.\r\n /// Accesing this property can be costly because some\r\n /// collections cannot detect the number of stored elements directly, resorting to enumerating themselves.\r\n property Count: NativeInt read GetCount;\r\n end;\r\n\r\n /// Base class for all Enex enumerator objects.\r\n /// All Enex collection are expected to provide enumerators that derive from\r\n /// this class.\r\n TAbstractEnumerator = class abstract(TRefCountedObject, IEnumerator)\r\n private\r\n FCreatedAtVersion: NativeInt;\r\n FOwner: TAbstractContainer;\r\n FCurrent: T;\r\n FEnded: Boolean;\r\n protected\r\n /// Specifies the owner collection.\r\n /// The collection that generated this enumerator.\r\n property Owner: TAbstractContainer read FOwner;\r\n\r\n /// Returns the current element of the enumerated collection.\r\n /// This method is the getter for Current property. Use the property to obtain the element instead.\r\n /// The current element of the enumerated collection.\r\n /// The enumerated collection has changed.\r\n function GetCurrent(): T;\r\n\r\n /// Implement this method to move the iterator to the next element in the collection.\r\n /// The \"next\" value. Must be returned by the descending classes.\r\n /// True if the iteration to the next element was successful; False otherwise.\r\n function TryMoveNext(out ACurrent: T): Boolean; virtual; abstract;\r\n public\r\n /// Initializes an enumerator object.\r\n /// The owner collection.\r\n /// Descending classes must always call this constructor in their constructor.\r\n /// is nil.\r\n constructor Create(const AOwner: TAbstractContainer);\r\n\r\n /// Destroys this enumerator object.\r\n destructor Destroy; override;\r\n\r\n /// Moves the enumerator to the next element of collection.\r\n /// This method is usually called by compiler generated code. Its purpose is to move the \"pointer\" to the next element in\r\n /// the collection (if there are elements left). Also note that many specific enumerator implementations may throw various\r\n /// exceptions if the enumerated collection was changed while enumerating.\r\n /// True if the enumerator succesefully selected the next element; False is there are\r\n /// no more elements to be enumerated.\r\n /// The enumerated collection has changed.\r\n function MoveNext(): Boolean;\r\n\r\n /// Checking change of collection.\r\n function VersionChanged: Boolean;\r\n\r\n /// Returns the current element of the enumerated collection.\r\n /// This property can only return a valid element if MoveNext was priorly called and returned True;\r\n /// otherwise the behavior of this property is undefined. \r\n /// The current element of the enumerated collection.\r\n /// The enumerated collection has changed.\r\n property Current: T read GetCurrent;\r\n end;\r\n\r\n /// A variation of an enumerator object thet forwards all calls to an enclosed enumerator and allows filtering\r\n /// the enumerated value.\r\n /// By default filtering is off, but it can be enaled by overriding the AcceptValue method.\r\n TForwardingEnumerator = class abstract(TAbstractEnumerator)\r\n private\r\n FForwardEnumerator: IEnumerator;\r\n protected\r\n /// Obtains the next value from the use enumerator.\r\n /// The \"next\" value. The value obtained from the forwarding enumerator.\r\n /// This method calls AcceptValue and if the result is False iterates further until\r\n /// a values from the enclised enumerator is accepted.\r\n /// True if the iteration to the next element was successful; False otherwise.\r\n function TryMoveNext(out ACurrent: T): Boolean; override;\r\n\r\n /// Override in descending enumerator classes to accept or reject a value provided by the\r\n /// enclosed enumerator.\r\n /// The value to accept or reject.\r\n /// True if the value is accepted; False otherwise.\r\n /// The current implementation always returns True.\r\n function AcceptValue(const AValue: T): Boolean; virtual;\r\n public\r\n /// Initializes a fprwarding enumerator object.\r\n /// The owner collection.\r\n /// The enumerator to forward all calls to.\r\n /// Descending classes must always call this constructor in their constructor.\r\n /// is nil.\r\n /// is nil.\r\n constructor Create(const AOwner: TAbstractContainer; const AEnumerator: IEnumerator);\r\n end;\r\n\r\n /// Base class for all non-associative Enex collections.\r\n /// All normal Enex collections (ex. list or stack) are derived from this base class.\r\n /// It implements the extended Enex operations based on enumerability.\r\n TSequence = class abstract(TAbstractContainer, IComparable, ISequence)\r\n private\r\n FElementRules: TRules;\r\n\r\n protected\r\n /// Compares two values for equality.\r\n /// The first value.\r\n /// The second value.\r\n /// True if the values are equal; False otherwise.\r\n /// This method uses the equality comparer. If such a comparer was not provided\r\n /// a default one is requested.\r\n function ElementsAreEqual(const ALeft, ARight: T): Boolean;\r\n\r\n /// Compares two values.\r\n /// The first value.\r\n /// The second value.\r\n /// A value less than zero if is less than .\r\n /// A value greater than zero if is greater than . Zero if\r\n /// is equal to .\r\n /// This method uses the comparer. If such a comparer was not provided\r\n /// a default one is requested.\r\n function CompareElements(const ALeft, ARight: T): NativeInt;\r\n\r\n /// Generates a hash code for the given value.\r\n /// The value.\r\n /// The calculated hash code.\r\n /// This method uses the equality comparer. If such a comparer was not provided\r\n /// a default one is requested.\r\n function GetElementHashCode(const AValue: T): NativeInt; overload;\r\n\r\n /// Specifies the rule set that describes the stored elements.\r\n /// A rule set describing the stored elements.\r\n property ElementRules: TRules read FElementRules;\r\n public\r\n /// Instantiates this class.\r\n /// The default comparer and equality comparer are requested if this constructor is used. Do not call this method if\r\n /// you don't know what you are doing.\r\n constructor Create(); overload;\r\n\r\n /// Instantiates this class.\r\n /// The rules set used by the collection.\r\n /// The provided rules set is used by this collection. This constructor must be called from descendent collections.\r\n constructor Create(const ARules: TRules); overload;\r\n\r\n /// Returns the biggest element.\r\n /// An element from the collection considered to have the biggest value.\r\n /// The collection is empty.\r\n function Max(): T; virtual;\r\n\r\n /// Returns the smallest element.\r\n /// An element from the collection considered to have the smallest value.\r\n /// The collection is empty.\r\n function Min(): T; virtual;\r\n\r\n /// Returns the first element.\r\n /// The first element in collection.\r\n /// The collection is empty.\r\n function First(): T; virtual;\r\n\r\n /// Returns the first element or a default if the collection is empty.\r\n /// The default value returned if the collection is empty.\r\n /// The first element in collection if the collection is not empty; otherwise is returned.\r\n function FirstOrDefault(const ADefault: T): T; virtual;\r\n\r\n /// Returns the first element that satisfies the given predicate.\r\n /// The predicate to use.\r\n /// The first element that satisfies the given predicate.\r\n /// The collection is empty.\r\n /// No elements satisfy the predicate.\r\n /// is nil.\r\n function FirstWhere(const APredicate: TPredicate): T; virtual;\r\n\r\n /// Returns the first element that satisfies the given predicate or a default value.\r\n /// The predicate to use.\r\n /// The default value.\r\n /// The first element that satisfies the given predicate; or otherwise.\r\n /// is nil.\r\n function FirstWhereOrDefault(const APredicate: TPredicate; const ADefault: T): T; virtual;\r\n\r\n /// Returns the first element that does not satisfy the given predicate.\r\n /// The predicate to use.\r\n /// The first element that does not satisfy the given predicate.\r\n /// The collection is empty.\r\n /// No elements that do not satisfy the predicate.\r\n /// is nil.\r\n function FirstWhereNot(const APredicate: TPredicate): T;\r\n\r\n /// Returns the first element that does not satisfy the given predicate or a default value.\r\n /// The predicate to use.\r\n /// The default value.\r\n /// The first element that does not satisfy the given predicate; or otherwise.\r\n /// is nil.\r\n function FirstWhereNotOrDefault(const APredicate: TPredicate; const ADefault: T): T;\r\n\r\n /// Returns the first element lower than a given value.\r\n /// The value to compare against.\r\n /// The first element that satisfies the given condition.\r\n /// The collection is empty.\r\n /// No elements satisfy the condition.\r\n function FirstWhereLower(const ABound: T): T;\r\n\r\n /// Returns the first element lower than a given value or a default.\r\n /// The value to compare against.\r\n /// The default value.\r\n /// The first element that satisfies the given condition; or otherwise.\r\n /// The collection is empty.\r\n /// No elements satisfy the condition.\r\n function FirstWhereLowerOrDefault(const ABound: T; const ADefault: T): T;\r\n\r\n /// Returns the first element lower than or equal to a given value.\r\n /// The value to compare against.\r\n /// The first element that satisfies the given condition.\r\n /// The collection is empty.\r\n /// No elements satisfy the condition.\r\n function FirstWhereLowerOrEqual(const ABound: T): T;\r\n\r\n /// Returns the first element lower than or equal to a given value or a default.\r\n /// The value to compare against.\r\n /// The default value.\r\n /// The first element that satisfies the given condition; or otherwise.\r\n /// The collection is empty.\r\n /// No elements satisfy the condition.\r\n function FirstWhereLowerOrEqualOrDefault(const ABound: T; const ADefault: T): T;\r\n\r\n /// Returns the first element greater than a given value.\r\n /// The value to compare against.\r\n /// The first element that satisfies the given condition.\r\n /// The collection is empty.\r\n /// No elements satisfy the condition.\r\n function FirstWhereGreater(const ABound: T): T;\r\n\r\n /// Returns the first element greater than a given value or a default.\r\n /// The value to compare against.\r\n /// The default value.\r\n /// The first element that satisfies the given condition; or otherwise.\r\n /// The collection is empty.\r\n /// No elements satisfy the condition.\r\n function FirstWhereGreaterOrDefault(const ABound: T; const ADefault: T): T;\r\n\r\n /// Returns the first element greater than or equal to a given value.\r\n /// The value to compare against.\r\n /// The first element that satisfies the given condition.\r\n /// The collection is empty.\r\n /// No elements satisfy the condition.\r\n function FirstWhereGreaterOrEqual(const ABound: T): T;\r\n\r\n /// Returns the first element greater than or equal to a given value or a default.\r\n /// The value to compare against.\r\n /// The default value.\r\n /// The first element that satisfies the given condition; or otherwise.\r\n /// The collection is empty.\r\n /// No elements satisfy the condition.\r\n function FirstWhereGreaterOrEqualOrDefault(const ABound: T; const ADefault: T): T;\r\n\r\n /// Returns the first element situated within the given bounds.\r\n /// The lower bound.\r\n /// The higher bound.\r\n /// The first element that satisfies the given condition.\r\n /// The collection is empty.\r\n /// No elements satisfy the condition.\r\n function FirstWhereBetween(const ALower, AHigher: T): T;\r\n\r\n /// Returns the first element situated within the given bounds or a default.\r\n /// The lower bound.\r\n /// The higher bound.\r\n /// The default value.\r\n /// The first element that satisfies the given condition; or otherwise.\r\n /// The collection is empty.\r\n /// No elements satisfy the condition.\r\n function FirstWhereBetweenOrDefault(const ALower, AHigher: T; const ADefault: T): T;\r\n\r\n /// Returns the last element.\r\n /// The last element in collection.\r\n /// The collection is empty.\r\n function Last(): T; virtual;\r\n\r\n /// Returns the last element or a default if the collection is empty.\r\n /// The default value returned if the collection is empty.\r\n /// The last element in collection if the collection is not empty; otherwise is returned.\r\n function LastOrDefault(const ADefault: T): T; virtual;\r\n\r\n /// Aggregates a value based on the collection's elements.\r\n /// The aggregator method.\r\n /// A value that contains the collection's aggregated value.\r\n /// This method returns the first element if the collection only has one element. Otherwise,\r\n /// is invoked for each two elements (first and second; then the result of the first two\r\n /// and the third, and so on). The simplest example of aggregation is the \"sum\" operation where you can obtain the sum of all\r\n /// elements in the value.\r\n /// is nil.\r\n /// The collection is empty.\r\n function Aggregate(const AAggregator: TFunc): T; virtual;\r\n\r\n /// Aggregates a value based on the collection's elements.\r\n /// The aggregator method.\r\n /// The default value returned if the collection is empty.\r\n /// A value that contains the collection's aggregated value. If the collection is empty, is returned.\r\n /// This method returns the first element if the collection only has one element. Otherwise,\r\n /// is invoked for each two elements (first and second; then the result of the first two\r\n /// and the third, and so on). The simplest example of aggregation is the \"sum\" operation where you can obtain the sum of all\r\n /// elements in the value.\r\n /// is nil.\r\n function AggregateOrDefault(const AAggregator: TFunc; const ADefault: T): T; virtual;\r\n\r\n /// Returns the element at a given position.\r\n /// The index from which to return the element.\r\n /// The element at the specified position.\r\n /// This method is slow for collections that cannot reference their elements by indexes, for example linked lists.\r\n /// The collection is empty.\r\n /// is out of bounds.\r\n function ElementAt(const AIndex: NativeInt): T; virtual;\r\n\r\n /// Returns the element at a given position.\r\n /// The index from which to return the element.\r\n /// The default value returned if the collection is empty.\r\n /// The element at the specified position if the collection is not empty and the position is not out of bounds; otherwise\r\n /// the value of is returned.\r\n /// This method is slow for collections that cannot reference their elements by indexes, for example linked lists.\r\n function ElementAtOrDefault(const AIndex: NativeInt; const ADefault: T): T; virtual;\r\n\r\n /// Check whether at least one element in the collection satisfies a given predicate.\r\n /// The predicate to check for each element.\r\n /// True if at least one element satisfies a given predicate; False otherwise.\r\n /// This method traverses the whole collection and checks the value of the predicate for each element. This method\r\n /// stops on the first element for which the predicate returns True. The logical equivalent of this operation is \"OR\".\r\n /// is nil.\r\n function Any(const APredicate: TPredicate): Boolean; virtual;\r\n\r\n /// Checks that all elements in the collection satisfies a given predicate.\r\n /// The predicate to check for each element.\r\n /// True if all elements satisfy a given predicate; False otherwise.\r\n /// This method traverses the whole collection and checks the value of the predicate for each element. This method\r\n /// stops on the first element for which the predicate returns False. The logical equivalent of this operation is \"AND\".\r\n /// is nil.\r\n function All(const APredicate: TPredicate): Boolean; virtual;\r\n\r\n /// Checks whether the elements in this collection are equal to the elements in another collection.\r\n /// The collection to compare to.\r\n /// True if the collections are equal; False if the collections are different.\r\n /// This method checks that each element at position X in this collection is equal to an element at position X in\r\n /// the provided collection. If the number of elements in both collections is different, then the collections are considered different.\r\n /// Note that comparison of element is done using the rule set used by this collection. This means that comparing this collection\r\n /// to another one might yield a different result than comparing the other collection to this one.\r\n /// is nil.\r\n function EqualsTo(const ACollection: IEnumerable): Boolean; virtual;\r\n\r\n /// Selects only the elements that satisfy a given rule.\r\n /// The predicate that represents the rule.\r\n /// A new collection that contains only the elements that satisfy the given rule.\r\n /// is nil.\r\n function Where(const APredicate: TPredicate): ISequence;\r\n\r\n /// Selects only the elements that do not satisfy a given rule.\r\n /// The predicate that represents the rule.\r\n /// A new collection that contains only the elements that do not satisfy the given rule.\r\n /// is nil.\r\n function WhereNot(const APredicate: TPredicate): ISequence;\r\n\r\n /// Selects only the elements that are less than a given value.\r\n /// The element to compare against.\r\n /// A new collection that contains only the elements that satisfy the relationship.\r\n function WhereLower(const ABound: T): ISequence;\r\n\r\n /// Selects only the elements that are less than or equal to a given value.\r\n /// The element to compare against.\r\n /// A new collection that contains only the elements that satisfy the relationship.\r\n function WhereLowerOrEqual(const ABound: T): ISequence;\r\n\r\n /// Selects only the elements that are greater than a given value.\r\n /// The element to compare against.\r\n /// A new collection that contains only the elements that satisfy the relationship.\r\n function WhereGreater(const ABound: T): ISequence;\r\n\r\n /// Selects only the elements that are greater than or equal to a given value.\r\n /// The element to compare against.\r\n /// A new collection that contains only the elements that satisfy the relationship.\r\n function WhereGreaterOrEqual(const ABound: T): ISequence;\r\n\r\n /// Selects only the elements whose values are contained whithin a given interval.\r\n /// The lower bound.\r\n /// The upper bound.\r\n /// A new collection that contains only the elements that satisfy the relationship.\r\n /// The elements that are equal to the lower or upper bound are also included.\r\n function WhereBetween(const ALower, AHigher: T): ISequence;\r\n\r\n /// Selects all the elements from the collection excluding duplicates.\r\n /// A new collection that contains the distinct elements.\r\n function Distinct(): ISequence; virtual;\r\n\r\n /// Returns a new ordered collection that contains the elements from this collection.\r\n /// Specifies whether the elements are ordered in an ascending or descending way.\r\n /// A new ordered collection.\r\n function Ordered(const AAscending: Boolean = true): ISequence; overload; virtual;\r\n\r\n /// Returns a new ordered collection that contains the elements from this collection.\r\n /// The comparison method.\r\n /// A new ordered collection.\r\n /// is nil.\r\n function Ordered(const ASortProc: TComparison): ISequence; overload; virtual;\r\n\r\n /// Revereses the contents of the collection.\r\n /// A new collection that contains the elements from this collection but in reverse order.\r\n function Reversed(): ISequence; virtual;\r\n\r\n /// Concatenates this collection with another collection.\r\n /// A collection to concatenate.\r\n /// A new collection that contains the elements from this collection followed by elements\r\n /// from the given collection.\r\n /// is nil.\r\n function Concat(const ACollection: ISequence): ISequence;\r\n\r\n /// Creates a new collection that contains the elements from both collections, taken a single time.\r\n /// The collection to unify with.\r\n /// A new collection that contains the elements from this collection followed by elements\r\n /// from the given collection except the elements that already are present in this collection. This operation can be seen as\r\n /// a \"concat\" operation followed by a \"distinct\" operation. \r\n /// is nil.\r\n function Union(const ACollection: ISequence): ISequence;\r\n\r\n /// Creates a new collection that contains the elements from this collection minus the ones in the given collection.\r\n /// The collection to exclude.\r\n /// A new collection that contains the elements from this collection minus those elements that are common between\r\n /// this and the given collection.\r\n /// is nil.\r\n function Exclude(const ACollection: ISequence): ISequence;\r\n\r\n /// Creates a new collection that contains the elements that are present in both collections.\r\n /// The collection to interset with.\r\n /// A new collection that contains the elements that are common to both collections.\r\n /// is nil.\r\n function Intersect(const ACollection: ISequence): ISequence;\r\n\r\n /// Select the elements whose indexes are located in the given range.\r\n /// The lower bound.\r\n /// The upper bound.\r\n /// A new collection that contains the elements whose indexes in this collection are located between \r\n /// and . Note that this method does not check the indexes. This means that a bad combination of parameters will\r\n /// simply result in an empty or incorrect result.\r\n function Range(const AStart, AEnd: NativeInt): ISequence;\r\n\r\n /// Selects only a given amount of elements.\r\n /// The number of elements to select.\r\n /// A new collection that contains only the first elements.\r\n /// is zero.\r\n function Take(const ACount: NativeInt): ISequence;\r\n\r\n /// Selects all the elements from the collection while a given rule is satisfied.\r\n /// The rule to satisfy.\r\n /// A new collection that contains the selected elements.\r\n /// This method selects all elements from the collection while the given rule is satisfied.\r\n /// is nil.\r\n function TakeWhile(const APredicate: TPredicate): ISequence;\r\n\r\n /// Selects all the elements from the collection while elements are lower than a given value.\r\n /// The value to check against.\r\n /// A new collection that contains the selected elements.\r\n /// This method selects all elements from the collection while the given rule is satisfied.\r\n function TakeWhileLower(const ABound: T): ISequence;\r\n\r\n /// Selects all the elements from the collection while elements are lower than\r\n /// or equal to a given value.\r\n /// The value to check against.\r\n /// A new collection that contains the selected elements.\r\n /// This method selects all elements from the collection while the given rule is satisfied.\r\n function TakeWhileLowerOrEqual(const ABound: T): ISequence;\r\n\r\n /// Selects all the elements from the collection while elements are greater than\r\n /// a given value.\r\n /// The value to check against.\r\n /// A new collection that contains the selected elements.\r\n /// This method selects all elements from the collection while the given rule is satisfied.\r\n function TakeWhileGreater(const ABound: T): ISequence;\r\n\r\n /// Selects all the elements from the collection while elements are greater than\r\n /// or equal to a given value.\r\n /// The value to check against.\r\n /// A new collection that contains the selected elements.\r\n /// This method selects all elements from the collection while the given rule is satisfied.\r\n function TakeWhileGreaterOrEqual(const ABound: T): ISequence;\r\n\r\n /// Selects all the elements from the collection while elements are between a given range of values.\r\n /// The lower bound.\r\n /// The higher bound.\r\n /// A new collection that contains the selected elements.\r\n /// This method selects all elements from the collection while the given rule is satisfied.\r\n function TakeWhileBetween(const ALower, AHigher: T): ISequence;\r\n\r\n /// Skips a given amount of elements.\r\n /// The number of elements to skip.\r\n /// A new collection that contains the elements that were not skipped.\r\n /// is zero.\r\n function Skip(const ACount: NativeInt): ISequence;\r\n\r\n /// Skips all the elements from the collection while a given rule is satisfied.\r\n /// The rule to satisfy.\r\n /// A new collection that contains the elements that were not skipped.\r\n /// is nil.\r\n function SkipWhile(const APredicate: TPredicate): ISequence;\r\n\r\n /// Skips all the elements from the collection while elements are lower than a given value.\r\n /// The value to check.\r\n /// A new collection that contains the elements that were not skipped.\r\n function SkipWhileLower(const ABound: T): ISequence;\r\n\r\n /// Skips all the elements from the collection while elements are lower than or equal to a given value.\r\n /// The value to check.\r\n /// A new collection that contains the elements that were not skipped.\r\n function SkipWhileLowerOrEqual(const ABound: T): ISequence;\r\n\r\n /// Skips all the elements from the collection while elements are greater than a given value.\r\n /// The value to check.\r\n /// A new collection that contains the elements that were not skipped.\r\n function SkipWhileGreater(const ABound: T): ISequence;\r\n\r\n /// Skips all the elements from the collection while elements are greater than or equal to a given value.\r\n /// The value to check.\r\n /// A new collection that contains the elements that were not skipped.\r\n function SkipWhileGreaterOrEqual(const ABound: T): ISequence;\r\n\r\n /// Skips all the elements from the collection while elements are between a given range of values.\r\n /// The lower bound.\r\n /// The higher bound.\r\n /// A new collection that contains the elements that were not skipped.\r\n function SkipWhileBetween(const ALower, AHigher: T): ISequence;\r\n\r\n /// Exposes a type that provides extended Enex operations such as \"select\".\r\n /// A record that exposes more Enex operations that otherwise would be impossible.\r\n function Op: TEnexExtOps;\r\n\r\n /// Creates a new list containing the elements of this collection.\r\n /// A list containing the elements copied from this collection.\r\n /// This method also copies the rule set of this collection. Be careful if the rule set\r\n /// performs cleanup on the elements.\r\n function ToList(): IList;\r\n\r\n /// Creates a new set containing the elements of this collection.\r\n /// A set containing the elements copied from this collection.\r\n /// This method also copies the rule set of this collection. Be careful if the rule set\r\n /// performs cleanup on the elements.\r\n function ToSet(): ISet;\r\n\r\n /// Compares the elements in this collection to another collection.\r\n /// The instance to compare against.\r\n /// An integer value depicting the result of the comparison operation.\r\n /// If the result is less than zero, Self is less than . If the result is zero,\r\n /// Self is equal to . And finally, if the result is greater than zero, Self is greater\r\n /// than .\r\n function CompareTo(AObject: TObject): Integer;\r\n\r\n /// Generates the hash code of all the elements in the collection.\r\n /// An integer value representing the hash codes of all the elements in the collection.\r\n function GetHashCode(): Integer; override;\r\n\r\n /// Checks whether this collection is equal to another collection.\r\n /// The collection to check against.\r\n /// True if the collections are equal; False otherwise.\r\n /// This method checks whether is not nil, and that\r\n /// is an Enex collection. Then, elements are checked for equality one by one.\r\n function Equals(Obj: TObject): Boolean; override;\r\n\r\n /// Generates a new collection that contains a given value for a given number of times.\r\n /// The element to fill the collection with.\r\n /// The number of times the element is present in the collection (the length of the collection).\r\n /// The rule set describing the elements in the new collection.\r\n /// A new collection containing the , times.\r\n /// is nil.\r\n /// is zero or less.\r\n class function Fill(const AElement: T; const ACount: NativeInt; const ARules: TRules): ISequence; overload; static;\r\n\r\n /// Generates a new collection that contains a given value for a given number of times.\r\n /// The element to fill the collection with.\r\n /// The number of times the element is present in the collection (the length of the collection).\r\n /// A new collection containing the , times.\r\n /// is zero or less.\r\n class function Fill(const AElement: T; const ACount: NativeInt): ISequence; overload; static;\r\n end;\r\n\r\n /// The base abstract class for simple (non-associative) collections.\r\n /// This collection exposes some operations that need to be implemented in descending classes and some\r\n /// default implementations using Enex operations.\r\n TCollection = class abstract(TSequence, ICollection)\r\n private\r\n FRemoveNotification: TRemoveNotification;\r\n\r\n protected\r\n /// Override in descendant classed to properly handle elements that are removed from\r\n /// the collection.\r\n /// The element being removed.\r\n /// This method is called by the collection when an element is removed and the caller has\r\n /// no possibility of obtaining it. For example, a call to Clear calls this method for each element\r\n /// of the collection.\r\n procedure HandleElementRemoved(const AElement: T); virtual;\r\n\r\n /// Call this method in descendant collections to properly invoke the removal mechanism.\r\n /// The element being removed.\r\n /// This method verifies if a custom removal notification is registered and calls it. Otherwise the normal\r\n /// removal mechanisms are involved.\r\n procedure NotifyElementRemoved(const AElement: T);\r\n public\r\n /// Destroys this instance.\r\n /// Do not call this method directly; call Free instead.\r\n destructor Destroy(); override;\r\n\r\n /// Specifies a custom remove notification method that will be called by this\r\n /// collection when elements are removed.\r\n /// The notification method.\r\n property RemoveNotification: TRemoveNotification read FRemoveNotification write FRemoveNotification;\r\n\r\n /// Clears the contents of the collection.\r\n /// This implementation uses Enex First operation to obtain the first element and then calls Remove to remove it.\r\n /// If Remove method is not overridden.\r\n procedure Clear(); virtual;\r\n\r\n /// Appends an element to the back of the list.\r\n /// The value to append.\r\n /// Always raised in this implementation.\r\n procedure Add(const AValue: T); virtual;\r\n\r\n /// Adds all the elements from a collection to this collection.\r\n /// The values to add.\r\n /// Where exactly the elements are added is unspecified and depends on the implementing collection. This method calls Add for each element\r\n /// in the supplied collection. For most descending collections this is OK.\r\n /// If Add method is not overridden.\r\n /// is nil.\r\n procedure AddAll(const ACollection: IEnumerable); virtual;\r\n\r\n /// Removes a given value from the collection.\r\n /// The value to remove.\r\n /// If the collection does not contain the given value, nothing happens.\r\n /// Always raised in this implementation.\r\n procedure Remove(const AValue: T); virtual;\r\n\r\n /// Removes all the elements from a collection that are also found in this collection.\r\n /// The values to remove.\r\n /// This implementation calls Remove for each element in the collection.\r\n /// is nil.\r\n /// If Remove method is not overridden.\r\n procedure RemoveAll(const ACollection: IEnumerable); virtual;\r\n\r\n /// Checks whether a specified element is contained in this collection.\r\n /// The value to check for.\r\n /// True if the value was found in the collection; False otherwise.\r\n /// The implementation in this class iterates over all elements and checks for the requested\r\n /// value. Most descendant classes will likely provide a better version.\r\n function Contains(const AValue: T): Boolean; virtual;\r\n\r\n /// Checks whether all the elements from a specified collection are contained in this collection.\r\n /// The value to check for.\r\n /// True if the values were found in the collection; False otherwise.\r\n /// The current implementation calls Contains on each individual element from the supplied collection.\r\n function ContainsAll(const ACollection: IEnumerable): Boolean; virtual;\r\n end;\r\n\r\n /// Base class for all associative Enex collections.\r\n /// All associative collections (ex. dictionary or multi-map) are derived from this base class.\r\n /// It implements the extended Enex operations based on enumerability.\r\n TAssociation = class abstract(TAbstractContainer>, IAssociation)\r\n private\r\n FKeyRules: TRules;\r\n FValueRules: TRules;\r\n FKeyRemoveNotification: TRemoveNotification;\r\n FValueRemoveNotification: TRemoveNotification;\r\n\r\n protected\r\n /// Specifies a custom remove notification method that will be called by this\r\n /// collection when keys are removed.\r\n /// The notification method.\r\n property KeyRemoveNotification: TRemoveNotification read FKeyRemoveNotification write FKeyRemoveNotification;\r\n\r\n /// Specifies a custom remove notification method that will be called by this\r\n /// collection when values are removed.\r\n /// The notification method.\r\n property ValueRemoveNotification: TRemoveNotification read FValueRemoveNotification write FValueRemoveNotification;\r\n\r\n /// Compares two keys for equality.\r\n /// The first key.\r\n /// The second key.\r\n /// True if the keys are equal; False otherwise.\r\n /// This method uses the equality comparer. If such a comparer was not provided\r\n /// a default one is requested.\r\n function KeysAreEqual(const ALeft, ARight: TKey): Boolean;\r\n\r\n /// Compares two keys.\r\n /// The first key.\r\n /// The second key.\r\n /// A value less than zero if is less than .\r\n /// A value greater than zero if is greater than . Zero if\r\n /// is equal to .\r\n /// This method uses the comparer. If such a comparer was not provided\r\n /// a default one is requested.\r\n function CompareKeys(const ALeft, ARight: TKey): NativeInt;\r\n\r\n /// Generates a hash code for the given key.\r\n /// The key.\r\n /// The calculated hash code.\r\n /// This method uses the equality comparer. If such a comparer was not provided\r\n /// a default one is requested.\r\n function GetKeyHashCode(const AValue: TKey): NativeInt; overload;\r\n\r\n /// Compares two values for equality.\r\n /// The first value.\r\n /// The second value.\r\n /// True if the keys are equal; False otherwise.\r\n /// This method uses the equality comparer. If such a comparer was not provided\r\n /// a default one is requested.\r\n function ValuesAreEqual(const ALeft, ARight: TValue): Boolean;\r\n\r\n /// Compares two values.\r\n /// The first value.\r\n /// The second value.\r\n /// A value less than zero if is less than .\r\n /// A value greater than zero if is greater than . Zero if\r\n /// is equal to .\r\n /// This method uses the comparer. If such a comparer was not provided\r\n /// a default one is requested.\r\n function CompareValues(const ALeft, ARight: TValue): NativeInt;\r\n\r\n /// Generates a hash code for the given value.\r\n /// The value.\r\n /// The calculated hash code.\r\n /// This method uses the equality comparer. If such a comparer was not provided\r\n /// a default one is requested.\r\n function GetValueHashCode(const AValue: TValue): NativeInt; overload;\r\n\r\n /// Specifies the rule set that describes the keys of the stored pairs.\r\n /// A rule set describing the keys.\r\n property KeyRules: TRules read FKeyRules;\r\n\r\n /// Specifies the rule set that describes the values of the stored pairs.\r\n /// A rule set describing the values.\r\n property ValueRules: TRules read FValueRules;\r\n\r\n /// Override in descendent classed to properly handle keys that are removed from\r\n /// the collection.\r\n /// The key being removed.\r\n /// This method is called by the collection when a key is removed and the caller has\r\n /// no possibility of obtaining it. For example, a call to Clear calls this method for each key\r\n /// of the collection.\r\n procedure HandleKeyRemoved(const AKey: TKey); virtual;\r\n\r\n /// Override in descendaet classed to properly handle values that are removed from\r\n /// the collection.\r\n /// The key being removed.\r\n /// This method is called by the collection when a value is removed and the caller has\r\n /// no possibility of obtaining it. For example, a call to Clear calls this method for each value\r\n /// of the collection.\r\n procedure HandleValueRemoved(const AValue: TValue); virtual;\r\n\r\n /// Call this method in descendent collections to properly invoke the removal mechanism.\r\n /// The key being removed.\r\n /// This method verifies whether a custom removal notification is registered and calls it. Otherwise the normal\r\n /// removal mechanisms are involved.\r\n procedure NotifyKeyRemoved(const AKey: TKey);\r\n\r\n /// Call this method in descendent collections to properly invoke the removal mechanism.\r\n /// The key being removed.\r\n /// This method verifies whether a custom removal notification is registered and calls it. Otherwise the normal\r\n /// removal mechanisms are involved.\r\n procedure NotifyValueRemoved(const AValue: TValue);\r\n public\r\n /// Instantiates this class.\r\n /// The default comparer and equality comparer are requested if this constructor is used. Do not call this method if\r\n /// you don't know what you are doing.\r\n constructor Create(); overload;\r\n\r\n /// Instantiates this class.\r\n /// The rules set used by the collection for its keys.\r\n /// The rules set used by the collection for its values.\r\n /// The provided rules set is used by this collection. This constructor must be called from descendent collections.\r\n constructor Create(const AKeyRules: TRules; const AValueRules: TRules); overload;\r\n\r\n /// Returns the value associated with the given key.\r\n /// The key for which to return the associated value.\r\n /// The value associated with the given key.\r\n /// No such key in the collection.\r\n function ValueForKey(const AKey: TKey): TValue; virtual;\r\n\r\n /// Checks whether the collection contains a given key-value pair.\r\n /// The key part of the pair.\r\n /// The value part of the pair.\r\n /// True if the given key-value pair exists; False otherwise.\r\n function KeyHasValue(const AKey: TKey; const AValue: TValue): Boolean; virtual;\r\n\r\n /// Returns the biggest key.\r\n /// The biggest key stored in the collection.\r\n /// The collection is empty.\r\n function MaxKey(): TKey; virtual;\r\n\r\n /// Returns the smallest key.\r\n /// The smallest key stored in the collection.\r\n /// The collection is empty.\r\n function MinKey(): TKey; virtual;\r\n\r\n /// Returns the biggest value.\r\n /// The biggest value stored in the collection.\r\n /// The collection is empty.\r\n function MaxValue(): TValue; virtual;\r\n\r\n /// Returns the smallest value.\r\n /// The smallest value stored in the collection.\r\n /// The collection is empty.\r\n function MinValue(): TValue; virtual;\r\n\r\n /// Checks whether this collection includes the key-value pairs in another collection.\r\n /// The collection to check against.\r\n /// True if this collection includes the elements in another; False otherwise.\r\n function Includes(const ACollection: IEnumerable>): Boolean; virtual;\r\n\r\n /// Returns an Enex collection that contains only the keys.\r\n /// An Enex collection that contains all the keys stored in the collection.\r\n function SelectKeys(): ISequence; virtual;\r\n\r\n /// Returns an Enex collection that contains only the values.\r\n /// An Enex collection that contains all the values stored in the collection.\r\n function SelectValues(): ISequence; virtual;\r\n\r\n /// Selects all the key-value pairs from the collection excluding the duplicates by key.\r\n /// A new collection that contains the distinct pairs.\r\n function DistinctByKeys(): IAssociation;\r\n\r\n /// Selects all the key-value pairs from the collection excluding the duplicates by value.\r\n /// A new collection that contains the distinct pairs.\r\n function DistinctByValues(): IAssociation;\r\n\r\n /// Selects only the key-value pairs that satisfy a given rule.\r\n /// The predicate that represents the rule.\r\n /// A new collection that contains only the pairs that satisfy the given rule.\r\n /// is nil.\r\n function Where(const APredicate: TPredicate): IAssociation;\r\n\r\n /// Selects only the key-value pairs that do not satisfy a given rule.\r\n /// The predicate that represents the rule.\r\n /// A new collection that contains only the pairs that do not satisfy the given rule.\r\n /// is nil.\r\n function WhereNot(const APredicate: TPredicate): IAssociation;\r\n\r\n /// Selects only the key-value pairs whose keys are less than a given value.\r\n /// The value to compare against.\r\n /// A new collection that contains only the pairs that satisfy the relationship.\r\n function WhereKeyLower(const ABound: TKey): IAssociation;\r\n\r\n /// Selects only the key-value pairs whose keys are less than or equal to a given value.\r\n /// The value to compare against.\r\n /// A new collection that contains only the pairs that satisfy the relationship.\r\n function WhereKeyLowerOrEqual(const ABound: TKey): IAssociation;\r\n\r\n /// Selects only the key-value pairs whose keys are greater than a given value.\r\n /// The value to compare against.\r\n /// A new collection that contains only the pairs that satisfy the relationship.\r\n function WhereKeyGreater(const ABound: TKey): IAssociation;\r\n\r\n /// Selects only the key-value pairs whose keys are greater than or equal to a given value.\r\n /// The value to compare against.\r\n /// A new collection that contains only the pairs that satisfy the relationship.\r\n function WhereKeyGreaterOrEqual(const ABound: TKey): IAssociation;\r\n\r\n /// Selects only the key-value pairs whose keys are contained whithin a given interval.\r\n /// The lower bound.\r\n /// The upper bound.\r\n /// A new collection that contains only the pairs that satisfy the relationship.\r\n function WhereKeyBetween(const ALower, AHigher: TKey): IAssociation;\r\n\r\n /// Selects only the key-value pairs whose values are less than a given value.\r\n /// The value to compare against.\r\n /// A new collection that contains only the pairs that satisfy the relationship.\r\n function WhereValueLower(const ABound: TValue): IAssociation;\r\n\r\n /// Selects only the key-value pairs whose values are less than or equal to a given value.\r\n /// The value to compare against.\r\n /// A new collection that contains only the pairs that satisfy the relationship.\r\n function WhereValueLowerOrEqual(const ABound: TValue): IAssociation;\r\n\r\n /// Selects only the key-value pairs whose values are greater than a given value.\r\n /// The value to compare against.\r\n /// A new collection that contains only the pairs that satisfy the relationship.\r\n function WhereValueGreater(const ABound: TValue): IAssociation;\r\n\r\n /// Selects only the key-value pairs whose values are greater than or equal to a given value.\r\n /// The value to compare against.\r\n /// A new collection that contains only the pairs that satisfy the relationship.\r\n function WhereValueGreaterOrEqual(const ABound: TValue): IAssociation;\r\n\r\n /// Selects only the key-value pairs whose values are contained whithin a given interval.\r\n /// The lower bound.\r\n /// The upper bound.\r\n /// A new collection that contains only the pairs that satisfy the relationship.\r\n function WhereValueBetween(const ALower, AHigher: TValue): IAssociation;\r\n\r\n /// Creates a new dictionary containing the elements of this collection.\r\n /// A dictionary containing the elements copied from this collection.\r\n /// This method also copies the rule set of this collection. Be careful if the rule set\r\n /// performs cleanup on the elements.\r\n /// The collection contains more than\r\n /// one key-value pair with the same key.\r\n function ToDictionary(): IDictionary;\r\n end;\r\n\r\n /// The base abstract class for associtative collections.\r\n /// This collection exposes some operations that need to be implemented in descending classes and some\r\n /// default implementations using Enex operations.\r\n TAbstractMap = class abstract(TAssociation, IMap)\r\n public\r\n /// Destroys this instance.\r\n /// Do not call this method directly; call Free instead.\r\n destructor Destroy(); override;\r\n\r\n /// Clears the contents of the collection.\r\n /// This implementation uses Enex First operation on collection's keys to obtain key and then calls Remove to remove it along side its value.\r\n /// If Remove method is not overridden.\r\n procedure Clear(); virtual;\r\n\r\n /// Adds a key-value pair to the map.\r\n /// The key-value pair to add.\r\n /// The map already contains a pair with the given key.\r\n /// Always raised in this implementation.\r\n procedure Add(const APair: TPair); overload;\r\n\r\n /// Adds a key-value pair to the map.\r\n /// The key of pair.\r\n /// The value associated with the key.\r\n /// The map already contains a pair with the given key.\r\n /// Always raised in this implementation.\r\n procedure Add(const AKey: TKey; const AValue: TValue); overload; virtual;\r\n\r\n /// Adds a collection of key-value pairs to the map.\r\n /// The collection to add.\r\n /// The map already contains a pair with the given key.\r\n /// is nil.\r\n /// If Add method is not overridden.\r\n procedure AddAll(const ACollection: IEnumerable>); virtual;\r\n\r\n /// Removes a key-value pair using a given key.\r\n /// The key of pair.\r\n /// If the specified key was not found in the map, nothing happens.\r\n /// Always raised in this implementation.\r\n procedure Remove(const AKey: TKey); virtual;\r\n\r\n /// Checks whether the map contains a key-value pair identified by the given key.\r\n /// The key to check for.\r\n /// True if the map contains a pair identified by the given key; False otherwise.\r\n /// This implementation uses Enex operations to lookup the key. Most derived collections will override this method.\r\n function ContainsKey(const AKey: TKey): Boolean; virtual;\r\n\r\n /// Checks whether the map contains a key-value pair that contains a given value.\r\n /// The value to check for.\r\n /// True if the map contains a pair containing the given value; False otherwise.\r\n /// This implementation uses Enex operations to lookup the key. Most derived collections will override this method.\r\n function ContainsValue(const AValue: TValue): Boolean; virtual;\r\n end;\r\n\r\n {$ENDREGION}\r\n\r\n{$REGION 'Exception Support'}\r\ntype\r\n /// Thrown when an attempt to call an unsupported default parameterless constructor is made.\r\n EDefaultConstructorNotAllowed = class(Exception);\r\n\r\n /// Thrown when a Collections.Base.TRefCountedObject tries to keep itself alive.\r\n ECannotSelfReferenceException = class(Exception);\r\n\r\n{$IF RTLVersion < 22}\r\n /// Thrown when a given argument is nil.\r\n /// This exception is normally provided by Delphi XE's SysUtils.pas.\r\n EArgumentNilException = class(EArgumentException);\r\n{$IFEND}\r\n\r\n /// Thrown when a given argument combination specifies a smaller range than required.\r\n /// This exception is usually used by collections. The exception is thrown when there is not enough\r\n /// space in an array to copy the values to.\r\n EArgumentOutOfSpaceException = class(EArgumentOutOfRangeException);\r\n\r\n /// Represents all exceptions that are thrown when collections are involved.\r\n ECollectionException = class(Exception);\r\n\r\n /// Thrown when an enumerator detects that the enumerated collection was changed.\r\n ECollectionChangedException = class(ECollectionException);\r\n\r\n /// Thrown when a collection was identified to be empty (and it shouldn't have been).\r\n ECollectionEmptyException = class(ECollectionException);\r\n\r\n /// Thrown when a collection was expected to have only one element, but more than one was found.\r\n ECollectionNotOneException = class(ECollectionException);\r\n\r\n /// Thrown when a predicated applied to a collection generates a void collection.\r\n ECollectionFilteredEmptyException = class(ECollectionException);\r\n\r\n /// Thrown when trying to add a key-value pair into a collection that already has that key\r\n /// in it.\r\n EDuplicateKeyException = class(ECollectionException);\r\n\r\n /// Thrown for a serialization or deserialization error.\r\n ESerializationException = class(Exception);\r\n\r\n /// Thrown when the key (of a pair) is not found in the collection.\r\n EKeyNotFoundException = class(ECollectionException);\r\n\r\n /// A static class that offers methods for throwing exceptions.\r\n /// Collections.Base.ExceptionHelper is used internally in this package to\r\n /// throw all kinds of exceptions. This class is useful because it separates the exceptions\r\n /// (including the messages) from the rest of the code.\r\n ExceptionHelper = class sealed\r\n public\r\n /// Internal method. Do not call directly!\r\n /// The interface of this function may change in the future.\r\n class procedure Throw_CannotSelfReferenceError();\r\n\r\n /// Internal method. Do not call directly!\r\n /// The interface of this function may change in the future.\r\n class procedure Throw_ArgumentNilError(const ArgName: String);\r\n\r\n /// Internal method. Do not call directly!\r\n /// The interface of this function may change in the future.\r\n class procedure Throw_ArgumentOutOfRangeError(const ArgName: String);\r\n\r\n /// Internal method. Do not call directly!\r\n /// The interface of this function may change in the future.\r\n class procedure Throw_ArgumentOutOfSpaceError(const ArgName: String);\r\n\r\n /// Internal method. Do not call directly!\r\n /// The interface of this function may change in the future.\r\n class procedure Throw_OperationNotSupported(const AOperation: String);\r\n\r\n /// Internal method. Do not call directly!\r\n /// The interface of this function may change in the future.\r\n class procedure Throw_CollectionChangedError();\r\n\r\n /// Internal method. Do not call directly!\r\n /// The interface of this function may change in the future.\r\n class procedure Throw_CollectionEmptyError();\r\n\r\n /// Internal method. Do not call directly!\r\n /// The interface of this function may change in the future.\r\n class procedure Throw_CollectionHasMoreThanOneElement();\r\n\r\n /// Internal method. Do not call directly!\r\n /// The interface of this function may change in the future.\r\n class procedure Throw_CollectionHasNoFilteredElements();\r\n\r\n /// Internal method. Do not call directly!\r\n /// The interface of this function may change in the future.\r\n class procedure Throw_DuplicateKeyError(const ArgName: String);\r\n\r\n /// Internal method. Do not call directly!\r\n /// The interface of this function may change in the future.\r\n class procedure Throw_KeyNotFoundError(const ArgName: String);\r\n\r\n /// Internal method. Do not call directly!\r\n /// The interface of this function may change in the future.\r\n class procedure Throw_TypeNotAClassError(const TypeName: String);\r\n\r\n /// Internal method. Do not call directly!\r\n /// The interface of this function may change in the future.\r\n class procedure Throw_TypeDoesNotExposeMember(const MemberName: String);\r\n\r\n /// Internal method. Do not call directly!\r\n /// The interface of this function may change in the future.\r\n class procedure Throw_TypeCannotBeSerialized(const ATypeInfo: PTypeInfo);\r\n\r\n /// Internal method. Do not call directly!\r\n /// The interface of this function may change in the future.\r\n class procedure Throw_TypeDoesNotHaveEnoughRtti(const ATypeInfo: PTypeInfo);\r\n\r\n /// Internal method. Do not call directly!\r\n /// The interface of this function may change in the future.\r\n class procedure Throw_FieldTypeDoesNotHaveEnoughRtti(const AField: TRttiField);\r\n\r\n /// Internal method. Do not call directly!\r\n /// The interface of this function may change in the future.\r\n class procedure Throw_BadDynamicArrayReference(const ATypeInfo: PTypeInfo);\r\n\r\n /// Internal method. Do not call directly!\r\n /// The interface of this function may change in the future.\r\n class procedure Throw_BadRecordReference(const ATypeInfo: PTypeInfo);\r\n\r\n /// Internal method. Do not call directly!\r\n /// The interface of this function may change in the future.\r\n class procedure Throw_BadClassReference(const ATypeInfo: PTypeInfo);\r\n\r\n /// Internal method. Do not call directly!\r\n /// The interface of this function may change in the future.\r\n class procedure Throw_ExpectedAnotherBinaryValuePoint(); static;\r\n\r\n /// Internal method. Do not call directly!\r\n /// The interface of this function may change in the future.\r\n class procedure Throw_ExpectedAnotherField(const AExpected: TRttiField; const AName: string; AOffset: Int64);\r\n\r\n /// Internal method. Do not call directly!\r\n /// The interface of this function may change in the future.\r\n class procedure Throw_ExpectedAnotherLabel(const AExpectedLabel, AActualLabel: string);\r\n\r\n /// Internal method. Do not call directly!\r\n /// The interface of this function may change in the future.\r\n class procedure Throw_ExpectedAnotherElementCount(const AArrayType: TRttiArrayType; const AExpectedCount, AActualCount: NativeInt);\r\n\r\n /// Internal method. Do not call directly!\r\n /// The interface of this function may change in the future.\r\n class procedure Throw_ExpectedAnotherType(const AExpected: TRttiType; const AActual: string);\r\n\r\n /// Internal method. Do not call directly!\r\n /// The interface of this function may change in the future.\r\n class procedure Throw_ExpectedAnotherSetSize(const AExpectedSize, AActualSize: NativeInt);\r\n end;\r\n\r\nresourcestring\r\n SDefaultParameterlessCtorNotAllowed = 'Default parameterless constructor not allowed!';\r\n SCannotSelfReference = 'The object cannot self-reference!';\r\n SNilArgument = 'Argument \"%s\" is nil. Expected a normal non-disposed object!';\r\n SOutOfRangeArgument = 'Argument \"%s\" is out of range. An argument that falls into the required range of values is expected!';\r\n SOutOfSpaceArgument = 'Argument \"%s\" does not have enough space to hold the result!';\r\n SParentCollectionChanged = 'Parent collection has changed. Cannot continue the operation!';\r\n SKeyNotFound = 'The key given by the \"%s\" argument was not found in the collection!';\r\n SDuplicateKey = 'The key given by the \"%s\" argument was already registered in the collection!';\r\n SEmptyCollection = 'The collection is empty! The operation cannot be performed!';\r\n SOperationNotSupported = 'The request collection operation %s is not supported by this instance.';\r\n SCollectionHasMoreThanOneElements = 'The collection has more than one element!';\r\n SCollectionHasNoFilteredElements = 'The applied predicate generates a void collection.';\r\n STypeNotAClass = 'The type \"%s\" on which the operation was invoked is not a class!';\r\n STypeDoesNotExposeMember = 'The type the collection operates on does not expose member \"%s\"!';\r\n STypeCannotBeSerialized = 'Serialization for values of type %s (kind: %s) is not supported.';\r\n STypeDoesNotHaveEnoughRtti = 'Type %s (kind %s) does not have enough RTTI to be serializable.';\r\n SFieldTypeDoesNotHaveEnoughRtti = 'Field %s member of type %s (kind %s) does not have enough RTTI to be serializable.';\r\n SBadDynamicArrayReference = 'Dynamic array of type %s (kind %s) cannot be deserialized because it is a reference to an unavailable dynamic array.';\r\n SBadRecordReference = 'Record of type %s (kind %s) cannot be deserialized because it is a reference to an unavailable record.';\r\n SBadClassReference = 'Class of type %s (kind %s) cannot be deserialized because it is a reference to an unavailable class.';\r\n SExpectedAnotherBinaryValuePoint = 'Found a binary stream point that was unexpected while deserializing.';\r\n SExpectedAnotherField = 'Expected a field %s with offset %d, but got a field %s with offset %d!';\r\n SExpectedAnotherLabel = 'Expected a label %s , but got a label %s!';\r\n SExpectedAnotherElementCount = 'Expected a static array of type %s with %d elements but got %d elements.';\r\n SExpectedAnotherType = 'Expected a type %s, but got another type %s!';\r\n SExpectedAnotherSetSize = 'When deserializing a set expected it to have %d bytes but got %d bytes!';\r\n{$ENDREGION}\r\n\r\n{$REGION 'Enex Internal Enumerables'}\r\ntype\r\n //private type\r\n TWhereSequence = class sealed(TSequence)\r\n private type\r\n TEnumerator = class(TForwardingEnumerator)\r\n public\r\n function AcceptValue(const AValue: T): Boolean; override;\r\n end;\r\n\r\n private\r\n FCollection: TSequence;\r\n FPredicate: TPredicate;\r\n FInvertResult: Boolean;\r\n\r\n public\r\n constructor Create(const ACollection: TSequence;\r\n const APredicate: TPredicate; const AInvertResult: Boolean); overload;\r\n destructor Destroy(); override;\r\n function GetEnumerator(): IEnumerator; override;\r\n end;\r\n\r\n TSelectSequence = class sealed(TSequence)\r\n private type\r\n TEnumerator = class(TAbstractEnumerator)\r\n private\r\n FInEnumerator: IEnumerator;\r\n public\r\n function TryMoveNext(out ACurrent: TOut): Boolean; override;\r\n end;\r\n\r\n private\r\n FCollection: TSequence;\r\n FSelector: TFunc;\r\n\r\n protected\r\n function GetCount(): NativeInt; override;\r\n public\r\n constructor Create(const ACollection: TSequence; const ASelector: TFunc; const ARules: TRules); overload;\r\n destructor Destroy(); override;\r\n function GetEnumerator(): IEnumerator; override;\r\n function Empty(): Boolean; override;\r\n function First(): TOut; override;\r\n function Last(): TOut; override;\r\n function Single(): TOut; override;\r\n function ElementAt(const AIndex: NativeInt): TOut; override;\r\n end;\r\n\r\n TSelectClassSequence = class sealed(TSequence)\r\n private type\r\n TEnumerator = class(TAbstractEnumerator)\r\n private\r\n FInEnumerator: IEnumerator;\r\n public\r\n function TryMoveNext(out ACurrent: TOut): Boolean; override;\r\n end;\r\n\r\n private\r\n FCollection: TSequence;\r\n\r\n public\r\n constructor Create(const ACollection: TSequence; const ARules: TRules); overload;\r\n destructor Destroy(); override;\r\n function GetEnumerator(): IEnumerator; override;\r\n end;\r\n\r\n TConcatSequence = class sealed(TSequence)\r\n private type\r\n TEnumerator = class(TAbstractEnumerator)\r\n private\r\n FInEnumerator1, FInEnumerator2: IEnumerator;\r\n public\r\n function TryMoveNext(out ACurrent: T): Boolean; override;\r\n end;\r\n\r\n private\r\n FCollection1: TSequence;\r\n FCollection2: ISequence;\r\n protected\r\n function GetCount(): NativeInt; override;\r\n\r\n public\r\n constructor Create(const ACollection1: TSequence; const ACollection2: ISequence); overload;\r\n destructor Destroy(); override;\r\n function GetEnumerator(): IEnumerator; override;\r\n function Empty(): Boolean; override;\r\n function Any(const APredicate: TPredicate): Boolean; override;\r\n function All(const APredicate: TPredicate): Boolean; override;\r\n end;\r\n\r\n TUnionSequence = class sealed(TSequence)\r\n private type\r\n TEnumerator = class(TAbstractEnumerator)\r\n private\r\n FInEnumerator1, FInEnumerator2: IEnumerator;\r\n FSet: ISet;\r\n public\r\n function TryMoveNext(out ACurrent: T): Boolean; override;\r\n end;\r\n\r\n private\r\n FCollection1: TSequence;\r\n FCollection2: ISequence;\r\n public\r\n constructor Create(const ACollection1: TSequence; const ACollection2: ISequence); overload;\r\n destructor Destroy(); override;\r\n function GetEnumerator(): IEnumerator; override;\r\n end;\r\n\r\n TExclusionSequence = class sealed(TSequence)\r\n private type\r\n TEnumerator = class(TAbstractEnumerator)\r\n private\r\n FInEnumerator1, FInEnumerator2: IEnumerator;\r\n FSet: ISet;\r\n public\r\n function TryMoveNext(out ACurrent: T): Boolean; override;\r\n end;\r\n\r\n private\r\n FCollection1: TSequence;\r\n FCollection2: ISequence;\r\n public\r\n constructor Create(const ACollection1: TSequence; const ACollection2: ISequence); overload;\r\n destructor Destroy(); override;\r\n function GetEnumerator(): IEnumerator; override;\r\n end;\r\n\r\n TIntersectionSequence = class sealed(TSequence)\r\n private type\r\n TEnumerator = class(TAbstractEnumerator)\r\n private\r\n FInEnumerator1, FInEnumerator2: IEnumerator;\r\n FSet: ISet;\r\n public\r\n function TryMoveNext(out ACurrent: T): Boolean; override;\r\n end;\r\n\r\n private\r\n FCollection1: TSequence;\r\n FCollection2: ISequence;\r\n public\r\n constructor Create(const ACollection1: TSequence; const ACollection2: ISequence); overload;\r\n destructor Destroy(); override;\r\n function GetEnumerator(): IEnumerator; override;\r\n end;\r\n\r\n TDistinctSequence = class sealed(TSequence)\r\n private type\r\n TEnumerator = class(TForwardingEnumerator)\r\n private\r\n FSet: ISet;\r\n public\r\n function AcceptValue(const AValue: T): Boolean; override;\r\n end;\r\n\r\n private\r\n FCollection: TSequence;\r\n\r\n public\r\n constructor Create(const ACollection: TSequence); overload;\r\n destructor Destroy(); override;\r\n function GetEnumerator(): IEnumerator; override;\r\n end;\r\n\r\n TRangeSequence = class sealed(TSequence)\r\n private type\r\n TEnumerator = class(TAbstractEnumerator)\r\n private\r\n FInEnumerator: IEnumerator;\r\n FCurrentIndex: NativeInt;\r\n public\r\n function TryMoveNext(out ACurrent: T): Boolean; override;\r\n end;\r\n\r\n private\r\n FStart, FEnd: NativeInt;\r\n FCollection: TSequence;\r\n\r\n public\r\n constructor Create(const ACollection: TSequence; const AStart, AEnd: NativeInt); overload;\r\n destructor Destroy(); override;\r\n function GetEnumerator(): IEnumerator; override;\r\n end;\r\n\r\n TSkipSequence = class sealed(TSequence)\r\n private type\r\n TEnumerator = class(TForwardingEnumerator)\r\n private\r\n FCurrentIndex: NativeInt;\r\n public\r\n function AcceptValue(const AValue: T): Boolean; override;\r\n end;\r\n\r\n private\r\n FCount: NativeInt;\r\n FCollection: TSequence;\r\n\r\n public\r\n constructor Create(const ACollection: TSequence; const ACount: NativeInt); overload;\r\n destructor Destroy(); override;\r\n function GetEnumerator(): IEnumerator; override;\r\n end;\r\n\r\n TTakeSequence = class sealed(TSequence)\r\n private type\r\n TEnumerator = class(TForwardingEnumerator)\r\n private\r\n FCurrentIndex: NativeInt;\r\n public\r\n function AcceptValue(const AValue: T): Boolean; override;\r\n end;\r\n\r\n private\r\n FCount: NativeInt;\r\n FCollection: TSequence;\r\n\r\n public\r\n constructor Create(const ACollection: TSequence; const ACount: NativeInt); overload;\r\n destructor Destroy(); override;\r\n function GetEnumerator(): IEnumerator; override;\r\n end;\r\n\r\n TFillSequence = class sealed(TSequence)\r\n private type\r\n TEnumerator = class(TAbstractEnumerator)\r\n private\r\n FRemaining: NativeInt;\r\n public\r\n function TryMoveNext(out ACurrent: T): Boolean; override;\r\n end;\r\n\r\n private\r\n FElement: T;\r\n FCount: NativeInt;\r\n\r\n protected\r\n function GetCount(): NativeInt; override;\r\n public\r\n constructor Create(const AElement: T; const ACount: NativeInt; const ARules: TRules);\r\n function GetEnumerator(): IEnumerator; override;\r\n function Empty(): Boolean; override;\r\n function Max(): T; override;\r\n function Min(): T; override;\r\n function First(): T; override;\r\n function FirstOrDefault(const ADefault: T): T; override;\r\n function Last(): T; override;\r\n function LastOrDefault(const ADefault: T): T; override;\r\n function Single(): T; override;\r\n function SingleOrDefault(const ADefault: T): T; override;\r\n function Aggregate(const AAggregator: TFunc): T; override;\r\n function AggregateOrDefault(const AAggregator: TFunc; const ADefault: T): T; override;\r\n function ElementAt(const AIndex: NativeInt): T; override;\r\n function ElementAtOrDefault(const AIndex: NativeInt; const ADefault: T): T; override;\r\n function Any(const APredicate: TPredicate): Boolean; override;\r\n function All(const APredicate: TPredicate): Boolean; override;\r\n function EqualsTo(const ACollection: IEnumerable): Boolean; override;\r\n end;\r\n\r\n TTakeWhileSequence = class sealed(TSequence)\r\n private type\r\n TEnumerator = class(TAbstractEnumerator)\r\n private\r\n FInEnumerator: IEnumerator;\r\n public\r\n function TryMoveNext(out ACurrent: T): Boolean; override;\r\n end;\r\n\r\n private\r\n FCollection: TSequence;\r\n FPredicate: TPredicate;\r\n\r\n public\r\n constructor Create(const ACollection: TSequence; const APredicate: TPredicate); overload;\r\n destructor Destroy(); override;\r\n function GetEnumerator(): IEnumerator; override;\r\n end;\r\n\r\n TSkipWhileSequence = class sealed(TSequence)\r\n private type\r\n TEnumerator = class(TForwardingEnumerator)\r\n private\r\n FStarted: Boolean;\r\n public\r\n function AcceptValue(const AValue: T): Boolean; override;\r\n end;\r\n\r\n private\r\n FCollection: TSequence;\r\n FPredicate: TPredicate;\r\n\r\n public\r\n constructor Create(const ACollection: TSequence; const APredicate: TPredicate); overload;\r\n destructor Destroy(); override;\r\n function GetEnumerator(): IEnumerator; override;\r\n end;\r\n\r\n TGroupBySequence = class sealed(TSequence>)\r\n private type\r\n TEnexGroupingCollection = class(TSequence, IGrouping)\r\n private\r\n FBy: TBy;\r\n FList: IList;\r\n public\r\n function GetKey(): TBy;\r\n function GetCount(): NativeInt; override;\r\n function GetEnumerator(): IEnumerator; override;\r\n procedure CopyTo(var AArray: array of T; const AStartIndex: NativeInt); overload; override;\r\n function Empty(): Boolean; override;\r\n function Max(): T; override;\r\n function Min(): T; override;\r\n function First(): T; override;\r\n function FirstOrDefault(const ADefault: T): T; override;\r\n function Last(): T; override;\r\n function LastOrDefault(const ADefault: T): T; override;\r\n function Single(): T; override;\r\n function SingleOrDefault(const ADefault: T): T; override;\r\n function Aggregate(const AAggregator: TFunc): T; override;\r\n function AggregateOrDefault(const AAggregator: TFunc; const ADefault: T): T; override;\r\n function ElementAt(const AIndex: NativeInt): T; override;\r\n function ElementAtOrDefault(const AIndex: NativeInt; const ADefault: T): T; override;\r\n function Any(const APredicate: TPredicate): Boolean; override;\r\n function All(const APredicate: TPredicate): Boolean; override;\r\n function EqualsTo(const ACollection: IEnumerable): Boolean; override;\r\n end;\r\n\r\n private var\r\n FCollection: TSequence;\r\n FSelector: TFunc;\r\n\r\n public\r\n constructor Create(const ACollection: TSequence; const ASelector: TFunc);\r\n destructor Destroy(); override;\r\n function GetEnumerator(): IEnumerator>; override;\r\n end;\r\n\r\n TSelectKeysSequence = class sealed(TSequence)\r\n private type\r\n TEnumerator = class(TAbstractEnumerator)\r\n private\r\n FInEnumerator: IEnumerator>;\r\n public\r\n function TryMoveNext(out ACurrent: TKey): Boolean; override;\r\n end;\r\n\r\n private\r\n FCollection: TAssociation;\r\n\r\n protected\r\n function GetCount(): NativeInt; override;\r\n\r\n public\r\n constructor Create(const ACollection: TAssociation); overload;\r\n destructor Destroy(); override;\r\n function GetEnumerator(): IEnumerator; override;\r\n end;\r\n\r\n TSelectValuesSequence = class sealed(TSequence)\r\n private type\r\n TEnumerator = class(TAbstractEnumerator)\r\n private\r\n FInEnumerator: IEnumerator>;\r\n public\r\n function TryMoveNext(out ACurrent: TValue): Boolean; override;\r\n end;\r\n\r\n private\r\n FCollection: TAssociation;\r\n\r\n protected\r\n function GetCount(): NativeInt; override;\r\n\r\n public\r\n constructor Create(const ACollection: TAssociation); overload;\r\n destructor Destroy(); override;\r\n function GetEnumerator(): IEnumerator; override;\r\n end;\r\n\r\n TAssociativeWhereSequence = class sealed(TAssociation)\r\n private type\r\n TEnumerator = class(TForwardingEnumerator>)\r\n public\r\n function AcceptValue(const AValue: TPair): Boolean; override;\r\n end;\r\n\r\n var\r\n FCollection: TAssociation;\r\n FPredicate: TPredicate;\r\n FInvertResult: Boolean;\r\n public\r\n constructor Create(const ACollection: TAssociation;\r\n const APredicate: TPredicate; const AInvertResult: Boolean); overload;\r\n destructor Destroy(); override;\r\n function GetEnumerator(): IEnumerator>; override;\r\n end;\r\n\r\n TAssociativeDistinctByKeysSequence = class sealed(TAssociation)\r\n private type\r\n TEnumerator = class(TForwardingEnumerator>)\r\n private\r\n FSet: ISet;\r\n public\r\n function AcceptValue(const AValue: TPair): Boolean; override;\r\n end;\r\n\r\n private\r\n FCollection: TAssociation;\r\n\r\n public\r\n constructor Create(const ACollection: TAssociation); overload;\r\n destructor Destroy(); override;\r\n function GetEnumerator(): IEnumerator>; override;\r\n end;\r\n\r\n TAssociativeDistinctByValuesSequence = class sealed(TAssociation)\r\n private type\r\n TEnumerator = class(TForwardingEnumerator>)\r\n private\r\n FSet: ISet;\r\n public\r\n function AcceptValue(const AValue: TPair): Boolean; override;\r\n end;\r\n\r\n private\r\n FCollection: TAssociation;\r\n\r\n public\r\n constructor Create(const ACollection: TAssociation); overload;\r\n destructor Destroy(); override;\r\n function GetEnumerator(): IEnumerator>; override;\r\n end;\r\n// end;\r\n\r\n{$ENDREGION}\r\n\r\nimplementation\r\nuses\r\n Collections.Dictionaries,\r\n Collections.Sets,\r\n Collections.Lists, System.SyncObjs;\r\n\r\nfunction TypeKindToStr(const AKind: TTypeKind): String;\r\nbegin\r\n Result := GetEnumName(TypeInfo(TTypeKind), Ord(AKind));\r\nend;\r\n\r\n{ TAbstractEnumerator }\r\n\r\nconstructor TAbstractEnumerator.Create(const AOwner: TAbstractContainer);\r\nbegin\r\n FOwner := AOwner;\r\n KeepObjectAlive(FOwner);\r\n FCreatedAtVersion := FOwner.FVersion;\r\n FEnded := False;\r\nend;\r\n\r\ndestructor TAbstractEnumerator.Destroy;\r\nbegin\r\n ReleaseObject(FOwner);\r\n inherited;\r\nend;\r\n\r\nfunction TAbstractEnumerator.GetCurrent: T;\r\nbegin\r\n //if FCreatedAtVersion <> FOwner.FVersion then\r\n // ExceptionHelper.Throw_CollectionChangedError();\r\n\r\n Result := FCurrent;\r\nend;\r\n\r\nfunction TAbstractEnumerator.MoveNext: Boolean;\r\nbegin\r\n //if FCreatedAtVersion <> FOwner.FVersion then\r\n // ExceptionHelper.Throw_CollectionChangedError();\r\n\r\n if FEnded then\r\n Result := False\r\n else begin\r\n Result := TryMoveNext(FCurrent);\r\n\r\n if not Result then\r\n FEnded := True;\r\n end;\r\nend;\r\n\r\nfunction TAbstractEnumerator.VersionChanged: Boolean;\r\nbegin\r\n Result := (FCreatedAtVersion <> FOwner.FVersion);\r\nend;\r\n\r\n{ TForwardingEnumerator }\r\n\r\nfunction TForwardingEnumerator.AcceptValue(const AValue: T): Boolean;\r\nbegin\r\n Result := True;\r\nend;\r\n\r\nconstructor TForwardingEnumerator.Create(const AOwner: TAbstractContainer; const AEnumerator: IEnumerator);\r\nbegin\r\n inherited Create(AOwner);\r\n\r\n if not Assigned(AEnumerator) then\r\n ExceptionHelper.Throw_ArgumentNilError('AEnumerator');\r\n\r\n FForwardEnumerator := AEnumerator;\r\nend;\r\n\r\nfunction TForwardingEnumerator.TryMoveNext(out ACurrent: T): Boolean;\r\nbegin\r\n while True do\r\n begin\r\n Result := FForwardEnumerator.MoveNext();\r\n\r\n if Result then\r\n begin\r\n ACurrent := FForwardEnumerator.Current;\r\n\r\n if AcceptValue(ACurrent) then\r\n Break;\r\n end else\r\n Break;\r\n end;\r\nend;\r\n\r\n{ TEnexExtOps }\r\n\r\nfunction TEnexExtOps.GroupBy(const ASelector: TFunc): ISequence>;\r\nbegin\r\n { Check arguments }\r\n if not Assigned(ASelector) then\r\n ExceptionHelper.Throw_ArgumentNilError('ASelector');\r\n\r\n { Create an intermediate collection that will lazy-create the actual stuff }\r\n Result := TGroupBySequence.Create(FInstance, ASelector);\r\nend;\r\n\r\n{$IF CompilerVersion > 21}\r\nfunction TEnexExtOps.Select(const AMemberName: string): ISequence;\r\nvar\r\n LSelector: TFunc;\r\nbegin\r\n { Get selector }\r\n LSelector := Member.Name(AMemberName);\r\n\r\n if not Assigned(LSelector) then\r\n ExceptionHelper.Throw_TypeDoesNotExposeMember('AMemberName');\r\n\r\n { Select the member by a name, as out type }\r\n Result := Select(LSelector);\r\nend;\r\n\r\nfunction TEnexExtOps.Select(const AMemberName: string): ISequence;\r\nvar\r\n LSelector: TFunc;\r\nbegin\r\n { Get selector }\r\n LSelector := Member.Name(AMemberName);\r\n\r\n if not Assigned(LSelector) then\r\n ExceptionHelper.Throw_TypeDoesNotExposeMember(AMemberName);\r\n\r\n { Select the member by a name, as out type }\r\n Result := Select(LSelector);\r\nend;\r\n\r\nfunction TEnexExtOps.Select(const AMemberNames: array of string): ISequence;\r\nvar\r\n LSelector: TFunc;\r\nbegin\r\n { Get selector }\r\n LSelector := Member.Name(AMemberNames);\r\n\r\n if not Assigned(LSelector) then\r\n ExceptionHelper.Throw_TypeDoesNotExposeMember('...');\r\n\r\n { Select the member by a name, as out type }\r\n Result := Select(LSelector);\r\nend;\r\n{$IFEND}\r\n\r\nfunction TEnexExtOps.GroupJoin(\r\n const AInner: IEnumerable; const AKeySelector: TFunc;\r\n const AInnerKeySelector: TFunc;\r\n const AResultSelector: TFunc, TResult>): ISequence;\r\nvar\r\n LInnerGroups: IDictionary>;\r\n LInnerValue: TInner;\r\n LValue: T;\r\n LKey: TKey;\r\n LInnerList: IList;\r\n LResult: IList;\r\nbegin\r\n if not Assigned(AInner) then\r\n ExceptionHelper.Throw_ArgumentNilError('AInner');\r\n\r\n if not Assigned(AKeySelector) then\r\n ExceptionHelper.Throw_ArgumentNilError('AKeySelector');\r\n\r\n if not Assigned(AInnerKeySelector) then\r\n ExceptionHelper.Throw_ArgumentNilError('AInnerKeySelector');\r\n\r\n if not Assigned(AResultSelector) then\r\n ExceptionHelper.Throw_ArgumentNilError('AResultSelector');\r\n\r\n { Group the inner values by key }\r\n LInnerGroups := TDictionary>.Create();\r\n\r\n for LInnerValue in AInner do\r\n begin\r\n { Generate the key for the inner element }\r\n LKey := AInnerKeySelector(LInnerValue);\r\n\r\n { Add the element into our small simulated multi-map here }\r\n if not LInnerGroups.TryGetValue(LKey, LInnerList) then\r\n begin\r\n LInnerList := TList.Create();\r\n LInnerGroups.Add(LKey, LInnerList);\r\n end;\r\n\r\n LInnerList.Add(LInnerValue);\r\n end;\r\n\r\n { M'kay, now that we have established the inner groups, let's start joining the fucker. }\r\n LResult := TList.Create();\r\n\r\n for LValue in TSequence(FInstance) do\r\n begin\r\n { Generate the key of the outer element }\r\n LKey := AKeySelector(LValue);\r\n\r\n { Now, if there is something in the inner group for this key, use it. }\r\n if LInnerGroups.TryGetValue(LKey, LInnerList) then\r\n LResult.Add(AResultSelector(LValue, LInnerList));\r\n end;\r\n\r\n\r\n Result := LResult;\r\nend;\r\n\r\nfunction TEnexExtOps.Join(\r\n const AInner: IEnumerable; const AKeySelector: TFunc;\r\n const AInnerKeySelector: TFunc;\r\n const AResultSelector: TFunc): ISequence;\r\nvar\r\n LInnerGroups: TObjectDictionary>;\r\n LInnerValue: TInner;\r\n LValue: T;\r\n LKey: TKey;\r\n LInnerList: TList;\r\n LResult: IList;\r\nbegin\r\n if not Assigned(AInner) then\r\n ExceptionHelper.Throw_ArgumentNilError('AInner');\r\n\r\n if not Assigned(AKeySelector) then\r\n ExceptionHelper.Throw_ArgumentNilError('AKeySelector');\r\n\r\n if not Assigned(AInnerKeySelector) then\r\n ExceptionHelper.Throw_ArgumentNilError('AInnerKeySelector');\r\n\r\n if not Assigned(AResultSelector) then\r\n ExceptionHelper.Throw_ArgumentNilError('AResultSelector');\r\n\r\n { Group the inner values by key }\r\n LInnerGroups := TObjectDictionary>.Create();\r\n LInnerGroups.OwnsValues := True;\r\n\r\n try\r\n for LInnerValue in AInner do\r\n begin\r\n { Generate the key for the inner element }\r\n LKey := AInnerKeySelector(LInnerValue);\r\n\r\n { Add the element into our small simulated multi-map here }\r\n if not LInnerGroups.TryGetValue(LKey, LInnerList) then\r\n begin\r\n LInnerList := TList.Create();\r\n LInnerGroups.Add(LKey, LInnerList);\r\n end;\r\n\r\n LInnerList.Add(LInnerValue);\r\n end;\r\n\r\n { M'kay, now that we have established the inner groups, let's start joining the fucker. }\r\n LResult := TList.Create();\r\n\r\n for LValue in TSequence(FInstance) do\r\n begin\r\n { Generate the key of the outer element }\r\n LKey := AKeySelector(LValue);\r\n\r\n { Now, if there is something in the inner group for this key, use it. }\r\n if LInnerGroups.TryGetValue(LKey, LInnerList) then\r\n begin\r\n for LInnerValue in LInnerList do\r\n LResult.Add(AResultSelector(LValue, LInnerValue));\r\n end;\r\n end;\r\n\r\n finally\r\n LInnerGroups.Free;\r\n end;\r\n\r\n Result := LResult;\r\nend;\r\n\r\nfunction TEnexExtOps.OrderBy(\r\n const ASelector1: TFunc; const ASelector2: TFunc;\r\n const ASelector3: TFunc; const ASelector4: TFunc;\r\n const ASelector5: TFunc): ISequence;\r\nvar\r\n LList: TList;\r\n LComparer1: IComparer;\r\n LComparer2: IComparer;\r\n LComparer3: IComparer;\r\n LComparer4: IComparer;\r\n LComparer5: IComparer;\r\n LSortProc: TComparison;\r\nbegin\r\n if not Assigned(ASelector1) then\r\n ExceptionHelper.Throw_ArgumentNilError('ASelector1');\r\n\r\n if not Assigned(ASelector2) then\r\n ExceptionHelper.Throw_ArgumentNilError('ASelector2');\r\n\r\n if not Assigned(ASelector3) then\r\n ExceptionHelper.Throw_ArgumentNilError('ASelector3');\r\n\r\n if not Assigned(ASelector4) then\r\n ExceptionHelper.Throw_ArgumentNilError('ASelector4');\r\n\r\n if not Assigned(ASelector5) then\r\n ExceptionHelper.Throw_ArgumentNilError('ASelector5');\r\n\r\n { Create an itermediary LList }\r\n LList := TList.Create();\r\n LList.AddAll(TSequence(FInstance));\r\n\r\n { Create the comparer }\r\n LComparer1 := TComparer.Default;\r\n LComparer2 := TComparer.Default;\r\n LComparer3 := TComparer.Default;\r\n LComparer4 := TComparer.Default;\r\n LComparer5 := TComparer.Default;\r\n LSortProc :=\r\n function(const Left, Right: T): Integer\r\n begin\r\n Result := LComparer1.Compare(ASelector1(Left), ASelector1(Right));\r\n if Result = 0 then\r\n begin\r\n Result := LComparer2.Compare(ASelector2(Left), ASelector2(Right));\r\n\r\n if Result = 0 then\r\n begin\r\n Result := LComparer3.Compare(ASelector3(Left), ASelector3(Right));\r\n\r\n if Result = 0 then\r\n begin\r\n Result := LComparer4.Compare(ASelector4(Left), ASelector4(Right));\r\n\r\n if Result = 0 then\r\n Result := LComparer5.Compare(ASelector5(Left), ASelector5(Right));\r\n end;\r\n end;\r\n end;\r\n end;\r\n\r\n { Sort the stuff }\r\n LList.Sort(LSortProc);\r\n\r\n { Pass the LList further }\r\n Result := LList;\r\nend;\r\n\r\nfunction TEnexExtOps.OrderBy(\r\n const ASelector1: TFunc; const ASelector2: TFunc;\r\n const ASelector3: TFunc;\r\n const ASelector4: TFunc): ISequence;\r\nvar\r\n LList: TList;\r\n LComparer1: IComparer;\r\n LComparer2: IComparer;\r\n LComparer3: IComparer;\r\n LComparer4: IComparer;\r\n LSortProc: TComparison;\r\nbegin\r\n if not Assigned(ASelector1) then\r\n ExceptionHelper.Throw_ArgumentNilError('ASelector1');\r\n\r\n if not Assigned(ASelector2) then\r\n ExceptionHelper.Throw_ArgumentNilError('ASelector2');\r\n\r\n if not Assigned(ASelector3) then\r\n ExceptionHelper.Throw_ArgumentNilError('ASelector3');\r\n\r\n if not Assigned(ASelector4) then\r\n ExceptionHelper.Throw_ArgumentNilError('ASelector4');\r\n\r\n { Create an itermediary LList }\r\n LList := TList.Create();\r\n LList.AddAll(TSequence(FInstance));\r\n\r\n { Create the comparer }\r\n LComparer1 := TComparer.Default;\r\n LComparer2 := TComparer.Default;\r\n LComparer3 := TComparer.Default;\r\n LComparer4 := TComparer.Default;\r\n LSortProc :=\r\n function(const Left, Right: T): Integer\r\n begin\r\n Result := LComparer1.Compare(ASelector1(Left), ASelector1(Right));\r\n if Result = 0 then\r\n begin\r\n Result := LComparer2.Compare(ASelector2(Left), ASelector2(Right));\r\n\r\n if Result = 0 then\r\n begin\r\n Result := LComparer3.Compare(ASelector3(Left), ASelector3(Right));\r\n\r\n if Result = 0 then\r\n Result := LComparer4.Compare(ASelector4(Left), ASelector4(Right));\r\n end;\r\n end;\r\n end;\r\n\r\n { Sort the stuff }\r\n LList.Sort(LSortProc);\r\n\r\n { Pass the LList further }\r\n Result := LList;\r\nend;\r\n\r\nfunction TEnexExtOps.OrderBy(\r\n const ASelector1: TFunc; const ASelector2: TFunc;\r\n const ASelector3: TFunc): ISequence;\r\nvar\r\n LList: TList;\r\n LComparer1: IComparer;\r\n LComparer2: IComparer;\r\n LComparer3: IComparer;\r\n LSortProc: TComparison;\r\nbegin\r\n if not Assigned(ASelector1) then\r\n ExceptionHelper.Throw_ArgumentNilError('ASelector1');\r\n\r\n if not Assigned(ASelector2) then\r\n ExceptionHelper.Throw_ArgumentNilError('ASelector2');\r\n\r\n if not Assigned(ASelector3) then\r\n ExceptionHelper.Throw_ArgumentNilError('ASelector3');\r\n\r\n { Create an itermediary LList }\r\n LList := TList.Create();\r\n LList.AddAll(TSequence(FInstance));\r\n\r\n { Create the comparer }\r\n LComparer1 := TComparer.Default;\r\n LComparer2 := TComparer.Default;\r\n LComparer3 := TComparer.Default;\r\n LSortProc :=\r\n function(const Left, Right: T): Integer\r\n begin\r\n Result := LComparer1.Compare(ASelector1(Left), ASelector1(Right));\r\n if Result = 0 then\r\n begin\r\n Result := LComparer2.Compare(ASelector2(Left), ASelector2(Right));\r\n\r\n if Result = 0 then\r\n Result := LComparer3.Compare(ASelector3(Left), ASelector3(Right));\r\n end;\r\n end;\r\n\r\n { Sort the stuff }\r\n LList.Sort(LSortProc);\r\n\r\n { Pass the LList further }\r\n Result := LList;\r\nend;\r\n\r\nfunction TEnexExtOps.OrderBy(const ASelector1: TFunc;\r\n const ASelector2: TFunc): ISequence;\r\nvar\r\n LList: TList;\r\n LComparer1: IComparer;\r\n LComparer2: IComparer;\r\n LSortProc: TComparison;\r\nbegin\r\n if not Assigned(ASelector1) then\r\n ExceptionHelper.Throw_ArgumentNilError('ASelector1');\r\n\r\n if not Assigned(ASelector2) then\r\n ExceptionHelper.Throw_ArgumentNilError('ASelector2');\r\n\r\n { Create an itermediary LList }\r\n LList := TList.Create();\r\n LList.AddAll(TSequence(FInstance));\r\n\r\n { Create the comparer }\r\n LComparer1 := TComparer.Default;\r\n LComparer2 := TComparer.Default;\r\n LSortProc :=\r\n function(const Left, Right: T): Integer\r\n begin\r\n Result := LComparer1.Compare(ASelector1(Left), ASelector1(Right));\r\n if Result = 0 then\r\n Result := LComparer2.Compare(ASelector2(Left), ASelector2(Right));\r\n end;\r\n\r\n { Sort the stuff }\r\n LList.Sort(LSortProc);\r\n\r\n { Pass the LList further }\r\n Result := LList;\r\nend;\r\n\r\nfunction TEnexExtOps.OrderBy(const ASelector: TFunc): ISequence;\r\nvar\r\n LList: TList;\r\n LComparer: IComparer;\r\n LSortProc: TComparison;\r\nbegin\r\n if not Assigned(ASelector) then\r\n ExceptionHelper.Throw_ArgumentNilError('ASelector');\r\n\r\n { Create an itermediary LList }\r\n LList := TList.Create();\r\n LList.AddAll(TSequence(FInstance));\r\n\r\n { Create the comparer }\r\n LComparer := TComparer.Default;\r\n LSortProc :=\r\n function(const Left, Right: T): Integer\r\n begin\r\n Result := LComparer.Compare(ASelector(Left), ASelector(Right));\r\n end;\r\n\r\n { Sort the stuff }\r\n LList.Sort(LSortProc);\r\n\r\n { Pass the LList further }\r\n Result := LList;\r\nend;\r\n\r\nfunction TEnexExtOps.Select: ISequence;\r\nvar\r\n LTypeInfo: PTypeInfo;\r\nbegin\r\n { Make sure that T is a class }\r\n LTypeInfo := TypeInfo(T);\r\n\r\n { TADA! }\r\n if (not Assigned(LTypeInfo)) or (LTypeInfo^.Kind <> tkClass) then\r\n ExceptionHelper.Throw_TypeNotAClassError(GetTypeName(LTypeInfo));\r\n\r\n Result := TSelectClassSequence.Create(FInstance, TRules.Default);\r\nend;\r\n\r\nfunction TEnexExtOps.Select(const ASelector: TFunc): ISequence;\r\nbegin\r\n { With default type support }\r\n Result := Select(ASelector, TRules.Default);\r\nend;\r\n\r\nfunction TEnexExtOps.Select(const ASelector: TFunc; const ARules: TRules): ISequence;\r\nbegin\r\n { Check arguments }\r\n if not Assigned(ASelector) then\r\n ExceptionHelper.Throw_ArgumentNilError('ASelector');\r\n\r\n { Create a new Enex collection }\r\n Result := TSelectSequence.Create(FInstance, ASelector, ARules);\r\nend;\r\n\r\n{ TAbstractContainer }\r\n\r\nconstructor TAbstractContainer.Create(const AThreadSafe: LongBool);\r\nbegin\r\n inherited Create;\r\n\r\n FLock := TMREWSync.Create;\r\n ThreadSafe := AThreadSafe;\r\nend;\r\n\r\ndestructor TAbstractContainer.Destroy;\r\nbegin\r\n FThreadSafe := False;\r\n FreeAndNil(FLock);\r\n\r\n inherited;\r\nend;\r\n\r\nprocedure TAbstractContainer.LockForRead;\r\nbegin\r\n if FThreadSafe then\r\n FLock.BeginRead;\r\nend;\r\n\r\nprocedure TAbstractContainer.LockForWrite;\r\nbegin\r\n if FThreadSafe then\r\n FLock.BeginWrite;\r\nend;\r\n\r\nprocedure TAbstractContainer.NotifyCollectionChanged;\r\nbegin\r\n AtomicIncrement(FVersion);\r\nend;\r\n\r\nprocedure TAbstractContainer.SetThreadSafe(const Value: LongBool);\r\nbegin\r\n FThreadSafe := Value;\r\nend;\r\n\r\nprocedure TAbstractContainer.UnLockForRead;\r\nbegin\r\n if FThreadSafe then\r\n FLock.EndRead;\r\nend;\r\n\r\nprocedure TAbstractContainer.UnLockForWrite;\r\nbegin\r\n if FThreadSafe then\r\n FLock.EndWrite;\r\nend;\r\n\r\nfunction TAbstractContainer.Version: NativeInt;\r\nbegin\r\n Result := FVersion;\r\nend;\r\n\r\n{ TAbstractContainer }\r\n\r\nprocedure TAbstractContainer.CopyTo(var AArray: array of T);\r\nbegin\r\n { Call upper version }\r\n CopyTo(AArray, 0);\r\nend;\r\n\r\nprocedure TAbstractContainer.CopyTo(var AArray: array of T; const AStartIndex: NativeInt);\r\nvar\r\n LEnumerator: IEnumerator;\r\n L, I: NativeInt;\r\nbegin\r\n if (AStartIndex >= Length(AArray)) or (AStartIndex < 0) then\r\n ExceptionHelper.Throw_ArgumentOutOfRangeError('AStartIndex');\r\n\r\n { Retrieve the enumerator object }\r\n LEnumerator := GetEnumerator();\r\n L := Length(AArray);\r\n I := AStartIndex;\r\n\r\n { Iterate until ANY element supports the predicate }\r\n while LEnumerator.MoveNext() do\r\n begin\r\n if I >= L then\r\n ExceptionHelper.Throw_ArgumentOutOfSpaceError('AArray/AStartIndex');\r\n\r\n AArray[I] := LEnumerator.Current;\r\n Inc(I);\r\n end;\r\nend;\r\n\r\nfunction TAbstractContainer.Empty: Boolean;\r\nvar\r\n LEnumerator: IEnumerator;\r\nbegin\r\n { Retrieve the enumerator object }\r\n LEnumerator := GetEnumerator();\r\n\r\n { Check if empty }\r\n Result := (not LEnumerator.MoveNext());\r\nend;\r\n\r\nfunction TAbstractContainer.GetCount: NativeInt;\r\nvar\r\n LEnumerator: IEnumerator;\r\nbegin\r\n { Retrieve the enumerator object }\r\n LEnumerator := GetEnumerator();\r\n\r\n { Iterate till the end }\r\n Result := 0;\r\n while LEnumerator.MoveNext() do Inc(Result);\r\nend;\r\n\r\nfunction TAbstractContainer.Single: T;\r\nvar\r\n LEnumerator: IEnumerator;\r\nbegin\r\n { Retrieve the enumerator object }\r\n LEnumerator := GetEnumerator();\r\n\r\n { Get the first object in the enumeration, otherwise fail! }\r\n if LEnumerator.MoveNext() then\r\n Result := LEnumerator.Current\r\n else\r\n ExceptionHelper.Throw_CollectionEmptyError();\r\n\r\n { Fail if more than one elements are there }\r\n if LEnumerator.MoveNext() then\r\n ExceptionHelper.Throw_CollectionHasMoreThanOneElement();\r\nend;\r\n\r\nfunction TAbstractContainer.SingleOrDefault(const ADefault: T): T;\r\nvar\r\n LEnumerator: IEnumerator;\r\nbegin\r\n { Retrieve the enumerator object }\r\n LEnumerator := GetEnumerator();\r\n\r\n { Get the first object in the enumeration, otherwise fail! }\r\n if LEnumerator.MoveNext() then\r\n Result := LEnumerator.Current\r\n else\r\n Exit(ADefault);\r\n\r\n { Fail if more than one elements are there }\r\n if LEnumerator.MoveNext() then\r\n ExceptionHelper.Throw_CollectionHasMoreThanOneElement();\r\nend;\r\n\r\nfunction TAbstractContainer.ToArray: TArray;\r\nvar\r\n LCount: NativeInt;\r\n LResult: TArray;\r\nbegin\r\n LCount := Count;\r\n\r\n if LCount > 0 then\r\n begin\r\n { Set the length of array }\r\n SetLength(LResult, LCount);\r\n\r\n { Copy all elements to array }\r\n CopyTo(LResult);\r\n end else\r\n SetLength(LResult, 0);\r\n\r\n Result := LResult;\r\nend;\r\n\r\n{ TSequence }\r\n\r\nfunction TSequence.Aggregate(const AAggregator: TFunc): T;\r\nvar\r\n LEnumerator: IEnumerator;\r\nbegin\r\n if not Assigned(AAggregator) then\r\n ExceptionHelper.Throw_ArgumentNilError('AAggregator');\r\n\r\n { Retrieve the enumerator object and type }\r\n LEnumerator := GetEnumerator();\r\n\r\n { Get the first object in the enumeration, otherwise fail! }\r\n if not LEnumerator.MoveNext() then\r\n ExceptionHelper.Throw_CollectionEmptyError();\r\n\r\n { Select the first element as comparison base }\r\n Result := LEnumerator.Current;\r\n\r\n { Iterate over the last N - 1 elements }\r\n while LEnumerator.MoveNext() do\r\n begin\r\n { Aggregate a value }\r\n Result := AAggregator(Result, LEnumerator.Current);\r\n end;\r\nend;\r\n\r\nfunction TSequence.AggregateOrDefault(const AAggregator: TFunc; const ADefault: T): T;\r\nvar\r\n LEnumerator: IEnumerator;\r\nbegin\r\n if not Assigned(AAggregator) then\r\n ExceptionHelper.Throw_ArgumentNilError('AAggregator');\r\n\r\n { Retrieve the enumerator object and type }\r\n LEnumerator := GetEnumerator();\r\n\r\n { Get the first object in the enumeration, otherwise fail! }\r\n if not LEnumerator.MoveNext() then\r\n Exit(ADefault);\r\n\r\n { Select the first element as comparison base }\r\n Result := LEnumerator.Current;\r\n\r\n { Iterate over the last N - 1 elements }\r\n while LEnumerator.MoveNext() do\r\n begin\r\n { Aggregate a value }\r\n Result := AAggregator(Result, LEnumerator.Current);\r\n end;\r\nend;\r\n\r\nfunction TSequence.All(const APredicate: TPredicate): Boolean;\r\nvar\r\n LEnumerator: IEnumerator;\r\nbegin\r\n if not Assigned(APredicate) then\r\n ExceptionHelper.Throw_ArgumentNilError('APredicate');\r\n\r\n { Retrieve the enumerator object }\r\n LEnumerator := GetEnumerator();\r\n\r\n { Iterate while ALL elements support the predicate }\r\n while LEnumerator.MoveNext() do\r\n begin\r\n if not APredicate(LEnumerator.Current) then\r\n Exit(false);\r\n end;\r\n\r\n Result := true;\r\nend;\r\n\r\nfunction TSequence.Any(const APredicate: TPredicate): Boolean;\r\nvar\r\n LEnumerator: IEnumerator;\r\nbegin\r\n if not Assigned(APredicate) then\r\n ExceptionHelper.Throw_ArgumentNilError('APredicate');\r\n\r\n { Retrieve the enumerator object }\r\n LEnumerator := GetEnumerator();\r\n\r\n { Iterate until ANY element supports the predicate }\r\n while LEnumerator.MoveNext() do\r\n begin\r\n if APredicate(LEnumerator.Current) then\r\n Exit(true);\r\n end;\r\n\r\n Result := false;\r\nend;\r\n\r\nfunction TSequence.CompareElements(const ALeft, ARight: T): NativeInt;\r\nbegin\r\n { Lazy init }\r\n if not Assigned(FElementRules.FComparer) then\r\n FElementRules.FComparer := TComparer.Default;\r\n\r\n Result := FElementRules.FComparer.Compare(ALeft, ARight);\r\nend;\r\n\r\nfunction TSequence.CompareTo(AObject: TObject): Integer;\r\nvar\r\n LIterSelf, LIterTo: IEnumerator;\r\n LMovSelf, LMovTo: Boolean;\r\nbegin\r\n { Check if we can continue }\r\n if (not Assigned(AObject)) or (not AObject.InheritsFrom(TSequence)) then\r\n Result := 1\r\n else begin\r\n { Assume equality }\r\n Result := 0;\r\n\r\n { Get enumerators }\r\n LIterSelf := GetEnumerator();\r\n LIterTo := TSequence(AObject).GetEnumerator();\r\n\r\n while true do\r\n begin\r\n { Iterate and verify that both enumerators moved }\r\n LMovSelf := LIterSelf.MoveNext();\r\n LMovTo := LIterTo.MoveNext();\r\n\r\n { If one moved but the other did not - error }\r\n if LMovSelf <> LMovTo then\r\n begin\r\n { Decide on the return value }\r\n if LMovSelf then\r\n Result := 1\r\n else\r\n Result := -1;\r\n\r\n Break;\r\n end;\r\n\r\n { If neither moved, we've reached the end }\r\n if not LMovSelf then\r\n Break;\r\n\r\n { Verify both values are identical }\r\n Result := CompareElements(LIterSelf.Current, LIterTo.Current);\r\n if Result <> 0 then\r\n Break;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TSequence.Concat(const ACollection: ISequence): ISequence;\r\nbegin\r\n { Check arguments }\r\n if not Assigned(ACollection) then\r\n ExceptionHelper.Throw_ArgumentNilError('ACollection');\r\n\r\n { Create concatenation iterator }\r\n Result := TConcatSequence.Create(Self, ACollection);\r\nend;\r\n\r\nconstructor TSequence.Create(const ARules: TRules);\r\nbegin\r\n inherited Create;\r\n\r\n FElementRules := ARules;\r\nend;\r\n\r\nconstructor TSequence.Create;\r\nbegin\r\n Create(TRules.Default);\r\nend;\r\n\r\nfunction TSequence.Distinct: ISequence;\r\nbegin\r\n { Create a new enumerator }\r\n Result := TDistinctSequence.Create(Self);\r\nend;\r\n\r\nfunction TSequence.ElementAt(const AIndex: NativeInt): T;\r\nvar\r\n LEnumerator: IEnumerator;\r\n LCount: NativeInt;\r\nbegin\r\n if AIndex < 0 then\r\n ExceptionHelper.Throw_ArgumentOutOfRangeError('AIndex');\r\n\r\n { Retrieve the enumerator object }\r\n LEnumerator := GetEnumerator();\r\n LCount := 0;\r\n\r\n while LEnumerator.MoveNext() do\r\n begin\r\n { If we reached thge element, exit }\r\n if LCount = AIndex then\r\n Exit(LEnumerator.Current);\r\n\r\n Inc(LCount);\r\n end;\r\n\r\n { Fail! }\r\n ExceptionHelper.Throw_ArgumentOutOfRangeError('AIndex');\r\nend;\r\n\r\nfunction TSequence.ElementAtOrDefault(const AIndex: NativeInt; const ADefault: T): T;\r\nvar\r\n LEnumerator: IEnumerator;\r\n LCount: NativeInt;\r\nbegin\r\n if AIndex < 0 then\r\n ExceptionHelper.Throw_ArgumentOutOfRangeError('AIndex');\r\n\r\n { Retrieve the enumerator object }\r\n LEnumerator := GetEnumerator();\r\n LCount := 0;\r\n\r\n while LEnumerator.MoveNext() do\r\n begin\r\n { If we reached thge element, exit }\r\n if LCount = AIndex then\r\n Exit(LEnumerator.Current);\r\n\r\n Inc(LCount);\r\n end;\r\n\r\n { Return default value }\r\n Result := ADefault;\r\nend;\r\n\r\nfunction TSequence.ElementsAreEqual(const ALeft, ARight: T): Boolean;\r\nbegin\r\n { Lazy init }\r\n if not Assigned(FElementRules.FEqComparer) then\r\n FElementRules.FEqComparer := TEqualityComparer.Default;\r\n\r\n Result := FElementRules.FEqComparer.Equals(ALeft, ARight);\r\nend;\r\n\r\nfunction TSequence.Equals(Obj: TObject): Boolean;\r\nbegin\r\n { Call comparison }\r\n Result := (CompareTo(Obj) = 0);\r\nend;\r\n\r\nfunction TSequence.EqualsTo(const ACollection: IEnumerable): Boolean;\r\nvar\r\n LEnumerator1, LEnumerator2: IEnumerator;\r\n LMoved1, LMoved2: Boolean;\r\nbegin\r\n { Check arguments }\r\n if not Assigned(ACollection) then\r\n ExceptionHelper.Throw_ArgumentNilError('ACollection');\r\n\r\n { Get enumerators }\r\n LEnumerator1 := GetEnumerator();\r\n LEnumerator2 := ACollection.GetEnumerator();\r\n\r\n while true do\r\n begin\r\n { Iterate and verify that both enumerators moved }\r\n LMoved1 := LEnumerator1.MoveNext();\r\n LMoved2 := LEnumerator2.MoveNext();\r\n\r\n { If one moved but the other did not - error }\r\n if LMoved1 <> LMoved2 then\r\n Exit(false);\r\n\r\n { If neither moved, we've reached the end }\r\n if not LMoved1 then\r\n break;\r\n\r\n { Verify both values are identical }\r\n if not ElementsAreEqual(LEnumerator1.Current, LEnumerator2.Current) then\r\n Exit(false);\r\n end;\r\n\r\n { It worked! }\r\n Result := true;\r\nend;\r\n\r\nfunction TSequence.Exclude(const ACollection: ISequence): ISequence;\r\nbegin\r\n { Check arguments }\r\n if not Assigned(ACollection) then\r\n ExceptionHelper.Throw_ArgumentNilError('ACollection');\r\n\r\n { Create concatenation iterator }\r\n Result := TExclusionSequence.Create(Self, ACollection);\r\nend;\r\n\r\nclass function TSequence.Fill(const AElement: T; const ACount: NativeInt; const ARules: TRules): ISequence;\r\nbegin\r\n { Check arguments }\r\n if ACount <= 0 then\r\n ExceptionHelper.Throw_ArgumentOutOfRangeError('ACount');\r\n\r\n { Create an collection }\r\n Result := TFillSequence.Create(AElement, ACount, ARules);\r\nend;\r\n\r\nclass function TSequence.Fill(const AElement: T; const ACount: NativeInt): ISequence;\r\nbegin\r\n { Call upper function }\r\n Result := Fill(AElement, ACount, TRules.Default);\r\nend;\r\n\r\nfunction TSequence.First: T;\r\nvar\r\n LEnumerator: IEnumerator;\r\nbegin\r\n { Retrieve the enumerator object }\r\n LEnumerator := GetEnumerator();\r\n\r\n { Get the first object in the enumeration, otherwise fail! }\r\n if LEnumerator.MoveNext() then\r\n Result := LEnumerator.Current\r\n else\r\n ExceptionHelper.Throw_CollectionEmptyError();\r\nend;\r\n\r\nfunction TSequence.FirstOrDefault(const ADefault: T): T;\r\nvar\r\n LEnumerator: IEnumerator;\r\nbegin\r\n { Retrieve the enumerator object }\r\n LEnumerator := GetEnumerator();\r\n\r\n { Get the first object in the enumeration, otherwise return default! }\r\n if LEnumerator.MoveNext() then\r\n Result := LEnumerator.Current\r\n else\r\n Result := ADefault;\r\nend;\r\n\r\nfunction TSequence.FirstWhere(const APredicate: TPredicate): T;\r\nvar\r\n LEnumerator: IEnumerator;\r\n LWasOne: Boolean;\r\nbegin\r\n if not Assigned(APredicate) then\r\n ExceptionHelper.Throw_ArgumentNilError('APredicate');\r\n\r\n { Retrieve the enumerator object }\r\n LEnumerator := GetEnumerator();\r\n LWasOne := false;\r\n\r\n { Do the funky stuff already }\r\n while LEnumerator.MoveNext do\r\n begin\r\n LWasOne := true;\r\n\r\n if APredicate(LEnumerator.Current) then\r\n Exit(LEnumerator.Current);\r\n end;\r\n\r\n { Failure to find what we need }\r\n if LWasOne then\r\n ExceptionHelper.Throw_CollectionHasNoFilteredElements()\r\n else\r\n ExceptionHelper.Throw_CollectionEmptyError();\r\nend;\r\n\r\nfunction TSequence.FirstWhereBetween(const ALower, AHigher: T): T;\r\nbegin\r\n Result := FirstWhere(\r\n function(Arg1: T): Boolean\r\n begin\r\n Result := (CompareElements(Arg1, ALower) >= 0) and\r\n (CompareElements(Arg1, AHigher) <= 0)\r\n end\r\n );\r\nend;\r\n\r\nfunction TSequence.FirstWhereBetweenOrDefault(const ALower, AHigher, ADefault: T): T;\r\nbegin\r\n Result := FirstWhereOrDefault(\r\n function(Arg1: T): Boolean\r\n begin\r\n Result := (CompareElements(Arg1, ALower) >= 0) and\r\n (CompareElements(Arg1, AHigher) <= 0)\r\n end,\r\n ADefault\r\n );\r\nend;\r\n\r\nfunction TSequence.FirstWhereGreater(const ABound: T): T;\r\nbegin\r\n Result := FirstWhere(\r\n function(Arg1: T): Boolean\r\n begin\r\n Result := CompareElements(Arg1, ABound) > 0;\r\n end\r\n );\r\nend;\r\n\r\nfunction TSequence.FirstWhereGreaterOrDefault(const ABound, ADefault: T): T;\r\nbegin\r\n Result := FirstWhereOrDefault(\r\n function(Arg1: T): Boolean\r\n begin\r\n Result := CompareElements(Arg1, ABound) > 0;\r\n end,\r\n ADefault\r\n );\r\nend;\r\n\r\nfunction TSequence.FirstWhereGreaterOrEqual(const ABound: T): T;\r\nbegin\r\n Result := FirstWhere(\r\n function(Arg1: T): Boolean\r\n begin\r\n Result := CompareElements(Arg1, ABound) >= 0;\r\n end\r\n );\r\nend;\r\n\r\nfunction TSequence.FirstWhereGreaterOrEqualOrDefault(const ABound, ADefault: T): T;\r\nbegin\r\n Result := FirstWhereOrDefault(\r\n function(Arg1: T): Boolean\r\n begin\r\n Result := CompareElements(Arg1, ABound) >= 0;\r\n end,\r\n ADefault\r\n );\r\nend;\r\n\r\nfunction TSequence.FirstWhereLower(const ABound: T): T;\r\nbegin\r\n Result := FirstWhere(\r\n function(Arg1: T): Boolean\r\n begin\r\n Result := CompareElements(Arg1, ABound) < 0;\r\n end\r\n );\r\nend;\r\n\r\nfunction TSequence.FirstWhereLowerOrDefault(const ABound, ADefault: T): T;\r\nbegin\r\n Result := FirstWhereOrDefault(\r\n function(Arg1: T): Boolean\r\n begin\r\n Result := CompareElements(Arg1, ABound) < 0;\r\n end,\r\n ADefault\r\n );\r\nend;\r\n\r\nfunction TSequence.FirstWhereLowerOrEqual(const ABound: T): T;\r\nbegin\r\n Result := FirstWhere(\r\n function(Arg1: T): Boolean\r\n begin\r\n Result := CompareElements(Arg1, ABound) <= 0;\r\n end\r\n );\r\nend;\r\n\r\nfunction TSequence.FirstWhereLowerOrEqualOrDefault(const ABound, ADefault: T): T;\r\nbegin\r\n Result := FirstWhereOrDefault(\r\n function(Arg1: T): Boolean\r\n begin\r\n Result := CompareElements(Arg1, ABound) <= 0;\r\n end,\r\n ADefault\r\n );\r\nend;\r\n\r\nfunction TSequence.FirstWhereNot(const APredicate: TPredicate): T;\r\nbegin\r\n if not Assigned(APredicate) then\r\n ExceptionHelper.Throw_ArgumentNilError('APredicate');\r\n\r\n Result := FirstWhere(\r\n function(Arg1: T): Boolean\r\n begin\r\n Result := not APredicate(Arg1);\r\n end\r\n );\r\nend;\r\n\r\nfunction TSequence.FirstWhereNotOrDefault(\r\n const APredicate: TPredicate; const ADefault: T): T;\r\nbegin\r\n if not Assigned(APredicate) then\r\n ExceptionHelper.Throw_ArgumentNilError('APredicate');\r\n\r\n Result := FirstWhereOrDefault(\r\n function(Arg1: T): Boolean\r\n begin\r\n Result := not APredicate(Arg1);\r\n end,\r\n ADefault\r\n );\r\nend;\r\n\r\nfunction TSequence.FirstWhereOrDefault(const APredicate: TPredicate; const ADefault: T): T;\r\nvar\r\n LEnumerator: IEnumerator;\r\nbegin\r\n if not Assigned(APredicate) then\r\n ExceptionHelper.Throw_ArgumentNilError('APredicate');\r\n\r\n { Retrieve the enumerator object }\r\n LEnumerator := GetEnumerator();\r\n\r\n { Do the funky stuff already }\r\n while LEnumerator.MoveNext do\r\n if APredicate(LEnumerator.Current) then\r\n Exit(LEnumerator.Current);\r\n\r\n { Failure to find what we need }\r\n Result := ADefault;\r\nend;\r\n\r\nfunction TSequence.GetElementHashCode(const AValue: T): NativeInt;\r\nbegin\r\n { Lazy init }\r\n if not Assigned(FElementRules.FEqComparer) then\r\n FElementRules.FEqComparer := TEqualityComparer.Default;\r\n\r\n Result := FElementRules.FEqComparer.GetHashCode(AValue);\r\nend;\r\n\r\nfunction TSequence.GetHashCode: Integer;\r\nconst\r\n CMagic = $0F;\r\n\r\nvar\r\n LEnumerator: IEnumerator;\r\nbegin\r\n { Obtain the enumerator }\r\n LEnumerator := GetEnumerator();\r\n\r\n { Start at 0 }\r\n Result := 0;\r\n\r\n { ... }\r\n while LEnumerator.MoveNext() do\r\n Result := CMagic * Result + GetElementHashCode(LEnumerator.Current);\r\nend;\r\n\r\nfunction TSequence.Intersect(const ACollection: ISequence): ISequence;\r\nbegin\r\n { Check arguments }\r\n if not Assigned(ACollection) then\r\n ExceptionHelper.Throw_ArgumentNilError('ACollection');\r\n\r\n { Create concatenation iterator }\r\n Result := TIntersectionSequence.Create(Self, ACollection);\r\nend;\r\n\r\nfunction TSequence.Last: T;\r\nvar\r\n LEnumerator: IEnumerator;\r\nbegin\r\n { Retrieve the enumerator object }\r\n LEnumerator := GetEnumerator();\r\n\r\n { Get the first object in the enumeration, otherwise fail! }\r\n if not LEnumerator.MoveNext() then\r\n ExceptionHelper.Throw_CollectionEmptyError();\r\n\r\n { Iterate till the last element in the LEnumerator }\r\n while true do\r\n begin\r\n Result := LEnumerator.Current;\r\n\r\n { Exit if we hit the last element }\r\n if not LEnumerator.MoveNext() then\r\n Exit;\r\n end;\r\nend;\r\n\r\nfunction TSequence.LastOrDefault(const ADefault: T): T;\r\nvar\r\n LEnumerator: IEnumerator;\r\nbegin\r\n { Retrieve the enumerator object }\r\n LEnumerator := GetEnumerator();\r\n\r\n { Get the first object in the enumeration, otherwise return default! }\r\n if not LEnumerator.MoveNext() then\r\n Exit(ADefault);\r\n\r\n { Iterate till the last element in the LEnumerator }\r\n while true do\r\n begin\r\n Result := LEnumerator.Current;\r\n\r\n { Exit if we hit the last element }\r\n if not LEnumerator.MoveNext() then\r\n Exit;\r\n end;\r\nend;\r\n\r\nfunction TSequence.Max: T;\r\nvar\r\n LEnumerator: IEnumerator;\r\nbegin\r\n { Retrieve the enumerator object and type }\r\n LEnumerator := GetEnumerator();\r\n\r\n { Get the first object in the enumeration, otherwise fail! }\r\n if not LEnumerator.MoveNext() then\r\n ExceptionHelper.Throw_CollectionEmptyError();\r\n\r\n { Select the first element as comparison base }\r\n Result := LEnumerator.Current;\r\n\r\n { Iterate till the last element in the LEnumerator }\r\n while true do\r\n begin\r\n if CompareElements(LEnumerator.Current, Result) > 0 then\r\n Result := LEnumerator.Current;\r\n\r\n { Exit if we hit the last element }\r\n if not LEnumerator.MoveNext() then\r\n Exit;\r\n end;\r\nend;\r\n\r\nfunction TSequence.Min: T;\r\nvar\r\n LEnumerator: IEnumerator;\r\nbegin\r\n { Retrieve the enumerator object and type }\r\n LEnumerator := GetEnumerator();\r\n\r\n { Get the first object in the enumeration, otherwise fail! }\r\n if not LEnumerator.MoveNext() then\r\n ExceptionHelper.Throw_CollectionEmptyError();\r\n\r\n { Select the first element as comparison base }\r\n Result := LEnumerator.Current;\r\n\r\n { Iterate till the last element in the LEnumerator }\r\n while true do\r\n begin\r\n if CompareElements(LEnumerator.Current, Result) < 0 then\r\n Result := LEnumerator.Current;\r\n\r\n { Exit if we hit the last element }\r\n if not LEnumerator.MoveNext() then\r\n Exit;\r\n end;\r\nend;\r\n\r\nfunction TSequence.Op: TEnexExtOps;\r\nbegin\r\n { Build up the record + keep an optional reference to the object }\r\n Result.FInstance := Self;\r\n Result.FKeepAlive := Self.ExtractReference;\r\n Result.FRules := FElementRules;\r\nend;\r\n\r\nfunction TSequence.Range(const AStart, AEnd: NativeInt): ISequence;\r\nbegin\r\n if AStart < 0 then\r\n ExceptionHelper.Throw_ArgumentOutOfRangeError('AStart');\r\n if AEnd < AStart then\r\n ExceptionHelper.Throw_ArgumentOutOfRangeError('AEnd');\r\n\r\n { Create a new Enex collection }\r\n Result := TRangeSequence.Create(Self, AStart, AEnd);\r\nend;\r\n\r\nfunction TSequence.Reversed: ISequence;\r\nvar\r\n LList: TList;\r\nbegin\r\n { Create an itermediary LList }\r\n LList := TList.Create(ElementRules);\r\n LList.AddAll(Self);\r\n LList.Reverse();\r\n\r\n { Pass the LList further }\r\n Result := LList;\r\nend;\r\n\r\nfunction TSequence.Skip(const ACount: NativeInt): ISequence;\r\nbegin\r\n { Check parameters }\r\n if ACount = 0 then\r\n ExceptionHelper.Throw_ArgumentOutOfRangeError('ACount');\r\n\r\n { Create a new Enex collection }\r\n Result := TSkipSequence.Create(Self, ACount);\r\nend;\r\n\r\nfunction TSequence.SkipWhile(const APredicate: TPredicate): ISequence;\r\nbegin\r\n { Check arguments }\r\n if not Assigned(APredicate) then\r\n ExceptionHelper.Throw_ArgumentNilError('APredicate');\r\n\r\n { Create a new Enex collection }\r\n Result := TSkipWhileSequence.Create(Self, APredicate);\r\nend;\r\n\r\nfunction TSequence.SkipWhileBetween(const ALower, AHigher: T): ISequence;\r\nvar\r\n LLower, LHigher: T;\r\nbegin\r\n { Locals }\r\n LLower := ALower;\r\n LHigher := AHigher;\r\n\r\n { Use SkipWhile() and pass an anonymous function }\r\n Result := SkipWhile(\r\n function(Arg1: T): Boolean\r\n begin\r\n Exit((CompareElements(Arg1, LLower) >= 0) and (CompareElements(Arg1, LHigher) <= 0));\r\n end\r\n );\r\nend;\r\n\r\nfunction TSequence.SkipWhileGreater(const ABound: T): ISequence;\r\nvar\r\n LBound: T;\r\nbegin\r\n { Locals }\r\n LBound := ABound;\r\n\r\n { Use SkipWhile() and pass an anonymous function }\r\n Result := SkipWhile(\r\n function(Arg1: T): Boolean\r\n begin\r\n Exit(CompareElements(Arg1, LBound) > 0);\r\n end\r\n );\r\nend;\r\n\r\nfunction TSequence.SkipWhileGreaterOrEqual(const ABound: T): ISequence;\r\nvar\r\n LBound: T;\r\nbegin\r\n { Locals }\r\n LBound := ABound;\r\n\r\n { Use SkipWhile() and pass an anonymous function }\r\n Result := SkipWhile(\r\n function(Arg1: T): Boolean\r\n begin\r\n Exit(CompareElements(Arg1, LBound) >= 0);\r\n end\r\n );\r\nend;\r\n\r\nfunction TSequence.SkipWhileLower(const ABound: T): ISequence;\r\nvar\r\n LBound: T;\r\nbegin\r\n { Locals }\r\n LBound := ABound;\r\n\r\n { Use SkipWhile() and pass an anonymous function }\r\n Result := SkipWhile(\r\n function(Arg1: T): Boolean\r\n begin\r\n Exit(CompareElements(Arg1, LBound) < 0);\r\n end\r\n );\r\nend;\r\n\r\nfunction TSequence.SkipWhileLowerOrEqual(const ABound: T): ISequence;\r\nvar\r\n LBound: T;\r\nbegin\r\n { Locals }\r\n LBound := ABound;\r\n\r\n { Use SkipWhile() and pass an anonymous function }\r\n Result := SkipWhile(\r\n function(Arg1: T): Boolean\r\n begin\r\n Exit(CompareElements(Arg1, LBound) <= 0);\r\n end\r\n );\r\nend;\r\n\r\nfunction TSequence.Ordered(const ASortProc: TComparison): ISequence;\r\nvar\r\n LList: TList;\r\nbegin\r\n { Create an itermediary LList }\r\n LList := TList.Create(ElementRules);\r\n LList.AddAll(Self);\r\n LList.Sort(ASortProc);\r\n\r\n { Pass the LList further }\r\n Result := LList;\r\nend;\r\n\r\nfunction TSequence.Ordered(const AAscending: Boolean = true): ISequence;\r\nvar\r\n LList: TList;\r\nbegin\r\n { Create an itermediary LList }\r\n LList := TList.Create(ElementRules);\r\n LList.AddAll(Self);\r\n LList.Sort(AAscending);\r\n\r\n { Pass the LList further }\r\n Result := LList;\r\nend;\r\n\r\nfunction TSequence.Take(const ACount: NativeInt): ISequence;\r\nbegin\r\n { Check parameters }\r\n if ACount = 0 then\r\n ExceptionHelper.Throw_ArgumentOutOfRangeError('ACount');\r\n\r\n { Create a new Enex collection }\r\n Result := TTakeSequence.Create(Self, ACount);\r\nend;\r\n\r\nfunction TSequence.TakeWhile(const APredicate: TPredicate): ISequence;\r\nbegin\r\n { Check arguments }\r\n if not Assigned(APredicate) then\r\n ExceptionHelper.Throw_ArgumentNilError('APredicate');\r\n\r\n { Create a new Enex collection }\r\n Result := TTakeWhileSequence.Create(Self, APredicate);\r\nend;\r\n\r\nfunction TSequence.TakeWhileBetween(const ALower, AHigher: T): ISequence;\r\nvar\r\n LLower, LHigher: T;\r\nbegin\r\n { Locals }\r\n LLower := ALower;\r\n LHigher := AHigher;\r\n\r\n { Use TakeWhile() and pass an anonymous function }\r\n Result := TakeWhile(\r\n function(Arg1: T): Boolean\r\n begin\r\n Exit((CompareElements(Arg1, LLower) >= 0) and (CompareElements(Arg1, LHigher) <= 0));\r\n end\r\n );\r\nend;\r\n\r\nfunction TSequence.TakeWhileGreater(const ABound: T): ISequence;\r\nvar\r\n LBound: T;\r\nbegin\r\n { Locals }\r\n LBound := ABound;\r\n\r\n { Use TakeWhile() and pass an anonymous function }\r\n Result := TakeWhile(\r\n function(Arg1: T): Boolean\r\n begin\r\n Exit(CompareElements(Arg1, LBound) > 0);\r\n end\r\n );\r\nend;\r\n\r\nfunction TSequence.TakeWhileGreaterOrEqual(const ABound: T): ISequence;\r\nvar\r\n LBound: T;\r\nbegin\r\n { Locals }\r\n LBound := ABound;\r\n\r\n { Use TakeWhile() and pass an anonymous function }\r\n Result := TakeWhile(\r\n function(Arg1: T): Boolean\r\n begin\r\n Exit(CompareElements(Arg1, LBound) >= 0);\r\n end\r\n );\r\nend;\r\n\r\nfunction TSequence.TakeWhileLower(const ABound: T): ISequence;\r\nvar\r\n LBound: T;\r\nbegin\r\n { Locals }\r\n LBound := ABound;\r\n\r\n { Use TakeWhile() and pass an anonymous function }\r\n Result := TakeWhile(\r\n function(Arg1: T): Boolean\r\n begin\r\n Exit(CompareElements(Arg1, LBound) < 0);\r\n end\r\n );\r\nend;\r\n\r\nfunction TSequence.TakeWhileLowerOrEqual(const ABound: T): ISequence;\r\nvar\r\n LBound: T;\r\nbegin\r\n { Locals }\r\n LBound := ABound;\r\n\r\n { Use TakeWhile() and pass an anonymous function }\r\n Result := TakeWhile(\r\n function(Arg1: T): Boolean\r\n begin\r\n Exit(CompareElements(Arg1, LBound) <= 0);\r\n end\r\n );\r\nend;\r\n\r\nfunction TSequence.ToList: IList;\r\nbegin\r\n { Simply make up a list }\r\n Result := TList.Create(ElementRules);\r\n Result.AddAll(Self);\r\nend;\r\n\r\nfunction TSequence.ToSet: ISet;\r\nbegin\r\n { Simply make up a bag }\r\n Result := THashSet.Create(ElementRules);\r\n Result.AddAll(Self);\r\nend;\r\n\r\nfunction TSequence.Union(const ACollection: ISequence): ISequence;\r\nbegin\r\n { Check arguments }\r\n if not Assigned(ACollection) then\r\n ExceptionHelper.Throw_ArgumentNilError('ACollection');\r\n\r\n { Create concatenation iterator }\r\n Result := TUnionSequence.Create(Self, ACollection);\r\nend;\r\n\r\nfunction TSequence.Where(const APredicate: TPredicate): ISequence;\r\nbegin\r\n { Check arguments }\r\n if not Assigned(APredicate) then\r\n ExceptionHelper.Throw_ArgumentNilError('APredicate');\r\n\r\n { Create a new Enex collection }\r\n Result := TWhereSequence.Create(Self, APredicate, False); // Don't invert the result\r\nend;\r\n\r\nfunction TSequence.WhereBetween(const ALower, AHigher: T): ISequence;\r\nvar\r\n LLower, LHigher: T;\r\nbegin\r\n { Locals }\r\n LLower := ALower;\r\n LHigher := AHigher;\r\n\r\n { Use Where() and pass an anonymous function }\r\n Result := Where(\r\n function(Arg1: T): Boolean\r\n begin\r\n Exit((CompareElements(Arg1, LLower) >= 0) and (CompareElements(Arg1, LHigher) <= 0));\r\n end\r\n );\r\nend;\r\n\r\nfunction TSequence.WhereGreater(const ABound: T): ISequence;\r\nvar\r\n LBound: T;\r\nbegin\r\n { Locals }\r\n LBound := ABound;\r\n\r\n { Use Where() and pass an anonymous function }\r\n Result := Where(\r\n function(Arg1: T): Boolean\r\n begin\r\n Exit(CompareElements(Arg1, LBound) > 0);\r\n end\r\n );\r\nend;\r\n\r\nfunction TSequence.WhereGreaterOrEqual(const ABound: T): ISequence;\r\nvar\r\n LBound: T;\r\nbegin\r\n { Locals }\r\n LBound := ABound;\r\n\r\n { Use Where() and pass an anonymous function }\r\n Result := Where(\r\n function(Arg1: T): Boolean\r\n begin\r\n Exit(CompareElements(Arg1, LBound) >= 0);\r\n end\r\n );\r\nend;\r\n\r\nfunction TSequence.WhereLower(const ABound: T): ISequence;\r\nvar\r\n LBound: T;\r\nbegin\r\n { Locals }\r\n LBound := ABound;\r\n\r\n { Use Where() and pass an anonymous function }\r\n Result := Where(\r\n function(Arg1: T): Boolean\r\n begin\r\n Exit(CompareElements(Arg1, LBound) < 0);\r\n end\r\n );\r\nend;\r\n\r\nfunction TSequence.WhereLowerOrEqual(const ABound: T): ISequence;\r\nvar\r\n LBound: T;\r\nbegin\r\n { Locals }\r\n LBound := ABound;\r\n\r\n { Use Where() and pass an anonymous function }\r\n Result := Where(\r\n function(Arg1: T): Boolean\r\n begin\r\n Exit(CompareElements(Arg1, LBound) <= 0);\r\n end\r\n );\r\nend;\r\n\r\nfunction TSequence.WhereNot(\r\n const APredicate: TPredicate): ISequence;\r\nbegin\r\n { Check arguments }\r\n if not Assigned(APredicate) then\r\n ExceptionHelper.Throw_ArgumentNilError('APredicate');\r\n\r\n { Create a new Enex collection }\r\n Result := TWhereSequence.Create(Self, APredicate, True); // Invert the result\r\nend;\r\n\r\n{ TCollection }\r\n\r\nprocedure TCollection.Add(const AValue: T);\r\nbegin\r\n ExceptionHelper.Throw_OperationNotSupported('Add');\r\nend;\r\n\r\nprocedure TCollection.AddAll(const ACollection: IEnumerable);\r\nvar\r\n LValue: T;\r\nbegin\r\n if not Assigned(ACollection) then\r\n ExceptionHelper.Throw_ArgumentNilError('ACollection');\r\n\r\n for LValue in ACollection do\r\n Add(LValue);\r\nend;\r\n\r\nprocedure TCollection.Clear;\r\nvar\r\n LValue: T;\r\nbegin\r\n while not Empty() do\r\n begin\r\n LValue := First();\r\n Remove(LValue);\r\n\r\n NotifyElementRemoved(LValue);\r\n end;\r\nend;\r\n\r\nfunction TCollection.Contains(const AValue: T): Boolean;\r\nvar\r\n LEnumerator: IEnumerator;\r\nbegin\r\n LEnumerator := GetEnumerator();\r\n while LEnumerator.MoveNext() do\r\n if ElementsAreEqual(LEnumerator.Current, AValue) then\r\n Exit(True);\r\n\r\n Result := False;\r\nend;\r\n\r\nfunction TCollection.ContainsAll(const ACollection: IEnumerable): Boolean;\r\nvar\r\n LValue: T;\r\nbegin\r\n if not Assigned(ACollection) then\r\n ExceptionHelper.Throw_ArgumentNilError('ACollection');\r\n\r\n Result := True;\r\n for LValue in ACollection do\r\n Result := Result and Contains(LValue);\r\nend;\r\n\r\ndestructor TCollection.Destroy;\r\nbegin\r\n Clear();\r\n inherited;\r\nend;\r\n\r\nprocedure TCollection.HandleElementRemoved(const AElement: T);\r\nbegin\r\n // Nothing\r\nend;\r\n\r\nprocedure TCollection.NotifyElementRemoved(const AElement: T);\r\nbegin\r\n { Handle removal }\r\n if Assigned(FRemoveNotification) then\r\n FRemoveNotification(AElement)\r\n else\r\n HandleElementRemoved(AElement);\r\nend;\r\n\r\nprocedure TCollection.Remove(const AValue: T);\r\nbegin\r\n ExceptionHelper.Throw_OperationNotSupported('Remove');\r\nend;\r\n\r\nprocedure TCollection.RemoveAll(const ACollection: IEnumerable);\r\nvar\r\n LValue: T;\r\nbegin\r\n if not Assigned(ACollection) then\r\n ExceptionHelper.Throw_ArgumentNilError('ACollection');\r\n\r\n for LValue in ACollection do\r\n Remove(LValue);\r\nend;\r\n\r\n\r\n{ TAssociation }\r\n\r\nconstructor TAssociation.Create;\r\nbegin\r\n Create(TRules.Default, TRules.Default);\r\nend;\r\n\r\nfunction TAssociation.CompareKeys(const ALeft, ARight: TKey): NativeInt;\r\nbegin\r\n { Lazy init }\r\n if not Assigned(FKeyRules.FComparer) then\r\n FKeyRules.FComparer := TComparer.Default;\r\n\r\n Result := FKeyRules.FComparer.Compare(ALeft, ARight);\r\nend;\r\n\r\nfunction TAssociation.CompareValues(const ALeft, ARight: TValue): NativeInt;\r\nbegin\r\n { Lazy init }\r\n if not Assigned(FValueRules.FComparer) then\r\n FValueRules.FComparer := TComparer.Default;\r\n\r\n Result := FValueRules.FComparer.Compare(ALeft, ARight);\r\nend;\r\n\r\nconstructor TAssociation.Create(const AKeyRules: TRules; const AValueRules: TRules);\r\nbegin\r\n inherited Create;\r\n\r\n FKeyRules := AKeyRules;\r\n FValueRules := AValueRules;\r\nend;\r\n\r\nfunction TAssociation.DistinctByKeys: IAssociation;\r\nbegin\r\n Result := TAssociativeDistinctByKeysSequence.Create(Self);\r\nend;\r\n\r\nfunction TAssociation.DistinctByValues: IAssociation;\r\nbegin\r\n Result := TAssociativeDistinctByValuesSequence.Create(Self);\r\nend;\r\n\r\nfunction TAssociation.GetKeyHashCode(const AValue: TKey): NativeInt;\r\nbegin\r\n { Lazy init }\r\n if not Assigned(FKeyRules.FEqComparer) then\r\n FKeyRules.FEqComparer := TEqualityComparer.Default;\r\n\r\n Result := FKeyRules.FEqComparer.GetHashCode(AValue);\r\nend;\r\n\r\nfunction TAssociation.GetValueHashCode(const AValue: TValue): NativeInt;\r\nbegin\r\n { Lazy init }\r\n if not Assigned(FValueRules.FEqComparer) then\r\n FValueRules.FEqComparer := TEqualityComparer.Default;\r\n\r\n Result := FValueRules.FEqComparer.GetHashCode(AValue);\r\nend;\r\n\r\nprocedure TAssociation.HandleKeyRemoved(const AKey: TKey);\r\nbegin\r\n // Nothing!\r\nend;\r\n\r\nprocedure TAssociation.HandleValueRemoved(const AValue: TValue);\r\nbegin\r\n // Nothing!\r\nend;\r\n\r\nfunction TAssociation.Includes(const ACollection: IEnumerable>): Boolean;\r\nvar\r\n LEnumerator: IEnumerator>;\r\nbegin\r\n { Retrieve the enumerator object }\r\n LEnumerator := ACollection.GetEnumerator();\r\n\r\n { Iterate till the last element in the LEnumerator }\r\n while LEnumerator.MoveNext do\r\n begin\r\n if not KeyHasValue(LEnumerator.Current.Key, LEnumerator.Current.Value) then\r\n Exit(false);\r\n end;\r\n\r\n { We got here, it means all is OK }\r\n Result := true;\r\nend;\r\n\r\nfunction TAssociation.KeyHasValue(const AKey: TKey; const AValue: TValue): Boolean;\r\nvar\r\n LEnumerator: IEnumerator>;\r\nbegin\r\n { Retrieve the enumerator object and type }\r\n LEnumerator := GetEnumerator();\r\n\r\n { Iterate till the last element in the LEnumerator }\r\n while LEnumerator.MoveNext do\r\n begin\r\n if KeysAreEqual(LEnumerator.Current.Key, AKey) and\r\n ValuesAreEqual(LEnumerator.Current.Value, AValue) then\r\n Exit(true);\r\n end;\r\n\r\n { No found! }\r\n Result := false;\r\nend;\r\n\r\nfunction TAssociation.KeysAreEqual(const ALeft, ARight: TKey): Boolean;\r\nbegin\r\n { Lazy init }\r\n if not Assigned(FKeyRules.FEqComparer) then\r\n FKeyRules.FEqComparer := TEqualityComparer.Default;\r\n\r\n Result := FKeyRules.FEqComparer.Equals(ALeft, ARight);\r\nend;\r\n\r\nfunction TAssociation.MaxKey: TKey;\r\nvar\r\n LEnumerator: IEnumerator>;\r\nbegin\r\n { Retrieve the enumerator object and type }\r\n LEnumerator := GetEnumerator();\r\n\r\n { Get the first object in the enumeration, otherwise fail! }\r\n if not LEnumerator.MoveNext() then\r\n ExceptionHelper.Throw_CollectionEmptyError();\r\n\r\n { Select the first element as comparison base }\r\n Result := LEnumerator.Current.Key;\r\n\r\n { Iterate till the last element in the LEnumerator }\r\n while true do\r\n begin\r\n if CompareKeys(LEnumerator.Current.Key, Result) > 0 then\r\n Result := LEnumerator.Current.Key;\r\n\r\n { Exit if we hit the last element }\r\n if not LEnumerator.MoveNext() then\r\n Exit;\r\n end;\r\nend;\r\n\r\nfunction TAssociation.MaxValue: TValue;\r\nvar\r\n LEnumerator: IEnumerator>;\r\nbegin\r\n { Retrieve the enumerator object and type }\r\n LEnumerator := GetEnumerator();\r\n\r\n { Get the first object in the enumeration, otherwise fail! }\r\n if not LEnumerator.MoveNext() then\r\n ExceptionHelper.Throw_CollectionEmptyError();\r\n\r\n { Select the first element as comparison base }\r\n Result := LEnumerator.Current.Value;\r\n\r\n { Iterate till the last element in the LEnumerator }\r\n while true do\r\n begin\r\n if CompareValues(LEnumerator.Current.Value, Result) > 0 then\r\n Result := LEnumerator.Current.Value;\r\n\r\n { Exit if we hit the last element }\r\n if not LEnumerator.MoveNext() then\r\n Exit;\r\n end;\r\nend;\r\n\r\nfunction TAssociation.MinKey: TKey;\r\nvar\r\n LEnumerator: IEnumerator>;\r\nbegin\r\n { Retrieve the enumerator object and type }\r\n LEnumerator := GetEnumerator();\r\n\r\n { Get the first object in the enumeration, otherwise fail! }\r\n if not LEnumerator.MoveNext() then\r\n ExceptionHelper.Throw_CollectionEmptyError();\r\n\r\n { Select the first element as comparison base }\r\n Result := LEnumerator.Current.Key;\r\n\r\n { Iterate till the last element in the LEnumerator }\r\n while true do\r\n begin\r\n if CompareKeys(LEnumerator.Current.Key, Result) < 0 then\r\n Result := LEnumerator.Current.Key;\r\n\r\n { Exit if we hit the last element }\r\n if not LEnumerator.MoveNext() then\r\n Exit;\r\n end;\r\nend;\r\n\r\nfunction TAssociation.MinValue: TValue;\r\nvar\r\n LEnumerator: IEnumerator>;\r\nbegin\r\n { Retrieve the enumerator object and type }\r\n LEnumerator := GetEnumerator();\r\n\r\n { Get the first object in the enumeration, otherwise fail! }\r\n if not LEnumerator.MoveNext() then\r\n ExceptionHelper.Throw_CollectionEmptyError();\r\n\r\n { Select the first element as comparison base }\r\n Result := LEnumerator.Current.Value;\r\n\r\n { Iterate till the last element in the LEnumerator }\r\n while true do\r\n begin\r\n if CompareValues(LEnumerator.Current.Value, Result) < 0 then\r\n Result := LEnumerator.Current.Value;\r\n\r\n { Exit if we hit the last element }\r\n if not LEnumerator.MoveNext() then\r\n Exit;\r\n end;\r\nend;\r\n\r\nprocedure TAssociation.NotifyKeyRemoved(const AKey: TKey);\r\nbegin\r\n { Handle stuff }\r\n if Assigned(FKeyRemoveNotification) then\r\n FKeyRemoveNotification(AKey)\r\n else\r\n HandleKeyRemoved(AKey);\r\nend;\r\n\r\nprocedure TAssociation.NotifyValueRemoved(const AValue: TValue);\r\nbegin\r\n { Handle stuff }\r\n if Assigned(FValueRemoveNotification) then\r\n FValueRemoveNotification(AValue)\r\n else\r\n HandleValueRemoved(AValue);\r\nend;\r\n\r\nfunction TAssociation.SelectKeys: ISequence;\r\nbegin\r\n { Create a selector }\r\n Result := TSelectKeysSequence.Create(Self);\r\nend;\r\n\r\nfunction TAssociation.SelectValues: ISequence;\r\nbegin\r\n { Create a selector }\r\n Result := TSelectValuesSequence.Create(Self);\r\nend;\r\n\r\nfunction TAssociation.ToDictionary: IDictionary;\r\nbegin\r\n Result := TDictionary.Create(KeyRules, ValueRules);\r\n Result.AddAll(Self);\r\nend;\r\n\r\nfunction TAssociation.ValueForKey(const AKey: TKey): TValue;\r\nvar\r\n LEnumerator: IEnumerator>;\r\nbegin\r\n { Retrieve the enumerator object and type }\r\n LEnumerator := GetEnumerator();\r\n\r\n { Iterate till the last element in the LEnumerator }\r\n while LEnumerator.MoveNext do\r\n begin\r\n if KeysAreEqual(LEnumerator.Current.Key, AKey) then\r\n Exit(LEnumerator.Current.Value);\r\n end;\r\n\r\n { If nothing found, simply raise an exception }\r\n ExceptionHelper.Throw_KeyNotFoundError('AKey');\r\nend;\r\n\r\nfunction TAssociation.ValuesAreEqual(const ALeft, ARight: TValue): Boolean;\r\nbegin\r\n { Lazy init }\r\n if not Assigned(FValueRules.FEqComparer) then\r\n FValueRules.FEqComparer := TEqualityComparer.Default;\r\n\r\n Result := FValueRules.FEqComparer.Equals(ALeft, ARight);\r\nend;\r\n\r\nfunction TAssociation.Where(\r\n const APredicate: TPredicate): IAssociation;\r\nbegin\r\n { Check arguments }\r\n if not Assigned(APredicate) then\r\n ExceptionHelper.Throw_ArgumentNilError('APredicate');\r\n\r\n { Create a new Enex collection }\r\n Result := TAssociativeWhereSequence.Create(Self, APredicate, False); // Don't invert the result\r\nend;\r\n\r\nfunction TAssociation.WhereKeyBetween(const ALower,\r\n AHigher: TKey): IAssociation;\r\nvar\r\n LLower, LHigher: TKey;\r\nbegin\r\n { Locals }\r\n LLower := ALower;\r\n LHigher := AHigher;\r\n\r\n { Use Where() and pass an anonymous function }\r\n Result := Where(\r\n function(Arg1: TKey; Arg2: TValue): Boolean\r\n begin\r\n Exit((CompareKeys(Arg1, LLower) >= 0) and (CompareKeys(Arg1, LHigher) <= 0));\r\n end\r\n );\r\nend;\r\n\r\nfunction TAssociation.WhereKeyGreater(\r\n const ABound: TKey): IAssociation;\r\nvar\r\n LBound: TKey;\r\nbegin\r\n { Locals }\r\n LBound := ABound;\r\n\r\n { Use Where() and pass an anonymous function }\r\n Result := Where(\r\n function(Arg1: TKey; Arg2: TValue): Boolean\r\n begin\r\n Exit(CompareKeys(Arg1, LBound) > 0);\r\n end\r\n );\r\nend;\r\n\r\nfunction TAssociation.WhereKeyGreaterOrEqual(\r\n const ABound: TKey): IAssociation;\r\nvar\r\n LBound: TKey;\r\nbegin\r\n { Locals }\r\n LBound := ABound;\r\n\r\n { Use Where() and pass an anonymous function }\r\n Result := Where(\r\n function(Arg1: TKey; Arg2: TValue): Boolean\r\n begin\r\n Exit(CompareKeys(Arg1, LBound) >= 0);\r\n end\r\n );\r\nend;\r\n\r\nfunction TAssociation.WhereKeyLower(\r\n const ABound: TKey): IAssociation;\r\nvar\r\n LBound: TKey;\r\n LRules: TRules;\r\nbegin\r\n { Locals }\r\n LBound := ABound;\r\n\r\n { Use Where() and pass an anonymous function }\r\n Result := Where(\r\n function(Arg1: TKey; Arg2: TValue): Boolean\r\n begin\r\n Exit(CompareKeys(Arg1, LBound) < 0);\r\n end\r\n );\r\nend;\r\n\r\nfunction TAssociation.WhereKeyLowerOrEqual(\r\n const ABound: TKey): IAssociation;\r\nvar\r\n LBound: TKey;\r\nbegin\r\n { Locals }\r\n LBound := ABound;\r\n\r\n { Use Where() and pass an anonymous function }\r\n Result := Where(\r\n function(Arg1: TKey; Arg2: TValue): Boolean\r\n begin\r\n Exit(CompareKeys(Arg1, LBound) <= 0);\r\n end\r\n );\r\nend;\r\n\r\nfunction TAssociation.WhereNot(\r\n const APredicate: TPredicate): IAssociation;\r\nbegin\r\n { Check arguments }\r\n if not Assigned(APredicate) then\r\n ExceptionHelper.Throw_ArgumentNilError('APredicate');\r\n\r\n { Create a new Enex collection }\r\n Result := TAssociativeWhereSequence.Create(Self, APredicate, True); // Invert the result\r\nend;\r\n\r\nfunction TAssociation.WhereValueBetween(\r\n const ALower, AHigher: TValue): IAssociation;\r\nvar\r\n LLower, LHigher: TValue;\r\nbegin\r\n { Locals }\r\n LLower := ALower;\r\n LHigher := AHigher;\r\n\r\n { Use Where() and pass an anonymous function }\r\n Result := Where(\r\n function(Arg1: TKey; Arg2: TValue): Boolean\r\n begin\r\n Exit((CompareValues(Arg2, LLower) >= 0) and (CompareValues(Arg2, LHigher) <= 0));\r\n end\r\n );\r\nend;\r\n\r\nfunction TAssociation.WhereValueGreater(\r\n const ABound: TValue): IAssociation;\r\nvar\r\n LBound: TValue;\r\nbegin\r\n { Locals }\r\n LBound := ABound;\r\n\r\n { Use Where() and pass an anonymous function }\r\n Result := Where(\r\n function(Arg1: TKey; Arg2: TValue): Boolean\r\n begin\r\n Exit(CompareValues(Arg2, LBound) > 0);\r\n end\r\n );\r\nend;\r\n\r\nfunction TAssociation.WhereValueGreaterOrEqual(\r\n const ABound: TValue): IAssociation;\r\nvar\r\n LBound: TValue;\r\nbegin\r\n { Locals }\r\n LBound := ABound;\r\n\r\n { Use Where() and pass an anonymous function }\r\n Result := Where(\r\n function(Arg1: TKey; Arg2: TValue): Boolean\r\n begin\r\n Exit(CompareValues(Arg2, LBound) >= 0);\r\n end\r\n );\r\nend;\r\n\r\nfunction TAssociation.WhereValueLower(\r\n const ABound: TValue): IAssociation;\r\nvar\r\n LBound: TValue;\r\nbegin\r\n { Locals }\r\n LBound := ABound;\r\n\r\n { Use Where() and pass an anonymous function }\r\n Result := Where(\r\n function(Arg1: TKey; Arg2: TValue): Boolean\r\n begin\r\n Exit(CompareValues(Arg2, LBound) < 0);\r\n end\r\n );\r\nend;\r\n\r\nfunction TAssociation.WhereValueLowerOrEqual(\r\n const ABound: TValue): IAssociation;\r\nvar\r\n LBound: TValue;\r\nbegin\r\n { Locals }\r\n LBound := ABound;\r\n\r\n { Use Where() and pass an anonymous function }\r\n Result := Where(\r\n function(Arg1: TKey; Arg2: TValue): Boolean\r\n begin\r\n Exit(CompareValues(Arg2, LBound) <= 0);\r\n end\r\n );\r\nend;\r\n\r\n\r\n{ TAbstractMap }\r\n\r\nprocedure TAbstractMap.Add(const AKey: TKey; const AValue: TValue);\r\nbegin\r\n ExceptionHelper.Throw_OperationNotSupported('Add');\r\nend;\r\n\r\nprocedure TAbstractMap.Add(const APair: TPair);\r\nbegin\r\n Add(APair.Key, APair.Value);\r\nend;\r\n\r\nprocedure TAbstractMap.AddAll(const ACollection: IEnumerable>);\r\nvar\r\n LPair: TPair;\r\nbegin\r\n if not Assigned(ACollection) then\r\n ExceptionHelper.Throw_ArgumentNilError('ACollection');\r\n\r\n for LPair in ACollection do\r\n Add(LPair.Key, LPair.Value);\r\nend;\r\n\r\nprocedure TAbstractMap.Clear;\r\nvar\r\n LKeys: IList;\r\n LKey: TKey;\r\nbegin\r\n LKeys := SelectKeys().ToList();\r\n for LKey in LKeys do\r\n begin\r\n Remove(LKey);\r\n NotifyKeyRemoved(LKey);\r\n end;\r\nend;\r\n\r\nfunction TAbstractMap.ContainsKey(const AKey: TKey): Boolean;\r\nvar\r\n LEnumerator: IEnumerator>;\r\nbegin\r\n LEnumerator := GetEnumerator();\r\n while LEnumerator.MoveNext() do\r\n if KeysAreEqual(LEnumerator.Current.Key, AKey) then\r\n Exit(True);\r\n\r\n Result := False;\r\nend;\r\n\r\nfunction TAbstractMap.ContainsValue(const AValue: TValue): Boolean;\r\nvar\r\n LEnumerator: IEnumerator>;\r\nbegin\r\n LEnumerator := GetEnumerator();\r\n while LEnumerator.MoveNext() do\r\n if ValuesAreEqual(LEnumerator.Current.Value, AValue) then\r\n Exit(True);\r\n\r\n Result := False;\r\nend;\r\n\r\ndestructor TAbstractMap.Destroy;\r\nbegin\r\n Clear();\r\n inherited;\r\nend;\r\n\r\nprocedure TAbstractMap.Remove(const AKey: TKey);\r\nbegin\r\n ExceptionHelper.Throw_OperationNotSupported('Remove');\r\nend;\r\n\r\n{ Collections.TWhereSequence }\r\n\r\nconstructor TWhereSequence.Create(const ACollection: TSequence;\r\n const APredicate: TPredicate; const AInvertResult: Boolean);\r\nbegin\r\n { Check arguments }\r\n if not Assigned(APredicate) then\r\n ExceptionHelper.Throw_ArgumentNilError('APredicate');\r\n\r\n if not Assigned(ACollection) then\r\n ExceptionHelper.Throw_ArgumentNilError('ACollection');\r\n\r\n inherited Create(ACollection.ElementRules);\r\n\r\n { Assign internals }\r\n FCollection := ACollection;\r\n KeepObjectAlive(FCollection);\r\n\r\n FPredicate := APredicate;\r\n FInvertResult := AInvertResult;\r\nend;\r\n\r\ndestructor TWhereSequence.Destroy;\r\nbegin\r\n { Delete the enumerable if required }\r\n ReleaseObject(FCollection, false);\r\n\r\n inherited;\r\nend;\r\n\r\nfunction TWhereSequence.GetEnumerator: IEnumerator;\r\nbegin\r\n { Generate an enumerator }\r\n Result := TEnumerator.Create(Self, FCollection.GetEnumerator());\r\nend;\r\n\r\n{ TWhereSequence.TEnumerator }\r\n\r\nfunction TWhereSequence.TEnumerator.AcceptValue(const AValue: T): Boolean;\r\nbegin\r\n with TWhereSequence(Owner) do\r\n Result := FPredicate(AValue) xor FInvertResult;\r\nend;\r\n\r\n{ TSelectSequence }\r\n\r\nconstructor TSelectSequence.Create(const ACollection: TSequence;\r\n const ASelector: TFunc; const ARules: TRules);\r\nbegin\r\n { Check arguments }\r\n if not Assigned(ASelector) then\r\n ExceptionHelper.Throw_ArgumentNilError('ASelector');\r\n\r\n if not Assigned(ACollection) then\r\n ExceptionHelper.Throw_ArgumentNilError('ACollection');\r\n\r\n { Rules ... }\r\n inherited Create(ARules);\r\n\r\n { Assign internals }\r\n FCollection := ACollection;\r\n KeepObjectAlive(FCollection);\r\n\r\n FSelector := ASelector;\r\nend;\r\n\r\ndestructor TSelectSequence.Destroy;\r\nbegin\r\n { Delete the enumerable if required }\r\n ReleaseObject(FCollection, false);\r\n\r\n inherited;\r\nend;\r\n\r\nfunction TSelectSequence.ElementAt(const AIndex: NativeInt): TOut;\r\nbegin\r\n Result := FSelector(FCollection.ElementAt(AIndex));\r\nend;\r\n\r\nfunction TSelectSequence.Empty: Boolean;\r\nbegin\r\n Result := FCollection.Empty;\r\nend;\r\n\r\nfunction TSelectSequence.First: TOut;\r\nbegin\r\n Result := FSelector(FCollection.First);\r\nend;\r\n\r\nfunction TSelectSequence.GetCount: NativeInt;\r\nbegin\r\n Result := FCollection.GetCount();\r\nend;\r\n\r\nfunction TSelectSequence.GetEnumerator: IEnumerator;\r\nvar\r\n LEnumerator: TEnumerator;\r\nbegin\r\n LEnumerator := TEnumerator.Create(Self);\r\n LEnumerator.FInEnumerator := FCollection.GetEnumerator();\r\n Result := LEnumerator;\r\nend;\r\n\r\nfunction TSelectSequence.Last: TOut;\r\nbegin\r\n Result := FSelector(FCollection.Last);\r\nend;\r\n\r\nfunction TSelectSequence.Single: TOut;\r\nbegin\r\n Result := FSelector(FCollection.Single);\r\nend;\r\n\r\n{ TSelectSequence.TEnumerator }\r\n\r\nfunction TSelectSequence.TEnumerator.TryMoveNext(out ACurrent: TOut): Boolean;\r\nbegin\r\n { Next iteration }\r\n Result := FInEnumerator.MoveNext();\r\n\r\n { Terminate on sub-enum termination }\r\n if not Result then\r\n Exit;\r\n\r\n { Return the next \"selected\" element }\r\n ACurrent := TSelectSequence(Owner).FSelector(FInEnumerator.Current);\r\nend;\r\n\r\n{ TConcatSequence }\r\n\r\nfunction TConcatSequence.All(const APredicate: TPredicate): Boolean;\r\nbegin\r\n Result := FCollection1.All(APredicate) and FCollection2.All(APredicate);\r\nend;\r\n\r\nfunction TConcatSequence.Any(const APredicate: TPredicate): Boolean;\r\nbegin\r\n Result := FCollection1.Any(APredicate) or FCollection2.Any(APredicate);\r\nend;\r\n\r\nconstructor TConcatSequence.Create(\r\n const ACollection1: TSequence; const ACollection2: ISequence);\r\nbegin\r\n { Check arguments }\r\n if not Assigned(ACollection1) then\r\n ExceptionHelper.Throw_ArgumentNilError('ACollection1');\r\n\r\n if not Assigned(ACollection2) then\r\n ExceptionHelper.Throw_ArgumentNilError('ACollection2');\r\n\r\n { Rules ... }\r\n inherited Create(ACollection1.ElementRules);\r\n\r\n { Assign internals }\r\n FCollection1 := ACollection1;\r\n KeepObjectAlive(FCollection1);\r\n\r\n FCollection2 := ACollection2;\r\nend;\r\n\r\ndestructor TConcatSequence.Destroy;\r\nbegin\r\n { Delete the enumerable if required }\r\n ReleaseObject(FCollection1, false);\r\n\r\n inherited;\r\nend;\r\n\r\nfunction TConcatSequence.Empty: Boolean;\r\nbegin\r\n Result := (GetCount = 0);\r\nend;\r\n\r\nfunction TConcatSequence.GetCount: NativeInt;\r\nbegin\r\n Result := FCollection1.GetCount() + FCollection2.GetCount();\r\nend;\r\n\r\nfunction TConcatSequence.GetEnumerator: IEnumerator;\r\nvar\r\n LEnumerator: TEnumerator;\r\nbegin\r\n LEnumerator := TEnumerator.Create(Self);\r\n LEnumerator.FInEnumerator1 := FCollection1.GetEnumerator();\r\n LEnumerator.FInEnumerator2 := FCollection2.GetEnumerator();\r\n Result := LEnumerator;\r\nend;\r\n\r\n{ TConcatSequence.TEnumerator }\r\n\r\nfunction TConcatSequence.TEnumerator.TryMoveNext(out ACurrent: T): Boolean;\r\nbegin\r\n if Assigned(FInEnumerator1) then\r\n begin\r\n { Iterate over 1 }\r\n Result := FInEnumerator1.MoveNext();\r\n\r\n { Succesefully iterated collection 1 }\r\n if Result then\r\n begin\r\n ACurrent := FInEnumerator1.Current;\r\n Exit;\r\n end;\r\n\r\n { We've reached the bottom of 1 }\r\n FInEnumerator1 := nil;\r\n end;\r\n\r\n { Iterate over 2 now }\r\n Result := FInEnumerator2.MoveNext();\r\n if Result then\r\n ACurrent := FInEnumerator2.Current;\r\nend;\r\n\r\n{ TUnionSequence }\r\n\r\nconstructor TUnionSequence.Create(\r\n const ACollection1: TSequence; const ACollection2: ISequence);\r\nbegin\r\n { Check arguments }\r\n if not Assigned(ACollection1) then\r\n ExceptionHelper.Throw_ArgumentNilError('ACollection1');\r\n\r\n if not Assigned(ACollection2) then\r\n ExceptionHelper.Throw_ArgumentNilError('ACollection2');\r\n\r\n { Rules ... }\r\n inherited Create(ACollection1.ElementRules);\r\n\r\n { Assign internals }\r\n FCollection1 := ACollection1;\r\n KeepObjectAlive(FCollection1);\r\n\r\n FCollection2 := ACollection2;\r\nend;\r\n\r\ndestructor TUnionSequence.Destroy;\r\nbegin\r\n { Delete the enumerable if required }\r\n ReleaseObject(FCollection1, false);\r\n\r\n inherited;\r\nend;\r\n\r\nfunction TUnionSequence.GetEnumerator: IEnumerator;\r\nvar\r\n LEnumerator: TEnumerator;\r\nbegin\r\n LEnumerator := TEnumerator.Create(Self);\r\n LEnumerator.FSet := THashSet.Create();\r\n LEnumerator.FInEnumerator1 := FCollection1.GetEnumerator();\r\n LEnumerator.FInEnumerator2 := FCollection2.GetEnumerator();\r\n Result := LEnumerator;\r\nend;\r\n\r\n{ TUnionSequence.TEnumerator }\r\n\r\nfunction TUnionSequence.TEnumerator.TryMoveNext(out ACurrent: T): Boolean;\r\nbegin\r\n if Assigned(FInEnumerator1) then\r\n begin\r\n { Iterate over 1 }\r\n Result := FInEnumerator1.MoveNext();\r\n\r\n { Succesefully iterated collection 1 }\r\n if Result then\r\n begin\r\n { Add the element to the set }\r\n ACurrent := FInEnumerator1.Current;\r\n FSet.Add(ACurrent);\r\n Exit;\r\n end;\r\n\r\n { We've reached the bottom of 1 }\r\n FInEnumerator1 := nil;\r\n end;\r\n\r\n { Continue until we find what we need or we get to the bottom }\r\n while True do\r\n begin\r\n { Iterate over 2 now }\r\n Result := FInEnumerator2.MoveNext();\r\n\r\n { Exit on bad result }\r\n if not Result then\r\n Exit;\r\n\r\n { Exit if the element is good }\r\n if not FSet.Contains(FInEnumerator2.Current) then\r\n begin\r\n ACurrent := FInEnumerator2.Current;\r\n FSet.Add(ACurrent);\r\n Exit;\r\n end;\r\n end;\r\nend;\r\n\r\n{ TExclusionSequence }\r\n\r\nconstructor TExclusionSequence.Create(\r\n const ACollection1: TSequence; const ACollection2: ISequence);\r\nbegin\r\n { Check arguments }\r\n if not Assigned(ACollection1) then\r\n ExceptionHelper.Throw_ArgumentNilError('ACollection1');\r\n\r\n if not Assigned(ACollection2) then\r\n ExceptionHelper.Throw_ArgumentNilError('ACollection2');\r\n\r\n { Rules ... }\r\n inherited Create(ACollection1.ElementRules);\r\n\r\n { Assign internals }\r\n FCollection1 := ACollection1;\r\n KeepObjectAlive(FCollection1);\r\n\r\n FCollection2 := ACollection2;\r\nend;\r\n\r\ndestructor TExclusionSequence.Destroy;\r\nbegin\r\n { Delete the enumerable if required }\r\n ReleaseObject(FCollection1, false);\r\n\r\n inherited;\r\nend;\r\n\r\nfunction TExclusionSequence.GetEnumerator: IEnumerator;\r\nvar\r\n LEnumerator: TEnumerator;\r\nbegin\r\n LEnumerator := TEnumerator.Create(Self);\r\n LEnumerator.FSet := THashSet.Create();\r\n LEnumerator.FInEnumerator1 := FCollection1.GetEnumerator();\r\n LEnumerator.FInEnumerator2 := FCollection2.GetEnumerator();\r\n Result := LEnumerator;\r\nend;\r\n\r\n{ TExclusionSequence.TEnumerator }\r\n\r\nfunction TExclusionSequence.TEnumerator.TryMoveNext(out ACurrent: T): Boolean;\r\nbegin\r\n { Load the first enum into the set }\r\n if Assigned(FInEnumerator2) then\r\n begin\r\n while FInEnumerator2.MoveNext() do\r\n FSet.Add(FInEnumerator2.Current);\r\n\r\n FInEnumerator2 := nil;\r\n end;\r\n\r\n { Continue until we find what we need or we get to the bottom }\r\n while True do\r\n begin\r\n { Iterate over 1 }\r\n Result := FInEnumerator1.MoveNext();\r\n\r\n { Exit on bad result }\r\n if not Result then\r\n Exit;\r\n\r\n { Exit if the element is good }\r\n if not FSet.Contains(FInEnumerator1.Current) then\r\n begin\r\n ACurrent := FInEnumerator1.Current;\r\n Exit;\r\n end;\r\n end;\r\nend;\r\n\r\n{ TIntersectionSequence }\r\n\r\nconstructor TIntersectionSequence.Create(\r\n const ACollection1: TSequence; const ACollection2: ISequence);\r\nbegin\r\n { Check arguments }\r\n if not Assigned(ACollection1) then\r\n ExceptionHelper.Throw_ArgumentNilError('ACollection1');\r\n\r\n if not Assigned(ACollection2) then\r\n ExceptionHelper.Throw_ArgumentNilError('ACollection2');\r\n\r\n { Rules ... }\r\n inherited Create(ACollection1.ElementRules);\r\n\r\n { Assign internals }\r\n FCollection1 := ACollection1;\r\n KeepObjectAlive(FCollection1);\r\n\r\n FCollection2 := ACollection2;\r\nend;\r\n\r\ndestructor TIntersectionSequence.Destroy;\r\nbegin\r\n { Delete the enumerable if required }\r\n ReleaseObject(FCollection1, false);\r\n\r\n inherited;\r\nend;\r\n\r\nfunction TIntersectionSequence.GetEnumerator: IEnumerator;\r\nvar\r\n LEnumerator: TEnumerator;\r\nbegin\r\n LEnumerator := TEnumerator.Create(Self);\r\n LEnumerator.FSet := THashSet.Create();\r\n LEnumerator.FInEnumerator1 := FCollection1.GetEnumerator();\r\n LEnumerator.FInEnumerator2 := FCollection2.GetEnumerator();\r\n Result := LEnumerator;\r\nend;\r\n\r\n{ Collection.TIntersectionSequence.TEnumerator }\r\n\r\nfunction TIntersectionSequence.TEnumerator.TryMoveNext(out ACurrent: T): Boolean;\r\nbegin\r\n { Load the first enum into the set }\r\n if Assigned(FInEnumerator1) then\r\n begin\r\n while FInEnumerator1.MoveNext() do\r\n FSet.Add(FInEnumerator1.Current);\r\n\r\n FInEnumerator1 := nil;\r\n end;\r\n\r\n { Continue until we find what we need or we get to the bottom }\r\n while True do\r\n begin\r\n { Iterate over 1 }\r\n Result := FInEnumerator2.MoveNext();\r\n\r\n { Exit on bad result }\r\n if not Result then\r\n Exit;\r\n\r\n { Exit if the element is good }\r\n if FSet.Contains(FInEnumerator2.Current) then\r\n begin\r\n ACurrent := FInEnumerator2.Current;\r\n Exit;\r\n end;\r\n end;\r\nend;\r\n\r\n{ TRangeSequence }\r\n\r\nconstructor TRangeSequence.Create(const ACollection: TSequence; const AStart, AEnd: NativeInt);\r\nbegin\r\n if AStart < 0 then\r\n ExceptionHelper.Throw_ArgumentOutOfRangeError('AStart');\r\n\r\n if AEnd < 0 then\r\n ExceptionHelper.Throw_ArgumentOutOfRangeError('AEnd');\r\n\r\n { Check arguments }\r\n if not Assigned(ACollection) then\r\n ExceptionHelper.Throw_ArgumentNilError('ACollection');\r\n\r\n { Rules ... }\r\n inherited Create(ACollection.ElementRules);\r\n\r\n { Assign internals }\r\n FCollection := ACollection;\r\n KeepObjectAlive(FCollection);\r\n\r\n FStart := AStart;\r\n FEnd := AEnd;\r\nend;\r\n\r\ndestructor TRangeSequence.Destroy;\r\nbegin\r\n { Delete the enumerable if required }\r\n ReleaseObject(FCollection, false);\r\n\r\n inherited;\r\nend;\r\n\r\nfunction TRangeSequence.GetEnumerator: IEnumerator;\r\nvar\r\n LEnumerator: TEnumerator;\r\nbegin\r\n LEnumerator := TEnumerator.Create(Self);\r\n LEnumerator.FInEnumerator := FCollection.GetEnumerator();\r\n Result := LEnumerator;\r\nend;\r\n\r\n{ TRangeSequence.TEnumerator }\r\n\r\nfunction TRangeSequence.TEnumerator.TryMoveNext(out ACurrent: T): Boolean;\r\nbegin\r\n with TRangeSequence(Owner) do\r\n begin\r\n while FCurrentIndex < FStart do\r\n begin\r\n { Move cursor }\r\n Result := FInEnumerator.MoveNext();\r\n if not Result then\r\n Exit;\r\n Inc(FCurrentIndex);\r\n end;\r\n\r\n { Check if we're finished }\r\n if (FCurrentIndex > FEnd) then\r\n Exit(false);\r\n\r\n { Move the cursor next in the sub-enum, and increase index }\r\n Result := FInEnumerator.MoveNext();\r\n if not Result then\r\n Exit;\r\n\r\n ACurrent := FInEnumerator.Current;\r\n Inc(FCurrentIndex);\r\n end;\r\nend;\r\n\r\n{ TDistinctSequence }\r\n\r\nconstructor TDistinctSequence.Create(const ACollection: TSequence);\r\nbegin\r\n { Check arguments }\r\n if not Assigned(ACollection) then\r\n ExceptionHelper.Throw_ArgumentNilError('ACollection');\r\n\r\n inherited Create(ACollection.ElementRules);\r\n\r\n { Assign internals }\r\n FCollection := ACollection;\r\n KeepObjectAlive(FCollection);\r\nend;\r\n\r\ndestructor TDistinctSequence.Destroy;\r\nbegin\r\n { Delete the enumerable if required }\r\n ReleaseObject(FCollection, false);\r\n\r\n inherited;\r\nend;\r\n\r\nfunction TDistinctSequence.GetEnumerator: IEnumerator;\r\nvar\r\n LEnumerator: TEnumerator;\r\nbegin\r\n LEnumerator := TEnumerator.Create(Self, FCollection.GetEnumerator());\r\n LEnumerator.FSet := THashSet.Create();\r\n Result := LEnumerator;\r\nend;\r\n\r\n{ TDistinctSequence.TEnumerator }\r\n\r\nfunction TDistinctSequence.TEnumerator.AcceptValue(const AValue: T): Boolean;\r\nbegin\r\n Result := not FSet.Contains(AValue);\r\n if Result then\r\n FSet.Add(AValue);\r\nend;\r\n\r\n{ TFillSequence }\r\n\r\nfunction TFillSequence.Aggregate(const AAggregator: TFunc): T;\r\nvar\r\n I: NativeInt;\r\nbegin\r\n { Check arguments }\r\n if not Assigned(AAggregator) then\r\n ExceptionHelper.Throw_ArgumentNilError('AAggregator');\r\n\r\n if FCount = 0 then\r\n ExceptionHelper.Throw_CollectionEmptyError();\r\n\r\n { Select the first element as comparison base }\r\n Result := FElement;\r\n\r\n { Iterate over the last N - 1 elements }\r\n for I := 1 to FCount - 1 do\r\n begin\r\n { Aggregate a value }\r\n Result := AAggregator(Result, FElement);\r\n end;\r\nend;\r\n\r\nfunction TFillSequence.AggregateOrDefault(const AAggregator: TFunc; const ADefault: T): T;\r\nvar\r\n I: NativeInt;\r\nbegin\r\n { Check arguments }\r\n if not Assigned(AAggregator) then\r\n ExceptionHelper.Throw_ArgumentNilError('AAggregator');\r\n\r\n if FCount = 0 then\r\n Exit(ADefault);\r\n\r\n { Select the first element as comparison base }\r\n Result := FElement;\r\n\r\n { Iterate over the last N - 1 elements }\r\n for I := 1 to FCount - 1 do\r\n begin\r\n { Aggregate a value }\r\n Result := AAggregator(Result, FElement);\r\n end;\r\nend;\r\n\r\nfunction TFillSequence.All(const APredicate: TPredicate): Boolean;\r\nbegin\r\n if not Assigned(APredicate) then\r\n ExceptionHelper.Throw_ArgumentNilError('APredicate');\r\n\r\n if not APredicate(FElement) then\r\n Result := false\r\n else\r\n Result := true;\r\nend;\r\n\r\nfunction TFillSequence.Any(const APredicate: TPredicate): Boolean;\r\nbegin\r\n if not Assigned(APredicate) then\r\n ExceptionHelper.Throw_ArgumentNilError('APredicate');\r\n\r\n if APredicate(FElement) then\r\n Result := true\r\n else\r\n Result := false;\r\nend;\r\n\r\nconstructor TFillSequence.Create(const AElement: T; const ACount: NativeInt; const ARules: TRules);\r\nbegin\r\n if ACount <= 0 then\r\n ExceptionHelper.Throw_ArgumentOutOfRangeError('ACount');\r\n\r\n { Install the type }\r\n inherited Create(ARules);\r\n\r\n { Copy values in }\r\n FCount := ACount;\r\n FElement := AElement;\r\nend;\r\n\r\nfunction TFillSequence.ElementAt(const AIndex: NativeInt): T;\r\nbegin\r\n if (AIndex = FCount) or (AIndex < 0) then\r\n ExceptionHelper.Throw_ArgumentOutOfRangeError('AIndex');\r\n\r\n Result := FElement;\r\nend;\r\n\r\nfunction TFillSequence.ElementAtOrDefault(const AIndex: NativeInt; const ADefault: T): T;\r\nbegin\r\n if (AIndex = FCount) or (AIndex < 0) then\r\n Result := ADefault\r\n else\r\n Result := FElement;\r\nend;\r\n\r\nfunction TFillSequence.Empty: Boolean;\r\nbegin\r\n Result := (FCount = 0);\r\nend;\r\n\r\nfunction TFillSequence.EqualsTo(const ACollection: IEnumerable): Boolean;\r\nvar\r\n LValue: T;\r\n I: NativeInt;\r\nbegin\r\n I := 0;\r\n\r\n for LValue in ACollection do\r\n begin\r\n if I >= FCount then\r\n Exit(false);\r\n\r\n if not ElementsAreEqual(FElement, LValue) then\r\n Exit(false);\r\n\r\n Inc(I);\r\n end;\r\n\r\n if I < FCount then\r\n Exit(false);\r\n\r\n Result := true;\r\nend;\r\n\r\nfunction TFillSequence.First: T;\r\nbegin\r\n if FCount = 0 then\r\n ExceptionHelper.Throw_CollectionEmptyError();\r\n\r\n Result := FElement;\r\nend;\r\n\r\nfunction TFillSequence.FirstOrDefault(const ADefault: T): T;\r\nbegin\r\n if FCount = 0 then\r\n Result := ADefault\r\n else\r\n Result := FElement;\r\nend;\r\n\r\nfunction TFillSequence.GetCount: NativeInt;\r\nbegin\r\n Result := FCount;\r\nend;\r\n\r\nfunction TFillSequence.GetEnumerator: IEnumerator;\r\nvar\r\n LEnumerator: TEnumerator;\r\nbegin\r\n LEnumerator := TEnumerator.Create(Self);\r\n LEnumerator.FRemaining := FCount;\r\n Result := LEnumerator;\r\nend;\r\n\r\nfunction TFillSequence.Last: T;\r\nbegin\r\n if FCount = 0 then\r\n ExceptionHelper.Throw_CollectionEmptyError();\r\n\r\n Result := FElement;\r\nend;\r\n\r\nfunction TFillSequence.LastOrDefault(const ADefault: T): T;\r\nbegin\r\n if FCount = 0 then\r\n Result := ADefault\r\n else\r\n Result := FElement;\r\nend;\r\n\r\nfunction TFillSequence.Max: T;\r\nbegin\r\n if FCount = 0 then\r\n ExceptionHelper.Throw_CollectionEmptyError();\r\n\r\n Result := FElement;\r\nend;\r\n\r\nfunction TFillSequence.Min: T;\r\nbegin\r\n if FCount = 0 then\r\n ExceptionHelper.Throw_CollectionEmptyError();\r\n\r\n Result := FElement;\r\nend;\r\n\r\nfunction TFillSequence.Single: T;\r\nbegin\r\n if FCount = 0 then\r\n ExceptionHelper.Throw_CollectionEmptyError()\r\n else if FCount = 1 then\r\n Result := FElement\r\n else\r\n ExceptionHelper.Throw_CollectionHasMoreThanOneElement();\r\nend;\r\n\r\nfunction TFillSequence.SingleOrDefault(const ADefault: T): T;\r\nbegin\r\n if FCount = 0 then\r\n Result := ADefault\r\n else if FCount = 1 then\r\n Result := FElement\r\n else\r\n ExceptionHelper.Throw_CollectionHasMoreThanOneElement();\r\nend;\r\n\r\n{ TFillSequence.TEnumerator }\r\n\r\nfunction TFillSequence.TEnumerator.TryMoveNext(out ACurrent: T): Boolean;\r\nbegin\r\n { Check for end }\r\n Result := FRemaining > 0;\r\n\r\n if Result then\r\n begin\r\n Dec(FRemaining);\r\n ACurrent := TFillSequence(Owner).FElement;\r\n end;\r\nend;\r\n\r\n{ TSkipSequence }\r\n\r\nconstructor TSkipSequence.Create(const ACollection: TSequence; const ACount: NativeInt);\r\nbegin\r\n { Check parameters }\r\n if ACount <= 0 then\r\n ExceptionHelper.Throw_ArgumentOutOfRangeError('ACount');\r\n\r\n { Check arguments }\r\n if not Assigned(ACollection) then\r\n ExceptionHelper.Throw_ArgumentNilError('ACollection');\r\n\r\n { Installing the element type }\r\n inherited Create(ACollection.ElementRules);\r\n\r\n { Assign internals }\r\n FCollection := ACollection;\r\n KeepObjectAlive(FCollection);\r\n\r\n FCount := ACount;\r\nend;\r\n\r\ndestructor TSkipSequence.Destroy;\r\nbegin\r\n { Delete the enumerable if required }\r\n ReleaseObject(FCollection, false);\r\n\r\n inherited;\r\nend;\r\n\r\nfunction TSkipSequence.GetEnumerator: IEnumerator;\r\nbegin\r\n { Create the enumerator }\r\n Result := TEnumerator.Create(Self, FCollection.GetEnumerator());\r\nend;\r\n\r\n{ TSkipSequence.TEnumerator }\r\n\r\nfunction TSkipSequence.TEnumerator.AcceptValue(const AValue: T): Boolean;\r\nbegin\r\n Result := FCurrentIndex >= TSkipSequence(Owner).FCount;\r\n Inc(FCurrentIndex);\r\nend;\r\n\r\n{ TTakeSequence }\r\n\r\nconstructor TTakeSequence.Create(const ACollection: TSequence; const ACount: NativeInt);\r\nbegin\r\n { Check parameters }\r\n if ACount <= 0 then\r\n ExceptionHelper.Throw_ArgumentOutOfRangeError('ACount');\r\n\r\n { Check arguments }\r\n if not Assigned(ACollection) then\r\n ExceptionHelper.Throw_ArgumentNilError('ACollection');\r\n\r\n { Installing the element type }\r\n inherited Create(ACollection.ElementRules);\r\n\r\n { Assign internals }\r\n FCollection := ACollection;\r\n KeepObjectAlive(FCollection);\r\n\r\n FCount := ACount;\r\nend;\r\n\r\ndestructor TTakeSequence.Destroy;\r\nbegin\r\n { Delete the enumerable if required }\r\n ReleaseObject(FCollection, false);\r\n\r\n inherited;\r\nend;\r\n\r\nfunction TTakeSequence.GetEnumerator: IEnumerator;\r\nbegin\r\n { Create the enumerator }\r\n Result := TEnumerator.Create(Self, FCollection.GetEnumerator());\r\nend;\r\n\r\n{ TTakeSequence.TEnumerator }\r\n\r\nfunction TTakeSequence.TEnumerator.AcceptValue(const AValue: T): Boolean;\r\nbegin\r\n Result := FCurrentIndex < TSkipSequence(Owner).FCount;\r\n Inc(FCurrentIndex);\r\nend;\r\n\r\n{ TTakeWhileSequence }\r\n\r\nconstructor TTakeWhileSequence.Create(const ACollection: TSequence; const APredicate: TPredicate);\r\nbegin\r\n { Check arguments }\r\n if not Assigned(APredicate) then\r\n ExceptionHelper.Throw_ArgumentNilError('APredicate');\r\n\r\n if not Assigned(ACollection) then\r\n ExceptionHelper.Throw_ArgumentNilError('ACollection');\r\n\r\n { Install the type }\r\n inherited Create(ACollection.ElementRules);\r\n\r\n { Assign internals }\r\n FCollection := ACollection;\r\n KeepObjectAlive(FCollection);\r\n\r\n FPredicate := APredicate;\r\nend;\r\n\r\ndestructor TTakeWhileSequence.Destroy;\r\nbegin\r\n { Delete the enumerable if required }\r\n ReleaseObject(FCollection, false);\r\n\r\n inherited;\r\nend;\r\n\r\nfunction TTakeWhileSequence.GetEnumerator: IEnumerator;\r\nvar\r\n LEnumerator: TEnumerator;\r\nbegin\r\n LEnumerator := TEnumerator.Create(Self);\r\n LEnumerator.FInEnumerator := FCollection.GetEnumerator();\r\n Result := LEnumerator;\r\nend;\r\n\r\n{ TTakeWhileSequence.TEnumerator }\r\n\r\nfunction TTakeWhileSequence.TEnumerator.TryMoveNext(out ACurrent: T): Boolean;\r\nbegin\r\n Result := FInEnumerator.MoveNext() and\r\n TTakeWhileSequence(Owner).FPredicate(FInEnumerator.Current);\r\n\r\n if Result then\r\n ACurrent := FInEnumerator.Current;\r\nend;\r\n\r\n{ TSkipWhileSequence }\r\n\r\nconstructor TSkipWhileSequence.Create(const ACollection: TSequence; const APredicate: TPredicate);\r\nbegin\r\n { Check arguments }\r\n if not Assigned(APredicate) then\r\n ExceptionHelper.Throw_ArgumentNilError('APredicate');\r\n\r\n if not Assigned(ACollection) then\r\n ExceptionHelper.Throw_ArgumentNilError('ACollection');\r\n\r\n { Install the type }\r\n inherited Create(ACollection.ElementRules);\r\n\r\n { Assign internals }\r\n FCollection := ACollection;\r\n KeepObjectAlive(FCollection);\r\n\r\n FPredicate := APredicate;\r\nend;\r\n\r\ndestructor TSkipWhileSequence.Destroy;\r\nbegin\r\n { Delete the enumerable if required }\r\n ReleaseObject(FCollection, false);\r\n\r\n inherited;\r\nend;\r\n\r\nfunction TSkipWhileSequence.GetEnumerator: IEnumerator;\r\nvar\r\n LEnumerator: TEnumerator;\r\nbegin\r\n LEnumerator := TEnumerator.Create(Self, FCollection.GetEnumerator());\r\n Result := LEnumerator;\r\nend;\r\n\r\n{ TSkipWhileSequence.TEnumerator }\r\n\r\nfunction TSkipWhileSequence.TEnumerator.AcceptValue(const AValue: T): Boolean;\r\nbegin\r\n if not FStarted then\r\n begin\r\n if TSkipWhileSequence(Owner).FPredicate(AValue) then\r\n Exit(False);\r\n\r\n FStarted := True;\r\n end;\r\n\r\n Result := True;\r\nend;\r\n\r\n{ TGroupBySequence }\r\n\r\nconstructor TGroupBySequence.Create(\r\n const ACollection: TSequence; const ASelector: TFunc);\r\nbegin\r\n { Check arguments }\r\n if not Assigned(ASelector) then\r\n ExceptionHelper.Throw_ArgumentNilError('ASelector');\r\n\r\n if not Assigned(ACollection) then\r\n ExceptionHelper.Throw_ArgumentNilError('ACollection');\r\n\r\n { Install the type (some default type) }\r\n inherited Create();\r\n\r\n { Assign internals }\r\n FCollection := ACollection;\r\n KeepObjectAlive(FCollection);\r\n\r\n FSelector := ASelector;\r\nend;\r\n\r\ndestructor TGroupBySequence.Destroy;\r\nbegin\r\n { Delete the enumerable if required }\r\n ReleaseObject(FCollection, false);\r\n\r\n inherited;\r\nend;\r\n\r\nfunction TGroupBySequence.GetEnumerator: IEnumerator>;\r\nvar\r\n LDictionary: IDictionary>;\r\n LList: IList;\r\n LSrcEnumerator: IEnumerator;\r\n LDictEnumerator: IEnumerator>>;\r\n LGroup: TBy;\r\n LOutList: IList>;\r\n LGrouping: TEnexGroupingCollection;\r\n LGroupingIntf: IGrouping;\r\nbegin\r\n { Initialize the dictionary (need one that preserves the input order) }\r\n LDictionary := TLinkedDictionary>.Create();\r\n\r\n { Obtain the source enumerator }\r\n LSrcEnumerator := FCollection.GetEnumerator();\r\n while LSrcEnumerator.MoveNext() do\r\n begin\r\n LGroup := FSelector(LSrcEnumerator.Current);\r\n\r\n { Try to get the list of groupet input elements }\r\n if not LDictionary.TryGetValue(LGroup, LList) then\r\n begin\r\n LList := TList.Create();\r\n LDictionary.Add(LGroup, LList);\r\n end;\r\n\r\n { Add the element that was grouped into the list, and move on ... }\r\n LList.Add(LSrcEnumerator.Current);\r\n end;\r\n\r\n { Build result and such things }\r\n LOutList := TList>.Create();\r\n\r\n { Get the dictionary enumerator and build output }\r\n LDictEnumerator := LDictionary.GetEnumerator();\r\n while LDictEnumerator.MoveNext() do\r\n begin\r\n { Initialize the grouping structure }\r\n LGrouping := TEnexGroupingCollection.Create;\r\n LGrouping.FBy := LDictEnumerator.Current.Key;\r\n LGrouping.FList := LDictEnumerator.Current.Value;\r\n LGroupingIntf := LGrouping;\r\n\r\n { Place it into output }\r\n LOutList.Add(LGroupingIntf);\r\n end;\r\n\r\n LDictEnumerator := nil;\r\n LDictionary := nil;\r\n\r\n { Finally, provide the enumerator }\r\n Result := LOutList.GetEnumerator();\r\nend;\r\n\r\n{ TGroupBySequence.TEnexGroupingCollection }\r\n\r\nfunction TGroupBySequence.TEnexGroupingCollection.Aggregate(const AAggregator: TFunc): T;\r\nbegin\r\n Result := FList.Aggregate(AAggregator);\r\nend;\r\n\r\nfunction TGroupBySequence.TEnexGroupingCollection.AggregateOrDefault(const AAggregator: TFunc; const ADefault: T): T;\r\nbegin\r\n Result := FList.AggregateOrDefault(AAggregator, ADefault);\r\nend;\r\n\r\nfunction TGroupBySequence.TEnexGroupingCollection.All(const APredicate: TPredicate): Boolean;\r\nbegin\r\n Result := FList.All(APredicate);\r\nend;\r\n\r\nfunction TGroupBySequence.TEnexGroupingCollection.Any(const APredicate: TPredicate): Boolean;\r\nbegin\r\n Result := FList.Any(APredicate);\r\nend;\r\n\r\nprocedure TGroupBySequence.TEnexGroupingCollection.CopyTo(var AArray: array of T; const AStartIndex: NativeInt);\r\nbegin\r\n FList.CopyTo(AArray, AStartIndex);\r\nend;\r\n\r\nfunction TGroupBySequence.TEnexGroupingCollection.ElementAt(const AIndex: NativeInt): T;\r\nbegin\r\n Result := FList.ElementAt(AIndex);\r\nend;\r\n\r\nfunction TGroupBySequence.TEnexGroupingCollection.ElementAtOrDefault(const AIndex: NativeInt; const ADefault: T): T;\r\nbegin\r\n Result := FList.ElementAtOrDefault(AIndex, ADefault);\r\nend;\r\n\r\nfunction TGroupBySequence.TEnexGroupingCollection.Empty: Boolean;\r\nbegin\r\n Result := FList.Empty;\r\nend;\r\n\r\nfunction TGroupBySequence.TEnexGroupingCollection.EqualsTo(const ACollection: IEnumerable): Boolean;\r\nbegin\r\n Result := FList.EqualsTo(ACollection);\r\nend;\r\n\r\nfunction TGroupBySequence.TEnexGroupingCollection.First: T;\r\nbegin\r\n Result := FList.First;\r\nend;\r\n\r\nfunction TGroupBySequence.TEnexGroupingCollection.FirstOrDefault(const ADefault: T): T;\r\nbegin\r\n Result := FList.FirstOrDefault(ADefault);\r\nend;\r\n\r\nfunction TGroupBySequence.TEnexGroupingCollection.GetCount: NativeInt;\r\nbegin\r\n Result := FList.Count;\r\nend;\r\n\r\nfunction TGroupBySequence.TEnexGroupingCollection.GetEnumerator: IEnumerator;\r\nbegin\r\n Result := FList.GetEnumerator();\r\nend;\r\n\r\nfunction TGroupBySequence.TEnexGroupingCollection.GetKey: TBy;\r\nbegin\r\n Result := FBy;\r\nend;\r\n\r\nfunction TGroupBySequence.TEnexGroupingCollection.Last: T;\r\nbegin\r\n Result := FList.Last;\r\nend;\r\n\r\nfunction TGroupBySequence.TEnexGroupingCollection.LastOrDefault(const ADefault: T): T;\r\nbegin\r\n Result := FList.LastOrDefault(ADefault);\r\nend;\r\n\r\nfunction TGroupBySequence.TEnexGroupingCollection.Max: T;\r\nbegin\r\n Result := FList.Max;\r\nend;\r\n\r\nfunction TGroupBySequence.TEnexGroupingCollection.Min: T;\r\nbegin\r\n Result := FList.Min;\r\nend;\r\n\r\nfunction TGroupBySequence.TEnexGroupingCollection.Single: T;\r\nbegin\r\n Result := FList.Single;\r\nend;\r\n\r\nfunction TGroupBySequence.TEnexGroupingCollection.SingleOrDefault(const ADefault: T): T;\r\nbegin\r\n Result := FList.SingleOrDefault(ADefault);\r\nend;\r\n\r\n{ TSelectKeysSequence }\r\n\r\nconstructor TSelectKeysSequence.Create(const ACollection: TAssociation);\r\nbegin\r\n { Check arguments }\r\n if not Assigned(ACollection) then\r\n ExceptionHelper.Throw_ArgumentNilError('ACollection');\r\n\r\n { Install the type }\r\n inherited Create(ACollection.KeyRules);\r\n\r\n { Assign internals }\r\n FCollection := ACollection;\r\n KeepObjectAlive(FCollection);\r\nend;\r\n\r\ndestructor TSelectKeysSequence.Destroy;\r\nbegin\r\n { Delete the enumerable if required }\r\n ReleaseObject(FCollection, false);\r\n\r\n inherited;\r\nend;\r\n\r\nfunction TSelectKeysSequence.GetCount: NativeInt;\r\nbegin\r\n Result := FCollection.GetCount();\r\nend;\r\n\r\nfunction TSelectKeysSequence.GetEnumerator: IEnumerator;\r\nvar\r\n LEnumerator: TEnumerator;\r\nbegin\r\n LEnumerator := TEnumerator.Create(Self);\r\n LEnumerator.FInEnumerator := FCollection.GetEnumerator();\r\n Result := LEnumerator;\r\nend;\r\n\r\n{ TSelectKeysSequence.TEnumerator }\r\n\r\nfunction TSelectKeysSequence.TEnumerator.TryMoveNext(out ACurrent: TKey): Boolean;\r\nbegin\r\n { Next iteration }\r\n Result := FInEnumerator.MoveNext();\r\n if Result then\r\n ACurrent := FInEnumerator.Current.Key;\r\nend;\r\n\r\n{ TSelectValuesSequence }\r\n\r\nconstructor TSelectValuesSequence.Create(\r\n const ACollection: TAssociation);\r\nbegin\r\n { Check arguments }\r\n if not Assigned(ACollection) then\r\n ExceptionHelper.Throw_ArgumentNilError('ACollection');\r\n\r\n { Install the type }\r\n inherited Create(ACollection.ValueRules);\r\n\r\n { Assign internals }\r\n FCollection := ACollection;\r\n\r\n KeepObjectAlive(FCollection);\r\nend;\r\n\r\ndestructor TSelectValuesSequence.Destroy;\r\nbegin\r\n { Delete the enumerable if required }\r\n ReleaseObject(FCollection, false);\r\n\r\n inherited;\r\nend;\r\n\r\nfunction TSelectValuesSequence.GetCount: NativeInt;\r\nbegin\r\n Result := FCollection.GetCount();\r\nend;\r\n\r\nfunction TSelectValuesSequence.GetEnumerator: IEnumerator;\r\nvar\r\n LEnumerator: TEnumerator;\r\nbegin\r\n LEnumerator := TEnumerator.Create(Self);\r\n LEnumerator.FInEnumerator := FCollection.GetEnumerator();\r\n Result := LEnumerator;\r\nend;\r\n\r\n{ TSelectValuesSequence.TEnumerator }\r\n\r\nfunction TSelectValuesSequence.TEnumerator.TryMoveNext(out ACurrent: TValue): Boolean;\r\nbegin\r\n { Next iteration }\r\n Result := FInEnumerator.MoveNext();\r\n if Result then\r\n ACurrent := FInEnumerator.Current.Value;\r\nend;\r\n\r\n{ TAssociativeWhereSequence }\r\n\r\nconstructor TAssociativeWhereSequence.Create(\r\n const ACollection: TAssociation;\r\n const APredicate: TPredicate;\r\n const AInvertResult: Boolean);\r\nbegin\r\n { Check arguments }\r\n if not Assigned(APredicate) then\r\n ExceptionHelper.Throw_ArgumentNilError('APredicate');\r\n\r\n if not Assigned(ACollection) then\r\n ExceptionHelper.Throw_ArgumentNilError('ACollection');\r\n\r\n { Install types }\r\n inherited Create(ACollection.KeyRules, ACollection.ValueRules);\r\n\r\n { Assign internals }\r\n FCollection := ACollection;\r\n KeepObjectAlive(FCollection);\r\n\r\n FPredicate := APredicate;\r\n\r\n FInvertResult := AInvertResult;\r\nend;\r\n\r\ndestructor TAssociativeWhereSequence.Destroy;\r\nbegin\r\n { Delete the enumerable if required }\r\n ReleaseObject(FCollection, false);\r\n\r\n inherited;\r\nend;\r\n\r\nfunction TAssociativeWhereSequence.GetEnumerator: IEnumerator>;\r\nbegin\r\n { Generate an enumerator }\r\n Result := TEnumerator.Create(Self, FCollection.GetEnumerator());\r\nend;\r\n\r\n{ TAssociativeWhereSequence.TEnumerator }\r\n\r\nfunction TAssociativeWhereSequence.TEnumerator.AcceptValue(const AValue: TPair): Boolean;\r\nbegin\r\n with TAssociativeWhereSequence(Owner) do\r\n Result := FPredicate(AValue.Key, AValue.Value) xor FInvertResult;\r\nend;\r\n\r\n{ TAssociativeDistinctByKeysSequence }\r\n\r\nconstructor TAssociativeDistinctByKeysSequence.Create(\r\n const ACollection: TAssociation);\r\nbegin\r\n { Check arguments }\r\n if not Assigned(ACollection) then\r\n ExceptionHelper.Throw_ArgumentNilError('ACollection');\r\n\r\n { Install types }\r\n inherited Create(ACollection.KeyRules, ACollection.ValueRules);\r\n\r\n { Assign internals }\r\n FCollection := ACollection;\r\n KeepObjectAlive(FCollection);\r\nend;\r\n\r\ndestructor TAssociativeDistinctByKeysSequence.Destroy;\r\nbegin\r\n { Delete the enumerable if required }\r\n ReleaseObject(FCollection, false);\r\n\r\n inherited;\r\nend;\r\n\r\nfunction TAssociativeDistinctByKeysSequence.GetEnumerator: IEnumerator>;\r\nvar\r\n LEnumerator: TEnumerator;\r\nbegin\r\n LEnumerator := TEnumerator.Create(Self, FCollection.GetEnumerator());\r\n LEnumerator.FSet := THashSet.Create();\r\n Result := LEnumerator;\r\nend;\r\n\r\n{ TAssociativeDistinctByKeysSequence.TEnumerator }\r\n\r\nfunction TAssociativeDistinctByKeysSequence.TEnumerator.AcceptValue(const AValue: TPair): Boolean;\r\nbegin\r\n Result := not FSet.Contains(AValue.Key);\r\n if Result then\r\n FSet.Add(AValue.Key);\r\nend;\r\n\r\n{ TAssociativeDistinctByValuesSequence }\r\n\r\nconstructor TAssociativeDistinctByValuesSequence.Create(\r\n const ACollection: TAssociation);\r\nbegin\r\n { Check arguments }\r\n if not Assigned(ACollection) then\r\n ExceptionHelper.Throw_ArgumentNilError('ACollection');\r\n\r\n { Install types }\r\n inherited Create(ACollection.KeyRules, ACollection.ValueRules);\r\n\r\n { Assign internals }\r\n FCollection := ACollection;\r\n KeepObjectAlive(FCollection);\r\nend;\r\n\r\ndestructor TAssociativeDistinctByValuesSequence.Destroy;\r\nbegin\r\n { Delete the enumerable if required }\r\n ReleaseObject(FCollection, false);\r\n\r\n inherited;\r\nend;\r\n\r\nfunction TAssociativeDistinctByValuesSequence.GetEnumerator: IEnumerator>;\r\nvar\r\n LEnumerator: TEnumerator;\r\nbegin\r\n LEnumerator := TEnumerator.Create(Self, FCollection.GetEnumerator());\r\n LEnumerator.FSet := THashSet.Create();\r\n Result := LEnumerator;\r\nend;\r\n\r\n{ TAssociativeDistinctByValuesSequence.TEnumerator }\r\n\r\nfunction TAssociativeDistinctByValuesSequence.TEnumerator.AcceptValue(const AValue: TPair): Boolean;\r\nbegin\r\n Result := not FSet.Contains(AValue.Value);\r\n if Result then\r\n FSet.Add(AValue.Value);\r\nend;\r\n\r\n{ TSelectClassSequence }\r\n\r\nconstructor TSelectClassSequence.Create(const ACollection: TSequence; const ARules: TRules);\r\nbegin\r\n { Check arguments }\r\n if not Assigned(ACollection) then\r\n ExceptionHelper.Throw_ArgumentNilError('ACollection');\r\n\r\n { Installing the element type }\r\n inherited Create(ARules);\r\n\r\n { Assign internals }\r\n FCollection := ACollection;\r\n KeepObjectAlive(FCollection);\r\nend;\r\n\r\ndestructor TSelectClassSequence.Destroy;\r\nbegin\r\n { Delete the enumerable if required }\r\n ReleaseObject(FCollection, false);\r\n\r\n inherited;\r\nend;\r\n\r\nfunction TSelectClassSequence.GetEnumerator: IEnumerator;\r\nvar\r\n LEnumerator: TEnumerator;\r\nbegin\r\n LEnumerator := TEnumerator.Create(Self);\r\n LEnumerator.FInEnumerator := FCollection.GetEnumerator();\r\n Result := LEnumerator;\r\nend;\r\n\r\n{ TSelectClassSequence.TEnumerator }\r\n\r\nfunction TSelectClassSequence.TEnumerator.TryMoveNext(out ACurrent: TOut): Boolean;\r\nbegin\r\n { Iterate until given condition is met on an element }\r\n while True do\r\n begin\r\n Result := FInEnumerator.MoveNext();\r\n\r\n { Terminate on sub-enum termination }\r\n if not Result then\r\n Exit;\r\n\r\n { Check if T is TOut. Exit if yes}\r\n if Assigned(FInEnumerator.Current) and FInEnumerator.Current.InheritsFrom(TOut) then\r\n begin\r\n FCurrent := TOut(TObject(FInEnumerator.Current));\r\n Exit;\r\n end;\r\n end;\r\nend;\r\n\r\n{ TRules }\r\n\r\nclass function TRules.Create(const AComparer: IComparer;\r\n const AEqualityComparer: IEqualityComparer): TRules;\r\nbegin\r\n if not Assigned(AComparer) then\r\n ExceptionHelper.Throw_ArgumentNilError('AComparer');\r\n\r\n if not Assigned(AEqualityComparer) then\r\n ExceptionHelper.Throw_ArgumentNilError('AEqualityComparer');\r\n\r\n { Initialize }\r\n Result.FComparer := AComparer;\r\n Result.FEqComparer := AEqualityComparer;\r\nend;\r\n\r\nclass function TRules.Custom(const AComparer: TCustomComparer): TRules;\r\nbegin\r\n if not Assigned(AComparer) then\r\n ExceptionHelper.Throw_ArgumentNilError('AComparer');\r\n\r\n { Init with proper stuff }\r\n Result.FComparer := AComparer;\r\n Result.FEqComparer := AComparer;\r\nend;\r\n\r\nclass function TRules.Default: TRules;\r\nbegin\r\n { Init with proper stuff }\r\n Result.FComparer := TComparer.Default;\r\n Result.FEqComparer := TEqualityComparer.Default;\r\nend;\r\n\r\n{ TRefCountedObject }\r\n\r\nprocedure TRefCountedObject.AfterConstruction;\r\nbegin\r\n FInConstruction := false;\r\n inherited AfterConstruction();\r\nend;\r\n\r\nfunction TRefCountedObject.ExtractReference: IInterface;\r\nvar\r\n LRefCount: NativeInt;\r\nbegin\r\n { While constructing, an object has an implicit LRefCount count of 1 }\r\n if FInConstruction then\r\n LRefCount := 1\r\n else\r\n LRefCount := 0;\r\n\r\n {\r\n If the object is referenced in other places as an\r\n interface, get a new one, otherwise return nil\r\n }\r\n if RefCount > LRefCount then\r\n Result := Self\r\n else\r\n Result := nil;\r\nend;\r\n\r\nprocedure TRefCountedObject.KeepObjectAlive(const AObject: TRefCountedObject);\r\nvar\r\n I, LKALen: NativeInt;\r\n LIntfRef: IInterface;\r\nbegin\r\n { Skip nil references }\r\n if not Assigned(AObject) then\r\n Exit;\r\n\r\n { Cannot self-ref! }\r\n if AObject = Self then\r\n ExceptionHelper.Throw_CannotSelfReferenceError();\r\n\r\n { Extract an optional reference, do not continue if failed }\r\n LIntfRef := AObject.ExtractReference();\r\n if not Assigned(LIntfRef) then\r\n Exit;\r\n\r\n LKALen := Length(FKeepAliveList);\r\n\r\n { Find a free spot }\r\n if LKALen > 0 then\r\n for I := 0 to LKALen - 1 do\r\n if not Assigned(FKeepAliveList[I]) then\r\n begin\r\n FKeepAliveList[I] := LIntfRef;\r\n Exit;\r\n end;\r\n\r\n { No free spots, extend array and insert the ref there }\r\n SetLength(FKeepAliveList, LKALen + 1);\r\n FKeepAliveList[LKALen] := LIntfRef;\r\nend;\r\n\r\nclass function TRefCountedObject.NewInstance: TObject;\r\nbegin\r\n Result := inherited NewInstance();\r\n\r\n { Set in construction! }\r\n TRefCountedObject(Result).FInConstruction := true;\r\nend;\r\n\r\nprocedure TRefCountedObject.ReleaseObject(const AObject: TRefCountedObject; const AFreeObject: Boolean);\r\nvar\r\n I, LKALen: NativeInt;\r\n LIntfRef: IInterface;\r\nbegin\r\n { Do nothing on nil references, since it may be calle din destructors }\r\n if not Assigned(AObject) then\r\n Exit;\r\n\r\n { Cannot self-ref! }\r\n if AObject = Self then\r\n ExceptionHelper.Throw_CannotSelfReferenceError();\r\n\r\n { Extract an optional reference, if none received, exit }\r\n LIntfRef := AObject.ExtractReference();\r\n if not Assigned(LIntfRef) then\r\n begin\r\n if AFreeObject then\r\n AObject.Free;\r\n\r\n Exit;\r\n end;\r\n\r\n LKALen := Length(FKeepAliveList);\r\n\r\n { Find a free spot }\r\n if LKALen > 0 then\r\n for I := 0 to LKALen - 1 do\r\n if FKeepAliveList[I] = LIntfRef then\r\n begin\r\n { Release the spot and kill references to the interface }\r\n FKeepAliveList[I] := nil;\r\n LIntfRef := nil;\r\n Exit;\r\n end;\r\nend;\r\n\r\n{ ExceptionHelper }\r\n\r\nclass procedure ExceptionHelper.Throw_ArgumentNilError(const ArgName: String);\r\nbegin\r\n raise EArgumentNilException.CreateResFmt(@SNilArgument, [ArgName]);\r\nend;\r\n\r\nclass procedure ExceptionHelper.Throw_ArgumentOutOfRangeError(const ArgName: String);\r\nbegin\r\n raise EArgumentOutOfRangeException.CreateResFmt(@SOutOfRangeArgument, [ArgName]);\r\nend;\r\n\r\nclass procedure ExceptionHelper.Throw_ArgumentOutOfSpaceError(const ArgName: String);\r\nbegin\r\n raise EArgumentOutOfSpaceException.CreateResFmt(@SOutOfSpaceArgument, [ArgName]);\r\nend;\r\n\r\nclass procedure ExceptionHelper.Throw_CannotSelfReferenceError;\r\nbegin\r\n raise ECannotSelfReferenceException.CreateRes(@SCannotSelfReference);\r\nend;\r\n\r\nclass procedure ExceptionHelper.Throw_CollectionChangedError;\r\nbegin\r\n raise ECollectionChangedException.CreateRes(@SParentCollectionChanged);\r\nend;\r\n\r\nclass procedure ExceptionHelper.Throw_CollectionEmptyError;\r\nbegin\r\n raise ECollectionEmptyException.CreateRes(@SEmptyCollection);\r\nend;\r\n\r\nclass procedure ExceptionHelper.Throw_CollectionHasMoreThanOneElement;\r\nbegin\r\n raise ECollectionNotOneException.CreateRes(@SCollectionHasMoreThanOneElements);\r\nend;\r\n\r\nclass procedure ExceptionHelper.Throw_CollectionHasNoFilteredElements;\r\nbegin\r\n raise ECollectionFilteredEmptyException.CreateRes(@SCollectionHasNoFilteredElements);\r\nend;\r\n\r\nclass procedure ExceptionHelper.Throw_DuplicateKeyError(const ArgName: String);\r\nbegin\r\n raise EDuplicateKeyException.CreateResFmt(@SDuplicateKey, [ArgName]);\r\nend;\r\n\r\nclass procedure ExceptionHelper.Throw_KeyNotFoundError(const ArgName: String);\r\nbegin\r\n raise EKeyNotFoundException.CreateResFmt(@SKeyNotFound, [ArgName]);\r\nend;\r\n\r\nclass procedure ExceptionHelper.Throw_OperationNotSupported(const AOperation: String);\r\nbegin\r\n raise ENotSupportedException.CreateResFmt(@SOperationNotSupported, [AOperation]);\r\nend;\r\n\r\nclass procedure ExceptionHelper.Throw_TypeDoesNotExposeMember(const MemberName: String);\r\nbegin\r\n raise ENotSupportedException.CreateResFmt(@STypeDoesNotExposeMember, [MemberName]);\r\nend;\r\n\r\nclass procedure ExceptionHelper.Throw_TypeNotAClassError(const TypeName: String);\r\nbegin\r\n raise ENotSupportedException.CreateResFmt(@STypeNotAClass, [TypeName]);\r\nend;\r\n\r\nclass procedure ExceptionHelper.Throw_BadClassReference(const ATypeInfo: PTypeInfo);\r\nbegin\r\n raise ESerializationException.CreateResFmt(@SBadClassReference, [GetTypeName(ATypeInfo), TypeKindToStr(ATypeInfo^.Kind)]);\r\nend;\r\n\r\nclass procedure ExceptionHelper.Throw_BadDynamicArrayReference(const ATypeInfo: PTypeInfo);\r\nbegin\r\n raise ESerializationException.CreateResFmt(@SBadDynamicArrayReference, [GetTypeName(ATypeInfo), TypeKindToStr(ATypeInfo^.Kind)]);\r\nend;\r\n\r\nclass procedure ExceptionHelper.Throw_BadRecordReference(const ATypeInfo: PTypeInfo);\r\nbegin\r\n raise ESerializationException.CreateResFmt(@SBadRecordReference, [GetTypeName(ATypeInfo), TypeKindToStr(ATypeInfo^.Kind)]);\r\nend;\r\n\r\nclass procedure ExceptionHelper.Throw_ExpectedAnotherBinaryValuePoint;\r\nbegin\r\n raise ESerializationException.CreateRes(@SExpectedAnotherBinaryValuePoint);\r\nend;\r\n\r\nclass procedure ExceptionHelper.Throw_ExpectedAnotherElementCount(const AArrayType: TRttiArrayType; const AExpectedCount, AActualCount: NativeInt);\r\nbegin\r\n raise ESerializationException.CreateResFmt(@SExpectedAnotherElementCount, [AArrayType.Name, AExpectedCount, AActualCount]);\r\nend;\r\n\r\nclass procedure ExceptionHelper.Throw_ExpectedAnotherField(const AExpected: TRttiField; const AName: string; AOffset: Int64);\r\nbegin\r\n raise ESerializationException.CreateResFmt(@SExpectedAnotherField, [AExpected.Name, AExpected.Offset, AName, AOffset]);\r\nend;\r\n\r\nclass procedure ExceptionHelper.Throw_ExpectedAnotherLabel(const AExpectedLabel, AActualLabel: string);\r\nbegin\r\n raise ESerializationException.CreateResFmt(@SExpectedAnotherLabel, [AExpectedLabel, AActualLabel]);\r\nend;\r\n\r\nclass procedure ExceptionHelper.Throw_ExpectedAnotherSetSize(const AExpectedSize, AActualSize: NativeInt);\r\nbegin\r\n raise ESerializationException.CreateResFmt(@SExpectedAnotherSetSize, [AExpectedSize, AActualSize]);\r\nend;\r\n\r\nclass procedure ExceptionHelper.Throw_ExpectedAnotherType(const AExpected: TRttiType; const AActual: string);\r\nbegin\r\n raise ESerializationException.CreateResFmt(@SExpectedAnotherType, [AExpected.Name, AActual]);\r\nend;\r\n\r\nclass procedure ExceptionHelper.Throw_FieldTypeDoesNotHaveEnoughRtti(const AField: TRttiField);\r\nbegin\r\n raise ESerializationException.CreateResFmt(@SFieldTypeDoesNotHaveEnoughRtti, [AField.Name, AField.Parent.Name, TypeKindToStr(AField.Parent.TypeKind)]);\r\nend;\r\n\r\nclass procedure ExceptionHelper.Throw_TypeCannotBeSerialized(const ATypeInfo: PTypeInfo);\r\nbegin\r\n raise ESerializationException.CreateResFmt(@STypeCannotBeSerialized, [GetTypeName(ATypeInfo), TypeKindToStr(ATypeInfo^.Kind)]);\r\nend;\r\n\r\nclass procedure ExceptionHelper.Throw_TypeDoesNotHaveEnoughRtti(const ATypeInfo: PTypeInfo);\r\nbegin\r\n raise ESerializationException.CreateResFmt(@STypeDoesNotHaveEnoughRtti, [GetTypeName(ATypeInfo), TypeKindToStr(ATypeInfo^.Kind)]);\r\nend;\r\n\r\nend.\r\n" }, { "path": "Collections/Collections.BidiDictionaries.pas", "content": "(*\r\n* Copyright (c) 2011-2012, Ciobanu Alexandru\r\n* All rights reserved.\r\n*\r\n* Redistribution and use in source and binary forms, with or without\r\n* modification, are permitted provided that the following conditions are met:\r\n* * Redistributions of source code must retain the above copyright\r\n* notice, this list of conditions and the following disclaimer.\r\n* * Redistributions in binary form must reproduce the above copyright\r\n* notice, this list of conditions and the following disclaimer in the\r\n* documentation and/or other materials provided with the distribution.\r\n* * Neither the name of the nor the\r\n* names of its contributors may be used to endorse or promote products\r\n* derived from this software without specific prior written permission.\r\n*\r\n* THIS SOFTWARE IS PROVIDED BY THE AUTHOR ''AS IS'' AND ANY\r\n* EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED\r\n* WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE\r\n* DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY\r\n* DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES\r\n* (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;\r\n* LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND\r\n* ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT\r\n* (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS\r\n* SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.\r\n*)\r\n\r\nunit Collections.BidiDictionaries;\r\ninterface\r\nuses SysUtils,\r\n Generics.Defaults,\r\n Generics.Collections,\r\n Collections.Base,\r\n Collections.Dictionaries;\r\n\r\ntype\r\n /// The base abstract class for all bidi-dictionary collections.\r\n TAbstractBidiDictionary = class abstract(TAbstractMap, IDictionary, IBidiDictionary)\r\n private\r\n FByKeyDictionary: IDictionary;\r\n FByValueDictionary: IDictionary;\r\n\r\n { Got from the underlying collections }\r\n FValueCollection: ISequence;\r\n FKeyCollection: ISequence;\r\n\r\n protected\r\n function IDictionary.Extract = ExtractValueForKey;\r\n function IDictionary.TryGetValue = TryGetValueForKey;\r\n function IDictionary.GetValue = GetValueForKey;\r\n procedure IDictionary.SetValue = SetValueForKey;\r\n\r\n /// Specifies the internal dictionary used as back-end to store key relations.\r\n /// A map used as back-end.\r\n property ByKeyDictionary: IDictionary read FByKeyDictionary;\r\n\r\n /// Specifies the internal dictionary used as back-end to store value relations.\r\n /// A map used as back-end.\r\n property ByValueDictionary: IDictionary read FByValueDictionary;\r\n\r\n /// Called when this bidirectional dictionary needs to initialize its internal key dictionary.\r\n /// The rule set describing the keys.\r\n function CreateKeyDictionary(const AKeyRules: TRules;\r\n const AValueRules: TRules): IDictionary; virtual; abstract;\r\n\r\n /// Called when this bidirectional dictionary needs to initialize its internal value dictionary.\r\n /// The rule set describing the values.\r\n function CreateValueDictionary(const AValueRules: TRules;\r\n const AKeyRules: TRules): IDictionary; virtual; abstract;\r\n\r\n /// Returns the number of pairs in the bidi-dictionary.\r\n /// A positive value specifying the total number of pairs in the bidi-dictionary.\r\n function GetCount(): NativeInt; override;\r\n\r\n /// Returns the value associated with a key.\r\n /// The key for which to obtain the associated value.\r\n /// The associated value.\r\n /// The key is not found in the collection.\r\n function GetValueForKey(const AKey: TKey): TValue;\r\n\r\n /// Sets the value for a given key.\r\n /// The key for which to set the value.\r\n /// The value to set.\r\n /// If the dictionary does not contain the key, this method acts like Add; otherwise the\r\n /// value of the specified key is modified.\r\n /// The new value is already used by another key.\r\n procedure SetValueForKey(const AKey: TKey; const AValue: TValue);\r\n\r\n /// Returns the key associated with a value.\r\n /// The value for which to obtain the associated key.\r\n /// The associated key.\r\n /// The value is not found in the collection.\r\n function GetKeyForValue(const AValue: TValue): TKey;\r\n\r\n /// Sets the key for a given value.\r\n /// The value for which to set the key.\r\n /// The key to set.\r\n /// If the dictionary does not contain the value, this method acts like Add; otherwise the\r\n /// key of the specified value is modified.\r\n /// The new key is already used by another value.\r\n procedure SetKeyForValue(const AValue: TValue; const AKey: TKey);\r\n public\r\n /// Creates a new bi-directional dictionary collection.\r\n /// A rule set describing the keys in the dictionary.\r\n /// A rule set describing the values in the dictionary.\r\n constructor Create(const AKeyRules: TRules; const AValueRules: TRules); overload;\r\n\r\n /// Clears the contents of the dictionary.\r\n procedure Clear(); override;\r\n\r\n /// Adds a key-value pair to the bidi-dictionary.\r\n /// The key of the pair.\r\n /// The value associated with the key.\r\n /// The dictionary already contains a pair with the given key or value.\r\n procedure Add(const AKey: TKey; const AValue: TValue); overload; override;\r\n\r\n /// Extracts a value using a given key.\r\n /// The key of the associated value.\r\n /// The value associated with the key.\r\n /// This function is identical to RemoveKey but will return the stored value. If there is no pair with the given key, an exception is raised.\r\n /// The is not part of the map.\r\n function ExtractValueForKey(const AKey: TKey): TValue;\r\n\r\n /// Extracts a key using a given value.\r\n /// The value of the associated key.\r\n /// The key associated with the value.\r\n /// This function is identical to RemoveValue but will return the stored key. If there is no pair with the given value, an exception is raised.\r\n /// The is not part of the map.\r\n function ExtractKeyForValue(const AValue: TValue): TKey;\r\n\r\n /// Removes a key-value pair using a given key.\r\n /// The key (and its associated value) to remove.\r\n procedure RemoveValueForKey(const AKey: TKey);\r\n\r\n /// Removes a key-value pair using a given key.\r\n /// The key of the pair.\r\n procedure Remove(const AKey: TKey); override;\r\n\r\n /// Removes a key-value pair using a given value.\r\n /// The value (and its associated key) to remove.\r\n procedure RemoveKeyForValue(const AValue: TValue);\r\n\r\n /// Removes a specific key-value combination.\r\n /// The key to remove.\r\n /// The value to remove.\r\n /// This method only removes a key-value combination if that combination actually exists in the bidi-dictionary.\r\n /// If the key is associated with another value, nothing happens.\r\n procedure RemovePair(const AKey: TKey; const AValue: TValue); overload;\r\n\r\n /// Removes a specific key-value combination.\r\n /// The key to remove.\r\n /// The value to remove.\r\n /// This method only removes a key-value combination if that combination actually exists in the bidi-dictionary.\r\n /// If the key is associated with another value, nothing happens.\r\n procedure RemovePair(const APair: TPair); overload;\r\n\r\n /// Checks whether the dictionary contains a key-value pair identified by the given key.\r\n /// The key to check for.\r\n /// True if the dictionary contains a pair identified by the given key; False otherwise.\r\n function ContainsKey(const AKey: TKey): Boolean; override;\r\n\r\n /// Checks whether the dictionary contains a key-value pair that contains a given value.\r\n /// The value to check for.\r\n /// True if the dictionary contains a pair holding the given value; False otherwise.\r\n function ContainsValue(const AValue: TValue): Boolean; override;\r\n\r\n /// Checks whether the dictionary contains the given key-value combination.\r\n /// The key associated with the value.\r\n /// The value associated with the key.\r\n /// True if the dictionary contains the given association; False otherwise.\r\n function ContainsPair(const AKey: TKey; const AValue: TValue): Boolean; overload;\r\n\r\n /// Checks whether the dictionary contains a given key-value combination.\r\n /// The key-value pair combination.\r\n /// True if the dictionary contains the given association; False otherwise.\r\n function ContainsPair(const APair: TPair): Boolean; overload;\r\n\r\n /// Tries to obtain the value associated with a given key.\r\n /// The key for which to try to retrieve the value.\r\n /// The found value (if the result is True).\r\n /// True if the dictionary contains a value for the given key; False otherwise.\r\n function TryGetValueForKey(const AKey: TKey; out AFoundValue: TValue): Boolean;\r\n\r\n /// Tries to obtain the key associated with a given value.\r\n /// The value for which to try to retrieve the key.\r\n /// The found key (if the result is True).\r\n /// True if the dictionary contains a key for the given value; False otherwise.\r\n function TryGetKeyForValue(const AValue: TValue; out AFoundKey: TKey): Boolean;\r\n\r\n /// Returns the value associated with a key.\r\n /// The key for which to obtain the associated value.\r\n /// The associated value.\r\n /// The key is not found in the bidi-dictionary.\r\n property ByKey[const AKey: TKey]: TValue read GetValueForKey write SetValueForKey;\r\n\r\n /// Returns the key associated with a value.\r\n /// The value for which to obtain the associated key.\r\n /// The associated value.\r\n /// The key is not found in the bidi-dictionary.\r\n property ByValue[const AValue: TValue]: TKey read GetKeyForValue write SetKeyForValue;\r\n\r\n /// Specifies the collection that contains only the keys.\r\n /// An Enex collection that contains all the keys stored in the bidi-dictionary.\r\n property Keys: ISequence read FKeyCollection;\r\n\r\n /// Specifies the collection that contains only the values.\r\n /// An Enex collection that contains all the values stored in the bidi-dictionary.\r\n property Values: ISequence read FValueCollection;\r\n\r\n /// Returns the number of pairs in the bidi-map.\r\n /// A positive value specifying the total number of pairs in the bidi-dictionary.\r\n property Count: NativeInt read GetCount;\r\n\r\n /// Returns a new enumerator object used to enumerate this bidi-dictionary.\r\n /// This method is usually called by compiler-generated code. Its purpose is to create an enumerator\r\n /// object that is used to actually traverse the bidi-map.\r\n /// An enumerator object.\r\n function GetEnumerator(): IEnumerator>; override;\r\n\r\n /// Copies the values stored in the bidi-dictionary to a given array.\r\n /// An array where to copy the contents of the bidi-dictionary.\r\n /// The index into the array at which the copying begins.\r\n /// This method assumes that has enough space to hold the contents of the bidi-dictionary.\r\n /// is out of bounds.\r\n /// The array is not long enough.\r\n procedure CopyTo(var AArray: array of TPair; const AStartIndex: NativeInt); overload; override;\r\n\r\n /// Returns the value associated with the given key.\r\n /// The key for which to return the associated value.\r\n /// The value associated with the given key.\r\n /// No such key in the bidi-dictionary.\r\n function ValueForKey(const AKey: TKey): TValue; override;\r\n\r\n /// Checks whether the bidi-map contains a given key-value pair.\r\n /// The key part of the pair.\r\n /// The value part of the pair.\r\n /// True if the given key-value pair exists; False otherwise.\r\n function KeyHasValue(const AKey: TKey; const AValue: TValue): Boolean; override;\r\n\r\n /// Returns an Enex collection that contains only the keys.\r\n /// An Enex collection that contains all the keys stored in the bidi-map.\r\n function SelectKeys(): ISequence; override;\r\n\r\n /// Returns an Enex collection that contains only the values.\r\n /// An Enex collection that contains all the values stored in the bidi-map.\r\n function SelectValues(): ISequence; override;\r\n\r\n /// Checks whether the dictionary is empty.\r\n /// True if the dictionary is empty; False otherwise.\r\n /// This method is the recommended way of detecting if the collection is empty. It is optimized\r\n /// in most collections to offer a fast response.\r\n function Empty(): Boolean; override;\r\n\r\n /// Returns the biggest key.\r\n /// The biggest key stored in this bidirectional dictionary.\r\n /// The dictionary is empty.\r\n function MaxKey(): TKey; override;\r\n\r\n /// Returns the smallest key.\r\n /// The smallest key stored in this bidirectional dictionary.\r\n /// The dictionary is empty.\r\n function MinKey(): TKey; override;\r\n\r\n /// Returns the biggest value.\r\n /// The biggest value stored in this bidirectional dictionary.\r\n /// The dictionary is empty.\r\n function MaxValue(): TValue; override;\r\n\r\n /// Returns the smallest value.\r\n /// The smallest value stored in this bidirectional dictionary.\r\n /// The dictionary is empty.\r\n function MinValue(): TValue; override;\r\n end;\r\n\r\ntype\r\n /// The generic bidirectional dictionary collection.\r\n /// This type uses two hash-based dictionaries to store its keys and values.\r\n TBidiDictionary = class(TAbstractBidiDictionary)\r\n private\r\n FInitialCapacity: NativeInt;\r\n\r\n protected\r\n /// Called when the dictionary needs to initialize the key sub-dictionary.\r\n /// The rule set describing the keys.\r\n /// The rule set describing the values.\r\n /// This method creates a hash-based dictionary used as the underlying back-end for the keys.\r\n function CreateKeyDictionary(const AKeyRules: TRules;\r\n const AValueRules: TRules): IDictionary; override;\r\n\r\n /// Called when the dictionary needs to initialize the value sub-dictionary.\r\n /// The rule set describing the keys.\r\n /// The rule set describing the values.\r\n /// This method creates a hash-based dictionary used as the underlying back-end for the values.\r\n function CreateValueDictionary(const AValueRules: TRules;\r\n const AKeyRules: TRules): IDictionary; override;\r\n public\r\n /// Creates a new bi-directional dictionary collection.\r\n /// This constructor requests the default rule set. Call the overloaded constructor if\r\n /// specific a set of rules need to be passed.\r\n constructor Create(); overload;\r\n\r\n /// Creates a new bi-directional dictionary collection.\r\n /// A rule set describing the keys in the dictionary.\r\n /// A rule set describing the values in the dictionary.\r\n constructor Create(const AKeyRules: TRules; const AValueRules: TRules); overload;\r\n\r\n /// Creates a new bi-directional dictionary collection.\r\n /// A rule set describing the keys in the dictionary.\r\n /// A rule set describing the values in the dictionary.\r\n /// The dictionary's initial capacity.\r\n constructor Create(const AKeyRules: TRules; const AValueRules: TRules; const AInitialCapacity: NativeInt); overload;\r\n end;\r\n\r\n /// The generic bidirectional dictionary collection designed to store objects.\r\n /// This type uses two hash-based dictionaries to store its keys and values.\r\n TObjectBidiDictionary = class(TBidiDictionary)\r\n private\r\n FOwnsKeys, FOwnsValues: Boolean;\r\n\r\n protected\r\n /// Frees the key (object) that was removed from the collection.\r\n /// The key that was removed from the collection.\r\n procedure HandleKeyRemoved(const AKey: TKey); override;\r\n\r\n /// Frees the value (object) that was removed from the collection.\r\n /// The value that was removed from the collection.\r\n procedure HandleValueRemoved(const AValue: TValue); override;\r\n public\r\n /// Specifies whether this dictionary owns the keys.\r\n /// True if the dictionary owns the keys; False otherwise.\r\n /// This property specifies the way the dictionary controls the life-time of the stored keys. The value of this property has effect only\r\n /// if the keys are objects, otherwise it is ignored.\r\n property OwnsKeys: Boolean read FOwnsKeys write FOwnsKeys;\r\n\r\n /// Specifies whether this dictionary owns the values.\r\n /// True if the dictionary owns the values; False otherwise.\r\n /// This property specifies the way the dictionary controls the life-time of the stored values. \r\n /// The value of this property has effect only if the values are objects, otherwise it is ignored.\r\n property OwnsValues: Boolean read FOwnsValues write FOwnsValues;\r\n end;\r\n\r\ntype\r\n /// The generic bidirectional dictionary collection.\r\n /// This type uses a sorted dictionary to store its keys and a hash-based dictionary for its values.\r\n TSortedBidiDictionary = class(TAbstractBidiDictionary)\r\n private\r\n FAscending: Boolean;\r\n\r\n protected\r\n /// Called when the dictionary needs to initialize the key sub-dictionary.\r\n /// The rule set describing the keys.\r\n /// The rule set describing the values.\r\n /// This method creates a sorted dictionary used as the underlying back-end for the keys.\r\n function CreateKeyDictionary(const AKeyRules: TRules;\r\n const AValueRules: TRules): IDictionary; override;\r\n\r\n /// Called when the dictionary needs to initialize the value sub-dictionary.\r\n /// The rule set describing the keys.\r\n /// The rule set describing the values.\r\n /// This method creates a hash-based dictionary used as the underlying back-end for the values.\r\n function CreateValueDictionary(const AValueRules: TRules;\r\n const AKeyRules: TRules): IDictionary; override;\r\n public\r\n /// Creates a new bi-directional dictionary collection.\r\n /// This constructor requests the default rule set. Call the overloaded constructor if\r\n /// specific a set of rules need to be passed. The keys are stored in ascending order.\r\n constructor Create(); overload;\r\n\r\n /// Creates a new bi-directional dictionary collection.\r\n /// A rule set describing the keys in the dictionary.\r\n /// A rule set describing the values in the dictionary.\r\n /// The keys are stored in ascending order.\r\n constructor Create(const AKeyRules: TRules; const AValueRules: TRules); overload;\r\n\r\n /// Creates a new bi-directional dictionary collection.\r\n /// A rule set describing the keys in the dictionary.\r\n /// A rule set describing the values in the dictionary.\r\n /// Pass in a value of True if the keys should be kept in ascending order.\r\n /// Pass in False for descending order.\r\n constructor Create(const AKeyRules: TRules; const AValueRules: TRules; const AAscending: Boolean); overload;\r\n end;\r\n\r\n /// The generic bidirectional dictionary collection designed to store objects.\r\n /// This type uses a sorted dictionary to store its keys and a hash-based dictionary for its values.\r\n TObjectSortedBidiDictionary = class(TSortedBidiDictionary)\r\n private\r\n FOwnsKeys, FOwnsValues: Boolean;\r\n\r\n protected\r\n /// Frees the key (object) that was removed from the collection.\r\n /// The key that was removed from the collection.\r\n procedure HandleKeyRemoved(const AKey: TKey); override;\r\n\r\n /// Frees the value (object) that was removed from the collection.\r\n /// The value that was removed from the collection.\r\n procedure HandleValueRemoved(const AValue: TValue); override;\r\n public\r\n /// Specifies whether this dictionary owns the keys.\r\n /// True if the dictionary owns the keys; False otherwise.\r\n /// This property specifies the way the dictionary controls the life-time of the stored keys. The value of this property has effect only\r\n /// if the keys are objects, otherwise it is ignored.\r\n property OwnsKeys: Boolean read FOwnsKeys write FOwnsKeys;\r\n\r\n /// Specifies whether this dictionary owns the values.\r\n /// True if the dictionary owns the values; False otherwise.\r\n /// This property specifies the way the dictionary controls the life-time of the stored values. \r\n /// The value of this property has effect only if the values are objects, otherwise it is ignored.\r\n property OwnsValues: Boolean read FOwnsValues write FOwnsValues;\r\n end;\r\n\r\ntype\r\n /// The generic bidirectional dictionary collection.\r\n /// This type uses two sorted dictionaries to store its keys and values.\r\n TDoubleSortedBidiDictionary = class(TAbstractBidiDictionary)\r\n private\r\n FAscendingKeys, FAscendingValues: Boolean;\r\n\r\n protected\r\n /// Called when the dictionary needs to initialize the key sub-dictionary.\r\n /// The rule set describing the keys.\r\n /// The rule set describing the values.\r\n /// This method creates a sorted dictionary used as the underlying back-end for the keys.\r\n function CreateKeyDictionary(const AKeyRules: TRules;\r\n const AValueRules: TRules): IDictionary; override;\r\n\r\n /// Called when the dictionary needs to initialize the value sub-dictionary.\r\n /// The rule set describing the keys.\r\n /// The rule set describing the values.\r\n /// This method creates a sorted dictionary used as the underlying back-end for the values.\r\n function CreateValueDictionary(const AValueRules: TRules;\r\n const AKeyRules: TRules): IDictionary; override;\r\n\r\n public\r\n /// Creates a new bi-directional dictionary collection.\r\n /// This constructor requests the default rule set. Call the overloaded constructor if\r\n /// specific a set of rules need to be passed. The keys and values are stored in ascending order.\r\n constructor Create(); overload;\r\n\r\n /// Creates a new bi-directional dictionary collection.\r\n /// A rule set describing the keys in the dictionary.\r\n /// A rule set describing the values in the dictionary.\r\n /// The keys and values are stored in ascending order.\r\n constructor Create(const AKeyRules: TRules; const AValueRules: TRules); overload;\r\n\r\n /// Creates a new bi-directional dictionary collection.\r\n /// A rule set describing the keys in the dictionary.\r\n /// A rule set describing the values in the dictionary.\r\n /// Pass in a value of True if the keys should be kept in ascending order.\r\n /// Pass in False for descending order.\r\n /// Pass in a value of True if the values should be kept in ascending order.\r\n /// Pass in False for descending order.\r\n constructor Create(const AKeyRules: TRules; const AValueRules: TRules;\r\n const AAscendingKeys: Boolean; const AAscendingValues: Boolean); overload;\r\n end;\r\n\r\n /// The generic bidirectional dictionary collection designed to store objects.\r\n /// This type uses two hsorted dictionaries to store its keys and values.\r\n TObjectDoubleSortedBidiDictionary = class(TDoubleSortedBidiDictionary)\r\n private\r\n FOwnsKeys, FOwnsValues: Boolean;\r\n\r\n protected\r\n /// Frees the key (object) that was removed from the collection.\r\n /// The key that was removed from the collection.\r\n procedure HandleKeyRemoved(const AKey: TKey); override;\r\n\r\n /// Frees the value (object) that was removed from the collection.\r\n /// The value that was removed from the collection.\r\n procedure HandleValueRemoved(const AValue: TValue); override;\r\n public\r\n /// Specifies whether this dictionary owns the keys.\r\n /// True if the dictionary owns the keys; False otherwise.\r\n /// This property specifies the way the dictionary controls the life-time of the stored keys. The value of this property has effect only\r\n /// if the keys are objects, otherwise it is ignored.\r\n property OwnsKeys: Boolean read FOwnsKeys write FOwnsKeys;\r\n\r\n /// Specifies whether this dictionary owns the values.\r\n /// True if the dictionary owns the values; False otherwise.\r\n /// This property specifies the way the dictionary controls the life-time of the stored values. The value of this property has effect only\r\n /// if the values are objects, otherwise it is ignored.\r\n property OwnsValues: Boolean read FOwnsValues write FOwnsValues;\r\n end;\r\n\r\nimplementation\r\n\r\n{ TAbstractBidiDictionary }\r\n\r\nprocedure TAbstractBidiDictionary.Add(const AKey: TKey; const AValue: TValue);\r\nbegin\r\n if FByKeyDictionary.ContainsKey(AKey) then\r\n ExceptionHelper.Throw_DuplicateKeyError('AKey');\r\n\r\n if FByValueDictionary.ContainsKey(AValue) then\r\n ExceptionHelper.Throw_DuplicateKeyError('AValue');\r\n\r\n FByKeyDictionary.Add(AKey, AValue);\r\n FByValueDictionary.Add(AValue, AKey);\r\nend;\r\n\r\nprocedure TAbstractBidiDictionary.Clear;\r\nbegin\r\n if Assigned(FByKeyDictionary) then\r\n FByKeyDictionary.Clear();\r\n\r\n if Assigned(FByValueDictionary) then\r\n FByValueDictionary.Clear();\r\nend;\r\n\r\nfunction TAbstractBidiDictionary.ContainsKey(const AKey: TKey): Boolean;\r\nbegin\r\n { Use the value dictionary }\r\n Result := FByKeyDictionary.ContainsKey(AKey);\r\nend;\r\n\r\nfunction TAbstractBidiDictionary.ContainsPair(const APair: TPair): Boolean;\r\nbegin\r\n { Call the best method eva! }\r\n Result := ContainsPair(APair.Key, APair.Value);\r\nend;\r\n\r\nfunction TAbstractBidiDictionary.ContainsPair(const AKey: TKey; const AValue: TValue): Boolean;\r\nvar\r\n LRealValue: TValue;\r\nbegin\r\n { Check that the key exists and that the associated value is the same one. }\r\n Result := FByKeyDictionary.TryGetValue(AKey, LRealValue) and ValuesAreEqual(AValue, LRealValue);\r\nend;\r\n\r\nfunction TAbstractBidiDictionary.ContainsValue(const AValue: TValue): Boolean;\r\nbegin\r\n { Use the value dictionary }\r\n Result := FByValueDictionary.ContainsKey(AValue);\r\nend;\r\n\r\nprocedure TAbstractBidiDictionary.CopyTo(var AArray: array of TPair; const AStartIndex: NativeInt);\r\nbegin\r\n { Copy from the key dictionary }\r\n FByKeyDictionary.CopyTo(AArray, AStartIndex);\r\nend;\r\n\r\nconstructor TAbstractBidiDictionary.Create(const AKeyRules: TRules; const AValueRules: TRules);\r\nbegin\r\n { Install the types }\r\n inherited Create(AKeyRules, AValueRules);\r\n\r\n { Create the maps }\r\n FByKeyDictionary := CreateKeyDictionary(AKeyRules, ValueRules);\r\n FByValueDictionary := CreateValueDictionary(AValueRules, KeyRules);\r\n\r\n { The collections }\r\n FValueCollection := FByValueDictionary.Keys;\r\n FKeyCollection := FByKeyDictionary.Keys;\r\nend;\r\n\r\nfunction TAbstractBidiDictionary.Empty: Boolean;\r\nbegin\r\n { Redirect }\r\n Result := FByKeyDictionary.Empty();\r\nend;\r\n\r\nfunction TAbstractBidiDictionary.ExtractKeyForValue(const AValue: TValue): TKey;\r\nbegin\r\n if FByValueDictionary.TryGetValue(AValue, Result) then\r\n begin\r\n { Remove the key/value from their dictionaries }\r\n FByKeyDictionary.Remove(Result);\r\n FByValueDictionary.Remove(AValue);\r\n end else\r\n ExceptionHelper.Throw_KeyNotFoundError('AValue');\r\nend;\r\n\r\nfunction TAbstractBidiDictionary.ExtractValueForKey(const AKey: TKey): TValue;\r\nbegin\r\n if FByKeyDictionary.TryGetValue(AKey, Result) then\r\n begin\r\n { Remove the key/value from their dictionaries }\r\n FByKeyDictionary.Remove(AKey);\r\n FByValueDictionary.Extract(Result);\r\n end else\r\n ExceptionHelper.Throw_KeyNotFoundError('AKey');\r\nend;\r\n\r\nfunction TAbstractBidiDictionary.GetCount: NativeInt;\r\nbegin\r\n { Redirect }\r\n Result := FByKeyDictionary.Count;\r\nend;\r\n\r\nfunction TAbstractBidiDictionary.GetEnumerator: IEnumerator>;\r\nbegin\r\n Result := FByKeyDictionary.GetEnumerator();\r\nend;\r\n\r\nfunction TAbstractBidiDictionary.GetKeyForValue(const AValue: TValue): TKey;\r\nbegin\r\n { Use indexed property. }\r\n Result := FByValueDictionary[AValue];\r\nend;\r\n\r\nfunction TAbstractBidiDictionary.GetValueForKey(const AKey: TKey): TValue;\r\nbegin\r\n { Use indexed property. }\r\n Result := FByKeyDictionary[AKey];\r\nend;\r\n\r\nfunction TAbstractBidiDictionary.KeyHasValue(const AKey: TKey; const AValue: TValue): Boolean;\r\nbegin\r\n { Call into the key dictionary }\r\n Result := FByKeyDictionary.KeyHasValue(AKey, AValue);\r\nend;\r\n\r\nfunction TAbstractBidiDictionary.MaxKey: TKey;\r\nbegin\r\n Result := FByKeyDictionary.MaxKey;\r\nend;\r\n\r\nfunction TAbstractBidiDictionary.MaxValue: TValue;\r\nbegin\r\n { Use the value dictionary for lookup by keys -- much faster }\r\n Result := FByValueDictionary.MaxKey;\r\nend;\r\n\r\nfunction TAbstractBidiDictionary.MinKey: TKey;\r\nbegin\r\n Result := FByKeyDictionary.MinKey;\r\nend;\r\n\r\nfunction TAbstractBidiDictionary.MinValue: TValue;\r\nbegin\r\n { Use the value dictionary for lookup by keys -- much faster }\r\n Result := FByValueDictionary.MinKey;\r\nend;\r\n\r\nprocedure TAbstractBidiDictionary.RemovePair(const AKey: TKey; const AValue: TValue);\r\nvar\r\n LAssociatedValue: TValue;\r\nbegin\r\n { Check if key -> value relationship actually exists }\r\n if FByKeyDictionary.TryGetValue(AKey, LAssociatedValue) and\r\n ValuesAreEqual(LAssociatedValue, AValue) then\r\n begin\r\n { Remove the key/value from their dictionaries }\r\n FByKeyDictionary.Remove(AKey);\r\n FByValueDictionary.Remove(AValue);\r\n end;\r\nend;\r\n\r\nprocedure TAbstractBidiDictionary.Remove(const AKey: TKey);\r\nbegin\r\n { Redirect ... }\r\n RemoveValueForKey(AKey);\r\nend;\r\n\r\nprocedure TAbstractBidiDictionary.RemovePair(const APair: TPair);\r\nbegin\r\n { Redirect ... }\r\n RemovePair(APair.Key, APair.Value);\r\nend;\r\n\r\nprocedure TAbstractBidiDictionary.RemoveValueForKey(const AKey: TKey);\r\nvar\r\n LAssociatedValue: TValue;\r\nbegin\r\n if FByKeyDictionary.TryGetValue(AKey, LAssociatedValue) then\r\n begin\r\n { Remove the key/value from their dictionaries }\r\n FByKeyDictionary.Remove(AKey);\r\n FByValueDictionary.Remove(LAssociatedValue);\r\n\r\n NotifyValueRemoved(LAssociatedValue);\r\n end;\r\nend;\r\n\r\nprocedure TAbstractBidiDictionary.RemoveKeyForValue(const AValue: TValue);\r\nvar\r\n LAssociatedKey: TKey;\r\nbegin\r\n if FByValueDictionary.TryGetValue(AValue, LAssociatedKey) then\r\n begin\r\n { Remove the key/value from their dictionaries }\r\n FByKeyDictionary.Remove(LAssociatedKey);\r\n FByValueDictionary.Remove(AValue);\r\n\r\n NotifyKeyRemoved(LAssociatedKey);\r\n end;\r\nend;\r\n\r\nfunction TAbstractBidiDictionary.SelectKeys: ISequence;\r\nbegin\r\n Result := FKeyCollection;\r\nend;\r\n\r\nfunction TAbstractBidiDictionary.SelectValues: ISequence;\r\nbegin\r\n Result := FValueCollection;\r\nend;\r\n\r\nprocedure TAbstractBidiDictionary.SetKeyForValue(const AValue: TValue; const AKey: TKey);\r\nvar\r\n LOldKey: TKey;\r\nbegin\r\n { AKey cannot be in the dictionary! }\r\n if FByKeyDictionary.ContainsKey(AKey) then\r\n ExceptionHelper.Throw_DuplicateKeyError('AKey');\r\n\r\n { Replace or add }\r\n if FByValueDictionary.TryGetValue(AValue, LOldKey) then\r\n FByKeyDictionary.Remove(LOldKey);\r\n\r\n { Register the new Key --> Value relation }\r\n FByKeyDictionary.Add(AKey, AValue);\r\n\r\n { Update the old Value --> Key relation }\r\n FByValueDictionary[AValue] := AKey;\r\nend;\r\n\r\nprocedure TAbstractBidiDictionary.SetValueForKey(const AKey: TKey; const AValue: TValue);\r\nvar\r\n LOldValue: TValue;\r\nbegin\r\n { AKey cannot be in the dictionary! }\r\n if FByValueDictionary.ContainsKey(AValue) then\r\n ExceptionHelper.Throw_DuplicateKeyError('AValue');\r\n\r\n { Replace or add }\r\n if FByKeyDictionary.TryGetValue(AKey, LOldValue) then\r\n FByValueDictionary.Remove(LOldValue);\r\n\r\n { Register the new Value --> Key relation }\r\n FByValueDictionary.Add(AValue, AKey);\r\n\r\n { Update the old Key --> Value relation }\r\n FByKeyDictionary[AKey] := AValue;\r\nend;\r\n\r\nfunction TAbstractBidiDictionary.TryGetKeyForValue(const AValue: TValue; out AFoundKey: TKey): Boolean;\r\nbegin\r\n { Act as a bridge }\r\n Result := FByValueDictionary.TryGetValue(AValue, AFoundKey);\r\nend;\r\n\r\nfunction TAbstractBidiDictionary.TryGetValueForKey(const AKey: TKey; out AFoundValue: TValue): Boolean;\r\nbegin\r\n { Act as a bridge }\r\n Result := FByKeyDictionary.TryGetValue(AKey, AFoundValue);\r\nend;\r\n\r\nfunction TAbstractBidiDictionary.ValueForKey(const AKey: TKey): TValue;\r\nbegin\r\n { Act as a bridge }\r\n Result := FByKeyDictionary.ValueForKey(AKey);\r\nend;\r\n\r\n{ TBidiDictionary }\r\n\r\nconstructor TBidiDictionary.Create(const AKeyRules: TRules;\r\n const AValueRules: TRules; const AInitialCapacity: NativeInt);\r\nbegin\r\n FInitialCapacity := AInitialCapacity;\r\n inherited Create(AKeyRules, AValueRules);\r\nend;\r\n\r\nconstructor TBidiDictionary.Create;\r\nbegin\r\n Create(TRules.Default, TRules.Default, CDefaultSize);\r\nend;\r\n\r\nconstructor TBidiDictionary.Create(const AKeyRules: TRules; const AValueRules: TRules);\r\nbegin\r\n Create(AKeyRules, AValueRules, CDefaultSize);\r\nend;\r\n\r\nfunction TBidiDictionary.CreateKeyDictionary(\r\n const AKeyRules: TRules;\r\n const AValueRules: TRules): IDictionary;\r\nvar\r\n LDictionary: TDictionary;\r\nbegin\r\n { Use a double sorted map }\r\n LDictionary := TDictionary.Create(AKeyRules, AValueRules, FInitialCapacity);\r\n LDictionary.KeyRemoveNotification := NotifyKeyRemoved;\r\n\r\n Result := LDictionary;\r\nend;\r\n\r\nfunction TBidiDictionary.CreateValueDictionary(\r\n const AValueRules: TRules;\r\n const AKeyRules: TRules): IDictionary;\r\nvar\r\n LDictionary: TDictionary;\r\nbegin\r\n { Use a double sorted map }\r\n LDictionary := TDictionary.Create(AValueRules, AKeyRules, FInitialCapacity);\r\n LDictionary.KeyRemoveNotification := NotifyValueRemoved;\r\n\r\n Result := LDictionary;\r\nend;\r\n\r\n{ TObjectBidiDictionary }\r\n\r\nprocedure TObjectBidiDictionary.HandleKeyRemoved(const AKey: TKey);\r\nbegin\r\n if FOwnsKeys then\r\n PObject(@AKey)^.Free;\r\nend;\r\n\r\nprocedure TObjectBidiDictionary.HandleValueRemoved(const AValue: TValue);\r\nbegin\r\n if FOwnsValues then\r\n PObject(@AValue)^.Free;\r\nend;\r\n\r\n{ TSortedBidiDictionary }\r\n\r\nfunction TSortedBidiDictionary.CreateKeyDictionary(\r\n const AKeyRules: TRules;\r\n const AValueRules: TRules): IDictionary;\r\nvar\r\n LDictionary: TSortedDictionary;\r\nbegin\r\n { Use a double sorted map }\r\n LDictionary := TSortedDictionary.Create(AKeyRules, AValueRules, FAscending);\r\n LDictionary.KeyRemoveNotification := NotifyKeyRemoved;\r\n\r\n Result := LDictionary;\r\nend;\r\n\r\nfunction TSortedBidiDictionary.CreateValueDictionary(\r\n const AValueRules: TRules;\r\n const AKeyRules: TRules): IDictionary;\r\nvar\r\n LDictionary: TDictionary;\r\nbegin\r\n { Use a double sorted map }\r\n LDictionary := TDictionary.Create(AValueRules, AKeyRules);\r\n LDictionary.KeyRemoveNotification := NotifyValueRemoved;\r\n\r\n Result := LDictionary;\r\nend;\r\n\r\nconstructor TSortedBidiDictionary.Create(\r\n const AKeyRules: TRules; const AValueRules: TRules;\r\n const AAscending: Boolean);\r\nbegin\r\n FAscending := AAscending;\r\n inherited Create(AKeyRules, AValueRules);\r\nend;\r\n\r\nconstructor TSortedBidiDictionary.Create;\r\nbegin\r\n Create(TRules.Default, TRules.Default, True);\r\nend;\r\n\r\nconstructor TSortedBidiDictionary.Create(const AKeyRules: TRules; const AValueRules: TRules);\r\nbegin\r\n Create(AKeyRules, AValueRules, True);\r\nend;\r\n\r\n{ TObjectSortedBidiDictionary }\r\n\r\nprocedure TObjectSortedBidiDictionary.HandleKeyRemoved(const AKey: TKey);\r\nbegin\r\n if FOwnsKeys then\r\n PObject(@AKey)^.Free;\r\nend;\r\n\r\nprocedure TObjectSortedBidiDictionary.HandleValueRemoved(const AValue: TValue);\r\nbegin\r\n if FOwnsValues then\r\n PObject(@AValue)^.Free;\r\nend;\r\n\r\n{ TDoubleSortedBidiDictionary }\r\n\r\nfunction TDoubleSortedBidiDictionary.CreateKeyDictionary(\r\n const AKeyRules: TRules;\r\n const AValueRules: TRules): IDictionary;\r\nvar\r\n LDictionary: TSortedDictionary;\r\nbegin\r\n { Use a double sorted map }\r\n LDictionary := TSortedDictionary.Create(AKeyRules, AValueRules, FAscendingKeys);\r\n LDictionary.KeyRemoveNotification := NotifyKeyRemoved;\r\n\r\n Result := LDictionary;\r\nend;\r\n\r\nfunction TDoubleSortedBidiDictionary.CreateValueDictionary(\r\n const AValueRules: TRules;\r\n const AKeyRules: TRules): IDictionary;\r\nvar\r\n LDictionary: TSortedDictionary;\r\nbegin\r\n { Use a double sorted map }\r\n LDictionary := TSortedDictionary.Create(AValueRules, AKeyRules, FAscendingValues);\r\n LDictionary.KeyRemoveNotification := NotifyValueRemoved;\r\n\r\n Result := LDictionary;\r\nend;\r\n\r\nconstructor TDoubleSortedBidiDictionary.Create(\r\n const AKeyRules: TRules; const AValueRules: TRules;\r\n const AAscendingKeys, AAscendingValues: Boolean);\r\nbegin\r\n FAscendingKeys := AAscendingKeys;\r\n FAscendingValues := AAscendingValues;\r\n\r\n inherited Create(AKeyRules, AValueRules);\r\nend;\r\n\r\nconstructor TDoubleSortedBidiDictionary.Create;\r\nbegin\r\n Create(TRules.Default, TRules.Default, True, True);\r\nend;\r\n\r\nconstructor TDoubleSortedBidiDictionary.Create(const AKeyRules: TRules; const AValueRules: TRules);\r\nbegin\r\n Create(AKeyRules, AValueRules, True, True);\r\nend;\r\n\r\n{ TObjectDoubleSortedBidiDictionary }\r\n\r\nprocedure TObjectDoubleSortedBidiDictionary.HandleKeyRemoved(const AKey: TKey);\r\nbegin\r\n if FOwnsKeys then\r\n PObject(@AKey)^.Free;\r\nend;\r\n\r\nprocedure TObjectDoubleSortedBidiDictionary.HandleValueRemoved(const AValue: TValue);\r\nbegin\r\n if FOwnsValues then\r\n PObject(@AValue)^.Free;\r\nend;\r\n\r\nend.\r\n" }, { "path": "Collections/Collections.BidiMaps.pas", "content": "(*\r\n* Copyright (c) 2009-2012, Ciobanu Alexandru\r\n* All rights reserved.\r\n*\r\n* Redistribution and use in source and binary forms, with or without\r\n* modification, are permitted provided that the following conditions are met:\r\n* * Redistributions of source code must retain the above copyright\r\n* notice, this list of conditions and the following disclaimer.\r\n* * Redistributions in binary form must reproduce the above copyright\r\n* notice, this list of conditions and the following disclaimer in the\r\n* documentation and/or other materials provided with the distribution.\r\n* * Neither the name of the nor the\r\n* names of its contributors may be used to endorse or promote products\r\n* derived from this software without specific prior written permission.\r\n*\r\n* THIS SOFTWARE IS PROVIDED BY THE AUTHOR ''AS IS'' AND ANY\r\n* EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED\r\n* WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE\r\n* DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY\r\n* DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES\r\n* (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;\r\n* LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND\r\n* ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT\r\n* (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS\r\n* SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.\r\n*)\r\n\r\nunit Collections.BidiMaps;\r\ninterface\r\nuses SysUtils,\r\n Generics.Defaults,\r\n Generics.Collections,\r\n Collections.Base,\r\n Collections.MultiMaps;\r\n\r\ntype\r\n /// The base abstract class for all bidi-maps in this package.\r\n TAbstractBidiMap = class abstract(TAbstractMap, IBidiMap)\r\n private\r\n FByKeyMap: IMultiMap;\r\n FByValueMap: IMultiMap;\r\n\r\n { Got from the underlying collections }\r\n FValueCollection: ISequence;\r\n FKeyCollection: ISequence;\r\n\r\n protected\r\n /// Specifies the internal map used as back-end to store key relations.\r\n /// A map used as back-end.\r\n property ByKeyMap: IMultiMap read FByKeyMap;\r\n\r\n /// Specifies the internal map used as back-end to store value relations.\r\n /// A map used as back-end.\r\n property ByValueMap: IMultiMap read FByValueMap;\r\n\r\n /// Called when the map needs to initialize its internal key map.\r\n /// The rule set describing the keys.\r\n function CreateKeyMap(const AKeyRules: TRules;\r\n const AValueRules: TRules): IMultiMap; virtual; abstract;\r\n\r\n /// Called when the map needs to initialize its internal value map.\r\n /// The rule set describing the values.\r\n function CreateValueMap(const AValueRules: TRules;\r\n const AKeyRules: TRules): IMultiMap; virtual; abstract;\r\n\r\n /// Returns the number of pairs in the bidi-map.\r\n /// A positive value specifying the total number of pairs in the bidi-map.\r\n function GetCount(): NativeInt; override;\r\n\r\n /// Returns the collection of keys associated with a value.\r\n /// The value for which to obtain the associated keys.\r\n /// An Enex collection that contains the values associated with this key.\r\n /// The value is not found in the bidi-map.\r\n function GetKeysByValue(const AValue: TValue): ISequence;\r\n\r\n /// Returns the collection of values associated with a key.\r\n /// The key for which to obtain the associated values.\r\n /// An Enex collection that contains the values associated with this key.\r\n /// The key is not found in the bidi-map.\r\n function GetValuesByKey(const AKey: TKey): ISequence;\r\n public\r\n /// Creates a new bi-directional map collection.\r\n /// A rule set describing the keys in the map.\r\n /// A rule set describing the values in the map.\r\n constructor Create(const AKeyRules: TRules; const AValueRules: TRules); overload;\r\n\r\n /// Clears the contents of the bidi-map.\r\n procedure Clear(); override;\r\n\r\n /// Adds a key-value pair to the bidi-map.\r\n /// The key of the pair.\r\n /// The value associated with the key.\r\n /// The map already contains a pair with the given key.\r\n procedure Add(const AKey: TKey; const AValue: TValue); overload; override;\r\n\r\n /// Removes a key-value pair using a given key.\r\n /// The key (and its associated values) to remove.\r\n /// This method removes all the values that are associated with the given key. The rule set's cleanup\r\n /// routines are used to clean up the values that are dropped from the bidi-map.\r\n procedure RemoveValuesForKey(const AKey: TKey);\r\n\r\n /// Removes a key-value pair using a given key.\r\n /// The key of the pair.\r\n /// If the specified key was not found in the bidi-map, nothing happens.\r\n procedure Remove(const AKey: TKey); overload; override;\r\n\r\n /// Removes a key-value pair using a given value.\r\n /// The value (and its associated keys) to remove.\r\n /// This method removes all the keys that are associated with the given value. The rule set's cleanup\r\n /// routines are used to clean up the keys that are dropped from the bidi-map.\r\n procedure RemoveKeysForValue(const AValue: TValue);\r\n\r\n /// Removes a specific key-value combination.\r\n /// The key to remove.\r\n /// The value to remove.\r\n /// This method only removes a key-value combination if that combination actually exists in the bidi-map.\r\n /// If the key is associated with another value, nothing happens.\r\n procedure RemovePair(const AKey: TKey; const AValue: TValue); overload;\r\n\r\n /// Removes a key-value combination.\r\n /// The pair to remove.\r\n /// This method only removes a key-value combination if that combination actually exists in the bidi-map.\r\n /// If the key is associated with another value, nothing happens.\r\n procedure RemovePair(const APair: TPair); overload;\r\n\r\n /// Checks whether the map contains a key-value pair identified by the given key.\r\n /// The key to check for.\r\n /// True if the map contains a pair identified by the given key; False otherwise.\r\n function ContainsKey(const AKey: TKey): Boolean; override;\r\n\r\n /// Checks whether the map contains a key-value pair that contains a given value.\r\n /// The value to check for.\r\n /// True if the map contains a pair containing the given value; False otherwise.\r\n function ContainsValue(const AValue: TValue): Boolean; override;\r\n\r\n /// Checks whether the map contains the given key-value combination.\r\n /// The key associated with the value.\r\n /// The value associated with the key.\r\n /// True if the map contains the given association; False otherwise.\r\n function ContainsPair(const AKey: TKey; const AValue: TValue): Boolean; overload;\r\n\r\n /// Checks whether the map contains a given key-value combination.\r\n /// The key-value pair combination.\r\n /// True if the map contains the given association; False otherwise.\r\n function ContainsPair(const APair: TPair): Boolean; overload;\r\n\r\n /// Returns the collection of values associated with a key.\r\n /// The key for which to obtain the associated values.\r\n /// An Enex collection that contains the values associated with this key.\r\n /// The key is not found in the bidi-map.\r\n property ByKey[const AKey: TKey]: ISequence read GetValuesByKey;\r\n\r\n /// Returns the collection of keys associated with a value.\r\n /// The value for which to obtain the associated keys.\r\n /// An Enex collection that contains the values associated with this key.\r\n /// The value is not found in the bidi-map.\r\n property ByValue[const AValue: TValue]: ISequence read GetKeysByValue;\r\n\r\n /// Specifies the collection that contains only the keys.\r\n /// An Enex collection that contains all the keys stored in the bidi-map.\r\n property Keys: ISequence read FKeyCollection;\r\n\r\n /// Specifies the collection that contains only the values.\r\n /// An Enex collection that contains all the values stored in the bidi-map.\r\n property Values: ISequence read FValueCollection;\r\n\r\n /// Returns the number of pairs in the bidi-map.\r\n /// A positive value specifying the total number of pairs in the bidi-map.\r\n property Count: NativeInt read GetCount;\r\n\r\n /// Returns a new enumerator object used to enumerate this bidi-map.\r\n /// This method is usually called by compiler-generated code. Its purpose is to create an enumerator\r\n /// object that is used to actually traverse the bidi-map.\r\n /// An enumerator object.\r\n function GetEnumerator(): IEnumerator>; override;\r\n\r\n /// Copies the values stored in the bidi-map to a given array.\r\n /// An array where to copy the contents of the bidi-map.\r\n /// The index into the array at which the copying begins.\r\n /// This method assumes that has enough space to hold the contents of the bidi-map.\r\n /// is out of bounds.\r\n /// The array is not long enough.\r\n procedure CopyTo(var AArray: array of TPair; const AStartIndex: NativeInt); overload; override;\r\n\r\n /// Returns the value associated with the given key.\r\n /// The key for which to return the associated value.\r\n /// The value associated with the given key.\r\n /// No such key in the bidi-map.\r\n function ValueForKey(const AKey: TKey): TValue; override;\r\n\r\n /// Checks whether the bidi-map contains a given key-value pair.\r\n /// The key part of the pair.\r\n /// The value part of the pair.\r\n /// True if the given key-value pair exists; False otherwise.\r\n function KeyHasValue(const AKey: TKey; const AValue: TValue): Boolean; override;\r\n\r\n /// Returns an Enex collection that contains only the keys.\r\n /// An Enex collection that contains all the keys stored in the bidi-map.\r\n function SelectKeys(): ISequence; override;\r\n\r\n /// Returns an Enex collection that contains only the values.\r\n /// An Enex collection that contains all the values stored in the bidi-map.\r\n function SelectValues(): ISequence; override;\r\n end;\r\n\r\ntype\r\n /// The generic bidirectional map collection.\r\n /// This type uses distinct multimaps to store its keys and values.\r\n TBidiMap = class(TAbstractBidiMap)\r\n private\r\n FInitialCapacity: NativeInt;\r\n\r\n protected\r\n /// Called when the map needs to initialize the key multimap.\r\n /// The rule set describing the keys.\r\n /// The rule set describing the values.\r\n /// This method creates a distinct multimap used as the underlying back-end for the map.\r\n function CreateKeyMap(const AKeyRules: TRules;\r\n const AValueRules: TRules): IMultiMap; override;\r\n\r\n /// Called when the map needs to initialize the value multimap.\r\n /// The rule set describing the keys.\r\n /// The rule set describing the values.\r\n /// This method creates a distinct multimap used as the underlying back-end for the map.\r\n function CreateValueMap(const AValueRules: TRules;\r\n const AKeyRules: TRules): IMultiMap; override;\r\n\r\n public\r\n /// Creates a new bi-directional map collection.\r\n /// This constructor requests the default rule set. Call the overloaded constructor if\r\n /// specific a set of rules need to be passed.\r\n constructor Create(); overload;\r\n\r\n /// Creates a new bi-directional map collection.\r\n /// A rule set describing the keys in the map.\r\n /// A rule set describing the values in the map.\r\n constructor Create(const AKeyRules: TRules; const AValueRules: TRules); overload;\r\n\r\n /// Creates a new bi-directional map collection.\r\n /// A rule set describing the keys in the map.\r\n /// A rule set describing the values in the map.\r\n /// The map's initial capacity.\r\n constructor Create(const AKeyRules: TRules; const AValueRules: TRules; const AInitialCapacity: NativeInt); overload;\r\n end;\r\n\r\n /// The generic bidirectional map collection designed to store objects.\r\n /// This type uses distinct multimaps to store its keys and values.\r\n TObjectBidiMap = class(TBidiMap)\r\n private\r\n FOwnsKeys, FOwnsValues: Boolean;\r\n\r\n protected\r\n /// Frees the key (object) that was removed from the collection.\r\n /// The key that was removed from the collection.\r\n procedure HandleKeyRemoved(const AKey: TKey); override;\r\n\r\n /// Frees the value (object) that was removed from the collection.\r\n /// The value that was removed from the collection.\r\n procedure HandleValueRemoved(const AValue: TValue); override;\r\n public\r\n /// Specifies whether this map owns the keys.\r\n /// True if the map owns the keys; False otherwise.\r\n /// This property specififies the way the map controls the life-time of the stored keys. The value of this property has effect only\r\n /// if the keys are objects, otherwise it is ignored.\r\n property OwnsKeys: Boolean read FOwnsKeys write FOwnsKeys;\r\n\r\n /// Specifies whether this map owns the values.\r\n /// True if the map owns the values; False otherwise.\r\n /// This property specififes the way the map controls the life-time of the stored values. The value of this property has effect only\r\n /// if the values are objects, otherwise it is ignored.\r\n property OwnsValues: Boolean read FOwnsValues write FOwnsValues;\r\n end;\r\n\r\ntype\r\n /// The generic bidirectional map collection.\r\n /// This type uses sorted distinct multimaps to store its keys and values.\r\n TSortedBidiMap = class(TAbstractBidiMap)\r\n private\r\n FAscendingSort: Boolean;\r\n\r\n protected\r\n /// Called when the map needs to initialize the key multimap.\r\n /// The rule set describing the keys.\r\n /// The rule set describing the values.\r\n /// This method creates a sorted distinct multimap used as the underlying back-end for the map.\r\n function CreateKeyMap(const AKeyRules: TRules;\r\n const AValueRules: TRules): IMultiMap; override;\r\n\r\n /// Called when the map needs to initialize the value multimap.\r\n /// The rule set describing the keys.\r\n /// The rule set describing the values.\r\n /// This method creates a sorted distinct multimap used as the underlying back-end for the map.\r\n function CreateValueMap(const AValueRules: TRules;\r\n const AKeyRules: TRules): IMultiMap; override;\r\n public\r\n /// Creates a new bi-directional map collection.\r\n /// This constructor requests the default rule set. Call the overloaded constructor if\r\n /// specific a set of rules need to be passed. The keys are stored in ascending order.\r\n constructor Create(); overload;\r\n\r\n /// Creates a new bi-directional map collection.\r\n /// A rule set describing the keys in the map.\r\n /// A rule set describing the values in the map.\r\n /// The keys are stored in ascending order.\r\n constructor Create(const AKeyRules: TRules; const AValueRules: TRules); overload;\r\n\r\n /// Creates a new bi-directional map collection.\r\n /// A rule set describing the keys in the map.\r\n /// A rule set describing the values in the map.\r\n /// Pass in a value of True if the keys should be kept in ascending order.\r\n /// Pass in False for descending order.\r\n constructor Create(const AKeyRules: TRules; const AValueRules: TRules; const AAscending: Boolean); overload;\r\n\r\n /// Returns the biggest key.\r\n /// The biggest key stored in the map.\r\n /// The map is empty.\r\n function MaxKey(): TKey; override;\r\n\r\n /// Returns the smallest key.\r\n /// The smallest key stored in the map.\r\n /// The map is empty.\r\n function MinKey(): TKey; override;\r\n end;\r\n\r\n /// The generic bidirectional map collection designed to store objects.\r\n /// This type uses sorted distinct multimaps to store its keys and values.\r\n TObjectSortedBidiMap = class(TSortedBidiMap)\r\n private\r\n FOwnsKeys, FOwnsValues: Boolean;\r\n\r\n protected\r\n /// Frees the key (object) that was removed from the collection.\r\n /// The key that was removed from the collection.\r\n procedure HandleKeyRemoved(const AKey: TKey); override;\r\n\r\n /// Frees the value (object) that was removed from the collection.\r\n /// The value that was removed from the collection.\r\n procedure HandleValueRemoved(const AValue: TValue); override;\r\n public\r\n /// Specifies whether this map owns the keys.\r\n /// True if the map owns the keys; False otherwise.\r\n /// This propertyspecififes the way the map controls the life-time of the stored keys. The value of this property has effect only\r\n /// if the keys are objects, otherwise it is ignored.\r\n property OwnsKeys: Boolean read FOwnsKeys write FOwnsKeys;\r\n\r\n /// Specifies whether this map owns the values.\r\n /// True if the map owns the values; False otherwise.\r\n /// This property specifies the way the map controls the life-time of the stored values. The value of this property has effect only\r\n /// if the values are objects, otherwise it is ignored.\r\n property OwnsValues: Boolean read FOwnsValues write FOwnsValues;\r\n end;\r\n\r\ntype\r\n /// The generic bidirectional map collection.\r\n /// This type uses double sorted distinct multimaps to store its keys and values.\r\n TDoubleSortedBidiMap = class(TSortedBidiMap)\r\n private\r\n FAscendingKeys, FAscendingValues: Boolean;\r\n\r\n protected\r\n /// Called when the map needs to initialize the key multimap.\r\n /// The rule set describing the keys.\r\n /// The rule set describing the values.\r\n /// This method creates a double sorted distinct multimap used as the underlying back-end for the map.\r\n function CreateKeyMap(const AKeyRules: TRules;\r\n const AValueRules: TRules): IMultiMap; override;\r\n\r\n /// Called when the map needs to initialize the value multimap.\r\n /// The rule set describing the keys.\r\n /// The rule set describing the values.\r\n /// This method creates a double sorted distinct multimap used as the underlying back-end for the map.\r\n function CreateValueMap(const AValueRules: TRules;\r\n const AKeyRules: TRules): IMultiMap; override;\r\n public\r\n /// Creates a new bi-directional map collection.\r\n /// This constructor requests the default rule set. Call the overloaded constructor if\r\n /// specific a set of rules need to be passed. The keys and values are stored in ascending order.\r\n constructor Create(); overload;\r\n\r\n /// Creates a new bi-directional map collection.\r\n /// A rule set describing the keys in the map.\r\n /// A rule set describing the values in the map.\r\n /// The keys and values are stored in ascending order.\r\n constructor Create(const AKeyRules: TRules; const AValueRules: TRules); overload;\r\n\r\n /// Creates a new bi-directional map collection.\r\n /// A rule set describing the keys in the map.\r\n /// A rule set describing the values in the map.\r\n /// Pass in a value of True if the keys should be kept in ascending order.\r\n /// Pass in False for descending order.\r\n /// Pass in a value of True if the values should be kept in ascending order.\r\n /// Pass in False for descending order.\r\n constructor Create(const AKeyRules: TRules; const AValueRules: TRules;\r\n const AAscendingKeys: Boolean; const AAscendingValues: Boolean); overload;\r\n\r\n /// Returns the biggest key.\r\n /// The biggest key stored in the map.\r\n /// The map is empty.\r\n function MaxKey(): TKey; override;\r\n\r\n /// Returns the smallest key.\r\n /// The smallest key stored in the map.\r\n /// The map is empty.\r\n function MinKey(): TKey; override;\r\n end;\r\n\r\n /// The generic bidirectional map collection designed to store objects.\r\n /// This type uses double sorted distinct multimaps to store its keys and values.\r\n TObjectDoubleSortedBidiMap = class(TDoubleSortedBidiMap)\r\n private\r\n FOwnsKeys, FOwnsValues: Boolean;\r\n\r\n protected\r\n /// Frees the key (object) that was removed from the collection.\r\n /// The key that was removed from the collection.\r\n procedure HandleKeyRemoved(const AKey: TKey); override;\r\n\r\n /// Frees the value (object) that was removed from the collection.\r\n /// The value that was removed from the collection.\r\n procedure HandleValueRemoved(const AValue: TValue); override;\r\n public\r\n /// Specifies whether this map owns the keys.\r\n /// True if the map owns the keys; False otherwise.\r\n /// This property specififes the way the map controls the life-time of the stored keys. The value of this property has effect only\r\n /// if the keys are objects, otherwise it is ignored.\r\n property OwnsKeys: Boolean read FOwnsKeys write FOwnsKeys;\r\n\r\n /// Specifies whether this map owns the values.\r\n /// True if the map owns the values; False otherwise.\r\n /// This property specifies the way the map controls the life-time of the stored values. The value of this property has effect only\r\n /// if the values are objects, otherwise it is ignored.\r\n property OwnsValues: Boolean read FOwnsValues write FOwnsValues;\r\n end;\r\n\r\nimplementation\r\n\r\n\r\n{ TAbstractBidiMap }\r\n\r\nprocedure TAbstractBidiMap.Add(const AKey: TKey; const AValue: TValue);\r\nbegin\r\n { Add the K/V pair to the maps }\r\n FByKeyMap.Add(AKey, AValue);\r\n FByValueMap.Add(AValue, AKey);\r\nend;\r\n\r\nprocedure TAbstractBidiMap.Clear;\r\nbegin\r\n if Assigned(FByKeyMap) then\r\n FByKeyMap.Clear;\r\n\r\n if Assigned(FByValueMap) then\r\n FByValueMap.Clear;\r\nend;\r\n\r\nfunction TAbstractBidiMap.ContainsKey(const AKey: TKey): Boolean;\r\nbegin\r\n Result := FByKeyMap.ContainsKey(AKey);\r\nend;\r\n\r\nfunction TAbstractBidiMap.ContainsPair(const APair: TPair): Boolean;\r\nbegin\r\n { The by-key relation since it is always correct }\r\n Result := FByKeyMap.ContainsPair(APair.Key, APair.Value);\r\nend;\r\n\r\nfunction TAbstractBidiMap.ContainsPair(const AKey: TKey; const AValue: TValue): Boolean;\r\nbegin\r\n { The by-key relation since it is always correct }\r\n Result := FByKeyMap.ContainsPair(AKey, AValue);\r\nend;\r\n\r\nfunction TAbstractBidiMap.ContainsValue(const AValue: TValue): Boolean;\r\nbegin\r\n Result := FByValueMap.ContainsKey(AValue);\r\nend;\r\n\r\nprocedure TAbstractBidiMap.CopyTo(var AArray: array of TPair; const AStartIndex: NativeInt);\r\nbegin\r\n { Check for indexes }\r\n if (AStartIndex >= Length(AArray)) or (AStartIndex < 0) then\r\n ExceptionHelper.Throw_ArgumentOutOfRangeError('AStartIndex');\r\n\r\n if (Length(AArray) - AStartIndex) < Count then\r\n ExceptionHelper.Throw_ArgumentOutOfSpaceError('AArray');\r\n\r\n { Call the underlying collection }\r\n FByKeyMap.CopyTo(AArray, AStartIndex);\r\nend;\r\n\r\nconstructor TAbstractBidiMap.Create(const AKeyRules: TRules; const AValueRules: TRules);\r\nbegin\r\n { Install the types }\r\n inherited Create(AKeyRules, AValueRules);\r\n\r\n { Create the maps }\r\n FByKeyMap := CreateKeyMap(AKeyRules, ValueRules);\r\n FByValueMap := CreateValueMap(AValueRules, KeyRules);\r\n\r\n { The collections }\r\n FValueCollection := FByValueMap.Keys;\r\n FKeyCollection := FByKeyMap.Keys;\r\nend;\r\n\r\nfunction TAbstractBidiMap.GetCount: NativeInt;\r\nbegin\r\n { The count follows the map properties }\r\n Result := FByKeyMap.Count;\r\nend;\r\n\r\nfunction TAbstractBidiMap.GetEnumerator: IEnumerator>;\r\nbegin\r\n { Pass the enumerator from the key map }\r\n Result := FByKeyMap.GetEnumerator();\r\nend;\r\n\r\nfunction TAbstractBidiMap.GetKeysByValue(const AValue: TValue): ISequence;\r\nbegin\r\n Result := FByValueMap[AValue];\r\nend;\r\n\r\nfunction TAbstractBidiMap.GetValuesByKey(const AKey: TKey): ISequence;\r\nbegin\r\n Result := FByKeyMap[AKey];\r\nend;\r\n\r\nfunction TAbstractBidiMap.KeyHasValue(const AKey: TKey; const AValue: TValue): Boolean;\r\nbegin\r\n Result := ContainsPair(AKey, AValue);\r\nend;\r\n\r\nprocedure TAbstractBidiMap.RemovePair(const AKey: TKey; const AValue: TValue);\r\nvar\r\n LValues: ISequence;\r\n LValue: TValue;\r\nbegin\r\n { Check whether there is such a key }\r\n if not FByKeyMap.ContainsPair(AKey, AValue) then\r\n Exit;\r\n\r\n { Remove the stuff }\r\n FByKeyMap.RemovePair(AKey, AValue);\r\n FByValueMap.RemovePair(AValue, AKey);\r\nend;\r\n\r\nprocedure TAbstractBidiMap.RemovePair(const APair: TPair);\r\nbegin\r\n RemovePair(APair.Key, APair.Value);\r\nend;\r\n\r\nprocedure TAbstractBidiMap.Remove(const AKey: TKey);\r\nbegin\r\n RemoveValuesForKey(AKey);\r\nend;\r\n\r\nprocedure TAbstractBidiMap.RemoveValuesForKey(const AKey: TKey);\r\nvar\r\n LValues: ISequence;\r\n LValue: TValue;\r\nbegin\r\n { Check whether there is such a key }\r\n if not FByKeyMap.TryGetValues(AKey, LValues) then\r\n Exit;\r\n\r\n { Exclude the key for all values too }\r\n for LValue in LValues do\r\n FByValueMap.RemovePair(LValue, AKey);\r\n\r\n { And finally remove the key }\r\n FByKeyMap.Remove(AKey);\r\nend;\r\n\r\nprocedure TAbstractBidiMap.RemoveKeysForValue(const AValue: TValue);\r\nvar\r\n LKeys: ISequence;\r\n LValue: TKey;\r\nbegin\r\n { Check whether there is such a key }\r\n if not FByValueMap.TryGetValues(AValue, LKeys) then\r\n Exit;\r\n\r\n { Exclude the key for all values too}\r\n for LValue in LKeys do\r\n FByKeyMap.RemovePair(LValue, AValue);\r\n\r\n { And finally remove the key }\r\n FByValueMap.Remove(AValue);\r\nend;\r\n\r\nfunction TAbstractBidiMap.SelectKeys: ISequence;\r\nbegin\r\n { Pass the values on }\r\n Result := Keys;\r\nend;\r\n\r\nfunction TAbstractBidiMap.SelectValues: ISequence;\r\nbegin\r\n { Pass the value on }\r\n Result := Values;\r\nend;\r\n\r\nfunction TAbstractBidiMap.ValueForKey(const AKey: TKey): TValue;\r\nbegin\r\n Result := FByKeyMap[AKey].First;\r\nend;\r\n\r\n{ TBidiMap }\r\n\r\nconstructor TBidiMap.Create(const AKeyRules: TRules; const AValueRules: TRules;\r\n const AInitialCapacity: NativeInt);\r\nbegin\r\n FInitialCapacity := AInitialCapacity;\r\n inherited Create(AKeyRules, AValueRules);\r\nend;\r\n\r\nconstructor TBidiMap.Create;\r\nbegin\r\n Create(TRules.Default, TRules.Default, CDefaultSize);\r\nend;\r\n\r\nconstructor TBidiMap.Create(const AKeyRules: TRules;\r\n const AValueRules: TRules);\r\nbegin\r\n Create(AKeyRules, AValueRules, CDefaultSize);\r\nend;\r\n\r\nfunction TBidiMap.CreateKeyMap(const AKeyRules: TRules;\r\n const AValueRules: TRules): IMultiMap;\r\nvar\r\n LNewCapacity: NativeInt;\r\n LMap: TDistinctMultiMap;\r\nbegin\r\n { Create a simple dictionary }\r\n if FInitialCapacity <= 0 then\r\n LNewCapacity := CDefaultSize\r\n else\r\n LNewCapacity := FInitialCapacity;\r\n\r\n { Use a simple non-sorted map }\r\n LMap := TDistinctMultiMap.Create(AKeyRules, AValueRules, LNewCapacity);\r\n LMap.KeyRemoveNotification := NotifyKeyRemoved;\r\n\r\n Result := LMap;\r\nend;\r\n\r\nfunction TBidiMap.CreateValueMap(const AValueRules: TRules;\r\n const AKeyRules: TRules): IMultiMap;\r\nvar\r\n LNewCapacity: NativeInt;\r\n LMap: TDistinctMultiMap;\r\nbegin\r\n { Create a simple dictionary }\r\n if FInitialCapacity <= 0 then\r\n LNewCapacity := CDefaultSize\r\n else\r\n LNewCapacity := FInitialCapacity;\r\n\r\n { Use a simple non-sorted map }\r\n LMap := TDistinctMultiMap.Create(AValueRules, AKeyRules, LNewCapacity);\r\n LMap.KeyRemoveNotification := NotifyValueRemoved;\r\n\r\n Result := LMap;\r\nend;\r\n\r\n{ TObjectBidiMap }\r\n\r\nprocedure TObjectBidiMap.HandleKeyRemoved(const AKey: TKey);\r\nbegin\r\n if FOwnsKeys then\r\n PObject(@AKey)^.Free;\r\nend;\r\n\r\nprocedure TObjectBidiMap.HandleValueRemoved(const AValue: TValue);\r\nbegin\r\n if FOwnsValues then\r\n PObject(@AValue)^.Free;\r\nend;\r\n\r\n{ TSortedBidiMap }\r\n\r\nconstructor TSortedBidiMap.Create(const AKeyRules: TRules;\r\n const AValueRules: TRules; const AAscending: Boolean);\r\nbegin\r\n { Do the dew and continue }\r\n FAscendingSort := AAscending;\r\n inherited Create(AKeyRules, AValueRules);\r\nend;\r\n\r\nconstructor TSortedBidiMap.Create;\r\nbegin\r\n Create(TRules.Default, TRules.Default, True);\r\nend;\r\n\r\nconstructor TSortedBidiMap.Create(const AKeyRules: TRules;\r\n const AValueRules: TRules);\r\nbegin\r\n Create(AKeyRules, AValueRules, True);\r\nend;\r\n\r\nfunction TSortedBidiMap.CreateKeyMap(const AKeyRules: TRules;\r\n const AValueRules: TRules): IMultiMap;\r\nvar\r\n LMap: TSortedDistinctMultiMap;\r\nbegin\r\n { Use a simple sorted map }\r\n LMap := TSortedDistinctMultiMap.Create(AKeyRules, AValueRules, FAscendingSort);\r\n LMap.KeyRemoveNotification := NotifyKeyRemoved;\r\n\r\n Result := LMap;\r\nend;\r\n\r\nfunction TSortedBidiMap.CreateValueMap(const AValueRules: TRules;\r\n const AKeyRules: TRules): IMultiMap;\r\nvar\r\n LMap: TSortedDistinctMultiMap;\r\nbegin\r\n { Use a simple sorted map }\r\n LMap := TSortedDistinctMultiMap.Create(AValueRules, AKeyRules, FAscendingSort);\r\n LMap.KeyRemoveNotification := NotifyValueRemoved;\r\n Result := LMap;\r\nend;\r\n\r\nfunction TSortedBidiMap.MaxKey: TKey;\r\nbegin\r\n Result := ByKeyMap.MaxKey;\r\nend;\r\n\r\nfunction TSortedBidiMap.MinKey: TKey;\r\nbegin\r\n Result := ByKeyMap.MinKey;\r\nend;\r\n\r\n{ TObjectSortedBidiMap }\r\n\r\nprocedure TObjectSortedBidiMap.HandleKeyRemoved(const AKey: TKey);\r\nbegin\r\n if FOwnsKeys then\r\n PObject(@AKey)^.Free;\r\nend;\r\n\r\nprocedure TObjectSortedBidiMap.HandleValueRemoved(const AValue: TValue);\r\nbegin\r\n if FOwnsValues then\r\n PObject(@AValue)^.Free;\r\nend;\r\n\r\n{ TDoubleSortedBidiMap }\r\n\r\nconstructor TDoubleSortedBidiMap.Create(\r\n const AKeyRules: TRules; const AValueRules: TRules;\r\n const AAscendingKeys, AAscendingValues: Boolean);\r\nbegin\r\n { Do the dew and continue! }\r\n FAscendingKeys := AAscendingKeys;\r\n FAscendingValues := AAscendingValues;\r\n\r\n inherited Create(AKeyRules, AValueRules);\r\nend;\r\n\r\nconstructor TDoubleSortedBidiMap.Create;\r\nbegin\r\n Create(TRules.Default, TRules.Default, True, True);\r\nend;\r\n\r\nconstructor TDoubleSortedBidiMap.Create(const AKeyRules: TRules;\r\n const AValueRules: TRules);\r\nbegin\r\n Create(AKeyRules, AValueRules, True, True);\r\nend;\r\n\r\nfunction TDoubleSortedBidiMap.CreateKeyMap(const AKeyRules: TRules;\r\n const AValueRules: TRules): IMultiMap;\r\nvar\r\n LMap: TDoubleSortedDistinctMultiMap;\r\nbegin\r\n { Use a double sorted map }\r\n LMap := TDoubleSortedDistinctMultiMap.Create(AKeyRules, AValueRules, FAscendingKeys, FAscendingValues);\r\n LMap.KeyRemoveNotification := NotifyKeyRemoved;\r\n\r\n Result := LMap;\r\nend;\r\n\r\nfunction TDoubleSortedBidiMap.CreateValueMap(const AValueRules: TRules;\r\n const AKeyRules: TRules): IMultiMap;\r\nvar\r\n LMap: TDoubleSortedDistinctMultiMap;\r\nbegin\r\n { Use a double sorted map }\r\n LMap := TDoubleSortedDistinctMultiMap.Create(AValueRules, AKeyRules, FAscendingKeys, FAscendingValues);\r\n LMap.KeyRemoveNotification := NotifyValueRemoved;\r\n Result := LMap;\r\nend;\r\n\r\nfunction TDoubleSortedBidiMap.MaxKey: TKey;\r\nbegin\r\n Result := ByKeyMap.MaxKey;\r\nend;\r\n\r\nfunction TDoubleSortedBidiMap.MinKey: TKey;\r\nbegin\r\n Result := ByKeyMap.MinKey;\r\nend;\r\n\r\n{ TObjectDoubleSortedBidiMap }\r\n\r\nprocedure TObjectDoubleSortedBidiMap.HandleKeyRemoved(const AKey: TKey);\r\nbegin\r\n if FOwnsKeys then\r\n PObject(@AKey)^.Free;\r\nend;\r\n\r\nprocedure TObjectDoubleSortedBidiMap.HandleValueRemoved(const AValue: TValue);\r\nbegin\r\n if FOwnsValues then\r\n PObject(@AValue)^.Free;\r\nend;\r\n\r\nend.\r\n" }, { "path": "Collections/Collections.Dictionaries.pas", "content": "(*\r\n* Copyright (c) 2008-2012, Ciobanu Alexandru\r\n* All rights reserved.\r\n*\r\n* Redistribution and use in source and binary forms, with or without\r\n* modification, are permitted provided that the following conditions are met:\r\n* * Redistributions of source code must retain the above copyright\r\n* notice, this list of conditions and the following disclaimer.\r\n* * Redistributions in binary form must reproduce the above copyright\r\n* notice, this list of conditions and the following disclaimer in the\r\n* documentation and/or other materials provided with the distribution.\r\n* * Neither the name of the nor the\r\n* names of its contributors may be used to endorse or promote products\r\n* derived from this software without specific prior written permission.\r\n*\r\n* THIS SOFTWARE IS PROVIDED BY THE AUTHOR ''AS IS'' AND ANY\r\n* EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED\r\n* WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE\r\n* DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY\r\n* DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES\r\n* (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;\r\n* LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND\r\n* ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT\r\n* (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS\r\n* SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.\r\n*)\r\n\r\nunit Collections.Dictionaries;\r\ninterface\r\nuses SysUtils,\r\n Generics.Defaults,\r\n Generics.Collections,\r\n Collections.Base;\r\n\r\ntype\r\n /// The abstract base class for all generic dictionary collections.\r\n /// Descending class must implement all required methods and can implement all optional methods.\r\n TAbstractDictionary = class abstract(TAbstractMap, IDictionary)\r\n private type\r\n {$REGION 'Internal Types'}\r\n TKeyEnumerator = class(TAbstractEnumerator)\r\n private\r\n FOwnerEnumerator: IEnumerator>;\r\n public\r\n constructor Create(const AOwner: TAbstractDictionary);\r\n function TryMoveNext(out ACurrent: TKey): Boolean; override;\r\n end;\r\n\r\n TValueEnumerator = class(TAbstractEnumerator)\r\n private\r\n FOwnerEnumerator: IEnumerator>;\r\n public\r\n constructor Create(const AOwner: TAbstractDictionary);\r\n function TryMoveNext(out ACurrent: TValue): Boolean; override;\r\n end;\r\n\r\n TKeySequence = class(TSequence)\r\n private\r\n FOwner: TAbstractDictionary;\r\n protected\r\n function GetCount(): NativeInt; override;\r\n public\r\n constructor Create(const AOwner: TAbstractDictionary);\r\n function GetEnumerator(): IEnumerator; override;\r\n procedure CopyTo(var AArray: array of TKey; const AStartIndex: NativeInt); overload; override;\r\n end;\r\n\r\n TValueSequence = class(TSequence)\r\n private\r\n FOwner: TAbstractDictionary;\r\n protected\r\n function GetCount(): NativeInt; override;\r\n public\r\n constructor Create(const AOwner: TAbstractDictionary);\r\n function GetEnumerator(): IEnumerator; override;\r\n procedure CopyTo(var AArray: array of TValue; const AStartIndex: NativeInt); overload; override;\r\n end;\r\n {$ENDREGION}\r\n\r\n private\r\n FKeyCollection: ISequence;\r\n FValueCollection: ISequence;\r\n\r\n protected\r\n /// Returns the value associated with the given key.\r\n /// The key for which to try to retrieve the value.\r\n /// The value associated with the key.\r\n /// The key is not found in the dictionary.\r\n /// If TryGetValue method is not overridden.\r\n function GetValue(const AKey: TKey): TValue;\r\n\r\n /// Sets the value for a given key.\r\n /// The key for which to set the value.\r\n /// The value to set.\r\n /// If the dictionary does not contain the key, this method acts like Add; otherwise the\r\n /// value of the specified key is modified. The implementation in this class always raises an exception.\r\n /// Always raised in current implementation.\r\n procedure SetValue(const AKey: TKey; const Value: TValue); virtual;\r\n\r\n /// Replaces a given value with a new one.\r\n /// The value to be replaced.\r\n /// The value to be replaced with.\r\n /// This method is called by the dictioanry when a value needs to be replaced with another.\r\n /// The default implementation will compare the values, if those are equal nothing is done. Otherwise the old value is\r\n /// \"disposed of\" and the new one is copied over. Descendant classes my want another behaviour.\r\n procedure ReplaceValue(var ACurrent: TValue; const ANew: TValue); virtual;\r\n\r\n /// Extracts the value associated to a key from the dictionary.\r\n /// The key to search for.\r\n /// The looked up value.\r\n /// True if the value was found and stored in parameter; False otherwise.\r\n /// Descending classes must implement this method in order to support both Remove and Extract methods. In the current implementation\r\n /// this method always raises an exception.\r\n /// Always raised in this implementation.\r\n function TryExtract(const AKey: TKey; out AValue: TValue): Boolean; virtual;\r\n public\r\n /// Creates a new dictionary collection.\r\n /// A rule set describing the keys in the dictionary.\r\n /// A rule set describing the values in the dictionary.\r\n constructor Create(const AKeyRules: TRules; const AValueRules: TRules);\r\n\r\n /// Adds a key-value pair to the dictionary.\r\n /// The key of pair.\r\n /// The value associated with the key.\r\n /// In the current implementation always raises an exception.\r\n /// The dictionary already contains a pair with the given key.\r\n /// Always raised in this implementation.\r\n procedure Add(const AKey: TKey; const AValue: TValue); overload; override;\r\n\r\n /// Removes a key-value pair using a given key.\r\n /// The key of the pair to remove.\r\n /// If the specified key was not found in the dictionary, nothing happens.\r\n /// If TryExtract method is not overridden.\r\n procedure Remove(const AKey: TKey); override;\r\n\r\n /// Extracts a value using a given key.\r\n /// The key of the associated value.\r\n /// The value associated with the key.\r\n /// This function is identical to Remove but will return the stored value. If there is no pair with the given key, an exception is raised.\r\n /// The is not part of the dictionary.\r\n /// If TryExtract method is not overridden.\r\n function Extract(const AKey: TKey): TValue;\r\n\r\n /// Checks whether the dictionary contains a key-value pair identified by the given key.\r\n /// The key to check for.\r\n /// True if the dictionary contains a pair identified by the given key; False otherwise.\r\n /// If TryGetValue method is not overridden.\r\n function ContainsKey(const AKey: TKey): Boolean; override;\r\n\r\n /// Checks whether the dictionary contains a key-value pair that contains a given value.\r\n /// The value to check for.\r\n /// True if the dictionary contains a pair containing the given value; False otherwise.\r\n /// The implementation in this class iterates over all pairs and checks for the requested\r\n /// value. Most descendant classes will most likely provide a better version.\r\n function ContainsValue(const AValue: TValue): Boolean; override;\r\n\r\n /// Tries to obtain the value associated with a given key.\r\n /// The key for which to try to retrieve the value.\r\n /// The found value (if the result is True).\r\n /// True if the dictionary contains a value for the given key; False otherwise.\r\n /// The implementation in this class iterates over all pairs and checks for the requested\r\n /// key. Most descendant classes will most likely provide a better version.\r\n function TryGetValue(const AKey: TKey; out AFoundValue: TValue): Boolean; virtual;\r\n\r\n /// Adds or Set a key-value pair to the dictionary.\r\n /// The key of pair.\r\n /// The value associated with the key.\r\n /// Always raised in this implementation.\r\n procedure AddOrSetValue(const Key: TKey; const Value: TValue); virtual;\r\n\r\n /// Gets or sets the value for a given key.\r\n /// The key to operate on.\r\n /// The value associated with the key.\r\n /// If the dictionary does not contain the key, this method acts like Add if assignment is done to this property;\r\n /// otherwise the value of the specified key is modified.\r\n /// Trying to read the value of a key that is\r\n /// not found in the dictionary.\r\n property Items[const AKey: TKey]: TValue read GetValue write SetValue; default;\r\n\r\n /// Specifies the collection that contains only the keys.\r\n /// An Enex collection that contains all the keys stored in the dictionary.\r\n property Keys: ISequence read FKeyCollection;\r\n\r\n /// Specifies the collection that contains only the values.\r\n /// An Enex collection that contains all the values stored in the dictionary.\r\n property Values: ISequence read FValueCollection;\r\n\r\n /// Returns the value associated with the given key.\r\n /// The key for which to return the associated value.\r\n /// The value associated with the given key.\r\n /// No such key in the dictionary.\r\n /// If TryGetValue method is not overridden.\r\n function ValueForKey(const AKey: TKey): TValue; override;\r\n\r\n /// Checks whether the dictionary contains a given key-value pair.\r\n /// The key part of the pair.\r\n /// The value part of the pair.\r\n /// True if the given key-value pair exists; False otherwise.\r\n /// If TryGetValue method is not overridden.\r\n function KeyHasValue(const AKey: TKey; const AValue: TValue): Boolean; override;\r\n\r\n /// Returns an Enex collection that contains only the keys.\r\n /// An Enex collection that contains all the keys stored in the dictionary.\r\n function SelectKeys(): ISequence; override;\r\n\r\n /// Returns an Enex collection that contains only the values.\r\n /// An Enex collection that contains all the values stored in the dictionary.\r\n function SelectValues(): ISequence; override;\r\n end;\r\n\r\ntype\r\n /// The generic dictionary collection.\r\n /// This type uses hashing mechanisms to store its key-value pairs.\r\n TDictionary = class(TAbstractDictionary)\r\n private type\r\n {$REGION 'Internal Types'}\r\n { Generic Dictionary Pairs Enumerator }\r\n TEnumerator = class(TAbstractEnumerator>)\r\n private\r\n FCurrentIndex: NativeInt;\r\n public\r\n function TryMoveNext(out ACurrent: TPair): Boolean; override;\r\n end;\r\n\r\n PEntry = ^TEntry;\r\n TEntry = record\r\n FHashCode: NativeInt;\r\n FNext: NativeInt;\r\n FKey: TKey;\r\n FValue: TValue;\r\n end;\r\n\r\n TBucketArray = TArray;\r\n TEntryArray = TArray;\r\n {$ENDREGION}\r\n\r\n private var\r\n FBucketArray: TBucketArray;\r\n FEntryArray: TEntryArray;\r\n FCount: NativeInt;\r\n FFreeCount: NativeInt;\r\n FFreeList: NativeInt;\r\n\r\n { Internal }\r\n procedure InitializeInternals(const ACapacity: NativeInt);\r\n procedure Insert(const AKey: TKey; const AValue: TValue; const AShouldAdd: Boolean = true);\r\n function FindEntry(const AKey: TKey): NativeInt;\r\n procedure Resize();\r\n function Hash(const AKey: TKey): NativeInt;\r\n protected\r\n /// Returns the number of key-value pairs in the dictionary.\r\n /// A positive value specifying the number of pairs in the dictionary.\r\n function GetCount(): NativeInt; override;\r\n\r\n /// Sets the value for a given key.\r\n /// The key for which to set the value.\r\n /// The value to set.\r\n /// If the dictionary does not contain the key, this method acts like Add; otherwise the\r\n /// value of the specified key is modified.\r\n procedure SetValue(const AKey: TKey; const Value: TValue); override;\r\n\r\n procedure ReplaceValue(var ACurrent: TValue; const ANew: TValue); override;\r\n\r\n /// Extracts the value associated to a key from the dictionary.\r\n /// The key to search for.\r\n /// The looked up value.\r\n /// True if the value was found and stored in parameter; False otherwise.\r\n function TryExtract(const AKey: TKey; out AValue: TValue): Boolean; override;\r\n public\r\n /// Creates a new dictionary collection.\r\n /// This constructor requests the default rule set. Call the overloaded constructor if\r\n /// specific a set of rules need to be passed.\r\n constructor Create(const AInitialCapacity: NativeInt = TAbstractContainer.CDefaultSize; const AThreadSafe: Boolean = False); overload;\r\n\r\n /// Creates a new dictionary collection.\r\n /// A rule set describing the keys in the dictionary.\r\n /// A rule set describing the values in the dictionary.\r\n //constructor Create(const AKeyRules: TRules; const AValueRules: TRules); overload;\r\n\r\n /// Creates a new dictionary collection.\r\n /// A rule set describing the keys in the dictionary.\r\n /// A rule set describing the values in the dictionary.\r\n /// The dictionary's initial capacity.\r\n constructor Create(const AKeyRules: TRules; const AValueRules: TRules;\r\n const AInitialCapacity: NativeInt = TAbstractContainer.CDefaultSize; const AThreadSafe: Boolean = False); overload;\r\n\r\n destructor Destroy; override;\r\n\r\n /// Clears the contents of the dictionary.\r\n procedure Clear(); override;\r\n\r\n /// Adds a key-value pair to the dictionary.\r\n /// The key of pair.\r\n /// The value associated with the key.\r\n /// The dictionary already contains a pair with the given key.\r\n procedure Add(const AKey: TKey; const AValue: TValue); override;\r\n\r\n /// Removes a key-value pair using a given key.\r\n /// The key of the pair to remove.\r\n /// If the specified key was not found in the dictionary, nothing happens.\r\n /// If TryExtract method is not overridden.\r\n procedure Remove(const AKey: TKey); override;\r\n\r\n /// Checks whether the dictionary contains a key-value pair that contains a given value.\r\n /// The value to check for.\r\n /// True if the dictionary contains a pair containing the given value; False otherwise.\r\n function ContainsValue(const AValue: TValue): Boolean; override;\r\n\r\n /// Tries to obtain the value associated with a given key.\r\n /// The key for which to try to retrieve the value.\r\n /// The found value (if the result is True).\r\n /// True if the dictionary contains a value for the given key; False otherwise.\r\n function TryGetValue(const AKey: TKey; out AFoundValue: TValue): Boolean; override;\r\n\r\n /// Adds or Set a key-value pair to the dictionary.\r\n /// The key of pair.\r\n /// The value associated with the key.\r\n procedure AddOrSetValue(const Key: TKey; const Value: TValue); override;\r\n\r\n /// Returns a new enumerator object used to enumerate this dictionary.\r\n /// This method is usually called by compiler-generated code. Its purpose is to create an enumerator\r\n /// object that is used to actually traverse the dictionary.\r\n /// An enumerator object.\r\n function GetEnumerator(): IEnumerator>; override;\r\n\r\n /// Copies the values stored in the dictionary to a given array.\r\n /// An array where to copy the contents of the dictionary.\r\n /// The index into the array at which the copying begins.\r\n /// This method assumes that has enough space to hold the contents of the dictionary.\r\n /// is out of bounds.\r\n /// The array is not long enough.\r\n procedure CopyTo(var AArray: array of TPair; const AStartIndex: NativeInt); overload; override;\r\n end;\r\n\r\n /// The generic dictionary collection designed to store objects.\r\n /// This type uses hashing mechanisms to store its key-value pairs.\r\n TObjectDictionary = class(TDictionary)\r\n private\r\n FOwnsKeys, FOwnsValues: Boolean;\r\n\r\n protected\r\n /// Frees the key (object) that was removed from the collection.\r\n /// The key that was removed from the collection.\r\n procedure HandleKeyRemoved(const AKey: TKey); override;\r\n\r\n /// Frees the value (object) that was removed from the collection.\r\n /// The value that was removed from the collection.\r\n procedure HandleValueRemoved(const AValue: TValue); override;\r\n\r\n /// Replaces a given value with a new one.\r\n /// The value to be replaced.\r\n /// The value to be replaced with.\r\n /// This implementation will check the objects by reference and free the current one if needed.\r\n procedure ReplaceValue(var ACurrent: TValue; const ANew: TValue); override;\r\n public\r\n /// Specifies whether this dictionary owns the keys.\r\n /// True if the dictionary owns the keys; False otherwise.\r\n /// This property specifies the way the dictionary controls the life-time of the stored keys. The value of\r\n /// this property has effect only if the keys are objects, otherwise it is ignored.\r\n property OwnsKeys: Boolean read FOwnsKeys write FOwnsKeys;\r\n\r\n /// Specifies whether this dictionary owns the values.\r\n /// True if the dictionary owns the values; False otherwise.\r\n /// This property specifies the way the dictionary controls the life-time of the stored values. The value of\r\n /// this property has effect only if the values are objects, otherwise it is ignored.\r\n property OwnsValues: Boolean read FOwnsValues write FOwnsValues;\r\n end;\r\n\r\n /// The generic dictionary collection designed to store pointers.\r\n /// This type uses hashing mechanisms to store its key-value pairs.\r\n TPointerDictionary = class(TObjectDictionary)\r\n protected\r\n /// Frees the key (pointer) that was removed from the collection.\r\n /// The key that was removed from the collection.\r\n procedure HandleKeyRemoved(const AKey: TKey); override;\r\n\r\n /// Frees the value (pointer) that was removed from the collection.\r\n /// The value that was removed from the collection.\r\n procedure HandleValueRemoved(const AValue: TValue); override;\r\n\r\n /// Replaces a given value with a new one.\r\n /// The value to be replaced.\r\n /// The value to be replaced with.\r\n /// This implementation will check the objects by reference and free the current one if needed.\r\n procedure ReplaceValue(var ACurrent: TValue; const ANew: TValue); override;\r\n end;\r\n\r\ntype\r\n /// The generic dictionary collection.\r\n /// This type uses hashing mechanisms and linked lists to store its key-value pairs.\r\n TLinkedDictionary = class(TAbstractDictionary)\r\n private type\r\n {$REGION 'Internal Types'}\r\n PEntry = ^TEntry;\r\n TEntry = record\r\n FHashCode: NativeInt;\r\n FNext, FPrev: PEntry;\r\n FKey: TKey;\r\n FValue: TValue;\r\n end;\r\n\r\n TBucketArray = TArray;\r\n\r\n TEnumerator = class(TAbstractEnumerator>)\r\n private\r\n FCurrentEntry: PEntry;\r\n public\r\n function TryMoveNext(out ACurrent: TPair): Boolean; override;\r\n end;\r\n {$ENDREGION}\r\n\r\n private var\r\n FBucketArray: TBucketArray;\r\n FCount, FFreeCount: NativeInt;\r\n FHead, FTail, FFirstFree: PEntry;\r\n\r\n { Internal }\r\n procedure InitializeInternals(const ACapacity: NativeInt);\r\n procedure Insert(const AKey: TKey; const AValue: TValue; const AShouldAdd: Boolean = true);\r\n procedure ReInsert(const AEntry: PEntry; const ACapacity: NativeInt);\r\n\r\n function FindEntry(const AKey: TKey): PEntry;\r\n function Hash(const AKey: TKey): NativeInt;\r\n\r\n { Caching }\r\n function NeedEntry(const AKey: TKey; const AValue: TValue; const AHash: NativeInt): PEntry;\r\n procedure ReleaseEntry(const AEntry: PEntry);\r\n\r\n protected\r\n /// Returns the number of key-value pairs in the dictionary.\r\n /// A positive value specifying the number of pairs in the dictionary.\r\n function GetCount(): NativeInt; override;\r\n\r\n /// Sets the value for a given key.\r\n /// The key for which to set the value.\r\n /// The value to set.\r\n /// If the dictionary does not contain the key, this method acts like Add; otherwise the\r\n /// value of the specified key is modified.\r\n procedure SetValue(const AKey: TKey; const Value: TValue); override;\r\n\r\n /// Extracts the value associated to a key from the dictionary.\r\n /// The key to search for.\r\n /// The looked up value.\r\n /// True if the value was found and stored in parameter; False otherwise.\r\n /// Descending classes must implement this method in order to support both Remove and Extract methods. In the current implementation\r\n /// this method always raises an exception.\r\n /// Always raised in this implementation.\r\n function TryExtract(const AKey: TKey; out AValue: TValue): Boolean; override;\r\n public\r\n /// Creates a new dictionary collection.\r\n /// This constructor requests the default rule set. Call the overloaded constructor if\r\n /// specific a set of rules need to be passed.\r\n constructor Create(); overload;\r\n\r\n /// Creates a new dictionary collection.\r\n /// A rule set describing the keys in the dictionary.\r\n /// A rule set describing the values in the dictionary.\r\n constructor Create(const AKeyRules: TRules; const AValueRules: TRules); overload;\r\n\r\n /// Creates a new dictionary collection.\r\n /// A rule set describing the keys in the dictionary.\r\n /// A rule set describing the values in the dictionary.\r\n /// The dictionary's initial capacity.\r\n constructor Create(const AKeyRules: TRules; const AValueRules: TRules; const AInitialCapacity: NativeInt); overload;\r\n\r\n /// Destroys this instance.\r\n /// Do not call this method directly; call Free instead.\r\n destructor Destroy(); override;\r\n\r\n /// Clears the contents of the dictionary.\r\n procedure Clear(); override;\r\n\r\n /// Specifies the number of key-value pairs in the dictionary.\r\n /// A positive value specifying the number of pairs in the dictionary.\r\n property Count: NativeInt read FCount;\r\n\r\n /// Adds a key-value pair to the dictionary.\r\n /// The key of pair.\r\n /// The value associated with the key.\r\n /// The dictionary already contains a pair with the given key.\r\n procedure Add(const AKey: TKey; const AValue: TValue); override;\r\n\r\n /// Checks whether the dictionary contains a key-value pair that contains a given value.\r\n /// The value to check for.\r\n /// True if the dictionary contains a pair containing the given value; False otherwise.\r\n function ContainsValue(const AValue: TValue): Boolean; override;\r\n\r\n /// Tries to obtain the value associated with a given key.\r\n /// The key for which to try to retrieve the value.\r\n /// The found value (if the result is True).\r\n /// True if the dictionary contains a value for the given key; False otherwise.\r\n function TryGetValue(const AKey: TKey; out AFoundValue: TValue): Boolean; override;\r\n\r\n /// Returns a new enumerator object used to enumerate this dictionary.\r\n /// This method is usually called by compiler-generated code. Its purpose is to create an enumerator\r\n /// object that is used to actually traverse the dictionary.\r\n /// An enumerator object.\r\n function GetEnumerator(): IEnumerator>; override;\r\n\r\n /// Copies the values stored in the dictionary to a given array.\r\n /// An array where to copy the contents of the dictionary.\r\n /// The index into the array at which the copying begins.\r\n /// This method assumes that has enough space to hold the contents of the dictionary.\r\n /// is out of bounds.\r\n /// The array is not long enough.\r\n procedure CopyTo(var AArray: array of TPair; const AStartIndex: NativeInt); overload; override;\r\n end;\r\n\r\n /// The generic dictionary collection designed to store objects.\r\n /// This type uses hashing mechanisms and linked lists to store its key-value pairs.\r\n TObjectLinkedDictionary = class(TLinkedDictionary)\r\n private\r\n FOwnsKeys, FOwnsValues: Boolean;\r\n\r\n protected\r\n /// Frees the key (object) that was removed from the collection.\r\n /// The key that was removed from the collection.\r\n procedure HandleKeyRemoved(const AKey: TKey); override;\r\n\r\n /// Frees the value (object) that was removed from the collection.\r\n /// The value that was removed from the collection.\r\n procedure HandleValueRemoved(const AValue: TValue); override;\r\n\r\n /// Replaces a given value with a new one.\r\n /// The value to be replaced.\r\n /// The value to be replaced with.\r\n /// This implementation will check the objects by reference and free the current one if needed.\r\n procedure ReplaceValue(var ACurrent: TValue; const ANew: TValue); override;\r\n public\r\n /// Specifies whether this dictionary owns the keys.\r\n /// True if the dictionary owns the keys; False otherwise.\r\n /// This property specifies the way the dictionary controls the life-time of the stored keys. The value of\r\n /// this property has effect only if the keys are objects, otherwise it is ignored.\r\n property OwnsKeys: Boolean read FOwnsKeys write FOwnsKeys;\r\n\r\n /// Specifies whether this dictionary owns the values.\r\n /// True if the dictionary owns the values; False otherwise.\r\n /// This property specifies the way the dictionary controls the life-time of the stored values. The value of\r\n /// this property has effect only if the values are objects, otherwise it is ignored.\r\n property OwnsValues: Boolean read FOwnsValues write FOwnsValues;\r\n end;\r\n\r\ntype\r\n /// The generic sorted dictionary collection.\r\n /// This type uses an AVL tree to store its key-value pairs.\r\n TSortedDictionary = class(TAbstractDictionary)\r\n private type\r\n {$REGION 'Internal Types'}\r\n //TBalanceAct = (baStart, baLeft, baRight, baLoop, baEnd);\r\n\r\n { An internal node class }\r\n TNode = class\r\n private\r\n FKey: TKey;\r\n FValue: TValue;\r\n\r\n FParent,\r\n FLeft, FRight: TNode;\r\n\r\n FBalance: ShortInt;\r\n end;\r\n\r\n TEnumerator = class(TAbstractEnumerator>)\r\n private\r\n FCurrentEntry: TNode;\r\n public\r\n function TryMoveNext(out ACurrent: TPair): Boolean; override;\r\n end;\r\n {$ENDREGION}\r\n\r\n private var\r\n FCount: NativeInt;\r\n FRoot: TNode;\r\n FSignFix: NativeInt;\r\n\r\n function FindNodeWithKey(const AKey: TKey): TNode;\r\n function FindLeftMostNode(): TNode;\r\n function FindRightMostNode(): TNode;\r\n function WalkToTheRight(const ANode: TNode): TNode;\r\n function MakeNode(const AKey: TKey; const AValue: TValue; const ARoot: TNode): TNode;\r\n procedure RecursiveClear(const ANode: TNode);\r\n procedure ReBalanceSubTreeOnInsert(const ANode: TNode);\r\n function Insert(const AKey: TKey; const AValue: TValue; const AChangeOrFail: Boolean): Boolean;\r\n procedure BalanceTreesAfterRemoval(const ANode: TNode);\r\n protected\r\n /// Returns the number of key-value pairs in the dictionary.\r\n /// A positive value specifying the number of pairs in the dictionary.\r\n function GetCount(): NativeInt; override;\r\n\r\n /// Sets the value for a given key.\r\n /// The key for which to set the value.\r\n /// The value to set.\r\n /// If the dictionary does not contain the key, this method acts like Add; otherwise the\r\n /// value of the specified key is modified.\r\n procedure SetValue(const AKey: TKey; const Value: TValue); override;\r\n\r\n /// Extracts the value associated to a key from the dictionary.\r\n /// The key to search for.\r\n /// The looked up value.\r\n /// True if the value was found and stored in parameter; False otherwise.\r\n /// Descending classes must implement this method in order to support both Remove and Extract methods. In the current implementation\r\n /// this method always raises an exception.\r\n /// Always raised in this implementation.\r\n function TryExtract(const AKey: TKey; out AValue: TValue): Boolean; override;\r\n public\r\n /// Creates a new dictionary collection.\r\n /// This constructor requests the default rule set. Call the overloaded constructor if\r\n /// specific a set of rules need to be passed. The keys are stored in ascending order.\r\n constructor Create(); overload;\r\n\r\n /// Creates a new dictionary collection.\r\n /// A rule set describing the keys in the dictionary.\r\n /// A rule set describing the values in the dictionary.\r\n /// The keys are stored in ascending order.\r\n constructor Create(const AKeyRules: TRules; const AValueRules: TRules); overload;\r\n\r\n /// Creates a new dictionary collection.\r\n /// A rule set describing the keys in the dictionary.\r\n /// A rule set describing the values in the dictionary.\r\n /// Pass in a value of True if the keys should be kept in ascending order.\r\n /// Pass in False for descending order.\r\n constructor Create(const AKeyRules: TRules; const AValueRules: TRules; const AAscending: Boolean); overload;\r\n\r\n /// Clears the contents of the dictionary.\r\n procedure Clear(); override;\r\n\r\n /// Specifies the number of key-value pairs in the dictionary.\r\n /// A positive value specifying the number of pairs in the dictionary.\r\n property Count: NativeInt read FCount;\r\n\r\n /// Adds a key-value pair to the dictionary.\r\n /// The key of pair.\r\n /// The value associated with the key.\r\n /// The dictionary already contains a pair with the given key.\r\n procedure Add(const AKey: TKey; const AValue: TValue); override;\r\n\r\n /// Checks whether the dictionary contains a key-value pair that contains a given value.\r\n /// The value to check for.\r\n /// True if the dictionary contains a pair containing the given value; False otherwise.\r\n function ContainsValue(const AValue: TValue): Boolean; override;\r\n\r\n /// Tries to obtain the value associated with a given key.\r\n /// The key for which to try to retrieve the value.\r\n /// The found value (if the result is True).\r\n /// True if the dictionary contains a value for the given key; False otherwise.\r\n function TryGetValue(const AKey: TKey; out AFoundValue: TValue): Boolean; override;\r\n\r\n /// Returns a new enumerator object used to enumerate this dictionary.\r\n /// This method is usually called by compiler-generated code. Its purpose is to create an enumerator\r\n /// object that is used to actually traverse the dictionary.\r\n /// An enumerator object.\r\n function GetEnumerator(): IEnumerator>; override;\r\n\r\n /// Copies the values stored in the dictionary to a given array.\r\n /// An array where to copy the contents of the dictionary.\r\n /// The index into the array at which the copying begins.\r\n /// This method assumes that has enough space to hold the contents of the dictionary.\r\n /// is out of bounds.\r\n /// The array is not long enough.\r\n procedure CopyTo(var AArray: array of TPair; const AStartIndex: NativeInt); overload; override;\r\n\r\n /// Returns the biggest key.\r\n /// The biggest key stored in the dictionary.\r\n /// The dictionary is empty.\r\n function MaxKey(): TKey; override;\r\n\r\n /// Returns the smallest key.\r\n /// The smallest key stored in the dictionary.\r\n /// The dictionary is empty.\r\n function MinKey(): TKey; override;\r\n end;\r\n\r\n /// The generic sorted dictionary collection designed to store objects.\r\n /// This type uses an AVL tree to store its key-value pairs.\r\n TObjectSortedDictionary = class(TSortedDictionary)\r\n private\r\n FOwnsKeys, FOwnsValues: Boolean;\r\n\r\n protected\r\n /// Frees the key (object) that was removed from the collection.\r\n /// The key that was removed from the collection.\r\n procedure HandleKeyRemoved(const AKey: TKey); override;\r\n\r\n /// Frees the value (object) that was removed from the collection.\r\n /// The value that was removed from the collection.\r\n procedure HandleValueRemoved(const AValue: TValue); override;\r\n\r\n /// Replaces a given value with a new one.\r\n /// The value to be replaced.\r\n /// The value to be replaced with.\r\n /// This implementation will check the objects by reference and free the current one if needed.\r\n procedure ReplaceValue(var ACurrent: TValue; const ANew: TValue); override;\r\n public\r\n /// Specifies whether this dictionary owns the keys.\r\n /// True if the dictionary owns the keys; False otherwise.\r\n /// This property specifies the way the dictionary controls the life-time of the stored keys. The value of\r\n /// this property has effect only if the keys are objects, otherwise it is ignored.\r\n property OwnsKeys: Boolean read FOwnsKeys write FOwnsKeys;\r\n\r\n /// Specifies whether this dictionary owns the values.\r\n /// True if the dictionary owns the values; False otherwise.\r\n /// This property specifies the way the dictionary controls the life-time of the stored values. The value of\r\n /// this property has effect only if the values are objects, otherwise it is ignored.\r\n property OwnsValues: Boolean read FOwnsValues write FOwnsValues;\r\n end;\r\n\r\nimplementation\r\n\r\nuses\r\n System.SyncObjs;\r\n\r\n{ TAbstractDictionary }\r\n\r\nprocedure TAbstractDictionary.Add(const AKey: TKey; const AValue: TValue);\r\nbegin\r\n ExceptionHelper.Throw_OperationNotSupported('Add');\r\nend;\r\n\r\nprocedure TAbstractDictionary.AddOrSetValue(const Key: TKey; const Value: TValue);\r\nbegin\r\n ExceptionHelper.Throw_OperationNotSupported('AddOrSetValue');\r\nend;\r\n\r\nfunction TAbstractDictionary.ContainsKey(const AKey: TKey): Boolean;\r\nvar\r\n LDummy: TValue;\r\nbegin\r\n Result := TryGetValue(AKey, LDummy);\r\nend;\r\n\r\nfunction TAbstractDictionary.ContainsValue(const AValue: TValue): Boolean;\r\nvar\r\n LEnumerator: IEnumerator>;\r\nbegin\r\n LEnumerator := GetEnumerator();\r\n while LEnumerator.MoveNext() do\r\n if ValuesAreEqual(AValue, LEnumerator.Current.Value) then\r\n Exit(True);\r\n\r\n Result := False;\r\nend;\r\n\r\nconstructor TAbstractDictionary.Create(const AKeyRules: TRules; const AValueRules: TRules);\r\nbegin\r\n inherited Create(AKeyRules, AValueRules);\r\n\r\n FKeyCollection := TKeySequence.Create(Self);\r\n FValueCollection := TValueSequence.Create(Self);\r\nend;\r\n\r\nfunction TAbstractDictionary.Extract(const AKey: TKey): TValue;\r\nbegin\r\n if not TryExtract(AKey, Result) then\r\n ExceptionHelper.Throw_KeyNotFoundError('AKey');\r\nend;\r\n\r\nfunction TAbstractDictionary.GetValue(const AKey: TKey): TValue;\r\nbegin\r\n if not TryGetValue(AKey, Result) then\r\n ExceptionHelper.Throw_KeyNotFoundError('AKey');\r\nend;\r\n\r\nfunction TAbstractDictionary.KeyHasValue(const AKey: TKey; const AValue: TValue): Boolean;\r\nvar\r\n LFoundValue: TValue;\r\nbegin\r\n Result := TryGetValue(AKey, LFoundValue) and ValuesAreEqual(LFoundValue, AValue);\r\nend;\r\n\r\nprocedure TAbstractDictionary.Remove(const AKey: TKey);\r\nvar\r\n LValue: TValue;\r\nbegin\r\n if TryExtract(AKey, LValue) then\r\n NotifyValueRemoved(LValue);\r\nend;\r\n\r\nprocedure TAbstractDictionary.ReplaceValue(var ACurrent: TValue; const ANew: TValue);\r\nbegin\r\n if not ValuesAreEqual(ACurrent, ANew) then\r\n begin\r\n { Notify that an element is removed. }\r\n NotifyValueRemoved(ACurrent);\r\n\r\n { Replace it. }\r\n ACurrent := ANew;\r\n end;\r\nend;\r\n\r\nfunction TAbstractDictionary.SelectKeys: ISequence;\r\nbegin\r\n Result := FKeyCollection;\r\nend;\r\n\r\nfunction TAbstractDictionary.SelectValues: ISequence;\r\nbegin\r\n Result := FValueCollection;\r\nend;\r\n\r\nprocedure TAbstractDictionary.SetValue(const AKey: TKey; const Value: TValue);\r\nbegin\r\n ExceptionHelper.Throw_OperationNotSupported('SetValue');\r\nend;\r\n\r\nfunction TAbstractDictionary.TryExtract(const AKey: TKey; out AValue: TValue): Boolean;\r\nbegin\r\n ExceptionHelper.Throw_OperationNotSupported('TryExtract');\r\nend;\r\n\r\nfunction TAbstractDictionary.TryGetValue(const AKey: TKey; out AFoundValue: TValue): Boolean;\r\nvar\r\n LEnumerator: IEnumerator>;\r\nbegin\r\n LEnumerator := GetEnumerator();\r\n while LEnumerator.MoveNext() do\r\n if KeysAreEqual(AKey, LEnumerator.Current.Key) then\r\n begin\r\n AFoundValue := LEnumerator.Current.Value;\r\n Exit(True);\r\n end;\r\n\r\n Result := False;\r\nend;\r\n\r\nfunction TAbstractDictionary.ValueForKey(const AKey: TKey): TValue;\r\nbegin\r\n if not TryGetValue(AKey, Result) then\r\n ExceptionHelper.Throw_KeyNotFoundError('AKey');\r\nend;\r\n\r\n{ TAbstractDictionary.TKeySequence }\r\n\r\nprocedure TAbstractDictionary.TKeySequence.CopyTo(var AArray: array of TKey; const AStartIndex: NativeInt);\r\nvar\r\n LArray: TArray>;\r\n I: NativeInt;\r\nbegin\r\n { Check for indexes }\r\n if (AStartIndex >= Length(AArray)) or (AStartIndex < 0) then\r\n ExceptionHelper.Throw_ArgumentOutOfRangeError('AStartIndex');\r\n\r\n if (Length(AArray) - AStartIndex) < FOwner.Count then\r\n ExceptionHelper.Throw_ArgumentOutOfSpaceError('AArray');\r\n\r\n SetLength(LArray, FOwner.GetCount());\r\n FOwner.CopyTo(LArray, 0);\r\n\r\n for I := 0 to Length(LArray) - 1 do\r\n AArray[AStartIndex + I] := LArray[I].Key;\r\nend;\r\n\r\nconstructor TAbstractDictionary.TKeySequence.Create(const AOwner: TAbstractDictionary);\r\nbegin\r\n inherited Create(AOwner.KeyRules);\r\n FOwner := AOwner;\r\nend;\r\n\r\nfunction TAbstractDictionary.TKeySequence.GetCount: NativeInt;\r\nbegin\r\n Result := FOwner.GetCount();\r\nend;\r\n\r\nfunction TAbstractDictionary.TKeySequence.GetEnumerator: IEnumerator;\r\nbegin\r\n Result := TKeyEnumerator.Create(FOwner);\r\nend;\r\n\r\n{ TAbstractDictionary.TValueSequence }\r\n\r\nprocedure TAbstractDictionary.TValueSequence.CopyTo(var AArray: array of TValue; const AStartIndex: NativeInt);\r\nvar\r\n LArray: TArray>;\r\n I: NativeInt;\r\nbegin\r\n { Check for indexes }\r\n if (AStartIndex >= Length(AArray)) or (AStartIndex < 0) then\r\n ExceptionHelper.Throw_ArgumentOutOfRangeError('AStartIndex');\r\n\r\n if (Length(AArray) - AStartIndex) < FOwner.Count then\r\n ExceptionHelper.Throw_ArgumentOutOfSpaceError('AArray');\r\n\r\n SetLength(LArray, FOwner.GetCount());\r\n FOwner.CopyTo(LArray, 0);\r\n\r\n for I := 0 to Length(LArray) - 1 do\r\n AArray[AStartIndex + I] := LArray[I].Value;\r\nend;\r\n\r\nconstructor TAbstractDictionary.TValueSequence.Create(const AOwner: TAbstractDictionary);\r\nbegin\r\n inherited Create(AOwner.ValueRules);\r\n FOwner := AOwner;\r\nend;\r\n\r\nfunction TAbstractDictionary.TValueSequence.GetCount: NativeInt;\r\nbegin\r\n Result := FOwner.GetCount();\r\nend;\r\n\r\nfunction TAbstractDictionary.TValueSequence.GetEnumerator: IEnumerator;\r\nbegin\r\n Result := TValueEnumerator.Create(FOwner);\r\nend;\r\n\r\n{ TAbstractDictionary.TKeyEnumerator }\r\n\r\nconstructor TAbstractDictionary.TKeyEnumerator.Create(const AOwner: TAbstractDictionary);\r\nbegin\r\n inherited Create(AOwner);\r\n FOwnerEnumerator := AOwner.GetEnumerator();\r\nend;\r\n\r\nfunction TAbstractDictionary.TKeyEnumerator.TryMoveNext(out ACurrent: TKey): Boolean;\r\nbegin\r\n Result := FOwnerEnumerator.MoveNext();\r\n if Result then\r\n ACurrent := FOwnerEnumerator.Current.Key;\r\nend;\r\n\r\n{ TAbstractDictionary.TValueEnumerator }\r\n\r\nconstructor TAbstractDictionary.TValueEnumerator.Create(const AOwner: TAbstractDictionary);\r\nbegin\r\n FOwnerEnumerator := AOwner.GetEnumerator();\r\n inherited Create(AOwner);\r\nend;\r\n\r\nfunction TAbstractDictionary.TValueEnumerator.TryMoveNext(out ACurrent: TValue): Boolean;\r\nbegin\r\n Result := FOwnerEnumerator.MoveNext();\r\n if Result then\r\n ACurrent := FOwnerEnumerator.Current.Value;\r\nend;\r\n\r\n{ TDictionary }\r\n\r\nprocedure TDictionary.Add(const AKey: TKey; const AValue: TValue);\r\nbegin\r\n Insert(AKey, AValue);\r\nend;\r\n\r\nprocedure TDictionary.AddOrSetValue(const Key: TKey; const Value: TValue);\r\nbegin\r\n SetValue(Key, Value);\r\nend;\r\n\r\nprocedure TDictionary.Clear;\r\nvar\r\n I, K: NativeInt;\r\n Entry: PEntry;\r\nbegin\r\n LockForWrite;\r\n\r\n if FCount > 0 then\r\n for I := 0 to Length(FBucketArray) - 1 do\r\n FBucketArray[I] := -1;\r\n\r\n for I := 0 to Length(FEntryArray) - 1 do\r\n begin\r\n Entry := @FEntryArray[I];\r\n if Entry.FHashCode >= 0 then\r\n begin\r\n NotifyKeyRemoved(Entry.FKey);\r\n Entry.FKey := default(TKey);\r\n\r\n NotifyValueRemoved(Entry.FValue);\r\n Entry.FValue := default(TValue);\r\n end;\r\n end;\r\n\r\n FillChar(FEntryArray[0], Length(FEntryArray) * SizeOf(TEntry), 0);\r\n\r\n FFreeList := -1;\r\n FCount := 0;\r\n FFreeCount := 0;\r\n\r\n NotifyCollectionChanged();\r\n\r\n UnLockForWrite;\r\nend;\r\n\r\nfunction TDictionary.ContainsValue(const AValue: TValue): Boolean;\r\nvar\r\n I: NativeInt;\r\n Entry: PEntry;\r\nbegin\r\n Result := False;\r\n\r\n LockForRead;\r\n\r\n for I := 0 to FCount - 1 do\r\n begin\r\n Entry := @FEntryArray[I];\r\n if (Entry.FHashCode >= 0) and (ValuesAreEqual(Entry.FValue, AValue)) then\r\n begin\r\n UnLockForRead;\r\n Exit(True);\r\n end;\r\n end;\r\n\r\n UnLockForRead;\r\nend;\r\n\r\nprocedure TDictionary.CopyTo(var AArray: array of TPair; const AStartIndex: NativeInt);\r\nvar\r\n I, X: NativeInt;\r\n Entry: PEntry;\r\nbegin\r\n { Check for indexes }\r\n if (AStartIndex >= Length(AArray)) or (AStartIndex < 0) then\r\n ExceptionHelper.Throw_ArgumentOutOfRangeError('AStartIndex');\r\n\r\n if (Length(AArray) - AStartIndex) < Count then\r\n ExceptionHelper.Throw_ArgumentOutOfSpaceError('AArray');\r\n\r\n X := AStartIndex;\r\n\r\n LockForRead;\r\n\r\n for I := 0 to FCount - 1 do\r\n begin\r\n Entry := @FEntryArray[I];\r\n if (Entry.FHashCode >= 0) then\r\n begin\r\n AArray[X].Key := Entry.FKey;\r\n AArray[X].Value := Entry.FValue;\r\n\r\n Inc(X);\r\n end;\r\n end;\r\n\r\n UnLockForRead;\r\nend;\r\n\r\nconstructor TDictionary.Create(const AKeyRules: TRules;\r\n const AValueRules: TRules; const AInitialCapacity: NativeInt = TAbstractContainer.CDefaultSize;\r\n const AThreadSafe: Boolean = False);\r\nbegin\r\n inherited Create(AKeyRules, AValueRules);\r\n\r\n ThreadSafe := AThreadSafe;\r\n\r\n if AInitialCapacity <= 0 then\r\n InitializeInternals(CDefaultSize)\r\n else\r\n InitializeInternals(AInitialCapacity)\r\nend;\r\n\r\ndestructor TDictionary.Destroy;\r\nbegin\r\n inherited Destroy;\r\nend;\r\n\r\nconstructor TDictionary.Create(const AInitialCapacity: NativeInt = TAbstractContainer.CDefaultSize;\r\n const AThreadSafe: Boolean = False);\r\nbegin\r\n Create(TRules.Default, TRules.Default, AInitialCapacity, AThreadSafe);\r\nend;\r\n\r\n//constructor TDictionary.Create(const AKeyRules: TRules; const AValueRules: TRules);\r\n//begin\r\n// Create(AKeyRules, AValueRules, CDefaultSize);\r\n//end;\r\n\r\nfunction TDictionary.FindEntry(const AKey: TKey): NativeInt;\r\nvar\r\n LHashCode, I: NativeInt;\r\n Entry: PEntry;\r\nbegin\r\n Result := -1;\r\n\r\n LockForRead;\r\n\r\n if Length(FBucketArray) > 0 then\r\n begin\r\n { Generate the hash code }\r\n LHashCode := Hash(AKey);\r\n\r\n I := FBucketArray[LHashCode mod Length(FBucketArray)];\r\n\r\n while I >= 0 do\r\n begin\r\n Entry := @FEntryArray[I];\r\n if (Entry.FHashCode = LHashCode) and KeysAreEqual(Entry.FKey, AKey) then\r\n begin\r\n Result := I;\r\n\r\n UnLockForRead;\r\n Exit;\r\n end;\r\n\r\n I := Entry.FNext;\r\n end;\r\n end;\r\n\r\n UnLockForRead;\r\nend;\r\n\r\nfunction TDictionary.GetCount: NativeInt;\r\nbegin\r\n LockForRead;\r\n\r\n Result := (FCount - FFreeCount);\r\n\r\n UnLockForRead;\r\nend;\r\n\r\nfunction TDictionary.GetEnumerator: IEnumerator>;\r\nbegin\r\n Result := TEnumerator.Create(Self);\r\nend;\r\n\r\nfunction TDictionary.Hash(const AKey: TKey): NativeInt;\r\nconst\r\n PositiveMask = not NativeInt(1 shl (SizeOf(NativeInt) * 8 - 1));\r\nbegin\r\n Result := PositiveMask and ((PositiveMask and GetKeyHashCode(AKey)) + 1);\r\nend;\r\n\r\nprocedure TDictionary.InitializeInternals(const ACapacity: NativeInt);\r\nvar\r\n I: NativeInt;\r\nbegin\r\n LockForWrite;\r\n\r\n SetLength(FBucketArray, ACapacity);\r\n SetLength(FEntryArray, ACapacity);\r\n\r\n for I := 0 to ACapacity - 1 do\r\n begin\r\n FBucketArray[I] := -1;\r\n FEntryArray[I].FHashCode := -1;\r\n end;\r\n\r\n FFreeList := -1;\r\n\r\n UnLockForWrite;\r\nend;\r\n\r\nprocedure TDictionary.Insert(const AKey: TKey; const AValue: TValue; const AShouldAdd: Boolean);\r\nvar\r\n LFreeList, LIndex,\r\n LHashCode, I: NativeInt;\r\n Entry: PEntry;\r\nbegin\r\n LockForRead;\r\n\r\n LFreeList := 0;\r\n\r\n if Length(FBucketArray) = 0 then\r\n InitializeInternals(CDefaultSize);\r\n\r\n { Generate the hash code }\r\n LHashCode := Hash(AKey);\r\n LIndex := LHashCode mod Length(FBucketArray);\r\n\r\n I := FBucketArray[LIndex];\r\n\r\n while I >= 0 do\r\n begin\r\n Entry := @FEntryArray[I];\r\n if (Entry.FHashCode = LHashCode) and KeysAreEqual(Entry.FKey, AKey) then\r\n begin\r\n if AShouldAdd then\r\n begin\r\n UnLockForRead;\r\n ExceptionHelper.Throw_DuplicateKeyError('AKey');\r\n end;\r\n\r\n LockForWrite;\r\n\r\n ReplaceValue(Entry.FValue, AValue);\r\n NotifyCollectionChanged();\r\n\r\n UnLockForWrite;\r\n\r\n UnLockForRead;\r\n Exit;\r\n end;\r\n\r\n { Move to next }\r\n I := Entry.FNext;\r\n end;\r\n\r\n { Adjust free spaces }\r\n if FFreeCount > 0 then\r\n begin\r\n LFreeList := FFreeList;\r\n\r\n LockForWrite;\r\n\r\n FFreeList := FEntryArray[LFreeList].FNext;\r\n Dec(FFreeCount);\r\n\r\n UnLockForWrite;\r\n end else\r\n begin\r\n { Adjust LIndex if there is not enough free space }\r\n if FCount = Length(FEntryArray) then\r\n begin\r\n Resize();\r\n LIndex := LHashCode mod Length(FBucketArray);\r\n end;\r\n\r\n LFreeList := FCount;\r\n\r\n LockForWrite;\r\n Inc(FCount);\r\n UnLockForWrite;\r\n end;\r\n\r\n { Insert the element at the right position and adjust arrays }\r\n LockForWrite;\r\n\r\n Entry := @FEntryArray[LFreeList];\r\n Entry.FHashCode := LHashCode;\r\n Entry.FKey := AKey;\r\n Entry.FValue := AValue;\r\n Entry.FNext := FBucketArray[LIndex];\r\n\r\n FBucketArray[LIndex] := LFreeList;\r\n\r\n NotifyCollectionChanged();\r\n\r\n UnLockForWrite;\r\n\r\n UnLockForRead;\r\nend;\r\n\r\nprocedure TDictionary.Remove(const AKey: TKey);\r\nbegin\r\n LockForWrite;\r\n try\r\n inherited Remove(AKey);\r\n finally\r\n UnLockForWrite;\r\n end;\r\nend;\r\n\r\nprocedure TDictionary.ReplaceValue(var ACurrent: TValue; const ANew: TValue);\r\nbegin\r\n LockForWrite;\r\n inherited ReplaceValue(ACurrent, ANew);\r\n UnLockForWrite;\r\nend;\r\n\r\nprocedure TDictionary.Resize;\r\nvar\r\n LNewLength, I, LIndex: NativeInt;\r\n Entry: PEntry;\r\nbegin\r\n LockForWrite;\r\n\r\n LNewLength := FCount * 2;\r\n\r\n SetLength(FBucketArray, LNewLength);\r\n SetLength(FEntryArray, LNewLength);\r\n\r\n for I := 0 to LNewLength - 1 do\r\n FBucketArray[I] := -1;\r\n\r\n for I := 0 to FCount - 1 do\r\n begin\r\n Entry := @FEntryArray[I];\r\n LIndex := Entry.FHashCode mod LNewLength;\r\n Entry.FNext := FBucketArray[LIndex];\r\n FBucketArray[LIndex] := I;\r\n end;\r\n\r\n UnLockForWrite;\r\nend;\r\n\r\nprocedure TDictionary.SetValue(const AKey: TKey; const Value: TValue);\r\nbegin\r\n { Simply call insert }\r\n LockForWrite;\r\n try\r\n Insert(AKey, Value, false);\r\n finally\r\n UnLockForWrite;\r\n end;\r\nend;\r\n\r\nfunction TDictionary.TryExtract(const AKey: TKey; out AValue: TValue): Boolean;\r\nvar\r\n LHashCode, LIndex,\r\n LRemIndex, I: NativeInt;\r\n Entry: PEntry;\r\nbegin\r\n Result := False;\r\n\r\n LockForRead;\r\n\r\n if Length(FBucketArray) > 0 then\r\n begin\r\n { Generate the hash code }\r\n LHashCode := Hash(AKey);\r\n\r\n LIndex := LHashCode mod Length(FBucketArray);\r\n LRemIndex := -1;\r\n\r\n I := FBucketArray[LIndex];\r\n\r\n while I >= 0 do\r\n begin\r\n Entry := @FEntryArray[I];\r\n if (Entry.FHashCode = LHashCode) and KeysAreEqual(Entry.FKey, AKey) then\r\n begin\r\n LockForWrite;\r\n\r\n if LRemIndex < 0 then\r\n FBucketArray[LIndex] := Entry.FNext\r\n else\r\n FEntryArray[LRemIndex].FNext := Entry.FNext;\r\n\r\n { Cleanup required? }\r\n AValue := Entry.FValue;\r\n Result := True;\r\n\r\n Entry.FHashCode := -1;\r\n Entry.FNext := FFreeList;\r\n Entry.FKey := default(TKey);\r\n Entry.FValue := default(TValue);\r\n\r\n FFreeList := I;\r\n Inc(FFreeCount);\r\n NotifyCollectionChanged();\r\n\r\n UnLockForWrite;\r\n UnLockForRead;\r\n\r\n Exit;\r\n end;\r\n\r\n LRemIndex := I;\r\n I := Entry.FNext;\r\n end;\r\n end;\r\n\r\n UnLockForRead;\r\nend;\r\n\r\nfunction TDictionary.TryGetValue(const AKey: TKey; out AFoundValue: TValue): Boolean;\r\nvar\r\n LIndex: NativeInt;\r\nbegin\r\n LockForRead;\r\n\r\n LIndex := FindEntry(AKey);\r\n\r\n if LIndex >= 0 then\r\n begin\r\n AFoundValue := FEntryArray[LIndex].FValue;\r\n\r\n UnLockForRead;\r\n Exit(True);\r\n end;\r\n\r\n UnLockForRead;\r\n\r\n { Key not found, simply fail }\r\n AFoundValue := Default(TValue);\r\n Result := False;\r\nend;\r\n\r\n\r\n{ TDictionary.TEnumerator }\r\n\r\nfunction TDictionary.TEnumerator.TryMoveNext(out ACurrent: TPair): Boolean;\r\nvar\r\n Entry: PEntry;\r\nbegin\r\n with TDictionary(Owner) do\r\n begin\r\n LockForRead;\r\n\r\n while FCurrentIndex < FCount do\r\n begin\r\n Entry := @FEntryArray[FCurrentIndex];\r\n if Entry.FHashCode >= 0 then\r\n begin\r\n ACurrent.Key := Entry.FKey;\r\n ACurrent.Value := Entry.FValue;\r\n\r\n Inc(FCurrentIndex);\r\n Result := True;\r\n\r\n UnLockForRead;\r\n Exit;\r\n end;\r\n\r\n Inc(FCurrentIndex);\r\n end;\r\n\r\n FCurrentIndex := FCount + 1;\r\n Result := False;\r\n\r\n UnLockForRead;\r\n end;\r\nend;\r\n\r\n{ TObjectDictionary }\r\n\r\nprocedure TObjectDictionary.HandleKeyRemoved(const AKey: TKey);\r\nbegin\r\n if FOwnsKeys then\r\n PObject(@AKey)^.Free;\r\nend;\r\n\r\nprocedure TObjectDictionary.HandleValueRemoved(const AValue: TValue);\r\nbegin\r\n if FOwnsValues then\r\n PObject(@AValue)^.Free;\r\nend;\r\n\r\nprocedure TObjectDictionary.ReplaceValue(var ACurrent: TValue; const ANew: TValue);\r\nbegin\r\n { Only act if owns objects is set. Otherwise fallback to default. }\r\n if (FOwnsValues) and (PObject(@ACurrent)^ <> PObject(@ANew)^) then\r\n begin\r\n NotifyValueRemoved(ACurrent);\r\n ACurrent := ANew;\r\n end else\r\n inherited;\r\nend;\r\n\r\n{ TLinkedDictionary }\r\n\r\nprocedure TLinkedDictionary.Add(const AKey: TKey; const AValue: TValue);\r\nbegin\r\n Insert(AKey, AValue);\r\nend;\r\n\r\nprocedure TLinkedDictionary.Clear;\r\nvar\r\n LEntry, LCurr: PEntry;\r\nbegin\r\n LEntry := FHead;\r\n\r\n while Assigned(LEntry) do\r\n begin\r\n NotifyKeyRemoved(LEntry.FKey);\r\n NotifyValueRemoved(LEntry.FValue);\r\n\r\n { Next and kill }\r\n LCurr := LEntry;\r\n LEntry := LEntry^.FNext;\r\n\r\n ReleaseEntry(LCurr);\r\n end;\r\n\r\n { Clear nodes }\r\n FHead := nil;\r\n FTail := nil;\r\n\r\n { Clear array }\r\n FillChar(FBucketArray[0], Length(FBucketArray) * SizeOf(PEntry), 0);\r\n FCount := 0;\r\n\r\n NotifyCollectionChanged();\r\nend;\r\n\r\nfunction TLinkedDictionary.ContainsValue(const AValue: TValue): Boolean;\r\nvar\r\n LEntry: PEntry;\r\nbegin\r\n Result := False;\r\n LEntry := FHead;\r\n\r\n while Assigned(LEntry) do\r\n begin\r\n if ValuesAreEqual(LEntry^.FValue, AValue) then\r\n Exit(true);\r\n\r\n { Go to next }\r\n LEntry := LEntry^.FNext;\r\n end;\r\nend;\r\n\r\nprocedure TLinkedDictionary.CopyTo(var AArray: array of TPair; const AStartIndex: NativeInt);\r\nvar\r\n I, X: NativeInt;\r\n LEntry: PEntry;\r\nbegin\r\n { Check for indexes }\r\n if (AStartIndex >= Length(AArray)) or (AStartIndex < 0) then\r\n ExceptionHelper.Throw_ArgumentOutOfRangeError('AStartIndex');\r\n\r\n if (Length(AArray) - AStartIndex) < Count then\r\n ExceptionHelper.Throw_ArgumentOutOfSpaceError('AArray');\r\n\r\n X := AStartIndex;\r\n LEntry := FHead;\r\n\r\n while Assigned(LEntry) do\r\n begin\r\n { Copy it }\r\n AArray[X].Key := LEntry^.FKey;\r\n AArray[X].Value := LEntry^.FValue;\r\n\r\n { Go to next }\r\n Inc(X);\r\n LEntry := LEntry^.FNext;\r\n end;\r\nend;\r\n\r\nconstructor TLinkedDictionary.Create(\r\n const AKeyRules: TRules; const AValueRules: TRules; const AInitialCapacity: NativeInt);\r\nbegin\r\n inherited Create(AKeyRules, AValueRules);\r\n\r\n if AInitialCapacity <= 0 then\r\n InitializeInternals(CDefaultSize)\r\n else\r\n InitializeInternals(AInitialCapacity)\r\nend;\r\n\r\nconstructor TLinkedDictionary.Create();\r\nbegin\r\n Create(TRules.Default, TRules.Default, CDefaultSize);\r\nend;\r\n\r\nconstructor TLinkedDictionary.Create(const AKeyRules: TRules; const AValueRules: TRules);\r\nbegin\r\n Create(AKeyRules, AValueRules, CDefaultSize);\r\nend;\r\n\r\ndestructor TLinkedDictionary.Destroy;\r\nvar\r\n LNext: PEntry;\r\nbegin\r\n { Clear first }\r\n Clear();\r\n\r\n { Clear the cached entries too }\r\n if FFreeCount > 0 then\r\n while Assigned(FFirstFree) do\r\n begin\r\n LNext := FFirstFree^.FNext;\r\n\r\n { Delphi doesn't seem to finalize these }\r\n FFirstFree^.FValue := default(TValue);\r\n FFirstFree^.FKey := default(TKey);\r\n\r\n FreeMem(FFirstFree);\r\n FFirstFree := LNext;\r\n end;\r\n\r\n inherited;\r\nend;\r\n\r\nfunction TLinkedDictionary.FindEntry(const AKey: TKey): PEntry;\r\nvar\r\n LHashCode, LCapacity: NativeInt;\r\n LEntry: PEntry;\r\nbegin\r\n { Init }\r\n Result := nil;\r\n LHashCode := Hash(AKey);\r\n LCapacity := Length(FBucketArray);\r\n LEntry := FBucketArray[LHashCode mod LCapacity];\r\n\r\n while Assigned(LEntry) and\r\n ((LEntry^.FHashCode mod LCapacity) = (LHashCode mod LCapacity)) do\r\n begin\r\n { Check the key }\r\n if KeysAreEqual(LEntry^.FKey, AKey) then\r\n Exit(LEntry);\r\n\r\n { Go to next }\r\n LEntry := LEntry^.FNext;\r\n end;\r\nend;\r\n\r\nfunction TLinkedDictionary.GetCount: NativeInt;\r\nbegin\r\n Result := FCount;\r\nend;\r\n\r\nfunction TLinkedDictionary.GetEnumerator: IEnumerator>;\r\nvar\r\n LEnumerator: TEnumerator;\r\nbegin\r\n LEnumerator := TEnumerator.Create(Self);\r\n LEnumerator.FCurrentEntry := FHead;\r\n Result := LEnumerator;\r\nend;\r\n\r\nfunction TLinkedDictionary.Hash(const AKey: TKey): NativeInt;\r\nconst\r\n PositiveMask = not NativeInt(1 shl (SizeOf(NativeInt) * 8 - 1));\r\nbegin\r\n Result := PositiveMask and ((PositiveMask and GetKeyHashCode(AKey)) + 1);\r\nend;\r\n\r\nprocedure TLinkedDictionary.InitializeInternals(const ACapacity: NativeInt);\r\nbegin\r\n { Initialize and clear the dictionary }\r\n SetLength(FBucketArray, ACapacity);\r\n FillChar(FBucketArray[0], ACapacity * SizeOf(PEntry), 0);\r\nend;\r\n\r\nprocedure TLinkedDictionary.Insert(const AKey: TKey; const AValue: TValue; const AShouldAdd: Boolean);\r\nvar\r\n LHashCode, LNewLength, LCapacity: NativeInt;\r\n LEntry, LNewEntry: PEntry;\r\nbegin\r\n { Initialize stuff }\r\n LHashCode := Hash(AKey);\r\n\r\n while True do\r\n begin\r\n LCapacity := Length(FBucketArray);\r\n LEntry := FBucketArray[LHashCode mod LCapacity];\r\n\r\n { Case 1: we have a free spot and can insert directly }\r\n if not Assigned(LEntry) then\r\n begin\r\n { Insert the entry }\r\n LNewEntry := NeedEntry(AKey, AValue, LHashCode);\r\n LNewEntry^.FPrev := FTail;\r\n LNewEntry^.FNext := nil;\r\n\r\n if Assigned(FTail) then\r\n FTail^.FNext := LNewEntry;\r\n\r\n FTail := LNewEntry;\r\n\r\n if not Assigned(FHead) then\r\n FHead := LNewEntry;\r\n\r\n FBucketArray[LHashCode mod LCapacity] := LNewEntry;\r\n\r\n NotifyCollectionChanged();\r\n Inc(FCount);\r\n\r\n Exit;\r\n end;\r\n\r\n { Case 2: The spot is filled but capacity is sufficient }\r\n if FCount < LCapacity then\r\n begin\r\n { Search for a place to insert the node into }\r\n\r\n while True do\r\n begin\r\n { Check the key }\r\n if KeysAreEqual(LEntry^.FKey, AKey) then\r\n begin\r\n if AShouldAdd then\r\n ExceptionHelper.Throw_DuplicateKeyError('AKey');\r\n\r\n ReplaceValue(LEntry^.FValue, AValue);\r\n\r\n NotifyCollectionChanged();\r\n Exit;\r\n end;\r\n\r\n if not Assigned(LEntry^.FNext) or\r\n ((LEntry^.FNext^.FHashCode mod LCapacity) <> (LHashCode mod LCapacity)) then Break;\r\n\r\n { Go to next }\r\n LEntry := LEntry^.FNext;\r\n end;\r\n\r\n { Insert the entry }\r\n LNewEntry := NeedEntry(AKey, AValue, LHashCode);\r\n\r\n { Get our entry in }\r\n LNewEntry^.FNext := LEntry^.FNext;\r\n LNewEntry^.FPrev := LEntry;\r\n\r\n if Assigned(LEntry^.FNext) then\r\n LEntry^.FNext^.FPrev := LNewEntry;\r\n\r\n LEntry^.FNext := LNewEntry;\r\n\r\n if LEntry = FTail then\r\n FTail := LNewEntry;\r\n\r\n NotifyCollectionChanged();\r\n Inc(FCount);\r\n\r\n Exit;\r\n end;\r\n\r\n { Case 3: The spot is filled but capacity is not sufficient }\r\n if FCount >= LCapacity then\r\n begin\r\n { Reset the bucket list }\r\n LNewLength := FCount * 2;\r\n SetLength(FBucketArray, LNewLength);\r\n FillChar(FBucketArray[0], LNewLength * SizeOf(PEntry), 0);\r\n\r\n { Rehash! }\r\n LEntry := FHead;\r\n FHead := nil;\r\n FTail := nil;\r\n\r\n { Rehash the whole list using new capacity }\r\n while Assigned(LEntry) do\r\n begin\r\n LNewEntry := LEntry^.FNext;\r\n ReInsert(LEntry, LNewLength);\r\n\r\n LEntry := LNewEntry;\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TLinkedDictionary.NeedEntry(const AKey: TKey;\r\n const AValue: TValue; const AHash: NativeInt): PEntry;\r\nbegin\r\n if FFreeCount > 0 then\r\n begin\r\n Result := FFirstFree;\r\n FFirstFree := FFirstFree^.FNext;\r\n\r\n Dec(FFreeCount);\r\n end else\r\n Result := AllocMem(SizeOf(TEntry));\r\n\r\n { Initialize the node }\r\n Result^.FHashCode := AHash;\r\n Result^.FKey := AKey;\r\n Result^.FValue := AValue;\r\nend;\r\n\r\nprocedure TLinkedDictionary.ReInsert(const AEntry: PEntry; const ACapacity: NativeInt);\r\nvar\r\n LEntry: PEntry;\r\nbegin\r\n { Initialize stuff }\r\n LEntry := FBucketArray[AEntry^.FHashCode mod ACapacity];\r\n\r\n { Case 1: we have a free spot and can insert directly }\r\n if not Assigned(LEntry) then\r\n begin\r\n AEntry^.FPrev := FTail;\r\n AEntry^.FNext := nil;\r\n\r\n if Assigned(FTail) then\r\n FTail^.FNext := AEntry;\r\n\r\n FTail := AEntry;\r\n\r\n if not Assigned(FHead) then\r\n FHead := AEntry;\r\n\r\n FBucketArray[AEntry^.FHashCode mod ACapacity] := AEntry;\r\n\r\n Exit;\r\n end;\r\n\r\n { Case 2: The spot is filled but capacity is sufficient }\r\n while True do\r\n begin\r\n { Check the key }\r\n ASSERT(not KeysAreEqual(LEntry^.FKey, AEntry^.FKey));\r\n\r\n if not Assigned(LEntry^.FNext) or\r\n ((LEntry^.FNext^.FHashCode mod ACapacity) <> (AEntry^.FHashCode mod ACapacity)) then Break;\r\n\r\n { Go to next }\r\n LEntry := LEntry^.FNext;\r\n end;\r\n\r\n { Get our entry in }\r\n AEntry^.FNext := LEntry^.FNext;\r\n AEntry^.FPrev := LEntry;\r\n\r\n if Assigned(LEntry^.FNext) then\r\n LEntry^.FNext^.FPrev := AEntry;\r\n\r\n LEntry^.FNext := AEntry;\r\n\r\n if LEntry = FTail then\r\n FTail := AEntry;\r\nend;\r\n\r\nprocedure TLinkedDictionary.ReleaseEntry(const AEntry: PEntry);\r\nbegin\r\n if FFreeCount = CDefaultSize then\r\n begin\r\n { Delphi doesn't seem to finalize these }\r\n AEntry^.FValue := default(TValue);\r\n AEntry^.FKey := default(TKey);\r\n\r\n FreeMem(AEntry);\r\n end else begin\r\n { Place the entry into the cache }\r\n AEntry^.FNext := FFirstFree;\r\n FFirstFree := AEntry;\r\n\r\n Inc(FFreeCount);\r\n end;\r\nend;\r\n\r\nprocedure TLinkedDictionary.SetValue(const AKey: TKey; const Value: TValue);\r\nbegin\r\n { Simply call insert }\r\n Insert(AKey, Value, false);\r\nend;\r\n\r\nfunction TLinkedDictionary.TryExtract(const AKey: TKey; out AValue: TValue): Boolean;\r\nvar\r\n LHashCode, LCapacity: NativeInt;\r\n LEntry: PEntry;\r\nbegin\r\n { Generate the hash code }\r\n LHashCode := Hash(AKey);\r\n LCapacity := Length(FBucketArray);\r\n LEntry := FBucketArray[LHashCode mod LCapacity];\r\n Result := False;\r\n\r\n while Assigned(LEntry) and\r\n ((LEntry^.FHashCode mod LCapacity) = (LHashCode mod LCapacity)) do\r\n begin\r\n { Check the key }\r\n if KeysAreEqual(LEntry^.FKey, AKey) then\r\n begin\r\n { Remove self from the linked list }\r\n if Assigned(LEntry^.FPrev) then\r\n LEntry^.FPrev^.FNext := LEntry^.FNext;\r\n\r\n if Assigned(LEntry^.FNext) then\r\n LEntry^.FNext^.FPrev := LEntry^.FPrev;\r\n\r\n if LEntry = FBucketArray[LHashCode mod LCapacity] then\r\n begin\r\n { This entry is the first for the given hash code. Set the next if it has same hash. }\r\n if Assigned(LEntry^.FNext) and ((LEntry^.FNext^.FHashCode mod LCapacity) = (LEntry^.FHashCode mod LCapacity)) then\r\n FBucketArray[LHashCode mod LCapacity] := LEntry^.FNext\r\n else\r\n FBucketArray[LHashCode mod LCapacity] := nil;\r\n end;\r\n\r\n if FTail = LEntry then\r\n FTail := LEntry^.FPrev;\r\n\r\n if FHead = LEntry then\r\n FHead := LEntry^.FNext;\r\n\r\n\r\n { Kill this entry }\r\n AValue := LEntry^.FValue;\r\n Result := True;\r\n\r\n ReleaseEntry(LEntry);\r\n Dec(FCount);\r\n NotifyCollectionChanged();\r\n\r\n { All done, let's exit }\r\n Exit;\r\n end;\r\n\r\n { Go to next }\r\n LEntry := LEntry^.FNext;\r\n end;\r\nend;\r\n\r\nfunction TLinkedDictionary.TryGetValue(const AKey: TKey; out AFoundValue: TValue): Boolean;\r\nvar\r\n LEntry: PEntry;\r\nbegin\r\n LEntry := FindEntry(AKey);\r\n\r\n if Assigned(LEntry) then\r\n begin\r\n AFoundValue := LEntry^.FValue;\r\n Exit(True);\r\n end;\r\n\r\n { Key not found, simply fail }\r\n AFoundValue := default(TValue);\r\n Result := False;\r\nend;\r\n\r\n{ TLinkedDictionary.TEnumerator }\r\n\r\nfunction TLinkedDictionary.TEnumerator.TryMoveNext(out ACurrent: TPair): Boolean;\r\nbegin\r\n Result := Assigned(FCurrentEntry);\r\n if Result then\r\n begin\r\n ACurrent.Key := FCurrentEntry^.FKey;\r\n ACurrent.Value := FCurrentEntry^.FValue;\r\n\r\n FCurrentEntry := FCurrentEntry^.FNext;\r\n end;\r\nend;\r\n\r\n{ TObjectLinkedDictionary }\r\n\r\nprocedure TObjectLinkedDictionary.HandleKeyRemoved(const AKey: TKey);\r\nbegin\r\n if FOwnsKeys then\r\n PObject(@AKey)^.Free;\r\nend;\r\n\r\nprocedure TObjectLinkedDictionary.HandleValueRemoved(const AValue: TValue);\r\nbegin\r\n if FOwnsValues then\r\n PObject(@AValue)^.Free;\r\nend;\r\n\r\nprocedure TObjectLinkedDictionary.ReplaceValue(var ACurrent: TValue; const ANew: TValue);\r\nbegin\r\n { Only act if owns objects is set. Otherwise fallback to default. }\r\n if (FOwnsValues) and (PObject(@ACurrent)^ <> PObject(@ANew)^) then\r\n begin\r\n NotifyValueRemoved(ACurrent);\r\n ACurrent := ANew;\r\n end else\r\n inherited;\r\nend;\r\n\r\n{ TSortedDictionary }\r\n\r\nprocedure TSortedDictionary.Add(const AKey: TKey; const AValue: TValue);\r\nbegin\r\n { Insert the pair }\r\n if not Insert(AKey, AValue, false) then\r\n ExceptionHelper.Throw_DuplicateKeyError('AKey');\r\nend;\r\n\r\nprocedure TSortedDictionary.BalanceTreesAfterRemoval(const ANode: TNode);\r\nvar\r\n LCurrentAct: TBalanceAct;\r\n LLNode, LXNode, LSNode,\r\n LWNode, LYNode: TNode;\r\nbegin\r\n { Initiliaze ... }\r\n LCurrentAct := TBalanceAct.baStart;\r\n LLNode := ANode;\r\n\r\n { Continue looping until end is declared }\r\n while LCurrentAct <> TBalanceAct.baEnd do\r\n begin\r\n case LCurrentAct of\r\n\r\n { START MODE }\r\n TBalanceAct.baStart:\r\n begin\r\n if not Assigned(LLNode.FRight) then\r\n begin\r\n { Exclude myself! }\r\n if Assigned(LLNode.FLeft) then\r\n LLNode.FLeft.FParent := LLNode.FParent;\r\n\r\n { I'm root! nothing to do here }\r\n if not Assigned(LLNode.FParent) then\r\n begin\r\n FRoot := LLNode.FLeft;\r\n\r\n { DONE! }\r\n LCurrentAct := TBalanceAct.baEnd;\r\n continue;\r\n end;\r\n\r\n { ... }\r\n if LLNode = LLNode.FParent.FLeft then\r\n begin\r\n LLNode.FParent.FLeft := LLNode.FLeft;\r\n LYNode := LLNode.FParent;\r\n end else\r\n begin\r\n LLNode.FParent.FRight := LLNode.FLeft;\r\n LYNode := LLNode.FParent;\r\n\r\n { RIGHT! }\r\n LCurrentAct := TBalanceAct.baRight;\r\n continue;\r\n end;\r\n end else if not Assigned(LLNode.FRight.FLeft) then\r\n begin\r\n { Case 1, RIGHT, NO LEFT }\r\n if Assigned(LLNode.FLeft) then\r\n begin\r\n LLNode.FLeft.FParent := LLNode.FRight;\r\n LLNode.FRight.FLeft := LLNode.FLeft;\r\n end;\r\n\r\n LLNode.FRight.FBalance := LLNode.FBalance;\r\n LLNode.FRight.FParent := LLNode.FParent;\r\n\r\n if not Assigned(LLNode.FParent) then\r\n FRoot := LLNode.FRight\r\n else\r\n begin\r\n if LLNode = LLNode.FParent.FLeft then\r\n LLNode.FParent.FLeft := LLNode.FRight\r\n else\r\n LLNode.FParent.FRight := LLNode.FRight;\r\n end;\r\n\r\n LYNode := LLNode.FRight;\r\n\r\n { RIGHT! }\r\n LCurrentAct := TBalanceAct.baRight;\r\n continue;\r\n end else\r\n begin\r\n { Case 3: RIGHT+LEFT }\r\n LSNode := LLNode.FRight.FLeft;\r\n\r\n while Assigned(LSNode.FLeft) do\r\n LSNode := LSNode.FLeft;\r\n\r\n if Assigned(LLNode.FLeft) then\r\n begin\r\n LLNode.FLeft.FParent := LSNode;\r\n LSNode.FLeft := LLNode.FLeft;\r\n end;\r\n\r\n LSNode.FParent.FLeft := LSNode.FRight;\r\n\r\n if Assigned(LSNode.FRight) then\r\n LSNode.FRight.FParent := LSNode.FParent;\r\n\r\n LLNode.FRight.FParent := LSNode;\r\n LSNode.FRight := LLNode.FRight;\r\n\r\n LYNode := LSNode.FParent;\r\n\r\n LSNode.FBalance := LLNode.FBalance;\r\n LSNode.FParent := LLNode.FParent;\r\n\r\n if not Assigned(LLNode.FParent) then\r\n FRoot := LSNode\r\n else\r\n begin\r\n if LLNode = LLNode.FParent.FLeft then\r\n LLNode.FParent.FLeft := LSNode\r\n else\r\n LLNode.FParent.FRight := LSNode;\r\n end;\r\n end;\r\n\r\n { LEFT! }\r\n LCurrentAct := TBalanceAct.baLeft;\r\n continue;\r\n end; { baStart }\r\n\r\n { LEFT BALANCING MODE }\r\n TBalanceAct.baLeft:\r\n begin\r\n Inc(LYNode.FBalance);\r\n\r\n if LYNode.FBalance = 1 then\r\n begin\r\n { DONE! }\r\n LCurrentAct := TBalanceAct.baEnd;\r\n continue;\r\n end\r\n else if LYNode.FBalance = 2 then\r\n begin\r\n LXNode := LYNode.FRight;\r\n\r\n if LXNode.FBalance = -1 then\r\n begin\r\n LWNode := LXNode.FLeft;\r\n LWNode.FParent := LYNode.FParent;\r\n\r\n if not Assigned(LYNode.FParent) then\r\n FRoot := LWNode\r\n else\r\n begin\r\n if LYNode.FParent.FLeft = LYNode then\r\n LYNode.FParent.FLeft := LWNode\r\n else\r\n LYNode.FParent.FRight := LWNode;\r\n end;\r\n\r\n LXNode.FLeft := LWNode.FRight;\r\n\r\n if Assigned(LXNode.FLeft) then\r\n LXNode.FLeft.FParent := LXNode;\r\n\r\n LYNode.FRight := LWNode.FLeft;\r\n\r\n if Assigned(LYNode.FRight) then\r\n LYNode.FRight.FParent := LYNode;\r\n\r\n LWNode.FRight := LXNode;\r\n LWNode.FLeft := LYNode;\r\n\r\n LXNode.FParent := LWNode;\r\n LYNode.FParent := LWNode;\r\n\r\n if LWNode.FBalance = 1 then\r\n begin\r\n LXNode.FBalance := 0;\r\n LYNode.FBalance := -1;\r\n end else if LWNode.FBalance = 0 then\r\n begin\r\n LXNode.FBalance := 0;\r\n LYNode.FBalance := 0;\r\n end else\r\n begin\r\n LXNode.FBalance := 1;\r\n LYNode.FBalance := 0;\r\n end;\r\n\r\n LWNode.FBalance := 0;\r\n LYNode := LWNode;\r\n end else\r\n begin\r\n LXNode.FParent := LYNode.FParent;\r\n\r\n if Assigned(LYNode.FParent) then\r\n begin\r\n if LYNode.FParent.FLeft = LYNode then\r\n LYNode.FParent.FLeft := LXNode\r\n else\r\n LYNode.FParent.FRight := LXNode;\r\n end else\r\n FRoot := LXNode;\r\n\r\n LYNode.FRight := LXNode.FLeft;\r\n\r\n if Assigned(LYNode.FRight) then\r\n LYNode.FRight.FParent := LYNode;\r\n\r\n LXNode.FLeft := LYNode;\r\n LYNode.FParent := LXNode;\r\n\r\n if LXNode.FBalance = 0 then\r\n begin\r\n LXNode.FBalance := -1;\r\n LYNode.FBalance := 1;\r\n\r\n { DONE! }\r\n LCurrentAct := TBalanceAct.baEnd;\r\n continue;\r\n end else\r\n begin\r\n LXNode.FBalance := 0;\r\n LYNode.FBalance := 0;\r\n\r\n LYNode := LXNode;\r\n end;\r\n end;\r\n end;\r\n\r\n { LOOP! }\r\n LCurrentAct := TBalanceAct.baLoop;\r\n continue;\r\n end; { baLeft }\r\n\r\n { RIGHT BALANCING MODE }\r\n TBalanceAct.baRight:\r\n begin\r\n Dec(LYNode.FBalance);\r\n\r\n if LYNode.FBalance = -1 then\r\n begin\r\n { DONE! }\r\n LCurrentAct := TBalanceAct.baEnd;\r\n continue;\r\n end\r\n else if LYNode.FBalance = -2 then\r\n begin\r\n LXNode := LYNode.FLeft;\r\n\r\n if LXNode.FBalance = 1 then\r\n begin\r\n LWNode := LXNode.FRight;\r\n LWNode.FParent := LYNode.FParent;\r\n\r\n if not Assigned(LYNode.FParent) then\r\n FRoot := LWNode\r\n else\r\n begin\r\n if LYNode.FParent.FLeft = LYNode then\r\n LYNode.FParent.FLeft := LWNode\r\n else\r\n LYNode.FParent.FRight := LWNode;\r\n end;\r\n\r\n LXNode.FRight := LWNode.FLeft;\r\n\r\n if Assigned(LXNode.FRight) then\r\n LXNode.FRight.FParent := LXNode;\r\n\r\n LYNode.FLeft := LWNode.FRight;\r\n\r\n if Assigned(LYNode.FLeft) then\r\n LYNode.FLeft.FParent := LYNode;\r\n\r\n LWNode.FLeft := LXNode;\r\n LWNode.FRight := LYNode;\r\n\r\n LXNode.FParent := LWNode;\r\n LYNode.FParent := LWNode;\r\n\r\n if LWNode.FBalance = -1 then\r\n begin\r\n LXNode.FBalance := 0;\r\n LYNode.FBalance := 1;\r\n end else if LWNode.FBalance = 0 then\r\n begin\r\n LXNode.FBalance := 0;\r\n LYNode.FBalance := 0;\r\n end else\r\n begin\r\n LXNode.FBalance := -1;\r\n LYNode.FBalance := 0;\r\n end;\r\n\r\n LWNode.FBalance := 0;\r\n LYNode := LWNode;\r\n end else\r\n begin\r\n LXNode.FParent := LYNode.FParent;\r\n\r\n if Assigned(LYNode.FParent) then\r\n begin\r\n if LYNode.FParent.FLeft = LYNode then\r\n LYNode.FParent.FLeft := LXNode\r\n else\r\n LYNode.FParent.FRight := LXNode\r\n end else\r\n FRoot := LXNode;\r\n\r\n LYNode.FLeft := LXNode.FRight;\r\n\r\n if Assigned(LYNode.FLeft) then\r\n LYNode.FLeft.FParent := LYNode;\r\n\r\n LXNode.FRight := LYNode;\r\n LYNode.FParent := LXNode;\r\n\r\n if LXNode.FBalance = 0 then\r\n begin\r\n LXNode.FBalance := 1;\r\n LYNode.FBalance := -1;\r\n\r\n { END! }\r\n LCurrentAct := TBalanceAct.baEnd;\r\n continue;\r\n end else\r\n begin\r\n LXNode.FBalance := 0;\r\n LYNode.FBalance := 0;\r\n\r\n LYNode := LXNode;\r\n end;\r\n end;\r\n end;\r\n\r\n { LOOP! }\r\n LCurrentAct := TBalanceAct.baLoop;\r\n continue;\r\n end; { baRight }\r\n\r\n TBalanceAct.baLoop:\r\n begin\r\n { Verify continuation }\r\n if Assigned(LYNode.FParent) then\r\n begin\r\n if LYNode = LYNode.FParent.FLeft then\r\n begin\r\n LYNode := LYNode.FParent;\r\n\r\n { LEFT! }\r\n LCurrentAct := TBalanceAct.baLeft;\r\n continue;\r\n end;\r\n\r\n LYNode := LYNode.FParent;\r\n\r\n { RIGHT! }\r\n LCurrentAct := TBalanceAct.baRight;\r\n continue;\r\n end;\r\n\r\n { END! }\r\n LCurrentAct := TBalanceAct.baEnd;\r\n continue;\r\n end;\r\n end; { Case }\r\n end; { While }\r\nend;\r\n\r\nprocedure TSortedDictionary.Clear;\r\nbegin\r\n if Assigned(FRoot) then\r\n begin\r\n RecursiveClear(FRoot);\r\n FRoot := nil;\r\n\r\n { Update markers }\r\n NotifyCollectionChanged();\r\n FCount := 0;\r\n end;\r\nend;\r\n\r\nfunction TSortedDictionary.ContainsValue(const AValue: TValue): Boolean;\r\nvar\r\n LNode: TNode;\r\nbegin\r\n { Find the left-most node }\r\n LNode := FindLeftMostNode();\r\n\r\n while Assigned(LNode) do\r\n begin\r\n { Verify existance }\r\n if ValuesAreEqual(LNode.FValue, AValue) then\r\n Exit(true);\r\n\r\n { Navigate further in the tree }\r\n LNode := WalkToTheRight(LNode);\r\n end;\r\n\r\n Exit(false);\r\nend;\r\n\r\nprocedure TSortedDictionary.CopyTo(var AArray: array of TPair; const AStartIndex: NativeInt);\r\nvar\r\n X: NativeInt;\r\n LNode: TNode;\r\nbegin\r\n { Check for indexes }\r\n if (AStartIndex >= Length(AArray)) or (AStartIndex < 0) then\r\n ExceptionHelper.Throw_ArgumentOutOfRangeError('AStartIndex');\r\n\r\n if (Length(AArray) - AStartIndex) < FCount then\r\n ExceptionHelper.Throw_ArgumentOutOfSpaceError('AArray');\r\n\r\n X := AStartIndex;\r\n\r\n { Find the left-most node }\r\n LNode := FindLeftMostNode();\r\n\r\n while Assigned(LNode) do\r\n begin\r\n { Get the key }\r\n AArray[X].Key := LNode.FKey;\r\n AArray[X].Value := LNode.FValue;\r\n\r\n { Navigate further in the tree }\r\n LNode := WalkToTheRight(LNode);\r\n\r\n { Increment the index }\r\n Inc(X);\r\n end;\r\nend;\r\n\r\nconstructor TSortedDictionary.Create();\r\nbegin\r\n Create(TRules.Default, TRules.Default, True);\r\nend;\r\n\r\nconstructor TSortedDictionary.Create(const AKeyRules: TRules; const AValueRules: TRules);\r\nbegin\r\n Create(AKeyRules, AValueRules, True);\r\nend;\r\n\r\nconstructor TSortedDictionary.Create(const AKeyRules: TRules;\r\n const AValueRules: TRules; const AAscending: Boolean);\r\nbegin\r\n inherited Create(AKeyRules, AValueRules);\r\n\r\n if AAscending then\r\n FSignFix := 1\r\n else\r\n FSignFix := -1;\r\nend;\r\n\r\nfunction TSortedDictionary.FindLeftMostNode: TNode;\r\nbegin\r\n { Start with root }\r\n Result := FRoot;\r\n\r\n { And go to maximum left }\r\n if Assigned(Result) then\r\n begin\r\n while Assigned(Result.FLeft) do\r\n Result := Result.FLeft;\r\n end;\r\nend;\r\n\r\nfunction TSortedDictionary.FindNodeWithKey(const AKey: TKey): TNode;\r\nvar\r\n LNode: TNode;\r\n LCompareResult: NativeInt;\r\nbegin\r\n { Get root }\r\n LNode := FRoot;\r\n\r\n while Assigned(LNode) do\r\n begin\r\n\t LCompareResult := CompareKeys(AKey, LNode.FKey) * FSignFix;\r\n\r\n { Navigate left, right or find! }\r\n if LCompareResult < 0 then\r\n LNode := LNode.FLeft\r\n else if LCompareResult > 0 then\r\n LNode := LNode.FRight\r\n else\r\n Exit(LNode);\r\n end;\r\n\r\n { Did not find anything ... }\r\n Result := nil;\r\nend;\r\n\r\nfunction TSortedDictionary.FindRightMostNode: TNode;\r\nbegin\r\n { Start with root }\r\n Result := FRoot;\r\n\r\n { And go to maximum left }\r\n if Assigned(Result) then\r\n begin\r\n while Assigned(Result.FRight) do\r\n Result := Result.FRight;\r\n end;\r\nend;\r\n\r\nfunction TSortedDictionary.GetCount: NativeInt;\r\nbegin\r\n Result := FCount;\r\nend;\r\n\r\nfunction TSortedDictionary.GetEnumerator: IEnumerator>;\r\nvar\r\n LEnumerator: TEnumerator;\r\nbegin\r\n LEnumerator := TEnumerator.Create(Self);\r\n LEnumerator.FCurrentEntry := FindLeftMostNode();\r\n Result := LEnumerator;\r\nend;\r\n\r\nfunction TSortedDictionary.Insert(const AKey: TKey; const AValue: TValue; const AChangeOrFail: Boolean): Boolean;\r\nvar\r\n LNode: TNode;\r\n LCompareResult: NativeInt;\r\nbegin\r\n { First one get special treatment! }\r\n if not Assigned(FRoot) then\r\n begin\r\n FRoot := MakeNode(AKey, AValue, nil);\r\n\r\n { Increase markers }\r\n Inc(FCount);\r\n NotifyCollectionChanged();\r\n\r\n { [ADDED NEW] Exit function }\r\n Exit(true);\r\n end;\r\n\r\n { Get root }\r\n LNode := FRoot;\r\n\r\n while true do\r\n begin\r\n\t LCompareResult := CompareKeys(AKey, LNode.FKey) * FSignFix;\r\n\r\n if LCompareResult < 0 then\r\n begin\r\n if Assigned(LNode.FLeft) then\r\n LNode := LNode.FLeft\r\n else\r\n begin\r\n { Create new node }\r\n LNode.FLeft := MakeNode(AKey, AValue, LNode);\r\n Dec(LNode.FBalance);\r\n\r\n { [ADDED NEW] Exit function! }\r\n break;\r\n end;\r\n end else if LCompareResult > 0 then\r\n begin\r\n if Assigned(LNode.FRight) then\r\n LNode := LNode.FRight\r\n else\r\n begin\r\n LNode.FRight := MakeNode(AKey, AValue, LNode);\r\n Inc(LNode.FBalance);\r\n\r\n { [ADDED NEW] Exit function! }\r\n break;\r\n end;\r\n end else\r\n begin\r\n { Found node with the same AKey. Check what to do next }\r\n if not AChangeOrFail then\r\n Exit(false);\r\n\r\n ReplaceValue(LNode.FValue, AValue);\r\n\r\n { Increase markers }\r\n NotifyCollectionChanged();\r\n\r\n { [CHANGED OLD] Exit function }\r\n Exit(true);\r\n end;\r\n end;\r\n\r\n { Rebalance the tree }\r\n ReBalanceSubTreeOnInsert(LNode);\r\n\r\n Inc(FCount);\r\n NotifyCollectionChanged();\r\n\r\n Result := true;\r\nend;\r\n\r\nfunction TSortedDictionary.MakeNode(const AKey: TKey; const AValue: TValue; const ARoot: TNode): TNode;\r\nbegin\r\n Result := TNode.Create();\r\n Result.FKey := AKey;\r\n Result.FValue := AValue;\r\n Result.FParent := ARoot;\r\nend;\r\n\r\nfunction TSortedDictionary.MaxKey: TKey;\r\nbegin\r\n { Check there are elements in the set }\r\n if not Assigned(FRoot) then\r\n ExceptionHelper.Throw_CollectionEmptyError();\r\n\r\n if FSignFix = 1 then\r\n Result := FindRightMostNode().FKey\r\n else\r\n Result := FindLeftMostNode().FKey;\r\nend;\r\n\r\nfunction TSortedDictionary.MinKey: TKey;\r\nbegin\r\n { Check there are elements in the set }\r\n if not Assigned(FRoot) then\r\n ExceptionHelper.Throw_CollectionEmptyError();\r\n\r\n if FSignFix = 1 then\r\n Result := FindLeftMostNode().FKey\r\n else\r\n Result := FindRightMostNode().FKey;\r\nend;\r\n\r\nprocedure TSortedDictionary.ReBalanceSubTreeOnInsert(const ANode: TNode);\r\nvar\r\n LLNode, LXNode, LWNode: TNode;\r\nbegin\r\n LLNode := ANode;\r\n\r\n { Re-balancing the tree! }\r\n while (LLNode.FBalance <> 0) and Assigned(LLNode.FParent) do\r\n begin\r\n if (LLNode.FParent.FLeft = LLNode) then\r\n Dec(LLNode.FParent.FBalance)\r\n else\r\n Inc(LLNode.FParent.FBalance);\r\n\r\n { Move up }\r\n LLNode := LLNode.FParent;\r\n\r\n if (LLNode.FBalance = -2) then\r\n begin\r\n LXNode := LLNode.FLeft;\r\n\r\n if (LXNode.FBalance = -1) then\r\n begin\r\n LXNode.FParent := LLNode.FParent;\r\n\r\n if not Assigned(LLNode.FParent) then\r\n FRoot := LXNode\r\n else\r\n begin\r\n if (LLNode.FParent.FLeft = LLNode) then\r\n LLNode.FParent.FLeft := LXNode\r\n else\r\n LLNode.FParent.FRight := LXNode;\r\n end;\r\n\r\n LLNode.FLeft := LXNode.FRight;\r\n\r\n if Assigned(LLNode.FLeft) then\r\n LLNode.FLeft.FParent := LLNode;\r\n\r\n LXNode.FRight := LLNode;\r\n LLNode.FParent := LXNode;\r\n\r\n LXNode.FBalance := 0;\r\n LLNode.FBalance := 0;\r\n end else\r\n begin\r\n LWNode := LXNode.FRight;\r\n LWNode.FParent := LLNode.FParent;\r\n\r\n if not Assigned(LLNode.FParent) then\r\n FRoot := LWNode\r\n else\r\n begin\r\n if LLNode.FParent.FLeft = LLNode then\r\n LLNode.FParent.FLeft := LWNode\r\n else\r\n LLNode.FParent.FRight := LWNode;\r\n end;\r\n\r\n LXNode.FRight := LWNode.FLeft;\r\n\r\n if Assigned(LXNode.FRight) then\r\n LXNode.FRight.FParent := LXNode;\r\n\r\n LLNode.FLeft := LWNode.FRight;\r\n\r\n if Assigned(LLNode.FLeft) then\r\n LLNode.FLeft.FParent := LLNode;\r\n\r\n LWNode.FLeft := LXNode;\r\n LWNode.FRight := LLNode;\r\n\r\n LXNode.FParent := LWNode;\r\n LLNode.FParent := LWNode;\r\n\r\n { Apply proper balancing }\r\n if LWNode.FBalance = -1 then\r\n begin\r\n LXNode.FBalance := 0;\r\n LLNode.FBalance := 1;\r\n end else if LWNode.FBalance = 0 then\r\n begin\r\n LXNode.FBalance := 0;\r\n LLNode.FBalance := 0;\r\n end else\r\n begin\r\n LXNode.FBalance := -1;\r\n LLNode.FBalance := 0;\r\n end;\r\n\r\n LWNode.FBalance := 0;\r\n end;\r\n\r\n break;\r\n end else if LLNode.FBalance = 2 then\r\n begin\r\n LXNode := LLNode.FRight;\r\n\r\n if LXNode.FBalance = 1 then\r\n begin\r\n LXNode.FParent := LLNode.FParent;\r\n\r\n if not Assigned(LLNode.FParent) then\r\n FRoot := LXNode\r\n else\r\n begin\r\n if LLNode.FParent.FLeft = LLNode then\r\n LLNode.FParent.FLeft := LXNode\r\n else\r\n LLNode.FParent.FRight := LXNode;\r\n end;\r\n\r\n LLNode.FRight := LXNode.FLeft;\r\n\r\n if Assigned(LLNode.FRight) then\r\n LLNode.FRight.FParent := LLNode;\r\n\r\n LXNode.FLeft := LLNode;\r\n LLNode.FParent := LXNode;\r\n\r\n LXNode.FBalance := 0;\r\n LLNode.FBalance := 0;\r\n end else\r\n begin\r\n LWNode := LXNode.FLeft;\r\n LWNode.FParent := LLNode.FParent;\r\n\r\n if not Assigned(LLNode.FParent) then\r\n FRoot := LWNode\r\n else\r\n begin\r\n if LLNode.FParent.FLeft = LLNode then\r\n LLNode.FParent.FLeft := LWNode\r\n else\r\n LLNode.FParent.FRight := LWNode;\r\n end;\r\n\r\n LXNode.FLeft := LWNode.FRight;\r\n\r\n if Assigned(LXNode.FLeft) then\r\n LXNode.FLeft.FParent := LXNode;\r\n\r\n LLNode.FRight := LWNode.FLeft;\r\n\r\n if Assigned(LLNode.FRight) then\r\n LLNode.FRight.FParent := LLNode;\r\n\r\n LWNode.FRight := LXNode;\r\n LWNode.FLeft := LLNode;\r\n\r\n LXNode.FParent := LWNode;\r\n LLNode.FParent := LWNode;\r\n\r\n if LWNode.FBalance = 1 then\r\n begin\r\n LXNode.FBalance := 0;\r\n LLNode.FBalance := -1;\r\n end else if LWNode.FBalance = 0 then\r\n begin\r\n LXNode.FBalance := 0;\r\n LLNode.FBalance := 0;\r\n end else\r\n begin\r\n LXNode.FBalance := 1;\r\n LLNode.FBalance := 0;\r\n end;\r\n\r\n LWNode.FBalance := 0;\r\n end;\r\n\r\n break;\r\n end;\r\n end;\r\n\r\nend;\r\n\r\nprocedure TSortedDictionary.RecursiveClear(const ANode: TNode);\r\nbegin\r\n if Assigned(ANode.FLeft) then\r\n RecursiveClear(ANode.FLeft);\r\n\r\n if Assigned(ANode.FRight) then\r\n RecursiveClear(ANode.FRight);\r\n\r\n { Cleanup for AKey/Value }\r\n NotifyKeyRemoved(ANode.FKey);\r\n NotifyValueRemoved(ANode.FValue);\r\n\r\n { Finally, free the node itself }\r\n ANode.Free;\r\nend;\r\n\r\nprocedure TSortedDictionary.SetValue(const AKey: TKey; const Value: TValue);\r\nbegin\r\n { Allow inserting and adding values }\r\n Insert(AKey, Value, true);\r\nend;\r\n\r\nfunction TSortedDictionary.TryExtract(const AKey: TKey; out AValue: TValue): Boolean;\r\nvar\r\n LNode: TNode;\r\nbegin\r\n Result := False;\r\n\r\n { Get root }\r\n LNode := FindNodeWithKey(AKey);\r\n if not Assigned(LNode) then\r\n Exit;\r\n\r\n BalanceTreesAfterRemoval(LNode);\r\n\r\n AValue := LNode.FValue;\r\n LNode.Free;\r\n\r\n Result := True;\r\n Dec(FCount);\r\n NotifyCollectionChanged();\r\nend;\r\n\r\nfunction TSortedDictionary.TryGetValue(const AKey: TKey; out AFoundValue: TValue): Boolean;\r\nvar\r\n LResultNode: TNode;\r\nbegin\r\n LResultNode := FindNodeWithKey(AKey);\r\n\r\n if Assigned(LResultNode) then\r\n begin\r\n AFoundValue := LResultNode.FValue;\r\n Exit(true);\r\n end;\r\n\r\n { Default }\r\n AFoundValue := default(TValue);\r\n Exit(false);\r\nend;\r\n\r\nfunction TSortedDictionary.WalkToTheRight(const ANode: TNode): TNode;\r\nbegin\r\n Result := ANode;\r\n\r\n if not Assigned(Result) then\r\n Exit;\r\n\r\n { Navigate further in the tree }\r\n if not Assigned(Result.FRight) then\r\n begin\r\n while (Assigned(Result.FParent) and (Result = Result.FParent.FRight)) do\r\n Result := Result.FParent;\r\n\r\n Result := Result.FParent;\r\n end else\r\n begin\r\n Result := Result.FRight;\r\n\r\n while Assigned(Result.FLeft) do\r\n Result := Result.FLeft;\r\n end;\r\nend;\r\n\r\n{ TSortedDictionary.TEnumerator }\r\n\r\nfunction TSortedDictionary.TEnumerator.TryMoveNext(out ACurrent: TPair): Boolean;\r\nbegin\r\n Result := Assigned(FCurrentEntry);\r\n\r\n if Result then\r\n begin\r\n ACurrent.Key := FCurrentEntry.FKey;\r\n ACurrent.Value := FCurrentEntry.FValue;\r\n\r\n FCurrentEntry := TSortedDictionary(Owner).WalkToTheRight(FCurrentEntry);\r\n end;\r\nend;\r\n{ TObjectSortedDictionary }\r\n\r\nprocedure TObjectSortedDictionary.HandleKeyRemoved(const AKey: TKey);\r\nbegin\r\n if FOwnsKeys then\r\n PObject(@AKey)^.Free;\r\nend;\r\n\r\nprocedure TObjectSortedDictionary.HandleValueRemoved(const AValue: TValue);\r\nbegin\r\n if FOwnsValues then\r\n PObject(@AValue)^.Free;\r\nend;\r\n\r\nprocedure TObjectSortedDictionary.ReplaceValue(var ACurrent: TValue; const ANew: TValue);\r\nbegin\r\n { Only act if owns objects is set. Otherwise fallback to default. }\r\n if (FOwnsValues) and (PObject(@ACurrent)^ <> PObject(@ANew)^) then\r\n begin\r\n NotifyValueRemoved(ACurrent);\r\n ACurrent := ANew;\r\n end else\r\n inherited;\r\nend;\r\n\r\n{ TPointerDictionary }\r\n\r\nprocedure TPointerDictionary.HandleKeyRemoved(const AKey: TKey);\r\nbegin\r\n if FOwnsKeys then\r\n FreeMemory(PPointer(@AKey)^);\r\nend;\r\n\r\nprocedure TPointerDictionary.HandleValueRemoved(\r\n const AValue: TValue);\r\nbegin\r\n if FOwnsValues then\r\n FreeMemory(PPointer(@AValue)^);\r\nend;\r\n\r\nprocedure TPointerDictionary.ReplaceValue(var ACurrent: TValue; const ANew: TValue);\r\nbegin\r\n if (FOwnsValues) and (PPointer(@ACurrent)^ <> PPointer(@ANew)^) then\r\n begin\r\n NotifyValueRemoved(ACurrent);\r\n ACurrent := ANew;\r\n end else\r\n inherited;\r\nend;\r\n\r\nend.\r\n" }, { "path": "Collections/Collections.Dynamic.pas", "content": "(*\r\n* Copyright (c) 2011-2012, Ciobanu Alexandru\r\n* All rights reserved.\r\n*\r\n* Redistribution and use in source and binary forms, with or without\r\n* modification, are permitted provided that the following conditions are met:\r\n* * Redistributions of source code must retain the above copyright\r\n* notice, this list of conditions and the following disclaimer.\r\n* * Redistributions in binary form must reproduce the above copyright\r\n* notice, this list of conditions and the following disclaimer in the\r\n* documentation and/or other materials provided with the distribution.\r\n* * Neither the name of the nor the\r\n* names of its contributors may be used to endorse or promote products\r\n* derived from this software without specific prior written permission.\r\n*\r\n* THIS SOFTWARE IS PROVIDED BY THE AUTHOR ''AS IS'' AND ANY\r\n* EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED\r\n* WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE\r\n* DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY\r\n* DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES\r\n* (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;\r\n* LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND\r\n* ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT\r\n* (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS\r\n* SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.\r\n*)\r\n\r\nunit Collections.Dynamic;\r\ninterface\r\n{$IF CompilerVersion > 21}\r\nuses\r\n SysUtils,\r\n Generics.Collections,\r\n Rtti,\r\n TypInfo;\r\n\r\ntype\r\n /// Alias for the Rtti TValue type. The compiler seems to have a hard\r\n /// time differentiating TValue from the generic TValue type argument.\r\n TAny = TValue;\r\n\r\n /// An alias to the Variant type. Its main purpose is to serve as a reminder that\r\n /// it contains a part of an object. It is to be considered a \"dynamic record\".\r\n TView = Variant;\r\n\r\n /// A special purpose record type that exposes a number of methods that generate\r\n /// selector methods for fields and properties of a class or record type.\r\n Member = record\r\n private class var\r\n FViewVariantType: Word;\r\n\r\n private type\r\n {$REGION 'Internal Types'}\r\n TViewPair = TPair;\r\n TViewArray = TArray;\r\n\r\n TSelector = class(TInterfacedObject, TFunc, TFunc)\r\n private\r\n FContext: TRttiContext;\r\n FType: TRttiType;\r\n FMember: TRttiMember;\r\n\r\n protected\r\n function TFunc.Invoke = GenericInvoke;\r\n function TFunc.Invoke = TValueInvoke;\r\n\r\n public\r\n function TValueInvoke(AFrom: T): TValue; virtual; abstract;\r\n function GenericInvoke(AFrom: T): K;\r\n end;\r\n\r\n TRecordFieldSelector = class(TSelector)\r\n public\r\n function TValueInvoke(AFrom: Pointer): TValue; override;\r\n end;\r\n\r\n TClassFieldSelector = class(TSelector)\r\n public\r\n function TValueInvoke(AFrom: TObject): TValue; override;\r\n end;\r\n\r\n TClassPropertySelector = class(TSelector)\r\n public\r\n function TValueInvoke(AFrom: TObject): TValue; override;\r\n end;\r\n\r\n TViewSelector = class(TInterfacedObject, TFunc)\r\n private\r\n FNames: TArray;\r\n FFuncs: TArray>;\r\n public\r\n function Invoke(AFrom: T): TView;\r\n end;\r\n\r\n {$ENDREGION}\r\n\r\n public\r\n /// Generates a selector for a given member name.\r\n /// The field or property name to select from T.\r\n /// A selector function that retrieves the field/property from a class or record.\r\n /// nil is returned in case of error.\r\n class function Name(const AName: string): TFunc; overload; static;\r\n\r\n /// Generates a selector for a given member name.\r\n /// The field or property name to select from T.\r\n /// A selector function that retrieves the field/property from a class or record. The selected value is a TValue type.\r\n /// nil is returned in case of error.\r\n class function Name(const AName: string): TFunc; overload; static;\r\n\r\n /// Generates a selector for the given member names.\r\n /// The field or property names to select from T.\r\n /// A selector function that retrieves the fields/properties from a class or record. The selected value is a TView type.\r\n /// nil is returned in case of error.\r\n class function Name(const ANames: array of string): TFunc; overload; static;\r\n end;\r\n\r\nimplementation\r\nuses\r\n Variants;\r\n\r\ntype\r\n { Mapping the TSVDictionary into TVarData structure }\r\n TViewDictionaryVarData = packed record\r\n { Var type; will be assigned at run time }\r\n VType: TVarType;\r\n { Reserved stuff }\r\n Reserved1, Reserved2, Reserved3: Word;\r\n { A reference to the enclosed dictionary }\r\n FArray: Member.TViewArray;\r\n { Reserved stuff }\r\n Reserved4: LongWord;\r\n{$IFDEF CPUX64}\r\n Reserved4_1: LongWord;\r\n{$ENDIF}\r\n end;\r\n\r\n { Manager for our variant type }\r\n TViewDictionaryVariantType = class(TInvokeableVariantType)\r\n public\r\n procedure Clear(var V: TVarData); override;\r\n procedure Copy(var Dest: TVarData; const Source: TVarData; const Indirect: Boolean); override;\r\n function GetProperty(var Dest: TVarData; const V: TVarData; const Name: string): Boolean; override;\r\n end;\r\n\r\n{ TViewDictionaryVariantType }\r\n\r\nprocedure TViewDictionaryVariantType.Clear(var V: TVarData);\r\nbegin\r\n { Clear the variant type }\r\n V.VType := varEmpty;\r\n\r\n { And dispose the value }\r\n TViewDictionaryVarData(V).FArray := nil;\r\nend;\r\n\r\nprocedure TViewDictionaryVariantType.Copy(var Dest: TVarData;\r\n const Source: TVarData; const Indirect: Boolean);\r\nbegin\r\n if Indirect and VarDataIsByRef(Source) then\r\n VarDataCopyNoInd(Dest, Source)\r\n else\r\n begin\r\n with TViewDictionaryVarData(Dest) do\r\n begin\r\n { Copy the variant type }\r\n VType := VarType;\r\n\r\n { Copy the reference }\r\n FArray := TViewDictionaryVarData(Source).FArray;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TViewDictionaryVariantType.GetProperty(var Dest: TVarData; const V: TVarData; const Name: string): Boolean;\r\nvar\r\n LPair: Member.TViewPair;\r\n LAsVar: Variant;\r\nbegin\r\n { Iterate over our internal array and search for the requested property by name }\r\n with TViewDictionaryVarData(V) do\r\n begin\r\n for LPair in FArray do\r\n if AnsiSameStr(LPair.Key, Name) then\r\n begin\r\n LAsVar := LPair.Value.AsVariant;\r\n Dest := TVarData(LAsVar);\r\n\r\n Exit(True);\r\n end;\r\n end;\r\n\r\n { Key not found, means error }\r\n Clear(Dest);\r\n Result := False;\r\nend;\r\n\r\nvar\r\n { Our singleton that manages our variant type }\r\n FViewDictionaryVariantType: TViewDictionaryVariantType;\r\n\r\n{ Member.TSelector }\r\n\r\nfunction Member.TSelector.GenericInvoke(AFrom: T): K;\r\nvar\r\n LValue: TValue;\r\nbegin\r\n LValue := TValueInvoke(AFrom);\r\n Result := LValue.AsType();\r\nend;\r\n\r\n{ Member.TRecordFieldSelector }\r\n\r\nfunction Member.TRecordFieldSelector.TValueInvoke(AFrom: Pointer): TValue;\r\nbegin\r\n ASSERT(Assigned(FMember));\r\n ASSERT(FMember is TRttiField);\r\n\r\n Result := TRttiField(FMember).GetValue(AFrom);\r\nend;\r\n\r\n{ Member.TClassFieldSelector }\r\n\r\nfunction Member.TClassFieldSelector.TValueInvoke(AFrom: TObject): TValue;\r\nbegin\r\n ASSERT(Assigned(FMember));\r\n ASSERT(FMember is TRttiField);\r\n\r\n Result := TRttiField(FMember).GetValue(AFrom);\r\nend;\r\n\r\n{ Member.TClassPropertySelector }\r\n\r\nfunction Member.TClassPropertySelector.TValueInvoke(AFrom: TObject): TValue;\r\nbegin\r\n ASSERT(Assigned(FMember));\r\n ASSERT(FMember is TRttiProperty);\r\n\r\n Result := TRttiProperty(FMember).GetValue(AFrom);\r\nend;\r\n\r\n{ Member.TViewSelector }\r\n\r\nfunction Member.TViewSelector.Invoke(AFrom: T): TView;\r\nvar\r\n I, L: NativeInt;\r\n LCalc: TViewArray;\r\nbegin\r\n { Initialize a view }\r\n VarClear(Result);\r\n\r\n L := Length(FFuncs);\r\n SetLength(LCalc, L);\r\n\r\n { Copy selected fields over }\r\n for I := 0 to Length(FFuncs) - 1 do\r\n begin\r\n LCalc[I].Key := FNames[I];\r\n LCalc[I].Value := FFuncs[I](AFrom);\r\n end;\r\n\r\n { Give the result to the guy standing on the chair ... }\r\n with TVarData(Result) do\r\n begin\r\n VType := Member.FViewVariantType;\r\n Member.TViewArray(VPointer) := LCalc;\r\n end;\r\nend;\r\n\r\n{ Member }\r\n\r\nclass function Member.Name(const AName: string): TFunc;\r\nvar\r\n LT, LK: PTypeInfo;\r\n LContext: TRttiContext;\r\n LType: TRttiType;\r\n LMember: TRttiMember;\r\n LSelector: TSelector;\r\nbegin\r\n Result := nil;\r\n\r\n { Get the type }\r\n LT := TypeInfo(T);\r\n LK := TypeInfo(K);\r\n\r\n LType := LContext.GetType(LT);\r\n\r\n { Check for correctness }\r\n if not Assigned(LType) or not (LType.TypeKind in [tkClass, tkRecord]) then\r\n Exit;\r\n\r\n if LType.TypeKind = tkRecord then\r\n begin\r\n LMember := LType.GetField(AName);\r\n\r\n if not Assigned(LMember) then\r\n Exit;\r\n\r\n LSelector := TSelector(TRecordFieldSelector.Create());\r\n end else\r\n if LType.TypeKind = tkClass then\r\n begin\r\n LMember := LType.GetField(AName);\r\n\r\n if Assigned(LMember) then\r\n LSelector := TSelector(TClassFieldSelector.Create())\r\n else begin\r\n LMember := LType.GetProperty(AName);\r\n\r\n if not Assigned(LMember) then\r\n Exit;\r\n\r\n LSelector := TSelector(TClassPropertySelector.Create());\r\n end;\r\n end;\r\n\r\n { Upload selector }\r\n LSelector.FContext := LContext;\r\n LSelector.FType := LType;\r\n LSelector.FMember := LMember;\r\n\r\n Result := LSelector;\r\nend;\r\n\r\nclass function Member.Name(const AName: string): TFunc;\r\nbegin\r\n Result := Member.Name(AName);\r\nend;\r\n\r\nclass function Member.Name(const ANames: array of string): TFunc;\r\nvar\r\n LSelector: TViewSelector;\r\n I, L: NativeInt;\r\nbegin\r\n Result := nil;\r\n L := Length(ANames);\r\n\r\n if L = 0 then\r\n Exit;\r\n\r\n LSelector := TViewSelector.Create;\r\n\r\n { Prepare the array of selectors }\r\n SetLength(LSelector.FNames, L);\r\n SetLength(LSelector.FFuncs, L);\r\n\r\n { Create the array }\r\n for I := 0 to L - 1 do\r\n begin\r\n LSelector.FNames[I] := AnsiUpperCase(ANames[I]);\r\n LSelector.FFuncs[I] := Member.Name(ANames[I]);\r\n\r\n if not Assigned(LSelector.FFuncs[I]) then\r\n begin\r\n LSelector.Free;\r\n Exit;\r\n end;\r\n end;\r\n\r\n Result := LSelector;\r\nend;\r\n\r\ninitialization\r\n { Register our custom variant type }\r\n FViewDictionaryVariantType := TViewDictionaryVariantType.Create();\r\n Member.FViewVariantType := FViewDictionaryVariantType.VarType;\r\n\r\nfinalization\r\n { Uregister our custom variant }\r\n FreeAndNil(FViewDictionaryVariantType);\r\n{$ELSE}\r\nimplementation\r\n{$IFEND}\r\nend.\r\n" }, { "path": "Collections/Collections.Lists.pas", "content": "(*\r\n* Copyright (c) 2008-2012, Ciobanu Alexandru\r\n* All rights reserved.\r\n*\r\n* Redistribution and use in source and binary forms, with or without\r\n* modification, are permitted provided that the following conditions are met:\r\n* * Redistributions of source code must retain the above copyright\r\n* notice, this list of conditions and the following disclaimer.\r\n* * Redistributions in binary form must reproduce the above copyright\r\n* notice, this list of conditions and the following disclaimer in the\r\n* documentation and/or other materials provided with the distribution.\r\n* * Neither the name of the nor the\r\n* names of its contributors may be used to endorse or promote products\r\n* derived from this software without specific prior written permission.\r\n*\r\n* THIS SOFTWARE IS PROVIDED BY THE AUTHOR ''AS IS'' AND ANY\r\n* EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED\r\n* WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE\r\n* DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY\r\n* DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES\r\n* (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;\r\n* LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND\r\n* ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT\r\n* (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS\r\n* SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.\r\n*)\r\n\r\n{$DEFINE OPTIMIZED_SORT}\r\nunit Collections.Lists;\r\ninterface\r\nuses SysUtils,\r\n Generics.Defaults,\r\n Collections.Serialization,\r\n Collections.Base;\r\n\r\ntype\r\n /// The abstract base class for all generic list collections.\r\n /// Descending classes must implement the required abstract methods and optionally can implement\r\n /// the non-required method.\r\n TAbstractList = class(TCollection, IList)\r\n protected\r\n /// Returns the item at a given index.\r\n /// The index in the list.\r\n /// The element at the specified position.\r\n /// is out of bounds.\r\n function GetItem(const AIndex: NativeInt): T;\r\n\r\n /// Sets the item at a given index.\r\n /// The index in the list.\r\n /// The new value.\r\n /// In the current implementation this method always raises an exception.\r\n /// is out of bounds.\r\n /// Always raised in this implementation.\r\n procedure SetItem(const AIndex: NativeInt; const AValue: T); virtual;\r\n\r\n /// Replaces a given item with a new one.\r\n /// The item to be replaced.\r\n /// The item to be replaced with.\r\n /// This method is called by the list when an item at a specified index needs to be replaced with another.\r\n /// The default implementation will compare the values, if those are equal nothing is done. Otherwise the old item is\r\n /// \"disposed of\" and the new one is copied over. Descendant classes my want another behaviour.\r\n procedure ReplaceItem(var ACurrent: T; const ANew: T); virtual;\r\n\r\n /// Extracts the element from the specified index.\r\n /// The index to stract from.\r\n /// The value stored at that index.\r\n /// True if the value was found and stored in parameter; False otherwise.\r\n /// Descending classes must implement this method in order to support both RemoveAt and ExtractAt methods. In the current implementation\r\n /// this method always raises an exception.\r\n /// Always raised in this implementation.\r\n function TryExtractAt(const AIndex: NativeInt; out AValue: T): Boolean; virtual;\r\n\r\n /// Returns the item at a given index.\r\n /// The index in the list.\r\n /// The value stored at that index.\r\n /// True if the value was found and stored in parameter; False otherwise.\r\n /// The current implementation iterates over all elements until the element at the specified index is reached.\r\n function TryGetItemAt(const AIndex: NativeInt; out AValue: T): Boolean; virtual;\r\n public\r\n /// Creates a new list collection.\r\n /// A rule set describing the elements in the list.\r\n constructor Create(const ARules: TRules);\r\n\r\n /// Appends an element to the back of the list.\r\n /// The value to append.\r\n /// If Insert method is not overridden.\r\n procedure Add(const AValue: T); override;\r\n\r\n /// Appends all elements from a given collection to the back of a list.\r\n /// The values to append.\r\n /// is nil.\r\n /// If Insert method is not overridden.\r\n procedure AddAll(const ACollection: IEnumerable); override;\r\n\r\n /// Inserts an element into the list.\r\n /// The index to insert to.\r\n /// The value to insert.\r\n /// All elements starting with are moved to the right by one and then\r\n /// is placed at position .\r\n /// is out of bounds.\r\n /// Always raised in this implementation.\r\n procedure Insert(const AIndex: NativeInt; const AValue: T); virtual;\r\n\r\n /// Inserts the elements of a collection into the list.\r\n /// The index to insert to.\r\n /// The values to insert.\r\n /// All elements starting with are moved to the right by the length of\r\n /// and then is placed at position .\r\n /// is out of bounds.\r\n /// is nil.\r\n /// If one element based Insert method is not overridden.\r\n procedure InsertAll(const AIndex: NativeInt; const ACollection: IEnumerable); virtual;\r\n\r\n /// Removes a given value from the list.\r\n /// The value to remove.\r\n /// If the list does not contain the given value, nothing happens.\r\n /// If TryExtractAt method is not overridden.\r\n procedure Remove(const AValue: T); override;\r\n\r\n /// Removes an element from the list at a given index.\r\n /// The index from which to remove the element.\r\n /// This method removes the specified element and moves all following elements to the left by one.\r\n /// is out of bounds.\r\n /// If one element based TryExtractAt method is not overridden.\r\n procedure RemoveAt(const AIndex: NativeInt);\r\n\r\n /// Extracts an element from the list at a given index.\r\n /// The index from which to extract the element.\r\n /// This method removes the specified element and moves all following elements to the left by one.\r\n /// The removed element is returned to the caller.\r\n /// is out of bounds.\r\n /// If TryExtractAt method is not overridden.\r\n function ExtractAt(const AIndex: NativeInt): T;\r\n\r\n /// Checks whether the list contains a given value.\r\n /// The value to check.\r\n /// True if the value was found in the list; False otherwise.\r\n /// The implementation in this class iterates over all elements and checks for the requested\r\n /// value. Most descendant classes will most likely provide a better version.\r\n /// If IndexOf method is not overridden.\r\n function Contains(const AValue: T): Boolean; override;\r\n\r\n /// Searches for the first appearance of a given element in this list.\r\n /// The value to search for.\r\n /// -1 if the value was not found; otherwise a positive value indicating the index of the value.\r\n function IndexOf(const AValue: T): NativeInt; virtual;\r\n\r\n /// Searches for the last appearance of a given element in this list.\r\n /// The value to search for.\r\n /// -1 if the value was not found; otherwise a positive value indicating the index of the value.\r\n /// If LastIndexOf method is not overridden.\r\n function LastIndexOf(const AValue: T): NativeInt; virtual;\r\n\r\n /// Returns the item at a given index.\r\n /// The index in the collection.\r\n /// The element at the specified position.\r\n /// is out of bounds.\r\n property Items[const AIndex: NativeInt]: T read GetItem write SetItem; default;\r\n\r\n /// Returns the element at a given position.\r\n /// The index from which to return the element.\r\n /// The element at the specified position.\r\n /// In the current implementation this method uses TryGetItemAt.\r\n /// The list is empty.\r\n /// is out of bounds.\r\n function ElementAt(const AIndex: NativeInt): T; override;\r\n\r\n /// Returns the element at a given position.\r\n /// The index from which to return the element.\r\n /// The default value returned if the list is empty.\r\n /// In the current implementation this method uses TryGetItemAt.\r\n /// The element at the specified position if the list is not empty and the position is not out of bounds; otherwise\r\n /// the value of is returned.\r\n function ElementAtOrDefault(const AIndex: NativeInt; const ADefault: T): T; override;\r\n end;\r\n\r\n /// The abstract base class for all generic linked list collections.\r\n /// Descending classes must implement the required abstract methods and optionally can implement\r\n /// the non-required method.\r\n TAbstractLinkedList = class(TAbstractList, ILinkedList, IQueue, IStack)\r\n protected\r\n procedure IStack.Push = AddLast;\r\n function IStack.Pop = ExtractLast;\r\n function IStack.Peek = Last;\r\n procedure IQueue.Enqueue = AddLast;\r\n function IQueue.Dequeue = ExtractFirst;\r\n function IQueue.Peek = First;\r\n public\r\n /// Appends an element to the back of list.\r\n /// The value to append.\r\n /// This method is functionally identical to Add. Classes that implement this interface can simply\r\n /// alias this method to Add.\r\n /// If Insert method is not overridden.\r\n procedure AddLast(const AValue: T); virtual;\r\n\r\n /// Appends the elements from a collection to the back of the list.\r\n /// The values to append.\r\n /// This method is functionally identical to Add. Classes that implement this interface can simply\r\n /// alias this method to Add.\r\n /// is nil.\r\n /// If Insert method is not overridden.\r\n procedure AddAllLast(const ACollection: IEnumerable); virtual;\r\n\r\n /// Appends an element to the front of the list.\r\n /// The value to append.\r\n /// If Insert method is not overridden.\r\n procedure AddFirst(const AValue: T); virtual;\r\n\r\n /// Appends the elements from a collection to the back of the list.\r\n /// The values to append.\r\n /// is nil.\r\n /// If Insert method is not overridden.\r\n procedure AddAllFirst(const ACollection: IEnumerable); virtual;\r\n\r\n /// Removes the first element of the list.\r\n /// The list is empty.\r\n /// If TryExtractAt method is not overridden.\r\n procedure RemoveFirst(); virtual;\r\n\r\n /// Removes the last element of the list.\r\n /// The list is empty.\r\n /// If TryExtractAt method is not overridden.\r\n procedure RemoveLast(); virtual;\r\n\r\n /// Extracts the first element of the list.\r\n /// The first element of the list.\r\n /// The list is empty.\r\n /// If TryExtractAt method is not overridden.\r\n function ExtractFirst(): T; virtual;\r\n\r\n /// Removes the last element of the list.\r\n /// The last element of the list.\r\n /// The list is empty.\r\n /// If TryExtractAt method is not overridden.\r\n function ExtractLast(): T; virtual;\r\n end;\r\n\r\ntype\r\n /// The generic list collection.\r\n /// This type uses an internal array to store its values.\r\n TList = class(TAbstractList, IDynamic, ISerializable)\r\n private type\r\n {$REGION 'Internal Types'}\r\n{$IFDEF OPTIMIZED_SORT}\r\n { Stack entry }\r\n TStackEntry = record\r\n First, Last: NativeInt;\r\n end;\r\n\r\n { Required for the non-recursive QSort }\r\n TQuickSortStack = array[0..63] of TStackEntry;\r\n{$ENDIF}\r\n\r\n TEnumerator = class(TAbstractEnumerator)\r\n private\r\n FCurrentIndex: NativeInt;\r\n public\r\n function TryMoveNext(out ACurrent: T): Boolean; override;\r\n end;\r\n {$ENDREGION}\r\n\r\n private var\r\n FArray: TArray;\r\n FLength: NativeInt;\r\n\r\n {$HINTS OFF}\r\n procedure QuickSort(ALeft, ARight: NativeInt; const ASortProc: TComparison); overload;\r\n procedure QuickSort(ALeft, ARight: NativeInt; const AAscending: Boolean); overload;\r\n {$HINTS ON}\r\n\r\n protected\r\n /// Serializes the contents of this class to a given context.\r\n /// The output context where data is written.\r\n /// Override in descending classes to provide more serialization data.\r\n procedure Serialize(const AContext: TOutputContext); virtual;\r\n\r\n /// Deserializes the contents of this class from a given context.\r\n /// The input context from which the data is read.\r\n /// Override in descending classes to obtain more deserialization data.\r\n procedure Deserialize(const AContext: TInputContext); virtual;\r\n\r\n /// Sets the item at a given index.\r\n /// The index in the list.\r\n /// The new value.\r\n /// is out of bounds.\r\n procedure SetItem(const AIndex: NativeInt; const AValue: T); override;\r\n\r\n /// Returns the number of elements in the list.\r\n /// A positive value specifying the number of elements in the list.\r\n function GetCount(): NativeInt; override;\r\n\r\n /// Returns the current capacity.\r\n /// A positive number that specifies the number of elements that the list can hold before it\r\n /// needs to grow again.\r\n /// The value of this method is greater than or equal to the amount of elements in the list. If this value\r\n /// is greater than the number of elements, it means that the list has some extra capacity to operate upon.\r\n function GetCapacity(): NativeInt;\r\n\r\n /// Extracts the element from the specified index.\r\n /// The index to stract from.\r\n /// The value stored at that index.\r\n /// True if the value was found and stored in parameter; False otherwise.\r\n function TryExtractAt(const AIndex: NativeInt; out AValue: T): Boolean; override;\r\n\r\n /// Returns the item at a given index.\r\n /// The index in the list.\r\n /// The value stored at that index.\r\n /// True if the value was found and stored in parameter; False otherwise.\r\n function TryGetItemAt(const AIndex: NativeInt; out AValue: T): Boolean; override;\r\n public\r\n /// Creates a new list collection.\r\n /// This constructor requests the default rule set. Call the overloaded constructor if\r\n /// specific a set of rules need to be passed.\r\n constructor Create(); overload;\r\n\r\n /// Creates a new list collection.\r\n /// A rule set describing the elements in the list.\r\n constructor Create(const ARules: TRules); overload;\r\n\r\n /// Creates a new list collection.\r\n /// The set's initial capacity.\r\n /// A rule set describing the elements in the list.\r\n constructor Create(const ARules: TRules; const AInitialCapacity: NativeInt); overload;\r\n\r\n /// Clears the contents of the list.\r\n procedure Clear(); override;\r\n\r\n /// Inserts an element into the list.\r\n /// The index to insert to.\r\n /// The value to insert.\r\n /// All elements starting with are moved to the right by one and then\r\n /// is placed at position .\r\n /// is out of bounds.\r\n procedure Insert(const AIndex: NativeInt; const AValue: T); override;\r\n\r\n /// Inserts the elements of a collection into the list.\r\n /// The index to insert to.\r\n /// The values to insert.\r\n /// All elements starting with are moved to the right by the length of\r\n /// and then is placed at position .\r\n /// is out of bounds.\r\n /// is nil.\r\n procedure InsertAll(const AIndex: NativeInt; const ACollection: IEnumerable); override;\r\n\r\n /// Reverses the elements in this list.\r\n /// The start index.\r\n /// The count of elements.\r\n /// This method reverses number of elements in\r\n /// the list, starting with the element.\r\n /// Parameter combination is incorrect.\r\n procedure Reverse(const AStartIndex, ACount: NativeInt); overload;\r\n\r\n /// Reverses the elements in this list.\r\n /// The start index.\r\n /// This method reverses all elements in the list, starting with the element.\r\n /// is out of bounds.\r\n procedure Reverse(const AStartIndex: NativeInt); overload;\r\n\r\n /// Reverses the elements in this list.\r\n procedure Reverse(); overload;\r\n\r\n /// Sorts the contents of this list.\r\n /// The start index.\r\n /// The count of elements.\r\n /// Specifies whether ascending or descending sorting is performed. The default is True.\r\n /// This method sorts number of elements in\r\n /// the list, starting with the element.\r\n /// Parameter combination is incorrect.\r\n procedure Sort(const AStartIndex, ACount: NativeInt; const AAscending: Boolean = true); overload;\r\n\r\n /// Sorts the contents of this list.\r\n /// The start index.\r\n /// Specifies whether ascending or descending sorting is performed. The default is True.\r\n /// This method sorts all elements in the list, starting with the element.\r\n /// is out of bounds.\r\n procedure Sort(const AStartIndex: NativeInt; const AAscending: Boolean = true); overload;\r\n\r\n /// Sorts the contents of this list.\r\n /// Specifies whether ascending or descending sorting is performed. The default is True.\r\n procedure Sort(const AAscending: Boolean = true); overload;\r\n\r\n /// Sorts the contents of this list using a given comparison method.\r\n /// The start index.\r\n /// The count of elements.\r\n /// The method used to compare elements.\r\n /// This method sorts number of elements in\r\n /// the list, starting with the element.\r\n /// Parameter combination is incorrect.\r\n /// is nil.\r\n procedure Sort(const AStartIndex, ACount: NativeInt; const ASortProc: TComparison); overload;\r\n\r\n /// Sorts the contents of this list using a given comparison method.\r\n /// The start index.\r\n /// The method used to compare elements.\r\n /// This method sorts all elements in the list, starting with the element.\r\n /// Parameter combination is incorrect.\r\n /// is nil.\r\n procedure Sort(const AStartIndex: NativeInt; const ASortProc: TComparison); overload;\r\n\r\n /// Sorts the contents of this list using a given comparison method.\r\n /// The method used to compare elements.\r\n /// Parameter combination is incorrect.\r\n /// is nil.\r\n procedure Sort(const ASortProc: TComparison); overload;\r\n\r\n /// Searches for the first appearance of a given element in this list.\r\n /// The value to search for.\r\n /// -1 if the value was not found; otherwise a positive value indicating the index of the value.\r\n /// Parameter combination is incorrect.\r\n function IndexOf(const AValue: T): NativeInt; override;\r\n\r\n /// Searches for the last appearance of a given element in this list.\r\n /// The value to search for.\r\n /// -1 if the value was not found; otherwise a positive value indicating the index of the value.\r\n /// Parameter combination is incorrect.\r\n function LastIndexOf(const AValue: T): NativeInt; override;\r\n\r\n /// Specifies the number of elements in the list.\r\n /// A positive value specifying the number of elements in the list.\r\n property Count: NativeInt read FLength;\r\n\r\n /// Specifies the current capacity.\r\n /// A positive number that specifies the number of elements that the list can hold before it\r\n /// needs to grow again.\r\n /// The value of this property is greater than or equal to the amount of elements in the list. If this value\r\n /// if greater than the number of elements, it means that the list has some extra capacity to operate upon.\r\n property Capacity: NativeInt read GetCapacity;\r\n\r\n /// Returns a new enumerator object used to enumerate this list.\r\n /// This method is usually called by compiler-generated code. Its purpose is to create an enumerator\r\n /// object that is used to actually traverse the list.\r\n /// An enumerator object.\r\n function GetEnumerator(): IEnumerator; override;\r\n\r\n /// Removes the excess capacity from the list.\r\n /// This method can be called manually to force the list to drop the extra capacity it might hold. For example,\r\n /// after performing some massive operations on a big list, call this method to ensure that all extra memory held by the\r\n /// list is released.\r\n procedure Shrink();\r\n\r\n /// Forces the list to increase its capacity.\r\n /// Call this method to force the list to increase its capacity ahead of time. Manually adjusting the capacity\r\n /// can be useful in certain situations.\r\n procedure Grow();\r\n\r\n /// Copies the values stored in the list to a given array.\r\n /// An array where to copy the contents of the list.\r\n /// The index into the array at which the copying begins.\r\n /// This method assumes that has enough space to hold the contents of the list.\r\n /// is out of bounds.\r\n /// The array is not long enough.\r\n procedure CopyTo(var AArray: array of T; const AStartIndex: NativeInt); overload; override;\r\n\r\n /// Checks whether the list is empty.\r\n /// True if the list is empty; False otherwise.\r\n /// This method is the recommended way of detecting if the list is empty.\r\n function Empty(): Boolean; override;\r\n\r\n /// Returns the biggest element.\r\n /// An element from the list considered to have the biggest value.\r\n /// The list is empty.\r\n function Max(): T; override;\r\n\r\n /// Returns the smallest element.\r\n /// An element from the list considered to have the smallest value.\r\n /// The list is empty.\r\n function Min(): T; override;\r\n\r\n /// Returns the first element.\r\n /// The first element in the list.\r\n /// The list is empty.\r\n function First(): T; override;\r\n\r\n /// Returns the first element or a default, if the list is empty.\r\n /// The default value returned if the list is empty.\r\n /// The first element in the list if the list is not empty; otherwise is returned.\r\n function FirstOrDefault(const ADefault: T): T; override;\r\n\r\n /// Returns the last element.\r\n /// The last element in the list.\r\n /// The list is empty.\r\n function Last(): T; override;\r\n\r\n /// Returns the last element or a default, if the list is empty.\r\n /// The default value returned if the list is empty.\r\n /// The last element in the list if the list is not empty; otherwise is returned.\r\n function LastOrDefault(const ADefault: T): T; override;\r\n\r\n /// Returns the single element stored in the list.\r\n /// The element in the list.\r\n /// This method checks if the list contains just one element, in which case it is returned.\r\n /// The list is empty.\r\n /// There is more than one element in the list.\r\n function Single(): T; override;\r\n\r\n /// Returns the single element stored in the list, or a default value.\r\n /// The default value returned if there are less or more elements in the list.\r\n /// The element in the list if the condition is satisfied; is returned otherwise.\r\n /// This method checks if the list contains just one element, in which case it is returned. Otherwise\r\n /// the value in is returned.\r\n function SingleOrDefault(const ADefault: T): T; override;\r\n\r\n /// Aggregates a value based on the list's elements.\r\n /// The aggregator method.\r\n /// A value that contains the list's aggregated value.\r\n /// This method returns the first element if the list only has one element. Otherwise,\r\n /// is invoked for each two elements (first and second; then the result of the first two\r\n /// and the third, and so on). The simplest example of aggregation is the \"sum\" operation, where you can obtain the sum of all\r\n /// elements in the value.\r\n /// is nil.\r\n /// The list is empty.\r\n function Aggregate(const AAggregator: TFunc): T; override;\r\n\r\n /// Aggregates a value based on the list's elements.\r\n /// The aggregator method.\r\n /// The default value returned if the list is empty.\r\n /// A value that contains the list's aggregated value. If the list is empty, is returned.\r\n /// This method returns the first element if the list only has one element. Otherwise,\r\n /// is invoked for each two elements (first and second; then the result of the first two\r\n /// and the third, and so on). The simplest example of aggregation is the \"sum\" operation where you can obtain the sum of all\r\n /// elements in the value.\r\n /// is nil.\r\n function AggregateOrDefault(const AAggregator: TFunc; const ADefault: T): T; override;\r\n\r\n /// Checks whether at least one element in the list satisfies a given predicate.\r\n /// The predicate to check for each element.\r\n /// True if at least one element satisfies a given predicate; False otherwise.\r\n /// This method traverses the whole list and checks the value of the predicate for each element. This method\r\n /// stops on the first element for which the predicate returns True. The logical equivalent of this operation is \"OR\".\r\n /// is nil.\r\n function Any(const APredicate: TPredicate): Boolean; override;\r\n\r\n /// Checks that all elements in the list satisfy a given predicate.\r\n /// The predicate to check for each element.\r\n /// True if all elements satisfy a given predicate; False otherwise.\r\n /// This method traverses the whole list and checks the value of the predicate for each element. This method\r\n /// stops on the first element for which the predicate returns False. The logical equivalent of this operation is \"AND\".\r\n /// is nil.\r\n function All(const APredicate: TPredicate): Boolean; override;\r\n\r\n /// Checks whether the elements in this list are equal to the elements in another collection.\r\n /// The collection to compare to.\r\n /// True if the collections are equal; False if the collections are different.\r\n /// This method checks that each element at position X in this list is equal to an element at position X in\r\n /// the provided collection. If the number of elements in both collections is different, then the collections are considered different.\r\n /// Note that the comparison of elements is done using the rule set used by this list. This means that comparing this collection\r\n /// to another one might yeild a different result than comparing the other collection to this one.\r\n /// is nil.\r\n function EqualsTo(const ACollection: IEnumerable): Boolean; override;\r\n end;\r\n\r\n /// The generic list collection designed to store objects.\r\n /// This type uses an internal array to store its objects.\r\n TObjectList = class(TList)\r\n private\r\n FOwnsObjects: Boolean;\r\n\r\n protected\r\n /// Frees the object that was removed from the collection.\r\n /// The object that was removed from the collection.\r\n procedure HandleElementRemoved(const AElement: T); override;\r\n\r\n /// Replaces a given object with a new one.\r\n /// The object to be replaced.\r\n /// The object to be replaced with.\r\n /// This method will check the objects by reference and free the current one if needed.\r\n procedure ReplaceItem(var ACurrent: T; const ANew: T); override;\r\n public\r\n /// Specifies whether this list owns the objects stored in it.\r\n /// True if the list owns its objects; False otherwise.\r\n /// This property specifies the way the list controls the life-time of the stored objects.\r\n property OwnsObjects: Boolean read FOwnsObjects write FOwnsObjects;\r\n end;\r\n\r\ntype\r\n /// The generic sorted list collection.\r\n /// This type uses an internal array to store its values.\r\n TSortedList = class(TList)\r\n private var\r\n FAscending: Boolean;\r\n\r\n procedure InternalInsert(const AIndex: NativeInt; const AValue: T);\r\n function BinarySearch(const AElement: T; const AStartIndex, ACount: NativeInt; const AAscending: Boolean): NativeInt;\r\n protected\r\n /// Sets the item at a given index.\r\n /// The index in the list.\r\n /// The new value.\r\n /// is out of bounds.\r\n /// Always raised in this implementation.\r\n procedure SetItem(const AIndex: NativeInt; const AValue: T); override;\r\n public\r\n /// Creates a new list collection.\r\n /// This constructor requests the default rule set. Call the overloaded constructor if\r\n /// specific a set of rules need to be passed. The elements are stored in ascending order.\r\n constructor Create(); overload;\r\n\r\n /// Creates a new list collection.\r\n /// A rule set describing the elements in the list.\r\n /// The elements are stored in ascending order.\r\n constructor Create(const ARules: TRules); overload;\r\n\r\n /// Creates a new list collection.\r\n /// The set's initial capacity.\r\n /// Pass in a value of True if the elements should be kept in ascending order.\r\n /// Pass in False for descending order.\r\n /// A rule set describing the elements in the list.\r\n constructor Create(const ARules: TRules; const AInitialCapacity: NativeInt; const AAscending: Boolean); overload;\r\n\r\n /// Adds an element to the list.\r\n /// The value to add.\r\n /// The index where to insert the element.\r\n /// This method always raises an exception because inserting is not allowed on sorted collections.\r\n /// Always raised in this implementation.\r\n procedure Insert(const AIndex: NativeInt; const AValue: T); override;\r\n\r\n /// Add the elements from a collection to the list.\r\n /// The values to add.\r\n /// The index where to insert the element.\r\n /// This method always raises an exception because inserting is not allowed on sorted collections.\r\n /// Always raised in this implementation.\r\n procedure InsertAll(const AIndex: NativeInt; const ACollection: IEnumerable); override;\r\n\r\n /// Adds an element to the list.\r\n /// The value to add.\r\n /// The added value is not appended. The list tries to figure out where to insert it to keep its elements\r\n /// ordered at all times.\r\n procedure Add(const AValue: T); override;\r\n\r\n /// Add the elements from a collection to the list.\r\n /// The values to add.\r\n /// The added values are not appended. The list tries to figure out where to insert the new values\r\n /// to keep its elements ordered at all times.\r\n /// is nil.\r\n procedure AddAll(const ACollection: IEnumerable); override;\r\n\r\n /// Searches for the first appearance of a given element in this list.\r\n /// The value to search for.\r\n /// -1 if the value was not found; otherwise a positive value indicating the index of the value.\r\n /// This method uses binary search because the list is always sorted.\r\n /// Parameter combination is incorrect.\r\n function IndexOf(const AValue: T): NativeInt; override;\r\n\r\n /// Searches for the last appearance of a given element in this list.\r\n /// The value to search for.\r\n /// -1 if the value was not found; otherwise a positive value indicating the index of the value.\r\n /// This method uses binary search because the list is always sorted.\r\n /// Parameter combination is incorrect.\r\n function LastIndexOf(const AValue: T): NativeInt; override;\r\n\r\n /// Returns the biggest element.\r\n /// An element from the list considered to have the biggest value.\r\n /// The list is empty.\r\n function Max(): T; override;\r\n\r\n /// Returns the smallest element.\r\n /// An element from the list considered to have the smallest value.\r\n /// The list is empty.\r\n function Min(): T; override;\r\n end;\r\n\r\n /// The generic sorted list collection designed to store objects.\r\n /// This type uses an internal array to store its objects.\r\n TObjectSortedList = class(TSortedList)\r\n private\r\n FOwnsObjects: Boolean;\r\n\r\n protected\r\n /// Frees the object that was removed from the collection.\r\n /// The object that was removed from the collection.\r\n procedure HandleElementRemoved(const AElement: T); override;\r\n\r\n public\r\n /// Specifies whether this list owns the objects stored in it.\r\n /// True if the list owns its objects; False otherwise.\r\n /// This property specifies the way the list controls the life-time of the stored objects.\r\n property OwnsObjects: Boolean read FOwnsObjects write FOwnsObjects;\r\n end;\r\n\r\ntype\r\n /// The generic linked list collection.\r\n /// This type uses a linked list to store its values.\r\n TLinkedList = class(TAbstractLinkedList)\r\n private type\r\n {$REGION 'Internal Types'}\r\n PEntry = ^TEntry;\r\n TEntry = record\r\n FPrev, FNext: PEntry;\r\n FValue: T;\r\n end;\r\n\r\n TEnumerator = class(TAbstractEnumerator)\r\n private\r\n FCurrentEntry: PEntry;\r\n public\r\n function TryMoveNext(out ACurrent: T): Boolean; override;\r\n end;\r\n {$ENDREGION}\r\n\r\n private var\r\n FCanCache: Boolean;\r\n FFirst, FLast, FFirstFree: PEntry;\r\n FCount, FFreeCount: NativeInt;\r\n\r\n { Caching }\r\n function EntryAt(const AIndex: NativeInt; const AThrow: Boolean = True): PEntry;\r\n function NeedEntry(const AValue: T): PEntry;\r\n procedure ReleaseEntry(const AEntry: PEntry);\r\n protected\r\n /// Sets the item at a given index.\r\n /// The index in the list.\r\n /// The new value.\r\n /// is out of bounds.\r\n /// This is a very slow operation and should be avoided.\r\n procedure SetItem(const AIndex: NativeInt; const AValue: T); override;\r\n\r\n /// Returns the number of elements in the list.\r\n /// A positive value specifying the number of elements in the list.\r\n function GetCount(): NativeInt; override;\r\n\r\n /// Extracts the element from the specified index.\r\n /// The index to stract from.\r\n /// The value stored at that index.\r\n /// True if the value was found and stored in parameter; False otherwise.\r\n function TryExtractAt(const AIndex: NativeInt; out AValue: T): Boolean; override;\r\n\r\n /// Returns the item at a given index.\r\n /// The index in the list.\r\n /// The value stored at that index.\r\n /// True if the value was found and stored in parameter; False otherwise.\r\n function TryGetItemAt(const AIndex: NativeInt; out AValue: T): Boolean; override;\r\n public\r\n /// Creates a new list collection.\r\n /// This constructor requests the default rule set. Call the overloaded constructor if\r\n /// specific a set of rules need to be passed.\r\n constructor Create(); overload;\r\n\r\n /// Creates a new list collection.\r\n /// A rule set describing the elements in the list.\r\n constructor Create(const ARules: TRules); overload;\r\n\r\n /// Destroys this instance.\r\n /// Do not call this method directly; call Free instead.\r\n destructor Destroy(); override;\r\n\r\n /// Clears the contents of the list.\r\n procedure Clear(); override;\r\n\r\n /// Inserts an element into the list.\r\n /// The index to insert to.\r\n /// The value to insert.\r\n /// All elements starting with are moved to the right by one and then\r\n /// is placed at position .\r\n /// is out of bounds.\r\n procedure Insert(const AIndex: NativeInt; const AValue: T); override;\r\n\r\n /// Inserts the elements of a collection into the list.\r\n /// The index to insert to.\r\n /// The values to insert.\r\n /// All elements starting with are moved to the right by the length of\r\n /// and then is placed at position .\r\n /// is out of bounds.\r\n /// is nil.\r\n procedure InsertAll(const AIndex: NativeInt; const ACollection: IEnumerable); override;\r\n\r\n /// Removes a given value from the list.\r\n /// The value to remove.\r\n /// If the list does not contain the given value, nothing happens.\r\n procedure Remove(const AValue: T); override;\r\n\r\n /// Searches for the first appearance of a given element in this list.\r\n /// The value to search for.\r\n /// -1 if the value was not found; otherwise a positive value indicating the index of the value.\r\n /// Parameter combination is incorrect.\r\n function IndexOf(const AValue: T): NativeInt; override;\r\n\r\n /// Searches for the last appearance of a given element in this list.\r\n /// The value to search for.\r\n /// -1 if the value was not found; otherwise a positive value indicating the index of the value.\r\n /// Parameter combination is incorrect.\r\n function LastIndexOf(const AValue: T): NativeInt; override;\r\n\r\n /// Specifies the number of elements in the list.\r\n /// A positive value specifying the number of elements in the list.\r\n property Count: NativeInt read FCount;\r\n\r\n /// Returns a new enumerator object used to enumerate this list.\r\n /// This method is usually called by compiler-generated code. Its purpose is to create an enumerator\r\n /// object that is used to actually traverse the list.\r\n /// An enumerator object.\r\n function GetEnumerator(): IEnumerator; override;\r\n\r\n /// Copies the values stored in the list to a given array.\r\n /// An array where to copy the contents of the list.\r\n /// The index into the array at which the copying begins.\r\n /// This method assumes that has enough space to hold the contents of the list.\r\n /// is out of bounds.\r\n /// The array is not long enough.\r\n procedure CopyTo(var AArray: array of T; const AStartIndex: NativeInt); overload; override;\r\n\r\n /// Checks whether the list is empty.\r\n /// True if the list is empty; False otherwise.\r\n /// This method is the recommended way of detecting if the list is empty.\r\n function Empty(): Boolean; override;\r\n\r\n /// Returns the first element.\r\n /// The first element in the list.\r\n /// The list is empty.\r\n function First(): T; override;\r\n\r\n /// Returns the first element or a default, if the list is empty.\r\n /// The default value returned if the list is empty.\r\n /// The first element in the list if the list is not empty; otherwise is returned.\r\n function FirstOrDefault(const ADefault: T): T; override;\r\n\r\n /// Returns the last element.\r\n /// The last element in the list.\r\n /// The list is empty.\r\n function Last(): T; override;\r\n\r\n /// Returns the last element or a default, if the list is empty.\r\n /// The default value returned if the list is empty.\r\n /// The last element in the list if the list is not empty; otherwise is returned.\r\n function LastOrDefault(const ADefault: T): T; override;\r\n\r\n /// Returns the single element stored in the list.\r\n /// The element in the list.\r\n /// This method checks if the list contains just one element, in which case it is returned.\r\n /// The list is empty.\r\n /// There is more than one element in the list.\r\n function Single(): T; override;\r\n\r\n /// Returns the single element stored in the list, or a default value.\r\n /// The default value returned if there are less or more elements in the list.\r\n /// The element in the list if the condition is satisfied; is returned otherwise.\r\n /// This method checks if the list contains just one element, in which case it is returned. Otherwise\r\n /// the value in is returned.\r\n function SingleOrDefault(const ADefault: T): T; override;\r\n end;\r\n\r\n /// The generic linked list collection designed to store objects.\r\n /// This type uses a linked list to store its objects.\r\n TObjectLinkedList = class(TLinkedList)\r\n private\r\n FOwnsObjects: Boolean;\r\n\r\n protected\r\n /// Frees the object that was removed from the collection.\r\n /// The object that was removed from the collection.\r\n procedure HandleElementRemoved(const AElement: T); override;\r\n\r\n /// Replaces a given object with a new one.\r\n /// The object to be replaced.\r\n /// The object to be replaced with.\r\n /// This method will check the objects by reference and free the current one, if needed.\r\n procedure ReplaceItem(var ACurrent: T; const ANew: T); override;\r\n public\r\n /// Specifies whether this list owns the objects stored in it.\r\n /// True if the list owns its objects; False otherwise.\r\n /// This property specifies the way the list controls the life-time of the stored objects.\r\n property OwnsObjects: Boolean read FOwnsObjects write FOwnsObjects;\r\n end;\r\n\r\ntype\r\n /// The generic sorted linked list collection.\r\n /// This type uses a linked list to store its values.\r\n TSortedLinkedList = class(TLinkedList)\r\n private\r\n FAscending: Boolean;\r\n\r\n protected\r\n /// Sets the item at a given index.\r\n /// The index in the list.\r\n /// The new value.\r\n /// is out of bounds.\r\n /// Always raised in this implementation.\r\n procedure SetItem(const AIndex: NativeInt; const AValue: T); override;\r\n public\r\n /// Creates a new list collection.\r\n /// This constructor requests the default rule set. Call the overloaded constructor if\r\n /// specific a set of rules need to be passed. The elements are stored in ascending order.\r\n constructor Create(); overload;\r\n\r\n /// Creates a new list collection.\r\n /// A rule set describing the elements in the list.\r\n /// The elements are stored in ascending order.\r\n constructor Create(const ARules: TRules); overload;\r\n\r\n /// Creates a new list collection.\r\n /// Pass in a value of True if the elements should be kept in ascending order.\r\n /// Pass in False for descending order.\r\n /// A rule set describing the elements in the list.\r\n constructor Create(const ARules: TRules; const AAscending: Boolean); overload;\r\n\r\n /// Adds an element to the list.\r\n /// The value to add.\r\n /// The index where to insert the element.\r\n /// This method always raises an exception because inserting is not allowed on sorted collections.\r\n /// Always raised in this implementation.\r\n procedure Insert(const AIndex: NativeInt; const AValue: T); override;\r\n\r\n /// Add the elements from a collection to the list.\r\n /// The values to add.\r\n /// The index where to insert the element.\r\n /// This method always raises an exception because inserting is not allowed on sorted collections.\r\n /// Always raised in this implementation.\r\n procedure InsertAll(const AIndex: NativeInt; const ACollection: IEnumerable); override;\r\n\r\n /// Adds an element to the list.\r\n /// The value to add.\r\n /// The added value is not appended. The list tries to figure out where to insert it to keep its elements\r\n /// ordered at all times.\r\n procedure Add(const AValue: T); override;\r\n\r\n /// Add the elements from a collection to the list.\r\n /// The values to add.\r\n /// The added values are not appended. The list tries to figure out where to insert the new values\r\n /// to keep its elements ordered at all times.\r\n /// is nil.\r\n procedure AddAll(const ACollection: IEnumerable); override;\r\n\r\n /// Returns the biggest element.\r\n /// An element from the list considered to have the biggest value.\r\n /// The list is empty.\r\n function Max(): T; override;\r\n\r\n /// Returns the smallest element.\r\n /// An element from the list considered to have the smallest value.\r\n /// The list is empty.\r\n function Min(): T; override;\r\n end;\r\n\r\n /// The generic sorted linked list collection designed to store objects.\r\n /// This type uses a linked list to store its objects.\r\n TObjectSortedLinkedList = class(TSortedLinkedList)\r\n private\r\n FOwnsObjects: Boolean;\r\n\r\n protected\r\n /// Frees the object that was removed from the collection.\r\n /// The object that was removed from the collection.\r\n procedure HandleElementRemoved(const AElement: T); override;\r\n\r\n public\r\n /// Specifies whether this list owns the objects stored in it.\r\n /// True if the list owns its objects; False otherwise.\r\n /// This property specifies the way the list controls the life-time of the stored objects.\r\n property OwnsObjects: Boolean read FOwnsObjects write FOwnsObjects;\r\n end;\r\n\r\nimplementation\r\n\r\n{ TAbstractList }\r\n\r\nprocedure TAbstractList.AddAll(const ACollection: IEnumerable);\r\nbegin\r\n InsertAll(GetCount(), ACollection);\r\nend;\r\n\r\nprocedure TAbstractList.Add(const AValue: T);\r\nbegin\r\n Insert(GetCount(), AValue);\r\nend;\r\n\r\nfunction TAbstractList.Contains(const AValue: T): Boolean;\r\nbegin\r\n Result := IndexOf(AValue) >= 0;\r\nend;\r\n\r\nconstructor TAbstractList.Create(const ARules: TRules);\r\nbegin\r\n inherited Create(ARules);\r\nend;\r\n\r\nfunction TAbstractList.ElementAt(const AIndex: NativeInt): T;\r\nbegin\r\n if not TryGetItemAt(AIndex, Result) then\r\n ExceptionHelper.Throw_ArgumentOutOfRangeError('AIndex');\r\nend;\r\n\r\nfunction TAbstractList.ElementAtOrDefault(const AIndex: NativeInt; const ADefault: T): T;\r\nbegin\r\n if AIndex < 0 then\r\n ExceptionHelper.Throw_ArgumentOutOfRangeError('AIndex');\r\n\r\n if not TryGetItemAt(AIndex, Result) then\r\n Result := ADefault\r\nend;\r\n\r\nfunction TAbstractList.ExtractAt(const AIndex: NativeInt): T;\r\nbegin\r\n if not TryExtractAt(AIndex, Result) then\r\n ExceptionHelper.Throw_ArgumentOutOfRangeError('AIndex');\r\nend;\r\n\r\nfunction TAbstractList.GetItem(const AIndex: NativeInt): T;\r\nbegin\r\n if not TryGetItemAt(AIndex, Result) then\r\n ExceptionHelper.Throw_ArgumentOutOfRangeError('AIndex');\r\nend;\r\n\r\nfunction TAbstractList.IndexOf(const AValue: T): NativeInt;\r\nvar\r\n LEnumerator: IEnumerator;\r\nbegin\r\n LEnumerator := GetEnumerator();\r\n Result := 0;\r\n\r\n while LEnumerator.MoveNext() do\r\n begin\r\n if ElementsAreEqual(AValue, LEnumerator.Current) then Exit;\r\n Inc(Result);\r\n end;\r\n\r\n Result := -1;\r\nend;\r\n\r\nprocedure TAbstractList.InsertAll(const AIndex: NativeInt; const ACollection: IEnumerable);\r\nvar\r\n LIn: T;\r\n LIndex: NativeInt;\r\nbegin\r\n if not Assigned(ACollection) then\r\n ExceptionHelper.Throw_ArgumentNilError('ACollection');\r\n\r\n LIndex := AIndex;\r\n for LIn in ACollection do\r\n begin\r\n Insert(LIndex, LIn);\r\n Inc(LIndex);\r\n end;\r\nend;\r\n\r\nprocedure TAbstractList.Insert(const AIndex: NativeInt; const AValue: T);\r\nbegin\r\n ExceptionHelper.Throw_OperationNotSupported('Insert');\r\nend;\r\n\r\nfunction TAbstractList.LastIndexOf(const AValue: T): NativeInt;\r\nbegin\r\n ExceptionHelper.Throw_OperationNotSupported('LastIndexOf');\r\nend;\r\n\r\nprocedure TAbstractList.Remove(const AValue: T);\r\nvar\r\n LIndex: NativeInt;\r\n LDummy: T;\r\nbegin\r\n LIndex := IndexOf(AValue);\r\n if LIndex >= 0 then\r\n TryExtractAt(LIndex, LDummy);\r\nend;\r\n\r\nprocedure TAbstractList.RemoveAt(const AIndex: NativeInt);\r\nvar\r\n LValue: T;\r\nbegin\r\n if not TryExtractAt(AIndex, LValue) then\r\n ExceptionHelper.Throw_ArgumentOutOfRangeError('AIndex')\r\n else\r\n NotifyElementRemoved(LValue);\r\nend;\r\n\r\nprocedure TAbstractList.ReplaceItem(var ACurrent: T; const ANew: T);\r\nbegin\r\n if not ElementsAreEqual(ACurrent, ANew) then\r\n begin\r\n { Notify that an element is removed. }\r\n NotifyElementRemoved(ACurrent);\r\n\r\n { Replace it. }\r\n ACurrent := ANew;\r\n end;\r\nend;\r\n\r\nprocedure TAbstractList.SetItem(const AIndex: NativeInt; const AValue: T);\r\nbegin\r\n ExceptionHelper.Throw_OperationNotSupported('SetItem');\r\nend;\r\n\r\nfunction TAbstractList.TryExtractAt(const AIndex: NativeInt; out AValue: T): Boolean;\r\nbegin\r\n ExceptionHelper.Throw_OperationNotSupported('TryExtractAt');\r\nend;\r\n\r\nfunction TAbstractList.TryGetItemAt(const AIndex: NativeInt; out AValue: T): Boolean;\r\nvar\r\n LEnumerator: IEnumerator;\r\n LIndex: NativeInt;\r\nbegin\r\n Result := False;\r\n\r\n if (AIndex >= 0) and (AIndex < GetCount()) then\r\n begin\r\n LEnumerator := GetEnumerator();\r\n LIndex := 0;\r\n while LEnumerator.MoveNext() do\r\n begin\r\n if LIndex = AIndex then\r\n begin\r\n AValue := LEnumerator.Current;\r\n Exit(True);\r\n end;\r\n\r\n Inc(LIndex);\r\n end;\r\n end;\r\nend;\r\n\r\n{ TAbstractLinkedList }\r\n\r\nprocedure TAbstractLinkedList.AddFirst(const AValue: T);\r\nbegin\r\n Insert(0, AValue);\r\nend;\r\n\r\nprocedure TAbstractLinkedList.AddAllFirst(const ACollection: IEnumerable);\r\nbegin\r\n InsertAll(0, ACollection);\r\nend;\r\n\r\nprocedure TAbstractLinkedList.AddLast(const AValue: T);\r\nbegin\r\n Insert(GetCount(), AValue);\r\nend;\r\n\r\nprocedure TAbstractLinkedList.AddAllLast(const ACollection: IEnumerable);\r\nbegin\r\n InsertAll(GetCount(), ACollection);\r\nend;\r\n\r\nfunction TAbstractLinkedList.ExtractFirst: T;\r\nbegin\r\n if GetCount() = 0 then\r\n ExceptionHelper.Throw_CollectionEmptyError();\r\n\r\n Result := ExtractAt(0);\r\nend;\r\n\r\nfunction TAbstractLinkedList.ExtractLast: T;\r\nbegin\r\n if GetCount() = 0 then\r\n ExceptionHelper.Throw_CollectionEmptyError();\r\n\r\n Result := ExtractAt(GetCount() - 1);\r\nend;\r\n\r\nprocedure TAbstractLinkedList.RemoveFirst;\r\nbegin\r\n if GetCount() = 0 then\r\n ExceptionHelper.Throw_CollectionEmptyError();\r\n\r\n RemoveAt(0);\r\nend;\r\n\r\nprocedure TAbstractLinkedList.RemoveLast;\r\nbegin\r\n if GetCount() = 0 then\r\n ExceptionHelper.Throw_CollectionEmptyError();\r\n\r\n RemoveAt(GetCount() - 1);\r\nend;\r\n\r\n{ TList }\r\n\r\nfunction TList.Aggregate(const AAggregator: TFunc): T;\r\nvar\r\n I: NativeInt;\r\nbegin\r\n { Check arguments }\r\n if not Assigned(AAggregator) then\r\n ExceptionHelper.Throw_ArgumentNilError('AAggregator');\r\n\r\n if FLength = 0 then\r\n ExceptionHelper.Throw_CollectionEmptyError();\r\n\r\n { Select the first element as comparison base }\r\n Result := FArray[0];\r\n\r\n { Iterate over the last N - 1 elements }\r\n for I := 1 to FLength - 1 do\r\n Result := AAggregator(Result, FArray[I]);\r\nend;\r\n\r\nfunction TList.AggregateOrDefault(const AAggregator: TFunc; const ADefault: T): T;\r\nvar\r\n I: NativeInt;\r\nbegin\r\n { Check arguments }\r\n if not Assigned(AAggregator) then\r\n ExceptionHelper.Throw_ArgumentNilError('AAggregator');\r\n\r\n if FLength = 0 then\r\n Exit(ADefault);\r\n\r\n { Select the first element as comparison base }\r\n Result := FArray[0];\r\n\r\n { Iterate over the last N - 1 elements }\r\n for I := 1 to FLength - 1 do\r\n Result := AAggregator(Result, FArray[I]);\r\nend;\r\n\r\nfunction TList.All(const APredicate: TPredicate): Boolean;\r\nvar\r\n I: NativeInt;\r\nbegin\r\n if not Assigned(APredicate) then\r\n ExceptionHelper.Throw_ArgumentNilError('APredicate');\r\n\r\n if FLength > 0 then\r\n for I := 0 to FLength - 1 do\r\n if not APredicate(FArray[I]) then\r\n Exit(false);\r\n\r\n Result := true;\r\nend;\r\n\r\nfunction TList.Any(const APredicate: TPredicate): Boolean;\r\nvar\r\n I: NativeInt;\r\nbegin\r\n if not Assigned(APredicate) then\r\n ExceptionHelper.Throw_ArgumentNilError('APredicate');\r\n\r\n if FLength > 0 then\r\n for I := 0 to FLength - 1 do\r\n if APredicate(FArray[I]) then\r\n Exit(true);\r\n\r\n Result := false;\r\nend;\r\n\r\nprocedure TList.Clear;\r\nvar\r\n I: NativeInt;\r\nbegin\r\n { Should clean up each element individually }\r\n if FLength > 0 then\r\n begin\r\n for I := 0 to FLength - 1 do\r\n NotifyElementRemoved(FArray[I]);\r\n\r\n NotifyCollectionChanged();\r\n end;\r\n\r\n { Reset the length }\r\n FLength := 0;\r\nend;\r\n\r\nprocedure TList.CopyTo(var AArray: array of T; const AStartIndex: NativeInt);\r\nvar\r\n I: NativeInt;\r\nbegin\r\n { Check for indexes }\r\n if (AStartIndex >= Length(AArray)) or (AStartIndex < 0) then\r\n ExceptionHelper.Throw_ArgumentOutOfRangeError('AStartIndex');\r\n\r\n if (Length(AArray) - AStartIndex) < Count then\r\n ExceptionHelper.Throw_ArgumentOutOfSpaceError('AArray');\r\n\r\n { Copy all elements safely }\r\n for I := 0 to FLength - 1 do\r\n AArray[AStartIndex + I] := FArray[I];\r\nend;\r\n\r\nconstructor TList.Create(const ARules: TRules);\r\nbegin\r\n Create(ARules, CDefaultSize);\r\nend;\r\n\r\nconstructor TList.Create(const ARules: TRules; const AInitialCapacity: NativeInt);\r\nbegin\r\n inherited Create(ARules);\r\n\r\n if AInitialCapacity <= 0 then\r\n SetLength(FArray, 0)\r\n else\r\n SetLength(FArray, AInitialCapacity);\r\nend;\r\n\r\nconstructor TList.Create;\r\nbegin\r\n Create(TRules.Default, CDefaultSize);\r\nend;\r\n\r\nprocedure TList.Deserialize(const AContext: TInputContext);\r\nvar\r\n L64Length: Int64;\r\nbegin\r\n AContext.GetValue('Length', L64Length); FLength := L64Length;\r\n AContext.GetValue>('Array', FArray);\r\nend;\r\n\r\nfunction TList.Empty: Boolean;\r\nbegin\r\n Result := (FLength = 0);\r\nend;\r\n\r\nfunction TList.EqualsTo(const ACollection: IEnumerable): Boolean;\r\nvar\r\n LValue: T;\r\n I: NativeInt;\r\nbegin\r\n I := 0;\r\n\r\n for LValue in ACollection do\r\n begin\r\n if I >= FLength then\r\n Exit(false);\r\n\r\n if not ElementsAreEqual(FArray[I], LValue) then\r\n Exit(false);\r\n\r\n Inc(I);\r\n end;\r\n\r\n if I < FLength then\r\n Exit(false);\r\n\r\n Result := true;\r\nend;\r\n\r\nfunction TList.First: T;\r\nbegin\r\n { Check length }\r\n if FLength = 0 then\r\n ExceptionHelper.Throw_CollectionEmptyError();\r\n\r\n Result := FArray[0];\r\nend;\r\n\r\nfunction TList.FirstOrDefault(const ADefault: T): T;\r\nbegin\r\n { Check length }\r\n if FLength = 0 then\r\n Result := ADefault\r\n else\r\n Result := FArray[0];\r\nend;\r\n\r\nfunction TList.GetCapacity: NativeInt;\r\nbegin\r\n Result := Length(FArray);\r\nend;\r\n\r\nfunction TList.GetCount: NativeInt;\r\nbegin\r\n Result := FLength;\r\nend;\r\n\r\nfunction TList.GetEnumerator: IEnumerator;\r\nbegin\r\n { Create an enumerator }\r\n Result := TEnumerator.Create(Self);\r\nend;\r\n\r\nprocedure TList.Grow;\r\nbegin\r\n { Grow the array }\r\n if FLength < CDefaultSize then\r\n SetLength(FArray, FLength + CDefaultSize)\r\n else\r\n SetLength(FArray, FLength * 2);\r\nend;\r\n\r\nfunction TList.IndexOf(const AValue: T): NativeInt;\r\nbegin\r\n for Result := 0 to FLength - 1 do\r\n if ElementsAreEqual(FArray[Result], AValue) then\r\n Exit;\r\n\r\n Result := -1;\r\nend;\r\n\r\nprocedure TList.Insert(const AIndex: NativeInt; const AValue: T);\r\nvar\r\n I: NativeInt;\r\nbegin\r\n if (AIndex > FLength) or (AIndex < 0) then\r\n ExceptionHelper.Throw_ArgumentOutOfRangeError('AIndex');\r\n\r\n if FLength = Length(FArray) then\r\n Grow();\r\n\r\n { Move the array to the right }\r\n if AIndex < FLength then\r\n for I := FLength downto (AIndex + 1) do\r\n FArray[I] := FArray[I - 1];\r\n\r\n Inc(FLength);\r\n\r\n { Put the element into the new position }\r\n FArray[AIndex] := AValue;\r\n NotifyCollectionChanged();\r\nend;\r\n\r\nprocedure TList.InsertAll(const AIndex: NativeInt; const ACollection: IEnumerable);\r\nvar\r\n LValue: T;\r\n LEnumArray: TArray;\r\n LEnumLen: NativeInt;\r\n I: NativeInt;\r\nbegin\r\n if (AIndex > FLength) or (AIndex < 0) then\r\n ExceptionHelper.Throw_ArgumentOutOfRangeError('AIndex');\r\n\r\n if not Assigned(ACollection) then\r\n ExceptionHelper.Throw_ArgumentNilError('ACollection');\r\n\r\n { Create a temporary list with teh given elements }\r\n LEnumLen := 0;\r\n for LValue in ACollection do\r\n begin\r\n if Length(LEnumArray) = LEnumLen then\r\n SetLength(LEnumArray, (Length(LEnumArray) + 1) * 2);\r\n\r\n LEnumArray[LEnumLen] := LValue;\r\n Inc(LEnumLen);\r\n end;\r\n\r\n { Check for free space and extend the array to support it if necessary }\r\n if (Length(FArray) - FLength) < LEnumLen then\r\n SetLength(FArray, LEnumLen + FLength);\r\n\r\n { Move the contents of the list to the right }\r\n if AIndex < FLength then\r\n for I := (FLength - 1) downto AIndex do\r\n FArray[LEnumLen + I] := FArray[I];\r\n\r\n { Copy the contents in }\r\n for I := 0 to LEnumLen - 1 do\r\n FArray[AIndex + I] := LEnumArray[I];\r\n\r\n { Update internals }\r\n Inc(FLength, LEnumLen);\r\n NotifyCollectionChanged();\r\nend;\r\n\r\nfunction TList.Last: T;\r\nbegin\r\n { Check length }\r\n if FLength = 0 then\r\n ExceptionHelper.Throw_CollectionEmptyError();\r\n\r\n Result := FArray[FLength - 1];\r\nend;\r\n\r\nfunction TList.LastOrDefault(const ADefault: T): T;\r\nbegin\r\n { Check length }\r\n if FLength = 0 then\r\n Result := ADefault\r\n else\r\n Result := FArray[FLength - 1];\r\nend;\r\n\r\nfunction TList.Max: T;\r\nvar\r\n I: NativeInt;\r\nbegin\r\n { Check length }\r\n if FLength = 0 then\r\n ExceptionHelper.Throw_CollectionEmptyError();\r\n\r\n { Default one }\r\n Result := FArray[0];\r\n\r\n for I := 1 to FLength - 1 do\r\n if CompareElements(FArray[I], Result) > 0 then\r\n Result := FArray[I];\r\nend;\r\n\r\nfunction TList.Min: T;\r\nvar\r\n I: NativeInt;\r\nbegin\r\n { Check length }\r\n if FLength = 0 then\r\n ExceptionHelper.Throw_CollectionEmptyError();\r\n\r\n { Default one }\r\n Result := FArray[0];\r\n\r\n for I := 1 to FLength - 1 do\r\n if CompareElements(FArray[I], Result) < 0 then\r\n Result := FArray[I];\r\nend;\r\n\r\nprocedure TList.QuickSort(ALeft, ARight: NativeInt; const AAscending: Boolean);\r\nbegin\r\n if AAscending then { Ascending sort }\r\n QuickSort(ALeft, ARight,\r\n function(const ALeft, ARight: T): Integer\r\n begin\r\n Exit(CompareElements(ALeft, ARight));\r\n end\r\n ) else { Descending sort }\r\n QuickSort(ALeft, ARight,\r\n function(const ALeft, ARight: T): Integer\r\n begin\r\n Exit(-CompareElements(ALeft, ARight));\r\n end\r\n )\r\nend;\r\n\r\nprocedure TList.QuickSort(ALeft, ARight: NativeInt; const ASortProc: TComparison);\r\n{$IFNDEF OPTIMIZED_SORT}\r\nvar\r\n I, J: NativeInt;\r\n LPivot, LTemp: T;\r\nbegin\r\n ASSERT(Assigned(ASortProc));\r\n\r\n repeat\r\n I := ALeft;\r\n J := ARight;\r\n\r\n LPivot := FArray[(ALeft + ARight) div 2];\r\n\r\n repeat\r\n while ASortProc(FArray[I], LPivot) < 0 do\r\n Inc(I);\r\n\r\n while ASortProc(FArray[J], LPivot) > 0 do\r\n Dec(J);\r\n\r\n if I <= J then\r\n begin\r\n\r\n if I <> J then\r\n begin\r\n LTemp := FArray[I];\r\n FArray[I] := FArray[J];\r\n FArray[J] := LTemp;\r\n end;\r\n\r\n Inc(I);\r\n Dec(J);\r\n end;\r\n\r\n until I > J;\r\n\r\n if ALeft < J then\r\n QuickSort(FArray, ALeft, J, ASortProc);\r\n\r\n ALeft := I;\r\n\r\n until I >= ARight;\r\nend;\r\n{$ELSE}\r\nvar\r\n LSubArray, LSubLeft, LSubRight: NativeInt;\r\n LPivot, LTemp: T;\r\n LStack: TQuickSortStack;\r\nbegin\r\n ASSERT(Assigned(ASortProc));\r\n\r\n LSubArray := 0;\r\n\r\n LStack[LSubArray].First := ALeft;\r\n LStack[LSubArray].Last := ARight;\r\n\r\n repeat\r\n ALeft := LStack[LSubArray].First;\r\n ARight := LStack[LSubArray].Last;\r\n Dec(LSubArray);\r\n repeat\r\n LSubLeft := ALeft;\r\n LSubRight := ARight;\r\n LPivot:= FArray[(ALeft + ARight) shr 1];\r\n\r\n repeat\r\n while ASortProc(FArray[LSubLeft], LPivot) < 0 do\r\n Inc(LSubLeft);\r\n\r\n while ASortProc(FArray[LSubRight], LPivot) > 0 do\r\n Dec(LSubRight);\r\n\r\n if LSubLeft <= LSubRight then\r\n begin\r\n LTemp := FArray[LSubLeft];\r\n FArray[LSubLeft] := FArray[LSubRight];\r\n FArray[LSubRight] := LTemp;\r\n Inc(LSubLeft);\r\n Dec(LSubRight);\r\n end;\r\n until LSubLeft > LSubRight;\r\n\r\n if LSubLeft < ARight then\r\n begin\r\n Inc(LSubArray);\r\n LStack[LSubArray].First := LSubLeft;\r\n LStack[LSubArray].Last := ARight;\r\n end;\r\n\r\n ARight := LSubRight;\r\n until ALeft >= ARight;\r\n until LSubArray < 0;\r\nend;\r\n{$ENDIF}\r\n\r\nfunction TList.LastIndexOf(const AValue: T): NativeInt;\r\nbegin\r\n for Result := FLength - 1 downto 0 do\r\n if ElementsAreEqual(FArray[Result], AValue) then\r\n Exit;\r\n\r\n Result := -1;\r\nend;\r\n\r\nprocedure TList.Reverse(const AStartIndex, ACount: NativeInt);\r\nvar\r\n I: NativeInt;\r\n LValue: T;\r\nbegin\r\n { Check for indexes }\r\n if AStartIndex < 0 then\r\n ExceptionHelper.Throw_ArgumentOutOfRangeError('AStartIndex');\r\n\r\n if ACount < 0 then\r\n ExceptionHelper.Throw_ArgumentOutOfRangeError('ACount');\r\n\r\n if ((AStartIndex + ACount) > FLength) then\r\n ExceptionHelper.Throw_ArgumentOutOfRangeError('AStartIndex/ACount');\r\n\r\n if ACount < 2 then\r\n Exit;\r\n\r\n { Reverse the array }\r\n for I := 0 to (ACount div 2) - 1 do\r\n begin\r\n LValue := FArray[AStartIndex + I];\r\n FArray[AStartIndex + I] := FArray[AStartIndex + ACount - I - 1];\r\n FArray[AStartIndex + ACount - I - 1] := LValue;\r\n end;\r\nend;\r\n\r\nprocedure TList.Reverse(const AStartIndex: NativeInt);\r\nbegin\r\n { Call the complete method }\r\n Reverse(AStartIndex, FLength - AStartIndex);\r\nend;\r\n\r\nprocedure TList.Reverse;\r\nbegin\r\n { Call the complete method }\r\n Reverse(0, FLength);\r\nend;\r\n\r\nprocedure TList.Sort(const AStartIndex, ACount: NativeInt; const AAscending: Boolean);\r\nbegin\r\n { Check for indexes }\r\n if AStartIndex < 0 then\r\n ExceptionHelper.Throw_ArgumentOutOfRangeError('AStartIndex');\r\n\r\n if ACount < 0 then\r\n ExceptionHelper.Throw_ArgumentOutOfRangeError('ACount');\r\n\r\n if ((AStartIndex + ACount) > FLength) then\r\n ExceptionHelper.Throw_ArgumentOutOfRangeError('AStartIndex/ACount');\r\n\r\n if ACount > 0 then\r\n QuickSort(AStartIndex, (AStartIndex + ACount) - 1, AAscending);\r\nend;\r\n\r\nprocedure TList.Sort(const AStartIndex: NativeInt; const AAscending: Boolean);\r\nbegin\r\n { Call the better method }\r\n Sort(AStartIndex, FLength, AAscending);\r\nend;\r\n\r\nprocedure TList.Serialize(const AContext: TOutputContext);\r\nbegin\r\n AContext.AddValue('Length', Int64(FLength));\r\n AContext.AddValue('Array', FArray);\r\nend;\r\n\r\nprocedure TList.SetItem(const AIndex: NativeInt; const AValue: T);\r\nbegin\r\n { Check range }\r\n if (AIndex >= FLength) or (AIndex < 0) then\r\n ExceptionHelper.Throw_ArgumentOutOfRangeError('AIndex');\r\n\r\n { Delegate }\r\n ReplaceItem(FArray[AIndex], AValue);\r\n\r\n { Increment version }\r\n NotifyCollectionChanged();\r\nend;\r\n\r\nprocedure TList.Shrink;\r\nbegin\r\n { Cut the capacity, if required }\r\n if FLength < Capacity then\r\n SetLength(FArray, FLength);\r\nend;\r\n\r\nfunction TList.Single: T;\r\nbegin\r\n { Check length }\r\n if FLength = 0 then\r\n ExceptionHelper.Throw_CollectionEmptyError()\r\n else if FLength > 1 then\r\n ExceptionHelper.Throw_CollectionHasMoreThanOneElement()\r\n else\r\n Result := FArray[0];\r\nend;\r\n\r\nfunction TList.SingleOrDefault(const ADefault: T): T;\r\nbegin\r\n { Check length }\r\n if FLength = 0 then\r\n Result := ADefault\r\n else if FLength > 1 then\r\n ExceptionHelper.Throw_CollectionHasMoreThanOneElement()\r\n else\r\n Result := FArray[0];\r\nend;\r\n\r\nprocedure TList.Sort(const AStartIndex, ACount: NativeInt; const ASortProc: TComparison);\r\nbegin\r\n { Check for indexes }\r\n if AStartIndex < 0 then\r\n ExceptionHelper.Throw_ArgumentOutOfRangeError('AStartIndex');\r\n\r\n if ACount < 0 then\r\n ExceptionHelper.Throw_ArgumentOutOfRangeError('ACount');\r\n\r\n if ((AStartIndex + ACount) > FLength) then\r\n ExceptionHelper.Throw_ArgumentOutOfRangeError('AStartIndex/ACount');\r\n\r\n if ACount > 0 then\r\n QuickSort(AStartIndex, (AStartIndex + ACount) - 1, ASortProc);\r\nend;\r\n\r\nprocedure TList.Sort(const AStartIndex: NativeInt; const ASortProc: TComparison);\r\nbegin\r\n { Call the better method }\r\n Sort(AStartIndex, FLength, ASortProc);\r\nend;\r\n\r\nprocedure TList.Sort(const ASortProc: TComparison);\r\nbegin\r\n if not Assigned(ASortProc) then\r\n ExceptionHelper.Throw_ArgumentNilError('ASortProc');\r\n\r\n { Call the better method }\r\n Sort(0, FLength, ASortProc);\r\nend;\r\n\r\nfunction TList.TryExtractAt(const AIndex: NativeInt; out AValue: T): Boolean;\r\nvar\r\n I: NativeInt;\r\nbegin\r\n Result := False;\r\n if (AIndex >= FLength) or (AIndex < 0) then\r\n Exit;\r\n\r\n { Return the element at that position. }\r\n AValue := FArray[AIndex];\r\n\r\n { Move the list }\r\n if FLength > 1 then\r\n for I := AIndex to FLength - 2 do\r\n FArray[I] := FArray[I + 1];\r\n\r\n Result := True;\r\n Dec(FLength);\r\n NotifyCollectionChanged();\r\nend;\r\n\r\nfunction TList.TryGetItemAt(const AIndex: NativeInt; out AValue: T): Boolean;\r\nbegin\r\n if (AIndex >= 0) and (AIndex < FLength) then\r\n begin\r\n AValue := FArray[AIndex];\r\n Result := True;\r\n end else\r\n Result := False;\r\nend;\r\n\r\nprocedure TList.Sort(const AAscending: Boolean);\r\nbegin\r\n { Call the better method }\r\n Sort(0, FLength, AAscending);\r\nend;\r\n\r\n{ TList.TEnumerator }\r\n\r\nfunction TList.TEnumerator.TryMoveNext(out ACurrent: T): Boolean;\r\nbegin\r\n with TList(Owner) do\r\n begin\r\n Result := FCurrentIndex < FLength;\r\n\r\n if Result then\r\n begin\r\n ACurrent := FArray[FCurrentIndex];\r\n Inc(FCurrentIndex);\r\n end;\r\n end;\r\nend;\r\n\r\n{ TObjectList }\r\n\r\nprocedure TObjectList.HandleElementRemoved(const AElement: T);\r\nbegin\r\n if FOwnsObjects then\r\n TObject(AElement).Free;\r\nend;\r\n\r\nprocedure TObjectList.ReplaceItem(var ACurrent: T; const ANew: T);\r\nbegin\r\n { Only act if owns objects is set. Otherwise fallback to default. }\r\n if (FOwnsObjects) and (TObject(ACurrent) <> TObject(ANew)) then\r\n begin\r\n NotifyElementRemoved(ACurrent);\r\n ACurrent := ANew;\r\n end else\r\n inherited;\r\nend;\r\n\r\n{ TSortedList }\r\n\r\nprocedure TSortedList.InternalInsert(const AIndex: NativeInt; const AValue: T);\r\nvar\r\n I: NativeInt;\r\nbegin\r\n ASSERT(AIndex <= FLength);\r\n ASSERT(AIndex >= 0);\r\n\r\n if FLength = Length(FArray) then\r\n Grow();\r\n\r\n { Move the array to the right }\r\n if AIndex < FLength then\r\n for I := FLength downto (AIndex + 1) do\r\n FArray[I] := FArray[I - 1];\r\n\r\n Inc(FLength);\r\n\r\n { Put the element into the new position }\r\n FArray[AIndex] := AValue;\r\n NotifyCollectionChanged();\r\nend;\r\n\r\nprocedure TSortedList.AddAll(const ACollection: IEnumerable);\r\nvar\r\n LValue: T;\r\nbegin\r\n if not Assigned(ACollection) then\r\n ExceptionHelper.Throw_ArgumentNilError('ACollection');\r\n\r\n { Enumerate and add, preserving order}\r\n for LValue in ACollection do\r\n Add(LValue);\r\nend;\r\n\r\nprocedure TSortedList.Add(const AValue: T);\r\nvar\r\n LLeft, LRight, LMiddle: NativeInt;\r\n LCompareResult, LSignFix: NativeInt;\r\nbegin\r\n { Case 1, empty list, optimize }\r\n if FLength = 0 then\r\n InternalInsert(0, AValue)\r\n else\r\n begin\r\n { Sign fix }\r\n if FAscending then\r\n LSignFix := 1\r\n else\r\n LSignFix := -1;\r\n\r\n { Check for valid type support }\r\n LLeft := 0;\r\n LRight := LLeft + FLength - 1;\r\n\r\n while (LLeft <= LRight) do\r\n begin\r\n LMiddle := (LLeft + LRight) div 2;\r\n LCompareResult := CompareElements(FArray[LMiddle], AValue) * LSignFix;\r\n\r\n if LCompareResult > 0 then\r\n LRight := LMiddle - 1\r\n else if LCompareResult < 0 then\r\n LLeft := LMiddle + 1\r\n else\r\n Break;\r\n end;\r\n\r\n { LMiddle is located on the approximative spot. Let's see }\r\n if (LCompareResult = 0) or (LCompareResult > 0) then\r\n InternalInsert(LMiddle, AValue)\r\n else\r\n InternalInsert(LMiddle + 1, AValue);\r\n end;\r\nend;\r\n\r\nconstructor TSortedList.Create(const ARules: TRules);\r\nbegin\r\n Create(ARules, CDefaultSize, True);\r\nend;\r\n\r\nconstructor TSortedList.Create();\r\nbegin\r\n Create(TRules.Default, CDefaultSize, True);\r\nend;\r\n\r\nconstructor TSortedList.Create(const ARules: TRules; const AInitialCapacity: NativeInt; const AAscending: Boolean);\r\nbegin\r\n inherited Create(ARules, AInitialCapacity);\r\n FAscending := AAscending;\r\nend;\r\n\r\nprocedure TSortedList.Insert(const AIndex: NativeInt; const AValue: T);\r\nbegin\r\n ExceptionHelper.Throw_OperationNotSupported('Insert');\r\nend;\r\n\r\nprocedure TSortedList.InsertAll(const AIndex: NativeInt; const ACollection: IEnumerable);\r\nbegin\r\n ExceptionHelper.Throw_OperationNotSupported('Insert');\r\nend;\r\n\r\nfunction TSortedList.BinarySearch(const AElement: T; const AStartIndex, ACount: NativeInt;\r\n const AAscending: Boolean): NativeInt;\r\nvar\r\n LLeft, LRight, LMiddle: NativeInt;\r\n LCompareResult: NativeInt;\r\nbegin\r\n { Do not search for 0 count }\r\n if ACount = 0 then\r\n begin\r\n Result := -1;\r\n Exit;\r\n end;\r\n\r\n LLeft := AStartIndex;\r\n LRight := LLeft + ACount - 1;\r\n\r\n while (LLeft <= LRight) do\r\n begin\r\n LMiddle := (LLeft + LRight) div 2;\r\n LCompareResult := CompareElements(FArray[LMiddle], AElement);\r\n\r\n if not AAscending then\r\n LCompareResult := LCompareResult * -1;\r\n\r\n if LCompareResult > 0 then\r\n LRight := LMiddle - 1\r\n else if LCompareResult < 0 then\r\n LLeft := LMiddle + 1\r\n else begin\r\n Result := LMiddle - AStartIndex;\r\n Exit;\r\n end;\r\n end;\r\n\r\n Result := -1;\r\nend;\r\n\r\nfunction TSortedList.IndexOf(const AValue: T): NativeInt;\r\nvar\r\n I, J: NativeInt;\r\nbegin\r\n { Search for the value }\r\n J := BinarySearch(AValue, 0, FLength, FAscending);\r\n\r\n if J = -1 then\r\n Exit(-1);\r\n\r\n for I := J - 1 downto 0 do\r\n if not ElementsAreEqual(AValue, FArray[I]) then\r\n begin\r\n Result := I + 1;\r\n Exit;\r\n end;\r\n\r\n Result := J;\r\nend;\r\n\r\nfunction TSortedList.Max: T;\r\nbegin\r\n if FAscending then\r\n Result := Last()\r\n else\r\n Result := First();\r\nend;\r\n\r\nfunction TSortedList.Min: T;\r\nbegin\r\n if FAscending then\r\n Result := First()\r\n else\r\n Result := Last();\r\nend;\r\n\r\nprocedure TSortedList.SetItem(const AIndex: NativeInt; const AValue: T);\r\nbegin\r\n ExceptionHelper.Throw_OperationNotSupported('SetItem');\r\nend;\r\n\r\nfunction TSortedList.LastIndexOf(const AValue: T): NativeInt;\r\nvar\r\n I, J: NativeInt;\r\nbegin\r\n { Search for the value }\r\n J := BinarySearch(AValue, 0, FLength, FAscending);\r\n\r\n if J = -1 then\r\n Exit(-1);\r\n\r\n for I := J + 1 to FLength - 1 do\r\n if not ElementsAreEqual(AValue, FArray[I]) then\r\n begin\r\n Result := I - 1;\r\n Exit;\r\n end;\r\n\r\n Result := J;\r\nend;\r\n\r\n{ TObjectSortedList }\r\n\r\nprocedure TObjectSortedList.HandleElementRemoved(const AElement: T);\r\nbegin\r\n if FOwnsObjects then\r\n TObject(AElement).Free;\r\nend;\r\n\r\n{ TLinkedList }\r\n\r\nprocedure TLinkedList.Clear;\r\nvar\r\n LCurrent, LNext: PEntry;\r\nbegin\r\n if FFirst <> nil then\r\n begin\r\n LCurrent := FFirst;\r\n while Assigned(LCurrent) do\r\n begin\r\n NotifyElementRemoved(LCurrent^.FValue);\r\n\r\n { Release}\r\n LNext := LCurrent^.FNext;\r\n ReleaseEntry(LCurrent);\r\n LCurrent := LNext;\r\n end;\r\n\r\n FFirst := nil;\r\n FLast := nil;\r\n FCount := 0;\r\n\r\n NotifyCollectionChanged();\r\n end;\r\nend;\r\n\r\nprocedure TLinkedList.CopyTo(var AArray: array of T; const AStartIndex: NativeInt);\r\nvar\r\n X: NativeInt;\r\n LCurrent: PEntry;\r\nbegin\r\n { Check for indexes }\r\n if (AStartIndex >= Length(AArray)) or (AStartIndex < 0) then\r\n ExceptionHelper.Throw_ArgumentOutOfRangeError('AStartIndex');\r\n\r\n if (Length(AArray) - AStartIndex) < FCount then\r\n ExceptionHelper.Throw_ArgumentOutOfSpaceError('AArray');\r\n\r\n X := AStartIndex;\r\n LCurrent := FFirst;\r\n while Assigned(LCurrent) do\r\n begin\r\n AArray[X] := LCurrent^.FValue;\r\n Inc(X);\r\n LCurrent := LCurrent^.FNext;\r\n end;\r\nend;\r\n\r\nconstructor TLinkedList.Create;\r\nbegin\r\n Create(TRules.Default);\r\nend;\r\n\r\nconstructor TLinkedList.Create(const ARules: TRules);\r\nbegin\r\n inherited Create(ARules);\r\n FCanCache := True;\r\nend;\r\n\r\ndestructor TLinkedList.Destroy;\r\nvar\r\n LNext: PEntry;\r\nbegin\r\n FCanCache := False;\r\n\r\n if FFreeCount > 0 then\r\n while Assigned(FFirstFree) do\r\n begin\r\n LNext := FFirstFree^.FNext;\r\n\r\n { Delphi doesn finalize this }\r\n FFirstFree^.FValue := default(T);\r\n\r\n FreeMem(FFirstFree);\r\n FFirstFree := LNext;\r\n end;\r\n\r\n inherited;\r\nend;\r\n\r\nfunction TLinkedList.Empty: Boolean;\r\nbegin\r\n Result := not Assigned(FFirst);\r\nend;\r\n\r\nfunction TLinkedList.First: T;\r\nbegin\r\n if not Assigned(FFirst) then\r\n ExceptionHelper.Throw_CollectionEmptyError();\r\n\r\n Result := FFirst^.FValue;\r\nend;\r\n\r\nfunction TLinkedList.FirstOrDefault(const ADefault: T): T;\r\nbegin\r\n if not Assigned(FFirst) then\r\n Result := ADefault\r\n else\r\n Result := FFirst^.FValue;\r\nend;\r\n\r\nfunction TLinkedList.GetCount: NativeInt;\r\nbegin\r\n Result := FCount;\r\nend;\r\n\r\nfunction TLinkedList.GetEnumerator: IEnumerator;\r\nvar\r\n LEnumerator: TEnumerator;\r\nbegin\r\n LEnumerator := TEnumerator.Create(Self);\r\n LEnumerator.FCurrentEntry := FFirst;\r\n Result := LEnumerator;\r\nend;\r\n\r\nfunction TLinkedList.IndexOf(const AValue: T): NativeInt;\r\nvar\r\n LCurrent: PEntry;\r\nbegin\r\n LCurrent := FFirst;\r\n Result := 0;\r\n while Assigned(LCurrent) do\r\n begin\r\n { Check elements }\r\n if ElementsAreEqual(AValue, LCurrent^.FValue) then\r\n Exit;\r\n\r\n LCurrent := LCurrent^.FNext;\r\n Inc(Result);\r\n end;\r\n\r\n Result := -1;\r\nend;\r\n\r\nprocedure TLinkedList.Insert(const AIndex: NativeInt; const AValue: T);\r\nvar\r\n LCurrent, LNew: PEntry;\r\nbegin\r\n if AIndex = FCount then\r\n LCurrent := nil\r\n else\r\n LCurrent := EntryAt(AIndex);\r\n\r\n { Make our node! Insert it to the list }\r\n LNew := NeedEntry(AValue);\r\n\r\n if Assigned(LCurrent) then\r\n begin\r\n LNew^.FPrev := LCurrent^.FPrev;\r\n\r\n if Assigned(LCurrent^.FPrev) then\r\n LCurrent^.FPrev^.FNext := LNew;\r\n\r\n LCurrent^.FPrev := LNew;\r\n\r\n if FFirst = LCurrent then\r\n FFirst := LNew;\r\n end else\r\n begin\r\n LNew^.FPrev := FLast;\r\n\r\n if Assigned(FLast) then\r\n FLast^.FNext := LNew;\r\n\r\n FLast := LNew;\r\n end;\r\n\r\n LNew^.FNext := LCurrent;\r\n if LCurrent = FFirst then\r\n FFirst := LNew;\r\n\r\n NotifyCollectionChanged();\r\n Inc(FCount);\r\nend;\r\n\r\nprocedure TLinkedList.InsertAll(const AIndex: NativeInt; const ACollection: IEnumerable);\r\nvar\r\n LCurrent, LNewFirst, LNewLast, LNew: PEntry;\r\n LValue: T;\r\nbegin\r\n if not Assigned(ACollection) then\r\n ExceptionHelper.Throw_ArgumentNilError('ACollection');\r\n\r\n if AIndex = FCount then\r\n LCurrent := nil\r\n else\r\n LCurrent := EntryAt(AIndex);\r\n\r\n { Build up the chain from the input collection }\r\n LNewFirst := nil;\r\n LNewLast := nil;\r\n for LValue in ACollection do\r\n begin\r\n LNew := NeedEntry(LValue);\r\n LNew^.FPrev := LNewLast;\r\n LNew^.FNext := nil;\r\n\r\n if Assigned(LNewLast) then\r\n LNewLast^.FNext := LNew;\r\n\r\n LNewLast := LNew;\r\n\r\n if not Assigned(LNewFirst) then\r\n LNewFirst := LNew;\r\n\r\n Inc(FCount);\r\n end;\r\n\r\n if not Assigned(LNewFirst) then\r\n Exit;\r\n\r\n { The chain is created! now append it to this list's chain }\r\n if Assigned(LCurrent) then\r\n begin\r\n LNewFirst^.FPrev := LCurrent^.FPrev;\r\n\r\n if Assigned(LCurrent^.FPrev) then\r\n LCurrent^.FPrev^.FNext := LNewFirst;\r\n\r\n LCurrent^.FPrev := LNewLast;\r\n\r\n if FFirst = LCurrent then\r\n FFirst := LNewFirst;\r\n end else\r\n begin\r\n LNewFirst^.FPrev := FLast;\r\n\r\n if Assigned(FLast) then\r\n FLast^.FNext := LNewFirst;\r\n\r\n FLast := LNewLast;\r\n end;\r\n\r\n LNewLast^.FNext := LCurrent;\r\n if LCurrent = FFirst then\r\n FFirst := LNewFirst;\r\n\r\n NotifyCollectionChanged();\r\nend;\r\n\r\nfunction TLinkedList.Last: T;\r\nbegin\r\n if not Assigned(FLast) then\r\n ExceptionHelper.Throw_CollectionEmptyError();\r\n\r\n Result := FLast^.FValue;\r\nend;\r\n\r\nfunction TLinkedList.LastIndexOf(const AValue: T): NativeInt;\r\nvar\r\n LCurrent: PEntry;\r\nbegin\r\n LCurrent := FLast;\r\n Result := FCount - 1;\r\n while Assigned(LCurrent) do\r\n begin\r\n { Check elements }\r\n if ElementsAreEqual(AValue, LCurrent^.FValue) then\r\n Exit;\r\n\r\n LCurrent := LCurrent^.FPrev;\r\n Dec(Result);\r\n end;\r\n\r\n Result := -1;\r\nend;\r\n\r\nfunction TLinkedList.LastOrDefault(const ADefault: T): T;\r\nbegin\r\n if not Assigned(FLast) then\r\n Result := ADefault\r\n else\r\n Result := FLast^.FValue;\r\nend;\r\n\r\nfunction TLinkedList.NeedEntry(const AValue: T): PEntry;\r\nbegin\r\n if FFreeCount > 0 then\r\n begin\r\n Result := FFirstFree;\r\n FFirstFree := FFirstFree^.FNext;\r\n\r\n Dec(FFreeCount);\r\n end else\r\n Result := AllocMem(SizeOf(TEntry));\r\n\r\n { Initialize the node }\r\n Result^.FValue := AValue;\r\nend;\r\n\r\nfunction TLinkedList.EntryAt(const AIndex: NativeInt; const AThrow: Boolean): PEntry;\r\nvar\r\n LIndex: NativeInt;\r\nbegin\r\n if ((AIndex >= FCount)) or (AIndex < 0) then\r\n if AThrow then\r\n ExceptionHelper.Throw_ArgumentOutOfRangeError('AIndex')\r\n else\r\n Exit(nil);\r\n\r\n { Find the position }\r\n if AIndex = (FCount - 1) then\r\n Result := FLast\r\n else if AIndex = 0 then\r\n Result := FFirst\r\n else begin\r\n Result := FFirst;\r\n LIndex := 0;\r\n while Assigned(Result) do\r\n begin\r\n if LIndex = AIndex then\r\n Exit;\r\n\r\n Result := Result^.FNext;\r\n Inc(LIndex);\r\n end;\r\n\r\n { Should never happen }\r\n if AThrow then\r\n ExceptionHelper.Throw_ArgumentOutOfRangeError('AIndex')\r\n else\r\n Exit(nil);\r\n end;\r\nend;\r\n\r\nprocedure TLinkedList.ReleaseEntry(const AEntry: PEntry);\r\nbegin\r\n if (FFreeCount = CDefaultSize) or not FCanCache then\r\n begin\r\n { Delphi doesn finalize this }\r\n AEntry^.FValue := default(T);\r\n FreeMem(AEntry);\r\n end else begin\r\n { Place the entry into the cache }\r\n AEntry^.FNext := FFirstFree;\r\n FFirstFree := AEntry;\r\n\r\n Inc(FFreeCount);\r\n end;\r\nend;\r\n\r\nprocedure TLinkedList.Remove(const AValue: T);\r\nvar\r\n LCurrent: PEntry;\r\nbegin\r\n LCurrent := FFirst;\r\n while Assigned(LCurrent) do\r\n begin\r\n if ElementsAreEqual(AValue, LCurrent^.FValue) then\r\n begin\r\n { Remove the node }\r\n if Assigned(LCurrent^.FPrev) then\r\n LCurrent^.FPrev^.FNext := LCurrent^.FNext;\r\n if Assigned(LCurrent^.FNext) then\r\n LCurrent^.FNext^.FPrev := LCurrent^.FPrev;\r\n if FFirst = LCurrent then\r\n FFirst := LCurrent^.FNext;\r\n if FLast = LCurrent then\r\n FLast := LCurrent^.FPrev;\r\n\r\n ReleaseEntry(LCurrent);\r\n NotifyCollectionChanged();\r\n Dec(FCount);\r\n Exit;\r\n end;\r\n\r\n LCurrent := LCurrent^.FNext;\r\n end;\r\nend;\r\n\r\nprocedure TLinkedList.SetItem(const AIndex: NativeInt; const AValue: T);\r\nbegin\r\n { Delegate }\r\n ReplaceItem(EntryAt(AIndex)^.FValue, AValue);\r\n\r\n { Increment version }\r\n NotifyCollectionChanged();\r\nend;\r\n\r\nfunction TLinkedList.Single: T;\r\nbegin\r\n { Check length }\r\n if not Assigned(FFirst) then\r\n ExceptionHelper.Throw_CollectionEmptyError()\r\n else if FFirst <> FLast then\r\n ExceptionHelper.Throw_CollectionHasMoreThanOneElement()\r\n else\r\n Result := FFirst^.FValue;\r\nend;\r\n\r\nfunction TLinkedList.SingleOrDefault(const ADefault: T): T;\r\nbegin\r\n { Check length }\r\n if not Assigned(FFirst) then\r\n Result := ADefault\r\n else if FFirst <> FLast then\r\n ExceptionHelper.Throw_CollectionHasMoreThanOneElement()\r\n else\r\n Result := FFirst^.FValue;\r\nend;\r\n\r\nfunction TLinkedList.TryExtractAt(const AIndex: NativeInt; out AValue: T): Boolean;\r\nvar\r\n LCurrent: PEntry;\r\nbegin\r\n Result := False;\r\n LCurrent := EntryAt(AIndex, False);\r\n\r\n if not Assigned(LCurrent) then\r\n Exit;\r\n\r\n AValue := LCurrent^.FValue;\r\n\r\n { Remove the node }\r\n if Assigned(LCurrent^.FPrev) then\r\n LCurrent^.FPrev^.FNext := LCurrent^.FNext;\r\n if Assigned(LCurrent^.FNext) then\r\n LCurrent^.FNext^.FPrev := LCurrent^.FPrev;\r\n if FFirst = LCurrent then\r\n FFirst := LCurrent^.FNext;\r\n if FLast = LCurrent then\r\n FLast := LCurrent^.FPrev;\r\n\r\n ReleaseEntry(LCurrent);\r\n Result := True;\r\n\r\n NotifyCollectionChanged();\r\n Dec(FCount);\r\nend;\r\n\r\nfunction TLinkedList.TryGetItemAt(const AIndex: NativeInt; out AValue: T): Boolean;\r\nvar\r\n LEntry: PEntry;\r\nbegin\r\n LEntry := EntryAt(AIndex, False);\r\n\r\n if Assigned(LEntry) then\r\n begin\r\n Result := True;\r\n AValue := LEntry^.FValue;\r\n end else\r\n Result := False;\r\nend;\r\n\r\n{ TLinkedList.TEnumerator }\r\n\r\nfunction TLinkedList.TEnumerator.TryMoveNext(out ACurrent: T): Boolean;\r\nbegin\r\n Result := Assigned(FCurrentEntry);\r\n if Result then\r\n begin\r\n ACurrent := FCurrentEntry^.FValue;\r\n FCurrentEntry := FCurrentEntry^.FNext;\r\n end;\r\nend;\r\n\r\n{ TObjectLinkedList }\r\n\r\nprocedure TObjectLinkedList.HandleElementRemoved(const AElement: T);\r\nbegin\r\n if FOwnsObjects then\r\n TObject(AElement).Free;\r\nend;\r\n\r\nprocedure TObjectLinkedList.ReplaceItem(var ACurrent: T; const ANew: T);\r\nbegin\r\n { Only act if owns objects is set. Otherwise fallback to default. }\r\n if (FOwnsObjects) and (TObject(ACurrent) <> TObject(ANew)) then\r\n begin\r\n NotifyElementRemoved(ACurrent);\r\n ACurrent := ANew;\r\n end else\r\n inherited;\r\nend;\r\n\r\n{ TSortedLinkedList }\r\n\r\nprocedure TSortedLinkedList.Add(const AValue: T);\r\nvar\r\n LCurrent, LNew: PEntry;\r\n LSign: NativeInt;\r\nbegin\r\n if FAscending then\r\n LSign := 1\r\n else\r\n LSign := -1;\r\n\r\n LCurrent := FFirst;\r\n\r\n while Assigned(LCurrent) do\r\n begin\r\n if ((CompareElements(AValue, LCurrent^.FValue) * LSign) < 0) then\r\n Break;\r\n\r\n LCurrent := LCurrent^.FNext;\r\n end;\r\n\r\n { Make our node! Insert it to the list }\r\n LNew := NeedEntry(AValue);\r\n\r\n if Assigned(LCurrent) then\r\n begin\r\n LNew^.FPrev := LCurrent^.FPrev;\r\n\r\n if Assigned(LCurrent^.FPrev) then\r\n LCurrent^.FPrev^.FNext := LNew;\r\n\r\n LCurrent^.FPrev := LNew;\r\n\r\n if FFirst = LCurrent then\r\n FFirst := LNew;\r\n end else\r\n begin\r\n LNew^.FPrev := FLast;\r\n\r\n if Assigned(FLast) then\r\n FLast^.FNext := LNew;\r\n\r\n FLast := LNew;\r\n end;\r\n\r\n LNew^.FNext := LCurrent;\r\n if LCurrent = FFirst then\r\n FFirst := LNew;\r\n\r\n\r\n NotifyCollectionChanged();\r\n Inc(FCount);\r\nend;\r\n\r\nprocedure TSortedLinkedList.AddAll(const ACollection: IEnumerable);\r\nvar\r\n LValue: T;\r\nbegin\r\n { Check input }\r\n if not Assigned(ACollection) then\r\n ExceptionHelper.Throw_ArgumentNilError('ACollection');\r\n\r\n for LValue in ACollection do\r\n Add(LValue);\r\nend;\r\n\r\nconstructor TSortedLinkedList.Create();\r\nbegin\r\n Create(TRules.Default, True);\r\nend;\r\n\r\nconstructor TSortedLinkedList.Create(const ARules: TRules);\r\nbegin\r\n Create(ARules, True);\r\nend;\r\n\r\nconstructor TSortedLinkedList.Create(const ARules: TRules; const AAscending: Boolean);\r\nbegin\r\n inherited Create(ARules);\r\n FAscending := AAscending;\r\nend;\r\n\r\nprocedure TSortedLinkedList.Insert(const AIndex: NativeInt; const AValue: T);\r\nbegin\r\n ExceptionHelper.Throw_OperationNotSupported('Insert');\r\nend;\r\n\r\nprocedure TSortedLinkedList.InsertAll(const AIndex: NativeInt; const ACollection: IEnumerable);\r\nbegin\r\n ExceptionHelper.Throw_OperationNotSupported('Insert');\r\nend;\r\n\r\nfunction TSortedLinkedList.Max: T;\r\nbegin\r\n if not Assigned(FFirst) then\r\n ExceptionHelper.Throw_CollectionEmptyError();\r\n\r\n if FAscending then\r\n Result := FLast^.FValue\r\n else\r\n Result := FFirst^.FValue;\r\nend;\r\n\r\nfunction TSortedLinkedList.Min: T;\r\nbegin\r\n if not Assigned(FFirst) then\r\n ExceptionHelper.Throw_CollectionEmptyError();\r\n\r\n if FAscending then\r\n Result := FFirst^.FValue\r\n else\r\n Result := FLast^.FValue;\r\nend;\r\n\r\nprocedure TSortedLinkedList.SetItem(const AIndex: NativeInt; const AValue: T);\r\nbegin\r\n ExceptionHelper.Throw_OperationNotSupported('SetItem');\r\nend;\r\n\r\n{ TObjectSortedLinkedList }\r\n\r\nprocedure TObjectSortedLinkedList.HandleElementRemoved(const AElement: T);\r\nbegin\r\n if FOwnsObjects then\r\n TObject(AElement).Free;\r\nend;\r\n\r\nend.\r\n" }, { "path": "Collections/Collections.MultiMaps.pas", "content": "(*\r\n* Copyright (c) 2009-2012, Ciobanu Alexandru\r\n* All rights reserved.\r\n*\r\n* Redistribution and use in source and binary forms, with or without\r\n* modification, are permitted provided that the following conditions are met:\r\n* * Redistributions of source code must retain the above copyright\r\n* notice, this list of conditions and the following disclaimer.\r\n* * Redistributions in binary form must reproduce the above copyright\r\n* notice, this list of conditions and the following disclaimer in the\r\n* documentation and/or other materials provided with the distribution.\r\n* * Neither the name of the nor the\r\n* names of its contributors may be used to endorse or promote products\r\n* derived from this software without specific prior written permission.\r\n*\r\n* THIS SOFTWARE IS PROVIDED BY THE AUTHOR ''AS IS'' AND ANY\r\n* EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED\r\n* WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE\r\n* DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY\r\n* DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES\r\n* (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;\r\n* LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND\r\n* ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT\r\n* (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS\r\n* SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.\r\n*)\r\n\r\nunit Collections.MultiMaps;\r\ninterface\r\nuses SysUtils,\r\n Generics.Defaults,\r\n Generics.Collections,\r\n Collections.Base,\r\n Collections.Lists,\r\n Collections.Sets,\r\n Collections.Dictionaries;\r\n\r\ntype\r\n /// The base abstract class for all multi-maps in this package.\r\n TAbstractMultiMap = class abstract(TAbstractMap, IMultiMap)\r\n private type\r\n {$REGION 'Internal Types'}\r\n TEnumerator = class(TAbstractEnumerator>)\r\n private\r\n FDictionaryEnumerator: IEnumerator>>;\r\n FCollectionEnumerator: IEnumerator;\r\n public\r\n constructor Create(const AOwner: TAbstractMultiMap);\r\n function TryMoveNext(out ACurrent: TPair): Boolean; override;\r\n end;\r\n\r\n TValueEnumerator = class(TAbstractEnumerator)\r\n private\r\n FOwnerEnumerator: IEnumerator>;\r\n public\r\n constructor Create(const AOwner: TAbstractMultiMap);\r\n function TryMoveNext(out ACurrent: TValue): Boolean; override;\r\n end;\r\n\r\n TValueSequence = class(TSequence)\r\n private\r\n FOwner: TAbstractMultiMap;\r\n protected\r\n function GetCount(): NativeInt; override;\r\n public\r\n constructor Create(const AOwner: TAbstractMultiMap);\r\n function GetEnumerator(): IEnumerator; override;\r\n procedure CopyTo(var AArray: array of TValue; const AStartIndex: NativeInt); overload; override;\r\n function Empty(): Boolean; override;\r\n end;\r\n {$ENDREGION}\r\n\r\n private\r\n FKnownCount: NativeInt;\r\n FEmpty: ICollection;\r\n FKeyCollection: ISequence;\r\n FValueCollection: ISequence;\r\n FDictionary: IDictionary>;\r\n FLastKey: TKey;\r\n FLastCollection: ICollection;\r\n\r\n protected\r\n /// Specifies the internal dictionary used as back-end.\r\n /// A dictionary of lists used as back-end.\r\n property Dictionary: IDictionary> read FDictionary;\r\n\r\n /// Returns the number of pairs in the multi-map.\r\n /// A positive value specifying the total number of pairs in the multi-map.\r\n /// The value returned by this method represents the total number of key-value pairs\r\n /// stored in the dictionary. In a multi-map, this means that each value associated with a key\r\n /// is calculated as a pair. If a key has multiple values associated with it, each key-value\r\n /// combination is calculated as one.\r\n function GetCount(): NativeInt; override;\r\n\r\n /// Returns the collection of values associated with a key.\r\n /// The key for which to obtain the associated values.\r\n /// An Enex collection that contains the values associated with this key.\r\n /// The key is not found in the collection.\r\n function GetValues(const AKey: TKey): ISequence;\r\n\r\n /// Called when the map needs to initialize its internal dictionary.\r\n /// The rule set describing the keys.\r\n function CreateDictionary(const AKeyRules: TRules): IDictionary>; virtual; abstract;\r\n\r\n /// Called when the map needs to initialize a list associated with a key.\r\n /// The rule set describing the values.\r\n function CreateCollection(const AValueRules: TRules): ICollection; virtual; abstract;\r\n public\r\n /// Creates a new multi-map collection.\r\n /// A rule set describing the keys in the map.\r\n /// A rule set describing the values in the map.\r\n constructor Create(const AKeyRules: TRules; const AValueRules: TRules);\r\n\r\n /// Clears the contents of the multi-map.\r\n procedure Clear(); override;\r\n\r\n /// Adds a key-value pair to the multi-map.\r\n /// The key of the pair.\r\n /// The value associated with the key.\r\n /// The multi-map already contains a pair with the given key.\r\n procedure Add(const AKey: TKey; const AValue: TValue); overload; override;\r\n\r\n /// Removes a key-value pair using a given key.\r\n /// The key of pair.\r\n /// If the specified key was not found in the multi-map, nothing happens.\r\n procedure Remove(const AKey: TKey); overload; override;\r\n\r\n /// Extracts all values using their key.\r\n /// The key of the associated values.\r\n /// A collection of values associated with the key.\r\n /// This function is identical to RemoveKey but will return the associated values. If there is no given key, an exception is raised.\r\n /// The is not part of the map.\r\n function ExtractValues(const AKey: TKey): ISequence;\r\n\r\n /// Removes a key-value pair using a given key and value.\r\n /// The key associated with the value.\r\n /// The value to remove.\r\n /// A multi-map allows storing multiple values for a given key. This method allows removing only the\r\n /// specified value from the collection of values associated with the given key.\r\n procedure RemovePair(const AKey: TKey; const AValue: TValue); overload;\r\n\r\n /// Removes a key-value pair using a given key and value.\r\n /// The key and its associated value to remove.\r\n /// A multi-map allows storing multiple values for a given key. This method allows removing only the\r\n /// specified value from the collection of values associated with the given key.\r\n procedure RemovePair(const APair: TPair); overload;\r\n\r\n /// Checks whether the multi-map contains a key-value pair identified by the given key.\r\n /// The key to check for.\r\n /// True if the map contains a pair identified by the given key; False otherwise.\r\n function ContainsKey(const AKey: TKey): Boolean; override;\r\n\r\n /// Checks whether the multi-map contains a key-value pair that contains a given value.\r\n /// The value to check for.\r\n /// True if the multi-map contains a pair containing the given value; False otherwise.\r\n function ContainsValue(const AValue: TValue): Boolean; overload; override;\r\n\r\n /// Checks whether the multi-map contains a given key-value combination.\r\n /// The key associated with the value.\r\n /// The value associated with the key.\r\n /// True if the map contains the given association; False otherwise.\r\n function ContainsPair(const AKey: TKey; const AValue: TValue): Boolean; overload;\r\n\r\n /// Checks whether the multi-map contains a given key-value combination.\r\n /// The key-value pair to check for.\r\n /// True if the map contains the given association; False otherwise.\r\n function ContainsPair(const APair: TPair): Boolean; overload;\r\n\r\n /// Tries to extract the collection of values associated with a key.\r\n /// The key for which to obtain the associated values.\r\n /// The Enex collection that stores the associated values.\r\n /// True if the key exists in the collection; False otherwise.\r\n function TryGetValues(const AKey: TKey; out AValues: ISequence): Boolean; overload;\r\n\r\n /// Tries to extract the collection of values associated with a key.\r\n /// The key for which to obtain the associated values.\r\n /// The associated collection if the key is valid; an empty collection otherwise.\r\n function TryGetValues(const AKey: TKey): ISequence; overload;\r\n\r\n /// Returns the collection of values associated with a key.\r\n /// The key for which to obtain the associated values.\r\n /// An Enex collection that contains the values associated with this key.\r\n /// The key is not found in the multi-map.\r\n property Items[const AKey: TKey]: ISequence read GetValues; default;\r\n\r\n /// Returns the number of pairs in the multi-map.\r\n /// A positive value specifying the total number of pairs in the multi-map.\r\n /// The value returned by this method represents the total number of key-value pairs\r\n /// stored in the dictionary. In a multi-map, this means that each value associated with a key\r\n /// is calculated as a pair. If a key has multiple values associated with it, each key-value\r\n /// combination is calculated as one.\r\n property Count: NativeInt read FKnownCount;\r\n\r\n /// Specifies the collection that contains only the keys.\r\n /// An Enex collection that contains all the keys stored in the multi-map.\r\n property Keys: ISequence read FKeyCollection;\r\n\r\n /// Specifies the collection that contains only the values.\r\n /// An Enex collection that contains all the values stored in the multi-map.\r\n property Values: ISequence read FValueCollection;\r\n\r\n /// Returns a new enumerator object used to enumerate this multi-map.\r\n /// This method is usually called by compiler-generated code. Its purpose is to create an enumerator\r\n /// object that is used to actually traverse the multi-map.\r\n /// An enumerator object.\r\n function GetEnumerator(): IEnumerator>; override;\r\n\r\n /// Copies the values stored in the multi-map to a given array.\r\n /// An array where to copy the contents of the multi-map.\r\n /// The index into the array at which the copying begins.\r\n /// This method assumes that has enough space to hold the contents of the multi-map.\r\n /// is out of bounds.\r\n /// The array is not long enough.\r\n procedure CopyTo(var AArray: array of TPair; const AStartIndex: NativeInt); overload; override;\r\n\r\n /// Returns the value associated with the given key.\r\n /// The key for which to return the associated value.\r\n /// The value associated with the given key.\r\n /// No such key in the multi-map.\r\n function ValueForKey(const AKey: TKey): TValue; override;\r\n\r\n /// Checks whether the multi-map contains a given key-value pair.\r\n /// The key part of the pair.\r\n /// The value part of the pair.\r\n /// True if the given key-value pair exists; False otherwise.\r\n function KeyHasValue(const AKey: TKey; const AValue: TValue): Boolean; override;\r\n\r\n /// Returns an Enex collection that contains only the keys.\r\n /// An Enex collection that contains all the keys stored in the multi-map.\r\n function SelectKeys(): ISequence; override;\r\n\r\n /// Returns an Enex collection that contains only the values.\r\n /// An Enex collection that contains all the values stored in the multi-map.\r\n function SelectValues(): ISequence; override;\r\n end;\r\n\r\ntype\r\n /// The generic multi-map collection.\r\n /// This type uses a dictionary and a number of lists to store its\r\n /// keys and values.\r\n TMultiMap = class(TAbstractMultiMap)\r\n private\r\n FInitialCapacity: NativeInt;\r\n\r\n protected\r\n /// Called when the map needs to initialize its internal dictionary.\r\n /// The rule set describing the keys.\r\n /// This method creates a hash-based dictionary used as the underlying back-end for the map.\r\n function CreateDictionary(const AKeyRules: TRules): IDictionary>; override;\r\n\r\n /// Called when the map needs to initialize a list associated with a key.\r\n /// The rule set describing the values.\r\n /// This method creates a simple array-based list. This list is associated with a key and stores the map's\r\n /// values for that key.\r\n function CreateCollection(const AValueRules: TRules): ICollection; override;\r\n public\r\n /// Creates a new multi-map collection.\r\n /// This constructor requests the default rule set. Call the overloaded constructor if\r\n /// specific a set of rules need to be passed.\r\n constructor Create(); overload;\r\n\r\n /// Creates a new multi-map collection.\r\n /// A rule set describing the keys in the map.\r\n /// A rule set describing the values in the map.\r\n constructor Create(const AKeyRules: TRules; const AValueRules: TRules); overload;\r\n\r\n /// Creates a new multi-map collection.\r\n /// A rule set describing the keys in the map.\r\n /// A rule set describing the values in the map.\r\n /// The map's initial capacity.\r\n constructor Create(const AKeyRules: TRules; const AValueRules: TRules;\r\n const AInitialCapacity: NativeInt); overload;\r\n end;\r\n\r\n /// The generic multi-map collection designed to store objects.\r\n /// This type uses a dictionary and a number of lists to store its\r\n /// keys and values.\r\n TObjectMultiMap = class(TMultiMap)\r\n private\r\n FOwnsKeys, FOwnsValues: Boolean;\r\n\r\n protected\r\n /// Frees the key (object) that was removed from the collection.\r\n /// The key that was removed from the collection.\r\n procedure HandleKeyRemoved(const AKey: TKey); override;\r\n\r\n /// Frees the value (object) that was removed from the collection.\r\n /// The value that was removed from the collection.\r\n procedure HandleValueRemoved(const AValue: TValue); override;\r\n public\r\n /// Specifies whether this map owns the keys.\r\n /// True if the map owns the keys; False otherwise.\r\n /// This property specifies the way the map controls the life-time of the stored keys. The value of this property has effect only\r\n /// if the keys are objects, otherwise it is ignored.\r\n property OwnsKeys: Boolean read FOwnsKeys write FOwnsKeys;\r\n\r\n /// Specifies whether this map owns the values.\r\n /// True if the map owns the values; False otherwise.\r\n /// This property specifies the way the map controls the life-time of the stored values. The value of this property has effect only\r\n /// if the values are objects, otherwise it is ignored.\r\n property OwnsValues: Boolean read FOwnsValues write FOwnsValues;\r\n end;\r\n\r\ntype\r\n /// The generic multi-map collection.\r\n /// This type uses a sorted dictionary and a number of lists to store its\r\n /// keys and values.\r\n TSortedMultiMap = class(TAbstractMultiMap)\r\n private\r\n FAscendingSort: Boolean;\r\n\r\n protected\r\n /// Called when the map needs to initialize its internal dictionary.\r\n /// The rule set describing the keys.\r\n /// This method creates an AVL dictionary used as the underlying back-end for the map.\r\n function CreateDictionary(const AKeyRules: TRules): IDictionary>; override;\r\n\r\n /// Called when the map needs to initialize a list associated with a key.\r\n /// The rule set describing the values.\r\n /// This method creates a simple array-based list. This list is associated with a key and store the map's\r\n /// values for that key.\r\n function CreateCollection(const AValueRules: TRules): ICollection; override;\r\n public\r\n /// Creates a new multi-map collection.\r\n /// This constructor requests the default rule set. Call the overloaded constructor if\r\n /// specific a set of rules need to be passed. The keys are stored in ascending order.\r\n constructor Create(); overload;\r\n\r\n /// Creates a new multi-map collection.\r\n /// A rule set describing the keys in the map.\r\n /// A rule set describing the values in the map.\r\n /// The keys are stored in ascending order.\r\n constructor Create(const AKeyRules: TRules; const AValueRules: TRules); overload;\r\n\r\n /// Creates a new multi-map collection.\r\n /// A rule set describing the keys in the map.\r\n /// A rule set describing the values in the map.\r\n /// Pass in a value of True if the keys should be kept in ascending order.\r\n /// Pass in False for descending order.\r\n constructor Create(const AKeyRules: TRules; const AValueRules: TRules; const AAscending: Boolean); overload;\r\n\r\n /// Returns the biggest key.\r\n /// The biggest key stored in the map.\r\n /// The map is empty.\r\n function MaxKey(): TKey; override;\r\n\r\n /// Returns the smallest key.\r\n /// The smallest key stored in the map.\r\n /// The map is empty.\r\n function MinKey(): TKey; override;\r\n end;\r\n\r\n /// The generic multi-map collection designed to store objects.\r\n /// This type uses a sorted dictionary and a number of lists to store its\r\n /// keys and values.\r\n TObjectSortedMultiMap = class(TSortedMultiMap)\r\n private\r\n FOwnsKeys, FOwnsValues: Boolean;\r\n\r\n protected\r\n /// Frees the key (object) that was removed from the collection.\r\n /// The key that was removed from the collection.\r\n procedure HandleKeyRemoved(const AKey: TKey); override;\r\n\r\n /// Frees the value (object) that was removed from the collection.\r\n /// The value that was removed from the collection.\r\n procedure HandleValueRemoved(const AValue: TValue); override;\r\n public\r\n /// Specifies whether this map owns the keys.\r\n /// True if the map owns the keys; False otherwise.\r\n /// This property specifies the way the map controls the life-time of the stored keys. The value of this property has effect only\r\n /// if the keys are objects, otherwise it is ignored.\r\n property OwnsKeys: Boolean read FOwnsKeys write FOwnsKeys;\r\n\r\n /// Specifies whether this map owns the values.\r\n /// True if the map owns the values; False otherwise.\r\n /// This property specifies the way the map controls the life-time of the stored values. The value of this property has effect only\r\n /// if the values are objects, otherwise it is ignored.\r\n property OwnsValues: Boolean read FOwnsValues write FOwnsValues;\r\n end;\r\n\r\ntype\r\n /// The generic multi-map collection.\r\n /// This type uses a dictionary and a number of sets to store its\r\n /// keys and values.\r\n TDistinctMultiMap = class(TAbstractMultiMap)\r\n private\r\n FInitialCapacity: NativeInt;\r\n\r\n protected\r\n /// Called when the map needs to initialize its internal dictionary.\r\n /// The rule set describing the keys.\r\n /// This method creates a hash-based dictionary used as the underlying back-end for the map.\r\n function CreateDictionary(const AKeyRules: TRules): IDictionary>; override;\r\n\r\n /// Called when the map needs to initialize a set associated with a key.\r\n /// The rule set describing the values.\r\n /// This method creates a hash-based set. This set is associated with a key and stores the map's\r\n /// values for that key.\r\n function CreateCollection(const AValueRules: TRules): ICollection; override;\r\n public\r\n /// Creates a new multi-map collection.\r\n /// This constructor requests the default rule set. Call the overloaded constructor if\r\n /// specific a set of rules need to be passed.\r\n constructor Create(); overload;\r\n\r\n /// Creates a new multi-map collection.\r\n /// A rule set describing the keys in the map.\r\n /// A rule set describing the values in the map.\r\n constructor Create(const AKeyRules: TRules; const AValueRules: TRules); overload;\r\n\r\n /// Creates a new multi-map collection.\r\n /// A rule set describing the keys in the map.\r\n /// A rule set describing the values in the map.\r\n /// The map's initial capacity.\r\n constructor Create(const AKeyRules: TRules; const AValueRules: TRules; const AInitialCapacity: NativeInt); overload;\r\n end;\r\n\r\n /// The generic multi-map collection designed to store objects.\r\n /// This type uses a dictionary and a number of sets to store its\r\n /// keys and values.\r\n TObjectDistinctMultiMap = class(TDistinctMultiMap)\r\n private\r\n FOwnsKeys, FOwnsValues: Boolean;\r\n\r\n protected\r\n /// Frees the key (object) that was removed from the collection.\r\n /// The key that was removed from the collection.\r\n procedure HandleKeyRemoved(const AKey: TKey); override;\r\n\r\n /// Frees the value (object) that was removed from the collection.\r\n /// The value that was removed from the collection.\r\n procedure HandleValueRemoved(const AValue: TValue); override;\r\n public\r\n /// Specifies whether this map owns the keys.\r\n /// True if the map owns the keys; False otherwise.\r\n /// This property specifies the way the map controls the life-time of the stored keys. The value of this property has effect only\r\n /// if the keys are objects, otherwise it is ignored.\r\n property OwnsKeys: Boolean read FOwnsKeys write FOwnsKeys;\r\n\r\n /// Specifies whether this map owns the values.\r\n /// True if the map owns the values; False otherwise.\r\n /// This property specifies the way the map controls the life-time of the stored values. The value of this property has effect only\r\n /// if the values are objects, otherwise it is ignored.\r\n property OwnsValues: Boolean read FOwnsValues write FOwnsValues;\r\n end;\r\n\r\ntype\r\n /// The generic distinct multi-map collection.\r\n /// This type uses a sorted dictionary and a number of sorted sets to store its\r\n /// keys and values.\r\n TSortedDistinctMultiMap = class(TAbstractMultiMap)\r\n private\r\n FAscendingSort: Boolean;\r\n\r\n protected\r\n /// Called when the map needs to initialize its internal dictionary.\r\n /// The rule set describing the keys.\r\n /// This method creates an AVL dictionary used as the underlying back-end for the map.\r\n function CreateDictionary(const AKeyRules: TRules): IDictionary>; override;\r\n\r\n /// Called when the map needs to initialize a set associated with a key.\r\n /// The rule set describing the values.\r\n /// This method creates an AVL-based set. This set is associated with a key and stores the map's\r\n /// values for that key.\r\n function CreateCollection(const AValueRules: TRules): ICollection; override;\r\n public\r\n /// Creates a new multi-map collection.\r\n /// This constructor requests the default rule set. Call the overloaded constructor if\r\n /// specific a set of rules need to be passed. The keys are stored in ascending order.\r\n constructor Create(); overload;\r\n\r\n /// Creates a new multi-map collection.\r\n /// A rule set describing the keys in the map.\r\n /// A rule set describing the values in the map.\r\n /// The keys are stored in ascending order.\r\n constructor Create(const AKeyRules: TRules; const AValueRules: TRules); overload;\r\n\r\n /// Creates a new multi-map collection.\r\n /// A rule set describing the keys in the map.\r\n /// A rule set describing the values in the map.\r\n /// Pass in a value of True if the keys should be kept in ascending order.\r\n /// Pass in False for descending order.\r\n constructor Create(const AKeyRules: TRules; const AValueRules: TRules; const AAscending: Boolean); overload;\r\n\r\n /// Returns the biggest key.\r\n /// The biggest key stored in the map.\r\n /// The map is empty.\r\n function MaxKey(): TKey; override;\r\n\r\n /// Returns the smallest key.\r\n /// The smallest key stored in the map.\r\n /// The map is empty.\r\n function MinKey(): TKey; override;\r\n end;\r\n\r\n /// The generic distinct multi-map collection designed to store objects.\r\n /// This type uses a sorted dictionary and a number of sorted sets to store its\r\n /// keys and values.\r\n TObjectSortedDistinctMultiMap = class(TSortedDistinctMultiMap)\r\n private\r\n FOwnsKeys, FOwnsValues: Boolean;\r\n\r\n protected\r\n /// Frees the key (object) that was removed from the collection.\r\n /// The key that was removed from the collection.\r\n procedure HandleKeyRemoved(const AKey: TKey); override;\r\n\r\n /// Frees the value (object) that was removed from the collection.\r\n /// The value that was removed from the collection.\r\n procedure HandleValueRemoved(const AValue: TValue); override;\r\n public\r\n /// Specifies whether this map owns the keys.\r\n /// True if the map owns the keys; False otherwise.\r\n /// This property specifies the way the map controls the life-time of the stored keys. The value of this property has effect only\r\n /// if the keys are objects, otherwise it is ignored.\r\n property OwnsKeys: Boolean read FOwnsKeys write FOwnsKeys;\r\n\r\n /// Specifies whether this map owns the values.\r\n /// True if the map owns the values; False otherwise.\r\n /// This property specifies the way the map controls the life-time of the stored values. The value of this property has effect only\r\n /// if the values are objects, otherwise it is ignored.\r\n property OwnsValues: Boolean read FOwnsValues write FOwnsValues;\r\n end;\r\n\r\ntype\r\n /// The generic multi-map collection.\r\n /// This type uses a sorted dictionary and a number of sorted lists to store its\r\n /// keys and values.\r\n TDoubleSortedMultiMap = class(TSortedMultiMap)\r\n private\r\n FAscendingValues: Boolean;\r\n\r\n protected\r\n /// Called when the map needs to initialize a list associated with a key.\r\n /// The rule set describing the values.\r\n /// This method creates a simple array-based sorted list. This list is associated with a key and stores the map's\r\n /// values for that key.\r\n function CreateCollection(const AValueRules: TRules): ICollection; override;\r\n public\r\n /// Creates a new multi-map collection.\r\n /// This constructor requests the default rule set. Call the overloaded constructor if\r\n /// specific a set of rules need to be passed. The keys and values are stored in ascending order.\r\n constructor Create(); overload;\r\n\r\n /// Creates a new multi-map collection.\r\n /// A rule set describing the keys in the map.\r\n /// A rule set describing the values in the map.\r\n /// The keys and values are stored in ascending order.\r\n constructor Create(const AKeyRules: TRules; const AValueRules: TRules); overload;\r\n\r\n /// Creates a new multi-map collection.\r\n /// A rule set describing the keys in the map.\r\n /// A rule set describing the values in the map.\r\n /// Pass in a value of True if the keys should be kept in ascending order.\r\n /// Pass in False for descending order.\r\n /// Pass in a value of True if the values should be kept in ascending order.\r\n /// Pass in False for descending order.\r\n constructor Create(const AKeyRules: TRules; const AValueRules: TRules;\r\n const AAscendingKeys: Boolean; const AAscendingValues: Boolean); overload;\r\n end;\r\n\r\n /// The generic multi-map collection designed to store objects.\r\n /// This type uses a sorted dictionary and a number of sorted lists to store its\r\n /// keys and values.\r\n TObjectDoubleSortedMultiMap = class(TDoubleSortedMultiMap)\r\n private\r\n FOwnsKeys, FOwnsValues: Boolean;\r\n\r\n protected\r\n /// Frees the key (object) that was removed from the collection.\r\n /// The key that was removed from the collection.\r\n procedure HandleKeyRemoved(const AKey: TKey); override;\r\n\r\n /// Frees the value (object) that was removed from the collection.\r\n /// The value that was removed from the collection.\r\n procedure HandleValueRemoved(const AValue: TValue); override;\r\n public\r\n /// Specifies whether this map owns the keys.\r\n /// True if the map owns the keys; False otherwise.\r\n /// This property specifies the way the map controls the life-time of the stored keys. The value of this property has effect only\r\n /// if the keys are objects, otherwise it is ignored.\r\n property OwnsKeys: Boolean read FOwnsKeys write FOwnsKeys;\r\n\r\n /// Specifies whether this map owns the values.\r\n /// True if the map owns the values; False otherwise.\r\n /// This property specifies the way the map controls the life-time of the stored values. The value of this property has effect only\r\n /// if the values are objects, otherwise it is ignored.\r\n property OwnsValues: Boolean read FOwnsValues write FOwnsValues;\r\n end;\r\n\r\ntype\r\n /// The generic multi-map collection.\r\n /// This type uses a sorted dictionary and a number of sorted sets to store its\r\n /// keys and values.\r\n TDoubleSortedDistinctMultiMap = class(TSortedDistinctMultiMap)\r\n private\r\n FAscendingValues: Boolean;\r\n\r\n protected\r\n /// Called when the map needs to initialize a set associated with a key.\r\n /// The rule set describing the values.\r\n /// This method creates an AVL-based set. This set is associated with a key and stores the map's\r\n /// values for that key.\r\n function CreateCollection(const AValueRules: TRules): ICollection; override;\r\n public\r\n /// Creates a new multi-map collection.\r\n /// This constructor requests the default rule set. Call the overloaded constructor if\r\n /// specific a set of rules need to be passed. The keys and values are stored in ascending order.\r\n constructor Create(); overload;\r\n\r\n /// Creates a new multi-map collection.\r\n /// A rule set describing the keys in the map.\r\n /// A rule set describing the values in the map.\r\n /// The keys and values are stored in ascending order.\r\n constructor Create(const AKeyRules: TRules; const AValueRules: TRules); overload;\r\n\r\n /// Creates a new multi-map collection.\r\n /// A rule set describing the keys in the map.\r\n /// A rule set describing the values in the map.\r\n /// Pass in a value of True if the keys should be kept in ascending order.\r\n /// Pass in False for descending order.\r\n /// Pass in a value of True if the values should be kept in ascending order.\r\n /// Pass in False for descending order.\r\n constructor Create(const AKeyRules: TRules; const AValueRules: TRules;\r\n const AAscendingKeys: Boolean; const AAscendingValues: Boolean); overload;\r\n end;\r\n\r\n /// The generic multi-map collection designed to store objects.\r\n /// This type uses a sorted dictionary and a number of sorted sets to store its\r\n /// keys and values.\r\n TObjectDoubleSortedDistinctMultiMap = class(TDoubleSortedDistinctMultiMap)\r\n private\r\n FOwnsKeys, FOwnsValues: Boolean;\r\n\r\n protected\r\n /// Frees the key (object) that was removed from the collection.\r\n /// The key that was removed from the collection.\r\n procedure HandleKeyRemoved(const AKey: TKey); override;\r\n\r\n /// Frees the value (object) that was removed from the collection.\r\n /// The value that was removed from the collection.\r\n procedure HandleValueRemoved(const AValue: TValue); override;\r\n public\r\n /// Specifies whether this map owns the keys.\r\n /// True if the map owns the keys; False otherwise.\r\n /// This property specifies the way the map controls the life-time of the stored keys. The value of this property has effect only\r\n /// if the keys are objects, otherwise it is ignored.\r\n property OwnsKeys: Boolean read FOwnsKeys write FOwnsKeys;\r\n\r\n /// Specifies whether this map owns the values.\r\n /// True if the map owns the values; False otherwise.\r\n /// This property specifies the way the map controls the life-time of the stored values. The value of this property has effect only\r\n /// if the values are objects, otherwise it is ignored.\r\n property OwnsValues: Boolean read FOwnsValues write FOwnsValues;\r\n end;\r\n\r\nimplementation\r\n\r\n\r\n{ TAbstractMultiMap }\r\n\r\nprocedure TAbstractMultiMap.Add(const AKey: TKey; const AValue: TValue);\r\nbegin\r\n if not KeysAreEqual(AKey, FLastKey) or not Assigned(FLastCollection) then\r\n begin\r\n { Try to look-up what we need. Create a new LList and add it if required. }\r\n if not FDictionary.TryGetValue(AKey, FLastCollection) then\r\n begin\r\n FLastCollection := CreateCollection(ValueRules);\r\n FDictionary[AKey] := FLastCollection;\r\n end;\r\n\r\n FLastKey := AKey;\r\n end;\r\n\r\n { Add the new element to the LList }\r\n FLastCollection.Add(AValue);\r\n\r\n { Increase the version }\r\n Inc(FKnownCount);\r\n NotifyCollectionChanged();\r\nend;\r\n\r\nprocedure TAbstractMultiMap.Clear;\r\nbegin\r\n { Simply clear out the dictionary }\r\n if Assigned(FDictionary) then\r\n FDictionary.Clear();\r\n\r\n { Increase the version }\r\n FKnownCount := 0;\r\n FLastKey := default(TKey);\r\n FLastCollection := nil;\r\n\r\n NotifyCollectionChanged();\r\nend;\r\n\r\nfunction TAbstractMultiMap.ContainsKey(const AKey: TKey): Boolean;\r\nbegin\r\n { Delegate to the dictionary object }\r\n Result := FDictionary.ContainsKey(AKey);\r\nend;\r\n\r\nfunction TAbstractMultiMap.ContainsPAir(const AKey: TKey; const AValue: TValue): Boolean;\r\nvar\r\n LList: ICollection;\r\nbegin\r\n { Try to find .. otherwise fail! }\r\n if FDictionary.TryGetValue(AKey, LList) then\r\n Result := LList.Contains(AValue)\r\n else\r\n Result := false;\r\nend;\r\n\r\nfunction TAbstractMultiMap.ContainsPair(const APair: TPair): Boolean;\r\nbegin\r\n { Call upper function }\r\n Result := ContainsPair(APair.Key, APair.Value);\r\nend;\r\n\r\nfunction TAbstractMultiMap.ContainsValue(const AValue: TValue): Boolean;\r\nvar\r\n LList: ICollection;\r\nbegin\r\n { Iterate over the dictionary }\r\n for LList in FDictionary.Values do\r\n begin\r\n { Is there anything there? }\r\n if LList.Contains(AValue) then\r\n Exit(true);\r\n end;\r\n\r\n { Nothing found }\r\n Result := false;\r\nend;\r\n\r\nprocedure TAbstractMultiMap.CopyTo(var AArray: array of TPair; const AStartIndex: NativeInt);\r\nvar\r\n LKey: TKey;\r\n LArray: TArray;\r\n LList: ICollection;\r\n X, I, LCount: NativeInt;\r\nbegin\r\n { Check for indexes }\r\n if (AStartIndex >= Length(AArray)) or (AStartIndex < 0) then\r\n ExceptionHelper.Throw_ArgumentOutOfRangeError('AStartIndex');\r\n\r\n if (Length(AArray) - AStartIndex) < Count then\r\n ExceptionHelper.Throw_ArgumentOutOfSpaceError('AArray');\r\n\r\n X := AStartIndex;\r\n\r\n { Iterate over all lists and copy thtm to array }\r\n for LKey in FDictionary.Keys do\r\n begin\r\n LList := FDictionary[LKey];\r\n LCount := LList.Count;\r\n SetLength(LArray, LCount);\r\n LList.CopyTo(LArray, 0);\r\n\r\n for I := 0 to LCount - 1 do\r\n begin\r\n AArray[X + I].Key := LKey;\r\n AArray[X + I].Value := LArray[I];\r\n end;\r\n\r\n Inc(X, LCount);\r\n end;\r\nend;\r\n\r\nconstructor TAbstractMultiMap.Create(\r\n const AKeyRules: TRules;\r\n const AValueRules: TRules);\r\nbegin\r\n { Install the types }\r\n inherited Create(AKeyRules, AValueRules);\r\n\r\n { Create the dictionary }\r\n FDictionary := CreateDictionary(KeyRules);\r\n\r\n FKeyCollection := FDictionary.Keys;\r\n FValueCollection := TValueSequence.Create(Self);\r\n\r\n { Create an internal empty list }\r\n FEmpty := CreateCollection(ValueRules);\r\nend;\r\n\r\nfunction TAbstractMultiMap.ExtractValues(const AKey: TKey): ISequence;\r\nvar\r\n LList: ICollection;\r\n LNewList: TLinkedList;\r\nbegin\r\n if FDictionary.TryGetValue(AKey, LList) then\r\n Dec(FKnownCount, LList.Count)\r\n else\r\n ExceptionHelper.Throw_KeyNotFoundError('AKey');\r\n\r\n { Simply remove the element. The LList should be auto-magically collected also }\r\n FDictionary.Remove(AKey);\r\n\r\n { Create the out list }\r\n LNewList := TLinkedList.Create();\r\n LNewList.AddAll(LList);\r\n\r\n { Hackishly push out all elements from this list }\r\n //TODO: fix me please. This must clear stuff properly.\r\n// while not LList.Empty do\r\n// LList.ExtractAt(LList.Count - 1);\r\n\r\n { Assign output }\r\n Result := LNewList;\r\n NotifyCollectionChanged();\r\nend;\r\n\r\nfunction TAbstractMultiMap.GetCount: NativeInt;\r\nbegin\r\n Result := FKnownCount;\r\nend;\r\n\r\nfunction TAbstractMultiMap.GetEnumerator: IEnumerator>;\r\nbegin\r\n Result := TEnumerator.Create(Self);\r\nend;\r\n\r\nfunction TAbstractMultiMap.GetValues(const AKey: TKey): ISequence;\r\nvar\r\n LList: ICollection;\r\nbegin\r\n if not FDictionary.TryGetValue(AKey, LList) then\r\n ExceptionHelper.Throw_KeyNotFoundError('AKey');\r\n\r\n Result := LList;\r\nend;\r\n\r\nfunction TAbstractMultiMap.KeyHasValue(const AKey: TKey; const AValue: TValue): Boolean;\r\nbegin\r\n Result := ContainsPair(AKey, AValue);\r\nend;\r\n\r\nprocedure TAbstractMultiMap.RemovePair(const AKey: TKey; const AValue: TValue);\r\nvar\r\n LList: ICollection;\r\nbegin\r\n { Simply remove the value from the LList at key }\r\n if FDictionary.TryGetValue(AKey, LList) then\r\n begin\r\n if LList.Contains(AValue) then\r\n begin\r\n LList.Remove(AValue);\r\n\r\n { Kill the LList for one element }\r\n if LList.Count = 0 then\r\n FDictionary.Remove(AKey);\r\n\r\n Dec(FKnownCount, 1);\r\n\r\n { Increase the version }\r\n NotifyCollectionChanged();\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TAbstractMultiMap.RemovePair(const APair: TPair);\r\nbegin\r\n { Call upper function }\r\n RemovePair(APair.Key, APair.Value);\r\nend;\r\n\r\nfunction TAbstractMultiMap.SelectKeys: ISequence;\r\nbegin\r\n Result := Keys;\r\nend;\r\n\r\nfunction TAbstractMultiMap.SelectValues: ISequence;\r\nbegin\r\n Result := Values;\r\nend;\r\n\r\nfunction TAbstractMultiMap.TryGetValues(const AKey: TKey): ISequence;\r\nbegin\r\n if not TryGetValues(AKey, Result) then\r\n Result := FEmpty;\r\nend;\r\n\r\nfunction TAbstractMultiMap.TryGetValues(const AKey: TKey;\r\n out AValues: ISequence): Boolean;\r\nvar\r\n LList: ICollection;\r\nbegin\r\n { Use the internal stuff }\r\n Result := FDictionary.TryGetValue(AKey, LList);\r\n\r\n if Result then\r\n AValues := LList;\r\nend;\r\n\r\nfunction TAbstractMultiMap.ValueForKey(const AKey: TKey): TValue;\r\nbegin\r\n Result := GetValues(AKey).ElementAt(0);\r\nend;\r\n\r\nprocedure TAbstractMultiMap.Remove(const AKey: TKey);\r\nvar\r\n LList: ICollection;\r\nbegin\r\n if FDictionary.TryGetValue(AKey, LList) then\r\n Dec(FKnownCount, LList.Count);\r\n\r\n { Simply remove the element. The LList should be auto-magically collected also }\r\n FDictionary.Remove(AKey);\r\n\r\n { Increase the version }\r\n NotifyCollectionChanged();\r\nend;\r\n\r\n{ TAbstractMultiMap.TEnumerator }\r\n\r\nconstructor TAbstractMultiMap.TEnumerator.Create(const AOwner: TAbstractMultiMap);\r\nbegin\r\n inherited Create(AOwner);\r\n FDictionaryEnumerator := AOwner.FDictionary.GetEnumerator();\r\nend;\r\n\r\nfunction TAbstractMultiMap.TEnumerator.TryMoveNext(out ACurrent: TPair): Boolean;\r\nbegin\r\n { Repeat until something happens }\r\n while True do\r\n begin\r\n if Assigned(FCollectionEnumerator) and FCollectionEnumerator.MoveNext() then\r\n begin\r\n { Next element }\r\n ACurrent.Key := FDictionaryEnumerator.Current.Key;\r\n ACurrent.Value := FCollectionEnumerator.Current;\r\n\r\n Exit(True);\r\n end else\r\n begin\r\n Result := FDictionaryEnumerator.MoveNext();\r\n if not Result then\r\n Break;\r\n\r\n FCollectionEnumerator := FDictionaryEnumerator.Current.Value.GetEnumerator();\r\n end;\r\n end;\r\nend;\r\n\r\n{ TAbstractMultiMap.TValueEnumerator }\r\n\r\nconstructor TAbstractMultiMap.TValueEnumerator.Create(const AOwner: TAbstractMultiMap);\r\nbegin\r\n inherited Create(AOwner);\r\n FOwnerEnumerator := AOwner.GetEnumerator();\r\nend;\r\n\r\nfunction TAbstractMultiMap.TValueEnumerator.TryMoveNext(out ACurrent: TValue): Boolean;\r\nbegin\r\n Result := FOwnerEnumerator.MoveNext();\r\n if Result then\r\n ACurrent := FOwnerEnumerator.Current.Value;\r\nend;\r\n\r\n{ TAbstractMultiMap.TValueSequence }\r\n\r\nconstructor TAbstractMultiMap.TValueSequence.Create(const AOwner: TAbstractMultiMap);\r\nbegin\r\n inherited Create(AOwner.ValueRules);\r\n FOwner := AOwner;\r\nend;\r\n\r\nfunction TAbstractMultiMap.TValueSequence.Empty: Boolean;\r\nbegin\r\n Result := FOwner.Empty;\r\nend;\r\n\r\nfunction TAbstractMultiMap.TValueSequence.GetCount: NativeInt;\r\nbegin\r\n Result := FOwner.Count;\r\nend;\r\n\r\nfunction TAbstractMultiMap.TValueSequence.GetEnumerator: IEnumerator;\r\nbegin\r\n Result := TValueEnumerator.Create(FOwner);\r\nend;\r\n\r\nprocedure TAbstractMultiMap.TValueSequence.CopyTo(var AArray: array of TValue; const AStartIndex: NativeInt);\r\nvar\r\n LList: ICollection;\r\n X: NativeInt;\r\nbegin\r\n { Check for indexes }\r\n if (AStartIndex >= Length(AArray)) or (AStartIndex < 0) then\r\n ExceptionHelper.Throw_ArgumentOutOfRangeError('AStartIndex');\r\n\r\n if (Length(AArray) - AStartIndex) < FOwner.Count then\r\n ExceptionHelper.Throw_ArgumentOutOfSpaceError('AArray');\r\n\r\n X := AStartIndex;\r\n\r\n { Iterate over all lists and copy them to array }\r\n for LList in TAbstractMultiMap(FOwner).FDictionary.Values do\r\n begin\r\n LList.CopyTo(AArray, X);\r\n Inc(X, LList.Count);\r\n end;\r\nend;\r\n\r\n{ TMultiMap }\r\n\r\nconstructor TMultiMap.Create(\r\n const AKeyRules: TRules; const AValueRules: TRules; const AInitialCapacity: NativeInt);\r\nbegin\r\n FInitialCapacity := AInitialCapacity;\r\n inherited Create(AKeyRules, AValueRules);\r\nend;\r\n\r\nconstructor TMultiMap.Create;\r\nbegin\r\n Create(TRules.Default, TRules.Default, CDefaultSize);\r\nend;\r\n\r\nconstructor TMultiMap.Create(const AKeyRules: TRules; const AValueRules: TRules);\r\nbegin\r\n Create(AKeyRules, AValueRules, CDefaultSize);\r\nend;\r\n\r\nfunction TMultiMap.CreateDictionary(const AKeyRules: TRules): IDictionary>;\r\nvar\r\n LNewCapacity: NativeInt;\r\n LDictionary: TDictionary>;\r\nbegin\r\n { Create a simple dictionary }\r\n if FInitialCapacity <= 0 then\r\n LNewCapacity := CDefaultSize\r\n else\r\n LNewCapacity := FInitialCapacity;\r\n\r\n LDictionary := TDictionary>.Create(AKeyRules, TRules>.Default, LNewCapacity);\r\n LDictionary.KeyRemoveNotification := NotifyKeyRemoved;\r\n\r\n Result := LDictionary;\r\nend;\r\n\r\nfunction TMultiMap.CreateCollection(const AValueRules: TRules): ICollection;\r\nvar\r\n LList: TList;\r\nbegin\r\n { Create a simple list }\r\n LList := TList.Create(AValueRules);\r\n LList.RemoveNotification := NotifyValueRemoved;\r\n\r\n Result := LList;\r\nend;\r\n\r\n{ TObjectMultiMap }\r\n\r\nprocedure TObjectMultiMap.HandleKeyRemoved(const AKey: TKey);\r\nbegin\r\n if FOwnsKeys then\r\n PObject(@AKey)^.Free;\r\nend;\r\n\r\nprocedure TObjectMultiMap.HandleValueRemoved(const AValue: TValue);\r\nbegin\r\n if FOwnsValues then\r\n PObject(@AValue)^.Free;\r\nend;\r\n\r\n{ TSortedMultiMap }\r\n\r\n\r\nconstructor TSortedMultiMap.Create(const AKeyRules: TRules;\r\n const AValueRules: TRules; const AAscending: Boolean);\r\nbegin\r\n { Do the dew and continue }\r\n FAscendingSort := AAscending;\r\n inherited Create(AKeyRules, AValueRules);\r\nend;\r\n\r\nconstructor TSortedMultiMap.Create;\r\nbegin\r\n Create(TRules.Default, TRules.Default, True);\r\nend;\r\n\r\nconstructor TSortedMultiMap.Create(const AKeyRules: TRules; const AValueRules: TRules);\r\nbegin\r\n Create(AKeyRules, AValueRules, True);\r\nend;\r\n\r\nfunction TSortedMultiMap.CreateDictionary(const AKeyRules: TRules): IDictionary>;\r\nvar\r\n LDictionary: TSortedDictionary>;\r\nbegin\r\n { Create a simple dictionary }\r\n LDictionary := TSortedDictionary>.Create(AKeyRules, TRules>.Default, FAscendingSort);\r\n LDictionary.KeyRemoveNotification := NotifyKeyRemoved;\r\n\r\n Result := LDictionary;\r\nend;\r\n\r\nfunction TSortedMultiMap.CreateCollection(const AValueRules: TRules): ICollection;\r\nvar\r\n LList: TList;\r\nbegin\r\n { Create a simple list }\r\n LList := TList.Create(AValueRules);\r\n LList.RemoveNotification := NotifyValueRemoved;\r\n\r\n Result := LList;\r\nend;\r\n\r\nfunction TSortedMultiMap.MaxKey: TKey;\r\nbegin\r\n Result := Dictionary.MaxKey;\r\nend;\r\n\r\nfunction TSortedMultiMap.MinKey: TKey;\r\nbegin\r\n Result := Dictionary.MinKey;\r\nend;\r\n\r\n{ TObjectSortedMultiMap }\r\n\r\nprocedure TObjectSortedMultiMap.HandleKeyRemoved(const AKey: TKey);\r\nbegin\r\n if FOwnsKeys then\r\n PObject(@AKey)^.Free;\r\nend;\r\n\r\nprocedure TObjectSortedMultiMap.HandleValueRemoved(const AValue: TValue);\r\nbegin\r\n if FOwnsValues then\r\n PObject(@AValue)^.Free;\r\nend;\r\n\r\n{ TDistinctMultiMap }\r\n\r\nconstructor TDistinctMultiMap.Create(\r\n const AKeyRules: TRules; const AValueRules: TRules; const AInitialCapacity: NativeInt);\r\nbegin\r\n FInitialCapacity := AInitialCapacity;\r\n inherited Create(AKeyRules, AValueRules);\r\nend;\r\n\r\nconstructor TDistinctMultiMap.Create;\r\nbegin\r\n Create(TRules.Default, TRules.Default, CDefaultSize);\r\nend;\r\n\r\nconstructor TDistinctMultiMap.Create(const AKeyRules: TRules; const AValueRules: TRules);\r\nbegin\r\n Create(AKeyRules, AValueRules, CDefaultSize);\r\nend;\r\n\r\nfunction TDistinctMultiMap.CreateDictionary(const AKeyRules: TRules): IDictionary>;\r\nvar\r\n LNewCapacity: NativeInt;\r\n LDictionary: TDictionary>;\r\nbegin\r\n { Create a simple dictionary }\r\n if FInitialCapacity <= 0 then\r\n LNewCapacity := CDefaultSize\r\n else\r\n LNewCapacity := FInitialCapacity;\r\n\r\n LDictionary := TDictionary>.Create(AKeyRules, TRules>.Default, LNewCapacity);\r\n LDictionary.KeyRemoveNotification := NotifyKeyRemoved;\r\n\r\n Result := LDictionary;\r\nend;\r\n\r\nfunction TDistinctMultiMap.CreateCollection(const AValueRules: TRules): ICollection;\r\nvar\r\n LSet: THashSet;\r\nbegin\r\n { Create a simple list }\r\n LSet := THashSet.Create(AValueRules);\r\n LSet.RemoveNotification := NotifyValueRemoved;\r\n\r\n Result := LSet;\r\nend;\r\n\r\n{ TObjectDistinctMultiMap }\r\n\r\nprocedure TObjectDistinctMultiMap.HandleKeyRemoved(const AKey: TKey);\r\nbegin\r\n if FOwnsKeys then\r\n PObject(@AKey)^.Free;\r\nend;\r\n\r\nprocedure TObjectDistinctMultiMap.HandleValueRemoved(const AValue: TValue);\r\nbegin\r\n if FOwnsValues then\r\n PObject(@AValue)^.Free;\r\nend;\r\n\r\n{ TSortedDistinctMultiMap }\r\n\r\nconstructor TSortedDistinctMultiMap.Create(const AKeyRules: TRules;\r\n const AValueRules: TRules; const AAscending: Boolean);\r\nbegin\r\n { Do the dew and continue }\r\n FAscendingSort := AAscending;\r\n inherited Create(AKeyRules, AValueRules);\r\nend;\r\n\r\nconstructor TSortedDistinctMultiMap.Create;\r\nbegin\r\n Create(TRules.Default, TRules.Default, True);\r\nend;\r\n\r\nconstructor TSortedDistinctMultiMap.Create(const AKeyRules: TRules; const AValueRules: TRules);\r\nbegin\r\n Create(AKeyRules, AValueRules, True);\r\nend;\r\n\r\nfunction TSortedDistinctMultiMap.CreateDictionary(const AKeyRules: TRules): IDictionary>;\r\nvar\r\n LDictionary: TSortedDictionary>;\r\nbegin\r\n { Create a simple dictionary }\r\n LDictionary := TSortedDictionary>.Create(AKeyRules,\r\n TRules>.Default, FAscendingSort);\r\n\r\n LDictionary.KeyRemoveNotification := NotifyKeyRemoved;\r\n\r\n Result := LDictionary;\r\nend;\r\n\r\nfunction TSortedDistinctMultiMap.CreateCollection(const AValueRules: TRules): ICollection;\r\nvar\r\n LSet: THashSet;\r\nbegin\r\n { Create a simple list }\r\n LSet := THashSet.Create(AValueRules);\r\n LSet.RemoveNotification := NotifyValueRemoved;\r\n\r\n Result := LSet;\r\nend;\r\n\r\nfunction TSortedDistinctMultiMap.MaxKey: TKey;\r\nbegin\r\n Result := Dictionary.MaxKey;\r\nend;\r\n\r\nfunction TSortedDistinctMultiMap.MinKey: TKey;\r\nbegin\r\n Result := Dictionary.MinKey;\r\nend;\r\n\r\n{ TObjectSortedDistinctMultiMap }\r\n\r\nprocedure TObjectSortedDistinctMultiMap.HandleKeyRemoved(const AKey: TKey);\r\nbegin\r\n if FOwnsKeys then\r\n PObject(@AKey)^.Free;\r\nend;\r\n\r\nprocedure TObjectSortedDistinctMultiMap.HandleValueRemoved(const AValue: TValue);\r\nbegin\r\n if FOwnsValues then\r\n PObject(@AValue)^.Free;\r\nend;\r\n\r\n{ TDoubleSortedMultiMap }\r\n\r\nconstructor TDoubleSortedMultiMap.Create(\r\n const AKeyRules: TRules; const AValueRules: TRules;\r\n const AAscendingKeys, AAscendingValues: Boolean);\r\nbegin\r\n { Do da dew and continue! }\r\n FAscendingValues := AAscendingValues;\r\n inherited Create(AKeyRules, AValueRules, AAscendingKeys);\r\nend;\r\n\r\nconstructor TDoubleSortedMultiMap.Create;\r\nbegin\r\n Create(TRules.Default, TRules.Default, True, True);\r\nend;\r\n\r\nconstructor TDoubleSortedMultiMap.Create(const AKeyRules: TRules; const AValueRules: TRules);\r\nbegin\r\n Create(AKeyRules, AValueRules, True, True);\r\nend;\r\n\r\nfunction TDoubleSortedMultiMap.CreateCollection(const AValueRules: TRules): ICollection;\r\nvar\r\n LList: TSortedList;\r\nbegin\r\n { Create a simple list }\r\n LList := TSortedList.Create(AValueRules, CDefaultSize, FAscendingValues);\r\n LList.RemoveNotification := NotifyValueRemoved;\r\n\r\n Result := LList;\r\nend;\r\n\r\n{ TObjectDoubleSortedMultiMap }\r\n\r\nprocedure TObjectDoubleSortedMultiMap.HandleKeyRemoved(const AKey: TKey);\r\nbegin\r\n if FOwnsKeys then\r\n PObject(@AKey)^.Free;\r\nend;\r\n\r\nprocedure TObjectDoubleSortedMultiMap.HandleValueRemoved(const AValue: TValue);\r\nbegin\r\n if FOwnsValues then\r\n PObject(@AValue)^.Free;\r\nend;\r\n\r\n{ TDoubleSortedDistinctMultiMap }\r\n\r\nconstructor TDoubleSortedDistinctMultiMap.Create(\r\n const AKeyRules: TRules; const AValueRules: TRules;\r\n const AAscendingKeys, AAscendingValues: Boolean);\r\nbegin\r\n { Do da dew and continue! }\r\n FAscendingValues := AAscendingValues;\r\n inherited Create(AKeyRules, AValueRules, AAscendingKeys);\r\nend;\r\n\r\nconstructor TDoubleSortedDistinctMultiMap.Create;\r\nbegin\r\n Create(TRules.Default, TRules.Default, True, True);\r\nend;\r\n\r\nconstructor TDoubleSortedDistinctMultiMap.Create(const AKeyRules: TRules; const AValueRules: TRules);\r\nbegin\r\n Create(AKeyRules, AValueRules, True, True);\r\nend;\r\n\r\nfunction TDoubleSortedDistinctMultiMap.CreateCollection(const AValueRules: TRules): ICollection;\r\nvar\r\n LSet: TSortedSet;\r\nbegin\r\n { Create a simple list }\r\n LSet := TSortedSet.Create(AValueRules, FAscendingValues);\r\n LSet.RemoveNotification := NotifyValueRemoved;\r\n\r\n Result := LSet;\r\nend;\r\n\r\n{ TObjectDoubleSortedDistinctMultiMap }\r\n\r\nprocedure TObjectDoubleSortedDistinctMultiMap.HandleKeyRemoved(const AKey: TKey);\r\nbegin\r\n if FOwnsKeys then\r\n PObject(@AKey)^.Free;\r\nend;\r\n\r\nprocedure TObjectDoubleSortedDistinctMultiMap.HandleValueRemoved(const AValue: TValue);\r\nbegin\r\n if FOwnsValues then\r\n PObject(@AValue)^.Free;\r\nend;\r\n\r\nend.\r\n" }, { "path": "Collections/Collections.Queues.pas", "content": "(*\r\n* Copyright (c) 2008-2012, Ciobanu Alexandru\r\n* All rights reserved.\r\n*\r\n* Redistribution and use in source and binary forms, with or without\r\n* modification, are permitted provided that the following conditions are met:\r\n* * Redistributions of source code must retain the above copyright\r\n* notice, this list of conditions and the following disclaimer.\r\n* * Redistributions in binary form must reproduce the above copyright\r\n* notice, this list of conditions and the following disclaimer in the\r\n* documentation and/or other materials provided with the distribution.\r\n* * Neither the name of the nor the\r\n* names of its contributors may be used to endorse or promote products\r\n* derived from this software without specific prior written permission.\r\n*\r\n* THIS SOFTWARE IS PROVIDED BY THE AUTHOR ''AS IS'' AND ANY\r\n* EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED\r\n* WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE\r\n* DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY\r\n* DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES\r\n* (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;\r\n* LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND\r\n* ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT\r\n* (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS\r\n* SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.\r\n*)\r\n\r\nunit Collections.Queues;\r\ninterface\r\nuses SysUtils,\r\n Generics.Defaults,\r\n Generics.Collections,\r\n Collections.Lists,\r\n Collections.Base;\r\n\r\ntype\r\n /// The abstract base class for all generic queue collections.\r\n /// Descending classes must implement the required abstract methods and optionally can implement\r\n /// the non-required method.\r\n TAbstractQueue = class(TCollection, IQueue)\r\n public\r\n /// Creates a new queue collection.\r\n /// A rule set describing the elements in the queue.\r\n constructor Create(const ARules: TRules);\r\n\r\n /// Appends an element to the head of the queue.\r\n /// The value to append.\r\n /// This implementation calls the Add method.\r\n /// If Add method is not overridden.\r\n procedure Enqueue(const AValue: T);\r\n\r\n /// Reads the element from the bottom of the queue.\r\n /// The value at the bottom of the queue.\r\n /// This method does not remove the element from the bottom of the queue. It merely reads it's value.\r\n /// This implementation uses Enex First operation.\r\n /// The queue is empty.\r\n function Peek(): T; virtual;\r\n\r\n /// Retrieves the element from the head of the queue.\r\n /// The value at the head of the queue.\r\n /// This method removes the element from the top of the queue. The implementation in this class\r\n /// always raises an exception.\r\n /// The stack is empty.\r\n /// Always raised in current implementation.\r\n function Dequeue(): T; virtual;\r\n end;\r\n\r\n /// The generic queue collection.\r\n /// This type uses an internal array to store its values.\r\n TQueue = class(TAbstractQueue, IDynamic)\r\n private type\r\n {$REGION 'Internal Types'}\r\n TEnumerator = class(TAbstractEnumerator)\r\n private\r\n FLeftCount, FCurrentHead: NativeInt;\r\n public\r\n function TryMoveNext(out ACurrent: T): Boolean; override;\r\n end;\r\n {$ENDREGION}\r\n\r\n private var\r\n FHead: NativeInt;\r\n FTail: NativeInt;\r\n FLength: NativeInt;\r\n FArray: TArray;\r\n\r\n procedure SetCapacity(const ANewCapacity : NativeInt);\r\n protected\r\n /// Returns the number of elements in the queue.\r\n /// A positive value specifying the number of elements in the queue.\r\n function GetCount(): NativeInt; override;\r\n\r\n /// Returns the current capacity.\r\n /// A positive number that specifies the number of elements that the queue can hold before it\r\n /// needs to grow again.\r\n /// The value of this method is greater than or equal to the amount of elements in the queue. If this value\r\n /// is greater than the number of elements, it means that the queue has some extra capacity to operate upon.\r\n function GetCapacity(): NativeInt;\r\n public\r\n /// Creates a new queue collection.\r\n /// This constructor requests the default rule set. Call the overloaded constructor if\r\n /// specific a set of rules need to be passed.\r\n constructor Create(const AThreadSafe: Boolean = False); overload;\r\n\r\n constructor Create(const AInitialCapacity: NativeInt; const AThreadSafe: Boolean = False); overload;\r\n\r\n /// Creates a new queue collection.\r\n /// A rule set describing the elements in the queue.\r\n constructor Create(const ARules: TRules; const AThreadSafe: Boolean = False); overload;\r\n\r\n /// Creates a new queue collection.\r\n /// The set's initial capacity.\r\n /// A rule set describing the elements in the queue.\r\n constructor Create(const ARules: TRules; const AInitialCapacity: NativeInt; const AThreadSafe: Boolean = False); overload;\r\n\r\n destructor Destroy; override;\r\n\r\n /// Clears the contents of the queue.\r\n procedure Clear(); override;\r\n\r\n /// Appends an element to the top of the queue.\r\n /// The value to append.\r\n procedure Add(const AValue: T); override;\r\n\r\n /// Retrieves the element from the bottom of the queue.\r\n /// The value at the bottom of the queue.\r\n /// This method removes the element from the bottom of the queue.\r\n /// The queue is empty.\r\n function Dequeue(): T; override;\r\n\r\n /// Checks whether the queue contains a given value.\r\n /// The value to check.\r\n /// True if the value was found in the queue; False otherwise.\r\n function Contains(const AValue: T): Boolean; override;\r\n\r\n /// Specifies the number of elements in the queue.\r\n /// A positive value specifying the number of elements in the queue.\r\n property Count: NativeInt read FLength;\r\n\r\n /// Specifies the current capacity.\r\n /// A positive number that specifies the number of elements that the queue can hold before it\r\n /// needs to grow again.\r\n /// The value of this property is greater than or equal to the amount of elements in the queue. If this value\r\n /// if greater than the number of elements, it means that the queue has some extra capacity to operate upon.\r\n property Capacity: NativeInt read GetCapacity write SetCapacity;\r\n\r\n /// Removes the excess capacity from the queue.\r\n /// This method can be called manually to force the queue to drop the extra capacity it might hold. For example,\r\n /// after performing some massive operations on a big list, call this method to ensure that all extra memory held by the\r\n /// queue is released.\r\n procedure Shrink();\r\n\r\n /// Forces the queue to increase its capacity.\r\n /// Call this method to force the queue to increase its capacity ahead of time. Manually adjusting the capacity\r\n /// can be useful in certain situations.\r\n procedure Grow();\r\n\r\n /// Returns a new enumerator object used to enumerate this queue.\r\n /// This method is usually called by compiler-generated code. Its purpose is to create an enumerator\r\n /// object that is used to actually traverse the queue.\r\n /// An enumerator object.\r\n function GetEnumerator(): IEnumerator; override;\r\n\r\n /// Copies the values stored in the queue to a given array.\r\n /// An array where to copy the contents of the queue.\r\n /// The index into the array at which the copying begins.\r\n /// This method assumes that has enough space to hold the contents of the queue.\r\n /// is out of bounds.\r\n /// The array is not long enough.\r\n procedure CopyTo(var AArray: array of T; const AStartIndex: NativeInt); overload; override;\r\n\r\n /// Checks whether the queue is empty.\r\n /// True if the queue is empty; False otherwise.\r\n /// This method is the recommended way of detecting if the queue is empty.\r\n function Empty(): Boolean; override;\r\n\r\n /// Returns the biggest element.\r\n /// An element from the queue considered to have the biggest value.\r\n /// The queue is empty.\r\n function Max(): T; override;\r\n\r\n /// Returns the smallest element.\r\n /// An element from the queue considered to have the smallest value.\r\n /// The queue is empty.\r\n function Min(): T; override;\r\n\r\n /// Returns the first element.\r\n /// The first element in the queue.\r\n /// The queue is empty.\r\n function First(): T; override;\r\n\r\n /// Returns the first element or a default, if the queue is empty.\r\n /// The default value returned if the queue is empty.\r\n /// The first element in the queue if the queue is not empty; otherwise is returned.\r\n function FirstOrDefault(const ADefault: T): T; override;\r\n\r\n /// Returns the last element.\r\n /// The last element in the queue.\r\n /// The queue is empty.\r\n function Last(): T; override;\r\n\r\n /// Returns the last element or a default if the queue is empty.\r\n /// The default value returned if the queue is empty.\r\n /// The last element in the queue if the queue is not empty; otherwise is returned.\r\n function LastOrDefault(const ADefault: T): T; override;\r\n\r\n /// Returns the single element stored in the queue.\r\n /// The element in the queue.\r\n /// This method checks if the queue contains just one element, in which case it is returned.\r\n /// The queue is empty.\r\n /// There is more than one element in the queue.\r\n function Single(): T; override;\r\n\r\n /// Returns the single element stored in the queue, or a default value.\r\n /// The default value returned if there are less or more elements in the queue.\r\n /// The element in the queue if the condition is satisfied; is returned otherwise.\r\n /// This method checks if the queue contains just one element, in which case it is returned. Otherwise\r\n /// the value in is returned.\r\n function SingleOrDefault(const ADefault: T): T; override;\r\n\r\n /// Aggregates a value based on the queue's elements.\r\n /// The aggregator method.\r\n /// A value that contains the queue's aggregated value.\r\n /// This method returns the first element if the queue only has one element. Otherwise,\r\n /// is invoked for each two elements (first and second; then the result of the first two\r\n /// and the third, and so on). The simplest example of aggregation is the \"sum\" operation where you can obtain the sum of all\r\n /// elements in the value.\r\n /// is nil.\r\n /// The queue is empty.\r\n function Aggregate(const AAggregator: TFunc): T; override;\r\n\r\n /// Aggregates a value based on the queue's elements.\r\n /// The aggregator method.\r\n /// The default value returned if the queue is empty.\r\n /// A value that contains the queue's aggregated value. If the queue is empty, is returned.\r\n /// This method returns the first element if the queue only has one element. Otherwise,\r\n /// is invoked for each two elements (first and second; then the result of the first two\r\n /// and the third, and so on). The simplest example of aggregation is the \"sum\" operation, where you can obtain the sum of all\r\n /// elements in the value.\r\n /// is nil.\r\n function AggregateOrDefault(const AAggregator: TFunc; const ADefault: T): T; override;\r\n\r\n /// Returns the element at a given position.\r\n /// The index from which to return the element.\r\n /// The element at the specified position.\r\n /// The queue is empty.\r\n /// is out of bounds.\r\n function ElementAt(const AIndex: NativeInt): T; override;\r\n\r\n /// Returns the element at a given position.\r\n /// The index from which to return the element.\r\n /// The default value returned if the queue is empty.\r\n /// The element at the specified position if the queue is not empty and the position is not out of bounds; otherwise\r\n /// the value of is returned.\r\n function ElementAtOrDefault(const AIndex: NativeInt; const ADefault: T): T; override;\r\n\r\n /// Checks whether at least one element in the queue satisfies a given predicate.\r\n /// The predicate to check for each element.\r\n /// True if at least one element satisfies a given predicate; False otherwise.\r\n /// This method traverses the whole queue and checks the value of the predicate for each element. This method\r\n /// stops on the first element for which the predicate returns True. The logical equivalent of this operation is \"OR\".\r\n /// is nil.\r\n function Any(const APredicate: TPredicate): Boolean; override;\r\n\r\n /// Checks that all elements in the queue satisfy a given predicate.\r\n /// The predicate to check for each element.\r\n /// True if all elements satisfy a given predicate; False otherwise.\r\n /// This method traverses the whole queue and checks the value of the predicate for each element. This method\r\n /// stops on the first element for which the predicate returns False. The logical equivalent of this operation is \"AND\".\r\n /// is nil.\r\n function All(const APredicate: TPredicate): Boolean; override;\r\n\r\n /// Checks whether the elements in this queue are equal to the elements in another collection.\r\n /// The collection to compare to.\r\n /// True if the collections are equal; False if the collections are different.\r\n /// This method checks that each element at position X in this queue is equal to an element at position X in\r\n /// the provided collection. If the number of elements in both collections is different, then the collections are considered different.\r\n /// Note that the comparisons of elements is done using the rule set used by this queue. This means that comparing this collection\r\n /// to another one might yeild a different result than comparing the other collection to this one.\r\n /// is nil.\r\n function EqualsTo(const ACollection: IEnumerable): Boolean; override;\r\n end;\r\n\r\n /// The generic queue collection designed to store objects.\r\n /// This type uses an internal array to store its objects.\r\n TObjectQueue = class(TQueue)\r\n private\r\n FOwnsObjects: Boolean;\r\n\r\n protected\r\n /// Frees the object that was removed from the collection.\r\n /// The object that was removed from the collection.\r\n procedure HandleElementRemoved(const AElement: T); override;\r\n\r\n public\r\n /// Specifies whether this queue owns the objects stored in it.\r\n /// True if the queue owns its objects; False otherwise.\r\n /// This property controls the way the queue controls the life-time of the stored objects.\r\n property OwnsObjects: Boolean read FOwnsObjects write FOwnsObjects;\r\n end;\r\n\r\ntype\r\n /// The generic queue collection.\r\n /// This type uses a linked list to store its values.\r\n TLinkedQueue = class(TAbstractQueue)\r\n private type\r\n {$REGION 'Internal Types'}\r\n PEntry = ^TEntry;\r\n TEntry = record\r\n FPrev, FNext: PEntry;\r\n FValue: T;\r\n end;\r\n\r\n TEnumerator = class(TAbstractEnumerator)\r\n private\r\n FCurrentEntry: PEntry;\r\n public\r\n function TryMoveNext(out ACurrent: T): Boolean; override;\r\n end;\r\n {$ENDREGION}\r\n\r\n private var\r\n FFirst, FLast, FFirstFree: PEntry;\r\n FCount, FFreeCount: NativeInt;\r\n\r\n { Caching }\r\n function NeedEntry(const AValue: T): PEntry;\r\n procedure ReleaseEntry(const AEntry: PEntry);\r\n protected\r\n /// Returns the number of elements in the queue.\r\n /// A positive value specifying the number of elements in the queue.\r\n function GetCount(): NativeInt; override;\r\n public\r\n /// Creates a new queue collection.\r\n /// This constructor requests the default rule set. Call the overloaded constructor if\r\n /// specific a set of rules need to be passed.\r\n constructor Create(); overload;\r\n\r\n /// Creates a new queue collection.\r\n /// A rule set describing the elements in the queue.\r\n constructor Create(const ARules: TRules); overload;\r\n\r\n /// Destroys this instance.\r\n /// Do not call this method directly; call Free instead.\r\n destructor Destroy(); override;\r\n\r\n /// Clears the contents of the queue.\r\n procedure Clear(); override;\r\n\r\n /// Appends an element to the top of the queue.\r\n /// The value to append.\r\n procedure Add(const AValue: T); override;\r\n\r\n /// Retrieves the element from the bottom of the queue.\r\n /// The value at the bottom of the queue.\r\n /// This method removes the element from the bottom of the queue.\r\n /// The queue is empty.\r\n function Dequeue(): T; override;\r\n\r\n /// Checks whether the queue contains a given value.\r\n /// The value to check.\r\n /// True if the value was found in the queue; False otherwise.\r\n function Contains(const AValue: T): Boolean; override;\r\n\r\n /// Specifies the number of elements in the queue.\r\n /// A positive value specifying the number of elements in the queue.\r\n property Count: NativeInt read FCount;\r\n\r\n /// Returns a new enumerator object used to enumerate this queue.\r\n /// This method is usually called by compiler-generated code. Its purpose is to create an enumerator\r\n /// object that is used to actually traverse the queue.\r\n /// An enumerator object.\r\n function GetEnumerator(): IEnumerator; override;\r\n\r\n /// Copies the values stored in the queue to a given array.\r\n /// An array where to copy the contents of the queue.\r\n /// The index into the array at which the copying begins.\r\n /// This method assumes that has enough space to hold the contents of the queue.\r\n /// is out of bounds.\r\n /// The array is not long enough.\r\n procedure CopyTo(var AArray: array of T; const AStartIndex: NativeInt); overload; override;\r\n\r\n /// Checks whether the queue is empty.\r\n /// True if the queue is empty; False otherwise.\r\n /// This method is the recommended way of detecting if the queue is empty.\r\n function Empty(): Boolean; override;\r\n\r\n /// Returns the biggest element.\r\n /// An element from the queue considered to have the biggest value.\r\n /// The queue is empty.\r\n function Max(): T; override;\r\n\r\n /// Returns the smallest element.\r\n /// An element from the queue considered to have the smallest value.\r\n /// The queue is empty.\r\n function Min(): T; override;\r\n\r\n /// Returns the first element.\r\n /// The first element in the queue.\r\n /// The queue is empty.\r\n function First(): T; override;\r\n\r\n /// Returns the first element or a default, if the queue is empty.\r\n /// The default value returned if the queue is empty.\r\n /// The first element in the queue if the queue is not empty; otherwise is returned.\r\n function FirstOrDefault(const ADefault: T): T; override;\r\n\r\n /// Returns the last element.\r\n /// The last element in the queue.\r\n /// The queue is empty.\r\n function Last(): T; override;\r\n\r\n /// Returns the last element or a default, if the queue is empty.\r\n /// The default value returned if the queue is empty.\r\n /// The last element in queue if the queue is not empty; otherwise is returned.\r\n function LastOrDefault(const ADefault: T): T; override;\r\n\r\n /// Returns the single element stored in the queue.\r\n /// The element in the queue.\r\n /// This method checks if the queue contains just one element, in which case it is returned.\r\n /// The queue is empty.\r\n /// There is more than one element in the queue.\r\n function Single(): T; override;\r\n\r\n /// Returns the single element stored in the queue, or a default value.\r\n /// The default value returned if there are less or more elements in the queue.\r\n /// The element in the queue if the condition is satisfied; is returned otherwise.\r\n /// This method checks if the queue contains just one element, in which case it is returned. Otherwise\r\n /// the value in is returned.\r\n function SingleOrDefault(const ADefault: T): T; override;\r\n\r\n /// Aggregates a value based on the queue's elements.\r\n /// The aggregator method.\r\n /// A value that contains the queue's aggregated value.\r\n /// This method returns the first element if the queue only has one element. Otherwise,\r\n /// is invoked for each two elements (first and second; then the result of the first two\r\n /// and the third, and so on). The simplest example of aggregation is the \"sum\" operation, where you can obtain the sum of all\r\n /// elements in the value.\r\n /// is nil.\r\n /// The queue is empty.\r\n function Aggregate(const AAggregator: TFunc): T; override;\r\n\r\n /// Aggregates a value based on the queue's elements.\r\n /// The aggregator method.\r\n /// The default value returned if the queue is empty.\r\n /// A value that contains the queue's aggregated value. If the queue is empty, is returned.\r\n /// This method returns the first element if the queue only has one element. Otherwise,\r\n /// is invoked for each two elements (first and second; then the result of the first two\r\n /// and the third, and so on). The simplest example of aggregation is the \"sum\" operation, where you can obtain the sum of all\r\n /// elements in the value.\r\n /// is nil.\r\n function AggregateOrDefault(const AAggregator: TFunc; const ADefault: T): T; override;\r\n\r\n /// Returns the element at a given position.\r\n /// The index from which to return the element.\r\n /// The element at the specified position.\r\n /// The queue is empty.\r\n /// is out of bounds.\r\n function ElementAt(const AIndex: NativeInt): T; override;\r\n\r\n /// Returns the element at a given position.\r\n /// The index from which to return the element.\r\n /// The default value returned if the queue is empty.\r\n /// The element at the specified position if the queue is not empty and the position is not out of bounds; otherwise\r\n /// the value of is returned.\r\n function ElementAtOrDefault(const AIndex: NativeInt; const ADefault: T): T; override;\r\n\r\n /// Checks whether at least one element in the queue satisfies a given predicate.\r\n /// The predicate to check for each element.\r\n /// True if at least one element satisfies a given predicate; False otherwise.\r\n /// This method traverses the whole queue and checks the value of the predicate for each element. This method\r\n /// stops on the first element for which the predicate returns True. The logical equivalent of this operation is \"OR\".\r\n /// is nil.\r\n function Any(const APredicate: TPredicate): Boolean; override;\r\n\r\n /// Checks that all elements in the queue satisfy a given predicate.\r\n /// The predicate to check for each element.\r\n /// True if all elements satisfy a given predicate; False otherwise.\r\n /// This method traverses the whole queue and checks the value of the predicate for each element. This method\r\n /// stops on the first element for which the predicate returns False. The logical equivalent of this operation is \"AND\".\r\n /// is nil.\r\n function All(const APredicate: TPredicate): Boolean; override;\r\n\r\n /// Checks whether the elements in this queue are equal to the elements in another collection.\r\n /// The collection to compare to.\r\n /// True if the collections are equal; False if the collections are different.\r\n /// This method checks that each element at position X in this queue is equal to an element at position X in\r\n /// the provided collection. If the number of elements in the collections is different, then the collections are considered different.\r\n /// Note that the comparison of elements is done using the rule set used by this queue. This means that comparing this collection\r\n /// to another one might yeild a different result than comparing the other collection to this one.\r\n /// is nil.\r\n function EqualsTo(const ACollection: IEnumerable): Boolean; override;\r\n end;\r\n\r\n /// The generic queue collection designed to store objects.\r\n /// This type uses a linked list to store its objects.\r\n TObjectLinkedQueue = class(TLinkedQueue)\r\n private\r\n FOwnsObjects: Boolean;\r\n\r\n protected\r\n /// Frees the object that was removed from the collection.\r\n /// The object that was removed from the collection.\r\n procedure HandleElementRemoved(const AElement: T); override;\r\n\r\n public\r\n /// Specifies whether this queue owns the objects stored in it.\r\n /// True if the queue owns its objects; False otherwise.\r\n /// This property controls the way the queue controls the life-time of the stored objects.\r\n property OwnsObjects: Boolean read FOwnsObjects write FOwnsObjects;\r\n end;\r\n\r\ntype\r\n /// The generic priority queue collection.\r\n /// This collection reorganizes the first-out element based on a given priority.\r\n TPriorityQueue = class(TAssociation, IPriorityQueue, IDynamic)\r\n private type\r\n {$REGION 'Internal Types'}\r\n { Internal storage }\r\n TPriorityPair = record\r\n FPriority: TPriority;\r\n FValue: TValue;\r\n end;\r\n\r\n TEnumerator = class(TAbstractEnumerator>)\r\n private\r\n FCurrentIndex: NativeInt;\r\n public\r\n function TryMoveNext(out ACurrent: TPair): Boolean; override;\r\n end;\r\n {$ENDREGION}\r\n\r\n private\r\n FCount: NativeInt;\r\n FSign: NativeInt;\r\n FArray: TArray;\r\n\r\n { Used internally to remove items from queue }\r\n function RemoveAt(const AIndex: NativeInt): TPriorityPair;\r\n protected\r\n /// Returns the number of elements in the queue.\r\n /// A positive value specifying the number of elements in the queue.\r\n function GetCount(): NativeInt; override;\r\n\r\n /// Returns the current capacity.\r\n /// A positive number that specifies the number of elements that the queue can hold before it\r\n /// needs to grow again.\r\n /// The value of this method is greater than or equal to the amount of elements in the queue. If this value\r\n /// is greater than the number of elements, it means that the queue has some extra capacity to operate upon.\r\n function GetCapacity(): NativeInt;\r\n public\r\n /// Creates a new instance of this class.\r\n /// Specifies the comparison order of the priorities. The default is True.\r\n /// The default rule set for the operated type is used.\r\n constructor Create(const AAscending: Boolean = True); overload;\r\n\r\n /// Creates a new instance of this class.\r\n /// Specifies the comparison order of the priorities. The default is True.\r\n /// Specifies the initial capacity of the queue.\r\n /// The default rule set for the operated type is used.\r\n constructor Create(const AInitialCapacity: NativeInt; const AAscending: Boolean = True); overload;\r\n\r\n /// Creates a new instance of this class.\r\n /// A collection of priority/value pairs to copy elements from.\r\n /// Specifies the comparison order of the priorities. The default is True.\r\n /// The default rule set for the operated type is used.\r\n constructor Create(const ACollection: IEnumerable>; const AAscending: Boolean = True); overload;\r\n\r\n /// Creates a new instance of this class.\r\n /// An array of priority/value pairs to copy elements from.\r\n /// Specifies the comparison order of the priorities. The default is True.\r\n /// The default rule set for the operated type is used.\r\n constructor Create(const AArray: array of TPair; const AAscending: Boolean = True); overload;\r\n\r\n /// Creates a new instance of this class.\r\n /// The rule set used for the queues' priorities.\r\n /// The rule set used for the queues' values.\r\n /// Specifies the comparison order of the priorities. The default is True.\r\n constructor Create(const APriorityRules: TRules; const AValueRules: TRules;\r\n const AAscending: Boolean = true); overload;\r\n\r\n /// Creates a new instance of this class.\r\n /// The rule set used for the queues' priorities.\r\n /// The rule set used for the queues' values.\r\n /// Specifies the comparison order of the priorities. The default is True.\r\n /// Specifies the initial capacity of the queue.\r\n constructor Create(const APriorityRules: TRules; const AValueRules: TRules;\r\n const AInitialCapacity: NativeInt; const AAscending: Boolean = True); overload;\r\n\r\n /// Creates a new instance of this class.\r\n /// A collection of priority/value pairs to copy elements from.\r\n /// The rule set used for the queues' priorities.\r\n /// The rule set used for the queues' values.\r\n /// Specifies the comparison order of the priorities. The default is True.\r\n /// is nil.\r\n constructor Create(const APriorityRules: TRules; const AValueRules: TRules;\r\n const ACollection: IEnumerable>; const AAscending: Boolean = True); overload;\r\n\r\n /// Creates a new instance of this class.\r\n /// An array of priority/value pairs to copy elements from.\r\n /// The rule set used for the queues' priorities.\r\n /// The rule set used for the queues' values.\r\n /// Specifies the comparison order of the priorities. The default is True.\r\n constructor Create(const APriorityRules: TRules; const AValueRules: TRules;\r\n const AArray: array of TPair; const AAscending: Boolean = True); overload;\r\n\r\n /// Destroys this instance.\r\n /// Do not call this method directly; call Free instead.\r\n destructor Destroy(); override;\r\n\r\n /// Clears the contents of the queue.\r\n procedure Clear();\r\n\r\n /// Checks whether the queue contains a given value.\r\n /// The value to search for.\r\n /// True if the value was found in the queue; False otherwise.\r\n function Contains(const AValue: TValue): Boolean;\r\n\r\n /// Appends an element to the queue with the default priority set to the type's default value.\r\n /// The value to append.\r\n /// Depending on the sorting order specified at creation time, the element is either pushed to the\r\n /// front or the tail of the queue.\r\n procedure Enqueue(const AValue: TValue); overload;\r\n\r\n /// Appends an element to the queue with the given priority.\r\n /// The value to append.\r\n /// The priority of the value.\r\n /// This method automatically moves the enqueued value to the correct position using the sorting order\r\n /// or the specified priority.\r\n procedure Enqueue(const AValue: TValue; const APriority: TPriority); overload;\r\n\r\n /// Retrieves the element from the bottom of the queue.\r\n /// The value at the bottom of the queue.\r\n /// This method removes the element from the bottom of the queue.\r\n /// The queue is empty.\r\n function Dequeue(): TValue; overload;\r\n\r\n /// Reads the element from the bottom of the queue.\r\n /// The value at the bottom of the queue.\r\n /// This method does not remove the element from the bottom of the queue. It merely reads its value.\r\n /// The queue is empty.\r\n function Peek(): TValue; overload;\r\n\r\n /// Specifies the number of elements in the queue.\r\n /// A positive value specifying the number of elements in the queue.\r\n property Count: NativeInt read FCount;\r\n\r\n /// Specifies the current capacity.\r\n /// A positive number that specifies the number of elements that the queue can hold before it\r\n /// needs to grow again.\r\n /// The value of this property is greater than or equal to the amount of elements in the queue. If this value\r\n /// if greater than the number of elements, it means that the queue has some extra capacity to operate upon.\r\n property Capacity: NativeInt read GetCapacity;\r\n\r\n /// Returns a new enumerator object used to enumerate this queue.\r\n /// This method is usually called by compiler-generated code. Its purpose is to create an enumerator\r\n /// object that is used to actually traverse the queue.\r\n /// An enumerator object.\r\n function GetEnumerator() : IEnumerator>; override;\r\n\r\n /// Removes the excess capacity from the queue.\r\n /// This method can be called manually to force the queue to drop the extra capacity it might hold. For example,\r\n /// after performing some massive operations on a big list, call this method to ensure that all extra memory held by the\r\n /// queue is released.\r\n procedure Shrink();\r\n\r\n /// Forces the queue to increase its capacity.\r\n /// Call this method to force the queue to increase its capacity ahead of time. Manually adjusting the capacity\r\n /// can be useful in certain situations.\r\n procedure Grow();\r\n\r\n /// Copies the values stored in the queue to a given array.\r\n /// An array where to copy the contents of the queue.\r\n /// The index into the array at which the copying begins.\r\n /// This method assumes that has enough space to hold the contents of the queue.\r\n /// is out of bounds.\r\n /// The array is not long enough.\r\n procedure CopyTo(var AArray: array of TPair; const AStartIndex: NativeInt); overload; override;\r\n\r\n /// Returns the biggest priority associated with an element in the queue.\r\n /// A priority of an element from the queue considered to have the biggest value.\r\n /// The queue is empty.\r\n function MaxKey(): TPriority; override;\r\n end;\r\n\r\n /// The generic priority queue collection designed to store objects.\r\n /// This collection reorganizes the first-out element based on a given priority.\r\n TObjectPriorityQueue = class(TPriorityQueue)\r\n private\r\n FOwnsPriorities, FOwnsValues: Boolean;\r\n\r\n protected\r\n /// Frees the priority (object) that was removed from the queue.\r\n /// The priority that was removed from the queue.\r\n procedure HandleKeyRemoved(const AKey: TPriority); override;\r\n\r\n /// Frees the value (object) that was removed from the queue.\r\n /// The value that was removed from the queue.\r\n procedure HandleValueRemoved(const AValue: TValue); override;\r\n public\r\n /// Specifies whether this queue owns the priorities (if objects).\r\n /// True if the queue owns the priorities; False otherwise.\r\n /// This property controls the way the queue controls the life-time of the stored priorities. The value of\r\n /// this property has effect only if the priorities are objects, otherwise it is ignored.\r\n property OwnsPriorities: Boolean read FOwnsPriorities write FOwnsPriorities;\r\n\r\n /// Specifies whether this queue owns the values.\r\n /// True if the queue owns the values; False otherwise.\r\n /// This property controls the way the queue controls the life-time of the stored values. The value of\r\n /// this property has effect only if the values are objects, otherwise it is ignored.\r\n property OwnsValues: Boolean read FOwnsValues write FOwnsValues;\r\n end;\r\n\r\nimplementation\r\n\r\n{ TAbstractQueue }\r\n\r\nconstructor TAbstractQueue.Create(const ARules: TRules);\r\nbegin\r\n inherited Create(ARules);\r\nend;\r\n\r\nfunction TAbstractQueue.Dequeue: T;\r\nbegin\r\n ExceptionHelper.Throw_OperationNotSupported('Dequeue');\r\nend;\r\n\r\nprocedure TAbstractQueue.Enqueue(const AValue: T);\r\nbegin\r\n Add(AValue);\r\nend;\r\n\r\nfunction TAbstractQueue.Peek: T;\r\nbegin\r\n Result := First();\r\nend;\r\n\r\n{ TQueue }\r\n\r\nfunction TQueue.Aggregate(const AAggregator: TFunc): T;\r\nvar\r\n I, LH: NativeInt;\r\nbegin\r\n { Check arguments }\r\n if not Assigned(AAggregator) then\r\n ExceptionHelper.Throw_ArgumentNilError('AAggregator');\r\n\r\n if FLength = 0 then\r\n ExceptionHelper.Throw_CollectionEmptyError();\r\n\r\n LockForRead;\r\n\r\n { Select the first element as comparison base }\r\n Result := FArray[FHead];\r\n\r\n LH := (FHead + 1) mod Length(FArray);\r\n\r\n for I := 1 to FLength - 1 do\r\n begin\r\n { Aggregate a value }\r\n Result := AAggregator(Result, FArray[LH]);\r\n\r\n { Circulate Head }\r\n LH := (LH + 1) mod Length(FArray);\r\n end;\r\n\r\n UnLockForRead;\r\nend;\r\n\r\nfunction TQueue.AggregateOrDefault(const AAggregator: TFunc; const ADefault: T): T;\r\nvar\r\n I, LH: NativeInt;\r\nbegin\r\n { Check arguments }\r\n if not Assigned(AAggregator) then\r\n ExceptionHelper.Throw_ArgumentNilError('AAggregator');\r\n\r\n if FLength = 0 then\r\n Exit(ADefault);\r\n\r\n LockForRead;\r\n\r\n { Select the first element as comparison base }\r\n Result := FArray[FHead];\r\n\r\n LH := (FHead + 1) mod Length(FArray);\r\n\r\n for I := 1 to FLength - 1 do\r\n begin\r\n { Aggregate a value }\r\n Result := AAggregator(Result, FArray[LH]);\r\n\r\n { Circulate Head }\r\n LH := (LH + 1) mod Length(FArray);\r\n end;\r\n\r\n UnLockForRead;\r\nend;\r\n\r\nfunction TQueue.All(const APredicate: TPredicate): Boolean;\r\nvar\r\n I, LH: NativeInt;\r\nbegin\r\n if not Assigned(APredicate) then\r\n ExceptionHelper.Throw_ArgumentNilError('APredicate');\r\n\r\n LockForRead;\r\n\r\n if FLength > 0 then\r\n begin\r\n LH := FHead;\r\n for I := 0 to FLength - 1 do\r\n begin\r\n if not APredicate(FArray[LH]) then\r\n begin\r\n UnLockForRead;\r\n Exit(false);\r\n end;\r\n\r\n { Circulate Head }\r\n LH := (LH + 1) mod Length(FArray);\r\n end;\r\n end;\r\n\r\n UnLockForRead;\r\n\r\n Result := true;\r\nend;\r\n\r\nfunction TQueue.Any(const APredicate: TPredicate): Boolean;\r\nvar\r\n I, LH: NativeInt;\r\nbegin\r\n if not Assigned(APredicate) then\r\n ExceptionHelper.Throw_ArgumentNilError('APredicate');\r\n\r\n LockForRead;\r\n\r\n if FLength > 0 then\r\n begin\r\n LH := FHead;\r\n for I := 0 to FLength - 1 do\r\n begin\r\n if APredicate(FArray[LH]) then\r\n begin\r\n UnLockForRead;\r\n Exit(true);\r\n end;\r\n\r\n { Circulate Head }\r\n LH := (LH + 1) mod Length(FArray);\r\n end;\r\n end;\r\n\r\n UnLockForRead;\r\n\r\n Result := false;\r\nend;\r\n\r\nprocedure TQueue.Clear;\r\nvar\r\n LElement: T;\r\nbegin\r\n { If must cleanup, use the dequeue method }\r\n while Count > 0 do\r\n begin\r\n LElement := Dequeue();\r\n NotifyElementRemoved(LElement);\r\n end;\r\n\r\n LockForWrite;\r\n\r\n { Clear all internals }\r\n FTail := 0;\r\n FHead := 0;\r\n FLength := 0;\r\n\r\n NotifyCollectionChanged();\r\n\r\n UnLockForWrite;\r\nend;\r\n\r\nfunction TQueue.Contains(const AValue: T): Boolean;\r\nvar\r\n I: NativeInt;\r\n LCapacity: NativeInt;\r\nbegin\r\n { Do a look-up in all the queue }\r\n Result := False;\r\n\r\n LockForRead;\r\n\r\n I := FHead;\r\n LCapacity := Length(FArray);\r\n\r\n while I <> FTail do\r\n begin\r\n if ElementsAreEqual(FArray[I], AValue) then\r\n begin\r\n Result := True;\r\n Break;\r\n end;\r\n\r\n { Next + wrap over }\r\n I := (I + 1) mod LCapacity;\r\n end;\r\n\r\n UnLockForRead;\r\nend;\r\n \r\nprocedure TQueue.CopyTo(var AArray: array of T; const AStartIndex: NativeInt);\r\nvar\r\n I, X: NativeInt;\r\n LCapacity: NativeInt;\r\nbegin\r\n { Check for indexes }\r\n if (AStartIndex >= Length(AArray)) or (AStartIndex < 0) then\r\n ExceptionHelper.Throw_ArgumentOutOfRangeError('AStartIndex');\r\n\r\n if (Length(AArray) - AStartIndex) < Count then\r\n ExceptionHelper.Throw_ArgumentOutOfSpaceError('AArray');\r\n\r\n LockForRead;\r\n\r\n X := AStartIndex;\r\n I := FHead;\r\n LCapacity := Length(FArray);\r\n\r\n LockForWrite;\r\n\r\n while FTail <> I do\r\n begin\r\n { Copy value }\r\n AArray[X] := FArray[I];\r\n\r\n { Next + wrap over }\r\n I := (I + 1) mod LCapacity;\r\n Inc(X);\r\n end;\r\n\r\n UnLockForWrite;\r\n\r\n UnLockForRead;\r\nend;\r\n\r\nconstructor TQueue.Create(const AThreadSafe: Boolean = False);\r\nbegin\r\n Create(TRules.Default, CDefaultSize, AThreadSafe);\r\nend;\r\n\r\nconstructor TQueue.Create(const ARules: TRules; const AInitialCapacity: NativeInt; const AThreadSafe: Boolean = False);\r\nbegin\r\n inherited Create(ARules);\r\n\r\n ThreadSafe := AThreadSafe;\r\n\r\n LockForWrite;\r\n\r\n if AInitialCapacity <= 0 then\r\n SetLength(FArray, 0)\r\n else\r\n SetLength(FArray, AInitialCapacity);\r\n\r\n UnLockForWrite;\r\nend;\r\n\r\nconstructor TQueue.Create(const AInitialCapacity: NativeInt; const AThreadSafe: Boolean = False);\r\nbegin\r\n Create(TRules.Default, AInitialCapacity, AThreadSafe);\r\nend;\r\n\r\nconstructor TQueue.Create(const ARules: TRules; const AThreadSafe: Boolean = False);\r\nbegin\r\n Create(ARules, CDefaultSize, AThreadSafe);\r\nend;\r\n\r\nfunction TQueue.ElementAt(const AIndex: NativeInt): T;\r\nvar\r\n LH: NativeInt;\r\nbegin\r\n if (AIndex >= FLength) or (AIndex < 0) then\r\n ExceptionHelper.Throw_ArgumentOutOfRangeError('AIndex');\r\n\r\n LockForRead;\r\n\r\n LH := (FHead + AIndex) mod Length(FArray);\r\n Result := FArray[LH];\r\n\r\n UnLockForRead;\r\nend;\r\n\r\nfunction TQueue.ElementAtOrDefault(const AIndex: NativeInt; const ADefault: T): T;\r\nvar\r\n LH: NativeInt;\r\nbegin\r\n if (AIndex >= FLength) or (AIndex < 0) then\r\n Exit(ADefault);\r\n\r\n LockForRead;\r\n\r\n LH := (FHead + AIndex) mod Length(FArray);\r\n Result := FArray[LH];\r\n\r\n UnLockForRead;\r\nend;\r\n\r\nfunction TQueue.Empty: Boolean;\r\nbegin\r\n Result := (FLength = 0);\r\nend;\r\n\r\nprocedure TQueue.Add(const AValue: T);\r\nvar\r\n LNewCapacity: NativeInt;\r\nbegin\r\n LockForWrite;\r\n\r\n { Ensure Capacity }\r\n if FLength = Length(FArray) then\r\n begin\r\n LNewCapacity := Length(FArray) * 2;\r\n\r\n if LNewCapacity < CDefaultSize then\r\n LNewCapacity := Length(FArray) + CDefaultSize;\r\n\r\n SetCapacity(LNewCapacity);\r\n end;\r\n\r\n { Place the element to the end of the list }\r\n FArray[FTail] := AValue;\r\n FTail := (FTail + 1) mod Length(FArray);\r\n\r\n Inc(FLength);\r\n\r\n NotifyCollectionChanged();\r\n\r\n UnLockForWrite;\r\nend;\r\n\r\nfunction TQueue.EqualsTo(const ACollection: IEnumerable): Boolean;\r\nvar\r\n LValue: T;\r\n I, LH: NativeInt;\r\nbegin\r\n LockForRead;\r\n\r\n I := 0;\r\n LH := FHead;\r\n\r\n for LValue in ACollection do\r\n begin\r\n if I >= FLength then\r\n begin\r\n UnLockForRead;\r\n Exit(false);\r\n end;\r\n\r\n if not ElementsAreEqual(FArray[LH], LValue) then\r\n begin\r\n UnLockForRead;\r\n Exit(false);\r\n end;\r\n\r\n LH := (LH + 1) mod Length(FArray);\r\n Inc(I);\r\n end;\r\n\r\n if I < FLength then\r\n begin\r\n UnLockForRead;\r\n Exit(false);\r\n end;\r\n\r\n UnLockForRead;\r\n\r\n Result := true;\r\nend;\r\n\r\nfunction TQueue.First: T;\r\nbegin\r\n { Check length }\r\n if FLength = 0 then\r\n ExceptionHelper.Throw_CollectionEmptyError();\r\n\r\n LockForRead;\r\n\r\n Result := FArray[FHead];\r\n\r\n UnLockForRead;\r\nend;\r\n\r\nfunction TQueue.FirstOrDefault(const ADefault: T): T;\r\nbegin\r\n LockForRead;\r\n\r\n { Check length }\r\n if FLength = 0 then\r\n Result := ADefault\r\n else\r\n Result := FArray[FHead];\r\n\r\n UnLockForRead;\r\nend;\r\n\r\nfunction TQueue.Dequeue: T;\r\nbegin\r\n if FLength = 0 then\r\n ExceptionHelper.Throw_CollectionEmptyError();\r\n\r\n LockForRead;\r\n\r\n { Get the head }\r\n Result := FArray[FHead];\r\n\r\n LockForWrite;\r\n\r\n { Circulate Head }\r\n FHead := (FHead + 1) mod Length(FArray);\r\n\r\n Dec(FLength);\r\n NotifyCollectionChanged();\r\n\r\n UnLockForWrite;\r\n\r\n UnLockForRead;\r\nend;\r\n\r\ndestructor TQueue.Destroy;\r\nbegin\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TQueue.GetCapacity: NativeInt;\r\nbegin\r\n Result := Length(FArray);\r\nend;\r\n\r\nfunction TQueue.GetCount: NativeInt;\r\nbegin\r\n Result := FLength;\r\nend;\r\n\r\nfunction TQueue.GetEnumerator: IEnumerator;\r\nvar\r\n LEnumerator: TEnumerator;\r\nbegin\r\n LEnumerator := TEnumerator.Create(Self);\r\n LEnumerator.FCurrentHead := FHead;\r\n Result := LEnumerator;\r\nend;\r\n\r\nprocedure TQueue.Grow;\r\nvar\r\n LNewCapacity: NativeInt;\r\nbegin\r\n LockForRead;\r\n\r\n { Ensure Capacity }\r\n if FLength = Length(FArray) then\r\n begin\r\n LNewCapacity := Length(FArray) * 2;\r\n\r\n if LNewCapacity < CDefaultSize then\r\n LNewCapacity := Length(FArray) + CDefaultSize;\r\n\r\n SetCapacity(LNewCapacity);\r\n end;\r\n\r\n UnLockForRead;\r\nend;\r\n\r\nfunction TQueue.Last: T;\r\nvar\r\n LT: NativeInt;\r\nbegin\r\n { Check length }\r\n if FLength = 0 then\r\n ExceptionHelper.Throw_CollectionEmptyError();\r\n\r\n LockForRead;\r\n\r\n LT := (FTail - 1) mod Length(FArray);\r\n Result := FArray[LT];\r\n\r\n UnLockForRead;\r\nend;\r\n\r\nfunction TQueue.LastOrDefault(const ADefault: T): T;\r\nvar\r\n LT: NativeInt;\r\nbegin\r\n LockForRead;\r\n\r\n { Check length }\r\n if FLength = 0 then\r\n Result := ADefault\r\n else\r\n begin\r\n LT := (FTail - 1) mod Length(FArray);\r\n Result := FArray[LT];\r\n end;\r\n\r\n UnLockForRead;\r\nend;\r\n\r\nfunction TQueue.Max: T;\r\nvar\r\n I, LH: NativeInt;\r\nbegin\r\n { Check length }\r\n if FLength = 0 then\r\n ExceptionHelper.Throw_CollectionEmptyError();\r\n\r\n LockForRead;\r\n\r\n { Default one }\r\n LH := FHead;\r\n Result := FArray[LH];\r\n\r\n LH := (LH + 1) mod Length(FArray);\r\n\r\n for I := 1 to FLength - 1 do\r\n begin\r\n if CompareElements(FArray[LH], Result) > 0 then\r\n Result := FArray[I];\r\n\r\n { Circulate Head }\r\n LH := (LH + 1) mod Length(FArray);\r\n end;\r\n\r\n UnLockForRead;\r\nend;\r\n\r\nfunction TQueue.Min: T;\r\nvar\r\n I, LH: NativeInt;\r\nbegin\r\n { Check length }\r\n if FLength = 0 then\r\n ExceptionHelper.Throw_CollectionEmptyError();\r\n\r\n LockForRead;\r\n\r\n { Default one }\r\n LH := FHead;\r\n Result := FArray[LH];\r\n\r\n LH := (LH + 1) mod Length(FArray);\r\n\r\n for I := 1 to FLength - 1 do\r\n begin\r\n if CompareElements(FArray[LH], Result) < 0 then\r\n Result := FArray[I];\r\n\r\n { Circulate Head }\r\n LH := (LH + 1) mod Length(FArray);\r\n end;\r\n\r\n UnLockForRead;\r\nend;\r\n\r\nprocedure TQueue.SetCapacity(const ANewCapacity: NativeInt);\r\nvar\r\n LNewArray: TArray;\r\nbegin\r\n LockForWrite;\r\n { Create new array }\r\n SetLength(LNewArray, ANewCapacity);\r\n\r\n if (FLength > 0) then\r\n begin\r\n if FHead < FTail then\r\n Move(FArray[FHead], LNewArray[0], FLength * SizeOf(T))\r\n else\r\n begin\r\n Move(FArray[FHead], LNewArray[0], (FLength - FHead) * SizeOf(T));\r\n Move(FArray[0], LNewArray[Length(FArray) - FHead], FTail * SizeOf(T));\r\n end;\r\n end;\r\n\r\n { Switch arrays }\r\n FArray := LNewArray;\r\n FTail := FLength;\r\n FHead := 0;\r\n\r\n NotifyCollectionChanged();\r\n\r\n UnLockForWrite;\r\nend;\r\n\r\nprocedure TQueue.Shrink;\r\nbegin\r\n LockForRead;\r\n\r\n { Ensure Capacity }\r\n if FLength < Capacity then\r\n SetCapacity(FLength);\r\n\r\n UnLockForRead;\r\nend;\r\n\r\nfunction TQueue.Single: T;\r\nbegin\r\n { Check length }\r\n if FLength = 0 then\r\n ExceptionHelper.Throw_CollectionEmptyError()\r\n else\r\n if FLength > 1 then\r\n ExceptionHelper.Throw_CollectionHasMoreThanOneElement()\r\n else\r\n begin\r\n LockForRead;\r\n Result := FArray[FHead];\r\n UnLockForRead;\r\n end;\r\nend;\r\n\r\nfunction TQueue.SingleOrDefault(const ADefault: T): T;\r\nbegin\r\n { Check length }\r\n if FLength = 0 then\r\n Result := ADefault\r\n else\r\n if FLength > 1 then\r\n ExceptionHelper.Throw_CollectionHasMoreThanOneElement()\r\n else\r\n begin\r\n LockForRead;\r\n Result := FArray[FHead];\r\n UnLockForRead;\r\n end;\r\nend;\r\n\r\n{ TQueue.TEnumerator }\r\n\r\nfunction TQueue.TEnumerator.TryMoveNext(out ACurrent: T): Boolean;\r\nbegin\r\n with TQueue(Owner) do\r\n begin\r\n Result := FLeftCount < FLength;\r\n if Result then\r\n begin\r\n ACurrent := FArray[FCurrentHead];\r\n\r\n { Circulate Head }\r\n FCurrentHead := (FCurrentHead + 1) mod Length(FArray);\r\n Inc(FLeftCount);\r\n end;\r\n end;\r\nend;\r\n\r\n{ TObjectQueue }\r\n\r\nprocedure TObjectQueue.HandleElementRemoved(const AElement: T);\r\nbegin\r\n if FOwnsObjects then\r\n TObject(AElement).Free;\r\nend;\r\n\r\n{ TLinkedQueue }\r\n\r\nfunction TLinkedQueue.Aggregate(const AAggregator: TFunc): T;\r\nvar\r\n LCurrent: PEntry;\r\nbegin\r\n { Check arguments }\r\n if not Assigned(AAggregator) then\r\n ExceptionHelper.Throw_ArgumentNilError('AAggregator');\r\n\r\n if not Assigned(FFirst) then\r\n ExceptionHelper.Throw_CollectionEmptyError();\r\n\r\n { Select the first element as comparison base }\r\n Result := FFirst^.FValue;\r\n LCurrent := FFirst^.FNext;\r\n\r\n { Iterate over the last N - 1 elements }\r\n while Assigned(LCurrent) do\r\n begin\r\n Result := AAggregator(Result, LCurrent^.FValue);\r\n LCurrent := LCurrent^.FNext;\r\n end;\r\nend;\r\n\r\nfunction TLinkedQueue.AggregateOrDefault(const AAggregator: TFunc; const ADefault: T): T;\r\nvar\r\n LCurrent: PEntry;\r\nbegin\r\n { Check arguments }\r\n if not Assigned(AAggregator) then\r\n ExceptionHelper.Throw_ArgumentNilError('AAggregator');\r\n\r\n { Select the first element as comparison base }\r\n if not Assigned(FFirst) then\r\n Exit(ADefault);\r\n\r\n Result := FFirst^.FValue;\r\n LCurrent := FFirst^.FNext;\r\n\r\n { Iterate over the last N - 1 elements }\r\n while Assigned(LCurrent) do\r\n begin\r\n Result := AAggregator(Result, LCurrent^.FValue);\r\n LCurrent := LCurrent^.FNext;\r\n end;\r\nend;\r\n\r\nfunction TLinkedQueue.All(const APredicate: TPredicate): Boolean;\r\nvar\r\n LCurrent: PEntry;\r\nbegin\r\n if not Assigned(APredicate) then\r\n ExceptionHelper.Throw_ArgumentNilError('APredicate');\r\n\r\n LCurrent := FFirst;\r\n\r\n while Assigned(LCurrent) do\r\n begin\r\n if not APredicate(LCurrent^.FValue) then\r\n Exit(false);\r\n\r\n LCurrent := LCurrent^.FNext;\r\n end;\r\n\r\n Result := true;\r\nend;\r\n\r\nfunction TLinkedQueue.Any(const APredicate: TPredicate): Boolean;\r\nvar\r\n LCurrent: PEntry;\r\nbegin\r\n if not Assigned(APredicate) then\r\n ExceptionHelper.Throw_ArgumentNilError('APredicate');\r\n\r\n LCurrent := FFirst;\r\n\r\n while Assigned(LCurrent) do\r\n begin\r\n if APredicate(LCurrent^.FValue) then\r\n Exit(true);\r\n\r\n LCurrent := LCurrent^.FNext;\r\n end;\r\n\r\n Result := false;\r\nend;\r\n\r\nprocedure TLinkedQueue.Clear;\r\nvar\r\n LCurrent, LNext: PEntry;\r\nbegin\r\n LCurrent := FFirst;\r\n while Assigned(LCurrent) do\r\n begin\r\n NotifyElementRemoved(LCurrent^.FValue);\r\n\r\n { Release}\r\n LNext := LCurrent^.FNext;\r\n ReleaseEntry(LCurrent);\r\n LCurrent := LNext;\r\n end;\r\n\r\n FFirst := nil;\r\n FLast := nil;\r\n FCount := 0;\r\n NotifyCollectionChanged();\r\nend;\r\n\r\nfunction TLinkedQueue.Contains(const AValue: T): Boolean;\r\nvar\r\n LCurrent: PEntry;\r\nbegin\r\n LCurrent := FFirst;\r\n Result := False;\r\n\r\n while Assigned(LCurrent) do\r\n begin\r\n if ElementsAreEqual(AValue, LCurrent^.FValue) then\r\n Exit(True);\r\n\r\n LCurrent := LCurrent^.FNext;\r\n end;\r\nend;\r\n\r\nprocedure TLinkedQueue.CopyTo(var AArray: array of T; const AStartIndex: NativeInt);\r\nvar\r\n X: NativeInt;\r\n LCurrent: PEntry;\r\nbegin\r\n { Check for indexes }\r\n if (AStartIndex >= Length(AArray)) or (AStartIndex < 0) then\r\n ExceptionHelper.Throw_ArgumentOutOfRangeError('AStartIndex');\r\n\r\n if (Length(AArray) - AStartIndex) < FCount then\r\n ExceptionHelper.Throw_ArgumentOutOfSpaceError('AArray');\r\n\r\n X := AStartIndex;\r\n LCurrent := FFirst;\r\n while Assigned(LCurrent) do\r\n begin\r\n AArray[X] := LCurrent^.FValue;\r\n Inc(X);\r\n LCurrent := LCurrent^.FNext;\r\n end;\r\nend;\r\n\r\nconstructor TLinkedQueue.Create;\r\nbegin\r\n Create(TRules.Default);\r\nend;\r\n\r\nconstructor TLinkedQueue.Create(const ARules: TRules);\r\nbegin\r\n inherited Create(ARules);\r\nend;\r\n\r\nfunction TLinkedQueue.ElementAt(const AIndex: NativeInt): T;\r\nvar\r\n LCurrent: PEntry;\r\n LIndex: NativeInt;\r\nbegin\r\n { Check range }\r\n if (AIndex >= FCount) or (AIndex < 0) then\r\n ExceptionHelper.Throw_ArgumentOutOfRangeError('AIndex');\r\n\r\n LCurrent := FFirst;\r\n LIndex := 0;\r\n while Assigned(LCurrent) do\r\n begin\r\n if LIndex = AIndex then\r\n Exit(LCurrent^.FValue);\r\n\r\n LCurrent := LCurrent^.FNext;\r\n Inc(LIndex);\r\n end;\r\n\r\n { Should never happen }\r\n ExceptionHelper.Throw_ArgumentOutOfRangeError('AIndex');\r\nend;\r\n\r\nfunction TLinkedQueue.ElementAtOrDefault(const AIndex: NativeInt; const ADefault: T): T;\r\nvar\r\n LCurrent: PEntry;\r\n LIndex: NativeInt;\r\nbegin\r\n { Check range }\r\n if AIndex < 0 then\r\n ExceptionHelper.Throw_ArgumentOutOfRangeError('AIndex');\r\n\r\n if AIndex >= FCount then\r\n Exit(ADefault);\r\n\r\n LCurrent := FFirst;\r\n LIndex := 0;\r\n while Assigned(LCurrent) do\r\n begin\r\n if LIndex = AIndex then\r\n Exit(LCurrent^.FValue);\r\n\r\n LCurrent := LCurrent^.FNext;\r\n Inc(LIndex);\r\n end;\r\n\r\n { Should never happen }\r\n Result := ADefault;\r\nend;\r\n\r\nfunction TLinkedQueue.Empty: Boolean;\r\nbegin\r\n { Call the one from the list }\r\n Result := not Assigned(FLast);\r\nend;\r\n\r\nprocedure TLinkedQueue.Add(const AValue: T);\r\nvar\r\n LNew: PEntry;\r\nbegin\r\n LNew := NeedEntry(AValue);\r\n LNew^.FPrev := FLast;\r\n LNew^.FNext := nil;\r\n\r\n if Assigned(FLast) then\r\n FLast^.FNext := LNew;\r\n\r\n FLast := LNew;\r\n\r\n if not Assigned(FFirst) then\r\n FFirst := LNew;\r\n\r\n NotifyCollectionChanged();\r\n Inc(FCount);\r\nend;\r\n\r\nfunction TLinkedQueue.EqualsTo(const ACollection: IEnumerable): Boolean;\r\nvar\r\n LValue: T;\r\n LCurrent: PEntry;\r\nbegin\r\n LCurrent := FFirst;\r\n for LValue in ACollection do\r\n begin\r\n if not Assigned(LCurrent) then\r\n Exit(false);\r\n\r\n if not ElementsAreEqual(LCurrent^.FValue, LValue) then\r\n Exit(false);\r\n\r\n LCurrent := LCurrent^.FNext;\r\n end;\r\n\r\n Result := not Assigned(LCurrent);\r\nend;\r\n\r\nfunction TLinkedQueue.First: T;\r\nbegin\r\n if not Assigned(FFirst) then\r\n ExceptionHelper.Throw_CollectionEmptyError();\r\n\r\n Result := FFirst^.FValue;\r\nend;\r\n\r\nfunction TLinkedQueue.FirstOrDefault(const ADefault: T): T;\r\nbegin\r\n if not Assigned(FFirst) then\r\n Result := ADefault\r\n else\r\n Result := FFirst^.FValue;\r\nend;\r\n\r\ndestructor TLinkedQueue.Destroy;\r\nvar\r\n LNext: PEntry;\r\nbegin\r\n { Some cleanup }\r\n Clear();\r\n\r\n { Clear the cached entries too }\r\n if FFreeCount > 0 then\r\n while Assigned(FFirstFree) do\r\n begin\r\n LNext := FFirstFree^.FNext;\r\n\r\n { Delphi doesn finalize this }\r\n FFirstFree^.FValue := default(T);\r\n\r\n FreeMem(FFirstFree);\r\n FFirstFree := LNext;\r\n end;\r\n\r\n inherited;\r\nend;\r\n\r\nfunction TLinkedQueue.Dequeue: T;\r\nvar\r\n LEntry: PEntry;\r\nbegin\r\n if not Assigned(FFirst) then\r\n ExceptionHelper.Throw_CollectionEmptyError();\r\n\r\n LEntry := FFirst;\r\n Result := LEntry^.FValue;\r\n FFirst := LEntry^.FNext;\r\n\r\n if FLast = LEntry then\r\n FLast := FFirst;\r\n\r\n ReleaseEntry(LEntry);\r\n\r\n NotifyCollectionChanged();\r\n Dec(FCount);\r\nend;\r\n\r\nfunction TLinkedQueue.GetCount: NativeInt;\r\nbegin\r\n Result := FCount;\r\nend;\r\n\r\nfunction TLinkedQueue.GetEnumerator: IEnumerator;\r\nvar\r\n LEnumerator: TEnumerator;\r\nbegin\r\n LEnumerator := TEnumerator.Create(Self);\r\n LEnumerator.FCurrentEntry := FFirst;\r\n Result := LEnumerator;\r\nend;\r\n\r\nfunction TLinkedQueue.Last: T;\r\nbegin\r\n if not Assigned(FLast) then\r\n ExceptionHelper.Throw_CollectionEmptyError();\r\n\r\n Result := FLast^.FValue;\r\nend;\r\n\r\nfunction TLinkedQueue.LastOrDefault(const ADefault: T): T;\r\nbegin\r\n if not Assigned(FLast) then\r\n Result := ADefault\r\n else\r\n Result := FLast^.FValue;\r\nend;\r\n\r\nfunction TLinkedQueue.Max: T;\r\nvar\r\n LCurrent: PEntry;\r\nbegin\r\n if not Assigned(FLast) then\r\n ExceptionHelper.Throw_CollectionEmptyError();\r\n\r\n Result := FFirst^.FValue;\r\n LCurrent := FFirst^.FNext;\r\n\r\n while Assigned(LCurrent) do\r\n begin\r\n if CompareElements(LCurrent^.FValue, Result) > 0 then\r\n Result := LCurrent^.FValue;\r\n\r\n LCurrent := LCurrent^.FNext;\r\n end;\r\nend;\r\n\r\nfunction TLinkedQueue.Min: T;\r\nvar\r\n LCurrent: PEntry;\r\nbegin\r\n if not Assigned(FLast) then\r\n ExceptionHelper.Throw_CollectionEmptyError();\r\n\r\n Result := FFirst^.FValue;\r\n LCurrent := FFirst^.FNext;\r\n\r\n while Assigned(LCurrent) do\r\n begin\r\n if CompareElements(LCurrent^.FValue, Result) < 0 then\r\n Result := LCurrent^.FValue;\r\n\r\n LCurrent := LCurrent^.FNext;\r\n end;\r\nend;\r\n\r\nfunction TLinkedQueue.NeedEntry(const AValue: T): PEntry;\r\nbegin\r\n if FFreeCount > 0 then\r\n begin\r\n Result := FFirstFree;\r\n FFirstFree := FFirstFree^.FNext;\r\n\r\n Dec(FFreeCount);\r\n end else\r\n Result := AllocMem(SizeOf(TEntry));\r\n\r\n { Initialize the node }\r\n Result^.FValue := AValue;\r\nend;\r\n\r\nprocedure TLinkedQueue.ReleaseEntry(const AEntry: PEntry);\r\nbegin\r\n if FFreeCount = CDefaultSize then\r\n begin\r\n { Delphi doesn finalize this }\r\n AEntry^.FValue := default(T);\r\n FreeMem(AEntry);\r\n end else begin\r\n { Place the entry into the cache }\r\n AEntry^.FNext := FFirstFree;\r\n FFirstFree := AEntry;\r\n\r\n Inc(FFreeCount);\r\n end;\r\nend;\r\n\r\nfunction TLinkedQueue.Single: T;\r\nbegin\r\n { Check length }\r\n if not Assigned(FFirst) then\r\n ExceptionHelper.Throw_CollectionEmptyError()\r\n else if FFirst <> FLast then\r\n ExceptionHelper.Throw_CollectionHasMoreThanOneElement()\r\n else\r\n Result := FFirst^.FValue;\r\nend;\r\n\r\nfunction TLinkedQueue.SingleOrDefault(const ADefault: T): T;\r\nbegin\r\n { Check length }\r\n if not Assigned(FFirst) then\r\n Result := ADefault\r\n else if FFirst <> FLast then\r\n ExceptionHelper.Throw_CollectionHasMoreThanOneElement()\r\n else\r\n Result := FFirst^.FValue;\r\nend;\r\n\r\n{ TLinkedQueue.TEnumerator }\r\n\r\nfunction TLinkedQueue.TEnumerator.TryMoveNext(out ACurrent: T): Boolean;\r\nbegin\r\n Result := Assigned(FCurrentEntry);\r\n if Result then\r\n begin\r\n ACurrent := FCurrentEntry^.FValue;\r\n FCurrentEntry := FCurrentEntry^.FNext;\r\n end;\r\nend;\r\n\r\n{ TObjectLinkedQueue }\r\n\r\nprocedure TObjectLinkedQueue.HandleElementRemoved(const AElement: T);\r\nbegin\r\n if FOwnsObjects then\r\n TObject(AElement).Free;\r\nend;\r\n\r\n{ TPriorityQueue }\r\n\r\nprocedure TPriorityQueue.Clear;\r\nvar\r\n I: NativeInt;\r\nbegin\r\n { Cleanup the array }\r\n for I := 0 to FCount - 1 do\r\n begin\r\n NotifyKeyRemoved(FArray[I].FPriority);\r\n NotifyValueRemoved(FArray[I].FValue);\r\n end;\r\n\r\n { Dispose of all the stuff }\r\n NotifyCollectionChanged();\r\n FCount := 0;\r\nend;\r\n\r\nfunction TPriorityQueue.Contains(const AValue: TValue): Boolean;\r\nvar\r\n I: NativeInt;\r\nbegin\r\n { Check whether the thing contains what we need }\r\n if FCount > 0 then\r\n for I := 0 to FCount - 1 do\r\n if ValuesAreEqual(FArray[I].FValue, AValue) then\r\n Exit(true);\r\n\r\n { Nope ... }\r\n Result := false;\r\nend;\r\n\r\nprocedure TPriorityQueue.CopyTo(var AArray: array of TPair; const AStartIndex: NativeInt);\r\nvar\r\n I: NativeInt;\r\nbegin\r\n { Check for indexes }\r\n if (AStartIndex >= Length(AArray)) or (AStartIndex < 0) then\r\n ExceptionHelper.Throw_ArgumentOutOfRangeError('AStartIndex');\r\n\r\n if (Length(AArray) - AStartIndex) < FCount then\r\n ExceptionHelper.Throw_ArgumentOutOfSpaceError('AArray');\r\n\r\n { Copy the stuff in }\r\n for I := 0 to FCount - 1 do\r\n begin\r\n AArray[AStartIndex + I].Key := FArray[I].FPriority;\r\n AArray[AStartIndex + I].Value := FArray[I].FValue;\r\n end;\r\nend;\r\n\r\nconstructor TPriorityQueue.Create(const AArray: array of TPair;\r\n const AAscending: Boolean);\r\nbegin\r\n { Call upper constructor }\r\n Create(TRules.Default, TRules.Default, AArray, AAscending);\r\nend;\r\n\r\nconstructor TPriorityQueue.Create(const ACollection: IEnumerable>;\r\n const AAscending: Boolean);\r\nbegin\r\n { Call upper constructor }\r\n Create(TRules.Default, TRules.Default, ACollection, AAscending);\r\nend;\r\n\r\nconstructor TPriorityQueue.Create(const AAscending: Boolean);\r\nbegin\r\n { Call upper constructor }\r\n Create(TRules.Default, TRules.Default, CDefaultSize, AAscending);\r\nend;\r\n\r\nconstructor TPriorityQueue.Create(\r\n const APriorityRules: TRules;\r\n const AValueRules: TRules;\r\n const AArray: array of TPair;\r\n const AAscending: Boolean);\r\nvar\r\n I: NativeInt;\r\nbegin\r\n { Call upper constructor }\r\n Create(APriorityRules, AValueRules, CDefaultSize, AAscending);\r\n\r\n { Copy all items in }\r\n if Length(AArray) > 0 then\r\n for I := 0 to Length(AArray) - 1 do\r\n Enqueue(AArray[I].Value, AArray[I].Key);\r\nend;\r\n\r\nconstructor TPriorityQueue.Create(\r\n const APriorityRules: TRules;\r\n const AValueRules: TRules;\r\n const AInitialCapacity: NativeInt;\r\n const AAscending: Boolean);\r\nbegin\r\n { Install types }\r\n inherited Create(APriorityRules, AValueRules);\r\n\r\n SetLength(FArray, AInitialCapacity);\r\n FCount := 0;\r\n\r\n if AAscending then\r\n FSign := 1\r\n else\r\n FSign := -1;\r\nend;\r\n\r\nconstructor TPriorityQueue.Create(const AInitialCapacity: NativeInt; const AAscending: Boolean);\r\nbegin\r\n { Call upper constructor }\r\n Create(TRules.Default, TRules.Default, AInitialCapacity, AAscending);\r\nend;\r\n\r\nconstructor TPriorityQueue.Create(\r\n const APriorityRules: TRules;\r\n const AValueRules: TRules;\r\n const ACollection: IEnumerable>;\r\n const AAscending: Boolean);\r\nvar\r\n LValue: TPair;\r\nbegin\r\n { Call upper constructor }\r\n Create(APriorityRules, AValueRules, CDefaultSize, AAscending);\r\n\r\n if not Assigned(ACollection) then\r\n ExceptionHelper.Throw_ArgumentNilError('ACollection');\r\n\r\n { Pump in all items }\r\n for LValue in ACollection do\r\n Enqueue(LValue.Value, LValue.Key);\r\nend;\r\n\r\nconstructor TPriorityQueue.Create(\r\n const APriorityRules: TRules;\r\n const AValueRules: TRules;\r\n const AAscending: Boolean);\r\nbegin\r\n { Call upper constructor }\r\n Create(APriorityRules, AValueRules, CDefaultSize, AAscending);\r\nend;\r\n\r\nfunction TPriorityQueue.Dequeue: TValue;\r\nvar\r\n LPair: TPriorityPair;\r\nbegin\r\n if FCount = 0 then\r\n ExceptionHelper.Throw_CollectionEmptyError();\r\n\r\n { Extract element at position zero (the head) }\r\n LPair := RemoveAt(0);\r\n\r\n { CLeanup the priority element }\r\n NotifyKeyRemoved(LPair.FPriority);\r\n\r\n { And return the value }\r\n Result := LPair.FValue;\r\n NotifyCollectionChanged();\r\nend;\r\n\r\ndestructor TPriorityQueue.Destroy;\r\nbegin\r\n { First clear }\r\n Clear();\r\n\r\n inherited;\r\nend;\r\n\r\nprocedure TPriorityQueue.Enqueue(const AValue: TValue; const APriority: TPriority);\r\nvar\r\n I, X: NativeInt;\r\nbegin\r\n { Grow if required }\r\n if FCount = Length(FArray) then\r\n Grow();\r\n\r\n I := FCount;\r\n Inc(FCount);\r\n\r\n { Move items to new positions }\r\n while true do\r\n begin\r\n if I > 0 then\r\n X := (I - 1) div 2\r\n else\r\n X := 0;\r\n\r\n { Check for exit }\r\n if (I = 0) or ((CompareKeys(FArray[X].FPriority, APriority) * FSign) > 0) then\r\n break;\r\n\r\n FArray[I] := FArray[X];\r\n I := X;\r\n end;\r\n\r\n { Insert the new item }\r\n FArray[I].FPriority := APriority;\n FArray[I].FValue := AValue;\n\n NotifyCollectionChanged();\nend;\r\n\r\nprocedure TPriorityQueue.Enqueue(const AValue: TValue);\r\nbegin\r\n { Insert with default priority }\r\n Enqueue(AValue, default(TPriority));\r\nend;\r\n\r\nfunction TPriorityQueue.GetCapacity: NativeInt;\r\nbegin\r\n Result := Length(FArray);\r\nend;\r\n\r\nfunction TPriorityQueue.GetCount: NativeInt;\r\nbegin\r\n { Use the FCount }\r\n Result := FCount;\r\nend;\r\n\r\nfunction TPriorityQueue.GetEnumerator: IEnumerator>;\r\nbegin\r\n { Create an enumerator }\r\n Result := TEnumerator.Create(Self);\r\nend;\r\n\r\nprocedure TPriorityQueue.Grow;\r\nvar\r\n LNewCapacity: NativeInt;\r\nbegin\r\n LNewCapacity := Length(FArray) * 2;\r\n\r\n if LNewCapacity < CDefaultSize then\r\n LNewCapacity := CDefaultSize;\r\n\r\n { Extend the array }\r\n SetLength(FArray, LNewCapacity);\r\nend;\r\n\r\nfunction TPriorityQueue.MaxKey: TPriority;\r\nbegin\r\n if FCount = 0 then\r\n ExceptionHelper.Throw_CollectionEmptyError();\r\n\r\n Result := FArray[0].FPriority;\r\nend;\r\n\r\nfunction TPriorityQueue.Peek: TValue;\r\nbegin\r\n if FCount = 0 then\r\n ExceptionHelper.Throw_CollectionEmptyError();\r\n\r\n { Peek at the element at position zero (the head) }\r\n Result := FArray[0].FValue;\r\nend;\r\n\r\nfunction TPriorityQueue.RemoveAt(const AIndex: NativeInt): TPriorityPair;\r\nvar\r\n LTemp: TPriorityPair;\r\n I, X, LStart: NativeInt;\r\nbegin\r\n { Obtain the item that is removed }\r\n Result := FArray[AIndex];\r\n LTemp := FArray[FCount - 1];\r\n\r\n Dec(FCount);\r\n\r\n { Fill in the create hole }\r\n if (FCount = 0) or (AIndex = FCount) then\n Exit;\n\r\n I := AIndex;\r\n\r\n if I > 0 then\r\n LStart := (I - 1) div 2\r\n else\r\n LStart := 0;\r\n\r\n while ((CompareKeys(LTemp.FPriority, FArray[LStart].FPriority) * FSign) > 0) do\n begin\n FArray[I] := FArray[LStart];\r\n I := LStart;\n\n if I > 0 then\r\n LStart := (I - 1) div 2\r\n else\r\n LStart := 0;\r\n end;\n\n if (I = AIndex) then\n begin\n while (I < (FCount div 2)) do\r\n begin\n X := (I * 2) + 1;\n\n if ((X < FCount - 1) and ((CompareKeys(FArray[X].FPriority, FArray[X + 1].FPriority) * FSign) < 0)) then\n Inc(X);\n\n if ((CompareKeys(FArray[X].FPriority, LTemp.FPriority) * FSign) <= 0) then\n break;\n\n FArray[I] := FArray[X];\n I := X;\n end;\r\n end;\n\n FArray[I] := LTemp;\r\nend;\r\n\r\nprocedure TPriorityQueue.Shrink;\r\nbegin\r\n { Remove the excess stuff }\r\n if FCount < Length(FArray) then\r\n SetLength(FArray, FCount);\r\nend;\r\n\r\n{ TPriorityQueue.TEnumerator }\r\n\r\nfunction TPriorityQueue.TEnumerator.TryMoveNext(out ACurrent: TPair): Boolean;\r\nbegin\r\n with TPriorityQueue(Owner) do\r\n begin\r\n Result := FCurrentIndex < FCount;\r\n\r\n if Result then\r\n begin\r\n ACurrent.Key := FArray[FCurrentIndex].FPriority;\r\n ACurrent.Value := FArray[FCurrentIndex].FValue;\r\n Inc(FCurrentIndex);\r\n end;\r\n end;\r\nend;\r\n\r\n{ TObjectPriorityQueue }\r\n\r\nprocedure TObjectPriorityQueue.HandleKeyRemoved(const AKey: TPriority);\r\nbegin\r\n if FOwnsPriorities then\r\n PObject(@AKey)^.Free;\r\nend;\r\n\r\nprocedure TObjectPriorityQueue.HandleValueRemoved(const AValue: TValue);\r\nbegin\r\n if FOwnsValues then\r\n PObject(@AValue)^.Free;\r\nend;\r\n\r\nend.\r\n" }, { "path": "Collections/Collections.Serialization.pas", "content": "(*\r\n* Copyright (c) 2011-2012, Ciobanu Alexandru\r\n* All rights reserved.\r\n*\r\n* Redistribution and use in source and binary forms, with or without\r\n* modification, are permitted provided that the following conditions are met:\r\n* * Redistributions of source code must retain the above copyright\r\n* notice, this list of conditions and the following disclaimer.\r\n* * Redistributions in binary form must reproduce the above copyright\r\n* notice, this list of conditions and the following disclaimer in the\r\n* documentation and/or other materials provided with the distribution.\r\n* * Neither the name of the nor the\r\n* names of its contributors may be used to endorse or promote products\r\n* derived from this software without specific prior written permission.\r\n*\r\n* THIS SOFTWARE IS PROVIDED BY THE AUTHOR ''AS IS'' AND ANY\r\n* EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED\r\n* WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE\r\n* DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY\r\n* DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES\r\n* (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;\r\n* LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND\r\n* ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT\r\n* (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS\r\n* SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.\r\n*)\r\nunit Collections.Serialization;\r\ninterface\r\nuses\r\n SysUtils,\r\n TypInfo,\r\n Classes,\r\n Rtti,\r\n Generics.Collections,\r\n Collections.Base;\r\n\r\ntype\r\n /// Annotate this attribute on fields that should not be serialized.\r\n NonSerialized = class(TCustomAttribute);\r\n\r\n /// An abstract base class for all serialization engines.\r\n /// Inherit this base class and implement its abstract methods to create a fully functional\r\n /// serialization engine capable of serializing most data types provided by Delphi.\r\n TSerializer = class abstract(TInterfacedObject)\r\n private\r\n FObjectReg: TDictionary;\r\n FDynArrayReg: TDictionary;\r\n FRecordReg: TDictionary;\r\n FLastId: Int32;\r\n FSkipErrors: Boolean;\r\n FRttiContext: TRttiContext;\r\n\r\n procedure ErrorNotSupported(const ATypeInfo: PTypeInfo);\r\n procedure ErrorNotEnoughRtti(const ATypeInfo: PTypeInfo);\r\n procedure ErrorNoFieldRtti(const AField: TRttiField);\r\n procedure SerializeInternal(const AType: TRttiType; const AValueRef: Pointer);\r\n procedure WriteStaticArray(const ATypeInfo: PTypeInfo; const ARefToFirstElement: Pointer);\r\n procedure WriteDynamicArray(const ATypeInfo: PTypeInfo; const ADynArray: Pointer);\r\n procedure WriteRecord(const ATypeInfo: PTypeInfo; const ARefToRecord: Pointer);\r\n procedure WriteClass(const ATypeInfo: PTypeInfo; const AObject: TObject);\r\n protected\r\n /// Specifies the RTTI context object used by this serializer to obtain the required\r\n /// type information. Can be used in descending classes.\r\n /// A RTTI context object.\r\n property RttiContext: TRttiContext read FRttiContext;\r\n\r\n /// Writes a 8-bit signed integer.\r\n /// The value containing the actual data to write.\r\n /// This is an abstract method that must be implemented in desceding serializer classes in order to\r\n /// facilitate writing of the specified value.\r\n /// A wide variety of serialization problems.\r\n procedure WriteInt8(const AValue: Int8); virtual; abstract;\r\n\r\n /// Writes a 8-bit unsigned integer.\r\n /// The value containing the actual data to write.\r\n /// This is an abstract method that must be implemented in desceding serializer classes in order to\r\n /// facilitate writing of the specified value.\r\n /// A wide variety of serialization problems.\r\n procedure WriteUInt8(const AValue: UInt8); virtual; abstract;\r\n\r\n /// Writes a 16-bit signed integer.\r\n /// The value containing the actual data to write.\r\n /// This is an abstract method that must be implemented in desceding serializer classes in order to\r\n /// facilitate writing of the specified value.\r\n /// A wide variety of serialization problems.\r\n procedure WriteInt16(const AValue: Int16); virtual; abstract;\r\n\r\n /// Writes a 16-bit unsigned integer.\r\n /// The value containing the actual data to write.\r\n /// This is an abstract method that must be implemented in desceding serializer classes in order to\r\n /// facilitate writing of the specified value.\r\n /// A wide variety of serialization problems.\r\n procedure WriteUInt16(const AValue: UInt16); virtual; abstract;\r\n\r\n /// Writes a 32-bit signed integer.\r\n /// The value containing the actual data to write.\r\n /// This is an abstract method that must be implemented in desceding serializer classes in order to\r\n /// facilitate writing of the specified value.\r\n /// A wide variety of serialization problems.\r\n procedure WriteInt32(const AValue: Int32); virtual; abstract;\r\n\r\n /// Writes a 32-bit unsigned integer.\r\n /// The value containing the actual data to write.\r\n /// This is an abstract method that must be implemented in desceding serializer classes in order to\r\n /// facilitate writing of the specified value.\r\n /// A wide variety of serialization problems.\r\n procedure WriteUInt32(const AValue: UInt32); virtual; abstract;\r\n\r\n /// Writes a 64-bit signed integer.\r\n /// The value containing the actual data to write.\r\n /// This is an abstract method that must be implemented in desceding serializer classes in order to\r\n /// facilitate writing of the specified value.\r\n /// A wide variety of serialization problems.\r\n procedure WriteInt64(const AValue: Int64); virtual; abstract;\r\n\r\n /// Writes a 64-bit unsigned integer.\r\n /// The value containing the actual data to write.\r\n /// This is an abstract method that must be implemented in desceding serializer classes in order to\r\n /// facilitate writing of the specified value.\r\n /// A wide variety of serialization problems.\r\n procedure WriteUInt64(const AValue: UInt64); virtual; abstract;\r\n\r\n /// Writes a single byte ANSI character.\r\n /// The value containing the actual data to write.\r\n /// This is an abstract method that must be implemented in desceding serializer classes in order to\r\n /// facilitate writing of the specified value.\r\n /// A wide variety of serialization problems.\r\n procedure WriteAnsiChar(const AValue: AnsiChar); virtual; abstract;\r\n\r\n /// Writes a two byte WIDE character.\r\n /// The value containing the actual data to write.\r\n /// This is an abstract method that must be implemented in desceding serializer classes in order to\r\n /// facilitate writing of the specified value.\r\n /// A wide variety of serialization problems.\r\n procedure WriteWideChar(const AValue: WideChar); virtual; abstract;\r\n\r\n /// Writes a single precision floating point value.\r\n /// The value containing the actual data to write.\r\n /// This is an abstract method that must be implemented in desceding serializer classes in order to\r\n /// facilitate writing of the specified value.\r\n /// A wide variety of serialization problems.\r\n procedure WriteSingle(const AValue: Single); virtual; abstract;\r\n\r\n /// Writes a double precision floating point value.\r\n /// The value containing the actual data to write.\r\n /// This is an abstract method that must be implemented in desceding serializer classes in order to\r\n /// facilitate writing of the specified value.\r\n /// A wide variety of serialization problems.\r\n procedure WriteDouble(const AValue: Double); virtual; abstract;\r\n\r\n /// Writes an extended precision floating point value.\r\n /// The value containing the actual data to write.\r\n /// This is an abstract method that must be implemented in desceding serializer classes in order to\r\n /// facilitate writing of the specified value.\r\n /// A wide variety of serialization problems.\r\n procedure WriteExtended(const AValue: Extended); virtual; abstract;\r\n\r\n /// Writes a comp floating point value.\r\n /// The value containing the actual data to write.\r\n /// This is an abstract method that must be implemented in desceding serializer classes in order to\r\n /// facilitate writing of the specified value.\r\n /// A wide variety of serialization problems.\r\n procedure WriteComp(const AValue: Comp); virtual; abstract;\r\n\r\n /// Writes a currency floating point value.\r\n /// The value containing the actual data to write.\r\n /// This is an abstract method that must be implemented in desceding serializer classes in order to\r\n /// facilitate writing of the specified value.\r\n /// A wide variety of serialization problems.\r\n procedure WriteCurrency(const AValue: Currency); virtual; abstract;\r\n\r\n /// Writes a short ANSI string.\r\n /// The value containing the actual data to write.\r\n /// This is an abstract method that must be implemented in desceding serializer classes in order to\r\n /// facilitate writing of the specified value.\r\n /// A wide variety of serialization problems.\r\n procedure WriteShortString(const AValue: ShortString); virtual; abstract;\r\n\r\n /// Writes a long ANSI string.\r\n /// The value containing the actual data to write.\r\n /// This is an abstract method that must be implemented in desceding serializer classes in order to\r\n /// facilitate writing of the specified value.\r\n /// A wide variety of serialization problems.\r\n procedure WriteAnsiString(const AValue: AnsiString); virtual; abstract;\r\n\r\n /// Writes a long WIDE string.\r\n /// The value containing the actual data to write.\r\n /// This is an abstract method that must be implemented in desceding serializer classes in order to\r\n /// facilitate writing of the specified value.\r\n /// A wide variety of serialization problems.\r\n procedure WriteWideString(const AValue: WideString); virtual; abstract;\r\n\r\n /// Writes a long UNICODE string.\r\n /// The value containing the actual data to write.\r\n /// This is an abstract method that must be implemented in desceding serializer classes in order to\r\n /// facilitate writing of the specified value.\r\n /// A wide variety of serialization problems.\r\n procedure WriteUnicodeString(const AValue: UnicodeString); virtual; abstract;\r\n\r\n /// Writes a metaclass. Note that a metaclass might not be resolvable on deserialization.\r\n /// The value containing the actual data to write.\r\n /// This is an abstract method that must be implemented in desceding serializer classes in order to\r\n /// facilitate writing of the specified value.\r\n /// A wide variety of serialization problems.\r\n procedure WriteMetaClass(const AValue: TClass); virtual; abstract;\r\n\r\n /// Writes a set.\r\n /// The value containing the actual data to write.\r\n /// The size in bytes of a set value.\r\n /// This is an abstract method that must be implemented in desceding serializer classes.\r\n /// A wide variety of serialization problems.\r\n procedure WriteSet(const ASetSize: UInt8; const AValue); virtual; abstract;\r\n\r\n /// Writes an enumeration.\r\n /// The ordinal value of the enumeration.\r\n /// This is an abstract method that must be implemented in desceding serializer classes.\r\n /// A wide variety of serialization problems.\r\n procedure WriteEnum(const AValue: Int64); virtual; abstract;\r\n\r\n /// Notifies the serializer that the serialization for the root type is started.\r\n /// This is an abstract method that must be implemented in desceding serializer classes in order to\r\n /// mark the beggining of the serialization process. This is a convenience method, if the serializer needs not prepare\r\n /// itself then a simple empty implementation is enough.\r\n /// A wide variety of serialization problems.\r\n procedure BeginWriteRoot(); virtual; abstract;\r\n\r\n /// Notifies the serializer that the serialization for the root type has ended.\r\n /// This is an abstract method that must be implemented in desceding serializer classes in order to\r\n /// mark the ending of the serialization process. This is a convenience method, if the serializer needs not prepare\r\n /// itself then a simple empty implementation is enough.\r\n /// A wide variety of serialization problems.\r\n procedure EndWriteRoot(); virtual; abstract;\r\n\r\n /// Notifies the serializer that a class or record field is about to be serialized.\r\n /// The field RTTI information.\r\n /// This is an abstract method that must be implemented in desceding serializer classes in order to\r\n /// prepare it for an upcoming field value. This method will never be called with a nil value.\r\n /// A wide variety of serialization problems.\r\n procedure BeginWriteField(const AField: TRttiField); overload; virtual; abstract;\r\n\r\n /// Notifies the serializer that a pseudo-field (otherwise known as a \"label\") is about to be serialized.\r\n /// The name of the pseudo-field.\r\n /// This is an abstract method that must be implemented in desceding serializer classes in order to\r\n /// prepare it for an upcoming field value. The supplied argument can hold anything inclusing and empty string.\r\n /// A wide variety of serialization problems.\r\n procedure BeginWriteField(const ALabel: String); overload; virtual; abstract;\r\n\r\n /// Notifies the serializer that a field or a label was serialized.\r\n /// This is an abstract method that must be implemented in desceding serializer classes. This method marks the end\r\n /// of serialization of a field or label.\r\n /// A wide variety of serialization problems.\r\n procedure EndWriteField(); virtual; abstract;\r\n\r\n /// Notifies the serializer that a record is about to be serialized.\r\n /// The record RTTI information.\r\n /// An internal ID that uniquily identifies this record.\r\n /// This is an abstract method that must be implemented in desceding serializer classes. The supplied \r\n /// will never be nil. The inheriting class should store some of the RTTI information along with the generated ,\r\n /// which will be required on deserialization.\r\n /// A wide variety of serialization problems.\r\n procedure BeginWriteRecord(const ARecordType: TRttiRecordType; const AId: Int32); overload; virtual; abstract;\r\n\r\n /// Notifies the serializer that a record was serialized.\r\n /// This is an abstract method that must be implemented in desceding serializer classes. This method marks the end\r\n /// of serialization of a record. It will only be called if BeginWriteRecord was priorly called.\r\n /// A wide variety of serialization problems.\r\n procedure EndWriteRecord(); virtual; abstract;\r\n\r\n /// Notifies the serializer that a record reference is about to be serialized.\r\n /// An internal ID that uniquily identifies the referenced record.\r\n /// This is an abstract method that must be implemented in desceding serializer classes. This method\r\n /// is called if the serialier notices that the address of the record is the same with the address of another record that was already serialized\r\n /// thus it needs only to store a \"pointer\" to that record. The supplied is the unique ID of the record that was already serialized\r\n /// and has the same address with this one. Note, this method will only be called for \"pointer to record\" types and not static records.\r\n /// A wide variety of serialization problems.\r\n procedure WriteRecordReference(const AReference: Int32); virtual; abstract;\r\n\r\n /// Notifies the serializer that a nil record reference is about to be serialized.\r\n /// This is an abstract method that must be implemented in desceding serializer classes. This method\r\n /// is called if the serialier notices that the address of the record is nil and thus there is nothing to do. Note, this method\r\n /// will only be called for \"pointer to record\" types and not static records.\r\n /// A wide variety of serialization problems.\r\n procedure WriteNilRecordReference(); virtual; abstract;\r\n\r\n /// Notifies the serializer that a class is about to be serialized.\r\n /// The class RTTI information.\r\n /// The metaclass of the class.\r\n /// An internal ID that uniquily identifies this class.\r\n /// This is an abstract method that must be implemented in desceding serializer classes. The supplied \r\n /// will never be nil. The inheriting class should store some of the RTTI information, the meta class along with the generated ,\r\n /// which will be required on deserialization. This method is only called if the class was not already serialized.\r\n /// A wide variety of serialization problems.\r\n procedure BeginWriteClass(const AClassType: TRttiInstanceType; const AType: TClass; const AId: Int32); virtual; abstract;\r\n\r\n /// Notifies the serializer that a class was serialized.\r\n /// This is an abstract method that must be implemented in desceding serializer classes. This method marks the end\r\n /// of serialization of a class. It will only be called if BeginWriteClass was priorly called.\r\n /// A wide variety of serialization problems.\r\n procedure EndWriteClass(); virtual; abstract;\r\n\r\n /// Notifies the serializer that a class reference is about to be serialized.\r\n /// An internal ID that uniquily identifies the referenced class.\r\n /// This is an abstract method that must be implemented in desceding serializer classes. This method\r\n /// is called if the serialier notices that the address of the class instance is the same with the address of another class instance\r\n /// that was already serialized thus it needs only to store a \"pointer\" to that class instance. The supplied \r\n /// is the unique ID of the class instance that was already serialized and has the same address with this one.\r\n /// A wide variety of serialization problems.\r\n procedure WriteClassReference(const AReference: Int32); virtual; abstract;\r\n\r\n /// Notifies the serializer that a nil class instance is about to be serialized.\r\n /// This is an abstract method that must be implemented in desceding serializer classes. This method\r\n /// is called if the serialier notices that the address of the class instance is nil and thus there is nothing to do. It is also impossible to\r\n /// obtain the metaclass from a nil instance.\r\n /// A wide variety of serialization problems.\r\n procedure WriteNilClassReference(); virtual; abstract;\r\n\r\n /// Notifies the serializer that a static array is about to be serialized.\r\n /// The array RTTI information.\r\n /// The number of elements that the array contains.\r\n /// This is an abstract method that must be implemented in desceding serializer classes. This method must store some RTTI information along\r\n /// with the number of elements. This information will be used later on deserialization time.\r\n /// A wide variety of serialization problems.\r\n procedure BeginWriteStaticArray(const AArrayType: TRttiArrayType; const ANumberOfElements: NativeInt); virtual; abstract;\r\n\r\n /// Notifies the serializer that a static array was serialized.\r\n /// This is an abstract method that must be implemented in desceding serializer classes. This method marks the end\r\n /// of serialization of a static array. It will only be called if BeginWriteStaticArray was priorly called.\r\n /// A wide variety of serialization problems.\r\n procedure EndWriteStaticArray(); virtual; abstract;\r\n\r\n /// Notifies the serializer that a dynamic array is about to be serialized.\r\n /// The array RTTI information.\r\n /// The number of elements to serialize. Can never be a value of zero.\r\n /// An internal ID that uniquily identifies this array.\r\n /// This is an abstract method that must be implemented in desceding serializer classes. The supplied \r\n /// will never be nil. The inheriting class should store some of the RTTI information, the number of elements along with the generated ,\r\n /// which will be required on deserialization. This method is only called if the dynamic array was not already serialized.\r\n /// A wide variety of serialization problems.\r\n procedure BeginWriteDynamicArray(const AArrayType: TRttiDynamicArrayType; const ANumberOfElements: NativeInt; const AId: Int32); virtual; abstract;\r\n\r\n /// Notifies the serializer that a dynamic array was serialized.\r\n /// This is an abstract method that must be implemented in desceding serializer classes. This method marks the end\r\n /// of serialization of a dynamic array. It will only be called if BeginWriteDynamicArray was priorly called.\r\n /// A wide variety of serialization problems.\r\n procedure EndWriteDynamicArray(); virtual; abstract;\r\n\r\n /// Notifies the serializer that a dynamic array reference is about to be serialized.\r\n /// An internal ID that uniquily identifies the referenced array.\r\n /// This is an abstract method that must be implemented in desceding serializer classes. This method\r\n /// is called if the serialier notices that the address of the array is the same with the address of another array\r\n /// that was already serialized thus it needs only to store a \"pointer\" to that array. The supplied \r\n /// is the unique ID of the array that was already serialized and has the same address with this one.\r\n /// A wide variety of serialization problems.\r\n procedure WriteDynamicArrayReference(const AReference: Int32); virtual; abstract;\r\n\r\n /// Notifies the serializer that a nil dynamic array is about to be serialized.\r\n /// This is an abstract method that must be implemented in desceding serializer classes. This method\r\n /// is called if the serialier notices that the address of the dynamic array is nil and thus there is nothing to do.\r\n /// A wide variety of serialization problems.\r\n procedure WriteNilDynamicArrayReference(); virtual; abstract;\r\n public\r\n /// Creates a new serializer instance.\r\n /// When descending from this class this constructor must be called. If not called, some internal\r\n /// data structures will remain un-initialized.\r\n constructor Create();\r\n\r\n /// Destroys this serializer instance.\r\n /// Never forget to call this destructor in descendant classes, otherwise memory leaks will occur.\r\n destructor Destroy(); override;\r\n\r\n /// Serializes an object.\r\n /// The object that needs to be serialized. Can be nil.\r\n /// A wide variety of serialization problems.\r\n procedure Serialize(const AObject: TObject); overload;\r\n\r\n /// Serializes an value.\r\n /// The value's type information.\r\n /// The value that needs to be serialized.\r\n /// is nil.\r\n /// A wide variety of serialization problems.\r\n procedure Serialize(const ATypeInfo: PTypeInfo; const AValue); overload;\r\n\r\n /// Serializes an generic value.\r\n /// The value that needs to be serialized.\r\n /// does not have RTTI.\r\n /// A wide variety of serialization problems.\r\n procedure Serialize(const AValue: T); overload;\r\n\r\n /// Specifies whether the serializer throws exceptions for values that cannot be serialized.\r\n /// True if serializer skips problematic fields; False if the serializer raises an exception on\r\n /// problematic fields.\r\n property SkipErrors: Boolean read FSkipErrors write FSkipErrors;\r\n\r\n /// Creates a new default serializer.\r\n /// The stream into which to serialize.\r\n /// A new default binary serializer.\r\n /// Generally, serializers are not reusable for separate contexts. This means that after you serialize a root type\r\n /// the serializer needs to be destroyed.\r\n /// is nil.\r\n class function Default(const AStream: TStream): TSerializer; static;\r\n end;\r\n\r\n /// An abstract base class for all deserialization engines.\r\n /// Inherit this base class and implement its abstract methods to create a fully functional\r\n /// deserialization engine. A serialization engine must also be developed to complement the deserialization engine.\r\n TDeserializer = class abstract(TInterfacedObject)\r\n protected type\r\n /// Defines the possible ways a referencef type is stored.\r\n TReferenceType = (\r\n /// The type was stored completely. All fields or elements were stored.\r\n rtInline,\r\n /// The type was not stored, but rather a reference to another \"instance\" was stored.\r\n rtPointer,\r\n /// The type was not stored because it was a nil reference.\r\n rtNil\r\n );\r\n\r\n private\r\n FObjectReg: TDictionary;\r\n FDynArrayReg: TDictionary;\r\n FRecordReg: TDictionary;\r\n FSkipErrors: Boolean;\r\n FRttiContext: TRttiContext;\r\n\r\n procedure ErrorNotSupported(const ATypeInfo: PTypeInfo);\r\n procedure ErrorNotEnoughRtti(const ATypeInfo: PTypeInfo);\r\n procedure ErrorNoFieldRtti(const AField: TRttiField);\r\n procedure DeserializeInternal(const AType: TRttiType; const AValueRef: Pointer);\r\n function CreateInstance(const AClassType: TRttiInstanceType): TObject;\r\n procedure ReadStaticArray(const ATypeInfo: PTypeInfo; const ARefToFirstElement: Pointer);\r\n procedure ReadDynamicArray(const ATypeInfo: PTypeInfo; out ADynArray: Pointer);\r\n procedure ReadRecord(const ATypeInfo: PTypeInfo; var ARefToRecord: Pointer);\r\n procedure ReadClass(const ATypeInfo: PTypeInfo; out AObject: TObject);\r\n protected\r\n /// Specifies the RTTI context object used by this deserializer to obtain the required\r\n /// type information. Can be used in descending classes.\r\n /// A RTTI context object.\r\n property RttiContext: TRttiContext read FRttiContext;\r\n\r\n /// Reads a 8-bit signed integer.\r\n /// The output value in which read data is stored.\r\n /// This is an abstract method that must be implemented in desceding serializer classes. A correct implementation must\r\n /// verify that the next value in the stream is indeed compatible with this read request and only then read it. Otherwise, the deserializer\r\n /// must raise an exception.\r\n /// A wide variety of deserialization problems.\r\n procedure ReadInt8(out AValue: Int8); virtual; abstract;\r\n\r\n /// Reads a 8-bit unsigned integer.\r\n /// The output value in which read data is stored.\r\n /// This is an abstract method that must be implemented in desceding serializer classes. A correct implementation must\r\n /// verify that the next value in the stream is indeed compatible with this read request and only then read it. Otherwise, the deserializer\r\n /// must raise an exception.\r\n /// A wide variety of deserialization problems.\r\n procedure ReadUInt8(out AValue: UInt8); virtual; abstract;\r\n\r\n /// Reads a 16-bit signed integer.\r\n /// The output value in which read data is stored.\r\n /// This is an abstract method that must be implemented in desceding serializer classes. A correct implementation must\r\n /// verify that the next value in the stream is indeed compatible with this read request and only then read it. Otherwise, the deserializer\r\n /// must raise an exception.\r\n /// A wide variety of deserialization problems.\r\n procedure ReadInt16(out AValue: Int16); virtual; abstract;\r\n\r\n /// Reads a 16-bit unsigned integer.\r\n /// The output value in which read data is stored.\r\n /// This is an abstract method that must be implemented in desceding serializer classes. A correct implementation must\r\n /// verify that the next value in the stream is indeed compatible with this read request and only then read it. Otherwise, the deserializer\r\n /// must raise an exception.\r\n /// A wide variety of deserialization problems.\r\n procedure ReadUInt16(out AValue: UInt16); virtual; abstract;\r\n\r\n /// Reads a 32-bit signed integer.\r\n /// The output value in which read data is stored.\r\n /// This is an abstract method that must be implemented in desceding serializer classes. A correct implementation must\r\n /// verify that the next value in the stream is indeed compatible with this read request and only then read it. Otherwise, the deserializer\r\n /// must raise an exception.\r\n /// A wide variety of deserialization problems.\r\n procedure ReadInt32(out AValue: Int32); virtual; abstract;\r\n\r\n /// Reads a 32-bit unsigned integer.\r\n /// The output value in which read data is stored.\r\n /// This is an abstract method that must be implemented in desceding serializer classes. A correct implementation must\r\n /// verify that the next value in the stream is indeed compatible with this read request and only then read it. Otherwise, the deserializer\r\n /// must raise an exception.\r\n /// A wide variety of deserialization problems.\r\n procedure ReadUInt32(out AValue: UInt32); virtual; abstract;\r\n\r\n /// Reads a 64-bit signed integer.\r\n /// The output value in which read data is stored.\r\n /// This is an abstract method that must be implemented in desceding serializer classes. A correct implementation must\r\n /// verify that the next value in the stream is indeed compatible with this read request and only then read it. Otherwise, the deserializer\r\n /// must raise an exception.\r\n /// A wide variety of deserialization problems.\r\n procedure ReadInt64(out AValue: Int64); virtual; abstract;\r\n\r\n /// Reads a 64-bit unsigned integer.\r\n /// The output value in which read data is stored.\r\n /// This is an abstract method that must be implemented in desceding serializer classes. A correct implementation must\r\n /// verify that the next value in the stream is indeed compatible with this read request and only then read it. Otherwise, the deserializer\r\n /// must raise an exception.\r\n /// A wide variety of deserialization problems.\r\n procedure ReadUInt64(out AValue: UInt64); virtual; abstract;\r\n\r\n /// Reads a single byte ANSI character.\r\n /// The output value in which read data is stored.\r\n /// This is an abstract method that must be implemented in desceding serializer classes. A correct implementation must\r\n /// verify that the next value in the stream is indeed compatible with this read request and only then read it. Otherwise, the deserializer\r\n /// must raise an exception.\r\n /// A wide variety of deserialization problems.\r\n procedure ReadAnsiChar(out AValue: AnsiChar); virtual; abstract;\r\n\r\n /// Reads a two byte WIDE character.\r\n /// The output value in which read data is stored.\r\n /// This is an abstract method that must be implemented in desceding serializer classes. A correct implementation must\r\n /// verify that the next value in the stream is indeed compatible with this read request and only then read it. Otherwise, the deserializer\r\n /// must raise an exception.\r\n /// A wide variety of deserialization problems.\r\n procedure ReadWideChar(out AValue: WideChar); virtual; abstract;\r\n\r\n /// Reads a single precision floating point value.\r\n /// The output value in which read data is stored.\r\n /// This is an abstract method that must be implemented in desceding serializer classes. A correct implementation must\r\n /// verify that the next value in the stream is indeed compatible with this read request and only then read it. Otherwise, the deserializer\r\n /// must raise an exception.\r\n /// A wide variety of deserialization problems.\r\n procedure ReadSingle(out AValue: Single); virtual; abstract;\r\n\r\n /// Reads a double precision floating point value.\r\n /// The output value in which read data is stored.\r\n /// This is an abstract method that must be implemented in desceding serializer classes. A correct implementation must\r\n /// verify that the next value in the stream is indeed compatible with this read request and only then read it. Otherwise, the deserializer\r\n /// must raise an exception.\r\n /// A wide variety of deserialization problems.\r\n procedure ReadDouble(out AValue: Double); virtual; abstract;\r\n\r\n /// Reads an extended precision floating point value.\r\n /// The output value in which read data is stored.\r\n /// This is an abstract method that must be implemented in desceding serializer classes. A correct implementation must\r\n /// verify that the next value in the stream is indeed compatible with this read request and only then read it. Otherwise, the deserializer\r\n /// must raise an exception.\r\n /// A wide variety of deserialization problems.\r\n procedure ReadExtended(out AValue: Extended); virtual; abstract;\r\n\r\n /// Reads a comp floating point value.\r\n /// The output value in which read data is stored.\r\n /// This is an abstract method that must be implemented in desceding serializer classes. A correct implementation must\r\n /// verify that the next value in the stream is indeed compatible with this read request and only then read it. Otherwise, the deserializer\r\n /// must raise an exception.\r\n /// A wide variety of deserialization problems.\r\n procedure ReadComp(out AValue: Comp); virtual; abstract;\r\n\r\n /// Reads a currency floating point value.\r\n /// The output value in which read data is stored.\r\n /// This is an abstract method that must be implemented in desceding serializer classes. A correct implementation must\r\n /// verify that the next value in the stream is indeed compatible with this read request and only then read it. Otherwise, the deserializer\r\n /// must raise an exception.\r\n /// A wide variety of deserialization problems.\r\n procedure ReadCurrency(out AValue: Currency); virtual; abstract;\r\n\r\n /// Reads a short ANSI string.\r\n /// The output value in which read data is stored.\r\n /// This is an abstract method that must be implemented in desceding serializer classes. A correct implementation must\r\n /// verify that the next value in the stream is indeed compatible with this read request and only then read it. Otherwise, the deserializer\r\n /// must raise an exception.\r\n /// A wide variety of deserialization problems.\r\n procedure ReadShortString(out AValue: ShortString); virtual; abstract;\r\n\r\n /// Reads a long ANSI string.\r\n /// The output value in which read data is stored.\r\n /// This is an abstract method that must be implemented in desceding serializer classes. A correct implementation must\r\n /// verify that the next value in the stream is indeed compatible with this read request and only then read it. Otherwise, the deserializer\r\n /// must raise an exception.\r\n /// A wide variety of deserialization problems.\r\n procedure ReadAnsiString(out AValue: AnsiString); virtual; abstract;\r\n\r\n /// Reads a long WIDE string.\r\n /// The output value in which read data is stored.\r\n /// This is an abstract method that must be implemented in desceding serializer classes. A correct implementation must\r\n /// verify that the next value in the stream is indeed compatible with this read request and only then read it. Otherwise, the deserializer\r\n /// must raise an exception.\r\n /// A wide variety of deserialization problems.\r\n procedure ReadWideString(out AValue: WideString); virtual; abstract;\r\n\r\n /// Reads a long UNICODE string.\r\n /// The output value in which read data is stored.\r\n /// This is an abstract method that must be implemented in desceding serializer classes. A correct implementation must\r\n /// verify that the next value in the stream is indeed compatible with this read request and only then read it. Otherwise, the deserializer\r\n /// must raise an exception.\r\n /// A wide variety of deserialization problems.\r\n procedure ReadUnicodeString(out AValue: UnicodeString); virtual; abstract;\r\n\r\n /// Reads a meta class.\r\n /// The output value in which read data is stored.\r\n /// This is an abstract method that must be implemented in desceding serializer classes. A correct implementation must\r\n /// verify that the next value in the stream is indeed compatible with this read request and only then read it. Otherwise, the deserializer\r\n /// must raise an exception.\r\n /// A wide variety of deserialization problems.\r\n procedure ReadMetaClass(out AValue: TClass); virtual; abstract;\r\n\r\n /// Reads a set.\r\n /// The size of the expected set.\r\n /// The output value in which read data is stored.\r\n /// This is an abstract method that must be implemented in desceding serializer classes.\r\n /// A wide variety of deserialization problems.\r\n procedure ReadSet(const ASetSize: UInt8; out AValue); virtual; abstract;\r\n\r\n /// Reads an enumeration.\r\n /// The output value in which read data is stored.\r\n /// This is an abstract method that must be implemented in desceding serializer classes.\r\n /// A wide variety of deserialization problems.\r\n procedure ReadEnum(out AValue: Int64); virtual; abstract;\r\n\r\n /// Notifies the deserializer that the root type is about to be read.\r\n /// This is an abstract method that must be implemented in desceding serializer classes. It marks the\r\n /// beggining of the deserialization process.\r\n /// A wide variety of deserialization problems.\r\n procedure BeginReadRoot(); virtual; abstract;\r\n\r\n /// Notifies the deserializer that the root type was read.\r\n /// This is an abstract method that must be implemented in desceding serializer classes. It marks the\r\n /// end of the deserialization process.\r\n /// A wide variety of deserialization problems.\r\n procedure EndReadRoot(); virtual; abstract;\r\n\r\n /// Notifies the deserializer that a field is about to be read.\r\n /// The field RTTI information. Can never be nil.\r\n /// This is an abstract method that must be implemented in desceding serializer classes. The descendant class must\r\n /// read RTTI and informational data that the complementing serializer has writtern.\r\n /// A wide variety of deserialization problems.\r\n procedure BeginReadField(const AField: TRttiField); overload; virtual; abstract;\r\n\r\n /// Notifies the deserializer that a label is about to be read.\r\n /// The label. Can be any string including an empty one.\r\n /// This is an abstract method that must be implemented in desceding serializer classes.\r\n /// A wide variety of deserialization problems.\r\n procedure BeginReadField(const ALabel: String); overload; virtual; abstract;\r\n\r\n /// Notifies the deserializer that a field or label was read.\r\n /// This is an abstract method that must be implemented in desceding serializer classes. It marks the\r\n /// end of a field or label deserialization.\r\n /// A wide variety of deserialization problems.\r\n procedure EndReadField(); virtual; abstract;\r\n\r\n /// Notifies the deserializer that a record is about to be read.\r\n /// The record RTTI information. Can never be nil.\r\n /// The expected unique record ID as assigned by the serializer. should be filled if the result\r\n /// of this function is rtInline or rtPointer.\r\n /// rtInline is the record is serialized inline. rtPointer if the read data is actually a pointer to another record,\r\n /// in which case identifies the pointed record. A result of rtNil means that a nil reference is read.\r\n /// This is an abstract method that must be implemented in desceding serializer classes. The descending deserializer must return the proper\r\n /// type of serialized entry.\r\n /// A wide variety of deserialization problems.\r\n function BeginReadRecord(const ARecordType: TRttiRecordType; out AId: Int32): TReferenceType; virtual; abstract;\r\n\r\n /// Notifies the deserializer that a record was read.\r\n /// This is an abstract method that must be implemented in desceding serializer classes. It marks the\r\n /// end of a record deserialization and is called only if BeginReadRecord was called priorly.\r\n /// A wide variety of deserialization problems.\r\n procedure EndReadRecord(); virtual; abstract;\r\n\r\n /// Notifies the deserializer that a class is about to be read.\r\n /// The class RTTI information. Can never be nil.\r\n /// The expected metaclass that is used to instantiate the class. If a nil value is returned, RTTI class info is used (which can be wrong).\r\n /// The expected unique class ID as assigned by the serializer. should be filled if the result\r\n /// of this function is rtInline or rtPointer.\r\n /// rtInline is the class is serialized inline. rtPointer if the read data is actually a pointer to another class,\r\n /// in which case identifies the pointed class. A result of rtNil means that a nil reference is read.\r\n /// This is an abstract method that must be implemented in desceding serializer classes. The descending deserializer must return the proper\r\n /// type of serialized entry.\r\n /// A wide variety of deserialization problems.\r\n function BeginReadClass(const AClassType: TRttiInstanceType; out AType: TClass; out AId: Int32): TReferenceType; virtual; abstract;\r\n\r\n /// Notifies the deserializer that a class was read.\r\n /// This is an abstract method that must be implemented in desceding serializer classes. It marks the\r\n /// end of a record deserialization and is called only if BeginReadClass was called priorly.\r\n /// A wide variety of deserialization problems.\r\n procedure EndReadClass(); virtual; abstract;\r\n\r\n /// Notifies the deserializer that a static array is about to be read.\r\n /// The array RTTI information. Can never be nil.\r\n /// The number of expected array elements.\r\n /// This is an abstract method that must be implemented in desceding serializer classes.\r\n /// A wide variety of deserialization problems.\r\n procedure BeginReadStaticArray(const AArrayType: TRttiArrayType; const ANumberOfElements: NativeInt); virtual; abstract;\r\n\r\n /// Notifies the deserializer that a static array was read.\r\n /// This is an abstract method that must be implemented in desceding serializer classes. It marks the\r\n /// end of a record deserialization and is called only if BeginReadDynamicArray was called priorly.\r\n /// A wide variety of deserialization problems.\r\n procedure EndReadStaticArray(); virtual; abstract;\r\n\r\n /// Notifies the deserializer that a dynamic array is about to be read.\r\n /// The class RTTI information. Can never be nil.\r\n /// The number of written array elements. Always greater than zero.\r\n /// The expected unique array ID as assigned by the serializer. should be filled if the result\r\n /// of this function is rtInline or rtPointer.\r\n /// rtInline is the array is serialized inline. rtPointer if the read data is actually a pointer to another array,\r\n /// in which case identifies the pointed array. A result of rtNil means that a nil reference is read.\r\n /// This is an abstract method that must be implemented in desceding serializer classes. The descending deserializer must return the proper\r\n /// type of serialized entry.\r\n /// A wide variety of deserialization problems.\r\n function BeginReadDynamicArray(const AArrayType: TRttiDynamicArrayType; out ANumberOfElements: NativeInt; out AId: Int32): TReferenceType; virtual; abstract;\r\n\r\n /// Notifies the deserializer that a dynamic array was read.\r\n /// This is an abstract method that must be implemented in desceding serializer classes. It marks the\r\n /// end of a record deserialization and is called only if BeginReadDynamicArray was called priorly.\r\n /// A wide variety of deserialization problems.\r\n procedure EndReadDynamicArray(); virtual; abstract;\r\n public\r\n /// Creates a new deserializer instance.\r\n /// When descending from this class this constructor must be called. If not called, some internal\r\n /// data structures will remain un-initialized.\r\n constructor Create();\r\n\r\n /// Destroys this deserializer instance.\r\n /// Never forget to call this destructor in descendant classes, otherwise memory leaks will occur.\r\n destructor Destroy(); override;\r\n\r\n /// Deserializes an object.\r\n /// The deserialized object.\r\n /// A wide variety of serialization problems.\r\n function Deserialize(): TObject; overload;\r\n\r\n /// Serializes an generic value.\r\n /// The deserialized value.\r\n /// does not have RTTI.\r\n /// A wide variety of serialization problems.\r\n function Deserialize(): T; overload;\r\n\r\n /// Deserializes an value.\r\n /// The value's type information.\r\n /// The location of the value that needs to be deserialized.\r\n /// is nil.\r\n /// A wide variety of serialization problems.\r\n procedure Deserialize(const ATypeInfo: PTypeInfo; out AValue); overload;\r\n\r\n /// Specifies whether the deserializer throws exceptions for values that cannot be deserialized.\r\n /// True if deserializer skips problematic fields; False if the deserializer raises an exception on\r\n /// problematic fields.\r\n property SkipErrors: Boolean read FSkipErrors write FSkipErrors;\r\n\r\n /// Creates a new default deserializer.\r\n /// The stream from which to deserialize.\r\n /// A new default binary deserializer.\r\n /// Generally, deserializers are not reusable for separate contexts. This means that after you deserialize a root type\r\n /// the serializer needs to be destroyed.\r\n /// is nil.\r\n class function Default(const AStream: TStream): TDeserializer; static;\r\n end;\r\n\r\n /// Defines a set of methods that can be used to write data to a serialization engine in a safe way.\r\n /// This type wraps a serialization engine and exposes some of its functionality to the consumer classes in a safe way.\r\n /// This type is used by the interface. Note that all write operations must be performed in the same\r\n /// order the read operation will be performed when the class will be deserialized.\r\n TOutputContext = record\r\n private\r\n FSerializer: TSerializer;\r\n class function Create(const ASerializer: TSerializer): TOutputContext; static;\r\n public\r\n /// Writes a 8-bit signed integer using a given label.\r\n /// The name of the value to write. Otherwise known as the \"label\".\r\n /// The value containing the actual data to write.\r\n /// This . Can be used to chain read operations.\r\n /// A wide variety of serialization problems.\r\n function AddValue(const AName: String; const AValue: Int8): TOutputContext; overload;\r\n\r\n /// Writes a 8-bit unsigned integer using a given label.\r\n /// The name of the value to write. Otherwise known as the \"label\".\r\n /// The value containing the actual data to write.\r\n /// This . Can be used to chain read operations.\r\n /// A wide variety of serialization problems.\r\n function AddValue(const AName: String; const AValue: UInt8): TOutputContext; overload;\r\n\r\n /// Writes a 16-bit signed integer using a given label.\r\n /// The name of the value to write. Otherwise known as the \"label\".\r\n /// The value containing the actual data to write.\r\n /// This . Can be used to chain read operations.\r\n /// A wide variety of serialization problems.\r\n function AddValue(const AName: String; const AValue: Int16): TOutputContext; overload;\r\n\r\n /// Writes a 16-bit unsigned integer using a given label.\r\n /// The name of the value to write. Otherwise known as the \"label\".\r\n /// The value containing the actual data to write.\r\n /// This . Can be used to chain read operations.\r\n /// A wide variety of serialization problems.\r\n function AddValue(const AName: String; const AValue: UInt16): TOutputContext; overload;\r\n\r\n /// Writes a 32-bit signed integer using a given label.\r\n /// The name of the value to write. Otherwise known as the \"label\".\r\n /// The value containing the actual data to write.\r\n /// This . Can be used to chain read operations.\r\n /// A wide variety of serialization problems.\r\n function AddValue(const AName: String; const AValue: Int32): TOutputContext; overload;\r\n\r\n /// Writes a 32-bit unsigned integer using a given label.\r\n /// The name of the value to write. Otherwise known as the \"label\".\r\n /// The value containing the actual data to write.\r\n /// This . Can be used to chain read operations.\r\n /// A wide variety of serialization problems.\r\n function AddValue(const AName: String; const AValue: UInt32): TOutputContext; overload;\r\n\r\n /// Writes a 64-bit signed integer using a given label.\r\n /// The name of the value to write. Otherwise known as the \"label\".\r\n /// The value containing the actual data to write.\r\n /// This . Can be used to chain read operations.\r\n /// A wide variety of serialization problems.\r\n function AddValue(const AName: String; const AValue: Int64): TOutputContext; overload;\r\n\r\n /// Writes a 64-bit unsigned integer using a given label.\r\n /// The name of the value to write. Otherwise known as the \"label\".\r\n /// The value containing the actual data to write.\r\n /// This . Can be used to chain read operations.\r\n /// A wide variety of serialization problems.\r\n function AddValue(const AName: String; const AValue: UInt64): TOutputContext; overload;\r\n\r\n /// Writes a single byte ANSI character using a given label.\r\n /// The name of the value to write. Otherwise known as the \"label\".\r\n /// The value containing the actual data to write.\r\n /// This . Can be used to chain read operations.\r\n /// A wide variety of serialization problems.\r\n function AddValue(const AName: String; const AValue: AnsiChar): TOutputContext; overload;\r\n\r\n /// Writes a two byte WIDE character using a given label.\r\n /// The name of the value to write. Otherwise known as the \"label\".\r\n /// The value containing the actual data to write.\r\n /// This . Can be used to chain read operations.\r\n /// A wide variety of serialization problems.\r\n function AddValue(const AName: String; const AValue: WideChar): TOutputContext; overload;\r\n\r\n /// Writes a single precision floating point number using a given label.\r\n /// The name of the value to write. Otherwise known as the \"label\".\r\n /// The value containing the actual data to write.\r\n /// This . Can be used to chain read operations.\r\n /// A wide variety of serialization problems.\r\n function AddValue(const AName: String; const AValue: Single): TOutputContext; overload;\r\n\r\n /// Writes a double precision floating point number using a given label.\r\n /// The name of the value to write. Otherwise known as the \"label\".\r\n /// The value containing the actual data to write.\r\n /// This . Can be used to chain read operations.\r\n /// A wide variety of serialization problems.\r\n function AddValue(const AName: String; const AValue: Double): TOutputContext; overload;\r\n\r\n /// Writes an extended precision floating point number using a given label.\r\n /// The name of the value to write. Otherwise known as the \"label\".\r\n /// The value containing the actual data to write.\r\n /// This . Can be used to chain read operations.\r\n /// A wide variety of serialization problems.\r\n function AddValue(const AName: String; const AValue: Extended): TOutputContext; overload;\r\n\r\n /// Writes a comp floating point number using a given label.\r\n /// The name of the value to write. Otherwise known as the \"label\".\r\n /// The value containing the actual data to write.\r\n /// This . Can be used to chain read operations.\r\n /// A wide variety of serialization problems.\r\n function AddValue(const AName: String; const AValue: Comp): TOutputContext; overload;\r\n\r\n /// Writes a currency floating point number using a given label.\r\n /// The name of the value to write. Otherwise known as the \"label\".\r\n /// The value containing the actual data to write.\r\n /// This . Can be used to chain read operations.\r\n /// A wide variety of serialization problems.\r\n function AddValue(const AName: String; const AValue: Currency): TOutputContext; overload;\r\n\r\n /// Writes a short ANSI string using a given label.\r\n /// The name of the value to write. Otherwise known as the \"label\".\r\n /// The value containing the actual data to write.\r\n /// This . Can be used to chain read operations.\r\n /// A wide variety of serialization problems.\r\n function AddValue(const AName: String; const AValue: ShortString): TOutputContext; overload;\r\n\r\n /// Writes a long ANSI string using a given label.\r\n /// The name of the value to write. Otherwise known as the \"label\".\r\n /// The value containing the actual data to write.\r\n /// This . Can be used to chain read operations.\r\n /// A wide variety of serialization problems.\r\n function AddValue(const AName: String; const AValue: AnsiString): TOutputContext; overload;\r\n\r\n /// Writes a long WIDE string using a given label.\r\n /// The name of the value to write. Otherwise known as the \"label\".\r\n /// The value containing the actual data to write.\r\n /// This . Can be used to chain read operations.\r\n /// A wide variety of serialization problems.\r\n function AddValue(const AName: String; const AValue: WideString): TOutputContext; overload;\r\n\r\n /// Writes a long UNICODE string using a given label.\r\n /// The name of the value to write. Otherwise known as the \"label\".\r\n /// The value containing the actual data to write.\r\n /// This . Can be used to chain read operations.\r\n /// A wide variety of serialization problems.\r\n function AddValue(const AName: String; const AValue: UnicodeString): TOutputContext; overload;\r\n\r\n /// Writes a metaclass using a given label. Note that the metaclass might not be resolvable on deserialization.\r\n /// The name of the value to write. Otherwise known as the \"label\".\r\n /// The value containing the actual data to write.\r\n /// This . Can be used to chain read operations.\r\n /// A wide variety of serialization problems.\r\n function AddValue(const AName: String; const AValue: TClass): TOutputContext; overload;\r\n\r\n /// Writes an object using a given label. Note that the object's metaclass might not be resolvable on deserialization.\r\n /// The name of the value to write. Otherwise known as the \"label\".\r\n /// The value containing the actual data to write.\r\n /// This . Can be used to chain read operations.\r\n /// A wide variety of serialization problems.\r\n function AddValue(const AName: String; const AValue: TObject): TOutputContext; overload;\r\n\r\n /// Writes a generic value using a given label.\r\n /// The name of the value to write. Otherwise known as the \"label\".\r\n /// The value containing the actual data to write.\r\n /// This . Can be used to chain read operations.\r\n /// This method can be used to serialize anything, starting with simple values like integer and ending in types such as arrays of records.\r\n /// A wide variety of serialization problems.\r\n function AddValue(const AName: String; const AValue: T): TOutputContext; overload;\r\n end;\r\n\r\n /// Defines a set of methods that can be used to read data from a deserialization engine in a safe way.\r\n /// This type wraps a deserialization engine and exposes some of its functionality to the consumer classes in a safe way.\r\n /// This type is used by the interface. Note that all read operations must be performed in the same\r\n /// order the write operation were performed when the class was serialized.\r\n TInputContext = record\r\n private\r\n FDeserializer: TDeserializer;\r\n class function Create(const ADeserializer: TDeserializer): TInputContext; static;\r\n public\r\n /// Reads a 8-bit signed integer using a given label.\r\n /// The name of the value to read. Otherwise known as the \"label\".\r\n /// An output value containing the read data.\r\n /// This . Can be used to chain read operations.\r\n /// The provided label wasn't found or the requested type is invalid.\r\n function GetValue(const AName: String; out AValue: Int8): TInputContext; overload;\r\n\r\n /// Reads a 8-bit unsigned integer using a given label.\r\n /// The name of the value to read. Otherwise known as the \"label\".\r\n /// An output value containing the read data.\r\n /// This . Can be used to chain read operations.\r\n /// The provided label wasn't found or the requested type is invalid.\r\n function GetValue(const AName: String; out AValue: UInt8): TInputContext; overload;\r\n\r\n /// Reads a 16-bit signed integer using a given label.\r\n /// The name of the value to read. Otherwise known as the \"label\".\r\n /// An output value containing the read data.\r\n /// This . Can be used to chain read operations.\r\n /// The provided label wasn't found or the requested type is invalid.\r\n function GetValue(const AName: String; out AValue: Int16): TInputContext; overload;\r\n\r\n /// Reads a 16-bit unsigned integer using a given label.\r\n /// The name of the value to read. Otherwise known as the \"label\".\r\n /// An output value containing the read data.\r\n /// This . Can be used to chain read operations.\r\n /// The provided label wasn't found or the requested type is invalid.\r\n function GetValue(const AName: String; out AValue: UInt16): TInputContext; overload;\r\n\r\n /// Reads a 32-bit signed integer using a given label.\r\n /// The name of the value to read. Otherwise known as the \"label\".\r\n /// An output value containing the read data.\r\n /// This . Can be used to chain read operations.\r\n /// The provided label wasn't found or the requested type is invalid.\r\n function GetValue(const AName: String; out AValue: Int32): TInputContext; overload;\r\n\r\n /// Reads a 32-bit unsigned integer using a given label.\r\n /// The name of the value to read. Otherwise known as the \"label\".\r\n /// An output value containing the read data.\r\n /// This . Can be used to chain read operations.\r\n /// The provided label wasn't found or the requested type is invalid.\r\n function GetValue(const AName: String; out AValue: UInt32): TInputContext; overload;\r\n\r\n /// Reads a 64-bit signed integer using a given label.\r\n /// The name of the value to read. Otherwise known as the \"label\".\r\n /// An output value containing the read data.\r\n /// This . Can be used to chain read operations.\r\n /// The provided label wasn't found or the requested type is invalid.\r\n function GetValue(const AName: String; out AValue: Int64): TInputContext; overload;\r\n\r\n /// Reads a 64-bit signed integer using a given label.\r\n /// The name of the value to read. Otherwise known as the \"label\".\r\n /// An output value containing the read data.\r\n /// This . Can be used to chain read operations.\r\n /// The provided label wasn't found or the requested type is invalid.\r\n function GetValue(const AName: String; out AValue: UInt64): TInputContext; overload;\r\n\r\n /// Reads a single byte ANSI character.\r\n /// The name of the value to read. Otherwise known as the \"label\".\r\n /// An output value containing the read data.\r\n /// This . Can be used to chain read operations.\r\n /// The provided label wasn't found or the requested type is invalid.\r\n function GetValue(const AName: String; out AValue: AnsiChar): TInputContext; overload;\r\n\r\n /// Reads a two-byte WIDE character.\r\n /// The name of the value to read. Otherwise known as the \"label\".\r\n /// An output value containing the read data.\r\n /// This . Can be used to chain read operations.\r\n /// The provided label wasn't found or the requested type is invalid.\r\n function GetValue(const AName: String; out AValue: WideChar): TInputContext; overload;\r\n\r\n /// Reads a single precision floating point number.\r\n /// The name of the value to read. Otherwise known as the \"label\".\r\n /// An output value containing the read data.\r\n /// This . Can be used to chain read operations.\r\n /// The provided label wasn't found or the requested type is invalid.\r\n function GetValue(const AName: String; out AValue: Single): TInputContext; overload;\r\n\r\n /// Reads a double precision floating point number.\r\n /// The name of the value to read. Otherwise known as the \"label\".\r\n /// An output value containing the read data.\r\n /// This . Can be used to chain read operations.\r\n /// The provided label wasn't found or the requested type is invalid.\r\n function GetValue(const AName: String; out AValue: Double): TInputContext; overload;\r\n\r\n /// Reads an extended precision floating point number.\r\n /// The name of the value to read. Otherwise known as the \"label\".\r\n /// An output value containing the read data.\r\n /// This . Can be used to chain read operations.\r\n /// The provided label wasn't found or the requested type is invalid.\r\n function GetValue(const AName: String; out AValue: Extended): TInputContext; overload;\r\n\r\n /// Reads comp floating point number.\r\n /// The name of the value to read. Otherwise known as the \"label\".\r\n /// An output value containing the read data.\r\n /// This . Can be used to chain read operations.\r\n /// The provided label wasn't found or the requested type is invalid.\r\n function GetValue(const AName: String; out AValue: Comp): TInputContext; overload;\r\n\r\n /// Reads currency floating point number.\r\n /// The name of the value to read. Otherwise known as the \"label\".\r\n /// An output value containing the read data.\r\n /// This . Can be used to chain read operations.\r\n /// The provided label wasn't found or the requested type is invalid.\r\n function GetValue(const AName: String; out AValue: Currency): TInputContext; overload;\r\n\r\n /// Reads short ANSI string.\r\n /// The name of the value to read. Otherwise known as the \"label\".\r\n /// An output value containing the read data.\r\n /// This . Can be used to chain read operations.\r\n /// The provided label wasn't found or the requested type is invalid.\r\n function GetValue(const AName: String; out AValue: ShortString): TInputContext; overload;\r\n\r\n /// Reads a long ANSI string.\r\n /// The name of the value to read. Otherwise known as the \"label\".\r\n /// An output value containing the read data.\r\n /// This . Can be used to chain read operations.\r\n /// The provided label wasn't found or the requested type is invalid.\r\n function GetValue(const AName: String; out AValue: AnsiString): TInputContext; overload;\r\n\r\n /// Reads a long WIDE string.\r\n /// The name of the value to read. Otherwise known as the \"label\".\r\n /// An output value containing the read data.\r\n /// This . Can be used to chain read operations.\r\n /// The provided label wasn't found or the requested type is invalid.\r\n function GetValue(const AName: String; out AValue: WideString): TInputContext; overload;\r\n\r\n /// Reads a long UNICODE string.\r\n /// The name of the value to read. Otherwise known as the \"label\".\r\n /// An output value containing the read data.\r\n /// This . Can be used to chain read operations.\r\n /// The provided label wasn't found or the requested type is invalid.\r\n function GetValue(const AName: String; out AValue: UnicodeString): TInputContext; overload;\r\n\r\n /// Reads a metaclass. If the metaclass cannot be resolved to a real type a nil values is returned.\r\n /// The name of the value to read. Otherwise known as the \"label\".\r\n /// An output value containing the read data.\r\n /// This . Can be used to chain read operations.\r\n /// The provided label wasn't found or the requested type is invalid.\r\n function GetValue(const AName: String; out AValue: TClass): TInputContext; overload;\r\n\r\n /// Reads an object instance. If the metaclass of the object cannot be resolved the mest match is used.\r\n /// The name of the value to read. Otherwise known as the \"label\".\r\n /// An output value containing the read data.\r\n /// This . Can be used to chain read operations.\r\n /// The provided label wasn't found or the requested type is invalid.\r\n function GetValue(const AName: String; out AValue: TObject): TInputContext; overload;\r\n\r\n /// Reads a generic value. Use this method when none of the above overloads are helpful.\r\n /// The name of the value to read. Otherwise known as the \"label\".\r\n /// An output value containing the read data.\r\n /// This . Can be used to chain read operations.\r\n /// This method can be used to deserialize anything, starting with simple values like integer and ending in types such as arrays of records. If the serialized data\r\n /// is not compatible with the provided generic argument an exception will occur.\r\n /// The provided label wasn't found or the requested type is invalid.\r\n function GetValue(const AName: String; out AValue: T): TInputContext; overload;\r\n end;\r\n\r\n /// Defines a set of methods that need to be implemented by classes in order\r\n /// to override the default serialization support.\r\n /// Implement this interface only if custom serialization code is needed for a\r\n /// class. A class implementing this interface need not to worry about the reference counting mechanics. The serialization engine\r\n /// will not modify the reference count of the instance being serialized or deserializaed.\r\n ISerializable = interface\r\n ['{F00C10CC-1744-4905-B4C9-F158DCF6A7A7}']\r\n\r\n /// Serializes the instance of the class that implements this interface.\r\n /// The output serialization context into which values need to be added.\r\n /// This method is called automatically by the serialization engine when the class implementing this interface\r\n /// is serialized. Use the provided context object to serialize distinct values that make up the object.\r\n procedure Serialize(const AContext: TOutputContext);\r\n\r\n /// Deserializes the instance of the class that implements this interface.\r\n /// The input serialization context from which values need to be read.\r\n /// This method is called automatically by the deserialization engine when the class implementing this interface\r\n /// is deserialized. Use the provided context object to read distinct values that make up the object. Note that this method is called\r\n /// right after the default parameterless constructor of the class is called. The constructor need to prepare the object.\r\n procedure Deserialize(const AContext: TInputContext);\r\n end;\r\n\r\nimplementation\r\n\r\nfunction IsSerializable(const AField: TRttiField): Boolean;\r\nvar\r\n LAttr: TCustomAttribute;\r\nbegin\r\n ASSERT(Assigned(AField));\r\n for LAttr in AField.GetAttributes() do\r\n if LAttr is NonSerialized then\r\n Exit(False);\r\n\r\n Result := True;\r\nend;\r\n\r\nprocedure GetSafeInterface(const AObject: TObject; const AIID: TGUID; var AOut: Pointer);\r\nvar\r\n LIntfEntry: PInterfaceEntry;\r\n\r\nbegin\r\n AOut := nil;\r\n\r\n { Nothing on nil object }\r\n if not Assigned(AObject) then\r\n Exit;\r\n\r\n { Obtain the interface entry }\r\n LIntfEntry := AObject.GetInterfaceEntry(AIID);\r\n\r\n { If there is such an interface and it has an Object offset, get it }\r\n if (Assigned(LIntfEntry)) and (LIntfEntry^.IOffset <> 0) then\r\n AOut := Pointer(NativeUInt(AObject) + NativeUInt(LIntfEntry^.IOffset));\r\n\r\n { Note: No AddRef is performed since we have no idea if the object\r\n has ref cont > 0 already! We're only using the \"pseudo-intf\" entry }\r\nend;\r\n\r\ntype\r\n PInt8 = ^Int8;\r\n PUInt8 = ^UInt8;\r\n PInt16 = ^Int16;\r\n PUInt16 = ^UInt16;\r\n PInt32 = ^Int32;\r\n PUInt32 = ^UInt32;\r\n PInt64 = ^Int64;\r\n PUInt64 = ^UInt64;\r\n PClass = ^TClass;\r\n\r\n{$REGION 'Binary Serialization'}\r\ntype\r\n TStreamedValueType = (\r\n svStartRoot, svEndRoot,\r\n svStartRecord, svEndRecord, svReferencedRecord, svNilRecord,\r\n svStartField, svStartLabel, svEndField,\r\n svStartClass, svEndClass, svReferencedClass, svNilClass,\r\n svStartStaticArray, svEndStaticArray,\r\n svStartDynamicArray, svEndDynamicArray, svReferencedDynamicArray, svNilDynamicArray,\r\n svInt8, svUInt8, svInt16, svUInt16, svInt32, svUInt32, svInt64, svUInt64,\r\n svSingle, svDouble, svExtended, svComp, svCurrency,\r\n svAnsiChar, svWideChar,\r\n svShortString, svAnsiString, svWideString, svUnicodeString,\r\n svMetaClass, svNilMetaClass,\r\n svEnum, svSet\r\n );\r\n\r\n TStreamedValueTypes = set of TStreamedValueType;\r\n\r\n TBinarySerializer = class(TSerializer)\r\n private\r\n FStream: TStream;\r\n\r\n procedure WriteCustomType(const AType: TRttiType);\r\n procedure WriteType(const AType: TStreamedValueType);\r\n procedure WriteData(const ASize: NativeInt; const AData);\r\n protected\r\n procedure WriteInt8(const AValue: Int8); override;\r\n procedure WriteUInt8(const AValue: UInt8); override;\r\n procedure WriteInt16(const AValue: Int16); override;\r\n procedure WriteUInt16(const AValue: UInt16); override;\r\n procedure WriteInt32(const AValue: Int32); override;\r\n procedure WriteUInt32(const AValue: UInt32); override;\r\n procedure WriteInt64(const AValue: Int64); override;\r\n procedure WriteUInt64(const AValue: UInt64); override;\r\n procedure WriteAnsiChar(const AValue: AnsiChar); override;\r\n procedure WriteWideChar(const AValue: WideChar); override;\r\n procedure WriteSingle(const AValue: Single); override;\r\n procedure WriteDouble(const AValue: Double); override;\r\n procedure WriteExtended(const AValue: Extended); override;\r\n procedure WriteComp(const AValue: Comp); override;\r\n procedure WriteCurrency(const AValue: Currency); override;\r\n procedure WriteShortString(const AValue: ShortString); override;\r\n procedure WriteAnsiString(const AValue: AnsiString); override;\r\n procedure WriteWideString(const AValue: WideString); override;\r\n procedure WriteUnicodeString(const AValue: UnicodeString); override;\r\n procedure WriteMetaClass(const AValue: TClass); override;\r\n procedure WriteSet(const ASetSize: UInt8; const AValue); override;\r\n procedure WriteEnum(const AValue: Int64); override;\r\n\r\n procedure BeginWriteRoot(); override;\r\n procedure EndWriteRoot(); override;\r\n\r\n procedure BeginWriteField(const AField: TRttiField); overload; override;\r\n procedure BeginWriteField(const ALabel: String); overload; override;\r\n procedure EndWriteField(); override;\r\n\r\n procedure BeginWriteRecord(const ARecordType: TRttiRecordType; const AId: Int32); override;\r\n procedure EndWriteRecord(); override;\r\n procedure WriteRecordReference(const AReference: Int32); override;\r\n procedure WriteNilRecordReference(); override;\r\n\r\n procedure BeginWriteClass(const AClassType: TRttiInstanceType; const AType: TClass; const AId: Int32); override;\r\n procedure EndWriteClass(); override;\r\n procedure WriteClassReference(const AReference: Int32); override;\r\n procedure WriteNilClassReference(); override;\r\n\r\n procedure BeginWriteStaticArray(const AArrayType: TRttiArrayType; const ANumberOfElements: NativeInt); override;\r\n procedure EndWriteStaticArray(); override;\r\n\r\n procedure BeginWriteDynamicArray(const AArrayType: TRttiDynamicArrayType; const ANumberOfElements: NativeInt; const AId: Int32); override;\r\n procedure EndWriteDynamicArray(); override;\r\n procedure WriteDynamicArrayReference(const AReference: Int32); override;\r\n procedure WriteNilDynamicArrayReference(); override;\r\n public\r\n constructor Create(const AStream: TStream);\r\n end;\r\n\r\n TBinaryDeserializer = class(TDeserializer)\r\n private\r\n FStream: TStream;\r\n\r\n procedure ExpectType(const AWhatType: TRttiType);\r\n procedure Expect(const AWhat: TStreamedValueType); overload;\r\n function Expect(const AWhat: TStreamedValueTypes): TStreamedValueType; overload;\r\n procedure ReadData(const ASize: NativeInt; out AData);\r\n\r\n function GetMetaClass(const AUnit, AClass: String): TClass;\r\n protected\r\n procedure ReadInt8(out AValue: Int8); override;\r\n procedure ReadUInt8(out AValue: UInt8); override;\r\n procedure ReadInt16(out AValue: Int16); override;\r\n procedure ReadUInt16(out AValue: UInt16); override;\r\n procedure ReadInt32(out AValue: Int32); override;\r\n procedure ReadUInt32(out AValue: UInt32); override;\r\n procedure ReadInt64(out AValue: Int64); override;\r\n procedure ReadUInt64(out AValue: UInt64); override;\r\n procedure ReadAnsiChar(out AValue: AnsiChar); override;\r\n procedure ReadWideChar(out AValue: WideChar); override;\r\n procedure ReadSingle(out AValue: Single); override;\r\n procedure ReadDouble(out AValue: Double); override;\r\n procedure ReadExtended(out AValue: Extended); override;\r\n procedure ReadComp(out AValue: Comp); override;\r\n procedure ReadCurrency(out AValue: Currency); override;\r\n procedure ReadShortString(out AValue: ShortString); override;\r\n procedure ReadAnsiString(out AValue: AnsiString); override;\r\n procedure ReadWideString(out AValue: WideString); override;\r\n procedure ReadUnicodeString(out AValue: UnicodeString); override;\r\n procedure ReadMetaClass(out AValue: TClass); override;\r\n procedure ReadSet(const ASetSize: UInt8; out AValue); override;\r\n procedure ReadEnum(out AValue: Int64); override;\r\n\r\n procedure BeginReadRoot(); override;\r\n procedure EndReadRoot(); override;\r\n\r\n procedure BeginReadField(const AField: TRttiField); overload; override;\r\n procedure BeginReadField(const ALabel: String); overload; override;\r\n procedure EndReadField(); override;\r\n\r\n function BeginReadRecord(const ARecordType: TRttiRecordType; out AId: Int32): TDeserializer.TReferenceType; override;\r\n procedure EndReadRecord(); override;\r\n\r\n function BeginReadClass(const AClassType: TRttiInstanceType; out AType: TClass; out AId: Int32): TDeserializer.TReferenceType; override;\r\n procedure EndReadClass(); override;\r\n\r\n procedure BeginReadStaticArray(const AArrayType: TRttiArrayType; const ANumberOfElements: NativeInt); override;\r\n procedure EndReadStaticArray(); override;\r\n\r\n function BeginReadDynamicArray(const AArrayType: TRttiDynamicArrayType; out ANumberOfElements: NativeInt; out AId: Int32): TDeserializer.TReferenceType; override;\r\n procedure EndReadDynamicArray(); override;\r\n\r\n public\r\n constructor Create(const AStream: TStream);\r\n end;\r\n\r\n{ TBinarySerializer }\r\n\r\nprocedure TBinarySerializer.BeginWriteClass(const AClassType: TRttiInstanceType; const AType: TClass; const AId: Int32);\r\nbegin\r\n WriteType(svStartClass);\r\n WriteMetaClass(AType);\r\n WriteInt32(AId);\r\nend;\r\n\r\nprocedure TBinarySerializer.BeginWriteDynamicArray(const AArrayType: TRttiDynamicArrayType; const ANumberOfElements: NativeInt; const AId: Int32);\r\nbegin\r\n ASSERT(Assigned(AArrayType));\r\n ASSERT(ANumberOfElements > 0);\r\n\r\n WriteType(svStartDynamicArray);\r\n WriteCustomType(AArrayType);\r\n\r\n WriteInt32(AId);\r\n WriteInt64(ANumberOfElements);\r\nend;\r\n\r\nprocedure TBinarySerializer.BeginWriteField(const ALabel: String);\r\nbegin\r\n WriteType(svStartLabel);\r\n WriteUnicodeString(ALabel);\r\nend;\r\n\r\nprocedure TBinarySerializer.BeginWriteField(const AField: TRttiField);\r\nbegin\r\n ASSERT(Assigned(AField));\r\n\r\n WriteType(svStartField);\r\n WriteCustomType(AField.FieldType);\r\n WriteUnicodeString(AField.Name);\r\n WriteInt64(AField.Offset);\r\nend;\r\n\r\nprocedure TBinarySerializer.BeginWriteRecord(const ARecordType: TRttiRecordType; const AId: Int32);\r\nbegin\r\n ASSERT(Assigned(ARecordType));\r\n\r\n WriteType(svStartRecord);\r\n WriteCustomType(ARecordType);\r\n WriteInt32(AId);\r\nend;\r\n\r\nprocedure TBinarySerializer.BeginWriteRoot;\r\nbegin\r\n WriteType(svStartRoot);\r\nend;\r\n\r\nprocedure TBinarySerializer.BeginWriteStaticArray(const AArrayType: TRttiArrayType; const ANumberOfElements: NativeInt);\r\nbegin\r\n ASSERT(Assigned(AArrayType));\r\n\r\n WriteType(svStartStaticArray);\r\n WriteCustomType(AArrayType);\r\n WriteInt64(ANumberOfElements);\r\nend;\r\n\r\nconstructor TBinarySerializer.Create(const AStream: TStream);\r\nbegin\r\n inherited Create();\r\n\r\n if not Assigned(AStream) then\r\n ExceptionHelper.Throw_ArgumentNilError('AStream');\r\n\r\n FStream := AStream;\r\nend;\r\n\r\nprocedure TBinarySerializer.EndWriteClass;\r\nbegin\r\n WriteType(svEndClass);\r\nend;\r\n\r\nprocedure TBinarySerializer.EndWriteDynamicArray;\r\nbegin\r\n WriteType(svEndDynamicArray);\r\nend;\r\n\r\nprocedure TBinarySerializer.EndWriteField;\r\nbegin\r\n WriteType(svEndField);\r\nend;\r\n\r\nprocedure TBinarySerializer.EndWriteRecord;\r\nbegin\r\n WriteType(svEndRecord);\r\nend;\r\n\r\nprocedure TBinarySerializer.EndWriteRoot;\r\nbegin\r\n WriteType(svEndRoot);\r\nend;\r\n\r\nprocedure TBinarySerializer.EndWriteStaticArray;\r\nbegin\r\n WriteType(svEndStaticArray);\r\nend;\r\n\r\nprocedure TBinarySerializer.WriteAnsiChar(const AValue: AnsiChar);\r\nbegin\r\n WriteType(svAnsiChar);\r\n WriteData(SizeOf(AValue), AValue);\r\nend;\r\n\r\nprocedure TBinarySerializer.WriteAnsiString(const AValue: AnsiString);\r\nvar\r\n LCodePage: UInt16;\r\n LLength: NativeInt;\r\nbegin\r\n LLength := Length(AValue);\r\n LCodePage := StringCodePage(AValue);\r\n\r\n WriteType(svAnsiString);\r\n WriteData(SizeOf(LCodePage), LCodePage);\r\n WriteData(SizeOf(LLength), LLength);\r\n WriteData(LLength, AValue[1]);\r\nend;\r\n\r\nprocedure TBinarySerializer.WriteClassReference(const AReference: Int32);\r\nbegin\r\n WriteType(svReferencedClass);\r\n WriteInt32(AReference);\r\nend;\r\n\r\nprocedure TBinarySerializer.WriteComp(const AValue: Comp);\r\nbegin\r\n WriteType(svComp);\r\n WriteData(SizeOf(AValue), AValue);\r\nend;\r\n\r\nprocedure TBinarySerializer.WriteCurrency(const AValue: Currency);\r\nbegin\r\n WriteType(svCurrency);\r\n WriteData(SizeOf(AValue), AValue);\r\nend;\r\n\r\nprocedure TBinarySerializer.WriteCustomType(const AType: TRttiType);\r\nbegin\r\n ASSERT(Assigned(AType));\r\n WriteUnicodeString(AType.Name);\r\nend;\r\n\r\nprocedure TBinarySerializer.WriteData(const ASize: NativeInt; const AData);\r\nbegin\r\n FStream.WriteBuffer(AData, ASize);\r\nend;\r\n\r\nprocedure TBinarySerializer.WriteDouble(const AValue: Double);\r\nbegin\r\n WriteType(svDouble);\r\n WriteData(SizeOf(AValue), AValue);\r\nend;\r\n\r\nprocedure TBinarySerializer.WriteDynamicArrayReference(const AReference: Int32);\r\nbegin\r\n WriteType(svReferencedDynamicArray);\r\n WriteData(SizeOf(AReference), AReference);\r\nend;\r\n\r\nprocedure TBinarySerializer.WriteEnum(const AValue: Int64);\r\nbegin\r\n WriteType(svEnum);\r\n WriteData(SizeOf(AValue), AValue);\r\nend;\r\n\r\nprocedure TBinarySerializer.WriteExtended(const AValue: Extended);\r\nbegin\r\n WriteType(svExtended);\r\n WriteData(SizeOf(AValue), AValue);\r\nend;\r\n\r\nprocedure TBinarySerializer.WriteInt16(const AValue: Int16);\r\nbegin\r\n WriteType(svInt16);\r\n WriteData(SizeOf(AValue), AValue);\r\nend;\r\n\r\nprocedure TBinarySerializer.WriteInt32(const AValue: Int32);\r\nbegin\r\n WriteType(svInt32);\r\n WriteData(SizeOf(AValue), AValue);\r\nend;\r\n\r\nprocedure TBinarySerializer.WriteInt64(const AValue: Int64);\r\nbegin\r\n WriteType(svInt64);\r\n WriteData(SizeOf(AValue), AValue);\r\nend;\r\n\r\nprocedure TBinarySerializer.WriteInt8(const AValue: Int8);\r\nbegin\r\n WriteType(svInt8);\r\n WriteData(SizeOf(AValue), AValue);\r\nend;\r\n\r\nprocedure TBinarySerializer.WriteMetaClass(const AValue: TClass);\r\nbegin\r\n if Assigned(AValue) then\r\n begin\r\n WriteType(svMetaClass);\r\n WriteUnicodeString(AValue.UnitName);\r\n WriteUnicodeString(AValue.ClassName);\r\n end else\r\n WriteType(svNilMetaClass);\r\nend;\r\n\r\nprocedure TBinarySerializer.WriteNilClassReference;\r\nbegin\r\n WriteType(svNilClass);\r\nend;\r\n\r\nprocedure TBinarySerializer.WriteNilDynamicArrayReference;\r\nbegin\r\n WriteType(svNilDynamicArray);\r\nend;\r\n\r\nprocedure TBinarySerializer.WriteNilRecordReference;\r\nbegin\r\n WriteType(svNilRecord);\r\nend;\r\n\r\nprocedure TBinarySerializer.WriteRecordReference(const AReference: Int32);\r\nbegin\r\n WriteType(svReferencedRecord);\r\n WriteInt32(AReference);\r\nend;\r\n\r\nprocedure TBinarySerializer.WriteSet(const ASetSize: UInt8; const AValue);\r\nbegin\r\n WriteType(svSet);\r\n WriteUInt8(ASetSize);\r\n WriteData(ASetSize, AValue);\r\nend;\r\n\r\nprocedure TBinarySerializer.WriteShortString(const AValue: ShortString);\r\nvar\r\n LLength: UInt8;\r\nbegin\r\n LLength := Length(AValue);\r\n\r\n WriteType(svShortString);\r\n WriteData(SizeOf(LLength), LLength);\r\n WriteData(LLength, AValue[1]);\r\nend;\r\n\r\nprocedure TBinarySerializer.WriteSingle(const AValue: Single);\r\nbegin\r\n WriteType(svSingle);\r\n WriteData(SizeOf(AValue), AValue);\r\nend;\r\n\r\nprocedure TBinarySerializer.WriteType(const AType: TStreamedValueType);\r\nbegin\r\n FStream.WriteBuffer(AType, SizeOf(AType));\r\nend;\r\n\r\nprocedure TBinarySerializer.WriteUInt16(const AValue: UInt16);\r\nbegin\r\n WriteType(svUInt16);\r\n WriteData(SizeOf(AValue), AValue);\r\nend;\r\n\r\nprocedure TBinarySerializer.WriteUInt32(const AValue: UInt32);\r\nbegin\r\n WriteType(svUInt32);\r\n WriteData(SizeOf(AValue), AValue);\r\nend;\r\n\r\nprocedure TBinarySerializer.WriteUInt64(const AValue: UInt64);\r\nbegin\r\n WriteType(svUInt64);\r\n WriteData(SizeOf(AValue), AValue);\r\nend;\r\n\r\nprocedure TBinarySerializer.WriteUInt8(const AValue: UInt8);\r\nbegin\r\n WriteType(svUInt8);\r\n WriteData(SizeOf(AValue), AValue);\r\nend;\r\n\r\nprocedure TBinarySerializer.WriteUnicodeString(const AValue: UnicodeString);\r\nvar\r\n LLength: NativeInt;\r\n LUtf8: RawByteString;\r\nbegin\r\n LUtf8 := UTF8Encode(AValue);\r\n LLength := Length(LUtf8);\r\n\r\n WriteType(svUnicodeString);\r\n WriteData(SizeOf(LLength), LLength);\r\n WriteData(LLength, LUtf8[1]);\r\nend;\r\n\r\nprocedure TBinarySerializer.WriteWideChar(const AValue: WideChar);\r\nbegin\r\n WriteType(svWideChar);\r\n WriteData(SizeOf(AValue), AValue);\r\nend;\r\n\r\nprocedure TBinarySerializer.WriteWideString(const AValue: WideString);\r\nvar\r\n LLength: NativeInt;\r\n LUtf8: RawByteString;\r\nbegin\r\n LUtf8 := UTF8Encode(AValue);\r\n LLength := Length(LUtf8);\r\n\r\n WriteType(svWideString);\r\n WriteData(SizeOf(LLength), LLength);\r\n WriteData(LLength, LUtf8[1]);\r\nend;\r\n\r\n\r\n{ TBinaryDeserializer }\r\n\r\nfunction TBinaryDeserializer.BeginReadClass(const AClassType: TRttiInstanceType; out AType: TClass; out AId: Int32): TDeserializer.TReferenceType;\r\nbegin\r\n ASSERT(Assigned(AClassType));\r\n\r\n Result := rtInline;\r\n case Expect([svStartClass, svReferencedClass, svNilClass]) of\r\n svStartClass:\r\n begin\r\n ReadMetaClass(AType);\r\n ReadInt32(AId);\r\n end;\r\n\r\n svReferencedClass:\r\n begin\r\n ReadInt32(AId);\r\n Result := rtPointer;\r\n end;\r\n\r\n svNilClass:\r\n Result := rtNil;\r\n end;\r\nend;\r\n\r\nfunction TBinaryDeserializer.BeginReadDynamicArray(const AArrayType: TRttiDynamicArrayType;\r\n out ANumberOfElements: NativeInt; out AId: Int32): TDeserializer.TReferenceType;\r\nvar\r\n LCount: Int64;\r\nbegin\r\n ASSERT(Assigned(AArrayType));\r\n\r\n Result := rtInline;\r\n case Expect([svStartDynamicArray, svReferencedDynamicArray, svNilDynamicArray]) of\r\n svStartDynamicArray:\r\n begin\r\n ExpectType(AArrayType);\r\n ReadInt32(AId);\r\n ReadInt64(LCount);\r\n ANumberOfElements := LCount;\r\n end;\r\n\r\n svReferencedDynamicArray:\r\n begin\r\n ReadInt32(AId);\r\n Result := rtPointer;\r\n end;\r\n\r\n svNilDynamicArray:\r\n Result := rtNil;\r\n end;\r\nend;\r\n\r\nprocedure TBinaryDeserializer.BeginReadField(const ALabel: String);\r\nvar\r\n LLabel: String;\r\nbegin\r\n Expect(svStartLabel);\r\n ReadUnicodeString(LLabel);\r\n\r\n if (LLabel <> ALabel) then\r\n ExceptionHelper.Throw_ExpectedAnotherLabel(ALabel, LLabel);\r\nend;\r\n\r\nprocedure TBinaryDeserializer.BeginReadField(const AField: TRttiField);\r\nvar\r\n LName: String;\r\n LOffset: Int64;\r\nbegin\r\n ASSERT(Assigned(AField));\r\n\r\n Expect(svStartField);\r\n ExpectType(AField.FieldType);\r\n\r\n ReadUnicodeString(LName);\r\n ReadInt64(LOffset);\r\n\r\n if (LName <> AField.Name) or (LOffset <> AField.Offset) then\r\n ExceptionHelper.Throw_ExpectedAnotherField(AField, LName, LOffset);\r\nend;\r\n\r\nfunction TBinaryDeserializer.BeginReadRecord(const ARecordType: TRttiRecordType; out AId: Int32): TDeserializer.TReferenceType;\r\nbegin\r\n ASSERT(Assigned(ARecordType));\r\n\r\n Result := rtInline;\r\n case Expect([svStartRecord, svReferencedRecord, svNilRecord]) of\r\n svStartRecord:\r\n begin\r\n ExpectType(ARecordType);\r\n ReadInt32(AId);\r\n end;\r\n\r\n svReferencedRecord:\r\n begin\r\n ReadInt32(AId);\r\n Result := rtPointer;\r\n end;\r\n\r\n svNilRecord:\r\n Result := rtNil;\r\n end;\r\nend;\r\n\r\nprocedure TBinaryDeserializer.BeginReadRoot;\r\nbegin\r\n Expect(svStartRoot);\r\nend;\r\n\r\nprocedure TBinaryDeserializer.BeginReadStaticArray(const AArrayType: TRttiArrayType; const ANumberOfElements: NativeInt);\r\nvar\r\n LElements: Int64;\r\nbegin\r\n ASSERT(Assigned(AArrayType));\r\n\r\n Expect(svStartStaticArray);\r\n ExpectType(AArrayType);\r\n ReadInt64(LElements);\r\n\r\n if (ANumberOfElements <> LElements) then\r\n ExceptionHelper.Throw_ExpectedAnotherElementCount(AArrayType, ANumberOfElements, LElements);\r\nend;\r\n\r\nconstructor TBinaryDeserializer.Create(const AStream: TStream);\r\nbegin\r\n inherited Create();\r\n\r\n if not Assigned(AStream) then\r\n ExceptionHelper.Throw_ArgumentNilError('AStream');\r\n\r\n FStream := AStream;\r\nend;\r\n\r\nprocedure TBinaryDeserializer.EndReadClass;\r\nbegin\r\n Expect(svEndClass);\r\nend;\r\n\r\nprocedure TBinaryDeserializer.EndReadDynamicArray;\r\nbegin\r\n Expect(svEndDynamicArray);\r\nend;\r\n\r\nprocedure TBinaryDeserializer.EndReadField;\r\nbegin\r\n Expect(svEndField);\r\nend;\r\n\r\nprocedure TBinaryDeserializer.EndReadRecord;\r\nbegin\r\n Expect(svEndRecord);\r\nend;\r\n\r\nprocedure TBinaryDeserializer.EndReadRoot;\r\nbegin\r\n Expect(svEndRoot);\r\nend;\r\n\r\nprocedure TBinaryDeserializer.EndReadStaticArray;\r\nbegin\r\n Expect(svEndStaticArray);\r\nend;\r\n\r\nfunction TBinaryDeserializer.Expect(const AWhat: TStreamedValueTypes): TStreamedValueType;\r\nbegin\r\n FStream.ReadBuffer(Result, SizeOf(Result));\r\n\r\n if not (Result in AWhat) then\r\n ExceptionHelper.Throw_ExpectedAnotherBinaryValuePoint();\r\nend;\r\n\r\nprocedure TBinaryDeserializer.ExpectType(const AWhatType: TRttiType);\r\nvar\r\n LName: String;\r\nbegin\r\n ASSERT(Assigned(AWhatType));\r\n ReadUnicodeString(LName);\r\n\r\n if (LName <> AWhatType.Name) then\r\n ExceptionHelper.Throw_ExpectedAnotherType(AWhatType, LName);\r\nend;\r\n\r\nfunction TBinaryDeserializer.GetMetaClass(const AUnit, AClass: String): TClass;\r\nvar\r\n LType: TRttiType;\r\nbegin\r\n LType := RttiContext.FindType(AUnit + '.' + AClass);\r\n\r\n { Find out the type }\r\n if LType is TRttiInstanceType then\r\n Result := TRttiInstanceType(LType).MetaclassType\r\n else\r\n Result := nil;\r\nend;\r\n\r\n\r\nprocedure TBinaryDeserializer.Expect(const AWhat: TStreamedValueType);\r\nbegin\r\n Expect([AWhat]);\r\nend;\r\n\r\nprocedure TBinaryDeserializer.ReadAnsiChar(out AValue: AnsiChar);\r\nbegin\r\n Expect(svAnsiChar);\r\n ReadData(SizeOf(AValue), AValue);\r\nend;\r\n\r\nprocedure TBinaryDeserializer.ReadAnsiString(out AValue: AnsiString);\r\nvar\r\n LCodePage: UInt16;\r\n LLength: NativeInt;\r\nbegin\r\n Expect(svAnsiString);\r\n ReadData(SizeOf(LCodePage), LCodePage);\r\n ReadData(SizeOf(LLength), LLength);\r\n\r\n SetLength(AValue, LLength);\r\n SetCodePage(RawByteString(AValue), LCodePage);\r\n ReadData(LLength, AValue[1]);\r\nend;\r\n\r\nprocedure TBinaryDeserializer.ReadComp(out AValue: Comp);\r\nbegin\r\n Expect(svComp);\r\n ReadData(SizeOf(AValue), AValue);\r\nend;\r\n\r\nprocedure TBinaryDeserializer.ReadCurrency(out AValue: Currency);\r\nbegin\r\n Expect(svCurrency);\r\n ReadData(SizeOf(AValue), AValue);\r\nend;\r\n\r\nprocedure TBinaryDeserializer.ReadData(const ASize: NativeInt; out AData);\r\nbegin\r\n FStream.ReadBuffer(AData, ASize);\r\nend;\r\n\r\nprocedure TBinaryDeserializer.ReadDouble(out AValue: Double);\r\nbegin\r\n Expect(svDouble);\r\n ReadData(SizeOf(AValue), AValue);\r\nend;\r\n\r\nprocedure TBinaryDeserializer.ReadEnum(out AValue: Int64);\r\nbegin\r\n Expect(svEnum);\r\n ReadData(SizeOf(AValue), AValue);\r\nend;\r\n\r\nprocedure TBinaryDeserializer.ReadExtended(out AValue: Extended);\r\nbegin\r\n Expect(svExtended);\r\n ReadData(SizeOf(AValue), AValue);\r\nend;\r\n\r\nprocedure TBinaryDeserializer.ReadInt16(out AValue: Int16);\r\nbegin\r\n Expect(svInt16);\r\n ReadData(SizeOf(AValue), AValue);\r\nend;\r\n\r\nprocedure TBinaryDeserializer.ReadInt32(out AValue: Int32);\r\nbegin\r\n Expect(svInt32);\r\n ReadData(SizeOf(AValue), AValue);\r\nend;\r\n\r\nprocedure TBinaryDeserializer.ReadInt64(out AValue: Int64);\r\nbegin\r\n Expect(svInt64);\r\n ReadData(SizeOf(AValue), AValue);\r\nend;\r\n\r\nprocedure TBinaryDeserializer.ReadInt8(out AValue: Int8);\r\nbegin\r\n Expect(svInt8);\r\n ReadData(SizeOf(AValue), AValue);\r\nend;\r\n\r\nprocedure TBinaryDeserializer.ReadMetaClass(out AValue: TClass);\r\nvar\r\n LUnit, LClass: String;\r\nbegin\r\n case Expect([svMetaClass, svNilMetaClass]) of\r\n svMetaClass:\r\n begin\r\n ReadUnicodeString(LUnit);\r\n ReadUnicodeString(LClass);\r\n\r\n AValue := GetMetaClass(LUnit, LClass);\r\n end;\r\n\r\n svNilMetaClass:\r\n AValue := nil;\r\n end;\r\nend;\r\n\r\nprocedure TBinaryDeserializer.ReadSet(const ASetSize: UInt8; out AValue);\r\nvar\r\n LSize: UInt8;\r\nbegin\r\n Expect(svSet);\r\n ReadUInt8(LSize);\r\n\r\n if (LSize <> ASetSize) then\r\n ExceptionHelper.Throw_ExpectedAnotherSetSize(ASetSize, LSize);\r\n\r\n ReadData(LSize, AValue);\r\nend;\r\n\r\nprocedure TBinaryDeserializer.ReadShortString(out AValue: ShortString);\r\nvar\r\n LLength: UInt8;\r\nbegin\r\n Expect(svShortString);\r\n ReadData(SizeOf(LLength), LLength);\r\n ReadData(LLength, AValue[1]);\r\n AValue[0] := AnsiChar(LLength);\r\nend;\r\n\r\nprocedure TBinaryDeserializer.ReadSingle(out AValue: Single);\r\nbegin\r\n Expect(svSingle);\r\n ReadData(SizeOf(AValue), AValue);\r\nend;\r\n\r\nprocedure TBinaryDeserializer.ReadUInt16(out AValue: UInt16);\r\nbegin\r\n Expect(svUInt16);\r\n ReadData(SizeOf(AValue), AValue);\r\nend;\r\n\r\nprocedure TBinaryDeserializer.ReadUInt32(out AValue: UInt32);\r\nbegin\r\n Expect(svUInt32);\r\n ReadData(SizeOf(AValue), AValue);\r\nend;\r\n\r\nprocedure TBinaryDeserializer.ReadUInt64(out AValue: UInt64);\r\nbegin\r\n Expect(svUInt64);\r\n ReadData(SizeOf(AValue), AValue);\r\nend;\r\n\r\nprocedure TBinaryDeserializer.ReadUInt8(out AValue: UInt8);\r\nbegin\r\n Expect(svUInt8);\r\n ReadData(SizeOf(AValue), AValue);\r\nend;\r\n\r\nprocedure TBinaryDeserializer.ReadUnicodeString(out AValue: UnicodeString);\r\nvar\r\n LLength: NativeInt;\r\n Utf8: RawByteString;\r\nbegin\r\n Expect(svUnicodeString);\r\n ReadData(SizeOf(LLength), LLength);\r\n\r\n SetLength(Utf8, LLength);\r\n ReadData(LLength, Utf8[1]);\r\n\r\n AValue := UTF8ToUnicodeString(Utf8);\r\nend;\r\n\r\nprocedure TBinaryDeserializer.ReadWideChar(out AValue: WideChar);\r\nbegin\r\n Expect(svWideChar);\r\n ReadData(SizeOf(AValue), AValue);\r\nend;\r\n\r\nprocedure TBinaryDeserializer.ReadWideString(out AValue: WideString);\r\nvar\r\n LLength: NativeInt;\r\n Utf8: RawByteString;\r\nbegin\r\n Expect(svWideString);\r\n ReadData(SizeOf(LLength), LLength);\r\n\r\n SetLength(Utf8, LLength);\r\n ReadData(LLength, Utf8[1]);\r\n\r\n AValue := UTF8ToWideString(Utf8);\r\nend;\r\n\r\n{$ENDREGION}\r\n\r\n{ TSerializer }\r\n\r\nclass function TSerializer.Default(const AStream: TStream): TSerializer;\r\nbegin\r\n Result := TBinarySerializer.Create(AStream);\r\nend;\r\n\r\nconstructor TSerializer.Create;\r\nbegin\r\n FDynArrayReg := TDictionary.Create();\r\n FObjectReg := TDictionary.Create();\r\n FRecordReg := TDictionary.Create();\r\n\r\n FSkipErrors := true;\r\nend;\r\n\r\ndestructor TSerializer.Destroy;\r\nbegin\r\n FRecordReg.Free;\r\n FDynArrayReg.Free;\r\n FObjectReg.Free;\r\n\r\n inherited;\r\nend;\r\n\r\nprocedure TSerializer.ErrorNoFieldRtti(const AField: TRttiField);\r\nbegin\r\n if not FSkipErrors then\r\n ExceptionHelper.Throw_FieldTypeDoesNotHaveEnoughRtti(AField);\r\nend;\r\n\r\nprocedure TSerializer.ErrorNotEnoughRtti(const ATypeInfo: PTypeInfo);\r\nbegin\r\n if not FSkipErrors then\r\n ExceptionHelper.Throw_TypeDoesNotHaveEnoughRtti(ATypeInfo);\r\nend;\r\n\r\nprocedure TSerializer.ErrorNotSupported(const ATypeInfo: PTypeInfo);\r\nbegin\r\n if not FSkipErrors then\r\n ExceptionHelper.Throw_TypeCannotBeSerialized(ATypeInfo);\r\nend;\r\n\r\nprocedure TSerializer.Serialize(const ATypeInfo: PTypeInfo; const AValue);\r\nbegin\r\n if not Assigned(ATypeInfo) then\r\n ExceptionHelper.Throw_ArgumentNilError('ATypeInfo');\r\n\r\n { Call internal \"un-checked\" method. }\r\n BeginWriteRoot();\r\n SerializeInternal(FRttiContext.GetType(ATypeInfo), @AValue);\r\n EndWriteRoot();\r\nend;\r\n\r\nprocedure TSerializer.Serialize(const AObject: TObject);\r\nbegin\r\n if Assigned(AObject) then\r\n Serialize(AObject.ClassInfo, AObject)\r\n else\r\n Serialize(TypeInfo(TObject), AObject);\r\nend;\r\n\r\nprocedure TSerializer.Serialize(const AValue: T);\r\nbegin\r\n Serialize(TypeInfo(T), AValue);\r\nend;\r\n\r\nprocedure TSerializer.WriteClass(const ATypeInfo: PTypeInfo; const AObject: TObject);\r\nvar\r\n LClass: TRttiInstanceType;\r\n LField: TRttiField;\r\n LClassId: Int32;\r\n LSerializable: ISerializable;\r\nbegin\r\n { ARefToRecord points to the first field in the record }\r\n ASSERT(ATypeInfo^.Kind = tkClass);\r\n\r\n { Get the class info }\r\n LClass := nil;\r\n if Assigned(AObject) then\r\n LClass := FRttiContext.GetType(AObject.ClassType) as TRttiInstanceType;\r\n if not Assigned(LClass) then\r\n LClass := FRttiContext.GetType(ATypeInfo) as TRttiInstanceType;\r\n\r\n if not Assigned(LClass) then\r\n begin\r\n ErrorNotEnoughRtti(ATypeInfo);\r\n Exit;\r\n end;\r\n\r\n { Check if the object is already serialized }\r\n if not Assigned(AObject) then\r\n WriteNilClassReference()\r\n else if FObjectReg.TryGetValue(AObject, LClassId) then\r\n WriteClassReference(LClassId)\r\n else begin\r\n { Register object in the dictionary }\r\n Inc(FLastId);\r\n FObjectReg.Add(AObject, FLastId);\r\n\r\n { Notify that a class is being written }\r\n BeginWriteClass(LClass, AObject.ClassType, FLastId);\r\n\r\n { Check if the class has it's own serialization code }\r\n GetSafeInterface(AObject, ISerializable, Pointer(LSerializable));\r\n if Assigned(LSerializable) then\r\n begin\r\n LSerializable.Serialize(TOutputContext.Create(Self));\r\n Pointer(LSerializable) := nil;\r\n end else begin\r\n { Walk through the record }\r\n for LField in LClass.GetFields() do\r\n begin\r\n if not Assigned(LField.FieldType) then\r\n begin\r\n ErrorNoFieldRtti(LField);\r\n continue;\r\n end;\r\n\r\n if IsSerializable(LField) then\r\n begin\r\n BeginWriteField(LField);\r\n SerializeInternal(LField.FieldType, Pointer(LField.Offset + NativeInt(AObject)));\r\n EndWriteField();\r\n end;\r\n end;\r\n end;\r\n\r\n EndWriteClass();\r\n end;\r\nend;\r\n\r\nprocedure TSerializer.WriteDynamicArray(const ATypeInfo: PTypeInfo; const ADynArray: Pointer);\r\nvar\r\n LArray: TRttiDynamicArrayType;\r\n LIndex, LCount: NativeInt;\r\n LArrayId: Int32;\r\nbegin\r\n { ARefToRecord points to the first field in the record }\r\n ASSERT(ATypeInfo^.Kind = tkDynArray);\r\n LArray := FRttiContext.GetType(ATypeInfo) as TRttiDynamicArrayType;\r\n\r\n if (not Assigned(LArray)) or (not Assigned(LArray.ElementType))then\r\n begin\r\n ErrorNotEnoughRtti(ATypeInfo);\r\n Exit;\r\n end;\r\n\r\n { Check if the array is already serialized }\r\n if not Assigned(ADynArray) then\r\n WriteNilDynamicArrayReference()\r\n else if FDynArrayReg.TryGetValue(ADynArray, LArrayId) then\r\n WriteDynamicArrayReference(LArrayId)\r\n else begin\r\n { Register array in the dictionary }\r\n Inc(FLastId);\r\n FDynArrayReg.Add(ADynArray, LArrayId);\r\n\r\n { Obtain the count of elements }\r\n LCount := DynArraySize(ADynArray);\r\n\r\n { Notify that a class is being written }\r\n BeginWriteDynamicArray(LArray, LCount, FLastId);\r\n\r\n { Walk through the array }\r\n for LIndex := 0 to LCount - 1 do\r\n SerializeInternal(LArray.ElementType, Pointer(LIndex * LArray.ElementType.TypeSize + NativeInt(ADynArray)));\r\n\r\n EndWriteDynamicArray();\r\n end;\r\nend;\r\n\r\nprocedure TSerializer.WriteRecord(const ATypeInfo: PTypeInfo; const ARefToRecord: Pointer);\r\nvar\r\n LRecord: TRttiRecordType;\r\n LField: TRttiField;\r\n LRecordId: Int32;\r\nbegin\r\n { ARefToRecord points to the first field in the record }\r\n ASSERT(ATypeInfo^.Kind = tkRecord);\r\n LRecord := FRttiContext.GetType(ATypeInfo) as TRttiRecordType;\r\n\r\n if not Assigned(LRecord) then\r\n begin\r\n ErrorNotEnoughRtti(ATypeInfo);\r\n Exit;\r\n end;\r\n\r\n { Check if the object is already serialized }\r\n if not Assigned(ARefToRecord) then\r\n WriteNilRecordReference()\r\n else if FRecordReg.TryGetValue(ARefToRecord, LRecordId) then\r\n WriteRecordReference(LRecordId)\r\n else begin\r\n { Register object in the dictionary }\r\n Inc(FLastId);\r\n FRecordReg.Add(ARefToRecord, FLastId);\r\n\r\n { Notify that a class is being written }\r\n BeginWriteRecord(LRecord, FLastId);\r\n\r\n { Walk through the record }\r\n for LField in LRecord.GetFields() do\r\n begin\r\n if not Assigned(LField.FieldType) then\r\n begin\r\n ErrorNoFieldRtti(LField);\r\n continue;\r\n end;\r\n\r\n if IsSerializable(LField) then\r\n begin\r\n BeginWriteField(LField);\r\n SerializeInternal(LField.FieldType, Pointer(LField.Offset + NativeInt(ARefToRecord)));\r\n EndWriteField();\r\n end;\r\n end;\r\n\r\n EndWriteRecord();\r\n end;\r\nend;\r\n\r\nprocedure TSerializer.SerializeInternal(const AType: TRttiType; const AValueRef: Pointer);\r\nvar\r\n LTypeData: PTypeData;\r\n LSetOrd: Int64;\r\nbegin\r\n LTypeData := GetTypeData(AType.Handle);\r\n\r\n case AType.TypeKind of\r\n tkProcedure,\r\n tkUnknown,\r\n tkMethod,\r\n tkVariant,\r\n tkInterface:\r\n if not FSkipErrors then\r\n ErrorNotSupported(AType.Handle);\r\n\r\n tkEnumeration:\r\n begin\r\n LSetOrd := 0;\r\n case AType.TypeSize of\r\n 1: LSetOrd := PInt8(AValueRef)^;\r\n 2: LSetOrd := PInt16(AValueRef)^;\r\n 4: LSetOrd := PInt32(AValueRef)^;\r\n 8: LSetOrd := PInt64(AValueRef)^;\r\n else\r\n ASSERT(False);\r\n end;\r\n\r\n WriteEnum(LSetOrd);\r\n end;\r\n\r\n tkSet:\r\n WriteSet(AType.TypeSize, AValueRef^);\r\n\r\n tkInteger:\r\n begin\r\n if Assigned(LTypeData) then\r\n begin\r\n case LTypeData^.OrdType of\r\n otSByte:\r\n WriteInt8(PInt8(AValueRef)^);\r\n otUByte:\r\n WriteUInt8(PUInt8(AValueRef)^);\r\n otSWord:\r\n WriteInt16(PInt16(AValueRef)^);\r\n otUWord:\r\n WriteUInt16(PUInt16(AValueRef)^);\r\n otSLong:\r\n WriteInt32(PInt32(AValueRef)^);\r\n otULong:\r\n WriteUInt32(PUInt32(AValueRef)^);\r\n end;\r\n end else\r\n ErrorNotEnoughRtti(AType.Handle);\r\n end;\r\n\r\n tkInt64:\r\n begin\r\n if Assigned(LTypeData) then\r\n begin\r\n if LTypeData^.MaxInt64Value > LTypeData^.MinInt64Value then\r\n WriteInt64(PInt64(AValueRef)^)\r\n else\r\n WriteUInt64(PUInt64(AValueRef)^);\r\n end else\r\n ErrorNotEnoughRtti(AType.Handle);\r\n end;\r\n\r\n tkChar:\r\n WriteAnsiChar(PAnsiChar(AValueRef)^);\r\n\r\n tkWChar:\r\n WriteWideChar(PWideChar(AValueRef)^);\r\n\r\n tkFloat:\r\n begin\r\n if Assigned(LTypeData) then\r\n begin\r\n case LTypeData^.FloatType of\r\n ftSingle:\r\n WriteSingle(PSingle(AValueRef)^);\r\n ftDouble:\r\n WriteDouble(PDouble(AValueRef)^);\r\n ftExtended:\r\n WriteExtended(PExtended(AValueRef)^);\r\n ftComp:\r\n WriteComp(PComp(AValueRef)^);\r\n ftCurr:\r\n WriteCurrency(PCurrency(AValueRef)^);\r\n end;\r\n end else\r\n ErrorNotEnoughRtti(AType.Handle);\r\n end;\r\n\r\n tkString:\r\n WriteShortString(PShortString(AValueRef)^);\r\n tkLString:\r\n WriteAnsiString(PAnsiString(AValueRef)^);\r\n tkWString:\r\n WriteWideString(PWideString(AValueRef)^);\r\n tkUString:\r\n WriteUnicodeString(PUnicodeString(AValueRef)^);\r\n tkClassRef:\r\n WriteMetaClass(PPointer(AValueRef)^);\r\n tkRecord:\r\n WriteRecord(AType.Handle, AValueRef);\r\n tkClass:\r\n WriteClass(AType.Handle, PPointer(AValueRef)^);\r\n tkArray:\r\n WriteStaticArray(AType.Handle, AValueRef);\r\n tkDynArray:\r\n WriteDynamicArray(AType.Handle, PPointer(AValueRef)^);\r\n tkPointer:\r\n begin\r\n { Check if this is apointer to a record }\r\n if Assigned(LTypeData^.RefType) and Assigned(LTypeData^.RefType^) and (LTypeData^.RefType^^.Kind = tkRecord) then\r\n WriteRecord(LTypeData^.RefType^, PPointer(AValueRef)^)\r\n else\r\n ErrorNotSupported(AType.Handle);\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TSerializer.WriteStaticArray(const ATypeInfo: PTypeInfo; const ARefToFirstElement: Pointer);\r\nvar\r\n LArray: TRttiArrayType;\r\n LIndex: NativeInt;\r\nbegin\r\n { ARefToRecord points to the first field in the record }\r\n ASSERT(ATypeInfo^.Kind = tkArray);\r\n LArray := FRttiContext.GetType(ATypeInfo) as TRttiArrayType;\r\n\r\n if (not Assigned(LArray)) or (not Assigned(LArray.ElementType)) then\r\n begin\r\n ErrorNotEnoughRtti(ATypeInfo);\r\n Exit;\r\n end;\r\n\r\n { Notify that a record is being written }\r\n BeginWriteStaticArray(LArray, LArray.TotalElementCount);\r\n\r\n { Walk through the record }\r\n for LIndex := 0 to LArray.TotalElementCount - 1 do\r\n SerializeInternal(LArray.ElementType, Pointer(LIndex * LArray.ElementType.TypeSize + NativeInt(ARefToFirstElement)));\r\n\r\n EndWriteStaticArray();\r\nend;\r\n\r\n{ TDeserializer }\r\n\r\nclass function TDeserializer.Default(const AStream: TStream): TDeserializer;\r\nbegin\r\n Result := TBinaryDeserializer.Create(AStream);\r\nend;\r\n\r\nconstructor TDeserializer.Create;\r\nbegin\r\n FDynArrayReg := TDictionary.Create();\r\n FObjectReg := TDictionary.Create();\r\n FRecordReg := TDictionary.Create();\r\n\r\n FSkipErrors := true;\r\nend;\r\n\r\nfunction TDeserializer.CreateInstance(const AClassType: TRttiInstanceType): TObject;\r\nvar\r\n LMethod: TRttiMethod;\r\nbegin\r\n if Assigned(AClassType) then\r\n begin\r\n { Invoke the first parameterless constructor found. }\r\n for LMethod in AClassType.GetMethods() do\r\n if LMethod.HasExtendedInfo and LMethod.IsConstructor then\r\n if LMethod.GetParameters() = nil then\r\n Exit(LMethod.Invoke(AClassType.MetaclassType, []).AsObject);\r\n\r\n { Not found ... Use the old fashioned way }\r\n Result := AClassType.MetaclassType.Create();\r\n end else\r\n Result := nil;\r\nend;\r\n\r\nprocedure TDeserializer.Deserialize(const ATypeInfo: PTypeInfo; out AValue);\r\nbegin\r\n if not Assigned(ATypeInfo) then\r\n ExceptionHelper.Throw_ArgumentNilError('ATypeInfo');\r\n\r\n { Call internal \"un-checked\" method. }\r\n BeginReadRoot();\r\n DeserializeInternal(FRttiContext.GetType(ATypeInfo), @AValue);\r\n EndReadRoot();\r\nend;\r\n\r\nfunction TDeserializer.Deserialize: T;\r\nbegin\r\n Deserialize(TypeInfo(T), Result);\r\nend;\r\n\r\nfunction TDeserializer.Deserialize: TObject;\r\nbegin\r\n Deserialize(TypeInfo(TObject), Result);\r\nend;\r\n\r\ndestructor TDeserializer.Destroy;\r\nbegin\r\n FDynArrayReg.Free;\r\n FObjectReg.Free;\r\n FRecordReg.Free;\r\n\r\n inherited;\r\nend;\r\n\r\nprocedure TDeserializer.ErrorNoFieldRtti(const AField: TRttiField);\r\nbegin\r\n if not FSkipErrors then\r\n ExceptionHelper.Throw_FieldTypeDoesNotHaveEnoughRtti(AField);\r\nend;\r\n\r\nprocedure TDeserializer.ErrorNotEnoughRtti(const ATypeInfo: PTypeInfo);\r\nbegin\r\n if not FSkipErrors then\r\n ExceptionHelper.Throw_TypeDoesNotHaveEnoughRtti(ATypeInfo);\r\nend;\r\n\r\nprocedure TDeserializer.ErrorNotSupported(const ATypeInfo: PTypeInfo);\r\nbegin\r\n if not FSkipErrors then\r\n ExceptionHelper.Throw_TypeCannotBeSerialized(ATypeInfo);\r\nend;\r\n\r\nprocedure TDeserializer.ReadClass(const ATypeInfo: PTypeInfo; out AObject: TObject);\r\nvar\r\n LClass: TRttiInstanceType;\r\n LField: TRttiField;\r\n LClassId: Int32;\r\n LClassType: TClass;\r\n LSerializable: ISerializable;\r\nbegin\r\n { ARefToRecord points to the first field in the record }\r\n ASSERT(ATypeInfo^.Kind = tkClass);\r\n LClass := FRttiContext.GetType(ATypeInfo) as TRttiInstanceType;\r\n\r\n if not Assigned(LClass) then\r\n begin\r\n ErrorNotEnoughRtti(ATypeInfo);\r\n Exit;\r\n end;\r\n\r\n case BeginReadClass(LClass, LClassType, LClassId) of\r\n rtInline:\r\n begin\r\n if Assigned(LClassType) then\r\n LClass := FRttiContext.GetType(LClassType.ClassInfo) as TRttiInstanceType;\r\n\r\n if not Assigned(LClass) then\r\n LClass := FRttiContext.GetType(ATypeInfo) as TRttiInstanceType;\r\n\r\n AObject := CreateInstance(LClass);\r\n FObjectReg.AddOrSetValue(LClassId, Pointer(AObject));\r\n try\r\n GetSafeInterface(AObject, ISerializable, Pointer(LSerializable));\r\n if Assigned(LSerializable) then\r\n begin\r\n LSerializable.Deserialize(TInputContext.Create(Self));\r\n Pointer(LSerializable) := nil;\r\n end else begin\r\n { Walk through the class }\r\n for LField in LClass.GetFields() do\r\n begin\r\n if not Assigned(LField.FieldType) then\r\n begin\r\n ErrorNoFieldRtti(LField);\r\n continue;\r\n end;\r\n\r\n if IsSerializable(LField) then\r\n begin\r\n BeginReadField(LField);\r\n DeserializeInternal(LField.FieldType, Pointer(LField.Offset + NativeInt(AObject)));\r\n EndReadField();\r\n end;\r\n end;\r\n end;\r\n\r\n EndReadClass();\r\n except\r\n AObject.Free;\r\n AObject := nil;\r\n end;\r\n end;\r\n\r\n rtPointer:\r\n begin\r\n if not FObjectReg.TryGetValue(LClassId, Pointer(AObject)) then\r\n ExceptionHelper.Throw_BadClassReference(ATypeInfo);\r\n end;\r\n\r\n rtNil:\r\n AObject := nil;\r\n end;\r\n\r\n\r\nend;\r\n\r\nprocedure TDeserializer.ReadDynamicArray(const ATypeInfo: PTypeInfo; out ADynArray: Pointer);\r\nvar\r\n LArray: TRttiDynamicArrayType;\r\n LIndex, LCount: NativeInt;\r\n LArrayId: Int32;\r\n LOutPtr: Pointer;\r\n LDim: NativeInt;\r\nbegin\r\n { ARefToRecord points to the first field in the record }\r\n ASSERT(ATypeInfo^.Kind = tkDynArray);\r\n LArray := FRttiContext.GetType(ATypeInfo) as TRttiDynamicArrayType;\r\n\r\n if (not Assigned(LArray)) or (not Assigned(LArray.ElementType))then\r\n begin\r\n ErrorNotEnoughRtti(ATypeInfo);\r\n Exit;\r\n end;\r\n\r\n DynArrayClear(ADynArray, ATypeInfo);\r\n case BeginReadDynamicArray(LArray, LCount, LArrayId) of\r\n rtInline:\r\n begin\r\n LDim := LCount;\r\n DynArraySetLength(ADynArray, ATypeInfo, 1, @LDim);\r\n FDynArrayReg.AddOrSetValue(LArrayId, ADynArray);\r\n\r\n { Walk through the array }\r\n for LIndex := 0 to LCount - 1 do\r\n DeserializeInternal(LArray.ElementType, Pointer(LIndex * LArray.ElementType.TypeSize + NativeInt(ADynArray)));\r\n\r\n EndReadDynamicArray();\r\n end;\r\n\r\n rtPointer:\r\n begin\r\n if not FDynArrayReg.TryGetValue(LArrayId, LOutPtr) then\r\n ExceptionHelper.Throw_BadDynamicArrayReference(ATypeInfo)\r\n else\r\n TBytes(ADynArray) := TBytes(LOutPtr);\r\n end;\r\n\r\n rtNil:\r\n ADynArray := nil;\r\n end;\r\nend;\r\n\r\nprocedure TDeserializer.ReadRecord(const ATypeInfo: PTypeInfo; var ARefToRecord: Pointer);\r\nvar\r\n LRecord: TRttiRecordType;\r\n LField: TRttiField;\r\n LRecordId: Int32;\r\n LHasAddr: Boolean;\r\nbegin\r\n { ARefToRecord points to the first field in the record }\r\n ASSERT(ATypeInfo^.Kind = tkRecord);\r\n LRecord := FRttiContext.GetType(ATypeInfo) as TRttiRecordType;\r\n\r\n if not Assigned(LRecord) then\r\n begin\r\n ErrorNotEnoughRtti(ATypeInfo);\r\n Exit;\r\n end;\r\n\r\n LHasAddr := Assigned(ARefToRecord);\r\n\r\n case BeginReadRecord(LRecord, LRecordId) of\r\n rtInline:\r\n begin\r\n if not LHasAddr then\r\n begin\r\n { Allocate enough memory for the value and initialize it }\r\n GetMem(ARefToRecord, LRecord.TypeSize);\r\n InitializeArray(ARefToRecord, LRecord.Handle, 1);\r\n end;\r\n\r\n FRecordReg.AddOrSetValue(LRecordId, ARefToRecord);\r\n\r\n try\r\n { Walk through the record }\r\n for LField in LRecord.GetFields() do\r\n begin\r\n if not Assigned(LField.FieldType) then\r\n begin\r\n ErrorNoFieldRtti(LField);\r\n continue;\r\n end;\r\n\r\n if IsSerializable(LField) then\r\n begin\r\n BeginReadField(LField);\r\n DeserializeInternal(LField.FieldType, Pointer(LField.Offset + NativeInt(ARefToRecord)));\r\n EndReadField();\r\n end;\r\n end;\r\n\r\n EndReadRecord();\r\n except\r\n if not LHasAddr then\r\n begin\r\n FinalizeArray(ARefToRecord, LRecord.Handle, 1);\r\n FreeMem(ARefToRecord);\r\n\r\n ARefToRecord := nil;\r\n end;\r\n end;\r\n end;\r\n\r\n rtPointer:\r\n begin\r\n if not FRecordReg.TryGetValue(LRecordId, ARefToRecord) then\r\n ExceptionHelper.Throw_BadRecordReference(ATypeInfo);\r\n end;\r\n\r\n rtNil:\r\n ARefToRecord := nil;\r\n end;\r\n\r\n\r\nend;\r\n\r\nprocedure TDeserializer.ReadStaticArray(const ATypeInfo: PTypeInfo; const ARefToFirstElement: Pointer);\r\nvar\r\n LArray: TRttiArrayType;\r\n LIndex: NativeInt;\r\nbegin\r\n { ARefToRecord points to the first field in the record }\r\n ASSERT(ATypeInfo^.Kind = tkArray);\r\n LArray := FRttiContext.GetType(ATypeInfo) as TRttiArrayType;\r\n\r\n if (not Assigned(LArray)) or (not Assigned(LArray.ElementType)) then\r\n begin\r\n ErrorNotEnoughRtti(ATypeInfo);\r\n Exit;\r\n end;\r\n\r\n { Notify that a record is being written }\r\n BeginReadStaticArray(LArray, LArray.TotalElementCount);\r\n\r\n { Walk through the record }\r\n for LIndex := 0 to LArray.TotalElementCount - 1 do\r\n DeserializeInternal(LArray.ElementType, Pointer(LIndex * LArray.ElementType.TypeSize + NativeInt(ARefToFirstElement)));\r\n\r\n EndReadStaticArray();\r\nend;\r\n\r\nprocedure TDeserializer.DeserializeInternal(const AType: TRttiType; const AValueRef: Pointer);\r\nvar\r\n LTypeData: PTypeData;\r\n LRecordRef: Pointer;\r\n LSetOrd: Int64;\r\nbegin\r\n LTypeData := GetTypeData(AType.Handle);\r\n\r\n case AType.TypeKind of\r\n tkProcedure,\r\n tkUnknown,\r\n tkMethod,\r\n tkVariant,\r\n tkInterface:\r\n if not FSkipErrors then\r\n ErrorNotSupported(AType.Handle);\r\n\r\n tkEnumeration:\r\n begin\r\n ReadEnum(LSetOrd);\r\n case AType.TypeSize of\r\n 1: PInt8(AValueRef)^ := LSetOrd;\r\n 2: PInt16(AValueRef)^ := LSetOrd;\r\n 4: PInt32(AValueRef)^ := LSetOrd;\r\n 8: PInt64(AValueRef)^ := LSetOrd;\r\n else\r\n ASSERT(False);\r\n end;\r\n end;\r\n\r\n tkSet:\r\n ReadSet(AType.TypeSize, AValueRef^);\r\n\r\n tkInteger:\r\n begin\r\n if Assigned(LTypeData) then\r\n begin\r\n case LTypeData^.OrdType of\r\n otSByte:\r\n ReadInt8(PInt8(AValueRef)^);\r\n otUByte:\r\n ReadUInt8(PUInt8(AValueRef)^);\r\n otSWord:\r\n ReadInt16(PInt16(AValueRef)^);\r\n otUWord:\r\n ReadUInt16(PUInt16(AValueRef)^);\r\n otSLong:\r\n ReadInt32(PInt32(AValueRef)^);\r\n otULong:\r\n ReadUInt32(PUInt32(AValueRef)^);\r\n end;\r\n end else\r\n ErrorNotEnoughRtti(AType.Handle);\r\n end;\r\n\r\n tkInt64:\r\n begin\r\n if Assigned(LTypeData) then\r\n begin\r\n if LTypeData^.MaxInt64Value > LTypeData^.MinInt64Value then\r\n ReadInt64(PInt64(AValueRef)^)\r\n else\r\n ReadUInt64(PUInt64(AValueRef)^);\r\n end else\r\n ErrorNotEnoughRtti(AType.Handle);\r\n end;\r\n\r\n tkChar:\r\n ReadAnsiChar(PAnsiChar(AValueRef)^);\r\n\r\n tkWChar:\r\n ReadWideChar(PWideChar(AValueRef)^);\r\n\r\n tkFloat:\r\n begin\r\n if Assigned(LTypeData) then\r\n begin\r\n case LTypeData^.FloatType of\r\n ftSingle:\r\n ReadSingle(PSingle(AValueRef)^);\r\n ftDouble:\r\n ReadDouble(PDouble(AValueRef)^);\r\n ftExtended:\r\n ReadExtended(PExtended(AValueRef)^);\r\n ftComp:\r\n ReadComp(PComp(AValueRef)^);\r\n ftCurr:\r\n ReadCurrency(PCurrency(AValueRef)^);\r\n end;\r\n end else\r\n ErrorNotEnoughRtti(AType.Handle);\r\n end;\r\n\r\n tkString:\r\n ReadShortString(PShortString(AValueRef)^);\r\n tkLString:\r\n ReadAnsiString(PAnsiString(AValueRef)^);\r\n tkWString:\r\n ReadWideString(PWideString(AValueRef)^);\r\n tkUString:\r\n ReadUnicodeString(PUnicodeString(AValueRef)^);\r\n tkClassRef:\r\n ReadMetaClass(PClass(AValueRef)^);\r\n tkRecord:\r\n begin\r\n LRecordRef := AValueRef;\r\n ReadRecord(AType.Handle, LRecordRef);\r\n end;\r\n tkClass:\r\n ReadClass(AType.Handle, PObject(AValueRef)^);\r\n tkArray:\r\n ReadStaticArray(AType.Handle, AValueRef);\r\n tkDynArray:\r\n ReadDynamicArray(AType.Handle, PPointer(AValueRef)^);\r\n tkPointer:\r\n begin\r\n PPointer(AValueRef)^ := nil;\r\n { Check if this is apointer to a record }\r\n if Assigned(LTypeData^.RefType) and Assigned(LTypeData^.RefType^) and (LTypeData^.RefType^^.Kind = tkRecord) then\r\n ReadRecord(LTypeData^.RefType^, PPointer(AValueRef)^)\r\n else\r\n ErrorNotSupported(AType.Handle);\r\n end;\r\n end;\r\nend;\r\n\r\n{ TOutputContext }\r\n\r\nfunction TOutputContext.AddValue(const AName: String; const AValue: Int64): TOutputContext;\r\nbegin\r\n { Write data }\r\n FSerializer.BeginWriteField(AName);\r\n FSerializer.WriteInt64(AValue);\r\n FSerializer.EndWriteField();\r\n\r\n { Return self for chaining }\r\n Result := Self;\r\nend;\r\n\r\nfunction TOutputContext.AddValue(const AName: String; const AValue: UInt32): TOutputContext;\r\nbegin\r\n { Write data }\r\n FSerializer.BeginWriteField(AName);\r\n FSerializer.WriteUInt32(AValue);\r\n FSerializer.EndWriteField();\r\n\r\n { Return self for chaining }\r\n Result := Self;\r\nend;\r\n\r\nfunction TOutputContext.AddValue(const AName: String; const AValue: UInt64): TOutputContext;\r\nbegin\r\n { Write data }\r\n FSerializer.BeginWriteField(AName);\r\n FSerializer.WriteUInt64(AValue);\r\n FSerializer.EndWriteField();\r\n\r\n { Return self for chaining }\r\n Result := Self;\r\nend;\r\n\r\nfunction TOutputContext.AddValue(const AName: String; const AValue: WideChar): TOutputContext;\r\nbegin\r\n { Write data }\r\n FSerializer.BeginWriteField(AName);\r\n FSerializer.WriteWideChar(AValue);\r\n FSerializer.EndWriteField();\r\n\r\n { Return self for chaining }\r\n Result := Self;\r\nend;\r\n\r\nfunction TOutputContext.AddValue(const AName: String; const AValue: AnsiChar): TOutputContext;\r\nbegin\r\n { Write data }\r\n FSerializer.BeginWriteField(AName);\r\n FSerializer.WriteAnsiChar(AValue);\r\n FSerializer.EndWriteField();\r\n\r\n { Return self for chaining }\r\n Result := Self;\r\nend;\r\n\r\nfunction TOutputContext.AddValue(const AName: String; const AValue: UInt8): TOutputContext;\r\nbegin\r\n { Write data }\r\n FSerializer.BeginWriteField(AName);\r\n FSerializer.WriteUInt8(AValue);\r\n FSerializer.EndWriteField();\r\n\r\n { Return self for chaining }\r\n Result := Self;\r\nend;\r\n\r\nfunction TOutputContext.AddValue(const AName: String; const AValue: Int8): TOutputContext;\r\nbegin\r\n { Write data }\r\n FSerializer.BeginWriteField(AName);\r\n FSerializer.WriteInt8(AValue);\r\n FSerializer.EndWriteField();\r\n\r\n { Return self for chaining }\r\n Result := Self;\r\nend;\r\n\r\nfunction TOutputContext.AddValue(const AName: String; const AValue: Int16): TOutputContext;\r\nbegin\r\n { Write data }\r\n FSerializer.BeginWriteField(AName);\r\n FSerializer.WriteInt16(AValue);\r\n FSerializer.EndWriteField();\r\n\r\n { Return self for chaining }\r\n Result := Self;\r\nend;\r\n\r\nfunction TOutputContext.AddValue(const AName: String; const AValue: Int32): TOutputContext;\r\nbegin\r\n { Write data }\r\n FSerializer.BeginWriteField(AName);\r\n FSerializer.WriteInt32(AValue);\r\n FSerializer.EndWriteField();\r\n\r\n { Return self for chaining }\r\n Result := Self;\r\nend;\r\n\r\nfunction TOutputContext.AddValue(const AName: String; const AValue: UInt16): TOutputContext;\r\nbegin\r\n { Write data }\r\n FSerializer.BeginWriteField(AName);\r\n FSerializer.WriteUInt16(AValue);\r\n FSerializer.EndWriteField();\r\n\r\n { Return self for chaining }\r\n Result := Self;\r\nend;\r\n\r\nfunction TOutputContext.AddValue(const AName: String; const AValue: WideString): TOutputContext;\r\nbegin\r\n { Write data }\r\n FSerializer.BeginWriteField(AName);\r\n FSerializer.WriteWideString(AValue);\r\n FSerializer.EndWriteField();\r\n\r\n { Return self for chaining }\r\n Result := Self;\r\nend;\r\n\r\nfunction TOutputContext.AddValue(const AName: String; const AValue: AnsiString): TOutputContext;\r\nbegin\r\n { Write data }\r\n FSerializer.BeginWriteField(AName);\r\n FSerializer.WriteAnsiString(AValue);\r\n FSerializer.EndWriteField();\r\n\r\n { Return self for chaining }\r\n Result := Self;\r\nend;\r\n\r\nfunction TOutputContext.AddValue(const AName: String; const AValue: UnicodeString): TOutputContext;\r\nbegin\r\n { Write data }\r\n FSerializer.BeginWriteField(AName);\r\n FSerializer.WriteUnicodeString(AValue);\r\n FSerializer.EndWriteField();\r\n\r\n { Return self for chaining }\r\n Result := Self;\r\nend;\r\n\r\nfunction TOutputContext.AddValue(const AName: String; const AValue: TObject): TOutputContext;\r\nbegin\r\n { Write data }\r\n FSerializer.BeginWriteField(AName);\r\n FSerializer.WriteClass(TypeInfo(TObject), AValue);\r\n FSerializer.EndWriteField();\r\n\r\n { Return self for chaining }\r\n Result := Self;\r\nend;\r\n\r\nfunction TOutputContext.AddValue(const AName: String; const AValue: TClass): TOutputContext;\r\nbegin\r\n { Write data }\r\n FSerializer.BeginWriteField(AName);\r\n FSerializer.WriteMetaClass(AValue);\r\n FSerializer.EndWriteField();\r\n\r\n { Return self for chaining }\r\n Result := Self;\r\nend;\r\n\r\nfunction TOutputContext.AddValue(const AName: String; const AValue: ShortString): TOutputContext;\r\nbegin\r\n { Write data }\r\n FSerializer.BeginWriteField(AName);\r\n FSerializer.WriteShortString(AValue);\r\n FSerializer.EndWriteField();\r\n\r\n { Return self for chaining }\r\n Result := Self;\r\nend;\r\n\r\nfunction TOutputContext.AddValue(const AName: String; const AValue: Double): TOutputContext;\r\nbegin\r\n { Write data }\r\n FSerializer.BeginWriteField(AName);\r\n FSerializer.WriteDouble(AValue);\r\n FSerializer.EndWriteField();\r\n\r\n { Return self for chaining }\r\n Result := Self;\r\nend;\r\n\r\nfunction TOutputContext.AddValue(const AName: String; const AValue: Single): TOutputContext;\r\nbegin\r\n { Write data }\r\n FSerializer.BeginWriteField(AName);\r\n FSerializer.WriteSingle(AValue);\r\n FSerializer.EndWriteField();\r\n\r\n { Return self for chaining }\r\n Result := Self;\r\nend;\r\n\r\nfunction TOutputContext.AddValue(const AName: String; const AValue: Extended): TOutputContext;\r\nbegin\r\n { Write data }\r\n FSerializer.BeginWriteField(AName);\r\n FSerializer.WriteExtended(AValue);\r\n FSerializer.EndWriteField();\r\n\r\n { Return self for chaining }\r\n Result := Self;\r\nend;\r\n\r\nfunction TOutputContext.AddValue(const AName: String; const AValue: Currency): TOutputContext;\r\nbegin\r\n { Write data }\r\n FSerializer.BeginWriteField(AName);\r\n FSerializer.WriteCurrency(AValue);\r\n FSerializer.EndWriteField();\r\n\r\n { Return self for chaining }\r\n Result := Self;\r\nend;\r\n\r\nfunction TOutputContext.AddValue(const AName: String; const AValue: Comp): TOutputContext;\r\nbegin\r\n { Write data }\r\n FSerializer.BeginWriteField(AName);\r\n FSerializer.WriteComp(AValue);\r\n FSerializer.EndWriteField();\r\n\r\n { Return self for chaining }\r\n Result := Self;\r\nend;\r\n\r\nfunction TOutputContext.AddValue(const AName: String; const AValue: T): TOutputContext;\r\nbegin\r\n { Write data }\r\n FSerializer.BeginWriteField(AName);\r\n FSerializer.SerializeInternal(\r\n FSerializer.RttiContext.GetType(TypeInfo(T)), @AValue);\r\n FSerializer.EndWriteField();\r\n\r\n { Return self for chaining }\r\n Result := Self;\r\nend;\r\n\r\nclass function TOutputContext.Create(const ASerializer: TSerializer): TOutputContext;\r\nbegin\r\n Result.FSerializer := ASerializer;\r\nend;\r\n\r\n{ TInputContext }\r\n\r\n\r\nclass function TInputContext.Create(const ADeserializer: TDeserializer): TInputContext;\r\nbegin\r\n Result.FDeserializer := ADeserializer;\r\nend;\r\n\r\nfunction TInputContext.GetValue(const AName: String; out AValue: Int64): TInputContext;\r\nbegin\r\n { Read data }\r\n FDeserializer.BeginReadField(AName);\r\n FDeserializer.ReadInt64(AValue);\r\n FDeserializer.EndReadField();\r\n\r\n { Return self for chaining }\r\n Result := Self;\r\nend;\r\n\r\nfunction TInputContext.GetValue(const AName: String; out AValue: UInt32): TInputContext;\r\nbegin\r\n { Read data }\r\n FDeserializer.BeginReadField(AName);\r\n FDeserializer.ReadUInt32(AValue);\r\n FDeserializer.EndReadField();\r\n\r\n { Return self for chaining }\r\n Result := Self;\r\nend;\r\n\r\nfunction TInputContext.GetValue(const AName: String; out AValue: UInt64): TInputContext;\r\nbegin\r\n { Read data }\r\n FDeserializer.BeginReadField(AName);\r\n FDeserializer.ReadUInt64(AValue);\r\n FDeserializer.EndReadField();\r\n\r\n { Return self for chaining }\r\n Result := Self;\r\nend;\r\n\r\nfunction TInputContext.GetValue(const AName: String; out AValue: WideChar): TInputContext;\r\nbegin\r\n { Read data }\r\n FDeserializer.BeginReadField(AName);\r\n FDeserializer.ReadWideChar(AValue);\r\n FDeserializer.EndReadField();\r\n\r\n { Return self for chaining }\r\n Result := Self;\r\nend;\r\n\r\nfunction TInputContext.GetValue(const AName: String; out AValue: AnsiChar): TInputContext;\r\nbegin\r\n { Read data }\r\n FDeserializer.BeginReadField(AName);\r\n FDeserializer.ReadAnsiChar(AValue);\r\n FDeserializer.EndReadField();\r\n\r\n { Return self for chaining }\r\n Result := Self;\r\nend;\r\n\r\nfunction TInputContext.GetValue(const AName: String; out AValue: UInt8): TInputContext;\r\nbegin\r\n { Read data }\r\n FDeserializer.BeginReadField(AName);\r\n FDeserializer.ReadUInt8(AValue);\r\n FDeserializer.EndReadField();\r\n\r\n { Return self for chaining }\r\n Result := Self;\r\nend;\r\n\r\nfunction TInputContext.GetValue(const AName: String; out AValue: Int8): TInputContext;\r\nbegin\r\n { Read data }\r\n FDeserializer.BeginReadField(AName);\r\n FDeserializer.ReadInt8(AValue);\r\n FDeserializer.EndReadField();\r\n\r\n { Return self for chaining }\r\n Result := Self;\r\nend;\r\n\r\nfunction TInputContext.GetValue(const AName: String; out AValue: Int16): TInputContext;\r\nbegin\r\n { Read data }\r\n FDeserializer.BeginReadField(AName);\r\n FDeserializer.ReadInt16(AValue);\r\n FDeserializer.EndReadField();\r\n\r\n { Return self for chaining }\r\n Result := Self;\r\nend;\r\n\r\nfunction TInputContext.GetValue(const AName: String; out AValue: Int32): TInputContext;\r\nbegin\r\n { Read data }\r\n FDeserializer.BeginReadField(AName);\r\n FDeserializer.ReadInt32(AValue);\r\n FDeserializer.EndReadField();\r\n\r\n { Return self for chaining }\r\n Result := Self;\r\nend;\r\n\r\nfunction TInputContext.GetValue(const AName: String; out AValue: UInt16): TInputContext;\r\nbegin\r\n { Read data }\r\n FDeserializer.BeginReadField(AName);\r\n FDeserializer.ReadUInt16(AValue);\r\n FDeserializer.EndReadField();\r\n\r\n { Return self for chaining }\r\n Result := Self;\r\nend;\r\n\r\nfunction TInputContext.GetValue(const AName: String; out AValue: Single): TInputContext;\r\nbegin\r\n { Read data }\r\n FDeserializer.BeginReadField(AName);\r\n FDeserializer.ReadSingle(AValue);\r\n FDeserializer.EndReadField();\r\n\r\n { Return self for chaining }\r\n Result := Self;\r\nend;\r\n\r\nfunction TInputContext.GetValue(const AName: String; out AValue: WideString): TInputContext;\r\nbegin\r\n { Read data }\r\n FDeserializer.BeginReadField(AName);\r\n FDeserializer.ReadWideString(AValue);\r\n FDeserializer.EndReadField();\r\n\r\n { Return self for chaining }\r\n Result := Self;\r\nend;\r\n\r\nfunction TInputContext.GetValue(const AName: String; out AValue: AnsiString): TInputContext;\r\nbegin\r\n { Read data }\r\n FDeserializer.BeginReadField(AName);\r\n FDeserializer.ReadAnsiString(AValue);\r\n FDeserializer.EndReadField();\r\n\r\n { Return self for chaining }\r\n Result := Self;\r\nend;\r\n\r\nfunction TInputContext.GetValue(const AName: String; out AValue: UnicodeString): TInputContext;\r\nbegin\r\n { Read data }\r\n FDeserializer.BeginReadField(AName);\r\n FDeserializer.ReadUnicodeString(AValue);\r\n FDeserializer.EndReadField();\r\n\r\n { Return self for chaining }\r\n Result := Self;\r\nend;\r\n\r\nfunction TInputContext.GetValue(const AName: String; out AValue: TObject): TInputContext;\r\nbegin\r\n { Read data }\r\n FDeserializer.BeginReadField(AName);\r\n FDeserializer.ReadClass(TypeInfo(TObject), AValue);\r\n FDeserializer.EndReadField();\r\n\r\n { Return self for chaining }\r\n Result := Self;\r\nend;\r\n\r\nfunction TInputContext.GetValue(const AName: String; out AValue: TClass): TInputContext;\r\nbegin\r\n { Read data }\r\n FDeserializer.BeginReadField(AName);\r\n FDeserializer.ReadMetaClass(AValue);\r\n FDeserializer.EndReadField();\r\n\r\n { Return self for chaining }\r\n Result := Self;\r\nend;\r\n\r\nfunction TInputContext.GetValue(const AName: String; out AValue: Extended): TInputContext;\r\nbegin\r\n { Read data }\r\n FDeserializer.BeginReadField(AName);\r\n FDeserializer.ReadExtended(AValue);\r\n FDeserializer.EndReadField();\r\n\r\n { Return self for chaining }\r\n Result := Self;\r\nend;\r\n\r\nfunction TInputContext.GetValue(const AName: String; out AValue: Double): TInputContext;\r\nbegin\r\n { Read data }\r\n FDeserializer.BeginReadField(AName);\r\n FDeserializer.ReadDouble(AValue);\r\n FDeserializer.EndReadField();\r\n\r\n { Return self for chaining }\r\n Result := Self;\r\nend;\r\n\r\nfunction TInputContext.GetValue(const AName: String; out AValue: Comp): TInputContext;\r\nbegin\r\n { Read data }\r\n FDeserializer.BeginReadField(AName);\r\n FDeserializer.ReadComp(AValue);\r\n FDeserializer.EndReadField();\r\n\r\n { Return self for chaining }\r\n Result := Self;\r\nend;\r\n\r\nfunction TInputContext.GetValue(const AName: String; out AValue: ShortString): TInputContext;\r\nbegin\r\n { Read data }\r\n FDeserializer.BeginReadField(AName);\r\n FDeserializer.ReadShortString(AValue);\r\n FDeserializer.EndReadField();\r\n\r\n { Return self for chaining }\r\n Result := Self;\r\nend;\r\n\r\nfunction TInputContext.GetValue(const AName: String; out AValue: Currency): TInputContext;\r\nbegin\r\n { Read data }\r\n FDeserializer.BeginReadField(AName);\r\n FDeserializer.ReadCurrency(AValue);\r\n FDeserializer.EndReadField();\r\n\r\n { Return self for chaining }\r\n Result := Self;\r\nend;\r\n\r\nfunction TInputContext.GetValue(const AName: String; out AValue: T): TInputContext;\r\nbegin\r\n { Read data }\r\n FDeserializer.BeginReadField(AName);\r\n FDeserializer.DeserializeInternal(\r\n FDeserializer.RttiContext.GetType(TypeInfo(T)), @AValue);\r\n FDeserializer.EndReadField();\r\n\r\n { Return self for chaining }\r\n Result := Self;\r\nend;\r\n\r\nend.\r\n" }, { "path": "Collections/Collections.Sets.pas", "content": "(*\r\n* Copyright (c) 2008-2012, Ciobanu Alexandru\r\n* All rights reserved.\r\n*\r\n* Redistribution and use in source and binary forms, with or without\r\n* modification, are permitted provided that the following conditions are met:\r\n* * Redistributions of source code must retain the above copyright\r\n* notice, this list of conditions and the following disclaimer.\r\n* * Redistributions in binary form must reproduce the above copyright\r\n* notice, this list of conditions and the following disclaimer in the\r\n* documentation and/or other materials provided with the distribution.\r\n* * Neither the name of the nor the\r\n* names of its contributors may be used to endorse or promote products\r\n* derived from this software without specific prior written permission.\r\n*\r\n* THIS SOFTWARE IS PROVIDED BY THE AUTHOR ''AS IS'' AND ANY\r\n* EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED\r\n* WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE\r\n* DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY\r\n* DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES\r\n* (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;\r\n* LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND\r\n* ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT\r\n* (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS\r\n* SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.\r\n*)\r\n\r\nunit Collections.Sets;\r\ninterface\r\nuses SysUtils,\r\n Generics.Defaults,\r\n Collections.Base;\r\n\r\ntype\r\n /// The asbstract base for all generic set collections.\r\n /// Descending classes must implement the required abstract methods and optionally can implement\r\n /// the non-required method.\r\n TAbstractSet = class abstract(TCollection, ISet)\r\n public\r\n /// Creates a new set collection.\r\n /// A rule set describing the elements in the set.\r\n constructor Create(const ARules: TRules);\r\n\r\n /// Destroys this instance.\r\n /// Do not call this method directly; call Free instead.\r\n destructor Destroy(); override;\r\n end;\r\n\r\ntype\r\n /// The generic set collection.\r\n /// This type uses hashing techniques to store its values.\r\n THashSet = class(TAbstractSet)\r\n private type\r\n {$REGION 'Internal Types'}\r\n TEnumerator = class(TAbstractEnumerator)\r\n private\r\n FCurrentIndex: NativeInt;\r\n public\r\n function TryMoveNext(out ACurrent: T): Boolean; override;\r\n end;\r\n\r\n TEntry = record\r\n FHashCode: NativeInt;\r\n FNext: NativeInt;\r\n FKey: T;\r\n end;\r\n\r\n TBucketArray = array of NativeInt;\r\n {$ENDREGION}\r\n\r\n private var\r\n FBucketArray: TBucketArray;\r\n FEntryArray: TArray;\r\n FCount: NativeInt;\r\n FFreeCount: NativeInt;\r\n FFreeList: NativeInt;\r\n\r\n { Internal }\r\n procedure InitializeInternals(const ACapacity: NativeInt);\r\n procedure Insert(const AKey: T; const ShouldAdd: Boolean = true);\r\n function FindEntry(const AKey: T): NativeInt;\r\n procedure Resize();\r\n function Hash(const AKey: T): NativeInt;\r\n\r\n protected\r\n /// Returns the number of elements in the set.\r\n /// A positive value specifying the number of elements in the set.\r\n function GetCount(): NativeInt; override;\r\n public\r\n /// Creates a new set collection.\r\n /// This constructor requests the default rule set. Call the overloaded constructor if\r\n /// specific a set of rules need to be passed.\r\n constructor Create(); overload;\r\n\r\n /// Creates a new set collection.\r\n /// A rule set describing the elements in the set.\r\n constructor Create(const ARules: TRules); overload;\r\n\r\n /// Creates a new set collection.\r\n /// The set's initial capacity.\r\n /// A rule set describing the elements in the set.\r\n constructor Create(const ARules: TRules; const AInitialCapacity: NativeInt); overload;\r\n\r\n /// Clears the contents of the set.\r\n procedure Clear(); override;\r\n\r\n /// Adds an element to the set.\r\n /// The value to add.\r\n /// If the set already contains the given value, nothing happens.\r\n procedure Add(const AValue: T); override;\r\n\r\n /// Removes a given value from the set.\r\n /// The value to remove.\r\n /// If the set does not contain the given value, nothing happens.\r\n procedure Remove(const AValue: T); override;\r\n\r\n /// Checks whether the set contains a given value.\r\n /// The value to check.\r\n /// True if the value was found in the set; False otherwise.\r\n function Contains(const AValue: T): Boolean; override;\r\n\r\n /// Specifies the number of elements in the set.\r\n /// A positive value specifying the number of elements in the set.\r\n property Count: NativeInt read GetCount;\r\n\r\n /// Returns a new enumerator object used to enumerate this set.\r\n /// This method is usually called by compiler-generated code. Its purpose is to create an enumerator\r\n /// object that is used to actually traverse the set.\r\n /// An enumerator object.\r\n function GetEnumerator() : IEnumerator; override;\r\n\r\n /// Copies the values stored in the set to a given array.\r\n /// An array where to copy the contents of the set.\r\n /// The index into the array at which the copying begins.\r\n /// This method assumes that has enough space to hold the contents of the set.\r\n /// is out of bounds.\r\n /// The array is not long enough.\r\n procedure CopyTo(var AArray: array of T; const AStartIndex: NativeInt); overload; override;\r\n\r\n /// Checks whether the set is empty.\r\n /// True if the set is empty; False otherwise.\r\n /// This method is the recommended way of detecting if the set is empty.\r\n function Empty(): Boolean; override;\r\n end;\r\n\r\n /// The generic set collection designed to store objects.\r\n /// This type uses hashing techniques to store its objects.\r\n TObjectHashSet = class(THashSet)\r\n private\r\n FOwnsObjects: Boolean;\r\n\r\n protected\r\n /// Frees the object that was removed from the collection.\r\n /// The object that was removed from the collection.\r\n procedure HandleElementRemoved(const AElement: T); override;\r\n public\r\n /// Specifies whether this set owns the objects stored in it.\r\n /// True if the set owns its objects; False otherwise.\r\n /// This property controls the way the set controls the life-time of the stored objects.\r\n property OwnsObjects: Boolean read FOwnsObjects write FOwnsObjects;\r\n end;\r\n\r\ntype\r\n /// The generic set collection.\r\n /// This type uses hashing techniques and linked lists to store its values.\r\n TLinkedSet = class(TAbstractSet)\r\n private type\r\n {$REGION 'Internal Types'}\r\n PEntry = ^TEntry;\r\n TEntry = record\r\n FHashCode: NativeInt;\r\n FNext, FPrev: PEntry;\r\n FValue: T;\r\n end;\r\n\r\n TBucketArray = TArray;\r\n\r\n TEnumerator = class(TAbstractEnumerator)\r\n private\r\n FCurrentEntry: PEntry;\r\n public\r\n function TryMoveNext(out ACurrent: T): Boolean; override;\r\n end;\r\n {$ENDREGION}\r\n\r\n private var\r\n FBucketArray: TBucketArray;\r\n FCount, FFreeCount: NativeInt;\r\n FHead, FTail, FFirstFree: PEntry;\r\n\r\n { Internal }\r\n procedure InitializeInternals(const ACapacity: NativeInt);\r\n procedure Insert(const AValue: T; const AShouldAdd: Boolean = true);\r\n procedure ReInsert(const AEntry: PEntry; const ACapacity: NativeInt);\r\n\r\n function FindEntry(const AValue: T): PEntry;\r\n function Hash(const AValue: T): NativeInt;\r\n\r\n { Caching }\r\n function NeedEntry(const AValue: T; const AHash: NativeInt): PEntry;\r\n procedure ReleaseEntry(const AEntry: PEntry);\r\n protected\r\n /// Returns the number of elements in the set.\r\n /// A positive value specifying the number of elements in the set.\r\n function GetCount(): NativeInt; override;\r\n\r\n public\r\n /// Creates a new set collection.\r\n /// This constructor requests the default rule set. Call the overloaded constructor if\r\n /// specific a set of rules need to be passed.\r\n constructor Create(); overload;\r\n\r\n /// Creates a new set collection.\r\n /// A rule set describing the elements in the set.\r\n constructor Create(const ARules: TRules); overload;\r\n\r\n /// Creates a new set collection.\r\n /// The set's initial capacity.\r\n /// A rule set describing the elements in the set.\r\n constructor Create(const ARules: TRules; const AInitialCapacity: NativeInt); overload;\r\n\r\n /// Destroys this instance.\r\n /// Do not call this method directly; call Free instead.\r\n destructor Destroy(); override;\r\n\r\n /// Clears the contents of the set.\r\n procedure Clear(); override;\r\n\r\n /// Adds an element to the set.\r\n /// The value to add.\r\n /// If the set already contains the given value, nothing happens.\r\n procedure Add(const AValue: T); override;\r\n\r\n /// Removes a given value from the set.\r\n /// The value to remove.\r\n /// If the set does not contain the given value, nothing happens.\r\n procedure Remove(const AValue: T); override;\r\n\r\n /// Checks whether the set contains a given value.\r\n /// The value to check.\r\n /// True if the value was found in the set; False otherwise.\r\n function Contains(const AValue: T): Boolean; override;\r\n\r\n /// Specifies the number of elements in the set.\r\n /// A positive value specifying the number of elements in the set.\r\n property Count: NativeInt read FCount;\r\n\r\n /// Returns a new enumerator object used to enumerate this set.\r\n /// This method is usually called by compiler-generated code. Its purpose is to create an enumerator\r\n /// object that is used to actually traverse the set.\r\n /// An enumerator object.\r\n function GetEnumerator() : IEnumerator; override;\r\n\r\n /// Copies the values stored in the set to a given array.\r\n /// An array where to copy the contents of the set.\r\n /// The index into the array at which the copying begins.\r\n /// This method assumes that has enough space to hold the contents of the set.\r\n /// is out of bounds.\r\n /// The array is not long enough.\r\n procedure CopyTo(var AArray: array of T; const AStartIndex: NativeInt); overload; override;\r\n\r\n /// Checks whether the set is empty.\r\n /// True if the set is empty; False otherwise.\r\n /// This method is the recommended way of detecting if the set is empty.\r\n function Empty(): Boolean; override;\r\n end;\r\n\r\n /// The generic set collection designed to store objects.\r\n /// This type uses hashing techniques and linked lists to store its objects.\r\n TObjectLinkedSet = class(TLinkedSet)\r\n private\r\n FOwnsObjects: Boolean;\r\n\r\n protected\r\n /// Frees the object that was removed from the collection.\r\n /// The object that was removed from the collection.\r\n procedure HandleElementRemoved(const AElement: T); override;\r\n public\r\n /// Specifies whether this set owns the objects stored in it.\r\n /// True if the set owns its objects; False otherwise.\r\n /// This property controls the way the set controls the life-time of the stored objects.\r\n property OwnsObjects: Boolean read FOwnsObjects write FOwnsObjects;\r\n end;\r\n\r\ntype\r\n /// The generic set collection.\r\n /// This type uses an AVL tree to store its values.\r\n TSortedSet = class(TAbstractSet, ISortedSet)\r\n private type\r\n {$REGION 'Internal Types'}\r\n //TBalanceAct = (baStart = 0, baLeft, baRight, baLoop, baEnd);\r\n\r\n { An internal node class }\r\n TNode = class\r\n private\r\n FKey: T;\r\n\r\n FParent,\r\n FLeft, FRight: TNode;\r\n\r\n FBalance: ShortInt;\r\n end;\r\n\r\n TEnumerator = class(TAbstractEnumerator)\r\n private\r\n FCurrentEntry: TNode;\r\n public\r\n function TryMoveNext(out ACurrent: T): Boolean; override;\r\n end;\r\n {$ENDREGION}\r\n\r\n private var\r\n FCount: NativeInt;\r\n FRoot: TNode;\r\n FSignFix: NativeInt;\r\n\r\n function FindNodeWithKey(const AValue: T): TNode;\r\n function FindLeftMostNode(): TNode;\r\n function FindRightMostNode(): TNode;\r\n function WalkToTheRight(const ANode: TNode): TNode;\r\n function MakeNode(const AValue: T; const ARoot: TNode): TNode;\r\n procedure RecursiveClear(const ANode: TNode);\r\n procedure ReBalanceSubTreeOnInsert(const ANode: TNode);\r\n procedure Insert(const AValue: T);\r\n procedure BalanceTreesAfterRemoval(const ANode: TNode);\r\n protected\r\n /// Returns the number of elements in the set.\r\n /// A positive value specifying the number of elements in the set.\r\n function GetCount(): NativeInt; override;\r\n public\r\n /// Creates a new set collection.\r\n /// This constructor requests the default rule set. Call the overloaded constructor if\r\n /// specific a set of rules need to be passed. The elements are stored in ascending order.\r\n constructor Create(); overload;\r\n\r\n /// Creates a new set collection.\r\n /// A rule set describing the elements in the set.\r\n /// The elements are stored in ascending order.\r\n constructor Create(const ARules: TRules); overload;\r\n\r\n /// Creates a new set collection.\r\n /// Pass in a value of True if the elements should be kept in ascending order. Pass in False for descending order.\r\n /// A rule set describing the elements in the set.\r\n constructor Create(const ARules: TRules; const AAscending: Boolean); overload;\r\n\r\n /// Clears the contents of the set.\r\n procedure Clear(); override;\r\n\r\n /// Adds an element to the set.\r\n /// The value to add.\r\n /// If the set already contains the given value, nothing happens.\r\n procedure Add(const AValue: T); override;\r\n\r\n /// Removes a given value from the set.\r\n /// The value to remove.\r\n /// If the set does not contain the given value, nothing happens.\r\n procedure Remove(const AValue: T); override;\r\n\r\n /// Checks whether the set contains a given value.\r\n /// The value to check.\r\n /// True if the value was found in the set; False otherwise.\r\n function Contains(const AValue: T): Boolean; override;\r\n\r\n /// Specifies the number of elements in the set.\r\n /// A positive value specifying the number of elements in the set.\r\n property Count: NativeInt read FCount;\r\n\r\n /// Returns a new enumerator object used to enumerate this set.\r\n /// This method is usually called by compiler-generated code. Its purpose is to create an enumerator\r\n /// object that is used to actually traverse the set.\r\n /// An enumerator object.\r\n function GetEnumerator() : IEnumerator; override;\r\n\r\n /// Copies the values stored in the set to a given array.\r\n /// An array where to copy the contents of the set.\r\n /// The index into the array at which the copying begins.\r\n /// This method assumes that has enough space to hold the contents of the set.\r\n /// is out of bounds.\r\n /// The array is not long enough.\r\n procedure CopyTo(var AArray: array of T; const AStartIndex: NativeInt); overload; override;\r\n\r\n /// Checks whether the set is empty.\r\n /// True if the set is empty; False otherwise.\r\n /// This method is the recommended way of detecting if the set is empty.\r\n function Empty(): Boolean; override;\r\n\r\n /// Returns the biggest element.\r\n /// An element from the set considered to have the biggest value.\r\n /// The set is empty.\r\n function Max(): T; override;\r\n\r\n /// Returns the smallest element.\r\n /// An element from the set considered to have the smallest value.\r\n /// The set is empty.\r\n function Min(): T; override;\r\n\r\n /// Returns the first element.\r\n /// The first element in the set.\r\n /// The set is empty.\r\n function First(): T; override;\r\n\r\n /// Returns the first element or a default, if the set is empty.\r\n /// The default value returned if the set is empty.\r\n /// The first element in the set if the set is not empty; otherwise is returned.\r\n function FirstOrDefault(const ADefault: T): T; override;\r\n\r\n /// Returns the last element.\r\n /// The last element in the set.\r\n /// The set is empty.\r\n function Last(): T; override;\r\n\r\n /// Returns the last element or a default, if the set is empty.\r\n /// The default value returned if the set is empty.\r\n /// The last element in the set if the set is not empty; otherwise is returned.\r\n function LastOrDefault(const ADefault: T): T; override;\r\n\r\n /// Returns the single element stored in the set.\r\n /// The element in set.\r\n /// This method checks if the set contains just one element, in which case it is returned.\r\n /// The set is empty.\r\n /// There is more than one element in the set.\r\n function Single(): T; override;\r\n\r\n /// Returns the single element stored in the set, or a default value.\r\n /// The default value returned if there are less or more elements in the set.\r\n /// The element in the set if the condition is satisfied; is returned otherwise.\r\n /// This method checks if the set contains just one element, in which case it is returned. Otherwise\r\n /// the value in is returned.\r\n function SingleOrDefault(const ADefault: T): T; override;\r\n end;\r\n\r\n /// The generic set collection designed to store objects.\r\n /// This type uses an AVL tree to store its objects.\r\n TObjectSortedSet = class(TSortedSet)\r\n private\r\n FOwnsObjects: Boolean;\r\n\r\n protected\r\n /// Frees the object that was removed from the collection.\r\n /// The object that was removed from the collection.\r\n procedure HandleElementRemoved(const AElement: T); override;\r\n\r\n public\r\n /// Specifies whether this set owns the objects stored in it.\r\n /// True if the set owns its objects; False otherwise.\r\n /// This property controls the way the set controls the life-time of the stored objects.\r\n property OwnsObjects: Boolean read FOwnsObjects write FOwnsObjects;\r\n end;\r\n\r\ntype\r\n /// The generic set collection.\r\n /// This type uses an internal array to store its values.\r\n TArraySet = class(TAbstractSet, ISortedSet, IDynamic)\r\n private type\r\n {$REGION 'Internal Types'}\r\n TEnumerator = class(TAbstractEnumerator)\r\n private\r\n FCurrentIndex: NativeInt;\r\n public\r\n function TryMoveNext(out ACurrent: T): Boolean; override;\r\n end;\r\n {$ENDREGION}\r\n\r\n private var\r\n FArray: TArray;\r\n FCount: NativeInt;\r\n FSignFix: NativeInt;\r\n\r\n { Inserts an element into a position }\r\n function BinarySearch(const AElement: T): NativeInt;\r\n protected\r\n /// Returns the number of elements in the set.\r\n /// A positive value specifying the number of elements in the set.\r\n function GetCount(): NativeInt; override;\r\n\r\n /// Returns the current capacity.\r\n /// A positive number that specifies the number of elements that the set can hold before it\r\n /// needs to grow again.\r\n /// The value of this method is greater than or equal to the amount of elements in the set. If this value\r\n /// is greater than the number of elements, it means that the set has some extra capacity to operate upon.\r\n function GetCapacity(): NativeInt;\r\n public\r\n /// Creates a new set collection.\r\n /// This constructor requests the default rule set. Call the overloaded constructor if\r\n /// specific a set of rules need to be passed. The elements are stored in ascending order.\r\n constructor Create(); overload;\r\n\r\n /// Creates a new set collection.\r\n /// A rule set describing the elements in the set.\r\n /// The elements are stored in ascending order.\r\n constructor Create(const ARules: TRules); overload;\r\n\r\n /// Creates a new set collection.\r\n /// Pass in a value of True if the elements should be kept in ascending order. Pass in False for descending order.\r\n /// The set's initial capacity.\r\n /// A rule set describing the elements in the set.\r\n constructor Create(const ARules: TRules; const AInitialCapacity: NativeInt; const AAscending: Boolean); overload;\r\n\r\n /// Clears the contents of the set.\r\n procedure Clear(); override;\r\n\r\n /// Adds an element to the set.\r\n /// The value to add.\r\n /// If the set already contains the given value, nothing happens.\r\n procedure Add(const AValue: T); override;\r\n\r\n /// Removes a given value from the set.\r\n /// The value to remove.\r\n /// If the set does not contain the given value, nothing happens.\r\n procedure Remove(const AValue: T); override;\r\n\r\n /// Checks whether the set contains a given value.\r\n /// The value to check.\r\n /// True if the value was found in the set; False otherwise.\r\n function Contains(const AValue: T): Boolean; override;\r\n\r\n /// Specifies the number of elements in the set.\r\n /// A positive value specifying the number of elements in the set.\r\n property Count: NativeInt read FCount;\r\n\r\n /// Specifies the current capacity.\r\n /// A positive number that specifies the number of elements that the set can hold before it\r\n /// needs to grow again.\r\n /// The value of this property is greater than or equal to the amount of elements in the set. If this value\r\n /// if greater than the number of elements, it means that the set has some extra capacity to operate upon.\r\n property Capacity: NativeInt read GetCapacity;\r\n\r\n /// Returns a new enumerator object used to enumerate this set.\r\n /// This method is usually called by compiler-generated code. Its purpose is to create an enumerator\r\n /// object that is used to actually traverse the set.\r\n /// An enumerator object.\r\n function GetEnumerator(): IEnumerator; override;\r\n\r\n /// Removes the excess capacity from the set.\r\n /// This method can be called manually to force the set to drop the extra capacity it might hold. For example,\r\n /// after performing some massive operations on a big list, call this method to ensure that all extra memory held by the\r\n /// set is released.\r\n procedure Shrink();\r\n\r\n /// Forces the set to increase its capacity.\r\n /// Call this method to force the set to increase its capacity ahead of time. Manually adjusting the capacity\r\n /// can be useful in certain situations.\r\n procedure Grow();\r\n\r\n /// Copies the values stored in the set to a given array.\r\n /// An array where to copy the contents of the set.\r\n /// The index into the array at which the copying begins.\r\n /// This method assumes that has enough space to hold the contents of the set.\r\n /// is out of bounds.\r\n /// The array is not long enough.\r\n procedure CopyTo(var AArray: array of T; const AStartIndex: NativeInt); overload; override;\r\n\r\n /// Checks whether the set is empty.\r\n /// True if the set is empty; False otherwise.\r\n /// This method is the recommended way of detecting if the set is empty.\r\n function Empty(): Boolean; override;\r\n\r\n /// Returns the biggest element.\r\n /// An element from the set considered to have the biggest value.\r\n /// The set is empty.\r\n function Max(): T; override;\r\n\r\n /// Returns the smallest element.\r\n /// An element from the set considered to have the smallest value.\r\n /// The set is empty.\r\n function Min(): T; override;\r\n\r\n /// Returns the first element.\r\n /// The first element in the set.\r\n /// The set is empty.\r\n function First(): T; override;\r\n\r\n /// Returns the first element or a default, if the set is empty.\r\n /// The default value returned if the set is empty.\r\n /// The first element in the set if the set is not empty; otherwise is returned.\r\n function FirstOrDefault(const ADefault: T): T; override;\r\n\r\n /// Returns the last element.\r\n /// The last element in the set.\r\n /// The set is empty.\r\n function Last(): T; override;\r\n\r\n /// Returns the last element or a default, if the set is empty.\r\n /// The default value returned if the set is empty.\r\n /// The last element in set if the set is not empty; otherwise is returned.\r\n function LastOrDefault(const ADefault: T): T; override;\r\n\r\n /// Returns the single element stored in the set.\r\n /// The element in set.\r\n /// This method checks if the set contains just one element, in which case it is returned.\r\n /// The set is empty.\r\n /// There is more than one element in the set.\r\n function Single(): T; override;\r\n\r\n /// Returns the single element stored in the set, or a default value.\r\n /// The default value returned if there is less or more elements in the set.\r\n /// The element in the set if the condition is satisfied; is returned otherwise.\r\n /// This method checks if the set contains just one element, in which case it is returned. Otherwise\r\n /// the value in is returned.\r\n function SingleOrDefault(const ADefault: T): T; override;\r\n\r\n /// Aggregates a value based on the set's elements.\r\n /// The aggregator method.\r\n /// A value that contains the set's aggregated value.\r\n /// This method returns the first element if the set only has one element. Otherwise,\r\n /// is invoked for each two elements (first and second; then the result of the first two\r\n /// and the third, and so on). The simplest example of aggregation is the \"sum\" operation, where you can obtain the sum of all\r\n /// elements in the value.\r\n /// is nil.\r\n /// The set is empty.\r\n function Aggregate(const AAggregator: TFunc): T; override;\r\n\r\n /// Aggregates a value based on the set's elements.\r\n /// The aggregator method.\r\n /// The default value returned if the set is empty.\r\n /// A value that contains the set's aggregated value. If the set is empty, is returned.\r\n /// This method returns the first element if the set only has one element. Otherwise,\r\n /// is invoked for each two elements (first and second; then the result of the first two\r\n /// and the third, and so on). The simplest example of aggregation is the \"sum\" operation, where you can obtain the sum of all\r\n /// elements in the value.\r\n /// is nil.\r\n function AggregateOrDefault(const AAggregator: TFunc; const ADefault: T): T; override;\r\n\r\n /// Returns the element at a given position.\r\n /// The index from which to return the element.\r\n /// The element at the specified position.\r\n /// The set is empty.\r\n /// is out of bounds.\r\n function ElementAt(const AIndex: NativeInt): T; override;\r\n\r\n /// Returns the element at a given position.\r\n /// The index from which to return the element.\r\n /// The default value returned if the set is empty.\r\n /// The element at the specified position if the set is not empty and the position is not out of bounds; otherwise\r\n /// the value of is returned.\r\n function ElementAtOrDefault(const AIndex: NativeInt; const ADefault: T): T; override;\r\n\r\n /// Checks whether at least one element in the set satisfies a given predicate.\r\n /// The predicate to check for each element.\r\n /// True if at least one element satisfies a given predicate; False otherwise.\r\n /// This method traverses the whole set and checks the value of the predicate for each element. This method\r\n /// stops on the first element for which the predicate returns True. The logical equivalent of this operation is \"OR\".\r\n /// is nil.\r\n function Any(const APredicate: TPredicate): Boolean; override;\r\n\r\n /// Checks that all elements in the set satisfy a given predicate.\r\n /// The predicate to check for each element.\r\n /// True if all elements satisfy a given predicate; False otherwise.\r\n /// This method traverses the whole set and checks the value of the predicate for each element. This method\r\n /// stops on the first element for which the predicate returns False. The logical equivalent of this operation is \"AND\".\r\n /// is nil.\r\n function All(const APredicate: TPredicate): Boolean; override;\r\n\r\n /// Checks whether the elements in this set are equal to the elements in another collection.\r\n /// The collection to compare to.\r\n /// True if the collections are equal; False if the collections are different.\r\n /// This method checks that each element at position X in this set is equal to an element at position X in\r\n /// the provided collection. If the number of elements in both collections is different, then the collections are considered different.\r\n /// Note that the comparison of elements is done using the rule set used by this set. This means that comparing this collection\r\n /// to another one might yeild a different result than comparing the other collection to this one.\r\n /// is nil.\r\n function EqualsTo(const ACollection: IEnumerable): Boolean; override;\r\n end;\r\n\r\n /// The generic set collection designed to store objects.\r\n /// This type uses an internal array to store its objects.\r\n TObjectArraySet = class(TArraySet)\r\n private\r\n FOwnsObjects: Boolean;\r\n\r\n protected\r\n /// Frees the object that was removed from the collection.\r\n /// The object that was removed from the collection.\r\n procedure HandleElementRemoved(const AElement: T); override;\r\n\r\n public\r\n /// Specifies whether this set owns the objects stored in it.\r\n /// True if the set owns its objects; False otherwise.\r\n /// This property controls the way the set controls the life-time of the stored objects.\r\n property OwnsObjects: Boolean read FOwnsObjects write FOwnsObjects;\r\n end;\r\n\r\n{$IF CompilerVersion > 21}\r\ntype\r\n /// A specific 16-bit integer set collection.\r\n /// This collection uses an internal bit array to store its values.\r\n TBitSet = class(TAbstractSet, ISortedSet)\r\n private type\r\n {$REGION 'Internal Types'}\r\n TAscendingEnumerator = class(TAbstractEnumerator)\r\n private\r\n FValue: Word;\r\n FPageIndex, FBitIndex, FPage: NativeInt;\r\n\r\n public\r\n function TryMoveNext(out ACurrent: Word): Boolean; override;\r\n end;\r\n\r\n TDescendingEnumerator = class(TAscendingEnumerator)\r\n public\r\n function TryMoveNext(out ACurrent: Word): Boolean; override;\r\n end;\r\n {$ENDREGION}\r\n\r\n private const\r\n CPageSize = SizeOf(NativeInt);\r\n\r\n private var\r\n FCount: NativeInt;\r\n FBitArray: TArray;\r\n FAscending: Boolean;\r\n\r\n protected\r\n /// Returns the number of elements in the set.\r\n /// A positive value specifying the number of elements in the set.\r\n function GetCount(): NativeInt; override;\r\n\r\n public\r\n /// Creates a new set collection.\r\n /// This collection does not use comparison rules for its default functionality. It relies on the fact that default\r\n /// RTL comparators use the same rules as the natural ordering of Word values. The elements are stored in ascending order.\r\n constructor Create(); overload;\r\n\r\n /// Creates a new set collection.\r\n /// A rule set describing the elements in the set.\r\n /// The supplied rule set is ignored.\r\n constructor Create(const ARules: TRules); overload;\r\n\r\n /// Creates a new set collection.\r\n /// Pass in a value of True if the elements should be kept in ascending order. Pass in False for descending order.\r\n /// This collection does not use comparison rules for its default functionality. It relies on the fact that default\r\n /// RTL comparators use the same rules as the natural ordering of Word values.\r\n constructor Create(const AAscending: Boolean); overload;\r\n\r\n /// Clears the contents of the set.\r\n procedure Clear(); override;\r\n\r\n /// Adds an element to the set.\r\n /// The value to add.\r\n /// If the set already contains the given value, nothing happens.\r\n procedure Add(const AValue: Word); override;\r\n\r\n /// Removes a given value from the set.\r\n /// The value to remove.\r\n /// If the set does not contain the given value, nothing happens.\r\n procedure Remove(const AValue: Word); override;\r\n\r\n /// Checks whether the set contains a given value.\r\n /// The value to check.\r\n /// True if the value was found in the set; False otherwise.\r\n function Contains(const AValue: Word): Boolean; override;\r\n\r\n /// Specifies the number of elements in the set.\r\n /// A positive value specifying the number of elements in the set.\r\n property Count: NativeInt read FCount;\r\n\r\n /// Returns a new enumerator object used to enumerate this set.\r\n /// This method is usually called by compiler-generated code. Its purpose is to create an enumerator\r\n /// object that is used to actually traverse the set.\r\n /// An enumerator object.\r\n function GetEnumerator() : IEnumerator; override;\r\n\r\n /// Copies the values stored in the set to a given array.\r\n /// An array where to copy the contents of the set.\r\n /// The index into the array at which the copying begins.\r\n /// This method assumes that has enough space to hold the contents of the set.\r\n /// is out of bounds.\r\n /// The array is not long enough.\r\n procedure CopyTo(var AArray: array of Word; const AStartIndex: NativeInt); overload; override;\r\n\r\n /// Checks whether the set is empty.\r\n /// True if the set is empty; False otherwise.\r\n /// This method is the recommended way of detecting if the set is empty.\r\n function Empty(): Boolean; override;\r\n\r\n /// Returns the biggest element.\r\n /// An element from the set considered to have the biggest value.\r\n /// The set is empty.\r\n function Max(): Word; override;\r\n\r\n /// Returns the smallest element.\r\n /// An element from the set considered to have the smallest value.\r\n /// The set is empty.\r\n function Min(): Word; override;\r\n\r\n /// Returns the first element.\r\n /// The first element in the set.\r\n /// The set is empty.\r\n function First(): Word; override;\r\n\r\n /// Returns the first element or a default, if the set is empty.\r\n /// The default value returned if the set is empty.\r\n /// The first element in the set if the set is not empty; otherwise is returned.\r\n function FirstOrDefault(const ADefault: Word): Word; override;\r\n\r\n /// Returns the last element.\r\n /// The last element in the set.\r\n /// The set is empty.\r\n function Last(): Word; override;\r\n\r\n /// Returns the last element or a default, if the set is empty.\r\n /// The default value returned if the set is empty.\r\n /// The last element in the set if the set is not empty; otherwise is returned.\r\n function LastOrDefault(const ADefault: Word): Word; override;\r\n\r\n /// Returns the single element stored in the set.\r\n /// The element in set.\r\n /// This method checks if the set contains just one element, in which case it is returned.\r\n /// The set is empty.\r\n /// There is more than one element in the set.\r\n function Single(): Word; override;\r\n\r\n /// Returns the single element stored in the set, or a default value.\r\n /// The default value returned if there are less or more elements in the set.\r\n /// The element in the set if the condition is satisfied; is returned otherwise.\r\n /// This method checks if the set contains just one element, in which case it is returned. Otherwise\r\n /// the value in is returned.\r\n function SingleOrDefault(const ADefault: Word): Word; override;\r\n end;\r\n {$IFEND}\r\n\r\nimplementation\r\n\r\n{ TAbstractSet }\r\n\r\n\r\ndestructor TAbstractSet.Destroy;\r\nbegin\r\n Clear();\r\n inherited;\r\nend;\r\n\r\nconstructor TAbstractSet.Create(const ARules: TRules);\r\nbegin\r\n inherited Create(ARules);\r\nend;\r\n\r\n{ THashSet }\r\n\r\nprocedure THashSet.Add(const AValue: T);\r\nbegin\r\n { Call insert }\r\n Insert(AValue, False);\r\nend;\r\n\r\nprocedure THashSet.Clear;\r\nvar\r\n I: NativeInt;\r\nbegin\r\n if FCount > 0 then\r\n for I := 0 to Length(FBucketArray) - 1 do\r\n FBucketArray[I] := -1;\r\n\r\n for I := 0 to Length(FEntryArray) - 1 do\r\n if FEntryArray[I].FHashCode >= 0 then\r\n begin\r\n NotifyElementRemoved(FEntryArray[I].FKey);\r\n FEntryArray[I].FKey := default(T);\r\n NotifyCollectionChanged();\r\n end;\r\n\r\n if Length(FEntryArray) > 0 then\r\n FillChar(FEntryArray[0], Length(FEntryArray) * SizeOf(TEntry), 0);\r\n\r\n FFreeList := -1;\r\n FCount := 0;\r\n FFreeCount := 0;\r\nend;\r\n\r\nfunction THashSet.Contains(const AValue: T): Boolean;\r\nbegin\r\n Result := (FindEntry(AValue) >= 0);\r\nend;\r\n\r\nprocedure THashSet.CopyTo(var AArray: array of T; const AStartIndex: NativeInt);\r\nvar\r\n I, X: NativeInt;\r\nbegin\r\n { Check for indexes }\r\n if (AStartIndex >= Length(AArray)) or (AStartIndex < 0) then\r\n ExceptionHelper.Throw_ArgumentOutOfRangeError('AStartIndex');\r\n\r\n if (Length(AArray) - AStartIndex) < Count then\r\n ExceptionHelper.Throw_ArgumentOutOfSpaceError('AArray');\r\n\r\n X := AStartIndex;\r\n\r\n for I := 0 to FCount - 1 do\r\n begin\r\n if (FEntryArray[I].FHashCode >= 0) then\r\n begin\r\n AArray[X] := FEntryArray[I].FKey;\r\n Inc(X);\r\n end;\r\n end;\r\nend;\r\n\r\nconstructor THashSet.Create(const ARules: TRules; const AInitialCapacity: NativeInt);\r\nbegin\r\n inherited Create(ARules);\r\n\r\n { Check for proper capacity }\r\n if AInitialCapacity <= 0 then\r\n InitializeInternals(CDefaultSize)\r\n else\r\n InitializeInternals(AInitialCapacity)\r\nend;\r\n\r\nconstructor THashSet.Create();\r\nbegin\r\n Create(TRules.Default, CDefaultSize);\r\nend;\r\n\r\nconstructor THashSet.Create(const ARules: TRules);\r\nbegin\r\n Create(ARules, CDefaultSize);\r\nend;\r\n\r\nfunction THashSet.Empty: Boolean;\r\nbegin\r\n Result := (Count = 0);\r\nend;\r\n\r\nfunction THashSet.FindEntry(const AKey: T): NativeInt;\r\nvar\r\n LHashCode: NativeInt;\r\n I: NativeInt;\r\nbegin\r\n Result := -1;\r\n\r\n if Length(FBucketArray) > 0 then\r\n begin\r\n { Generate the hash code }\r\n LHashCode := Hash(AKey);\r\n\r\n I := FBucketArray[LHashCode mod Length(FBucketArray)];\r\n\r\n while I >= 0 do\r\n begin\r\n if (FEntryArray[I].FHashCode = LHashCode) and ElementsAreEqual(FEntryArray[I].FKey, AKey) then\r\n begin Result := I; Exit; end;\r\n\r\n I := FEntryArray[I].FNext;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction THashSet.GetCount: NativeInt;\r\nbegin\r\n Result := (FCount - FFreeCount);\r\nend;\r\n\r\nfunction THashSet.GetEnumerator: IEnumerator;\r\nbegin\r\n Result := TEnumerator.Create(Self);\r\nend;\r\n\r\nfunction THashSet.Hash(const AKey: T): NativeInt;\r\nconst\r\n PositiveMask = not NativeInt(1 shl (SizeOf(NativeInt) * 8 - 1));\r\nbegin\r\n Result := PositiveMask and ((PositiveMask and GetElementHashCode(AKey)) + 1);\r\nend;\r\n\r\nprocedure THashSet.InitializeInternals(const ACapacity: NativeInt);\r\nvar\r\n I: NativeInt;\r\nbegin\r\n SetLength(FBucketArray, ACapacity);\r\n SetLength(FEntryArray, ACapacity);\r\n\r\n for I := 0 to ACapacity - 1 do\r\n begin\r\n FBucketArray[I] := -1;\r\n FEntryArray[I].FHashCode := -1;\r\n end;\r\n\r\n FFreeList := -1;\r\nend;\r\n\r\nprocedure THashSet.Insert(const AKey: T; const ShouldAdd: Boolean);\r\nvar\r\n LFreeList, LIndex,\r\n LHashCode, I: NativeInt;\r\nbegin\r\n LFreeList := 0;\r\n\r\n if Length(FBucketArray) = 0 then\r\n InitializeInternals(CDefaultSize);\r\n\r\n { Generate the hash code }\r\n LHashCode := Hash(AKey);\r\n LIndex := LHashCode mod Length(FBucketArray);\r\n\r\n I := FBucketArray[LIndex];\r\n\r\n while I >= 0 do\r\n begin\r\n if (FEntryArray[I].FHashCode = LHashCode) and ElementsAreEqual(FEntryArray[I].FKey, AKey) then\r\n begin\r\n if (ShouldAdd) then\r\n ExceptionHelper.Throw_DuplicateKeyError('AKey');\r\n\r\n Exit;\r\n end;\r\n\r\n { Move to next }\r\n I := FEntryArray[I].FNext;\r\n end;\r\n\r\n { Adjust free spaces }\r\n if FFreeCount > 0 then\r\n begin\r\n LFreeList := FFreeList;\r\n FFreeList := FEntryArray[LFreeList].FNext;\r\n\r\n Dec(FFreeCount);\r\n end else\r\n begin\r\n { Adjust LIndex if there is not enough free space }\r\n if FCount = Length(FEntryArray) then\r\n begin\r\n Resize();\r\n LIndex := LHashCode mod Length(FBucketArray);\r\n end;\r\n\r\n LFreeList := FCount;\r\n Inc(FCount);\r\n end;\r\n\r\n { Insert the element at the right position and adjust arrays }\r\n FEntryArray[LFreeList].FHashCode := LHashCode;\r\n FEntryArray[LFreeList].FKey := AKey;\r\n FEntryArray[LFreeList].FNext := FBucketArray[LIndex];\r\n\r\n FBucketArray[LIndex] := LFreeList;\r\n NotifyCollectionChanged();\r\nend;\r\n\r\nprocedure THashSet.Remove(const AValue: T);\r\nvar\r\n LHashCode, LIndex,\r\n I, LRemIndex: NativeInt;\r\nbegin\r\n if Length(FBucketArray) > 0 then\r\n begin\r\n { Generate the hash code }\r\n LHashCode := Hash(AValue);\r\n\r\n LIndex := LHashCode mod Length(FBucketArray);\r\n LRemIndex := -1;\r\n\r\n I := FBucketArray[LIndex];\r\n\r\n while I >= 0 do\r\n begin\r\n if (FEntryArray[I].FHashCode = LHashCode) and ElementsAreEqual(FEntryArray[I].FKey, AValue) then\r\n begin\r\n\r\n if LRemIndex < 0 then\r\n begin\r\n FBucketArray[LIndex] := FEntryArray[I].FNext;\r\n end else\r\n begin\r\n FEntryArray[LRemIndex].FNext := FEntryArray[I].FNext;\r\n end;\r\n\r\n FEntryArray[I].FHashCode := -1;\r\n FEntryArray[I].FNext := FFreeList;\r\n FEntryArray[I].FKey := default(T);\r\n\r\n FFreeList := I;\r\n Inc(FFreeCount);\r\n NotifyCollectionChanged();\r\n\r\n Exit;\r\n end;\r\n\r\n LRemIndex := I;\r\n I := FEntryArray[I].FNext;\r\n end;\r\n\r\n end;\r\nend;\r\n\r\nprocedure THashSet.Resize;\r\nvar\r\n LNewLength, I, LIndex: NativeInt;\r\nbegin\r\n LNewLength := FCount * 2;\r\n\r\n SetLength(FBucketArray, LNewLength);\r\n SetLength(FEntryArray, LNewLength);\r\n\r\n for I := 0 to LNewLength - 1 do\r\n FBucketArray[I] := -1;\r\n\r\n for I := 0 to FCount - 1 do\r\n begin\r\n LIndex := FEntryArray[I].FHashCode mod LNewLength;\r\n FEntryArray[I].FNext := FBucketArray[LIndex];\r\n FBucketArray[LIndex] := I;\r\n end;\r\nend;\r\n\r\n{ THashSet.TEnumerator }\r\n\r\nfunction THashSet.TEnumerator.TryMoveNext(out ACurrent: T): Boolean;\r\nbegin\r\n with THashSet(Owner) do\r\n begin\r\n while FCurrentIndex < FCount do\r\n begin\r\n if FEntryArray[FCurrentIndex].FHashCode >= 0 then\r\n begin\r\n ACurrent := FEntryArray[FCurrentIndex].FKey;\r\n\r\n Inc(FCurrentIndex);\r\n Result := True;\r\n Exit;\r\n end;\r\n\r\n Inc(FCurrentIndex);\r\n end;\r\n\r\n FCurrentIndex := FCount + 1;\r\n Result := False;\r\n end;\r\nend;\r\n\r\n{ TObjectHashSet }\r\n\r\nprocedure TObjectHashSet.HandleElementRemoved(const AElement: T);\r\nbegin\r\n if FOwnsObjects then\r\n TObject(AElement).Free;\r\nend;\r\n\r\n{ TLinkedSet }\r\n\r\nprocedure TLinkedSet.Add(const AValue: T);\r\nbegin\r\n { Call insert }\r\n Insert(AValue, False);\r\nend;\r\n\r\nprocedure TLinkedSet.Clear;\r\nvar\r\n LEntry, LCurr: PEntry;\r\nbegin\r\n LEntry := FHead;\r\n\r\n while Assigned(LEntry) do\r\n begin\r\n NotifyElementRemoved(LEntry.FValue);\r\n\r\n { Next and kill }\r\n LCurr := LEntry;\r\n LEntry := LEntry^.FNext;\r\n\r\n ReleaseEntry(LCurr);\r\n end;\r\n\r\n { Clear nodes }\r\n FHead := nil;\r\n FTail := nil;\r\n\r\n { Clear array }\r\n FillChar(FBucketArray[0], Length(FBucketArray) * SizeOf(PEntry), 0);\r\n FCount := 0;\r\n\r\n NotifyCollectionChanged();\r\nend;\r\n\r\nfunction TLinkedSet.Contains(const AValue: T): Boolean;\r\nbegin\r\n Result := Assigned(FindEntry(AValue));\r\nend;\r\n\r\nprocedure TLinkedSet.CopyTo(var AArray: array of T; const AStartIndex: NativeInt);\r\nvar\r\n X: NativeInt;\r\n LEntry: PEntry;\r\nbegin\r\n { Check for indexes }\r\n if (AStartIndex >= Length(AArray)) or (AStartIndex < 0) then\r\n ExceptionHelper.Throw_ArgumentOutOfRangeError('AStartIndex');\r\n\r\n if (Length(AArray) - AStartIndex) < Count then\r\n ExceptionHelper.Throw_ArgumentOutOfSpaceError('AArray');\r\n\r\n X := AStartIndex;\r\n LEntry := FHead;\r\n\r\n while Assigned(LEntry) do\r\n begin\r\n { Copy it }\r\n AArray[X] := LEntry^.FValue;\r\n\r\n { Go to next }\r\n Inc(X);\r\n LEntry := LEntry^.FNext;\r\n end;\r\nend;\r\n\r\nconstructor TLinkedSet.Create(const ARules: TRules; const AInitialCapacity: NativeInt);\r\nbegin\r\n inherited Create(ARules);\r\n\r\n { Check for proper capacity }\r\n if AInitialCapacity <= 0 then\r\n InitializeInternals(CDefaultSize)\r\n else\r\n InitializeInternals(AInitialCapacity)\r\nend;\r\n\r\nconstructor TLinkedSet.Create;\r\nbegin\r\n Create(TRules.Default, CDefaultSize);\r\nend;\r\n\r\nconstructor TLinkedSet.Create(const ARules: TRules);\r\nbegin\r\n { Call upper constructor }\r\n Create(ARules, CDefaultSize);\r\nend;\r\n\r\ndestructor TLinkedSet.Destroy;\r\nvar\r\n LNext: PEntry;\r\nbegin\r\n { Clear first }\r\n Clear();\r\n\r\n { Clear the cached entries too }\r\n if FFreeCount > 0 then\r\n while Assigned(FFirstFree) do\r\n begin\r\n LNext := FFirstFree^.FNext;\r\n\r\n { Delphi doesn finalize this }\r\n FFirstFree^.FValue := default(T);\r\n\r\n FreeMem(FFirstFree);\r\n FFirstFree := LNext;\r\n end;\r\n\r\n inherited;\r\nend;\r\n\r\nfunction TLinkedSet.Empty: Boolean;\r\nbegin\r\n Result := (FCount = 0);\r\nend;\r\n\r\nfunction TLinkedSet.FindEntry(const AValue: T): PEntry;\r\nvar\r\n LHashCode, LCapacity: NativeInt;\r\n LEntry: PEntry;\r\nbegin\r\n { Init }\r\n Result := nil;\r\n LHashCode := Hash(AValue);\r\n LCapacity := Length(FBucketArray);\r\n LEntry := FBucketArray[LHashCode mod LCapacity];\r\n\r\n while Assigned(LEntry) and\r\n ((LEntry^.FHashCode mod LCapacity) = (LHashCode mod LCapacity)) do\r\n begin\r\n { Check the key }\r\n if ElementsAreEqual(LEntry^.FValue, AValue) then\r\n Exit(LEntry);\r\n\r\n { Go to next }\r\n LEntry := LEntry^.FNext;\r\n end;\r\nend;\r\n\r\nfunction TLinkedSet.GetCount: NativeInt;\r\nbegin\r\n Result := FCount;\r\nend;\r\n\r\nfunction TLinkedSet.GetEnumerator: IEnumerator;\r\nvar\r\n LEnumerator: TEnumerator;\r\nbegin\r\n LEnumerator := TEnumerator.Create(Self);\r\n LEnumerator.FCurrentEntry := FHead;\r\n Result := LEnumerator;\r\nend;\r\n\r\nfunction TLinkedSet.Hash(const AValue: T): NativeInt;\r\nconst\r\n PositiveMask = not NativeInt(1 shl (SizeOf(NativeInt) * 8 - 1));\r\nbegin\r\n Result := PositiveMask and ((PositiveMask and GetElementHashCode(AValue)) + 1);\r\nend;\r\n\r\nprocedure TLinkedSet.InitializeInternals(const ACapacity: NativeInt);\r\nbegin\r\n { Initialize and clear the dictionary }\r\n SetLength(FBucketArray, ACapacity);\r\n FillChar(FBucketArray[0], ACapacity * SizeOf(PEntry), 0);\r\nend;\r\n\r\nprocedure TLinkedSet.Insert(const AValue: T; const AShouldAdd: Boolean);\r\nvar\r\n LHashCode, LNewLength, LCapacity: NativeInt;\r\n LEntry, LNewEntry: PEntry;\r\nbegin\r\n { Initialize stuff }\r\n LHashCode := Hash(AValue);\r\n\r\n while True do\r\n begin\r\n LCapacity := Length(FBucketArray);\r\n LEntry := FBucketArray[LHashCode mod LCapacity];\r\n\r\n { Case 1: we have a free spot and can insert directly }\r\n if not Assigned(LEntry) then\r\n begin\r\n { Insert the entry }\r\n LNewEntry := NeedEntry(AValue, LHashCode);\r\n LNewEntry^.FPrev := FTail;\r\n LNewEntry^.FNext := nil;\r\n\r\n if Assigned(FTail) then\r\n FTail^.FNext := LNewEntry;\r\n\r\n FTail := LNewEntry;\r\n\r\n if not Assigned(FHead) then\r\n FHead := LNewEntry;\r\n\r\n FBucketArray[LHashCode mod LCapacity] := LNewEntry;\r\n\r\n NotifyCollectionChanged();\r\n Inc(FCount);\r\n\r\n Exit;\r\n end;\r\n\r\n { Case 2: The spot is filled but capacity is sufficient }\r\n if FCount < LCapacity then\r\n begin\r\n { Search for a place to insert the node into }\r\n\r\n while True do\r\n begin\r\n { Check the key }\r\n if ElementsAreEqual(LEntry^.FValue, AValue) then\r\n begin\r\n if AShouldAdd then\r\n ExceptionHelper.Throw_DuplicateKeyError('AKey');\r\n\r\n LEntry^.FValue := AValue;\r\n\r\n NotifyCollectionChanged();\r\n Exit;\r\n end;\r\n\r\n if not Assigned(LEntry^.FNext) or\r\n ((LEntry^.FNext^.FHashCode mod LCapacity) <> (LHashCode mod LCapacity)) then Break;\r\n\r\n { Go to next }\r\n LEntry := LEntry^.FNext;\r\n end;\r\n\r\n { Insert the entry }\r\n LNewEntry := NeedEntry(AValue, LHashCode);\r\n\r\n { Get our entry in }\r\n LNewEntry^.FNext := LEntry^.FNext;\r\n LNewEntry^.FPrev := LEntry;\r\n\r\n if Assigned(LEntry^.FNext) then\r\n LEntry^.FNext^.FPrev := LNewEntry;\r\n\r\n LEntry^.FNext := LNewEntry;\r\n\r\n if LEntry = FTail then\r\n FTail := LNewEntry;\r\n\r\n NotifyCollectionChanged();\r\n Inc(FCount);\r\n\r\n Exit;\r\n end;\r\n\r\n { Case 3: The spot is filled but capacity is not sufficient }\r\n if FCount >= LCapacity then\r\n begin\r\n { Reset the bucket list }\r\n LNewLength := FCount * 2;\r\n SetLength(FBucketArray, LNewLength);\r\n FillChar(FBucketArray[0], LNewLength * SizeOf(PEntry), 0);\r\n\r\n { Rehash! }\r\n LEntry := FHead;\r\n FHead := nil;\r\n FTail := nil;\r\n\r\n { Rehash the whole list using new capacity }\r\n while Assigned(LEntry) do\r\n begin\r\n LNewEntry := LEntry^.FNext;\r\n ReInsert(LEntry, LNewLength);\r\n\r\n LEntry := LNewEntry;\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TLinkedSet.NeedEntry(const AValue: T; const AHash: NativeInt): PEntry;\r\nbegin\r\n if FFreeCount > 0 then\r\n begin\r\n Result := FFirstFree;\r\n FFirstFree := FFirstFree^.FNext;\r\n\r\n Dec(FFreeCount);\r\n end else\r\n Result := AllocMem(SizeOf(TEntry));\r\n\r\n { Initialize the node }\r\n Result^.FHashCode := AHash;\r\n Result^.FValue := AValue;\r\nend;\r\n\r\nprocedure TLinkedSet.ReInsert(const AEntry: PEntry; const ACapacity: NativeInt);\r\nvar\r\n LEntry: PEntry;\r\nbegin\r\n { Initialize stuff }\r\n LEntry := FBucketArray[AEntry^.FHashCode mod ACapacity];\r\n\r\n { Case 1: we have a free spot and can insert directly }\r\n if not Assigned(LEntry) then\r\n begin\r\n AEntry^.FPrev := FTail;\r\n AEntry^.FNext := nil;\r\n\r\n if Assigned(FTail) then\r\n FTail^.FNext := AEntry;\r\n\r\n FTail := AEntry;\r\n\r\n if not Assigned(FHead) then\r\n FHead := AEntry;\r\n\r\n FBucketArray[AEntry^.FHashCode mod ACapacity] := AEntry;\r\n\r\n Exit;\r\n end;\r\n\r\n { Case 2: The spot is filled but capacity is sufficient }\r\n while True do\r\n begin\r\n { Check the key }\r\n ASSERT(not ElementsAreEqual(LEntry^.FValue, AEntry^.FValue));\r\n\r\n if not Assigned(LEntry^.FNext) or\r\n ((LEntry^.FNext^.FHashCode mod ACapacity) <> (AEntry^.FHashCode mod ACapacity)) then Break;\r\n\r\n { Go to next }\r\n LEntry := LEntry^.FNext;\r\n end;\r\n\r\n { Get our entry in }\r\n AEntry^.FNext := LEntry^.FNext;\r\n AEntry^.FPrev := LEntry;\r\n\r\n if Assigned(LEntry^.FNext) then\r\n LEntry^.FNext^.FPrev := AEntry;\r\n\r\n LEntry^.FNext := AEntry;\r\n\r\n if LEntry = FTail then\r\n FTail := AEntry;\r\nend;\r\n\r\nprocedure TLinkedSet.ReleaseEntry(const AEntry: PEntry);\r\nbegin\r\n if FFreeCount = CDefaultSize then\r\n begin\r\n { Delphi doesn finalize this }\r\n AEntry^.FValue := default(T);\r\n FreeMem(AEntry);\r\n end else begin\r\n { Place the entry into the cache }\r\n AEntry^.FNext := FFirstFree;\r\n FFirstFree := AEntry;\r\n\r\n Inc(FFreeCount);\r\n end;\r\nend;\r\n\r\nprocedure TLinkedSet.Remove(const AValue: T);\r\nvar\r\n LHashCode, LCapacity: NativeInt;\r\n LEntry: PEntry;\r\nbegin\r\n { Generate the hash code }\r\n LHashCode := Hash(AValue);\r\n LCapacity := Length(FBucketArray);\r\n LEntry := FBucketArray[LHashCode mod LCapacity];\r\n\r\n while Assigned(LEntry) and\r\n ((LEntry^.FHashCode mod LCapacity) = (LHashCode mod LCapacity)) do\r\n begin\r\n { Check the key }\r\n if ElementsAreEqual(LEntry^.FValue, AValue) then\r\n begin\r\n { Remove self from the linked list }\r\n if Assigned(LEntry^.FPrev) then\r\n LEntry^.FPrev^.FNext := LEntry^.FNext;\r\n\r\n if Assigned(LEntry^.FNext) then\r\n LEntry^.FNext^.FPrev := LEntry^.FPrev;\r\n\r\n if LEntry = FBucketArray[LHashCode mod LCapacity] then\r\n begin\r\n { This entry is the first for the given hash code. Set the next if it has same hash. }\r\n if Assigned(LEntry^.FNext) and ((LEntry^.FNext^.FHashCode mod LCapacity) = (LEntry^.FHashCode mod LCapacity)) then\r\n FBucketArray[LHashCode mod LCapacity] := LEntry^.FNext\r\n else\r\n FBucketArray[LHashCode mod LCapacity] := nil;\r\n end;\r\n\r\n if FTail = LEntry then\r\n FTail := LEntry^.FPrev;\r\n\r\n if FHead = LEntry then\r\n FHead := LEntry^.FNext;\r\n\r\n { Kill this entry }\r\n ReleaseEntry(LEntry);\r\n Dec(FCount);\r\n NotifyCollectionChanged();\r\n\r\n { All done, let's exit }\r\n Exit;\r\n end;\r\n\r\n { Go to next }\r\n LEntry := LEntry^.FNext;\r\n end;\r\nend;\r\n\r\n{ TLinkedSet.TPairEnumerator }\r\n\r\nfunction TLinkedSet.TEnumerator.TryMoveNext(out ACurrent: T): Boolean;\r\nbegin\r\n Result := Assigned(FCurrentEntry);\r\n if Result then\r\n begin\r\n ACurrent := FCurrentEntry^.FValue;\r\n FCurrentEntry := FCurrentEntry^.FNext;\r\n end;\r\nend;\r\n\r\n{ TObjectLinkedSet }\r\n\r\nprocedure TObjectLinkedSet.HandleElementRemoved(const AElement: T);\r\nbegin\r\n if FOwnsObjects then\r\n TObject(AElement).Free;\r\nend;\r\n\r\n{ TSortedSet }\r\n\r\nprocedure TSortedSet.Add(const AValue: T);\r\nbegin\r\n { Insert the value }\r\n Insert(AValue);\r\nend;\r\n\r\nprocedure TSortedSet.BalanceTreesAfterRemoval(const ANode: TNode);\r\nvar\r\n LCurrentAct: TBalanceAct;\r\n LLNode, LXNode, LSNode,\r\n LWNode, LYNode: TNode;\r\nbegin\r\n { Initialize ... }\r\n LCurrentAct := TBalanceAct.baStart;\r\n LLNode := ANode;\r\n\r\n { Continue looping until end is declared }\r\n while LCurrentAct <> TBalanceAct.baEnd do\r\n begin\r\n case LCurrentAct of\r\n\r\n { START MODE }\r\n TBalanceAct.baStart:\r\n begin\r\n if not Assigned(LLNode.FRight) then\r\n begin\r\n { Exclude myself! }\r\n if Assigned(LLNode.FLeft) then\r\n LLNode.FLeft.FParent := LLNode.FParent;\r\n\r\n { I'm root! nothing to do here }\r\n if not Assigned(LLNode.FParent) then\r\n begin\r\n FRoot := LLNode.FLeft;\r\n\r\n { DONE! }\r\n LCurrentAct := TBalanceAct.baEnd;\r\n continue;\r\n end;\r\n\r\n { ... }\r\n if LLNode = LLNode.FParent.FLeft then\r\n begin\r\n LLNode.FParent.FLeft := LLNode.FLeft;\r\n LYNode := LLNode.FParent;\r\n end else\r\n begin\r\n LLNode.FParent.FRight := LLNode.FLeft;\r\n LYNode := LLNode.FParent;\r\n\r\n { RIGHT! }\r\n LCurrentAct := TBalanceAct.baRight;\r\n continue;\r\n end;\r\n end else if not Assigned(LLNode.FRight.FLeft) then\r\n begin\r\n { Case 1, RIGHT, NO LEFT }\r\n if Assigned(LLNode.FLeft) then\r\n begin\r\n LLNode.FLeft.FParent := LLNode.FRight;\r\n LLNode.FRight.FLeft := LLNode.FLeft;\r\n end;\r\n\r\n LLNode.FRight.FBalance := LLNode.FBalance;\r\n LLNode.FRight.FParent := LLNode.FParent;\r\n\r\n if not Assigned(LLNode.FParent) then\r\n FRoot := LLNode.FRight\r\n else\r\n begin\r\n if LLNode = LLNode.FParent.FLeft then\r\n LLNode.FParent.FLeft := LLNode.FRight\r\n else\r\n LLNode.FParent.FRight := LLNode.FRight;\r\n end;\r\n\r\n LYNode := LLNode.FRight;\r\n\r\n { RIGHT! }\r\n LCurrentAct := TBalanceAct.baRight;\r\n continue;\r\n end else\r\n begin\r\n { Case 3: RIGHT+LEFT }\r\n LSNode := LLNode.FRight.FLeft;\r\n\r\n while Assigned(LSNode.FLeft) do\r\n LSNode := LSNode.FLeft;\r\n\r\n if Assigned(LLNode.FLeft) then\r\n begin\r\n LLNode.FLeft.FParent := LSNode;\r\n LSNode.FLeft := LLNode.FLeft;\r\n end;\r\n\r\n LSNode.FParent.FLeft := LSNode.FRight;\r\n\r\n if Assigned(LSNode.FRight) then\r\n LSNode.FRight.FParent := LSNode.FParent;\r\n\r\n LLNode.FRight.FParent := LSNode;\r\n LSNode.FRight := LLNode.FRight;\r\n\r\n LYNode := LSNode.FParent;\r\n\r\n LSNode.FBalance := LLNode.FBalance;\r\n LSNode.FParent := LLNode.FParent;\r\n\r\n if not Assigned(LLNode.FParent) then\r\n FRoot := LSNode\r\n else\r\n begin\r\n if LLNode = LLNode.FParent.FLeft then\r\n LLNode.FParent.FLeft := LSNode\r\n else\r\n LLNode.FParent.FRight := LSNode;\r\n end;\r\n end;\r\n\r\n { LEFT! }\r\n LCurrentAct := TBalanceAct.baLeft;\r\n continue;\r\n end; { baStart }\r\n\r\n { LEFT BALANCING MODE }\r\n TBalanceAct.baLeft:\r\n begin\r\n Inc(LYNode.FBalance);\r\n\r\n if LYNode.FBalance = 1 then\r\n begin\r\n { DONE! }\r\n LCurrentAct := TBalanceAct.baEnd;\r\n continue;\r\n end\r\n else if LYNode.FBalance = 2 then\r\n begin\r\n LXNode := LYNode.FRight;\r\n\r\n if LXNode.FBalance = -1 then\r\n begin\r\n LWNode := LXNode.FLeft;\r\n LWNode.FParent := LYNode.FParent;\r\n\r\n if not Assigned(LYNode.FParent) then\r\n FRoot := LWNode\r\n else\r\n begin\r\n if LYNode.FParent.FLeft = LYNode then\r\n LYNode.FParent.FLeft := LWNode\r\n else\r\n LYNode.FParent.FRight := LWNode;\r\n end;\r\n\r\n LXNode.FLeft := LWNode.FRight;\r\n\r\n if Assigned(LXNode.FLeft) then\r\n LXNode.FLeft.FParent := LXNode;\r\n\r\n LYNode.FRight := LWNode.FLeft;\r\n\r\n if Assigned(LYNode.FRight) then\r\n LYNode.FRight.FParent := LYNode;\r\n\r\n LWNode.FRight := LXNode;\r\n LWNode.FLeft := LYNode;\r\n\r\n LXNode.FParent := LWNode;\r\n LYNode.FParent := LWNode;\r\n\r\n if LWNode.FBalance = 1 then\r\n begin\r\n LXNode.FBalance := 0;\r\n LYNode.FBalance := -1;\r\n end else if LWNode.FBalance = 0 then\r\n begin\r\n LXNode.FBalance := 0;\r\n LYNode.FBalance := 0;\r\n end else\r\n begin\r\n LXNode.FBalance := 1;\r\n LYNode.FBalance := 0;\r\n end;\r\n\r\n LWNode.FBalance := 0;\r\n LYNode := LWNode;\r\n end else\r\n begin\r\n LXNode.FParent := LYNode.FParent;\r\n\r\n if Assigned(LYNode.FParent) then\r\n begin\r\n if LYNode.FParent.FLeft = LYNode then\r\n LYNode.FParent.FLeft := LXNode\r\n else\r\n LYNode.FParent.FRight := LXNode;\r\n end else\r\n FRoot := LXNode;\r\n\r\n LYNode.FRight := LXNode.FLeft;\r\n\r\n if Assigned(LYNode.FRight) then\r\n LYNode.FRight.FParent := LYNode;\r\n\r\n LXNode.FLeft := LYNode;\r\n LYNode.FParent := LXNode;\r\n\r\n if LXNode.FBalance = 0 then\r\n begin\r\n LXNode.FBalance := -1;\r\n LYNode.FBalance := 1;\r\n\r\n { DONE! }\r\n LCurrentAct := TBalanceAct.baEnd;\r\n continue;\r\n end else\r\n begin\r\n LXNode.FBalance := 0;\r\n LYNode.FBalance := 0;\r\n\r\n LYNode := LXNode;\r\n end;\r\n end;\r\n end;\r\n\r\n { LOOP! }\r\n LCurrentAct := TBalanceAct.baLoop;\r\n continue;\r\n end; { baLeft }\r\n\r\n { RIGHT BALANCING MODE }\r\n TBalanceAct.baRight:\r\n begin\r\n Dec(LYNode.FBalance);\r\n\r\n if LYNode.FBalance = -1 then\r\n begin\r\n { DONE! }\r\n LCurrentAct := TBalanceAct.baEnd;\r\n continue;\r\n end\r\n else if LYNode.FBalance = -2 then\r\n begin\r\n LXNode := LYNode.FLeft;\r\n\r\n if LXNode.FBalance = 1 then\r\n begin\r\n LWNode := LXNode.FRight;\r\n LWNode.FParent := LYNode.FParent;\r\n\r\n if not Assigned(LYNode.FParent) then\r\n FRoot := LWNode\r\n else\r\n begin\r\n if LYNode.FParent.FLeft = LYNode then\r\n LYNode.FParent.FLeft := LWNode\r\n else\r\n LYNode.FParent.FRight := LWNode;\r\n end;\r\n\r\n LXNode.FRight := LWNode.FLeft;\r\n\r\n if Assigned(LXNode.FRight) then\r\n LXNode.FRight.FParent := LXNode;\r\n\r\n LYNode.FLeft := LWNode.FRight;\r\n\r\n if Assigned(LYNode.FLeft) then\r\n LYNode.FLeft.FParent := LYNode;\r\n\r\n LWNode.FLeft := LXNode;\r\n LWNode.FRight := LYNode;\r\n\r\n LXNode.FParent := LWNode;\r\n LYNode.FParent := LWNode;\r\n\r\n if LWNode.FBalance = -1 then\r\n begin\r\n LXNode.FBalance := 0;\r\n LYNode.FBalance := 1;\r\n end else if LWNode.FBalance = 0 then\r\n begin\r\n LXNode.FBalance := 0;\r\n LYNode.FBalance := 0;\r\n end else\r\n begin\r\n LXNode.FBalance := -1;\r\n LYNode.FBalance := 0;\r\n end;\r\n\r\n LWNode.FBalance := 0;\r\n LYNode := LWNode;\r\n end else\r\n begin\r\n LXNode.FParent := LYNode.FParent;\r\n\r\n if Assigned(LYNode.FParent) then\r\n begin\r\n if LYNode.FParent.FLeft = LYNode then\r\n LYNode.FParent.FLeft := LXNode\r\n else\r\n LYNode.FParent.FRight := LXNode\r\n end else\r\n FRoot := LXNode;\r\n\r\n LYNode.FLeft := LXNode.FRight;\r\n\r\n if Assigned(LYNode.FLeft) then\r\n LYNode.FLeft.FParent := LYNode;\r\n\r\n LXNode.FRight := LYNode;\r\n LYNode.FParent := LXNode;\r\n\r\n if LXNode.FBalance = 0 then\r\n begin\r\n LXNode.FBalance := 1;\r\n LYNode.FBalance := -1;\r\n\r\n { END! }\r\n LCurrentAct := TBalanceAct.baEnd;\r\n continue;\r\n end else\r\n begin\r\n LXNode.FBalance := 0;\r\n LYNode.FBalance := 0;\r\n\r\n LYNode := LXNode;\r\n end;\r\n end;\r\n end;\r\n\r\n { LOOP! }\r\n LCurrentAct := TBalanceAct.baLoop;\r\n continue;\r\n end; { baRight }\r\n\r\n TBalanceAct.baLoop:\r\n begin\r\n { Verify continuation }\r\n if Assigned(LYNode.FParent) then\r\n begin\r\n if LYNode = LYNode.FParent.FLeft then\r\n begin\r\n LYNode := LYNode.FParent;\r\n\r\n { LEFT! }\r\n LCurrentAct := TBalanceAct.baLeft;\r\n continue;\r\n end;\r\n\r\n LYNode := LYNode.FParent;\r\n\r\n { RIGHT! }\r\n LCurrentAct := TBalanceAct.baRight;\r\n continue;\r\n end;\r\n\r\n { END! }\r\n LCurrentAct := TBalanceAct.baEnd;\r\n continue;\r\n end;\r\n end; { Case }\r\n end; { While }\r\nend;\r\n\r\nprocedure TSortedSet.Clear;\r\nbegin\r\n if Assigned(FRoot) then\r\n begin\r\n RecursiveClear(FRoot);\r\n FRoot := nil;\r\n\r\n { Update markers }\r\n NotifyCollectionChanged();\r\n FCount := 0;\r\n end;\r\nend;\r\n\r\nfunction TSortedSet.Contains(const AValue: T): Boolean;\r\nbegin\r\n Result := Assigned(FindNodeWithKey(AValue));\r\nend;\r\n\r\nprocedure TSortedSet.CopyTo(var AArray: array of T; const AStartIndex: NativeInt);\r\nvar\r\n X: NativeInt;\r\n LNode: TNode;\r\nbegin\r\n { Check for indexes }\r\n if (AStartIndex >= Length(AArray)) or (AStartIndex < 0) then\r\n ExceptionHelper.Throw_ArgumentOutOfRangeError('AStartIndex');\r\n\r\n if (Length(AArray) - AStartIndex) < FCount then\r\n ExceptionHelper.Throw_ArgumentOutOfSpaceError('AArray');\r\n\r\n X := AStartIndex;\r\n\r\n { Find the left-most node }\r\n LNode := FindLeftMostNode();\r\n\r\n while Assigned(LNode) do\r\n begin\r\n { Get the key }\r\n AArray[X] := LNode.FKey;\r\n\r\n { Navigate further in the tree }\r\n LNode := WalkToTheRight(LNode);\r\n\r\n { Increment the index }\r\n Inc(X);\r\n end;\r\nend;\r\n\r\nconstructor TSortedSet.Create(const ARules: TRules; const AAscending: Boolean);\r\nbegin\r\n inherited Create(ARules);\r\n\r\n if AAscending then\r\n FSignFix := 1\r\n else\r\n FSignFix := -1;\r\nend;\r\n\r\nconstructor TSortedSet.Create;\r\nbegin\r\n Create(TRules.Default, True);\r\nend;\r\n\r\nfunction TSortedSet.Empty: Boolean;\r\nbegin\r\n Result := not Assigned(FRoot);\r\nend;\r\n\r\nfunction TSortedSet.FindLeftMostNode: TNode;\r\nbegin\r\n { Start with root }\r\n Result := FRoot;\r\n\r\n { And go to maximum left }\r\n if Assigned(Result) then\r\n begin\r\n while Assigned(Result.FLeft) do\r\n Result := Result.FLeft;\r\n end;\r\nend;\r\n\r\nfunction TSortedSet.FindNodeWithKey(const AValue: T): TNode;\r\nvar\r\n LNode: TNode;\r\n LCompareResult: NativeInt;\r\nbegin\r\n { Get root }\r\n LNode := FRoot;\r\n\r\n while Assigned(LNode) do\r\n begin\r\n\t LCompareResult := CompareElements(AValue, LNode.FKey) * FSignFix;\r\n\r\n { Navigate left, right or find! }\r\n if LCompareResult < 0 then\r\n LNode := LNode.FLeft\r\n else if LCompareResult > 0 then\r\n LNode := LNode.FRight\r\n else\r\n Exit(LNode);\r\n end;\r\n\r\n { Did not find anything ... }\r\n Result := nil;\r\nend;\r\n\r\nfunction TSortedSet.FindRightMostNode: TNode;\r\nbegin\r\n { Start with root }\r\n Result := FRoot;\r\n\r\n { And go to maximum left }\r\n if Assigned(Result) then\r\n begin\r\n while Assigned(Result.FRight) do\r\n Result := Result.FRight;\r\n end;\r\nend;\r\n\r\nfunction TSortedSet.First: T;\r\nbegin\r\n { Check there are elements in the set }\r\n if not Assigned(FRoot) then\r\n ExceptionHelper.Throw_CollectionEmptyError();\r\n\r\n Result := FindLeftMostNode().FKey\r\nend;\r\n\r\nfunction TSortedSet.FirstOrDefault(const ADefault: T): T;\r\nbegin\r\n { Check there are elements in the set }\r\n if not Assigned(FRoot) then\r\n Result := ADefault\r\n else\r\n Result := FindLeftMostNode().FKey\r\nend;\r\n\r\nfunction TSortedSet.GetCount: NativeInt;\r\nbegin\r\n Result := FCount;\r\nend;\r\n\r\nfunction TSortedSet.GetEnumerator: IEnumerator;\r\nvar\r\n LEnumerator: TEnumerator;\r\nbegin\r\n LEnumerator := TEnumerator.Create(Self);\r\n LEnumerator.FCurrentEntry := FindLeftMostNode();\r\n Result := LEnumerator;\r\nend;\r\n\r\nprocedure TSortedSet.Insert(const AValue: T);\r\nvar\r\n LNode: TNode;\r\n LCompareResult: NativeInt;\r\nbegin\r\n { First one get special treatment! }\r\n if not Assigned(FRoot) then\r\n begin\r\n FRoot := MakeNode(AValue, nil);\r\n\r\n { Increase markers }\r\n Inc(FCount);\r\n NotifyCollectionChanged();\r\n\r\n { [ADDED NEW] Exit function }\r\n Exit;\r\n end;\r\n\r\n { Get root }\r\n LNode := FRoot;\r\n\r\n while true do\r\n begin\r\n\t LCompareResult := CompareElements(AValue, LNode.FKey) * FSignFix;\r\n\r\n if LCompareResult < 0 then\r\n begin\r\n if Assigned(LNode.FLeft) then\r\n LNode := LNode.FLeft\r\n else\r\n begin\r\n { Create a new node }\r\n LNode.FLeft := MakeNode(AValue, LNode);\r\n Dec(LNode.FBalance);\r\n\r\n { [ADDED NEW] Exit function! }\r\n break;\r\n end;\r\n end else if LCompareResult > 0 then\r\n begin\r\n if Assigned(LNode.FRight) then\r\n LNode := LNode.FRight\r\n else\r\n begin\r\n LNode.FRight := MakeNode(AValue, LNode);\r\n Inc(LNode.FBalance);\r\n\r\n { [ADDED NEW] Exit function! }\r\n break;\r\n end;\r\n end else\r\n begin\r\n { Found a node with the same key. }\r\n { [NOTHING] Exit function }\r\n Exit();\r\n end;\r\n end;\r\n\r\n { Rebalance the tree }\r\n ReBalanceSubTreeOnInsert(LNode);\r\n\r\n Inc(FCount);\r\n NotifyCollectionChanged();\r\nend;\r\n\r\nfunction TSortedSet.Last: T;\r\nbegin\r\n { Check there are elements in the set }\r\n if not Assigned(FRoot) then\r\n ExceptionHelper.Throw_CollectionEmptyError();\r\n\r\n Result := FindRightMostNode().FKey\r\nend;\r\n\r\nfunction TSortedSet.LastOrDefault(const ADefault: T): T;\r\nbegin\r\n { Check there are elements in the set }\r\n if not Assigned(FRoot) then\r\n Result := ADefault\r\n else\r\n Result := FindRightMostNode().FKey\r\nend;\r\n\r\nfunction TSortedSet.MakeNode(const AValue: T; const ARoot: TNode): TNode;\r\nbegin\r\n Result := TNode.Create();\r\n Result.FKey := AValue;\r\n Result.FParent := ARoot;\r\nend;\r\n\r\nfunction TSortedSet.Max: T;\r\nbegin\r\n { Check there are elements in the set }\r\n if not Assigned(FRoot) then\r\n ExceptionHelper.Throw_CollectionEmptyError();\r\n\r\n if FSignFix = 1 then\r\n Result := FindRightMostNode().FKey\r\n else\r\n Result := FindLeftMostNode().FKey;\r\nend;\r\n\r\nfunction TSortedSet.Min: T;\r\nbegin\r\n { Check there are elements in the set }\r\n if not Assigned(FRoot) then\r\n ExceptionHelper.Throw_CollectionEmptyError();\r\n\r\n if FSignFix = 1 then\r\n Result := FindLeftMostNode().FKey\r\n else\r\n Result := FindRightMostNode().FKey;\r\nend;\r\n\r\nprocedure TSortedSet.ReBalanceSubTreeOnInsert(const ANode: TNode);\r\nvar\r\n LLNode, LXNode, LWNode: TNode;\r\nbegin\r\n LLNode := ANode;\r\n\r\n { Re-balancing the tree! }\r\n while (LLNode.FBalance <> 0) and Assigned(LLNode.FParent) do\r\n begin\r\n if (LLNode.FParent.FLeft = LLNode) then\r\n Dec(LLNode.FParent.FBalance)\r\n else\r\n Inc(LLNode.FParent.FBalance);\r\n\r\n { Move up }\r\n LLNode := LLNode.FParent;\r\n\r\n if (LLNode.FBalance = -2) then\r\n begin\r\n LXNode := LLNode.FLeft;\r\n\r\n if (LXNode.FBalance = -1) then\r\n begin\r\n LXNode.FParent := LLNode.FParent;\r\n\r\n if not Assigned(LLNode.FParent) then\r\n FRoot := LXNode\r\n else\r\n begin\r\n if (LLNode.FParent.FLeft = LLNode) then\r\n LLNode.FParent.FLeft := LXNode\r\n else\r\n LLNode.FParent.FRight := LXNode;\r\n end;\r\n\r\n LLNode.FLeft := LXNode.FRight;\r\n\r\n if Assigned(LLNode.FLeft) then\r\n LLNode.FLeft.FParent := LLNode;\r\n\r\n LXNode.FRight := LLNode;\r\n LLNode.FParent := LXNode;\r\n\r\n LXNode.FBalance := 0;\r\n LLNode.FBalance := 0;\r\n end else\r\n begin\r\n LWNode := LXNode.FRight;\r\n LWNode.FParent := LLNode.FParent;\r\n\r\n if not Assigned(LLNode.FParent) then\r\n FRoot := LWNode\r\n else\r\n begin\r\n if LLNode.FParent.FLeft = LLNode then\r\n LLNode.FParent.FLeft := LWNode\r\n else\r\n LLNode.FParent.FRight := LWNode;\r\n end;\r\n\r\n LXNode.FRight := LWNode.FLeft;\r\n\r\n if Assigned(LXNode.FRight) then\r\n LXNode.FRight.FParent := LXNode;\r\n\r\n LLNode.FLeft := LWNode.FRight;\r\n\r\n if Assigned(LLNode.FLeft) then\r\n LLNode.FLeft.FParent := LLNode;\r\n\r\n LWNode.FLeft := LXNode;\r\n LWNode.FRight := LLNode;\r\n\r\n LXNode.FParent := LWNode;\r\n LLNode.FParent := LWNode;\r\n\r\n { Apply proper balancing }\r\n if LWNode.FBalance = -1 then\r\n begin\r\n LXNode.FBalance := 0;\r\n LLNode.FBalance := 1;\r\n end else if LWNode.FBalance = 0 then\r\n begin\r\n LXNode.FBalance := 0;\r\n LLNode.FBalance := 0;\r\n end else\r\n begin\r\n LXNode.FBalance := -1;\r\n LLNode.FBalance := 0;\r\n end;\r\n\r\n LWNode.FBalance := 0;\r\n end;\r\n\r\n break;\r\n end else if LLNode.FBalance = 2 then\r\n begin\r\n LXNode := LLNode.FRight;\r\n\r\n if LXNode.FBalance = 1 then\r\n begin\r\n LXNode.FParent := LLNode.FParent;\r\n\r\n if not Assigned(LLNode.FParent) then\r\n FRoot := LXNode\r\n else\r\n begin\r\n if LLNode.FParent.FLeft = LLNode then\r\n LLNode.FParent.FLeft := LXNode\r\n else\r\n LLNode.FParent.FRight := LXNode;\r\n end;\r\n\r\n LLNode.FRight := LXNode.FLeft;\r\n\r\n if Assigned(LLNode.FRight) then\r\n LLNode.FRight.FParent := LLNode;\r\n\r\n LXNode.FLeft := LLNode;\r\n LLNode.FParent := LXNode;\r\n\r\n LXNode.FBalance := 0;\r\n LLNode.FBalance := 0;\r\n end else\r\n begin\r\n LWNode := LXNode.FLeft;\r\n LWNode.FParent := LLNode.FParent;\r\n\r\n if not Assigned(LLNode.FParent) then\r\n FRoot := LWNode\r\n else\r\n begin\r\n if LLNode.FParent.FLeft = LLNode then\r\n LLNode.FParent.FLeft := LWNode\r\n else\r\n LLNode.FParent.FRight := LWNode;\r\n end;\r\n\r\n LXNode.FLeft := LWNode.FRight;\r\n\r\n if Assigned(LXNode.FLeft) then\r\n LXNode.FLeft.FParent := LXNode;\r\n\r\n LLNode.FRight := LWNode.FLeft;\r\n\r\n if Assigned(LLNode.FRight) then\r\n LLNode.FRight.FParent := LLNode;\r\n\r\n LWNode.FRight := LXNode;\r\n LWNode.FLeft := LLNode;\r\n\r\n LXNode.FParent := LWNode;\r\n LLNode.FParent := LWNode;\r\n\r\n if LWNode.FBalance = 1 then\r\n begin\r\n LXNode.FBalance := 0;\r\n LLNode.FBalance := -1;\r\n end else if LWNode.FBalance = 0 then\r\n begin\r\n LXNode.FBalance := 0;\r\n LLNode.FBalance := 0;\r\n end else\r\n begin\r\n LXNode.FBalance := 1;\r\n LLNode.FBalance := 0;\r\n end;\r\n\r\n LWNode.FBalance := 0;\r\n end;\r\n\r\n break;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TSortedSet.Remove(const AValue: T);\r\nvar\r\n LNode: TNode;\r\nbegin\r\n { Get root }\r\n LNode := FindNodeWithKey(AValue);\r\n\r\n { Remove and rebalance the tree accordingly }\r\n if not Assigned(LNode) then\r\n Exit;\r\n\r\n { .. Do da dew! }\r\n BalanceTreesAfterRemoval(LNode);\r\n\r\n { Kill the node }\r\n LNode.Free;\r\n\r\n Dec(FCount);\r\n NotifyCollectionChanged();\r\nend;\r\n\r\nfunction TSortedSet.Single: T;\r\nbegin\r\n { Check there are elements in the set }\r\n if not Assigned(FRoot) then\r\n ExceptionHelper.Throw_CollectionEmptyError();\r\n\r\n { Check for more than one }\r\n if Assigned(FRoot.FLeft) or Assigned(FRoot.FRight) then\r\n ExceptionHelper.Throw_CollectionHasMoreThanOneElement();\r\n\r\n Result := FRoot.FKey;\r\nend;\r\n\r\nfunction TSortedSet.SingleOrDefault(const ADefault: T): T;\r\nbegin\r\n { Check there are elements in the set }\r\n if not Assigned(FRoot) then\r\n Exit(ADefault);\r\n\r\n { Check for more than one }\r\n if Assigned(FRoot.FLeft) or Assigned(FRoot.FRight) then\r\n ExceptionHelper.Throw_CollectionHasMoreThanOneElement();\r\n\r\n Result := FRoot.FKey;\r\nend;\r\n\r\nprocedure TSortedSet.RecursiveClear(const ANode: TNode);\r\nbegin\r\n if Assigned(ANode.FLeft)then\r\n RecursiveClear(ANode.FLeft);\r\n\r\n if Assigned(ANode.FRight) then\r\n RecursiveClear(ANode.FRight);\r\n\r\n { Cleanup for Key/Value }\r\n NotifyElementRemoved(ANode.FKey);\r\n\r\n { Finally, free the node itself }\r\n ANode.Free;\r\nend;\r\n\r\nfunction TSortedSet.WalkToTheRight(const ANode: TNode): TNode;\r\nbegin\r\n Result := ANode;\r\n\r\n if not Assigned(Result) then\r\n Exit;\r\n\r\n { Navigate further in the tree }\r\n if not Assigned(Result.FRight) then\r\n begin\r\n while (Assigned(Result.FParent) and (Result = Result.FParent.FRight)) do\r\n Result := Result.FParent;\r\n\r\n Result := Result.FParent;\r\n end else\r\n begin\r\n Result := Result.FRight;\r\n\r\n while Assigned(Result.FLeft) do\r\n Result := Result.FLeft;\r\n end;\r\nend;\r\n\r\nconstructor TSortedSet.Create(const ARules: TRules);\r\nbegin\r\n Create(ARules, True);\r\nend;\r\n\r\n{ TSortedSet.TEnumerator }\r\n\r\nfunction TSortedSet.TEnumerator.TryMoveNext(out ACurrent: T): Boolean;\r\nbegin\r\n Result := Assigned(FCurrentEntry);\r\n\r\n if Result then\r\n begin\r\n ACurrent := FCurrentEntry.FKey;\r\n FCurrentEntry := TSortedSet(Owner).WalkToTheRight(FCurrentEntry);\r\n end;\r\nend;\r\n\r\n{ TObjectSortedSet }\r\n\r\nprocedure TObjectSortedSet.HandleElementRemoved(const AElement: T);\r\nbegin\r\n if FOwnsObjects then\r\n TObject(AElement).Free;\r\nend;\r\n\r\n{ TArraySet }\r\n\r\nprocedure TArraySet.Add(const AValue: T);\r\nvar\r\n LLeft, LRight, LMiddle, I: NativeInt;\r\n LCompareResult: NativeInt;\r\nbegin\r\n { Case 1, empty list, optimize }\r\n if FCount > 0 then\r\n begin\r\n { Check for valid type support }\r\n LLeft := 0;\r\n LRight := LLeft + FCount - 1;\r\n\r\n while (LLeft <= LRight) do\r\n begin\r\n LMiddle := (LLeft + LRight) div 2;\r\n LCompareResult := CompareElements(FArray[LMiddle], AValue) * FSignFix;\r\n\r\n if LCompareResult > 0 then\r\n LRight := LMiddle - 1\r\n else if LCompareResult < 0 then\r\n LLeft := LMiddle + 1\r\n else\r\n Exit; { Element already contained in the array, exit }\r\n end;\r\n\r\n if LCompareResult < 0 then\r\n Inc(LMiddle);\r\n end else\r\n LMiddle := 0;\r\n\r\n if FCount = Length(FArray) then\r\n Grow();\r\n\r\n { Move the array to the right }\r\n if LMiddle < FCount then\r\n for I := FCount downto (LMiddle + 1) do\r\n FArray[I] := FArray[I - 1];\r\n\r\n { Put the element into the new position }\r\n FArray[LMiddle] := AValue;\r\n\r\n NotifyCollectionChanged();\r\n Inc(FCount);\r\nend;\r\n\r\nfunction TArraySet.Aggregate(const AAggregator: TFunc): T;\r\nvar\r\n I: NativeInt;\r\nbegin\r\n { Check arguments }\r\n if not Assigned(AAggregator) then\r\n ExceptionHelper.Throw_ArgumentNilError('AAggregator');\r\n\r\n if FCount = 0 then\r\n ExceptionHelper.Throw_CollectionEmptyError();\r\n\r\n { Select the first element as comparison base }\r\n Result := FArray[0];\r\n\r\n { Iterate over the last N - 1 elements }\r\n for I := 1 to FCount - 1 do\r\n begin\r\n { Aggregate a value }\r\n Result := AAggregator(Result, FArray[I]);\r\n end;\r\nend;\r\n\r\nfunction TArraySet.AggregateOrDefault(const AAggregator: TFunc; const ADefault: T): T;\r\nvar\r\n I: NativeInt;\r\nbegin\r\n { Check arguments }\r\n if not Assigned(AAggregator) then\r\n ExceptionHelper.Throw_ArgumentNilError('AAggregator');\r\n\r\n if FCount = 0 then\r\n Exit(ADefault);\r\n\r\n { Select the first element as comparison base }\r\n Result := FArray[0];\r\n\r\n { Iterate over the last N - 1 elements }\r\n for I := 1 to FCount - 1 do\r\n begin\r\n { Aggregate a value }\r\n Result := AAggregator(Result, FArray[I]);\r\n end;\r\nend;\r\n\r\nfunction TArraySet.All(const APredicate: TPredicate): Boolean;\r\nvar\r\n I: NativeInt;\r\nbegin\r\n if not Assigned(APredicate) then\r\n ExceptionHelper.Throw_ArgumentNilError('APredicate');\r\n\r\n if FCount > 0 then\r\n for I := 0 to FCount - 1 do\r\n if not APredicate(FArray[I]) then\r\n Exit(false);\r\n\r\n Result := true;\r\nend;\r\n\r\nfunction TArraySet.Any(const APredicate: TPredicate): Boolean;\r\nvar\r\n I: NativeInt;\r\nbegin\r\n if not Assigned(APredicate) then\r\n ExceptionHelper.Throw_ArgumentNilError('APredicate');\r\n\r\n if FCount > 0 then\r\n for I := 0 to FCount - 1 do\r\n if APredicate(FArray[I]) then\r\n Exit(true);\r\n\r\n Result := false;\r\nend;\r\n\r\nfunction TArraySet.BinarySearch(const AElement: T): NativeInt;\r\nvar\r\n LLeft, LRight, LMiddle: NativeInt;\r\n LCompareResult: NativeInt;\r\nbegin\r\n Result := -1;\r\n\r\n { Optimized cases }\r\n if FCount = 0 then\r\n Exit;\r\n\r\n if (FCount = 1) and (CompareElements(FArray[0], AElement) = 0) then\r\n Exit(0);\r\n\r\n { The actual binary search }\r\n\r\n LLeft := 0;\r\n LRight := LLeft + FCount - 1;\r\n\r\n while (LLeft <= LRight) do\r\n begin\r\n LMiddle := (LLeft + LRight) div 2;\r\n LCompareResult := CompareElements(FArray[LMiddle], AElement) * FSignFix;\r\n\r\n if LCompareResult > 0 then\r\n LRight := LMiddle - 1\r\n else if LCompareResult < 0 then\r\n LLeft := LMiddle + 1\r\n else begin\r\n Result := LMiddle;\r\n Exit;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TArraySet.Clear;\r\nvar\r\n I: NativeInt;\r\nbegin\r\n { Reset the length }\r\n if FCount > 0 then\r\n begin\r\n for I := 0 to FCount - 1 do\r\n NotifyElementRemoved(FArray[I]);\r\n\r\n NotifyCollectionChanged();\r\n FCount := 0;\r\n end;\r\nend;\r\n\r\nfunction TArraySet.Contains(const AValue: T): Boolean;\r\nbegin\r\n Result := BinarySearch(AValue) > -1;\r\nend;\r\n\r\nprocedure TArraySet.CopyTo(var AArray: array of T; const AStartIndex: NativeInt);\r\nvar\r\n I: NativeInt;\r\nbegin\r\n if (AStartIndex >= Length(AArray)) or (AStartIndex < 0) then\r\n ExceptionHelper.Throw_ArgumentOutOfRangeError('AStartIndex');\r\n\r\n { Check for indexes }\r\n if (Length(AArray) - AStartIndex) < FCount then\r\n ExceptionHelper.Throw_ArgumentOutOfSpaceError('AArray');\r\n\r\n { Copy all elements safely }\r\n for I := 0 to FCount - 1 do\r\n AArray[AStartIndex + I] := FArray[I];\r\nend;\r\n\r\nconstructor TArraySet.Create(const ARules: TRules);\r\nbegin\r\n Create(ARules, CDefaultSize, True);\r\nend;\r\n\r\nconstructor TArraySet.Create(const ARules: TRules; const AInitialCapacity: NativeInt; const AAscending: Boolean);\r\nbegin\r\n inherited Create(ARules);\r\n\r\n if AAscending then\r\n FSignFix := 1\r\n else\r\n FSignFix := -1;\r\n\r\n if AInitialCapacity <= 0 then\r\n SetLength(FArray, 0)\r\n else\r\n SetLength(FArray, AInitialCapacity);\r\nend;\r\n\r\nconstructor TArraySet.Create;\r\nbegin\r\n Create(TRules.Default, CDefaultSize, True);\r\nend;\r\n\r\nfunction TArraySet.ElementAt(const AIndex: NativeInt): T;\r\nbegin\r\n { Simply use the getter }\r\n if (AIndex >= FCount) or (AIndex < 0) then\r\n ExceptionHelper.Throw_ArgumentOutOfRangeError('AIndex');\r\n\r\n Result := FArray[AIndex];\r\nend;\r\n\r\nfunction TArraySet.ElementAtOrDefault(const AIndex: NativeInt; const ADefault: T): T;\r\nbegin\r\n if AIndex < 0 then\r\n ExceptionHelper.Throw_ArgumentOutOfRangeError('AIndex');\r\n\r\n if AIndex >= FCount then\r\n Result := ADefault\r\n else\r\n Result := FArray[AIndex];\r\nend;\r\n\r\nfunction TArraySet.Empty: Boolean;\r\nbegin\r\n Result := FCount = 0;\r\nend;\r\n\r\nfunction TArraySet.EqualsTo(const ACollection: IEnumerable): Boolean;\r\nvar\r\n LValue: T;\r\n I: NativeInt;\r\nbegin\r\n I := 0;\r\n\r\n for LValue in ACollection do\r\n begin\r\n if I >= FCount then\r\n Exit(false);\r\n\r\n if not ElementsAreEqual(FArray[I], LValue) then\r\n Exit(false);\r\n\r\n Inc(I);\r\n end;\r\n\r\n if I < FCount then\r\n Exit(false);\r\n\r\n Result := true;\r\nend;\r\n\r\nfunction TArraySet.First: T;\r\nbegin\r\n { Check length }\r\n if FCount = 0 then\r\n ExceptionHelper.Throw_CollectionEmptyError();\r\n\r\n Result := FArray[0];\r\nend;\r\n\r\nfunction TArraySet.FirstOrDefault(const ADefault: T): T;\r\nbegin\r\n { Check length }\r\n if FCount = 0 then\r\n Result := ADefault\r\n else\r\n Result := FArray[0];\r\nend;\r\n\r\nfunction TArraySet.GetCapacity: NativeInt;\r\nbegin\r\n Result := Length(FArray);\r\nend;\r\n\r\nfunction TArraySet.GetCount: NativeInt;\r\nbegin\r\n Result := FCount;\r\nend;\r\n\r\nfunction TArraySet.GetEnumerator: IEnumerator;\r\nbegin\r\n { Create an enumerator }\r\n Result := TEnumerator.Create(Self);\r\nend;\r\n\r\nprocedure TArraySet.Grow;\r\nbegin\r\n { Grow the array }\r\n if FCount < CDefaultSize then\r\n SetLength(FArray, FCount + CDefaultSize)\r\n else\r\n SetLength(FArray, FCount * 2);\r\nend;\r\n\r\nfunction TArraySet.Last: T;\r\nbegin\r\n { Check length }\r\n if FCount = 0 then\r\n ExceptionHelper.Throw_CollectionEmptyError();\r\n\r\n Result := FArray[FCount - 1];\r\nend;\r\n\r\nfunction TArraySet.LastOrDefault(const ADefault: T): T;\r\nbegin\r\n { Check length }\r\n if FCount = 0 then\r\n Result := ADefault\r\n else\r\n Result := FArray[FCount - 1];\r\nend;\r\n\r\nfunction TArraySet.Max: T;\r\nvar\r\n I: NativeInt;\r\nbegin\r\n { Check length }\r\n if FCount = 0 then\r\n ExceptionHelper.Throw_CollectionEmptyError();\r\n\r\n { Optimized get }\r\n if FSignFix = 1 then\r\n Result := FArray[FCount - 1]\r\n else\r\n Result := FArray[0];\r\nend;\r\n\r\nfunction TArraySet.Min: T;\r\nvar\r\n I: NativeInt;\r\nbegin\r\n { Check length }\r\n if FCount = 0 then\r\n ExceptionHelper.Throw_CollectionEmptyError();\r\n\r\n { Optimized get }\r\n if FSignFix = 1 then\r\n Result := FArray[0]\r\n else\r\n Result := FArray[FCount - 1];\r\nend;\r\n\r\nprocedure TArraySet.Remove(const AValue: T);\r\nvar\r\n I, LFoundIndex: NativeInt;\r\nbegin\r\n { Defaults }\r\n LFoundIndex := BinarySearch(AValue);\r\n if LFoundIndex > -1 then\r\n begin\r\n { Move the list }\r\n for I := LFoundIndex to FCount - 2 do\r\n FArray[I] := FArray[I + 1];\r\n\r\n Dec(FCount);\r\n NotifyCollectionChanged();\r\n end;\r\nend;\r\n\r\nprocedure TArraySet.Shrink;\r\nbegin\r\n { Cut the capacity if required }\r\n if FCount < Capacity then\r\n SetLength(FArray, FCount);\r\nend;\r\n\r\nfunction TArraySet.Single: T;\r\nbegin\r\n { Check length }\r\n if FCount = 0 then\r\n ExceptionHelper.Throw_CollectionEmptyError()\r\n else if FCount > 1 then\r\n ExceptionHelper.Throw_CollectionHasMoreThanOneElement()\r\n else\r\n Result := FArray[0];\r\nend;\r\n\r\nfunction TArraySet.SingleOrDefault(const ADefault: T): T;\r\nbegin\r\n { Check length }\r\n if FCount = 0 then\r\n Result := ADefault\r\n else if FCount > 1 then\r\n ExceptionHelper.Throw_CollectionHasMoreThanOneElement()\r\n else\r\n Result := FArray[0];\r\nend;\r\n\r\n{ TArraySet.TEnumerator }\r\n\r\nfunction TArraySet.TEnumerator.TryMoveNext(out ACurrent: T): Boolean;\r\nbegin\r\n with TArraySet(Owner) do\r\n begin\r\n Result := FCurrentIndex < FCount;\r\n\r\n if Result then\r\n begin\r\n ACurrent := FArray[FCurrentIndex];\r\n Inc(FCurrentIndex);\r\n end;\r\n end;\r\nend;\r\n\r\n{ TObjectArraySet }\r\n\r\nprocedure TObjectArraySet.HandleElementRemoved(const AElement: T);\r\nbegin\r\n if FOwnsObjects then\r\n TObject(AElement).Free;\r\nend;\r\n\r\n{$IF CompilerVersion > 21}\r\n\r\n{ TBitSet }\r\n\r\nprocedure TBitSet.Add(const AValue: Word);\r\nvar\r\n LPage, LBit, LMask: NativeInt;\r\n LOldLength: NativeInt;\r\nbegin\r\n { Caculate the position of the bit }\r\n LPage := AValue div (CPageSize * 8);\r\n LBit := AValue mod (CPageSize * 8);\r\n LMask := 1 shl LBit;\r\n\r\n { Check if the page is mapped }\r\n LOldLength := Length(FBitArray);\r\n if LPage >= LOldLength then\r\n begin\r\n { We need to extend the bit array to the given page }\r\n SetLength(FBitArray, LPage + 1);\r\n\r\n { Fill the new part of the array with zeroes }\r\n FillChar(FBitArray[LOldLength],\r\n CPageSize * (Length(FBitArray) - LOldLength), 0);\r\n end else\r\n begin\r\n { Verify if the bit was already set, and do nothing if so }\r\n if (FBitArray[LPage] and LMask) = LMask then\r\n Exit;\r\n end;\r\n\r\n { Now, set the bit }\r\n FBitArray[LPage] := FBitArray[LPage] or LMask;\r\n\r\n { Update internals }\r\n Inc(FCount);\r\n NotifyCollectionChanged();\r\nend;\r\n\r\nprocedure TBitSet.Clear;\r\nvar\r\n LPage, LBit, LCurrent: NativeInt;\r\n LChanged: Boolean;\r\nbegin\r\n LChanged := False;\r\n for LPage := 0 to Length(FBitArray) - 1 do\r\n begin\r\n LCurrent := FBitArray[LPage];\r\n if LCurrent <> 0 then\r\n begin\r\n { Only process elements on the pages that have them }\r\n for LBit := 0 to (CPageSize * 8) - 1 do\r\n if (LCurrent and (1 shl LBit)) <> 0 then\r\n NotifyElementRemoved(LBit + LPage * CPageSize * 8);\r\n\r\n LChanged := True;\r\n end;\r\n end;\r\n\r\n if LChanged then\r\n NotifyCollectionChanged();\r\n\r\n { Kill array }\r\n SetLength(FBitArray, 0);\r\nend;\r\n\r\nfunction TBitSet.Contains(const AValue: Word): Boolean;\r\nvar\r\n LPage, LBit, LMask: NativeInt;\r\nbegin\r\n { Caculate the position of the bit }\r\n LPage := AValue div (CPageSize * 8);\r\n LBit := AValue mod (CPageSize * 8);\r\n\r\n { Check if the page is mapped }\r\n if LPage >= Length(FBitArray) then\r\n Exit(False);\r\n\r\n { The page is mapped, let's check the bit }\r\n LMask := 1 shl LBit;\r\n Result := (FBitArray[LPage] and LMask) = LMask;\r\nend;\r\n\r\nprocedure TBitSet.CopyTo(var AArray: array of Word; const AStartIndex: NativeInt);\r\nvar\r\n LPage, LBit, LCurrent, X: NativeInt;\r\nbegin\r\n if (AStartIndex >= Length(AArray)) or (AStartIndex < 0) then\r\n ExceptionHelper.Throw_ArgumentOutOfRangeError('AStartIndex');\r\n\r\n { Check for indexes }\r\n if (Length(AArray) - AStartIndex) < FCount then\r\n ExceptionHelper.Throw_ArgumentOutOfSpaceError('AArray');\r\n\r\n { Copy elements }\r\n X := AStartIndex;\r\n for LPage := 0 to Length(FBitArray) - 1 do\r\n begin\r\n LCurrent := FBitArray[LPage];\r\n\r\n if LCurrent <> 0 then\r\n begin\r\n { Only process elements on the pages that have them }\r\n for LBit := 0 to (CPageSize * 8) - 1 do\r\n if (LCurrent and (1 shl LBit)) <> 0 then\r\n begin\r\n AArray[X] := (LBit + LPage * CPageSize * 8);\r\n Inc(X);\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\nconstructor TBitSet.Create(const ARules: TRules);\r\nbegin\r\n Create(True);\r\nend;\r\n\r\nconstructor TBitSet.Create();\r\nbegin\r\n Create(True);\r\nend;\r\n\r\nconstructor TBitSet.Create(const AAscending: Boolean);\r\nbegin\r\n inherited Create(TRules.Default);\r\n FAscending := AAscending;\r\nend;\r\n\r\nfunction TBitSet.Empty: Boolean;\r\nbegin\r\n Result := FCount = 0;\r\nend;\r\n\r\nfunction TBitSet.First: Word;\r\nbegin\r\n if FCount = 0 then\r\n ExceptionHelper.Throw_CollectionEmptyError();\r\n\r\n Result := FirstOrDefault(0);\r\nend;\r\n\r\nfunction TBitSet.FirstOrDefault(const ADefault: Word): Word;\r\nvar\r\n LPage, LBit, LCurrent: NativeInt;\r\nbegin\r\n for LPage := 0 to Length(FBitArray) - 1 do\r\n begin\r\n LCurrent := FBitArray[LPage];\r\n if LCurrent <> 0 then\r\n begin\r\n { Only process elements on the pages that have them }\r\n for LBit := 0 to (CPageSize * 8) - 1 do\r\n if (LCurrent and (1 shl LBit)) <> 0 then\r\n Exit(LBit + LPage * CPageSize * 8);\r\n end;\r\n end;\r\n\r\n Result := ADefault;\r\nend;\r\n\r\nfunction TBitSet.GetCount: NativeInt;\r\nbegin\r\n Result := FCount;\r\nend;\r\n\r\nfunction TBitSet.GetEnumerator: IEnumerator;\r\nvar\r\n LEnumerator: TAscendingEnumerator;\r\nbegin\r\n if FAscending then\r\n begin\r\n LEnumerator := TAscendingEnumerator.Create(Self);\r\n LEnumerator.FPageIndex := -1;\r\n end else begin\r\n LEnumerator := TDescendingEnumerator.Create(Self);\r\n LEnumerator.FPageIndex := Length(FBitArray);\r\n end;\r\n\r\n Result := LEnumerator;\r\nend;\r\n\r\nfunction TBitSet.Last: Word;\r\nbegin\r\n if FCount = 0 then\r\n ExceptionHelper.Throw_CollectionEmptyError();\r\n\r\n Result := LastOrDefault(0);\r\nend;\r\n\r\nfunction TBitSet.LastOrDefault(const ADefault: Word): Word;\r\nvar\r\n LPage, LBit, LCurrent: NativeInt;\r\nbegin\r\n for LPage := Length(FBitArray) - 1 downto 0 do\r\n begin\r\n LCurrent := FBitArray[LPage];\r\n if LCurrent <> 0 then\r\n begin\r\n { Only process elements on the pages that have them }\r\n for LBit := (CPageSize * 8) - 1 downto 0 do\r\n if (LCurrent and (1 shl LBit)) <> 0 then\r\n Exit(LBit + LPage * CPageSize * 8);\r\n end;\r\n end;\r\n\r\n Result := ADefault;\r\nend;\r\n\r\nfunction TBitSet.Max: Word;\r\nbegin\r\n if FAscending then\r\n Result := Last()\r\n else\r\n Result := First();\r\nend;\r\n\r\nfunction TBitSet.Min: Word;\r\nbegin\r\n if FAscending then\r\n Result := First()\r\n else\r\n Result := Last();\r\nend;\r\n\r\nprocedure TBitSet.Remove(const AValue: Word);\r\nvar\r\n LPage, LBit, LMask: NativeInt;\r\nbegin\r\n { Caculate the position of the bit }\r\n LPage := AValue div (CPageSize * 8);\r\n LBit := AValue mod (CPageSize * 8);\r\n\r\n { Check if the page is mapped. If the page is not mapped then the element\r\n is surely not there. }\r\n if LPage >= Length(FBitArray) then\r\n Exit;\r\n\r\n LMask := 1 shl LBit;\r\n\r\n { Verify if the bit was already set, and do nothing if so }\r\n if (FBitArray[LPage] and LMask) = LMask then\r\n Exit;\r\n\r\n { The page is mapped, let's check the bit }\r\n FBitArray[LPage] := FBitArray[LPage] and not LMask;\r\n\r\n { Update internals }\r\n Dec(FCount);\r\n NotifyCollectionChanged();\r\nend;\r\n\r\nfunction TBitSet.Single: Word;\r\nbegin\r\n { Check length }\r\n if FCount = 0 then\r\n ExceptionHelper.Throw_CollectionEmptyError()\r\n else if FCount > 1 then\r\n ExceptionHelper.Throw_CollectionHasMoreThanOneElement();\r\n\r\n Result := First();\r\nend;\r\n\r\nfunction TBitSet.SingleOrDefault(const ADefault: Word): Word;\r\nbegin\r\n { Check length }\r\n if FCount > 1 then\r\n ExceptionHelper.Throw_CollectionHasMoreThanOneElement();\r\n\r\n if FCount = 0 then\r\n Result := ADefault\r\n else\r\n Result := First();\r\nend;\r\n\r\n{ TBitSet.TEnumerator }\r\n\r\nfunction TBitSet.TAscendingEnumerator.TryMoveNext(out ACurrent: Word): Boolean;\r\nbegin\r\n Result := false;\r\n\r\n while True do\r\n begin\r\n if FPage = 0 then\r\n begin\r\n { Move to the next page, check if it exists, otherwise we're finished }\r\n Inc(FPageIndex);\r\n if FPageIndex >= Length(TBitSet(Owner).FBitArray) then\r\n Break;\r\n\r\n { Reset all the data }\r\n FBitIndex := 0;\r\n FPage := TBitSet(Owner).FBitArray[FPageIndex];\r\n end;\r\n\r\n if (FPage and 1) = 1 then\r\n begin\r\n { The value is set }\r\n ACurrent := FBitIndex + FPageIndex * CPageSize * 8;\r\n Result := True;\r\n end;\r\n\r\n Inc(FBitIndex);\r\n FPage := FPage shr 1;\r\n\r\n if Result then\r\n Break;\r\n end;\r\nend;\r\n\r\n{ TBitSet.TDescendingEnumerator }\r\n\r\nfunction TBitSet.TDescendingEnumerator.TryMoveNext(out ACurrent: Word): Boolean;\r\nconst\r\n CMask: NativeInt = NativeInt(1) shl ((CPageSize * 8) - 1);\r\nbegin\r\n Result := false;\r\n while True do\r\n begin\r\n if FPage = 0 then\r\n begin\r\n { Move to the next page, check if it exists, otherwise we're finished }\r\n Dec(FPageIndex);\r\n if FPageIndex < 0 then\r\n Break;\r\n\r\n { Reset all the data }\r\n FBitIndex := (CPageSize * 8) - 1;\r\n FPage := TBitSet(Owner).FBitArray[FPageIndex];\r\n end;\r\n\r\n if (FPage and CMask) = CMask then\r\n begin\r\n { The value is set }\r\n FValue := FBitIndex + FPageIndex * CPageSize * 8;\r\n Result := True;\r\n end;\r\n\r\n Dec(FBitIndex);\r\n FPage := FPage shl 1;\r\n\r\n if Result then\r\n Break;\r\n end;\r\nend;\r\n{$IFEND}\r\n\r\nend.\r\n\r\n" }, { "path": "Collections/Collections.Stacks.pas", "content": "(*\r\n* Copyright (c) 2008-2012, Ciobanu Alexandru\r\n* All rights reserved.\r\n*\r\n* Redistribution and use in source and binary forms, with or without\r\n* modification, are permitted provided that the following conditions are met:\r\n* * Redistributions of source code must retain the above copyright\r\n* notice, this list of conditions and the following disclaimer.\r\n* * Redistributions in binary form must reproduce the above copyright\r\n* notice, this list of conditions and the following disclaimer in the\r\n* documentation and/or other materials provided with the distribution.\r\n* * Neither the name of the nor the\r\n* names of its contributors may be used to endorse or promote products\r\n* derived from this software without specific prior written permission.\r\n*\r\n* THIS SOFTWARE IS PROVIDED BY THE AUTHOR ''AS IS'' AND ANY\r\n* EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED\r\n* WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE\r\n* DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY\r\n* DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES\r\n* (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;\r\n* LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND\r\n* ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT\r\n* (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS\r\n* SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.\r\n*)\r\n\r\nunit Collections.Stacks;\r\ninterface\r\nuses SysUtils,\r\n Generics.Defaults,\r\n Generics.Collections,\r\n Collections.Lists,\r\n Collections.Base;\r\n\r\ntype\r\n /// The abstract base class for all generic stack (LIFO) collection.\r\n /// Descending classes must implement the required abstract methods and optionally can implement\r\n /// the non-required method.\r\n TAbstractStack = class abstract(TCollection, IStack)\r\n public\r\n /// Creates a new stack collection.\r\n /// A rule set describing the elements in the set.\r\n constructor Create(const ARules: TRules);\r\n\r\n /// Destroys this instance.\r\n /// Do not call this method directly; call Free instead.\r\n destructor Destroy(); override;\r\n\r\n /// Pushes an element to the top of the stack.\r\n /// The value to push.\r\n /// The implementation in this class always raises an exception. This implementation calls Add method.\r\n /// If Add method is not overridden.\r\n procedure Push(const AValue: T); virtual;\r\n\r\n /// Retrieves the element from the top of the stack.\r\n /// The value at the top of the stack.\r\n /// This method removes the element from the top of the stack. The implementation in this class\r\n /// always raises an exception.\r\n /// The stack is empty.\r\n /// Always raised in current implementation.\r\n function Pop(): T; virtual;\r\n\r\n /// Reads the element from the top of the stack.\r\n /// The value at the top of the stack.\r\n /// This method does not remove the element from the top of the stack. It merely reads its value. This implementation calls\r\n /// Enex Last operation.\r\n /// The stack is empty.\r\n function Peek(): T; virtual;\r\n end;\r\n\r\ntype\r\n /// The generic stack (LIFO) collection.\r\n /// This type uses an internal array to store its values.\r\n TStack = class(TAbstractStack, IDynamic)\r\n private type\r\n {$REGION 'Internal Types'}\r\n { Generic Stack List Enumerator }\r\n TEnumerator = class(TAbstractEnumerator)\r\n private\r\n FCurrentIndex: NativeInt;\r\n public\r\n function TryMoveNext(out ACurrent: T): Boolean; override;\r\n end;\r\n {$ENDREGION}\r\n\r\n private var\r\n FArray: TArray;\r\n FLength: NativeInt;\r\n\r\n protected\r\n /// Returns the number of elements in the stack.\r\n /// A positive value specifying the number of elements in the stack.\r\n function GetCount(): NativeInt; override;\r\n\r\n /// Returns the current capacity.\r\n /// A positive number that specifies the number of elements that the stack can hold before it\r\n /// needs to grow again.\r\n /// The value of this method is greater than or equal to the amount of elements in the stack. If this value\r\n /// is greater than the number of elements, it means that the stack has some extra capacity to operate upon.\r\n function GetCapacity(): NativeInt;\r\n public\r\n /// Creates a new stack collection.\r\n /// This constructor requests the default rule set. Call the overloaded constructor if\r\n /// specific a set of rules need to be passed.\r\n constructor Create(); overload;\r\n\r\n /// Creates a new stack collection.\r\n /// A rule set describing the elements in the set.\r\n constructor Create(const ARules: TRules); overload;\r\n\r\n /// Creates a new stack collection.\r\n /// A rule set describing the elements in the stack.\r\n /// The stack's initial capacity.\r\n constructor Create(const ARules: TRules; const AInitialCapacity: NativeInt); overload;\r\n\r\n /// Clears the contents of the stack.\r\n procedure Clear(); override;\r\n\r\n /// Pushes an element to the top of the stack.\r\n /// The value to push.\r\n procedure Add(const AValue: T); override;\r\n\r\n /// Retrieves the element from the top of the stack.\r\n /// The value at the top of the stack.\r\n /// This method removes the element from the top of the stack.\r\n /// The stack is empty.\r\n function Pop(): T; override;\r\n\r\n /// Removes an element from the stack.\r\n /// The value to remove. If there is no such element in the stack, nothing happens.\r\n procedure Remove(const AValue: T); override;\r\n\r\n /// Checks whether the stack contains a given value.\r\n /// The value to check.\r\n /// True if the value was found in the stack; False otherwise.\r\n function Contains(const AValue: T): Boolean; override;\r\n\r\n /// Specifies the number of elements in the stack.\r\n /// A positive value specifying the number of elements in the stack.\r\n property Count: NativeInt read FLength;\r\n\r\n /// Specifies the current capacity.\r\n /// A positive number that specifies the number of elements that the stack can hold before it\r\n /// needs to grow again.\r\n /// The value of this property is greater than or equal to the amount of elements in the stack. If this value\r\n /// if greater than the number of elements, it means that the stack has some extra capacity to operate upon.\r\n property Capacity: NativeInt read GetCapacity;\r\n\r\n /// Removes the excess capacity from the stack.\r\n /// This method can be called manually to force the stack to drop the extra capacity it might hold. For example,\r\n /// after performing some massive operations on a big list, call this method to ensure that all extra memory held by the\r\n /// stack is released.\r\n procedure Shrink();\r\n\r\n /// Forces the stack to increase its capacity.\r\n /// Call this method to force the stack to increase its capacity ahead of time. Manually adjusting the capacity\r\n /// can be useful in certain situations.\r\n procedure Grow();\r\n\r\n /// Returns a new enumerator object used to enumerate this stack.\r\n /// This method is usually called by compiler-generated code. Its purpose is to create an enumerator\r\n /// object that is used to actually traverse the stack.\r\n /// An enumerator object.\r\n function GetEnumerator(): IEnumerator; override;\r\n\r\n /// Copies the values stored in the stack to a given array.\r\n /// An array where to copy the contents of the stack.\r\n /// The index into the array at which the copying begins.\r\n /// This method assumes that has enough space to hold the contents of the stack.\r\n /// is out of bounds.\r\n /// The array is not long enough.\r\n procedure CopyTo(var AArray: array of T; const AStartIndex: NativeInt); overload; override;\r\n\r\n /// Checks whether the stack is empty.\r\n /// True if the stack is empty; False otherwise.\r\n /// This method is the recommended way of detecting if the stack is empty.\r\n function Empty(): Boolean; override;\r\n\r\n /// Returns the biggest element.\r\n /// An element from the stack considered to have the biggest value.\r\n /// The stack is empty.\r\n function Max(): T; override;\r\n\r\n /// Returns the smallest element.\r\n /// An element from the stack considered to have the smallest value.\r\n /// The stack is empty.\r\n function Min(): T; override;\r\n\r\n /// Returns the first element.\r\n /// The first element in the stack.\r\n /// The stack is empty.\r\n function First(): T; override;\r\n\r\n /// Returns the first element or a default, if the stack is empty.\r\n /// The default value returned if the stack is empty.\r\n /// The first element in the stack if the stack is not empty; otherwise is returned.\r\n function FirstOrDefault(const ADefault: T): T; override;\r\n\r\n /// Returns the last element.\r\n /// The last element in the stack.\r\n /// The stack is empty.\r\n function Last(): T; override;\r\n\r\n /// Returns the last element or a default if the stack is empty.\r\n /// The default value returned if the stack is empty.\r\n /// The last element in stack if the stack is not empty; otherwise is returned.\r\n function LastOrDefault(const ADefault: T): T; override;\r\n\r\n /// Returns the single element stored in the stack.\r\n /// The element in the stack.\r\n /// This method checks whether the stack contains just one element, in which case it is returned.\r\n /// The stack is empty.\r\n /// There is more than one element in the stack.\r\n function Single(): T; override;\r\n\r\n /// Returns the single element stored in the stack or a default value.\r\n /// The default value returned if there are less or more elements in the stack.\r\n /// The element in the stack if the condition is satisfied; is returned otherwise.\r\n /// This method checks whether the stack contains just one element, in which case it is returned. Otherwise\r\n /// the value in is returned.\r\n function SingleOrDefault(const ADefault: T): T; override;\r\n\r\n /// Aggregates a value based on the stack's elements.\r\n /// The aggregator method.\r\n /// A value that contains the stack's aggregated value.\r\n /// This method returns the first element if the stack only has one element. Otherwise,\r\n /// is invoked for each two elements (first and second; then the result of the first two\r\n /// and the third, and so on). The simplest example of aggregation is the \"sum\" operation, where you can obtain the sum of all\r\n /// elements in the value.\r\n /// is nil.\r\n /// The stack is empty.\r\n function Aggregate(const AAggregator: TFunc): T; override;\r\n\r\n /// Aggregates a value based on the stack's elements.\r\n /// The aggregator method.\r\n /// The default value returned if the stack is empty.\r\n /// A value that contains the stack's aggregated value. If the stack is empty, is returned.\r\n /// This method returns the first element if the stack only has one element. Otherwise,\r\n /// is invoked for each two elements (first and second; then the result of the first two\r\n /// and the third, and so on). The simplest example of aggregation is the \"sum\" operation, where you can obtain the sum of all\r\n /// elements in the value.\r\n /// is nil.\r\n function AggregateOrDefault(const AAggregator: TFunc; const ADefault: T): T; override;\r\n\r\n /// Returns the element at a given position.\r\n /// The index from which to return the element.\r\n /// The element at the specified position.\r\n /// The stack is empty.\r\n /// is out of bounds.\r\n function ElementAt(const AIndex: NativeInt): T; override;\r\n\r\n /// Returns the element at a given position.\r\n /// The index from which to return the element.\r\n /// The default value returned if the stack is empty.\r\n /// The element at the specified position if the stack is not empty and the position is not out of bounds; otherwise\r\n /// the value of is returned.\r\n function ElementAtOrDefault(const AIndex: NativeInt; const ADefault: T): T; override;\r\n\r\n /// Checks whether at least one element in the stack satisfies a given predicate.\r\n /// The predicate to check for each element.\r\n /// True if at least one element satisfies a given predicate; False otherwise.\r\n /// This method traverses the whole stack and checks the value of the predicate for each element. This method\r\n /// stops on the first element for which the predicate returns True. The logical equivalent of this operation is \"OR\".\r\n /// is nil.\r\n function Any(const APredicate: TPredicate): Boolean; override;\r\n\r\n /// Checks that all elements in the stack satisfy a given predicate.\r\n /// The predicate to check for each element.\r\n /// True if all elements satisfy a given predicate; False otherwise.\r\n /// This method traverses the whole stack and checks the value of the predicate for each element. This method\r\n /// stops on the first element for which the predicate returns False. The logical equivalent of this operation is \"AND\".\r\n /// is nil.\r\n function All(const APredicate: TPredicate): Boolean; override;\r\n\r\n /// Checks whether the elements in this stack are equal to the elements in another collection.\r\n /// The collection to compare to.\r\n /// True if the collections are equal; False if the collections are different.\r\n /// This method checks that each element at position X in this stack is equal to an element at position X in\r\n /// the provided collection. If the number of elements in both collections is different, then the collections are considered different.\r\n /// Note that the comparison of elements is done using the rule set used by this stack. This means that comparing this collection\r\n /// to another one might yeild a different result than comparing the other collection to this one.\r\n /// is nil.\r\n function EqualsTo(const ACollection: IEnumerable): Boolean; override;\r\n end;\r\n\r\n /// The generic stack (LIFO) collection designed to store objects.\r\n /// This type uses an internal array to store its objects.\r\n TObjectStack = class(TStack)\r\n private\r\n FOwnsObjects: Boolean;\r\n\r\n protected\r\n /// Frees the object that was removed from the collection.\r\n /// The object that was removed from the collection.\r\n procedure HandleElementRemoved(const AElement: T); override;\r\n\r\n public\r\n /// Specifies whether this stack owns the objects stored in it.\r\n /// True if the stack owns its objects; False otherwise.\r\n /// This property controls the way the stack controls the life-time of the stored objects.\r\n property OwnsObjects: Boolean read FOwnsObjects write FOwnsObjects;\r\n end;\r\n\r\ntype\r\n /// The generic stack (LIFO) collection.\r\n /// This type uses a linked list to store its values.\r\n TLinkedStack = class(TAbstractStack)\r\n private type\r\n {$REGION 'Internal Types'}\r\n PEntry = ^TEntry;\r\n TEntry = record\r\n FPrev, FNext: PEntry;\r\n FValue: T;\r\n end;\r\n\r\n TEnumerator = class(TAbstractEnumerator)\r\n private\r\n FCurrentEntry: PEntry;\r\n public\r\n function TryMoveNext(out ACurrent: T): Boolean; override;\r\n end;\r\n {$ENDREGION}\r\n\r\n private var\r\n FFirst, FLast, FFirstFree: PEntry;\r\n FCount, FFreeCount: NativeInt;\r\n\r\n { Caching }\r\n function NeedEntry(const AValue: T): PEntry;\r\n procedure ReleaseEntry(const AEntry: PEntry);\r\n protected\r\n\r\n /// Returns the number of elements in the stack.\r\n /// A positive value specifying the number of elements in the stack.\r\n function GetCount(): NativeInt; override;\r\n public\r\n /// Creates a new stack collection.\r\n /// This constructor requests the default rule set. Call the overloaded constructor if\r\n /// specific a set of rules need to be passed.\r\n constructor Create(); overload;\r\n\r\n /// Creates a new stack collection.\r\n /// A rule set describing the elements in the set.\r\n constructor Create(const ARules: TRules); overload;\r\n\r\n /// Destroys this instance.\r\n /// Do not call this method directly; call Free instead\r\n destructor Destroy(); override;\r\n\r\n /// Clears the contents of the stack.\r\n procedure Clear(); override;\r\n\r\n /// Pushes an element to the top of the stack.\r\n /// The value to push.\r\n procedure Add(const AValue: T); override;\r\n\r\n /// Retrieves the element from the top of the stack.\r\n /// The value at the top of the stack.\r\n /// This method removes the element from the top of the stack.\r\n /// The stack is empty.\r\n function Pop(): T; override;\r\n\r\n /// Removes an element from the stack.\r\n /// The value to remove. If there is no such element in the stack, nothing happens.\r\n procedure Remove(const AValue: T); override;\r\n\r\n /// Checks whether the stack contains a given value.\r\n /// The value to check.\r\n /// True if the value was found in the stack; False otherwise.\r\n function Contains(const AValue: T): Boolean; override;\r\n\r\n /// Specifies the number of elements in the stack.\r\n /// A positive value specifying the number of elements in the stack.\r\n property Count: NativeInt read FCount;\r\n\r\n /// Returns a new enumerator object used to enumerate this stack.\r\n /// This method is usually called by compiler-generated code. Its purpose is to create an enumerator\r\n /// object that is used to actually traverse the stack.\r\n /// An enumerator object.\r\n function GetEnumerator(): IEnumerator; override;\r\n\r\n /// Copies the values stored in the stack to a given array.\r\n /// An array where to copy the contents of the stack.\r\n /// The index into the array at which the copying begins.\r\n /// This method assumes that has enough space to hold the contents of the stack.\r\n /// is out of bounds.\r\n /// The array is not long enough.\r\n procedure CopyTo(var AArray: array of T; const AStartIndex: NativeInt); overload; override;\r\n\r\n /// Checks whether the stack is empty.\r\n /// True if the stack is empty; False otherwise.\r\n /// This method is the recommended way of detecting if the stack is empty.\r\n function Empty(): Boolean; override;\r\n\r\n /// Returns the biggest element.\r\n /// An element from the stack considered to have the biggest value.\r\n /// The stack is empty.\r\n function Max(): T; override;\r\n\r\n /// Returns the smallest element.\r\n /// An element from the stack considered to have the smallest value.\r\n /// The stack is empty.\r\n function Min(): T; override;\r\n\r\n /// Returns the first element.\r\n /// The first element in the stack.\r\n /// The stack is empty.\r\n function First(): T; override;\r\n\r\n /// Returns the first element or a default if the stack is empty.\r\n /// The default value returned if the stack is empty.\r\n /// The first element in stack if the stack is not empty; otherwise is returned.\r\n function FirstOrDefault(const ADefault: T): T; override;\r\n\r\n /// Returns the last element.\r\n /// The last element in the stack.\r\n /// The stack is empty.\r\n function Last(): T; override;\r\n\r\n /// Returns the last element or a default, if the stack is empty.\r\n /// The default value returned if the stack is empty.\r\n /// The last element in the stack if the stack is not empty; otherwise is returned.\r\n function LastOrDefault(const ADefault: T): T; override;\r\n\r\n /// Returns the single element stored in the stack.\r\n /// The element in the stack.\r\n /// This method checks whether the stack contains just one element, in which case it is returned.\r\n /// The stack is empty.\r\n /// There is more than one element in the stack.\r\n function Single(): T; override;\r\n\r\n /// Returns the single element stored in the stack, or a default value.\r\n /// The default value returned if there are less or more elements in the stack.\r\n /// The element in the stack if the condition is satisfied; is returned otherwise.\r\n /// This method checks if the stack contains just one element, in which case it is returned. Otherwise\r\n /// the value in is returned.\r\n function SingleOrDefault(const ADefault: T): T; override;\r\n\r\n /// Aggregates a value based on the stack's elements.\r\n /// The aggregator method.\r\n /// A value that contains the stack's aggregated value.\r\n /// This method returns the first element if the stack only has one element. Otherwise,\r\n /// is invoked for each two elements (first and second; then the result of the first two\r\n /// and the third, and so on). The simplest example of aggregation is the \"sum\" operation, where you can obtain the sum of all\r\n /// elements in the value.\r\n /// is nil.\r\n /// The stack is empty.\r\n function Aggregate(const AAggregator: TFunc): T; override;\r\n\r\n /// Aggregates a value based on the stack's elements.\r\n /// The aggregator method.\r\n /// The default value returned if the stack is empty.\r\n /// A value that contains the stack's aggregated value. If the stack is empty, is returned.\r\n /// This method returns the first element if the stack only has one element. Otherwise,\r\n /// is invoked for each two elements (first and second; then the result of the first two\r\n /// and the third, and so on). The simplest example of aggregation is the \"sum\" operation, where you can obtain the sum of all\r\n /// elements in the value.\r\n /// is nil.\r\n function AggregateOrDefault(const AAggregator: TFunc; const ADefault: T): T; override;\r\n\r\n /// Returns the element at a given position.\r\n /// The index from which to return the element.\r\n /// The element at the specified position.\r\n /// The stack is empty.\r\n /// is out of bounds.\r\n function ElementAt(const AIndex: NativeInt): T; override;\r\n\r\n /// Returns the element at a given position.\r\n /// The index from which to return the element.\r\n /// The default value returned if the stack is empty.\r\n /// The element at the specified position if the stack is not empty and the position is not out of bounds; otherwise\r\n /// the value of is returned.\r\n function ElementAtOrDefault(const AIndex: NativeInt; const ADefault: T): T; override;\r\n\r\n /// Checks whether at least one element in the stack satisfies a given predicate.\r\n /// The predicate to check for each element.\r\n /// True if at least one element satisfies a given predicate; False otherwise.\r\n /// This method traverses the whole stack and checks the value of the predicate for each element. This method\r\n /// stops on the first element for which the predicate returns True. The logical equivalent of this operation is \"OR\".\r\n /// is nil.\r\n function Any(const APredicate: TPredicate): Boolean; override;\r\n\r\n /// Checks that all elements in the stack satisfy a given predicate.\r\n /// The predicate to check for each element.\r\n /// True if all elements satisfy a given predicate; False otherwise.\r\n /// This method traverses the whole stack and checks the value of the predicate for each element. This method\r\n /// stops on the first element for which the predicate returns False. The logical equivalent of this operation is \"AND\".\r\n /// is nil.\r\n function All(const APredicate: TPredicate): Boolean; override;\r\n\r\n /// Checks whether the elements in this stack are equal to the elements in another collection.\r\n /// The collection to compare to.\r\n /// True if the collections are equal; False if the collections are different.\r\n /// This method checks that each element at position X in this stack is equal to an element at position X in\r\n /// the provided collection. If the number of elements in both collections is different, then the collections are considered different.\r\n /// Note that the comparison of elements is done using the rule set used by this stack. This means that comparing this collection\r\n /// to another one might yeild a different result than comparing the other collection to this one.\r\n /// is nil.\r\n function EqualsTo(const ACollection: IEnumerable): Boolean; override;\r\n end;\r\n\r\n /// The generic stack (LIFO) collection designed to store objects.\r\n /// This type uses a linked list to store its objects.\r\n TObjectLinkedStack = class(TLinkedStack)\r\n private\r\n FOwnsObjects: Boolean;\r\n\r\n protected\r\n /// Frees the object that was removed from the collection.\r\n /// The object that was removed from the collection.\r\n procedure HandleElementRemoved(const AElement: T); override;\r\n\r\n public\r\n /// Specifies whether this stack owns the objects stored in it.\r\n /// True if the stack owns its objects; False otherwise.\r\n /// This property specifies the way the stack controls the life-time of the stored objects.\r\n property OwnsObjects: Boolean read FOwnsObjects write FOwnsObjects;\r\n end;\r\n\r\nimplementation\r\n\r\n{ TAbstractStack }\r\n\r\nconstructor TAbstractStack.Create(const ARules: TRules);\r\nbegin\r\n inherited Create(ARules);\r\nend;\r\n\r\ndestructor TAbstractStack.Destroy;\r\nbegin\r\n Clear();\r\n inherited;\r\nend;\r\n\r\nfunction TAbstractStack.Peek: T;\r\nbegin\r\n Result := Last();\r\nend;\r\n\r\nfunction TAbstractStack.Pop: T;\r\nbegin\r\n ExceptionHelper.Throw_OperationNotSupported('Pop');\r\nend;\r\n\r\nprocedure TAbstractStack.Push(const AValue: T);\r\nbegin\r\n Add(AValue);\r\nend;\r\n\r\n{ TStack }\r\n\r\nfunction TStack.Aggregate(const AAggregator: TFunc): T;\r\nvar\r\n I: NativeInt;\r\nbegin\r\n { Check arguments }\r\n if not Assigned(AAggregator) then\r\n ExceptionHelper.Throw_ArgumentNilError('AAggregator');\r\n\r\n if FLength = 0 then\r\n ExceptionHelper.Throw_CollectionEmptyError();\r\n\r\n { Select the first element as comparison base }\r\n Result := FArray[0];\r\n\r\n { Iterate over the last N - 1 elements }\r\n for I := 1 to FLength - 1 do\r\n begin\r\n { Aggregate a value }\r\n Result := AAggregator(Result, FArray[I]);\r\n end;\r\nend;\r\n\r\nfunction TStack.AggregateOrDefault(const AAggregator: TFunc; const ADefault: T): T;\r\nvar\r\n I: NativeInt;\r\nbegin\r\n { Check arguments }\r\n if not Assigned(AAggregator) then\r\n ExceptionHelper.Throw_ArgumentNilError('AAggregator');\r\n\r\n if FLength = 0 then\r\n Exit(ADefault);\r\n\r\n { Select the first element as comparison base }\r\n Result := FArray[0];\r\n\r\n { Iterate over the last N - 1 elements }\r\n for I := 1 to FLength - 1 do\r\n begin\r\n { Aggregate a value }\r\n Result := AAggregator(Result, FArray[I]);\r\n end;\r\nend;\r\n\r\nfunction TStack.All(const APredicate: TPredicate): Boolean;\r\nvar\r\n I: NativeInt;\r\nbegin\r\n if not Assigned(APredicate) then\r\n ExceptionHelper.Throw_ArgumentNilError('APredicate');\r\n\r\n if FLength > 0 then\r\n for I := 0 to FLength - 1 do\r\n if not APredicate(FArray[I]) then\r\n Exit(false);\r\n\r\n Result := true;\r\nend;\r\n\r\nfunction TStack.Any(const APredicate: TPredicate): Boolean;\r\nvar\r\n I: NativeInt;\r\nbegin\r\n if not Assigned(APredicate) then\r\n ExceptionHelper.Throw_ArgumentNilError('APredicate');\r\n\r\n if FLength > 0 then\r\n for I := 0 to FLength - 1 do\r\n if APredicate(FArray[I]) then\r\n Exit(true);\r\n\r\n Result := false;\r\nend;\r\n\r\nprocedure TStack.Clear;\r\nvar\r\n I: NativeInt;\r\nbegin\r\n if FLength > 0 then\r\n begin\r\n for I := 0 to FLength - 1 do\r\n NotifyElementRemoved(FArray[I]);\r\n\r\n { Simply reset all to default }\r\n FLength := 0;\r\n SetLength(FArray, 0);\r\n NotifyCollectionChanged();\r\n end;\r\nend;\r\n\r\nfunction TStack.Contains(const AValue: T): Boolean;\r\nvar\r\n I: NativeInt;\r\nbegin\r\n { Defaults }\r\n Result := False;\r\n if (FLength = 0) then Exit;\r\n\r\n for I := 0 to FLength - 1 do\r\n begin\r\n if ElementsAreEqual(FArray[I], AValue) then\r\n begin\r\n Result := True;\r\n Exit;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TStack.CopyTo(var AArray: array of T; const AStartIndex: NativeInt);\r\nvar\r\n I: NativeInt;\r\nbegin\r\n { Check for indexes }\r\n if (AStartIndex >= Length(AArray)) or (AStartIndex < 0) then\r\n ExceptionHelper.Throw_ArgumentOutOfRangeError('AStartIndex');\r\n\r\n if (Length(AArray) - AStartIndex) < FLength then\r\n ExceptionHelper.Throw_ArgumentOutOfSpaceError('AArray');\r\n\r\n { Copy all elements safely }\r\n for I := 0 to FLength - 1 do\r\n AArray[AStartIndex + I] := FArray[I];\r\nend;\r\n\r\nconstructor TStack.Create(const ARules: TRules);\r\nbegin\r\n Create(ARules, CDefaultSize);\r\nend;\r\n\r\nconstructor TStack.Create();\r\nbegin\r\n Create(TRules.Default, CDefaultSize);\r\nend;\r\n\r\nconstructor TStack.Create(const ARules: TRules; const AInitialCapacity: NativeInt);\r\nbegin\r\n { Initialize instance }\r\n inherited Create(ARules);\r\n\r\n if AInitialCapacity <= 0 then\r\n SetLength(FArray, 0)\r\n else\r\n SetLength(FArray, AInitialCapacity);\r\nend;\r\n\r\nfunction TStack.ElementAt(const AIndex: NativeInt): T;\r\nbegin\r\n if (AIndex >= FLength) or (AIndex < 0) then\r\n ExceptionHelper.Throw_ArgumentOutOfRangeError('AIndex');\r\n\r\n Result := FArray[AIndex];\r\nend;\r\n\r\nfunction TStack.ElementAtOrDefault(const AIndex: NativeInt; const ADefault: T): T;\r\nbegin\r\n { Check range }\r\n if AIndex < 0 then\r\n ExceptionHelper.Throw_ArgumentOutOfRangeError('AIndex');\r\n\r\n if (AIndex >= FLength) then\r\n Result := ADefault\r\n else\r\n Result := FArray[AIndex];\r\nend;\r\n\r\nfunction TStack.Empty: Boolean;\r\nbegin\r\n Result := (FLength = 0);\r\nend;\r\n\r\nfunction TStack.EqualsTo(const ACollection: IEnumerable): Boolean;\r\nvar\r\n LValue: T;\r\n I: NativeInt;\r\nbegin\r\n I := 0;\r\n\r\n for LValue in ACollection do\r\n begin\r\n if I >= FLength then\r\n Exit(false);\r\n\r\n if not ElementsAreEqual(FArray[I], LValue) then\r\n Exit(false);\r\n\r\n Inc(I);\r\n end;\r\n\r\n if I < FLength then\r\n Exit(false);\r\n\r\n Result := true;\r\nend;\r\n\r\nfunction TStack.First: T;\r\nbegin\r\n { Check length }\r\n if FLength = 0 then\r\n ExceptionHelper.Throw_CollectionEmptyError();\r\n\r\n Result := FArray[0];\r\nend;\r\n\r\nfunction TStack.FirstOrDefault(const ADefault: T): T;\r\nbegin\r\n { Check length }\r\n if FLength = 0 then\r\n Result := ADefault\r\n else\r\n Result := FArray[0];\r\nend;\r\n\r\nfunction TStack.GetCapacity: NativeInt;\r\nbegin\r\n Result := Length(FArray);\r\nend;\r\n\r\nfunction TStack.GetCount: NativeInt;\r\nbegin\r\n { Use the variable }\r\n Result := FLength;\r\nend;\r\n\r\nfunction TStack.GetEnumerator: IEnumerator;\r\nbegin\r\n Result := TEnumerator.Create(Self);\r\nend;\r\n\r\nprocedure TStack.Grow;\r\nvar\r\n LNewCapacity: NativeInt;\r\nbegin\r\n if Capacity = 0 then\r\n LNewCapacity := CDefaultSize\r\n else\r\n LNewCapacity := Capacity * 2;\r\n\r\n SetLength(FArray, LNewCapacity);\r\nend;\r\n\r\nfunction TStack.Last: T;\r\nbegin\r\n { Check length }\r\n if FLength = 0 then\r\n ExceptionHelper.Throw_CollectionEmptyError();\r\n\r\n Result := FArray[FLength - 1];\r\nend;\r\n\r\nfunction TStack.LastOrDefault(const ADefault: T): T;\r\nbegin\r\n { Check length }\r\n if FLength = 0 then\r\n Result := ADefault\r\n else\r\n Result := FArray[FLength - 1];\r\nend;\r\n\r\nfunction TStack.Max: T;\r\nvar\r\n I: NativeInt;\r\nbegin\r\n { Check length }\r\n if FLength = 0 then\r\n ExceptionHelper.Throw_CollectionEmptyError();\r\n\r\n { Default one }\r\n Result := FArray[0];\r\n\r\n for I := 1 to FLength - 1 do\r\n if CompareElements(FArray[I], Result) > 0 then\r\n Result := FArray[I];\r\nend;\r\n\r\nfunction TStack.Min: T;\r\nvar\r\n I: NativeInt;\r\nbegin\r\n { Check length }\r\n if FLength = 0 then\r\n ExceptionHelper.Throw_CollectionEmptyError();\r\n\r\n { Default one }\r\n Result := FArray[0];\r\n\r\n for I := 1 to FLength - 1 do\r\n if CompareElements(FArray[I], Result) < 0 then\r\n Result := FArray[I];\r\nend;\r\n\r\nfunction TStack.Pop: T;\r\nbegin\r\n if FLength > 0 then\r\n begin\r\n Result := FArray[FLength - 1];\r\n\r\n Dec(FLength);\r\n NotifyCollectionChanged();\r\n end else\r\n ExceptionHelper.Throw_CollectionEmptyError();\r\nend;\r\n\r\nprocedure TStack.Add(const AValue: T);\r\nbegin\r\n { Ensure enough capacity }\r\n if (FLength >= Capacity) then\r\n Grow();\r\n\r\n { Add the element to the stack and increase the index }\r\n FArray[FLength] := AValue;\r\n Inc(FLength);\r\n NotifyCollectionChanged();\r\nend;\r\n\r\nprocedure TStack.Remove(const AValue: T);\r\nvar\r\n I, LFoundIndex: NativeInt;\r\nbegin\r\n { Defaults }\r\n if (FLength = 0) then Exit;\r\n LFoundIndex := -1;\r\n\r\n for I := 0 to FLength - 1 do\r\n begin\r\n if ElementsAreEqual(FArray[I], AValue) then\r\n begin\r\n LFoundIndex := I;\r\n Break;\r\n end;\r\n end;\r\n\r\n if (LFoundIndex > -1) then\r\n begin\r\n { Move the list }\r\n if FLength > 1 then\r\n for I := LFoundIndex to FLength - 2 do\r\n FArray[I] := FArray[I + 1];\r\n\r\n Dec(FLength);\r\n NotifyCollectionChanged();\r\n end;\r\nend;\r\n\r\nprocedure TStack.Shrink;\r\nbegin\r\n { Cut the capacity if required }\r\n if FLength < Capacity then\r\n SetLength(FArray, FLength);\r\nend;\r\n\r\nfunction TStack.Single: T;\r\nbegin\r\n { Check length }\r\n if FLength = 0 then\r\n ExceptionHelper.Throw_CollectionEmptyError()\r\n else if FLength > 1 then\r\n ExceptionHelper.Throw_CollectionHasMoreThanOneElement()\r\n else\r\n Result := FArray[0];\r\nend;\r\n\r\nfunction TStack.SingleOrDefault(const ADefault: T): T;\r\nbegin\r\n { Check length }\r\n if FLength = 0 then\r\n Result := ADefault\r\n else if FLength > 1 then\r\n ExceptionHelper.Throw_CollectionHasMoreThanOneElement()\r\n else\r\n Result := FArray[0];\r\nend;\r\n\r\n{ TStack.TEnumerator }\r\n\r\nfunction TStack.TEnumerator.TryMoveNext(out ACurrent: T): Boolean;\r\nbegin\r\n with TStack(Owner) do\r\n begin\r\n Result := FCurrentIndex < FLength;\r\n\r\n if Result then\r\n begin\r\n ACurrent := FArray[FCurrentIndex];\r\n Inc(FCurrentIndex);\r\n end;\r\n end;\r\nend;\r\n\r\n{ TObjectStack }\r\n\r\nprocedure TObjectStack.HandleElementRemoved(const AElement: T);\r\nbegin\r\n if FOwnsObjects then\r\n TObject(AElement).Free;\r\nend;\r\n\r\n{ TLinkedStack }\r\n\r\nfunction TLinkedStack.Aggregate(const AAggregator: TFunc): T;\r\nvar\r\n LCurrent: PEntry;\r\nbegin\r\n { Check arguments }\r\n if not Assigned(AAggregator) then\r\n ExceptionHelper.Throw_ArgumentNilError('AAggregator');\r\n\r\n if not Assigned(FFirst) then\r\n ExceptionHelper.Throw_CollectionEmptyError();\r\n\r\n { Select the first element as comparison base }\r\n Result := FFirst^.FValue;\r\n LCurrent := FFirst^.FNext;\r\n\r\n { Iterate over the last N - 1 elements }\r\n while Assigned(LCurrent) do\r\n begin\r\n Result := AAggregator(Result, LCurrent^.FValue);\r\n LCurrent := LCurrent^.FNext;\r\n end;\r\nend;\r\n\r\nfunction TLinkedStack.AggregateOrDefault(const AAggregator: TFunc; const ADefault: T): T;\r\nvar\r\n LCurrent: PEntry;\r\nbegin\r\n { Check arguments }\r\n if not Assigned(AAggregator) then\r\n ExceptionHelper.Throw_ArgumentNilError('AAggregator');\r\n\r\n { Select the first element as comparison base }\r\n if not Assigned(FFirst) then\r\n Exit(ADefault);\r\n\r\n Result := FFirst^.FValue;\r\n LCurrent := FFirst^.FNext;\r\n\r\n { Iterate over the last N - 1 elements }\r\n while Assigned(LCurrent) do\r\n begin\r\n Result := AAggregator(Result, LCurrent^.FValue);\r\n LCurrent := LCurrent^.FNext;\r\n end;\r\nend;\r\n\r\nfunction TLinkedStack.All(const APredicate: TPredicate): Boolean;\r\nvar\r\n LCurrent: PEntry;\r\nbegin\r\n if not Assigned(APredicate) then\r\n ExceptionHelper.Throw_ArgumentNilError('APredicate');\r\n\r\n LCurrent := FFirst;\r\n\r\n while Assigned(LCurrent) do\r\n begin\r\n if not APredicate(LCurrent^.FValue) then\r\n Exit(false);\r\n\r\n LCurrent := LCurrent^.FNext;\r\n end;\r\n\r\n Result := true;\r\nend;\r\n\r\nfunction TLinkedStack.Any(const APredicate: TPredicate): Boolean;\r\nvar\r\n LCurrent: PEntry;\r\nbegin\r\n if not Assigned(APredicate) then\r\n ExceptionHelper.Throw_ArgumentNilError('APredicate');\r\n\r\n LCurrent := FFirst;\r\n\r\n while Assigned(LCurrent) do\r\n begin\r\n if APredicate(LCurrent^.FValue) then\r\n Exit(true);\r\n\r\n LCurrent := LCurrent^.FNext;\r\n end;\r\n\r\n Result := false;\r\nend;\r\n\r\nprocedure TLinkedStack.Clear;\r\nvar\r\n LCurrent, LNext: PEntry;\r\nbegin\r\n if Assigned(FFirst) then\r\n begin\r\n LCurrent := FFirst;\r\n while Assigned(LCurrent) do\r\n begin\r\n NotifyElementRemoved(LCurrent^.FValue);\r\n\r\n { Release}\r\n LNext := LCurrent^.FNext;\r\n ReleaseEntry(LCurrent);\r\n LCurrent := LNext;\r\n end;\r\n\r\n FFirst := nil;\r\n FLast := nil;\r\n FCount := 0;\r\n NotifyCollectionChanged();\r\n end;\r\nend;\r\n\r\nfunction TLinkedStack.Contains(const AValue: T): Boolean;\r\nvar\r\n LCurrent: PEntry;\r\nbegin\r\n LCurrent := FFirst;\r\n Result := False;\r\n\r\n while Assigned(LCurrent) do\r\n begin\r\n if ElementsAreEqual(AValue, LCurrent^.FValue) then\r\n Exit(True);\r\n\r\n LCurrent := LCurrent^.FNext;\r\n end;\r\nend;\r\n\r\nprocedure TLinkedStack.CopyTo(var AArray: array of T; const AStartIndex: NativeInt);\r\nvar\r\n X: NativeInt;\r\n LCurrent: PEntry;\r\nbegin\r\n { Check for indexes }\r\n if (AStartIndex >= Length(AArray)) or (AStartIndex < 0) then\r\n ExceptionHelper.Throw_ArgumentOutOfRangeError('AStartIndex');\r\n\r\n if (Length(AArray) - AStartIndex) < FCount then\r\n ExceptionHelper.Throw_ArgumentOutOfSpaceError('AArray');\r\n\r\n X := AStartIndex;\r\n LCurrent := FFirst;\r\n while Assigned(LCurrent) do\r\n begin\r\n AArray[X] := LCurrent^.FValue;\r\n Inc(X);\r\n LCurrent := LCurrent^.FNext;\r\n end;\r\nend;\r\n\r\nconstructor TLinkedStack.Create;\r\nbegin\r\n inherited Create(TRules.Default);\r\nend;\r\n\r\nconstructor TLinkedStack.Create(const ARules: TRules);\r\nbegin\r\n inherited Create(ARules);\r\nend;\r\n\r\ndestructor TLinkedStack.Destroy;\r\nvar\r\n LNext: PEntry;\r\nbegin\r\n { Some cleanup }\r\n Clear();\r\n\r\n { Clear the cached entries too }\r\n if FFreeCount > 0 then\r\n while Assigned(FFirstFree) do\r\n begin\r\n LNext := FFirstFree^.FNext;\r\n\r\n { Delphi doesn finalize this }\r\n FFirstFree^.FValue := default(T);\r\n\r\n FreeMem(FFirstFree);\r\n FFirstFree := LNext;\r\n end;\r\n\r\n inherited;\r\nend;\r\n\r\nfunction TLinkedStack.ElementAt(const AIndex: NativeInt): T;\r\nvar\r\n LCurrent: PEntry;\r\n LIndex: NativeInt;\r\nbegin\r\n { Check range }\r\n if (AIndex >= FCount) or (AIndex < 0) then\r\n ExceptionHelper.Throw_ArgumentOutOfRangeError('AIndex');\r\n\r\n LCurrent := FFirst;\r\n LIndex := 0;\r\n while Assigned(LCurrent) do\r\n begin\r\n if LIndex = AIndex then\r\n Exit(LCurrent^.FValue);\r\n\r\n LCurrent := LCurrent^.FNext;\r\n Inc(LIndex);\r\n end;\r\n\r\n { Should never happen }\r\n ExceptionHelper.Throw_ArgumentOutOfRangeError('AIndex');\r\nend;\r\n\r\nfunction TLinkedStack.ElementAtOrDefault(const AIndex: NativeInt; const ADefault: T): T;\r\nvar\r\n LCurrent: PEntry;\r\n LIndex: NativeInt;\r\nbegin\r\n { Check range }\r\n if AIndex < 0 then\r\n ExceptionHelper.Throw_ArgumentOutOfRangeError('AIndex');\r\n\r\n if AIndex >= FCount then\r\n Exit(ADefault);\r\n\r\n LCurrent := FFirst;\r\n LIndex := 0;\r\n while Assigned(LCurrent) do\r\n begin\r\n if LIndex = AIndex then\r\n Exit(LCurrent^.FValue);\r\n\r\n LCurrent := LCurrent^.FNext;\r\n Inc(LIndex);\r\n end;\r\n\r\n { Should never happen }\r\n Result := ADefault;\r\nend;\r\n\r\nfunction TLinkedStack.Empty: Boolean;\r\nbegin\r\n { Call the one from the list }\r\n Result := not Assigned(FFirst);\r\nend;\r\n\r\nfunction TLinkedStack.EqualsTo(const ACollection: IEnumerable): Boolean;\r\nvar\r\n LValue: T;\r\n LCurrent: PEntry;\r\nbegin\r\n LCurrent := FFirst;\r\n for LValue in ACollection do\r\n begin\r\n if not Assigned(LCurrent) then\r\n Exit(false);\r\n\r\n if not ElementsAreEqual(LCurrent^.FValue, LValue) then\r\n Exit(false);\r\n\r\n LCurrent := LCurrent^.FNext;\r\n end;\r\n\r\n Result := not Assigned(LCurrent);\r\nend;\r\n\r\nfunction TLinkedStack.First: T;\r\nbegin\r\n if not Assigned(FFirst) then\r\n ExceptionHelper.Throw_CollectionEmptyError();\r\n\r\n Result := FFirst^.FValue;\r\nend;\r\n\r\nfunction TLinkedStack.FirstOrDefault(const ADefault: T): T;\r\nbegin\r\n if not Assigned(FFirst) then\r\n Result := ADefault\r\n else\r\n Result := FFirst^.FValue;\r\nend;\r\n\r\nfunction TLinkedStack.GetCount: NativeInt;\r\nbegin\r\n { Use the variable }\r\n Result := FCount;\r\nend;\r\n\r\nfunction TLinkedStack.GetEnumerator: IEnumerator;\r\nvar\r\n LEnumerator: TEnumerator;\r\nbegin\r\n LEnumerator := TEnumerator.Create(Self);\r\n LEnumerator.FCurrentEntry := FFirst;\r\n Result := LEnumerator;\r\nend;\r\n\r\nfunction TLinkedStack.Last: T;\r\nbegin\r\n if not Assigned(FLast) then\r\n ExceptionHelper.Throw_CollectionEmptyError();\r\n\r\n Result := FLast^.FValue;\r\nend;\r\n\r\nfunction TLinkedStack.LastOrDefault(const ADefault: T): T;\r\nbegin\r\n if not Assigned(FLast) then\r\n Result := ADefault\r\n else\r\n Result := FLast^.FValue;\r\nend;\r\n\r\nfunction TLinkedStack.Max: T;\r\nvar\r\n LCurrent: PEntry;\r\nbegin\r\n if not Assigned(FLast) then\r\n ExceptionHelper.Throw_CollectionEmptyError();\r\n\r\n Result := FFirst^.FValue;\r\n LCurrent := FFirst^.FNext;\r\n\r\n while Assigned(LCurrent) do\r\n begin\r\n if CompareElements(LCurrent^.FValue, Result) > 0 then\r\n Result := LCurrent^.FValue;\r\n\r\n LCurrent := LCurrent^.FNext;\r\n end;\r\nend;\r\n\r\nfunction TLinkedStack.Min: T;\r\nvar\r\n LCurrent: PEntry;\r\nbegin\r\n if not Assigned(FLast) then\r\n ExceptionHelper.Throw_CollectionEmptyError();\r\n\r\n Result := FFirst^.FValue;\r\n LCurrent := FFirst^.FNext;\r\n\r\n while Assigned(LCurrent) do\r\n begin\r\n if CompareElements(LCurrent^.FValue, Result) < 0 then\r\n Result := LCurrent^.FValue;\r\n\r\n LCurrent := LCurrent^.FNext;\r\n end;\r\nend;\r\n\r\nfunction TLinkedStack.NeedEntry(const AValue: T): PEntry;\r\nbegin\r\n if FFreeCount > 0 then\r\n begin\r\n Result := FFirstFree;\r\n FFirstFree := FFirstFree^.FNext;\r\n\r\n Dec(FFreeCount);\r\n end else\r\n Result := AllocMem(SizeOf(TEntry));\r\n\r\n { Initialize the node }\r\n Result^.FValue := AValue;\r\nend;\r\n\r\nfunction TLinkedStack.Pop: T;\r\nvar\r\n LEntry: PEntry;\r\nbegin\r\n if not Assigned(FLast) then\r\n ExceptionHelper.Throw_CollectionEmptyError();\r\n\r\n LEntry := FLast;\r\n Result := LEntry^.FValue;\r\n FLast := LEntry^.FPrev;\r\n\r\n if FFirst = LEntry then\r\n FFirst := FLast;\r\n\r\n ReleaseEntry(LEntry);\r\n\r\n NotifyCollectionChanged();\r\n Dec(FCount);\r\nend;\r\n\r\nprocedure TLinkedStack.Add(const AValue: T);\r\nvar\r\n LNew: PEntry;\r\nbegin\r\n LNew := NeedEntry(AValue);\r\n LNew^.FPrev := FLast;\r\n LNew^.FNext := nil;\r\n\r\n if Assigned(FLast) then\r\n FLast^.FNext := LNew;\r\n\r\n FLast := LNew;\r\n\r\n if not Assigned(FFirst) then\r\n FFirst := LNew;\r\n\r\n NotifyCollectionChanged();\r\n Inc(FCount);\r\nend;\r\n\r\nprocedure TLinkedStack.ReleaseEntry(const AEntry: PEntry);\r\nbegin\r\n if FFreeCount = CDefaultSize then\r\n begin\r\n { Delphi doesn finalize this }\r\n AEntry^.FValue := default(T);\r\n FreeMem(AEntry);\r\n end else begin\r\n { Place the entry into the cache }\r\n AEntry^.FNext := FFirstFree;\r\n FFirstFree := AEntry;\r\n\r\n Inc(FFreeCount);\r\n end;\r\nend;\r\n\r\nprocedure TLinkedStack.Remove(const AValue: T);\r\nvar\r\n LCurrent: PEntry;\r\nbegin\r\n LCurrent := FFirst;\r\n\r\n while Assigned(LCurrent) do\r\n begin\r\n if ElementsAreEqual(AValue, LCurrent^.FValue) then\r\n begin\r\n { Remove the node }\r\n if Assigned(LCurrent^.FPrev) then\r\n LCurrent^.FPrev^.FNext := LCurrent^.FNext;\r\n if Assigned(LCurrent^.FNext) then\r\n LCurrent^.FNext^.FPrev := LCurrent^.FPrev;\r\n if FFirst = LCurrent then\r\n FFirst := LCurrent^.FNext;\r\n if FLast = LCurrent then\r\n FLast := LCurrent^.FPrev;\r\n\r\n ReleaseEntry(LCurrent);\r\n NotifyCollectionChanged();\r\n Dec(FCount);\r\n Exit;\r\n end;\r\n\r\n LCurrent := LCurrent^.FNext;\r\n end;\r\nend;\r\n\r\nfunction TLinkedStack.Single: T;\r\nbegin\r\n { Check length }\r\n if not Assigned(FFirst) then\r\n ExceptionHelper.Throw_CollectionEmptyError()\r\n else if FFirst <> FLast then\r\n ExceptionHelper.Throw_CollectionHasMoreThanOneElement()\r\n else\r\n Result := FFirst^.FValue;\r\nend;\r\n\r\nfunction TLinkedStack.SingleOrDefault(const ADefault: T): T;\r\nbegin\r\n { Check length }\r\n if not Assigned(FFirst) then\r\n Result := ADefault\r\n else if FFirst <> FLast then\r\n ExceptionHelper.Throw_CollectionHasMoreThanOneElement()\r\n else\r\n Result := FFirst^.FValue;\r\nend;\r\n\r\n{ TLinkedStack.TEnumerator }\r\n\r\nfunction TLinkedStack.TEnumerator.TryMoveNext(out ACurrent: T): Boolean;\r\nbegin\r\n Result := Assigned(FCurrentEntry);\r\n if Result then\r\n begin\r\n ACurrent := FCurrentEntry^.FValue;\r\n FCurrentEntry := FCurrentEntry^.FNext;\r\n end;\r\nend;\r\n\r\n{ TObjectLinkedStack }\r\n\r\nprocedure TObjectLinkedStack.HandleElementRemoved(const AElement: T);\r\nbegin\r\n if FOwnsObjects then\r\n TObject(AElement).Free;\r\nend;\r\n\r\nend.\r\n" }, { "path": "Collections/Collections.dpk", "content": "package Collections;\r\n\r\n{$R *.res}\r\n{$IFDEF IMPLICITBUILDING This IFDEF should not be used by users}\r\n{$ALIGN 8}\r\n{$ASSERTIONS ON}\r\n{$BOOLEVAL OFF}\r\n{$DEBUGINFO ON}\r\n{$EXTENDEDSYNTAX ON}\r\n{$IMPORTEDDATA ON}\r\n{$IOCHECKS ON}\r\n{$LOCALSYMBOLS ON}\r\n{$LONGSTRINGS ON}\r\n{$OPENSTRINGS ON}\r\n{$OPTIMIZATION ON}\r\n{$OVERFLOWCHECKS OFF}\r\n{$RANGECHECKS OFF}\r\n{$REFERENCEINFO ON}\r\n{$SAFEDIVIDE OFF}\r\n{$STACKFRAMES OFF}\r\n{$TYPEDADDRESS OFF}\r\n{$VARSTRINGCHECKS ON}\r\n{$WRITEABLECONST OFF}\r\n{$MINENUMSIZE 1}\r\n{$IMAGEBASE $400000}\r\n{$DEFINE DEBUG}\r\n{$ENDIF IMPLICITBUILDING}\r\n{$IMPLICITBUILD ON}\r\n\r\nrequires\r\n rtl;\r\n\r\ncontains\r\n Collections.Bags in 'Collections.Bags.pas',\r\n Collections.Base in 'Collections.Base.pas',\r\n Collections.BidiDictionaries in 'Collections.BidiDictionaries.pas',\r\n Collections.BidiMaps in 'Collections.BidiMaps.pas',\r\n Collections.Dictionaries in 'Collections.Dictionaries.pas',\r\n Collections.Dynamic in 'Collections.Dynamic.pas',\r\n Collections.Lists in 'Collections.Lists.pas',\r\n Collections.MultiMaps in 'Collections.MultiMaps.pas',\r\n Collections.Queues in 'Collections.Queues.pas',\r\n Collections.Sets in 'Collections.Sets.pas',\r\n Collections.Stacks in 'Collections.Stacks.pas',\r\n Collections.Serialization in 'Collections.Serialization.pas';\r\n\r\nend.\r\n\r\n" }, { "path": "Collections/Collections.dproj", "content": "\t\r\n\t\t\r\n\t\t\t{B6403A30-71D9-4B76-8676-CFF58E93639E}\r\n\t\t\tCollections.dpk\r\n\t\t\t13.4\r\n\t\t\tDebug\r\n\t\t\tDCC32\r\n\t\t\tTrue\r\n\t\t\tPackage\r\n\t\t\tNone\r\n\t\t\tWin32\r\n\t\t\t3\r\n\t\t\r\n\t\t\r\n\t\t\ttrue\r\n\t\t\r\n\t\t\r\n\t\t\ttrue\r\n\t\t\tBase\r\n\t\t\ttrue\r\n\t\t\r\n\t\t\r\n\t\t\ttrue\r\n\t\t\tBase\r\n\t\t\ttrue\r\n\t\t\r\n\t\t\r\n\t\t\ttrue\r\n\t\t\tBase\r\n\t\t\ttrue\r\n\t\t\r\n\t\t\r\n\t\t\ttrue\r\n\t\t\tBase\r\n\t\t\ttrue\r\n\t\t\r\n\t\t\r\n\t\t\ttrue\r\n\t\t\tCfg_2\r\n\t\t\ttrue\r\n\t\t\ttrue\r\n\t\t\r\n\t\t\r\n\t\t\t177\r\n\t\t\tCompanyName=Alexandru Ciobanu;FileDescription=Collections Package;FileVersion=1.2.0.177;InternalName=delphi-coll;LegalCopyright=Alexandru Ciobanu;LegalTrademarks=;OriginalFilename=;ProductName=Collections Package;ProductVersion=1.2.0.0;Comments=\r\n\t\t\t1033\r\n\t\t\ttrue\r\n\t\t\tSystem;Xml;Data;Datasnap;Web;Soap;$(DCC_Namespace)\r\n\t\t\t2\r\n\t\t\ttrue\r\n\t\t\t00400000\r\n\t\t\t..\\..\\bin\\Collections.bpl\r\n\t\t\ttrue\r\n\t\t\t..\\..\\bin\r\n\t\t\t..\\..\\bin;$(DCC_UnitSearchPath)\r\n\t\t\tx86\r\n\t\t\tfalse\r\n\t\t\tfalse\r\n\t\t\ttrue\r\n\t\t\t..\\..\\bin\r\n\t\t\tfalse\r\n\t\t\t..\\..\\bin\r\n\t\t\tfalse\r\n\t\t\tfalse\r\n\t\t\r\n\t\t\r\n\t\t\tWinapi;System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;$(DCC_Namespace)\r\n\t\t\tCollections_Icon.ico\r\n\t\t\t$(BDS)\\bin\\default_app.manifest\r\n\t\t\tCompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments=\r\n\t\t\r\n\t\t\r\n\t\t\ttrue\r\n\t\t\tCollections_Icon.ico\r\n\t\t\tWinapi;System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;Bde;$(DCC_Namespace)\r\n\t\t\t1033\r\n\t\t\t$(BDS)\\bin\\default_app.manifest\r\n\t\t\tCompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments=\r\n\t\t\r\n\t\t\r\n\t\t\tfalse\r\n\t\t\tRELEASE;$(DCC_Define)\r\n\t\t\t0\r\n\t\t\tfalse\r\n\t\t\r\n\t\t\r\n\t\t\tDEBUG;$(DCC_Define)\r\n\t\t\r\n\t\t\r\n\t\t\t..\\..\\bin\\$(Config)\\$(Platform);$(DCC_UnitSearchPath)\r\n\t\t\t..\\..\\bin\\$(Config)\\$(Platform)\r\n\t\t\tCompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments=\r\n\t\t\t..\\..\\bin\\$(Config)\\$(Platform)\r\n\t\t\t..\\..\\bin\\$(Config)\\$(Platform)\r\n\t\t\r\n\t\t\r\n\t\t\t\r\n\t\t\t\tMainSource\r\n\t\t\t\r\n\t\t\t\r\n\t\t\t\r\n\t\t\t\r\n\t\t\t\r\n\t\t\t\r\n\t\t\t\r\n\t\t\t\r\n\t\t\t\r\n\t\t\t\r\n\t\t\t\r\n\t\t\t\r\n\t\t\t\r\n\t\t\t\r\n\t\t\t\r\n\t\t\t\tCfg_2\r\n\t\t\t\tBase\r\n\t\t\t\r\n\t\t\t\r\n\t\t\t\tBase\r\n\t\t\t\r\n\t\t\t\r\n\t\t\t\tCfg_1\r\n\t\t\t\tBase\r\n\t\t\t\r\n\t\t\r\n\t\t\r\n\t\t\r\n\t\t\r\n\t\t\tDelphi.Personality.12\r\n\t\t\tPackage\r\n\t\t\t\r\n\t\t\t\t\r\n\t\t\t\t\t\r\n\t\t\t\t\t\tCollections.dpk\r\n\t\t\t\t\t\r\n\t\t\t\t\t\r\n\t\t\t\t\t\r\n\t\t\t\t\t\tTrue\r\n\t\t\t\t\t\tTrue\r\n\t\t\t\t\t\t1\r\n\t\t\t\t\t\t2\r\n\t\t\t\t\t\t0\r\n\t\t\t\t\t\t179\r\n\t\t\t\t\t\tFalse\r\n\t\t\t\t\t\tFalse\r\n\t\t\t\t\t\tFalse\r\n\t\t\t\t\t\tFalse\r\n\t\t\t\t\t\tFalse\r\n\t\t\t\t\t\t1033\r\n\t\t\t\t\t\t1252\r\n\t\t\t\t\t\r\n\t\t\t\t\t\r\n\t\t\t\t\t\tAlexandru Ciobanu\r\n\t\t\t\t\t\tCollections Package\r\n\t\t\t\t\t\t1.2.0.179\r\n\t\t\t\t\t\tdelphi-coll\r\n\t\t\t\t\t\tAlexandru Ciobanu\r\n\t\t\t\t\t\t\r\n\t\t\t\t\t\t\r\n\t\t\t\t\t\tCollections Package\r\n\t\t\t\t\t\t1.2.0.0\r\n\t\t\t\t\t\t\r\n\t\t\t\t\t\r\n\t\t\t\t\t\r\n\t\t\t\t\r\n\t\t\t\t\r\n\t\t\t\t\tTrue\r\n\t\t\t\t\tFalse\r\n\t\t\t\t\tTrue\r\n\t\t\t\t\r\n\t\t\t\r\n\t\t\t12\r\n\t\t\r\n\t\r\n" }, { "path": "Collections/Collections_project.tvsconfig", "content": "\r\n" }, { "path": "DbgCodeProfiler.pas", "content": "unit DbgCodeProfiler;\r\n\r\ninterface\r\n\r\nuses System.Classes, WinApi.Windows, Collections.Queues, DbgHookTypes,\r\n System.SysUtils, System.SyncObjs, DebugerTypes;\r\n\r\ntype\r\n TTrackPointInfo = class\r\n ThData: PThreadData;\r\n Address: Pointer;\r\n TrackRETBp: PTrackRETBreakpoint;\r\n CurThTime: UInt64;\r\n IsRetTrackPoint: LongBool;\r\n ParentFuncAddr: Pointer;\r\n FuncInfo: TObject;\r\n end;\r\n\r\n TTrackPointInfoQueue = class(TQueue);\r\n\r\n TDbgCodeProfiler = class\r\n private\r\n FTrackPointInfoQueue: TTrackPointInfoQueue;\r\n FTrackPointInfoQueueEvent: TEvent;\r\n\r\n FWorkerThread: TThread;\r\n\r\n DbgTrackBreakpoints: TTrackBreakpointList;\r\n DbgTrackRETBreakpoints: TTrackRETBreakpointList;\r\n public\r\n DbgCurTrackAddress: Pointer;\r\n\r\n constructor Create;\r\n destructor Destroy; override;\r\n\r\n procedure Clear;\r\n\r\n procedure SetTrackBreakpoint(const Address: Pointer; FuncInfo: TObject; const BPType: TTrackBreakpointType = tbTrackFunc);\r\n function SetTrackRETBreakpoint(const Address: Pointer): PTrackRETBreakpoint;\r\n\r\n procedure RemoveTrackBreakpoint(const Address: Pointer; const BPType: TTrackBreakpointType = tbTrackFunc);\r\n function ProcessTrackBreakPoint(DebugEvent: PDebugEvent): LongBool;\r\n function ProcessTrackRETBreakPoint(DebugEvent: PDebugEvent): LongBool;\r\n\r\n procedure RegisterRETTrackPoint(ThData: PThreadData; Address: Pointer; TrackRETBp: PTrackRETBreakpoint; const CurThTime: UInt64);\r\n procedure RegisterTrackPoint(ThData: PThreadData; Address, ParentFuncAddr: Pointer; FuncInfo: TObject; TrackRETBp: PTrackRETBreakpoint; const CurThTime: UInt64);\r\n\r\n procedure InitDbgTracking(const Capacity: Integer);\r\n procedure ClearDbgTracking;\r\n\r\n procedure StartWorkerThread;\r\n procedure StopWorkerThread;\r\n\r\n property TrackPointInfoQueue: TTrackPointInfoQueue read FTrackPointInfoQueue;\r\n property TrackPointInfoQueueEvent: TEvent read FTrackPointInfoQueueEvent;\r\n end;\r\n\r\n TDbgCodeProfilerWorkerThread = class(TThread)\r\n private\r\n FOwner: TDbgCodeProfiler;\r\n protected\r\n procedure Execute; override;\r\n public\r\n constructor Create(AOwner: TDbgCodeProfiler);\r\n end;\r\n\r\nimplementation\r\n\r\nuses\r\n DebugInfo, WinAPIUtils, Debuger, System.Contnrs;\r\n\r\n{ TDbgCodeProfiler }\r\n\r\nprocedure TDbgCodeProfiler.Clear;\r\nbegin\r\n ClearDbgTracking;\r\nend;\r\n\r\nprocedure TDbgCodeProfiler.ClearDbgTracking;\r\nbegin\r\n StopWorkerThread;\r\n\r\n if Assigned(DbgTrackBreakpoints) then\r\n begin\r\n DbgTrackBreakpoints.Clear;\r\n FreeAndNil(DbgTrackBreakpoints);\r\n end;\r\n\r\n if Assigned(DbgTrackRETBreakpoints) then\r\n begin\r\n DbgTrackRETBreakpoints.Clear;\r\n FreeAndNil(DbgTrackRETBreakpoints);\r\n end;\r\n\r\n if Assigned(FTrackPointInfoQueue) then\r\n begin\r\n FTrackPointInfoQueue.Clear;\r\n //FreeAndNil(FTrackPointInfoQueue);\r\n end;\r\nend;\r\n\r\nconstructor TDbgCodeProfiler.Create;\r\nbegin\r\n inherited;\r\n\r\n FTrackPointInfoQueue := TTrackPointInfoQueue.Create(4096, True);\r\n FTrackPointInfoQueueEvent := TEvent.Create(nil, False, False, '');\r\nend;\r\n\r\ndestructor TDbgCodeProfiler.Destroy;\r\nbegin\r\n Clear;\r\n\r\n FreeAndNil(FTrackPointInfoQueue);\r\n FreeAndNil(FTrackPointInfoQueueEvent);\r\n\r\n inherited;\r\nend;\r\n\r\nprocedure TDbgCodeProfiler.InitDbgTracking(const Capacity: Integer);\r\nbegin\r\n DbgTrackBreakpoints := TTrackBreakpointList.Create(Capacity * 2);\r\n DbgTrackBreakpoints.OwnsValues := True;\r\n\r\n DbgTrackRETBreakpoints := TTrackRETBreakpointList.Create(Capacity * 2);\r\n DbgTrackRETBreakpoints.OwnsValues := True;\r\n\r\n StartWorkerThread;\r\nend;\r\n\r\nprocedure TDbgCodeProfiler.RegisterTrackPoint(ThData: PThreadData; Address, ParentFuncAddr: Pointer; FuncInfo: TObject;\r\n TrackRETBp: PTrackRETBreakpoint; const CurThTime: UInt64);\r\nvar\r\n TrackFuncInfo: TCodeTrackFuncInfo;\r\n ParentCallFuncInfo: TCallFuncInfo;\r\n ParentFuncInfo: TFuncInfo;\r\n ParentTrackFuncInfo: TCodeTrackFuncInfo;\r\n\r\n TrackStackPoint: PTrackStackPoint;\r\nbegin\r\n // --- --- //\r\n Inc(ThData^.DbgTrackEventCount);\r\n\r\n TrackFuncInfo := TCodeTrackFuncInfo(ThData^.DbgTrackFuncList.GetTrackFuncInfo(FuncInfo));\r\n ThData^.DbgTrackUnitList.CheckTrackFuncInfo(TrackFuncInfo);\r\n\r\n TrackFuncInfo.IncCallCount;\r\n TrackFuncInfo.TrackUnitInfo.IncCallCount;\r\n\r\n // \r\n ParentCallFuncInfo := TrackFuncInfo.AddParentCall(ParentFuncAddr);\r\n\r\n // \r\n ParentTrackFuncInfo := nil;\r\n\r\n if Assigned(ParentCallFuncInfo) then\r\n begin\r\n ParentFuncInfo := TFuncInfo(ParentCallFuncInfo.FuncInfo);\r\n if Assigned(ParentFuncInfo) then\r\n begin\r\n ParentTrackFuncInfo := TCodeTrackFuncInfo(ThData^.DbgTrackFuncList.GetTrackFuncInfo(ParentFuncInfo));\r\n ThData^.DbgTrackUnitList.CheckTrackFuncInfo(ParentTrackFuncInfo);\r\n\r\n ParentTrackFuncInfo.AddChildCall(Address);\r\n end;\r\n end;\r\n\r\n // Track Stack\r\n TrackStackPoint := ThData^.DbgTrackStack.Push;\r\n\r\n TrackStackPoint^.TrackFuncInfo := TrackFuncInfo;\r\n TrackStackPoint^.ParentTrackFuncInfo := ParentTrackFuncInfo;\r\n TrackStackPoint^.TrackRETBreakpoint := TrackRETBp; // \r\n TrackStackPoint^.Enter := CurThTime;\r\n TrackStackPoint^.Elapsed := 0;\r\n\r\n // --- --- //\r\n TInterlocked.Increment(gvDebuger.ProcessData.DbgTrackEventCount);\r\n\r\n TrackFuncInfo := TCodeTrackFuncInfo(gvDebuger.ProcessData.DbgTrackFuncList.GetTrackFuncInfo(FuncInfo));\r\n gvDebuger.ProcessData.DbgTrackUnitList.CheckTrackFuncInfo(TrackFuncInfo);\r\n\r\n TrackFuncInfo.IncCallCount;\r\n TrackFuncInfo.TrackUnitInfo.IncCallCount;\r\n\r\n // \r\n ParentCallFuncInfo := TrackFuncInfo.AddParentCall(ParentFuncAddr);\r\n\r\n // \r\n ParentTrackFuncInfo := nil;\r\n\r\n if Assigned(ParentCallFuncInfo) then\r\n begin\r\n ParentFuncInfo := TFuncInfo(ParentCallFuncInfo.FuncInfo);\r\n if Assigned(ParentFuncInfo) then\r\n begin\r\n ParentTrackFuncInfo := TCodeTrackFuncInfo(gvDebuger.ProcessData.DbgTrackFuncList.GetTrackFuncInfo(ParentFuncInfo));\r\n gvDebuger.ProcessData.DbgTrackUnitList.CheckTrackFuncInfo(ParentTrackFuncInfo);\r\n\r\n ParentTrackFuncInfo.AddChildCall(Address);\r\n end;\r\n end;\r\n\r\n // \r\n TrackStackPoint^.ProcTrackFuncInfo := TrackFuncInfo;\r\n TrackStackPoint^.ProcParentTrackFuncInfo := ParentTrackFuncInfo;\r\nend;\r\n\r\nfunction TDbgCodeProfiler.ProcessTrackBreakPoint(DebugEvent: PDebugEvent): LongBool;\r\nvar\r\n ThData: PThreadData;\r\n Address: Pointer;\r\n TrackBp: PTrackBreakpoint;\r\n ParentFuncAddr: Pointer;\r\n TrackRETBreakpoint: PTrackRETBreakpoint;\r\n\r\n procedure _RegisterTrackPoint;\r\n var\r\n TrackPointInfo: TTrackPointInfo;\r\n begin\r\n TrackPointInfo := TTrackPointInfo.Create;\r\n\r\n TrackPointInfo.ThData := ThData;\r\n TrackPointInfo.Address := Address;\r\n TrackPointInfo.TrackRETBp := TrackRETBreakpoint;\r\n TrackPointInfo.CurThTime := _QueryThreadCycleTime(ThData^.ThreadHandle);\r\n TrackPointInfo.IsRetTrackPoint := False;\r\n TrackPointInfo.ParentFuncAddr := ParentFuncAddr;\r\n TrackPointInfo.FuncInfo := TrackBp^.FuncInfo;\r\n\r\n FTrackPointInfoQueue.Add(TrackPointInfo);\r\n FTrackPointInfoQueueEvent.SetEvent;\r\n end;\r\n\r\n procedure _RegisterFreeMemInfoPoint;\r\n var\r\n FuncInfo: TFuncInfo;\r\n MemInfo: TGetMemInfo;\r\n Param: TVarInfo;\r\n Addr: Pointer;\r\n begin\r\n FuncInfo := TFuncInfo(TrackBp^.FuncInfo);\r\n if (gvDebugInfo.MemoryManagerInfo.FreeMem = FuncInfo) or\r\n (gvDebugInfo.MemoryManagerInfo.ReallocMem = FuncInfo)\r\n then\r\n begin\r\n Param := TVarInfo(FuncInfo.Params[0]);\r\n Addr := Pointer(Integer(Param.Value));\r\n\r\n if gvDebuger.DbgMemoryProfiler.FindMemoryPointer(Addr, ThData, MemInfo) then\r\n begin\r\n Dec(ThData^.DbgGetMemInfoSize, MemInfo.Size);\r\n\r\n Dec(gvDebuger.ProcessData.ProcessGetMemCount);\r\n Dec(gvDebuger.ProcessData.ProcessGetMemSize, MemInfo.Size);\r\n\r\n ThData^.DbgGetMemInfo.Remove(Addr);\r\n end;\r\n end;\r\n end;\r\n\r\nbegin\r\n if gvDebuger.UpdateCurThreadContext then\r\n begin\r\n ThData := gvDebuger.CurThreadData;\r\n\r\n Address := DebugEvent^.Exception.ExceptionRecord.ExceptionAddress;\r\n if DbgTrackBreakpoints.TryGetValue(Address, TrackBp) then\r\n begin\r\n // \r\n ParentFuncAddr := nil;\r\n Check(gvDebuger.ReadData(Pointer(ThData^.Context^.Esp), @ParentFuncAddr, SizeOf(Pointer)));\r\n\r\n // \r\n TrackRETBreakpoint := SetTrackRETBreakpoint(ParentFuncAddr);\r\n TrackRETBreakpoint^.FuncInfo := TrackBp^.FuncInfo;\r\n TrackRETBreakpoint^.BPType := TrackBp^.BPType;\r\n\r\n // Code byte \r\n DbgCurTrackAddress := Address;\r\n gvDebuger.RemoveBreakpoint(Address, TrackBp^.SaveByte);\r\n gvDebuger.SetSingleStepMode(ThData, True);\r\n\r\n // --- --- //\r\n if tbTrackFunc in TrackBp^.BPType then\r\n _RegisterTrackPoint;\r\n\r\n if tbMemInfo in TrackBp^.BPType then\r\n _RegisterFreeMemInfoPoint;\r\n\r\n // \r\n Exit(True);\r\n end;\r\n end;\r\n\r\n // Track Breakpoint\r\n Exit(False);\r\nend;\r\n\r\nprocedure TDbgCodeProfiler.RegisterRETTrackPoint(ThData: PThreadData; Address: Pointer; TrackRETBp: PTrackRETBreakpoint; const CurThTime: UInt64);\r\nvar\r\n TrackStackPoint: PTrackStackPoint;\r\n FuncAddress: Pointer;\r\n CallFuncInfo: TCallFuncInfo;\r\nbegin\r\n // Track- \r\n while ThData^.DbgTrackStack.Count > 0 do\r\n begin\r\n TrackStackPoint := ThData^.DbgTrackStack.Pop;\r\n\r\n // \r\n TrackStackPoint^.Leave := CurThTime;\r\n // Thread\r\n TrackStackPoint^.TrackFuncInfo.GrowElapsed(TrackStackPoint^.Elapsed);\r\n // Proc\r\n TrackStackPoint^.ProcTrackFuncInfo.GrowElapsed(TrackStackPoint^.Elapsed);\r\n\r\n // \r\n // Thread\r\n if TrackStackPoint^.TrackFuncInfo.ParentFuncs.TryGetValue(Address, CallFuncInfo) then\r\n Inc(CallFuncInfo.Data, TrackStackPoint^.Elapsed);\r\n\r\n // Proc\r\n if TrackStackPoint^.ProcTrackFuncInfo.ParentFuncs.TryGetValue(Address, CallFuncInfo) then\r\n Inc(CallFuncInfo.Data, TrackStackPoint^.Elapsed);\r\n\r\n // \r\n // Thread\r\n if Assigned(TrackStackPoint^.ParentTrackFuncInfo) then\r\n begin\r\n FuncAddress := TFuncInfo(TrackStackPoint^.TrackFuncInfo.FuncInfo).Address;\r\n if TrackStackPoint^.ParentTrackFuncInfo.ChildFuncs.TryGetValue(FuncAddress, CallFuncInfo) then\r\n Inc(CallFuncInfo.Data, TrackStackPoint^.Elapsed);\r\n end;\r\n\r\n // Proc\r\n if Assigned(TrackStackPoint^.ProcParentTrackFuncInfo) then\r\n begin\r\n FuncAddress := TFuncInfo(TrackStackPoint^.ProcTrackFuncInfo.FuncInfo).Address;\r\n if TrackStackPoint^.ProcParentTrackFuncInfo.ChildFuncs.TryGetValue(FuncAddress, CallFuncInfo) then\r\n Inc(CallFuncInfo.Data, TrackStackPoint^.Elapsed);\r\n end;\r\n\r\n // - \r\n if TrackStackPoint^.TrackRETBreakpoint = TrackRETBp then\r\n begin\r\n // Dec(TrackRETBp.Count);\r\n Break;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TDbgCodeProfiler.ProcessTrackRETBreakPoint(DebugEvent: PDebugEvent): LongBool;\r\nvar\r\n ThData: PThreadData;\r\n Address: Pointer;\r\n TrackRETBp: PTrackRETBreakpoint;\r\n\r\n procedure _RegisterRETTrackPoint;\r\n var\r\n TrackPointInfo: TTrackPointInfo;\r\n begin\r\n TrackPointInfo := TTrackPointInfo.Create;\r\n\r\n TrackPointInfo.ThData := ThData;\r\n TrackPointInfo.Address := Address;\r\n TrackPointInfo.TrackRETBp := TrackRETBp;\r\n TrackPointInfo.CurThTime := _QueryThreadCycleTime(ThData^.ThreadHandle);\r\n TrackPointInfo.IsRetTrackPoint := True;\r\n\r\n FTrackPointInfoQueue.Add(TrackPointInfo);\r\n FTrackPointInfoQueueEvent.SetEvent;\r\n end;\r\n\r\n procedure _RegisterGetMemInfoPoint;\r\n var\r\n FuncInfo: TFuncInfo;\r\n ParamSize: TVarInfo;\r\n ParamAddr: TVarInfo;\r\n Addr: Pointer;\r\n Size: Cardinal;\r\n NewMemInfo: TGetMemInfo;\r\n begin\r\n FuncInfo := TFuncInfo(TrackRETBp^.FuncInfo);\r\n\r\n // Dec(TrackRETBp^.Count);\r\n\r\n ParamAddr := nil;\r\n ParamSize := nil;\r\n\r\n if (gvDebugInfo.MemoryManagerInfo.GetMem = FuncInfo) or\r\n (gvDebugInfo.MemoryManagerInfo.AllocMem = FuncInfo)\r\n then\r\n begin\r\n // GetMem: function(Size: NativeInt): Pointer;\r\n // AllocMem: function(Size: NativeInt): Pointer;\r\n\r\n ParamSize := TVarInfo(FuncInfo.Params[0]);\r\n\r\n ParamAddr := TVarInfo.Create;\r\n ParamAddr.DataType := FuncInfo.ResultType;\r\n ParamAddr.VarKind := vkRegister;\r\n end\r\n else\r\n if (gvDebugInfo.MemoryManagerInfo.ReallocMem = FuncInfo)\r\n then\r\n begin\r\n // ReallocMem: function(P: Pointer; Size: NativeInt): Pointer;\r\n\r\n ParamSize := TVarInfo(FuncInfo.Params[1]);\r\n\r\n ParamAddr := TVarInfo.Create;\r\n ParamAddr.DataType := FuncInfo.ResultType;\r\n ParamAddr.VarKind := vkRegister;\r\n end;\r\n\r\n if Assigned(ParamSize) and Assigned(ParamAddr) then\r\n begin\r\n Size := 1; //ParamSize.Value;\r\n Addr := Pointer(Integer(ParamAddr.Value));\r\n\r\n FreeAndNil(ParamAddr);\r\n\r\n // \r\n //NewMemInfo := AllocMem(SizeOf(RGetMemInfo));\r\n NewMemInfo := TGetMemInfo.Create;\r\n\r\n NewMemInfo.PerfIdx := gvDebuger.ProcessData.CurDbgPointIdx;\r\n NewMemInfo.ObjAddr := Addr;\r\n NewMemInfo.Size := Size;\r\n\r\n //NewMemInfo^.Stack := DbgMemInfo^.Stack;\r\n NewMemInfo.Stack[0] := nil;\r\n\r\n NewMemInfo.ObjectType := ''; // \r\n\r\n ThData^.DbgGetMemInfo.AddOrSetValue(Addr, NewMemInfo);\r\n Inc(ThData^.DbgGetMemInfoSize, NewMemInfo.Size);\r\n\r\n Inc(gvDebuger.ProcessData.ProcessGetMemCount);\r\n Inc(gvDebuger.ProcessData.ProcessGetMemSize, NewMemInfo.Size);\r\n end;\r\n end;\r\n\r\nbegin\r\n if gvDebuger.UpdateCurThreadContext then\r\n begin\r\n ThData := gvDebuger.CurThreadData;\r\n\r\n Address := DebugEvent^.Exception.ExceptionRecord.ExceptionAddress;\r\n if DbgTrackRETBreakpoints.TryGetValue(Address, TrackRETBp) and (TrackRETBp.Count > 0){???} then\r\n begin\r\n if tbTrackFunc in TrackRETBp^.BPType then\r\n _RegisterRETTrackPoint;\r\n\r\n if tbMemInfo in TrackRETBp^.BPType then\r\n _RegisterGetMemInfoPoint;\r\n\r\n // \r\n if TrackRETBp.Count > 0 then\r\n Dec(TrackRETBp.Count);\r\n\r\n // breakpoint \r\n if TrackRETBp.Count > 0 then\r\n DbgCurTrackAddress := Address;\r\n\r\n // byte-code \r\n gvDebuger.RemoveBreakpoint(Address, TrackRETBp^.SaveByte);\r\n\r\n //if TrackRETBp^.Count = 0 then\r\n // DbgTrackRETBreakpoints.Remove(Address);\r\n\r\n gvDebuger.SetSingleStepMode(ThData, True);\r\n\r\n Exit(True);\r\n end;\r\n end;\r\n\r\n Exit(False);\r\nend;\r\n\r\nprocedure TDbgCodeProfiler.RemoveTrackBreakpoint(const Address: Pointer; const BPType: TTrackBreakpointType);\r\nvar\r\n TrackBp: PTrackBreakpoint;\r\nbegin\r\n if DbgTrackBreakpoints.TryGetValue(Address, TrackBp) then\r\n begin\r\n Exclude(TrackBp^.BPType, BPType);\r\n\r\n if TrackBp^.BPType = [] then\r\n begin\r\n gvDebuger.RemoveBreakpoint(Address, TrackBp^.SaveByte);\r\n //DbgTrackBreakpoints.Remove(Address);\r\n end;\r\n end\r\n else\r\n RaiseDebugCoreException();\r\nend;\r\n\r\nprocedure TDbgCodeProfiler.SetTrackBreakpoint(const Address: Pointer; FuncInfo: TObject; const BPType: TTrackBreakpointType);\r\nvar\r\n TrackBk: PTrackBreakpoint;\r\nbegin\r\n if not DbgTrackBreakpoints.TryGetValue(Address, TrackBk) then\r\n begin\r\n TrackBk := AllocMem(SizeOf(TTrackBreakpoint));\r\n\r\n TrackBk^.FuncInfo := FuncInfo;\r\n TrackBk^.SaveByte := 0;\r\n\r\n TrackBk^.BPType := [];\r\n Include(TrackBk^.BPType, BPType);\r\n\r\n gvDebuger.SetBreakpoint(Address, TrackBk^.SaveByte);\r\n\r\n DbgTrackBreakpoints.Add(Address, TrackBk);\r\n end\r\n else\r\n Include(TrackBk^.BPType, BPType);\r\nend;\r\n\r\nfunction TDbgCodeProfiler.SetTrackRETBreakpoint(const Address: Pointer): PTrackRETBreakpoint;\r\nbegin\r\n if DbgTrackRETBreakpoints.TryGetValue(Address, Result) then\r\n begin\r\n Inc(Result^.Count);\r\n\r\n gvDebuger.RestoreBreakpoint(Address);\r\n end\r\n else\r\n begin\r\n Result := AllocMem(SizeOf(TTrackRETBreakpoint));\r\n\r\n Result^.Count := 1;\r\n\r\n Result^.SaveByte := 0;\r\n gvDebuger.SetBreakpoint(Address, Result^.SaveByte);\r\n\r\n Result^.BPType := [];\r\n\r\n DbgTrackRETBreakpoints.Add(Address, Result);\r\n end;\r\nend;\r\n\r\nprocedure TDbgCodeProfiler.StartWorkerThread;\r\nbegin\r\n if FWorkerThread = Nil then\r\n FWorkerThread := TDbgCodeProfilerWorkerThread.Create(Self);\r\nend;\r\n\r\nprocedure TDbgCodeProfiler.StopWorkerThread;\r\nbegin\r\n if Assigned(FWorkerThread) then\r\n begin\r\n FWorkerThread.Terminate;\r\n FTrackPointInfoQueueEvent.SetEvent;\r\n\r\n FWorkerThread.WaitFor;\r\n FreeAndNil(FWorkerThread);\r\n end;\r\nend;\r\n\r\n{ TDbgCodeProfilerWorkerThread }\r\n\r\nconstructor TDbgCodeProfilerWorkerThread.Create(AOwner: TDbgCodeProfiler);\r\nbegin\r\n inherited Create(False);\r\n FreeOnTerminate := False;\r\n\r\n FOwner := AOwner;\r\nend;\r\n\r\nprocedure TDbgCodeProfilerWorkerThread.Execute;\r\nvar\r\n TrackPointInfo: TTrackPointInfo;\r\nbegin\r\n while not Terminated do\r\n begin\r\n FOwner.TrackPointInfoQueueEvent.WaitFor;\r\n\r\n while not Terminated and (FOwner.TrackPointInfoQueue.Count > 0) do\r\n begin\r\n TrackPointInfo := FOwner.TrackPointInfoQueue.Dequeue;\r\n try\r\n with TrackPointInfo do\r\n begin\r\n if IsRetTrackPoint then\r\n FOwner.RegisterRETTrackPoint(ThData, Address, TrackRETBp, CurThTime)\r\n else\r\n FOwner.RegisterTrackPoint(ThData, Address, ParentFuncAddr, FuncInfo, TrackRETBp, CurThTime);\r\n end;\r\n finally\r\n FreeAndNil(TrackPointInfo);\r\n end;\r\n end;\r\n\r\n if not Terminated then\r\n Sleep(500);\r\n end;\r\nend;\r\n\r\nend.\r\n" }, { "path": "DbgHook32.dpr", "content": "library DbgHook32;\r\n\r\nuses\r\n Windows,\r\n DbgHookTypes in 'DbgHookTypes.pas',\r\n DbgHookThread in 'DbgHookThread.pas',\r\n DbgHookPerf in 'DbgHookPerf.pas',\r\n DbgHookMemory in 'DbgHookMemory.pas',\r\n DbgHookSyncObjs in 'DbgHookSyncObjs.pas',\r\n DbgHookCS in 'DbgHookCS.pas',\r\n DbgHookUtils in 'DbgHookUtils.pas',\r\n WinAPIUtils in 'WinAPIUtils.pas',\r\n KOLDetours in 'External\\KOLDetours.pas';\r\n\r\nexports\r\n InitThreadHook,\r\n InitSyncObjsHook,\r\n InitMemoryHook,\r\n InitPerfomance,\r\n\r\n ResetThreadHook,\r\n ResetSyncObjsHook,\r\n ResetMemoryHook,\r\n ResetPerfomance;\r\n\r\nprocedure _HookDLLProc(Reason: Integer);\r\nbegin\r\n if Reason = DLL_PROCESS_DETACH then\r\n begin\r\n ResetPerfomance;\r\n ResetMemoryHook;\r\n ResetSyncObjsHook;\r\n ResetThreadHook;\r\n end;\r\nend;\r\n\r\nbegin\r\n DllProc := @_HookDLLProc;\r\nend.\r\n" }, { "path": "DbgHook32.dproj", "content": "\r\n \r\n {5769B713-B63C-48E8-8145-EF5BBB15C728}\r\n 14.6\r\n DbgHook32.dpr\r\n Release\r\n DCC32\r\n None\r\n True\r\n Win32\r\n 1\r\n Library\r\n \r\n \r\n true\r\n \r\n \r\n true\r\n Base\r\n true\r\n \r\n \r\n true\r\n Base\r\n true\r\n \r\n \r\n 3\r\n true\r\n None\r\n CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments=\r\n System;Xml;Data;Datasnap;Web;Soap;Winapi;$(DCC_Namespace)\r\n 1049\r\n dcu_hook\r\n true\r\n true\r\n DbgHook32.dll\r\n false\r\n false\r\n vclx;vcl;vclimg;dbrtl;Rave77VCL;bdertl;rtl;vclactnband;vcldb;vcldbx;vcltouch;xmlrtl;dsnap;dsnapcon;TeeUI;Tee;TeeDB;vclib;ibxpress;adortl;IndyCore;IndySystem;IndyProtocols;inet;intrawebdb_100_140;Intraweb_100_140;VclSmp;vclie;websnap;webdsnap;inetdb;inetdbbde;inetdbxpress;soaprtl;vclribbon;dbexpress;DbxCommonDriver;DataSnapIndy10ServerTransport;DataSnapProviderClient;DataSnapServer;DbxClientDriver;DBXInterBaseDriver;DBXMySQLDriver;dbxcds;DBXFirebirdDriver;DBXSybaseASEDriver;DBXSybaseASADriver;DBXOracleDriver;DBXMSSQLDriver;DBXInformixDriver;DBXDb2Driver;GanttPackage;JclDeveloperTools;Jcl;JclVcl;JclContainers;JvCore;JvSystem;JvStdCtrls;JvAppFrm;JvBands;JvDB;JvDlgs;JvBDE;JvControls;JvCmp;JvCrypt;JvCustom;JvDocking;JvDotNetCtrls;JvGlobus;JvHMI;JvJans;JvManagedThreads;JvMM;JvNet;JvPageComps;JvPascalInterpreter;JvPluginSystem;JvPrintPreview;JvRuntimeDesign;JvTimeFramework;JvWizards;JvXPCtrls;VirtualTreesR;$(DCC_UsePackage)\r\n 00400000\r\n x86\r\n false\r\n false\r\n false\r\n true\r\n \r\n \r\n RELEASE;$(DCC_Define)\r\n \r\n \r\n DEBUG;$(DCC_Define)\r\n \r\n \r\n \r\n MainSource\r\n \r\n \r\n \r\n \r\n \r\n \r\n \r\n \r\n \r\n \r\n Cfg_2\r\n Base\r\n \r\n \r\n Base\r\n \r\n \r\n Cfg_1\r\n Base\r\n \r\n \r\n \r\n \r\n Delphi.Personality.12\r\n \r\n \r\n \r\n \r\n DbgHook32.dpr\r\n \r\n \r\n False\r\n True\r\n False\r\n C:\\Projects\\dbg-spider\\Spider.exe\r\n C:\\Projects\\dbg-spider\r\n \r\n \r\n False\r\n False\r\n 1\r\n 0\r\n 0\r\n 0\r\n False\r\n False\r\n False\r\n False\r\n False\r\n 1049\r\n 1251\r\n \r\n \r\n \r\n \r\n 1.0.0.0\r\n \r\n \r\n \r\n \r\n \r\n 1.0.0.0\r\n \r\n \r\n \r\n Microsoft Office 2000 Sample Automation Server Wrapper Components\r\n Microsoft Office XP Sample Automation Server Wrapper Components\r\n \r\n \r\n \r\n False\r\n True\r\n False\r\n \r\n \r\n 12\r\n \r\n \r\n\r\n" }, { "path": "DbgHookCS.pas", "content": "unit DbgHookCS;\r\n\r\ninterface\r\n\r\nuses Windows;\r\n\r\ntype\r\n TDbgCriticalSection = class\r\n private\r\n FLock: TRTLCriticalSection;\r\n public\r\n constructor Create;\r\n destructor Destroy; override;\r\n\r\n procedure Enter;\r\n procedure Leave;\r\n\r\n function TryEnter: LongBool;\r\n end;\r\n\r\n\r\nimplementation\r\n\r\nuses DbgHookSyncObjs;\r\n\r\n{ TDbgCriticalSection }\r\n\r\nconstructor TDbgCriticalSection.Create;\r\nbegin\r\n inherited;\r\n\r\n InitializeCriticalSection(FLock);\r\nend;\r\n\r\ndestructor TDbgCriticalSection.Destroy;\r\nbegin\r\n DeleteCriticalSection(FLock);\r\n inherited;\r\nend;\r\n\r\nprocedure TDbgCriticalSection.Enter;\r\nbegin\r\n if SyncObjsHooked and Assigned(Kernel32_EnterCriticalSection) then\r\n Kernel32_EnterCriticalSection(FLock)\r\n else\r\n EnterCriticalSection(FLock);\r\nend;\r\n\r\nprocedure TDbgCriticalSection.Leave;\r\nbegin\r\n if SyncObjsHooked and Assigned(Kernel32_LeaveCriticalSection) then\r\n Kernel32_LeaveCriticalSection(FLock)\r\n else\r\n LeaveCriticalSection(FLock);\r\nend;\r\n\r\nfunction TDbgCriticalSection.TryEnter: LongBool;\r\nbegin\r\n Result := TryEnterCriticalSection(FLock);\r\nend;\r\n\r\nend.\r\n" }, { "path": "DbgHookMemory.pas", "content": "unit DbgHookMemory;\r\n\r\ninterface\r\n\r\nuses DbgHookTypes, DbgHookCS;\r\n\r\nprocedure InitMemoryHook(MemoryMgr: Pointer; MemoryCallStack: LongBool); stdcall;\r\nprocedure ResetMemoryHook; stdcall;\r\n\r\nfunction _OutMemInfoBuf(const DbgInfoType: TDbgInfoType = dstMemInfo): LongBool;\r\n\r\nvar\r\n MemInfoLock: TDbgCriticalSection = nil;\r\n MemInfoList: PDbgMemInfoList = nil;\r\n MemInfoListCnt: Integer = 0;\r\n\r\nimplementation\r\n\r\nuses WinApi.Windows, System.SysUtils, DbgHookUtils;\r\n\r\nvar\r\n _BaseMemoryMgr: TMemoryManagerEx;\r\n _HookMemoryMgr: TMemoryManagerEx;\r\n\r\n MemCallStack: LongBool = False;\r\n\r\n MemLock: TDbgCriticalSection = nil;\r\n\r\n _MemoryMgr: PMemoryManagerEx = nil;\r\n\r\ntype\r\n TMemSize = NativeInt;\r\n\r\nfunction _HookGetMem(Size: TMemSize): Pointer; forward;\r\nfunction _HookFreeMem(P: Pointer): Integer; forward;\r\nfunction _HookReallocMem(P: Pointer; Size: TMemSize): Pointer; forward;\r\nfunction _HookAllocMem(Size: TMemSize): Pointer; forward;\r\n\r\ntype\r\n PMemOutDbgInfo = ^TMemOutDbgInfo;\r\n TMemOutDbgInfo = array[0..2] of NativeUInt;\r\n\r\nthreadvar\r\n _MemOutDbgInfo: TMemOutDbgInfo;\r\n\r\nprocedure _MemOutInfo(const DbgInfoType: TDbgInfoType; Ptr: Pointer; const Count: NativeUInt);\r\nvar\r\n MemOutDbgInfo: PMemOutDbgInfo;\r\nbegin\r\n MemOutDbgInfo := @_MemOutDbgInfo;\r\n MemOutDbgInfo[0] := NativeUInt(DbgInfoType);\r\n MemOutDbgInfo[1] := NativeUInt(Ptr);\r\n MemOutDbgInfo[2] := NativeUInt(Count);\r\n\r\n RaiseException(DBG_EXCEPTION, 0, 3, @MemOutDbgInfo[0]);\r\nend;\r\n\r\nprocedure _SetMemHookStatus(const Status: NativeUInt);\r\nvar\r\n MemOutDbgInfo: PMemOutDbgInfo;\r\nbegin\r\n MemOutDbgInfo := @_MemOutDbgInfo;\r\n MemOutDbgInfo[0] := NativeUInt(dstMemHookStatus);\r\n MemOutDbgInfo[1] := Status;\r\n MemOutDbgInfo[2] := 0;\r\n\r\n RaiseException(DBG_EXCEPTION, 0, 2, @MemOutDbgInfo[0]);\r\nend;\r\n\r\nfunction _OutMemInfoBuf(const DbgInfoType: TDbgInfoType = dstMemInfo): LongBool;\r\nbegin\r\n Result := False;\r\n\r\n if MemInfoList = Nil then Exit;\r\n if MemInfoLock = Nil then Exit;\r\n\r\n MemInfoLock.Enter;\r\n try\r\n if MemInfoListCnt > 0 then\r\n begin\r\n _MemOutInfo(DbgInfoType, @MemInfoList^[0], MemInfoListCnt);\r\n MemInfoListCnt := 0; // \r\n\r\n Result := True;\r\n end;\r\n finally\r\n MemInfoLock.Leave;\r\n end;\r\nend;\r\n\r\nthreadvar\r\n _DbgMemInfo: TDbgMemInfo;\r\n\r\nprocedure _AddMemInfo(const _MemInfoType: TDbgMemInfoType; const _Ptr: Pointer; const _Size: Cardinal); stdcall;\r\nvar\r\n DbgMemInfo: PDbgMemInfo;\r\nbegin\r\n if MemInfoLock = Nil then Exit;\r\n if MemInfoList = Nil then Exit;\r\n\r\n DbgMemInfo := @_DbgMemInfo;\r\n ZeroMemory(DbgMemInfo, SizeOf(TDbgMemInfo));\r\n\r\n DbgMemInfo.Ptr := _Ptr;\r\n DbgMemInfo.ThreadId := GetCurrentThreadId;\r\n DbgMemInfo.MemInfoType := _MemInfoType;\r\n case DbgMemInfo.MemInfoType of\r\n miGetMem:\r\n begin\r\n DbgMemInfo.Size := _Size;\r\n //GetCallStack(DbgMemInfo.Stack, -2);\r\n GetCallStackOS(DbgMemInfo.Stack, 3);\r\n end;\r\n miFreeMem:\r\n begin\r\n DbgMemInfo.ObjClassType[0] := #0;\r\n end;\r\n end;\r\n\r\n MemInfoLock.Enter;\r\n if MemInfoList <> Nil then\r\n begin\r\n MemInfoList^[MemInfoListCnt] := DbgMemInfo^;\r\n Inc(MemInfoListCnt);\r\n\r\n if MemInfoListCnt = _DbgMemListLength then\r\n _OutMemInfoBuf;\r\n end;\r\n MemInfoLock.Leave;\r\nend;\r\n\r\n{.$DEFINE MEMLOCK}\r\n\r\nfunction _HookGetMem(Size: TMemSize): Pointer;\r\nbegin\r\n {$IFDEF MEMLOCK}\r\n MemLock.Enter;\r\n try\r\n {$ENDIF}\r\n Result := _BaseMemoryMgr.GetMem(Size);\r\n\r\n if Size >= SizeOf(Cardinal) then\r\n PCardinal(Result)^ := $00000000; // TObject\r\n\r\n _AddMemInfo(miGetMem, Result, Size);\r\n {$IFDEF MEMLOCK}\r\n finally\r\n MemLock.Leave;\r\n end;\r\n {$ENDIF}\r\nend;\r\n\r\nfunction _HookFreeMem(P: Pointer): Integer;\r\nbegin\r\n {$IFDEF MEMLOCK}\r\n MemLock.Enter;\r\n try\r\n {$ENDIF}\r\n _AddMemInfo(miFreeMem, P, 0);\r\n\r\n // !!! \r\n //PCardinal(P)^ := $00000000; // TObject\r\n\r\n Result := _BaseMemoryMgr.FreeMem(P);\r\n {$IFDEF MEMLOCK}\r\n finally\r\n MemLock.Leave;\r\n end;\r\n {$ENDIF}\r\nend;\r\n\r\nfunction _HookReallocMem(P: Pointer; Size: TMemSize): Pointer;\r\nbegin\r\n {$IFDEF MEMLOCK}\r\n MemLock.Enter;\r\n try\r\n {$ENDIF}\r\n _AddMemInfo(miFreeMem, P, 0);\r\n\r\n Result := _BaseMemoryMgr.ReallocMem(P, Size);\r\n\r\n _AddMemInfo(miGetMem, Result, Size);\r\n {$IFDEF MEMLOCK}\r\n finally\r\n MemLock.Leave;\r\n end;\r\n {$ENDIF}\r\nend;\r\n\r\nfunction _HookAllocMem(Size: TMemSize): Pointer;\r\nbegin\r\n {$IFDEF MEMLOCK}\r\n MemLock.Enter;\r\n try\r\n {$ENDIF}\r\n Result := _BaseMemoryMgr.AllocMem(Size);\r\n\r\n _AddMemInfo(miGetMem, Result, Size);\r\n {$IFDEF MEMLOCK}\r\n finally\r\n MemLock.Leave;\r\n end;\r\n {$ENDIF}\r\nend;\r\n\r\nprocedure InitMemoryHook(MemoryMgr: Pointer; MemoryCallStack: LongBool); stdcall;\r\nbegin\r\n _Log('Init memory hooks...');\r\n\r\n MemInfoListCnt := 0;\r\n MemCallStack := MemoryCallStack;\r\n\r\n MemLock := TDbgCriticalSection.Create;\r\n\r\n MemInfoList := AllocMem(SizeOf(TDbgMemInfoList));\r\n MemInfoLock := TDbgCriticalSection.Create;\r\n\r\n _HookMemoryMgr.GetMem := _HookGetMem;\r\n _HookMemoryMgr.FreeMem := _HookFreeMem;\r\n _HookMemoryMgr.ReallocMem := _HookReallocMem;\r\n _HookMemoryMgr.AllocMem := _HookAllocMem;\r\n\r\n _MemoryMgr := MemoryMgr;\r\n\r\n _BaseMemoryMgr.GetMem := _MemoryMgr^.GetMem;\r\n _BaseMemoryMgr.FreeMem := _MemoryMgr^.FreeMem;\r\n _BaseMemoryMgr.ReallocMem := _MemoryMgr^.ReallocMem;\r\n _BaseMemoryMgr.AllocMem := _MemoryMgr^.AllocMem;\r\n\r\n MemLock.Enter;\r\n MemInfoLock.Enter;\r\n\r\n _MemoryMgr^.GetMem := _HookMemoryMgr.GetMem;\r\n _MemoryMgr^.FreeMem := _HookMemoryMgr.FreeMem;\r\n _MemoryMgr^.ReallocMem := _HookMemoryMgr.ReallocMem;\r\n _MemoryMgr^.AllocMem := _HookMemoryMgr.AllocMem;\r\n\r\n MemInfoLock.Leave;\r\n MemLock.Leave;\r\n\r\n // _SetMemHookStatus(0);\r\n\r\n _Log('Init memory hooks - ok');\r\nend;\r\n\r\nprocedure ResetMemoryHook; stdcall;\r\nbegin\r\n try\r\n if _MemoryMgr = nil then Exit;\r\n if MemInfoLock = nil then Exit;\r\n\r\n // \r\n MemInfoLock.Enter;\r\n try\r\n _MemoryMgr^ := _BaseMemoryMgr;\r\n _MemoryMgr := Nil;\r\n\r\n _SetMemHookStatus(1);\r\n finally\r\n MemInfoLock.Leave;\r\n end;\r\n\r\n while not MemInfoLock.TryEnter do\r\n SwitchToThread;\r\n try\r\n // \r\n _OutMemInfoBuf(dstMemInfo);\r\n\r\n FreeMemory(MemInfoList);\r\n MemInfoList := Nil;\r\n finally\r\n MemInfoLock.Leave;\r\n end;\r\n\r\n FreeAndNil(MemInfoLock);\r\n\r\n FreeAndNil(MemLock);\r\n\r\n _Log('Reset memory hooks - ok');\r\n except\r\n on E: Exception do\r\n _Log('Reset memory hooks fail: ' + E.Message);\r\n end;\r\nend;\r\n\r\nend.\r\n" }, { "path": "DbgHookPerf.pas", "content": "unit DbgHookPerf;\r\n\r\ninterface\r\n\r\nprocedure InitPerfomance(Delta: Cardinal); stdcall;\r\nprocedure ResetPerfomance; stdcall;\r\n\r\nimplementation\r\n\r\nuses WinApi.Windows, System.Classes, System.SysUtils, DbgHookTypes, DbgHookMemory, DbgHookSyncObjs, DbgHookUtils,\r\n DbgHookCS;\r\n\r\ntype\r\n POutDbgInfo = ^TOutDbgInfo;\r\n TOutDbgInfo = array[0..4] of NativeUInt;\r\n\r\nvar\r\n _Delta: Cardinal = 0;\r\n\r\n _TimerQueue: THandle = 0;\r\n _OutDbgInfoTimer: THandle = 0;\r\n _SamplingTimer: THandle = 0;\r\n\r\n _IsSetOutDbgInfoThreadName: LongBool = False;\r\n _DbgInfoPerfomance: NativeUInt = NativeUInt(dstPerfomance);\r\n _DbgOutLock: TDbgCriticalSection = Nil;\r\n\r\n _OutDbgInfoRec: TOutDbgInfo;\r\n\r\nprocedure _OutDbgInfo(Context: Pointer; Success: LongBool); stdcall;\r\nconst\r\n _DBG_THREAD_NAME = '### DbgInfo control thread';\r\nbegin\r\n if _DbgOutLock.TryEnter then // , \r\n try\r\n if not _IsSetOutDbgInfoThreadName then\r\n begin\r\n _IsSetOutDbgInfoThreadName := True;\r\n TThread.NameThreadForDebugging(_DBG_THREAD_NAME, GetCurrentThreadId);\r\n end;\r\n\r\n ZeroMemory(@_OutDbgInfoRec[0], SizeOf(TOutDbgInfo));\r\n\r\n if MemInfoLock <> Nil then\r\n MemInfoLock.Enter;\r\n\r\n if SyncObjsInfoLock <> Nil then\r\n SyncObjsInfoLock.Enter;\r\n\r\n try\r\n _OutDbgInfoRec[0] := NativeUInt(dstPerfomanceAndInfo);\r\n\r\n if (MemInfoListCnt > 0) and (MemInfoList <> Nil) then\r\n begin\r\n _OutDbgInfoRec[1] := NativeUInt(@MemInfoList^[0]);\r\n _OutDbgInfoRec[2] := NativeUInt(MemInfoListCnt);\r\n end;\r\n\r\n if (SyncObjsInfoListCnt > 0) and (SyncObjsInfoList <> Nil) then\r\n begin\r\n _OutDbgInfoRec[3] := NativeUInt(@SyncObjsInfoList^[0]);\r\n _OutDbgInfoRec[4] := NativeUInt(SyncObjsInfoListCnt);\r\n end;\r\n\r\n RaiseException(DBG_EXCEPTION, 0, 5, @_OutDbgInfoRec[0]);\r\n\r\n MemInfoListCnt := 0;\r\n SyncObjsInfoListCnt := 0;\r\n finally\r\n if SyncObjsInfoLock <> Nil then\r\n SyncObjsInfoLock.Leave;\r\n\r\n if MemInfoLock <> Nil then\r\n MemInfoLock.Leave;\r\n end;\r\n finally\r\n _DbgOutLock.Leave;\r\n end;\r\nend;\r\n\r\nprocedure InitPerfomance(Delta: Cardinal); stdcall;\r\nbegin\r\n _Delta := Delta;\r\n\r\n _DbgOutLock := TDbgCriticalSection.Create;\r\n\r\n _TimerQueue := CreateTimerQueue;\r\n if _TimerQueue <> 0 then\r\n begin\r\n if CreateTimerQueueTimer(_OutDbgInfoTimer, _TimerQueue, @_OutDbgInfo, nil, _Delta, _Delta, WT_EXECUTEINTIMERTHREAD or WT_EXECUTEINPERSISTENTTHREAD) then\r\n _Log(Format('Init perfomance timer (%d msec) - ok', [_Delta]))\r\n else\r\n _Log(Format('Init perfomance timer (%d msec) - fail', [_Delta]));\r\n end\r\n else\r\n _Log('Init timer queue - fail');\r\nend;\r\n\r\nprocedure ResetPerfomance; stdcall;\r\nbegin\r\n try\r\n if DeleteTimerQueue(_TimerQueue) then\r\n _Log('Reset perfomance timer queue - ok')\r\n else\r\n _Log('Reset perfomance timer queue - fail');\r\n\r\n FreeAndNil(_DbgOutLock);\r\n except\r\n on E: Exception do\r\n _Log('Reset perfomance thread fail: ' + E.Message);\r\n end;\r\nend;\r\n\r\nend.\r\n" }, { "path": "DbgHookSyncObjs.pas", "content": "unit DbgHookSyncObjs;\r\n\r\ninterface\r\n\r\nuses WinApi.Windows, DbgHookCS, DbgHookTypes;\r\n\r\ntype\r\n TKernel32_Sleep =\r\n procedure (milliseconds: Cardinal); stdcall;\r\n TKernel32_SleepEx =\r\n function (dwMilliseconds: DWORD; bAlertable: BOOL): DWORD; stdcall;\r\n\r\n TKernel32_EnterCriticalSection =\r\n procedure (var lpCriticalSection: TRTLCriticalSection); stdcall;\r\n TKernel32_LeaveCriticalSection =\r\n procedure (var lpCriticalSection: TRTLCriticalSection); stdcall;\r\n\r\n TKernel32_WaitForSingleObject =\r\n function (hHandle: THandle; dwMilliseconds: DWORD): DWORD; stdcall;\r\n TKernel32_WaitForSingleObjectEx =\r\n function (hHandle: THandle; dwMilliseconds: DWORD; bAlertable: BOOL): DWORD; stdcall;\r\n TKernel32_WaitForMultipleObjects =\r\n function (nCount: DWORD; lpHandles: PWOHandleArray; bWaitAll: BOOL; dwMilliseconds: DWORD): DWORD; stdcall;\r\n TKernel32_WaitForMultipleObjectsEx =\r\n function (nCount: DWORD; lpHandles: PWOHandleArray; bWaitAll: BOOL; dwMilliseconds: DWORD; bAlertable: BOOL): DWORD; stdcall;\r\n\r\n TKernel32_SendMessageA =\r\n function (hWnd: HWND; Msg: UINT; wParam: WPARAM; lParam: LPARAM): LRESULT; stdcall;\r\n TKernel32_SendMessageW =\r\n function (hWnd: HWND; Msg: UINT; wParam: WPARAM; lParam: LPARAM): LRESULT; stdcall;\r\n TKernel32_SendMessageTimeoutA =\r\n function (hWnd: HWND; Msg: UINT; wParam: WPARAM; lParam: LPARAM; fuFlags, uTimeout: UINT; lpdwResult: PDWORD_PTR): LRESULT; stdcall;\r\n TKernel32_SendMessageTimeoutW =\r\n function (hWnd: HWND; Msg: UINT; wParam: WPARAM; lParam: LPARAM; fuFlags, uTimeout: UINT; lpdwResult: PDWORD_PTR): LRESULT; stdcall;\r\n\r\n\r\nvar\r\n SyncObjsHooked: LongBool = False;\r\n\r\n Kernel32_Sleep: TKernel32_Sleep = nil;\r\n Kernel32_SleepEx: TKernel32_SleepEx = nil;\r\n\r\n Kernel32_EnterCriticalSection: TKernel32_EnterCriticalSection = nil;\r\n Kernel32_LeaveCriticalSection: TKernel32_LeaveCriticalSection = nil;\r\n\r\n Kernel32_WaitForSingleObject: TKernel32_WaitForSingleObject = nil;\r\n Kernel32_WaitForSingleObjectEx: TKernel32_WaitForSingleObjectEx = nil;\r\n Kernel32_WaitForMultipleObjects: TKernel32_WaitForMultipleObjects = nil;\r\n Kernel32_WaitForMultipleObjectsEx: TKernel32_WaitForMultipleObjectsEx = nil;\r\n\r\n Kernel32_SendMessageA: TKernel32_SendMessageA = Nil;\r\n Kernel32_SendMessageW: TKernel32_SendMessageW = Nil;\r\n Kernel32_SendMessageTimeoutA: TKernel32_SendMessageTimeoutA = Nil;\r\n Kernel32_SendMessageTimeoutW: TKernel32_SendMessageTimeoutW = Nil;\r\n\r\nfunction InitSyncObjsHook(ImageBase: Pointer): LongBool; stdcall;\r\nprocedure ResetSyncObjsHook; stdcall;\r\n\r\nprocedure _OutSyncObjsInfo;\r\n\r\nvar\r\n SyncObjsInfoList: PDbgSyncObjsInfoList = nil;\r\n SyncObjsInfoListCnt: Integer = 0;\r\n\r\n SyncObjsInfoLock: TDbgCriticalSection = nil;\r\n\r\nimplementation\r\n\r\nuses System.SysUtils, System.Classes, WinAPIUtils, JclPEImage{TODO: Remove JCL}, DBGHookUtils;\r\n\r\nvar\r\n SyncObjsId: Integer = 0;\r\n\r\ntype\r\n PSyncObjsOutDbgInfo = ^TSyncObjsOutDbgInfo;\r\n TSyncObjsOutDbgInfo = array[0..2] of NativeUInt;\r\n\r\nthreadvar\r\n _SyncObjsOutDbgInfo: TSyncObjsOutDbgInfo;\r\n\r\nprocedure _SyncObjsOutInfo(const DbgInfoType: TDbgInfoType; Ptr: Pointer; const Count: NativeUInt);\r\nvar\r\n SyncObjsOutDbgInfo: PSyncObjsOutDbgInfo;\r\nbegin\r\n SyncObjsOutDbgInfo := @_SyncObjsOutDbgInfo;\r\n\r\n SyncObjsOutDbgInfo[0] := NativeUInt(DbgInfoType);\r\n SyncObjsOutDbgInfo[1] := NativeUInt(Ptr);\r\n SyncObjsOutDbgInfo[2] := NativeUInt(Count);\r\n\r\n RaiseException(DBG_EXCEPTION, 0, 3, @SyncObjsOutDbgInfo[0]);\r\nend;\r\n\r\nprocedure _OutSyncObjsInfo;\r\nbegin\r\n if SyncObjsInfoList = Nil then Exit;\r\n if SyncObjsInfoLock = Nil then Exit;\r\n\r\n SyncObjsInfoLock.Enter;\r\n try\r\n if SyncObjsInfoListCnt > 0 then\r\n begin\r\n _SyncObjsOutInfo(dstSyncObjsInfo, @SyncObjsInfoList^[0], SyncObjsInfoListCnt);\r\n\r\n // \r\n SyncObjsInfoListCnt := 0;\r\n end;\r\n finally\r\n SyncObjsInfoLock.Leave;\r\n end;\r\nend;\r\n\r\n(*\r\nprocedure _AddToSyncObjsAdvInfo(const Data: NativeUInt);\r\nbegin\r\n _SyncObjsAdvInfoList^[_SyncObjsAdvInfoListCnt] := Data;\r\n\r\n Inc(_SyncObjsAdvInfoListCnt);\r\nend;\r\n\r\nprocedure _AddCSAdvInfo(const Id: NativeUInt; const Data: PRTLCriticalSection);\r\nvar\r\n SizeIdx: NativeUInt;\r\n\r\n procedure _AddCSDebugInfo(const CSDebugInfo: PRTLCriticalSectionDebug);\r\n var\r\n NextCS: PRTLCriticalSection;\r\n begin\r\n if Assigned(CSDebugInfo) then\r\n begin\r\n _AddToSyncObjsAdvInfo(NativeUInt(CSDebugInfo^.CriticalSection));\r\n\r\n Inc(_SyncObjsAdvInfoList^[SizeIdx]);\r\n\r\n if Assigned(CSDebugInfo^.ProcessLocksList.Flink) then\r\n begin\r\n NextCS := PRTLCriticalSection(NativeUInt(CSDebugInfo^.ProcessLocksList.Flink) - SizeOf(PRTLCriticalSection));\r\n _AddCSDebugInfo(NextCS^.DebugInfo);\r\n end;\r\n end;\r\n end;\r\n\r\nbegin\r\n if Assigned(Data) and (Data^.OwningThread <> 0) and (Data^.OwningThread <> GetCurrentThreadId) then\r\n begin\r\n _AddToSyncObjsAdvInfo(Id);\r\n\r\n SizeIdx := _SyncObjsAdvInfoListCnt;\r\n _AddToSyncObjsAdvInfo(0); // Size buf\r\n\r\n _AddCSDebugInfo(Data^.DebugInfo);\r\n end;\r\nend;\r\n\r\nprocedure _AddSyncObjsAdvInfo(const DbgSyncObjsType: TDbgSyncObjsType; const Id: NativeUInt; const Data: NativeUInt);\r\nbegin\r\n case DbgSyncObjsType of\r\n soEnterCriticalSection:\r\n _AddCSAdvInfo(Id, Pointer(Data));\r\n end;\r\nend;\r\n*)\r\n\r\nprocedure _AddCSAdvInfo(const SyncObjsInfo: PDbgSyncObjsInfo);\r\nbegin\r\n case SyncObjsInfo^.SyncObjsType of\r\n soEnterCriticalSection:\r\n case SyncObjsInfo^.SyncObjsStateType of\r\n sosEnter:\r\n begin\r\n // , CS\r\n if IsValidAddr(SyncObjsInfo^.CS) then\r\n SyncObjsInfo^.OwningThreadId := SyncObjsInfo^.CS^.OwningThread;\r\n end;\r\n end;\r\n soLeaveCriticalSection:\r\n case SyncObjsInfo^.SyncObjsStateType of\r\n sosLeave:\r\n begin\r\n // , CS\r\n if IsValidAddr(SyncObjsInfo^.CS) then\r\n SyncObjsInfo^.OwningThreadId := SyncObjsInfo^.CS^.OwningThread;\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure _AddSyncObjsAdvInfo(const SyncObjsInfo: PDbgSyncObjsInfo);\r\nbegin\r\n case SyncObjsInfo^.SyncObjsType of\r\n soEnterCriticalSection, soLeaveCriticalSection:\r\n _AddCSAdvInfo(SyncObjsInfo);\r\n end;\r\nend;\r\n\r\nprocedure _AddSyncObjsInfo(const DbgSyncObjsType: TDbgSyncObjsType; const DbgSyncObjsStateType: TDbgSyncObjsStateType;\r\n const Id: NativeUInt; const Data: NativeUInt); stdcall;\r\nvar\r\n SyncObjsInfo: PDbgSyncObjsInfo;\r\n CurTime: Int64;\r\nbegin\r\n if SyncObjsInfoList = Nil then Exit;\r\n if SyncObjsInfoLock = Nil then Exit;\r\n\r\n CurTime := _QueryPerformanceCounter;\r\n\r\n SyncObjsInfoLock.Enter;\r\n if SyncObjsInfoList <> Nil then\r\n begin\r\n SyncObjsInfo := @SyncObjsInfoList^[SyncObjsInfoListCnt];\r\n ZeroMemory(SyncObjsInfo, SizeOf(TDbgSyncObjsInfo));\r\n\r\n SyncObjsInfo^.Id := Id;\r\n SyncObjsInfo^.ThreadId := GetCurrentThreadId;\r\n SyncObjsInfo^.CurTime := CurTime;\r\n SyncObjsInfo^.SyncObjsStateType := DbgSyncObjsStateType;\r\n SyncObjsInfo^.SyncObjsType := DbgSyncObjsType;\r\n\r\n case SyncObjsInfo^.SyncObjsType of\r\n soSleep:\r\n SyncObjsInfo^.MSec := Data;\r\n soWaitForSingleObject:\r\n SyncObjsInfo^.Handle := THandle(Data);\r\n soWaitForMultipleObjects:\r\n SyncObjsInfo^.Handles := PWOHandleArray(Data);\r\n soEnterCriticalSection,\r\n soLeaveCriticalSection,\r\n soInCriticalSection:\r\n begin\r\n SyncObjsInfo^.CS := PRTLCriticalSection(Data);\r\n SyncObjsInfo^.OwningThreadId := 0;\r\n end;\r\n soSendMessage:\r\n SyncObjsInfo^.Msg := UINT(Data);\r\n end;\r\n\r\n if (DbgSyncObjsStateType = sosEnter) or\r\n // soInCriticalSection soEnterCriticalSection.sosEnter\r\n ((SyncObjsInfo^.SyncObjsType = soInCriticalSection) and (DbgSyncObjsStateType = sosLeave))\r\n then\r\n begin\r\n //GetCallStack(SyncObjsInfo^.Stack, -2);\r\n GetCallStackOS(SyncObjsInfo^.Stack, 3);\r\n end;\r\n\r\n _AddSyncObjsAdvInfo(SyncObjsInfo);\r\n\r\n Inc(SyncObjsInfoListCnt);\r\n\r\n if (SyncObjsInfoListCnt = _DbgSyncObjsListLength) then\r\n _OutSyncObjsInfo;\r\n end;\r\n SyncObjsInfoLock.Leave;\r\nend;\r\n\r\nprocedure _HookSleep(milliseconds: Cardinal); stdcall;\r\nvar\r\n Id: NativeUInt;\r\nbegin\r\n Id := NativeUInt(InterlockedIncrement(SyncObjsId));\r\n\r\n _AddSyncObjsInfo(soSleep, sosEnter, Id, milliseconds);\r\n\r\n Kernel32_Sleep(milliseconds);\r\n\r\n _AddSyncObjsInfo(soSleep, sosLeave, Id, milliseconds);\r\nend;\r\n\r\nfunction _HookSleepEx(dwMilliseconds: DWORD; bAlertable: BOOL): DWORD; stdcall;\r\nvar\r\n Id: NativeUInt;\r\nbegin\r\n Id := NativeUInt(InterlockedIncrement(SyncObjsId));\r\n\r\n _AddSyncObjsInfo(soSleep, sosEnter, Id, dwMilliseconds);\r\n\r\n Result := Kernel32_SleepEx(dwMilliseconds, bAlertable);\r\n\r\n _AddSyncObjsInfo(soSleep, sosLeave, Id, dwMilliseconds);\r\nend;\r\n\r\nprocedure _HookEnterCriticalSection(var lpCriticalSection: TRTLCriticalSection); stdcall;\r\nvar\r\n Id: NativeUInt;\r\nbegin\r\n //TODO:\r\n // Debug CriticalSections: http://msdn.microsoft.com/en-us/magazine/cc164040.aspx\r\n\r\n Id := NativeUInt(InterlockedIncrement(SyncObjsId));\r\n\r\n _AddSyncObjsInfo(soEnterCriticalSection, sosEnter, Id, NativeUInt(@lpCriticalSection));\r\n\r\n Kernel32_EnterCriticalSection(lpCriticalSection);\r\n\r\n _AddSyncObjsInfo(soEnterCriticalSection, sosLeave, Id, NativeUInt(@lpCriticalSection));\r\n\r\n _AddSyncObjsInfo(soInCriticalSection, sosEnter, Id, NativeUInt(@lpCriticalSection));\r\nend;\r\n\r\nprocedure _HookLeaveCriticalSection(var lpCriticalSection: TRTLCriticalSection); stdcall;\r\nvar\r\n Id: NativeUInt;\r\nbegin\r\n // sosEnter @lpCriticalSection\r\n _AddSyncObjsInfo(soInCriticalSection, sosLeave, 0, NativeUInt(@lpCriticalSection));\r\n\r\n Id := NativeUInt(InterlockedIncrement(SyncObjsId));\r\n\r\n _AddSyncObjsInfo(soLeaveCriticalSection, sosEnter, Id, NativeUInt(@lpCriticalSection));\r\n\r\n Kernel32_LeaveCriticalSection(lpCriticalSection);\r\n\r\n _AddSyncObjsInfo(soLeaveCriticalSection, sosLeave, Id, NativeUInt(@lpCriticalSection));\r\nend;\r\n\r\nfunction _HookWaitForSingleObject(hHandle: THandle; dwMilliseconds: DWORD): DWORD; stdcall;\r\nvar\r\n Id: NativeUInt;\r\nbegin\r\n Id := NativeUInt(InterlockedIncrement(SyncObjsId));\r\n\r\n _AddSyncObjsInfo(soWaitForSingleObject, sosEnter, Id, NativeUInt(hHandle));\r\n\r\n Result := Kernel32_WaitForSingleObject(hHandle, dwMilliseconds);\r\n\r\n _AddSyncObjsInfo(soWaitForSingleObject, sosLeave, Id, NativeUInt(hHandle));\r\nend;\r\n\r\nfunction _HookWaitForSingleObjectEx(hHandle: THandle; dwMilliseconds: DWORD; bAlertable: BOOL): DWORD; stdcall;\r\nvar\r\n Id: NativeUInt;\r\nbegin\r\n Id := NativeUInt(InterlockedIncrement(SyncObjsId));\r\n\r\n _AddSyncObjsInfo(soWaitForSingleObject, sosEnter, Id, NativeUInt(hHandle));\r\n\r\n Result := Kernel32_WaitForSingleObjectEx(hHandle, dwMilliseconds, bAlertable);\r\n\r\n _AddSyncObjsInfo(soWaitForSingleObject, sosLeave, Id, NativeUInt(hHandle));\r\nend;\r\n\r\nfunction _HookWaitForMultipleObjects(nCount: DWORD; lpHandles: PWOHandleArray; bWaitAll: BOOL; dwMilliseconds: DWORD): DWORD; stdcall;\r\nvar\r\n Id: NativeUInt;\r\nbegin\r\n Id := NativeUInt(InterlockedIncrement(SyncObjsId));\r\n\r\n _AddSyncObjsInfo(soWaitForMultipleObjects, sosEnter, Id, NativeUInt(Pointer(lpHandles)));\r\n\r\n Result := Kernel32_WaitForMultipleObjects(nCount, lpHandles, bWaitAll, dwMilliseconds);\r\n\r\n _AddSyncObjsInfo(soWaitForMultipleObjects, sosLeave, Id, NativeUInt(Pointer(lpHandles)));\r\nend;\r\n\r\nfunction _HookWaitForMultipleObjectsEx(nCount: DWORD; lpHandles: PWOHandleArray; bWaitAll: BOOL; dwMilliseconds: DWORD; bAlertable: BOOL): DWORD; stdcall;\r\nvar\r\n Id: NativeUInt;\r\nbegin\r\n Id := NativeUInt(InterlockedIncrement(SyncObjsId));\r\n\r\n _AddSyncObjsInfo(soWaitForMultipleObjects, sosEnter, Id, NativeUInt(Pointer(lpHandles)));\r\n\r\n Result := Kernel32_WaitForMultipleObjectsEx(nCount, lpHandles, bWaitAll, dwMilliseconds, bAlertable);\r\n\r\n _AddSyncObjsInfo(soWaitForMultipleObjects, sosLeave, Id, NativeUInt(Pointer(lpHandles)));\r\nend;\r\n\r\nfunction _HookSendMessageA(hWnd: HWND; Msg: UINT; wParam: WPARAM; lParam: LPARAM): LRESULT; stdcall;\r\nvar\r\n Id: NativeUInt;\r\nbegin\r\n Id := NativeUInt(InterlockedIncrement(SyncObjsId));\r\n\r\n _AddSyncObjsInfo(soSendMessage, sosEnter, Id, NativeUInt(Msg));\r\n\r\n Result := Kernel32_SendMessageA(hWnd, Msg, wParam, lParam);\r\n\r\n _AddSyncObjsInfo(soSendMessage, sosLeave, Id, NativeUInt(Msg));\r\nend;\r\n\r\nfunction _HookSendMessageW(hWnd: HWND; Msg: UINT; wParam: WPARAM; lParam: LPARAM): LRESULT; stdcall;\r\nvar\r\n Id: NativeUInt;\r\nbegin\r\n Id := NativeUInt(InterlockedIncrement(SyncObjsId));\r\n\r\n _AddSyncObjsInfo(soSendMessage, sosEnter, Id, NativeUInt(Msg));\r\n\r\n Result := Kernel32_SendMessageW(hWnd, Msg, wParam, lParam);\r\n\r\n _AddSyncObjsInfo(soSendMessage, sosLeave, Id, NativeUInt(Msg));\r\nend;\r\n\r\nfunction _HookSendMessageTimeoutA(hWnd: HWND; Msg: UINT; wParam: WPARAM; lParam: LPARAM; fuFlags, uTimeout: UINT; lpdwResult: PDWORD_PTR): LRESULT; stdcall;\r\nvar\r\n Id: NativeUInt;\r\nbegin\r\n Id := NativeUInt(InterlockedIncrement(SyncObjsId));\r\n\r\n _AddSyncObjsInfo(soSendMessage, sosEnter, Id, NativeUInt(Msg));\r\n\r\n Result := Kernel32_SendMessageTimeoutA(hWnd, Msg, wParam, lParam, fuFlags, uTimeout, lpdwResult);\r\n\r\n _AddSyncObjsInfo(soSendMessage, sosLeave, Id, NativeUInt(Msg));\r\nend;\r\n\r\nfunction _HookSendMessageTimeoutW(hWnd: HWND; Msg: UINT; wParam: WPARAM; lParam: LPARAM; fuFlags, uTimeout: UINT; lpdwResult: PDWORD_PTR): LRESULT; stdcall;\r\nvar\r\n Id: NativeUInt;\r\nbegin\r\n Id := NativeUInt(InterlockedIncrement(SyncObjsId));\r\n\r\n _AddSyncObjsInfo(soSendMessage, sosEnter, Id, NativeUInt(Msg));\r\n\r\n Result := Kernel32_SendMessageTimeoutW(hWnd, Msg, wParam, lParam, fuFlags, uTimeout, lpdwResult);\r\n\r\n _AddSyncObjsInfo(soSendMessage, sosLeave, Id, NativeUInt(Msg));\r\nend;\r\n\r\n\r\nvar\r\n _PeMapImgHooks: TJclPeMapImgHooks = Nil;\r\n _hKernel32: THandle = 0;\r\n _hUser32: THandle = 0;\r\n _ImageBase: Pointer = Nil;\r\n\r\nfunction _ReplaceImport(ModuleName: PWideChar; lpProcName: LPCSTR; HookProc: Pointer; var BaseProc: Pointer): LongBool;\r\nvar\r\n ProcAddr: Pointer;\r\n hModule: THandle;\r\nbegin\r\n Result := False;\r\n\r\n hModule := GetModuleHandle(ModuleName);\r\n if hModule = 0 then\r\n begin\r\n _Log(Format('GetModuleHandle \"%s\" - fail', [String(ModuleName)]));\r\n Exit;\r\n end;\r\n\r\n ProcAddr := GetProcAddress(hModule, lpProcName);\r\n if ProcAddr = Nil then\r\n begin\r\n _Log(Format('Hook %s - fail GetProcAddress', [String(lpProcName)]));\r\n Exit;\r\n end;\r\n\r\n if _PeMapImgHooks.ReplaceImport(_ImageBase, ModuleName, ProcAddr, HookProc) then\r\n begin\r\n BaseProc := ProcAddr;\r\n Result := True;\r\n\r\n _Log(Format('Hook %s - ok', [String(lpProcName)]));\r\n end\r\n else\r\n // \r\n _Log(Format('Hook %s - skip', [String(lpProcName)]));\r\nend;\r\n\r\nfunction _HookSyncObjs(ImageBase: Pointer): LongBool;\r\nbegin\r\n if not SyncObjsHooked then\r\n begin\r\n SyncObjsInfoLock := TDbgCriticalSection.Create;\r\n\r\n _PeMapImgHooks := TJclPeMapImgHooks.Create;\r\n\r\n _ImageBase := ImageBase;\r\n\r\n SyncObjsInfoLock.Enter;\r\n try\r\n _ReplaceImport(kernel32, 'Sleep', @_HookSleep, @Kernel32_Sleep);\r\n _ReplaceImport(kernel32, 'SleepEx', @_HookSleepEx, @Kernel32_SleepEx);\r\n\r\n _ReplaceImport(kernel32, 'EnterCriticalSection', @_HookEnterCriticalSection, @Kernel32_EnterCriticalSection);\r\n _ReplaceImport(kernel32, 'LeaveCriticalSection', @_HookLeaveCriticalSection, @Kernel32_LeaveCriticalSection);\r\n\r\n _ReplaceImport(kernel32, 'WaitForSingleObject', @_HookWaitForSingleObject, @Kernel32_WaitForSingleObject);\r\n _ReplaceImport(kernel32, 'WaitForSingleObjectEx', @_HookWaitForSingleObjectEx, @Kernel32_WaitForSingleObjectEx);\r\n _ReplaceImport(kernel32, 'WaitForMultipleObjects', @_HookWaitForMultipleObjects, @Kernel32_WaitForMultipleObjects);\r\n _ReplaceImport(kernel32, 'WaitForMultipleObjectsEx', @_HookWaitForMultipleObjectsEx, @Kernel32_WaitForMultipleObjectsEx);\r\n\r\n _ReplaceImport(user32, 'SendMessageA', @_HookSendMessageA, @Kernel32_SendMessageA);\r\n _ReplaceImport(user32, 'SendMessageW', @_HookSendMessageW, @Kernel32_SendMessageW);\r\n _ReplaceImport(user32, 'SendMessageTimeoutA', @_HookSendMessageTimeoutA, @Kernel32_SendMessageTimeoutA);\r\n _ReplaceImport(user32, 'SendMessageTimeoutW', @_HookSendMessageTimeoutW, @Kernel32_SendMessageTimeoutW);\r\n\r\n SyncObjsHooked := True;\r\n Result := True;\r\n finally\r\n SyncObjsInfoLock.Leave;\r\n end;\r\n end\r\n else\r\n Result := True;\r\nend;\r\n\r\nprocedure _UnHookSyncObjs;\r\nbegin\r\n if SyncObjsHooked and Assigned(_PeMapImgHooks) then\r\n begin\r\n if Assigned(@Kernel32_Sleep) then\r\n _PeMapImgHooks.UnhookByBaseAddress(@Kernel32_Sleep);\r\n if Assigned(@Kernel32_SleepEx) then\r\n _PeMapImgHooks.UnhookByBaseAddress(@Kernel32_SleepEx);\r\n\r\n if Assigned(@Kernel32_EnterCriticalSection) then\r\n _PeMapImgHooks.UnhookByBaseAddress(@Kernel32_EnterCriticalSection);\r\n if Assigned(@Kernel32_LeaveCriticalSection) then\r\n _PeMapImgHooks.UnhookByBaseAddress(@Kernel32_LeaveCriticalSection);\r\n\r\n if Assigned(@Kernel32_WaitForSingleObject) then\r\n _PeMapImgHooks.UnhookByBaseAddress(@Kernel32_WaitForSingleObject);\r\n if Assigned(@Kernel32_WaitForSingleObjectEx) then\r\n _PeMapImgHooks.UnhookByBaseAddress(@Kernel32_WaitForSingleObjectEx);\r\n if Assigned(@Kernel32_WaitForMultipleObjects) then\r\n _PeMapImgHooks.UnhookByBaseAddress(@Kernel32_WaitForMultipleObjects);\r\n if Assigned(@Kernel32_WaitForMultipleObjectsEx) then\r\n _PeMapImgHooks.UnhookByBaseAddress(@Kernel32_WaitForMultipleObjectsEx);\r\n\r\n if Assigned(@Kernel32_SendMessageA) then\r\n _PeMapImgHooks.UnhookByBaseAddress(@Kernel32_SendMessageA);\r\n if Assigned(@Kernel32_SendMessageW) then\r\n _PeMapImgHooks.UnhookByBaseAddress(@Kernel32_SendMessageW);\r\n if Assigned(@Kernel32_SendMessageTimeoutA) then\r\n _PeMapImgHooks.UnhookByBaseAddress(@Kernel32_SendMessageTimeoutA);\r\n if Assigned(@Kernel32_SendMessageTimeoutW) then\r\n _PeMapImgHooks.UnhookByBaseAddress(@Kernel32_SendMessageTimeoutW);\r\n\r\n FreeAndNil(_PeMapImgHooks);\r\n end;\r\nend;\r\n\r\nfunction InitSyncObjsHook(ImageBase: Pointer): LongBool; stdcall;\r\nbegin\r\n SyncObjsInfoList := AllocMem(SizeOf(TDbgSyncObjsInfoList));\r\n\r\n SyncObjsInfoLock := TDbgCriticalSection.Create;\r\n\r\n Result := _HookSyncObjs(ImageBase);\r\n if Result then\r\n _Log('Init SyncObjs hooks - ok')\r\n else\r\n _Log('Init SyncObjs hooks - fail')\r\nend;\r\n\r\nprocedure ResetSyncObjsHook; stdcall;\r\nbegin\r\n try\r\n if SyncObjsHooked then\r\n begin\r\n while not SyncObjsInfoLock.TryEnter do\r\n SwitchToThread;\r\n try\r\n _UnHookSyncObjs;\r\n finally\r\n SyncObjsInfoLock.Leave;\r\n end;\r\n\r\n while not SyncObjsInfoLock.TryEnter do\r\n SwitchToThread;\r\n try\r\n _OutSyncObjsInfo;\r\n\r\n FreeMemory(SyncObjsInfoList);\r\n SyncObjsInfoList := nil;\r\n finally\r\n SyncObjsInfoLock.Leave;\r\n end;\r\n end;\r\n\r\n FreeAndNil(SyncObjsInfoLock);\r\n\r\n _Log('Reset SyncObjs hooks - ok');\r\n except\r\n on E: Exception do\r\n _Log('Reset SyncObjs hooks fail: ' + E.Message);\r\n end;\r\nend;\r\n\r\nend.\r\n" }, { "path": "DbgHookThread.pas", "content": "unit DbgHookThread;\r\n\r\ninterface\r\n\r\nfunction InitThreadHook(ImageBase: Pointer; _vmtClassName: Integer): LongBool; stdcall;\r\nprocedure ResetThreadHook; stdcall;\r\n\r\nimplementation\r\n\r\nuses WinApi.Windows, System.SysUtils, System.Classes, DbgHookTypes, DbgHookCS, DbgHookUtils, JclPEImage{TODO: Remove JCL},\r\n KOLDetours;\r\n\r\ntype\r\n TKernel32_CreateThread = function(SecurityAttributes: Pointer; StackSize: LongWord;\r\n ThreadFunc: TThreadFunc; Parameter: Pointer;\r\n CreationFlags: LongWord; var ThreadId: LongWord): Integer; stdcall;\r\n\r\n PThreadRec = ^TThreadRec;\r\n TThreadRec = record\r\n Func: TThreadFunc;\r\n Parameter: Pointer;\r\n end;\r\n\r\nvar\r\n ThreadsLock: TDbgCriticalSection = nil;\r\n ThreadsHooked: LongBool = False;\r\n Kernel32_CreateThread: TKernel32_CreateThread = nil;\r\n\r\nprocedure _OutCreateThreadInfo(const ParentThreadId, ThreadId: Cardinal; ThName: PShortString);\r\nvar\r\n Args: array[0..3] of NativeUInt;\r\nbegin\r\n Args[0] := NativeUInt(dstThreadInfo);\r\n Args[1] := ThreadId;\r\n Args[2] := NativeUInt(@ThName^[1]);\r\n Args[3] := ParentThreadId;\r\n\r\n RaiseException(DBG_EXCEPTION, 0, 4, @Args[0]);\r\nend;\r\n\r\nfunction _HookedCreateThread(SecurityAttributes: Pointer; StackSize: LongWord;\r\n ThreadFunc: TThreadFunc; Parameter: Pointer;\r\n CreationFlags: LongWord; var ThreadId: LongWord): Integer; stdcall;\r\nvar\r\n ThRec: PThreadRec;\r\n Th: TObject;\r\n ParentId: Cardinal;\r\n Ptr: Pointer;\r\n ThName: ShortString;\r\nbegin\r\n Th := Nil;\r\n ThName := '';\r\n\r\n ThreadsLock.Enter;\r\n try\r\n ParentId := GetCurrentThreadId;\r\n\r\n if Assigned(Parameter) then\r\n begin\r\n ThRec := PThreadRec(Parameter);\r\n try\r\n if IsValidAddr(ThRec) then\r\n begin\r\n Th := TObject(ThRec^.Parameter);\r\n Ptr := Pointer(Integer(Th.ClassType) + RTL_vmtClassName);\r\n if IsValidAddr(Ptr) then\r\n begin\r\n Ptr := PPointer(Ptr)^;\r\n if IsValidAddr(Ptr) then\r\n ThName := PShortString(Ptr)^;\r\n end;\r\n end;\r\n except\r\n Th := Nil;\r\n end;\r\n end;\r\n\r\n Result := Kernel32_CreateThread(SecurityAttributes, StackSize, ThreadFunc, Parameter, CreationFlags, ThreadId);\r\n\r\n if (Result <> 0) and (Th <> nil) and (ThName <> '') then\r\n _OutCreateThreadInfo(ParentId, ThreadId, @ThName);\r\n finally\r\n ThName := '';\r\n ThreadsLock.Leave;\r\n end;\r\nend;\r\n\r\nvar\r\n _PeMapImgHooks: TJclPeMapImgHooks = Nil;\r\n\r\nfunction _HookThreads(ImageBase: Pointer; _vmtClassName: Integer): LongBool;\r\nvar\r\n ProcAddr: Pointer;\r\nbegin\r\n if not ThreadsHooked then\r\n begin\r\n RTL_vmtClassName := _vmtClassName;\r\n _Log(Format('vmtClassName = %d', [RTL_vmtClassName]));\r\n\r\n ThreadsLock := TDbgCriticalSection.Create;\r\n\r\n _PeMapImgHooks := TJclPeMapImgHooks.Create;\r\n\r\n ProcAddr := GetProcAddress(GetModuleHandle(kernel32), 'CreateThread');\r\n _Log(Format('CreateThread: %p', [ProcAddr]));\r\n\r\n ThreadsLock.Enter;\r\n try\r\n Result := _PeMapImgHooks.ReplaceImport(ImageBase, kernel32, ProcAddr, @_HookedCreateThread);\r\n\r\n if Result then\r\n @Kernel32_CreateThread := ProcAddr\r\n else\r\n begin\r\n\t //in case it doesn't work (Windows Server?): the hard way \r\n Kernel32_CreateThread := KOLDetours.InterceptCreate(ProcAddr, @_HookedCreateThread);\r\n Result := True;\r\n end;\r\n\r\n ThreadsHooked := Result;\r\n finally\r\n ThreadsLock.Leave;\r\n end;\r\n end\r\n else\r\n Result := True;\r\nend;\r\n\r\nprocedure _UnHookThreads;\r\nbegin\r\n if ThreadsHooked then\r\n begin\r\n while not ThreadsLock.TryEnter do\r\n SwitchToThread;\r\n try\r\n _PeMapImgHooks.UnhookByBaseAddress(@Kernel32_CreateThread);\r\n FreeAndNil(_PeMapImgHooks);\r\n\r\n ThreadsHooked := False;\r\n finally\r\n ThreadsLock.Leave;\r\n end;\r\n\r\n while not ThreadsLock.TryEnter do\r\n SwitchToThread;\r\n end;\r\n\r\n FreeAndNil(ThreadsLock);\r\nend;\r\n\r\nfunction InitThreadHook(ImageBase: Pointer; _vmtClassName: Integer): LongBool; stdcall;\r\nbegin\r\n _Log('Init debug hooks...');\r\n\r\n Result := _HookThreads(ImageBase, _vmtClassName);\r\n if Result then\r\n _Log('Init thread hook - ok')\r\n else\r\n _Log('Init thread hook - fail')\r\nend;\r\n\r\nprocedure ResetThreadHook; stdcall;\r\nbegin\r\n try\r\n _UnHookThreads;\r\n\r\n _Log('Reset thread hook - ok');\r\n except\r\n on E: Exception do\r\n _Log('Reset thread hook fail: ' + E.Message);\r\n end;\r\nend;\r\n\r\nend.\r\n" }, { "path": "DbgHookTypes.pas", "content": "unit DbgHookTypes;\r\n\r\ninterface\r\n\r\nuses\r\n WinApi.Windows;\r\n\r\nconst\r\n DBG_EXCEPTION = $0EEDFFF0;\r\n\r\n _EHOOK_GetCallStack = 1;\r\n _EHOOK_GetObjClassType = 2;\r\n\r\n DBG_STACK_LENGTH = 32;\r\n\r\ntype\r\n TDbgInfoType = (\r\n dstUnknown = 0,\r\n dstThreadInfo,\r\n dstMemInfo,\r\n dstPerfomance,\r\n dstPerfomanceAndInfo,\r\n dstMemHookStatus,\r\n dstSyncObjsInfo,\r\n dstSampling\r\n );\r\n\r\n // Memory Info\r\n\r\n TDbgMemInfoType = (miGetMem = 0, miFreeMem);\r\n\r\n PDbgHookInfoStack = ^TDbgHookInfoStack;\r\n TDbgHookInfoStack = array[0..(DBG_STACK_LENGTH - 1)] of Pointer;\r\n\r\n TObjClassTypeName = array[0..(SizeOf(TDbgHookInfoStack) - 1)] of AnsiChar;\r\n\r\n PDbgMemInfo = ^TDbgMemInfo;\r\n TDbgMemInfo = packed record\r\n Ptr: Pointer;\r\n ThreadId: Cardinal;\r\n case MemInfoType: TDbgMemInfoType of\r\n miGetMem: (\r\n Size: Cardinal;\r\n Stack: TDbgHookInfoStack;\r\n );\r\n miFreeMem: (\r\n ObjClassType: TObjClassTypeName;\r\n );\r\n end;\r\n\r\n // SyncObjs\r\n\r\n TDbgSyncObjsType = (\r\n soUnknown = 0,\r\n soSleep,\r\n soWaitForSingleObject, soWaitForMultipleObjects,\r\n soEnterCriticalSection, soLeaveCriticalSection, soInCriticalSection,\r\n soSendMessage\r\n );\r\n\r\n TDbgSyncObjsStateType = (sosUnknown = 0, sosEnter, sosLeave);\r\n\r\n PDbgSyncObjsInfo = ^TDbgSyncObjsInfo;\r\n TDbgSyncObjsInfo = packed record\r\n Id: NativeUInt;\r\n ThreadId: Cardinal;\r\n CurTime: Int64;\r\n Stack: TDbgHookInfoStack;\r\n SyncObjsStateType: TDbgSyncObjsStateType;\r\n case SyncObjsType: TDbgSyncObjsType of\r\n soUnknown:\r\n ();\r\n soSleep:\r\n (\r\n MSec: NativeUInt;\r\n );\r\n soWaitForSingleObject:\r\n (\r\n Handle: THandle;\r\n );\r\n soWaitForMultipleObjects:\r\n (\r\n Handles: PWOHandleArray;\r\n );\r\n soEnterCriticalSection,\r\n soLeaveCriticalSection,\r\n soInCriticalSection:\r\n (\r\n CS: PRTLCriticalSection;\r\n OwningThreadId: Cardinal;\r\n );\r\n soSendMessage:\r\n (\r\n Msg: UINT;\r\n );\r\n end;\r\n\r\nconst\r\n _DbgMemListLength = ($FFFFF div SizeOf(TDbgMemInfo));\r\n _DbgSyncObjsListLength = ($FFFFF div SizeOf(TDbgSyncObjsInfo));\r\n\r\ntype\r\n PDbgMemInfoList = ^TDbgMemInfoList;\r\n TDbgMemInfoList = array[0.._DbgMemListLength - 1] of TDbgMemInfo;\r\n\r\n PDbgMemInfoListBuf = ^TDbgMemInfoListBuf;\r\n TDbgMemInfoListBuf = record\r\n Count: Integer;\r\n DbgMemInfoList: PDbgMemInfoList;\r\n DbgPointIdx: Integer;\r\n end;\r\n\r\n PDbgSyncObjsInfoList = ^TDbgSyncObjsInfoList;\r\n TDbgSyncObjsInfoList = array[0.._DbgSyncObjsListLength - 1] of TDbgSyncObjsInfo;\r\n\r\n PDbgSyncObjsInfoListBuf = ^TDbgSyncObjsInfoListBuf;\r\n TDbgSyncObjsInfoListBuf = record\r\n Count: Integer;\r\n DbgSyncObjsInfoList: PDbgSyncObjsInfoList;\r\n DbgPointIdx: Integer;\r\n end;\r\n\r\nimplementation\r\n\r\nend.\r\n" }, { "path": "DbgHookUtils.pas", "content": "unit DbgHookUtils;\r\n\r\ninterface\r\n\r\nuses System.SysUtils, DbgHookTypes;\r\n\r\ntype\r\n TJclAddr = NativeInt;\r\n\r\n PStackFrame = ^TStackFrame;\r\n TStackFrame = record\r\n CallerFrame: TJclAddr;\r\n CallerAddr: TJclAddr;\r\n end;\r\n\r\nprocedure _Log(const Msg: AnsiString); overload;\r\nprocedure _Log(const Msg: String); overload;\r\nprocedure _LogException(E: Exception; const Code: Integer = 0);\r\n\r\nfunction IsValidCodeAddr(const Addr: Pointer): LongBool;\r\nfunction IsValidAddr(const Addr: Pointer): LongBool;\r\n\r\nfunction _GetObjClassType(const Obj: Pointer; var ObjClassName: ShortString): LongBool;\r\n\r\nfunction GetFramePointer: Pointer; assembler;\r\nfunction GetStackTop: TJclAddr; assembler;\r\n\r\nprocedure GetCallStack(var Stack: TDbgHookInfoStack; Level: Integer); stdcall;\r\nprocedure GetCallStackOS(var Stack: TDbgHookInfoStack; FramesToSkip: Integer); stdcall;\r\n\r\nvar\r\n RTL_vmtClassName: Integer = System.vmtClassName;\r\n\r\nimplementation\r\n\r\nuses Windows;\r\n\r\n{ --- From JCL --- }\r\ntype\r\n NT_TIB32 = packed record\r\n ExceptionList: DWORD;\r\n StackBase: DWORD;\r\n StackLimit: DWORD;\r\n SubSystemTib: DWORD;\r\n case Integer of\r\n 0 : (\r\n FiberData: DWORD;\r\n ArbitraryUserPointer: DWORD;\r\n Self: DWORD;\r\n );\r\n 1 : (\r\n Version: DWORD;\r\n );\r\n end;\r\n{ --- From JCL --- }\r\n\r\nprocedure _Log(const Msg: AnsiString);\r\nbegin\r\n OutputDebugStringA(PAnsiChar(Msg));\r\nend;\r\n\r\nprocedure _Log(const Msg: String);\r\nbegin\r\n _Log(AnsiString(Msg));\r\nend;\r\n\r\nprocedure _LogException(E: Exception; const Code: Integer = 0);\r\nbegin\r\n _Log(Format('DbgHook error (%d): %s', [Code, E.Message]));\r\nend;\r\n\r\nthreadvar\r\n _Buf: TMemoryBasicInformation;\r\n\r\nfunction IsValidCodeAddr(const Addr: Pointer): LongBool;\r\nconst\r\n _PAGE_CODE = DWORD(PAGE_EXECUTE Or PAGE_EXECUTE_READ or PAGE_EXECUTE_READWRITE Or PAGE_EXECUTE_WRITECOPY);\r\nvar\r\n Buf: PMemoryBasicInformation;\r\nBegin\r\n Result := False;\r\n\r\n if (Addr = nil) or (Addr = Pointer(-1)) then Exit;\r\n\r\n Buf := @_Buf;\r\n Result := (VirtualQuery(Addr, Buf^, SizeOf(TMemoryBasicInformation)) <> 0) And ((Buf^.Protect And _PAGE_CODE) <> 0);\r\nend;\r\n\r\nfunction IsValidAddr(const Addr: Pointer): LongBool;\r\nvar\r\n Buf: PMemoryBasicInformation;\r\nBegin\r\n Result := False;\r\n\r\n if (Addr = nil) or (Addr = Pointer(-1)) then Exit;\r\n\r\n Buf := @_Buf;\r\n\r\n Result := (VirtualQuery(Addr, Buf^, SizeOf(TMemoryBasicInformation)) <> 0);\r\nend;\r\n\r\nfunction _GetObjClassType(const Obj: Pointer; var ObjClassName: ShortString): LongBool;\r\nvar\r\n ClassTypePtr: Pointer;\r\n ClassNamePtr: Pointer;\r\nbegin\r\n Result := False;\r\n try\r\n if not IsValidAddr(Obj) then Exit;\r\n\r\n ClassTypePtr := PPointer(Obj)^;\r\n if not IsValidCodeAddr(ClassTypePtr) then Exit;\r\n ClassNamePtr := Pointer(Integer(ClassTypePtr) + RTL_vmtClassName);\r\n if not IsValidCodeAddr(ClassNamePtr) then Exit;\r\n ClassNamePtr := PPointer(ClassNamePtr)^;\r\n if not IsValidCodeAddr(ClassNamePtr) then Exit;\r\n ObjClassName := PShortString(ClassNamePtr)^;\r\n Result := True;\r\n except\r\n on E: Exception do\r\n _LogException(E, _EHOOK_GetObjClassType);\r\n end;\r\nend;\r\n\r\nfunction GetFramePointer: Pointer; assembler;\r\nasm\r\n MOV EAX, EBP\r\nend;\r\n\r\nfunction GetStackTop: TJclAddr; assembler;\r\nasm\r\n MOV EAX, FS:[0].NT_TIB32.StackBase\r\nend;\r\n\r\nprocedure GetCallStack(var Stack: TDbgHookInfoStack; Level: Integer); stdcall;\r\nvar\r\n TopOfStack: TJclAddr;\r\n BaseOfStack: TJclAddr;\r\n StackFrame: PStackFrame;\r\nbegin\r\n try\r\n ZeroMemory(@Stack[0], Length(Stack) * SizeOf(Pointer));\r\n\r\n StackFrame := GetFramePointer;\r\n BaseOfStack := TJclAddr(StackFrame) - 1;\r\n TopOfStack := GetStackTop;\r\n\r\n while (Level < Length(Stack)) and (\r\n (Level < 0) or (\r\n (BaseOfStack < TJclAddr(StackFrame)) and\r\n (TJclAddr(StackFrame) < TopOfStack) and\r\n IsValidAddr(StackFrame)\r\n // TODO: - \r\n // and IsValidCodeAddr(Pointer(StackFrame^.CallerAddr))\r\n )\r\n )\r\n do begin\r\n if Level >= 0 then\r\n Stack[Level] := Pointer(StackFrame^.CallerAddr - 1);\r\n\r\n StackFrame := PStackFrame(StackFrame^.CallerFrame);\r\n\r\n Inc(Level);\r\n end;\r\n except\r\n on E: Exception do\r\n _LogException(E, _EHOOK_GetCallStack);\r\n end;\r\nend;\r\n\r\nfunction RtlCaptureStackBackTrace(FramesToSkip: ULONG; FramesToCapture: ULONG; BackTrace: Pointer; BackTraceHash: PULONG): USHORT; stdcall;\r\n external 'kernel32.dll' name 'RtlCaptureStackBackTrace';\r\n\r\nprocedure GetCallStackOS(var Stack: TDbgHookInfoStack; FramesToSkip: Integer); stdcall;\r\nbegin\r\n //ZeroMemory(@Stack[0], SizeOf(TDbgHookInfoStack));\r\n\r\n RtlCaptureStackBackTrace(FramesToSkip, DBG_STACK_LENGTH, @Stack[0], Nil);\r\nend;\r\n\r\nend.\r\n" }, { "path": "DbgMemoryProfiler.pas", "content": "unit DbgMemoryProfiler;\r\n\r\ninterface\r\n\r\nuses System.Classes, WinApi.Windows, Collections.Queues, DbgHookTypes,\r\n System.SysUtils, System.SyncObjs, DebugerTypes;\r\n\r\ntype\r\n TProcessMemoryQueue = TQueue;\r\n\r\n TDbgMemoryProfiler = class\r\n private\r\n FProcessMemoryQueue: TProcessMemoryQueue;\r\n\r\n FMemoryCheckMode: LongBool;\r\n FMemoryCallStack: LongBool;\r\n FMemoryCheckDoubleFree: LongBool;\r\n\r\n procedure SetMemoryCallStack(const Value: LongBool);\r\n procedure SetMemoryCheckDoubleFree(const Value: LongBool);\r\n procedure SetMemoryCheckMode(const Value: LongBool);\r\n public\r\n constructor Create;\r\n destructor Destroy; override;\r\n\r\n procedure Clear;\r\n\r\n function ProcessMemoryInfoQueue: LongBool;\r\n procedure ProcessMemoryInfoBuf(const Buf: PDbgMemInfoListBuf);\r\n\r\n function FindMemoryPointer(const Ptr: Pointer; var ThData: PThreadData; var MemInfo: TGetMemInfo): LongBool;\r\n\r\n procedure LoadMemoryInfoPackEx(const MemInfoPack: Pointer; const Count: Cardinal);\r\n\r\n procedure UpdateMemoryInfoObjectTypes;\r\n procedure UpdateMemoryInfoObjectTypesOfThread(ThData: PThreadData);\r\n\r\n property MemoryCheckMode: LongBool read FMemoryCheckMode write SetMemoryCheckMode;\r\n property MemoryCallStack: LongBool read FMemoryCallStack write SetMemoryCallStack;\r\n property MemoryCheckDoubleFree: LongBool read FMemoryCheckDoubleFree write SetMemoryCheckDoubleFree;\r\n end;\r\n\r\nimplementation\r\n\r\nuses Debuger, Collections.Base;\r\n\r\nconst\r\n _MAX_MEM_INFO_BUF_COUNT = 512;\r\n\r\n\r\n{ TDbgMemoryProfiler }\r\n\r\nprocedure TDbgMemoryProfiler.Clear;\r\nbegin\r\n FProcessMemoryQueue.Clear;\r\nend;\r\n\r\nconstructor TDbgMemoryProfiler.Create;\r\nbegin\r\n inherited;\r\n\r\n FProcessMemoryQueue := TProcessMemoryQueue.Create(True);\r\n FProcessMemoryQueue.Capacity := _MAX_MEM_INFO_BUF_COUNT + 1;\r\nend;\r\n\r\ndestructor TDbgMemoryProfiler.Destroy;\r\nbegin\r\n Clear;\r\n\r\n FreeAndNil(FProcessMemoryQueue);\r\n\r\n inherited;\r\nend;\r\n\r\nfunction TDbgMemoryProfiler.FindMemoryPointer(const Ptr: Pointer; var ThData: PThreadData; var MemInfo: TGetMemInfo): LongBool;\r\nvar\r\n Idx: Integer;\r\nbegin\r\n Result := False;\r\n\r\n // \r\n if ThData <> Nil then\r\n Result := ThData^.DbgGetMemInfo.TryGetValue(Ptr, MemInfo);\r\n\r\n if not Result then\r\n begin\r\n // \r\n Idx := 0;\r\n repeat\r\n ThData := gvDebuger.GetThreadDataByIdx(Idx);\r\n if ThData <> Nil then\r\n begin\r\n Result := ThData^.DbgGetMemInfo.TryGetValue(Ptr, MemInfo);\r\n\r\n Inc(Idx);\r\n end;\r\n until Result or (ThData = Nil);\r\n end;\r\nend;\r\n\r\nprocedure TDbgMemoryProfiler.LoadMemoryInfoPackEx(const MemInfoPack: Pointer; const Count: Cardinal);\r\nvar\r\n Buf: PDbgMemInfoListBuf;\r\nbegin\r\n if not MemoryCheckMode then\r\n Exit;\r\n\r\n while FProcessMemoryQueue.Count >= _MAX_MEM_INFO_BUF_COUNT do\r\n SwitchToThread;\r\n\r\n Buf := AllocMem(SizeOf(TDbgMemInfoListBuf));\r\n Buf^.Count := Count;\r\n Buf^.DbgMemInfoList := AllocMem(Count * SizeOf(TDbgMemInfo));\r\n Buf^.DbgPointIdx := gvDebuger.ProcessData.CurDbgPointIdx;\r\n\r\n if gvDebuger.ReadData(MemInfoPack, Buf^.DbgMemInfoList, Count * SizeOf(TDbgMemInfo)) then\r\n FProcessMemoryQueue.Enqueue(Buf)\r\n else\r\n RaiseDebugCoreException();\r\nend;\r\n\r\nprocedure TDbgMemoryProfiler.ProcessMemoryInfoBuf(const Buf: PDbgMemInfoListBuf);\r\nvar\r\n Idx: Integer;\r\n DbgMemInfo: PDbgMemInfo;\r\n ThData: PThreadData;\r\n FoundThData: PThreadData;\r\n MemInfo: TGetMemInfo;\r\n NewMemInfo: TGetMemInfo;\r\nbegin\r\n ThData := Nil;\r\n\r\n for Idx := 0 to Buf^.Count - 1 do\r\n begin\r\n DbgMemInfo := @Buf^.DbgMemInfoList^[Idx];\r\n if (ThData = Nil) or (ThData^.ThreadID <> DbgMemInfo^.ThreadId) then\r\n ThData := gvDebuger.GetThreadData(DbgMemInfo^.ThreadId, True);\r\n\r\n if ThData = Nil then\r\n RaiseDebugCoreException();\r\n\r\n case DbgMemInfo^.MemInfoType of\r\n miGetMem:\r\n begin\r\n //DoDbgLog(DbgMemInfo^.ThreadId, Format('%s: %p (%d)', ['GetMem', DbgMemInfo^.Ptr, DbgMemInfo^.Size]));\r\n\r\n // , - \r\n // TODO: , - FreeMem\r\n (*\r\n FoundThData := ThData;\r\n if FindMemoryPointer(DbgMemInfo^.Ptr, FoundThData, MemInfo) then\r\n begin\r\n //DoDbgLog(FoundThData^.ThreadId, Format('<<< ERROR!!! FOUND BEFORE GETMEM (%d)', [MemInfo^.Size]));\r\n\r\n Dec(FoundThData^.DbgGetMemInfoSize, MemInfo^.Size);\r\n\r\n Dec(FProcessData.ProcessGetMemCount);\r\n Dec(FProcessData.ProcessGetMemSize, MemInfo^.Size);\r\n\r\n FoundThData^.DbgGetMemInfo.Remove(DbgMemInfo^.Ptr);\r\n end;\r\n *)\r\n\r\n // \r\n NewMemInfo := TGetMemInfo.Create;\r\n\r\n NewMemInfo.PerfIdx := Buf^.DbgPointIdx;\r\n NewMemInfo.ObjAddr := DbgMemInfo^.Ptr;\r\n NewMemInfo.Size := DbgMemInfo^.Size;\r\n NewMemInfo.ObjectType := ''; // \r\n\r\n NewMemInfo.LoadStack(@DbgMemInfo^.Stack);\r\n\r\n ThData^.DbgGetMemInfo.AddOrSetValue(DbgMemInfo^.Ptr, NewMemInfo);\r\n TInterlocked.Add(ThData^.DbgGetMemInfoSize, NewMemInfo.Size);\r\n\r\n TInterlocked.Add(gvDebuger.ProcessData.ProcessGetMemCount, 1);\r\n TInterlocked.Add(gvDebuger.ProcessData.ProcessGetMemSize, NewMemInfo.Size);\r\n end;\r\n miFreeMem:\r\n begin\r\n //DoDbgLog(DbgMemInfo^.ThreadId, Format('%s: %p (%d)', ['FreeMem', DbgMemInfo^.Ptr, DbgMemInfo^.Size]));\r\n\r\n FoundThData := ThData;\r\n if FindMemoryPointer(DbgMemInfo^.Ptr, FoundThData, MemInfo) then\r\n begin\r\n TInterlocked.Add(FoundThData^.DbgGetMemInfoSize, -MemInfo.Size);\r\n\r\n TInterlocked.Add(gvDebuger.ProcessData.ProcessGetMemCount, -1);\r\n TInterlocked.Add(gvDebuger.ProcessData.ProcessGetMemSize, -MemInfo.Size);\r\n\r\n FoundThData^.DbgGetMemInfo.Remove(DbgMemInfo^.Ptr);\r\n end\r\n else\r\n begin\r\n // , \r\n //RaiseDebugCoreException();\r\n //DoDbgLog(DbgMemInfo^.ThreadId, '<<< ERROR!!! NOT FOUND FOR FREEMEM');\r\n\r\n // TODO: Double free ???\r\n end;\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TDbgMemoryProfiler.ProcessMemoryInfoQueue: LongBool;\r\nvar\r\n Buf: PDbgMemInfoListBuf;\r\nbegin\r\n Result := False;\r\n\r\n if not MemoryCheckMode then\r\n Exit;\r\n\r\n try\r\n if FProcessMemoryQueue.Count > 0 then\r\n begin\r\n Buf := FProcessMemoryQueue.Dequeue;\r\n try\r\n ProcessMemoryInfoBuf(Buf);\r\n finally\r\n FreeMemory(Buf^.DbgMemInfoList);\r\n FreeMemory(Buf);\r\n end;\r\n\r\n Result := True;\r\n end;\r\n except\r\n on E: Exception do ; // TODO:\r\n end;\r\nend;\r\n\r\nprocedure TDbgMemoryProfiler.SetMemoryCallStack(const Value: LongBool);\r\nbegin\r\n FMemoryCallStack := Value;\r\nend;\r\n\r\nprocedure TDbgMemoryProfiler.SetMemoryCheckDoubleFree(const Value: LongBool);\r\nbegin\r\n FMemoryCheckDoubleFree := Value;\r\nend;\r\n\r\nprocedure TDbgMemoryProfiler.SetMemoryCheckMode(const Value: LongBool);\r\nbegin\r\n FMemoryCheckMode := Value;\r\nend;\r\n\r\nprocedure TDbgMemoryProfiler.UpdateMemoryInfoObjectTypes;\r\nvar\r\n Idx: Integer;\r\n ThData: PThreadData;\r\nbegin\r\n Idx := 0;\r\n repeat\r\n ThData := gvDebuger.GetThreadDataByIdx(Idx);\r\n if ThData <> Nil then\r\n begin\r\n UpdateMemoryInfoObjectTypesOfThread(ThData);\r\n Inc(Idx);\r\n end;\r\n until ThData = Nil;\r\n\r\n // \r\n (*\r\n GetMemInfo := ProcessData.DbgGetMemInfo;\r\n if GetMemInfo.Count > 0 then\r\n begin\r\n for GetMemInfoItem in GetMemInfo do\r\n GetMemInfoItem.Value^.ObjectType := GetMemInfoItem.Value^.GetObjectType(GetMemInfoItem.Key);\r\n end;\r\n *)\r\nend;\r\n\r\nprocedure TDbgMemoryProfiler.UpdateMemoryInfoObjectTypesOfThread(ThData: PThreadData);\r\nvar\r\n GetMemInfo: TGetMemInfoList;\r\n GetMemInfoItem: TGetMemInfoItem;\r\nbegin\r\n GetMemInfo := ThData^.DbgGetMemInfo;\r\n if GetMemInfo.Count > 0 then\r\n begin\r\n GetMemInfo.LockForRead;\r\n try\r\n for GetMemInfoItem in GetMemInfo do\r\n GetMemInfoItem.Value.CheckObjectType;\r\n finally\r\n GetMemInfo.UnLockForRead;\r\n end;\r\n end;\r\nend;\r\n\r\nend.\r\n" }, { "path": "DbgSamplingProfiler.pas", "content": "unit DbgSamplingProfiler;\r\n\r\ninterface\r\n\r\nuses System.Classes, WinApi.Windows, Collections.Queues, DbgHookTypes,\r\n System.SysUtils, System.SyncObjs, DebugerTypes;\r\n\r\ntype\r\n TDbgSamplingProfiler = class\r\n private\r\n // Timers\r\n FTimerQueue: THandle;\r\n FSamplingTimer: THandle;\r\n FSamplingLock: TCriticalSection;\r\n public\r\n constructor Create;\r\n destructor Destroy; override;\r\n\r\n procedure Clear;\r\n\r\n procedure InitSamplingTimer;\r\n procedure ResetSamplingTimer;\r\n procedure DoSamplingEvent;\r\n\r\n procedure ProcessDbgSamplingInfo;\r\n function ProcessSamplingInfo: LongBool;\r\n\r\n procedure AddThreadSamplingInfo(ThreadData: PThreadData);\r\n function ProcessThreadSamplingInfo(ThreadData: PThreadData): LongBool;\r\n procedure ProcessThreadSamplingStack(ThreadData: PThreadData; var Stack: TDbgInfoStack);\r\n procedure ProcessThreadSamplingAddress(ThData: PThreadData; FuncAddr, ParentFuncAddr: Pointer);\r\n end;\r\n\r\nimplementation\r\n\r\nuses\r\n Debuger, WinAPIUtils, DebugInfo;\r\n\r\nprocedure _DbgSamplingEvent(Context: Pointer; Success: LongBool); stdcall;\r\nbegin\r\n if Assigned(gvDebuger) then\r\n gvDebuger.DbgSamplingProfiler.DoSamplingEvent;\r\nend;\r\n\r\n\r\n{ TDbgSamplingProfiler }\r\n\r\nprocedure TDbgSamplingProfiler.AddThreadSamplingInfo(ThreadData: PThreadData);\r\nvar\r\n ThCPU: UInt64;\r\n FreqCPU: Int64;\r\n Stack: TDbgInfoStack;\r\n StackInfo: PDbgInfoStackRec;\r\n Res: DWORD;\r\nbegin\r\n if Assigned(ThreadData^.ThreadAdvInfo) and (ThreadData^.ThreadAdvInfo.ThreadAdvType = tatNormal) then\r\n begin\r\n ThCPU := _QueryThreadCycleTime(ThreadData^.ThreadHandle);\r\n FreqCPU := _QueryPerformanceFrequency;\r\n\r\n // FreqCPU - CPU 1 \r\n // , 10% 1 \r\n if (ThCPU - ThreadData^.SamplingCPUTime) > (FreqCPU div 10000) then\r\n begin\r\n ThreadData^.SamplingCPUTime := ThCPU;\r\n Inc(ThreadData^.SamplingCount);\r\n\r\n SetLength(Stack, 0);\r\n\r\n Res := SuspendThread(ThreadData^.ThreadHandle);\r\n if Res = 0 then\r\n begin\r\n if gvDebuger.UpdateThreadContext(ThreadData, CONTEXT_CONTROL) then\r\n begin\r\n gvDebuger.GetCallStack(ThreadData, Stack);\r\n end;\r\n end;\r\n\r\n ResumeThread(ThreadData^.ThreadHandle);\r\n\r\n if Length(Stack) > 0 then\r\n begin\r\n New(StackInfo);\r\n StackInfo^.Stack := Stack;\r\n\r\n ThreadData^.SamplingQueue.Add(StackInfo);\r\n end;\r\n end\r\n else\r\n ThreadData^.SamplingCPUTime := ThCPU;\r\n end;\r\nend;\r\n\r\nprocedure TDbgSamplingProfiler.Clear;\r\nbegin\r\n\r\nend;\r\n\r\nconstructor TDbgSamplingProfiler.Create;\r\nbegin\r\n inherited;\r\n\r\n FTimerQueue := 0;\r\n FSamplingTimer := 0;\r\n FSamplingLock := TCriticalSection.Create;\r\nend;\r\n\r\ndestructor TDbgSamplingProfiler.Destroy;\r\nbegin\r\n Clear;\r\n FreeAndNil(FSamplingLock);\r\n\r\n inherited;\r\nend;\r\n\r\nprocedure TDbgSamplingProfiler.DoSamplingEvent;\r\nbegin\r\n if gvDebuger.DbgState <> dsWait then Exit;\r\n\r\n // , \r\n if FSamplingLock.TryEnter then\r\n begin\r\n ProcessDbgSamplingInfo;\r\n\r\n FSamplingLock.Leave;\r\n end;\r\nend;\r\n\r\nprocedure TDbgSamplingProfiler.InitSamplingTimer;\r\nbegin\r\n FTimerQueue := CreateTimerQueue;\r\n if FTimerQueue <> 0 then\r\n begin\r\n if CreateTimerQueueTimer(FSamplingTimer, FTimerQueue, @_DbgSamplingEvent, nil, 100, 1, WT_EXECUTEINPERSISTENTTHREAD) then\r\n begin\r\n gvDebuger.Log('Init sampling timer - ok');\r\n Exit;\r\n end;\r\n end;\r\n\r\n gvDebuger.Log('Init sampling timer - fail');\r\nend;\r\n\r\nprocedure TDbgSamplingProfiler.ProcessDbgSamplingInfo;\r\nvar\r\n CPUTime: UInt64;\r\n ThData: PThreadData;\r\n I: Integer;\r\n Threads: TDbgActiveThreads;\r\nbegin\r\n CPUTime := _QueryProcessCycleTime(gvDebuger.ProcessData.AttachedProcessHandle);\r\n // TODO: CPU\r\n if CPUTime > gvDebuger.ProcessData.SamplingCPUTime then\r\n begin\r\n gvDebuger.ProcessData.SamplingCPUTime := CPUTime;\r\n TInterlocked.Increment(gvDebuger.ProcessData.SamplingCount);\r\n\r\n gvDebuger.GetActiveThreads(Threads);\r\n\r\n for I := 0 to High(Threads) do\r\n begin\r\n ThData := Threads[I];\r\n if ThData^.State = tsActive then\r\n AddThreadSamplingInfo(ThData);\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TDbgSamplingProfiler.ProcessSamplingInfo: LongBool;\r\nvar\r\n I: Integer;\r\n ThData: PThreadData;\r\nbegin\r\n Result := False;\r\n\r\n if not(gvDebuger.CodeTracking and gvDebuger.SamplingMethod) then\r\n Exit;\r\n\r\n try\r\n for I := gvDebuger.GetThreadCount - 1 downto 0 do\r\n begin\r\n ThData := gvDebuger.GetThreadDataByIdx(I);\r\n Result := ProcessThreadSamplingInfo(ThData) or Result;\r\n end;\r\n except\r\n on E: Exception do ; // TODO:\r\n end;\r\nend;\r\n\r\nprocedure TDbgSamplingProfiler.ProcessThreadSamplingAddress(ThData: PThreadData; FuncAddr, ParentFuncAddr: Pointer);\r\nvar\r\n UnitInfo: TUnitInfo;\r\n FuncInfo: TFuncInfo;\r\n LineInfo: TLineInfo;\r\n\r\n TrackFuncInfo: TCodeTrackFuncInfo;\r\n ParentCallFuncInfo: TCallFuncInfo;\r\n ParentFuncInfo: TFuncInfo;\r\n ParentTrackFuncInfo: TCodeTrackFuncInfo;\r\nbegin\r\n // --- --- //\r\n if gvDebugInfo.GetLineInfo(FuncAddr, UnitInfo, FuncInfo, LineInfo, False) = slNotFound then\r\n Exit;\r\n\r\n TrackFuncInfo := TCodeTrackFuncInfo(ThData^.DbgTrackFuncList.GetTrackFuncInfo(FuncInfo));\r\n ThData^.DbgTrackUnitList.CheckTrackFuncInfo(TrackFuncInfo);\r\n\r\n TrackFuncInfo.IncCallCount;\r\n\r\n // \r\n ThData.DbgTrackUsedUnitList.AddOrSetValue(UnitInfo, TrackFuncInfo.TrackUnitInfo);\r\n\r\n // \r\n ParentCallFuncInfo := TrackFuncInfo.AddParentCall(ParentFuncAddr);\r\n\r\n // \r\n if Assigned(ParentCallFuncInfo) then\r\n begin\r\n ParentFuncInfo := TFuncInfo(ParentCallFuncInfo.FuncInfo);\r\n if Assigned(ParentFuncInfo) then\r\n begin\r\n ParentTrackFuncInfo := TCodeTrackFuncInfo(ThData^.DbgTrackFuncList.GetTrackFuncInfo(ParentFuncInfo));\r\n ThData^.DbgTrackUnitList.CheckTrackFuncInfo(ParentTrackFuncInfo);\r\n\r\n ParentTrackFuncInfo.AddChildCall(FuncAddr);\r\n end;\r\n end;\r\n\r\n // --- --- //\r\n TrackFuncInfo := TCodeTrackFuncInfo(gvDebuger.ProcessData.DbgTrackFuncList.GetTrackFuncInfo(FuncInfo));\r\n gvDebuger.ProcessData.DbgTrackUnitList.CheckTrackFuncInfo(TrackFuncInfo);\r\n\r\n TrackFuncInfo.IncCallCount;\r\n\r\n // \r\n gvDebuger.ProcessData.DbgTrackUsedUnitList.AddOrSetValue(UnitInfo, TrackFuncInfo.TrackUnitInfo);\r\n\r\n // \r\n ParentCallFuncInfo := TrackFuncInfo.AddParentCall(ParentFuncAddr);\r\n\r\n // \r\n if Assigned(ParentCallFuncInfo) then\r\n begin\r\n ParentFuncInfo := TFuncInfo(ParentCallFuncInfo.FuncInfo);\r\n if Assigned(ParentFuncInfo) then\r\n begin\r\n ParentTrackFuncInfo := TCodeTrackFuncInfo(gvDebuger.ProcessData.DbgTrackFuncList.GetTrackFuncInfo(ParentFuncInfo));\r\n gvDebuger.ProcessData.DbgTrackUnitList.CheckTrackFuncInfo(ParentTrackFuncInfo);\r\n\r\n ParentTrackFuncInfo.AddChildCall(FuncAddr);\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TDbgSamplingProfiler.ProcessThreadSamplingInfo(ThreadData: PThreadData): LongBool;\r\nvar\r\n StackInfo: PDbgInfoStackRec;\r\nbegin\r\n if ThreadData.SamplingQueue.Count > 0 then\r\n begin\r\n try\r\n while ThreadData.SamplingQueue.Count > 0 do\r\n begin\r\n StackInfo := ThreadData.SamplingQueue.Dequeue;\r\n try\r\n if Length(StackInfo^.Stack) > 0 then\r\n ProcessThreadSamplingStack(ThreadData, StackInfo^.Stack);\r\n finally\r\n Dispose(StackInfo);\r\n end;\r\n end;\r\n except\r\n on E: Exception do ;\r\n end;\r\n\r\n Result := True;\r\n end\r\n else\r\n Result := False;\r\nend;\r\n\r\nprocedure TDbgSamplingProfiler.ProcessThreadSamplingStack(ThreadData: PThreadData; var Stack: TDbgInfoStack);\r\nvar\r\n Idx: Integer;\r\n TrackUnitInfoPair: TTrackUnitInfoPair;\r\nbegin\r\n TInterlocked.Add(gvDebuger.ProcessData.DbgTrackEventCount, 1);\r\n TInterlocked.Add(ThreadData^.DbgTrackEventCount, 1);\r\n\r\n try\r\n for Idx := 0 to High(Stack) - 1 do\r\n ProcessThreadSamplingAddress(ThreadData, Stack[Idx], Stack[Idx + 1]);\r\n\r\n for TrackUnitInfoPair in ThreadData.DbgTrackUsedUnitList do\r\n TrackUnitInfoPair.Value.IncCallCount;\r\n\r\n for TrackUnitInfoPair in gvDebuger.ProcessData.DbgTrackUsedUnitList do\r\n TrackUnitInfoPair.Value.IncCallCount;\r\n finally\r\n SetLength(Stack, 0);\r\n ThreadData.DbgTrackUsedUnitList.Clear;\r\n gvDebuger.ProcessData.DbgTrackUsedUnitList.Clear;\r\n end;\r\nend;\r\n\r\nprocedure TDbgSamplingProfiler.ResetSamplingTimer;\r\nbegin\r\n if FTimerQueue <> 0 then\r\n begin\r\n if DeleteTimerQueue(FTimerQueue) then\r\n gvDebuger.Log('Reset timer queue - ok')\r\n else\r\n gvDebuger.Log('Reset timer queue - fail');\r\n\r\n FSamplingTimer := 0;\r\n FTimerQueue := 0;\r\n end;\r\nend;\r\n\r\nend.\r\n" }, { "path": "DbgSyncObjsProfiler.pas", "content": "unit DbgSyncObjsProfiler;\r\n\r\ninterface\r\n\r\nuses System.Classes, WinApi.Windows, Collections.Queues, DbgHookTypes,\r\n System.SysUtils, System.SyncObjs, DebugerTypes;\r\n\r\ntype\r\n TSyncObjsInfoQueue = TQueue;\r\n\r\n TDbgSyncObjsProfiler = class\r\n private\r\n FSyncObjsInfoQueue: TSyncObjsInfoQueue;\r\n\r\n FSyncObjsTracking: LongBool;\r\n procedure SetSyncObjsTracking(const Value: LongBool);\r\n public\r\n constructor Create;\r\n destructor Destroy; override;\r\n\r\n procedure Clear;\r\n\r\n function ProcessSyncObjsInfoQueue: LongBool;\r\n procedure LoadSyncObjsInfoPackEx(const SyncObjsInfoPack: Pointer; const Count: Cardinal);\r\n procedure ProcessSyncObjsInfoBuf(const Buf: PDbgSyncObjsInfoListBuf);\r\n\r\n property SyncObjsInfoQueue: TSyncObjsInfoQueue read FSyncObjsInfoQueue;\r\n property SyncObjsTracking: LongBool read FSyncObjsTracking write SetSyncObjsTracking;\r\n end;\r\n\r\nimplementation\r\n\r\nuses Debuger, CollectList;\r\n\r\nconst\r\n _MAX_SYNC_OBJS_INFO_BUF_COUNT = 512;\r\n\r\n{ TDbgSyncObjsProfiler }\r\n\r\nprocedure TDbgSyncObjsProfiler.Clear;\r\nbegin\r\n FSyncObjsInfoQueue.Clear;\r\nend;\r\n\r\nconstructor TDbgSyncObjsProfiler.Create;\r\nbegin\r\n inherited;\r\n\r\n FSyncObjsInfoQueue := TSyncObjsInfoQueue.Create(True);\r\n FSyncObjsInfoQueue.Capacity := _MAX_SYNC_OBJS_INFO_BUF_COUNT + 1;\r\nend;\r\n\r\ndestructor TDbgSyncObjsProfiler.Destroy;\r\nbegin\r\n FSyncObjsInfoQueue.Free;\r\n inherited;\r\nend;\r\n\r\nprocedure TDbgSyncObjsProfiler.LoadSyncObjsInfoPackEx(const SyncObjsInfoPack: Pointer; const Count: Cardinal);\r\nvar\r\n Buf: PDbgSyncObjsInfoListBuf;\r\nbegin\r\n if not SyncObjsTracking then\r\n Exit;\r\n\r\n while FSyncObjsInfoQueue.Count >= _MAX_SYNC_OBJS_INFO_BUF_COUNT do\r\n SwitchToThread;\r\n\r\n Buf := AllocMem(SizeOf(TDbgSyncObjsInfoListBuf));\r\n Buf^.Count := Count;\r\n Buf^.DbgSyncObjsInfoList := AllocMem(Count * SizeOf(TDbgSyncObjsInfo));\r\n Buf^.DbgPointIdx := gvDebuger.ProcessData.CurDbgPointIdx;\r\n\r\n if gvDebuger.ReadData(SyncObjsInfoPack, Buf^.DbgSyncObjsInfoList, Count * SizeOf(TDbgSyncObjsInfo)) then\r\n FSyncObjsInfoQueue.Enqueue(Buf)\r\n else\r\n RaiseDebugCoreException();\r\nend;\r\n\r\nprocedure TDbgSyncObjsProfiler.ProcessSyncObjsInfoBuf(const Buf: PDbgSyncObjsInfoListBuf);\r\nvar\r\n ThData: PThreadData;\r\n\r\n function FindCSLink(const CSData: PRTLCriticalSection): PSyncObjsInfo;\r\n var\r\n Idx: Integer;\r\n begin\r\n for Idx := ThData^.DbgSyncObjsInfo.Count - 1 downto 0 do\r\n begin\r\n Result := ThData^.DbgSyncObjsInfo[Idx];\r\n if (Result^.SyncObjsInfo.SyncObjsType = soInCriticalSection) and\r\n (Result^.Link = nil) and\r\n (Result^.SyncObjsInfo.CS = CSData) and\r\n (Result^.SyncObjsInfo.SyncObjsStateType = sosEnter)\r\n then\r\n Exit;\r\n end;\r\n\r\n Result := nil;\r\n end;\r\n\r\nvar\r\n Idx: Integer;\r\n SyncObjsInfo: PDbgSyncObjsInfo;\r\n ThSyncObjsInfo: PSyncObjsInfo;\r\n SyncObjsLink: PSyncObjsInfo;\r\n SyncObjsLinkExt: PSyncObjsInfo;\r\nbegin\r\n ThData := Nil;\r\n\r\n for Idx := 0 to Buf^.Count - 1 do\r\n begin\r\n SyncObjsInfo := @Buf^.DbgSyncObjsInfoList^[Idx];\r\n if (ThData = Nil) or (ThData^.ThreadID <> SyncObjsInfo^.ThreadId) then\r\n ThData := gvDebuger.GetThreadData(SyncObjsInfo^.ThreadId, True);\r\n\r\n if ThData = Nil then\r\n Continue; // TODO: - \r\n //RaiseDebugCoreException();\r\n\r\n case SyncObjsInfo^.SyncObjsType of\r\n soSleep, soWaitForSingleObject, soWaitForMultipleObjects, soEnterCriticalSection, soInCriticalSection, soSendMessage:\r\n begin\r\n ThData^.DbgSyncObjsInfo.BeginRead;\r\n try\r\n SyncObjsLink := nil;\r\n SyncObjsLinkExt := nil;\r\n\r\n if SyncObjsInfo^.SyncObjsStateType = sosLeave then\r\n begin\r\n // sosEnter \r\n if SyncObjsInfo^.SyncObjsType = soInCriticalSection then\r\n begin\r\n // Id Id , CS\r\n // CS SyncObjsStateType = sosEnter\r\n\r\n SyncObjsLink := FindCSLink(SyncObjsInfo^.CS);\r\n end\r\n else\r\n begin\r\n // Id \r\n\r\n if ThData^.DbgSyncObjsInfoByID.TryGetValue(SyncObjsInfo^.Id, SyncObjsLink) then\r\n begin\r\n // Id , EnterCriticalSection,\r\n // soInCriticalSection\r\n\r\n if SyncObjsInfo^.SyncObjsType <> soEnterCriticalSection then\r\n ThData^.DbgSyncObjsInfoByID.Remove(SyncObjsInfo^.Id);\r\n end;\r\n end;\r\n end\r\n else // sosEnter\r\n begin\r\n if SyncObjsInfo^.SyncObjsType = soInCriticalSection then\r\n begin\r\n // soEnterCriticalSection\r\n if ThData^.DbgSyncObjsInfoByID.TryGetValue(SyncObjsInfo^.Id, SyncObjsLinkExt) then\r\n ThData^.DbgSyncObjsInfoByID.Remove(SyncObjsInfo^.Id);\r\n end;\r\n end;\r\n\r\n // \r\n ThSyncObjsInfo := ThData^.DbgSyncObjsInfo.Add;\r\n\r\n if ThData^.State = tsFinished then\r\n ThSyncObjsInfo^.PerfIdx := PThreadPoint(ThData^.DbgPoints[ThData^.DbgPoints.Count - 1])^.PerfIdx\r\n else\r\n ThSyncObjsInfo^.PerfIdx := Buf^.DbgPointIdx;\r\n\r\n // \r\n ThSyncObjsInfo^.Link := SyncObjsLink;\r\n if SyncObjsLink <> nil then\r\n SyncObjsLink^.Link := ThSyncObjsInfo;\r\n\r\n // \r\n ThSyncObjsInfo^.LinkExt := SyncObjsLinkExt;\r\n if SyncObjsLinkExt <> nil then\r\n SyncObjsLinkExt^.LinkExt := ThSyncObjsInfo;\r\n\r\n // , \r\n ThSyncObjsInfo^.SyncObjsInfo.Init(SyncObjsInfo);\r\n\r\n ThData^.DbgSyncObjsInfo.Commit;\r\n\r\n // sosEnter \r\n if SyncObjsInfo^.SyncObjsStateType = sosEnter then\r\n begin\r\n if SyncObjsInfo^.SyncObjsType <> soInCriticalSection then\r\n ThData^.DbgSyncObjsInfoByID.AddOrSetValue(SyncObjsInfo^.Id, ThSyncObjsInfo);\r\n end;\r\n\r\n // \r\n case SyncObjsInfo^.SyncObjsType of\r\n soEnterCriticalSection, soInCriticalSection,\r\n soSendMessage,\r\n soWaitForSingleObject, soWaitForMultipleObjects:\r\n begin\r\n ThData^.DbgSyncObjsUnitList.LoadStack(ThSyncObjsInfo);\r\n end;\r\n end;\r\n finally\r\n ThData^.DbgSyncObjsInfo.EndRead;\r\n end;\r\n end;\r\n soLeaveCriticalSection:\r\n begin\r\n // TODO:\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TDbgSyncObjsProfiler.ProcessSyncObjsInfoQueue: LongBool;\r\nvar\r\n Buf: PDbgSyncObjsInfoListBuf;\r\nbegin\r\n Result := False;\r\n\r\n if not SyncObjsTracking then\r\n Exit;\r\n\r\n if FSyncObjsInfoQueue.Count > 0 then\r\n begin\r\n try\r\n // \r\n if FSyncObjsInfoQueue.Count < _MAX_SYNC_OBJS_INFO_BUF_COUNT then\r\n begin\r\n Buf := FSyncObjsInfoQueue.First;\r\n if (gvDebuger.ProcessData.CurDbgPointIdx - Buf^.DbgPointIdx) <= 2 then\r\n Exit;\r\n end;\r\n\r\n Buf := FSyncObjsInfoQueue.Dequeue;\r\n try\r\n ProcessSyncObjsInfoBuf(Buf);\r\n finally\r\n FreeMemory(Buf^.DbgSyncObjsInfoList);\r\n FreeMemory(Buf);\r\n end;\r\n\r\n Result := True;\r\n except\r\n on E: Exception do ; // TODO:\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TDbgSyncObjsProfiler.SetSyncObjsTracking(const Value: LongBool);\r\nbegin\r\n FSyncObjsTracking := Value;\r\nend;\r\n\r\nend.\r\n" }, { "path": "DbgWorkerThread.pas", "content": "unit DbgWorkerThread;\r\n\r\ninterface\r\n\r\nuses System.Classes, System.SysUtils;\r\n\r\ntype\r\n TDbgWorkerThread = class(TThread)\r\n protected\r\n procedure Execute; override;\r\n public\r\n constructor Create;\r\n destructor Destroy; override;\r\n\r\n procedure Stop;\r\n\r\n class procedure Init; static;\r\n class procedure Reset; static;\r\n end;\r\n\r\nvar\r\n gvDbgWorkerThread: TDbgWorkerThread = Nil;\r\n\r\nimplementation\r\n\r\nuses Debuger;\r\n\r\n{ TDbgWorkerThread }\r\n\r\nconstructor TDbgWorkerThread.Create;\r\nbegin\r\n inherited Create(False);\r\n FreeOnTerminate := False;\r\nend;\r\n\r\ndestructor TDbgWorkerThread.Destroy;\r\nbegin\r\n inherited;\r\nend;\r\n\r\nprocedure TDbgWorkerThread.Execute;\r\nvar\r\n HasNext: LongBool;\r\nbegin\r\n NameThreadForDebugging(ClassName);\r\n\r\n repeat\r\n HasNext := False;\r\n\r\n if Assigned(gvDebuger) then\r\n begin\r\n HasNext := gvDebuger.DbgSamplingProfiler.ProcessSamplingInfo;\r\n\r\n HasNext := gvDebuger.DbgMemoryProfiler.ProcessMemoryInfoQueue or HasNext;\r\n HasNext := gvDebuger.DbgSysncObjsProfiler.ProcessSyncObjsInfoQueue or HasNext;\r\n\r\n if not HasNext then\r\n Sleep(10);\r\n end;\r\n until Terminated and not(HasNext);\r\nend;\r\n\r\nclass procedure TDbgWorkerThread.Init;\r\nbegin\r\n if gvDebuger.CodeTracking or\r\n gvDebuger.DbgMemoryProfiler.MemoryCheckMode or\r\n gvDebuger.DbgSysncObjsProfiler.SyncObjsTracking\r\n then\r\n begin\r\n if gvDbgWorkerThread = Nil then\r\n gvDbgWorkerThread := TDbgWorkerThread.Create;\r\n end;\r\nend;\r\n\r\nclass procedure TDbgWorkerThread.Reset;\r\nbegin\r\n if Assigned(gvDbgWorkerThread) then\r\n begin\r\n gvDbgWorkerThread.Stop;\r\n FreeAndNil(gvDbgWorkerThread);\r\n end;\r\nend;\r\n\r\nprocedure TDbgWorkerThread.Stop;\r\nbegin\r\n Terminate;\r\n WaitFor;\r\nend;\r\n\r\n\r\nend.\r\n" }, { "path": "DebugHook.pas", "content": "unit DebugHook;\r\n\r\ninterface\r\n\r\nuses Windows, DebugInfo;\r\n\r\nfunction LoadDbgHookDll(hProcess: THandle; const DllPath: String; ImageBase: Pointer; MemoryMgr: TVarInfo; _vmtClassName: Integer;\r\n MemoryCallStack: LongBool; SyncObjsHook: LongBool): LongBool;\r\nfunction UnLoadDbgHookDll(hProcess: THandle; const DllPath: String): LongBool;\r\n\r\nimplementation\r\n\r\nuses Debuger;\r\n\r\ntype\r\n TInfoName = array[0..31] of AnsiChar;\r\n TInfoPathName = array[0..(MAX_PATH - 1)] of AnsiChar;\r\n TStrTemp = array[0..255] of AnsiChar;\r\n\r\n PDbgLoaderInfo = ^TDbgLoaderInfo;\r\n TDbgLoaderInfo = record\r\n LoadLibrary : function(lpLibFileName: PAnsiChar): HMODULE; stdcall;\r\n GetProcAddress : function(hModule: HMODULE; lpProcName: LPCSTR): FARPROC; stdcall;\r\n OutputDebugStringA : procedure (lpOutputString: LPCSTR); stdcall;\r\n lstrcpyA: function (lpString1, lpString2: LPCSTR): LPSTR; stdcall;\r\n lstrlenA: function (lpString: LPCSTR): Integer; stdcall;\r\n\r\n sKernel32 : TInfoName;\r\n sUser32 : TInfoName;\r\n sExitThread : TInfoName;\r\n sDllPath : TInfoPathName;\r\n\r\n sDllProcThreadHook: TInfoName;\r\n sDllProcMemoryHook: TInfoName;\r\n sDllProcPerfomance: TInfoName;\r\n sDllProcSyncObjsHook: TInfoName;\r\n\r\n slstrcpyA: TInfoName;\r\n slstrlenA: TInfoName;\r\n\r\n sTemp: TStrTemp;\r\n\r\n ImageBase : Pointer;\r\n vmtClassName : Integer;\r\n MemoryMgr : Pointer;\r\n MemoryCallStack : LongBool;\r\n PerfDelta : Cardinal;\r\n\r\n SyncObjsHook : LongBool;\r\n end;\r\n\r\nprocedure _DbgLoader(DbgLoaderInfo: PDbgLoaderInfo); stdcall;\r\nvar\r\n HLib: HMODULE;\r\n\r\n ExitThread: procedure(uExitCode: UINT); stdcall;\r\n InitThreadHook: function(ImageBase: Pointer; _vmtClassName: Integer): LongBool; stdcall;\r\n InitSyncObjsHook: function(ImageBase: Pointer): LongBool; stdcall;\r\n InitMemoryHook: procedure(MemoryMgr: Pointer; MemoryCallStack: LongBool); stdcall;\r\n InitPerfomance: procedure(Delta: Cardinal); stdcall;\r\nbegin\r\n //asm\r\n // int 3; // breakpoint for testing\r\n //end;\r\n\r\n if DbgLoaderInfo = nil then Exit;\r\n\r\n with DbgLoaderInfo^ do\r\n begin\r\n HLib := DbgLoaderInfo.LoadLibrary(sKernel32);\r\n\r\n if HLib = 0 then Exit;\r\n\r\n @ExitThread := DbgLoaderInfo.GetProcAddress(HLib, sExitThread);\r\n\r\n if @ExitThread = nil then Exit;\r\n\r\n HLib := DbgLoaderInfo.LoadLibrary(sDllPath);\r\n if HLib <> 0 then\r\n begin\r\n @InitThreadHook := DbgLoaderInfo.GetProcAddress(HLib, sDllProcThreadHook);\r\n @InitSyncObjsHook := DbgLoaderInfo.GetProcAddress(HLib, sDllProcSyncObjsHook);\r\n @InitMemoryHook := DbgLoaderInfo.GetProcAddress(HLib, sDllProcMemoryHook);\r\n @InitPerfomance := DbgLoaderInfo.GetProcAddress(HLib, sDllProcPerfomance);\r\n\r\n if (@InitThreadHook <> nil) and InitThreadHook(ImageBase, vmtClassName) then\r\n begin\r\n // 1 - \r\n if SyncObjsHook and (@InitSyncObjsHook <> nil) then\r\n InitSyncObjsHook(ImageBase);\r\n\r\n // 2 - \r\n if (@InitMemoryHook <> nil) and (MemoryMgr <> Nil) then\r\n InitMemoryHook(MemoryMgr, MemoryCallStack);\r\n\r\n // 3 - \r\n if (@InitPerfomance <> nil) then\r\n InitPerfomance(PerfDelta);\r\n end;\r\n\r\n ExitThread(0);\r\n end\r\n else\r\n ExitThread(1);\r\n end;\r\nend;\r\nprocedure _DbgLoaderEnd; begin end;\r\n\r\nfunction LoadDbgHookDll(hProcess: THandle; const DllPath: String; ImageBase: Pointer; MemoryMgr: TVarInfo; _vmtClassName: Integer;\r\n MemoryCallStack: LongBool; SyncObjsHook: LongBool): LongBool;\r\nvar\r\n DbgLoaderInfo: TDbgLoaderInfo;\r\n hKernel32: THandle;\r\nbegin\r\n ZeroMemory(@DbgLoaderInfo, SizeOf(TDbgLoaderInfo));\r\n\r\n DbgLoaderInfo.ImageBase := ImageBase;\r\n\r\n DbgLoaderInfo.vmtClassName := _vmtClassName;\r\n\r\n if Assigned(MemoryMgr) then\r\n DbgLoaderInfo.MemoryMgr := Pointer(MemoryMgr.Offset)\r\n else\r\n DbgLoaderInfo.MemoryMgr := nil;\r\n\r\n DbgLoaderInfo.MemoryCallStack := MemoryCallStack;\r\n DbgLoaderInfo.PerfDelta := 10;\r\n\r\n DbgLoaderInfo.SyncObjsHook := SyncObjsHook;\r\n\r\n hKernel32 := GetModuleHandle('kernel32.dll');\r\n @DbgLoaderInfo.LoadLibrary := GetProcAddress(hKernel32, 'LoadLibraryA');\r\n @DbgLoaderInfo.GetProcAddress := GetProcAddress(hKernel32, 'GetProcAddress');\r\n @DbgLoaderInfo.OutputDebugStringA := GetProcAddress(hKernel32, 'OutputDebugStringA');;\r\n @DbgLoaderInfo.lstrcpyA := GetProcAddress(hKernel32, 'lstrcpyA');\r\n @DbgLoaderInfo.lstrlenA := GetProcAddress(hKernel32, 'lstrlenA');\r\n\r\n lstrcpyA(DbgLoaderInfo.sKernel32, 'kernel32.dll');\r\n lstrcpyA(DbgLoaderInfo.sUser32, 'user32.dll');\r\n lstrcpyA(DbgLoaderInfo.sExitThread, 'ExitThread');\r\n lstrcpyA(DbgLoaderInfo.sDllPath, PAnsiChar(AnsiString(DllPath)));\r\n lstrcpyA(DbgLoaderInfo.sDllProcThreadHook, 'InitThreadHook');\r\n lstrcpyA(DbgLoaderInfo.sDllProcSyncObjsHook, 'InitSyncObjsHook');\r\n lstrcpyA(DbgLoaderInfo.sDllProcMemoryHook, 'InitMemoryHook');\r\n //lstrcpyA(DbgLoaderInfo.sDllProcPerfomance, 'InitPerfomance');\r\n\r\n try\r\n gvDebuger.InjectThread(hProcess,\r\n @_DbgLoader, Cardinal(@_DbgLoaderEnd) - Cardinal(@_DbgLoader),\r\n @DbgLoaderInfo, SizeOf(TDbgLoaderInfo), False);\r\n\r\n Result := True;\r\n except\r\n Raise;\r\n end;\r\nend;\r\n\r\ntype\r\n PDbgUnLoaderInfo = ^TDbgLoaderInfo;\r\n TDbgUnLoaderInfo = record\r\n LoadLibrary : function(lpLibFileName: PAnsiChar): HMODULE; stdcall;\r\n GetProcAddress : function(hModule: HMODULE; lpProcName: LPCSTR): FARPROC; stdcall;\r\n sKernel32 : TInfoName;\r\n sUser32 : TInfoName;\r\n sExitThread : TInfoName;\r\n sDllPath : TInfoPathName;\r\n\r\n sDllResetThreadHook: TInfoName;\r\n sDllResetSyncObjsHook: TInfoName;\r\n sDllResetMemoryHook: TInfoName;\r\n sDllResetPerfomance: TInfoName;\r\n end;\r\n\r\nprocedure _DbgUnLoader(DbgLoaderInfo: PDbgLoaderInfo); stdcall;\r\nvar\r\n HLib: HMODULE;\r\n\r\n ExitThread: procedure(uExitCode: UINT); stdcall;\r\n ResetThreadHook: procedure; stdcall;\r\n ResetSyncObjsHook: procedure; stdcall;\r\n ResetMemoryHook: procedure; stdcall;\r\n ResetPerfomance: procedure; stdcall;\r\nbegin\r\n with DbgLoaderInfo^ do\r\n begin\r\n HLib := LoadLibrary(sKernel32);\r\n @ExitThread := GetProcAddress(HLib, sExitThread);\r\n\r\n HLib := LoadLibrary(sDllPath);\r\n @ResetThreadHook := GetProcAddress(HLib, sDllProcThreadHook);\r\n @ResetSyncObjsHook := GetProcAddress(HLib, sDllProcSyncObjsHook);\r\n @ResetMemoryHook := GetProcAddress(HLib, sDllProcMemoryHook);\r\n @ResetPerfomance := GetProcAddress(HLib, sDllProcPerfomance);\r\n\r\n if @ResetPerfomance <> Nil then\r\n ResetPerfomance();\r\n\r\n if @ResetMemoryHook <> Nil then\r\n ResetMemoryHook();\r\n\r\n if @ResetSyncObjsHook <> Nil then\r\n ResetSyncObjsHook();\r\n\r\n if @ResetThreadHook <> Nil then\r\n ResetThreadHook();\r\n\r\n ExitThread(0);\r\n end;\r\nend;\r\nprocedure _DbgUnLoaderEnd; begin end;\r\n\r\nfunction UnLoadDbgHookDll(hProcess: THandle; const DllPath: String): LongBool;\r\nvar\r\n DbgUnLoaderInfo: TDbgLoaderInfo;\r\nbegin\r\n Result := False;\r\n\r\n ZeroMemory(@DbgUnLoaderInfo, SizeOf(TDbgUnLoaderInfo));\r\n\r\n @DbgUnLoaderInfo.LoadLibrary := GetProcAddress(GetModuleHandle('kernel32.dll'), 'LoadLibraryA');\r\n @DbgUnLoaderInfo.GetProcAddress := GetProcAddress(GetModuleHandle('kernel32.dll'), 'GetProcAddress');\r\n\r\n lstrcpyA(DbgUnLoaderInfo.sKernel32, 'kernel32.dll');\r\n lstrcpyA(DbgUnLoaderInfo.sUser32, 'user32.dll');\r\n lstrcpyA(DbgUnLoaderInfo.sExitThread, 'ExitThread');\r\n lstrcpyA(DbgUnLoaderInfo.sDllPath, PAnsiChar(AnsiString(DllPath)));\r\n lstrcpyA(DbgUnLoaderInfo.sDllProcThreadHook, 'ResetThreadHook');\r\n lstrcpyA(DbgUnLoaderInfo.sDllProcSyncObjsHook, 'ResetSyncObjsHook');\r\n lstrcpyA(DbgUnLoaderInfo.sDllProcMemoryHook, 'ResetMemoryHook');\r\n lstrcpyA(DbgUnLoaderInfo.sDllProcPerfomance, 'ResetPerfomance');\r\n\r\n try\r\n gvDebuger.InjectThread(hProcess,\r\n @_DbgLoader, Cardinal(@_DbgLoaderEnd) - Cardinal(@_DbgLoader),\r\n @DbgUnLoaderInfo, SizeOf(TDbgUnLoaderInfo), False);\r\n\r\n Result := True;\r\n except\r\n // Raise;\r\n end;\r\nend;\r\n\r\nend.\r\n" }, { "path": "DebugInfo.pas", "content": "Unit DebugInfo;\r\n\r\nInterface\r\n\r\nUses\r\n SysUtils, Windows, Classes, Debuger, DebugerTypes, Generics.Collections, Generics.Defaults;\r\n\r\nType\r\n TFindResult = (slNotFound = 0, slFoundExact, slFoundNotExact, slFoundWithoutLine);\r\n\r\nType\r\n TSegmentCodeInfo = Class;\r\n TUnitInfo = Class;\r\n TFuncInfo = Class;\r\n TTypeInfo = Class;\r\n TUnitSourceModuleInfo = class;\r\n\r\n TLineInfo = Class\r\n public\r\n LineNo: Integer;\r\n Address: Pointer;\r\n SrcSegment: TUnitSourceModuleInfo;\r\n End;\r\n\r\n TLineInfoList = TObjectList;\r\n\r\n TTypeKind = (tkBoolean, tkWordBool, tkLongBool, tkShortInt, tkSmallInt, tkInteger, tkInt64, tkByte, tkWord, tkCardinal, tkUInt64, tkSingle, tkReal48, tkReal, tkExtended, tkCurrency, tkComplex,\r\n tkPString, tkLString, tkWString, tkChar, tkPointer, tkSubRange, tkArray, tkEnum, tkStructure, tkClass, tkSet, tkVariant, tkProperty, tkFieldList, tkClosure, tkClassRef, tkWideChar, tkProcedure,\r\n tkArgList, tkMFunction, tkVoid, tkObject, tkDynamicArray);\r\n\r\n TNameId = type Integer;\r\n\r\n TNameInfo = Class(TObject)\r\n public\r\n NameId: Integer;\r\n SymbolInfo: TObject; // TJclTD32SymbolInfo\r\n\r\n function Name: AnsiString; virtual; abstract;\r\n function ShortName: String; virtual; abstract;\r\n End;\r\n\r\n TNameIdList = TDictionary;\r\n\r\n TNameList = Class(TList)\r\n private\r\n FNameIdList: TNameIdList;\r\n FFreeItems: LongBool;\r\n function GetNameInfoItem(const Index: Integer): TNameInfo;\r\n protected\r\n procedure Notify(Ptr: Pointer; Action: TListNotification); override;\r\n procedure CheckNameIdList;\r\n public\r\n constructor Create;\r\n destructor Destroy; override;\r\n\r\n procedure Clear; override;\r\n\r\n function FindByName(Const Name: AnsiString; const SubStr: LongBool = False): TNameInfo;\r\n function FindByNameId(Const NameId: TNameId): TNameInfo;\r\n\r\n property NameInfoItems[const Index: Integer]: TNameInfo read GetNameInfoItem; default;\r\n property FreeItems: LongBool read FFreeItems write FFreeItems;\r\n End;\r\n\r\n TTypeInfo = Class(TNameInfo)\r\n public\r\n Kind: TTypeKind;\r\n BaseType: TTypeInfo;\r\n DataSize: Integer;\r\n MinValue: Integer;\r\n MaxValue: Integer;\r\n IndexType: TTypeInfo;\r\n\r\n Members: TNameList;\r\n Elements: TNameList;\r\n\r\n UnitInfo: TUnitInfo;\r\n TypeInfoIdx: Integer; // Index in UnitInfo.Types\r\n\r\n Constructor Create;\r\n Destructor Destroy; Override;\r\n\r\n function Name: AnsiString; override;\r\n function ShortName: String; override;\r\n\r\n function KindAsString: String;\r\n function TypeOf: String;\r\n function ElementsToString: String;\r\n end;\r\n\r\n TEnumInfo = Class(TNameInfo)\r\n public\r\n TypeInfo: TTypeInfo;\r\n OrderValue: Integer;\r\n\r\n function Name: AnsiString; override;\r\n function ShortName: String; override;\r\n End;\r\n\r\n TConstInfo = Class(TNameInfo)\r\n private\r\n FValue: Variant;\r\n procedure SetValue(const Value: Variant);\r\n public\r\n TypeInfo: TTypeInfo;\r\n Owner: TSegmentCodeInfo;\r\n\r\n function Name: AnsiString; override;\r\n function ShortName: String; override;\r\n\r\n function UnitInfo: TUnitInfo;\r\n\r\n function ValueAsString: String;\r\n\r\n property Value: Variant read FValue write SetValue;\r\n End;\r\n\r\n TRegInfo = Class\r\n public\r\n StartOffset: Cardinal;\r\n EndOffset: Cardinal;\r\n RegisterIndex: Integer;\r\n End;\r\n\r\n TVarKind = (vkGlobal, vkStack, vkRegister, vkLink, vkTLS);\r\n\r\n TVarInfo = Class(TNameInfo)\r\n public\r\n DataType: TTypeInfo;\r\n Owner: TSegmentCodeInfo;\r\n VarKind: TVarKind;\r\n // IsPointer : LongBool;\r\n // ByRef : LongBool;\r\n Offset: Integer;\r\n RegisterRanges: TList;\r\n\r\n Constructor Create;\r\n Destructor Destroy; Override;\r\n\r\n function UnitInfo: TUnitInfo;\r\n\r\n function Name: AnsiString; override;\r\n function ShortName: String; override;\r\n\r\n function DataTypeName: String;\r\n\r\n function AsString: String;\r\n\r\n function Value: Variant;\r\n End;\r\n\r\n TMemberScope = (msPrivate, msProtected, msPublic);\r\n\r\n TStructMember = Class(TNameInfo)\r\n public\r\n DataType: TTypeInfo;\r\n Offset: Integer;\r\n DataSize: Integer;\r\n Scope: TMemberScope;\r\n AliasNameId: TNameId;\r\n MethodNameId: TNameId;\r\n Method: TFuncInfo; // read function for properties\r\n IsDefault: LongBool; // true for default property\r\n\r\n function Alias: AnsiString; // read field for properties\r\n function MethodName: AnsiString; // read function name for properties\r\n\r\n function Name: AnsiString; override;\r\n function ShortName: String; override;\r\n end;\r\n\r\n // .text,.itext,.data,.bss,.tls,.pdata,.idata,.didata,.rdata,.reloc,.rsrc\r\n TSegmentType = (ustUnknown = 0, ustCode, ustICode, ustData, ustBSS, ustTLS, ustPData, ustIData, ustDIData, ustRData, ustReloc, ustSrc);\r\n\r\n TSegmentClassInfo = class\r\n public\r\n Address: Pointer;\r\n Size: Cardinal;\r\n SegType: TSegmentType;\r\n ID: Word;\r\n\r\n function SegTypeName: String;\r\n class function StrToSegmentType(const Str: String): TSegmentType; static;\r\n end;\r\n\r\n TUnitSegmentInfo = Class\r\n public\r\n UnitInfo: TUnitInfo;\r\n Address: Pointer;\r\n Size: Cardinal;\r\n SegmentClassInfo: TSegmentClassInfo;\r\n End;\r\n\r\n TUnitSourceModuleInfo = Class(TNameInfo)\r\n public\r\n UnitInfo: TUnitInfo;\r\n Lines: TLineInfoList;\r\n Address: Pointer;\r\n\r\n Constructor Create;\r\n Destructor Destroy; Override;\r\n\r\n Procedure Clear; Virtual;\r\n\r\n function Name: AnsiString; Override;\r\n function ShortName: String; override;\r\n\r\n function FullUnitName: String;\r\n End;\r\n\r\n TDebugInfo = Class;\r\n\r\n TSegmentCodeInfo = Class(TNameInfo)\r\n public\r\n Address: Pointer;\r\n Size: Cardinal;\r\n\r\n Consts: TNameList;\r\n Types: TNameList;\r\n Vars: TNameList;\r\n Funcs: TNameList;\r\n\r\n Lines: TLineInfoList;\r\n\r\n Constructor Create;\r\n Destructor Destroy; Override;\r\n\r\n function Name: AnsiString; override;\r\n function ShortName: String; override;\r\n\r\n Procedure Clear; Virtual;\r\n\r\n function FindTypeByName(const TypeName: AnsiString; const SubStr: LongBool = False): TTypeInfo;\r\n function FindFuncByName(const FuncName: AnsiString; const SubStr: LongBool = False): TFuncInfo;\r\n function FindFuncByNameId(const FuncNameId: Integer): TFuncInfo;\r\n function FindConstByName(const ConstName: AnsiString; const SubStr: LongBool = False): TConstInfo;\r\n function FindVarByName(const VarName: AnsiString; const SubStr: LongBool = False): TVarInfo;\r\n\r\n function CheckAddress(const Addr: Pointer): Integer;\r\n End;\r\n\r\n ISegmentCodeInfoComparer = IComparer;\r\n\r\n TSegmentCodeInfoComparer = class(TInterfacedObject, ISegmentCodeInfoComparer)\r\n public\r\n function Compare(const Left, Right: TSegmentCodeInfo): Integer;\r\n end;\r\n\r\n TSegmentCodeInfoList = Class(TList)\r\n private\r\n FSorted: LongBool;\r\n public\r\n constructor Create;\r\n destructor Destroy; override;\r\n\r\n procedure CheckSorted;\r\n procedure UpdateSort;\r\n\r\n function FindByAddress(const Address: Pointer): TSegmentCodeInfo;\r\n End;\r\n\r\n TFuncInfo = Class(TSegmentCodeInfo)\r\n UnitInfo: TUnitInfo;\r\n UnitSegment: TUnitSegmentInfo;\r\n\r\n Params: TNameList; // TODO: Vars\r\n\r\n ResultType: TTypeInfo;\r\n\r\n Parent: TFuncInfo;\r\n ID: TObject;\r\n ParentID: TObject;\r\n\r\n Constructor Create;\r\n Destructor Destroy; Override;\r\n\r\n function ShortName: String; override;\r\n\r\n function ParamsAsString: String;\r\n End;\r\n\r\n TUnitType = (utProject, utSystem, utComponentLib, utExternal, utUnknown);\r\n\r\n TUnitInfo = Class(TSegmentCodeInfo)\r\n protected\r\n function GetUnitType: TUnitType;\r\n public\r\n Segments: TList;\r\n SourceSegments: TList;\r\n UsedUnits: TStringList;\r\n FuncsByAddr: TSegmentCodeInfoList;\r\n\r\n Constructor Create;\r\n Destructor Destroy; Override;\r\n\r\n Procedure Clear; Override;\r\n\r\n function ShortName: String; Override;\r\n\r\n function FullUnitName: String;\r\n\r\n function FindSegmentByAddr(const Addr: Pointer; const SegmentID: Word = 0): TUnitSegmentInfo;\r\n function FindSourceSegmentByNameId(const NameId: TNameId): TUnitSourceModuleInfo;\r\n function FindSourceSegmentByAddr(const Addr: Pointer): TUnitSourceModuleInfo;\r\n\r\n property UnitType: TUnitType read GetUnitType;\r\n end;\r\n\r\n TDLLInfo = Class(TSegmentCodeInfo)\r\n\r\n End;\r\n\r\n PAddressInfo = ^RAddressInfo;\r\n\r\n RAddressInfo = record\r\n Addr: Pointer;\r\n UnitInfo: TUnitInfo;\r\n FuncInfo: TFuncInfo;\r\n LineInfo: TLineInfo;\r\n FindResult: TFindResult;\r\n end;\r\n\r\n TAddressInfoList = class(TDictionary)\r\n private\r\n FLock: TMREWSync;\r\n protected\r\n procedure ValueNotify(const Value: PAddressInfo; Action: TCollectionNotification); override;\r\n public\r\n constructor Create(ACapacity: Integer = 0);\r\n destructor Destroy; override;\r\n\r\n property Lock: TMREWSync read FLock;\r\n end;\r\n\r\n TStackEntry = Class\r\n Public\r\n UnitInfo: TUnitInfo;\r\n FuncInfo: TFuncInfo;\r\n LineInfo: TLineInfo;\r\n EIP: Pointer;\r\n RET: Pointer;\r\n EBP: Pointer;\r\n\r\n Constructor Create;\r\n Function GetInfo: String;\r\n Function UpdateInfo(Const Addr: Pointer = nil): TFindResult;\r\n End;\r\n\r\n TDebugInfoProgressCallback = procedure(const Action: String; const Progress: Integer) of object;\r\n\r\n TDbgSourceDirListItem = record\r\n ShortFileName: String;\r\n FileName: String;\r\n HashCode : Cardinal;\r\n end;\r\n\r\n TDbgSourceDirList = class\r\n private\r\n FBuckets: array of TDbgSourceDirListItem;\r\n FCount: Integer;\r\n FGrowth: Integer;\r\n FCapacity: Integer;\r\n protected\r\n procedure Grow;\r\n function LinearFind(const HashCode: Cardinal; const ShortFileName: String; var Index : Integer): Boolean;\r\n function SameItem(const HashCode1, HashCode2: Cardinal; const ShortFileName1, ShortFileName2: String): Boolean;\r\n function GetItemHashCode(const ShortFileName: String): Integer;\r\n public\r\n function Add(const FileName: String): Boolean;\r\n function Contains(const ShortFileName: String): Boolean;\r\n function TryGetValue(const ShortFileName: String; out FileName: String): Boolean;\r\n procedure Clear;\r\n\r\n property Count : Integer read FCount;\r\n end;\r\n\r\n TDbgSourceList = Array [Low(TUnitType) .. High(TUnitType)] of TDbgSourceDirList;\r\n\r\n TMemoryManagerInfo = class\r\n public\r\n VarInfo: TVarInfo;\r\n GetMem: TFuncInfo;\r\n FreeMem: TFuncInfo;\r\n ReallocMem: TFuncInfo;\r\n AllocMem: TFuncInfo;\r\n\r\n constructor Create;\r\n procedure Clear;\r\n end;\r\n\r\n TRTLInfo = class\r\n public\r\n vmtClassNameInfo: TConstInfo;\r\n\r\n constructor Create;\r\n procedure Clear;\r\n\r\n function vmtClassName: Integer;\r\n end;\r\n\r\n TDebugInfoClass = Class Of TDebugInfo;\r\n\r\n TDebugInfo = Class\r\n Private\r\n FDirs: TDbgSourceList;\r\n FSegments: TStringList;\r\n FUnits: TStringList; // Sorted by name\r\n FUnitsByAddr: TSegmentCodeInfoList; // Sorted by Address\r\n FDbgLog: TDbgLog;\r\n FMemoryManagerInfo: TMemoryManagerInfo;\r\n FRTLInfo: TRTLInfo;\r\n\r\n FExeFileName: String;\r\n FDebugInfoLoaded: LongBool;\r\n\r\n FDebugInfoProgressCallback: TDebugInfoProgressCallback;\r\n FLastProgressAction: String;\r\n FLastProgress: Integer;\r\n\r\n function GetDirs(const SourceType: TUnitType): TDbgSourceDirList;\r\n procedure ClearDirs;\r\n Protected\r\n FDebugInfoType: String;\r\n FUseShortNames: LongBool;\r\n\r\n procedure DoProgress(const Action: String; const Progress: Integer); virtual;\r\n Function DoReadDebugInfo(Const FileName: String; ALoadDebugInfo: LongBool): LongBool; Virtual; abstract;\r\n\r\n function GetSegmentByID(const ID: Word): TSegmentClassInfo;\r\n function GetSegmentByType(const SegType: TSegmentType): TSegmentClassInfo;\r\n\r\n function ParseUnitName(UnitInfo: TUnitInfo; const WithExt: LongBool = True): String; virtual;\r\n function ParseFuncName(FuncInfo: TFuncInfo): String; virtual;\r\n function ParseTypeName(TypeInfo: TTypeInfo): String; virtual;\r\n function ParseConstName(ConstInfo: TConstInfo): String; virtual;\r\n function ParseVarName(VarInfo: TVarInfo): String; virtual;\r\n function ParseStructMemberName(StructMember: TStructMember): String; virtual;\r\n Public\r\n Constructor Create;\r\n Destructor Destroy; Override;\r\n\r\n Procedure ClearDebugInfo; Virtual;\r\n Function HasDebugInfo(Const FileName: String): LongBool; Virtual; abstract;\r\n Function ReadDebugInfo(Const FileName: String): LongBool; Virtual;\r\n Function GetFileCount: Integer; Virtual;\r\n Function GetFile(Index: Integer): String; Virtual;\r\n Function GetTypeInfo(Const TypeName: String): TTypeInfo; Virtual;\r\n Function GetAddrInfo(Var Addr: Pointer; Const FileName: String; Line: Cardinal): TFindResult; Virtual; abstract;\r\n Procedure GetCallStackItems(const ThreadID: TThreadId; Const ExceptAddr, ExceptFrame: Pointer; StackItems: TList); Virtual;\r\n\r\n Function GetLineInfo(const Addr: Pointer; Var UnitInfo: TUnitInfo; Var FuncInfo: TFuncInfo; Var LineInfo: TLineInfo; GetPrevLine: LongBool): TFindResult; Virtual; abstract;\r\n Function GetLineInformation(const Addr: Pointer; Var UnitName: String; Var FuncName: String; Var Line: LongInt; GetPrevLine: LongBool): TFindResult; Virtual;\r\n\r\n procedure UpdateSourceDirs(const SourceType: TUnitType; const SourceDirs: String); virtual;\r\n procedure AddSourceDir(const SourceDir: TDbgSourceDirList; const Dir: String; const Recursive: LongBool = True); virtual;\r\n\r\n function FullUnitName(const UnitName: String): String;\r\n function GetUnitType(const UnitName: String): TUnitType;\r\n\r\n Function MakeFuncDbgFullName(Const ClassName, MethodName: AnsiString): AnsiString; Virtual; abstract;\r\n Function MakeFuncShortName(Const MethodName: AnsiString): AnsiString; Virtual; abstract;\r\n Function MakeFuncNativeName(Const MethodName: AnsiString): AnsiString; Virtual; abstract;\r\n\r\n Function FuncByName(const FuncName: AnsiString): TFuncInfo;\r\n\r\n Function Evaluate(BriefMode: LongBool; Const Expression: String; Const TimeOut: Cardinal = INFINITE): String; Virtual; abstract;\r\n\r\n Function EvaluateVariable(VarInfo: TVarInfo): Variant; virtual; abstract;\r\n Function VarValueAsString(const Value: Variant): String; virtual; abstract;\r\n\r\n procedure SetMemoryManagerBreakpoints; Virtual; abstract;\r\n procedure ResetMemoryManagerBreakpoints; Virtual; abstract;\r\n\r\n Procedure InitDebugHook; Virtual; abstract;\r\n\r\n Function GetNameById(const Idx: TNameId): AnsiString; virtual; abstract;\r\n\r\n Function CheckAddr(Const Addr: Pointer): LongBool; Virtual;\r\n Function DumpLineInformation(Const Addr: Pointer): String;\r\n Function GetParamsStr(FuncInfo: TFuncInfo; Const EBP: Pointer; IsTopStack: LongBool): String;\r\n\r\n Function GetClassName(Const ObjectPtr: Pointer): String; Virtual; abstract;\r\n Function GetExceptionName(ExceptionRecord: PExceptionRecord): String; Virtual;\r\n Function GetExceptionMessage(ExceptionRecord: PExceptionRecord; const ThreadID: TThreadId): String; Virtual;\r\n Function GetExceptionAddress(ExceptionRecord: PExceptionRecord): Pointer; Virtual;\r\n Function GetExceptionFrame(ExceptionRecord: PExceptionRecord): Pointer; Virtual;\r\n Function CheckDebugException(ExceptionRecord: PExceptionRecord; Var IsTraceException: LongBool): LongBool; Virtual;\r\n Function CheckSystemFile(Const FileName: String): LongBool; Virtual; abstract;\r\n\r\n Function IsSystemException(Const ExceptionCode: DWORD): LongBool;\r\n\r\n Function CheckDebugOutputMessage(DebugEvent: PDebugEvent): LongBool;\r\n Function ProcessDebugOutputMessage(Const Msg: WideString; DebugEvent: PDebugEvent): LongBool; Virtual;\r\n\r\n Function IsValidAddr(Const Addr: Pointer): LongBool;\r\n Function IsValidCodeAddr(Const Addr: Pointer): LongBool;\r\n Function IsValidStackAddr(Const Addr: Pointer; const ThreadID: TThreadId): LongBool;\r\n Function IsValidDataAddr(Const Addr: Pointer; const ThreadID: TThreadId): LongBool;\r\n\r\n // Property SourceDirs: String read FSourceDirs;\r\n Property Dirs[const SourceType: TUnitType]: TDbgSourceDirList Read GetDirs;\r\n Property Segments: TStringList Read FSegments;\r\n Property Units: TStringList Read FUnits;\r\n Property UnitsByAddr: TSegmentCodeInfoList read FUnitsByAddr;\r\n\r\n Property DbgLog: TDbgLog read FDbgLog;\r\n\r\n property DebugInfoLoaded: LongBool read FDebugInfoLoaded;\r\n property DebugInfoType: String read FDebugInfoType;\r\n property DebugInfoProgressCallback: TDebugInfoProgressCallback read FDebugInfoProgressCallback write FDebugInfoProgressCallback;\r\n property UseShortNames: LongBool read FUseShortNames write FUseShortNames;\r\n property MemoryManagerInfo: TMemoryManagerInfo read FMemoryManagerInfo;\r\n property RTLInfo: TRTLInfo read FRTLInfo;\r\n End;\r\n\r\nconst\r\n // TODO: for MACOS '_text'\r\n SegmentTypeNames: array [TSegmentType] of String =\r\n ('', 'text', 'itext', 'data', 'bss', 'tls', 'pdata', 'idata', 'didata', 'rdata', 'reloc', 'rsrc');\r\n\r\nvar\r\n gvDebugInfo: TDebugInfo = nil;\r\n\r\nImplementation\r\n\r\nUses\r\n ClassUtils, Variants, IOUtils, Types, System.AnsiStrings;\r\n\r\nfunction IncPointer(Ptr: Pointer; Offset: Integer): Pointer; inline;\r\nbegin\r\n Result := Pointer(Integer(Ptr) + Offset);\r\nend;\r\n\r\n// SimpleStringHash and SimpleLowerCaseStringHash are taken from DWScript\r\n// The code is probably under copyright of Eric Grange\r\nfunction SimpleStringHash(const s : UnicodeString) : Cardinal; inline;\r\nvar\r\n i : Integer;\r\nbegin\r\n // modified FNV-1a using length as seed\r\n Result:=Length(s);\r\n for i:=1 to Result do\r\n Result:=(Result xor Ord(s[i]))*16777619;\r\nend;\r\n\r\nfunction SimpleLowerCaseStringHash(const s : UnicodeString) : Cardinal;\r\n\r\n function Fallback(const s : UnicodeString) : Cardinal;\r\n begin\r\n Result:=SimpleStringHash(LowerCase(s));\r\n end;\r\n\r\nvar\r\n i : Integer;\r\n c : Word;\r\nbegin\r\n // modified FNV-1a using length as seed\r\n Result:=Length(s);\r\n for i:=1 to Result do begin\r\n c:=Ord(s[i]);\r\n if c>127 then\r\n Exit(Fallback(s))\r\n else if c in [Ord('A')..Ord('Z')] then\r\n c:=c+(Ord('a')-Ord('A'));\r\n Result:=(Result xor c)*16777619;\r\n end;\r\nend;\r\n\r\n\r\n{ TDebugInfo }\r\n\r\nConstructor TDebugInfo.Create;\r\nvar\r\n ST: TUnitType;\r\nBegin\r\n Inherited Create;\r\n\r\n for ST := Low(TUnitType) to High(TUnitType) do\r\n FDirs[ST] := TDbgSourceDirList.Create;\r\n\r\n FSegments := TStringList.Create;\r\n FSegments.OwnsObjects := True;\r\n\r\n FUnits := TStringList.Create;\r\n FUnitsByAddr := TSegmentCodeInfoList.Create;\r\n\r\n FDbgLog := TDbgLog.Create;\r\n\r\n FExeFileName := '';\r\n FDebugInfoLoaded := False;\r\n FDebugInfoType := '';\r\n\r\n FDebugInfoProgressCallback := Nil;\r\n FLastProgressAction := '';\r\n FLastProgress := 0;\r\n\r\n FUseShortNames := True;\r\n\r\n FMemoryManagerInfo := TMemoryManagerInfo.Create;\r\n FRTLInfo := TRTLInfo.Create;\r\nEnd;\r\n\r\nDestructor TDebugInfo.Destroy;\r\nvar\r\n ST: TUnitType;\r\nBegin\r\n ClearDebugInfo;\r\n\r\n FreeAndNil(FUnitsByAddr);\r\n FreeAndNil(FUnits);\r\n\r\n FreeAndNil(FSegments);\r\n\r\n for ST := Low(TUnitType) to High(TUnitType) do\r\n FreeAndNil(FDirs[ST]);\r\n\r\n FreeAndNil(FDbgLog);\r\n\r\n FreeAndNil(FMemoryManagerInfo);\r\n FreeAndNil(FRTLInfo);\r\n\r\n Inherited Destroy;\r\nEnd;\r\n\r\nprocedure TDebugInfo.DoProgress(const Action: String; const Progress: Integer);\r\nbegin\r\n if (FLastProgressAction <> Action) or (FLastProgress <> Progress) then\r\n begin\r\n FLastProgressAction := Action;\r\n FLastProgress := Progress;\r\n\r\n if Assigned(FDebugInfoProgressCallback) then\r\n FDebugInfoProgressCallback(Action, Progress);\r\n end;\r\nend;\r\n\r\nprocedure TDebugInfo.AddSourceDir(const SourceDir: TDbgSourceDirList; const Dir: String; const Recursive: LongBool);\r\nconst\r\n _PAS_EXTS: array [0 .. 2] of String = ('*.pas', '*.inc', '*.dpr');\r\nvar\r\n Files: TStringDynArray;\r\n J, I: Integer;\r\n FileName: String;\r\nbegin\r\n for J := 0 to High(_PAS_EXTS) do\r\n begin\r\n Files := TDirectory.GetFiles(Dir, _PAS_EXTS[J], TSearchOption.soAllDirectories);\r\n\r\n if Length(Files) > 0 then\r\n for I := 0 to High(Files) do\r\n begin\r\n FileName := Files[I];\r\n SourceDir.Add(FileName);\r\n end;\r\n end;\r\nend;\r\n\r\nFunction TDebugInfo.CheckAddr(Const Addr: Pointer): LongBool;\r\nVar\r\n UnitInfo: TUnitInfo;\r\n FuncInfo: TFuncInfo;\r\n LineInfo: TLineInfo;\r\nBegin\r\n Result := GetLineInfo(Addr, UnitInfo, FuncInfo, LineInfo, False) <> slNotFound;\r\nEnd;\r\n\r\nFunction TDebugInfo.CheckDebugException(ExceptionRecord: PExceptionRecord; Var IsTraceException: LongBool): LongBool;\r\nBegin\r\n IsTraceException := False;\r\n Case ExceptionRecord^.ExceptionCode Of\r\n EXCEPTION_SET_THREAD_NAME, STATUS_NONCONTINUABLE_EXCEPTION:\r\n Result := True;\r\n Else\r\n Result := False;\r\n End;\r\nEnd;\r\n\r\nProcedure TDebugInfo.ClearDebugInfo;\r\nBegin\r\n If FDebugInfoLoaded Then\r\n Begin\r\n FDebugInfoLoaded := False;\r\n\r\n ClearDirs;\r\n\r\n FUnitsByAddr.Clear;\r\n ClearStringList(FUnits);\r\n\r\n FDbgLog.ClearLog;\r\n\r\n FMemoryManagerInfo.Clear;\r\n FRTLInfo.Clear;\r\n\r\n FExeFileName := '';\r\n End;\r\nEnd;\r\n\r\nprocedure TDebugInfo.ClearDirs;\r\nvar\r\n ST: TUnitType;\r\nbegin\r\n for ST := Low(TUnitType) to High(TUnitType) do\r\n FDirs[ST].Clear;\r\nend;\r\n\r\nFunction TDebugInfo.ReadDebugInfo(Const FileName: String): LongBool;\r\nBegin\r\n Result := FDebugInfoLoaded And SameText(FExeFileName, FileName);\r\n\r\n If Not Result Then\r\n Begin\r\n Result := DoReadDebugInfo(FileName, True);\r\n\r\n If Result Then\r\n Begin\r\n FExeFileName := FileName;\r\n FDebugInfoLoaded := True;\r\n End;\r\n End;\r\nEnd;\r\n\r\nprocedure TDebugInfo.UpdateSourceDirs(const SourceType: TUnitType; const SourceDirs: String);\r\nvar\r\n SL: TStringList;\r\n I: Integer;\r\n S: String;\r\nbegin\r\n FDirs[SourceType].Clear;\r\n\r\n SL := TStringList.Create;\r\n try\r\n SL.Delimiter := ';';\r\n SL.StrictDelimiter := True;\r\n SL.Duplicates := dupIgnore;\r\n\r\n SL.DelimitedText := SourceDirs;\r\n\r\n for I := 0 to SL.Count - 1 do\r\n begin\r\n S := Trim(SL[I]);\r\n if (S <> '') then\r\n begin\r\n S := ExcludeTrailingPathDelimiter(S);\r\n if DirectoryExists(S) then\r\n AddSourceDir(FDirs[SourceType], S, True);\r\n end;\r\n end;\r\n finally\r\n FreeAndNil(SL);\r\n end;\r\nend;\r\n\r\nFunction TDebugInfo.DumpLineInformation(Const Addr: Pointer): String;\r\nVar\r\n UnitName: String;\r\n FuncName: String;\r\n Line: Integer;\r\nBegin\r\n If GetLineInformation(Addr, UnitName, FuncName, Line, False) <> slNotFound Then\r\n Result := Format('%p: %s@%s(%d)', [Pointer(Addr), UnitName, FuncName, Line])\r\n Else\r\n Result := Format('%p: no source info', [Pointer(Addr)]);\r\nEnd;\r\n\r\nfunction TDebugInfo.FullUnitName(const UnitName: String): String;\r\nconst\r\n _PAS = '.pas';\r\n _INC = '.inc';\r\n _DPR = '.dpr';\r\nvar\r\n Res: String;\r\n ResExt: String;\r\n ST: TUnitType;\r\nbegin\r\n for ST := Low(TUnitType) to High(TUnitType) do\r\n begin\r\n Res := AnsiLowerCase(UnitName);\r\n\r\n ResExt := ExtractFileExt(Res);\r\n\r\n if (Length(ResExt) <> 4) or ((ResExt <> _PAS) and (ResExt <> _INC) and (ResExt <> _DPR)) then\r\n Res := Res + _PAS;\r\n\r\n if not FDirs[ST].TryGetValue(Res, Result) then\r\n begin\r\n if not SameStr(ResExt, _PAS) then\r\n begin\r\n Res := ChangeFileExt(Res, _PAS);\r\n if FDirs[ST].TryGetValue(Res, Result) then\r\n Exit;\r\n end;\r\n\r\n if not SameStr(ResExt, _INC) then\r\n begin\r\n Res := ChangeFileExt(Res, _INC);\r\n if FDirs[ST].TryGetValue(Res, Result) then\r\n Exit;\r\n end;\r\n\r\n if not SameStr(ResExt, _DPR) then\r\n begin\r\n Res := ChangeFileExt(Res, _DPR);\r\n if FDirs[ST].TryGetValue(Res, Result) then\r\n Exit;\r\n end;\r\n end\r\n else\r\n Exit;\r\n end;\r\n\r\n Result := UnitName;\r\nend;\r\n\r\nfunction TDebugInfo.FuncByName(const FuncName: AnsiString): TFuncInfo;\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := 0 to Units.Count - 1 do\r\n begin\r\n Result := TUnitInfo(Units.Objects[I]).FindFuncByName(FuncName);\r\n if Assigned(Result) then\r\n Exit;\r\n end;\r\n\r\n Result := Nil;\r\nend;\r\n\r\nFunction TDebugInfo.GetFileCount: Integer;\r\nBegin\r\n Result := FUnits.Count;\r\nEnd;\r\n\r\nfunction TDebugInfo.GetLineInformation(const Addr: Pointer; var UnitName, FuncName: String; var Line: Integer; GetPrevLine: LongBool): TFindResult;\r\nVar\r\n UnitInfo: TUnitInfo;\r\n FuncInfo: TFuncInfo;\r\n LineInfo: TLineInfo;\r\nBegin\r\n UnitName := '';\r\n FuncName := '';\r\n Line := -1;\r\n\r\n Result := GetLineInfo(Addr, UnitInfo, FuncInfo, LineInfo, GetPrevLine);\r\n If Result <> slNotFound Then\r\n Begin\r\n UnitName := UnitInfo.FullUnitName;\r\n FuncName := String(FuncInfo.Name);\r\n If LineInfo <> Nil Then\r\n Line := LineInfo.LineNo;\r\n End;\r\nend;\r\n\r\nFunction TDebugInfo.GetFile(Index: Integer): String;\r\nBegin\r\n Result := TUnitInfo(FUnits[Index]).FullUnitName;\r\nEnd;\r\n\r\nFunction TDebugInfo.GetParamsStr(FuncInfo: TFuncInfo; Const EBP: Pointer; IsTopStack: LongBool): String;\r\n// Var\r\n// I : Integer;\r\n// ToStringData : TToStringData;\r\n// ParamName : String;\r\n// ParamValue : TVarInfo;\r\n// ParamEval : Variant;\r\n// ParamRes : String;\r\nBegin\r\n // Result := '';\r\n //\r\n // If (FuncInfo <> Nil) And (FuncInfo.Params.Count > 0) Then\r\n // Begin\r\n // ToStringData.DebuggeeControl := DebuggeeControl;\r\n // ToStringData.DebugInfo := Self;\r\n // ToStringData.Mode := tsmBrief;\r\n // ToStringData.RecursionLevel := 0;\r\n //\r\n // For I := 0 To FuncInfo.Params.Count - 1 Do\r\n // Begin\r\n // ParamName := FuncInfo.Params[I];\r\n // ParamValue := TVarInfo(FuncInfo.Params.Objects[I]);\r\n //\r\n // ParamRes := '???';\r\n //\r\n // If (EBP <> 0) And ((ParamValue.VarKind In [vkGlobal, vkStack]) Or (IsTopStack And (ParamValue.VarKind = vkRegister))) Then\r\n // Begin\r\n // Try\r\n // ParamEval := EvaluateVariable(DebuggeeControl, ParamValue, EBP, False);\r\n // ParamRes := VariantToString(ParamEval, ToStringData);\r\n // Except\r\n // ParamRes := '[error]';\r\n // End;\r\n // End;\r\n //\r\n // If Result <> '' Then Result := Result + ', ';\r\n // Result := Result + Format('%s=%s', [ParamName, ParamRes]);\r\n // End;\r\n //\r\n // If Result <> '' Then\r\n // Result := '(' + Result + ')';\r\n // End;\r\nEnd;\r\n\r\nfunction TDebugInfo.GetSegmentByID(const ID: Word): TSegmentClassInfo;\r\nvar\r\n Idx: Integer;\r\nbegin\r\n for Idx := 0 to Segments.Count - 1 do\r\n begin\r\n Result := TSegmentClassInfo(Segments.Objects[Idx]);\r\n if Result.ID = ID then\r\n Exit;\r\n end;\r\n\r\n Result := Nil;\r\nend;\r\n\r\nfunction TDebugInfo.GetSegmentByType(const SegType: TSegmentType): TSegmentClassInfo;\r\nvar\r\n Idx: Integer;\r\nbegin\r\n for Idx := 0 to Segments.Count - 1 do\r\n begin\r\n Result := TSegmentClassInfo(Segments.Objects[Idx]);\r\n if Result.SegType = SegType then\r\n Exit;\r\n end;\r\n\r\n Result := Nil;\r\nend;\r\n\r\nFunction TDebugInfo.GetTypeInfo(Const TypeName: String): TTypeInfo;\r\nVar\r\n UnitInfo: TUnitInfo;\r\n I: Integer;\r\nBegin\r\n Result := Nil;\r\n For I := 0 To Units.Count - 1 Do\r\n Begin\r\n UnitInfo := TUnitInfo(Units.Objects[I]);\r\n Result := UnitInfo.FindTypeByName(AnsiString(TypeName));\r\n if Result <> Nil then\r\n Exit;\r\n End;\r\nEnd;\r\n\r\nfunction TDebugInfo.GetUnitType(const UnitName: String): TUnitType;\r\nbegin\r\n for Result := Low(TUnitType) to High(TUnitType) do\r\n begin\r\n if FDirs[Result].Contains(AnsiLowerCase(UnitName)) then\r\n Exit;\r\n end;\r\n\r\n if CheckSystemFile(UnitName) then\r\n begin\r\n Result := utSystem;\r\n Exit;\r\n end;\r\n\r\n Result := utUnknown;\r\nend;\r\n\r\nFunction TDebugInfo.GetExceptionName(ExceptionRecord: PExceptionRecord): String;\r\nBegin\r\n case ExceptionRecord^.ExceptionCode of\r\n STATUS_ACCESS_VIOLATION:\r\n Result := 'EACCESS_VIOLATION';\r\n STATUS_ARRAY_BOUNDS_EXCEEDED:\r\n Result := 'EARRAY_BOUNDS_EXCEEDED';\r\n STATUS_FLOAT_DENORMAL_OPERAND:\r\n Result := 'EFLOAT_DENORMAL_OPERAND';\r\n STATUS_FLOAT_DIVIDE_BY_ZERO:\r\n Result := 'EFLOAT_DIVIDE_BY_ZERO';\r\n STATUS_FLOAT_INEXACT_RESULT:\r\n Result := 'EFLOAT_INEXACT_RESULT';\r\n STATUS_FLOAT_INVALID_OPERATION:\r\n Result := 'EFLOAT_INVALID_OPERATION';\r\n STATUS_FLOAT_OVERFLOW:\r\n Result := 'EFLOAT_OVERFLOW';\r\n STATUS_FLOAT_STACK_CHECK:\r\n Result := 'EFLOAT_STACK_CHECK';\r\n STATUS_FLOAT_UNDERFLOW:\r\n Result := 'EFLOAT_UNDERFLOW';\r\n STATUS_INTEGER_DIVIDE_BY_ZERO:\r\n Result := 'EINTEGER_DIVIDE_BY_ZERO';\r\n STATUS_INTEGER_OVERFLOW:\r\n Result := 'EINTEGER_OVERFLOW';\r\n STATUS_PRIVILEGED_INSTRUCTION:\r\n Result := 'EPRIVILEGED_INSTRUCTION';\r\n STATUS_STACK_OVERFLOW:\r\n Result := 'ESTACK_OVERFLOW';\r\n STATUS_CONTROL_C_EXIT:\r\n Result := 'ECONTROL_C_EXIT';\r\n else\r\n Result := Format('$%x', [ExceptionRecord^.ExceptionCode]);\r\n end;\r\nEnd;\r\n\r\nFunction TDebugInfo.GetExceptionAddress(ExceptionRecord: PExceptionRecord): Pointer;\r\nBegin\r\n Result := ExceptionRecord^.ExceptionAddress;\r\nEnd;\r\n\r\nfunction TDebugInfo.GetExceptionFrame(ExceptionRecord: PExceptionRecord): Pointer;\r\nbegin\r\n Result := Nil;\r\nend;\r\n\r\nFunction TDebugInfo.GetExceptionMessage(ExceptionRecord: PExceptionRecord; const ThreadID: TThreadId): String;\r\nBegin\r\n Result := '';\r\n // Result := Format('Exception \"%s($%x)\" at $%p, TID = $%x', [\r\n // GetExceptionName(ExceptionRecord),\r\n // ExceptionRecord^.ExceptionCode,\r\n // GetExceptionAddress(ExceptionRecord),\r\n // ThreadId]);\r\nEnd;\r\n\r\nprocedure TDebugInfo.GetCallStackItems(const ThreadID: TThreadId; Const ExceptAddr, ExceptFrame: Pointer; StackItems: TList);\r\n\r\n Function AddStackEntry(Const Addr, EBP: Pointer): TStackEntry;\r\n var\r\n LastStackEntry: TStackEntry;\r\n Begin\r\n Result := Nil;\r\n\r\n if StackItems.Count > 0 then\r\n begin\r\n LastStackEntry := TStackEntry(StackItems[StackItems.Count - 1]);\r\n if LastStackEntry.EBP = EBP then\r\n Exit;\r\n end;\r\n\r\n If IsValidCodeAddr(Addr) Then\r\n Begin\r\n Result := TStackEntry.Create;\r\n Result.UpdateInfo(Addr);\r\n Result.EBP := EBP;\r\n\r\n StackItems.Add(Result);\r\n End\r\n End;\r\n\r\nVar\r\n EIP: Pointer;\r\n EBP: Pointer;\r\n ESP: Pointer;\r\n ESPV: Pointer;\r\n OpCode: Byte;\r\n StackEntry: TStackEntry;\r\n ThData: PThreadData;\r\nBegin\r\n If (ExceptAddr <> nil) And (ExceptFrame <> nil) Then\r\n Begin\r\n EIP := ExceptAddr;\r\n EBP := ExceptFrame;\r\n ESP := nil;\r\n End\r\n Else\r\n Begin\r\n ThData := gvDebuger.UpdateThreadContext(ThreadID);\r\n\r\n if ThData = Nil then\r\n Exit;\r\n\r\n EIP := Pointer(ThData^.Context.EIP);\r\n EBP := Pointer(ThData^.Context.EBP);\r\n ESP := Pointer(ThData^.Context.ESP);\r\n End;\r\n\r\n StackEntry := AddStackEntry(EIP, EBP);\r\n\r\n If (ESP <> nil) And (StackEntry <> Nil) And (StackEntry.FuncInfo <> Nil) And (StackEntry.LineInfo <> Nil) Then\r\n Begin\r\n If (StackEntry.LineInfo = TLineInfo(StackEntry.FuncInfo.Lines[0])) Then\r\n Begin\r\n If (EIP = StackEntry.FuncInfo.Address) Then\r\n Begin\r\n StackEntry.EBP := nil;\r\n ESPV := Nil;\r\n if gvDebuger.ReadData(ESP, @ESPV, SizeOf(ESPV)) then\r\n AddStackEntry(ESPV, EBP);\r\n End\r\n Else\r\n Begin\r\n StackEntry.EBP := nil;\r\n ESPV := Nil;\r\n if gvDebuger.ReadData(ESP, @ESPV, SizeOf(ESPV)) then\r\n begin\r\n // push ebp; move ebp, esp;\r\n If (ESPV = EBP) Then\r\n Begin\r\n gvDebuger.ReadData(Pointer(Cardinal(ESP) + 4), @ESPV, SizeOf(ESPV));\r\n AddStackEntry(ESPV, EBP);\r\n End;\r\n end;\r\n End;\r\n End\r\n Else If (StackEntry.LineInfo = TLineInfo(StackEntry.FuncInfo.Lines[StackEntry.FuncInfo.Lines.Count - 1])) Then\r\n Begin\r\n StackEntry.EBP := nil;\r\n ESPV := Nil;\r\n OpCode := $00;\r\n // ret;\r\n if gvDebuger.ReadData(EIP, @OpCode, SizeOf(Byte)) then\r\n If OpCode In [$C3, $CB] Then\r\n Begin\r\n if gvDebuger.ReadData(ESP, @ESPV, SizeOf(ESPV)) then\r\n AddStackEntry(ESPV, EBP);\r\n End;\r\n End;\r\n End;\r\n\r\n While IsValidAddr(EBP) Do\r\n Begin\r\n if gvDebuger.ReadData(IncPointer(EBP, 4), @EIP, SizeOf(Pointer)) then\r\n begin\r\n if gvDebuger.ReadData(EBP, @EBP, SizeOf(Pointer)) then\r\n begin\r\n If AddStackEntry(EIP, EBP) = Nil Then\r\n Break;\r\n end\r\n else\r\n Break;\r\n end\r\n else\r\n Break;\r\n End;\r\nEnd;\r\n\r\nfunction TDebugInfo.GetDirs(const SourceType: TUnitType): TDbgSourceDirList;\r\nbegin\r\n Result := FDirs[SourceType];\r\nend;\r\n\r\nfunction TDebugInfo.ParseConstName(ConstInfo: TConstInfo): String;\r\nbegin\r\n Result := String(ConstInfo.Name);\r\nend;\r\n\r\nfunction TDebugInfo.ParseFuncName(FuncInfo: TFuncInfo): String;\r\nbegin\r\n Result := String(FuncInfo.Name);\r\nend;\r\n\r\nfunction TDebugInfo.ParseStructMemberName(StructMember: TStructMember): String;\r\nbegin\r\n Result := String(StructMember.Name);\r\nend;\r\n\r\nfunction TDebugInfo.ParseTypeName(TypeInfo: TTypeInfo): String;\r\nbegin\r\n Result := String(TypeInfo.Name);\r\nend;\r\n\r\nfunction TDebugInfo.ParseUnitName(UnitInfo: TUnitInfo; const WithExt: LongBool = True): String;\r\nbegin\r\n Result := ExtractFileName(UnitInfo.FullUnitName);\r\n\r\n if not WithExt then\r\n Result := ChangeFileExt(Result, '');\r\nend;\r\n\r\nfunction TDebugInfo.ParseVarName(VarInfo: TVarInfo): String;\r\nbegin\r\n Result := String(VarInfo.Name);\r\nend;\r\n\r\nFunction TDebugInfo.ProcessDebugOutputMessage(Const Msg: WideString; DebugEvent: PDebugEvent): LongBool;\r\nBegin\r\n Result := False;\r\n\r\n // IDEAPI_AddToOutputPanel(PWideChar(Msg), False, False);\r\nEnd;\r\n\r\nFunction TDebugInfo.CheckDebugOutputMessage(DebugEvent: PDebugEvent): LongBool;\r\nVar\r\n OutputStringW: WideString;\r\n OutputStringA: AnsiString;\r\n\r\n isUnicode: LongBool;\r\n StrAddr: Pointer;\r\n StrSize: Word;\r\nBegin\r\n Result := False;\r\n\r\n If DebugEvent^.dwDebugEventCode <> OUTPUT_DEBUG_STRING_EVENT Then\r\n Exit;\r\n\r\n isUnicode := WordBool(DebugEvent^.DebugString.fUnicode);\r\n StrAddr := DebugEvent^.DebugString.lpDebugStringData;\r\n StrSize := DebugEvent^.DebugString.nDebugStringLength - 1;\r\n\r\n if isUnicode then\r\n begin\r\n SetLength(OutputStringW, StrSize div SizeOf(WideChar));\r\n if not gvDebuger.ReadData(StrAddr, @OutputStringW, StrSize) then\r\n OutputStringW := '';\r\n end\r\n else\r\n begin\r\n SetLength(OutputStringA, StrSize);\r\n if not gvDebuger.ReadData(StrAddr, @OutputStringA, StrSize) then\r\n OutputStringA := '';\r\n\r\n OutputStringW := WideString(OutputStringA);\r\n end;\r\n\r\n Result := ProcessDebugOutputMessage(OutputStringW, DebugEvent);\r\nEnd;\r\n\r\nFunction TDebugInfo.IsSystemException(Const ExceptionCode: DWORD): LongBool;\r\nBegin\r\n Case ExceptionCode Of\r\n STATUS_ACCESS_VIOLATION, STATUS_ARRAY_BOUNDS_EXCEEDED, STATUS_FLOAT_DENORMAL_OPERAND, STATUS_FLOAT_DIVIDE_BY_ZERO, STATUS_FLOAT_INEXACT_RESULT, STATUS_FLOAT_INVALID_OPERATION,\r\n STATUS_FLOAT_OVERFLOW, STATUS_FLOAT_STACK_CHECK, STATUS_FLOAT_UNDERFLOW, STATUS_INTEGER_DIVIDE_BY_ZERO, STATUS_INTEGER_OVERFLOW, STATUS_PRIVILEGED_INSTRUCTION, STATUS_STACK_OVERFLOW,\r\n STATUS_CONTROL_C_EXIT:\r\n Result := True;\r\n Else\r\n Result := False;\r\n End;\r\nEnd;\r\n\r\nfunction TDebugInfo.IsValidAddr(const Addr: Pointer): LongBool;\r\nBegin\r\n Result := gvDebuger.IsValidAddr(Addr);\r\nend;\r\n\r\nfunction TDebugInfo.IsValidCodeAddr(const Addr: Pointer): LongBool;\r\nBegin\r\n Result := gvDebuger.IsValidCodeAddr(Addr);\r\nend;\r\n\r\nfunction TDebugInfo.IsValidDataAddr(const Addr: Pointer; const ThreadID: TThreadId): LongBool;\r\nbegin\r\n Result := IsValidAddr(Addr) And Not(IsValidCodeAddr(Addr) Or IsValidStackAddr(Addr, ThreadID));\r\nend;\r\n\r\nfunction TDebugInfo.IsValidStackAddr(const Addr: Pointer; const ThreadID: TThreadId): LongBool;\r\nVar\r\n TIB: Pointer;\r\n TopStack: Pointer;\r\n ThreadData: PThreadData;\r\n ThreadContext: TContext;\r\n ldtSel: LDT_ENTRY;\r\nBegin\r\n Result := False;\r\n\r\n ThreadData := gvDebuger.GetThreadData(ThreadID);\r\n\r\n if ThreadData <> nil then\r\n begin\r\n ThreadContext := gvDebuger.GetRegisters(ThreadID);\r\n If GetThreadSelectorEntry(ThreadData^.ThreadHandle, ThreadContext.SegFs, ldtSel) Then\r\n Begin\r\n TIB := Pointer((ldtSel.BaseHi shl 24) Or (ldtSel.BaseMid shl 16) Or (ldtSel.BaseLow));\r\n TopStack := nil;\r\n if gvDebuger.ReadData(Pointer(Cardinal(TIB) + 4), @TopStack, SizeOf(Pointer)) { fs:[4] } then\r\n Result := (TopStack <> nil) And (Cardinal(Addr) <= Cardinal(TopStack)) And (Cardinal(Addr) >= (ThreadContext.ESP));\r\n End;\r\n end;\r\nend;\r\n\r\n{ TFuncInfo }\r\n\r\nConstructor TFuncInfo.Create;\r\nBegin\r\n Inherited;\r\n\r\n UnitSegment := Nil;\r\n\r\n Params := TNameList.Create;\r\n Params.FreeItems := False;\r\nEnd;\r\n\r\nDestructor TFuncInfo.Destroy;\r\nBegin\r\n FreeAndNil(Params);\r\n\r\n Inherited;\r\nEnd;\r\n\r\nfunction TFuncInfo.ParamsAsString: String;\r\n// const\r\n// _Self = 'Self';\r\n// _Result = 'Result';\r\nvar\r\n I: Integer;\r\n Param: TVarInfo;\r\n Res: TStringList;\r\nbegin\r\n Result := '';\r\n\r\n Res := TStringList.Create;\r\n try\r\n for I := 0 to Params.Count - 1 do\r\n begin\r\n Param := TVarInfo(Params[I]);\r\n\r\n // TODO: , \r\n // if (I = 0) and SameText(String(Param.Name), _Self) then\r\n // Continue;\r\n\r\n // if SameText(String(Param.Name), _Result) then\r\n // Break;\r\n\r\n Res.Add(Param.AsString);\r\n end;\r\n\r\n for I := 0 to Res.Count - 1 do\r\n begin\r\n if Result <> '' then\r\n Result := Result + '; ';\r\n\r\n Result := Result + Res[I];\r\n end;\r\n finally\r\n FreeAndNil(Res);\r\n end;\r\nend;\r\n\r\nfunction TFuncInfo.ShortName: String;\r\nbegin\r\n Result := gvDebugInfo.ParseFuncName(Self);\r\nend;\r\n\r\n{ TTypeInfo }\r\n\r\nconstructor TTypeInfo.Create;\r\nbegin\r\n Inherited;\r\n\r\n NameId := -1;\r\n Members := Nil;\r\n Elements := Nil;\r\nend;\r\n\r\ndestructor TTypeInfo.Destroy;\r\nbegin\r\n FreeAndNil(Members);\r\n FreeAndNil(Elements);\r\n\r\n Inherited;\r\nend;\r\n\r\nfunction TTypeInfo.ElementsToString: String;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := '';\r\n\r\n if (Kind = tkEnum) And (Elements <> Nil) then\r\n begin\r\n for I := 0 to Elements.Count - 1 do\r\n begin\r\n if Result <> '' then\r\n Result := Result + ', ';\r\n\r\n Result := Result + Elements[I].ShortName;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TTypeInfo.KindAsString: String;\r\nbegin\r\n case Kind of\r\n tkBoolean:\r\n Result := 'Boolean';\r\n tkWordBool:\r\n Result := 'WordBool';\r\n tkLongBool:\r\n Result := 'LongBool';\r\n tkShortInt:\r\n Result := 'ShortInt';\r\n tkSmallInt:\r\n Result := 'SmallInt';\r\n tkInteger:\r\n Result := 'Integer';\r\n tkInt64:\r\n Result := 'Int64';\r\n tkByte:\r\n Result := 'Byte';\r\n tkWord:\r\n Result := 'Word';\r\n tkCardinal:\r\n Result := 'Cardinal';\r\n tkUInt64:\r\n Result := 'UInt64';\r\n tkSingle:\r\n Result := 'Single';\r\n tkReal48:\r\n Result := 'Real48';\r\n tkReal:\r\n Result := 'Real';\r\n tkExtended:\r\n Result := 'Extended';\r\n tkCurrency:\r\n Result := 'Currency';\r\n tkComplex:\r\n Result := 'Complex';\r\n tkPString:\r\n Result := 'ShortString';\r\n tkLString:\r\n Result := 'String';\r\n tkWString:\r\n Result := 'WideString';\r\n tkChar:\r\n Result := 'Char';\r\n tkPointer:\r\n Result := 'Pointer';\r\n tkSubRange:\r\n Result := 'SubRange';\r\n tkArray:\r\n Result := 'Array';\r\n tkEnum:\r\n Result := '';\r\n tkStructure:\r\n Result := 'Record';\r\n tkClass:\r\n Result := 'TClass';\r\n tkSet:\r\n Result := 'Set';\r\n tkVariant:\r\n Result := 'Variant';\r\n tkProperty:\r\n Result := 'Property';\r\n tkFieldList:\r\n Result := 'FieldList';\r\n tkClosure:\r\n Result := 'Closure';\r\n tkClassRef:\r\n Result := 'ClassRef';\r\n tkWideChar:\r\n Result := 'WideChar';\r\n tkProcedure:\r\n Result := 'Procedure';\r\n tkArgList:\r\n Result := 'ArgList';\r\n tkMFunction:\r\n Result := 'MFunction';\r\n tkVoid:\r\n Result := 'Void';\r\n tkObject:\r\n Result := 'TObject';\r\n tkDynamicArray:\r\n Result := 'DynArray';\r\n end;\r\nend;\r\n\r\nfunction TTypeInfo.Name: AnsiString;\r\nbegin\r\n Result := '';\r\n\r\n if NameId > 0 then\r\n Result := gvDebugInfo.GetNameById(NameId)\r\n else if (Kind = tkObject) and (BaseType <> Nil) then\r\n Result := BaseType.Name\r\n else\r\n Result := AnsiString(KindAsString);\r\nend;\r\n\r\nfunction TTypeInfo.ShortName: String;\r\nbegin\r\n Result := gvDebugInfo.ParseTypeName(Self);\r\nend;\r\n\r\nfunction TTypeInfo.TypeOf: String;\r\nbegin\r\n Result := '';\r\n\r\n if BaseType <> nil then\r\n begin\r\n case Kind of\r\n tkArray, tkSet, tkDynamicArray:\r\n Result := Format('%s Of %s', [KindAsString, BaseType.ShortName]);\r\n tkObject, tkClass:\r\n Result := Format('%s(%s)', [KindAsString, BaseType.ShortName]);\r\n else\r\n Result := Format('(%s)', [BaseType.ShortName])\r\n end;\r\n end\r\n else\r\n begin\r\n case Kind of\r\n tkEnum:\r\n Result := Format('(%s)', [ElementsToString]);\r\n else\r\n Result := KindAsString;\r\n end;\r\n end;\r\nend;\r\n\r\n{ TVarInfo }\r\n\r\nfunction TVarInfo.AsString: String;\r\nbegin\r\n if Assigned(DataType) then\r\n Result := Format('%s: %s', [ShortName, DataType.ShortName])\r\n else\r\n Result := ShortName;\r\nend;\r\n\r\nConstructor TVarInfo.Create;\r\nBegin\r\n inherited;\r\n\r\n // \r\n // RegisterRanges := TList.Create;\r\n RegisterRanges := Nil;\r\nEnd;\r\n\r\nfunction TVarInfo.DataTypeName: String;\r\nbegin\r\n if Assigned(DataType) then\r\n Result := DataType.ShortName\r\n else\r\n Result := '';\r\nend;\r\n\r\nDestructor TVarInfo.Destroy;\r\nBegin\r\n if Assigned(RegisterRanges) then\r\n FreeList(RegisterRanges);\r\n\r\n inherited;\r\nEnd;\r\n\r\nfunction TVarInfo.UnitInfo: TUnitInfo;\r\nbegin\r\n Result := Nil;\r\n\r\n if Owner is TFuncInfo then\r\n Result := TFuncInfo(Owner).UnitInfo\r\n else if Owner is TUnitInfo then\r\n Result := TUnitInfo(Owner);\r\nend;\r\n\r\nfunction TVarInfo.Value: Variant;\r\nbegin\r\n Result := gvDebugInfo.EvaluateVariable(Self);\r\nend;\r\n\r\nfunction TVarInfo.Name: AnsiString;\r\nbegin\r\n Result := gvDebugInfo.GetNameById(NameId)\r\nend;\r\n\r\nfunction TVarInfo.ShortName: String;\r\nbegin\r\n Result := gvDebugInfo.ParseVarName(Self)\r\nend;\r\n\r\n{ TUnitInfo }\r\n\r\nprocedure TUnitInfo.Clear;\r\nbegin\r\n ClearList(Segments);\r\n ClearList(SourceSegments);\r\n\r\n if Assigned(UsedUnits) then\r\n UsedUnits.Clear;\r\n\r\n Lines.Clear;\r\n\r\n if Assigned(FuncsByAddr) then\r\n FuncsByAddr.Clear;\r\n\r\n inherited Clear;\r\nend;\r\n\r\nconstructor TUnitInfo.Create;\r\nbegin\r\n Inherited Create;\r\n\r\n UsedUnits := TStringList.Create;\r\n Segments := TList.Create;\r\n SourceSegments := TList.Create;\r\n FuncsByAddr := TSegmentCodeInfoList.Create;\r\n\r\n Lines.OwnsObjects := True;\r\nend;\r\n\r\ndestructor TUnitInfo.Destroy;\r\nbegin\r\n Clear;\r\n\r\n FreeAndNil(UsedUnits);\r\n FreeAndNil(Segments);\r\n FreeAndNil(SourceSegments);\r\n FreeAndNil(FuncsByAddr);\r\n\r\n Inherited;\r\nend;\r\n\r\nfunction TUnitInfo.FindSegmentByAddr(const Addr: Pointer; const SegmentID: Word = 0): TUnitSegmentInfo;\r\nvar\r\n Idx: Integer;\r\nbegin\r\n for Idx := 0 to Segments.Count - 1 do\r\n begin\r\n Result := Segments[Idx];\r\n\r\n if (SegmentID <> 0) and Assigned(Result.SegmentClassInfo) and (Result.SegmentClassInfo.ID <> SegmentID) then\r\n Continue;\r\n\r\n if (Cardinal(Addr) >= Cardinal(Result.Address)) and (Cardinal(Addr) < (Cardinal(Result.Address) + Result.Size)) then\r\n Exit;\r\n end;\r\n\r\n Result := Nil;\r\nend;\r\n\r\nfunction TUnitInfo.FindSourceSegmentByAddr(const Addr: Pointer): TUnitSourceModuleInfo;\r\nvar\r\n Idx: Integer;\r\nbegin\r\n for Idx := SourceSegments.Count - 1 downto 0 do\r\n begin\r\n Result := SourceSegments[Idx];\r\n\r\n if (Cardinal(Addr) >= Cardinal(Result.Address)) then\r\n Exit;\r\n end;\r\n\r\n Result := Nil;\r\nend;\r\n\r\nfunction TUnitInfo.FindSourceSegmentByNameId(const NameId: TNameId): TUnitSourceModuleInfo;\r\nvar\r\n Idx: Integer;\r\nbegin\r\n for Idx := 0 to SourceSegments.Count - 1 do\r\n begin\r\n Result := TUnitSourceModuleInfo(SourceSegments[Idx]);\r\n if Result.NameId = NameId then\r\n Exit;\r\n end;\r\n\r\n Result := Nil;\r\nend;\r\n\r\nfunction TUnitInfo.FullUnitName: String;\r\nbegin\r\n Result := gvDebugInfo.FullUnitName(String(Name));\r\nend;\r\n\r\nfunction TUnitInfo.ShortName: String;\r\nbegin\r\n Result := gvDebugInfo.ParseUnitName(Self);\r\nend;\r\n\r\nfunction TUnitInfo.GetUnitType: TUnitType;\r\nbegin\r\n Result := gvDebugInfo.GetUnitType(ShortName);\r\nend;\r\n\r\n{ TStackEntry }\r\n\r\nconstructor TStackEntry.Create;\r\nbegin\r\n Inherited Create;\r\n\r\n UnitInfo := Nil;\r\n FuncInfo := Nil;\r\n LineInfo := Nil;\r\n EIP := Nil;\r\n RET := Nil;\r\n EBP := Nil;\r\nend;\r\n\r\nfunction TStackEntry.GetInfo: String;\r\nbegin\r\n Result := Format('[$%p] ', [EIP]);\r\n If UnitInfo <> Nil Then\r\n Begin\r\n // XE4 \r\n // If UnitInfo <> Nil Then\r\n // Result := Result + String(UnitInfo.Name);\r\n If FuncInfo <> Nil Then\r\n begin\r\n Result := Result + FuncInfo.ShortName;\r\n end;\r\n If LineInfo <> Nil Then\r\n Result := Result + Format(' (%d)', [LineInfo.LineNo]);\r\n End\r\n Else\r\n Result := Result + 'no source';\r\nend;\r\n\r\nfunction TStackEntry.UpdateInfo(const Addr: Pointer): TFindResult;\r\nbegin\r\n EIP := Addr;\r\n Result := gvDebugInfo.GetLineInfo(EIP, UnitInfo, FuncInfo, LineInfo, False);\r\nend;\r\n\r\n{ TConstInfo }\r\n\r\nfunction TConstInfo.Name: AnsiString;\r\nbegin\r\n Result := gvDebugInfo.GetNameById(NameId);\r\nend;\r\n\r\nprocedure TConstInfo.SetValue(const Value: Variant);\r\nbegin\r\n FValue := Value;\r\nend;\r\n\r\nfunction TConstInfo.ShortName: String;\r\nbegin\r\n Result := gvDebugInfo.ParseConstName(Self);\r\nend;\r\n\r\nfunction TConstInfo.UnitInfo: TUnitInfo;\r\nbegin\r\n if Owner is TUnitInfo then\r\n Result := TUnitInfo(Owner)\r\n else\r\n if Owner is TFuncInfo then\r\n Result := TFuncInfo(Owner).UnitInfo\r\n else\r\n Result := Nil;\r\nend;\r\n\r\nfunction TConstInfo.ValueAsString: String;\r\nbegin\r\n Result := gvDebugInfo.VarValueAsString(Value);\r\nend;\r\n\r\n{ TSegmentCodeInfo }\r\n\r\nfunction TSegmentCodeInfo.CheckAddress(const Addr: Pointer): Integer;\r\nbegin\r\n if NativeUInt(Addr) < NativeUInt(Address) then\r\n Result := -1\r\n else if NativeUInt(Addr) > (NativeUInt(Address) + NativeUInt(Size)) then\r\n Result := 1\r\n else\r\n Result := 0;\r\nend;\r\n\r\nprocedure TSegmentCodeInfo.Clear;\r\nbegin\r\n Consts.Clear;\r\n Types.Clear;\r\n Vars.Clear;\r\n Funcs.Clear;\r\n\r\n Lines.Clear;\r\nend;\r\n\r\nconstructor TSegmentCodeInfo.Create;\r\nbegin\r\n inherited;\r\n\r\n Consts := TNameList.Create;\r\n Types := TNameList.Create;\r\n Vars := TNameList.Create;\r\n Funcs := TNameList.Create;\r\n\r\n Lines := TLineInfoList.Create(False);\r\nend;\r\n\r\ndestructor TSegmentCodeInfo.Destroy;\r\nbegin\r\n Clear;\r\n\r\n FreeAndNil(Consts);\r\n FreeAndNil(Types);\r\n FreeAndNil(Vars);\r\n FreeAndNil(Funcs);\r\n\r\n FreeAndNil(Lines);\r\n\r\n inherited;\r\nend;\r\n\r\nfunction TSegmentCodeInfo.FindConstByName(const ConstName: AnsiString; const SubStr: LongBool = False): TConstInfo;\r\nbegin\r\n Result := TConstInfo(Consts.FindByName(ConstName, SubStr));\r\nend;\r\n\r\nfunction TSegmentCodeInfo.FindFuncByName(const FuncName: AnsiString; const SubStr: LongBool = False): TFuncInfo;\r\nbegin\r\n Result := TFuncInfo(Funcs.FindByName(FuncName, SubStr));\r\nend;\r\n\r\nfunction TSegmentCodeInfo.FindFuncByNameId(const FuncNameId: Integer): TFuncInfo;\r\nbegin\r\n Result := TFuncInfo(Funcs.FindByNameId(FuncNameId));\r\nend;\r\n\r\nfunction TSegmentCodeInfo.FindTypeByName(const TypeName: AnsiString; const SubStr: LongBool = False): TTypeInfo;\r\nbegin\r\n Result := TTypeInfo(Types.FindByName(TypeName, SubStr));\r\nend;\r\n\r\nfunction TSegmentCodeInfo.FindVarByName(const VarName: AnsiString; const SubStr: LongBool = False): TVarInfo;\r\nbegin\r\n Result := TVarInfo(Vars.FindByName(VarName, SubStr));\r\nend;\r\n\r\nfunction TSegmentCodeInfo.Name: AnsiString;\r\nbegin\r\n Result := gvDebugInfo.GetNameById(NameId);\r\nend;\r\n\r\nfunction TSegmentCodeInfo.ShortName: String;\r\nbegin\r\n Result := String(Name);\r\nend;\r\n\r\n{ TNameList }\r\n\r\nprocedure TNameList.CheckNameIdList;\r\nvar\r\n I: Integer;\r\n NameInfo: TNameInfo;\r\nbegin\r\n if FNameIdList = nil then\r\n begin\r\n FNameIdList := TNameIdList.Create(Capacity);\r\n\r\n for I := 0 to Count - 1 do\r\n begin\r\n NameInfo := TNameInfo(List[I]);\r\n\r\n FNameIdList.AddOrSetValue(NameInfo.NameId, NameInfo);\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TNameList.Clear;\r\nvar\r\n I: Integer;\r\n Obj: TObject;\r\nbegin\r\n if Assigned(FNameIdList) then\r\n FreeAndNil(FNameIdList);\r\n\r\n if FFreeItems then\r\n begin\r\n for I := 0 to Count - 1 do\r\n begin\r\n Obj := List[I];\r\n if Obj <> nil then\r\n begin\r\n List[I] := nil;\r\n FreeAndNil(Obj);\r\n end;\r\n end;\r\n end;\r\n\r\n inherited Clear;\r\nend;\r\n\r\nconstructor TNameList.Create;\r\nbegin\r\n inherited;\r\n\r\n FNameIdList := Nil;\r\n FFreeItems := True;\r\n // Capacity := 16;\r\nend;\r\n\r\ndestructor TNameList.Destroy;\r\nbegin\r\n Clear;\r\n\r\n inherited;\r\nend;\r\n\r\nfunction TNameList.FindByName(const Name: AnsiString; const SubStr: LongBool = False): TNameInfo;\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := 0 to Count - 1 do\r\n begin\r\n Result := TNameInfo(List[I]);\r\n if (Result.NameId > 0) then\r\n begin\r\n if SubStr then\r\n begin\r\n if Pos(Name, Result.Name) > 0 then\r\n Exit;\r\n end\r\n else\r\n begin\r\n if SameText(Name, Result.Name) then\r\n Exit;\r\n end;\r\n end;\r\n end;\r\n\r\n Result := Nil;\r\nend;\r\n\r\nfunction TNameList.FindByNameId(const NameId: TNameId): TNameInfo;\r\nbegin\r\n CheckNameIdList;\r\n\r\n if not FNameIdList.TryGetValue(NameId, Result) then\r\n Result := Nil;\r\nend;\r\n\r\nfunction TNameList.GetNameInfoItem(const Index: Integer): TNameInfo;\r\nbegin\r\n Result := TNameInfo(Items[Index]);\r\nend;\r\n\r\nprocedure TNameList.Notify(Ptr: Pointer; Action: TListNotification);\r\nvar\r\n NameInfo: TNameInfo;\r\nbegin\r\n if Assigned(FNameIdList) then\r\n begin\r\n NameInfo := TNameInfo(Ptr);\r\n\r\n case Action of\r\n lnAdded:\r\n FNameIdList.AddOrSetValue(NameInfo.NameId, NameInfo);\r\n lnDeleted:\r\n FNameIdList.Remove(NameInfo.NameId);\r\n end;\r\n end;\r\nend;\r\n\r\n{ TStructMember }\r\n\r\nfunction TStructMember.Alias: AnsiString;\r\nbegin\r\n Result := gvDebugInfo.GetNameById(AliasNameId);\r\nend;\r\n\r\nfunction TStructMember.MethodName: AnsiString;\r\nbegin\r\n Result := gvDebugInfo.GetNameById(MethodNameId);\r\nend;\r\n\r\nfunction TStructMember.Name: AnsiString;\r\nbegin\r\n Result := gvDebugInfo.GetNameById(NameId);\r\nend;\r\n\r\nfunction TStructMember.ShortName: String;\r\nbegin\r\n Result := gvDebugInfo.ParseStructMemberName(Self);\r\nend;\r\n\r\n{ TEnumInfo }\r\n\r\nfunction TEnumInfo.Name: AnsiString;\r\nbegin\r\n Result := gvDebugInfo.GetNameById(NameId);\r\nend;\r\n\r\nfunction TEnumInfo.ShortName: String;\r\nbegin\r\n Result := String(Name);\r\nend;\r\n\r\n{ TSegmentCodeInfoList }\r\n\r\nprocedure TSegmentCodeInfoList.CheckSorted;\r\nbegin\r\n if not FSorted then\r\n begin\r\n Sort;\r\n FSorted := True;\r\n end;\r\nend;\r\n\r\nconstructor TSegmentCodeInfoList.Create;\r\nbegin\r\n inherited Create(TSegmentCodeInfoComparer.Create);\r\n\r\n FSorted := False;\r\nend;\r\n\r\ndestructor TSegmentCodeInfoList.Destroy;\r\nbegin\r\n\r\n inherited;\r\nend;\r\n\r\nfunction TSegmentCodeInfoList.FindByAddress(const Address: Pointer): TSegmentCodeInfo;\r\nvar\r\n SearchItem: TSegmentCodeInfo;\r\n Idx: Integer;\r\n D: Integer;\r\nbegin\r\n Result := Nil;\r\n\r\n if Count = 0 then\r\n Exit;\r\n\r\n CheckSorted;\r\n\r\n SearchItem := TSegmentCodeInfo.Create;\r\n try\r\n SearchItem.Address := Address;\r\n\r\n BinarySearch(SearchItem, Idx); // !!! Idx +- 1\r\n\r\n if (Idx >= 0) and (Idx < Count) then\r\n Result := Items[Idx]\r\n else if Idx = Count then\r\n Result := Items[Count - 1];\r\n\r\n if (Result <> Nil) then\r\n begin\r\n D := Result.CheckAddress(Address);\r\n\r\n if D <> 0 then\r\n begin\r\n Inc(Idx, D);\r\n\r\n if (Idx >= 0) and (Idx < Count) then\r\n begin\r\n Result := Items[Idx];\r\n\r\n if Result.CheckAddress(Address) <> 0 then\r\n Result := Nil;\r\n end\r\n else\r\n Result := Nil;\r\n end;\r\n end;\r\n finally\r\n FreeAndNil(SearchItem);\r\n end;\r\nend;\r\n\r\nprocedure TSegmentCodeInfoList.UpdateSort;\r\nbegin\r\n FSorted := False;\r\n Sort;\r\n FSorted := True;\r\nend;\r\n\r\n{ TSegmentCodeInfoComparer }\r\n\r\nfunction TSegmentCodeInfoComparer.Compare(const Left, Right: TSegmentCodeInfo): Integer;\r\nvar\r\n L, R: NativeInt;\r\nbegin\r\n L := NativeInt(Left.Address);\r\n R := NativeInt(Right.Address);\r\n\r\n Result := Integer(L - R);\r\nend;\r\n\r\n{ TAddressInfoList }\r\n\r\nconstructor TAddressInfoList.Create(ACapacity: Integer);\r\nbegin\r\n inherited Create(ACapacity);\r\n\r\n FLock := TMREWSync.Create;\r\nend;\r\n\r\ndestructor TAddressInfoList.Destroy;\r\nbegin\r\n Clear;\r\n\r\n FreeAndNil(FLock);\r\n\r\n inherited;\r\nend;\r\n\r\nprocedure TAddressInfoList.ValueNotify(const Value: PAddressInfo; Action: TCollectionNotification);\r\nbegin\r\n inherited;\r\n\r\n if Action = cnRemoved then\r\n FreeMemory(Value);\r\nend;\r\n\r\n{ TUnitSourceModuleInfo }\r\n\r\nprocedure TUnitSourceModuleInfo.Clear;\r\nbegin\r\n Lines.Clear;\r\nend;\r\n\r\nconstructor TUnitSourceModuleInfo.Create;\r\nbegin\r\n inherited Create;\r\n\r\n Lines := TLineInfoList.Create(False);\r\nend;\r\n\r\ndestructor TUnitSourceModuleInfo.Destroy;\r\nbegin\r\n Clear;\r\n FreeAndNil(Lines);\r\n\r\n inherited;\r\nend;\r\n\r\nfunction TUnitSourceModuleInfo.FullUnitName: String;\r\nbegin\r\n Result := gvDebugInfo.FullUnitName(String(Name));\r\nend;\r\n\r\nfunction TUnitSourceModuleInfo.Name: AnsiString;\r\nbegin\r\n Result := gvDebugInfo.GetNameById(NameId);\r\nend;\r\n\r\nfunction TUnitSourceModuleInfo.ShortName: String;\r\nbegin\r\n Result := String(Name);\r\nend;\r\n\r\n{ TDbgSourceDirList }\r\n\r\nprocedure TDbgSourceDirList.Grow;\r\nvar\r\n i, j, n : Integer;\r\n oldBuckets : array of TDbgSourceDirListItem;\r\nbegin\r\n if FCapacity = 0 then\r\n FCapacity := 64\r\n else\r\n FCapacity := FCapacity * 2;\r\n FGrowth := (FCapacity * 11) div 16;\r\n\r\n SetLength(oldBuckets, Length(FBuckets));\r\n for i := 0 to Length(FBuckets) - 1 do\r\n oldBuckets[i] := FBuckets[i];\r\n\r\n FBuckets := nil;\r\n SetLength(FBuckets, FCapacity);\r\n\r\n n := FCapacity - 1;\r\n for i := 0 to High(oldBuckets) do\r\n begin\r\n if oldBuckets[i].HashCode = 0 then\r\n Continue;\r\n j := (oldBuckets[i].HashCode and (FCapacity - 1));\r\n while FBuckets[j].HashCode <> 0 do\r\n j := (j + 1) and n;\r\n FBuckets[j] := oldBuckets[i];\r\n end;\r\nend;\r\n\r\nfunction TDbgSourceDirList.LinearFind(const HashCode: Cardinal;\r\n const ShortFileName: String; var Index: Integer) : Boolean;\r\nbegin\r\n repeat\r\n if FBuckets[Index].HashCode = 0 then\r\n Exit(False)\r\n else\r\n if SameItem(HashCode, FBuckets[Index].HashCode, ShortFileName, FBuckets[Index].ShortFileName) then\r\n Exit(True);\r\n Index := (Index + 1) and (FCapacity - 1);\r\n until False;\r\nend;\r\n\r\nfunction TDbgSourceDirList.Add(const FileName: String) : Boolean;\r\nvar\r\n Index: Integer;\r\n HashCode: Integer;\r\n ShortFileName: String;\r\nbegin\r\n if FCount >= FGrowth then\r\n Grow;\r\n\r\n ShortFileName := AnsiLowerCase(ExtractFileName(FileName));\r\n\r\n HashCode := GetItemHashCode(ShortFileName);\r\n Index := (HashCode and (FCapacity - 1));\r\n if LinearFind(HashCode, ShortFileName, Index) then\r\n Exit(False);\r\n\r\n FBuckets[Index].ShortFileName := ShortFileName;\r\n FBuckets[Index].FileName := FileName;\r\n FBuckets[Index].HashCode := HashCode;\r\n Inc(FCount);\r\n Result := True;\r\nend;\r\n\r\nfunction TDbgSourceDirList.Contains(const ShortFileName: String): Boolean;\r\nvar\r\n Index: Integer;\r\n HashCode: Cardinal;\r\nbegin\r\n if FCount = 0 then\r\n Exit(False);\r\n HashCode := GetItemHashCode(ShortFileName);\r\n Index := HashCode and (FCapacity - 1);\r\n Result := LinearFind(HashCode, ShortFileName, Index);\r\nend;\r\n\r\nprocedure TDbgSourceDirList.Clear;\r\nbegin\r\n FCount := 0;\r\n FCapacity := 0;\r\n FGrowth := 0;\r\n FBuckets := nil;\r\nend;\r\n\r\nfunction TDbgSourceDirList.SameItem(const HashCode1, HashCode2: Cardinal;\r\n const ShortFileName1, ShortFileName2: String): Boolean;\r\nbegin\r\n Result := HashCode1 = HashCode2;\r\n if Result then\r\n Result := SameText(ShortFileName1, ShortFileName2);\r\nend;\r\n\r\nfunction TDbgSourceDirList.TryGetValue(const ShortFileName: String;\r\n out FileName: String): Boolean;\r\nvar\r\n Index: Integer;\r\n HashCode: Integer;\r\nbegin\r\n if FCount = 0 then\r\n Exit(False);\r\n HashCode := GetItemHashCode(ShortFileName);\r\n Index := (HashCode and (FCapacity - 1));\r\n Result := LinearFind(HashCode, ShortFileName, Index);\r\n if Result then\r\n FileName := FBuckets[Index].FileName;\r\nend;\r\n\r\nfunction TDbgSourceDirList.GetItemHashCode(const ShortFileName: String): Integer;\r\nbegin\r\n Result := SimpleLowerCaseStringHash(ShortFileName);\r\nend;\r\n\r\n{ TMemoryManagerInfo }\r\n\r\nprocedure TMemoryManagerInfo.Clear;\r\nbegin\r\n VarInfo := Nil;\r\n GetMem := Nil;\r\n FreeMem := Nil;\r\n ReallocMem := Nil;\r\n AllocMem := Nil;\r\nend;\r\n\r\nconstructor TMemoryManagerInfo.Create;\r\nbegin\r\n inherited;\r\n\r\n Clear;\r\nend;\r\n\r\n{ TSegmentClassInfo }\r\n\r\nfunction TSegmentClassInfo.SegTypeName: String;\r\nbegin\r\n Result := SegmentTypeNames[SegType];\r\nend;\r\n\r\nclass function TSegmentClassInfo.StrToSegmentType(const Str: String): TSegmentType;\r\nvar\r\n SegName: String;\r\n Idx: Integer;\r\nbegin\r\n if Str <> '' then\r\n begin\r\n Idx := 1;\r\n while (Idx <= Length(Str)) and CharInSet(Str[Idx], ['.', '_']) do\r\n Inc(Idx);\r\n\r\n SegName := Copy(Str, Idx, MaxInt);\r\n\r\n for Result := ustCode to High(TSegmentType) do\r\n if SameText(SegName, SegmentTypeNames[Result]) then\r\n Exit;\r\n end;\r\n\r\n Result := ustUnknown;\r\nend;\r\n\r\n{ TRTLInfo }\r\n\r\nprocedure TRTLInfo.Clear;\r\nbegin\r\n vmtClassNameInfo := Nil;\r\nend;\r\n\r\nconstructor TRTLInfo.Create;\r\nbegin\r\n inherited;\r\n\r\n Clear;\r\nend;\r\n\r\nfunction TRTLInfo.vmtClassName: Integer;\r\nbegin\r\n if Assigned(vmtClassNameInfo) then\r\n Result := Integer(vmtClassNameInfo.Value)\r\n else\r\n Result := System.vmtClassName;\r\nend;\r\n\r\nEnd.\r\n" }, { "path": "Debuger.pas", "content": "unit Debuger;\r\n\r\ninterface\r\n\r\nuses\r\n WinApi.Windows, System.Classes, System.SysUtils, System.SyncObjs,\r\n ClassUtils, JclPeImage, JclDebug, DebugerTypes, DbgHookTypes,\r\n Collections.Queues, Collections.Dictionaries, DbgMemoryProfiler,\r\n DbgSyncObjsProfiler, DbgSamplingProfiler, DbgCodeProfiler;\r\n\r\ntype\r\n TDebuger = class\r\n strict private\r\n FProcessData: TProcessData; // \r\n private\r\n FThreadList: TDbgThreadList; // \r\n FThreadAdvInfoList: TThreadAdvInfoList; // \r\n FActiveThreadList: TDbgActiveThreadList; // \r\n\r\n FSetEntryPointBreakPoint: LongBool; // , \r\n FBreakpointList: TBreakpointList; // \r\n FRestoreBPIndex: Integer; // \r\n FRestoreMBPIndex: Integer; // \r\n FRestoredHWBPIndex: Integer; // \r\n FRestoredThread: TThreadId;\r\n FCloseDebugProcess: LongBool; // \r\n FContinueStatus: DWORD; // ContinueDebugEvent\r\n FResumeAction: TResumeAction; // \r\n FRemoveCurrentBreakpoint: LongBool; // \r\n\r\n FCurThreadId: TThreadId;\r\n FCurThreadData: PThreadData;\r\n\r\n FDbgState: TDbgState;\r\n\r\n FDbgTraceState: TDbgTraceState;\r\n FTraceEvent: TEvent;\r\n FTraceCounter: Cardinal;\r\n\r\n // Debug options\r\n FPerfomanceMode: LongBool;\r\n\r\n FExceptionCheckMode: LongBool;\r\n FExceptionCallStack: LongBool;\r\n\r\n FCodeTracking: LongBool;\r\n FTrackSystemUnits: LongBool;\r\n FSamplingMethod: LongBool;\r\n // ---\r\n\r\n FMemoryBPCheckMode: LongBool;\r\n\r\n FPerfomanceCheckPtr: Pointer;\r\n\r\n // \r\n FMainLoopFailed: TNotifyEvent;\r\n FCreateThread: TCreateThreadEvent;\r\n FCreateProcess: TCreateProcessEvent;\r\n FExitThread: TExitThreadEvent;\r\n FExitProcess: TExitProcessEvent;\r\n FLoadDll: TLoadDllEvent;\r\n FUnLoadDll: TUnLoadDllEvent;\r\n FDebugString: TDebugStringEvent;\r\n FRip: TRipEvent;\r\n FEndDebug: TNotifyEvent;\r\n FChangeDebugState: TNotifyEvent;\r\n\r\n FDbgLog: TDbgLogEvent;\r\n FDbgLogMode: LongBool; // \r\n\r\n FExceptionEvents: TExceptionEvents;\r\n FBreakPoint: TBreakPointEvent;\r\n FHardwareBreakpoint: THardwareBreakpointEvent;\r\n\r\n FDbgMemoryProfiler: TDbgMemoryProfiler;\r\n FDbgSyncObjsProfiler: TDbgSyncObjsProfiler;\r\n FDbgSamplingProfiler: TDbgSamplingProfiler;\r\n FDbgCodeProfiler: TDbgCodeProfiler;\r\n\r\n function GetExceptionEvent(const Index: TExceptionCode): TDefaultExceptionEvent;\r\n procedure SetExceptionEvent(const Index: TExceptionCode; const Value: TDefaultExceptionEvent);\r\n procedure SetCloseDebugProcess(const Value: LongBool);\r\n\r\n procedure SetPerfomanceMode(const Value: LongBool);\r\n procedure SetCodeTracking(const Value: LongBool);\r\n procedure SetTrackSystemUnits(const Value: LongBool);\r\n procedure SetExceptionCallStack(const Value: LongBool);\r\n procedure SetExceptionCheckMode(const Value: LongBool);\r\n\r\n procedure DoSetBreakpoint(const Address: Pointer; var SaveByte: Byte);\r\n procedure DoSetBreakpointF(const Address: Pointer; var SaveByte: Byte);\r\n //procedure DoRemoveBreakpoint(const Address: Pointer; const SaveByte: Byte);\r\n procedure DoRemoveBreakpointF(const Address: Pointer; const SaveByte: Byte);\r\n //procedure DoRestoreBreakpoint(const Address: Pointer);\r\n procedure DoRestoreBreakpointF(const Address: Pointer);\r\n\r\n procedure SetDbgTraceState(const Value: TDbgTraceState);\r\n procedure SetDbgState(const Value: TDbgState);\r\n procedure SetSamplingMethod(const Value: LongBool);\r\n\r\n function GetActive: LongBool; inline;\r\n protected\r\n // \r\n function AddThread(const ThreadID: TThreadId; ThreadHandle: THandle): PThreadData;\r\n procedure RemoveThread(const ThreadID: TThreadId);\r\n\r\n function GetThreadIndex(const ThreadID: TThreadId; const UseFinished: LongBool = False): Integer;\r\n\r\n function GetThreadInfoIndex(const ThreadId: TThreadId): Integer;\r\n function AddThreadInfo(const ThreadId: TThreadId): PThreadAdvInfo;\r\n function GetThreadInfo(const ThreadId: TThreadId): PThreadAdvInfo;\r\n function SetThreadInfo(const ThreadId: TThreadId): PThreadAdvInfo;\r\n\r\n // \r\n procedure DoCreateProcess(DebugEvent: PDebugEvent);\r\n procedure DoExitProcess(DebugEvent: PDebugEvent);\r\n\r\n procedure DoCreateThread(DebugEvent: PDebugEvent);\r\n procedure DoExitThread(DebugEvent: PDebugEvent);\r\n\r\n procedure DoLoadDll(DebugEvent: PDebugEvent);\r\n procedure DoUnLoadDll(DebugEvent: PDebugEvent);\r\n\r\n procedure DoDebugString(DebugEvent: PDebugEvent);\r\n procedure DoRip(DebugEvent: PDebugEvent);\r\n procedure DoEndDebug;\r\n procedure DoDebugerFailed;\r\n procedure DoResumeAction(const ThreadID: TThreadId);\r\n\r\n procedure DoDbgLog(const ThreadId: TThreadId; const LogData: String);\r\n\r\n // \r\n procedure CallUnhandledExceptionEvents(const Code: TExceptionCode; DebugEvent: PDebugEvent);\r\n procedure CallUnhandledBreakPointEvents(const Code: TExceptionCode; DebugEvent: PDebugEvent);\r\n\r\n procedure ProcessExceptionBreakPoint(DebugEvent: PDebugEvent);\r\n\r\n function ProcessUserBreakPoint(DebugEvent: PDebugEvent): LongBool;\r\n\r\n function ProcessTraceBreakPoint(DebugEvent: PDebugEvent): LongBool;\r\n\r\n procedure ProcessExceptionSingleStep(DebugEvent: PDebugEvent);\r\n procedure ProcessExceptionGuardPage(DebugEvent: PDebugEvent);\r\n\r\n procedure SetThreadName(DebugEvent: PDebugEvent);\r\n\r\n procedure ProcessDbgException(DebugEvent: PDebugEvent);\r\n procedure ProcessDbgThreadInfo(DebugEvent: PDebugEvent);\r\n procedure ProcessDbgMemoryInfo(DebugEvent: PDebugEvent);\r\n procedure ProcessDbgPerfomance(DebugEvent: PDebugEvent);\r\n procedure ProcessDbgSyncObjsInfo(DebugEvent: PDebugEvent);\r\n procedure ProcessDbgTraceInfo(DebugEvent: PDebugEvent);\r\n procedure ProcessDbgSamplingInfo(DebugEvent: PDebugEvent);\r\n\r\n function ProcessHardwareBreakpoint(DebugEvent: PDebugEvent): LongBool;\r\n\r\n // \r\n\r\n function AddNewBreakPoint(var Value: TBreakpoint): LongBool;\r\n procedure CheckBreakpointIndex(Value: Integer);\r\n function CheckIsAddrInRealMemoryBPRegion(BreakPointIndex: Integer; AAddr: Pointer): LongBool;\r\n function GetBPIndex(BreakPointAddr: Pointer; const ThreadID: TThreadId = 0): Integer;\r\n function GetMBPIndex(BreakPointAddr: Pointer; FromIndex: Integer = 0): Integer;\r\n function IsBreakpointPresent(const Value: TBreakpoint): LongBool;\r\n procedure ToggleInt3Breakpoint(Index: Integer; Active: LongBool);\r\n procedure ToggleMemoryBreakpoint(Index: Integer; Active: LongBool);\r\n procedure UpdateHardwareBreakpoints(const ThreadID: TThreadId);\r\n\r\n function PerfomancePauseDebug: LongBool;\r\n\r\n function AddThreadPointInfo(ThreadData: PThreadData; const PointType: TDbgPointType; DebugEvent: PDebugEvent = nil): LongBool;\r\n function AddProcessPointInfo(const PointType: TDbgPointType): LongBool;\r\n\r\n public\r\n constructor Create;\r\n destructor Destroy; override;\r\n\r\n procedure ClearDbgInfo;\r\n\r\n procedure Log(const Msg: String);\r\n\r\n // / \r\n function AttachToProcess(const ProcessID: TProcessId; SentEntryPointBreakPoint: LongBool): LongBool;\r\n function DebugNewProcess(const AppPath: string; var ErrInfo: String; const RunParams: String = ''; const WorkingDirectory: String = ''): LongBool;\r\n\r\n function StopDebug: LongBool;\r\n function PauseDebug: LongBool;\r\n function ContinueDebug: LongBool;\r\n function TraceDebug(const TraceType: TDbgTraceState): LongBool;\r\n\r\n // \r\n procedure ProcessDebugEvents;\r\n\r\n // \r\n Function ProcAllocMem(const Size: Cardinal): Pointer;\r\n Procedure ProcFreeMem(Data : Pointer; const Size: NativeUInt = 0);\r\n\r\n procedure InjectThread(hProcess: THandle; Func: Pointer; FuncSize: Cardinal; aParams: Pointer;\r\n aParamsSize: Cardinal; WaitAndFree: LongBool = True);\r\n function InjectFunc(Func: Pointer; const CodeSize: Cardinal): Pointer;\r\n\r\n procedure InjectPerfThread;\r\n procedure InjectPerfFunc;\r\n\r\n function ReadData(const AddrPrt, ResultPtr: Pointer; const DataSize: Integer): LongBool;\r\n\r\n function ReadStringA(AddrPrt: Pointer; Len: Integer = 0): AnsiString;\r\n function ReadStringW(AddrPrt: Pointer; Len: Integer = 0): WideString;\r\n function ReadStringP(AddrPrt: Pointer; Len: Byte = 0): ShortString;\r\n\r\n function WriteData(AddrPrt, DataPtr: Pointer; const DataSize: Cardinal): LongBool;\r\n\r\n procedure SetFlag(const ThreadID: TThreadId; Flag: DWORD; Value: LongBool);\r\n function GetFlag(const ThreadID: TThreadId; Flag: DWORD): LongBool;\r\n\r\n function UpdateThreadContext(const ThreadID: TThreadId; const ContextFlags: Cardinal = CONTEXT_FULL): PThreadData; overload;\r\n function UpdateThreadContext(ThreadData: PThreadData; const ContextFlags: Cardinal = CONTEXT_FULL): LongBool; overload;\r\n\r\n function UpdateCurThreadContext(const ContextFlags: Cardinal = CONTEXT_FULL): LongBool;\r\n\r\n function GetRegisters(const ThreadID: TThreadId): TContext;\r\n procedure SetRegisters(const ThreadID: TThreadId; var Context: TContext);\r\n\r\n procedure SetSingleStepMode(const ThreadID: TThreadId; const RestoreEIPAfterBP: LongBool); overload;\r\n procedure SetSingleStepMode(ThData: PThreadData; const RestoreEIPAfterBP: LongBool); overload;\r\n\r\n Function IsValidAddr(Const Addr: Pointer): LongBool;\r\n Function IsValidCodeAddr(Const Addr: Pointer): LongBool;\r\n Function IsValidProcessCodeAddr(Const Addr: Pointer): LongBool;\r\n\r\n procedure GetCallStack(ThData: PThreadData; var Stack: TDbgInfoStack);\r\n procedure GetCallStackEx(ThData: PThreadData; var Stack: TDbgInfoStack);\r\n\r\n function GetThreadData(const ThreadID: TThreadId; const UseFinished: LongBool = False): PThreadData;\r\n function CurThreadId: TThreadId;\r\n function CurThreadData: PThreadData;\r\n function GetThreadCount: Integer;\r\n function GetThreadDataByIdx(const Idx: Integer): PThreadData;\r\n procedure GetActiveThreads(var Res: TDbgActiveThreads);\r\n\r\n // \r\n Procedure ExecuteCode(AddrPtr: Pointer; const TimeOut: Cardinal);\r\n\r\n function GetDllName(lpImageName, lpBaseOfDll: Pointer; var Unicode: LongBool): AnsiString;\r\n\r\n // \r\n function SetUserBreakpoint(Address: Pointer; const ThreadId: TThreadId = 0; const Description: string = ''): LongBool;\r\n function SetMemoryBreakpoint(Address: Pointer; Size: Cardinal; BreakOnWrite: LongBool; const Description: string): LongBool;\r\n\r\n procedure RemoveBreakpoint(const Address: Pointer; const SaveByte: Byte); overload; inline;\r\n procedure SetBreakpoint(const Address: Pointer; var SaveByte: Byte); inline;\r\n procedure RestoreBreakpoint(const Address: Pointer); inline;\r\n\r\n procedure RemoveBreakpoint(Index: Integer); overload;\r\n procedure ToggleBreakpoint(Index: Integer; Active: LongBool);\r\n\r\n function BreakpointCount: Integer;\r\n function BreakpointItem(Index: Integer): TBreakpoint;\r\n\r\n procedure RemoveCurrentBreakpoint;\r\n\r\n // \r\n procedure SetHardwareBreakpoint(const ThreadId: TThreadID; Address: Pointer; Size: THWBPSize; Mode: THWBPMode; HWIndex: THWBPIndex; const Description: string);\r\n procedure ToggleHardwareBreakpoint(const ThreadId: TThreadID; Index: THWBPIndex; Active: LongBool);\r\n procedure DropHardwareBreakpoint(const ThreadId: TThreadID; Index: THWBPIndex);\r\n procedure DropAllHardwareBreakpoint(const ThreadId: TThreadID);\r\n\r\n // \r\n property OnMainLoopFailed: TNotifyEvent read FMainLoopFailed write FMainLoopFailed;\r\n property OnEndDebug: TNotifyEvent read FEndDebug write FEndDebug;\r\n property OnChangeDebugState: TNotifyEvent read FChangeDebugState write FChangeDebugState;\r\n\r\n // \r\n property OnCreateThread: TCreateThreadEvent read FCreateThread write FCreateThread;\r\n property OnCreateProcess: TCreateProcessEvent read FCreateProcess write FCreateProcess;\r\n property OnExitThread: TExitThreadEvent read FExitThread write FExitThread;\r\n property OnExitProcess: TExitProcessEvent read FExitProcess write FExitProcess;\r\n property OnLoadDll: TLoadDllEvent read FLoadDll write FLoadDll;\r\n property OnUnloadDll: TUnLoadDllEvent read FUnLoadDll write FUnLoadDll;\r\n property OnDebugString: TDebugStringEvent read FDebugString write FDebugString;\r\n property OnRip: TRipEvent read FRip write FRip;\r\n property OnDbgLog: TDbgLogEvent read FDbgLog write FDbgLog;\r\n\r\n property DbgLogMode: LongBool read FDbgLogMode write FDbgLogMode;\r\n\r\n // \r\n property OnBreakPoint: TBreakPointEvent read FBreakPoint write FBreakPoint;\r\n property OnHardwareBreakpoint: THardwareBreakpointEvent read FHardwareBreakpoint write FHardwareBreakpoint;\r\n property OnUnknownException: TDefaultExceptionEvent index ecUnknown read GetExceptionEvent write SetExceptionEvent;\r\n property OnUnknownBreakPoint: TDefaultExceptionEvent index ecBreakpoint read GetExceptionEvent write SetExceptionEvent;\r\n property OnSingleStep: TDefaultExceptionEvent index ecSingleStep read GetExceptionEvent write SetExceptionEvent;\r\n property OnCtrlC: TDefaultExceptionEvent index ecCtrlC read GetExceptionEvent write SetExceptionEvent;\r\n property OnNonContinuable: TDefaultExceptionEvent index ecNonContinuable read GetExceptionEvent write SetExceptionEvent;\r\n property OnPageGuard: TDefaultExceptionEvent index ecGuard read GetExceptionEvent write SetExceptionEvent;\r\n\r\n // \r\n property ContinueStatus: DWORD read FContinueStatus write FContinueStatus;\r\n property CloseDebugProcessOnFree: LongBool read FCloseDebugProcess write SetCloseDebugProcess;\r\n property ProcessData: TProcessData read FProcessData;\r\n property ResumeAction: TResumeAction read FResumeAction write FResumeAction;\r\n property DbgState: TDbgState read FDbgState write SetDbgState;\r\n property DbgTraceState: TDbgTraceState read FDbgTraceState write SetDbgTraceState;\r\n\r\n property Active: LongBool read GetActive;\r\n\r\n // \r\n property PerfomanceMode: LongBool read FPerfomanceMode write SetPerfomanceMode;\r\n\r\n property ExceptionCheckMode: LongBool read FExceptionCheckMode write SetExceptionCheckMode;\r\n property ExceptionCallStack: LongBool read FExceptionCallStack write SetExceptionCallStack;\r\n\r\n property CodeTracking: LongBool read FCodeTracking write SetCodeTracking;\r\n property TrackSystemUnits: LongBool read FTrackSystemUnits write SetTrackSystemUnits;\r\n property SamplingMethod: LongBool read FSamplingMethod write SetSamplingMethod;\r\n\r\n property MemoryBPCheckMode: LongBool read FMemoryBPCheckMode write FMemoryBPCheckMode;\r\n\r\n property DbgMemoryProfiler: TDbgMemoryProfiler read FDbgMemoryProfiler;\r\n property DbgSysncObjsProfiler: TDbgSyncObjsProfiler read FDbgSyncObjsProfiler;\r\n property DbgSamplingProfiler: TDbgSamplingProfiler read FDbgSamplingProfiler;\r\n property DbgCodeProfiler: TDbgCodeProfiler read FDbgCodeProfiler;\r\n end;\r\n\r\nvar\r\n gvDebuger: TDebuger = nil;\r\n\r\nimplementation\r\n\r\nuses\r\n RTLConsts, Math, DebugHook, DebugInfo, WinAPIUtils, Winapi.TlHelp32, Winapi.ImageHlp,\r\n System.Contnrs, System.AnsiStrings, CollectList, Collections.Base,\r\n DbgWorkerThread;\r\n\r\nfunction _DbgPerfomanceHook(pvParam: Pointer): DWORD; stdcall;\r\nbegin\r\n Result := DWORD(@_DbgPerfomanceHook);\r\nend;\r\n\r\nfunction CodeDataToExceptionCode(const Value: DWORD): TExceptionCode;\r\nconst\r\n EXCEPTION_UNKNOWN = 0;\r\n ExceptionCodeData: array [TExceptionCode] of DWORD = (\r\n EXCEPTION_UNKNOWN,\r\n EXCEPTION_BREAKPOINT,\r\n EXCEPTION_SINGLE_STEP,\r\n DBG_CONTROL_C,\r\n EXCEPTION_NONCONTINUABLE_EXCEPTION,\r\n EXCEPTION_GUARD_PAGE,\r\n EXCEPTION_SET_THREAD_NAME\r\n );\r\nbegin\r\n for Result := Low(TExceptionCode) to High(TExceptionCode) do\r\n if Value = ExceptionCodeData[Result] then\r\n Break;\r\n\r\n Result := ecUnknown;\r\nend;\r\n\r\n{ TDebuger }\r\n\r\nfunction TDebuger.AddNewBreakPoint(var Value: TBreakpoint): LongBool;\r\nvar\r\n Len: Integer;\r\nbegin\r\n Result := not IsBreakpointPresent(Value);\r\n if Result then\r\n begin\r\n Value.Active := True;\r\n Len := BreakpointCount;\r\n SetLength(FBreakpointList, Len + 1);\r\n FBreakpointList[Len] := Value;\r\n end;\r\nend;\r\n\r\nfunction TDebuger.AddThreadPointInfo(ThreadData: PThreadData; const PointType: TDbgPointType; DebugEvent: PDebugEvent = nil): LongBool;\r\nvar\r\n Cur: UInt64;\r\n //Prev: UInt64;\r\n PrevTime: UInt64;\r\n Delta: UInt64;\r\n ThPoint: PThreadPoint;\r\nbegin\r\n Result := False;\r\n\r\n if ThreadData = Nil then Exit;\r\n\r\n //Delta := 0;\r\n //Prev := 0;\r\n //Cur := 0;\r\n\r\n case PointType of\r\n ptStart:\r\n Result := True;\r\n ptStop:\r\n Result := True;\r\n ptException:\r\n Result := True;\r\n ptPerfomance:\r\n begin\r\n // \r\n ThreadData^.Elapsed := FProcessData.Elapsed - ThreadData^.Started;\r\n\r\n // CPU\r\n PrevTime := ThreadData^.CPUTime;\r\n ThreadData^.CPUTime := GetThreadCPUTime(ThreadData^.ThreadHandle);\r\n Delta := ThreadData^.CPUTime - PrevTime;\r\n\r\n // CPU\r\n Cur := _QueryThreadCycleTime(ThreadData^.ThreadHandle);\r\n //Prev := ThreadData^.CPUElapsed;\r\n ThreadData^.CPUElapsed := Cur;\r\n\r\n // , \r\n Result := (Delta > (_QueryPerformanceFrequency div 10000)); // 0.1 msec 10 msec\r\n end;\r\n ptSyncObjsInfo:\r\n Result := True;\r\n ptTraceInfo:\r\n Result := True;\r\n end;\r\n\r\n if Result then\r\n begin\r\n //ThreadData^.DbgPoints.BeginRead;\r\n try\r\n ThPoint := PThreadPoint(ThreadData^.DbgPoints.Add);\r\n\r\n ThPoint^.PerfIdx := FProcessData.CurDbgPointIdx;\r\n\r\n ThPoint^.PointType := PointType;\r\n case PointType of\r\n ptStart:\r\n begin\r\n ThreadData^.Started :=\r\n FProcessData.Started + FProcessData.DbgPointByIdx(ThPoint^.PerfIdx)^.FromStart;\r\n end;\r\n ptStop:\r\n begin\r\n ThreadData^.Elapsed :=\r\n (FProcessData.Started + FProcessData.DbgPointByIdx(ThPoint^.PerfIdx)^.FromStart) - ThreadData^.Started;\r\n\r\n ThreadData^.CPUTime := GetThreadCPUTime(ThreadData^.ThreadHandle);\r\n\r\n ThreadData^.CPUElapsed := _QueryThreadCycleTime(ThreadData^.ThreadHandle);\r\n end;\r\n ptException:\r\n begin\r\n ThPoint^.ExceptInfo := TExceptInfo.Create(DebugEvent);\r\n ThreadData^.DbgExceptions.Add(ThPoint^.ExceptInfo);\r\n\r\n FProcessData.DbgExceptions.Add(ThPoint^.ExceptInfo);\r\n end;\r\n ptPerfomance:\r\n begin\r\n ThPoint^.PerfInfo := Nil;\r\n (* TODO:\r\n ThPoint^.PerfInfo := TPerfInfo.Create;\r\n ThPoint^.PerfInfo.DeltaTickCPU := Cur - Prev;\r\n ThPoint^.PerfInfo.DeltaTime := Delta;\r\n *)\r\n end;\r\n ptSyncObjsInfo:\r\n begin\r\n ThPoint^.SyncObjsInfo := TSyncObjsInfo.Create(DebugEvent, ThreadData, ThPoint^.PerfIdx);\r\n end;\r\n ptTraceInfo:\r\n begin\r\n if FDbgTraceState = dtsPause then\r\n begin\r\n ThPoint^.ExceptInfo := TExceptInfo.Create(ThreadData);\r\n ThPoint^.ExceptInfo.ExceptionName := Format('### DBG_TRACE #%d', [FTraceCounter]);\r\n\r\n ThreadData^.DbgExceptions.Add(ThPoint^.ExceptInfo);\r\n\r\n FProcessData.DbgExceptions.Add(ThPoint^.ExceptInfo);\r\n end;\r\n end;\r\n end;\r\n finally\r\n ThreadData^.DbgPoints.Commit;\r\n //ThreadData^.DbgPoints.EndRead;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TDebuger.AddProcessPointInfo(const PointType: TDbgPointType): LongBool;\r\nvar\r\n ProcPoint: PProcessPoint;\r\n Cur: UInt64;\r\n PCur: Int64;\r\n PrevTime: UInt64;\r\n CurTime: UInt64;\r\n Delta: UInt64;\r\nbegin\r\n Result := False;\r\n\r\n PCur := _QueryPerformanceCounter;\r\n\r\n CurTime := GetProcessCPUTime(FProcessData.AttachedProcessHandle);\r\n\r\n Delta := 0;\r\n\r\n case PointType of\r\n ptStart, ptException, ptThreadInfo, ptTraceInfo {, ptMemoryInfo}:\r\n begin\r\n Result := True;\r\n end;\r\n ptStop:\r\n begin\r\n FProcessData.Elapsed := PCur;\r\n FProcessData.CPUElapsed := _QueryProcessCycleTime(FProcessData.AttachedProcessHandle);\r\n FProcessData.CPUTime := CurTime;\r\n\r\n Result := True;\r\n end;\r\n ptPerfomance:\r\n begin\r\n // \r\n FProcessData.Elapsed := PCur;\r\n\r\n // CPU\r\n Cur := _QueryProcessCycleTime(FProcessData.AttachedProcessHandle);\r\n FProcessData.CPUElapsed := Cur;\r\n\r\n // CPU \r\n PrevTime := FProcessData.CPUTime;\r\n FProcessData.CPUTime := CurTime;\r\n Delta := CurTime - PrevTime;\r\n\r\n // \r\n Result := (Delta > (_QueryPerformanceFrequency div 10000)); // 0.1 msec 10 msec\r\n end;\r\n end;\r\n\r\n if Result then\r\n begin\r\n ProcPoint := FProcessData.DbgPoints.Add;\r\n\r\n ProcPoint^.FromStart := PCur - FProcessData.Started;\r\n ProcPoint^.CPUTime := CurTime;\r\n\r\n ProcPoint^.PointType := PointType;\r\n case PointType of\r\n ptPerfomance:\r\n begin\r\n ProcPoint^.DeltaTime := Delta;\r\n end;\r\n end;\r\n\r\n FProcessData.DbgPoints.Commit;\r\n end;\r\nend;\r\n\r\nfunction TDebuger.AddThread(const ThreadID: TThreadId; ThreadHandle: THandle): PThreadData;\r\nbegin\r\n Result := FThreadList.Add;\r\n\r\n Result^.Init;\r\n\r\n Result^.ThreadID := ThreadID;\r\n Result^.State := tsActive;\r\n Result^.ThreadHandle := ThreadHandle;\r\n\r\n FActiveThreadList.AddOrSetValue(ThreadId, Result);\r\n\r\n Result^.ThreadAdvInfo := SetThreadInfo(ThreadId);\r\n Result^.ThreadAdvInfo^.ThreadData := Result;\r\n\r\n FThreadList.Commit;\r\n\r\n if AddProcessPointInfo(ptThreadInfo) then\r\n AddThreadPointInfo(Result, ptStart);\r\nend;\r\n\r\nfunction TDebuger.AddThreadInfo(const ThreadId: TThreadId): PThreadAdvInfo;\r\nbegin\r\n Result := FThreadAdvInfoList.Add;\r\n\r\n Result^.ThreadId := ThreadId;\r\n Result^.ThreadData := Nil;\r\n\r\n FThreadAdvInfoList.Commit;\r\nend;\r\n\r\nfunction TDebuger.ProcAllocMem(const Size: Cardinal): Pointer;\r\nbegin\r\n // TODO: Size\r\n Result := VirtualAllocEx(FProcessData.AttachedProcessHandle, Nil, Size, MEM_COMMIT Or MEM_RESERVE, PAGE_EXECUTE_READWRITE);\r\n If Result = nil Then\r\n RaiseLastOsError;\r\nend;\r\n\r\nfunction TDebuger.AttachToProcess(const ProcessID: TProcessId; SentEntryPointBreakPoint: LongBool): LongBool;\r\nbegin\r\n LoadLibrary('DbgHook32.dll'); // \r\n\r\n Result := False;\r\n\r\n if FProcessData.State = psActive then\r\n Exit;\r\n\r\n FSetEntryPointBreakPoint := SentEntryPointBreakPoint;\r\n\r\n FProcessData.ProcessID := ProcessID;\r\n\r\n Result := DebugActiveProcess(Cardinal(ProcessID));\r\nend;\r\n\r\nfunction TDebuger.BreakpointCount: Integer;\r\nbegin\r\n Result := Length(FBreakpointList);\r\nend;\r\n\r\nfunction TDebuger.BreakpointItem(Index: Integer): TBreakpoint;\r\nbegin\r\n CheckBreakpointIndex(Index);\r\n Result := FBreakpointList[Index];\r\nend;\r\n\r\nprocedure TDebuger.CallUnhandledBreakPointEvents(const Code: TExceptionCode; DebugEvent: PDebugEvent);\r\nbegin\r\n //ContinueStatus := DBG_EXCEPTION_NOT_HANDLED;\r\n\r\n if Assigned(FExceptionEvents[Code]) then\r\n FExceptionEvents[Code](Self, DebugEvent^.dwThreadId, @DebugEvent^.Exception.ExceptionRecord);\r\nend;\r\n\r\nprocedure TDebuger.CallUnhandledExceptionEvents(const Code: TExceptionCode; DebugEvent: PDebugEvent);\r\nvar\r\n IsTraceException: LongBool;\r\nbegin\r\n if gvDebugInfo.CheckDebugException(@DebugEvent^.Exception.ExceptionRecord, IsTraceException) then\r\n begin\r\n if IsTraceException then\r\n begin\r\n // TODO:\r\n end;\r\n\r\n ContinueStatus := DBG_CONTINUE;\r\n end\r\n else\r\n begin\r\n if DebugEvent^.Exception.dwFirstChance = 1 then\r\n begin\r\n ContinueStatus := DBG_EXCEPTION_NOT_HANDLED;\r\n\r\n if AddProcessPointInfo(ptException) then\r\n AddThreadPointInfo(CurThreadData, ptException, DebugEvent);\r\n\r\n if Assigned(FExceptionEvents[Code]) then\r\n FExceptionEvents[Code](Self, DebugEvent^.dwThreadId, @DebugEvent^.Exception.ExceptionRecord);\r\n end\r\n else\r\n ContinueStatus := DBG_CONTINUE;\r\n end;\r\nend;\r\n\r\nprocedure TDebuger.CheckBreakpointIndex(Value: Integer);\r\nbegin\r\n if (Value < 0) or (Value >= BreakpointCount) then\r\n raise EDebugCoreException.CreateFmt(SListIndexError, [Value]);\r\nend;\r\n\r\nfunction TDebuger.CheckIsAddrInRealMemoryBPRegion(BreakPointIndex: Integer; AAddr: Pointer): LongBool;\r\nbegin\r\n CheckBreakpointIndex(BreakPointIndex);\r\n Result := Cardinal(AAddr) >= Cardinal(FBreakpointList[BreakPointIndex].Memory.Address);\r\n if Result then\r\n Result := Cardinal(AAddr) < Cardinal(FBreakpointList[BreakPointIndex].Memory.Address) + FBreakpointList[BreakPointIndex].Memory.Size;\r\nend;\r\n\r\nprocedure TDebuger.ClearDbgInfo;\r\nvar\r\n I: Integer;\r\n ThData: PThreadData;\r\nbegin\r\n DbgState := dsNone;\r\n\r\n FDbgMemoryProfiler.Clear;\r\n FDbgSyncObjsProfiler.Clear;\r\n FDbgSamplingProfiler.Clear;\r\n FDbgCodeProfiler.Clear;\r\n\r\n FProcessData.Clear;\r\n\r\n try\r\n FActiveThreadList.Clear;\r\n\r\n FThreadList.BeginWrite;\r\n try\r\n for I := 0 to FThreadList.Count - 1 do\r\n begin\r\n ThData := FThreadList[I];\r\n ThData.Clear;\r\n end;\r\n finally\r\n FThreadList.Clear;\r\n FThreadList.EndWrite;\r\n end;\r\n finally\r\n FThreadAdvInfoList.Clear;\r\n\r\n FTraceCounter := 0;\r\n end;\r\nend;\r\n\r\nfunction TDebuger.ContinueDebug: LongBool;\r\nbegin\r\n Result := False;\r\n\r\n if DbgTraceState = dtsPause then\r\n begin\r\n DbgTraceState := dtsContinue;\r\n\r\n FTraceEvent.SetEvent;\r\n Result := True;\r\n end;\r\nend;\r\n\r\nconstructor TDebuger.Create();\r\n\r\n function SetDebugPriv: LongBool;\r\n var\r\n Token: THandle;\r\n tkp: TTokenPrivileges;\r\n begin\r\n Result := False;\r\n if OpenProcessToken(GetCurrentProcess, TOKEN_ADJUST_PRIVILEGES or TOKEN_QUERY, Token) then\r\n begin\r\n if LookupPrivilegeValue(nil, PChar('SeDebugPrivilege'), tkp.Privileges[0].Luid) then\r\n begin\r\n tkp.PrivilegeCount := 1;\r\n tkp.Privileges[0].Attributes := SE_PRIVILEGE_ENABLED;\r\n Result := AdjustTokenPrivileges(Token, False, tkp, 0, PTokenPrivileges(nil)^, PCardinal(nil)^);\r\n end;\r\n end;\r\n end;\r\n\r\nbegin\r\n inherited Create;\r\n\r\n if not SetDebugPriv then\r\n RaiseLastOSError;\r\n\r\n FDbgState := dsNone;\r\n FDbgTraceState := dtsContinue;\r\n\r\n FTraceEvent := TEvent.Create(nil, True, False, '');\r\n\r\n FRestoreBPIndex := -1;\r\n FRestoreMBPIndex := -1;\r\n FRestoredHWBPIndex := -1;\r\n FRestoredThread := 0;\r\n FCloseDebugProcess := True;\r\n FSetEntryPointBreakPoint := False;\r\n FDbgLogMode := False;\r\n FMemoryBPCheckMode := False;\r\n\r\n FThreadList := TCollectList.Create;\r\n FThreadAdvInfoList := TCollectList.Create;\r\n FActiveThreadList := TDbgActiveThreadList.Create(512, True);\r\n\r\n FProcessData := TProcessData.Create;\r\n\r\n FPerfomanceMode := False;\r\n FPerfomanceCheckPtr := Nil; //Pointer($76FED315);\r\n\r\n FDbgSamplingProfiler := TDbgSamplingProfiler.Create;\r\n FDbgMemoryProfiler := TDbgMemoryProfiler.Create;\r\n FDbgSyncObjsProfiler := TDbgSyncObjsProfiler.Create;\r\n FDbgCodeProfiler := TDbgCodeProfiler.Create;\r\nend;\r\n\r\nfunction TDebuger.CurThreadData: PThreadData;\r\nbegin\r\n if FCurThreadData = Nil then\r\n UpdateCurThreadContext;\r\n\r\n Result := FCurThreadData;\r\nend;\r\n\r\nfunction TDebuger.CurThreadId: TThreadId;\r\nbegin\r\n Result := FCurThreadId;\r\nend;\r\n\r\nfunction TDebuger.DebugNewProcess(const AppPath: string; var ErrInfo: String; const RunParams: String = ''; const WorkingDirectory: String = ''): LongBool;\r\nvar\r\n PI: PProcessInformation;\r\n SI: PStartupInfo;\r\n CmdLine: String;\r\n PCmdLine: PChar;\r\n PAppName: PChar;\r\n PWorkDir: PChar;\r\nbegin\r\n LoadLibrary('DbgHook32.dll'); // \r\n\r\n Result := False;\r\n if FProcessData.State = psActive then\r\n Exit;\r\n\r\n //FSetEntryPointBreakPoint := SentEntryPointBreakPoint;\r\n FSetEntryPointBreakPoint := False;\r\n\r\n PI := AllocMem(SizeOf(TProcessInformation));\r\n SI := AllocMem(SizeOf(TStartupInfo));\r\n try\r\n SI.cb := SizeOf(TStartupInfo);\r\n SI.dwFlags := STARTF_USESHOWWINDOW;\r\n SI.wShowWindow := SW_SHOWNORMAL;\r\n\r\n PAppName := nil;\r\n PCmdLine := nil;\r\n PWorkDir := nil;\r\n\r\n if RunParams <> '' then\r\n begin\r\n CmdLine := Format('\"%s\" %s', [AppPath, RunParams]);\r\n PCmdLine := PChar(CmdLine);\r\n end\r\n else\r\n PAppName := PChar(AppPath);\r\n\r\n if (WorkingDirectory <> '') and (DirectoryExists(WorkingDirectory)) then\r\n PWorkDir := PChar(WorkingDirectory);\r\n\r\n Result := CreateProcess(PAppName, PCmdLine, nil, nil, False, DEBUG_PROCESS or DEBUG_ONLY_THIS_PROCESS, nil,\r\n PWorkDir, SI^, PI^);\r\n\r\n if Result then\r\n begin\r\n FProcessData.ProcessID := TProcessId(PI.dwProcessId);\r\n FProcessData.CreatedProcessHandle := PI.hProcess;\r\n FProcessData.CreatedThreadHandle := PI.hThread;\r\n end\r\n else\r\n ErrInfo := SysErrorMessage(GetLastError);\r\n finally\r\n FreeMemory(PI);\r\n FreeMemory(SI);\r\n end;\r\nend;\r\n\r\ndestructor TDebuger.Destroy;\r\nbegin\r\n StopDebug;\r\n\r\n ClearDbgInfo;\r\n\r\n FreeAndNil(FActiveThreadList);\r\n FreeAndNil(FThreadList);\r\n FreeAndNil(FThreadAdvInfoList);\r\n\r\n FreeAndNil(FProcessData);\r\n\r\n FreeAndNil(FTraceEvent);\r\n\r\n FreeAndNil(FDbgMemoryProfiler);\r\n FreeAndNil(FDbgSyncObjsProfiler);\r\n FreeAndNil(FDbgSamplingProfiler);\r\n FreeAndNil(FDbgCodeProfiler);\r\n\r\n inherited;\r\nend;\r\n\r\nprocedure TDebuger.DoCreateProcess(DebugEvent: PDebugEvent);\r\nvar\r\n CreateThreadInfo: PCreateThreadDebugInfo;\r\nbegin\r\n DbgState := dsStarted;\r\n\r\n FProcessData.State := psActive;\r\n\r\n // \r\n FProcessData.AttachedFileHandle := DebugEvent^.CreateProcessInfo.hFile;\r\n FProcessData.AttachedProcessHandle := DebugEvent^.CreateProcessInfo.hProcess;\r\n FProcessData.AttachedThreadHandle := DebugEvent^.CreateProcessInfo.hThread;\r\n\r\n FProcessData.StartAddress := DebugEvent^.CreateProcessInfo.lpStartAddress;\r\n FProcessData.BaseOfImage := DebugEvent^.CreateProcessInfo.lpBaseOfImage;\r\n FProcessData.MainThreadID := DebugEvent^.dwThreadId;\r\n\r\n FProcessData.Started := _QueryPerformanceCounter;\r\n FProcessData.DbgPoints := TCollectList.Create;\r\n FProcessData.DbgGetMemInfo := TGetMemInfoList.Create(1024, True);\r\n FProcessData.DbgGetMemInfo.OwnsValues := True;\r\n\r\n FProcessData.ProcessGetMemCount := 0;\r\n FProcessData.ProcessGetMemSize := 0;\r\n\r\n FProcessData.DbgExceptions.Clear;\r\n\r\n FProcessData.DbgTrackEventCount := 0;\r\n FProcessData.DbgTrackUnitList := TCodeTrackUnitInfoList.Create(4096);\r\n FProcessData.DbgTrackUnitList.OwnsValues := True;\r\n FProcessData.DbgTrackFuncList := TCodeTrackFuncInfoList.Create(4096);\r\n FProcessData.DbgTrackFuncList.OwnsValues := True;\r\n FProcessData.DbgTrackUsedUnitList := TTrackUnitInfoList.Create(64);\r\n FProcessData.DbgTrackUsedUnitList.OwnsKeys := False;\r\n FProcessData.DbgTrackUsedUnitList.OwnsValues := False;\r\n\r\n //DbgTrackBreakpoints := nil;\r\n //DbgTrackRETBreakpoints := nil;\r\n\r\n // \r\n AddProcessPointInfo(ptStart);\r\n\r\n // \r\n //LoadLibrary('DbgHook32.dll'); // ??? \r\n\r\n if Assigned(gvDebugInfo) then\r\n gvDebugInfo.InitDebugHook;\r\n\r\n // BreakPoint \r\n if FSetEntryPointBreakPoint then\r\n SetUserBreakpoint(FProcessData.StartAddress, 0, 'Process Entry Point Breakpoint');\r\n\r\n if Assigned(FCreateProcess) then\r\n FCreateProcess(Self, DebugEvent^.dwProcessId, @DebugEvent^.CreateProcessInfo);\r\n\r\n AddThread(DebugEvent^.dwThreadId, FProcessData.AttachedThreadHandle);\r\n\r\n with SetThreadInfo(DebugEvent^.dwThreadId)^ do\r\n begin\r\n ThreadName := 'Main thread';\r\n ThreadAdvType := tatNormal;\r\n end;\r\n\r\n if Assigned(FCreateThread) then\r\n begin\r\n CreateThreadInfo := AllocMem(SizeOf(TCreateThreadDebugInfo));\r\n try\r\n CreateThreadInfo.hThread := FProcessData.AttachedThreadHandle;\r\n FCreateThread(Self, DebugEvent^.dwThreadId, CreateThreadInfo);\r\n finally\r\n FreeMemory(CreateThreadInfo);\r\n end;\r\n end;\r\n\r\n // \r\n if CodeTracking and SamplingMethod then\r\n DbgSamplingProfiler.InitSamplingTimer;\r\n\r\n TDbgWorkerThread.Init;\r\n\r\n DoResumeAction(DebugEvent^.dwThreadId);\r\nend;\r\n\r\nprocedure TDebuger.DoCreateThread(DebugEvent: PDebugEvent);\r\nbegin\r\n AddThread(DebugEvent^.dwThreadId, DebugEvent^.CreateThread.hThread);\r\n\r\n if Assigned(FCreateThread) then\r\n FCreateThread(Self, DebugEvent^.dwThreadId, @DebugEvent^.CreateThread);\r\nend;\r\n\r\nprocedure TDebuger.DoDebugString(DebugEvent: PDebugEvent);\r\nbegin\r\n if Assigned(FDebugString) then\r\n FDebugString(Self, DebugEvent.dwThreadId, @DebugEvent^.DebugString);\r\nend;\r\n\r\nprocedure TDebuger.DoExitProcess(DebugEvent: PDebugEvent);\r\nbegin\r\n DbgSamplingProfiler.ResetSamplingTimer;\r\n\r\n TDbgWorkerThread.Reset;\r\n\r\n DbgState := dsStoping;\r\n FProcessData.State := psFinished;\r\n\r\n // \r\n AddProcessPointInfo(ptStop);\r\n\r\n // \r\n if Assigned(FExitThread) then\r\n FExitThread(Self, FProcessData.MainThreadID, nil);\r\n RemoveThread(FProcessData.MainThreadID);\r\n\r\n if Assigned(FExitProcess) then\r\n FExitProcess(Self, FProcessData.ProcessID, @DebugEvent^.ExitProcess);\r\n\r\n if FProcessData.AttachedFileHandle <> 0 then\r\n begin\r\n CloseHandle(FProcessData.AttachedFileHandle);\r\n FProcessData.AttachedFileHandle := 0;\r\n end;\r\n\r\n //FreeLibrary('DbgHook32.dll');\r\nend;\r\n\r\nprocedure TDebuger.DoExitThread(DebugEvent: PDebugEvent);\r\nbegin\r\n if FPerfomanceMode and (DebugEvent^.ExitThread.dwExitCode = Cardinal(@_DbgPerfomanceHook)) then\r\n Exit;\r\n\r\n if Assigned(FExitThread) then\r\n FExitThread(Self, DebugEvent^.dwThreadId, @DebugEvent^.ExitThread);\r\n\r\n RemoveThread(DebugEvent^.dwThreadId);\r\nend;\r\n\r\ntype\r\n PThreadRec = ^TThreadRec;\r\n TThreadRec = record\r\n Func: TThreadFunc;\r\n Parameter: Pointer;\r\n end;\r\n\r\nprocedure TDebuger.DoEndDebug;\r\nbegin\r\n DbgState := dsStoped;\r\n\r\n if Assigned(FEndDebug) then\r\n FEndDebug(Self);\r\nend;\r\n\r\nprocedure TDebuger.DoLoadDll(DebugEvent: PDebugEvent);\r\nbegin\r\n if Assigned(FLoadDll) then\r\n begin\r\n FLoadDll(Self, DebugEvent^.dwThreadId, @DebugEvent^.LoadDll);\r\n DoResumeAction(DebugEvent^.dwThreadId);\r\n end;\r\n //CloseHandle(DebugEvent^.LoadDll.hFile); ???\r\nend;\r\n\r\nprocedure TDebuger.DoDbgLog(const ThreadId: TThreadId; const LogData: String);\r\nbegin\r\n if FDbgLogMode and Assigned(FDbgLog) then\r\n FDbgLog(Self, ThreadId, LogData);\r\nend;\r\n\r\nprocedure TDebuger.DoDebugerFailed;\r\nbegin\r\n DbgState := dsDbgFail;\r\n\r\n if Assigned(FMainLoopFailed) then\r\n FMainLoopFailed(Self);\r\nend;\r\n\r\n(*\r\nprocedure TDebuger.DoRestoreBreakpoint(const Address: Pointer);\r\nvar\r\n OldProtect: DWORD;\r\n Dummy: TSysUInt;\r\nbegin\r\n Check(VirtualProtectEx(FProcessData.AttachedProcessHandle, Address, 1, PAGE_READWRITE, OldProtect));\r\n try\r\n Check(WriteProcessMemory(FProcessData.AttachedProcessHandle, Address, @BPOpcode, 1, Dummy));\r\n finally\r\n Check(VirtualProtectEx(FProcessData.AttachedProcessHandle, Address, 1, OldProtect, OldProtect));\r\n end;\r\nend;\r\n*)\r\n\r\nprocedure TDebuger.DoRestoreBreakpointF(const Address: Pointer);\r\nvar\r\n Dummy: TSysUInt;\r\nbegin\r\n Check(WriteProcessMemory(FProcessData.AttachedProcessHandle, Address, @BPOpcode, 1, Dummy));\r\nend;\r\n\r\nprocedure TDebuger.DoResumeAction(const ThreadID: TThreadId);\r\nbegin\r\n // \r\n // \r\n // TraceIn StepOver ..\r\n // \r\n\r\n case ResumeAction of\r\n raTraceInto:\r\n SetSingleStepMode(ThreadID, False);\r\n\r\n raStepOver:\r\n { } ;\r\n\r\n { , .. StepOver\r\n , :\r\n CALL, INT, LOOP, LOOPZ, LOOPNZ, REP, REPZ, REPNZ, CMPS, CMPSB, CMPSW,\r\n LODSB, LODSW, MOVS, MOVSB, MOVSW, SCAS, SCASB, SCASW, STOS, STOSB, STOSW\r\n }\r\n\r\n raRunUntilReturn:\r\n { , } ;\r\n\r\n raStop:\r\n ContinueStatus := DBG_CONTROL_C;\r\n end;\r\nend;\r\n\r\nprocedure TDebuger.DoRip(DebugEvent: PDebugEvent);\r\nbegin\r\n DbgState := dsDbgFail;\r\n\r\n if Assigned(FRip) then\r\n FRip(Self, DebugEvent^.dwThreadId, @DebugEvent^.RipInfo);\r\nend;\r\n\r\nprocedure TDebuger.DoUnLoadDll(DebugEvent: PDebugEvent);\r\nbegin\r\n if Assigned(FUnLoadDll) then\r\n begin\r\n FUnLoadDll(Self, DebugEvent^.dwThreadId, @DebugEvent^.UnloadDll);\r\n DoResumeAction(DebugEvent^.dwThreadId);\r\n end;\r\nend;\r\n\r\nprocedure TDebuger.DropAllHardwareBreakpoint(const ThreadId: TThreadID);\r\nvar\r\n I: THWBPIndex;\r\n NeedUpdate: LongBool;\r\n ThData: PThreadData;\r\nbegin\r\n ThData := GetThreadData(ThreadID);\r\n if ThData <> nil then\r\n begin\r\n NeedUpdate := False;\r\n for I := 0 to 3 do\r\n if ThData^.Breakpoint.Address[I] <> nil then\r\n begin\r\n NeedUpdate := True;\r\n ThData^.Breakpoint.Address[I] := nil;\r\n end;\r\n if NeedUpdate then\r\n UpdateHardwareBreakpoints(ThreadId);\r\n end;\r\nend;\r\n\r\nprocedure TDebuger.DropHardwareBreakpoint(const ThreadId: TThreadID; Index: THWBPIndex);\r\nvar\r\n ThData: PThreadData;\r\nbegin\r\n ThData := GetThreadData(ThreadID);\r\n if ThData <> nil then\r\n begin\r\n if ThData^.Breakpoint.Address[Index] = nil then\r\n Exit;\r\n ThData^.Breakpoint.Address[Index] := nil;\r\n UpdateHardwareBreakpoints(ThreadId);\r\n end;\r\nend;\r\n\r\nprocedure TDebuger.ExecuteCode(AddrPtr: Pointer; const TimeOut: Cardinal);\r\nbegin\r\n\r\nend;\r\n\r\nprocedure TDebuger.ProcFreeMem(Data: Pointer; const Size: NativeUInt = 0);\r\nbegin\r\n{$IF CompilerVersion >= 28.0}\r\n if VirtualFreeEx(FProcessData.AttachedProcessHandle, Data, Size, MEM_RELEASE) = false then\r\n{$ELSE}\r\n if VirtualFreeEx(FProcessData.AttachedProcessHandle, Data, Size, MEM_RELEASE) = nil then\r\n{$IFEND}\r\n RaiseLastOSError;\r\nend;\r\n\r\nfunction TDebuger.GetActive: LongBool;\r\nconst\r\n DBG_STOPED_STATE = [dsNone, dsStoped, dsDbgFail];\r\nbegin\r\n Result := not(FDbgState in DBG_STOPED_STATE);\r\nend;\r\n\r\nprocedure TDebuger.GetActiveThreads(var Res: TDbgActiveThreads);\r\nbegin\r\n FActiveThreadList.LockForRead;\r\n\r\n SetLength(Res, FActiveThreadList.Count);\r\n FActiveThreadList.Values.CopyTo(Res);\r\n\r\n FActiveThreadList.UnLockForRead;\r\nend;\r\n\r\nfunction TDebuger.GetBPIndex(BreakPointAddr: Pointer; const ThreadID: TThreadId = 0): Integer;\r\nvar\r\n BP: PBreakpoint;\r\nbegin\r\n for Result := 0 to BreakpointCount - 1 do\r\n begin\r\n BP := @FBreakpointList[Result];\r\n if BP^.bpType <> btUser then\r\n Continue;\r\n\r\n if (BP^.Int3.Address = BreakPointAddr) and ((ThreadID = 0) or (BP^.ThreadId = ThreadId)) then\r\n Exit;\r\n end;\r\n\r\n Result := -1;\r\nend;\r\n\r\nprocedure TDebuger.GetCallStack(ThData: PThreadData; var Stack: TDbgInfoStack);\r\nconst\r\n _MAX_STACK_CNT = 64;\r\n\r\n function AddStackEntry(Const Addr: Pointer; var Cnt: Integer): LongBool;\r\n begin\r\n Result := (Cnt < _MAX_STACK_CNT) and IsValidAddr(Addr);\r\n\r\n if Result then\r\n begin\r\n Stack[Cnt] := Addr;\r\n Inc(Cnt);\r\n end;\r\n end;\r\n\r\nVar\r\n EIP : Pointer;\r\n EBP : Pointer;\r\n Cnt: Integer;\r\nBegin\r\n EIP := Pointer(ThData^.Context^.Eip);\r\n EBP := Pointer(ThData^.Context^.Ebp);\r\n\r\n SetLength(Stack, _MAX_STACK_CNT);\r\n Cnt := 0;\r\n\r\n if AddStackEntry(EIP, Cnt) then\r\n begin\r\n while IsValidAddr(EBP) Do\r\n begin\r\n if not ReadData(IncPointer(EBP, SizeOf(Pointer)), @EIP, SizeOf(Pointer)) then\r\n Break;\r\n\r\n if not ReadData(EBP, @EBP, SizeOf(Pointer)) then\r\n Break;\r\n\r\n if not AddStackEntry(EIP, Cnt) then\r\n Break;\r\n end;\r\n end;\r\n\r\n SetLength(Stack, Cnt);\r\nend;\r\n\r\nprocedure TDebuger.GetCallStackEx(ThData: PThreadData; var Stack: TDbgInfoStack);\r\nconst\r\n _MAX_STACK_CNT = 64;\r\nvar\r\n {$IFDEF WIN32}\r\n StackFrame: TStackFrame;\r\n {$ELSE}\r\n StackFrame: TStackFrame64;\r\n {$ENDIF}\r\n ThreadContext: PContext;\r\n MachineType: DWORD;\r\n Cnt: Integer;\r\nbegin\r\n ZeroMemory(@StackFrame, SizeOf(TStackFrame));\r\n\r\n StackFrame.AddrPC.Mode := AddrModeFlat;\r\n StackFrame.AddrStack.Mode := AddrModeFlat;\r\n StackFrame.AddrFrame.Mode := AddrModeFlat;\r\n\r\n ThreadContext := ThData^.Context;\r\n\r\n {$IFDEF WIN32}\r\n StackFrame.AddrPC.Offset := ThreadContext.Eip;\r\n StackFrame.AddrStack.Offset := ThreadContext.Esp;\r\n StackFrame.AddrFrame.Offset := ThreadContext.Ebp;\r\n MachineType := IMAGE_FILE_MACHINE_I386;\r\n {$ELSE}\r\n StackFrame.AddrPC.Offset := ThreadContext.Rip;\r\n StackFrame.AddrStack.Offset := ThreadContext.Rsp;\r\n StackFrame.AddrFrame.Offset := ThreadContext.Rbp;\r\n MachineType := IMAGE_FILE_MACHINE_AMD64;\r\n {$ENDIF}\r\n\r\n SetLength(Stack, _MAX_STACK_CNT); // TODO: \r\n\r\n Cnt := 0;\r\n while Cnt < Length(Stack) do\r\n begin\r\n {$IFDEF WIN32}\r\n if not StackWalk(MachineType, ProcessData.AttachedProcessHandle, ThData^.ThreadHandle, @StackFrame, ThreadContext, nil, nil, nil, nil) then\r\n Break;\r\n {$ELSE}\r\n if not StackWalk64(MachineType, hProcess, hThread, StackFrame, ThreadContext, nil, nil, nil, nil) then\r\n Break;\r\n {$ENDIF}\r\n Stack[Cnt] := Pointer(StackFrame.AddrPC.Offset);\r\n\r\n Inc(Cnt);\r\n end;\r\n\r\n SetLength(Stack, Cnt);\r\nend;\r\n\r\nfunction GetMappedFileNameA(hProcess: THandle; lpv: Pointer; lpFilename: LPSTR; nSize: DWORD): DWORD; stdcall; external 'psapi.dll';\r\n\r\nfunction TDebuger.GetDllName(lpImageName, lpBaseOfDll: Pointer; var Unicode: LongBool): AnsiString;\r\nvar\r\n DllNameAddr: Pointer;\r\n MappedName: array [0 .. MAX_PATH - 1] of AnsiChar;\r\nbegin\r\n Result := '';\r\n\r\n if ReadData(lpImageName, @DllNameAddr, 4) then\r\n begin\r\n SetLength(Result, MAX_PATH shl 1);\r\n if not ReadData(DllNameAddr, @Result[1], MAX_PATH shl 1) then\r\n Result := '';\r\n end;\r\n\r\n if Result = '' then\r\n begin\r\n if GetMappedFileNameA(FProcessData.AttachedProcessHandle, lpBaseOfDll, @MappedName[0], MAX_PATH) > 0 then\r\n begin\r\n Result := PAnsiChar(@MappedName[0]);\r\n Unicode := False;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TDebuger.GetExceptionEvent(const Index: TExceptionCode): TDefaultExceptionEvent;\r\nbegin\r\n Result := FExceptionEvents[Index];\r\nend;\r\n\r\nfunction TDebuger.GetFlag(const ThreadID: TThreadId; Flag: DWORD): LongBool;\r\nvar\r\n Context: TContext;\r\n ThData: PThreadData;\r\nbegin\r\n Result := False;\r\n ThData := GetThreadData(ThreadId);\r\n if ThData <> nil then\r\n begin\r\n ZeroMemory(@Context, SizeOf(Context));\r\n Context.ContextFlags := CONTEXT_FULL;\r\n Check(GetThreadContext(ThData^.ThreadHandle, Context));\r\n Result := Context.EFlags and Flag = 1;\r\n end;\r\nend;\r\n\r\nfunction TDebuger.GetMBPIndex(BreakPointAddr: Pointer; FromIndex: Integer): Integer;\r\n\r\n function CheckStartAddr(Data: Pointer): LongBool;\r\n begin\r\n Result := Cardinal(Data) <= Cardinal(BreakPointAddr);\r\n end;\r\n\r\n function CheckEndAddr(Data: Pointer; Size: DWORD): LongBool;\r\n begin\r\n Result := Cardinal(Data) + Size > Cardinal(BreakPointAddr);\r\n end;\r\n\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := -1;\r\n for I := FromIndex to BreakpointCount - 1 do\r\n begin\r\n if FBreakpointList[I].bpType <> btMemory then\r\n Continue;\r\n if CheckStartAddr(FBreakpointList[I].Memory.RegionStart) and CheckEndAddr(FBreakpointList[I].Memory.RegionStart,\r\n FBreakpointList[I].Memory.RegionSize) then\r\n begin\r\n Result := I;\r\n Break;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TDebuger.GetRegisters(const ThreadID: TThreadId): TContext;\r\nvar\r\n ThData: PThreadData;\r\nbegin\r\n if (ThreadID = FCurThreadId) then\r\n Result := CurThreadData^.Context^\r\n else\r\n begin\r\n ThData := UpdateThreadContext(ThreadId);\r\n if ThData <> nil then\r\n Result := ThData^.Context^\r\n else\r\n RaiseDebugCoreException();\r\n end;\r\nend;\r\n\r\nfunction TDebuger.GetThreadIndex(const ThreadID: TThreadId; const UseFinished: LongBool = False): Integer;\r\nvar\r\n ThData: PThreadData;\r\nbegin\r\n for Result := FThreadList.Count - 1 downto 0 do\r\n begin\r\n ThData := FThreadList[Result];\r\n if (ThData^.ThreadID = ThreadID) and ((ThData^.State <> tsFinished) or UseFinished) then\r\n Exit;\r\n end;\r\n\r\n Result := -1;\r\nend;\r\n\r\nfunction TDebuger.GetThreadInfo(const ThreadId: TThreadId): PThreadAdvInfo;\r\nvar\r\n Idx: Integer;\r\nbegin\r\n Result := Nil;\r\n\r\n FThreadAdvInfoList.BeginRead;\r\n try\r\n Idx := GetThreadInfoIndex(ThreadId);\r\n if Idx >= 0 then\r\n Result := FThreadAdvInfoList[Idx];\r\n finally\r\n FThreadAdvInfoList.EndRead;\r\n end;\r\nend;\r\n\r\nfunction TDebuger.GetThreadInfoIndex(const ThreadId: TThreadId): Integer;\r\nvar\r\n ThInfo: PThreadAdvInfo;\r\nbegin\r\n FThreadAdvInfoList.BeginRead;\r\n try\r\n for Result := FThreadAdvInfoList.Count - 1 downto 0 do\r\n begin\r\n ThInfo := FThreadAdvInfoList[Result];\r\n if (ThInfo^.ThreadID = ThreadID) and\r\n ((ThInfo^.ThreadData = Nil) or (ThInfo^.ThreadData^.State <> tsFinished))\r\n then\r\n Exit;\r\n end;\r\n finally\r\n FThreadAdvInfoList.EndRead;\r\n end;\r\n\r\n Result := -1;\r\nend;\r\n\r\nfunction TDebuger.GetThreadCount: Integer;\r\nbegin\r\n Result := FThreadList.Count;\r\nend;\r\n\r\nfunction TDebuger.GetThreadData(const ThreadID: TThreadId; const UseFinished: LongBool = False): PThreadData;\r\nvar\r\n Index: Integer;\r\nbegin\r\n Result := nil;\r\n\r\n if not FActiveThreadList.TryGetValue(ThreadID, Result) then\r\n begin\r\n if UseFinished then\r\n begin\r\n Index := GetThreadIndex(ThreadId, UseFinished);\r\n if Index >= 0 then\r\n Result := FThreadList[Index];\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TDebuger.GetThreadDataByIdx(const Idx: Integer): PThreadData;\r\nbegin\r\n Result := Nil;\r\n\r\n if Idx < FThreadList.Count then\r\n Result := FThreadList[Idx];\r\nend;\r\n\r\nfunction TDebuger.IsBreakpointPresent(const Value: TBreakpoint): LongBool;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := False;\r\n for I := 0 to BreakpointCount - 1 do\r\n case FBreakpointList[I].bpType of\r\n btUser:\r\n if FBreakpointList[I].Int3.Address = Value.Int3.Address then\r\n begin\r\n Result := True;\r\n Break;\r\n end;\r\n btMemory:\r\n if CheckIsAddrInRealMemoryBPRegion(I, Value.Memory.Address) or\r\n CheckIsAddrInRealMemoryBPRegion(I, Pointer(Cardinal(Value.Memory.Address) + Value.Memory.Size - 1)) then\r\n begin\r\n Result := True;\r\n Break;\r\n end;\r\n end;\r\nend;\r\n\r\nthreadvar\r\n _mbi: TMemoryBasicInformation;\r\n\r\nfunction TDebuger.IsValidAddr(const Addr: Pointer): LongBool;\r\nVar\r\n mbi: PMemoryBasicInformation;\r\nBegin\r\n Result := False;\r\n\r\n if (Addr = nil) or (Addr = Pointer(-1)) then Exit;\r\n\r\n mbi := @_mbi;\r\n\r\n Result := (VirtualQueryEx(FProcessData.AttachedProcessHandle, Addr, mbi^, SizeOf(TMemoryBasicInformation)) <> 0);\r\nend;\r\n\r\nfunction TDebuger.IsValidCodeAddr(const Addr: Pointer): LongBool;\r\nConst\r\n _PAGE_CODE = DWORD(PAGE_EXECUTE Or PAGE_EXECUTE_READ or PAGE_EXECUTE_READWRITE Or PAGE_EXECUTE_WRITECOPY);\r\nVar\r\n mbi: PMemoryBasicInformation;\r\nBegin\r\n Result := False;\r\n\r\n mbi := @_mbi;\r\n\r\n if (VirtualQueryEx(FProcessData.AttachedProcessHandle, Addr, mbi^, SizeOf(TMemoryBasicInformation)) <> 0) then\r\n Result := ((mbi^.Protect And _PAGE_CODE) <> 0);\r\nend;\r\n\r\nfunction TDebuger.IsValidProcessCodeAddr(const Addr: Pointer): LongBool;\r\nBegin\r\n Result := False;\r\n\r\n if FProcessData.PEImage <> Nil then\r\n Result := (Cardinal(Addr) >= Cardinal(FProcessData.BaseOfImage)) and\r\n (Cardinal(Addr) <= (Cardinal(FProcessData.BaseOfImage) + FProcessData.PEImage.OptionalHeader32.SizeOfCode));\r\nend;\r\n\r\nfunction TDebuger.PauseDebug: LongBool;\r\nbegin\r\n if Active then\r\n begin\r\n DbgTraceState := dtsPause;\r\n Result := DebugBreakProcess(FProcessData.AttachedProcessHandle);\r\n end\r\n else\r\n Result := True;\r\nend;\r\n\r\nfunction TDebuger.InjectFunc(Func: Pointer; const CodeSize: Cardinal): Pointer;\r\nbegin\r\n Result := VirtualAllocEx(FProcessData.AttachedProcessHandle, nil, CodeSize, MEM_COMMIT, PAGE_READWRITE);\r\n\r\n if not(Assigned(Result) and WriteData(Result, Func, CodeSize)) then\r\n RaiseDebugCoreException(Format('Fail inject func [%p]: %d', [Func, GetLastError]));\r\n\r\n //VirtualFreeEx(ProcessID, ThreadAddr, 0, MEM_RELEASE); // TODO: on Stop debug\r\nend;\r\n\r\nprocedure TDebuger.InjectPerfFunc;\r\nbegin\r\n FPerfomanceCheckPtr := InjectFunc(@_DbgPerfomanceHook, 256);\r\nend;\r\n\r\nprocedure TDebuger.InjectPerfThread;\r\nvar\r\n hThread: THandle;\r\n lpThreadId: Cardinal;\r\nbegin\r\n if (FProcessData.AttachedProcessHandle <> 0) and (DbgState = dsWait) then\r\n begin\r\n if not Assigned(FPerfomanceCheckPtr) then\r\n InjectPerfFunc;\r\n\r\n hThread := CreateRemoteThread(FProcessData.AttachedProcessHandle, nil, 0, FPerfomanceCheckPtr, Nil, 0, lpThreadId);\r\n if hThread <> 0 then\r\n begin\r\n WaitForSingleObject(hThread, INFINITE);\r\n\r\n CloseHandle(hThread);\r\n end;\r\n end\r\nend;\r\n\r\nprocedure TDebuger.InjectThread(hProcess: THandle; Func: Pointer; FuncSize: Cardinal; aParams: Pointer;\r\n aParamsSize: Cardinal; WaitAndFree: LongBool = True);\r\nvar\r\n hThread: THandle;\r\n lpNumberOfBytes: TSysUInt;\r\n lpThreadId: Cardinal;\r\n ThreadAddr, ParamAddr: Pointer;\r\nbegin\r\n // , \r\n ThreadAddr := VirtualAllocEx(hProcess, nil, FuncSize, MEM_COMMIT, PAGE_EXECUTE_READWRITE);\r\n if not WriteProcessMemory(hProcess, ThreadAddr, Func, FuncSize, lpNumberOfBytes) then\r\n RaiseDebugCoreException();\r\n\r\n // \r\n if (aParams <> nil) and (aParamsSize > 0) then\r\n begin\r\n ParamAddr := VirtualAllocEx(hProcess, nil, aParamsSize, MEM_COMMIT, PAGE_EXECUTE_READWRITE);\r\n if not WriteProcessMemory(hProcess, ParamAddr, aParams, aParamsSize, lpNumberOfBytes) then\r\n RaiseDebugCoreException();\r\n end\r\n else\r\n ParamAddr := Nil;\r\n\r\n // , .\r\n hThread := CreateRemoteThread(hProcess, nil, 2048, ThreadAddr, ParamAddr, CREATE_SUSPENDED, lpThreadId);\r\n\r\n if not SetThreadPriority(hThread, THREAD_PRIORITY_NORMAL{THREAD_PRIORITY_TIME_CRITICAL}) then\r\n RaiseDebugCoreException();\r\n\r\n if ResumeThread(hThread) = Cardinal(-1) then\r\n RaiseDebugCoreException();\r\n\r\n if WaitAndFree then\r\n begin\r\n // \r\n WaitForSingleObject(hThread, INFINITE);\r\n\r\n // \r\n CloseHandle(hThread);\r\n VirtualFreeEx(hProcess, ParamAddr, 0, MEM_RELEASE);\r\n VirtualFreeEx(hProcess, ThreadAddr, 0, MEM_RELEASE);\r\n end\r\n else\r\n Sleep(1000);\r\nend;\r\n\r\nfunction TDebuger.PerfomancePauseDebug: LongBool;\r\nbegin\r\n // , DebugBreak\r\n // , , \r\n //Result := DebugBreakProcess(FProcessInfo.AttachedProcessHandle);\r\n\r\n InjectPerfThread;\r\n Result := True;\r\nend;\r\n\r\nprocedure TDebuger.ProcessExceptionBreakPoint(DebugEvent: PDebugEvent);\r\nbegin\r\n if FCodeTracking or FMemoryBPCheckMode then\r\n begin\r\n if DbgCodeProfiler.ProcessTrackRETBreakPoint(DebugEvent) then\r\n Exit;\r\n\r\n if DbgCodeProfiler.ProcessTrackBreakPoint(DebugEvent) then\r\n Exit;\r\n end;\r\n\r\n if ProcessUserBreakPoint(DebugEvent) then\r\n Exit;\r\n\r\n if ProcessTraceBreakPoint(DebugEvent) then\r\n Exit;\r\n\r\n CallUnhandledBreakPointEvents(ecBreakpoint, DebugEvent);\r\nend;\r\n\r\nprocedure TDebuger.ProcessExceptionGuardPage(DebugEvent: PDebugEvent);\r\nvar\r\n CurrentMBPIndex: Integer;\r\n\r\n function CheckWriteMode: LongBool;\r\n begin\r\n Result := not FBreakpointList[CurrentMBPIndex].Memory.BreakOnWrite;\r\n if not Result then\r\n Result := DebugEvent^.Exception.ExceptionRecord.ExceptionInformation[0] = 1;\r\n end;\r\n\r\nvar\r\n MBPIndex: Integer;\r\n ReleaseMBP: LongBool;\r\n dwGuardedAddr: Pointer;\r\nbegin\r\n ReleaseMBP := False;\r\n FRemoveCurrentBreakpoint := False;\r\n dwGuardedAddr := Pointer(DebugEvent^.Exception.ExceptionRecord.ExceptionInformation[1]);\r\n MBPIndex := GetMBPIndex(dwGuardedAddr);\r\n if MBPIndex >= 0 then\r\n begin\r\n CurrentMBPIndex := MBPIndex;\r\n while not CheckIsAddrInRealMemoryBPRegion(CurrentMBPIndex, dwGuardedAddr) do\r\n begin\r\n CurrentMBPIndex := GetMBPIndex(dwGuardedAddr, CurrentMBPIndex + 1);\r\n if CurrentMBPIndex < 0 then\r\n Break;\r\n end;\r\n\r\n if CurrentMBPIndex >= 0 then\r\n begin\r\n MBPIndex := CurrentMBPIndex;\r\n if Assigned(FBreakPoint) and CheckWriteMode then\r\n FBreakPoint(Self, DebugEvent^.dwThreadId, @DebugEvent^.Exception.ExceptionRecord, MBPIndex, ReleaseMBP)\r\n else\r\n CallUnhandledExceptionEvents(ecGuard, DebugEvent);\r\n end\r\n else\r\n CallUnhandledExceptionEvents(ecGuard, DebugEvent);\r\n\r\n FBreakpointList[MBPIndex].Active := False;\r\n SetSingleStepMode(DebugEvent^.dwThreadId, False);\r\n if ReleaseMBP or FRemoveCurrentBreakpoint then\r\n RemoveBreakpoint(MBPIndex)\r\n else\r\n FRestoreMBPIndex := MBPIndex;\r\n end\r\n else\r\n CallUnhandledExceptionEvents(ecGuard, DebugEvent);\r\nend;\r\n\r\nprocedure TDebuger.ProcessExceptionSingleStep(DebugEvent: PDebugEvent);\r\n//var\r\n //Handled: LongBool;\r\n //ThData: PThreadData;\r\nbegin\r\n //ThData := CurThreadData;\r\n\r\n //if Assigned(ThData) then\r\n //begin\r\n if Assigned(DbgCodeProfiler.DbgCurTrackAddress) then\r\n begin\r\n DoRestoreBreakpointF(DbgCodeProfiler.DbgCurTrackAddress);\r\n DbgCodeProfiler.DbgCurTrackAddress := nil;\r\n end;\r\n\r\n Exit;\r\n //end;\r\n\r\n\r\n\r\n (*\r\n // HWBP\r\n Handled := ProcessHardwareBreakpoint(DebugEvent);\r\n\r\n // - HWPB HWBP\r\n if not Handled and (Cardinal(FRestoredThread) <> 0) and (FRestoredHWBPIndex >= 0) then\r\n begin\r\n ToggleHardwareBreakpoint(FRestoredThread, FRestoredHWBPIndex, True);\r\n FRestoredThread := 0;\r\n FRestoredHWBPIndex := -1;\r\n end;\r\n\r\n // \r\n if FRestoreBPIndex >= 0 then\r\n begin\r\n CheckBreakpointIndex(FRestoreBPIndex);\r\n if FBreakpointList[FRestoreBPIndex].bpType = btUser then\r\n ToggleInt3Breakpoint(FRestoreBPIndex, True);\r\n FRestoreBPIndex := -1;\r\n end;\r\n\r\n // M\r\n if FRestoreMBPIndex >= 0 then\r\n begin\r\n CheckBreakpointIndex(FRestoreMBPIndex);\r\n if FBreakpointList[FRestoreMBPIndex].bpType = btMemory then\r\n ToggleMemoryBreakpoint(FRestoreMBPIndex, True);\r\n FRestoreMBPIndex := -1;\r\n end;\r\n\r\n // \r\n // \r\n if ResumeAction <> raRun then\r\n begin\r\n CallUnhandledExceptionEvents(ecSingleStep, DebugEvent);\r\n\r\n // \r\n DoResumeAction(DebugEvent^.dwThreadId);\r\n end;\r\n *)\r\nend;\r\n\r\nfunction TDebuger.ProcessHardwareBreakpoint(DebugEvent: PDebugEvent): LongBool;\r\nvar\r\n Index: Integer;\r\n ReleaseBP: LongBool;\r\n //ThData: PThreadData;\r\n Context: PContext;\r\nbegin\r\n FRemoveCurrentBreakpoint := False;\r\n\r\n// ThData := GetThreadData(DebugEvent^.dwThreadId);\r\n//\r\n// ZeroMemory(@Context, SizeOf(TContext));\r\n// Context.ContextFlags := CONTEXT_DEBUG_REGISTERS;\r\n// Check(GetThreadContext(ThData^.ThreadHandle, Context));\r\n\r\n if CurThreadData = Nil then\r\n RaiseDebugCoreException();\r\n\r\n Context := CurThreadData^.Context;\r\n\r\n //UpdateThreadContext()\r\n\r\n Result := Context^.Dr6 and $F <> 0;\r\n if not Result then\r\n Exit;\r\n\r\n Index := -1;\r\n if Context^.Dr6 and 1 <> 0 then\r\n Index := 0;\r\n if Context^.Dr6 and 2 <> 0 then\r\n Index := 1;\r\n if Context^.Dr6 and 4 <> 0 then\r\n Index := 2;\r\n if Context^.Dr6 and 8 <> 0 then\r\n Index := 3;\r\n\r\n if Index < 0 then\r\n Exit;\r\n\r\n ReleaseBP := False;\r\n\r\n if Assigned(FHardwareBreakpoint) then\r\n FHardwareBreakpoint(Self, DebugEvent^.dwThreadId, @DebugEvent^.Exception.ExceptionRecord, Index, ReleaseBP);\r\n\r\n ToggleHardwareBreakpoint(DebugEvent^.dwThreadId, Index, False);\r\n SetSingleStepMode(DebugEvent^.dwThreadId, False);\r\n\r\n if ReleaseBP or FRemoveCurrentBreakpoint then\r\n DropHardwareBreakpoint(DebugEvent^.dwThreadId, Index)\r\n else\r\n begin\r\n // HWBP ,\r\n // .. \r\n // ProcessExceptionSingleStep, HWBP \r\n // HWBP\r\n if (Cardinal(FRestoredThread) <> 0) and (FRestoredHWBPIndex >= 0) then\r\n ToggleHardwareBreakpoint(FRestoredThread, FRestoredHWBPIndex, True);\r\n\r\n FRestoredHWBPIndex := Index;\r\n FRestoredThread := DebugEvent^.dwThreadId;\r\n end;\r\nend;\r\n\r\nfunction TDebuger.ProcessTraceBreakPoint(DebugEvent: PDebugEvent): LongBool;\r\nbegin\r\n Result := False;\r\n\r\n if DbgTraceState in [dtsPause..dtsStepOut] then\r\n begin\r\n DbgState := dsPause;\r\n\r\n Inc(FTraceCounter);\r\n ProcessDbgTraceInfo(DebugEvent);\r\n\r\n // \r\n FTraceEvent.ResetEvent;\r\n FTraceEvent.WaitFor;\r\n\r\n ProcessDbgTraceInfo(DebugEvent);\r\n\r\n Result := True;\r\n end;\r\nend;\r\n\r\nfunction TDebuger.ProcessUserBreakPoint(DebugEvent: PDebugEvent): LongBool;\r\nvar\r\n Address: Pointer;\r\n ReleaseBP: LongBool;\r\n BreakPointIndex: Integer;\r\nbegin\r\n Result := False;\r\n\r\n ReleaseBP := False;\r\n FRemoveCurrentBreakpoint := False;\r\n\r\n Address := DebugEvent^.Exception.ExceptionRecord.ExceptionAddress;\r\n BreakPointIndex := GetBPIndex(Address, DebugEvent^.dwThreadId);\r\n if BreakPointIndex >= 0 then\r\n begin\r\n if Assigned(FBreakPoint) then\r\n FBreakPoint(Self, DebugEvent^.dwThreadId, @DebugEvent^.Exception.ExceptionRecord, BreakPointIndex, ReleaseBP)\r\n else\r\n CallUnhandledBreakPointEvents(ecBreakpoint, DebugEvent);\r\n\r\n ToggleInt3Breakpoint(BreakPointIndex, False);\r\n SetSingleStepMode(DebugEvent^.dwThreadId, True);\r\n if ReleaseBP or FRemoveCurrentBreakpoint then\r\n RemoveBreakpoint(BreakPointIndex)\r\n else\r\n FRestoreBPIndex := BreakPointIndex;\r\n\r\n Result := True;\r\n end;\r\nend;\r\n\r\nprocedure TDebuger.ProcessDbgPerfomance(DebugEvent: PDebugEvent);\r\nvar\r\n ThData: PThreadData;\r\n I: Integer;\r\nbegin\r\n DbgState := dsPerfomance;\r\n\r\n // \r\n if AddProcessPointInfo(ptPerfomance) then\r\n begin\r\n // , \r\n for I := 0 to FThreadList.Count - 1 do\r\n begin\r\n ThData := FThreadList[I];\r\n if ThData^.State = tsActive then\r\n AddThreadPointInfo(ThData, ptPerfomance);\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TDebuger.ProcessDbgSamplingInfo(DebugEvent: PDebugEvent);\r\nbegin\r\n DbgSamplingProfiler.ProcessDbgSamplingInfo;\r\nend;\r\n\r\nprocedure TDebuger.ProcessDbgSyncObjsInfo(DebugEvent: PDebugEvent);\r\nvar\r\n ER: PExceptionRecord;\r\n DbgInfoType: TDbgInfoType;\r\n Ptr: Pointer;\r\n Size: Cardinal;\r\nbegin\r\n ER := @DebugEvent^.Exception.ExceptionRecord;\r\n DbgInfoType := TDbgInfoType(ER^.ExceptionInformation[0]);\r\n\r\n case DbgInfoType of\r\n dstSyncObjsInfo:\r\n begin\r\n Ptr := Pointer(ER^.ExceptionInformation[1]);\r\n Size := ER^.ExceptionInformation[2];\r\n\r\n DbgSysncObjsProfiler.LoadSyncObjsInfoPackEx(Ptr, Size);\r\n end;\r\n dstPerfomanceAndInfo:\r\n begin\r\n Ptr := Pointer(ER^.ExceptionInformation[3]);\r\n Size := ER^.ExceptionInformation[4];\r\n\r\n DbgSysncObjsProfiler.LoadSyncObjsInfoPackEx(Ptr, Size);\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TDebuger.ReadData(const AddrPrt, ResultPtr: Pointer; const DataSize: Integer): LongBool;\r\nvar\r\n Dummy: TSysUInt;\r\nbegin\r\n Result := ReadProcessMemory(FProcessData.AttachedProcessHandle, AddrPrt, ResultPtr, DataSize, Dummy) and\r\n (Integer(Dummy) = DataSize);\r\nend;\r\n\r\nfunction TDebuger.ReadStringA(AddrPrt: Pointer; Len: Integer = 0): AnsiString;\r\nvar\r\n C: AnsiChar;\r\nbegin\r\n Result := '';\r\n\r\n if Len = -1 then\r\n begin\r\n // PAnsiChar. #0\r\n // TODO: \r\n repeat\r\n C := #0;\r\n\r\n if not ReadData(AddrPrt, @C, SizeOf(AnsiChar)) then Exit;\r\n\r\n if C <> #0 then\r\n begin\r\n Result := Result + C;\r\n\r\n AddrPrt := IncPointer(AddrPrt, SizeOf(AnsiChar));\r\n end;\r\n\r\n until C = #0;\r\n end\r\n else\r\n begin\r\n if Len = 0 then\r\n ReadData(IncPointer(AddrPrt, -SizeOf(Pointer)), @Len, SizeOf(Pointer));\r\n\r\n if (Len > 0) then\r\n begin\r\n SetLength(Result, Len);\r\n if not ReadData(AddrPrt, @Result[1], Len) then\r\n Result := '';\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TDebuger.ReadStringP(AddrPrt: Pointer; Len: Byte = 0): ShortString;\r\nbegin\r\n Result := '';\r\n\r\n if Len = 0 then\r\n ReadData(IncPointer(AddrPrt, -SizeOf(Byte)), @Len, SizeOf(Byte));\r\n\r\n if (Len > 0) then\r\n begin\r\n SetLength(Result, Len);\r\n if not ReadData(AddrPrt, @Result[1], Len) then\r\n Result := '';\r\n end;\r\nend;\r\n\r\nfunction TDebuger.ReadStringW(AddrPrt: Pointer; Len: Integer = 0): WideString;\r\nbegin\r\n Result := '';\r\n\r\n if Len = 0 then\r\n ReadData(IncPointer(AddrPrt, -SizeOf(Pointer)), @Len, SizeOf(Pointer));\r\n\r\n if (Len > 0) then\r\n begin\r\n SetLength(Result, Len);\r\n if not ReadData(AddrPrt, @Result[1], Len * SizeOf(WideChar)) then\r\n Result := '';\r\n end;\r\nend;\r\n\r\nprocedure TDebuger.RemoveBreakpoint(Index: Integer);\r\nvar\r\n Len: Integer;\r\nbegin\r\n ToggleBreakpoint(Index, False);\r\n Len := BreakpointCount;\r\n if Len = 1 then\r\n SetLength(FBreakpointList, 0)\r\n else\r\n begin\r\n FBreakpointList[Index] := FBreakpointList[Len - 1];\r\n SetLength(FBreakpointList, Len - 1);\r\n end;\r\nend;\r\n\r\nprocedure TDebuger.RemoveBreakpoint(const Address: Pointer; const SaveByte: Byte);\r\nbegin\r\n DoRemoveBreakpointF(Address, SaveByte);\r\nend;\r\n\r\nprocedure TDebuger.RemoveCurrentBreakpoint;\r\nbegin\r\n FRemoveCurrentBreakpoint := True;\r\nend;\r\n\r\nprocedure TDebuger.RemoveThread(const ThreadID: TThreadId);\r\nvar\r\n ThData: PThreadData;\r\nbegin\r\n ThData := GetThreadData(ThreadID);\r\n if ThData <> nil then\r\n begin\r\n FActiveThreadList.Remove(ThreadId);\r\n\r\n if ThData^.Breakpoint <> nil then\r\n begin\r\n FreeMemory(ThData^.Breakpoint);\r\n ThData^.Breakpoint := nil;\r\n end;\r\n\r\n ThData^.State := tsFinished;\r\n\r\n if AddProcessPointInfo(ptThreadInfo) then\r\n AddThreadPointInfo(ThData, ptStop);\r\n\r\n DbgMemoryProfiler.UpdateMemoryInfoObjectTypesOfThread(ThData);\r\n end;\r\nend;\r\n\r\nprocedure TDebuger.RestoreBreakpoint(const Address: Pointer);\r\nbegin\r\n DoRestoreBreakpointF(Address);\r\nend;\r\n\r\nprocedure TDebuger.ProcessDbgException(DebugEvent: PDebugEvent);\r\nvar\r\n ER: PExceptionRecord;\r\nbegin\r\n ER := @DebugEvent^.Exception.ExceptionRecord;\r\n case TDbgInfoType(ER^.ExceptionInformation[0]) of\r\n dstThreadInfo:\r\n ProcessDbgThreadInfo(DebugEvent);\r\n dstMemInfo:\r\n ProcessDbgMemoryInfo(DebugEvent);\r\n dstPerfomance:\r\n ProcessDbgPerfomance(DebugEvent);\r\n dstPerfomanceAndInfo:\r\n begin\r\n ProcessDbgPerfomance(DebugEvent);\r\n ProcessDbgMemoryInfo(DebugEvent);\r\n ProcessDbgSyncObjsInfo(DebugEvent);\r\n end;\r\n dstMemHookStatus:\r\n ProcessDbgMemoryInfo(DebugEvent);\r\n dstSyncObjsInfo:\r\n ProcessDbgSyncObjsInfo(DebugEvent);\r\n dstSampling:\r\n ProcessDbgSamplingInfo(DebugEvent);\r\n end;\r\nend;\r\n\r\nprocedure TDebuger.Log(const Msg: String);\r\nbegin\r\n DoDbgLog(CurThreadId, Msg);\r\nend;\r\n\r\nprocedure TDebuger.ProcessDbgMemoryInfo(DebugEvent: PDebugEvent);\r\nvar\r\n ER: PExceptionRecord;\r\n DbgInfoType: TDbgInfoType;\r\n Ptr: Pointer;\r\n Size: Cardinal;\r\nbegin\r\n ER := @DebugEvent^.Exception.ExceptionRecord;\r\n DbgInfoType := TDbgInfoType(ER^.ExceptionInformation[0]);\r\n\r\n case DbgInfoType of\r\n dstMemInfo, dstPerfomanceAndInfo:\r\n begin\r\n Ptr := Pointer(ER^.ExceptionInformation[1]);\r\n Size := ER^.ExceptionInformation[2];\r\n\r\n //LoadMemoryInfoPack(Ptr, Size);\r\n DbgMemoryProfiler.LoadMemoryInfoPackEx(Ptr, Size);\r\n end;\r\n dstMemHookStatus:\r\n begin\r\n case ER^.ExceptionInformation[1] of\r\n 0: gvDebugInfo.ResetMemoryManagerBreakpoints;\r\n 1: gvDebugInfo.SetMemoryManagerBreakpoints;\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TDebuger.ProcessDbgThreadInfo(DebugEvent: PDebugEvent);\r\nvar\r\n ER: PExceptionRecord;\r\n ThreadID: Cardinal;\r\n StrAddr: Pointer;\r\n Str: ShortString;\r\n ThInfo: PThreadAdvInfo;\r\nbegin\r\n ER := @DebugEvent^.Exception.ExceptionRecord;\r\n ThreadID := ER^.ExceptionInformation[1];\r\n if ThreadID <> 0 then\r\n begin\r\n ThInfo := SetThreadInfo(ThreadID);\r\n\r\n //ThInfo^.ThreadParentId := DebugEvent^.dwThreadId;\r\n ThInfo^.ThreadParentId := ER^.ExceptionInformation[3];\r\n\r\n StrAddr := Pointer(ER^.ExceptionInformation[2]);\r\n if StrAddr <> Nil then\r\n begin\r\n Str := ReadStringP(StrAddr, 0);\r\n if Str <> '' then\r\n begin\r\n ThInfo^.ThreadClassName := String(Str);\r\n ThInfo^.ThreadAdvType := tatNormal;\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TDebuger.ProcessDbgTraceInfo(DebugEvent: PDebugEvent);\r\nvar\r\n ThData: PThreadData;\r\n I: Integer;\r\nbegin\r\n if AddProcessPointInfo(ptTraceInfo) then\r\n begin\r\n for I := 0 to FThreadList.Count - 1 do\r\n begin\r\n ThData := FThreadList[I];\r\n if ThData^.State = tsActive then\r\n AddThreadPointInfo(ThData, ptTraceInfo);\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TDebuger.ProcessDebugEvents;\r\nvar\r\n DebugEvent: PDebugEvent;\r\n ExceptionCode: DWORD;\r\n CallNextLoopIteration: LongBool;\r\nbegin\r\n DebugEvent := AllocMem(SizeOf(TDebugEvent));\r\n try\r\n repeat\r\n ContinueStatus := DBG_CONTINUE;\r\n\r\n DbgState := dsWait;\r\n FCurThreadData := nil;\r\n FCurThreadId := 0;\r\n\r\n if not WaitForDebugEvent(DebugEvent^, INFINITE) then\r\n begin\r\n DoDebugerFailed;\r\n Exit;\r\n end;\r\n\r\n DbgState := dsEvent;\r\n\r\n FCurThreadData := nil;\r\n FCurThreadId := TThreadId(DebugEvent^.dwThreadId);\r\n\r\n case DebugEvent^.dwDebugEventCode of\r\n EXCEPTION_DEBUG_EVENT:\r\n begin\r\n ExceptionCode := DebugEvent^.Exception.ExceptionRecord.ExceptionCode;\r\n\r\n case ExceptionCode of\r\n EXCEPTION_BREAKPOINT:\r\n ProcessExceptionBreakPoint(DebugEvent);\r\n\r\n EXCEPTION_SINGLE_STEP:\r\n ProcessExceptionSingleStep(DebugEvent);\r\n\r\n DBG_EXCEPTION:\r\n ProcessDbgException(DebugEvent);\r\n\r\n EXCEPTION_SET_THREAD_NAME:\r\n SetThreadName(DebugEvent);\r\n\r\n EXCEPTION_GUARD_PAGE:\r\n ProcessExceptionGuardPage(DebugEvent);\r\n else\r\n CallUnhandledExceptionEvents(CodeDataToExceptionCode(ExceptionCode), DebugEvent);\r\n end;\r\n end;\r\n\r\n CREATE_THREAD_DEBUG_EVENT:\r\n DoCreateThread(DebugEvent);\r\n\r\n CREATE_PROCESS_DEBUG_EVENT:\r\n DoCreateProcess(DebugEvent);\r\n\r\n EXIT_THREAD_DEBUG_EVENT:\r\n DoExitThread(DebugEvent);\r\n\r\n EXIT_PROCESS_DEBUG_EVENT:\r\n DoExitProcess(DebugEvent);\r\n\r\n LOAD_DLL_DEBUG_EVENT:\r\n DoLoadDll(DebugEvent);\r\n\r\n UNLOAD_DLL_DEBUG_EVENT:\r\n DoUnLoadDll(DebugEvent);\r\n\r\n OUTPUT_DEBUG_STRING_EVENT:\r\n DoDebugString(DebugEvent);\r\n\r\n RIP_EVENT:\r\n DoRip(DebugEvent);\r\n end;\r\n\r\n CallNextLoopIteration := ContinueDebugEvent(DebugEvent^.dwProcessId, DebugEvent^.dwThreadId, ContinueStatus);\r\n\r\n until not(CallNextLoopIteration) or (DebugEvent^.dwDebugEventCode = EXIT_PROCESS_DEBUG_EVENT);\r\n finally\r\n FreeMemory(DebugEvent);\r\n end;\r\n\r\n DoEndDebug;\r\nend;\r\n\r\nprocedure TDebuger.DoSetBreakpoint(const Address: Pointer; var SaveByte: Byte);\r\nvar\r\n Dummy: TSysUInt;\r\n OldProtect: DWORD;\r\nbegin\r\n Check(VirtualProtectEx(FProcessData.AttachedProcessHandle, Address, 1, PAGE_EXECUTE_READWRITE, OldProtect));\r\n\r\n Check(ReadProcessMemory(FProcessData.AttachedProcessHandle, Address, @SaveByte, 1, Dummy));\r\n Check(WriteProcessMemory(FProcessData.AttachedProcessHandle, Address, @BPOpcode, 1, Dummy));\r\n\r\n Check(VirtualProtectEx(FProcessData.AttachedProcessHandle, Address, 1, OldProtect, OldProtect));\r\nend;\r\n\r\nprocedure TDebuger.DoSetBreakpointF(const Address: Pointer; var SaveByte: Byte);\r\nvar\r\n Dummy: TSysUInt;\r\nbegin\r\n Check(ReadProcessMemory(FProcessData.AttachedProcessHandle, Address, @SaveByte, 1, Dummy));\r\n Check(WriteProcessMemory(FProcessData.AttachedProcessHandle, Address, @BPOpcode, 1, Dummy));\r\nend;\r\n\r\nfunction TDebuger.SetUserBreakpoint(Address: Pointer; const ThreadId: TThreadId = 0; const Description: string = ''): LongBool;\r\nvar\r\n Breakpoint: TBreakpoint;\r\n //OldProtect: DWORD;\r\n //Dummy: TSysUInt;\r\nbegin\r\n ZeroMemory(@Breakpoint, SizeOf(TBreakpoint));\r\n\r\n Breakpoint.bpType := btUser;\r\n Breakpoint.ThreadId := ThreadId;\r\n Breakpoint.Active := True;\r\n Breakpoint.Int3.Address := Address;\r\n Breakpoint.Description := ShortString(Description);\r\n\r\n DoSetBreakpoint(Address, Breakpoint.Int3.SaveByte);\r\n\r\n (*\r\n Check(VirtualProtectEx(FProcessData.AttachedProcessHandle, Address, 1, PAGE_READWRITE, OldProtect));\r\n try\r\n Check(ReadProcessMemory(FProcessData.AttachedProcessHandle, Address, @Breakpoint.Int3.ByteCode, 1, Dummy));\r\n Check(WriteProcessMemory(FProcessData.AttachedProcessHandle, Address, @BPOpcode, 1, Dummy));\r\n finally\r\n Check(VirtualProtectEx(FProcessData.AttachedProcessHandle, Address, 1, OldProtect, OldProtect));\r\n end;\r\n *)\r\n\r\n Result := AddNewBreakPoint(Breakpoint);\r\nend;\r\n\r\nprocedure TDebuger.SetBreakpoint(const Address: Pointer; var SaveByte: Byte);\r\nbegin\r\n DoSetBreakpointF(Address, SaveByte);\r\nend;\r\n\r\nprocedure TDebuger.SetCloseDebugProcess(const Value: LongBool);\r\nbegin\r\n FCloseDebugProcess := Value;\r\n DebugSetProcessKillOnExit(CloseDebugProcessOnFree);\r\nend;\r\n\r\nprocedure TDebuger.SetCodeTracking(const Value: LongBool);\r\nbegin\r\n FCodeTracking := Value;\r\nend;\r\n\r\nprocedure TDebuger.SetDbgState(const Value: TDbgState);\r\nconst\r\n _UpdateState: set of TDbgState = [dsNone, dsStarted, dsTrace, dsPause, dsStoping, dsStoped, dsDbgFail];\r\nvar\r\n Update: LongBool;\r\nbegin\r\n if Value <> FDbgState then\r\n begin\r\n Update := (FDbgState in _UpdateState) or (Value in _UpdateState);\r\n\r\n FDbgState := Value;\r\n\r\n if Assigned(FChangeDebugState) and Update then\r\n FChangeDebugState(Self);\r\n end;\r\nend;\r\n\r\nprocedure TDebuger.SetDbgTraceState(const Value: TDbgTraceState);\r\nbegin\r\n if Value <> FDbgTraceState then\r\n begin\r\n FDbgTraceState := Value;\r\n\r\n if Assigned(FChangeDebugState) then\r\n FChangeDebugState(Self);\r\n end;\r\nend;\r\n\r\nprocedure TDebuger.SetExceptionCallStack(const Value: LongBool);\r\nbegin\r\n FExceptionCallStack := Value;\r\nend;\r\n\r\nprocedure TDebuger.SetExceptionCheckMode(const Value: LongBool);\r\nbegin\r\n FExceptionCheckMode := Value;\r\nend;\r\n\r\nprocedure TDebuger.SetExceptionEvent(const Index: TExceptionCode; const Value: TDefaultExceptionEvent);\r\nbegin\r\n FExceptionEvents[Index] := Value;\r\nend;\r\n\r\nprocedure TDebuger.SetFlag(const ThreadID: TThreadId; Flag: DWORD; Value: LongBool);\r\nvar\r\n ThData: PThreadData;\r\n Context: TContext;\r\nbegin\r\n ThData := GetThreadData(ThreadId);\r\n if ThData <> nil then\r\n begin\r\n ZeroMemory(@Context, SizeOf(Context));\r\n Context.ContextFlags := CONTEXT_FULL;\r\n Check(GetThreadContext(ThData^.ThreadHandle, Context));\r\n if Value then\r\n Context.EFlags := Context.EFlags or Flag\r\n else\r\n Context.EFlags := Context.EFlags and not Flag;\r\n Check(SetThreadContext(ThData^.ThreadHandle, Context));\r\n end;\r\nend;\r\n\r\nprocedure TDebuger.SetHardwareBreakpoint(const ThreadId: TThreadID; Address: Pointer; Size: THWBPSize; Mode: THWBPMode; HWIndex: THWBPIndex;\r\n const Description: string);\r\nvar\r\n ThData: PThreadData;\r\nbegin\r\n ThData := GetThreadData(ThreadID);\r\n if ThData <> nil then\r\n begin\r\n ThData^.Breakpoint.Address[HWIndex] := Address;\r\n ThData^.Breakpoint.Size[HWIndex] := Size;\r\n ThData^.Breakpoint.Mode[HWIndex] := Mode;\r\n ThData^.Breakpoint.Description[HWIndex] := ShortString(Description);\r\n ThData^.Breakpoint.Active[HWIndex] := True;\r\n\r\n UpdateHardwareBreakpoints(ThreadId);\r\n end;\r\nend;\r\n\r\nfunction TDebuger.SetMemoryBreakpoint(Address: Pointer; Size: Cardinal; BreakOnWrite: LongBool; const Description: string): LongBool;\r\nvar\r\n Breakpoint: TBreakpoint;\r\n MBI: TMemoryBasicInformation; // TODO: GetMemory\r\n Index: Integer;\r\nbegin\r\n Index := GetMBPIndex(Address);\r\n if (Index >= 0) and (FBreakpointList[Index].bpType = btMemory) then\r\n begin\r\n MBI.BaseAddress := FBreakpointList[Index].Memory.RegionStart;\r\n MBI.RegionSize := FBreakpointList[Index].Memory.RegionSize;\r\n MBI.Protect := FBreakpointList[Index].Memory.PreviosRegionProtect;\r\n end\r\n else\r\n Check(VirtualQueryEx(ProcessData.AttachedProcessHandle, Address, MBI, SizeOf(TMemoryBasicInformation)) > 0);\r\n ZeroMemory(@Breakpoint, SizeOf(TBreakpoint));\r\n Breakpoint.bpType := btMemory;\r\n Breakpoint.Description := ShortString(Description);\r\n Breakpoint.Memory.Address := Address;\r\n Breakpoint.Memory.Size := Size;\r\n Breakpoint.Memory.BreakOnWrite := BreakOnWrite;\r\n Breakpoint.Memory.RegionStart := MBI.BaseAddress;\r\n Breakpoint.Memory.RegionSize := MBI.RegionSize;\r\n if Size = 0 then\r\n Inc(Size);\r\n Check(VirtualProtectEx(FProcessData.AttachedProcessHandle, Address, Size, MBI.Protect or PAGE_GUARD, Breakpoint.Memory.PreviosRegionProtect));\r\n if Index >= 0 then\r\n Breakpoint.Memory.PreviosRegionProtect := MBI.Protect;\r\n Result := AddNewBreakPoint(Breakpoint);\r\nend;\r\n\r\nprocedure TDebuger.SetPerfomanceMode(const Value: LongBool);\r\nbegin\r\n if FPerfomanceMode <> Value then\r\n begin\r\n FPerfomanceMode := Value;\r\n (*\r\n if FPerfomanceMode then\r\n FDbgPerfomanceThread.Suspended := False\r\n else\r\n FDbgPerfomanceThread.Suspended := True;\r\n *)\r\n end;\r\nend;\r\n\r\nprocedure TDebuger.SetRegisters(const ThreadID: TThreadId; var Context: TContext);\r\nvar\r\n ThData: PThreadData;\r\nbegin\r\n ThData := GetThreadData(ThreadId);\r\n if ThData <> nil then\r\n begin\r\n Context.ContextFlags := CONTEXT_FULL;\r\n Check(SetThreadContext(ThData^.ThreadHandle, Context));\r\n end;\r\nend;\r\n\r\nprocedure TDebuger.SetSamplingMethod(const Value: LongBool);\r\nbegin\r\n FSamplingMethod := Value;\r\nend;\r\n\r\nprocedure TDebuger.SetSingleStepMode(ThData: PThreadData; const RestoreEIPAfterBP: LongBool);\r\nbegin\r\n // !!! ThData^.Context \r\n if RestoreEIPAfterBP then\r\n Dec(ThData^.Context^.Eip);\r\n\r\n ThData^.Context^.EFlags := ThData^.Context^.EFlags or EFLAGS_TF;\r\n\r\n Check(SetThreadContext(ThData^.ThreadHandle, ThData^.Context^));\r\nend;\r\n\r\nprocedure TDebuger.SetSingleStepMode(const ThreadID: TThreadId; const RestoreEIPAfterBP: LongBool);\r\nvar\r\n ThData: PThreadData;\r\nbegin\r\n ThData := GetThreadData(ThreadID);\r\n\r\n ZeroMemory(ThData^.Context, SizeOf(TContext));\r\n\r\n ThData^.Context^.ContextFlags := CONTEXT_FULL;\r\n Check(GetThreadContext(ThData^.ThreadHandle, ThData^.Context^));\r\n\r\n if RestoreEIPAfterBP then\r\n Dec(ThData^.Context^.Eip);\r\n\r\n ThData^.Context^.EFlags := ThData^.Context^.EFlags or EFLAGS_TF;\r\n\r\n Check(SetThreadContext(ThData^.ThreadHandle, ThData^.Context^));\r\nend;\r\n\r\nfunction TDebuger.SetThreadInfo(const ThreadId: TThreadId): PThreadAdvInfo;\r\nbegin\r\n Result := GetThreadInfo(ThreadId);\r\n if Result = Nil then\r\n Result := AddThreadInfo(ThreadId);\r\nend;\r\n\r\nprocedure TDebuger.SetThreadName(DebugEvent: PDebugEvent);\r\nvar\r\n StrAddr: Pointer;\r\n Str: AnsiString;\r\n ThreadAdvInfo: PThreadAdvInfo;\r\nbegin\r\n StrAddr := Pointer(DebugEvent^.Exception.ExceptionRecord.ExceptionInformation[1]);\r\n Str := ReadStringA(StrAddr, -1);\r\n if Str <> '' then\r\n begin\r\n ThreadAdvInfo := SetThreadInfo(DebugEvent^.dwThreadId);\r\n\r\n ThreadAdvInfo^.ThreadName := String(Str);\r\n\r\n if ThreadAdvInfo^.ThreadName <> '' then\r\n begin\r\n if Copy(ThreadAdvInfo^.ThreadName, 1, 3) = _SERVICE_THREAD_PREFIX then\r\n ThreadAdvInfo^.ThreadAdvType := tatService\r\n else\r\n ThreadAdvInfo^.ThreadAdvType := tatNormal;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TDebuger.SetTrackSystemUnits(const Value: LongBool);\r\nbegin\r\n FTrackSystemUnits := Value;\r\nend;\r\n\r\nfunction TDebuger.StopDebug: LongBool;\r\nbegin\r\n Result := False;\r\n\r\n if FDbgState = dsPause then\r\n ContinueDebug;\r\n\r\n if Active then\r\n begin\r\n UnLoadDbgHookDll(ProcessData.AttachedProcessHandle, 'DbgHook32.dll');\r\n\r\n if CloseDebugProcessOnFree then\r\n begin\r\n if FProcessData.CreatedProcessHandle <> 0 then\r\n Result := TerminateProcess(FProcessData.CreatedProcessHandle, 0);\r\n end\r\n else\r\n Result := DebugActiveProcessStop(Cardinal(FProcessData.ProcessID));\r\n end;\r\n\r\n if FProcessData.CreatedProcessHandle <> 0 then\r\n begin\r\n CloseHandle(FProcessData.CreatedProcessHandle);\r\n FProcessData.CreatedProcessHandle := 0;\r\n end;\r\n\r\n if FProcessData.CreatedThreadHandle <> 0 then\r\n begin\r\n CloseHandle(FProcessData.CreatedThreadHandle);\r\n FProcessData.CreatedThreadHandle := 0;\r\n end;\r\n\r\n if FProcessData.AttachedFileHandle <> 0 then\r\n begin\r\n CloseHandle(FProcessData.AttachedFileHandle);\r\n FProcessData.AttachedFileHandle := 0;\r\n end;\r\nend;\r\n\r\nprocedure TDebuger.ToggleBreakpoint(Index: Integer; Active: LongBool);\r\nbegin\r\n CheckBreakpointIndex(Index);\r\n case FBreakpointList[Index].bpType of\r\n btUser:\r\n ToggleInt3Breakpoint(Index, Active);\r\n btMemory:\r\n ToggleMemoryBreakpoint(Index, Active);\r\n end;\r\nend;\r\n\r\nprocedure TDebuger.ToggleHardwareBreakpoint(const ThreadId: TThreadID; Index: THWBPIndex; Active: LongBool);\r\nvar\r\n ThData: PThreadData;\r\nbegin\r\n ThData := GetThreadData(ThreadID);\r\n if ThData <> nil then\r\n begin\r\n if ThData^.Breakpoint.Active[Index] = Active then\r\n Exit;\r\n ThData^.Breakpoint.Active[Index] := Active;\r\n UpdateHardwareBreakpoints(ThreadId);\r\n end;\r\nend;\r\n\r\n(*\r\nprocedure TDebuger.DoRemoveBreakpoint(const Address: Pointer; const SaveByte: Byte);\r\nvar\r\n Dummy: TSysUInt;\r\n OldProtect: DWORD;\r\nbegin\r\n Check(VirtualProtectEx(FProcessData.AttachedProcessHandle, Address, 1, PAGE_READWRITE, OldProtect));\r\n try\r\n Check(WriteProcessMemory(FProcessData.AttachedProcessHandle, Address, @SaveByte, 1, Dummy));\r\n finally\r\n Check(VirtualProtectEx(FProcessData.AttachedProcessHandle, Address, 1, OldProtect, OldProtect));\r\n end;\r\nend;\r\n*)\r\n\r\nprocedure TDebuger.DoRemoveBreakpointF(const Address: Pointer; const SaveByte: Byte);\r\nvar\r\n Dummy: TSysUInt;\r\nbegin\r\n Check(WriteProcessMemory(FProcessData.AttachedProcessHandle, Address, @SaveByte, 1, Dummy));\r\nend;\r\n\r\nprocedure TDebuger.ToggleInt3Breakpoint(Index: Integer; Active: LongBool);\r\nvar\r\n OldProtect: DWORD;\r\n Dummy: TSysUInt;\r\nbegin\r\n CheckBreakpointIndex(Index);\r\n\r\n if FBreakpointList[Index].bpType <> btUser then\r\n Exit;\r\n\r\n if FBreakpointList[Index].Active = Active then\r\n Exit;\r\n\r\n Check(VirtualProtectEx(FProcessData.AttachedProcessHandle, FBreakpointList[Index].Int3.Address, 1, PAGE_READWRITE, OldProtect));\r\n try\r\n if Active then\r\n Check(WriteProcessMemory(FProcessData.AttachedProcessHandle, FBreakpointList[Index].Int3.Address, @BPOpcode, 1, Dummy))\r\n else\r\n Check(WriteProcessMemory(FProcessData.AttachedProcessHandle, FBreakpointList[Index].Int3.Address, @FBreakpointList[Index].Int3.SaveByte, 1, Dummy));\r\n finally\r\n Check(VirtualProtectEx(FProcessData.AttachedProcessHandle, FBreakpointList[Index].Int3.Address, 1, OldProtect, OldProtect));\r\n end;\r\n\r\n FBreakpointList[Index].Active := Active;\r\nend;\r\n\r\nprocedure TDebuger.ToggleMemoryBreakpoint(Index: Integer; Active: LongBool);\r\nvar\r\n Dummy, TmpSize: DWORD;\r\nbegin\r\n CheckBreakpointIndex(Index);\r\n if FBreakpointList[Index].bpType <> btMemory then\r\n Exit;\r\n if FBreakpointList[Index].Active = Active then\r\n Exit;\r\n TmpSize := FBreakpointList[Index].Memory.Size;\r\n if TmpSize = 0 then\r\n Inc(TmpSize);\r\n if Active then\r\n Check(VirtualProtectEx(FProcessData.AttachedProcessHandle, FBreakpointList[Index].Memory.Address, TmpSize,\r\n FBreakpointList[Index].Memory.PreviosRegionProtect or PAGE_GUARD, Dummy))\r\n else\r\n Check(VirtualProtectEx(FProcessData.AttachedProcessHandle, FBreakpointList[Index].Memory.Address, TmpSize,\r\n FBreakpointList[Index].Memory.PreviosRegionProtect, Dummy));\r\n FBreakpointList[Index].Active := Active;\r\nend;\r\n\r\nfunction TDebuger.TraceDebug(const TraceType: TDbgTraceState): LongBool;\r\nbegin\r\n Result := False;\r\n\r\n case TraceType of\r\n dtsContinue:\r\n Result := ContinueDebug;\r\n dtsPause:\r\n Result := PauseDebug;\r\n dtsStepIn:;\r\n dtsStepOver:;\r\n dtsStepOut:;\r\n end;\r\n\r\n SwitchToThread;\r\nend;\r\n\r\nconst\r\n DR7_SET_LOC_DR0 = $01;\r\n DR7_SET_GLB_DR0 = $02;\r\n\r\n DR7_SET_LOC_DR1 = $04;\r\n DR7_SET_GLB_DR1 = $08;\r\n\r\n DR7_SET_LOC_DR2 = $10;\r\n DR7_SET_GLB_DR2 = $20;\r\n\r\n DR7_SET_LOC_DR3 = $40;\r\n DR7_SET_GLB_DR3 = $80;\r\n\r\n DR7_SET_LOC_ON = $100;\r\n DR7_SET_GLB_ON = $200;\r\n\r\n DR_On: array [THWBPIndex] of DWORD =\r\n (DR7_SET_LOC_DR0, DR7_SET_LOC_DR1, DR7_SET_LOC_DR2, DR7_SET_LOC_DR3);\r\n\r\n DR7_PROTECT = $2000;\r\n\r\n DR_SIZE_BYTE = 0;\r\n DR_SIZE_WORD = 1;\r\n DR_SIZE_DWORD = 3;\r\n\r\n DR_MODE_E = 0;\r\n DR_MODE_W = 1;\r\n DR_MODE_I = 2;\r\n DR_MODE_R = 3;\r\n\r\n DR7_MODE_DR0_E = DR_MODE_E shl 16;\r\n DR7_MODE_DR0_W = DR_MODE_W shl 16;\r\n DR7_MODE_DR0_I = DR_MODE_I shl 16;\r\n DR7_MODE_DR0_R = DR_MODE_R shl 16;\r\n\r\n DR7_SIZE_DR0_B = DR_SIZE_BYTE shl 18;\r\n DR7_SIZE_DR0_W = DR_SIZE_WORD shl 18;\r\n DR7_SIZE_DR0_D = DR_SIZE_DWORD shl 18;\r\n\r\n DR7_MODE_DR1_E = DR_MODE_E shl 20;\r\n DR7_MODE_DR1_W = DR_MODE_W shl 20;\r\n DR7_MODE_DR1_I = DR_MODE_I shl 20;\r\n DR7_MODE_DR1_R = DR_MODE_R shl 20;\r\n\r\n DR7_SIZE_DR1_B = DR_SIZE_BYTE shl 22;\r\n DR7_SIZE_DR1_W = DR_SIZE_WORD shl 22;\r\n DR7_SIZE_DR1_D = DR_SIZE_DWORD shl 22;\r\n\r\n DR7_MODE_DR2_E = DR_MODE_E shl 24;\r\n DR7_MODE_DR2_W = DR_MODE_W shl 24;\r\n DR7_MODE_DR2_I = DR_MODE_I shl 24;\r\n DR7_MODE_DR2_R = DR_MODE_R shl 24;\r\n\r\n DR7_SIZE_DR2_B = DR_SIZE_BYTE shl 26;\r\n DR7_SIZE_DR2_W = DR_SIZE_WORD shl 26;\r\n DR7_SIZE_DR2_D = DR_SIZE_DWORD shl 26;\r\n\r\n DR7_MODE_DR3_E = DR_MODE_E shl 28;\r\n DR7_MODE_DR3_W = DR_MODE_W shl 28;\r\n DR7_MODE_DR3_I = DR_MODE_I shl 28;\r\n DR7_MODE_DR3_R = DR_MODE_R shl 28;\r\n\r\n DR7_SIZE_DR3_B = DR_SIZE_BYTE shl 30;\r\n DR7_SIZE_DR3_W = DR_SIZE_WORD shl 30;\r\n DR7_SIZE_DR3_D = $C0000000; // DR_SIZE_DWORD shl 30;\r\n\r\n DR_Mode: array [THWBPIndex] of array [THWBPMode] of DWORD = (\r\n (DR7_MODE_DR0_E, DR7_MODE_DR0_W, DR7_MODE_DR0_I, DR7_MODE_DR0_R),\r\n (DR7_MODE_DR1_E, DR7_MODE_DR1_W, DR7_MODE_DR1_I, DR7_MODE_DR1_R),\r\n (DR7_MODE_DR2_E, DR7_MODE_DR2_W, DR7_MODE_DR2_I, DR7_MODE_DR2_R),\r\n (DR7_MODE_DR3_E, DR7_MODE_DR3_W, DR7_MODE_DR3_I, DR7_MODE_DR3_R)\r\n );\r\n\r\n DR_Size: array [THWBPIndex] of array [THWBPSize] of DWORD = (\r\n (DR7_SIZE_DR0_B, DR7_SIZE_DR0_W, DR7_SIZE_DR0_D),\r\n (DR7_SIZE_DR1_B, DR7_SIZE_DR1_W, DR7_SIZE_DR1_D),\r\n (DR7_SIZE_DR2_B, DR7_SIZE_DR2_W, DR7_SIZE_DR2_D),\r\n (DR7_SIZE_DR3_B, DR7_SIZE_DR3_W, DR7_SIZE_DR3_D)\r\n );\r\n\r\nfunction TDebuger.UpdateCurThreadContext(const ContextFlags: Cardinal = CONTEXT_FULL): LongBool;\r\nbegin\r\n Result := True;\r\n\r\n if (FCurThreadData = nil) or (FCurThreadData^.Context^.ContextFlags <> ContextFlags) then\r\n begin\r\n FCurThreadData := UpdateThreadContext(FCurThreadId, ContextFlags);\r\n Result := Assigned(FCurThreadData);\r\n end;\r\nend;\r\n\r\nprocedure TDebuger.UpdateHardwareBreakpoints(const ThreadID: TThreadId);\r\nvar\r\n Context: PContext;\r\n I: THWBPIndex;\r\n ThData: PThreadData;\r\n Breakpoint: PHardwareBreakpoint;\r\nbegin\r\n ThData := GetThreadData(ThreadID);\r\n if ThData = nil then\r\n Exit;\r\n\r\n Context := AllocMem(SizeOf(TContext));\r\n try\r\n Context.ContextFlags := CONTEXT_DEBUG_REGISTERS;\r\n\r\n Breakpoint := ThData^.Breakpoint;\r\n\r\n for I := 0 to 3 do\r\n begin\r\n if not Breakpoint.Active[I] then\r\n Continue;\r\n\r\n if Breakpoint.Address[I] <> nil then\r\n begin\r\n Context.Dr7 := Context.Dr7 or DR7_SET_LOC_ON;\r\n\r\n case I of\r\n 0: Context.Dr0 := DWORD(Breakpoint.Address[I]);\r\n 1: Context.Dr1 := DWORD(Breakpoint.Address[I]);\r\n 2: Context.Dr2 := DWORD(Breakpoint.Address[I]);\r\n 3: Context.Dr3 := DWORD(Breakpoint.Address[I]);\r\n end;\r\n\r\n Context.Dr7 := Context.Dr7 or DR_On[I];\r\n Context.Dr7 := Context.Dr7 or DR_Mode[I, Breakpoint.Mode[I]];\r\n Context.Dr7 := Context.Dr7 or DR_Size[I, Breakpoint.Size[I]];\r\n end;\r\n end;\r\n\r\n Check(SetThreadContext(ThData^.ThreadHandle, Context^));\r\n finally\r\n FreeMem(Context);\r\n end;\r\nend;\r\n\r\nfunction TDebuger.UpdateThreadContext(ThreadData: PThreadData; const ContextFlags: Cardinal = CONTEXT_FULL): LongBool;\r\nbegin\r\n Result := False;\r\n\r\n if ThreadData <> Nil then\r\n begin\r\n //ZeroMemory(ThreadData^.Context, SizeOf(TContext));\r\n\r\n ThreadData^.Context^.ContextFlags := ContextFlags;\r\n Result := GetThreadContext(ThreadData^.ThreadHandle, ThreadData^.Context^);\r\n end;\r\nend;\r\n\r\nfunction TDebuger.UpdateThreadContext(const ThreadID: TThreadId; const ContextFlags: Cardinal = CONTEXT_FULL): PThreadData;\r\nbegin\r\n Result := GetThreadData(ThreadId);\r\n if Result <> nil then\r\n if not UpdateThreadContext(Result, ContextFlags) then\r\n RaiseDebugCoreException();\r\nend;\r\n\r\nfunction TDebuger.WriteData(AddrPrt, DataPtr: Pointer; const DataSize: Cardinal): LongBool;\r\nvar\r\n Dummy: TSysUInt;\r\nbegin\r\n Result :=\r\n WriteProcessMemory(FProcessData.AttachedProcessHandle, AddrPrt, DataPtr, DataSize, Dummy) and (Dummy = DataSize);\r\n\r\n if Result then\r\n Result := FlushInstructionCache(FProcessData.AttachedProcessHandle, AddrPrt, DataSize);\r\nend;\r\n\r\ninitialization\r\n\r\nfinalization\r\n if gvDebuger <> Nil then\r\n FreeAndNil(gvDebuger);\r\nend.\r\n" }, { "path": "DebugerTypes.pas", "content": "unit DebugerTypes;\r\n\r\ninterface\r\n\r\nuses System.SysUtils, WinApi.Windows, System.Classes, JclPeImage, System.SyncObjs, ClassUtils, DbgHookTypes, System.Contnrs,\r\n System.Generics.Collections, Collections.Dictionaries, Collections.Queues, CollectList,\r\n uSharedObject;\r\n\r\ntype\r\n TSysUInt = NativeUInt;\r\n PReal48 = ^Real48;\r\n PReal = ^Real;\r\n\r\n\r\nconst\r\n EXCEPTION_SET_THREAD_NAME = $406D1388;\r\n\r\nconst\r\n _SERVICE_THREAD_PREFIX = '###';\r\n\r\n// \r\nconst\r\n EFLAGS_CF = $001;\r\n EFLAGS_PF = $004;\r\n EFLAGS_AF = $010;\r\n EFLAGS_ZF = $040;\r\n EFLAGS_SF = $080;\r\n EFLAGS_TF = $100;\r\n EFLAGS_IF = $200;\r\n EFLAGS_DF = $400;\r\n EFLAGS_OF = $800;\r\n\r\nconst\r\n BPOpcode: Byte = $CC;\r\n\r\ntype\r\n TThreadId = type Cardinal;\r\n TProcessId = type Cardinal;\r\n\r\n EDebugCoreException = class(Exception);\r\n\r\n // \r\n TResumeAction = (\r\n raRun, // \r\n raTraceInto, // \r\n raStepOver, // \r\n raRunUntilReturn, // \r\n raStop // \r\n );\r\n\r\n // \r\n TCreateThreadEvent = procedure(Sender: TObject; ThreadId: TThreadId; Data: PCreateThreadDebugInfo) of object;\r\n TCreateProcessEvent = procedure(Sender: TObject; ProcessId: TProcessId; Data: PCreateProcessDebugInfo) of object;\r\n TExitThreadEvent = procedure(Sender: TObject; ThreadId: TThreadId; Data: PExitThreadDebugInfo) of object;\r\n TExitProcessEvent = procedure(Sender: TObject; ProcessId: TProcessId; Data: PExitProcessDebugInfo) of object;\r\n TLoadDllEvent = procedure(Sender: TObject; ThreadId: TThreadId; Data: PLoadDLLDebugInfo) of object;\r\n TUnLoadDllEvent = procedure(Sender: TObject; ThreadId: TThreadId; Data: PUnloadDLLDebugInfo) of object;\r\n TDebugStringEvent = procedure(Sender: TObject; ThreadId: TThreadId; Data: POutputDebugStringInfo) of object;\r\n TRipEvent = procedure(Sender: TObject; ThreadId: TThreadId; Data: PRIPInfo) of object;\r\n TDbgLogEvent = procedure(Sender: TObject; ThreadId: TThreadId; const Data: String) of object;\r\n\r\n // \r\n TDefaultExceptionEvent = procedure(Sender: TObject; ThreadId: TThreadId; ExceptionRecord: PExceptionRecord) of object;\r\n TBreakPointEvent = procedure(Sender: TObject; ThreadId: TThreadId; ExceptionRecord: PExceptionRecord;\r\n BreakPointIndex: Integer; var ReleaseBreakpoint: LongBool) of object;\r\n\r\n // ( ,\r\n // )\r\n\r\n TExceptionCode = (ecUnknown, ecBreakpoint, ecSingleStep, ecCtrlC, ecNonContinuable, ecGuard, ecSetThreadName);\r\n TExceptionEvents = array[TExceptionCode] of TDefaultExceptionEvent;\r\n\r\n // ( )\r\n\r\n TBreakpointType = (\r\n btUser,\r\n btTemp,\r\n btCodeTrack,\r\n btMemory\r\n );\r\n\r\n // \r\n\r\n TInt3Breakpoint = record\r\n Address: Pointer;\r\n SaveByte: Byte;\r\n end;\r\n\r\n TMemotyBreakPoint = record\r\n Address: Pointer;\r\n Size: Cardinal;\r\n BreakOnWrite: LongBool;\r\n RegionStart: Pointer;\r\n RegionSize: Cardinal;\r\n PreviosRegionProtect: Cardinal;\r\n end;\r\n\r\n PBreakpoint = ^TBreakpoint;\r\n TBreakpoint = packed record\r\n bpType: TBreakpointType;\r\n ThreadId: TThreadId;\r\n Description: ShortString;\r\n Active: LongBool;\r\n case Integer of\r\n 0: (Int3: TInt3Breakpoint);\r\n 1: (Memory: TMemotyBreakPoint);\r\n end;\r\n\r\n TBreakpointList = array of TBreakpoint;\r\n\r\n TTrackBreakpointType = (tbTrackFunc, tbMemInfo);\r\n TTrackBreakpointTypes = set of TTrackBreakpointType;\r\n\r\n PTrackBreakpoint = ^TTrackBreakpoint;\r\n TTrackBreakpoint = record\r\n FuncInfo: TObject;\r\n SaveByte: Byte;\r\n BPType: TTrackBreakpointTypes;\r\n end;\r\n\r\n TTrackBreakpointList = TPointerDictionary;\r\n\r\n PTrackRETBreakpoint = ^TTrackRETBreakpoint;\r\n TTrackRETBreakpoint = record\r\n FuncInfo: TObject;\r\n Count: Cardinal;\r\n SaveByte: Byte;\r\n BPType: TTrackBreakpointTypes;\r\n end;\r\n\r\n TTrackRETBreakpointList = TPointerDictionary;\r\n\r\n THWBPIndex = 0..3;\r\n THWBPSize = (hsByte, hdWord, hsDWord);\r\n THWBPMode = (hmExecute, hmWrite, hmIO, hmReadWrite);\r\n\r\n PHardwareBreakpoint = ^THardwareBreakpoint;\r\n THardwareBreakpoint = packed record\r\n Address: array [THWBPIndex] of Pointer;\r\n Size: array [THWBPIndex] of THWBPSize;\r\n Mode: array [THWBPIndex] of THWBPMode;\r\n Description: array [THWBPIndex] of ShortString;\r\n Active: array [THWBPIndex] of LongBool;\r\n end;\r\n\r\n (*\r\n PStackPoint = ^TStackPoint;\r\n TStackPoint = packed record\r\n EIP: Pointer;\r\n EBP: Pointer;\r\n end;\r\n\r\n TStackPointList = Array of TStackPoint;\r\n *)\r\n\r\n TDbgInfoStack = array of Pointer;\r\n\r\n PDbgInfoStackRec = ^TDbgInfoStackRec;\r\n TDbgInfoStackRec = record\r\n Stack: TDbgInfoStack;\r\n end;\r\n\r\n TMemAction = (maGetMem = 0, maFreeMem);\r\n\r\n PMemInfo = ^TMemInfo;\r\n TMemInfo = packed record\r\n //PerfIdx: Cardinal;\r\n case MemAction: TMemAction of\r\n maGetMem: (\r\n GetMemPtr: Pointer;\r\n GetMemSize: Cardinal;\r\n //Stack: TStackPointList;\r\n );\r\n maFreeMem: (\r\n FreeMemPtr: Pointer;\r\n //ObjType: Cardinal;\r\n );\r\n end;\r\n\r\n //PGetMemInfo = ^TGetMemInfo;\r\n TGetMemInfo = class(TSharedObject)\r\n public\r\n PerfIdx: Integer;\r\n ObjAddr: Pointer;\r\n Size: Integer;\r\n Stack: TDbgInfoStack;\r\n ObjectType: String;\r\n\r\n function GetObjectType: String;\r\n procedure CheckObjectType;\r\n procedure LoadStack(const DbgStack: PDbgHookInfoStack);\r\n end;\r\n\r\n TGetMemInfoList = TObjectDictionary;\r\n TGetMemInfoItem = TPair;\r\n\r\n PDbgSyncObjsInfoEx = ^TDbgSyncObjsInfoEx;\r\n TDbgSyncObjsInfoEx = packed record\r\n public\r\n procedure LoadStack(const DbgStack: PDbgHookInfoStack);\r\n procedure Init(const SyncObjsInfo: PDbgSyncObjsInfo);\r\n public\r\n Id: NativeUInt;\r\n ThreadId: TThreadId;\r\n CurTime: Int64;\r\n Stack: TDbgInfoStack;\r\n SyncObjsStateType: TDbgSyncObjsStateType;\r\n case SyncObjsType: TDbgSyncObjsType of\r\n soUnknown:\r\n ();\r\n soSleep:\r\n (\r\n MSec: NativeUInt;\r\n );\r\n soWaitForSingleObject:\r\n (\r\n Handle: THandle;\r\n );\r\n soWaitForMultipleObjects:\r\n (\r\n Handles: PWOHandleArray;\r\n );\r\n soEnterCriticalSection,\r\n soLeaveCriticalSection,\r\n soInCriticalSection:\r\n (\r\n CS: PRTLCriticalSection;\r\n OwningThreadId: TThreadId;\r\n );\r\n soSendMessage:\r\n ();\r\n end;\r\n\r\n PSyncObjsInfo = ^RSyncObjsInfo;\r\n RSyncObjsInfo = record\r\n PerfIdx: Integer;\r\n Link: PSyncObjsInfo; // \r\n LinkExt: PSyncObjsInfo; // \r\n SyncObjsInfo: TDbgSyncObjsInfoEx;\r\n public\r\n function WaitTime: Int64;\r\n function IsShortLock: LongBool;\r\n\r\n function Enter: PSyncObjsInfo; inline;\r\n function Leave: PSyncObjsInfo; inline;\r\n\r\n function EnterExt: PSyncObjsInfo;\r\n function LeaveExt: PSyncObjsInfo;\r\n end;\r\n\r\n TSyncObjsInfoList = TBaseCollectList; // TCollectList;\r\n\r\n PRPSyncObjsInfo = ^RPSyncObjsInfo;\r\n RPSyncObjsInfo = record\r\n SyncObjsInfo: PSyncObjsInfo;\r\n end;\r\n\r\n TSyncObjsInfoListByID = TDictionary;\r\n TSyncObjsInfoListByCS = TDictionary;\r\n\r\n // SyncObjs, \r\n TFuncSyncObjsInfoList = TCollectList;\r\n\r\n PThreadData = ^TThreadData;\r\n\r\n TExceptInfo = class\r\n public\r\n ThreadID: TThreadId;\r\n Address: Pointer;\r\n Frame: Pointer;\r\n ExceptionName: String;\r\n Message: String;\r\n Stack: TList;\r\n\r\n constructor Create(DebugEvent: PDebugEvent); overload;\r\n constructor Create(ThreadData: PThreadData); overload;\r\n constructor Create(); overload;\r\n\r\n destructor Destroy; override;\r\n end;\r\n\r\n TSyncObjsInfo = class\r\n public\r\n SyncObjsType: TDbgSyncObjsType;\r\n SyncObjsStateType: TDbgSyncObjsStateType;\r\n PerfIdx: Cardinal;\r\n Id: NativeUInt;\r\n Data: NativeUInt;\r\n Link: TSyncObjsInfo;\r\n\r\n constructor Create(const DebugEvent: PDebugEvent; const ThreadData: PThreadData; const APerfIdx: Cardinal);\r\n destructor Destroy; override;\r\n\r\n function FindLink(const ThreadData: PThreadData): TSyncObjsInfo;\r\n end;\r\n\r\n TPerfInfo = class\r\n public\r\n DeltaTickCPU: UInt64; // CPU\r\n DeltaTime: UInt64;\r\n //StackPoint: TStackPointList;\r\n end;\r\n\r\n TDbgPointType = (ptNone = 0, ptWait, ptStart, ptStop, ptException, ptPerfomance, ptThreadInfo, ptMemoryInfo,\r\n ptSyncObjsInfo, ptTraceInfo);\r\n\r\n PThreadPoint = ^TThreadPoint;\r\n TThreadPoint = packed record\r\n public\r\n procedure Clear;\r\n public\r\n PerfIdx: Cardinal;\r\n case PointType: TDbgPointType of\r\n ptStart: ();\r\n ptStop: ();\r\n ptException: (\r\n ExceptInfo: TExceptInfo;\r\n );\r\n ptPerfomance: (\r\n PerfInfo: TPerfInfo;\r\n );\r\n ptMemoryInfo: (\r\n );\r\n ptSyncObjsInfo: (\r\n SyncObjsInfo: TSyncObjsInfo;\r\n );\r\n end;\r\n\r\n TThreadAdvType = (tatUnknown = 0, tatService, tatNormal);\r\n\r\n PThreadAdvInfo = ^TThreadAdvInfo;\r\n TThreadAdvInfo = record\r\n ThreadId: TThreadId;\r\n ThreadParentId: TThreadId;\r\n ThreadData: PThreadData;\r\n ThreadClassName: String;\r\n ThreadName: String;\r\n ThreadAdvType: TThreadAdvType;\r\n\r\n function AsString: String;\r\n end;\r\n\r\n TCallFuncInfo = class\r\n FuncInfo: TObject;\r\n LineNo: Cardinal;\r\n CallCount: UInt64;\r\n Data: UInt64;\r\n public\r\n property Elapsed: UInt64 read Data write Data;\r\n property Size: UInt64 read Data write Data;\r\n end;\r\n\r\n TCallFuncCounter = class(TObjectDictionary)\r\n private\r\n function AddNewCallFunc(const Addr: Pointer): TCallFuncInfo;\r\n public\r\n function AddCallFunc(const Addr: Pointer): TCallFuncInfo;\r\n function GetCallFunc(const Addr: Pointer): TCallFuncInfo;\r\n end;\r\n TCallFuncCounterPair = TPair;\r\n\r\n TTrackUnitInfo = class;\r\n TTrackFuncInfo = class;\r\n\r\n TTrackUnitInfoBaseList = TObjectDictionary;\r\n TTrackFuncInfoBaseList = TObjectDictionary;\r\n\r\n TTrackUnitInfo = class\r\n private\r\n FUnitInfo: TObject;\r\n FFuncInfoList: TTrackFuncInfoBaseList;\r\n\r\n FCallCount: Int64;\r\n public\r\n constructor Create(AUnitInfo: TObject);\r\n destructor Destroy; override;\r\n\r\n procedure IncCallCount; inline;\r\n\r\n property UnitInfo: TObject read FUnitInfo;\r\n\r\n property FuncInfoList: TTrackFuncInfoBaseList read FFuncInfoList;\r\n\r\n property CallCount: Int64 read FCallCount;\r\n end;\r\n\r\n TCodeTrackUnitInfo = class(TTrackUnitInfo)\r\n private\r\n FElapsed: Int64;\r\n public\r\n procedure GrowElapsed(const Value: Int64); inline;\r\n\r\n // TODO: \r\n // property Elapsed: UInt64 read FElapsed;\r\n end;\r\n\r\n TMemInfoTrackUnitInfo = class(TTrackUnitInfo)\r\n private\r\n FCurCount: Int64;\r\n FSize: Int64;\r\n public\r\n procedure GrowSize(const Value: Int64); inline;\r\n\r\n procedure IncCurCount; inline;\r\n procedure DecCurCount; inline;\r\n\r\n property CurCount: Int64 read FCurCount;\r\n end;\r\n\r\n TSyncObjsTrackUnitInfo = class(TTrackUnitInfo);\r\n\r\n TTrackUnitInfoList = class(TTrackUnitInfoBaseList)\r\n protected\r\n function CreateTrackUnitInfo(const UnitInfo: TObject): TTrackUnitInfo; virtual;\r\n public\r\n function GetTrackUnitInfo(const UnitInfo: TObject): TTrackUnitInfo;\r\n procedure CheckTrackFuncInfo(TrackFuncInfo: TTrackFuncInfo);\r\n end;\r\n TTrackUnitInfoPair = TPair;\r\n\r\n TCodeTrackUnitInfoList = class(TTrackUnitInfoList)\r\n protected\r\n function CreateTrackUnitInfo(const UnitInfo: TObject): TTrackUnitInfo; override;\r\n public\r\n end;\r\n\r\n TMemInfoTrackUnitInfoList = class(TTrackUnitInfoList)\r\n protected\r\n function CreateTrackUnitInfo(const UnitInfo: TObject): TTrackUnitInfo; override;\r\n public\r\n procedure LoadStack(const GetMemInfo: TGetMemInfo);\r\n end;\r\n\r\n TSyncObjsTrackUnitInfoList = class(TTrackUnitInfoList)\r\n protected\r\n function CreateTrackUnitInfo(const UnitInfo: TObject): TTrackUnitInfo; override;\r\n public\r\n procedure LoadStack(const SyncObjsInfo: PSyncObjsInfo);\r\n end;\r\n\r\n TTrackFuncInfo = class\r\n private\r\n FFuncInfo: TObject;\r\n FTrackUnitInfo: TTrackUnitInfo;\r\n\r\n FCallCount: UInt64;\r\n\r\n FParentFuncs: TCallFuncCounter;\r\n FChildFuncs: TCallFuncCounter;\r\n public\r\n constructor Create(AFuncInfo: TObject);\r\n destructor Destroy; override;\r\n\r\n function AddParentCall(const Addr: Pointer): TCallFuncInfo; inline;\r\n function AddChildCall(const Addr: Pointer): TCallFuncInfo; inline;\r\n\r\n procedure IncCallCount; inline;\r\n\r\n property FuncInfo: TObject read FFuncInfo;\r\n\r\n property TrackUnitInfo: TTrackUnitInfo read FTrackUnitInfo write FTrackUnitInfo;\r\n property ParentFuncs: TCallFuncCounter read FParentFuncs;\r\n property ChildFuncs: TCallFuncCounter read FChildFuncs;\r\n\r\n property CallCount: UInt64 read FCallCount;\r\n end;\r\n\r\n TMemInfoTrackFuncInfo = class(TTrackFuncInfo)\r\n private\r\n FCurCount: Int64;\r\n FSize: Int64;\r\n FGetMemList: TGetMemInfoList;\r\n public\r\n constructor Create(AFuncInfo: TObject);\r\n destructor Destroy; override;\r\n\r\n procedure GrowSize(const Value: Int64); inline;\r\n\r\n procedure IncCurCount; inline;\r\n procedure DecCurCount; inline;\r\n\r\n procedure AddGetMemInfo(const GetMemInfo: TGetMemInfo);\r\n\r\n property CurCount: Int64 read FCurCount;\r\n property Size: Int64 read FSize;\r\n\r\n property GetMemList: TGetMemInfoList read FGetMemList;\r\n end;\r\n\r\n TCodeTrackFuncInfo = class(TTrackFuncInfo)\r\n private\r\n FCPUElapsed: UInt64;\r\n public\r\n procedure GrowElapsed(const Value: UInt64); inline;\r\n\r\n property CPUElapsed: UInt64 read FCPUElapsed;\r\n end;\r\n\r\n TSyncObjsTrackFuncInfo = class(TTrackFuncInfo)\r\n private\r\n FWaitTime: Int64;\r\n FSyncObjsList: TFuncSyncObjsInfoList;\r\n public\r\n constructor Create(AFuncInfo: TObject);\r\n destructor Destroy; override;\r\n\r\n procedure GrowWaitTime(const Value: Int64); inline;\r\n\r\n property WaitTime: Int64 read FWaitTime;\r\n property SyncObjsList: TFuncSyncObjsInfoList read FSyncObjsList;\r\n end;\r\n\r\n TTrackFuncInfoList = class(TTrackFuncInfoBaseList)\r\n protected\r\n function CreateTrackFuncInfo(const FuncInfo: TObject): TTrackFuncInfo; virtual;\r\n public\r\n function GetTrackFuncInfo(const FuncInfo: TObject): TTrackFuncInfo;\r\n end;\r\n TTrackFuncInfoPair = TPair;\r\n\r\n TMemInfoTrackFuncInfoList = class(TTrackFuncInfoList)\r\n protected\r\n function CreateTrackFuncInfo(const FuncInfo: TObject): TTrackFuncInfo; override;\r\n end;\r\n\r\n TCodeTrackFuncInfoList = class(TTrackFuncInfoList)\r\n protected\r\n function CreateTrackFuncInfo(const FuncInfo: TObject): TTrackFuncInfo; override;\r\n end;\r\n\r\n TSyncObjsTrackFuncInfoList = class(TTrackFuncInfoList)\r\n protected\r\n function CreateTrackFuncInfo(const FuncInfo: TObject): TTrackFuncInfo; override;\r\n end;\r\n\r\n PTrackStackPoint = ^TTrackStackPoint;\r\n TTrackStackPoint = record\r\n private\r\n function GetLeave: UInt64;\r\n procedure SetLeave(const Value: UInt64);\r\n public\r\n TrackFuncInfo: TCodeTrackFuncInfo;\r\n ParentTrackFuncInfo: TCodeTrackFuncInfo;\r\n\r\n ProcTrackFuncInfo: TCodeTrackFuncInfo;\r\n ProcParentTrackFuncInfo: TCodeTrackFuncInfo;\r\n\r\n TrackRETBreakpoint: PTrackRETBreakpoint;\r\n\r\n Enter: UInt64;\r\n Elapsed: UInt64;\r\n\r\n property Leave: UInt64 read GetLeave write SetLeave;\r\n end;\r\n\r\n TFastStack = class\r\n private\r\n FTop: Integer;\r\n FItems: array of T;\r\n\r\n procedure Grow;\r\n function GetCount: Integer; inline;\r\n public\r\n constructor Create(const ACapacity: Integer = 64);\r\n\r\n function Push: Pointer;\r\n function Pop: Pointer;\r\n property Count: Integer read GetCount;\r\n end;\r\n\r\n TTrackStack = TFastStack;\r\n\r\n\r\n TThreadAdvInfoList = TBaseCollectList; //TCollectList;\r\n\r\n TThreadPointList = TBaseCollectList; //TCollectList;\r\n\r\n TThreadMemInfoList = TBaseCollectList; //TCollectList;\r\n\r\n TThreadState = (tsNone, tsActive, tsFinished, tsSuspended, tsLocked);\r\n\r\n TThreadData = packed record\r\n ThreadID: TThreadId;\r\n State: TThreadState;\r\n ThreadHandle: THandle;\r\n ThreadAdvInfo: PThreadAdvInfo;\r\n Context: PContext; // 32 \r\n Breakpoint: PHardwareBreakpoint;\r\n Started: Int64; // \r\n Elapsed: Int64; // \r\n\r\n CPUElapsed: UInt64; // CPU\r\n CPUTime: UInt64; // CPU\r\n\r\n SamplingCPUTime: UInt64;\r\n SamplingCount: Cardinal;\r\n SamplingQueue: TQueue;\r\n\r\n WaitTime: Int64; // \r\n\r\n DbgPoints: TThreadPointList;\r\n\r\n DbgGetMemInfo: TGetMemInfoList;\r\n DbgGetMemInfoSize: Int64;\r\n\r\n DbgSyncObjsInfo: TSyncObjsInfoList;\r\n DbgSyncObjsInfoByID: TSyncObjsInfoListByID;\r\n\r\n DbgGetMemUnitList: TMemInfoTrackUnitInfoList;\r\n DbgSyncObjsUnitList: TSyncObjsTrackUnitInfoList;\r\n //DbgGetMemFuncList: TTrackFuncInfoList;\r\n\r\n DbgExceptions: TThreadList;\r\n\r\n DbgTrackEventCount: Int64;\r\n DbgTrackUnitList: TCodeTrackUnitInfoList;\r\n DbgTrackFuncList: TCodeTrackFuncInfoList;\r\n DbgTrackStack: TTrackStack;\r\n DbgTrackUsedUnitList: TTrackUnitInfoList; // \r\n\r\n function DbgPointsCount: Cardinal;\r\n function DbgPointByIdx(const Idx: Integer): PThreadPoint;\r\n\r\n function DbgExceptionsCount: Cardinal;\r\n function DbgExceptionsByIdx(const Idx: Cardinal): TExceptInfo;\r\n\r\n function DbgSyncObjsCount: Cardinal;\r\n function DbgSyncObjsByIdx(const Idx: Integer): PSyncObjsInfo;\r\n\r\n procedure UpdateGetMemUnitList;\r\n\r\n procedure Init;\r\n procedure Clear;\r\n end;\r\n\r\n TDbgThreadList = TBaseCollectList; //TCollectList;\r\n TDbgActiveThreadList = TDictionary;\r\n TDbgActiveThreads = array of PThreadData;\r\n\r\n PProcessPoint = ^TProcessPoint;\r\n TProcessPoint = packed record\r\n FromStart: Int64; // - \r\n CPUTime: UInt64; // CPU\r\n case PointType: TDbgPointType of\r\n ptStart: ();\r\n ptStop: ();\r\n ptException: ();\r\n ptPerfomance: (\r\n //DeltaTick: Int64;\r\n //DeltaTickCPU: UInt64;\r\n DeltaTime: UInt64;\r\n );\r\n ptMemoryInfo: ();\r\n end;\r\n\r\n TProcessPointList = TBaseCollectList; //TCollectList;\r\n\r\n // .\r\n // , DebugProcessData\r\n // !!!\r\n // ,\r\n // CloseHandle()\r\n\r\n TProcessState = (psNone, psActive, psFinished);\r\n\r\n //PProcessData = ^TProcessData;\r\n TProcessData = class\r\n public\r\n ProcessID: TProcessId;\r\n State: TProcessState;\r\n StartAddress: Pointer;\r\n BaseOfImage: Pointer;\r\n MainThreadID: TThreadId;\r\n PEImage: TJclPeImage;\r\n\r\n Started: Int64;\r\n Elapsed: Int64;\r\n CPUTime: UInt64;\r\n CPUElapsed: UInt64; // CPU\r\n\r\n SamplingCPUTime: UInt64;\r\n SamplingCount: Int64;\r\n\r\n DbgPoints: TProcessPointList;\r\n\r\n DbgGetMemInfo: TGetMemInfoList; // \r\n DbgGetMemInfoSize: Cardinal;\r\n\r\n ProcessGetMemCount: Int64;\r\n ProcessGetMemSize: Int64;\r\n\r\n DbgExceptions: TThreadList;\r\n\r\n DbgTrackEventCount: Int64;\r\n DbgTrackUnitList: TCodeTrackUnitInfoList;\r\n DbgTrackFuncList: TCodeTrackFuncInfoList;\r\n DbgTrackUsedUnitList: TTrackUnitInfoList; // \r\n\r\n CreatedProcessHandle: THandle;\r\n CreatedThreadHandle: THandle;\r\n AttachedProcessHandle: THandle;\r\n AttachedThreadHandle: THandle;\r\n AttachedFileHandle: THandle;\r\n\r\n constructor Create;\r\n destructor Destroy; override;\r\n\r\n //DbgShareMem: THandle; // FileMap \r\n\r\n function Elapsed_MSec: Cardinal; // msec\r\n function DbgPointsCount: Cardinal;\r\n function DbgPointByIdx(const Idx: Cardinal): PProcessPoint;\r\n function CurDbgPointIdx: Integer;\r\n\r\n function DbgExceptionsCount: Cardinal;\r\n\r\n procedure Clear;\r\n\r\n procedure SetPEImage(APEImage: TJclPeImage);\r\n end;\r\n\r\n THardwareBreakpointEvent = procedure(Sender: TObject; ThreadId: TThreadId; ExceptionRecord: PExceptionRecord;\r\n BreakPointIndex: THWBPIndex; var ReleaseBreakpoint: LongBool) of object;\r\n\r\n TDbgState = (dsNone, dsStarted, dsWait, dsPerfomance, dsTrace, dsEvent, dsPause, dsStoping, dsStoped, dsDbgFail);\r\n\r\n TDbgTraceState = (dtsContinue, dtsPause, dtsStepIn, dtsStepOver, dtsStepOut);\r\n\r\n TDbgLogType = (dltUnknown = 0, dltInfo, dltWarning, dltError, dltDebugOutput, dltProcessEvent, dltThreadEvent, dltExceptionEvent,\r\n dltBreakPointEvent, dltDLLEvent);\r\n\r\n TDbgLogItem = Class\r\n public\r\n LogType: TDbgLogType;\r\n DateTime: TDateTime;\r\n LogMessage: String;\r\n\r\n destructor Destroy; override;\r\n End;\r\n\r\n TDbgLog = class(TList)\r\n private\r\n FLock: TMREWSync;\r\n function GetItem(const Index: Integer): TDbgLogItem;\r\n public\r\n constructor Create;\r\n destructor Destroy; override;\r\n\r\n procedure ClearLog;\r\n\r\n procedure Add(const LogType: TDbgLogType; const Msg: String); overload;\r\n procedure Add(const LogType: TDbgLogType; const FmtMsg: String; const Args: array of Const); overload;\r\n\r\n property Items[const Index: Integer]: TDbgLogItem read GetItem; default;\r\n property Lock: TMREWSync read FLock;\r\n end;\r\n\r\nprocedure RaiseDebugCoreException(const Msg: String = '');\r\n\r\nimplementation\r\n\r\nuses Debuger, DebugInfo, WinAPIUtils, Collections.Base;\r\n\r\nprocedure RaiseDebugCoreException(const Msg: String);\r\nbegin\r\n raise EDebugCoreException.Create(Msg);\r\nend;\r\n\r\n\r\n{ TDebugProcessData }\r\n\r\nprocedure TProcessData.Clear;\r\nbegin\r\n SamplingCPUTime := 0;\r\n SamplingCount := 0;\r\n\r\n if DbgPoints <> Nil then\r\n FreeAndNil(DbgPoints);\r\n\r\n FreeAndNil(DbgGetMemInfo);\r\n DbgExceptions.Clear;\r\n\r\n FreeAndNil(DbgTrackFuncList);\r\n FreeAndNil(DbgTrackUnitList);\r\n FreeAndNil(DbgTrackUsedUnitList);\r\nend;\r\n\r\nconstructor TProcessData.Create;\r\nbegin\r\n inherited;\r\n\r\n State := psNone;\r\n DbgPoints := Nil;\r\n DbgExceptions := TThreadList.Create;\r\nend;\r\n\r\nfunction TProcessData.CurDbgPointIdx: Integer;\r\nbegin\r\n if Assigned(DbgPoints) and (DbgPoints.Count > 0) then\r\n Result := DbgPoints.Count - 1\r\n else\r\n begin\r\n Result := 0;\r\n RaiseDebugCoreException();\r\n end;\r\nend;\r\n\r\nfunction TProcessData.DbgExceptionsCount: Cardinal;\r\nvar\r\n L: TList;\r\nbegin\r\n L := DbgExceptions.LockList;\r\n try\r\n Result := Cardinal(L.Count);\r\n finally\r\n DbgExceptions.UnlockList;\r\n end;\r\nend;\r\n\r\nfunction TProcessData.DbgPointByIdx(const Idx: Cardinal): PProcessPoint;\r\nbegin\r\n Result := DbgPoints[Idx];\r\nend;\r\n\r\nfunction TProcessData.DbgPointsCount: Cardinal;\r\nbegin\r\n if Assigned(DbgPoints) then\r\n Result := DbgPoints.Count\r\n else\r\n Result := 0;\r\nend;\r\n\r\ndestructor TProcessData.Destroy;\r\nbegin\r\n Clear;\r\n\r\n FreeAndNil(DbgExceptions);\r\n\r\n inherited;\r\nend;\r\n\r\nfunction TProcessData.Elapsed_MSec: Cardinal;\r\nvar\r\n Cur: Int64;\r\n Freq: Int64;\r\nbegin\r\n if State = psActive then\r\n Cur := _QueryPerformanceCounter\r\n else\r\n Cur := Elapsed;\r\n\r\n Freq := _QueryPerformanceFrequency;\r\n Result := ((Cur - Started) * 1000) div Freq;\r\nend;\r\n\r\nprocedure TProcessData.SetPEImage(APEImage: TJclPeImage);\r\nbegin\r\n PEImage := APEImage;\r\nend;\r\n\r\n{ TThreadData }\r\n\r\nprocedure TThreadData.Clear;\r\nvar\r\n I: Integer;\r\nbegin\r\n if Breakpoint <> Nil then\r\n begin\r\n FreeMemory(Breakpoint);\r\n Breakpoint := Nil;\r\n end;\r\n\r\n if DbgPoints <> Nil then\r\n begin\r\n for I := 0 to DbgPointsCount - 1 do\r\n DbgPointByIdx(I).Clear;\r\n\r\n FreeAndNil(DbgPoints);\r\n end;\r\n\r\n FreeAndNil(DbgGetMemInfo);\r\n FreeAndNil(DbgGetMemUnitList);\r\n FreeAndNil(DbgSyncObjsUnitList);\r\n //FreeAndNil(DbgGetMemFuncList);\r\n FreeAndNil(DbgSyncObjsInfo);\r\n FreeAndNil(DbgSyncObjsInfoByID);\r\n FreeAndNil(DbgExceptions);\r\n\r\n FreeAndNil(DbgTrackUnitList);\r\n FreeAndNil(DbgTrackFuncList);\r\n FreeAndNil(DbgTrackStack);\r\n\r\n FreeAndNil(SamplingQueue);\r\n FreeAndNil(DbgTrackUsedUnitList);\r\n\r\n FreeMemory(Context);\r\n\r\n ThreadAdvInfo := Nil;\r\nend;\r\n\r\nfunction TThreadData.DbgExceptionsByIdx(const Idx: Cardinal): TExceptInfo;\r\nvar\r\n L: TList;\r\nbegin\r\n Result := nil;\r\n\r\n L := DbgExceptions.LockList;\r\n try\r\n if (L.Count > 0) and (Idx < Cardinal(L.Count)) then\r\n Result := TExceptInfo(L[Idx]);\r\n finally\r\n DbgExceptions.UnlockList;\r\n end;\r\nend;\r\n\r\nfunction TThreadData.DbgExceptionsCount: Cardinal;\r\nvar\r\n L: TList;\r\nbegin\r\n L := DbgExceptions.LockList;\r\n try\r\n Result := Cardinal(L.Count);\r\n finally\r\n DbgExceptions.UnlockList;\r\n end;\r\nend;\r\n\r\nfunction TThreadData.DbgPointByIdx(const Idx: Integer): PThreadPoint;\r\nbegin\r\n if Idx < DbgPoints.Count then\r\n Result := DbgPoints[Idx]\r\n else\r\n Result := Nil;\r\nend;\r\n\r\nfunction TThreadData.DbgPointsCount: Cardinal;\r\nbegin\r\n Result := DbgPoints.Count;\r\nend;\r\n\r\nfunction TThreadData.DbgSyncObjsByIdx(const Idx: Integer): PSyncObjsInfo;\r\nbegin\r\n if Idx < DbgSyncObjsInfo.Count then\r\n Result := DbgSyncObjsInfo[Idx]\r\n else\r\n Result := Nil;\r\nend;\r\n\r\nfunction TThreadData.DbgSyncObjsCount: Cardinal;\r\nbegin\r\n Result := DbgSyncObjsInfo.Count;\r\nend;\r\n\r\nprocedure TThreadData.Init;\r\nbegin\r\n ThreadID := 0;\r\n State := tsNone;\r\n ThreadHandle := 0;\r\n\r\n ThreadAdvInfo := Nil;\r\n\r\n Context := GetMemory(SizeOf(TContext));\r\n Breakpoint := GetMemory(SizeOf(THardwareBreakpoint));\r\n\r\n Started := 0;\r\n Elapsed := 0;\r\n CPUElapsed := 0;\r\n\r\n SamplingCPUTime := 0;\r\n SamplingCount := 0;\r\n SamplingQueue := TQueue.Create(4096, True);\r\n DbgTrackUsedUnitList := TTrackUnitInfoList.Create(64);\r\n DbgTrackUsedUnitList.OwnsKeys := False;\r\n DbgTrackUsedUnitList.OwnsValues := False;\r\n\r\n DbgPoints := TCollectList.Create;\r\n\r\n DbgGetMemInfo := TGetMemInfoList.Create(1024, True);\r\n DbgGetMemInfo.OwnsValues := True;\r\n\r\n DbgGetMemUnitList := TMemInfoTrackUnitInfoList.Create(512, True);\r\n DbgGetMemUnitList.OwnsValues := True;\r\n\r\n DbgSyncObjsUnitList := TSyncObjsTrackUnitInfoList.Create(512, True);\r\n DbgSyncObjsUnitList.OwnsValues := True;\r\n\r\n DbgExceptions := TThreadList.Create;\r\n\r\n DbgSyncObjsInfo := TCollectList.Create;\r\n\r\n DbgSyncObjsInfoByID := TSyncObjsInfoListByID.Create(4096, True);\r\n\r\n DbgTrackEventCount := 0;\r\n DbgTrackUnitList := TCodeTrackUnitInfoList.Create(512, True);\r\n DbgTrackUnitList.OwnsValues := True;\r\n\r\n DbgTrackFuncList := TCodeTrackFuncInfoList.Create(4096, True);\r\n DbgTrackFuncList.OwnsValues := True;\r\n\r\n DbgTrackStack := TTrackStack.Create(64);\r\nend;\r\n\r\nprocedure TThreadData.UpdateGetMemUnitList;\r\nvar\r\n GetMemInfoItem: TGetMemInfoItem;\r\nbegin\r\n DbgGetMemUnitList.Clear;\r\n\r\n DbgGetMemInfo.LockForRead;\r\n try\r\n for GetMemInfoItem in DbgGetMemInfo do\r\n DbgGetMemUnitList.LoadStack(GetMemInfoItem.Value);\r\n finally\r\n DbgGetMemInfo.UnLockForRead;\r\n end;\r\nend;\r\n\r\n{ TThreadPoint }\r\n\r\nprocedure TThreadPoint.Clear;\r\nbegin\r\n case PointType of\r\n ptException:\r\n FreeAndNil(ExceptInfo);\r\n ptPerfomance:\r\n FreeAndNil(PerfInfo);\r\n ptSyncObjsInfo:\r\n FreeAndNil(SyncObjsInfo);\r\n end;\r\nend;\r\n\r\n{ TThreadAdvInfo }\r\n\r\nfunction TThreadAdvInfo.AsString: String;\r\nconst\r\n _UNKNOWN = 'unknown';\r\nbegin\r\n if ThreadName <> '' then\r\n Result := ThreadName\r\n else\r\n if ThreadClassName <> '' then\r\n Result := ThreadClassName\r\n else\r\n Result := _UNKNOWN;\r\nend;\r\n\r\n{ RGetMemInfo }\r\n\r\nprocedure TGetMemInfo.CheckObjectType;\r\nbegin\r\n if ObjectType = '' then\r\n begin\r\n if gvDebuger.Active then\r\n ObjectType := gvDebugInfo.GetClassName(ObjAddr);\r\n end;\r\nend;\r\n\r\nfunction TGetMemInfo.GetObjectType: String;\r\nbegin\r\n CheckObjectType;\r\n\r\n Result := String(ObjectType);\r\nend;\r\n\r\nprocedure TGetMemInfo.LoadStack(const DbgStack: PDbgHookInfoStack);\r\nvar\r\n I: Integer;\r\n Ptr: Pointer;\r\nbegin\r\n I := 0;\r\n while I < Length(DbgStack^) do\r\n begin\r\n Ptr := DbgStack^[I];\r\n\r\n if (Ptr = nil) or (Ptr = Pointer(-1)) then\r\n begin\r\n SetLength(Stack, I);\r\n Move(DbgStack^[0], Stack[0], I * SizeOf(Pointer));\r\n\r\n Exit;\r\n end;\r\n\r\n Inc(I);\r\n end;\r\nend;\r\n\r\n{ TExceptInfo }\r\n\r\nconstructor TExceptInfo.Create(DebugEvent: PDebugEvent);\r\nvar\r\n ER: PExceptionRecord;\r\nbegin\r\n Create;\r\n\r\n if Assigned(DebugEvent) then\r\n begin\r\n ThreadID := DebugEvent^.dwThreadId;\r\n\r\n ER := @DebugEvent^.Exception.ExceptionRecord;\r\n Address := gvDebugInfo.GetExceptionAddress(ER);\r\n Frame := gvDebugInfo.GetExceptionFrame(ER);\r\n ExceptionName := gvDebugInfo.GetExceptionName(ER);\r\n Message := gvDebugInfo.GetExceptionMessage(ER, ThreadID);\r\n\r\n gvDebugInfo.GetCallStackItems(ThreadID, Address, Frame, Stack);\r\n end;\r\nend;\r\n\r\nconstructor TExceptInfo.Create(ThreadData: PThreadData);\r\nbegin\r\n Create;\r\n\r\n if Assigned(ThreadData) then\r\n begin\r\n gvDebuger.UpdateThreadContext(ThreadData);\r\n ThreadID := ThreadData^.ThreadID;\r\n Address := Pointer(ThreadData^.Context^.Eip);\r\n Frame := Pointer(ThreadData^.Context^.Ebp);\r\n\r\n gvDebugInfo.GetCallStackItems(ThreadID, Address, Frame, Stack);\r\n end;\r\nend;\r\n\r\nconstructor TExceptInfo.Create;\r\nbegin\r\n inherited Create;\r\n\r\n Stack := TObjectList.Create;\r\nend;\r\n\r\ndestructor TExceptInfo.Destroy;\r\nbegin\r\n FreeAndNil(Stack);\r\n\r\n inherited;\r\nend;\r\n\r\n{ TDbgLog }\r\n\r\nprocedure TDbgLog.Add(const LogType: TDbgLogType; const Msg: String);\r\nvar\r\n LogItem: TDbgLogItem;\r\nbegin\r\n LogItem := TDbgLogItem.Create;\r\n LogItem.LogType := LogType;\r\n LogItem.DateTime := Now;\r\n LogItem.LogMessage := Msg;\r\n\r\n FLock.BeginWrite;\r\n try\r\n inherited Add(LogItem);\r\n finally\r\n FLock.EndWrite;\r\n end;\r\nend;\r\n\r\nprocedure TDbgLog.Add(const LogType: TDbgLogType; const FmtMsg: String; const Args: array of Const);\r\nbegin\r\n Add(LogType, Format(FmtMsg, Args));\r\nend;\r\n\r\nprocedure TDbgLog.ClearLog;\r\nbegin\r\n FLock.BeginWrite;\r\n try\r\n ClearList(Self);\r\n finally\r\n FLock.EndWrite;\r\n end;\r\nend;\r\n\r\nconstructor TDbgLog.Create;\r\nbegin\r\n inherited Create;\r\n\r\n Capacity := 1000;\r\n FLock := TMREWSync.Create;\r\nend;\r\n\r\ndestructor TDbgLog.Destroy;\r\nbegin\r\n ClearLog;\r\n\r\n FreeAndNil(FLock);\r\n\r\n inherited;\r\nend;\r\n\r\nfunction TDbgLog.GetItem(const Index: Integer): TDbgLogItem;\r\nbegin\r\n Result := Nil;\r\n\r\n FLock.BeginRead;\r\n try\r\n if (Index >= 0) and (Index < Count) then\r\n Result := TDbgLogItem(List[Index]);\r\n finally\r\n FLock.EndRead;\r\n end;\r\nend;\r\n\r\n{ TTrackFuncInfo }\r\n\r\nfunction TTrackFuncInfo.AddChildCall(const Addr: Pointer): TCallFuncInfo;\r\nbegin\r\n Result := FChildFuncs.AddCallFunc(Addr);\r\nend;\r\n\r\nfunction TTrackFuncInfo.AddParentCall(const Addr: Pointer): TCallFuncInfo;\r\nbegin\r\n Result := FParentFuncs.AddCallFunc(Addr)\r\nend;\r\n\r\nconstructor TTrackFuncInfo.Create(AFuncInfo: TObject);\r\nbegin\r\n inherited Create;\r\n\r\n FFuncInfo := AFuncInfo;\r\n FTrackUnitInfo := nil;\r\n FParentFuncs := TCallFuncCounter.Create(128);\r\n FParentFuncs.OwnsValues := True;\r\n FChildFuncs := TCallFuncCounter.Create(128);\r\n FChildFuncs.OwnsValues := True;\r\nend;\r\n\r\ndestructor TTrackFuncInfo.Destroy;\r\nbegin\r\n FreeAndNil(FParentFuncs);\r\n FreeAndNil(FChildFuncs);\r\n\r\n inherited;\r\nend;\r\n\r\nprocedure TTrackFuncInfo.IncCallCount;\r\nbegin\r\n Inc(FCallCount);\r\n\r\n // \r\n // \r\n //FTrackUnitInfo.IncCallCount;\r\nend;\r\n\r\n{ TCodeTrackFuncInfo }\r\n\r\nprocedure TCodeTrackFuncInfo.GrowElapsed(const Value: UInt64);\r\nbegin\r\n Inc(FCPUElapsed, Value);\r\n TCodeTrackUnitInfo(FTrackUnitInfo).GrowElapsed(Value);\r\nend;\r\n\r\n{ TMemInfoTrackFuncInfo }\r\n\r\nprocedure TMemInfoTrackFuncInfo.AddGetMemInfo(const GetMemInfo: TGetMemInfo);\r\nbegin\r\n if FGetMemList = Nil then\r\n begin\r\n FGetMemList := TGetMemInfoList.Create(256, True);\r\n FGetMemList.OwnsValues := False;\r\n end;\r\n\r\n FGetMemList.AddOrSetValue(GetMemInfo.ObjAddr, GetMemInfo);\r\nend;\r\n\r\ndestructor TMemInfoTrackFuncInfo.Destroy;\r\nbegin\r\n FreeAndNil(FGetMemList);\r\n\r\n inherited;\r\nend;\r\n\r\nconstructor TMemInfoTrackFuncInfo.Create(AFuncInfo: TObject);\r\nbegin\r\n inherited;\r\n\r\n FGetMemList := Nil;\r\nend;\r\n\r\nprocedure TMemInfoTrackFuncInfo.DecCurCount;\r\nbegin\r\n Dec(FCurCount);\r\n TMemInfoTrackUnitInfo(FTrackUnitInfo).DecCurCount;\r\nend;\r\n\r\nprocedure TMemInfoTrackFuncInfo.GrowSize(const Value: Int64);\r\nbegin\r\n Inc(FSize, Value);\r\n TMemInfoTrackUnitInfo(FTrackUnitInfo).GrowSize(Value);\r\nend;\r\n\r\nprocedure TMemInfoTrackFuncInfo.IncCurCount;\r\nbegin\r\n Inc(FCurCount);\r\n TMemInfoTrackUnitInfo(FTrackUnitInfo).IncCurCount;\r\nend;\r\n\r\n{ TTrackFuncInfoList }\r\n\r\nfunction TTrackFuncInfoList.CreateTrackFuncInfo(const FuncInfo: TObject): TTrackFuncInfo;\r\nbegin\r\n Result := TTrackFuncInfo.Create(FuncInfo);\r\nend;\r\n\r\nfunction TTrackFuncInfoList.GetTrackFuncInfo(const FuncInfo: TObject): TTrackFuncInfo;\r\nbegin\r\n Assert(Assigned(FuncInfo));\r\n\r\n if not TryGetValue(FuncInfo, Result) then\r\n begin\r\n Result := CreateTrackFuncInfo(FuncInfo);\r\n Add(FuncInfo, Result);\r\n end;\r\nend;\r\n\r\n{ TCallCounter }\r\n\r\nfunction TCallFuncCounter.AddCallFunc(const Addr: Pointer): TCallFuncInfo;\r\nbegin\r\n Result := Nil;\r\n\r\n if (Addr = Nil) or (Addr = Pointer(-1)) then\r\n Exit;\r\n\r\n if TryGetValue(Addr, Result) then\r\n Inc(Result.CallCount)\r\n else\r\n begin\r\n Result := AddNewCallFunc(Addr);\r\n Result.CallCount := 1;\r\n\r\n Add(Addr, Result);\r\n end;\r\nend;\r\n\r\nfunction TCallFuncCounter.AddNewCallFunc(const Addr: Pointer): TCallFuncInfo;\r\nvar\r\n UnitInfo: TUnitInfo;\r\n FuncInfo: TFuncInfo;\r\n LineInfo: TLineInfo;\r\nbegin\r\n Result := TCallFuncInfo.Create;\r\n\r\n FuncInfo := nil;\r\n LineInfo := nil;\r\n if gvDebugInfo.GetLineInfo(Addr, UnitInfo, FuncInfo, LineInfo, False) <> slNotFound then\r\n begin\r\n Result.FuncInfo := FuncInfo;\r\n if Assigned(LineInfo) then\r\n Result.LineNo := LineInfo.LineNo;\r\n end;\r\nend;\r\n\r\nfunction TCallFuncCounter.GetCallFunc(const Addr: Pointer): TCallFuncInfo;\r\nbegin\r\n if not TryGetValue(Addr, Result) then\r\n Result := Nil;\r\nend;\r\n\r\n{ TTrackUnitInfoList }\r\n\r\nprocedure TTrackUnitInfoList.CheckTrackFuncInfo(TrackFuncInfo: TTrackFuncInfo);\r\nvar\r\n FuncInfo: TFuncInfo;\r\nbegin\r\n FuncInfo := TFuncInfo(TrackFuncInfo.FuncInfo);\r\n\r\n if Assigned(FuncInfo) then\r\n begin\r\n if TrackFuncInfo.TrackUnitInfo = nil then\r\n TrackFuncInfo.TrackUnitInfo := GetTrackUnitInfo(FuncInfo.UnitInfo);\r\n\r\n TrackFuncInfo.TrackUnitInfo.FuncInfoList.AddOrSetValue(FuncInfo, TrackFuncInfo);\r\n end;\r\nend;\r\n\r\nfunction TTrackUnitInfoList.CreateTrackUnitInfo(const UnitInfo: TObject): TTrackUnitInfo;\r\nbegin\r\n Result := TTrackUnitInfo.Create(UnitInfo);\r\nend;\r\n\r\nfunction TTrackUnitInfoList.GetTrackUnitInfo(const UnitInfo: TObject): TTrackUnitInfo;\r\nbegin\r\n if not TryGetValue(UnitInfo, Result) then\r\n begin\r\n LockForWrite;\r\n try\r\n if not TryGetValue(UnitInfo, Result) then\r\n begin\r\n Result := CreateTrackUnitInfo(UnitInfo);\r\n\r\n Add(UnitInfo, Result);\r\n end;\r\n finally\r\n UnLockForWrite;\r\n end;\r\n end;\r\nend;\r\n\r\n{ TMemInfoTrackUnitInfoList }\r\n\r\nfunction TMemInfoTrackUnitInfoList.CreateTrackUnitInfo(const UnitInfo: TObject): TTrackUnitInfo;\r\nbegin\r\n Result := TMemInfoTrackUnitInfo.Create(UnitInfo);\r\n Result.FuncInfoList.OwnsValues := True;\r\nend;\r\n\r\nprocedure TMemInfoTrackUnitInfoList.LoadStack(const GetMemInfo: TGetMemInfo);\r\nvar\r\n StackEntry: TStackEntry;\r\n I: Integer;\r\n Addr: Pointer;\r\n TrackUnitInfo: TMemInfoTrackUnitInfo;\r\n TrackFuncInfo: TTrackFuncInfo;\r\n CallFuncInfo: TCallFuncInfo;\r\nbegin\r\n StackEntry := TStackEntry.Create;\r\n try\r\n for I := 0 to High(GetMemInfo.Stack) do\r\n begin\r\n Addr := GetMemInfo.Stack[I];\r\n\r\n if (Addr = nil) or (Addr = Pointer(-1)) then Break;\r\n\r\n if StackEntry.UpdateInfo(Addr) <> slNotFound then\r\n begin\r\n TrackUnitInfo := TMemInfoTrackUnitInfo(GetTrackUnitInfo(StackEntry.UnitInfo));\r\n\r\n if not TrackUnitInfo.FuncInfoList.TryGetValue(StackEntry.FuncInfo, TrackFuncInfo) then\r\n begin\r\n TrackFuncInfo := TMemInfoTrackFuncInfo.Create(StackEntry.FuncInfo);\r\n TrackFuncInfo.TrackUnitInfo := TrackUnitInfo;\r\n\r\n TrackUnitInfo.FuncInfoList.AddOrSetValue(StackEntry.FuncInfo, TrackFuncInfo);\r\n end;\r\n\r\n TMemInfoTrackFuncInfo(TrackFuncInfo).IncCallCount;\r\n TMemInfoTrackFuncInfo(TrackFuncInfo).IncCurCount;\r\n TMemInfoTrackFuncInfo(TrackFuncInfo).GrowSize(GetMemInfo.Size);\r\n TMemInfoTrackFuncInfo(TrackFuncInfo).AddGetMemInfo(GetMemInfo);\r\n\r\n // TODO: Addr\r\n if I > 0 then\r\n begin\r\n Addr := GetMemInfo.Stack[I - 1];\r\n CallFuncInfo := TrackFuncInfo.AddChildCall(Addr);\r\n if Assigned(CallFuncInfo) then\r\n Inc(CallFuncInfo.Data, GetMemInfo.Size);\r\n end;\r\n\r\n // TODO: Addr\r\n if I < High(GetMemInfo.Stack) then\r\n begin\r\n Addr := GetMemInfo.Stack[I + 1];\r\n CallFuncInfo := TrackFuncInfo.AddParentCall(Addr);\r\n if Assigned(CallFuncInfo) then\r\n Inc(CallFuncInfo.Data, GetMemInfo.Size);\r\n end;\r\n end;\r\n end;\r\n finally\r\n FreeAndNil(StackEntry);\r\n end;\r\nend;\r\n\r\n{ TTrackUnitInfo }\r\n\r\nconstructor TTrackUnitInfo.Create(AUnitInfo: TObject);\r\nbegin\r\n inherited Create;\r\n\r\n FFuncInfoList := TTrackFuncInfoBaseList.Create(128);\r\n FFuncInfoList.OwnsValues := False;\r\n FFuncInfoList.OwnsKeys := False;\r\n\r\n FUnitInfo := AUnitInfo;\r\n FCallCount := 0;\r\nend;\r\n\r\ndestructor TTrackUnitInfo.Destroy;\r\nbegin\r\n FUnitInfo := nil;\r\n FreeAndNil(FFuncInfoList);\r\n\r\n inherited;\r\nend;\r\n\r\nprocedure TTrackUnitInfo.IncCallCount;\r\nbegin\r\n TInterlocked.Add(FCallCount, 1);\r\nend;\r\n\r\nprocedure TCodeTrackUnitInfo.GrowElapsed(const Value: Int64);\r\nbegin\r\n TInterlocked.Add(FElapsed, Value);\r\nend;\r\n\r\n{ TTrackStackPoint }\r\n\r\nfunction TTrackStackPoint.GetLeave: UInt64;\r\nbegin\r\n Result := Enter + Elapsed;\r\nend;\r\n\r\nprocedure TTrackStackPoint.SetLeave(const Value: UInt64);\r\nbegin\r\n Elapsed := (Value - Enter) + 1;\r\nend;\r\n\r\n{ TSyncObjsInfo }\r\n\r\nconstructor TSyncObjsInfo.Create(const DebugEvent: PDebugEvent; const ThreadData: PThreadData; const APerfIdx: Cardinal);\r\nvar\r\n ER: PExceptionRecord;\r\nbegin\r\n inherited Create;\r\n\r\n PerfIdx := APerfIdx;\r\n\r\n ER := @DebugEvent^.Exception.ExceptionRecord;\r\n SyncObjsType := TDbgSyncObjsType(ER^.ExceptionInformation[1]);\r\n SyncObjsStateType := TDbgSyncObjsStateType(ER^.ExceptionInformation[2]);\r\n Id := ER^.ExceptionInformation[3];\r\n Data := ER^.ExceptionInformation[4];\r\n Link := FindLink(ThreadData);\r\n if Assigned(Link) then\r\n Link.Link := Self;\r\nend;\r\n\r\ndestructor TSyncObjsInfo.Destroy;\r\nbegin\r\n\r\n inherited;\r\nend;\r\n\r\nfunction TSyncObjsInfo.FindLink(const ThreadData: PThreadData): TSyncObjsInfo;\r\nvar\r\n I: Integer;\r\n ThPoint: PThreadPoint;\r\nbegin\r\n Result := nil;\r\n\r\n if SyncObjsStateType = sosLeave then\r\n begin\r\n ThreadData^.DbgPoints.BeginRead;\r\n try\r\n I := ThreadData^.DbgPoints.Count - 2;\r\n while I >= 0 do\r\n begin\r\n ThPoint := ThreadData^.DbgPoints[I];\r\n\r\n if (ThPoint^.PointType = ptSyncObjsInfo) and (ThPoint^.SyncObjsInfo.Id = Id) then\r\n begin\r\n Result := ThPoint^.SyncObjsInfo;\r\n Exit;\r\n end;\r\n\r\n Dec(I);\r\n end;\r\n finally\r\n ThreadData^.DbgPoints.EndRead;\r\n end;\r\n end;\r\nend;\r\n\r\n{ TMemInfoTrackUnitInfo }\r\n\r\nprocedure TMemInfoTrackUnitInfo.DecCurCount;\r\nbegin\r\n Dec(FCurCount);\r\nend;\r\n\r\nprocedure TMemInfoTrackUnitInfo.GrowSize(const Value: Int64);\r\nbegin\r\n Inc(FSize, Value);\r\nend;\r\n\r\nprocedure TMemInfoTrackUnitInfo.IncCurCount;\r\nbegin\r\n Inc(FCurCount);\r\nend;\r\n\r\n{ TMemInfoTrackFuncInfoList }\r\n\r\nfunction TMemInfoTrackFuncInfoList.CreateTrackFuncInfo(const FuncInfo: TObject): TTrackFuncInfo;\r\nbegin\r\n Result := TMemInfoTrackFuncInfo.Create(FuncInfo);\r\nend;\r\n\r\n{ TCodeTrackFuncInfoList }\r\n\r\nfunction TCodeTrackFuncInfoList.CreateTrackFuncInfo(const FuncInfo: TObject): TTrackFuncInfo;\r\nbegin\r\n Result := TCodeTrackFuncInfo.Create(FuncInfo);\r\nend;\r\n\r\nfunction TCodeTrackUnitInfoList.CreateTrackUnitInfo(const UnitInfo: TObject): TTrackUnitInfo;\r\nbegin\r\n Result := TCodeTrackUnitInfo.Create(UnitInfo);\r\nend;\r\n\r\n{ TSyncObjsTrackUnitInfoList }\r\n\r\nfunction TSyncObjsTrackUnitInfoList.CreateTrackUnitInfo(const UnitInfo: TObject): TTrackUnitInfo;\r\nbegin\r\n Result := TSyncObjsTrackUnitInfo.Create(UnitInfo);\r\n Result.FuncInfoList.OwnsValues := True;\r\nend;\r\n\r\nprocedure TSyncObjsTrackUnitInfoList.LoadStack(const SyncObjsInfo: PSyncObjsInfo);\r\nvar\r\n StackEntry: TStackEntry;\r\n I: Integer;\r\n Addr: Pointer;\r\n TrackUnitInfo: TSyncObjsTrackUnitInfo;\r\n TrackFuncInfo: TTrackFuncInfo;\r\n CallFuncInfo: TCallFuncInfo;\r\n DbgSyncObjsInfo: PDbgSyncObjsInfoEx;\r\n WaitTime: Int64;\r\n ThData: PThreadData;\r\n SyncObjsListItem: PRPSyncObjsInfo;\r\nbegin\r\n if SyncObjsInfo = Nil then Exit;\r\n\r\n DbgSyncObjsInfo := @SyncObjsInfo^.SyncObjsInfo;\r\n\r\n // SyncObj, \r\n if (DbgSyncObjsInfo^.SyncObjsStateType = sosLeave) and (Length(DbgSyncObjsInfo^.Stack) = 0) then\r\n if Assigned(SyncObjsInfo^.Link) then\r\n DbgSyncObjsInfo := @SyncObjsInfo^.Link^.SyncObjsInfo;\r\n\r\n // TODO: \r\n // \r\n\r\n // \r\n // Enter . \r\n // TODO: \r\n if SyncObjsInfo^.IsShortLock then\r\n Exit;\r\n\r\n case DbgSyncObjsInfo^.SyncObjsType of\r\n soEnterCriticalSection:\r\n begin\r\n // \r\n if DbgSyncObjsInfo^.OwningThreadId = 0 then\r\n Exit;\r\n\r\n // \r\n if (DbgSyncObjsInfo^.ThreadId = DbgSyncObjsInfo^.OwningThreadId) then\r\n Exit;\r\n end;\r\n soInCriticalSection:\r\n begin\r\n //\r\n end;\r\n soSendMessage:\r\n begin\r\n // SendMessage \r\n if DbgSyncObjsInfo^.ThreadId = gvDebuger.ProcessData.MainThreadID then\r\n Exit;\r\n end;\r\n end;\r\n\r\n StackEntry := TStackEntry.Create;\r\n try\r\n if DbgSyncObjsInfo^.SyncObjsType = soInCriticalSection then\r\n begin\r\n // , WaitTime\r\n // WaitTime \r\n\r\n // ,\r\n // \r\n\r\n for I := 0 to High(DbgSyncObjsInfo^.Stack) do\r\n begin\r\n Addr := DbgSyncObjsInfo^.Stack[I];\r\n\r\n if StackEntry.UpdateInfo(Addr) <> slNotFound then\r\n begin\r\n TrackUnitInfo := TSyncObjsTrackUnitInfo(GetTrackUnitInfo(StackEntry.UnitInfo));\r\n\r\n // TrackFuncInfo\r\n if not TrackUnitInfo.FuncInfoList.TryGetValue(StackEntry.FuncInfo, TrackFuncInfo) then\r\n begin\r\n TrackFuncInfo := TSyncObjsTrackFuncInfo.Create(StackEntry.FuncInfo);\r\n TrackFuncInfo.TrackUnitInfo := TrackUnitInfo;\r\n\r\n TrackUnitInfo.FuncInfoList.AddOrSetValue(StackEntry.FuncInfo, TrackFuncInfo);\r\n end;\r\n\r\n // SyncObj\r\n //TSyncObjsTrackFuncInfo(TrackFuncInfo).IncCallCount;\r\n\r\n // SyncObj \r\n SyncObjsListItem := TSyncObjsTrackFuncInfo(TrackFuncInfo).SyncObjsList.Add;\r\n SyncObjsListItem^.SyncObjsInfo := SyncObjsInfo;\r\n TSyncObjsTrackFuncInfo(TrackFuncInfo).SyncObjsList.Commit;\r\n\r\n // \r\n Break;\r\n end;\r\n end;\r\n end\r\n else\r\n begin\r\n // \r\n for I := 0 to High(DbgSyncObjsInfo^.Stack) do\r\n begin\r\n Addr := DbgSyncObjsInfo^.Stack[I];\r\n\r\n if StackEntry.UpdateInfo(Addr) <> slNotFound then\r\n begin\r\n TrackUnitInfo := TSyncObjsTrackUnitInfo(GetTrackUnitInfo(StackEntry.UnitInfo));\r\n\r\n // TrackFuncInfo\r\n if not TrackUnitInfo.FuncInfoList.TryGetValue(StackEntry.FuncInfo, TrackFuncInfo) then\r\n begin\r\n TrackFuncInfo := TSyncObjsTrackFuncInfo.Create(StackEntry.FuncInfo);\r\n TrackFuncInfo.TrackUnitInfo := TrackUnitInfo;\r\n\r\n TrackUnitInfo.FuncInfoList.AddOrSetValue(StackEntry.FuncInfo, TrackFuncInfo);\r\n end;\r\n\r\n case SyncObjsInfo^.SyncObjsInfo.SyncObjsStateType of\r\n sosEnter:\r\n begin\r\n // SyncObj\r\n TSyncObjsTrackFuncInfo(TrackFuncInfo).IncCallCount;\r\n\r\n // SyncObj \r\n SyncObjsListItem := TSyncObjsTrackFuncInfo(TrackFuncInfo).SyncObjsList.Add;\r\n SyncObjsListItem^.SyncObjsInfo := SyncObjsInfo;\r\n TSyncObjsTrackFuncInfo(TrackFuncInfo).SyncObjsList.Commit;\r\n\r\n // TODO: Addr\r\n if I > 0 then\r\n begin\r\n Addr := DbgSyncObjsInfo^.Stack[I - 1];\r\n TrackFuncInfo.AddChildCall(Addr);\r\n end;\r\n\r\n // TODO: Addr\r\n if I < High(DbgSyncObjsInfo^.Stack) then\r\n begin\r\n Addr := DbgSyncObjsInfo^.Stack[I + 1];\r\n TrackFuncInfo.AddParentCall(Addr);\r\n end;\r\n end;\r\n sosLeave:\r\n begin\r\n // SyncObj\r\n if Assigned(SyncObjsInfo^.Link) then\r\n begin\r\n WaitTime := SyncObjsInfo^.WaitTime;\r\n TSyncObjsTrackFuncInfo(TrackFuncInfo).GrowWaitTime(WaitTime);\r\n\r\n // \r\n if I = 0 then\r\n begin\r\n ThData := gvDebuger.GetThreadData(SyncObjsInfo^.SyncObjsInfo.ThreadId, True);\r\n TInterlocked.Add(ThData^.WaitTime, WaitTime);\r\n end;\r\n\r\n // TODO: Addr\r\n if I > 0 then\r\n begin\r\n Addr := DbgSyncObjsInfo^.Stack[I - 1];\r\n CallFuncInfo := TrackFuncInfo.ChildFuncs.GetCallFunc(Addr);\r\n if Assigned(CallFuncInfo) then\r\n Inc(CallFuncInfo.Data, WaitTime);\r\n end;\r\n\r\n // TODO: Addr\r\n if I < High(DbgSyncObjsInfo^.Stack) then\r\n begin\r\n Addr := DbgSyncObjsInfo^.Stack[I + 1];\r\n CallFuncInfo := TrackFuncInfo.ParentFuncs.GetCallFunc(Addr);\r\n if Assigned(CallFuncInfo) then\r\n Inc(CallFuncInfo.Data, WaitTime);\r\n end;\r\n end;\r\n end;\r\n end;\r\n end;\r\n end;\r\n end;\r\n finally\r\n FreeAndNil(StackEntry);\r\n end;\r\nend;\r\n\r\n{ TSyncObjsTrackFuncInfoList }\r\n\r\nfunction TSyncObjsTrackFuncInfoList.CreateTrackFuncInfo(const FuncInfo: TObject): TTrackFuncInfo;\r\nbegin\r\n Result := TSyncObjsTrackFuncInfo.Create(FuncInfo);\r\nend;\r\n\r\n{ TSyncObjsTrackFuncInfo }\r\n\r\nconstructor TSyncObjsTrackFuncInfo.Create(AFuncInfo: TObject);\r\nbegin\r\n inherited Create(AFuncInfo);\r\n\r\n FSyncObjsList := TFuncSyncObjsInfoList.Create(32 * SizeOf(Pointer));\r\nend;\r\n\r\ndestructor TSyncObjsTrackFuncInfo.Destroy;\r\nbegin\r\n FreeAndNil(FSyncObjsList);\r\n\r\n inherited;\r\nend;\r\n\r\nprocedure TSyncObjsTrackFuncInfo.GrowWaitTime(const Value: Int64);\r\nbegin\r\n Inc(FWaitTime, Value);\r\nend;\r\n\r\n{ RSyncObjsInfo }\r\n\r\nfunction RSyncObjsInfo.Enter: PSyncObjsInfo;\r\nbegin\r\n if SyncObjsInfo.SyncObjsStateType = sosEnter then\r\n Result := @Self\r\n else\r\n Result := Link;\r\nend;\r\n\r\nfunction RSyncObjsInfo.EnterExt: PSyncObjsInfo;\r\nbegin\r\n if (LinkExt <> Nil) and (SyncObjsInfo.SyncObjsType = soInCriticalSection) then\r\n Result := LinkExt.Enter\r\n else\r\n Result := Enter;\r\nend;\r\n\r\nfunction RSyncObjsInfo.IsShortLock: LongBool;\r\nvar\r\n _Leave: PSyncObjsInfo;\r\n _Enter: PSyncObjsInfo;\r\nbegin\r\n Result := False;\r\n\r\n _Leave := LeaveExt;\r\n if Assigned(_Leave) then\r\n begin\r\n _Enter := EnterExt;\r\n if Assigned(_Enter) then\r\n Result := ((_Leave^.PerfIdx - _Enter^.PerfIdx) <= 1);\r\n end;\r\nend;\r\n\r\nfunction RSyncObjsInfo.Leave: PSyncObjsInfo;\r\nbegin\r\n if SyncObjsInfo.SyncObjsStateType = sosLeave then\r\n Result := @Self\r\n else\r\n Result := Link;\r\nend;\r\n\r\nfunction RSyncObjsInfo.LeaveExt: PSyncObjsInfo;\r\nbegin\r\n if (LinkExt <> Nil) and (SyncObjsInfo.SyncObjsType = soEnterCriticalSection) then\r\n Result := LinkExt.Leave\r\n else\r\n Result := Leave;\r\nend;\r\n\r\nfunction RSyncObjsInfo.WaitTime: Int64;\r\nvar\r\n _Leave: PSyncObjsInfo;\r\n _Enter: PSyncObjsInfo;\r\n _LeaveTime: Int64;\r\nbegin\r\n Result := 0;\r\n\r\n _Leave := Leave;\r\n if Assigned(_Leave) then\r\n _LeaveTime := _Leave.SyncObjsInfo.CurTime\r\n else\r\n _LeaveTime := _QueryPerformanceCounter;\r\n\r\n _Enter := Enter;\r\n begin\r\n if Assigned(_Enter) then\r\n Result := _LeaveTime - _Enter.SyncObjsInfo.CurTime;\r\n end;\r\nend;\r\n\r\n{ TDbgSyncObjsInfoEx }\r\n\r\nprocedure TDbgSyncObjsInfoEx.Init(const SyncObjsInfo: PDbgSyncObjsInfo);\r\nbegin\r\n Id := SyncObjsInfo^.Id;\r\n ThreadId := SyncObjsInfo^.ThreadId;\r\n CurTime := SyncObjsInfo^.CurTime;\r\n SyncObjsStateType := SyncObjsInfo^.SyncObjsStateType;\r\n SyncObjsType := SyncObjsInfo^.SyncObjsType;\r\n case SyncObjsType of\r\n soUnknown: ;\r\n soSleep:\r\n MSec := SyncObjsInfo^.MSec;\r\n soWaitForSingleObject:\r\n Handle := SyncObjsInfo^.Handle;\r\n soWaitForMultipleObjects:\r\n Handles := SyncObjsInfo^.Handles;\r\n soEnterCriticalSection,\r\n soLeaveCriticalSection,\r\n soInCriticalSection:\r\n begin\r\n CS := SyncObjsInfo^.CS;\r\n OwningThreadId := SyncObjsInfo^.OwningThreadId;\r\n end;\r\n soSendMessage: ;\r\n end;\r\n\r\n LoadStack(@SyncObjsInfo^.Stack);\r\nend;\r\n\r\nprocedure TDbgSyncObjsInfoEx.LoadStack(const DbgStack: PDbgHookInfoStack);\r\nvar\r\n I: Integer;\r\n Ptr: Pointer;\r\nbegin\r\n for I := 0 to High(DbgStack^) do\r\n begin\r\n Ptr := DbgStack^[I];\r\n\r\n if (Ptr = nil) or (Ptr = Pointer(-1)) then\r\n begin\r\n SetLength(Stack, I);\r\n if I > 0 then\r\n Move(DbgStack^[0], Stack[0], I * SizeOf(Pointer));\r\n\r\n Exit;\r\n end;\r\n end;\r\nend;\r\n\r\n{ TDbgLogItem }\r\n\r\ndestructor TDbgLogItem.Destroy;\r\nbegin\r\n LogType := dltUnknown;\r\n\r\n inherited;\r\nend;\r\n\r\n{ TTrackStack }\r\n\r\nconstructor TFastStack.Create(const ACapacity: Integer);\r\nbegin\r\n inherited Create;\r\n\r\n FTop := -1;\r\n SetLength(FItems, ACapacity);\r\nend;\r\n\r\nfunction TFastStack.GetCount: Integer;\r\nbegin\r\n Result := FTop + 1;\r\nend;\r\n\r\nprocedure TFastStack.Grow;\r\nvar\r\n L: Integer;\r\n Delta: Integer;\r\nbegin\r\n L := Length(Fitems);\r\n\r\n if L <= 32 then\r\n Delta := L\r\n else\r\n Delta := L div 2;\r\n\r\n SetLength(FItems, L + Delta);\r\nend;\r\n\r\nfunction TFastStack.Pop: Pointer;\r\nbegin\r\n if FTop >= 0 then\r\n begin\r\n Result := @FItems[FTop];\r\n Dec(FTop);\r\n end\r\n else\r\n Result := Nil;\r\nend;\r\n\r\nfunction TFastStack.Push: Pointer;\r\nbegin\r\n Inc(FTop);\r\n\r\n if FTop = Length(FItems) then\r\n Grow;\r\n\r\n Result := @FItems[FTop];\r\nend;\r\n\r\nend.\r\n" }, { "path": "DelphiDebugInfo.pas", "content": "unit DelphiDebugInfo;\r\n\r\nInterface\r\n\r\nUses\r\n SysUtils, Windows, Classes, DebugInfo, Debuger, DebugerTypes, JclTD32Ex;\r\n\r\nType\r\n TDelphiVersion = (dvAuto = 0, dvD1 = 8, dvD2 = 9, dvD3 = 10, dvD4 = 12, dvD5 = 13, dvD6 = 14, dvD7 = 15, dvD8 = 16, dvD2005 = 17, dvD2006_7 = 18,\r\n dvD2009 = 20, dvD2010 = 21, dvDXE = 22, dvDXE2 = 23, dvDXE3 = 24, dvDXE4 = 25);\r\n\r\n TDelphiDebugInfo = Class(TDebugInfo)\r\n Private\r\n FDelphiVersion: TDelphiVersion;\r\n FSystemUnits: TStringList;\r\n FAddressInfoList: TAddressInfoList;\r\n FIsHookSet: LongBool;\r\n\r\n Function ImageBase: Cardinal;\r\n Function ImageNames(const Index: TNameId): AnsiString;\r\n function LoadVar(UnitInfo: TUnitInfo; VarSymbol: TJclTD32NamedSymbol; Func: TFuncInfo): TVarInfo;\r\n procedure LoadFunc(UnitInfo: TUnitInfo; FuncSymbol: TJclTD32ProcSymbolInfo);\r\n procedure LoadSymbols(UnitInfo: TUnitInfo; Module: TJclTD32ModuleInfo);\r\n function GetUnitFileName(const UnitName: String): String;\r\n procedure LoadConst(OwnerInfo: TSegmentCodeInfo; ConstSymbol: TJclTD32ConstantSymbolInfo);\r\n //procedure LoadLines(UnitInfo: TUnitInfo; Source: TJclTD32SourceModuleInfo);\r\n procedure LoadSourceLines(UnitInfo: TUnitInfo; UnitSourceModuleInfo: TUnitSourceModuleInfo; Source: TJclTD32SourceModuleInfo);\r\n procedure LoadSegments(UnitInfo: TUnitInfo; Module: TJclTD32ModuleInfo);\r\n procedure LoadSourceModules(UnitInfo: TUnitInfo; Module: TJclTD32ModuleInfo);\r\n function LoadType(UnitInfo: TUnitInfo; const TypeIndex: Integer; out DstType: TTypeInfo): Integer;\r\n procedure LoadUsedUnits(UnitInfo: TUnitInfo; Module: TJclTD32ModuleInfo);\r\n function RegisterIndex(const Index: Byte): Integer;\r\n\r\n procedure InitSegments;\r\n\r\n Function ParseUnit(Module: TJclTD32ModuleInfo): TUnitInfo;\r\n\r\n Procedure ResolveUnits;\r\n\r\n Function FindUnitByAddr(const Addr: Pointer): TUnitInfo;\r\n Function FindFuncByAddr(const UnitInfo: TUnitInfo; const Addr: Pointer): TFuncInfo;\r\n Function FindLineByAddr(const FuncInfo: TFuncInfo; const Addr: Pointer; const GetPrevLine: LongBool = False): TLineInfo;\r\n\r\n function CustomVariantAsString(const Value: Variant): String;\r\n procedure SetDelphiVersion(const Value: TDelphiVersion);\r\n procedure InitCodeTracking(const SetBP: LongBool);\r\n procedure FillSystemUnits;\r\n\r\n Protected\r\n FImage: TJclPeBorTD32Image;\r\n\r\n function GetDBGFileName(const FileName: String): String;\r\n\r\n Function DoReadDebugInfo(Const FileName: String; ALoadDebugInfo: LongBool): LongBool; Override;\r\n Public\r\n Constructor Create;\r\n Destructor Destroy; Override;\r\n\r\n Function GetNameById(const Idx: TNameId): AnsiString; override;\r\n\r\n function ParseUnitName(UnitInfo: TUnitInfo; const WithExt: LongBool = True): String; override;\r\n function ParseFuncName(FuncInfo: TFuncInfo): String; override;\r\n function ParseTypeName(TypeInfo: TTypeInfo): String; override;\r\n function ParseConstName(ConstInfo: TConstInfo): String; override;\r\n function ParseVarName(VarInfo: TVarInfo): String; override;\r\n function ParseStructMemberName(StructMember: TStructMember): String; override;\r\n\r\n Procedure ClearDebugInfo; Override;\r\n\r\n Function HasDebugInfo(Const FileName: String): LongBool; Override;\r\n\r\n Function GetAddrInfo(Var Addr: Pointer; Const FileName: String; Line: Cardinal): TFindResult; Override;\r\n\r\n Function GetLineInfo(const Addr: Pointer; Var UnitInfo: TUnitInfo; Var FuncInfo: TFuncInfo; Var LineInfo: TLineInfo; GetPrevLine: LongBool): TFindResult; Override;\r\n\r\n Function MakeFuncDbgFullName(Const ClassName, MethodName: AnsiString): AnsiString; Override;\r\n Function MakeFuncShortName(Const MethodName: AnsiString): AnsiString; Override;\r\n Function MakeFuncNativeName(Const MethodName: AnsiString): AnsiString; Override;\r\n\r\n Function Evaluate(BriefMode: LongBool; Const Expression: String; Const TimeOut: Cardinal = INFINITE): String; Override;\r\n Function EvaluateVariable(VarInfo: TVarInfo): Variant; override;\r\n\r\n Function VarValueAsString(const Value: Variant): String; override;\r\n\r\n function GetSystemUnit: TUnitInfo;\r\n function GetMemoryManager: TVarInfo; virtual;\r\n function GetVMTClassName: TConstInfo;\r\n function SetDebugHook(const Value: Byte): LongBool;\r\n\r\n procedure SetMemoryManagerBreakpoints; Override;\r\n procedure ResetMemoryManagerBreakpoints; Override;\r\n\r\n Procedure InitDebugHook; Override;\r\n\r\n Function CheckAddr(Const Addr: Pointer): LongBool; Override;\r\n\r\n Function GetClassName(Const ObjectPtr: Pointer): String; Override;\r\n Function GetExceptionName(ExceptionRecord: PExceptionRecord): String; Override;\r\n Function GetExceptionMessage(ExceptionRecord: PExceptionRecord; Const ThreadId: TThreadId): String; Override;\r\n Function GetExceptionAddress(ExceptionRecord: PExceptionRecord): Pointer; Override;\r\n Function GetExceptionFrame(ExceptionRecord: PExceptionRecord): Pointer; Override;\r\n Function IsDelphiException(ExceptionRecord: PExceptionRecord): LongBool;\r\n Function IsDelphiTraceException(ExceptionRecord: PExceptionRecord): LongBool;\r\n Function CheckDebugException(ExceptionRecord: PExceptionRecord; Var IsTraceException: LongBool): LongBool; Override;\r\n Function CheckSystemFile(Const FileName: String): LongBool; Override;\r\n\r\n property DelphiVersion: TDelphiVersion read FDelphiVersion write SetDelphiVersion;\r\n End;\r\n\r\nFunction HasDelphiDebugInfo(Const AFileName: String): LongBool;\r\n\r\nImplementation\r\n\r\nUses\r\n JclDebug, JclPeImage, JclWin32,\r\n Math, Variants, ClassUtils, DebugHook, System.StrUtils, System.Contnrs, Vcl.Forms;\r\n\r\nConst\r\n cContinuable = 0;\r\n cNonContinuable = 1;\r\n cDelphiException = DWORD($0EEDFADE);\r\n cDelphiReRaise = DWORD($0EEDFADF);\r\n cDelphiExcept = DWORD($0EEDFAE0);\r\n cDelphiFinally = DWORD($0EEDFAE1);\r\n cDelphiTerminate = DWORD($0EEDFAE2);\r\n cDelphiUnhandled = DWORD($0EEDFAE3);\r\n cNonDelphiException = DWORD($0EEDFAE4);\r\n cDelphiExitFinally = DWORD($0EEDFAE5);\r\n\r\nFunction HasDelphiDebugInfo(Const AFileName: String): LongBool;\r\nVar\r\n PEImage: TJclPeBorTD32Image;\r\nBegin\r\n Result := FileExists(AFileName);\r\n If Result Then\r\n Begin\r\n PEImage := TJclPeBorTD32Image.Create(True);\r\n Try\r\n PEImage.FileName := AFileName;\r\n Result := PEImage.IsTD32DebugPresent;\r\n Finally\r\n PEImage.Free;\r\n End;\r\n End;\r\nEnd;\r\n\r\n{ TDelphiDebugInfo }\r\n\r\nConstructor TDelphiDebugInfo.Create;\r\nBegin\r\n Inherited Create;\r\n\r\n FImage := Nil;\r\n FDelphiVersion := dvAuto;\r\n FSystemUnits := TStringList.Create;\r\n FAddressInfoList := TAddressInfoList.Create(16 * 1024);\r\n FIsHookSet := False;\r\n\r\n FillSystemUnits;\r\nEnd;\r\n\r\nfunction TDelphiDebugInfo.CustomVariantAsString(const Value: Variant): String;\r\n//var\r\n// CustomVariantData: ICustomVariantData;\r\n// ToStringData: TToStringData;\r\nbegin\r\n Result := '#VALUE#';\r\n\r\n //TODO:\r\n\r\n// If Supports(IUnknown(TVarData(Value).VUnknown), ICustomVariantData, CustomVariantData) Then\r\n// begin\r\n// ToStringData.DebugInfo := Self;\r\n// ToStringData.Mode := tsmBrief;\r\n// ToStringData.RecursionLevel := 0;\r\n//\r\n// Result := CustomVariantData.AsString(ToStringData);\r\n// end\r\n// Else\r\n// Result := 'Unsupported data type';\r\nend;\r\n\r\nDestructor TDelphiDebugInfo.Destroy;\r\nBegin\r\n ClearDebugInfo;\r\n\r\n FreeAndNil(FImage);\r\n FreeAndNil(FSystemUnits);\r\n FreeAndNil(FAddressInfoList);\r\n\r\n Inherited Destroy;\r\nEnd;\r\n\r\nfunction TDelphiDebugInfo.ParseConstName(ConstInfo: TConstInfo): String;\r\nvar\r\n SL: TStringArray;\r\nbegin\r\n Result := inherited;\r\n\r\n if FUseShortNames then\r\n begin\r\n SplitStr(Result, '@', SL);\r\n Result := SL[ High(SL)];\r\n end;\r\nend;\r\n\r\nfunction TDelphiDebugInfo.ParseFuncName(FuncInfo: TFuncInfo): String;\r\nvar\r\n SL: TStringArray;\r\n Idx: Integer;\r\n S: String;\r\n P: Integer;\r\nbegin\r\n Result := inherited;\r\n\r\n if FUseShortNames then\r\n begin\r\n SplitStr(Result, '@', SL);\r\n\r\n Result := '';\r\n for Idx := 0 to High(SL) do\r\n begin\r\n S := SL[Idx];\r\n if S <> '' then\r\n begin\r\n if Result <> '' then\r\n Result := Result + '.';\r\n\r\n P := Pos('$qq', S);\r\n if P > 0 then\r\n SetLength(S, P - 1);\r\n\r\n Result := Result + S;\r\n\r\n if P > 0 then\r\n Break;\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TDelphiDebugInfo.ParseStructMemberName(StructMember: TStructMember): String;\r\nbegin\r\n Result := inherited;\r\nend;\r\n\r\nfunction TDelphiDebugInfo.ParseTypeName(TypeInfo: TTypeInfo): String;\r\nvar\r\n SL: TStringArray;\r\n Idx: Integer;\r\n S: String;\r\n P: Integer;\r\nbegin\r\n Result := inherited;\r\n\r\n if FUseShortNames then\r\n begin\r\n SplitStr(Result, '@', SL);\r\n\r\n Result := '';\r\n for Idx := 0 to High(SL) do\r\n begin\r\n S := SL[Idx];\r\n if S <> '' then\r\n begin\r\n if Result <> '' then\r\n Result := Result + '.';\r\n\r\n repeat\r\n P := Pos('$', S);\r\n if P > 0 then\r\n Delete(S, P, 3);\r\n until P <= 0;\r\n\r\n Result := Result + S;\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\nFunction TDelphiDebugInfo.ParseUnit(Module: TJclTD32ModuleInfo): TUnitInfo;\r\nBegin\r\n Result := TUnitInfo.Create;\r\n Result.SymbolInfo := Module;\r\n\r\n Result.NameId := Module.NameIndex;\r\n\r\n Units.AddObject(Result.ShortName, Result);\r\n UnitsByAddr.Add(Result);\r\n\r\n LoadSegments(Result, Module);\r\n LoadUsedUnits(Result, Module);\r\n LoadSymbols(Result, Module);\r\n LoadSourceModules(Result, Module);\r\nEnd;\r\n\r\nfunction TDelphiDebugInfo.ParseUnitName(UnitInfo: TUnitInfo; const WithExt: LongBool = True): String;\r\nbegin\r\n Result := inherited;\r\nend;\r\n\r\nfunction TDelphiDebugInfo.ParseVarName(VarInfo: TVarInfo): String;\r\nvar\r\n SL: TStringArray;\r\n Idx: Integer;\r\nbegin\r\n Result := inherited;\r\n\r\n if FUseShortNames then\r\n begin\r\n SplitStr(Result, '@', SL);\r\n\r\n Result := '';\r\n for Idx := 0 to High(SL) do\r\n if SL[Idx] <> '' then\r\n begin\r\n if Result <> '' then\r\n Result := Result + '.';\r\n\r\n Result := Result + SL[Idx];\r\n end;\r\n end;\r\nend;\r\n{ ............................................................................... }\r\n\r\nFunction TDelphiDebugInfo.GetUnitFileName(Const UnitName: String): String;\r\nVar\r\n S: String;\r\n Ext: String;\r\n ST: TUnitType;\r\nBegin\r\n S := AnsiLowerCase(ExtractFileName(UnitName));\r\n\r\n Ext := ExtractFileExt(S);\r\n If (Ext <> '.pas') and (Ext <> '.inc') and (Ext <> '.dpr') Then\r\n S := S + '.pas';\r\n\r\n for ST := Low(TUnitType) to High(TUnitType) do\r\n if Dirs[ST].TryGetValue(S, Result) then\r\n Exit;\r\n\r\n Result := S;\r\nEnd;\r\n\r\nfunction TDelphiDebugInfo.GetVMTClassName: TConstInfo;\r\nconst\r\n _vmtClassName = 'vmtClassName';\r\nVar\r\n USystem: TUnitInfo;\r\nbegin\r\n Result := Nil;\r\n\r\n USystem := GetSystemUnit;\r\n if Assigned(USystem) then\r\n Result := USystem.FindConstByName(_vmtClassName, True);\r\nend;\r\n\r\nfunction TDelphiDebugInfo.GetNameById(const Idx: TNameId): AnsiString;\r\nbegin\r\n Result := ImageNames(Idx);\r\nend;\r\n\r\nfunction TDelphiDebugInfo.GetSystemUnit: TUnitInfo;\r\nconst\r\n _SystemUnit: String = 'system.pas';\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := 0 to Units.Count - 1 do\r\n begin\r\n Result := TUnitInfo(Units.Objects[I]);\r\n if SameText(_SystemUnit, Result.ShortName) then\r\n Exit;\r\n end;\r\n\r\n Result := Nil;\r\nend;\r\n\r\nProcedure TDelphiDebugInfo.LoadSegments(UnitInfo: TUnitInfo; Module: TJclTD32ModuleInfo);\r\nVar\r\n I: Integer;\r\n SegmentInfo: TSegmentInfo;\r\n S: TUnitSegmentInfo;\r\nBegin\r\n UnitInfo.Segments.Capacity := Module.SegmentCount;\r\n For I := 0 To Module.SegmentCount - 1 Do\r\n Begin\r\n SegmentInfo := Module.Segment[I];\r\n\r\n S := TUnitSegmentInfo.Create;\r\n S.Address := Pointer(SegmentInfo.Offset + FImage.ImageSectionHeaders[SegmentInfo.Segment - 1].VirtualAddress + ImageBase);\r\n\r\n S.Size := SegmentInfo.Size;\r\n\r\n // $0000 Data segment\r\n // $0001 Code segment\r\n case SegmentInfo.Flags of\r\n $0000:\r\n S.SegmentClassInfo := GetSegmentByType(ustData);\r\n $0001:\r\n S.SegmentClassInfo := GetSegmentByType(ustCode);\r\n else\r\n RaiseDebugCoreException();\r\n end;\r\n\r\n if Assigned(S.SegmentClassInfo) then\r\n begin\r\n if (S.SegmentClassInfo.SegType = ustCode) and\r\n ((UnitInfo.Address = Nil) or (Cardinal(UnitInfo.Address) > Cardinal(S.Address)))\r\n then\r\n UnitInfo.Address := Pointer(S.Address);\r\n\r\n case S.SegmentClassInfo.SegType of\r\n ustData:\r\n Inc(UnitInfo.Size, S.Size);\r\n ustCode:\r\n Inc(UnitInfo.Size, S.Size);\r\n end;\r\n end\r\n else\r\n RaiseDebugCoreException('');\r\n\r\n UnitInfo.Segments.Add(S);\r\n End;\r\nEnd;\r\n\r\nprocedure TDelphiDebugInfo.LoadSourceLines(UnitInfo: TUnitInfo; UnitSourceModuleInfo: TUnitSourceModuleInfo; Source: TJclTD32SourceModuleInfo);\r\nVar\r\n I: Integer;\r\n LineInfo: TJclTD32LineInfo;\r\n L: TLineInfo;\r\n F: TFuncInfo;\r\nBegin\r\n UnitSourceModuleInfo.Lines.Capacity := Source.LineCount;\r\n For I := 0 To Source.LineCount - 1 Do\r\n Begin\r\n LineInfo := Source.Line[I];\r\n\r\n L := TLineInfo.Create;\r\n L.LineNo := LineInfo.LineNo; // - 1; ???\r\n L.Address := Pointer(LineInfo.Offset + FImage.ImageSectionHeaders[LineInfo.Segment - 1].VirtualAddress + ImageBase);\r\n L.SrcSegment := UnitSourceModuleInfo;\r\n\r\n UnitSourceModuleInfo.Lines.Add(L);\r\n\r\n UnitInfo.Lines.Add(L);\r\n\r\n F := FindFuncByAddr(UnitInfo, L.Address);\r\n If F <> Nil Then\r\n F.Lines.Add(L);\r\n End;\r\nend;\r\n\r\nprocedure TDelphiDebugInfo.LoadSourceModules(UnitInfo: TUnitInfo; Module: TJclTD32ModuleInfo);\r\nVar\r\n I: Integer;\r\n SourceModuleInfo: TJclTD32SourceModuleInfo;\r\n SM: TUnitSourceModuleInfo;\r\nbegin\r\n For I := 0 To Module.SourceModuleCount - 1 Do\r\n Begin\r\n SourceModuleInfo := Module.SourceModules[I];\r\n\r\n SM := TUnitSourceModuleInfo.Create;\r\n SM.UnitInfo := UnitInfo;\r\n SM.NameId := SourceModuleInfo.NameIndex;\r\n SM.SymbolInfo := SourceModuleInfo;\r\n\r\n //LoadLines(UnitInfo, SourceModuleInfo);\r\n LoadSourceLines(UnitInfo, SM, SourceModuleInfo);\r\n\r\n UnitInfo.SourceSegments.Add(SM);\r\n End;\r\nend;\r\n\r\nProcedure TDelphiDebugInfo.LoadUsedUnits(UnitInfo: TUnitInfo; Module: TJclTD32ModuleInfo);\r\nVar\r\n I: Integer;\r\n Idx: Integer;\r\n Name: String;\r\n UName: String;\r\nBegin\r\n UnitInfo.UsedUnits.Capacity := Module.UsedModuleNameIndexCount;\r\n For I := 0 To Module.UsedModuleNameIndexCount - 1 Do\r\n Begin\r\n Idx := Module.UsedModuleNameIndices[I];\r\n Name := String(ImageNames(Idx));\r\n UName := GetUnitFileName(Name);\r\n UnitInfo.UsedUnits.Add(UName);\r\n End;\r\nEnd;\r\n\r\n(*\r\nProcedure TDelphiDebugInfo.LoadLines(UnitInfo: TUnitInfo; Source: TJclTD32SourceModuleInfo);\r\nVar\r\n I: Integer;\r\n LineInfo: TJclTD32LineInfo;\r\n L: TLineInfo;\r\n F: TFuncInfo;\r\nBegin\r\n UnitInfo.Lines.Capacity := UnitInfo.Lines.Capacity + Source.LineCount;\r\n For I := 0 To Source.LineCount - 1 Do\r\n Begin\r\n LineInfo := Source.Line[I];\r\n\r\n L := TLineInfo.Create;\r\n L.LineNo := LineInfo.LineNo; // - 1; ???\r\n L.Address := Pointer(LineInfo.Offset + FImage.ImageSectionHeaders[LineInfo.Segment - 1].VirtualAddress + ImageBase);\r\n UnitInfo.Lines.Add(L);\r\n\r\n F := FindFuncByAddr(UnitInfo, L.Address);\r\n If F <> Nil Then\r\n F.Lines.Add(L);\r\n End;\r\nEnd;\r\n*)\r\n\r\nconst\r\n _DefJclSymbolTypeKindToTypeKind: array[Low(TJclSymbolTypeKind) .. High(TJclSymbolTypeKind)] of TTypeKind = (\r\n tkBoolean, tkWordBool, tkLongBool, tkShortInt,\r\n tkSmallInt, tkInteger, tkInt64, tkByte, tkWord, tkCardinal, tkUInt64,\r\n tkSingle, tkReal48, tkReal, tkExtended, tkCurrency, tkComplex, tkPString,\r\n tkLString, tkWString, tkChar, tkPointer, tkSubRange, tkArray, tkEnum,\r\n tkStructure, tkClass, tkSet, tkVariant, tkProperty, tkFieldList, tkClosure,\r\n tkClassRef, tkWideChar, tkProcedure, tkArgList, tkMFunction, tkVoid);\r\n\r\n\r\nFunction TDelphiDebugInfo.LoadType(UnitInfo: TUnitInfo; const TypeIndex: Integer; out DstType: TTypeInfo): Integer;\r\nVar\r\n SrcType: TJclSymbolTypeInfo;\r\n\r\n procedure _LoadPointerType;\r\n begin\r\n If SrcType.ElementType <> 0 Then\r\n Begin\r\n LoadType(UnitInfo, SrcType.ElementType, DstType.BaseType);\r\n If DstType.BaseType.Kind = tkClass Then\r\n DstType.Kind := tkObject\r\n Else If (DstType.BaseType.Kind = tkArray) And (DstType.BaseType.DataSize = -1) Then\r\n DstType.Kind := tkDynamicArray;\r\n End;\r\n end;\r\n\r\n procedure _LoadClassType;\r\n var\r\n I, J: Integer;\r\n SrcList: TJclSymbolTypeInfo;\r\n SrcMember: TJclTD32MemberSymbolInfo;\r\n SrcMemberType: TJclSymbolTypeInfo;\r\n DstMember: TStructMember;\r\n DstTypeMember: TStructMember;\r\n begin\r\n SrcList := FImage.TD32Scanner.SymbolTypes[SrcType.Elements];\r\n If SrcList.ElementType <> 0 Then\r\n LoadType(UnitInfo, SrcList.ElementType, DstType.BaseType);\r\n\r\n DstType.Members := TNameList.Create;\r\n DstType.Members.Capacity := SrcList.Members.Count;\r\n For I := 0 To SrcList.Members.Count - 1 Do\r\n Begin\r\n //DstMember := Nil;\r\n SrcMember := TJclTD32MemberSymbolInfo(SrcList.Members[I]);\r\n\r\n SrcMemberType := FImage.TD32Scanner.SymbolTypes[SrcMember.TypeIndex];\r\n\r\n if SrcMemberType = Nil then\r\n begin\r\n // TODO: - XE4 \r\n Continue;\r\n end;\r\n\r\n DstMember := TStructMember.Create;\r\n DstMember.NameId := SrcMember.NameIndex;\r\n DstMember.SymbolInfo := SrcMember;\r\n\r\n Case SrcMember.Flags And 3 Of\r\n 0, 3:\r\n DstMember.Scope := msPublic;\r\n 1:\r\n DstMember.Scope := msPrivate;\r\n 2:\r\n DstMember.Scope := msProtected;\r\n End;\r\n\r\n If SrcMemberType.Kind = stkClassRef Then\r\n LoadType(UnitInfo, SrcMemberType.ElementType, DstMember.DataType);\r\n\r\n If SrcMemberType.Kind <> stkProperty Then\r\n Begin\r\n If SrcMemberType.Kind <> stkClassRef Then\r\n LoadType(UnitInfo, SrcMember.TypeIndex, DstMember.DataType);\r\n DstMember.Offset := SrcMember.Offset;\r\n DstMember.DataSize := DstMember.DataType.DataSize;\r\n End\r\n Else\r\n Begin\r\n LoadType(UnitInfo, SrcMemberType.ElementType, DstMember.DataType);\r\n\r\n DstMember.IsDefault := (SrcMemberType.Flags And 1) = 1;\r\n\r\n If (SrcMemberType.Flags And 2) = 2 Then\r\n DstMember.MethodNameId := SrcMemberType.MinValue\r\n Else\r\n Begin\r\n DstMember.Offset := SrcMemberType.MinValue;\r\n DstMember.DataSize := DstMember.DataType.DataSize;\r\n End;\r\n\r\n For J := 0 To DstType.Members.Count - 1 Do\r\n Begin\r\n DstTypeMember := TStructMember(DstType.Members[J]);\r\n If DstTypeMember.Offset = SrcMemberType.MinValue Then\r\n Begin\r\n // TODO: , DstTypeMember\r\n DstMember.AliasNameId := DstTypeMember.NameId;\r\n Break;\r\n End;\r\n End;\r\n End;\r\n\r\n If DstMember <> Nil Then\r\n DstType.Members.Add(DstMember);\r\n End;\r\n end;\r\n\r\n procedure _LoadStructureType;\r\n var\r\n I: Integer;\r\n SrcList: TJclSymbolTypeInfo;\r\n DstMember: TStructMember;\r\n SrcMember: TJclTD32MemberSymbolInfo;\r\n begin\r\n SrcList := FImage.TD32Scanner.SymbolTypes[SrcType.Elements];\r\n\r\n DstType.Members := TNameList.Create;\r\n DstType.Members.Capacity := SrcList.Members.Count;\r\n For I := 0 To SrcList.Members.Count - 1 Do\r\n Begin\r\n SrcMember := TJclTD32MemberSymbolInfo(SrcList.Members[I]);\r\n\r\n DstMember := TStructMember.Create;\r\n DstMember.NameId := SrcMember.NameIndex;\r\n DstMember.SymbolInfo := SrcMember;\r\n DstMember.Scope := msPublic;\r\n\r\n LoadType(UnitInfo, SrcMember.TypeIndex, DstMember.DataType);\r\n\r\n DstMember.Offset := SrcMember.Offset;\r\n DstMember.DataSize := DstMember.DataType.DataSize;\r\n\r\n DstType.Members.Add(DstMember);\r\n End;\r\n end;\r\n\r\n procedure _LoadEnumType;\r\n var\r\n I: Integer;\r\n SrcList: TJclSymbolTypeInfo;\r\n SrcEnum: TJclEnumerateSymbolInfo;\r\n EnumMember: TEnumInfo;\r\n begin\r\n DstType.Elements := TNameList.Create;\r\n\r\n DstType.DataSize := FImage.TD32Scanner.SymbolTypes[SrcType.ElementType].DataSize;\r\n DstType.MinValue := High(DstType.MinValue);\r\n DstType.MaxValue := Low(DstType.MaxValue);\r\n\r\n SrcList := FImage.TD32Scanner.SymbolTypes[SrcType.Elements];\r\n DstType.Elements.Capacity := SrcList.Members.Count;\r\n For I := 0 To SrcList.Members.Count - 1 Do\r\n Begin\r\n SrcEnum := TJclEnumerateSymbolInfo(SrcList.Members[I]);\r\n\r\n EnumMember := TEnumInfo.Create;\r\n EnumMember.NameId := SrcEnum.NameIndex;\r\n EnumMember.SymbolInfo := SrcEnum;\r\n\r\n EnumMember.TypeInfo := DstType;\r\n EnumMember.OrderValue := SrcEnum.Value;\r\n\r\n DstType.Elements.Add(EnumMember);\r\n\r\n If SrcEnum.Value < DstType.MinValue Then\r\n DstType.MinValue := SrcEnum.Value;\r\n If SrcEnum.Value > DstType.MaxValue Then\r\n DstType.MaxValue := SrcEnum.Value;\r\n End;\r\n end;\r\n\r\n procedure _LoadSubRangeType;\r\n var\r\n SrcList: TJclSymbolTypeInfo;\r\n begin\r\n DstType.MinValue := SrcType.MinValue;\r\n DstType.MaxValue := SrcType.MaxValue;\r\n\r\n SrcList := FImage.TD32Scanner.SymbolTypes[SrcType.IndexType];\r\n Case SrcList.Kind Of\r\n stkBoolean, stkWordBool, stkLongBool:\r\n Case DstType.DataSize Of\r\n 1:\r\n DstType.Kind := tkBoolean;\r\n 2:\r\n DstType.Kind := tkWordBool;\r\n 4:\r\n DstType.Kind := tkLongBool;\r\n End;\r\n stkChar, stkWideChar:\r\n Case DstType.DataSize Of\r\n 1:\r\n DstType.Kind := tkChar;\r\n 2:\r\n DstType.Kind := tkWideChar;\r\n End;\r\n Else\r\n Case DstType.DataSize Of\r\n 1:\r\n Case SrcList.Kind Of\r\n stkShortInt, stkSmallInt, stkInteger:\r\n DstType.Kind := tkShortInt;\r\n Else\r\n DstType.Kind := tkByte;\r\n End;\r\n 2:\r\n Case SrcList.Kind Of\r\n stkShortInt, stkSmallInt, stkInteger:\r\n DstType.Kind := tkSmallInt;\r\n Else\r\n DstType.Kind := tkWord;\r\n End;\r\n 4:\r\n Case SrcList.Kind Of\r\n stkShortInt, stkSmallInt, stkInteger:\r\n DstType.Kind := tkInteger;\r\n Else\r\n DstType.Kind := tkCardinal;\r\n End;\r\n End;\r\n End;\r\n end;\r\n\r\n procedure _LoadArrayType;\r\n var\r\n SrcList: TJclSymbolTypeInfo;\r\n begin\r\n LoadType(UnitInfo, SrcType.IndexType, DstType.IndexType);\r\n LoadType(UnitInfo, SrcType.ElementType, DstType.BaseType);\r\n DstType.DataSize := SrcType.DataSize;\r\n\r\n SrcList := FImage.TD32Scanner.SymbolTypes[SrcType.IndexType];\r\n Case SrcList.Kind Of\r\n stkSubRange:\r\n Begin\r\n DstType.MinValue := SrcList.MinValue;\r\n DstType.MaxValue := SrcList.MaxValue;\r\n End\r\n Else\r\n begin\r\n DstType.MinValue := DstType.IndexType.MinValue;\r\n DstType.MaxValue := DstType.IndexType.MaxValue;\r\n end;\r\n End;\r\n end;\r\n\r\nBegin\r\n SrcType := FImage.TD32Scanner.SymbolTypes[TypeIndex];\r\n\r\n If (SrcType <> Nil) and (SrcType.UnitInfo = UnitInfo) Then\r\n begin\r\n Result := SrcType.UnitInfoIndex;\r\n DstType := TTypeInfo(UnitInfo.Types[Result]);\r\n Exit;\r\n end;\r\n\r\n DstType := TTypeInfo.Create;\r\n DstType.Kind := tkVoid;\r\n DstType.DataSize := SizeOf(Pointer);\r\n DstType.UnitInfo := UnitInfo;\r\n DstType.NameId := -1;\r\n DstType.SymbolInfo := SrcType;\r\n\r\n DstType.TypeInfoIdx := UnitInfo.Types.Add(DstType);\r\n Result := DstType.TypeInfoIdx;\r\n\r\n if SrcType = Nil then\r\n Exit;\r\n\r\n SrcType.UnitInfo := UnitInfo;\r\n SrcType.UnitInfoIndex := DstType.TypeInfoIdx;\r\n\r\n DstType.NameId := SrcType.NameIndex;\r\n DstType.Kind := _DefJclSymbolTypeKindToTypeKind[SrcType.Kind];\r\n DstType.DataSize := SrcType.DataSize;\r\n\r\n Case SrcType.Kind Of\r\n stkBoolean:\r\n Begin\r\n DstType.MinValue := 0;\r\n DstType.MaxValue := 1;\r\n End;\r\n stkWordBool:\r\n Begin\r\n DstType.MinValue := 0;\r\n DstType.MaxValue := 1;\r\n End;\r\n stkLongBool:\r\n Begin\r\n DstType.MinValue := 0;\r\n DstType.MaxValue := 1;\r\n End;\r\n stkShortInt:\r\n Begin\r\n DstType.MinValue := Low(ShortInt);\r\n DstType.MaxValue := High(ShortInt);\r\n End;\r\n stkSmallInt:\r\n Begin\r\n DstType.MinValue := Low(SmallInt);\r\n DstType.MaxValue := High(SmallInt);\r\n End;\r\n stkInteger:\r\n Begin\r\n DstType.MinValue := Low(Integer);\r\n DstType.MaxValue := High(Integer);\r\n End;\r\n stkInt64: ;\r\n stkByte:\r\n Begin\r\n DstType.MinValue := Low(Byte);\r\n DstType.MaxValue := High(Byte);\r\n End;\r\n stkWord:\r\n Begin\r\n DstType.MinValue := Low(Word);\r\n DstType.MaxValue := High(Word);\r\n End;\r\n stkCardinal:\r\n Begin\r\n DstType.MinValue := Low(Cardinal);\r\n Cardinal(DstType.MaxValue) := High(Cardinal);\r\n End;\r\n stkUInt64: ;\r\n stkSingle: ;\r\n stkReal48: ;\r\n stkReal: ;\r\n stkExtended: ;\r\n stkCurrency: ;\r\n stkComplex: ;\r\n stkPString:\r\n Begin\r\n DstType.DataSize := SizeOf(ShortString);\r\n LoadType(UnitInfo, SrcType.IndexType, DstType.BaseType);\r\n End;\r\n stkLString:\r\n Begin\r\n DstType.DataSize := SizeOf(AnsiString);\r\n LoadType(UnitInfo, SrcType.ElementType, DstType.BaseType);\r\n End;\r\n stkWString:\r\n Begin\r\n DstType.DataSize := SizeOf(WideString);\r\n LoadType(UnitInfo, SrcType.ElementType, DstType.BaseType);\r\n End;\r\n stkChar:\r\n Begin\r\n DstType.MinValue := 0;\r\n DstType.MaxValue := Ord(High(AnsiChar));\r\n End;\r\n stkPointer:\r\n Begin\r\n _LoadPointerType;\r\n End;\r\n stkSubRange:\r\n Begin\r\n _LoadSubRangeType;\r\n End;\r\n stkArray:\r\n Begin\r\n _LoadArrayType;\r\n End;\r\n stkEnum:\r\n Begin\r\n _LoadEnumType;\r\n End;\r\n stkStructure:\r\n Begin\r\n _LoadStructureType;\r\n End;\r\n stkClass:\r\n Begin\r\n _LoadClassType;\r\n End;\r\n stkSet:\r\n Begin\r\n LoadType(UnitInfo, SrcType.ElementType, DstType.BaseType);\r\n DstType.DataSize := SrcType.DataSize;\r\n End;\r\n stkVariant: ; // ???\r\n stkProperty:\r\n Begin\r\n // TODO:\r\n End;\r\n stkFieldList: ; // ???\r\n stkClosure:\r\n Begin\r\n DstType.Kind := tkPointer;\r\n End;\r\n stkClassRef:\r\n Begin\r\n // TODO:\r\n End;\r\n stkWideChar:\r\n Begin\r\n DstType.MinValue := Low(Word);\r\n DstType.MaxValue := High(Word);\r\n End;\r\n stkProcedure:\r\n Begin\r\n // TODO: Params\r\n End;\r\n stkArgList: ;\r\n stkMFunction: ;\r\n stkVoid: ;\r\n else\r\n Begin\r\n SrcType.Kind := SrcType.Kind;\r\n RaiseDebugCoreException();\r\n End;\r\n End;\r\nEnd;\r\n\r\nProcedure TDelphiDebugInfo.LoadConst(OwnerInfo: TSegmentCodeInfo; ConstSymbol: TJclTD32ConstantSymbolInfo);\r\nVar\r\n ConstInfo: TConstInfo;\r\n TypeInfo: TJclSymbolTypeInfo;\r\n ConstName: String;\r\n\r\n procedure LoadExtended;\r\n //var\r\n // ExtValue: Extended;\r\n begin\r\n //ExtValue := PExtended(ConstSymbol.Value)^;\r\n //TODO: ConstInfo.Value := IUnknown(TExtendedConstantValue.Create(ExtValue));\r\n end;\r\n\r\n procedure LoadSet;\r\n var\r\n SetValue: TBytes;\r\n begin\r\n SetLength(SetValue, 32);\r\n Move(ConstSymbol.Value^, SetValue[TypeInfo.MinValue], ConstSymbol.Size);\r\n LoadType(ConstInfo.UnitInfo, ConstSymbol.TypeIndex, ConstInfo.TypeInfo);\r\n //TODO: ConstInfo.Value := IUnknown(TSetVariantValue.Create(ConstInfo.TypeInfo, SetValue));\r\n end;\r\n\r\n procedure LoadSubRange;\r\n begin\r\n LoadType(ConstInfo.UnitInfo, ConstSymbol.TypeIndex, ConstInfo.TypeInfo);\r\n //TODO: ConstInfo.Value := GetValueNonRef(Nil, ConstInfo.TypeInfo, TUIntPtr(ConstSymbol.Value^), False);\r\n end;\r\n\r\nBegin\r\n ConstInfo := Nil;\r\n TypeInfo := FImage.TD32Scanner.SymbolTypes[ConstSymbol.TypeIndex];\r\n If TypeInfo <> Nil Then\r\n try\r\n ConstInfo := TConstInfo.Create;\r\n ConstInfo.Owner := OwnerInfo;\r\n ConstInfo.NameId := ConstSymbol.NameIndex;\r\n ConstInfo.SymbolInfo := ConstSymbol;\r\n LoadType(ConstInfo.UnitInfo, ConstSymbol.TypeIndex, ConstInfo.TypeInfo);\r\n\r\n Case TypeInfo.Kind Of\r\n stkBoolean:\r\n ConstInfo.Value := PBoolean(ConstSymbol.Value)^;\r\n stkWordBool:\r\n ConstInfo.Value := PWordBool(ConstSymbol.Value)^;\r\n stkLongBool:\r\n ConstInfo.Value := PBool(ConstSymbol.Value)^;\r\n stkShortInt:\r\n ConstInfo.Value := PShortInt(ConstSymbol.Value)^;\r\n stkSmallInt:\r\n ConstInfo.Value := PSmallInt(ConstSymbol.Value)^;\r\n stkInteger:\r\n ConstInfo.Value := PInteger(ConstSymbol.Value)^;\r\n stkInt64:\r\n ConstInfo.Value := PInt64(ConstSymbol.Value)^;\r\n stkByte:\r\n ConstInfo.Value := PByte(ConstSymbol.Value)^;\r\n stkWord:\r\n ConstInfo.Value := PWord(ConstSymbol.Value)^;\r\n stkCardinal:\r\n ConstInfo.Value := PCardinal(ConstSymbol.Value)^;\r\n stkUInt64:\r\n ConstInfo.Value := PUInt64(ConstSymbol.Value)^;\r\n stkSingle:\r\n ConstInfo.Value := PSingle(ConstSymbol.Value)^;\r\n stkReal48:\r\n ConstInfo.Value := PReal48(ConstSymbol.Value)^;\r\n stkReal:\r\n ConstInfo.Value := PReal(ConstSymbol.Value)^;\r\n stkExtended:\r\n LoadExtended;\r\n stkCurrency:\r\n ConstInfo.Value := PCurrency(ConstSymbol.Value)^;\r\n stkPointer:\r\n //TODO: ConstInfo.Value := IUnknown(TPointerConstantValue.Create(PPointer(ConstSymbol.Value)^));\r\n ConstInfo.Value := '#PTR_CONST#';\r\n stkLString, stkWString:\r\n ConstInfo.Value := '#STR_CONST#';\r\n stkSet:\r\n LoadSet;\r\n stkSubRange:\r\n LoadSubRange;\r\n Else\r\n FreeAndNil(ConstInfo);\r\n End;\r\n except\r\n on E: Exception do\r\n begin\r\n ConstName := String(ImageNames(ConstSymbol.NameIndex));\r\n RaiseDebugCoreException(Format('%s.%s', [ConstInfo.UnitInfo.Name, ConstName]));\r\n end;\r\n end;\r\n\r\n If ConstInfo <> Nil Then\r\n Begin\r\n If ConstInfo.Owner is TFuncInfo Then\r\n TFuncInfo(ConstInfo.Owner).Consts.Add(ConstInfo)\r\n Else\r\n ConstInfo.UnitInfo.Consts.Add(ConstInfo);\r\n End;\r\nEnd;\r\n\r\nFunction TDelphiDebugInfo.RegisterIndex(const Index: Byte): Integer;\r\nBegin\r\n Case Index Of\r\n 1, 5, 9, 17:\r\n Result := 0;\r\n 2, 6, 10, 18:\r\n Result := 1;\r\n 3, 7, 11, 19:\r\n Result := 2;\r\n 4, 8, 12, 20:\r\n Result := 3;\r\n 13, 21:\r\n Result := 4;\r\n 14, 22:\r\n Result := 5;\r\n 15, 23:\r\n Result := 6;\r\n 16, 24:\r\n Result := 7;\r\n 31, 33:\r\n Result := 8;\r\n Else\r\n Result := -1;\r\n End;\r\n\r\n Case Index Of\r\n 1, 2, 3, 4:\r\n Result := Result Or (1 Shl 4);\r\n 5, 6, 7, 8:\r\n Result := Result Or (2 Shl 4);\r\n 9, 10, 11, 12, 13, 14, 15, 16, 31:\r\n Result := Result Or (3 Shl 4);\r\n End;\r\nEnd;\r\n\r\nFunction TDelphiDebugInfo.LoadVar(UnitInfo: TUnitInfo; VarSymbol: TJclTD32NamedSymbol; Func: TFuncInfo): TVarInfo;\r\n\r\n procedure LoadRegister(VarInfo: TVarInfo);\r\n Var\r\n I: Integer;\r\n RegInfo: TRegInfo;\r\n RegRange: PRegisterRange;\r\n begin\r\n VarInfo.VarKind := vkRegister;\r\n VarInfo.Offset := RegisterIndex(TJclTD32RegisterSymbolInfo(VarSymbol).Registers);\r\n VarInfo.RegisterRanges := TList.Create;\r\n\r\n For I := 0 To TJclTD32RegisterSymbolInfo(VarSymbol).RangeCount - 1 Do\r\n begin\r\n RegRange := TJclTD32RegisterSymbolInfo(VarSymbol).Range[I];\r\n\r\n RegInfo := TRegInfo.Create;\r\n RegInfo.StartOffset := Cardinal(Func.Address) + RegRange^.Start;\r\n RegInfo.EndOffset := RegInfo.StartOffset + RegRange^.Len;\r\n RegInfo.RegisterIndex := RegisterIndex(RegRange^.Registers);\r\n\r\n VarInfo.RegisterRanges.Add(RegInfo);\r\n end;\r\n end;\r\n\r\nBegin\r\n Result := TVarInfo.Create;\r\n Result.SymbolInfo := VarSymbol;\r\n\r\n Case VarSymbol.SymbolType Of\r\n SYMBOL_TYPE_REGISTER:\r\n Begin\r\n LoadRegister(Result);\r\n End;\r\n SYMBOL_TYPE_BPREL32:\r\n Begin\r\n Result.VarKind := vkStack;\r\n Result.Offset := TJclTD32BPRel32SymbolInfo(VarSymbol).Offset;\r\n End;\r\n SYMBOL_TYPE_LDATA32, SYMBOL_TYPE_GDATA32:\r\n Begin\r\n Result.VarKind := vkGlobal;\r\n Result.Offset := TJclTD32DataSymbolInfo(VarSymbol).Offset + FImage.ImageSectionHeaders[TJclTD32DataSymbolInfo(VarSymbol).Segment - 1]\r\n .VirtualAddress + ImageBase;\r\n End;\r\n SYMBOL_TYPE_SLINK32:\r\n Begin\r\n Result.VarKind := vkLink;\r\n Result.Offset := TJclTD32LinkSymbolInfo(VarSymbol).Offset;\r\n End;\r\n End;\r\n\r\n If VarSymbol.SymbolType = SYMBOL_TYPE_SLINK32 Then\r\n begin\r\n Result.NameId := -1;\r\n end\r\n Else\r\n Begin\r\n Result.NameId := VarSymbol.NameIndex;\r\n LoadType(UnitInfo, VarSymbol.TypeIndex, Result.DataType);\r\n End;\r\n\r\n If Func <> Nil Then\r\n begin\r\n Result.Owner := Func;\r\n Func.Vars.Add(Result)\r\n end\r\n Else\r\n begin\r\n Result.Owner := UnitInfo;\r\n UnitInfo.Vars.Add(Result);\r\n end;\r\nEnd;\r\n\r\nProcedure TDelphiDebugInfo.LoadSymbols(UnitInfo: TUnitInfo; Module: TJclTD32ModuleInfo);\r\nVar\r\n I: Integer;\r\n SymbolInfo: TJclTD32SymbolInfo;\r\nBegin\r\n UnitInfo.Types.Capacity := 128;\r\n UnitInfo.Funcs.Capacity := 128;\r\n UnitInfo.FuncsByAddr.Capacity := 128;\r\n UnitInfo.Vars.Capacity := 32;\r\n UnitInfo.Consts.Capacity := 32;\r\n\r\n For I := 0 To Module.SymbolCount - 1 Do\r\n begin\r\n SymbolInfo := Module.Symbols[I];\r\n Case SymbolInfo.SymbolType Of\r\n SYMBOL_TYPE_PCONSTANT:\r\n LoadConst(UnitInfo, TJclTD32ConstantSymbolInfo(SymbolInfo));\r\n SYMBOL_TYPE_BPREL32, SYMBOL_TYPE_LDATA32, SYMBOL_TYPE_GDATA32, SYMBOL_TYPE_SLINK32:\r\n LoadVar(UnitInfo, TJclTD32NamedSymbol(SymbolInfo), Nil);\r\n SYMBOL_TYPE_LPROC32, SYMBOL_TYPE_GPROC32:\r\n LoadFunc(UnitInfo, TJclTD32ProcSymbolInfo(SymbolInfo));\r\n End;\r\n end;\r\nEnd;\r\n\r\nProcedure TDelphiDebugInfo.LoadFunc(UnitInfo: TUnitInfo; FuncSymbol: TJclTD32ProcSymbolInfo);\r\nVar\r\n I: Integer;\r\n ProcInfo: TJclSymbolTypeInfo;\r\n FuncInfo: TFuncInfo;\r\n SymbolInfo: TJclTD32SymbolInfo;\r\n VarInfo: TVarInfo;\r\nBegin\r\n FuncInfo := TFuncInfo.Create;\r\n FuncInfo.NameId := FuncSymbol.NameIndex;\r\n FuncInfo.SymbolInfo := FuncSymbol;\r\n FuncInfo.Address := Pointer(FuncSymbol.Offset + FImage.ImageSectionHeaders[FuncSymbol.Segment - 1].VirtualAddress + ImageBase);\r\n FuncInfo.Size := FuncSymbol.Size;\r\n FuncInfo.UnitInfo := UnitInfo;\r\n FuncInfo.ID := FuncSymbol;\r\n FuncInfo.ParentID := FuncSymbol.Parent;\r\n\r\n ProcInfo := FImage.TD32Scanner.SymbolTypes[FuncSymbol.TypeIndex];\r\n LoadType(UnitInfo, ProcInfo.IndexType, FuncInfo.ResultType);\r\n\r\n FuncInfo.Vars.Capacity := 8;\r\n\r\n For I := 0 To FuncSymbol.SymbolCount - 1 Do\r\n begin\r\n SymbolInfo := FuncSymbol.Symbols[I];\r\n Case SymbolInfo.SymbolType Of\r\n SYMBOL_TYPE_PCONSTANT:\r\n LoadConst(FuncInfo, TJclTD32ConstantSymbolInfo(SymbolInfo));\r\n SYMBOL_TYPE_SLINK32:\r\n LoadVar(UnitInfo, TJclTD32NamedSymbol(SymbolInfo), FuncInfo);\r\n SYMBOL_TYPE_REGISTER, SYMBOL_TYPE_BPREL32, SYMBOL_TYPE_LDATA32, SYMBOL_TYPE_GDATA32:\r\n Begin\r\n VarInfo := LoadVar(UnitInfo, TJclTD32NamedSymbol(SymbolInfo), FuncInfo);\r\n FuncInfo.Params.Add(VarInfo);\r\n End;\r\n End;\r\n end;\r\n\r\n UnitInfo.Funcs.Add(FuncInfo);\r\n UnitInfo.FuncsByAddr.Add(FuncInfo);\r\nEnd;\r\n\r\nprocedure TDelphiDebugInfo.ResetMemoryManagerBreakpoints;\r\nbegin\r\n // gvDebuger.MemoryBPCheckMode := False;\r\n\r\n if MemoryManagerInfo.VarInfo = nil then Exit;\r\n\r\n if MemoryManagerInfo.GetMem <> nil then\r\n gvDebuger.DbgCodeProfiler.RemoveTrackBreakpoint(MemoryManagerInfo.GetMem.Address, tbMemInfo);\r\n if MemoryManagerInfo.FreeMem <> nil then\r\n gvDebuger.DbgCodeProfiler.RemoveTrackBreakpoint(MemoryManagerInfo.FreeMem.Address, tbMemInfo);\r\n if MemoryManagerInfo.ReallocMem <> nil then\r\n gvDebuger.DbgCodeProfiler.RemoveTrackBreakpoint(MemoryManagerInfo.ReallocMem.Address, tbMemInfo);\r\n if MemoryManagerInfo.AllocMem <> nil then\r\n gvDebuger.DbgCodeProfiler.RemoveTrackBreakpoint(MemoryManagerInfo.AllocMem.Address, tbMemInfo);\r\n\r\n gvDebuger.Log('Reset slow memory manager hook - ok');\r\nend;\r\n\r\nProcedure TDelphiDebugInfo.ResolveUnits;\r\nVar\r\n I, J, U: Integer;\r\n Member: TStructMember;\r\n UInfo: TUnitInfo;\r\n TInfo: TTypeInfo;\r\n FuncJ, FuncU: TFuncInfo;\r\nBegin\r\n if Units.Count = 0 then\r\n Exit;\r\n\r\n Units.Sorted := True;\r\n\r\n For I := 0 To Units.Count - 1 Do\r\n Begin\r\n UInfo := TUnitInfo(Units.Objects[I]);\r\n\r\n // DoProgress(Format('Check unit \"%s\"', [UInfo.Name]), 90 + Round((I + 1) * Delta));\r\n\r\n For J := 0 To UInfo.UsedUnits.Count - 1 Do\r\n Begin\r\n U := Units.IndexOf(UInfo.UsedUnits[J]);\r\n If U <> -1 Then\r\n UInfo.UsedUnits.Objects[J] := Units.Objects[U];\r\n End;\r\n\r\n For J := 0 To UInfo.Types.Count - 1 Do\r\n Begin\r\n TInfo := TTypeInfo(UInfo.Types[J]);\r\n If TInfo.Members <> Nil Then\r\n For U := 0 To TInfo.Members.Count - 1 Do\r\n Begin\r\n Member := TStructMember(TInfo.Members[U]);\r\n If (Member.MethodNameId <> 0) then\r\n Member.Method := UInfo.FindFuncByNameId(Member.MethodNameId);\r\n End;\r\n End;\r\n\r\n UInfo.FuncsByAddr.Capacity := UInfo.Funcs.Count;\r\n For J := 0 To UInfo.Funcs.Count - 1 Do\r\n begin\r\n FuncJ := TFuncInfo(UInfo.Funcs[J]);\r\n\r\n For U := 0 To UInfo.Funcs.Count - 1 Do\r\n begin\r\n FuncU := TFuncInfo(UInfo.Funcs[U]);\r\n If FuncJ.ID = FuncU.ParentID Then\r\n FuncU.Parent := FuncJ;\r\n end;\r\n end;\r\n End;\r\nEnd;\r\n\r\nfunction TDelphiDebugInfo.SetDebugHook(const Value: Byte): LongBool;\r\nConst\r\n _DebugHook: AnsiString = 'DebugHook';\r\n\r\n // Value:\r\n // 1 to notify debugger of non-Delphi exceptions\r\n // >1 to notify debugger of exception unwinding\r\nVar\r\n USystem: TUnitInfo;\r\n DebugHook: TVarInfo;\r\nbegin\r\n Result := False;\r\n\r\n USystem := GetSystemUnit;\r\n if Assigned(USystem) then\r\n begin\r\n DebugHook := USystem.FindVarByName(_DebugHook, True);\r\n If Assigned(DebugHook) Then\r\n gvDebuger.WriteData(Pointer(DebugHook.Offset), @Value, SizeOf(Byte));\r\n end;\r\nend;\r\n\r\nprocedure TDelphiDebugInfo.SetDelphiVersion(const Value: TDelphiVersion);\r\nbegin\r\n FDelphiVersion := Value;\r\nend;\r\n\r\n\r\nprocedure TDelphiDebugInfo.SetMemoryManagerBreakpoints;\r\nvar\r\n Members: TNameList;\r\n Member: TStructMember;\r\n Addr: Pointer;\r\n\r\n function _GetFuncPtr: Pointer;\r\n var\r\n Offset: Pointer;\r\n begin\r\n if Member = nil then\r\n RaiseDebugCoreException();\r\n\r\n Result := nil;\r\n Offset := Pointer(MemoryManagerInfo.VarInfo.Offset + Member.Offset);\r\n if not gvDebuger.ReadData(Offset, @Result, SizeOf(Pointer)) then\r\n RaiseDebugCoreException();\r\n end;\r\n\r\n function _SetTrackBreakpoint(Addr: Pointer): TFuncInfo;\r\n var\r\n UnitInfo: TUnitInfo;\r\n LineInfo: TLineInfo;\r\n begin\r\n Result := Nil;\r\n\r\n if GetLineInfo(Addr, UnitInfo, Result, LineInfo, False) <> slNotFound then\r\n gvDebuger.DbgCodeProfiler.SetTrackBreakpoint(Addr, Result, tbMemInfo)\r\n else\r\n RaiseDebugCoreException();\r\n end;\r\n\r\nbegin\r\n if MemoryManagerInfo.VarInfo = nil then Exit;\r\n\r\n if MemoryManagerInfo.VarInfo.DataType = nil then Exit;\r\n\r\n Members := MemoryManagerInfo.VarInfo.DataType.Members;\r\n if Assigned(Members) and (Members.Count > 0) then\r\n begin\r\n gvDebuger.MemoryBPCheckMode := True;\r\n\r\n Member := TStructMember(Members.FindByName('GetMem'));\r\n Addr := _GetFuncPtr;\r\n MemoryManagerInfo.GetMem := _SetTrackBreakpoint(Addr);\r\n\r\n Member := TStructMember(Members.FindByName('FreeMem'));\r\n Addr := _GetFuncPtr;\r\n MemoryManagerInfo.FreeMem := _SetTrackBreakpoint(Addr);\r\n\r\n Member := TStructMember(Members.FindByName('ReallocMem'));\r\n Addr := _GetFuncPtr;\r\n MemoryManagerInfo.ReallocMem := _SetTrackBreakpoint(Addr);\r\n\r\n Member := TStructMember(Members.FindByName('AllocMem'));\r\n Addr := _GetFuncPtr;\r\n MemoryManagerInfo.AllocMem := _SetTrackBreakpoint(Addr);\r\n\r\n gvDebuger.Log('Set slow memory manager hook - ok');\r\n end;\r\nend;\r\n\r\nfunction TDelphiDebugInfo.VarValueAsString(const Value: Variant): String;\r\nbegin\r\n if VarType(Value) = varUnknown then\r\n Result := CustomVariantAsString(Value)\r\n else\r\n Result := VarToStrDef(Value, '');\r\nend;\r\n\r\nFunction TDelphiDebugInfo.FindUnitByAddr(const Addr: Pointer): TUnitInfo;\r\nvar\r\n I, J: Integer;\r\n Segment: TUnitSegmentInfo;\r\nBegin\r\n // TODO:\r\n //Result := TUnitInfo(UnitsByAddr.FindByAddress(Addr));\r\n\r\n for I := 0 to Units.Count - 1 do\r\n begin\r\n Result := TUnitInfo(Units.Objects[I]);\r\n for J := 0 to Result.Segments.Count - 1 do\r\n begin\r\n Segment := Result.Segments[J];\r\n\r\n if Assigned(Segment.SegmentClassInfo) and (Segment.SegmentClassInfo.SegType = ustCode) and\r\n (Cardinal(Addr) >= Cardinal(Segment.Address)) and (Cardinal(Addr) <= (Cardinal(Segment.Address) + Segment.Size))\r\n then\r\n Exit;\r\n end;\r\n end;\r\n\r\n Result := Nil;\r\nEnd;\r\n\r\nprocedure TDelphiDebugInfo.FillSystemUnits;\r\nbegin\r\n FSystemUnits.Clear;\r\n FSystemUnits.Sorted := False;\r\n FSystemUnits.CaseSensitive := False;\r\n\r\n FSystemUnits.Add('System');\r\n FSystemUnits.Add('Classes');\r\n FSystemUnits.Add('Windows');\r\n FSystemUnits.Add('SysUtils');\r\n FSystemUnits.Add('Variants');\r\n FSystemUnits.Add('StrUtils');\r\n FSystemUnits.Add('WideStrUtils');\r\n FSystemUnits.Add('XMLDoc');\r\n FSystemUnits.Add('XMLIntf');\r\n FSystemUnits.Add('Graphics');\r\n FSystemUnits.Add('Forms');\r\n FSystemUnits.Add('Controls');\r\n FSystemUnits.Add('StdCtrls');\r\n FSystemUnits.Add('ExtCtrls');\r\n FSystemUnits.Add('ComCtrls');\r\n FSystemUnits.Add('Buttons');\r\n FSystemUnits.Add('ActnList');\r\n FSystemUnits.Add('Mask');\r\n FSystemUnits.Add('Dialogs');\r\n\r\n FSystemUnits.Add('WinApi');\r\n FSystemUnits.Add('Vcl');\r\n FSystemUnits.Add('Soap');\r\n FSystemUnits.Add('Xml');\r\n FSystemUnits.Add('Web');\r\n FSystemUnits.Add('Data');\r\n\r\n (*\r\n FSystemUnits.Add('acPNG');\r\n FSystemUnits.Add('sCommonData');\r\n FSystemUnits.Add('acZLibEx');\r\n FSystemUnits.Add('sVclUtils');\r\n FSystemUnits.Add('sLabel');\r\n FSystemUnits.Add('sSkinProvider');\r\n FSystemUnits.Add('sSkinManager');\r\n FSystemUnits.Add('sGraphUtils');\r\n FSystemUnits.Add('acntUtils');\r\n *)\r\n\r\n FSystemUnits.Sorted := True;\r\nend;\r\n\r\nFunction TDelphiDebugInfo.FindFuncByAddr(const UnitInfo: TUnitInfo; const Addr: Pointer): TFuncInfo;\r\nVar\r\n I: Integer;\r\nBegin\r\n // TODO:\r\n //Result := TFuncInfo(UnitInfo.FuncsByAddr.FindByAddress(Addr));\r\n\r\n For I := 0 To UnitInfo.Funcs.Count - 1 Do\r\n Begin\r\n Result := TFuncInfo(UnitInfo.Funcs[I]);\r\n\r\n if (Cardinal(Result.Address) <= Cardinal(Addr)) and (Cardinal(Addr) < Cardinal(Result.Address) + Result.Size) then\r\n Exit;\r\n End;\r\n Result := Nil;\r\nEnd;\r\n\r\nFunction TDelphiDebugInfo.FindLineByAddr(const FuncInfo: TFuncInfo; const Addr: Pointer; const GetPrevLine: LongBool = False): TLineInfo;\r\nVar\r\n LineIdx: Integer;\r\n //SearchLine: TLineInfo;\r\nBegin\r\n (*\r\n Result := Nil;\r\n\r\n SearchLine := TLineInfo.Create;\r\n try\r\n SearchLine.Address := Addr;\r\n FuncInfo.Lines.BinarySearch(SearchLine, LineIdx);\r\n finally\r\n FreeAndNil(SearchLine);\r\n end;\r\n\r\n if (LineIdx >= 0) and (LineIdx < FuncInfo.Lines.Count) then\r\n begin\r\n if (LineIdx > 0) and GetPrevLine then\r\n Dec(LineIdx);\r\n\r\n Result := FuncInfo.Lines[LineIdx];\r\n end;\r\n *)\r\n\r\n LineIdx := FuncInfo.Lines.Count - 1;\r\n\r\n While (LineIdx >= 0) Do\r\n Begin\r\n Result := TLineInfo(FuncInfo.Lines[LineIdx]);\r\n If Cardinal(Addr) >= Cardinal(Result.Address) Then\r\n Begin\r\n If GetPrevLine And (LineIdx > 0) Then\r\n Result := TLineInfo(FuncInfo.Lines[LineIdx - 1]);\r\n\r\n Exit;\r\n End;\r\n Dec(LineIdx);\r\n End;\r\n\r\n Result := Nil;\r\nEnd;\r\n\r\nFunction TDelphiDebugInfo.DoReadDebugInfo(Const FileName: String; ALoadDebugInfo: LongBool): LongBool;\r\nVar\r\n I: Integer;\r\n Module: TJclTD32ModuleInfo;\r\n Delta: Double;\r\nBegin\r\n Result := FileExists(FileName);\r\n If Result Then\r\n Begin\r\n DoProgress('Prepare', 4);\r\n if Assigned(FImage) then\r\n FreeAndNil(FImage);\r\n\r\n DoProgress('Init image', 5);\r\n FImage := TJclPeBorTD32Image.Create(True);\r\n DoProgress('Load image', 5);\r\n\r\n FImage.FileName := GetDBGFileName(FileName);\r\n\r\n DoProgress('Load debug info', 10);\r\n Result := FImage.IsTD32DebugPresent;\r\n If Result And ALoadDebugInfo and (FImage.TD32Scanner.ModuleCount > 0) Then\r\n Begin\r\n case FImage.TD32DebugDataType of\r\n ddtInImage:\r\n FDebugInfoType := 'Internal';\r\n ddtTDS:\r\n FDebugInfoType := 'External(TDS)';\r\n end;\r\n\r\n InitSegments;\r\n\r\n Delta := 70 / FImage.TD32Scanner.ModuleCount;\r\n For I := 0 To FImage.TD32Scanner.ModuleCount - 1 Do\r\n Begin\r\n Module := FImage.TD32Scanner.Modules[I];\r\n ParseUnit(Module);\r\n\r\n DoProgress('Load debug info', 10 + Round((I + 1) * Delta));\r\n End;\r\n\r\n DoProgress('Check debug info', 80);\r\n ResolveUnits;\r\n\r\n // , DebugInfo\r\n //UnMapAndLoad(FImage.LoadedImage);\r\n End;\r\n DoProgress('Debug info loaded', 99);\r\n End;\r\nEnd;\r\n\r\nFunction TDelphiDebugInfo.CheckAddr(Const Addr: Pointer): LongBool;\r\nBegin\r\n Result := FindUnitByAddr(Addr) <> Nil;\r\nEnd;\r\n\r\nFunction TDelphiDebugInfo.CheckDebugException(ExceptionRecord: PExceptionRecord; Var IsTraceException: LongBool): LongBool;\r\nBegin\r\n Result := Inherited CheckDebugException(ExceptionRecord, IsTraceException);\r\n\r\n If Not Result And IsDelphiException(ExceptionRecord) Then\r\n Begin\r\n IsTraceException := IsDelphiTraceException(ExceptionRecord);\r\n Result := ExceptionRecord^.ExceptionFlags = cContinuable;\r\n End;\r\nEnd;\r\n\r\nFunction TDelphiDebugInfo.CheckSystemFile(Const FileName: String): LongBool;\r\nVar\r\n FN: String;\r\n SL: TStringArray;\r\nBegin\r\n Result := False;\r\n FN := ExtractFileName(FileName);\r\n SplitStr(FN, '.', SL);\r\n if Length(SL) > 0 then\r\n Result := (FSystemUnits.IndexOf(SL[0]) >= 0);\r\nEnd;\r\n\r\nProcedure TDelphiDebugInfo.ClearDebugInfo;\r\nvar\r\n DbgFileName: String;\r\nBegin\r\n FIsHookSet := False;\r\n\r\n if Assigned(FImage) then\r\n begin\r\n DbgFileName := '';\r\n\r\n if DebugInfoLoaded then\r\n DbgFileName := FImage.FileName;\r\n\r\n FreeAndNil(FImage);\r\n\r\n if DebugInfoLoaded and (DbgFileName <> '') then\r\n DeleteFile(PWideChar(DbgFileName));\r\n end;\r\n\r\n FDelphiVersion := dvAuto;\r\n\r\n if Assigned(FSystemUnits) then\r\n FSystemUnits.Clear;\r\n\r\n if Assigned(FAddressInfoList) then\r\n FAddressInfoList.Clear;\r\n\r\n Inherited ClearDebugInfo;\r\nEnd;\r\n\r\nFunction TDelphiDebugInfo.HasDebugInfo(Const FileName: String): LongBool;\r\nBegin\r\n Result := HasDelphiDebugInfo(FileName);\r\nEnd;\r\n\r\nFunction TDelphiDebugInfo.GetAddrInfo(Var Addr: Pointer; Const FileName: String; Line: Cardinal): TFindResult;\r\nVar\r\n Index: Integer;\r\n UnitInfo: TUnitInfo;\r\n ExactMatch: LongBool;\r\nBegin\r\n Result := slNotFound;\r\n\r\n Index := Units.IndexOf(LowerCase(FileName));\r\n If Index <> -1 Then\r\n Begin\r\n UnitInfo := TUnitInfo(Units.Objects[Index]);\r\n\r\n // TODO: ( )\r\n Index := UnitInfo.Lines.IndexOf(Pointer(Line));\r\n ExactMatch := (Index >= 0);\r\n If (Index >= 0) And (Index < UnitInfo.Lines.Count) Then\r\n Begin\r\n Addr := TLineInfo(UnitInfo.Lines[Index]).Address;\r\n If ExactMatch Then\r\n Result := slFoundExact\r\n Else\r\n Result := slFoundNotExact;\r\n End;\r\n End;\r\nEnd;\r\n\r\nfunction TDelphiDebugInfo.GetClassName(Const ObjectPtr: Pointer): String;\r\nConst\r\n _ValidChars = ['_', 'a' .. 'z', 'A' .. 'Z', '0' .. '9'];\r\nVar\r\n ObjTypePtr: Pointer;\r\n ClassNamePtr: Pointer;\r\n ClassName: ShortString;\r\n I: Integer;\r\nbegin\r\n Result := '';\r\n ObjTypePtr := Nil;\r\n if gvDebuger.ReadData(ObjectPtr, @ObjTypePtr, SizeOf(Pointer)) then\r\n begin\r\n ClassNamePtr := Nil;\r\n if gvDebuger.ReadData(IncPointer(ObjTypePtr, RTLInfo.vmtClassName), @ClassNamePtr, SizeOf(Pointer)) then\r\n begin\r\n ClassName := gvDebuger.ReadStringP(IncPointer(ClassNamePtr, SizeOf(Byte)));\r\n for I := 1 to Length(ClassName) do\r\n if not(ClassName[I] in _ValidChars) then\r\n Exit;\r\n\r\n Result := String(ClassName);\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TDelphiDebugInfo.GetDBGFileName(const FileName: String): String;\r\nvar\r\n I: Integer;\r\nbegin\r\n // \r\n // TODO: \r\n I := 0;\r\n repeat\r\n Result := ChangeFileExt(FileName, '.~dbg');\r\n if FileExists(Result) then\r\n begin\r\n if DeleteFile(PWideChar(Result)) then\r\n Break\r\n else\r\n Result := ChangeFileExt(FileName, '.~dbg' + IntToStr(I));\r\n\r\n Inc(I);\r\n\r\n if I >= 10 then\r\n begin\r\n Result := FileName;\r\n Break;\r\n end;\r\n end\r\n else\r\n Break;\r\n until False;\r\n\r\n if Result <> FileName then\r\n if not CopyFile(PWideChar(FileName), PWideChar(Result), True) then\r\n Result := FileName;\r\nend;\r\n\r\nFunction TDelphiDebugInfo.GetExceptionAddress(ExceptionRecord: PExceptionRecord): Pointer;\r\nBegin\r\n If IsDelphiException(ExceptionRecord) And (ExceptionRecord^.NumberParameters > 0) Then\r\n Result := Pointer(ExceptionRecord^.ExceptionInformation[0])\r\n Else\r\n Result := Inherited GetExceptionAddress(ExceptionRecord);\r\nEnd;\r\n\r\nFunction TDelphiDebugInfo.GetExceptionFrame(ExceptionRecord: PExceptionRecord): Pointer;\r\nBegin\r\n If ExceptionRecord^.ExceptionCode = cDelphiException Then\r\n Result := Pointer(ExceptionRecord^.ExceptionInformation[5])\r\n Else\r\n Result := Inherited GetExceptionFrame(ExceptionRecord);\r\nEnd;\r\n\r\nFunction TDelphiDebugInfo.GetExceptionMessage(ExceptionRecord: PExceptionRecord; const ThreadId: TThreadId): String;\r\nVar\r\n ExceptTypeAddr: Pointer;\r\n ExceptMsgPtr: Pointer;\r\nBegin\r\n Result := '';\r\n If ExceptionRecord^.ExceptionCode = cDelphiException Then\r\n Begin\r\n ExceptTypeAddr := Pointer(ExceptionRecord^.ExceptionInformation[1]);\r\n\r\n ExceptMsgPtr := nil;\r\n if gvDebuger.ReadData(@Exception(ExceptTypeAddr).Message, @ExceptMsgPtr, SizeOf(Pointer)) then\r\n Result := gvDebuger.ReadStringW(ExceptMsgPtr);\r\n End\r\n Else\r\n Result := Inherited GetExceptionMessage(ExceptionRecord, ThreadId);\r\nEnd;\r\n\r\nFunction TDelphiDebugInfo.GetExceptionName(ExceptionRecord: PExceptionRecord): String;\r\nVar\r\n ExceptTypeAddr: Pointer;\r\nBegin\r\n If ExceptionRecord^.ExceptionCode = cDelphiException Then\r\n Begin\r\n ExceptTypeAddr := Pointer(ExceptionRecord^.ExceptionInformation[1]);\r\n Result := GetClassName(ExceptTypeAddr);\r\n End\r\n Else\r\n Result := Inherited GetExceptionName(ExceptionRecord);\r\nEnd;\r\n\r\nFunction TDelphiDebugInfo.GetLineInfo(const Addr: Pointer; Var UnitInfo: TUnitInfo; Var FuncInfo: TFuncInfo; Var LineInfo: TLineInfo;\r\n GetPrevLine: LongBool): TFindResult;\r\nvar\r\n AddressInfo: PAddressInfo;\r\nBegin\r\n Result := slNotFound;\r\n\r\n UnitInfo := Nil;\r\n FuncInfo := Nil;\r\n LineInfo := Nil;\r\n\r\n FAddressInfoList.Lock.BeginRead;\r\n try\r\n if FAddressInfoList.TryGetValue(Addr, AddressInfo) then\r\n begin\r\n UnitInfo := AddressInfo.UnitInfo;\r\n FuncInfo := AddressInfo.FuncInfo;\r\n LineInfo := AddressInfo.LineInfo;\r\n Result := AddressInfo.FindResult;\r\n end\r\n else\r\n begin\r\n UnitInfo := FindUnitByAddr(Addr);\r\n If UnitInfo <> Nil Then\r\n Begin\r\n FuncInfo := FindFuncByAddr(UnitInfo, Addr);\r\n If FuncInfo <> Nil Then\r\n Begin\r\n LineInfo := FindLineByAddr(FuncInfo, Addr, GetPrevLine);\r\n If LineInfo = Nil Then\r\n Result := slFoundWithoutLine\r\n Else\r\n Begin\r\n If LineInfo.Address = Addr Then\r\n Result := slFoundExact\r\n Else\r\n Result := slFoundNotExact;\r\n End;\r\n End;\r\n End;\r\n\r\n AddressInfo := AllocMem(SizeOf(RAddressInfo));\r\n AddressInfo.Addr := Addr;\r\n AddressInfo.UnitInfo := UnitInfo;\r\n AddressInfo.FuncInfo := FuncInfo;\r\n AddressInfo.LineInfo := LineInfo;\r\n AddressInfo.FindResult := Result;\r\n\r\n FAddressInfoList.Lock.BeginWrite;\r\n try\r\n FAddressInfoList.AddOrSetValue(Addr, AddressInfo);\r\n finally\r\n FAddressInfoList.Lock.EndWrite;\r\n end;\r\n end;\r\n finally\r\n FAddressInfoList.Lock.EndRead;\r\n end;\r\nEnd;\r\n\r\nfunction TDelphiDebugInfo.GetMemoryManager: TVarInfo;\r\nconst\r\n _TMemoryManager: AnsiString = 'TMemoryManager';\r\nVar\r\n USystem: TUnitInfo;\r\n MMType: TTypeInfo;\r\n J: Integer;\r\nbegin\r\n Result := Nil;\r\n\r\n USystem := GetSystemUnit;\r\n if Assigned(USystem) then\r\n begin\r\n MMType := USystem.FindTypeByName(_TMemoryManager, True);\r\n if Assigned(MMType) then\r\n begin\r\n for J := 0 to USystem.Vars.Count - 1 do\r\n begin\r\n Result := TVarInfo(USystem.Vars[J]);\r\n if Result.DataType = MMType then\r\n Exit;\r\n end;\r\n Result := nil;\r\n end;\r\n end;\r\nend;\r\n\r\nFunction TDelphiDebugInfo.MakeFuncDbgFullName(Const ClassName, MethodName: AnsiString): AnsiString;\r\nBegin\r\n Result := '@' + ClassName + '@' + MethodName;\r\nEnd;\r\n\r\nFunction TDelphiDebugInfo.MakeFuncShortName(Const MethodName: AnsiString): AnsiString;\r\nVar\r\n I: Integer;\r\nBegin\r\n Result := MethodName;\r\n I := Pos(AnsiString('@'), Result);\r\n If I = 1 Then\r\n Begin\r\n Delete(Result, 1, 1);\r\n I := Pos(AnsiString('@'), Result);\r\n If I > -1 Then\r\n Delete(Result, 1, I)\r\n Else\r\n Insert('@', Result, 1);\r\n End;\r\nEnd;\r\n\r\nFunction TDelphiDebugInfo.MakeFuncNativeName(Const MethodName: AnsiString): AnsiString;\r\nBegin\r\n Result := MethodName;\r\n If Result <> '' Then\r\n Begin\r\n If Result[1] = '@' Then\r\n Delete(Result, 1, 1);\r\n Result := AnsiString(StringReplace(String(Result), '@', '.', [rfReplaceAll]));\r\n End;\r\nEnd;\r\n\r\nFunction TDelphiDebugInfo.Evaluate(BriefMode: LongBool; Const Expression: String; Const TimeOut: Cardinal = INFINITE): String;\r\n// Var\r\n// Parser : TExprParser;\r\n// UnitInfo : TUnitInfo;\r\n// FuncInfo : TFuncInfo;\r\n// LineInfo : TLineInfo;\r\nBegin\r\n // Result := '';\r\n // If Expression <> '' Then\r\n // Try\r\n // GetLineInfo(Debuger.GetRegisters.EIP, UnitInfo, FuncInfo, LineInfo, False);\r\n // Parser := TExprParser.Create(DebuggeeControl, Self, UnitInfo, FuncInfo, BriefMode, Expression);\r\n // Try\r\n // Result := Parser.CalculateAsString;\r\n // Finally\r\n // Parser.Free;\r\n // End;\r\n // Except\r\n // On E : EDebugException Do\r\n // Raise;\r\n // On E : Exception Do\r\n // Raise EEvaluateException.Create(E.Message);\r\n // End;\r\nEnd;\r\n\r\nfunction TDelphiDebugInfo.EvaluateVariable(VarInfo: TVarInfo): Variant;\r\n//var\r\n// EBP: Pointer;\r\n// Value: Variant;\r\nbegin\r\n //EBP := Pointer(gvDebuger.GetRegisters(gvDebuger.CurThreadId).Ebp);\r\n //TODO: Value := EvaluateProcs.EvaluateVariable(gvDebuger, VarInfo, EBP, True);\r\n\r\n //TODO: Result := EvaluateProcs.CalculateValue(Value, CalculateData);\r\n Result := Unassigned;\r\nend;\r\n\r\nfunction TDelphiDebugInfo.ImageBase: Cardinal;\r\nbegin\r\n Result := FImage.OptionalHeader32.ImageBase;\r\nend;\r\n\r\nfunction TDelphiDebugInfo.ImageNames(const Index: TNameId): AnsiString;\r\nbegin\r\n if (Index >= 0) and (FImage <> Nil) and (FImage.TD32Scanner <> Nil) and (Index < FImage.TD32Scanner.NameCount) then\r\n Result := FImage.TD32Scanner.Names[Index]\r\n else\r\n Result := '';\r\nend;\r\n\r\nprocedure TDelphiDebugInfo.InitCodeTracking(const SetBP: LongBool);\r\nvar\r\n FuncCount: Integer;\r\n I, J: Integer;\r\n UnitInfo: TUnitInfo;\r\n FuncInfo: TFuncInfo;\r\n Segment: TUnitSegmentInfo;\r\n OldProtect: Cardinal;\r\nbegin\r\n FuncCount := 128;\r\n\r\n if SetBP then\r\n for I := 0 to Units.Count - 1 do\r\n Inc(FuncCount, TUnitInfo(Units.Objects[I]).Funcs.Count);\r\n\r\n gvDebuger.DbgCodeProfiler.ClearDbgTracking;\r\n gvDebuger.DbgCodeProfiler.InitDbgTracking(FuncCount);\r\n\r\n if SetBP then\r\n begin\r\n for I := 0 to Units.Count - 1 do\r\n begin\r\n UnitInfo := TUnitInfo(Units.Objects[I]);\r\n\r\n for J := 0 to UnitInfo.Segments.Count - 1 do\r\n begin\r\n Segment := UnitInfo.Segments[J];\r\n if Assigned(Segment.SegmentClassInfo) and (Segment.SegmentClassInfo.SegType = ustCode) then\r\n Assert(\r\n VirtualProtectEx(\r\n gvDebuger.ProcessData.AttachedProcessHandle, Pointer(Segment.Address), Segment.Size, PAGE_EXECUTE_READWRITE, OldProtect\r\n )\r\n );\r\n end;\r\n\r\n if not gvDebuger.TrackSystemUnits and (UnitInfo.UnitType = utSystem) then\r\n Continue;\r\n\r\n for J := 0 to UnitInfo.Funcs.Count - 1 do\r\n begin\r\n FuncInfo := TFuncInfo(UnitInfo.Funcs[J]);\r\n gvDebuger.DbgCodeProfiler.SetTrackBreakpoint(FuncInfo.Address, FuncInfo);\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\nProcedure TDelphiDebugInfo.InitDebugHook;\r\nBegin\r\n if not FIsHookSet then\r\n begin\r\n FIsHookSet := True;\r\n\r\n gvDebuger.ProcessData.SetPEImage(FImage);\r\n\r\n InitCodeTracking(gvDebuger.CodeTracking and not gvDebuger.SamplingMethod);\r\n\r\n MemoryManagerInfo.VarInfo := GetMemoryManager;\r\n RTLInfo.vmtClassNameInfo := GetVMTClassName;\r\n\r\n // GetMem FreeMem\r\n // SetMemoryManagerBreakpoints;\r\n\r\n // \r\n // !!! , \r\n LoadDbgHookDll(\r\n gvDebuger.ProcessData.AttachedProcessHandle,\r\n Format('%s\\DbgHook32.dll', [ExtractFileDir(Application.ExeName)]),\r\n Pointer(FImage.OptionalHeader32.ImageBase),\r\n MemoryManagerInfo.VarInfo,\r\n RTLInfo.vmtClassName,\r\n gvDebuger.DbgMemoryProfiler.MemoryCallStack,\r\n gvDebuger.DbgSysncObjsProfiler.SyncObjsTracking\r\n );\r\n end;\r\nEnd;\r\n\r\nprocedure TDelphiDebugInfo.InitSegments;\r\nvar\r\n Idx: Integer;\r\n Segment: TSegmentClassInfo;\r\n ImageSectionHeader: TImageSectionHeader;\r\nbegin\r\n Segments.Clear;\r\n\r\n for Idx := 0 to FImage.ImageSectionCount - 1 do\r\n begin\r\n Segment := TSegmentClassInfo.Create;\r\n\r\n Segment.SegType := TSegmentClassInfo.StrToSegmentType(FImage.ImageSectionNames[Idx]);\r\n\r\n ImageSectionHeader := FImage.ImageSectionHeaders[Idx];\r\n Segment.Address := Pointer(ImageSectionHeader.VirtualAddress + ImageBase);\r\n Segment.Size := ImageSectionHeader.SizeOfRawData;\r\n Segment.ID := Idx + 1;\r\n\r\n Segments.AddObject(FImage.ImageSectionNames[Idx], Segment);\r\n end;\r\n\r\n (*\r\n Segment := TSegmentClassInfo.Create;\r\n Segment.ID := $0000;\r\n Segment.SegType := ustData;\r\n\r\n Segments.AddObject('DATA', Segment);\r\n\r\n Segment := TSegmentClassInfo.Create;\r\n Segment.ID := $0001;\r\n Segment.SegType := ustCode;\r\n\r\n Segments.AddObject('CODE', Segment);\r\n *)\r\nend;\r\n\r\nFunction TDelphiDebugInfo.IsDelphiException(ExceptionRecord: PExceptionRecord): LongBool;\r\nBegin\r\n Case ExceptionRecord^.ExceptionCode Of\r\n cDelphiUnhandled, cDelphiTerminate, cDelphiException, cDelphiReRaise, cDelphiExcept, cDelphiFinally, cNonDelphiException, cDelphiExitFinally:\r\n Result := True;\r\n Else\r\n Result := False;\r\n End;\r\nEnd;\r\n\r\nFunction TDelphiDebugInfo.IsDelphiTraceException(ExceptionRecord: PExceptionRecord): LongBool;\r\nBegin\r\n Case ExceptionRecord^.ExceptionCode Of\r\n // cDelphiUnhandled,\r\n // cDelphiTerminate,\r\n cDelphiException, cDelphiReRaise, cDelphiExcept, cDelphiFinally,\r\n // cNonDelphiException,\r\n cDelphiExitFinally:\r\n Result := True;\r\n Else\r\n Result := False;\r\n End;\r\nEnd;\r\n\r\ninitialization\r\n\r\n// _HookThreads;\r\n\r\nfinalization\r\n\r\n// _UnhookThreads;\r\n\r\nEnd.\r\n" }, { "path": "External/Jedi/Jcl/source/common/Jcl8087.pas", "content": "{**************************************************************************************************}\r\n{ }\r\n{ Project JEDI Code Library (JCL) }\r\n{ }\r\n{ The contents of this file are subject to the Mozilla Public License Version 1.1 (the \"License\"); }\r\n{ you may not use this file except in compliance with the License. You may obtain a copy of the }\r\n{ License at http://www.mozilla.org/MPL/ }\r\n{ }\r\n{ Software distributed under the License is distributed on an \"AS IS\" basis, WITHOUT WARRANTY OF }\r\n{ ANY KIND, either express or implied. See the License for the specific language governing rights }\r\n{ and limitations under the License. }\r\n{ }\r\n{ The Original Code is Jcl8087.pas }\r\n{ }\r\n{ The Initial Developer of the Original Code is Marcel van Brakel. }\r\n{ Portions created by Marcel van Brakel are Copyright Marcel van Brakel. All rights reserved. }\r\n{ }\r\n{ Contributor(s): }\r\n{ Marcel van Brakel }\r\n{ ESB Consultancy }\r\n{ Robert Marquardt (marquardt) }\r\n{ Robert Rossmair (rrossmair) }\r\n{ Matthias Thoma (mthoma) }\r\n{ Petr Vones }\r\n{ }\r\n{**************************************************************************************************}\r\n{ }\r\n{ This unit contains various routine for manipulating the math coprocessor. This includes such }\r\n{ things as querying and setting the rounding precision of floating point operations and }\r\n{ retrieving the coprocessor's status word. }\r\n{ }\r\n{**************************************************************************************************}\r\n{ }\r\n{ Last modified: $Date:: 2011-09-03 00:07:50 +0200 (sam. 03 sept. 2011) $ }\r\n{ Revision: $Rev:: 3599 $ }\r\n{ Author: $Author:: outchy $ }\r\n{ }\r\n{**************************************************************************************************}\r\n\r\nunit Jcl8087;\r\n\r\n{$I jcl.inc}\r\n\r\ninterface\r\n\r\n{$IFDEF UNITVERSIONING}\r\nuses\r\n JclUnitVersioning;\r\n{$ENDIF UNITVERSIONING}\r\n\r\ntype\r\n T8087Precision = (pcSingle, pcReserved, pcDouble, pcExtended);\r\n T8087Rounding = (rcNearestOrEven, rcDownInfinity, rcUpInfinity, rcChopOrTruncate);\r\n T8087Infinity = (icProjective, icAffine);\r\n T8087Exception = (emInvalidOp, emDenormalizedOperand, emZeroDivide, emOverflow,\r\n emUnderflow, emPrecision);\r\n T8087Exceptions = set of T8087Exception;\r\n\r\nconst\r\n All8087Exceptions = [Low(T8087Exception)..High(T8087Exception)];\r\n\r\nfunction Get8087ControlWord: Word;\r\nfunction Get8087Infinity: T8087Infinity;\r\nfunction Get8087Precision: T8087Precision;\r\nfunction Get8087Rounding: T8087Rounding;\r\nfunction Get8087StatusWord(ClearExceptions: Boolean): Word;\r\n\r\nfunction Set8087Infinity(const Infinity: T8087Infinity): T8087Infinity;\r\nfunction Set8087Precision(const Precision: T8087Precision): T8087Precision;\r\nfunction Set8087Rounding(const Rounding: T8087Rounding): T8087Rounding;\r\nfunction Set8087ControlWord(const Control: Word): Word;\r\n\r\nfunction ClearPending8087Exceptions: T8087Exceptions;\r\nfunction GetPending8087Exceptions: T8087Exceptions;\r\nfunction GetMasked8087Exceptions: T8087Exceptions;\r\nfunction SetMasked8087Exceptions(Exceptions: T8087Exceptions; ClearBefore: Boolean = True): T8087Exceptions;\r\nfunction Mask8087Exceptions(Exceptions: T8087Exceptions): T8087Exceptions;\r\nfunction Unmask8087Exceptions(Exceptions: T8087Exceptions; ClearBefore: Boolean = True): T8087Exceptions;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jcl.svn.sourceforge.net/svnroot/jcl/tags/JCL-2.4-Build4571/jcl/source/common/Jcl8087.pas $';\r\n Revision: '$Revision: 3599 $';\r\n Date: '$Date: 2011-09-03 00:07:50 +0200 (sam. 03 sept. 2011) $';\r\n LogPath: 'JCL\\source\\common';\r\n Extra: '';\r\n Data: nil\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nconst\r\n X87ExceptBits = $3F;\r\n\r\nfunction Get8087ControlWord: Word;\r\nasm\r\n FSTCW Result\r\n FWAIT\r\nend;\r\n\r\nfunction Get8087Infinity: T8087Infinity;\r\nbegin\r\n Result := T8087Infinity((Get8087ControlWord and $1000) shr 12);\r\nend;\r\n\r\nfunction Get8087Precision: T8087Precision;\r\nbegin\r\n Result := T8087Precision((Get8087ControlWord and $0300) shr 8);\r\nend;\r\n\r\nfunction Get8087Rounding: T8087Rounding;\r\nbegin\r\n Result := T8087Rounding((Get8087ControlWord and $0C00) shr 10);\r\nend;\r\n\r\n{$IFDEF CPU64}\r\nfunction Get8087StatusWord(ClearExceptions: Boolean): Word;\r\nasm\r\n TEST ClearExceptions, ClearExceptions\r\n JZ @@Without\r\n FSTSW Result // get status word (clears exceptions)\r\n JMP @@Leave\r\n@@Without:\r\n FNSTSW Result // get status word (without clearing exceptions)\r\n@@Leave:\r\nend;\r\n{$ELSE}\r\nfunction Get8087StatusWord(ClearExceptions: Boolean): Word;\r\nbegin\r\n if ClearExceptions then\r\n asm\r\n FSTSW Result // get status word (clears exceptions)\r\n end\r\n else\r\n asm\r\n FNSTSW Result // get status word (without clearing exceptions)\r\n end;\r\nend;\r\n{$ENDIF CPU64}\r\n\r\nfunction Set8087Infinity(const Infinity: T8087Infinity): T8087Infinity;\r\nvar\r\n CW: Word;\r\nbegin\r\n CW := Get8087ControlWord;\r\n Result := T8087Infinity((CW and $1000) shr 12);\r\n Set8087ControlWord((CW and $EFFF) or (Word(Infinity) shl 12));\r\nend;\r\n\r\nfunction Set8087Precision(const Precision: T8087Precision): T8087Precision;\r\nvar\r\n CW: Word;\r\nbegin\r\n CW := Get8087ControlWord;\r\n Result := T8087Precision((CW and $0300) shr 8);\r\n Set8087ControlWord((CW and $FCFF) or (Word(Precision) shl 8));\r\nend;\r\n\r\nfunction Set8087Rounding(const Rounding: T8087Rounding): T8087Rounding;\r\nvar\r\n CW: Word;\r\nbegin\r\n CW := Get8087ControlWord;\r\n Result := T8087Rounding((CW and $0C00) shr 10);\r\n Set8087ControlWord((CW and $F3FF) or (Word(Rounding) shl 10));\r\nend;\r\n\r\nfunction Set8087ControlWord(const Control: Word): Word;\r\nvar\r\n StackControl: Word;\r\nasm\r\n MOV StackControl, Control\r\n FNCLEX\r\n FSTCW Result // save the old control word\r\n FLDCW StackControl // load the new control word\r\nend;\r\n\r\nfunction ClearPending8087Exceptions: T8087Exceptions;\r\n\r\n function GetSW: Word;\r\n asm\r\n FNSTSW Result\r\n AND Result, X87ExceptBits\r\n FNCLEX\r\n end;\r\n\r\nvar\r\n SW: Word;\r\nbegin\r\n SW := GetSW;\r\n\r\n Result := [];\r\n if (SW and $01) <> 0 then\r\n Include(Result, emInvalidOp);\r\n if (SW and $02) <> 0 then\r\n Include(Result, emDenormalizedOperand);\r\n if (SW and $04) <> 0 then\r\n Include(Result, emZeroDivide);\r\n if (SW and $08) <> 0 then\r\n Include(Result, emOverflow);\r\n if (SW and $10) <> 0 then\r\n Include(Result, emUnderflow);\r\n if (SW and $20) <> 0 then\r\n Include(Result, emPrecision);\r\nend;\r\n\r\nfunction GetPending8087Exceptions: T8087Exceptions;\r\n\r\n function GetSW: Word;\r\n asm\r\n FNSTSW Result\r\n AND Result, X87ExceptBits\r\n end;\r\n\r\nvar\r\n SW: Word;\r\nbegin\r\n SW := GetSW;\r\n Result := [];\r\n if (SW and $01) <> 0 then\r\n Include(Result, emInvalidOp);\r\n if (SW and $02) <> 0 then\r\n Include(Result, emDenormalizedOperand);\r\n if (SW and $04) <> 0 then\r\n Include(Result, emZeroDivide);\r\n if (SW and $08) <> 0 then\r\n Include(Result, emOverflow);\r\n if (SW and $10) <> 0 then\r\n Include(Result, emUnderflow);\r\n if (SW and $20) <> 0 then\r\n Include(Result, emPrecision);\r\nend;\r\n\r\nfunction GetMasked8087Exceptions: T8087Exceptions;\r\n\r\n function GetCW: Word;\r\n asm\r\n FSTCW Result\r\n AND Result, X87ExceptBits\r\n end;\r\n\r\nvar\r\n CW: Word;\r\nbegin\r\n CW := GetCW;\r\n Result := [];\r\n if (CW and $01) <> 0 then\r\n Include(Result, emInvalidOp);\r\n if (CW and $02) <> 0 then\r\n Include(Result, emDenormalizedOperand);\r\n if (CW and $04) <> 0 then\r\n Include(Result, emZeroDivide);\r\n if (CW and $08) <> 0 then\r\n Include(Result, emOverflow);\r\n if (CW and $10) <> 0 then\r\n Include(Result, emUnderflow);\r\n if (CW and $20) <> 0 then\r\n Include(Result, emPrecision);\r\nend;\r\n\r\nfunction SetMasked8087Exceptions(Exceptions: T8087Exceptions; ClearBefore: Boolean): T8087Exceptions;\r\n\r\n function ClearPendingExceptions: Word;\r\n asm\r\n FNCLEX // clear pending exceptions\r\n end;\r\n\r\n function SetCW(NewCW: Word): Word;\r\n var\r\n StackNewCW: Word;\r\n asm\r\n FSTCW Result\r\n FWAIT\r\n MOV StackNewCW, NewCW\r\n MOV AX, Result\r\n AND AX, NOT X87ExceptBits // mask exception mask bits 0..5\r\n OR StackNewCW, AX\r\n FLDCW StackNewCW\r\n end;\r\n\r\nvar\r\n OldCW, NewCW: Word;\r\nbegin\r\n if ClearBefore then\r\n ClearPendingExceptions;\r\n NewCW := 0;\r\n if emInvalidOp in Exceptions then\r\n NewCW := NewCW or $01;\r\n if emDenormalizedOperand in Exceptions then\r\n NewCW := NewCW or $02;\r\n if emZeroDivide in Exceptions then\r\n NewCW := NewCW or $04;\r\n if emOverflow in Exceptions then\r\n NewCW := NewCW or $08;\r\n if emUnderflow in Exceptions then\r\n NewCW := NewCW or $10;\r\n if emPrecision in Exceptions then\r\n NewCW := NewCW or $20;\r\n OldCW := SetCW(NewCW);\r\n Result := [];\r\n if (OldCW and $01) <> 0 then\r\n Include(Result, emInvalidOp);\r\n if (OldCW and $02) <> 0 then\r\n Include(Result, emDenormalizedOperand);\r\n if (OldCW and $04) <> 0 then\r\n Include(Result, emZeroDivide);\r\n if (OldCW and $08) <> 0 then\r\n Include(Result, emOverflow);\r\n if (OldCW and $10) <> 0 then\r\n Include(Result, emUnderflow);\r\n if (OldCW and $20) <> 0 then\r\n Include(Result, emPrecision);\r\nend;\r\n\r\nfunction Mask8087Exceptions(Exceptions: T8087Exceptions): T8087Exceptions;\r\nbegin\r\n Result := GetMasked8087Exceptions;\r\n Exceptions := Exceptions + Result;\r\n SetMasked8087Exceptions(Exceptions, False);\r\nend;\r\n\r\nfunction Unmask8087Exceptions(Exceptions: T8087Exceptions; ClearBefore: Boolean): T8087Exceptions;\r\nbegin\r\n Result := GetMasked8087Exceptions;\r\n Exceptions := Result - Exceptions;\r\n SetMasked8087Exceptions(Exceptions, ClearBefore);\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jcl/source/common/JclAbstractContainers.pas", "content": "{**************************************************************************************************}\r\n{ }\r\n{ Project JEDI Code Library (JCL) }\r\n{ }\r\n{ The contents of this file are subject to the Mozilla Public License Version 1.1 (the \"License\"); }\r\n{ you may not use this file except in compliance with the License. You may obtain a copy of the }\r\n{ License at http://www.mozilla.org/MPL/ }\r\n{ }\r\n{ Software distributed under the License is distributed on an \"AS IS\" basis, WITHOUT WARRANTY OF }\r\n{ ANY KIND, either express or implied. See the License for the specific language governing rights }\r\n{ and limitations under the License. }\r\n{ }\r\n{ The Original Code is AbstractContainer.pas and DCL_Util.pas. }\r\n{ }\r\n{ The Initial Developer of the Original Code is Jean-Philippe BEMPEL aka RDM. Portions created by }\r\n{ Jean-Philippe BEMPEL are Copyright (C) Jean-Philippe BEMPEL (rdm_30 att yahoo dott com) }\r\n{ All rights reserved. }\r\n{ }\r\n{ Contributors: }\r\n{ Daniele Teti (dade2004) }\r\n{ Robert Marquardt (marquardt) }\r\n{ Florent Ouchet (outchy) }\r\n{ }\r\n{**************************************************************************************************}\r\n{ }\r\n{ The Delphi Container Library }\r\n{ }\r\n{**************************************************************************************************}\r\n{ }\r\n{ Last modified: $Date:: 2012-02-19 22:43:22 +0100 (dim. 19 févr. 2012) $ }\r\n{ Revision: $Rev:: 3735 $ }\r\n{ Author: $Author:: outchy $ }\r\n{ }\r\n{**************************************************************************************************}\r\n\r\nunit JclAbstractContainers;\r\n\r\n{$I jcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n {$IFDEF HAS_UNIT_LIBC}\r\n Libc,\r\n {$ENDIF HAS_UNIT_LIBC}\r\n {$IFDEF HAS_UNITSCOPE}\r\n System.Classes,\r\n {$ELSE ~HAS_UNITSCOPE}\r\n Classes,\r\n {$ENDIF ~HAS_UNITSCOPE}\r\n JclBase, JclContainerIntf, JclSynch, JclSysUtils,\r\n JclWideStrings,\r\n JclAnsiStrings;\r\n\r\ntype\r\n // (OF) was moved to JclSysUtils\r\n // TJclIntfCriticalSection = JclSysUtils.TJclIntfCriticalSection;\r\n\r\n TJclAbstractLockable = class(TInterfacedObject {$IFDEF THREADSAFE}, IJclLockable {$ENDIF THREADSAFE})\r\n {$IFDEF THREADSAFE}\r\n protected\r\n FThreadSafe: Boolean;\r\n FSyncReaderWriter: TJclMultiReadExclusiveWrite;\r\n public\r\n constructor Create;\r\n destructor Destroy; override;\r\n property SyncReaderWriter: TJclMultiReadExclusiveWrite read FSyncReaderWriter;\r\n { IJclLockable }\r\n procedure ReadLock;\r\n procedure ReadUnlock;\r\n procedure WriteLock;\r\n procedure WriteUnlock;\r\n {$ENDIF THREADSAFE}\r\n end;\r\n\r\n TJclAbstractContainerBase = class(TJclAbstractLockable, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclCloneable, IJclIntfCloneable, IJclBaseContainer)\r\n protected\r\n FAllowDefaultElements: Boolean;\r\n FDuplicates: TDuplicates;\r\n FRemoveSingleElement: Boolean;\r\n FReturnDefaultElements: Boolean;\r\n FReadOnly: Boolean;\r\n FCapacity: Integer;\r\n FSize: Integer;\r\n FAutoGrowParameter: Integer;\r\n FAutoGrowStrategy: TJclAutoGrowStrategy;\r\n FAutoPackParameter: Integer;\r\n FAutoPackStrategy: TJclAutoPackStrategy;\r\n procedure AutoGrow; virtual;\r\n procedure AutoPack; virtual;\r\n function CheckDuplicate: Boolean;\r\n function CreateEmptyContainer: TJclAbstractContainerBase; virtual; abstract;\r\n procedure AssignDataTo(Dest: TJclAbstractContainerBase); virtual;\r\n procedure AssignPropertiesTo(Dest: TJclAbstractContainerBase); virtual;\r\n public\r\n constructor Create;\r\n { IJclBaseContainer }\r\n procedure Assign(const Source: IJclBaseContainer);\r\n procedure AssignTo(const Dest: IJclBaseContainer);\r\n function GetAllowDefaultElements: Boolean; virtual;\r\n function GetContainerReference: TObject;\r\n function GetDuplicates: TDuplicates; virtual;\r\n function GetReadOnly: Boolean; virtual;\r\n function GetRemoveSingleElement: Boolean; virtual;\r\n function GetReturnDefaultElements: Boolean; virtual;\r\n function GetThreadSafe: Boolean; virtual;\r\n procedure SetAllowDefaultElements(Value: Boolean); virtual;\r\n procedure SetDuplicates(Value: TDuplicates); virtual;\r\n procedure SetReadOnly(Value: Boolean); virtual;\r\n procedure SetRemoveSingleElement(Value: Boolean); virtual;\r\n procedure SetReturnDefaultElements(Value: Boolean); virtual;\r\n procedure SetThreadSafe(Value: Boolean); virtual;\r\n property AllowDefaultElements: Boolean read GetAllowDefaultElements write SetAllowDefaultElements;\r\n property Duplicates: TDuplicates read GetDuplicates write SetDuplicates;\r\n property ReadOnly: Boolean read GetReadOnly write SetReadOnly;\r\n property RemoveSingleElement: Boolean read GetRemoveSingleElement write SetRemoveSingleElement;\r\n property ReturnDefaultElements: Boolean read GetReturnDefaultElements write SetReturnDefaultElements;\r\n property ThreadSafe: Boolean read GetThreadSafe write SetThreadSafe;\r\n { IJclCloneable }\r\n function ObjectClone: TObject;\r\n { IJclIntfCloneable }\r\n function IntfClone: IInterface;\r\n // IJclGrowable is not in interface list because some descendants won't use this code\r\n { IJclGrowable }\r\n function CalcGrowCapacity(ACapacity, ASize: Integer): Integer; virtual;\r\n function GetAutoGrowParameter: Integer; virtual;\r\n function GetAutoGrowStrategy: TJclAutoGrowStrategy; virtual;\r\n procedure Grow; virtual;\r\n procedure SetAutoGrowParameter(Value: Integer); virtual;\r\n procedure SetAutoGrowStrategy(Value: TJclAutoGrowStrategy); virtual;\r\n property AutoGrowParameter: Integer read GetAutoGrowParameter write SetAutoGrowParameter;\r\n property AutoGrowStrategy: TJclAutoGrowStrategy read GetAutoGrowStrategy write SetAutoGrowStrategy;\r\n // IJclPackable is not in interface list because some descendants won't use this code\r\n { IJclPackable }\r\n function CalcPackCapacity(ACapacity, ASize: Integer): Integer; virtual;\r\n function GetAutoPackParameter: Integer; virtual;\r\n function GetAutoPackStrategy: TJclAutoPackStrategy; virtual;\r\n function GetCapacity: Integer; virtual;\r\n procedure Pack; virtual;\r\n procedure SetAutoPackParameter(Value: Integer); virtual;\r\n procedure SetAutoPackStrategy(Value: TJclAutoPackStrategy); virtual;\r\n procedure SetCapacity(Value: Integer); virtual;\r\n property AutoPackParameter: Integer read GetAutoPackParameter write SetAutoPackParameter;\r\n property AutoPackStrategy: TJclAutoPackStrategy read GetAutoPackStrategy write SetAutoPackStrategy;\r\n end;\r\n\r\n TJclAbstractIterator = class(TJclAbstractLockable, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclCloneable, IJclIntfCloneable, IJclAbstractIterator)\r\n private\r\n FValid: Boolean;\r\n protected\r\n procedure CheckValid;\r\n function CreateEmptyIterator: TJclAbstractIterator; virtual; abstract;\r\n procedure AssignPropertiesTo(Dest: TJclAbstractIterator); virtual;\r\n public\r\n constructor Create(AValid: Boolean);\r\n property Valid: Boolean read FValid write FValid;\r\n { IJclAbstractIterator }\r\n procedure Assign(const Source: IJclAbstractIterator);\r\n procedure AssignTo(const Dest: IJclAbstractIterator);\r\n function GetIteratorReference: TObject;\r\n { IJclCloneable }\r\n function ObjectClone: TObject;\r\n { IJclIntfCloneable }\r\n function IntfClone: IInterface;\r\n end;\r\n\r\n TJclIntfAbstractContainer = class(TJclAbstractContainerBase, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclCloneable, IJclIntfCloneable, IJclBaseContainer, IJclIntfContainer,\r\n IJclIntfOwner, IJclIntfEqualityComparer, IJclIntfComparer, IJclIntfHashConverter)\r\n protected\r\n FEqualityCompare: TIntfEqualityCompare;\r\n FCompare: TIntfCompare;\r\n FHashConvert: TIntfHashConvert;\r\n FOnFreeObject: TFreeIntfEvent;\r\n procedure AssignPropertiesTo(Dest: TJclAbstractContainerBase); override;\r\n public\r\n { IJclIntfOwner }\r\n function GetOnFreeObject: TFreeIntfEvent;\r\n function FreeObject(var AInterface: IInterface): IInterface; virtual;\r\n procedure SetOnFreeObject(Value: TFreeIntfEvent);\r\n property OnFreeObject: TFreeIntfEvent read GetOnFreeObject write SetOnFreeObject;\r\n { IJclIntfEqualityComparer }\r\n function GetEqualityCompare: TIntfEqualityCompare; virtual;\r\n procedure SetEqualityCompare(Value: TIntfEqualityCompare); virtual;\r\n function ItemsEqual(const A, B: IInterface): Boolean; virtual;\r\n property EqualityCompare: TIntfEqualityCompare read GetEqualityCompare write SetEqualityCompare;\r\n { IJclIntfComparer }\r\n function GetCompare: TIntfCompare; virtual;\r\n procedure SetCompare(Value: TIntfCompare); virtual;\r\n function ItemsCompare(const A, B: IInterface): Integer; virtual;\r\n property Compare: TIntfCompare read GetCompare write SetCompare;\r\n { IJclIntfHashConverter }\r\n function GetHashConvert: TIntfHashConvert; virtual;\r\n procedure SetHashConvert(Value: TIntfHashConvert); virtual;\r\n function Hash(const AInterface: IInterface): Integer; virtual;\r\n property HashConvert: TIntfHashConvert read GetHashConvert write SetHashConvert;\r\n end;\r\n\r\n TJclStrAbstractContainer = class(TJclAbstractContainerBase, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclCloneable, IJclIntfCloneable, IJclBaseContainer, IJclStrBaseContainer)\r\n protected\r\n FCaseSensitive: Boolean;\r\n procedure AssignPropertiesTo(Dest: TJclAbstractContainerBase); override;\r\n public\r\n { IJclStrBaseContainer }\r\n function GetCaseSensitive: Boolean; virtual;\r\n procedure SetCaseSensitive(Value: Boolean); virtual;\r\n property CaseSensitive: Boolean read GetCaseSensitive write SetCaseSensitive;\r\n end;\r\n\r\n TJclAnsiStrAbstractContainer = class(TJclStrAbstractContainer, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclCloneable, IJclIntfCloneable, IJclBaseContainer, IJclStrBaseContainer, IJclAnsiStrContainer,\r\n IJclAnsiStrOwner, IJclAnsiStrEqualityComparer, IJclAnsiStrComparer, IJclAnsiStrHashConverter)\r\n protected\r\n FEncoding: TJclAnsiStrEncoding;\r\n FEqualityCompare: TAnsiStrEqualityCompare;\r\n FCompare: TAnsiStrCompare;\r\n FHashConvert: TAnsiStrHashConvert;\r\n FOnFreeString: TFreeAnsiStrEvent;\r\n procedure AssignPropertiesTo(Dest: TJclAbstractContainerBase); override;\r\n public\r\n { IJclAnsiStrOwner }\r\n function GetOnFreeString: TFreeAnsiStrEvent;\r\n function FreeString(var AString: AnsiString): AnsiString; virtual;\r\n procedure SetOnFreeString(Value: TFreeAnsiStrEvent);\r\n property OnFreeString: TFreeAnsiStrEvent read GetOnFreeString write SetOnFreeString;\r\n { IJclAnsiStrContainer }\r\n function GetEncoding: TJclAnsiStrEncoding; virtual;\r\n procedure SetEncoding(Value: TJclAnsiStrEncoding); virtual;\r\n property Encoding: TJclAnsiStrEncoding read GetEncoding write SetEncoding;\r\n { IJclAnsiStrEqualityComparer }\r\n function GetEqualityCompare: TAnsiStrEqualityCompare; virtual;\r\n procedure SetEqualityCompare(Value: TAnsiStrEqualityCompare); virtual;\r\n function ItemsEqual(const A, B: AnsiString): Boolean; virtual;\r\n property EqualityCompare: TAnsiStrEqualityCompare read GetEqualityCompare write SetEqualityCompare;\r\n { IJclAnsiStrComparer }\r\n function GetCompare: TAnsiStrCompare; virtual;\r\n procedure SetCompare(Value: TAnsiStrCompare); virtual;\r\n function ItemsCompare(const A, B: AnsiString): Integer; virtual;\r\n property Compare: TAnsiStrCompare read GetCompare write SetCompare;\r\n { IJclAnsiStrHashConverter }\r\n function GetHashConvert: TAnsiStrHashConvert; virtual;\r\n procedure SetHashConvert(Value: TAnsiStrHashConvert); virtual;\r\n function Hash(const AString: AnsiString): Integer; virtual;\r\n property HashConvert: TAnsiStrHashConvert read GetHashConvert write SetHashConvert;\r\n end;\r\n\r\n TJclWideStrAbstractContainer = class(TJclStrAbstractContainer, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclCloneable, IJclIntfCloneable, IJclBaseContainer, IJclStrBaseContainer, IJclWideStrContainer,\r\n IJclWideStrOwner, IJclWideStrEqualityComparer, IJclWideStrComparer, IJclWideStrHashConverter)\r\n protected\r\n FEncoding: TJclWideStrEncoding;\r\n FEqualityCompare: TWideStrEqualityCompare;\r\n FCompare: TWideStrCompare;\r\n FHashConvert: TWideStrHashConvert;\r\n FOnFreeString: TFreeWideStrEvent;\r\n procedure AssignPropertiesTo(Dest: TJclAbstractContainerBase); override;\r\n public\r\n { IJclWideStrOwner }\r\n function GetOnFreeString: TFreeWideStrEvent;\r\n function FreeString(var AString: WideString): WideString; virtual;\r\n procedure SetOnFreeString(Value: TFreeWideStrEvent);\r\n property OnFreeString: TFreeWideStrEvent read GetOnFreeString write SetOnFreeString;\r\n { IJclWideStrContainer }\r\n function GetEncoding: TJclWideStrEncoding; virtual;\r\n procedure SetEncoding(Value: TJclWideStrEncoding); virtual;\r\n property Encoding: TJclWideStrEncoding read GetEncoding write SetEncoding;\r\n { IJclWideStrEqualityComparer }\r\n function GetEqualityCompare: TWideStrEqualityCompare; virtual;\r\n procedure SetEqualityCompare(Value: TWideStrEqualityCompare); virtual;\r\n function ItemsEqual(const A, B: WideString): Boolean; virtual;\r\n property EqualityCompare: TWideStrEqualityCompare read GetEqualityCompare write SetEqualityCompare;\r\n { IJclWideStrComparer }\r\n function GetCompare: TWideStrCompare; virtual;\r\n procedure SetCompare(Value: TWideStrCompare); virtual;\r\n function ItemsCompare(const A, B: WideString): Integer; virtual;\r\n property Compare: TWideStrCompare read GetCompare write SetCompare;\r\n { IJclWideStrHashConverter }\r\n function GetHashConvert: TWideStrHashConvert; virtual;\r\n procedure SetHashConvert(Value: TWideStrHashConvert); virtual;\r\n function Hash(const AString: WideString): Integer; virtual;\r\n property HashConvert: TWideStrHashConvert read GetHashConvert write SetHashConvert;\r\n end;\r\n\r\n {$IFDEF SUPPORTS_UNICODE_STRING}\r\n TJclUnicodeStrAbstractContainer = class(TJclStrAbstractContainer, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclCloneable, IJclIntfCloneable, IJclBaseContainer, IJclStrBaseContainer, IJclUnicodeStrContainer,\r\n IJclUnicodeStrOwner, IJclUnicodeStrEqualityComparer, IJclUnicodeStrComparer, IJclUnicodeStrHashConverter)\r\n protected\r\n FEqualityCompare: TUnicodeStrEqualityCompare;\r\n FCompare: TUnicodeStrCompare;\r\n FHashConvert: TUnicodeStrHashConvert;\r\n FOnFreeString: TFreeUnicodeStrEvent;\r\n procedure AssignPropertiesTo(Dest: TJclAbstractContainerBase); override;\r\n public\r\n { IJclUnicodeStrOwner }\r\n function GetOnFreeString: TFreeUnicodeStrEvent;\r\n function FreeString(var AString: UnicodeString): UnicodeString; virtual;\r\n procedure SetOnFreeString(Value: TFreeUnicodeStrEvent);\r\n property OnFreeString: TFreeUnicodeStrEvent read GetOnFreeString write SetOnFreeString;\r\n { IJclUnicodeStrEqualityComparer }\r\n function GetEqualityCompare: TUnicodeStrEqualityCompare; virtual;\r\n procedure SetEqualityCompare(Value: TUnicodeStrEqualityCompare); virtual;\r\n function ItemsEqual(const A, B: UnicodeString): Boolean; virtual;\r\n property EqualityCompare: TUnicodeStrEqualityCompare read GetEqualityCompare write SetEqualityCompare;\r\n { IJclUnicodeStrComparer }\r\n function GetCompare: TUnicodeStrCompare; virtual;\r\n procedure SetCompare(Value: TUnicodeStrCompare); virtual;\r\n function ItemsCompare(const A, B: UnicodeString): Integer; virtual;\r\n property Compare: TUnicodeStrCompare read GetCompare write SetCompare;\r\n { IJclUnicodeStrHashConverter }\r\n function GetHashConvert: TUnicodeStrHashConvert; virtual;\r\n procedure SetHashConvert(Value: TUnicodeStrHashConvert); virtual;\r\n function Hash(const AString: UnicodeString): Integer; virtual;\r\n property HashConvert: TUnicodeStrHashConvert read GetHashConvert write SetHashConvert;\r\n end;\r\n {$ENDIF SUPPORTS_UNICODE_STRING}\r\n\r\n TJclSingleAbstractContainer = class(TJclAbstractContainerBase, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclCloneable, IJclIntfCloneable, IJclBaseContainer, IJclSingleContainer,\r\n IJclSingleOwner, IJclSingleEqualityComparer, IJclSingleComparer, IJclSingleHashConverter)\r\n protected\r\n FPrecision: Single;\r\n FEqualityCompare: TSingleEqualityCompare;\r\n FCompare: TSingleCompare;\r\n FHashConvert: TSingleHashConvert;\r\n FOnFreeSingle: TFreeSingleEvent;\r\n procedure AssignPropertiesTo(Dest: TJclAbstractContainerBase); override;\r\n public\r\n { IJclSingleOwner }\r\n function GetOnFreeSingle: TFreeSingleEvent;\r\n function FreeSingle(var AValue: Single): Single; virtual;\r\n procedure SetOnFreeSingle(Value: TFreeSingleEvent);\r\n property OnFreeSingle: TFreeSingleEvent read GetOnFreeSingle write SetOnFreeSingle;\r\n { IJclSingleContainer }\r\n function GetPrecision: Single; virtual;\r\n procedure SetPrecision(const Value: Single); virtual;\r\n property Precision: Single read GetPrecision write SetPrecision;\r\n { IJclSingleEqualityComparer }\r\n function GetEqualityCompare: TSingleEqualityCompare; virtual;\r\n procedure SetEqualityCompare(Value: TSingleEqualityCompare); virtual;\r\n function ItemsEqual(const A, B: Single): Boolean; virtual;\r\n property EqualityCompare: TSingleEqualityCompare read GetEqualityCompare write SetEqualityCompare;\r\n { IJclSingleComparer }\r\n function GetCompare: TSingleCompare; virtual;\r\n procedure SetCompare(Value: TSingleCompare); virtual;\r\n function ItemsCompare(const A, B: Single): Integer; virtual;\r\n property Compare: TSingleCompare read GetCompare write SetCompare;\r\n { IJclSingleHashConverter }\r\n function GetHashConvert: TSingleHashConvert; virtual;\r\n procedure SetHashConvert(Value: TSingleHashConvert); virtual;\r\n function Hash(const AValue: Single): Integer; virtual;\r\n property HashConvert: TSingleHashConvert read GetHashConvert write SetHashConvert;\r\n end;\r\n\r\n TJclDoubleAbstractContainer = class(TJclAbstractContainerBase, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclCloneable, IJclIntfCloneable, IJclBaseContainer, IJclDoubleContainer,\r\n IJclDoubleOwner, IJclDoubleEqualityComparer, IJclDoubleComparer, IJclDoubleHashConverter)\r\n protected\r\n FPrecision: Double;\r\n FEqualityCompare: TDoubleEqualityCompare;\r\n FCompare: TDoubleCompare;\r\n FHashConvert: TDoubleHashConvert;\r\n FOnFreeDouble: TFreeDoubleEvent;\r\n procedure AssignPropertiesTo(Dest: TJclAbstractContainerBase); override;\r\n public\r\n { IJclDoubleOwner }\r\n function GetOnFreeDouble: TFreeDoubleEvent;\r\n function FreeDouble(var AValue: Double): Double; virtual;\r\n procedure SetOnFreeDouble(Value: TFreeDoubleEvent);\r\n property OnFreeDouble: TFreeDoubleEvent read GetOnFreeDouble write SetOnFreeDouble;\r\n { IJclDoubleContainer }\r\n function GetPrecision: Double; virtual;\r\n procedure SetPrecision(const Value: Double); virtual;\r\n property Precision: Double read GetPrecision write SetPrecision;\r\n { IJclDoubleEqualityComparer }\r\n function GetEqualityCompare: TDoubleEqualityCompare; virtual;\r\n procedure SetEqualityCompare(Value: TDoubleEqualityCompare); virtual;\r\n function ItemsEqual(const A, B: Double): Boolean; virtual;\r\n property EqualityCompare: TDoubleEqualityCompare read GetEqualityCompare write SetEqualityCompare;\r\n { IJclDoubleComparer }\r\n function GetCompare: TDoubleCompare; virtual;\r\n procedure SetCompare(Value: TDoubleCompare); virtual;\r\n function ItemsCompare(const A, B: Double): Integer; virtual;\r\n property Compare: TDoubleCompare read GetCompare write SetCompare;\r\n { IJclDoubleHashConverter }\r\n function GetHashConvert: TDoubleHashConvert; virtual;\r\n procedure SetHashConvert(Value: TDoubleHashConvert); virtual;\r\n function Hash(const AValue: Double): Integer; virtual;\r\n property HashConvert: TDoubleHashConvert read GetHashConvert write SetHashConvert;\r\n end;\r\n\r\n TJclExtendedAbstractContainer = class(TJclAbstractContainerBase, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclCloneable, IJclIntfCloneable, IJclBaseContainer, IJclExtendedContainer,\r\n IJclExtendedOwner, IJclExtendedEqualityComparer, IJclExtendedComparer, IJclExtendedHashConverter)\r\n protected\r\n FPrecision: Extended;\r\n FEqualityCompare: TExtendedEqualityCompare;\r\n FCompare: TExtendedCompare;\r\n FHashConvert: TExtendedHashConvert;\r\n FOnFreeExtended: TFreeExtendedEvent;\r\n procedure AssignPropertiesTo(Dest: TJclAbstractContainerBase); override;\r\n public\r\n { IJclExtendedOwner }\r\n function GetOnFreeExtended: TFreeExtendedEvent;\r\n function FreeExtended(var AValue: Extended): Extended; virtual;\r\n procedure SetOnFreeExtended(Value: TFreeExtendedEvent);\r\n property OnFreeExtended: TFreeExtendedEvent read GetOnFreeExtended write SetOnFreeExtended;\r\n { IJclExtendedContainer }\r\n function GetPrecision: Extended; virtual;\r\n procedure SetPrecision(const Value: Extended); virtual;\r\n property Precision: Extended read GetPrecision write SetPrecision;\r\n { IJclExtendedEqualityComparer }\r\n function GetEqualityCompare: TExtendedEqualityCompare; virtual;\r\n procedure SetEqualityCompare(Value: TExtendedEqualityCompare); virtual;\r\n function ItemsEqual(const A, B: Extended): Boolean; virtual;\r\n property EqualityCompare: TExtendedEqualityCompare read GetEqualityCompare write SetEqualityCompare;\r\n { IJclExtendedComparer }\r\n function GetCompare: TExtendedCompare; virtual;\r\n procedure SetCompare(Value: TExtendedCompare); virtual;\r\n function ItemsCompare(const A, B: Extended): Integer; virtual;\r\n property Compare: TExtendedCompare read GetCompare write SetCompare;\r\n { IJclExtendedHashConverter }\r\n function GetHashConvert: TExtendedHashConvert; virtual;\r\n procedure SetHashConvert(Value: TExtendedHashConvert); virtual;\r\n function Hash(const AValue: Extended): Integer; virtual;\r\n property HashConvert: TExtendedHashConvert read GetHashConvert write SetHashConvert;\r\n end;\r\n\r\n TJclIntegerAbstractContainer = class(TJclAbstractContainerBase, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclCloneable, IJclIntfCloneable, IJclBaseContainer, IJclIntegerContainer,\r\n IJclIntegerOwner, IJclIntegerEqualityComparer, IJclIntegerComparer, IJclIntegerHashConverter)\r\n protected\r\n FEqualityCompare: TIntegerEqualityCompare;\r\n FCompare: TIntegerCompare;\r\n FHashConvert: TIntegerHashConvert;\r\n FOnFreeInteger: TFreeIntegerEvent;\r\n procedure AssignPropertiesTo(Dest: TJclAbstractContainerBase); override;\r\n public\r\n { IJclIntegerOwner }\r\n function GetOnFreeInteger: TFreeIntegerEvent;\r\n function FreeInteger(var AValue: Integer): Integer; virtual;\r\n procedure SetOnFreeInteger(Value: TFreeIntegerEvent);\r\n property OnFreeInteger: TFreeIntegerEvent read GetOnFreeInteger write SetOnFreeInteger;\r\n { IJclIntegerEqualityComparer }\r\n function GetEqualityCompare: TIntegerEqualityCompare; virtual;\r\n procedure SetEqualityCompare(Value: TIntegerEqualityCompare); virtual;\r\n function ItemsEqual(A, B: Integer): Boolean; virtual;\r\n property EqualityCompare: TIntegerEqualityCompare read GetEqualityCompare write SetEqualityCompare;\r\n { IJclIntegerComparer }\r\n function GetCompare: TIntegerCompare; virtual;\r\n procedure SetCompare(Value: TIntegerCompare); virtual;\r\n function ItemsCompare(A, B: Integer): Integer; virtual;\r\n property Compare: TIntegerCompare read GetCompare write SetCompare;\r\n { IJclIntegerHashConverter }\r\n function GetHashConvert: TIntegerHashConvert; virtual;\r\n procedure SetHashConvert(Value: TIntegerHashConvert); virtual;\r\n function Hash(AValue: Integer): Integer; virtual;\r\n property HashConvert: TIntegerHashConvert read GetHashConvert write SetHashConvert;\r\n end;\r\n\r\n TJclCardinalAbstractContainer = class(TJclAbstractContainerBase, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclCloneable, IJclIntfCloneable, IJclBaseContainer, IJclCardinalContainer,\r\n IJclCardinalOwner, IJclCardinalEqualityComparer, IJclCardinalComparer, IJclCardinalHashConverter)\r\n protected\r\n FEqualityCompare: TCardinalEqualityCompare;\r\n FCompare: TCardinalCompare;\r\n FHashConvert: TCardinalHashConvert;\r\n FOnFreeCardinal: TFreeCardinalEvent;\r\n procedure AssignPropertiesTo(Dest: TJclAbstractContainerBase); override;\r\n public\r\n { IJclCardinalOwner }\r\n function GetOnFreeCardinal: TFreeCardinalEvent;\r\n function FreeCardinal(var AValue: Cardinal): Cardinal; virtual;\r\n procedure SetOnFreeCardinal(Value: TFreeCardinalEvent);\r\n property OnFreeCardinal: TFreeCardinalEvent read GetOnFreeCardinal write SetOnFreeCardinal;\r\n { IJclCardinalEqualityComparer }\r\n function GetEqualityCompare: TCardinalEqualityCompare; virtual;\r\n procedure SetEqualityCompare(Value: TCardinalEqualityCompare); virtual;\r\n function ItemsEqual(A, B: Cardinal): Boolean; virtual;\r\n property EqualityCompare: TCardinalEqualityCompare read GetEqualityCompare write SetEqualityCompare;\r\n { IJclCardinalComparer }\r\n function GetCompare: TCardinalCompare; virtual;\r\n procedure SetCompare(Value: TCardinalCompare); virtual;\r\n function ItemsCompare(A, B: Cardinal): Integer; virtual;\r\n property Compare: TCardinalCompare read GetCompare write SetCompare;\r\n { IJclCardinalHashConverter }\r\n function GetHashConvert: TCardinalHashConvert; virtual;\r\n procedure SetHashConvert(Value: TCardinalHashConvert); virtual;\r\n function Hash(AValue: Cardinal): Integer; virtual;\r\n property HashConvert: TCardinalHashConvert read GetHashConvert write SetHashConvert;\r\n end;\r\n\r\n TJclInt64AbstractContainer = class(TJclAbstractContainerBase, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclCloneable, IJclIntfCloneable, IJclBaseContainer, IJclInt64Container,\r\n IJclInt64Owner, IJclInt64EqualityComparer, IJclInt64Comparer, IJclInt64HashConverter)\r\n protected\r\n FEqualityCompare: TInt64EqualityCompare;\r\n FCompare: TInt64Compare;\r\n FHashConvert: TInt64HashConvert;\r\n FOnFreeInt64: TFreeInt64Event;\r\n procedure AssignPropertiesTo(Dest: TJclAbstractContainerBase); override;\r\n public\r\n { IJclInt64Owner }\r\n function GetOnFreeInt64: TFreeInt64Event;\r\n function FreeInt64(var AValue: Int64): Int64; virtual;\r\n procedure SetOnFreeInt64(Value: TFreeInt64Event);\r\n property OnFreeInt64: TFreeInt64Event read GetOnFreeInt64 write SetOnFreeInt64;\r\n { IJclInt64EqualityComparer }\r\n function GetEqualityCompare: TInt64EqualityCompare; virtual;\r\n procedure SetEqualityCompare(Value: TInt64EqualityCompare); virtual;\r\n function ItemsEqual(const A, B: Int64): Boolean; virtual;\r\n property EqualityCompare: TInt64EqualityCompare read GetEqualityCompare write SetEqualityCompare;\r\n { IJclInt64Comparer }\r\n function GetCompare: TInt64Compare; virtual;\r\n procedure SetCompare(Value: TInt64Compare); virtual;\r\n function ItemsCompare(const A, B: Int64): Integer; virtual;\r\n property Compare: TInt64Compare read GetCompare write SetCompare;\r\n { IJclInt64HashConverter }\r\n function GetHashConvert: TInt64HashConvert; virtual;\r\n procedure SetHashConvert(Value: TInt64HashConvert); virtual;\r\n function Hash(const AValue: Int64): Integer; virtual;\r\n property HashConvert: TInt64HashConvert read GetHashConvert write SetHashConvert;\r\n end;\r\n\r\n TJclPtrAbstractContainer = class(TJclAbstractContainerBase, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclCloneable, IJclIntfCloneable, IJclBaseContainer, IJclPtrContainer,\r\n IJclPtrOwner, IJclPtrEqualityComparer, IJclPtrComparer, IJclPtrHashConverter)\r\n protected\r\n FEqualityCompare: TPtrEqualityCompare;\r\n FCompare: TPtrCompare;\r\n FHashConvert: TPtrHashConvert;\r\n FOnFreePointer: TFreePtrEvent;\r\n procedure AssignPropertiesTo(Dest: TJclAbstractContainerBase); override;\r\n public\r\n { IJclPtrOwner }\r\n function GetOnFreePointer: TFreePtrEvent;\r\n function FreePointer(var APtr: Pointer): Pointer; virtual;\r\n procedure SetOnFreePointer(Value: TFreePtrEvent);\r\n property OnFreePointer: TFreePtrEvent read GetOnFreePointer write SetOnFreePointer;\r\n { IJclPtrEqualityComparer }\r\n function GetEqualityCompare: TPtrEqualityCompare; virtual;\r\n procedure SetEqualityCompare(Value: TPtrEqualityCompare); virtual;\r\n function ItemsEqual(A, B: Pointer): Boolean; virtual;\r\n property EqualityCompare: TPtrEqualityCompare read GetEqualityCompare write SetEqualityCompare;\r\n { IJclPtrComparer }\r\n function GetCompare: TPtrCompare; virtual;\r\n procedure SetCompare(Value: TPtrCompare); virtual;\r\n function ItemsCompare(A, B: Pointer): Integer; virtual;\r\n property Compare: TPtrCompare read GetCompare write SetCompare;\r\n { IJclPtrHashConverter }\r\n function GetHashConvert: TPtrHashConvert; virtual;\r\n procedure SetHashConvert(Value: TPtrHashConvert); virtual;\r\n function Hash(APtr: Pointer): Integer; virtual;\r\n property HashConvert: TPtrHashConvert read GetHashConvert write SetHashConvert;\r\n end;\r\n\r\n TJclAbstractContainer = class(TJclAbstractContainerBase, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclCloneable, IJclIntfCloneable, IJclBaseContainer, IJclContainer,\r\n IJclObjectOwner, IJclEqualityComparer, IJclComparer, IJclHashConverter)\r\n protected\r\n FOwnsObjects: Boolean;\r\n FEqualityCompare: TEqualityCompare;\r\n FCompare: TCompare;\r\n FHashConvert: THashConvert;\r\n FOnFreeObject: TFreeObjectEvent;\r\n procedure AssignPropertiesTo(Dest: TJclAbstractContainerBase); override;\r\n public\r\n constructor Create(AOwnsObjects: Boolean);\r\n { IJclObjectOwner }\r\n function GetOnFreeObject: TFreeObjectEvent;\r\n function FreeObject(var AObject: TObject): TObject; virtual;\r\n procedure SetOnFreeObject(Value: TFreeObjectEvent);\r\n property OnFreeObject: TFreeObjectEvent read GetOnFreeObject write SetOnFreeObject;\r\n function GetOwnsObjects: Boolean; virtual;\r\n property OwnsObjects: Boolean read GetOwnsObjects;\r\n { IJclEqualityComparer }\r\n function GetEqualityCompare: TEqualityCompare; virtual;\r\n procedure SetEqualityCompare(Value: TEqualityCompare); virtual;\r\n function ItemsEqual(A, B: TObject): Boolean; virtual;\r\n property EqualityCompare: TEqualityCompare read GetEqualityCompare write SetEqualityCompare;\r\n { IJclComparer }\r\n function GetCompare: TCompare; virtual;\r\n procedure SetCompare(Value: TCompare); virtual;\r\n function ItemsCompare(A, B: TObject): Integer; virtual;\r\n property Compare: TCompare read GetCompare write SetCompare;\r\n { IJclHashConverter }\r\n function GetHashConvert: THashConvert; virtual;\r\n procedure SetHashConvert(Value: THashConvert); virtual;\r\n function Hash(AObject: TObject): Integer; virtual;\r\n property HashConvert: THashConvert read GetHashConvert write SetHashConvert;\r\n end;\r\n\r\n {$IFDEF SUPPORTS_GENERICS}\r\n //DOM-IGNORE-BEGIN\r\n\r\n TJclAbstractContainer = class(TJclAbstractContainerBase, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclCloneable, IJclIntfCloneable, IJclBaseContainer, IJclContainer,\r\n IJclItemOwner, IJclEqualityComparer, IJclComparer, IJclHashConverter)\r\n protected\r\n FOwnsItems: Boolean;\r\n FEqualityCompare: TEqualityCompare;\r\n FCompare: TCompare;\r\n FHashConvert: THashConvert;\r\n FOnFreeItem: TFreeItemEvent;\r\n procedure AssignPropertiesTo(Dest: TJclAbstractContainerBase); override;\r\n public\r\n constructor Create(AOwnsItems: Boolean);\r\n { IJclItemOwner }\r\n function GetOnFreeItem: TFreeItemEvent;\r\n function FreeItem(var AItem: T): T; virtual;\r\n procedure SetOnFreeItem(Value: TFreeItemEvent);\r\n property OnFreeItem: TFreeItemEvent read GetOnFreeItem write SetOnFreeItem;\r\n function GetOwnsItems: Boolean; virtual;\r\n property OwnsItems: Boolean read GetOwnsItems;\r\n { IJclEqualityComparer }\r\n function GetEqualityCompare: TEqualityCompare; virtual;\r\n procedure SetEqualityCompare(Value: TEqualityCompare); virtual;\r\n function ItemsEqual(const A, B: T): Boolean; virtual;\r\n property EqualityCompare: TEqualityCompare read GetEqualityCompare write SetEqualityCompare;\r\n { IJclComparer }\r\n function GetCompare: TCompare; virtual;\r\n procedure SetCompare(Value: TCompare); virtual;\r\n function ItemsCompare(const A, B: T): Integer; virtual;\r\n property Compare: TCompare read GetCompare write SetCompare;\r\n { IJclHashConverter }\r\n function GetHashConvert: THashConvert; virtual;\r\n procedure SetHashConvert(Value: THashConvert); virtual;\r\n function Hash(const AItem: T): Integer; virtual;\r\n property HashConvert: THashConvert read GetHashConvert write SetHashConvert;\r\n end;\r\n\r\n //DOM-IGNORE-END\r\n {$ENDIF SUPPORTS_GENERICS}\r\n\r\n TJclAnsiStrAbstractCollection = class(TJclAnsiStrAbstractContainer,\r\n {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE} IJclCloneable, IJclIntfCloneable, IJclBaseContainer,\r\n IJclStrBaseContainer, IJclAnsiStrContainer, IJclAnsiStrFlatContainer, IJclAnsiStrCollection,\r\n IJclAnsiStrEqualityComparer, IJclAnsiStrComparer)\r\n public\r\n { IJclAnsiStrCollection }\r\n function Add(const AString: AnsiString): Boolean; virtual; abstract;\r\n function AddAll(const ACollection: IJclAnsiStrCollection): Boolean; virtual; abstract;\r\n procedure Clear; virtual; abstract;\r\n function Contains(const AString: AnsiString): Boolean; virtual; abstract;\r\n function ContainsAll(const ACollection: IJclAnsiStrCollection): Boolean; virtual; abstract;\r\n function CollectionEquals(const ACollection: IJclAnsiStrCollection): Boolean; virtual; abstract;\r\n function Extract(const AString: AnsiString): Boolean; virtual; abstract;\r\n function ExtractAll(const ACollection: IJclAnsiStrCollection): Boolean; virtual; abstract;\r\n function First: IJclAnsiStrIterator; virtual; abstract;\r\n function IsEmpty: Boolean; virtual; abstract;\r\n function Last: IJclAnsiStrIterator; virtual; abstract;\r\n function Remove(const AString: AnsiString): Boolean; virtual; abstract;\r\n function RemoveAll(const ACollection: IJclAnsiStrCollection): Boolean; virtual; abstract;\r\n function RetainAll(const ACollection: IJclAnsiStrCollection): Boolean; virtual; abstract;\r\n function Size: Integer; virtual; abstract;\r\n {$IFDEF SUPPORTS_FOR_IN}\r\n function GetEnumerator: IJclAnsistrIterator; virtual; abstract;\r\n {$ENDIF SUPPORTS_FOR_IN}\r\n { IJclAnsiStrFlatContainer }\r\n procedure LoadFromStrings(Strings: TJclAnsiStrings);\r\n procedure SaveToStrings(Strings: TJclAnsiStrings);\r\n procedure AppendToStrings(Strings: TJclAnsiStrings);\r\n procedure AppendFromStrings(Strings: TJclAnsiStrings);\r\n function GetAsStrings: TJclAnsiStrings;\r\n function GetAsDelimited(const Separator: AnsiString = AnsiLineBreak): AnsiString;\r\n procedure AppendDelimited(const AString: AnsiString; const Separator: AnsiString = AnsiLineBreak);\r\n procedure LoadDelimited(const AString: AnsiString; const Separator: AnsiString = AnsiLineBreak);\r\n end;\r\n\r\n TJclWideStrAbstractCollection = class(TJclWideStrAbstractContainer,\r\n {$IFDEF THREADSAFE}IJclLockable,{$ENDIF THREADSAFE} IJclCloneable, IJclIntfCloneable, IJclBaseContainer,\r\n IJclStrBaseContainer, IJclWideStrContainer, IJclWideStrFlatContainer, IJclWideStrCollection,\r\n IJclWideStrEqualityComparer, IJclWideStrComparer)\r\n public\r\n { IJclWideStrCollection }\r\n function Add(const AString: WideString): Boolean; virtual; abstract;\r\n function AddAll(const ACollection: IJclWideStrCollection): Boolean; virtual; abstract;\r\n procedure Clear; virtual; abstract;\r\n function Contains(const AString: WideString): Boolean; virtual; abstract;\r\n function ContainsAll(const ACollection: IJclWideStrCollection): Boolean; virtual; abstract;\r\n function CollectionEquals(const ACollection: IJclWideStrCollection): Boolean; virtual; abstract;\r\n function Extract(const AString: WideString): Boolean; virtual; abstract;\r\n function ExtractAll(const ACollection: IJclWideStrCollection): Boolean; virtual; abstract;\r\n function First: IJclWideStrIterator; virtual; abstract;\r\n function IsEmpty: Boolean; virtual; abstract;\r\n function Last: IJclWideStrIterator; virtual; abstract;\r\n function Remove(const AString: WideString): Boolean; virtual; abstract;\r\n function RemoveAll(const ACollection: IJclWideStrCollection): Boolean; virtual; abstract;\r\n function RetainAll(const ACollection: IJclWideStrCollection): Boolean; virtual; abstract;\r\n function Size: Integer; virtual; abstract;\r\n {$IFDEF SUPPORTS_FOR_IN}\r\n function GetEnumerator: IJclWideStrIterator; virtual; abstract;\r\n {$ENDIF SUPPORTS_FOR_IN}\r\n { IJclWideStrFlatContainer }\r\n procedure LoadFromStrings(Strings: TJclWideStrings);\r\n procedure SaveToStrings(Strings: TJclWideStrings);\r\n procedure AppendToStrings(Strings: TJclWideStrings);\r\n procedure AppendFromStrings(Strings: TJclWideStrings);\r\n function GetAsStrings: TJclWideStrings;\r\n function GetAsDelimited(const Separator: WideString = WideLineBreak): WideString;\r\n procedure AppendDelimited(const AString: WideString; const Separator: WideString = WideLineBreak);\r\n procedure LoadDelimited(const AString: WideString; const Separator: WideString = WideLineBreak);\r\n end;\r\n\r\n {$IFDEF SUPPORTS_UNICODE_STRING}\r\n TJclUnicodeStrAbstractCollection = class(TJclUnicodeStrAbstractContainer,\r\n {$IFDEF THREADSAFE}IJclLockable,{$ENDIF THREADSAFE} IJclCloneable, IJclIntfCloneable, IJclBaseContainer,\r\n IJclStrBaseContainer, IJclUnicodeStrContainer, IJclUnicodeStrFlatContainer, IJclUnicodeStrCollection,\r\n IJclUnicodeStrEqualityComparer, IJclUnicodeStrComparer)\r\n public\r\n { IJclUnicodeStrCollection }\r\n function Add(const AString: UnicodeString): Boolean; virtual; abstract;\r\n function AddAll(const ACollection: IJclUnicodeStrCollection): Boolean; virtual; abstract;\r\n procedure Clear; virtual; abstract;\r\n function Contains(const AString: UnicodeString): Boolean; virtual; abstract;\r\n function ContainsAll(const ACollection: IJclUnicodeStrCollection): Boolean; virtual; abstract;\r\n function CollectionEquals(const ACollection: IJclUnicodeStrCollection): Boolean; virtual; abstract;\r\n function Extract(const AString: UnicodeString): Boolean; virtual; abstract;\r\n function ExtractAll(const ACollection: IJclUnicodeStrCollection): Boolean; virtual; abstract;\r\n function First: IJclUnicodeStrIterator; virtual; abstract;\r\n function IsEmpty: Boolean; virtual; abstract;\r\n function Last: IJclUnicodeStrIterator; virtual; abstract;\r\n function Remove(const AString: UnicodeString): Boolean; virtual; abstract;\r\n function RemoveAll(const ACollection: IJclUnicodeStrCollection): Boolean; virtual; abstract;\r\n function RetainAll(const ACollection: IJclUnicodeStrCollection): Boolean; virtual; abstract;\r\n function Size: Integer; virtual; abstract;\r\n {$IFDEF SUPPORTS_FOR_IN}\r\n function GetEnumerator: IJclUnicodeStrIterator; virtual; abstract;\r\n {$ENDIF SUPPORTS_FOR_IN}\r\n { IJclUnicodeStrFlatContainer }\r\n procedure LoadFromStrings(Strings: TJclUnicodeStrings);\r\n procedure SaveToStrings(Strings: TJclUnicodeStrings);\r\n procedure AppendToStrings(Strings: TJclUnicodeStrings);\r\n procedure AppendFromStrings(Strings: TJclUnicodeStrings);\r\n function GetAsStrings: TJclUnicodeStrings;\r\n function GetAsDelimited(const Separator: UnicodeString = WideLineBreak): UnicodeString;\r\n procedure AppendDelimited(const AString: UnicodeString; const Separator: UnicodeString = WideLineBreak);\r\n procedure LoadDelimited(const AString: UnicodeString; const Separator: UnicodeString = WideLineBreak);\r\n end;\r\n {$ENDIF SUPPORTS_UNICODE_STRING}\r\n\r\nconst\r\n // table of byte permutations without inner loop\r\n BytePermTable: array [Byte] of Byte =\r\n ( 22, 133, 0, 244, 194, 193, 4, 164, 69, 211, 166, 235, 75, 110, 9, 140,\r\n 125, 84, 64, 209, 57, 47, 197, 76, 237, 48, 189, 87, 221, 254, 20, 132,\r\n 25, 162, 203, 225, 186, 165, 72, 228, 61, 208, 158, 185, 114, 173, 1, 66,\r\n 202, 46, 198, 214, 27, 161, 178, 238, 8, 68, 97, 17, 199, 210, 96, 196,\r\n 85, 240, 233, 71, 232, 142, 148, 70, 184, 152, 90, 206, 139, 182, 34, 101,\r\n 104, 12, 143, 227, 24, 247, 175, 150, 39, 31, 36, 123, 62, 119, 236, 28,\r\n 117, 100, 230, 223, 30, 154, 18, 153, 127, 192, 176, 19, 174, 134, 2, 216,\r\n 218, 91, 45, 7, 128, 138, 126, 40, 16, 54, 207, 181, 11, 137, 60, 191,\r\n 51, 231, 121, 213, 86, 111, 141, 172, 98, 226, 179, 249, 136, 58, 88, 93,\r\n 201, 195, 118, 144, 146, 113, 212, 32, 21, 131, 177, 33, 151, 130, 205, 171,\r\n 92, 251, 168, 29, 156, 124, 224, 200, 3, 187, 105, 52, 239, 147, 82, 94,\r\n 26, 102, 243, 242, 145, 163, 49, 135, 43, 78, 112, 83, 63, 35, 170, 167,\r\n 250, 159, 73, 37, 6, 79, 106, 215, 129, 74, 109, 42, 41, 120, 23, 160,\r\n 107, 180, 103, 77, 53, 169, 89, 149, 44, 38, 81, 246, 188, 67, 15, 80,\r\n 155, 99, 95, 5, 229, 108, 13, 255, 59, 241, 252, 245, 222, 248, 115, 55,\r\n 217, 56, 65, 219, 204, 190, 10, 50, 253, 183, 234, 116, 122, 220, 14, 157);\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jcl.svn.sourceforge.net/svnroot/jcl/tags/JCL-2.4-Build4571/jcl/source/common/JclAbstractContainers.pas $';\r\n Revision: '$Revision: 3735 $';\r\n Date: '$Date: 2012-02-19 22:43:22 +0100 (dim. 19 févr. 2012) $';\r\n LogPath: 'JCL\\source\\common';\r\n Extra: '';\r\n Data: nil\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n {$IFDEF HAS_UNITSCOPE}\r\n {$IFDEF HAS_UNIT_ANSISTRINGS}\r\n System.AnsiStrings,\r\n {$ENDIF HAS_UNIT_ANSISTRINGS}\r\n System.SysUtils,\r\n {$ELSE ~HAS_UNITSCOPE}\r\n {$IFDEF HAS_UNIT_ANSISTRINGS}\r\n AnsiStrings,\r\n {$ENDIF HAS_UNIT_ANSISTRINGS}\r\n SysUtils,\r\n {$ENDIF ~HAS_UNITSCOPE}\r\n JclStringConversions, JclUnicode, JclAlgorithms;\r\n\r\n//=== { TJclAbstractLockable } ===============================================\r\n\r\n{$IFDEF THREADSAFE}\r\n\r\nconstructor TJclAbstractLockable.Create;\r\nbegin\r\n inherited Create;\r\n FThreadSafe := True;\r\n FSyncReaderWriter := TJclMultiReadExclusiveWrite.Create(mpReaders);\r\nend;\r\n\r\ndestructor TJclAbstractLockable.Destroy;\r\nbegin\r\n FSyncReaderWriter.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJclAbstractLockable.ReadLock;\r\nbegin\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\nend;\r\n\r\nprocedure TJclAbstractLockable.ReadUnlock;\r\nbegin\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\nend;\r\n\r\nprocedure TJclAbstractLockable.WriteLock;\r\nbegin\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\nend;\r\n\r\nprocedure TJclAbstractLockable.WriteUnlock;\r\nbegin\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\nend;\r\n{$ENDIF THREADSAFE}\r\n\r\n//=== { TJclAbstractContainerBase } ==========================================\r\n\r\nconstructor TJclAbstractContainerBase.Create;\r\nbegin\r\n inherited Create;\r\n\r\n FAllowDefaultElements := True;\r\n FDuplicates := dupAccept;\r\n FRemoveSingleElement := True;\r\n FReturnDefaultElements := True;\r\n FAutoGrowStrategy := agsProportional;\r\n FAutoGrowParameter := 4;\r\n FAutoPackStrategy := apsDisabled;\r\n FAutoPackParameter := 4;\r\nend;\r\n\r\nprocedure TJclAbstractContainerBase.Assign(const Source: IJclBaseContainer);\r\nbegin\r\n Source.AssignTo(Self);\r\nend;\r\n\r\nprocedure TJclAbstractContainerBase.AssignDataTo(Dest: TJclAbstractContainerBase);\r\nbegin\r\n // override to customize\r\n if Dest.ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\nend;\r\n\r\nprocedure TJclAbstractContainerBase.AssignPropertiesTo(Dest: TJclAbstractContainerBase);\r\nbegin\r\n // override to customize\r\n Dest.AllowDefaultElements := AllowDefaultElements;\r\n Dest.Duplicates := Duplicates;\r\n Dest.RemoveSingleElement := RemoveSingleElement;\r\n Dest.ReturnDefaultElements := ReturnDefaultElements;\r\n Dest.AutoGrowParameter := AutoGrowParameter;\r\n Dest.AutoGrowStrategy := AutoGrowStrategy;\r\n Dest.AutoPackParameter := AutoPackParameter;\r\n Dest.AutoPackStrategy := AutoPackStrategy;\r\nend;\r\n\r\nprocedure TJclAbstractContainerBase.AssignTo(const Dest: IJclBaseContainer);\r\nvar\r\n DestObject: TObject;\r\nbegin\r\n DestObject := Dest.GetContainerReference;\r\n if DestObject is TJclAbstractContainerBase then\r\n begin\r\n AssignPropertiesTo(TJclAbstractContainerBase(DestObject));\r\n AssignDataTo(TJclAbstractContainerBase(DestObject));\r\n end\r\n else\r\n raise EJclAssignError.Create;\r\nend;\r\n\r\nprocedure TJclAbstractContainerBase.AutoGrow;\r\nbegin\r\n SetCapacity(CalcGrowCapacity(FCapacity, FSize));\r\nend;\r\n\r\nprocedure TJclAbstractContainerBase.AutoPack;\r\nbegin\r\n SetCapacity(CalcPackCapacity(FCapacity, FSize));\r\nend;\r\n\r\nfunction TJclAbstractContainerBase.CalcGrowCapacity(ACapacity, ASize: Integer): Integer;\r\nvar\r\n Increment: Integer;\r\nbegin\r\n Result := ACapacity;\r\n if ASize = ACapacity then\r\n begin\r\n case FAutoGrowStrategy of\r\n agsDisabled: ;\r\n agsAgressive:\r\n Result := ACapacity + 1;\r\n agsProportional:\r\n begin\r\n Increment := ACapacity div FAutoGrowParameter;\r\n if Increment = 0 then\r\n Increment := 1;\r\n Result := ACapacity + Increment;\r\n end;\r\n agsIncremental:\r\n Result := ACapacity + FAutoGrowParameter;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJclAbstractContainerBase.CalcPackCapacity(ACapacity, ASize: Integer): Integer;\r\nvar\r\n Decrement: Integer;\r\nbegin\r\n Result := ACapacity;\r\n if ASize < ACapacity then\r\n begin\r\n case FAutoPackStrategy of\r\n apsDisabled:\r\n Decrement := 0;\r\n apsAgressive:\r\n Decrement := 1;\r\n apsProportional:\r\n Decrement := ACapacity div FAutoPackParameter;\r\n apsIncremental:\r\n Decrement := FAutoPackParameter;\r\n else\r\n Decrement := 0;\r\n end;\r\n if (Decrement > 0) and ((ASize + Decrement) <= ACapacity) then\r\n Result := ASize;\r\n end;\r\nend;\r\n\r\nfunction TJclAbstractContainerBase.CheckDuplicate: Boolean;\r\nbegin\r\n case FDuplicates of\r\n dupIgnore:\r\n Result := False;\r\n dupAccept:\r\n Result := True;\r\n //dupError: ;\r\n else\r\n raise EJclDuplicateElementError.Create;\r\n end;\r\nend;\r\n\r\nfunction TJclAbstractContainerBase.ObjectClone: TObject;\r\nvar\r\n NewContainer: TJclAbstractContainerBase;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n NewContainer := CreateEmptyContainer;\r\n AssignDataTo(NewContainer);\r\n Result := NewContainer;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclAbstractContainerBase.GetAllowDefaultElements: Boolean;\r\nbegin\r\n Result := FAllowDefaultElements;\r\nend;\r\n\r\nfunction TJclAbstractContainerBase.GetAutoGrowParameter: Integer;\r\nbegin\r\n Result := FAutoGrowParameter;\r\nend;\r\n\r\nfunction TJclAbstractContainerBase.GetAutoGrowStrategy: TJclAutoGrowStrategy;\r\nbegin\r\n Result := FAutoGrowStrategy;\r\nend;\r\n\r\nfunction TJclAbstractContainerBase.GetAutoPackParameter: Integer;\r\nbegin\r\n Result := FAutoPackParameter;\r\nend;\r\n\r\nfunction TJclAbstractContainerBase.GetAutoPackStrategy: TJclAutoPackStrategy;\r\nbegin\r\n Result := FAutoPackStrategy;\r\nend;\r\n\r\nfunction TJclAbstractContainerBase.GetCapacity: Integer;\r\nbegin\r\n Result := FCapacity;\r\nend;\r\n\r\nfunction TJclAbstractContainerBase.GetContainerReference: TObject;\r\nbegin\r\n Result := Self;\r\nend;\r\n\r\nfunction TJclAbstractContainerBase.GetDuplicates: TDuplicates;\r\nbegin\r\n Result := FDuplicates;\r\nend;\r\n\r\nfunction TJclAbstractContainerBase.GetReadOnly: Boolean;\r\nbegin\r\n Result := FReadOnly;\r\nend;\r\n\r\nfunction TJclAbstractContainerBase.GetRemoveSingleElement: Boolean;\r\nbegin\r\n Result := FRemoveSingleElement;\r\nend;\r\n\r\nfunction TJclAbstractContainerBase.GetReturnDefaultElements: Boolean;\r\nbegin\r\n Result := FReturnDefaultElements;\r\nend;\r\n\r\nfunction TJclAbstractContainerBase.GetThreadSafe: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n Result := FThreadSafe;\r\n {$ELSE ~THREADSAFE}\r\n Result := False;\r\n {$ENDIF ~THREADSAFE}\r\nend;\r\n\r\nprocedure TJclAbstractContainerBase.Grow;\r\nbegin\r\n // override to customize\r\n SetCapacity(CalcGrowCapacity(FCapacity, FSize));\r\nend;\r\n\r\nfunction TJclAbstractContainerBase.IntfClone: IInterface;\r\nvar\r\n NewContainer: TJclAbstractContainerBase;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n NewContainer := CreateEmptyContainer;\r\n AssignDataTo(NewContainer);\r\n Result := NewContainer;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclAbstractContainerBase.Pack;\r\nbegin\r\n // override to customize\r\n SetCapacity(CalcPackCapacity(FCapacity, FSize));\r\nend;\r\n\r\nprocedure TJclAbstractContainerBase.SetAllowDefaultElements(Value: Boolean);\r\nbegin\r\n FAllowDefaultElements := Value;\r\nend;\r\n\r\nprocedure TJclAbstractContainerBase.SetAutoGrowParameter(Value: Integer);\r\nbegin\r\n FAutoGrowParameter := Value;\r\nend;\r\n\r\nprocedure TJclAbstractContainerBase.SetAutoGrowStrategy(Value: TJclAutoGrowStrategy);\r\nbegin\r\n FAutoGrowStrategy := Value;\r\nend;\r\n\r\nprocedure TJclAbstractContainerBase.SetAutoPackParameter(Value: Integer);\r\nbegin\r\n FAutoPackParameter := Value;\r\nend;\r\n\r\nprocedure TJclAbstractContainerBase.SetAutoPackStrategy(Value: TJclAutoPackStrategy);\r\nbegin\r\n FAutoPackStrategy := Value;\r\nend;\r\n\r\nprocedure TJclAbstractContainerBase.SetCapacity(Value: Integer);\r\nbegin\r\n FCapacity := Value;\r\nend;\r\n\r\nprocedure TJclAbstractContainerBase.SetDuplicates(Value: TDuplicates);\r\nbegin\r\n FDuplicates := Value;\r\nend;\r\n\r\nprocedure TJclAbstractContainerBase.SetReadOnly(Value: Boolean);\r\nbegin\r\n FReadOnly := Value;\r\nend;\r\n\r\nprocedure TJclAbstractContainerBase.SetRemoveSingleElement(Value: Boolean);\r\nbegin\r\n FRemoveSingleElement := Value;\r\nend;\r\n\r\nprocedure TJclAbstractContainerBase.SetReturnDefaultElements(Value: Boolean);\r\nbegin\r\n FReturnDefaultElements := Value;\r\nend;\r\n\r\nprocedure TJclAbstractContainerBase.SetThreadSafe(Value: Boolean);\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FThreadSafe := Value;\r\n {$ELSE ~THREADSAFE}\r\n if Value then\r\n raise EJclOperationNotSupportedError.Create;\r\n {$ENDIF ~THREADSAFE}\r\nend;\r\n\r\n//=== { TJclAbstractIterator } ===============================================\r\n\r\nconstructor TJclAbstractIterator.Create(AValid: Boolean);\r\nbegin\r\n inherited Create;\r\n FValid := AValid;\r\nend;\r\n\r\nprocedure TJclAbstractIterator.Assign(const Source: IJclAbstractIterator);\r\nbegin\r\n Source.AssignTo(Self);\r\nend;\r\n\r\nprocedure TJclAbstractIterator.AssignPropertiesTo(Dest: TJclAbstractIterator);\r\nbegin\r\n Dest.FValid := FValid;\r\nend;\r\n\r\nprocedure TJclAbstractIterator.AssignTo(const Dest: IJclAbstractIterator);\r\nvar\r\n DestObject: TObject;\r\nbegin\r\n DestObject := Dest.GetIteratorReference;\r\n if DestObject is TJclAbstractIterator then\r\n AssignPropertiesTo(TJclAbstractIterator(DestObject))\r\n else\r\n raise EJclAssignError.Create;\r\nend;\r\n\r\nprocedure TJclAbstractIterator.CheckValid;\r\nbegin\r\n if not Valid then\r\n raise EJclIllegalStateOperationError.Create;\r\nend;\r\n\r\nfunction TJclAbstractIterator.ObjectClone: TObject;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := CreateEmptyIterator;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclAbstractIterator.GetIteratorReference: TObject;\r\nbegin\r\n Result := Self;\r\nend;\r\n\r\nfunction TJclAbstractIterator.IntfClone: IInterface;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := CreateEmptyIterator;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\n//=== { TJclIntfAbstractContainer } ==========================================\r\n\r\nprocedure TJclIntfAbstractContainer.AssignPropertiesTo(Dest: TJclAbstractContainerBase);\r\nvar\r\n ADest: TJclIntfAbstractContainer;\r\nbegin\r\n inherited AssignPropertiesTo(Dest);\r\n if Dest is TJclIntfAbstractContainer then\r\n begin\r\n ADest := TJclIntfAbstractContainer(Dest);\r\n ADest.EqualityCompare := EqualityCompare;\r\n ADest.Compare := Compare;\r\n ADest.HashConvert := HashConvert;\r\n end;\r\nend;\r\n\r\nfunction TJclIntfAbstractContainer.FreeObject(var AInterface: IInterface): IInterface;\r\nbegin\r\n if Assigned(FOnFreeObject) then\r\n Result := FOnFreeObject(AInterface)\r\n else\r\n begin\r\n Result := AInterface;\r\n AInterface := nil;\r\n end;\r\nend;\r\n\r\nfunction TJclIntfAbstractContainer.GetCompare: TIntfCompare;\r\nbegin\r\n Result := FCompare;\r\nend;\r\n\r\nfunction TJclIntfAbstractContainer.GetEqualityCompare: TIntfEqualityCompare;\r\nbegin\r\n Result := FEqualityCompare;\r\nend;\r\n\r\nfunction TJclIntfAbstractContainer.GetHashConvert: TIntfHashConvert;\r\nbegin\r\n Result := FHashConvert;\r\nend;\r\n\r\nfunction TJclIntfAbstractContainer.GetOnFreeObject: TFreeIntfEvent;\r\nbegin\r\n Result := FOnFreeObject;\r\nend;\r\n\r\nfunction TJclIntfAbstractContainer.Hash(const AInterface: IInterface): Integer;\r\nbegin\r\n if Assigned(FHashConvert) then\r\n Result := FHashConvert(AInterface)\r\n else\r\n Result := IntfSimpleHashConvert(AInterface);\r\nend;\r\n\r\nfunction TJclIntfAbstractContainer.ItemsCompare(const A, B: IInterface): Integer;\r\nbegin\r\n if Assigned(FCompare) then\r\n Result := FCompare(A, B)\r\n else\r\n Result := IntfSimpleCompare(A, B);\r\nend;\r\n\r\nfunction TJclIntfAbstractContainer.ItemsEqual(const A, B: IInterface): Boolean;\r\nbegin\r\n if Assigned(FEqualityCompare) then\r\n Result := FEqualityCompare(A, B)\r\n else\r\n if Assigned(FCompare) then\r\n Result := FCompare(A, B) = 0\r\n else\r\n Result := IntfSimpleEqualityCompare(A, B);\r\nend;\r\n\r\nprocedure TJclIntfAbstractContainer.SetCompare(Value: TIntfCompare);\r\nbegin\r\n FCompare := Value;\r\nend;\r\n\r\nprocedure TJclIntfAbstractContainer.SetEqualityCompare(Value: TIntfEqualityCompare);\r\nbegin\r\n FEqualityCompare := Value;\r\nend;\r\n\r\nprocedure TJclIntfAbstractContainer.SetHashConvert(Value: TIntfHashConvert);\r\nbegin\r\n FHashConvert := Value;\r\nend;\r\n\r\nprocedure TJclIntfAbstractContainer.SetOnFreeObject(Value: TFreeIntfEvent);\r\nbegin\r\n FOnFreeObject := Value;\r\nend;\r\n\r\n//=== { TJclStrAbstractContainer } ===========================================\r\n\r\nprocedure TJclStrAbstractContainer.AssignPropertiesTo(Dest: TJclAbstractContainerBase);\r\nbegin\r\n inherited AssignPropertiesTo(Dest);\r\n if Dest is TJclStrAbstractContainer then\r\n TJclStrAbstractContainer(Dest).SetCaseSensitive(GetCaseSensitive);\r\nend;\r\n\r\nfunction TJclStrAbstractContainer.GetCaseSensitive: Boolean;\r\nbegin\r\n Result := FCaseSensitive;\r\nend;\r\n\r\nprocedure TJclStrAbstractContainer.SetCaseSensitive(Value: Boolean);\r\nbegin\r\n FCaseSensitive := Value;\r\nend;\r\n\r\n//=== { TJclAnsiStrAbstractContainer } =======================================\r\n\r\nprocedure TJclAnsiStrAbstractContainer.AssignPropertiesTo(Dest: TJclAbstractContainerBase);\r\nvar\r\n ADest: TJclAnsiStrAbstractContainer;\r\nbegin\r\n inherited AssignPropertiesTo(Dest);\r\n if Dest is TJclAnsiStrAbstractContainer then\r\n begin\r\n ADest := TJclAnsiStrAbstractContainer(Dest);\r\n ADest.Encoding := Encoding;\r\n ADest.EqualityCompare := EqualityCompare;\r\n ADest.Compare := Compare;\r\n ADest.HashConvert := HashConvert;\r\n end;\r\nend;\r\n\r\nfunction TJclAnsiStrAbstractContainer.FreeString(var AString: AnsiString): AnsiString;\r\nbegin\r\n if Assigned(FOnFreeString) then\r\n Result := FOnFreeString(AString)\r\n else\r\n begin\r\n Result := AString;\r\n AString := '';\r\n end;\r\nend;\r\n\r\nfunction TJclAnsiStrAbstractContainer.GetCompare: TAnsiStrCompare;\r\nbegin\r\n Result := FCompare;\r\nend;\r\n\r\nfunction TJclAnsiStrAbstractContainer.GetEncoding: TJclAnsiStrEncoding;\r\nbegin\r\n Result := FEncoding;\r\nend;\r\n\r\nfunction TJclAnsiStrAbstractContainer.GetEqualityCompare: TAnsiStrEqualityCompare;\r\nbegin\r\n Result := FEqualityCompare;\r\nend;\r\n\r\nfunction TJclAnsiStrAbstractContainer.GetHashConvert: TAnsiStrHashConvert;\r\nbegin\r\n Result := FHashConvert;\r\nend;\r\n\r\nfunction TJclAnsiStrAbstractContainer.GetOnFreeString: TFreeAnsiStrEvent;\r\nbegin\r\n Result := FOnFreeString;\r\nend;\r\n\r\nfunction TJclAnsiStrAbstractContainer.Hash(const AString: AnsiString): Integer;\r\nbegin\r\n if Assigned(FHashConvert) then\r\n Result := FHashConvert(AString)\r\n else\r\n begin\r\n case FEncoding of\r\n seISO:\r\n if FCaseSensitive then\r\n Result := AnsiStrSimpleHashConvert(AString)\r\n else\r\n Result := AnsiStrSimpleHashConvertI(AString);\r\n seUTF8:\r\n if FCaseSensitive then\r\n Result := AnsiStrSimpleHashConvertU(AString)\r\n else\r\n Result := AnsiStrSimpleHashConvertUI(AString);\r\n else\r\n raise EJclOperationNotSupportedError.Create;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJclAnsiStrAbstractContainer.ItemsCompare(const A, B: AnsiString): Integer;\r\nbegin\r\n if Assigned(FCompare) then\r\n Result := FCompare(A, B)\r\n else\r\n begin\r\n case FEncoding of\r\n seISO, seUTF8:\r\n if FCaseSensitive then\r\n Result := AnsiStrSimpleCompare(A, B)\r\n else\r\n Result := AnsiStrSimpleCompareI(A, B);\r\n else\r\n raise EJclOperationNotSupportedError.Create;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJclAnsiStrAbstractContainer.ItemsEqual(const A, B: AnsiString): Boolean;\r\nbegin\r\n if Assigned(FEqualityCompare) then\r\n Result := FEqualityCompare(A, B)\r\n else\r\n if Assigned(FCompare) then\r\n Result := FCompare(A, B) = 0\r\n else\r\n begin\r\n case FEncoding of\r\n seISO, seUTF8:\r\n if FCaseSensitive then\r\n Result := AnsiStrSimpleEqualityCompare(A, B)\r\n else\r\n Result := AnsiStrSimpleEqualityCompareI(A, B);\r\n else\r\n raise EJclOperationNotSupportedError.Create;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJclAnsiStrAbstractContainer.SetCompare(Value: TAnsiStrCompare);\r\nbegin\r\n FCompare := Value;\r\nend;\r\n\r\nprocedure TJclAnsiStrAbstractContainer.SetEncoding(Value: TJclAnsiStrEncoding);\r\nbegin\r\n FEncoding := Value;\r\nend;\r\n\r\nprocedure TJclAnsiStrAbstractContainer.SetEqualityCompare(Value: TAnsiStrEqualityCompare);\r\nbegin\r\n FEqualityCompare := Value;\r\nend;\r\n\r\nprocedure TJclAnsiStrAbstractContainer.SetHashConvert(Value: TAnsiStrHashConvert);\r\nbegin\r\n FHashConvert := Value;\r\nend;\r\n\r\nprocedure TJclAnsiStrAbstractContainer.SetOnFreeString(\r\n Value: TFreeAnsiStrEvent);\r\nbegin\r\n FOnFreeString := Value;\r\nend;\r\n\r\n//=== { TJclWideStrContainer } ===============================================\r\n\r\nprocedure TJclWideStrAbstractContainer.AssignPropertiesTo(Dest: TJclAbstractContainerBase);\r\nvar\r\n ADest: TJclWideStrAbstractContainer;\r\nbegin\r\n inherited AssignPropertiesTo(Dest);\r\n if Dest is TJclWideStrAbstractContainer then\r\n begin\r\n ADest := TJclWideStrAbstractContainer(Dest);\r\n ADest.Encoding := Encoding;\r\n ADest.EqualityCompare := EqualityCompare;\r\n ADest.Compare := Compare;\r\n ADest.HashConvert := HashConvert;\r\n end;\r\nend;\r\n\r\nfunction TJclWideStrAbstractContainer.FreeString(var AString: WideString): WideString;\r\nbegin\r\n if Assigned(FOnFreeString) then\r\n Result := FOnFreeString(AString)\r\n else\r\n begin\r\n Result := AString;\r\n AString := '';\r\n end;\r\nend;\r\n\r\nfunction TJclWideStrAbstractContainer.GetCompare: TWideStrCompare;\r\nbegin\r\n Result := FCompare;\r\nend;\r\n\r\nfunction TJclWideStrAbstractContainer.GetEncoding: TJclWideStrEncoding;\r\nbegin\r\n Result := FEncoding;\r\nend;\r\n\r\nfunction TJclWideStrAbstractContainer.GetEqualityCompare: TWideStrEqualityCompare;\r\nbegin\r\n Result := FEqualityCompare;\r\nend;\r\n\r\nfunction TJclWideStrAbstractContainer.GetHashConvert: TWideStrHashConvert;\r\nbegin\r\n Result := FHashConvert;\r\nend;\r\n\r\nfunction TJclWideStrAbstractContainer.GetOnFreeString: TFreeWideStrEvent;\r\nbegin\r\n Result := FOnFreeString;\r\nend;\r\n\r\nfunction TJclWideStrAbstractContainer.Hash(const AString: WideString): Integer;\r\nbegin\r\n if Assigned(FHashConvert) then\r\n Result := FHashConvert(AString)\r\n else\r\n begin\r\n case FEncoding of\r\n seUTF16:\r\n if FCaseSensitive then\r\n Result := WideStrSimpleHashConvert(AString)\r\n else\r\n Result := WideStrSimpleHashConvertI(AString);\r\n else\r\n raise EJclOperationNotSupportedError.Create;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJclWideStrAbstractContainer.ItemsCompare(const A, B: WideString): Integer;\r\nbegin\r\n if Assigned(FCompare) then\r\n Result := FCompare(A, B)\r\n else\r\n begin\r\n case FEncoding of\r\n seUTF16:\r\n if FCaseSensitive then\r\n Result := WideStrSimpleCompare(A, B)\r\n else\r\n Result := WideStrSimpleCompareI(A, B);\r\n else\r\n raise EJclOperationNotSupportedError.Create;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJclWideStrAbstractContainer.ItemsEqual(const A, B: WideString): Boolean;\r\nbegin\r\n if Assigned(FEqualityCompare) then\r\n Result := FEqualityCompare(A, B)\r\n else\r\n if Assigned(FCompare) then\r\n Result := FCompare(A, B) = 0\r\n else\r\n begin\r\n case FEncoding of\r\n seUTF16:\r\n if FCaseSensitive then\r\n Result := WideStrSimpleEqualityCompare(A, B)\r\n else\r\n Result := WideStrSimpleEqualityCompareI(A, B);\r\n else\r\n raise EJclOperationNotSupportedError.Create;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJclWideStrAbstractContainer.SetCompare(Value: TWideStrCompare);\r\nbegin\r\n FCompare := Value;\r\nend;\r\n\r\nprocedure TJclWideStrAbstractContainer.SetEncoding(Value: TJclWideStrEncoding);\r\nbegin\r\n FEncoding := Value;\r\nend;\r\n\r\nprocedure TJclWideStrAbstractContainer.SetEqualityCompare(Value: TWideStrEqualityCompare);\r\nbegin\r\n FEqualityCompare := Value;\r\nend;\r\n\r\nprocedure TJclWideStrAbstractContainer.SetHashConvert(Value: TWideStrHashConvert);\r\nbegin\r\n FHashConvert := Value;\r\nend;\r\n\r\nprocedure TJclWideStrAbstractContainer.SetOnFreeString(\r\n Value: TFreeWideStrEvent);\r\nbegin\r\n FOnFreeString := Value;\r\nend;\r\n\r\n{$IFDEF SUPPORTS_UNICODE_STRING}\r\n//=== { TJclUnicodeStrContainer } ===============================================\r\n\r\nprocedure TJclUnicodeStrAbstractContainer.AssignPropertiesTo(Dest: TJclAbstractContainerBase);\r\nvar\r\n ADest: TJclUnicodeStrAbstractContainer;\r\nbegin\r\n inherited AssignPropertiesTo(Dest);\r\n if Dest is TJclUnicodeStrAbstractContainer then\r\n begin\r\n ADest := TJclUnicodeStrAbstractContainer(Dest);\r\n ADest.EqualityCompare := EqualityCompare;\r\n ADest.Compare := Compare;\r\n ADest.HashConvert := HashConvert;\r\n end;\r\nend;\r\n\r\nfunction TJclUnicodeStrAbstractContainer.FreeString(var AString: UnicodeString): UnicodeString;\r\nbegin\r\n if Assigned(FOnFreeString) then\r\n Result := FOnFreeString(AString)\r\n else\r\n begin\r\n Result := AString;\r\n AString := '';\r\n end;\r\nend;\r\n\r\nfunction TJclUnicodeStrAbstractContainer.GetCompare: TUnicodeStrCompare;\r\nbegin\r\n Result := FCompare;\r\nend;\r\n\r\nfunction TJclUnicodeStrAbstractContainer.GetEqualityCompare: TUnicodeStrEqualityCompare;\r\nbegin\r\n Result := FEqualityCompare;\r\nend;\r\n\r\nfunction TJclUnicodeStrAbstractContainer.GetHashConvert: TUnicodeStrHashConvert;\r\nbegin\r\n Result := FHashConvert;\r\nend;\r\n\r\nfunction TJclUnicodeStrAbstractContainer.GetOnFreeString: TFreeUnicodeStrEvent;\r\nbegin\r\n Result := FOnFreeString;\r\nend;\r\n\r\nfunction TJclUnicodeStrAbstractContainer.Hash(const AString: UnicodeString): Integer;\r\nbegin\r\n if Assigned(FHashConvert) then\r\n Result := FHashConvert(AString)\r\n else\r\n if FCaseSensitive then\r\n Result := UnicodeStrSimpleHashConvert(AString)\r\n else\r\n Result := UnicodeStrSimpleHashConvertI(AString);\r\nend;\r\n\r\nfunction TJclUnicodeStrAbstractContainer.ItemsCompare(const A, B: UnicodeString): Integer;\r\nbegin\r\n if Assigned(FCompare) then\r\n Result := FCompare(A, B)\r\n else\r\n if FCaseSensitive then\r\n Result := UnicodeStrSimpleCompare(A, B)\r\n else\r\n Result := UnicodeStrSimpleCompareI(A, B);\r\nend;\r\n\r\nfunction TJclUnicodeStrAbstractContainer.ItemsEqual(const A, B: UnicodeString): Boolean;\r\nbegin\r\n if Assigned(FEqualityCompare) then\r\n Result := FEqualityCompare(A, B)\r\n else\r\n if Assigned(FCompare) then\r\n Result := FCompare(A, B) = 0\r\n else\r\n if FCaseSensitive then\r\n Result := UnicodeStrSimpleEqualityCompare(A, B)\r\n else\r\n Result := UnicodeStrSimpleEqualityCompareI(A, B);\r\nend;\r\n\r\nprocedure TJclUnicodeStrAbstractContainer.SetCompare(Value: TUnicodeStrCompare);\r\nbegin\r\n FCompare := Value;\r\nend;\r\n\r\nprocedure TJclUnicodeStrAbstractContainer.SetEqualityCompare(Value: TUnicodeStrEqualityCompare);\r\nbegin\r\n FEqualityCompare := Value;\r\nend;\r\n\r\nprocedure TJclUnicodeStrAbstractContainer.SetHashConvert(Value: TUnicodeStrHashConvert);\r\nbegin\r\n FHashConvert := Value;\r\nend;\r\n\r\nprocedure TJclUnicodeStrAbstractContainer.SetOnFreeString(Value: TFreeUnicodeStrEvent);\r\nbegin\r\n FOnFreeString := Value;\r\nend;\r\n{$ENDIF SUPPORTS_UNICODE_STRING}\r\n\r\n//=== { TJclSingleAbstractContainer } ========================================\r\n\r\nprocedure TJclSingleAbstractContainer.AssignPropertiesTo(Dest: TJclAbstractContainerBase);\r\nvar\r\n ADest: TJclSingleAbstractContainer;\r\nbegin\r\n inherited AssignPropertiesTo(Dest);\r\n if Dest is TJclSingleAbstractContainer then\r\n begin\r\n ADest := TJclSingleAbstractContainer(Dest);\r\n ADest.Precision := Precision;\r\n ADest.EqualityCompare := EqualityCompare;\r\n ADest.Compare := Compare;\r\n ADest.HashConvert := HashConvert;\r\n end;\r\nend;\r\n\r\nfunction TJclSingleAbstractContainer.FreeSingle(var AValue: Single): Single;\r\nbegin\r\n if Assigned(FOnFreeSingle) then\r\n Result := FOnFreeSingle(AValue)\r\n else\r\n begin\r\n Result := AValue;\r\n AValue := 0.0;\r\n end;\r\nend;\r\n\r\nfunction TJclSingleAbstractContainer.GetCompare: TSingleCompare;\r\nbegin\r\n Result := FCompare;\r\nend;\r\n\r\nfunction TJclSingleAbstractContainer.GetEqualityCompare: TSingleEqualityCompare;\r\nbegin\r\n Result := FEqualityCompare;\r\nend;\r\n\r\nfunction TJclSingleAbstractContainer.GetHashConvert: TSingleHashConvert;\r\nbegin\r\n Result := FHashConvert;\r\nend;\r\n\r\nfunction TJclSingleAbstractContainer.GetOnFreeSingle: TFreeSingleEvent;\r\nbegin\r\n Result := FOnFreeSingle;\r\nend;\r\n\r\nfunction TJclSingleAbstractContainer.GetPrecision: Single;\r\nbegin\r\n Result := FPrecision;\r\nend;\r\n\r\nfunction TJclSingleAbstractContainer.Hash(const AValue: Single): Integer;\r\nbegin\r\n if Assigned(FHashConvert) then\r\n Result := FHashConvert(AValue)\r\n else\r\n Result := SingleSimpleHashConvert(AValue);\r\nend;\r\n\r\nfunction TJclSingleAbstractContainer.ItemsCompare(const A, B: Single): Integer;\r\nbegin\r\n if Assigned(FCompare) then\r\n Result := FCompare(A, B)\r\n else\r\n if Abs(A - B) <= FPrecision then\r\n Result := 0\r\n else\r\n if A > B then\r\n Result := 1\r\n else\r\n Result := -1;\r\nend;\r\n\r\nfunction TJclSingleAbstractContainer.ItemsEqual(const A, B: Single): Boolean;\r\nbegin\r\n if Assigned(FEqualityCompare) then\r\n Result := FEqualityCompare(A, B)\r\n else\r\n if Assigned(FCompare) then\r\n Result := FCompare(A, B) = 0\r\n else\r\n Result := Abs(A - B) <= FPrecision;\r\nend;\r\n\r\nprocedure TJclSingleAbstractContainer.SetCompare(Value: TSingleCompare);\r\nbegin\r\n FCompare := Value;\r\nend;\r\n\r\nprocedure TJclSingleAbstractContainer.SetEqualityCompare(Value: TSingleEqualityCompare);\r\nbegin\r\n FEqualityCompare := Value;\r\nend;\r\n\r\nprocedure TJclSingleAbstractContainer.SetHashConvert(Value: TSingleHashConvert);\r\nbegin\r\n FHashConvert := Value;\r\nend;\r\n\r\nprocedure TJclSingleAbstractContainer.SetOnFreeSingle(Value: TFreeSingleEvent);\r\nbegin\r\n FOnFreeSingle := Value;\r\nend;\r\n\r\nprocedure TJclSingleAbstractContainer.SetPrecision(const Value: Single);\r\nbegin\r\n FPrecision := Value;\r\nend;\r\n\r\n//=== { TJclDoubleAbstractContainer } ========================================\r\n\r\nprocedure TJclDoubleAbstractContainer.AssignPropertiesTo(Dest: TJclAbstractContainerBase);\r\nvar\r\n ADest: TJclDoubleAbstractContainer;\r\nbegin\r\n inherited AssignPropertiesTo(Dest);\r\n if Dest is TJclDoubleAbstractContainer then\r\n begin\r\n ADest := TJclDoubleAbstractContainer(Dest);\r\n ADest.Precision := Precision;\r\n ADest.Compare := Compare;\r\n ADest.EqualityCompare := EqualityCompare;\r\n ADest.HashConvert := HashConvert;\r\n end;\r\nend;\r\n\r\nfunction TJclDoubleAbstractContainer.FreeDouble(var AValue: Double): Double;\r\nbegin\r\n if Assigned(FOnFreeDouble) then\r\n Result := FOnFreeDouble(AValue)\r\n else\r\n begin\r\n Result := AValue;\r\n AValue := 0.0;\r\n end;\r\nend;\r\n\r\nfunction TJclDoubleAbstractContainer.GetCompare: TDoubleCompare;\r\nbegin\r\n Result := FCompare;\r\nend;\r\n\r\nfunction TJclDoubleAbstractContainer.GetEqualityCompare: TDoubleEqualityCompare;\r\nbegin\r\n Result := FEqualityCompare;\r\nend;\r\n\r\nfunction TJclDoubleAbstractContainer.GetHashConvert: TDoubleHashConvert;\r\nbegin\r\n Result := FHashConvert;\r\nend;\r\n\r\nfunction TJclDoubleAbstractContainer.GetOnFreeDouble: TFreeDoubleEvent;\r\nbegin\r\n Result := FOnFreeDouble;\r\nend;\r\n\r\nfunction TJclDoubleAbstractContainer.GetPrecision: Double;\r\nbegin\r\n Result := FPrecision;\r\nend;\r\n\r\nfunction TJclDoubleAbstractContainer.Hash(const AValue: Double): Integer;\r\nbegin\r\n if Assigned(FHashConvert) then\r\n Result := FHashConvert(AValue)\r\n else\r\n Result := DoubleSimpleHashConvert(AValue);\r\nend;\r\n\r\nfunction TJclDoubleAbstractContainer.ItemsCompare(const A, B: Double): Integer;\r\nbegin\r\n if Assigned(FCompare) then\r\n Result := FCompare(A, B)\r\n else\r\n if Abs(A - B) <= FPrecision then\r\n Result := 0\r\n else\r\n if A > B then\r\n Result := 1\r\n else\r\n Result := -1;\r\nend;\r\n\r\nfunction TJclDoubleAbstractContainer.ItemsEqual(const A, B: Double): Boolean;\r\nbegin\r\n if Assigned(FEqualityCompare) then\r\n Result := FEqualityCompare(A, B)\r\n else\r\n if Assigned(FCompare) then\r\n Result := FCompare(A, B) = 0\r\n else\r\n Result := Abs(A - B) <= FPrecision;\r\nend;\r\n\r\nprocedure TJclDoubleAbstractContainer.SetCompare(Value: TDoubleCompare);\r\nbegin\r\n FCompare := Value;\r\nend;\r\n\r\nprocedure TJclDoubleAbstractContainer.SetEqualityCompare(Value: TDoubleEqualityCompare);\r\nbegin\r\n FEqualityCompare := Value;\r\nend;\r\n\r\nprocedure TJclDoubleAbstractContainer.SetHashConvert(Value: TDoubleHashConvert);\r\nbegin\r\n FHashConvert := Value;\r\nend;\r\n\r\nprocedure TJclDoubleAbstractContainer.SetOnFreeDouble(Value: TFreeDoubleEvent);\r\nbegin\r\n FOnFreeDouble := Value;\r\nend;\r\n\r\nprocedure TJclDoubleAbstractContainer.SetPrecision(const Value: Double);\r\nbegin\r\n FPrecision := Value;\r\nend;\r\n\r\n//=== { TJclExtendedAbstractContainer } ======================================\r\n\r\nprocedure TJclExtendedAbstractContainer.AssignPropertiesTo(Dest: TJclAbstractContainerBase);\r\nvar\r\n ADest: TJclExtendedAbstractContainer;\r\nbegin\r\n inherited AssignPropertiesTo(Dest);\r\n if Dest is TJclExtendedAbstractContainer then\r\n begin\r\n ADest := TJclExtendedAbstractContainer(Dest);\r\n ADest.Precision := Precision;\r\n ADest.EqualityCompare := EqualityCompare;\r\n ADest.Compare := Compare;\r\n ADest.HashConvert := HashConvert;\r\n end;\r\nend;\r\n\r\nfunction TJclExtendedAbstractContainer.FreeExtended(var AValue: Extended): Extended;\r\nbegin\r\n if Assigned(FOnFreeExtended) then\r\n Result := FOnFreeExtended(AValue)\r\n else\r\n begin\r\n Result := AValue;\r\n AValue := 0.0;\r\n end;\r\nend;\r\n\r\nfunction TJclExtendedAbstractContainer.GetCompare: TExtendedCompare;\r\nbegin\r\n Result := FCompare;\r\nend;\r\n\r\nfunction TJclExtendedAbstractContainer.GetEqualityCompare: TExtendedEqualityCompare;\r\nbegin\r\n Result := FEqualityCompare;\r\nend;\r\n\r\nfunction TJclExtendedAbstractContainer.GetHashConvert: TExtendedHashConvert;\r\nbegin\r\n Result := FHashConvert;\r\nend;\r\n\r\nfunction TJclExtendedAbstractContainer.GetOnFreeExtended: TFreeExtendedEvent;\r\nbegin\r\n Result := FOnFreeExtended;\r\nend;\r\n\r\nfunction TJclExtendedAbstractContainer.GetPrecision: Extended;\r\nbegin\r\n Result := FPrecision;\r\nend;\r\n\r\nfunction TJclExtendedAbstractContainer.Hash(const AValue: Extended): Integer;\r\nbegin\r\n if Assigned(FHashConvert) then\r\n Result := FHashConvert(AValue)\r\n else\r\n Result := ExtendedSimpleHashConvert(AValue);\r\nend;\r\n\r\nfunction TJclExtendedAbstractContainer.ItemsCompare(const A, B: Extended): Integer;\r\nbegin\r\n if Assigned(FCompare) then\r\n Result := FCompare(A, B)\r\n else\r\n if Abs(A - B) <= FPrecision then\r\n Result := 0\r\n else\r\n if A > B then\r\n Result := 1\r\n else\r\n Result := -1;\r\nend;\r\n\r\nfunction TJclExtendedAbstractContainer.ItemsEqual(const A, B: Extended): Boolean;\r\nbegin\r\n if Assigned(FEqualityCompare) then\r\n Result := FEqualityCompare(A, B)\r\n else\r\n if Assigned(FCompare) then\r\n Result := FCompare(A, B) = 0\r\n else\r\n Result := Abs(A - B) <= FPrecision;\r\nend;\r\n\r\nprocedure TJclExtendedAbstractContainer.SetCompare(Value: TExtendedCompare);\r\nbegin\r\n FCompare := Value;\r\nend;\r\n\r\nprocedure TJclExtendedAbstractContainer.SetEqualityCompare(Value: TExtendedEqualityCompare);\r\nbegin\r\n FEqualityCompare := Value;\r\nend;\r\n\r\nprocedure TJclExtendedAbstractContainer.SetHashConvert(Value: TExtendedHashConvert);\r\nbegin\r\n FHashConvert := Value;\r\nend;\r\n\r\nprocedure TJclExtendedAbstractContainer.SetOnFreeExtended(\r\n Value: TFreeExtendedEvent);\r\nbegin\r\n FOnFreeExtended := Value;\r\nend;\r\n\r\nprocedure TJclExtendedAbstractContainer.SetPrecision(const Value: Extended);\r\nbegin\r\n FPrecision := Value;\r\nend;\r\n\r\n//=== { TJclIntegerAbstractContainer } =======================================\r\n\r\nprocedure TJclIntegerAbstractContainer.AssignPropertiesTo(Dest: TJclAbstractContainerBase);\r\nvar\r\n ADest: TJclIntegerAbstractContainer;\r\nbegin\r\n inherited AssignPropertiesTo(Dest);\r\n if Dest is TJclIntegerAbstractContainer then\r\n begin\r\n ADest := TJclIntegerAbstractContainer(Dest);\r\n ADest.EqualityCompare := EqualityCompare;\r\n ADest.Compare := Compare;\r\n ADest.HashConvert := HashConvert;\r\n end;\r\nend;\r\n\r\nfunction TJclIntegerAbstractContainer.FreeInteger(var AValue: Integer): Integer;\r\nbegin\r\n if Assigned(FOnFreeInteger) then\r\n Result := FOnFreeInteger(AValue)\r\n else\r\n begin\r\n Result := AValue;\r\n AValue := 0;\r\n end;\r\nend;\r\n\r\nfunction TJclIntegerAbstractContainer.GetCompare: TIntegerCompare;\r\nbegin\r\n Result := FCompare;\r\nend;\r\n\r\nfunction TJclIntegerAbstractContainer.GetEqualityCompare: TIntegerEqualityCompare;\r\nbegin\r\n Result := FEqualityCompare;\r\nend;\r\n\r\nfunction TJclIntegerAbstractContainer.GetHashConvert: TIntegerHashConvert;\r\nbegin\r\n Result := FHashConvert;\r\nend;\r\n\r\nfunction TJclIntegerAbstractContainer.GetOnFreeInteger: TFreeIntegerEvent;\r\nbegin\r\n Result := FOnFreeInteger;\r\nend;\r\n\r\nfunction TJclIntegerAbstractContainer.Hash(AValue: Integer): Integer;\r\nbegin\r\n if Assigned(FHashConvert) then\r\n Result := FHashConvert(AValue)\r\n else\r\n Result := IntegerSimpleHashConvert(AValue);\r\nend;\r\n\r\nfunction TJclIntegerAbstractContainer.ItemsCompare(A, B: Integer): Integer;\r\nbegin\r\n if Assigned(FCompare) then\r\n Result := FCompare(A, B)\r\n else\r\n Result := IntegerSimpleCompare(A, B);\r\nend;\r\n\r\nfunction TJclIntegerAbstractContainer.ItemsEqual(A, B: Integer): Boolean;\r\nbegin\r\n if Assigned(FEqualityCompare) then\r\n Result := FEqualityCompare(A, B)\r\n else\r\n if Assigned(FCompare) then\r\n Result := FCompare(A, B) = 0\r\n else\r\n Result := IntegerSimpleEqualityCompare(A, B);\r\nend;\r\n\r\nprocedure TJclIntegerAbstractContainer.SetCompare(Value: TIntegerCompare);\r\nbegin\r\n FCompare := Value;\r\nend;\r\n\r\nprocedure TJclIntegerAbstractContainer.SetEqualityCompare(Value: TIntegerEqualityCompare);\r\nbegin\r\n FEqualityCompare := Value;\r\nend;\r\n\r\nprocedure TJclIntegerAbstractContainer.SetHashConvert(Value: TIntegerHashConvert);\r\nbegin\r\n FHashConvert := Value;\r\nend;\r\n\r\nprocedure TJclIntegerAbstractContainer.SetOnFreeInteger(\r\n Value: TFreeIntegerEvent);\r\nbegin\r\n FOnFreeInteger := Value;\r\nend;\r\n\r\n//=== { TJclCardinalAbstractContainer } ======================================\r\n\r\nprocedure TJclCardinalAbstractContainer.AssignPropertiesTo(Dest: TJclAbstractContainerBase);\r\nvar\r\n ADest: TJclCardinalAbstractContainer;\r\nbegin\r\n inherited AssignPropertiesTo(Dest);\r\n if Dest is TJclCardinalAbstractContainer then\r\n begin\r\n ADest := TJclCardinalAbstractContainer(Dest);\r\n ADest.EqualityCompare := EqualityCompare;\r\n ADest.Compare := Compare;\r\n ADest.HashConvert := HashConvert;\r\n end;\r\nend;\r\n\r\nfunction TJclCardinalAbstractContainer.FreeCardinal(var AValue: Cardinal): Cardinal;\r\nbegin\r\n if Assigned(FOnFreeCardinal) then\r\n Result := FOnFreeCardinal(AValue)\r\n else\r\n begin\r\n Result := AValue;\r\n AValue := 0;\r\n end;\r\nend;\r\n\r\nfunction TJclCardinalAbstractContainer.GetCompare: TCardinalCompare;\r\nbegin\r\n Result := FCompare;\r\nend;\r\n\r\nfunction TJclCardinalAbstractContainer.GetEqualityCompare: TCardinalEqualityCompare;\r\nbegin\r\n Result := FEqualityCompare;\r\nend;\r\n\r\nfunction TJclCardinalAbstractContainer.GetHashConvert: TCardinalHashConvert;\r\nbegin\r\n Result := FHashConvert;\r\nend;\r\n\r\nfunction TJclCardinalAbstractContainer.GetOnFreeCardinal: TFreeCardinalEvent;\r\nbegin\r\n Result := FOnFreeCardinal;\r\nend;\r\n\r\nfunction TJclCardinalAbstractContainer.Hash(AValue: Cardinal): Integer;\r\nbegin\r\n if Assigned(FHashConvert) then\r\n Result := FHashConvert(AValue)\r\n else\r\n Result := CardinalSimpleHashConvert(AValue);\r\nend;\r\n\r\nfunction TJclCardinalAbstractContainer.ItemsCompare(A, B: Cardinal): Integer;\r\nbegin\r\n if Assigned(FCompare) then\r\n Result := FCompare(A, B)\r\n else\r\n Result := CardinalSimpleCompare(A, B);\r\nend;\r\n\r\nfunction TJclCardinalAbstractContainer.ItemsEqual(A, B: Cardinal): Boolean;\r\nbegin\r\n if Assigned(FEqualityCompare) then\r\n Result := FEqualityCompare(A, B)\r\n else\r\n if Assigned(FCompare) then\r\n Result := FCompare(A, B) = 0\r\n else\r\n Result := CardinalSimpleEqualityCompare(A, B);\r\nend;\r\n\r\nprocedure TJclCardinalAbstractContainer.SetCompare(Value: TCardinalCompare);\r\nbegin\r\n FCompare := Value;\r\nend;\r\n\r\nprocedure TJclCardinalAbstractContainer.SetEqualityCompare(Value: TCardinalEqualityCompare);\r\nbegin\r\n FEqualityCompare := Value;\r\nend;\r\n\r\nprocedure TJclCardinalAbstractContainer.SetHashConvert(Value: TCardinalHashConvert);\r\nbegin\r\n FHashConvert := Value;\r\nend;\r\n\r\nprocedure TJclCardinalAbstractContainer.SetOnFreeCardinal(\r\n Value: TFreeCardinalEvent);\r\nbegin\r\n FOnFreeCardinal := Value;\r\nend;\r\n\r\n//=== { TJclInt64AbstractContainer } =========================================\r\n\r\nprocedure TJclInt64AbstractContainer.AssignPropertiesTo(Dest: TJclAbstractContainerBase);\r\nvar\r\n ADest: TJclInt64AbstractContainer;\r\nbegin\r\n inherited AssignPropertiesTo(Dest);\r\n if Dest is TJclInt64AbstractContainer then\r\n begin\r\n ADest := TJclInt64AbstractContainer(Dest);\r\n ADest.EqualityCompare := EqualityCompare;\r\n ADest.Compare := Compare;\r\n ADest.HashConvert := HashConvert;\r\n end;\r\nend;\r\n\r\nfunction TJclInt64AbstractContainer.FreeInt64(var AValue: Int64): Int64;\r\nbegin\r\n if Assigned(FOnFreeInt64) then\r\n Result := FOnFreeInt64(AValue)\r\n else\r\n begin\r\n Result := AValue;\r\n AValue := 0;\r\n end;\r\nend;\r\n\r\nfunction TJclInt64AbstractContainer.GetCompare: TInt64Compare;\r\nbegin\r\n Result := FCompare;\r\nend;\r\n\r\nfunction TJclInt64AbstractContainer.GetEqualityCompare: TInt64EqualityCompare;\r\nbegin\r\n Result := FEqualityCompare;\r\nend;\r\n\r\nfunction TJclInt64AbstractContainer.GetHashConvert: TInt64HashConvert;\r\nbegin\r\n Result := FHashConvert;\r\nend;\r\n\r\nfunction TJclInt64AbstractContainer.GetOnFreeInt64: TFreeInt64Event;\r\nbegin\r\n Result := FOnFreeInt64;\r\nend;\r\n\r\nfunction TJclInt64AbstractContainer.Hash(const AValue: Int64): Integer;\r\nbegin\r\n if Assigned(FHashConvert) then\r\n Result := FHashConvert(AValue)\r\n else\r\n Result := Int64SimpleHashConvert(AValue);\r\nend;\r\n\r\nfunction TJclInt64AbstractContainer.ItemsCompare(const A, B: Int64): Integer;\r\nbegin\r\n if Assigned(FCompare) then\r\n Result := FCompare(A, B)\r\n else\r\n Result := Int64SimpleCompare(A, B);\r\nend;\r\n\r\nfunction TJclInt64AbstractContainer.ItemsEqual(const A, B: Int64): Boolean;\r\nbegin\r\n if Assigned(FEqualityCompare) then\r\n Result := FEqualityCompare(A, B)\r\n else\r\n if Assigned(FCompare) then\r\n Result := FCompare(A, B) = 0\r\n else\r\n Result := Int64SimpleEqualityCompare(A, B);\r\nend;\r\n\r\nprocedure TJclInt64AbstractContainer.SetCompare(Value: TInt64Compare);\r\nbegin\r\n FCompare := Value;\r\nend;\r\n\r\nprocedure TJclInt64AbstractContainer.SetEqualityCompare(Value: TInt64EqualityCompare);\r\nbegin\r\n FEqualityCompare := Value;\r\nend;\r\n\r\nprocedure TJclInt64AbstractContainer.SetHashConvert(Value: TInt64HashConvert);\r\nbegin\r\n FHashConvert := Value;\r\nend;\r\n\r\nprocedure TJclInt64AbstractContainer.SetOnFreeInt64(Value: TFreeInt64Event);\r\nbegin\r\n FOnFreeInt64 := Value;\r\nend;\r\n\r\n//=== { TJclPtrAbstractContainer } ===========================================\r\n\r\nprocedure TJclPtrAbstractContainer.AssignPropertiesTo(Dest: TJclAbstractContainerBase);\r\nvar\r\n ADest: TJclPtrAbstractContainer;\r\nbegin\r\n inherited AssignPropertiesTo(Dest);\r\n if Dest is TJclPtrAbstractContainer then\r\n begin\r\n ADest := TJclPtrAbstractContainer(Dest);\r\n ADest.EqualityCompare := EqualityCompare;\r\n ADest.Compare := Compare;\r\n ADest.HashConvert := HashConvert;\r\n end;\r\nend;\r\n\r\nfunction TJclPtrAbstractContainer.FreePointer(var APtr: Pointer): Pointer;\r\nbegin\r\n if Assigned(FOnFreePointer) then\r\n Result := FOnFreePointer(APtr)\r\n else\r\n begin\r\n Result := APtr;\r\n APtr := nil;\r\n end;\r\nend;\r\n\r\nfunction TJclPtrAbstractContainer.GetCompare: TPtrCompare;\r\nbegin\r\n Result := FCompare;\r\nend;\r\n\r\nfunction TJclPtrAbstractContainer.GetEqualityCompare: TPtrEqualityCompare;\r\nbegin\r\n Result := FEqualityCompare;\r\nend;\r\n\r\nfunction TJclPtrAbstractContainer.GetHashConvert: TPtrHashConvert;\r\nbegin\r\n Result := FHashConvert;\r\nend;\r\n\r\nfunction TJclPtrAbstractContainer.GetOnFreePointer: TFreePtrEvent;\r\nbegin\r\n Result := FOnFreePointer;\r\nend;\r\n\r\nfunction TJclPtrAbstractContainer.Hash(APtr: Pointer): Integer;\r\nbegin\r\n if Assigned(FHashConvert) then\r\n Result := FHashConvert(APtr)\r\n else\r\n Result := PtrSimpleHashConvert(APtr);\r\nend;\r\n\r\nfunction TJclPtrAbstractContainer.ItemsCompare(A, B: Pointer): Integer;\r\nbegin\r\n if Assigned(FCompare) then\r\n Result := FCompare(A, B)\r\n else\r\n Result := PtrSimpleCompare(A, B);\r\nend;\r\n\r\nfunction TJclPtrAbstractContainer.ItemsEqual(A, B: Pointer): Boolean;\r\nbegin\r\n if Assigned(FEqualityCompare) then\r\n Result := FEqualityCompare(A, B)\r\n else\r\n if Assigned(FCompare) then\r\n Result := FCompare(A, B) = 0\r\n else\r\n Result := PtrSimpleEqualityCompare(A, B);\r\nend;\r\nprocedure TJclPtrAbstractContainer.SetCompare(Value: TPtrCompare);\r\nbegin\r\n FCompare := Value;\r\nend;\r\n\r\nprocedure TJclPtrAbstractContainer.SetEqualityCompare(Value: TPtrEqualityCompare);\r\nbegin\r\n FEqualityCompare := Value;\r\nend;\r\n\r\nprocedure TJclPtrAbstractContainer.SetHashConvert(Value: TPtrHashConvert);\r\nbegin\r\n FHashConvert := Value;\r\nend;\r\n\r\nprocedure TJclPtrAbstractContainer.SetOnFreePointer(Value: TFreePtrEvent);\r\nbegin\r\n FOnFreePointer := Value;\r\nend;\r\n\r\n//=== { TJclAbstractContainer } ==============================================\r\n\r\nconstructor TJclAbstractContainer.Create(AOwnsObjects: Boolean);\r\nbegin\r\n inherited Create;\r\n FOwnsObjects := AOwnsObjects;\r\nend;\r\n\r\nprocedure TJclAbstractContainer.AssignPropertiesTo(Dest: TJclAbstractContainerBase);\r\nvar\r\n ADest: TJclAbstractContainer;\r\nbegin\r\n inherited AssignPropertiesTo(Dest);\r\n if Dest is TJclAbstractContainer then\r\n begin\r\n ADest := TJclAbstractContainer(Dest);\r\n ADest.EqualityCompare := EqualityCompare;\r\n ADest.Compare := Compare;\r\n ADest.HashConvert := HashConvert;\r\n end;\r\nend;\r\n\r\nfunction TJclAbstractContainer.FreeObject(var AObject: TObject): TObject;\r\nbegin\r\n if Assigned(FOnFreeObject) then\r\n Result := FOnFreeObject(AObject)\r\n else\r\n if FOwnsObjects then\r\n begin\r\n Result := nil;\r\n FreeAndNil(AObject);\r\n end\r\n else\r\n begin\r\n Result := AObject;\r\n AObject := nil;\r\n end;\r\nend;\r\n\r\nfunction TJclAbstractContainer.GetCompare: TCompare;\r\nbegin\r\n Result := FCompare;\r\nend;\r\n\r\nfunction TJclAbstractContainer.GetEqualityCompare: TEqualityCompare;\r\nbegin\r\n Result := FEqualityCompare;\r\nend;\r\n\r\nfunction TJclAbstractContainer.GetHashConvert: THashConvert;\r\nbegin\r\n Result := FHashConvert;\r\nend;\r\n\r\nfunction TJclAbstractContainer.GetOnFreeObject: TFreeObjectEvent;\r\nbegin\r\n Result := FOnFreeObject;\r\nend;\r\n\r\nfunction TJclAbstractContainer.GetOwnsObjects: Boolean;\r\nbegin\r\n Result := FOwnsObjects;\r\nend;\r\n\r\nfunction TJclAbstractContainer.Hash(AObject: TObject): Integer;\r\nbegin\r\n if Assigned(FHashConvert) then\r\n Result := FHashConvert(AObject)\r\n else\r\n Result := SimpleHashConvert(AObject);\r\nend;\r\n\r\nfunction TJclAbstractContainer.ItemsCompare(A, B: TObject): Integer;\r\nbegin\r\n if Assigned(FCompare) then\r\n Result := FCompare(A, B)\r\n else\r\n Result := SimpleCompare(A, B);\r\nend;\r\n\r\nfunction TJclAbstractContainer.ItemsEqual(A, B: TObject): Boolean;\r\nbegin\r\n if Assigned(FEqualityCompare) then\r\n Result := FEqualityCompare(A, B)\r\n else\r\n if Assigned(FCompare) then\r\n Result := FCompare(A, B) = 0\r\n else\r\n Result := SimpleEqualityCompare(A, B);\r\nend;\r\n\r\nprocedure TJclAbstractContainer.SetCompare(Value: TCompare);\r\nbegin\r\n FCompare := Value;\r\nend;\r\n\r\nprocedure TJclAbstractContainer.SetEqualityCompare(Value: TEqualityCompare);\r\nbegin\r\n FEqualityCompare := Value;\r\nend;\r\n\r\nprocedure TJclAbstractContainer.SetHashConvert(Value: THashConvert);\r\nbegin\r\n FHashConvert := Value;\r\nend;\r\n\r\nprocedure TJclAbstractContainer.SetOnFreeObject(Value: TFreeObjectEvent);\r\nbegin\r\n FOnFreeObject := Value;\r\nend;\r\n\r\n{$IFDEF SUPPORTS_GENERICS}\r\n//DOM-IGNORE-BEGIN\r\n\r\n//=== { TJclAbstractContainer } ===========================================\r\n\r\nconstructor TJclAbstractContainer.Create(AOwnsItems: Boolean);\r\nbegin\r\n inherited Create;\r\n FOwnsItems := AOwnsItems;\r\nend;\r\n\r\nprocedure TJclAbstractContainer.AssignPropertiesTo(Dest: TJclAbstractContainerBase);\r\nvar\r\n ADest: TJclAbstractContainer;\r\nbegin\r\n inherited AssignPropertiesTo(Dest);\r\n if Dest is TJclAbstractContainer then\r\n begin\r\n ADest := TJclAbstractContainer(Dest);\r\n ADest.EqualityCompare := EqualityCompare;\r\n ADest.Compare := Compare;\r\n ADest.HashConvert := HashConvert;\r\n end;\r\nend;\r\n\r\nfunction TJclAbstractContainer.FreeItem(var AItem: T): T;\r\nbegin\r\n if Assigned(FOnFreeItem) then\r\n Result := FOnFreeItem(AItem)\r\n else\r\n if FOwnsItems then\r\n begin\r\n Result := Default(T);\r\n FreeAndNil(AItem);\r\n end\r\n else\r\n begin\r\n Result := AItem;\r\n AItem := Default(T);\r\n end;\r\nend;\r\n\r\nfunction TJclAbstractContainer.GetCompare: TCompare;\r\nbegin\r\n Result := FCompare;\r\nend;\r\n\r\nfunction TJclAbstractContainer.GetEqualityCompare: TEqualityCompare;\r\nbegin\r\n Result := FEqualityCompare;\r\nend;\r\n\r\nfunction TJclAbstractContainer.GetHashConvert: THashConvert;\r\nbegin\r\n Result := FHashConvert;\r\nend;\r\n\r\nfunction TJclAbstractContainer.GetOnFreeItem: TFreeItemEvent;\r\nbegin\r\n Result := FOnFreeItem;\r\nend;\r\n\r\nfunction TJclAbstractContainer.GetOwnsItems: Boolean;\r\nbegin\r\n Result := FOwnsItems;\r\nend;\r\n\r\nfunction TJclAbstractContainer.Hash(const AItem: T): Integer;\r\nbegin\r\n if Assigned(FHashConvert) then\r\n Result := FHashConvert(AItem)\r\n else\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nfunction TJclAbstractContainer.ItemsCompare(const A, B: T): Integer;\r\nbegin\r\n if Assigned(FCompare) then\r\n Result := FCompare(A, B)\r\n else\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nfunction TJclAbstractContainer.ItemsEqual(const A, B: T): Boolean;\r\nbegin\r\n if Assigned(FEqualityCompare) then\r\n Result := FEqualityCompare(A, B)\r\n else\r\n if Assigned(FCompare) then\r\n Result := FCompare(A, B) = 0\r\n else\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nprocedure TJclAbstractContainer.SetCompare(Value: TCompare);\r\nbegin\r\n FCompare := Value;\r\nend;\r\n\r\nprocedure TJclAbstractContainer.SetEqualityCompare(Value: TEqualityCompare);\r\nbegin\r\n FEqualityCompare := Value;\r\nend;\r\n\r\nprocedure TJclAbstractContainer.SetHashConvert(Value: THashConvert);\r\nbegin\r\n FHashConvert := Value;\r\nend;\r\n\r\nprocedure TJclAbstractContainer.SetOnFreeItem(Value: TFreeItemEvent);\r\nbegin\r\n FOnFreeItem := Value;\r\nend;\r\n\r\n//DOM-IGNORE-END\r\n{$ENDIF SUPPORTS_GENERICS}\r\n\r\n//=== { TJclAnsiStrAbstractCollection } ======================================\r\n\r\n// TODO: common implementation, need a function to search for a string starting from\r\n// a predefined index\r\nprocedure TJclAnsiStrAbstractCollection.AppendDelimited(const AString, Separator: AnsiString);\r\nvar\r\n Item: AnsiString;\r\n SepLen: Integer;\r\n PString, PSep, PPos: PAnsiChar;\r\nbegin\r\n PString := PAnsiChar(AString);\r\n PSep := PAnsiChar(Separator);\r\n PPos := StrPos(PString, PSep);\r\n if PPos <> nil then\r\n begin\r\n SepLen := StrLen(PSep);\r\n repeat\r\n //SetLength(Item, PPos - PString + 1);\r\n SetLength(Item, PPos - PString);\r\n Move(PString^, Item[1], (PPos - PString) * SizeOf(AnsiChar));\r\n //Item[PPos - PString + 1] := #0;\r\n Add(Item);\r\n PString := PPos + SepLen;\r\n PPos := StrPos(PString, PSep);\r\n until PPos = nil;\r\n if StrLen(PString) > 0 then //ex. hello#world\r\n Add(PString);\r\n end\r\n else //There isnt a Separator in AString\r\n Add(AString);\r\nend;\r\n\r\nprocedure TJclAnsiStrAbstractCollection.AppendFromStrings(Strings: TJclAnsiStrings);\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := 0 to Strings.Count - 1 do\r\n Add(Strings[I]);\r\nend;\r\n\r\nprocedure TJclAnsiStrAbstractCollection.AppendToStrings(Strings: TJclAnsiStrings);\r\nvar\r\n It: IJclAnsiStrIterator;\r\nbegin\r\n It := First;\r\n Strings.BeginUpdate;\r\n try\r\n while It.HasNext do\r\n Strings.Add(It.Next);\r\n finally\r\n Strings.EndUpdate;\r\n end;\r\nend;\r\n\r\nfunction TJclAnsiStrAbstractCollection.GetAsDelimited(const Separator: AnsiString): AnsiString;\r\nvar\r\n It: IJclAnsiStrIterator;\r\nbegin\r\n It := First;\r\n Result := '';\r\n if It.HasNext then\r\n Result := It.Next;\r\n while It.HasNext do\r\n Result := Result + Separator + It.Next;\r\nend;\r\n\r\nfunction TJclAnsiStrAbstractCollection.GetAsStrings: TJclAnsiStrings;\r\nbegin\r\n Result := TJclAnsiStringList.Create;\r\n try\r\n AppendToStrings(Result);\r\n except\r\n Result.Free;\r\n raise;\r\n end;\r\nend;\r\n\r\nprocedure TJclAnsiStrAbstractCollection.LoadDelimited(const AString, Separator: AnsiString);\r\nbegin\r\n Clear;\r\n AppendDelimited(AString, Separator);\r\nend;\r\n\r\nprocedure TJclAnsiStrAbstractCollection.LoadFromStrings(Strings: TJclAnsiStrings);\r\nbegin\r\n Clear;\r\n AppendFromStrings(Strings);\r\nend;\r\n\r\nprocedure TJclAnsiStrAbstractCollection.SaveToStrings(Strings: TJclAnsiStrings);\r\nbegin\r\n Strings.Clear;\r\n AppendToStrings(Strings);\r\nend;\r\n\r\n//=== { TJclWideStrAbstractCollection } ======================================\r\n\r\n// TODO: common implementation, need a function to search for a string starting from\r\n// a predefined index\r\nprocedure TJclWideStrAbstractCollection.AppendDelimited(const AString, Separator: WideString);\r\nvar\r\n Item: WideString;\r\n SepLen: Integer;\r\n PString, PSep, PPos: PWideChar;\r\nbegin\r\n PString := PWideChar(AString);\r\n PSep := PWideChar(Separator);\r\n PPos := StrPosW(PString, PSep);\r\n if PPos <> nil then\r\n begin\r\n SepLen := StrLenW(PSep);\r\n repeat\r\n //SetLength(Item, PPos - PString + 1);\r\n SetLength(Item, PPos - PString);\r\n Move(PString^, Item[1], (PPos - PString) * SizeOf(WideChar));\r\n //Item[PPos - PString + 1] := #0;\r\n Add(Item);\r\n PString := PPos + SepLen;\r\n PPos := StrPosW(PString, PSep);\r\n until PPos = nil;\r\n if StrLenW(PString) > 0 then //ex. hello#world\r\n Add(PString);\r\n end\r\n else //There isnt a Separator in AString\r\n Add(AString);\r\nend;\r\n\r\nprocedure TJclWideStrAbstractCollection.AppendFromStrings(Strings: TJclWideStrings);\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := 0 to Strings.Count - 1 do\r\n Add(Strings[I]);\r\nend;\r\n\r\nprocedure TJclWideStrAbstractCollection.AppendToStrings(Strings: TJclWideStrings);\r\nvar\r\n It: IJclWideStrIterator;\r\nbegin\r\n It := First;\r\n Strings.BeginUpdate;\r\n try\r\n while It.HasNext do\r\n Strings.Add(It.Next);\r\n finally\r\n Strings.EndUpdate;\r\n end;\r\nend;\r\n\r\nfunction TJclWideStrAbstractCollection.GetAsDelimited(const Separator: WideString): WideString;\r\nvar\r\n It: IJclWideStrIterator;\r\nbegin\r\n It := First;\r\n Result := '';\r\n if It.HasNext then\r\n Result := It.Next;\r\n while It.HasNext do\r\n Result := Result + Separator + It.Next;\r\nend;\r\n\r\nfunction TJclWideStrAbstractCollection.GetAsStrings: TJclWideStrings;\r\nbegin\r\n Result := TJclWideStringList.Create;\r\n try\r\n AppendToStrings(Result);\r\n except\r\n Result.Free;\r\n raise;\r\n end;\r\nend;\r\n\r\nprocedure TJclWideStrAbstractCollection.LoadDelimited(const AString, Separator: WideString);\r\nbegin\r\n Clear;\r\n AppendDelimited(AString, Separator);\r\nend;\r\n\r\nprocedure TJclWideStrAbstractCollection.LoadFromStrings(Strings: TJclWideStrings);\r\nbegin\r\n Clear;\r\n AppendFromStrings(Strings);\r\nend;\r\n\r\nprocedure TJclWideStrAbstractCollection.SaveToStrings(Strings: TJclWideStrings);\r\nbegin\r\n Strings.Clear;\r\n AppendToStrings(Strings);\r\nend;\r\n\r\n{$IFDEF SUPPORTS_UNICODE_STRING}\r\n//=== { TJclUnicodeStrAbstractCollection } ===================================\r\n\r\n// TODO: common implementation, need a function to search for a string starting from\r\n// a predefined index\r\nprocedure TJclUnicodeStrAbstractCollection.AppendDelimited(const AString, Separator: UnicodeString);\r\nvar\r\n Item: UnicodeString;\r\n SepLen: Integer;\r\n PString, PSep, PPos: PWideChar;\r\nbegin\r\n PString := PWideChar(AString);\r\n PSep := PWideChar(Separator);\r\n PPos := StrPos(PString, PSep);\r\n if PPos <> nil then\r\n begin\r\n SepLen := StrLen(PSep);\r\n repeat\r\n //SetLength(Item, PPos - PString + 1);\r\n SetLength(Item, PPos - PString);\r\n Move(PString^, Item[1], (PPos - PString) * SizeOf(WideChar));\r\n //Item[PPos - PString + 1] := #0;\r\n Add(Item);\r\n PString := PPos + SepLen;\r\n PPos := StrPos(PString, PSep);\r\n until PPos = nil;\r\n if StrLen(PString) > 0 then //ex. hello#world\r\n Add(PString);\r\n end\r\n else //There isnt a Separator in AString\r\n Add(AString);\r\nend;\r\n\r\nprocedure TJclUnicodeStrAbstractCollection.AppendFromStrings(Strings: TJclUnicodeStrings);\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := 0 to Strings.Count - 1 do\r\n Add(Strings[I]);\r\nend;\r\n\r\nprocedure TJclUnicodeStrAbstractCollection.AppendToStrings(Strings: TJclUnicodeStrings);\r\nvar\r\n It: IJclUnicodeStrIterator;\r\nbegin\r\n It := First;\r\n Strings.BeginUpdate;\r\n try\r\n while It.HasNext do\r\n Strings.Add(It.Next);\r\n finally\r\n Strings.EndUpdate;\r\n end;\r\nend;\r\n\r\nfunction TJclUnicodeStrAbstractCollection.GetAsDelimited(const Separator: UnicodeString): UnicodeString;\r\nvar\r\n It: IJclUnicodeStrIterator;\r\nbegin\r\n It := First;\r\n Result := '';\r\n if It.HasNext then\r\n Result := It.Next;\r\n while It.HasNext do\r\n Result := Result + Separator + It.Next;\r\nend;\r\n\r\nfunction TJclUnicodeStrAbstractCollection.GetAsStrings: TJclUnicodeStrings;\r\nbegin\r\n Result := TJclUnicodeStringList.Create;\r\n try\r\n AppendToStrings(Result);\r\n except\r\n Result.Free;\r\n raise;\r\n end;\r\nend;\r\n\r\nprocedure TJclUnicodeStrAbstractCollection.LoadDelimited(const AString, Separator: UnicodeString);\r\nbegin\r\n Clear;\r\n AppendDelimited(AString, Separator);\r\nend;\r\n\r\nprocedure TJclUnicodeStrAbstractCollection.LoadFromStrings(Strings: TJclUnicodeStrings);\r\nbegin\r\n Clear;\r\n AppendFromStrings(Strings);\r\nend;\r\n\r\nprocedure TJclUnicodeStrAbstractCollection.SaveToStrings(Strings: TJclUnicodeStrings);\r\nbegin\r\n Strings.Clear;\r\n AppendToStrings(Strings);\r\nend;\r\n{$ENDIF SUPPORTS_UNICODE_STRING}\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n\r\n" }, { "path": "External/Jedi/Jcl/source/common/JclAlgorithms.pas", "content": "{**************************************************************************************************}\r\n{ WARNING: JEDI preprocessor generated unit. Do not edit. }\r\n{**************************************************************************************************}\r\n\r\n{**************************************************************************************************}\r\n{ }\r\n{ Project JEDI Code Library (JCL) }\r\n{ }\r\n{ The contents of this file are subject to the Mozilla Public License Version 1.1 (the \"License\"); }\r\n{ you may not use this file except in compliance with the License. You may obtain a copy of the }\r\n{ License at http://www.mozilla.org/MPL/ }\r\n{ }\r\n{ Software distributed under the License is distributed on an \"AS IS\" basis, WITHOUT WARRANTY OF }\r\n{ ANY KIND, either express or implied. See the License for the specific language governing rights }\r\n{ and limitations under the License. }\r\n{ }\r\n{ The Original Code is Algorithms.pas. }\r\n{ }\r\n{ The Initial Developer of the Original Code is Jean-Philippe BEMPEL aka RDM. Portions created by }\r\n{ Jean-Philippe BEMPEL are Copyright (C) Jean-Philippe BEMPEL (rdm_30 att yahoo dott com) }\r\n{ All rights reserved. }\r\n{ }\r\n{ Contributors: }\r\n{ Florent Ouchet (outchy) }\r\n{ }\r\n{**************************************************************************************************}\r\n{ }\r\n{ The Delphi Container Library }\r\n{ }\r\n{**************************************************************************************************}\r\n{ }\r\n{ Last modified: $Date:: 2012-08-14 23:30:14 +0200 (mar. 14 août 2012) $ }\r\n{ Revision: $Rev:: 3830 $ }\r\n{ Author: $Author:: jfudickar $ }\r\n{ }\r\n{**************************************************************************************************}\r\n\r\nunit JclAlgorithms;\r\n\r\n{$I jcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n JclBase, JclContainerIntf;\r\n\r\n// Compare functions\r\nfunction IntfSimpleCompare(const Obj1, Obj2: IInterface): Integer;\r\nfunction AnsiStrSimpleCompare(const Obj1, Obj2: AnsiString): Integer;\r\nfunction WideStrSimpleCompare(const Obj1, Obj2: WideString): Integer;\r\n{$IFDEF SUPPORTS_UNICODE_STRING}\r\nfunction UnicodeStrSimpleCompare(const Obj1, Obj2: UnicodeString): Integer;\r\n{$ENDIF SUPPORTS_UNICODE_STRING}\r\nfunction StrSimpleCompare(const Obj1, Obj2: string): Integer;\r\nfunction SingleSimpleCompare(const Obj1, Obj2: Single): Integer;\r\nfunction DoubleSimpleCompare(const Obj1, Obj2: Double): Integer;\r\nfunction ExtendedSimpleCompare(const Obj1, Obj2: Extended): Integer;\r\nfunction FloatSimpleCompare(const Obj1, Obj2: Float): Integer;\r\nfunction IntegerSimpleCompare(Obj1, Obj2: Integer): Integer;\r\nfunction CardinalSimpleCompare(Obj1, Obj2: Cardinal): Integer;\r\nfunction Int64SimpleCompare(const Obj1, Obj2: Int64): Integer;\r\nfunction PtrSimpleCompare(Obj1, Obj2: Pointer): Integer;\r\nfunction SimpleCompare(Obj1, Obj2: TObject): Integer;\r\n\r\nfunction IntegerCompare(Obj1, Obj2: TObject): Integer;\r\n\r\nfunction AnsiStrSimpleCompareI(const Obj1, Obj2: AnsiString): Integer;\r\nfunction WideStrSimpleCompareI(const Obj1, Obj2: WideString): Integer;\r\n{$IFDEF SUPPORTS_UNICODE_STRING}\r\nfunction UnicodeStrSimpleCompareI(const Obj1, Obj2: UnicodeString): Integer;\r\n{$ENDIF SUPPORTS_UNICODE_STRING}\r\nfunction StrSimpleCompareI(const Obj1, Obj2: string): Integer;\r\n\r\n// Compare functions for equality\r\nfunction IntfSimpleEqualityCompare(const Obj1, Obj2: IInterface): Boolean;\r\nfunction AnsiStrSimpleEqualityCompare(const Obj1, Obj2: AnsiString): Boolean;\r\nfunction WideStrSimpleEqualityCompare(const Obj1, Obj2: WideString): Boolean;\r\n{$IFDEF SUPPORTS_UNICODE_STRING}\r\nfunction UnicodeStrSimpleEqualityCompare(const Obj1, Obj2: UnicodeString): Boolean;\r\n{$ENDIF SUPPORTS_UNICODE_STRING}\r\nfunction StrSimpleEqualityCompare(const Obj1, Obj2: string): Boolean;\r\nfunction SingleSimpleEqualityCompare(const Obj1, Obj2: Single): Boolean;\r\nfunction DoubleSimpleEqualityCompare(const Obj1, Obj2: Double): Boolean;\r\nfunction ExtendedSimpleEqualityCompare(const Obj1, Obj2: Extended): Boolean;\r\nfunction FloatSimpleEqualityCompare(const Obj1, Obj2: Float): Boolean;\r\nfunction IntegerSimpleEqualityCompare(Obj1, Obj2: Integer): Boolean;\r\nfunction CardinalSimpleEqualityCompare(Obj1, Obj2: Cardinal): Boolean;\r\nfunction Int64SimpleEqualityCompare(const Obj1, Obj2: Int64): Boolean;\r\nfunction PtrSimpleEqualityCompare(Obj1, Obj2: Pointer): Boolean;\r\nfunction SimpleEqualityCompare(Obj1, Obj2: TObject): Boolean;\r\n\r\nfunction AnsiStrSimpleEqualityCompareI(const Obj1, Obj2: AnsiString): Boolean;\r\nfunction WideStrSimpleEqualityCompareI(const Obj1, Obj2: WideString): Boolean;\r\n{$IFDEF SUPPORTS_UNICODE_STRING}\r\nfunction UnicodeStrSimpleEqualityCompareI(const Obj1, Obj2: UnicodeString): Boolean;\r\n{$ENDIF SUPPORTS_UNICODE_STRING}\r\nfunction StrSimpleEqualityCompareI(const Obj1, Obj2: string): Boolean;\r\n\r\n// Hash conversion functions\r\nfunction IntfSimpleHashConvert(const AInterface: IInterface): Integer;\r\nfunction AnsiStrSimpleHashConvert(const AString: AnsiString): Integer;\r\nfunction WideStrSimpleHashConvert(const AString: WideString): Integer;\r\n{$IFDEF SUPPORTS_UNICODE_STRING}\r\nfunction UnicodeStrSimpleHashConvert(const AString: UnicodeString): Integer;\r\n{$ENDIF SUPPORTS_UNICODE_STRING}\r\nfunction StrSimpleHashConvert(const AString: string): Integer;\r\nfunction SingleSimpleHashConvert(const AValue: Single): Integer;\r\nfunction DoubleSimpleHashConvert(const AValue: Double): Integer;\r\nfunction ExtendedSimpleHashConvert(const AValue: Extended): Integer;\r\nfunction FloatSimpleHashConvert(const AValue: Float): Integer;\r\nfunction IntegerSimpleHashConvert(AValue: Integer): Integer;\r\nfunction CardinalSimpleHashConvert(AValue: Cardinal): Integer;\r\nfunction Int64SimpleHashConvert(const AValue: Int64): Integer;\r\nfunction PtrSimpleHashConvert(APtr: Pointer): Integer;\r\nfunction SimpleHashConvert(AObject: TObject): Integer;\r\n\r\nfunction AnsiStrSimpleHashConvertI(const AString: AnsiString): Integer;\r\nfunction AnsiStrSimpleHashConvertU(const AString: AnsiString): Integer;\r\nfunction AnsiStrSimpleHashConvertUI(const AString: AnsiString): Integer;\r\nfunction WideStrSimpleHashConvertI(const AString: WideString): Integer;\r\n{$IFDEF SUPPORTS_UNICODE_STRING}\r\nfunction UnicodeStrSimpleHashConvertI(const AString: UnicodeString): Integer;\r\n{$ENDIF SUPPORTS_UNICODE_STRING}\r\nfunction StrSimpleHashConvertI(const AString: string): Integer;\r\n\r\ntype\r\n // Hash Function\r\n // Result must be in 0..Range-1\r\n TJclHashToRangeFunction = function(Key, Range: Integer): Integer;\r\n\r\nfunction JclSimpleHashToRange(Key, Range: Integer): Integer;\r\n\r\n// move array algorithms\r\nprocedure FinalizeArrayBeforeMove(var List: TDynIInterfaceArray; FromIndex, ToIndex, Count: SizeInt); overload;\r\n {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\nprocedure InitializeArray(var List: TDynIInterfaceArray; FromIndex, Count: SizeInt); overload;\r\n {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\nprocedure InitializeArrayAfterMove(var List: TDynIInterfaceArray; FromIndex, ToIndex, Count: SizeInt); overload;\r\n {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\n\r\nprocedure MoveArray(var List: TDynIInterfaceArray; FromIndex, ToIndex, Count: SizeInt); overload;\r\nprocedure FinalizeArrayBeforeMove(var List: TDynAnsiStringArray; FromIndex, ToIndex, Count: SizeInt); overload;\r\n {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\nprocedure InitializeArray(var List: TDynAnsiStringArray; FromIndex, Count: SizeInt); overload;\r\n {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\nprocedure InitializeArrayAfterMove(var List: TDynAnsiStringArray; FromIndex, ToIndex, Count: SizeInt); overload;\r\n {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\n\r\nprocedure MoveArray(var List: TDynAnsiStringArray; FromIndex, ToIndex, Count: SizeInt); overload;\r\nprocedure FinalizeArrayBeforeMove(var List: TDynWideStringArray; FromIndex, ToIndex, Count: SizeInt); overload;\r\n {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\nprocedure InitializeArray(var List: TDynWideStringArray; FromIndex, Count: SizeInt); overload;\r\n {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\nprocedure InitializeArrayAfterMove(var List: TDynWideStringArray; FromIndex, ToIndex, Count: SizeInt); overload;\r\n {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\n\r\nprocedure MoveArray(var List: TDynWideStringArray; FromIndex, ToIndex, Count: SizeInt); overload;\r\n{$IFDEF SUPPORTS_UNICODE_STRING}\r\n\r\nprocedure FinalizeArrayBeforeMove(var List: TDynUnicodeStringArray; FromIndex, ToIndex, Count: SizeInt); overload;\r\n {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\nprocedure InitializeArray(var List: TDynUnicodeStringArray; FromIndex, Count: SizeInt); overload;\r\n {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\nprocedure InitializeArrayAfterMove(var List: TDynUnicodeStringArray; FromIndex, ToIndex, Count: SizeInt); overload;\r\n {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\n\r\nprocedure MoveArray(var List: TDynUnicodeStringArray; FromIndex, ToIndex, Count: SizeInt); overload;\r\n{$ENDIF SUPPORTS_UNICODE_STRING}\r\nprocedure InitializeArrayAfterMove(var List: TDynSingleArray; FromIndex, ToIndex, Count: SizeInt); overload;\r\n {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\nprocedure MoveArray(var List: TDynSingleArray; FromIndex, ToIndex, Count: SizeInt); overload;\r\nprocedure InitializeArrayAfterMove(var List: TDynDoubleArray; FromIndex, ToIndex, Count: SizeInt); overload;\r\n {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\nprocedure MoveArray(var List: TDynDoubleArray; FromIndex, ToIndex, Count: SizeInt); overload;\r\nprocedure InitializeArrayAfterMove(var List: TDynExtendedArray; FromIndex, ToIndex, Count: SizeInt); overload;\r\n {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\nprocedure MoveArray(var List: TDynExtendedArray; FromIndex, ToIndex, Count: SizeInt); overload;\r\nprocedure InitializeArrayAfterMove(var List: TDynIntegerArray; FromIndex, ToIndex, Count: SizeInt); overload;\r\n {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\nprocedure MoveArray(var List: TDynIntegerArray; FromIndex, ToIndex, Count: SizeInt); overload;\r\nprocedure InitializeArrayAfterMove(var List: TDynCardinalArray; FromIndex, ToIndex, Count: SizeInt); overload;\r\n {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\nprocedure MoveArray(var List: TDynCardinalArray; FromIndex, ToIndex, Count: SizeInt); overload;\r\nprocedure InitializeArrayAfterMove(var List: TDynInt64Array; FromIndex, ToIndex, Count: SizeInt); overload;\r\n {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\nprocedure MoveArray(var List: TDynInt64Array; FromIndex, ToIndex, Count: SizeInt); overload;\r\nprocedure InitializeArrayAfterMove(var List: TDynPointerArray; FromIndex, ToIndex, Count: SizeInt); overload;\r\n {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\nprocedure MoveArray(var List: TDynPointerArray; FromIndex, ToIndex, Count: SizeInt); overload;\r\nprocedure InitializeArrayAfterMove(var List: TDynObjectArray; FromIndex, ToIndex, Count: SizeInt); overload;\r\n {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\nprocedure MoveArray(var List: TDynObjectArray; FromIndex, ToIndex, Count: SizeInt); overload;\r\n\r\n{$IFDEF GENERIC}\r\nprocedure MoveArray(var List: TDynSizeIntArray; FromIndex, ToIndex, Count: SizeInt); overload;\r\n{$ELSE ~GENERIC}\r\n{$IFDEF REFCOUNTED}\r\nprocedure FinalizeArrayBeforeMove(var List: TDynSizeIntArray; FromIndex, ToIndex, Count: SizeInt); overload;\r\n {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\nprocedure InitializeArray(var List: TDynSizeIntArray; FromIndex, Count: SizeInt); overload;\r\n {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\nprocedure InitializeArrayAfterMove(var List: TDynSizeIntArray; FromIndex, ToIndex, Count: SizeInt); overload;\r\n {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\n{$ELSE ~REFCOUNTED}\r\n{$IFDEF ZEROINIT}\r\nprocedure InitializeArrayAfterMove(var List: TDynSizeIntArray; FromIndex, ToIndex, Count: SizeInt); overload;\r\n {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\n{$ENDIF ZEROINIT}\r\n{$ENDIF ~REFCOUNTED}\r\nprocedure MoveArray(var List: TDynSizeIntArray; FromIndex, ToIndex, Count: SizeInt); overload;{$ENDIF ~GENERIC}\r\n{$IFNDEF FPC}\r\n{$IFDEF GENERIC}\r\nprocedure MoveArray(var List: TDynStringArray; FromIndex, ToIndex, Count: SizeInt); overload;\r\n{$ELSE ~GENERIC}\r\n{$IFDEF REFCOUNTED}\r\nprocedure FinalizeArrayBeforeMove(var List: TDynStringArray; FromIndex, ToIndex, Count: SizeInt); overload;\r\n {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\nprocedure InitializeArray(var List: TDynStringArray; FromIndex, Count: SizeInt); overload;\r\n {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\nprocedure InitializeArrayAfterMove(var List: TDynStringArray; FromIndex, ToIndex, Count: SizeInt); overload;\r\n {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\n{$ELSE ~REFCOUNTED}\r\n{$IFDEF ZEROINIT}\r\nprocedure InitializeArrayAfterMove(var List: TDynStringArray; FromIndex, ToIndex, Count: SizeInt); overload;\r\n {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\n{$ENDIF ZEROINIT}\r\n{$ENDIF ~REFCOUNTED}\r\nprocedure MoveArray(var List: TDynStringArray; FromIndex, ToIndex, Count: SizeInt); overload;{$ENDIF ~GENERIC}\r\n{$IFDEF GENERIC}\r\nprocedure MoveArray(var List: TDynFloatArray; FromIndex, ToIndex, Count: SizeInt); overload;\r\n{$ELSE ~GENERIC}\r\n{$IFDEF REFCOUNTED}\r\nprocedure FinalizeArrayBeforeMove(var List: TDynFloatArray; FromIndex, ToIndex, Count: SizeInt); overload;\r\n {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\nprocedure InitializeArray(var List: TDynFloatArray; FromIndex, Count: SizeInt); overload;\r\n {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\nprocedure InitializeArrayAfterMove(var List: TDynFloatArray; FromIndex, ToIndex, Count: SizeInt); overload;\r\n {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\n{$ELSE ~REFCOUNTED}\r\n{$IFDEF ZEROINIT}\r\nprocedure InitializeArrayAfterMove(var List: TDynFloatArray; FromIndex, ToIndex, Count: SizeInt); overload;\r\n {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\n{$ENDIF ZEROINIT}\r\n{$ENDIF ~REFCOUNTED}\r\nprocedure MoveArray(var List: TDynFloatArray; FromIndex, ToIndex, Count: SizeInt); overload;{$ENDIF ~GENERIC}\r\n{$ENDIF ~FPC}\r\n\r\n// Iterate algorithms\r\nprocedure Iterate(const First: IJclIntfIterator; Count: Integer; F: TIntfIterateProcedure); overload;\r\nprocedure Iterate(const First: IJclAnsiStrIterator; Count: Integer; F: TAnsiStrIterateProcedure); overload;\r\nprocedure Iterate(const First: IJclWideStrIterator; Count: Integer; F: TWideStrIterateProcedure); overload;\r\n{$IFDEF SUPPORTS_UNICODE_STRING}\r\nprocedure Iterate(const First: IJclUnicodeStrIterator; Count: Integer; F: TUnicodeStrIterateProcedure); overload;\r\n{$ENDIF SUPPORTS_UNICODE_STRING}\r\nprocedure Iterate(const First: IJclSingleIterator; Count: Integer; F: TSingleIterateProcedure); overload;\r\nprocedure Iterate(const First: IJclDoubleIterator; Count: Integer; F: TDoubleIterateProcedure); overload;\r\nprocedure Iterate(const First: IJclExtendedIterator; Count: Integer; F: TExtendedIterateProcedure); overload;\r\nprocedure Iterate(const First: IJclIntegerIterator; Count: Integer; F: TIntegerIterateProcedure); overload;\r\nprocedure Iterate(const First: IJclCardinalIterator; Count: Integer; F: TCardinalIterateProcedure); overload;\r\nprocedure Iterate(const First: IJclInt64Iterator; Count: Integer; F: TInt64IterateProcedure); overload;\r\nprocedure Iterate(const First: IJclPtrIterator; Count: Integer; F: TPtrIterateProcedure); overload;\r\nprocedure Iterate(const First: IJclIterator; Count: Integer; F: TIterateProcedure); overload;\r\n\r\n\r\n// Apply algorithms\r\nprocedure Apply(const First: IJclIntfIterator; Count: Integer; F: TIntfApplyFunction); overload;\r\nprocedure Apply(const First: IJclAnsiStrIterator; Count: Integer; F: TAnsiStrApplyFunction); overload;\r\nprocedure Apply(const First: IJclWideStrIterator; Count: Integer; F: TWideStrApplyFunction); overload;\r\n{$IFDEF SUPPORTS_UNICODE_STRING}\r\nprocedure Apply(const First: IJclUnicodeStrIterator; Count: Integer; F: TUnicodeStrApplyFunction); overload;\r\n{$ENDIF SUPPORTS_UNICODE_STRING}\r\nprocedure Apply(const First: IJclSingleIterator; Count: Integer; F: TSingleApplyFunction); overload;\r\nprocedure Apply(const First: IJclDoubleIterator; Count: Integer; F: TDoubleApplyFunction); overload;\r\nprocedure Apply(const First: IJclExtendedIterator; Count: Integer; F: TExtendedApplyFunction); overload;\r\nprocedure Apply(const First: IJclIntegerIterator; Count: Integer; F: TIntegerApplyFunction); overload;\r\nprocedure Apply(const First: IJclCardinalIterator; Count: Integer; F: TCardinalApplyFunction); overload;\r\nprocedure Apply(const First: IJclInt64Iterator; Count: Integer; F: TInt64ApplyFunction); overload;\r\nprocedure Apply(const First: IJclPtrIterator; Count: Integer; F: TPtrApplyFunction); overload;\r\nprocedure Apply(const First: IJclIterator; Count: Integer; F: TApplyFunction); overload;\r\n\r\n\r\n// Find algorithms\r\nfunction Find(const First: IJclIntfIterator; Count: Integer; const AInterface: IInterface;\r\n AComparator: TIntfCompare): IJclIntfIterator; overload;\r\nfunction Find(const First: IJclIntfIterator; Count: Integer; const AInterface: IInterface;\r\n AEqualityComparator: TIntfEqualityCompare): IJclIntfIterator; overload;\r\nfunction Find(const First: IJclAnsiStrIterator; Count: Integer; const AString: AnsiString;\r\n AComparator: TAnsiStrCompare): IJclAnsiStrIterator; overload;\r\nfunction Find(const First: IJclAnsiStrIterator; Count: Integer; const AString: AnsiString;\r\n AEqualityComparator: TAnsiStrEqualityCompare): IJclAnsiStrIterator; overload;\r\nfunction Find(const First: IJclWideStrIterator; Count: Integer; const AString: WideString;\r\n AComparator: TWideStrCompare): IJclWideStrIterator; overload;\r\nfunction Find(const First: IJclWideStrIterator; Count: Integer; const AString: WideString;\r\n AEqualityComparator: TWideStrEqualityCompare): IJclWideStrIterator; overload;\r\n{$IFDEF SUPPORTS_UNICODE_STRING}\r\nfunction Find(const First: IJclUnicodeStrIterator; Count: Integer; const AString: UnicodeString;\r\n AComparator: TUnicodeStrCompare): IJclUnicodeStrIterator; overload;\r\n{$ENDIF SUPPORTS_UNICODE_STRING}\r\n{$IFDEF SUPPORTS_UNICODE_STRING}\r\nfunction Find(const First: IJclUnicodeStrIterator; Count: Integer; const AString: UnicodeString;\r\n AEqualityComparator: TUnicodeStrEqualityCompare): IJclUnicodeStrIterator; overload;\r\n{$ENDIF SUPPORTS_UNICODE_STRING}\r\nfunction Find(const First: IJclSingleIterator; Count: Integer; const AValue: Single;\r\n AComparator: TSingleCompare): IJclSingleIterator; overload;\r\nfunction Find(const First: IJclSingleIterator; Count: Integer; const AValue: Single;\r\n AEqualityComparator: TSingleEqualityCompare): IJclSingleIterator; overload;\r\nfunction Find(const First: IJclDoubleIterator; Count: Integer; const AValue: Double;\r\n AComparator: TDoubleCompare): IJclDoubleIterator; overload;\r\nfunction Find(const First: IJclDoubleIterator; Count: Integer; const AValue: Double;\r\n AEqualityComparator: TDoubleEqualityCompare): IJclDoubleIterator; overload;\r\nfunction Find(const First: IJclExtendedIterator; Count: Integer; const AValue: Extended;\r\n AComparator: TExtendedCompare): IJclExtendedIterator; overload;\r\nfunction Find(const First: IJclExtendedIterator; Count: Integer; const AValue: Extended;\r\n AEqualityComparator: TExtendedEqualityCompare): IJclExtendedIterator; overload;\r\nfunction Find(const First: IJclIntegerIterator; Count: Integer; AValue: Integer;\r\n AComparator: TIntegerCompare): IJclIntegerIterator; overload;\r\nfunction Find(const First: IJclIntegerIterator; Count: Integer; AValue: Integer;\r\n AEqualityComparator: TIntegerEqualityCompare): IJclIntegerIterator; overload;\r\nfunction Find(const First: IJclCardinalIterator; Count: Integer; AValue: Cardinal;\r\n AComparator: TCardinalCompare): IJclCardinalIterator; overload;\r\nfunction Find(const First: IJclCardinalIterator; Count: Integer; AValue: Cardinal;\r\n AEqualityComparator: TCardinalEqualityCompare): IJclCardinalIterator; overload;\r\nfunction Find(const First: IJclInt64Iterator; Count: Integer; const AValue: Int64;\r\n AComparator: TInt64Compare): IJclInt64Iterator; overload;\r\nfunction Find(const First: IJclInt64Iterator; Count: Integer; const AValue: Int64;\r\n AEqualityComparator: TInt64EqualityCompare): IJclInt64Iterator; overload;\r\nfunction Find(const First: IJclPtrIterator; Count: Integer; APtr: Pointer;\r\n AComparator: TPtrCompare): IJclPtrIterator; overload;\r\nfunction Find(const First: IJclPtrIterator; Count: Integer; APtr: Pointer;\r\n AEqualityComparator: TPtrEqualityCompare): IJclPtrIterator; overload;\r\nfunction Find(const First: IJclIterator; Count: Integer; AObject: TObject;\r\n AComparator: TCompare): IJclIterator; overload;\r\nfunction Find(const First: IJclIterator; Count: Integer; AObject: TObject;\r\n AEqualityComparator: TEqualityCompare): IJclIterator; overload;\r\n\r\n\r\n// CountObject algorithms\r\nfunction CountObject(const First: IJclIntfIterator; Count: Integer;\r\n const AInterface: IInterface; AComparator: TIntfCompare): Integer; overload;\r\nfunction CountObject(const First: IJclIntfIterator; Count: Integer;\r\n const AInterface: IInterface; AEqualityComparator: TIntfEqualityCompare): Integer; overload;\r\nfunction CountObject(const First: IJclAnsiStrIterator; Count: Integer;\r\n const AString: AnsiString; AComparator: TAnsiStrCompare): Integer; overload;\r\nfunction CountObject(const First: IJclAnsiStrIterator; Count: Integer;\r\n const AString: AnsiString; AEqualityComparator: TAnsiStrEqualityCompare): Integer; overload;\r\nfunction CountObject(const First: IJclWideStrIterator; Count: Integer;\r\n const AString: WideString; AComparator: TWideStrCompare): Integer; overload;\r\nfunction CountObject(const First: IJclWideStrIterator; Count: Integer;\r\n const AString: WideString; AEqualityComparator: TWideStrEqualityCompare): Integer; overload;\r\n{$IFDEF SUPPORTS_UNICODE_STRING}\r\nfunction CountObject(const First: IJclUnicodeStrIterator; Count: Integer;\r\n const AString: UnicodeString; AComparator: TUnicodeStrCompare): Integer; overload;\r\n{$ENDIF SUPPORTS_UNICODE_STRING}\r\n{$IFDEF SUPPORTS_UNICODE_STRING}\r\nfunction CountObject(const First: IJclUnicodeStrIterator; Count: Integer;\r\n const AString: UnicodeString; AEqualityComparator: TUnicodeStrEqualityCompare): Integer; overload;\r\n{$ENDIF SUPPORTS_UNICODE_STRING}\r\nfunction CountObject(const First: IJclSingleIterator; Count: Integer;\r\n const AValue: Single; AComparator: TSingleCompare): Integer; overload;\r\nfunction CountObject(const First: IJclSingleIterator; Count: Integer;\r\n const AValue: Single; AEqualityComparator: TSingleEqualityCompare): Integer; overload;\r\nfunction CountObject(const First: IJclDoubleIterator; Count: Integer;\r\n const AValue: Double; AComparator: TDoubleCompare): Integer; overload;\r\nfunction CountObject(const First: IJclDoubleIterator; Count: Integer;\r\n const AValue: Double; AEqualityComparator: TDoubleEqualityCompare): Integer; overload;\r\nfunction CountObject(const First: IJclExtendedIterator; Count: Integer;\r\n const AValue: Extended; AComparator: TExtendedCompare): Integer; overload;\r\nfunction CountObject(const First: IJclExtendedIterator; Count: Integer;\r\n const AValue: Extended; AEqualityComparator: TExtendedEqualityCompare): Integer; overload;\r\nfunction CountObject(const First: IJclIntegerIterator; Count: Integer;\r\n AValue: Integer; AComparator: TIntegerCompare): Integer; overload;\r\nfunction CountObject(const First: IJclIntegerIterator; Count: Integer;\r\n AValue: Integer; AEqualityComparator: TIntegerEqualityCompare): Integer; overload;\r\nfunction CountObject(const First: IJclCardinalIterator; Count: Integer;\r\n AValue: Cardinal; AComparator: TCardinalCompare): Integer; overload;\r\nfunction CountObject(const First: IJclCardinalIterator; Count: Integer;\r\n AValue: Cardinal; AEqualityComparator: TCardinalEqualityCompare): Integer; overload;\r\nfunction CountObject(const First: IJclInt64Iterator; Count: Integer;\r\n const AValue: Int64; AComparator: TInt64Compare): Integer; overload;\r\nfunction CountObject(const First: IJclInt64Iterator; Count: Integer;\r\n const AValue: Int64; AEqualityComparator: TInt64EqualityCompare): Integer; overload;\r\nfunction CountObject(const First: IJclPtrIterator; Count: Integer;\r\n APtr: Pointer; AComparator: TPtrCompare): Integer; overload;\r\nfunction CountObject(const First: IJclPtrIterator; Count: Integer;\r\n APtr: Pointer; AEqualityComparator: TPtrEqualityCompare): Integer; overload;\r\nfunction CountObject(const First: IJclIterator; Count: Integer;\r\n AObject: TObject; AComparator: TCompare): Integer; overload;\r\nfunction CountObject(const First: IJclIterator; Count: Integer;\r\n AObject: TObject; AEqualityComparator: TEqualityCompare): Integer; overload;\r\n\r\n\r\n// Copy algorithms\r\nprocedure Copy(const First: IJclIntfIterator; Count: Integer;\r\n const Output: IJclIntfIterator); overload;\r\nprocedure Copy(const First: IJclAnsiStrIterator; Count: Integer;\r\n const Output: IJclAnsiStrIterator); overload;\r\nprocedure Copy(const First: IJclWideStrIterator; Count: Integer;\r\n const Output: IJclWideStrIterator); overload;\r\n{$IFDEF SUPPORTS_UNICODE_STRING}\r\nprocedure Copy(const First: IJclUnicodeStrIterator; Count: Integer;\r\n const Output: IJclUnicodeStrIterator); overload;\r\n{$ENDIF SUPPORTS_UNICODE_STRING}\r\nprocedure Copy(const First: IJclSingleIterator; Count: Integer;\r\n const Output: IJclSingleIterator); overload;\r\nprocedure Copy(const First: IJclDoubleIterator; Count: Integer;\r\n const Output: IJclDoubleIterator); overload;\r\nprocedure Copy(const First: IJclExtendedIterator; Count: Integer;\r\n const Output: IJclExtendedIterator); overload;\r\nprocedure Copy(const First: IJclIntegerIterator; Count: Integer;\r\n const Output: IJclIntegerIterator); overload;\r\nprocedure Copy(const First: IJclCardinalIterator; Count: Integer;\r\n const Output: IJclCardinalIterator); overload;\r\nprocedure Copy(const First: IJclInt64Iterator; Count: Integer;\r\n const Output: IJclInt64Iterator); overload;\r\nprocedure Copy(const First: IJclPtrIterator; Count: Integer;\r\n const Output: IJclPtrIterator); overload;\r\nprocedure Copy(const First: IJclIterator; Count: Integer;\r\n const Output: IJclIterator); overload;\r\n\r\n\r\n// Generate algorithms\r\nprocedure Generate(const List: IJclIntfList; Count: Integer; const AInterface: IInterface); overload;\r\nprocedure Generate(const List: IJclAnsiStrList; Count: Integer; const AString: AnsiString); overload;\r\nprocedure Generate(const List: IJclWideStrList; Count: Integer; const AString: WideString); overload;\r\n{$IFDEF SUPPORTS_UNICODE_STRING}\r\nprocedure Generate(const List: IJclUnicodeStrList; Count: Integer; const AString: UnicodeString); overload;\r\n{$ENDIF SUPPORTS_UNICODE_STRING}\r\nprocedure Generate(const List: IJclSingleList; Count: Integer; const AValue: Single); overload;\r\nprocedure Generate(const List: IJclDoubleList; Count: Integer; const AValue: Double); overload;\r\nprocedure Generate(const List: IJclExtendedList; Count: Integer; const AValue: Extended); overload;\r\nprocedure Generate(const List: IJclIntegerList; Count: Integer; AValue: Integer); overload;\r\nprocedure Generate(const List: IJclCardinalList; Count: Integer; AValue: Cardinal); overload;\r\nprocedure Generate(const List: IJclInt64List; Count: Integer; const AValue: Int64); overload;\r\nprocedure Generate(const List: IJclPtrList; Count: Integer; APtr: Pointer); overload;\r\nprocedure Generate(const List: IJclList; Count: Integer; AObject: TObject); overload;\r\n\r\n\r\n// Fill algorithms\r\nprocedure Fill(const First: IJclIntfIterator; Count: Integer; const AInterface: IInterface); overload;\r\nprocedure Fill(const First: IJclAnsiStrIterator; Count: Integer; const AString: AnsiString); overload;\r\nprocedure Fill(const First: IJclWideStrIterator; Count: Integer; const AString: WideString); overload;\r\n{$IFDEF SUPPORTS_UNICODE_STRING}\r\nprocedure Fill(const First: IJclUnicodeStrIterator; Count: Integer; const AString: UnicodeString); overload;\r\n{$ENDIF SUPPORTS_UNICODE_STRING}\r\nprocedure Fill(const First: IJclSingleIterator; Count: Integer; const AValue: Single); overload;\r\nprocedure Fill(const First: IJclDoubleIterator; Count: Integer; const AValue: Double); overload;\r\nprocedure Fill(const First: IJclExtendedIterator; Count: Integer; const AValue: Extended); overload;\r\nprocedure Fill(const First: IJclIntegerIterator; Count: Integer; AValue: Integer); overload;\r\nprocedure Fill(const First: IJclCardinalIterator; Count: Integer; AValue: Cardinal); overload;\r\nprocedure Fill(const First: IJclInt64Iterator; Count: Integer; const AValue: Int64); overload;\r\nprocedure Fill(const First: IJclPtrIterator; Count: Integer; APtr: Pointer); overload;\r\nprocedure Fill(const First: IJclIterator; Count: Integer; AObject: TObject); overload;\r\n\r\n\r\n// Reverse algorithms\r\nprocedure Reverse(const First, Last: IJclIntfIterator); overload;\r\nprocedure Reverse(const First, Last: IJclAnsiStrIterator); overload;\r\nprocedure Reverse(const First, Last: IJclWideStrIterator); overload;\r\n{$IFDEF SUPPORTS_UNICODE_STRING}\r\nprocedure Reverse(const First, Last: IJclUnicodeStrIterator); overload;\r\n{$ENDIF SUPPORTS_UNICODE_STRING}\r\nprocedure Reverse(const First, Last: IJclSingleIterator); overload;\r\nprocedure Reverse(const First, Last: IJclDoubleIterator); overload;\r\nprocedure Reverse(const First, Last: IJclExtendedIterator); overload;\r\nprocedure Reverse(const First, Last: IJclIntegerIterator); overload;\r\nprocedure Reverse(const First, Last: IJclCardinalIterator); overload;\r\nprocedure Reverse(const First, Last: IJclInt64Iterator); overload;\r\nprocedure Reverse(const First, Last: IJclPtrIterator); overload;\r\nprocedure Reverse(const First, Last: IJclIterator); overload;\r\n\r\n\r\nprocedure QuickSort(const AList: IJclIntfList; L, R: Integer; AComparator: TIntfCompare); overload;\r\nprocedure QuickSort(const AList: IJclAnsiStrList; L, R: Integer; AComparator: TAnsiStrCompare); overload;\r\nprocedure QuickSort(const AList: IJclWideStrList; L, R: Integer; AComparator: TWideStrCompare); overload;\r\n{$IFDEF SUPPORTS_UNICODE_STRING}\r\nprocedure QuickSort(const AList: IJclUnicodeStrList; L, R: Integer; AComparator: TUnicodeStrCompare); overload;\r\n{$ENDIF SUPPORTS_UNICODE_STRING}\r\nprocedure QuickSort(const AList: IJclSingleList; L, R: Integer; AComparator: TSingleCompare); overload;\r\nprocedure QuickSort(const AList: IJclDoubleList; L, R: Integer; AComparator: TDoubleCompare); overload;\r\nprocedure QuickSort(const AList: IJclExtendedList; L, R: Integer; AComparator: TExtendedCompare); overload;\r\nprocedure QuickSort(const AList: IJclIntegerList; L, R: Integer; AComparator: TIntegerCompare); overload;\r\nprocedure QuickSort(const AList: IJclCardinalList; L, R: Integer; AComparator: TCardinalCompare); overload;\r\nprocedure QuickSort(const AList: IJclInt64List; L, R: Integer; AComparator: TInt64Compare); overload;\r\nprocedure QuickSort(const AList: IJclPtrList; L, R: Integer; AComparator: TPtrCompare); overload;\r\nprocedure QuickSort(const AList: IJclList; L, R: Integer; AComparator: TCompare); overload;\r\n\r\n\r\nvar\r\n IntfSortProc: TIntfSortProc = QuickSort;\r\n AnsiStrSortProc: TAnsiStrSortProc = QuickSort;\r\n WideStrSortProc: TWideStrSortProc = QuickSort;\r\n {$IFDEF SUPPORTS_UNICODE_STRING}\r\n UnicodeStrSortProc: TUnicodeStrSortProc = QuickSort;\r\n {$ENDIF SUPPORTS_UNICODE_STRING}\r\n SingleSortProc: TSingleSortProc = QuickSort;\r\n DoubleSortProc: TDoubleSortProc = QuickSort;\r\n ExtendedSortProc: TExtendedSortProc = QuickSort;\r\n IntegerSortProc: TIntegerSortProc = QuickSort;\r\n CardinalSortProc: TCardinalSortProc = QuickSort;\r\n Int64SortProc: TInt64SortProc = QuickSort;\r\n PtrSortProc: TPtrSortProc = QuickSort;\r\n SortProc: TSortProc = QuickSort;\r\n\r\n// Sort algorithms\r\nprocedure Sort(const AList: IJclIntfList; First, Last: Integer; AComparator: TIntfCompare); overload;\r\nprocedure Sort(const AList: IJclAnsiStrList; First, Last: Integer; AComparator: TAnsiStrCompare); overload;\r\nprocedure Sort(const AList: IJclWideStrList; First, Last: Integer; AComparator: TWideStrCompare); overload;\r\n{$IFDEF SUPPORTS_UNICODE_STRING}\r\nprocedure Sort(const AList: IJclUnicodeStrList; First, Last: Integer; AComparator: TUnicodeStrCompare); overload;\r\n{$ENDIF SUPPORTS_UNICODE_STRING}\r\nprocedure Sort(const AList: IJclSingleList; First, Last: Integer; AComparator: TSingleCompare); overload;\r\nprocedure Sort(const AList: IJclDoubleList; First, Last: Integer; AComparator: TDoubleCompare); overload;\r\nprocedure Sort(const AList: IJclExtendedList; First, Last: Integer; AComparator: TExtendedCompare); overload;\r\nprocedure Sort(const AList: IJclIntegerList; First, Last: Integer; AComparator: TIntegerCompare); overload;\r\nprocedure Sort(const AList: IJclCardinalList; First, Last: Integer; AComparator: TCardinalCompare); overload;\r\nprocedure Sort(const AList: IJclInt64List; First, Last: Integer; AComparator: TInt64Compare); overload;\r\nprocedure Sort(const AList: IJclPtrList; First, Last: Integer; AComparator: TPtrCompare); overload;\r\nprocedure Sort(const AList: IJclList; First, Last: Integer; AComparator: TCompare); overload;\r\n\r\n\r\n{$IFDEF SUPPORTS_GENERICS}\r\n//DOM-IGNORE-BEGIN\r\n\r\ntype\r\n // cannot implement generic global functions\r\n TJclAlgorithms = class\r\n private\r\n //FSortProc: TSortProc;\r\n public\r\n class procedure Iterate(const First: IJclIterator; Count: Integer; F: TIterateProcedure);\r\n class procedure Apply(const First: IJclIterator; Count: Integer; F: TApplyFunction);\r\n class function Find(const First: IJclIterator; Count: Integer; const AItem: T;\r\n AComparator: TCompare): IJclIterator; overload;\r\n class function Find(const First: IJclIterator; Count: Integer; const AItem: T;\r\n AEqualityComparator: TEqualityCompare): IJclIterator; overload;\r\n class function CountObject(const First: IJclIterator; Count: Integer;\r\n const AItem: T; AComparator: TCompare): Integer; overload;\r\n class function CountObject(const First: IJclIterator; Count: Integer;\r\n const AItem: T; AEqualityComparator: TEqualityCompare): Integer; overload;\r\n class procedure Copy(const First: IJclIterator; Count: Integer;\r\n const Output: IJclIterator);\r\n class procedure Generate(const List: IJclList; Count: Integer; const AItem: T);\r\n class procedure Fill(const First: IJclIterator; Count: Integer; const AItem: T);\r\n class procedure Reverse(const First, Last: IJclIterator);\r\n class procedure QuickSort(const AList: IJclList; L, R: Integer; AComparator: TCompare);\r\n class procedure Sort(const AList: IJclList; First, Last: Integer; AComparator: TCompare);\r\n //class property SortProc: TSortProc read FSortProc write FSortProc;\r\n end;\r\n\r\n//DOM-IGNORE-END\r\n{$ENDIF SUPPORTS_GENERICS}\r\n\r\nconst\r\n // table of byte permutations without inner loop\r\n BytePermTable: array [Byte] of Byte =\r\n ( 22, 133, 0, 244, 194, 193, 4, 164, 69, 211, 166, 235, 75, 110, 9, 140,\r\n 125, 84, 64, 209, 57, 47, 197, 76, 237, 48, 189, 87, 221, 254, 20, 132,\r\n 25, 162, 203, 225, 186, 165, 72, 228, 61, 208, 158, 185, 114, 173, 1, 66,\r\n 202, 46, 198, 214, 27, 161, 178, 238, 8, 68, 97, 17, 199, 210, 96, 196,\r\n 85, 240, 233, 71, 232, 142, 148, 70, 184, 152, 90, 206, 139, 182, 34, 101,\r\n 104, 12, 143, 227, 24, 247, 175, 150, 39, 31, 36, 123, 62, 119, 236, 28,\r\n 117, 100, 230, 223, 30, 154, 18, 153, 127, 192, 176, 19, 174, 134, 2, 216,\r\n 218, 91, 45, 7, 128, 138, 126, 40, 16, 54, 207, 181, 11, 137, 60, 191,\r\n 51, 231, 121, 213, 86, 111, 141, 172, 98, 226, 179, 249, 136, 58, 88, 93,\r\n 201, 195, 118, 144, 146, 113, 212, 32, 21, 131, 177, 33, 151, 130, 205, 171,\r\n 92, 251, 168, 29, 156, 124, 224, 200, 3, 187, 105, 52, 239, 147, 82, 94,\r\n 26, 102, 243, 242, 145, 163, 49, 135, 43, 78, 112, 83, 63, 35, 170, 167,\r\n 250, 159, 73, 37, 6, 79, 106, 215, 129, 74, 109, 42, 41, 120, 23, 160,\r\n 107, 180, 103, 77, 53, 169, 89, 149, 44, 38, 81, 246, 188, 67, 15, 80,\r\n 155, 99, 95, 5, 229, 108, 13, 255, 59, 241, 252, 245, 222, 248, 115, 55,\r\n 217, 56, 65, 219, 204, 190, 10, 50, 253, 183, 234, 116, 122, 220, 14, 157);\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jcl.svn.sourceforge.net/svnroot/jcl/tags/JCL-2.4-Build4571/jcl/source/common/JclAlgorithms.pas $';\r\n Revision: '$Revision: 3830 $';\r\n Date: '$Date: 2012-08-14 23:30:14 +0200 (mar. 14 août 2012) $';\r\n LogPath: 'JCL\\source\\common';\r\n Extra: '';\r\n Data: nil\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n {$IFDEF HAS_UNITSCOPE}\r\n {$IFDEF COMPILER11_UP}\r\n Winapi.Windows,\r\n {$ENDIF COMPILER11_UP}\r\n {$IFDEF HAS_UNIT_ANSISTRINGS}\r\n System.AnsiStrings,\r\n {$ENDIF HAS_UNIT_ANSISTRINGS}\r\n {$IFDEF UNICODE_RTL_DATABASE}\r\n System.Character,\r\n {$ENDIF UNICODE_RTL_DATABASE}\r\n System.SysUtils,\r\n {$ELSE ~HAS_UNITSCOPE}\r\n {$IFDEF COMPILER11_UP}\r\n Windows,\r\n {$ENDIF COMPILER11_UP}\r\n {$IFDEF HAS_UNIT_ANSISTRINGS}\r\n AnsiStrings,\r\n {$ENDIF HAS_UNIT_ANSISTRINGS}\r\n {$IFDEF UNICODE_RTL_DATABASE}\r\n Character,\r\n {$ENDIF UNICODE_RTL_DATABASE}\r\n SysUtils,\r\n {$ENDIF ~HAS_UNITSCOPE}\r\n JclAnsiStrings, JclStringConversions, JclUnicode;\r\n\r\nfunction IntfSimpleCompare(const Obj1, Obj2: IInterface): Integer;\r\nbegin\r\n if SizeInt(Obj1) < SizeInt(Obj2) then\r\n Result := -1\r\n else\r\n if SizeInt(Obj1) > SizeInt(Obj2) then\r\n Result := 1\r\n else\r\n Result := 0;\r\nend;\r\n\r\n// default is case-sensitive\r\nfunction AnsiStrSimpleCompare(const Obj1, Obj2: AnsiString): Integer;\r\nbegin\r\n Result := CompareStr(Obj1, Obj2);\r\nend;\r\n\r\n// case-insensitive\r\nfunction AnsiStrSimpleCompareI(const Obj1, Obj2: AnsiString): Integer;\r\nbegin\r\n Result := CompareText(Obj1, Obj2);\r\nend;\r\n\r\n// default is case-sensitive\r\nfunction WideStrSimpleCompare(const Obj1, Obj2: WideString): Integer;\r\nbegin\r\n Result := WideCompareStr(Obj1, Obj2);\r\nend;\r\n\r\n// case-insensitive\r\nfunction WideStrSimpleCompareI(const Obj1, Obj2: WideString): Integer;\r\nbegin\r\n Result := {$IFDEF HAS_UNITSCOPE}System.{$ENDIF}SysUtils.WideCompareText(Obj1, Obj2);\r\nend;\r\n\r\n{$IFDEF SUPPORTS_UNICODE_STRING}\r\n// default is case-sensitive\r\nfunction UnicodeStrSimpleCompare(const Obj1, Obj2: UnicodeString): Integer;\r\nbegin\r\n Result := CompareStr(Obj1, Obj2);\r\nend;\r\n\r\n// case-insensitive\r\nfunction UnicodeStrSimpleCompareI(const Obj1, Obj2: UnicodeString): Integer;\r\nbegin\r\n Result := CompareText(Obj1, Obj2);\r\nend;\r\n{$ENDIF SUPPORTS_UNICODE_STRING}\r\n\r\nfunction StrSimpleCompare(const Obj1, Obj2: string): Integer;\r\nbegin\r\n case SizeOf(Obj1[1]) of\r\n SizeOf(AnsiChar):\r\n Result := CompareStr(Obj1, Obj2);\r\n SizeOf(WideChar):\r\n {$IFDEF SUPPORTS_UNICODE}\r\n Result := CompareStr(Obj1, Obj2);\r\n {$ELSE ~SUPPORTS_UNICODE}\r\n Result := WideCompareStr(Obj1, Obj2);\r\n {$ENDIF ~SUPPORTS_UNICODE}\r\n else\r\n raise EJclOperationNotSupportedError.Create;\r\n end;\r\nend;\r\n\r\nfunction StrSimpleCompareI(const Obj1, Obj2: string): Integer;\r\nbegin\r\n case SizeOf(Obj1[1]) of\r\n SizeOf(AnsiChar):\r\n Result := CompareText(Obj1, Obj2);\r\n SizeOf(WideChar):\r\n {$IFDEF SUPPORTS_UNICODE}\r\n Result := CompareText(Obj1, Obj2);\r\n {$ELSE ~SUPPORTS_UNICODE}\r\n {$IFDEF HAS_UNITSCOPE}System.{$ENDIF}SysUtils.WideCompareText(Obj1, Obj2);\r\n {$ENDIF ~SUPPORTS_UNICODE}\r\n else\r\n raise EJclOperationNotSupportedError.Create;\r\n end;\r\nend;\r\n\r\nfunction SingleSimpleCompare(const Obj1, Obj2: Single): Integer;\r\nbegin\r\n if Obj1 < Obj2 then\r\n Result := -1\r\n else\r\n if Obj1 > Obj2 then\r\n Result := 1\r\n else\r\n Result := 0;\r\nend;\r\n\r\nfunction DoubleSimpleCompare(const Obj1, Obj2: Double): Integer;\r\nbegin\r\n if Obj1 < Obj2 then\r\n Result := -1\r\n else\r\n if Obj1 > Obj2 then\r\n Result := 1\r\n else\r\n Result := 0;\r\nend;\r\n\r\nfunction ExtendedSimpleCompare(const Obj1, Obj2: Extended): Integer;\r\nbegin\r\n if Obj1 < Obj2 then\r\n Result := -1\r\n else\r\n if Obj1 > Obj2 then\r\n Result := 1\r\n else\r\n Result := 0;\r\nend;\r\n\r\nfunction FloatSimpleCompare(const Obj1, Obj2: Float): Integer;\r\nbegin\r\n if Obj1 < Obj2 then\r\n Result := -1\r\n else\r\n if Obj1 > Obj2 then\r\n Result := 1\r\n else\r\n Result := 0;\r\nend;\r\n\r\nfunction IntegerSimpleCompare(Obj1, Obj2: Integer): Integer;\r\nbegin\r\n if Obj1 < Obj2 then\r\n Result := -1\r\n else\r\n if Obj1 > Obj2 then\r\n Result := 1\r\n else\r\n Result := 0;\r\nend;\r\n\r\nfunction CardinalSimpleCompare(Obj1, Obj2: Cardinal): Integer;\r\nbegin\r\n if Obj1 < Obj2 then\r\n Result := -1\r\n else\r\n if Obj1 > Obj2 then\r\n Result := 1\r\n else\r\n Result := 0;\r\nend;\r\n\r\nfunction Int64SimpleCompare(const Obj1, Obj2: Int64): Integer;\r\nbegin\r\n if Obj1 < Obj2 then\r\n Result := -1\r\n else\r\n if Obj1 > Obj2 then\r\n Result := 1\r\n else\r\n Result := 0;\r\nend;\r\n\r\nfunction PtrSimpleCompare(Obj1, Obj2: Pointer): Integer;\r\nbegin\r\n if SizeInt(Obj1) < SizeInt(Obj2) then\r\n Result := -1\r\n else\r\n if SizeInt(Obj1) > SizeInt(Obj2) then\r\n Result := 1\r\n else\r\n Result := 0;\r\nend;\r\n\r\nfunction SimpleCompare(Obj1, Obj2: TObject): Integer;\r\nbegin\r\n if SizeInt(Obj1) < SizeInt(Obj2) then\r\n Result := -1\r\n else\r\n if SizeInt(Obj1) > SizeInt(Obj2) then\r\n Result := 1\r\n else\r\n Result := 0;\r\nend;\r\n\r\nfunction IntegerCompare(Obj1, Obj2: TObject): Integer;\r\nbegin\r\n if SizeInt(Obj1) < SizeInt(Obj2) then\r\n Result := -1\r\n else\r\n if SizeInt(Obj1) > SizeInt(Obj2) then\r\n Result := 1\r\n else\r\n Result := 0;\r\nend;\r\n\r\nfunction IntfSimpleEqualityCompare(const Obj1, Obj2: IInterface): Boolean;\r\nbegin\r\n Result := SizeInt(Obj1) = SizeInt(Obj2);\r\nend;\r\n\r\n// default is case-sensitive\r\nfunction AnsiStrSimpleEqualityCompare(const Obj1, Obj2: AnsiString): Boolean;\r\nbegin\r\n Result := CompareStr(Obj1, Obj2) = 0;\r\nend;\r\n\r\n// case-insensitive\r\nfunction AnsiStrSimpleEqualityCompareI(const Obj1, Obj2: AnsiString): Boolean;\r\nbegin\r\n Result := CompareText(Obj1, Obj2) = 0;\r\nend;\r\n\r\n// default is case-sensitive\r\nfunction WideStrSimpleEqualityCompare(const Obj1, Obj2: WideString): Boolean;\r\nbegin\r\n Result := WideCompareStr(Obj1, Obj2) = 0;\r\nend;\r\n\r\n// case-insensitive\r\nfunction WideStrSimpleEqualityCompareI(const Obj1, Obj2: WideString): Boolean;\r\nbegin\r\n Result := {$IFDEF HAS_UNITSCOPE}System.{$ENDIF}SysUtils.WideCompareText(Obj1, Obj2) = 0;\r\nend;\r\n\r\n{$IFDEF SUPPORTS_UNICODE_STRING}\r\n// default is case-sensitive\r\nfunction UnicodeStrSimpleEqualityCompare(const Obj1, Obj2: UnicodeString): Boolean;\r\nbegin\r\n Result := CompareStr(Obj1, Obj2) = 0;\r\nend;\r\n\r\n// case-insensitive\r\nfunction UnicodeStrSimpleEqualityCompareI(const Obj1, Obj2: UnicodeString): Boolean;\r\nbegin\r\n Result := CompareText(Obj1, Obj2) = 0;\r\nend;\r\n{$ENDIF SUPPORTS_UNICODE_STRING}\r\n\r\nfunction StrSimpleEqualityCompare(const Obj1, Obj2: string): Boolean;\r\nbegin\r\n case SizeOf(Obj1[1]) of\r\n SizeOf(AnsiChar):\r\n Result := CompareStr(Obj1, Obj2) = 0;\r\n SizeOf(WideChar):\r\n Result := WideCompareStr(Obj1, Obj2) = 0;\r\n else\r\n raise EJclOperationNotSupportedError.Create;\r\n end;\r\nend;\r\n\r\nfunction StrSimpleEqualityCompareI(const Obj1, Obj2: string): Boolean;\r\nbegin\r\n case SizeOf(Obj1[1]) of\r\n SizeOf(AnsiChar):\r\n Result := CompareText(Obj1, Obj2) = 0;\r\n SizeOf(WideChar):\r\n Result := {$IFDEF HAS_UNITSCOPE}System.{$ENDIF}SysUtils.WideCompareText(Obj1, Obj2) = 0;\r\n else\r\n raise EJclOperationNotSupportedError.Create;\r\n end;\r\nend;\r\n\r\nfunction SingleSimpleEqualityCompare(const Obj1, Obj2: Single): Boolean;\r\nbegin\r\n Result := Obj1 = Obj2;\r\nend;\r\n\r\nfunction DoubleSimpleEqualityCompare(const Obj1, Obj2: Double): Boolean;\r\nbegin\r\n Result := Obj1 = Obj2;\r\nend;\r\n\r\nfunction ExtendedSimpleEqualityCompare(const Obj1, Obj2: Extended): Boolean;\r\nbegin\r\n Result := Obj1 = Obj2;\r\nend;\r\n\r\nfunction FloatSimpleEqualityCompare(const Obj1, Obj2: Float): Boolean;\r\nbegin\r\n Result := Obj1 = Obj2;\r\nend;\r\n\r\nfunction IntegerSimpleEqualityCompare(Obj1, Obj2: Integer): Boolean;\r\nbegin\r\n Result := Obj1 = Obj2;\r\nend;\r\n\r\nfunction CardinalSimpleEqualityCompare(Obj1, Obj2: Cardinal): Boolean;\r\nbegin\r\n Result := Obj1 = Obj2;\r\nend;\r\n\r\nfunction Int64SimpleEqualityCompare(const Obj1, Obj2: Int64): Boolean;\r\nbegin\r\n Result := Obj1 = Obj2;\r\nend;\r\n\r\nfunction PtrSimpleEqualityCompare(Obj1, Obj2: Pointer): Boolean;\r\nbegin\r\n Result := SizeInt(Obj1) = SizeInt(Obj2);\r\nend;\r\n\r\nfunction SimpleEqualityCompare(Obj1, Obj2: TObject): Boolean;\r\nbegin\r\n Result := SizeInt(Obj1) = SizeInt(Obj2);\r\nend;\r\n\r\nfunction IntfSimpleHashConvert(const AInterface: IInterface): Integer;\r\nbegin\r\n {$IFDEF CPU32}\r\n Result := SizeInt(AInterface) and MaxInt;\r\n {$ELSE ~CPU32}\r\n Result := (SizeInt(AInterface) xor (SizeInt(AInterface) shr 32)) and MaxInt;\r\n {$ENDIF ~CPU32}\r\nend;\r\n\r\n// from \"Fast Hashing of Variable-Length Text Strings\", Peter K. Pearson, 1990\r\n// http://portal.acm.org/citation.cfm?id=78978\r\ntype\r\n TIntegerHash = packed record\r\n case Byte of\r\n 0: (H1, H2, H3, H4: Byte);\r\n 1: (H: Integer);\r\n 2: (C: UCS4);\r\n end;\r\n\r\n// default is case-sensitive and ISO-encoded\r\nfunction AnsiStrSimpleHashConvert(const AString: AnsiString): Integer;\r\nvar\r\n I: Integer;\r\n C: Byte;\r\n IntegerHash: TIntegerHash;\r\nbegin\r\n IntegerHash.H1 := 0;\r\n IntegerHash.H2 := 1;\r\n IntegerHash.H3 := 2;\r\n IntegerHash.H4 := 3;\r\n for I := 1 to Length(AString) do\r\n begin\r\n C := Ord(AString[I]);\r\n IntegerHash.H1 := BytePermTable[IntegerHash.H1 xor C];\r\n IntegerHash.H2 := BytePermTable[IntegerHash.H2 xor C];\r\n IntegerHash.H3 := BytePermTable[IntegerHash.H3 xor C];\r\n IntegerHash.H4 := BytePermTable[IntegerHash.H4 xor C];\r\n end;\r\n Result := IntegerHash.H and MaxInt;\r\nend;\r\n\r\n// case-insensitive and ISO-encoded\r\nfunction AnsiStrSimpleHashConvertI(const AString: AnsiString): Integer;\r\nvar\r\n I: Integer;\r\n C: Byte;\r\n IntegerHash: TIntegerHash;\r\nbegin\r\n IntegerHash.H1 := 0;\r\n IntegerHash.H2 := 1;\r\n IntegerHash.H3 := 2;\r\n IntegerHash.H4 := 3;\r\n for I := 1 to Length(AString) - 1 do\r\n begin\r\n C := Ord(JclAnsiStrings.CharUpper(AString[I]));\r\n IntegerHash.H1 := BytePermTable[IntegerHash.H1 xor C];\r\n IntegerHash.H2 := BytePermTable[IntegerHash.H2 xor C];\r\n IntegerHash.H3 := BytePermTable[IntegerHash.H3 xor C];\r\n IntegerHash.H4 := BytePermTable[IntegerHash.H4 xor C];\r\n end;\r\n Result := IntegerHash.H and MaxInt;\r\nend;\r\n\r\n// case-sensitive and UTF8-encoded\r\nfunction AnsiStrSimpleHashConvertU(const AString: AnsiString): Integer;\r\nvar\r\n I: SizeInt;\r\n C, IntegerHash: TIntegerHash;\r\nbegin\r\n IntegerHash.H1 := 0;\r\n IntegerHash.H2 := 1;\r\n IntegerHash.H3 := 2;\r\n IntegerHash.H4 := 3;\r\n I := 1;\r\n while I < Length(AString) do\r\n begin\r\n C.C := UTF8GetNextChar(AString, I);\r\n if I = -1 then\r\n raise EJclUnexpectedEOSequenceError.Create;\r\n IntegerHash.H1 := BytePermTable[IntegerHash.H1 xor C.H1];\r\n IntegerHash.H2 := BytePermTable[IntegerHash.H2 xor C.H2];\r\n IntegerHash.H3 := BytePermTable[IntegerHash.H3 xor C.H3];\r\n IntegerHash.H4 := BytePermTable[IntegerHash.H4 xor C.H4];\r\n end;\r\n Result := IntegerHash.H and MaxInt;\r\nend;\r\n\r\n// case-insensitive and UTF8-encoded\r\nfunction AnsiStrSimpleHashConvertUI(const AString: AnsiString): Integer;\r\nvar\r\n I: SizeInt;\r\n J: Integer;\r\n C, IntegerHash: TIntegerHash;\r\n CA: TUCS4Array;\r\nbegin\r\n IntegerHash.H1 := 0;\r\n IntegerHash.H2 := 1;\r\n IntegerHash.H3 := 2;\r\n IntegerHash.H4 := 3;\r\n I := 1;\r\n {$IFDEF UNICODE_RTL_DATABASE}\r\n SetLength(CA, 1);\r\n {$ELSE ~UNICODE_RTL_DATABASE}\r\n SetLength(CA, 0);\r\n {$ENDIF ~UNICODE_RTL_DATABASE}\r\n while I < Length(AString) do\r\n begin\r\n C.C := UTF8GetNextChar(AString, I);\r\n {$IFDEF UNICODE_RTL_DATABASE}\r\n CA[0] := Ord(TCharacter.ToLower(Chr(C.C)));\r\n {$ELSE ~UNICODE_RTL_DATABASE}\r\n CA := UnicodeCaseFold(C.C);\r\n {$ENDIF ~UNICODE_RTL_DATABASE}\r\n for J := Low(CA) to High(CA) do\r\n begin\r\n C.C := CA[J];\r\n if I = -1 then\r\n raise EJclUnexpectedEOSequenceError.Create;\r\n IntegerHash.H1 := BytePermTable[IntegerHash.H1 xor C.H1];\r\n IntegerHash.H2 := BytePermTable[IntegerHash.H2 xor C.H2];\r\n IntegerHash.H3 := BytePermTable[IntegerHash.H3 xor C.H3];\r\n IntegerHash.H4 := BytePermTable[IntegerHash.H4 xor C.H4];\r\n end;\r\n end;\r\n Result := IntegerHash.H and MaxInt;\r\nend;\r\n\r\n// default is case-sensitive\r\nfunction WideStrSimpleHashConvert(const AString: WideString): Integer;\r\nvar\r\n I: SizeInt;\r\n C, IntegerHash: TIntegerHash;\r\nbegin\r\n IntegerHash.H1 := 0;\r\n IntegerHash.H2 := 1;\r\n IntegerHash.H3 := 2;\r\n IntegerHash.H4 := 3;\r\n I := 1;\r\n while I < Length(AString) do\r\n begin\r\n C.C := UTF16GetNextChar(AString, I);\r\n if I = -1 then\r\n raise EJclUnexpectedEOSequenceError.Create;\r\n IntegerHash.H1 := BytePermTable[IntegerHash.H1 xor C.H1];\r\n IntegerHash.H2 := BytePermTable[IntegerHash.H2 xor C.H2];\r\n IntegerHash.H3 := BytePermTable[IntegerHash.H3 xor C.H3];\r\n IntegerHash.H4 := BytePermTable[IntegerHash.H4 xor C.H4];\r\n end;\r\n Result := IntegerHash.H and MaxInt;\r\nend;\r\n\r\n// case-insensitive\r\nfunction WideStrSimpleHashConvertI(const AString: WideString): Integer;\r\nvar\r\n I: SizeInt;\r\n J: Integer;\r\n C, IntegerHash: TIntegerHash;\r\n CA: TUCS4Array;\r\nbegin\r\n IntegerHash.H1 := 0;\r\n IntegerHash.H2 := 1;\r\n IntegerHash.H3 := 2;\r\n IntegerHash.H4 := 3;\r\n {$IFDEF UNICODE_RTL_DATABASE}\r\n SetLength(CA, 1);\r\n {$ELSE ~UNICODE_RTL_DATABASE}\r\n SetLength(CA, 0);\r\n {$ENDIF ~UNICODE_RTL_DATABASE}\r\n I := 1;\r\n while I < Length(AString) do\r\n begin\r\n C.C := UTF16GetNextChar(AString, I);\r\n {$IFDEF UNICODE_RTL_DATABASE}\r\n CA[0] := Ord(TCharacter.ToLower(Chr(C.C)));\r\n {$ELSE ~UNICODE_RTL_DATABASE}\r\n CA := UnicodeCaseFold(C.C);\r\n {$ENDIF ~UNICODE_RTL_DATABASE}\r\n for J := Low(CA) to High(CA) do\r\n begin\r\n C.C := CA[J];\r\n if I = -1 then\r\n raise EJclUnexpectedEOSequenceError.Create;\r\n IntegerHash.H1 := BytePermTable[IntegerHash.H1 xor C.H1];\r\n IntegerHash.H2 := BytePermTable[IntegerHash.H2 xor C.H2];\r\n IntegerHash.H3 := BytePermTable[IntegerHash.H3 xor C.H3];\r\n IntegerHash.H4 := BytePermTable[IntegerHash.H4 xor C.H4];\r\n end;\r\n end;\r\n Result := IntegerHash.H and MaxInt;\r\nend;\r\n\r\n{$IFDEF SUPPORTS_UNICODE_STRING}\r\n// default is case-sensitive\r\nfunction UnicodeStrSimpleHashConvert(const AString: UnicodeString): Integer;\r\nvar\r\n I: SizeInt;\r\n C, IntegerHash: TIntegerHash;\r\nbegin\r\n IntegerHash.H1 := 0;\r\n IntegerHash.H2 := 1;\r\n IntegerHash.H3 := 2;\r\n IntegerHash.H4 := 3;\r\n I := 1;\r\n while I < Length(AString) do\r\n begin\r\n C.C := UTF16GetNextChar(AString, I);\r\n if I = -1 then\r\n raise EJclUnexpectedEOSequenceError.Create;\r\n IntegerHash.H1 := BytePermTable[IntegerHash.H1 xor C.H1];\r\n IntegerHash.H2 := BytePermTable[IntegerHash.H2 xor C.H2];\r\n IntegerHash.H3 := BytePermTable[IntegerHash.H3 xor C.H3];\r\n IntegerHash.H4 := BytePermTable[IntegerHash.H4 xor C.H4];\r\n end;\r\n Result := IntegerHash.H and MaxInt;\r\nend;\r\n\r\n// case-insensitive\r\nfunction UnicodeStrSimpleHashConvertI(const AString: UnicodeString): Integer;\r\nvar\r\n I: SizeInt;\r\n J: Integer;\r\n C, IntegerHash: TIntegerHash;\r\n CA: TUCS4Array;\r\nbegin\r\n IntegerHash.H1 := 0;\r\n IntegerHash.H2 := 1;\r\n IntegerHash.H3 := 2;\r\n IntegerHash.H4 := 3;\r\n {$IFDEF UNICODE_RTL_DATABASE}\r\n SetLength(CA, 1);\r\n {$ELSE ~UNICODE_RTL_DATABASE}\r\n SetLength(CA, 0);\r\n {$ENDIF ~UNICODE_RTL_DATABASE}\r\n I := 1;\r\n while I < Length(AString) do\r\n begin\r\n C.C := UTF16GetNextChar(AString, I);\r\n {$IFDEF UNICODE_RTL_DATABASE}\r\n CA[0] := Ord(TCharacter.ToLower(Chr(C.C)));\r\n {$ELSE ~UNICODE_RTL_DATABASE}\r\n CA := UnicodeCaseFold(C.C);\r\n {$ENDIF ~UNICODE_RTL_DATABASE}\r\n for J := Low(CA) to High(CA) do\r\n begin\r\n C.C := CA[J];\r\n if I = -1 then\r\n raise EJclUnexpectedEOSequenceError.Create;\r\n IntegerHash.H1 := BytePermTable[IntegerHash.H1 xor C.H1];\r\n IntegerHash.H2 := BytePermTable[IntegerHash.H2 xor C.H2];\r\n IntegerHash.H3 := BytePermTable[IntegerHash.H3 xor C.H3];\r\n IntegerHash.H4 := BytePermTable[IntegerHash.H4 xor C.H4];\r\n end;\r\n end;\r\n Result := IntegerHash.H and MaxInt;\r\nend;\r\n{$ENDIF SUPPORTS_UNICODE_STRING}\r\n\r\nfunction StrSimpleHashConvert(const AString: string): Integer;\r\nbegin\r\n {$IFDEF SUPPORTS_UNICODE}\r\n {$IFDEF SUPPORTS_UNICODE_STRING}\r\n Result := UnicodeStrSimpleHashConvert(AString);\r\n {$ELSE ~SUPPORTS_UNICODE_STRING}\r\n Result := WideStrSimpleHashConvert(AString);\r\n {$ENDIF ~SUPPORTS_UNICODE_STRING}\r\n {$ELSE ~SUPPORTS_UNICODE}\r\n Result := AnsiStrSimpleHashConvert(AString);\r\n {$ENDIF ~SUPPORTS_UNICODE}\r\nend;\r\n\r\nfunction StrSimpleHashConvertI(const AString: string): Integer;\r\nbegin\r\n {$IFDEF SUPPORTS_UNICODE}\r\n {$IFDEF SUPPORTS_UNICODE_STRING}\r\n Result := UnicodeStrSimpleHashConvertI(AString);\r\n {$ELSE ~SUPPORTS_UNICODE_STRING}\r\n Result := WideStrSimpleHashConvertI(AString);\r\n {$ENDIF ~SUPPORTS_UNICODE_STRING}\r\n {$ELSE ~SUPPORTS_UNICODE}\r\n Result := AnsiStrSimpleHashConvertI(AString);\r\n {$ENDIF ~SUPPORTS_UNICODE}\r\nend;\r\n\r\nfunction SingleSimpleHashConvert(const AValue: Single): Integer;\r\nconst\r\n A = 0.6180339887; // (sqrt(5) - 1) / 2\r\nbegin\r\n Result := Round(MaxInt * Frac(AValue * A));\r\nend;\r\n\r\nfunction DoubleSimpleHashConvert(const AValue: Double): Integer;\r\nconst\r\n A = 0.6180339887; // (sqrt(5) - 1) / 2\r\nbegin\r\n Result := Round(MaxInt * Frac(AValue * A));\r\nend;\r\n\r\nfunction ExtendedSimpleHashConvert(const AValue: Extended): Integer;\r\nconst\r\n A = 0.6180339887; // (sqrt(5) - 1) / 2\r\nbegin\r\n Result := Round(MaxInt * Frac(AValue * A));\r\nend;\r\n\r\nfunction FloatSimpleHashConvert(const AValue: Float): Integer;\r\nconst\r\n A = 0.6180339887; // (sqrt(5) - 1) / 2\r\nbegin\r\n Result := Round(MaxInt * Frac(AValue * A));\r\nend;\r\n\r\nfunction IntegerSimpleHashConvert(AValue: Integer): Integer;\r\nbegin\r\n Result := AValue and MaxInt;\r\nend;\r\n\r\nfunction CardinalSimpleHashConvert(AValue: Cardinal): Integer;\r\nbegin\r\n Result := AValue and MaxInt;\r\nend;\r\n\r\nfunction Int64SimpleHashConvert(const AValue: Int64): Integer;\r\nbegin\r\n Result := (AValue xor (AValue shr 32)) and MaxInt;\r\nend;\r\n\r\nfunction PtrSimpleHashConvert(APtr: Pointer): Integer;\r\nbegin\r\n Result := SizeInt(APtr) and MaxInt;\r\nend;\r\n\r\nfunction SimpleHashConvert(AObject: TObject): Integer;\r\nbegin\r\n Result := SizeInt(AObject) and MaxInt;\r\nend;\r\n\r\nfunction JclSimpleHashToRange(Key, Range: Integer): Integer;\r\n// return a value between 0 and (Range-1) based on integer-hash Key\r\nconst\r\n A = 0.6180339887; // (sqrt(5) - 1) / 2\r\nbegin\r\n Result := Trunc(Range * (Frac(Abs(Key * A))));\r\nend;\r\n\r\nprocedure FinalizeArrayBeforeMove(var List: TDynIInterfaceArray; FromIndex, ToIndex, Count: SizeInt); overload;\r\nbegin\r\n Assert(Count > 0);\r\n if FromIndex < ToIndex then\r\n begin\r\n if Count > (ToIndex - FromIndex) then\r\n Finalize(List[FromIndex + Count], ToIndex - FromIndex)\r\n else\r\n Finalize(List[ToIndex], Count);\r\n end\r\n else\r\n if FromIndex > ToIndex then\r\n begin\r\n if Count > (FromIndex - ToIndex) then\r\n Count := FromIndex - ToIndex;\r\n Finalize(List[ToIndex], Count)\r\n end;\r\nend;\r\n\r\nprocedure InitializeArray(var List: TDynIInterfaceArray; FromIndex, Count: SizeInt); overload;\r\nbegin\r\n {$IFDEF FPC}\r\n while Count > 0 do\r\n begin\r\n Initialize(List[FromIndex]);\r\n Inc(FromIndex);\r\n Dec(Count);\r\n end;\r\n {$ELSE ~FPC}\r\n Initialize(List[FromIndex], Count);\r\n {$ENDIF ~FPC}\r\nend;\r\n\r\nprocedure InitializeArrayAfterMove(var List: TDynIInterfaceArray; FromIndex, ToIndex, Count: SizeInt); overload;\r\nbegin\r\n { Keep reference counting working }\r\n if FromIndex < ToIndex then\r\n begin\r\n if (ToIndex - FromIndex) < Count then\r\n Count := ToIndex - FromIndex;\r\n InitializeArray(List, FromIndex, Count);\r\n end\r\n else\r\n if FromIndex > ToIndex then\r\n begin\r\n if (FromIndex - ToIndex) < Count then\r\n InitializeArray(List, ToIndex + Count, FromIndex - ToIndex)\r\n else\r\n InitializeArray(List, FromIndex, Count);\r\n end;\r\nend;\r\n\r\nprocedure MoveArray(var List: TDynIInterfaceArray; FromIndex, ToIndex, Count: SizeInt); overload;\r\nbegin\r\n if Count > 0 then\r\n begin\r\n FinalizeArrayBeforeMove(List, FromIndex, ToIndex, Count);\r\n Move(List[FromIndex], List[ToIndex], Count * SizeOf(List[0]));\r\n InitializeArrayAfterMove(List, FromIndex, ToIndex, Count);\r\n end;\r\nend;\r\n\r\nprocedure FinalizeArrayBeforeMove(var List: TDynAnsiStringArray; FromIndex, ToIndex, Count: SizeInt); overload;\r\nbegin\r\n Assert(Count > 0);\r\n if FromIndex < ToIndex then\r\n begin\r\n if Count > (ToIndex - FromIndex) then\r\n Finalize(List[FromIndex + Count], ToIndex - FromIndex)\r\n else\r\n Finalize(List[ToIndex], Count);\r\n end\r\n else\r\n if FromIndex > ToIndex then\r\n begin\r\n if Count > (FromIndex - ToIndex) then\r\n Count := FromIndex - ToIndex;\r\n Finalize(List[ToIndex], Count)\r\n end;\r\nend;\r\n\r\nprocedure InitializeArray(var List: TDynAnsiStringArray; FromIndex, Count: SizeInt); overload;\r\nbegin\r\n {$IFDEF FPC}\r\n while Count > 0 do\r\n begin\r\n Initialize(List[FromIndex]);\r\n Inc(FromIndex);\r\n Dec(Count);\r\n end;\r\n {$ELSE ~FPC}\r\n Initialize(List[FromIndex], Count);\r\n {$ENDIF ~FPC}\r\nend;\r\n\r\nprocedure InitializeArrayAfterMove(var List: TDynAnsiStringArray; FromIndex, ToIndex, Count: SizeInt); overload;\r\nbegin\r\n { Keep reference counting working }\r\n if FromIndex < ToIndex then\r\n begin\r\n if (ToIndex - FromIndex) < Count then\r\n Count := ToIndex - FromIndex;\r\n InitializeArray(List, FromIndex, Count);\r\n end\r\n else\r\n if FromIndex > ToIndex then\r\n begin\r\n if (FromIndex - ToIndex) < Count then\r\n InitializeArray(List, ToIndex + Count, FromIndex - ToIndex)\r\n else\r\n InitializeArray(List, FromIndex, Count);\r\n end;\r\nend;\r\n\r\nprocedure MoveArray(var List: TDynAnsiStringArray; FromIndex, ToIndex, Count: SizeInt); overload;\r\nbegin\r\n if Count > 0 then\r\n begin\r\n FinalizeArrayBeforeMove(List, FromIndex, ToIndex, Count);\r\n Move(List[FromIndex], List[ToIndex], Count * SizeOf(List[0]));\r\n InitializeArrayAfterMove(List, FromIndex, ToIndex, Count);\r\n end;\r\nend;\r\n\r\nprocedure FinalizeArrayBeforeMove(var List: TDynWideStringArray; FromIndex, ToIndex, Count: SizeInt); overload;\r\nbegin\r\n Assert(Count > 0);\r\n if FromIndex < ToIndex then\r\n begin\r\n if Count > (ToIndex - FromIndex) then\r\n Finalize(List[FromIndex + Count], ToIndex - FromIndex)\r\n else\r\n Finalize(List[ToIndex], Count);\r\n end\r\n else\r\n if FromIndex > ToIndex then\r\n begin\r\n if Count > (FromIndex - ToIndex) then\r\n Count := FromIndex - ToIndex;\r\n Finalize(List[ToIndex], Count)\r\n end;\r\nend;\r\n\r\nprocedure InitializeArray(var List: TDynWideStringArray; FromIndex, Count: SizeInt); overload;\r\nbegin\r\n {$IFDEF FPC}\r\n while Count > 0 do\r\n begin\r\n Initialize(List[FromIndex]);\r\n Inc(FromIndex);\r\n Dec(Count);\r\n end;\r\n {$ELSE ~FPC}\r\n Initialize(List[FromIndex], Count);\r\n {$ENDIF ~FPC}\r\nend;\r\n\r\nprocedure InitializeArrayAfterMove(var List: TDynWideStringArray; FromIndex, ToIndex, Count: SizeInt); overload;\r\nbegin\r\n { Keep reference counting working }\r\n if FromIndex < ToIndex then\r\n begin\r\n if (ToIndex - FromIndex) < Count then\r\n Count := ToIndex - FromIndex;\r\n InitializeArray(List, FromIndex, Count);\r\n end\r\n else\r\n if FromIndex > ToIndex then\r\n begin\r\n if (FromIndex - ToIndex) < Count then\r\n InitializeArray(List, ToIndex + Count, FromIndex - ToIndex)\r\n else\r\n InitializeArray(List, FromIndex, Count);\r\n end;\r\nend;\r\n\r\nprocedure MoveArray(var List: TDynWideStringArray; FromIndex, ToIndex, Count: SizeInt); overload;\r\nbegin\r\n if Count > 0 then\r\n begin\r\n FinalizeArrayBeforeMove(List, FromIndex, ToIndex, Count);\r\n Move(List[FromIndex], List[ToIndex], Count * SizeOf(List[0]));\r\n InitializeArrayAfterMove(List, FromIndex, ToIndex, Count);\r\n end;\r\nend;\r\n\r\n{$IFDEF SUPPORTS_UNICODE_STRING}\r\n\r\nprocedure FinalizeArrayBeforeMove(var List: TDynUnicodeStringArray; FromIndex, ToIndex, Count: SizeInt); overload;\r\nbegin\r\n Assert(Count > 0);\r\n if FromIndex < ToIndex then\r\n begin\r\n if Count > (ToIndex - FromIndex) then\r\n Finalize(List[FromIndex + Count], ToIndex - FromIndex)\r\n else\r\n Finalize(List[ToIndex], Count);\r\n end\r\n else\r\n if FromIndex > ToIndex then\r\n begin\r\n if Count > (FromIndex - ToIndex) then\r\n Count := FromIndex - ToIndex;\r\n Finalize(List[ToIndex], Count)\r\n end;\r\nend;\r\n\r\nprocedure InitializeArray(var List: TDynUnicodeStringArray; FromIndex, Count: SizeInt); overload;\r\nbegin\r\n {$IFDEF FPC}\r\n while Count > 0 do\r\n begin\r\n Initialize(List[FromIndex]);\r\n Inc(FromIndex);\r\n Dec(Count);\r\n end;\r\n {$ELSE ~FPC}\r\n Initialize(List[FromIndex], Count);\r\n {$ENDIF ~FPC}\r\nend;\r\n\r\nprocedure InitializeArrayAfterMove(var List: TDynUnicodeStringArray; FromIndex, ToIndex, Count: SizeInt); overload;\r\nbegin\r\n { Keep reference counting working }\r\n if FromIndex < ToIndex then\r\n begin\r\n if (ToIndex - FromIndex) < Count then\r\n Count := ToIndex - FromIndex;\r\n InitializeArray(List, FromIndex, Count);\r\n end\r\n else\r\n if FromIndex > ToIndex then\r\n begin\r\n if (FromIndex - ToIndex) < Count then\r\n InitializeArray(List, ToIndex + Count, FromIndex - ToIndex)\r\n else\r\n InitializeArray(List, FromIndex, Count);\r\n end;\r\nend;\r\n\r\nprocedure MoveArray(var List: TDynUnicodeStringArray; FromIndex, ToIndex, Count: SizeInt); overload;\r\nbegin\r\n if Count > 0 then\r\n begin\r\n FinalizeArrayBeforeMove(List, FromIndex, ToIndex, Count);\r\n Move(List[FromIndex], List[ToIndex], Count * SizeOf(List[0]));\r\n InitializeArrayAfterMove(List, FromIndex, ToIndex, Count);\r\n end;\r\nend;\r\n{$ENDIF SUPPORTS_UNICODE_STRING}\r\n\r\nprocedure InitializeArrayAfterMove(var List: TDynSingleArray; FromIndex, ToIndex, Count: SizeInt); overload;\r\nbegin\r\n { Clean array }\r\n if FromIndex < ToIndex then\r\n begin\r\n if (ToIndex - FromIndex) < Count then\r\n Count := ToIndex - FromIndex;\r\n FillChar(List[FromIndex], Count * SizeOf(List[0]), 0);\r\n end\r\n else\r\n if FromIndex > ToIndex then\r\n begin\r\n if (FromIndex - ToIndex) < Count then\r\n FillChar(List[ToIndex + Count], (FromIndex - ToIndex) * SizeOf(List[0]), 0)\r\n else\r\n FillChar(List[FromIndex], Count * SizeOf(List[0]), 0);\r\n end;\r\nend;\r\n\r\nprocedure MoveArray(var List: TDynSingleArray; FromIndex, ToIndex, Count: SizeInt); overload;\r\nbegin\r\n if Count > 0 then\r\n begin\r\n Move(List[FromIndex], List[ToIndex], Count * SizeOf(List[0]));\r\n InitializeArrayAfterMove(List, FromIndex, ToIndex, Count);\r\n end;\r\nend;\r\n\r\nprocedure InitializeArrayAfterMove(var List: TDynDoubleArray; FromIndex, ToIndex, Count: SizeInt); overload;\r\nbegin\r\n { Clean array }\r\n if FromIndex < ToIndex then\r\n begin\r\n if (ToIndex - FromIndex) < Count then\r\n Count := ToIndex - FromIndex;\r\n FillChar(List[FromIndex], Count * SizeOf(List[0]), 0);\r\n end\r\n else\r\n if FromIndex > ToIndex then\r\n begin\r\n if (FromIndex - ToIndex) < Count then\r\n FillChar(List[ToIndex + Count], (FromIndex - ToIndex) * SizeOf(List[0]), 0)\r\n else\r\n FillChar(List[FromIndex], Count * SizeOf(List[0]), 0);\r\n end;\r\nend;\r\n\r\nprocedure MoveArray(var List: TDynDoubleArray; FromIndex, ToIndex, Count: SizeInt); overload;\r\nbegin\r\n if Count > 0 then\r\n begin\r\n Move(List[FromIndex], List[ToIndex], Count * SizeOf(List[0]));\r\n InitializeArrayAfterMove(List, FromIndex, ToIndex, Count);\r\n end;\r\nend;\r\n\r\nprocedure InitializeArrayAfterMove(var List: TDynExtendedArray; FromIndex, ToIndex, Count: SizeInt); overload;\r\nbegin\r\n { Clean array }\r\n if FromIndex < ToIndex then\r\n begin\r\n if (ToIndex - FromIndex) < Count then\r\n Count := ToIndex - FromIndex;\r\n FillChar(List[FromIndex], Count * SizeOf(List[0]), 0);\r\n end\r\n else\r\n if FromIndex > ToIndex then\r\n begin\r\n if (FromIndex - ToIndex) < Count then\r\n FillChar(List[ToIndex + Count], (FromIndex - ToIndex) * SizeOf(List[0]), 0)\r\n else\r\n FillChar(List[FromIndex], Count * SizeOf(List[0]), 0);\r\n end;\r\nend;\r\n\r\nprocedure MoveArray(var List: TDynExtendedArray; FromIndex, ToIndex, Count: SizeInt); overload;\r\nbegin\r\n if Count > 0 then\r\n begin\r\n Move(List[FromIndex], List[ToIndex], Count * SizeOf(List[0]));\r\n InitializeArrayAfterMove(List, FromIndex, ToIndex, Count);\r\n end;\r\nend;\r\n\r\nprocedure InitializeArrayAfterMove(var List: TDynIntegerArray; FromIndex, ToIndex, Count: SizeInt); overload;\r\nbegin\r\n { Clean array }\r\n if FromIndex < ToIndex then\r\n begin\r\n if (ToIndex - FromIndex) < Count then\r\n Count := ToIndex - FromIndex;\r\n FillChar(List[FromIndex], Count * SizeOf(List[0]), 0);\r\n end\r\n else\r\n if FromIndex > ToIndex then\r\n begin\r\n if (FromIndex - ToIndex) < Count then\r\n FillChar(List[ToIndex + Count], (FromIndex - ToIndex) * SizeOf(List[0]), 0)\r\n else\r\n FillChar(List[FromIndex], Count * SizeOf(List[0]), 0);\r\n end;\r\nend;\r\n\r\nprocedure MoveArray(var List: TDynIntegerArray; FromIndex, ToIndex, Count: SizeInt); overload;\r\nbegin\r\n if Count > 0 then\r\n begin\r\n Move(List[FromIndex], List[ToIndex], Count * SizeOf(List[0]));\r\n InitializeArrayAfterMove(List, FromIndex, ToIndex, Count);\r\n end;\r\nend;\r\n\r\nprocedure InitializeArrayAfterMove(var List: TDynCardinalArray; FromIndex, ToIndex, Count: SizeInt); overload;\r\nbegin\r\n { Clean array }\r\n if FromIndex < ToIndex then\r\n begin\r\n if (ToIndex - FromIndex) < Count then\r\n Count := ToIndex - FromIndex;\r\n FillChar(List[FromIndex], Count * SizeOf(List[0]), 0);\r\n end\r\n else\r\n if FromIndex > ToIndex then\r\n begin\r\n if (FromIndex - ToIndex) < Count then\r\n FillChar(List[ToIndex + Count], (FromIndex - ToIndex) * SizeOf(List[0]), 0)\r\n else\r\n FillChar(List[FromIndex], Count * SizeOf(List[0]), 0);\r\n end;\r\nend;\r\n\r\nprocedure MoveArray(var List: TDynCardinalArray; FromIndex, ToIndex, Count: SizeInt); overload;\r\nbegin\r\n if Count > 0 then\r\n begin\r\n Move(List[FromIndex], List[ToIndex], Count * SizeOf(List[0]));\r\n InitializeArrayAfterMove(List, FromIndex, ToIndex, Count);\r\n end;\r\nend;\r\n\r\nprocedure InitializeArrayAfterMove(var List: TDynInt64Array; FromIndex, ToIndex, Count: SizeInt); overload;\r\nbegin\r\n { Clean array }\r\n if FromIndex < ToIndex then\r\n begin\r\n if (ToIndex - FromIndex) < Count then\r\n Count := ToIndex - FromIndex;\r\n FillChar(List[FromIndex], Count * SizeOf(List[0]), 0);\r\n end\r\n else\r\n if FromIndex > ToIndex then\r\n begin\r\n if (FromIndex - ToIndex) < Count then\r\n FillChar(List[ToIndex + Count], (FromIndex - ToIndex) * SizeOf(List[0]), 0)\r\n else\r\n FillChar(List[FromIndex], Count * SizeOf(List[0]), 0);\r\n end;\r\nend;\r\n\r\nprocedure MoveArray(var List: TDynInt64Array; FromIndex, ToIndex, Count: SizeInt); overload;\r\nbegin\r\n if Count > 0 then\r\n begin\r\n Move(List[FromIndex], List[ToIndex], Count * SizeOf(List[0]));\r\n InitializeArrayAfterMove(List, FromIndex, ToIndex, Count);\r\n end;\r\nend;\r\n\r\nprocedure InitializeArrayAfterMove(var List: TDynPointerArray; FromIndex, ToIndex, Count: SizeInt); overload;\r\nbegin\r\n { Clean array }\r\n if FromIndex < ToIndex then\r\n begin\r\n if (ToIndex - FromIndex) < Count then\r\n Count := ToIndex - FromIndex;\r\n FillChar(List[FromIndex], Count * SizeOf(List[0]), 0);\r\n end\r\n else\r\n if FromIndex > ToIndex then\r\n begin\r\n if (FromIndex - ToIndex) < Count then\r\n FillChar(List[ToIndex + Count], (FromIndex - ToIndex) * SizeOf(List[0]), 0)\r\n else\r\n FillChar(List[FromIndex], Count * SizeOf(List[0]), 0);\r\n end;\r\nend;\r\n\r\nprocedure MoveArray(var List: TDynPointerArray; FromIndex, ToIndex, Count: SizeInt); overload;\r\nbegin\r\n if Count > 0 then\r\n begin\r\n Move(List[FromIndex], List[ToIndex], Count * SizeOf(List[0]));\r\n InitializeArrayAfterMove(List, FromIndex, ToIndex, Count);\r\n end;\r\nend;\r\n\r\nprocedure InitializeArrayAfterMove(var List: TDynObjectArray; FromIndex, ToIndex, Count: SizeInt); overload;\r\nbegin\r\n { Clean array }\r\n if FromIndex < ToIndex then\r\n begin\r\n if (ToIndex - FromIndex) < Count then\r\n Count := ToIndex - FromIndex;\r\n FillChar(List[FromIndex], Count * SizeOf(List[0]), 0);\r\n end\r\n else\r\n if FromIndex > ToIndex then\r\n begin\r\n if (FromIndex - ToIndex) < Count then\r\n FillChar(List[ToIndex + Count], (FromIndex - ToIndex) * SizeOf(List[0]), 0)\r\n else\r\n FillChar(List[FromIndex], Count * SizeOf(List[0]), 0);\r\n end;\r\nend;\r\n\r\nprocedure MoveArray(var List: TDynObjectArray; FromIndex, ToIndex, Count: SizeInt); overload;\r\nbegin\r\n if Count > 0 then\r\n begin\r\n Move(List[FromIndex], List[ToIndex], Count * SizeOf(List[0]));\r\n InitializeArrayAfterMove(List, FromIndex, ToIndex, Count);\r\n end;\r\nend;\r\n\r\n\r\nprocedure InitializeArrayAfterMove(var List: TDynSizeIntArray; FromIndex, ToIndex, Count: SizeInt); overload;\r\nbegin\r\n { Clean array }\r\n if FromIndex < ToIndex then\r\n begin\r\n if (ToIndex - FromIndex) < Count then\r\n Count := ToIndex - FromIndex;\r\n FillChar(List[FromIndex], Count * SizeOf(List[0]), 0);\r\n end\r\n else\r\n if FromIndex > ToIndex then\r\n begin\r\n if (FromIndex - ToIndex) < Count then\r\n FillChar(List[ToIndex + Count], (FromIndex - ToIndex) * SizeOf(List[0]), 0)\r\n else\r\n FillChar(List[FromIndex], Count * SizeOf(List[0]), 0);\r\n end;\r\nend;\r\n\r\nprocedure MoveArray(var List: TDynSizeIntArray; FromIndex, ToIndex, Count: SizeInt); overload;\r\nbegin\r\n if Count > 0 then\r\n begin\r\n Move(List[FromIndex], List[ToIndex], Count * SizeOf(List[0]));\r\n InitializeArrayAfterMove(List, FromIndex, ToIndex, Count);\r\n end;\r\nend;\r\n\r\n{$IFNDEF FPC}\r\nprocedure FinalizeArrayBeforeMove(var List: TDynStringArray; FromIndex, ToIndex, Count: SizeInt); overload;\r\nbegin\r\n Assert(Count > 0);\r\n if FromIndex < ToIndex then\r\n begin\r\n if Count > (ToIndex - FromIndex) then\r\n Finalize(List[FromIndex + Count], ToIndex - FromIndex)\r\n else\r\n Finalize(List[ToIndex], Count);\r\n end\r\n else\r\n if FromIndex > ToIndex then\r\n begin\r\n if Count > (FromIndex - ToIndex) then\r\n Count := FromIndex - ToIndex;\r\n Finalize(List[ToIndex], Count)\r\n end;\r\nend;\r\n\r\nprocedure InitializeArray(var List: TDynStringArray; FromIndex, Count: SizeInt); overload;\r\nbegin\r\n\r\n Initialize(List[FromIndex], Count);\r\nend;\r\n\r\nprocedure InitializeArrayAfterMove(var List: TDynStringArray; FromIndex, ToIndex, Count: SizeInt); overload;\r\nbegin\r\n { Keep reference counting working }\r\n if FromIndex < ToIndex then\r\n begin\r\n if (ToIndex - FromIndex) < Count then\r\n Count := ToIndex - FromIndex;\r\n InitializeArray(List, FromIndex, Count);\r\n end\r\n else\r\n if FromIndex > ToIndex then\r\n begin\r\n if (FromIndex - ToIndex) < Count then\r\n InitializeArray(List, ToIndex + Count, FromIndex - ToIndex)\r\n else\r\n InitializeArray(List, FromIndex, Count);\r\n end;\r\nend;\r\n\r\nprocedure MoveArray(var List: TDynStringArray; FromIndex, ToIndex, Count: SizeInt); overload;\r\nbegin\r\n if Count > 0 then\r\n begin\r\n FinalizeArrayBeforeMove(List, FromIndex, ToIndex, Count);\r\n Move(List[FromIndex], List[ToIndex], Count * SizeOf(List[0]));\r\n InitializeArrayAfterMove(List, FromIndex, ToIndex, Count);\r\n end;\r\nend;\r\n\r\nprocedure InitializeArrayAfterMove(var List: TDynFloatArray; FromIndex, ToIndex, Count: SizeInt); overload;\r\nbegin\r\n { Clean array }\r\n if FromIndex < ToIndex then\r\n begin\r\n if (ToIndex - FromIndex) < Count then\r\n Count := ToIndex - FromIndex;\r\n FillChar(List[FromIndex], Count * SizeOf(List[0]), 0);\r\n end\r\n else\r\n if FromIndex > ToIndex then\r\n begin\r\n if (FromIndex - ToIndex) < Count then\r\n FillChar(List[ToIndex + Count], (FromIndex - ToIndex) * SizeOf(List[0]), 0)\r\n else\r\n FillChar(List[FromIndex], Count * SizeOf(List[0]), 0);\r\n end;\r\nend;\r\n\r\nprocedure MoveArray(var List: TDynFloatArray; FromIndex, ToIndex, Count: SizeInt); overload;\r\nbegin\r\n if Count > 0 then\r\n begin\r\n Move(List[FromIndex], List[ToIndex], Count * SizeOf(List[0]));\r\n InitializeArrayAfterMove(List, FromIndex, ToIndex, Count);\r\n end;\r\nend;\r\n{$ENDIF ~FPC}\r\n\r\nprocedure Iterate(const First: IJclIntfIterator; Count: Integer; F: TIntfIterateProcedure);\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := Count - 1 downto 0 do\r\n if First.HasNext then\r\n F(First.Next)\r\n else\r\n Break;\r\nend;\r\n\r\nprocedure Iterate(const First: IJclAnsiStrIterator; Count: Integer; F: TAnsiStrIterateProcedure);\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := Count - 1 downto 0 do\r\n if First.HasNext then\r\n F(First.Next)\r\n else\r\n Break;\r\nend;\r\n\r\nprocedure Iterate(const First: IJclWideStrIterator; Count: Integer; F: TWideStrIterateProcedure);\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := Count - 1 downto 0 do\r\n if First.HasNext then\r\n F(First.Next)\r\n else\r\n Break;\r\nend;\r\n\r\n{$IFDEF SUPPORTS_UNICODE_STRING}\r\nprocedure Iterate(const First: IJclUnicodeStrIterator; Count: Integer; F: TUnicodeStrIterateProcedure);\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := Count - 1 downto 0 do\r\n if First.HasNext then\r\n F(First.Next)\r\n else\r\n Break;\r\nend;\r\n{$ENDIF SUPPORTS_UNICODE_STRING}\r\n\r\nprocedure Iterate(const First: IJclSingleIterator; Count: Integer; F: TSingleIterateProcedure);\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := Count - 1 downto 0 do\r\n if First.HasNext then\r\n F(First.Next)\r\n else\r\n Break;\r\nend;\r\n\r\nprocedure Iterate(const First: IJclDoubleIterator; Count: Integer; F: TDoubleIterateProcedure);\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := Count - 1 downto 0 do\r\n if First.HasNext then\r\n F(First.Next)\r\n else\r\n Break;\r\nend;\r\n\r\nprocedure Iterate(const First: IJclExtendedIterator; Count: Integer; F: TExtendedIterateProcedure);\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := Count - 1 downto 0 do\r\n if First.HasNext then\r\n F(First.Next)\r\n else\r\n Break;\r\nend;\r\n\r\nprocedure Iterate(const First: IJclIntegerIterator; Count: Integer; F: TIntegerIterateProcedure);\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := Count - 1 downto 0 do\r\n if First.HasNext then\r\n F(First.Next)\r\n else\r\n Break;\r\nend;\r\n\r\nprocedure Iterate(const First: IJclCardinalIterator; Count: Integer; F: TCardinalIterateProcedure);\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := Count - 1 downto 0 do\r\n if First.HasNext then\r\n F(First.Next)\r\n else\r\n Break;\r\nend;\r\n\r\nprocedure Iterate(const First: IJclInt64Iterator; Count: Integer; F: TInt64IterateProcedure);\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := Count - 1 downto 0 do\r\n if First.HasNext then\r\n F(First.Next)\r\n else\r\n Break;\r\nend;\r\n\r\nprocedure Iterate(const First: IJclPtrIterator; Count: Integer; F: TPtrIterateProcedure);\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := Count - 1 downto 0 do\r\n if First.HasNext then\r\n F(First.Next)\r\n else\r\n Break;\r\nend;\r\n\r\nprocedure Iterate(const First: IJclIterator; Count: Integer; F: TIterateProcedure);\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := Count - 1 downto 0 do\r\n if First.HasNext then\r\n F(First.Next)\r\n else\r\n Break;\r\nend;\r\n\r\n\r\nprocedure Apply(const First: IJclIntfIterator; Count: Integer; F: TIntfApplyFunction);\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := Count - 1 downto 0 do\r\n if First.HasNext then\r\n First.SetObject(F(First.Next))\r\n else\r\n Break;\r\nend;\r\n\r\nprocedure Apply(const First: IJclAnsiStrIterator; Count: Integer; F: TAnsiStrApplyFunction);\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := Count - 1 downto 0 do\r\n if First.HasNext then\r\n First.SetString(F(First.Next))\r\n else\r\n Break;\r\nend;\r\n\r\nprocedure Apply(const First: IJclWideStrIterator; Count: Integer; F: TWideStrApplyFunction);\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := Count - 1 downto 0 do\r\n if First.HasNext then\r\n First.SetString(F(First.Next))\r\n else\r\n Break;\r\nend;\r\n\r\n{$IFDEF SUPPORTS_UNICODE_STRING}\r\nprocedure Apply(const First: IJclUnicodeStrIterator; Count: Integer; F: TUnicodeStrApplyFunction);\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := Count - 1 downto 0 do\r\n if First.HasNext then\r\n First.SetString(F(First.Next))\r\n else\r\n Break;\r\nend;\r\n{$ENDIF SUPPORTS_UNICODE_STRING}\r\n\r\nprocedure Apply(const First: IJclSingleIterator; Count: Integer; F: TSingleApplyFunction);\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := Count - 1 downto 0 do\r\n if First.HasNext then\r\n First.SetValue(F(First.Next))\r\n else\r\n Break;\r\nend;\r\n\r\nprocedure Apply(const First: IJclDoubleIterator; Count: Integer; F: TDoubleApplyFunction);\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := Count - 1 downto 0 do\r\n if First.HasNext then\r\n First.SetValue(F(First.Next))\r\n else\r\n Break;\r\nend;\r\n\r\nprocedure Apply(const First: IJclExtendedIterator; Count: Integer; F: TExtendedApplyFunction);\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := Count - 1 downto 0 do\r\n if First.HasNext then\r\n First.SetValue(F(First.Next))\r\n else\r\n Break;\r\nend;\r\n\r\nprocedure Apply(const First: IJclIntegerIterator; Count: Integer; F: TIntegerApplyFunction);\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := Count - 1 downto 0 do\r\n if First.HasNext then\r\n First.SetValue(F(First.Next))\r\n else\r\n Break;\r\nend;\r\n\r\nprocedure Apply(const First: IJclCardinalIterator; Count: Integer; F: TCardinalApplyFunction);\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := Count - 1 downto 0 do\r\n if First.HasNext then\r\n First.SetValue(F(First.Next))\r\n else\r\n Break;\r\nend;\r\n\r\nprocedure Apply(const First: IJclInt64Iterator; Count: Integer; F: TInt64ApplyFunction);\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := Count - 1 downto 0 do\r\n if First.HasNext then\r\n First.SetValue(F(First.Next))\r\n else\r\n Break;\r\nend;\r\n\r\nprocedure Apply(const First: IJclPtrIterator; Count: Integer; F: TPtrApplyFunction);\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := Count - 1 downto 0 do\r\n if First.HasNext then\r\n First.SetPointer(F(First.Next))\r\n else\r\n Break;\r\nend;\r\n\r\nprocedure Apply(const First: IJclIterator; Count: Integer; F: TApplyFunction);\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := Count - 1 downto 0 do\r\n if First.HasNext then\r\n First.SetObject(F(First.Next))\r\n else\r\n Break;\r\nend;\r\n\r\n\r\nfunction Find(const First: IJclIntfIterator; Count: Integer;\r\n const AInterface: IInterface; AComparator: TIntfCompare): IJclIntfIterator;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := nil;\r\n for I := Count - 1 downto 0 do\r\n if First.HasNext then\r\n begin\r\n if AComparator(First.Next, AInterface) = 0 then\r\n begin\r\n Result := First;\r\n Break;\r\n end;\r\n end\r\n else\r\n Break;\r\nend;\r\n\r\nfunction Find(const First: IJclIntfIterator; Count: Integer;\r\n const AInterface: IInterface; AEqualityComparator: TIntfEqualityCompare): IJclIntfIterator;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := nil;\r\n for I := Count - 1 downto 0 do\r\n if First.HasNext then\r\n begin\r\n if AEqualityComparator(First.Next, AInterface) then\r\n begin\r\n Result := First;\r\n Break;\r\n end;\r\n end\r\n else\r\n Break;\r\nend;\r\n\r\nfunction Find(const First: IJclAnsiStrIterator; Count: Integer;\r\n const AString: AnsiString; AComparator: TAnsiStrCompare): IJclAnsiStrIterator;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := nil;\r\n for I := Count - 1 downto 0 do\r\n if First.HasNext then\r\n begin\r\n if AComparator(First.Next, AString) = 0 then\r\n begin\r\n Result := First;\r\n Break;\r\n end;\r\n end\r\n else\r\n Break;\r\nend;\r\n\r\nfunction Find(const First: IJclAnsiStrIterator; Count: Integer;\r\n const AString: AnsiString; AEqualityComparator: TAnsiStrEqualityCompare): IJclAnsiStrIterator;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := nil;\r\n for I := Count - 1 downto 0 do\r\n if First.HasNext then\r\n begin\r\n if AEqualityComparator(First.Next, AString) then\r\n begin\r\n Result := First;\r\n Break;\r\n end;\r\n end\r\n else\r\n Break;\r\nend;\r\n\r\nfunction Find(const First: IJclWideStrIterator; Count: Integer;\r\n const AString: WideString; AComparator: TWideStrCompare): IJclWideStrIterator;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := nil;\r\n for I := Count - 1 downto 0 do\r\n if First.HasNext then\r\n begin\r\n if AComparator(First.Next, AString) = 0 then\r\n begin\r\n Result := First;\r\n Break;\r\n end;\r\n end\r\n else\r\n Break;\r\nend;\r\n\r\nfunction Find(const First: IJclWideStrIterator; Count: Integer;\r\n const AString: WideString; AEqualityComparator: TWideStrEqualityCompare): IJclWideStrIterator;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := nil;\r\n for I := Count - 1 downto 0 do\r\n if First.HasNext then\r\n begin\r\n if AEqualityComparator(First.Next, AString) then\r\n begin\r\n Result := First;\r\n Break;\r\n end;\r\n end\r\n else\r\n Break;\r\nend;\r\n\r\n{$IFDEF SUPPORTS_UNICODE_STRING}\r\nfunction Find(const First: IJclUnicodeStrIterator; Count: Integer;\r\n const AString: UnicodeString; AComparator: TUnicodeStrCompare): IJclUnicodeStrIterator;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := nil;\r\n for I := Count - 1 downto 0 do\r\n if First.HasNext then\r\n begin\r\n if AComparator(First.Next, AString) = 0 then\r\n begin\r\n Result := First;\r\n Break;\r\n end;\r\n end\r\n else\r\n Break;\r\nend;\r\n{$ENDIF SUPPORTS_UNICODE_STRING}\r\n\r\n{$IFDEF SUPPORTS_UNICODE_STRING}\r\nfunction Find(const First: IJclUnicodeStrIterator; Count: Integer;\r\n const AString: UnicodeString; AEqualityComparator: TUnicodeStrEqualityCompare): IJclUnicodeStrIterator;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := nil;\r\n for I := Count - 1 downto 0 do\r\n if First.HasNext then\r\n begin\r\n if AEqualityComparator(First.Next, AString) then\r\n begin\r\n Result := First;\r\n Break;\r\n end;\r\n end\r\n else\r\n Break;\r\nend;\r\n{$ENDIF SUPPORTS_UNICODE_STRING}\r\n\r\nfunction Find(const First: IJclSingleIterator; Count: Integer;\r\n const AValue: Single; AComparator: TSingleCompare): IJclSingleIterator;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := nil;\r\n for I := Count - 1 downto 0 do\r\n if First.HasNext then\r\n begin\r\n if AComparator(First.Next, AValue) = 0 then\r\n begin\r\n Result := First;\r\n Break;\r\n end;\r\n end\r\n else\r\n Break;\r\nend;\r\n\r\nfunction Find(const First: IJclSingleIterator; Count: Integer;\r\n const AValue: Single; AEqualityComparator: TSingleEqualityCompare): IJclSingleIterator;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := nil;\r\n for I := Count - 1 downto 0 do\r\n if First.HasNext then\r\n begin\r\n if AEqualityComparator(First.Next, AValue) then\r\n begin\r\n Result := First;\r\n Break;\r\n end;\r\n end\r\n else\r\n Break;\r\nend;\r\n\r\nfunction Find(const First: IJclDoubleIterator; Count: Integer;\r\n const AValue: Double; AComparator: TDoubleCompare): IJclDoubleIterator;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := nil;\r\n for I := Count - 1 downto 0 do\r\n if First.HasNext then\r\n begin\r\n if AComparator(First.Next, AValue) = 0 then\r\n begin\r\n Result := First;\r\n Break;\r\n end;\r\n end\r\n else\r\n Break;\r\nend;\r\n\r\nfunction Find(const First: IJclDoubleIterator; Count: Integer;\r\n const AValue: Double; AEqualityComparator: TDoubleEqualityCompare): IJclDoubleIterator;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := nil;\r\n for I := Count - 1 downto 0 do\r\n if First.HasNext then\r\n begin\r\n if AEqualityComparator(First.Next, AValue) then\r\n begin\r\n Result := First;\r\n Break;\r\n end;\r\n end\r\n else\r\n Break;\r\nend;\r\n\r\nfunction Find(const First: IJclExtendedIterator; Count: Integer;\r\n const AValue: Extended; AComparator: TExtendedCompare): IJclExtendedIterator;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := nil;\r\n for I := Count - 1 downto 0 do\r\n if First.HasNext then\r\n begin\r\n if AComparator(First.Next, AValue) = 0 then\r\n begin\r\n Result := First;\r\n Break;\r\n end;\r\n end\r\n else\r\n Break;\r\nend;\r\n\r\nfunction Find(const First: IJclExtendedIterator; Count: Integer;\r\n const AValue: Extended; AEqualityComparator: TExtendedEqualityCompare): IJclExtendedIterator;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := nil;\r\n for I := Count - 1 downto 0 do\r\n if First.HasNext then\r\n begin\r\n if AEqualityComparator(First.Next, AValue) then\r\n begin\r\n Result := First;\r\n Break;\r\n end;\r\n end\r\n else\r\n Break;\r\nend;\r\n\r\nfunction Find(const First: IJclIntegerIterator; Count: Integer;\r\n AValue: Integer; AComparator: TIntegerCompare): IJclIntegerIterator;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := nil;\r\n for I := Count - 1 downto 0 do\r\n if First.HasNext then\r\n begin\r\n if AComparator(First.Next, AValue) = 0 then\r\n begin\r\n Result := First;\r\n Break;\r\n end;\r\n end\r\n else\r\n Break;\r\nend;\r\n\r\nfunction Find(const First: IJclIntegerIterator; Count: Integer;\r\n AValue: Integer; AEqualityComparator: TIntegerEqualityCompare): IJclIntegerIterator;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := nil;\r\n for I := Count - 1 downto 0 do\r\n if First.HasNext then\r\n begin\r\n if AEqualityComparator(First.Next, AValue) then\r\n begin\r\n Result := First;\r\n Break;\r\n end;\r\n end\r\n else\r\n Break;\r\nend;\r\n\r\nfunction Find(const First: IJclCardinalIterator; Count: Integer;\r\n AValue: Cardinal; AComparator: TCardinalCompare): IJclCardinalIterator;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := nil;\r\n for I := Count - 1 downto 0 do\r\n if First.HasNext then\r\n begin\r\n if AComparator(First.Next, AValue) = 0 then\r\n begin\r\n Result := First;\r\n Break;\r\n end;\r\n end\r\n else\r\n Break;\r\nend;\r\n\r\nfunction Find(const First: IJclCardinalIterator; Count: Integer;\r\n AValue: Cardinal; AEqualityComparator: TCardinalEqualityCompare): IJclCardinalIterator;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := nil;\r\n for I := Count - 1 downto 0 do\r\n if First.HasNext then\r\n begin\r\n if AEqualityComparator(First.Next, AValue) then\r\n begin\r\n Result := First;\r\n Break;\r\n end;\r\n end\r\n else\r\n Break;\r\nend;\r\n\r\nfunction Find(const First: IJclInt64Iterator; Count: Integer;\r\n const AValue: Int64; AComparator: TInt64Compare): IJclInt64Iterator;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := nil;\r\n for I := Count - 1 downto 0 do\r\n if First.HasNext then\r\n begin\r\n if AComparator(First.Next, AValue) = 0 then\r\n begin\r\n Result := First;\r\n Break;\r\n end;\r\n end\r\n else\r\n Break;\r\nend;\r\n\r\nfunction Find(const First: IJclInt64Iterator; Count: Integer;\r\n const AValue: Int64; AEqualityComparator: TInt64EqualityCompare): IJclInt64Iterator;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := nil;\r\n for I := Count - 1 downto 0 do\r\n if First.HasNext then\r\n begin\r\n if AEqualityComparator(First.Next, AValue) then\r\n begin\r\n Result := First;\r\n Break;\r\n end;\r\n end\r\n else\r\n Break;\r\nend;\r\n\r\nfunction Find(const First: IJclPtrIterator; Count: Integer;\r\n APtr: Pointer; AComparator: TPtrCompare): IJclPtrIterator;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := nil;\r\n for I := Count - 1 downto 0 do\r\n if First.HasNext then\r\n begin\r\n if AComparator(First.Next, APtr) = 0 then\r\n begin\r\n Result := First;\r\n Break;\r\n end;\r\n end\r\n else\r\n Break;\r\nend;\r\n\r\nfunction Find(const First: IJclPtrIterator; Count: Integer;\r\n APtr: Pointer; AEqualityComparator: TPtrEqualityCompare): IJclPtrIterator;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := nil;\r\n for I := Count - 1 downto 0 do\r\n if First.HasNext then\r\n begin\r\n if AEqualityComparator(First.Next, APtr) then\r\n begin\r\n Result := First;\r\n Break;\r\n end;\r\n end\r\n else\r\n Break;\r\nend;\r\n\r\nfunction Find(const First: IJclIterator; Count: Integer;\r\n AObject: TObject; AComparator: TCompare): IJclIterator;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := nil;\r\n for I := Count - 1 downto 0 do\r\n if First.HasNext then\r\n begin\r\n if AComparator(First.Next, AObject) = 0 then\r\n begin\r\n Result := First;\r\n Break;\r\n end;\r\n end\r\n else\r\n Break;\r\nend;\r\n\r\nfunction Find(const First: IJclIterator; Count: Integer;\r\n AObject: TObject; AEqualityComparator: TEqualityCompare): IJclIterator;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := nil;\r\n for I := Count - 1 downto 0 do\r\n if First.HasNext then\r\n begin\r\n if AEqualityComparator(First.Next, AObject) then\r\n begin\r\n Result := First;\r\n Break;\r\n end;\r\n end\r\n else\r\n Break;\r\nend;\r\n\r\n\r\nfunction CountObject(const First: IJclIntfIterator; Count: Integer;\r\n const AInterface: IInterface; AComparator: TIntfCompare): Integer;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := 0;\r\n for I := Count - 1 downto 0 do\r\n if First.HasNext then\r\n Inc(Result, Ord(AComparator(First.Next, AInterface) = 0))\r\n else\r\n Break;\r\nend;\r\n\r\nfunction CountObject(const First: IJclIntfIterator; Count: Integer;\r\n const AInterface: IInterface; AEqualityComparator: TIntfEqualityCompare): Integer;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := 0;\r\n for I := Count - 1 downto 0 do\r\n if First.HasNext then\r\n Inc(Result, Ord(AEqualityComparator(First.Next, AInterface)))\r\n else\r\n Break;\r\nend;\r\n\r\nfunction CountObject(const First: IJclAnsiStrIterator; Count: Integer;\r\n const AString: AnsiString; AComparator: TAnsiStrCompare): Integer;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := 0;\r\n for I := Count - 1 downto 0 do\r\n if First.HasNext then\r\n Inc(Result, Ord(AComparator(First.Next, AString) = 0))\r\n else\r\n Break;\r\nend;\r\n\r\nfunction CountObject(const First: IJclAnsiStrIterator; Count: Integer;\r\n const AString: AnsiString; AEqualityComparator: TAnsiStrEqualityCompare): Integer;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := 0;\r\n for I := Count - 1 downto 0 do\r\n if First.HasNext then\r\n Inc(Result, Ord(AEqualityComparator(First.Next, AString)))\r\n else\r\n Break;\r\nend;\r\n\r\nfunction CountObject(const First: IJclWideStrIterator; Count: Integer;\r\n const AString: WideString; AComparator: TWideStrCompare): Integer;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := 0;\r\n for I := Count - 1 downto 0 do\r\n if First.HasNext then\r\n Inc(Result, Ord(AComparator(First.Next, AString) = 0))\r\n else\r\n Break;\r\nend;\r\n\r\nfunction CountObject(const First: IJclWideStrIterator; Count: Integer;\r\n const AString: WideString; AEqualityComparator: TWideStrEqualityCompare): Integer;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := 0;\r\n for I := Count - 1 downto 0 do\r\n if First.HasNext then\r\n Inc(Result, Ord(AEqualityComparator(First.Next, AString)))\r\n else\r\n Break;\r\nend;\r\n\r\n{$IFDEF SUPPORTS_UNICODE_STRING}\r\nfunction CountObject(const First: IJclUnicodeStrIterator; Count: Integer;\r\n const AString: UnicodeString; AComparator: TUnicodeStrCompare): Integer;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := 0;\r\n for I := Count - 1 downto 0 do\r\n if First.HasNext then\r\n Inc(Result, Ord(AComparator(First.Next, AString) = 0))\r\n else\r\n Break;\r\nend;\r\n{$ENDIF SUPPORTS_UNICODE_STRING}\r\n\r\n{$IFDEF SUPPORTS_UNICODE_STRING}\r\nfunction CountObject(const First: IJclUnicodeStrIterator; Count: Integer;\r\n const AString: UnicodeString; AEqualityComparator: TUnicodeStrEqualityCompare): Integer;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := 0;\r\n for I := Count - 1 downto 0 do\r\n if First.HasNext then\r\n Inc(Result, Ord(AEqualityComparator(First.Next, AString)))\r\n else\r\n Break;\r\nend;\r\n{$ENDIF SUPPORTS_UNICODE_STRING}\r\n\r\nfunction CountObject(const First: IJclSingleIterator; Count: Integer;\r\n const AValue: Single; AComparator: TSingleCompare): Integer;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := 0;\r\n for I := Count - 1 downto 0 do\r\n if First.HasNext then\r\n Inc(Result, Ord(AComparator(First.Next, AValue) = 0))\r\n else\r\n Break;\r\nend;\r\n\r\nfunction CountObject(const First: IJclSingleIterator; Count: Integer;\r\n const AValue: Single; AEqualityComparator: TSingleEqualityCompare): Integer;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := 0;\r\n for I := Count - 1 downto 0 do\r\n if First.HasNext then\r\n Inc(Result, Ord(AEqualityComparator(First.Next, AValue)))\r\n else\r\n Break;\r\nend;\r\n\r\nfunction CountObject(const First: IJclDoubleIterator; Count: Integer;\r\n const AValue: Double; AComparator: TDoubleCompare): Integer;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := 0;\r\n for I := Count - 1 downto 0 do\r\n if First.HasNext then\r\n Inc(Result, Ord(AComparator(First.Next, AValue) = 0))\r\n else\r\n Break;\r\nend;\r\n\r\nfunction CountObject(const First: IJclDoubleIterator; Count: Integer;\r\n const AValue: Double; AEqualityComparator: TDoubleEqualityCompare): Integer;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := 0;\r\n for I := Count - 1 downto 0 do\r\n if First.HasNext then\r\n Inc(Result, Ord(AEqualityComparator(First.Next, AValue)))\r\n else\r\n Break;\r\nend;\r\n\r\nfunction CountObject(const First: IJclExtendedIterator; Count: Integer;\r\n const AValue: Extended; AComparator: TExtendedCompare): Integer;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := 0;\r\n for I := Count - 1 downto 0 do\r\n if First.HasNext then\r\n Inc(Result, Ord(AComparator(First.Next, AValue) = 0))\r\n else\r\n Break;\r\nend;\r\n\r\nfunction CountObject(const First: IJclExtendedIterator; Count: Integer;\r\n const AValue: Extended; AEqualityComparator: TExtendedEqualityCompare): Integer;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := 0;\r\n for I := Count - 1 downto 0 do\r\n if First.HasNext then\r\n Inc(Result, Ord(AEqualityComparator(First.Next, AValue)))\r\n else\r\n Break;\r\nend;\r\n\r\nfunction CountObject(const First: IJclIntegerIterator; Count: Integer;\r\n AValue: Integer; AComparator: TIntegerCompare): Integer;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := 0;\r\n for I := Count - 1 downto 0 do\r\n if First.HasNext then\r\n Inc(Result, Ord(AComparator(First.Next, AValue) = 0))\r\n else\r\n Break;\r\nend;\r\n\r\nfunction CountObject(const First: IJclIntegerIterator; Count: Integer;\r\n AValue: Integer; AEqualityComparator: TIntegerEqualityCompare): Integer;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := 0;\r\n for I := Count - 1 downto 0 do\r\n if First.HasNext then\r\n Inc(Result, Ord(AEqualityComparator(First.Next, AValue)))\r\n else\r\n Break;\r\nend;\r\n\r\nfunction CountObject(const First: IJclCardinalIterator; Count: Integer;\r\n AValue: Cardinal; AComparator: TCardinalCompare): Integer;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := 0;\r\n for I := Count - 1 downto 0 do\r\n if First.HasNext then\r\n Inc(Result, Ord(AComparator(First.Next, AValue) = 0))\r\n else\r\n Break;\r\nend;\r\n\r\nfunction CountObject(const First: IJclCardinalIterator; Count: Integer;\r\n AValue: Cardinal; AEqualityComparator: TCardinalEqualityCompare): Integer;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := 0;\r\n for I := Count - 1 downto 0 do\r\n if First.HasNext then\r\n Inc(Result, Ord(AEqualityComparator(First.Next, AValue)))\r\n else\r\n Break;\r\nend;\r\n\r\nfunction CountObject(const First: IJclInt64Iterator; Count: Integer;\r\n const AValue: Int64; AComparator: TInt64Compare): Integer;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := 0;\r\n for I := Count - 1 downto 0 do\r\n if First.HasNext then\r\n Inc(Result, Ord(AComparator(First.Next, AValue) = 0))\r\n else\r\n Break;\r\nend;\r\n\r\nfunction CountObject(const First: IJclInt64Iterator; Count: Integer;\r\n const AValue: Int64; AEqualityComparator: TInt64EqualityCompare): Integer;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := 0;\r\n for I := Count - 1 downto 0 do\r\n if First.HasNext then\r\n Inc(Result, Ord(AEqualityComparator(First.Next, AValue)))\r\n else\r\n Break;\r\nend;\r\n\r\nfunction CountObject(const First: IJclPtrIterator; Count: Integer;\r\n APtr: Pointer; AComparator: TPtrCompare): Integer;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := 0;\r\n for I := Count - 1 downto 0 do\r\n if First.HasNext then\r\n Inc(Result, Ord(AComparator(First.Next, APtr) = 0))\r\n else\r\n Break;\r\nend;\r\n\r\nfunction CountObject(const First: IJclPtrIterator; Count: Integer;\r\n APtr: Pointer; AEqualityComparator: TPtrEqualityCompare): Integer;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := 0;\r\n for I := Count - 1 downto 0 do\r\n if First.HasNext then\r\n Inc(Result, Ord(AEqualityComparator(First.Next, APtr)))\r\n else\r\n Break;\r\nend;\r\n\r\nfunction CountObject(const First: IJclIterator; Count: Integer;\r\n AObject: TObject; AComparator: TCompare): Integer;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := 0;\r\n for I := Count - 1 downto 0 do\r\n if First.HasNext then\r\n Inc(Result, Ord(AComparator(First.Next, AObject) = 0))\r\n else\r\n Break;\r\nend;\r\n\r\nfunction CountObject(const First: IJclIterator; Count: Integer;\r\n AObject: TObject; AEqualityComparator: TEqualityCompare): Integer;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := 0;\r\n for I := Count - 1 downto 0 do\r\n if First.HasNext then\r\n Inc(Result, Ord(AEqualityComparator(First.Next, AObject)))\r\n else\r\n Break;\r\nend;\r\n\r\n\r\nprocedure Copy(const First: IJclIntfIterator; Count: Integer;\r\n const Output: IJclIntfIterator);\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := Count - 1 downto 0 do\r\n if Output.HasNext and First.HasNext then\r\n begin\r\n Output.Next;\r\n Output.SetObject(First.Next);\r\n end\r\n else\r\n Break;\r\nend;\r\n\r\nprocedure Copy(const First: IJclAnsiStrIterator; Count: Integer;\r\n const Output: IJclAnsiStrIterator);\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := Count - 1 downto 0 do\r\n if Output.HasNext and First.HasNext then\r\n begin\r\n Output.Next;\r\n Output.SetString(First.Next);\r\n end\r\n else\r\n Break;\r\nend;\r\n\r\nprocedure Copy(const First: IJclWideStrIterator; Count: Integer;\r\n const Output: IJclWideStrIterator);\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := Count - 1 downto 0 do\r\n if Output.HasNext and First.HasNext then\r\n begin\r\n Output.Next;\r\n Output.SetString(First.Next);\r\n end\r\n else\r\n Break;\r\nend;\r\n\r\n{$IFDEF SUPPORTS_UNICODE_STRING}\r\nprocedure Copy(const First: IJclUnicodeStrIterator; Count: Integer;\r\n const Output: IJclUnicodeStrIterator);\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := Count - 1 downto 0 do\r\n if Output.HasNext and First.HasNext then\r\n begin\r\n Output.Next;\r\n Output.SetString(First.Next);\r\n end\r\n else\r\n Break;\r\nend;\r\n{$ENDIF SUPPORTS_UNICODE_STRING}\r\n\r\nprocedure Copy(const First: IJclSingleIterator; Count: Integer;\r\n const Output: IJclSingleIterator);\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := Count - 1 downto 0 do\r\n if Output.HasNext and First.HasNext then\r\n begin\r\n Output.Next;\r\n Output.SetValue(First.Next);\r\n end\r\n else\r\n Break;\r\nend;\r\n\r\nprocedure Copy(const First: IJclDoubleIterator; Count: Integer;\r\n const Output: IJclDoubleIterator);\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := Count - 1 downto 0 do\r\n if Output.HasNext and First.HasNext then\r\n begin\r\n Output.Next;\r\n Output.SetValue(First.Next);\r\n end\r\n else\r\n Break;\r\nend;\r\n\r\nprocedure Copy(const First: IJclExtendedIterator; Count: Integer;\r\n const Output: IJclExtendedIterator);\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := Count - 1 downto 0 do\r\n if Output.HasNext and First.HasNext then\r\n begin\r\n Output.Next;\r\n Output.SetValue(First.Next);\r\n end\r\n else\r\n Break;\r\nend;\r\n\r\nprocedure Copy(const First: IJclIntegerIterator; Count: Integer;\r\n const Output: IJclIntegerIterator);\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := Count - 1 downto 0 do\r\n if Output.HasNext and First.HasNext then\r\n begin\r\n Output.Next;\r\n Output.SetValue(First.Next);\r\n end\r\n else\r\n Break;\r\nend;\r\n\r\nprocedure Copy(const First: IJclCardinalIterator; Count: Integer;\r\n const Output: IJclCardinalIterator);\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := Count - 1 downto 0 do\r\n if Output.HasNext and First.HasNext then\r\n begin\r\n Output.Next;\r\n Output.SetValue(First.Next);\r\n end\r\n else\r\n Break;\r\nend;\r\n\r\nprocedure Copy(const First: IJclInt64Iterator; Count: Integer;\r\n const Output: IJclInt64Iterator);\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := Count - 1 downto 0 do\r\n if Output.HasNext and First.HasNext then\r\n begin\r\n Output.Next;\r\n Output.SetValue(First.Next);\r\n end\r\n else\r\n Break;\r\nend;\r\n\r\nprocedure Copy(const First: IJclPtrIterator; Count: Integer;\r\n const Output: IJclPtrIterator);\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := Count - 1 downto 0 do\r\n if Output.HasNext and First.HasNext then\r\n begin\r\n Output.Next;\r\n Output.SetPointer(First.Next);\r\n end\r\n else\r\n Break;\r\nend;\r\n\r\nprocedure Copy(const First: IJclIterator; Count: Integer;\r\n const Output: IJclIterator);\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := Count - 1 downto 0 do\r\n if Output.HasNext and First.HasNext then\r\n begin\r\n Output.Next;\r\n Output.SetObject(First.Next);\r\n end\r\n else\r\n Break;\r\nend;\r\n\r\n\r\nprocedure Generate(const List: IJclIntfList; Count: Integer;\r\n const AInterface: IInterface);\r\nvar\r\n I: Integer;\r\nbegin\r\n List.Clear;\r\n for I := 0 to Count - 1 do\r\n List.Add(AInterface);\r\nend;\r\n\r\nprocedure Generate(const List: IJclAnsiStrList; Count: Integer;\r\n const AString: AnsiString);\r\nvar\r\n I: Integer;\r\nbegin\r\n List.Clear;\r\n for I := 0 to Count - 1 do\r\n List.Add(AString);\r\nend;\r\n\r\nprocedure Generate(const List: IJclWideStrList; Count: Integer;\r\n const AString: WideString);\r\nvar\r\n I: Integer;\r\nbegin\r\n List.Clear;\r\n for I := 0 to Count - 1 do\r\n List.Add(AString);\r\nend;\r\n\r\n{$IFDEF SUPPORTS_UNICODE_STRING}\r\nprocedure Generate(const List: IJclUnicodeStrList; Count: Integer;\r\n const AString: UnicodeString);\r\nvar\r\n I: Integer;\r\nbegin\r\n List.Clear;\r\n for I := 0 to Count - 1 do\r\n List.Add(AString);\r\nend;\r\n{$ENDIF SUPPORTS_UNICODE_STRING}\r\n\r\nprocedure Generate(const List: IJclSingleList; Count: Integer;\r\n const AValue: Single);\r\nvar\r\n I: Integer;\r\nbegin\r\n List.Clear;\r\n for I := 0 to Count - 1 do\r\n List.Add(AValue);\r\nend;\r\n\r\nprocedure Generate(const List: IJclDoubleList; Count: Integer;\r\n const AValue: Double);\r\nvar\r\n I: Integer;\r\nbegin\r\n List.Clear;\r\n for I := 0 to Count - 1 do\r\n List.Add(AValue);\r\nend;\r\n\r\nprocedure Generate(const List: IJclExtendedList; Count: Integer;\r\n const AValue: Extended);\r\nvar\r\n I: Integer;\r\nbegin\r\n List.Clear;\r\n for I := 0 to Count - 1 do\r\n List.Add(AValue);\r\nend;\r\n\r\nprocedure Generate(const List: IJclIntegerList; Count: Integer;\r\n AValue: Integer);\r\nvar\r\n I: Integer;\r\nbegin\r\n List.Clear;\r\n for I := 0 to Count - 1 do\r\n List.Add(AValue);\r\nend;\r\n\r\nprocedure Generate(const List: IJclCardinalList; Count: Integer;\r\n AValue: Cardinal);\r\nvar\r\n I: Integer;\r\nbegin\r\n List.Clear;\r\n for I := 0 to Count - 1 do\r\n List.Add(AValue);\r\nend;\r\n\r\nprocedure Generate(const List: IJclInt64List; Count: Integer;\r\n const AValue: Int64);\r\nvar\r\n I: Integer;\r\nbegin\r\n List.Clear;\r\n for I := 0 to Count - 1 do\r\n List.Add(AValue);\r\nend;\r\n\r\nprocedure Generate(const List: IJclPtrList; Count: Integer;\r\n APtr: Pointer);\r\nvar\r\n I: Integer;\r\nbegin\r\n List.Clear;\r\n for I := 0 to Count - 1 do\r\n List.Add(APtr);\r\nend;\r\n\r\nprocedure Generate(const List: IJclList; Count: Integer;\r\n AObject: TObject);\r\nvar\r\n I: Integer;\r\nbegin\r\n List.Clear;\r\n for I := 0 to Count - 1 do\r\n List.Add(AObject);\r\nend;\r\n\r\n\r\nprocedure Fill(const First: IJclIntfIterator; Count: Integer;\r\n const AInterface: IInterface);\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := Count - 1 downto 0 do\r\n if First.HasNext then\r\n begin\r\n First.Next;\r\n First.SetObject(AInterface);\r\n end\r\n else\r\n Break;\r\nend;\r\n\r\nprocedure Fill(const First: IJclAnsiStrIterator; Count: Integer;\r\n const AString: AnsiString);\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := Count - 1 downto 0 do\r\n if First.HasNext then\r\n begin\r\n First.Next;\r\n First.SetString(AString);\r\n end\r\n else\r\n Break;\r\nend;\r\n\r\nprocedure Fill(const First: IJclWideStrIterator; Count: Integer;\r\n const AString: WideString);\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := Count - 1 downto 0 do\r\n if First.HasNext then\r\n begin\r\n First.Next;\r\n First.SetString(AString);\r\n end\r\n else\r\n Break;\r\nend;\r\n\r\n{$IFDEF SUPPORTS_UNICODE_STRING}\r\nprocedure Fill(const First: IJclUnicodeStrIterator; Count: Integer;\r\n const AString: UnicodeString);\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := Count - 1 downto 0 do\r\n if First.HasNext then\r\n begin\r\n First.Next;\r\n First.SetString(AString);\r\n end\r\n else\r\n Break;\r\nend;\r\n{$ENDIF SUPPORTS_UNICODE_STRING}\r\n\r\nprocedure Fill(const First: IJclSingleIterator; Count: Integer;\r\n const AValue: Single);\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := Count - 1 downto 0 do\r\n if First.HasNext then\r\n begin\r\n First.Next;\r\n First.SetValue(AValue);\r\n end\r\n else\r\n Break;\r\nend;\r\n\r\nprocedure Fill(const First: IJclDoubleIterator; Count: Integer;\r\n const AValue: Double);\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := Count - 1 downto 0 do\r\n if First.HasNext then\r\n begin\r\n First.Next;\r\n First.SetValue(AValue);\r\n end\r\n else\r\n Break;\r\nend;\r\n\r\nprocedure Fill(const First: IJclExtendedIterator; Count: Integer;\r\n const AValue: Extended);\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := Count - 1 downto 0 do\r\n if First.HasNext then\r\n begin\r\n First.Next;\r\n First.SetValue(AValue);\r\n end\r\n else\r\n Break;\r\nend;\r\n\r\nprocedure Fill(const First: IJclIntegerIterator; Count: Integer;\r\n AValue: Integer);\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := Count - 1 downto 0 do\r\n if First.HasNext then\r\n begin\r\n First.Next;\r\n First.SetValue(AValue);\r\n end\r\n else\r\n Break;\r\nend;\r\n\r\nprocedure Fill(const First: IJclCardinalIterator; Count: Integer;\r\n AValue: Cardinal);\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := Count - 1 downto 0 do\r\n if First.HasNext then\r\n begin\r\n First.Next;\r\n First.SetValue(AValue);\r\n end\r\n else\r\n Break;\r\nend;\r\n\r\nprocedure Fill(const First: IJclInt64Iterator; Count: Integer;\r\n const AValue: Int64);\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := Count - 1 downto 0 do\r\n if First.HasNext then\r\n begin\r\n First.Next;\r\n First.SetValue(AValue);\r\n end\r\n else\r\n Break;\r\nend;\r\n\r\nprocedure Fill(const First: IJclPtrIterator; Count: Integer;\r\n APtr: Pointer);\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := Count - 1 downto 0 do\r\n if First.HasNext then\r\n begin\r\n First.Next;\r\n First.SetPointer(APtr);\r\n end\r\n else\r\n Break;\r\nend;\r\n\r\nprocedure Fill(const First: IJclIterator; Count: Integer;\r\n AObject: TObject);\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := Count - 1 downto 0 do\r\n if First.HasNext then\r\n begin\r\n First.Next;\r\n First.SetObject(AObject);\r\n end\r\n else\r\n Break;\r\nend;\r\n\r\n\r\nprocedure Reverse(const First, Last: IJclIntfIterator);\r\nvar\r\n Obj: IInterface;\r\nbegin\r\n if not First.HasNext then\r\n Exit;\r\n if not Last.HasPrevious then\r\n Exit;\r\n while First.NextIndex < Last.PreviousIndex do\r\n begin\r\n Obj := First.Next;\r\n Last.Previous;\r\n First.SetObject(Last.GetObject);\r\n Last.SetObject(Obj);\r\n end;\r\nend;\r\n\r\nprocedure Reverse(const First, Last: IJclAnsiStrIterator);\r\nvar\r\n Obj: AnsiString;\r\nbegin\r\n if not First.HasNext then\r\n Exit;\r\n if not Last.HasPrevious then\r\n Exit;\r\n while First.NextIndex < Last.PreviousIndex do\r\n begin\r\n Obj := First.Next;\r\n Last.Previous;\r\n First.SetString(Last.GetString);\r\n Last.SetString(Obj);\r\n end;\r\nend;\r\n\r\nprocedure Reverse(const First, Last: IJclWideStrIterator);\r\nvar\r\n Obj: WideString;\r\nbegin\r\n if not First.HasNext then\r\n Exit;\r\n if not Last.HasPrevious then\r\n Exit;\r\n while First.NextIndex < Last.PreviousIndex do\r\n begin\r\n Obj := First.Next;\r\n Last.Previous;\r\n First.SetString(Last.GetString);\r\n Last.SetString(Obj);\r\n end;\r\nend;\r\n\r\n{$IFDEF SUPPORTS_UNICODE_STRING}\r\nprocedure Reverse(const First, Last: IJclUnicodeStrIterator);\r\nvar\r\n Obj: UnicodeString;\r\nbegin\r\n if not First.HasNext then\r\n Exit;\r\n if not Last.HasPrevious then\r\n Exit;\r\n while First.NextIndex < Last.PreviousIndex do\r\n begin\r\n Obj := First.Next;\r\n Last.Previous;\r\n First.SetString(Last.GetString);\r\n Last.SetString(Obj);\r\n end;\r\nend;\r\n{$ENDIF SUPPORTS_UNICODE_STRING}\r\n\r\nprocedure Reverse(const First, Last: IJclSingleIterator);\r\nvar\r\n Obj: Single;\r\nbegin\r\n if not First.HasNext then\r\n Exit;\r\n if not Last.HasPrevious then\r\n Exit;\r\n while First.NextIndex < Last.PreviousIndex do\r\n begin\r\n Obj := First.Next;\r\n Last.Previous;\r\n First.SetValue(Last.GetValue);\r\n Last.SetValue(Obj);\r\n end;\r\nend;\r\n\r\nprocedure Reverse(const First, Last: IJclDoubleIterator);\r\nvar\r\n Obj: Double;\r\nbegin\r\n if not First.HasNext then\r\n Exit;\r\n if not Last.HasPrevious then\r\n Exit;\r\n while First.NextIndex < Last.PreviousIndex do\r\n begin\r\n Obj := First.Next;\r\n Last.Previous;\r\n First.SetValue(Last.GetValue);\r\n Last.SetValue(Obj);\r\n end;\r\nend;\r\n\r\nprocedure Reverse(const First, Last: IJclExtendedIterator);\r\nvar\r\n Obj: Extended;\r\nbegin\r\n if not First.HasNext then\r\n Exit;\r\n if not Last.HasPrevious then\r\n Exit;\r\n while First.NextIndex < Last.PreviousIndex do\r\n begin\r\n Obj := First.Next;\r\n Last.Previous;\r\n First.SetValue(Last.GetValue);\r\n Last.SetValue(Obj);\r\n end;\r\nend;\r\n\r\nprocedure Reverse(const First, Last: IJclIntegerIterator);\r\nvar\r\n Obj: Integer;\r\nbegin\r\n if not First.HasNext then\r\n Exit;\r\n if not Last.HasPrevious then\r\n Exit;\r\n while First.NextIndex < Last.PreviousIndex do\r\n begin\r\n Obj := First.Next;\r\n Last.Previous;\r\n First.SetValue(Last.GetValue);\r\n Last.SetValue(Obj);\r\n end;\r\nend;\r\n\r\nprocedure Reverse(const First, Last: IJclCardinalIterator);\r\nvar\r\n Obj: Cardinal;\r\nbegin\r\n if not First.HasNext then\r\n Exit;\r\n if not Last.HasPrevious then\r\n Exit;\r\n while First.NextIndex < Last.PreviousIndex do\r\n begin\r\n Obj := First.Next;\r\n Last.Previous;\r\n First.SetValue(Last.GetValue);\r\n Last.SetValue(Obj);\r\n end;\r\nend;\r\n\r\nprocedure Reverse(const First, Last: IJclInt64Iterator);\r\nvar\r\n Obj: Int64;\r\nbegin\r\n if not First.HasNext then\r\n Exit;\r\n if not Last.HasPrevious then\r\n Exit;\r\n while First.NextIndex < Last.PreviousIndex do\r\n begin\r\n Obj := First.Next;\r\n Last.Previous;\r\n First.SetValue(Last.GetValue);\r\n Last.SetValue(Obj);\r\n end;\r\nend;\r\n\r\nprocedure Reverse(const First, Last: IJclPtrIterator);\r\nvar\r\n Obj: Pointer;\r\nbegin\r\n if not First.HasNext then\r\n Exit;\r\n if not Last.HasPrevious then\r\n Exit;\r\n while First.NextIndex < Last.PreviousIndex do\r\n begin\r\n Obj := First.Next;\r\n Last.Previous;\r\n First.SetPointer(Last.GetPointer);\r\n Last.SetPointer(Obj);\r\n end;\r\nend;\r\n\r\nprocedure Reverse(const First, Last: IJclIterator);\r\nvar\r\n Obj: TObject;\r\nbegin\r\n if not First.HasNext then\r\n Exit;\r\n if not Last.HasPrevious then\r\n Exit;\r\n while First.NextIndex < Last.PreviousIndex do\r\n begin\r\n Obj := First.Next;\r\n Last.Previous;\r\n First.SetObject(Last.GetObject);\r\n Last.SetObject(Obj);\r\n end;\r\nend;\r\n\r\n\r\nprocedure QuickSort(const AList: IJclIntfList; L, R: Integer;\r\n AComparator: TIntfCompare);\r\nvar\r\n I, J, P: Integer;\r\n Obj: IInterface;\r\nbegin\r\n repeat\r\n I := L;\r\n J := R;\r\n P := (L + R) shr 1;\r\n repeat\r\n Obj := AList.GetObject(P);\r\n while AComparator(AList.GetObject(I), Obj) < 0 do\r\n Inc(I);\r\n while AComparator(AList.GetObject(J), Obj) > 0 do\r\n Dec(J);\r\n if I <= J then\r\n begin\r\n Obj := AList.GetObject(I);\r\n AList.SetObject(I, AList.GetObject(J));\r\n AList.SetObject(J, Obj);\r\n if P = I then\r\n P := J\r\n else\r\n if P = J then\r\n P := I;\r\n Inc(I);\r\n Dec(J);\r\n end;\r\n until I > J;\r\n if L < J then\r\n QuickSort(AList, L, J, AComparator);\r\n L := I;\r\n until I >= R;\r\nend;\r\n\r\nprocedure QuickSort(const AList: IJclAnsiStrList; L, R: Integer;\r\n AComparator: TAnsiStrCompare);\r\nvar\r\n I, J, P: Integer;\r\n Obj: AnsiString;\r\nbegin\r\n repeat\r\n I := L;\r\n J := R;\r\n P := (L + R) shr 1;\r\n repeat\r\n Obj := AList.GetString(P);\r\n while AComparator(AList.GetString(I), Obj) < 0 do\r\n Inc(I);\r\n while AComparator(AList.GetString(J), Obj) > 0 do\r\n Dec(J);\r\n if I <= J then\r\n begin\r\n Obj := AList.GetString(I);\r\n AList.SetString(I, AList.GetString(J));\r\n AList.SetString(J, Obj);\r\n if P = I then\r\n P := J\r\n else\r\n if P = J then\r\n P := I;\r\n Inc(I);\r\n Dec(J);\r\n end;\r\n until I > J;\r\n if L < J then\r\n QuickSort(AList, L, J, AComparator);\r\n L := I;\r\n until I >= R;\r\nend;\r\n\r\nprocedure QuickSort(const AList: IJclWideStrList; L, R: Integer;\r\n AComparator: TWideStrCompare);\r\nvar\r\n I, J, P: Integer;\r\n Obj: WideString;\r\nbegin\r\n repeat\r\n I := L;\r\n J := R;\r\n P := (L + R) shr 1;\r\n repeat\r\n Obj := AList.GetString(P);\r\n while AComparator(AList.GetString(I), Obj) < 0 do\r\n Inc(I);\r\n while AComparator(AList.GetString(J), Obj) > 0 do\r\n Dec(J);\r\n if I <= J then\r\n begin\r\n Obj := AList.GetString(I);\r\n AList.SetString(I, AList.GetString(J));\r\n AList.SetString(J, Obj);\r\n if P = I then\r\n P := J\r\n else\r\n if P = J then\r\n P := I;\r\n Inc(I);\r\n Dec(J);\r\n end;\r\n until I > J;\r\n if L < J then\r\n QuickSort(AList, L, J, AComparator);\r\n L := I;\r\n until I >= R;\r\nend;\r\n\r\n{$IFDEF SUPPORTS_UNICODE_STRING}\r\nprocedure QuickSort(const AList: IJclUnicodeStrList; L, R: Integer;\r\n AComparator: TUnicodeStrCompare);\r\nvar\r\n I, J, P: Integer;\r\n Obj: UnicodeString;\r\nbegin\r\n repeat\r\n I := L;\r\n J := R;\r\n P := (L + R) shr 1;\r\n repeat\r\n Obj := AList.GetString(P);\r\n while AComparator(AList.GetString(I), Obj) < 0 do\r\n Inc(I);\r\n while AComparator(AList.GetString(J), Obj) > 0 do\r\n Dec(J);\r\n if I <= J then\r\n begin\r\n Obj := AList.GetString(I);\r\n AList.SetString(I, AList.GetString(J));\r\n AList.SetString(J, Obj);\r\n if P = I then\r\n P := J\r\n else\r\n if P = J then\r\n P := I;\r\n Inc(I);\r\n Dec(J);\r\n end;\r\n until I > J;\r\n if L < J then\r\n QuickSort(AList, L, J, AComparator);\r\n L := I;\r\n until I >= R;\r\nend;\r\n{$ENDIF SUPPORTS_UNICODE_STRING}\r\n\r\nprocedure QuickSort(const AList: IJclSingleList; L, R: Integer;\r\n AComparator: TSingleCompare);\r\nvar\r\n I, J, P: Integer;\r\n Obj: Single;\r\nbegin\r\n repeat\r\n I := L;\r\n J := R;\r\n P := (L + R) shr 1;\r\n repeat\r\n Obj := AList.GetValue(P);\r\n while AComparator(AList.GetValue(I), Obj) < 0 do\r\n Inc(I);\r\n while AComparator(AList.GetValue(J), Obj) > 0 do\r\n Dec(J);\r\n if I <= J then\r\n begin\r\n Obj := AList.GetValue(I);\r\n AList.SetValue(I, AList.GetValue(J));\r\n AList.SetValue(J, Obj);\r\n if P = I then\r\n P := J\r\n else\r\n if P = J then\r\n P := I;\r\n Inc(I);\r\n Dec(J);\r\n end;\r\n until I > J;\r\n if L < J then\r\n QuickSort(AList, L, J, AComparator);\r\n L := I;\r\n until I >= R;\r\nend;\r\n\r\nprocedure QuickSort(const AList: IJclDoubleList; L, R: Integer;\r\n AComparator: TDoubleCompare);\r\nvar\r\n I, J, P: Integer;\r\n Obj: Double;\r\nbegin\r\n repeat\r\n I := L;\r\n J := R;\r\n P := (L + R) shr 1;\r\n repeat\r\n Obj := AList.GetValue(P);\r\n while AComparator(AList.GetValue(I), Obj) < 0 do\r\n Inc(I);\r\n while AComparator(AList.GetValue(J), Obj) > 0 do\r\n Dec(J);\r\n if I <= J then\r\n begin\r\n Obj := AList.GetValue(I);\r\n AList.SetValue(I, AList.GetValue(J));\r\n AList.SetValue(J, Obj);\r\n if P = I then\r\n P := J\r\n else\r\n if P = J then\r\n P := I;\r\n Inc(I);\r\n Dec(J);\r\n end;\r\n until I > J;\r\n if L < J then\r\n QuickSort(AList, L, J, AComparator);\r\n L := I;\r\n until I >= R;\r\nend;\r\n\r\nprocedure QuickSort(const AList: IJclExtendedList; L, R: Integer;\r\n AComparator: TExtendedCompare);\r\nvar\r\n I, J, P: Integer;\r\n Obj: Extended;\r\nbegin\r\n repeat\r\n I := L;\r\n J := R;\r\n P := (L + R) shr 1;\r\n repeat\r\n Obj := AList.GetValue(P);\r\n while AComparator(AList.GetValue(I), Obj) < 0 do\r\n Inc(I);\r\n while AComparator(AList.GetValue(J), Obj) > 0 do\r\n Dec(J);\r\n if I <= J then\r\n begin\r\n Obj := AList.GetValue(I);\r\n AList.SetValue(I, AList.GetValue(J));\r\n AList.SetValue(J, Obj);\r\n if P = I then\r\n P := J\r\n else\r\n if P = J then\r\n P := I;\r\n Inc(I);\r\n Dec(J);\r\n end;\r\n until I > J;\r\n if L < J then\r\n QuickSort(AList, L, J, AComparator);\r\n L := I;\r\n until I >= R;\r\nend;\r\n\r\nprocedure QuickSort(const AList: IJclIntegerList; L, R: Integer;\r\n AComparator: TIntegerCompare);\r\nvar\r\n I, J, P: Integer;\r\n Obj: Integer;\r\nbegin\r\n repeat\r\n I := L;\r\n J := R;\r\n P := (L + R) shr 1;\r\n repeat\r\n Obj := AList.GetValue(P);\r\n while AComparator(AList.GetValue(I), Obj) < 0 do\r\n Inc(I);\r\n while AComparator(AList.GetValue(J), Obj) > 0 do\r\n Dec(J);\r\n if I <= J then\r\n begin\r\n Obj := AList.GetValue(I);\r\n AList.SetValue(I, AList.GetValue(J));\r\n AList.SetValue(J, Obj);\r\n if P = I then\r\n P := J\r\n else\r\n if P = J then\r\n P := I;\r\n Inc(I);\r\n Dec(J);\r\n end;\r\n until I > J;\r\n if L < J then\r\n QuickSort(AList, L, J, AComparator);\r\n L := I;\r\n until I >= R;\r\nend;\r\n\r\nprocedure QuickSort(const AList: IJclCardinalList; L, R: Integer;\r\n AComparator: TCardinalCompare);\r\nvar\r\n I, J, P: Integer;\r\n Obj: Cardinal;\r\nbegin\r\n repeat\r\n I := L;\r\n J := R;\r\n P := (L + R) shr 1;\r\n repeat\r\n Obj := AList.GetValue(P);\r\n while AComparator(AList.GetValue(I), Obj) < 0 do\r\n Inc(I);\r\n while AComparator(AList.GetValue(J), Obj) > 0 do\r\n Dec(J);\r\n if I <= J then\r\n begin\r\n Obj := AList.GetValue(I);\r\n AList.SetValue(I, AList.GetValue(J));\r\n AList.SetValue(J, Obj);\r\n if P = I then\r\n P := J\r\n else\r\n if P = J then\r\n P := I;\r\n Inc(I);\r\n Dec(J);\r\n end;\r\n until I > J;\r\n if L < J then\r\n QuickSort(AList, L, J, AComparator);\r\n L := I;\r\n until I >= R;\r\nend;\r\n\r\nprocedure QuickSort(const AList: IJclInt64List; L, R: Integer;\r\n AComparator: TInt64Compare);\r\nvar\r\n I, J, P: Integer;\r\n Obj: Int64;\r\nbegin\r\n repeat\r\n I := L;\r\n J := R;\r\n P := (L + R) shr 1;\r\n repeat\r\n Obj := AList.GetValue(P);\r\n while AComparator(AList.GetValue(I), Obj) < 0 do\r\n Inc(I);\r\n while AComparator(AList.GetValue(J), Obj) > 0 do\r\n Dec(J);\r\n if I <= J then\r\n begin\r\n Obj := AList.GetValue(I);\r\n AList.SetValue(I, AList.GetValue(J));\r\n AList.SetValue(J, Obj);\r\n if P = I then\r\n P := J\r\n else\r\n if P = J then\r\n P := I;\r\n Inc(I);\r\n Dec(J);\r\n end;\r\n until I > J;\r\n if L < J then\r\n QuickSort(AList, L, J, AComparator);\r\n L := I;\r\n until I >= R;\r\nend;\r\n\r\nprocedure QuickSort(const AList: IJclPtrList; L, R: Integer;\r\n AComparator: TPtrCompare);\r\nvar\r\n I, J, P: Integer;\r\n Obj: Pointer;\r\nbegin\r\n repeat\r\n I := L;\r\n J := R;\r\n P := (L + R) shr 1;\r\n repeat\r\n Obj := AList.GetPointer(P);\r\n while AComparator(AList.GetPointer(I), Obj) < 0 do\r\n Inc(I);\r\n while AComparator(AList.GetPointer(J), Obj) > 0 do\r\n Dec(J);\r\n if I <= J then\r\n begin\r\n Obj := AList.GetPointer(I);\r\n AList.SetPointer(I, AList.GetPointer(J));\r\n AList.SetPointer(J, Obj);\r\n if P = I then\r\n P := J\r\n else\r\n if P = J then\r\n P := I;\r\n Inc(I);\r\n Dec(J);\r\n end;\r\n until I > J;\r\n if L < J then\r\n QuickSort(AList, L, J, AComparator);\r\n L := I;\r\n until I >= R;\r\nend;\r\n\r\nprocedure QuickSort(const AList: IJclList; L, R: Integer;\r\n AComparator: TCompare);\r\nvar\r\n I, J, P: Integer;\r\n Obj: TObject;\r\nbegin\r\n repeat\r\n I := L;\r\n J := R;\r\n P := (L + R) shr 1;\r\n repeat\r\n Obj := AList.GetObject(P);\r\n while AComparator(AList.GetObject(I), Obj) < 0 do\r\n Inc(I);\r\n while AComparator(AList.GetObject(J), Obj) > 0 do\r\n Dec(J);\r\n if I <= J then\r\n begin\r\n Obj := AList.GetObject(I);\r\n AList.SetObject(I, AList.GetObject(J));\r\n AList.SetObject(J, Obj);\r\n if P = I then\r\n P := J\r\n else\r\n if P = J then\r\n P := I;\r\n Inc(I);\r\n Dec(J);\r\n end;\r\n until I > J;\r\n if L < J then\r\n QuickSort(AList, L, J, AComparator);\r\n L := I;\r\n until I >= R;\r\nend;\r\n\r\n\r\nprocedure Sort(const AList: IJclIntfList; First, Last: Integer; AComparator: TIntfCompare);\r\nbegin\r\n IntfSortProc(AList, First, Last, AComparator);\r\nend;\r\n\r\nprocedure Sort(const AList: IJclAnsiStrList; First, Last: Integer; AComparator: TAnsiStrCompare);\r\nbegin\r\n AnsiStrSortProc(AList, First, Last, AComparator);\r\nend;\r\n\r\nprocedure Sort(const AList: IJclWideStrList; First, Last: Integer; AComparator: TWideStrCompare);\r\nbegin\r\n WideStrSortProc(AList, First, Last, AComparator);\r\nend;\r\n\r\n{$IFDEF SUPPORTS_UNICODE_STRING}\r\nprocedure Sort(const AList: IJclUnicodeStrList; First, Last: Integer; AComparator: TUnicodeStrCompare);\r\nbegin\r\n UnicodeStrSortProc(AList, First, Last, AComparator);\r\nend;\r\n{$ENDIF SUPPORTS_UNICODE_STRING}\r\n\r\nprocedure Sort(const AList: IJclSingleList; First, Last: Integer; AComparator: TSingleCompare);\r\nbegin\r\n SingleSortProc(AList, First, Last, AComparator);\r\nend;\r\n\r\nprocedure Sort(const AList: IJclDoubleList; First, Last: Integer; AComparator: TDoubleCompare);\r\nbegin\r\n DoubleSortProc(AList, First, Last, AComparator);\r\nend;\r\n\r\nprocedure Sort(const AList: IJclExtendedList; First, Last: Integer; AComparator: TExtendedCompare);\r\nbegin\r\n ExtendedSortProc(AList, First, Last, AComparator);\r\nend;\r\n\r\nprocedure Sort(const AList: IJclIntegerList; First, Last: Integer; AComparator: TIntegerCompare);\r\nbegin\r\n IntegerSortProc(AList, First, Last, AComparator);\r\nend;\r\n\r\nprocedure Sort(const AList: IJclCardinalList; First, Last: Integer; AComparator: TCardinalCompare);\r\nbegin\r\n CardinalSortProc(AList, First, Last, AComparator);\r\nend;\r\n\r\nprocedure Sort(const AList: IJclInt64List; First, Last: Integer; AComparator: TInt64Compare);\r\nbegin\r\n Int64SortProc(AList, First, Last, AComparator);\r\nend;\r\n\r\nprocedure Sort(const AList: IJclPtrList; First, Last: Integer; AComparator: TPtrCompare);\r\nbegin\r\n PtrSortProc(AList, First, Last, AComparator);\r\nend;\r\n\r\nprocedure Sort(const AList: IJclList; First, Last: Integer; AComparator: TCompare);\r\nbegin\r\n SortProc(AList, First, Last, AComparator);\r\nend;\r\n\r\n{$IFDEF SUPPORTS_GENERICS}\r\n//DOM-IGNORE-BEGIN\r\n\r\nclass procedure TJclAlgorithms.Iterate(const First: IJclIterator; Count: Integer; F: TIterateProcedure);\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := Count - 1 downto 0 do\r\n if First.HasNext then\r\n F(First.Next)\r\n else\r\n Break;\r\nend;\r\n\r\nclass procedure TJclAlgorithms.Apply(const First: IJclIterator; Count: Integer; F: TApplyFunction);\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := Count - 1 downto 0 do\r\n if First.HasNext then\r\n First.SetItem(F(First.Next))\r\n else\r\n Break;\r\nend;\r\n\r\nclass function TJclAlgorithms.Find(const First: IJclIterator; Count: Integer;\r\n const AItem: T; AComparator: TCompare): IJclIterator;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := nil;\r\n for I := Count - 1 downto 0 do\r\n if First.HasNext then\r\n begin\r\n if AComparator(First.Next, AItem) = 0 then\r\n begin\r\n Result := First;\r\n Break;\r\n end;\r\n end\r\n else\r\n Break;\r\nend;\r\n\r\nclass function TJclAlgorithms.Find(const First: IJclIterator; Count: Integer;\r\n const AItem: T; AEqualityComparator: TEqualityCompare): IJclIterator;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := nil;\r\n for I := Count - 1 downto 0 do\r\n if First.HasNext then\r\n begin\r\n if AEqualityComparator(First.Next, AItem) then\r\n begin\r\n Result := First;\r\n Break;\r\n end;\r\n end\r\n else\r\n Break;\r\nend;\r\n\r\nclass function TJclAlgorithms.CountObject(const First: IJclIterator; Count: Integer;\r\n const AItem: T; AComparator: TCompare): Integer;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := 0;\r\n for I := Count - 1 downto 0 do\r\n if First.HasNext then\r\n Inc(Result, Ord(AComparator(First.Next, AItem) = 0))\r\n else\r\n Break;\r\nend;\r\n\r\nclass function TJclAlgorithms.CountObject(const First: IJclIterator; Count: Integer;\r\n const AItem: T; AEqualityComparator: TEqualityCompare): Integer;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := 0;\r\n for I := Count - 1 downto 0 do\r\n if First.HasNext then\r\n Inc(Result, Ord(AEqualityComparator(First.Next, AItem)))\r\n else\r\n Break;\r\nend;\r\n\r\nclass procedure TJclAlgorithms.Copy(const First: IJclIterator; Count: Integer;\r\n const Output: IJclIterator);\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := Count - 1 downto 0 do\r\n if Output.HasNext and First.HasNext then\r\n begin\r\n Output.Next;\r\n Output.SetItem(First.Next);\r\n end\r\n else\r\n Break;\r\nend;\r\n\r\nclass procedure TJclAlgorithms.Generate(const List: IJclList; Count: Integer;\r\n const AItem: T);\r\nvar\r\n I: Integer;\r\nbegin\r\n List.Clear;\r\n for I := 0 to Count - 1 do\r\n List.Add(AItem);\r\nend;\r\n\r\nclass procedure TJclAlgorithms.Fill(const First: IJclIterator; Count: Integer;\r\n const AItem: T);\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := Count - 1 downto 0 do\r\n if First.HasNext then\r\n begin\r\n First.Next;\r\n First.SetItem(AItem);\r\n end\r\n else\r\n Break;\r\nend;\r\n\r\nclass procedure TJclAlgorithms.Reverse(const First, Last: IJclIterator);\r\nvar\r\n Obj: T;\r\nbegin\r\n if not First.HasNext then\r\n Exit;\r\n if not Last.HasPrevious then\r\n Exit;\r\n while First.NextIndex < Last.PreviousIndex do\r\n begin\r\n Obj := First.Next;\r\n Last.Previous;\r\n First.SetItem(Last.GetItem);\r\n Last.SetItem(Obj);\r\n end;\r\nend;\r\n\r\nclass procedure TJclAlgorithms.QuickSort(const AList: IJclList; L, R: Integer;\r\n AComparator: TCompare);\r\nvar\r\n I, J, P: Integer;\r\n Obj: T;\r\nbegin\r\n repeat\r\n I := L;\r\n J := R;\r\n P := (L + R) shr 1;\r\n repeat\r\n Obj := AList.GetItem(P);\r\n while AComparator(AList.GetItem(I), Obj) < 0 do\r\n Inc(I);\r\n while AComparator(AList.GetItem(J), Obj) > 0 do\r\n Dec(J);\r\n if I <= J then\r\n begin\r\n Obj := AList.GetItem(I);\r\n AList.SetItem(I, AList.GetItem(J));\r\n AList.SetItem(J, Obj);\r\n if P = I then\r\n P := J\r\n else\r\n if P = J then\r\n P := I;\r\n Inc(I);\r\n Dec(J);\r\n end;\r\n until I > J;\r\n if L < J then\r\n TJclAlgorithms.QuickSort(AList, L, J, AComparator);\r\n L := I;\r\n until I >= R;\r\nend;\r\n\r\nclass procedure TJclAlgorithms.Sort(const AList: IJclList; First, Last: Integer;\r\n AComparator: TCompare);\r\nbegin\r\n TJclAlgorithms.QuickSort(AList, First, Last, AComparator);\r\nend;\r\n\r\n//DOM-IGNORE-END\r\n{$ENDIF SUPPORTS_GENERICS}\r\n\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend." }, { "path": "External/Jedi/Jcl/source/common/JclAnsiStrings.pas", "content": "{**************************************************************************************************}\r\n{ }\r\n{ Project JEDI Code Library (JCL) }\r\n{ }\r\n{ The contents of this file are subject to the Mozilla Public License Version 1.1 (the \"License\"); }\r\n{ you may not use this file except in compliance with the License. You may obtain a copy of the }\r\n{ License at http://www.mozilla.org/MPL/ }\r\n{ }\r\n{ Software distributed under the License is distributed on an \"AS IS\" basis, WITHOUT WARRANTY OF }\r\n{ ANY KIND, either express or implied. See the License for the specific language governing rights }\r\n{ and limitations under the License. }\r\n{ }\r\n{ The Original Code is JclStrings.pas. }\r\n{ }\r\n{ The Initial Developer of the Original Code is Marcel van Brakel. }\r\n{ Portions created by Marcel van Brakel are Copyright (C) Marcel van Brakel. All rights reserved. }\r\n{ }\r\n{ Contributor(s): }\r\n{ Alexander Radchenko }\r\n{ Andreas Hausladen (ahuser) }\r\n{ Anthony Steele }\r\n{ Azret Botash }\r\n{ Barry Kelly }\r\n{ Huanlin Tsai }\r\n{ Jack N.A. Bakker }\r\n{ Jean-Fabien Connault (cycocrew) }\r\n{ John C Molyneux }\r\n{ Leonard Wennekers }\r\n{ Martin Kimmings }\r\n{ Martin Kubecka }\r\n{ Massimo Maria Ghisalberti }\r\n{ Matthias Thoma (mthoma) }\r\n{ Michael Winter }\r\n{ Nick Hodges }\r\n{ Olivier Sannier (obones) }\r\n{ Patrick Kolla }\r\n{ Pelle F. S. Liljendal }\r\n{ Petr Vones (pvones) }\r\n{ Robert Lee }\r\n{ Robert Marquardt (marquardt) }\r\n{ Robert Rossmair (rrossmair) }\r\n{ Andreas Schmidt }\r\n{ }\r\n{**************************************************************************************************}\r\n{ }\r\n{ Various character and string routines (searching, testing and transforming) }\r\n{ }\r\n{**************************************************************************************************}\r\n{ }\r\n{ Last modified: $Date:: 2012-01-03 20:03:51 +0100 (mar. 03 janv. 2012) $ }\r\n{ Revision: $Rev:: 3668 $ }\r\n{ Author: $Author:: jfudickar $ }\r\n{ }\r\n{**************************************************************************************************}\r\n\r\nunit JclAnsiStrings; // former JclStrings\r\n\r\n{$I jcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n {$IFDEF HAS_UNITSCOPE}\r\n {$IFDEF MSWINDOWS}\r\n Winapi.Windows,\r\n {$ENDIF MSWINDOWS}\r\n System.Classes, System.SysUtils,\r\n {$IFDEF HAS_UNIT_ANSISTRINGS}\r\n System.AnsiStrings,\r\n {$ENDIF HAS_UNIT_ANSISTRINGS}\r\n {$ELSE ~HAS_UNITSCOPE}\r\n {$IFDEF MSWINDOWS}\r\n Windows,\r\n {$ENDIF MSWINDOWS}\r\n Classes, SysUtils,\r\n {$IFDEF HAS_UNIT_ANSISTRINGS}\r\n AnsiStrings,\r\n {$ENDIF HAS_UNIT_ANSISTRINGS}\r\n {$ENDIF ~HAS_UNITSCOPE}\r\n JclBase;\r\n\r\n// Ansi types\r\n\r\ntype\r\n {$IFDEF SUPPORTS_UNICODE}\r\n TJclAnsiStringList = class;\r\n\r\n // Codegear should be the one providing this class, in the AnsiStrings unit.\r\n // It has been requested in QC 65630 but this was closed as \"won't do\".\r\n // So we are providing here a very light implementation that is designed\r\n // to provide the basics, and in no way be a \"copy/paste\" of what is in the RTL.\r\n TJclAnsiStrings = class(TPersistent)\r\n private\r\n FDelimiter: AnsiChar;\r\n FNameValueSeparator: AnsiChar;\r\n FStrictDelimiter: Boolean;\r\n FQuoteChar: AnsiChar;\r\n function GetText: AnsiString;\r\n procedure SetText(const Value: AnsiString);\r\n function GetCommaText: AnsiString; {$IFDEF SUPPORTS_INLINE}inline;{$ENDIF}\r\n procedure SetCommaText(const Value: AnsiString); {$IFDEF SUPPORTS_INLINE}inline;{$ENDIF}\r\n function GetDelimitedText: AnsiString; overload; {$IFDEF SUPPORTS_INLINE}inline;{$ENDIF}\r\n function GetDelimitedText(const ADelimiter: AnsiString; AQuoteChar: AnsiChar): AnsiString; overload;\r\n procedure SetDelimitedText(const Value: AnsiString); overload; {$IFDEF SUPPORTS_INLINE}inline;{$ENDIF}\r\n procedure SetDelimitedText(const Value, ADelimiter: AnsiString; AQuoteChar: AnsiChar); overload;\r\n function ExtractName(const S: AnsiString): AnsiString;\r\n function GetName(Index: Integer): AnsiString;\r\n function GetValue(const Name: AnsiString): AnsiString;\r\n procedure SetValue(const Name, Value: AnsiString);\r\n function GetValueFromIndex(Index: Integer): AnsiString;\r\n procedure SetValueFromIndex(Index: Integer; const Value: AnsiString);\r\n protected\r\n procedure AssignTo(Dest: TPersistent); override;\r\n\r\n procedure Error(const Msg: string; Data: Integer); overload;\r\n procedure Error(Msg: PResStringRec; Data: Integer); overload;\r\n\r\n function GetString(Index: Integer): AnsiString; virtual; abstract;\r\n procedure SetString(Index: Integer; const Value: AnsiString); virtual; abstract;\r\n function GetObject(Index: Integer): TObject; virtual; abstract;\r\n procedure SetObject(Index: Integer; AObject: TObject); virtual; abstract;\r\n\r\n function GetCapacity: Integer; virtual;\r\n procedure SetCapacity(const Value: Integer); virtual;\r\n function GetCount: Integer; virtual; abstract;\r\n function CompareStrings(const S1, S2: AnsiString): Integer; virtual;\r\n public\r\n constructor Create;\r\n\r\n procedure Assign(Source: TPersistent); override;\r\n\r\n function Add(const S: AnsiString): Integer; virtual;\r\n function AddObject(const S: AnsiString; AObject: TObject): Integer; virtual; abstract;\r\n procedure AddStrings(Strings: TJclAnsiStrings); virtual;\r\n procedure Insert(Index: Integer; const S: AnsiString); virtual;\r\n procedure InsertObject(Index: Integer; const S: AnsiString; AObject: TObject); virtual; abstract;\r\n procedure Delete(Index: Integer); virtual; abstract;\r\n procedure Clear; virtual; abstract;\r\n procedure LoadFromFile(const FileName: TFileName); virtual;\r\n procedure LoadFromStream(Stream: TStream); virtual;\r\n procedure SaveToFile(const FileName: TFileName); virtual;\r\n procedure SaveToStream(Stream: TStream); virtual;\r\n procedure BeginUpdate;\r\n procedure EndUpdate;\r\n function IndexOf(const S: AnsiString): Integer; virtual;\r\n function IndexOfName(const Name: AnsiString): Integer; virtual;\r\n function IndexOfObject(AObject: TObject): Integer; virtual;\r\n procedure Exchange(Index1, Index2: Integer); virtual;\r\n\r\n property Delimiter: AnsiChar read FDelimiter write FDelimiter;\r\n property DelimitedText: AnsiString read GetDelimitedText write SetDelimitedText;\r\n property CommaText: AnsiString read GetCommaText write SetCommaText;\r\n property StrictDelimiter: Boolean read FStrictDelimiter write FStrictDelimiter;\r\n property QuoteChar: AnsiChar read FQuoteChar write FQuoteChar;\r\n\r\n property Strings[Index: Integer]: AnsiString read GetString write SetString; default;\r\n property Objects[Index: Integer]: TObject read GetObject write SetObject;\r\n property Text: AnsiString read GetText write SetText;\r\n property Count: Integer read GetCount;\r\n property Capacity: Integer read GetCapacity write SetCapacity;\r\n property Names[Index: Integer]: AnsiString read GetName;\r\n property Values[const Name: AnsiString]: AnsiString read GetValue write SetValue;\r\n property ValueFromIndex[Index: Integer]: AnsiString read GetValueFromIndex write SetValueFromIndex;\r\n property NameValueSeparator: AnsiChar read FNameValueSeparator write FNameValueSeparator;\r\n end;\r\n\r\n TJclAnsiStringListSortCompare = function(List: TJclAnsiStringList; Index1, Index2: Integer): Integer;\r\n\r\n TJclAnsiStringObjectHolder = record\r\n Str: AnsiString;\r\n Obj: TObject;\r\n end;\r\n\r\n TJclAnsiStringList = class(TJclAnsiStrings)\r\n private\r\n FStrings: array of TJclAnsiStringObjectHolder;\r\n FCount: Integer;\r\n FDuplicates: TDuplicates;\r\n FSorted: Boolean;\r\n FCaseSensitive: Boolean;\r\n procedure Grow;\r\n procedure QuickSort(L, R: Integer; SCompare: TJclAnsiStringListSortCompare);\r\n procedure SetSorted(Value: Boolean);\r\n protected\r\n procedure AssignTo(Dest: TPersistent); override;\r\n function GetString(Index: Integer): AnsiString; override;\r\n procedure SetString(Index: Integer; const Value: AnsiString); override;\r\n function GetObject(Index: Integer): TObject; override;\r\n procedure SetObject(Index: Integer; AObject: TObject); override;\r\n function GetCapacity: Integer; override;\r\n procedure SetCapacity(const Value: Integer); override;\r\n function GetCount: Integer; override;\r\n function CompareStrings(const S1, S2: AnsiString): Integer; override;\r\n public\r\n constructor Create;\r\n\r\n function AddObject(const S: AnsiString; AObject: TObject): Integer; override;\r\n procedure Assign(Source: TPersistent); override;\r\n procedure InsertObject(Index: Integer; const S: AnsiString; AObject: TObject); override;\r\n procedure Delete(Index: Integer); override;\r\n function Find(const S: AnsiString; var Index: Integer): Boolean; virtual;\r\n procedure CustomSort(Compare: TJclAnsiStringListSortCompare); virtual;\r\n procedure Sort; virtual;\r\n procedure Clear; override;\r\n\r\n property CaseSensitive: Boolean read FCaseSensitive write FCaseSensitive;\r\n property Duplicates: TDuplicates read FDuplicates write FDuplicates;\r\n property Sorted: Boolean read FSorted write SetSorted;\r\n end;\r\n {$ELSE ~SUPPORTS_UNICODE}\r\n TJclAnsiStrings = Classes.TStrings;\r\n TJclAnsiStringList = Classes.TStringList;\r\n {$ENDIF ~SUPPORTS_UNICODE}\r\n\r\n TAnsiStrings = TJclAnsiStrings;\r\n TAnsiStringList = TJclAnsiStringList;\r\n\r\n// Exceptions\r\ntype\r\n EJclAnsiStringError = class(EJclError);\r\n EJclAnsiStringListError = class(EJclAnsiStringError);\r\n\r\n// Character constants and sets\r\n\r\nconst\r\n // Misc. often used character definitions\r\n AnsiNull = AnsiChar(#0);\r\n AnsiSoh = AnsiChar(#1);\r\n AnsiStx = AnsiChar(#2);\r\n AnsiEtx = AnsiChar(#3);\r\n AnsiEot = AnsiChar(#4);\r\n AnsiEnq = AnsiChar(#5);\r\n AnsiAck = AnsiChar(#6);\r\n AnsiBell = AnsiChar(#7);\r\n AnsiBackspace = AnsiChar(#8);\r\n AnsiTab = AnsiChar(#9);\r\n AnsiLineFeed = AnsiChar(#10);\r\n AnsiVerticalTab = AnsiChar(#11);\r\n AnsiFormFeed = AnsiChar(#12);\r\n AnsiCarriageReturn = AnsiChar(#13);\r\n AnsiCrLf = AnsiString(#13#10);\r\n AnsiSo = AnsiChar(#14);\r\n AnsiSi = AnsiChar(#15);\r\n AnsiDle = AnsiChar(#16);\r\n AnsiDc1 = AnsiChar(#17);\r\n AnsiDc2 = AnsiChar(#18);\r\n AnsiDc3 = AnsiChar(#19);\r\n AnsiDc4 = AnsiChar(#20);\r\n AnsiNak = AnsiChar(#21);\r\n AnsiSyn = AnsiChar(#22);\r\n AnsiEtb = AnsiChar(#23);\r\n AnsiCan = AnsiChar(#24);\r\n AnsiEm = AnsiChar(#25);\r\n AnsiEndOfFile = AnsiChar(#26);\r\n AnsiEscape = AnsiChar(#27);\r\n AnsiFs = AnsiChar(#28);\r\n AnsiGs = AnsiChar(#29);\r\n AnsiRs = AnsiChar(#30);\r\n AnsiUs = AnsiChar(#31);\r\n AnsiSpace = AnsiChar(' ');\r\n AnsiComma = AnsiChar(',');\r\n AnsiBackslash = AnsiChar('\\');\r\n AnsiForwardSlash = AnsiChar('/');\r\n\r\n AnsiDoubleQuote = AnsiChar('\"');\r\n AnsiSingleQuote = AnsiChar('''');\r\n\r\n {$IFDEF MSWINDOWS}\r\n AnsiLineBreak = AnsiCrLf;\r\n {$ENDIF MSWINDOWS}\r\n {$IFDEF UNIX}\r\n AnsiLineBreak = AnsiLineFeed;\r\n {$ENDIF UNIX}\r\n\r\n AnsiSignMinus = AnsiChar('-');\r\n AnsiSignPlus = AnsiChar('+');\r\n\r\n // Misc. character sets\r\n\r\n AnsiWhiteSpace = [AnsiTab, AnsiLineFeed, AnsiVerticalTab,\r\n AnsiFormFeed, AnsiCarriageReturn, AnsiSpace];\r\n AnsiSigns = [AnsiSignMinus, AnsiSignPlus];\r\n AnsiUppercaseLetters = ['A'..'Z'];\r\n AnsiLowercaseLetters = ['a'..'z'];\r\n AnsiLetters = ['A'..'Z', 'a'..'z'];\r\n AnsiDecDigits = ['0'..'9'];\r\n AnsiOctDigits = ['0'..'7'];\r\n AnsiHexDigits = ['0'..'9', 'A'..'F', 'a'..'f'];\r\n AnsiValidIdentifierLetters = ['0'..'9', 'A'..'Z', 'a'..'z', '_'];\r\n\r\nconst\r\n // CharType return values\r\n C1_UPPER = $0001; // Uppercase\r\n C1_LOWER = $0002; // Lowercase\r\n C1_DIGIT = $0004; // Decimal digits\r\n C1_SPACE = $0008; // Space characters\r\n C1_PUNCT = $0010; // Punctuation\r\n C1_CNTRL = $0020; // Control characters\r\n C1_BLANK = $0040; // Blank characters\r\n C1_XDIGIT = $0080; // Hexadecimal digits\r\n C1_ALPHA = $0100; // Any linguistic character: alphabetic, syllabary, or ideographic\r\n\r\n {$IFDEF MSWINDOWS}\r\n {$IFDEF SUPPORTS_EXTSYM}\r\n {$EXTERNALSYM C1_UPPER}\r\n {$EXTERNALSYM C1_LOWER}\r\n {$EXTERNALSYM C1_DIGIT}\r\n {$EXTERNALSYM C1_SPACE}\r\n {$EXTERNALSYM C1_PUNCT}\r\n {$EXTERNALSYM C1_CNTRL}\r\n {$EXTERNALSYM C1_BLANK}\r\n {$EXTERNALSYM C1_XDIGIT}\r\n {$EXTERNALSYM C1_ALPHA}\r\n {$ENDIF SUPPORTS_EXTSYM}\r\n {$ENDIF MSWINDOWS}\r\n\r\n// String Test Routines\r\nfunction StrIsAlpha(const S: AnsiString): Boolean;\r\nfunction StrIsAlphaNum(const S: AnsiString): Boolean;\r\nfunction StrIsAlphaNumUnderscore(const S: AnsiString): Boolean;\r\nfunction StrContainsChars(const S: AnsiString; Chars: TSysCharSet; CheckAll: Boolean): Boolean;\r\nfunction StrConsistsOfNumberChars(const S: AnsiString): Boolean;\r\nfunction StrIsDigit(const S: AnsiString): Boolean;\r\nfunction StrIsSubset(const S: AnsiString; const ValidChars: TSysCharSet): Boolean;\r\nfunction StrSame(const S1, S2: AnsiString): Boolean;\r\n\r\n// String Transformation Routines\r\nfunction StrCenter(const S: AnsiString; L: SizeInt; C: AnsiChar = ' '): AnsiString;\r\nfunction StrCharPosLower(const S: AnsiString; CharPos: SizeInt): AnsiString;\r\nfunction StrCharPosUpper(const S: AnsiString; CharPos: SizeInt): AnsiString;\r\nfunction StrDoubleQuote(const S: AnsiString): AnsiString;\r\nfunction StrEnsureNoPrefix(const Prefix, Text: AnsiString): AnsiString;\r\nfunction StrEnsureNoSuffix(const Suffix, Text: AnsiString): AnsiString;\r\nfunction StrEnsurePrefix(const Prefix, Text: AnsiString): AnsiString;\r\nfunction StrEnsureSuffix(const Suffix, Text: AnsiString): AnsiString;\r\nfunction StrEscapedToString(const S: AnsiString): AnsiString;\r\nfunction StrLower(const S: AnsiString): AnsiString;\r\nprocedure StrLowerInPlace(var S: AnsiString);\r\nprocedure StrLowerBuff(S: PAnsiChar);\r\nprocedure StrMove(var Dest: AnsiString; const Source: AnsiString; const ToIndex,\r\n FromIndex, Count: SizeInt);\r\nfunction StrPadLeft(const S: AnsiString; Len: SizeInt; C: AnsiChar = AnsiSpace): AnsiString;\r\nfunction StrPadRight(const S: AnsiString; Len: SizeInt; C: AnsiChar = AnsiSpace): AnsiString;\r\nfunction StrProper(const S: AnsiString): AnsiString;\r\nprocedure StrProperBuff(S: PAnsiChar);\r\nfunction StrQuote(const S: AnsiString; C: AnsiChar): AnsiString;\r\nfunction StrRemoveChars(const S: AnsiString; const Chars: TSysCharSet): AnsiString;\r\nfunction StrKeepChars(const S: AnsiString; const Chars: TSysCharSet): AnsiString;\r\nprocedure StrReplace(var S: AnsiString; const Search, Replace: AnsiString; Flags: TReplaceFlags = []);\r\nfunction StrReplaceChar(const S: AnsiString; const Source, Replace: AnsiChar): AnsiString;\r\nfunction StrReplaceChars(const S: AnsiString; const Chars: TSysCharSet; Replace: AnsiChar): AnsiString;\r\nfunction StrReplaceButChars(const S: AnsiString; const Chars: TSysCharSet; Replace: AnsiChar): AnsiString;\r\nfunction StrRepeat(const S: AnsiString; Count: SizeInt): AnsiString;\r\nfunction StrRepeatLength(const S: AnsiString; const L: SizeInt): AnsiString;\r\nfunction StrReverse(const S: AnsiString): AnsiString;\r\nprocedure StrReverseInPlace(var S: AnsiString);\r\nfunction StrSingleQuote(const S: AnsiString): AnsiString;\r\nprocedure StrSkipChars(var S: PAnsiChar; const Chars: TSysCharSet); overload;\r\nprocedure StrSkipChars(const S: AnsiString; var Index: SizeInt; const Chars: TSysCharSet); overload;\r\nfunction StrSmartCase(const S: AnsiString; Delimiters: TSysCharSet): AnsiString;\r\nfunction StrStringToEscaped(const S: AnsiString): AnsiString;\r\nfunction StrStripNonNumberChars(const S: AnsiString): AnsiString;\r\nfunction StrToHex(const Source: AnsiString): AnsiString;\r\nfunction StrTrimCharLeft(const S: AnsiString; C: AnsiChar): AnsiString;\r\nfunction StrTrimCharsLeft(const S: AnsiString; const Chars: TSysCharSet): AnsiString;\r\nfunction StrTrimCharRight(const S: AnsiString; C: AnsiChar): AnsiString;\r\nfunction StrTrimCharsRight(const S: AnsiString; const Chars: TSysCharSet): AnsiString;\r\nfunction StrTrimQuotes(const S: AnsiString): AnsiString; overload;\r\nfunction StrTrimQuotes(const S: AnsiString; QuoteChar: AnsiChar): AnsiString; overload;\r\nfunction StrUpper(const S: AnsiString): AnsiString;\r\nprocedure StrUpperInPlace(var S: AnsiString);\r\nprocedure StrUpperBuff(S: PAnsiChar);\r\n\r\n{$IFDEF MSWINDOWS}\r\nfunction StrOemToAnsi(const S: AnsiString): AnsiString;\r\nfunction StrAnsiToOem(const S: AnsiString): AnsiString;\r\n{$ENDIF MSWINDOWS}\r\n\r\n// String Management\r\nprocedure StrAddRef(var S: AnsiString);\r\nprocedure StrDecRef(var S: AnsiString);\r\nfunction StrLength(const S: AnsiString): Longint;\r\nfunction StrRefCount(const S: AnsiString): Longint;\r\nprocedure StrResetLength(var S: AnsiString);\r\n\r\n// String Search and Replace Routines\r\nfunction StrCharCount(const S: AnsiString; C: AnsiChar): SizeInt;\r\nfunction StrCharsCount(const S: AnsiString; Chars: TSysCharSet): SizeInt;\r\nfunction StrStrCount(const S, SubS: AnsiString): SizeInt;\r\nfunction StrCompare(const S1, S2: AnsiString; CaseSensitive: Boolean = False): SizeInt;\r\nfunction StrCompareRangeEx(const S1, S2: AnsiString; Index, Count: SizeInt; CaseSensitive: Boolean = False): SizeInt;\r\nfunction StrCompareRange(const S1, S2: AnsiString; Index, Count: SizeInt; CaseSensitive: Boolean = True): SizeInt;\r\nfunction StrRepeatChar(C: AnsiChar; Count: SizeInt): AnsiString;\r\nfunction StrFind(const Substr, S: AnsiString; const Index: SizeInt = 1): SizeInt;\r\nfunction StrHasPrefix(const S: AnsiString; const Prefixes: array of AnsiString): Boolean;\r\nfunction StrHasSuffix(const S: AnsiString; const Suffixes: array of AnsiString): Boolean;\r\nfunction StrIHasPrefix(const S: AnsiString; const Prefixes: array of AnsiString): Boolean;\r\nfunction StrIHasSuffix(const S: AnsiString; const Suffixes: array of AnsiString): Boolean;\r\nfunction StrIndex(const S: AnsiString; const List: array of AnsiString; CaseSensitive: Boolean = False): SizeInt;\r\nfunction StrILastPos(const SubStr, S: AnsiString): SizeInt;\r\nfunction StrIPos(const SubStr, S: AnsiString): SizeInt;\r\nfunction StrIPrefixIndex(const S: AnsiString; const Prefixes: array of AnsiString): SizeInt;\r\nfunction StrIsOneOf(const S: AnsiString; const List: array of AnsiString): Boolean;\r\nfunction StrISuffixIndex(const S: AnsiString; const Suffixes: array of AnsiString): SizeInt;\r\nfunction StrLastPos(const SubStr, S: AnsiString): SizeInt;\r\nfunction StrMatch(const Substr, S: AnsiString; Index: SizeInt = 1): SizeInt;\r\nfunction StrMatches(const Substr, S: AnsiString; const Index: SizeInt = 1): Boolean;\r\nfunction StrNIPos(const S, SubStr: AnsiString; N: SizeInt): SizeInt;\r\nfunction StrNPos(const S, SubStr: AnsiString; N: SizeInt): SizeInt;\r\nfunction StrPrefixIndex(const S: AnsiString; const Prefixes: array of AnsiString): SizeInt;\r\nfunction StrSearch(const Substr, S: AnsiString; const Index: SizeInt = 1): SizeInt;\r\nfunction StrSuffixIndex(const S: AnsiString; const Suffixes: array of AnsiString): SizeInt;\r\n\r\n// String Extraction\r\n// String Extraction\r\n// Returns the String before SubStr\r\nfunction StrAfter(const SubStr, S: AnsiString): AnsiString;\r\n/// Returns the AnsiString after SubStr\r\nfunction StrBefore(const SubStr, S: AnsiString): AnsiString;\r\n/// Splits a AnsiString at SubStr, returns true when SubStr is found, Left contains the\r\n/// AnsiString before the SubStr and Rigth the AnsiString behind SubStr\r\nfunction StrSplit(const SubStr, S: AnsiString;var Left, Right : AnsiString): boolean;\r\n/// Returns the AnsiString between Start and Stop\r\nfunction StrBetween(const S: AnsiString; const Start, Stop: AnsiChar): AnsiString;\r\n/// Returns the left N characters of the AnsiString\r\nfunction StrChopRight(const S: AnsiString; N: SizeInt): AnsiString;\r\n/// Returns the left Count characters of the AnsiString\r\nfunction StrLeft(const S: AnsiString; Count: SizeInt): AnsiString;\r\n/// Returns the AnsiString starting from position Start for the Count Characters\r\nfunction StrMid(const S: AnsiString; Start, Count: SizeInt): AnsiString;\r\n/// Returns the AnsiString starting from position N to the end\r\nfunction StrRestOf(const S: AnsiString; N: SizeInt): AnsiString;\r\n/// Returns the right Count characters of the AnsiString\r\nfunction StrRight(const S: AnsiString; Count: SizeInt): AnsiString;\r\n\r\n// Character Test Routines\r\nfunction CharEqualNoCase(const C1, C2: AnsiChar): Boolean; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\nfunction CharIsAlpha(const C: AnsiChar): Boolean; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\nfunction CharIsAlphaNum(const C: AnsiChar): Boolean; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\nfunction CharIsBlank(const C: AnsiChar): Boolean; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\nfunction CharIsControl(const C: AnsiChar): Boolean; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\nfunction CharIsDelete(const C: AnsiChar): Boolean; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\nfunction CharIsDigit(const C: AnsiChar): Boolean; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\nfunction CharIsFracDigit(const C: AnsiChar): Boolean; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\nfunction CharIsHexDigit(const C: AnsiChar): Boolean; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\nfunction CharIsLower(const C: AnsiChar): Boolean; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\nfunction CharIsNumberChar(const C: AnsiChar): Boolean; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\nfunction CharIsNumber(const C: AnsiChar): Boolean; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\nfunction CharIsPrintable(const C: AnsiChar): Boolean; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\nfunction CharIsPunctuation(const C: AnsiChar): Boolean; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\nfunction CharIsReturn(const C: AnsiChar): Boolean; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\nfunction CharIsSpace(const C: AnsiChar): Boolean; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\nfunction CharIsUpper(const C: AnsiChar): Boolean; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\nfunction CharIsValidIdentifierLetter(const C: AnsiChar): Boolean; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\nfunction CharIsWhiteSpace(const C: AnsiChar): Boolean; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\nfunction CharIsWildcard(const C: AnsiChar): Boolean; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\nfunction CharType(const C: AnsiChar): Word;\r\n\r\n// Character Transformation Routines\r\nfunction CharHex(const C: AnsiChar): Byte;\r\nfunction CharLower(const C: AnsiChar): AnsiChar;\r\nfunction CharUpper(const C: AnsiChar): AnsiChar;\r\nfunction CharToggleCase(const C: AnsiChar): AnsiChar;\r\n\r\n// Character Search and Replace\r\nfunction CharPos(const S: AnsiString; const C: AnsiChar; const Index: SizeInt = 1): SizeInt;\r\nfunction CharLastPos(const S: AnsiString; const C: AnsiChar; const Index: SizeInt = 1): SizeInt;\r\nfunction CharIPos(const S: AnsiString; C: AnsiChar; const Index: SizeInt = 1): SizeInt;\r\nfunction CharReplace(var S: AnsiString; const Search, Replace: AnsiChar): SizeInt;\r\n\r\n// PCharVector\r\ntype\r\n PAnsiCharVector = ^PAnsiChar;\r\n\r\nfunction StringsToPCharVector(var Dest: PAnsiCharVector; const Source: TJclAnsiStrings): PAnsiCharVector;\r\nfunction PCharVectorCount(Source: PAnsiCharVector): SizeInt;\r\nprocedure PCharVectorToStrings(const Dest: TJclAnsiStrings; Source: PAnsiCharVector);\r\nprocedure FreePCharVector(var Dest: PAnsiCharVector);\r\n\r\n// MultiSz Routines\r\ntype\r\n PAnsiMultiSz = PAnsiChar;\r\n\r\nfunction StringsToMultiSz(var Dest: PAnsiMultiSz; const Source: TJclAnsiStrings): PAnsiMultiSz;\r\nprocedure MultiSzToStrings(const Dest: TJclAnsiStrings; const Source: PAnsiMultiSz);\r\nfunction MultiSzLength(const Source: PAnsiMultiSz): SizeInt;\r\nprocedure AllocateMultiSz(var Dest: PAnsiMultiSz; Len: SizeInt);\r\nprocedure FreeMultiSz(var Dest: PAnsiMultiSz);\r\nfunction MultiSzDup(const Source: PAnsiMultiSz): PAnsiMultiSz;\r\n\r\n// TJclAnsiStrings Manipulation\r\nprocedure StrIToStrings(S, Sep: AnsiString; const List: TJclAnsiStrings; const AllowEmptyString: Boolean = True);\r\nprocedure StrToStrings(S, Sep: AnsiString; const List: TJclAnsiStrings; const AllowEmptyString: Boolean = True);\r\nfunction StringsToStr(const List: TJclAnsiStrings; const Sep: AnsiString; const AllowEmptyString: Boolean = True): AnsiString;\r\nprocedure TrimStrings(const List: TJclAnsiStrings; DeleteIfEmpty: Boolean = True);\r\nprocedure TrimStringsRight(const List: TJclAnsiStrings; DeleteIfEmpty: Boolean = True);\r\nprocedure TrimStringsLeft(const List: TJclAnsiStrings; DeleteIfEmpty: Boolean = True);\r\nfunction AddStringToStrings(const S: AnsiString; Strings: TJclAnsiStrings; const Unique: Boolean): Boolean;\r\n\r\n// Miscellaneous\r\n// (OF) moved to JclSysUtils\r\n//function BooleanToStr(B: Boolean): AnsiString;\r\nfunction FileToString(const FileName: TFileName): AnsiString;\r\nprocedure StringToFile(const FileName: TFileName; const Contents: AnsiString; Append: Boolean = False);\r\nfunction StrToken(var S: AnsiString; Separator: AnsiChar): AnsiString;\r\nprocedure StrTokens(const S: AnsiString; const List: TJclAnsiStrings);\r\nprocedure StrTokenToStrings(S: AnsiString; Separator: AnsiChar; const List: TJclAnsiStrings);\r\nfunction StrWord(const S: AnsiString; var Index: SizeInt; out Word: AnsiString): Boolean; overload;\r\nfunction StrWord(var S: PAnsiChar; out Word: AnsiString): Boolean; overload;\r\nfunction StrIdent(const S: AnsiString; var Index: SizeInt; out Ident: AnsiString): Boolean; overload;\r\nfunction StrIdent(var S: PAnsiChar; out Ident: AnsiString): Boolean; overload;\r\nfunction StrToFloatSafe(const S: AnsiString): Float;\r\nfunction StrToIntSafe(const S: AnsiString): Integer;\r\nprocedure StrNormIndex(const StrLen: SizeInt; var Index: SizeInt; var Count: SizeInt); overload;\r\n\r\nfunction ArrayOf(List: TJclAnsiStrings): TDynStringArray; overload;\r\n\r\nfunction AnsiCompareNaturalStr(const S1, S2: AnsiString): SizeInt;\r\nfunction AnsiCompareNaturalText(const S1, S2: AnsiString): SizeInt;\r\n\r\n// internal structures published to make function inlining working\r\nconst\r\n AnsiCharCount = Ord(High(AnsiChar)) + 1; // # of chars in one set\r\n AnsiLoOffset = AnsiCharCount * 0; // offset to lower case chars\r\n AnsiUpOffset = AnsiCharCount * 1; // offset to upper case chars\r\n AnsiReOffset = AnsiCharCount * 2; // offset to reverse case chars\r\n AnsiCaseMapSize = AnsiCharCount * 3; // # of chars is a table\r\n\r\nvar\r\n AnsiCaseMap: array [0..AnsiCaseMapSize - 1] of AnsiChar; // case mappings\r\n AnsiCaseMapReady: Boolean = False; // true if case map exists\r\n AnsiCharTypes: array [AnsiChar] of Word;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jcl.svn.sourceforge.net/svnroot/jcl/tags/JCL-2.4-Build4571/jcl/source/common/JclAnsiStrings.pas $';\r\n Revision: '$Revision: 3668 $';\r\n Date: '$Date: 2012-01-03 20:03:51 +0100 (mar. 03 janv. 2012) $';\r\n LogPath: 'JCL\\source\\common';\r\n Extra: '';\r\n Data: nil\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n {$IFDEF HAS_UNIT_LIBC}\r\n Libc,\r\n {$ENDIF HAS_UNIT_LIBC}\r\n {$IFDEF SUPPORTS_UNICODE}\r\n RtlConsts,\r\n {$ENDIF SUPPORTS_UNICODE}\r\n JclLogic, JclResources, JclStreams, JclSynch, JclSysUtils;\r\n\r\n//=== Internal ===============================================================\r\n\r\ntype\r\n TAnsiStrRec = packed record\r\n RefCount: SizeInt;\r\n Length: SizeInt;\r\n end;\r\n PAnsiStrRec = ^TAnsiStrRec;\r\n\r\nconst\r\n AnsiStrRecSize = SizeOf(TAnsiStrRec); // size of the AnsiString header rec\r\n\r\nprocedure LoadCharTypes;\r\nvar\r\n CurrChar: AnsiChar;\r\n CurrType: Word;\r\nbegin\r\n for CurrChar := Low(AnsiChar) to High(AnsiChar) do\r\n begin\r\n {$IFDEF MSWINDOWS}\r\n CurrType := 0;\r\n GetStringTypeExA(LOCALE_USER_DEFAULT, CT_CTYPE1, @CurrChar, SizeOf(AnsiChar), CurrType);\r\n {$DEFINE CHAR_TYPES_INITIALIZED}\r\n {$ENDIF MSWINDOWS}\r\n {$IFDEF LINUX}\r\n CurrType := 0;\r\n if isupper(Byte(CurrChar)) <> 0 then\r\n CurrType := CurrType or C1_UPPER;\r\n if islower(Byte(CurrChar)) <> 0 then\r\n CurrType := CurrType or C1_LOWER;\r\n if isdigit(Byte(CurrChar)) <> 0 then\r\n CurrType := CurrType or C1_DIGIT;\r\n if isspace(Byte(CurrChar)) <> 0 then\r\n CurrType := CurrType or C1_SPACE;\r\n if ispunct(Byte(CurrChar)) <> 0 then\r\n CurrType := CurrType or C1_PUNCT;\r\n if iscntrl(Byte(CurrChar)) <> 0 then\r\n CurrType := CurrType or C1_CNTRL;\r\n if isblank(Byte(CurrChar)) <> 0 then\r\n CurrType := CurrType or C1_BLANK;\r\n if isxdigit(Byte(CurrChar)) <> 0 then\r\n CurrType := CurrType or C1_XDIGIT;\r\n if isalpha(Byte(CurrChar)) <> 0 then\r\n CurrType := CurrType or C1_ALPHA;\r\n {$DEFINE CHAR_TYPES_INITIALIZED}\r\n {$ENDIF LINUX}\r\n AnsiCharTypes[CurrChar] := CurrType;\r\n {$IFNDEF CHAR_TYPES_INITIALIZED}\r\n Implement case map initialization here\r\n {$ENDIF ~CHAR_TYPES_INITIALIZED}\r\n end;\r\nend;\r\n\r\nprocedure LoadCaseMap;\r\nvar\r\n CurrChar, UpCaseChar, LoCaseChar, ReCaseChar: AnsiChar;\r\nbegin\r\n if not AnsiCaseMapReady then\r\n begin\r\n for CurrChar := Low(AnsiChar) to High(AnsiChar) do\r\n begin\r\n {$IFDEF MSWINDOWS}\r\n LoCaseChar := CurrChar;\r\n UpCaseChar := CurrChar;\r\n {$IFDEF HAS_UNITSCOPE}Winapi.{$ENDIF}Windows.CharLowerBuffA(@LoCaseChar, 1);\r\n {$IFDEF HAS_UNITSCOPE}Winapi.{$ENDIF}Windows.CharUpperBuffA(@UpCaseChar, 1);\r\n {$DEFINE CASE_MAP_INITIALIZED}\r\n {$ENDIF MSWINDOWS}\r\n {$IFDEF LINUX}\r\n LoCaseChar := AnsiChar(tolower(Byte(CurrChar)));\r\n UpCaseChar := AnsiChar(toupper(Byte(CurrChar)));\r\n {$DEFINE CASE_MAP_INITIALIZED}\r\n {$ENDIF LINUX}\r\n {$IFNDEF CASE_MAP_INITIALIZED}\r\n Implement case map initialization here\r\n {$ENDIF ~CASE_MAP_INITIALIZED}\r\n if CharIsUpper(CurrChar) then\r\n ReCaseChar := LoCaseChar\r\n else\r\n if CharIsLower(CurrChar) then\r\n ReCaseChar := UpCaseChar\r\n else\r\n ReCaseChar := CurrChar;\r\n AnsiCaseMap[Ord(CurrChar) + AnsiLoOffset] := LoCaseChar;\r\n AnsiCaseMap[Ord(CurrChar) + AnsiUpOffset] := UpCaseChar;\r\n AnsiCaseMap[Ord(CurrChar) + AnsiReOffset] := ReCaseChar;\r\n end;\r\n AnsiCaseMapReady := True;\r\n end;\r\nend;\r\n\r\n// Uppercases or Lowercases a give AnsiString depending on the\r\n// passed offset. (UpOffset or LoOffset)\r\n\r\nprocedure StrCase(var Str: AnsiString; const Offset: SizeInt);\r\nvar\r\n P: PAnsiChar;\r\n I, L: SizeInt;\r\nbegin\r\n if Str <> '' then\r\n begin\r\n UniqueString(Str);\r\n P := PAnsiChar(Str);\r\n L := Length(Str);\r\n for I := 1 to L do\r\n begin\r\n P^ := AnsiCaseMap[Offset + Ord(P^)];\r\n Inc(P);\r\n end;\r\n end;\r\nend;\r\n\r\n// Internal utility function\r\n// Uppercases or Lowercases a give null terminated string depending on the\r\n// passed offset. (UpOffset or LoOffset)\r\n\r\nprocedure StrCaseBuff(S: PAnsiChar; const Offset: SizeInt);\r\nbegin\r\n if (S <> nil) and (S^ <> #0) then\r\n begin\r\n repeat\r\n S^ := AnsiCaseMap[Offset + Ord(S^)];\r\n Inc(S);\r\n until S^ = #0;\r\n end;\r\nend;\r\n\r\n{$IFDEF SUPPORTS_UNICODE}\r\n\r\n//=== { TJclAnsiStrings } ====================================================\r\n\r\nconstructor TJclAnsiStrings.Create;\r\nbegin\r\n inherited Create;\r\n\r\n FDelimiter := ',';\r\n FNameValueSeparator := '=';\r\n FQuoteChar := '\"';\r\n FStrictDelimiter := False;\r\nend;\r\n\r\nprocedure TJclAnsiStrings.Assign(Source: TPersistent);\r\nvar\r\n StringsSource: TStrings;\r\n I: Integer;\r\nbegin\r\n if Source is TStrings then\r\n begin\r\n StringsSource := TStrings(Source);\r\n BeginUpdate;\r\n try\r\n Clear;\r\n FDelimiter := AnsiChar(StringsSource.Delimiter);\r\n FNameValueSeparator := AnsiChar(StringsSource.NameValueSeparator);\r\n for I := 0 to StringsSource.Count - 1 do\r\n AddObject(AnsiString(StringsSource.Strings[I]), StringsSource.Objects[I]);\r\n finally\r\n EndUpdate;\r\n end;\r\n end\r\n else\r\n inherited Assign(Source);\r\nend;\r\n\r\nprocedure TJclAnsiStrings.AssignTo(Dest: TPersistent);\r\nvar\r\n StringsDest: TStrings;\r\n AnsiStringsDest: TJclAnsiStrings;\r\n I: Integer;\r\nbegin\r\n if Dest is TStrings then\r\n begin\r\n StringsDest := TStrings(Dest);\r\n StringsDest.BeginUpdate;\r\n try\r\n StringsDest.Clear;\r\n StringsDest.Delimiter := Char(Delimiter);\r\n StringsDest.NameValueSeparator := Char(NameValueSeparator);\r\n for I := 0 to Count - 1 do\r\n StringsDest.AddObject(string(Strings[I]), Objects[I]);\r\n finally\r\n StringsDest.EndUpdate;\r\n end;\r\n end\r\n else\r\n if Dest is TJclAnsiStrings then\r\n begin\r\n AnsiStringsDest := TJclAnsiStrings(Dest);\r\n BeginUpdate;\r\n try\r\n AnsiStringsDest.Clear;\r\n AnsiStringsDest.FNameValueSeparator := FNameValueSeparator;\r\n AnsiStringsDest.FDelimiter := FDelimiter;\r\n for I := 0 to Count - 1 do\r\n AnsiStringsDest.AddObject(Strings[I], Objects[I]);\r\n finally\r\n EndUpdate;\r\n end;\r\n end\r\n else\r\n inherited AssignTo(Dest);\r\nend;\r\n\r\nfunction TJclAnsiStrings.Add(const S: AnsiString): Integer;\r\nbegin\r\n Result := AddObject(S, nil);\r\nend;\r\n\r\nprocedure TJclAnsiStrings.AddStrings(Strings: TJclAnsiStrings);\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := 0 to Strings.Count - 1 do\r\n Add(Strings.Strings[I]);\r\nend;\r\n\r\nprocedure TJclAnsiStrings.Error(const Msg: string; Data: Integer);\r\nbegin\r\n raise EJclAnsiStringListError.CreateFmt(Msg, [Data]);\r\nend;\r\n\r\nprocedure TJclAnsiStrings.Error(Msg: PResStringRec; Data: Integer);\r\nbegin\r\n Error(LoadResString(Msg), Data);\r\nend;\r\n\r\nfunction TJclAnsiStrings.CompareStrings(const S1, S2: AnsiString): Integer;\r\nbegin\r\n Result := CompareStr(S1, S2);\r\nend;\r\n\r\nfunction TJclAnsiStrings.IndexOf(const S: AnsiString): Integer;\r\nbegin\r\n for Result := 0 to Count - 1 do\r\n if CompareStrings(Strings[Result], S) = 0 then\r\n Exit;\r\n Result := -1;\r\nend;\r\n\r\nfunction TJclAnsiStrings.IndexOfName(const Name: AnsiString): Integer;\r\nvar\r\n P: Integer;\r\n S: AnsiString;\r\nbegin\r\n for Result := 0 to Count - 1 do\r\n begin\r\n S := Strings[Result];\r\n P := AnsiPos(NameValueSeparator, S);\r\n if (P > 0) and (CompareStrings(Copy(S, 1, P - 1), Name) = 0) then\r\n Exit;\r\n end;\r\n Result := -1;\r\nend;\r\n\r\nfunction TJclAnsiStrings.IndexOfObject(AObject: TObject): Integer;\r\nbegin\r\n for Result := 0 to Count - 1 do\r\n if Objects[Result] = AObject then\r\n Exit;\r\n Result := -1;\r\nend;\r\n\r\nprocedure TJclAnsiStrings.Exchange(Index1, Index2: Integer);\r\nvar\r\n TempString: AnsiString;\r\n TempObject: TObject;\r\nbegin\r\n BeginUpdate;\r\n try\r\n TempString := Strings[Index1];\r\n TempObject := Objects[Index1];\r\n Strings[Index1] := Strings[Index2];\r\n Objects[Index1] := Objects[Index2];\r\n Strings[Index2] := TempString;\r\n Objects[Index2] := TempObject;\r\n finally\r\n EndUpdate;\r\n end;\r\nend;\r\n\r\nfunction TJclAnsiStrings.GetCommaText: AnsiString;\r\nbegin\r\n Result := GetDelimitedText(AnsiComma, AnsiDoubleQuote);\r\nend;\r\n\r\nfunction TJclAnsiStrings.GetDelimitedText: AnsiString;\r\nbegin\r\n Result := GetDelimitedText(Delimiter, QuoteChar);\r\nend;\r\n\r\nfunction TJclAnsiStrings.GetDelimitedText(const ADelimiter: AnsiString; AQuoteChar: AnsiChar): AnsiString;\r\n\r\n function Quoted(Item: AnsiString): AnsiString;\r\n begin\r\n if (not StrictDelimiter) and ((Pos(AnsiSpace, Item) > 0) or (Pos(FQuoteChar, Item) > 0)) then\r\n begin\r\n Result := AnsiQuotedStr(Item, AQuoteChar);\r\n end\r\n else\r\n Result := Item;\r\n end;\r\n\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := '';\r\n for I := 0 to Count - 2 do\r\n Result := Result + Quoted(Strings[I]) + ADelimiter;\r\n if Count > 0 then\r\n Result := Result + Quoted(Strings[Count - 1]);\r\nend;\r\n\r\nprocedure TJclAnsiStrings.Insert(Index: Integer; const S: AnsiString);\r\nbegin\r\n InsertObject(Index, S, nil);\r\nend;\r\n\r\nprocedure TJclAnsiStrings.SetCommaText(const Value: AnsiString);\r\nbegin\r\n SetDelimitedText(Value, AnsiComma, AnsiDoubleQuote);\r\nend;\r\n\r\nprocedure TJclAnsiStrings.SetDelimitedText(const Value: AnsiString);\r\nbegin\r\n SetDelimitedText(Value, Delimiter, QuoteChar);\r\nend;\r\n\r\nprocedure TJclAnsiStrings.SetDelimitedText(const Value, ADelimiter: AnsiString; AQuoteChar: AnsiChar);\r\n\r\n procedure InternalAdd(Item: AnsiString);\r\n begin\r\n Item := StrTrimQuotes(Item, AQuoteChar);\r\n StrReplace(Item, AQuoteChar + AQuoteChar, AQuoteChar, [rfReplaceAll]);\r\n Add(Item);\r\n end;\r\n\r\nvar\r\n ValueLength, LastStart, Index, QuoteCharCount: Integer;\r\n ValueChar: AnsiChar;\r\nbegin\r\n Clear;\r\n LastStart := 1;\r\n QuoteCharCount := 0;\r\n ValueLength := Length(Value);\r\n for Index := 1 to ValueLength do\r\n begin\r\n ValueChar := Value[Index];\r\n if ValueChar = AQuoteChar then\r\n Inc(QuoteCharCount);\r\n if ((ValueChar = ADelimiter) or ((ValueChar = ' ') and (not StrictDelimiter)))\r\n and ((not Odd(QuoteCharCount) or (QuoteCharCount = 0))) then\r\n begin\r\n if StrictDelimiter then\r\n Add(Copy(Value, LastStart, Index - LastStart))\r\n else\r\n InternalAdd(Copy(Value, LastStart, Index - LastStart));\r\n QuoteCharCount := 0;\r\n LastStart := Index + 1;\r\n end;\r\n if (Index = ValueLength) and (LastStart < ValueLength) then\r\n begin\r\n if StrictDelimiter then\r\n Add(Copy(Value, LastStart, ValueLength - LastStart + 1))\r\n else\r\n InternalAdd(Copy(Value, LastStart, Index - LastStart + 1));\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJclAnsiStrings.GetText: AnsiString;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := '';\r\n for I := 0 to Count - 2 do\r\n Result := Result + Strings[I] + AnsiLineBreak;\r\n if Count > 0 then\r\n Result := Result + Strings[Count - 1] + AnsiLineBreak;\r\nend;\r\n\r\nprocedure TJclAnsiStrings.SetText(const Value: AnsiString);\r\nvar\r\n Index, Start, Len: Integer;\r\n S: AnsiString;\r\nbegin\r\n Clear;\r\n Len := Length(Value);\r\n Index := 1;\r\n while Index <= Len do\r\n begin\r\n Start := Index;\r\n while (Index <= Len) and not CharIsReturn(Value[Index]) do\r\n Inc(Index);\r\n\r\n S := Copy(Value, Start, Index - Start);\r\n Add(S);\r\n\r\n if (Index <= Len) and (Value[Index] = AnsiCarriageReturn) then\r\n Inc(Index);\r\n if (Index <= Len) and (Value[Index] = AnsiLineFeed) then\r\n Inc(Index);\r\n end;\r\nend;\r\n\r\nfunction TJclAnsiStrings.GetCapacity: Integer;\r\nbegin\r\n Result := Count; // Might be overridden in derived classes\r\nend;\r\n\r\nprocedure TJclAnsiStrings.SetCapacity(const Value: Integer);\r\nbegin\r\n // Nothing at this level\r\nend;\r\n\r\nprocedure TJclAnsiStrings.BeginUpdate;\r\nbegin\r\nend;\r\n\r\nprocedure TJclAnsiStrings.EndUpdate;\r\nbegin\r\nend;\r\n\r\nprocedure TJclAnsiStrings.LoadFromFile(const FileName: TFileName);\r\nvar\r\n Stream: TStream;\r\nbegin\r\n Stream := TFileStream.Create(FileName, fmOpenRead or fmShareDenyWrite);\r\n try\r\n LoadFromStream(Stream);\r\n finally\r\n Stream.Free;\r\n end;\r\nend;\r\n\r\nprocedure TJclAnsiStrings.LoadFromStream(Stream: TStream);\r\nvar\r\n Size: Integer;\r\n S: AnsiString;\r\nbegin\r\n BeginUpdate;\r\n try\r\n Size := Stream.Size - Stream.Position;\r\n System.SetString(S, nil, Size);\r\n Stream.Read(PAnsiChar(S)^, Size);\r\n SetText(S);\r\n finally\r\n EndUpdate;\r\n end;\r\nend;\r\n\r\nprocedure TJclAnsiStrings.SaveToFile(const FileName: TFileName);\r\nvar\r\n Stream: TStream;\r\nbegin\r\n Stream := TFileStream.Create(FileName, fmCreate);\r\n try\r\n SaveToStream(Stream);\r\n finally\r\n Stream.Free;\r\n end;\r\nend;\r\n\r\nprocedure TJclAnsiStrings.SaveToStream(Stream: TStream);\r\nvar\r\n S: AnsiString;\r\nbegin\r\n S := GetText;\r\n Stream.WriteBuffer(PAnsiChar(S)^, Length(S));\r\nend;\r\n\r\nfunction TJclAnsiStrings.ExtractName(const S: AnsiString): AnsiString;\r\nvar\r\n P: Integer;\r\nbegin\r\n Result := S;\r\n P := AnsiPos(NameValueSeparator, Result);\r\n if P > 0 then\r\n SetLength(Result, P - 1)\r\n else\r\n SetLength(Result, 0);\r\nend;\r\n\r\nfunction TJclAnsiStrings.GetName(Index: Integer): AnsiString;\r\nbegin\r\n Result := ExtractName(Strings[Index]);\r\nend;\r\n\r\nfunction TJclAnsiStrings.GetValue(const Name: AnsiString): AnsiString;\r\nvar\r\n I: Integer;\r\nbegin\r\n I := IndexOfName(Name);\r\n if I >= 0 then\r\n Result := Copy(GetString(I), Length(Name) + 2, MaxInt)\r\n else\r\n Result := '';\r\nend;\r\n\r\nprocedure TJclAnsiStrings.SetValue(const Name, Value: AnsiString);\r\nvar\r\n I: Integer;\r\nbegin\r\n I := IndexOfName(Name);\r\n if Value <> '' then\r\n begin\r\n if I < 0 then\r\n I := Add('');\r\n SetString(I, Name + NameValueSeparator + Value);\r\n end\r\n else\r\n begin\r\n if I >= 0 then\r\n Delete(I);\r\n end;\r\nend;\r\n\r\nfunction TJclAnsiStrings.GetValueFromIndex(Index: Integer): AnsiString;\r\nvar\r\n S: AnsiString;\r\n P: Integer;\r\nbegin\r\n if Index >= 0 then\r\n begin\r\n S := Strings[Index];\r\n P := AnsiPos(NameValueSeparator, S);\r\n if P > 0 then\r\n Result := Copy(S, P + 1, Length(S) - P)\r\n else\r\n Result := '';\r\n end\r\n else\r\n Result := '';\r\nend;\r\n\r\nprocedure TJclAnsiStrings.SetValueFromIndex(Index: Integer; const Value: AnsiString);\r\nbegin\r\n if Value <> '' then\r\n begin\r\n if Index < 0 then\r\n Index := Add('');\r\n SetString(Index, Names[Index] + NameValueSeparator + Value);\r\n end\r\n else\r\n begin\r\n if Index >= 0 then\r\n Delete(Index);\r\n end;\r\nend;\r\n\r\n//=== { TJclAnsiStringList } =================================================\r\n\r\nconstructor TJclAnsiStringList.Create;\r\nbegin\r\n inherited Create;\r\n FCaseSensitive := True;\r\nend;\r\n\r\nprocedure TJclAnsiStringList.Assign(Source: TPersistent);\r\nvar\r\n StringListSource: TStringList;\r\nbegin\r\n if Source is TStringList then\r\n begin\r\n StringListSource := TStringList(Source);\r\n FDuplicates := StringListSource.Duplicates;\r\n FSorted := StringListSource.Sorted;\r\n FCaseSensitive := StringListSource.CaseSensitive;\r\n end;\r\n inherited Assign(Source);\r\nend;\r\n\r\nprocedure TJclAnsiStringList.AssignTo(Dest: TPersistent);\r\nvar\r\n StringListDest: TStringList;\r\n AnsiStringListDest: TJclAnsiStringList;\r\nbegin\r\n if Dest is TStringList then\r\n begin\r\n StringListDest := TStringList(Dest);\r\n StringListDest.Clear; // make following assignments a lot faster\r\n StringListDest.Duplicates := FDuplicates;\r\n StringListDest.Sorted := FSorted;\r\n StringListDest.CaseSensitive := FCaseSensitive;\r\n end\r\n else\r\n if Dest is TJclAnsiStringList then\r\n begin\r\n AnsiStringListDest := TJclAnsiStringList(Dest);\r\n AnsiStringListDest.Clear;\r\n AnsiStringListDest.FDuplicates := FDuplicates;\r\n AnsiStringListDest.FSorted := FSorted;\r\n AnsiStringListDest.FCaseSensitive := FCaseSensitive;\r\n end;\r\n inherited AssignTo(Dest);\r\nend;\r\n\r\nfunction TJclAnsiStringList.CompareStrings(const S1: AnsiString; const S2: AnsiString): Integer;\r\nbegin\r\n if FCaseSensitive then\r\n Result := CompareStr(S1, S2)\r\n else\r\n Result := CompareText(S1, S2);\r\nend;\r\n\r\nprocedure TJclAnsiStringList.Grow;\r\nvar\r\n Delta: Integer;\r\nbegin\r\n if Capacity > 64 then\r\n Delta := Capacity div 4\r\n else if Capacity > 8 then\r\n Delta := 16\r\n else\r\n Delta := 4;\r\n\r\n SetCapacity(Capacity + Delta);\r\nend;\r\n\r\nfunction TJclAnsiStringList.GetString(Index: Integer): AnsiString;\r\nbegin\r\n if (Index < 0) or (Index >= FCount) then\r\n Error(@SListIndexError, Index);\r\n\r\n Result := FStrings[Index].Str;\r\nend;\r\n\r\nprocedure TJclAnsiStringList.SetString(Index: Integer; const Value: AnsiString);\r\nbegin\r\n if Sorted then\r\n Error(@SSortedListError, 0);\r\n\r\n if (Index < 0) or (Index >= FCount) then\r\n Error(@SListIndexError, Index);\r\n\r\n FStrings[Index].Str := Value;\r\nend;\r\n\r\nfunction TJclAnsiStringList.GetObject(Index: Integer): TObject;\r\nbegin\r\n if (Index < 0) or (Index >= FCount) then\r\n Error(@SListIndexError, Index);\r\n\r\n Result := FStrings[Index].Obj;\r\nend;\r\n\r\nprocedure TJclAnsiStringList.SetObject(Index: Integer; AObject: TObject);\r\nbegin\r\n if (Index < 0) or (Index >= FCount) then\r\n Error(@SListIndexError, Index);\r\n\r\n FStrings[Index].Obj := AObject;\r\nend;\r\n\r\nfunction TJclAnsiStringList.GetCapacity: Integer;\r\nbegin\r\n Result := Length(FStrings);\r\nend;\r\n\r\nprocedure TJclAnsiStringList.SetCapacity(const Value: Integer);\r\nbegin\r\n if (Value < FCount) then\r\n Error(@SListCapacityError, Value);\r\n\r\n if Value <> Capacity then\r\n SetLength(FStrings, Value);\r\nend;\r\n\r\nfunction TJclAnsiStringList.GetCount: Integer;\r\nbegin\r\n Result := FCount;\r\nend;\r\n\r\nprocedure TJclAnsiStringList.InsertObject(Index: Integer; const S: AnsiString; AObject: TObject);\r\nvar\r\n I: Integer;\r\nbegin\r\n if Count = Capacity then\r\n Grow;\r\n\r\n for I := Count - 1 downto Index do\r\n FStrings[I + 1] := FStrings[I];\r\n\r\n FStrings[Index].Str := S;\r\n FStrings[Index].Obj := AObject;\r\n Inc(FCount);\r\nend;\r\n\r\nfunction TJclAnsiStringList.AddObject(const S: AnsiString; AObject: TObject): Integer;\r\nbegin\r\n if not Sorted then\r\n begin\r\n Result := Count;\r\n end\r\n else\r\n begin\r\n case Duplicates of\r\n dupAccept: ;\r\n dupIgnore:\r\n if Find(S, Result) then\r\n Exit;\r\n dupError:\r\n if Find(S, Result) then\r\n Error(@SDuplicateString, 0);\r\n end;\r\n end;\r\n\r\n InsertObject(Result, S, AObject);\r\nend;\r\n\r\nprocedure TJclAnsiStringList.Delete(Index: Integer);\r\nvar\r\n I: Integer;\r\nbegin\r\n if (Index < 0) or (Index >= FCount) then\r\n Error(@SListIndexError, Index);\r\n\r\n for I := Index to Count - 2 do\r\n FStrings[I] := FStrings[I + 1];\r\n \r\n SetLength(FStrings[FCount - 1].Str, 0); // the last string is no longer useful\r\n \r\n Dec(FCount);\r\nend;\r\n\r\nprocedure TJclAnsiStringList.Clear;\r\nvar\r\n I: Integer;\r\nbegin\r\n FCount := 0;\r\n for I := 0 to Length(FStrings) - 1 do\r\n begin\r\n FStrings[I].Str := '';\r\n FStrings[I].Obj := nil;\r\n end;\r\nend;\r\n\r\nfunction TJclAnsiStringList.Find(const S: AnsiString; var Index: Integer): Boolean;\r\nvar\r\n L, H, I, C: Integer;\r\nbegin\r\n Result := False;\r\n L := 0;\r\n H := FCount - 1;\r\n while L <= H do\r\n begin\r\n I := (L + H) shr 1;\r\n C := CompareStrings(FStrings[I].Str, S);\r\n if C < 0 then\r\n L := I + 1\r\n else\r\n begin\r\n H := I - 1;\r\n if C = 0 then\r\n begin\r\n Result := True;\r\n if Duplicates <> dupAccept then\r\n L := I;\r\n end;\r\n end;\r\n end;\r\n Index := L;\r\nend;\r\n\r\nfunction AnsiStringListCompareStrings(List: TJclAnsiStringList; Index1, Index2: Integer): Integer;\r\nbegin\r\n Result := List.CompareStrings(List.FStrings[Index1].Str,\r\n List.FStrings[Index2].Str);\r\nend;\r\n\r\nprocedure TJclAnsiStringList.Sort;\r\nbegin\r\n CustomSort(AnsiStringListCompareStrings);\r\nend;\r\n\r\nprocedure TJclAnsiStringList.CustomSort(Compare: TJclAnsiStringListSortCompare);\r\nbegin\r\n if not Sorted and (FCount > 1) then\r\n QuickSort(0, FCount - 1, Compare);\r\nend;\r\n\r\nprocedure TJclAnsiStringList.QuickSort(L, R: Integer; SCompare: TJclAnsiStringListSortCompare);\r\nvar\r\n I, J, P: Integer;\r\nbegin\r\n repeat\r\n I := L;\r\n J := R;\r\n P := (L + R) shr 1;\r\n repeat\r\n while SCompare(Self, I, P) < 0 do\r\n Inc(I);\r\n while SCompare(Self, J, P) > 0 do\r\n Dec(J);\r\n if I <= J then\r\n begin\r\n if I <> J then\r\n Exchange(I, J);\r\n if P = I then\r\n P := J\r\n else\r\n if P = J then\r\n P := I;\r\n Inc(I);\r\n Dec(J);\r\n end;\r\n until I > J;\r\n if L < J then\r\n QuickSort(L, J, SCompare);\r\n L := I;\r\n until I >= R;\r\nend;\r\n\r\nprocedure TJclAnsiStringList.SetSorted(Value: Boolean);\r\nbegin\r\n if FSorted <> Value then\r\n begin\r\n if Value then\r\n Sort;\r\n FSorted := Value;\r\n end;\r\nend;\r\n\r\n{$ENDIF SUPPORTS_UNICODE}\r\n\r\n// String Test Routines\r\nfunction StrIsAlpha(const S: AnsiString): Boolean;\r\nvar\r\n I: SizeInt;\r\nbegin\r\n Result := S <> '';\r\n for I := 1 to Length(S) do\r\n begin\r\n if not CharIsAlpha(S[I]) then\r\n begin\r\n Result := False;\r\n Exit;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction StrIsAlphaNum(const S: AnsiString): Boolean;\r\nvar\r\n I: SizeInt;\r\nbegin\r\n Result := S <> '';\r\n for I := 1 to Length(S) do\r\n begin\r\n if not CharIsAlphaNum(S[I]) then\r\n begin\r\n Result := False;\r\n Exit;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction StrConsistsofNumberChars(const S: AnsiString): Boolean;\r\nvar\r\n I: SizeInt;\r\nbegin\r\n Result := S <> '';\r\n for I := 1 to Length(S) do\r\n begin\r\n if not CharIsNumberChar(S[I]) then\r\n begin\r\n Result := False;\r\n Exit;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction StrContainsChars(const S: AnsiString; Chars: TSysCharSet; CheckAll: Boolean): Boolean;\r\nvar\r\n I: SizeInt;\r\n C: AnsiChar;\r\nbegin\r\n Result := Chars = [];\r\n if not Result then\r\n begin\r\n if CheckAll then\r\n begin\r\n for I := 1 to Length(S) do\r\n begin\r\n C := S[I];\r\n if C in Chars then\r\n begin\r\n Chars := Chars - [C];\r\n if Chars = [] then\r\n Break;\r\n end;\r\n end;\r\n Result := (Chars = []);\r\n end\r\n else\r\n begin\r\n for I := 1 to Length(S) do\r\n if S[I] in Chars then\r\n begin\r\n Result := True;\r\n Break;\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction StrIsAlphaNumUnderscore(const S: AnsiString): Boolean;\r\nvar\r\n I: SizeInt;\r\n C: AnsiChar;\r\nbegin\r\n for i := 1 to Length(s) do\r\n begin\r\n C := S[I];\r\n\r\n if not (CharIsAlphaNum(C) or (C = '_')) then\r\n begin\r\n Result := False;\r\n Exit;\r\n end;\r\n end;\r\n\r\n Result := True and (Length(S) > 0);\r\nend;\r\n\r\nfunction StrIsDigit(const S: AnsiString): Boolean;\r\nvar\r\n I: SizeInt;\r\nbegin\r\n Result := S <> '';\r\n for I := 1 to Length(S) do\r\n begin\r\n if not CharIsDigit(S[I]) then\r\n begin\r\n Result := False;\r\n Exit;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction StrIsSubset(const S: AnsiString; const ValidChars: TSysCharSet): Boolean;\r\nvar\r\n I: SizeInt;\r\nbegin\r\n for I := 1 to Length(S) do\r\n begin\r\n if not (S[I] in ValidChars) then\r\n begin\r\n Result := False;\r\n Exit;\r\n end;\r\n end;\r\n\r\n Result := True and (Length(S) > 0);\r\nend;\r\n\r\nfunction StrSame(const S1, S2: AnsiString): Boolean;\r\nbegin\r\n Result := StrCompare(S1, S2) = 0;\r\nend;\r\n\r\n//=== String Transformation Routines =========================================\r\n\r\nfunction StrCenter(const S: AnsiString; L: SizeInt; C: AnsiChar = ' '): AnsiString;\r\nbegin\r\n if Length(S) < L then\r\n begin\r\n Result := StringOfChar(C, (L - Length(S)) div 2) + S;\r\n Result := Result + StringOfChar(C, L - Length(Result));\r\n end\r\n else\r\n Result := S;\r\nend;\r\n\r\nfunction StrCharPosLower(const S: AnsiString; CharPos: SizeInt): AnsiString;\r\nbegin\r\n Result := S;\r\n if (CharPos > 0) and (CharPos <= Length(S)) then\r\n Result[CharPos] := CharLower(Result[CharPos]);\r\nend;\r\n\r\nfunction StrCharPosUpper(const S: AnsiString; CharPos: SizeInt): AnsiString;\r\nbegin\r\n Result := S;\r\n if (CharPos > 0) and (CharPos <= Length(S)) then\r\n Result[CharPos] := CharUpper(Result[CharPos]);\r\nend;\r\n\r\nfunction StrDoubleQuote(const S: AnsiString): AnsiString;\r\nbegin\r\n Result := AnsiDoubleQuote + S + AnsiDoubleQuote;\r\nend;\r\n\r\nfunction StrEnsureNoPrefix(const Prefix, Text: AnsiString): AnsiString;\r\nvar\r\n PrefixLen: SizeInt;\r\nbegin\r\n PrefixLen := Length(Prefix);\r\n if Copy(Text, 1, PrefixLen) = Prefix then\r\n Result := Copy(Text, PrefixLen + 1, Length(Text))\r\n else\r\n Result := Text;\r\nend;\r\n\r\nfunction StrEnsureNoSuffix(const Suffix, Text: AnsiString): AnsiString;\r\nvar\r\n SuffixLen: SizeInt;\r\n StrLength: SizeInt;\r\nbegin\r\n SuffixLen := Length(Suffix);\r\n StrLength := Length(Text);\r\n if Copy(Text, StrLength - SuffixLen + 1, SuffixLen) = Suffix then\r\n Result := Copy(Text, 1, StrLength - SuffixLen)\r\n else\r\n Result := Text;\r\nend;\r\n\r\nfunction StrEnsurePrefix(const Prefix, Text: AnsiString): AnsiString;\r\nvar\r\n PrefixLen: SizeInt;\r\nbegin\r\n PrefixLen := Length(Prefix);\r\n if Copy(Text, 1, PrefixLen) = Prefix then\r\n Result := Text\r\n else\r\n Result := Prefix + Text;\r\nend;\r\n\r\nfunction StrEnsureSuffix(const Suffix, Text: AnsiString): AnsiString;\r\nvar\r\n SuffixLen: SizeInt;\r\nbegin\r\n SuffixLen := Length(Suffix);\r\n if Copy(Text, Length(Text) - SuffixLen + 1, SuffixLen) = Suffix then\r\n Result := Text\r\n else\r\n Result := Text + Suffix;\r\nend;\r\n\r\nfunction StrEscapedToString(const S: AnsiString): AnsiString;\r\n procedure HandleHexEscapeSeq(const S: AnsiString; var I: SizeInt; Len: SizeInt; var Dest: AnsiString);\r\n const\r\n HexDigits = AnsiString('0123456789abcdefABCDEF');\r\n var\r\n StartI, Val, N: SizeInt;\r\n begin\r\n StartI := I;\r\n N := Pos(S[I + 1], HexDigits) - 1;\r\n if N < 0 then\r\n // '\\x' without hex digit following is not escape sequence\r\n Dest := Dest + '\\x'\r\n else\r\n begin\r\n Inc(I); // Jump over x\r\n if N >= 16 then\r\n N := N - 6;\r\n Val := N;\r\n // Same for second digit\r\n if I < Len then\r\n begin\r\n N := Pos(S[I + 1], HexDigits) - 1;\r\n if N >= 0 then\r\n begin\r\n Inc(I); // Jump over first digit\r\n if N >= 16 then\r\n N := N - 6;\r\n Val := Val * 16 + N;\r\n end;\r\n end;\r\n\r\n if Val > Ord(High(AnsiChar)) then\r\n raise EJclAnsiStringError.CreateResFmt(@RsNumericConstantTooLarge, [Val, StartI]);\r\n\r\n Dest := Dest + AnsiChar(Val);\r\n end;\r\n end;\r\n\r\n procedure HandleOctEscapeSeq(const S: AnsiString; var I: SizeInt; Len: SizeInt; var Dest: AnsiString);\r\n const\r\n OctDigits = AnsiString('01234567');\r\n var\r\n StartI, Val, N: SizeInt;\r\n begin\r\n StartI := I;\r\n // first digit\r\n Val := Pos(S[I], OctDigits) - 1;\r\n if I < Len then\r\n begin\r\n N := Pos(S[I + 1], OctDigits) - 1;\r\n if N >= 0 then\r\n begin\r\n Inc(I);\r\n Val := Val * 8 + N;\r\n end;\r\n if I < Len then\r\n begin\r\n N := Pos(S[I + 1], OctDigits) - 1;\r\n if N >= 0 then\r\n begin\r\n Inc(I);\r\n Val := Val * 8 + N;\r\n end;\r\n end;\r\n end;\r\n\r\n if Val > Ord(High(AnsiChar)) then\r\n raise EJclAnsiStringError.CreateResFmt(@RsNumericConstantTooLarge, [Val, StartI]);\r\n\r\n Dest := Dest + AnsiChar(Val);\r\n end;\r\n\r\nvar\r\n I, Len: SizeInt;\r\nbegin\r\n Result := '';\r\n I := 1;\r\n Len := Length(S);\r\n while I <= Len do\r\n begin\r\n if not ((S[I] = '\\') and (I < Len)) then\r\n Result := Result + S[I]\r\n else\r\n begin\r\n Inc(I); // Jump over escape character\r\n case S[I] of\r\n 'a':\r\n Result := Result + AnsiBell;\r\n 'b':\r\n Result := Result + AnsiBackspace;\r\n 'f':\r\n Result := Result + AnsiFormFeed;\r\n 'n':\r\n Result := Result + AnsiLineFeed;\r\n 'r':\r\n Result := Result + AnsiCarriageReturn;\r\n 't':\r\n Result := Result + AnsiTab;\r\n 'v':\r\n Result := Result + AnsiVerticalTab;\r\n '\\':\r\n Result := Result + '\\';\r\n '\"':\r\n Result := Result + '\"';\r\n '''':\r\n Result := Result + ''''; // Optionally escaped\r\n '?':\r\n Result := Result + '?'; // Optionally escaped\r\n 'x':\r\n if I < Len then\r\n // Start of hex escape sequence\r\n HandleHexEscapeSeq(S, I, Len, Result)\r\n else\r\n // '\\x' at end of AnsiString is not escape sequence\r\n Result := Result + '\\x';\r\n '0'..'7':\r\n // start of octal escape sequence\r\n HandleOctEscapeSeq(S, I, Len, Result);\r\n else\r\n // no escape sequence\r\n Result := Result + '\\' + S[I];\r\n end;\r\n end;\r\n Inc(I);\r\n end;\r\nend;\r\n\r\nfunction StrLower(const S: AnsiString): AnsiString;\r\nbegin\r\n Result := S;\r\n StrLowerInPlace(Result);\r\nend;\r\n\r\nprocedure StrLowerInPlace(var S: AnsiString);\r\nbegin\r\n StrCase(S, AnsiLoOffset);\r\nend;\r\n\r\nprocedure StrLowerBuff(S: PAnsiChar);\r\nbegin\r\n StrCaseBuff(S, AnsiLoOffset);\r\nend;\r\n\r\nprocedure StrMove(var Dest: AnsiString; const Source: AnsiString;\r\n const ToIndex, FromIndex, Count: SizeInt);\r\nbegin\r\n // Check strings\r\n if (Source = '') or (Length(Dest) = 0) then\r\n Exit;\r\n\r\n // Check FromIndex\r\n if (FromIndex <= 0) or (FromIndex > Length(Source)) or\r\n (ToIndex <= 0) or (ToIndex > Length(Dest)) or\r\n ((FromIndex + Count - 1) > Length(Source)) or ((ToIndex + Count - 1) > Length(Dest)) then\r\n { TODO : Is failure without notice the proper thing to do here? }\r\n Exit;\r\n\r\n // Move\r\n Move(Source[FromIndex], Dest[ToIndex], Count);\r\nend;\r\n\r\nfunction StrPadLeft(const S: AnsiString; Len: SizeInt; C: AnsiChar): AnsiString;\r\nvar\r\n L: SizeInt;\r\nbegin\r\n L := Length(S);\r\n if L < Len then\r\n Result := StringOfChar(C, Len - L) + S\r\n else\r\n Result := S;\r\nend;\r\n\r\nfunction StrPadRight(const S: AnsiString; Len: SizeInt; C: AnsiChar): AnsiString;\r\nvar\r\n L: SizeInt;\r\nbegin\r\n L := Length(S);\r\n if L < Len then\r\n Result := S + StringOfChar(C, Len - L)\r\n else\r\n Result := S;\r\nend;\r\n\r\nfunction StrProper(const S: AnsiString): AnsiString;\r\nbegin\r\n Result := StrLower(S);\r\n if Result <> '' then\r\n Result[1] := UpCase(Result[1]);\r\nend;\r\n\r\nprocedure StrProperBuff(S: PAnsiChar);\r\nbegin\r\n if (S <> nil) and (S^ <> #0) then\r\n begin\r\n StrLowerBuff(S);\r\n S^ := CharUpper(S^);\r\n end;\r\nend;\r\n\r\nfunction StrQuote(const S: AnsiString; C: AnsiChar): AnsiString;\r\nvar\r\n L: SizeInt;\r\nbegin\r\n L := Length(S);\r\n Result := S;\r\n if L > 0 then\r\n begin\r\n if Result[1] <> C then\r\n begin\r\n Result := C + Result;\r\n Inc(L);\r\n end;\r\n if Result[L] <> C then\r\n Result := Result + C;\r\n end;\r\nend;\r\n\r\nfunction StrRemoveChars(const S: AnsiString; const Chars: TSysCharSet): AnsiString;\r\nvar\r\n Source, Dest: PAnsiChar;\r\n Index, Len: SizeInt;\r\nbegin\r\n Len := Length(S);\r\n SetLength(Result, Len);\r\n UniqueString(Result);\r\n Source := PAnsiChar(S);\r\n Dest := PAnsiChar(Result);\r\n for Index := 0 to Len - 1 do\r\n begin\r\n if not (Source^ in Chars) then\r\n begin\r\n Dest^ := Source^;\r\n Inc(Dest);\r\n end;\r\n Inc(Source);\r\n end;\r\n SetLength(Result, Dest - PAnsiChar(Result));\r\nend;\r\n\r\nfunction StrKeepChars(const S: AnsiString; const Chars: TSysCharSet): AnsiString;\r\nvar\r\n Source, Dest: PAnsiChar;\r\n Index, Len: SizeInt;\r\nbegin\r\n Len := Length(S);\r\n SetLength(Result, Len);\r\n UniqueString(Result);\r\n Source := PAnsiChar(S);\r\n Dest := PAnsiChar(Result);\r\n for Index := 0 to Len - 1 do\r\n begin\r\n if Source^ in Chars then\r\n begin\r\n Dest^ := Source^;\r\n Inc(Dest);\r\n end;\r\n Inc(Source);\r\n end;\r\n SetLength(Result, Dest - PAnsiChar(Result));\r\nend;\r\n\r\nfunction StrRepeat(const S: AnsiString; Count: SizeInt): AnsiString;\r\nvar\r\n L: SizeInt;\r\n P: PAnsiChar;\r\nbegin\r\n L := Length(S);\r\n SetLength(Result, Count * L);\r\n P := Pointer(Result);\r\n if P <> nil then\r\n begin\r\n while Count > 0 do\r\n begin\r\n Move(Pointer(S)^, P^, L);\r\n P := P + L;\r\n Dec(Count);\r\n end;\r\n end;\r\nend;\r\n\r\nfunction StrRepeatLength(const S: AnsiString; const L: SizeInt): AnsiString;\r\nvar\r\n Count: SizeInt;\r\n LenS: SizeInt;\r\n P: PAnsiChar;\r\nbegin\r\n Result := '';\r\n LenS := Length(S);\r\n\r\n if (LenS > 0) and (S <> '') then\r\n begin\r\n Count := L div LenS;\r\n if Count * LenS < L then\r\n Inc(Count);\r\n SetLength(Result, Count * LenS);\r\n P := Pointer(Result);\r\n while Count > 0 do\r\n begin\r\n Move(Pointer(S)^, P^, LenS);\r\n P := P + LenS;\r\n Dec(Count);\r\n end;\r\n if Length(S) > L then\r\n SetLength(Result, L);\r\n end;\r\nend;\r\n\r\nprocedure StrReplace(var S: AnsiString; const Search, Replace: AnsiString; Flags: TReplaceFlags);\r\nvar\r\n SearchStr: AnsiString;\r\n ResultStr: AnsiString; { result string }\r\n SourcePtr: PAnsiChar; { pointer into S of character under examination }\r\n SourceMatchPtr: PAnsiChar; { pointers into S and Search when first character has }\r\n SearchMatchPtr: PAnsiChar; { been matched and we're probing for a complete match }\r\n ResultPtr: PAnsiChar; { pointer into Result of character being written }\r\n ResultIndex: SizeInt;\r\n SearchLength: SizeInt; { length of search string }\r\n ReplaceLength: SizeInt; { length of replace string }\r\n BufferLength: SizeInt; { length of temporary result buffer }\r\n ResultLength: SizeInt; { length of result string }\r\n C: AnsiChar; { first character of search string }\r\n IgnoreCase: Boolean;\r\nbegin\r\n if Search = '' then\r\n begin\r\n if S = '' then\r\n begin\r\n S := Replace;\r\n Exit;\r\n end\r\n else\r\n raise EJclAnsiStringError.CreateRes(@RsBlankSearchString);\r\n end;\r\n\r\n if S <> '' then\r\n begin\r\n IgnoreCase := rfIgnoreCase in Flags;\r\n if IgnoreCase then\r\n SearchStr := StrUpper(Search)\r\n else\r\n SearchStr := Search;\r\n { avoid having to call Length() within the loop }\r\n SearchLength := Length(Search);\r\n ReplaceLength := Length(Replace);\r\n ResultLength := Length(S);\r\n BufferLength := ResultLength;\r\n SetLength(ResultStr, BufferLength);\r\n { get pointers to begin of source and result }\r\n ResultPtr := PAnsiChar(ResultStr);\r\n SourcePtr := PAnsiChar(S);\r\n C := SearchStr[1];\r\n { while we haven't reached the end of the string }\r\n while True do\r\n begin\r\n { copy characters until we find the first character of the search string }\r\n if IgnoreCase then\r\n while (CharUpper(SourcePtr^) <> C) and (SourcePtr^ <> #0) do\r\n begin\r\n ResultPtr^ := SourcePtr^;\r\n Inc(ResultPtr);\r\n Inc(SourcePtr);\r\n end\r\n else\r\n while (SourcePtr^ <> C) and (SourcePtr^ <> #0) do\r\n begin\r\n ResultPtr^ := SourcePtr^;\r\n Inc(ResultPtr);\r\n Inc(SourcePtr);\r\n end;\r\n { did we find that first character or did we hit the end of the string? }\r\n if SourcePtr^ = #0 then\r\n Break\r\n else\r\n begin\r\n { continue comparing, +1 because first character was matched already }\r\n SourceMatchPtr := SourcePtr + 1;\r\n SearchMatchPtr := PAnsiChar(SearchStr) + 1;\r\n if IgnoreCase then\r\n while (CharUpper(SourceMatchPtr^) = SearchMatchPtr^) and (SearchMatchPtr^ <> #0) do\r\n begin\r\n Inc(SourceMatchPtr);\r\n Inc(SearchMatchPtr);\r\n end\r\n else\r\n while (SourceMatchPtr^ = SearchMatchPtr^) and (SearchMatchPtr^ <> #0) do\r\n begin\r\n Inc(SourceMatchPtr);\r\n Inc(SearchMatchPtr);\r\n end;\r\n { did we find a complete match? }\r\n if SearchMatchPtr^ = #0 then\r\n begin\r\n // keep track of result length\r\n Inc(ResultLength, ReplaceLength - SearchLength);\r\n if ReplaceLength > 0 then\r\n begin\r\n // increase buffer size if required\r\n if ResultLength > BufferLength then\r\n begin\r\n BufferLength := ResultLength * 2;\r\n ResultIndex := ResultPtr - PAnsiChar(ResultStr) + 1;\r\n SetLength(ResultStr, BufferLength);\r\n ResultPtr := @ResultStr[ResultIndex];\r\n end;\r\n { append replace to result and move past the search string in source }\r\n Move((@Replace[1])^, ResultPtr^, ReplaceLength);\r\n end;\r\n Inc(SourcePtr, SearchLength);\r\n Inc(ResultPtr, ReplaceLength);\r\n { replace all instances or just one? }\r\n if not (rfReplaceAll in Flags) then\r\n begin\r\n { just one, copy until end of source and break out of loop }\r\n while SourcePtr^ <> #0 do\r\n begin\r\n ResultPtr^ := SourcePtr^;\r\n Inc(ResultPtr);\r\n Inc(SourcePtr);\r\n end;\r\n Break;\r\n end;\r\n end\r\n else\r\n begin\r\n { copy current character and start over with the next }\r\n ResultPtr^ := SourcePtr^;\r\n Inc(ResultPtr);\r\n Inc(SourcePtr);\r\n end;\r\n end;\r\n end;\r\n { set result length and copy result into S }\r\n SetLength(ResultStr, ResultLength);\r\n S := ResultStr;\r\n end;\r\nend;\r\n\r\nfunction StrReplaceChar(const S: AnsiString; const Source, Replace: AnsiChar): AnsiString;\r\nvar\r\n I: SizeInt;\r\nbegin\r\n Result := S;\r\n for I := 1 to Length(S) do\r\n if Result[I] = Source then\r\n Result[I] := Replace;\r\nend;\r\n\r\nfunction StrReplaceChars(const S: AnsiString; const Chars: TSysCharSet; Replace: AnsiChar): AnsiString;\r\nvar\r\n I: SizeInt;\r\nbegin\r\n Result := S;\r\n for I := 1 to Length(S) do\r\n if Result[I] in Chars then\r\n Result[I] := Replace;\r\nend;\r\n\r\nfunction StrReplaceButChars(const S: AnsiString; const Chars: TSysCharSet;\r\n Replace: AnsiChar): AnsiString;\r\nvar\r\n I: SizeInt;\r\nbegin\r\n Result := S;\r\n for I := 1 to Length(S) do\r\n if not (Result[I] in Chars) then\r\n Result[I] := Replace;\r\nend;\r\n\r\nfunction StrReverse(const S: AnsiString): AnsiString;\r\nbegin\r\n Result := S;\r\n StrReverseInplace(Result);\r\nend;\r\n\r\nprocedure StrReverseInPlace(var S: AnsiString);\r\nvar\r\n P1, P2: PAnsiChar;\r\n C: AnsiChar;\r\nbegin\r\n UniqueString(S);\r\n P1 := PAnsiChar(S);\r\n P2 := P1 + SizeOf(AnsiChar) * (Length(S) - 1);\r\n while P1 < P2 do\r\n begin\r\n C := P1^;\r\n P1^ := P2^;\r\n P2^ := C;\r\n Inc(P1);\r\n Dec(P2);\r\n end;\r\nend;\r\n\r\nfunction StrSingleQuote(const S: AnsiString): AnsiString;\r\nbegin\r\n Result := AnsiSingleQuote + S + AnsiSingleQuote;\r\nend;\r\n\r\nprocedure StrSkipChars(var S: PAnsiChar; const Chars: TSysCharSet);\r\nbegin\r\n while S^ in Chars do\r\n Inc(S);\r\nend;\r\n\r\nprocedure StrSkipChars(const S: AnsiString; var Index: SizeInt; const Chars: TSysCharSet);\r\nbegin\r\n while S[Index] in Chars do\r\n Inc(Index);\r\nend;\r\n\r\nfunction StrSmartCase(const S: AnsiString; Delimiters: TSysCharSet): AnsiString;\r\nvar\r\n Source, Dest: PAnsiChar;\r\n Index, Len: SizeInt;\r\nbegin\r\n Result := '';\r\n if Delimiters = [] then\r\n Include(Delimiters, AnsiSpace);\r\n\r\n if S <> '' then\r\n begin\r\n Result := S;\r\n UniqueString(Result);\r\n\r\n Len := Length(S);\r\n Source := PAnsiChar(S);\r\n Dest := PAnsiChar(Result);\r\n Inc(Dest);\r\n\r\n for Index := 2 to Len do\r\n begin\r\n if (Source^ in Delimiters) then\r\n Dest^ := CharUpper(Dest^);\r\n\r\n Inc(Dest);\r\n Inc(Source);\r\n end;\r\n\r\n Result[1] := CharUpper(Result[1]);\r\n end;\r\nend;\r\n\r\nfunction StrStringToEscaped(const S: AnsiString): AnsiString;\r\nvar\r\n I: SizeInt;\r\nbegin\r\n Result := '';\r\n for I := 1 to Length(S) do\r\n begin\r\n case S[I] of\r\n AnsiBackspace:\r\n Result := Result + '\\b';\r\n AnsiBell:\r\n Result := Result + '\\a';\r\n AnsiCarriageReturn:\r\n Result := Result + '\\r';\r\n AnsiFormFeed:\r\n Result := Result + '\\f';\r\n AnsiLineFeed:\r\n Result := Result + '\\n';\r\n AnsiTab:\r\n Result := Result + '\\t';\r\n AnsiVerticalTab:\r\n Result := Result + '\\v';\r\n '\\':\r\n Result := Result + '\\\\';\r\n '\"':\r\n Result := Result + '\\\"';\r\n else\r\n // Characters < ' ' are escaped with hex sequence\r\n if S[I] < #32 then\r\n Result := Result + AnsiString(Format('\\x%.2x', [SizeInt(S[I])]))\r\n else\r\n Result := Result + S[I];\r\n end;\r\n end;\r\nend;\r\n\r\nfunction StrStripNonNumberChars(const S: AnsiString): AnsiString;\r\nvar\r\n I: SizeInt;\r\n C: AnsiChar;\r\nbegin\r\n Result := '';\r\n for I := 1 to Length(S) do\r\n begin\r\n C := S[I];\r\n if CharIsNumberChar(C) then\r\n Result := Result + C;\r\n end;\r\nend;\r\n\r\nfunction StrToHex(const Source: AnsiString): AnsiString;\r\nvar\r\n Index: SizeInt;\r\n C, L, N: SizeInt;\r\n BL, BH: Byte;\r\n S: AnsiString;\r\nbegin\r\n Result := '';\r\n if Source <> '' then\r\n begin\r\n S := Source;\r\n L := Length(S);\r\n if Odd(L) then\r\n begin\r\n S := '0' + S;\r\n Inc(L);\r\n end;\r\n Index := 1;\r\n SetLength(Result, L div 2);\r\n C := 1;\r\n N := 1;\r\n while C <= L do\r\n begin\r\n BH := CharHex(S[Index]);\r\n Inc(Index);\r\n BL := CharHex(S[Index]);\r\n Inc(Index);\r\n Inc(C, 2);\r\n if (BH = $FF) or (BL = $FF) then\r\n begin\r\n Result := '';\r\n Exit;\r\n end;\r\n Result[N] := AnsiChar((Cardinal(BH) shl 4) or Cardinal(BL));\r\n Inc(N);\r\n end;\r\n end;\r\nend;\r\n\r\nfunction StrTrimCharLeft(const S: AnsiString; C: AnsiChar): AnsiString;\r\nvar\r\n I, L: SizeInt;\r\nbegin\r\n I := 1;\r\n L := Length(S);\r\n while (I <= L) and (S[I] = C) do\r\n Inc(I);\r\n Result := Copy(S, I, L - I + 1);\r\nend;\r\n\r\nfunction StrTrimCharsLeft(const S: AnsiString; const Chars: TSysCharSet): AnsiString;\r\nvar\r\n I, L: SizeInt;\r\nbegin\r\n I := 1;\r\n L := Length(S);\r\n while (I <= L) and (S[I] in Chars) do\r\n Inc(I);\r\n Result := Copy(S, I, L - I + 1);\r\nend;\r\n\r\nfunction StrTrimCharsRight(const S: AnsiString; const Chars: TSysCharSet): AnsiString;\r\nvar\r\n I: SizeInt;\r\nbegin\r\n I := Length(S);\r\n while (I >= 1) and (S[I] in Chars) do\r\n Dec(I);\r\n Result := Copy(S, 1, I);\r\nend;\r\n\r\nfunction StrTrimCharRight(const S: AnsiString; C: AnsiChar): AnsiString;\r\nvar\r\n I: SizeInt;\r\nbegin\r\n I := Length(S);\r\n while (I >= 1) and (S[I] = C) do\r\n Dec(I);\r\n Result := Copy(S, 1, I);\r\nend;\r\n\r\nfunction StrTrimQuotes(const S: AnsiString): AnsiString;\r\nvar\r\n First, Last: AnsiChar;\r\n L: SizeInt;\r\nbegin\r\n L := Length(S);\r\n if L > 1 then\r\n begin\r\n First := S[1];\r\n Last := S[L];\r\n if (First = Last) and ((First = AnsiSingleQuote) or (First = AnsiDoubleQuote)) then\r\n Result := Copy(S, 2, L - 2)\r\n else\r\n Result := S;\r\n end\r\n else\r\n Result := S;\r\nend;\r\n\r\nfunction StrTrimQuotes(const S: AnsiString; QuoteChar: AnsiChar): AnsiString;\r\nvar\r\n First, Last: AnsiChar;\r\n L: SizeInt;\r\nbegin\r\n L := Length(S);\r\n if L > 1 then\r\n begin\r\n First := S[1];\r\n Last := S[L];\r\n if (First = Last) and (First = QuoteChar) then\r\n Result := Copy(S, 2, L - 2)\r\n else\r\n Result := S;\r\n end\r\n else\r\n Result := S;\r\nend;\r\n\r\nfunction StrUpper(const S: AnsiString): AnsiString;\r\nbegin\r\n Result := S;\r\n StrUpperInPlace(Result);\r\nend;\r\n\r\nprocedure StrUpperInPlace(var S: AnsiString);\r\nbegin\r\n StrCase(S, AnsiUpOffset);\r\nend;\r\n\r\nprocedure StrUpperBuff(S: PAnsiChar);\r\nbegin\r\n StrCaseBuff(S, AnsiUpOffset);\r\nend;\r\n\r\n{$IFDEF MSWINDOWS}\r\nfunction StrOemToAnsi(const S: AnsiString): AnsiString;\r\nbegin\r\n SetLength(Result, Length(S));\r\n OemToAnsiBuff(PAnsiChar(S), PAnsiChar(Result), Length(S));\r\nend;\r\n\r\nfunction StrAnsiToOem(const S: AnsiString): AnsiString;\r\nbegin\r\n SetLength(Result, Length(S));\r\n AnsiToOemBuff(PAnsiChar(S), PAnsiChar(Result), Length(S));\r\nend;\r\n{$ENDIF MSWINDOWS}\r\n\r\n//=== String Management ======================================================\r\n\r\nprocedure StrAddRef(var S: AnsiString);\r\nvar\r\n P: PAnsiStrRec;\r\nbegin\r\n P := Pointer(S);\r\n if P <> nil then\r\n begin\r\n Dec(P);\r\n if P^.RefCount = -1 then\r\n UniqueString(S)\r\n else\r\n LockedInc(P^.RefCount);\r\n end;\r\nend;\r\n\r\nprocedure StrDecRef(var S: AnsiString);\r\nvar\r\n P: PAnsiStrRec;\r\nbegin\r\n P := Pointer(S);\r\n if P <> nil then\r\n begin\r\n Dec(P);\r\n case P^.RefCount of\r\n -1, 0:\r\n { nothing } ;\r\n 1:\r\n begin\r\n Finalize(S);\r\n Pointer(S) := nil;\r\n end;\r\n else\r\n LockedDec(P^.RefCount);\r\n end;\r\n end;\r\nend;\r\n\r\nfunction StrLength(const S: AnsiString): Longint;\r\nvar\r\n P: PAnsiStrRec;\r\nbegin\r\n Result := 0;\r\n P := Pointer(S);\r\n if P <> nil then\r\n begin\r\n Dec(P);\r\n Result := P^.Length and (not $80000000 shr 1);\r\n end;\r\nend;\r\n\r\nfunction StrRefCount(const S: AnsiString): Longint;\r\nvar\r\n P: PAnsiStrRec;\r\nbegin\r\n Result := 0;\r\n P := Pointer(S);\r\n if P <> nil then\r\n begin\r\n Dec(P);\r\n Result := P^.RefCount;\r\n end;\r\nend;\r\n\r\nprocedure StrResetLength(var S: AnsiString);\r\nvar\r\n I: SizeInt;\r\nbegin\r\n for I := 1 to Length(S) do\r\n if S[I] = #0 then\r\n begin\r\n SetLength(S, I);\r\n Exit;\r\n end;\r\nend;\r\n\r\n//=== String Search and Replace Routines =====================================\r\n\r\nfunction StrCharCount(const S: AnsiString; C: AnsiChar): SizeInt;\r\nvar\r\n I: SizeInt;\r\nbegin\r\n Result := 0;\r\n for I := 1 to Length(S) do\r\n if S[I] = C then\r\n Inc(Result);\r\nend;\r\n\r\nfunction StrCharsCount(const S: AnsiString; Chars: TSysCharSet): SizeInt;\r\nvar\r\n I: SizeInt;\r\nbegin\r\n Result := 0;\r\n for I := 1 to Length(S) do\r\n if S[I] in Chars then\r\n Inc(Result);\r\nend;\r\n\r\nfunction StrStrCount(const S, SubS: AnsiString): SizeInt;\r\nvar\r\n I: SizeInt;\r\nbegin\r\n Result := 0;\r\n if (Length(SubS) > Length(S)) or (Length(SubS) = 0) or (Length(S) = 0) then\r\n Exit;\r\n if Length(SubS) = 1 then\r\n begin\r\n Result := StrCharCount(S, SubS[1]);\r\n Exit;\r\n end;\r\n I := StrSearch(SubS, S, 1);\r\n\r\n if I > 0 then\r\n Inc(Result);\r\n\r\n while (I > 0) and (Length(S) > I + Length(SubS)) do\r\n begin\r\n I := StrSearch(SubS, S, I + 1);\r\n if I > 0 then\r\n Inc(Result);\r\n end;\r\nend;\r\n\r\n(*\r\n{ 1} Test(StrCompareRange('', '', 1, 5), 0);\r\n{ 2} Test(StrCompareRange('A', '', 1, 5), -1);\r\n{ 3} Test(StrCompareRange('AB', '', 1, 5), -1);\r\n{ 4} Test(StrCompareRange('ABC', '', 1, 5), -1);\r\n{ 5} Test(StrCompareRange('', 'A', 1, 5), -1);\r\n{ 6} Test(StrCompareRange('', 'AB', 1, 5), -1);\r\n{ 7} Test(StrCompareRange('', 'ABC', 1, 5), -1);\r\n{ 8} Test(StrCompareRange('A', 'a', 1, 5), -2);\r\n{ 9} Test(StrCompareRange('A', 'a', 1, 1), -32);\r\n{10} Test(StrCompareRange('aA', 'aB', 1, 1), 0);\r\n{11} Test(StrCompareRange('aA', 'aB', 1, 2), -1);\r\n{12} Test(StrCompareRange('aB', 'aA', 1, 2), 1);\r\n{13} Test(StrCompareRange('aA', 'aa', 1, 2), -32);\r\n{14} Test(StrCompareRange('aa', 'aA', 1, 2), 32);\r\n{15} Test(StrCompareRange('', '', 1, 0), 0);\r\n{16} Test(StrCompareRange('A', 'A', 1, 0), -2);\r\n{17} Test(StrCompareRange('Aa', 'A', 1, 0), -2);\r\n{18} Test(StrCompareRange('Aa', 'Aa', 1, 2), 0);\r\n{19} Test(StrCompareRange('Aa', 'A', 1, 2), 0);\r\n{20} Test(StrCompareRange('Ba', 'A', 1, 2), 1);\r\n*)\r\nfunction StrCompareRangeEx(const S1, S2: AnsiString; Index, Count: SizeInt; CaseSensitive: Boolean): SizeInt;\r\nvar\r\n Len1, Len2: SizeInt;\r\n I: SizeInt;\r\n C1, C2: AnsiChar;\r\nbegin\r\n if Pointer(S1) = Pointer(S2) then\r\n begin\r\n if (Count <= 0) and (S1 <> '') then\r\n Result := -2 // no work\r\n else\r\n Result := 0;\r\n end\r\n else\r\n if (S1 = '') or (S2 = '') then\r\n Result := -1 // null string\r\n else\r\n if Count <= 0 then\r\n Result := -2 // no work\r\n else\r\n begin\r\n Len1 := Length(S1);\r\n Len2 := Length(S2);\r\n\r\n if (Index - 1) + Count > Len1 then\r\n Result := -2\r\n else\r\n begin\r\n if (Index - 1) + Count > Len2 then // strange behaviour, but the assembler code does it\r\n Count := Len2 - (Index - 1);\r\n\r\n if CaseSensitive then\r\n begin\r\n for I := 0 to Count - 1 do\r\n begin\r\n C1 := S1[Index + I];\r\n C2 := S2[Index + I];\r\n if C1 <> C2 then\r\n begin\r\n Result := Ord(C1) - Ord(C2);\r\n Exit;\r\n end;\r\n end;\r\n end\r\n else\r\n begin\r\n for I := 0 to Count - 1 do\r\n begin\r\n C1 := S1[Index + I];\r\n C2 := S2[Index + I];\r\n if C1 <> C2 then\r\n begin\r\n C1 := CharLower(C1);\r\n C2 := CharLower(C2);\r\n if C1 <> C2 then\r\n begin\r\n Result := Ord(C1) - Ord(C2);\r\n Exit;\r\n end;\r\n end;\r\n end;\r\n end;\r\n Result := 0;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction StrCompare(const S1, S2: AnsiString; CaseSensitive: Boolean): SizeInt;\r\nvar\r\n Len1, Len2: SizeInt;\r\nbegin\r\n if Pointer(S1) = Pointer(S2) then\r\n Result := 0\r\n else\r\n begin\r\n Len1 := Length(S1);\r\n Len2 := Length(S2);\r\n Result := Len1 - Len2;\r\n if Result = 0 then\r\n Result := StrCompareRangeEx(S1, S2, 1, Len1, CaseSensitive);\r\n end;\r\nend;\r\n\r\nfunction StrCompareRange(const S1, S2: AnsiString; Index, Count: SizeInt; CaseSensitive: Boolean): SizeInt;\r\nbegin\r\n Result := StrCompareRangeEx(S1, S2, Index, Count, CaseSensitive);\r\nend;\r\n\r\nfunction StrRepeatChar(C: AnsiChar; Count: SizeInt): AnsiString;\r\nbegin\r\n SetLength(Result, Count);\r\n if Count > 0 then\r\n FillChar(Result[1], Count, C);\r\nend;\r\n\r\nfunction StrFind(const Substr, S: AnsiString; const Index: SizeInt): SizeInt;\r\nvar\r\n pos: SizeInt;\r\nbegin\r\n if (SubStr <> '') and (S <> '') then\r\n begin\r\n pos := StrIPos(Substr, Copy(S, Index, Length(S) - Index + 1));\r\n if pos = 0 then\r\n Result := 0\r\n else\r\n Result := Index + Pos - 1;\r\n end\r\n else\r\n Result := 0;\r\nend;\r\n\r\nfunction StrHasPrefix(const S: AnsiString; const Prefixes: array of AnsiString): Boolean;\r\nbegin\r\n Result := StrPrefixIndex(S, Prefixes) > -1;\r\nend;\r\n\r\nfunction StrHasSuffix(const S: AnsiString; const Suffixes: array of AnsiString): Boolean;\r\nbegin\r\n Result := StrSuffixIndex(S, Suffixes) > -1;\r\nend;\r\n\r\nfunction StrIHasPrefix(const S: AnsiString; const Prefixes: array of AnsiString): Boolean;\r\nbegin\r\n Result := StrIPrefixIndex(S, Prefixes) > -1;\r\nend;\r\n\r\nfunction StrIHasSuffix(const S: AnsiString; const Suffixes: array of AnsiString): Boolean;\r\nbegin\r\n Result := StrISuffixIndex(S, Suffixes) > -1;\r\nend;\r\n\r\nfunction StrIndex(const S: AnsiString; const List: array of AnsiString; CaseSensitive: Boolean): SizeInt;\r\nvar\r\n I: SizeInt;\r\nbegin\r\n Result := -1;\r\n for I := Low(List) to High(List) do\r\n begin\r\n if StrCompare(S, List[I], CaseSensitive) = 0 then\r\n begin\r\n Result := I;\r\n Break;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction StrILastPos(const SubStr, S: AnsiString): SizeInt;\r\nbegin\r\n Result := StrLastPos(StrUpper(SubStr), StrUpper(S));\r\nend;\r\n\r\nfunction StrIPos(const SubStr, S: AnsiString): SizeInt;\r\nbegin\r\n Result := Pos(StrUpper(SubStr), StrUpper(S));\r\nend;\r\n\r\nfunction StrIPrefixIndex(const S: AnsiString; const Prefixes: array of AnsiString): SizeInt;\r\nvar\r\n I: SizeInt;\r\n Test: AnsiString;\r\nbegin\r\n Result := -1;\r\n for I := Low(Prefixes) to High(Prefixes) do\r\n begin\r\n Test := StrLeft(S, Length(Prefixes[I]));\r\n if CompareText(Test, Prefixes[I]) = 0 then\r\n begin\r\n Result := I;\r\n Break;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction StrIsOneOf(const S: AnsiString; const List: array of AnsiString): Boolean;\r\nbegin\r\n Result := StrIndex(S, List) > -1;\r\nend;\r\n\r\nfunction StrISuffixIndex(const S: AnsiString; const Suffixes: array of AnsiString): SizeInt;\r\nvar\r\n I: SizeInt;\r\n Test: AnsiString;\r\nbegin\r\n Result := -1;\r\n for I := Low(Suffixes) to High(Suffixes) do\r\n begin\r\n Test := StrRight(S, Length(Suffixes[I]));\r\n if CompareText(Test, Suffixes[I]) = 0 then\r\n begin\r\n Result := I;\r\n Break;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction StrLastPos(const SubStr, S: AnsiString): SizeInt;\r\nvar\r\n Last, Current: PAnsiChar;\r\nbegin\r\n Result := 0;\r\n Last := nil;\r\n Current := PAnsiChar(S);\r\n\r\n while (Current <> nil) and (Current^ <> #0) do\r\n begin\r\n Current := {$if CompilerVersion > 24}System.AnsiStrings.{$endif}AnsiStrPos(PAnsiChar(Current), PAnsiChar(SubStr));\r\n if Current <> nil then\r\n begin\r\n Last := Current;\r\n Inc(Current);\r\n end;\r\n end;\r\n if Last <> nil then\r\n Result := Abs(PAnsiChar(S) - Last) + 1;\r\nend;\r\n\r\n// IMPORTANT NOTE: The StrMatch function does currently not work with the Asterix (*)\r\n// (*) acts like (?)\r\n\r\nfunction StrMatch(const Substr, S: AnsiString; Index: SizeInt): SizeInt;\r\nvar\r\n SI, SubI, SLen, SubLen: SizeInt;\r\n SubC: AnsiChar;\r\nbegin\r\n SLen := Length(S);\r\n SubLen := Length(Substr);\r\n Result := 0;\r\n if (Index > SLen) or (SubLen = 0) then\r\n Exit;\r\n while Index <= SLen do\r\n begin\r\n SubI := 1;\r\n SI := Index;\r\n while (SI <= SLen) and (SubI <= SubLen) do\r\n begin\r\n SubC := Substr[SubI];\r\n if (SubC = '*') or (SubC = '?') or (SubC = S[SI]) then\r\n begin\r\n Inc(SI);\r\n Inc(SubI);\r\n end\r\n else\r\n Break;\r\n end;\r\n if SubI > SubLen then\r\n begin\r\n Result := Index;\r\n Break;\r\n end;\r\n Inc(Index);\r\n end;\r\nend;\r\n\r\n\r\n// Derived from \"Like\" by Michael Winter\r\n\r\nfunction StrMatches(const Substr, S: AnsiString; const Index: SizeInt): Boolean;\r\nvar\r\n StringPtr: PAnsiChar;\r\n PatternPtr: PAnsiChar;\r\n StringRes: PAnsiChar;\r\n PatternRes: PAnsiChar;\r\nbegin\r\n if SubStr = '' then\r\n raise EJclAnsiStringError.CreateRes(@RsBlankSearchString);\r\n\r\n Result := SubStr = '*';\r\n\r\n if Result or (S = '') then\r\n Exit;\r\n\r\n if (Index <= 0) or (Index > Length(S)) then\r\n raise EJclAnsiStringError.CreateRes(@RsArgumentOutOfRange);\r\n\r\n StringPtr := PAnsiChar(@S[Index]);\r\n PatternPtr := PAnsiChar(SubStr);\r\n StringRes := nil;\r\n PatternRes := nil;\r\n\r\n repeat\r\n repeat\r\n case PatternPtr^ of\r\n #0:\r\n begin\r\n Result := StringPtr^ = #0;\r\n if Result or (StringRes = nil) or (PatternRes = nil) then\r\n Exit;\r\n\r\n StringPtr := StringRes;\r\n PatternPtr := PatternRes;\r\n Break;\r\n end;\r\n '*':\r\n begin\r\n Inc(PatternPtr);\r\n PatternRes := PatternPtr;\r\n Break;\r\n end;\r\n '?':\r\n begin\r\n if StringPtr^ = #0 then\r\n Exit;\r\n Inc(StringPtr);\r\n Inc(PatternPtr);\r\n end;\r\n else\r\n begin\r\n if StringPtr^ = #0 then\r\n Exit;\r\n if StringPtr^ <> PatternPtr^ then\r\n begin\r\n if (StringRes = nil) or (PatternRes = nil) then\r\n Exit;\r\n StringPtr := StringRes;\r\n PatternPtr := PatternRes;\r\n Break;\r\n end\r\n else\r\n begin\r\n Inc(StringPtr);\r\n Inc(PatternPtr);\r\n end;\r\n end;\r\n end;\r\n until False;\r\n\r\n repeat\r\n case PatternPtr^ of\r\n #0:\r\n begin\r\n Result := True;\r\n Exit;\r\n end;\r\n '*':\r\n begin\r\n Inc(PatternPtr);\r\n PatternRes := PatternPtr;\r\n end;\r\n '?':\r\n begin\r\n if StringPtr^ = #0 then\r\n Exit;\r\n Inc(StringPtr);\r\n Inc(PatternPtr);\r\n end;\r\n else\r\n begin\r\n repeat\r\n if StringPtr^ = #0 then\r\n Exit;\r\n if StringPtr^ = PatternPtr^ then\r\n Break;\r\n Inc(StringPtr);\r\n until False;\r\n Inc(StringPtr);\r\n StringRes := StringPtr;\r\n Inc(PatternPtr);\r\n Break;\r\n end;\r\n end;\r\n until False;\r\n until False;\r\nend;\r\n\r\nfunction StrNPos(const S, SubStr: AnsiString; N: SizeInt): SizeInt;\r\nvar\r\n I, P: SizeInt;\r\nbegin\r\n if N < 1 then\r\n begin\r\n Result := 0;\r\n Exit;\r\n end;\r\n\r\n Result := StrSearch(SubStr, S, 1);\r\n I := 1;\r\n while I < N do\r\n begin\r\n P := StrSearch(SubStr, S, Result + 1);\r\n if P = 0 then\r\n begin\r\n Result := 0;\r\n Break;\r\n end\r\n else\r\n begin\r\n Result := P;\r\n Inc(I);\r\n end;\r\n end;\r\nend;\r\n\r\nfunction StrNIPos(const S, SubStr: AnsiString; N: SizeInt): SizeInt;\r\nvar\r\n I, P: SizeInt;\r\nbegin\r\n if N < 1 then\r\n begin\r\n Result := 0;\r\n Exit;\r\n end;\r\n\r\n Result := StrFind(SubStr, S, 1);\r\n I := 1;\r\n while I < N do\r\n begin\r\n P := StrFind(SubStr, S, Result + 1);\r\n if P = 0 then\r\n begin\r\n Result := 0;\r\n Break;\r\n end\r\n else\r\n begin\r\n Result := P;\r\n Inc(I);\r\n end;\r\n end;\r\nend;\r\n\r\nfunction StrPrefixIndex(const S: AnsiString; const Prefixes: array of AnsiString): SizeInt;\r\nvar\r\n I: SizeInt;\r\n Test: AnsiString;\r\nbegin\r\n Result := -1;\r\n for I := Low(Prefixes) to High(Prefixes) do\r\n begin\r\n Test := StrLeft(S, Length(Prefixes[I]));\r\n if CompareStr(Test, Prefixes[I]) = 0 then\r\n begin\r\n Result := I;\r\n Break;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction StrSearch(const Substr, S: AnsiString; const Index: SizeInt): SizeInt;\r\nvar\r\n SP, SPI, SubP: PAnsiChar;\r\n SLen: SizeInt;\r\nbegin\r\n SLen := Length(S);\r\n if Index <= SLen then\r\n begin\r\n SP := PAnsiChar(S);\r\n SubP := PAnsiChar(Substr);\r\n SPI := SP;\r\n Inc(SPI, Index);\r\n Dec(SPI);\r\n SPI := {$if CompilerVersion > 24}System.AnsiStrings.{$endif}StrPos(SPI, SubP);\r\n if SPI <> nil then\r\n Result := SPI - SP + 1\r\n else\r\n Result := 0;\r\n end\r\n else\r\n Result := 0;\r\nend;\r\n\r\nfunction StrSuffixIndex(const S: AnsiString; const Suffixes: array of AnsiString): SizeInt;\r\nvar\r\n I: SizeInt;\r\n Test: AnsiString;\r\nbegin\r\n Result := -1;\r\n for I := Low(Suffixes) to High(Suffixes) do\r\n begin\r\n Test := StrRight(S, Length(Suffixes[I]));\r\n if CompareStr(Test, Suffixes[I]) = 0 then\r\n begin\r\n Result := I;\r\n Break;\r\n end;\r\n end;\r\nend;\r\n\r\n//=== String Extraction ======================================================\r\n\r\nfunction StrAfter(const SubStr, S: AnsiString): AnsiString;\r\nvar\r\n P: SizeInt;\r\nbegin\r\n P := StrFind(SubStr, S, 1); // StrFind is case-insensitive pos\r\n if P <= 0 then\r\n Result := '' // substr not found -> nothing after it\r\n else\r\n Result := StrRestOf(S, P + Length(SubStr));\r\nend;\r\n\r\nfunction StrBefore(const SubStr, S: AnsiString): AnsiString;\r\nvar\r\n P: SizeInt;\r\nbegin\r\n P := StrFind(SubStr, S, 1);\r\n if P <= 0 then\r\n Result := S\r\n else\r\n Result := StrLeft(S, P - 1);\r\nend;\r\n\r\nfunction StrSplit(const SubStr, S: AnsiString;var Left, Right : AnsiString): boolean;\r\nvar\r\n P: SizeInt;\r\nbegin\r\n P := StrFind(SubStr, S, 1);\r\n Result:= p > 0;\r\n if Result then\r\n begin\r\n Left := StrLeft(S, P - 1);\r\n Right := StrRestOf(S, P + Length(SubStr));\r\n end\r\n else\r\n begin\r\n Left := '';\r\n Right := '';\r\n end;\r\nend;\r\n\r\nfunction StrBetween(const S: AnsiString; const Start, Stop: AnsiChar): AnsiString;\r\nvar\r\n PosStart, PosEnd: SizeInt;\r\n L: SizeInt;\r\nbegin\r\n PosStart := Pos(Start, S);\r\n PosEnd := StrSearch(Stop, S, PosStart + 1); // PosEnd has to be after PosStart.\r\n\r\n if (PosStart > 0) and (PosEnd > PosStart) then\r\n begin\r\n L := PosEnd - PosStart;\r\n Result := Copy(S, PosStart + 1, L - 1);\r\n end\r\n else\r\n Result := '';\r\nend;\r\n\r\nfunction StrChopRight(const S: AnsiString; N: SizeInt): AnsiString;\r\nbegin\r\n Result := Copy(S, 1, Length(S) - N);\r\nend;\r\n\r\nfunction StrLeft(const S: AnsiString; Count: SizeInt): AnsiString;\r\nbegin\r\n Result := Copy(S, 1, Count);\r\nend;\r\n\r\nfunction StrMid(const S: AnsiString; Start, Count: SizeInt): AnsiString;\r\nbegin\r\n Result := Copy(S, Start, Count);\r\nend;\r\n\r\nfunction StrRestOf(const S: AnsiString; N: SizeInt): AnsiString;\r\nbegin\r\n Result := Copy(S, N, (Length(S) - N + 1));\r\nend;\r\n\r\nfunction StrRight(const S: AnsiString; Count: SizeInt): AnsiString;\r\nbegin\r\n Result := Copy(S, Length(S) - Count + 1, Count);\r\nend;\r\n\r\n//=== Character (do we have it ;) ============================================\r\n\r\nfunction CharEqualNoCase(const C1, C2: AnsiChar): Boolean;\r\nbegin\r\n // if they are not equal chars, may be same letter different case\r\n Result := (C1 = C2) or\r\n (CharIsAlpha(C1) and CharIsAlpha(C2) and (CharLower(C1) = CharLower(C2)));\r\nend;\r\n\r\n\r\nfunction CharIsAlpha(const C: AnsiChar): Boolean;\r\nbegin\r\n Result := (AnsiCharTypes[C] and C1_ALPHA) <> 0;\r\nend;\r\n\r\nfunction CharIsAlphaNum(const C: AnsiChar): Boolean;\r\nbegin\r\n Result := ((AnsiCharTypes[C] and C1_ALPHA) <> 0) or\r\n ((AnsiCharTypes[C] and C1_DIGIT) <> 0);\r\nend;\r\n\r\nfunction CharIsBlank(const C: AnsiChar): Boolean;\r\nbegin\r\n Result := ((AnsiCharTypes[C] and C1_BLANK) <> 0);\r\nend;\r\n\r\nfunction CharIsControl(const C: AnsiChar): Boolean;\r\nbegin\r\n Result := (AnsiCharTypes[C] and C1_CNTRL) <> 0;\r\nend;\r\n\r\nfunction CharIsDelete(const C: AnsiChar): Boolean;\r\nbegin\r\n Result := (C = #8);\r\nend;\r\n\r\nfunction CharIsDigit(const C: AnsiChar): Boolean;\r\nbegin\r\n Result := (AnsiCharTypes[C] and C1_DIGIT) <> 0;\r\nend;\r\n\r\nfunction CharIsFracDigit(const C: AnsiChar): Boolean;\r\nbegin\r\n Result := (C = '.') or ((AnsiCharTypes[C] and C1_DIGIT) <> 0);\r\nend;\r\n\r\nfunction CharIsHexDigit(const C: AnsiChar): Boolean;\r\nbegin\r\n case C of\r\n 'A'..'F',\r\n 'a'..'f':\r\n Result := True;\r\n else\r\n Result := ((AnsiCharTypes[C] and C1_DIGIT) <> 0);\r\n end;\r\nend;\r\n\r\nfunction CharIsLower(const C: AnsiChar): Boolean;\r\nbegin\r\n Result := (AnsiCharTypes[C] and C1_LOWER) <> 0;\r\nend;\r\n\r\n// JclSysUtils.TJclFormatSettings.GetDecimalSeparator is manually inlined in the 2 following functions\r\n// this fixes compiler warnings about functions not being inlined\r\n \r\nfunction CharIsNumberChar(const C: AnsiChar): Boolean;\r\nbegin\r\n Result := ((AnsiCharTypes[C] and C1_DIGIT) <> 0) or (C = AnsiSignMinus) or (C = AnsiSignPlus) or\r\n (Char(C) = {$IFDEF RTL220_UP}FormatSettings.DecimalSeparator{$ELSE}SysUtils.DecimalSeparator{$ENDIF});\r\nend;\r\n\r\nfunction CharIsNumber(const C: AnsiChar): Boolean;\r\nbegin\r\n Result := ((AnsiCharTypes[C] and C1_DIGIT) <> 0) or\r\n (Char(C) = {$IFDEF RTL220_UP}FormatSettings.DecimalSeparator{$ELSE}SysUtils.DecimalSeparator{$ENDIF});\r\nend;\r\n\r\nfunction CharIsPrintable(const C: AnsiChar): Boolean;\r\nbegin\r\n Result := not CharIsControl(C);\r\nend;\r\n\r\nfunction CharIsPunctuation(const C: AnsiChar): Boolean;\r\nbegin\r\n Result := ((AnsiCharTypes[C] and C1_PUNCT) <> 0);\r\nend;\r\n\r\nfunction CharIsReturn(const C: AnsiChar): Boolean;\r\nbegin\r\n Result := (C = AnsiLineFeed) or (C = AnsiCarriageReturn);\r\nend;\r\n\r\nfunction CharIsSpace(const C: AnsiChar): Boolean;\r\nbegin\r\n Result := (AnsiCharTypes[C] and C1_SPACE) <> 0;\r\nend;\r\n\r\nfunction CharIsUpper(const C: AnsiChar): Boolean;\r\nbegin\r\n Result := (AnsiCharTypes[C] and C1_UPPER) <> 0;\r\nend;\r\n\r\nfunction CharIsValidIdentifierLetter(const C: AnsiChar): Boolean;\r\nbegin\r\n case C of\r\n '0'..'9', 'A'..'Z', 'a'..'z', '_':\r\n Result := True;\r\n else\r\n Result := False;\r\n end;\r\nend;\r\n\r\nfunction CharIsWhiteSpace(const C: AnsiChar): Boolean;\r\nbegin\r\n Result := (C = AnsiTab) or (C = AnsiLineFeed) or (C = AnsiVerticalTab) or\r\n (C = AnsiFormFeed) or (C = AnsiCarriageReturn) or (C =AnsiSpace) or\r\n ((AnsiCharTypes[C] and C1_SPACE) <> 0);\r\nend;\r\n\r\nfunction CharIsWildcard(const C: AnsiChar): Boolean;\r\nbegin\r\n case C of\r\n '*', '?':\r\n Result := True;\r\n else\r\n Result := False;\r\n end;\r\nend;\r\n\r\nfunction CharType(const C: AnsiChar): Word;\r\nbegin\r\n Result := AnsiCharTypes[C];\r\nend;\r\n\r\n//=== PCharVector ============================================================\r\n\r\nfunction StringsToPCharVector(var Dest: PAnsiCharVector; const Source: TJclAnsiStrings): PAnsiCharVector;\r\nvar\r\n I: SizeInt;\r\n S: AnsiString;\r\n List: array of PAnsiChar;\r\nbegin\r\n Assert(Source <> nil);\r\n Dest := AllocMem((Source.Count + SizeOf(AnsiChar)) * SizeOf(PAnsiChar));\r\n SetLength(List, Source.Count + SizeOf(AnsiChar));\r\n for I := 0 to Source.Count - 1 do\r\n begin\r\n S := Source[I];\r\n {$IFDEF SUPPORTS_UNICODE}\r\n List[I] := AnsiStrAlloc(Length(S) + SizeOf(AnsiChar));\r\n {$ELSE ~SUPPORTS_UNICODE}\r\n List[I] := StrAlloc(Length(S) + SizeOf(AnsiChar));\r\n {$ENDIF ~SUPPORTS_UNICODE}\r\n {$if CompilerVersion > 24}System.AnsiStrings.{$endif}StrPCopy(List[I], S);\r\n end;\r\n List[Source.Count] := nil;\r\n Move(List[0], Dest^, (Source.Count + 1) * SizeOf(PAnsiChar));\r\n Result := Dest;\r\nend;\r\n\r\nfunction PCharVectorCount(Source: PAnsiCharVector): SizeInt;\r\nbegin\r\n Result := 0;\r\n if Source <> nil then\r\n while Source^ <> nil do\r\n begin\r\n Inc(Source);\r\n Inc(Result);\r\n end;\r\nend;\r\n\r\nprocedure PCharVectorToStrings(const Dest: TJclAnsiStrings; Source: PAnsiCharVector);\r\nvar\r\n I, Count: SizeInt;\r\n List: array of PAnsiChar;\r\nbegin\r\n Assert(Dest <> nil);\r\n if Source <> nil then\r\n begin\r\n Count := PCharVectorCount(Source);\r\n SetLength(List, Count);\r\n Move(Source^, List[0], Count * SizeOf(PAnsiChar));\r\n Dest.BeginUpdate;\r\n try\r\n Dest.Clear;\r\n for I := 0 to Count - 1 do\r\n Dest.Add(List[I]);\r\n finally\r\n Dest.EndUpdate;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure FreePCharVector(var Dest: PAnsiCharVector);\r\nvar\r\n I, Count: SizeInt;\r\n List: array of PAnsiChar;\r\nbegin\r\n if Dest <> nil then\r\n begin\r\n Count := PCharVectorCount(Dest);\r\n SetLength(List, Count);\r\n Move(Dest^, List[0], Count * SizeOf(PAnsiChar));\r\n for I := 0 to Count - 1 do\r\n {$if CompilerVersion > 24}System.AnsiStrings.{$endif}StrDispose(List[I]);\r\n FreeMem(Dest, (Count + 1) * SizeOf(PAnsiChar));\r\n Dest := nil;\r\n end;\r\nend;\r\n\r\n//=== Character Transformation Routines ======================================\r\n\r\nfunction CharHex(const C: AnsiChar): Byte;\r\nbegin\r\n case C of\r\n '0'..'9':\r\n Result := Ord(C) - Ord('0');\r\n 'a'..'f':\r\n Result := Ord(C) - Ord('a') + 10;\r\n 'A'..'F':\r\n Result := Ord(C) - Ord('A') + 10;\r\n else\r\n Result := $FF;\r\n end;\r\nend;\r\n\r\nfunction CharLower(const C: AnsiChar): AnsiChar;\r\nbegin\r\n Result := AnsiCaseMap[Ord(C) + AnsiLoOffset];\r\nend;\r\n\r\nfunction CharToggleCase(const C: AnsiChar): AnsiChar;\r\nbegin\r\n Result := AnsiCaseMap[Ord(C) + AnsiReOffset];\r\nend;\r\n\r\nfunction CharUpper(const C: AnsiChar): AnsiChar;\r\nbegin\r\n Result := AnsiCaseMap[Ord(C) + AnsiUpOffset];\r\nend;\r\n\r\n//=== Character Search and Replace ===========================================\r\n\r\nfunction CharLastPos(const S: AnsiString; const C: AnsiChar; const Index: SizeInt): SizeInt;\r\nbegin\r\n if (Index > 0) and (Index <= Length(S)) then\r\n for Result := Length(S) downto Index do\r\n if S[Result] = C then\r\n Exit;\r\n Result := 0;\r\nend;\r\n\r\nfunction CharPos(const S: AnsiString; const C: AnsiChar; const Index: SizeInt): SizeInt;\r\nbegin\r\n if (Index > 0) and (Index <= Length(S)) then\r\n for Result := Index to Length(S) do\r\n if S[Result] = C then\r\n Exit;\r\n Result := 0;\r\nend;\r\n\r\nfunction CharIPos(const S: AnsiString; C: AnsiChar; const Index: SizeInt): SizeInt;\r\nbegin\r\n if (Index > 0) and (Index <= Length(S)) then\r\n begin\r\n C := CharUpper(C);\r\n for Result := Index to Length(S) do\r\n if AnsiCaseMap[Ord(S[Result]) + AnsiUpOffset] = C then\r\n Exit;\r\n end;\r\n Result := 0;\r\nend;\r\n\r\nfunction CharReplace(var S: AnsiString; const Search, Replace: AnsiChar): SizeInt;\r\nvar\r\n P: PAnsiChar;\r\n Index, Len: SizeInt;\r\nbegin\r\n Result := 0;\r\n if Search <> Replace then\r\n begin\r\n UniqueString(S);\r\n Len := Length(S);\r\n P := PAnsiChar(S);\r\n for Index := 0 to Len - 1 do\r\n begin\r\n if P^ = Search then\r\n begin\r\n P^ := Replace;\r\n Inc(Result);\r\n end;\r\n Inc(P);\r\n end;\r\n end;\r\nend;\r\n\r\n//=== MultiSz ================================================================\r\n\r\nfunction StringsToMultiSz(var Dest: PAnsiMultiSz; const Source: TJclAnsiStrings): PAnsiMultiSz;\r\nvar\r\n I, TotalLength: SizeInt;\r\n P: PAnsiMultiSz;\r\nbegin\r\n Assert(Source <> nil);\r\n TotalLength := 1;\r\n for I := 0 to Source.Count - 1 do\r\n if Source[I] = '' then\r\n raise EJclAnsiStringError.CreateRes(@RsInvalidEmptyStringItem)\r\n else\r\n Inc(TotalLength, {$if CompilerVersion > 24}System.AnsiStrings.{$endif}StrLen(PAnsiChar(AnsiString(Source[I]))) + 1);\r\n AllocateMultiSz(Dest, TotalLength);\r\n P := Dest;\r\n for I := 0 to Source.Count - 1 do\r\n begin\r\n P := {$if CompilerVersion > 24}System.AnsiStrings.{$endif}StrECopy(P, PAnsiChar(AnsiString(Source[I])));\r\n Inc(P);\r\n end;\r\n P^ := #0;\r\n Result := Dest;\r\nend;\r\n\r\nprocedure MultiSzToStrings(const Dest: TJclAnsiStrings; const Source: PAnsiMultiSz);\r\nvar\r\n P: PAnsiMultiSz;\r\nbegin\r\n Assert(Dest <> nil);\r\n Dest.BeginUpdate;\r\n try\r\n Dest.Clear;\r\n if Source <> nil then\r\n begin\r\n P := Source;\r\n while P^ <> #0 do\r\n begin\r\n Dest.Add(P);\r\n P := {$if CompilerVersion > 24}System.AnsiStrings.{$endif}StrEnd(P);\r\n Inc(P);\r\n end;\r\n end;\r\n finally\r\n Dest.EndUpdate;\r\n end;\r\nend;\r\n\r\nfunction MultiSzLength(const Source: PAnsiMultiSz): SizeInt;\r\nvar\r\n P: PAnsiMultiSz;\r\nbegin\r\n Result := 0;\r\n if Source <> nil then\r\n begin\r\n P := Source;\r\n repeat\r\n Inc(Result, {$if CompilerVersion > 24}System.AnsiStrings.{$endif}StrLen(P) + 1);\r\n P := {$if CompilerVersion > 24}System.AnsiStrings.{$endif}StrEnd(P);\r\n Inc(P);\r\n until P^ = #0;\r\n Inc(Result);\r\n end;\r\nend;\r\n\r\nprocedure AllocateMultiSz(var Dest: PAnsiMultiSz; Len: SizeInt);\r\nbegin\r\n if Len > 0 then\r\n GetMem(Dest, Len * SizeOf(AnsiChar))\r\n else\r\n Dest := nil;\r\nend;\r\n\r\nprocedure FreeMultiSz(var Dest: PAnsiMultiSz);\r\nbegin\r\n if Dest <> nil then\r\n FreeMem(Dest);\r\n Dest := nil;\r\nend;\r\n\r\nfunction MultiSzDup(const Source: PAnsiMultiSz): PAnsiMultiSz;\r\nvar\r\n Len: SizeInt;\r\nbegin\r\n if Source <> nil then\r\n begin\r\n Len := MultiSzLength(Source);\r\n Result := nil;\r\n AllocateMultiSz(Result, Len);\r\n Move(Source^, Result^, Len * SizeOf(AnsiChar));\r\n end\r\n else\r\n Result := nil;\r\nend;\r\n\r\n//=== TJclAnsiStrings Manipulation ===============================================\r\n\r\nprocedure StrToStrings(S, Sep: AnsiString; const List: TJclAnsiStrings; const AllowEmptyString: Boolean = True);\r\nvar\r\n I, L: SizeInt;\r\n Left: AnsiString;\r\nbegin\r\n Assert(List <> nil);\r\n List.BeginUpdate;\r\n try\r\n List.Clear;\r\n L := Length(Sep);\r\n I := Pos(Sep, S);\r\n while I > 0 do\r\n begin\r\n Left := StrLeft(S, I - 1);\r\n if (Left <> '') or AllowEmptyString then\r\n List.Add(Left);\r\n Delete(S, 1, I + L - 1);\r\n I := Pos(Sep, S);\r\n end;\r\n if S <> '' then\r\n List.Add(S); // Ignore empty strings at the end.\r\n finally\r\n List.EndUpdate;\r\n end;\r\nend;\r\n\r\nprocedure StrIToStrings(S, Sep: AnsiString; const List: TJclAnsiStrings; const AllowEmptyString: Boolean = True);\r\nvar\r\n I, L: SizeInt;\r\n LowerCaseStr: AnsiString;\r\n Left: AnsiString;\r\nbegin\r\n Assert(List <> nil);\r\n LowerCaseStr := StrLower(S);\r\n Sep := StrLower(Sep);\r\n L := Length(Sep);\r\n I := Pos(Sep, LowerCaseStr);\r\n List.BeginUpdate;\r\n try\r\n List.Clear;\r\n while I > 0 do\r\n begin\r\n Left := StrLeft(S, I - 1);\r\n if (Left <> '') or AllowEmptyString then\r\n List.Add(Left);\r\n Delete(S, 1, I + L - 1);\r\n Delete(LowerCaseStr, 1, I + L - 1);\r\n I := Pos(Sep, LowerCaseStr);\r\n end;\r\n if S <> '' then\r\n List.Add(S); // Ignore empty strings at the end.\r\n finally\r\n List.EndUpdate;\r\n end;\r\nend;\r\n\r\nfunction StringsToStr(const List: TJclAnsiStrings; const Sep: AnsiString;\r\n const AllowEmptyString: Boolean): AnsiString;\r\nvar\r\n I, L: SizeInt;\r\nbegin\r\n Result := '';\r\n for I := 0 to List.Count - 1 do\r\n begin\r\n if (List[I] <> '') or AllowEmptyString then\r\n begin\r\n // don't combine these into one addition, somehow it hurts performance\r\n Result := Result + List[I];\r\n Result := Result + Sep;\r\n end;\r\n end;\r\n // remove terminating separator\r\n if List.Count <> 0 then\r\n begin\r\n L := Length(Sep);\r\n Delete(Result, Length(Result) - L + 1, L);\r\n end;\r\nend;\r\n\r\nprocedure TrimStrings(const List: TJclAnsiStrings; DeleteIfEmpty: Boolean);\r\nvar\r\n I: SizeInt;\r\nbegin\r\n Assert(List <> nil);\r\n List.BeginUpdate;\r\n try\r\n for I := List.Count - 1 downto 0 do\r\n begin\r\n List[I] := Trim(List[I]);\r\n if (List[I] = '') and DeleteIfEmpty then\r\n List.Delete(I);\r\n end;\r\n finally\r\n List.EndUpdate;\r\n end;\r\nend;\r\n\r\nprocedure TrimStringsRight(const List: TJclAnsiStrings; DeleteIfEmpty: Boolean);\r\nvar\r\n I: SizeInt;\r\nbegin\r\n Assert(List <> nil);\r\n List.BeginUpdate;\r\n try\r\n for I := List.Count - 1 downto 0 do\r\n begin\r\n List[I] := TrimRight(List[I]);\r\n if (List[I] = '') and DeleteIfEmpty then\r\n List.Delete(I);\r\n end;\r\n finally\r\n List.EndUpdate;\r\n end;\r\nend;\r\n\r\nprocedure TrimStringsLeft(const List: TJclAnsiStrings; DeleteIfEmpty: Boolean);\r\nvar\r\n I: SizeInt;\r\nbegin\r\n Assert(List <> nil);\r\n List.BeginUpdate;\r\n try\r\n for I := List.Count - 1 downto 0 do\r\n begin\r\n List[I] := TrimLeft(List[I]);\r\n if (List[I] = '') and DeleteIfEmpty then\r\n List.Delete(I);\r\n end;\r\n finally\r\n List.EndUpdate;\r\n end;\r\nend;\r\n\r\nfunction AddStringToStrings(const S: AnsiString; Strings: TJclAnsiStrings; const Unique: Boolean): Boolean;\r\nbegin\r\n Assert(Strings <> nil);\r\n Result := Unique and (Strings.IndexOf(S) <> -1);\r\n if not Result then\r\n Result := Strings.Add(S) > -1;\r\nend;\r\n\r\n//=== Miscellaneous ==========================================================\r\n\r\nfunction FileToString(const FileName: TFileName): AnsiString;\r\nvar\r\n FS: TFileStream;\r\n Len: SizeInt;\r\nbegin\r\n FS := TFileStream.Create(FileName, fmOpenRead or fmShareDenyWrite);\r\n try\r\n Len := FS.Size;\r\n SetLength(Result, Len);\r\n if Len > 0 then\r\n FS.ReadBuffer(Result[1], Len);\r\n finally\r\n FS.Free;\r\n end;\r\nend;\r\n\r\nprocedure StringToFile(const FileName: TFileName; const Contents: AnsiString; Append: Boolean);\r\nvar\r\n FS: TFileStream;\r\n Len: SizeInt;\r\nbegin\r\n if Append and FileExists(FileName) then\r\n FS := TFileStream.Create(FileName, fmOpenReadWrite or fmShareDenyWrite)\r\n else\r\n FS := TFileStream.Create(FileName, fmCreate);\r\n try\r\n if Append then\r\n FS.Seek(0, soEnd); // faster than .Position := .Size\r\n Len := Length(Contents);\r\n if Len > 0 then\r\n FS.WriteBuffer(Contents[1], Len);\r\n finally\r\n FS.Free;\r\n end;\r\nend;\r\n\r\nfunction StrToken(var S: AnsiString; Separator: AnsiChar): AnsiString;\r\nvar\r\n I: SizeInt;\r\nbegin\r\n I := Pos(Separator, S);\r\n if I <> 0 then\r\n begin\r\n Result := Copy(S, 1, I - 1);\r\n Delete(S, 1, I);\r\n end\r\n else\r\n begin\r\n Result := S;\r\n S := '';\r\n end;\r\nend;\r\n\r\nprocedure StrTokens(const S: AnsiString; const List: TJclAnsiStrings);\r\nvar\r\n Start: PAnsiChar;\r\n Token: AnsiString;\r\n Done: Boolean;\r\nbegin\r\n Assert(List <> nil);\r\n if List = nil then\r\n Exit;\r\n\r\n List.BeginUpdate;\r\n try\r\n List.Clear;\r\n Start := Pointer(S);\r\n repeat\r\n Done := StrWord(Start, Token);\r\n if Token <> '' then\r\n List.Add(Token);\r\n until Done;\r\n finally\r\n List.EndUpdate;\r\n end;\r\nend;\r\n\r\nprocedure StrTokenToStrings(S: AnsiString; Separator: AnsiChar; const List: TJclAnsiStrings);\r\nvar\r\n Token: AnsiString;\r\nbegin\r\n Assert(List <> nil);\r\n\r\n if List = nil then\r\n Exit;\r\n\r\n List.BeginUpdate;\r\n try\r\n List.Clear;\r\n while S <> '' do\r\n begin\r\n Token := StrToken(S, Separator);\r\n List.Add(Token);\r\n end;\r\n finally\r\n List.EndUpdate;\r\n end;\r\nend;\r\n\r\nfunction StrWord(const S: AnsiString; var Index: SizeInt; out Word: AnsiString): Boolean;\r\nvar\r\n Start: SizeInt;\r\n C: AnsiChar;\r\nbegin\r\n Word := '';\r\n if (S = '') then\r\n begin\r\n Result := True;\r\n Exit;\r\n end;\r\n Start := Index;\r\n Result := False;\r\n while True do\r\n begin\r\n C := S[Index];\r\n case C of\r\n #0:\r\n begin\r\n if Start <> 0 then\r\n Word := Copy(S, Start, Index - Start);\r\n Result := True;\r\n Exit;\r\n end;\r\n AnsiSpace, AnsiLineFeed, AnsiCarriageReturn:\r\n begin\r\n if Start <> 0 then\r\n begin\r\n Word := Copy(S, Start, Index - Start);\r\n Exit;\r\n end\r\n else\r\n begin\r\n while CharIsWhiteSpace(C) do\r\n begin\r\n Inc(Index);\r\n C := S[Index];\r\n end;\r\n end;\r\n end;\r\n else\r\n if Start = 0 then\r\n Start := Index;\r\n Inc(Index);\r\n end;\r\n end;\r\nend;\r\n\r\nfunction StrWord(var S: PAnsiChar; out Word: AnsiString): Boolean;\r\nvar\r\n Start: PAnsiChar;\r\nbegin\r\n Word := '';\r\n if S = nil then\r\n begin\r\n Result := True;\r\n Exit;\r\n end;\r\n Start := nil;\r\n Result := False;\r\n while True do\r\n begin\r\n case S^ of\r\n #0:\r\n begin\r\n if Start <> nil then\r\n SetString(Word, Start, S - Start);\r\n Result := True;\r\n Exit;\r\n end;\r\n AnsiSpace, AnsiLineFeed, AnsiCarriageReturn:\r\n begin\r\n if Start <> nil then\r\n begin\r\n SetString(Word, Start, S - Start);\r\n Exit;\r\n end\r\n else\r\n while CharIsWhiteSpace(S^) do\r\n Inc(S);\r\n end;\r\n else\r\n if Start = nil then\r\n Start := S;\r\n Inc(S);\r\n end;\r\n end;\r\nend;\r\n\r\nfunction StrIdent(const S: AnsiString; var Index: SizeInt; out Ident: AnsiString): Boolean;\r\nvar\r\n Start: SizeInt;\r\n C: AnsiChar;\r\nbegin\r\n Ident := '';\r\n if (S = '') then\r\n begin\r\n Result := True;\r\n Exit;\r\n end;\r\n Start := Index;\r\n Result := False;\r\n while True do\r\n begin\r\n C := S[Index];\r\n if CharIsValidIdentifierLetter(C) then\r\n begin\r\n if Start = 0 then\r\n Start := Index;\r\n end\r\n else\r\n if C = #0 then\r\n begin\r\n if Start <> 0 then\r\n Ident := Copy(S, Start, Index - Start);\r\n Result := True;\r\n Exit;\r\n end\r\n else\r\n begin\r\n if Start <> 0 then\r\n begin\r\n Ident := Copy(S, Start, Index - Start);\r\n Exit;\r\n end;\r\n end;\r\n Inc(Index);\r\n end;\r\nend;\r\n\r\nfunction StrIdent(var S: PAnsiChar; out Ident: AnsiString): Boolean;\r\nvar\r\n Start: PAnsiChar;\r\n C: AnsiChar;\r\nbegin\r\n Ident := '';\r\n if S = nil then\r\n begin\r\n Result := True;\r\n Exit;\r\n end;\r\n Start := nil;\r\n Result := False;\r\n while True do\r\n begin\r\n C := S^;\r\n if CharIsValidIdentifierLetter(C) then\r\n begin\r\n if Start = nil then\r\n Start := S;\r\n end\r\n else\r\n if C = #0 then\r\n begin\r\n if Start <> nil then\r\n SetString(Ident, Start, S - Start);\r\n Result := True;\r\n Exit;\r\n end\r\n else\r\n begin\r\n if Start <> nil then\r\n begin\r\n SetString(Ident, Start, S - Start);\r\n Exit;\r\n end\r\n end;\r\n Inc(S);\r\n end;\r\nend;\r\n\r\nfunction StrToFloatSafe(const S: AnsiString): Float;\r\nvar\r\n Temp: AnsiString;\r\n I, J, K: SizeInt;\r\n SwapSeparators, IsNegative: Boolean;\r\n DecSep: AnsiChar;\r\n ThouSep: AnsiChar;\r\nbegin\r\n DecSep := AnsiChar(JclFormatSettings.DecimalSeparator);\r\n ThouSep := AnsiChar(JclFormatSettings.ThousandSeparator);\r\n Temp := S;\r\n SwapSeparators := False;\r\n\r\n IsNegative := False;\r\n J := 0;\r\n for I := 1 to Length(Temp) do\r\n begin\r\n if Temp[I] = '-' then\r\n IsNegative := not IsNegative\r\n else\r\n if not (Temp[I] in [' ', '(', '+']) then\r\n begin\r\n // if it appears prior to any digit, it has to be a decimal separator\r\n SwapSeparators := Temp[I] = ThouSep;\r\n J := I;\r\n Break;\r\n end;\r\n end;\r\n\r\n if not SwapSeparators then\r\n begin\r\n K := CharPos(Temp, DecSep);\r\n SwapSeparators :=\r\n // if it appears prior to any digit, it has to be a decimal separator\r\n (K > J) and\r\n // if it appears multiple times, it has to be a thousand separator\r\n ((StrCharCount(Temp, DecSep) > 1) or\r\n // we assume (consistent with Windows Platform SDK documentation),\r\n // that thousand separators appear only to the left of the decimal\r\n (K < CharPos(Temp, ThouSep)));\r\n end;\r\n\r\n if SwapSeparators then\r\n begin\r\n // assume a numerical string from a different locale,\r\n // where DecimalSeparator and ThousandSeparator are exchanged\r\n for I := 1 to Length(Temp) do\r\n if Temp[I] = DecSep then\r\n Temp[I] := ThouSep\r\n else\r\n if Temp[I] = ThouSep then\r\n Temp[I] := DecSep;\r\n end;\r\n\r\n Temp := StrKeepChars(Temp, AnsiDecDigits + [DecSep]);\r\n\r\n if Length(Temp) > 0 then\r\n begin\r\n if Temp[1] = DecSep then\r\n Temp := '0' + Temp;\r\n if Temp[Length(Temp)] = DecSep then\r\n Temp := Temp + '0';\r\n Result := StrToFloat(string(Temp));\r\n if IsNegative then\r\n Result := -Result;\r\n end\r\n else\r\n Result := 0.0;\r\nend;\r\n\r\nfunction StrToIntSafe(const S: AnsiString): Integer;\r\nbegin\r\n Result := Trunc(StrToFloatSafe(S));\r\nend;\r\n\r\nprocedure StrNormIndex(const StrLen: SizeInt; var Index: SizeInt; var Count: SizeInt); overload;\r\nbegin\r\n Index := Max(1, Min(Index, StrLen + 1));\r\n Count := Max(0, Min(Count, StrLen + 1 - Index));\r\nend;\r\n\r\nfunction ArrayOf(List: TJclAnsiStrings): TDynStringArray;\r\nvar\r\n I: SizeInt;\r\nbegin\r\n if List <> nil then\r\n begin\r\n SetLength(Result, List.Count);\r\n for I := 0 to List.Count - 1 do\r\n Result[I] := string(List[I]);\r\n end\r\n else\r\n Result := nil;\r\nend;\r\n\r\nfunction AnsiCompareNatural(const S1, S2: AnsiString; CaseInsensitive: Boolean): SizeInt;\r\nvar\r\n Cur1, Len1,\r\n Cur2, Len2: SizeInt;\r\n\r\n procedure NumberCompare;\r\n var\r\n IsReallyNumber: Boolean;\r\n FirstDiffBreaks: Boolean;\r\n Val1, Val2: SizeInt;\r\n begin\r\n Result := 0;\r\n IsReallyNumber := False;\r\n // count leading spaces in S1\r\n while CharIsWhiteSpace(S1[Cur1]) do\r\n begin\r\n Dec(Result);\r\n Inc(Cur1);\r\n end;\r\n // count leading spaces in S2 (canceling them out against the ones in S1)\r\n while CharIsWhiteSpace(S2[Cur2]) do\r\n begin\r\n Inc(Result);\r\n Inc(Cur2);\r\n end;\r\n\r\n // if spaces match, or both strings are actually followed by a numeric character, continue the checks\r\n if (Result = 0) or (CharIsNumberChar(S1[Cur1])) and (CharIsNumberChar(S2[Cur2])) then\r\n begin\r\n // Check signed number\r\n if (S1[Cur1] = '-') and (S2[Cur2] <> '-') then\r\n Result := 1\r\n else\r\n if (S2[Cur2] = '-') and (S1[Cur1] <> '-') then\r\n Result := -1\r\n else\r\n Result := 0;\r\n\r\n if (S1[Cur1] = '-') or (S1[Cur1] = '+') then\r\n Inc(Cur1);\r\n if (S2[Cur2] = '-') or (S2[Cur2] = '+') then\r\n Inc(Cur2);\r\n\r\n FirstDiffBreaks := (S1[Cur1] = '0') or (S2[Cur2] = '0');\r\n while CharIsDigit(S1[Cur1]) and CharIsDigit(S2[Cur2]) do\r\n begin\r\n IsReallyNumber := True;\r\n Val1 := StrToInt(string(S1[Cur1]));\r\n Val2 := StrToInt(string(S2[Cur2]));\r\n\r\n if (Result = 0) and (Val1 < Val2) then\r\n Result := -1\r\n else\r\n if (Result = 0) and (Val1 > Val2) then\r\n Result := 1;\r\n if FirstDiffBreaks and (Result <> 0) then\r\n Break;\r\n Inc(Cur1);\r\n Inc(Cur2);\r\n end;\r\n\r\n if IsReallyNumber then\r\n begin\r\n if not FirstDiffBreaks then\r\n begin\r\n if CharIsDigit(S1[Cur1]) then\r\n Result := 1\r\n else\r\n if CharIsDigit(S2[Cur2]) then\r\n Result := -1;\r\n end;\r\n end;\r\n end;\r\n end;\r\n\r\nbegin\r\n Cur1 := 1;\r\n Len1 := Length(S1);\r\n Cur2 := 1;\r\n Len2 := Length(S2);\r\n Result := 0;\r\n\r\n while (Result = 0) do\r\n begin\r\n if (Cur1 = Len1) and (Cur2 = Len2) then\r\n Break\r\n else\r\n if (S1[Cur1] = '-') and CharIsNumberChar(S2[Cur2]) and (S2[Cur2] <> '-') then\r\n Result := -1\r\n else\r\n if (S2[Cur2] = '-') and CharIsNumberChar(S1[Cur1]) and (S1[Cur1] <> '-') then\r\n Result := 1\r\n else\r\n if CharIsNumberChar(S1[Cur1]) and CharIsNumberChar(S2[Cur2]) then\r\n NumberCompare\r\n else\r\n if (Cur1 = Len1) and (Cur2 < Len2) then\r\n Result := -1\r\n else\r\n if (Cur1 < Len1) and (Cur2 = Len2) then\r\n Result := 1\r\n else\r\n begin\r\n Result := StrCompare(S1,S2);\r\n if CaseInsensitive then\r\n Result := {$if CompilerVersion > 24}System.AnsiStrings.{$endif}AnsiStrLIComp(PAnsiChar(@S1[Cur1]), PAnsiChar(@S2[Cur2]), 1)\r\n else\r\n Result := {$if CompilerVersion > 24}System.AnsiStrings.{$endif}AnsiStrLComp(PAnsiChar(@S1[Cur1]), PAnsiChar(@S2[Cur2]), 1);\r\n Inc(Cur1);\r\n Inc(Cur2);\r\n end;\r\n end;\r\nend;\r\n\r\nfunction AnsiCompareNaturalStr(const S1, S2: AnsiString): SizeInt; overload;\r\nbegin\r\n Result := AnsiCompareNatural(S1, S2, False);\r\nend;\r\n\r\nfunction AnsiCompareNaturalText(const S1, S2: AnsiString): SizeInt; overload;\r\nbegin\r\n Result := AnsiCompareNatural(S1, S2, True);\r\nend;\r\n\r\ninitialization\r\n LoadCharTypes; // this table first\r\n LoadCaseMap; // or this function does not work\r\n{$IFDEF UNITVERSIONING}\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jcl/source/common/JclArrayLists.pas", "content": "{**************************************************************************************************}\r\n{ WARNING: JEDI preprocessor generated unit. Do not edit. }\r\n{**************************************************************************************************}\r\n\r\n{**************************************************************************************************}\r\n{ }\r\n{ Project JEDI Code Library (JCL) }\r\n{ }\r\n{ The contents of this file are subject to the Mozilla Public License Version 1.1 (the \"License\"); }\r\n{ you may not use this file except in compliance with the License. You may obtain a copy of the }\r\n{ License at http://www.mozilla.org/MPL/ }\r\n{ }\r\n{ Software distributed under the License is distributed on an \"AS IS\" basis, WITHOUT WARRANTY OF }\r\n{ ANY KIND, either express or implied. See the License for the specific language governing rights }\r\n{ and limitations under the License. }\r\n{ }\r\n{ The Original Code is ArrayList.pas. }\r\n{ }\r\n{ The Initial Developer of the Original Code is Jean-Philippe BEMPEL aka RDM. Portions created by }\r\n{ Jean-Philippe BEMPEL are Copyright (C) Jean-Philippe BEMPEL (rdm_30 att yahoo dott com) }\r\n{ All rights reserved. }\r\n{ }\r\n{ Contributors: }\r\n{ Florent Ouchet (outchy) }\r\n{ }\r\n{**************************************************************************************************}\r\n{ }\r\n{ The Delphi Container Library }\r\n{ }\r\n{**************************************************************************************************}\r\n{ }\r\n{ Last modified: $Date:: 2012-02-24 12:14:46 +0100 (ven. 24 févr. 2012) $ }\r\n{ Revision: $Rev:: 3745 $ }\r\n{ Author: $Author:: outchy $ }\r\n{ }\r\n{**************************************************************************************************}\r\n\r\nunit JclArrayLists;\r\n\r\n{$I jcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF HAS_UNITSCOPE}\r\n System.Classes,\r\n {$ELSE ~HAS_UNITSCOPE}\r\n Classes,\r\n {$ENDIF ~HAS_UNITSCOPE}\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n JclAlgorithms,\r\n JclBase, JclAbstractContainers, JclContainerIntf, JclSynch;\r\n\r\n\r\ntype\r\n TItrStart = (isFirst, isLast);\r\n\r\n TJclIntfArrayList = class(TJclIntfAbstractContainer, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclIntfCloneable, IJclCloneable, IJclPackable, IJclGrowable, IJclBaseContainer, IJclIntfEqualityComparer, IJclIntfContainer, IJclIntfFlatContainer,\r\n IJclIntfCollection, IJclIntfList, IJclIntfArray)\r\n protected\r\n function CreateEmptyContainer: TJclAbstractContainerBase; override;\r\n private\r\n FElementData: TDynIInterfaceArray;\r\n // fix ambiguous warnings when compiled on Delphi.net and earlier versions of Delphi.win32\r\n // complaining about possible unaffected result.\r\n function RaiseOutOfBoundsError: IInterface;\r\n protected\r\n procedure AssignDataTo(Dest: TJclAbstractContainerBase); override;\r\n public\r\n constructor Create(ACapacity: Integer); overload;\r\n constructor Create(const ACollection: IJclIntfCollection); overload;\r\n destructor Destroy; override;\r\n { IJclPackable }\r\n procedure SetCapacity(Value: Integer); override;\r\n { IJclIntfCollection }\r\n function Add(const AInterface: IInterface): Boolean;\r\n function AddAll(const ACollection: IJclIntfCollection): Boolean;\r\n procedure Clear;\r\n function Contains(const AInterface: IInterface): Boolean;\r\n function ContainsAll(const ACollection: IJclIntfCollection): Boolean;\r\n function CollectionEquals(const ACollection: IJclIntfCollection): Boolean;\r\n function Extract(const AInterface: IInterface): Boolean;\r\n function ExtractAll(const ACollection: IJclIntfCollection): Boolean;\r\n function First: IJclIntfIterator;\r\n function IsEmpty: Boolean;\r\n function Last: IJclIntfIterator;\r\n function Remove(const AInterface: IInterface): Boolean;\r\n function RemoveAll(const ACollection: IJclIntfCollection): Boolean;\r\n function RetainAll(const ACollection: IJclIntfCollection): Boolean;\r\n function Size: Integer;\r\n {$IFDEF SUPPORTS_FOR_IN}\r\n function GetEnumerator: IJclIntfIterator;\r\n {$ENDIF SUPPORTS_FOR_IN}\r\n { IJclIntfList }\r\n function Delete(Index: Integer): IInterface;\r\n function ExtractIndex(Index: Integer): IInterface;\r\n function GetObject(Index: Integer): IInterface;\r\n function IndexOf(const AInterface: IInterface): Integer;\r\n function Insert(Index: Integer; const AInterface: IInterface): Boolean;\r\n function InsertAll(Index: Integer; const ACollection: IJclIntfCollection): Boolean;\r\n function LastIndexOf(const AInterface: IInterface): Integer;\r\n procedure SetObject(Index: Integer; const AInterface: IInterface);\r\n function SubList(First, Count: Integer): IJclIntfList;\r\n end;\r\n\r\n TJclIntfArrayIterator = class(TJclAbstractIterator, IJclIntfIterator, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclIntfCloneable, IJclCloneable)\r\n private\r\n FCursor: Integer;\r\n FStart: TItrStart;\r\n FOwnList: TJclIntfArrayList;\r\n protected\r\n procedure AssignPropertiesTo(Dest: TJclAbstractIterator); override;\r\n function CreateEmptyIterator: TJclAbstractIterator; override;\r\n public\r\n constructor Create(AOwnList: TJclIntfArrayList; ACursor: Integer; AValid: Boolean; AStart: TItrStart);\r\n { IJclIntfIterator }\r\n function Add(const AInterface: IInterface): Boolean;\r\n procedure Extract;\r\n function GetObject: IInterface;\r\n function HasNext: Boolean;\r\n function HasPrevious: Boolean;\r\n function Insert(const AInterface: IInterface): Boolean;\r\n function IteratorEquals(const AIterator: IJclIntfIterator): Boolean;\r\n function Next: IInterface;\r\n function NextIndex: Integer;\r\n function Previous: IInterface;\r\n function PreviousIndex: Integer;\r\n procedure Remove;\r\n procedure Reset;\r\n procedure SetObject(const AInterface: IInterface);\r\n {$IFDEF SUPPORTS_FOR_IN}\r\n function MoveNext: Boolean;\r\n property Current: IInterface read GetObject;\r\n {$ENDIF SUPPORTS_FOR_IN}\r\n end;\r\n\r\n TJclAnsiStrArrayList = class(TJclAnsiStrAbstractCollection, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclIntfCloneable, IJclCloneable, IJclPackable, IJclGrowable, IJclBaseContainer, IJclAnsiStrEqualityComparer, IJclAnsiStrContainer, IJclAnsiStrFlatContainer, IJclStrBaseContainer,\r\n IJclAnsiStrCollection, IJclAnsiStrList, IJclAnsiStrArray)\r\n protected\r\n function CreateEmptyContainer: TJclAbstractContainerBase; override;\r\n private\r\n FElementData: TDynAnsiStringArray;\r\n // fix ambiguous warnings when compiled on Delphi.net and earlier versions of Delphi.win32\r\n // complaining about possible unaffected result.\r\n function RaiseOutOfBoundsError: AnsiString;\r\n protected\r\n procedure AssignDataTo(Dest: TJclAbstractContainerBase); override;\r\n public\r\n constructor Create(ACapacity: Integer); overload;\r\n constructor Create(const ACollection: IJclAnsiStrCollection); overload;\r\n destructor Destroy; override;\r\n { IJclPackable }\r\n procedure SetCapacity(Value: Integer); override;\r\n { IJclAnsiStrCollection }\r\n function Add(const AString: AnsiString): Boolean; override;\r\n function AddAll(const ACollection: IJclAnsiStrCollection): Boolean; override;\r\n procedure Clear; override;\r\n function Contains(const AString: AnsiString): Boolean; override;\r\n function ContainsAll(const ACollection: IJclAnsiStrCollection): Boolean; override;\r\n function CollectionEquals(const ACollection: IJclAnsiStrCollection): Boolean; override;\r\n function Extract(const AString: AnsiString): Boolean; override;\r\n function ExtractAll(const ACollection: IJclAnsiStrCollection): Boolean; override;\r\n function First: IJclAnsiStrIterator; override;\r\n function IsEmpty: Boolean; override;\r\n function Last: IJclAnsiStrIterator; override;\r\n function Remove(const AString: AnsiString): Boolean; override;\r\n function RemoveAll(const ACollection: IJclAnsiStrCollection): Boolean; override;\r\n function RetainAll(const ACollection: IJclAnsiStrCollection): Boolean; override;\r\n function Size: Integer; override;\r\n {$IFDEF SUPPORTS_FOR_IN}\r\n function GetEnumerator: IJclAnsiStrIterator; override;\r\n {$ENDIF SUPPORTS_FOR_IN}\r\n { IJclAnsiStrList }\r\n function Delete(Index: Integer): AnsiString;\r\n function ExtractIndex(Index: Integer): AnsiString;\r\n function GetString(Index: Integer): AnsiString;\r\n function IndexOf(const AString: AnsiString): Integer;\r\n function Insert(Index: Integer; const AString: AnsiString): Boolean;\r\n function InsertAll(Index: Integer; const ACollection: IJclAnsiStrCollection): Boolean;\r\n function LastIndexOf(const AString: AnsiString): Integer;\r\n procedure SetString(Index: Integer; const AString: AnsiString);\r\n function SubList(First, Count: Integer): IJclAnsiStrList;\r\n end;\r\n\r\n TJclAnsiStrArrayIterator = class(TJclAbstractIterator, IJclAnsiStrIterator, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclIntfCloneable, IJclCloneable)\r\n private\r\n FCursor: Integer;\r\n FStart: TItrStart;\r\n FOwnList: TJclAnsiStrArrayList;\r\n protected\r\n procedure AssignPropertiesTo(Dest: TJclAbstractIterator); override;\r\n function CreateEmptyIterator: TJclAbstractIterator; override;\r\n public\r\n constructor Create(AOwnList: TJclAnsiStrArrayList; ACursor: Integer; AValid: Boolean; AStart: TItrStart);\r\n { IJclAnsiStrIterator }\r\n function Add(const AString: AnsiString): Boolean;\r\n procedure Extract;\r\n function GetString: AnsiString;\r\n function HasNext: Boolean;\r\n function HasPrevious: Boolean;\r\n function Insert(const AString: AnsiString): Boolean;\r\n function IteratorEquals(const AIterator: IJclAnsiStrIterator): Boolean;\r\n function Next: AnsiString;\r\n function NextIndex: Integer;\r\n function Previous: AnsiString;\r\n function PreviousIndex: Integer;\r\n procedure Remove;\r\n procedure Reset;\r\n procedure SetString(const AString: AnsiString);\r\n {$IFDEF SUPPORTS_FOR_IN}\r\n function MoveNext: Boolean;\r\n property Current: AnsiString read GetString;\r\n {$ENDIF SUPPORTS_FOR_IN}\r\n end;\r\n\r\n TJclWideStrArrayList = class(TJclWideStrAbstractCollection, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclIntfCloneable, IJclCloneable, IJclPackable, IJclGrowable, IJclBaseContainer, IJclWideStrEqualityComparer, IJclWideStrContainer, IJclWideStrFlatContainer, IJclStrBaseContainer,\r\n IJclWideStrCollection, IJclWideStrList, IJclWideStrArray)\r\n protected\r\n function CreateEmptyContainer: TJclAbstractContainerBase; override;\r\n private\r\n FElementData: TDynWideStringArray;\r\n // fix ambiguous warnings when compiled on Delphi.net and earlier versions of Delphi.win32\r\n // complaining about possible unaffected result.\r\n function RaiseOutOfBoundsError: WideString;\r\n protected\r\n procedure AssignDataTo(Dest: TJclAbstractContainerBase); override;\r\n public\r\n constructor Create(ACapacity: Integer); overload;\r\n constructor Create(const ACollection: IJclWideStrCollection); overload;\r\n destructor Destroy; override;\r\n { IJclPackable }\r\n procedure SetCapacity(Value: Integer); override;\r\n { IJclWideStrCollection }\r\n function Add(const AString: WideString): Boolean; override;\r\n function AddAll(const ACollection: IJclWideStrCollection): Boolean; override;\r\n procedure Clear; override;\r\n function Contains(const AString: WideString): Boolean; override;\r\n function ContainsAll(const ACollection: IJclWideStrCollection): Boolean; override;\r\n function CollectionEquals(const ACollection: IJclWideStrCollection): Boolean; override;\r\n function Extract(const AString: WideString): Boolean; override;\r\n function ExtractAll(const ACollection: IJclWideStrCollection): Boolean; override;\r\n function First: IJclWideStrIterator; override;\r\n function IsEmpty: Boolean; override;\r\n function Last: IJclWideStrIterator; override;\r\n function Remove(const AString: WideString): Boolean; override;\r\n function RemoveAll(const ACollection: IJclWideStrCollection): Boolean; override;\r\n function RetainAll(const ACollection: IJclWideStrCollection): Boolean; override;\r\n function Size: Integer; override;\r\n {$IFDEF SUPPORTS_FOR_IN}\r\n function GetEnumerator: IJclWideStrIterator; override;\r\n {$ENDIF SUPPORTS_FOR_IN}\r\n { IJclWideStrList }\r\n function Delete(Index: Integer): WideString;\r\n function ExtractIndex(Index: Integer): WideString;\r\n function GetString(Index: Integer): WideString;\r\n function IndexOf(const AString: WideString): Integer;\r\n function Insert(Index: Integer; const AString: WideString): Boolean;\r\n function InsertAll(Index: Integer; const ACollection: IJclWideStrCollection): Boolean;\r\n function LastIndexOf(const AString: WideString): Integer;\r\n procedure SetString(Index: Integer; const AString: WideString);\r\n function SubList(First, Count: Integer): IJclWideStrList;\r\n end;\r\n\r\n TJclWideStrArrayIterator = class(TJclAbstractIterator, IJclWideStrIterator, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclIntfCloneable, IJclCloneable)\r\n private\r\n FCursor: Integer;\r\n FStart: TItrStart;\r\n FOwnList: TJclWideStrArrayList;\r\n protected\r\n procedure AssignPropertiesTo(Dest: TJclAbstractIterator); override;\r\n function CreateEmptyIterator: TJclAbstractIterator; override;\r\n public\r\n constructor Create(AOwnList: TJclWideStrArrayList; ACursor: Integer; AValid: Boolean; AStart: TItrStart);\r\n { IJclWideStrIterator }\r\n function Add(const AString: WideString): Boolean;\r\n procedure Extract;\r\n function GetString: WideString;\r\n function HasNext: Boolean;\r\n function HasPrevious: Boolean;\r\n function Insert(const AString: WideString): Boolean;\r\n function IteratorEquals(const AIterator: IJclWideStrIterator): Boolean;\r\n function Next: WideString;\r\n function NextIndex: Integer;\r\n function Previous: WideString;\r\n function PreviousIndex: Integer;\r\n procedure Remove;\r\n procedure Reset;\r\n procedure SetString(const AString: WideString);\r\n {$IFDEF SUPPORTS_FOR_IN}\r\n function MoveNext: Boolean;\r\n property Current: WideString read GetString;\r\n {$ENDIF SUPPORTS_FOR_IN}\r\n end;\r\n\r\n {$IFDEF SUPPORTS_UNICODE_STRING}\r\n TJclUnicodeStrArrayList = class(TJclUnicodeStrAbstractCollection, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclIntfCloneable, IJclCloneable, IJclPackable, IJclGrowable, IJclBaseContainer, IJclUnicodeStrEqualityComparer, IJclUnicodeStrContainer, IJclUnicodeStrFlatContainer, IJclStrBaseContainer,\r\n IJclUnicodeStrCollection, IJclUnicodeStrList, IJclUnicodeStrArray)\r\n protected\r\n function CreateEmptyContainer: TJclAbstractContainerBase; override;\r\n private\r\n FElementData: TDynUnicodeStringArray;\r\n // fix ambiguous warnings when compiled on Delphi.net and earlier versions of Delphi.win32\r\n // complaining about possible unaffected result.\r\n function RaiseOutOfBoundsError: UnicodeString;\r\n protected\r\n procedure AssignDataTo(Dest: TJclAbstractContainerBase); override;\r\n public\r\n constructor Create(ACapacity: Integer); overload;\r\n constructor Create(const ACollection: IJclUnicodeStrCollection); overload;\r\n destructor Destroy; override;\r\n { IJclPackable }\r\n procedure SetCapacity(Value: Integer); override;\r\n { IJclUnicodeStrCollection }\r\n function Add(const AString: UnicodeString): Boolean; override;\r\n function AddAll(const ACollection: IJclUnicodeStrCollection): Boolean; override;\r\n procedure Clear; override;\r\n function Contains(const AString: UnicodeString): Boolean; override;\r\n function ContainsAll(const ACollection: IJclUnicodeStrCollection): Boolean; override;\r\n function CollectionEquals(const ACollection: IJclUnicodeStrCollection): Boolean; override;\r\n function Extract(const AString: UnicodeString): Boolean; override;\r\n function ExtractAll(const ACollection: IJclUnicodeStrCollection): Boolean; override;\r\n function First: IJclUnicodeStrIterator; override;\r\n function IsEmpty: Boolean; override;\r\n function Last: IJclUnicodeStrIterator; override;\r\n function Remove(const AString: UnicodeString): Boolean; override;\r\n function RemoveAll(const ACollection: IJclUnicodeStrCollection): Boolean; override;\r\n function RetainAll(const ACollection: IJclUnicodeStrCollection): Boolean; override;\r\n function Size: Integer; override;\r\n {$IFDEF SUPPORTS_FOR_IN}\r\n function GetEnumerator: IJclUnicodeStrIterator; override;\r\n {$ENDIF SUPPORTS_FOR_IN}\r\n { IJclUnicodeStrList }\r\n function Delete(Index: Integer): UnicodeString;\r\n function ExtractIndex(Index: Integer): UnicodeString;\r\n function GetString(Index: Integer): UnicodeString;\r\n function IndexOf(const AString: UnicodeString): Integer;\r\n function Insert(Index: Integer; const AString: UnicodeString): Boolean;\r\n function InsertAll(Index: Integer; const ACollection: IJclUnicodeStrCollection): Boolean;\r\n function LastIndexOf(const AString: UnicodeString): Integer;\r\n procedure SetString(Index: Integer; const AString: UnicodeString);\r\n function SubList(First, Count: Integer): IJclUnicodeStrList;\r\n end;\r\n {$ENDIF SUPPORTS_UNICODE_STRING}\r\n\r\n {$IFDEF SUPPORTS_UNICODE_STRING}\r\n TJclUnicodeStrArrayIterator = class(TJclAbstractIterator, IJclUnicodeStrIterator, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclIntfCloneable, IJclCloneable)\r\n private\r\n FCursor: Integer;\r\n FStart: TItrStart;\r\n FOwnList: TJclUnicodeStrArrayList;\r\n protected\r\n procedure AssignPropertiesTo(Dest: TJclAbstractIterator); override;\r\n function CreateEmptyIterator: TJclAbstractIterator; override;\r\n public\r\n constructor Create(AOwnList: TJclUnicodeStrArrayList; ACursor: Integer; AValid: Boolean; AStart: TItrStart);\r\n { IJclUnicodeStrIterator }\r\n function Add(const AString: UnicodeString): Boolean;\r\n procedure Extract;\r\n function GetString: UnicodeString;\r\n function HasNext: Boolean;\r\n function HasPrevious: Boolean;\r\n function Insert(const AString: UnicodeString): Boolean;\r\n function IteratorEquals(const AIterator: IJclUnicodeStrIterator): Boolean;\r\n function Next: UnicodeString;\r\n function NextIndex: Integer;\r\n function Previous: UnicodeString;\r\n function PreviousIndex: Integer;\r\n procedure Remove;\r\n procedure Reset;\r\n procedure SetString(const AString: UnicodeString);\r\n {$IFDEF SUPPORTS_FOR_IN}\r\n function MoveNext: Boolean;\r\n property Current: UnicodeString read GetString;\r\n {$ENDIF SUPPORTS_FOR_IN}\r\n end;\r\n {$ENDIF SUPPORTS_UNICODE_STRING}\r\n\r\n {$IFDEF CONTAINER_ANSISTR}\r\n TJclStrArrayList = TJclAnsiStrArrayList;\r\n {$ENDIF CONTAINER_ANSISTR}\r\n {$IFDEF CONTAINER_WIDESTR}\r\n TJclStrArrayList = TJclWideStrArrayList;\r\n {$ENDIF CONTAINER_WIDESTR}\r\n {$IFDEF CONTAINER_UNICODESTR}\r\n TJclStrArrayList = TJclUnicodeStrArrayList;\r\n {$ENDIF CONTAINER_UNICODESTR}\r\n\r\n {$IFDEF CONTAINER_ANSISTR}\r\n TJclStrArrayIterator = TJclAnsiStrArrayIterator;\r\n {$ENDIF CONTAINER_ANSISTR}\r\n {$IFDEF CONTAINER_WIDESTR}\r\n TJclStrArrayIterator = TJclWideStrArrayIterator;\r\n {$ENDIF CONTAINER_WIDESTR}\r\n {$IFDEF CONTAINER_UNICODESTR}\r\n TJclStrArrayIterator = TJclUnicodeStrArrayIterator;\r\n {$ENDIF CONTAINER_UNICODESTR}\r\n\r\n TJclSingleArrayList = class(TJclSingleAbstractContainer, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclIntfCloneable, IJclCloneable, IJclPackable, IJclGrowable, IJclBaseContainer, IJclSingleEqualityComparer, IJclSingleContainer, IJclSingleFlatContainer,\r\n IJclSingleCollection, IJclSingleList, IJclSingleArray)\r\n protected\r\n function CreateEmptyContainer: TJclAbstractContainerBase; override;\r\n private\r\n FElementData: TDynSingleArray;\r\n // fix ambiguous warnings when compiled on Delphi.net and earlier versions of Delphi.win32\r\n // complaining about possible unaffected result.\r\n function RaiseOutOfBoundsError: Single;\r\n protected\r\n procedure AssignDataTo(Dest: TJclAbstractContainerBase); override;\r\n public\r\n constructor Create(ACapacity: Integer); overload;\r\n constructor Create(const ACollection: IJclSingleCollection); overload;\r\n destructor Destroy; override;\r\n { IJclPackable }\r\n procedure SetCapacity(Value: Integer); override;\r\n { IJclSingleCollection }\r\n function Add(const AValue: Single): Boolean;\r\n function AddAll(const ACollection: IJclSingleCollection): Boolean;\r\n procedure Clear;\r\n function Contains(const AValue: Single): Boolean;\r\n function ContainsAll(const ACollection: IJclSingleCollection): Boolean;\r\n function CollectionEquals(const ACollection: IJclSingleCollection): Boolean;\r\n function Extract(const AValue: Single): Boolean;\r\n function ExtractAll(const ACollection: IJclSingleCollection): Boolean;\r\n function First: IJclSingleIterator;\r\n function IsEmpty: Boolean;\r\n function Last: IJclSingleIterator;\r\n function Remove(const AValue: Single): Boolean;\r\n function RemoveAll(const ACollection: IJclSingleCollection): Boolean;\r\n function RetainAll(const ACollection: IJclSingleCollection): Boolean;\r\n function Size: Integer;\r\n {$IFDEF SUPPORTS_FOR_IN}\r\n function GetEnumerator: IJclSingleIterator;\r\n {$ENDIF SUPPORTS_FOR_IN}\r\n { IJclSingleList }\r\n function Delete(Index: Integer): Single;\r\n function ExtractIndex(Index: Integer): Single;\r\n function GetValue(Index: Integer): Single;\r\n function IndexOf(const AValue: Single): Integer;\r\n function Insert(Index: Integer; const AValue: Single): Boolean;\r\n function InsertAll(Index: Integer; const ACollection: IJclSingleCollection): Boolean;\r\n function LastIndexOf(const AValue: Single): Integer;\r\n procedure SetValue(Index: Integer; const AValue: Single);\r\n function SubList(First, Count: Integer): IJclSingleList;\r\n end;\r\n\r\n TJclSingleArrayIterator = class(TJclAbstractIterator, IJclSingleIterator, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclIntfCloneable, IJclCloneable)\r\n private\r\n FCursor: Integer;\r\n FStart: TItrStart;\r\n FOwnList: TJclSingleArrayList;\r\n protected\r\n procedure AssignPropertiesTo(Dest: TJclAbstractIterator); override;\r\n function CreateEmptyIterator: TJclAbstractIterator; override;\r\n public\r\n constructor Create(AOwnList: TJclSingleArrayList; ACursor: Integer; AValid: Boolean; AStart: TItrStart);\r\n { IJclSingleIterator }\r\n function Add(const AValue: Single): Boolean;\r\n procedure Extract;\r\n function GetValue: Single;\r\n function HasNext: Boolean;\r\n function HasPrevious: Boolean;\r\n function Insert(const AValue: Single): Boolean;\r\n function IteratorEquals(const AIterator: IJclSingleIterator): Boolean;\r\n function Next: Single;\r\n function NextIndex: Integer;\r\n function Previous: Single;\r\n function PreviousIndex: Integer;\r\n procedure Remove;\r\n procedure Reset;\r\n procedure SetValue(const AValue: Single);\r\n {$IFDEF SUPPORTS_FOR_IN}\r\n function MoveNext: Boolean;\r\n property Current: Single read GetValue;\r\n {$ENDIF SUPPORTS_FOR_IN}\r\n end;\r\n\r\n TJclDoubleArrayList = class(TJclDoubleAbstractContainer, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclIntfCloneable, IJclCloneable, IJclPackable, IJclGrowable, IJclBaseContainer, IJclDoubleEqualityComparer, IJclDoubleContainer, IJclDoubleFlatContainer,\r\n IJclDoubleCollection, IJclDoubleList, IJclDoubleArray)\r\n protected\r\n function CreateEmptyContainer: TJclAbstractContainerBase; override;\r\n private\r\n FElementData: TDynDoubleArray;\r\n // fix ambiguous warnings when compiled on Delphi.net and earlier versions of Delphi.win32\r\n // complaining about possible unaffected result.\r\n function RaiseOutOfBoundsError: Double;\r\n protected\r\n procedure AssignDataTo(Dest: TJclAbstractContainerBase); override;\r\n public\r\n constructor Create(ACapacity: Integer); overload;\r\n constructor Create(const ACollection: IJclDoubleCollection); overload;\r\n destructor Destroy; override;\r\n { IJclPackable }\r\n procedure SetCapacity(Value: Integer); override;\r\n { IJclDoubleCollection }\r\n function Add(const AValue: Double): Boolean;\r\n function AddAll(const ACollection: IJclDoubleCollection): Boolean;\r\n procedure Clear;\r\n function Contains(const AValue: Double): Boolean;\r\n function ContainsAll(const ACollection: IJclDoubleCollection): Boolean;\r\n function CollectionEquals(const ACollection: IJclDoubleCollection): Boolean;\r\n function Extract(const AValue: Double): Boolean;\r\n function ExtractAll(const ACollection: IJclDoubleCollection): Boolean;\r\n function First: IJclDoubleIterator;\r\n function IsEmpty: Boolean;\r\n function Last: IJclDoubleIterator;\r\n function Remove(const AValue: Double): Boolean;\r\n function RemoveAll(const ACollection: IJclDoubleCollection): Boolean;\r\n function RetainAll(const ACollection: IJclDoubleCollection): Boolean;\r\n function Size: Integer;\r\n {$IFDEF SUPPORTS_FOR_IN}\r\n function GetEnumerator: IJclDoubleIterator;\r\n {$ENDIF SUPPORTS_FOR_IN}\r\n { IJclDoubleList }\r\n function Delete(Index: Integer): Double;\r\n function ExtractIndex(Index: Integer): Double;\r\n function GetValue(Index: Integer): Double;\r\n function IndexOf(const AValue: Double): Integer;\r\n function Insert(Index: Integer; const AValue: Double): Boolean;\r\n function InsertAll(Index: Integer; const ACollection: IJclDoubleCollection): Boolean;\r\n function LastIndexOf(const AValue: Double): Integer;\r\n procedure SetValue(Index: Integer; const AValue: Double);\r\n function SubList(First, Count: Integer): IJclDoubleList;\r\n end;\r\n\r\n TJclDoubleArrayIterator = class(TJclAbstractIterator, IJclDoubleIterator, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclIntfCloneable, IJclCloneable)\r\n private\r\n FCursor: Integer;\r\n FStart: TItrStart;\r\n FOwnList: TJclDoubleArrayList;\r\n protected\r\n procedure AssignPropertiesTo(Dest: TJclAbstractIterator); override;\r\n function CreateEmptyIterator: TJclAbstractIterator; override;\r\n public\r\n constructor Create(AOwnList: TJclDoubleArrayList; ACursor: Integer; AValid: Boolean; AStart: TItrStart);\r\n { IJclDoubleIterator }\r\n function Add(const AValue: Double): Boolean;\r\n procedure Extract;\r\n function GetValue: Double;\r\n function HasNext: Boolean;\r\n function HasPrevious: Boolean;\r\n function Insert(const AValue: Double): Boolean;\r\n function IteratorEquals(const AIterator: IJclDoubleIterator): Boolean;\r\n function Next: Double;\r\n function NextIndex: Integer;\r\n function Previous: Double;\r\n function PreviousIndex: Integer;\r\n procedure Remove;\r\n procedure Reset;\r\n procedure SetValue(const AValue: Double);\r\n {$IFDEF SUPPORTS_FOR_IN}\r\n function MoveNext: Boolean;\r\n property Current: Double read GetValue;\r\n {$ENDIF SUPPORTS_FOR_IN}\r\n end;\r\n\r\n TJclExtendedArrayList = class(TJclExtendedAbstractContainer, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclIntfCloneable, IJclCloneable, IJclPackable, IJclGrowable, IJclBaseContainer, IJclExtendedEqualityComparer, IJclExtendedContainer, IJclExtendedFlatContainer,\r\n IJclExtendedCollection, IJclExtendedList, IJclExtendedArray)\r\n protected\r\n function CreateEmptyContainer: TJclAbstractContainerBase; override;\r\n private\r\n FElementData: TDynExtendedArray;\r\n // fix ambiguous warnings when compiled on Delphi.net and earlier versions of Delphi.win32\r\n // complaining about possible unaffected result.\r\n function RaiseOutOfBoundsError: Extended;\r\n protected\r\n procedure AssignDataTo(Dest: TJclAbstractContainerBase); override;\r\n public\r\n constructor Create(ACapacity: Integer); overload;\r\n constructor Create(const ACollection: IJclExtendedCollection); overload;\r\n destructor Destroy; override;\r\n { IJclPackable }\r\n procedure SetCapacity(Value: Integer); override;\r\n { IJclExtendedCollection }\r\n function Add(const AValue: Extended): Boolean;\r\n function AddAll(const ACollection: IJclExtendedCollection): Boolean;\r\n procedure Clear;\r\n function Contains(const AValue: Extended): Boolean;\r\n function ContainsAll(const ACollection: IJclExtendedCollection): Boolean;\r\n function CollectionEquals(const ACollection: IJclExtendedCollection): Boolean;\r\n function Extract(const AValue: Extended): Boolean;\r\n function ExtractAll(const ACollection: IJclExtendedCollection): Boolean;\r\n function First: IJclExtendedIterator;\r\n function IsEmpty: Boolean;\r\n function Last: IJclExtendedIterator;\r\n function Remove(const AValue: Extended): Boolean;\r\n function RemoveAll(const ACollection: IJclExtendedCollection): Boolean;\r\n function RetainAll(const ACollection: IJclExtendedCollection): Boolean;\r\n function Size: Integer;\r\n {$IFDEF SUPPORTS_FOR_IN}\r\n function GetEnumerator: IJclExtendedIterator;\r\n {$ENDIF SUPPORTS_FOR_IN}\r\n { IJclExtendedList }\r\n function Delete(Index: Integer): Extended;\r\n function ExtractIndex(Index: Integer): Extended;\r\n function GetValue(Index: Integer): Extended;\r\n function IndexOf(const AValue: Extended): Integer;\r\n function Insert(Index: Integer; const AValue: Extended): Boolean;\r\n function InsertAll(Index: Integer; const ACollection: IJclExtendedCollection): Boolean;\r\n function LastIndexOf(const AValue: Extended): Integer;\r\n procedure SetValue(Index: Integer; const AValue: Extended);\r\n function SubList(First, Count: Integer): IJclExtendedList;\r\n end;\r\n\r\n TJclExtendedArrayIterator = class(TJclAbstractIterator, IJclExtendedIterator, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclIntfCloneable, IJclCloneable)\r\n private\r\n FCursor: Integer;\r\n FStart: TItrStart;\r\n FOwnList: TJclExtendedArrayList;\r\n protected\r\n procedure AssignPropertiesTo(Dest: TJclAbstractIterator); override;\r\n function CreateEmptyIterator: TJclAbstractIterator; override;\r\n public\r\n constructor Create(AOwnList: TJclExtendedArrayList; ACursor: Integer; AValid: Boolean; AStart: TItrStart);\r\n { IJclExtendedIterator }\r\n function Add(const AValue: Extended): Boolean;\r\n procedure Extract;\r\n function GetValue: Extended;\r\n function HasNext: Boolean;\r\n function HasPrevious: Boolean;\r\n function Insert(const AValue: Extended): Boolean;\r\n function IteratorEquals(const AIterator: IJclExtendedIterator): Boolean;\r\n function Next: Extended;\r\n function NextIndex: Integer;\r\n function Previous: Extended;\r\n function PreviousIndex: Integer;\r\n procedure Remove;\r\n procedure Reset;\r\n procedure SetValue(const AValue: Extended);\r\n {$IFDEF SUPPORTS_FOR_IN}\r\n function MoveNext: Boolean;\r\n property Current: Extended read GetValue;\r\n {$ENDIF SUPPORTS_FOR_IN}\r\n end;\r\n\r\n {$IFDEF MATH_SINGLE_PRECISION}\r\n TJclFloatArrayList = TJclSingleArrayList;\r\n {$ENDIF MATH_SINGLE_PRECISION}\r\n {$IFDEF MATH_DOUBLE_PRECISION}\r\n TJclFloatArrayList = TJclDoubleArrayList;\r\n {$ENDIF MATH_DOUBLE_PRECISION}\r\n {$IFDEF MATH_EXTENDED_PRECISION}\r\n TJclFloatArrayList = TJclExtendedArrayList;\r\n {$ENDIF MATH_EXTENDED_PRECISION}\r\n\r\n {$IFDEF MATH_SINGLE_PRECISION}\r\n TJclFloatArrayIterator = TJclSingleArrayIterator;\r\n {$ENDIF MATH_SINGLE_PRECISION}\r\n {$IFDEF MATH_DOUBLE_PRECISION}\r\n TJclFloatArrayIterator = TJclDoubleArrayIterator;\r\n {$ENDIF MATH_DOUBLE_PRECISION}\r\n {$IFDEF MATH_EXTENDED_PRECISION}\r\n TJclFloatArrayIterator = TJclExtendedArrayIterator;\r\n {$ENDIF MATH_EXTENDED_PRECISION}\r\n\r\n TJclIntegerArrayList = class(TJclIntegerAbstractContainer, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclIntfCloneable, IJclCloneable, IJclPackable, IJclGrowable, IJclBaseContainer, IJclIntegerEqualityComparer, IJclIntegerContainer, IJclIntegerFlatContainer,\r\n IJclIntegerCollection, IJclIntegerList, IJclIntegerArray)\r\n protected\r\n function CreateEmptyContainer: TJclAbstractContainerBase; override;\r\n private\r\n FElementData: TDynIntegerArray;\r\n // fix ambiguous warnings when compiled on Delphi.net and earlier versions of Delphi.win32\r\n // complaining about possible unaffected result.\r\n function RaiseOutOfBoundsError: Integer;\r\n protected\r\n procedure AssignDataTo(Dest: TJclAbstractContainerBase); override;\r\n public\r\n constructor Create(ACapacity: Integer); overload;\r\n constructor Create(const ACollection: IJclIntegerCollection); overload;\r\n destructor Destroy; override;\r\n { IJclPackable }\r\n procedure SetCapacity(Value: Integer); override;\r\n { IJclIntegerCollection }\r\n function Add(AValue: Integer): Boolean;\r\n function AddAll(const ACollection: IJclIntegerCollection): Boolean;\r\n procedure Clear;\r\n function Contains(AValue: Integer): Boolean;\r\n function ContainsAll(const ACollection: IJclIntegerCollection): Boolean;\r\n function CollectionEquals(const ACollection: IJclIntegerCollection): Boolean;\r\n function Extract(AValue: Integer): Boolean;\r\n function ExtractAll(const ACollection: IJclIntegerCollection): Boolean;\r\n function First: IJclIntegerIterator;\r\n function IsEmpty: Boolean;\r\n function Last: IJclIntegerIterator;\r\n function Remove(AValue: Integer): Boolean;\r\n function RemoveAll(const ACollection: IJclIntegerCollection): Boolean;\r\n function RetainAll(const ACollection: IJclIntegerCollection): Boolean;\r\n function Size: Integer;\r\n {$IFDEF SUPPORTS_FOR_IN}\r\n function GetEnumerator: IJclIntegerIterator;\r\n {$ENDIF SUPPORTS_FOR_IN}\r\n { IJclIntegerList }\r\n function Delete(Index: Integer): Integer;\r\n function ExtractIndex(Index: Integer): Integer;\r\n function GetValue(Index: Integer): Integer;\r\n function IndexOf(AValue: Integer): Integer;\r\n function Insert(Index: Integer; AValue: Integer): Boolean;\r\n function InsertAll(Index: Integer; const ACollection: IJclIntegerCollection): Boolean;\r\n function LastIndexOf(AValue: Integer): Integer;\r\n procedure SetValue(Index: Integer; AValue: Integer);\r\n function SubList(First, Count: Integer): IJclIntegerList;\r\n end;\r\n\r\n TJclIntegerArrayIterator = class(TJclAbstractIterator, IJclIntegerIterator, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclIntfCloneable, IJclCloneable)\r\n private\r\n FCursor: Integer;\r\n FStart: TItrStart;\r\n FOwnList: TJclIntegerArrayList;\r\n protected\r\n procedure AssignPropertiesTo(Dest: TJclAbstractIterator); override;\r\n function CreateEmptyIterator: TJclAbstractIterator; override;\r\n public\r\n constructor Create(AOwnList: TJclIntegerArrayList; ACursor: Integer; AValid: Boolean; AStart: TItrStart);\r\n { IJclIntegerIterator }\r\n function Add(AValue: Integer): Boolean;\r\n procedure Extract;\r\n function GetValue: Integer;\r\n function HasNext: Boolean;\r\n function HasPrevious: Boolean;\r\n function Insert(AValue: Integer): Boolean;\r\n function IteratorEquals(const AIterator: IJclIntegerIterator): Boolean;\r\n function Next: Integer;\r\n function NextIndex: Integer;\r\n function Previous: Integer;\r\n function PreviousIndex: Integer;\r\n procedure Remove;\r\n procedure Reset;\r\n procedure SetValue(AValue: Integer);\r\n {$IFDEF SUPPORTS_FOR_IN}\r\n function MoveNext: Boolean;\r\n property Current: Integer read GetValue;\r\n {$ENDIF SUPPORTS_FOR_IN}\r\n end;\r\n\r\n TJclCardinalArrayList = class(TJclCardinalAbstractContainer, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclIntfCloneable, IJclCloneable, IJclPackable, IJclGrowable, IJclBaseContainer, IJclCardinalEqualityComparer, IJclCardinalContainer, IJclCardinalFlatContainer,\r\n IJclCardinalCollection, IJclCardinalList, IJclCardinalArray)\r\n protected\r\n function CreateEmptyContainer: TJclAbstractContainerBase; override;\r\n private\r\n FElementData: TDynCardinalArray;\r\n // fix ambiguous warnings when compiled on Delphi.net and earlier versions of Delphi.win32\r\n // complaining about possible unaffected result.\r\n function RaiseOutOfBoundsError: Cardinal;\r\n protected\r\n procedure AssignDataTo(Dest: TJclAbstractContainerBase); override;\r\n public\r\n constructor Create(ACapacity: Integer); overload;\r\n constructor Create(const ACollection: IJclCardinalCollection); overload;\r\n destructor Destroy; override;\r\n { IJclPackable }\r\n procedure SetCapacity(Value: Integer); override;\r\n { IJclCardinalCollection }\r\n function Add(AValue: Cardinal): Boolean;\r\n function AddAll(const ACollection: IJclCardinalCollection): Boolean;\r\n procedure Clear;\r\n function Contains(AValue: Cardinal): Boolean;\r\n function ContainsAll(const ACollection: IJclCardinalCollection): Boolean;\r\n function CollectionEquals(const ACollection: IJclCardinalCollection): Boolean;\r\n function Extract(AValue: Cardinal): Boolean;\r\n function ExtractAll(const ACollection: IJclCardinalCollection): Boolean;\r\n function First: IJclCardinalIterator;\r\n function IsEmpty: Boolean;\r\n function Last: IJclCardinalIterator;\r\n function Remove(AValue: Cardinal): Boolean;\r\n function RemoveAll(const ACollection: IJclCardinalCollection): Boolean;\r\n function RetainAll(const ACollection: IJclCardinalCollection): Boolean;\r\n function Size: Integer;\r\n {$IFDEF SUPPORTS_FOR_IN}\r\n function GetEnumerator: IJclCardinalIterator;\r\n {$ENDIF SUPPORTS_FOR_IN}\r\n { IJclCardinalList }\r\n function Delete(Index: Integer): Cardinal;\r\n function ExtractIndex(Index: Integer): Cardinal;\r\n function GetValue(Index: Integer): Cardinal;\r\n function IndexOf(AValue: Cardinal): Integer;\r\n function Insert(Index: Integer; AValue: Cardinal): Boolean;\r\n function InsertAll(Index: Integer; const ACollection: IJclCardinalCollection): Boolean;\r\n function LastIndexOf(AValue: Cardinal): Integer;\r\n procedure SetValue(Index: Integer; AValue: Cardinal);\r\n function SubList(First, Count: Integer): IJclCardinalList;\r\n end;\r\n\r\n TJclCardinalArrayIterator = class(TJclAbstractIterator, IJclCardinalIterator, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclIntfCloneable, IJclCloneable)\r\n private\r\n FCursor: Integer;\r\n FStart: TItrStart;\r\n FOwnList: TJclCardinalArrayList;\r\n protected\r\n procedure AssignPropertiesTo(Dest: TJclAbstractIterator); override;\r\n function CreateEmptyIterator: TJclAbstractIterator; override;\r\n public\r\n constructor Create(AOwnList: TJclCardinalArrayList; ACursor: Integer; AValid: Boolean; AStart: TItrStart);\r\n { IJclCardinalIterator }\r\n function Add(AValue: Cardinal): Boolean;\r\n procedure Extract;\r\n function GetValue: Cardinal;\r\n function HasNext: Boolean;\r\n function HasPrevious: Boolean;\r\n function Insert(AValue: Cardinal): Boolean;\r\n function IteratorEquals(const AIterator: IJclCardinalIterator): Boolean;\r\n function Next: Cardinal;\r\n function NextIndex: Integer;\r\n function Previous: Cardinal;\r\n function PreviousIndex: Integer;\r\n procedure Remove;\r\n procedure Reset;\r\n procedure SetValue(AValue: Cardinal);\r\n {$IFDEF SUPPORTS_FOR_IN}\r\n function MoveNext: Boolean;\r\n property Current: Cardinal read GetValue;\r\n {$ENDIF SUPPORTS_FOR_IN}\r\n end;\r\n\r\n TJclInt64ArrayList = class(TJclInt64AbstractContainer, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclIntfCloneable, IJclCloneable, IJclPackable, IJclGrowable, IJclBaseContainer, IJclInt64EqualityComparer, IJclInt64Container, IJclInt64FlatContainer,\r\n IJclInt64Collection, IJclInt64List, IJclInt64Array)\r\n protected\r\n function CreateEmptyContainer: TJclAbstractContainerBase; override;\r\n private\r\n FElementData: TDynInt64Array;\r\n // fix ambiguous warnings when compiled on Delphi.net and earlier versions of Delphi.win32\r\n // complaining about possible unaffected result.\r\n function RaiseOutOfBoundsError: Int64;\r\n protected\r\n procedure AssignDataTo(Dest: TJclAbstractContainerBase); override;\r\n public\r\n constructor Create(ACapacity: Integer); overload;\r\n constructor Create(const ACollection: IJclInt64Collection); overload;\r\n destructor Destroy; override;\r\n { IJclPackable }\r\n procedure SetCapacity(Value: Integer); override;\r\n { IJclInt64Collection }\r\n function Add(const AValue: Int64): Boolean;\r\n function AddAll(const ACollection: IJclInt64Collection): Boolean;\r\n procedure Clear;\r\n function Contains(const AValue: Int64): Boolean;\r\n function ContainsAll(const ACollection: IJclInt64Collection): Boolean;\r\n function CollectionEquals(const ACollection: IJclInt64Collection): Boolean;\r\n function Extract(const AValue: Int64): Boolean;\r\n function ExtractAll(const ACollection: IJclInt64Collection): Boolean;\r\n function First: IJclInt64Iterator;\r\n function IsEmpty: Boolean;\r\n function Last: IJclInt64Iterator;\r\n function Remove(const AValue: Int64): Boolean;\r\n function RemoveAll(const ACollection: IJclInt64Collection): Boolean;\r\n function RetainAll(const ACollection: IJclInt64Collection): Boolean;\r\n function Size: Integer;\r\n {$IFDEF SUPPORTS_FOR_IN}\r\n function GetEnumerator: IJclInt64Iterator;\r\n {$ENDIF SUPPORTS_FOR_IN}\r\n { IJclInt64List }\r\n function Delete(Index: Integer): Int64;\r\n function ExtractIndex(Index: Integer): Int64;\r\n function GetValue(Index: Integer): Int64;\r\n function IndexOf(const AValue: Int64): Integer;\r\n function Insert(Index: Integer; const AValue: Int64): Boolean;\r\n function InsertAll(Index: Integer; const ACollection: IJclInt64Collection): Boolean;\r\n function LastIndexOf(const AValue: Int64): Integer;\r\n procedure SetValue(Index: Integer; const AValue: Int64);\r\n function SubList(First, Count: Integer): IJclInt64List;\r\n end;\r\n\r\n TJclInt64ArrayIterator = class(TJclAbstractIterator, IJclInt64Iterator, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclIntfCloneable, IJclCloneable)\r\n private\r\n FCursor: Integer;\r\n FStart: TItrStart;\r\n FOwnList: TJclInt64ArrayList;\r\n protected\r\n procedure AssignPropertiesTo(Dest: TJclAbstractIterator); override;\r\n function CreateEmptyIterator: TJclAbstractIterator; override;\r\n public\r\n constructor Create(AOwnList: TJclInt64ArrayList; ACursor: Integer; AValid: Boolean; AStart: TItrStart);\r\n { IJclInt64Iterator }\r\n function Add(const AValue: Int64): Boolean;\r\n procedure Extract;\r\n function GetValue: Int64;\r\n function HasNext: Boolean;\r\n function HasPrevious: Boolean;\r\n function Insert(const AValue: Int64): Boolean;\r\n function IteratorEquals(const AIterator: IJclInt64Iterator): Boolean;\r\n function Next: Int64;\r\n function NextIndex: Integer;\r\n function Previous: Int64;\r\n function PreviousIndex: Integer;\r\n procedure Remove;\r\n procedure Reset;\r\n procedure SetValue(const AValue: Int64);\r\n {$IFDEF SUPPORTS_FOR_IN}\r\n function MoveNext: Boolean;\r\n property Current: Int64 read GetValue;\r\n {$ENDIF SUPPORTS_FOR_IN}\r\n end;\r\n\r\n TJclPtrArrayList = class(TJclPtrAbstractContainer, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclIntfCloneable, IJclCloneable, IJclPackable, IJclGrowable, IJclBaseContainer, IJclPtrEqualityComparer, IJclPtrContainer, IJclPtrFlatContainer,\r\n IJclPtrCollection, IJclPtrList, IJclPtrArray)\r\n protected\r\n function CreateEmptyContainer: TJclAbstractContainerBase; override;\r\n private\r\n FElementData: TDynPointerArray;\r\n // fix ambiguous warnings when compiled on Delphi.net and earlier versions of Delphi.win32\r\n // complaining about possible unaffected result.\r\n function RaiseOutOfBoundsError: Pointer;\r\n protected\r\n procedure AssignDataTo(Dest: TJclAbstractContainerBase); override;\r\n public\r\n constructor Create(ACapacity: Integer); overload;\r\n constructor Create(const ACollection: IJclPtrCollection); overload;\r\n destructor Destroy; override;\r\n { IJclPackable }\r\n procedure SetCapacity(Value: Integer); override;\r\n { IJclPtrCollection }\r\n function Add(APtr: Pointer): Boolean;\r\n function AddAll(const ACollection: IJclPtrCollection): Boolean;\r\n procedure Clear;\r\n function Contains(APtr: Pointer): Boolean;\r\n function ContainsAll(const ACollection: IJclPtrCollection): Boolean;\r\n function CollectionEquals(const ACollection: IJclPtrCollection): Boolean;\r\n function Extract(APtr: Pointer): Boolean;\r\n function ExtractAll(const ACollection: IJclPtrCollection): Boolean;\r\n function First: IJclPtrIterator;\r\n function IsEmpty: Boolean;\r\n function Last: IJclPtrIterator;\r\n function Remove(APtr: Pointer): Boolean;\r\n function RemoveAll(const ACollection: IJclPtrCollection): Boolean;\r\n function RetainAll(const ACollection: IJclPtrCollection): Boolean;\r\n function Size: Integer;\r\n {$IFDEF SUPPORTS_FOR_IN}\r\n function GetEnumerator: IJclPtrIterator;\r\n {$ENDIF SUPPORTS_FOR_IN}\r\n { IJclPtrList }\r\n function Delete(Index: Integer): Pointer;\r\n function ExtractIndex(Index: Integer): Pointer;\r\n function GetPointer(Index: Integer): Pointer;\r\n function IndexOf(APtr: Pointer): Integer;\r\n function Insert(Index: Integer; APtr: Pointer): Boolean;\r\n function InsertAll(Index: Integer; const ACollection: IJclPtrCollection): Boolean;\r\n function LastIndexOf(APtr: Pointer): Integer;\r\n procedure SetPointer(Index: Integer; APtr: Pointer);\r\n function SubList(First, Count: Integer): IJclPtrList;\r\n end;\r\n\r\n TJclPtrArrayIterator = class(TJclAbstractIterator, IJclPtrIterator, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclIntfCloneable, IJclCloneable)\r\n private\r\n FCursor: Integer;\r\n FStart: TItrStart;\r\n FOwnList: TJclPtrArrayList;\r\n protected\r\n procedure AssignPropertiesTo(Dest: TJclAbstractIterator); override;\r\n function CreateEmptyIterator: TJclAbstractIterator; override;\r\n public\r\n constructor Create(AOwnList: TJclPtrArrayList; ACursor: Integer; AValid: Boolean; AStart: TItrStart);\r\n { IJclPtrIterator }\r\n function Add(APtr: Pointer): Boolean;\r\n procedure Extract;\r\n function GetPointer: Pointer;\r\n function HasNext: Boolean;\r\n function HasPrevious: Boolean;\r\n function Insert(APtr: Pointer): Boolean;\r\n function IteratorEquals(const AIterator: IJclPtrIterator): Boolean;\r\n function Next: Pointer;\r\n function NextIndex: Integer;\r\n function Previous: Pointer;\r\n function PreviousIndex: Integer;\r\n procedure Remove;\r\n procedure Reset;\r\n procedure SetPointer(APtr: Pointer);\r\n {$IFDEF SUPPORTS_FOR_IN}\r\n function MoveNext: Boolean;\r\n property Current: Pointer read GetPointer;\r\n {$ENDIF SUPPORTS_FOR_IN}\r\n end;\r\n\r\n TJclArrayList = class(TJclAbstractContainer, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclIntfCloneable, IJclCloneable, IJclPackable, IJclGrowable, IJclBaseContainer, IJclEqualityComparer, IJclContainer, IJclFlatContainer, IJclObjectOwner,\r\n IJclCollection, IJclList, IJclArray)\r\n protected\r\n function CreateEmptyContainer: TJclAbstractContainerBase; override;\r\n private\r\n FElementData: TDynObjectArray;\r\n // fix ambiguous warnings when compiled on Delphi.net and earlier versions of Delphi.win32\r\n // complaining about possible unaffected result.\r\n function RaiseOutOfBoundsError: TObject;\r\n protected\r\n procedure AssignDataTo(Dest: TJclAbstractContainerBase); override;\r\n public\r\n constructor Create(ACapacity: Integer; AOwnsObjects: Boolean); overload;\r\n constructor Create(const ACollection: IJclCollection; AOwnsObjects: Boolean); overload;\r\n destructor Destroy; override;\r\n { IJclPackable }\r\n procedure SetCapacity(Value: Integer); override;\r\n { IJclCollection }\r\n function Add(AObject: TObject): Boolean;\r\n function AddAll(const ACollection: IJclCollection): Boolean;\r\n procedure Clear;\r\n function Contains(AObject: TObject): Boolean;\r\n function ContainsAll(const ACollection: IJclCollection): Boolean;\r\n function CollectionEquals(const ACollection: IJclCollection): Boolean;\r\n function Extract(AObject: TObject): Boolean;\r\n function ExtractAll(const ACollection: IJclCollection): Boolean;\r\n function First: IJclIterator;\r\n function IsEmpty: Boolean;\r\n function Last: IJclIterator;\r\n function Remove(AObject: TObject): Boolean;\r\n function RemoveAll(const ACollection: IJclCollection): Boolean;\r\n function RetainAll(const ACollection: IJclCollection): Boolean;\r\n function Size: Integer;\r\n {$IFDEF SUPPORTS_FOR_IN}\r\n function GetEnumerator: IJclIterator;\r\n {$ENDIF SUPPORTS_FOR_IN}\r\n { IJclList }\r\n function Delete(Index: Integer): TObject;\r\n function ExtractIndex(Index: Integer): TObject;\r\n function GetObject(Index: Integer): TObject;\r\n function IndexOf(AObject: TObject): Integer;\r\n function Insert(Index: Integer; AObject: TObject): Boolean;\r\n function InsertAll(Index: Integer; const ACollection: IJclCollection): Boolean;\r\n function LastIndexOf(AObject: TObject): Integer;\r\n procedure SetObject(Index: Integer; AObject: TObject);\r\n function SubList(First, Count: Integer): IJclList;\r\n end;\r\n\r\n TJclArrayIterator = class(TJclAbstractIterator, IJclIterator, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclIntfCloneable, IJclCloneable)\r\n private\r\n FCursor: Integer;\r\n FStart: TItrStart;\r\n FOwnList: TJclArrayList;\r\n protected\r\n procedure AssignPropertiesTo(Dest: TJclAbstractIterator); override;\r\n function CreateEmptyIterator: TJclAbstractIterator; override;\r\n public\r\n constructor Create(AOwnList: TJclArrayList; ACursor: Integer; AValid: Boolean; AStart: TItrStart);\r\n { IJclIterator }\r\n function Add(AObject: TObject): Boolean;\r\n procedure Extract;\r\n function GetObject: TObject;\r\n function HasNext: Boolean;\r\n function HasPrevious: Boolean;\r\n function Insert(AObject: TObject): Boolean;\r\n function IteratorEquals(const AIterator: IJclIterator): Boolean;\r\n function Next: TObject;\r\n function NextIndex: Integer;\r\n function Previous: TObject;\r\n function PreviousIndex: Integer;\r\n procedure Remove;\r\n procedure Reset;\r\n procedure SetObject(AObject: TObject);\r\n {$IFDEF SUPPORTS_FOR_IN}\r\n function MoveNext: Boolean;\r\n property Current: TObject read GetObject;\r\n {$ENDIF SUPPORTS_FOR_IN}\r\n end;\r\n\r\n\r\n {$IFDEF SUPPORTS_GENERICS}\r\n //DOM-IGNORE-BEGIN\r\n\r\n TJclArrayIterator = class;\r\n\r\n TJclArrayList = class(TJclAbstractContainer, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclIntfCloneable, IJclCloneable, IJclPackable, IJclGrowable, IJclBaseContainer, IJclEqualityComparer, IJclContainer, IJclFlatContainer, IJclItemOwner,\r\n IJclCollection, IJclList, IJclArray)\r\n protected\r\n type\r\n TDynArray = array of T;\r\n TArrayIterator = TJclArrayIterator;\r\n procedure MoveArray(var List: TDynArray; FromIndex, ToIndex, Count: SizeInt);\r\n private\r\n FElementData: TDynArray;\r\n // fix ambiguous warnings when compiled on Delphi.net and earlier versions of Delphi.win32\r\n // complaining about possible unaffected result.\r\n function RaiseOutOfBoundsError: T;\r\n protected\r\n procedure AssignDataTo(Dest: TJclAbstractContainerBase); override;\r\n public\r\n constructor Create(ACapacity: Integer; AOwnsItems: Boolean); overload;\r\n constructor Create(const ACollection: IJclCollection; AOwnsItems: Boolean); overload;\r\n destructor Destroy; override;\r\n { IJclPackable }\r\n procedure SetCapacity(Value: Integer); override;\r\n { IJclCollection }\r\n function Add(const AItem: T): Boolean;\r\n function AddAll(const ACollection: IJclCollection): Boolean;\r\n procedure Clear;\r\n function Contains(const AItem: T): Boolean;\r\n function ContainsAll(const ACollection: IJclCollection): Boolean;\r\n function CollectionEquals(const ACollection: IJclCollection): Boolean;\r\n function Extract(const AItem: T): Boolean;\r\n function ExtractAll(const ACollection: IJclCollection): Boolean;\r\n function First: IJclIterator;\r\n function IsEmpty: Boolean;\r\n function Last: IJclIterator;\r\n function Remove(const AItem: T): Boolean;\r\n function RemoveAll(const ACollection: IJclCollection): Boolean;\r\n function RetainAll(const ACollection: IJclCollection): Boolean;\r\n function Size: Integer;\r\n {$IFDEF SUPPORTS_FOR_IN}\r\n function GetEnumerator: IJclIterator;\r\n {$ENDIF SUPPORTS_FOR_IN}\r\n { IJclList }\r\n function Delete(Index: Integer): T;\r\n function ExtractIndex(Index: Integer): T;\r\n function GetItem(Index: Integer): T;\r\n function IndexOf(const AItem: T): Integer;\r\n function Insert(Index: Integer; const AItem: T): Boolean;\r\n function InsertAll(Index: Integer; const ACollection: IJclCollection): Boolean;\r\n function LastIndexOf(const AItem: T): Integer;\r\n procedure SetItem(Index: Integer; const AItem: T);\r\n function SubList(First, Count: Integer): IJclList;\r\n end;\r\n\r\n TJclArrayIterator = class(TJclAbstractIterator, IJclIterator, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclIntfCloneable, IJclCloneable)\r\n private\r\n FCursor: Integer;\r\n FStart: TItrStart;\r\n FOwnList: IJclList;\r\n protected\r\n procedure AssignPropertiesTo(Dest: TJclAbstractIterator); override;\r\n function CreateEmptyIterator: TJclAbstractIterator; override;\r\n public\r\n constructor Create(AOwnList: IJclList; ACursor: Integer; AValid: Boolean; AStart: TItrStart);\r\n { IJclIterator }\r\n function Add(const AItem: T): Boolean;\r\n procedure Extract;\r\n function GetItem: T;\r\n function HasNext: Boolean;\r\n function HasPrevious: Boolean;\r\n function Insert(const AItem: T): Boolean;\r\n function IteratorEquals(const AIterator: IJclIterator): Boolean;\r\n function Next: T;\r\n function NextIndex: Integer;\r\n function Previous: T;\r\n function PreviousIndex: Integer;\r\n procedure Remove;\r\n procedure Reset;\r\n procedure SetItem(const AItem: T);\r\n {$IFDEF SUPPORTS_FOR_IN}\r\n function MoveNext: Boolean;\r\n property Current: T read GetItem;\r\n {$ENDIF SUPPORTS_FOR_IN}\r\n end;\r\n\r\n // E = External helper to compare items for equality\r\n // GetHashCode is not used\r\n TJclArrayListE = class(TJclArrayList, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclIntfCloneable, IJclCloneable, IJclPackable, IJclGrowable, IJclBaseContainer, IJclContainer, IJclItemOwner, IJclEqualityComparer,\r\n IJclCollection, IJclList, IJclArray)\r\n private\r\n FEqualityComparer: IJclEqualityComparer;\r\n protected\r\n procedure AssignPropertiesTo(Dest: TJclAbstractContainerBase); override;\r\n function CreateEmptyContainer: TJclAbstractContainerBase; override;\r\n public\r\n constructor Create(const AEqualityComparer: IJclEqualityComparer; ACapacity: Integer; AOwnsItems: Boolean); overload;\r\n constructor Create(const AEqualityComparer: IJclEqualityComparer; const ACollection: IJclCollection; AOwnsItems: Boolean); overload;\r\n { IJclEqualityComparer }\r\n function ItemsEqual(const A, B: T): Boolean; override;\r\n property EqualityComparer: IJclEqualityComparer read FEqualityComparer write FEqualityComparer;\r\n end;\r\n\r\n // F = Function to compare items for equality\r\n TJclArrayListF = class(TJclArrayList, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclIntfCloneable, IJclCloneable, IJclPackable, IJclGrowable, IJclBaseContainer, IJclContainer, IJclItemOwner, IJclEqualityComparer,\r\n IJclCollection, IJclList, IJclArray)\r\n protected\r\n function CreateEmptyContainer: TJclAbstractContainerBase; override;\r\n public\r\n constructor Create(const AEqualityCompare: TEqualityCompare; ACapacity: Integer; AOwnsItems: Boolean); overload;\r\n constructor Create(const AEqualityCompare: TEqualityCompare; const ACollection: IJclCollection; AOwnsItems: Boolean); overload;\r\n end;\r\n\r\n // I = Items can compare themselves to others\r\n TJclArrayListI> = class(TJclArrayList, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclIntfCloneable, IJclCloneable, IJclPackable, IJclGrowable, IJclBaseContainer, IJclContainer, IJclItemOwner, IJclEqualityComparer,\r\n IJclCollection, IJclList, IJclArray)\r\n protected\r\n function CreateEmptyContainer: TJclAbstractContainerBase; override;\r\n public\r\n { IJclEqualityComparer }\r\n function ItemsEqual(const A, B: T): Boolean; override;\r\n end;\r\n\r\n //DOM-IGNORE-END\r\n {$ENDIF SUPPORTS_GENERICS}\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jcl.svn.sourceforge.net/svnroot/jcl/tags/JCL-2.4-Build4571/jcl/source/common/JclArrayLists.pas $';\r\n Revision: '$Revision: 3745 $';\r\n Date: '$Date: 2012-02-24 12:14:46 +0100 (ven. 24 févr. 2012) $';\r\n LogPath: 'JCL\\source\\common';\r\n Extra: '';\r\n Data: nil\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n {$IFDEF SUPPORTNAMESPACES}\r\n System.SysUtils;\r\n {$ELSE}\r\n SysUtils;\r\n {$ENDIF}\r\n\r\n//=== { TJclIntfArrayList } ======================================================\r\n\r\nconstructor TJclIntfArrayList.Create(ACapacity: Integer);\r\nbegin\r\n inherited Create();\r\n SetCapacity(ACapacity);\r\nend;\r\n\r\nconstructor TJclIntfArrayList.Create(const ACollection: IJclIntfCollection);\r\nbegin\r\n inherited Create();\r\n if ACollection = nil then\r\n raise EJclNoCollectionError.Create;\r\n SetCapacity(ACollection.Size);\r\n AddAll(ACollection);\r\nend;\r\n\r\ndestructor TJclIntfArrayList.Destroy;\r\nbegin\r\n FReadOnly := False;\r\n Clear;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJclIntfArrayList.Add(const AInterface: IInterface): Boolean;\r\nvar\r\n Index: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := FAllowDefaultElements or not ItemsEqual(AInterface, nil);\r\n if Result then\r\n begin\r\n if FDuplicates <> dupAccept then\r\n for Index := 0 to FSize - 1 do\r\n if ItemsEqual(AInterface, FElementData[Index]) then\r\n begin\r\n Result := CheckDuplicate;\r\n Break;\r\n end;\r\n\r\n if Result then\r\n begin\r\n if FSize = FCapacity then\r\n AutoGrow;\r\n Result := FSize < FCapacity;\r\n if Result then\r\n begin\r\n FElementData[FSize] := AInterface;\r\n Inc(FSize);\r\n end;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfArrayList.AddAll(const ACollection: IJclIntfCollection): Boolean;\r\nvar\r\n It: IJclIntfIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n Result := Add(It.Next) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclIntfArrayList.AssignDataTo(Dest: TJclAbstractContainerBase);\r\nvar\r\n ADest: TJclIntfArrayList;\r\n ACollection: IJclIntfCollection;\r\nbegin\r\n inherited AssignDataTo(Dest);\r\n if Dest is TJclIntfArrayList then\r\n begin\r\n ADest := TJclIntfArrayList(Dest);\r\n ADest.Clear;\r\n ADest.AddAll(Self);\r\n end\r\n else\r\n if Supports(IInterface(Dest), IJclIntfCollection, ACollection) then\r\n begin\r\n ACollection.Clear;\r\n ACollection.AddAll(Self);\r\n end;\r\nend;\r\n\r\nprocedure TJclIntfArrayList.Clear;\r\nvar\r\n I: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n for I := 0 to FSize - 1 do\r\n FreeObject(FElementData[I]);\r\n FSize := 0;\r\n AutoPack;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfArrayList.CollectionEquals(const ACollection: IJclIntfCollection): Boolean;\r\nvar\r\n I: Integer;\r\n It: IJclIntfIterator;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n if FSize <> ACollection.Size then\r\n Exit;\r\n It := ACollection.First;\r\n for I := 0 to FSize - 1 do\r\n if not ItemsEqual(FElementData[I], It.Next) then\r\n Exit;\r\n Result := True;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfArrayList.Contains(const AInterface: IInterface): Boolean;\r\nvar\r\n I: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n for I := 0 to FSize - 1 do\r\n if ItemsEqual(FElementData[I], AInterface) then\r\n begin\r\n Result := True;\r\n Break;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfArrayList.ContainsAll(const ACollection: IJclIntfCollection): Boolean;\r\nvar\r\n It: IJclIntfIterator;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := True;\r\n if ACollection = nil then\r\n Exit;\r\n It := ACollection.First;\r\n while Result and It.HasNext do\r\n Result := Contains(It.Next);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfArrayList.Delete(Index: Integer): IInterface;\r\nvar\r\n Extracted: IInterface;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Extracted := ExtractIndex(Index);\r\n Result := FreeObject(Extracted);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfArrayList.Extract(const AInterface: IInterface): Boolean;\r\nvar\r\n I: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n for I := FSize - 1 downto 0 do\r\n if ItemsEqual(FElementData[I], AInterface) then\r\n begin\r\n if I < (FSize - 1) then\r\n MoveArray(FElementData, I + 1, I, FSize - 1 - I)\r\n else\r\n FElementData[I] := nil;\r\n Dec(FSize);\r\n Result := True;\r\n if FRemoveSingleElement then\r\n Break;\r\n end;\r\n AutoPack;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfArrayList.ExtractAll(const ACollection: IJclIntfCollection): Boolean;\r\nvar\r\n It: IJclIntfIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n Result := Extract(It.Next) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfArrayList.ExtractIndex(Index: Integer): IInterface;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if (Index >= 0) and (Index < FSize) then\r\n begin\r\n Result := FElementData[Index];\r\n if Index < (FSize - 1) then\r\n MoveArray(FElementData, Index + 1, Index, FSize - 1 - Index)\r\n else\r\n FElementData[Index] := nil;\r\n Dec(FSize);\r\n AutoPack;\r\n end\r\n else\r\n Result := RaiseOutOfBoundsError;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfArrayList.First: IJclIntfIterator;\r\nbegin\r\n Result := TJclIntfArrayIterator.Create(Self, 0, False, isFirst);\r\nend;\r\n\r\n{$IFDEF SUPPORTS_FOR_IN}\r\nfunction TJclIntfArrayList.GetEnumerator: IJclIntfIterator;\r\nbegin\r\n Result := TJclIntfArrayIterator.Create(Self, 0, False, isFirst);\r\nend;\r\n{$ENDIF SUPPORTS_FOR_IN}\r\n\r\nfunction TJclIntfArrayList.GetObject(Index: Integer): IInterface;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := nil;\r\n if (Index >= 0) and (Index < FSize) then\r\n Result := FElementData[Index]\r\n else\r\n if not FReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create(IntToStr(Index));\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfArrayList.IndexOf(const AInterface: IInterface): Integer;\r\nvar\r\n I: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := -1;\r\n for I := 0 to FSize - 1 do\r\n if ItemsEqual(FElementData[I], AInterface) then\r\n begin\r\n Result := I;\r\n Break;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfArrayList.Insert(Index: Integer; const AInterface: IInterface): Boolean;\r\nvar\r\n I: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := FAllowDefaultElements or not ItemsEqual(AInterface, nil);\r\n\r\n if (Index < 0) or (Index > FSize) then\r\n raise EJclOutOfBoundsError.Create;\r\n\r\n if Result then\r\n begin\r\n if FDuplicates <> dupAccept then\r\n for I := 0 to FSize - 1 do\r\n if ItemsEqual(AInterface, FElementData[I]) then\r\n begin\r\n Result := CheckDuplicate;\r\n Break;\r\n end;\r\n\r\n if Result then\r\n begin\r\n if FSize = FCapacity then\r\n AutoGrow;\r\n Result := FSize < FCapacity;\r\n if Result then\r\n begin\r\n if Index < FSize then\r\n MoveArray(FElementData, Index, Index + 1, FSize - Index);\r\n FElementData[Index] := AInterface;\r\n Inc(FSize);\r\n end;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfArrayList.InsertAll(Index: Integer; const ACollection: IJclIntfCollection): Boolean;\r\nvar\r\n It: IJclIntfIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if (Index < 0) or (Index > FSize) then\r\n raise EJclOutOfBoundsError.Create;\r\n if ACollection = nil then\r\n Exit;\r\n\r\n Result := True;\r\n It := ACollection.Last;\r\n while It.HasPrevious do\r\n Result := Insert(Index, It.Previous) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfArrayList.IsEmpty: Boolean;\r\nbegin\r\n Result := FSize = 0;\r\nend;\r\n\r\nfunction TJclIntfArrayList.Last: IJclIntfIterator;\r\nbegin\r\n Result := TJclIntfArrayIterator.Create(Self, FSize - 1, False, isLast);\r\nend;\r\n\r\nfunction TJclIntfArrayList.LastIndexOf(const AInterface: IInterface): Integer;\r\nvar\r\n I: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := -1;\r\n for I := FSize - 1 downto 0 do\r\n if ItemsEqual(FElementData[I], AInterface) then\r\n begin\r\n Result := I;\r\n Break;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfArrayList.RaiseOutOfBoundsError: IInterface;\r\nbegin\r\n raise EJclOutOfBoundsError.Create;\r\nend;\r\n\r\nfunction TJclIntfArrayList.Remove(const AInterface: IInterface): Boolean;\r\nvar\r\n Extracted: IInterface;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := Extract(AInterface);\r\n if Result then\r\n begin\r\n Extracted := AInterface;\r\n FreeObject(Extracted);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfArrayList.RemoveAll(const ACollection: IJclIntfCollection): Boolean;\r\nvar\r\n It: IJclIntfIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n Result := Remove(It.Next) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfArrayList.RetainAll(const ACollection: IJclIntfCollection): Boolean;\r\nvar\r\n I: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n for I := FSize - 1 downto 0 do\r\n if not ACollection.Contains(FElementData[I]) then\r\n Delete(I);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclIntfArrayList.SetCapacity(Value: Integer);\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Value >= FSize then\r\n begin\r\n SetLength(FElementData, Value);\r\n inherited SetCapacity(Value);\r\n end\r\n else\r\n raise EJclOutOfBoundsError.Create;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclIntfArrayList.SetObject(Index: Integer; const AInterface: IInterface);\r\nvar\r\n ReplaceItem: Boolean;\r\n I: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if (Index < 0) or (Index >= FSize) then\r\n raise EJclOutOfBoundsError.Create;\r\n ReplaceItem := FAllowDefaultElements or not ItemsEqual(AInterface, nil);\r\n if ReplaceItem then\r\n begin\r\n if FDuplicates <> dupAccept then\r\n for I := 0 to FSize - 1 do\r\n if ItemsEqual(FElementData[I], AInterface) then\r\n begin\r\n ReplaceItem := CheckDuplicate;\r\n Break;\r\n end;\r\n if ReplaceItem then\r\n begin\r\n FreeObject(FElementData[Index]);\r\n FElementData[Index] := AInterface;\r\n end;\r\n end;\r\n if not ReplaceItem then\r\n Delete(Index);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfArrayList.Size: Integer;\r\nbegin\r\n Result := FSize;\r\nend;\r\n\r\nfunction TJclIntfArrayList.SubList(First, Count: Integer): IJclIntfList;\r\nvar\r\n I: Integer;\r\n Last: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Last := First + Count - 1;\r\n if Last >= FSize then\r\n Last := FSize - 1;\r\n Result := CreateEmptyContainer as IJclIntfList;\r\n for I := First to Last do\r\n Result.Add(FElementData[I]);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfArrayList.CreateEmptyContainer: TJclAbstractContainerBase;\r\nbegin\r\n Result := TJclIntfArrayList.Create(FSize);\r\n AssignPropertiesTo(Result);\r\nend;\r\n\r\n//=== { TJclIntfArrayIterator } ===============================================================\r\n\r\nconstructor TJclIntfArrayIterator.Create(AOwnList: TJclIntfArrayList; ACursor: Integer; AValid: Boolean; AStart: TItrStart);\r\nbegin\r\n inherited Create(AValid);\r\n FOwnList := AOwnList;\r\n FStart := AStart;\r\n FCursor := ACursor;\r\nend;\r\n\r\nfunction TJclIntfArrayIterator.Add(const AInterface: IInterface): Boolean;\r\nbegin\r\n Result := FOwnList.Add(AInterface);\r\nend;\r\n\r\nprocedure TJclIntfArrayIterator.AssignPropertiesTo(Dest: TJclAbstractIterator);\r\nvar\r\n ADest: TJclIntfArrayIterator;\r\nbegin\r\n inherited AssignPropertiesTo(Dest);\r\n if Dest is TJclIntfArrayIterator then\r\n begin\r\n ADest := TJclIntfArrayIterator(Dest);\r\n ADest.FOwnList := FOwnList;\r\n ADest.FCursor := FCursor;\r\n ADest.FStart := FStart;\r\n end;\r\nend;\r\n\r\nfunction TJclIntfArrayIterator.CreateEmptyIterator: TJclAbstractIterator;\r\nbegin\r\n Result := TJclIntfArrayIterator.Create(FOwnList, FCursor, Valid, FStart);\r\nend;\r\n\r\nprocedure TJclIntfArrayIterator.Extract;\r\nbegin\r\n CheckValid;\r\n Valid := False;\r\n FOwnList.ExtractIndex(FCursor);\r\nend;\r\n\r\nfunction TJclIntfArrayIterator.GetObject: IInterface;\r\nbegin\r\n CheckValid;\r\n Result := FOwnList.GetObject(FCursor);\r\nend;\r\n\r\nfunction TJclIntfArrayIterator.HasNext: Boolean;\r\nbegin\r\n if Valid then\r\n Result := FCursor < (FOwnList.Size - 1)\r\n else\r\n Result := FCursor < FOwnList.Size;\r\nend;\r\n\r\nfunction TJclIntfArrayIterator.HasPrevious: Boolean;\r\nbegin\r\n if Valid then\r\n Result := FCursor > 0\r\n else\r\n Result := FCursor >= 0;\r\nend;\r\n\r\nfunction TJclIntfArrayIterator.Insert(const AInterface: IInterface): Boolean;\r\nbegin\r\n CheckValid;\r\n Result := FOwnList.Insert(FCursor, AInterface);\r\nend;\r\n\r\nfunction TJclIntfArrayIterator.IteratorEquals(const AIterator: IJclIntfIterator): Boolean;\r\nvar\r\n Obj: TObject;\r\n ItrObj: TJclIntfArrayIterator;\r\nbegin\r\n Result := False;\r\n if AIterator = nil then\r\n Exit;\r\n Obj := AIterator.GetIteratorReference;\r\n if Obj is TJclIntfArrayIterator then\r\n begin\r\n ItrObj := TJclIntfArrayIterator(Obj);\r\n Result := (FOwnList = ItrObj.FOwnList) and (FCursor = ItrObj.FCursor) and (Valid = ItrObj.Valid);\r\n end;\r\nend;\r\n\r\n{$IFDEF SUPPORTS_FOR_IN}\r\nfunction TJclIntfArrayIterator.MoveNext: Boolean;\r\nbegin\r\n if Valid then\r\n Inc(FCursor)\r\n else\r\n Valid := True;\r\n Result := FCursor < FOwnList.Size;\r\nend;\r\n{$ENDIF SUPPORTS_FOR_IN}\r\n\r\nfunction TJclIntfArrayIterator.Next: IInterface;\r\nbegin\r\n if Valid then\r\n Inc(FCursor)\r\n else\r\n Valid := True;\r\n Result := FOwnList.GetObject(FCursor);\r\nend;\r\n\r\nfunction TJclIntfArrayIterator.NextIndex: Integer;\r\nbegin\r\n if Valid then\r\n Result := FCursor + 1\r\n else\r\n Result := FCursor;\r\nend;\r\n\r\nfunction TJclIntfArrayIterator.Previous: IInterface;\r\nbegin\r\n if Valid then\r\n Dec(FCursor)\r\n else\r\n Valid := True;\r\n Result := FOwnList.GetObject(FCursor);\r\nend;\r\n\r\nfunction TJclIntfArrayIterator.PreviousIndex: Integer;\r\nbegin\r\n if Valid then\r\n Result := FCursor - 1\r\n else\r\n Result := FCursor;\r\nend;\r\n\r\nprocedure TJclIntfArrayIterator.Remove;\r\nbegin\r\n CheckValid;\r\n Valid := False;\r\n FOwnList.Delete(FCursor);\r\nend;\r\n\r\nprocedure TJclIntfArrayIterator.Reset;\r\nbegin\r\n Valid := False;\r\n case FStart of\r\n isFirst:\r\n FCursor := 0;\r\n isLast:\r\n FCursor := FOwnList.Size - 1;\r\n end;\r\nend;\r\n\r\nprocedure TJclIntfArrayIterator.SetObject(const AInterface: IInterface);\r\nbegin\r\n CheckValid;\r\n FOwnList.SetObject(FCursor, AInterface);\r\nend;\r\n\r\n//=== { TJclAnsiStrArrayList } ======================================================\r\n\r\nconstructor TJclAnsiStrArrayList.Create(ACapacity: Integer);\r\nbegin\r\n inherited Create();\r\n SetCapacity(ACapacity);\r\nend;\r\n\r\nconstructor TJclAnsiStrArrayList.Create(const ACollection: IJclAnsiStrCollection);\r\nbegin\r\n inherited Create();\r\n if ACollection = nil then\r\n raise EJclNoCollectionError.Create;\r\n SetCapacity(ACollection.Size);\r\n AddAll(ACollection);\r\nend;\r\n\r\ndestructor TJclAnsiStrArrayList.Destroy;\r\nbegin\r\n FReadOnly := False;\r\n Clear;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJclAnsiStrArrayList.Add(const AString: AnsiString): Boolean;\r\nvar\r\n Index: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := FAllowDefaultElements or not ItemsEqual(AString, '');\r\n if Result then\r\n begin\r\n if FDuplicates <> dupAccept then\r\n for Index := 0 to FSize - 1 do\r\n if ItemsEqual(AString, FElementData[Index]) then\r\n begin\r\n Result := CheckDuplicate;\r\n Break;\r\n end;\r\n\r\n if Result then\r\n begin\r\n if FSize = FCapacity then\r\n AutoGrow;\r\n Result := FSize < FCapacity;\r\n if Result then\r\n begin\r\n FElementData[FSize] := AString;\r\n Inc(FSize);\r\n end;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclAnsiStrArrayList.AddAll(const ACollection: IJclAnsiStrCollection): Boolean;\r\nvar\r\n It: IJclAnsiStrIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n Result := Add(It.Next) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclAnsiStrArrayList.AssignDataTo(Dest: TJclAbstractContainerBase);\r\nvar\r\n ADest: TJclAnsiStrArrayList;\r\n ACollection: IJclAnsiStrCollection;\r\nbegin\r\n inherited AssignDataTo(Dest);\r\n if Dest is TJclAnsiStrArrayList then\r\n begin\r\n ADest := TJclAnsiStrArrayList(Dest);\r\n ADest.Clear;\r\n ADest.AddAll(Self);\r\n end\r\n else\r\n if Supports(IInterface(Dest), IJclAnsiStrCollection, ACollection) then\r\n begin\r\n ACollection.Clear;\r\n ACollection.AddAll(Self);\r\n end;\r\nend;\r\n\r\nprocedure TJclAnsiStrArrayList.Clear;\r\nvar\r\n I: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n for I := 0 to FSize - 1 do\r\n FreeString(FElementData[I]);\r\n FSize := 0;\r\n AutoPack;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclAnsiStrArrayList.CollectionEquals(const ACollection: IJclAnsiStrCollection): Boolean;\r\nvar\r\n I: Integer;\r\n It: IJclAnsiStrIterator;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n if FSize <> ACollection.Size then\r\n Exit;\r\n It := ACollection.First;\r\n for I := 0 to FSize - 1 do\r\n if not ItemsEqual(FElementData[I], It.Next) then\r\n Exit;\r\n Result := True;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclAnsiStrArrayList.Contains(const AString: AnsiString): Boolean;\r\nvar\r\n I: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n for I := 0 to FSize - 1 do\r\n if ItemsEqual(FElementData[I], AString) then\r\n begin\r\n Result := True;\r\n Break;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclAnsiStrArrayList.ContainsAll(const ACollection: IJclAnsiStrCollection): Boolean;\r\nvar\r\n It: IJclAnsiStrIterator;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := True;\r\n if ACollection = nil then\r\n Exit;\r\n It := ACollection.First;\r\n while Result and It.HasNext do\r\n Result := Contains(It.Next);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclAnsiStrArrayList.Delete(Index: Integer): AnsiString;\r\nvar\r\n Extracted: AnsiString;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Extracted := ExtractIndex(Index);\r\n Result := FreeString(Extracted);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclAnsiStrArrayList.Extract(const AString: AnsiString): Boolean;\r\nvar\r\n I: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n for I := FSize - 1 downto 0 do\r\n if ItemsEqual(FElementData[I], AString) then\r\n begin\r\n if I < (FSize - 1) then\r\n MoveArray(FElementData, I + 1, I, FSize - 1 - I)\r\n else\r\n FElementData[I] := '';\r\n Dec(FSize);\r\n Result := True;\r\n if FRemoveSingleElement then\r\n Break;\r\n end;\r\n AutoPack;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclAnsiStrArrayList.ExtractAll(const ACollection: IJclAnsiStrCollection): Boolean;\r\nvar\r\n It: IJclAnsiStrIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n Result := Extract(It.Next) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclAnsiStrArrayList.ExtractIndex(Index: Integer): AnsiString;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if (Index >= 0) and (Index < FSize) then\r\n begin\r\n Result := FElementData[Index];\r\n if Index < (FSize - 1) then\r\n MoveArray(FElementData, Index + 1, Index, FSize - 1 - Index)\r\n else\r\n FElementData[Index] := '';\r\n Dec(FSize);\r\n AutoPack;\r\n end\r\n else\r\n Result := RaiseOutOfBoundsError;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclAnsiStrArrayList.First: IJclAnsiStrIterator;\r\nbegin\r\n Result := TJclAnsiStrArrayIterator.Create(Self, 0, False, isFirst);\r\nend;\r\n\r\n{$IFDEF SUPPORTS_FOR_IN}\r\nfunction TJclAnsiStrArrayList.GetEnumerator: IJclAnsiStrIterator;\r\nbegin\r\n Result := TJclAnsiStrArrayIterator.Create(Self, 0, False, isFirst);\r\nend;\r\n{$ENDIF SUPPORTS_FOR_IN}\r\n\r\nfunction TJclAnsiStrArrayList.GetString(Index: Integer): AnsiString;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := '';\r\n if (Index >= 0) and (Index < FSize) then\r\n Result := FElementData[Index]\r\n else\r\n if not FReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create(IntToStr(Index));\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclAnsiStrArrayList.IndexOf(const AString: AnsiString): Integer;\r\nvar\r\n I: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := -1;\r\n for I := 0 to FSize - 1 do\r\n if ItemsEqual(FElementData[I], AString) then\r\n begin\r\n Result := I;\r\n Break;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclAnsiStrArrayList.Insert(Index: Integer; const AString: AnsiString): Boolean;\r\nvar\r\n I: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := FAllowDefaultElements or not ItemsEqual(AString, '');\r\n\r\n if (Index < 0) or (Index > FSize) then\r\n raise EJclOutOfBoundsError.Create;\r\n\r\n if Result then\r\n begin\r\n if FDuplicates <> dupAccept then\r\n for I := 0 to FSize - 1 do\r\n if ItemsEqual(AString, FElementData[I]) then\r\n begin\r\n Result := CheckDuplicate;\r\n Break;\r\n end;\r\n\r\n if Result then\r\n begin\r\n if FSize = FCapacity then\r\n AutoGrow;\r\n Result := FSize < FCapacity;\r\n if Result then\r\n begin\r\n if Index < FSize then\r\n MoveArray(FElementData, Index, Index + 1, FSize - Index);\r\n FElementData[Index] := AString;\r\n Inc(FSize);\r\n end;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclAnsiStrArrayList.InsertAll(Index: Integer; const ACollection: IJclAnsiStrCollection): Boolean;\r\nvar\r\n It: IJclAnsiStrIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if (Index < 0) or (Index > FSize) then\r\n raise EJclOutOfBoundsError.Create;\r\n if ACollection = nil then\r\n Exit;\r\n\r\n Result := True;\r\n It := ACollection.Last;\r\n while It.HasPrevious do\r\n Result := Insert(Index, It.Previous) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclAnsiStrArrayList.IsEmpty: Boolean;\r\nbegin\r\n Result := FSize = 0;\r\nend;\r\n\r\nfunction TJclAnsiStrArrayList.Last: IJclAnsiStrIterator;\r\nbegin\r\n Result := TJclAnsiStrArrayIterator.Create(Self, FSize - 1, False, isLast);\r\nend;\r\n\r\nfunction TJclAnsiStrArrayList.LastIndexOf(const AString: AnsiString): Integer;\r\nvar\r\n I: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := -1;\r\n for I := FSize - 1 downto 0 do\r\n if ItemsEqual(FElementData[I], AString) then\r\n begin\r\n Result := I;\r\n Break;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclAnsiStrArrayList.RaiseOutOfBoundsError: AnsiString;\r\nbegin\r\n raise EJclOutOfBoundsError.Create;\r\nend;\r\n\r\nfunction TJclAnsiStrArrayList.Remove(const AString: AnsiString): Boolean;\r\nvar\r\n Extracted: AnsiString;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := Extract(AString);\r\n if Result then\r\n begin\r\n Extracted := AString;\r\n FreeString(Extracted);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclAnsiStrArrayList.RemoveAll(const ACollection: IJclAnsiStrCollection): Boolean;\r\nvar\r\n It: IJclAnsiStrIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n Result := Remove(It.Next) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclAnsiStrArrayList.RetainAll(const ACollection: IJclAnsiStrCollection): Boolean;\r\nvar\r\n I: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n for I := FSize - 1 downto 0 do\r\n if not ACollection.Contains(FElementData[I]) then\r\n Delete(I);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclAnsiStrArrayList.SetCapacity(Value: Integer);\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Value >= FSize then\r\n begin\r\n SetLength(FElementData, Value);\r\n inherited SetCapacity(Value);\r\n end\r\n else\r\n raise EJclOutOfBoundsError.Create;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclAnsiStrArrayList.SetString(Index: Integer; const AString: AnsiString);\r\nvar\r\n ReplaceItem: Boolean;\r\n I: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if (Index < 0) or (Index >= FSize) then\r\n raise EJclOutOfBoundsError.Create;\r\n ReplaceItem := FAllowDefaultElements or not ItemsEqual(AString, '');\r\n if ReplaceItem then\r\n begin\r\n if FDuplicates <> dupAccept then\r\n for I := 0 to FSize - 1 do\r\n if ItemsEqual(FElementData[I], AString) then\r\n begin\r\n ReplaceItem := CheckDuplicate;\r\n Break;\r\n end;\r\n if ReplaceItem then\r\n begin\r\n FreeString(FElementData[Index]);\r\n FElementData[Index] := AString;\r\n end;\r\n end;\r\n if not ReplaceItem then\r\n Delete(Index);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclAnsiStrArrayList.Size: Integer;\r\nbegin\r\n Result := FSize;\r\nend;\r\n\r\nfunction TJclAnsiStrArrayList.SubList(First, Count: Integer): IJclAnsiStrList;\r\nvar\r\n I: Integer;\r\n Last: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Last := First + Count - 1;\r\n if Last >= FSize then\r\n Last := FSize - 1;\r\n Result := CreateEmptyContainer as IJclAnsiStrList;\r\n for I := First to Last do\r\n Result.Add(FElementData[I]);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclAnsiStrArrayList.CreateEmptyContainer: TJclAbstractContainerBase;\r\nbegin\r\n Result := TJclAnsiStrArrayList.Create(FSize);\r\n AssignPropertiesTo(Result);\r\nend;\r\n\r\n//=== { TJclAnsiStrArrayIterator } ===============================================================\r\n\r\nconstructor TJclAnsiStrArrayIterator.Create(AOwnList: TJclAnsiStrArrayList; ACursor: Integer; AValid: Boolean; AStart: TItrStart);\r\nbegin\r\n inherited Create(AValid);\r\n FOwnList := AOwnList;\r\n FStart := AStart;\r\n FCursor := ACursor;\r\nend;\r\n\r\nfunction TJclAnsiStrArrayIterator.Add(const AString: AnsiString): Boolean;\r\nbegin\r\n Result := FOwnList.Add(AString);\r\nend;\r\n\r\nprocedure TJclAnsiStrArrayIterator.AssignPropertiesTo(Dest: TJclAbstractIterator);\r\nvar\r\n ADest: TJclAnsiStrArrayIterator;\r\nbegin\r\n inherited AssignPropertiesTo(Dest);\r\n if Dest is TJclAnsiStrArrayIterator then\r\n begin\r\n ADest := TJclAnsiStrArrayIterator(Dest);\r\n ADest.FOwnList := FOwnList;\r\n ADest.FCursor := FCursor;\r\n ADest.FStart := FStart;\r\n end;\r\nend;\r\n\r\nfunction TJclAnsiStrArrayIterator.CreateEmptyIterator: TJclAbstractIterator;\r\nbegin\r\n Result := TJclAnsiStrArrayIterator.Create(FOwnList, FCursor, Valid, FStart);\r\nend;\r\n\r\nprocedure TJclAnsiStrArrayIterator.Extract;\r\nbegin\r\n CheckValid;\r\n Valid := False;\r\n FOwnList.ExtractIndex(FCursor);\r\nend;\r\n\r\nfunction TJclAnsiStrArrayIterator.GetString: AnsiString;\r\nbegin\r\n CheckValid;\r\n Result := FOwnList.GetString(FCursor);\r\nend;\r\n\r\nfunction TJclAnsiStrArrayIterator.HasNext: Boolean;\r\nbegin\r\n if Valid then\r\n Result := FCursor < (FOwnList.Size - 1)\r\n else\r\n Result := FCursor < FOwnList.Size;\r\nend;\r\n\r\nfunction TJclAnsiStrArrayIterator.HasPrevious: Boolean;\r\nbegin\r\n if Valid then\r\n Result := FCursor > 0\r\n else\r\n Result := FCursor >= 0;\r\nend;\r\n\r\nfunction TJclAnsiStrArrayIterator.Insert(const AString: AnsiString): Boolean;\r\nbegin\r\n CheckValid;\r\n Result := FOwnList.Insert(FCursor, AString);\r\nend;\r\n\r\nfunction TJclAnsiStrArrayIterator.IteratorEquals(const AIterator: IJclAnsiStrIterator): Boolean;\r\nvar\r\n Obj: TObject;\r\n ItrObj: TJclAnsiStrArrayIterator;\r\nbegin\r\n Result := False;\r\n if AIterator = nil then\r\n Exit;\r\n Obj := AIterator.GetIteratorReference;\r\n if Obj is TJclAnsiStrArrayIterator then\r\n begin\r\n ItrObj := TJclAnsiStrArrayIterator(Obj);\r\n Result := (FOwnList = ItrObj.FOwnList) and (FCursor = ItrObj.FCursor) and (Valid = ItrObj.Valid);\r\n end;\r\nend;\r\n\r\n{$IFDEF SUPPORTS_FOR_IN}\r\nfunction TJclAnsiStrArrayIterator.MoveNext: Boolean;\r\nbegin\r\n if Valid then\r\n Inc(FCursor)\r\n else\r\n Valid := True;\r\n Result := FCursor < FOwnList.Size;\r\nend;\r\n{$ENDIF SUPPORTS_FOR_IN}\r\n\r\nfunction TJclAnsiStrArrayIterator.Next: AnsiString;\r\nbegin\r\n if Valid then\r\n Inc(FCursor)\r\n else\r\n Valid := True;\r\n Result := FOwnList.GetString(FCursor);\r\nend;\r\n\r\nfunction TJclAnsiStrArrayIterator.NextIndex: Integer;\r\nbegin\r\n if Valid then\r\n Result := FCursor + 1\r\n else\r\n Result := FCursor;\r\nend;\r\n\r\nfunction TJclAnsiStrArrayIterator.Previous: AnsiString;\r\nbegin\r\n if Valid then\r\n Dec(FCursor)\r\n else\r\n Valid := True;\r\n Result := FOwnList.GetString(FCursor);\r\nend;\r\n\r\nfunction TJclAnsiStrArrayIterator.PreviousIndex: Integer;\r\nbegin\r\n if Valid then\r\n Result := FCursor - 1\r\n else\r\n Result := FCursor;\r\nend;\r\n\r\nprocedure TJclAnsiStrArrayIterator.Remove;\r\nbegin\r\n CheckValid;\r\n Valid := False;\r\n FOwnList.Delete(FCursor);\r\nend;\r\n\r\nprocedure TJclAnsiStrArrayIterator.Reset;\r\nbegin\r\n Valid := False;\r\n case FStart of\r\n isFirst:\r\n FCursor := 0;\r\n isLast:\r\n FCursor := FOwnList.Size - 1;\r\n end;\r\nend;\r\n\r\nprocedure TJclAnsiStrArrayIterator.SetString(const AString: AnsiString);\r\nbegin\r\n CheckValid;\r\n FOwnList.SetString(FCursor, AString);\r\nend;\r\n\r\n//=== { TJclWideStrArrayList } ======================================================\r\n\r\nconstructor TJclWideStrArrayList.Create(ACapacity: Integer);\r\nbegin\r\n inherited Create();\r\n SetCapacity(ACapacity);\r\nend;\r\n\r\nconstructor TJclWideStrArrayList.Create(const ACollection: IJclWideStrCollection);\r\nbegin\r\n inherited Create();\r\n if ACollection = nil then\r\n raise EJclNoCollectionError.Create;\r\n SetCapacity(ACollection.Size);\r\n AddAll(ACollection);\r\nend;\r\n\r\ndestructor TJclWideStrArrayList.Destroy;\r\nbegin\r\n FReadOnly := False;\r\n Clear;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJclWideStrArrayList.Add(const AString: WideString): Boolean;\r\nvar\r\n Index: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := FAllowDefaultElements or not ItemsEqual(AString, '');\r\n if Result then\r\n begin\r\n if FDuplicates <> dupAccept then\r\n for Index := 0 to FSize - 1 do\r\n if ItemsEqual(AString, FElementData[Index]) then\r\n begin\r\n Result := CheckDuplicate;\r\n Break;\r\n end;\r\n\r\n if Result then\r\n begin\r\n if FSize = FCapacity then\r\n AutoGrow;\r\n Result := FSize < FCapacity;\r\n if Result then\r\n begin\r\n FElementData[FSize] := AString;\r\n Inc(FSize);\r\n end;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclWideStrArrayList.AddAll(const ACollection: IJclWideStrCollection): Boolean;\r\nvar\r\n It: IJclWideStrIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n Result := Add(It.Next) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclWideStrArrayList.AssignDataTo(Dest: TJclAbstractContainerBase);\r\nvar\r\n ADest: TJclWideStrArrayList;\r\n ACollection: IJclWideStrCollection;\r\nbegin\r\n inherited AssignDataTo(Dest);\r\n if Dest is TJclWideStrArrayList then\r\n begin\r\n ADest := TJclWideStrArrayList(Dest);\r\n ADest.Clear;\r\n ADest.AddAll(Self);\r\n end\r\n else\r\n if Supports(IInterface(Dest), IJclWideStrCollection, ACollection) then\r\n begin\r\n ACollection.Clear;\r\n ACollection.AddAll(Self);\r\n end;\r\nend;\r\n\r\nprocedure TJclWideStrArrayList.Clear;\r\nvar\r\n I: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n for I := 0 to FSize - 1 do\r\n FreeString(FElementData[I]);\r\n FSize := 0;\r\n AutoPack;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclWideStrArrayList.CollectionEquals(const ACollection: IJclWideStrCollection): Boolean;\r\nvar\r\n I: Integer;\r\n It: IJclWideStrIterator;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n if FSize <> ACollection.Size then\r\n Exit;\r\n It := ACollection.First;\r\n for I := 0 to FSize - 1 do\r\n if not ItemsEqual(FElementData[I], It.Next) then\r\n Exit;\r\n Result := True;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclWideStrArrayList.Contains(const AString: WideString): Boolean;\r\nvar\r\n I: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n for I := 0 to FSize - 1 do\r\n if ItemsEqual(FElementData[I], AString) then\r\n begin\r\n Result := True;\r\n Break;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclWideStrArrayList.ContainsAll(const ACollection: IJclWideStrCollection): Boolean;\r\nvar\r\n It: IJclWideStrIterator;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := True;\r\n if ACollection = nil then\r\n Exit;\r\n It := ACollection.First;\r\n while Result and It.HasNext do\r\n Result := Contains(It.Next);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclWideStrArrayList.Delete(Index: Integer): WideString;\r\nvar\r\n Extracted: WideString;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Extracted := ExtractIndex(Index);\r\n Result := FreeString(Extracted);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclWideStrArrayList.Extract(const AString: WideString): Boolean;\r\nvar\r\n I: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n for I := FSize - 1 downto 0 do\r\n if ItemsEqual(FElementData[I], AString) then\r\n begin\r\n if I < (FSize - 1) then\r\n MoveArray(FElementData, I + 1, I, FSize - 1 - I)\r\n else\r\n FElementData[I] := '';\r\n Dec(FSize);\r\n Result := True;\r\n if FRemoveSingleElement then\r\n Break;\r\n end;\r\n AutoPack;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclWideStrArrayList.ExtractAll(const ACollection: IJclWideStrCollection): Boolean;\r\nvar\r\n It: IJclWideStrIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n Result := Extract(It.Next) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclWideStrArrayList.ExtractIndex(Index: Integer): WideString;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if (Index >= 0) and (Index < FSize) then\r\n begin\r\n Result := FElementData[Index];\r\n if Index < (FSize - 1) then\r\n MoveArray(FElementData, Index + 1, Index, FSize - 1 - Index)\r\n else\r\n FElementData[Index] := '';\r\n Dec(FSize);\r\n AutoPack;\r\n end\r\n else\r\n Result := RaiseOutOfBoundsError;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclWideStrArrayList.First: IJclWideStrIterator;\r\nbegin\r\n Result := TJclWideStrArrayIterator.Create(Self, 0, False, isFirst);\r\nend;\r\n\r\n{$IFDEF SUPPORTS_FOR_IN}\r\nfunction TJclWideStrArrayList.GetEnumerator: IJclWideStrIterator;\r\nbegin\r\n Result := TJclWideStrArrayIterator.Create(Self, 0, False, isFirst);\r\nend;\r\n{$ENDIF SUPPORTS_FOR_IN}\r\n\r\nfunction TJclWideStrArrayList.GetString(Index: Integer): WideString;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := '';\r\n if (Index >= 0) and (Index < FSize) then\r\n Result := FElementData[Index]\r\n else\r\n if not FReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create(IntToStr(Index));\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclWideStrArrayList.IndexOf(const AString: WideString): Integer;\r\nvar\r\n I: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := -1;\r\n for I := 0 to FSize - 1 do\r\n if ItemsEqual(FElementData[I], AString) then\r\n begin\r\n Result := I;\r\n Break;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclWideStrArrayList.Insert(Index: Integer; const AString: WideString): Boolean;\r\nvar\r\n I: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := FAllowDefaultElements or not ItemsEqual(AString, '');\r\n\r\n if (Index < 0) or (Index > FSize) then\r\n raise EJclOutOfBoundsError.Create;\r\n\r\n if Result then\r\n begin\r\n if FDuplicates <> dupAccept then\r\n for I := 0 to FSize - 1 do\r\n if ItemsEqual(AString, FElementData[I]) then\r\n begin\r\n Result := CheckDuplicate;\r\n Break;\r\n end;\r\n\r\n if Result then\r\n begin\r\n if FSize = FCapacity then\r\n AutoGrow;\r\n Result := FSize < FCapacity;\r\n if Result then\r\n begin\r\n if Index < FSize then\r\n MoveArray(FElementData, Index, Index + 1, FSize - Index);\r\n FElementData[Index] := AString;\r\n Inc(FSize);\r\n end;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclWideStrArrayList.InsertAll(Index: Integer; const ACollection: IJclWideStrCollection): Boolean;\r\nvar\r\n It: IJclWideStrIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if (Index < 0) or (Index > FSize) then\r\n raise EJclOutOfBoundsError.Create;\r\n if ACollection = nil then\r\n Exit;\r\n\r\n Result := True;\r\n It := ACollection.Last;\r\n while It.HasPrevious do\r\n Result := Insert(Index, It.Previous) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclWideStrArrayList.IsEmpty: Boolean;\r\nbegin\r\n Result := FSize = 0;\r\nend;\r\n\r\nfunction TJclWideStrArrayList.Last: IJclWideStrIterator;\r\nbegin\r\n Result := TJclWideStrArrayIterator.Create(Self, FSize - 1, False, isLast);\r\nend;\r\n\r\nfunction TJclWideStrArrayList.LastIndexOf(const AString: WideString): Integer;\r\nvar\r\n I: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := -1;\r\n for I := FSize - 1 downto 0 do\r\n if ItemsEqual(FElementData[I], AString) then\r\n begin\r\n Result := I;\r\n Break;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclWideStrArrayList.RaiseOutOfBoundsError: WideString;\r\nbegin\r\n raise EJclOutOfBoundsError.Create;\r\nend;\r\n\r\nfunction TJclWideStrArrayList.Remove(const AString: WideString): Boolean;\r\nvar\r\n Extracted: WideString;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := Extract(AString);\r\n if Result then\r\n begin\r\n Extracted := AString;\r\n FreeString(Extracted);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclWideStrArrayList.RemoveAll(const ACollection: IJclWideStrCollection): Boolean;\r\nvar\r\n It: IJclWideStrIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n Result := Remove(It.Next) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclWideStrArrayList.RetainAll(const ACollection: IJclWideStrCollection): Boolean;\r\nvar\r\n I: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n for I := FSize - 1 downto 0 do\r\n if not ACollection.Contains(FElementData[I]) then\r\n Delete(I);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclWideStrArrayList.SetCapacity(Value: Integer);\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Value >= FSize then\r\n begin\r\n SetLength(FElementData, Value);\r\n inherited SetCapacity(Value);\r\n end\r\n else\r\n raise EJclOutOfBoundsError.Create;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclWideStrArrayList.SetString(Index: Integer; const AString: WideString);\r\nvar\r\n ReplaceItem: Boolean;\r\n I: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if (Index < 0) or (Index >= FSize) then\r\n raise EJclOutOfBoundsError.Create;\r\n ReplaceItem := FAllowDefaultElements or not ItemsEqual(AString, '');\r\n if ReplaceItem then\r\n begin\r\n if FDuplicates <> dupAccept then\r\n for I := 0 to FSize - 1 do\r\n if ItemsEqual(FElementData[I], AString) then\r\n begin\r\n ReplaceItem := CheckDuplicate;\r\n Break;\r\n end;\r\n if ReplaceItem then\r\n begin\r\n FreeString(FElementData[Index]);\r\n FElementData[Index] := AString;\r\n end;\r\n end;\r\n if not ReplaceItem then\r\n Delete(Index);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclWideStrArrayList.Size: Integer;\r\nbegin\r\n Result := FSize;\r\nend;\r\n\r\nfunction TJclWideStrArrayList.SubList(First, Count: Integer): IJclWideStrList;\r\nvar\r\n I: Integer;\r\n Last: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Last := First + Count - 1;\r\n if Last >= FSize then\r\n Last := FSize - 1;\r\n Result := CreateEmptyContainer as IJclWideStrList;\r\n for I := First to Last do\r\n Result.Add(FElementData[I]);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclWideStrArrayList.CreateEmptyContainer: TJclAbstractContainerBase;\r\nbegin\r\n Result := TJclWideStrArrayList.Create(FSize);\r\n AssignPropertiesTo(Result);\r\nend;\r\n\r\n//=== { TJclWideStrArrayIterator } ===============================================================\r\n\r\nconstructor TJclWideStrArrayIterator.Create(AOwnList: TJclWideStrArrayList; ACursor: Integer; AValid: Boolean; AStart: TItrStart);\r\nbegin\r\n inherited Create(AValid);\r\n FOwnList := AOwnList;\r\n FStart := AStart;\r\n FCursor := ACursor;\r\nend;\r\n\r\nfunction TJclWideStrArrayIterator.Add(const AString: WideString): Boolean;\r\nbegin\r\n Result := FOwnList.Add(AString);\r\nend;\r\n\r\nprocedure TJclWideStrArrayIterator.AssignPropertiesTo(Dest: TJclAbstractIterator);\r\nvar\r\n ADest: TJclWideStrArrayIterator;\r\nbegin\r\n inherited AssignPropertiesTo(Dest);\r\n if Dest is TJclWideStrArrayIterator then\r\n begin\r\n ADest := TJclWideStrArrayIterator(Dest);\r\n ADest.FOwnList := FOwnList;\r\n ADest.FCursor := FCursor;\r\n ADest.FStart := FStart;\r\n end;\r\nend;\r\n\r\nfunction TJclWideStrArrayIterator.CreateEmptyIterator: TJclAbstractIterator;\r\nbegin\r\n Result := TJclWideStrArrayIterator.Create(FOwnList, FCursor, Valid, FStart);\r\nend;\r\n\r\nprocedure TJclWideStrArrayIterator.Extract;\r\nbegin\r\n CheckValid;\r\n Valid := False;\r\n FOwnList.ExtractIndex(FCursor);\r\nend;\r\n\r\nfunction TJclWideStrArrayIterator.GetString: WideString;\r\nbegin\r\n CheckValid;\r\n Result := FOwnList.GetString(FCursor);\r\nend;\r\n\r\nfunction TJclWideStrArrayIterator.HasNext: Boolean;\r\nbegin\r\n if Valid then\r\n Result := FCursor < (FOwnList.Size - 1)\r\n else\r\n Result := FCursor < FOwnList.Size;\r\nend;\r\n\r\nfunction TJclWideStrArrayIterator.HasPrevious: Boolean;\r\nbegin\r\n if Valid then\r\n Result := FCursor > 0\r\n else\r\n Result := FCursor >= 0;\r\nend;\r\n\r\nfunction TJclWideStrArrayIterator.Insert(const AString: WideString): Boolean;\r\nbegin\r\n CheckValid;\r\n Result := FOwnList.Insert(FCursor, AString);\r\nend;\r\n\r\nfunction TJclWideStrArrayIterator.IteratorEquals(const AIterator: IJclWideStrIterator): Boolean;\r\nvar\r\n Obj: TObject;\r\n ItrObj: TJclWideStrArrayIterator;\r\nbegin\r\n Result := False;\r\n if AIterator = nil then\r\n Exit;\r\n Obj := AIterator.GetIteratorReference;\r\n if Obj is TJclWideStrArrayIterator then\r\n begin\r\n ItrObj := TJclWideStrArrayIterator(Obj);\r\n Result := (FOwnList = ItrObj.FOwnList) and (FCursor = ItrObj.FCursor) and (Valid = ItrObj.Valid);\r\n end;\r\nend;\r\n\r\n{$IFDEF SUPPORTS_FOR_IN}\r\nfunction TJclWideStrArrayIterator.MoveNext: Boolean;\r\nbegin\r\n if Valid then\r\n Inc(FCursor)\r\n else\r\n Valid := True;\r\n Result := FCursor < FOwnList.Size;\r\nend;\r\n{$ENDIF SUPPORTS_FOR_IN}\r\n\r\nfunction TJclWideStrArrayIterator.Next: WideString;\r\nbegin\r\n if Valid then\r\n Inc(FCursor)\r\n else\r\n Valid := True;\r\n Result := FOwnList.GetString(FCursor);\r\nend;\r\n\r\nfunction TJclWideStrArrayIterator.NextIndex: Integer;\r\nbegin\r\n if Valid then\r\n Result := FCursor + 1\r\n else\r\n Result := FCursor;\r\nend;\r\n\r\nfunction TJclWideStrArrayIterator.Previous: WideString;\r\nbegin\r\n if Valid then\r\n Dec(FCursor)\r\n else\r\n Valid := True;\r\n Result := FOwnList.GetString(FCursor);\r\nend;\r\n\r\nfunction TJclWideStrArrayIterator.PreviousIndex: Integer;\r\nbegin\r\n if Valid then\r\n Result := FCursor - 1\r\n else\r\n Result := FCursor;\r\nend;\r\n\r\nprocedure TJclWideStrArrayIterator.Remove;\r\nbegin\r\n CheckValid;\r\n Valid := False;\r\n FOwnList.Delete(FCursor);\r\nend;\r\n\r\nprocedure TJclWideStrArrayIterator.Reset;\r\nbegin\r\n Valid := False;\r\n case FStart of\r\n isFirst:\r\n FCursor := 0;\r\n isLast:\r\n FCursor := FOwnList.Size - 1;\r\n end;\r\nend;\r\n\r\nprocedure TJclWideStrArrayIterator.SetString(const AString: WideString);\r\nbegin\r\n CheckValid;\r\n FOwnList.SetString(FCursor, AString);\r\nend;\r\n\r\n{$IFDEF SUPPORTS_UNICODE_STRING}\r\n//=== { TJclUnicodeStrArrayList } ======================================================\r\n\r\nconstructor TJclUnicodeStrArrayList.Create(ACapacity: Integer);\r\nbegin\r\n inherited Create();\r\n SetCapacity(ACapacity);\r\nend;\r\n\r\nconstructor TJclUnicodeStrArrayList.Create(const ACollection: IJclUnicodeStrCollection);\r\nbegin\r\n inherited Create();\r\n if ACollection = nil then\r\n raise EJclNoCollectionError.Create;\r\n SetCapacity(ACollection.Size);\r\n AddAll(ACollection);\r\nend;\r\n\r\ndestructor TJclUnicodeStrArrayList.Destroy;\r\nbegin\r\n FReadOnly := False;\r\n Clear;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJclUnicodeStrArrayList.Add(const AString: UnicodeString): Boolean;\r\nvar\r\n Index: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := FAllowDefaultElements or not ItemsEqual(AString, '');\r\n if Result then\r\n begin\r\n if FDuplicates <> dupAccept then\r\n for Index := 0 to FSize - 1 do\r\n if ItemsEqual(AString, FElementData[Index]) then\r\n begin\r\n Result := CheckDuplicate;\r\n Break;\r\n end;\r\n\r\n if Result then\r\n begin\r\n if FSize = FCapacity then\r\n AutoGrow;\r\n Result := FSize < FCapacity;\r\n if Result then\r\n begin\r\n FElementData[FSize] := AString;\r\n Inc(FSize);\r\n end;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclUnicodeStrArrayList.AddAll(const ACollection: IJclUnicodeStrCollection): Boolean;\r\nvar\r\n It: IJclUnicodeStrIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n Result := Add(It.Next) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclUnicodeStrArrayList.AssignDataTo(Dest: TJclAbstractContainerBase);\r\nvar\r\n ADest: TJclUnicodeStrArrayList;\r\n ACollection: IJclUnicodeStrCollection;\r\nbegin\r\n inherited AssignDataTo(Dest);\r\n if Dest is TJclUnicodeStrArrayList then\r\n begin\r\n ADest := TJclUnicodeStrArrayList(Dest);\r\n ADest.Clear;\r\n ADest.AddAll(Self);\r\n end\r\n else\r\n if Supports(IInterface(Dest), IJclUnicodeStrCollection, ACollection) then\r\n begin\r\n ACollection.Clear;\r\n ACollection.AddAll(Self);\r\n end;\r\nend;\r\n\r\nprocedure TJclUnicodeStrArrayList.Clear;\r\nvar\r\n I: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n for I := 0 to FSize - 1 do\r\n FreeString(FElementData[I]);\r\n FSize := 0;\r\n AutoPack;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclUnicodeStrArrayList.CollectionEquals(const ACollection: IJclUnicodeStrCollection): Boolean;\r\nvar\r\n I: Integer;\r\n It: IJclUnicodeStrIterator;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n if FSize <> ACollection.Size then\r\n Exit;\r\n It := ACollection.First;\r\n for I := 0 to FSize - 1 do\r\n if not ItemsEqual(FElementData[I], It.Next) then\r\n Exit;\r\n Result := True;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclUnicodeStrArrayList.Contains(const AString: UnicodeString): Boolean;\r\nvar\r\n I: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n for I := 0 to FSize - 1 do\r\n if ItemsEqual(FElementData[I], AString) then\r\n begin\r\n Result := True;\r\n Break;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclUnicodeStrArrayList.ContainsAll(const ACollection: IJclUnicodeStrCollection): Boolean;\r\nvar\r\n It: IJclUnicodeStrIterator;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := True;\r\n if ACollection = nil then\r\n Exit;\r\n It := ACollection.First;\r\n while Result and It.HasNext do\r\n Result := Contains(It.Next);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclUnicodeStrArrayList.Delete(Index: Integer): UnicodeString;\r\nvar\r\n Extracted: UnicodeString;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Extracted := ExtractIndex(Index);\r\n Result := FreeString(Extracted);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclUnicodeStrArrayList.Extract(const AString: UnicodeString): Boolean;\r\nvar\r\n I: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n for I := FSize - 1 downto 0 do\r\n if ItemsEqual(FElementData[I], AString) then\r\n begin\r\n if I < (FSize - 1) then\r\n MoveArray(FElementData, I + 1, I, FSize - 1 - I)\r\n else\r\n FElementData[I] := '';\r\n Dec(FSize);\r\n Result := True;\r\n if FRemoveSingleElement then\r\n Break;\r\n end;\r\n AutoPack;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclUnicodeStrArrayList.ExtractAll(const ACollection: IJclUnicodeStrCollection): Boolean;\r\nvar\r\n It: IJclUnicodeStrIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n Result := Extract(It.Next) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclUnicodeStrArrayList.ExtractIndex(Index: Integer): UnicodeString;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if (Index >= 0) and (Index < FSize) then\r\n begin\r\n Result := FElementData[Index];\r\n if Index < (FSize - 1) then\r\n MoveArray(FElementData, Index + 1, Index, FSize - 1 - Index)\r\n else\r\n FElementData[Index] := '';\r\n Dec(FSize);\r\n AutoPack;\r\n end\r\n else\r\n Result := RaiseOutOfBoundsError;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclUnicodeStrArrayList.First: IJclUnicodeStrIterator;\r\nbegin\r\n Result := TJclUnicodeStrArrayIterator.Create(Self, 0, False, isFirst);\r\nend;\r\n\r\n{$IFDEF SUPPORTS_FOR_IN}\r\nfunction TJclUnicodeStrArrayList.GetEnumerator: IJclUnicodeStrIterator;\r\nbegin\r\n Result := TJclUnicodeStrArrayIterator.Create(Self, 0, False, isFirst);\r\nend;\r\n{$ENDIF SUPPORTS_FOR_IN}\r\n\r\nfunction TJclUnicodeStrArrayList.GetString(Index: Integer): UnicodeString;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := '';\r\n if (Index >= 0) and (Index < FSize) then\r\n Result := FElementData[Index]\r\n else\r\n if not FReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create(IntToStr(Index));\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclUnicodeStrArrayList.IndexOf(const AString: UnicodeString): Integer;\r\nvar\r\n I: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := -1;\r\n for I := 0 to FSize - 1 do\r\n if ItemsEqual(FElementData[I], AString) then\r\n begin\r\n Result := I;\r\n Break;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclUnicodeStrArrayList.Insert(Index: Integer; const AString: UnicodeString): Boolean;\r\nvar\r\n I: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := FAllowDefaultElements or not ItemsEqual(AString, '');\r\n\r\n if (Index < 0) or (Index > FSize) then\r\n raise EJclOutOfBoundsError.Create;\r\n\r\n if Result then\r\n begin\r\n if FDuplicates <> dupAccept then\r\n for I := 0 to FSize - 1 do\r\n if ItemsEqual(AString, FElementData[I]) then\r\n begin\r\n Result := CheckDuplicate;\r\n Break;\r\n end;\r\n\r\n if Result then\r\n begin\r\n if FSize = FCapacity then\r\n AutoGrow;\r\n Result := FSize < FCapacity;\r\n if Result then\r\n begin\r\n if Index < FSize then\r\n MoveArray(FElementData, Index, Index + 1, FSize - Index);\r\n FElementData[Index] := AString;\r\n Inc(FSize);\r\n end;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclUnicodeStrArrayList.InsertAll(Index: Integer; const ACollection: IJclUnicodeStrCollection): Boolean;\r\nvar\r\n It: IJclUnicodeStrIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if (Index < 0) or (Index > FSize) then\r\n raise EJclOutOfBoundsError.Create;\r\n if ACollection = nil then\r\n Exit;\r\n\r\n Result := True;\r\n It := ACollection.Last;\r\n while It.HasPrevious do\r\n Result := Insert(Index, It.Previous) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclUnicodeStrArrayList.IsEmpty: Boolean;\r\nbegin\r\n Result := FSize = 0;\r\nend;\r\n\r\nfunction TJclUnicodeStrArrayList.Last: IJclUnicodeStrIterator;\r\nbegin\r\n Result := TJclUnicodeStrArrayIterator.Create(Self, FSize - 1, False, isLast);\r\nend;\r\n\r\nfunction TJclUnicodeStrArrayList.LastIndexOf(const AString: UnicodeString): Integer;\r\nvar\r\n I: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := -1;\r\n for I := FSize - 1 downto 0 do\r\n if ItemsEqual(FElementData[I], AString) then\r\n begin\r\n Result := I;\r\n Break;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclUnicodeStrArrayList.RaiseOutOfBoundsError: UnicodeString;\r\nbegin\r\n raise EJclOutOfBoundsError.Create;\r\nend;\r\n\r\nfunction TJclUnicodeStrArrayList.Remove(const AString: UnicodeString): Boolean;\r\nvar\r\n Extracted: UnicodeString;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := Extract(AString);\r\n if Result then\r\n begin\r\n Extracted := AString;\r\n FreeString(Extracted);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclUnicodeStrArrayList.RemoveAll(const ACollection: IJclUnicodeStrCollection): Boolean;\r\nvar\r\n It: IJclUnicodeStrIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n Result := Remove(It.Next) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclUnicodeStrArrayList.RetainAll(const ACollection: IJclUnicodeStrCollection): Boolean;\r\nvar\r\n I: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n for I := FSize - 1 downto 0 do\r\n if not ACollection.Contains(FElementData[I]) then\r\n Delete(I);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclUnicodeStrArrayList.SetCapacity(Value: Integer);\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Value >= FSize then\r\n begin\r\n SetLength(FElementData, Value);\r\n inherited SetCapacity(Value);\r\n end\r\n else\r\n raise EJclOutOfBoundsError.Create;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclUnicodeStrArrayList.SetString(Index: Integer; const AString: UnicodeString);\r\nvar\r\n ReplaceItem: Boolean;\r\n I: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if (Index < 0) or (Index >= FSize) then\r\n raise EJclOutOfBoundsError.Create;\r\n ReplaceItem := FAllowDefaultElements or not ItemsEqual(AString, '');\r\n if ReplaceItem then\r\n begin\r\n if FDuplicates <> dupAccept then\r\n for I := 0 to FSize - 1 do\r\n if ItemsEqual(FElementData[I], AString) then\r\n begin\r\n ReplaceItem := CheckDuplicate;\r\n Break;\r\n end;\r\n if ReplaceItem then\r\n begin\r\n FreeString(FElementData[Index]);\r\n FElementData[Index] := AString;\r\n end;\r\n end;\r\n if not ReplaceItem then\r\n Delete(Index);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclUnicodeStrArrayList.Size: Integer;\r\nbegin\r\n Result := FSize;\r\nend;\r\n\r\nfunction TJclUnicodeStrArrayList.SubList(First, Count: Integer): IJclUnicodeStrList;\r\nvar\r\n I: Integer;\r\n Last: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Last := First + Count - 1;\r\n if Last >= FSize then\r\n Last := FSize - 1;\r\n Result := CreateEmptyContainer as IJclUnicodeStrList;\r\n for I := First to Last do\r\n Result.Add(FElementData[I]);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclUnicodeStrArrayList.CreateEmptyContainer: TJclAbstractContainerBase;\r\nbegin\r\n Result := TJclUnicodeStrArrayList.Create(FSize);\r\n AssignPropertiesTo(Result);\r\nend;\r\n\r\n{$ENDIF SUPPORTS_UNICODE_STRING}\r\n\r\n{$IFDEF SUPPORTS_UNICODE_STRING}\r\n//=== { TJclUnicodeStrArrayIterator } ===============================================================\r\n\r\nconstructor TJclUnicodeStrArrayIterator.Create(AOwnList: TJclUnicodeStrArrayList; ACursor: Integer; AValid: Boolean; AStart: TItrStart);\r\nbegin\r\n inherited Create(AValid);\r\n FOwnList := AOwnList;\r\n FStart := AStart;\r\n FCursor := ACursor;\r\nend;\r\n\r\nfunction TJclUnicodeStrArrayIterator.Add(const AString: UnicodeString): Boolean;\r\nbegin\r\n Result := FOwnList.Add(AString);\r\nend;\r\n\r\nprocedure TJclUnicodeStrArrayIterator.AssignPropertiesTo(Dest: TJclAbstractIterator);\r\nvar\r\n ADest: TJclUnicodeStrArrayIterator;\r\nbegin\r\n inherited AssignPropertiesTo(Dest);\r\n if Dest is TJclUnicodeStrArrayIterator then\r\n begin\r\n ADest := TJclUnicodeStrArrayIterator(Dest);\r\n ADest.FOwnList := FOwnList;\r\n ADest.FCursor := FCursor;\r\n ADest.FStart := FStart;\r\n end;\r\nend;\r\n\r\nfunction TJclUnicodeStrArrayIterator.CreateEmptyIterator: TJclAbstractIterator;\r\nbegin\r\n Result := TJclUnicodeStrArrayIterator.Create(FOwnList, FCursor, Valid, FStart);\r\nend;\r\n\r\nprocedure TJclUnicodeStrArrayIterator.Extract;\r\nbegin\r\n CheckValid;\r\n Valid := False;\r\n FOwnList.ExtractIndex(FCursor);\r\nend;\r\n\r\nfunction TJclUnicodeStrArrayIterator.GetString: UnicodeString;\r\nbegin\r\n CheckValid;\r\n Result := FOwnList.GetString(FCursor);\r\nend;\r\n\r\nfunction TJclUnicodeStrArrayIterator.HasNext: Boolean;\r\nbegin\r\n if Valid then\r\n Result := FCursor < (FOwnList.Size - 1)\r\n else\r\n Result := FCursor < FOwnList.Size;\r\nend;\r\n\r\nfunction TJclUnicodeStrArrayIterator.HasPrevious: Boolean;\r\nbegin\r\n if Valid then\r\n Result := FCursor > 0\r\n else\r\n Result := FCursor >= 0;\r\nend;\r\n\r\nfunction TJclUnicodeStrArrayIterator.Insert(const AString: UnicodeString): Boolean;\r\nbegin\r\n CheckValid;\r\n Result := FOwnList.Insert(FCursor, AString);\r\nend;\r\n\r\nfunction TJclUnicodeStrArrayIterator.IteratorEquals(const AIterator: IJclUnicodeStrIterator): Boolean;\r\nvar\r\n Obj: TObject;\r\n ItrObj: TJclUnicodeStrArrayIterator;\r\nbegin\r\n Result := False;\r\n if AIterator = nil then\r\n Exit;\r\n Obj := AIterator.GetIteratorReference;\r\n if Obj is TJclUnicodeStrArrayIterator then\r\n begin\r\n ItrObj := TJclUnicodeStrArrayIterator(Obj);\r\n Result := (FOwnList = ItrObj.FOwnList) and (FCursor = ItrObj.FCursor) and (Valid = ItrObj.Valid);\r\n end;\r\nend;\r\n\r\n{$IFDEF SUPPORTS_FOR_IN}\r\nfunction TJclUnicodeStrArrayIterator.MoveNext: Boolean;\r\nbegin\r\n if Valid then\r\n Inc(FCursor)\r\n else\r\n Valid := True;\r\n Result := FCursor < FOwnList.Size;\r\nend;\r\n{$ENDIF SUPPORTS_FOR_IN}\r\n\r\nfunction TJclUnicodeStrArrayIterator.Next: UnicodeString;\r\nbegin\r\n if Valid then\r\n Inc(FCursor)\r\n else\r\n Valid := True;\r\n Result := FOwnList.GetString(FCursor);\r\nend;\r\n\r\nfunction TJclUnicodeStrArrayIterator.NextIndex: Integer;\r\nbegin\r\n if Valid then\r\n Result := FCursor + 1\r\n else\r\n Result := FCursor;\r\nend;\r\n\r\nfunction TJclUnicodeStrArrayIterator.Previous: UnicodeString;\r\nbegin\r\n if Valid then\r\n Dec(FCursor)\r\n else\r\n Valid := True;\r\n Result := FOwnList.GetString(FCursor);\r\nend;\r\n\r\nfunction TJclUnicodeStrArrayIterator.PreviousIndex: Integer;\r\nbegin\r\n if Valid then\r\n Result := FCursor - 1\r\n else\r\n Result := FCursor;\r\nend;\r\n\r\nprocedure TJclUnicodeStrArrayIterator.Remove;\r\nbegin\r\n CheckValid;\r\n Valid := False;\r\n FOwnList.Delete(FCursor);\r\nend;\r\n\r\nprocedure TJclUnicodeStrArrayIterator.Reset;\r\nbegin\r\n Valid := False;\r\n case FStart of\r\n isFirst:\r\n FCursor := 0;\r\n isLast:\r\n FCursor := FOwnList.Size - 1;\r\n end;\r\nend;\r\n\r\nprocedure TJclUnicodeStrArrayIterator.SetString(const AString: UnicodeString);\r\nbegin\r\n CheckValid;\r\n FOwnList.SetString(FCursor, AString);\r\nend;\r\n{$ENDIF SUPPORTS_UNICODE_STRING}\r\n\r\n//=== { TJclSingleArrayList } ======================================================\r\n\r\nconstructor TJclSingleArrayList.Create(ACapacity: Integer);\r\nbegin\r\n inherited Create();\r\n SetCapacity(ACapacity);\r\nend;\r\n\r\nconstructor TJclSingleArrayList.Create(const ACollection: IJclSingleCollection);\r\nbegin\r\n inherited Create();\r\n if ACollection = nil then\r\n raise EJclNoCollectionError.Create;\r\n SetCapacity(ACollection.Size);\r\n AddAll(ACollection);\r\nend;\r\n\r\ndestructor TJclSingleArrayList.Destroy;\r\nbegin\r\n FReadOnly := False;\r\n Clear;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJclSingleArrayList.Add(const AValue: Single): Boolean;\r\nvar\r\n Index: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := FAllowDefaultElements or not ItemsEqual(AValue, 0.0);\r\n if Result then\r\n begin\r\n if FDuplicates <> dupAccept then\r\n for Index := 0 to FSize - 1 do\r\n if ItemsEqual(AValue, FElementData[Index]) then\r\n begin\r\n Result := CheckDuplicate;\r\n Break;\r\n end;\r\n\r\n if Result then\r\n begin\r\n if FSize = FCapacity then\r\n AutoGrow;\r\n Result := FSize < FCapacity;\r\n if Result then\r\n begin\r\n FElementData[FSize] := AValue;\r\n Inc(FSize);\r\n end;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSingleArrayList.AddAll(const ACollection: IJclSingleCollection): Boolean;\r\nvar\r\n It: IJclSingleIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n Result := Add(It.Next) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclSingleArrayList.AssignDataTo(Dest: TJclAbstractContainerBase);\r\nvar\r\n ADest: TJclSingleArrayList;\r\n ACollection: IJclSingleCollection;\r\nbegin\r\n inherited AssignDataTo(Dest);\r\n if Dest is TJclSingleArrayList then\r\n begin\r\n ADest := TJclSingleArrayList(Dest);\r\n ADest.Clear;\r\n ADest.AddAll(Self);\r\n end\r\n else\r\n if Supports(IInterface(Dest), IJclSingleCollection, ACollection) then\r\n begin\r\n ACollection.Clear;\r\n ACollection.AddAll(Self);\r\n end;\r\nend;\r\n\r\nprocedure TJclSingleArrayList.Clear;\r\nvar\r\n I: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n for I := 0 to FSize - 1 do\r\n FreeSingle(FElementData[I]);\r\n FSize := 0;\r\n AutoPack;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSingleArrayList.CollectionEquals(const ACollection: IJclSingleCollection): Boolean;\r\nvar\r\n I: Integer;\r\n It: IJclSingleIterator;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n if FSize <> ACollection.Size then\r\n Exit;\r\n It := ACollection.First;\r\n for I := 0 to FSize - 1 do\r\n if not ItemsEqual(FElementData[I], It.Next) then\r\n Exit;\r\n Result := True;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSingleArrayList.Contains(const AValue: Single): Boolean;\r\nvar\r\n I: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n for I := 0 to FSize - 1 do\r\n if ItemsEqual(FElementData[I], AValue) then\r\n begin\r\n Result := True;\r\n Break;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSingleArrayList.ContainsAll(const ACollection: IJclSingleCollection): Boolean;\r\nvar\r\n It: IJclSingleIterator;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := True;\r\n if ACollection = nil then\r\n Exit;\r\n It := ACollection.First;\r\n while Result and It.HasNext do\r\n Result := Contains(It.Next);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSingleArrayList.Delete(Index: Integer): Single;\r\nvar\r\n Extracted: Single;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Extracted := ExtractIndex(Index);\r\n Result := FreeSingle(Extracted);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSingleArrayList.Extract(const AValue: Single): Boolean;\r\nvar\r\n I: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n for I := FSize - 1 downto 0 do\r\n if ItemsEqual(FElementData[I], AValue) then\r\n begin\r\n if I < (FSize - 1) then\r\n MoveArray(FElementData, I + 1, I, FSize - 1 - I)\r\n else\r\n FElementData[I] := 0.0;\r\n Dec(FSize);\r\n Result := True;\r\n if FRemoveSingleElement then\r\n Break;\r\n end;\r\n AutoPack;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSingleArrayList.ExtractAll(const ACollection: IJclSingleCollection): Boolean;\r\nvar\r\n It: IJclSingleIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n Result := Extract(It.Next) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSingleArrayList.ExtractIndex(Index: Integer): Single;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if (Index >= 0) and (Index < FSize) then\r\n begin\r\n Result := FElementData[Index];\r\n if Index < (FSize - 1) then\r\n MoveArray(FElementData, Index + 1, Index, FSize - 1 - Index)\r\n else\r\n FElementData[Index] := 0.0;\r\n Dec(FSize);\r\n AutoPack;\r\n end\r\n else\r\n Result := RaiseOutOfBoundsError;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSingleArrayList.First: IJclSingleIterator;\r\nbegin\r\n Result := TJclSingleArrayIterator.Create(Self, 0, False, isFirst);\r\nend;\r\n\r\n{$IFDEF SUPPORTS_FOR_IN}\r\nfunction TJclSingleArrayList.GetEnumerator: IJclSingleIterator;\r\nbegin\r\n Result := TJclSingleArrayIterator.Create(Self, 0, False, isFirst);\r\nend;\r\n{$ENDIF SUPPORTS_FOR_IN}\r\n\r\nfunction TJclSingleArrayList.GetValue(Index: Integer): Single;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := 0.0;\r\n if (Index >= 0) and (Index < FSize) then\r\n Result := FElementData[Index]\r\n else\r\n if not FReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create(IntToStr(Index));\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSingleArrayList.IndexOf(const AValue: Single): Integer;\r\nvar\r\n I: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := -1;\r\n for I := 0 to FSize - 1 do\r\n if ItemsEqual(FElementData[I], AValue) then\r\n begin\r\n Result := I;\r\n Break;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSingleArrayList.Insert(Index: Integer; const AValue: Single): Boolean;\r\nvar\r\n I: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := FAllowDefaultElements or not ItemsEqual(AValue, 0.0);\r\n\r\n if (Index < 0) or (Index > FSize) then\r\n raise EJclOutOfBoundsError.Create;\r\n\r\n if Result then\r\n begin\r\n if FDuplicates <> dupAccept then\r\n for I := 0 to FSize - 1 do\r\n if ItemsEqual(AValue, FElementData[I]) then\r\n begin\r\n Result := CheckDuplicate;\r\n Break;\r\n end;\r\n\r\n if Result then\r\n begin\r\n if FSize = FCapacity then\r\n AutoGrow;\r\n Result := FSize < FCapacity;\r\n if Result then\r\n begin\r\n if Index < FSize then\r\n MoveArray(FElementData, Index, Index + 1, FSize - Index);\r\n FElementData[Index] := AValue;\r\n Inc(FSize);\r\n end;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSingleArrayList.InsertAll(Index: Integer; const ACollection: IJclSingleCollection): Boolean;\r\nvar\r\n It: IJclSingleIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if (Index < 0) or (Index > FSize) then\r\n raise EJclOutOfBoundsError.Create;\r\n if ACollection = nil then\r\n Exit;\r\n\r\n Result := True;\r\n It := ACollection.Last;\r\n while It.HasPrevious do\r\n Result := Insert(Index, It.Previous) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSingleArrayList.IsEmpty: Boolean;\r\nbegin\r\n Result := FSize = 0;\r\nend;\r\n\r\nfunction TJclSingleArrayList.Last: IJclSingleIterator;\r\nbegin\r\n Result := TJclSingleArrayIterator.Create(Self, FSize - 1, False, isLast);\r\nend;\r\n\r\nfunction TJclSingleArrayList.LastIndexOf(const AValue: Single): Integer;\r\nvar\r\n I: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := -1;\r\n for I := FSize - 1 downto 0 do\r\n if ItemsEqual(FElementData[I], AValue) then\r\n begin\r\n Result := I;\r\n Break;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSingleArrayList.RaiseOutOfBoundsError: Single;\r\nbegin\r\n raise EJclOutOfBoundsError.Create;\r\nend;\r\n\r\nfunction TJclSingleArrayList.Remove(const AValue: Single): Boolean;\r\nvar\r\n Extracted: Single;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := Extract(AValue);\r\n if Result then\r\n begin\r\n Extracted := AValue;\r\n FreeSingle(Extracted);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSingleArrayList.RemoveAll(const ACollection: IJclSingleCollection): Boolean;\r\nvar\r\n It: IJclSingleIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n Result := Remove(It.Next) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSingleArrayList.RetainAll(const ACollection: IJclSingleCollection): Boolean;\r\nvar\r\n I: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n for I := FSize - 1 downto 0 do\r\n if not ACollection.Contains(FElementData[I]) then\r\n Delete(I);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclSingleArrayList.SetCapacity(Value: Integer);\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Value >= FSize then\r\n begin\r\n SetLength(FElementData, Value);\r\n inherited SetCapacity(Value);\r\n end\r\n else\r\n raise EJclOutOfBoundsError.Create;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclSingleArrayList.SetValue(Index: Integer; const AValue: Single);\r\nvar\r\n ReplaceItem: Boolean;\r\n I: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if (Index < 0) or (Index >= FSize) then\r\n raise EJclOutOfBoundsError.Create;\r\n ReplaceItem := FAllowDefaultElements or not ItemsEqual(AValue, 0.0);\r\n if ReplaceItem then\r\n begin\r\n if FDuplicates <> dupAccept then\r\n for I := 0 to FSize - 1 do\r\n if ItemsEqual(FElementData[I], AValue) then\r\n begin\r\n ReplaceItem := CheckDuplicate;\r\n Break;\r\n end;\r\n if ReplaceItem then\r\n begin\r\n FreeSingle(FElementData[Index]);\r\n FElementData[Index] := AValue;\r\n end;\r\n end;\r\n if not ReplaceItem then\r\n Delete(Index);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSingleArrayList.Size: Integer;\r\nbegin\r\n Result := FSize;\r\nend;\r\n\r\nfunction TJclSingleArrayList.SubList(First, Count: Integer): IJclSingleList;\r\nvar\r\n I: Integer;\r\n Last: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Last := First + Count - 1;\r\n if Last >= FSize then\r\n Last := FSize - 1;\r\n Result := CreateEmptyContainer as IJclSingleList;\r\n for I := First to Last do\r\n Result.Add(FElementData[I]);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSingleArrayList.CreateEmptyContainer: TJclAbstractContainerBase;\r\nbegin\r\n Result := TJclSingleArrayList.Create(FSize);\r\n AssignPropertiesTo(Result);\r\nend;\r\n\r\n//=== { TJclSingleArrayIterator } ===============================================================\r\n\r\nconstructor TJclSingleArrayIterator.Create(AOwnList: TJclSingleArrayList; ACursor: Integer; AValid: Boolean; AStart: TItrStart);\r\nbegin\r\n inherited Create(AValid);\r\n FOwnList := AOwnList;\r\n FStart := AStart;\r\n FCursor := ACursor;\r\nend;\r\n\r\nfunction TJclSingleArrayIterator.Add(const AValue: Single): Boolean;\r\nbegin\r\n Result := FOwnList.Add(AValue);\r\nend;\r\n\r\nprocedure TJclSingleArrayIterator.AssignPropertiesTo(Dest: TJclAbstractIterator);\r\nvar\r\n ADest: TJclSingleArrayIterator;\r\nbegin\r\n inherited AssignPropertiesTo(Dest);\r\n if Dest is TJclSingleArrayIterator then\r\n begin\r\n ADest := TJclSingleArrayIterator(Dest);\r\n ADest.FOwnList := FOwnList;\r\n ADest.FCursor := FCursor;\r\n ADest.FStart := FStart;\r\n end;\r\nend;\r\n\r\nfunction TJclSingleArrayIterator.CreateEmptyIterator: TJclAbstractIterator;\r\nbegin\r\n Result := TJclSingleArrayIterator.Create(FOwnList, FCursor, Valid, FStart);\r\nend;\r\n\r\nprocedure TJclSingleArrayIterator.Extract;\r\nbegin\r\n CheckValid;\r\n Valid := False;\r\n FOwnList.ExtractIndex(FCursor);\r\nend;\r\n\r\nfunction TJclSingleArrayIterator.GetValue: Single;\r\nbegin\r\n CheckValid;\r\n Result := FOwnList.GetValue(FCursor);\r\nend;\r\n\r\nfunction TJclSingleArrayIterator.HasNext: Boolean;\r\nbegin\r\n if Valid then\r\n Result := FCursor < (FOwnList.Size - 1)\r\n else\r\n Result := FCursor < FOwnList.Size;\r\nend;\r\n\r\nfunction TJclSingleArrayIterator.HasPrevious: Boolean;\r\nbegin\r\n if Valid then\r\n Result := FCursor > 0\r\n else\r\n Result := FCursor >= 0;\r\nend;\r\n\r\nfunction TJclSingleArrayIterator.Insert(const AValue: Single): Boolean;\r\nbegin\r\n CheckValid;\r\n Result := FOwnList.Insert(FCursor, AValue);\r\nend;\r\n\r\nfunction TJclSingleArrayIterator.IteratorEquals(const AIterator: IJclSingleIterator): Boolean;\r\nvar\r\n Obj: TObject;\r\n ItrObj: TJclSingleArrayIterator;\r\nbegin\r\n Result := False;\r\n if AIterator = nil then\r\n Exit;\r\n Obj := AIterator.GetIteratorReference;\r\n if Obj is TJclSingleArrayIterator then\r\n begin\r\n ItrObj := TJclSingleArrayIterator(Obj);\r\n Result := (FOwnList = ItrObj.FOwnList) and (FCursor = ItrObj.FCursor) and (Valid = ItrObj.Valid);\r\n end;\r\nend;\r\n\r\n{$IFDEF SUPPORTS_FOR_IN}\r\nfunction TJclSingleArrayIterator.MoveNext: Boolean;\r\nbegin\r\n if Valid then\r\n Inc(FCursor)\r\n else\r\n Valid := True;\r\n Result := FCursor < FOwnList.Size;\r\nend;\r\n{$ENDIF SUPPORTS_FOR_IN}\r\n\r\nfunction TJclSingleArrayIterator.Next: Single;\r\nbegin\r\n if Valid then\r\n Inc(FCursor)\r\n else\r\n Valid := True;\r\n Result := FOwnList.GetValue(FCursor);\r\nend;\r\n\r\nfunction TJclSingleArrayIterator.NextIndex: Integer;\r\nbegin\r\n if Valid then\r\n Result := FCursor + 1\r\n else\r\n Result := FCursor;\r\nend;\r\n\r\nfunction TJclSingleArrayIterator.Previous: Single;\r\nbegin\r\n if Valid then\r\n Dec(FCursor)\r\n else\r\n Valid := True;\r\n Result := FOwnList.GetValue(FCursor);\r\nend;\r\n\r\nfunction TJclSingleArrayIterator.PreviousIndex: Integer;\r\nbegin\r\n if Valid then\r\n Result := FCursor - 1\r\n else\r\n Result := FCursor;\r\nend;\r\n\r\nprocedure TJclSingleArrayIterator.Remove;\r\nbegin\r\n CheckValid;\r\n Valid := False;\r\n FOwnList.Delete(FCursor);\r\nend;\r\n\r\nprocedure TJclSingleArrayIterator.Reset;\r\nbegin\r\n Valid := False;\r\n case FStart of\r\n isFirst:\r\n FCursor := 0;\r\n isLast:\r\n FCursor := FOwnList.Size - 1;\r\n end;\r\nend;\r\n\r\nprocedure TJclSingleArrayIterator.SetValue(const AValue: Single);\r\nbegin\r\n CheckValid;\r\n FOwnList.SetValue(FCursor, AValue);\r\nend;\r\n\r\n//=== { TJclDoubleArrayList } ======================================================\r\n\r\nconstructor TJclDoubleArrayList.Create(ACapacity: Integer);\r\nbegin\r\n inherited Create();\r\n SetCapacity(ACapacity);\r\nend;\r\n\r\nconstructor TJclDoubleArrayList.Create(const ACollection: IJclDoubleCollection);\r\nbegin\r\n inherited Create();\r\n if ACollection = nil then\r\n raise EJclNoCollectionError.Create;\r\n SetCapacity(ACollection.Size);\r\n AddAll(ACollection);\r\nend;\r\n\r\ndestructor TJclDoubleArrayList.Destroy;\r\nbegin\r\n FReadOnly := False;\r\n Clear;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJclDoubleArrayList.Add(const AValue: Double): Boolean;\r\nvar\r\n Index: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := FAllowDefaultElements or not ItemsEqual(AValue, 0.0);\r\n if Result then\r\n begin\r\n if FDuplicates <> dupAccept then\r\n for Index := 0 to FSize - 1 do\r\n if ItemsEqual(AValue, FElementData[Index]) then\r\n begin\r\n Result := CheckDuplicate;\r\n Break;\r\n end;\r\n\r\n if Result then\r\n begin\r\n if FSize = FCapacity then\r\n AutoGrow;\r\n Result := FSize < FCapacity;\r\n if Result then\r\n begin\r\n FElementData[FSize] := AValue;\r\n Inc(FSize);\r\n end;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclDoubleArrayList.AddAll(const ACollection: IJclDoubleCollection): Boolean;\r\nvar\r\n It: IJclDoubleIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n Result := Add(It.Next) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclDoubleArrayList.AssignDataTo(Dest: TJclAbstractContainerBase);\r\nvar\r\n ADest: TJclDoubleArrayList;\r\n ACollection: IJclDoubleCollection;\r\nbegin\r\n inherited AssignDataTo(Dest);\r\n if Dest is TJclDoubleArrayList then\r\n begin\r\n ADest := TJclDoubleArrayList(Dest);\r\n ADest.Clear;\r\n ADest.AddAll(Self);\r\n end\r\n else\r\n if Supports(IInterface(Dest), IJclDoubleCollection, ACollection) then\r\n begin\r\n ACollection.Clear;\r\n ACollection.AddAll(Self);\r\n end;\r\nend;\r\n\r\nprocedure TJclDoubleArrayList.Clear;\r\nvar\r\n I: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n for I := 0 to FSize - 1 do\r\n FreeDouble(FElementData[I]);\r\n FSize := 0;\r\n AutoPack;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclDoubleArrayList.CollectionEquals(const ACollection: IJclDoubleCollection): Boolean;\r\nvar\r\n I: Integer;\r\n It: IJclDoubleIterator;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n if FSize <> ACollection.Size then\r\n Exit;\r\n It := ACollection.First;\r\n for I := 0 to FSize - 1 do\r\n if not ItemsEqual(FElementData[I], It.Next) then\r\n Exit;\r\n Result := True;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclDoubleArrayList.Contains(const AValue: Double): Boolean;\r\nvar\r\n I: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n for I := 0 to FSize - 1 do\r\n if ItemsEqual(FElementData[I], AValue) then\r\n begin\r\n Result := True;\r\n Break;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclDoubleArrayList.ContainsAll(const ACollection: IJclDoubleCollection): Boolean;\r\nvar\r\n It: IJclDoubleIterator;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := True;\r\n if ACollection = nil then\r\n Exit;\r\n It := ACollection.First;\r\n while Result and It.HasNext do\r\n Result := Contains(It.Next);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclDoubleArrayList.Delete(Index: Integer): Double;\r\nvar\r\n Extracted: Double;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Extracted := ExtractIndex(Index);\r\n Result := FreeDouble(Extracted);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclDoubleArrayList.Extract(const AValue: Double): Boolean;\r\nvar\r\n I: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n for I := FSize - 1 downto 0 do\r\n if ItemsEqual(FElementData[I], AValue) then\r\n begin\r\n if I < (FSize - 1) then\r\n MoveArray(FElementData, I + 1, I, FSize - 1 - I)\r\n else\r\n FElementData[I] := 0.0;\r\n Dec(FSize);\r\n Result := True;\r\n if FRemoveSingleElement then\r\n Break;\r\n end;\r\n AutoPack;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclDoubleArrayList.ExtractAll(const ACollection: IJclDoubleCollection): Boolean;\r\nvar\r\n It: IJclDoubleIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n Result := Extract(It.Next) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclDoubleArrayList.ExtractIndex(Index: Integer): Double;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if (Index >= 0) and (Index < FSize) then\r\n begin\r\n Result := FElementData[Index];\r\n if Index < (FSize - 1) then\r\n MoveArray(FElementData, Index + 1, Index, FSize - 1 - Index)\r\n else\r\n FElementData[Index] := 0.0;\r\n Dec(FSize);\r\n AutoPack;\r\n end\r\n else\r\n Result := RaiseOutOfBoundsError;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclDoubleArrayList.First: IJclDoubleIterator;\r\nbegin\r\n Result := TJclDoubleArrayIterator.Create(Self, 0, False, isFirst);\r\nend;\r\n\r\n{$IFDEF SUPPORTS_FOR_IN}\r\nfunction TJclDoubleArrayList.GetEnumerator: IJclDoubleIterator;\r\nbegin\r\n Result := TJclDoubleArrayIterator.Create(Self, 0, False, isFirst);\r\nend;\r\n{$ENDIF SUPPORTS_FOR_IN}\r\n\r\nfunction TJclDoubleArrayList.GetValue(Index: Integer): Double;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := 0.0;\r\n if (Index >= 0) and (Index < FSize) then\r\n Result := FElementData[Index]\r\n else\r\n if not FReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create(IntToStr(Index));\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclDoubleArrayList.IndexOf(const AValue: Double): Integer;\r\nvar\r\n I: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := -1;\r\n for I := 0 to FSize - 1 do\r\n if ItemsEqual(FElementData[I], AValue) then\r\n begin\r\n Result := I;\r\n Break;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclDoubleArrayList.Insert(Index: Integer; const AValue: Double): Boolean;\r\nvar\r\n I: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := FAllowDefaultElements or not ItemsEqual(AValue, 0.0);\r\n\r\n if (Index < 0) or (Index > FSize) then\r\n raise EJclOutOfBoundsError.Create;\r\n\r\n if Result then\r\n begin\r\n if FDuplicates <> dupAccept then\r\n for I := 0 to FSize - 1 do\r\n if ItemsEqual(AValue, FElementData[I]) then\r\n begin\r\n Result := CheckDuplicate;\r\n Break;\r\n end;\r\n\r\n if Result then\r\n begin\r\n if FSize = FCapacity then\r\n AutoGrow;\r\n Result := FSize < FCapacity;\r\n if Result then\r\n begin\r\n if Index < FSize then\r\n MoveArray(FElementData, Index, Index + 1, FSize - Index);\r\n FElementData[Index] := AValue;\r\n Inc(FSize);\r\n end;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclDoubleArrayList.InsertAll(Index: Integer; const ACollection: IJclDoubleCollection): Boolean;\r\nvar\r\n It: IJclDoubleIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if (Index < 0) or (Index > FSize) then\r\n raise EJclOutOfBoundsError.Create;\r\n if ACollection = nil then\r\n Exit;\r\n\r\n Result := True;\r\n It := ACollection.Last;\r\n while It.HasPrevious do\r\n Result := Insert(Index, It.Previous) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclDoubleArrayList.IsEmpty: Boolean;\r\nbegin\r\n Result := FSize = 0;\r\nend;\r\n\r\nfunction TJclDoubleArrayList.Last: IJclDoubleIterator;\r\nbegin\r\n Result := TJclDoubleArrayIterator.Create(Self, FSize - 1, False, isLast);\r\nend;\r\n\r\nfunction TJclDoubleArrayList.LastIndexOf(const AValue: Double): Integer;\r\nvar\r\n I: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := -1;\r\n for I := FSize - 1 downto 0 do\r\n if ItemsEqual(FElementData[I], AValue) then\r\n begin\r\n Result := I;\r\n Break;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclDoubleArrayList.RaiseOutOfBoundsError: Double;\r\nbegin\r\n raise EJclOutOfBoundsError.Create;\r\nend;\r\n\r\nfunction TJclDoubleArrayList.Remove(const AValue: Double): Boolean;\r\nvar\r\n Extracted: Double;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := Extract(AValue);\r\n if Result then\r\n begin\r\n Extracted := AValue;\r\n FreeDouble(Extracted);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclDoubleArrayList.RemoveAll(const ACollection: IJclDoubleCollection): Boolean;\r\nvar\r\n It: IJclDoubleIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n Result := Remove(It.Next) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclDoubleArrayList.RetainAll(const ACollection: IJclDoubleCollection): Boolean;\r\nvar\r\n I: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n for I := FSize - 1 downto 0 do\r\n if not ACollection.Contains(FElementData[I]) then\r\n Delete(I);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclDoubleArrayList.SetCapacity(Value: Integer);\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Value >= FSize then\r\n begin\r\n SetLength(FElementData, Value);\r\n inherited SetCapacity(Value);\r\n end\r\n else\r\n raise EJclOutOfBoundsError.Create;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclDoubleArrayList.SetValue(Index: Integer; const AValue: Double);\r\nvar\r\n ReplaceItem: Boolean;\r\n I: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if (Index < 0) or (Index >= FSize) then\r\n raise EJclOutOfBoundsError.Create;\r\n ReplaceItem := FAllowDefaultElements or not ItemsEqual(AValue, 0.0);\r\n if ReplaceItem then\r\n begin\r\n if FDuplicates <> dupAccept then\r\n for I := 0 to FSize - 1 do\r\n if ItemsEqual(FElementData[I], AValue) then\r\n begin\r\n ReplaceItem := CheckDuplicate;\r\n Break;\r\n end;\r\n if ReplaceItem then\r\n begin\r\n FreeDouble(FElementData[Index]);\r\n FElementData[Index] := AValue;\r\n end;\r\n end;\r\n if not ReplaceItem then\r\n Delete(Index);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclDoubleArrayList.Size: Integer;\r\nbegin\r\n Result := FSize;\r\nend;\r\n\r\nfunction TJclDoubleArrayList.SubList(First, Count: Integer): IJclDoubleList;\r\nvar\r\n I: Integer;\r\n Last: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Last := First + Count - 1;\r\n if Last >= FSize then\r\n Last := FSize - 1;\r\n Result := CreateEmptyContainer as IJclDoubleList;\r\n for I := First to Last do\r\n Result.Add(FElementData[I]);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclDoubleArrayList.CreateEmptyContainer: TJclAbstractContainerBase;\r\nbegin\r\n Result := TJclDoubleArrayList.Create(FSize);\r\n AssignPropertiesTo(Result);\r\nend;\r\n\r\n//=== { TJclDoubleArrayIterator } ===============================================================\r\n\r\nconstructor TJclDoubleArrayIterator.Create(AOwnList: TJclDoubleArrayList; ACursor: Integer; AValid: Boolean; AStart: TItrStart);\r\nbegin\r\n inherited Create(AValid);\r\n FOwnList := AOwnList;\r\n FStart := AStart;\r\n FCursor := ACursor;\r\nend;\r\n\r\nfunction TJclDoubleArrayIterator.Add(const AValue: Double): Boolean;\r\nbegin\r\n Result := FOwnList.Add(AValue);\r\nend;\r\n\r\nprocedure TJclDoubleArrayIterator.AssignPropertiesTo(Dest: TJclAbstractIterator);\r\nvar\r\n ADest: TJclDoubleArrayIterator;\r\nbegin\r\n inherited AssignPropertiesTo(Dest);\r\n if Dest is TJclDoubleArrayIterator then\r\n begin\r\n ADest := TJclDoubleArrayIterator(Dest);\r\n ADest.FOwnList := FOwnList;\r\n ADest.FCursor := FCursor;\r\n ADest.FStart := FStart;\r\n end;\r\nend;\r\n\r\nfunction TJclDoubleArrayIterator.CreateEmptyIterator: TJclAbstractIterator;\r\nbegin\r\n Result := TJclDoubleArrayIterator.Create(FOwnList, FCursor, Valid, FStart);\r\nend;\r\n\r\nprocedure TJclDoubleArrayIterator.Extract;\r\nbegin\r\n CheckValid;\r\n Valid := False;\r\n FOwnList.ExtractIndex(FCursor);\r\nend;\r\n\r\nfunction TJclDoubleArrayIterator.GetValue: Double;\r\nbegin\r\n CheckValid;\r\n Result := FOwnList.GetValue(FCursor);\r\nend;\r\n\r\nfunction TJclDoubleArrayIterator.HasNext: Boolean;\r\nbegin\r\n if Valid then\r\n Result := FCursor < (FOwnList.Size - 1)\r\n else\r\n Result := FCursor < FOwnList.Size;\r\nend;\r\n\r\nfunction TJclDoubleArrayIterator.HasPrevious: Boolean;\r\nbegin\r\n if Valid then\r\n Result := FCursor > 0\r\n else\r\n Result := FCursor >= 0;\r\nend;\r\n\r\nfunction TJclDoubleArrayIterator.Insert(const AValue: Double): Boolean;\r\nbegin\r\n CheckValid;\r\n Result := FOwnList.Insert(FCursor, AValue);\r\nend;\r\n\r\nfunction TJclDoubleArrayIterator.IteratorEquals(const AIterator: IJclDoubleIterator): Boolean;\r\nvar\r\n Obj: TObject;\r\n ItrObj: TJclDoubleArrayIterator;\r\nbegin\r\n Result := False;\r\n if AIterator = nil then\r\n Exit;\r\n Obj := AIterator.GetIteratorReference;\r\n if Obj is TJclDoubleArrayIterator then\r\n begin\r\n ItrObj := TJclDoubleArrayIterator(Obj);\r\n Result := (FOwnList = ItrObj.FOwnList) and (FCursor = ItrObj.FCursor) and (Valid = ItrObj.Valid);\r\n end;\r\nend;\r\n\r\n{$IFDEF SUPPORTS_FOR_IN}\r\nfunction TJclDoubleArrayIterator.MoveNext: Boolean;\r\nbegin\r\n if Valid then\r\n Inc(FCursor)\r\n else\r\n Valid := True;\r\n Result := FCursor < FOwnList.Size;\r\nend;\r\n{$ENDIF SUPPORTS_FOR_IN}\r\n\r\nfunction TJclDoubleArrayIterator.Next: Double;\r\nbegin\r\n if Valid then\r\n Inc(FCursor)\r\n else\r\n Valid := True;\r\n Result := FOwnList.GetValue(FCursor);\r\nend;\r\n\r\nfunction TJclDoubleArrayIterator.NextIndex: Integer;\r\nbegin\r\n if Valid then\r\n Result := FCursor + 1\r\n else\r\n Result := FCursor;\r\nend;\r\n\r\nfunction TJclDoubleArrayIterator.Previous: Double;\r\nbegin\r\n if Valid then\r\n Dec(FCursor)\r\n else\r\n Valid := True;\r\n Result := FOwnList.GetValue(FCursor);\r\nend;\r\n\r\nfunction TJclDoubleArrayIterator.PreviousIndex: Integer;\r\nbegin\r\n if Valid then\r\n Result := FCursor - 1\r\n else\r\n Result := FCursor;\r\nend;\r\n\r\nprocedure TJclDoubleArrayIterator.Remove;\r\nbegin\r\n CheckValid;\r\n Valid := False;\r\n FOwnList.Delete(FCursor);\r\nend;\r\n\r\nprocedure TJclDoubleArrayIterator.Reset;\r\nbegin\r\n Valid := False;\r\n case FStart of\r\n isFirst:\r\n FCursor := 0;\r\n isLast:\r\n FCursor := FOwnList.Size - 1;\r\n end;\r\nend;\r\n\r\nprocedure TJclDoubleArrayIterator.SetValue(const AValue: Double);\r\nbegin\r\n CheckValid;\r\n FOwnList.SetValue(FCursor, AValue);\r\nend;\r\n\r\n//=== { TJclExtendedArrayList } ======================================================\r\n\r\nconstructor TJclExtendedArrayList.Create(ACapacity: Integer);\r\nbegin\r\n inherited Create();\r\n SetCapacity(ACapacity);\r\nend;\r\n\r\nconstructor TJclExtendedArrayList.Create(const ACollection: IJclExtendedCollection);\r\nbegin\r\n inherited Create();\r\n if ACollection = nil then\r\n raise EJclNoCollectionError.Create;\r\n SetCapacity(ACollection.Size);\r\n AddAll(ACollection);\r\nend;\r\n\r\ndestructor TJclExtendedArrayList.Destroy;\r\nbegin\r\n FReadOnly := False;\r\n Clear;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJclExtendedArrayList.Add(const AValue: Extended): Boolean;\r\nvar\r\n Index: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := FAllowDefaultElements or not ItemsEqual(AValue, 0.0);\r\n if Result then\r\n begin\r\n if FDuplicates <> dupAccept then\r\n for Index := 0 to FSize - 1 do\r\n if ItemsEqual(AValue, FElementData[Index]) then\r\n begin\r\n Result := CheckDuplicate;\r\n Break;\r\n end;\r\n\r\n if Result then\r\n begin\r\n if FSize = FCapacity then\r\n AutoGrow;\r\n Result := FSize < FCapacity;\r\n if Result then\r\n begin\r\n FElementData[FSize] := AValue;\r\n Inc(FSize);\r\n end;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclExtendedArrayList.AddAll(const ACollection: IJclExtendedCollection): Boolean;\r\nvar\r\n It: IJclExtendedIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n Result := Add(It.Next) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclExtendedArrayList.AssignDataTo(Dest: TJclAbstractContainerBase);\r\nvar\r\n ADest: TJclExtendedArrayList;\r\n ACollection: IJclExtendedCollection;\r\nbegin\r\n inherited AssignDataTo(Dest);\r\n if Dest is TJclExtendedArrayList then\r\n begin\r\n ADest := TJclExtendedArrayList(Dest);\r\n ADest.Clear;\r\n ADest.AddAll(Self);\r\n end\r\n else\r\n if Supports(IInterface(Dest), IJclExtendedCollection, ACollection) then\r\n begin\r\n ACollection.Clear;\r\n ACollection.AddAll(Self);\r\n end;\r\nend;\r\n\r\nprocedure TJclExtendedArrayList.Clear;\r\nvar\r\n I: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n for I := 0 to FSize - 1 do\r\n FreeExtended(FElementData[I]);\r\n FSize := 0;\r\n AutoPack;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclExtendedArrayList.CollectionEquals(const ACollection: IJclExtendedCollection): Boolean;\r\nvar\r\n I: Integer;\r\n It: IJclExtendedIterator;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n if FSize <> ACollection.Size then\r\n Exit;\r\n It := ACollection.First;\r\n for I := 0 to FSize - 1 do\r\n if not ItemsEqual(FElementData[I], It.Next) then\r\n Exit;\r\n Result := True;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclExtendedArrayList.Contains(const AValue: Extended): Boolean;\r\nvar\r\n I: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n for I := 0 to FSize - 1 do\r\n if ItemsEqual(FElementData[I], AValue) then\r\n begin\r\n Result := True;\r\n Break;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclExtendedArrayList.ContainsAll(const ACollection: IJclExtendedCollection): Boolean;\r\nvar\r\n It: IJclExtendedIterator;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := True;\r\n if ACollection = nil then\r\n Exit;\r\n It := ACollection.First;\r\n while Result and It.HasNext do\r\n Result := Contains(It.Next);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclExtendedArrayList.Delete(Index: Integer): Extended;\r\nvar\r\n Extracted: Extended;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Extracted := ExtractIndex(Index);\r\n Result := FreeExtended(Extracted);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclExtendedArrayList.Extract(const AValue: Extended): Boolean;\r\nvar\r\n I: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n for I := FSize - 1 downto 0 do\r\n if ItemsEqual(FElementData[I], AValue) then\r\n begin\r\n if I < (FSize - 1) then\r\n MoveArray(FElementData, I + 1, I, FSize - 1 - I)\r\n else\r\n FElementData[I] := 0.0;\r\n Dec(FSize);\r\n Result := True;\r\n if FRemoveSingleElement then\r\n Break;\r\n end;\r\n AutoPack;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclExtendedArrayList.ExtractAll(const ACollection: IJclExtendedCollection): Boolean;\r\nvar\r\n It: IJclExtendedIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n Result := Extract(It.Next) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclExtendedArrayList.ExtractIndex(Index: Integer): Extended;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if (Index >= 0) and (Index < FSize) then\r\n begin\r\n Result := FElementData[Index];\r\n if Index < (FSize - 1) then\r\n MoveArray(FElementData, Index + 1, Index, FSize - 1 - Index)\r\n else\r\n FElementData[Index] := 0.0;\r\n Dec(FSize);\r\n AutoPack;\r\n end\r\n else\r\n Result := RaiseOutOfBoundsError;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclExtendedArrayList.First: IJclExtendedIterator;\r\nbegin\r\n Result := TJclExtendedArrayIterator.Create(Self, 0, False, isFirst);\r\nend;\r\n\r\n{$IFDEF SUPPORTS_FOR_IN}\r\nfunction TJclExtendedArrayList.GetEnumerator: IJclExtendedIterator;\r\nbegin\r\n Result := TJclExtendedArrayIterator.Create(Self, 0, False, isFirst);\r\nend;\r\n{$ENDIF SUPPORTS_FOR_IN}\r\n\r\nfunction TJclExtendedArrayList.GetValue(Index: Integer): Extended;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := 0.0;\r\n if (Index >= 0) and (Index < FSize) then\r\n Result := FElementData[Index]\r\n else\r\n if not FReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create(IntToStr(Index));\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclExtendedArrayList.IndexOf(const AValue: Extended): Integer;\r\nvar\r\n I: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := -1;\r\n for I := 0 to FSize - 1 do\r\n if ItemsEqual(FElementData[I], AValue) then\r\n begin\r\n Result := I;\r\n Break;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclExtendedArrayList.Insert(Index: Integer; const AValue: Extended): Boolean;\r\nvar\r\n I: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := FAllowDefaultElements or not ItemsEqual(AValue, 0.0);\r\n\r\n if (Index < 0) or (Index > FSize) then\r\n raise EJclOutOfBoundsError.Create;\r\n\r\n if Result then\r\n begin\r\n if FDuplicates <> dupAccept then\r\n for I := 0 to FSize - 1 do\r\n if ItemsEqual(AValue, FElementData[I]) then\r\n begin\r\n Result := CheckDuplicate;\r\n Break;\r\n end;\r\n\r\n if Result then\r\n begin\r\n if FSize = FCapacity then\r\n AutoGrow;\r\n Result := FSize < FCapacity;\r\n if Result then\r\n begin\r\n if Index < FSize then\r\n MoveArray(FElementData, Index, Index + 1, FSize - Index);\r\n FElementData[Index] := AValue;\r\n Inc(FSize);\r\n end;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclExtendedArrayList.InsertAll(Index: Integer; const ACollection: IJclExtendedCollection): Boolean;\r\nvar\r\n It: IJclExtendedIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if (Index < 0) or (Index > FSize) then\r\n raise EJclOutOfBoundsError.Create;\r\n if ACollection = nil then\r\n Exit;\r\n\r\n Result := True;\r\n It := ACollection.Last;\r\n while It.HasPrevious do\r\n Result := Insert(Index, It.Previous) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclExtendedArrayList.IsEmpty: Boolean;\r\nbegin\r\n Result := FSize = 0;\r\nend;\r\n\r\nfunction TJclExtendedArrayList.Last: IJclExtendedIterator;\r\nbegin\r\n Result := TJclExtendedArrayIterator.Create(Self, FSize - 1, False, isLast);\r\nend;\r\n\r\nfunction TJclExtendedArrayList.LastIndexOf(const AValue: Extended): Integer;\r\nvar\r\n I: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := -1;\r\n for I := FSize - 1 downto 0 do\r\n if ItemsEqual(FElementData[I], AValue) then\r\n begin\r\n Result := I;\r\n Break;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclExtendedArrayList.RaiseOutOfBoundsError: Extended;\r\nbegin\r\n raise EJclOutOfBoundsError.Create;\r\nend;\r\n\r\nfunction TJclExtendedArrayList.Remove(const AValue: Extended): Boolean;\r\nvar\r\n Extracted: Extended;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := Extract(AValue);\r\n if Result then\r\n begin\r\n Extracted := AValue;\r\n FreeExtended(Extracted);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclExtendedArrayList.RemoveAll(const ACollection: IJclExtendedCollection): Boolean;\r\nvar\r\n It: IJclExtendedIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n Result := Remove(It.Next) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclExtendedArrayList.RetainAll(const ACollection: IJclExtendedCollection): Boolean;\r\nvar\r\n I: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n for I := FSize - 1 downto 0 do\r\n if not ACollection.Contains(FElementData[I]) then\r\n Delete(I);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclExtendedArrayList.SetCapacity(Value: Integer);\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Value >= FSize then\r\n begin\r\n SetLength(FElementData, Value);\r\n inherited SetCapacity(Value);\r\n end\r\n else\r\n raise EJclOutOfBoundsError.Create;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclExtendedArrayList.SetValue(Index: Integer; const AValue: Extended);\r\nvar\r\n ReplaceItem: Boolean;\r\n I: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if (Index < 0) or (Index >= FSize) then\r\n raise EJclOutOfBoundsError.Create;\r\n ReplaceItem := FAllowDefaultElements or not ItemsEqual(AValue, 0.0);\r\n if ReplaceItem then\r\n begin\r\n if FDuplicates <> dupAccept then\r\n for I := 0 to FSize - 1 do\r\n if ItemsEqual(FElementData[I], AValue) then\r\n begin\r\n ReplaceItem := CheckDuplicate;\r\n Break;\r\n end;\r\n if ReplaceItem then\r\n begin\r\n FreeExtended(FElementData[Index]);\r\n FElementData[Index] := AValue;\r\n end;\r\n end;\r\n if not ReplaceItem then\r\n Delete(Index);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclExtendedArrayList.Size: Integer;\r\nbegin\r\n Result := FSize;\r\nend;\r\n\r\nfunction TJclExtendedArrayList.SubList(First, Count: Integer): IJclExtendedList;\r\nvar\r\n I: Integer;\r\n Last: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Last := First + Count - 1;\r\n if Last >= FSize then\r\n Last := FSize - 1;\r\n Result := CreateEmptyContainer as IJclExtendedList;\r\n for I := First to Last do\r\n Result.Add(FElementData[I]);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclExtendedArrayList.CreateEmptyContainer: TJclAbstractContainerBase;\r\nbegin\r\n Result := TJclExtendedArrayList.Create(FSize);\r\n AssignPropertiesTo(Result);\r\nend;\r\n\r\n//=== { TJclExtendedArrayIterator } ===============================================================\r\n\r\nconstructor TJclExtendedArrayIterator.Create(AOwnList: TJclExtendedArrayList; ACursor: Integer; AValid: Boolean; AStart: TItrStart);\r\nbegin\r\n inherited Create(AValid);\r\n FOwnList := AOwnList;\r\n FStart := AStart;\r\n FCursor := ACursor;\r\nend;\r\n\r\nfunction TJclExtendedArrayIterator.Add(const AValue: Extended): Boolean;\r\nbegin\r\n Result := FOwnList.Add(AValue);\r\nend;\r\n\r\nprocedure TJclExtendedArrayIterator.AssignPropertiesTo(Dest: TJclAbstractIterator);\r\nvar\r\n ADest: TJclExtendedArrayIterator;\r\nbegin\r\n inherited AssignPropertiesTo(Dest);\r\n if Dest is TJclExtendedArrayIterator then\r\n begin\r\n ADest := TJclExtendedArrayIterator(Dest);\r\n ADest.FOwnList := FOwnList;\r\n ADest.FCursor := FCursor;\r\n ADest.FStart := FStart;\r\n end;\r\nend;\r\n\r\nfunction TJclExtendedArrayIterator.CreateEmptyIterator: TJclAbstractIterator;\r\nbegin\r\n Result := TJclExtendedArrayIterator.Create(FOwnList, FCursor, Valid, FStart);\r\nend;\r\n\r\nprocedure TJclExtendedArrayIterator.Extract;\r\nbegin\r\n CheckValid;\r\n Valid := False;\r\n FOwnList.ExtractIndex(FCursor);\r\nend;\r\n\r\nfunction TJclExtendedArrayIterator.GetValue: Extended;\r\nbegin\r\n CheckValid;\r\n Result := FOwnList.GetValue(FCursor);\r\nend;\r\n\r\nfunction TJclExtendedArrayIterator.HasNext: Boolean;\r\nbegin\r\n if Valid then\r\n Result := FCursor < (FOwnList.Size - 1)\r\n else\r\n Result := FCursor < FOwnList.Size;\r\nend;\r\n\r\nfunction TJclExtendedArrayIterator.HasPrevious: Boolean;\r\nbegin\r\n if Valid then\r\n Result := FCursor > 0\r\n else\r\n Result := FCursor >= 0;\r\nend;\r\n\r\nfunction TJclExtendedArrayIterator.Insert(const AValue: Extended): Boolean;\r\nbegin\r\n CheckValid;\r\n Result := FOwnList.Insert(FCursor, AValue);\r\nend;\r\n\r\nfunction TJclExtendedArrayIterator.IteratorEquals(const AIterator: IJclExtendedIterator): Boolean;\r\nvar\r\n Obj: TObject;\r\n ItrObj: TJclExtendedArrayIterator;\r\nbegin\r\n Result := False;\r\n if AIterator = nil then\r\n Exit;\r\n Obj := AIterator.GetIteratorReference;\r\n if Obj is TJclExtendedArrayIterator then\r\n begin\r\n ItrObj := TJclExtendedArrayIterator(Obj);\r\n Result := (FOwnList = ItrObj.FOwnList) and (FCursor = ItrObj.FCursor) and (Valid = ItrObj.Valid);\r\n end;\r\nend;\r\n\r\n{$IFDEF SUPPORTS_FOR_IN}\r\nfunction TJclExtendedArrayIterator.MoveNext: Boolean;\r\nbegin\r\n if Valid then\r\n Inc(FCursor)\r\n else\r\n Valid := True;\r\n Result := FCursor < FOwnList.Size;\r\nend;\r\n{$ENDIF SUPPORTS_FOR_IN}\r\n\r\nfunction TJclExtendedArrayIterator.Next: Extended;\r\nbegin\r\n if Valid then\r\n Inc(FCursor)\r\n else\r\n Valid := True;\r\n Result := FOwnList.GetValue(FCursor);\r\nend;\r\n\r\nfunction TJclExtendedArrayIterator.NextIndex: Integer;\r\nbegin\r\n if Valid then\r\n Result := FCursor + 1\r\n else\r\n Result := FCursor;\r\nend;\r\n\r\nfunction TJclExtendedArrayIterator.Previous: Extended;\r\nbegin\r\n if Valid then\r\n Dec(FCursor)\r\n else\r\n Valid := True;\r\n Result := FOwnList.GetValue(FCursor);\r\nend;\r\n\r\nfunction TJclExtendedArrayIterator.PreviousIndex: Integer;\r\nbegin\r\n if Valid then\r\n Result := FCursor - 1\r\n else\r\n Result := FCursor;\r\nend;\r\n\r\nprocedure TJclExtendedArrayIterator.Remove;\r\nbegin\r\n CheckValid;\r\n Valid := False;\r\n FOwnList.Delete(FCursor);\r\nend;\r\n\r\nprocedure TJclExtendedArrayIterator.Reset;\r\nbegin\r\n Valid := False;\r\n case FStart of\r\n isFirst:\r\n FCursor := 0;\r\n isLast:\r\n FCursor := FOwnList.Size - 1;\r\n end;\r\nend;\r\n\r\nprocedure TJclExtendedArrayIterator.SetValue(const AValue: Extended);\r\nbegin\r\n CheckValid;\r\n FOwnList.SetValue(FCursor, AValue);\r\nend;\r\n\r\n//=== { TJclIntegerArrayList } ======================================================\r\n\r\nconstructor TJclIntegerArrayList.Create(ACapacity: Integer);\r\nbegin\r\n inherited Create();\r\n SetCapacity(ACapacity);\r\nend;\r\n\r\nconstructor TJclIntegerArrayList.Create(const ACollection: IJclIntegerCollection);\r\nbegin\r\n inherited Create();\r\n if ACollection = nil then\r\n raise EJclNoCollectionError.Create;\r\n SetCapacity(ACollection.Size);\r\n AddAll(ACollection);\r\nend;\r\n\r\ndestructor TJclIntegerArrayList.Destroy;\r\nbegin\r\n FReadOnly := False;\r\n Clear;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJclIntegerArrayList.Add(AValue: Integer): Boolean;\r\nvar\r\n Index: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := FAllowDefaultElements or not ItemsEqual(AValue, 0);\r\n if Result then\r\n begin\r\n if FDuplicates <> dupAccept then\r\n for Index := 0 to FSize - 1 do\r\n if ItemsEqual(AValue, FElementData[Index]) then\r\n begin\r\n Result := CheckDuplicate;\r\n Break;\r\n end;\r\n\r\n if Result then\r\n begin\r\n if FSize = FCapacity then\r\n AutoGrow;\r\n Result := FSize < FCapacity;\r\n if Result then\r\n begin\r\n FElementData[FSize] := AValue;\r\n Inc(FSize);\r\n end;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntegerArrayList.AddAll(const ACollection: IJclIntegerCollection): Boolean;\r\nvar\r\n It: IJclIntegerIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n Result := Add(It.Next) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclIntegerArrayList.AssignDataTo(Dest: TJclAbstractContainerBase);\r\nvar\r\n ADest: TJclIntegerArrayList;\r\n ACollection: IJclIntegerCollection;\r\nbegin\r\n inherited AssignDataTo(Dest);\r\n if Dest is TJclIntegerArrayList then\r\n begin\r\n ADest := TJclIntegerArrayList(Dest);\r\n ADest.Clear;\r\n ADest.AddAll(Self);\r\n end\r\n else\r\n if Supports(IInterface(Dest), IJclIntegerCollection, ACollection) then\r\n begin\r\n ACollection.Clear;\r\n ACollection.AddAll(Self);\r\n end;\r\nend;\r\n\r\nprocedure TJclIntegerArrayList.Clear;\r\nvar\r\n I: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n for I := 0 to FSize - 1 do\r\n FreeInteger(FElementData[I]);\r\n FSize := 0;\r\n AutoPack;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntegerArrayList.CollectionEquals(const ACollection: IJclIntegerCollection): Boolean;\r\nvar\r\n I: Integer;\r\n It: IJclIntegerIterator;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n if FSize <> ACollection.Size then\r\n Exit;\r\n It := ACollection.First;\r\n for I := 0 to FSize - 1 do\r\n if not ItemsEqual(FElementData[I], It.Next) then\r\n Exit;\r\n Result := True;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntegerArrayList.Contains(AValue: Integer): Boolean;\r\nvar\r\n I: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n for I := 0 to FSize - 1 do\r\n if ItemsEqual(FElementData[I], AValue) then\r\n begin\r\n Result := True;\r\n Break;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntegerArrayList.ContainsAll(const ACollection: IJclIntegerCollection): Boolean;\r\nvar\r\n It: IJclIntegerIterator;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := True;\r\n if ACollection = nil then\r\n Exit;\r\n It := ACollection.First;\r\n while Result and It.HasNext do\r\n Result := Contains(It.Next);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntegerArrayList.Delete(Index: Integer): Integer;\r\nvar\r\n Extracted: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Extracted := ExtractIndex(Index);\r\n Result := FreeInteger(Extracted);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntegerArrayList.Extract(AValue: Integer): Boolean;\r\nvar\r\n I: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n for I := FSize - 1 downto 0 do\r\n if ItemsEqual(FElementData[I], AValue) then\r\n begin\r\n if I < (FSize - 1) then\r\n MoveArray(FElementData, I + 1, I, FSize - 1 - I)\r\n else\r\n FElementData[I] := 0;\r\n Dec(FSize);\r\n Result := True;\r\n if FRemoveSingleElement then\r\n Break;\r\n end;\r\n AutoPack;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntegerArrayList.ExtractAll(const ACollection: IJclIntegerCollection): Boolean;\r\nvar\r\n It: IJclIntegerIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n Result := Extract(It.Next) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntegerArrayList.ExtractIndex(Index: Integer): Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if (Index >= 0) and (Index < FSize) then\r\n begin\r\n Result := FElementData[Index];\r\n if Index < (FSize - 1) then\r\n MoveArray(FElementData, Index + 1, Index, FSize - 1 - Index)\r\n else\r\n FElementData[Index] := 0;\r\n Dec(FSize);\r\n AutoPack;\r\n end\r\n else\r\n Result := RaiseOutOfBoundsError;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntegerArrayList.First: IJclIntegerIterator;\r\nbegin\r\n Result := TJclIntegerArrayIterator.Create(Self, 0, False, isFirst);\r\nend;\r\n\r\n{$IFDEF SUPPORTS_FOR_IN}\r\nfunction TJclIntegerArrayList.GetEnumerator: IJclIntegerIterator;\r\nbegin\r\n Result := TJclIntegerArrayIterator.Create(Self, 0, False, isFirst);\r\nend;\r\n{$ENDIF SUPPORTS_FOR_IN}\r\n\r\nfunction TJclIntegerArrayList.GetValue(Index: Integer): Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := 0;\r\n if (Index >= 0) and (Index < FSize) then\r\n Result := FElementData[Index]\r\n else\r\n if not FReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create(IntToStr(Index));\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntegerArrayList.IndexOf(AValue: Integer): Integer;\r\nvar\r\n I: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := -1;\r\n for I := 0 to FSize - 1 do\r\n if ItemsEqual(FElementData[I], AValue) then\r\n begin\r\n Result := I;\r\n Break;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntegerArrayList.Insert(Index: Integer; AValue: Integer): Boolean;\r\nvar\r\n I: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := FAllowDefaultElements or not ItemsEqual(AValue, 0);\r\n\r\n if (Index < 0) or (Index > FSize) then\r\n raise EJclOutOfBoundsError.Create;\r\n\r\n if Result then\r\n begin\r\n if FDuplicates <> dupAccept then\r\n for I := 0 to FSize - 1 do\r\n if ItemsEqual(AValue, FElementData[I]) then\r\n begin\r\n Result := CheckDuplicate;\r\n Break;\r\n end;\r\n\r\n if Result then\r\n begin\r\n if FSize = FCapacity then\r\n AutoGrow;\r\n Result := FSize < FCapacity;\r\n if Result then\r\n begin\r\n if Index < FSize then\r\n MoveArray(FElementData, Index, Index + 1, FSize - Index);\r\n FElementData[Index] := AValue;\r\n Inc(FSize);\r\n end;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntegerArrayList.InsertAll(Index: Integer; const ACollection: IJclIntegerCollection): Boolean;\r\nvar\r\n It: IJclIntegerIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if (Index < 0) or (Index > FSize) then\r\n raise EJclOutOfBoundsError.Create;\r\n if ACollection = nil then\r\n Exit;\r\n\r\n Result := True;\r\n It := ACollection.Last;\r\n while It.HasPrevious do\r\n Result := Insert(Index, It.Previous) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntegerArrayList.IsEmpty: Boolean;\r\nbegin\r\n Result := FSize = 0;\r\nend;\r\n\r\nfunction TJclIntegerArrayList.Last: IJclIntegerIterator;\r\nbegin\r\n Result := TJclIntegerArrayIterator.Create(Self, FSize - 1, False, isLast);\r\nend;\r\n\r\nfunction TJclIntegerArrayList.LastIndexOf(AValue: Integer): Integer;\r\nvar\r\n I: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := -1;\r\n for I := FSize - 1 downto 0 do\r\n if ItemsEqual(FElementData[I], AValue) then\r\n begin\r\n Result := I;\r\n Break;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntegerArrayList.RaiseOutOfBoundsError: Integer;\r\nbegin\r\n raise EJclOutOfBoundsError.Create;\r\nend;\r\n\r\nfunction TJclIntegerArrayList.Remove(AValue: Integer): Boolean;\r\nvar\r\n Extracted: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := Extract(AValue);\r\n if Result then\r\n begin\r\n Extracted := AValue;\r\n FreeInteger(Extracted);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntegerArrayList.RemoveAll(const ACollection: IJclIntegerCollection): Boolean;\r\nvar\r\n It: IJclIntegerIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n Result := Remove(It.Next) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntegerArrayList.RetainAll(const ACollection: IJclIntegerCollection): Boolean;\r\nvar\r\n I: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n for I := FSize - 1 downto 0 do\r\n if not ACollection.Contains(FElementData[I]) then\r\n Delete(I);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclIntegerArrayList.SetCapacity(Value: Integer);\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Value >= FSize then\r\n begin\r\n SetLength(FElementData, Value);\r\n inherited SetCapacity(Value);\r\n end\r\n else\r\n raise EJclOutOfBoundsError.Create;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclIntegerArrayList.SetValue(Index: Integer; AValue: Integer);\r\nvar\r\n ReplaceItem: Boolean;\r\n I: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if (Index < 0) or (Index >= FSize) then\r\n raise EJclOutOfBoundsError.Create;\r\n ReplaceItem := FAllowDefaultElements or not ItemsEqual(AValue, 0);\r\n if ReplaceItem then\r\n begin\r\n if FDuplicates <> dupAccept then\r\n for I := 0 to FSize - 1 do\r\n if ItemsEqual(FElementData[I], AValue) then\r\n begin\r\n ReplaceItem := CheckDuplicate;\r\n Break;\r\n end;\r\n if ReplaceItem then\r\n begin\r\n FreeInteger(FElementData[Index]);\r\n FElementData[Index] := AValue;\r\n end;\r\n end;\r\n if not ReplaceItem then\r\n Delete(Index);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntegerArrayList.Size: Integer;\r\nbegin\r\n Result := FSize;\r\nend;\r\n\r\nfunction TJclIntegerArrayList.SubList(First, Count: Integer): IJclIntegerList;\r\nvar\r\n I: Integer;\r\n Last: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Last := First + Count - 1;\r\n if Last >= FSize then\r\n Last := FSize - 1;\r\n Result := CreateEmptyContainer as IJclIntegerList;\r\n for I := First to Last do\r\n Result.Add(FElementData[I]);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntegerArrayList.CreateEmptyContainer: TJclAbstractContainerBase;\r\nbegin\r\n Result := TJclIntegerArrayList.Create(FSize);\r\n AssignPropertiesTo(Result);\r\nend;\r\n\r\n//=== { TJclIntegerArrayIterator } ===============================================================\r\n\r\nconstructor TJclIntegerArrayIterator.Create(AOwnList: TJclIntegerArrayList; ACursor: Integer; AValid: Boolean; AStart: TItrStart);\r\nbegin\r\n inherited Create(AValid);\r\n FOwnList := AOwnList;\r\n FStart := AStart;\r\n FCursor := ACursor;\r\nend;\r\n\r\nfunction TJclIntegerArrayIterator.Add(AValue: Integer): Boolean;\r\nbegin\r\n Result := FOwnList.Add(AValue);\r\nend;\r\n\r\nprocedure TJclIntegerArrayIterator.AssignPropertiesTo(Dest: TJclAbstractIterator);\r\nvar\r\n ADest: TJclIntegerArrayIterator;\r\nbegin\r\n inherited AssignPropertiesTo(Dest);\r\n if Dest is TJclIntegerArrayIterator then\r\n begin\r\n ADest := TJclIntegerArrayIterator(Dest);\r\n ADest.FOwnList := FOwnList;\r\n ADest.FCursor := FCursor;\r\n ADest.FStart := FStart;\r\n end;\r\nend;\r\n\r\nfunction TJclIntegerArrayIterator.CreateEmptyIterator: TJclAbstractIterator;\r\nbegin\r\n Result := TJclIntegerArrayIterator.Create(FOwnList, FCursor, Valid, FStart);\r\nend;\r\n\r\nprocedure TJclIntegerArrayIterator.Extract;\r\nbegin\r\n CheckValid;\r\n Valid := False;\r\n FOwnList.ExtractIndex(FCursor);\r\nend;\r\n\r\nfunction TJclIntegerArrayIterator.GetValue: Integer;\r\nbegin\r\n CheckValid;\r\n Result := FOwnList.GetValue(FCursor);\r\nend;\r\n\r\nfunction TJclIntegerArrayIterator.HasNext: Boolean;\r\nbegin\r\n if Valid then\r\n Result := FCursor < (FOwnList.Size - 1)\r\n else\r\n Result := FCursor < FOwnList.Size;\r\nend;\r\n\r\nfunction TJclIntegerArrayIterator.HasPrevious: Boolean;\r\nbegin\r\n if Valid then\r\n Result := FCursor > 0\r\n else\r\n Result := FCursor >= 0;\r\nend;\r\n\r\nfunction TJclIntegerArrayIterator.Insert(AValue: Integer): Boolean;\r\nbegin\r\n CheckValid;\r\n Result := FOwnList.Insert(FCursor, AValue);\r\nend;\r\n\r\nfunction TJclIntegerArrayIterator.IteratorEquals(const AIterator: IJclIntegerIterator): Boolean;\r\nvar\r\n Obj: TObject;\r\n ItrObj: TJclIntegerArrayIterator;\r\nbegin\r\n Result := False;\r\n if AIterator = nil then\r\n Exit;\r\n Obj := AIterator.GetIteratorReference;\r\n if Obj is TJclIntegerArrayIterator then\r\n begin\r\n ItrObj := TJclIntegerArrayIterator(Obj);\r\n Result := (FOwnList = ItrObj.FOwnList) and (FCursor = ItrObj.FCursor) and (Valid = ItrObj.Valid);\r\n end;\r\nend;\r\n\r\n{$IFDEF SUPPORTS_FOR_IN}\r\nfunction TJclIntegerArrayIterator.MoveNext: Boolean;\r\nbegin\r\n if Valid then\r\n Inc(FCursor)\r\n else\r\n Valid := True;\r\n Result := FCursor < FOwnList.Size;\r\nend;\r\n{$ENDIF SUPPORTS_FOR_IN}\r\n\r\nfunction TJclIntegerArrayIterator.Next: Integer;\r\nbegin\r\n if Valid then\r\n Inc(FCursor)\r\n else\r\n Valid := True;\r\n Result := FOwnList.GetValue(FCursor);\r\nend;\r\n\r\nfunction TJclIntegerArrayIterator.NextIndex: Integer;\r\nbegin\r\n if Valid then\r\n Result := FCursor + 1\r\n else\r\n Result := FCursor;\r\nend;\r\n\r\nfunction TJclIntegerArrayIterator.Previous: Integer;\r\nbegin\r\n if Valid then\r\n Dec(FCursor)\r\n else\r\n Valid := True;\r\n Result := FOwnList.GetValue(FCursor);\r\nend;\r\n\r\nfunction TJclIntegerArrayIterator.PreviousIndex: Integer;\r\nbegin\r\n if Valid then\r\n Result := FCursor - 1\r\n else\r\n Result := FCursor;\r\nend;\r\n\r\nprocedure TJclIntegerArrayIterator.Remove;\r\nbegin\r\n CheckValid;\r\n Valid := False;\r\n FOwnList.Delete(FCursor);\r\nend;\r\n\r\nprocedure TJclIntegerArrayIterator.Reset;\r\nbegin\r\n Valid := False;\r\n case FStart of\r\n isFirst:\r\n FCursor := 0;\r\n isLast:\r\n FCursor := FOwnList.Size - 1;\r\n end;\r\nend;\r\n\r\nprocedure TJclIntegerArrayIterator.SetValue(AValue: Integer);\r\nbegin\r\n CheckValid;\r\n FOwnList.SetValue(FCursor, AValue);\r\nend;\r\n\r\n//=== { TJclCardinalArrayList } ======================================================\r\n\r\nconstructor TJclCardinalArrayList.Create(ACapacity: Integer);\r\nbegin\r\n inherited Create();\r\n SetCapacity(ACapacity);\r\nend;\r\n\r\nconstructor TJclCardinalArrayList.Create(const ACollection: IJclCardinalCollection);\r\nbegin\r\n inherited Create();\r\n if ACollection = nil then\r\n raise EJclNoCollectionError.Create;\r\n SetCapacity(ACollection.Size);\r\n AddAll(ACollection);\r\nend;\r\n\r\ndestructor TJclCardinalArrayList.Destroy;\r\nbegin\r\n FReadOnly := False;\r\n Clear;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJclCardinalArrayList.Add(AValue: Cardinal): Boolean;\r\nvar\r\n Index: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := FAllowDefaultElements or not ItemsEqual(AValue, 0);\r\n if Result then\r\n begin\r\n if FDuplicates <> dupAccept then\r\n for Index := 0 to FSize - 1 do\r\n if ItemsEqual(AValue, FElementData[Index]) then\r\n begin\r\n Result := CheckDuplicate;\r\n Break;\r\n end;\r\n\r\n if Result then\r\n begin\r\n if FSize = FCapacity then\r\n AutoGrow;\r\n Result := FSize < FCapacity;\r\n if Result then\r\n begin\r\n FElementData[FSize] := AValue;\r\n Inc(FSize);\r\n end;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclCardinalArrayList.AddAll(const ACollection: IJclCardinalCollection): Boolean;\r\nvar\r\n It: IJclCardinalIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n Result := Add(It.Next) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclCardinalArrayList.AssignDataTo(Dest: TJclAbstractContainerBase);\r\nvar\r\n ADest: TJclCardinalArrayList;\r\n ACollection: IJclCardinalCollection;\r\nbegin\r\n inherited AssignDataTo(Dest);\r\n if Dest is TJclCardinalArrayList then\r\n begin\r\n ADest := TJclCardinalArrayList(Dest);\r\n ADest.Clear;\r\n ADest.AddAll(Self);\r\n end\r\n else\r\n if Supports(IInterface(Dest), IJclCardinalCollection, ACollection) then\r\n begin\r\n ACollection.Clear;\r\n ACollection.AddAll(Self);\r\n end;\r\nend;\r\n\r\nprocedure TJclCardinalArrayList.Clear;\r\nvar\r\n I: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n for I := 0 to FSize - 1 do\r\n FreeCardinal(FElementData[I]);\r\n FSize := 0;\r\n AutoPack;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclCardinalArrayList.CollectionEquals(const ACollection: IJclCardinalCollection): Boolean;\r\nvar\r\n I: Integer;\r\n It: IJclCardinalIterator;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n if FSize <> ACollection.Size then\r\n Exit;\r\n It := ACollection.First;\r\n for I := 0 to FSize - 1 do\r\n if not ItemsEqual(FElementData[I], It.Next) then\r\n Exit;\r\n Result := True;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclCardinalArrayList.Contains(AValue: Cardinal): Boolean;\r\nvar\r\n I: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n for I := 0 to FSize - 1 do\r\n if ItemsEqual(FElementData[I], AValue) then\r\n begin\r\n Result := True;\r\n Break;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclCardinalArrayList.ContainsAll(const ACollection: IJclCardinalCollection): Boolean;\r\nvar\r\n It: IJclCardinalIterator;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := True;\r\n if ACollection = nil then\r\n Exit;\r\n It := ACollection.First;\r\n while Result and It.HasNext do\r\n Result := Contains(It.Next);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclCardinalArrayList.Delete(Index: Integer): Cardinal;\r\nvar\r\n Extracted: Cardinal;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Extracted := ExtractIndex(Index);\r\n Result := FreeCardinal(Extracted);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclCardinalArrayList.Extract(AValue: Cardinal): Boolean;\r\nvar\r\n I: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n for I := FSize - 1 downto 0 do\r\n if ItemsEqual(FElementData[I], AValue) then\r\n begin\r\n if I < (FSize - 1) then\r\n MoveArray(FElementData, I + 1, I, FSize - 1 - I)\r\n else\r\n FElementData[I] := 0;\r\n Dec(FSize);\r\n Result := True;\r\n if FRemoveSingleElement then\r\n Break;\r\n end;\r\n AutoPack;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclCardinalArrayList.ExtractAll(const ACollection: IJclCardinalCollection): Boolean;\r\nvar\r\n It: IJclCardinalIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n Result := Extract(It.Next) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclCardinalArrayList.ExtractIndex(Index: Integer): Cardinal;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if (Index >= 0) and (Index < FSize) then\r\n begin\r\n Result := FElementData[Index];\r\n if Index < (FSize - 1) then\r\n MoveArray(FElementData, Index + 1, Index, FSize - 1 - Index)\r\n else\r\n FElementData[Index] := 0;\r\n Dec(FSize);\r\n AutoPack;\r\n end\r\n else\r\n Result := RaiseOutOfBoundsError;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclCardinalArrayList.First: IJclCardinalIterator;\r\nbegin\r\n Result := TJclCardinalArrayIterator.Create(Self, 0, False, isFirst);\r\nend;\r\n\r\n{$IFDEF SUPPORTS_FOR_IN}\r\nfunction TJclCardinalArrayList.GetEnumerator: IJclCardinalIterator;\r\nbegin\r\n Result := TJclCardinalArrayIterator.Create(Self, 0, False, isFirst);\r\nend;\r\n{$ENDIF SUPPORTS_FOR_IN}\r\n\r\nfunction TJclCardinalArrayList.GetValue(Index: Integer): Cardinal;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := 0;\r\n if (Index >= 0) and (Index < FSize) then\r\n Result := FElementData[Index]\r\n else\r\n if not FReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create(IntToStr(Index));\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclCardinalArrayList.IndexOf(AValue: Cardinal): Integer;\r\nvar\r\n I: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := -1;\r\n for I := 0 to FSize - 1 do\r\n if ItemsEqual(FElementData[I], AValue) then\r\n begin\r\n Result := I;\r\n Break;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclCardinalArrayList.Insert(Index: Integer; AValue: Cardinal): Boolean;\r\nvar\r\n I: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := FAllowDefaultElements or not ItemsEqual(AValue, 0);\r\n\r\n if (Index < 0) or (Index > FSize) then\r\n raise EJclOutOfBoundsError.Create;\r\n\r\n if Result then\r\n begin\r\n if FDuplicates <> dupAccept then\r\n for I := 0 to FSize - 1 do\r\n if ItemsEqual(AValue, FElementData[I]) then\r\n begin\r\n Result := CheckDuplicate;\r\n Break;\r\n end;\r\n\r\n if Result then\r\n begin\r\n if FSize = FCapacity then\r\n AutoGrow;\r\n Result := FSize < FCapacity;\r\n if Result then\r\n begin\r\n if Index < FSize then\r\n MoveArray(FElementData, Index, Index + 1, FSize - Index);\r\n FElementData[Index] := AValue;\r\n Inc(FSize);\r\n end;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclCardinalArrayList.InsertAll(Index: Integer; const ACollection: IJclCardinalCollection): Boolean;\r\nvar\r\n It: IJclCardinalIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if (Index < 0) or (Index > FSize) then\r\n raise EJclOutOfBoundsError.Create;\r\n if ACollection = nil then\r\n Exit;\r\n\r\n Result := True;\r\n It := ACollection.Last;\r\n while It.HasPrevious do\r\n Result := Insert(Index, It.Previous) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclCardinalArrayList.IsEmpty: Boolean;\r\nbegin\r\n Result := FSize = 0;\r\nend;\r\n\r\nfunction TJclCardinalArrayList.Last: IJclCardinalIterator;\r\nbegin\r\n Result := TJclCardinalArrayIterator.Create(Self, FSize - 1, False, isLast);\r\nend;\r\n\r\nfunction TJclCardinalArrayList.LastIndexOf(AValue: Cardinal): Integer;\r\nvar\r\n I: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := -1;\r\n for I := FSize - 1 downto 0 do\r\n if ItemsEqual(FElementData[I], AValue) then\r\n begin\r\n Result := I;\r\n Break;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclCardinalArrayList.RaiseOutOfBoundsError: Cardinal;\r\nbegin\r\n raise EJclOutOfBoundsError.Create;\r\nend;\r\n\r\nfunction TJclCardinalArrayList.Remove(AValue: Cardinal): Boolean;\r\nvar\r\n Extracted: Cardinal;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := Extract(AValue);\r\n if Result then\r\n begin\r\n Extracted := AValue;\r\n FreeCardinal(Extracted);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclCardinalArrayList.RemoveAll(const ACollection: IJclCardinalCollection): Boolean;\r\nvar\r\n It: IJclCardinalIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n Result := Remove(It.Next) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclCardinalArrayList.RetainAll(const ACollection: IJclCardinalCollection): Boolean;\r\nvar\r\n I: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n for I := FSize - 1 downto 0 do\r\n if not ACollection.Contains(FElementData[I]) then\r\n Delete(I);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclCardinalArrayList.SetCapacity(Value: Integer);\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Value >= FSize then\r\n begin\r\n SetLength(FElementData, Value);\r\n inherited SetCapacity(Value);\r\n end\r\n else\r\n raise EJclOutOfBoundsError.Create;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclCardinalArrayList.SetValue(Index: Integer; AValue: Cardinal);\r\nvar\r\n ReplaceItem: Boolean;\r\n I: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if (Index < 0) or (Index >= FSize) then\r\n raise EJclOutOfBoundsError.Create;\r\n ReplaceItem := FAllowDefaultElements or not ItemsEqual(AValue, 0);\r\n if ReplaceItem then\r\n begin\r\n if FDuplicates <> dupAccept then\r\n for I := 0 to FSize - 1 do\r\n if ItemsEqual(FElementData[I], AValue) then\r\n begin\r\n ReplaceItem := CheckDuplicate;\r\n Break;\r\n end;\r\n if ReplaceItem then\r\n begin\r\n FreeCardinal(FElementData[Index]);\r\n FElementData[Index] := AValue;\r\n end;\r\n end;\r\n if not ReplaceItem then\r\n Delete(Index);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclCardinalArrayList.Size: Integer;\r\nbegin\r\n Result := FSize;\r\nend;\r\n\r\nfunction TJclCardinalArrayList.SubList(First, Count: Integer): IJclCardinalList;\r\nvar\r\n I: Integer;\r\n Last: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Last := First + Count - 1;\r\n if Last >= FSize then\r\n Last := FSize - 1;\r\n Result := CreateEmptyContainer as IJclCardinalList;\r\n for I := First to Last do\r\n Result.Add(FElementData[I]);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclCardinalArrayList.CreateEmptyContainer: TJclAbstractContainerBase;\r\nbegin\r\n Result := TJclCardinalArrayList.Create(FSize);\r\n AssignPropertiesTo(Result);\r\nend;\r\n\r\n//=== { TJclCardinalArrayIterator } ===============================================================\r\n\r\nconstructor TJclCardinalArrayIterator.Create(AOwnList: TJclCardinalArrayList; ACursor: Integer; AValid: Boolean; AStart: TItrStart);\r\nbegin\r\n inherited Create(AValid);\r\n FOwnList := AOwnList;\r\n FStart := AStart;\r\n FCursor := ACursor;\r\nend;\r\n\r\nfunction TJclCardinalArrayIterator.Add(AValue: Cardinal): Boolean;\r\nbegin\r\n Result := FOwnList.Add(AValue);\r\nend;\r\n\r\nprocedure TJclCardinalArrayIterator.AssignPropertiesTo(Dest: TJclAbstractIterator);\r\nvar\r\n ADest: TJclCardinalArrayIterator;\r\nbegin\r\n inherited AssignPropertiesTo(Dest);\r\n if Dest is TJclCardinalArrayIterator then\r\n begin\r\n ADest := TJclCardinalArrayIterator(Dest);\r\n ADest.FOwnList := FOwnList;\r\n ADest.FCursor := FCursor;\r\n ADest.FStart := FStart;\r\n end;\r\nend;\r\n\r\nfunction TJclCardinalArrayIterator.CreateEmptyIterator: TJclAbstractIterator;\r\nbegin\r\n Result := TJclCardinalArrayIterator.Create(FOwnList, FCursor, Valid, FStart);\r\nend;\r\n\r\nprocedure TJclCardinalArrayIterator.Extract;\r\nbegin\r\n CheckValid;\r\n Valid := False;\r\n FOwnList.ExtractIndex(FCursor);\r\nend;\r\n\r\nfunction TJclCardinalArrayIterator.GetValue: Cardinal;\r\nbegin\r\n CheckValid;\r\n Result := FOwnList.GetValue(FCursor);\r\nend;\r\n\r\nfunction TJclCardinalArrayIterator.HasNext: Boolean;\r\nbegin\r\n if Valid then\r\n Result := FCursor < (FOwnList.Size - 1)\r\n else\r\n Result := FCursor < FOwnList.Size;\r\nend;\r\n\r\nfunction TJclCardinalArrayIterator.HasPrevious: Boolean;\r\nbegin\r\n if Valid then\r\n Result := FCursor > 0\r\n else\r\n Result := FCursor >= 0;\r\nend;\r\n\r\nfunction TJclCardinalArrayIterator.Insert(AValue: Cardinal): Boolean;\r\nbegin\r\n CheckValid;\r\n Result := FOwnList.Insert(FCursor, AValue);\r\nend;\r\n\r\nfunction TJclCardinalArrayIterator.IteratorEquals(const AIterator: IJclCardinalIterator): Boolean;\r\nvar\r\n Obj: TObject;\r\n ItrObj: TJclCardinalArrayIterator;\r\nbegin\r\n Result := False;\r\n if AIterator = nil then\r\n Exit;\r\n Obj := AIterator.GetIteratorReference;\r\n if Obj is TJclCardinalArrayIterator then\r\n begin\r\n ItrObj := TJclCardinalArrayIterator(Obj);\r\n Result := (FOwnList = ItrObj.FOwnList) and (FCursor = ItrObj.FCursor) and (Valid = ItrObj.Valid);\r\n end;\r\nend;\r\n\r\n{$IFDEF SUPPORTS_FOR_IN}\r\nfunction TJclCardinalArrayIterator.MoveNext: Boolean;\r\nbegin\r\n if Valid then\r\n Inc(FCursor)\r\n else\r\n Valid := True;\r\n Result := FCursor < FOwnList.Size;\r\nend;\r\n{$ENDIF SUPPORTS_FOR_IN}\r\n\r\nfunction TJclCardinalArrayIterator.Next: Cardinal;\r\nbegin\r\n if Valid then\r\n Inc(FCursor)\r\n else\r\n Valid := True;\r\n Result := FOwnList.GetValue(FCursor);\r\nend;\r\n\r\nfunction TJclCardinalArrayIterator.NextIndex: Integer;\r\nbegin\r\n if Valid then\r\n Result := FCursor + 1\r\n else\r\n Result := FCursor;\r\nend;\r\n\r\nfunction TJclCardinalArrayIterator.Previous: Cardinal;\r\nbegin\r\n if Valid then\r\n Dec(FCursor)\r\n else\r\n Valid := True;\r\n Result := FOwnList.GetValue(FCursor);\r\nend;\r\n\r\nfunction TJclCardinalArrayIterator.PreviousIndex: Integer;\r\nbegin\r\n if Valid then\r\n Result := FCursor - 1\r\n else\r\n Result := FCursor;\r\nend;\r\n\r\nprocedure TJclCardinalArrayIterator.Remove;\r\nbegin\r\n CheckValid;\r\n Valid := False;\r\n FOwnList.Delete(FCursor);\r\nend;\r\n\r\nprocedure TJclCardinalArrayIterator.Reset;\r\nbegin\r\n Valid := False;\r\n case FStart of\r\n isFirst:\r\n FCursor := 0;\r\n isLast:\r\n FCursor := FOwnList.Size - 1;\r\n end;\r\nend;\r\n\r\nprocedure TJclCardinalArrayIterator.SetValue(AValue: Cardinal);\r\nbegin\r\n CheckValid;\r\n FOwnList.SetValue(FCursor, AValue);\r\nend;\r\n\r\n//=== { TJclInt64ArrayList } ======================================================\r\n\r\nconstructor TJclInt64ArrayList.Create(ACapacity: Integer);\r\nbegin\r\n inherited Create();\r\n SetCapacity(ACapacity);\r\nend;\r\n\r\nconstructor TJclInt64ArrayList.Create(const ACollection: IJclInt64Collection);\r\nbegin\r\n inherited Create();\r\n if ACollection = nil then\r\n raise EJclNoCollectionError.Create;\r\n SetCapacity(ACollection.Size);\r\n AddAll(ACollection);\r\nend;\r\n\r\ndestructor TJclInt64ArrayList.Destroy;\r\nbegin\r\n FReadOnly := False;\r\n Clear;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJclInt64ArrayList.Add(const AValue: Int64): Boolean;\r\nvar\r\n Index: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := FAllowDefaultElements or not ItemsEqual(AValue, 0);\r\n if Result then\r\n begin\r\n if FDuplicates <> dupAccept then\r\n for Index := 0 to FSize - 1 do\r\n if ItemsEqual(AValue, FElementData[Index]) then\r\n begin\r\n Result := CheckDuplicate;\r\n Break;\r\n end;\r\n\r\n if Result then\r\n begin\r\n if FSize = FCapacity then\r\n AutoGrow;\r\n Result := FSize < FCapacity;\r\n if Result then\r\n begin\r\n FElementData[FSize] := AValue;\r\n Inc(FSize);\r\n end;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclInt64ArrayList.AddAll(const ACollection: IJclInt64Collection): Boolean;\r\nvar\r\n It: IJclInt64Iterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n Result := Add(It.Next) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclInt64ArrayList.AssignDataTo(Dest: TJclAbstractContainerBase);\r\nvar\r\n ADest: TJclInt64ArrayList;\r\n ACollection: IJclInt64Collection;\r\nbegin\r\n inherited AssignDataTo(Dest);\r\n if Dest is TJclInt64ArrayList then\r\n begin\r\n ADest := TJclInt64ArrayList(Dest);\r\n ADest.Clear;\r\n ADest.AddAll(Self);\r\n end\r\n else\r\n if Supports(IInterface(Dest), IJclInt64Collection, ACollection) then\r\n begin\r\n ACollection.Clear;\r\n ACollection.AddAll(Self);\r\n end;\r\nend;\r\n\r\nprocedure TJclInt64ArrayList.Clear;\r\nvar\r\n I: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n for I := 0 to FSize - 1 do\r\n FreeInt64(FElementData[I]);\r\n FSize := 0;\r\n AutoPack;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclInt64ArrayList.CollectionEquals(const ACollection: IJclInt64Collection): Boolean;\r\nvar\r\n I: Integer;\r\n It: IJclInt64Iterator;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n if FSize <> ACollection.Size then\r\n Exit;\r\n It := ACollection.First;\r\n for I := 0 to FSize - 1 do\r\n if not ItemsEqual(FElementData[I], It.Next) then\r\n Exit;\r\n Result := True;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclInt64ArrayList.Contains(const AValue: Int64): Boolean;\r\nvar\r\n I: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n for I := 0 to FSize - 1 do\r\n if ItemsEqual(FElementData[I], AValue) then\r\n begin\r\n Result := True;\r\n Break;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclInt64ArrayList.ContainsAll(const ACollection: IJclInt64Collection): Boolean;\r\nvar\r\n It: IJclInt64Iterator;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := True;\r\n if ACollection = nil then\r\n Exit;\r\n It := ACollection.First;\r\n while Result and It.HasNext do\r\n Result := Contains(It.Next);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclInt64ArrayList.Delete(Index: Integer): Int64;\r\nvar\r\n Extracted: Int64;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Extracted := ExtractIndex(Index);\r\n Result := FreeInt64(Extracted);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclInt64ArrayList.Extract(const AValue: Int64): Boolean;\r\nvar\r\n I: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n for I := FSize - 1 downto 0 do\r\n if ItemsEqual(FElementData[I], AValue) then\r\n begin\r\n if I < (FSize - 1) then\r\n MoveArray(FElementData, I + 1, I, FSize - 1 - I)\r\n else\r\n FElementData[I] := 0;\r\n Dec(FSize);\r\n Result := True;\r\n if FRemoveSingleElement then\r\n Break;\r\n end;\r\n AutoPack;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclInt64ArrayList.ExtractAll(const ACollection: IJclInt64Collection): Boolean;\r\nvar\r\n It: IJclInt64Iterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n Result := Extract(It.Next) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclInt64ArrayList.ExtractIndex(Index: Integer): Int64;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if (Index >= 0) and (Index < FSize) then\r\n begin\r\n Result := FElementData[Index];\r\n if Index < (FSize - 1) then\r\n MoveArray(FElementData, Index + 1, Index, FSize - 1 - Index)\r\n else\r\n FElementData[Index] := 0;\r\n Dec(FSize);\r\n AutoPack;\r\n end\r\n else\r\n Result := RaiseOutOfBoundsError;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclInt64ArrayList.First: IJclInt64Iterator;\r\nbegin\r\n Result := TJclInt64ArrayIterator.Create(Self, 0, False, isFirst);\r\nend;\r\n\r\n{$IFDEF SUPPORTS_FOR_IN}\r\nfunction TJclInt64ArrayList.GetEnumerator: IJclInt64Iterator;\r\nbegin\r\n Result := TJclInt64ArrayIterator.Create(Self, 0, False, isFirst);\r\nend;\r\n{$ENDIF SUPPORTS_FOR_IN}\r\n\r\nfunction TJclInt64ArrayList.GetValue(Index: Integer): Int64;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := 0;\r\n if (Index >= 0) and (Index < FSize) then\r\n Result := FElementData[Index]\r\n else\r\n if not FReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create(IntToStr(Index));\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclInt64ArrayList.IndexOf(const AValue: Int64): Integer;\r\nvar\r\n I: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := -1;\r\n for I := 0 to FSize - 1 do\r\n if ItemsEqual(FElementData[I], AValue) then\r\n begin\r\n Result := I;\r\n Break;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclInt64ArrayList.Insert(Index: Integer; const AValue: Int64): Boolean;\r\nvar\r\n I: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := FAllowDefaultElements or not ItemsEqual(AValue, 0);\r\n\r\n if (Index < 0) or (Index > FSize) then\r\n raise EJclOutOfBoundsError.Create;\r\n\r\n if Result then\r\n begin\r\n if FDuplicates <> dupAccept then\r\n for I := 0 to FSize - 1 do\r\n if ItemsEqual(AValue, FElementData[I]) then\r\n begin\r\n Result := CheckDuplicate;\r\n Break;\r\n end;\r\n\r\n if Result then\r\n begin\r\n if FSize = FCapacity then\r\n AutoGrow;\r\n Result := FSize < FCapacity;\r\n if Result then\r\n begin\r\n if Index < FSize then\r\n MoveArray(FElementData, Index, Index + 1, FSize - Index);\r\n FElementData[Index] := AValue;\r\n Inc(FSize);\r\n end;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclInt64ArrayList.InsertAll(Index: Integer; const ACollection: IJclInt64Collection): Boolean;\r\nvar\r\n It: IJclInt64Iterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if (Index < 0) or (Index > FSize) then\r\n raise EJclOutOfBoundsError.Create;\r\n if ACollection = nil then\r\n Exit;\r\n\r\n Result := True;\r\n It := ACollection.Last;\r\n while It.HasPrevious do\r\n Result := Insert(Index, It.Previous) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclInt64ArrayList.IsEmpty: Boolean;\r\nbegin\r\n Result := FSize = 0;\r\nend;\r\n\r\nfunction TJclInt64ArrayList.Last: IJclInt64Iterator;\r\nbegin\r\n Result := TJclInt64ArrayIterator.Create(Self, FSize - 1, False, isLast);\r\nend;\r\n\r\nfunction TJclInt64ArrayList.LastIndexOf(const AValue: Int64): Integer;\r\nvar\r\n I: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := -1;\r\n for I := FSize - 1 downto 0 do\r\n if ItemsEqual(FElementData[I], AValue) then\r\n begin\r\n Result := I;\r\n Break;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclInt64ArrayList.RaiseOutOfBoundsError: Int64;\r\nbegin\r\n raise EJclOutOfBoundsError.Create;\r\nend;\r\n\r\nfunction TJclInt64ArrayList.Remove(const AValue: Int64): Boolean;\r\nvar\r\n Extracted: Int64;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := Extract(AValue);\r\n if Result then\r\n begin\r\n Extracted := AValue;\r\n FreeInt64(Extracted);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclInt64ArrayList.RemoveAll(const ACollection: IJclInt64Collection): Boolean;\r\nvar\r\n It: IJclInt64Iterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n Result := Remove(It.Next) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclInt64ArrayList.RetainAll(const ACollection: IJclInt64Collection): Boolean;\r\nvar\r\n I: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n for I := FSize - 1 downto 0 do\r\n if not ACollection.Contains(FElementData[I]) then\r\n Delete(I);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclInt64ArrayList.SetCapacity(Value: Integer);\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Value >= FSize then\r\n begin\r\n SetLength(FElementData, Value);\r\n inherited SetCapacity(Value);\r\n end\r\n else\r\n raise EJclOutOfBoundsError.Create;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclInt64ArrayList.SetValue(Index: Integer; const AValue: Int64);\r\nvar\r\n ReplaceItem: Boolean;\r\n I: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if (Index < 0) or (Index >= FSize) then\r\n raise EJclOutOfBoundsError.Create;\r\n ReplaceItem := FAllowDefaultElements or not ItemsEqual(AValue, 0);\r\n if ReplaceItem then\r\n begin\r\n if FDuplicates <> dupAccept then\r\n for I := 0 to FSize - 1 do\r\n if ItemsEqual(FElementData[I], AValue) then\r\n begin\r\n ReplaceItem := CheckDuplicate;\r\n Break;\r\n end;\r\n if ReplaceItem then\r\n begin\r\n FreeInt64(FElementData[Index]);\r\n FElementData[Index] := AValue;\r\n end;\r\n end;\r\n if not ReplaceItem then\r\n Delete(Index);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclInt64ArrayList.Size: Integer;\r\nbegin\r\n Result := FSize;\r\nend;\r\n\r\nfunction TJclInt64ArrayList.SubList(First, Count: Integer): IJclInt64List;\r\nvar\r\n I: Integer;\r\n Last: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Last := First + Count - 1;\r\n if Last >= FSize then\r\n Last := FSize - 1;\r\n Result := CreateEmptyContainer as IJclInt64List;\r\n for I := First to Last do\r\n Result.Add(FElementData[I]);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclInt64ArrayList.CreateEmptyContainer: TJclAbstractContainerBase;\r\nbegin\r\n Result := TJclInt64ArrayList.Create(FSize);\r\n AssignPropertiesTo(Result);\r\nend;\r\n\r\n//=== { TJclInt64ArrayIterator } ===============================================================\r\n\r\nconstructor TJclInt64ArrayIterator.Create(AOwnList: TJclInt64ArrayList; ACursor: Integer; AValid: Boolean; AStart: TItrStart);\r\nbegin\r\n inherited Create(AValid);\r\n FOwnList := AOwnList;\r\n FStart := AStart;\r\n FCursor := ACursor;\r\nend;\r\n\r\nfunction TJclInt64ArrayIterator.Add(const AValue: Int64): Boolean;\r\nbegin\r\n Result := FOwnList.Add(AValue);\r\nend;\r\n\r\nprocedure TJclInt64ArrayIterator.AssignPropertiesTo(Dest: TJclAbstractIterator);\r\nvar\r\n ADest: TJclInt64ArrayIterator;\r\nbegin\r\n inherited AssignPropertiesTo(Dest);\r\n if Dest is TJclInt64ArrayIterator then\r\n begin\r\n ADest := TJclInt64ArrayIterator(Dest);\r\n ADest.FOwnList := FOwnList;\r\n ADest.FCursor := FCursor;\r\n ADest.FStart := FStart;\r\n end;\r\nend;\r\n\r\nfunction TJclInt64ArrayIterator.CreateEmptyIterator: TJclAbstractIterator;\r\nbegin\r\n Result := TJclInt64ArrayIterator.Create(FOwnList, FCursor, Valid, FStart);\r\nend;\r\n\r\nprocedure TJclInt64ArrayIterator.Extract;\r\nbegin\r\n CheckValid;\r\n Valid := False;\r\n FOwnList.ExtractIndex(FCursor);\r\nend;\r\n\r\nfunction TJclInt64ArrayIterator.GetValue: Int64;\r\nbegin\r\n CheckValid;\r\n Result := FOwnList.GetValue(FCursor);\r\nend;\r\n\r\nfunction TJclInt64ArrayIterator.HasNext: Boolean;\r\nbegin\r\n if Valid then\r\n Result := FCursor < (FOwnList.Size - 1)\r\n else\r\n Result := FCursor < FOwnList.Size;\r\nend;\r\n\r\nfunction TJclInt64ArrayIterator.HasPrevious: Boolean;\r\nbegin\r\n if Valid then\r\n Result := FCursor > 0\r\n else\r\n Result := FCursor >= 0;\r\nend;\r\n\r\nfunction TJclInt64ArrayIterator.Insert(const AValue: Int64): Boolean;\r\nbegin\r\n CheckValid;\r\n Result := FOwnList.Insert(FCursor, AValue);\r\nend;\r\n\r\nfunction TJclInt64ArrayIterator.IteratorEquals(const AIterator: IJclInt64Iterator): Boolean;\r\nvar\r\n Obj: TObject;\r\n ItrObj: TJclInt64ArrayIterator;\r\nbegin\r\n Result := False;\r\n if AIterator = nil then\r\n Exit;\r\n Obj := AIterator.GetIteratorReference;\r\n if Obj is TJclInt64ArrayIterator then\r\n begin\r\n ItrObj := TJclInt64ArrayIterator(Obj);\r\n Result := (FOwnList = ItrObj.FOwnList) and (FCursor = ItrObj.FCursor) and (Valid = ItrObj.Valid);\r\n end;\r\nend;\r\n\r\n{$IFDEF SUPPORTS_FOR_IN}\r\nfunction TJclInt64ArrayIterator.MoveNext: Boolean;\r\nbegin\r\n if Valid then\r\n Inc(FCursor)\r\n else\r\n Valid := True;\r\n Result := FCursor < FOwnList.Size;\r\nend;\r\n{$ENDIF SUPPORTS_FOR_IN}\r\n\r\nfunction TJclInt64ArrayIterator.Next: Int64;\r\nbegin\r\n if Valid then\r\n Inc(FCursor)\r\n else\r\n Valid := True;\r\n Result := FOwnList.GetValue(FCursor);\r\nend;\r\n\r\nfunction TJclInt64ArrayIterator.NextIndex: Integer;\r\nbegin\r\n if Valid then\r\n Result := FCursor + 1\r\n else\r\n Result := FCursor;\r\nend;\r\n\r\nfunction TJclInt64ArrayIterator.Previous: Int64;\r\nbegin\r\n if Valid then\r\n Dec(FCursor)\r\n else\r\n Valid := True;\r\n Result := FOwnList.GetValue(FCursor);\r\nend;\r\n\r\nfunction TJclInt64ArrayIterator.PreviousIndex: Integer;\r\nbegin\r\n if Valid then\r\n Result := FCursor - 1\r\n else\r\n Result := FCursor;\r\nend;\r\n\r\nprocedure TJclInt64ArrayIterator.Remove;\r\nbegin\r\n CheckValid;\r\n Valid := False;\r\n FOwnList.Delete(FCursor);\r\nend;\r\n\r\nprocedure TJclInt64ArrayIterator.Reset;\r\nbegin\r\n Valid := False;\r\n case FStart of\r\n isFirst:\r\n FCursor := 0;\r\n isLast:\r\n FCursor := FOwnList.Size - 1;\r\n end;\r\nend;\r\n\r\nprocedure TJclInt64ArrayIterator.SetValue(const AValue: Int64);\r\nbegin\r\n CheckValid;\r\n FOwnList.SetValue(FCursor, AValue);\r\nend;\r\n\r\n//=== { TJclPtrArrayList } ======================================================\r\n\r\nconstructor TJclPtrArrayList.Create(ACapacity: Integer);\r\nbegin\r\n inherited Create();\r\n SetCapacity(ACapacity);\r\nend;\r\n\r\nconstructor TJclPtrArrayList.Create(const ACollection: IJclPtrCollection);\r\nbegin\r\n inherited Create();\r\n if ACollection = nil then\r\n raise EJclNoCollectionError.Create;\r\n SetCapacity(ACollection.Size);\r\n AddAll(ACollection);\r\nend;\r\n\r\ndestructor TJclPtrArrayList.Destroy;\r\nbegin\r\n FReadOnly := False;\r\n Clear;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJclPtrArrayList.Add(APtr: Pointer): Boolean;\r\nvar\r\n Index: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := FAllowDefaultElements or not ItemsEqual(APtr, nil);\r\n if Result then\r\n begin\r\n if FDuplicates <> dupAccept then\r\n for Index := 0 to FSize - 1 do\r\n if ItemsEqual(APtr, FElementData[Index]) then\r\n begin\r\n Result := CheckDuplicate;\r\n Break;\r\n end;\r\n\r\n if Result then\r\n begin\r\n if FSize = FCapacity then\r\n AutoGrow;\r\n Result := FSize < FCapacity;\r\n if Result then\r\n begin\r\n FElementData[FSize] := APtr;\r\n Inc(FSize);\r\n end;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclPtrArrayList.AddAll(const ACollection: IJclPtrCollection): Boolean;\r\nvar\r\n It: IJclPtrIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n Result := Add(It.Next) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclPtrArrayList.AssignDataTo(Dest: TJclAbstractContainerBase);\r\nvar\r\n ADest: TJclPtrArrayList;\r\n ACollection: IJclPtrCollection;\r\nbegin\r\n inherited AssignDataTo(Dest);\r\n if Dest is TJclPtrArrayList then\r\n begin\r\n ADest := TJclPtrArrayList(Dest);\r\n ADest.Clear;\r\n ADest.AddAll(Self);\r\n end\r\n else\r\n if Supports(IInterface(Dest), IJclPtrCollection, ACollection) then\r\n begin\r\n ACollection.Clear;\r\n ACollection.AddAll(Self);\r\n end;\r\nend;\r\n\r\nprocedure TJclPtrArrayList.Clear;\r\nvar\r\n I: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n for I := 0 to FSize - 1 do\r\n FreePointer(FElementData[I]);\r\n FSize := 0;\r\n AutoPack;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclPtrArrayList.CollectionEquals(const ACollection: IJclPtrCollection): Boolean;\r\nvar\r\n I: Integer;\r\n It: IJclPtrIterator;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n if FSize <> ACollection.Size then\r\n Exit;\r\n It := ACollection.First;\r\n for I := 0 to FSize - 1 do\r\n if not ItemsEqual(FElementData[I], It.Next) then\r\n Exit;\r\n Result := True;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclPtrArrayList.Contains(APtr: Pointer): Boolean;\r\nvar\r\n I: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n for I := 0 to FSize - 1 do\r\n if ItemsEqual(FElementData[I], APtr) then\r\n begin\r\n Result := True;\r\n Break;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclPtrArrayList.ContainsAll(const ACollection: IJclPtrCollection): Boolean;\r\nvar\r\n It: IJclPtrIterator;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := True;\r\n if ACollection = nil then\r\n Exit;\r\n It := ACollection.First;\r\n while Result and It.HasNext do\r\n Result := Contains(It.Next);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclPtrArrayList.Delete(Index: Integer): Pointer;\r\nvar\r\n Extracted: Pointer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Extracted := ExtractIndex(Index);\r\n Result := FreePointer(Extracted);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclPtrArrayList.Extract(APtr: Pointer): Boolean;\r\nvar\r\n I: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n for I := FSize - 1 downto 0 do\r\n if ItemsEqual(FElementData[I], APtr) then\r\n begin\r\n if I < (FSize - 1) then\r\n MoveArray(FElementData, I + 1, I, FSize - 1 - I)\r\n else\r\n FElementData[I] := nil;\r\n Dec(FSize);\r\n Result := True;\r\n if FRemoveSingleElement then\r\n Break;\r\n end;\r\n AutoPack;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclPtrArrayList.ExtractAll(const ACollection: IJclPtrCollection): Boolean;\r\nvar\r\n It: IJclPtrIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n Result := Extract(It.Next) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclPtrArrayList.ExtractIndex(Index: Integer): Pointer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if (Index >= 0) and (Index < FSize) then\r\n begin\r\n Result := FElementData[Index];\r\n if Index < (FSize - 1) then\r\n MoveArray(FElementData, Index + 1, Index, FSize - 1 - Index)\r\n else\r\n FElementData[Index] := nil;\r\n Dec(FSize);\r\n AutoPack;\r\n end\r\n else\r\n Result := RaiseOutOfBoundsError;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclPtrArrayList.First: IJclPtrIterator;\r\nbegin\r\n Result := TJclPtrArrayIterator.Create(Self, 0, False, isFirst);\r\nend;\r\n\r\n{$IFDEF SUPPORTS_FOR_IN}\r\nfunction TJclPtrArrayList.GetEnumerator: IJclPtrIterator;\r\nbegin\r\n Result := TJclPtrArrayIterator.Create(Self, 0, False, isFirst);\r\nend;\r\n{$ENDIF SUPPORTS_FOR_IN}\r\n\r\nfunction TJclPtrArrayList.GetPointer(Index: Integer): Pointer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := nil;\r\n if (Index >= 0) and (Index < FSize) then\r\n Result := FElementData[Index]\r\n else\r\n if not FReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create(IntToStr(Index));\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclPtrArrayList.IndexOf(APtr: Pointer): Integer;\r\nvar\r\n I: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := -1;\r\n for I := 0 to FSize - 1 do\r\n if ItemsEqual(FElementData[I], APtr) then\r\n begin\r\n Result := I;\r\n Break;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclPtrArrayList.Insert(Index: Integer; APtr: Pointer): Boolean;\r\nvar\r\n I: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := FAllowDefaultElements or not ItemsEqual(APtr, nil);\r\n\r\n if (Index < 0) or (Index > FSize) then\r\n raise EJclOutOfBoundsError.Create;\r\n\r\n if Result then\r\n begin\r\n if FDuplicates <> dupAccept then\r\n for I := 0 to FSize - 1 do\r\n if ItemsEqual(APtr, FElementData[I]) then\r\n begin\r\n Result := CheckDuplicate;\r\n Break;\r\n end;\r\n\r\n if Result then\r\n begin\r\n if FSize = FCapacity then\r\n AutoGrow;\r\n Result := FSize < FCapacity;\r\n if Result then\r\n begin\r\n if Index < FSize then\r\n MoveArray(FElementData, Index, Index + 1, FSize - Index);\r\n FElementData[Index] := APtr;\r\n Inc(FSize);\r\n end;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclPtrArrayList.InsertAll(Index: Integer; const ACollection: IJclPtrCollection): Boolean;\r\nvar\r\n It: IJclPtrIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if (Index < 0) or (Index > FSize) then\r\n raise EJclOutOfBoundsError.Create;\r\n if ACollection = nil then\r\n Exit;\r\n\r\n Result := True;\r\n It := ACollection.Last;\r\n while It.HasPrevious do\r\n Result := Insert(Index, It.Previous) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclPtrArrayList.IsEmpty: Boolean;\r\nbegin\r\n Result := FSize = 0;\r\nend;\r\n\r\nfunction TJclPtrArrayList.Last: IJclPtrIterator;\r\nbegin\r\n Result := TJclPtrArrayIterator.Create(Self, FSize - 1, False, isLast);\r\nend;\r\n\r\nfunction TJclPtrArrayList.LastIndexOf(APtr: Pointer): Integer;\r\nvar\r\n I: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := -1;\r\n for I := FSize - 1 downto 0 do\r\n if ItemsEqual(FElementData[I], APtr) then\r\n begin\r\n Result := I;\r\n Break;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclPtrArrayList.RaiseOutOfBoundsError: Pointer;\r\nbegin\r\n raise EJclOutOfBoundsError.Create;\r\nend;\r\n\r\nfunction TJclPtrArrayList.Remove(APtr: Pointer): Boolean;\r\nvar\r\n Extracted: Pointer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := Extract(APtr);\r\n if Result then\r\n begin\r\n Extracted := APtr;\r\n FreePointer(Extracted);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclPtrArrayList.RemoveAll(const ACollection: IJclPtrCollection): Boolean;\r\nvar\r\n It: IJclPtrIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n Result := Remove(It.Next) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclPtrArrayList.RetainAll(const ACollection: IJclPtrCollection): Boolean;\r\nvar\r\n I: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n for I := FSize - 1 downto 0 do\r\n if not ACollection.Contains(FElementData[I]) then\r\n Delete(I);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclPtrArrayList.SetCapacity(Value: Integer);\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Value >= FSize then\r\n begin\r\n SetLength(FElementData, Value);\r\n inherited SetCapacity(Value);\r\n end\r\n else\r\n raise EJclOutOfBoundsError.Create;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclPtrArrayList.SetPointer(Index: Integer; APtr: Pointer);\r\nvar\r\n ReplaceItem: Boolean;\r\n I: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if (Index < 0) or (Index >= FSize) then\r\n raise EJclOutOfBoundsError.Create;\r\n ReplaceItem := FAllowDefaultElements or not ItemsEqual(APtr, nil);\r\n if ReplaceItem then\r\n begin\r\n if FDuplicates <> dupAccept then\r\n for I := 0 to FSize - 1 do\r\n if ItemsEqual(FElementData[I], APtr) then\r\n begin\r\n ReplaceItem := CheckDuplicate;\r\n Break;\r\n end;\r\n if ReplaceItem then\r\n begin\r\n FreePointer(FElementData[Index]);\r\n FElementData[Index] := APtr;\r\n end;\r\n end;\r\n if not ReplaceItem then\r\n Delete(Index);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclPtrArrayList.Size: Integer;\r\nbegin\r\n Result := FSize;\r\nend;\r\n\r\nfunction TJclPtrArrayList.SubList(First, Count: Integer): IJclPtrList;\r\nvar\r\n I: Integer;\r\n Last: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Last := First + Count - 1;\r\n if Last >= FSize then\r\n Last := FSize - 1;\r\n Result := CreateEmptyContainer as IJclPtrList;\r\n for I := First to Last do\r\n Result.Add(FElementData[I]);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclPtrArrayList.CreateEmptyContainer: TJclAbstractContainerBase;\r\nbegin\r\n Result := TJclPtrArrayList.Create(FSize);\r\n AssignPropertiesTo(Result);\r\nend;\r\n\r\n//=== { TJclPtrArrayIterator } ===============================================================\r\n\r\nconstructor TJclPtrArrayIterator.Create(AOwnList: TJclPtrArrayList; ACursor: Integer; AValid: Boolean; AStart: TItrStart);\r\nbegin\r\n inherited Create(AValid);\r\n FOwnList := AOwnList;\r\n FStart := AStart;\r\n FCursor := ACursor;\r\nend;\r\n\r\nfunction TJclPtrArrayIterator.Add(APtr: Pointer): Boolean;\r\nbegin\r\n Result := FOwnList.Add(APtr);\r\nend;\r\n\r\nprocedure TJclPtrArrayIterator.AssignPropertiesTo(Dest: TJclAbstractIterator);\r\nvar\r\n ADest: TJclPtrArrayIterator;\r\nbegin\r\n inherited AssignPropertiesTo(Dest);\r\n if Dest is TJclPtrArrayIterator then\r\n begin\r\n ADest := TJclPtrArrayIterator(Dest);\r\n ADest.FOwnList := FOwnList;\r\n ADest.FCursor := FCursor;\r\n ADest.FStart := FStart;\r\n end;\r\nend;\r\n\r\nfunction TJclPtrArrayIterator.CreateEmptyIterator: TJclAbstractIterator;\r\nbegin\r\n Result := TJclPtrArrayIterator.Create(FOwnList, FCursor, Valid, FStart);\r\nend;\r\n\r\nprocedure TJclPtrArrayIterator.Extract;\r\nbegin\r\n CheckValid;\r\n Valid := False;\r\n FOwnList.ExtractIndex(FCursor);\r\nend;\r\n\r\nfunction TJclPtrArrayIterator.GetPointer: Pointer;\r\nbegin\r\n CheckValid;\r\n Result := FOwnList.GetPointer(FCursor);\r\nend;\r\n\r\nfunction TJclPtrArrayIterator.HasNext: Boolean;\r\nbegin\r\n if Valid then\r\n Result := FCursor < (FOwnList.Size - 1)\r\n else\r\n Result := FCursor < FOwnList.Size;\r\nend;\r\n\r\nfunction TJclPtrArrayIterator.HasPrevious: Boolean;\r\nbegin\r\n if Valid then\r\n Result := FCursor > 0\r\n else\r\n Result := FCursor >= 0;\r\nend;\r\n\r\nfunction TJclPtrArrayIterator.Insert(APtr: Pointer): Boolean;\r\nbegin\r\n CheckValid;\r\n Result := FOwnList.Insert(FCursor, APtr);\r\nend;\r\n\r\nfunction TJclPtrArrayIterator.IteratorEquals(const AIterator: IJclPtrIterator): Boolean;\r\nvar\r\n Obj: TObject;\r\n ItrObj: TJclPtrArrayIterator;\r\nbegin\r\n Result := False;\r\n if AIterator = nil then\r\n Exit;\r\n Obj := AIterator.GetIteratorReference;\r\n if Obj is TJclPtrArrayIterator then\r\n begin\r\n ItrObj := TJclPtrArrayIterator(Obj);\r\n Result := (FOwnList = ItrObj.FOwnList) and (FCursor = ItrObj.FCursor) and (Valid = ItrObj.Valid);\r\n end;\r\nend;\r\n\r\n{$IFDEF SUPPORTS_FOR_IN}\r\nfunction TJclPtrArrayIterator.MoveNext: Boolean;\r\nbegin\r\n if Valid then\r\n Inc(FCursor)\r\n else\r\n Valid := True;\r\n Result := FCursor < FOwnList.Size;\r\nend;\r\n{$ENDIF SUPPORTS_FOR_IN}\r\n\r\nfunction TJclPtrArrayIterator.Next: Pointer;\r\nbegin\r\n if Valid then\r\n Inc(FCursor)\r\n else\r\n Valid := True;\r\n Result := FOwnList.GetPointer(FCursor);\r\nend;\r\n\r\nfunction TJclPtrArrayIterator.NextIndex: Integer;\r\nbegin\r\n if Valid then\r\n Result := FCursor + 1\r\n else\r\n Result := FCursor;\r\nend;\r\n\r\nfunction TJclPtrArrayIterator.Previous: Pointer;\r\nbegin\r\n if Valid then\r\n Dec(FCursor)\r\n else\r\n Valid := True;\r\n Result := FOwnList.GetPointer(FCursor);\r\nend;\r\n\r\nfunction TJclPtrArrayIterator.PreviousIndex: Integer;\r\nbegin\r\n if Valid then\r\n Result := FCursor - 1\r\n else\r\n Result := FCursor;\r\nend;\r\n\r\nprocedure TJclPtrArrayIterator.Remove;\r\nbegin\r\n CheckValid;\r\n Valid := False;\r\n FOwnList.Delete(FCursor);\r\nend;\r\n\r\nprocedure TJclPtrArrayIterator.Reset;\r\nbegin\r\n Valid := False;\r\n case FStart of\r\n isFirst:\r\n FCursor := 0;\r\n isLast:\r\n FCursor := FOwnList.Size - 1;\r\n end;\r\nend;\r\n\r\nprocedure TJclPtrArrayIterator.SetPointer(APtr: Pointer);\r\nbegin\r\n CheckValid;\r\n FOwnList.SetPointer(FCursor, APtr);\r\nend;\r\n\r\n//=== { TJclArrayList } ======================================================\r\n\r\nconstructor TJclArrayList.Create(ACapacity: Integer; AOwnsObjects: Boolean);\r\nbegin\r\n inherited Create(AOwnsObjects);\r\n SetCapacity(ACapacity);\r\nend;\r\n\r\nconstructor TJclArrayList.Create(const ACollection: IJclCollection; AOwnsObjects: Boolean);\r\nbegin\r\n inherited Create(AOwnsObjects);\r\n if ACollection = nil then\r\n raise EJclNoCollectionError.Create;\r\n SetCapacity(ACollection.Size);\r\n AddAll(ACollection);\r\nend;\r\n\r\ndestructor TJclArrayList.Destroy;\r\nbegin\r\n FReadOnly := False;\r\n Clear;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJclArrayList.Add(AObject: TObject): Boolean;\r\nvar\r\n Index: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := FAllowDefaultElements or not ItemsEqual(AObject, nil);\r\n if Result then\r\n begin\r\n if FDuplicates <> dupAccept then\r\n for Index := 0 to FSize - 1 do\r\n if ItemsEqual(AObject, FElementData[Index]) then\r\n begin\r\n Result := CheckDuplicate;\r\n Break;\r\n end;\r\n\r\n if Result then\r\n begin\r\n if FSize = FCapacity then\r\n AutoGrow;\r\n Result := FSize < FCapacity;\r\n if Result then\r\n begin\r\n FElementData[FSize] := AObject;\r\n Inc(FSize);\r\n end;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclArrayList.AddAll(const ACollection: IJclCollection): Boolean;\r\nvar\r\n It: IJclIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n Result := Add(It.Next) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclArrayList.AssignDataTo(Dest: TJclAbstractContainerBase);\r\nvar\r\n ADest: TJclArrayList;\r\n ACollection: IJclCollection;\r\nbegin\r\n inherited AssignDataTo(Dest);\r\n if Dest is TJclArrayList then\r\n begin\r\n ADest := TJclArrayList(Dest);\r\n ADest.Clear;\r\n ADest.AddAll(Self);\r\n end\r\n else\r\n if Supports(IInterface(Dest), IJclCollection, ACollection) then\r\n begin\r\n ACollection.Clear;\r\n ACollection.AddAll(Self);\r\n end;\r\nend;\r\n\r\nprocedure TJclArrayList.Clear;\r\nvar\r\n I: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n for I := 0 to FSize - 1 do\r\n FreeObject(FElementData[I]);\r\n FSize := 0;\r\n AutoPack;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclArrayList.CollectionEquals(const ACollection: IJclCollection): Boolean;\r\nvar\r\n I: Integer;\r\n It: IJclIterator;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n if FSize <> ACollection.Size then\r\n Exit;\r\n It := ACollection.First;\r\n for I := 0 to FSize - 1 do\r\n if not ItemsEqual(FElementData[I], It.Next) then\r\n Exit;\r\n Result := True;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclArrayList.Contains(AObject: TObject): Boolean;\r\nvar\r\n I: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n for I := 0 to FSize - 1 do\r\n if ItemsEqual(FElementData[I], AObject) then\r\n begin\r\n Result := True;\r\n Break;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclArrayList.ContainsAll(const ACollection: IJclCollection): Boolean;\r\nvar\r\n It: IJclIterator;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := True;\r\n if ACollection = nil then\r\n Exit;\r\n It := ACollection.First;\r\n while Result and It.HasNext do\r\n Result := Contains(It.Next);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclArrayList.Delete(Index: Integer): TObject;\r\nvar\r\n Extracted: TObject;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Extracted := ExtractIndex(Index);\r\n Result := FreeObject(Extracted);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclArrayList.Extract(AObject: TObject): Boolean;\r\nvar\r\n I: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n for I := FSize - 1 downto 0 do\r\n if ItemsEqual(FElementData[I], AObject) then\r\n begin\r\n if I < (FSize - 1) then\r\n MoveArray(FElementData, I + 1, I, FSize - 1 - I)\r\n else\r\n FElementData[I] := nil;\r\n Dec(FSize);\r\n Result := True;\r\n if FRemoveSingleElement then\r\n Break;\r\n end;\r\n AutoPack;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclArrayList.ExtractAll(const ACollection: IJclCollection): Boolean;\r\nvar\r\n It: IJclIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n Result := Extract(It.Next) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclArrayList.ExtractIndex(Index: Integer): TObject;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if (Index >= 0) and (Index < FSize) then\r\n begin\r\n Result := FElementData[Index];\r\n if Index < (FSize - 1) then\r\n MoveArray(FElementData, Index + 1, Index, FSize - 1 - Index)\r\n else\r\n FElementData[Index] := nil;\r\n Dec(FSize);\r\n AutoPack;\r\n end\r\n else\r\n Result := RaiseOutOfBoundsError;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclArrayList.First: IJclIterator;\r\nbegin\r\n Result := TJclArrayIterator.Create(Self, 0, False, isFirst);\r\nend;\r\n\r\n{$IFDEF SUPPORTS_FOR_IN}\r\nfunction TJclArrayList.GetEnumerator: IJclIterator;\r\nbegin\r\n Result := TJclArrayIterator.Create(Self, 0, False, isFirst);\r\nend;\r\n{$ENDIF SUPPORTS_FOR_IN}\r\n\r\nfunction TJclArrayList.GetObject(Index: Integer): TObject;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := nil;\r\n if (Index >= 0) and (Index < FSize) then\r\n Result := FElementData[Index]\r\n else\r\n if not FReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create(IntToStr(Index));\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclArrayList.IndexOf(AObject: TObject): Integer;\r\nvar\r\n I: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := -1;\r\n for I := 0 to FSize - 1 do\r\n if ItemsEqual(FElementData[I], AObject) then\r\n begin\r\n Result := I;\r\n Break;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclArrayList.Insert(Index: Integer; AObject: TObject): Boolean;\r\nvar\r\n I: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := FAllowDefaultElements or not ItemsEqual(AObject, nil);\r\n\r\n if (Index < 0) or (Index > FSize) then\r\n raise EJclOutOfBoundsError.Create;\r\n\r\n if Result then\r\n begin\r\n if FDuplicates <> dupAccept then\r\n for I := 0 to FSize - 1 do\r\n if ItemsEqual(AObject, FElementData[I]) then\r\n begin\r\n Result := CheckDuplicate;\r\n Break;\r\n end;\r\n\r\n if Result then\r\n begin\r\n if FSize = FCapacity then\r\n AutoGrow;\r\n Result := FSize < FCapacity;\r\n if Result then\r\n begin\r\n if Index < FSize then\r\n MoveArray(FElementData, Index, Index + 1, FSize - Index);\r\n FElementData[Index] := AObject;\r\n Inc(FSize);\r\n end;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclArrayList.InsertAll(Index: Integer; const ACollection: IJclCollection): Boolean;\r\nvar\r\n It: IJclIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if (Index < 0) or (Index > FSize) then\r\n raise EJclOutOfBoundsError.Create;\r\n if ACollection = nil then\r\n Exit;\r\n\r\n Result := True;\r\n It := ACollection.Last;\r\n while It.HasPrevious do\r\n Result := Insert(Index, It.Previous) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclArrayList.IsEmpty: Boolean;\r\nbegin\r\n Result := FSize = 0;\r\nend;\r\n\r\nfunction TJclArrayList.Last: IJclIterator;\r\nbegin\r\n Result := TJclArrayIterator.Create(Self, FSize - 1, False, isLast);\r\nend;\r\n\r\nfunction TJclArrayList.LastIndexOf(AObject: TObject): Integer;\r\nvar\r\n I: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := -1;\r\n for I := FSize - 1 downto 0 do\r\n if ItemsEqual(FElementData[I], AObject) then\r\n begin\r\n Result := I;\r\n Break;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclArrayList.RaiseOutOfBoundsError: TObject;\r\nbegin\r\n raise EJclOutOfBoundsError.Create;\r\nend;\r\n\r\nfunction TJclArrayList.Remove(AObject: TObject): Boolean;\r\nvar\r\n Extracted: TObject;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := Extract(AObject);\r\n if Result then\r\n begin\r\n Extracted := AObject;\r\n FreeObject(Extracted);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclArrayList.RemoveAll(const ACollection: IJclCollection): Boolean;\r\nvar\r\n It: IJclIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n Result := Remove(It.Next) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclArrayList.RetainAll(const ACollection: IJclCollection): Boolean;\r\nvar\r\n I: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n for I := FSize - 1 downto 0 do\r\n if not ACollection.Contains(FElementData[I]) then\r\n Delete(I);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclArrayList.SetCapacity(Value: Integer);\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Value >= FSize then\r\n begin\r\n SetLength(FElementData, Value);\r\n inherited SetCapacity(Value);\r\n end\r\n else\r\n raise EJclOutOfBoundsError.Create;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclArrayList.SetObject(Index: Integer; AObject: TObject);\r\nvar\r\n ReplaceItem: Boolean;\r\n I: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if (Index < 0) or (Index >= FSize) then\r\n raise EJclOutOfBoundsError.Create;\r\n ReplaceItem := FAllowDefaultElements or not ItemsEqual(AObject, nil);\r\n if ReplaceItem then\r\n begin\r\n if FDuplicates <> dupAccept then\r\n for I := 0 to FSize - 1 do\r\n if ItemsEqual(FElementData[I], AObject) then\r\n begin\r\n ReplaceItem := CheckDuplicate;\r\n Break;\r\n end;\r\n if ReplaceItem then\r\n begin\r\n FreeObject(FElementData[Index]);\r\n FElementData[Index] := AObject;\r\n end;\r\n end;\r\n if not ReplaceItem then\r\n Delete(Index);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclArrayList.Size: Integer;\r\nbegin\r\n Result := FSize;\r\nend;\r\n\r\nfunction TJclArrayList.SubList(First, Count: Integer): IJclList;\r\nvar\r\n I: Integer;\r\n Last: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Last := First + Count - 1;\r\n if Last >= FSize then\r\n Last := FSize - 1;\r\n Result := CreateEmptyContainer as IJclList;\r\n for I := First to Last do\r\n Result.Add(FElementData[I]);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclArrayList.CreateEmptyContainer: TJclAbstractContainerBase;\r\nbegin\r\n Result := TJclArrayList.Create(FSize, False);\r\n AssignPropertiesTo(Result);\r\nend;\r\n\r\n//=== { TJclArrayIterator } ===============================================================\r\n\r\nconstructor TJclArrayIterator.Create(AOwnList: TJclArrayList; ACursor: Integer; AValid: Boolean; AStart: TItrStart);\r\nbegin\r\n inherited Create(AValid);\r\n FOwnList := AOwnList;\r\n FStart := AStart;\r\n FCursor := ACursor;\r\nend;\r\n\r\nfunction TJclArrayIterator.Add(AObject: TObject): Boolean;\r\nbegin\r\n Result := FOwnList.Add(AObject);\r\nend;\r\n\r\nprocedure TJclArrayIterator.AssignPropertiesTo(Dest: TJclAbstractIterator);\r\nvar\r\n ADest: TJclArrayIterator;\r\nbegin\r\n inherited AssignPropertiesTo(Dest);\r\n if Dest is TJclArrayIterator then\r\n begin\r\n ADest := TJclArrayIterator(Dest);\r\n ADest.FOwnList := FOwnList;\r\n ADest.FCursor := FCursor;\r\n ADest.FStart := FStart;\r\n end;\r\nend;\r\n\r\nfunction TJclArrayIterator.CreateEmptyIterator: TJclAbstractIterator;\r\nbegin\r\n Result := TJclArrayIterator.Create(FOwnList, FCursor, Valid, FStart);\r\nend;\r\n\r\nprocedure TJclArrayIterator.Extract;\r\nbegin\r\n CheckValid;\r\n Valid := False;\r\n FOwnList.ExtractIndex(FCursor);\r\nend;\r\n\r\nfunction TJclArrayIterator.GetObject: TObject;\r\nbegin\r\n CheckValid;\r\n Result := FOwnList.GetObject(FCursor);\r\nend;\r\n\r\nfunction TJclArrayIterator.HasNext: Boolean;\r\nbegin\r\n if Valid then\r\n Result := FCursor < (FOwnList.Size - 1)\r\n else\r\n Result := FCursor < FOwnList.Size;\r\nend;\r\n\r\nfunction TJclArrayIterator.HasPrevious: Boolean;\r\nbegin\r\n if Valid then\r\n Result := FCursor > 0\r\n else\r\n Result := FCursor >= 0;\r\nend;\r\n\r\nfunction TJclArrayIterator.Insert(AObject: TObject): Boolean;\r\nbegin\r\n CheckValid;\r\n Result := FOwnList.Insert(FCursor, AObject);\r\nend;\r\n\r\nfunction TJclArrayIterator.IteratorEquals(const AIterator: IJclIterator): Boolean;\r\nvar\r\n Obj: TObject;\r\n ItrObj: TJclArrayIterator;\r\nbegin\r\n Result := False;\r\n if AIterator = nil then\r\n Exit;\r\n Obj := AIterator.GetIteratorReference;\r\n if Obj is TJclArrayIterator then\r\n begin\r\n ItrObj := TJclArrayIterator(Obj);\r\n Result := (FOwnList = ItrObj.FOwnList) and (FCursor = ItrObj.FCursor) and (Valid = ItrObj.Valid);\r\n end;\r\nend;\r\n\r\n{$IFDEF SUPPORTS_FOR_IN}\r\nfunction TJclArrayIterator.MoveNext: Boolean;\r\nbegin\r\n if Valid then\r\n Inc(FCursor)\r\n else\r\n Valid := True;\r\n Result := FCursor < FOwnList.Size;\r\nend;\r\n{$ENDIF SUPPORTS_FOR_IN}\r\n\r\nfunction TJclArrayIterator.Next: TObject;\r\nbegin\r\n if Valid then\r\n Inc(FCursor)\r\n else\r\n Valid := True;\r\n Result := FOwnList.GetObject(FCursor);\r\nend;\r\n\r\nfunction TJclArrayIterator.NextIndex: Integer;\r\nbegin\r\n if Valid then\r\n Result := FCursor + 1\r\n else\r\n Result := FCursor;\r\nend;\r\n\r\nfunction TJclArrayIterator.Previous: TObject;\r\nbegin\r\n if Valid then\r\n Dec(FCursor)\r\n else\r\n Valid := True;\r\n Result := FOwnList.GetObject(FCursor);\r\nend;\r\n\r\nfunction TJclArrayIterator.PreviousIndex: Integer;\r\nbegin\r\n if Valid then\r\n Result := FCursor - 1\r\n else\r\n Result := FCursor;\r\nend;\r\n\r\nprocedure TJclArrayIterator.Remove;\r\nbegin\r\n CheckValid;\r\n Valid := False;\r\n FOwnList.Delete(FCursor);\r\nend;\r\n\r\nprocedure TJclArrayIterator.Reset;\r\nbegin\r\n Valid := False;\r\n case FStart of\r\n isFirst:\r\n FCursor := 0;\r\n isLast:\r\n FCursor := FOwnList.Size - 1;\r\n end;\r\nend;\r\n\r\nprocedure TJclArrayIterator.SetObject(AObject: TObject);\r\nbegin\r\n CheckValid;\r\n FOwnList.SetObject(FCursor, AObject);\r\nend;\r\n\r\n\r\n{$IFDEF SUPPORTS_GENERICS}\r\n//DOM-IGNORE-BEGIN\r\n\r\n//=== { TJclArrayList } ======================================================\r\n\r\nconstructor TJclArrayList.Create(ACapacity: Integer; AOwnsItems: Boolean);\r\nbegin\r\n inherited Create(AOwnsItems);\r\n SetCapacity(ACapacity);\r\nend;\r\n\r\nconstructor TJclArrayList.Create(const ACollection: IJclCollection; AOwnsItems: Boolean);\r\nbegin\r\n inherited Create(AOwnsItems);\r\n if ACollection = nil then\r\n raise EJclNoCollectionError.Create;\r\n SetCapacity(ACollection.Size);\r\n AddAll(ACollection);\r\nend;\r\n\r\ndestructor TJclArrayList.Destroy;\r\nbegin\r\n FReadOnly := False;\r\n Clear;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJclArrayList.Add(const AItem: T): Boolean;\r\nvar\r\n Index: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := FAllowDefaultElements or not ItemsEqual(AItem, Default(T));\r\n if Result then\r\n begin\r\n if FDuplicates <> dupAccept then\r\n for Index := 0 to FSize - 1 do\r\n if ItemsEqual(AItem, FElementData[Index]) then\r\n begin\r\n Result := CheckDuplicate;\r\n Break;\r\n end;\r\n\r\n if Result then\r\n begin\r\n if FSize = FCapacity then\r\n AutoGrow;\r\n Result := FSize < FCapacity;\r\n if Result then\r\n begin\r\n FElementData[FSize] := AItem;\r\n Inc(FSize);\r\n end;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclArrayList.AddAll(const ACollection: IJclCollection): Boolean;\r\nvar\r\n It: IJclIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n Result := Add(It.Next) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclArrayList.AssignDataTo(Dest: TJclAbstractContainerBase);\r\nvar\r\n ADest: TJclArrayList;\r\n ACollection: IJclCollection;\r\nbegin\r\n inherited AssignDataTo(Dest);\r\n if Dest is TJclArrayList then\r\n begin\r\n ADest := TJclArrayList(Dest);\r\n ADest.Clear;\r\n ADest.AddAll(Self);\r\n end\r\n else\r\n if Supports(IInterface(Dest), IJclCollection, ACollection) then\r\n begin\r\n ACollection.Clear;\r\n ACollection.AddAll(Self);\r\n end;\r\nend;\r\n\r\nprocedure TJclArrayList.Clear;\r\nvar\r\n I: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n for I := 0 to FSize - 1 do\r\n FreeItem(FElementData[I]);\r\n FSize := 0;\r\n AutoPack;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclArrayList.CollectionEquals(const ACollection: IJclCollection): Boolean;\r\nvar\r\n I: Integer;\r\n It: IJclIterator;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n if FSize <> ACollection.Size then\r\n Exit;\r\n It := ACollection.First;\r\n for I := 0 to FSize - 1 do\r\n if not ItemsEqual(FElementData[I], It.Next) then\r\n Exit;\r\n Result := True;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclArrayList.Contains(const AItem: T): Boolean;\r\nvar\r\n I: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n for I := 0 to FSize - 1 do\r\n if ItemsEqual(FElementData[I], AItem) then\r\n begin\r\n Result := True;\r\n Break;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclArrayList.ContainsAll(const ACollection: IJclCollection): Boolean;\r\nvar\r\n It: IJclIterator;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := True;\r\n if ACollection = nil then\r\n Exit;\r\n It := ACollection.First;\r\n while Result and It.HasNext do\r\n Result := Contains(It.Next);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclArrayList.Delete(Index: Integer): T;\r\nvar\r\n Extracted: T;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Extracted := ExtractIndex(Index);\r\n Result := FreeItem(Extracted);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclArrayList.Extract(const AItem: T): Boolean;\r\nvar\r\n I: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n for I := FSize - 1 downto 0 do\r\n if ItemsEqual(FElementData[I], AItem) then\r\n begin\r\n if I < (FSize - 1) then\r\n MoveArray(FElementData, I + 1, I, FSize - 1 - I)\r\n else\r\n FElementData[I] := Default(T);\r\n Dec(FSize);\r\n Result := True;\r\n if FRemoveSingleElement then\r\n Break;\r\n end;\r\n AutoPack;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclArrayList.ExtractAll(const ACollection: IJclCollection): Boolean;\r\nvar\r\n It: IJclIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n Result := Extract(It.Next) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclArrayList.ExtractIndex(Index: Integer): T;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if (Index >= 0) and (Index < FSize) then\r\n begin\r\n Result := FElementData[Index];\r\n if Index < (FSize - 1) then\r\n MoveArray(FElementData, Index + 1, Index, FSize - 1 - Index)\r\n else\r\n FElementData[Index] := Default(T);\r\n Dec(FSize);\r\n AutoPack;\r\n end\r\n else\r\n Result := RaiseOutOfBoundsError;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclArrayList.First: IJclIterator;\r\nbegin\r\n Result := TArrayIterator.Create(Self, 0, False, isFirst);\r\nend;\r\n\r\n{$IFDEF SUPPORTS_FOR_IN}\r\nfunction TJclArrayList.GetEnumerator: IJclIterator;\r\nbegin\r\n Result := TArrayIterator.Create(Self, 0, False, isFirst);\r\nend;\r\n{$ENDIF SUPPORTS_FOR_IN}\r\n\r\nfunction TJclArrayList.GetItem(Index: Integer): T;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := Default(T);\r\n if (Index >= 0) and (Index < FSize) then\r\n Result := FElementData[Index]\r\n else\r\n if not FReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create(IntToStr(Index));\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclArrayList.IndexOf(const AItem: T): Integer;\r\nvar\r\n I: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := -1;\r\n for I := 0 to FSize - 1 do\r\n if ItemsEqual(FElementData[I], AItem) then\r\n begin\r\n Result := I;\r\n Break;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclArrayList.Insert(Index: Integer; const AItem: T): Boolean;\r\nvar\r\n I: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := FAllowDefaultElements or not ItemsEqual(AItem, Default(T));\r\n\r\n if (Index < 0) or (Index > FSize) then\r\n raise EJclOutOfBoundsError.Create;\r\n\r\n if Result then\r\n begin\r\n if FDuplicates <> dupAccept then\r\n for I := 0 to FSize - 1 do\r\n if ItemsEqual(AItem, FElementData[I]) then\r\n begin\r\n Result := CheckDuplicate;\r\n Break;\r\n end;\r\n\r\n if Result then\r\n begin\r\n if FSize = FCapacity then\r\n AutoGrow;\r\n Result := FSize < FCapacity;\r\n if Result then\r\n begin\r\n if Index < FSize then\r\n MoveArray(FElementData, Index, Index + 1, FSize - Index);\r\n FElementData[Index] := AItem;\r\n Inc(FSize);\r\n end;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclArrayList.InsertAll(Index: Integer; const ACollection: IJclCollection): Boolean;\r\nvar\r\n It: IJclIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if (Index < 0) or (Index > FSize) then\r\n raise EJclOutOfBoundsError.Create;\r\n if ACollection = nil then\r\n Exit;\r\n\r\n Result := True;\r\n It := ACollection.Last;\r\n while It.HasPrevious do\r\n Result := Insert(Index, It.Previous) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclArrayList.IsEmpty: Boolean;\r\nbegin\r\n Result := FSize = 0;\r\nend;\r\n\r\nfunction TJclArrayList.Last: IJclIterator;\r\nbegin\r\n Result := TArrayIterator.Create(Self, FSize - 1, False, isLast);\r\nend;\r\n\r\nfunction TJclArrayList.LastIndexOf(const AItem: T): Integer;\r\nvar\r\n I: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := -1;\r\n for I := FSize - 1 downto 0 do\r\n if ItemsEqual(FElementData[I], AItem) then\r\n begin\r\n Result := I;\r\n Break;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclArrayList.RaiseOutOfBoundsError: T;\r\nbegin\r\n raise EJclOutOfBoundsError.Create;\r\nend;\r\n\r\nfunction TJclArrayList.Remove(const AItem: T): Boolean;\r\nvar\r\n Extracted: T;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := Extract(AItem);\r\n if Result then\r\n begin\r\n Extracted := AItem;\r\n FreeItem(Extracted);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclArrayList.RemoveAll(const ACollection: IJclCollection): Boolean;\r\nvar\r\n It: IJclIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n Result := Remove(It.Next) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclArrayList.RetainAll(const ACollection: IJclCollection): Boolean;\r\nvar\r\n I: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n for I := FSize - 1 downto 0 do\r\n if not ACollection.Contains(FElementData[I]) then\r\n Delete(I);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclArrayList.SetCapacity(Value: Integer);\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Value >= FSize then\r\n begin\r\n SetLength(FElementData, Value);\r\n inherited SetCapacity(Value);\r\n end\r\n else\r\n raise EJclOutOfBoundsError.Create;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclArrayList.SetItem(Index: Integer; const AItem: T);\r\nvar\r\n ReplaceItem: Boolean;\r\n I: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if (Index < 0) or (Index >= FSize) then\r\n raise EJclOutOfBoundsError.Create;\r\n ReplaceItem := FAllowDefaultElements or not ItemsEqual(AItem, Default(T));\r\n if ReplaceItem then\r\n begin\r\n if FDuplicates <> dupAccept then\r\n for I := 0 to FSize - 1 do\r\n if ItemsEqual(FElementData[I], AItem) then\r\n begin\r\n ReplaceItem := CheckDuplicate;\r\n Break;\r\n end;\r\n if ReplaceItem then\r\n begin\r\n FreeItem(FElementData[Index]);\r\n FElementData[Index] := AItem;\r\n end;\r\n end;\r\n if not ReplaceItem then\r\n Delete(Index);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclArrayList.Size: Integer;\r\nbegin\r\n Result := FSize;\r\nend;\r\n\r\nfunction TJclArrayList.SubList(First, Count: Integer): IJclList;\r\nvar\r\n I: Integer;\r\n Last: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Last := First + Count - 1;\r\n if Last >= FSize then\r\n Last := FSize - 1;\r\n Result := CreateEmptyContainer as IJclList;\r\n for I := First to Last do\r\n Result.Add(FElementData[I]);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclArrayList.MoveArray(var List: TDynArray; FromIndex, ToIndex, Count: SizeInt);\r\nvar\r\n I: SizeInt;\r\nbegin\r\n if FromIndex < ToIndex then\r\n begin\r\n for I := Count - 1 downto 0 do\r\n List[ToIndex + I] := List[FromIndex + I];\r\n\r\n if (ToIndex - FromIndex) < Count then\r\n // overlapped source and target\r\n for I := 0 to ToIndex - FromIndex - 1 do\r\n List[FromIndex + I] := Default(T)\r\n else\r\n // independant\r\n for I := 0 to Count - 1 do\r\n List[FromIndex + I] := Default(T);\r\n end\r\n else\r\n begin\r\n for I := 0 to Count - 1 do\r\n List[ToIndex + I] := List[FromIndex + I];\r\n\r\n if (FromIndex - ToIndex) < Count then\r\n // overlapped source and target\r\n for I := Count - FromIndex + ToIndex to Count - 1 do\r\n List[FromIndex + I] := Default(T)\r\n else\r\n // independant\r\n for I := 0 to Count - 1 do\r\n List[FromIndex + I] := Default(T);\r\n end; \r\nend;\r\n\r\n//=== { TJclArrayIterator } ===============================================================\r\n\r\nconstructor TJclArrayIterator.Create(AOwnList: IJclList; ACursor: Integer; AValid: Boolean; AStart: TItrStart);\r\nbegin\r\n inherited Create(AValid);\r\n FOwnList := AOwnList;\r\n FStart := AStart;\r\n FCursor := ACursor;\r\nend;\r\n\r\nfunction TJclArrayIterator.Add(const AItem: T): Boolean;\r\nbegin\r\n Result := FOwnList.Add(AItem);\r\nend;\r\n\r\nprocedure TJclArrayIterator.AssignPropertiesTo(Dest: TJclAbstractIterator);\r\nvar\r\n ADest: TJclArrayIterator;\r\nbegin\r\n inherited AssignPropertiesTo(Dest);\r\n if Dest is TJclArrayIterator then\r\n begin\r\n ADest := TJclArrayIterator(Dest);\r\n ADest.FOwnList := FOwnList;\r\n ADest.FCursor := FCursor;\r\n ADest.FStart := FStart;\r\n end;\r\nend;\r\n\r\nfunction TJclArrayIterator.CreateEmptyIterator: TJclAbstractIterator;\r\nbegin\r\n Result := TJclArrayIterator.Create(FOwnList, FCursor, Valid, FStart);\r\nend;\r\n\r\nprocedure TJclArrayIterator.Extract;\r\nbegin\r\n CheckValid;\r\n Valid := False;\r\n FOwnList.ExtractIndex(FCursor);\r\nend;\r\n\r\nfunction TJclArrayIterator.GetItem: T;\r\nbegin\r\n CheckValid;\r\n Result := FOwnList.GetItem(FCursor);\r\nend;\r\n\r\nfunction TJclArrayIterator.HasNext: Boolean;\r\nbegin\r\n if Valid then\r\n Result := FCursor < (FOwnList.Size - 1)\r\n else\r\n Result := FCursor < FOwnList.Size;\r\nend;\r\n\r\nfunction TJclArrayIterator.HasPrevious: Boolean;\r\nbegin\r\n if Valid then\r\n Result := FCursor > 0\r\n else\r\n Result := FCursor >= 0;\r\nend;\r\n\r\nfunction TJclArrayIterator.Insert(const AItem: T): Boolean;\r\nbegin\r\n CheckValid;\r\n Result := FOwnList.Insert(FCursor, AItem);\r\nend;\r\n\r\nfunction TJclArrayIterator.IteratorEquals(const AIterator: IJclIterator): Boolean;\r\nvar\r\n Obj: TObject;\r\n ItrObj: TJclArrayIterator;\r\nbegin\r\n Result := False;\r\n if AIterator = nil then\r\n Exit;\r\n Obj := AIterator.GetIteratorReference;\r\n if Obj is TJclArrayIterator then\r\n begin\r\n ItrObj := TJclArrayIterator(Obj);\r\n Result := (FOwnList = ItrObj.FOwnList) and (FCursor = ItrObj.FCursor) and (Valid = ItrObj.Valid);\r\n end;\r\nend;\r\n\r\n{$IFDEF SUPPORTS_FOR_IN}\r\nfunction TJclArrayIterator.MoveNext: Boolean;\r\nbegin\r\n if Valid then\r\n Inc(FCursor)\r\n else\r\n Valid := True;\r\n Result := FCursor < FOwnList.Size;\r\nend;\r\n{$ENDIF SUPPORTS_FOR_IN}\r\n\r\nfunction TJclArrayIterator.Next: T;\r\nbegin\r\n if Valid then\r\n Inc(FCursor)\r\n else\r\n Valid := True;\r\n Result := FOwnList.GetItem(FCursor);\r\nend;\r\n\r\nfunction TJclArrayIterator.NextIndex: Integer;\r\nbegin\r\n if Valid then\r\n Result := FCursor + 1\r\n else\r\n Result := FCursor;\r\nend;\r\n\r\nfunction TJclArrayIterator.Previous: T;\r\nbegin\r\n if Valid then\r\n Dec(FCursor)\r\n else\r\n Valid := True;\r\n Result := FOwnList.GetItem(FCursor);\r\nend;\r\n\r\nfunction TJclArrayIterator.PreviousIndex: Integer;\r\nbegin\r\n if Valid then\r\n Result := FCursor - 1\r\n else\r\n Result := FCursor;\r\nend;\r\n\r\nprocedure TJclArrayIterator.Remove;\r\nbegin\r\n CheckValid;\r\n Valid := False;\r\n FOwnList.Delete(FCursor);\r\nend;\r\n\r\nprocedure TJclArrayIterator.Reset;\r\nbegin\r\n Valid := False;\r\n case FStart of\r\n isFirst:\r\n FCursor := 0;\r\n isLast:\r\n FCursor := FOwnList.Size - 1;\r\n end;\r\nend;\r\n\r\nprocedure TJclArrayIterator.SetItem(const AItem: T);\r\nbegin\r\n CheckValid;\r\n FOwnList.SetItem(FCursor, AItem);\r\nend;\r\n\r\n//=== { TJclArrayListE } ==================================================\r\n\r\nconstructor TJclArrayListE.Create(const AEqualityComparer: IJclEqualityComparer; ACapacity: Integer;\r\n AOwnsItems: Boolean);\r\nbegin\r\n inherited Create(ACapacity, AOwnsItems);\r\n FEqualityComparer := AEqualityComparer;\r\nend;\r\n\r\nconstructor TJclArrayListE.Create(const AEqualityComparer: IJclEqualityComparer;\r\n const ACollection: IJclCollection; AOwnsItems: Boolean);\r\nbegin\r\n inherited Create(ACollection, AOwnsItems);\r\n FEqualityComparer := AEqualityComparer;\r\nend;\r\n\r\nprocedure TJclArrayListE.AssignPropertiesTo(Dest: TJclAbstractContainerBase);\r\nbegin\r\n inherited AssignPropertiesTo(Dest);\r\n if Dest is TJclArrayListE then\r\n TJclArrayListE(Dest).FEqualityComparer := FEqualityComparer;\r\nend;\r\n\r\nfunction TJclArrayListE.CreateEmptyContainer: TJclAbstractContainerBase;\r\nbegin\r\n Result := TJclArrayListE.Create(EqualityComparer, FSize, False);\r\n AssignPropertiesTo(Result);\r\nend;\r\n\r\nfunction TJclArrayListE.ItemsEqual(const A, B: T): Boolean;\r\nbegin\r\n if EqualityComparer <> nil then\r\n Result := EqualityComparer.ItemsEqual(A, B)\r\n else\r\n Result := inherited ItemsEqual(A, B);\r\nend;\r\n\r\n//=== { TJclArrayListF } ==================================================\r\n\r\nconstructor TJclArrayListF.Create(const AEqualityCompare: TEqualityCompare;\r\n ACapacity: Integer; AOwnsItems: Boolean);\r\nbegin\r\n inherited Create(ACapacity, AOwnsItems);\r\n SetEqualityCompare(AEqualityCompare);\r\nend;\r\n\r\nconstructor TJclArrayListF.Create(const AEqualityCompare: TEqualityCompare; const ACollection: IJclCollection;\r\n AOwnsItems: Boolean);\r\nbegin\r\n inherited Create(ACollection, AOwnsItems);\r\n SetEqualityCompare(AEqualityCompare);\r\nend;\r\n\r\nfunction TJclArrayListF.CreateEmptyContainer: TJclAbstractContainerBase;\r\nbegin\r\n Result := TJclArrayListF.Create(EqualityCompare, FSize, False);\r\n AssignPropertiesTo(Result);\r\nend;\r\n\r\n//=== { TJclArrayListI } ==================================================\r\n\r\nfunction TJclArrayListI.CreateEmptyContainer: TJclAbstractContainerBase;\r\nbegin\r\n Result := TJclArrayListI.Create(FSize, False);\r\n AssignPropertiesTo(Result);\r\nend;\r\n\r\nfunction TJclArrayListI.ItemsEqual(const A, B: T): Boolean;\r\nbegin\r\n if Assigned(FEqualityCompare) then\r\n Result := FEqualityCompare(A, B)\r\n else\r\n if Assigned(FCompare) then\r\n Result := FCompare(A, B) = 0\r\n else\r\n Result := A.Equals(B);\r\nend;\r\n\r\n//DOM-IGNORE-END\r\n{$ENDIF SUPPORTS_GENERICS}\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n\r\n" }, { "path": "External/Jedi/Jcl/source/common/JclArraySets.pas", "content": "{**************************************************************************************************}\r\n{ WARNING: JEDI preprocessor generated unit. Do not edit. }\r\n{**************************************************************************************************}\r\n\r\n{**************************************************************************************************}\r\n{ }\r\n{ Project JEDI Code Library (JCL) }\r\n{ }\r\n{ The contents of this file are subject to the Mozilla Public License Version 1.1 (the \"License\"); }\r\n{ you may not use this file except in compliance with the License. You may obtain a copy of the }\r\n{ License at http://www.mozilla.org/MPL/ }\r\n{ }\r\n{ Software distributed under the License is distributed on an \"AS IS\" basis, WITHOUT WARRANTY OF }\r\n{ ANY KIND, either express or implied. See the License for the specific language governing rights }\r\n{ and limitations under the License. }\r\n{ }\r\n{ The Original Code is ArraySet.pas. }\r\n{ }\r\n{ The Initial Developer of the Original Code is Jean-Philippe BEMPEL aka RDM. Portions created by }\r\n{ Jean-Philippe BEMPEL are Copyright (C) Jean-Philippe BEMPEL (rdm_30 att yahoo dott com) }\r\n{ All rights reserved. }\r\n{ }\r\n{ Contributors: }\r\n{ Florent Ouchet (outchy) }\r\n{ }\r\n{**************************************************************************************************}\r\n{ }\r\n{ The Delphi Container Library }\r\n{ }\r\n{**************************************************************************************************}\r\n{ }\r\n{ Last modified: $Date:: 2012-02-21 18:37:18 +0100 (mar. 21 févr. 2012) $ }\r\n{ Revision: $Rev:: 3739 $ }\r\n{ Author: $Author:: outchy $ }\r\n{ }\r\n{**************************************************************************************************}\r\n\r\nunit JclArraySets;\r\n\r\n{$I jcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF HAS_UNITSCOPE}\r\n System.Classes,\r\n {$ELSE ~HAS_UNITSCOPE}\r\n Classes,\r\n {$ENDIF ~HAS_UNITSCOPE}\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n {$IFDEF SUPPORTS_GENERICS}\r\n JclAlgorithms,\r\n {$ENDIF SUPPORTS_GENERICS}\r\n JclBase, JclAbstractContainers, JclContainerIntf, JclArrayLists, JclSynch;\r\n\r\ntype\r\n TJclIntfArraySet = class(TJclIntfArrayList, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclIntfCloneable, IJclCloneable, IJclPackable, IJclGrowable, IJclBaseContainer,\r\n IJclIntfContainer, IJclIntfFlatContainer, IJclIntfEqualityComparer, IJclIntfComparer,\r\n IJclIntfCollection, IJclIntfList, IJclIntfArray, IJclIntfSet)\r\n protected\r\n function CreateEmptyContainer: TJclAbstractContainerBase; override;\r\n private\r\n function BinarySearch(const AInterface: IInterface): Integer;\r\n public\r\n { IJclIntfCollection }\r\n function Add(const AInterface: IInterface): Boolean;\r\n function AddAll(const ACollection: IJclIntfCollection): Boolean;\r\n function Contains(const AInterface: IInterface): Boolean;\r\n { IJclIntfList }\r\n function Insert(Index: Integer; const AInterface: IInterface): Boolean;\r\n { IJclIntfSet }\r\n procedure Intersect(const ACollection: IJclIntfCollection);\r\n procedure Subtract(const ACollection: IJclIntfCollection);\r\n procedure Union(const ACollection: IJclIntfCollection);\r\n end;\r\n\r\n TJclAnsiStrArraySet = class(TJclAnsiStrArrayList, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclIntfCloneable, IJclCloneable, IJclPackable, IJclGrowable, IJclBaseContainer,\r\n IJclAnsiStrContainer, IJclAnsiStrFlatContainer, IJclAnsiStrEqualityComparer, IJclAnsiStrComparer, IJclStrBaseContainer,\r\n IJclAnsiStrCollection, IJclAnsiStrList, IJclAnsiStrArray, IJclAnsiStrSet)\r\n protected\r\n function CreateEmptyContainer: TJclAbstractContainerBase; override;\r\n private\r\n function BinarySearch(const AString: AnsiString): Integer;\r\n public\r\n { IJclAnsiStrCollection }\r\n function Add(const AString: AnsiString): Boolean; override;\r\n function AddAll(const ACollection: IJclAnsiStrCollection): Boolean; override;\r\n function Contains(const AString: AnsiString): Boolean; override;\r\n { IJclAnsiStrList }\r\n function Insert(Index: Integer; const AString: AnsiString): Boolean;\r\n { IJclAnsiStrSet }\r\n procedure Intersect(const ACollection: IJclAnsiStrCollection);\r\n procedure Subtract(const ACollection: IJclAnsiStrCollection);\r\n procedure Union(const ACollection: IJclAnsiStrCollection);\r\n end;\r\n\r\n TJclWideStrArraySet = class(TJclWideStrArrayList, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclIntfCloneable, IJclCloneable, IJclPackable, IJclGrowable, IJclBaseContainer,\r\n IJclWideStrContainer, IJclWideStrFlatContainer, IJclWideStrEqualityComparer, IJclWideStrComparer, IJclStrBaseContainer,\r\n IJclWideStrCollection, IJclWideStrList, IJclWideStrArray, IJclWideStrSet)\r\n protected\r\n function CreateEmptyContainer: TJclAbstractContainerBase; override;\r\n private\r\n function BinarySearch(const AString: WideString): Integer;\r\n public\r\n { IJclWideStrCollection }\r\n function Add(const AString: WideString): Boolean; override;\r\n function AddAll(const ACollection: IJclWideStrCollection): Boolean; override;\r\n function Contains(const AString: WideString): Boolean; override;\r\n { IJclWideStrList }\r\n function Insert(Index: Integer; const AString: WideString): Boolean;\r\n { IJclWideStrSet }\r\n procedure Intersect(const ACollection: IJclWideStrCollection);\r\n procedure Subtract(const ACollection: IJclWideStrCollection);\r\n procedure Union(const ACollection: IJclWideStrCollection);\r\n end;\r\n\r\n {$IFDEF SUPPORTS_UNICODE_STRING}\r\n TJclUnicodeStrArraySet = class(TJclUnicodeStrArrayList, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclIntfCloneable, IJclCloneable, IJclPackable, IJclGrowable, IJclBaseContainer,\r\n IJclUnicodeStrContainer, IJclUnicodeStrFlatContainer, IJclUnicodeStrEqualityComparer, IJclUnicodeStrComparer, IJclStrBaseContainer,\r\n IJclUnicodeStrCollection, IJclUnicodeStrList, IJclUnicodeStrArray, IJclUnicodeStrSet)\r\n protected\r\n function CreateEmptyContainer: TJclAbstractContainerBase; override;\r\n private\r\n function BinarySearch(const AString: UnicodeString): Integer;\r\n public\r\n { IJclUnicodeStrCollection }\r\n function Add(const AString: UnicodeString): Boolean; override;\r\n function AddAll(const ACollection: IJclUnicodeStrCollection): Boolean; override;\r\n function Contains(const AString: UnicodeString): Boolean; override;\r\n { IJclUnicodeStrList }\r\n function Insert(Index: Integer; const AString: UnicodeString): Boolean;\r\n { IJclUnicodeStrSet }\r\n procedure Intersect(const ACollection: IJclUnicodeStrCollection);\r\n procedure Subtract(const ACollection: IJclUnicodeStrCollection);\r\n procedure Union(const ACollection: IJclUnicodeStrCollection);\r\n end;\r\n {$ENDIF SUPPORTS_UNICODE_STRING}\r\n\r\n {$IFDEF CONTAINER_ANSISTR}\r\n TJclStrArraySet = TJclAnsiStrArraySet;\r\n {$ENDIF CONTAINER_ANSISTR}\r\n {$IFDEF CONTAINER_WIDESTR}\r\n TJclStrArraySet = TJclWideStrArraySet;\r\n {$ENDIF CONTAINER_WIDESTR}\r\n {$IFDEF CONTAINER_UNICODESTR}\r\n TJclStrArraySet = TJclUnicodeStrArraySet;\r\n {$ENDIF CONTAINER_UNICODESTR}\r\n\r\n TJclSingleArraySet = class(TJclSingleArrayList, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclIntfCloneable, IJclCloneable, IJclPackable, IJclGrowable, IJclBaseContainer,\r\n IJclSingleContainer, IJclSingleFlatContainer, IJclSingleEqualityComparer, IJclSingleComparer,\r\n IJclSingleCollection, IJclSingleList, IJclSingleArray, IJclSingleSet)\r\n protected\r\n function CreateEmptyContainer: TJclAbstractContainerBase; override;\r\n private\r\n function BinarySearch(const AValue: Single): Integer;\r\n public\r\n { IJclSingleCollection }\r\n function Add(const AValue: Single): Boolean;\r\n function AddAll(const ACollection: IJclSingleCollection): Boolean;\r\n function Contains(const AValue: Single): Boolean;\r\n { IJclSingleList }\r\n function Insert(Index: Integer; const AValue: Single): Boolean;\r\n { IJclSingleSet }\r\n procedure Intersect(const ACollection: IJclSingleCollection);\r\n procedure Subtract(const ACollection: IJclSingleCollection);\r\n procedure Union(const ACollection: IJclSingleCollection);\r\n end;\r\n\r\n TJclDoubleArraySet = class(TJclDoubleArrayList, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclIntfCloneable, IJclCloneable, IJclPackable, IJclGrowable, IJclBaseContainer,\r\n IJclDoubleContainer, IJclDoubleFlatContainer, IJclDoubleEqualityComparer, IJclDoubleComparer,\r\n IJclDoubleCollection, IJclDoubleList, IJclDoubleArray, IJclDoubleSet)\r\n protected\r\n function CreateEmptyContainer: TJclAbstractContainerBase; override;\r\n private\r\n function BinarySearch(const AValue: Double): Integer;\r\n public\r\n { IJclDoubleCollection }\r\n function Add(const AValue: Double): Boolean;\r\n function AddAll(const ACollection: IJclDoubleCollection): Boolean;\r\n function Contains(const AValue: Double): Boolean;\r\n { IJclDoubleList }\r\n function Insert(Index: Integer; const AValue: Double): Boolean;\r\n { IJclDoubleSet }\r\n procedure Intersect(const ACollection: IJclDoubleCollection);\r\n procedure Subtract(const ACollection: IJclDoubleCollection);\r\n procedure Union(const ACollection: IJclDoubleCollection);\r\n end;\r\n\r\n TJclExtendedArraySet = class(TJclExtendedArrayList, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclIntfCloneable, IJclCloneable, IJclPackable, IJclGrowable, IJclBaseContainer,\r\n IJclExtendedContainer, IJclExtendedFlatContainer, IJclExtendedEqualityComparer, IJclExtendedComparer,\r\n IJclExtendedCollection, IJclExtendedList, IJclExtendedArray, IJclExtendedSet)\r\n protected\r\n function CreateEmptyContainer: TJclAbstractContainerBase; override;\r\n private\r\n function BinarySearch(const AValue: Extended): Integer;\r\n public\r\n { IJclExtendedCollection }\r\n function Add(const AValue: Extended): Boolean;\r\n function AddAll(const ACollection: IJclExtendedCollection): Boolean;\r\n function Contains(const AValue: Extended): Boolean;\r\n { IJclExtendedList }\r\n function Insert(Index: Integer; const AValue: Extended): Boolean;\r\n { IJclExtendedSet }\r\n procedure Intersect(const ACollection: IJclExtendedCollection);\r\n procedure Subtract(const ACollection: IJclExtendedCollection);\r\n procedure Union(const ACollection: IJclExtendedCollection);\r\n end;\r\n\r\n {$IFDEF MATH_SINGLE_PRECISION}\r\n TJclFloatArraySet = TJclSingleArraySet;\r\n {$ENDIF MATH_SINGLE_PRECISION}\r\n {$IFDEF MATH_DOUBLE_PRECISION}\r\n TJclFloatArraySet = TJclDoubleArraySet;\r\n {$ENDIF MATH_DOUBLE_PRECISION}\r\n {$IFDEF MATH_EXTENDED_PRECISION}\r\n TJclFloatArraySet = TJclExtendedArraySet;\r\n {$ENDIF MATH_EXTENDED_PRECISION}\r\n\r\n TJclIntegerArraySet = class(TJclIntegerArrayList, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclIntfCloneable, IJclCloneable, IJclPackable, IJclGrowable, IJclBaseContainer,\r\n IJclIntegerContainer, IJclIntegerFlatContainer, IJclIntegerEqualityComparer, IJclIntegerComparer,\r\n IJclIntegerCollection, IJclIntegerList, IJclIntegerArray, IJclIntegerSet)\r\n protected\r\n function CreateEmptyContainer: TJclAbstractContainerBase; override;\r\n private\r\n function BinarySearch(AValue: Integer): Integer;\r\n public\r\n { IJclIntegerCollection }\r\n function Add(AValue: Integer): Boolean;\r\n function AddAll(const ACollection: IJclIntegerCollection): Boolean;\r\n function Contains(AValue: Integer): Boolean;\r\n { IJclIntegerList }\r\n function Insert(Index: Integer; AValue: Integer): Boolean;\r\n { IJclIntegerSet }\r\n procedure Intersect(const ACollection: IJclIntegerCollection);\r\n procedure Subtract(const ACollection: IJclIntegerCollection);\r\n procedure Union(const ACollection: IJclIntegerCollection);\r\n end;\r\n\r\n TJclCardinalArraySet = class(TJclCardinalArrayList, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclIntfCloneable, IJclCloneable, IJclPackable, IJclGrowable, IJclBaseContainer,\r\n IJclCardinalContainer, IJclCardinalFlatContainer, IJclCardinalEqualityComparer, IJclCardinalComparer,\r\n IJclCardinalCollection, IJclCardinalList, IJclCardinalArray, IJclCardinalSet)\r\n protected\r\n function CreateEmptyContainer: TJclAbstractContainerBase; override;\r\n private\r\n function BinarySearch(AValue: Cardinal): Integer;\r\n public\r\n { IJclCardinalCollection }\r\n function Add(AValue: Cardinal): Boolean;\r\n function AddAll(const ACollection: IJclCardinalCollection): Boolean;\r\n function Contains(AValue: Cardinal): Boolean;\r\n { IJclCardinalList }\r\n function Insert(Index: Integer; AValue: Cardinal): Boolean;\r\n { IJclCardinalSet }\r\n procedure Intersect(const ACollection: IJclCardinalCollection);\r\n procedure Subtract(const ACollection: IJclCardinalCollection);\r\n procedure Union(const ACollection: IJclCardinalCollection);\r\n end;\r\n\r\n TJclInt64ArraySet = class(TJclInt64ArrayList, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclIntfCloneable, IJclCloneable, IJclPackable, IJclGrowable, IJclBaseContainer,\r\n IJclInt64Container, IJclInt64FlatContainer, IJclInt64EqualityComparer, IJclInt64Comparer,\r\n IJclInt64Collection, IJclInt64List, IJclInt64Array, IJclInt64Set)\r\n protected\r\n function CreateEmptyContainer: TJclAbstractContainerBase; override;\r\n private\r\n function BinarySearch(const AValue: Int64): Integer;\r\n public\r\n { IJclInt64Collection }\r\n function Add(const AValue: Int64): Boolean;\r\n function AddAll(const ACollection: IJclInt64Collection): Boolean;\r\n function Contains(const AValue: Int64): Boolean;\r\n { IJclInt64List }\r\n function Insert(Index: Integer; const AValue: Int64): Boolean;\r\n { IJclInt64Set }\r\n procedure Intersect(const ACollection: IJclInt64Collection);\r\n procedure Subtract(const ACollection: IJclInt64Collection);\r\n procedure Union(const ACollection: IJclInt64Collection);\r\n end;\r\n\r\n TJclPtrArraySet = class(TJclPtrArrayList, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclIntfCloneable, IJclCloneable, IJclPackable, IJclGrowable, IJclBaseContainer,\r\n IJclPtrContainer, IJclPtrFlatContainer, IJclPtrEqualityComparer, IJclPtrComparer,\r\n IJclPtrCollection, IJclPtrList, IJclPtrArray, IJclPtrSet)\r\n protected\r\n function CreateEmptyContainer: TJclAbstractContainerBase; override;\r\n private\r\n function BinarySearch(APtr: Pointer): Integer;\r\n public\r\n { IJclPtrCollection }\r\n function Add(APtr: Pointer): Boolean;\r\n function AddAll(const ACollection: IJclPtrCollection): Boolean;\r\n function Contains(APtr: Pointer): Boolean;\r\n { IJclPtrList }\r\n function Insert(Index: Integer; APtr: Pointer): Boolean;\r\n { IJclPtrSet }\r\n procedure Intersect(const ACollection: IJclPtrCollection);\r\n procedure Subtract(const ACollection: IJclPtrCollection);\r\n procedure Union(const ACollection: IJclPtrCollection);\r\n end;\r\n\r\n TJclArraySet = class(TJclArrayList, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclIntfCloneable, IJclCloneable, IJclPackable, IJclGrowable, IJclBaseContainer,\r\n IJclContainer, IJclFlatContainer, IJclEqualityComparer, IJclComparer, IJclObjectOwner,\r\n IJclCollection, IJclList, IJclArray, IJclSet)\r\n protected\r\n function CreateEmptyContainer: TJclAbstractContainerBase; override;\r\n private\r\n function BinarySearch(AObject: TObject): Integer;\r\n public\r\n { IJclCollection }\r\n function Add(AObject: TObject): Boolean;\r\n function AddAll(const ACollection: IJclCollection): Boolean;\r\n function Contains(AObject: TObject): Boolean;\r\n { IJclList }\r\n function Insert(Index: Integer; AObject: TObject): Boolean;\r\n { IJclSet }\r\n procedure Intersect(const ACollection: IJclCollection);\r\n procedure Subtract(const ACollection: IJclCollection);\r\n procedure Union(const ACollection: IJclCollection);\r\n end;\r\n\r\n\r\n {$IFDEF SUPPORTS_GENERICS}\r\n //DOM-IGNORE-BEGIN\r\n\r\n TJclArraySet = class(TJclArrayList, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclIntfCloneable, IJclCloneable, IJclPackable, IJclGrowable, IJclBaseContainer,\r\n IJclContainer, IJclFlatContainer, IJclEqualityComparer, IJclComparer, IJclItemOwner,\r\n IJclCollection, IJclList, IJclArray, IJclSet)\r\n private\r\n function BinarySearch(const AItem: T): Integer;\r\n public\r\n { IJclCollection }\r\n function Add(const AItem: T): Boolean;\r\n function AddAll(const ACollection: IJclCollection): Boolean;\r\n function Contains(const AItem: T): Boolean;\r\n { IJclList }\r\n function Insert(Index: Integer; const AItem: T): Boolean;\r\n { IJclSet }\r\n procedure Intersect(const ACollection: IJclCollection);\r\n procedure Subtract(const ACollection: IJclCollection);\r\n procedure Union(const ACollection: IJclCollection);\r\n end;\r\n\r\n // E = External helper to compare items\r\n TJclArraySetE = class(TJclArraySet, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclIntfCloneable, IJclCloneable, IJclPackable, IJclGrowable, IJclBaseContainer, IJclContainer, IJclItemOwner, IJclEqualityComparer, IJclComparer,\r\n IJclCollection, IJclList, IJclArray, IJclSet)\r\n private\r\n FComparer: IJclComparer;\r\n protected\r\n procedure AssignPropertiesTo(Dest: TJclAbstractContainerBase); override;\r\n function CreateEmptyContainer: TJclAbstractContainerBase; override;\r\n public\r\n constructor Create(const AComparer: IJclComparer; ACapacity: Integer; AOwnsItems: Boolean); overload;\r\n constructor Create(const AComparer: IJclComparer; const ACollection: IJclCollection; AOwnsItems: Boolean); overload;\r\n { IJclEqualityComparer }\r\n function ItemsCompare(const A, B: T): Integer; override;\r\n { IJclComparer }\r\n function ItemsEqual(const A, B: T): Boolean; override;\r\n property Comparer: IJclComparer read FComparer write FComparer;\r\n end;\r\n\r\n // F = Function to compare items\r\n TJclArraySetF = class(TJclArraySet, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclIntfCloneable, IJclCloneable, IJclPackable, IJclGrowable, IJclBaseContainer, IJclContainer, IJclItemOwner, IJclEqualityComparer, IJclComparer,\r\n IJclCollection, IJclList, IJclArray, IJclSet)\r\n protected\r\n function CreateEmptyContainer: TJclAbstractContainerBase; override;\r\n public\r\n constructor Create(const ACompare: TCompare; ACapacity: Integer; AOwnsItems: Boolean); overload;\r\n constructor Create(const ACompare: TCompare; const ACollection: IJclCollection; AOwnsItems: Boolean); overload;\r\n end;\r\n\r\n // I = Items can compare themselves to others\r\n TJclArraySetI> = class(TJclArraySet, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclIntfCloneable, IJclCloneable, IJclPackable, IJclGrowable, IJclBaseContainer, IJclContainer, IJclItemOwner, IJclEqualityComparer, IJclComparer,\r\n IJclCollection, IJclList, IJclArray, IJclSet)\r\n protected\r\n function CreateEmptyContainer: TJclAbstractContainerBase; override;\r\n public\r\n { IJclEqualityComparer }\r\n function ItemsCompare(const A, B: T): Integer; override;\r\n { IJclComparer }\r\n function ItemsEqual(const A, B: T): Boolean; override;\r\n end;\r\n\r\n //DOM-IGNORE-END\r\n {$ENDIF SUPPORTS_GENERICS}\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jcl.svn.sourceforge.net/svnroot/jcl/tags/JCL-2.4-Build4571/jcl/source/common/JclArraySets.pas $';\r\n Revision: '$Revision: 3739 $';\r\n Date: '$Date: 2012-02-21 18:37:18 +0100 (mar. 21 févr. 2012) $';\r\n LogPath: 'JCL\\source\\common';\r\n Extra: '';\r\n Data: nil\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n {$IFDEF HAS_UNITSCOPE}\r\n System.SysUtils;\r\n {$ELSE ~HAS_UNITSCOPE}\r\n SysUtils;\r\n {$ENDIF ~HAS_UNITSCOPE}\r\n\r\n//=== { TJclIntfArraySet } ====================================================\r\n\r\nfunction TJclIntfArraySet.Add(const AInterface: IInterface): Boolean;\r\nvar\r\n Idx: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := FAllowDefaultElements or not ItemsEqual(AInterface, nil);\r\n if Result then\r\n begin\r\n Idx := BinarySearch(AInterface);\r\n if Idx >= 0 then\r\n Result := not ItemsEqual(GetObject(Idx), AInterface) or CheckDuplicate\r\n else\r\n Result := True;\r\n if Result then\r\n Result := inherited Insert(Idx + 1, AInterface);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfArraySet.AddAll(const ACollection: IJclIntfCollection): Boolean;\r\nvar\r\n It: IJclIntfIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n Result := Add(It.Next) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfArraySet.BinarySearch(const AInterface: IInterface): Integer;\r\nvar\r\n HiPos, LoPos, CompPos: Integer;\r\n Comp: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n LoPos := 0;\r\n HiPos := Size - 1;\r\n CompPos := (HiPos + LoPos) div 2;\r\n while HiPos >= LoPos do\r\n begin\r\n Comp := ItemsCompare(GetObject(CompPos), AInterface);\r\n if Comp < 0 then\r\n LoPos := CompPos + 1\r\n else\r\n if Comp > 0 then\r\n HiPos := CompPos - 1\r\n else\r\n begin\r\n HiPos := CompPos;\r\n LoPos := CompPos + 1;\r\n end;\r\n CompPos := (HiPos + LoPos) div 2;\r\n end;\r\n Result := HiPos;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfArraySet.Contains(const AInterface: IInterface): Boolean;\r\nvar\r\n Idx: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Idx := BinarySearch(AInterface);\r\n if Idx >= 0 then\r\n Result := ItemsEqual(GetObject(Idx), AInterface)\r\n else\r\n Result := False;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfArraySet.Insert(Index: Integer; const AInterface: IInterface): Boolean;\r\nbegin\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nprocedure TJclIntfArraySet.Intersect(const ACollection: IJclIntfCollection);\r\nbegin\r\n RetainAll(ACollection);\r\nend;\r\n\r\nprocedure TJclIntfArraySet.Subtract(const ACollection: IJclIntfCollection);\r\nbegin\r\n RemoveAll(ACollection);\r\nend;\r\n\r\nprocedure TJclIntfArraySet.Union(const ACollection: IJclIntfCollection);\r\nbegin\r\n AddAll(ACollection);\r\nend;\r\n\r\nfunction TJclIntfArraySet.CreateEmptyContainer: TJclAbstractContainerBase;\r\nbegin\r\n Result := TJclIntfArraySet.Create(Size);\r\n AssignPropertiesTo(Result);\r\nend;\r\n\r\n//=== { TJclAnsiStrArraySet } ====================================================\r\n\r\nfunction TJclAnsiStrArraySet.Add(const AString: AnsiString): Boolean;\r\nvar\r\n Idx: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := FAllowDefaultElements or not ItemsEqual(AString, '');\r\n if Result then\r\n begin\r\n Idx := BinarySearch(AString);\r\n if Idx >= 0 then\r\n Result := not ItemsEqual(GetString(Idx), AString) or CheckDuplicate\r\n else\r\n Result := True;\r\n if Result then\r\n Result := inherited Insert(Idx + 1, AString);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclAnsiStrArraySet.AddAll(const ACollection: IJclAnsiStrCollection): Boolean;\r\nvar\r\n It: IJclAnsiStrIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n Result := Add(It.Next) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclAnsiStrArraySet.BinarySearch(const AString: AnsiString): Integer;\r\nvar\r\n HiPos, LoPos, CompPos: Integer;\r\n Comp: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n LoPos := 0;\r\n HiPos := Size - 1;\r\n CompPos := (HiPos + LoPos) div 2;\r\n while HiPos >= LoPos do\r\n begin\r\n Comp := ItemsCompare(GetString(CompPos), AString);\r\n if Comp < 0 then\r\n LoPos := CompPos + 1\r\n else\r\n if Comp > 0 then\r\n HiPos := CompPos - 1\r\n else\r\n begin\r\n HiPos := CompPos;\r\n LoPos := CompPos + 1;\r\n end;\r\n CompPos := (HiPos + LoPos) div 2;\r\n end;\r\n Result := HiPos;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclAnsiStrArraySet.Contains(const AString: AnsiString): Boolean;\r\nvar\r\n Idx: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Idx := BinarySearch(AString);\r\n if Idx >= 0 then\r\n Result := ItemsEqual(GetString(Idx), AString)\r\n else\r\n Result := False;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclAnsiStrArraySet.Insert(Index: Integer; const AString: AnsiString): Boolean;\r\nbegin\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nprocedure TJclAnsiStrArraySet.Intersect(const ACollection: IJclAnsiStrCollection);\r\nbegin\r\n RetainAll(ACollection);\r\nend;\r\n\r\nprocedure TJclAnsiStrArraySet.Subtract(const ACollection: IJclAnsiStrCollection);\r\nbegin\r\n RemoveAll(ACollection);\r\nend;\r\n\r\nprocedure TJclAnsiStrArraySet.Union(const ACollection: IJclAnsiStrCollection);\r\nbegin\r\n AddAll(ACollection);\r\nend;\r\n\r\nfunction TJclAnsiStrArraySet.CreateEmptyContainer: TJclAbstractContainerBase;\r\nbegin\r\n Result := TJclAnsiStrArraySet.Create(Size);\r\n AssignPropertiesTo(Result);\r\nend;\r\n\r\n//=== { TJclWideStrArraySet } ====================================================\r\n\r\nfunction TJclWideStrArraySet.Add(const AString: WideString): Boolean;\r\nvar\r\n Idx: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := FAllowDefaultElements or not ItemsEqual(AString, '');\r\n if Result then\r\n begin\r\n Idx := BinarySearch(AString);\r\n if Idx >= 0 then\r\n Result := not ItemsEqual(GetString(Idx), AString) or CheckDuplicate\r\n else\r\n Result := True;\r\n if Result then\r\n Result := inherited Insert(Idx + 1, AString);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclWideStrArraySet.AddAll(const ACollection: IJclWideStrCollection): Boolean;\r\nvar\r\n It: IJclWideStrIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n Result := Add(It.Next) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclWideStrArraySet.BinarySearch(const AString: WideString): Integer;\r\nvar\r\n HiPos, LoPos, CompPos: Integer;\r\n Comp: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n LoPos := 0;\r\n HiPos := Size - 1;\r\n CompPos := (HiPos + LoPos) div 2;\r\n while HiPos >= LoPos do\r\n begin\r\n Comp := ItemsCompare(GetString(CompPos), AString);\r\n if Comp < 0 then\r\n LoPos := CompPos + 1\r\n else\r\n if Comp > 0 then\r\n HiPos := CompPos - 1\r\n else\r\n begin\r\n HiPos := CompPos;\r\n LoPos := CompPos + 1;\r\n end;\r\n CompPos := (HiPos + LoPos) div 2;\r\n end;\r\n Result := HiPos;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclWideStrArraySet.Contains(const AString: WideString): Boolean;\r\nvar\r\n Idx: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Idx := BinarySearch(AString);\r\n if Idx >= 0 then\r\n Result := ItemsEqual(GetString(Idx), AString)\r\n else\r\n Result := False;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclWideStrArraySet.Insert(Index: Integer; const AString: WideString): Boolean;\r\nbegin\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nprocedure TJclWideStrArraySet.Intersect(const ACollection: IJclWideStrCollection);\r\nbegin\r\n RetainAll(ACollection);\r\nend;\r\n\r\nprocedure TJclWideStrArraySet.Subtract(const ACollection: IJclWideStrCollection);\r\nbegin\r\n RemoveAll(ACollection);\r\nend;\r\n\r\nprocedure TJclWideStrArraySet.Union(const ACollection: IJclWideStrCollection);\r\nbegin\r\n AddAll(ACollection);\r\nend;\r\n\r\nfunction TJclWideStrArraySet.CreateEmptyContainer: TJclAbstractContainerBase;\r\nbegin\r\n Result := TJclWideStrArraySet.Create(Size);\r\n AssignPropertiesTo(Result);\r\nend;\r\n\r\n{$IFDEF SUPPORTS_UNICODE_STRING}\r\n//=== { TJclUnicodeStrArraySet } ====================================================\r\n\r\nfunction TJclUnicodeStrArraySet.Add(const AString: UnicodeString): Boolean;\r\nvar\r\n Idx: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := FAllowDefaultElements or not ItemsEqual(AString, '');\r\n if Result then\r\n begin\r\n Idx := BinarySearch(AString);\r\n if Idx >= 0 then\r\n Result := not ItemsEqual(GetString(Idx), AString) or CheckDuplicate\r\n else\r\n Result := True;\r\n if Result then\r\n Result := inherited Insert(Idx + 1, AString);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclUnicodeStrArraySet.AddAll(const ACollection: IJclUnicodeStrCollection): Boolean;\r\nvar\r\n It: IJclUnicodeStrIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n Result := Add(It.Next) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclUnicodeStrArraySet.BinarySearch(const AString: UnicodeString): Integer;\r\nvar\r\n HiPos, LoPos, CompPos: Integer;\r\n Comp: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n LoPos := 0;\r\n HiPos := Size - 1;\r\n CompPos := (HiPos + LoPos) div 2;\r\n while HiPos >= LoPos do\r\n begin\r\n Comp := ItemsCompare(GetString(CompPos), AString);\r\n if Comp < 0 then\r\n LoPos := CompPos + 1\r\n else\r\n if Comp > 0 then\r\n HiPos := CompPos - 1\r\n else\r\n begin\r\n HiPos := CompPos;\r\n LoPos := CompPos + 1;\r\n end;\r\n CompPos := (HiPos + LoPos) div 2;\r\n end;\r\n Result := HiPos;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclUnicodeStrArraySet.Contains(const AString: UnicodeString): Boolean;\r\nvar\r\n Idx: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Idx := BinarySearch(AString);\r\n if Idx >= 0 then\r\n Result := ItemsEqual(GetString(Idx), AString)\r\n else\r\n Result := False;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclUnicodeStrArraySet.Insert(Index: Integer; const AString: UnicodeString): Boolean;\r\nbegin\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nprocedure TJclUnicodeStrArraySet.Intersect(const ACollection: IJclUnicodeStrCollection);\r\nbegin\r\n RetainAll(ACollection);\r\nend;\r\n\r\nprocedure TJclUnicodeStrArraySet.Subtract(const ACollection: IJclUnicodeStrCollection);\r\nbegin\r\n RemoveAll(ACollection);\r\nend;\r\n\r\nprocedure TJclUnicodeStrArraySet.Union(const ACollection: IJclUnicodeStrCollection);\r\nbegin\r\n AddAll(ACollection);\r\nend;\r\n\r\nfunction TJclUnicodeStrArraySet.CreateEmptyContainer: TJclAbstractContainerBase;\r\nbegin\r\n Result := TJclUnicodeStrArraySet.Create(Size);\r\n AssignPropertiesTo(Result);\r\nend;\r\n\r\n{$ENDIF SUPPORTS_UNICODE_STRING}\r\n\r\n//=== { TJclSingleArraySet } ====================================================\r\n\r\nfunction TJclSingleArraySet.Add(const AValue: Single): Boolean;\r\nvar\r\n Idx: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := FAllowDefaultElements or not ItemsEqual(AValue, 0.0);\r\n if Result then\r\n begin\r\n Idx := BinarySearch(AValue);\r\n if Idx >= 0 then\r\n Result := not ItemsEqual(GetValue(Idx), AValue) or CheckDuplicate\r\n else\r\n Result := True;\r\n if Result then\r\n Result := inherited Insert(Idx + 1, AValue);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSingleArraySet.AddAll(const ACollection: IJclSingleCollection): Boolean;\r\nvar\r\n It: IJclSingleIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n Result := Add(It.Next) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSingleArraySet.BinarySearch(const AValue: Single): Integer;\r\nvar\r\n HiPos, LoPos, CompPos: Integer;\r\n Comp: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n LoPos := 0;\r\n HiPos := Size - 1;\r\n CompPos := (HiPos + LoPos) div 2;\r\n while HiPos >= LoPos do\r\n begin\r\n Comp := ItemsCompare(GetValue(CompPos), AValue);\r\n if Comp < 0 then\r\n LoPos := CompPos + 1\r\n else\r\n if Comp > 0 then\r\n HiPos := CompPos - 1\r\n else\r\n begin\r\n HiPos := CompPos;\r\n LoPos := CompPos + 1;\r\n end;\r\n CompPos := (HiPos + LoPos) div 2;\r\n end;\r\n Result := HiPos;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSingleArraySet.Contains(const AValue: Single): Boolean;\r\nvar\r\n Idx: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Idx := BinarySearch(AValue);\r\n if Idx >= 0 then\r\n Result := ItemsEqual(GetValue(Idx), AValue)\r\n else\r\n Result := False;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSingleArraySet.Insert(Index: Integer; const AValue: Single): Boolean;\r\nbegin\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nprocedure TJclSingleArraySet.Intersect(const ACollection: IJclSingleCollection);\r\nbegin\r\n RetainAll(ACollection);\r\nend;\r\n\r\nprocedure TJclSingleArraySet.Subtract(const ACollection: IJclSingleCollection);\r\nbegin\r\n RemoveAll(ACollection);\r\nend;\r\n\r\nprocedure TJclSingleArraySet.Union(const ACollection: IJclSingleCollection);\r\nbegin\r\n AddAll(ACollection);\r\nend;\r\n\r\nfunction TJclSingleArraySet.CreateEmptyContainer: TJclAbstractContainerBase;\r\nbegin\r\n Result := TJclSingleArraySet.Create(Size);\r\n AssignPropertiesTo(Result);\r\nend;\r\n\r\n//=== { TJclDoubleArraySet } ====================================================\r\n\r\nfunction TJclDoubleArraySet.Add(const AValue: Double): Boolean;\r\nvar\r\n Idx: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := FAllowDefaultElements or not ItemsEqual(AValue, 0.0);\r\n if Result then\r\n begin\r\n Idx := BinarySearch(AValue);\r\n if Idx >= 0 then\r\n Result := not ItemsEqual(GetValue(Idx), AValue) or CheckDuplicate\r\n else\r\n Result := True;\r\n if Result then\r\n Result := inherited Insert(Idx + 1, AValue);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclDoubleArraySet.AddAll(const ACollection: IJclDoubleCollection): Boolean;\r\nvar\r\n It: IJclDoubleIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n Result := Add(It.Next) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclDoubleArraySet.BinarySearch(const AValue: Double): Integer;\r\nvar\r\n HiPos, LoPos, CompPos: Integer;\r\n Comp: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n LoPos := 0;\r\n HiPos := Size - 1;\r\n CompPos := (HiPos + LoPos) div 2;\r\n while HiPos >= LoPos do\r\n begin\r\n Comp := ItemsCompare(GetValue(CompPos), AValue);\r\n if Comp < 0 then\r\n LoPos := CompPos + 1\r\n else\r\n if Comp > 0 then\r\n HiPos := CompPos - 1\r\n else\r\n begin\r\n HiPos := CompPos;\r\n LoPos := CompPos + 1;\r\n end;\r\n CompPos := (HiPos + LoPos) div 2;\r\n end;\r\n Result := HiPos;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclDoubleArraySet.Contains(const AValue: Double): Boolean;\r\nvar\r\n Idx: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Idx := BinarySearch(AValue);\r\n if Idx >= 0 then\r\n Result := ItemsEqual(GetValue(Idx), AValue)\r\n else\r\n Result := False;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclDoubleArraySet.Insert(Index: Integer; const AValue: Double): Boolean;\r\nbegin\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nprocedure TJclDoubleArraySet.Intersect(const ACollection: IJclDoubleCollection);\r\nbegin\r\n RetainAll(ACollection);\r\nend;\r\n\r\nprocedure TJclDoubleArraySet.Subtract(const ACollection: IJclDoubleCollection);\r\nbegin\r\n RemoveAll(ACollection);\r\nend;\r\n\r\nprocedure TJclDoubleArraySet.Union(const ACollection: IJclDoubleCollection);\r\nbegin\r\n AddAll(ACollection);\r\nend;\r\n\r\nfunction TJclDoubleArraySet.CreateEmptyContainer: TJclAbstractContainerBase;\r\nbegin\r\n Result := TJclDoubleArraySet.Create(Size);\r\n AssignPropertiesTo(Result);\r\nend;\r\n\r\n//=== { TJclExtendedArraySet } ====================================================\r\n\r\nfunction TJclExtendedArraySet.Add(const AValue: Extended): Boolean;\r\nvar\r\n Idx: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := FAllowDefaultElements or not ItemsEqual(AValue, 0.0);\r\n if Result then\r\n begin\r\n Idx := BinarySearch(AValue);\r\n if Idx >= 0 then\r\n Result := not ItemsEqual(GetValue(Idx), AValue) or CheckDuplicate\r\n else\r\n Result := True;\r\n if Result then\r\n Result := inherited Insert(Idx + 1, AValue);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclExtendedArraySet.AddAll(const ACollection: IJclExtendedCollection): Boolean;\r\nvar\r\n It: IJclExtendedIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n Result := Add(It.Next) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclExtendedArraySet.BinarySearch(const AValue: Extended): Integer;\r\nvar\r\n HiPos, LoPos, CompPos: Integer;\r\n Comp: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n LoPos := 0;\r\n HiPos := Size - 1;\r\n CompPos := (HiPos + LoPos) div 2;\r\n while HiPos >= LoPos do\r\n begin\r\n Comp := ItemsCompare(GetValue(CompPos), AValue);\r\n if Comp < 0 then\r\n LoPos := CompPos + 1\r\n else\r\n if Comp > 0 then\r\n HiPos := CompPos - 1\r\n else\r\n begin\r\n HiPos := CompPos;\r\n LoPos := CompPos + 1;\r\n end;\r\n CompPos := (HiPos + LoPos) div 2;\r\n end;\r\n Result := HiPos;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclExtendedArraySet.Contains(const AValue: Extended): Boolean;\r\nvar\r\n Idx: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Idx := BinarySearch(AValue);\r\n if Idx >= 0 then\r\n Result := ItemsEqual(GetValue(Idx), AValue)\r\n else\r\n Result := False;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclExtendedArraySet.Insert(Index: Integer; const AValue: Extended): Boolean;\r\nbegin\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nprocedure TJclExtendedArraySet.Intersect(const ACollection: IJclExtendedCollection);\r\nbegin\r\n RetainAll(ACollection);\r\nend;\r\n\r\nprocedure TJclExtendedArraySet.Subtract(const ACollection: IJclExtendedCollection);\r\nbegin\r\n RemoveAll(ACollection);\r\nend;\r\n\r\nprocedure TJclExtendedArraySet.Union(const ACollection: IJclExtendedCollection);\r\nbegin\r\n AddAll(ACollection);\r\nend;\r\n\r\nfunction TJclExtendedArraySet.CreateEmptyContainer: TJclAbstractContainerBase;\r\nbegin\r\n Result := TJclExtendedArraySet.Create(Size);\r\n AssignPropertiesTo(Result);\r\nend;\r\n\r\n//=== { TJclIntegerArraySet } ====================================================\r\n\r\nfunction TJclIntegerArraySet.Add(AValue: Integer): Boolean;\r\nvar\r\n Idx: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := FAllowDefaultElements or not ItemsEqual(AValue, 0);\r\n if Result then\r\n begin\r\n Idx := BinarySearch(AValue);\r\n if Idx >= 0 then\r\n Result := not ItemsEqual(GetValue(Idx), AValue) or CheckDuplicate\r\n else\r\n Result := True;\r\n if Result then\r\n Result := inherited Insert(Idx + 1, AValue);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntegerArraySet.AddAll(const ACollection: IJclIntegerCollection): Boolean;\r\nvar\r\n It: IJclIntegerIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n Result := Add(It.Next) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntegerArraySet.BinarySearch(AValue: Integer): Integer;\r\nvar\r\n HiPos, LoPos, CompPos: Integer;\r\n Comp: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n LoPos := 0;\r\n HiPos := Size - 1;\r\n CompPos := (HiPos + LoPos) div 2;\r\n while HiPos >= LoPos do\r\n begin\r\n Comp := ItemsCompare(GetValue(CompPos), AValue);\r\n if Comp < 0 then\r\n LoPos := CompPos + 1\r\n else\r\n if Comp > 0 then\r\n HiPos := CompPos - 1\r\n else\r\n begin\r\n HiPos := CompPos;\r\n LoPos := CompPos + 1;\r\n end;\r\n CompPos := (HiPos + LoPos) div 2;\r\n end;\r\n Result := HiPos;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntegerArraySet.Contains(AValue: Integer): Boolean;\r\nvar\r\n Idx: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Idx := BinarySearch(AValue);\r\n if Idx >= 0 then\r\n Result := ItemsEqual(GetValue(Idx), AValue)\r\n else\r\n Result := False;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntegerArraySet.Insert(Index: Integer; AValue: Integer): Boolean;\r\nbegin\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nprocedure TJclIntegerArraySet.Intersect(const ACollection: IJclIntegerCollection);\r\nbegin\r\n RetainAll(ACollection);\r\nend;\r\n\r\nprocedure TJclIntegerArraySet.Subtract(const ACollection: IJclIntegerCollection);\r\nbegin\r\n RemoveAll(ACollection);\r\nend;\r\n\r\nprocedure TJclIntegerArraySet.Union(const ACollection: IJclIntegerCollection);\r\nbegin\r\n AddAll(ACollection);\r\nend;\r\n\r\nfunction TJclIntegerArraySet.CreateEmptyContainer: TJclAbstractContainerBase;\r\nbegin\r\n Result := TJclIntegerArraySet.Create(Size);\r\n AssignPropertiesTo(Result);\r\nend;\r\n\r\n//=== { TJclCardinalArraySet } ====================================================\r\n\r\nfunction TJclCardinalArraySet.Add(AValue: Cardinal): Boolean;\r\nvar\r\n Idx: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := FAllowDefaultElements or not ItemsEqual(AValue, 0);\r\n if Result then\r\n begin\r\n Idx := BinarySearch(AValue);\r\n if Idx >= 0 then\r\n Result := not ItemsEqual(GetValue(Idx), AValue) or CheckDuplicate\r\n else\r\n Result := True;\r\n if Result then\r\n Result := inherited Insert(Idx + 1, AValue);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclCardinalArraySet.AddAll(const ACollection: IJclCardinalCollection): Boolean;\r\nvar\r\n It: IJclCardinalIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n Result := Add(It.Next) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclCardinalArraySet.BinarySearch(AValue: Cardinal): Integer;\r\nvar\r\n HiPos, LoPos, CompPos: Integer;\r\n Comp: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n LoPos := 0;\r\n HiPos := Size - 1;\r\n CompPos := (HiPos + LoPos) div 2;\r\n while HiPos >= LoPos do\r\n begin\r\n Comp := ItemsCompare(GetValue(CompPos), AValue);\r\n if Comp < 0 then\r\n LoPos := CompPos + 1\r\n else\r\n if Comp > 0 then\r\n HiPos := CompPos - 1\r\n else\r\n begin\r\n HiPos := CompPos;\r\n LoPos := CompPos + 1;\r\n end;\r\n CompPos := (HiPos + LoPos) div 2;\r\n end;\r\n Result := HiPos;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclCardinalArraySet.Contains(AValue: Cardinal): Boolean;\r\nvar\r\n Idx: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Idx := BinarySearch(AValue);\r\n if Idx >= 0 then\r\n Result := ItemsEqual(GetValue(Idx), AValue)\r\n else\r\n Result := False;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclCardinalArraySet.Insert(Index: Integer; AValue: Cardinal): Boolean;\r\nbegin\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nprocedure TJclCardinalArraySet.Intersect(const ACollection: IJclCardinalCollection);\r\nbegin\r\n RetainAll(ACollection);\r\nend;\r\n\r\nprocedure TJclCardinalArraySet.Subtract(const ACollection: IJclCardinalCollection);\r\nbegin\r\n RemoveAll(ACollection);\r\nend;\r\n\r\nprocedure TJclCardinalArraySet.Union(const ACollection: IJclCardinalCollection);\r\nbegin\r\n AddAll(ACollection);\r\nend;\r\n\r\nfunction TJclCardinalArraySet.CreateEmptyContainer: TJclAbstractContainerBase;\r\nbegin\r\n Result := TJclCardinalArraySet.Create(Size);\r\n AssignPropertiesTo(Result);\r\nend;\r\n\r\n//=== { TJclInt64ArraySet } ====================================================\r\n\r\nfunction TJclInt64ArraySet.Add(const AValue: Int64): Boolean;\r\nvar\r\n Idx: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := FAllowDefaultElements or not ItemsEqual(AValue, 0);\r\n if Result then\r\n begin\r\n Idx := BinarySearch(AValue);\r\n if Idx >= 0 then\r\n Result := not ItemsEqual(GetValue(Idx), AValue) or CheckDuplicate\r\n else\r\n Result := True;\r\n if Result then\r\n Result := inherited Insert(Idx + 1, AValue);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclInt64ArraySet.AddAll(const ACollection: IJclInt64Collection): Boolean;\r\nvar\r\n It: IJclInt64Iterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n Result := Add(It.Next) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclInt64ArraySet.BinarySearch(const AValue: Int64): Integer;\r\nvar\r\n HiPos, LoPos, CompPos: Integer;\r\n Comp: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n LoPos := 0;\r\n HiPos := Size - 1;\r\n CompPos := (HiPos + LoPos) div 2;\r\n while HiPos >= LoPos do\r\n begin\r\n Comp := ItemsCompare(GetValue(CompPos), AValue);\r\n if Comp < 0 then\r\n LoPos := CompPos + 1\r\n else\r\n if Comp > 0 then\r\n HiPos := CompPos - 1\r\n else\r\n begin\r\n HiPos := CompPos;\r\n LoPos := CompPos + 1;\r\n end;\r\n CompPos := (HiPos + LoPos) div 2;\r\n end;\r\n Result := HiPos;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclInt64ArraySet.Contains(const AValue: Int64): Boolean;\r\nvar\r\n Idx: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Idx := BinarySearch(AValue);\r\n if Idx >= 0 then\r\n Result := ItemsEqual(GetValue(Idx), AValue)\r\n else\r\n Result := False;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclInt64ArraySet.Insert(Index: Integer; const AValue: Int64): Boolean;\r\nbegin\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nprocedure TJclInt64ArraySet.Intersect(const ACollection: IJclInt64Collection);\r\nbegin\r\n RetainAll(ACollection);\r\nend;\r\n\r\nprocedure TJclInt64ArraySet.Subtract(const ACollection: IJclInt64Collection);\r\nbegin\r\n RemoveAll(ACollection);\r\nend;\r\n\r\nprocedure TJclInt64ArraySet.Union(const ACollection: IJclInt64Collection);\r\nbegin\r\n AddAll(ACollection);\r\nend;\r\n\r\nfunction TJclInt64ArraySet.CreateEmptyContainer: TJclAbstractContainerBase;\r\nbegin\r\n Result := TJclInt64ArraySet.Create(Size);\r\n AssignPropertiesTo(Result);\r\nend;\r\n\r\n//=== { TJclPtrArraySet } ====================================================\r\n\r\nfunction TJclPtrArraySet.Add(APtr: Pointer): Boolean;\r\nvar\r\n Idx: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := FAllowDefaultElements or not ItemsEqual(APtr, nil);\r\n if Result then\r\n begin\r\n Idx := BinarySearch(APtr);\r\n if Idx >= 0 then\r\n Result := not ItemsEqual(GetPointer(Idx), APtr) or CheckDuplicate\r\n else\r\n Result := True;\r\n if Result then\r\n Result := inherited Insert(Idx + 1, APtr);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclPtrArraySet.AddAll(const ACollection: IJclPtrCollection): Boolean;\r\nvar\r\n It: IJclPtrIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n Result := Add(It.Next) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclPtrArraySet.BinarySearch(APtr: Pointer): Integer;\r\nvar\r\n HiPos, LoPos, CompPos: Integer;\r\n Comp: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n LoPos := 0;\r\n HiPos := Size - 1;\r\n CompPos := (HiPos + LoPos) div 2;\r\n while HiPos >= LoPos do\r\n begin\r\n Comp := ItemsCompare(GetPointer(CompPos), APtr);\r\n if Comp < 0 then\r\n LoPos := CompPos + 1\r\n else\r\n if Comp > 0 then\r\n HiPos := CompPos - 1\r\n else\r\n begin\r\n HiPos := CompPos;\r\n LoPos := CompPos + 1;\r\n end;\r\n CompPos := (HiPos + LoPos) div 2;\r\n end;\r\n Result := HiPos;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclPtrArraySet.Contains(APtr: Pointer): Boolean;\r\nvar\r\n Idx: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Idx := BinarySearch(APtr);\r\n if Idx >= 0 then\r\n Result := ItemsEqual(GetPointer(Idx), APtr)\r\n else\r\n Result := False;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclPtrArraySet.Insert(Index: Integer; APtr: Pointer): Boolean;\r\nbegin\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nprocedure TJclPtrArraySet.Intersect(const ACollection: IJclPtrCollection);\r\nbegin\r\n RetainAll(ACollection);\r\nend;\r\n\r\nprocedure TJclPtrArraySet.Subtract(const ACollection: IJclPtrCollection);\r\nbegin\r\n RemoveAll(ACollection);\r\nend;\r\n\r\nprocedure TJclPtrArraySet.Union(const ACollection: IJclPtrCollection);\r\nbegin\r\n AddAll(ACollection);\r\nend;\r\n\r\nfunction TJclPtrArraySet.CreateEmptyContainer: TJclAbstractContainerBase;\r\nbegin\r\n Result := TJclPtrArraySet.Create(Size);\r\n AssignPropertiesTo(Result);\r\nend;\r\n\r\n//=== { TJclArraySet } ====================================================\r\n\r\nfunction TJclArraySet.Add(AObject: TObject): Boolean;\r\nvar\r\n Idx: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := FAllowDefaultElements or not ItemsEqual(AObject, nil);\r\n if Result then\r\n begin\r\n Idx := BinarySearch(AObject);\r\n if Idx >= 0 then\r\n Result := not ItemsEqual(GetObject(Idx), AObject) or CheckDuplicate\r\n else\r\n Result := True;\r\n if Result then\r\n Result := inherited Insert(Idx + 1, AObject);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclArraySet.AddAll(const ACollection: IJclCollection): Boolean;\r\nvar\r\n It: IJclIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n Result := Add(It.Next) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclArraySet.BinarySearch(AObject: TObject): Integer;\r\nvar\r\n HiPos, LoPos, CompPos: Integer;\r\n Comp: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n LoPos := 0;\r\n HiPos := Size - 1;\r\n CompPos := (HiPos + LoPos) div 2;\r\n while HiPos >= LoPos do\r\n begin\r\n Comp := ItemsCompare(GetObject(CompPos), AObject);\r\n if Comp < 0 then\r\n LoPos := CompPos + 1\r\n else\r\n if Comp > 0 then\r\n HiPos := CompPos - 1\r\n else\r\n begin\r\n HiPos := CompPos;\r\n LoPos := CompPos + 1;\r\n end;\r\n CompPos := (HiPos + LoPos) div 2;\r\n end;\r\n Result := HiPos;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclArraySet.Contains(AObject: TObject): Boolean;\r\nvar\r\n Idx: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Idx := BinarySearch(AObject);\r\n if Idx >= 0 then\r\n Result := ItemsEqual(GetObject(Idx), AObject)\r\n else\r\n Result := False;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclArraySet.Insert(Index: Integer; AObject: TObject): Boolean;\r\nbegin\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nprocedure TJclArraySet.Intersect(const ACollection: IJclCollection);\r\nbegin\r\n RetainAll(ACollection);\r\nend;\r\n\r\nprocedure TJclArraySet.Subtract(const ACollection: IJclCollection);\r\nbegin\r\n RemoveAll(ACollection);\r\nend;\r\n\r\nprocedure TJclArraySet.Union(const ACollection: IJclCollection);\r\nbegin\r\n AddAll(ACollection);\r\nend;\r\n\r\nfunction TJclArraySet.CreateEmptyContainer: TJclAbstractContainerBase;\r\nbegin\r\n Result := TJclArraySet.Create(Size, False);\r\n AssignPropertiesTo(Result);\r\nend;\r\n\r\n\r\n{$IFDEF SUPPORTS_GENERICS}\r\n//DOM-IGNORE-BEGIN\r\n\r\n//=== { TJclArraySet } ====================================================\r\n\r\nfunction TJclArraySet.Add(const AItem: T): Boolean;\r\nvar\r\n Idx: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := FAllowDefaultElements or not ItemsEqual(AItem, Default(T));\r\n if Result then\r\n begin\r\n Idx := BinarySearch(AItem);\r\n if Idx >= 0 then\r\n Result := not ItemsEqual(GetItem(Idx), AItem) or CheckDuplicate\r\n else\r\n Result := True;\r\n if Result then\r\n Result := inherited Insert(Idx + 1, AItem);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclArraySet.AddAll(const ACollection: IJclCollection): Boolean;\r\nvar\r\n It: IJclIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n Result := Add(It.Next) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclArraySet.BinarySearch(const AItem: T): Integer;\r\nvar\r\n HiPos, LoPos, CompPos: Integer;\r\n Comp: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n LoPos := 0;\r\n HiPos := Size - 1;\r\n CompPos := (HiPos + LoPos) div 2;\r\n while HiPos >= LoPos do\r\n begin\r\n Comp := ItemsCompare(GetItem(CompPos), AItem);\r\n if Comp < 0 then\r\n LoPos := CompPos + 1\r\n else\r\n if Comp > 0 then\r\n HiPos := CompPos - 1\r\n else\r\n begin\r\n HiPos := CompPos;\r\n LoPos := CompPos + 1;\r\n end;\r\n CompPos := (HiPos + LoPos) div 2;\r\n end;\r\n Result := HiPos;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclArraySet.Contains(const AItem: T): Boolean;\r\nvar\r\n Idx: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Idx := BinarySearch(AItem);\r\n if Idx >= 0 then\r\n Result := ItemsEqual(GetItem(Idx), AItem)\r\n else\r\n Result := False;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclArraySet.Insert(Index: Integer; const AItem: T): Boolean;\r\nbegin\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nprocedure TJclArraySet.Intersect(const ACollection: IJclCollection);\r\nbegin\r\n RetainAll(ACollection);\r\nend;\r\n\r\nprocedure TJclArraySet.Subtract(const ACollection: IJclCollection);\r\nbegin\r\n RemoveAll(ACollection);\r\nend;\r\n\r\nprocedure TJclArraySet.Union(const ACollection: IJclCollection);\r\nbegin\r\n AddAll(ACollection);\r\nend;\r\n\r\n//=== { TJclArraySetE } ===================================================\r\n\r\nconstructor TJclArraySetE.Create(const AComparer: IJclComparer; ACapacity: Integer; AOwnsItems: Boolean);\r\nbegin\r\n inherited Create(ACapacity, AOwnsItems);\r\n FComparer := AComparer;\r\nend;\r\n\r\nconstructor TJclArraySetE.Create(const AComparer: IJclComparer; const ACollection: IJclCollection;\r\n AOwnsItems: Boolean);\r\nbegin\r\n inherited Create(ACollection, AOwnsItems);\r\n FComparer := AComparer;\r\nend;\r\n\r\nprocedure TJclArraySetE.AssignPropertiesTo(Dest: TJclAbstractContainerBase);\r\nbegin\r\n inherited AssignPropertiesTo(Dest);\r\n if Dest is TJclArraySetE then\r\n TJclArraySetE(Dest).FComparer := Comparer;\r\nend;\r\n\r\nfunction TJclArraySetE.CreateEmptyContainer: TJclAbstractContainerBase;\r\nbegin\r\n Result := TJclArraySetE.Create(Comparer, Size, False);\r\n AssignPropertiesTo(Result);\r\nend;\r\n\r\nfunction TJclArraySetE.ItemsCompare(const A, B: T): Integer;\r\nbegin\r\n if Comparer <> nil then\r\n Result := Comparer.Compare(A, B)\r\n else\r\n Result := inherited ItemsCompare(A, B);\r\nend;\r\n\r\nfunction TJclArraySetE.ItemsEqual(const A, B: T): Boolean;\r\nbegin\r\n if Comparer <> nil then\r\n Result := Comparer.Compare(A, B) = 0\r\n else\r\n Result := inherited ItemsEqual(A, B);\r\nend;\r\n\r\n//=== { TJclArraySetF } ===================================================\r\n\r\nconstructor TJclArraySetF.Create(const ACompare: TCompare; ACapacity: Integer; AOwnsItems: Boolean);\r\nbegin\r\n inherited Create(ACapacity, AOwnsItems);\r\n SetCompare(ACompare);\r\nend;\r\n\r\nconstructor TJclArraySetF.Create(const ACompare: TCompare; const ACollection: IJclCollection;\r\n AOwnsItems: Boolean);\r\nbegin\r\n inherited Create(ACollection, AOwnsItems);\r\n SetCompare(ACompare);\r\nend;\r\n\r\nfunction TJclArraySetF.CreateEmptyContainer: TJclAbstractContainerBase;\r\nbegin\r\n Result := TJclArraySetF.Create(Compare, Size, False);\r\n AssignPropertiesTo(Result);\r\nend;\r\n\r\n//=== { TJclArraySetI } ===================================================\r\n\r\nfunction TJclArraySetI.CreateEmptyContainer: TJclAbstractContainerBase;\r\nbegin\r\n Result := TJclArraySetI.Create(Size, False);\r\n AssignPropertiesTo(Result);\r\nend;\r\n\r\nfunction TJclArraySetI.ItemsCompare(const A, B: T): Integer;\r\nbegin\r\n if Assigned(FCompare) then\r\n Result := FCompare(A, B)\r\n else\r\n Result := A.CompareTo(B);\r\nend;\r\n\r\nfunction TJclArraySetI.ItemsEqual(const A, B: T): Boolean;\r\nbegin\r\n if Assigned(FEqualityCompare) then\r\n Result := FEqualityCompare(A, B)\r\n else\r\n if Assigned(FCompare) then\r\n Result := FCompare(A, B) = 0\r\n else\r\n Result := A.CompareTo(B) = 0;\r\nend;\r\n\r\n//DOM-IGNORE-END\r\n{$ENDIF SUPPORTS_GENERICS}\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n\r\n" }, { "path": "External/Jedi/Jcl/source/common/JclBase.pas", "content": "{**************************************************************************************************}\r\n{ }\r\n{ Project JEDI Code Library (JCL) }\r\n{ }\r\n{ The contents of this file are subject to the Mozilla Public License Version 1.1 (the \"License\"); }\r\n{ you may not use this file except in compliance with the License. You may obtain a copy of the }\r\n{ License at http://www.mozilla.org/MPL/ }\r\n{ }\r\n{ Software distributed under the License is distributed on an \"AS IS\" basis, WITHOUT WARRANTY OF }\r\n{ ANY KIND, either express or implied. See the License for the specific language governing rights }\r\n{ and limitations under the License. }\r\n{ }\r\n{ The Original Code is JclBase.pas. }\r\n{ }\r\n{ The Initial Developer of the Original Code is Marcel van Brakel. }\r\n{ Portions created by Marcel van Brakel are Copyright Marcel van Brakel. All rights reserved. }\r\n{ }\r\n{ Contributors: }\r\n{ Marcel van Brakel, }\r\n{ Peter Friese, }\r\n{ Robert Marquardt (marquardt) }\r\n{ Robert Rossmair (rrossmair) }\r\n{ Petr Vones (pvones) }\r\n{ Florent Ouchet (outchy) }\r\n{ }\r\n{**************************************************************************************************}\r\n{ }\r\n{ This unit contains generic JCL base classes and routines to support earlier }\r\n{ versions of Delphi as well as FPC. }\r\n{ }\r\n{**************************************************************************************************}\r\n{ }\r\n{ Last modified: $Date:: 2012-09-05 20:00:33 +0200 (mer. 05 sept. 2012) $ }\r\n{ Revision: $Rev:: 3865 $ }\r\n{ Author: $Author:: outchy $ }\r\n{ }\r\n{**************************************************************************************************}\r\n\r\nunit JclBase;\r\n\r\n{$I jcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n {$IFDEF HAS_UNITSCOPE}\r\n {$IFDEF MSWINDOWS}\r\n Winapi.Windows,\r\n {$ENDIF MSWINDOWS}\r\n System.SysUtils;\r\n {$ELSE ~HAS_UNITSCOPE}\r\n {$IFDEF MSWINDOWS}\r\n Windows,\r\n {$ENDIF MSWINDOWS}\r\n SysUtils;\r\n {$ENDIF ~HAS_UNITSCOPE}\r\n\r\n// Version\r\nconst\r\n JclVersionMajor = 2; // 0=pre-release|beta/1, 2, ...=final\r\n JclVersionMinor = 4; // Fifth minor release since JCL 1.90\r\n JclVersionRelease = 1; // 0: pre-release|beta/ 1: release\r\n JclVersionBuild = 4571; // build number, days since march 1, 2000\r\n JclVersion = (JclVersionMajor shl 24) or (JclVersionMinor shl 16) or\r\n (JclVersionRelease shl 15) or (JclVersionBuild shl 0);\r\n\r\n// EJclError\r\ntype\r\n EJclError = class(Exception);\r\n\r\n// EJclInternalError\r\ntype\r\n EJclInternalError = class(EJclError);\r\n\r\n// Types\r\ntype\r\n {$IFDEF MATH_EXTENDED_PRECISION}\r\n Float = Extended;\r\n {$ENDIF MATH_EXTENDED_PRECISION}\r\n {$IFDEF MATH_DOUBLE_PRECISION}\r\n Float = Double;\r\n {$ENDIF MATH_DOUBLE_PRECISION}\r\n {$IFDEF MATH_SINGLE_PRECISION}\r\n Float = Single;\r\n {$ENDIF MATH_SINGLE_PRECISION}\r\n\r\n PFloat = ^Float;\r\n\r\ntype\r\n {$IFDEF FPC}\r\n Largeint = Int64;\r\n {$ELSE ~FPC}\r\n {$IFDEF CPU32}\r\n SizeInt = Integer;\r\n {$ENDIF CPU32}\r\n {$IFDEF CPU64}\r\n SizeInt = NativeInt;\r\n {$ENDIF CPU64}\r\n PSizeInt = ^SizeInt;\r\n PPointer = ^Pointer;\r\n PByte = System.PByte;\r\n Int8 = ShortInt;\r\n Int16 = Smallint;\r\n Int32 = Integer;\r\n UInt8 = Byte;\r\n UInt16 = Word;\r\n UInt32 = LongWord;\r\n PCardinal = ^Cardinal;\r\n {$IFNDEF COMPILER7_UP}\r\n UInt64 = Int64;\r\n {$ENDIF ~COMPILER7_UP}\r\n PWideChar = System.PWideChar;\r\n PPWideChar = ^JclBase.PWideChar;\r\n PPAnsiChar = ^PAnsiChar;\r\n PInt64 = type System.PInt64;\r\n {$ENDIF ~FPC}\r\n PPInt64 = ^PInt64;\r\n PPPAnsiChar = ^PPAnsiChar;\r\n\r\n// Int64 support\r\nprocedure I64ToCardinals(I: Int64; out LowPart, HighPart: Cardinal);\r\nprocedure CardinalsToI64(out I: Int64; const LowPart, HighPart: Cardinal);\r\n\r\n// Redefinition of TLargeInteger to relieve dependency on Windows.pas\r\n\r\n{$IFNDEF FPC}\r\ntype\r\n PLargeInteger = ^TLargeInteger;\r\n TLargeInteger = Int64;\r\n{$ENDIF ~FPC}\r\n\r\n{$IFNDEF COMPILER11_UP}\r\ntype\r\n TBytes = array of Byte;\r\n{$ENDIF ~COMPILER11_UP}\r\n\r\n// Redefinition of PByteArray to avoid range check exceptions.\r\ntype\r\n TJclByteArray = array [0..MaxInt div SizeOf(Byte) - 1] of Byte;\r\n PJclByteArray = ^TJclByteArray;\r\n TJclBytes = Pointer; // under .NET System.pas: TBytes = array of Byte;\r\n\r\n// Redefinition of ULARGE_INTEGER to relieve dependency on Windows.pas\r\ntype\r\n {$IFNDEF FPC}\r\n PULARGE_INTEGER = ^ULARGE_INTEGER;\r\n {$EXTERNALSYM PULARGE_INTEGER}\r\n ULARGE_INTEGER = record\r\n case Integer of\r\n 0:\r\n (LowPart: LongWord;\r\n HighPart: LongWord);\r\n 1:\r\n (QuadPart: Int64);\r\n end;\r\n {$EXTERNALSYM ULARGE_INTEGER}\r\n {$ENDIF ~FPC}\r\n TJclULargeInteger = ULARGE_INTEGER;\r\n PJclULargeInteger = PULARGE_INTEGER;\r\n\r\n// Dynamic Array support\r\ntype\r\n TDynByteArray = array of Byte;\r\n TDynShortIntArray = array of Shortint;\r\n TDynWordArray = array of Word;\r\n TDynSmallIntArray = array of Smallint;\r\n TDynLongIntArray = array of Longint;\r\n TDynInt64Array = array of Int64;\r\n TDynCardinalArray = array of Cardinal;\r\n TDynIntegerArray = array of Integer;\r\n TDynSizeIntArray = array of SizeInt;\r\n TDynExtendedArray = array of Extended;\r\n TDynDoubleArray = array of Double;\r\n TDynSingleArray = array of Single;\r\n TDynFloatArray = array of Float;\r\n TDynPointerArray = array of Pointer;\r\n TDynStringArray = array of string;\r\n TDynAnsiStringArray = array of AnsiString;\r\n TDynWideStringArray = array of WideString;\r\n {$IFDEF SUPPORTS_UNICODE_STRING}\r\n TDynUnicodeStringArray = array of UnicodeString;\r\n {$ENDIF SUPPORTS_UNICODE_STRING}\r\n TDynIInterfaceArray = array of IInterface;\r\n TDynObjectArray = array of TObject;\r\n TDynCharArray = array of Char;\r\n TDynAnsiCharArray = array of AnsiChar;\r\n TDynWideCharArray = array of WideChar;\r\n\r\n// Cross-Platform Compatibility\r\nconst\r\n // line delimiters for a version of Delphi/C++Builder\r\n NativeLineFeed = Char(#10);\r\n NativeCarriageReturn = Char(#13);\r\n NativeCrLf = string(#13#10);\r\n // default line break for a version of Delphi on a platform\r\n {$IFDEF MSWINDOWS}\r\n NativeLineBreak = NativeCrLf;\r\n {$ENDIF MSWINDOWS}\r\n {$IFDEF UNIX}\r\n NativeLineBreak = NativeLineFeed;\r\n {$ENDIF UNIX}\r\n\r\n HexPrefixPascal = string('$');\r\n HexPrefixC = string('0x');\r\n HexDigitFmt32 = string('%.8x');\r\n HexDigitFmt64 = string('%.16x');\r\n\r\n {$IFDEF BCB}\r\n HexPrefix = HexPrefixC;\r\n {$ELSE ~BCB}\r\n HexPrefix = HexPrefixPascal;\r\n {$ENDIF ~BCB}\r\n\r\n {$IFDEF CPU32}\r\n HexDigitFmt = HexDigitFmt32;\r\n {$ENDIF CPU32}\r\n {$IFDEF CPU64}\r\n HexDigitFmt = HexDigitFmt64;\r\n {$ENDIF CPU64}\r\n\r\n HexFmt = HexPrefix + HexDigitFmt;\r\n\r\nconst\r\n BOM_UTF16_LSB: array [0..1] of Byte = ($FF,$FE);\r\n BOM_UTF16_MSB: array [0..1] of Byte = ($FE,$FF);\r\n BOM_UTF8: array [0..2] of Byte = ($EF,$BB,$BF);\r\n BOM_UTF32_LSB: array [0..3] of Byte = ($FF,$FE,$00,$00);\r\n BOM_UTF32_MSB: array [0..3] of Byte = ($00,$00,$FE,$FF);\r\n// BOM_UTF7_1: array [0..3] of Byte = ($2B,$2F,$76,$38);\r\n// BOM_UTF7_2: array [0..3] of Byte = ($2B,$2F,$76,$39);\r\n// BOM_UTF7_3: array [0..3] of Byte = ($2B,$2F,$76,$2B);\r\n// BOM_UTF7_4: array [0..3] of Byte = ($2B,$2F,$76,$2F);\r\n// BOM_UTF7_5: array [0..3] of Byte = ($2B,$2F,$76,$38,$2D);\r\n\r\ntype\r\n // Unicode transformation formats (UTF) data types\r\n PUTF7 = ^UTF7;\r\n UTF7 = AnsiChar;\r\n PUTF8 = ^UTF8;\r\n UTF8 = AnsiChar;\r\n PUTF16 = ^UTF16;\r\n UTF16 = WideChar;\r\n PUTF32 = ^UTF32;\r\n UTF32 = Cardinal;\r\n\r\n // UTF conversion schemes (UCS) data types\r\n PUCS4 = ^UCS4;\r\n UCS4 = Cardinal;\r\n PUCS2 = PWideChar;\r\n UCS2 = WideChar;\r\n\r\n TUCS2Array = array of UCS2;\r\n TUCS4Array = array of UCS4;\r\n\r\n // string types\r\n TUTF8String = AnsiString;\r\n {$IFDEF SUPPORTS_UNICODE_STRING}\r\n TUTF16String = UnicodeString;\r\n TUCS2String = UnicodeString;\r\n {$ELSE}\r\n TUTF16String = WideString;\r\n TUCS2String = WideString;\r\n {$ENDIF SUPPORTS_UNICODE_STRING}\r\n\r\nvar\r\n AnsiReplacementCharacter: AnsiChar;\r\n\r\nconst\r\n UCS4ReplacementCharacter: UCS4 = $0000FFFD;\r\n MaximumUCS2: UCS4 = $0000FFFF;\r\n MaximumUTF16: UCS4 = $0010FFFF;\r\n MaximumUCS4: UCS4 = $7FFFFFFF;\r\n\r\n SurrogateHighStart = UCS4($D800);\r\n SurrogateHighEnd = UCS4($DBFF);\r\n SurrogateLowStart = UCS4($DC00);\r\n SurrogateLowEnd = UCS4($DFFF);\r\n\r\n// basic set types\r\ntype\r\n TSetOfAnsiChar = set of AnsiChar;\r\n\r\n{$IFNDEF XPLATFORM_RTL}\r\nprocedure RaiseLastOSError;\r\n{$ENDIF ~XPLATFORM_RTL}\r\n\r\n{$IFNDEF RTL230_UP}\r\nprocedure CheckOSError(ErrorCode: Cardinal);\r\n{$ENDIF RTL230_UP}\r\n\r\nprocedure MoveChar(const Source: string; FromIndex: SizeInt;\r\n var Dest: string; ToIndex, Count: SizeInt); overload; // Index: 0..n-1\r\n\r\nfunction AnsiByteArrayStringLen(Data: TBytes): SizeInt;\r\nfunction StringToAnsiByteArray(const S: string): TBytes;\r\nfunction AnsiByteArrayToString(const Data: TBytes; Count: SizeInt): string;\r\n\r\nfunction BytesOf(const Value: AnsiString): TBytes; overload;\r\nfunction BytesOf(const Value: WideString): TBytes; overload;\r\nfunction BytesOf(const Value: WideChar): TBytes; overload;\r\nfunction BytesOf(const Value: AnsiChar): TBytes; overload;\r\nfunction StringOf(const Bytes: array of Byte): AnsiString; overload;\r\nfunction StringOf(const Bytes: Pointer; Size: Cardinal): AnsiString; overload;\r\n\r\n{$IFNDEF FPC}\r\n{$IFNDEF COMPILER11_UP}\r\ntype // Definitions for 32 Bit Compilers\r\n // From BaseTsd.h\r\n INT_PTR = Integer;\r\n {$EXTERNALSYM INT_PTR}\r\n LONG_PTR = Longint;\r\n {$EXTERNALSYM LONG_PTR}\r\n UINT_PTR = Cardinal;\r\n {$EXTERNALSYM UINT_PTR}\r\n ULONG_PTR = LongWord;\r\n {$EXTERNALSYM ULONG_PTR}\r\n DWORD_PTR = ULONG_PTR;\r\n {$EXTERNALSYM DWORD_PTR}\r\n{$ENDIF ~COMPILER11_UP}\r\n\r\ntype\r\n PDWORD_PTR = ^DWORD_PTR;\r\n {$EXTERNALSYM PDWORD_PTR}\r\n{$ENDIF ~FPC}\r\n\r\ntype\r\n TJclAddr32 = Cardinal;\r\n {$IFDEF FPC}\r\n TJclAddr64 = QWord;\r\n {$IFDEF CPU64}\r\n TJclAddr = QWord;\r\n {$ENDIF CPU64}\r\n {$IFDEF CPU32}\r\n TJclAddr = Cardinal;\r\n {$ENDIF CPU32}\r\n {$ENDIF FPC}\r\n {$IFDEF BORLAND}\r\n TJclAddr64 = Int64;\r\n {$IFDEF CPU64}\r\n TJclAddr = TJclAddr64;\r\n {$ENDIF CPU64}\r\n {$IFDEF CPU32}\r\n TJclAddr = TJclAddr32;\r\n {$ENDIF CPU32}\r\n {$ENDIF BORLAND}\r\n PJclAddr = ^TJclAddr;\r\n\r\n EJclAddr64Exception = class(EJclError);\r\n\r\nfunction Addr64ToAddr32(const Value: TJclAddr64): TJclAddr32;\r\nfunction Addr32ToAddr64(const Value: TJclAddr32): TJclAddr64;\r\n\r\n{$IFDEF FPC}\r\ntype\r\n HWND = type Windows.HWND;\r\n{$ENDIF FPC}\r\n\r\n {$IFDEF SUPPORTS_GENERICS}\r\n//DOM-IGNORE-BEGIN\r\n\r\ntype\r\n TCompare = function(const Obj1, Obj2: T): Integer;\r\n TEqualityCompare = function(const Obj1, Obj2: T): Boolean;\r\n THashConvert = function(const AItem: T): Integer;\r\n\r\n IEqualityComparer = interface\r\n function Equals(A, B: T): Boolean;\r\n function GetHashCode(Obj: T): Integer;\r\n end;\r\n\r\n TEquatable = class(TInterfacedObject, IEquatable, IEqualityComparer)\r\n public\r\n { IEquatable }\r\n function TestEquals(Other: T): Boolean; overload;\r\n function IEquatable.Equals = TestEquals;\r\n { IEqualityComparer }\r\n function TestEquals(A, B: T): Boolean; overload;\r\n function IEqualityComparer.Equals = TestEquals;\r\n function GetHashCode2(Obj: T): Integer;\r\n function IEqualityComparer.GetHashCode = GetHashCode2;\r\n end;\r\n\r\n//DOM-IGNORE-END\r\n{$ENDIF SUPPORTS_GENERICS}\r\n\r\nconst\r\n {$IFDEF SUPPORTS_UNICODE}\r\n AWSuffix = 'W';\r\n {$ELSE ~SUPPORTS_UNICODE}\r\n AWSuffix = 'A';\r\n {$ENDIF ~SUPPORTS_UNICODE}\r\n\r\n{$IFDEF FPC}\r\n// FPC emits a lot of warning because the first parameter of its internal\r\n// GetMem is a var parameter, which is not initialized before the call to GetMem\r\nprocedure GetMem(out P; Size: Longint);\r\n{$ENDIF FPC}\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jcl.svn.sourceforge.net/svnroot/jcl/tags/JCL-2.4-Build4571/jcl/source/common/JclBase.pas $';\r\n Revision: '$Revision: 3865 $';\r\n Date: '$Date: 2012-09-05 20:00:33 +0200 (mer. 05 sept. 2012) $';\r\n LogPath: 'JCL\\source\\common';\r\n Extra: '';\r\n Data: nil\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n JclResources;\r\n\r\nprocedure MoveChar(const Source: string; FromIndex: SizeInt;\r\n var Dest: string; ToIndex, Count: SizeInt);\r\nbegin\r\n Move(Source[FromIndex + 1], Dest[ToIndex + 1], Count * SizeOf(Char));\r\nend;\r\n\r\nfunction AnsiByteArrayStringLen(Data: TBytes): SizeInt;\r\nvar\r\n I: SizeInt;\r\nbegin\r\n Result := Length(Data);\r\n for I := 0 to Result - 1 do\r\n if Data[I] = 0 then\r\n begin\r\n Result := I + 1;\r\n Break;\r\n end;\r\nend;\r\n\r\nfunction StringToAnsiByteArray(const S: string): TBytes;\r\nvar\r\n I: SizeInt;\r\n AnsiS: AnsiString;\r\nbegin\r\n AnsiS := AnsiString(S); // convert to AnsiString\r\n SetLength(Result, Length(AnsiS));\r\n for I := 0 to High(Result) do\r\n Result[I] := Byte(AnsiS[I + 1]);\r\nend;\r\n\r\nfunction AnsiByteArrayToString(const Data: TBytes; Count: SizeInt): string;\r\nvar\r\n I: SizeInt;\r\n AnsiS: AnsiString;\r\nbegin\r\n if Length(Data) < Count then\r\n Count := Length(Data);\r\n SetLength(AnsiS, Count);\r\n for I := 0 to Length(AnsiS) - 1 do\r\n AnsiS[I + 1] := AnsiChar(Data[I]);\r\n Result := string(AnsiS); // convert to System.String\r\nend;\r\n\r\nfunction BytesOf(const Value: AnsiString): TBytes;\r\nbegin\r\n SetLength(Result, Length(Value));\r\n if Value <> '' then\r\n Move(Pointer(Value)^, Result[0], Length(Value));\r\nend;\r\n\r\nfunction BytesOf(const Value: WideString): TBytes;\r\nbegin\r\n if Value <> '' then\r\n Result := JclBase.BytesOf(AnsiString(Value))\r\n else\r\n SetLength(Result, 0);\r\nend;\r\n\r\nfunction BytesOf(const Value: WideChar): TBytes;\r\nbegin\r\n Result := JclBase.BytesOf(WideString(Value));\r\nend;\r\n\r\nfunction BytesOf(const Value: AnsiChar): TBytes;\r\nbegin\r\n SetLength(Result, 1);\r\n Result[0] := Byte(Value);\r\nend;\r\n\r\nfunction StringOf(const Bytes: array of Byte): AnsiString;\r\nbegin\r\n if Length(Bytes) > 0 then\r\n begin\r\n SetLength(Result, Length(Bytes));\r\n Move(Bytes[0], Pointer(Result)^, Length(Bytes));\r\n end\r\n else\r\n Result := '';\r\nend;\r\n\r\nfunction StringOf(const Bytes: Pointer; Size: Cardinal): AnsiString;\r\nbegin\r\n if (Bytes <> nil) and (Size > 0) then\r\n begin\r\n SetLength(Result, Size);\r\n Move(Bytes^, Pointer(Result)^, Size);\r\n end\r\n else\r\n Result := '';\r\nend;\r\n\r\n// Int64 support\r\n\r\nprocedure I64ToCardinals(I: Int64; out LowPart, HighPart: Cardinal);\r\nbegin\r\n LowPart := TJclULargeInteger(I).LowPart;\r\n HighPart := TJclULargeInteger(I).HighPart;\r\nend;\r\n\r\nprocedure CardinalsToI64(out I: Int64; const LowPart, HighPart: Cardinal);\r\nbegin\r\n TJclULargeInteger(I).LowPart := LowPart;\r\n TJclULargeInteger(I).HighPart := HighPart;\r\nend;\r\n\r\n// Cross Platform Compatibility\r\n\r\n{$IFNDEF XPLATFORM_RTL}\r\nprocedure RaiseLastOSError;\r\nbegin\r\n RaiseLastWin32Error;\r\nend;\r\n{$ENDIF ~XPLATFORM_RTL}\r\n\r\n{$IFNDEF RTL230_UP}\r\nprocedure CheckOSError(ErrorCode: Cardinal);\r\nbegin\r\n if ErrorCode <> ERROR_SUCCESS then\r\n {$IFDEF RTL170_UP}\r\n RaiseLastOSError(ErrorCode);\r\n {$ELSE ~RTL170_UP}\r\n RaiseLastOSError;\r\n {$ENDIF ~RTL170_UP}\r\nend;\r\n{$ENDIF RTL230_UP}\r\n\r\n{$OVERFLOWCHECKS OFF}\r\n\r\nfunction Addr64ToAddr32(const Value: TJclAddr64): TJclAddr32;\r\nbegin\r\n if (Value shr 32) = 0 then\r\n Result := Value\r\n else\r\n raise EJclAddr64Exception.CreateResFmt(@RsCantConvertAddr64, [HexPrefix, Value]);\r\nend;\r\n\r\nfunction Addr32ToAddr64(const Value: TJclAddr32): TJclAddr64;\r\nbegin\r\n Result := Value;\r\nend;\r\n\r\n{$IFDEF OVERFLOWCHECKS_ON}\r\n{$OVERFLOWCHECKS ON}\r\n{$ENDIF OVERFLOWCHECKS_ON}\r\n\r\n{$IFDEF SUPPORTS_GENERICS}\r\n//DOM-IGNORE-BEGIN\r\n\r\n//=== { TEquatable } ======================================================\r\n\r\nfunction TEquatable.TestEquals(Other: T): Boolean;\r\nbegin\r\n if Other = nil then\r\n Result := False\r\n else\r\n Result := GetHashCode = Other.GetHashCode;\r\nend;\r\n\r\nfunction TEquatable.TestEquals(A, B: T): Boolean;\r\nbegin\r\n if A = nil then\r\n Result := B = nil\r\n else\r\n if B = nil then\r\n Result := False\r\n else\r\n Result := A.GetHashCode = B.GetHashCode;\r\nend;\r\n\r\nfunction TEquatable.GetHashCode2(Obj: T): Integer;\r\nbegin\r\n if Obj = nil then\r\n Result := 0\r\n else\r\n Result := Obj.GetHashCode;\r\nend;\r\n\r\n//DOM-IGNORE-END\r\n{$ENDIF SUPPORTS_GENERICS}\r\n\r\nprocedure LoadAnsiReplacementCharacter;\r\n{$IFDEF MSWINDOWS}\r\nvar\r\n CpInfo: TCpInfo;\r\nbegin\r\n CpInfo.MaxCharSize := 0;\r\n if GetCPInfo(CP_ACP, CpInfo) then\r\n AnsiReplacementCharacter := AnsiChar(Chr(CpInfo.DefaultChar[0]))\r\n else\r\n raise EJclInternalError.CreateRes(@RsEReplacementChar);\r\nend;\r\n{$ELSE ~MSWINDOWS}\r\nbegin\r\n AnsiReplacementCharacter := '?';\r\nend;\r\n{$ENDIF ~MSWINDOWS}\r\n\r\n{$IFDEF FPC}\r\n// FPC emits a lot of warning because the first parameter of its internal\r\n// GetMem is a var parameter, which is not initialized before the call to GetMem\r\nprocedure GetMem(out P; Size: Longint);\r\nbegin\r\n Pointer(P) := nil;\r\n GetMem(Pointer(P), Size);\r\nend;\r\n{$ENDIF FPC}\r\n\r\ninitialization\r\n\r\n LoadAnsiReplacementCharacter;\r\n {$IFDEF UNITVERSIONING}\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n {$ENDIF UNITVERSIONING}\r\n\r\nfinalization\r\n {$IFDEF UNITVERSIONING}\r\n UnregisterUnitVersion(HInstance);\r\n {$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jcl/source/common/JclBinaryTrees.pas", "content": "{**************************************************************************************************}\r\n{ WARNING: JEDI preprocessor generated unit. Do not edit. }\r\n{**************************************************************************************************}\r\n\r\n{**************************************************************************************************}\r\n{ }\r\n{ Project JEDI Code Library (JCL) }\r\n{ }\r\n{ The contents of this file are subject to the Mozilla Public License Version 1.1 (the \"License\"); }\r\n{ you may not use this file except in compliance with the License. You may obtain a copy of the }\r\n{ License at http://www.mozilla.org/MPL/ }\r\n{ }\r\n{ Software distributed under the License is distributed on an \"AS IS\" basis, WITHOUT WARRANTY OF }\r\n{ ANY KIND, either express or implied. See the License for the specific language governing rights }\r\n{ and limitations under the License. }\r\n{ }\r\n{ The Original Code is BinaryTree.pas. }\r\n{ }\r\n{ The Initial Developer of the Original Code is Jean-Philippe BEMPEL aka RDM. Portions created by }\r\n{ Jean-Philippe BEMPEL are Copyright (C) Jean-Philippe BEMPEL (rdm_30 att yahoo dott com) }\r\n{ All rights reserved. }\r\n{ }\r\n{ Contributors: }\r\n{ Florent Ouchet (outchy) }\r\n{ }\r\n{**************************************************************************************************}\r\n{ }\r\n{ The Delphi Container Library }\r\n{ }\r\n{**************************************************************************************************}\r\n{ }\r\n{ Last modified: $Date:: 2012-02-21 18:37:18 +0100 (mar. 21 févr. 2012) $ }\r\n{ Revision: $Rev:: 3739 $ }\r\n{ Author: $Author:: outchy $ }\r\n{ }\r\n{**************************************************************************************************}\r\n\r\nunit JclBinaryTrees;\r\n\r\n{$I jcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n {$IFDEF HAS_UNITSCOPE}\r\n System.Classes,\r\n {$ELSE ~HAS_UNITSCOPE}\r\n Classes,\r\n {$ENDIF ~HAS_UNITSCOPE}\r\n JclBase, JclAbstractContainers, JclAlgorithms, JclContainerIntf, JclSynch;\r\n\r\ntype\r\n TItrStart = (isFirst, isLast, isRoot);\r\n\r\n TJclIntfBinaryNode = class\r\n public\r\n Value: IInterface;\r\n Left: TJclIntfBinaryNode;\r\n Right: TJclIntfBinaryNode;\r\n Parent: TJclIntfBinaryNode;\r\n end;\r\n\r\n TJclIntfBinaryTree = class(TJclIntfAbstractContainer, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclIntfCloneable, IJclCloneable, IJclPackable, IJclBaseContainer,\r\n IJclIntfEqualityComparer, IJclIntfComparer, IJclIntfContainer, IJclIntfFlatContainer,\r\n IJclIntfCollection, IJclIntfTree)\r\n protected\r\n function CreateEmptyContainer: TJclAbstractContainerBase; override;\r\n private\r\n FMaxDepth: Integer;\r\n FRoot: TJclIntfBinaryNode;\r\n FTraverseOrder: TJclTraverseOrder;\r\n function BuildTree(const LeafArray: array of TJclIntfBinaryNode; Left, Right: Integer; Parent: TJclIntfBinaryNode;\r\n Offset: Integer): TJclIntfBinaryNode;\r\n function CloneNode(Node, Parent: TJclIntfBinaryNode): TJclIntfBinaryNode;\r\n protected\r\n procedure AssignDataTo(Dest: TJclAbstractContainerBase); override;\r\n procedure AssignPropertiesTo(Dest: TJclAbstractContainerBase); override;\r\n procedure AutoPack; override;\r\n public\r\n constructor Create(ACompare: TIntfCompare);\r\n destructor Destroy; override;\r\n { IJclPackable }\r\n procedure Pack; override;\r\n procedure SetCapacity(Value: Integer); override;\r\n { IJclIntfCollection }\r\n function Add(const AInterface: IInterface): Boolean;\r\n function AddAll(const ACollection: IJclIntfCollection): Boolean;\r\n procedure Clear;\r\n function Contains(const AInterface: IInterface): Boolean;\r\n function ContainsAll(const ACollection: IJclIntfCollection): Boolean;\r\n function CollectionEquals(const ACollection: IJclIntfCollection): Boolean;\r\n function Extract(const AInterface: IInterface): Boolean;\r\n function ExtractAll(const ACollection: IJclIntfCollection): Boolean;\r\n function First: IJclIntfIterator;\r\n function IsEmpty: Boolean;\r\n function Last: IJclIntfIterator;\r\n function Remove(const AInterface: IInterface): Boolean;\r\n function RemoveAll(const ACollection: IJclIntfCollection): Boolean;\r\n function RetainAll(const ACollection: IJclIntfCollection): Boolean;\r\n function Size: Integer;\r\n {$IFDEF SUPPORTS_FOR_IN}\r\n function GetEnumerator: IJclIntfIterator;\r\n {$ENDIF SUPPORTS_FOR_IN}\r\n { IJclIntfTree }\r\n function GetRoot: IJclIntfTreeIterator;\r\n function GetTraverseOrder: TJclTraverseOrder;\r\n procedure SetTraverseOrder(Value: TJclTraverseOrder);\r\n property Root: IJclIntfTreeIterator read GetRoot;\r\n property TraverseOrder: TJclTraverseOrder read GetTraverseOrder write SetTraverseOrder;\r\n end;\r\n\r\n TJclIntfBinaryTreeIterator = class(TJclAbstractIterator, IJclIntfIterator, IJclIntfTreeIterator, IJclIntfBinaryTreeIterator)\r\n protected\r\n FCursor: TJclIntfBinaryNode;\r\n FStart: TItrStart;\r\n FOwnTree: IJclIntfCollection;\r\n FEqualityComparer: IJclIntfEqualityComparer;\r\n procedure AssignPropertiesTo(Dest: TJclAbstractIterator); override;\r\n function GetNextCursor: TJclIntfBinaryNode; virtual; abstract;\r\n function GetPreviousCursor: TJclIntfBinaryNode; virtual; abstract;\r\n public\r\n constructor Create(const AOwnTree: IJclIntfCollection; ACursor: TJclIntfBinaryNode; AValid: Boolean; AStart: TItrStart);\r\n { IJclIntfIterator }\r\n function Add(const AInterface: IInterface): Boolean;\r\n procedure Extract;\r\n function GetObject: IInterface;\r\n function HasNext: Boolean;\r\n function HasPrevious: Boolean;\r\n function Insert(const AInterface: IInterface): Boolean;\r\n function IteratorEquals(const AIterator: IJclIntfIterator): Boolean;\r\n function Next: IInterface;\r\n function NextIndex: Integer;\r\n function Previous: IInterface;\r\n function PreviousIndex: Integer;\r\n procedure Remove;\r\n procedure Reset;\r\n procedure SetObject(const AInterface: IInterface);\r\n {$IFDEF SUPPORTS_FOR_IN}\r\n function MoveNext: Boolean;\r\n property Current: IInterface read GetObject;\r\n {$ENDIF SUPPORTS_FOR_IN}\r\n { IJclIntfTreeIterator }\r\n function AddChild(const AInterface: IInterface): Boolean;\r\n function ChildrenCount: Integer;\r\n procedure DeleteChild(Index: Integer);\r\n procedure DeleteChildren;\r\n procedure ExtractChild(Index: Integer);\r\n procedure ExtractChildren;\r\n function GetChild(Index: Integer): IInterface;\r\n function HasChild(Index: Integer): Boolean;\r\n function HasParent: Boolean;\r\n function IndexOfChild(const AInterface: IInterface): Integer;\r\n function InsertChild(Index: Integer; const AInterface: IInterface): Boolean;\r\n function Parent: IInterface;\r\n procedure SetChild(Index: Integer; const AInterface: IInterface);\r\n { IJclIntfBinaryTreeIterator }\r\n function HasLeft: Boolean;\r\n function HasRight: Boolean;\r\n function Left: IInterface;\r\n function Right: IInterface;\r\n end;\r\n\r\n TJclPreOrderIntfBinaryTreeIterator = class(TJclIntfBinaryTreeIterator, IJclIntfIterator, IJclIntfTreeIterator, IJclIntfBinaryTreeIterator,\r\n {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE} IJclIntfCloneable, IJclCloneable)\r\n protected\r\n function CreateEmptyIterator: TJclAbstractIterator; override;\r\n function GetNextCursor: TJclIntfBinaryNode; override;\r\n function GetPreviousCursor: TJclIntfBinaryNode; override;\r\n end;\r\n\r\n TJclInOrderIntfBinaryTreeIterator = class(TJclIntfBinaryTreeIterator, IJclIntfIterator, IJclIntfTreeIterator, IJclIntfBinaryTreeIterator,\r\n {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE} IJclIntfCloneable, IJclCloneable)\r\n protected\r\n function CreateEmptyIterator: TJclAbstractIterator; override;\r\n function GetNextCursor: TJclIntfBinaryNode; override;\r\n function GetPreviousCursor: TJclIntfBinaryNode; override;\r\n end;\r\n\r\n TJclPostOrderIntfBinaryTreeIterator = class(TJclIntfBinaryTreeIterator, IJclIntfIterator, IJclIntfTreeIterator, IJclIntfBinaryTreeIterator,\r\n {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE} IJclIntfCloneable, IJclCloneable)\r\n protected\r\n function CreateEmptyIterator: TJclAbstractIterator; override;\r\n function GetNextCursor: TJclIntfBinaryNode; override;\r\n function GetPreviousCursor: TJclIntfBinaryNode; override;\r\n end;\r\n\r\n TJclAnsiStrBinaryNode = class\r\n public\r\n Value: AnsiString;\r\n Left: TJclAnsiStrBinaryNode;\r\n Right: TJclAnsiStrBinaryNode;\r\n Parent: TJclAnsiStrBinaryNode;\r\n end;\r\n\r\n TJclAnsiStrBinaryTree = class(TJclAnsiStrAbstractCollection, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclIntfCloneable, IJclCloneable, IJclPackable, IJclBaseContainer,\r\n IJclAnsiStrEqualityComparer, IJclAnsiStrComparer, IJclAnsiStrContainer, IJclAnsiStrFlatContainer, IJclStrBaseContainer,\r\n IJclAnsiStrCollection, IJclAnsiStrTree)\r\n protected\r\n function CreateEmptyContainer: TJclAbstractContainerBase; override;\r\n private\r\n FMaxDepth: Integer;\r\n FRoot: TJclAnsiStrBinaryNode;\r\n FTraverseOrder: TJclTraverseOrder;\r\n function BuildTree(const LeafArray: array of TJclAnsiStrBinaryNode; Left, Right: Integer; Parent: TJclAnsiStrBinaryNode;\r\n Offset: Integer): TJclAnsiStrBinaryNode;\r\n function CloneNode(Node, Parent: TJclAnsiStrBinaryNode): TJclAnsiStrBinaryNode;\r\n protected\r\n procedure AssignDataTo(Dest: TJclAbstractContainerBase); override;\r\n procedure AssignPropertiesTo(Dest: TJclAbstractContainerBase); override;\r\n procedure AutoPack; override;\r\n public\r\n constructor Create(ACompare: TAnsiStrCompare);\r\n destructor Destroy; override;\r\n { IJclPackable }\r\n procedure Pack; override;\r\n procedure SetCapacity(Value: Integer); override;\r\n { IJclAnsiStrCollection }\r\n function Add(const AString: AnsiString): Boolean; override;\r\n function AddAll(const ACollection: IJclAnsiStrCollection): Boolean; override;\r\n procedure Clear; override;\r\n function Contains(const AString: AnsiString): Boolean; override;\r\n function ContainsAll(const ACollection: IJclAnsiStrCollection): Boolean; override;\r\n function CollectionEquals(const ACollection: IJclAnsiStrCollection): Boolean; override;\r\n function Extract(const AString: AnsiString): Boolean; override;\r\n function ExtractAll(const ACollection: IJclAnsiStrCollection): Boolean; override;\r\n function First: IJclAnsiStrIterator; override;\r\n function IsEmpty: Boolean; override;\r\n function Last: IJclAnsiStrIterator; override;\r\n function Remove(const AString: AnsiString): Boolean; override;\r\n function RemoveAll(const ACollection: IJclAnsiStrCollection): Boolean; override;\r\n function RetainAll(const ACollection: IJclAnsiStrCollection): Boolean; override;\r\n function Size: Integer; override;\r\n {$IFDEF SUPPORTS_FOR_IN}\r\n function GetEnumerator: IJclAnsiStrIterator; override;\r\n {$ENDIF SUPPORTS_FOR_IN}\r\n { IJclAnsiStrTree }\r\n function GetRoot: IJclAnsiStrTreeIterator;\r\n function GetTraverseOrder: TJclTraverseOrder;\r\n procedure SetTraverseOrder(Value: TJclTraverseOrder);\r\n property Root: IJclAnsiStrTreeIterator read GetRoot;\r\n property TraverseOrder: TJclTraverseOrder read GetTraverseOrder write SetTraverseOrder;\r\n end;\r\n\r\n TJclAnsiStrBinaryTreeIterator = class(TJclAbstractIterator, IJclAnsiStrIterator, IJclAnsiStrTreeIterator, IJclAnsiStrBinaryTreeIterator)\r\n protected\r\n FCursor: TJclAnsiStrBinaryNode;\r\n FStart: TItrStart;\r\n FOwnTree: IJclAnsiStrCollection;\r\n FEqualityComparer: IJclAnsiStrEqualityComparer;\r\n procedure AssignPropertiesTo(Dest: TJclAbstractIterator); override;\r\n function GetNextCursor: TJclAnsiStrBinaryNode; virtual; abstract;\r\n function GetPreviousCursor: TJclAnsiStrBinaryNode; virtual; abstract;\r\n public\r\n constructor Create(const AOwnTree: IJclAnsiStrCollection; ACursor: TJclAnsiStrBinaryNode; AValid: Boolean; AStart: TItrStart);\r\n { IJclAnsiStrIterator }\r\n function Add(const AString: AnsiString): Boolean;\r\n procedure Extract;\r\n function GetString: AnsiString;\r\n function HasNext: Boolean;\r\n function HasPrevious: Boolean;\r\n function Insert(const AString: AnsiString): Boolean;\r\n function IteratorEquals(const AIterator: IJclAnsiStrIterator): Boolean;\r\n function Next: AnsiString;\r\n function NextIndex: Integer;\r\n function Previous: AnsiString;\r\n function PreviousIndex: Integer;\r\n procedure Remove;\r\n procedure Reset;\r\n procedure SetString(const AString: AnsiString);\r\n {$IFDEF SUPPORTS_FOR_IN}\r\n function MoveNext: Boolean;\r\n property Current: AnsiString read GetString;\r\n {$ENDIF SUPPORTS_FOR_IN}\r\n { IJclAnsiStrTreeIterator }\r\n function AddChild(const AString: AnsiString): Boolean;\r\n function ChildrenCount: Integer;\r\n procedure DeleteChild(Index: Integer);\r\n procedure DeleteChildren;\r\n procedure ExtractChild(Index: Integer);\r\n procedure ExtractChildren;\r\n function GetChild(Index: Integer): AnsiString;\r\n function HasChild(Index: Integer): Boolean;\r\n function HasParent: Boolean;\r\n function IndexOfChild(const AString: AnsiString): Integer;\r\n function InsertChild(Index: Integer; const AString: AnsiString): Boolean;\r\n function Parent: AnsiString;\r\n procedure SetChild(Index: Integer; const AString: AnsiString);\r\n { IJclAnsiStrBinaryTreeIterator }\r\n function HasLeft: Boolean;\r\n function HasRight: Boolean;\r\n function Left: AnsiString;\r\n function Right: AnsiString;\r\n end;\r\n\r\n TJclPreOrderAnsiStrBinaryTreeIterator = class(TJclAnsiStrBinaryTreeIterator, IJclAnsiStrIterator, IJclAnsiStrTreeIterator, IJclAnsiStrBinaryTreeIterator,\r\n {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE} IJclIntfCloneable, IJclCloneable)\r\n protected\r\n function CreateEmptyIterator: TJclAbstractIterator; override;\r\n function GetNextCursor: TJclAnsiStrBinaryNode; override;\r\n function GetPreviousCursor: TJclAnsiStrBinaryNode; override;\r\n end;\r\n\r\n TJclInOrderAnsiStrBinaryTreeIterator = class(TJclAnsiStrBinaryTreeIterator, IJclAnsiStrIterator, IJclAnsiStrTreeIterator, IJclAnsiStrBinaryTreeIterator,\r\n {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE} IJclIntfCloneable, IJclCloneable)\r\n protected\r\n function CreateEmptyIterator: TJclAbstractIterator; override;\r\n function GetNextCursor: TJclAnsiStrBinaryNode; override;\r\n function GetPreviousCursor: TJclAnsiStrBinaryNode; override;\r\n end;\r\n\r\n TJclPostOrderAnsiStrBinaryTreeIterator = class(TJclAnsiStrBinaryTreeIterator, IJclAnsiStrIterator, IJclAnsiStrTreeIterator, IJclAnsiStrBinaryTreeIterator,\r\n {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE} IJclIntfCloneable, IJclCloneable)\r\n protected\r\n function CreateEmptyIterator: TJclAbstractIterator; override;\r\n function GetNextCursor: TJclAnsiStrBinaryNode; override;\r\n function GetPreviousCursor: TJclAnsiStrBinaryNode; override;\r\n end;\r\n\r\n TJclWideStrBinaryNode = class\r\n public\r\n Value: WideString;\r\n Left: TJclWideStrBinaryNode;\r\n Right: TJclWideStrBinaryNode;\r\n Parent: TJclWideStrBinaryNode;\r\n end;\r\n\r\n TJclWideStrBinaryTree = class(TJclWideStrAbstractCollection, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclIntfCloneable, IJclCloneable, IJclPackable, IJclBaseContainer,\r\n IJclWideStrEqualityComparer, IJclWideStrComparer, IJclWideStrContainer, IJclWideStrFlatContainer, IJclStrBaseContainer,\r\n IJclWideStrCollection, IJclWideStrTree)\r\n protected\r\n function CreateEmptyContainer: TJclAbstractContainerBase; override;\r\n private\r\n FMaxDepth: Integer;\r\n FRoot: TJclWideStrBinaryNode;\r\n FTraverseOrder: TJclTraverseOrder;\r\n function BuildTree(const LeafArray: array of TJclWideStrBinaryNode; Left, Right: Integer; Parent: TJclWideStrBinaryNode;\r\n Offset: Integer): TJclWideStrBinaryNode;\r\n function CloneNode(Node, Parent: TJclWideStrBinaryNode): TJclWideStrBinaryNode;\r\n protected\r\n procedure AssignDataTo(Dest: TJclAbstractContainerBase); override;\r\n procedure AssignPropertiesTo(Dest: TJclAbstractContainerBase); override;\r\n procedure AutoPack; override;\r\n public\r\n constructor Create(ACompare: TWideStrCompare);\r\n destructor Destroy; override;\r\n { IJclPackable }\r\n procedure Pack; override;\r\n procedure SetCapacity(Value: Integer); override;\r\n { IJclWideStrCollection }\r\n function Add(const AString: WideString): Boolean; override;\r\n function AddAll(const ACollection: IJclWideStrCollection): Boolean; override;\r\n procedure Clear; override;\r\n function Contains(const AString: WideString): Boolean; override;\r\n function ContainsAll(const ACollection: IJclWideStrCollection): Boolean; override;\r\n function CollectionEquals(const ACollection: IJclWideStrCollection): Boolean; override;\r\n function Extract(const AString: WideString): Boolean; override;\r\n function ExtractAll(const ACollection: IJclWideStrCollection): Boolean; override;\r\n function First: IJclWideStrIterator; override;\r\n function IsEmpty: Boolean; override;\r\n function Last: IJclWideStrIterator; override;\r\n function Remove(const AString: WideString): Boolean; override;\r\n function RemoveAll(const ACollection: IJclWideStrCollection): Boolean; override;\r\n function RetainAll(const ACollection: IJclWideStrCollection): Boolean; override;\r\n function Size: Integer; override;\r\n {$IFDEF SUPPORTS_FOR_IN}\r\n function GetEnumerator: IJclWideStrIterator; override;\r\n {$ENDIF SUPPORTS_FOR_IN}\r\n { IJclWideStrTree }\r\n function GetRoot: IJclWideStrTreeIterator;\r\n function GetTraverseOrder: TJclTraverseOrder;\r\n procedure SetTraverseOrder(Value: TJclTraverseOrder);\r\n property Root: IJclWideStrTreeIterator read GetRoot;\r\n property TraverseOrder: TJclTraverseOrder read GetTraverseOrder write SetTraverseOrder;\r\n end;\r\n\r\n TJclWideStrBinaryTreeIterator = class(TJclAbstractIterator, IJclWideStrIterator, IJclWideStrTreeIterator, IJclWideStrBinaryTreeIterator)\r\n protected\r\n FCursor: TJclWideStrBinaryNode;\r\n FStart: TItrStart;\r\n FOwnTree: IJclWideStrCollection;\r\n FEqualityComparer: IJclWideStrEqualityComparer;\r\n procedure AssignPropertiesTo(Dest: TJclAbstractIterator); override;\r\n function GetNextCursor: TJclWideStrBinaryNode; virtual; abstract;\r\n function GetPreviousCursor: TJclWideStrBinaryNode; virtual; abstract;\r\n public\r\n constructor Create(const AOwnTree: IJclWideStrCollection; ACursor: TJclWideStrBinaryNode; AValid: Boolean; AStart: TItrStart);\r\n { IJclWideStrIterator }\r\n function Add(const AString: WideString): Boolean;\r\n procedure Extract;\r\n function GetString: WideString;\r\n function HasNext: Boolean;\r\n function HasPrevious: Boolean;\r\n function Insert(const AString: WideString): Boolean;\r\n function IteratorEquals(const AIterator: IJclWideStrIterator): Boolean;\r\n function Next: WideString;\r\n function NextIndex: Integer;\r\n function Previous: WideString;\r\n function PreviousIndex: Integer;\r\n procedure Remove;\r\n procedure Reset;\r\n procedure SetString(const AString: WideString);\r\n {$IFDEF SUPPORTS_FOR_IN}\r\n function MoveNext: Boolean;\r\n property Current: WideString read GetString;\r\n {$ENDIF SUPPORTS_FOR_IN}\r\n { IJclWideStrTreeIterator }\r\n function AddChild(const AString: WideString): Boolean;\r\n function ChildrenCount: Integer;\r\n procedure DeleteChild(Index: Integer);\r\n procedure DeleteChildren;\r\n procedure ExtractChild(Index: Integer);\r\n procedure ExtractChildren;\r\n function GetChild(Index: Integer): WideString;\r\n function HasChild(Index: Integer): Boolean;\r\n function HasParent: Boolean;\r\n function IndexOfChild(const AString: WideString): Integer;\r\n function InsertChild(Index: Integer; const AString: WideString): Boolean;\r\n function Parent: WideString;\r\n procedure SetChild(Index: Integer; const AString: WideString);\r\n { IJclWideStrBinaryTreeIterator }\r\n function HasLeft: Boolean;\r\n function HasRight: Boolean;\r\n function Left: WideString;\r\n function Right: WideString;\r\n end;\r\n\r\n TJclPreOrderWideStrBinaryTreeIterator = class(TJclWideStrBinaryTreeIterator, IJclWideStrIterator, IJclWideStrTreeIterator, IJclWideStrBinaryTreeIterator,\r\n {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE} IJclIntfCloneable, IJclCloneable)\r\n protected\r\n function CreateEmptyIterator: TJclAbstractIterator; override;\r\n function GetNextCursor: TJclWideStrBinaryNode; override;\r\n function GetPreviousCursor: TJclWideStrBinaryNode; override;\r\n end;\r\n\r\n TJclInOrderWideStrBinaryTreeIterator = class(TJclWideStrBinaryTreeIterator, IJclWideStrIterator, IJclWideStrTreeIterator, IJclWideStrBinaryTreeIterator,\r\n {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE} IJclIntfCloneable, IJclCloneable)\r\n protected\r\n function CreateEmptyIterator: TJclAbstractIterator; override;\r\n function GetNextCursor: TJclWideStrBinaryNode; override;\r\n function GetPreviousCursor: TJclWideStrBinaryNode; override;\r\n end;\r\n\r\n TJclPostOrderWideStrBinaryTreeIterator = class(TJclWideStrBinaryTreeIterator, IJclWideStrIterator, IJclWideStrTreeIterator, IJclWideStrBinaryTreeIterator,\r\n {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE} IJclIntfCloneable, IJclCloneable)\r\n protected\r\n function CreateEmptyIterator: TJclAbstractIterator; override;\r\n function GetNextCursor: TJclWideStrBinaryNode; override;\r\n function GetPreviousCursor: TJclWideStrBinaryNode; override;\r\n end;\r\n\r\n {$IFDEF SUPPORTS_UNICODE_STRING}\r\n TJclUnicodeStrBinaryNode = class\r\n public\r\n Value: UnicodeString;\r\n Left: TJclUnicodeStrBinaryNode;\r\n Right: TJclUnicodeStrBinaryNode;\r\n Parent: TJclUnicodeStrBinaryNode;\r\n end;\r\n {$ENDIF SUPPORTS_UNICODE_STRING}\r\n\r\n {$IFDEF SUPPORTS_UNICODE_STRING}\r\n TJclUnicodeStrBinaryTree = class(TJclUnicodeStrAbstractCollection, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclIntfCloneable, IJclCloneable, IJclPackable, IJclBaseContainer,\r\n IJclUnicodeStrEqualityComparer, IJclUnicodeStrComparer, IJclUnicodeStrContainer, IJclUnicodeStrFlatContainer, IJclStrBaseContainer,\r\n IJclUnicodeStrCollection, IJclUnicodeStrTree)\r\n protected\r\n function CreateEmptyContainer: TJclAbstractContainerBase; override;\r\n private\r\n FMaxDepth: Integer;\r\n FRoot: TJclUnicodeStrBinaryNode;\r\n FTraverseOrder: TJclTraverseOrder;\r\n function BuildTree(const LeafArray: array of TJclUnicodeStrBinaryNode; Left, Right: Integer; Parent: TJclUnicodeStrBinaryNode;\r\n Offset: Integer): TJclUnicodeStrBinaryNode;\r\n function CloneNode(Node, Parent: TJclUnicodeStrBinaryNode): TJclUnicodeStrBinaryNode;\r\n protected\r\n procedure AssignDataTo(Dest: TJclAbstractContainerBase); override;\r\n procedure AssignPropertiesTo(Dest: TJclAbstractContainerBase); override;\r\n procedure AutoPack; override;\r\n public\r\n constructor Create(ACompare: TUnicodeStrCompare);\r\n destructor Destroy; override;\r\n { IJclPackable }\r\n procedure Pack; override;\r\n procedure SetCapacity(Value: Integer); override;\r\n { IJclUnicodeStrCollection }\r\n function Add(const AString: UnicodeString): Boolean; override;\r\n function AddAll(const ACollection: IJclUnicodeStrCollection): Boolean; override;\r\n procedure Clear; override;\r\n function Contains(const AString: UnicodeString): Boolean; override;\r\n function ContainsAll(const ACollection: IJclUnicodeStrCollection): Boolean; override;\r\n function CollectionEquals(const ACollection: IJclUnicodeStrCollection): Boolean; override;\r\n function Extract(const AString: UnicodeString): Boolean; override;\r\n function ExtractAll(const ACollection: IJclUnicodeStrCollection): Boolean; override;\r\n function First: IJclUnicodeStrIterator; override;\r\n function IsEmpty: Boolean; override;\r\n function Last: IJclUnicodeStrIterator; override;\r\n function Remove(const AString: UnicodeString): Boolean; override;\r\n function RemoveAll(const ACollection: IJclUnicodeStrCollection): Boolean; override;\r\n function RetainAll(const ACollection: IJclUnicodeStrCollection): Boolean; override;\r\n function Size: Integer; override;\r\n {$IFDEF SUPPORTS_FOR_IN}\r\n function GetEnumerator: IJclUnicodeStrIterator; override;\r\n {$ENDIF SUPPORTS_FOR_IN}\r\n { IJclUnicodeStrTree }\r\n function GetRoot: IJclUnicodeStrTreeIterator;\r\n function GetTraverseOrder: TJclTraverseOrder;\r\n procedure SetTraverseOrder(Value: TJclTraverseOrder);\r\n property Root: IJclUnicodeStrTreeIterator read GetRoot;\r\n property TraverseOrder: TJclTraverseOrder read GetTraverseOrder write SetTraverseOrder;\r\n end;\r\n {$ENDIF SUPPORTS_UNICODE_STRING}\r\n\r\n {$IFDEF SUPPORTS_UNICODE_STRING}\r\n TJclUnicodeStrBinaryTreeIterator = class(TJclAbstractIterator, IJclUnicodeStrIterator, IJclUnicodeStrTreeIterator, IJclUnicodeStrBinaryTreeIterator)\r\n protected\r\n FCursor: TJclUnicodeStrBinaryNode;\r\n FStart: TItrStart;\r\n FOwnTree: IJclUnicodeStrCollection;\r\n FEqualityComparer: IJclUnicodeStrEqualityComparer;\r\n procedure AssignPropertiesTo(Dest: TJclAbstractIterator); override;\r\n function GetNextCursor: TJclUnicodeStrBinaryNode; virtual; abstract;\r\n function GetPreviousCursor: TJclUnicodeStrBinaryNode; virtual; abstract;\r\n public\r\n constructor Create(const AOwnTree: IJclUnicodeStrCollection; ACursor: TJclUnicodeStrBinaryNode; AValid: Boolean; AStart: TItrStart);\r\n { IJclUnicodeStrIterator }\r\n function Add(const AString: UnicodeString): Boolean;\r\n procedure Extract;\r\n function GetString: UnicodeString;\r\n function HasNext: Boolean;\r\n function HasPrevious: Boolean;\r\n function Insert(const AString: UnicodeString): Boolean;\r\n function IteratorEquals(const AIterator: IJclUnicodeStrIterator): Boolean;\r\n function Next: UnicodeString;\r\n function NextIndex: Integer;\r\n function Previous: UnicodeString;\r\n function PreviousIndex: Integer;\r\n procedure Remove;\r\n procedure Reset;\r\n procedure SetString(const AString: UnicodeString);\r\n {$IFDEF SUPPORTS_FOR_IN}\r\n function MoveNext: Boolean;\r\n property Current: UnicodeString read GetString;\r\n {$ENDIF SUPPORTS_FOR_IN}\r\n { IJclUnicodeStrTreeIterator }\r\n function AddChild(const AString: UnicodeString): Boolean;\r\n function ChildrenCount: Integer;\r\n procedure DeleteChild(Index: Integer);\r\n procedure DeleteChildren;\r\n procedure ExtractChild(Index: Integer);\r\n procedure ExtractChildren;\r\n function GetChild(Index: Integer): UnicodeString;\r\n function HasChild(Index: Integer): Boolean;\r\n function HasParent: Boolean;\r\n function IndexOfChild(const AString: UnicodeString): Integer;\r\n function InsertChild(Index: Integer; const AString: UnicodeString): Boolean;\r\n function Parent: UnicodeString;\r\n procedure SetChild(Index: Integer; const AString: UnicodeString);\r\n { IJclUnicodeStrBinaryTreeIterator }\r\n function HasLeft: Boolean;\r\n function HasRight: Boolean;\r\n function Left: UnicodeString;\r\n function Right: UnicodeString;\r\n end;\r\n\r\n TJclPreOrderUnicodeStrBinaryTreeIterator = class(TJclUnicodeStrBinaryTreeIterator, IJclUnicodeStrIterator, IJclUnicodeStrTreeIterator, IJclUnicodeStrBinaryTreeIterator,\r\n {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE} IJclIntfCloneable, IJclCloneable)\r\n protected\r\n function CreateEmptyIterator: TJclAbstractIterator; override;\r\n function GetNextCursor: TJclUnicodeStrBinaryNode; override;\r\n function GetPreviousCursor: TJclUnicodeStrBinaryNode; override;\r\n end;\r\n\r\n TJclInOrderUnicodeStrBinaryTreeIterator = class(TJclUnicodeStrBinaryTreeIterator, IJclUnicodeStrIterator, IJclUnicodeStrTreeIterator, IJclUnicodeStrBinaryTreeIterator,\r\n {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE} IJclIntfCloneable, IJclCloneable)\r\n protected\r\n function CreateEmptyIterator: TJclAbstractIterator; override;\r\n function GetNextCursor: TJclUnicodeStrBinaryNode; override;\r\n function GetPreviousCursor: TJclUnicodeStrBinaryNode; override;\r\n end;\r\n\r\n TJclPostOrderUnicodeStrBinaryTreeIterator = class(TJclUnicodeStrBinaryTreeIterator, IJclUnicodeStrIterator, IJclUnicodeStrTreeIterator, IJclUnicodeStrBinaryTreeIterator,\r\n {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE} IJclIntfCloneable, IJclCloneable)\r\n protected\r\n function CreateEmptyIterator: TJclAbstractIterator; override;\r\n function GetNextCursor: TJclUnicodeStrBinaryNode; override;\r\n function GetPreviousCursor: TJclUnicodeStrBinaryNode; override;\r\n end;\r\n {$ENDIF SUPPORTS_UNICODE_STRING}\r\n\r\n {$IFDEF CONTAINER_ANSISTR}\r\n TJclStrBinaryNode = TJclAnsiStrBinaryNode;\r\n {$ENDIF CONTAINER_ANSISTR}\r\n {$IFDEF CONTAINER_WIDESTR}\r\n TJclStrBinaryNode = TJclWideStrBinaryNode;\r\n {$ENDIF CONTAINER_WIDESTR}\r\n {$IFDEF CONTAINER_UNICODESTR}\r\n TJclStrBinaryNode = TJclUnicodeStrBinaryNode;\r\n {$ENDIF CONTAINER_UNICODESTR}\r\n\r\n {$IFDEF CONTAINER_ANSISTR}\r\n TJclStrBinaryTree = TJclAnsiStrBinaryTree;\r\n {$ENDIF CONTAINER_ANSISTR}\r\n {$IFDEF CONTAINER_WIDESTR}\r\n TJclStrBinaryTree = TJclWideStrBinaryTree;\r\n {$ENDIF CONTAINER_WIDESTR}\r\n {$IFDEF CONTAINER_UNICODESTR}\r\n TJclStrBinaryTree = TJclUnicodeStrBinaryTree;\r\n {$ENDIF CONTAINER_UNICODESTR}\r\n\r\n {$IFDEF CONTAINER_ANSISTR}\r\n TJclStrBinaryTreeIterator = TJclAnsiStrBinaryTreeIterator;\r\n TJclPreOrderStrBinaryTreeIterator = TJclPreOrderAnsiStrBinaryTreeIterator;\r\n TJclInOrderStrBinaryTreeIterator = TJclInOrderAnsiStrBinaryTreeIterator;\r\n TJclPostOrderStrBinaryTreeIterator = TJclPostOrderAnsiStrBinaryTreeIterator;\r\n {$ENDIF CONTAINER_ANSISTR}\r\n {$IFDEF CONTAINER_WIDESTR}\r\n TJclStrBinaryTreeIterator = TJclWideStrBinaryTreeIterator;\r\n TJclPreOrderStrBinaryTreeIterator = TJclPreOrderWideStrBinaryTreeIterator;\r\n TJclInOrderStrBinaryTreeIterator = TJclInOrderWideStrBinaryTreeIterator;\r\n TJclPostOrderStrBinaryTreeIterator = TJclPostOrderWideStrBinaryTreeIterator;\r\n {$ENDIF CONTAINER_WIDESTR}\r\n {$IFDEF CONTAINER_UNICODESTR}\r\n TJclStrBinaryTreeIterator = TJclUnicodeStrBinaryTreeIterator;\r\n TJclPreOrderStrBinaryTreeIterator = TJclPreOrderUnicodeStrBinaryTreeIterator;\r\n TJclInOrderStrBinaryTreeIterator = TJclInOrderUnicodeStrBinaryTreeIterator;\r\n TJclPostOrderStrBinaryTreeIterator = TJclPostOrderUnicodeStrBinaryTreeIterator;\r\n {$ENDIF CONTAINER_UNICODESTR}\r\n\r\n TJclSingleBinaryNode = class\r\n public\r\n Value: Single;\r\n Left: TJclSingleBinaryNode;\r\n Right: TJclSingleBinaryNode;\r\n Parent: TJclSingleBinaryNode;\r\n end;\r\n\r\n TJclSingleBinaryTree = class(TJclSingleAbstractContainer, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclIntfCloneable, IJclCloneable, IJclPackable, IJclBaseContainer,\r\n IJclSingleEqualityComparer, IJclSingleComparer, IJclSingleContainer, IJclSingleFlatContainer,\r\n IJclSingleCollection, IJclSingleTree)\r\n protected\r\n function CreateEmptyContainer: TJclAbstractContainerBase; override;\r\n private\r\n FMaxDepth: Integer;\r\n FRoot: TJclSingleBinaryNode;\r\n FTraverseOrder: TJclTraverseOrder;\r\n function BuildTree(const LeafArray: array of TJclSingleBinaryNode; Left, Right: Integer; Parent: TJclSingleBinaryNode;\r\n Offset: Integer): TJclSingleBinaryNode;\r\n function CloneNode(Node, Parent: TJclSingleBinaryNode): TJclSingleBinaryNode;\r\n protected\r\n procedure AssignDataTo(Dest: TJclAbstractContainerBase); override;\r\n procedure AssignPropertiesTo(Dest: TJclAbstractContainerBase); override;\r\n procedure AutoPack; override;\r\n public\r\n constructor Create(ACompare: TSingleCompare);\r\n destructor Destroy; override;\r\n { IJclPackable }\r\n procedure Pack; override;\r\n procedure SetCapacity(Value: Integer); override;\r\n { IJclSingleCollection }\r\n function Add(const AValue: Single): Boolean;\r\n function AddAll(const ACollection: IJclSingleCollection): Boolean;\r\n procedure Clear;\r\n function Contains(const AValue: Single): Boolean;\r\n function ContainsAll(const ACollection: IJclSingleCollection): Boolean;\r\n function CollectionEquals(const ACollection: IJclSingleCollection): Boolean;\r\n function Extract(const AValue: Single): Boolean;\r\n function ExtractAll(const ACollection: IJclSingleCollection): Boolean;\r\n function First: IJclSingleIterator;\r\n function IsEmpty: Boolean;\r\n function Last: IJclSingleIterator;\r\n function Remove(const AValue: Single): Boolean;\r\n function RemoveAll(const ACollection: IJclSingleCollection): Boolean;\r\n function RetainAll(const ACollection: IJclSingleCollection): Boolean;\r\n function Size: Integer;\r\n {$IFDEF SUPPORTS_FOR_IN}\r\n function GetEnumerator: IJclSingleIterator;\r\n {$ENDIF SUPPORTS_FOR_IN}\r\n { IJclSingleTree }\r\n function GetRoot: IJclSingleTreeIterator;\r\n function GetTraverseOrder: TJclTraverseOrder;\r\n procedure SetTraverseOrder(Value: TJclTraverseOrder);\r\n property Root: IJclSingleTreeIterator read GetRoot;\r\n property TraverseOrder: TJclTraverseOrder read GetTraverseOrder write SetTraverseOrder;\r\n end;\r\n\r\n TJclSingleBinaryTreeIterator = class(TJclAbstractIterator, IJclSingleIterator, IJclSingleTreeIterator, IJclSingleBinaryTreeIterator)\r\n protected\r\n FCursor: TJclSingleBinaryNode;\r\n FStart: TItrStart;\r\n FOwnTree: IJclSingleCollection;\r\n FEqualityComparer: IJclSingleEqualityComparer;\r\n procedure AssignPropertiesTo(Dest: TJclAbstractIterator); override;\r\n function GetNextCursor: TJclSingleBinaryNode; virtual; abstract;\r\n function GetPreviousCursor: TJclSingleBinaryNode; virtual; abstract;\r\n public\r\n constructor Create(const AOwnTree: IJclSingleCollection; ACursor: TJclSingleBinaryNode; AValid: Boolean; AStart: TItrStart);\r\n { IJclSingleIterator }\r\n function Add(const AValue: Single): Boolean;\r\n procedure Extract;\r\n function GetValue: Single;\r\n function HasNext: Boolean;\r\n function HasPrevious: Boolean;\r\n function Insert(const AValue: Single): Boolean;\r\n function IteratorEquals(const AIterator: IJclSingleIterator): Boolean;\r\n function Next: Single;\r\n function NextIndex: Integer;\r\n function Previous: Single;\r\n function PreviousIndex: Integer;\r\n procedure Remove;\r\n procedure Reset;\r\n procedure SetValue(const AValue: Single);\r\n {$IFDEF SUPPORTS_FOR_IN}\r\n function MoveNext: Boolean;\r\n property Current: Single read GetValue;\r\n {$ENDIF SUPPORTS_FOR_IN}\r\n { IJclSingleTreeIterator }\r\n function AddChild(const AValue: Single): Boolean;\r\n function ChildrenCount: Integer;\r\n procedure DeleteChild(Index: Integer);\r\n procedure DeleteChildren;\r\n procedure ExtractChild(Index: Integer);\r\n procedure ExtractChildren;\r\n function GetChild(Index: Integer): Single;\r\n function HasChild(Index: Integer): Boolean;\r\n function HasParent: Boolean;\r\n function IndexOfChild(const AValue: Single): Integer;\r\n function InsertChild(Index: Integer; const AValue: Single): Boolean;\r\n function Parent: Single;\r\n procedure SetChild(Index: Integer; const AValue: Single);\r\n { IJclSingleBinaryTreeIterator }\r\n function HasLeft: Boolean;\r\n function HasRight: Boolean;\r\n function Left: Single;\r\n function Right: Single;\r\n end;\r\n\r\n TJclPreOrderSingleBinaryTreeIterator = class(TJclSingleBinaryTreeIterator, IJclSingleIterator, IJclSingleTreeIterator, IJclSingleBinaryTreeIterator,\r\n {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE} IJclIntfCloneable, IJclCloneable)\r\n protected\r\n function CreateEmptyIterator: TJclAbstractIterator; override;\r\n function GetNextCursor: TJclSingleBinaryNode; override;\r\n function GetPreviousCursor: TJclSingleBinaryNode; override;\r\n end;\r\n\r\n TJclInOrderSingleBinaryTreeIterator = class(TJclSingleBinaryTreeIterator, IJclSingleIterator, IJclSingleTreeIterator, IJclSingleBinaryTreeIterator,\r\n {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE} IJclIntfCloneable, IJclCloneable)\r\n protected\r\n function CreateEmptyIterator: TJclAbstractIterator; override;\r\n function GetNextCursor: TJclSingleBinaryNode; override;\r\n function GetPreviousCursor: TJclSingleBinaryNode; override;\r\n end;\r\n\r\n TJclPostOrderSingleBinaryTreeIterator = class(TJclSingleBinaryTreeIterator, IJclSingleIterator, IJclSingleTreeIterator, IJclSingleBinaryTreeIterator,\r\n {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE} IJclIntfCloneable, IJclCloneable)\r\n protected\r\n function CreateEmptyIterator: TJclAbstractIterator; override;\r\n function GetNextCursor: TJclSingleBinaryNode; override;\r\n function GetPreviousCursor: TJclSingleBinaryNode; override;\r\n end;\r\n\r\n TJclDoubleBinaryNode = class\r\n public\r\n Value: Double;\r\n Left: TJclDoubleBinaryNode;\r\n Right: TJclDoubleBinaryNode;\r\n Parent: TJclDoubleBinaryNode;\r\n end;\r\n\r\n TJclDoubleBinaryTree = class(TJclDoubleAbstractContainer, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclIntfCloneable, IJclCloneable, IJclPackable, IJclBaseContainer,\r\n IJclDoubleEqualityComparer, IJclDoubleComparer, IJclDoubleContainer, IJclDoubleFlatContainer,\r\n IJclDoubleCollection, IJclDoubleTree)\r\n protected\r\n function CreateEmptyContainer: TJclAbstractContainerBase; override;\r\n private\r\n FMaxDepth: Integer;\r\n FRoot: TJclDoubleBinaryNode;\r\n FTraverseOrder: TJclTraverseOrder;\r\n function BuildTree(const LeafArray: array of TJclDoubleBinaryNode; Left, Right: Integer; Parent: TJclDoubleBinaryNode;\r\n Offset: Integer): TJclDoubleBinaryNode;\r\n function CloneNode(Node, Parent: TJclDoubleBinaryNode): TJclDoubleBinaryNode;\r\n protected\r\n procedure AssignDataTo(Dest: TJclAbstractContainerBase); override;\r\n procedure AssignPropertiesTo(Dest: TJclAbstractContainerBase); override;\r\n procedure AutoPack; override;\r\n public\r\n constructor Create(ACompare: TDoubleCompare);\r\n destructor Destroy; override;\r\n { IJclPackable }\r\n procedure Pack; override;\r\n procedure SetCapacity(Value: Integer); override;\r\n { IJclDoubleCollection }\r\n function Add(const AValue: Double): Boolean;\r\n function AddAll(const ACollection: IJclDoubleCollection): Boolean;\r\n procedure Clear;\r\n function Contains(const AValue: Double): Boolean;\r\n function ContainsAll(const ACollection: IJclDoubleCollection): Boolean;\r\n function CollectionEquals(const ACollection: IJclDoubleCollection): Boolean;\r\n function Extract(const AValue: Double): Boolean;\r\n function ExtractAll(const ACollection: IJclDoubleCollection): Boolean;\r\n function First: IJclDoubleIterator;\r\n function IsEmpty: Boolean;\r\n function Last: IJclDoubleIterator;\r\n function Remove(const AValue: Double): Boolean;\r\n function RemoveAll(const ACollection: IJclDoubleCollection): Boolean;\r\n function RetainAll(const ACollection: IJclDoubleCollection): Boolean;\r\n function Size: Integer;\r\n {$IFDEF SUPPORTS_FOR_IN}\r\n function GetEnumerator: IJclDoubleIterator;\r\n {$ENDIF SUPPORTS_FOR_IN}\r\n { IJclDoubleTree }\r\n function GetRoot: IJclDoubleTreeIterator;\r\n function GetTraverseOrder: TJclTraverseOrder;\r\n procedure SetTraverseOrder(Value: TJclTraverseOrder);\r\n property Root: IJclDoubleTreeIterator read GetRoot;\r\n property TraverseOrder: TJclTraverseOrder read GetTraverseOrder write SetTraverseOrder;\r\n end;\r\n\r\n TJclDoubleBinaryTreeIterator = class(TJclAbstractIterator, IJclDoubleIterator, IJclDoubleTreeIterator, IJclDoubleBinaryTreeIterator)\r\n protected\r\n FCursor: TJclDoubleBinaryNode;\r\n FStart: TItrStart;\r\n FOwnTree: IJclDoubleCollection;\r\n FEqualityComparer: IJclDoubleEqualityComparer;\r\n procedure AssignPropertiesTo(Dest: TJclAbstractIterator); override;\r\n function GetNextCursor: TJclDoubleBinaryNode; virtual; abstract;\r\n function GetPreviousCursor: TJclDoubleBinaryNode; virtual; abstract;\r\n public\r\n constructor Create(const AOwnTree: IJclDoubleCollection; ACursor: TJclDoubleBinaryNode; AValid: Boolean; AStart: TItrStart);\r\n { IJclDoubleIterator }\r\n function Add(const AValue: Double): Boolean;\r\n procedure Extract;\r\n function GetValue: Double;\r\n function HasNext: Boolean;\r\n function HasPrevious: Boolean;\r\n function Insert(const AValue: Double): Boolean;\r\n function IteratorEquals(const AIterator: IJclDoubleIterator): Boolean;\r\n function Next: Double;\r\n function NextIndex: Integer;\r\n function Previous: Double;\r\n function PreviousIndex: Integer;\r\n procedure Remove;\r\n procedure Reset;\r\n procedure SetValue(const AValue: Double);\r\n {$IFDEF SUPPORTS_FOR_IN}\r\n function MoveNext: Boolean;\r\n property Current: Double read GetValue;\r\n {$ENDIF SUPPORTS_FOR_IN}\r\n { IJclDoubleTreeIterator }\r\n function AddChild(const AValue: Double): Boolean;\r\n function ChildrenCount: Integer;\r\n procedure DeleteChild(Index: Integer);\r\n procedure DeleteChildren;\r\n procedure ExtractChild(Index: Integer);\r\n procedure ExtractChildren;\r\n function GetChild(Index: Integer): Double;\r\n function HasChild(Index: Integer): Boolean;\r\n function HasParent: Boolean;\r\n function IndexOfChild(const AValue: Double): Integer;\r\n function InsertChild(Index: Integer; const AValue: Double): Boolean;\r\n function Parent: Double;\r\n procedure SetChild(Index: Integer; const AValue: Double);\r\n { IJclDoubleBinaryTreeIterator }\r\n function HasLeft: Boolean;\r\n function HasRight: Boolean;\r\n function Left: Double;\r\n function Right: Double;\r\n end;\r\n\r\n TJclPreOrderDoubleBinaryTreeIterator = class(TJclDoubleBinaryTreeIterator, IJclDoubleIterator, IJclDoubleTreeIterator, IJclDoubleBinaryTreeIterator,\r\n {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE} IJclIntfCloneable, IJclCloneable)\r\n protected\r\n function CreateEmptyIterator: TJclAbstractIterator; override;\r\n function GetNextCursor: TJclDoubleBinaryNode; override;\r\n function GetPreviousCursor: TJclDoubleBinaryNode; override;\r\n end;\r\n\r\n TJclInOrderDoubleBinaryTreeIterator = class(TJclDoubleBinaryTreeIterator, IJclDoubleIterator, IJclDoubleTreeIterator, IJclDoubleBinaryTreeIterator,\r\n {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE} IJclIntfCloneable, IJclCloneable)\r\n protected\r\n function CreateEmptyIterator: TJclAbstractIterator; override;\r\n function GetNextCursor: TJclDoubleBinaryNode; override;\r\n function GetPreviousCursor: TJclDoubleBinaryNode; override;\r\n end;\r\n\r\n TJclPostOrderDoubleBinaryTreeIterator = class(TJclDoubleBinaryTreeIterator, IJclDoubleIterator, IJclDoubleTreeIterator, IJclDoubleBinaryTreeIterator,\r\n {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE} IJclIntfCloneable, IJclCloneable)\r\n protected\r\n function CreateEmptyIterator: TJclAbstractIterator; override;\r\n function GetNextCursor: TJclDoubleBinaryNode; override;\r\n function GetPreviousCursor: TJclDoubleBinaryNode; override;\r\n end;\r\n\r\n TJclExtendedBinaryNode = class\r\n public\r\n Value: Extended;\r\n Left: TJclExtendedBinaryNode;\r\n Right: TJclExtendedBinaryNode;\r\n Parent: TJclExtendedBinaryNode;\r\n end;\r\n\r\n TJclExtendedBinaryTree = class(TJclExtendedAbstractContainer, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclIntfCloneable, IJclCloneable, IJclPackable, IJclBaseContainer,\r\n IJclExtendedEqualityComparer, IJclExtendedComparer, IJclExtendedContainer, IJclExtendedFlatContainer,\r\n IJclExtendedCollection, IJclExtendedTree)\r\n protected\r\n function CreateEmptyContainer: TJclAbstractContainerBase; override;\r\n private\r\n FMaxDepth: Integer;\r\n FRoot: TJclExtendedBinaryNode;\r\n FTraverseOrder: TJclTraverseOrder;\r\n function BuildTree(const LeafArray: array of TJclExtendedBinaryNode; Left, Right: Integer; Parent: TJclExtendedBinaryNode;\r\n Offset: Integer): TJclExtendedBinaryNode;\r\n function CloneNode(Node, Parent: TJclExtendedBinaryNode): TJclExtendedBinaryNode;\r\n protected\r\n procedure AssignDataTo(Dest: TJclAbstractContainerBase); override;\r\n procedure AssignPropertiesTo(Dest: TJclAbstractContainerBase); override;\r\n procedure AutoPack; override;\r\n public\r\n constructor Create(ACompare: TExtendedCompare);\r\n destructor Destroy; override;\r\n { IJclPackable }\r\n procedure Pack; override;\r\n procedure SetCapacity(Value: Integer); override;\r\n { IJclExtendedCollection }\r\n function Add(const AValue: Extended): Boolean;\r\n function AddAll(const ACollection: IJclExtendedCollection): Boolean;\r\n procedure Clear;\r\n function Contains(const AValue: Extended): Boolean;\r\n function ContainsAll(const ACollection: IJclExtendedCollection): Boolean;\r\n function CollectionEquals(const ACollection: IJclExtendedCollection): Boolean;\r\n function Extract(const AValue: Extended): Boolean;\r\n function ExtractAll(const ACollection: IJclExtendedCollection): Boolean;\r\n function First: IJclExtendedIterator;\r\n function IsEmpty: Boolean;\r\n function Last: IJclExtendedIterator;\r\n function Remove(const AValue: Extended): Boolean;\r\n function RemoveAll(const ACollection: IJclExtendedCollection): Boolean;\r\n function RetainAll(const ACollection: IJclExtendedCollection): Boolean;\r\n function Size: Integer;\r\n {$IFDEF SUPPORTS_FOR_IN}\r\n function GetEnumerator: IJclExtendedIterator;\r\n {$ENDIF SUPPORTS_FOR_IN}\r\n { IJclExtendedTree }\r\n function GetRoot: IJclExtendedTreeIterator;\r\n function GetTraverseOrder: TJclTraverseOrder;\r\n procedure SetTraverseOrder(Value: TJclTraverseOrder);\r\n property Root: IJclExtendedTreeIterator read GetRoot;\r\n property TraverseOrder: TJclTraverseOrder read GetTraverseOrder write SetTraverseOrder;\r\n end;\r\n\r\n TJclExtendedBinaryTreeIterator = class(TJclAbstractIterator, IJclExtendedIterator, IJclExtendedTreeIterator, IJclExtendedBinaryTreeIterator)\r\n protected\r\n FCursor: TJclExtendedBinaryNode;\r\n FStart: TItrStart;\r\n FOwnTree: IJclExtendedCollection;\r\n FEqualityComparer: IJclExtendedEqualityComparer;\r\n procedure AssignPropertiesTo(Dest: TJclAbstractIterator); override;\r\n function GetNextCursor: TJclExtendedBinaryNode; virtual; abstract;\r\n function GetPreviousCursor: TJclExtendedBinaryNode; virtual; abstract;\r\n public\r\n constructor Create(const AOwnTree: IJclExtendedCollection; ACursor: TJclExtendedBinaryNode; AValid: Boolean; AStart: TItrStart);\r\n { IJclExtendedIterator }\r\n function Add(const AValue: Extended): Boolean;\r\n procedure Extract;\r\n function GetValue: Extended;\r\n function HasNext: Boolean;\r\n function HasPrevious: Boolean;\r\n function Insert(const AValue: Extended): Boolean;\r\n function IteratorEquals(const AIterator: IJclExtendedIterator): Boolean;\r\n function Next: Extended;\r\n function NextIndex: Integer;\r\n function Previous: Extended;\r\n function PreviousIndex: Integer;\r\n procedure Remove;\r\n procedure Reset;\r\n procedure SetValue(const AValue: Extended);\r\n {$IFDEF SUPPORTS_FOR_IN}\r\n function MoveNext: Boolean;\r\n property Current: Extended read GetValue;\r\n {$ENDIF SUPPORTS_FOR_IN}\r\n { IJclExtendedTreeIterator }\r\n function AddChild(const AValue: Extended): Boolean;\r\n function ChildrenCount: Integer;\r\n procedure DeleteChild(Index: Integer);\r\n procedure DeleteChildren;\r\n procedure ExtractChild(Index: Integer);\r\n procedure ExtractChildren;\r\n function GetChild(Index: Integer): Extended;\r\n function HasChild(Index: Integer): Boolean;\r\n function HasParent: Boolean;\r\n function IndexOfChild(const AValue: Extended): Integer;\r\n function InsertChild(Index: Integer; const AValue: Extended): Boolean;\r\n function Parent: Extended;\r\n procedure SetChild(Index: Integer; const AValue: Extended);\r\n { IJclExtendedBinaryTreeIterator }\r\n function HasLeft: Boolean;\r\n function HasRight: Boolean;\r\n function Left: Extended;\r\n function Right: Extended;\r\n end;\r\n\r\n TJclPreOrderExtendedBinaryTreeIterator = class(TJclExtendedBinaryTreeIterator, IJclExtendedIterator, IJclExtendedTreeIterator, IJclExtendedBinaryTreeIterator,\r\n {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE} IJclIntfCloneable, IJclCloneable)\r\n protected\r\n function CreateEmptyIterator: TJclAbstractIterator; override;\r\n function GetNextCursor: TJclExtendedBinaryNode; override;\r\n function GetPreviousCursor: TJclExtendedBinaryNode; override;\r\n end;\r\n\r\n TJclInOrderExtendedBinaryTreeIterator = class(TJclExtendedBinaryTreeIterator, IJclExtendedIterator, IJclExtendedTreeIterator, IJclExtendedBinaryTreeIterator,\r\n {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE} IJclIntfCloneable, IJclCloneable)\r\n protected\r\n function CreateEmptyIterator: TJclAbstractIterator; override;\r\n function GetNextCursor: TJclExtendedBinaryNode; override;\r\n function GetPreviousCursor: TJclExtendedBinaryNode; override;\r\n end;\r\n\r\n TJclPostOrderExtendedBinaryTreeIterator = class(TJclExtendedBinaryTreeIterator, IJclExtendedIterator, IJclExtendedTreeIterator, IJclExtendedBinaryTreeIterator,\r\n {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE} IJclIntfCloneable, IJclCloneable)\r\n protected\r\n function CreateEmptyIterator: TJclAbstractIterator; override;\r\n function GetNextCursor: TJclExtendedBinaryNode; override;\r\n function GetPreviousCursor: TJclExtendedBinaryNode; override;\r\n end;\r\n\r\n {$IFDEF MATH_SINGLE_PRECISION}\r\n TJclFloatBinaryNode = TJclSingleBinaryNode;\r\n {$ENDIF MATH_SINGLE_PRECISION}\r\n {$IFDEF MATH_DOUBLE_PRECISION}\r\n TJclFloatBinaryNode = TJclDoubleBinaryNode;\r\n {$ENDIF MATH_DOUBLE_PRECISION}\r\n {$IFDEF MATH_EXTENDED_PRECISION}\r\n TJclFloatBinaryNode = TJclExtendedBinaryNode;\r\n {$ENDIF MATH_EXTENDED_PRECISION}\r\n\r\n {$IFDEF MATH_SINGLE_PRECISION}\r\n TJclFloatBinaryTree = TJclSingleBinaryTree;\r\n {$ENDIF MATH_SINGLE_PRECISION}\r\n {$IFDEF MATH_DOUBLE_PRECISION}\r\n TJclFloatBinaryTree = TJclDoubleBinaryTree;\r\n {$ENDIF MATH_DOUBLE_PRECISION}\r\n {$IFDEF MATH_EXTENDED_PRECISION}\r\n TJclFloatBinaryTree = TJclExtendedBinaryTree;\r\n {$ENDIF MATH_EXTENDED_PRECISION}\r\n\r\n {$IFDEF MATH_SINGLE_PRECISION}\r\n TJclFloatBinaryTreeIterator = TJclSingleBinaryTreeIterator;\r\n TJclPreOrderFloatBinaryTreeIterator = TJclPreOrderSingleBinaryTreeIterator;\r\n TJclInOrderFloatBinaryTreeIterator = TJclInOrderSingleBinaryTreeIterator;\r\n TJclPostOrderFloatBinaryTreeIterator = TJclPostOrderSingleBinaryTreeIterator;\r\n {$ENDIF MATH_SINGLE_PRECISION}\r\n {$IFDEF MATH_DOUBLE_PRECISION}\r\n TJclFloatBinaryTreeIterator = TJclDoubleBinaryTreeIterator;\r\n TJclPreOrderFloatBinaryTreeIterator = TJclPreOrderDoubleBinaryTreeIterator;\r\n TJclInOrderFloatBinaryTreeIterator = TJclInOrderDoubleBinaryTreeIterator;\r\n TJclPostOrderFloatBinaryTreeIterator = TJclPostOrderDoubleBinaryTreeIterator;\r\n {$ENDIF MATH_DOUBLE_PRECISION}\r\n {$IFDEF MATH_EXTENDED_PRECISION}\r\n TJclFloatBinaryTreeIterator = TJclExtendedBinaryTreeIterator;\r\n TJclPreOrderFloatBinaryTreeIterator = TJclPreOrderExtendedBinaryTreeIterator;\r\n TJclInOrderFloatBinaryTreeIterator = TJclInOrderExtendedBinaryTreeIterator;\r\n TJclPostOrderFloatBinaryTreeIterator = TJclPostOrderExtendedBinaryTreeIterator;\r\n {$ENDIF MATH_EXTENDED_PRECISION}\r\n\r\n TJclIntegerBinaryNode = class\r\n public\r\n Value: Integer;\r\n Left: TJclIntegerBinaryNode;\r\n Right: TJclIntegerBinaryNode;\r\n Parent: TJclIntegerBinaryNode;\r\n end;\r\n\r\n TJclIntegerBinaryTree = class(TJclIntegerAbstractContainer, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclIntfCloneable, IJclCloneable, IJclPackable, IJclBaseContainer,\r\n IJclIntegerEqualityComparer, IJclIntegerComparer, IJclIntegerContainer, IJclIntegerFlatContainer,\r\n IJclIntegerCollection, IJclIntegerTree)\r\n protected\r\n function CreateEmptyContainer: TJclAbstractContainerBase; override;\r\n private\r\n FMaxDepth: Integer;\r\n FRoot: TJclIntegerBinaryNode;\r\n FTraverseOrder: TJclTraverseOrder;\r\n function BuildTree(const LeafArray: array of TJclIntegerBinaryNode; Left, Right: Integer; Parent: TJclIntegerBinaryNode;\r\n Offset: Integer): TJclIntegerBinaryNode;\r\n function CloneNode(Node, Parent: TJclIntegerBinaryNode): TJclIntegerBinaryNode;\r\n protected\r\n procedure AssignDataTo(Dest: TJclAbstractContainerBase); override;\r\n procedure AssignPropertiesTo(Dest: TJclAbstractContainerBase); override;\r\n procedure AutoPack; override;\r\n public\r\n constructor Create(ACompare: TIntegerCompare);\r\n destructor Destroy; override;\r\n { IJclPackable }\r\n procedure Pack; override;\r\n procedure SetCapacity(Value: Integer); override;\r\n { IJclIntegerCollection }\r\n function Add(AValue: Integer): Boolean;\r\n function AddAll(const ACollection: IJclIntegerCollection): Boolean;\r\n procedure Clear;\r\n function Contains(AValue: Integer): Boolean;\r\n function ContainsAll(const ACollection: IJclIntegerCollection): Boolean;\r\n function CollectionEquals(const ACollection: IJclIntegerCollection): Boolean;\r\n function Extract(AValue: Integer): Boolean;\r\n function ExtractAll(const ACollection: IJclIntegerCollection): Boolean;\r\n function First: IJclIntegerIterator;\r\n function IsEmpty: Boolean;\r\n function Last: IJclIntegerIterator;\r\n function Remove(AValue: Integer): Boolean;\r\n function RemoveAll(const ACollection: IJclIntegerCollection): Boolean;\r\n function RetainAll(const ACollection: IJclIntegerCollection): Boolean;\r\n function Size: Integer;\r\n {$IFDEF SUPPORTS_FOR_IN}\r\n function GetEnumerator: IJclIntegerIterator;\r\n {$ENDIF SUPPORTS_FOR_IN}\r\n { IJclIntegerTree }\r\n function GetRoot: IJclIntegerTreeIterator;\r\n function GetTraverseOrder: TJclTraverseOrder;\r\n procedure SetTraverseOrder(Value: TJclTraverseOrder);\r\n property Root: IJclIntegerTreeIterator read GetRoot;\r\n property TraverseOrder: TJclTraverseOrder read GetTraverseOrder write SetTraverseOrder;\r\n end;\r\n\r\n TJclIntegerBinaryTreeIterator = class(TJclAbstractIterator, IJclIntegerIterator, IJclIntegerTreeIterator, IJclIntegerBinaryTreeIterator)\r\n protected\r\n FCursor: TJclIntegerBinaryNode;\r\n FStart: TItrStart;\r\n FOwnTree: IJclIntegerCollection;\r\n FEqualityComparer: IJclIntegerEqualityComparer;\r\n procedure AssignPropertiesTo(Dest: TJclAbstractIterator); override;\r\n function GetNextCursor: TJclIntegerBinaryNode; virtual; abstract;\r\n function GetPreviousCursor: TJclIntegerBinaryNode; virtual; abstract;\r\n public\r\n constructor Create(const AOwnTree: IJclIntegerCollection; ACursor: TJclIntegerBinaryNode; AValid: Boolean; AStart: TItrStart);\r\n { IJclIntegerIterator }\r\n function Add(AValue: Integer): Boolean;\r\n procedure Extract;\r\n function GetValue: Integer;\r\n function HasNext: Boolean;\r\n function HasPrevious: Boolean;\r\n function Insert(AValue: Integer): Boolean;\r\n function IteratorEquals(const AIterator: IJclIntegerIterator): Boolean;\r\n function Next: Integer;\r\n function NextIndex: Integer;\r\n function Previous: Integer;\r\n function PreviousIndex: Integer;\r\n procedure Remove;\r\n procedure Reset;\r\n procedure SetValue(AValue: Integer);\r\n {$IFDEF SUPPORTS_FOR_IN}\r\n function MoveNext: Boolean;\r\n property Current: Integer read GetValue;\r\n {$ENDIF SUPPORTS_FOR_IN}\r\n { IJclIntegerTreeIterator }\r\n function AddChild(AValue: Integer): Boolean;\r\n function ChildrenCount: Integer;\r\n procedure DeleteChild(Index: Integer);\r\n procedure DeleteChildren;\r\n procedure ExtractChild(Index: Integer);\r\n procedure ExtractChildren;\r\n function GetChild(Index: Integer): Integer;\r\n function HasChild(Index: Integer): Boolean;\r\n function HasParent: Boolean;\r\n function IndexOfChild(AValue: Integer): Integer;\r\n function InsertChild(Index: Integer; AValue: Integer): Boolean;\r\n function Parent: Integer;\r\n procedure SetChild(Index: Integer; AValue: Integer);\r\n { IJclIntegerBinaryTreeIterator }\r\n function HasLeft: Boolean;\r\n function HasRight: Boolean;\r\n function Left: Integer;\r\n function Right: Integer;\r\n end;\r\n\r\n TJclPreOrderIntegerBinaryTreeIterator = class(TJclIntegerBinaryTreeIterator, IJclIntegerIterator, IJclIntegerTreeIterator, IJclIntegerBinaryTreeIterator,\r\n {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE} IJclIntfCloneable, IJclCloneable)\r\n protected\r\n function CreateEmptyIterator: TJclAbstractIterator; override;\r\n function GetNextCursor: TJclIntegerBinaryNode; override;\r\n function GetPreviousCursor: TJclIntegerBinaryNode; override;\r\n end;\r\n\r\n TJclInOrderIntegerBinaryTreeIterator = class(TJclIntegerBinaryTreeIterator, IJclIntegerIterator, IJclIntegerTreeIterator, IJclIntegerBinaryTreeIterator,\r\n {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE} IJclIntfCloneable, IJclCloneable)\r\n protected\r\n function CreateEmptyIterator: TJclAbstractIterator; override;\r\n function GetNextCursor: TJclIntegerBinaryNode; override;\r\n function GetPreviousCursor: TJclIntegerBinaryNode; override;\r\n end;\r\n\r\n TJclPostOrderIntegerBinaryTreeIterator = class(TJclIntegerBinaryTreeIterator, IJclIntegerIterator, IJclIntegerTreeIterator, IJclIntegerBinaryTreeIterator,\r\n {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE} IJclIntfCloneable, IJclCloneable)\r\n protected\r\n function CreateEmptyIterator: TJclAbstractIterator; override;\r\n function GetNextCursor: TJclIntegerBinaryNode; override;\r\n function GetPreviousCursor: TJclIntegerBinaryNode; override;\r\n end;\r\n\r\n TJclCardinalBinaryNode = class\r\n public\r\n Value: Cardinal;\r\n Left: TJclCardinalBinaryNode;\r\n Right: TJclCardinalBinaryNode;\r\n Parent: TJclCardinalBinaryNode;\r\n end;\r\n\r\n TJclCardinalBinaryTree = class(TJclCardinalAbstractContainer, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclIntfCloneable, IJclCloneable, IJclPackable, IJclBaseContainer,\r\n IJclCardinalEqualityComparer, IJclCardinalComparer, IJclCardinalContainer, IJclCardinalFlatContainer,\r\n IJclCardinalCollection, IJclCardinalTree)\r\n protected\r\n function CreateEmptyContainer: TJclAbstractContainerBase; override;\r\n private\r\n FMaxDepth: Integer;\r\n FRoot: TJclCardinalBinaryNode;\r\n FTraverseOrder: TJclTraverseOrder;\r\n function BuildTree(const LeafArray: array of TJclCardinalBinaryNode; Left, Right: Integer; Parent: TJclCardinalBinaryNode;\r\n Offset: Integer): TJclCardinalBinaryNode;\r\n function CloneNode(Node, Parent: TJclCardinalBinaryNode): TJclCardinalBinaryNode;\r\n protected\r\n procedure AssignDataTo(Dest: TJclAbstractContainerBase); override;\r\n procedure AssignPropertiesTo(Dest: TJclAbstractContainerBase); override;\r\n procedure AutoPack; override;\r\n public\r\n constructor Create(ACompare: TCardinalCompare);\r\n destructor Destroy; override;\r\n { IJclPackable }\r\n procedure Pack; override;\r\n procedure SetCapacity(Value: Integer); override;\r\n { IJclCardinalCollection }\r\n function Add(AValue: Cardinal): Boolean;\r\n function AddAll(const ACollection: IJclCardinalCollection): Boolean;\r\n procedure Clear;\r\n function Contains(AValue: Cardinal): Boolean;\r\n function ContainsAll(const ACollection: IJclCardinalCollection): Boolean;\r\n function CollectionEquals(const ACollection: IJclCardinalCollection): Boolean;\r\n function Extract(AValue: Cardinal): Boolean;\r\n function ExtractAll(const ACollection: IJclCardinalCollection): Boolean;\r\n function First: IJclCardinalIterator;\r\n function IsEmpty: Boolean;\r\n function Last: IJclCardinalIterator;\r\n function Remove(AValue: Cardinal): Boolean;\r\n function RemoveAll(const ACollection: IJclCardinalCollection): Boolean;\r\n function RetainAll(const ACollection: IJclCardinalCollection): Boolean;\r\n function Size: Integer;\r\n {$IFDEF SUPPORTS_FOR_IN}\r\n function GetEnumerator: IJclCardinalIterator;\r\n {$ENDIF SUPPORTS_FOR_IN}\r\n { IJclCardinalTree }\r\n function GetRoot: IJclCardinalTreeIterator;\r\n function GetTraverseOrder: TJclTraverseOrder;\r\n procedure SetTraverseOrder(Value: TJclTraverseOrder);\r\n property Root: IJclCardinalTreeIterator read GetRoot;\r\n property TraverseOrder: TJclTraverseOrder read GetTraverseOrder write SetTraverseOrder;\r\n end;\r\n\r\n TJclCardinalBinaryTreeIterator = class(TJclAbstractIterator, IJclCardinalIterator, IJclCardinalTreeIterator, IJclCardinalBinaryTreeIterator)\r\n protected\r\n FCursor: TJclCardinalBinaryNode;\r\n FStart: TItrStart;\r\n FOwnTree: IJclCardinalCollection;\r\n FEqualityComparer: IJclCardinalEqualityComparer;\r\n procedure AssignPropertiesTo(Dest: TJclAbstractIterator); override;\r\n function GetNextCursor: TJclCardinalBinaryNode; virtual; abstract;\r\n function GetPreviousCursor: TJclCardinalBinaryNode; virtual; abstract;\r\n public\r\n constructor Create(const AOwnTree: IJclCardinalCollection; ACursor: TJclCardinalBinaryNode; AValid: Boolean; AStart: TItrStart);\r\n { IJclCardinalIterator }\r\n function Add(AValue: Cardinal): Boolean;\r\n procedure Extract;\r\n function GetValue: Cardinal;\r\n function HasNext: Boolean;\r\n function HasPrevious: Boolean;\r\n function Insert(AValue: Cardinal): Boolean;\r\n function IteratorEquals(const AIterator: IJclCardinalIterator): Boolean;\r\n function Next: Cardinal;\r\n function NextIndex: Integer;\r\n function Previous: Cardinal;\r\n function PreviousIndex: Integer;\r\n procedure Remove;\r\n procedure Reset;\r\n procedure SetValue(AValue: Cardinal);\r\n {$IFDEF SUPPORTS_FOR_IN}\r\n function MoveNext: Boolean;\r\n property Current: Cardinal read GetValue;\r\n {$ENDIF SUPPORTS_FOR_IN}\r\n { IJclCardinalTreeIterator }\r\n function AddChild(AValue: Cardinal): Boolean;\r\n function ChildrenCount: Integer;\r\n procedure DeleteChild(Index: Integer);\r\n procedure DeleteChildren;\r\n procedure ExtractChild(Index: Integer);\r\n procedure ExtractChildren;\r\n function GetChild(Index: Integer): Cardinal;\r\n function HasChild(Index: Integer): Boolean;\r\n function HasParent: Boolean;\r\n function IndexOfChild(AValue: Cardinal): Integer;\r\n function InsertChild(Index: Integer; AValue: Cardinal): Boolean;\r\n function Parent: Cardinal;\r\n procedure SetChild(Index: Integer; AValue: Cardinal);\r\n { IJclCardinalBinaryTreeIterator }\r\n function HasLeft: Boolean;\r\n function HasRight: Boolean;\r\n function Left: Cardinal;\r\n function Right: Cardinal;\r\n end;\r\n\r\n TJclPreOrderCardinalBinaryTreeIterator = class(TJclCardinalBinaryTreeIterator, IJclCardinalIterator, IJclCardinalTreeIterator, IJclCardinalBinaryTreeIterator,\r\n {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE} IJclIntfCloneable, IJclCloneable)\r\n protected\r\n function CreateEmptyIterator: TJclAbstractIterator; override;\r\n function GetNextCursor: TJclCardinalBinaryNode; override;\r\n function GetPreviousCursor: TJclCardinalBinaryNode; override;\r\n end;\r\n\r\n TJclInOrderCardinalBinaryTreeIterator = class(TJclCardinalBinaryTreeIterator, IJclCardinalIterator, IJclCardinalTreeIterator, IJclCardinalBinaryTreeIterator,\r\n {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE} IJclIntfCloneable, IJclCloneable)\r\n protected\r\n function CreateEmptyIterator: TJclAbstractIterator; override;\r\n function GetNextCursor: TJclCardinalBinaryNode; override;\r\n function GetPreviousCursor: TJclCardinalBinaryNode; override;\r\n end;\r\n\r\n TJclPostOrderCardinalBinaryTreeIterator = class(TJclCardinalBinaryTreeIterator, IJclCardinalIterator, IJclCardinalTreeIterator, IJclCardinalBinaryTreeIterator,\r\n {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE} IJclIntfCloneable, IJclCloneable)\r\n protected\r\n function CreateEmptyIterator: TJclAbstractIterator; override;\r\n function GetNextCursor: TJclCardinalBinaryNode; override;\r\n function GetPreviousCursor: TJclCardinalBinaryNode; override;\r\n end;\r\n\r\n TJclInt64BinaryNode = class\r\n public\r\n Value: Int64;\r\n Left: TJclInt64BinaryNode;\r\n Right: TJclInt64BinaryNode;\r\n Parent: TJclInt64BinaryNode;\r\n end;\r\n\r\n TJclInt64BinaryTree = class(TJclInt64AbstractContainer, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclIntfCloneable, IJclCloneable, IJclPackable, IJclBaseContainer,\r\n IJclInt64EqualityComparer, IJclInt64Comparer, IJclInt64Container, IJclInt64FlatContainer,\r\n IJclInt64Collection, IJclInt64Tree)\r\n protected\r\n function CreateEmptyContainer: TJclAbstractContainerBase; override;\r\n private\r\n FMaxDepth: Integer;\r\n FRoot: TJclInt64BinaryNode;\r\n FTraverseOrder: TJclTraverseOrder;\r\n function BuildTree(const LeafArray: array of TJclInt64BinaryNode; Left, Right: Integer; Parent: TJclInt64BinaryNode;\r\n Offset: Integer): TJclInt64BinaryNode;\r\n function CloneNode(Node, Parent: TJclInt64BinaryNode): TJclInt64BinaryNode;\r\n protected\r\n procedure AssignDataTo(Dest: TJclAbstractContainerBase); override;\r\n procedure AssignPropertiesTo(Dest: TJclAbstractContainerBase); override;\r\n procedure AutoPack; override;\r\n public\r\n constructor Create(ACompare: TInt64Compare);\r\n destructor Destroy; override;\r\n { IJclPackable }\r\n procedure Pack; override;\r\n procedure SetCapacity(Value: Integer); override;\r\n { IJclInt64Collection }\r\n function Add(const AValue: Int64): Boolean;\r\n function AddAll(const ACollection: IJclInt64Collection): Boolean;\r\n procedure Clear;\r\n function Contains(const AValue: Int64): Boolean;\r\n function ContainsAll(const ACollection: IJclInt64Collection): Boolean;\r\n function CollectionEquals(const ACollection: IJclInt64Collection): Boolean;\r\n function Extract(const AValue: Int64): Boolean;\r\n function ExtractAll(const ACollection: IJclInt64Collection): Boolean;\r\n function First: IJclInt64Iterator;\r\n function IsEmpty: Boolean;\r\n function Last: IJclInt64Iterator;\r\n function Remove(const AValue: Int64): Boolean;\r\n function RemoveAll(const ACollection: IJclInt64Collection): Boolean;\r\n function RetainAll(const ACollection: IJclInt64Collection): Boolean;\r\n function Size: Integer;\r\n {$IFDEF SUPPORTS_FOR_IN}\r\n function GetEnumerator: IJclInt64Iterator;\r\n {$ENDIF SUPPORTS_FOR_IN}\r\n { IJclInt64Tree }\r\n function GetRoot: IJclInt64TreeIterator;\r\n function GetTraverseOrder: TJclTraverseOrder;\r\n procedure SetTraverseOrder(Value: TJclTraverseOrder);\r\n property Root: IJclInt64TreeIterator read GetRoot;\r\n property TraverseOrder: TJclTraverseOrder read GetTraverseOrder write SetTraverseOrder;\r\n end;\r\n\r\n TJclInt64BinaryTreeIterator = class(TJclAbstractIterator, IJclInt64Iterator, IJclInt64TreeIterator, IJclInt64BinaryTreeIterator)\r\n protected\r\n FCursor: TJclInt64BinaryNode;\r\n FStart: TItrStart;\r\n FOwnTree: IJclInt64Collection;\r\n FEqualityComparer: IJclInt64EqualityComparer;\r\n procedure AssignPropertiesTo(Dest: TJclAbstractIterator); override;\r\n function GetNextCursor: TJclInt64BinaryNode; virtual; abstract;\r\n function GetPreviousCursor: TJclInt64BinaryNode; virtual; abstract;\r\n public\r\n constructor Create(const AOwnTree: IJclInt64Collection; ACursor: TJclInt64BinaryNode; AValid: Boolean; AStart: TItrStart);\r\n { IJclInt64Iterator }\r\n function Add(const AValue: Int64): Boolean;\r\n procedure Extract;\r\n function GetValue: Int64;\r\n function HasNext: Boolean;\r\n function HasPrevious: Boolean;\r\n function Insert(const AValue: Int64): Boolean;\r\n function IteratorEquals(const AIterator: IJclInt64Iterator): Boolean;\r\n function Next: Int64;\r\n function NextIndex: Integer;\r\n function Previous: Int64;\r\n function PreviousIndex: Integer;\r\n procedure Remove;\r\n procedure Reset;\r\n procedure SetValue(const AValue: Int64);\r\n {$IFDEF SUPPORTS_FOR_IN}\r\n function MoveNext: Boolean;\r\n property Current: Int64 read GetValue;\r\n {$ENDIF SUPPORTS_FOR_IN}\r\n { IJclInt64TreeIterator }\r\n function AddChild(const AValue: Int64): Boolean;\r\n function ChildrenCount: Integer;\r\n procedure DeleteChild(Index: Integer);\r\n procedure DeleteChildren;\r\n procedure ExtractChild(Index: Integer);\r\n procedure ExtractChildren;\r\n function GetChild(Index: Integer): Int64;\r\n function HasChild(Index: Integer): Boolean;\r\n function HasParent: Boolean;\r\n function IndexOfChild(const AValue: Int64): Integer;\r\n function InsertChild(Index: Integer; const AValue: Int64): Boolean;\r\n function Parent: Int64;\r\n procedure SetChild(Index: Integer; const AValue: Int64);\r\n { IJclInt64BinaryTreeIterator }\r\n function HasLeft: Boolean;\r\n function HasRight: Boolean;\r\n function Left: Int64;\r\n function Right: Int64;\r\n end;\r\n\r\n TJclPreOrderInt64BinaryTreeIterator = class(TJclInt64BinaryTreeIterator, IJclInt64Iterator, IJclInt64TreeIterator, IJclInt64BinaryTreeIterator,\r\n {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE} IJclIntfCloneable, IJclCloneable)\r\n protected\r\n function CreateEmptyIterator: TJclAbstractIterator; override;\r\n function GetNextCursor: TJclInt64BinaryNode; override;\r\n function GetPreviousCursor: TJclInt64BinaryNode; override;\r\n end;\r\n\r\n TJclInOrderInt64BinaryTreeIterator = class(TJclInt64BinaryTreeIterator, IJclInt64Iterator, IJclInt64TreeIterator, IJclInt64BinaryTreeIterator,\r\n {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE} IJclIntfCloneable, IJclCloneable)\r\n protected\r\n function CreateEmptyIterator: TJclAbstractIterator; override;\r\n function GetNextCursor: TJclInt64BinaryNode; override;\r\n function GetPreviousCursor: TJclInt64BinaryNode; override;\r\n end;\r\n\r\n TJclPostOrderInt64BinaryTreeIterator = class(TJclInt64BinaryTreeIterator, IJclInt64Iterator, IJclInt64TreeIterator, IJclInt64BinaryTreeIterator,\r\n {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE} IJclIntfCloneable, IJclCloneable)\r\n protected\r\n function CreateEmptyIterator: TJclAbstractIterator; override;\r\n function GetNextCursor: TJclInt64BinaryNode; override;\r\n function GetPreviousCursor: TJclInt64BinaryNode; override;\r\n end;\r\n\r\n TJclPtrBinaryNode = class\r\n public\r\n Value: Pointer;\r\n Left: TJclPtrBinaryNode;\r\n Right: TJclPtrBinaryNode;\r\n Parent: TJclPtrBinaryNode;\r\n end;\r\n\r\n TJclPtrBinaryTree = class(TJclPtrAbstractContainer, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclIntfCloneable, IJclCloneable, IJclPackable, IJclBaseContainer,\r\n IJclPtrEqualityComparer, IJclPtrComparer, IJclPtrContainer, IJclPtrFlatContainer,\r\n IJclPtrCollection, IJclPtrTree)\r\n protected\r\n function CreateEmptyContainer: TJclAbstractContainerBase; override;\r\n private\r\n FMaxDepth: Integer;\r\n FRoot: TJclPtrBinaryNode;\r\n FTraverseOrder: TJclTraverseOrder;\r\n function BuildTree(const LeafArray: array of TJclPtrBinaryNode; Left, Right: Integer; Parent: TJclPtrBinaryNode;\r\n Offset: Integer): TJclPtrBinaryNode;\r\n function CloneNode(Node, Parent: TJclPtrBinaryNode): TJclPtrBinaryNode;\r\n protected\r\n procedure AssignDataTo(Dest: TJclAbstractContainerBase); override;\r\n procedure AssignPropertiesTo(Dest: TJclAbstractContainerBase); override;\r\n procedure AutoPack; override;\r\n public\r\n constructor Create(ACompare: TPtrCompare);\r\n destructor Destroy; override;\r\n { IJclPackable }\r\n procedure Pack; override;\r\n procedure SetCapacity(Value: Integer); override;\r\n { IJclPtrCollection }\r\n function Add(APtr: Pointer): Boolean;\r\n function AddAll(const ACollection: IJclPtrCollection): Boolean;\r\n procedure Clear;\r\n function Contains(APtr: Pointer): Boolean;\r\n function ContainsAll(const ACollection: IJclPtrCollection): Boolean;\r\n function CollectionEquals(const ACollection: IJclPtrCollection): Boolean;\r\n function Extract(APtr: Pointer): Boolean;\r\n function ExtractAll(const ACollection: IJclPtrCollection): Boolean;\r\n function First: IJclPtrIterator;\r\n function IsEmpty: Boolean;\r\n function Last: IJclPtrIterator;\r\n function Remove(APtr: Pointer): Boolean;\r\n function RemoveAll(const ACollection: IJclPtrCollection): Boolean;\r\n function RetainAll(const ACollection: IJclPtrCollection): Boolean;\r\n function Size: Integer;\r\n {$IFDEF SUPPORTS_FOR_IN}\r\n function GetEnumerator: IJclPtrIterator;\r\n {$ENDIF SUPPORTS_FOR_IN}\r\n { IJclPtrTree }\r\n function GetRoot: IJclPtrTreeIterator;\r\n function GetTraverseOrder: TJclTraverseOrder;\r\n procedure SetTraverseOrder(Value: TJclTraverseOrder);\r\n property Root: IJclPtrTreeIterator read GetRoot;\r\n property TraverseOrder: TJclTraverseOrder read GetTraverseOrder write SetTraverseOrder;\r\n end;\r\n\r\n TJclPtrBinaryTreeIterator = class(TJclAbstractIterator, IJclPtrIterator, IJclPtrTreeIterator, IJclPtrBinaryTreeIterator)\r\n protected\r\n FCursor: TJclPtrBinaryNode;\r\n FStart: TItrStart;\r\n FOwnTree: IJclPtrCollection;\r\n FEqualityComparer: IJclPtrEqualityComparer;\r\n procedure AssignPropertiesTo(Dest: TJclAbstractIterator); override;\r\n function GetNextCursor: TJclPtrBinaryNode; virtual; abstract;\r\n function GetPreviousCursor: TJclPtrBinaryNode; virtual; abstract;\r\n public\r\n constructor Create(const AOwnTree: IJclPtrCollection; ACursor: TJclPtrBinaryNode; AValid: Boolean; AStart: TItrStart);\r\n { IJclPtrIterator }\r\n function Add(APtr: Pointer): Boolean;\r\n procedure Extract;\r\n function GetPointer: Pointer;\r\n function HasNext: Boolean;\r\n function HasPrevious: Boolean;\r\n function Insert(APtr: Pointer): Boolean;\r\n function IteratorEquals(const AIterator: IJclPtrIterator): Boolean;\r\n function Next: Pointer;\r\n function NextIndex: Integer;\r\n function Previous: Pointer;\r\n function PreviousIndex: Integer;\r\n procedure Remove;\r\n procedure Reset;\r\n procedure SetPointer(APtr: Pointer);\r\n {$IFDEF SUPPORTS_FOR_IN}\r\n function MoveNext: Boolean;\r\n property Current: Pointer read GetPointer;\r\n {$ENDIF SUPPORTS_FOR_IN}\r\n { IJclPtrTreeIterator }\r\n function AddChild(APtr: Pointer): Boolean;\r\n function ChildrenCount: Integer;\r\n procedure DeleteChild(Index: Integer);\r\n procedure DeleteChildren;\r\n procedure ExtractChild(Index: Integer);\r\n procedure ExtractChildren;\r\n function GetChild(Index: Integer): Pointer;\r\n function HasChild(Index: Integer): Boolean;\r\n function HasParent: Boolean;\r\n function IndexOfChild(APtr: Pointer): Integer;\r\n function InsertChild(Index: Integer; APtr: Pointer): Boolean;\r\n function Parent: Pointer;\r\n procedure SetChild(Index: Integer; APtr: Pointer);\r\n { IJclPtrBinaryTreeIterator }\r\n function HasLeft: Boolean;\r\n function HasRight: Boolean;\r\n function Left: Pointer;\r\n function Right: Pointer;\r\n end;\r\n\r\n TJclPreOrderPtrBinaryTreeIterator = class(TJclPtrBinaryTreeIterator, IJclPtrIterator, IJclPtrTreeIterator, IJclPtrBinaryTreeIterator,\r\n {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE} IJclIntfCloneable, IJclCloneable)\r\n protected\r\n function CreateEmptyIterator: TJclAbstractIterator; override;\r\n function GetNextCursor: TJclPtrBinaryNode; override;\r\n function GetPreviousCursor: TJclPtrBinaryNode; override;\r\n end;\r\n\r\n TJclInOrderPtrBinaryTreeIterator = class(TJclPtrBinaryTreeIterator, IJclPtrIterator, IJclPtrTreeIterator, IJclPtrBinaryTreeIterator,\r\n {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE} IJclIntfCloneable, IJclCloneable)\r\n protected\r\n function CreateEmptyIterator: TJclAbstractIterator; override;\r\n function GetNextCursor: TJclPtrBinaryNode; override;\r\n function GetPreviousCursor: TJclPtrBinaryNode; override;\r\n end;\r\n\r\n TJclPostOrderPtrBinaryTreeIterator = class(TJclPtrBinaryTreeIterator, IJclPtrIterator, IJclPtrTreeIterator, IJclPtrBinaryTreeIterator,\r\n {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE} IJclIntfCloneable, IJclCloneable)\r\n protected\r\n function CreateEmptyIterator: TJclAbstractIterator; override;\r\n function GetNextCursor: TJclPtrBinaryNode; override;\r\n function GetPreviousCursor: TJclPtrBinaryNode; override;\r\n end;\r\n\r\n TJclBinaryNode = class\r\n public\r\n Value: TObject;\r\n Left: TJclBinaryNode;\r\n Right: TJclBinaryNode;\r\n Parent: TJclBinaryNode;\r\n end;\r\n\r\n TJclBinaryTree = class(TJclAbstractContainer, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclIntfCloneable, IJclCloneable, IJclPackable, IJclBaseContainer,\r\n IJclEqualityComparer, IJclComparer, IJclContainer, IJclFlatContainer, IJclObjectOwner,\r\n IJclCollection, IJclTree)\r\n protected\r\n function CreateEmptyContainer: TJclAbstractContainerBase; override;\r\n private\r\n FMaxDepth: Integer;\r\n FRoot: TJclBinaryNode;\r\n FTraverseOrder: TJclTraverseOrder;\r\n function BuildTree(const LeafArray: array of TJclBinaryNode; Left, Right: Integer; Parent: TJclBinaryNode;\r\n Offset: Integer): TJclBinaryNode;\r\n function CloneNode(Node, Parent: TJclBinaryNode): TJclBinaryNode;\r\n protected\r\n procedure AssignDataTo(Dest: TJclAbstractContainerBase); override;\r\n procedure AssignPropertiesTo(Dest: TJclAbstractContainerBase); override;\r\n procedure AutoPack; override;\r\n public\r\n constructor Create(ACompare: TCompare; AOwnsObjects: Boolean);\r\n destructor Destroy; override;\r\n { IJclPackable }\r\n procedure Pack; override;\r\n procedure SetCapacity(Value: Integer); override;\r\n { IJclCollection }\r\n function Add(AObject: TObject): Boolean;\r\n function AddAll(const ACollection: IJclCollection): Boolean;\r\n procedure Clear;\r\n function Contains(AObject: TObject): Boolean;\r\n function ContainsAll(const ACollection: IJclCollection): Boolean;\r\n function CollectionEquals(const ACollection: IJclCollection): Boolean;\r\n function Extract(AObject: TObject): Boolean;\r\n function ExtractAll(const ACollection: IJclCollection): Boolean;\r\n function First: IJclIterator;\r\n function IsEmpty: Boolean;\r\n function Last: IJclIterator;\r\n function Remove(AObject: TObject): Boolean;\r\n function RemoveAll(const ACollection: IJclCollection): Boolean;\r\n function RetainAll(const ACollection: IJclCollection): Boolean;\r\n function Size: Integer;\r\n {$IFDEF SUPPORTS_FOR_IN}\r\n function GetEnumerator: IJclIterator;\r\n {$ENDIF SUPPORTS_FOR_IN}\r\n { IJclTree }\r\n function GetRoot: IJclTreeIterator;\r\n function GetTraverseOrder: TJclTraverseOrder;\r\n procedure SetTraverseOrder(Value: TJclTraverseOrder);\r\n property Root: IJclTreeIterator read GetRoot;\r\n property TraverseOrder: TJclTraverseOrder read GetTraverseOrder write SetTraverseOrder;\r\n end;\r\n\r\n TJclBinaryTreeIterator = class(TJclAbstractIterator, IJclIterator, IJclTreeIterator, IJclBinaryTreeIterator)\r\n protected\r\n FCursor: TJclBinaryNode;\r\n FStart: TItrStart;\r\n FOwnTree: IJclCollection;\r\n FEqualityComparer: IJclEqualityComparer;\r\n procedure AssignPropertiesTo(Dest: TJclAbstractIterator); override;\r\n function GetNextCursor: TJclBinaryNode; virtual; abstract;\r\n function GetPreviousCursor: TJclBinaryNode; virtual; abstract;\r\n public\r\n constructor Create(const AOwnTree: IJclCollection; ACursor: TJclBinaryNode; AValid: Boolean; AStart: TItrStart);\r\n { IJclIterator }\r\n function Add(AObject: TObject): Boolean;\r\n procedure Extract;\r\n function GetObject: TObject;\r\n function HasNext: Boolean;\r\n function HasPrevious: Boolean;\r\n function Insert(AObject: TObject): Boolean;\r\n function IteratorEquals(const AIterator: IJclIterator): Boolean;\r\n function Next: TObject;\r\n function NextIndex: Integer;\r\n function Previous: TObject;\r\n function PreviousIndex: Integer;\r\n procedure Remove;\r\n procedure Reset;\r\n procedure SetObject(AObject: TObject);\r\n {$IFDEF SUPPORTS_FOR_IN}\r\n function MoveNext: Boolean;\r\n property Current: TObject read GetObject;\r\n {$ENDIF SUPPORTS_FOR_IN}\r\n { IJclTreeIterator }\r\n function AddChild(AObject: TObject): Boolean;\r\n function ChildrenCount: Integer;\r\n procedure DeleteChild(Index: Integer);\r\n procedure DeleteChildren;\r\n procedure ExtractChild(Index: Integer);\r\n procedure ExtractChildren;\r\n function GetChild(Index: Integer): TObject;\r\n function HasChild(Index: Integer): Boolean;\r\n function HasParent: Boolean;\r\n function IndexOfChild(AObject: TObject): Integer;\r\n function InsertChild(Index: Integer; AObject: TObject): Boolean;\r\n function Parent: TObject;\r\n procedure SetChild(Index: Integer; AObject: TObject);\r\n { IJclBinaryTreeIterator }\r\n function HasLeft: Boolean;\r\n function HasRight: Boolean;\r\n function Left: TObject;\r\n function Right: TObject;\r\n end;\r\n\r\n TJclPreOrderBinaryTreeIterator = class(TJclBinaryTreeIterator, IJclIterator, IJclTreeIterator, IJclBinaryTreeIterator,\r\n {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE} IJclIntfCloneable, IJclCloneable)\r\n protected\r\n function CreateEmptyIterator: TJclAbstractIterator; override;\r\n function GetNextCursor: TJclBinaryNode; override;\r\n function GetPreviousCursor: TJclBinaryNode; override;\r\n end;\r\n\r\n TJclInOrderBinaryTreeIterator = class(TJclBinaryTreeIterator, IJclIterator, IJclTreeIterator, IJclBinaryTreeIterator,\r\n {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE} IJclIntfCloneable, IJclCloneable)\r\n protected\r\n function CreateEmptyIterator: TJclAbstractIterator; override;\r\n function GetNextCursor: TJclBinaryNode; override;\r\n function GetPreviousCursor: TJclBinaryNode; override;\r\n end;\r\n\r\n TJclPostOrderBinaryTreeIterator = class(TJclBinaryTreeIterator, IJclIterator, IJclTreeIterator, IJclBinaryTreeIterator,\r\n {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE} IJclIntfCloneable, IJclCloneable)\r\n protected\r\n function CreateEmptyIterator: TJclAbstractIterator; override;\r\n function GetNextCursor: TJclBinaryNode; override;\r\n function GetPreviousCursor: TJclBinaryNode; override;\r\n end;\r\n\r\n\r\n {$IFDEF SUPPORTS_GENERICS}\r\n //DOM-IGNORE-BEGIN\r\n\r\n TJclBinaryNode = class\r\n public\r\n Value: T;\r\n Left: TJclBinaryNode;\r\n Right: TJclBinaryNode;\r\n Parent: TJclBinaryNode;\r\n end;\r\n\r\n TJclBinaryTreeIterator = class;\r\n TJclPreOrderBinaryTreeIterator = class;\r\n TJclInOrderBinaryTreeIterator = class;\r\n TJclPostOrderBinaryTreeIterator = class;\r\n\r\n TJclBinaryTree = class(TJclAbstractContainer, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclIntfCloneable, IJclCloneable, IJclPackable, IJclBaseContainer,\r\n IJclEqualityComparer, IJclComparer, IJclContainer, IJclFlatContainer,IJclItemOwner,\r\n IJclCollection, IJclTree)\r\n protected\r\n type\r\n TBinaryNode = TJclBinaryNode;\r\n TPreOrderBinaryTreeIterator = TJclPreOrderBinaryTreeIterator;\r\n TInOrderBinaryTreeIterator = TJclInOrderBinaryTreeIterator;\r\n TPostOrderBinaryTreeIterator = TJclPostOrderBinaryTreeIterator;\r\n private\r\n FMaxDepth: Integer;\r\n FRoot: TBinaryNode;\r\n FTraverseOrder: TJclTraverseOrder;\r\n function BuildTree(const LeafArray: array of TBinaryNode; Left, Right: Integer; Parent: TBinaryNode;\r\n Offset: Integer): TBinaryNode;\r\n function CloneNode(Node, Parent: TBinaryNode): TBinaryNode;\r\n protected\r\n procedure AssignDataTo(Dest: TJclAbstractContainerBase); override;\r\n procedure AssignPropertiesTo(Dest: TJclAbstractContainerBase); override;\r\n procedure AutoPack; override;\r\n public\r\n constructor Create(AOwnsItems: Boolean);\r\n destructor Destroy; override;\r\n { IJclPackable }\r\n procedure Pack; override;\r\n procedure SetCapacity(Value: Integer); override;\r\n { IJclCollection }\r\n function Add(const AItem: T): Boolean;\r\n function AddAll(const ACollection: IJclCollection): Boolean;\r\n procedure Clear;\r\n function Contains(const AItem: T): Boolean;\r\n function ContainsAll(const ACollection: IJclCollection): Boolean;\r\n function CollectionEquals(const ACollection: IJclCollection): Boolean;\r\n function Extract(const AItem: T): Boolean;\r\n function ExtractAll(const ACollection: IJclCollection): Boolean;\r\n function First: IJclIterator;\r\n function IsEmpty: Boolean;\r\n function Last: IJclIterator;\r\n function Remove(const AItem: T): Boolean;\r\n function RemoveAll(const ACollection: IJclCollection): Boolean;\r\n function RetainAll(const ACollection: IJclCollection): Boolean;\r\n function Size: Integer;\r\n {$IFDEF SUPPORTS_FOR_IN}\r\n function GetEnumerator: IJclIterator;\r\n {$ENDIF SUPPORTS_FOR_IN}\r\n { IJclTree }\r\n function GetRoot: IJclTreeIterator;\r\n function GetTraverseOrder: TJclTraverseOrder;\r\n procedure SetTraverseOrder(Value: TJclTraverseOrder);\r\n property Root: IJclTreeIterator read GetRoot;\r\n property TraverseOrder: TJclTraverseOrder read GetTraverseOrder write SetTraverseOrder;\r\n end;\r\n\r\n TJclBinaryTreeIterator = class(TJclAbstractIterator, IJclIterator, IJclTreeIterator, IJclBinaryTreeIterator)\r\n protected\r\n FCursor: TJclBinaryNode;\r\n FStart: TItrStart;\r\n FOwnTree: IJclCollection;\r\n FEqualityComparer: IJclEqualityComparer;\r\n procedure AssignPropertiesTo(Dest: TJclAbstractIterator); override;\r\n function GetNextCursor: TJclBinaryNode; virtual; abstract;\r\n function GetPreviousCursor: TJclBinaryNode; virtual; abstract;\r\n public\r\n constructor Create(const AOwnTree: IJclCollection; ACursor: TJclBinaryNode; AValid: Boolean; AStart: TItrStart);\r\n { IJclIterator }\r\n function Add(const AItem: T): Boolean;\r\n procedure Extract;\r\n function GetItem: T;\r\n function HasNext: Boolean;\r\n function HasPrevious: Boolean;\r\n function Insert(const AItem: T): Boolean;\r\n function IteratorEquals(const AIterator: IJclIterator): Boolean;\r\n function Next: T;\r\n function NextIndex: Integer;\r\n function Previous: T;\r\n function PreviousIndex: Integer;\r\n procedure Remove;\r\n procedure Reset;\r\n procedure SetItem(const AItem: T);\r\n {$IFDEF SUPPORTS_FOR_IN}\r\n function MoveNext: Boolean;\r\n property Current: T read GetItem;\r\n {$ENDIF SUPPORTS_FOR_IN}\r\n { IJclTreeIterator }\r\n function AddChild(const AItem: T): Boolean;\r\n function ChildrenCount: Integer;\r\n procedure DeleteChild(Index: Integer);\r\n procedure DeleteChildren;\r\n procedure ExtractChild(Index: Integer);\r\n procedure ExtractChildren;\r\n function GetChild(Index: Integer): T;\r\n function HasChild(Index: Integer): Boolean;\r\n function HasParent: Boolean;\r\n function IndexOfChild(const AItem: T): Integer;\r\n function InsertChild(Index: Integer; const AItem: T): Boolean;\r\n function Parent: T;\r\n procedure SetChild(Index: Integer; const AItem: T);\r\n { IJclBinaryTreeIterator }\r\n function HasLeft: Boolean;\r\n function HasRight: Boolean;\r\n function Left: T;\r\n function Right: T;\r\n end;\r\n\r\n TJclPreOrderBinaryTreeIterator = class(TJclBinaryTreeIterator, IJclIterator, IJclTreeIterator, IJclBinaryTreeIterator,\r\n {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE} IJclIntfCloneable, IJclCloneable)\r\n protected\r\n function CreateEmptyIterator: TJclAbstractIterator; override;\r\n function GetNextCursor: TJclBinaryNode; override;\r\n function GetPreviousCursor: TJclBinaryNode; override;\r\n end;\r\n\r\n TJclInOrderBinaryTreeIterator = class(TJclBinaryTreeIterator, IJclIterator, IJclTreeIterator, IJclBinaryTreeIterator,\r\n {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE} IJclIntfCloneable, IJclCloneable)\r\n protected\r\n function CreateEmptyIterator: TJclAbstractIterator; override;\r\n function GetNextCursor: TJclBinaryNode; override;\r\n function GetPreviousCursor: TJclBinaryNode; override;\r\n end;\r\n\r\n TJclPostOrderBinaryTreeIterator = class(TJclBinaryTreeIterator, IJclIterator, IJclTreeIterator, IJclBinaryTreeIterator,\r\n {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE} IJclIntfCloneable, IJclCloneable)\r\n protected\r\n function CreateEmptyIterator: TJclAbstractIterator; override;\r\n function GetNextCursor: TJclBinaryNode; override;\r\n function GetPreviousCursor: TJclBinaryNode; override;\r\n end;\r\n\r\n // E = External helper to compare items\r\n TJclBinaryTreeE = class(TJclBinaryTree, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclIntfCloneable, IJclCloneable, IJclBaseContainer, IJclContainer, IJclItemOwner, IJclEqualityComparer, IJclComparer,\r\n IJclCollection, IJclTree)\r\n private\r\n FComparer: IJclComparer;\r\n protected\r\n procedure AssignPropertiesTo(Dest: TJclAbstractContainerBase); override;\r\n function CreateEmptyContainer: TJclAbstractContainerBase; override;\r\n public\r\n constructor Create(const AComparer: IJclComparer; AOwnsItems: Boolean);\r\n { IJclComparer }\r\n function ItemsCompare(const A, B: T): Integer; override;\r\n { IJclEqualityComparer }\r\n function ItemsEqual(const A, B: T): Boolean; override;\r\n property Comparer: IJclComparer read FComparer write FComparer;\r\n end;\r\n\r\n // F = Function to compare items\r\n TJclBinaryTreeF = class(TJclBinaryTree, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclIntfCloneable, IJclCloneable, IJclBaseContainer, IJclContainer, IJclItemOwner, IJclEqualityComparer, IJclComparer,\r\n IJclCollection, IJclTree)\r\n protected\r\n function CreateEmptyContainer: TJclAbstractContainerBase; override;\r\n public\r\n constructor Create(ACompare: TCompare; AOwnsItems: Boolean);\r\n end;\r\n\r\n // I = Items can compare themselves to an other\r\n TJclBinaryTreeI> = class(TJclBinaryTree, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclIntfCloneable, IJclCloneable, IJclBaseContainer, IJclContainer, IJclItemOwner, IJclEqualityComparer, IJclComparer,\r\n IJclCollection, IJclTree)\r\n protected\r\n function CreateEmptyContainer: TJclAbstractContainerBase; override;\r\n public\r\n { IJclComparer }\r\n function ItemsCompare(const A, B: T): Integer; override;\r\n { IJclEqualityComparer }\r\n function ItemsEqual(const A, B: T): Boolean; override;\r\n end;\r\n\r\n //DOM-IGNORE-END\r\n {$ENDIF SUPPORTS_GENERICS}\r\n\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jcl.svn.sourceforge.net/svnroot/jcl/tags/JCL-2.4-Build4571/jcl/source/common/JclBinaryTrees.pas $';\r\n Revision: '$Revision: 3739 $';\r\n Date: '$Date: 2012-02-21 18:37:18 +0100 (mar. 21 févr. 2012) $';\r\n LogPath: 'JCL\\source\\common';\r\n Extra: '';\r\n Data: nil\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n {$IFDEF HAS_UNITSCOPE}\r\n System.SysUtils;\r\n {$ELSE ~HAS_UNITSCOPE}\r\n SysUtils;\r\n {$ENDIF ~HAS_UNITSCOPE}\r\n\r\n//=== { TJclIntfBinaryTree } =================================================\r\n\r\nconstructor TJclIntfBinaryTree.Create(ACompare: TIntfCompare);\r\nbegin\r\n inherited Create();\r\n FTraverseOrder := toOrder;\r\n FMaxDepth := 0;\r\n FAutoPackParameter := 2;\r\n SetCompare(ACompare);\r\nend;\r\n\r\ndestructor TJclIntfBinaryTree.Destroy;\r\nbegin\r\n FReadOnly := False;\r\n Clear;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJclIntfBinaryTree.Add(const AInterface: IInterface): Boolean;\r\nvar\r\n NewNode, Current, Save: TJclIntfBinaryNode;\r\n Comp, Depth: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n // Insert into right place\r\n if FAllowDefaultElements or not ItemsEqual(AInterface, nil) then\r\n begin\r\n Save := nil;\r\n Current := FRoot;\r\n Comp := 1;\r\n Depth := 0;\r\n while Current <> nil do\r\n begin\r\n Inc(Depth);\r\n Save := Current;\r\n Comp := ItemsCompare(AInterface, Current.Value);\r\n if Comp < 0 then\r\n Current := Current.Left\r\n else\r\n if Comp > 0 then\r\n Current := Current.Right\r\n else\r\n if CheckDuplicate then\r\n Current := Current.Left // arbitrary decision\r\n else\r\n Break;\r\n end;\r\n if (Comp <> 0) or CheckDuplicate then\r\n begin\r\n NewNode := TJclIntfBinaryNode.Create;\r\n NewNode.Value := AInterface;\r\n NewNode.Parent := Save;\r\n if Save = nil then\r\n FRoot := NewNode\r\n else\r\n if ItemsCompare(NewNode.Value, Save.Value) <= 0 then\r\n Save.Left := NewNode\r\n else\r\n Save.Right := NewNode;\r\n Inc(FSize);\r\n Inc(Depth);\r\n if Depth > FMaxDepth then\r\n FMaxDepth := Depth;\r\n Result := True;\r\n AutoPack;\r\n end\r\n else\r\n Result := False;\r\n end\r\n else\r\n Result := False;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfBinaryTree.AddAll(const ACollection: IJclIntfCollection): Boolean;\r\nvar\r\n It: IJclIntfIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n Result := Add(It.Next) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclIntfBinaryTree.AssignDataTo(Dest: TJclAbstractContainerBase);\r\nvar\r\n ADest: TJclIntfBinaryTree;\r\n ACollection: IJclIntfCollection;\r\nbegin\r\n inherited AssignDataTo(Dest);\r\n if Dest is TJclIntfBinaryTree then\r\n begin\r\n ADest := TJclIntfBinaryTree(Dest);\r\n ADest.Clear;\r\n ADest.FSize := FSize;\r\n if FRoot <> nil then\r\n ADest.FRoot := CloneNode(FRoot, nil);\r\n end\r\n else\r\n if Supports(IInterface(Dest), IJclIntfCollection, ACollection) then\r\n begin\r\n ACollection.Clear;\r\n ACollection.AddAll(Self);\r\n end;\r\nend;\r\n\r\nprocedure TJclIntfBinaryTree.AssignPropertiesTo(Dest: TJclAbstractContainerBase);\r\nbegin\r\n inherited AssignPropertiesto(Dest);\r\n if Dest is TJclIntfBinaryTree then\r\n TJclIntfBinaryTree(Dest).FTraverseOrder := FTraverseOrder;\r\nend;\r\n\r\nprocedure TJclIntfBinaryTree.AutoPack;\r\nbegin\r\n case FAutoPackStrategy of\r\n //apsDisabled: ;\r\n apsAgressive:\r\n if (FMaxDepth > 1) and (((1 shl (FMaxDepth - 1)) - 1) > FSize) then\r\n Pack;\r\n // apsIncremental: ;\r\n apsProportional:\r\n if (FMaxDepth > FAutoPackParameter) and (((1 shl (FMaxDepth - FAutoPackParameter)) - 1) > FSize) then\r\n Pack;\r\n end;\r\nend;\r\n\r\nfunction TJclIntfBinaryTree.BuildTree(const LeafArray: array of TJclIntfBinaryNode; Left, Right: Integer; Parent: TJclIntfBinaryNode;\r\n Offset: Integer): TJclIntfBinaryNode;\r\nvar\r\n Middle: Integer;\r\nbegin\r\n Middle := (Left + Right + Offset) shr 1;\r\n Result := LeafArray[Middle];\r\n Result.Parent := Parent;\r\n if Middle > Left then\r\n Result.Left := BuildTree(LeafArray, Left, Middle - 1, Result, 0)\r\n else\r\n Result.Left := nil;\r\n if Middle < Right then\r\n Result.Right := BuildTree(LeafArray, Middle + 1, Right, Result, 1)\r\n else\r\n Result.Right := nil;\r\nend;\r\n\r\nprocedure TJclIntfBinaryTree.Clear;\r\nvar\r\n Current, Parent: TJclIntfBinaryNode;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n // postorder\r\n Current := FRoot;\r\n if Current = nil then\r\n Exit;\r\n // find first in post-order\r\n while (Current.Left <> nil) or (Current.Right <> nil) do\r\n begin\r\n if Current.Left <> nil then\r\n Current := Current.Left\r\n else\r\n Current := Current.Right;\r\n end;\r\n // for all items in the tree in post-order\r\n repeat\r\n Parent := Current.Parent;\r\n // remove reference\r\n if Parent <> nil then\r\n begin\r\n if Parent.Left = Current then\r\n Parent.Left := nil\r\n else\r\n if Parent.Right = Current then\r\n Parent.Right := nil;\r\n end;\r\n\r\n // free item\r\n FreeObject(Current.Value);\r\n Current.Free;\r\n\r\n // find next item\r\n Current := Parent;\r\n if (Current <> nil) and (Current.Right <> nil) then\r\n begin\r\n Current := Current.Right;\r\n while (Current.Left <> nil) or (Current.Right <> nil) do\r\n begin\r\n if Current.Left <> nil then\r\n Current := Current.Left\r\n else\r\n Current := Current.Right;\r\n end;\r\n end;\r\n until Current = nil;\r\n FRoot := nil;\r\n FSize := 0;\r\n FMaxDepth := 0;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfBinaryTree.CloneNode(Node, Parent: TJclIntfBinaryNode): TJclIntfBinaryNode;\r\nbegin\r\n Result := TJclIntfBinaryNode.Create;\r\n Result.Value := Node.Value;\r\n Result.Parent := Parent;\r\n if Node.Left <> nil then\r\n Result.Left := CloneNode(Node.Left, Result); // recursive call\r\n if Node.Right <> nil then\r\n Result.Right := CloneNode(Node.Right, Result); // recursive call\r\nend;\r\n\r\nfunction TJclIntfBinaryTree.CollectionEquals(const ACollection: IJclIntfCollection): Boolean;\r\nvar\r\n It, ItSelf: IJclIntfIterator;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n if FSize <> ACollection.Size then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n ItSelf := First;\r\n while ItSelf.HasNext do\r\n if not ItemsEqual(ItSelf.Next, It.Next) then\r\n begin\r\n Result := False;\r\n Break;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfBinaryTree.Contains(const AInterface: IInterface): Boolean;\r\nvar\r\n Comp: Integer;\r\n Current: TJclIntfBinaryNode;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n Current := FRoot;\r\n while Current <> nil do\r\n begin\r\n Comp := ItemsCompare(Current.Value, AInterface);\r\n if Comp = 0 then\r\n begin\r\n Result := True;\r\n Break;\r\n end\r\n else\r\n if Comp > 0 then\r\n Current := Current.Left\r\n else\r\n Current := Current.Right;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfBinaryTree.ContainsAll(const ACollection: IJclIntfCollection): Boolean;\r\nvar\r\n It: IJclIntfIterator;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := True;\r\n if ACollection = nil then\r\n Exit;\r\n It := ACollection.First;\r\n while Result and It.HasNext do\r\n Result := Contains(It.Next);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfBinaryTree.Extract(const AInterface: IInterface): Boolean;\r\nvar\r\n Current, Successor: TJclIntfBinaryNode;\r\n Comp: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n // locate AInterface in the tree\r\n Current := FRoot;\r\n repeat\r\n while Current <> nil do\r\n begin\r\n Comp := ItemsCompare(AInterface, Current.Value);\r\n if Comp = 0 then\r\n Break\r\n else\r\n if Comp < 0 then\r\n Current := Current.Left\r\n else\r\n Current := Current.Right;\r\n end;\r\n if Current = nil then\r\n Break;\r\n Result := True;\r\n // Remove Current from tree\r\n if (Current.Left = nil) and (Current.Right <> nil) then\r\n begin\r\n // remove references to Current\r\n Current.Right.Parent := Current.Parent;\r\n if Current.Parent <> nil then\r\n begin\r\n if Current.Parent.Left = Current then\r\n Current.Parent.Left := Current.Right\r\n else\r\n Current.Parent.Right := Current.Right;\r\n end\r\n else\r\n // fix root\r\n FRoot := Current.Right;\r\n Successor := Current.Parent;\r\n if Successor = nil then\r\n Successor := FRoot;\r\n end\r\n else\r\n if (Current.Left <> nil) and (Current.Right = nil) then\r\n begin\r\n // remove references to Current\r\n Current.Left.Parent := Current.Parent;\r\n if Current.Parent <> nil then\r\n begin\r\n if Current.Parent.Left = Current then\r\n Current.Parent.Left := Current.Left\r\n else\r\n Current.Parent.Right := Current.Left;\r\n end\r\n else\r\n // fix root\r\n FRoot := Current.Left;\r\n Successor := Current.Parent;\r\n if Successor = nil then\r\n Successor := FRoot;\r\n end\r\n else\r\n if (Current.Left <> nil) and (Current.Right <> nil) then\r\n begin\r\n // find the successor in tree\r\n Successor := Current.Right;\r\n while Successor.Left <> nil do\r\n Successor := Successor.Left;\r\n\r\n if Successor <> Current.Right then\r\n begin\r\n // remove references to successor\r\n Successor.Parent.Left := Successor.Right;\r\n if Successor.Right <> nil then\r\n Successor.Right.Parent := Successor.Parent;\r\n Successor.Right := Current.Right;\r\n if Successor.Right <> nil then\r\n Successor.Right.Parent := Successor;\r\n end;\r\n\r\n // insert successor in new position\r\n Successor.Left := Current.Left;\r\n if Current.Left <> nil then\r\n Current.Left.Parent := Successor;\r\n Successor.Parent := Current.Parent;\r\n if Current.Parent <> nil then\r\n begin\r\n if Current.Parent.Left = Current then\r\n Current.Parent.Left := Successor\r\n else\r\n Current.Parent.Right := Successor;\r\n end\r\n else\r\n // fix root\r\n FRoot := Successor;\r\n Successor := Current.Parent;\r\n if Successor <> nil then\r\n Successor := FRoot;\r\n end\r\n else\r\n begin\r\n // (Current.Left = nil) and (Current.Right = nil)\r\n Successor := Current.Parent;\r\n if Successor <> nil then\r\n begin\r\n // remove references from parent\r\n if Successor.Left = Current then\r\n Successor.Left := nil\r\n else\r\n Successor.Right := nil;\r\n end\r\n else\r\n FRoot := nil;\r\n end;\r\n Current.Value := nil;\r\n Current.Free;\r\n Dec(FSize);\r\n Current := Successor;\r\n until FRemoveSingleElement or (Current = nil);\r\n AutoPack;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfBinaryTree.ExtractAll(const ACollection: IJclIntfCollection): Boolean;\r\nvar\r\n It: IJclIntfIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n Result := Extract(It.Next) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfBinaryTree.First: IJclIntfIterator;\r\nvar\r\n Start: TJclIntfBinaryNode;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Start := FRoot;\r\n case GetTraverseOrder of\r\n toPreOrder:\r\n Result := TJclPreOrderIntfBinaryTreeIterator.Create(Self, Start, False, isFirst);\r\n toOrder:\r\n begin\r\n if Start <> nil then\r\n while Start.Left <> nil do\r\n Start := Start.Left;\r\n Result := TJclInOrderIntfBinaryTreeIterator.Create(Self, Start, False, isFirst);\r\n end;\r\n toPostOrder:\r\n begin\r\n if Start <> nil then\r\n while (Start.Left <> nil) or (Start.Right <> nil) do\r\n begin\r\n if Start.Left <> nil then\r\n Start := Start.Left\r\n else\r\n Start := Start.Right;\r\n end;\r\n Result := TJclPostOrderIntfBinaryTreeIterator.Create(Self, Start, False, isFirst);\r\n end;\r\n else\r\n Result := nil;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\n{$IFDEF SUPPORTS_FOR_IN}\r\nfunction TJclIntfBinaryTree.GetEnumerator: IJclIntfIterator;\r\nbegin\r\n Result := First;\r\nend;\r\n{$ENDIF SUPPORTS_FOR_IN}\r\n\r\nfunction TJclIntfBinaryTree.GetRoot: IJclIntfTreeIterator;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n case GetTraverseOrder of\r\n toPreOrder:\r\n Result := TJclPreOrderIntfBinaryTreeIterator.Create(Self, FRoot, False, isRoot);\r\n toOrder:\r\n Result := TJclInOrderIntfBinaryTreeIterator.Create(Self, FRoot, False, isRoot);\r\n toPostOrder:\r\n Result := TJclPostOrderIntfBinaryTreeIterator.Create(Self, FRoot, False, isRoot);\r\n else\r\n Result := nil;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfBinaryTree.GetTraverseOrder: TJclTraverseOrder;\r\nbegin\r\n Result := FTraverseOrder;\r\nend;\r\n\r\nfunction TJclIntfBinaryTree.IsEmpty: Boolean;\r\nbegin\r\n Result := FSize = 0;\r\nend;\r\n\r\nfunction TJclIntfBinaryTree.Last: IJclIntfIterator;\r\nvar\r\n Start: TJclIntfBinaryNode;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Start := FRoot;\r\n case FTraverseOrder of\r\n toPreOrder:\r\n begin\r\n if Start <> nil then\r\n while (Start.Left <> nil) or (Start.Right <> nil) do\r\n begin\r\n if Start.Right <> nil then\r\n Start := Start.Right\r\n else\r\n Start := Start.Left;\r\n end;\r\n Result := TJclPreOrderIntfBinaryTreeIterator.Create(Self, Start, False, isLast);\r\n end;\r\n toOrder:\r\n begin\r\n if Start <> nil then\r\n while Start.Right <> nil do\r\n Start := Start.Right;\r\n Result := TJclInOrderIntfBinaryTreeIterator.Create(Self, Start, False, isLast);\r\n end;\r\n toPostOrder:\r\n Result := TJclPostOrderIntfBinaryTreeIterator.Create(Self, Start, False, isLast);\r\n else\r\n Result := nil;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclIntfBinaryTree.Pack;\r\nvar\r\n LeafArray: array of TJclIntfBinaryNode;\r\n ANode, BNode: TJclIntfBinaryNode;\r\n Index: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n SetLength(Leafarray, FSize);\r\n try\r\n // in order enumeration of nodes\r\n ANode := FRoot;\r\n if ANode <> nil then\r\n begin\r\n // find first node\r\n while ANode.Left <> nil do\r\n ANode := ANode.Left;\r\n\r\n Index := 0;\r\n while ANode <> nil do\r\n begin\r\n LeafArray[Index] := ANode;\r\n Inc(Index);\r\n if ANode.Right <> nil then\r\n begin\r\n ANode := ANode.Right;\r\n while (ANode.Left <> nil) do\r\n ANode := ANode.Left;\r\n end\r\n else\r\n begin\r\n BNode := ANode;\r\n ANode := ANode.Parent;\r\n while (ANode <> nil) and (ANode.Right = BNode) do\r\n begin\r\n BNode := ANode;\r\n ANode := ANode.Parent;\r\n end;\r\n end;\r\n end;\r\n\r\n Index := FSize shr 1;\r\n FRoot := LeafArray[Index];\r\n FRoot.Parent := nil;\r\n if Index > 0 then\r\n FRoot.Left := BuildTree(LeafArray, 0, Index - 1, FRoot, 0)\r\n else\r\n FRoot.Left := nil;\r\n if Index < (FSize - 1) then\r\n FRoot.Right := BuildTree(LeafArray, Index + 1, FSize - 1, FRoot, 1)\r\n else\r\n FRoot.Right := nil;\r\n end;\r\n finally\r\n SetLength(LeafArray, 0);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfBinaryTree.Remove(const AInterface: IInterface): Boolean;\r\nvar\r\n Extracted: IInterface;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := Extract(AInterface);\r\n if Result then\r\n begin\r\n Extracted := AInterface;\r\n FreeObject(Extracted);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfBinaryTree.RemoveAll(const ACollection: IJclIntfCollection): Boolean;\r\nvar\r\n It: IJclIntfIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n Result := Remove(It.Next) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfBinaryTree.RetainAll(const ACollection: IJclIntfCollection): Boolean;\r\nvar\r\n It: IJclIntfIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := First;\r\n while It.HasNext do\r\n if not ACollection.Contains(It.Next) then\r\n It.Remove;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclIntfBinaryTree.SetCapacity(Value: Integer);\r\nbegin\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nprocedure TJclIntfBinaryTree.SetTraverseOrder(Value: TJclTraverseOrder);\r\nbegin\r\n FTraverseOrder := Value;\r\nend;\r\n\r\nfunction TJclIntfBinaryTree.Size: Integer;\r\nbegin\r\n Result := FSize;\r\nend;\r\n\r\nfunction TJclIntfBinaryTree.CreateEmptyContainer: TJclAbstractContainerBase;\r\nbegin\r\n Result := TJclIntfBinaryTree.Create(Compare);\r\n AssignPropertiesTo(Result);\r\nend;\r\n\r\n//=== { TJclIntfBinaryTreeIterator } ===========================================================\r\n\r\nconstructor TJclIntfBinaryTreeIterator.Create(const AOwnTree: IJclIntfCollection; ACursor: TJclIntfBinaryNode; AValid: Boolean; AStart: TItrStart);\r\nbegin\r\n inherited Create(AValid);\r\n FCursor := ACursor;\r\n FStart := AStart;\r\n FOwnTree := AOwnTree;\r\n FEqualityComparer := AOwnTree as IJclIntfEqualityComparer;\r\nend;\r\n\r\nfunction TJclIntfBinaryTreeIterator.Add(const AInterface: IInterface): Boolean;\r\nbegin\r\n Result := FOwnTree.Add(AInterface);\r\nend;\r\n\r\nfunction TJclIntfBinaryTreeIterator.AddChild(const AInterface: IInterface): Boolean;\r\nbegin\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nprocedure TJclIntfBinaryTreeIterator.AssignPropertiesTo(Dest: TJclAbstractIterator);\r\nvar\r\n ADest: TJclIntfBinaryTreeIterator;\r\nbegin\r\n inherited AssignPropertiesTo(Dest);\r\n if Dest is TJclIntfBinaryTreeIterator then\r\n begin\r\n ADest := TJclIntfBinaryTreeIterator(Dest);\r\n ADest.FCursor := FCursor;\r\n ADest.FOwnTree := FOwnTree;\r\n ADest.FEqualityComparer := FEqualityComparer;\r\n ADest.FStart := FStart;\r\n end;\r\nend;\r\n\r\nfunction TJclIntfBinaryTreeIterator.ChildrenCount: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := 0;\r\n if FCursor <> nil then\r\n begin\r\n if FCursor.Left <> nil then\r\n Inc(Result);\r\n if FCursor.Right <> nil then\r\n Inc(Result);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclIntfBinaryTreeIterator.DeleteChild(Index: Integer);\r\nbegin\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nprocedure TJclIntfBinaryTreeIterator.DeleteChildren;\r\nbegin\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nprocedure TJclIntfBinaryTreeIterator.Extract;\r\nvar\r\n OldCursor: TJclIntfBinaryNode;\r\nbegin\r\n if FOwnTree.ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n CheckValid;\r\n Valid := False;\r\n OldCursor := FCursor;\r\n if OldCursor <> nil then\r\n begin\r\n repeat\r\n FCursor := GetNextCursor;\r\n until (FCursor = nil) or FOwnTree.RemoveSingleElement\r\n or (not FEqualityComparer.ItemsEqual(OldCursor.Value, FCursor.Value));\r\n FOwnTree.Extract(OldCursor.Value);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.WriteUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclIntfBinaryTreeIterator.ExtractChild(Index: Integer);\r\nbegin\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nprocedure TJclIntfBinaryTreeIterator.ExtractChildren;\r\nbegin\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nfunction TJclIntfBinaryTreeIterator.GetChild(Index: Integer): IInterface;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := nil;\r\n if (FCursor <> nil) and (Index = 0) and (FCursor.Left <> nil) then\r\n FCursor := FCursor.Left\r\n else\r\n if (FCursor <> nil) and (Index = 0) then\r\n FCursor := FCursor.Right\r\n else\r\n if (FCursor <> nil) and (Index = 1) then\r\n FCursor := FCursor.Right\r\n else\r\n FCursor := nil;\r\n if FCursor <> nil then\r\n Result := FCursor.Value\r\n else\r\n if not FOwnTree.ReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfBinaryTreeIterator.GetObject: IInterface;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n CheckValid;\r\n Result := nil;\r\n if FCursor <> nil then\r\n Result := FCursor.Value\r\n else\r\n if not FOwnTree.ReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfBinaryTreeIterator.HasChild(Index: Integer): Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if (FCursor <> nil) and (Index = 0) then\r\n Result := (FCursor.Left <> nil) or (FCursor.Right <> nil)\r\n else\r\n if (FCursor <> nil) and (Index = 1) then\r\n Result := (FCursor.Left <> nil) and (FCursor.Right <> nil)\r\n else\r\n Result := False;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfBinaryTreeIterator.HasLeft: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := (FCursor <> nil) and (FCursor.Left <> nil);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfBinaryTreeIterator.HasNext: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Valid then\r\n Result := GetNextCursor <> nil\r\n else\r\n Result := FCursor <> nil;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfBinaryTreeIterator.HasParent: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := (FCursor <> nil) and (FCursor.Parent <> nil);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfBinaryTreeIterator.HasPrevious: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Valid then\r\n Result := GetPreviousCursor <> nil\r\n else\r\n Result := FCursor <> nil;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfBinaryTreeIterator.HasRight: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := (FCursor <> nil) and (FCursor.Right <> nil);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfBinaryTreeIterator.IndexOfChild(const AInterface: IInterface): Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := -1;\r\n if FCursor <> nil then\r\n begin\r\n if FCursor.Left <> nil then\r\n begin\r\n if FEqualityComparer.ItemsEqual(FCursor.Left.Value, AInterface) then\r\n Result := 0\r\n else\r\n if (FCursor.Right <> nil) and FEqualityComparer.ItemsEqual(FCursor.Right.Value, AInterface) then\r\n Result := 1;\r\n end\r\n else\r\n if (FCursor.Right <> nil) and FEqualityComparer.ItemsEqual(FCursor.Right.Value, AInterface) then\r\n Result := 0;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfBinaryTreeIterator.Insert(const AInterface: IInterface): Boolean;\r\nbegin\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nfunction TJclIntfBinaryTreeIterator.InsertChild(Index: Integer; const AInterface: IInterface): Boolean;\r\nbegin\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nfunction TJclIntfBinaryTreeIterator.IteratorEquals(const AIterator: IJclIntfIterator): Boolean;\r\nvar\r\n Obj: TObject;\r\n ItrObj: TJclIntfBinaryTreeIterator;\r\nbegin\r\n Result := False;\r\n if AIterator = nil then\r\n Exit;\r\n Obj := AIterator.GetIteratorReference;\r\n if Obj is TJclIntfBinaryTreeIterator then\r\n begin\r\n ItrObj := TJclIntfBinaryTreeIterator(Obj);\r\n Result := (FOwnTree = ItrObj.FOwnTree) and (FCursor = ItrObj.FCursor) and (Valid = ItrObj.Valid);\r\n end;\r\nend;\r\n\r\nfunction TJclIntfBinaryTreeIterator.Left: IInterface;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := nil;\r\n if FCursor <> nil then\r\n FCursor := FCursor.Left;\r\n if FCursor <> nil then\r\n Result := FCursor.Value\r\n else\r\n if not FOwnTree.ReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\n{$IFDEF SUPPORTS_FOR_IN}\r\nfunction TJclIntfBinaryTreeIterator.MoveNext: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Valid then\r\n FCursor := GetNextCursor\r\n else\r\n Valid := True;\r\n Result := FCursor <> nil;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n{$ENDIF SUPPORTS_FOR_IN}\r\n\r\nfunction TJclIntfBinaryTreeIterator.Next: IInterface;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Valid then\r\n FCursor := GetNextCursor\r\n else\r\n Valid := True;\r\n Result := nil;\r\n if FCursor <> nil then\r\n Result := FCursor.Value\r\n else\r\n if not FOwnTree.ReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfBinaryTreeIterator.NextIndex: Integer;\r\nbegin\r\n // No index\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nfunction TJclIntfBinaryTreeIterator.Parent: IInterface;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := nil;\r\n if FCursor <> nil then\r\n FCursor := FCursor.Parent;\r\n if FCursor <> nil then\r\n Result := FCursor.Value\r\n else\r\n if not FOwnTree.ReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfBinaryTreeIterator.Previous: IInterface;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Valid then\r\n FCursor := GetPreviousCursor\r\n else\r\n Valid := True;\r\n Result := nil;\r\n if FCursor <> nil then\r\n Result := FCursor.Value\r\n else\r\n if not FOwnTree.ReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfBinaryTreeIterator.PreviousIndex: Integer;\r\nbegin\r\n // No index\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nprocedure TJclIntfBinaryTreeIterator.Remove;\r\nvar\r\n OldCursor: TJclIntfBinaryNode;\r\nbegin\r\n if FOwnTree.ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n CheckValid;\r\n Valid := False;\r\n OldCursor := FCursor;\r\n if OldCursor <> nil then\r\n begin\r\n repeat\r\n FCursor := GetNextCursor;\r\n until (FCursor = nil) or FOwnTree.RemoveSingleElement\r\n or (not FEqualityComparer.ItemsEqual(OldCursor.Value, FCursor.Value));\r\n FOwnTree.Remove(OldCursor.Value);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.WriteUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclIntfBinaryTreeIterator.Reset;\r\nvar\r\n NewCursor: TJclIntfBinaryNode;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Valid := False;\r\n case FStart of\r\n isFirst:\r\n begin\r\n NewCursor := FCursor;\r\n while NewCursor <> nil do\r\n begin\r\n NewCursor := GetPreviousCursor;\r\n if NewCursor <> nil then\r\n FCursor := NewCursor;\r\n end;\r\n end;\r\n isLast:\r\n begin\r\n NewCursor := FCursor;\r\n while NewCursor <> nil do\r\n begin\r\n NewCursor := GetNextCursor;\r\n if NewCursor <> nil then\r\n FCursor := NewCursor;\r\n end;\r\n end;\r\n isRoot:\r\n begin\r\n while (FCursor <> nil) and (FCursor.Parent <> nil) do\r\n FCursor := FCursor.Parent;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfBinaryTreeIterator.Right: IInterface;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := nil;\r\n if FCursor <> nil then\r\n FCursor := FCursor.Right;\r\n if FCursor <> nil then\r\n Result := FCursor.Value\r\n else\r\n if not FOwnTree.ReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclIntfBinaryTreeIterator.SetChild(Index: Integer; const AInterface: IInterface);\r\nbegin\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nprocedure TJclIntfBinaryTreeIterator.SetObject(const AInterface: IInterface);\r\nbegin\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\n//=== { TJclPreOrderIntfBinaryTreeIterator } ===================================================\r\n\r\nfunction TJclPreOrderIntfBinaryTreeIterator.CreateEmptyIterator: TJclAbstractIterator;\r\nbegin\r\n Result := TJclPreOrderIntfBinaryTreeIterator.Create(FOwnTree, FCursor, Valid, FStart);\r\nend;\r\n\r\nfunction TJclPreOrderIntfBinaryTreeIterator.GetNextCursor: TJclIntfBinaryNode;\r\nvar\r\n LastRet: TJclIntfBinaryNode;\r\nbegin\r\n Result := FCursor;\r\n if Result = nil then\r\n Exit;\r\n LastRet := Result;\r\n if Result.Left <> nil then\r\n Result := Result.Left\r\n else\r\n if Result.Right <> nil then\r\n Result := Result.Right\r\n else\r\n begin\r\n Result := Result.Parent;\r\n while (Result <> nil) and ((Result.Right = nil) or (Result.Right = LastRet)) do\r\n begin\r\n LastRet := Result;\r\n Result := Result.Parent;\r\n end;\r\n if Result <> nil then // not root\r\n Result := Result.Right;\r\n end;\r\nend;\r\n\r\nfunction TJclPreOrderIntfBinaryTreeIterator.GetPreviousCursor: TJclIntfBinaryNode;\r\nvar\r\n LastRet: TJclIntfBinaryNode;\r\nbegin\r\n Result := FCursor;\r\n if Result = nil then\r\n Exit;\r\n LastRet := Result;\r\n Result := Result.Parent;\r\n if (Result <> nil) and (Result.Left <> LastRet) and (Result.Left <> nil) then\r\n // come from Right\r\n begin\r\n Result := Result.Left;\r\n while (Result.Left <> nil) or (Result.Right <> nil) do // both childs\r\n begin\r\n if Result.Right <> nil then // right child first\r\n Result := Result.Right\r\n else\r\n Result := Result.Left;\r\n end;\r\n end;\r\nend;\r\n\r\n//=== { TJclInOrderIntfBinaryTreeIterator } ====================================================\r\n\r\nfunction TJclInOrderIntfBinaryTreeIterator.CreateEmptyIterator: TJclAbstractIterator;\r\nbegin\r\n Result := TJclInOrderIntfBinaryTreeIterator.Create(FOwnTree, FCursor, Valid, FStart);\r\nend;\r\n\r\nfunction TJclInOrderIntfBinaryTreeIterator.GetNextCursor: TJclIntfBinaryNode;\r\nvar\r\n LastRet: TJclIntfBinaryNode;\r\nbegin\r\n Result := FCursor;\r\n if Result = nil then\r\n Exit;\r\n if Result.Right <> nil then\r\n begin\r\n Result := Result.Right;\r\n while (Result.Left <> nil) do\r\n Result := Result.Left;\r\n end\r\n else\r\n begin\r\n LastRet := Result;\r\n Result := Result.Parent;\r\n while (Result <> nil) and (Result.Right = LastRet) do\r\n begin\r\n LastRet := Result;\r\n Result := Result.Parent;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJclInOrderIntfBinaryTreeIterator.GetPreviousCursor: TJclIntfBinaryNode;\r\nvar\r\n LastRet: TJclIntfBinaryNode;\r\nbegin\r\n Result := FCursor;\r\n if Result = nil then\r\n Exit;\r\n if Result.Left <> nil then\r\n begin\r\n Result := Result.Left;\r\n while Result.Right <> nil do\r\n Result := Result.Right;\r\n end\r\n else\r\n begin\r\n LastRet := Result;\r\n Result := Result.Parent;\r\n while (Result <> nil) and (Result.Right <> LastRet) do // Come from Left\r\n begin\r\n LastRet := Result;\r\n Result := Result.Parent;\r\n end;\r\n end;\r\nend;\r\n\r\n//=== { TJclPostOrderIntfBinaryTreeIterator } ==================================================\r\n\r\nfunction TJclPostOrderIntfBinaryTreeIterator.CreateEmptyIterator: TJclAbstractIterator;\r\nbegin\r\n Result := TJclPostOrderIntfBinaryTreeIterator.Create(FOwnTree, FCursor, Valid, FStart);\r\nend;\r\n\r\nfunction TJclPostOrderIntfBinaryTreeIterator.GetNextCursor: TJclIntfBinaryNode;\r\nvar\r\n LastRet: TJclIntfBinaryNode;\r\nbegin\r\n Result := FCursor;\r\n if Result = nil then\r\n Exit;\r\n LastRet := Result;\r\n Result := Result.Parent;\r\n if (Result <> nil) and (Result.Right <> nil) and (Result.Right <> LastRet) then\r\n begin\r\n Result := Result.Right;\r\n while (Result.Left <> nil) or (Result.Right <> nil) do\r\n begin\r\n if Result.Left <> nil then\r\n Result := Result.Left\r\n else\r\n Result := Result.Right;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJclPostOrderIntfBinaryTreeIterator.GetPreviousCursor: TJclIntfBinaryNode;\r\nvar\r\n LastRet: TJclIntfBinaryNode;\r\nbegin\r\n Result := FCursor;\r\n if Result = nil then\r\n Exit;\r\n if Result.Right <> nil then\r\n Result := Result.Right\r\n else\r\n if Result.Left <> nil then\r\n Result := Result.Left\r\n else\r\n begin\r\n LastRet := Result;\r\n Result := Result.Parent;\r\n while (Result <> nil) and ((Result.Left = nil) or (Result.Left = LastRet)) do\r\n begin\r\n LastRet := Result;\r\n Result := Result.Parent;\r\n end;\r\n if Result <> nil then // not root\r\n Result := Result.Left;\r\n end;\r\nend;\r\n\r\n//=== { TJclAnsiStrBinaryTree } =================================================\r\n\r\nconstructor TJclAnsiStrBinaryTree.Create(ACompare: TAnsiStrCompare);\r\nbegin\r\n inherited Create();\r\n FTraverseOrder := toOrder;\r\n FMaxDepth := 0;\r\n FAutoPackParameter := 2;\r\n SetCompare(ACompare);\r\nend;\r\n\r\ndestructor TJclAnsiStrBinaryTree.Destroy;\r\nbegin\r\n FReadOnly := False;\r\n Clear;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJclAnsiStrBinaryTree.Add(const AString: AnsiString): Boolean;\r\nvar\r\n NewNode, Current, Save: TJclAnsiStrBinaryNode;\r\n Comp, Depth: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n // Insert into right place\r\n if FAllowDefaultElements or not ItemsEqual(AString, '') then\r\n begin\r\n Save := nil;\r\n Current := FRoot;\r\n Comp := 1;\r\n Depth := 0;\r\n while Current <> nil do\r\n begin\r\n Inc(Depth);\r\n Save := Current;\r\n Comp := ItemsCompare(AString, Current.Value);\r\n if Comp < 0 then\r\n Current := Current.Left\r\n else\r\n if Comp > 0 then\r\n Current := Current.Right\r\n else\r\n if CheckDuplicate then\r\n Current := Current.Left // arbitrary decision\r\n else\r\n Break;\r\n end;\r\n if (Comp <> 0) or CheckDuplicate then\r\n begin\r\n NewNode := TJclAnsiStrBinaryNode.Create;\r\n NewNode.Value := AString;\r\n NewNode.Parent := Save;\r\n if Save = nil then\r\n FRoot := NewNode\r\n else\r\n if ItemsCompare(NewNode.Value, Save.Value) <= 0 then\r\n Save.Left := NewNode\r\n else\r\n Save.Right := NewNode;\r\n Inc(FSize);\r\n Inc(Depth);\r\n if Depth > FMaxDepth then\r\n FMaxDepth := Depth;\r\n Result := True;\r\n AutoPack;\r\n end\r\n else\r\n Result := False;\r\n end\r\n else\r\n Result := False;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclAnsiStrBinaryTree.AddAll(const ACollection: IJclAnsiStrCollection): Boolean;\r\nvar\r\n It: IJclAnsiStrIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n Result := Add(It.Next) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclAnsiStrBinaryTree.AssignDataTo(Dest: TJclAbstractContainerBase);\r\nvar\r\n ADest: TJclAnsiStrBinaryTree;\r\n ACollection: IJclAnsiStrCollection;\r\nbegin\r\n inherited AssignDataTo(Dest);\r\n if Dest is TJclAnsiStrBinaryTree then\r\n begin\r\n ADest := TJclAnsiStrBinaryTree(Dest);\r\n ADest.Clear;\r\n ADest.FSize := FSize;\r\n if FRoot <> nil then\r\n ADest.FRoot := CloneNode(FRoot, nil);\r\n end\r\n else\r\n if Supports(IInterface(Dest), IJclAnsiStrCollection, ACollection) then\r\n begin\r\n ACollection.Clear;\r\n ACollection.AddAll(Self);\r\n end;\r\nend;\r\n\r\nprocedure TJclAnsiStrBinaryTree.AssignPropertiesTo(Dest: TJclAbstractContainerBase);\r\nbegin\r\n inherited AssignPropertiesto(Dest);\r\n if Dest is TJclAnsiStrBinaryTree then\r\n TJclAnsiStrBinaryTree(Dest).FTraverseOrder := FTraverseOrder;\r\nend;\r\n\r\nprocedure TJclAnsiStrBinaryTree.AutoPack;\r\nbegin\r\n case FAutoPackStrategy of\r\n //apsDisabled: ;\r\n apsAgressive:\r\n if (FMaxDepth > 1) and (((1 shl (FMaxDepth - 1)) - 1) > FSize) then\r\n Pack;\r\n // apsIncremental: ;\r\n apsProportional:\r\n if (FMaxDepth > FAutoPackParameter) and (((1 shl (FMaxDepth - FAutoPackParameter)) - 1) > FSize) then\r\n Pack;\r\n end;\r\nend;\r\n\r\nfunction TJclAnsiStrBinaryTree.BuildTree(const LeafArray: array of TJclAnsiStrBinaryNode; Left, Right: Integer; Parent: TJclAnsiStrBinaryNode;\r\n Offset: Integer): TJclAnsiStrBinaryNode;\r\nvar\r\n Middle: Integer;\r\nbegin\r\n Middle := (Left + Right + Offset) shr 1;\r\n Result := LeafArray[Middle];\r\n Result.Parent := Parent;\r\n if Middle > Left then\r\n Result.Left := BuildTree(LeafArray, Left, Middle - 1, Result, 0)\r\n else\r\n Result.Left := nil;\r\n if Middle < Right then\r\n Result.Right := BuildTree(LeafArray, Middle + 1, Right, Result, 1)\r\n else\r\n Result.Right := nil;\r\nend;\r\n\r\nprocedure TJclAnsiStrBinaryTree.Clear;\r\nvar\r\n Current, Parent: TJclAnsiStrBinaryNode;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n // postorder\r\n Current := FRoot;\r\n if Current = nil then\r\n Exit;\r\n // find first in post-order\r\n while (Current.Left <> nil) or (Current.Right <> nil) do\r\n begin\r\n if Current.Left <> nil then\r\n Current := Current.Left\r\n else\r\n Current := Current.Right;\r\n end;\r\n // for all items in the tree in post-order\r\n repeat\r\n Parent := Current.Parent;\r\n // remove reference\r\n if Parent <> nil then\r\n begin\r\n if Parent.Left = Current then\r\n Parent.Left := nil\r\n else\r\n if Parent.Right = Current then\r\n Parent.Right := nil;\r\n end;\r\n\r\n // free item\r\n FreeString(Current.Value);\r\n Current.Free;\r\n\r\n // find next item\r\n Current := Parent;\r\n if (Current <> nil) and (Current.Right <> nil) then\r\n begin\r\n Current := Current.Right;\r\n while (Current.Left <> nil) or (Current.Right <> nil) do\r\n begin\r\n if Current.Left <> nil then\r\n Current := Current.Left\r\n else\r\n Current := Current.Right;\r\n end;\r\n end;\r\n until Current = nil;\r\n FRoot := nil;\r\n FSize := 0;\r\n FMaxDepth := 0;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclAnsiStrBinaryTree.CloneNode(Node, Parent: TJclAnsiStrBinaryNode): TJclAnsiStrBinaryNode;\r\nbegin\r\n Result := TJclAnsiStrBinaryNode.Create;\r\n Result.Value := Node.Value;\r\n Result.Parent := Parent;\r\n if Node.Left <> nil then\r\n Result.Left := CloneNode(Node.Left, Result); // recursive call\r\n if Node.Right <> nil then\r\n Result.Right := CloneNode(Node.Right, Result); // recursive call\r\nend;\r\n\r\nfunction TJclAnsiStrBinaryTree.CollectionEquals(const ACollection: IJclAnsiStrCollection): Boolean;\r\nvar\r\n It, ItSelf: IJclAnsiStrIterator;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n if FSize <> ACollection.Size then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n ItSelf := First;\r\n while ItSelf.HasNext do\r\n if not ItemsEqual(ItSelf.Next, It.Next) then\r\n begin\r\n Result := False;\r\n Break;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclAnsiStrBinaryTree.Contains(const AString: AnsiString): Boolean;\r\nvar\r\n Comp: Integer;\r\n Current: TJclAnsiStrBinaryNode;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n Current := FRoot;\r\n while Current <> nil do\r\n begin\r\n Comp := ItemsCompare(Current.Value, AString);\r\n if Comp = 0 then\r\n begin\r\n Result := True;\r\n Break;\r\n end\r\n else\r\n if Comp > 0 then\r\n Current := Current.Left\r\n else\r\n Current := Current.Right;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclAnsiStrBinaryTree.ContainsAll(const ACollection: IJclAnsiStrCollection): Boolean;\r\nvar\r\n It: IJclAnsiStrIterator;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := True;\r\n if ACollection = nil then\r\n Exit;\r\n It := ACollection.First;\r\n while Result and It.HasNext do\r\n Result := Contains(It.Next);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclAnsiStrBinaryTree.Extract(const AString: AnsiString): Boolean;\r\nvar\r\n Current, Successor: TJclAnsiStrBinaryNode;\r\n Comp: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n // locate AString in the tree\r\n Current := FRoot;\r\n repeat\r\n while Current <> nil do\r\n begin\r\n Comp := ItemsCompare(AString, Current.Value);\r\n if Comp = 0 then\r\n Break\r\n else\r\n if Comp < 0 then\r\n Current := Current.Left\r\n else\r\n Current := Current.Right;\r\n end;\r\n if Current = nil then\r\n Break;\r\n Result := True;\r\n // Remove Current from tree\r\n if (Current.Left = nil) and (Current.Right <> nil) then\r\n begin\r\n // remove references to Current\r\n Current.Right.Parent := Current.Parent;\r\n if Current.Parent <> nil then\r\n begin\r\n if Current.Parent.Left = Current then\r\n Current.Parent.Left := Current.Right\r\n else\r\n Current.Parent.Right := Current.Right;\r\n end\r\n else\r\n // fix root\r\n FRoot := Current.Right;\r\n Successor := Current.Parent;\r\n if Successor = nil then\r\n Successor := FRoot;\r\n end\r\n else\r\n if (Current.Left <> nil) and (Current.Right = nil) then\r\n begin\r\n // remove references to Current\r\n Current.Left.Parent := Current.Parent;\r\n if Current.Parent <> nil then\r\n begin\r\n if Current.Parent.Left = Current then\r\n Current.Parent.Left := Current.Left\r\n else\r\n Current.Parent.Right := Current.Left;\r\n end\r\n else\r\n // fix root\r\n FRoot := Current.Left;\r\n Successor := Current.Parent;\r\n if Successor = nil then\r\n Successor := FRoot;\r\n end\r\n else\r\n if (Current.Left <> nil) and (Current.Right <> nil) then\r\n begin\r\n // find the successor in tree\r\n Successor := Current.Right;\r\n while Successor.Left <> nil do\r\n Successor := Successor.Left;\r\n\r\n if Successor <> Current.Right then\r\n begin\r\n // remove references to successor\r\n Successor.Parent.Left := Successor.Right;\r\n if Successor.Right <> nil then\r\n Successor.Right.Parent := Successor.Parent;\r\n Successor.Right := Current.Right;\r\n if Successor.Right <> nil then\r\n Successor.Right.Parent := Successor;\r\n end;\r\n\r\n // insert successor in new position\r\n Successor.Left := Current.Left;\r\n if Current.Left <> nil then\r\n Current.Left.Parent := Successor;\r\n Successor.Parent := Current.Parent;\r\n if Current.Parent <> nil then\r\n begin\r\n if Current.Parent.Left = Current then\r\n Current.Parent.Left := Successor\r\n else\r\n Current.Parent.Right := Successor;\r\n end\r\n else\r\n // fix root\r\n FRoot := Successor;\r\n Successor := Current.Parent;\r\n if Successor <> nil then\r\n Successor := FRoot;\r\n end\r\n else\r\n begin\r\n // (Current.Left = nil) and (Current.Right = nil)\r\n Successor := Current.Parent;\r\n if Successor <> nil then\r\n begin\r\n // remove references from parent\r\n if Successor.Left = Current then\r\n Successor.Left := nil\r\n else\r\n Successor.Right := nil;\r\n end\r\n else\r\n FRoot := nil;\r\n end;\r\n Current.Value := '';\r\n Current.Free;\r\n Dec(FSize);\r\n Current := Successor;\r\n until FRemoveSingleElement or (Current = nil);\r\n AutoPack;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclAnsiStrBinaryTree.ExtractAll(const ACollection: IJclAnsiStrCollection): Boolean;\r\nvar\r\n It: IJclAnsiStrIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n Result := Extract(It.Next) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclAnsiStrBinaryTree.First: IJclAnsiStrIterator;\r\nvar\r\n Start: TJclAnsiStrBinaryNode;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Start := FRoot;\r\n case GetTraverseOrder of\r\n toPreOrder:\r\n Result := TJclPreOrderAnsiStrBinaryTreeIterator.Create(Self, Start, False, isFirst);\r\n toOrder:\r\n begin\r\n if Start <> nil then\r\n while Start.Left <> nil do\r\n Start := Start.Left;\r\n Result := TJclInOrderAnsiStrBinaryTreeIterator.Create(Self, Start, False, isFirst);\r\n end;\r\n toPostOrder:\r\n begin\r\n if Start <> nil then\r\n while (Start.Left <> nil) or (Start.Right <> nil) do\r\n begin\r\n if Start.Left <> nil then\r\n Start := Start.Left\r\n else\r\n Start := Start.Right;\r\n end;\r\n Result := TJclPostOrderAnsiStrBinaryTreeIterator.Create(Self, Start, False, isFirst);\r\n end;\r\n else\r\n Result := nil;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\n{$IFDEF SUPPORTS_FOR_IN}\r\nfunction TJclAnsiStrBinaryTree.GetEnumerator: IJclAnsiStrIterator;\r\nbegin\r\n Result := First;\r\nend;\r\n{$ENDIF SUPPORTS_FOR_IN}\r\n\r\nfunction TJclAnsiStrBinaryTree.GetRoot: IJclAnsiStrTreeIterator;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n case GetTraverseOrder of\r\n toPreOrder:\r\n Result := TJclPreOrderAnsiStrBinaryTreeIterator.Create(Self, FRoot, False, isRoot);\r\n toOrder:\r\n Result := TJclInOrderAnsiStrBinaryTreeIterator.Create(Self, FRoot, False, isRoot);\r\n toPostOrder:\r\n Result := TJclPostOrderAnsiStrBinaryTreeIterator.Create(Self, FRoot, False, isRoot);\r\n else\r\n Result := nil;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclAnsiStrBinaryTree.GetTraverseOrder: TJclTraverseOrder;\r\nbegin\r\n Result := FTraverseOrder;\r\nend;\r\n\r\nfunction TJclAnsiStrBinaryTree.IsEmpty: Boolean;\r\nbegin\r\n Result := FSize = 0;\r\nend;\r\n\r\nfunction TJclAnsiStrBinaryTree.Last: IJclAnsiStrIterator;\r\nvar\r\n Start: TJclAnsiStrBinaryNode;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Start := FRoot;\r\n case FTraverseOrder of\r\n toPreOrder:\r\n begin\r\n if Start <> nil then\r\n while (Start.Left <> nil) or (Start.Right <> nil) do\r\n begin\r\n if Start.Right <> nil then\r\n Start := Start.Right\r\n else\r\n Start := Start.Left;\r\n end;\r\n Result := TJclPreOrderAnsiStrBinaryTreeIterator.Create(Self, Start, False, isLast);\r\n end;\r\n toOrder:\r\n begin\r\n if Start <> nil then\r\n while Start.Right <> nil do\r\n Start := Start.Right;\r\n Result := TJclInOrderAnsiStrBinaryTreeIterator.Create(Self, Start, False, isLast);\r\n end;\r\n toPostOrder:\r\n Result := TJclPostOrderAnsiStrBinaryTreeIterator.Create(Self, Start, False, isLast);\r\n else\r\n Result := nil;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclAnsiStrBinaryTree.Pack;\r\nvar\r\n LeafArray: array of TJclAnsiStrBinaryNode;\r\n ANode, BNode: TJclAnsiStrBinaryNode;\r\n Index: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n SetLength(Leafarray, FSize);\r\n try\r\n // in order enumeration of nodes\r\n ANode := FRoot;\r\n if ANode <> nil then\r\n begin\r\n // find first node\r\n while ANode.Left <> nil do\r\n ANode := ANode.Left;\r\n\r\n Index := 0;\r\n while ANode <> nil do\r\n begin\r\n LeafArray[Index] := ANode;\r\n Inc(Index);\r\n if ANode.Right <> nil then\r\n begin\r\n ANode := ANode.Right;\r\n while (ANode.Left <> nil) do\r\n ANode := ANode.Left;\r\n end\r\n else\r\n begin\r\n BNode := ANode;\r\n ANode := ANode.Parent;\r\n while (ANode <> nil) and (ANode.Right = BNode) do\r\n begin\r\n BNode := ANode;\r\n ANode := ANode.Parent;\r\n end;\r\n end;\r\n end;\r\n\r\n Index := FSize shr 1;\r\n FRoot := LeafArray[Index];\r\n FRoot.Parent := nil;\r\n if Index > 0 then\r\n FRoot.Left := BuildTree(LeafArray, 0, Index - 1, FRoot, 0)\r\n else\r\n FRoot.Left := nil;\r\n if Index < (FSize - 1) then\r\n FRoot.Right := BuildTree(LeafArray, Index + 1, FSize - 1, FRoot, 1)\r\n else\r\n FRoot.Right := nil;\r\n end;\r\n finally\r\n SetLength(LeafArray, 0);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclAnsiStrBinaryTree.Remove(const AString: AnsiString): Boolean;\r\nvar\r\n Extracted: AnsiString;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := Extract(AString);\r\n if Result then\r\n begin\r\n Extracted := AString;\r\n FreeString(Extracted);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclAnsiStrBinaryTree.RemoveAll(const ACollection: IJclAnsiStrCollection): Boolean;\r\nvar\r\n It: IJclAnsiStrIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n Result := Remove(It.Next) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclAnsiStrBinaryTree.RetainAll(const ACollection: IJclAnsiStrCollection): Boolean;\r\nvar\r\n It: IJclAnsiStrIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := First;\r\n while It.HasNext do\r\n if not ACollection.Contains(It.Next) then\r\n It.Remove;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclAnsiStrBinaryTree.SetCapacity(Value: Integer);\r\nbegin\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nprocedure TJclAnsiStrBinaryTree.SetTraverseOrder(Value: TJclTraverseOrder);\r\nbegin\r\n FTraverseOrder := Value;\r\nend;\r\n\r\nfunction TJclAnsiStrBinaryTree.Size: Integer;\r\nbegin\r\n Result := FSize;\r\nend;\r\n\r\nfunction TJclAnsiStrBinaryTree.CreateEmptyContainer: TJclAbstractContainerBase;\r\nbegin\r\n Result := TJclAnsiStrBinaryTree.Create(Compare);\r\n AssignPropertiesTo(Result);\r\nend;\r\n\r\n//=== { TJclAnsiStrBinaryTreeIterator } ===========================================================\r\n\r\nconstructor TJclAnsiStrBinaryTreeIterator.Create(const AOwnTree: IJclAnsiStrCollection; ACursor: TJclAnsiStrBinaryNode; AValid: Boolean; AStart: TItrStart);\r\nbegin\r\n inherited Create(AValid);\r\n FCursor := ACursor;\r\n FStart := AStart;\r\n FOwnTree := AOwnTree;\r\n FEqualityComparer := AOwnTree as IJclAnsiStrEqualityComparer;\r\nend;\r\n\r\nfunction TJclAnsiStrBinaryTreeIterator.Add(const AString: AnsiString): Boolean;\r\nbegin\r\n Result := FOwnTree.Add(AString);\r\nend;\r\n\r\nfunction TJclAnsiStrBinaryTreeIterator.AddChild(const AString: AnsiString): Boolean;\r\nbegin\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nprocedure TJclAnsiStrBinaryTreeIterator.AssignPropertiesTo(Dest: TJclAbstractIterator);\r\nvar\r\n ADest: TJclAnsiStrBinaryTreeIterator;\r\nbegin\r\n inherited AssignPropertiesTo(Dest);\r\n if Dest is TJclAnsiStrBinaryTreeIterator then\r\n begin\r\n ADest := TJclAnsiStrBinaryTreeIterator(Dest);\r\n ADest.FCursor := FCursor;\r\n ADest.FOwnTree := FOwnTree;\r\n ADest.FEqualityComparer := FEqualityComparer;\r\n ADest.FStart := FStart;\r\n end;\r\nend;\r\n\r\nfunction TJclAnsiStrBinaryTreeIterator.ChildrenCount: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := 0;\r\n if FCursor <> nil then\r\n begin\r\n if FCursor.Left <> nil then\r\n Inc(Result);\r\n if FCursor.Right <> nil then\r\n Inc(Result);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclAnsiStrBinaryTreeIterator.DeleteChild(Index: Integer);\r\nbegin\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nprocedure TJclAnsiStrBinaryTreeIterator.DeleteChildren;\r\nbegin\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nprocedure TJclAnsiStrBinaryTreeIterator.Extract;\r\nvar\r\n OldCursor: TJclAnsiStrBinaryNode;\r\nbegin\r\n if FOwnTree.ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n CheckValid;\r\n Valid := False;\r\n OldCursor := FCursor;\r\n if OldCursor <> nil then\r\n begin\r\n repeat\r\n FCursor := GetNextCursor;\r\n until (FCursor = nil) or FOwnTree.RemoveSingleElement\r\n or (not FEqualityComparer.ItemsEqual(OldCursor.Value, FCursor.Value));\r\n FOwnTree.Extract(OldCursor.Value);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.WriteUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclAnsiStrBinaryTreeIterator.ExtractChild(Index: Integer);\r\nbegin\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nprocedure TJclAnsiStrBinaryTreeIterator.ExtractChildren;\r\nbegin\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nfunction TJclAnsiStrBinaryTreeIterator.GetChild(Index: Integer): AnsiString;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := '';\r\n if (FCursor <> nil) and (Index = 0) and (FCursor.Left <> nil) then\r\n FCursor := FCursor.Left\r\n else\r\n if (FCursor <> nil) and (Index = 0) then\r\n FCursor := FCursor.Right\r\n else\r\n if (FCursor <> nil) and (Index = 1) then\r\n FCursor := FCursor.Right\r\n else\r\n FCursor := nil;\r\n if FCursor <> nil then\r\n Result := FCursor.Value\r\n else\r\n if not FOwnTree.ReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclAnsiStrBinaryTreeIterator.GetString: AnsiString;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n CheckValid;\r\n Result := '';\r\n if FCursor <> nil then\r\n Result := FCursor.Value\r\n else\r\n if not FOwnTree.ReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclAnsiStrBinaryTreeIterator.HasChild(Index: Integer): Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if (FCursor <> nil) and (Index = 0) then\r\n Result := (FCursor.Left <> nil) or (FCursor.Right <> nil)\r\n else\r\n if (FCursor <> nil) and (Index = 1) then\r\n Result := (FCursor.Left <> nil) and (FCursor.Right <> nil)\r\n else\r\n Result := False;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclAnsiStrBinaryTreeIterator.HasLeft: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := (FCursor <> nil) and (FCursor.Left <> nil);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclAnsiStrBinaryTreeIterator.HasNext: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Valid then\r\n Result := GetNextCursor <> nil\r\n else\r\n Result := FCursor <> nil;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclAnsiStrBinaryTreeIterator.HasParent: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := (FCursor <> nil) and (FCursor.Parent <> nil);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclAnsiStrBinaryTreeIterator.HasPrevious: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Valid then\r\n Result := GetPreviousCursor <> nil\r\n else\r\n Result := FCursor <> nil;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclAnsiStrBinaryTreeIterator.HasRight: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := (FCursor <> nil) and (FCursor.Right <> nil);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclAnsiStrBinaryTreeIterator.IndexOfChild(const AString: AnsiString): Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := -1;\r\n if FCursor <> nil then\r\n begin\r\n if FCursor.Left <> nil then\r\n begin\r\n if FEqualityComparer.ItemsEqual(FCursor.Left.Value, AString) then\r\n Result := 0\r\n else\r\n if (FCursor.Right <> nil) and FEqualityComparer.ItemsEqual(FCursor.Right.Value, AString) then\r\n Result := 1;\r\n end\r\n else\r\n if (FCursor.Right <> nil) and FEqualityComparer.ItemsEqual(FCursor.Right.Value, AString) then\r\n Result := 0;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclAnsiStrBinaryTreeIterator.Insert(const AString: AnsiString): Boolean;\r\nbegin\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nfunction TJclAnsiStrBinaryTreeIterator.InsertChild(Index: Integer; const AString: AnsiString): Boolean;\r\nbegin\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nfunction TJclAnsiStrBinaryTreeIterator.IteratorEquals(const AIterator: IJclAnsiStrIterator): Boolean;\r\nvar\r\n Obj: TObject;\r\n ItrObj: TJclAnsiStrBinaryTreeIterator;\r\nbegin\r\n Result := False;\r\n if AIterator = nil then\r\n Exit;\r\n Obj := AIterator.GetIteratorReference;\r\n if Obj is TJclAnsiStrBinaryTreeIterator then\r\n begin\r\n ItrObj := TJclAnsiStrBinaryTreeIterator(Obj);\r\n Result := (FOwnTree = ItrObj.FOwnTree) and (FCursor = ItrObj.FCursor) and (Valid = ItrObj.Valid);\r\n end;\r\nend;\r\n\r\nfunction TJclAnsiStrBinaryTreeIterator.Left: AnsiString;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := '';\r\n if FCursor <> nil then\r\n FCursor := FCursor.Left;\r\n if FCursor <> nil then\r\n Result := FCursor.Value\r\n else\r\n if not FOwnTree.ReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\n{$IFDEF SUPPORTS_FOR_IN}\r\nfunction TJclAnsiStrBinaryTreeIterator.MoveNext: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Valid then\r\n FCursor := GetNextCursor\r\n else\r\n Valid := True;\r\n Result := FCursor <> nil;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n{$ENDIF SUPPORTS_FOR_IN}\r\n\r\nfunction TJclAnsiStrBinaryTreeIterator.Next: AnsiString;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Valid then\r\n FCursor := GetNextCursor\r\n else\r\n Valid := True;\r\n Result := '';\r\n if FCursor <> nil then\r\n Result := FCursor.Value\r\n else\r\n if not FOwnTree.ReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclAnsiStrBinaryTreeIterator.NextIndex: Integer;\r\nbegin\r\n // No index\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nfunction TJclAnsiStrBinaryTreeIterator.Parent: AnsiString;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := '';\r\n if FCursor <> nil then\r\n FCursor := FCursor.Parent;\r\n if FCursor <> nil then\r\n Result := FCursor.Value\r\n else\r\n if not FOwnTree.ReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclAnsiStrBinaryTreeIterator.Previous: AnsiString;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Valid then\r\n FCursor := GetPreviousCursor\r\n else\r\n Valid := True;\r\n Result := '';\r\n if FCursor <> nil then\r\n Result := FCursor.Value\r\n else\r\n if not FOwnTree.ReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclAnsiStrBinaryTreeIterator.PreviousIndex: Integer;\r\nbegin\r\n // No index\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nprocedure TJclAnsiStrBinaryTreeIterator.Remove;\r\nvar\r\n OldCursor: TJclAnsiStrBinaryNode;\r\nbegin\r\n if FOwnTree.ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n CheckValid;\r\n Valid := False;\r\n OldCursor := FCursor;\r\n if OldCursor <> nil then\r\n begin\r\n repeat\r\n FCursor := GetNextCursor;\r\n until (FCursor = nil) or FOwnTree.RemoveSingleElement\r\n or (not FEqualityComparer.ItemsEqual(OldCursor.Value, FCursor.Value));\r\n FOwnTree.Remove(OldCursor.Value);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.WriteUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclAnsiStrBinaryTreeIterator.Reset;\r\nvar\r\n NewCursor: TJclAnsiStrBinaryNode;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Valid := False;\r\n case FStart of\r\n isFirst:\r\n begin\r\n NewCursor := FCursor;\r\n while NewCursor <> nil do\r\n begin\r\n NewCursor := GetPreviousCursor;\r\n if NewCursor <> nil then\r\n FCursor := NewCursor;\r\n end;\r\n end;\r\n isLast:\r\n begin\r\n NewCursor := FCursor;\r\n while NewCursor <> nil do\r\n begin\r\n NewCursor := GetNextCursor;\r\n if NewCursor <> nil then\r\n FCursor := NewCursor;\r\n end;\r\n end;\r\n isRoot:\r\n begin\r\n while (FCursor <> nil) and (FCursor.Parent <> nil) do\r\n FCursor := FCursor.Parent;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclAnsiStrBinaryTreeIterator.Right: AnsiString;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := '';\r\n if FCursor <> nil then\r\n FCursor := FCursor.Right;\r\n if FCursor <> nil then\r\n Result := FCursor.Value\r\n else\r\n if not FOwnTree.ReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclAnsiStrBinaryTreeIterator.SetChild(Index: Integer; const AString: AnsiString);\r\nbegin\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nprocedure TJclAnsiStrBinaryTreeIterator.SetString(const AString: AnsiString);\r\nbegin\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\n//=== { TJclPreOrderAnsiStrBinaryTreeIterator } ===================================================\r\n\r\nfunction TJclPreOrderAnsiStrBinaryTreeIterator.CreateEmptyIterator: TJclAbstractIterator;\r\nbegin\r\n Result := TJclPreOrderAnsiStrBinaryTreeIterator.Create(FOwnTree, FCursor, Valid, FStart);\r\nend;\r\n\r\nfunction TJclPreOrderAnsiStrBinaryTreeIterator.GetNextCursor: TJclAnsiStrBinaryNode;\r\nvar\r\n LastRet: TJclAnsiStrBinaryNode;\r\nbegin\r\n Result := FCursor;\r\n if Result = nil then\r\n Exit;\r\n LastRet := Result;\r\n if Result.Left <> nil then\r\n Result := Result.Left\r\n else\r\n if Result.Right <> nil then\r\n Result := Result.Right\r\n else\r\n begin\r\n Result := Result.Parent;\r\n while (Result <> nil) and ((Result.Right = nil) or (Result.Right = LastRet)) do\r\n begin\r\n LastRet := Result;\r\n Result := Result.Parent;\r\n end;\r\n if Result <> nil then // not root\r\n Result := Result.Right;\r\n end;\r\nend;\r\n\r\nfunction TJclPreOrderAnsiStrBinaryTreeIterator.GetPreviousCursor: TJclAnsiStrBinaryNode;\r\nvar\r\n LastRet: TJclAnsiStrBinaryNode;\r\nbegin\r\n Result := FCursor;\r\n if Result = nil then\r\n Exit;\r\n LastRet := Result;\r\n Result := Result.Parent;\r\n if (Result <> nil) and (Result.Left <> LastRet) and (Result.Left <> nil) then\r\n // come from Right\r\n begin\r\n Result := Result.Left;\r\n while (Result.Left <> nil) or (Result.Right <> nil) do // both childs\r\n begin\r\n if Result.Right <> nil then // right child first\r\n Result := Result.Right\r\n else\r\n Result := Result.Left;\r\n end;\r\n end;\r\nend;\r\n\r\n//=== { TJclInOrderAnsiStrBinaryTreeIterator } ====================================================\r\n\r\nfunction TJclInOrderAnsiStrBinaryTreeIterator.CreateEmptyIterator: TJclAbstractIterator;\r\nbegin\r\n Result := TJclInOrderAnsiStrBinaryTreeIterator.Create(FOwnTree, FCursor, Valid, FStart);\r\nend;\r\n\r\nfunction TJclInOrderAnsiStrBinaryTreeIterator.GetNextCursor: TJclAnsiStrBinaryNode;\r\nvar\r\n LastRet: TJclAnsiStrBinaryNode;\r\nbegin\r\n Result := FCursor;\r\n if Result = nil then\r\n Exit;\r\n if Result.Right <> nil then\r\n begin\r\n Result := Result.Right;\r\n while (Result.Left <> nil) do\r\n Result := Result.Left;\r\n end\r\n else\r\n begin\r\n LastRet := Result;\r\n Result := Result.Parent;\r\n while (Result <> nil) and (Result.Right = LastRet) do\r\n begin\r\n LastRet := Result;\r\n Result := Result.Parent;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJclInOrderAnsiStrBinaryTreeIterator.GetPreviousCursor: TJclAnsiStrBinaryNode;\r\nvar\r\n LastRet: TJclAnsiStrBinaryNode;\r\nbegin\r\n Result := FCursor;\r\n if Result = nil then\r\n Exit;\r\n if Result.Left <> nil then\r\n begin\r\n Result := Result.Left;\r\n while Result.Right <> nil do\r\n Result := Result.Right;\r\n end\r\n else\r\n begin\r\n LastRet := Result;\r\n Result := Result.Parent;\r\n while (Result <> nil) and (Result.Right <> LastRet) do // Come from Left\r\n begin\r\n LastRet := Result;\r\n Result := Result.Parent;\r\n end;\r\n end;\r\nend;\r\n\r\n//=== { TJclPostOrderAnsiStrBinaryTreeIterator } ==================================================\r\n\r\nfunction TJclPostOrderAnsiStrBinaryTreeIterator.CreateEmptyIterator: TJclAbstractIterator;\r\nbegin\r\n Result := TJclPostOrderAnsiStrBinaryTreeIterator.Create(FOwnTree, FCursor, Valid, FStart);\r\nend;\r\n\r\nfunction TJclPostOrderAnsiStrBinaryTreeIterator.GetNextCursor: TJclAnsiStrBinaryNode;\r\nvar\r\n LastRet: TJclAnsiStrBinaryNode;\r\nbegin\r\n Result := FCursor;\r\n if Result = nil then\r\n Exit;\r\n LastRet := Result;\r\n Result := Result.Parent;\r\n if (Result <> nil) and (Result.Right <> nil) and (Result.Right <> LastRet) then\r\n begin\r\n Result := Result.Right;\r\n while (Result.Left <> nil) or (Result.Right <> nil) do\r\n begin\r\n if Result.Left <> nil then\r\n Result := Result.Left\r\n else\r\n Result := Result.Right;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJclPostOrderAnsiStrBinaryTreeIterator.GetPreviousCursor: TJclAnsiStrBinaryNode;\r\nvar\r\n LastRet: TJclAnsiStrBinaryNode;\r\nbegin\r\n Result := FCursor;\r\n if Result = nil then\r\n Exit;\r\n if Result.Right <> nil then\r\n Result := Result.Right\r\n else\r\n if Result.Left <> nil then\r\n Result := Result.Left\r\n else\r\n begin\r\n LastRet := Result;\r\n Result := Result.Parent;\r\n while (Result <> nil) and ((Result.Left = nil) or (Result.Left = LastRet)) do\r\n begin\r\n LastRet := Result;\r\n Result := Result.Parent;\r\n end;\r\n if Result <> nil then // not root\r\n Result := Result.Left;\r\n end;\r\nend;\r\n\r\n//=== { TJclWideStrBinaryTree } =================================================\r\n\r\nconstructor TJclWideStrBinaryTree.Create(ACompare: TWideStrCompare);\r\nbegin\r\n inherited Create();\r\n FTraverseOrder := toOrder;\r\n FMaxDepth := 0;\r\n FAutoPackParameter := 2;\r\n SetCompare(ACompare);\r\nend;\r\n\r\ndestructor TJclWideStrBinaryTree.Destroy;\r\nbegin\r\n FReadOnly := False;\r\n Clear;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJclWideStrBinaryTree.Add(const AString: WideString): Boolean;\r\nvar\r\n NewNode, Current, Save: TJclWideStrBinaryNode;\r\n Comp, Depth: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n // Insert into right place\r\n if FAllowDefaultElements or not ItemsEqual(AString, '') then\r\n begin\r\n Save := nil;\r\n Current := FRoot;\r\n Comp := 1;\r\n Depth := 0;\r\n while Current <> nil do\r\n begin\r\n Inc(Depth);\r\n Save := Current;\r\n Comp := ItemsCompare(AString, Current.Value);\r\n if Comp < 0 then\r\n Current := Current.Left\r\n else\r\n if Comp > 0 then\r\n Current := Current.Right\r\n else\r\n if CheckDuplicate then\r\n Current := Current.Left // arbitrary decision\r\n else\r\n Break;\r\n end;\r\n if (Comp <> 0) or CheckDuplicate then\r\n begin\r\n NewNode := TJclWideStrBinaryNode.Create;\r\n NewNode.Value := AString;\r\n NewNode.Parent := Save;\r\n if Save = nil then\r\n FRoot := NewNode\r\n else\r\n if ItemsCompare(NewNode.Value, Save.Value) <= 0 then\r\n Save.Left := NewNode\r\n else\r\n Save.Right := NewNode;\r\n Inc(FSize);\r\n Inc(Depth);\r\n if Depth > FMaxDepth then\r\n FMaxDepth := Depth;\r\n Result := True;\r\n AutoPack;\r\n end\r\n else\r\n Result := False;\r\n end\r\n else\r\n Result := False;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclWideStrBinaryTree.AddAll(const ACollection: IJclWideStrCollection): Boolean;\r\nvar\r\n It: IJclWideStrIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n Result := Add(It.Next) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclWideStrBinaryTree.AssignDataTo(Dest: TJclAbstractContainerBase);\r\nvar\r\n ADest: TJclWideStrBinaryTree;\r\n ACollection: IJclWideStrCollection;\r\nbegin\r\n inherited AssignDataTo(Dest);\r\n if Dest is TJclWideStrBinaryTree then\r\n begin\r\n ADest := TJclWideStrBinaryTree(Dest);\r\n ADest.Clear;\r\n ADest.FSize := FSize;\r\n if FRoot <> nil then\r\n ADest.FRoot := CloneNode(FRoot, nil);\r\n end\r\n else\r\n if Supports(IInterface(Dest), IJclWideStrCollection, ACollection) then\r\n begin\r\n ACollection.Clear;\r\n ACollection.AddAll(Self);\r\n end;\r\nend;\r\n\r\nprocedure TJclWideStrBinaryTree.AssignPropertiesTo(Dest: TJclAbstractContainerBase);\r\nbegin\r\n inherited AssignPropertiesto(Dest);\r\n if Dest is TJclWideStrBinaryTree then\r\n TJclWideStrBinaryTree(Dest).FTraverseOrder := FTraverseOrder;\r\nend;\r\n\r\nprocedure TJclWideStrBinaryTree.AutoPack;\r\nbegin\r\n case FAutoPackStrategy of\r\n //apsDisabled: ;\r\n apsAgressive:\r\n if (FMaxDepth > 1) and (((1 shl (FMaxDepth - 1)) - 1) > FSize) then\r\n Pack;\r\n // apsIncremental: ;\r\n apsProportional:\r\n if (FMaxDepth > FAutoPackParameter) and (((1 shl (FMaxDepth - FAutoPackParameter)) - 1) > FSize) then\r\n Pack;\r\n end;\r\nend;\r\n\r\nfunction TJclWideStrBinaryTree.BuildTree(const LeafArray: array of TJclWideStrBinaryNode; Left, Right: Integer; Parent: TJclWideStrBinaryNode;\r\n Offset: Integer): TJclWideStrBinaryNode;\r\nvar\r\n Middle: Integer;\r\nbegin\r\n Middle := (Left + Right + Offset) shr 1;\r\n Result := LeafArray[Middle];\r\n Result.Parent := Parent;\r\n if Middle > Left then\r\n Result.Left := BuildTree(LeafArray, Left, Middle - 1, Result, 0)\r\n else\r\n Result.Left := nil;\r\n if Middle < Right then\r\n Result.Right := BuildTree(LeafArray, Middle + 1, Right, Result, 1)\r\n else\r\n Result.Right := nil;\r\nend;\r\n\r\nprocedure TJclWideStrBinaryTree.Clear;\r\nvar\r\n Current, Parent: TJclWideStrBinaryNode;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n // postorder\r\n Current := FRoot;\r\n if Current = nil then\r\n Exit;\r\n // find first in post-order\r\n while (Current.Left <> nil) or (Current.Right <> nil) do\r\n begin\r\n if Current.Left <> nil then\r\n Current := Current.Left\r\n else\r\n Current := Current.Right;\r\n end;\r\n // for all items in the tree in post-order\r\n repeat\r\n Parent := Current.Parent;\r\n // remove reference\r\n if Parent <> nil then\r\n begin\r\n if Parent.Left = Current then\r\n Parent.Left := nil\r\n else\r\n if Parent.Right = Current then\r\n Parent.Right := nil;\r\n end;\r\n\r\n // free item\r\n FreeString(Current.Value);\r\n Current.Free;\r\n\r\n // find next item\r\n Current := Parent;\r\n if (Current <> nil) and (Current.Right <> nil) then\r\n begin\r\n Current := Current.Right;\r\n while (Current.Left <> nil) or (Current.Right <> nil) do\r\n begin\r\n if Current.Left <> nil then\r\n Current := Current.Left\r\n else\r\n Current := Current.Right;\r\n end;\r\n end;\r\n until Current = nil;\r\n FRoot := nil;\r\n FSize := 0;\r\n FMaxDepth := 0;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclWideStrBinaryTree.CloneNode(Node, Parent: TJclWideStrBinaryNode): TJclWideStrBinaryNode;\r\nbegin\r\n Result := TJclWideStrBinaryNode.Create;\r\n Result.Value := Node.Value;\r\n Result.Parent := Parent;\r\n if Node.Left <> nil then\r\n Result.Left := CloneNode(Node.Left, Result); // recursive call\r\n if Node.Right <> nil then\r\n Result.Right := CloneNode(Node.Right, Result); // recursive call\r\nend;\r\n\r\nfunction TJclWideStrBinaryTree.CollectionEquals(const ACollection: IJclWideStrCollection): Boolean;\r\nvar\r\n It, ItSelf: IJclWideStrIterator;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n if FSize <> ACollection.Size then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n ItSelf := First;\r\n while ItSelf.HasNext do\r\n if not ItemsEqual(ItSelf.Next, It.Next) then\r\n begin\r\n Result := False;\r\n Break;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclWideStrBinaryTree.Contains(const AString: WideString): Boolean;\r\nvar\r\n Comp: Integer;\r\n Current: TJclWideStrBinaryNode;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n Current := FRoot;\r\n while Current <> nil do\r\n begin\r\n Comp := ItemsCompare(Current.Value, AString);\r\n if Comp = 0 then\r\n begin\r\n Result := True;\r\n Break;\r\n end\r\n else\r\n if Comp > 0 then\r\n Current := Current.Left\r\n else\r\n Current := Current.Right;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclWideStrBinaryTree.ContainsAll(const ACollection: IJclWideStrCollection): Boolean;\r\nvar\r\n It: IJclWideStrIterator;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := True;\r\n if ACollection = nil then\r\n Exit;\r\n It := ACollection.First;\r\n while Result and It.HasNext do\r\n Result := Contains(It.Next);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclWideStrBinaryTree.Extract(const AString: WideString): Boolean;\r\nvar\r\n Current, Successor: TJclWideStrBinaryNode;\r\n Comp: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n // locate AString in the tree\r\n Current := FRoot;\r\n repeat\r\n while Current <> nil do\r\n begin\r\n Comp := ItemsCompare(AString, Current.Value);\r\n if Comp = 0 then\r\n Break\r\n else\r\n if Comp < 0 then\r\n Current := Current.Left\r\n else\r\n Current := Current.Right;\r\n end;\r\n if Current = nil then\r\n Break;\r\n Result := True;\r\n // Remove Current from tree\r\n if (Current.Left = nil) and (Current.Right <> nil) then\r\n begin\r\n // remove references to Current\r\n Current.Right.Parent := Current.Parent;\r\n if Current.Parent <> nil then\r\n begin\r\n if Current.Parent.Left = Current then\r\n Current.Parent.Left := Current.Right\r\n else\r\n Current.Parent.Right := Current.Right;\r\n end\r\n else\r\n // fix root\r\n FRoot := Current.Right;\r\n Successor := Current.Parent;\r\n if Successor = nil then\r\n Successor := FRoot;\r\n end\r\n else\r\n if (Current.Left <> nil) and (Current.Right = nil) then\r\n begin\r\n // remove references to Current\r\n Current.Left.Parent := Current.Parent;\r\n if Current.Parent <> nil then\r\n begin\r\n if Current.Parent.Left = Current then\r\n Current.Parent.Left := Current.Left\r\n else\r\n Current.Parent.Right := Current.Left;\r\n end\r\n else\r\n // fix root\r\n FRoot := Current.Left;\r\n Successor := Current.Parent;\r\n if Successor = nil then\r\n Successor := FRoot;\r\n end\r\n else\r\n if (Current.Left <> nil) and (Current.Right <> nil) then\r\n begin\r\n // find the successor in tree\r\n Successor := Current.Right;\r\n while Successor.Left <> nil do\r\n Successor := Successor.Left;\r\n\r\n if Successor <> Current.Right then\r\n begin\r\n // remove references to successor\r\n Successor.Parent.Left := Successor.Right;\r\n if Successor.Right <> nil then\r\n Successor.Right.Parent := Successor.Parent;\r\n Successor.Right := Current.Right;\r\n if Successor.Right <> nil then\r\n Successor.Right.Parent := Successor;\r\n end;\r\n\r\n // insert successor in new position\r\n Successor.Left := Current.Left;\r\n if Current.Left <> nil then\r\n Current.Left.Parent := Successor;\r\n Successor.Parent := Current.Parent;\r\n if Current.Parent <> nil then\r\n begin\r\n if Current.Parent.Left = Current then\r\n Current.Parent.Left := Successor\r\n else\r\n Current.Parent.Right := Successor;\r\n end\r\n else\r\n // fix root\r\n FRoot := Successor;\r\n Successor := Current.Parent;\r\n if Successor <> nil then\r\n Successor := FRoot;\r\n end\r\n else\r\n begin\r\n // (Current.Left = nil) and (Current.Right = nil)\r\n Successor := Current.Parent;\r\n if Successor <> nil then\r\n begin\r\n // remove references from parent\r\n if Successor.Left = Current then\r\n Successor.Left := nil\r\n else\r\n Successor.Right := nil;\r\n end\r\n else\r\n FRoot := nil;\r\n end;\r\n Current.Value := '';\r\n Current.Free;\r\n Dec(FSize);\r\n Current := Successor;\r\n until FRemoveSingleElement or (Current = nil);\r\n AutoPack;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclWideStrBinaryTree.ExtractAll(const ACollection: IJclWideStrCollection): Boolean;\r\nvar\r\n It: IJclWideStrIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n Result := Extract(It.Next) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclWideStrBinaryTree.First: IJclWideStrIterator;\r\nvar\r\n Start: TJclWideStrBinaryNode;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Start := FRoot;\r\n case GetTraverseOrder of\r\n toPreOrder:\r\n Result := TJclPreOrderWideStrBinaryTreeIterator.Create(Self, Start, False, isFirst);\r\n toOrder:\r\n begin\r\n if Start <> nil then\r\n while Start.Left <> nil do\r\n Start := Start.Left;\r\n Result := TJclInOrderWideStrBinaryTreeIterator.Create(Self, Start, False, isFirst);\r\n end;\r\n toPostOrder:\r\n begin\r\n if Start <> nil then\r\n while (Start.Left <> nil) or (Start.Right <> nil) do\r\n begin\r\n if Start.Left <> nil then\r\n Start := Start.Left\r\n else\r\n Start := Start.Right;\r\n end;\r\n Result := TJclPostOrderWideStrBinaryTreeIterator.Create(Self, Start, False, isFirst);\r\n end;\r\n else\r\n Result := nil;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\n{$IFDEF SUPPORTS_FOR_IN}\r\nfunction TJclWideStrBinaryTree.GetEnumerator: IJclWideStrIterator;\r\nbegin\r\n Result := First;\r\nend;\r\n{$ENDIF SUPPORTS_FOR_IN}\r\n\r\nfunction TJclWideStrBinaryTree.GetRoot: IJclWideStrTreeIterator;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n case GetTraverseOrder of\r\n toPreOrder:\r\n Result := TJclPreOrderWideStrBinaryTreeIterator.Create(Self, FRoot, False, isRoot);\r\n toOrder:\r\n Result := TJclInOrderWideStrBinaryTreeIterator.Create(Self, FRoot, False, isRoot);\r\n toPostOrder:\r\n Result := TJclPostOrderWideStrBinaryTreeIterator.Create(Self, FRoot, False, isRoot);\r\n else\r\n Result := nil;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclWideStrBinaryTree.GetTraverseOrder: TJclTraverseOrder;\r\nbegin\r\n Result := FTraverseOrder;\r\nend;\r\n\r\nfunction TJclWideStrBinaryTree.IsEmpty: Boolean;\r\nbegin\r\n Result := FSize = 0;\r\nend;\r\n\r\nfunction TJclWideStrBinaryTree.Last: IJclWideStrIterator;\r\nvar\r\n Start: TJclWideStrBinaryNode;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Start := FRoot;\r\n case FTraverseOrder of\r\n toPreOrder:\r\n begin\r\n if Start <> nil then\r\n while (Start.Left <> nil) or (Start.Right <> nil) do\r\n begin\r\n if Start.Right <> nil then\r\n Start := Start.Right\r\n else\r\n Start := Start.Left;\r\n end;\r\n Result := TJclPreOrderWideStrBinaryTreeIterator.Create(Self, Start, False, isLast);\r\n end;\r\n toOrder:\r\n begin\r\n if Start <> nil then\r\n while Start.Right <> nil do\r\n Start := Start.Right;\r\n Result := TJclInOrderWideStrBinaryTreeIterator.Create(Self, Start, False, isLast);\r\n end;\r\n toPostOrder:\r\n Result := TJclPostOrderWideStrBinaryTreeIterator.Create(Self, Start, False, isLast);\r\n else\r\n Result := nil;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclWideStrBinaryTree.Pack;\r\nvar\r\n LeafArray: array of TJclWideStrBinaryNode;\r\n ANode, BNode: TJclWideStrBinaryNode;\r\n Index: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n SetLength(Leafarray, FSize);\r\n try\r\n // in order enumeration of nodes\r\n ANode := FRoot;\r\n if ANode <> nil then\r\n begin\r\n // find first node\r\n while ANode.Left <> nil do\r\n ANode := ANode.Left;\r\n\r\n Index := 0;\r\n while ANode <> nil do\r\n begin\r\n LeafArray[Index] := ANode;\r\n Inc(Index);\r\n if ANode.Right <> nil then\r\n begin\r\n ANode := ANode.Right;\r\n while (ANode.Left <> nil) do\r\n ANode := ANode.Left;\r\n end\r\n else\r\n begin\r\n BNode := ANode;\r\n ANode := ANode.Parent;\r\n while (ANode <> nil) and (ANode.Right = BNode) do\r\n begin\r\n BNode := ANode;\r\n ANode := ANode.Parent;\r\n end;\r\n end;\r\n end;\r\n\r\n Index := FSize shr 1;\r\n FRoot := LeafArray[Index];\r\n FRoot.Parent := nil;\r\n if Index > 0 then\r\n FRoot.Left := BuildTree(LeafArray, 0, Index - 1, FRoot, 0)\r\n else\r\n FRoot.Left := nil;\r\n if Index < (FSize - 1) then\r\n FRoot.Right := BuildTree(LeafArray, Index + 1, FSize - 1, FRoot, 1)\r\n else\r\n FRoot.Right := nil;\r\n end;\r\n finally\r\n SetLength(LeafArray, 0);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclWideStrBinaryTree.Remove(const AString: WideString): Boolean;\r\nvar\r\n Extracted: WideString;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := Extract(AString);\r\n if Result then\r\n begin\r\n Extracted := AString;\r\n FreeString(Extracted);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclWideStrBinaryTree.RemoveAll(const ACollection: IJclWideStrCollection): Boolean;\r\nvar\r\n It: IJclWideStrIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n Result := Remove(It.Next) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclWideStrBinaryTree.RetainAll(const ACollection: IJclWideStrCollection): Boolean;\r\nvar\r\n It: IJclWideStrIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := First;\r\n while It.HasNext do\r\n if not ACollection.Contains(It.Next) then\r\n It.Remove;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclWideStrBinaryTree.SetCapacity(Value: Integer);\r\nbegin\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nprocedure TJclWideStrBinaryTree.SetTraverseOrder(Value: TJclTraverseOrder);\r\nbegin\r\n FTraverseOrder := Value;\r\nend;\r\n\r\nfunction TJclWideStrBinaryTree.Size: Integer;\r\nbegin\r\n Result := FSize;\r\nend;\r\n\r\nfunction TJclWideStrBinaryTree.CreateEmptyContainer: TJclAbstractContainerBase;\r\nbegin\r\n Result := TJclWideStrBinaryTree.Create(Compare);\r\n AssignPropertiesTo(Result);\r\nend;\r\n\r\n//=== { TJclWideStrBinaryTreeIterator } ===========================================================\r\n\r\nconstructor TJclWideStrBinaryTreeIterator.Create(const AOwnTree: IJclWideStrCollection; ACursor: TJclWideStrBinaryNode; AValid: Boolean; AStart: TItrStart);\r\nbegin\r\n inherited Create(AValid);\r\n FCursor := ACursor;\r\n FStart := AStart;\r\n FOwnTree := AOwnTree;\r\n FEqualityComparer := AOwnTree as IJclWideStrEqualityComparer;\r\nend;\r\n\r\nfunction TJclWideStrBinaryTreeIterator.Add(const AString: WideString): Boolean;\r\nbegin\r\n Result := FOwnTree.Add(AString);\r\nend;\r\n\r\nfunction TJclWideStrBinaryTreeIterator.AddChild(const AString: WideString): Boolean;\r\nbegin\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nprocedure TJclWideStrBinaryTreeIterator.AssignPropertiesTo(Dest: TJclAbstractIterator);\r\nvar\r\n ADest: TJclWideStrBinaryTreeIterator;\r\nbegin\r\n inherited AssignPropertiesTo(Dest);\r\n if Dest is TJclWideStrBinaryTreeIterator then\r\n begin\r\n ADest := TJclWideStrBinaryTreeIterator(Dest);\r\n ADest.FCursor := FCursor;\r\n ADest.FOwnTree := FOwnTree;\r\n ADest.FEqualityComparer := FEqualityComparer;\r\n ADest.FStart := FStart;\r\n end;\r\nend;\r\n\r\nfunction TJclWideStrBinaryTreeIterator.ChildrenCount: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := 0;\r\n if FCursor <> nil then\r\n begin\r\n if FCursor.Left <> nil then\r\n Inc(Result);\r\n if FCursor.Right <> nil then\r\n Inc(Result);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclWideStrBinaryTreeIterator.DeleteChild(Index: Integer);\r\nbegin\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nprocedure TJclWideStrBinaryTreeIterator.DeleteChildren;\r\nbegin\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nprocedure TJclWideStrBinaryTreeIterator.Extract;\r\nvar\r\n OldCursor: TJclWideStrBinaryNode;\r\nbegin\r\n if FOwnTree.ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n CheckValid;\r\n Valid := False;\r\n OldCursor := FCursor;\r\n if OldCursor <> nil then\r\n begin\r\n repeat\r\n FCursor := GetNextCursor;\r\n until (FCursor = nil) or FOwnTree.RemoveSingleElement\r\n or (not FEqualityComparer.ItemsEqual(OldCursor.Value, FCursor.Value));\r\n FOwnTree.Extract(OldCursor.Value);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.WriteUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclWideStrBinaryTreeIterator.ExtractChild(Index: Integer);\r\nbegin\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nprocedure TJclWideStrBinaryTreeIterator.ExtractChildren;\r\nbegin\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nfunction TJclWideStrBinaryTreeIterator.GetChild(Index: Integer): WideString;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := '';\r\n if (FCursor <> nil) and (Index = 0) and (FCursor.Left <> nil) then\r\n FCursor := FCursor.Left\r\n else\r\n if (FCursor <> nil) and (Index = 0) then\r\n FCursor := FCursor.Right\r\n else\r\n if (FCursor <> nil) and (Index = 1) then\r\n FCursor := FCursor.Right\r\n else\r\n FCursor := nil;\r\n if FCursor <> nil then\r\n Result := FCursor.Value\r\n else\r\n if not FOwnTree.ReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclWideStrBinaryTreeIterator.GetString: WideString;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n CheckValid;\r\n Result := '';\r\n if FCursor <> nil then\r\n Result := FCursor.Value\r\n else\r\n if not FOwnTree.ReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclWideStrBinaryTreeIterator.HasChild(Index: Integer): Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if (FCursor <> nil) and (Index = 0) then\r\n Result := (FCursor.Left <> nil) or (FCursor.Right <> nil)\r\n else\r\n if (FCursor <> nil) and (Index = 1) then\r\n Result := (FCursor.Left <> nil) and (FCursor.Right <> nil)\r\n else\r\n Result := False;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclWideStrBinaryTreeIterator.HasLeft: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := (FCursor <> nil) and (FCursor.Left <> nil);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclWideStrBinaryTreeIterator.HasNext: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Valid then\r\n Result := GetNextCursor <> nil\r\n else\r\n Result := FCursor <> nil;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclWideStrBinaryTreeIterator.HasParent: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := (FCursor <> nil) and (FCursor.Parent <> nil);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclWideStrBinaryTreeIterator.HasPrevious: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Valid then\r\n Result := GetPreviousCursor <> nil\r\n else\r\n Result := FCursor <> nil;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclWideStrBinaryTreeIterator.HasRight: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := (FCursor <> nil) and (FCursor.Right <> nil);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclWideStrBinaryTreeIterator.IndexOfChild(const AString: WideString): Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := -1;\r\n if FCursor <> nil then\r\n begin\r\n if FCursor.Left <> nil then\r\n begin\r\n if FEqualityComparer.ItemsEqual(FCursor.Left.Value, AString) then\r\n Result := 0\r\n else\r\n if (FCursor.Right <> nil) and FEqualityComparer.ItemsEqual(FCursor.Right.Value, AString) then\r\n Result := 1;\r\n end\r\n else\r\n if (FCursor.Right <> nil) and FEqualityComparer.ItemsEqual(FCursor.Right.Value, AString) then\r\n Result := 0;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclWideStrBinaryTreeIterator.Insert(const AString: WideString): Boolean;\r\nbegin\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nfunction TJclWideStrBinaryTreeIterator.InsertChild(Index: Integer; const AString: WideString): Boolean;\r\nbegin\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nfunction TJclWideStrBinaryTreeIterator.IteratorEquals(const AIterator: IJclWideStrIterator): Boolean;\r\nvar\r\n Obj: TObject;\r\n ItrObj: TJclWideStrBinaryTreeIterator;\r\nbegin\r\n Result := False;\r\n if AIterator = nil then\r\n Exit;\r\n Obj := AIterator.GetIteratorReference;\r\n if Obj is TJclWideStrBinaryTreeIterator then\r\n begin\r\n ItrObj := TJclWideStrBinaryTreeIterator(Obj);\r\n Result := (FOwnTree = ItrObj.FOwnTree) and (FCursor = ItrObj.FCursor) and (Valid = ItrObj.Valid);\r\n end;\r\nend;\r\n\r\nfunction TJclWideStrBinaryTreeIterator.Left: WideString;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := '';\r\n if FCursor <> nil then\r\n FCursor := FCursor.Left;\r\n if FCursor <> nil then\r\n Result := FCursor.Value\r\n else\r\n if not FOwnTree.ReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\n{$IFDEF SUPPORTS_FOR_IN}\r\nfunction TJclWideStrBinaryTreeIterator.MoveNext: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Valid then\r\n FCursor := GetNextCursor\r\n else\r\n Valid := True;\r\n Result := FCursor <> nil;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n{$ENDIF SUPPORTS_FOR_IN}\r\n\r\nfunction TJclWideStrBinaryTreeIterator.Next: WideString;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Valid then\r\n FCursor := GetNextCursor\r\n else\r\n Valid := True;\r\n Result := '';\r\n if FCursor <> nil then\r\n Result := FCursor.Value\r\n else\r\n if not FOwnTree.ReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclWideStrBinaryTreeIterator.NextIndex: Integer;\r\nbegin\r\n // No index\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nfunction TJclWideStrBinaryTreeIterator.Parent: WideString;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := '';\r\n if FCursor <> nil then\r\n FCursor := FCursor.Parent;\r\n if FCursor <> nil then\r\n Result := FCursor.Value\r\n else\r\n if not FOwnTree.ReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclWideStrBinaryTreeIterator.Previous: WideString;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Valid then\r\n FCursor := GetPreviousCursor\r\n else\r\n Valid := True;\r\n Result := '';\r\n if FCursor <> nil then\r\n Result := FCursor.Value\r\n else\r\n if not FOwnTree.ReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclWideStrBinaryTreeIterator.PreviousIndex: Integer;\r\nbegin\r\n // No index\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nprocedure TJclWideStrBinaryTreeIterator.Remove;\r\nvar\r\n OldCursor: TJclWideStrBinaryNode;\r\nbegin\r\n if FOwnTree.ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n CheckValid;\r\n Valid := False;\r\n OldCursor := FCursor;\r\n if OldCursor <> nil then\r\n begin\r\n repeat\r\n FCursor := GetNextCursor;\r\n until (FCursor = nil) or FOwnTree.RemoveSingleElement\r\n or (not FEqualityComparer.ItemsEqual(OldCursor.Value, FCursor.Value));\r\n FOwnTree.Remove(OldCursor.Value);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.WriteUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclWideStrBinaryTreeIterator.Reset;\r\nvar\r\n NewCursor: TJclWideStrBinaryNode;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Valid := False;\r\n case FStart of\r\n isFirst:\r\n begin\r\n NewCursor := FCursor;\r\n while NewCursor <> nil do\r\n begin\r\n NewCursor := GetPreviousCursor;\r\n if NewCursor <> nil then\r\n FCursor := NewCursor;\r\n end;\r\n end;\r\n isLast:\r\n begin\r\n NewCursor := FCursor;\r\n while NewCursor <> nil do\r\n begin\r\n NewCursor := GetNextCursor;\r\n if NewCursor <> nil then\r\n FCursor := NewCursor;\r\n end;\r\n end;\r\n isRoot:\r\n begin\r\n while (FCursor <> nil) and (FCursor.Parent <> nil) do\r\n FCursor := FCursor.Parent;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclWideStrBinaryTreeIterator.Right: WideString;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := '';\r\n if FCursor <> nil then\r\n FCursor := FCursor.Right;\r\n if FCursor <> nil then\r\n Result := FCursor.Value\r\n else\r\n if not FOwnTree.ReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclWideStrBinaryTreeIterator.SetChild(Index: Integer; const AString: WideString);\r\nbegin\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nprocedure TJclWideStrBinaryTreeIterator.SetString(const AString: WideString);\r\nbegin\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\n//=== { TJclPreOrderWideStrBinaryTreeIterator } ===================================================\r\n\r\nfunction TJclPreOrderWideStrBinaryTreeIterator.CreateEmptyIterator: TJclAbstractIterator;\r\nbegin\r\n Result := TJclPreOrderWideStrBinaryTreeIterator.Create(FOwnTree, FCursor, Valid, FStart);\r\nend;\r\n\r\nfunction TJclPreOrderWideStrBinaryTreeIterator.GetNextCursor: TJclWideStrBinaryNode;\r\nvar\r\n LastRet: TJclWideStrBinaryNode;\r\nbegin\r\n Result := FCursor;\r\n if Result = nil then\r\n Exit;\r\n LastRet := Result;\r\n if Result.Left <> nil then\r\n Result := Result.Left\r\n else\r\n if Result.Right <> nil then\r\n Result := Result.Right\r\n else\r\n begin\r\n Result := Result.Parent;\r\n while (Result <> nil) and ((Result.Right = nil) or (Result.Right = LastRet)) do\r\n begin\r\n LastRet := Result;\r\n Result := Result.Parent;\r\n end;\r\n if Result <> nil then // not root\r\n Result := Result.Right;\r\n end;\r\nend;\r\n\r\nfunction TJclPreOrderWideStrBinaryTreeIterator.GetPreviousCursor: TJclWideStrBinaryNode;\r\nvar\r\n LastRet: TJclWideStrBinaryNode;\r\nbegin\r\n Result := FCursor;\r\n if Result = nil then\r\n Exit;\r\n LastRet := Result;\r\n Result := Result.Parent;\r\n if (Result <> nil) and (Result.Left <> LastRet) and (Result.Left <> nil) then\r\n // come from Right\r\n begin\r\n Result := Result.Left;\r\n while (Result.Left <> nil) or (Result.Right <> nil) do // both childs\r\n begin\r\n if Result.Right <> nil then // right child first\r\n Result := Result.Right\r\n else\r\n Result := Result.Left;\r\n end;\r\n end;\r\nend;\r\n\r\n//=== { TJclInOrderWideStrBinaryTreeIterator } ====================================================\r\n\r\nfunction TJclInOrderWideStrBinaryTreeIterator.CreateEmptyIterator: TJclAbstractIterator;\r\nbegin\r\n Result := TJclInOrderWideStrBinaryTreeIterator.Create(FOwnTree, FCursor, Valid, FStart);\r\nend;\r\n\r\nfunction TJclInOrderWideStrBinaryTreeIterator.GetNextCursor: TJclWideStrBinaryNode;\r\nvar\r\n LastRet: TJclWideStrBinaryNode;\r\nbegin\r\n Result := FCursor;\r\n if Result = nil then\r\n Exit;\r\n if Result.Right <> nil then\r\n begin\r\n Result := Result.Right;\r\n while (Result.Left <> nil) do\r\n Result := Result.Left;\r\n end\r\n else\r\n begin\r\n LastRet := Result;\r\n Result := Result.Parent;\r\n while (Result <> nil) and (Result.Right = LastRet) do\r\n begin\r\n LastRet := Result;\r\n Result := Result.Parent;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJclInOrderWideStrBinaryTreeIterator.GetPreviousCursor: TJclWideStrBinaryNode;\r\nvar\r\n LastRet: TJclWideStrBinaryNode;\r\nbegin\r\n Result := FCursor;\r\n if Result = nil then\r\n Exit;\r\n if Result.Left <> nil then\r\n begin\r\n Result := Result.Left;\r\n while Result.Right <> nil do\r\n Result := Result.Right;\r\n end\r\n else\r\n begin\r\n LastRet := Result;\r\n Result := Result.Parent;\r\n while (Result <> nil) and (Result.Right <> LastRet) do // Come from Left\r\n begin\r\n LastRet := Result;\r\n Result := Result.Parent;\r\n end;\r\n end;\r\nend;\r\n\r\n//=== { TJclPostOrderWideStrBinaryTreeIterator } ==================================================\r\n\r\nfunction TJclPostOrderWideStrBinaryTreeIterator.CreateEmptyIterator: TJclAbstractIterator;\r\nbegin\r\n Result := TJclPostOrderWideStrBinaryTreeIterator.Create(FOwnTree, FCursor, Valid, FStart);\r\nend;\r\n\r\nfunction TJclPostOrderWideStrBinaryTreeIterator.GetNextCursor: TJclWideStrBinaryNode;\r\nvar\r\n LastRet: TJclWideStrBinaryNode;\r\nbegin\r\n Result := FCursor;\r\n if Result = nil then\r\n Exit;\r\n LastRet := Result;\r\n Result := Result.Parent;\r\n if (Result <> nil) and (Result.Right <> nil) and (Result.Right <> LastRet) then\r\n begin\r\n Result := Result.Right;\r\n while (Result.Left <> nil) or (Result.Right <> nil) do\r\n begin\r\n if Result.Left <> nil then\r\n Result := Result.Left\r\n else\r\n Result := Result.Right;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJclPostOrderWideStrBinaryTreeIterator.GetPreviousCursor: TJclWideStrBinaryNode;\r\nvar\r\n LastRet: TJclWideStrBinaryNode;\r\nbegin\r\n Result := FCursor;\r\n if Result = nil then\r\n Exit;\r\n if Result.Right <> nil then\r\n Result := Result.Right\r\n else\r\n if Result.Left <> nil then\r\n Result := Result.Left\r\n else\r\n begin\r\n LastRet := Result;\r\n Result := Result.Parent;\r\n while (Result <> nil) and ((Result.Left = nil) or (Result.Left = LastRet)) do\r\n begin\r\n LastRet := Result;\r\n Result := Result.Parent;\r\n end;\r\n if Result <> nil then // not root\r\n Result := Result.Left;\r\n end;\r\nend;\r\n\r\n{$IFDEF SUPPORTS_UNICODE_STRING}\r\n//=== { TJclUnicodeStrBinaryTree } =================================================\r\n\r\nconstructor TJclUnicodeStrBinaryTree.Create(ACompare: TUnicodeStrCompare);\r\nbegin\r\n inherited Create();\r\n FTraverseOrder := toOrder;\r\n FMaxDepth := 0;\r\n FAutoPackParameter := 2;\r\n SetCompare(ACompare);\r\nend;\r\n\r\ndestructor TJclUnicodeStrBinaryTree.Destroy;\r\nbegin\r\n FReadOnly := False;\r\n Clear;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJclUnicodeStrBinaryTree.Add(const AString: UnicodeString): Boolean;\r\nvar\r\n NewNode, Current, Save: TJclUnicodeStrBinaryNode;\r\n Comp, Depth: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n // Insert into right place\r\n if FAllowDefaultElements or not ItemsEqual(AString, '') then\r\n begin\r\n Save := nil;\r\n Current := FRoot;\r\n Comp := 1;\r\n Depth := 0;\r\n while Current <> nil do\r\n begin\r\n Inc(Depth);\r\n Save := Current;\r\n Comp := ItemsCompare(AString, Current.Value);\r\n if Comp < 0 then\r\n Current := Current.Left\r\n else\r\n if Comp > 0 then\r\n Current := Current.Right\r\n else\r\n if CheckDuplicate then\r\n Current := Current.Left // arbitrary decision\r\n else\r\n Break;\r\n end;\r\n if (Comp <> 0) or CheckDuplicate then\r\n begin\r\n NewNode := TJclUnicodeStrBinaryNode.Create;\r\n NewNode.Value := AString;\r\n NewNode.Parent := Save;\r\n if Save = nil then\r\n FRoot := NewNode\r\n else\r\n if ItemsCompare(NewNode.Value, Save.Value) <= 0 then\r\n Save.Left := NewNode\r\n else\r\n Save.Right := NewNode;\r\n Inc(FSize);\r\n Inc(Depth);\r\n if Depth > FMaxDepth then\r\n FMaxDepth := Depth;\r\n Result := True;\r\n AutoPack;\r\n end\r\n else\r\n Result := False;\r\n end\r\n else\r\n Result := False;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclUnicodeStrBinaryTree.AddAll(const ACollection: IJclUnicodeStrCollection): Boolean;\r\nvar\r\n It: IJclUnicodeStrIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n Result := Add(It.Next) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclUnicodeStrBinaryTree.AssignDataTo(Dest: TJclAbstractContainerBase);\r\nvar\r\n ADest: TJclUnicodeStrBinaryTree;\r\n ACollection: IJclUnicodeStrCollection;\r\nbegin\r\n inherited AssignDataTo(Dest);\r\n if Dest is TJclUnicodeStrBinaryTree then\r\n begin\r\n ADest := TJclUnicodeStrBinaryTree(Dest);\r\n ADest.Clear;\r\n ADest.FSize := FSize;\r\n if FRoot <> nil then\r\n ADest.FRoot := CloneNode(FRoot, nil);\r\n end\r\n else\r\n if Supports(IInterface(Dest), IJclUnicodeStrCollection, ACollection) then\r\n begin\r\n ACollection.Clear;\r\n ACollection.AddAll(Self);\r\n end;\r\nend;\r\n\r\nprocedure TJclUnicodeStrBinaryTree.AssignPropertiesTo(Dest: TJclAbstractContainerBase);\r\nbegin\r\n inherited AssignPropertiesto(Dest);\r\n if Dest is TJclUnicodeStrBinaryTree then\r\n TJclUnicodeStrBinaryTree(Dest).FTraverseOrder := FTraverseOrder;\r\nend;\r\n\r\nprocedure TJclUnicodeStrBinaryTree.AutoPack;\r\nbegin\r\n case FAutoPackStrategy of\r\n //apsDisabled: ;\r\n apsAgressive:\r\n if (FMaxDepth > 1) and (((1 shl (FMaxDepth - 1)) - 1) > FSize) then\r\n Pack;\r\n // apsIncremental: ;\r\n apsProportional:\r\n if (FMaxDepth > FAutoPackParameter) and (((1 shl (FMaxDepth - FAutoPackParameter)) - 1) > FSize) then\r\n Pack;\r\n end;\r\nend;\r\n\r\nfunction TJclUnicodeStrBinaryTree.BuildTree(const LeafArray: array of TJclUnicodeStrBinaryNode; Left, Right: Integer; Parent: TJclUnicodeStrBinaryNode;\r\n Offset: Integer): TJclUnicodeStrBinaryNode;\r\nvar\r\n Middle: Integer;\r\nbegin\r\n Middle := (Left + Right + Offset) shr 1;\r\n Result := LeafArray[Middle];\r\n Result.Parent := Parent;\r\n if Middle > Left then\r\n Result.Left := BuildTree(LeafArray, Left, Middle - 1, Result, 0)\r\n else\r\n Result.Left := nil;\r\n if Middle < Right then\r\n Result.Right := BuildTree(LeafArray, Middle + 1, Right, Result, 1)\r\n else\r\n Result.Right := nil;\r\nend;\r\n\r\nprocedure TJclUnicodeStrBinaryTree.Clear;\r\nvar\r\n Current, Parent: TJclUnicodeStrBinaryNode;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n // postorder\r\n Current := FRoot;\r\n if Current = nil then\r\n Exit;\r\n // find first in post-order\r\n while (Current.Left <> nil) or (Current.Right <> nil) do\r\n begin\r\n if Current.Left <> nil then\r\n Current := Current.Left\r\n else\r\n Current := Current.Right;\r\n end;\r\n // for all items in the tree in post-order\r\n repeat\r\n Parent := Current.Parent;\r\n // remove reference\r\n if Parent <> nil then\r\n begin\r\n if Parent.Left = Current then\r\n Parent.Left := nil\r\n else\r\n if Parent.Right = Current then\r\n Parent.Right := nil;\r\n end;\r\n\r\n // free item\r\n FreeString(Current.Value);\r\n Current.Free;\r\n\r\n // find next item\r\n Current := Parent;\r\n if (Current <> nil) and (Current.Right <> nil) then\r\n begin\r\n Current := Current.Right;\r\n while (Current.Left <> nil) or (Current.Right <> nil) do\r\n begin\r\n if Current.Left <> nil then\r\n Current := Current.Left\r\n else\r\n Current := Current.Right;\r\n end;\r\n end;\r\n until Current = nil;\r\n FRoot := nil;\r\n FSize := 0;\r\n FMaxDepth := 0;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclUnicodeStrBinaryTree.CloneNode(Node, Parent: TJclUnicodeStrBinaryNode): TJclUnicodeStrBinaryNode;\r\nbegin\r\n Result := TJclUnicodeStrBinaryNode.Create;\r\n Result.Value := Node.Value;\r\n Result.Parent := Parent;\r\n if Node.Left <> nil then\r\n Result.Left := CloneNode(Node.Left, Result); // recursive call\r\n if Node.Right <> nil then\r\n Result.Right := CloneNode(Node.Right, Result); // recursive call\r\nend;\r\n\r\nfunction TJclUnicodeStrBinaryTree.CollectionEquals(const ACollection: IJclUnicodeStrCollection): Boolean;\r\nvar\r\n It, ItSelf: IJclUnicodeStrIterator;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n if FSize <> ACollection.Size then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n ItSelf := First;\r\n while ItSelf.HasNext do\r\n if not ItemsEqual(ItSelf.Next, It.Next) then\r\n begin\r\n Result := False;\r\n Break;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclUnicodeStrBinaryTree.Contains(const AString: UnicodeString): Boolean;\r\nvar\r\n Comp: Integer;\r\n Current: TJclUnicodeStrBinaryNode;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n Current := FRoot;\r\n while Current <> nil do\r\n begin\r\n Comp := ItemsCompare(Current.Value, AString);\r\n if Comp = 0 then\r\n begin\r\n Result := True;\r\n Break;\r\n end\r\n else\r\n if Comp > 0 then\r\n Current := Current.Left\r\n else\r\n Current := Current.Right;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclUnicodeStrBinaryTree.ContainsAll(const ACollection: IJclUnicodeStrCollection): Boolean;\r\nvar\r\n It: IJclUnicodeStrIterator;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := True;\r\n if ACollection = nil then\r\n Exit;\r\n It := ACollection.First;\r\n while Result and It.HasNext do\r\n Result := Contains(It.Next);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclUnicodeStrBinaryTree.Extract(const AString: UnicodeString): Boolean;\r\nvar\r\n Current, Successor: TJclUnicodeStrBinaryNode;\r\n Comp: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n // locate AString in the tree\r\n Current := FRoot;\r\n repeat\r\n while Current <> nil do\r\n begin\r\n Comp := ItemsCompare(AString, Current.Value);\r\n if Comp = 0 then\r\n Break\r\n else\r\n if Comp < 0 then\r\n Current := Current.Left\r\n else\r\n Current := Current.Right;\r\n end;\r\n if Current = nil then\r\n Break;\r\n Result := True;\r\n // Remove Current from tree\r\n if (Current.Left = nil) and (Current.Right <> nil) then\r\n begin\r\n // remove references to Current\r\n Current.Right.Parent := Current.Parent;\r\n if Current.Parent <> nil then\r\n begin\r\n if Current.Parent.Left = Current then\r\n Current.Parent.Left := Current.Right\r\n else\r\n Current.Parent.Right := Current.Right;\r\n end\r\n else\r\n // fix root\r\n FRoot := Current.Right;\r\n Successor := Current.Parent;\r\n if Successor = nil then\r\n Successor := FRoot;\r\n end\r\n else\r\n if (Current.Left <> nil) and (Current.Right = nil) then\r\n begin\r\n // remove references to Current\r\n Current.Left.Parent := Current.Parent;\r\n if Current.Parent <> nil then\r\n begin\r\n if Current.Parent.Left = Current then\r\n Current.Parent.Left := Current.Left\r\n else\r\n Current.Parent.Right := Current.Left;\r\n end\r\n else\r\n // fix root\r\n FRoot := Current.Left;\r\n Successor := Current.Parent;\r\n if Successor = nil then\r\n Successor := FRoot;\r\n end\r\n else\r\n if (Current.Left <> nil) and (Current.Right <> nil) then\r\n begin\r\n // find the successor in tree\r\n Successor := Current.Right;\r\n while Successor.Left <> nil do\r\n Successor := Successor.Left;\r\n\r\n if Successor <> Current.Right then\r\n begin\r\n // remove references to successor\r\n Successor.Parent.Left := Successor.Right;\r\n if Successor.Right <> nil then\r\n Successor.Right.Parent := Successor.Parent;\r\n Successor.Right := Current.Right;\r\n if Successor.Right <> nil then\r\n Successor.Right.Parent := Successor;\r\n end;\r\n\r\n // insert successor in new position\r\n Successor.Left := Current.Left;\r\n if Current.Left <> nil then\r\n Current.Left.Parent := Successor;\r\n Successor.Parent := Current.Parent;\r\n if Current.Parent <> nil then\r\n begin\r\n if Current.Parent.Left = Current then\r\n Current.Parent.Left := Successor\r\n else\r\n Current.Parent.Right := Successor;\r\n end\r\n else\r\n // fix root\r\n FRoot := Successor;\r\n Successor := Current.Parent;\r\n if Successor <> nil then\r\n Successor := FRoot;\r\n end\r\n else\r\n begin\r\n // (Current.Left = nil) and (Current.Right = nil)\r\n Successor := Current.Parent;\r\n if Successor <> nil then\r\n begin\r\n // remove references from parent\r\n if Successor.Left = Current then\r\n Successor.Left := nil\r\n else\r\n Successor.Right := nil;\r\n end\r\n else\r\n FRoot := nil;\r\n end;\r\n Current.Value := '';\r\n Current.Free;\r\n Dec(FSize);\r\n Current := Successor;\r\n until FRemoveSingleElement or (Current = nil);\r\n AutoPack;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclUnicodeStrBinaryTree.ExtractAll(const ACollection: IJclUnicodeStrCollection): Boolean;\r\nvar\r\n It: IJclUnicodeStrIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n Result := Extract(It.Next) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclUnicodeStrBinaryTree.First: IJclUnicodeStrIterator;\r\nvar\r\n Start: TJclUnicodeStrBinaryNode;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Start := FRoot;\r\n case GetTraverseOrder of\r\n toPreOrder:\r\n Result := TJclPreOrderUnicodeStrBinaryTreeIterator.Create(Self, Start, False, isFirst);\r\n toOrder:\r\n begin\r\n if Start <> nil then\r\n while Start.Left <> nil do\r\n Start := Start.Left;\r\n Result := TJclInOrderUnicodeStrBinaryTreeIterator.Create(Self, Start, False, isFirst);\r\n end;\r\n toPostOrder:\r\n begin\r\n if Start <> nil then\r\n while (Start.Left <> nil) or (Start.Right <> nil) do\r\n begin\r\n if Start.Left <> nil then\r\n Start := Start.Left\r\n else\r\n Start := Start.Right;\r\n end;\r\n Result := TJclPostOrderUnicodeStrBinaryTreeIterator.Create(Self, Start, False, isFirst);\r\n end;\r\n else\r\n Result := nil;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\n{$IFDEF SUPPORTS_FOR_IN}\r\nfunction TJclUnicodeStrBinaryTree.GetEnumerator: IJclUnicodeStrIterator;\r\nbegin\r\n Result := First;\r\nend;\r\n{$ENDIF SUPPORTS_FOR_IN}\r\n\r\nfunction TJclUnicodeStrBinaryTree.GetRoot: IJclUnicodeStrTreeIterator;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n case GetTraverseOrder of\r\n toPreOrder:\r\n Result := TJclPreOrderUnicodeStrBinaryTreeIterator.Create(Self, FRoot, False, isRoot);\r\n toOrder:\r\n Result := TJclInOrderUnicodeStrBinaryTreeIterator.Create(Self, FRoot, False, isRoot);\r\n toPostOrder:\r\n Result := TJclPostOrderUnicodeStrBinaryTreeIterator.Create(Self, FRoot, False, isRoot);\r\n else\r\n Result := nil;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclUnicodeStrBinaryTree.GetTraverseOrder: TJclTraverseOrder;\r\nbegin\r\n Result := FTraverseOrder;\r\nend;\r\n\r\nfunction TJclUnicodeStrBinaryTree.IsEmpty: Boolean;\r\nbegin\r\n Result := FSize = 0;\r\nend;\r\n\r\nfunction TJclUnicodeStrBinaryTree.Last: IJclUnicodeStrIterator;\r\nvar\r\n Start: TJclUnicodeStrBinaryNode;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Start := FRoot;\r\n case FTraverseOrder of\r\n toPreOrder:\r\n begin\r\n if Start <> nil then\r\n while (Start.Left <> nil) or (Start.Right <> nil) do\r\n begin\r\n if Start.Right <> nil then\r\n Start := Start.Right\r\n else\r\n Start := Start.Left;\r\n end;\r\n Result := TJclPreOrderUnicodeStrBinaryTreeIterator.Create(Self, Start, False, isLast);\r\n end;\r\n toOrder:\r\n begin\r\n if Start <> nil then\r\n while Start.Right <> nil do\r\n Start := Start.Right;\r\n Result := TJclInOrderUnicodeStrBinaryTreeIterator.Create(Self, Start, False, isLast);\r\n end;\r\n toPostOrder:\r\n Result := TJclPostOrderUnicodeStrBinaryTreeIterator.Create(Self, Start, False, isLast);\r\n else\r\n Result := nil;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclUnicodeStrBinaryTree.Pack;\r\nvar\r\n LeafArray: array of TJclUnicodeStrBinaryNode;\r\n ANode, BNode: TJclUnicodeStrBinaryNode;\r\n Index: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n SetLength(Leafarray, FSize);\r\n try\r\n // in order enumeration of nodes\r\n ANode := FRoot;\r\n if ANode <> nil then\r\n begin\r\n // find first node\r\n while ANode.Left <> nil do\r\n ANode := ANode.Left;\r\n\r\n Index := 0;\r\n while ANode <> nil do\r\n begin\r\n LeafArray[Index] := ANode;\r\n Inc(Index);\r\n if ANode.Right <> nil then\r\n begin\r\n ANode := ANode.Right;\r\n while (ANode.Left <> nil) do\r\n ANode := ANode.Left;\r\n end\r\n else\r\n begin\r\n BNode := ANode;\r\n ANode := ANode.Parent;\r\n while (ANode <> nil) and (ANode.Right = BNode) do\r\n begin\r\n BNode := ANode;\r\n ANode := ANode.Parent;\r\n end;\r\n end;\r\n end;\r\n\r\n Index := FSize shr 1;\r\n FRoot := LeafArray[Index];\r\n FRoot.Parent := nil;\r\n if Index > 0 then\r\n FRoot.Left := BuildTree(LeafArray, 0, Index - 1, FRoot, 0)\r\n else\r\n FRoot.Left := nil;\r\n if Index < (FSize - 1) then\r\n FRoot.Right := BuildTree(LeafArray, Index + 1, FSize - 1, FRoot, 1)\r\n else\r\n FRoot.Right := nil;\r\n end;\r\n finally\r\n SetLength(LeafArray, 0);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclUnicodeStrBinaryTree.Remove(const AString: UnicodeString): Boolean;\r\nvar\r\n Extracted: UnicodeString;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := Extract(AString);\r\n if Result then\r\n begin\r\n Extracted := AString;\r\n FreeString(Extracted);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclUnicodeStrBinaryTree.RemoveAll(const ACollection: IJclUnicodeStrCollection): Boolean;\r\nvar\r\n It: IJclUnicodeStrIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n Result := Remove(It.Next) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclUnicodeStrBinaryTree.RetainAll(const ACollection: IJclUnicodeStrCollection): Boolean;\r\nvar\r\n It: IJclUnicodeStrIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := First;\r\n while It.HasNext do\r\n if not ACollection.Contains(It.Next) then\r\n It.Remove;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclUnicodeStrBinaryTree.SetCapacity(Value: Integer);\r\nbegin\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nprocedure TJclUnicodeStrBinaryTree.SetTraverseOrder(Value: TJclTraverseOrder);\r\nbegin\r\n FTraverseOrder := Value;\r\nend;\r\n\r\nfunction TJclUnicodeStrBinaryTree.Size: Integer;\r\nbegin\r\n Result := FSize;\r\nend;\r\n\r\nfunction TJclUnicodeStrBinaryTree.CreateEmptyContainer: TJclAbstractContainerBase;\r\nbegin\r\n Result := TJclUnicodeStrBinaryTree.Create(Compare);\r\n AssignPropertiesTo(Result);\r\nend;\r\n\r\n{$ENDIF SUPPORTS_UNICODE_STRING}\r\n\r\n{$IFDEF SUPPORTS_UNICODE_STRING}\r\n//=== { TJclUnicodeStrBinaryTreeIterator } ===========================================================\r\n\r\nconstructor TJclUnicodeStrBinaryTreeIterator.Create(const AOwnTree: IJclUnicodeStrCollection; ACursor: TJclUnicodeStrBinaryNode; AValid: Boolean; AStart: TItrStart);\r\nbegin\r\n inherited Create(AValid);\r\n FCursor := ACursor;\r\n FStart := AStart;\r\n FOwnTree := AOwnTree;\r\n FEqualityComparer := AOwnTree as IJclUnicodeStrEqualityComparer;\r\nend;\r\n\r\nfunction TJclUnicodeStrBinaryTreeIterator.Add(const AString: UnicodeString): Boolean;\r\nbegin\r\n Result := FOwnTree.Add(AString);\r\nend;\r\n\r\nfunction TJclUnicodeStrBinaryTreeIterator.AddChild(const AString: UnicodeString): Boolean;\r\nbegin\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nprocedure TJclUnicodeStrBinaryTreeIterator.AssignPropertiesTo(Dest: TJclAbstractIterator);\r\nvar\r\n ADest: TJclUnicodeStrBinaryTreeIterator;\r\nbegin\r\n inherited AssignPropertiesTo(Dest);\r\n if Dest is TJclUnicodeStrBinaryTreeIterator then\r\n begin\r\n ADest := TJclUnicodeStrBinaryTreeIterator(Dest);\r\n ADest.FCursor := FCursor;\r\n ADest.FOwnTree := FOwnTree;\r\n ADest.FEqualityComparer := FEqualityComparer;\r\n ADest.FStart := FStart;\r\n end;\r\nend;\r\n\r\nfunction TJclUnicodeStrBinaryTreeIterator.ChildrenCount: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := 0;\r\n if FCursor <> nil then\r\n begin\r\n if FCursor.Left <> nil then\r\n Inc(Result);\r\n if FCursor.Right <> nil then\r\n Inc(Result);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclUnicodeStrBinaryTreeIterator.DeleteChild(Index: Integer);\r\nbegin\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nprocedure TJclUnicodeStrBinaryTreeIterator.DeleteChildren;\r\nbegin\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nprocedure TJclUnicodeStrBinaryTreeIterator.Extract;\r\nvar\r\n OldCursor: TJclUnicodeStrBinaryNode;\r\nbegin\r\n if FOwnTree.ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n CheckValid;\r\n Valid := False;\r\n OldCursor := FCursor;\r\n if OldCursor <> nil then\r\n begin\r\n repeat\r\n FCursor := GetNextCursor;\r\n until (FCursor = nil) or FOwnTree.RemoveSingleElement\r\n or (not FEqualityComparer.ItemsEqual(OldCursor.Value, FCursor.Value));\r\n FOwnTree.Extract(OldCursor.Value);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.WriteUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclUnicodeStrBinaryTreeIterator.ExtractChild(Index: Integer);\r\nbegin\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nprocedure TJclUnicodeStrBinaryTreeIterator.ExtractChildren;\r\nbegin\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nfunction TJclUnicodeStrBinaryTreeIterator.GetChild(Index: Integer): UnicodeString;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := '';\r\n if (FCursor <> nil) and (Index = 0) and (FCursor.Left <> nil) then\r\n FCursor := FCursor.Left\r\n else\r\n if (FCursor <> nil) and (Index = 0) then\r\n FCursor := FCursor.Right\r\n else\r\n if (FCursor <> nil) and (Index = 1) then\r\n FCursor := FCursor.Right\r\n else\r\n FCursor := nil;\r\n if FCursor <> nil then\r\n Result := FCursor.Value\r\n else\r\n if not FOwnTree.ReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclUnicodeStrBinaryTreeIterator.GetString: UnicodeString;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n CheckValid;\r\n Result := '';\r\n if FCursor <> nil then\r\n Result := FCursor.Value\r\n else\r\n if not FOwnTree.ReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclUnicodeStrBinaryTreeIterator.HasChild(Index: Integer): Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if (FCursor <> nil) and (Index = 0) then\r\n Result := (FCursor.Left <> nil) or (FCursor.Right <> nil)\r\n else\r\n if (FCursor <> nil) and (Index = 1) then\r\n Result := (FCursor.Left <> nil) and (FCursor.Right <> nil)\r\n else\r\n Result := False;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclUnicodeStrBinaryTreeIterator.HasLeft: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := (FCursor <> nil) and (FCursor.Left <> nil);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclUnicodeStrBinaryTreeIterator.HasNext: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Valid then\r\n Result := GetNextCursor <> nil\r\n else\r\n Result := FCursor <> nil;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclUnicodeStrBinaryTreeIterator.HasParent: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := (FCursor <> nil) and (FCursor.Parent <> nil);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclUnicodeStrBinaryTreeIterator.HasPrevious: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Valid then\r\n Result := GetPreviousCursor <> nil\r\n else\r\n Result := FCursor <> nil;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclUnicodeStrBinaryTreeIterator.HasRight: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := (FCursor <> nil) and (FCursor.Right <> nil);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclUnicodeStrBinaryTreeIterator.IndexOfChild(const AString: UnicodeString): Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := -1;\r\n if FCursor <> nil then\r\n begin\r\n if FCursor.Left <> nil then\r\n begin\r\n if FEqualityComparer.ItemsEqual(FCursor.Left.Value, AString) then\r\n Result := 0\r\n else\r\n if (FCursor.Right <> nil) and FEqualityComparer.ItemsEqual(FCursor.Right.Value, AString) then\r\n Result := 1;\r\n end\r\n else\r\n if (FCursor.Right <> nil) and FEqualityComparer.ItemsEqual(FCursor.Right.Value, AString) then\r\n Result := 0;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclUnicodeStrBinaryTreeIterator.Insert(const AString: UnicodeString): Boolean;\r\nbegin\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nfunction TJclUnicodeStrBinaryTreeIterator.InsertChild(Index: Integer; const AString: UnicodeString): Boolean;\r\nbegin\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nfunction TJclUnicodeStrBinaryTreeIterator.IteratorEquals(const AIterator: IJclUnicodeStrIterator): Boolean;\r\nvar\r\n Obj: TObject;\r\n ItrObj: TJclUnicodeStrBinaryTreeIterator;\r\nbegin\r\n Result := False;\r\n if AIterator = nil then\r\n Exit;\r\n Obj := AIterator.GetIteratorReference;\r\n if Obj is TJclUnicodeStrBinaryTreeIterator then\r\n begin\r\n ItrObj := TJclUnicodeStrBinaryTreeIterator(Obj);\r\n Result := (FOwnTree = ItrObj.FOwnTree) and (FCursor = ItrObj.FCursor) and (Valid = ItrObj.Valid);\r\n end;\r\nend;\r\n\r\nfunction TJclUnicodeStrBinaryTreeIterator.Left: UnicodeString;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := '';\r\n if FCursor <> nil then\r\n FCursor := FCursor.Left;\r\n if FCursor <> nil then\r\n Result := FCursor.Value\r\n else\r\n if not FOwnTree.ReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\n{$IFDEF SUPPORTS_FOR_IN}\r\nfunction TJclUnicodeStrBinaryTreeIterator.MoveNext: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Valid then\r\n FCursor := GetNextCursor\r\n else\r\n Valid := True;\r\n Result := FCursor <> nil;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n{$ENDIF SUPPORTS_FOR_IN}\r\n\r\nfunction TJclUnicodeStrBinaryTreeIterator.Next: UnicodeString;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Valid then\r\n FCursor := GetNextCursor\r\n else\r\n Valid := True;\r\n Result := '';\r\n if FCursor <> nil then\r\n Result := FCursor.Value\r\n else\r\n if not FOwnTree.ReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclUnicodeStrBinaryTreeIterator.NextIndex: Integer;\r\nbegin\r\n // No index\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nfunction TJclUnicodeStrBinaryTreeIterator.Parent: UnicodeString;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := '';\r\n if FCursor <> nil then\r\n FCursor := FCursor.Parent;\r\n if FCursor <> nil then\r\n Result := FCursor.Value\r\n else\r\n if not FOwnTree.ReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclUnicodeStrBinaryTreeIterator.Previous: UnicodeString;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Valid then\r\n FCursor := GetPreviousCursor\r\n else\r\n Valid := True;\r\n Result := '';\r\n if FCursor <> nil then\r\n Result := FCursor.Value\r\n else\r\n if not FOwnTree.ReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclUnicodeStrBinaryTreeIterator.PreviousIndex: Integer;\r\nbegin\r\n // No index\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nprocedure TJclUnicodeStrBinaryTreeIterator.Remove;\r\nvar\r\n OldCursor: TJclUnicodeStrBinaryNode;\r\nbegin\r\n if FOwnTree.ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n CheckValid;\r\n Valid := False;\r\n OldCursor := FCursor;\r\n if OldCursor <> nil then\r\n begin\r\n repeat\r\n FCursor := GetNextCursor;\r\n until (FCursor = nil) or FOwnTree.RemoveSingleElement\r\n or (not FEqualityComparer.ItemsEqual(OldCursor.Value, FCursor.Value));\r\n FOwnTree.Remove(OldCursor.Value);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.WriteUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclUnicodeStrBinaryTreeIterator.Reset;\r\nvar\r\n NewCursor: TJclUnicodeStrBinaryNode;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Valid := False;\r\n case FStart of\r\n isFirst:\r\n begin\r\n NewCursor := FCursor;\r\n while NewCursor <> nil do\r\n begin\r\n NewCursor := GetPreviousCursor;\r\n if NewCursor <> nil then\r\n FCursor := NewCursor;\r\n end;\r\n end;\r\n isLast:\r\n begin\r\n NewCursor := FCursor;\r\n while NewCursor <> nil do\r\n begin\r\n NewCursor := GetNextCursor;\r\n if NewCursor <> nil then\r\n FCursor := NewCursor;\r\n end;\r\n end;\r\n isRoot:\r\n begin\r\n while (FCursor <> nil) and (FCursor.Parent <> nil) do\r\n FCursor := FCursor.Parent;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclUnicodeStrBinaryTreeIterator.Right: UnicodeString;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := '';\r\n if FCursor <> nil then\r\n FCursor := FCursor.Right;\r\n if FCursor <> nil then\r\n Result := FCursor.Value\r\n else\r\n if not FOwnTree.ReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclUnicodeStrBinaryTreeIterator.SetChild(Index: Integer; const AString: UnicodeString);\r\nbegin\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nprocedure TJclUnicodeStrBinaryTreeIterator.SetString(const AString: UnicodeString);\r\nbegin\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\n//=== { TJclPreOrderUnicodeStrBinaryTreeIterator } ===================================================\r\n\r\nfunction TJclPreOrderUnicodeStrBinaryTreeIterator.CreateEmptyIterator: TJclAbstractIterator;\r\nbegin\r\n Result := TJclPreOrderUnicodeStrBinaryTreeIterator.Create(FOwnTree, FCursor, Valid, FStart);\r\nend;\r\n\r\nfunction TJclPreOrderUnicodeStrBinaryTreeIterator.GetNextCursor: TJclUnicodeStrBinaryNode;\r\nvar\r\n LastRet: TJclUnicodeStrBinaryNode;\r\nbegin\r\n Result := FCursor;\r\n if Result = nil then\r\n Exit;\r\n LastRet := Result;\r\n if Result.Left <> nil then\r\n Result := Result.Left\r\n else\r\n if Result.Right <> nil then\r\n Result := Result.Right\r\n else\r\n begin\r\n Result := Result.Parent;\r\n while (Result <> nil) and ((Result.Right = nil) or (Result.Right = LastRet)) do\r\n begin\r\n LastRet := Result;\r\n Result := Result.Parent;\r\n end;\r\n if Result <> nil then // not root\r\n Result := Result.Right;\r\n end;\r\nend;\r\n\r\nfunction TJclPreOrderUnicodeStrBinaryTreeIterator.GetPreviousCursor: TJclUnicodeStrBinaryNode;\r\nvar\r\n LastRet: TJclUnicodeStrBinaryNode;\r\nbegin\r\n Result := FCursor;\r\n if Result = nil then\r\n Exit;\r\n LastRet := Result;\r\n Result := Result.Parent;\r\n if (Result <> nil) and (Result.Left <> LastRet) and (Result.Left <> nil) then\r\n // come from Right\r\n begin\r\n Result := Result.Left;\r\n while (Result.Left <> nil) or (Result.Right <> nil) do // both childs\r\n begin\r\n if Result.Right <> nil then // right child first\r\n Result := Result.Right\r\n else\r\n Result := Result.Left;\r\n end;\r\n end;\r\nend;\r\n\r\n//=== { TJclInOrderUnicodeStrBinaryTreeIterator } ====================================================\r\n\r\nfunction TJclInOrderUnicodeStrBinaryTreeIterator.CreateEmptyIterator: TJclAbstractIterator;\r\nbegin\r\n Result := TJclInOrderUnicodeStrBinaryTreeIterator.Create(FOwnTree, FCursor, Valid, FStart);\r\nend;\r\n\r\nfunction TJclInOrderUnicodeStrBinaryTreeIterator.GetNextCursor: TJclUnicodeStrBinaryNode;\r\nvar\r\n LastRet: TJclUnicodeStrBinaryNode;\r\nbegin\r\n Result := FCursor;\r\n if Result = nil then\r\n Exit;\r\n if Result.Right <> nil then\r\n begin\r\n Result := Result.Right;\r\n while (Result.Left <> nil) do\r\n Result := Result.Left;\r\n end\r\n else\r\n begin\r\n LastRet := Result;\r\n Result := Result.Parent;\r\n while (Result <> nil) and (Result.Right = LastRet) do\r\n begin\r\n LastRet := Result;\r\n Result := Result.Parent;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJclInOrderUnicodeStrBinaryTreeIterator.GetPreviousCursor: TJclUnicodeStrBinaryNode;\r\nvar\r\n LastRet: TJclUnicodeStrBinaryNode;\r\nbegin\r\n Result := FCursor;\r\n if Result = nil then\r\n Exit;\r\n if Result.Left <> nil then\r\n begin\r\n Result := Result.Left;\r\n while Result.Right <> nil do\r\n Result := Result.Right;\r\n end\r\n else\r\n begin\r\n LastRet := Result;\r\n Result := Result.Parent;\r\n while (Result <> nil) and (Result.Right <> LastRet) do // Come from Left\r\n begin\r\n LastRet := Result;\r\n Result := Result.Parent;\r\n end;\r\n end;\r\nend;\r\n\r\n//=== { TJclPostOrderUnicodeStrBinaryTreeIterator } ==================================================\r\n\r\nfunction TJclPostOrderUnicodeStrBinaryTreeIterator.CreateEmptyIterator: TJclAbstractIterator;\r\nbegin\r\n Result := TJclPostOrderUnicodeStrBinaryTreeIterator.Create(FOwnTree, FCursor, Valid, FStart);\r\nend;\r\n\r\nfunction TJclPostOrderUnicodeStrBinaryTreeIterator.GetNextCursor: TJclUnicodeStrBinaryNode;\r\nvar\r\n LastRet: TJclUnicodeStrBinaryNode;\r\nbegin\r\n Result := FCursor;\r\n if Result = nil then\r\n Exit;\r\n LastRet := Result;\r\n Result := Result.Parent;\r\n if (Result <> nil) and (Result.Right <> nil) and (Result.Right <> LastRet) then\r\n begin\r\n Result := Result.Right;\r\n while (Result.Left <> nil) or (Result.Right <> nil) do\r\n begin\r\n if Result.Left <> nil then\r\n Result := Result.Left\r\n else\r\n Result := Result.Right;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJclPostOrderUnicodeStrBinaryTreeIterator.GetPreviousCursor: TJclUnicodeStrBinaryNode;\r\nvar\r\n LastRet: TJclUnicodeStrBinaryNode;\r\nbegin\r\n Result := FCursor;\r\n if Result = nil then\r\n Exit;\r\n if Result.Right <> nil then\r\n Result := Result.Right\r\n else\r\n if Result.Left <> nil then\r\n Result := Result.Left\r\n else\r\n begin\r\n LastRet := Result;\r\n Result := Result.Parent;\r\n while (Result <> nil) and ((Result.Left = nil) or (Result.Left = LastRet)) do\r\n begin\r\n LastRet := Result;\r\n Result := Result.Parent;\r\n end;\r\n if Result <> nil then // not root\r\n Result := Result.Left;\r\n end;\r\nend;\r\n{$ENDIF SUPPORTS_UNICODE_STRING}\r\n\r\n//=== { TJclSingleBinaryTree } =================================================\r\n\r\nconstructor TJclSingleBinaryTree.Create(ACompare: TSingleCompare);\r\nbegin\r\n inherited Create();\r\n FTraverseOrder := toOrder;\r\n FMaxDepth := 0;\r\n FAutoPackParameter := 2;\r\n SetCompare(ACompare);\r\nend;\r\n\r\ndestructor TJclSingleBinaryTree.Destroy;\r\nbegin\r\n FReadOnly := False;\r\n Clear;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJclSingleBinaryTree.Add(const AValue: Single): Boolean;\r\nvar\r\n NewNode, Current, Save: TJclSingleBinaryNode;\r\n Comp, Depth: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n // Insert into right place\r\n if FAllowDefaultElements or not ItemsEqual(AValue, 0.0) then\r\n begin\r\n Save := nil;\r\n Current := FRoot;\r\n Comp := 1;\r\n Depth := 0;\r\n while Current <> nil do\r\n begin\r\n Inc(Depth);\r\n Save := Current;\r\n Comp := ItemsCompare(AValue, Current.Value);\r\n if Comp < 0 then\r\n Current := Current.Left\r\n else\r\n if Comp > 0 then\r\n Current := Current.Right\r\n else\r\n if CheckDuplicate then\r\n Current := Current.Left // arbitrary decision\r\n else\r\n Break;\r\n end;\r\n if (Comp <> 0) or CheckDuplicate then\r\n begin\r\n NewNode := TJclSingleBinaryNode.Create;\r\n NewNode.Value := AValue;\r\n NewNode.Parent := Save;\r\n if Save = nil then\r\n FRoot := NewNode\r\n else\r\n if ItemsCompare(NewNode.Value, Save.Value) <= 0 then\r\n Save.Left := NewNode\r\n else\r\n Save.Right := NewNode;\r\n Inc(FSize);\r\n Inc(Depth);\r\n if Depth > FMaxDepth then\r\n FMaxDepth := Depth;\r\n Result := True;\r\n AutoPack;\r\n end\r\n else\r\n Result := False;\r\n end\r\n else\r\n Result := False;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSingleBinaryTree.AddAll(const ACollection: IJclSingleCollection): Boolean;\r\nvar\r\n It: IJclSingleIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n Result := Add(It.Next) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclSingleBinaryTree.AssignDataTo(Dest: TJclAbstractContainerBase);\r\nvar\r\n ADest: TJclSingleBinaryTree;\r\n ACollection: IJclSingleCollection;\r\nbegin\r\n inherited AssignDataTo(Dest);\r\n if Dest is TJclSingleBinaryTree then\r\n begin\r\n ADest := TJclSingleBinaryTree(Dest);\r\n ADest.Clear;\r\n ADest.FSize := FSize;\r\n if FRoot <> nil then\r\n ADest.FRoot := CloneNode(FRoot, nil);\r\n end\r\n else\r\n if Supports(IInterface(Dest), IJclSingleCollection, ACollection) then\r\n begin\r\n ACollection.Clear;\r\n ACollection.AddAll(Self);\r\n end;\r\nend;\r\n\r\nprocedure TJclSingleBinaryTree.AssignPropertiesTo(Dest: TJclAbstractContainerBase);\r\nbegin\r\n inherited AssignPropertiesto(Dest);\r\n if Dest is TJclSingleBinaryTree then\r\n TJclSingleBinaryTree(Dest).FTraverseOrder := FTraverseOrder;\r\nend;\r\n\r\nprocedure TJclSingleBinaryTree.AutoPack;\r\nbegin\r\n case FAutoPackStrategy of\r\n //apsDisabled: ;\r\n apsAgressive:\r\n if (FMaxDepth > 1) and (((1 shl (FMaxDepth - 1)) - 1) > FSize) then\r\n Pack;\r\n // apsIncremental: ;\r\n apsProportional:\r\n if (FMaxDepth > FAutoPackParameter) and (((1 shl (FMaxDepth - FAutoPackParameter)) - 1) > FSize) then\r\n Pack;\r\n end;\r\nend;\r\n\r\nfunction TJclSingleBinaryTree.BuildTree(const LeafArray: array of TJclSingleBinaryNode; Left, Right: Integer; Parent: TJclSingleBinaryNode;\r\n Offset: Integer): TJclSingleBinaryNode;\r\nvar\r\n Middle: Integer;\r\nbegin\r\n Middle := (Left + Right + Offset) shr 1;\r\n Result := LeafArray[Middle];\r\n Result.Parent := Parent;\r\n if Middle > Left then\r\n Result.Left := BuildTree(LeafArray, Left, Middle - 1, Result, 0)\r\n else\r\n Result.Left := nil;\r\n if Middle < Right then\r\n Result.Right := BuildTree(LeafArray, Middle + 1, Right, Result, 1)\r\n else\r\n Result.Right := nil;\r\nend;\r\n\r\nprocedure TJclSingleBinaryTree.Clear;\r\nvar\r\n Current, Parent: TJclSingleBinaryNode;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n // postorder\r\n Current := FRoot;\r\n if Current = nil then\r\n Exit;\r\n // find first in post-order\r\n while (Current.Left <> nil) or (Current.Right <> nil) do\r\n begin\r\n if Current.Left <> nil then\r\n Current := Current.Left\r\n else\r\n Current := Current.Right;\r\n end;\r\n // for all items in the tree in post-order\r\n repeat\r\n Parent := Current.Parent;\r\n // remove reference\r\n if Parent <> nil then\r\n begin\r\n if Parent.Left = Current then\r\n Parent.Left := nil\r\n else\r\n if Parent.Right = Current then\r\n Parent.Right := nil;\r\n end;\r\n\r\n // free item\r\n FreeSingle(Current.Value);\r\n Current.Free;\r\n\r\n // find next item\r\n Current := Parent;\r\n if (Current <> nil) and (Current.Right <> nil) then\r\n begin\r\n Current := Current.Right;\r\n while (Current.Left <> nil) or (Current.Right <> nil) do\r\n begin\r\n if Current.Left <> nil then\r\n Current := Current.Left\r\n else\r\n Current := Current.Right;\r\n end;\r\n end;\r\n until Current = nil;\r\n FRoot := nil;\r\n FSize := 0;\r\n FMaxDepth := 0;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSingleBinaryTree.CloneNode(Node, Parent: TJclSingleBinaryNode): TJclSingleBinaryNode;\r\nbegin\r\n Result := TJclSingleBinaryNode.Create;\r\n Result.Value := Node.Value;\r\n Result.Parent := Parent;\r\n if Node.Left <> nil then\r\n Result.Left := CloneNode(Node.Left, Result); // recursive call\r\n if Node.Right <> nil then\r\n Result.Right := CloneNode(Node.Right, Result); // recursive call\r\nend;\r\n\r\nfunction TJclSingleBinaryTree.CollectionEquals(const ACollection: IJclSingleCollection): Boolean;\r\nvar\r\n It, ItSelf: IJclSingleIterator;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n if FSize <> ACollection.Size then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n ItSelf := First;\r\n while ItSelf.HasNext do\r\n if not ItemsEqual(ItSelf.Next, It.Next) then\r\n begin\r\n Result := False;\r\n Break;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSingleBinaryTree.Contains(const AValue: Single): Boolean;\r\nvar\r\n Comp: Integer;\r\n Current: TJclSingleBinaryNode;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n Current := FRoot;\r\n while Current <> nil do\r\n begin\r\n Comp := ItemsCompare(Current.Value, AValue);\r\n if Comp = 0 then\r\n begin\r\n Result := True;\r\n Break;\r\n end\r\n else\r\n if Comp > 0 then\r\n Current := Current.Left\r\n else\r\n Current := Current.Right;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSingleBinaryTree.ContainsAll(const ACollection: IJclSingleCollection): Boolean;\r\nvar\r\n It: IJclSingleIterator;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := True;\r\n if ACollection = nil then\r\n Exit;\r\n It := ACollection.First;\r\n while Result and It.HasNext do\r\n Result := Contains(It.Next);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSingleBinaryTree.Extract(const AValue: Single): Boolean;\r\nvar\r\n Current, Successor: TJclSingleBinaryNode;\r\n Comp: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n // locate AValue in the tree\r\n Current := FRoot;\r\n repeat\r\n while Current <> nil do\r\n begin\r\n Comp := ItemsCompare(AValue, Current.Value);\r\n if Comp = 0 then\r\n Break\r\n else\r\n if Comp < 0 then\r\n Current := Current.Left\r\n else\r\n Current := Current.Right;\r\n end;\r\n if Current = nil then\r\n Break;\r\n Result := True;\r\n // Remove Current from tree\r\n if (Current.Left = nil) and (Current.Right <> nil) then\r\n begin\r\n // remove references to Current\r\n Current.Right.Parent := Current.Parent;\r\n if Current.Parent <> nil then\r\n begin\r\n if Current.Parent.Left = Current then\r\n Current.Parent.Left := Current.Right\r\n else\r\n Current.Parent.Right := Current.Right;\r\n end\r\n else\r\n // fix root\r\n FRoot := Current.Right;\r\n Successor := Current.Parent;\r\n if Successor = nil then\r\n Successor := FRoot;\r\n end\r\n else\r\n if (Current.Left <> nil) and (Current.Right = nil) then\r\n begin\r\n // remove references to Current\r\n Current.Left.Parent := Current.Parent;\r\n if Current.Parent <> nil then\r\n begin\r\n if Current.Parent.Left = Current then\r\n Current.Parent.Left := Current.Left\r\n else\r\n Current.Parent.Right := Current.Left;\r\n end\r\n else\r\n // fix root\r\n FRoot := Current.Left;\r\n Successor := Current.Parent;\r\n if Successor = nil then\r\n Successor := FRoot;\r\n end\r\n else\r\n if (Current.Left <> nil) and (Current.Right <> nil) then\r\n begin\r\n // find the successor in tree\r\n Successor := Current.Right;\r\n while Successor.Left <> nil do\r\n Successor := Successor.Left;\r\n\r\n if Successor <> Current.Right then\r\n begin\r\n // remove references to successor\r\n Successor.Parent.Left := Successor.Right;\r\n if Successor.Right <> nil then\r\n Successor.Right.Parent := Successor.Parent;\r\n Successor.Right := Current.Right;\r\n if Successor.Right <> nil then\r\n Successor.Right.Parent := Successor;\r\n end;\r\n\r\n // insert successor in new position\r\n Successor.Left := Current.Left;\r\n if Current.Left <> nil then\r\n Current.Left.Parent := Successor;\r\n Successor.Parent := Current.Parent;\r\n if Current.Parent <> nil then\r\n begin\r\n if Current.Parent.Left = Current then\r\n Current.Parent.Left := Successor\r\n else\r\n Current.Parent.Right := Successor;\r\n end\r\n else\r\n // fix root\r\n FRoot := Successor;\r\n Successor := Current.Parent;\r\n if Successor <> nil then\r\n Successor := FRoot;\r\n end\r\n else\r\n begin\r\n // (Current.Left = nil) and (Current.Right = nil)\r\n Successor := Current.Parent;\r\n if Successor <> nil then\r\n begin\r\n // remove references from parent\r\n if Successor.Left = Current then\r\n Successor.Left := nil\r\n else\r\n Successor.Right := nil;\r\n end\r\n else\r\n FRoot := nil;\r\n end;\r\n Current.Value := 0.0;\r\n Current.Free;\r\n Dec(FSize);\r\n Current := Successor;\r\n until FRemoveSingleElement or (Current = nil);\r\n AutoPack;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSingleBinaryTree.ExtractAll(const ACollection: IJclSingleCollection): Boolean;\r\nvar\r\n It: IJclSingleIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n Result := Extract(It.Next) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSingleBinaryTree.First: IJclSingleIterator;\r\nvar\r\n Start: TJclSingleBinaryNode;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Start := FRoot;\r\n case GetTraverseOrder of\r\n toPreOrder:\r\n Result := TJclPreOrderSingleBinaryTreeIterator.Create(Self, Start, False, isFirst);\r\n toOrder:\r\n begin\r\n if Start <> nil then\r\n while Start.Left <> nil do\r\n Start := Start.Left;\r\n Result := TJclInOrderSingleBinaryTreeIterator.Create(Self, Start, False, isFirst);\r\n end;\r\n toPostOrder:\r\n begin\r\n if Start <> nil then\r\n while (Start.Left <> nil) or (Start.Right <> nil) do\r\n begin\r\n if Start.Left <> nil then\r\n Start := Start.Left\r\n else\r\n Start := Start.Right;\r\n end;\r\n Result := TJclPostOrderSingleBinaryTreeIterator.Create(Self, Start, False, isFirst);\r\n end;\r\n else\r\n Result := nil;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\n{$IFDEF SUPPORTS_FOR_IN}\r\nfunction TJclSingleBinaryTree.GetEnumerator: IJclSingleIterator;\r\nbegin\r\n Result := First;\r\nend;\r\n{$ENDIF SUPPORTS_FOR_IN}\r\n\r\nfunction TJclSingleBinaryTree.GetRoot: IJclSingleTreeIterator;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n case GetTraverseOrder of\r\n toPreOrder:\r\n Result := TJclPreOrderSingleBinaryTreeIterator.Create(Self, FRoot, False, isRoot);\r\n toOrder:\r\n Result := TJclInOrderSingleBinaryTreeIterator.Create(Self, FRoot, False, isRoot);\r\n toPostOrder:\r\n Result := TJclPostOrderSingleBinaryTreeIterator.Create(Self, FRoot, False, isRoot);\r\n else\r\n Result := nil;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSingleBinaryTree.GetTraverseOrder: TJclTraverseOrder;\r\nbegin\r\n Result := FTraverseOrder;\r\nend;\r\n\r\nfunction TJclSingleBinaryTree.IsEmpty: Boolean;\r\nbegin\r\n Result := FSize = 0;\r\nend;\r\n\r\nfunction TJclSingleBinaryTree.Last: IJclSingleIterator;\r\nvar\r\n Start: TJclSingleBinaryNode;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Start := FRoot;\r\n case FTraverseOrder of\r\n toPreOrder:\r\n begin\r\n if Start <> nil then\r\n while (Start.Left <> nil) or (Start.Right <> nil) do\r\n begin\r\n if Start.Right <> nil then\r\n Start := Start.Right\r\n else\r\n Start := Start.Left;\r\n end;\r\n Result := TJclPreOrderSingleBinaryTreeIterator.Create(Self, Start, False, isLast);\r\n end;\r\n toOrder:\r\n begin\r\n if Start <> nil then\r\n while Start.Right <> nil do\r\n Start := Start.Right;\r\n Result := TJclInOrderSingleBinaryTreeIterator.Create(Self, Start, False, isLast);\r\n end;\r\n toPostOrder:\r\n Result := TJclPostOrderSingleBinaryTreeIterator.Create(Self, Start, False, isLast);\r\n else\r\n Result := nil;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclSingleBinaryTree.Pack;\r\nvar\r\n LeafArray: array of TJclSingleBinaryNode;\r\n ANode, BNode: TJclSingleBinaryNode;\r\n Index: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n SetLength(Leafarray, FSize);\r\n try\r\n // in order enumeration of nodes\r\n ANode := FRoot;\r\n if ANode <> nil then\r\n begin\r\n // find first node\r\n while ANode.Left <> nil do\r\n ANode := ANode.Left;\r\n\r\n Index := 0;\r\n while ANode <> nil do\r\n begin\r\n LeafArray[Index] := ANode;\r\n Inc(Index);\r\n if ANode.Right <> nil then\r\n begin\r\n ANode := ANode.Right;\r\n while (ANode.Left <> nil) do\r\n ANode := ANode.Left;\r\n end\r\n else\r\n begin\r\n BNode := ANode;\r\n ANode := ANode.Parent;\r\n while (ANode <> nil) and (ANode.Right = BNode) do\r\n begin\r\n BNode := ANode;\r\n ANode := ANode.Parent;\r\n end;\r\n end;\r\n end;\r\n\r\n Index := FSize shr 1;\r\n FRoot := LeafArray[Index];\r\n FRoot.Parent := nil;\r\n if Index > 0 then\r\n FRoot.Left := BuildTree(LeafArray, 0, Index - 1, FRoot, 0)\r\n else\r\n FRoot.Left := nil;\r\n if Index < (FSize - 1) then\r\n FRoot.Right := BuildTree(LeafArray, Index + 1, FSize - 1, FRoot, 1)\r\n else\r\n FRoot.Right := nil;\r\n end;\r\n finally\r\n SetLength(LeafArray, 0);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSingleBinaryTree.Remove(const AValue: Single): Boolean;\r\nvar\r\n Extracted: Single;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := Extract(AValue);\r\n if Result then\r\n begin\r\n Extracted := AValue;\r\n FreeSingle(Extracted);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSingleBinaryTree.RemoveAll(const ACollection: IJclSingleCollection): Boolean;\r\nvar\r\n It: IJclSingleIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n Result := Remove(It.Next) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSingleBinaryTree.RetainAll(const ACollection: IJclSingleCollection): Boolean;\r\nvar\r\n It: IJclSingleIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := First;\r\n while It.HasNext do\r\n if not ACollection.Contains(It.Next) then\r\n It.Remove;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclSingleBinaryTree.SetCapacity(Value: Integer);\r\nbegin\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nprocedure TJclSingleBinaryTree.SetTraverseOrder(Value: TJclTraverseOrder);\r\nbegin\r\n FTraverseOrder := Value;\r\nend;\r\n\r\nfunction TJclSingleBinaryTree.Size: Integer;\r\nbegin\r\n Result := FSize;\r\nend;\r\n\r\nfunction TJclSingleBinaryTree.CreateEmptyContainer: TJclAbstractContainerBase;\r\nbegin\r\n Result := TJclSingleBinaryTree.Create(Compare);\r\n AssignPropertiesTo(Result);\r\nend;\r\n\r\n//=== { TJclSingleBinaryTreeIterator } ===========================================================\r\n\r\nconstructor TJclSingleBinaryTreeIterator.Create(const AOwnTree: IJclSingleCollection; ACursor: TJclSingleBinaryNode; AValid: Boolean; AStart: TItrStart);\r\nbegin\r\n inherited Create(AValid);\r\n FCursor := ACursor;\r\n FStart := AStart;\r\n FOwnTree := AOwnTree;\r\n FEqualityComparer := AOwnTree as IJclSingleEqualityComparer;\r\nend;\r\n\r\nfunction TJclSingleBinaryTreeIterator.Add(const AValue: Single): Boolean;\r\nbegin\r\n Result := FOwnTree.Add(AValue);\r\nend;\r\n\r\nfunction TJclSingleBinaryTreeIterator.AddChild(const AValue: Single): Boolean;\r\nbegin\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nprocedure TJclSingleBinaryTreeIterator.AssignPropertiesTo(Dest: TJclAbstractIterator);\r\nvar\r\n ADest: TJclSingleBinaryTreeIterator;\r\nbegin\r\n inherited AssignPropertiesTo(Dest);\r\n if Dest is TJclSingleBinaryTreeIterator then\r\n begin\r\n ADest := TJclSingleBinaryTreeIterator(Dest);\r\n ADest.FCursor := FCursor;\r\n ADest.FOwnTree := FOwnTree;\r\n ADest.FEqualityComparer := FEqualityComparer;\r\n ADest.FStart := FStart;\r\n end;\r\nend;\r\n\r\nfunction TJclSingleBinaryTreeIterator.ChildrenCount: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := 0;\r\n if FCursor <> nil then\r\n begin\r\n if FCursor.Left <> nil then\r\n Inc(Result);\r\n if FCursor.Right <> nil then\r\n Inc(Result);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclSingleBinaryTreeIterator.DeleteChild(Index: Integer);\r\nbegin\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nprocedure TJclSingleBinaryTreeIterator.DeleteChildren;\r\nbegin\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nprocedure TJclSingleBinaryTreeIterator.Extract;\r\nvar\r\n OldCursor: TJclSingleBinaryNode;\r\nbegin\r\n if FOwnTree.ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n CheckValid;\r\n Valid := False;\r\n OldCursor := FCursor;\r\n if OldCursor <> nil then\r\n begin\r\n repeat\r\n FCursor := GetNextCursor;\r\n until (FCursor = nil) or FOwnTree.RemoveSingleElement\r\n or (not FEqualityComparer.ItemsEqual(OldCursor.Value, FCursor.Value));\r\n FOwnTree.Extract(OldCursor.Value);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.WriteUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclSingleBinaryTreeIterator.ExtractChild(Index: Integer);\r\nbegin\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nprocedure TJclSingleBinaryTreeIterator.ExtractChildren;\r\nbegin\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nfunction TJclSingleBinaryTreeIterator.GetChild(Index: Integer): Single;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := 0.0;\r\n if (FCursor <> nil) and (Index = 0) and (FCursor.Left <> nil) then\r\n FCursor := FCursor.Left\r\n else\r\n if (FCursor <> nil) and (Index = 0) then\r\n FCursor := FCursor.Right\r\n else\r\n if (FCursor <> nil) and (Index = 1) then\r\n FCursor := FCursor.Right\r\n else\r\n FCursor := nil;\r\n if FCursor <> nil then\r\n Result := FCursor.Value\r\n else\r\n if not FOwnTree.ReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSingleBinaryTreeIterator.GetValue: Single;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n CheckValid;\r\n Result := 0.0;\r\n if FCursor <> nil then\r\n Result := FCursor.Value\r\n else\r\n if not FOwnTree.ReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSingleBinaryTreeIterator.HasChild(Index: Integer): Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if (FCursor <> nil) and (Index = 0) then\r\n Result := (FCursor.Left <> nil) or (FCursor.Right <> nil)\r\n else\r\n if (FCursor <> nil) and (Index = 1) then\r\n Result := (FCursor.Left <> nil) and (FCursor.Right <> nil)\r\n else\r\n Result := False;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSingleBinaryTreeIterator.HasLeft: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := (FCursor <> nil) and (FCursor.Left <> nil);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSingleBinaryTreeIterator.HasNext: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Valid then\r\n Result := GetNextCursor <> nil\r\n else\r\n Result := FCursor <> nil;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSingleBinaryTreeIterator.HasParent: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := (FCursor <> nil) and (FCursor.Parent <> nil);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSingleBinaryTreeIterator.HasPrevious: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Valid then\r\n Result := GetPreviousCursor <> nil\r\n else\r\n Result := FCursor <> nil;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSingleBinaryTreeIterator.HasRight: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := (FCursor <> nil) and (FCursor.Right <> nil);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSingleBinaryTreeIterator.IndexOfChild(const AValue: Single): Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := -1;\r\n if FCursor <> nil then\r\n begin\r\n if FCursor.Left <> nil then\r\n begin\r\n if FEqualityComparer.ItemsEqual(FCursor.Left.Value, AValue) then\r\n Result := 0\r\n else\r\n if (FCursor.Right <> nil) and FEqualityComparer.ItemsEqual(FCursor.Right.Value, AValue) then\r\n Result := 1;\r\n end\r\n else\r\n if (FCursor.Right <> nil) and FEqualityComparer.ItemsEqual(FCursor.Right.Value, AValue) then\r\n Result := 0;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSingleBinaryTreeIterator.Insert(const AValue: Single): Boolean;\r\nbegin\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nfunction TJclSingleBinaryTreeIterator.InsertChild(Index: Integer; const AValue: Single): Boolean;\r\nbegin\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nfunction TJclSingleBinaryTreeIterator.IteratorEquals(const AIterator: IJclSingleIterator): Boolean;\r\nvar\r\n Obj: TObject;\r\n ItrObj: TJclSingleBinaryTreeIterator;\r\nbegin\r\n Result := False;\r\n if AIterator = nil then\r\n Exit;\r\n Obj := AIterator.GetIteratorReference;\r\n if Obj is TJclSingleBinaryTreeIterator then\r\n begin\r\n ItrObj := TJclSingleBinaryTreeIterator(Obj);\r\n Result := (FOwnTree = ItrObj.FOwnTree) and (FCursor = ItrObj.FCursor) and (Valid = ItrObj.Valid);\r\n end;\r\nend;\r\n\r\nfunction TJclSingleBinaryTreeIterator.Left: Single;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := 0.0;\r\n if FCursor <> nil then\r\n FCursor := FCursor.Left;\r\n if FCursor <> nil then\r\n Result := FCursor.Value\r\n else\r\n if not FOwnTree.ReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\n{$IFDEF SUPPORTS_FOR_IN}\r\nfunction TJclSingleBinaryTreeIterator.MoveNext: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Valid then\r\n FCursor := GetNextCursor\r\n else\r\n Valid := True;\r\n Result := FCursor <> nil;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n{$ENDIF SUPPORTS_FOR_IN}\r\n\r\nfunction TJclSingleBinaryTreeIterator.Next: Single;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Valid then\r\n FCursor := GetNextCursor\r\n else\r\n Valid := True;\r\n Result := 0.0;\r\n if FCursor <> nil then\r\n Result := FCursor.Value\r\n else\r\n if not FOwnTree.ReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSingleBinaryTreeIterator.NextIndex: Integer;\r\nbegin\r\n // No index\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nfunction TJclSingleBinaryTreeIterator.Parent: Single;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := 0.0;\r\n if FCursor <> nil then\r\n FCursor := FCursor.Parent;\r\n if FCursor <> nil then\r\n Result := FCursor.Value\r\n else\r\n if not FOwnTree.ReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSingleBinaryTreeIterator.Previous: Single;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Valid then\r\n FCursor := GetPreviousCursor\r\n else\r\n Valid := True;\r\n Result := 0.0;\r\n if FCursor <> nil then\r\n Result := FCursor.Value\r\n else\r\n if not FOwnTree.ReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSingleBinaryTreeIterator.PreviousIndex: Integer;\r\nbegin\r\n // No index\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nprocedure TJclSingleBinaryTreeIterator.Remove;\r\nvar\r\n OldCursor: TJclSingleBinaryNode;\r\nbegin\r\n if FOwnTree.ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n CheckValid;\r\n Valid := False;\r\n OldCursor := FCursor;\r\n if OldCursor <> nil then\r\n begin\r\n repeat\r\n FCursor := GetNextCursor;\r\n until (FCursor = nil) or FOwnTree.RemoveSingleElement\r\n or (not FEqualityComparer.ItemsEqual(OldCursor.Value, FCursor.Value));\r\n FOwnTree.Remove(OldCursor.Value);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.WriteUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclSingleBinaryTreeIterator.Reset;\r\nvar\r\n NewCursor: TJclSingleBinaryNode;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Valid := False;\r\n case FStart of\r\n isFirst:\r\n begin\r\n NewCursor := FCursor;\r\n while NewCursor <> nil do\r\n begin\r\n NewCursor := GetPreviousCursor;\r\n if NewCursor <> nil then\r\n FCursor := NewCursor;\r\n end;\r\n end;\r\n isLast:\r\n begin\r\n NewCursor := FCursor;\r\n while NewCursor <> nil do\r\n begin\r\n NewCursor := GetNextCursor;\r\n if NewCursor <> nil then\r\n FCursor := NewCursor;\r\n end;\r\n end;\r\n isRoot:\r\n begin\r\n while (FCursor <> nil) and (FCursor.Parent <> nil) do\r\n FCursor := FCursor.Parent;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSingleBinaryTreeIterator.Right: Single;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := 0.0;\r\n if FCursor <> nil then\r\n FCursor := FCursor.Right;\r\n if FCursor <> nil then\r\n Result := FCursor.Value\r\n else\r\n if not FOwnTree.ReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclSingleBinaryTreeIterator.SetChild(Index: Integer; const AValue: Single);\r\nbegin\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nprocedure TJclSingleBinaryTreeIterator.SetValue(const AValue: Single);\r\nbegin\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\n//=== { TJclPreOrderSingleBinaryTreeIterator } ===================================================\r\n\r\nfunction TJclPreOrderSingleBinaryTreeIterator.CreateEmptyIterator: TJclAbstractIterator;\r\nbegin\r\n Result := TJclPreOrderSingleBinaryTreeIterator.Create(FOwnTree, FCursor, Valid, FStart);\r\nend;\r\n\r\nfunction TJclPreOrderSingleBinaryTreeIterator.GetNextCursor: TJclSingleBinaryNode;\r\nvar\r\n LastRet: TJclSingleBinaryNode;\r\nbegin\r\n Result := FCursor;\r\n if Result = nil then\r\n Exit;\r\n LastRet := Result;\r\n if Result.Left <> nil then\r\n Result := Result.Left\r\n else\r\n if Result.Right <> nil then\r\n Result := Result.Right\r\n else\r\n begin\r\n Result := Result.Parent;\r\n while (Result <> nil) and ((Result.Right = nil) or (Result.Right = LastRet)) do\r\n begin\r\n LastRet := Result;\r\n Result := Result.Parent;\r\n end;\r\n if Result <> nil then // not root\r\n Result := Result.Right;\r\n end;\r\nend;\r\n\r\nfunction TJclPreOrderSingleBinaryTreeIterator.GetPreviousCursor: TJclSingleBinaryNode;\r\nvar\r\n LastRet: TJclSingleBinaryNode;\r\nbegin\r\n Result := FCursor;\r\n if Result = nil then\r\n Exit;\r\n LastRet := Result;\r\n Result := Result.Parent;\r\n if (Result <> nil) and (Result.Left <> LastRet) and (Result.Left <> nil) then\r\n // come from Right\r\n begin\r\n Result := Result.Left;\r\n while (Result.Left <> nil) or (Result.Right <> nil) do // both childs\r\n begin\r\n if Result.Right <> nil then // right child first\r\n Result := Result.Right\r\n else\r\n Result := Result.Left;\r\n end;\r\n end;\r\nend;\r\n\r\n//=== { TJclInOrderSingleBinaryTreeIterator } ====================================================\r\n\r\nfunction TJclInOrderSingleBinaryTreeIterator.CreateEmptyIterator: TJclAbstractIterator;\r\nbegin\r\n Result := TJclInOrderSingleBinaryTreeIterator.Create(FOwnTree, FCursor, Valid, FStart);\r\nend;\r\n\r\nfunction TJclInOrderSingleBinaryTreeIterator.GetNextCursor: TJclSingleBinaryNode;\r\nvar\r\n LastRet: TJclSingleBinaryNode;\r\nbegin\r\n Result := FCursor;\r\n if Result = nil then\r\n Exit;\r\n if Result.Right <> nil then\r\n begin\r\n Result := Result.Right;\r\n while (Result.Left <> nil) do\r\n Result := Result.Left;\r\n end\r\n else\r\n begin\r\n LastRet := Result;\r\n Result := Result.Parent;\r\n while (Result <> nil) and (Result.Right = LastRet) do\r\n begin\r\n LastRet := Result;\r\n Result := Result.Parent;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJclInOrderSingleBinaryTreeIterator.GetPreviousCursor: TJclSingleBinaryNode;\r\nvar\r\n LastRet: TJclSingleBinaryNode;\r\nbegin\r\n Result := FCursor;\r\n if Result = nil then\r\n Exit;\r\n if Result.Left <> nil then\r\n begin\r\n Result := Result.Left;\r\n while Result.Right <> nil do\r\n Result := Result.Right;\r\n end\r\n else\r\n begin\r\n LastRet := Result;\r\n Result := Result.Parent;\r\n while (Result <> nil) and (Result.Right <> LastRet) do // Come from Left\r\n begin\r\n LastRet := Result;\r\n Result := Result.Parent;\r\n end;\r\n end;\r\nend;\r\n\r\n//=== { TJclPostOrderSingleBinaryTreeIterator } ==================================================\r\n\r\nfunction TJclPostOrderSingleBinaryTreeIterator.CreateEmptyIterator: TJclAbstractIterator;\r\nbegin\r\n Result := TJclPostOrderSingleBinaryTreeIterator.Create(FOwnTree, FCursor, Valid, FStart);\r\nend;\r\n\r\nfunction TJclPostOrderSingleBinaryTreeIterator.GetNextCursor: TJclSingleBinaryNode;\r\nvar\r\n LastRet: TJclSingleBinaryNode;\r\nbegin\r\n Result := FCursor;\r\n if Result = nil then\r\n Exit;\r\n LastRet := Result;\r\n Result := Result.Parent;\r\n if (Result <> nil) and (Result.Right <> nil) and (Result.Right <> LastRet) then\r\n begin\r\n Result := Result.Right;\r\n while (Result.Left <> nil) or (Result.Right <> nil) do\r\n begin\r\n if Result.Left <> nil then\r\n Result := Result.Left\r\n else\r\n Result := Result.Right;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJclPostOrderSingleBinaryTreeIterator.GetPreviousCursor: TJclSingleBinaryNode;\r\nvar\r\n LastRet: TJclSingleBinaryNode;\r\nbegin\r\n Result := FCursor;\r\n if Result = nil then\r\n Exit;\r\n if Result.Right <> nil then\r\n Result := Result.Right\r\n else\r\n if Result.Left <> nil then\r\n Result := Result.Left\r\n else\r\n begin\r\n LastRet := Result;\r\n Result := Result.Parent;\r\n while (Result <> nil) and ((Result.Left = nil) or (Result.Left = LastRet)) do\r\n begin\r\n LastRet := Result;\r\n Result := Result.Parent;\r\n end;\r\n if Result <> nil then // not root\r\n Result := Result.Left;\r\n end;\r\nend;\r\n\r\n//=== { TJclDoubleBinaryTree } =================================================\r\n\r\nconstructor TJclDoubleBinaryTree.Create(ACompare: TDoubleCompare);\r\nbegin\r\n inherited Create();\r\n FTraverseOrder := toOrder;\r\n FMaxDepth := 0;\r\n FAutoPackParameter := 2;\r\n SetCompare(ACompare);\r\nend;\r\n\r\ndestructor TJclDoubleBinaryTree.Destroy;\r\nbegin\r\n FReadOnly := False;\r\n Clear;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJclDoubleBinaryTree.Add(const AValue: Double): Boolean;\r\nvar\r\n NewNode, Current, Save: TJclDoubleBinaryNode;\r\n Comp, Depth: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n // Insert into right place\r\n if FAllowDefaultElements or not ItemsEqual(AValue, 0.0) then\r\n begin\r\n Save := nil;\r\n Current := FRoot;\r\n Comp := 1;\r\n Depth := 0;\r\n while Current <> nil do\r\n begin\r\n Inc(Depth);\r\n Save := Current;\r\n Comp := ItemsCompare(AValue, Current.Value);\r\n if Comp < 0 then\r\n Current := Current.Left\r\n else\r\n if Comp > 0 then\r\n Current := Current.Right\r\n else\r\n if CheckDuplicate then\r\n Current := Current.Left // arbitrary decision\r\n else\r\n Break;\r\n end;\r\n if (Comp <> 0) or CheckDuplicate then\r\n begin\r\n NewNode := TJclDoubleBinaryNode.Create;\r\n NewNode.Value := AValue;\r\n NewNode.Parent := Save;\r\n if Save = nil then\r\n FRoot := NewNode\r\n else\r\n if ItemsCompare(NewNode.Value, Save.Value) <= 0 then\r\n Save.Left := NewNode\r\n else\r\n Save.Right := NewNode;\r\n Inc(FSize);\r\n Inc(Depth);\r\n if Depth > FMaxDepth then\r\n FMaxDepth := Depth;\r\n Result := True;\r\n AutoPack;\r\n end\r\n else\r\n Result := False;\r\n end\r\n else\r\n Result := False;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclDoubleBinaryTree.AddAll(const ACollection: IJclDoubleCollection): Boolean;\r\nvar\r\n It: IJclDoubleIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n Result := Add(It.Next) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclDoubleBinaryTree.AssignDataTo(Dest: TJclAbstractContainerBase);\r\nvar\r\n ADest: TJclDoubleBinaryTree;\r\n ACollection: IJclDoubleCollection;\r\nbegin\r\n inherited AssignDataTo(Dest);\r\n if Dest is TJclDoubleBinaryTree then\r\n begin\r\n ADest := TJclDoubleBinaryTree(Dest);\r\n ADest.Clear;\r\n ADest.FSize := FSize;\r\n if FRoot <> nil then\r\n ADest.FRoot := CloneNode(FRoot, nil);\r\n end\r\n else\r\n if Supports(IInterface(Dest), IJclDoubleCollection, ACollection) then\r\n begin\r\n ACollection.Clear;\r\n ACollection.AddAll(Self);\r\n end;\r\nend;\r\n\r\nprocedure TJclDoubleBinaryTree.AssignPropertiesTo(Dest: TJclAbstractContainerBase);\r\nbegin\r\n inherited AssignPropertiesto(Dest);\r\n if Dest is TJclDoubleBinaryTree then\r\n TJclDoubleBinaryTree(Dest).FTraverseOrder := FTraverseOrder;\r\nend;\r\n\r\nprocedure TJclDoubleBinaryTree.AutoPack;\r\nbegin\r\n case FAutoPackStrategy of\r\n //apsDisabled: ;\r\n apsAgressive:\r\n if (FMaxDepth > 1) and (((1 shl (FMaxDepth - 1)) - 1) > FSize) then\r\n Pack;\r\n // apsIncremental: ;\r\n apsProportional:\r\n if (FMaxDepth > FAutoPackParameter) and (((1 shl (FMaxDepth - FAutoPackParameter)) - 1) > FSize) then\r\n Pack;\r\n end;\r\nend;\r\n\r\nfunction TJclDoubleBinaryTree.BuildTree(const LeafArray: array of TJclDoubleBinaryNode; Left, Right: Integer; Parent: TJclDoubleBinaryNode;\r\n Offset: Integer): TJclDoubleBinaryNode;\r\nvar\r\n Middle: Integer;\r\nbegin\r\n Middle := (Left + Right + Offset) shr 1;\r\n Result := LeafArray[Middle];\r\n Result.Parent := Parent;\r\n if Middle > Left then\r\n Result.Left := BuildTree(LeafArray, Left, Middle - 1, Result, 0)\r\n else\r\n Result.Left := nil;\r\n if Middle < Right then\r\n Result.Right := BuildTree(LeafArray, Middle + 1, Right, Result, 1)\r\n else\r\n Result.Right := nil;\r\nend;\r\n\r\nprocedure TJclDoubleBinaryTree.Clear;\r\nvar\r\n Current, Parent: TJclDoubleBinaryNode;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n // postorder\r\n Current := FRoot;\r\n if Current = nil then\r\n Exit;\r\n // find first in post-order\r\n while (Current.Left <> nil) or (Current.Right <> nil) do\r\n begin\r\n if Current.Left <> nil then\r\n Current := Current.Left\r\n else\r\n Current := Current.Right;\r\n end;\r\n // for all items in the tree in post-order\r\n repeat\r\n Parent := Current.Parent;\r\n // remove reference\r\n if Parent <> nil then\r\n begin\r\n if Parent.Left = Current then\r\n Parent.Left := nil\r\n else\r\n if Parent.Right = Current then\r\n Parent.Right := nil;\r\n end;\r\n\r\n // free item\r\n FreeDouble(Current.Value);\r\n Current.Free;\r\n\r\n // find next item\r\n Current := Parent;\r\n if (Current <> nil) and (Current.Right <> nil) then\r\n begin\r\n Current := Current.Right;\r\n while (Current.Left <> nil) or (Current.Right <> nil) do\r\n begin\r\n if Current.Left <> nil then\r\n Current := Current.Left\r\n else\r\n Current := Current.Right;\r\n end;\r\n end;\r\n until Current = nil;\r\n FRoot := nil;\r\n FSize := 0;\r\n FMaxDepth := 0;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclDoubleBinaryTree.CloneNode(Node, Parent: TJclDoubleBinaryNode): TJclDoubleBinaryNode;\r\nbegin\r\n Result := TJclDoubleBinaryNode.Create;\r\n Result.Value := Node.Value;\r\n Result.Parent := Parent;\r\n if Node.Left <> nil then\r\n Result.Left := CloneNode(Node.Left, Result); // recursive call\r\n if Node.Right <> nil then\r\n Result.Right := CloneNode(Node.Right, Result); // recursive call\r\nend;\r\n\r\nfunction TJclDoubleBinaryTree.CollectionEquals(const ACollection: IJclDoubleCollection): Boolean;\r\nvar\r\n It, ItSelf: IJclDoubleIterator;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n if FSize <> ACollection.Size then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n ItSelf := First;\r\n while ItSelf.HasNext do\r\n if not ItemsEqual(ItSelf.Next, It.Next) then\r\n begin\r\n Result := False;\r\n Break;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclDoubleBinaryTree.Contains(const AValue: Double): Boolean;\r\nvar\r\n Comp: Integer;\r\n Current: TJclDoubleBinaryNode;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n Current := FRoot;\r\n while Current <> nil do\r\n begin\r\n Comp := ItemsCompare(Current.Value, AValue);\r\n if Comp = 0 then\r\n begin\r\n Result := True;\r\n Break;\r\n end\r\n else\r\n if Comp > 0 then\r\n Current := Current.Left\r\n else\r\n Current := Current.Right;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclDoubleBinaryTree.ContainsAll(const ACollection: IJclDoubleCollection): Boolean;\r\nvar\r\n It: IJclDoubleIterator;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := True;\r\n if ACollection = nil then\r\n Exit;\r\n It := ACollection.First;\r\n while Result and It.HasNext do\r\n Result := Contains(It.Next);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclDoubleBinaryTree.Extract(const AValue: Double): Boolean;\r\nvar\r\n Current, Successor: TJclDoubleBinaryNode;\r\n Comp: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n // locate AValue in the tree\r\n Current := FRoot;\r\n repeat\r\n while Current <> nil do\r\n begin\r\n Comp := ItemsCompare(AValue, Current.Value);\r\n if Comp = 0 then\r\n Break\r\n else\r\n if Comp < 0 then\r\n Current := Current.Left\r\n else\r\n Current := Current.Right;\r\n end;\r\n if Current = nil then\r\n Break;\r\n Result := True;\r\n // Remove Current from tree\r\n if (Current.Left = nil) and (Current.Right <> nil) then\r\n begin\r\n // remove references to Current\r\n Current.Right.Parent := Current.Parent;\r\n if Current.Parent <> nil then\r\n begin\r\n if Current.Parent.Left = Current then\r\n Current.Parent.Left := Current.Right\r\n else\r\n Current.Parent.Right := Current.Right;\r\n end\r\n else\r\n // fix root\r\n FRoot := Current.Right;\r\n Successor := Current.Parent;\r\n if Successor = nil then\r\n Successor := FRoot;\r\n end\r\n else\r\n if (Current.Left <> nil) and (Current.Right = nil) then\r\n begin\r\n // remove references to Current\r\n Current.Left.Parent := Current.Parent;\r\n if Current.Parent <> nil then\r\n begin\r\n if Current.Parent.Left = Current then\r\n Current.Parent.Left := Current.Left\r\n else\r\n Current.Parent.Right := Current.Left;\r\n end\r\n else\r\n // fix root\r\n FRoot := Current.Left;\r\n Successor := Current.Parent;\r\n if Successor = nil then\r\n Successor := FRoot;\r\n end\r\n else\r\n if (Current.Left <> nil) and (Current.Right <> nil) then\r\n begin\r\n // find the successor in tree\r\n Successor := Current.Right;\r\n while Successor.Left <> nil do\r\n Successor := Successor.Left;\r\n\r\n if Successor <> Current.Right then\r\n begin\r\n // remove references to successor\r\n Successor.Parent.Left := Successor.Right;\r\n if Successor.Right <> nil then\r\n Successor.Right.Parent := Successor.Parent;\r\n Successor.Right := Current.Right;\r\n if Successor.Right <> nil then\r\n Successor.Right.Parent := Successor;\r\n end;\r\n\r\n // insert successor in new position\r\n Successor.Left := Current.Left;\r\n if Current.Left <> nil then\r\n Current.Left.Parent := Successor;\r\n Successor.Parent := Current.Parent;\r\n if Current.Parent <> nil then\r\n begin\r\n if Current.Parent.Left = Current then\r\n Current.Parent.Left := Successor\r\n else\r\n Current.Parent.Right := Successor;\r\n end\r\n else\r\n // fix root\r\n FRoot := Successor;\r\n Successor := Current.Parent;\r\n if Successor <> nil then\r\n Successor := FRoot;\r\n end\r\n else\r\n begin\r\n // (Current.Left = nil) and (Current.Right = nil)\r\n Successor := Current.Parent;\r\n if Successor <> nil then\r\n begin\r\n // remove references from parent\r\n if Successor.Left = Current then\r\n Successor.Left := nil\r\n else\r\n Successor.Right := nil;\r\n end\r\n else\r\n FRoot := nil;\r\n end;\r\n Current.Value := 0.0;\r\n Current.Free;\r\n Dec(FSize);\r\n Current := Successor;\r\n until FRemoveSingleElement or (Current = nil);\r\n AutoPack;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclDoubleBinaryTree.ExtractAll(const ACollection: IJclDoubleCollection): Boolean;\r\nvar\r\n It: IJclDoubleIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n Result := Extract(It.Next) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclDoubleBinaryTree.First: IJclDoubleIterator;\r\nvar\r\n Start: TJclDoubleBinaryNode;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Start := FRoot;\r\n case GetTraverseOrder of\r\n toPreOrder:\r\n Result := TJclPreOrderDoubleBinaryTreeIterator.Create(Self, Start, False, isFirst);\r\n toOrder:\r\n begin\r\n if Start <> nil then\r\n while Start.Left <> nil do\r\n Start := Start.Left;\r\n Result := TJclInOrderDoubleBinaryTreeIterator.Create(Self, Start, False, isFirst);\r\n end;\r\n toPostOrder:\r\n begin\r\n if Start <> nil then\r\n while (Start.Left <> nil) or (Start.Right <> nil) do\r\n begin\r\n if Start.Left <> nil then\r\n Start := Start.Left\r\n else\r\n Start := Start.Right;\r\n end;\r\n Result := TJclPostOrderDoubleBinaryTreeIterator.Create(Self, Start, False, isFirst);\r\n end;\r\n else\r\n Result := nil;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\n{$IFDEF SUPPORTS_FOR_IN}\r\nfunction TJclDoubleBinaryTree.GetEnumerator: IJclDoubleIterator;\r\nbegin\r\n Result := First;\r\nend;\r\n{$ENDIF SUPPORTS_FOR_IN}\r\n\r\nfunction TJclDoubleBinaryTree.GetRoot: IJclDoubleTreeIterator;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n case GetTraverseOrder of\r\n toPreOrder:\r\n Result := TJclPreOrderDoubleBinaryTreeIterator.Create(Self, FRoot, False, isRoot);\r\n toOrder:\r\n Result := TJclInOrderDoubleBinaryTreeIterator.Create(Self, FRoot, False, isRoot);\r\n toPostOrder:\r\n Result := TJclPostOrderDoubleBinaryTreeIterator.Create(Self, FRoot, False, isRoot);\r\n else\r\n Result := nil;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclDoubleBinaryTree.GetTraverseOrder: TJclTraverseOrder;\r\nbegin\r\n Result := FTraverseOrder;\r\nend;\r\n\r\nfunction TJclDoubleBinaryTree.IsEmpty: Boolean;\r\nbegin\r\n Result := FSize = 0;\r\nend;\r\n\r\nfunction TJclDoubleBinaryTree.Last: IJclDoubleIterator;\r\nvar\r\n Start: TJclDoubleBinaryNode;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Start := FRoot;\r\n case FTraverseOrder of\r\n toPreOrder:\r\n begin\r\n if Start <> nil then\r\n while (Start.Left <> nil) or (Start.Right <> nil) do\r\n begin\r\n if Start.Right <> nil then\r\n Start := Start.Right\r\n else\r\n Start := Start.Left;\r\n end;\r\n Result := TJclPreOrderDoubleBinaryTreeIterator.Create(Self, Start, False, isLast);\r\n end;\r\n toOrder:\r\n begin\r\n if Start <> nil then\r\n while Start.Right <> nil do\r\n Start := Start.Right;\r\n Result := TJclInOrderDoubleBinaryTreeIterator.Create(Self, Start, False, isLast);\r\n end;\r\n toPostOrder:\r\n Result := TJclPostOrderDoubleBinaryTreeIterator.Create(Self, Start, False, isLast);\r\n else\r\n Result := nil;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclDoubleBinaryTree.Pack;\r\nvar\r\n LeafArray: array of TJclDoubleBinaryNode;\r\n ANode, BNode: TJclDoubleBinaryNode;\r\n Index: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n SetLength(Leafarray, FSize);\r\n try\r\n // in order enumeration of nodes\r\n ANode := FRoot;\r\n if ANode <> nil then\r\n begin\r\n // find first node\r\n while ANode.Left <> nil do\r\n ANode := ANode.Left;\r\n\r\n Index := 0;\r\n while ANode <> nil do\r\n begin\r\n LeafArray[Index] := ANode;\r\n Inc(Index);\r\n if ANode.Right <> nil then\r\n begin\r\n ANode := ANode.Right;\r\n while (ANode.Left <> nil) do\r\n ANode := ANode.Left;\r\n end\r\n else\r\n begin\r\n BNode := ANode;\r\n ANode := ANode.Parent;\r\n while (ANode <> nil) and (ANode.Right = BNode) do\r\n begin\r\n BNode := ANode;\r\n ANode := ANode.Parent;\r\n end;\r\n end;\r\n end;\r\n\r\n Index := FSize shr 1;\r\n FRoot := LeafArray[Index];\r\n FRoot.Parent := nil;\r\n if Index > 0 then\r\n FRoot.Left := BuildTree(LeafArray, 0, Index - 1, FRoot, 0)\r\n else\r\n FRoot.Left := nil;\r\n if Index < (FSize - 1) then\r\n FRoot.Right := BuildTree(LeafArray, Index + 1, FSize - 1, FRoot, 1)\r\n else\r\n FRoot.Right := nil;\r\n end;\r\n finally\r\n SetLength(LeafArray, 0);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclDoubleBinaryTree.Remove(const AValue: Double): Boolean;\r\nvar\r\n Extracted: Double;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := Extract(AValue);\r\n if Result then\r\n begin\r\n Extracted := AValue;\r\n FreeDouble(Extracted);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclDoubleBinaryTree.RemoveAll(const ACollection: IJclDoubleCollection): Boolean;\r\nvar\r\n It: IJclDoubleIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n Result := Remove(It.Next) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclDoubleBinaryTree.RetainAll(const ACollection: IJclDoubleCollection): Boolean;\r\nvar\r\n It: IJclDoubleIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := First;\r\n while It.HasNext do\r\n if not ACollection.Contains(It.Next) then\r\n It.Remove;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclDoubleBinaryTree.SetCapacity(Value: Integer);\r\nbegin\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nprocedure TJclDoubleBinaryTree.SetTraverseOrder(Value: TJclTraverseOrder);\r\nbegin\r\n FTraverseOrder := Value;\r\nend;\r\n\r\nfunction TJclDoubleBinaryTree.Size: Integer;\r\nbegin\r\n Result := FSize;\r\nend;\r\n\r\nfunction TJclDoubleBinaryTree.CreateEmptyContainer: TJclAbstractContainerBase;\r\nbegin\r\n Result := TJclDoubleBinaryTree.Create(Compare);\r\n AssignPropertiesTo(Result);\r\nend;\r\n\r\n//=== { TJclDoubleBinaryTreeIterator } ===========================================================\r\n\r\nconstructor TJclDoubleBinaryTreeIterator.Create(const AOwnTree: IJclDoubleCollection; ACursor: TJclDoubleBinaryNode; AValid: Boolean; AStart: TItrStart);\r\nbegin\r\n inherited Create(AValid);\r\n FCursor := ACursor;\r\n FStart := AStart;\r\n FOwnTree := AOwnTree;\r\n FEqualityComparer := AOwnTree as IJclDoubleEqualityComparer;\r\nend;\r\n\r\nfunction TJclDoubleBinaryTreeIterator.Add(const AValue: Double): Boolean;\r\nbegin\r\n Result := FOwnTree.Add(AValue);\r\nend;\r\n\r\nfunction TJclDoubleBinaryTreeIterator.AddChild(const AValue: Double): Boolean;\r\nbegin\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nprocedure TJclDoubleBinaryTreeIterator.AssignPropertiesTo(Dest: TJclAbstractIterator);\r\nvar\r\n ADest: TJclDoubleBinaryTreeIterator;\r\nbegin\r\n inherited AssignPropertiesTo(Dest);\r\n if Dest is TJclDoubleBinaryTreeIterator then\r\n begin\r\n ADest := TJclDoubleBinaryTreeIterator(Dest);\r\n ADest.FCursor := FCursor;\r\n ADest.FOwnTree := FOwnTree;\r\n ADest.FEqualityComparer := FEqualityComparer;\r\n ADest.FStart := FStart;\r\n end;\r\nend;\r\n\r\nfunction TJclDoubleBinaryTreeIterator.ChildrenCount: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := 0;\r\n if FCursor <> nil then\r\n begin\r\n if FCursor.Left <> nil then\r\n Inc(Result);\r\n if FCursor.Right <> nil then\r\n Inc(Result);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclDoubleBinaryTreeIterator.DeleteChild(Index: Integer);\r\nbegin\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nprocedure TJclDoubleBinaryTreeIterator.DeleteChildren;\r\nbegin\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nprocedure TJclDoubleBinaryTreeIterator.Extract;\r\nvar\r\n OldCursor: TJclDoubleBinaryNode;\r\nbegin\r\n if FOwnTree.ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n CheckValid;\r\n Valid := False;\r\n OldCursor := FCursor;\r\n if OldCursor <> nil then\r\n begin\r\n repeat\r\n FCursor := GetNextCursor;\r\n until (FCursor = nil) or FOwnTree.RemoveSingleElement\r\n or (not FEqualityComparer.ItemsEqual(OldCursor.Value, FCursor.Value));\r\n FOwnTree.Extract(OldCursor.Value);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.WriteUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclDoubleBinaryTreeIterator.ExtractChild(Index: Integer);\r\nbegin\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nprocedure TJclDoubleBinaryTreeIterator.ExtractChildren;\r\nbegin\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nfunction TJclDoubleBinaryTreeIterator.GetChild(Index: Integer): Double;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := 0.0;\r\n if (FCursor <> nil) and (Index = 0) and (FCursor.Left <> nil) then\r\n FCursor := FCursor.Left\r\n else\r\n if (FCursor <> nil) and (Index = 0) then\r\n FCursor := FCursor.Right\r\n else\r\n if (FCursor <> nil) and (Index = 1) then\r\n FCursor := FCursor.Right\r\n else\r\n FCursor := nil;\r\n if FCursor <> nil then\r\n Result := FCursor.Value\r\n else\r\n if not FOwnTree.ReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclDoubleBinaryTreeIterator.GetValue: Double;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n CheckValid;\r\n Result := 0.0;\r\n if FCursor <> nil then\r\n Result := FCursor.Value\r\n else\r\n if not FOwnTree.ReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclDoubleBinaryTreeIterator.HasChild(Index: Integer): Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if (FCursor <> nil) and (Index = 0) then\r\n Result := (FCursor.Left <> nil) or (FCursor.Right <> nil)\r\n else\r\n if (FCursor <> nil) and (Index = 1) then\r\n Result := (FCursor.Left <> nil) and (FCursor.Right <> nil)\r\n else\r\n Result := False;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclDoubleBinaryTreeIterator.HasLeft: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := (FCursor <> nil) and (FCursor.Left <> nil);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclDoubleBinaryTreeIterator.HasNext: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Valid then\r\n Result := GetNextCursor <> nil\r\n else\r\n Result := FCursor <> nil;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclDoubleBinaryTreeIterator.HasParent: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := (FCursor <> nil) and (FCursor.Parent <> nil);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclDoubleBinaryTreeIterator.HasPrevious: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Valid then\r\n Result := GetPreviousCursor <> nil\r\n else\r\n Result := FCursor <> nil;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclDoubleBinaryTreeIterator.HasRight: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := (FCursor <> nil) and (FCursor.Right <> nil);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclDoubleBinaryTreeIterator.IndexOfChild(const AValue: Double): Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := -1;\r\n if FCursor <> nil then\r\n begin\r\n if FCursor.Left <> nil then\r\n begin\r\n if FEqualityComparer.ItemsEqual(FCursor.Left.Value, AValue) then\r\n Result := 0\r\n else\r\n if (FCursor.Right <> nil) and FEqualityComparer.ItemsEqual(FCursor.Right.Value, AValue) then\r\n Result := 1;\r\n end\r\n else\r\n if (FCursor.Right <> nil) and FEqualityComparer.ItemsEqual(FCursor.Right.Value, AValue) then\r\n Result := 0;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclDoubleBinaryTreeIterator.Insert(const AValue: Double): Boolean;\r\nbegin\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nfunction TJclDoubleBinaryTreeIterator.InsertChild(Index: Integer; const AValue: Double): Boolean;\r\nbegin\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nfunction TJclDoubleBinaryTreeIterator.IteratorEquals(const AIterator: IJclDoubleIterator): Boolean;\r\nvar\r\n Obj: TObject;\r\n ItrObj: TJclDoubleBinaryTreeIterator;\r\nbegin\r\n Result := False;\r\n if AIterator = nil then\r\n Exit;\r\n Obj := AIterator.GetIteratorReference;\r\n if Obj is TJclDoubleBinaryTreeIterator then\r\n begin\r\n ItrObj := TJclDoubleBinaryTreeIterator(Obj);\r\n Result := (FOwnTree = ItrObj.FOwnTree) and (FCursor = ItrObj.FCursor) and (Valid = ItrObj.Valid);\r\n end;\r\nend;\r\n\r\nfunction TJclDoubleBinaryTreeIterator.Left: Double;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := 0.0;\r\n if FCursor <> nil then\r\n FCursor := FCursor.Left;\r\n if FCursor <> nil then\r\n Result := FCursor.Value\r\n else\r\n if not FOwnTree.ReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\n{$IFDEF SUPPORTS_FOR_IN}\r\nfunction TJclDoubleBinaryTreeIterator.MoveNext: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Valid then\r\n FCursor := GetNextCursor\r\n else\r\n Valid := True;\r\n Result := FCursor <> nil;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n{$ENDIF SUPPORTS_FOR_IN}\r\n\r\nfunction TJclDoubleBinaryTreeIterator.Next: Double;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Valid then\r\n FCursor := GetNextCursor\r\n else\r\n Valid := True;\r\n Result := 0.0;\r\n if FCursor <> nil then\r\n Result := FCursor.Value\r\n else\r\n if not FOwnTree.ReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclDoubleBinaryTreeIterator.NextIndex: Integer;\r\nbegin\r\n // No index\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nfunction TJclDoubleBinaryTreeIterator.Parent: Double;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := 0.0;\r\n if FCursor <> nil then\r\n FCursor := FCursor.Parent;\r\n if FCursor <> nil then\r\n Result := FCursor.Value\r\n else\r\n if not FOwnTree.ReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclDoubleBinaryTreeIterator.Previous: Double;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Valid then\r\n FCursor := GetPreviousCursor\r\n else\r\n Valid := True;\r\n Result := 0.0;\r\n if FCursor <> nil then\r\n Result := FCursor.Value\r\n else\r\n if not FOwnTree.ReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclDoubleBinaryTreeIterator.PreviousIndex: Integer;\r\nbegin\r\n // No index\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nprocedure TJclDoubleBinaryTreeIterator.Remove;\r\nvar\r\n OldCursor: TJclDoubleBinaryNode;\r\nbegin\r\n if FOwnTree.ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n CheckValid;\r\n Valid := False;\r\n OldCursor := FCursor;\r\n if OldCursor <> nil then\r\n begin\r\n repeat\r\n FCursor := GetNextCursor;\r\n until (FCursor = nil) or FOwnTree.RemoveSingleElement\r\n or (not FEqualityComparer.ItemsEqual(OldCursor.Value, FCursor.Value));\r\n FOwnTree.Remove(OldCursor.Value);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.WriteUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclDoubleBinaryTreeIterator.Reset;\r\nvar\r\n NewCursor: TJclDoubleBinaryNode;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Valid := False;\r\n case FStart of\r\n isFirst:\r\n begin\r\n NewCursor := FCursor;\r\n while NewCursor <> nil do\r\n begin\r\n NewCursor := GetPreviousCursor;\r\n if NewCursor <> nil then\r\n FCursor := NewCursor;\r\n end;\r\n end;\r\n isLast:\r\n begin\r\n NewCursor := FCursor;\r\n while NewCursor <> nil do\r\n begin\r\n NewCursor := GetNextCursor;\r\n if NewCursor <> nil then\r\n FCursor := NewCursor;\r\n end;\r\n end;\r\n isRoot:\r\n begin\r\n while (FCursor <> nil) and (FCursor.Parent <> nil) do\r\n FCursor := FCursor.Parent;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclDoubleBinaryTreeIterator.Right: Double;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := 0.0;\r\n if FCursor <> nil then\r\n FCursor := FCursor.Right;\r\n if FCursor <> nil then\r\n Result := FCursor.Value\r\n else\r\n if not FOwnTree.ReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclDoubleBinaryTreeIterator.SetChild(Index: Integer; const AValue: Double);\r\nbegin\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nprocedure TJclDoubleBinaryTreeIterator.SetValue(const AValue: Double);\r\nbegin\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\n//=== { TJclPreOrderDoubleBinaryTreeIterator } ===================================================\r\n\r\nfunction TJclPreOrderDoubleBinaryTreeIterator.CreateEmptyIterator: TJclAbstractIterator;\r\nbegin\r\n Result := TJclPreOrderDoubleBinaryTreeIterator.Create(FOwnTree, FCursor, Valid, FStart);\r\nend;\r\n\r\nfunction TJclPreOrderDoubleBinaryTreeIterator.GetNextCursor: TJclDoubleBinaryNode;\r\nvar\r\n LastRet: TJclDoubleBinaryNode;\r\nbegin\r\n Result := FCursor;\r\n if Result = nil then\r\n Exit;\r\n LastRet := Result;\r\n if Result.Left <> nil then\r\n Result := Result.Left\r\n else\r\n if Result.Right <> nil then\r\n Result := Result.Right\r\n else\r\n begin\r\n Result := Result.Parent;\r\n while (Result <> nil) and ((Result.Right = nil) or (Result.Right = LastRet)) do\r\n begin\r\n LastRet := Result;\r\n Result := Result.Parent;\r\n end;\r\n if Result <> nil then // not root\r\n Result := Result.Right;\r\n end;\r\nend;\r\n\r\nfunction TJclPreOrderDoubleBinaryTreeIterator.GetPreviousCursor: TJclDoubleBinaryNode;\r\nvar\r\n LastRet: TJclDoubleBinaryNode;\r\nbegin\r\n Result := FCursor;\r\n if Result = nil then\r\n Exit;\r\n LastRet := Result;\r\n Result := Result.Parent;\r\n if (Result <> nil) and (Result.Left <> LastRet) and (Result.Left <> nil) then\r\n // come from Right\r\n begin\r\n Result := Result.Left;\r\n while (Result.Left <> nil) or (Result.Right <> nil) do // both childs\r\n begin\r\n if Result.Right <> nil then // right child first\r\n Result := Result.Right\r\n else\r\n Result := Result.Left;\r\n end;\r\n end;\r\nend;\r\n\r\n//=== { TJclInOrderDoubleBinaryTreeIterator } ====================================================\r\n\r\nfunction TJclInOrderDoubleBinaryTreeIterator.CreateEmptyIterator: TJclAbstractIterator;\r\nbegin\r\n Result := TJclInOrderDoubleBinaryTreeIterator.Create(FOwnTree, FCursor, Valid, FStart);\r\nend;\r\n\r\nfunction TJclInOrderDoubleBinaryTreeIterator.GetNextCursor: TJclDoubleBinaryNode;\r\nvar\r\n LastRet: TJclDoubleBinaryNode;\r\nbegin\r\n Result := FCursor;\r\n if Result = nil then\r\n Exit;\r\n if Result.Right <> nil then\r\n begin\r\n Result := Result.Right;\r\n while (Result.Left <> nil) do\r\n Result := Result.Left;\r\n end\r\n else\r\n begin\r\n LastRet := Result;\r\n Result := Result.Parent;\r\n while (Result <> nil) and (Result.Right = LastRet) do\r\n begin\r\n LastRet := Result;\r\n Result := Result.Parent;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJclInOrderDoubleBinaryTreeIterator.GetPreviousCursor: TJclDoubleBinaryNode;\r\nvar\r\n LastRet: TJclDoubleBinaryNode;\r\nbegin\r\n Result := FCursor;\r\n if Result = nil then\r\n Exit;\r\n if Result.Left <> nil then\r\n begin\r\n Result := Result.Left;\r\n while Result.Right <> nil do\r\n Result := Result.Right;\r\n end\r\n else\r\n begin\r\n LastRet := Result;\r\n Result := Result.Parent;\r\n while (Result <> nil) and (Result.Right <> LastRet) do // Come from Left\r\n begin\r\n LastRet := Result;\r\n Result := Result.Parent;\r\n end;\r\n end;\r\nend;\r\n\r\n//=== { TJclPostOrderDoubleBinaryTreeIterator } ==================================================\r\n\r\nfunction TJclPostOrderDoubleBinaryTreeIterator.CreateEmptyIterator: TJclAbstractIterator;\r\nbegin\r\n Result := TJclPostOrderDoubleBinaryTreeIterator.Create(FOwnTree, FCursor, Valid, FStart);\r\nend;\r\n\r\nfunction TJclPostOrderDoubleBinaryTreeIterator.GetNextCursor: TJclDoubleBinaryNode;\r\nvar\r\n LastRet: TJclDoubleBinaryNode;\r\nbegin\r\n Result := FCursor;\r\n if Result = nil then\r\n Exit;\r\n LastRet := Result;\r\n Result := Result.Parent;\r\n if (Result <> nil) and (Result.Right <> nil) and (Result.Right <> LastRet) then\r\n begin\r\n Result := Result.Right;\r\n while (Result.Left <> nil) or (Result.Right <> nil) do\r\n begin\r\n if Result.Left <> nil then\r\n Result := Result.Left\r\n else\r\n Result := Result.Right;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJclPostOrderDoubleBinaryTreeIterator.GetPreviousCursor: TJclDoubleBinaryNode;\r\nvar\r\n LastRet: TJclDoubleBinaryNode;\r\nbegin\r\n Result := FCursor;\r\n if Result = nil then\r\n Exit;\r\n if Result.Right <> nil then\r\n Result := Result.Right\r\n else\r\n if Result.Left <> nil then\r\n Result := Result.Left\r\n else\r\n begin\r\n LastRet := Result;\r\n Result := Result.Parent;\r\n while (Result <> nil) and ((Result.Left = nil) or (Result.Left = LastRet)) do\r\n begin\r\n LastRet := Result;\r\n Result := Result.Parent;\r\n end;\r\n if Result <> nil then // not root\r\n Result := Result.Left;\r\n end;\r\nend;\r\n\r\n//=== { TJclExtendedBinaryTree } =================================================\r\n\r\nconstructor TJclExtendedBinaryTree.Create(ACompare: TExtendedCompare);\r\nbegin\r\n inherited Create();\r\n FTraverseOrder := toOrder;\r\n FMaxDepth := 0;\r\n FAutoPackParameter := 2;\r\n SetCompare(ACompare);\r\nend;\r\n\r\ndestructor TJclExtendedBinaryTree.Destroy;\r\nbegin\r\n FReadOnly := False;\r\n Clear;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJclExtendedBinaryTree.Add(const AValue: Extended): Boolean;\r\nvar\r\n NewNode, Current, Save: TJclExtendedBinaryNode;\r\n Comp, Depth: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n // Insert into right place\r\n if FAllowDefaultElements or not ItemsEqual(AValue, 0.0) then\r\n begin\r\n Save := nil;\r\n Current := FRoot;\r\n Comp := 1;\r\n Depth := 0;\r\n while Current <> nil do\r\n begin\r\n Inc(Depth);\r\n Save := Current;\r\n Comp := ItemsCompare(AValue, Current.Value);\r\n if Comp < 0 then\r\n Current := Current.Left\r\n else\r\n if Comp > 0 then\r\n Current := Current.Right\r\n else\r\n if CheckDuplicate then\r\n Current := Current.Left // arbitrary decision\r\n else\r\n Break;\r\n end;\r\n if (Comp <> 0) or CheckDuplicate then\r\n begin\r\n NewNode := TJclExtendedBinaryNode.Create;\r\n NewNode.Value := AValue;\r\n NewNode.Parent := Save;\r\n if Save = nil then\r\n FRoot := NewNode\r\n else\r\n if ItemsCompare(NewNode.Value, Save.Value) <= 0 then\r\n Save.Left := NewNode\r\n else\r\n Save.Right := NewNode;\r\n Inc(FSize);\r\n Inc(Depth);\r\n if Depth > FMaxDepth then\r\n FMaxDepth := Depth;\r\n Result := True;\r\n AutoPack;\r\n end\r\n else\r\n Result := False;\r\n end\r\n else\r\n Result := False;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclExtendedBinaryTree.AddAll(const ACollection: IJclExtendedCollection): Boolean;\r\nvar\r\n It: IJclExtendedIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n Result := Add(It.Next) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclExtendedBinaryTree.AssignDataTo(Dest: TJclAbstractContainerBase);\r\nvar\r\n ADest: TJclExtendedBinaryTree;\r\n ACollection: IJclExtendedCollection;\r\nbegin\r\n inherited AssignDataTo(Dest);\r\n if Dest is TJclExtendedBinaryTree then\r\n begin\r\n ADest := TJclExtendedBinaryTree(Dest);\r\n ADest.Clear;\r\n ADest.FSize := FSize;\r\n if FRoot <> nil then\r\n ADest.FRoot := CloneNode(FRoot, nil);\r\n end\r\n else\r\n if Supports(IInterface(Dest), IJclExtendedCollection, ACollection) then\r\n begin\r\n ACollection.Clear;\r\n ACollection.AddAll(Self);\r\n end;\r\nend;\r\n\r\nprocedure TJclExtendedBinaryTree.AssignPropertiesTo(Dest: TJclAbstractContainerBase);\r\nbegin\r\n inherited AssignPropertiesto(Dest);\r\n if Dest is TJclExtendedBinaryTree then\r\n TJclExtendedBinaryTree(Dest).FTraverseOrder := FTraverseOrder;\r\nend;\r\n\r\nprocedure TJclExtendedBinaryTree.AutoPack;\r\nbegin\r\n case FAutoPackStrategy of\r\n //apsDisabled: ;\r\n apsAgressive:\r\n if (FMaxDepth > 1) and (((1 shl (FMaxDepth - 1)) - 1) > FSize) then\r\n Pack;\r\n // apsIncremental: ;\r\n apsProportional:\r\n if (FMaxDepth > FAutoPackParameter) and (((1 shl (FMaxDepth - FAutoPackParameter)) - 1) > FSize) then\r\n Pack;\r\n end;\r\nend;\r\n\r\nfunction TJclExtendedBinaryTree.BuildTree(const LeafArray: array of TJclExtendedBinaryNode; Left, Right: Integer; Parent: TJclExtendedBinaryNode;\r\n Offset: Integer): TJclExtendedBinaryNode;\r\nvar\r\n Middle: Integer;\r\nbegin\r\n Middle := (Left + Right + Offset) shr 1;\r\n Result := LeafArray[Middle];\r\n Result.Parent := Parent;\r\n if Middle > Left then\r\n Result.Left := BuildTree(LeafArray, Left, Middle - 1, Result, 0)\r\n else\r\n Result.Left := nil;\r\n if Middle < Right then\r\n Result.Right := BuildTree(LeafArray, Middle + 1, Right, Result, 1)\r\n else\r\n Result.Right := nil;\r\nend;\r\n\r\nprocedure TJclExtendedBinaryTree.Clear;\r\nvar\r\n Current, Parent: TJclExtendedBinaryNode;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n // postorder\r\n Current := FRoot;\r\n if Current = nil then\r\n Exit;\r\n // find first in post-order\r\n while (Current.Left <> nil) or (Current.Right <> nil) do\r\n begin\r\n if Current.Left <> nil then\r\n Current := Current.Left\r\n else\r\n Current := Current.Right;\r\n end;\r\n // for all items in the tree in post-order\r\n repeat\r\n Parent := Current.Parent;\r\n // remove reference\r\n if Parent <> nil then\r\n begin\r\n if Parent.Left = Current then\r\n Parent.Left := nil\r\n else\r\n if Parent.Right = Current then\r\n Parent.Right := nil;\r\n end;\r\n\r\n // free item\r\n FreeExtended(Current.Value);\r\n Current.Free;\r\n\r\n // find next item\r\n Current := Parent;\r\n if (Current <> nil) and (Current.Right <> nil) then\r\n begin\r\n Current := Current.Right;\r\n while (Current.Left <> nil) or (Current.Right <> nil) do\r\n begin\r\n if Current.Left <> nil then\r\n Current := Current.Left\r\n else\r\n Current := Current.Right;\r\n end;\r\n end;\r\n until Current = nil;\r\n FRoot := nil;\r\n FSize := 0;\r\n FMaxDepth := 0;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclExtendedBinaryTree.CloneNode(Node, Parent: TJclExtendedBinaryNode): TJclExtendedBinaryNode;\r\nbegin\r\n Result := TJclExtendedBinaryNode.Create;\r\n Result.Value := Node.Value;\r\n Result.Parent := Parent;\r\n if Node.Left <> nil then\r\n Result.Left := CloneNode(Node.Left, Result); // recursive call\r\n if Node.Right <> nil then\r\n Result.Right := CloneNode(Node.Right, Result); // recursive call\r\nend;\r\n\r\nfunction TJclExtendedBinaryTree.CollectionEquals(const ACollection: IJclExtendedCollection): Boolean;\r\nvar\r\n It, ItSelf: IJclExtendedIterator;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n if FSize <> ACollection.Size then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n ItSelf := First;\r\n while ItSelf.HasNext do\r\n if not ItemsEqual(ItSelf.Next, It.Next) then\r\n begin\r\n Result := False;\r\n Break;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclExtendedBinaryTree.Contains(const AValue: Extended): Boolean;\r\nvar\r\n Comp: Integer;\r\n Current: TJclExtendedBinaryNode;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n Current := FRoot;\r\n while Current <> nil do\r\n begin\r\n Comp := ItemsCompare(Current.Value, AValue);\r\n if Comp = 0 then\r\n begin\r\n Result := True;\r\n Break;\r\n end\r\n else\r\n if Comp > 0 then\r\n Current := Current.Left\r\n else\r\n Current := Current.Right;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclExtendedBinaryTree.ContainsAll(const ACollection: IJclExtendedCollection): Boolean;\r\nvar\r\n It: IJclExtendedIterator;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := True;\r\n if ACollection = nil then\r\n Exit;\r\n It := ACollection.First;\r\n while Result and It.HasNext do\r\n Result := Contains(It.Next);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclExtendedBinaryTree.Extract(const AValue: Extended): Boolean;\r\nvar\r\n Current, Successor: TJclExtendedBinaryNode;\r\n Comp: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n // locate AValue in the tree\r\n Current := FRoot;\r\n repeat\r\n while Current <> nil do\r\n begin\r\n Comp := ItemsCompare(AValue, Current.Value);\r\n if Comp = 0 then\r\n Break\r\n else\r\n if Comp < 0 then\r\n Current := Current.Left\r\n else\r\n Current := Current.Right;\r\n end;\r\n if Current = nil then\r\n Break;\r\n Result := True;\r\n // Remove Current from tree\r\n if (Current.Left = nil) and (Current.Right <> nil) then\r\n begin\r\n // remove references to Current\r\n Current.Right.Parent := Current.Parent;\r\n if Current.Parent <> nil then\r\n begin\r\n if Current.Parent.Left = Current then\r\n Current.Parent.Left := Current.Right\r\n else\r\n Current.Parent.Right := Current.Right;\r\n end\r\n else\r\n // fix root\r\n FRoot := Current.Right;\r\n Successor := Current.Parent;\r\n if Successor = nil then\r\n Successor := FRoot;\r\n end\r\n else\r\n if (Current.Left <> nil) and (Current.Right = nil) then\r\n begin\r\n // remove references to Current\r\n Current.Left.Parent := Current.Parent;\r\n if Current.Parent <> nil then\r\n begin\r\n if Current.Parent.Left = Current then\r\n Current.Parent.Left := Current.Left\r\n else\r\n Current.Parent.Right := Current.Left;\r\n end\r\n else\r\n // fix root\r\n FRoot := Current.Left;\r\n Successor := Current.Parent;\r\n if Successor = nil then\r\n Successor := FRoot;\r\n end\r\n else\r\n if (Current.Left <> nil) and (Current.Right <> nil) then\r\n begin\r\n // find the successor in tree\r\n Successor := Current.Right;\r\n while Successor.Left <> nil do\r\n Successor := Successor.Left;\r\n\r\n if Successor <> Current.Right then\r\n begin\r\n // remove references to successor\r\n Successor.Parent.Left := Successor.Right;\r\n if Successor.Right <> nil then\r\n Successor.Right.Parent := Successor.Parent;\r\n Successor.Right := Current.Right;\r\n if Successor.Right <> nil then\r\n Successor.Right.Parent := Successor;\r\n end;\r\n\r\n // insert successor in new position\r\n Successor.Left := Current.Left;\r\n if Current.Left <> nil then\r\n Current.Left.Parent := Successor;\r\n Successor.Parent := Current.Parent;\r\n if Current.Parent <> nil then\r\n begin\r\n if Current.Parent.Left = Current then\r\n Current.Parent.Left := Successor\r\n else\r\n Current.Parent.Right := Successor;\r\n end\r\n else\r\n // fix root\r\n FRoot := Successor;\r\n Successor := Current.Parent;\r\n if Successor <> nil then\r\n Successor := FRoot;\r\n end\r\n else\r\n begin\r\n // (Current.Left = nil) and (Current.Right = nil)\r\n Successor := Current.Parent;\r\n if Successor <> nil then\r\n begin\r\n // remove references from parent\r\n if Successor.Left = Current then\r\n Successor.Left := nil\r\n else\r\n Successor.Right := nil;\r\n end\r\n else\r\n FRoot := nil;\r\n end;\r\n Current.Value := 0.0;\r\n Current.Free;\r\n Dec(FSize);\r\n Current := Successor;\r\n until FRemoveSingleElement or (Current = nil);\r\n AutoPack;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclExtendedBinaryTree.ExtractAll(const ACollection: IJclExtendedCollection): Boolean;\r\nvar\r\n It: IJclExtendedIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n Result := Extract(It.Next) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclExtendedBinaryTree.First: IJclExtendedIterator;\r\nvar\r\n Start: TJclExtendedBinaryNode;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Start := FRoot;\r\n case GetTraverseOrder of\r\n toPreOrder:\r\n Result := TJclPreOrderExtendedBinaryTreeIterator.Create(Self, Start, False, isFirst);\r\n toOrder:\r\n begin\r\n if Start <> nil then\r\n while Start.Left <> nil do\r\n Start := Start.Left;\r\n Result := TJclInOrderExtendedBinaryTreeIterator.Create(Self, Start, False, isFirst);\r\n end;\r\n toPostOrder:\r\n begin\r\n if Start <> nil then\r\n while (Start.Left <> nil) or (Start.Right <> nil) do\r\n begin\r\n if Start.Left <> nil then\r\n Start := Start.Left\r\n else\r\n Start := Start.Right;\r\n end;\r\n Result := TJclPostOrderExtendedBinaryTreeIterator.Create(Self, Start, False, isFirst);\r\n end;\r\n else\r\n Result := nil;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\n{$IFDEF SUPPORTS_FOR_IN}\r\nfunction TJclExtendedBinaryTree.GetEnumerator: IJclExtendedIterator;\r\nbegin\r\n Result := First;\r\nend;\r\n{$ENDIF SUPPORTS_FOR_IN}\r\n\r\nfunction TJclExtendedBinaryTree.GetRoot: IJclExtendedTreeIterator;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n case GetTraverseOrder of\r\n toPreOrder:\r\n Result := TJclPreOrderExtendedBinaryTreeIterator.Create(Self, FRoot, False, isRoot);\r\n toOrder:\r\n Result := TJclInOrderExtendedBinaryTreeIterator.Create(Self, FRoot, False, isRoot);\r\n toPostOrder:\r\n Result := TJclPostOrderExtendedBinaryTreeIterator.Create(Self, FRoot, False, isRoot);\r\n else\r\n Result := nil;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclExtendedBinaryTree.GetTraverseOrder: TJclTraverseOrder;\r\nbegin\r\n Result := FTraverseOrder;\r\nend;\r\n\r\nfunction TJclExtendedBinaryTree.IsEmpty: Boolean;\r\nbegin\r\n Result := FSize = 0;\r\nend;\r\n\r\nfunction TJclExtendedBinaryTree.Last: IJclExtendedIterator;\r\nvar\r\n Start: TJclExtendedBinaryNode;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Start := FRoot;\r\n case FTraverseOrder of\r\n toPreOrder:\r\n begin\r\n if Start <> nil then\r\n while (Start.Left <> nil) or (Start.Right <> nil) do\r\n begin\r\n if Start.Right <> nil then\r\n Start := Start.Right\r\n else\r\n Start := Start.Left;\r\n end;\r\n Result := TJclPreOrderExtendedBinaryTreeIterator.Create(Self, Start, False, isLast);\r\n end;\r\n toOrder:\r\n begin\r\n if Start <> nil then\r\n while Start.Right <> nil do\r\n Start := Start.Right;\r\n Result := TJclInOrderExtendedBinaryTreeIterator.Create(Self, Start, False, isLast);\r\n end;\r\n toPostOrder:\r\n Result := TJclPostOrderExtendedBinaryTreeIterator.Create(Self, Start, False, isLast);\r\n else\r\n Result := nil;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclExtendedBinaryTree.Pack;\r\nvar\r\n LeafArray: array of TJclExtendedBinaryNode;\r\n ANode, BNode: TJclExtendedBinaryNode;\r\n Index: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n SetLength(Leafarray, FSize);\r\n try\r\n // in order enumeration of nodes\r\n ANode := FRoot;\r\n if ANode <> nil then\r\n begin\r\n // find first node\r\n while ANode.Left <> nil do\r\n ANode := ANode.Left;\r\n\r\n Index := 0;\r\n while ANode <> nil do\r\n begin\r\n LeafArray[Index] := ANode;\r\n Inc(Index);\r\n if ANode.Right <> nil then\r\n begin\r\n ANode := ANode.Right;\r\n while (ANode.Left <> nil) do\r\n ANode := ANode.Left;\r\n end\r\n else\r\n begin\r\n BNode := ANode;\r\n ANode := ANode.Parent;\r\n while (ANode <> nil) and (ANode.Right = BNode) do\r\n begin\r\n BNode := ANode;\r\n ANode := ANode.Parent;\r\n end;\r\n end;\r\n end;\r\n\r\n Index := FSize shr 1;\r\n FRoot := LeafArray[Index];\r\n FRoot.Parent := nil;\r\n if Index > 0 then\r\n FRoot.Left := BuildTree(LeafArray, 0, Index - 1, FRoot, 0)\r\n else\r\n FRoot.Left := nil;\r\n if Index < (FSize - 1) then\r\n FRoot.Right := BuildTree(LeafArray, Index + 1, FSize - 1, FRoot, 1)\r\n else\r\n FRoot.Right := nil;\r\n end;\r\n finally\r\n SetLength(LeafArray, 0);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclExtendedBinaryTree.Remove(const AValue: Extended): Boolean;\r\nvar\r\n Extracted: Extended;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := Extract(AValue);\r\n if Result then\r\n begin\r\n Extracted := AValue;\r\n FreeExtended(Extracted);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclExtendedBinaryTree.RemoveAll(const ACollection: IJclExtendedCollection): Boolean;\r\nvar\r\n It: IJclExtendedIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n Result := Remove(It.Next) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclExtendedBinaryTree.RetainAll(const ACollection: IJclExtendedCollection): Boolean;\r\nvar\r\n It: IJclExtendedIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := First;\r\n while It.HasNext do\r\n if not ACollection.Contains(It.Next) then\r\n It.Remove;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclExtendedBinaryTree.SetCapacity(Value: Integer);\r\nbegin\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nprocedure TJclExtendedBinaryTree.SetTraverseOrder(Value: TJclTraverseOrder);\r\nbegin\r\n FTraverseOrder := Value;\r\nend;\r\n\r\nfunction TJclExtendedBinaryTree.Size: Integer;\r\nbegin\r\n Result := FSize;\r\nend;\r\n\r\nfunction TJclExtendedBinaryTree.CreateEmptyContainer: TJclAbstractContainerBase;\r\nbegin\r\n Result := TJclExtendedBinaryTree.Create(Compare);\r\n AssignPropertiesTo(Result);\r\nend;\r\n\r\n//=== { TJclExtendedBinaryTreeIterator } ===========================================================\r\n\r\nconstructor TJclExtendedBinaryTreeIterator.Create(const AOwnTree: IJclExtendedCollection; ACursor: TJclExtendedBinaryNode; AValid: Boolean; AStart: TItrStart);\r\nbegin\r\n inherited Create(AValid);\r\n FCursor := ACursor;\r\n FStart := AStart;\r\n FOwnTree := AOwnTree;\r\n FEqualityComparer := AOwnTree as IJclExtendedEqualityComparer;\r\nend;\r\n\r\nfunction TJclExtendedBinaryTreeIterator.Add(const AValue: Extended): Boolean;\r\nbegin\r\n Result := FOwnTree.Add(AValue);\r\nend;\r\n\r\nfunction TJclExtendedBinaryTreeIterator.AddChild(const AValue: Extended): Boolean;\r\nbegin\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nprocedure TJclExtendedBinaryTreeIterator.AssignPropertiesTo(Dest: TJclAbstractIterator);\r\nvar\r\n ADest: TJclExtendedBinaryTreeIterator;\r\nbegin\r\n inherited AssignPropertiesTo(Dest);\r\n if Dest is TJclExtendedBinaryTreeIterator then\r\n begin\r\n ADest := TJclExtendedBinaryTreeIterator(Dest);\r\n ADest.FCursor := FCursor;\r\n ADest.FOwnTree := FOwnTree;\r\n ADest.FEqualityComparer := FEqualityComparer;\r\n ADest.FStart := FStart;\r\n end;\r\nend;\r\n\r\nfunction TJclExtendedBinaryTreeIterator.ChildrenCount: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := 0;\r\n if FCursor <> nil then\r\n begin\r\n if FCursor.Left <> nil then\r\n Inc(Result);\r\n if FCursor.Right <> nil then\r\n Inc(Result);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclExtendedBinaryTreeIterator.DeleteChild(Index: Integer);\r\nbegin\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nprocedure TJclExtendedBinaryTreeIterator.DeleteChildren;\r\nbegin\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nprocedure TJclExtendedBinaryTreeIterator.Extract;\r\nvar\r\n OldCursor: TJclExtendedBinaryNode;\r\nbegin\r\n if FOwnTree.ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n CheckValid;\r\n Valid := False;\r\n OldCursor := FCursor;\r\n if OldCursor <> nil then\r\n begin\r\n repeat\r\n FCursor := GetNextCursor;\r\n until (FCursor = nil) or FOwnTree.RemoveSingleElement\r\n or (not FEqualityComparer.ItemsEqual(OldCursor.Value, FCursor.Value));\r\n FOwnTree.Extract(OldCursor.Value);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.WriteUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclExtendedBinaryTreeIterator.ExtractChild(Index: Integer);\r\nbegin\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nprocedure TJclExtendedBinaryTreeIterator.ExtractChildren;\r\nbegin\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nfunction TJclExtendedBinaryTreeIterator.GetChild(Index: Integer): Extended;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := 0.0;\r\n if (FCursor <> nil) and (Index = 0) and (FCursor.Left <> nil) then\r\n FCursor := FCursor.Left\r\n else\r\n if (FCursor <> nil) and (Index = 0) then\r\n FCursor := FCursor.Right\r\n else\r\n if (FCursor <> nil) and (Index = 1) then\r\n FCursor := FCursor.Right\r\n else\r\n FCursor := nil;\r\n if FCursor <> nil then\r\n Result := FCursor.Value\r\n else\r\n if not FOwnTree.ReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclExtendedBinaryTreeIterator.GetValue: Extended;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n CheckValid;\r\n Result := 0.0;\r\n if FCursor <> nil then\r\n Result := FCursor.Value\r\n else\r\n if not FOwnTree.ReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclExtendedBinaryTreeIterator.HasChild(Index: Integer): Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if (FCursor <> nil) and (Index = 0) then\r\n Result := (FCursor.Left <> nil) or (FCursor.Right <> nil)\r\n else\r\n if (FCursor <> nil) and (Index = 1) then\r\n Result := (FCursor.Left <> nil) and (FCursor.Right <> nil)\r\n else\r\n Result := False;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclExtendedBinaryTreeIterator.HasLeft: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := (FCursor <> nil) and (FCursor.Left <> nil);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclExtendedBinaryTreeIterator.HasNext: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Valid then\r\n Result := GetNextCursor <> nil\r\n else\r\n Result := FCursor <> nil;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclExtendedBinaryTreeIterator.HasParent: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := (FCursor <> nil) and (FCursor.Parent <> nil);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclExtendedBinaryTreeIterator.HasPrevious: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Valid then\r\n Result := GetPreviousCursor <> nil\r\n else\r\n Result := FCursor <> nil;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclExtendedBinaryTreeIterator.HasRight: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := (FCursor <> nil) and (FCursor.Right <> nil);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclExtendedBinaryTreeIterator.IndexOfChild(const AValue: Extended): Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := -1;\r\n if FCursor <> nil then\r\n begin\r\n if FCursor.Left <> nil then\r\n begin\r\n if FEqualityComparer.ItemsEqual(FCursor.Left.Value, AValue) then\r\n Result := 0\r\n else\r\n if (FCursor.Right <> nil) and FEqualityComparer.ItemsEqual(FCursor.Right.Value, AValue) then\r\n Result := 1;\r\n end\r\n else\r\n if (FCursor.Right <> nil) and FEqualityComparer.ItemsEqual(FCursor.Right.Value, AValue) then\r\n Result := 0;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclExtendedBinaryTreeIterator.Insert(const AValue: Extended): Boolean;\r\nbegin\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nfunction TJclExtendedBinaryTreeIterator.InsertChild(Index: Integer; const AValue: Extended): Boolean;\r\nbegin\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nfunction TJclExtendedBinaryTreeIterator.IteratorEquals(const AIterator: IJclExtendedIterator): Boolean;\r\nvar\r\n Obj: TObject;\r\n ItrObj: TJclExtendedBinaryTreeIterator;\r\nbegin\r\n Result := False;\r\n if AIterator = nil then\r\n Exit;\r\n Obj := AIterator.GetIteratorReference;\r\n if Obj is TJclExtendedBinaryTreeIterator then\r\n begin\r\n ItrObj := TJclExtendedBinaryTreeIterator(Obj);\r\n Result := (FOwnTree = ItrObj.FOwnTree) and (FCursor = ItrObj.FCursor) and (Valid = ItrObj.Valid);\r\n end;\r\nend;\r\n\r\nfunction TJclExtendedBinaryTreeIterator.Left: Extended;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := 0.0;\r\n if FCursor <> nil then\r\n FCursor := FCursor.Left;\r\n if FCursor <> nil then\r\n Result := FCursor.Value\r\n else\r\n if not FOwnTree.ReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\n{$IFDEF SUPPORTS_FOR_IN}\r\nfunction TJclExtendedBinaryTreeIterator.MoveNext: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Valid then\r\n FCursor := GetNextCursor\r\n else\r\n Valid := True;\r\n Result := FCursor <> nil;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n{$ENDIF SUPPORTS_FOR_IN}\r\n\r\nfunction TJclExtendedBinaryTreeIterator.Next: Extended;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Valid then\r\n FCursor := GetNextCursor\r\n else\r\n Valid := True;\r\n Result := 0.0;\r\n if FCursor <> nil then\r\n Result := FCursor.Value\r\n else\r\n if not FOwnTree.ReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclExtendedBinaryTreeIterator.NextIndex: Integer;\r\nbegin\r\n // No index\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nfunction TJclExtendedBinaryTreeIterator.Parent: Extended;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := 0.0;\r\n if FCursor <> nil then\r\n FCursor := FCursor.Parent;\r\n if FCursor <> nil then\r\n Result := FCursor.Value\r\n else\r\n if not FOwnTree.ReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclExtendedBinaryTreeIterator.Previous: Extended;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Valid then\r\n FCursor := GetPreviousCursor\r\n else\r\n Valid := True;\r\n Result := 0.0;\r\n if FCursor <> nil then\r\n Result := FCursor.Value\r\n else\r\n if not FOwnTree.ReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclExtendedBinaryTreeIterator.PreviousIndex: Integer;\r\nbegin\r\n // No index\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nprocedure TJclExtendedBinaryTreeIterator.Remove;\r\nvar\r\n OldCursor: TJclExtendedBinaryNode;\r\nbegin\r\n if FOwnTree.ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n CheckValid;\r\n Valid := False;\r\n OldCursor := FCursor;\r\n if OldCursor <> nil then\r\n begin\r\n repeat\r\n FCursor := GetNextCursor;\r\n until (FCursor = nil) or FOwnTree.RemoveSingleElement\r\n or (not FEqualityComparer.ItemsEqual(OldCursor.Value, FCursor.Value));\r\n FOwnTree.Remove(OldCursor.Value);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.WriteUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclExtendedBinaryTreeIterator.Reset;\r\nvar\r\n NewCursor: TJclExtendedBinaryNode;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Valid := False;\r\n case FStart of\r\n isFirst:\r\n begin\r\n NewCursor := FCursor;\r\n while NewCursor <> nil do\r\n begin\r\n NewCursor := GetPreviousCursor;\r\n if NewCursor <> nil then\r\n FCursor := NewCursor;\r\n end;\r\n end;\r\n isLast:\r\n begin\r\n NewCursor := FCursor;\r\n while NewCursor <> nil do\r\n begin\r\n NewCursor := GetNextCursor;\r\n if NewCursor <> nil then\r\n FCursor := NewCursor;\r\n end;\r\n end;\r\n isRoot:\r\n begin\r\n while (FCursor <> nil) and (FCursor.Parent <> nil) do\r\n FCursor := FCursor.Parent;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclExtendedBinaryTreeIterator.Right: Extended;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := 0.0;\r\n if FCursor <> nil then\r\n FCursor := FCursor.Right;\r\n if FCursor <> nil then\r\n Result := FCursor.Value\r\n else\r\n if not FOwnTree.ReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclExtendedBinaryTreeIterator.SetChild(Index: Integer; const AValue: Extended);\r\nbegin\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nprocedure TJclExtendedBinaryTreeIterator.SetValue(const AValue: Extended);\r\nbegin\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\n//=== { TJclPreOrderExtendedBinaryTreeIterator } ===================================================\r\n\r\nfunction TJclPreOrderExtendedBinaryTreeIterator.CreateEmptyIterator: TJclAbstractIterator;\r\nbegin\r\n Result := TJclPreOrderExtendedBinaryTreeIterator.Create(FOwnTree, FCursor, Valid, FStart);\r\nend;\r\n\r\nfunction TJclPreOrderExtendedBinaryTreeIterator.GetNextCursor: TJclExtendedBinaryNode;\r\nvar\r\n LastRet: TJclExtendedBinaryNode;\r\nbegin\r\n Result := FCursor;\r\n if Result = nil then\r\n Exit;\r\n LastRet := Result;\r\n if Result.Left <> nil then\r\n Result := Result.Left\r\n else\r\n if Result.Right <> nil then\r\n Result := Result.Right\r\n else\r\n begin\r\n Result := Result.Parent;\r\n while (Result <> nil) and ((Result.Right = nil) or (Result.Right = LastRet)) do\r\n begin\r\n LastRet := Result;\r\n Result := Result.Parent;\r\n end;\r\n if Result <> nil then // not root\r\n Result := Result.Right;\r\n end;\r\nend;\r\n\r\nfunction TJclPreOrderExtendedBinaryTreeIterator.GetPreviousCursor: TJclExtendedBinaryNode;\r\nvar\r\n LastRet: TJclExtendedBinaryNode;\r\nbegin\r\n Result := FCursor;\r\n if Result = nil then\r\n Exit;\r\n LastRet := Result;\r\n Result := Result.Parent;\r\n if (Result <> nil) and (Result.Left <> LastRet) and (Result.Left <> nil) then\r\n // come from Right\r\n begin\r\n Result := Result.Left;\r\n while (Result.Left <> nil) or (Result.Right <> nil) do // both childs\r\n begin\r\n if Result.Right <> nil then // right child first\r\n Result := Result.Right\r\n else\r\n Result := Result.Left;\r\n end;\r\n end;\r\nend;\r\n\r\n//=== { TJclInOrderExtendedBinaryTreeIterator } ====================================================\r\n\r\nfunction TJclInOrderExtendedBinaryTreeIterator.CreateEmptyIterator: TJclAbstractIterator;\r\nbegin\r\n Result := TJclInOrderExtendedBinaryTreeIterator.Create(FOwnTree, FCursor, Valid, FStart);\r\nend;\r\n\r\nfunction TJclInOrderExtendedBinaryTreeIterator.GetNextCursor: TJclExtendedBinaryNode;\r\nvar\r\n LastRet: TJclExtendedBinaryNode;\r\nbegin\r\n Result := FCursor;\r\n if Result = nil then\r\n Exit;\r\n if Result.Right <> nil then\r\n begin\r\n Result := Result.Right;\r\n while (Result.Left <> nil) do\r\n Result := Result.Left;\r\n end\r\n else\r\n begin\r\n LastRet := Result;\r\n Result := Result.Parent;\r\n while (Result <> nil) and (Result.Right = LastRet) do\r\n begin\r\n LastRet := Result;\r\n Result := Result.Parent;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJclInOrderExtendedBinaryTreeIterator.GetPreviousCursor: TJclExtendedBinaryNode;\r\nvar\r\n LastRet: TJclExtendedBinaryNode;\r\nbegin\r\n Result := FCursor;\r\n if Result = nil then\r\n Exit;\r\n if Result.Left <> nil then\r\n begin\r\n Result := Result.Left;\r\n while Result.Right <> nil do\r\n Result := Result.Right;\r\n end\r\n else\r\n begin\r\n LastRet := Result;\r\n Result := Result.Parent;\r\n while (Result <> nil) and (Result.Right <> LastRet) do // Come from Left\r\n begin\r\n LastRet := Result;\r\n Result := Result.Parent;\r\n end;\r\n end;\r\nend;\r\n\r\n//=== { TJclPostOrderExtendedBinaryTreeIterator } ==================================================\r\n\r\nfunction TJclPostOrderExtendedBinaryTreeIterator.CreateEmptyIterator: TJclAbstractIterator;\r\nbegin\r\n Result := TJclPostOrderExtendedBinaryTreeIterator.Create(FOwnTree, FCursor, Valid, FStart);\r\nend;\r\n\r\nfunction TJclPostOrderExtendedBinaryTreeIterator.GetNextCursor: TJclExtendedBinaryNode;\r\nvar\r\n LastRet: TJclExtendedBinaryNode;\r\nbegin\r\n Result := FCursor;\r\n if Result = nil then\r\n Exit;\r\n LastRet := Result;\r\n Result := Result.Parent;\r\n if (Result <> nil) and (Result.Right <> nil) and (Result.Right <> LastRet) then\r\n begin\r\n Result := Result.Right;\r\n while (Result.Left <> nil) or (Result.Right <> nil) do\r\n begin\r\n if Result.Left <> nil then\r\n Result := Result.Left\r\n else\r\n Result := Result.Right;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJclPostOrderExtendedBinaryTreeIterator.GetPreviousCursor: TJclExtendedBinaryNode;\r\nvar\r\n LastRet: TJclExtendedBinaryNode;\r\nbegin\r\n Result := FCursor;\r\n if Result = nil then\r\n Exit;\r\n if Result.Right <> nil then\r\n Result := Result.Right\r\n else\r\n if Result.Left <> nil then\r\n Result := Result.Left\r\n else\r\n begin\r\n LastRet := Result;\r\n Result := Result.Parent;\r\n while (Result <> nil) and ((Result.Left = nil) or (Result.Left = LastRet)) do\r\n begin\r\n LastRet := Result;\r\n Result := Result.Parent;\r\n end;\r\n if Result <> nil then // not root\r\n Result := Result.Left;\r\n end;\r\nend;\r\n\r\n//=== { TJclIntegerBinaryTree } =================================================\r\n\r\nconstructor TJclIntegerBinaryTree.Create(ACompare: TIntegerCompare);\r\nbegin\r\n inherited Create();\r\n FTraverseOrder := toOrder;\r\n FMaxDepth := 0;\r\n FAutoPackParameter := 2;\r\n SetCompare(ACompare);\r\nend;\r\n\r\ndestructor TJclIntegerBinaryTree.Destroy;\r\nbegin\r\n FReadOnly := False;\r\n Clear;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJclIntegerBinaryTree.Add(AValue: Integer): Boolean;\r\nvar\r\n NewNode, Current, Save: TJclIntegerBinaryNode;\r\n Comp, Depth: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n // Insert into right place\r\n if FAllowDefaultElements or not ItemsEqual(AValue, 0) then\r\n begin\r\n Save := nil;\r\n Current := FRoot;\r\n Comp := 1;\r\n Depth := 0;\r\n while Current <> nil do\r\n begin\r\n Inc(Depth);\r\n Save := Current;\r\n Comp := ItemsCompare(AValue, Current.Value);\r\n if Comp < 0 then\r\n Current := Current.Left\r\n else\r\n if Comp > 0 then\r\n Current := Current.Right\r\n else\r\n if CheckDuplicate then\r\n Current := Current.Left // arbitrary decision\r\n else\r\n Break;\r\n end;\r\n if (Comp <> 0) or CheckDuplicate then\r\n begin\r\n NewNode := TJclIntegerBinaryNode.Create;\r\n NewNode.Value := AValue;\r\n NewNode.Parent := Save;\r\n if Save = nil then\r\n FRoot := NewNode\r\n else\r\n if ItemsCompare(NewNode.Value, Save.Value) <= 0 then\r\n Save.Left := NewNode\r\n else\r\n Save.Right := NewNode;\r\n Inc(FSize);\r\n Inc(Depth);\r\n if Depth > FMaxDepth then\r\n FMaxDepth := Depth;\r\n Result := True;\r\n AutoPack;\r\n end\r\n else\r\n Result := False;\r\n end\r\n else\r\n Result := False;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntegerBinaryTree.AddAll(const ACollection: IJclIntegerCollection): Boolean;\r\nvar\r\n It: IJclIntegerIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n Result := Add(It.Next) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclIntegerBinaryTree.AssignDataTo(Dest: TJclAbstractContainerBase);\r\nvar\r\n ADest: TJclIntegerBinaryTree;\r\n ACollection: IJclIntegerCollection;\r\nbegin\r\n inherited AssignDataTo(Dest);\r\n if Dest is TJclIntegerBinaryTree then\r\n begin\r\n ADest := TJclIntegerBinaryTree(Dest);\r\n ADest.Clear;\r\n ADest.FSize := FSize;\r\n if FRoot <> nil then\r\n ADest.FRoot := CloneNode(FRoot, nil);\r\n end\r\n else\r\n if Supports(IInterface(Dest), IJclIntegerCollection, ACollection) then\r\n begin\r\n ACollection.Clear;\r\n ACollection.AddAll(Self);\r\n end;\r\nend;\r\n\r\nprocedure TJclIntegerBinaryTree.AssignPropertiesTo(Dest: TJclAbstractContainerBase);\r\nbegin\r\n inherited AssignPropertiesto(Dest);\r\n if Dest is TJclIntegerBinaryTree then\r\n TJclIntegerBinaryTree(Dest).FTraverseOrder := FTraverseOrder;\r\nend;\r\n\r\nprocedure TJclIntegerBinaryTree.AutoPack;\r\nbegin\r\n case FAutoPackStrategy of\r\n //apsDisabled: ;\r\n apsAgressive:\r\n if (FMaxDepth > 1) and (((1 shl (FMaxDepth - 1)) - 1) > FSize) then\r\n Pack;\r\n // apsIncremental: ;\r\n apsProportional:\r\n if (FMaxDepth > FAutoPackParameter) and (((1 shl (FMaxDepth - FAutoPackParameter)) - 1) > FSize) then\r\n Pack;\r\n end;\r\nend;\r\n\r\nfunction TJclIntegerBinaryTree.BuildTree(const LeafArray: array of TJclIntegerBinaryNode; Left, Right: Integer; Parent: TJclIntegerBinaryNode;\r\n Offset: Integer): TJclIntegerBinaryNode;\r\nvar\r\n Middle: Integer;\r\nbegin\r\n Middle := (Left + Right + Offset) shr 1;\r\n Result := LeafArray[Middle];\r\n Result.Parent := Parent;\r\n if Middle > Left then\r\n Result.Left := BuildTree(LeafArray, Left, Middle - 1, Result, 0)\r\n else\r\n Result.Left := nil;\r\n if Middle < Right then\r\n Result.Right := BuildTree(LeafArray, Middle + 1, Right, Result, 1)\r\n else\r\n Result.Right := nil;\r\nend;\r\n\r\nprocedure TJclIntegerBinaryTree.Clear;\r\nvar\r\n Current, Parent: TJclIntegerBinaryNode;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n // postorder\r\n Current := FRoot;\r\n if Current = nil then\r\n Exit;\r\n // find first in post-order\r\n while (Current.Left <> nil) or (Current.Right <> nil) do\r\n begin\r\n if Current.Left <> nil then\r\n Current := Current.Left\r\n else\r\n Current := Current.Right;\r\n end;\r\n // for all items in the tree in post-order\r\n repeat\r\n Parent := Current.Parent;\r\n // remove reference\r\n if Parent <> nil then\r\n begin\r\n if Parent.Left = Current then\r\n Parent.Left := nil\r\n else\r\n if Parent.Right = Current then\r\n Parent.Right := nil;\r\n end;\r\n\r\n // free item\r\n FreeInteger(Current.Value);\r\n Current.Free;\r\n\r\n // find next item\r\n Current := Parent;\r\n if (Current <> nil) and (Current.Right <> nil) then\r\n begin\r\n Current := Current.Right;\r\n while (Current.Left <> nil) or (Current.Right <> nil) do\r\n begin\r\n if Current.Left <> nil then\r\n Current := Current.Left\r\n else\r\n Current := Current.Right;\r\n end;\r\n end;\r\n until Current = nil;\r\n FRoot := nil;\r\n FSize := 0;\r\n FMaxDepth := 0;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntegerBinaryTree.CloneNode(Node, Parent: TJclIntegerBinaryNode): TJclIntegerBinaryNode;\r\nbegin\r\n Result := TJclIntegerBinaryNode.Create;\r\n Result.Value := Node.Value;\r\n Result.Parent := Parent;\r\n if Node.Left <> nil then\r\n Result.Left := CloneNode(Node.Left, Result); // recursive call\r\n if Node.Right <> nil then\r\n Result.Right := CloneNode(Node.Right, Result); // recursive call\r\nend;\r\n\r\nfunction TJclIntegerBinaryTree.CollectionEquals(const ACollection: IJclIntegerCollection): Boolean;\r\nvar\r\n It, ItSelf: IJclIntegerIterator;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n if FSize <> ACollection.Size then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n ItSelf := First;\r\n while ItSelf.HasNext do\r\n if not ItemsEqual(ItSelf.Next, It.Next) then\r\n begin\r\n Result := False;\r\n Break;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntegerBinaryTree.Contains(AValue: Integer): Boolean;\r\nvar\r\n Comp: Integer;\r\n Current: TJclIntegerBinaryNode;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n Current := FRoot;\r\n while Current <> nil do\r\n begin\r\n Comp := ItemsCompare(Current.Value, AValue);\r\n if Comp = 0 then\r\n begin\r\n Result := True;\r\n Break;\r\n end\r\n else\r\n if Comp > 0 then\r\n Current := Current.Left\r\n else\r\n Current := Current.Right;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntegerBinaryTree.ContainsAll(const ACollection: IJclIntegerCollection): Boolean;\r\nvar\r\n It: IJclIntegerIterator;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := True;\r\n if ACollection = nil then\r\n Exit;\r\n It := ACollection.First;\r\n while Result and It.HasNext do\r\n Result := Contains(It.Next);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntegerBinaryTree.Extract(AValue: Integer): Boolean;\r\nvar\r\n Current, Successor: TJclIntegerBinaryNode;\r\n Comp: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n // locate AValue in the tree\r\n Current := FRoot;\r\n repeat\r\n while Current <> nil do\r\n begin\r\n Comp := ItemsCompare(AValue, Current.Value);\r\n if Comp = 0 then\r\n Break\r\n else\r\n if Comp < 0 then\r\n Current := Current.Left\r\n else\r\n Current := Current.Right;\r\n end;\r\n if Current = nil then\r\n Break;\r\n Result := True;\r\n // Remove Current from tree\r\n if (Current.Left = nil) and (Current.Right <> nil) then\r\n begin\r\n // remove references to Current\r\n Current.Right.Parent := Current.Parent;\r\n if Current.Parent <> nil then\r\n begin\r\n if Current.Parent.Left = Current then\r\n Current.Parent.Left := Current.Right\r\n else\r\n Current.Parent.Right := Current.Right;\r\n end\r\n else\r\n // fix root\r\n FRoot := Current.Right;\r\n Successor := Current.Parent;\r\n if Successor = nil then\r\n Successor := FRoot;\r\n end\r\n else\r\n if (Current.Left <> nil) and (Current.Right = nil) then\r\n begin\r\n // remove references to Current\r\n Current.Left.Parent := Current.Parent;\r\n if Current.Parent <> nil then\r\n begin\r\n if Current.Parent.Left = Current then\r\n Current.Parent.Left := Current.Left\r\n else\r\n Current.Parent.Right := Current.Left;\r\n end\r\n else\r\n // fix root\r\n FRoot := Current.Left;\r\n Successor := Current.Parent;\r\n if Successor = nil then\r\n Successor := FRoot;\r\n end\r\n else\r\n if (Current.Left <> nil) and (Current.Right <> nil) then\r\n begin\r\n // find the successor in tree\r\n Successor := Current.Right;\r\n while Successor.Left <> nil do\r\n Successor := Successor.Left;\r\n\r\n if Successor <> Current.Right then\r\n begin\r\n // remove references to successor\r\n Successor.Parent.Left := Successor.Right;\r\n if Successor.Right <> nil then\r\n Successor.Right.Parent := Successor.Parent;\r\n Successor.Right := Current.Right;\r\n if Successor.Right <> nil then\r\n Successor.Right.Parent := Successor;\r\n end;\r\n\r\n // insert successor in new position\r\n Successor.Left := Current.Left;\r\n if Current.Left <> nil then\r\n Current.Left.Parent := Successor;\r\n Successor.Parent := Current.Parent;\r\n if Current.Parent <> nil then\r\n begin\r\n if Current.Parent.Left = Current then\r\n Current.Parent.Left := Successor\r\n else\r\n Current.Parent.Right := Successor;\r\n end\r\n else\r\n // fix root\r\n FRoot := Successor;\r\n Successor := Current.Parent;\r\n if Successor <> nil then\r\n Successor := FRoot;\r\n end\r\n else\r\n begin\r\n // (Current.Left = nil) and (Current.Right = nil)\r\n Successor := Current.Parent;\r\n if Successor <> nil then\r\n begin\r\n // remove references from parent\r\n if Successor.Left = Current then\r\n Successor.Left := nil\r\n else\r\n Successor.Right := nil;\r\n end\r\n else\r\n FRoot := nil;\r\n end;\r\n Current.Value := 0;\r\n Current.Free;\r\n Dec(FSize);\r\n Current := Successor;\r\n until FRemoveSingleElement or (Current = nil);\r\n AutoPack;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntegerBinaryTree.ExtractAll(const ACollection: IJclIntegerCollection): Boolean;\r\nvar\r\n It: IJclIntegerIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n Result := Extract(It.Next) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntegerBinaryTree.First: IJclIntegerIterator;\r\nvar\r\n Start: TJclIntegerBinaryNode;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Start := FRoot;\r\n case GetTraverseOrder of\r\n toPreOrder:\r\n Result := TJclPreOrderIntegerBinaryTreeIterator.Create(Self, Start, False, isFirst);\r\n toOrder:\r\n begin\r\n if Start <> nil then\r\n while Start.Left <> nil do\r\n Start := Start.Left;\r\n Result := TJclInOrderIntegerBinaryTreeIterator.Create(Self, Start, False, isFirst);\r\n end;\r\n toPostOrder:\r\n begin\r\n if Start <> nil then\r\n while (Start.Left <> nil) or (Start.Right <> nil) do\r\n begin\r\n if Start.Left <> nil then\r\n Start := Start.Left\r\n else\r\n Start := Start.Right;\r\n end;\r\n Result := TJclPostOrderIntegerBinaryTreeIterator.Create(Self, Start, False, isFirst);\r\n end;\r\n else\r\n Result := nil;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\n{$IFDEF SUPPORTS_FOR_IN}\r\nfunction TJclIntegerBinaryTree.GetEnumerator: IJclIntegerIterator;\r\nbegin\r\n Result := First;\r\nend;\r\n{$ENDIF SUPPORTS_FOR_IN}\r\n\r\nfunction TJclIntegerBinaryTree.GetRoot: IJclIntegerTreeIterator;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n case GetTraverseOrder of\r\n toPreOrder:\r\n Result := TJclPreOrderIntegerBinaryTreeIterator.Create(Self, FRoot, False, isRoot);\r\n toOrder:\r\n Result := TJclInOrderIntegerBinaryTreeIterator.Create(Self, FRoot, False, isRoot);\r\n toPostOrder:\r\n Result := TJclPostOrderIntegerBinaryTreeIterator.Create(Self, FRoot, False, isRoot);\r\n else\r\n Result := nil;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntegerBinaryTree.GetTraverseOrder: TJclTraverseOrder;\r\nbegin\r\n Result := FTraverseOrder;\r\nend;\r\n\r\nfunction TJclIntegerBinaryTree.IsEmpty: Boolean;\r\nbegin\r\n Result := FSize = 0;\r\nend;\r\n\r\nfunction TJclIntegerBinaryTree.Last: IJclIntegerIterator;\r\nvar\r\n Start: TJclIntegerBinaryNode;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Start := FRoot;\r\n case FTraverseOrder of\r\n toPreOrder:\r\n begin\r\n if Start <> nil then\r\n while (Start.Left <> nil) or (Start.Right <> nil) do\r\n begin\r\n if Start.Right <> nil then\r\n Start := Start.Right\r\n else\r\n Start := Start.Left;\r\n end;\r\n Result := TJclPreOrderIntegerBinaryTreeIterator.Create(Self, Start, False, isLast);\r\n end;\r\n toOrder:\r\n begin\r\n if Start <> nil then\r\n while Start.Right <> nil do\r\n Start := Start.Right;\r\n Result := TJclInOrderIntegerBinaryTreeIterator.Create(Self, Start, False, isLast);\r\n end;\r\n toPostOrder:\r\n Result := TJclPostOrderIntegerBinaryTreeIterator.Create(Self, Start, False, isLast);\r\n else\r\n Result := nil;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclIntegerBinaryTree.Pack;\r\nvar\r\n LeafArray: array of TJclIntegerBinaryNode;\r\n ANode, BNode: TJclIntegerBinaryNode;\r\n Index: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n SetLength(Leafarray, FSize);\r\n try\r\n // in order enumeration of nodes\r\n ANode := FRoot;\r\n if ANode <> nil then\r\n begin\r\n // find first node\r\n while ANode.Left <> nil do\r\n ANode := ANode.Left;\r\n\r\n Index := 0;\r\n while ANode <> nil do\r\n begin\r\n LeafArray[Index] := ANode;\r\n Inc(Index);\r\n if ANode.Right <> nil then\r\n begin\r\n ANode := ANode.Right;\r\n while (ANode.Left <> nil) do\r\n ANode := ANode.Left;\r\n end\r\n else\r\n begin\r\n BNode := ANode;\r\n ANode := ANode.Parent;\r\n while (ANode <> nil) and (ANode.Right = BNode) do\r\n begin\r\n BNode := ANode;\r\n ANode := ANode.Parent;\r\n end;\r\n end;\r\n end;\r\n\r\n Index := FSize shr 1;\r\n FRoot := LeafArray[Index];\r\n FRoot.Parent := nil;\r\n if Index > 0 then\r\n FRoot.Left := BuildTree(LeafArray, 0, Index - 1, FRoot, 0)\r\n else\r\n FRoot.Left := nil;\r\n if Index < (FSize - 1) then\r\n FRoot.Right := BuildTree(LeafArray, Index + 1, FSize - 1, FRoot, 1)\r\n else\r\n FRoot.Right := nil;\r\n end;\r\n finally\r\n SetLength(LeafArray, 0);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntegerBinaryTree.Remove(AValue: Integer): Boolean;\r\nvar\r\n Extracted: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := Extract(AValue);\r\n if Result then\r\n begin\r\n Extracted := AValue;\r\n FreeInteger(Extracted);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntegerBinaryTree.RemoveAll(const ACollection: IJclIntegerCollection): Boolean;\r\nvar\r\n It: IJclIntegerIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n Result := Remove(It.Next) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntegerBinaryTree.RetainAll(const ACollection: IJclIntegerCollection): Boolean;\r\nvar\r\n It: IJclIntegerIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := First;\r\n while It.HasNext do\r\n if not ACollection.Contains(It.Next) then\r\n It.Remove;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclIntegerBinaryTree.SetCapacity(Value: Integer);\r\nbegin\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nprocedure TJclIntegerBinaryTree.SetTraverseOrder(Value: TJclTraverseOrder);\r\nbegin\r\n FTraverseOrder := Value;\r\nend;\r\n\r\nfunction TJclIntegerBinaryTree.Size: Integer;\r\nbegin\r\n Result := FSize;\r\nend;\r\n\r\nfunction TJclIntegerBinaryTree.CreateEmptyContainer: TJclAbstractContainerBase;\r\nbegin\r\n Result := TJclIntegerBinaryTree.Create(Compare);\r\n AssignPropertiesTo(Result);\r\nend;\r\n\r\n//=== { TJclIntegerBinaryTreeIterator } ===========================================================\r\n\r\nconstructor TJclIntegerBinaryTreeIterator.Create(const AOwnTree: IJclIntegerCollection; ACursor: TJclIntegerBinaryNode; AValid: Boolean; AStart: TItrStart);\r\nbegin\r\n inherited Create(AValid);\r\n FCursor := ACursor;\r\n FStart := AStart;\r\n FOwnTree := AOwnTree;\r\n FEqualityComparer := AOwnTree as IJclIntegerEqualityComparer;\r\nend;\r\n\r\nfunction TJclIntegerBinaryTreeIterator.Add(AValue: Integer): Boolean;\r\nbegin\r\n Result := FOwnTree.Add(AValue);\r\nend;\r\n\r\nfunction TJclIntegerBinaryTreeIterator.AddChild(AValue: Integer): Boolean;\r\nbegin\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nprocedure TJclIntegerBinaryTreeIterator.AssignPropertiesTo(Dest: TJclAbstractIterator);\r\nvar\r\n ADest: TJclIntegerBinaryTreeIterator;\r\nbegin\r\n inherited AssignPropertiesTo(Dest);\r\n if Dest is TJclIntegerBinaryTreeIterator then\r\n begin\r\n ADest := TJclIntegerBinaryTreeIterator(Dest);\r\n ADest.FCursor := FCursor;\r\n ADest.FOwnTree := FOwnTree;\r\n ADest.FEqualityComparer := FEqualityComparer;\r\n ADest.FStart := FStart;\r\n end;\r\nend;\r\n\r\nfunction TJclIntegerBinaryTreeIterator.ChildrenCount: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := 0;\r\n if FCursor <> nil then\r\n begin\r\n if FCursor.Left <> nil then\r\n Inc(Result);\r\n if FCursor.Right <> nil then\r\n Inc(Result);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclIntegerBinaryTreeIterator.DeleteChild(Index: Integer);\r\nbegin\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nprocedure TJclIntegerBinaryTreeIterator.DeleteChildren;\r\nbegin\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nprocedure TJclIntegerBinaryTreeIterator.Extract;\r\nvar\r\n OldCursor: TJclIntegerBinaryNode;\r\nbegin\r\n if FOwnTree.ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n CheckValid;\r\n Valid := False;\r\n OldCursor := FCursor;\r\n if OldCursor <> nil then\r\n begin\r\n repeat\r\n FCursor := GetNextCursor;\r\n until (FCursor = nil) or FOwnTree.RemoveSingleElement\r\n or (not FEqualityComparer.ItemsEqual(OldCursor.Value, FCursor.Value));\r\n FOwnTree.Extract(OldCursor.Value);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.WriteUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclIntegerBinaryTreeIterator.ExtractChild(Index: Integer);\r\nbegin\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nprocedure TJclIntegerBinaryTreeIterator.ExtractChildren;\r\nbegin\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nfunction TJclIntegerBinaryTreeIterator.GetChild(Index: Integer): Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := 0;\r\n if (FCursor <> nil) and (Index = 0) and (FCursor.Left <> nil) then\r\n FCursor := FCursor.Left\r\n else\r\n if (FCursor <> nil) and (Index = 0) then\r\n FCursor := FCursor.Right\r\n else\r\n if (FCursor <> nil) and (Index = 1) then\r\n FCursor := FCursor.Right\r\n else\r\n FCursor := nil;\r\n if FCursor <> nil then\r\n Result := FCursor.Value\r\n else\r\n if not FOwnTree.ReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntegerBinaryTreeIterator.GetValue: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n CheckValid;\r\n Result := 0;\r\n if FCursor <> nil then\r\n Result := FCursor.Value\r\n else\r\n if not FOwnTree.ReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntegerBinaryTreeIterator.HasChild(Index: Integer): Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if (FCursor <> nil) and (Index = 0) then\r\n Result := (FCursor.Left <> nil) or (FCursor.Right <> nil)\r\n else\r\n if (FCursor <> nil) and (Index = 1) then\r\n Result := (FCursor.Left <> nil) and (FCursor.Right <> nil)\r\n else\r\n Result := False;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntegerBinaryTreeIterator.HasLeft: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := (FCursor <> nil) and (FCursor.Left <> nil);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntegerBinaryTreeIterator.HasNext: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Valid then\r\n Result := GetNextCursor <> nil\r\n else\r\n Result := FCursor <> nil;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntegerBinaryTreeIterator.HasParent: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := (FCursor <> nil) and (FCursor.Parent <> nil);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntegerBinaryTreeIterator.HasPrevious: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Valid then\r\n Result := GetPreviousCursor <> nil\r\n else\r\n Result := FCursor <> nil;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntegerBinaryTreeIterator.HasRight: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := (FCursor <> nil) and (FCursor.Right <> nil);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntegerBinaryTreeIterator.IndexOfChild(AValue: Integer): Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := -1;\r\n if FCursor <> nil then\r\n begin\r\n if FCursor.Left <> nil then\r\n begin\r\n if FEqualityComparer.ItemsEqual(FCursor.Left.Value, AValue) then\r\n Result := 0\r\n else\r\n if (FCursor.Right <> nil) and FEqualityComparer.ItemsEqual(FCursor.Right.Value, AValue) then\r\n Result := 1;\r\n end\r\n else\r\n if (FCursor.Right <> nil) and FEqualityComparer.ItemsEqual(FCursor.Right.Value, AValue) then\r\n Result := 0;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntegerBinaryTreeIterator.Insert(AValue: Integer): Boolean;\r\nbegin\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nfunction TJclIntegerBinaryTreeIterator.InsertChild(Index: Integer; AValue: Integer): Boolean;\r\nbegin\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nfunction TJclIntegerBinaryTreeIterator.IteratorEquals(const AIterator: IJclIntegerIterator): Boolean;\r\nvar\r\n Obj: TObject;\r\n ItrObj: TJclIntegerBinaryTreeIterator;\r\nbegin\r\n Result := False;\r\n if AIterator = nil then\r\n Exit;\r\n Obj := AIterator.GetIteratorReference;\r\n if Obj is TJclIntegerBinaryTreeIterator then\r\n begin\r\n ItrObj := TJclIntegerBinaryTreeIterator(Obj);\r\n Result := (FOwnTree = ItrObj.FOwnTree) and (FCursor = ItrObj.FCursor) and (Valid = ItrObj.Valid);\r\n end;\r\nend;\r\n\r\nfunction TJclIntegerBinaryTreeIterator.Left: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := 0;\r\n if FCursor <> nil then\r\n FCursor := FCursor.Left;\r\n if FCursor <> nil then\r\n Result := FCursor.Value\r\n else\r\n if not FOwnTree.ReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\n{$IFDEF SUPPORTS_FOR_IN}\r\nfunction TJclIntegerBinaryTreeIterator.MoveNext: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Valid then\r\n FCursor := GetNextCursor\r\n else\r\n Valid := True;\r\n Result := FCursor <> nil;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n{$ENDIF SUPPORTS_FOR_IN}\r\n\r\nfunction TJclIntegerBinaryTreeIterator.Next: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Valid then\r\n FCursor := GetNextCursor\r\n else\r\n Valid := True;\r\n Result := 0;\r\n if FCursor <> nil then\r\n Result := FCursor.Value\r\n else\r\n if not FOwnTree.ReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntegerBinaryTreeIterator.NextIndex: Integer;\r\nbegin\r\n // No index\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nfunction TJclIntegerBinaryTreeIterator.Parent: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := 0;\r\n if FCursor <> nil then\r\n FCursor := FCursor.Parent;\r\n if FCursor <> nil then\r\n Result := FCursor.Value\r\n else\r\n if not FOwnTree.ReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntegerBinaryTreeIterator.Previous: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Valid then\r\n FCursor := GetPreviousCursor\r\n else\r\n Valid := True;\r\n Result := 0;\r\n if FCursor <> nil then\r\n Result := FCursor.Value\r\n else\r\n if not FOwnTree.ReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntegerBinaryTreeIterator.PreviousIndex: Integer;\r\nbegin\r\n // No index\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nprocedure TJclIntegerBinaryTreeIterator.Remove;\r\nvar\r\n OldCursor: TJclIntegerBinaryNode;\r\nbegin\r\n if FOwnTree.ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n CheckValid;\r\n Valid := False;\r\n OldCursor := FCursor;\r\n if OldCursor <> nil then\r\n begin\r\n repeat\r\n FCursor := GetNextCursor;\r\n until (FCursor = nil) or FOwnTree.RemoveSingleElement\r\n or (not FEqualityComparer.ItemsEqual(OldCursor.Value, FCursor.Value));\r\n FOwnTree.Remove(OldCursor.Value);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.WriteUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclIntegerBinaryTreeIterator.Reset;\r\nvar\r\n NewCursor: TJclIntegerBinaryNode;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Valid := False;\r\n case FStart of\r\n isFirst:\r\n begin\r\n NewCursor := FCursor;\r\n while NewCursor <> nil do\r\n begin\r\n NewCursor := GetPreviousCursor;\r\n if NewCursor <> nil then\r\n FCursor := NewCursor;\r\n end;\r\n end;\r\n isLast:\r\n begin\r\n NewCursor := FCursor;\r\n while NewCursor <> nil do\r\n begin\r\n NewCursor := GetNextCursor;\r\n if NewCursor <> nil then\r\n FCursor := NewCursor;\r\n end;\r\n end;\r\n isRoot:\r\n begin\r\n while (FCursor <> nil) and (FCursor.Parent <> nil) do\r\n FCursor := FCursor.Parent;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntegerBinaryTreeIterator.Right: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := 0;\r\n if FCursor <> nil then\r\n FCursor := FCursor.Right;\r\n if FCursor <> nil then\r\n Result := FCursor.Value\r\n else\r\n if not FOwnTree.ReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclIntegerBinaryTreeIterator.SetChild(Index: Integer; AValue: Integer);\r\nbegin\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nprocedure TJclIntegerBinaryTreeIterator.SetValue(AValue: Integer);\r\nbegin\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\n//=== { TJclPreOrderIntegerBinaryTreeIterator } ===================================================\r\n\r\nfunction TJclPreOrderIntegerBinaryTreeIterator.CreateEmptyIterator: TJclAbstractIterator;\r\nbegin\r\n Result := TJclPreOrderIntegerBinaryTreeIterator.Create(FOwnTree, FCursor, Valid, FStart);\r\nend;\r\n\r\nfunction TJclPreOrderIntegerBinaryTreeIterator.GetNextCursor: TJclIntegerBinaryNode;\r\nvar\r\n LastRet: TJclIntegerBinaryNode;\r\nbegin\r\n Result := FCursor;\r\n if Result = nil then\r\n Exit;\r\n LastRet := Result;\r\n if Result.Left <> nil then\r\n Result := Result.Left\r\n else\r\n if Result.Right <> nil then\r\n Result := Result.Right\r\n else\r\n begin\r\n Result := Result.Parent;\r\n while (Result <> nil) and ((Result.Right = nil) or (Result.Right = LastRet)) do\r\n begin\r\n LastRet := Result;\r\n Result := Result.Parent;\r\n end;\r\n if Result <> nil then // not root\r\n Result := Result.Right;\r\n end;\r\nend;\r\n\r\nfunction TJclPreOrderIntegerBinaryTreeIterator.GetPreviousCursor: TJclIntegerBinaryNode;\r\nvar\r\n LastRet: TJclIntegerBinaryNode;\r\nbegin\r\n Result := FCursor;\r\n if Result = nil then\r\n Exit;\r\n LastRet := Result;\r\n Result := Result.Parent;\r\n if (Result <> nil) and (Result.Left <> LastRet) and (Result.Left <> nil) then\r\n // come from Right\r\n begin\r\n Result := Result.Left;\r\n while (Result.Left <> nil) or (Result.Right <> nil) do // both childs\r\n begin\r\n if Result.Right <> nil then // right child first\r\n Result := Result.Right\r\n else\r\n Result := Result.Left;\r\n end;\r\n end;\r\nend;\r\n\r\n//=== { TJclInOrderIntegerBinaryTreeIterator } ====================================================\r\n\r\nfunction TJclInOrderIntegerBinaryTreeIterator.CreateEmptyIterator: TJclAbstractIterator;\r\nbegin\r\n Result := TJclInOrderIntegerBinaryTreeIterator.Create(FOwnTree, FCursor, Valid, FStart);\r\nend;\r\n\r\nfunction TJclInOrderIntegerBinaryTreeIterator.GetNextCursor: TJclIntegerBinaryNode;\r\nvar\r\n LastRet: TJclIntegerBinaryNode;\r\nbegin\r\n Result := FCursor;\r\n if Result = nil then\r\n Exit;\r\n if Result.Right <> nil then\r\n begin\r\n Result := Result.Right;\r\n while (Result.Left <> nil) do\r\n Result := Result.Left;\r\n end\r\n else\r\n begin\r\n LastRet := Result;\r\n Result := Result.Parent;\r\n while (Result <> nil) and (Result.Right = LastRet) do\r\n begin\r\n LastRet := Result;\r\n Result := Result.Parent;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJclInOrderIntegerBinaryTreeIterator.GetPreviousCursor: TJclIntegerBinaryNode;\r\nvar\r\n LastRet: TJclIntegerBinaryNode;\r\nbegin\r\n Result := FCursor;\r\n if Result = nil then\r\n Exit;\r\n if Result.Left <> nil then\r\n begin\r\n Result := Result.Left;\r\n while Result.Right <> nil do\r\n Result := Result.Right;\r\n end\r\n else\r\n begin\r\n LastRet := Result;\r\n Result := Result.Parent;\r\n while (Result <> nil) and (Result.Right <> LastRet) do // Come from Left\r\n begin\r\n LastRet := Result;\r\n Result := Result.Parent;\r\n end;\r\n end;\r\nend;\r\n\r\n//=== { TJclPostOrderIntegerBinaryTreeIterator } ==================================================\r\n\r\nfunction TJclPostOrderIntegerBinaryTreeIterator.CreateEmptyIterator: TJclAbstractIterator;\r\nbegin\r\n Result := TJclPostOrderIntegerBinaryTreeIterator.Create(FOwnTree, FCursor, Valid, FStart);\r\nend;\r\n\r\nfunction TJclPostOrderIntegerBinaryTreeIterator.GetNextCursor: TJclIntegerBinaryNode;\r\nvar\r\n LastRet: TJclIntegerBinaryNode;\r\nbegin\r\n Result := FCursor;\r\n if Result = nil then\r\n Exit;\r\n LastRet := Result;\r\n Result := Result.Parent;\r\n if (Result <> nil) and (Result.Right <> nil) and (Result.Right <> LastRet) then\r\n begin\r\n Result := Result.Right;\r\n while (Result.Left <> nil) or (Result.Right <> nil) do\r\n begin\r\n if Result.Left <> nil then\r\n Result := Result.Left\r\n else\r\n Result := Result.Right;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJclPostOrderIntegerBinaryTreeIterator.GetPreviousCursor: TJclIntegerBinaryNode;\r\nvar\r\n LastRet: TJclIntegerBinaryNode;\r\nbegin\r\n Result := FCursor;\r\n if Result = nil then\r\n Exit;\r\n if Result.Right <> nil then\r\n Result := Result.Right\r\n else\r\n if Result.Left <> nil then\r\n Result := Result.Left\r\n else\r\n begin\r\n LastRet := Result;\r\n Result := Result.Parent;\r\n while (Result <> nil) and ((Result.Left = nil) or (Result.Left = LastRet)) do\r\n begin\r\n LastRet := Result;\r\n Result := Result.Parent;\r\n end;\r\n if Result <> nil then // not root\r\n Result := Result.Left;\r\n end;\r\nend;\r\n\r\n//=== { TJclCardinalBinaryTree } =================================================\r\n\r\nconstructor TJclCardinalBinaryTree.Create(ACompare: TCardinalCompare);\r\nbegin\r\n inherited Create();\r\n FTraverseOrder := toOrder;\r\n FMaxDepth := 0;\r\n FAutoPackParameter := 2;\r\n SetCompare(ACompare);\r\nend;\r\n\r\ndestructor TJclCardinalBinaryTree.Destroy;\r\nbegin\r\n FReadOnly := False;\r\n Clear;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJclCardinalBinaryTree.Add(AValue: Cardinal): Boolean;\r\nvar\r\n NewNode, Current, Save: TJclCardinalBinaryNode;\r\n Comp, Depth: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n // Insert into right place\r\n if FAllowDefaultElements or not ItemsEqual(AValue, 0) then\r\n begin\r\n Save := nil;\r\n Current := FRoot;\r\n Comp := 1;\r\n Depth := 0;\r\n while Current <> nil do\r\n begin\r\n Inc(Depth);\r\n Save := Current;\r\n Comp := ItemsCompare(AValue, Current.Value);\r\n if Comp < 0 then\r\n Current := Current.Left\r\n else\r\n if Comp > 0 then\r\n Current := Current.Right\r\n else\r\n if CheckDuplicate then\r\n Current := Current.Left // arbitrary decision\r\n else\r\n Break;\r\n end;\r\n if (Comp <> 0) or CheckDuplicate then\r\n begin\r\n NewNode := TJclCardinalBinaryNode.Create;\r\n NewNode.Value := AValue;\r\n NewNode.Parent := Save;\r\n if Save = nil then\r\n FRoot := NewNode\r\n else\r\n if ItemsCompare(NewNode.Value, Save.Value) <= 0 then\r\n Save.Left := NewNode\r\n else\r\n Save.Right := NewNode;\r\n Inc(FSize);\r\n Inc(Depth);\r\n if Depth > FMaxDepth then\r\n FMaxDepth := Depth;\r\n Result := True;\r\n AutoPack;\r\n end\r\n else\r\n Result := False;\r\n end\r\n else\r\n Result := False;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclCardinalBinaryTree.AddAll(const ACollection: IJclCardinalCollection): Boolean;\r\nvar\r\n It: IJclCardinalIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n Result := Add(It.Next) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclCardinalBinaryTree.AssignDataTo(Dest: TJclAbstractContainerBase);\r\nvar\r\n ADest: TJclCardinalBinaryTree;\r\n ACollection: IJclCardinalCollection;\r\nbegin\r\n inherited AssignDataTo(Dest);\r\n if Dest is TJclCardinalBinaryTree then\r\n begin\r\n ADest := TJclCardinalBinaryTree(Dest);\r\n ADest.Clear;\r\n ADest.FSize := FSize;\r\n if FRoot <> nil then\r\n ADest.FRoot := CloneNode(FRoot, nil);\r\n end\r\n else\r\n if Supports(IInterface(Dest), IJclCardinalCollection, ACollection) then\r\n begin\r\n ACollection.Clear;\r\n ACollection.AddAll(Self);\r\n end;\r\nend;\r\n\r\nprocedure TJclCardinalBinaryTree.AssignPropertiesTo(Dest: TJclAbstractContainerBase);\r\nbegin\r\n inherited AssignPropertiesto(Dest);\r\n if Dest is TJclCardinalBinaryTree then\r\n TJclCardinalBinaryTree(Dest).FTraverseOrder := FTraverseOrder;\r\nend;\r\n\r\nprocedure TJclCardinalBinaryTree.AutoPack;\r\nbegin\r\n case FAutoPackStrategy of\r\n //apsDisabled: ;\r\n apsAgressive:\r\n if (FMaxDepth > 1) and (((1 shl (FMaxDepth - 1)) - 1) > FSize) then\r\n Pack;\r\n // apsIncremental: ;\r\n apsProportional:\r\n if (FMaxDepth > FAutoPackParameter) and (((1 shl (FMaxDepth - FAutoPackParameter)) - 1) > FSize) then\r\n Pack;\r\n end;\r\nend;\r\n\r\nfunction TJclCardinalBinaryTree.BuildTree(const LeafArray: array of TJclCardinalBinaryNode; Left, Right: Integer; Parent: TJclCardinalBinaryNode;\r\n Offset: Integer): TJclCardinalBinaryNode;\r\nvar\r\n Middle: Integer;\r\nbegin\r\n Middle := (Left + Right + Offset) shr 1;\r\n Result := LeafArray[Middle];\r\n Result.Parent := Parent;\r\n if Middle > Left then\r\n Result.Left := BuildTree(LeafArray, Left, Middle - 1, Result, 0)\r\n else\r\n Result.Left := nil;\r\n if Middle < Right then\r\n Result.Right := BuildTree(LeafArray, Middle + 1, Right, Result, 1)\r\n else\r\n Result.Right := nil;\r\nend;\r\n\r\nprocedure TJclCardinalBinaryTree.Clear;\r\nvar\r\n Current, Parent: TJclCardinalBinaryNode;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n // postorder\r\n Current := FRoot;\r\n if Current = nil then\r\n Exit;\r\n // find first in post-order\r\n while (Current.Left <> nil) or (Current.Right <> nil) do\r\n begin\r\n if Current.Left <> nil then\r\n Current := Current.Left\r\n else\r\n Current := Current.Right;\r\n end;\r\n // for all items in the tree in post-order\r\n repeat\r\n Parent := Current.Parent;\r\n // remove reference\r\n if Parent <> nil then\r\n begin\r\n if Parent.Left = Current then\r\n Parent.Left := nil\r\n else\r\n if Parent.Right = Current then\r\n Parent.Right := nil;\r\n end;\r\n\r\n // free item\r\n FreeCardinal(Current.Value);\r\n Current.Free;\r\n\r\n // find next item\r\n Current := Parent;\r\n if (Current <> nil) and (Current.Right <> nil) then\r\n begin\r\n Current := Current.Right;\r\n while (Current.Left <> nil) or (Current.Right <> nil) do\r\n begin\r\n if Current.Left <> nil then\r\n Current := Current.Left\r\n else\r\n Current := Current.Right;\r\n end;\r\n end;\r\n until Current = nil;\r\n FRoot := nil;\r\n FSize := 0;\r\n FMaxDepth := 0;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclCardinalBinaryTree.CloneNode(Node, Parent: TJclCardinalBinaryNode): TJclCardinalBinaryNode;\r\nbegin\r\n Result := TJclCardinalBinaryNode.Create;\r\n Result.Value := Node.Value;\r\n Result.Parent := Parent;\r\n if Node.Left <> nil then\r\n Result.Left := CloneNode(Node.Left, Result); // recursive call\r\n if Node.Right <> nil then\r\n Result.Right := CloneNode(Node.Right, Result); // recursive call\r\nend;\r\n\r\nfunction TJclCardinalBinaryTree.CollectionEquals(const ACollection: IJclCardinalCollection): Boolean;\r\nvar\r\n It, ItSelf: IJclCardinalIterator;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n if FSize <> ACollection.Size then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n ItSelf := First;\r\n while ItSelf.HasNext do\r\n if not ItemsEqual(ItSelf.Next, It.Next) then\r\n begin\r\n Result := False;\r\n Break;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclCardinalBinaryTree.Contains(AValue: Cardinal): Boolean;\r\nvar\r\n Comp: Integer;\r\n Current: TJclCardinalBinaryNode;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n Current := FRoot;\r\n while Current <> nil do\r\n begin\r\n Comp := ItemsCompare(Current.Value, AValue);\r\n if Comp = 0 then\r\n begin\r\n Result := True;\r\n Break;\r\n end\r\n else\r\n if Comp > 0 then\r\n Current := Current.Left\r\n else\r\n Current := Current.Right;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclCardinalBinaryTree.ContainsAll(const ACollection: IJclCardinalCollection): Boolean;\r\nvar\r\n It: IJclCardinalIterator;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := True;\r\n if ACollection = nil then\r\n Exit;\r\n It := ACollection.First;\r\n while Result and It.HasNext do\r\n Result := Contains(It.Next);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclCardinalBinaryTree.Extract(AValue: Cardinal): Boolean;\r\nvar\r\n Current, Successor: TJclCardinalBinaryNode;\r\n Comp: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n // locate AValue in the tree\r\n Current := FRoot;\r\n repeat\r\n while Current <> nil do\r\n begin\r\n Comp := ItemsCompare(AValue, Current.Value);\r\n if Comp = 0 then\r\n Break\r\n else\r\n if Comp < 0 then\r\n Current := Current.Left\r\n else\r\n Current := Current.Right;\r\n end;\r\n if Current = nil then\r\n Break;\r\n Result := True;\r\n // Remove Current from tree\r\n if (Current.Left = nil) and (Current.Right <> nil) then\r\n begin\r\n // remove references to Current\r\n Current.Right.Parent := Current.Parent;\r\n if Current.Parent <> nil then\r\n begin\r\n if Current.Parent.Left = Current then\r\n Current.Parent.Left := Current.Right\r\n else\r\n Current.Parent.Right := Current.Right;\r\n end\r\n else\r\n // fix root\r\n FRoot := Current.Right;\r\n Successor := Current.Parent;\r\n if Successor = nil then\r\n Successor := FRoot;\r\n end\r\n else\r\n if (Current.Left <> nil) and (Current.Right = nil) then\r\n begin\r\n // remove references to Current\r\n Current.Left.Parent := Current.Parent;\r\n if Current.Parent <> nil then\r\n begin\r\n if Current.Parent.Left = Current then\r\n Current.Parent.Left := Current.Left\r\n else\r\n Current.Parent.Right := Current.Left;\r\n end\r\n else\r\n // fix root\r\n FRoot := Current.Left;\r\n Successor := Current.Parent;\r\n if Successor = nil then\r\n Successor := FRoot;\r\n end\r\n else\r\n if (Current.Left <> nil) and (Current.Right <> nil) then\r\n begin\r\n // find the successor in tree\r\n Successor := Current.Right;\r\n while Successor.Left <> nil do\r\n Successor := Successor.Left;\r\n\r\n if Successor <> Current.Right then\r\n begin\r\n // remove references to successor\r\n Successor.Parent.Left := Successor.Right;\r\n if Successor.Right <> nil then\r\n Successor.Right.Parent := Successor.Parent;\r\n Successor.Right := Current.Right;\r\n if Successor.Right <> nil then\r\n Successor.Right.Parent := Successor;\r\n end;\r\n\r\n // insert successor in new position\r\n Successor.Left := Current.Left;\r\n if Current.Left <> nil then\r\n Current.Left.Parent := Successor;\r\n Successor.Parent := Current.Parent;\r\n if Current.Parent <> nil then\r\n begin\r\n if Current.Parent.Left = Current then\r\n Current.Parent.Left := Successor\r\n else\r\n Current.Parent.Right := Successor;\r\n end\r\n else\r\n // fix root\r\n FRoot := Successor;\r\n Successor := Current.Parent;\r\n if Successor <> nil then\r\n Successor := FRoot;\r\n end\r\n else\r\n begin\r\n // (Current.Left = nil) and (Current.Right = nil)\r\n Successor := Current.Parent;\r\n if Successor <> nil then\r\n begin\r\n // remove references from parent\r\n if Successor.Left = Current then\r\n Successor.Left := nil\r\n else\r\n Successor.Right := nil;\r\n end\r\n else\r\n FRoot := nil;\r\n end;\r\n Current.Value := 0;\r\n Current.Free;\r\n Dec(FSize);\r\n Current := Successor;\r\n until FRemoveSingleElement or (Current = nil);\r\n AutoPack;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclCardinalBinaryTree.ExtractAll(const ACollection: IJclCardinalCollection): Boolean;\r\nvar\r\n It: IJclCardinalIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n Result := Extract(It.Next) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclCardinalBinaryTree.First: IJclCardinalIterator;\r\nvar\r\n Start: TJclCardinalBinaryNode;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Start := FRoot;\r\n case GetTraverseOrder of\r\n toPreOrder:\r\n Result := TJclPreOrderCardinalBinaryTreeIterator.Create(Self, Start, False, isFirst);\r\n toOrder:\r\n begin\r\n if Start <> nil then\r\n while Start.Left <> nil do\r\n Start := Start.Left;\r\n Result := TJclInOrderCardinalBinaryTreeIterator.Create(Self, Start, False, isFirst);\r\n end;\r\n toPostOrder:\r\n begin\r\n if Start <> nil then\r\n while (Start.Left <> nil) or (Start.Right <> nil) do\r\n begin\r\n if Start.Left <> nil then\r\n Start := Start.Left\r\n else\r\n Start := Start.Right;\r\n end;\r\n Result := TJclPostOrderCardinalBinaryTreeIterator.Create(Self, Start, False, isFirst);\r\n end;\r\n else\r\n Result := nil;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\n{$IFDEF SUPPORTS_FOR_IN}\r\nfunction TJclCardinalBinaryTree.GetEnumerator: IJclCardinalIterator;\r\nbegin\r\n Result := First;\r\nend;\r\n{$ENDIF SUPPORTS_FOR_IN}\r\n\r\nfunction TJclCardinalBinaryTree.GetRoot: IJclCardinalTreeIterator;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n case GetTraverseOrder of\r\n toPreOrder:\r\n Result := TJclPreOrderCardinalBinaryTreeIterator.Create(Self, FRoot, False, isRoot);\r\n toOrder:\r\n Result := TJclInOrderCardinalBinaryTreeIterator.Create(Self, FRoot, False, isRoot);\r\n toPostOrder:\r\n Result := TJclPostOrderCardinalBinaryTreeIterator.Create(Self, FRoot, False, isRoot);\r\n else\r\n Result := nil;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclCardinalBinaryTree.GetTraverseOrder: TJclTraverseOrder;\r\nbegin\r\n Result := FTraverseOrder;\r\nend;\r\n\r\nfunction TJclCardinalBinaryTree.IsEmpty: Boolean;\r\nbegin\r\n Result := FSize = 0;\r\nend;\r\n\r\nfunction TJclCardinalBinaryTree.Last: IJclCardinalIterator;\r\nvar\r\n Start: TJclCardinalBinaryNode;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Start := FRoot;\r\n case FTraverseOrder of\r\n toPreOrder:\r\n begin\r\n if Start <> nil then\r\n while (Start.Left <> nil) or (Start.Right <> nil) do\r\n begin\r\n if Start.Right <> nil then\r\n Start := Start.Right\r\n else\r\n Start := Start.Left;\r\n end;\r\n Result := TJclPreOrderCardinalBinaryTreeIterator.Create(Self, Start, False, isLast);\r\n end;\r\n toOrder:\r\n begin\r\n if Start <> nil then\r\n while Start.Right <> nil do\r\n Start := Start.Right;\r\n Result := TJclInOrderCardinalBinaryTreeIterator.Create(Self, Start, False, isLast);\r\n end;\r\n toPostOrder:\r\n Result := TJclPostOrderCardinalBinaryTreeIterator.Create(Self, Start, False, isLast);\r\n else\r\n Result := nil;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclCardinalBinaryTree.Pack;\r\nvar\r\n LeafArray: array of TJclCardinalBinaryNode;\r\n ANode, BNode: TJclCardinalBinaryNode;\r\n Index: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n SetLength(Leafarray, FSize);\r\n try\r\n // in order enumeration of nodes\r\n ANode := FRoot;\r\n if ANode <> nil then\r\n begin\r\n // find first node\r\n while ANode.Left <> nil do\r\n ANode := ANode.Left;\r\n\r\n Index := 0;\r\n while ANode <> nil do\r\n begin\r\n LeafArray[Index] := ANode;\r\n Inc(Index);\r\n if ANode.Right <> nil then\r\n begin\r\n ANode := ANode.Right;\r\n while (ANode.Left <> nil) do\r\n ANode := ANode.Left;\r\n end\r\n else\r\n begin\r\n BNode := ANode;\r\n ANode := ANode.Parent;\r\n while (ANode <> nil) and (ANode.Right = BNode) do\r\n begin\r\n BNode := ANode;\r\n ANode := ANode.Parent;\r\n end;\r\n end;\r\n end;\r\n\r\n Index := FSize shr 1;\r\n FRoot := LeafArray[Index];\r\n FRoot.Parent := nil;\r\n if Index > 0 then\r\n FRoot.Left := BuildTree(LeafArray, 0, Index - 1, FRoot, 0)\r\n else\r\n FRoot.Left := nil;\r\n if Index < (FSize - 1) then\r\n FRoot.Right := BuildTree(LeafArray, Index + 1, FSize - 1, FRoot, 1)\r\n else\r\n FRoot.Right := nil;\r\n end;\r\n finally\r\n SetLength(LeafArray, 0);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclCardinalBinaryTree.Remove(AValue: Cardinal): Boolean;\r\nvar\r\n Extracted: Cardinal;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := Extract(AValue);\r\n if Result then\r\n begin\r\n Extracted := AValue;\r\n FreeCardinal(Extracted);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclCardinalBinaryTree.RemoveAll(const ACollection: IJclCardinalCollection): Boolean;\r\nvar\r\n It: IJclCardinalIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n Result := Remove(It.Next) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclCardinalBinaryTree.RetainAll(const ACollection: IJclCardinalCollection): Boolean;\r\nvar\r\n It: IJclCardinalIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := First;\r\n while It.HasNext do\r\n if not ACollection.Contains(It.Next) then\r\n It.Remove;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclCardinalBinaryTree.SetCapacity(Value: Integer);\r\nbegin\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nprocedure TJclCardinalBinaryTree.SetTraverseOrder(Value: TJclTraverseOrder);\r\nbegin\r\n FTraverseOrder := Value;\r\nend;\r\n\r\nfunction TJclCardinalBinaryTree.Size: Integer;\r\nbegin\r\n Result := FSize;\r\nend;\r\n\r\nfunction TJclCardinalBinaryTree.CreateEmptyContainer: TJclAbstractContainerBase;\r\nbegin\r\n Result := TJclCardinalBinaryTree.Create(Compare);\r\n AssignPropertiesTo(Result);\r\nend;\r\n\r\n//=== { TJclCardinalBinaryTreeIterator } ===========================================================\r\n\r\nconstructor TJclCardinalBinaryTreeIterator.Create(const AOwnTree: IJclCardinalCollection; ACursor: TJclCardinalBinaryNode; AValid: Boolean; AStart: TItrStart);\r\nbegin\r\n inherited Create(AValid);\r\n FCursor := ACursor;\r\n FStart := AStart;\r\n FOwnTree := AOwnTree;\r\n FEqualityComparer := AOwnTree as IJclCardinalEqualityComparer;\r\nend;\r\n\r\nfunction TJclCardinalBinaryTreeIterator.Add(AValue: Cardinal): Boolean;\r\nbegin\r\n Result := FOwnTree.Add(AValue);\r\nend;\r\n\r\nfunction TJclCardinalBinaryTreeIterator.AddChild(AValue: Cardinal): Boolean;\r\nbegin\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nprocedure TJclCardinalBinaryTreeIterator.AssignPropertiesTo(Dest: TJclAbstractIterator);\r\nvar\r\n ADest: TJclCardinalBinaryTreeIterator;\r\nbegin\r\n inherited AssignPropertiesTo(Dest);\r\n if Dest is TJclCardinalBinaryTreeIterator then\r\n begin\r\n ADest := TJclCardinalBinaryTreeIterator(Dest);\r\n ADest.FCursor := FCursor;\r\n ADest.FOwnTree := FOwnTree;\r\n ADest.FEqualityComparer := FEqualityComparer;\r\n ADest.FStart := FStart;\r\n end;\r\nend;\r\n\r\nfunction TJclCardinalBinaryTreeIterator.ChildrenCount: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := 0;\r\n if FCursor <> nil then\r\n begin\r\n if FCursor.Left <> nil then\r\n Inc(Result);\r\n if FCursor.Right <> nil then\r\n Inc(Result);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclCardinalBinaryTreeIterator.DeleteChild(Index: Integer);\r\nbegin\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nprocedure TJclCardinalBinaryTreeIterator.DeleteChildren;\r\nbegin\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nprocedure TJclCardinalBinaryTreeIterator.Extract;\r\nvar\r\n OldCursor: TJclCardinalBinaryNode;\r\nbegin\r\n if FOwnTree.ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n CheckValid;\r\n Valid := False;\r\n OldCursor := FCursor;\r\n if OldCursor <> nil then\r\n begin\r\n repeat\r\n FCursor := GetNextCursor;\r\n until (FCursor = nil) or FOwnTree.RemoveSingleElement\r\n or (not FEqualityComparer.ItemsEqual(OldCursor.Value, FCursor.Value));\r\n FOwnTree.Extract(OldCursor.Value);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.WriteUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclCardinalBinaryTreeIterator.ExtractChild(Index: Integer);\r\nbegin\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nprocedure TJclCardinalBinaryTreeIterator.ExtractChildren;\r\nbegin\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nfunction TJclCardinalBinaryTreeIterator.GetChild(Index: Integer): Cardinal;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := 0;\r\n if (FCursor <> nil) and (Index = 0) and (FCursor.Left <> nil) then\r\n FCursor := FCursor.Left\r\n else\r\n if (FCursor <> nil) and (Index = 0) then\r\n FCursor := FCursor.Right\r\n else\r\n if (FCursor <> nil) and (Index = 1) then\r\n FCursor := FCursor.Right\r\n else\r\n FCursor := nil;\r\n if FCursor <> nil then\r\n Result := FCursor.Value\r\n else\r\n if not FOwnTree.ReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclCardinalBinaryTreeIterator.GetValue: Cardinal;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n CheckValid;\r\n Result := 0;\r\n if FCursor <> nil then\r\n Result := FCursor.Value\r\n else\r\n if not FOwnTree.ReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclCardinalBinaryTreeIterator.HasChild(Index: Integer): Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if (FCursor <> nil) and (Index = 0) then\r\n Result := (FCursor.Left <> nil) or (FCursor.Right <> nil)\r\n else\r\n if (FCursor <> nil) and (Index = 1) then\r\n Result := (FCursor.Left <> nil) and (FCursor.Right <> nil)\r\n else\r\n Result := False;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclCardinalBinaryTreeIterator.HasLeft: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := (FCursor <> nil) and (FCursor.Left <> nil);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclCardinalBinaryTreeIterator.HasNext: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Valid then\r\n Result := GetNextCursor <> nil\r\n else\r\n Result := FCursor <> nil;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclCardinalBinaryTreeIterator.HasParent: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := (FCursor <> nil) and (FCursor.Parent <> nil);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclCardinalBinaryTreeIterator.HasPrevious: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Valid then\r\n Result := GetPreviousCursor <> nil\r\n else\r\n Result := FCursor <> nil;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclCardinalBinaryTreeIterator.HasRight: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := (FCursor <> nil) and (FCursor.Right <> nil);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclCardinalBinaryTreeIterator.IndexOfChild(AValue: Cardinal): Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := -1;\r\n if FCursor <> nil then\r\n begin\r\n if FCursor.Left <> nil then\r\n begin\r\n if FEqualityComparer.ItemsEqual(FCursor.Left.Value, AValue) then\r\n Result := 0\r\n else\r\n if (FCursor.Right <> nil) and FEqualityComparer.ItemsEqual(FCursor.Right.Value, AValue) then\r\n Result := 1;\r\n end\r\n else\r\n if (FCursor.Right <> nil) and FEqualityComparer.ItemsEqual(FCursor.Right.Value, AValue) then\r\n Result := 0;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclCardinalBinaryTreeIterator.Insert(AValue: Cardinal): Boolean;\r\nbegin\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nfunction TJclCardinalBinaryTreeIterator.InsertChild(Index: Integer; AValue: Cardinal): Boolean;\r\nbegin\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nfunction TJclCardinalBinaryTreeIterator.IteratorEquals(const AIterator: IJclCardinalIterator): Boolean;\r\nvar\r\n Obj: TObject;\r\n ItrObj: TJclCardinalBinaryTreeIterator;\r\nbegin\r\n Result := False;\r\n if AIterator = nil then\r\n Exit;\r\n Obj := AIterator.GetIteratorReference;\r\n if Obj is TJclCardinalBinaryTreeIterator then\r\n begin\r\n ItrObj := TJclCardinalBinaryTreeIterator(Obj);\r\n Result := (FOwnTree = ItrObj.FOwnTree) and (FCursor = ItrObj.FCursor) and (Valid = ItrObj.Valid);\r\n end;\r\nend;\r\n\r\nfunction TJclCardinalBinaryTreeIterator.Left: Cardinal;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := 0;\r\n if FCursor <> nil then\r\n FCursor := FCursor.Left;\r\n if FCursor <> nil then\r\n Result := FCursor.Value\r\n else\r\n if not FOwnTree.ReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\n{$IFDEF SUPPORTS_FOR_IN}\r\nfunction TJclCardinalBinaryTreeIterator.MoveNext: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Valid then\r\n FCursor := GetNextCursor\r\n else\r\n Valid := True;\r\n Result := FCursor <> nil;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n{$ENDIF SUPPORTS_FOR_IN}\r\n\r\nfunction TJclCardinalBinaryTreeIterator.Next: Cardinal;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Valid then\r\n FCursor := GetNextCursor\r\n else\r\n Valid := True;\r\n Result := 0;\r\n if FCursor <> nil then\r\n Result := FCursor.Value\r\n else\r\n if not FOwnTree.ReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclCardinalBinaryTreeIterator.NextIndex: Integer;\r\nbegin\r\n // No index\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nfunction TJclCardinalBinaryTreeIterator.Parent: Cardinal;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := 0;\r\n if FCursor <> nil then\r\n FCursor := FCursor.Parent;\r\n if FCursor <> nil then\r\n Result := FCursor.Value\r\n else\r\n if not FOwnTree.ReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclCardinalBinaryTreeIterator.Previous: Cardinal;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Valid then\r\n FCursor := GetPreviousCursor\r\n else\r\n Valid := True;\r\n Result := 0;\r\n if FCursor <> nil then\r\n Result := FCursor.Value\r\n else\r\n if not FOwnTree.ReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclCardinalBinaryTreeIterator.PreviousIndex: Integer;\r\nbegin\r\n // No index\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nprocedure TJclCardinalBinaryTreeIterator.Remove;\r\nvar\r\n OldCursor: TJclCardinalBinaryNode;\r\nbegin\r\n if FOwnTree.ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n CheckValid;\r\n Valid := False;\r\n OldCursor := FCursor;\r\n if OldCursor <> nil then\r\n begin\r\n repeat\r\n FCursor := GetNextCursor;\r\n until (FCursor = nil) or FOwnTree.RemoveSingleElement\r\n or (not FEqualityComparer.ItemsEqual(OldCursor.Value, FCursor.Value));\r\n FOwnTree.Remove(OldCursor.Value);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.WriteUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclCardinalBinaryTreeIterator.Reset;\r\nvar\r\n NewCursor: TJclCardinalBinaryNode;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Valid := False;\r\n case FStart of\r\n isFirst:\r\n begin\r\n NewCursor := FCursor;\r\n while NewCursor <> nil do\r\n begin\r\n NewCursor := GetPreviousCursor;\r\n if NewCursor <> nil then\r\n FCursor := NewCursor;\r\n end;\r\n end;\r\n isLast:\r\n begin\r\n NewCursor := FCursor;\r\n while NewCursor <> nil do\r\n begin\r\n NewCursor := GetNextCursor;\r\n if NewCursor <> nil then\r\n FCursor := NewCursor;\r\n end;\r\n end;\r\n isRoot:\r\n begin\r\n while (FCursor <> nil) and (FCursor.Parent <> nil) do\r\n FCursor := FCursor.Parent;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclCardinalBinaryTreeIterator.Right: Cardinal;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := 0;\r\n if FCursor <> nil then\r\n FCursor := FCursor.Right;\r\n if FCursor <> nil then\r\n Result := FCursor.Value\r\n else\r\n if not FOwnTree.ReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclCardinalBinaryTreeIterator.SetChild(Index: Integer; AValue: Cardinal);\r\nbegin\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nprocedure TJclCardinalBinaryTreeIterator.SetValue(AValue: Cardinal);\r\nbegin\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\n//=== { TJclPreOrderCardinalBinaryTreeIterator } ===================================================\r\n\r\nfunction TJclPreOrderCardinalBinaryTreeIterator.CreateEmptyIterator: TJclAbstractIterator;\r\nbegin\r\n Result := TJclPreOrderCardinalBinaryTreeIterator.Create(FOwnTree, FCursor, Valid, FStart);\r\nend;\r\n\r\nfunction TJclPreOrderCardinalBinaryTreeIterator.GetNextCursor: TJclCardinalBinaryNode;\r\nvar\r\n LastRet: TJclCardinalBinaryNode;\r\nbegin\r\n Result := FCursor;\r\n if Result = nil then\r\n Exit;\r\n LastRet := Result;\r\n if Result.Left <> nil then\r\n Result := Result.Left\r\n else\r\n if Result.Right <> nil then\r\n Result := Result.Right\r\n else\r\n begin\r\n Result := Result.Parent;\r\n while (Result <> nil) and ((Result.Right = nil) or (Result.Right = LastRet)) do\r\n begin\r\n LastRet := Result;\r\n Result := Result.Parent;\r\n end;\r\n if Result <> nil then // not root\r\n Result := Result.Right;\r\n end;\r\nend;\r\n\r\nfunction TJclPreOrderCardinalBinaryTreeIterator.GetPreviousCursor: TJclCardinalBinaryNode;\r\nvar\r\n LastRet: TJclCardinalBinaryNode;\r\nbegin\r\n Result := FCursor;\r\n if Result = nil then\r\n Exit;\r\n LastRet := Result;\r\n Result := Result.Parent;\r\n if (Result <> nil) and (Result.Left <> LastRet) and (Result.Left <> nil) then\r\n // come from Right\r\n begin\r\n Result := Result.Left;\r\n while (Result.Left <> nil) or (Result.Right <> nil) do // both childs\r\n begin\r\n if Result.Right <> nil then // right child first\r\n Result := Result.Right\r\n else\r\n Result := Result.Left;\r\n end;\r\n end;\r\nend;\r\n\r\n//=== { TJclInOrderCardinalBinaryTreeIterator } ====================================================\r\n\r\nfunction TJclInOrderCardinalBinaryTreeIterator.CreateEmptyIterator: TJclAbstractIterator;\r\nbegin\r\n Result := TJclInOrderCardinalBinaryTreeIterator.Create(FOwnTree, FCursor, Valid, FStart);\r\nend;\r\n\r\nfunction TJclInOrderCardinalBinaryTreeIterator.GetNextCursor: TJclCardinalBinaryNode;\r\nvar\r\n LastRet: TJclCardinalBinaryNode;\r\nbegin\r\n Result := FCursor;\r\n if Result = nil then\r\n Exit;\r\n if Result.Right <> nil then\r\n begin\r\n Result := Result.Right;\r\n while (Result.Left <> nil) do\r\n Result := Result.Left;\r\n end\r\n else\r\n begin\r\n LastRet := Result;\r\n Result := Result.Parent;\r\n while (Result <> nil) and (Result.Right = LastRet) do\r\n begin\r\n LastRet := Result;\r\n Result := Result.Parent;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJclInOrderCardinalBinaryTreeIterator.GetPreviousCursor: TJclCardinalBinaryNode;\r\nvar\r\n LastRet: TJclCardinalBinaryNode;\r\nbegin\r\n Result := FCursor;\r\n if Result = nil then\r\n Exit;\r\n if Result.Left <> nil then\r\n begin\r\n Result := Result.Left;\r\n while Result.Right <> nil do\r\n Result := Result.Right;\r\n end\r\n else\r\n begin\r\n LastRet := Result;\r\n Result := Result.Parent;\r\n while (Result <> nil) and (Result.Right <> LastRet) do // Come from Left\r\n begin\r\n LastRet := Result;\r\n Result := Result.Parent;\r\n end;\r\n end;\r\nend;\r\n\r\n//=== { TJclPostOrderCardinalBinaryTreeIterator } ==================================================\r\n\r\nfunction TJclPostOrderCardinalBinaryTreeIterator.CreateEmptyIterator: TJclAbstractIterator;\r\nbegin\r\n Result := TJclPostOrderCardinalBinaryTreeIterator.Create(FOwnTree, FCursor, Valid, FStart);\r\nend;\r\n\r\nfunction TJclPostOrderCardinalBinaryTreeIterator.GetNextCursor: TJclCardinalBinaryNode;\r\nvar\r\n LastRet: TJclCardinalBinaryNode;\r\nbegin\r\n Result := FCursor;\r\n if Result = nil then\r\n Exit;\r\n LastRet := Result;\r\n Result := Result.Parent;\r\n if (Result <> nil) and (Result.Right <> nil) and (Result.Right <> LastRet) then\r\n begin\r\n Result := Result.Right;\r\n while (Result.Left <> nil) or (Result.Right <> nil) do\r\n begin\r\n if Result.Left <> nil then\r\n Result := Result.Left\r\n else\r\n Result := Result.Right;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJclPostOrderCardinalBinaryTreeIterator.GetPreviousCursor: TJclCardinalBinaryNode;\r\nvar\r\n LastRet: TJclCardinalBinaryNode;\r\nbegin\r\n Result := FCursor;\r\n if Result = nil then\r\n Exit;\r\n if Result.Right <> nil then\r\n Result := Result.Right\r\n else\r\n if Result.Left <> nil then\r\n Result := Result.Left\r\n else\r\n begin\r\n LastRet := Result;\r\n Result := Result.Parent;\r\n while (Result <> nil) and ((Result.Left = nil) or (Result.Left = LastRet)) do\r\n begin\r\n LastRet := Result;\r\n Result := Result.Parent;\r\n end;\r\n if Result <> nil then // not root\r\n Result := Result.Left;\r\n end;\r\nend;\r\n\r\n//=== { TJclInt64BinaryTree } =================================================\r\n\r\nconstructor TJclInt64BinaryTree.Create(ACompare: TInt64Compare);\r\nbegin\r\n inherited Create();\r\n FTraverseOrder := toOrder;\r\n FMaxDepth := 0;\r\n FAutoPackParameter := 2;\r\n SetCompare(ACompare);\r\nend;\r\n\r\ndestructor TJclInt64BinaryTree.Destroy;\r\nbegin\r\n FReadOnly := False;\r\n Clear;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJclInt64BinaryTree.Add(const AValue: Int64): Boolean;\r\nvar\r\n NewNode, Current, Save: TJclInt64BinaryNode;\r\n Comp, Depth: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n // Insert into right place\r\n if FAllowDefaultElements or not ItemsEqual(AValue, 0) then\r\n begin\r\n Save := nil;\r\n Current := FRoot;\r\n Comp := 1;\r\n Depth := 0;\r\n while Current <> nil do\r\n begin\r\n Inc(Depth);\r\n Save := Current;\r\n Comp := ItemsCompare(AValue, Current.Value);\r\n if Comp < 0 then\r\n Current := Current.Left\r\n else\r\n if Comp > 0 then\r\n Current := Current.Right\r\n else\r\n if CheckDuplicate then\r\n Current := Current.Left // arbitrary decision\r\n else\r\n Break;\r\n end;\r\n if (Comp <> 0) or CheckDuplicate then\r\n begin\r\n NewNode := TJclInt64BinaryNode.Create;\r\n NewNode.Value := AValue;\r\n NewNode.Parent := Save;\r\n if Save = nil then\r\n FRoot := NewNode\r\n else\r\n if ItemsCompare(NewNode.Value, Save.Value) <= 0 then\r\n Save.Left := NewNode\r\n else\r\n Save.Right := NewNode;\r\n Inc(FSize);\r\n Inc(Depth);\r\n if Depth > FMaxDepth then\r\n FMaxDepth := Depth;\r\n Result := True;\r\n AutoPack;\r\n end\r\n else\r\n Result := False;\r\n end\r\n else\r\n Result := False;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclInt64BinaryTree.AddAll(const ACollection: IJclInt64Collection): Boolean;\r\nvar\r\n It: IJclInt64Iterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n Result := Add(It.Next) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclInt64BinaryTree.AssignDataTo(Dest: TJclAbstractContainerBase);\r\nvar\r\n ADest: TJclInt64BinaryTree;\r\n ACollection: IJclInt64Collection;\r\nbegin\r\n inherited AssignDataTo(Dest);\r\n if Dest is TJclInt64BinaryTree then\r\n begin\r\n ADest := TJclInt64BinaryTree(Dest);\r\n ADest.Clear;\r\n ADest.FSize := FSize;\r\n if FRoot <> nil then\r\n ADest.FRoot := CloneNode(FRoot, nil);\r\n end\r\n else\r\n if Supports(IInterface(Dest), IJclInt64Collection, ACollection) then\r\n begin\r\n ACollection.Clear;\r\n ACollection.AddAll(Self);\r\n end;\r\nend;\r\n\r\nprocedure TJclInt64BinaryTree.AssignPropertiesTo(Dest: TJclAbstractContainerBase);\r\nbegin\r\n inherited AssignPropertiesto(Dest);\r\n if Dest is TJclInt64BinaryTree then\r\n TJclInt64BinaryTree(Dest).FTraverseOrder := FTraverseOrder;\r\nend;\r\n\r\nprocedure TJclInt64BinaryTree.AutoPack;\r\nbegin\r\n case FAutoPackStrategy of\r\n //apsDisabled: ;\r\n apsAgressive:\r\n if (FMaxDepth > 1) and (((1 shl (FMaxDepth - 1)) - 1) > FSize) then\r\n Pack;\r\n // apsIncremental: ;\r\n apsProportional:\r\n if (FMaxDepth > FAutoPackParameter) and (((1 shl (FMaxDepth - FAutoPackParameter)) - 1) > FSize) then\r\n Pack;\r\n end;\r\nend;\r\n\r\nfunction TJclInt64BinaryTree.BuildTree(const LeafArray: array of TJclInt64BinaryNode; Left, Right: Integer; Parent: TJclInt64BinaryNode;\r\n Offset: Integer): TJclInt64BinaryNode;\r\nvar\r\n Middle: Integer;\r\nbegin\r\n Middle := (Left + Right + Offset) shr 1;\r\n Result := LeafArray[Middle];\r\n Result.Parent := Parent;\r\n if Middle > Left then\r\n Result.Left := BuildTree(LeafArray, Left, Middle - 1, Result, 0)\r\n else\r\n Result.Left := nil;\r\n if Middle < Right then\r\n Result.Right := BuildTree(LeafArray, Middle + 1, Right, Result, 1)\r\n else\r\n Result.Right := nil;\r\nend;\r\n\r\nprocedure TJclInt64BinaryTree.Clear;\r\nvar\r\n Current, Parent: TJclInt64BinaryNode;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n // postorder\r\n Current := FRoot;\r\n if Current = nil then\r\n Exit;\r\n // find first in post-order\r\n while (Current.Left <> nil) or (Current.Right <> nil) do\r\n begin\r\n if Current.Left <> nil then\r\n Current := Current.Left\r\n else\r\n Current := Current.Right;\r\n end;\r\n // for all items in the tree in post-order\r\n repeat\r\n Parent := Current.Parent;\r\n // remove reference\r\n if Parent <> nil then\r\n begin\r\n if Parent.Left = Current then\r\n Parent.Left := nil\r\n else\r\n if Parent.Right = Current then\r\n Parent.Right := nil;\r\n end;\r\n\r\n // free item\r\n FreeInt64(Current.Value);\r\n Current.Free;\r\n\r\n // find next item\r\n Current := Parent;\r\n if (Current <> nil) and (Current.Right <> nil) then\r\n begin\r\n Current := Current.Right;\r\n while (Current.Left <> nil) or (Current.Right <> nil) do\r\n begin\r\n if Current.Left <> nil then\r\n Current := Current.Left\r\n else\r\n Current := Current.Right;\r\n end;\r\n end;\r\n until Current = nil;\r\n FRoot := nil;\r\n FSize := 0;\r\n FMaxDepth := 0;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclInt64BinaryTree.CloneNode(Node, Parent: TJclInt64BinaryNode): TJclInt64BinaryNode;\r\nbegin\r\n Result := TJclInt64BinaryNode.Create;\r\n Result.Value := Node.Value;\r\n Result.Parent := Parent;\r\n if Node.Left <> nil then\r\n Result.Left := CloneNode(Node.Left, Result); // recursive call\r\n if Node.Right <> nil then\r\n Result.Right := CloneNode(Node.Right, Result); // recursive call\r\nend;\r\n\r\nfunction TJclInt64BinaryTree.CollectionEquals(const ACollection: IJclInt64Collection): Boolean;\r\nvar\r\n It, ItSelf: IJclInt64Iterator;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n if FSize <> ACollection.Size then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n ItSelf := First;\r\n while ItSelf.HasNext do\r\n if not ItemsEqual(ItSelf.Next, It.Next) then\r\n begin\r\n Result := False;\r\n Break;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclInt64BinaryTree.Contains(const AValue: Int64): Boolean;\r\nvar\r\n Comp: Integer;\r\n Current: TJclInt64BinaryNode;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n Current := FRoot;\r\n while Current <> nil do\r\n begin\r\n Comp := ItemsCompare(Current.Value, AValue);\r\n if Comp = 0 then\r\n begin\r\n Result := True;\r\n Break;\r\n end\r\n else\r\n if Comp > 0 then\r\n Current := Current.Left\r\n else\r\n Current := Current.Right;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclInt64BinaryTree.ContainsAll(const ACollection: IJclInt64Collection): Boolean;\r\nvar\r\n It: IJclInt64Iterator;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := True;\r\n if ACollection = nil then\r\n Exit;\r\n It := ACollection.First;\r\n while Result and It.HasNext do\r\n Result := Contains(It.Next);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclInt64BinaryTree.Extract(const AValue: Int64): Boolean;\r\nvar\r\n Current, Successor: TJclInt64BinaryNode;\r\n Comp: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n // locate AValue in the tree\r\n Current := FRoot;\r\n repeat\r\n while Current <> nil do\r\n begin\r\n Comp := ItemsCompare(AValue, Current.Value);\r\n if Comp = 0 then\r\n Break\r\n else\r\n if Comp < 0 then\r\n Current := Current.Left\r\n else\r\n Current := Current.Right;\r\n end;\r\n if Current = nil then\r\n Break;\r\n Result := True;\r\n // Remove Current from tree\r\n if (Current.Left = nil) and (Current.Right <> nil) then\r\n begin\r\n // remove references to Current\r\n Current.Right.Parent := Current.Parent;\r\n if Current.Parent <> nil then\r\n begin\r\n if Current.Parent.Left = Current then\r\n Current.Parent.Left := Current.Right\r\n else\r\n Current.Parent.Right := Current.Right;\r\n end\r\n else\r\n // fix root\r\n FRoot := Current.Right;\r\n Successor := Current.Parent;\r\n if Successor = nil then\r\n Successor := FRoot;\r\n end\r\n else\r\n if (Current.Left <> nil) and (Current.Right = nil) then\r\n begin\r\n // remove references to Current\r\n Current.Left.Parent := Current.Parent;\r\n if Current.Parent <> nil then\r\n begin\r\n if Current.Parent.Left = Current then\r\n Current.Parent.Left := Current.Left\r\n else\r\n Current.Parent.Right := Current.Left;\r\n end\r\n else\r\n // fix root\r\n FRoot := Current.Left;\r\n Successor := Current.Parent;\r\n if Successor = nil then\r\n Successor := FRoot;\r\n end\r\n else\r\n if (Current.Left <> nil) and (Current.Right <> nil) then\r\n begin\r\n // find the successor in tree\r\n Successor := Current.Right;\r\n while Successor.Left <> nil do\r\n Successor := Successor.Left;\r\n\r\n if Successor <> Current.Right then\r\n begin\r\n // remove references to successor\r\n Successor.Parent.Left := Successor.Right;\r\n if Successor.Right <> nil then\r\n Successor.Right.Parent := Successor.Parent;\r\n Successor.Right := Current.Right;\r\n if Successor.Right <> nil then\r\n Successor.Right.Parent := Successor;\r\n end;\r\n\r\n // insert successor in new position\r\n Successor.Left := Current.Left;\r\n if Current.Left <> nil then\r\n Current.Left.Parent := Successor;\r\n Successor.Parent := Current.Parent;\r\n if Current.Parent <> nil then\r\n begin\r\n if Current.Parent.Left = Current then\r\n Current.Parent.Left := Successor\r\n else\r\n Current.Parent.Right := Successor;\r\n end\r\n else\r\n // fix root\r\n FRoot := Successor;\r\n Successor := Current.Parent;\r\n if Successor <> nil then\r\n Successor := FRoot;\r\n end\r\n else\r\n begin\r\n // (Current.Left = nil) and (Current.Right = nil)\r\n Successor := Current.Parent;\r\n if Successor <> nil then\r\n begin\r\n // remove references from parent\r\n if Successor.Left = Current then\r\n Successor.Left := nil\r\n else\r\n Successor.Right := nil;\r\n end\r\n else\r\n FRoot := nil;\r\n end;\r\n Current.Value := 0;\r\n Current.Free;\r\n Dec(FSize);\r\n Current := Successor;\r\n until FRemoveSingleElement or (Current = nil);\r\n AutoPack;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclInt64BinaryTree.ExtractAll(const ACollection: IJclInt64Collection): Boolean;\r\nvar\r\n It: IJclInt64Iterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n Result := Extract(It.Next) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclInt64BinaryTree.First: IJclInt64Iterator;\r\nvar\r\n Start: TJclInt64BinaryNode;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Start := FRoot;\r\n case GetTraverseOrder of\r\n toPreOrder:\r\n Result := TJclPreOrderInt64BinaryTreeIterator.Create(Self, Start, False, isFirst);\r\n toOrder:\r\n begin\r\n if Start <> nil then\r\n while Start.Left <> nil do\r\n Start := Start.Left;\r\n Result := TJclInOrderInt64BinaryTreeIterator.Create(Self, Start, False, isFirst);\r\n end;\r\n toPostOrder:\r\n begin\r\n if Start <> nil then\r\n while (Start.Left <> nil) or (Start.Right <> nil) do\r\n begin\r\n if Start.Left <> nil then\r\n Start := Start.Left\r\n else\r\n Start := Start.Right;\r\n end;\r\n Result := TJclPostOrderInt64BinaryTreeIterator.Create(Self, Start, False, isFirst);\r\n end;\r\n else\r\n Result := nil;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\n{$IFDEF SUPPORTS_FOR_IN}\r\nfunction TJclInt64BinaryTree.GetEnumerator: IJclInt64Iterator;\r\nbegin\r\n Result := First;\r\nend;\r\n{$ENDIF SUPPORTS_FOR_IN}\r\n\r\nfunction TJclInt64BinaryTree.GetRoot: IJclInt64TreeIterator;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n case GetTraverseOrder of\r\n toPreOrder:\r\n Result := TJclPreOrderInt64BinaryTreeIterator.Create(Self, FRoot, False, isRoot);\r\n toOrder:\r\n Result := TJclInOrderInt64BinaryTreeIterator.Create(Self, FRoot, False, isRoot);\r\n toPostOrder:\r\n Result := TJclPostOrderInt64BinaryTreeIterator.Create(Self, FRoot, False, isRoot);\r\n else\r\n Result := nil;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclInt64BinaryTree.GetTraverseOrder: TJclTraverseOrder;\r\nbegin\r\n Result := FTraverseOrder;\r\nend;\r\n\r\nfunction TJclInt64BinaryTree.IsEmpty: Boolean;\r\nbegin\r\n Result := FSize = 0;\r\nend;\r\n\r\nfunction TJclInt64BinaryTree.Last: IJclInt64Iterator;\r\nvar\r\n Start: TJclInt64BinaryNode;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Start := FRoot;\r\n case FTraverseOrder of\r\n toPreOrder:\r\n begin\r\n if Start <> nil then\r\n while (Start.Left <> nil) or (Start.Right <> nil) do\r\n begin\r\n if Start.Right <> nil then\r\n Start := Start.Right\r\n else\r\n Start := Start.Left;\r\n end;\r\n Result := TJclPreOrderInt64BinaryTreeIterator.Create(Self, Start, False, isLast);\r\n end;\r\n toOrder:\r\n begin\r\n if Start <> nil then\r\n while Start.Right <> nil do\r\n Start := Start.Right;\r\n Result := TJclInOrderInt64BinaryTreeIterator.Create(Self, Start, False, isLast);\r\n end;\r\n toPostOrder:\r\n Result := TJclPostOrderInt64BinaryTreeIterator.Create(Self, Start, False, isLast);\r\n else\r\n Result := nil;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclInt64BinaryTree.Pack;\r\nvar\r\n LeafArray: array of TJclInt64BinaryNode;\r\n ANode, BNode: TJclInt64BinaryNode;\r\n Index: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n SetLength(Leafarray, FSize);\r\n try\r\n // in order enumeration of nodes\r\n ANode := FRoot;\r\n if ANode <> nil then\r\n begin\r\n // find first node\r\n while ANode.Left <> nil do\r\n ANode := ANode.Left;\r\n\r\n Index := 0;\r\n while ANode <> nil do\r\n begin\r\n LeafArray[Index] := ANode;\r\n Inc(Index);\r\n if ANode.Right <> nil then\r\n begin\r\n ANode := ANode.Right;\r\n while (ANode.Left <> nil) do\r\n ANode := ANode.Left;\r\n end\r\n else\r\n begin\r\n BNode := ANode;\r\n ANode := ANode.Parent;\r\n while (ANode <> nil) and (ANode.Right = BNode) do\r\n begin\r\n BNode := ANode;\r\n ANode := ANode.Parent;\r\n end;\r\n end;\r\n end;\r\n\r\n Index := FSize shr 1;\r\n FRoot := LeafArray[Index];\r\n FRoot.Parent := nil;\r\n if Index > 0 then\r\n FRoot.Left := BuildTree(LeafArray, 0, Index - 1, FRoot, 0)\r\n else\r\n FRoot.Left := nil;\r\n if Index < (FSize - 1) then\r\n FRoot.Right := BuildTree(LeafArray, Index + 1, FSize - 1, FRoot, 1)\r\n else\r\n FRoot.Right := nil;\r\n end;\r\n finally\r\n SetLength(LeafArray, 0);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclInt64BinaryTree.Remove(const AValue: Int64): Boolean;\r\nvar\r\n Extracted: Int64;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := Extract(AValue);\r\n if Result then\r\n begin\r\n Extracted := AValue;\r\n FreeInt64(Extracted);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclInt64BinaryTree.RemoveAll(const ACollection: IJclInt64Collection): Boolean;\r\nvar\r\n It: IJclInt64Iterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n Result := Remove(It.Next) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclInt64BinaryTree.RetainAll(const ACollection: IJclInt64Collection): Boolean;\r\nvar\r\n It: IJclInt64Iterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := First;\r\n while It.HasNext do\r\n if not ACollection.Contains(It.Next) then\r\n It.Remove;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclInt64BinaryTree.SetCapacity(Value: Integer);\r\nbegin\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nprocedure TJclInt64BinaryTree.SetTraverseOrder(Value: TJclTraverseOrder);\r\nbegin\r\n FTraverseOrder := Value;\r\nend;\r\n\r\nfunction TJclInt64BinaryTree.Size: Integer;\r\nbegin\r\n Result := FSize;\r\nend;\r\n\r\nfunction TJclInt64BinaryTree.CreateEmptyContainer: TJclAbstractContainerBase;\r\nbegin\r\n Result := TJclInt64BinaryTree.Create(Compare);\r\n AssignPropertiesTo(Result);\r\nend;\r\n\r\n//=== { TJclInt64BinaryTreeIterator } ===========================================================\r\n\r\nconstructor TJclInt64BinaryTreeIterator.Create(const AOwnTree: IJclInt64Collection; ACursor: TJclInt64BinaryNode; AValid: Boolean; AStart: TItrStart);\r\nbegin\r\n inherited Create(AValid);\r\n FCursor := ACursor;\r\n FStart := AStart;\r\n FOwnTree := AOwnTree;\r\n FEqualityComparer := AOwnTree as IJclInt64EqualityComparer;\r\nend;\r\n\r\nfunction TJclInt64BinaryTreeIterator.Add(const AValue: Int64): Boolean;\r\nbegin\r\n Result := FOwnTree.Add(AValue);\r\nend;\r\n\r\nfunction TJclInt64BinaryTreeIterator.AddChild(const AValue: Int64): Boolean;\r\nbegin\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nprocedure TJclInt64BinaryTreeIterator.AssignPropertiesTo(Dest: TJclAbstractIterator);\r\nvar\r\n ADest: TJclInt64BinaryTreeIterator;\r\nbegin\r\n inherited AssignPropertiesTo(Dest);\r\n if Dest is TJclInt64BinaryTreeIterator then\r\n begin\r\n ADest := TJclInt64BinaryTreeIterator(Dest);\r\n ADest.FCursor := FCursor;\r\n ADest.FOwnTree := FOwnTree;\r\n ADest.FEqualityComparer := FEqualityComparer;\r\n ADest.FStart := FStart;\r\n end;\r\nend;\r\n\r\nfunction TJclInt64BinaryTreeIterator.ChildrenCount: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := 0;\r\n if FCursor <> nil then\r\n begin\r\n if FCursor.Left <> nil then\r\n Inc(Result);\r\n if FCursor.Right <> nil then\r\n Inc(Result);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclInt64BinaryTreeIterator.DeleteChild(Index: Integer);\r\nbegin\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nprocedure TJclInt64BinaryTreeIterator.DeleteChildren;\r\nbegin\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nprocedure TJclInt64BinaryTreeIterator.Extract;\r\nvar\r\n OldCursor: TJclInt64BinaryNode;\r\nbegin\r\n if FOwnTree.ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n CheckValid;\r\n Valid := False;\r\n OldCursor := FCursor;\r\n if OldCursor <> nil then\r\n begin\r\n repeat\r\n FCursor := GetNextCursor;\r\n until (FCursor = nil) or FOwnTree.RemoveSingleElement\r\n or (not FEqualityComparer.ItemsEqual(OldCursor.Value, FCursor.Value));\r\n FOwnTree.Extract(OldCursor.Value);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.WriteUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclInt64BinaryTreeIterator.ExtractChild(Index: Integer);\r\nbegin\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nprocedure TJclInt64BinaryTreeIterator.ExtractChildren;\r\nbegin\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nfunction TJclInt64BinaryTreeIterator.GetChild(Index: Integer): Int64;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := 0;\r\n if (FCursor <> nil) and (Index = 0) and (FCursor.Left <> nil) then\r\n FCursor := FCursor.Left\r\n else\r\n if (FCursor <> nil) and (Index = 0) then\r\n FCursor := FCursor.Right\r\n else\r\n if (FCursor <> nil) and (Index = 1) then\r\n FCursor := FCursor.Right\r\n else\r\n FCursor := nil;\r\n if FCursor <> nil then\r\n Result := FCursor.Value\r\n else\r\n if not FOwnTree.ReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclInt64BinaryTreeIterator.GetValue: Int64;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n CheckValid;\r\n Result := 0;\r\n if FCursor <> nil then\r\n Result := FCursor.Value\r\n else\r\n if not FOwnTree.ReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclInt64BinaryTreeIterator.HasChild(Index: Integer): Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if (FCursor <> nil) and (Index = 0) then\r\n Result := (FCursor.Left <> nil) or (FCursor.Right <> nil)\r\n else\r\n if (FCursor <> nil) and (Index = 1) then\r\n Result := (FCursor.Left <> nil) and (FCursor.Right <> nil)\r\n else\r\n Result := False;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclInt64BinaryTreeIterator.HasLeft: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := (FCursor <> nil) and (FCursor.Left <> nil);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclInt64BinaryTreeIterator.HasNext: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Valid then\r\n Result := GetNextCursor <> nil\r\n else\r\n Result := FCursor <> nil;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclInt64BinaryTreeIterator.HasParent: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := (FCursor <> nil) and (FCursor.Parent <> nil);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclInt64BinaryTreeIterator.HasPrevious: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Valid then\r\n Result := GetPreviousCursor <> nil\r\n else\r\n Result := FCursor <> nil;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclInt64BinaryTreeIterator.HasRight: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := (FCursor <> nil) and (FCursor.Right <> nil);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclInt64BinaryTreeIterator.IndexOfChild(const AValue: Int64): Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := -1;\r\n if FCursor <> nil then\r\n begin\r\n if FCursor.Left <> nil then\r\n begin\r\n if FEqualityComparer.ItemsEqual(FCursor.Left.Value, AValue) then\r\n Result := 0\r\n else\r\n if (FCursor.Right <> nil) and FEqualityComparer.ItemsEqual(FCursor.Right.Value, AValue) then\r\n Result := 1;\r\n end\r\n else\r\n if (FCursor.Right <> nil) and FEqualityComparer.ItemsEqual(FCursor.Right.Value, AValue) then\r\n Result := 0;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclInt64BinaryTreeIterator.Insert(const AValue: Int64): Boolean;\r\nbegin\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nfunction TJclInt64BinaryTreeIterator.InsertChild(Index: Integer; const AValue: Int64): Boolean;\r\nbegin\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nfunction TJclInt64BinaryTreeIterator.IteratorEquals(const AIterator: IJclInt64Iterator): Boolean;\r\nvar\r\n Obj: TObject;\r\n ItrObj: TJclInt64BinaryTreeIterator;\r\nbegin\r\n Result := False;\r\n if AIterator = nil then\r\n Exit;\r\n Obj := AIterator.GetIteratorReference;\r\n if Obj is TJclInt64BinaryTreeIterator then\r\n begin\r\n ItrObj := TJclInt64BinaryTreeIterator(Obj);\r\n Result := (FOwnTree = ItrObj.FOwnTree) and (FCursor = ItrObj.FCursor) and (Valid = ItrObj.Valid);\r\n end;\r\nend;\r\n\r\nfunction TJclInt64BinaryTreeIterator.Left: Int64;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := 0;\r\n if FCursor <> nil then\r\n FCursor := FCursor.Left;\r\n if FCursor <> nil then\r\n Result := FCursor.Value\r\n else\r\n if not FOwnTree.ReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\n{$IFDEF SUPPORTS_FOR_IN}\r\nfunction TJclInt64BinaryTreeIterator.MoveNext: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Valid then\r\n FCursor := GetNextCursor\r\n else\r\n Valid := True;\r\n Result := FCursor <> nil;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n{$ENDIF SUPPORTS_FOR_IN}\r\n\r\nfunction TJclInt64BinaryTreeIterator.Next: Int64;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Valid then\r\n FCursor := GetNextCursor\r\n else\r\n Valid := True;\r\n Result := 0;\r\n if FCursor <> nil then\r\n Result := FCursor.Value\r\n else\r\n if not FOwnTree.ReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclInt64BinaryTreeIterator.NextIndex: Integer;\r\nbegin\r\n // No index\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nfunction TJclInt64BinaryTreeIterator.Parent: Int64;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := 0;\r\n if FCursor <> nil then\r\n FCursor := FCursor.Parent;\r\n if FCursor <> nil then\r\n Result := FCursor.Value\r\n else\r\n if not FOwnTree.ReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclInt64BinaryTreeIterator.Previous: Int64;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Valid then\r\n FCursor := GetPreviousCursor\r\n else\r\n Valid := True;\r\n Result := 0;\r\n if FCursor <> nil then\r\n Result := FCursor.Value\r\n else\r\n if not FOwnTree.ReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclInt64BinaryTreeIterator.PreviousIndex: Integer;\r\nbegin\r\n // No index\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nprocedure TJclInt64BinaryTreeIterator.Remove;\r\nvar\r\n OldCursor: TJclInt64BinaryNode;\r\nbegin\r\n if FOwnTree.ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n CheckValid;\r\n Valid := False;\r\n OldCursor := FCursor;\r\n if OldCursor <> nil then\r\n begin\r\n repeat\r\n FCursor := GetNextCursor;\r\n until (FCursor = nil) or FOwnTree.RemoveSingleElement\r\n or (not FEqualityComparer.ItemsEqual(OldCursor.Value, FCursor.Value));\r\n FOwnTree.Remove(OldCursor.Value);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.WriteUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclInt64BinaryTreeIterator.Reset;\r\nvar\r\n NewCursor: TJclInt64BinaryNode;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Valid := False;\r\n case FStart of\r\n isFirst:\r\n begin\r\n NewCursor := FCursor;\r\n while NewCursor <> nil do\r\n begin\r\n NewCursor := GetPreviousCursor;\r\n if NewCursor <> nil then\r\n FCursor := NewCursor;\r\n end;\r\n end;\r\n isLast:\r\n begin\r\n NewCursor := FCursor;\r\n while NewCursor <> nil do\r\n begin\r\n NewCursor := GetNextCursor;\r\n if NewCursor <> nil then\r\n FCursor := NewCursor;\r\n end;\r\n end;\r\n isRoot:\r\n begin\r\n while (FCursor <> nil) and (FCursor.Parent <> nil) do\r\n FCursor := FCursor.Parent;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclInt64BinaryTreeIterator.Right: Int64;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := 0;\r\n if FCursor <> nil then\r\n FCursor := FCursor.Right;\r\n if FCursor <> nil then\r\n Result := FCursor.Value\r\n else\r\n if not FOwnTree.ReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclInt64BinaryTreeIterator.SetChild(Index: Integer; const AValue: Int64);\r\nbegin\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nprocedure TJclInt64BinaryTreeIterator.SetValue(const AValue: Int64);\r\nbegin\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\n//=== { TJclPreOrderInt64BinaryTreeIterator } ===================================================\r\n\r\nfunction TJclPreOrderInt64BinaryTreeIterator.CreateEmptyIterator: TJclAbstractIterator;\r\nbegin\r\n Result := TJclPreOrderInt64BinaryTreeIterator.Create(FOwnTree, FCursor, Valid, FStart);\r\nend;\r\n\r\nfunction TJclPreOrderInt64BinaryTreeIterator.GetNextCursor: TJclInt64BinaryNode;\r\nvar\r\n LastRet: TJclInt64BinaryNode;\r\nbegin\r\n Result := FCursor;\r\n if Result = nil then\r\n Exit;\r\n LastRet := Result;\r\n if Result.Left <> nil then\r\n Result := Result.Left\r\n else\r\n if Result.Right <> nil then\r\n Result := Result.Right\r\n else\r\n begin\r\n Result := Result.Parent;\r\n while (Result <> nil) and ((Result.Right = nil) or (Result.Right = LastRet)) do\r\n begin\r\n LastRet := Result;\r\n Result := Result.Parent;\r\n end;\r\n if Result <> nil then // not root\r\n Result := Result.Right;\r\n end;\r\nend;\r\n\r\nfunction TJclPreOrderInt64BinaryTreeIterator.GetPreviousCursor: TJclInt64BinaryNode;\r\nvar\r\n LastRet: TJclInt64BinaryNode;\r\nbegin\r\n Result := FCursor;\r\n if Result = nil then\r\n Exit;\r\n LastRet := Result;\r\n Result := Result.Parent;\r\n if (Result <> nil) and (Result.Left <> LastRet) and (Result.Left <> nil) then\r\n // come from Right\r\n begin\r\n Result := Result.Left;\r\n while (Result.Left <> nil) or (Result.Right <> nil) do // both childs\r\n begin\r\n if Result.Right <> nil then // right child first\r\n Result := Result.Right\r\n else\r\n Result := Result.Left;\r\n end;\r\n end;\r\nend;\r\n\r\n//=== { TJclInOrderInt64BinaryTreeIterator } ====================================================\r\n\r\nfunction TJclInOrderInt64BinaryTreeIterator.CreateEmptyIterator: TJclAbstractIterator;\r\nbegin\r\n Result := TJclInOrderInt64BinaryTreeIterator.Create(FOwnTree, FCursor, Valid, FStart);\r\nend;\r\n\r\nfunction TJclInOrderInt64BinaryTreeIterator.GetNextCursor: TJclInt64BinaryNode;\r\nvar\r\n LastRet: TJclInt64BinaryNode;\r\nbegin\r\n Result := FCursor;\r\n if Result = nil then\r\n Exit;\r\n if Result.Right <> nil then\r\n begin\r\n Result := Result.Right;\r\n while (Result.Left <> nil) do\r\n Result := Result.Left;\r\n end\r\n else\r\n begin\r\n LastRet := Result;\r\n Result := Result.Parent;\r\n while (Result <> nil) and (Result.Right = LastRet) do\r\n begin\r\n LastRet := Result;\r\n Result := Result.Parent;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJclInOrderInt64BinaryTreeIterator.GetPreviousCursor: TJclInt64BinaryNode;\r\nvar\r\n LastRet: TJclInt64BinaryNode;\r\nbegin\r\n Result := FCursor;\r\n if Result = nil then\r\n Exit;\r\n if Result.Left <> nil then\r\n begin\r\n Result := Result.Left;\r\n while Result.Right <> nil do\r\n Result := Result.Right;\r\n end\r\n else\r\n begin\r\n LastRet := Result;\r\n Result := Result.Parent;\r\n while (Result <> nil) and (Result.Right <> LastRet) do // Come from Left\r\n begin\r\n LastRet := Result;\r\n Result := Result.Parent;\r\n end;\r\n end;\r\nend;\r\n\r\n//=== { TJclPostOrderInt64BinaryTreeIterator } ==================================================\r\n\r\nfunction TJclPostOrderInt64BinaryTreeIterator.CreateEmptyIterator: TJclAbstractIterator;\r\nbegin\r\n Result := TJclPostOrderInt64BinaryTreeIterator.Create(FOwnTree, FCursor, Valid, FStart);\r\nend;\r\n\r\nfunction TJclPostOrderInt64BinaryTreeIterator.GetNextCursor: TJclInt64BinaryNode;\r\nvar\r\n LastRet: TJclInt64BinaryNode;\r\nbegin\r\n Result := FCursor;\r\n if Result = nil then\r\n Exit;\r\n LastRet := Result;\r\n Result := Result.Parent;\r\n if (Result <> nil) and (Result.Right <> nil) and (Result.Right <> LastRet) then\r\n begin\r\n Result := Result.Right;\r\n while (Result.Left <> nil) or (Result.Right <> nil) do\r\n begin\r\n if Result.Left <> nil then\r\n Result := Result.Left\r\n else\r\n Result := Result.Right;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJclPostOrderInt64BinaryTreeIterator.GetPreviousCursor: TJclInt64BinaryNode;\r\nvar\r\n LastRet: TJclInt64BinaryNode;\r\nbegin\r\n Result := FCursor;\r\n if Result = nil then\r\n Exit;\r\n if Result.Right <> nil then\r\n Result := Result.Right\r\n else\r\n if Result.Left <> nil then\r\n Result := Result.Left\r\n else\r\n begin\r\n LastRet := Result;\r\n Result := Result.Parent;\r\n while (Result <> nil) and ((Result.Left = nil) or (Result.Left = LastRet)) do\r\n begin\r\n LastRet := Result;\r\n Result := Result.Parent;\r\n end;\r\n if Result <> nil then // not root\r\n Result := Result.Left;\r\n end;\r\nend;\r\n\r\n//=== { TJclPtrBinaryTree } =================================================\r\n\r\nconstructor TJclPtrBinaryTree.Create(ACompare: TPtrCompare);\r\nbegin\r\n inherited Create();\r\n FTraverseOrder := toOrder;\r\n FMaxDepth := 0;\r\n FAutoPackParameter := 2;\r\n SetCompare(ACompare);\r\nend;\r\n\r\ndestructor TJclPtrBinaryTree.Destroy;\r\nbegin\r\n FReadOnly := False;\r\n Clear;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJclPtrBinaryTree.Add(APtr: Pointer): Boolean;\r\nvar\r\n NewNode, Current, Save: TJclPtrBinaryNode;\r\n Comp, Depth: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n // Insert into right place\r\n if FAllowDefaultElements or not ItemsEqual(APtr, nil) then\r\n begin\r\n Save := nil;\r\n Current := FRoot;\r\n Comp := 1;\r\n Depth := 0;\r\n while Current <> nil do\r\n begin\r\n Inc(Depth);\r\n Save := Current;\r\n Comp := ItemsCompare(APtr, Current.Value);\r\n if Comp < 0 then\r\n Current := Current.Left\r\n else\r\n if Comp > 0 then\r\n Current := Current.Right\r\n else\r\n if CheckDuplicate then\r\n Current := Current.Left // arbitrary decision\r\n else\r\n Break;\r\n end;\r\n if (Comp <> 0) or CheckDuplicate then\r\n begin\r\n NewNode := TJclPtrBinaryNode.Create;\r\n NewNode.Value := APtr;\r\n NewNode.Parent := Save;\r\n if Save = nil then\r\n FRoot := NewNode\r\n else\r\n if ItemsCompare(NewNode.Value, Save.Value) <= 0 then\r\n Save.Left := NewNode\r\n else\r\n Save.Right := NewNode;\r\n Inc(FSize);\r\n Inc(Depth);\r\n if Depth > FMaxDepth then\r\n FMaxDepth := Depth;\r\n Result := True;\r\n AutoPack;\r\n end\r\n else\r\n Result := False;\r\n end\r\n else\r\n Result := False;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclPtrBinaryTree.AddAll(const ACollection: IJclPtrCollection): Boolean;\r\nvar\r\n It: IJclPtrIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n Result := Add(It.Next) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclPtrBinaryTree.AssignDataTo(Dest: TJclAbstractContainerBase);\r\nvar\r\n ADest: TJclPtrBinaryTree;\r\n ACollection: IJclPtrCollection;\r\nbegin\r\n inherited AssignDataTo(Dest);\r\n if Dest is TJclPtrBinaryTree then\r\n begin\r\n ADest := TJclPtrBinaryTree(Dest);\r\n ADest.Clear;\r\n ADest.FSize := FSize;\r\n if FRoot <> nil then\r\n ADest.FRoot := CloneNode(FRoot, nil);\r\n end\r\n else\r\n if Supports(IInterface(Dest), IJclPtrCollection, ACollection) then\r\n begin\r\n ACollection.Clear;\r\n ACollection.AddAll(Self);\r\n end;\r\nend;\r\n\r\nprocedure TJclPtrBinaryTree.AssignPropertiesTo(Dest: TJclAbstractContainerBase);\r\nbegin\r\n inherited AssignPropertiesto(Dest);\r\n if Dest is TJclPtrBinaryTree then\r\n TJclPtrBinaryTree(Dest).FTraverseOrder := FTraverseOrder;\r\nend;\r\n\r\nprocedure TJclPtrBinaryTree.AutoPack;\r\nbegin\r\n case FAutoPackStrategy of\r\n //apsDisabled: ;\r\n apsAgressive:\r\n if (FMaxDepth > 1) and (((1 shl (FMaxDepth - 1)) - 1) > FSize) then\r\n Pack;\r\n // apsIncremental: ;\r\n apsProportional:\r\n if (FMaxDepth > FAutoPackParameter) and (((1 shl (FMaxDepth - FAutoPackParameter)) - 1) > FSize) then\r\n Pack;\r\n end;\r\nend;\r\n\r\nfunction TJclPtrBinaryTree.BuildTree(const LeafArray: array of TJclPtrBinaryNode; Left, Right: Integer; Parent: TJclPtrBinaryNode;\r\n Offset: Integer): TJclPtrBinaryNode;\r\nvar\r\n Middle: Integer;\r\nbegin\r\n Middle := (Left + Right + Offset) shr 1;\r\n Result := LeafArray[Middle];\r\n Result.Parent := Parent;\r\n if Middle > Left then\r\n Result.Left := BuildTree(LeafArray, Left, Middle - 1, Result, 0)\r\n else\r\n Result.Left := nil;\r\n if Middle < Right then\r\n Result.Right := BuildTree(LeafArray, Middle + 1, Right, Result, 1)\r\n else\r\n Result.Right := nil;\r\nend;\r\n\r\nprocedure TJclPtrBinaryTree.Clear;\r\nvar\r\n Current, Parent: TJclPtrBinaryNode;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n // postorder\r\n Current := FRoot;\r\n if Current = nil then\r\n Exit;\r\n // find first in post-order\r\n while (Current.Left <> nil) or (Current.Right <> nil) do\r\n begin\r\n if Current.Left <> nil then\r\n Current := Current.Left\r\n else\r\n Current := Current.Right;\r\n end;\r\n // for all items in the tree in post-order\r\n repeat\r\n Parent := Current.Parent;\r\n // remove reference\r\n if Parent <> nil then\r\n begin\r\n if Parent.Left = Current then\r\n Parent.Left := nil\r\n else\r\n if Parent.Right = Current then\r\n Parent.Right := nil;\r\n end;\r\n\r\n // free item\r\n FreePointer(Current.Value);\r\n Current.Free;\r\n\r\n // find next item\r\n Current := Parent;\r\n if (Current <> nil) and (Current.Right <> nil) then\r\n begin\r\n Current := Current.Right;\r\n while (Current.Left <> nil) or (Current.Right <> nil) do\r\n begin\r\n if Current.Left <> nil then\r\n Current := Current.Left\r\n else\r\n Current := Current.Right;\r\n end;\r\n end;\r\n until Current = nil;\r\n FRoot := nil;\r\n FSize := 0;\r\n FMaxDepth := 0;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclPtrBinaryTree.CloneNode(Node, Parent: TJclPtrBinaryNode): TJclPtrBinaryNode;\r\nbegin\r\n Result := TJclPtrBinaryNode.Create;\r\n Result.Value := Node.Value;\r\n Result.Parent := Parent;\r\n if Node.Left <> nil then\r\n Result.Left := CloneNode(Node.Left, Result); // recursive call\r\n if Node.Right <> nil then\r\n Result.Right := CloneNode(Node.Right, Result); // recursive call\r\nend;\r\n\r\nfunction TJclPtrBinaryTree.CollectionEquals(const ACollection: IJclPtrCollection): Boolean;\r\nvar\r\n It, ItSelf: IJclPtrIterator;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n if FSize <> ACollection.Size then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n ItSelf := First;\r\n while ItSelf.HasNext do\r\n if not ItemsEqual(ItSelf.Next, It.Next) then\r\n begin\r\n Result := False;\r\n Break;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclPtrBinaryTree.Contains(APtr: Pointer): Boolean;\r\nvar\r\n Comp: Integer;\r\n Current: TJclPtrBinaryNode;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n Current := FRoot;\r\n while Current <> nil do\r\n begin\r\n Comp := ItemsCompare(Current.Value, APtr);\r\n if Comp = 0 then\r\n begin\r\n Result := True;\r\n Break;\r\n end\r\n else\r\n if Comp > 0 then\r\n Current := Current.Left\r\n else\r\n Current := Current.Right;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclPtrBinaryTree.ContainsAll(const ACollection: IJclPtrCollection): Boolean;\r\nvar\r\n It: IJclPtrIterator;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := True;\r\n if ACollection = nil then\r\n Exit;\r\n It := ACollection.First;\r\n while Result and It.HasNext do\r\n Result := Contains(It.Next);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclPtrBinaryTree.Extract(APtr: Pointer): Boolean;\r\nvar\r\n Current, Successor: TJclPtrBinaryNode;\r\n Comp: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n // locate APtr in the tree\r\n Current := FRoot;\r\n repeat\r\n while Current <> nil do\r\n begin\r\n Comp := ItemsCompare(APtr, Current.Value);\r\n if Comp = 0 then\r\n Break\r\n else\r\n if Comp < 0 then\r\n Current := Current.Left\r\n else\r\n Current := Current.Right;\r\n end;\r\n if Current = nil then\r\n Break;\r\n Result := True;\r\n // Remove Current from tree\r\n if (Current.Left = nil) and (Current.Right <> nil) then\r\n begin\r\n // remove references to Current\r\n Current.Right.Parent := Current.Parent;\r\n if Current.Parent <> nil then\r\n begin\r\n if Current.Parent.Left = Current then\r\n Current.Parent.Left := Current.Right\r\n else\r\n Current.Parent.Right := Current.Right;\r\n end\r\n else\r\n // fix root\r\n FRoot := Current.Right;\r\n Successor := Current.Parent;\r\n if Successor = nil then\r\n Successor := FRoot;\r\n end\r\n else\r\n if (Current.Left <> nil) and (Current.Right = nil) then\r\n begin\r\n // remove references to Current\r\n Current.Left.Parent := Current.Parent;\r\n if Current.Parent <> nil then\r\n begin\r\n if Current.Parent.Left = Current then\r\n Current.Parent.Left := Current.Left\r\n else\r\n Current.Parent.Right := Current.Left;\r\n end\r\n else\r\n // fix root\r\n FRoot := Current.Left;\r\n Successor := Current.Parent;\r\n if Successor = nil then\r\n Successor := FRoot;\r\n end\r\n else\r\n if (Current.Left <> nil) and (Current.Right <> nil) then\r\n begin\r\n // find the successor in tree\r\n Successor := Current.Right;\r\n while Successor.Left <> nil do\r\n Successor := Successor.Left;\r\n\r\n if Successor <> Current.Right then\r\n begin\r\n // remove references to successor\r\n Successor.Parent.Left := Successor.Right;\r\n if Successor.Right <> nil then\r\n Successor.Right.Parent := Successor.Parent;\r\n Successor.Right := Current.Right;\r\n if Successor.Right <> nil then\r\n Successor.Right.Parent := Successor;\r\n end;\r\n\r\n // insert successor in new position\r\n Successor.Left := Current.Left;\r\n if Current.Left <> nil then\r\n Current.Left.Parent := Successor;\r\n Successor.Parent := Current.Parent;\r\n if Current.Parent <> nil then\r\n begin\r\n if Current.Parent.Left = Current then\r\n Current.Parent.Left := Successor\r\n else\r\n Current.Parent.Right := Successor;\r\n end\r\n else\r\n // fix root\r\n FRoot := Successor;\r\n Successor := Current.Parent;\r\n if Successor <> nil then\r\n Successor := FRoot;\r\n end\r\n else\r\n begin\r\n // (Current.Left = nil) and (Current.Right = nil)\r\n Successor := Current.Parent;\r\n if Successor <> nil then\r\n begin\r\n // remove references from parent\r\n if Successor.Left = Current then\r\n Successor.Left := nil\r\n else\r\n Successor.Right := nil;\r\n end\r\n else\r\n FRoot := nil;\r\n end;\r\n Current.Value := nil;\r\n Current.Free;\r\n Dec(FSize);\r\n Current := Successor;\r\n until FRemoveSingleElement or (Current = nil);\r\n AutoPack;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclPtrBinaryTree.ExtractAll(const ACollection: IJclPtrCollection): Boolean;\r\nvar\r\n It: IJclPtrIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n Result := Extract(It.Next) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclPtrBinaryTree.First: IJclPtrIterator;\r\nvar\r\n Start: TJclPtrBinaryNode;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Start := FRoot;\r\n case GetTraverseOrder of\r\n toPreOrder:\r\n Result := TJclPreOrderPtrBinaryTreeIterator.Create(Self, Start, False, isFirst);\r\n toOrder:\r\n begin\r\n if Start <> nil then\r\n while Start.Left <> nil do\r\n Start := Start.Left;\r\n Result := TJclInOrderPtrBinaryTreeIterator.Create(Self, Start, False, isFirst);\r\n end;\r\n toPostOrder:\r\n begin\r\n if Start <> nil then\r\n while (Start.Left <> nil) or (Start.Right <> nil) do\r\n begin\r\n if Start.Left <> nil then\r\n Start := Start.Left\r\n else\r\n Start := Start.Right;\r\n end;\r\n Result := TJclPostOrderPtrBinaryTreeIterator.Create(Self, Start, False, isFirst);\r\n end;\r\n else\r\n Result := nil;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\n{$IFDEF SUPPORTS_FOR_IN}\r\nfunction TJclPtrBinaryTree.GetEnumerator: IJclPtrIterator;\r\nbegin\r\n Result := First;\r\nend;\r\n{$ENDIF SUPPORTS_FOR_IN}\r\n\r\nfunction TJclPtrBinaryTree.GetRoot: IJclPtrTreeIterator;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n case GetTraverseOrder of\r\n toPreOrder:\r\n Result := TJclPreOrderPtrBinaryTreeIterator.Create(Self, FRoot, False, isRoot);\r\n toOrder:\r\n Result := TJclInOrderPtrBinaryTreeIterator.Create(Self, FRoot, False, isRoot);\r\n toPostOrder:\r\n Result := TJclPostOrderPtrBinaryTreeIterator.Create(Self, FRoot, False, isRoot);\r\n else\r\n Result := nil;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclPtrBinaryTree.GetTraverseOrder: TJclTraverseOrder;\r\nbegin\r\n Result := FTraverseOrder;\r\nend;\r\n\r\nfunction TJclPtrBinaryTree.IsEmpty: Boolean;\r\nbegin\r\n Result := FSize = 0;\r\nend;\r\n\r\nfunction TJclPtrBinaryTree.Last: IJclPtrIterator;\r\nvar\r\n Start: TJclPtrBinaryNode;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Start := FRoot;\r\n case FTraverseOrder of\r\n toPreOrder:\r\n begin\r\n if Start <> nil then\r\n while (Start.Left <> nil) or (Start.Right <> nil) do\r\n begin\r\n if Start.Right <> nil then\r\n Start := Start.Right\r\n else\r\n Start := Start.Left;\r\n end;\r\n Result := TJclPreOrderPtrBinaryTreeIterator.Create(Self, Start, False, isLast);\r\n end;\r\n toOrder:\r\n begin\r\n if Start <> nil then\r\n while Start.Right <> nil do\r\n Start := Start.Right;\r\n Result := TJclInOrderPtrBinaryTreeIterator.Create(Self, Start, False, isLast);\r\n end;\r\n toPostOrder:\r\n Result := TJclPostOrderPtrBinaryTreeIterator.Create(Self, Start, False, isLast);\r\n else\r\n Result := nil;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclPtrBinaryTree.Pack;\r\nvar\r\n LeafArray: array of TJclPtrBinaryNode;\r\n ANode, BNode: TJclPtrBinaryNode;\r\n Index: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n SetLength(Leafarray, FSize);\r\n try\r\n // in order enumeration of nodes\r\n ANode := FRoot;\r\n if ANode <> nil then\r\n begin\r\n // find first node\r\n while ANode.Left <> nil do\r\n ANode := ANode.Left;\r\n\r\n Index := 0;\r\n while ANode <> nil do\r\n begin\r\n LeafArray[Index] := ANode;\r\n Inc(Index);\r\n if ANode.Right <> nil then\r\n begin\r\n ANode := ANode.Right;\r\n while (ANode.Left <> nil) do\r\n ANode := ANode.Left;\r\n end\r\n else\r\n begin\r\n BNode := ANode;\r\n ANode := ANode.Parent;\r\n while (ANode <> nil) and (ANode.Right = BNode) do\r\n begin\r\n BNode := ANode;\r\n ANode := ANode.Parent;\r\n end;\r\n end;\r\n end;\r\n\r\n Index := FSize shr 1;\r\n FRoot := LeafArray[Index];\r\n FRoot.Parent := nil;\r\n if Index > 0 then\r\n FRoot.Left := BuildTree(LeafArray, 0, Index - 1, FRoot, 0)\r\n else\r\n FRoot.Left := nil;\r\n if Index < (FSize - 1) then\r\n FRoot.Right := BuildTree(LeafArray, Index + 1, FSize - 1, FRoot, 1)\r\n else\r\n FRoot.Right := nil;\r\n end;\r\n finally\r\n SetLength(LeafArray, 0);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclPtrBinaryTree.Remove(APtr: Pointer): Boolean;\r\nvar\r\n Extracted: Pointer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := Extract(APtr);\r\n if Result then\r\n begin\r\n Extracted := APtr;\r\n FreePointer(Extracted);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclPtrBinaryTree.RemoveAll(const ACollection: IJclPtrCollection): Boolean;\r\nvar\r\n It: IJclPtrIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n Result := Remove(It.Next) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclPtrBinaryTree.RetainAll(const ACollection: IJclPtrCollection): Boolean;\r\nvar\r\n It: IJclPtrIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := First;\r\n while It.HasNext do\r\n if not ACollection.Contains(It.Next) then\r\n It.Remove;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclPtrBinaryTree.SetCapacity(Value: Integer);\r\nbegin\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nprocedure TJclPtrBinaryTree.SetTraverseOrder(Value: TJclTraverseOrder);\r\nbegin\r\n FTraverseOrder := Value;\r\nend;\r\n\r\nfunction TJclPtrBinaryTree.Size: Integer;\r\nbegin\r\n Result := FSize;\r\nend;\r\n\r\nfunction TJclPtrBinaryTree.CreateEmptyContainer: TJclAbstractContainerBase;\r\nbegin\r\n Result := TJclPtrBinaryTree.Create(Compare);\r\n AssignPropertiesTo(Result);\r\nend;\r\n\r\n//=== { TJclPtrBinaryTreeIterator } ===========================================================\r\n\r\nconstructor TJclPtrBinaryTreeIterator.Create(const AOwnTree: IJclPtrCollection; ACursor: TJclPtrBinaryNode; AValid: Boolean; AStart: TItrStart);\r\nbegin\r\n inherited Create(AValid);\r\n FCursor := ACursor;\r\n FStart := AStart;\r\n FOwnTree := AOwnTree;\r\n FEqualityComparer := AOwnTree as IJclPtrEqualityComparer;\r\nend;\r\n\r\nfunction TJclPtrBinaryTreeIterator.Add(APtr: Pointer): Boolean;\r\nbegin\r\n Result := FOwnTree.Add(APtr);\r\nend;\r\n\r\nfunction TJclPtrBinaryTreeIterator.AddChild(APtr: Pointer): Boolean;\r\nbegin\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nprocedure TJclPtrBinaryTreeIterator.AssignPropertiesTo(Dest: TJclAbstractIterator);\r\nvar\r\n ADest: TJclPtrBinaryTreeIterator;\r\nbegin\r\n inherited AssignPropertiesTo(Dest);\r\n if Dest is TJclPtrBinaryTreeIterator then\r\n begin\r\n ADest := TJclPtrBinaryTreeIterator(Dest);\r\n ADest.FCursor := FCursor;\r\n ADest.FOwnTree := FOwnTree;\r\n ADest.FEqualityComparer := FEqualityComparer;\r\n ADest.FStart := FStart;\r\n end;\r\nend;\r\n\r\nfunction TJclPtrBinaryTreeIterator.ChildrenCount: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := 0;\r\n if FCursor <> nil then\r\n begin\r\n if FCursor.Left <> nil then\r\n Inc(Result);\r\n if FCursor.Right <> nil then\r\n Inc(Result);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclPtrBinaryTreeIterator.DeleteChild(Index: Integer);\r\nbegin\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nprocedure TJclPtrBinaryTreeIterator.DeleteChildren;\r\nbegin\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nprocedure TJclPtrBinaryTreeIterator.Extract;\r\nvar\r\n OldCursor: TJclPtrBinaryNode;\r\nbegin\r\n if FOwnTree.ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n CheckValid;\r\n Valid := False;\r\n OldCursor := FCursor;\r\n if OldCursor <> nil then\r\n begin\r\n repeat\r\n FCursor := GetNextCursor;\r\n until (FCursor = nil) or FOwnTree.RemoveSingleElement\r\n or (not FEqualityComparer.ItemsEqual(OldCursor.Value, FCursor.Value));\r\n FOwnTree.Extract(OldCursor.Value);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.WriteUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclPtrBinaryTreeIterator.ExtractChild(Index: Integer);\r\nbegin\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nprocedure TJclPtrBinaryTreeIterator.ExtractChildren;\r\nbegin\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nfunction TJclPtrBinaryTreeIterator.GetChild(Index: Integer): Pointer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := nil;\r\n if (FCursor <> nil) and (Index = 0) and (FCursor.Left <> nil) then\r\n FCursor := FCursor.Left\r\n else\r\n if (FCursor <> nil) and (Index = 0) then\r\n FCursor := FCursor.Right\r\n else\r\n if (FCursor <> nil) and (Index = 1) then\r\n FCursor := FCursor.Right\r\n else\r\n FCursor := nil;\r\n if FCursor <> nil then\r\n Result := FCursor.Value\r\n else\r\n if not FOwnTree.ReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclPtrBinaryTreeIterator.GetPointer: Pointer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n CheckValid;\r\n Result := nil;\r\n if FCursor <> nil then\r\n Result := FCursor.Value\r\n else\r\n if not FOwnTree.ReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclPtrBinaryTreeIterator.HasChild(Index: Integer): Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if (FCursor <> nil) and (Index = 0) then\r\n Result := (FCursor.Left <> nil) or (FCursor.Right <> nil)\r\n else\r\n if (FCursor <> nil) and (Index = 1) then\r\n Result := (FCursor.Left <> nil) and (FCursor.Right <> nil)\r\n else\r\n Result := False;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclPtrBinaryTreeIterator.HasLeft: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := (FCursor <> nil) and (FCursor.Left <> nil);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclPtrBinaryTreeIterator.HasNext: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Valid then\r\n Result := GetNextCursor <> nil\r\n else\r\n Result := FCursor <> nil;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclPtrBinaryTreeIterator.HasParent: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := (FCursor <> nil) and (FCursor.Parent <> nil);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclPtrBinaryTreeIterator.HasPrevious: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Valid then\r\n Result := GetPreviousCursor <> nil\r\n else\r\n Result := FCursor <> nil;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclPtrBinaryTreeIterator.HasRight: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := (FCursor <> nil) and (FCursor.Right <> nil);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclPtrBinaryTreeIterator.IndexOfChild(APtr: Pointer): Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := -1;\r\n if FCursor <> nil then\r\n begin\r\n if FCursor.Left <> nil then\r\n begin\r\n if FEqualityComparer.ItemsEqual(FCursor.Left.Value, APtr) then\r\n Result := 0\r\n else\r\n if (FCursor.Right <> nil) and FEqualityComparer.ItemsEqual(FCursor.Right.Value, APtr) then\r\n Result := 1;\r\n end\r\n else\r\n if (FCursor.Right <> nil) and FEqualityComparer.ItemsEqual(FCursor.Right.Value, APtr) then\r\n Result := 0;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclPtrBinaryTreeIterator.Insert(APtr: Pointer): Boolean;\r\nbegin\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nfunction TJclPtrBinaryTreeIterator.InsertChild(Index: Integer; APtr: Pointer): Boolean;\r\nbegin\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nfunction TJclPtrBinaryTreeIterator.IteratorEquals(const AIterator: IJclPtrIterator): Boolean;\r\nvar\r\n Obj: TObject;\r\n ItrObj: TJclPtrBinaryTreeIterator;\r\nbegin\r\n Result := False;\r\n if AIterator = nil then\r\n Exit;\r\n Obj := AIterator.GetIteratorReference;\r\n if Obj is TJclPtrBinaryTreeIterator then\r\n begin\r\n ItrObj := TJclPtrBinaryTreeIterator(Obj);\r\n Result := (FOwnTree = ItrObj.FOwnTree) and (FCursor = ItrObj.FCursor) and (Valid = ItrObj.Valid);\r\n end;\r\nend;\r\n\r\nfunction TJclPtrBinaryTreeIterator.Left: Pointer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := nil;\r\n if FCursor <> nil then\r\n FCursor := FCursor.Left;\r\n if FCursor <> nil then\r\n Result := FCursor.Value\r\n else\r\n if not FOwnTree.ReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\n{$IFDEF SUPPORTS_FOR_IN}\r\nfunction TJclPtrBinaryTreeIterator.MoveNext: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Valid then\r\n FCursor := GetNextCursor\r\n else\r\n Valid := True;\r\n Result := FCursor <> nil;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n{$ENDIF SUPPORTS_FOR_IN}\r\n\r\nfunction TJclPtrBinaryTreeIterator.Next: Pointer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Valid then\r\n FCursor := GetNextCursor\r\n else\r\n Valid := True;\r\n Result := nil;\r\n if FCursor <> nil then\r\n Result := FCursor.Value\r\n else\r\n if not FOwnTree.ReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclPtrBinaryTreeIterator.NextIndex: Integer;\r\nbegin\r\n // No index\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nfunction TJclPtrBinaryTreeIterator.Parent: Pointer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := nil;\r\n if FCursor <> nil then\r\n FCursor := FCursor.Parent;\r\n if FCursor <> nil then\r\n Result := FCursor.Value\r\n else\r\n if not FOwnTree.ReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclPtrBinaryTreeIterator.Previous: Pointer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Valid then\r\n FCursor := GetPreviousCursor\r\n else\r\n Valid := True;\r\n Result := nil;\r\n if FCursor <> nil then\r\n Result := FCursor.Value\r\n else\r\n if not FOwnTree.ReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclPtrBinaryTreeIterator.PreviousIndex: Integer;\r\nbegin\r\n // No index\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nprocedure TJclPtrBinaryTreeIterator.Remove;\r\nvar\r\n OldCursor: TJclPtrBinaryNode;\r\nbegin\r\n if FOwnTree.ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n CheckValid;\r\n Valid := False;\r\n OldCursor := FCursor;\r\n if OldCursor <> nil then\r\n begin\r\n repeat\r\n FCursor := GetNextCursor;\r\n until (FCursor = nil) or FOwnTree.RemoveSingleElement\r\n or (not FEqualityComparer.ItemsEqual(OldCursor.Value, FCursor.Value));\r\n FOwnTree.Remove(OldCursor.Value);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.WriteUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclPtrBinaryTreeIterator.Reset;\r\nvar\r\n NewCursor: TJclPtrBinaryNode;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Valid := False;\r\n case FStart of\r\n isFirst:\r\n begin\r\n NewCursor := FCursor;\r\n while NewCursor <> nil do\r\n begin\r\n NewCursor := GetPreviousCursor;\r\n if NewCursor <> nil then\r\n FCursor := NewCursor;\r\n end;\r\n end;\r\n isLast:\r\n begin\r\n NewCursor := FCursor;\r\n while NewCursor <> nil do\r\n begin\r\n NewCursor := GetNextCursor;\r\n if NewCursor <> nil then\r\n FCursor := NewCursor;\r\n end;\r\n end;\r\n isRoot:\r\n begin\r\n while (FCursor <> nil) and (FCursor.Parent <> nil) do\r\n FCursor := FCursor.Parent;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclPtrBinaryTreeIterator.Right: Pointer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := nil;\r\n if FCursor <> nil then\r\n FCursor := FCursor.Right;\r\n if FCursor <> nil then\r\n Result := FCursor.Value\r\n else\r\n if not FOwnTree.ReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclPtrBinaryTreeIterator.SetChild(Index: Integer; APtr: Pointer);\r\nbegin\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nprocedure TJclPtrBinaryTreeIterator.SetPointer(APtr: Pointer);\r\nbegin\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\n//=== { TJclPreOrderPtrBinaryTreeIterator } ===================================================\r\n\r\nfunction TJclPreOrderPtrBinaryTreeIterator.CreateEmptyIterator: TJclAbstractIterator;\r\nbegin\r\n Result := TJclPreOrderPtrBinaryTreeIterator.Create(FOwnTree, FCursor, Valid, FStart);\r\nend;\r\n\r\nfunction TJclPreOrderPtrBinaryTreeIterator.GetNextCursor: TJclPtrBinaryNode;\r\nvar\r\n LastRet: TJclPtrBinaryNode;\r\nbegin\r\n Result := FCursor;\r\n if Result = nil then\r\n Exit;\r\n LastRet := Result;\r\n if Result.Left <> nil then\r\n Result := Result.Left\r\n else\r\n if Result.Right <> nil then\r\n Result := Result.Right\r\n else\r\n begin\r\n Result := Result.Parent;\r\n while (Result <> nil) and ((Result.Right = nil) or (Result.Right = LastRet)) do\r\n begin\r\n LastRet := Result;\r\n Result := Result.Parent;\r\n end;\r\n if Result <> nil then // not root\r\n Result := Result.Right;\r\n end;\r\nend;\r\n\r\nfunction TJclPreOrderPtrBinaryTreeIterator.GetPreviousCursor: TJclPtrBinaryNode;\r\nvar\r\n LastRet: TJclPtrBinaryNode;\r\nbegin\r\n Result := FCursor;\r\n if Result = nil then\r\n Exit;\r\n LastRet := Result;\r\n Result := Result.Parent;\r\n if (Result <> nil) and (Result.Left <> LastRet) and (Result.Left <> nil) then\r\n // come from Right\r\n begin\r\n Result := Result.Left;\r\n while (Result.Left <> nil) or (Result.Right <> nil) do // both childs\r\n begin\r\n if Result.Right <> nil then // right child first\r\n Result := Result.Right\r\n else\r\n Result := Result.Left;\r\n end;\r\n end;\r\nend;\r\n\r\n//=== { TJclInOrderPtrBinaryTreeIterator } ====================================================\r\n\r\nfunction TJclInOrderPtrBinaryTreeIterator.CreateEmptyIterator: TJclAbstractIterator;\r\nbegin\r\n Result := TJclInOrderPtrBinaryTreeIterator.Create(FOwnTree, FCursor, Valid, FStart);\r\nend;\r\n\r\nfunction TJclInOrderPtrBinaryTreeIterator.GetNextCursor: TJclPtrBinaryNode;\r\nvar\r\n LastRet: TJclPtrBinaryNode;\r\nbegin\r\n Result := FCursor;\r\n if Result = nil then\r\n Exit;\r\n if Result.Right <> nil then\r\n begin\r\n Result := Result.Right;\r\n while (Result.Left <> nil) do\r\n Result := Result.Left;\r\n end\r\n else\r\n begin\r\n LastRet := Result;\r\n Result := Result.Parent;\r\n while (Result <> nil) and (Result.Right = LastRet) do\r\n begin\r\n LastRet := Result;\r\n Result := Result.Parent;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJclInOrderPtrBinaryTreeIterator.GetPreviousCursor: TJclPtrBinaryNode;\r\nvar\r\n LastRet: TJclPtrBinaryNode;\r\nbegin\r\n Result := FCursor;\r\n if Result = nil then\r\n Exit;\r\n if Result.Left <> nil then\r\n begin\r\n Result := Result.Left;\r\n while Result.Right <> nil do\r\n Result := Result.Right;\r\n end\r\n else\r\n begin\r\n LastRet := Result;\r\n Result := Result.Parent;\r\n while (Result <> nil) and (Result.Right <> LastRet) do // Come from Left\r\n begin\r\n LastRet := Result;\r\n Result := Result.Parent;\r\n end;\r\n end;\r\nend;\r\n\r\n//=== { TJclPostOrderPtrBinaryTreeIterator } ==================================================\r\n\r\nfunction TJclPostOrderPtrBinaryTreeIterator.CreateEmptyIterator: TJclAbstractIterator;\r\nbegin\r\n Result := TJclPostOrderPtrBinaryTreeIterator.Create(FOwnTree, FCursor, Valid, FStart);\r\nend;\r\n\r\nfunction TJclPostOrderPtrBinaryTreeIterator.GetNextCursor: TJclPtrBinaryNode;\r\nvar\r\n LastRet: TJclPtrBinaryNode;\r\nbegin\r\n Result := FCursor;\r\n if Result = nil then\r\n Exit;\r\n LastRet := Result;\r\n Result := Result.Parent;\r\n if (Result <> nil) and (Result.Right <> nil) and (Result.Right <> LastRet) then\r\n begin\r\n Result := Result.Right;\r\n while (Result.Left <> nil) or (Result.Right <> nil) do\r\n begin\r\n if Result.Left <> nil then\r\n Result := Result.Left\r\n else\r\n Result := Result.Right;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJclPostOrderPtrBinaryTreeIterator.GetPreviousCursor: TJclPtrBinaryNode;\r\nvar\r\n LastRet: TJclPtrBinaryNode;\r\nbegin\r\n Result := FCursor;\r\n if Result = nil then\r\n Exit;\r\n if Result.Right <> nil then\r\n Result := Result.Right\r\n else\r\n if Result.Left <> nil then\r\n Result := Result.Left\r\n else\r\n begin\r\n LastRet := Result;\r\n Result := Result.Parent;\r\n while (Result <> nil) and ((Result.Left = nil) or (Result.Left = LastRet)) do\r\n begin\r\n LastRet := Result;\r\n Result := Result.Parent;\r\n end;\r\n if Result <> nil then // not root\r\n Result := Result.Left;\r\n end;\r\nend;\r\n\r\n//=== { TJclBinaryTree } =================================================\r\n\r\nconstructor TJclBinaryTree.Create(ACompare: TCompare; AOwnsObjects: Boolean);\r\nbegin\r\n inherited Create(AOwnsObjects);\r\n FTraverseOrder := toOrder;\r\n FMaxDepth := 0;\r\n FAutoPackParameter := 2;\r\n SetCompare(ACompare);\r\nend;\r\n\r\ndestructor TJclBinaryTree.Destroy;\r\nbegin\r\n FReadOnly := False;\r\n Clear;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJclBinaryTree.Add(AObject: TObject): Boolean;\r\nvar\r\n NewNode, Current, Save: TJclBinaryNode;\r\n Comp, Depth: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n // Insert into right place\r\n if FAllowDefaultElements or not ItemsEqual(AObject, nil) then\r\n begin\r\n Save := nil;\r\n Current := FRoot;\r\n Comp := 1;\r\n Depth := 0;\r\n while Current <> nil do\r\n begin\r\n Inc(Depth);\r\n Save := Current;\r\n Comp := ItemsCompare(AObject, Current.Value);\r\n if Comp < 0 then\r\n Current := Current.Left\r\n else\r\n if Comp > 0 then\r\n Current := Current.Right\r\n else\r\n if CheckDuplicate then\r\n Current := Current.Left // arbitrary decision\r\n else\r\n Break;\r\n end;\r\n if (Comp <> 0) or CheckDuplicate then\r\n begin\r\n NewNode := TJclBinaryNode.Create;\r\n NewNode.Value := AObject;\r\n NewNode.Parent := Save;\r\n if Save = nil then\r\n FRoot := NewNode\r\n else\r\n if ItemsCompare(NewNode.Value, Save.Value) <= 0 then\r\n Save.Left := NewNode\r\n else\r\n Save.Right := NewNode;\r\n Inc(FSize);\r\n Inc(Depth);\r\n if Depth > FMaxDepth then\r\n FMaxDepth := Depth;\r\n Result := True;\r\n AutoPack;\r\n end\r\n else\r\n Result := False;\r\n end\r\n else\r\n Result := False;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclBinaryTree.AddAll(const ACollection: IJclCollection): Boolean;\r\nvar\r\n It: IJclIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n Result := Add(It.Next) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclBinaryTree.AssignDataTo(Dest: TJclAbstractContainerBase);\r\nvar\r\n ADest: TJclBinaryTree;\r\n ACollection: IJclCollection;\r\nbegin\r\n inherited AssignDataTo(Dest);\r\n if Dest is TJclBinaryTree then\r\n begin\r\n ADest := TJclBinaryTree(Dest);\r\n ADest.Clear;\r\n ADest.FSize := FSize;\r\n if FRoot <> nil then\r\n ADest.FRoot := CloneNode(FRoot, nil);\r\n end\r\n else\r\n if Supports(IInterface(Dest), IJclCollection, ACollection) then\r\n begin\r\n ACollection.Clear;\r\n ACollection.AddAll(Self);\r\n end;\r\nend;\r\n\r\nprocedure TJclBinaryTree.AssignPropertiesTo(Dest: TJclAbstractContainerBase);\r\nbegin\r\n inherited AssignPropertiesto(Dest);\r\n if Dest is TJclBinaryTree then\r\n TJclBinaryTree(Dest).FTraverseOrder := FTraverseOrder;\r\nend;\r\n\r\nprocedure TJclBinaryTree.AutoPack;\r\nbegin\r\n case FAutoPackStrategy of\r\n //apsDisabled: ;\r\n apsAgressive:\r\n if (FMaxDepth > 1) and (((1 shl (FMaxDepth - 1)) - 1) > FSize) then\r\n Pack;\r\n // apsIncremental: ;\r\n apsProportional:\r\n if (FMaxDepth > FAutoPackParameter) and (((1 shl (FMaxDepth - FAutoPackParameter)) - 1) > FSize) then\r\n Pack;\r\n end;\r\nend;\r\n\r\nfunction TJclBinaryTree.BuildTree(const LeafArray: array of TJclBinaryNode; Left, Right: Integer; Parent: TJclBinaryNode;\r\n Offset: Integer): TJclBinaryNode;\r\nvar\r\n Middle: Integer;\r\nbegin\r\n Middle := (Left + Right + Offset) shr 1;\r\n Result := LeafArray[Middle];\r\n Result.Parent := Parent;\r\n if Middle > Left then\r\n Result.Left := BuildTree(LeafArray, Left, Middle - 1, Result, 0)\r\n else\r\n Result.Left := nil;\r\n if Middle < Right then\r\n Result.Right := BuildTree(LeafArray, Middle + 1, Right, Result, 1)\r\n else\r\n Result.Right := nil;\r\nend;\r\n\r\nprocedure TJclBinaryTree.Clear;\r\nvar\r\n Current, Parent: TJclBinaryNode;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n // postorder\r\n Current := FRoot;\r\n if Current = nil then\r\n Exit;\r\n // find first in post-order\r\n while (Current.Left <> nil) or (Current.Right <> nil) do\r\n begin\r\n if Current.Left <> nil then\r\n Current := Current.Left\r\n else\r\n Current := Current.Right;\r\n end;\r\n // for all items in the tree in post-order\r\n repeat\r\n Parent := Current.Parent;\r\n // remove reference\r\n if Parent <> nil then\r\n begin\r\n if Parent.Left = Current then\r\n Parent.Left := nil\r\n else\r\n if Parent.Right = Current then\r\n Parent.Right := nil;\r\n end;\r\n\r\n // free item\r\n FreeObject(Current.Value);\r\n Current.Free;\r\n\r\n // find next item\r\n Current := Parent;\r\n if (Current <> nil) and (Current.Right <> nil) then\r\n begin\r\n Current := Current.Right;\r\n while (Current.Left <> nil) or (Current.Right <> nil) do\r\n begin\r\n if Current.Left <> nil then\r\n Current := Current.Left\r\n else\r\n Current := Current.Right;\r\n end;\r\n end;\r\n until Current = nil;\r\n FRoot := nil;\r\n FSize := 0;\r\n FMaxDepth := 0;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclBinaryTree.CloneNode(Node, Parent: TJclBinaryNode): TJclBinaryNode;\r\nbegin\r\n Result := TJclBinaryNode.Create;\r\n Result.Value := Node.Value;\r\n Result.Parent := Parent;\r\n if Node.Left <> nil then\r\n Result.Left := CloneNode(Node.Left, Result); // recursive call\r\n if Node.Right <> nil then\r\n Result.Right := CloneNode(Node.Right, Result); // recursive call\r\nend;\r\n\r\nfunction TJclBinaryTree.CollectionEquals(const ACollection: IJclCollection): Boolean;\r\nvar\r\n It, ItSelf: IJclIterator;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n if FSize <> ACollection.Size then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n ItSelf := First;\r\n while ItSelf.HasNext do\r\n if not ItemsEqual(ItSelf.Next, It.Next) then\r\n begin\r\n Result := False;\r\n Break;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclBinaryTree.Contains(AObject: TObject): Boolean;\r\nvar\r\n Comp: Integer;\r\n Current: TJclBinaryNode;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n Current := FRoot;\r\n while Current <> nil do\r\n begin\r\n Comp := ItemsCompare(Current.Value, AObject);\r\n if Comp = 0 then\r\n begin\r\n Result := True;\r\n Break;\r\n end\r\n else\r\n if Comp > 0 then\r\n Current := Current.Left\r\n else\r\n Current := Current.Right;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclBinaryTree.ContainsAll(const ACollection: IJclCollection): Boolean;\r\nvar\r\n It: IJclIterator;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := True;\r\n if ACollection = nil then\r\n Exit;\r\n It := ACollection.First;\r\n while Result and It.HasNext do\r\n Result := Contains(It.Next);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclBinaryTree.Extract(AObject: TObject): Boolean;\r\nvar\r\n Current, Successor: TJclBinaryNode;\r\n Comp: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n // locate AObject in the tree\r\n Current := FRoot;\r\n repeat\r\n while Current <> nil do\r\n begin\r\n Comp := ItemsCompare(AObject, Current.Value);\r\n if Comp = 0 then\r\n Break\r\n else\r\n if Comp < 0 then\r\n Current := Current.Left\r\n else\r\n Current := Current.Right;\r\n end;\r\n if Current = nil then\r\n Break;\r\n Result := True;\r\n // Remove Current from tree\r\n if (Current.Left = nil) and (Current.Right <> nil) then\r\n begin\r\n // remove references to Current\r\n Current.Right.Parent := Current.Parent;\r\n if Current.Parent <> nil then\r\n begin\r\n if Current.Parent.Left = Current then\r\n Current.Parent.Left := Current.Right\r\n else\r\n Current.Parent.Right := Current.Right;\r\n end\r\n else\r\n // fix root\r\n FRoot := Current.Right;\r\n Successor := Current.Parent;\r\n if Successor = nil then\r\n Successor := FRoot;\r\n end\r\n else\r\n if (Current.Left <> nil) and (Current.Right = nil) then\r\n begin\r\n // remove references to Current\r\n Current.Left.Parent := Current.Parent;\r\n if Current.Parent <> nil then\r\n begin\r\n if Current.Parent.Left = Current then\r\n Current.Parent.Left := Current.Left\r\n else\r\n Current.Parent.Right := Current.Left;\r\n end\r\n else\r\n // fix root\r\n FRoot := Current.Left;\r\n Successor := Current.Parent;\r\n if Successor = nil then\r\n Successor := FRoot;\r\n end\r\n else\r\n if (Current.Left <> nil) and (Current.Right <> nil) then\r\n begin\r\n // find the successor in tree\r\n Successor := Current.Right;\r\n while Successor.Left <> nil do\r\n Successor := Successor.Left;\r\n\r\n if Successor <> Current.Right then\r\n begin\r\n // remove references to successor\r\n Successor.Parent.Left := Successor.Right;\r\n if Successor.Right <> nil then\r\n Successor.Right.Parent := Successor.Parent;\r\n Successor.Right := Current.Right;\r\n if Successor.Right <> nil then\r\n Successor.Right.Parent := Successor;\r\n end;\r\n\r\n // insert successor in new position\r\n Successor.Left := Current.Left;\r\n if Current.Left <> nil then\r\n Current.Left.Parent := Successor;\r\n Successor.Parent := Current.Parent;\r\n if Current.Parent <> nil then\r\n begin\r\n if Current.Parent.Left = Current then\r\n Current.Parent.Left := Successor\r\n else\r\n Current.Parent.Right := Successor;\r\n end\r\n else\r\n // fix root\r\n FRoot := Successor;\r\n Successor := Current.Parent;\r\n if Successor <> nil then\r\n Successor := FRoot;\r\n end\r\n else\r\n begin\r\n // (Current.Left = nil) and (Current.Right = nil)\r\n Successor := Current.Parent;\r\n if Successor <> nil then\r\n begin\r\n // remove references from parent\r\n if Successor.Left = Current then\r\n Successor.Left := nil\r\n else\r\n Successor.Right := nil;\r\n end\r\n else\r\n FRoot := nil;\r\n end;\r\n Current.Value := nil;\r\n Current.Free;\r\n Dec(FSize);\r\n Current := Successor;\r\n until FRemoveSingleElement or (Current = nil);\r\n AutoPack;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclBinaryTree.ExtractAll(const ACollection: IJclCollection): Boolean;\r\nvar\r\n It: IJclIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n Result := Extract(It.Next) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclBinaryTree.First: IJclIterator;\r\nvar\r\n Start: TJclBinaryNode;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Start := FRoot;\r\n case GetTraverseOrder of\r\n toPreOrder:\r\n Result := TJclPreOrderBinaryTreeIterator.Create(Self, Start, False, isFirst);\r\n toOrder:\r\n begin\r\n if Start <> nil then\r\n while Start.Left <> nil do\r\n Start := Start.Left;\r\n Result := TJclInOrderBinaryTreeIterator.Create(Self, Start, False, isFirst);\r\n end;\r\n toPostOrder:\r\n begin\r\n if Start <> nil then\r\n while (Start.Left <> nil) or (Start.Right <> nil) do\r\n begin\r\n if Start.Left <> nil then\r\n Start := Start.Left\r\n else\r\n Start := Start.Right;\r\n end;\r\n Result := TJclPostOrderBinaryTreeIterator.Create(Self, Start, False, isFirst);\r\n end;\r\n else\r\n Result := nil;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\n{$IFDEF SUPPORTS_FOR_IN}\r\nfunction TJclBinaryTree.GetEnumerator: IJclIterator;\r\nbegin\r\n Result := First;\r\nend;\r\n{$ENDIF SUPPORTS_FOR_IN}\r\n\r\nfunction TJclBinaryTree.GetRoot: IJclTreeIterator;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n case GetTraverseOrder of\r\n toPreOrder:\r\n Result := TJclPreOrderBinaryTreeIterator.Create(Self, FRoot, False, isRoot);\r\n toOrder:\r\n Result := TJclInOrderBinaryTreeIterator.Create(Self, FRoot, False, isRoot);\r\n toPostOrder:\r\n Result := TJclPostOrderBinaryTreeIterator.Create(Self, FRoot, False, isRoot);\r\n else\r\n Result := nil;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclBinaryTree.GetTraverseOrder: TJclTraverseOrder;\r\nbegin\r\n Result := FTraverseOrder;\r\nend;\r\n\r\nfunction TJclBinaryTree.IsEmpty: Boolean;\r\nbegin\r\n Result := FSize = 0;\r\nend;\r\n\r\nfunction TJclBinaryTree.Last: IJclIterator;\r\nvar\r\n Start: TJclBinaryNode;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Start := FRoot;\r\n case FTraverseOrder of\r\n toPreOrder:\r\n begin\r\n if Start <> nil then\r\n while (Start.Left <> nil) or (Start.Right <> nil) do\r\n begin\r\n if Start.Right <> nil then\r\n Start := Start.Right\r\n else\r\n Start := Start.Left;\r\n end;\r\n Result := TJclPreOrderBinaryTreeIterator.Create(Self, Start, False, isLast);\r\n end;\r\n toOrder:\r\n begin\r\n if Start <> nil then\r\n while Start.Right <> nil do\r\n Start := Start.Right;\r\n Result := TJclInOrderBinaryTreeIterator.Create(Self, Start, False, isLast);\r\n end;\r\n toPostOrder:\r\n Result := TJclPostOrderBinaryTreeIterator.Create(Self, Start, False, isLast);\r\n else\r\n Result := nil;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclBinaryTree.Pack;\r\nvar\r\n LeafArray: array of TJclBinaryNode;\r\n ANode, BNode: TJclBinaryNode;\r\n Index: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n SetLength(Leafarray, FSize);\r\n try\r\n // in order enumeration of nodes\r\n ANode := FRoot;\r\n if ANode <> nil then\r\n begin\r\n // find first node\r\n while ANode.Left <> nil do\r\n ANode := ANode.Left;\r\n\r\n Index := 0;\r\n while ANode <> nil do\r\n begin\r\n LeafArray[Index] := ANode;\r\n Inc(Index);\r\n if ANode.Right <> nil then\r\n begin\r\n ANode := ANode.Right;\r\n while (ANode.Left <> nil) do\r\n ANode := ANode.Left;\r\n end\r\n else\r\n begin\r\n BNode := ANode;\r\n ANode := ANode.Parent;\r\n while (ANode <> nil) and (ANode.Right = BNode) do\r\n begin\r\n BNode := ANode;\r\n ANode := ANode.Parent;\r\n end;\r\n end;\r\n end;\r\n\r\n Index := FSize shr 1;\r\n FRoot := LeafArray[Index];\r\n FRoot.Parent := nil;\r\n if Index > 0 then\r\n FRoot.Left := BuildTree(LeafArray, 0, Index - 1, FRoot, 0)\r\n else\r\n FRoot.Left := nil;\r\n if Index < (FSize - 1) then\r\n FRoot.Right := BuildTree(LeafArray, Index + 1, FSize - 1, FRoot, 1)\r\n else\r\n FRoot.Right := nil;\r\n end;\r\n finally\r\n SetLength(LeafArray, 0);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclBinaryTree.Remove(AObject: TObject): Boolean;\r\nvar\r\n Extracted: TObject;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := Extract(AObject);\r\n if Result then\r\n begin\r\n Extracted := AObject;\r\n FreeObject(Extracted);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclBinaryTree.RemoveAll(const ACollection: IJclCollection): Boolean;\r\nvar\r\n It: IJclIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n Result := Remove(It.Next) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclBinaryTree.RetainAll(const ACollection: IJclCollection): Boolean;\r\nvar\r\n It: IJclIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := First;\r\n while It.HasNext do\r\n if not ACollection.Contains(It.Next) then\r\n It.Remove;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclBinaryTree.SetCapacity(Value: Integer);\r\nbegin\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nprocedure TJclBinaryTree.SetTraverseOrder(Value: TJclTraverseOrder);\r\nbegin\r\n FTraverseOrder := Value;\r\nend;\r\n\r\nfunction TJclBinaryTree.Size: Integer;\r\nbegin\r\n Result := FSize;\r\nend;\r\n\r\nfunction TJclBinaryTree.CreateEmptyContainer: TJclAbstractContainerBase;\r\nbegin\r\n Result := TJclBinaryTree.Create(Compare, False);\r\n AssignPropertiesTo(Result);\r\nend;\r\n\r\n//=== { TJclBinaryTreeIterator } ===========================================================\r\n\r\nconstructor TJclBinaryTreeIterator.Create(const AOwnTree: IJclCollection; ACursor: TJclBinaryNode; AValid: Boolean; AStart: TItrStart);\r\nbegin\r\n inherited Create(AValid);\r\n FCursor := ACursor;\r\n FStart := AStart;\r\n FOwnTree := AOwnTree;\r\n FEqualityComparer := AOwnTree as IJclEqualityComparer;\r\nend;\r\n\r\nfunction TJclBinaryTreeIterator.Add(AObject: TObject): Boolean;\r\nbegin\r\n Result := FOwnTree.Add(AObject);\r\nend;\r\n\r\nfunction TJclBinaryTreeIterator.AddChild(AObject: TObject): Boolean;\r\nbegin\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nprocedure TJclBinaryTreeIterator.AssignPropertiesTo(Dest: TJclAbstractIterator);\r\nvar\r\n ADest: TJclBinaryTreeIterator;\r\nbegin\r\n inherited AssignPropertiesTo(Dest);\r\n if Dest is TJclBinaryTreeIterator then\r\n begin\r\n ADest := TJclBinaryTreeIterator(Dest);\r\n ADest.FCursor := FCursor;\r\n ADest.FOwnTree := FOwnTree;\r\n ADest.FEqualityComparer := FEqualityComparer;\r\n ADest.FStart := FStart;\r\n end;\r\nend;\r\n\r\nfunction TJclBinaryTreeIterator.ChildrenCount: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := 0;\r\n if FCursor <> nil then\r\n begin\r\n if FCursor.Left <> nil then\r\n Inc(Result);\r\n if FCursor.Right <> nil then\r\n Inc(Result);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclBinaryTreeIterator.DeleteChild(Index: Integer);\r\nbegin\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nprocedure TJclBinaryTreeIterator.DeleteChildren;\r\nbegin\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nprocedure TJclBinaryTreeIterator.Extract;\r\nvar\r\n OldCursor: TJclBinaryNode;\r\nbegin\r\n if FOwnTree.ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n CheckValid;\r\n Valid := False;\r\n OldCursor := FCursor;\r\n if OldCursor <> nil then\r\n begin\r\n repeat\r\n FCursor := GetNextCursor;\r\n until (FCursor = nil) or FOwnTree.RemoveSingleElement\r\n or (not FEqualityComparer.ItemsEqual(OldCursor.Value, FCursor.Value));\r\n FOwnTree.Extract(OldCursor.Value);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.WriteUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclBinaryTreeIterator.ExtractChild(Index: Integer);\r\nbegin\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nprocedure TJclBinaryTreeIterator.ExtractChildren;\r\nbegin\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nfunction TJclBinaryTreeIterator.GetChild(Index: Integer): TObject;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := nil;\r\n if (FCursor <> nil) and (Index = 0) and (FCursor.Left <> nil) then\r\n FCursor := FCursor.Left\r\n else\r\n if (FCursor <> nil) and (Index = 0) then\r\n FCursor := FCursor.Right\r\n else\r\n if (FCursor <> nil) and (Index = 1) then\r\n FCursor := FCursor.Right\r\n else\r\n FCursor := nil;\r\n if FCursor <> nil then\r\n Result := FCursor.Value\r\n else\r\n if not FOwnTree.ReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclBinaryTreeIterator.GetObject: TObject;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n CheckValid;\r\n Result := nil;\r\n if FCursor <> nil then\r\n Result := FCursor.Value\r\n else\r\n if not FOwnTree.ReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclBinaryTreeIterator.HasChild(Index: Integer): Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if (FCursor <> nil) and (Index = 0) then\r\n Result := (FCursor.Left <> nil) or (FCursor.Right <> nil)\r\n else\r\n if (FCursor <> nil) and (Index = 1) then\r\n Result := (FCursor.Left <> nil) and (FCursor.Right <> nil)\r\n else\r\n Result := False;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclBinaryTreeIterator.HasLeft: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := (FCursor <> nil) and (FCursor.Left <> nil);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclBinaryTreeIterator.HasNext: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Valid then\r\n Result := GetNextCursor <> nil\r\n else\r\n Result := FCursor <> nil;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclBinaryTreeIterator.HasParent: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := (FCursor <> nil) and (FCursor.Parent <> nil);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclBinaryTreeIterator.HasPrevious: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Valid then\r\n Result := GetPreviousCursor <> nil\r\n else\r\n Result := FCursor <> nil;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclBinaryTreeIterator.HasRight: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := (FCursor <> nil) and (FCursor.Right <> nil);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclBinaryTreeIterator.IndexOfChild(AObject: TObject): Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := -1;\r\n if FCursor <> nil then\r\n begin\r\n if FCursor.Left <> nil then\r\n begin\r\n if FEqualityComparer.ItemsEqual(FCursor.Left.Value, AObject) then\r\n Result := 0\r\n else\r\n if (FCursor.Right <> nil) and FEqualityComparer.ItemsEqual(FCursor.Right.Value, AObject) then\r\n Result := 1;\r\n end\r\n else\r\n if (FCursor.Right <> nil) and FEqualityComparer.ItemsEqual(FCursor.Right.Value, AObject) then\r\n Result := 0;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclBinaryTreeIterator.Insert(AObject: TObject): Boolean;\r\nbegin\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nfunction TJclBinaryTreeIterator.InsertChild(Index: Integer; AObject: TObject): Boolean;\r\nbegin\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nfunction TJclBinaryTreeIterator.IteratorEquals(const AIterator: IJclIterator): Boolean;\r\nvar\r\n Obj: TObject;\r\n ItrObj: TJclBinaryTreeIterator;\r\nbegin\r\n Result := False;\r\n if AIterator = nil then\r\n Exit;\r\n Obj := AIterator.GetIteratorReference;\r\n if Obj is TJclBinaryTreeIterator then\r\n begin\r\n ItrObj := TJclBinaryTreeIterator(Obj);\r\n Result := (FOwnTree = ItrObj.FOwnTree) and (FCursor = ItrObj.FCursor) and (Valid = ItrObj.Valid);\r\n end;\r\nend;\r\n\r\nfunction TJclBinaryTreeIterator.Left: TObject;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := nil;\r\n if FCursor <> nil then\r\n FCursor := FCursor.Left;\r\n if FCursor <> nil then\r\n Result := FCursor.Value\r\n else\r\n if not FOwnTree.ReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\n{$IFDEF SUPPORTS_FOR_IN}\r\nfunction TJclBinaryTreeIterator.MoveNext: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Valid then\r\n FCursor := GetNextCursor\r\n else\r\n Valid := True;\r\n Result := FCursor <> nil;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n{$ENDIF SUPPORTS_FOR_IN}\r\n\r\nfunction TJclBinaryTreeIterator.Next: TObject;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Valid then\r\n FCursor := GetNextCursor\r\n else\r\n Valid := True;\r\n Result := nil;\r\n if FCursor <> nil then\r\n Result := FCursor.Value\r\n else\r\n if not FOwnTree.ReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclBinaryTreeIterator.NextIndex: Integer;\r\nbegin\r\n // No index\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nfunction TJclBinaryTreeIterator.Parent: TObject;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := nil;\r\n if FCursor <> nil then\r\n FCursor := FCursor.Parent;\r\n if FCursor <> nil then\r\n Result := FCursor.Value\r\n else\r\n if not FOwnTree.ReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclBinaryTreeIterator.Previous: TObject;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Valid then\r\n FCursor := GetPreviousCursor\r\n else\r\n Valid := True;\r\n Result := nil;\r\n if FCursor <> nil then\r\n Result := FCursor.Value\r\n else\r\n if not FOwnTree.ReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclBinaryTreeIterator.PreviousIndex: Integer;\r\nbegin\r\n // No index\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nprocedure TJclBinaryTreeIterator.Remove;\r\nvar\r\n OldCursor: TJclBinaryNode;\r\nbegin\r\n if FOwnTree.ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n CheckValid;\r\n Valid := False;\r\n OldCursor := FCursor;\r\n if OldCursor <> nil then\r\n begin\r\n repeat\r\n FCursor := GetNextCursor;\r\n until (FCursor = nil) or FOwnTree.RemoveSingleElement\r\n or (not FEqualityComparer.ItemsEqual(OldCursor.Value, FCursor.Value));\r\n FOwnTree.Remove(OldCursor.Value);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.WriteUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclBinaryTreeIterator.Reset;\r\nvar\r\n NewCursor: TJclBinaryNode;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Valid := False;\r\n case FStart of\r\n isFirst:\r\n begin\r\n NewCursor := FCursor;\r\n while NewCursor <> nil do\r\n begin\r\n NewCursor := GetPreviousCursor;\r\n if NewCursor <> nil then\r\n FCursor := NewCursor;\r\n end;\r\n end;\r\n isLast:\r\n begin\r\n NewCursor := FCursor;\r\n while NewCursor <> nil do\r\n begin\r\n NewCursor := GetNextCursor;\r\n if NewCursor <> nil then\r\n FCursor := NewCursor;\r\n end;\r\n end;\r\n isRoot:\r\n begin\r\n while (FCursor <> nil) and (FCursor.Parent <> nil) do\r\n FCursor := FCursor.Parent;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclBinaryTreeIterator.Right: TObject;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := nil;\r\n if FCursor <> nil then\r\n FCursor := FCursor.Right;\r\n if FCursor <> nil then\r\n Result := FCursor.Value\r\n else\r\n if not FOwnTree.ReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclBinaryTreeIterator.SetChild(Index: Integer; AObject: TObject);\r\nbegin\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nprocedure TJclBinaryTreeIterator.SetObject(AObject: TObject);\r\nbegin\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\n//=== { TJclPreOrderBinaryTreeIterator } ===================================================\r\n\r\nfunction TJclPreOrderBinaryTreeIterator.CreateEmptyIterator: TJclAbstractIterator;\r\nbegin\r\n Result := TJclPreOrderBinaryTreeIterator.Create(FOwnTree, FCursor, Valid, FStart);\r\nend;\r\n\r\nfunction TJclPreOrderBinaryTreeIterator.GetNextCursor: TJclBinaryNode;\r\nvar\r\n LastRet: TJclBinaryNode;\r\nbegin\r\n Result := FCursor;\r\n if Result = nil then\r\n Exit;\r\n LastRet := Result;\r\n if Result.Left <> nil then\r\n Result := Result.Left\r\n else\r\n if Result.Right <> nil then\r\n Result := Result.Right\r\n else\r\n begin\r\n Result := Result.Parent;\r\n while (Result <> nil) and ((Result.Right = nil) or (Result.Right = LastRet)) do\r\n begin\r\n LastRet := Result;\r\n Result := Result.Parent;\r\n end;\r\n if Result <> nil then // not root\r\n Result := Result.Right;\r\n end;\r\nend;\r\n\r\nfunction TJclPreOrderBinaryTreeIterator.GetPreviousCursor: TJclBinaryNode;\r\nvar\r\n LastRet: TJclBinaryNode;\r\nbegin\r\n Result := FCursor;\r\n if Result = nil then\r\n Exit;\r\n LastRet := Result;\r\n Result := Result.Parent;\r\n if (Result <> nil) and (Result.Left <> LastRet) and (Result.Left <> nil) then\r\n // come from Right\r\n begin\r\n Result := Result.Left;\r\n while (Result.Left <> nil) or (Result.Right <> nil) do // both childs\r\n begin\r\n if Result.Right <> nil then // right child first\r\n Result := Result.Right\r\n else\r\n Result := Result.Left;\r\n end;\r\n end;\r\nend;\r\n\r\n//=== { TJclInOrderBinaryTreeIterator } ====================================================\r\n\r\nfunction TJclInOrderBinaryTreeIterator.CreateEmptyIterator: TJclAbstractIterator;\r\nbegin\r\n Result := TJclInOrderBinaryTreeIterator.Create(FOwnTree, FCursor, Valid, FStart);\r\nend;\r\n\r\nfunction TJclInOrderBinaryTreeIterator.GetNextCursor: TJclBinaryNode;\r\nvar\r\n LastRet: TJclBinaryNode;\r\nbegin\r\n Result := FCursor;\r\n if Result = nil then\r\n Exit;\r\n if Result.Right <> nil then\r\n begin\r\n Result := Result.Right;\r\n while (Result.Left <> nil) do\r\n Result := Result.Left;\r\n end\r\n else\r\n begin\r\n LastRet := Result;\r\n Result := Result.Parent;\r\n while (Result <> nil) and (Result.Right = LastRet) do\r\n begin\r\n LastRet := Result;\r\n Result := Result.Parent;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJclInOrderBinaryTreeIterator.GetPreviousCursor: TJclBinaryNode;\r\nvar\r\n LastRet: TJclBinaryNode;\r\nbegin\r\n Result := FCursor;\r\n if Result = nil then\r\n Exit;\r\n if Result.Left <> nil then\r\n begin\r\n Result := Result.Left;\r\n while Result.Right <> nil do\r\n Result := Result.Right;\r\n end\r\n else\r\n begin\r\n LastRet := Result;\r\n Result := Result.Parent;\r\n while (Result <> nil) and (Result.Right <> LastRet) do // Come from Left\r\n begin\r\n LastRet := Result;\r\n Result := Result.Parent;\r\n end;\r\n end;\r\nend;\r\n\r\n//=== { TJclPostOrderBinaryTreeIterator } ==================================================\r\n\r\nfunction TJclPostOrderBinaryTreeIterator.CreateEmptyIterator: TJclAbstractIterator;\r\nbegin\r\n Result := TJclPostOrderBinaryTreeIterator.Create(FOwnTree, FCursor, Valid, FStart);\r\nend;\r\n\r\nfunction TJclPostOrderBinaryTreeIterator.GetNextCursor: TJclBinaryNode;\r\nvar\r\n LastRet: TJclBinaryNode;\r\nbegin\r\n Result := FCursor;\r\n if Result = nil then\r\n Exit;\r\n LastRet := Result;\r\n Result := Result.Parent;\r\n if (Result <> nil) and (Result.Right <> nil) and (Result.Right <> LastRet) then\r\n begin\r\n Result := Result.Right;\r\n while (Result.Left <> nil) or (Result.Right <> nil) do\r\n begin\r\n if Result.Left <> nil then\r\n Result := Result.Left\r\n else\r\n Result := Result.Right;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJclPostOrderBinaryTreeIterator.GetPreviousCursor: TJclBinaryNode;\r\nvar\r\n LastRet: TJclBinaryNode;\r\nbegin\r\n Result := FCursor;\r\n if Result = nil then\r\n Exit;\r\n if Result.Right <> nil then\r\n Result := Result.Right\r\n else\r\n if Result.Left <> nil then\r\n Result := Result.Left\r\n else\r\n begin\r\n LastRet := Result;\r\n Result := Result.Parent;\r\n while (Result <> nil) and ((Result.Left = nil) or (Result.Left = LastRet)) do\r\n begin\r\n LastRet := Result;\r\n Result := Result.Parent;\r\n end;\r\n if Result <> nil then // not root\r\n Result := Result.Left;\r\n end;\r\nend;\r\n\r\n\r\n\r\n{$IFDEF SUPPORTS_GENERICS}\r\n//DOM-IGNORE-BEGIN\r\n\r\n//=== { TJclBinaryTree } =================================================\r\n\r\nconstructor TJclBinaryTree.Create(AOwnsItems: Boolean);\r\nbegin\r\n inherited Create(AOwnsItems);\r\n FTraverseOrder := toOrder;\r\n FMaxDepth := 0;\r\n FAutoPackParameter := 2;\r\nend;\r\n\r\ndestructor TJclBinaryTree.Destroy;\r\nbegin\r\n FReadOnly := False;\r\n Clear;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJclBinaryTree.Add(const AItem: T): Boolean;\r\nvar\r\n NewNode, Current, Save: TJclBinaryNode;\r\n Comp, Depth: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n // Insert into right place\r\n if FAllowDefaultElements or not ItemsEqual(AItem, Default(T)) then\r\n begin\r\n Save := nil;\r\n Current := FRoot;\r\n Comp := 1;\r\n Depth := 0;\r\n while Current <> nil do\r\n begin\r\n Inc(Depth);\r\n Save := Current;\r\n Comp := ItemsCompare(AItem, Current.Value);\r\n if Comp < 0 then\r\n Current := Current.Left\r\n else\r\n if Comp > 0 then\r\n Current := Current.Right\r\n else\r\n if CheckDuplicate then\r\n Current := Current.Left // arbitrary decision\r\n else\r\n Break;\r\n end;\r\n if (Comp <> 0) or CheckDuplicate then\r\n begin\r\n NewNode := TJclBinaryNode.Create;\r\n NewNode.Value := AItem;\r\n NewNode.Parent := Save;\r\n if Save = nil then\r\n FRoot := NewNode\r\n else\r\n if ItemsCompare(NewNode.Value, Save.Value) <= 0 then\r\n Save.Left := NewNode\r\n else\r\n Save.Right := NewNode;\r\n Inc(FSize);\r\n Inc(Depth);\r\n if Depth > FMaxDepth then\r\n FMaxDepth := Depth;\r\n Result := True;\r\n AutoPack;\r\n end\r\n else\r\n Result := False;\r\n end\r\n else\r\n Result := False;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclBinaryTree.AddAll(const ACollection: IJclCollection): Boolean;\r\nvar\r\n It: IJclIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n Result := Add(It.Next) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclBinaryTree.AssignDataTo(Dest: TJclAbstractContainerBase);\r\nvar\r\n ADest: TJclBinaryTree;\r\n ACollection: IJclCollection;\r\nbegin\r\n inherited AssignDataTo(Dest);\r\n if Dest is TJclBinaryTree then\r\n begin\r\n ADest := TJclBinaryTree(Dest);\r\n ADest.Clear;\r\n ADest.FSize := FSize;\r\n if FRoot <> nil then\r\n ADest.FRoot := CloneNode(FRoot, nil);\r\n end\r\n else\r\n if Supports(IInterface(Dest), IJclCollection, ACollection) then\r\n begin\r\n ACollection.Clear;\r\n ACollection.AddAll(Self);\r\n end;\r\nend;\r\n\r\nprocedure TJclBinaryTree.AssignPropertiesTo(Dest: TJclAbstractContainerBase);\r\nbegin\r\n inherited AssignPropertiesto(Dest);\r\n if Dest is TJclBinaryTree then\r\n TJclBinaryTree(Dest).FTraverseOrder := FTraverseOrder;\r\nend;\r\n\r\nprocedure TJclBinaryTree.AutoPack;\r\nbegin\r\n case FAutoPackStrategy of\r\n //apsDisabled: ;\r\n apsAgressive:\r\n if (FMaxDepth > 1) and (((1 shl (FMaxDepth - 1)) - 1) > FSize) then\r\n Pack;\r\n // apsIncremental: ;\r\n apsProportional:\r\n if (FMaxDepth > FAutoPackParameter) and (((1 shl (FMaxDepth - FAutoPackParameter)) - 1) > FSize) then\r\n Pack;\r\n end;\r\nend;\r\n\r\nfunction TJclBinaryTree.BuildTree(const LeafArray: array of TJclBinaryNode; Left, Right: Integer; Parent: TJclBinaryNode;\r\n Offset: Integer): TJclBinaryNode;\r\nvar\r\n Middle: Integer;\r\nbegin\r\n Middle := (Left + Right + Offset) shr 1;\r\n Result := LeafArray[Middle];\r\n Result.Parent := Parent;\r\n if Middle > Left then\r\n Result.Left := BuildTree(LeafArray, Left, Middle - 1, Result, 0)\r\n else\r\n Result.Left := nil;\r\n if Middle < Right then\r\n Result.Right := BuildTree(LeafArray, Middle + 1, Right, Result, 1)\r\n else\r\n Result.Right := nil;\r\nend;\r\n\r\nprocedure TJclBinaryTree.Clear;\r\nvar\r\n Current, Parent: TJclBinaryNode;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n // postorder\r\n Current := FRoot;\r\n if Current = nil then\r\n Exit;\r\n // find first in post-order\r\n while (Current.Left <> nil) or (Current.Right <> nil) do\r\n begin\r\n if Current.Left <> nil then\r\n Current := Current.Left\r\n else\r\n Current := Current.Right;\r\n end;\r\n // for all items in the tree in post-order\r\n repeat\r\n Parent := Current.Parent;\r\n // remove reference\r\n if Parent <> nil then\r\n begin\r\n if Parent.Left = Current then\r\n Parent.Left := nil\r\n else\r\n if Parent.Right = Current then\r\n Parent.Right := nil;\r\n end;\r\n\r\n // free item\r\n FreeItem(Current.Value);\r\n Current.Free;\r\n\r\n // find next item\r\n Current := Parent;\r\n if (Current <> nil) and (Current.Right <> nil) then\r\n begin\r\n Current := Current.Right;\r\n while (Current.Left <> nil) or (Current.Right <> nil) do\r\n begin\r\n if Current.Left <> nil then\r\n Current := Current.Left\r\n else\r\n Current := Current.Right;\r\n end;\r\n end;\r\n until Current = nil;\r\n FRoot := nil;\r\n FSize := 0;\r\n FMaxDepth := 0;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclBinaryTree.CloneNode(Node, Parent: TJclBinaryNode): TJclBinaryNode;\r\nbegin\r\n Result := TJclBinaryNode.Create;\r\n Result.Value := Node.Value;\r\n Result.Parent := Parent;\r\n if Node.Left <> nil then\r\n Result.Left := CloneNode(Node.Left, Result); // recursive call\r\n if Node.Right <> nil then\r\n Result.Right := CloneNode(Node.Right, Result); // recursive call\r\nend;\r\n\r\nfunction TJclBinaryTree.CollectionEquals(const ACollection: IJclCollection): Boolean;\r\nvar\r\n It, ItSelf: IJclIterator;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n if FSize <> ACollection.Size then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n ItSelf := First;\r\n while ItSelf.HasNext do\r\n if not ItemsEqual(ItSelf.Next, It.Next) then\r\n begin\r\n Result := False;\r\n Break;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclBinaryTree.Contains(const AItem: T): Boolean;\r\nvar\r\n Comp: Integer;\r\n Current: TJclBinaryNode;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n Current := FRoot;\r\n while Current <> nil do\r\n begin\r\n Comp := ItemsCompare(Current.Value, AItem);\r\n if Comp = 0 then\r\n begin\r\n Result := True;\r\n Break;\r\n end\r\n else\r\n if Comp > 0 then\r\n Current := Current.Left\r\n else\r\n Current := Current.Right;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclBinaryTree.ContainsAll(const ACollection: IJclCollection): Boolean;\r\nvar\r\n It: IJclIterator;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := True;\r\n if ACollection = nil then\r\n Exit;\r\n It := ACollection.First;\r\n while Result and It.HasNext do\r\n Result := Contains(It.Next);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclBinaryTree.Extract(const AItem: T): Boolean;\r\nvar\r\n Current, Successor: TJclBinaryNode;\r\n Comp: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n // locate AItem in the tree\r\n Current := FRoot;\r\n repeat\r\n while Current <> nil do\r\n begin\r\n Comp := ItemsCompare(AItem, Current.Value);\r\n if Comp = 0 then\r\n Break\r\n else\r\n if Comp < 0 then\r\n Current := Current.Left\r\n else\r\n Current := Current.Right;\r\n end;\r\n if Current = nil then\r\n Break;\r\n Result := True;\r\n // Remove Current from tree\r\n if (Current.Left = nil) and (Current.Right <> nil) then\r\n begin\r\n // remove references to Current\r\n Current.Right.Parent := Current.Parent;\r\n if Current.Parent <> nil then\r\n begin\r\n if Current.Parent.Left = Current then\r\n Current.Parent.Left := Current.Right\r\n else\r\n Current.Parent.Right := Current.Right;\r\n end\r\n else\r\n // fix root\r\n FRoot := Current.Right;\r\n Successor := Current.Parent;\r\n if Successor = nil then\r\n Successor := FRoot;\r\n end\r\n else\r\n if (Current.Left <> nil) and (Current.Right = nil) then\r\n begin\r\n // remove references to Current\r\n Current.Left.Parent := Current.Parent;\r\n if Current.Parent <> nil then\r\n begin\r\n if Current.Parent.Left = Current then\r\n Current.Parent.Left := Current.Left\r\n else\r\n Current.Parent.Right := Current.Left;\r\n end\r\n else\r\n // fix root\r\n FRoot := Current.Left;\r\n Successor := Current.Parent;\r\n if Successor = nil then\r\n Successor := FRoot;\r\n end\r\n else\r\n if (Current.Left <> nil) and (Current.Right <> nil) then\r\n begin\r\n // find the successor in tree\r\n Successor := Current.Right;\r\n while Successor.Left <> nil do\r\n Successor := Successor.Left;\r\n\r\n if Successor <> Current.Right then\r\n begin\r\n // remove references to successor\r\n Successor.Parent.Left := Successor.Right;\r\n if Successor.Right <> nil then\r\n Successor.Right.Parent := Successor.Parent;\r\n Successor.Right := Current.Right;\r\n if Successor.Right <> nil then\r\n Successor.Right.Parent := Successor;\r\n end;\r\n\r\n // insert successor in new position\r\n Successor.Left := Current.Left;\r\n if Current.Left <> nil then\r\n Current.Left.Parent := Successor;\r\n Successor.Parent := Current.Parent;\r\n if Current.Parent <> nil then\r\n begin\r\n if Current.Parent.Left = Current then\r\n Current.Parent.Left := Successor\r\n else\r\n Current.Parent.Right := Successor;\r\n end\r\n else\r\n // fix root\r\n FRoot := Successor;\r\n Successor := Current.Parent;\r\n if Successor <> nil then\r\n Successor := FRoot;\r\n end\r\n else\r\n begin\r\n // (Current.Left = nil) and (Current.Right = nil)\r\n Successor := Current.Parent;\r\n if Successor <> nil then\r\n begin\r\n // remove references from parent\r\n if Successor.Left = Current then\r\n Successor.Left := nil\r\n else\r\n Successor.Right := nil;\r\n end\r\n else\r\n FRoot := nil;\r\n end;\r\n Current.Value := Default(T);\r\n Current.Free;\r\n Dec(FSize);\r\n Current := Successor;\r\n until FRemoveSingleElement or (Current = nil);\r\n AutoPack;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclBinaryTree.ExtractAll(const ACollection: IJclCollection): Boolean;\r\nvar\r\n It: IJclIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n Result := Extract(It.Next) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclBinaryTree.First: IJclIterator;\r\nvar\r\n Start: TJclBinaryNode;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Start := FRoot;\r\n case GetTraverseOrder of\r\n toPreOrder:\r\n Result := TPreOrderBinaryTreeIterator.Create(Self, Start, False, isFirst);\r\n toOrder:\r\n begin\r\n if Start <> nil then\r\n while Start.Left <> nil do\r\n Start := Start.Left;\r\n Result := TInOrderBinaryTreeIterator.Create(Self, Start, False, isFirst);\r\n end;\r\n toPostOrder:\r\n begin\r\n if Start <> nil then\r\n while (Start.Left <> nil) or (Start.Right <> nil) do\r\n begin\r\n if Start.Left <> nil then\r\n Start := Start.Left\r\n else\r\n Start := Start.Right;\r\n end;\r\n Result := TPostOrderBinaryTreeIterator.Create(Self, Start, False, isFirst);\r\n end;\r\n else\r\n Result := nil;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\n{$IFDEF SUPPORTS_FOR_IN}\r\nfunction TJclBinaryTree.GetEnumerator: IJclIterator;\r\nbegin\r\n Result := First;\r\nend;\r\n{$ENDIF SUPPORTS_FOR_IN}\r\n\r\nfunction TJclBinaryTree.GetRoot: IJclTreeIterator;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n case GetTraverseOrder of\r\n toPreOrder:\r\n Result := TPreOrderBinaryTreeIterator.Create(Self, FRoot, False, isRoot);\r\n toOrder:\r\n Result := TInOrderBinaryTreeIterator.Create(Self, FRoot, False, isRoot);\r\n toPostOrder:\r\n Result := TPostOrderBinaryTreeIterator.Create(Self, FRoot, False, isRoot);\r\n else\r\n Result := nil;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclBinaryTree.GetTraverseOrder: TJclTraverseOrder;\r\nbegin\r\n Result := FTraverseOrder;\r\nend;\r\n\r\nfunction TJclBinaryTree.IsEmpty: Boolean;\r\nbegin\r\n Result := FSize = 0;\r\nend;\r\n\r\nfunction TJclBinaryTree.Last: IJclIterator;\r\nvar\r\n Start: TJclBinaryNode;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Start := FRoot;\r\n case FTraverseOrder of\r\n toPreOrder:\r\n begin\r\n if Start <> nil then\r\n while (Start.Left <> nil) or (Start.Right <> nil) do\r\n begin\r\n if Start.Right <> nil then\r\n Start := Start.Right\r\n else\r\n Start := Start.Left;\r\n end;\r\n Result := TPreOrderBinaryTreeIterator.Create(Self, Start, False, isLast);\r\n end;\r\n toOrder:\r\n begin\r\n if Start <> nil then\r\n while Start.Right <> nil do\r\n Start := Start.Right;\r\n Result := TInOrderBinaryTreeIterator.Create(Self, Start, False, isLast);\r\n end;\r\n toPostOrder:\r\n Result := TPostOrderBinaryTreeIterator.Create(Self, Start, False, isLast);\r\n else\r\n Result := nil;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclBinaryTree.Pack;\r\nvar\r\n LeafArray: array of TJclBinaryNode;\r\n ANode, BNode: TJclBinaryNode;\r\n Index: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n SetLength(Leafarray, FSize);\r\n try\r\n // in order enumeration of nodes\r\n ANode := FRoot;\r\n if ANode <> nil then\r\n begin\r\n // find first node\r\n while ANode.Left <> nil do\r\n ANode := ANode.Left;\r\n\r\n Index := 0;\r\n while ANode <> nil do\r\n begin\r\n LeafArray[Index] := ANode;\r\n Inc(Index);\r\n if ANode.Right <> nil then\r\n begin\r\n ANode := ANode.Right;\r\n while (ANode.Left <> nil) do\r\n ANode := ANode.Left;\r\n end\r\n else\r\n begin\r\n BNode := ANode;\r\n ANode := ANode.Parent;\r\n while (ANode <> nil) and (ANode.Right = BNode) do\r\n begin\r\n BNode := ANode;\r\n ANode := ANode.Parent;\r\n end;\r\n end;\r\n end;\r\n\r\n Index := FSize shr 1;\r\n FRoot := LeafArray[Index];\r\n FRoot.Parent := nil;\r\n if Index > 0 then\r\n FRoot.Left := BuildTree(LeafArray, 0, Index - 1, FRoot, 0)\r\n else\r\n FRoot.Left := nil;\r\n if Index < (FSize - 1) then\r\n FRoot.Right := BuildTree(LeafArray, Index + 1, FSize - 1, FRoot, 1)\r\n else\r\n FRoot.Right := nil;\r\n end;\r\n finally\r\n SetLength(LeafArray, 0);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclBinaryTree.Remove(const AItem: T): Boolean;\r\nvar\r\n Extracted: T;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := Extract(AItem);\r\n if Result then\r\n begin\r\n Extracted := AItem;\r\n FreeItem(Extracted);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclBinaryTree.RemoveAll(const ACollection: IJclCollection): Boolean;\r\nvar\r\n It: IJclIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n Result := Remove(It.Next) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclBinaryTree.RetainAll(const ACollection: IJclCollection): Boolean;\r\nvar\r\n It: IJclIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := First;\r\n while It.HasNext do\r\n if not ACollection.Contains(It.Next) then\r\n It.Remove;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclBinaryTree.SetCapacity(Value: Integer);\r\nbegin\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nprocedure TJclBinaryTree.SetTraverseOrder(Value: TJclTraverseOrder);\r\nbegin\r\n FTraverseOrder := Value;\r\nend;\r\n\r\nfunction TJclBinaryTree.Size: Integer;\r\nbegin\r\n Result := FSize;\r\nend;\r\n\r\n//=== { TJclBinaryTreeIterator } ===========================================================\r\n\r\nconstructor TJclBinaryTreeIterator.Create(const AOwnTree: IJclCollection; ACursor: TJclBinaryNode; AValid: Boolean; AStart: TItrStart);\r\nbegin\r\n inherited Create(AValid);\r\n FCursor := ACursor;\r\n FStart := AStart;\r\n FOwnTree := AOwnTree;\r\n FEqualityComparer := AOwnTree as IJclEqualityComparer;\r\nend;\r\n\r\nfunction TJclBinaryTreeIterator.Add(const AItem: T): Boolean;\r\nbegin\r\n Result := FOwnTree.Add(AItem);\r\nend;\r\n\r\nfunction TJclBinaryTreeIterator.AddChild(const AItem: T): Boolean;\r\nbegin\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nprocedure TJclBinaryTreeIterator.AssignPropertiesTo(Dest: TJclAbstractIterator);\r\nvar\r\n ADest: TJclBinaryTreeIterator;\r\nbegin\r\n inherited AssignPropertiesTo(Dest);\r\n if Dest is TJclBinaryTreeIterator then\r\n begin\r\n ADest := TJclBinaryTreeIterator(Dest);\r\n ADest.FCursor := FCursor;\r\n ADest.FOwnTree := FOwnTree;\r\n ADest.FEqualityComparer := FEqualityComparer;\r\n ADest.FStart := FStart;\r\n end;\r\nend;\r\n\r\nfunction TJclBinaryTreeIterator.ChildrenCount: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := 0;\r\n if FCursor <> nil then\r\n begin\r\n if FCursor.Left <> nil then\r\n Inc(Result);\r\n if FCursor.Right <> nil then\r\n Inc(Result);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclBinaryTreeIterator.DeleteChild(Index: Integer);\r\nbegin\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nprocedure TJclBinaryTreeIterator.DeleteChildren;\r\nbegin\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nprocedure TJclBinaryTreeIterator.Extract;\r\nvar\r\n OldCursor: TJclBinaryNode;\r\nbegin\r\n if FOwnTree.ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n CheckValid;\r\n Valid := False;\r\n OldCursor := FCursor;\r\n if OldCursor <> nil then\r\n begin\r\n repeat\r\n FCursor := GetNextCursor;\r\n until (FCursor = nil) or FOwnTree.RemoveSingleElement\r\n or (not FEqualityComparer.ItemsEqual(OldCursor.Value, FCursor.Value));\r\n FOwnTree.Extract(OldCursor.Value);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.WriteUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclBinaryTreeIterator.ExtractChild(Index: Integer);\r\nbegin\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nprocedure TJclBinaryTreeIterator.ExtractChildren;\r\nbegin\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nfunction TJclBinaryTreeIterator.GetChild(Index: Integer): T;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := Default(T);\r\n if (FCursor <> nil) and (Index = 0) and (FCursor.Left <> nil) then\r\n FCursor := FCursor.Left\r\n else\r\n if (FCursor <> nil) and (Index = 0) then\r\n FCursor := FCursor.Right\r\n else\r\n if (FCursor <> nil) and (Index = 1) then\r\n FCursor := FCursor.Right\r\n else\r\n FCursor := nil;\r\n if FCursor <> nil then\r\n Result := FCursor.Value\r\n else\r\n if not FOwnTree.ReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclBinaryTreeIterator.GetItem: T;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n CheckValid;\r\n Result := Default(T);\r\n if FCursor <> nil then\r\n Result := FCursor.Value\r\n else\r\n if not FOwnTree.ReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclBinaryTreeIterator.HasChild(Index: Integer): Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if (FCursor <> nil) and (Index = 0) then\r\n Result := (FCursor.Left <> nil) or (FCursor.Right <> nil)\r\n else\r\n if (FCursor <> nil) and (Index = 1) then\r\n Result := (FCursor.Left <> nil) and (FCursor.Right <> nil)\r\n else\r\n Result := False;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclBinaryTreeIterator.HasLeft: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := (FCursor <> nil) and (FCursor.Left <> nil);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclBinaryTreeIterator.HasNext: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Valid then\r\n Result := GetNextCursor <> nil\r\n else\r\n Result := FCursor <> nil;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclBinaryTreeIterator.HasParent: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := (FCursor <> nil) and (FCursor.Parent <> nil);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclBinaryTreeIterator.HasPrevious: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Valid then\r\n Result := GetPreviousCursor <> nil\r\n else\r\n Result := FCursor <> nil;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclBinaryTreeIterator.HasRight: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := (FCursor <> nil) and (FCursor.Right <> nil);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclBinaryTreeIterator.IndexOfChild(const AItem: T): Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := -1;\r\n if FCursor <> nil then\r\n begin\r\n if FCursor.Left <> nil then\r\n begin\r\n if FEqualityComparer.ItemsEqual(FCursor.Left.Value, AItem) then\r\n Result := 0\r\n else\r\n if (FCursor.Right <> nil) and FEqualityComparer.ItemsEqual(FCursor.Right.Value, AItem) then\r\n Result := 1;\r\n end\r\n else\r\n if (FCursor.Right <> nil) and FEqualityComparer.ItemsEqual(FCursor.Right.Value, AItem) then\r\n Result := 0;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclBinaryTreeIterator.Insert(const AItem: T): Boolean;\r\nbegin\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nfunction TJclBinaryTreeIterator.InsertChild(Index: Integer; const AItem: T): Boolean;\r\nbegin\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nfunction TJclBinaryTreeIterator.IteratorEquals(const AIterator: IJclIterator): Boolean;\r\nvar\r\n Obj: TObject;\r\n ItrObj: TJclBinaryTreeIterator;\r\nbegin\r\n Result := False;\r\n if AIterator = nil then\r\n Exit;\r\n Obj := AIterator.GetIteratorReference;\r\n if Obj is TJclBinaryTreeIterator then\r\n begin\r\n ItrObj := TJclBinaryTreeIterator(Obj);\r\n Result := (FOwnTree = ItrObj.FOwnTree) and (FCursor = ItrObj.FCursor) and (Valid = ItrObj.Valid);\r\n end;\r\nend;\r\n\r\nfunction TJclBinaryTreeIterator.Left: T;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := Default(T);\r\n if FCursor <> nil then\r\n FCursor := FCursor.Left;\r\n if FCursor <> nil then\r\n Result := FCursor.Value\r\n else\r\n if not FOwnTree.ReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\n{$IFDEF SUPPORTS_FOR_IN}\r\nfunction TJclBinaryTreeIterator.MoveNext: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Valid then\r\n FCursor := GetNextCursor\r\n else\r\n Valid := True;\r\n Result := FCursor <> nil;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n{$ENDIF SUPPORTS_FOR_IN}\r\n\r\nfunction TJclBinaryTreeIterator.Next: T;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Valid then\r\n FCursor := GetNextCursor\r\n else\r\n Valid := True;\r\n Result := Default(T);\r\n if FCursor <> nil then\r\n Result := FCursor.Value\r\n else\r\n if not FOwnTree.ReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclBinaryTreeIterator.NextIndex: Integer;\r\nbegin\r\n // No index\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nfunction TJclBinaryTreeIterator.Parent: T;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := Default(T);\r\n if FCursor <> nil then\r\n FCursor := FCursor.Parent;\r\n if FCursor <> nil then\r\n Result := FCursor.Value\r\n else\r\n if not FOwnTree.ReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclBinaryTreeIterator.Previous: T;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Valid then\r\n FCursor := GetPreviousCursor\r\n else\r\n Valid := True;\r\n Result := Default(T);\r\n if FCursor <> nil then\r\n Result := FCursor.Value\r\n else\r\n if not FOwnTree.ReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclBinaryTreeIterator.PreviousIndex: Integer;\r\nbegin\r\n // No index\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nprocedure TJclBinaryTreeIterator.Remove;\r\nvar\r\n OldCursor: TJclBinaryNode;\r\nbegin\r\n if FOwnTree.ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n CheckValid;\r\n Valid := False;\r\n OldCursor := FCursor;\r\n if OldCursor <> nil then\r\n begin\r\n repeat\r\n FCursor := GetNextCursor;\r\n until (FCursor = nil) or FOwnTree.RemoveSingleElement\r\n or (not FEqualityComparer.ItemsEqual(OldCursor.Value, FCursor.Value));\r\n FOwnTree.Remove(OldCursor.Value);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.WriteUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclBinaryTreeIterator.Reset;\r\nvar\r\n NewCursor: TJclBinaryNode;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Valid := False;\r\n case FStart of\r\n isFirst:\r\n begin\r\n NewCursor := FCursor;\r\n while NewCursor <> nil do\r\n begin\r\n NewCursor := GetPreviousCursor;\r\n if NewCursor <> nil then\r\n FCursor := NewCursor;\r\n end;\r\n end;\r\n isLast:\r\n begin\r\n NewCursor := FCursor;\r\n while NewCursor <> nil do\r\n begin\r\n NewCursor := GetNextCursor;\r\n if NewCursor <> nil then\r\n FCursor := NewCursor;\r\n end;\r\n end;\r\n isRoot:\r\n begin\r\n while (FCursor <> nil) and (FCursor.Parent <> nil) do\r\n FCursor := FCursor.Parent;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclBinaryTreeIterator.Right: T;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := Default(T);\r\n if FCursor <> nil then\r\n FCursor := FCursor.Right;\r\n if FCursor <> nil then\r\n Result := FCursor.Value\r\n else\r\n if not FOwnTree.ReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclBinaryTreeIterator.SetChild(Index: Integer; const AItem: T);\r\nbegin\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nprocedure TJclBinaryTreeIterator.SetItem(const AItem: T);\r\nbegin\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\n//=== { TJclPreOrderBinaryTreeIterator } ===================================================\r\n\r\nfunction TJclPreOrderBinaryTreeIterator.CreateEmptyIterator: TJclAbstractIterator;\r\nbegin\r\n Result := TJclPreOrderBinaryTreeIterator.Create(FOwnTree, FCursor, Valid, FStart);\r\nend;\r\n\r\nfunction TJclPreOrderBinaryTreeIterator.GetNextCursor: TJclBinaryNode;\r\nvar\r\n LastRet: TJclBinaryNode;\r\nbegin\r\n Result := FCursor;\r\n if Result = nil then\r\n Exit;\r\n LastRet := Result;\r\n if Result.Left <> nil then\r\n Result := Result.Left\r\n else\r\n if Result.Right <> nil then\r\n Result := Result.Right\r\n else\r\n begin\r\n Result := Result.Parent;\r\n while (Result <> nil) and ((Result.Right = nil) or (Result.Right = LastRet)) do\r\n begin\r\n LastRet := Result;\r\n Result := Result.Parent;\r\n end;\r\n if Result <> nil then // not root\r\n Result := Result.Right;\r\n end;\r\nend;\r\n\r\nfunction TJclPreOrderBinaryTreeIterator.GetPreviousCursor: TJclBinaryNode;\r\nvar\r\n LastRet: TJclBinaryNode;\r\nbegin\r\n Result := FCursor;\r\n if Result = nil then\r\n Exit;\r\n LastRet := Result;\r\n Result := Result.Parent;\r\n if (Result <> nil) and (Result.Left <> LastRet) and (Result.Left <> nil) then\r\n // come from Right\r\n begin\r\n Result := Result.Left;\r\n while (Result.Left <> nil) or (Result.Right <> nil) do // both childs\r\n begin\r\n if Result.Right <> nil then // right child first\r\n Result := Result.Right\r\n else\r\n Result := Result.Left;\r\n end;\r\n end;\r\nend;\r\n\r\n//=== { TJclInOrderBinaryTreeIterator } ====================================================\r\n\r\nfunction TJclInOrderBinaryTreeIterator.CreateEmptyIterator: TJclAbstractIterator;\r\nbegin\r\n Result := TJclInOrderBinaryTreeIterator.Create(FOwnTree, FCursor, Valid, FStart);\r\nend;\r\n\r\nfunction TJclInOrderBinaryTreeIterator.GetNextCursor: TJclBinaryNode;\r\nvar\r\n LastRet: TJclBinaryNode;\r\nbegin\r\n Result := FCursor;\r\n if Result = nil then\r\n Exit;\r\n if Result.Right <> nil then\r\n begin\r\n Result := Result.Right;\r\n while (Result.Left <> nil) do\r\n Result := Result.Left;\r\n end\r\n else\r\n begin\r\n LastRet := Result;\r\n Result := Result.Parent;\r\n while (Result <> nil) and (Result.Right = LastRet) do\r\n begin\r\n LastRet := Result;\r\n Result := Result.Parent;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJclInOrderBinaryTreeIterator.GetPreviousCursor: TJclBinaryNode;\r\nvar\r\n LastRet: TJclBinaryNode;\r\nbegin\r\n Result := FCursor;\r\n if Result = nil then\r\n Exit;\r\n if Result.Left <> nil then\r\n begin\r\n Result := Result.Left;\r\n while Result.Right <> nil do\r\n Result := Result.Right;\r\n end\r\n else\r\n begin\r\n LastRet := Result;\r\n Result := Result.Parent;\r\n while (Result <> nil) and (Result.Right <> LastRet) do // Come from Left\r\n begin\r\n LastRet := Result;\r\n Result := Result.Parent;\r\n end;\r\n end;\r\nend;\r\n\r\n//=== { TJclPostOrderBinaryTreeIterator } ==================================================\r\n\r\nfunction TJclPostOrderBinaryTreeIterator.CreateEmptyIterator: TJclAbstractIterator;\r\nbegin\r\n Result := TJclPostOrderBinaryTreeIterator.Create(FOwnTree, FCursor, Valid, FStart);\r\nend;\r\n\r\nfunction TJclPostOrderBinaryTreeIterator.GetNextCursor: TJclBinaryNode;\r\nvar\r\n LastRet: TJclBinaryNode;\r\nbegin\r\n Result := FCursor;\r\n if Result = nil then\r\n Exit;\r\n LastRet := Result;\r\n Result := Result.Parent;\r\n if (Result <> nil) and (Result.Right <> nil) and (Result.Right <> LastRet) then\r\n begin\r\n Result := Result.Right;\r\n while (Result.Left <> nil) or (Result.Right <> nil) do\r\n begin\r\n if Result.Left <> nil then\r\n Result := Result.Left\r\n else\r\n Result := Result.Right;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJclPostOrderBinaryTreeIterator.GetPreviousCursor: TJclBinaryNode;\r\nvar\r\n LastRet: TJclBinaryNode;\r\nbegin\r\n Result := FCursor;\r\n if Result = nil then\r\n Exit;\r\n if Result.Right <> nil then\r\n Result := Result.Right\r\n else\r\n if Result.Left <> nil then\r\n Result := Result.Left\r\n else\r\n begin\r\n LastRet := Result;\r\n Result := Result.Parent;\r\n while (Result <> nil) and ((Result.Left = nil) or (Result.Left = LastRet)) do\r\n begin\r\n LastRet := Result;\r\n Result := Result.Parent;\r\n end;\r\n if Result <> nil then // not root\r\n Result := Result.Left;\r\n end;\r\nend;\r\n\r\n//=== { TJclBinaryTreeE } =================================================\r\n\r\nconstructor TJclBinaryTreeE.Create(const AComparer: IJclComparer; AOwnsItems: Boolean);\r\nbegin\r\n inherited Create(AOwnsItems);\r\n FComparer := AComparer;\r\nend;\r\n\r\nprocedure TJclBinaryTreeE.AssignPropertiesTo(Dest: TJclAbstractContainerBase);\r\nbegin\r\n inherited AssignPropertiesTo(Dest);\r\n if Dest is TJclBinaryTreeE then\r\n TJclBinaryTreeE(Dest).FComparer := FComparer;\r\nend;\r\n\r\nfunction TJclBinaryTreeE.CreateEmptyContainer: TJclAbstractContainerBase;\r\nbegin\r\n Result := TJclBinaryTreeE.Create(Comparer, False);\r\n AssignPropertiesTo(Result);\r\nend;\r\n\r\nfunction TJclBinaryTreeE.ItemsCompare(const A, B: T): Integer;\r\nbegin\r\n if Comparer <> nil then\r\n Result := Comparer.Compare(A, B)\r\n else\r\n Result := inherited ItemsCompare(A, B);\r\nend;\r\n\r\nfunction TJclBinaryTreeE.ItemsEqual(const A, B: T): Boolean;\r\nbegin\r\n if Comparer <> nil then\r\n Result := Comparer.Compare(A, B) = 0\r\n else\r\n Result := inherited ItemsEqual(A, B);\r\nend;\r\n\r\n//=== { TJclBinaryTreeF } =================================================\r\n\r\nconstructor TJclBinaryTreeF.Create(ACompare: TCompare; AOwnsItems: Boolean);\r\nbegin\r\n inherited Create(AOwnsItems);\r\n SetCompare(ACompare);\r\nend;\r\n\r\nfunction TJclBinaryTreeF.CreateEmptyContainer: TJclAbstractContainerBase;\r\nbegin\r\n Result := TJclBinaryTreeF.Create(Compare, False);\r\n AssignPropertiesTo(Result);\r\nend;\r\n\r\n//=== { TJclBinaryTreeI } =================================================\r\n\r\nfunction TJclBinaryTreeI.CreateEmptyContainer: TJclAbstractContainerBase;\r\nbegin\r\n Result := TJclBinaryTreeI.Create(False);\r\n AssignPropertiesTo(Result);\r\nend;\r\n\r\nfunction TJclBinaryTreeI.ItemsCompare(const A, B: T): Integer;\r\nbegin\r\n if Assigned(FCompare) then\r\n Result := FCompare(A, B)\r\n else\r\n Result := A.CompareTo(B);\r\nend;\r\n\r\nfunction TJclBinaryTreeI.ItemsEqual(const A, B: T): Boolean;\r\nbegin\r\n if Assigned(FEqualityCompare) then\r\n Result := FEqualityCompare(A, B)\r\n else\r\n if Assigned(FCompare) then\r\n Result := FCompare(A, B) = 0\r\n else\r\n Result := A.CompareTo(B) = 0;\r\nend;\r\n\r\n//DOM-IGNORE-END\r\n{$ENDIF SUPPORTS_GENERICS}\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n\r\n" }, { "path": "External/Jedi/Jcl/source/common/JclCharsets.pas", "content": "{**************************************************************************************************}\r\n{ }\r\n{ Project JEDI Code Library (JCL) }\r\n{ }\r\n{ The contents of this file are subject to the Mozilla Public License Version 1.1 (the \"License\"); }\r\n{ you may not use this file except in compliance with the License. You may obtain a copy of the }\r\n{ License at http://www.mozilla.org/MPL/ }\r\n{ }\r\n{ Software distributed under the License is distributed on an \"AS IS\" basis, WITHOUT WARRANTY OF }\r\n{ ANY KIND, either express or implied. See the License for the specific language governing rights }\r\n{ and limitations under the License. }\r\n{ }\r\n{ The Original Code is JclCharsets.pas. }\r\n{ }\r\n{ The Initial Developer of the Original Code is Florent Ouchet. }\r\n{ Portions created by Florent Ouchet are Copyright Florent Ouchet. All rights reserved. }\r\n{ }\r\n{ Contributors: }\r\n{ }\r\n{**************************************************************************************************}\r\n{ }\r\n{ Windows codepage bindings are taken from IE5 ones: }\r\n{ http://msdn.microsoft.com/en-us/library/aa752010(VS.85).aspx }\r\n{ }\r\n{**************************************************************************************************}\r\n{ }\r\n{ Last modified: $Date:: 2012-08-14 11:25:52 +0200 (mar. 14 août 2012) $ }\r\n{ Revision: $Rev:: 3819 $ }\r\n{ Author: $Author:: outchy $ }\r\n{ }\r\n{**************************************************************************************************}\r\n\r\nunit JclCharsets;\r\n\r\n{$I jcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n JclBase;\r\n\r\ntype\r\n EJclCharsetError = class(EJclError);\r\n\r\nconst\r\n CP_UTF16LE = 1200;\r\n\r\ntype\r\n TJclCharsetInfo = record\r\n Name: string;\r\n CodePage: Word;\r\n FamilyCodePage: Word;\r\n end;\r\n\r\nconst JclCharsetInfos: array [0..285] of TJclCharsetInfo =\r\n(* Arabic (ASMO 708) ASMO-708 708 1256 *)\r\n ((Name: 'ASMO-708'; CodePage: 708; FamilyCodePage: 1256),\r\n(* Arabic (DOS) DOS-720 720 1256 *)\r\n (Name: 'DOS-720'; CodePage: 720; FamilyCodePage: 1256),\r\n(* Arabic (ISO) iso-8859-6 arabic, csISOLatinArabic, ECMA-114, ISO_8859-6, ISO_8859-6:1987, iso-ir-127 28596 1256 *)\r\n (Name: 'iso-8859-6'; CodePage: 28596; FamilyCodePage: 1256),\r\n (Name: 'arabic'; CodePage: 28596; FamilyCodePage: 1256),\r\n (Name: 'csISOLatinArabic'; CodePage: 28596; FamilyCodePage: 1256),\r\n (Name: 'ECMA-114'; CodePage: 28596; FamilyCodePage: 1256),\r\n (Name: 'ISO_8859-6'; CodePage: 28596; FamilyCodePage: 1256),\r\n (Name: 'ISO_8859-6:1987'; CodePage: 28596; FamilyCodePage: 1256),\r\n (Name: 'iso-ir-127'; CodePage: 28596; FamilyCodePage: 1256),\r\n(* Arabic (Mac) x-mac-arabic 10004 1256 *)\r\n (Name: 'x-mac-arabic'; CodePage: 10004; FamilyCodePage: 1256),\r\n(* Arabic (Windows) windows-1256 cp1256 1256 1256 *)\r\n (Name: 'windows-1256'; CodePage: 1256; FamilyCodePage: 1256),\r\n (Name: 'cp1256'; CodePage: 1256; FamilyCodePage: 1256),\r\n(* Baltic (DOS) ibm775 CP500 775 1257 *)\r\n (Name: 'ibm775'; CodePage: 775; FamilyCodePage: 1257),\r\n (Name: 'CP500'; CodePage: 775; FamilyCodePage: 1257),\r\n(* Baltic (ISO) iso-8859-4 csISOLatin4, ISO_8859-4, ISO_8859-4:1988, iso-ir-110, l4, latin4 28594 1257 *)\r\n (Name: 'iso-8859-4'; CodePage: 28594; FamilyCodePage: 1257),\r\n (Name: 'csISOLatin4'; CodePage: 28594; FamilyCodePage: 1257),\r\n (Name: 'ISO_8859-4'; CodePage: 28594; FamilyCodePage: 1257),\r\n (Name: 'ISO_8859-4:1988'; CodePage: 28594; FamilyCodePage: 1257),\r\n (Name: 'iso-ir-110'; CodePage: 28594; FamilyCodePage: 1257),\r\n (Name: 'l4'; CodePage: 28594; FamilyCodePage: 1257),\r\n (Name: 'latin4'; CodePage: 28594; FamilyCodePage: 1257),\r\n(* Baltic (Windows) windows-1257 1257 1257 *)\r\n (Name: 'windows-1257'; CodePage: 1257; FamilyCodePage: 1257),\r\n(* Central European (DOS) ibm852 cp852 852 1250 *)\r\n (Name: 'ibm852'; CodePage: 852; FamilyCodePage: 1250),\r\n (Name: 'cp852'; CodePage: 852; FamilyCodePage: 1250),\r\n(* Central European (ISO) iso-8859-2 csISOLatin2, iso_8859-2, iso_8859-2:1987, iso8859-2, iso-ir-101, l2, latin2 28592 1250 *)\r\n (Name: 'iso-8859-2'; CodePage: 28592; FamilyCodePage: 1250),\r\n (Name: 'csISOLatin2'; CodePage: 28592; FamilyCodePage: 1250),\r\n (Name: 'iso_8859-2'; CodePage: 28592; FamilyCodePage: 1250),\r\n (Name: 'iso_8859-2:1987'; CodePage: 28592; FamilyCodePage: 1250),\r\n (Name: 'iso8859-2'; CodePage: 28592; FamilyCodePage: 1250),\r\n (Name: 'iso-ir-101'; CodePage: 28592; FamilyCodePage: 1250),\r\n (Name: 'l2'; CodePage: 28592; FamilyCodePage: 1250),\r\n (Name: 'latin2'; CodePage: 28592; FamilyCodePage: 1250),\r\n(* Central European (Mac) x-mac-ce 10029 1250 *)\r\n (Name: 'x-mac-ce'; CodePage: 10029; FamilyCodePage: 1250),\r\n(* Central European (Windows) windows-1250 x-cp1250 1250 1250 *)\r\n (Name: 'windows-1250'; CodePage: 1250; FamilyCodePage: 1250),\r\n (Name: 'x-cp1250'; CodePage: 1250; FamilyCodePage: 1250),\r\n(* Chinese Simplified (EUC) EUC-CN x-euc-cn 51936 936 *)\r\n (Name: 'EUC-CN'; CodePage: 51936; FamilyCodePage: 936),\r\n (Name: 'x-euc-cn'; CodePage: 51936; FamilyCodePage: 936),\r\n(* Chinese Simplified (GB2312) gb2312 chinese, CN-GB, csGB2312, csGB231280, csISO58GB231280, GB_2312-80, GB231280, GB2312-80, GBK, iso-ir-58 936 936 *)\r\n (Name: 'gb2312'; CodePage: 936; FamilyCodePage: 936),\r\n (Name: 'chinese'; CodePage: 936; FamilyCodePage: 936),\r\n (Name: 'CN-GB'; CodePage: 936; FamilyCodePage: 936),\r\n (Name: 'csGB2312'; CodePage: 936; FamilyCodePage: 936),\r\n (Name: 'csGB231280'; CodePage: 936; FamilyCodePage: 936),\r\n (Name: 'csISO58GB231280'; CodePage: 936; FamilyCodePage: 936),\r\n (Name: 'GB_2312-80'; CodePage: 936; FamilyCodePage: 936),\r\n (Name: 'GB231280'; CodePage: 936; FamilyCodePage: 936),\r\n (Name: 'GB2312-80'; CodePage: 936; FamilyCodePage: 936),\r\n (Name: 'GBK'; CodePage: 936; FamilyCodePage: 936),\r\n (Name: 'iso-ir-58'; CodePage: 936; FamilyCodePage: 936),\r\n(* Chinese Simplified (HZ) hz-gb-2312 52936 936 *)\r\n (Name: 'hz-gb-2312'; CodePage: 52936; FamilyCodePage: 936),\r\n(* Chinese Simplified (Mac) x-mac-chinesesimp 10008 936 *)\r\n (Name: 'x-mac-chinesesimp'; CodePage: 10008; FamilyCodePage: 936),\r\n(* Chinese Traditional (Big5) big5 cn-big5, csbig5, x-x-big5 950 950 *)\r\n (Name: 'big5'; CodePage: 950; FamilyCodePage: 950),\r\n (Name: 'cn-big5'; CodePage: 950; FamilyCodePage: 950),\r\n (Name: 'csbig5'; CodePage: 950; FamilyCodePage: 950),\r\n (Name: 'x-x-big5'; CodePage: 950; FamilyCodePage: 950),\r\n (Name: 'MS950'; CodePage: 950; FamilyCodePage: 950),\r\n(* Chinese Traditional (CNS) x-Chinese-CNS 20000 950 *)\r\n (Name: 'x-Chinese-CNS'; CodePage: 20000; FamilyCodePage: 950),\r\n(* Chinese Traditional (Eten) x-Chinese-Eten 20002 950 *)\r\n (Name: 'x-Chinese-Eten'; CodePage: 20002; FamilyCodePage: 950),\r\n(* Chinese Traditional (Mac) x-mac-chinesetrad 10002 950 *)\r\n (Name: 'x-mac-chinesetrad'; CodePage: 10002; FamilyCodePage: 950),\r\n(* Cyrillic (DOS) cp866 ibm866 866 1251 *)\r\n (Name: 'cp866'; CodePage: 866; FamilyCodePage: 1251),\r\n (Name: 'ibm866'; CodePage: 866; FamilyCodePage: 1251),\r\n(* Cyrillic (ISO) iso-8859-5 csISOLatin5, csISOLatinCyrillic, cyrillic, ISO_8859-5, ISO_8859-5:1988, iso-ir-144, l5 28595 1251 *)\r\n (Name: 'iso-8859-5'; CodePage: 28595; FamilyCodePage: 1251),\r\n (Name: 'csISOLatinCyrillic'; CodePage: 28595; FamilyCodePage: 1251),\r\n (Name: 'cyrillic'; CodePage: 28595; FamilyCodePage: 1251),\r\n (Name: 'ISO_8859-5'; CodePage: 28595; FamilyCodePage: 1251),\r\n (Name: 'ISO_8859-5:1988'; CodePage: 28595; FamilyCodePage: 1251),\r\n (Name: 'iso-ir-144'; CodePage: 28595; FamilyCodePage: 1251),\r\n(* Cyrillic (KOI8-R) koi8-r csKOI8R, koi, koi8, koi8r 20866 1251 *)\r\n (Name: 'koi8-r'; CodePage: 20866; FamilyCodePage: 1251),\r\n (Name: 'csKOI8R'; CodePage: 20866; FamilyCodePage: 1251),\r\n (Name: 'koi'; CodePage: 20866; FamilyCodePage: 1251),\r\n (Name: 'koi8'; CodePage: 20866; FamilyCodePage: 1251),\r\n (Name: 'koi8r'; CodePage: 20866; FamilyCodePage: 1251),\r\n(* Cyrillic (KOI8-U) koi8-u koi8-ru 21866 1251 *)\r\n (Name: 'koi8-u'; CodePage: 21866; FamilyCodePage: 1251),\r\n (Name: 'koi8-ru'; CodePage: 21866; FamilyCodePage: 1251),\r\n(* Cyrillic (Mac) x-mac-cyrillic 10007 1251 *)\r\n (Name: 'x-mac-cyrillic'; CodePage: 10007; FamilyCodePage: 1251),\r\n(* Cyrillic (Windows) windows-1251 x-cp1251 1251 1251 *)\r\n (Name: 'windows-1251'; CodePage: 1251; FamilyCodePage: 1251),\r\n (Name: 'x-cp1251'; CodePage: 1251; FamilyCodePage: 1251),\r\n(* Europa x-Europa 29001 1252 *)\r\n (Name: 'x-Europa'; CodePage: 29001; FamilyCodePage: 1252),\r\n(* German (IA5) x-IA5-German 20106 1252 *)\r\n (Name: 'x-IA5-German'; CodePage: 20106; FamilyCodePage: 1252),\r\n(* Greek (DOS) ibm737 737 1253 *)\r\n (Name: 'ibm737'; CodePage: 737; FamilyCodePage: 1253),\r\n(* Greek (ISO) iso-8859-7 csISOLatinGreek, ECMA-118, ELOT_928, greek, greek8, ISO_8859-7, ISO_8859-7:1987, iso-ir-126 28597 1253 *)\r\n (Name: 'iso-8859-7'; CodePage: 28597; FamilyCodePage: 1253),\r\n (Name: 'csISOLatinGreek'; CodePage: 28597; FamilyCodePage: 1253),\r\n (Name: 'ECMA-118'; CodePage: 28597; FamilyCodePage: 1253),\r\n (Name: 'ELOT_928'; CodePage: 28597; FamilyCodePage: 1253),\r\n (Name: 'greek'; CodePage: 28597; FamilyCodePage: 1253),\r\n (Name: 'greek8'; CodePage: 28597; FamilyCodePage: 1253),\r\n (Name: 'ISO_8859-7'; CodePage: 28597; FamilyCodePage: 1253),\r\n (Name: 'ISO_8859-7:1987'; CodePage: 28597; FamilyCodePage: 1253),\r\n (Name: 'iso-ir-126'; CodePage: 28597; FamilyCodePage: 1253),\r\n(* Greek (Mac) x-mac-greek 10006 1253 *)\r\n (Name: 'x-mac-greek'; CodePage: 10006; FamilyCodePage: 1253),\r\n(* Greek (Windows) windows-1253 1253 1253 *)\r\n (Name: 'windows-1253'; CodePage: 1253; FamilyCodePage: 1253),\r\n(* Greek, Modern (DOS) ibm869 869 1253 *)\r\n (Name: 'ibm869'; CodePage: 869; FamilyCodePage: 1253),\r\n(* Hebrew (DOS) DOS-862 862 1255 *)\r\n (Name: 'DOS-862'; CodePage: 862; FamilyCodePage: 1255),\r\n(* Hebrew (ISO-Logical) iso-8859-8-i logical 38598 1255 *)\r\n (Name: 'iso-8859-8-i'; CodePage: 38598; FamilyCodePage: 1255),\r\n (Name: 'logical'; CodePage: 38598; FamilyCodePage: 1255),\r\n(* Hebrew (ISO-Visual) iso-8859-8 csISOLatinHebrew, hebrew, ISO_8859-8, ISO_8859-8:1988, ISO-8859-8, iso-ir-138, visual 28598 1255 *)\r\n (Name: 'iso-8859-8'; CodePage: 28598; FamilyCodePage: 1255),\r\n (Name: 'csISOLatinHebrew'; CodePage: 28598; FamilyCodePage: 1255),\r\n (Name: 'hebrew'; CodePage: 28598; FamilyCodePage: 1255),\r\n (Name: 'ISO_8859-8'; CodePage: 28598; FamilyCodePage: 1255),\r\n (Name: 'ISO_8859-8:1988'; CodePage: 28598; FamilyCodePage: 1255),\r\n (Name: 'ISO-8859-8'; CodePage: 28598; FamilyCodePage: 1255),\r\n (Name: 'iso-ir-138'; CodePage: 28598; FamilyCodePage: 1255),\r\n (Name: 'visual'; CodePage: 28598; FamilyCodePage: 1255),\r\n(* Hebrew (Mac) x-mac-hebrew 10005 1255 *)\r\n (Name: 'x-mac-hebrew'; CodePage: 10005; FamilyCodePage: 1255),\r\n(* Hebrew (Windows) windows-1255 ISO_8859-8-I, ISO-8859-8, visual 1255 1255 *)\r\n (Name: 'windows-1255'; CodePage: 1255; FamilyCodePage: 1255),\r\n (Name: 'CP1255'; CodePage: 1255; FamilyCodePage: 1255),\r\n (Name: 'ISO_8859-8-I'; CodePage: 1255; FamilyCodePage: 1255),\r\n (Name: 'ISO-8859-8'; CodePage: 1255; FamilyCodePage: 1255),\r\n (Name: 'visual'; CodePage: 1255; FamilyCodePage: 1255),\r\n(* IBM EBCDIC (Arabic) x-EBCDIC-Arabic 20420 1256 *)\r\n (Name: 'x-EBCDIC-Arabic'; CodePage: 20420; FamilyCodePage: 1256),\r\n(* IBM EBCDIC (Cyrillic Russian) x-EBCDIC-CyrillicRussian 20880 1251 *)\r\n (Name: 'x-EBCDIC-CyrillicRussian'; CodePage: 20880; FamilyCodePage: 1251),\r\n(* IBM EBCDIC (Cyrillic Serbian-Bulgarian) x-EBCDIC-CyrillicSerbianBulgarian 21025 1251 *)\r\n (Name: 'x-EBCDIC-CyrillicSerbianBulgarian'; CodePage: 21025; FamilyCodePage: 1251),\r\n(* IBM EBCDIC (Denmark-Norway) x-EBCDIC-DenmarkNorway 20277 1252 *)\r\n (Name: 'x-EBCDIC-DenmarkNorway'; CodePage: 20277; FamilyCodePage: 1252),\r\n(* IBM EBCDIC (Denmark-Norway-Euro) x-ebcdic-denmarknorway-euro 1142 1252 *)\r\n (Name: 'x-ebcdic-denmarknorway-euro'; CodePage: 1142; FamilyCodePage: 1252),\r\n(* IBM EBCDIC (Finland-Sweden) x-EBCDIC-FinlandSweden 20278 1252 *)\r\n (Name: 'x-EBCDIC-FinlandSweden'; CodePage: 20278; FamilyCodePage: 1252),\r\n(* IBM EBCDIC (Finland-Sweden-Euro) x-ebcdic-finlandsweden-euro X-EBCDIC-France 1143 1252 *)\r\n (Name: 'x-ebcdic-finlandsweden-euro'; CodePage: 1143; FamilyCodePage: 1252),\r\n (Name: 'X-EBCDIC-France'; CodePage: 1143; FamilyCodePage: 1252),\r\n(* IBM EBCDIC (France-Euro) x-ebcdic-france-euro 1147 1252 *)\r\n (Name: 'x-ebcdic-france-euro'; CodePage: 1147; FamilyCodePage: 1252),\r\n(* IBM EBCDIC (Germany) x-EBCDIC-Germany 20273 1252 *)\r\n (Name: 'x-EBCDIC-Germany'; CodePage: 20273; FamilyCodePage: 1252),\r\n(* IBM EBCDIC (Germany-Euro) x-ebcdic-germany-euro 1141 1252 *)\r\n (Name: 'x-ebcdic-germany-euro'; CodePage: 1141; FamilyCodePage: 1252),\r\n(* IBM EBCDIC (Greek Modern) x-EBCDIC-GreekModern 875 1253 *)\r\n (Name: 'x-EBCDIC-GreekModern'; CodePage: 875; FamilyCodePage: 1253),\r\n(* IBM EBCDIC (Greek) x-EBCDIC-Greek 20423 1253 *)\r\n (Name: 'x-EBCDIC-Greek'; CodePage: 20423; FamilyCodePage: 1253),\r\n(* IBM EBCDIC (Hebrew) x-EBCDIC-Hebrew 20424 1255 *)\r\n (Name: 'x-EBCDIC-Hebrew'; CodePage: 20424; FamilyCodePage: 1255),\r\n(* IBM EBCDIC (Icelandic) x-EBCDIC-Icelandic 20871 1252 *)\r\n (Name: 'x-EBCDIC-Icelandic'; CodePage: 20871; FamilyCodePage: 1252),\r\n(* IBM EBCDIC (Icelandic-Euro) x-ebcdic-icelandic-euro 1149 1252 *)\r\n (Name: 'x-ebcdic-icelandic-euro'; CodePage: 1149; FamilyCodePage: 1252),\r\n(* IBM EBCDIC (International-Euro) x-ebcdic-international-euro 1148 1252 *)\r\n (Name: 'x-ebcdic-international-euro'; CodePage: 1148; FamilyCodePage: 1252),\r\n(* IBM EBCDIC (Italy) x-EBCDIC-Italy 20280 1252 *)\r\n (Name: 'x-EBCDIC-Italy'; CodePage: 20280; FamilyCodePage: 1252),\r\n(* IBM EBCDIC (Italy-Euro) x-ebcdic-italy-euro 1144 1252 *)\r\n (Name: 'x-ebcdic-italy-euro'; CodePage: 1144; FamilyCodePage: 1252),\r\n(* IBM EBCDIC (Japanese and Japanese Katakana) x-EBCDIC-JapaneseAndKana 50930 932 *)\r\n (Name: 'x-EBCDIC-JapaneseAndKana'; CodePage: 50930; FamilyCodePage: 932),\r\n(* IBM EBCDIC (Japanese and Japanese-Latin) x-EBCDIC-JapaneseAndJapaneseLatin 50939 932 *)\r\n (Name: 'x-EBCDIC-JapaneseAndJapaneseLatin'; CodePage: 50939; FamilyCodePage: 932),\r\n(* IBM EBCDIC (Japanese and US-Canada) x-EBCDIC-JapaneseAndUSCanada 50931 932 *)\r\n (Name: 'x-EBCDIC-JapaneseAndUSCanada'; CodePage: 50931; FamilyCodePage: 932),\r\n(* IBM EBCDIC (Japanese katakana) x-EBCDIC-JapaneseKatakana 20290 932 *)\r\n (Name: 'x-EBCDIC-JapaneseKatakana'; CodePage: 20290; FamilyCodePage: 932),\r\n(* IBM EBCDIC (Korean and Korean Extended) x-EBCDIC-KoreanAndKoreanExtended 50933 949 *)\r\n (Name: 'x-EBCDIC-KoreanAndKoreanExtended'; CodePage: 50933; FamilyCodePage: 949),\r\n(* IBM EBCDIC (Korean Extended) x-EBCDIC-KoreanExtended 20833 949 *)\r\n (Name: 'x-EBCDIC-KoreanExtended'; CodePage: 20833; FamilyCodePage: 949),\r\n(* IBM EBCDIC (Multilingual Latin-2) CP870 870 1250 *)\r\n (Name: 'CP870'; CodePage: 870; FamilyCodePage: 1250),\r\n(* IBM EBCDIC (Simplified Chinese) x-EBCDIC-SimplifiedChinese 50935 936 *)\r\n (Name: 'x-EBCDIC-SimplifiedChinese'; CodePage: 50935; FamilyCodePage: 936),\r\n(* IBM EBCDIC (Spain) X-EBCDIC-Spain 20284 1252 *)\r\n (Name: 'X-EBCDIC-Spain'; CodePage: 20284; FamilyCodePage: 1252),\r\n(* IBM EBCDIC (Spain-Euro) x-ebcdic-spain-euro 1145 1252 *)\r\n (Name: 'x-ebcdic-spain-euro'; CodePage: 1145; FamilyCodePage: 1252),\r\n(* IBM EBCDIC (Thai) x-EBCDIC-Thai 20838 874 *)\r\n (Name: 'x-EBCDIC-Thai'; CodePage: 20838; FamilyCodePage: 874),\r\n(* IBM EBCDIC (Traditional Chinese) x-EBCDIC-TraditionalChinese 50937 950 *)\r\n (Name: 'x-EBCDIC-TraditionalChinese'; CodePage: 50937; FamilyCodePage: 950),\r\n(* IBM EBCDIC (Turkish Latin-5) CP1026 1026 1254 *)\r\n (Name: 'CP1026'; CodePage: 1026; FamilyCodePage: 1254),\r\n(* IBM EBCDIC (Turkish) x-EBCDIC-Turkish 20905 1254 *)\r\n (Name: 'x-EBCDIC-Turkish'; CodePage: 20905; FamilyCodePage: 1254),\r\n(* IBM EBCDIC (UK) x-EBCDIC-UK 20285 1252 *)\r\n (Name: 'x-EBCDIC-UK'; CodePage: 20285; FamilyCodePage: 1252),\r\n(* IBM EBCDIC (UK-Euro) x-ebcdic-uk-euro 1146 1252 *)\r\n (Name: 'x-ebcdic-uk-euro'; CodePage: 1146; FamilyCodePage: 1252),\r\n(* IBM EBCDIC (US-Canada) ebcdic-cp-us 37 1252 *)\r\n (Name: 'ebcdic-cp-us'; CodePage: 37; FamilyCodePage: 1252),\r\n(* IBM EBCDIC (US-Canada-Euro) x-ebcdic-cp-us-euro 1140 1252 *)\r\n (Name: 'x-ebcdic-cp-us-euro'; CodePage: 1140; FamilyCodePage: 1252),\r\n(* Icelandic (DOS) ibm861 861 1252 *)\r\n (Name: 'ibm861'; CodePage: 861; FamilyCodePage: 1252),\r\n(* Icelandic (Mac) x-mac-icelandic 10079 1252 *)\r\n (Name: 'x-mac-icelandic'; CodePage: 10079; FamilyCodePage: 1252),\r\n(* ISCII Assamese x-iscii-as 57006 57006 *)\r\n (Name: 'x-iscii-as'; CodePage: 57006; FamilyCodePage: 57006),\r\n(* ISCII Bengali x-iscii-be 57003 57003 *)\r\n (Name: 'x-iscii-be'; CodePage: 57003; FamilyCodePage: 57003),\r\n(* ISCII Devanagari x-iscii-de 57002 57002 *)\r\n (Name: 'x-iscii-de'; CodePage: 57002; FamilyCodePage: 57002),\r\n(* ISCII Gujarathi x-iscii-gu 57010 57010 *)\r\n (Name: 'x-iscii-gu'; CodePage: 57010; FamilyCodePage: 57010),\r\n(* ISCII Kannada x-iscii-ka 57008 57008 *)\r\n (Name: 'x-iscii-ka'; CodePage: 57008; FamilyCodePage: 57008),\r\n(* ISCII Malayalam x-iscii-ma 57009 57009 *)\r\n (Name: 'x-iscii-ma'; CodePage: 57009; FamilyCodePage: 57009),\r\n(* ISCII Oriya x-iscii-or 57007 57007 *)\r\n (Name: 'x-iscii-or'; CodePage: 57007; FamilyCodePage: 57007),\r\n(* ISCII Panjabi x-iscii-pa 57011 57011 *)\r\n (Name: 'x-iscii-pa'; CodePage: 57011; FamilyCodePage: 57011),\r\n(* ISCII Tamil x-iscii-ta 57004 57004 *)\r\n (Name: 'x-iscii-ta'; CodePage: 57004; FamilyCodePage: 57004),\r\n(* ISCII Telugu x-iscii-te 57005 57005 *)\r\n (Name: 'x-iscii-te'; CodePage: 57005; FamilyCodePage: 57005),\r\n(* Japanese (EUC) euc-jp csEUCPkdFmtJapanese, Extended_UNIX_Code_Packed_Format_for_Japanese, x-euc, x-euc-jp 51932 932 *)\r\n (Name: 'euc-jp'; CodePage: 51932; FamilyCodePage: 932),\r\n (Name: 'csEUCPkdFmtJapanese'; CodePage: 51932; FamilyCodePage: 932),\r\n (Name: 'Extended_UNIX_Code_Packed_Format_for_Japanese'; CodePage: 51932; FamilyCodePage: 932),\r\n (Name: 'x-euc'; CodePage: 51932; FamilyCodePage: 932),\r\n (Name: 'x-euc-jp'; CodePage: 51932; FamilyCodePage: 932),\r\n(* Japanese (JIS) iso-2022-jp 50220 932 *)\r\n (Name: 'iso-2022-jp'; CodePage: 50220; FamilyCodePage: 932),\r\n(* Japanese (JIS-Allow 1 byte Kana - SO/SI) iso-2022-jp _iso-2022-jp$SIO 50222 932 *)\r\n (Name: 'iso-2022-jp'; CodePage: 50222; FamilyCodePage: 932),\r\n (Name: '_iso-2022-jp$SIO'; CodePage: 50222; FamilyCodePage: 932),\r\n(* Japanese (JIS-Allow 1 byte Kana) csISO2022JP _iso-2022-jp 50221 932 *)\r\n (Name: 'csISO2022JP'; CodePage: 50221; FamilyCodePage: 932),\r\n (Name: '_iso-2022-jp'; CodePage: 50221; FamilyCodePage: 932),\r\n(* Japanese (Mac) x-mac-japanese 10001 932 *)\r\n (Name: 'x-mac-japanese'; CodePage: 10001; FamilyCodePage: 932),\r\n(* Japanese (Shift-JIS) shift_jis csShiftJIS, csWindows31J, ms_Kanji, shift-jis, x-ms-cp932, x-sjis 932 932 *)\r\n (Name: 'shift_jis'; CodePage: 932; FamilyCodePage: 932),\r\n (Name: 'csShiftJIS'; CodePage: 932; FamilyCodePage: 932),\r\n (Name: 'csWindows31J'; CodePage: 932; FamilyCodePage: 932),\r\n (Name: 'ms_Kanji'; CodePage: 932; FamilyCodePage: 932),\r\n (Name: 'shift-jis'; CodePage: 932; FamilyCodePage: 932),\r\n (Name: 'x-ms-cp932'; CodePage: 932; FamilyCodePage: 932),\r\n (Name: 'x-sjis'; CodePage: 932; FamilyCodePage: 932),\r\n (Name: 'MS932'; CodePage: 932; FamilyCodePage: 932),\r\n(* Korean ks_c_5601-1987 csKSC56011987, euc-kr, iso-ir-149, korean, ks_c_5601, ks_c_5601_1987, ks_c_5601-1989, KSC_5601, KSC5601 949 949 *)\r\n (Name: 'ks_c_5601-1987'; CodePage: 949; FamilyCodePage: 949),\r\n (Name: 'csKSC56011987'; CodePage: 949; FamilyCodePage: 949),\r\n (Name: 'euc-kr'; CodePage: 949; FamilyCodePage: 949),\r\n (Name: 'iso-ir-149'; CodePage: 949; FamilyCodePage: 949),\r\n (Name: 'korean'; CodePage: 949; FamilyCodePage: 949),\r\n (Name: 'ks_c_5601'; CodePage: 949; FamilyCodePage: 949),\r\n (Name: 'ks_c_5601_1987'; CodePage: 949; FamilyCodePage: 949),\r\n (Name: 'ks_c_5601-1989'; CodePage: 949; FamilyCodePage: 949),\r\n (Name: 'KSC_5601'; CodePage: 949; FamilyCodePage: 949),\r\n (Name: 'KSC5601'; CodePage: 949; FamilyCodePage: 949),\r\n(* Korean (EUC) euc-kr csEUCKR 51949 949 *)\r\n (Name: 'euc-kr'; CodePage: 51949; FamilyCodePage: 949),\r\n (Name: 'csEUCKR'; CodePage: 51949; FamilyCodePage: 949),\r\n(* Korean (ISO) iso-2022-kr csISO2022KR 50225 949 *)\r\n (Name: 'iso-2022-kr'; CodePage: 50225; FamilyCodePage: 949),\r\n (Name: 'csISO2022KR'; CodePage: 50225; FamilyCodePage: 949),\r\n(* Korean (Johab) Johab 1361 1361 *)\r\n (Name: 'Johab'; CodePage: 1361; FamilyCodePage: 1361),\r\n(* Korean (Mac) x-mac-korean 10003 949 *)\r\n (Name: 'x-mac-korean'; CodePage: 10003; FamilyCodePage: 949),\r\n(* Latin 3 (ISO) iso-8859-3 csISOLatin3, ISO_8859-3, ISO_8859-3:1988, iso-ir-109, l3, latin3 28593 1254 *)\r\n (Name: 'iso-8859-3'; CodePage: 28593; FamilyCodePage: 1254),\r\n (Name: 'csISOLatin3'; CodePage: 28593; FamilyCodePage: 1254),\r\n (Name: 'ISO_8859-3'; CodePage: 28593; FamilyCodePage: 1254),\r\n (Name: 'ISO_8859-3:1988'; CodePage: 28593; FamilyCodePage: 1254),\r\n (Name: 'iso-ir-109'; CodePage: 28593; FamilyCodePage: 1254),\r\n (Name: 'l3,'; CodePage: 28593; FamilyCodePage: 1254),\r\n (Name: 'latin3'; CodePage: 28593; FamilyCodePage: 1254),\r\n(* Latin 9 (ISO) iso-8859-15 csISOLatin9, ISO_8859-15, l9, latin9 28605 1252 *)\r\n (Name: 'iso-8859-15'; CodePage: 28605; FamilyCodePage: 1252),\r\n (Name: 'csISOLatin9'; CodePage: 28605; FamilyCodePage: 1252),\r\n (Name: 'ISO_8859-15'; CodePage: 28605; FamilyCodePage: 1252),\r\n (Name: 'l9'; CodePage: 28605; FamilyCodePage: 1252),\r\n (Name: 'latin9'; CodePage: 28605; FamilyCodePage: 1252),\r\n(* Norwegian (IA5) x-IA5-Norwegian 20108 1252 *)\r\n (Name: 'x-IA5-Norwegian'; CodePage: 20108; FamilyCodePage: 1252),\r\n(* OEM United States IBM437 437, cp437, csPC8, CodePage437 437 1252 *)\r\n (Name: 'IBM437'; CodePage: 437; FamilyCodePage: 1252),\r\n (Name: '437'; CodePage: 437; FamilyCodePage: 1252),\r\n (Name: 'cp437'; CodePage: 437; FamilyCodePage: 1252),\r\n (Name: 'csPC8'; CodePage: 437; FamilyCodePage: 1252),\r\n (Name: 'CodePage437'; CodePage: 437; FamilyCodePage: 1252),\r\n(* Swedish (IA5) x-IA5-Swedish 20107 1252 *)\r\n (Name: 'x-IA5-Swedish'; CodePage: 20107; FamilyCodePage: 1252),\r\n(* Thai (Windows) windows-874 DOS-874, iso-8859-11, TIS-620 874 874 *)\r\n (Name: 'windows-874'; CodePage: 874; FamilyCodePage: 874),\r\n (Name: 'DOS-874'; CodePage: 874; FamilyCodePage: 874),\r\n (Name: 'iso-8859-11'; CodePage: 874; FamilyCodePage: 874),\r\n (Name: 'TIS-620'; CodePage: 874; FamilyCodePage: 874),\r\n(* Turkish (DOS) ibm857 857 1254 *)\r\n (Name: 'ibm857'; CodePage: 857; FamilyCodePage: 1254),\r\n(* Turkish (ISO) iso-8859-9 csISOLatin5, ISO_8859-9, ISO_8859-9:1989, iso-ir-148, l5, latin5 28599 1254 *)\r\n (Name: 'iso-8859-9'; CodePage: 28599; FamilyCodePage: 1254),\r\n (Name: 'csISOLatin5'; CodePage: 28599; FamilyCodePage: 1254),\r\n (Name: 'ISO_8859-9'; CodePage: 28599; FamilyCodePage: 1254),\r\n (Name: 'ISO_8859-9:1989'; CodePage: 28599; FamilyCodePage: 1254),\r\n (Name: 'iso-ir-148'; CodePage: 28599; FamilyCodePage: 1254),\r\n (Name: 'l5'; CodePage: 28599; FamilyCodePage: 1254),\r\n (Name: 'latin5'; CodePage: 28599; FamilyCodePage: 1254),\r\n(* Turkish (Mac) x-mac-turkish 10081 1254 *)\r\n (Name: 'x-mac-turkish'; CodePage: 10081; FamilyCodePage: 1254),\r\n(* Turkish (Windows) windows-1254 ISO_8859-9, ISO_8859-9:1989, iso-8859-9, iso-ir-148, latin5 1254 1254 *)\r\n (Name: 'windows-1254'; CodePage: 1254; FamilyCodePage: 1254),\r\n (Name: 'ISO_8859-9'; CodePage: 1254; FamilyCodePage: 1254),\r\n (Name: 'ISO_8859-9:1989'; CodePage: 1254; FamilyCodePage: 1254),\r\n (Name: 'iso-8859-9'; CodePage: 1254; FamilyCodePage: 1254),\r\n (Name: 'iso-ir-148'; CodePage: 1254; FamilyCodePage: 1254),\r\n(* Unicode unicode utf-16 1200 1200 *)\r\n (Name: 'utf-16'; CodePage: 1200; FamilyCodePage: 1200),\r\n (Name: 'unicode'; CodePage: 1200; FamilyCodePage: 1200),\r\n(* Unicode (Big-Endian) unicodeFFFE 1201 1200 *)\r\n (Name: 'unicodeFFFE'; CodePage: 1201; FamilyCodePage: 1200),\r\n(* Unicode (UTF-7) utf-7 csUnicode11UTF7, unicode-1-1-utf-7, x-unicode-2-0-utf-7 65000 1200 *)\r\n (Name: 'utf-7'; CodePage: 65000; FamilyCodePage: 1200),\r\n (Name: 'csUnicode11UTF7'; CodePage: 65000; FamilyCodePage: 1200),\r\n (Name: 'unicode-1-1-utf-7'; CodePage: 65000; FamilyCodePage: 1200),\r\n (Name: 'x-unicode-2-0-utf-7'; CodePage: 65000; FamilyCodePage: 1200),\r\n(* Unicode (UTF-8) utf-8 unicode-1-1-utf-8, unicode-2-0-utf-8, x-unicode-2-0-utf-8 65001 1200 *)\r\n (Name: 'utf-8'; CodePage: 65001; FamilyCodePage: 1200),\r\n (Name: 'unicode-1-1-utf-8'; CodePage: 65001; FamilyCodePage: 1200),\r\n (Name: 'unicode-2-0-utf-8'; CodePage: 65001; FamilyCodePage: 1200),\r\n (Name: 'x-unicode-2-0-utf-8'; CodePage: 65001; FamilyCodePage: 1200),\r\n(* US-ASCII us-ascii ANSI_X3.4-1968, ANSI_X3.4-1986, ascii, cp367, csASCII, IBM367, ISO_646.irv:1991, ISO646-US, iso-ir-6us 20127 1252 *)\r\n (Name: 'us-ascii'; CodePage: 20127; FamilyCodePage: 1252),\r\n (Name: 'ANSI_X3.4-1968'; CodePage: 20127; FamilyCodePage: 1252),\r\n (Name: 'ANSI_X3.4-1986'; CodePage: 20127; FamilyCodePage: 1252),\r\n (Name: 'ascii'; CodePage: 20127; FamilyCodePage: 1252),\r\n (Name: 'cp367'; CodePage: 20127; FamilyCodePage: 1252),\r\n (Name: 'csASCII'; CodePage: 20127; FamilyCodePage: 1252),\r\n (Name: 'IBM367'; CodePage: 20127; FamilyCodePage: 1252),\r\n (Name: 'ISO_646.irv:1991'; CodePage: 20127; FamilyCodePage: 1252),\r\n (Name: 'ISO646-US'; CodePage: 20127; FamilyCodePage: 1252),\r\n (Name: 'iso-ir-6us'; CodePage: 20127; FamilyCodePage: 1252),\r\n(* Vietnamese (Windows) windows-1258 1258 1258 *)\r\n (Name: 'windows-1258'; CodePage: 1258; FamilyCodePage: 1258),\r\n(* Western European (DOS) ibm850 850 1252 *)\r\n (Name: 'ibm850'; CodePage: 850; FamilyCodePage: 1252),\r\n(* Western European (IA5) x-IA5 20105 1252 *)\r\n (Name: 'x-IA5'; CodePage: 20105; FamilyCodePage: 1252),\r\n(* Western European (ISO) iso-8859-1 cp819, csISOLatin1, ibm819, iso_8859-1, iso_8859-1:1987, iso8859-1, iso-ir-100, l1, latin1 28591 1252 *)\r\n (Name: 'iso-8859-1'; CodePage: 28591; FamilyCodePage: 1252),\r\n (Name: 'cp819'; CodePage: 28591; FamilyCodePage: 1252),\r\n (Name: 'csISOLatin1'; CodePage: 28591; FamilyCodePage: 1252),\r\n (Name: 'ibm819'; CodePage: 28591; FamilyCodePage: 1252),\r\n (Name: 'iso_8859-1'; CodePage: 28591; FamilyCodePage: 1252),\r\n (Name: 'iso_8859-1:1987'; CodePage: 28591; FamilyCodePage: 1252),\r\n (Name: 'iso8859-1'; CodePage: 28591; FamilyCodePage: 1252),\r\n (Name: 'iso-ir-100'; CodePage: 28591; FamilyCodePage: 1252),\r\n (Name: 'l1'; CodePage: 28591; FamilyCodePage: 1252),\r\n (Name: 'latin1'; CodePage: 28591; FamilyCodePage: 1252),\r\n(* Western European (Mac) macintosh 10000 1252 *)\r\n (Name: 'macintosh'; CodePage: 10000; FamilyCodePage: 1252),\r\n(* Western European (Windows) Windows-1252 ANSI_X3.4-1968, ANSI_X3.4-1986, ascii, cp367, cp819, csASCII, IBM367, ibm819, ISO_646.irv:1991, iso_8859-1, iso_8859-1:1987, ISO646-US, iso8859-1, iso-8859-1, iso-ir-100, iso-ir-6, latin1, us, us-ascii, x-ansi 1252 1252 *)\r\n (Name: 'Windows-1252'; CodePage: 1252; FamilyCodePage: 1252),\r\n (Name: 'ANSI_X3.4-1968'; CodePage: 1252; FamilyCodePage: 1252),\r\n (Name: 'ANSI_X3.4-1986'; CodePage: 1252; FamilyCodePage: 1252),\r\n (Name: 'CP1252'; CodePage: 1252; FamilyCodePage: 1252),\r\n (Name: 'ascii'; CodePage: 1252; FamilyCodePage: 1252),\r\n (Name: 'cp367'; CodePage: 1252; FamilyCodePage: 1252),\r\n (Name: 'cp819'; CodePage: 1252; FamilyCodePage: 1252),\r\n (Name: 'csASCII'; CodePage: 1252; FamilyCodePage: 1252),\r\n (Name: 'IBM367'; CodePage: 1252; FamilyCodePage: 1252),\r\n (Name: 'ibm819'; CodePage: 1252; FamilyCodePage: 1252),\r\n (Name: 'ISO_646.irv:1991'; CodePage: 1252; FamilyCodePage: 1252),\r\n (Name: 'iso_8859-1'; CodePage: 1252; FamilyCodePage: 1252),\r\n (Name: 'iso_8859-1:1987'; CodePage: 1252; FamilyCodePage: 1252),\r\n (Name: 'ISO646-US'; CodePage: 1252; FamilyCodePage: 1252),\r\n (Name: 'iso8859-1'; CodePage: 1252; FamilyCodePage: 1252),\r\n (Name: 'iso-8859-1'; CodePage: 1252; FamilyCodePage: 1252),\r\n (Name: 'iso-ir-100'; CodePage: 1252; FamilyCodePage: 1252),\r\n (Name: 'iso-ir-6'; CodePage: 1252; FamilyCodePage: 1252),\r\n (Name: 'latin1'; CodePage: 1252; FamilyCodePage: 1252),\r\n (Name: 'us'; CodePage: 1252; FamilyCodePage: 1252),\r\n (Name: 'us-ascii'; CodePage: 1252; FamilyCodePage: 1252),\r\n (Name: 'x-ansi'; CodePage: 1252; FamilyCodePage: 1252) );\r\n\r\nfunction FamilyCodePageFromCharsetName(const CharsetName: string): Word;\r\nfunction FamilyCodePageFromCodePage(CodePage: Word): Word;\r\nfunction CodePageFromCharsetName(const CharsetName: string): Word;\r\nfunction CharsetInfoFromCharsetName(const CharsetName: string): TJclCharsetInfo;\r\nfunction CharsetNameFromCodePage(CodePage: Word): string;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jcl.svn.sourceforge.net/svnroot/jcl/tags/JCL-2.4-Build4571/jcl/source/common/JclCharsets.pas $';\r\n Revision: '$Revision: 3819 $';\r\n Date: '$Date: 2012-08-14 11:25:52 +0200 (mar. 14 août 2012) $';\r\n LogPath: 'JCL\\source\\common';\r\n Extra: '';\r\n Data: nil\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n {$IFDEF HAS_UNITSCOPE}\r\n System.SysUtils,\r\n {$ELSE ~HAS_UNITSCOPE}\r\n SysUtils,\r\n {$ENDIF ~HAS_UNITSCOPE}\r\n JclResources;\r\n\r\nfunction FamilyCodePageFromCharsetName(const CharsetName: string): Word;\r\nvar\r\n Index: Integer;\r\n UpperCharsetName: string;\r\nbegin\r\n UpperCharsetName := UpperCase(CharsetName);\r\n for Index := Low(JclCharsetInfos) to High(JclCharsetInfos) do\r\n if CompareStr(UpperCharsetName, UpperCase(JclCharsetInfos[Index].Name)) = 0 then\r\n begin\r\n Result := JclCharsetInfos[Index].FamilyCodePage;\r\n Exit;\r\n end;\r\n raise EJclCharsetError.CreateRes(@RsENoCharset);\r\nend;\r\n\r\nfunction CodePageFromCharsetName(const CharsetName: string): Word;\r\nvar\r\n Index: Integer;\r\n UpperCharsetName: string;\r\nbegin\r\n UpperCharsetName := UpperCase(CharsetName);\r\n for Index := Low(JclCharsetInfos) to High(JclCharsetInfos) do\r\n if CompareStr(UpperCharsetName, UpperCase(JclCharsetInfos[Index].Name)) = 0 then\r\n begin\r\n Result := JclCharsetInfos[Index].CodePage;\r\n Exit;\r\n end;\r\n raise EJclCharsetError.CreateRes(@RsENoCharset);\r\nend;\r\n\r\nfunction CharsetInfoFromCharsetName(const CharsetName: string): TJclCharsetInfo;\r\nvar\r\n Index: Integer;\r\n UpperCharsetName: string;\r\nbegin\r\n UpperCharsetName := UpperCase(CharsetName);\r\n for Index := Low(JclCharsetInfos) to High(JclCharsetInfos) do\r\n if CompareStr(UpperCharsetName, UpperCase(JclCharsetInfos[Index].Name)) = 0 then\r\n begin\r\n Result := JclCharsetInfos[Index];\r\n Exit;\r\n end;\r\n raise EJclCharsetError.CreateRes(@RsENoCharset);\r\nend;\r\n\r\nfunction FamilyCodePageFromCodePage(CodePage: Word): Word;\r\nvar\r\n Index: Integer;\r\nbegin\r\n for Index := Low(JclCharsetInfos) to High(JclCharsetInfos) do\r\n if JclCharsetInfos[Index].CodePage = CodePage then\r\n begin\r\n Result := JclCharsetInfos[Index].FamilyCodePage;\r\n Exit;\r\n end;\r\n raise EJclCharsetError.CreateRes(@RsENoCharset);\r\nend;\r\n\r\nfunction CharsetNameFromCodePage(CodePage: Word): string;\r\nvar\r\n Index: Integer;\r\nbegin\r\n for Index := Low(JclCharsetInfos) to High(JclCharsetInfos) do\r\n if JclCharsetInfos[Index].CodePage = CodePage then\r\n begin\r\n Result := JclCharsetInfos[Index].Name;\r\n Exit;\r\n end;\r\n raise EJclCharsetError.CreateRes(@RsENoCharset);\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n\r\n" }, { "path": "External/Jedi/Jcl/source/common/JclCompilerUtils.pas", "content": "{**************************************************************************************************}\r\n{ }\r\n{ Project JEDI Code Library (JCL) }\r\n{ }\r\n{ The contents of this file are subject to the Mozilla Public License Version 1.1 (the \"License\"); }\r\n{ you may not use this file except in compliance with the License. You may obtain a copy of the }\r\n{ License at http://www.mozilla.org/MPL/ }\r\n{ }\r\n{ Software distributed under the License is distributed on an \"AS IS\" basis, WITHOUT WARRANTY OF }\r\n{ ANY KIND, either express or implied. See the License for the specific language governing rights }\r\n{ and limitations under the License. }\r\n{ }\r\n{ The Original Code is DelphiInstall.pas. }\r\n{ }\r\n{ The Initial Developer of the Original Code is Petr Vones. Portions created by Petr Vones are }\r\n{ Copyright (C) of Petr Vones. All Rights Reserved. }\r\n{ }\r\n{ Contributor(s): }\r\n{ Andreas Hausladen (ahuser) }\r\n{ Florent Ouchet (outchy) }\r\n{ Robert Marquardt (marquardt) }\r\n{ Robert Rossmair (rrossmair) - crossplatform & BCB support }\r\n{ Uwe Schuster (uschuster) }\r\n{ }\r\n{**************************************************************************************************}\r\n{ }\r\n{ Last modified: $Date:: 2012-09-04 16:08:04 +0200 (mar. 04 sept. 2012) $ }\r\n{ Revision: $Rev:: 3861 $ }\r\n{ Author: $Author:: outchy $ }\r\n{ }\r\n{**************************************************************************************************}\r\n\r\nunit JclCompilerUtils;\r\n\r\n{$I jcl.inc}\r\n{$I crossplatform.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n {$IFDEF HAS_UNITSCOPE}\r\n {$IFDEF MSWINDOWS}\r\n Winapi.Windows,\r\n {$ENDIF MSWINDOWS}\r\n System.Classes, System.SysUtils, System.IniFiles,\r\n {$ELSE ~HAS_UNITSCOPE}\r\n {$IFDEF MSWINDOWS}\r\n Windows,\r\n {$ENDIF MSWINDOWS}\r\n Classes, SysUtils, IniFiles,\r\n {$ENDIF ~HAS_UNITSCOPE}\r\n JclBase, JclSysUtils;\r\n\r\ntype\r\n EJclCompilerUtilsException = class(EJclError);\r\n\r\n TJclCompilerSettingsFormat = (csfDOF, csfBDSProj, csfMsBuild);\r\n\r\n TJclBorlandCommandLineTool = class;\r\n TJclBorlandCommandLineToolEvent = procedure(Sender:TJclBorlandCommandLineTool) of object;\r\n\r\n TJclBorlandCommandLineTool = class(TInterfacedObject, IJclCommandLineTool)\r\n private\r\n FBinDirectory: string;\r\n FCompilerSettingsFormat: TJclCompilerSettingsFormat;\r\n FLongPathBug: Boolean;\r\n FOptions: TStringList;\r\n FOutputCallback: TTextHandler;\r\n FOutput: string;\r\n FOnAfterExecute: TJclBorlandCommandLineToolEvent;\r\n FOnBeforeExecute: TJclBorlandCommandLineToolEvent;\r\n procedure OemTextHandler(const Text: string);\r\n protected\r\n procedure CheckOutputValid;\r\n function GetFileName: string;\r\n function InternalExecute(const CommandLine: string): Boolean;\r\n public\r\n constructor Create(const ABinDirectory: string; ALongPathBug: Boolean;\r\n ACompilerSettingsFormat: TJclCompilerSettingsFormat);\r\n destructor Destroy; override;\r\n { IJclCommandLineTool }\r\n function GetExeName: string; virtual;\r\n function GetOptions: TStrings;\r\n function GetOutput: string;\r\n function GetOutputCallback: TTextHandler;\r\n procedure AddPathOption(const Option, Path: string);\r\n function Execute(const CommandLine: string): Boolean; virtual;\r\n procedure SetOutputCallback(const CallbackMethod: TTextHandler);\r\n property BinDirectory: string read FBinDirectory;\r\n property CompilerSettingsFormat: TJclCompilerSettingsFormat read FCompilerSettingsFormat;\r\n property ExeName: string read GetExeName;\r\n property LongPathBug: Boolean read FLongPathBug;\r\n property Options: TStrings read GetOptions;\r\n property OutputCallback: TTextHandler write SetOutputCallback;\r\n property Output: string read GetOutput;\r\n\r\n property FileName: string read GetFileName;\r\n property OnAfterExecute: TJclBorlandCommandLineToolEvent read FOnAfterExecute write FOnAfterExecute;\r\n property OnBeforeExecute: TJclBorlandCommandLineToolEvent read FOnBeforeExecute write FOnBeforeExecute;\r\n end;\r\n\r\n TJclBCC32 = class(TJclBorlandCommandLineTool)\r\n public\r\n class function GetPlatform: string; virtual;\r\n function GetExeName: string; override;\r\n end;\r\n\r\n TJclBCC64 = class(TJclBCC32)\r\n public\r\n class function GetPlatform: string; override;\r\n function GetExeName: string; override;\r\n end;\r\n\r\n TProjectOptions = record\r\n UsePackages: Boolean;\r\n UnitOutputDir: string;\r\n SearchPath: string;\r\n DynamicPackages: string;\r\n SearchDcpPath: string;\r\n Conditionals: string;\r\n Namespace: string;\r\n end;\r\n\r\n TJclStringsGetterFunction = function: TStrings of object;\r\n\r\n TJclDCC32 = class(TJclBorlandCommandLineTool)\r\n private\r\n FDCPSearchPath: string;\r\n FLibrarySearchPath: string;\r\n FLibraryDebugSearchPath: string;\r\n FCppSearchPath: string;\r\n FSupportsNoConfig: Boolean;\r\n FSupportsPlatform: Boolean;\r\n FOnEnvironmentVariables: TJclStringsGetterFunction;\r\n protected\r\n procedure AddProjectOptions(const ProjectFileName, DCPPath: string);\r\n function Compile(const ProjectFileName: string): Boolean;\r\n public\r\n class function GetPlatform: string; virtual;\r\n constructor Create(const ABinDirectory: string; ALongPathBug: Boolean;\r\n ACompilerSettingsFormat: TJclCompilerSettingsFormat; ASupportsNoConfig, ASupportsPlatform: Boolean;\r\n const ADCPSearchPath, ALibrarySearchPath, ALibraryDebugSearchPath, ACppSearchPath: string);\r\n function GetExeName: string; override;\r\n function Execute(const CommandLine: string): Boolean; override;\r\n function MakePackage(const PackageName, BPLPath, DCPPath: string;\r\n ExtraOptions: string = ''; ADebug: Boolean = False): Boolean;\r\n function MakeProject(const ProjectName, OutputDir, DcpSearchPath: string;\r\n ExtraOptions: string = ''; ADebug: Boolean = False): Boolean;\r\n procedure SetDefaultOptions(ADebug: Boolean); virtual;\r\n function AddBDSProjOptions(const ProjectFileName: string; var ProjectOptions: TProjectOptions): Boolean;\r\n function AddDOFOptions(const ProjectFileName: string; var ProjectOptions: TProjectOptions): Boolean;\r\n function AddDProjOptions(const ProjectFileName: string; var ProjectOptions: TProjectOptions): Boolean;\r\n property CppSearchPath: string read FCppSearchPath;\r\n property DCPSearchPath: string read FDCPSearchPath;\r\n property LibrarySearchPath: string read FLibrarySearchPath;\r\n property LibraryDebugSearchPath: string read FLibraryDebugSearchPath;\r\n property OnEnvironmentVariables: TJclStringsGetterFunction read FOnEnvironmentVariables write FOnEnvironmentVariables;\r\n property SupportsNoConfig: Boolean read FSupportsNoConfig;\r\n property SupportsPlatform: Boolean read FSupportsPlatform;\r\n end;\r\n\r\n TJclDCC64 = class(TJclDCC32)\r\n public\r\n class function GetPlatform: string; override;\r\n function GetExeName: string; override;\r\n end;\r\n\r\n TJclDCCOSX32 = class(TJclDCC32)\r\n public\r\n class function GetPlatform: string; override;\r\n function GetExeName: string; override;\r\n end;\r\n\r\n {$IFDEF MSWINDOWS}\r\n TJclDCCIL = class(TJclDCC32)\r\n private\r\n FMaxCLRVersion: string;\r\n protected\r\n function GetMaxCLRVersion: string;\r\n public\r\n function GetExeName: string; override;\r\n function MakeProject(const ProjectName, OutputDir, ExtraOptions: string;\r\n ADebug: Boolean = False): Boolean; reintroduce;\r\n procedure SetDefaultOptions(ADebug: Boolean); override;\r\n property MaxCLRVersion: string read GetMaxCLRVersion;\r\n end;\r\n {$ENDIF MSWINDOWS}\r\n\r\n TJclBpr2Mak = class(TJclBorlandCommandLineTool)\r\n public\r\n function GetExeName: string; override;\r\n end;\r\n\r\n TJclBorlandMake = class(TJclBorlandCommandLineTool)\r\n public\r\n function GetExeName: string; override;\r\n end;\r\n\r\nconst\r\n AsmExeName = 'tasm32.exe';\r\n BCC32ExeName = 'bcc32.exe';\r\n BCC64ExeName = 'bcc64.exe';\r\n DCC32ExeName = 'dcc32.exe';\r\n DCC64ExeName = 'dcc64.exe';\r\n DCCOSX32ExeName = 'dccosx.exe';\r\n DCCILExeName = 'dccil.exe';\r\n Bpr2MakExeName = 'bpr2mak.exe';\r\n MakeExeName = 'make.exe';\r\n\r\n BinaryExtensionPackage = '.bpl';\r\n BinaryExtensionLibrary = '.dll';\r\n BinaryExtensionExecutable = '.exe';\r\n SourceExtensionDelphiPackage = '.dpk';\r\n SourceExtensionBCBPackage = '.bpk';\r\n SourceExtensionDelphiProject = '.dpr';\r\n SourceExtensionBCBProject = '.bpr';\r\n SourceExtensionDProject = '.dproj';\r\n SourceExtensionBDSProject = '.bdsproj';\r\n SourceExtensionDOFProject = '.dof';\r\n SourceExtensionConfiguration = '.cfg';\r\n\r\nfunction BinaryFileName(const OutputPath, ProjectFileName: string): string;\r\n\r\nfunction IsDelphiPackage(const FileName: string): Boolean;\r\nfunction IsDelphiProject(const FileName: string): Boolean;\r\nfunction IsBCBPackage(const FileName: string): Boolean;\r\nfunction IsBCBProject(const FileName: string): Boolean;\r\n\r\nprocedure GetDPRFileInfo(const DPRFileName: string; out BinaryExtension: string;\r\n const LibSuffix: PString = nil);\r\nprocedure GetBPRFileInfo(const BPRFileName: string; out BinaryFileName: string;\r\n const Description: PString = nil);\r\nprocedure GetDPKFileInfo(const DPKFileName: string; out RunOnly: Boolean;\r\n const LibSuffix: PString = nil; const Description: PString = nil);\r\nprocedure GetBPKFileInfo(const BPKFileName: string; out RunOnly: Boolean;\r\n const BinaryFileName: PString = nil; const Description: PString = nil);\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jcl.svn.sourceforge.net/svnroot/jcl/tags/JCL-2.4-Build4571/jcl/source/common/JclCompilerUtils.pas $';\r\n Revision: '$Revision: 3861 $';\r\n Date: '$Date: 2012-09-04 16:08:04 +0200 (mar. 04 sept. 2012) $';\r\n LogPath: 'JCL\\source\\common';\r\n Extra: '';\r\n Data: nil\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n {$IFDEF HAS_UNITSCOPE}\r\n System.SysConst,\r\n {$ELSE ~HAS_UNITSCOPE}\r\n SysConst,\r\n {$ENDIF ~HAS_UNITSCOPE}\r\n {$IFDEF HAS_UNIT_LIBC}\r\n Libc,\r\n {$ENDIF HAS_UNIT_LIBC}\r\n JclFileUtils,\r\n JclDevToolsResources,\r\n JclIDEUtils,\r\n JclAnsiStrings,\r\n JclWideStrings,\r\n JclStrings,\r\n JclSysInfo,\r\n JclSimpleXml,\r\n JclMsBuild;\r\n\r\nconst\r\n // DOF options\r\n DOFDirectoriesSection = 'Directories';\r\n DOFUnitOutputDirKey = 'UnitOutputDir';\r\n DOFSearchPathName = 'SearchPath';\r\n DOFConditionals = 'Conditionals';\r\n DOFLinkerSection = 'Linker';\r\n DOFPackagesKey = 'Packages';\r\n DOFCompilerSection = 'Compiler';\r\n DOFPackageNoLinkKey = 'PackageNoLink';\r\n // injection of new compiler options to workaround L1496 internal error of Delphi 5 and C++Builder 5\r\n // adding -B switch to the compiler command line forces units to be built\r\n DOFAdditionalSection = 'Additional';\r\n DOFOptionsKey = 'Options';\r\n\r\n // BDSProj options\r\n BDSProjPersonalityInfoNodeName = 'PersonalityInfo';\r\n BDSProjOptionNodeName = 'Option';\r\n BDSProjNameProperty = 'Name';\r\n BDSProjPersonalityValue = 'Personality';\r\n BDSProjUnitOutputDirValue = 'UnitOutputDir';\r\n BDSProjSearchPathValue = 'SearchPath';\r\n BDSProjPackagesValue = 'Packages';\r\n BDSProjConditionalsValue = 'Conditionals';\r\n BDSProjUsePackagesValue = 'UsePackages';\r\n BDSProjDirectoriesNodeName = 'Directories';\r\n\r\n // DProj options\r\n DProjPersonalityNodeName = 'Borland.Personality';\r\n DProjDelphiPersonalityValue = 'Delphi.Personality';\r\n DProjDelphiDotNetPersonalityValue = 'DelphiDotNet.Personality';\r\n DProjUsePackageNodeName = 'DCC_UsePackage';\r\n DProjDcuOutputDirNodeName = 'DCC_DcuOutput';\r\n DProjUnitSearchPathNodeName = 'DCC_UnitSearchPath';\r\n DProjDefineNodeName = 'DCC_Define';\r\n DProjNamespaceNodeName = 'DCC_Namespace';\r\n\r\n DelphiLibSuffixOption = '{$LIBSUFFIX ''';\r\n DelphiDescriptionOption = '{$DESCRIPTION ''';\r\n DelphiRunOnlyOption = '{$RUNONLY}';\r\n DelphiBinaryExtOption = '{$E ';\r\n BCBLFlagsOption = ' 0 then\r\n begin\r\n SubS1 := Copy(S, LProjectPos, Length(S));\r\n J := 1;\r\n while (Pos('>', SubS1) = 0) and ((I + J) < BPKFile.Count) do\r\n begin\r\n SubS1 := SubS1 + BPKFile[I + J];\r\n Inc(J);\r\n end;\r\n\r\n BinaryFileNamePos := Pos('\"', SubS1);\r\n if BinaryFileNamePos > 0 then\r\n begin\r\n SubS2 := Copy(SubS1, BinaryFileNamePos + 1, Length(SubS1) - BinaryFileNamePos);\r\n EndFileNamePos := Pos('\"', SubS2);\r\n\r\n if EndFileNamePos > 0 then\r\n BinaryFileName := Copy(SubS2, 1, EndFileNamePos - 1);\r\n end;\r\n end;\r\n\r\n LFlagsPos := Pos(BCBLFlagsOption, S);\r\n if LFlagsPos > 0 then\r\n begin\r\n SubS1 := Copy(S, LFlagsPos, Length(S));\r\n J := 1;\r\n while (Pos('>', SubS1) = 0) and ((I + J) < BPKFile.Count) do\r\n begin\r\n SubS1 := SubS1 + BPKFile[I + J];\r\n Inc(J);\r\n end;\r\n DSwitchPos := Pos(BCBDSwitchOption, SubS1);\r\n if DSwitchPos > 0 then\r\n begin\r\n SubS2 := Copy(SubS1, DSwitchPos, Length(SubS1));\r\n SemiColonPos := Pos(';', SubS2);\r\n if SemiColonPos > 0 then\r\n begin\r\n SubS3 := Copy(SubS2, SemiColonPos + 1, Length(SubS2));\r\n AmpPos := Pos('&', SubS3);\r\n if (Description <> nil) and (AmpPos > 0) then\r\n Description^ := Copy(SubS3, 1, AmpPos - 1);\r\n end;\r\n end;\r\n end;\r\n end;\r\n finally\r\n BPKFile.Free;\r\n end;\r\nend;\r\n\r\nprocedure GetDPKFileInfo(const DPKFileName: string; out RunOnly: Boolean;\r\n const LibSuffix: PString = nil; const Description: PString = nil);\r\nvar\r\n I: Integer;\r\n S: string;\r\n DPKFile: TStringList;\r\nbegin\r\n DPKFile := TStringList.Create;\r\n try\r\n DPKFile.LoadFromFile(DPKFileName);\r\n if Assigned(Description) then\r\n Description^ := '';\r\n if Assigned(LibSuffix) then\r\n LibSuffix^ := '';\r\n RunOnly := False;\r\n for I := 0 to DPKFile.Count - 1 do\r\n begin\r\n S := TrimRight(DPKFile.Strings[I]);\r\n if Assigned(Description) and (Pos(DelphiDescriptionOption, S) = 1) then\r\n Description^ := Copy(S, Length(DelphiDescriptionOption), Length(S) - Length(DelphiDescriptionOption))\r\n else\r\n if Assigned(LibSuffix) and (Pos(DelphiLibSuffixOption, S) = 1) then\r\n LibSuffix^ := StrTrimQuotes(Copy(S, Length(DelphiLibSuffixOption), Length(S) - Length(DelphiLibSuffixOption)))\r\n else\r\n if Pos(DelphiRunOnlyOption, S) = 1 then\r\n RunOnly := True;\r\n end;\r\n finally\r\n DPKFile.Free;\r\n end;\r\nend;\r\n\r\nprocedure GetBPKFileInfo(const BPKFileName: string; out RunOnly: Boolean;\r\n const BinaryFileName: PString = nil; const Description: PString = nil);\r\nvar\r\n I, J: Integer;\r\n S, SubS1, SubS2, SubS3: string;\r\n BPKFile: TStringList;\r\n LFlagsPos, DSwitchPos, SemiColonPos, AmpPos, GprPos: Integer;\r\n LProjectPos, BinaryFileNamePos, EndFileNamePos: Integer;\r\nbegin\r\n BPKFile := TStringList.Create;\r\n try\r\n BPKFile.LoadFromFile(BPKFileName);\r\n if Assigned(Description) then\r\n Description^ := '';\r\n if Assigned(BinaryFileName) then\r\n BinaryFileName^ := '';\r\n RunOnly := False;\r\n for I := 0 to BPKFile.Count - 1 do\r\n begin\r\n S := BPKFile[I];\r\n\r\n LProjectPos := Pos(BCBProjectOption, S);\r\n if Assigned(BinaryFileName) and (LProjectPos > 0) then\r\n begin\r\n SubS1 := Copy(S, LProjectPos, Length(S));\r\n J := 1;\r\n while (Pos('>', SubS1) = 0) and ((I + J) < BPKFile.Count) do\r\n begin\r\n SubS1 := SubS1 + BPKFile[I + J];\r\n Inc(J);\r\n end;\r\n\r\n BinaryFileNamePos := Pos('\"', SubS1);\r\n if BinaryFileNamePos > 0 then\r\n begin\r\n SubS2 := Copy(SubS1, BinaryFileNamePos + 1, Length(SubS1) - BinaryFileNamePos);\r\n EndFileNamePos := Pos('\"', SubS2);\r\n\r\n if EndFileNamePos > 0 then\r\n BinaryFileName^ := Copy(SubS2, 1, EndFileNamePos - 1);\r\n end;\r\n end;\r\n\r\n LFlagsPos := Pos(BCBLFlagsOption, S);\r\n if LFlagsPos > 0 then\r\n begin\r\n SubS1 := Copy(S, LFlagsPos, Length(S));\r\n J := 1;\r\n while (Pos('>', SubS1) = 0) and ((I + J) < BPKFile.Count) do\r\n begin\r\n SubS1 := SubS1 + BPKFile[I + J];\r\n Inc(J);\r\n end;\r\n DSwitchPos := Pos(BCBDSwitchOption, SubS1);\r\n GprPos := Pos(BCBGprSwitchOption, SubS1);\r\n if DSwitchPos > 0 then\r\n begin\r\n SubS2 := Copy(SubS1, DSwitchPos, Length(SubS1));\r\n SemiColonPos := Pos(';', SubS2);\r\n if SemiColonPos > 0 then\r\n begin\r\n SubS3 := Copy(SubS2, SemiColonPos + 1, Length(SubS2));\r\n AmpPos := Pos('&', SubS3);\r\n if (Description <> nil) and (AmpPos > 0) then\r\n Description^ := Copy(SubS3, 1, AmpPos - 1);\r\n end;\r\n end;\r\n if GprPos > 0 then\r\n RunOnly := True;\r\n end;\r\n end;\r\n finally\r\n BPKFile.Free;\r\n end;\r\nend;\r\n\r\nfunction BinaryFileName(const OutputPath, ProjectFileName: string): string;\r\nvar\r\n ProjectExtension, LibSuffix, BinaryExtension: string;\r\n RunOnly: Boolean;\r\nbegin\r\n ProjectExtension := ExtractFileExt(ProjectFileName);\r\n if SameText(ProjectExtension, SourceExtensionDelphiPackage) then\r\n begin\r\n GetDPKFileInfo(ProjectFileName, RunOnly, @LibSuffix);\r\n Result := PathExtractFileNameNoExt(ProjectFileName) + LibSuffix + BinaryExtensionPackage;\r\n end\r\n else\r\n if SameText(ProjectExtension, SourceExtensionDelphiProject) then\r\n begin\r\n GetDPRFileInfo(ProjectFileName, BinaryExtension, @LibSuffix);\r\n Result := PathExtractFileNameNoExt(ProjectFileName) + LibSuffix + BinaryExtension;\r\n end\r\n else\r\n if SameText(ProjectExtension, SourceExtensionBCBPackage) then\r\n GetBPKFileInfo(ProjectFileName, RunOnly, @Result)\r\n else\r\n if SameText(ProjectExtension, SourceExtensionBCBProject) then\r\n GetBPRFileInfo(ProjectFileName, Result)\r\n else\r\n raise EJclCompilerUtilsException.CreateResFmt(@RsEUnknownProjectExtension, [ProjectExtension]);\r\n\r\n Result := PathAddSeparator(OutputPath) + Result;\r\nend;\r\n\r\nfunction IsDelphiPackage(const FileName: string): Boolean;\r\nbegin\r\n Result := SameText(ExtractFileExt(FileName), SourceExtensionDelphiPackage);\r\nend;\r\n\r\nfunction IsDelphiProject(const FileName: string): Boolean;\r\nbegin\r\n Result := SameText(ExtractFileExt(FileName), SourceExtensionDelphiProject);\r\nend;\r\n\r\nfunction IsBCBPackage(const FileName: string): Boolean;\r\nbegin\r\n Result := SameText(ExtractFileExt(FileName), SourceExtensionBCBPackage);\r\nend;\r\n\r\nfunction IsBCBProject(const FileName: string): Boolean;\r\nbegin\r\n Result := SameText(ExtractFileExt(FileName), SourceExtensionBCBProject);\r\nend;\r\n\r\n{$IFDEF MSWINDOWS}\r\ntype\r\n TFindResStartRec = record\r\n StartStr: WideString;\r\n MatchStr: WideString;\r\n end;\r\n PFindResStartRec = ^TFindResStartRec;\r\n\r\n// helper function to check strings starting \"StartStr\" in current string table\r\nfunction FindResStartCallBack(hModule: HMODULE; lpszType, lpszName: PChar;\r\n lParam: PFindResStartRec): BOOL; stdcall;\r\nvar\r\n ResInfo, ResHData, ResSize, ResIndex: Cardinal;\r\n ResData: PWord;\r\n StrLength: Word;\r\n MatchLen: Integer;\r\nbegin\r\n Result := True;\r\n MatchLen := Length(lParam^.StartStr);\r\n\r\n ResInfo := FindResource(hModule, lpszName, lpszType);\r\n if ResInfo <> 0 then\r\n begin\r\n ResHData := LoadResource(hModule, ResInfo);\r\n if ResHData <> 0 then\r\n begin\r\n ResData := LockResource(ResHData);\r\n if Assigned(ResData) then\r\n begin\r\n // string tables are a concatenation of maximum 16 prefixed-length widestrings\r\n ResSize := SizeofResource(hModule, ResInfo) div 2;\r\n ResIndex := 0;\r\n // iterate all concatenated strings\r\n while ResIndex < ResSize do\r\n begin\r\n StrLength := ResData^;\r\n Inc(ResData);\r\n Inc(ResIndex);\r\n if (StrLength >= MatchLen) and\r\n (StrLICompW(PWideChar(lParam^.StartStr), PWideChar(ResData), MatchLen) = 0) then\r\n begin\r\n // we have a match\r\n SetLength(lParam^.MatchStr, StrLength);\r\n Move(ResData^, lParam^.MatchStr[1], StrLength * SizeOf(lParam^.MatchStr[1]));\r\n Result := False;\r\n Break;\r\n end;\r\n Inc(ResData, StrLength);\r\n Inc(ResIndex, StrLength);\r\n end;\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\n// find in specified module \"FileName\" a resourcestring starting with StartStr\r\nfunction FindResStart(const FileName: string; const StartStr: WideString): WideString;\r\nvar\r\n H: HMODULE;\r\n FindResRec: TFindResStartRec;\r\nbegin\r\n FindResRec.StartStr := StartStr;\r\n FindResRec.MatchStr := '';\r\n\r\n H := LoadLibraryEx(PChar(FileName), 0, LOAD_LIBRARY_AS_DATAFILE or DONT_RESOLVE_DLL_REFERENCES);\r\n if H <> 0 then\r\n try\r\n EnumResourceNames(H, RT_STRING, @FindResStartCallBack, LPARAM(@FindResRec));\r\n finally\r\n FreeLibrary(H);\r\n end;\r\n\r\n Result := FindResRec.MatchStr;\r\nend;\r\n{$ENDIF MSWINDOWS}\r\n\r\n//=== { TJclBorlandCommandLineTool } =========================================\r\n\r\nconstructor TJclBorlandCommandLineTool.Create(const ABinDirectory: string; ALongPathBug: Boolean;\r\n ACompilerSettingsFormat: TJclCompilerSettingsFormat);\r\nbegin\r\n inherited Create;\r\n FBinDirectory := ABinDirectory;\r\n FLongPathBug := ALongPathBug;\r\n FCompilerSettingsFormat := ACompilerSettingsFormat;\r\n FOptions := TStringList.Create;\r\nend;\r\n\r\ndestructor TJclBorlandCommandLineTool.Destroy;\r\nbegin\r\n FreeAndNil(FOptions);\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJclBorlandCommandLineTool.AddPathOption(const Option, Path: string);\r\nvar\r\n S: string;\r\n\r\n // path before Delphi 2005 must be shortened\r\n // to avoid the 126 character limit of DCC32 (and eventually other command line tools)\r\n // which shows up with misleading error messages (\"Fatal: System.pas not found\") or\r\n // might even cause AVs\r\n procedure ConvertToShortPathNames(var Paths: string);\r\n var\r\n List: TStringList;\r\n I: Integer;\r\n begin\r\n {$IFDEF MSWINDOWS}\r\n if LongPathBug then\r\n begin\r\n List := TStringList.Create;\r\n try\r\n StrToStrings(Paths, PathSep, List);\r\n for I := 0 to List.Count - 1 do\r\n List[I] := PathGetShortName(List[I]);\r\n Paths := StringsToStr(List, PathSep);\r\n finally\r\n List.Free;\r\n end;\r\n end;\r\n {$ENDIF MSWINDOWS}\r\n end;\r\n\r\nbegin\r\n S := PathRemoveSeparator(Path);\r\n ConvertToShortPathNames(S);\r\n { TODO : If we were sure that options are always case-insensitive\r\n for Borland tools, we could use UpperCase(Option) below. }\r\n S := Format('-%s\"%s\"', [Option, S]);\r\n // avoid duplicate entries\r\n if Options.IndexOf(S) = -1 then\r\n Options.Add(S);\r\nend;\r\n\r\nprocedure TJclBorlandCommandLineTool.CheckOutputValid;\r\nbegin\r\n if Assigned(FOutputCallback) then\r\n raise EJclCommandLineToolError.CreateResFmt(@RsECmdLineToolOutputInvalid, [GetExeName]);\r\nend;\r\n\r\nfunction TJclBorlandCommandLineTool.Execute(const CommandLine: string): Boolean;\r\nbegin\r\n if Assigned(FOnBeforeExecute) then\r\n FOnBeforeExecute(Self);\r\n\r\n Result := InternalExecute(CommandLine);\r\n\r\n if Assigned(FOnAfterExecute) then\r\n FOnAfterExecute(Self);\r\nend;\r\n\r\nfunction TJclBorlandCommandLineTool.GetExeName: string;\r\nbegin\r\n Result := '';\r\n {$IFDEF MSWINDOWS}\r\n raise EAbstractError.CreateResFmt(@SAbstractError, ['']); // BCB doesn't support abstract keyword\r\n {$ENDIF MSWINDOWS}\r\nend;\r\n\r\nfunction TJclBorlandCommandLineTool.GetFileName: string;\r\nbegin\r\n Result := BinDirectory + GetExeName;\r\n if Pos(' ', Result) > 0 then\r\n Result := AnsiQuotedStr(Result, '\"');\r\nend;\r\n\r\nfunction TJclBorlandCommandLineTool.GetOptions: TStrings;\r\nbegin\r\n Result := FOptions;\r\nend;\r\n\r\nfunction TJclBorlandCommandLineTool.GetOutput: string;\r\nbegin\r\n CheckOutputValid;\r\n Result := FOutput;\r\nend;\r\n\r\nfunction TJclBorlandCommandLineTool.GetOutputCallback: TTextHandler;\r\nbegin\r\n Result := FOutputCallback;\r\nend;\r\n\r\nfunction TJclBorlandCommandLineTool.InternalExecute(\r\n const CommandLine: string): Boolean;\r\nvar\r\n LaunchCommand: string;\r\nbegin\r\n LaunchCommand := Format('%s %s', [FileName, StrAnsiToOem(AnsiString(CommandLine))]);\r\n if Assigned(FOutputCallback) then\r\n begin\r\n FOutputCallback(LaunchCommand);\r\n Result := JclSysUtils.Execute(LaunchCommand, OemTextHandler) = 0;\r\n end\r\n else\r\n begin\r\n Result := JclSysUtils.Execute(LaunchCommand, FOutput) = 0;\r\n {$IFDEF MSWINDOWS}\r\n FOutput := string(StrOemToAnsi(AnsiString(FOutput)));\r\n {$ENDIF MSWINDOWS}\r\n end;\r\nend;\r\n\r\nprocedure TJclBorlandCommandLineTool.OemTextHandler(const Text: string);\r\nvar\r\n AnsiText: string;\r\nbegin\r\n if Assigned(FOutputCallback) then\r\n begin\r\n {$IFDEF MSWINDOWS}\r\n // Text is OEM under Windows\r\n // Code below seems to crash older compilers at times, so we only do\r\n // the casts when it's absolutely necessary, that is when compiling\r\n // with a unicode compiler.\r\n {$IFDEF UNICODE}\r\n AnsiText := string(StrOemToAnsi(AnsiString(Text)));\r\n {$ELSE}\r\n AnsiText := StrOemToAnsi(Text);\r\n {$ENDIF UNICODE}\r\n {$ELSE ~MSWINDOWS}\r\n AnsiText := Text;\r\n {$ENDIF ~MSWINDOWS}\r\n FOutputCallback(AnsiText);\r\n end;\r\nend;\r\n\r\nprocedure TJclBorlandCommandLineTool.SetOutputCallback(const CallbackMethod: TTextHandler);\r\nbegin\r\n FOutputCallback := CallbackMethod;\r\nend;\r\n\r\n//=== { TJclBCC32 } ============================================================\r\n\r\nfunction TJclBCC32.GetExeName: string;\r\nbegin\r\n Result := BCC32ExeName;\r\nend;\r\n\r\nclass function TJclBCC32.GetPlatform: string;\r\nbegin\r\n Result := BDSPlatformWin32;\r\nend;\r\n\r\n//=== { TJclBCC64 } ============================================================\r\n\r\nfunction TJclBCC64.GetExeName: string;\r\nbegin\r\n Result := BCC64ExeName;\r\nend;\r\n\r\nclass function TJclBCC64.GetPlatform: string;\r\nbegin\r\n Result := BDSPlatformWin64;\r\nend;\r\n\r\n//=== { TJclDCC32 } ============================================================\r\n\r\nfunction TJclDCC32.AddDProjOptions(const ProjectFileName: string; var ProjectOptions: TProjectOptions): Boolean;\r\nvar\r\n DProjFileName, PersonalityName: string;\r\n MsBuildOptions: TJclMsBuildParser;\r\n ProjectExtensionsNode, PersonalityNode: TJclSimpleXMLElem;\r\nbegin\r\n DProjFileName := ChangeFileExt(ProjectFileName, SourceExtensionDProject);\r\n Result := FileExists(DProjFileName) and (CompilerSettingsFormat = csfMsBuild);\r\n if Result then\r\n begin\r\n MsBuildOptions := TJclMsBuildParser.Create(DProjFileName);\r\n try\r\n MsBuildOptions.Init;\r\n if SupportsPlatform then\r\n MsBuildOptions.Properties.GlobalProperties.Values['Platform'] := GetPlatform;\r\n\r\n if Assigned(FOnEnvironmentVariables) then\r\n MsBuildOptions.Properties.EnvironmentProperties.Assign(FOnEnvironmentVariables);\r\n\r\n MsBuildOptions.Parse;\r\n\r\n PersonalityName := '';\r\n ProjectExtensionsNode := MsBuildOptions.ProjectExtensions;\r\n if Assigned(ProjectExtensionsNode) then\r\n begin\r\n PersonalityNode := ProjectExtensionsNode.Items.ItemNamed[DProjPersonalityNodeName];\r\n if Assigned(PersonalityNode) then\r\n PersonalityName := PersonalityNode.Value;\r\n end;\r\n if StrHasPrefix(PersonalityName, [DProjDelphiPersonalityValue]) or\r\n AnsiSameText(PersonalityName, DProjDelphiDotNetPersonalityValue) then\r\n begin\r\n ProjectOptions.DynamicPackages := MsBuildOptions.Properties.Values[DProjUsePackageNodeName];\r\n ProjectOptions.UsePackages := ProjectOptions.DynamicPackages <> '';\r\n ProjectOptions.UnitOutputDir := MsBuildOptions.Properties.Values[DProjDcuOutputDirNodeName];\r\n ProjectOptions.SearchPath := MsBuildOptions.Properties.Values[DProjUnitSearchPathNodeName];\r\n ProjectOptions.Conditionals := MsBuildOptions.Properties.Values[DProjDefineNodeName];\r\n ProjectOptions.Namespace := MsBuildOptions.Properties.Values[DProjNamespaceNodeName];\r\n end;\r\n finally\r\n MsBuildOptions.Free;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJclDCC32.AddBDSProjOptions(const ProjectFileName: string; var ProjectOptions: TProjectOptions): Boolean;\r\nvar\r\n BDSProjFileName, PersonalityName: string;\r\n OptionsXmlFile: TJclSimpleXML;\r\n PersonalityInfoNode, OptionNode, ChildNode, PersonalityNode, DirectoriesNode: TJclSimpleXMLElem;\r\n NodeIndex: Integer;\r\n NameProperty: TJclSimpleXMLProp;\r\nbegin\r\n BDSProjFileName := ChangeFileExt(ProjectFileName, SourceExtensionBDSProject);\r\n Result := FileExists(BDSProjFileName);\r\n if Result then\r\n begin\r\n OptionsXmlFile := TJclSimpleXML.Create;\r\n try\r\n OptionsXmlFile.LoadFromFile(BDSProjFileName);\r\n OptionsXmlFile.Options := OptionsXmlFile.Options - [sxoAutoCreate];\r\n PersonalityInfoNode := OptionsXmlFile.Root.Items.ItemNamed[BDSProjPersonalityInfoNodeName];\r\n PersonalityName := '';\r\n if Assigned(PersonalityInfoNode) then\r\n begin\r\n OptionNode := PersonalityInfoNode.Items.ItemNamed[BDSProjOptionNodeName];\r\n if Assigned(OptionNode) then\r\n for NodeIndex := 0 to OptionNode.Items.Count - 1 do\r\n begin\r\n ChildNode := OptionNode.Items.Item[NodeIndex];\r\n if SameText(ChildNode.Name, BDSProjOptionNodeName) then\r\n begin\r\n NameProperty := ChildNode.Properties.ItemNamed[BDSProjNameProperty];\r\n if Assigned(NameProperty) and SameText(NameProperty.Value, BDSProjPersonalityValue) then\r\n begin\r\n PersonalityName := ChildNode.Value;\r\n Break;\r\n end;\r\n end;\r\n end;\r\n end;\r\n if PersonalityName <> '' then\r\n begin\r\n PersonalityNode := OptionsXmlFile.Root.Items.ItemNamed[PersonalityName];\r\n if Assigned(PersonalityNode) then\r\n begin\r\n DirectoriesNode := PersonalityNode.Items.ItemNamed[BDSProjDirectoriesNodeName];\r\n if Assigned(DirectoriesNode) then\r\n for NodeIndex := 0 to DirectoriesNode.Items.Count - 1 do\r\n begin\r\n ChildNode := DirectoriesNode.Items.Item[NodeIndex];\r\n if SameText(ChildNode.Name, BDSProjDirectoriesNodeName) then\r\n begin\r\n NameProperty := ChildNode.Properties.ItemNamed[BDSProjNameProperty];\r\n if Assigned(NameProperty) then\r\n begin\r\n if SameText(NameProperty.Value, BDSProjUnitOutputDirValue) then\r\n ProjectOptions.UnitOutputDir := ChildNode.Value\r\n else\r\n if SameText(NameProperty.Value, BDSProjSearchPathValue) then\r\n ProjectOptions.SearchPath := ChildNode.Value\r\n else\r\n if SameText(NameProperty.Value, BDSProjPackagesValue) then\r\n ProjectOptions.DynamicPackages := ChildNode.Value\r\n else\r\n if SameText(NameProperty.Value, BDSProjConditionalsValue) then\r\n ProjectOptions.Conditionals := ChildNode.Value\r\n else\r\n if SameText(NameProperty.Value, BDSProjUsePackagesValue) then\r\n ProjectOptions.UsePackages := StrToBoolean(ChildNode.Value);\r\n ProjectOptions.Namespace := '';\r\n end;\r\n end;\r\n end;\r\n end;\r\n end;\r\n finally\r\n OptionsXmlFile.Free;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJclDCC32.AddDOFOptions(const ProjectFileName: string; var ProjectOptions: TProjectOptions): Boolean;\r\nvar\r\n DOFFileName: string;\r\n OptionsFile: TIniFile;\r\nbegin\r\n DOFFileName := ChangeFileExt(ProjectFileName, SourceExtensionDOFProject);\r\n Result := FileExists(DOFFileName);\r\n if Result then\r\n begin\r\n OptionsFile := TIniFile.Create(DOFFileName);\r\n try\r\n ProjectOptions.SearchPath := OptionsFile.ReadString(DOFDirectoriesSection, DOFSearchPathName, '');\r\n ProjectOptions.UnitOutputDir := OptionsFile.ReadString(DOFDirectoriesSection, DOFUnitOutputDirKey, '');\r\n ProjectOptions.Conditionals := OptionsFile.ReadString(DOFDirectoriesSection, DOFConditionals, '');\r\n ProjectOptions.UsePackages := OptionsFile.ReadString(DOFCompilerSection, DOFPackageNoLinkKey, '') = '1';\r\n ProjectOptions.DynamicPackages := OptionsFile.ReadString(DOFLinkerSection, DOFPackagesKey, '');\r\n ProjectOptions.Namespace := '';\r\n finally\r\n OptionsFile.Free;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJclDCC32.AddProjectOptions(const ProjectFileName, DCPPath: string);\r\nvar\r\n ProjectOptions: TProjectOptions;\r\nbegin\r\n ProjectOptions.UsePackages := False;\r\n ProjectOptions.UnitOutputDir := '';\r\n ProjectOptions.SearchPath := '';\r\n ProjectOptions.DynamicPackages := '';\r\n ProjectOptions.SearchDcpPath := '';\r\n ProjectOptions.Conditionals := '';\r\n ProjectOptions.Namespace := '';\r\n\r\n if AddDProjOptions(ProjectFileName, ProjectOptions) or\r\n AddBDSProjOptions(ProjectFileName, ProjectOptions) or\r\n AddDOFOptions(ProjectFileName, ProjectOptions) then\r\n begin\r\n if ProjectOptions.UnitOutputDir <> '' then\r\n AddPathOption('N', ProjectOptions.UnitOutputDir);\r\n if ProjectOptions.SearchPath <> '' then\r\n begin\r\n AddPathOption('I', ProjectOptions.SearchPath);\r\n AddPathOption('R', ProjectOptions.SearchPath);\r\n end;\r\n if ProjectOptions.Conditionals <> '' then\r\n Options.Add(Format('-D%s', [ProjectOptions.Conditionals]));\r\n if SamePath(DCPPath, DCPSearchPath) then\r\n ProjectOptions.SearchDcpPath := DCPPath\r\n else\r\n ProjectOptions.SearchDcpPath := StrEnsureSuffix(PathSep, DCPPath) + DCPSearchPath;\r\n AddPathOption('U', StrEnsureSuffix(PathSep, ProjectOptions.SearchDcpPath) + ProjectOptions.SearchPath);\r\n if ProjectOptions.UsePackages and (ProjectOptions.DynamicPackages <> '') then\r\n Options.Add(Format('-LU\"%s\"', [ProjectOptions.DynamicPackages]));\r\n if ProjectOptions.Namespace <> '' then\r\n Options.Add('-ns' + ProjectOptions.Namespace);\r\n end;\r\nend;\r\n\r\nfunction TJclDCC32.Compile(const ProjectFileName: string): Boolean;\r\nbegin\r\n // Note: PathGetShortName may not return the short path if it's a network\r\n // drive. Hence we always double quote the path, regardless of the compiling\r\n // environment.\r\n Result := Execute(StrDoubleQuote(StrTrimQuotes(ProjectFileName)));\r\nend;\r\n\r\nconstructor TJclDCC32.Create(const ABinDirectory: string; ALongPathBug: Boolean;\r\n ACompilerSettingsFormat: TJclCompilerSettingsFormat; ASupportsNoConfig, ASupportsPlatform: Boolean;\r\n const ADCPSearchPath, ALibrarySearchPath, ALibraryDebugSearchPath, ACppSearchPath: string);\r\nbegin\r\n inherited Create(ABinDirectory, ALongPathBug, ACompilerSettingsFormat);\r\n FSupportsNoConfig := ASupportsNoConfig;\r\n FSupportsPlatform := ASupportsPlatform;\r\n FDCPSearchPath := ADCPSearchPath;\r\n FLibrarySearchPath := ALibrarySearchPath;\r\n FLibraryDebugSearchPath := ALibraryDebugSearchPath;\r\n FCppSearchPath := ACppSearchPath;\r\n SetDefaultOptions(False); // in case $(DELPHI)\\bin\\dcc32.cfg (replace as appropriate) is invalid\r\nend;\r\n\r\nfunction TJclDCC32.Execute(const CommandLine: string): Boolean;\r\n function IsPathOption(const S: string; out Len: Integer): Boolean;\r\n begin\r\n Result := False;\r\n if (Length(S) >= 2) and (S[1] = '-') then\r\n case UpCase(S[2]) of\r\n 'E', 'I', 'O', 'R', 'U':\r\n begin\r\n Result := True;\r\n Len := 2;\r\n end;\r\n 'L':\r\n if Length(S) >= 3 then\r\n begin\r\n case UpCase(S[3]) of\r\n 'E', 'e',\r\n 'N', 'n':\r\n Result := True;\r\n else\r\n Result := False;\r\n end;\r\n Len := 3;\r\n end;\r\n 'N':\r\n begin\r\n Result := True;\r\n if (Length(S) >= 3) then\r\n begin\r\n case Upcase(S[3]) of\r\n '0'..'9',\r\n 'H', 'O', 'B':\r\n Len := 3;\r\n else\r\n Len := 2;\r\n end;\r\n end;\r\n end;\r\n end;\r\n end;\r\nvar\r\n OptionIndex, PathIndex, SwitchLen: Integer;\r\n PathList: TStrings;\r\n Option, Arguments, CurrentFolder: string;\r\nbegin\r\n if Assigned(FOnBeforeExecute) then\r\n FOnBeforeExecute(Self);\r\n\r\n FOutput := '';\r\n Arguments := '';\r\n CurrentFolder := GetCurrentFolder;\r\n\r\n PathList := TStringList.Create;\r\n try\r\n for OptionIndex := 0 to Options.Count - 1 do\r\n begin\r\n Option := Options.Strings[OptionIndex];\r\n if IsPathOption(Option, SwitchLen) then\r\n begin\r\n StrToStrings(StrTrimQuotes(Copy(Option, SwitchLen + 1, Length(Option) - SwitchLen)), PathSep, PathList);\r\n if LongPathBug then\r\n // change to relative paths to avoid DCC32 126 character path limit\r\n for PathIndex := 0 to PathList.Count - 1 do\r\n PathList.Strings[PathIndex] := PathGetRelativePath(CurrentFolder, ExpandFileName(PathList[PathIndex]));\r\n if PathList.Count > 0 then\r\n Arguments := Format('%s %s\"%s\"', [Arguments, Copy(Option, 1, SwitchLen),\r\n StringsToStr(PathList, PathSep)]);\r\n end\r\n else\r\n Arguments := Format('%s %s', [Arguments, Option]);\r\n end;\r\n finally\r\n PathList.Free;\r\n end;\r\n\r\n Result := InternalExecute(CommandLine + Arguments);\r\n\r\n if Assigned(FOnAfterExecute) then\r\n FOnAfterExecute(Self);\r\nend;\r\n\r\nfunction TJclDCC32.GetExeName: string;\r\nbegin\r\n Result := DCC32ExeName;\r\nend;\r\n\r\nclass function TJclDCC32.GetPlatform: string;\r\nbegin\r\n Result := BDSPlatformWin32;\r\nend;\r\n\r\nfunction TJclDCC32.MakePackage(const PackageName, BPLPath, DCPPath: string; ExtraOptions: string = ''; ADebug: Boolean = False): Boolean;\r\nvar\r\n SaveDir: string;\r\n ConfigurationFileName, BackupFileName: string;\r\nbegin\r\n SaveDir := GetCurrentDir;\r\n SetCurrentDir(ExtractFilePath(PackageName) + '.');\r\n try\r\n // backup existing configuration file, if any\r\n ConfigurationFileName := ChangeFileExt(PackageName, SourceExtensionConfiguration);\r\n if FileExists(ConfigurationFileName) then\r\n FileBackup(ConfigurationFileName, True);\r\n\r\n Options.Clear;\r\n SetDefaultOptions(ADebug);\r\n AddProjectOptions(PackageName, DCPPath);\r\n try\r\n AddPathOption('LN', DCPPath);\r\n AddPathOption('LE', BPLPath);\r\n Options.Add(ExtraOptions);\r\n Result := Compile(PackageName);\r\n finally\r\n // restore existing configuration file, if any\r\n BackupFileName := GetBackupFileName(ConfigurationFileName);\r\n if FileExists(BackupFileName) then\r\n FileMove(BackupFileName, ConfigurationFileName, True);\r\n end;\r\n finally\r\n SetCurrentDir(SaveDir);\r\n end;\r\nend;\r\n\r\nfunction TJclDCC32.MakeProject(const ProjectName, OutputDir, DcpSearchPath: string;\r\n ExtraOptions: string = ''; ADebug: Boolean = False): Boolean;\r\nvar\r\n SaveDir: string;\r\n ConfigurationFileName, BackupFileName: string;\r\nbegin\r\n SaveDir := GetCurrentDir;\r\n SetCurrentDir(ExtractFilePath(ProjectName) + '.');\r\n try\r\n // backup existing configuration file, if any\r\n ConfigurationFileName := ChangeFileExt(ProjectName, SourceExtensionConfiguration);\r\n if FileExists(ConfigurationFileName) then\r\n FileBackup(ConfigurationFileName, True);\r\n\r\n Options.Clear;\r\n SetDefaultOptions(ADebug);\r\n AddProjectOptions(ProjectName, DcpSearchPath);\r\n try\r\n AddPathOption('E', OutputDir);\r\n Options.Add(ExtraOptions);\r\n Result := Compile(ProjectName);\r\n finally\r\n // restore existing configuration file, if any\r\n BackupFileName := GetBackupFileName(ConfigurationFileName);\r\n if FileExists(BackupFileName) then\r\n FileMove(BackupFileName, ConfigurationFileName, True);\r\n end;\r\n finally\r\n SetCurrentDir(SaveDir);\r\n end;\r\nend;\r\n\r\nprocedure TJclDCC32.SetDefaultOptions(ADebug: Boolean);\r\nbegin\r\n Options.Clear;\r\n if SupportsNoConfig then\r\n Options.Add('--no-config');\r\n if ADebug then\r\n AddPathOption('U', LibraryDebugSearchPath);\r\n AddPathOption('U', LibrarySearchPath);\r\n if CppSearchPath <> '' then\r\n begin\r\n AddPathOption('U', CppSearchPath);\r\n Options.Add('-LUrtl');\r\n end;\r\nend;\r\n\r\n//=== { TJclDCC64 } ==========================================================\r\n\r\nclass function TJclDCC64.GetPlatform: string;\r\nbegin\r\n Result := BDSPlatformWin64;\r\nend;\r\n\r\nfunction TJclDCC64.GetExeName: string;\r\nbegin\r\n Result := DCC64ExeName;\r\nend;\r\n\r\n//=== { TJclDCCOSX32 } =======================================================\r\n\r\nclass function TJclDCCOSX32.GetPlatform: string;\r\nbegin\r\n Result := BDSPlatformOSX32;\r\nend;\r\n\r\nfunction TJclDCCOSX32.GetExeName: string;\r\nbegin\r\n Result := DCCOSX32ExeName;\r\nend;\r\n\r\n{$IFDEF MSWINDOWS}\r\n//=== { TJclDCCIL } ==========================================================\r\n\r\nfunction TJclDCCIL.GetExeName: string;\r\nbegin\r\n Result := DCCILExeName;\r\nend;\r\n\r\nfunction TJclDCCIL.GetMaxCLRVersion: string;\r\nvar\r\n StartPos, EndPos: Integer;\r\nbegin\r\n if FMaxCLRVersion <> '' then\r\n begin\r\n Result := FMaxCLRVersion;\r\n Exit;\r\n end;\r\n\r\n Result := FindResStart(BinDirectory + GetExeName, ' --clrversion');\r\n\r\n StartPos := Pos(':', Result);\r\n if StartPos = 0 then\r\n StartPos := Pos('=', Result);\r\n\r\n if StartPos > 0 then\r\n Result := Copy(Result, StartPos + 1, Length(Result) - StartPos);\r\n\r\n EndPos := Pos(' ', Result);\r\n if EndPos > 0 then\r\n SetLength(Result, EndPos - 1);\r\n\r\n if Result = '' then\r\n Result := 'v1.1.4322'; // do not localize\r\n\r\n FMaxCLRVersion := Result;\r\nend;\r\n\r\nfunction TJclDCCIL.MakeProject(const ProjectName, OutputDir,\r\n ExtraOptions: string; ADebug: Boolean = False): Boolean;\r\nvar\r\n SaveDir: string;\r\nbegin\r\n SaveDir := GetCurrentDir;\r\n SetCurrentDir(ExtractFilePath(ProjectName) + '.');\r\n try\r\n Options.Clear;\r\n SetDefaultOptions(ADebug);\r\n AddProjectOptions(ProjectName, '');\r\n AddPathOption('E', OutputDir);\r\n Options.Add(ExtraOptions);\r\n Result := Compile(ProjectName);\r\n finally\r\n SetCurrentDir(SaveDir);\r\n end;\r\nend;\r\n\r\nprocedure TJclDCCIL.SetDefaultOptions(ADebug: Boolean);\r\nbegin\r\n Options.Clear;\r\n if ADebug then\r\n AddPathOption('U', LibraryDebugSearchPath);\r\n AddPathOption('U', LibrarySearchPath);\r\nend;\r\n\r\n{$ENDIF MSWINDOWS}\r\n\r\n//=== { TJclBorlandMake } ====================================================\r\n\r\nfunction TJclBorlandMake.GetExeName: string;\r\nbegin\r\n Result := MakeExeName;\r\nend;\r\n\r\n//=== { TJclBpr2Mak } ========================================================\r\n\r\nfunction TJclBpr2Mak.GetExeName: string;\r\nbegin\r\n Result := Bpr2MakExeName;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n\r\n" }, { "path": "External/Jedi/Jcl/source/common/JclComplex.pas", "content": "{**************************************************************************************************}\r\n{ }\r\n{ Project JEDI Code Library (JCL) }\r\n{ }\r\n{ The contents of this file are subject to the Mozilla Public License Version 1.1 (the \"License\"); }\r\n{ you may not use this file except in compliance with the License. You may obtain a copy of the }\r\n{ License at http://www.mozilla.org/MPL/ }\r\n{ }\r\n{ Software distributed under the License is distributed on an \"AS IS\" basis, WITHOUT WARRANTY OF }\r\n{ ANY KIND, either express or implied. See the License for the specific language governing rights }\r\n{ and limitations under the License. }\r\n{ }\r\n{ The Original Code is JclComplex.pas. }\r\n{ }\r\n{ The Initial Developer of the Original Code is Alexei Koudinov. Portions created by }\r\n{ Alexei Koudinov are Copyright (C) of Alexei Koudinov. All Rights Reserved. } \r\n{ }\r\n{ Contributor(s): }\r\n{ Marcel van Brakel }\r\n{ Alexei Koudinov }\r\n{ Robert Marquardt (marquardt) }\r\n{ Robert Rossmair (rrossmair) }\r\n{ Matthias Thoma (mthoma) }\r\n{ Petr Vones (pvones) } \r\n{ }\r\n{**************************************************************************************************}\r\n{ }\r\n{ Class for working with complex numbers. }\r\n{ }\r\n{**************************************************************************************************}\r\n{ }\r\n{ Last modified: $Date:: 2011-09-03 00:07:50 +0200 (sam. 03 sept. 2011) $ }\r\n{ Revision: $Rev:: 3599 $ }\r\n{ Author: $Author:: outchy $ }\r\n{ }\r\n{**************************************************************************************************}\r\n\r\nunit JclComplex;\r\n\r\n{$I jcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n {$IFDEF HAS_UNITSCOPE}\r\n System.SysUtils,\r\n {$ELSE ~HAS_UNITSCOPE}\r\n SysUtils,\r\n {$ENDIF ~HAS_UNITSCOPE}\r\n JclBase, JclMath, JclResources, JclStrings;\r\n\r\nconst\r\n TComplex_VERSION = 5.01;\r\n\r\ntype\r\n TComplexKind = (crRectangular, crPolar);\r\n\r\n TCoords = record\r\n X: Float; // rectangular real\r\n Y: Float; // rectangular imaginary\r\n R: Float; // polar radius\r\n Theta: Float; // polar angle\r\n end;\r\n\r\n TRectCoord = record\r\n X: Float;\r\n Y: Float;\r\n end;\r\n\r\n TJclComplex = class(TObject)\r\n private {z = x + yi}\r\n FCoord: TCoords;\r\n FFracLen: Byte;\r\n function MiscalcFloat(const X: Float): Float;\r\n procedure MiscalcComplex; // eliminates miscalculation\r\n procedure FillCoords(const ComplexType: TComplexKind);\r\n function GetRectangularString: string;\r\n function GetPolarString: string;\r\n procedure SetRectangularString(StrToParse: string);\r\n procedure SetPolarString(StrToParse: string);\r\n procedure SetFracLen(const X: Byte);\r\n function GetRadius: Float;\r\n function GetAngle: Float;\r\n function NormalizeAngle(const Value: Float): Float;\r\n protected\r\n function Assign(const Coord: TCoords; const ComplexType: TComplexKind = crRectangular): TJclComplex; overload;\r\n function CoreAdd(const First, Second: TRectCoord): TRectCoord;\r\n function CoreDiv(const First, Second: TRectCoord): TRectCoord;\r\n function CoreMul(const First, Second: TRectCoord): TRectCoord;\r\n function CoreSub(const First, Second: TRectCoord): TRectCoord;\r\n function CoreLn (const LnValue: TRectCoord): TRectCoord;\r\n function CoreExp(const ExpValue: TRectCoord): TRectCoord;\r\n function CorePwr(First, Second, Polar: TRectCoord): TRectCoord;\r\n function CoreIntPwr(First: TRectCoord; const Polar: TRectCoord; const Pwr: Integer): TRectCoord;\r\n function CoreRealPwr(First: TRectCoord; const Polar: TRectCoord; const Pwr: Float): TRectCoord;\r\n function CoreRoot(First: TRectCoord; const Polar: TRectCoord; const K, N: Word): TRectCoord;\r\n function CoreCos(const Value: TRectCoord): TRectCoord;\r\n function CoreSin(const Value: TRectCoord): TRectCoord;\r\n function CoreTan(const Value: TRectCoord): TRectCoord;\r\n function CoreCot(const Value: TRectCoord): TRectCoord;\r\n function CoreSec(const Value: TRectCoord): TRectCoord;\r\n function CoreCsc(const Value: TRectCoord): TRectCoord;\r\n function CoreCosH(const Value: TRectCoord): TRectCoord;\r\n function CoreSinH(const Value: TRectCoord): TRectCoord;\r\n function CoreTanH(const Value: TRectCoord): TRectCoord;\r\n function CoreCotH(const Value: TRectCoord): TRectCoord;\r\n function CoreSecH(const Value: TRectCoord): TRectCoord;\r\n function CoreCscH(const Value: TRectCoord): TRectCoord;\r\n function CoreI0(const Value: TRectCoord): TRectCoord;\r\n function CoreJ0(const Value: TRectCoord): TRectCoord;\r\n function CoreApproxLnGamma(const Value: TRectCoord): TRectCoord;\r\n function CoreLnGamma(Value: TRectCoord): TRectCoord;\r\n function CoreGamma(const Value: TRectCoord): TRectCoord;\r\n public\r\n //----------- constructors\r\n constructor Create; overload;\r\n constructor Create(const X, Y: Float; const ComplexType: TComplexKind = crRectangular); overload;\r\n\r\n //----------- complex numbers assignment routines\r\n function Assign(const X, Y: Float; const ComplexType: TComplexKind = crRectangular): TJclComplex; overload;\r\n function AssignZero: TJclComplex;\r\n function AssignOne: TJclComplex;\r\n function Duplicate: TJclComplex;\r\n\r\n //----------- arithmetics -- modify the object itself\r\n function CAdd(const AddValue: TJclComplex): TJclComplex; overload;\r\n function CAdd(const X, Y: Float; const ComplexType: TComplexKind = crRectangular): TJclComplex; overload;\r\n function CDiv(const DivValue: TJclComplex): TJclComplex; overload;\r\n function CDiv(const X, Y: Float; const ComplexType: TComplexKind = crRectangular): TJclComplex; overload;\r\n function CMul(const MulValue: TJclComplex): TJclComplex; overload;\r\n function CMul(const X, Y: Float; const ComplexType: TComplexKind = crRectangular): TJclComplex; overload;\r\n function CSub(const SubValue: TJclComplex): TJclComplex; overload;\r\n function CSub(const X, Y: Float; const ComplexType: TComplexKind = crRectangular): TJclComplex; overload;\r\n function CNeg: TJclComplex;\r\n function CConjugate: TJclComplex;\r\n\r\n //----------- arithmetics -- creates new resulting object\r\n function CNewAdd(const AddValue: TJclComplex): TJclComplex; overload;\r\n function CNewAdd(const X, Y: Float; const ComplexType: TComplexKind = crRectangular): TJclComplex; overload;\r\n function CNewDiv(const DivValue: TJclComplex): TJclComplex; overload;\r\n function CNewDiv(const X, Y: Float; const ComplexType: TComplexKind = crRectangular): TJclComplex; overload;\r\n function CNewMul(const MulValue: TJclComplex): TJclComplex; overload;\r\n function CNewMul(const X, Y: Float; const ComplexType: TComplexKind = crRectangular): TJclComplex; overload;\r\n function CNewSub(const SubValue: TJclComplex): TJclComplex; overload;\r\n function CNewSub(const X, Y: Float; const ComplexType: TComplexKind = crRectangular): TJclComplex; overload;\r\n function CNewNeg: TJclComplex;\r\n function CNewConjugate: TJclComplex;\r\n\r\n //----------- natural log and exponential functions -- modify the object itself\r\n function CLn: TJclComplex;\r\n function CExp: TJclComplex;\r\n function CPwr(const PwrValue: TJclComplex): TJclComplex; overload;\r\n function CPwr(const X, Y: Float; const ComplexType: TComplexKind = crRectangular): TJclComplex; overload;\r\n function CIntPwr(const Pwr: Integer): TJclComplex;\r\n function CRealPwr(const Pwr: Float): TJclComplex;\r\n function CRoot(const K, N: Word): TJclComplex;\r\n function CSqrt: TJclComplex;\r\n\r\n //----------- natural log and exponential functions -- create new resulting object\r\n function CNewLn: TJclComplex;\r\n function CNewExp: TJclComplex;\r\n function CNewPwr(PwrValue: TJclComplex): TJclComplex; overload;\r\n function CNewPwr(const X, Y: Float; const ComplexType: TComplexKind = crRectangular): TJclComplex; overload;\r\n function CNewIntPwr(const Pwr: Integer): TJclComplex;\r\n function CNewRealPwr(const Pwr: Float): TJclComplex;\r\n function CNewRoot(const K, N: Word): TJclComplex;\r\n function CNewSqrt: TJclComplex;\r\n\r\n //----------- trigonometric functions -- modify the object itself\r\n function CCos: TJclComplex;\r\n function CSin: TJclComplex;\r\n function CTan: TJclComplex;\r\n function CCot: TJclComplex;\r\n function CSec: TJclComplex;\r\n function CCsc: TJclComplex;\r\n\r\n //----------- trigonometric functions -- create new resulting object\r\n function CNewCsc: TJclComplex;\r\n function CNewCos: TJclComplex;\r\n function CNewSin: TJclComplex;\r\n function CNewTan: TJclComplex;\r\n function CNewCot: TJclComplex;\r\n function CNewSec: TJclComplex;\r\n\r\n //----------- complex hyperbolic functions -- modify the object itself\r\n function CCosH: TJclComplex;\r\n function CSinH: TJclComplex;\r\n function CTanH: TJclComplex;\r\n function CCotH: TJclComplex;\r\n function CSecH: TJclComplex;\r\n function CCscH: TJclComplex;\r\n\r\n //----------- complex hyperbolic functions -- create new resulting object\r\n function CNewCosH: TJclComplex;\r\n function CNewSinH: TJclComplex;\r\n function CNewTanH: TJclComplex;\r\n function CNewCotH: TJclComplex;\r\n function CNewSecH: TJclComplex;\r\n function CNewCscH: TJclComplex;\r\n\r\n //----------- complex Bessel functions of order zero -- modify the object itself\r\n function CI0: TJclComplex;\r\n function CJ0: TJclComplex;\r\n\r\n //----------- complex Bessel functions of order zero -- create new resulting object\r\n function CNewI0: TJclComplex;\r\n function CNewJ0: TJclComplex;\r\n\r\n //----------- complex Gamma functions -- modify the object itself\r\n function CApproxLnGamma: TJclComplex;\r\n function CLnGamma: TJclComplex;\r\n function CGamma: TJclComplex;\r\n\r\n //----------- complex Gamma functions -- create new resulting object\r\n function CNewApproxLnGamma: TJclComplex;\r\n function CNewLnGamma: TJclComplex;\r\n function CNewGamma: TJclComplex;\r\n\r\n //----------- miscellaneous routines\r\n function AbsoluteValue: Float; overload;\r\n function AbsoluteValue(const Coord: TRectCoord): Float; overload;\r\n function AbsoluteValueSqr: Float; overload;\r\n function AbsoluteValueSqr(const Coord: TRectCoord): Float; overload;\r\n function FormatExtended(const X: Float): string;\r\n\r\n property FracLength: Byte read FFracLen write SetFracLen default 8;\r\n\r\n //----------- getting different parts of the number\r\n property RealPart: Float read FCoord.X;\r\n property ImaginaryPart: Float read FCoord.Y;\r\n property Radius: Float read GetRadius;\r\n property Angle: Float read GetAngle;\r\n\r\n //----------- format output\r\n property AsString: string read GetRectangularString write SetRectangularString;\r\n property AsPolarString: string read GetPolarString write SetPolarString;\r\n end;\r\n\r\nvar\r\n ComplexPrecision: Float = 1E-14;\r\n\r\nconst\r\n MaxTerm: Byte = 35;\r\n EpsilonSqr: Float = 1E-20;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jcl.svn.sourceforge.net/svnroot/jcl/tags/JCL-2.4-Build4571/jcl/source/common/JclComplex.pas $';\r\n Revision: '$Revision: 3599 $';\r\n Date: '$Date: 2011-09-03 00:07:50 +0200 (sam. 03 sept. 2011) $';\r\n LogPath: 'JCL\\source\\common';\r\n Extra: '';\r\n Data: nil\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nconst\r\n MaxFracLen = 18;\r\n RectOne: TRectCoord = (X: 1.0; Y: 0.0);\r\n RectZero: TRectCoord = (X: 0.0; Y: 0.0);\r\n RectInfinity: TRectCoord = (X: Infinity; Y: Infinity);\r\n\r\nfunction Coordinates(const cX, cY: Float; CoordType: TComplexKind): TCoords;\r\nbegin\r\n case CoordType of\r\n crRectangular:\r\n begin\r\n Result.X := cX;\r\n Result.Y := cY;\r\n Result.R := 0.0;\r\n Result.Theta := 0.0;\r\n end;\r\n crPolar:\r\n begin\r\n Result.X := 0.0;\r\n Result.Y := 0.0;\r\n Result.R := cX;\r\n Result.Theta := cY;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction RectCoord(const X, Y: Float): TRectCoord; overload;\r\nbegin\r\n Result.X := X;\r\n Result.Y := Y;\r\nend;\r\n\r\nfunction RectCoord(Value: TJclComplex): TRectCoord; overload;\r\nbegin\r\n Result.X := Value.FCoord.X;\r\n Result.Y := Value.FCoord.Y;\r\nend;\r\n\r\n//=== { TJclComplex } ========================================================\r\n\r\nconstructor TJclComplex.Create;\r\nbegin\r\n inherited Create;\r\n AssignZero;\r\n FFracLen := MaxFracLen;\r\nend;\r\n\r\nconstructor TJclComplex.Create(const X, Y: Float; const ComplexType: TComplexKind);\r\nbegin\r\n inherited Create;\r\n Assign(X, Y, ComplexType);\r\n FFracLen := MaxFracLen;\r\nend;\r\n\r\nprocedure TJclComplex.FillCoords(const ComplexType: TComplexKind);\r\nbegin\r\n MiscalcComplex;\r\n case ComplexType of\r\n crPolar:\r\n begin\r\n FCoord.X := FCoord.R * JclMath.Cos(FCoord.Theta);\r\n FCoord.Y := FCoord.R * JclMath.Sin(FCoord.Theta);\r\n end;\r\n crRectangular:\r\n if FCoord.X = 0.0 then\r\n begin\r\n FCoord.R := Abs(FCoord.Y);\r\n FCoord.Theta := PiOn2 * Sgn(FCoord.Y);\r\n end\r\n else\r\n begin\r\n FCoord.R := AbsoluteValue;\r\n FCoord.Theta := System.ArcTan(FCoord.Y / FCoord.X);\r\n if FCoord.X < 0.0 then\r\n FCoord.Theta := FCoord.Theta + Pi * Sgn(FCoord.Y);\r\n end;\r\n end;\r\n MiscalcComplex;\r\nend;\r\n\r\nfunction TJclComplex.MiscalcFloat(const X: Float): Float;\r\nbegin\r\n Result := X;\r\n if Abs(Result) < ComplexPrecision then\r\n Result := 0.0;\r\nend;\r\n\r\nprocedure TJclComplex.MiscalcComplex; // eliminates miscalculation\r\nbegin\r\n FCoord.X := MiscalcFloat(FCoord.X);\r\n FCoord.Y := MiscalcFloat(FCoord.Y);\r\n FCoord.R := MiscalcFloat(FCoord.R);\r\n if FCoord.R = 0.0 then\r\n FCoord.Theta := 0.0\r\n else\r\n FCoord.Theta := MiscalcFloat(FCoord.Theta);\r\nend;\r\n\r\nfunction TJclComplex.Assign(const X, Y: Float; const ComplexType: TComplexKind): TJclComplex;\r\nbegin\r\n Result := Assign(Coordinates(X, Y, ComplexType), ComplexType);\r\nend;\r\n\r\nfunction TJclComplex.Assign(const Coord: TCoords; const ComplexType: TComplexKind): TJclComplex;\r\nbegin\r\n FCoord := Coord;\r\n FillCoords(ComplexType);\r\n MiscalcComplex;\r\n Result := Self;\r\nend;\r\n\r\nfunction TJclComplex.AssignZero: TJclComplex;\r\nbegin\r\n Result := Assign(0.0, 0.0, crRectangular);\r\nend;\r\n\r\nfunction TJclComplex.AssignOne: TJclComplex;\r\nbegin\r\n Result := Assign(1.0, 0.0, crRectangular);\r\nend;\r\n\r\nfunction TJclComplex.GetRectangularString: string;\r\nconst\r\n cImaginary = 'i';\r\nbegin\r\n MiscalcComplex;\r\n if (FCoord.X = 0.0) and (FCoord.Y = 0.0) then\r\n Result := '0'\r\n else\r\n if FCoord.X <> 0.0 then\r\n begin\r\n Result := FormatExtended(FCoord.X);\r\n if FCoord.Y > 0.0 then\r\n Result := Result + '+'\r\n else\r\n if FCoord.Y < 0.0 then\r\n Result := Result + '-';\r\n if FCoord.Y <> 0.0 then\r\n Result := Result + FormatExtended(Abs(FCoord.Y)) + cImaginary;\r\n end\r\n else\r\n Result := FormatExtended(FCoord.Y) + cImaginary;\r\nend;\r\n\r\nfunction TJclComplex.GetPolarString: string;\r\nbegin\r\n FillCoords(crRectangular);\r\n Result := FormatExtended(FCoord.R) + '*CIS(' + FormatExtended(FCoord.Theta) + ')';\r\nend;\r\n\r\nprocedure TJclComplex.SetRectangularString(StrToParse: string);\r\nvar\r\n SignPos: Integer;\r\n RealPart, ImagPart: Float;\r\nbegin\r\n StrToParse := StrRemoveChars(StrToParse, CharIsSpace);\r\n SignPos := StrFind('+', StrToParse, 2);\r\n if SignPos = 0 then\r\n SignPos := StrFind('-', StrToParse, 2);\r\n if SignPos > 0 then\r\n begin\r\n try\r\n RealPart := StrToFloat(Copy(StrToParse, 1, SignPos - 1));\r\n except\r\n raise EJclMathError.CreateRes(@RsComplexInvalidString);\r\n end;\r\n try\r\n ImagPart := StrToFloat(Copy(StrToParse, SignPos, Length(StrToParse) - SignPos));\r\n except\r\n raise EJclMathError.CreateRes(@RsComplexInvalidString);\r\n end;\r\n end\r\n else\r\n begin\r\n if (StrToParse[Length(StrToParse)] = 'i') or (StrToParse[Length(StrToParse)] = 'I') then\r\n begin\r\n RealPart := 0.0;\r\n try\r\n ImagPart := StrToFloat(Copy(StrToParse, 1, Length(StrToParse) - 1));\r\n except\r\n raise EJclMathError.CreateRes(@RsComplexInvalidString);\r\n end;\r\n end\r\n else\r\n begin\r\n try\r\n RealPart := StrToFloat(StrToParse);\r\n except\r\n raise EJclMathError.CreateRes(@RsComplexInvalidString);\r\n end;\r\n ImagPart := 0.0;\r\n end;\r\n end;\r\n Assign(RealPart, ImagPart, crRectangular);\r\nend;\r\n\r\nprocedure TJclComplex.SetPolarString(StrToParse: string);\r\nvar\r\n AstPos: Integer;\r\n Radius, Angle: Float;\r\nbegin\r\n StrToParse := AnsiUpperCase(StrRemoveChars(StrToParse, CharIsSpace));\r\n AstPos := Pos('*', StrToParse);\r\n if AstPos = 0 then\r\n raise EJclMathError.CreateRes(@RsComplexInvalidString);\r\n try\r\n Radius := StrToFloat(StrLeft(StrToParse, AstPos - 1));\r\n except\r\n raise EJclMathError.CreateRes(@RsComplexInvalidString);\r\n end;\r\n AstPos := Pos('(', StrToParse);\r\n if AstPos = 0 then\r\n raise EJclMathError.CreateRes(@RsComplexInvalidString);\r\n try\r\n Angle := StrToFloat(Copy(StrToParse, AstPos + 1, Length(StrToParse) - AstPos - 1));\r\n except\r\n raise EJclMathError.CreateRes(@RsComplexInvalidString);\r\n end;\r\n Assign(Radius, Angle, crPolar);\r\nend;\r\n\r\nfunction TJclComplex.Duplicate: TJclComplex;\r\nbegin\r\n Result := TJclComplex.Create(FCoord.X, FCoord.Y, crRectangular);\r\n Result.FFracLen := FFracLen;\r\nend;\r\n\r\n//=== arithmetics ============================================================\r\n\r\nfunction TJclComplex.CoreAdd(const First, Second: TRectCoord): TRectCoord;\r\nbegin\r\n Result.X := First.X + Second.X;\r\n Result.Y := First.Y + Second.Y;\r\nend;\r\n\r\nfunction TJclComplex.CAdd(const AddValue: TJclComplex): TJclComplex;\r\nvar\r\n ResCoord: TRectCoord;\r\nbegin\r\n ResCoord := CoreAdd(RectCoord(Self), RectCoord(AddValue));\r\n FCoord.X := ResCoord.X;\r\n FCoord.Y := ResCoord.Y;\r\n Result := Self;\r\nend;\r\n\r\nfunction TJclComplex.CAdd(const X, Y: Float; const ComplexType: TComplexKind): TJclComplex;\r\nvar\r\n NewComplex: TJclComplex;\r\nbegin\r\n NewComplex := TJclComplex.Create(X, Y, ComplexType);\r\n try\r\n Result := CAdd(NewComplex);\r\n finally\r\n NewComplex.Free;\r\n end;\r\nend;\r\n\r\nfunction TJclComplex.CNewAdd(const AddValue: TJclComplex): TJclComplex;\r\nvar\r\n ResCoord: TRectCoord;\r\nbegin\r\n ResCoord := CoreAdd(RectCoord(Self), RectCoord(AddValue));\r\n Result := TJclComplex.Create(ResCoord.X, ResCoord.Y, crRectangular);\r\n Result.FFracLen := FFracLen;\r\nend;\r\n\r\nfunction TJclComplex.CNewAdd(const X, Y: Float; const ComplexType: TComplexKind): TJclComplex;\r\nvar\r\n NewComplex: TJclComplex;\r\nbegin\r\n NewComplex := TJclComplex.Create(X, Y, ComplexType);\r\n try\r\n Result := CNewAdd(NewComplex);\r\n finally\r\n NewComplex.Free;\r\n end;\r\nend;\r\n\r\nfunction TJclComplex.CoreDiv(const First, Second: TRectCoord): TRectCoord;\r\nvar\r\n Denom: Float;\r\nbegin\r\n Denom := Sqr(Second.X) + Sqr(Second.Y);\r\n Result.X := (First.X * Second.X + First.Y * Second.Y) / Denom;\r\n Result.Y := (First.Y * Second.X - First.X * Second.Y) / Denom;\r\nend;\r\n\r\nfunction TJclComplex.CDiv(const DivValue: TJclComplex): TJclComplex;\r\nvar\r\n ResCoord: TRectCoord;\r\nbegin\r\n ResCoord := CoreDiv(RectCoord(Self), RectCoord(DivValue));\r\n FCoord.X := ResCoord.X;\r\n FCoord.Y := ResCoord.Y;\r\n Result := Self;\r\nend;\r\n\r\nfunction TJclComplex.CDiv(const X, Y: Float; const ComplexType: TComplexKind): TJclComplex;\r\nvar\r\n NewComplex: TJclComplex;\r\nbegin\r\n NewComplex := TJclComplex.Create(X, Y, ComplexType);\r\n try\r\n Result := CDiv(NewComplex);\r\n finally\r\n NewComplex.Free;\r\n end;\r\nend;\r\n\r\nfunction TJclComplex.CNewDiv(const DivValue: TJclComplex): TJclComplex;\r\nvar\r\n ResCoord: TRectCoord;\r\nbegin\r\n ResCoord := CoreDiv(RectCoord(Self), RectCoord(DivValue));\r\n Result := TJclComplex.Create(ResCoord.X, ResCoord.Y, crRectangular);\r\n Result.FFracLen := FFracLen;\r\nend;\r\n\r\nfunction TJclComplex.CNewDiv(const X, Y: Float; const ComplexType: TComplexKind): TJclComplex;\r\nvar\r\n NewComplex: TJclComplex;\r\nbegin\r\n NewComplex := TJclComplex.Create(X, Y, ComplexType);\r\n try\r\n Result := CNewDiv(NewComplex);\r\n finally\r\n NewComplex.Free;\r\n end;\r\nend;\r\n\r\nfunction TJclComplex.CoreMul(const First, Second: TRectCoord): TRectCoord;\r\nbegin\r\n Result.X := First.X * Second.X - First.Y * Second.Y;\r\n Result.Y := First.X * Second.Y + First.Y * Second.X;\r\nend;\r\n\r\nfunction TJclComplex.CMul(const MulValue: TJclComplex): TJclComplex;\r\nvar\r\n ResCoord: TRectCoord;\r\nbegin\r\n ResCoord := CoreMul(RectCoord(Self), RectCoord(MulValue));\r\n FCoord.X := ResCoord.X;\r\n FCoord.Y := ResCoord.Y;\r\n Result := Self;\r\nend;\r\n\r\nfunction TJclComplex.CMul(const X, Y: Float; const ComplexType: TComplexKind): TJclComplex;\r\nvar\r\n NewComplex: TJclComplex;\r\nbegin\r\n NewComplex := TJclComplex.Create(X, Y, ComplexType);\r\n try\r\n Result := CMul(NewComplex);\r\n finally\r\n NewComplex.Free;\r\n end;\r\nend;\r\n\r\nfunction TJclComplex.CNewMul(const MulValue: TJclComplex): TJclComplex;\r\nvar\r\n ResCoord: TRectCoord;\r\nbegin\r\n ResCoord := CoreMul(RectCoord(Self), RectCoord(MulValue));\r\n Result := TJclComplex.Create(ResCoord.X, ResCoord.Y, crRectangular);\r\n Result.FFracLen := FFracLen;\r\nend;\r\n\r\nfunction TJclComplex.CNewMul(const X, Y: Float; const ComplexType: TComplexKind): TJclComplex;\r\nvar\r\n NewComplex: TJclComplex;\r\nbegin\r\n NewComplex := TJclComplex.Create(X, Y, ComplexType);\r\n try\r\n Result := CNewMul(NewComplex);\r\n finally\r\n NewComplex.Free;\r\n end;\r\nend;\r\n\r\nfunction TJclComplex.CoreSub(const First, Second: TRectCoord): TRectCoord;\r\nbegin\r\n Result.X := First.X - Second.X;\r\n Result.Y := First.Y - Second.Y;\r\nend;\r\n\r\nfunction TJclComplex.CSub(const SubValue: TJclComplex): TJclComplex;\r\nvar\r\n ResValue: TRectCoord;\r\nbegin\r\n ResValue := CoreSub(RectCoord(Self), RectCoord(SubValue));\r\n FCoord.X := ResValue.X;\r\n FCoord.Y := ResValue.Y;\r\n Result := Self;\r\nend;\r\n\r\nfunction TJclComplex.CSub(const X, Y: Float; const ComplexType: TComplexKind): TJclComplex;\r\nvar\r\n NewComplex: TJclComplex;\r\nbegin\r\n NewComplex := TJclComplex.Create(X, Y, ComplexType);\r\n try\r\n Result := CSub(NewComplex);\r\n finally\r\n NewComplex.Free;\r\n end;\r\nend;\r\n\r\nfunction TJclComplex.CNewSub(const SubValue: TJclComplex): TJclComplex;\r\nvar\r\n ResValue: TRectCoord;\r\nbegin\r\n ResValue := CoreSub(RectCoord(Self), RectCoord(SubValue));\r\n Result := TJclComplex.Create(ResValue.X, ResValue.Y, crRectangular);\r\n Result.FFracLen := FFracLen;\r\nend;\r\n\r\nfunction TJclComplex.CNewSub(const X, Y: Float; const ComplexType: TComplexKind): TJclComplex;\r\nvar\r\n NewComplex: TJclComplex;\r\nbegin\r\n NewComplex := TJclComplex.Create(X, Y, ComplexType);\r\n try\r\n Result := CNewSub(NewComplex);\r\n finally\r\n NewComplex.Free;\r\n end;\r\nend;\r\n\r\nfunction TJclComplex.CNeg;\r\nbegin\r\n FCoord.X := -FCoord.X;\r\n FCoord.Y := -FCoord.Y;\r\n Result := Self;\r\nend;\r\n\r\nfunction TJclComplex.CNewNeg;\r\nbegin\r\n Result := TJclComplex.Create(-FCoord.X, -FCoord.Y, crRectangular);\r\n Result.FFracLen := FFracLen;\r\nend;\r\n\r\nfunction TJclComplex.CConjugate;\r\nbegin\r\n FCoord.Y := -FCoord.Y;\r\n Result := Self;\r\nend;\r\n\r\nfunction TJclComplex.CNewConjugate;\r\nbegin\r\n Result := TJclComplex.Create(FCoord.X, -FCoord.Y, crRectangular);\r\n Result.FFracLen := FFracLen;\r\nend;\r\n\r\n//=== natural log and exponential functions ==================================\r\n\r\nfunction TJclComplex.CoreLn(const LnValue: TRectCoord): TRectCoord;\r\nbegin\r\n Result.X := System.Ln(LnValue.X);\r\n Result.Y := NormalizeAngle(LnValue.Y);\r\nend;\r\n\r\nfunction TJclComplex.CLn: TJclComplex;\r\nvar\r\n ResCoord: TRectCoord;\r\nbegin\r\n FillCoords(crRectangular);\r\n ResCoord := CoreLn(RectCoord(FCoord.R, FCoord.Theta));\r\n FCoord.X := ResCoord.X;\r\n FCoord.Y := ResCoord.Y;\r\n Result := Self;\r\nend;\r\n\r\nfunction TJclComplex.CNewLn: TJclComplex;\r\nvar\r\n ResCoord: TRectCoord;\r\nbegin\r\n FillCoords(crRectangular);\r\n ResCoord := CoreLn(RectCoord(FCoord.R, FCoord.Theta));\r\n Result := TJclComplex.Create(ResCoord.X, ResCoord.Y, crRectangular);\r\n Result.FFracLen := FFracLen;\r\nend;\r\n\r\nfunction TJclComplex.CoreExp(const ExpValue: TRectCoord): TRectCoord;\r\nvar\r\n ExpX: Float;\r\nbegin\r\n ExpX := JclMath.Exp(ExpValue.X);\r\n Result.X := ExpX * JclMath.Cos(ExpValue.Y);\r\n Result.Y := ExpX * JclMath.Sin(ExpValue.Y);\r\nend;\r\n\r\nfunction TJclComplex.CExp: TJclComplex;\r\nvar\r\n ResCoord: TRectCoord;\r\nbegin\r\n ResCoord := CoreExp(RectCoord(FCoord.X, FCoord.Y));\r\n FCoord.X := ResCoord.X;\r\n FCoord.Y := ResCoord.Y;\r\n Result := Self;\r\nend;\r\n\r\nfunction TJclComplex.CNewExp: TJclComplex;\r\nvar\r\n ResCoord: TRectCoord;\r\nbegin\r\n ResCoord := CoreExp(RectCoord(FCoord.X, FCoord.Y));\r\n Result := TJclComplex.Create(ResCoord.X, ResCoord.Y, crRectangular);\r\n Result.FFracLen := FFracLen;\r\nend;\r\n\r\nfunction TJclComplex.CorePwr(First, Second, Polar: TRectCoord): TRectCoord;\r\nbegin\r\n First.X := MiscalcFloat(First.X);\r\n First.Y := MiscalcFloat(First.Y);\r\n Second.X := MiscalcFloat(Second.X);\r\n Second.Y := MiscalcFloat(Second.Y);\r\n if AbsoluteValueSqr(First) = 0.0 then\r\n if AbsoluteValueSqr(Second) = 0.0 then\r\n Result := RectOne\r\n else\r\n Result := RectZero\r\n else\r\n Result := CoreExp(CoreMul(Second, CoreLn(Polar)));\r\nend;\r\n\r\nfunction TJclComplex.CPwr(const PwrValue: TJclComplex): TJclComplex;\r\nvar\r\n ResValue: TRectCoord;\r\nbegin\r\n FillCoords(crRectangular);\r\n ResValue := CorePwr(RectCoord(Self), RectCoord(PwrValue), RectCoord(FCoord.R, FCoord.Theta));\r\n FCoord.X := ResValue.X;\r\n FCoord.Y := ResValue.Y;\r\n Result := Self;\r\nend;\r\n\r\nfunction TJclComplex.CPwr(const X, Y: Float; const ComplexType: TComplexKind): TJclComplex;\r\nvar\r\n NewComplex: TJclComplex;\r\nbegin\r\n NewComplex := TJclComplex.Create(X, Y, ComplexType);\r\n try\r\n Result := CPwr(NewComplex);\r\n finally\r\n NewComplex.Free;\r\n end;\r\nend;\r\n\r\nfunction TJclComplex.CNewPwr(PwrValue: TJclComplex): TJclComplex;\r\nvar\r\n ResValue: TRectCoord;\r\nbegin\r\n FillCoords(crRectangular);\r\n ResValue := CorePwr(RectCoord(Self), RectCoord(PwrValue), RectCoord(FCoord.R, FCoord.Theta));\r\n Result := TJclComplex.Create(ResValue.X, ResValue.Y, crRectangular);\r\n Result.FFracLen := FFracLen;\r\nend;\r\n\r\nfunction TJclComplex.CNewPwr(const X, Y: Float; const ComplexType: TComplexKind): TJclComplex;\r\nvar\r\n NewComplex: TJclComplex;\r\nbegin\r\n NewComplex := TJclComplex.Create(X, Y, ComplexType);\r\n try\r\n Result := CNewPwr(NewComplex);\r\n finally\r\n NewComplex.Free;\r\n end;\r\nend;\r\n\r\nfunction TJclComplex.CoreIntPwr(First: TRectCoord; const Polar: TRectCoord; const Pwr: Integer): TRectCoord;\r\nbegin\r\n First.X := MiscalcFloat(First.X);\r\n First.Y := MiscalcFloat(First.Y);\r\n if AbsoluteValueSqr(First) = 0.0 then\r\n if Pwr = 0 then\r\n Result := RectOne\r\n else\r\n Result := RectZero\r\n else\r\n Result := RectCoord(PowerInt(Polar.X, Pwr), NormalizeAngle(Pwr * Polar.Y));\r\nend;\r\n\r\nfunction TJclComplex.CIntPwr(const Pwr: Integer): TJclComplex;\r\nvar\r\n ResValue: TRectCoord;\r\nbegin\r\n FillCoords(crRectangular);\r\n ResValue := CoreIntPwr(RectCoord(Self), RectCoord(FCoord.R, FCoord.Theta), Pwr);\r\n FCoord.R := ResValue.X;\r\n FCoord.Theta := ResValue.Y;\r\n FillCoords(crPolar);\r\n Result := Self;\r\nend;\r\n\r\nfunction TJclComplex.CNewIntPwr(const Pwr: Integer): TJclComplex;\r\nvar\r\n ResValue: TRectCoord;\r\nbegin\r\n FillCoords(crRectangular);\r\n ResValue := CoreIntPwr(RectCoord(Self), RectCoord(FCoord.R, FCoord.Theta), Pwr);\r\n Result := TJclComplex.Create(ResValue.X, ResValue.Y, crPolar);\r\n Result.FFracLen := FFracLen;\r\nend;\r\n\r\nfunction TJclComplex.CoreRealPwr(First: TRectCoord; const Polar: TRectCoord; const Pwr: Float): TRectCoord;\r\nbegin\r\n First.X := MiscalcFloat(First.X);\r\n First.Y := MiscalcFloat(First.Y);\r\n if AbsoluteValueSqr(First) = 0.0 then\r\n if MiscalcFloat(Pwr) = 0.0 then\r\n Result := RectOne\r\n else\r\n Result := RectZero\r\n else\r\n Result := RectCoord(Power(Polar.X, Pwr), NormalizeAngle(Pwr * Polar.Y));\r\nend;\r\n\r\nfunction TJclComplex.CRealPwr(const Pwr: Float): TJclComplex;\r\nvar\r\n ResValue: TRectCoord;\r\nbegin\r\n FillCoords(crRectangular);\r\n ResValue := CoreRealPwr(RectCoord(Self), RectCoord(FCoord.R, FCoord.Theta), Pwr);\r\n FCoord.R := ResValue.X;\r\n FCoord.Theta := ResValue.Y;\r\n FillCoords(crPolar);\r\n Result := Self;\r\nend;\r\n\r\nfunction TJclComplex.CNewRealPwr(const Pwr: Float): TJclComplex;\r\nvar\r\n ResValue: TRectCoord;\r\nbegin\r\n FillCoords(crRectangular);\r\n ResValue := CoreRealPwr(RectCoord(Self), RectCoord(FCoord.R, FCoord.Theta), Pwr);\r\n Result := TJclComplex.Create(ResValue.X, ResValue.Y, crPolar);\r\n Result.FFracLen := FFracLen;\r\nend;\r\n\r\nfunction TJclComplex.CoreRoot(First: TRectCoord; const Polar: TRectCoord; const K, N: Word): TRectCoord;\r\nbegin\r\n First.X := MiscalcFloat(First.X);\r\n First.Y := MiscalcFloat(First.Y);\r\n if AbsoluteValue(First) = 0.0 then\r\n Result := RectZero\r\n else\r\n Result := RectCoord(Power(Polar.X, 1.0 / N), NormalizeAngle((Polar.Y + K * TwoPi) / N));\r\nend;\r\n\r\nfunction TJclComplex.CRoot(const K, N: Word): TJclComplex;\r\nvar\r\n ResValue: TRectCoord;\r\nbegin\r\n FillCoords(crRectangular);\r\n ResValue := CoreRoot(RectCoord(Self), RectCoord(FCoord.R, FCoord.Theta), K, N);\r\n FCoord.R := ResValue.X;\r\n FCoord.Theta := ResValue.Y;\r\n FillCoords(crPolar);\r\n Result := Self;\r\nend;\r\n\r\nfunction TJclComplex.CNewRoot(const K, N: Word): TJclComplex;\r\nvar\r\n ResValue: TRectCoord;\r\nbegin\r\n FillCoords(crRectangular);\r\n ResValue := CoreRoot(RectCoord(Self), RectCoord(FCoord.R, FCoord.Theta), K, N);\r\n Result := TJclComplex.Create(ResValue.X, ResValue.Y, crPolar);\r\n Result.FFracLen := FFracLen;\r\nend;\r\n\r\nfunction TJclComplex.CSqrt: TJclComplex;\r\nbegin\r\n Result := CRoot(0, 2);\r\nend;\r\n\r\nfunction TJclComplex.CNewSqrt: TJclComplex;\r\nbegin\r\n Result := CNewRoot(0, 2);\r\nend;\r\n\r\n//=== trigonometric functions ================================================\r\n\r\nfunction TJclComplex.CoreCos(const Value: TRectCoord): TRectCoord;\r\nbegin\r\n Result := RectCoord(JclMath.Cos(Value.X) * JclMath.CosH(Value.Y), -JclMath.Sin(Value.X) * JclMath.SinH(Value.Y));\r\nend;\r\n\r\nfunction TJclComplex.CCos: TJclComplex;\r\nvar\r\n ResValue: TRectCoord;\r\nbegin\r\n ResValue := CoreCos(RectCoord(Self));\r\n FCoord.X := ResValue.X;\r\n FCoord.Y := ResValue.Y;\r\n Result := Self;\r\nend;\r\n\r\nfunction TJclComplex.CNewCos: TJclComplex;\r\nvar\r\n ResValue: TRectCoord;\r\nbegin\r\n ResValue := CoreCos(RectCoord(Self));\r\n Result := TJclComplex.Create(ResValue.X, ResValue.Y, crRectangular);\r\n Result.FFracLen := FFracLen;\r\nend;\r\n\r\nfunction TJclComplex.CoreSin(const Value: TRectCoord): TRectCoord;\r\nbegin\r\n Result := RectCoord(JclMath.Sin(Value.X) * JclMath.CosH(Value.Y), JclMath.Cos(Value.X) * JclMath.SinH(Value.Y));\r\nend;\r\n\r\nfunction TJclComplex.CSin: TJclComplex;\r\nvar\r\n ResValue: TRectCoord;\r\nbegin\r\n ResValue := CoreSin(RectCoord(Self));\r\n FCoord.X := ResValue.X;\r\n FCoord.Y := ResValue.Y;\r\n Result := Self;\r\nend;\r\n\r\nfunction TJclComplex.CNewSin: TJclComplex;\r\nvar\r\n ResValue: TRectCoord;\r\nbegin\r\n ResValue := CoreSin(RectCoord(Self));\r\n Result := TJclComplex.Create(ResValue.X, ResValue.Y, crRectangular);\r\n Result.FFracLen := FFracLen;\r\nend;\r\n\r\nfunction TJclComplex.CoreTan(const Value: TRectCoord): TRectCoord;\r\nvar\r\n TempValue: Float;\r\nbegin\r\n TempValue := JclMath.Cos(2.0 * Value.X) + JclMath.CosH(2.0 * Value.Y);\r\n if MiscalcFloat(TempValue) <> 0.0 then\r\n Result := RectCoord(JclMath.Sin(2.0 * Value.X) / TempValue, JclMath.SinH(2.0 * Value.Y) / TempValue)\r\n else\r\n Result := RectInfinity;\r\nend;\r\n\r\nfunction TJclComplex.CTan: TJclComplex;\r\nvar\r\n ResValue: TRectCoord;\r\nbegin\r\n ResValue := CoreTan(RectCoord(Self));\r\n FCoord.X := ResValue.X;\r\n FCoord.Y := ResValue.Y;\r\n Result := Self;\r\nend;\r\n\r\nfunction TJclComplex.CNewTan: TJclComplex;\r\nvar\r\n ResValue: TRectCoord;\r\nbegin\r\n ResValue := CoreTan(RectCoord(Self));\r\n Result := TJclComplex.Create(ResValue.X, ResValue.Y, crRectangular);\r\n Result.FFracLen := FFracLen;\r\nend;\r\n\r\nfunction TJclComplex.CoreCot(const Value: TRectCoord): TRectCoord;\r\nvar\r\n TempValue: Float;\r\nbegin\r\n TempValue := JclMath.Cosh(2.0 * Value.Y) - JclMath.Cos(2.0 * Value.X);\r\n if MiscalcFloat(TempValue) <> 0.0 then\r\n Result := RectCoord(JclMath.Sin(2.0 * Value.X) / TempValue, -JclMath.SinH(2.0 * Value.Y) / TempValue)\r\n else\r\n Result := RectInfinity;\r\nend;\r\n\r\nfunction TJclComplex.CCot: TJclComplex;\r\nvar\r\n ResValue: TRectCoord;\r\nbegin\r\n ResValue := CoreCot(RectCoord(Self));\r\n FCoord.X := ResValue.X;\r\n FCoord.Y := ResValue.Y;\r\n Result := Self;\r\nend;\r\n\r\nfunction TJclComplex.CNewCot: TJclComplex;\r\nvar\r\n ResValue: TRectCoord;\r\nbegin\r\n ResValue := CoreCot(RectCoord(Self));\r\n Result := TJclComplex.Create(ResValue.X, ResValue.Y, crRectangular);\r\n Result.FFracLen := FFracLen;\r\nend;\r\n\r\nfunction TJclComplex.CoreSec(const Value: TRectCoord): TRectCoord;\r\nvar\r\n TempValue: TRectCoord;\r\nbegin\r\n TempValue := CoreCos(Value);\r\n if MiscalcFloat(AbsoluteValue(TempValue)) <> 0.0 then\r\n Result := CoreDiv(RectOne, TempValue)\r\n else\r\n Result := RectInfinity;\r\nend;\r\n\r\nfunction TJclComplex.CSec: TJclComplex;\r\nvar\r\n ResValue: TRectCoord;\r\nbegin\r\n ResValue := CoreSec(RectCoord(Self));\r\n FCoord.X := ResValue.X;\r\n FCoord.Y := ResValue.Y;\r\n Result := Self;\r\nend;\r\n\r\nfunction TJclComplex.CNewSec: TJclComplex;\r\nvar\r\n ResValue: TRectCoord;\r\nbegin\r\n ResValue := CoreSec(RectCoord(Self));\r\n Result := TJclComplex.Create(ResValue.X, ResValue.Y, crRectangular);\r\n Result.FFracLen := FFracLen;\r\nend;\r\n\r\nfunction TJclComplex.CoreCsc(const Value: TRectCoord): TRectCoord;\r\nvar\r\n TempValue: TRectCoord;\r\nbegin\r\n TempValue := CoreSin(Value);\r\n if MiscalcFloat(AbsoluteValue(TempValue)) <> 0.0 then\r\n Result := CoreDiv(RectOne, TempValue)\r\n else\r\n Result := RectInfinity;\r\nend;\r\n\r\nfunction TJclComplex.CCsc: TJclComplex;\r\nvar\r\n ResValue: TRectCoord;\r\nbegin\r\n ResValue := CoreCsc(RectCoord(Self));\r\n FCoord.X := ResValue.X;\r\n FCoord.Y := ResValue.Y;\r\n Result := Self;\r\nend;\r\n\r\nfunction TJclComplex.CNewCsc: TJclComplex;\r\nvar\r\n ResValue: TRectCoord;\r\nbegin\r\n ResValue := CoreCsc(RectCoord(Self));\r\n Result := TJclComplex.Create(ResValue.X, ResValue.Y, crRectangular);\r\n Result.FFracLen := FFracLen;\r\nend;\r\n\r\n//=== hyperbolic functions ===================================================\r\n\r\nfunction TJclComplex.CoreCosH(const Value: TRectCoord): TRectCoord;\r\nbegin\r\n Result := RectCoord(JclMath.CosH(Value.X) * JclMath.Cos(Value.Y), JclMath.SinH(Value.X) * JclMath.Sin(Value.Y));\r\nend;\r\n\r\nfunction TJclComplex.CCosH: TJclComplex;\r\nvar\r\n ResValue: TRectCoord;\r\nbegin\r\n ResValue := CoreCosH(RectCoord(Self));\r\n FCoord.X := ResValue.X;\r\n FCoord.Y := ResValue.Y;\r\n Result := Self;\r\nend;\r\n\r\nfunction TJclComplex.CNewCosH: TJclComplex;\r\nvar\r\n ResValue: TRectCoord;\r\nbegin\r\n ResValue := CoreCosH(RectCoord(Self));\r\n Result := TJclComplex.Create(ResValue.X, ResValue.Y, crRectangular);\r\n Result.FFracLen := FFracLen;\r\nend;\r\n\r\nfunction TJclComplex.CoreSinH(const Value: TRectCoord): TRectCoord;\r\nbegin\r\n Result := RectCoord(JclMath.SinH(Value.X) * JclMath.Cos(Value.Y), JclMath.CosH(Value.X) * JclMath.Sin(Value.Y));\r\nend;\r\n\r\nfunction TJclComplex.CSinH: TJclComplex;\r\nvar\r\n ResValue: TRectCoord;\r\nbegin\r\n ResValue := CoreSinH(RectCoord(Self));\r\n FCoord.X := ResValue.X;\r\n FCoord.Y := ResValue.Y;\r\n Result := Self;\r\nend;\r\n\r\nfunction TJclComplex.CNewSinH: TJclComplex;\r\nvar\r\n ResValue: TRectCoord;\r\nbegin\r\n ResValue := CoreSinH(RectCoord(Self));\r\n Result := TJclComplex.Create(ResValue.X, ResValue.Y, crRectangular);\r\n Result.FFracLen := FFracLen;\r\nend;\r\n\r\nfunction TJclComplex.CoreTanH(const Value: TRectCoord): TRectCoord;\r\nvar\r\n TempValue: Float;\r\nbegin\r\n TempValue := JclMath.CosH(2.0 * Value.X) + JclMath.Cos(2.0 * Value.Y);\r\n if MiscalcFloat(TempValue) <> 0.0 then\r\n Result := RectCoord(JclMath.SinH(2.0 * Value.X) / TempValue, JclMath.Sin(2.0 * Value.Y) / TempValue)\r\n else\r\n Result := RectInfinity;\r\nend;\r\n\r\nfunction TJclComplex.CTanH: TJclComplex;\r\nvar\r\n ResValue: TRectCoord;\r\nbegin\r\n ResValue := CoreTanH(RectCoord(Self));\r\n FCoord.X := ResValue.X;\r\n FCoord.Y := ResValue.Y;\r\n Result := Self;\r\nend;\r\n\r\nfunction TJclComplex.CNewTanH: TJclComplex;\r\nvar\r\n ResValue: TRectCoord;\r\nbegin\r\n ResValue := CoreTanH(RectCoord(Self));\r\n Result := TJclComplex.Create(ResValue.X, ResValue.Y, crRectangular);\r\n Result.FFracLen := FFracLen;\r\nend;\r\n\r\nfunction TJclComplex.CoreCotH(const Value: TRectCoord): TRectCoord;\r\nvar\r\n TempValue: Float;\r\nbegin\r\n TempValue := JclMath.Cosh(2.0 * Value.X) - JclMath.Cos(2.0 * Value.Y);\r\n if MiscalcFloat(TempValue) <> 0.0 then\r\n Result := RectCoord(JclMath.SinH(2.0 * Value.X) / TempValue, -JclMath.Sin(2.0 * Value.Y) / TempValue)\r\n else\r\n Result := RectInfinity;\r\nend;\r\n\r\nfunction TJclComplex.CCotH: TJclComplex;\r\nvar\r\n ResValue: TRectCoord;\r\nbegin\r\n ResValue := CoreCotH(RectCoord(Self));\r\n FCoord.X := ResValue.X;\r\n FCoord.Y := ResValue.Y;\r\n Result := Self;\r\nend;\r\n\r\nfunction TJclComplex.CNewCotH: TJclComplex;\r\nvar\r\n ResValue: TRectCoord;\r\nbegin\r\n ResValue := CoreCotH(RectCoord(Self));\r\n Result := TJclComplex.Create(ResValue.X, ResValue.Y, crRectangular);\r\n Result.FFracLen := FFracLen;\r\nend;\r\n\r\nfunction TJclComplex.CoreSecH(const Value: TRectCoord): TRectCoord;\r\nvar\r\n TempValue: TRectCoord;\r\nbegin\r\n TempValue := CoreCosH(Value);\r\n if MiscalcFloat(AbsoluteValue(TempValue)) <> 0.0 then\r\n Result := CoreDiv(RectOne, TempValue)\r\n else\r\n Result := RectInfinity;\r\nend;\r\n\r\nfunction TJclComplex.CSecH: TJclComplex;\r\nvar\r\n ResValue: TRectCoord;\r\nbegin\r\n ResValue := CoreSecH(RectCoord(Self));\r\n FCoord.X := ResValue.X;\r\n FCoord.Y := ResValue.Y;\r\n Result := Self;\r\nend;\r\n\r\nfunction TJclComplex.CNewSecH: TJclComplex;\r\nvar\r\n ResValue: TRectCoord;\r\nbegin\r\n ResValue := CoreSecH(RectCoord(Self));\r\n Result := TJclComplex.Create(ResValue.X, ResValue.Y, crRectangular);\r\n Result.FFracLen := FFracLen;\r\nend;\r\n\r\nfunction TJclComplex.CoreCscH(const Value: TRectCoord): TRectCoord;\r\nvar\r\n TempValue: TRectCoord;\r\nbegin\r\n TempValue := CoreSinH(Value);\r\n if MiscalcFloat(AbsoluteValue(TempValue)) <> 0.0 then\r\n Result := CoreDiv(RectOne, TempValue)\r\n else\r\n Result := RectInfinity;\r\nend;\r\n\r\nfunction TJclComplex.CCscH: TJclComplex;\r\nvar\r\n ResValue: TRectCoord;\r\nbegin\r\n ResValue := CoreCscH(RectCoord(Self));\r\n FCoord.X := ResValue.X;\r\n FCoord.Y := ResValue.Y;\r\n Result := Self;\r\nend;\r\n\r\nfunction TJclComplex.CNewCscH: TJclComplex;\r\nvar\r\n ResValue: TRectCoord;\r\nbegin\r\n ResValue := CoreCscH(RectCoord(Self));\r\n Result := TJclComplex.Create(ResValue.X, ResValue.Y, crRectangular);\r\n Result.FFracLen := FFracLen;\r\nend;\r\n\r\n//=== complex Bessel functions of order zero =================================\r\n\r\nfunction TJclComplex.CoreI0(const Value: TRectCoord): TRectCoord;\r\nvar\r\n ZSqr25, Term: TRectCoord;\r\n I: Integer;\r\n SizeSqr: Float;\r\nbegin\r\n Result := RectOne;\r\n ZSqr25 := CoreMul(Value, Value);\r\n ZSqr25 := RectCoord(0.25 * ZSqr25.X, 0.25 * ZSqr25.Y);\r\n Term := ZSqr25;\r\n Result := CoreAdd(Result, ZSqr25);\r\n I := 1;\r\n repeat\r\n Term := CoreMul(ZSqr25, Term);\r\n Inc(I);\r\n Term := RectCoord(Term.X / Sqr(I), Term.Y / Sqr(I));\r\n Result := CoreAdd(Result, Term);\r\n SizeSqr := Sqr(Term.X) + Sqr(Term.Y);\r\n until (I > MaxTerm) or (SizeSqr < EpsilonSqr);\r\nend;\r\n\r\nfunction TJclComplex.CI0: TJclComplex;\r\nvar\r\n ResValue: TRectCoord;\r\nbegin\r\n ResValue := CoreI0(RectCoord(Self));\r\n FCoord.X := ResValue.X;\r\n FCoord.Y := ResValue.Y;\r\n Result := Self;\r\nend;\r\n\r\nfunction TJclComplex.CNewI0: TJclComplex;\r\nvar\r\n ResValue: TRectCoord;\r\nbegin\r\n ResValue := CoreI0(RectCoord(Self));\r\n Result := TJclComplex.Create(ResValue.X, ResValue.Y, crRectangular);\r\n Result.FFracLen := FFracLen;\r\nend;\r\n\r\nfunction TJclComplex.CoreJ0(const Value: TRectCoord): TRectCoord;\r\nvar\r\n ZSqr25, Term: TRectCoord;\r\n I: Integer;\r\n SizeSqr: Float;\r\n AddFlag: Boolean;\r\nbegin\r\n Result := RectOne;\r\n ZSqr25 := CoreMul(Value, Value);\r\n ZSqr25 := RectCoord(0.25 * ZSqr25.X, 0.25 * ZSqr25.Y);\r\n Term := ZSqr25;\r\n Result := CoreSub(Result, ZSqr25);\r\n AddFlag := False;\r\n I := 1;\r\n repeat\r\n Term := CoreMul(ZSqr25, Term);\r\n Inc(I);\r\n AddFlag := not AddFlag;\r\n Term := RectCoord(Term.X / Sqr(I), Term.Y / Sqr(I));\r\n if AddFlag then\r\n Result := CoreAdd(Result, Term)\r\n else\r\n Result := CoreSub(Result, Term);\r\n SizeSqr := Sqr(Term.X) + Sqr(Term.Y);\r\n until (I > MaxTerm) or (SizeSqr < EpsilonSqr);\r\nend;\r\n\r\nfunction TJclComplex.CJ0: TJclComplex;\r\nvar\r\n ResValue: TRectCoord;\r\nbegin\r\n ResValue := CoreJ0(RectCoord(Self));\r\n FCoord.X := ResValue.X;\r\n FCoord.Y := ResValue.Y;\r\n Result := Self;\r\nend;\r\n\r\nfunction TJclComplex.CNewJ0: TJclComplex;\r\nvar\r\n ResValue: TRectCoord;\r\nbegin\r\n ResValue := CoreJ0(RectCoord(Self));\r\n Result := TJclComplex.Create(ResValue.X, ResValue.Y, crRectangular);\r\n Result.FFracLen := FFracLen;\r\nend;\r\n\r\nfunction TJclComplex.CoreApproxLnGamma(const Value: TRectCoord): TRectCoord;\r\nconst\r\n C: array [1..8] of Float =\r\n (1.0 / 12.0, -1.0 / 360.0, 1.0 / 1260.0, -1.0 / 1680.0,\r\n 1.0 / 1188.0, -691.0 / 360360.0, 1.0 / 156.0, -3617.0 / 122400.0);\r\nvar\r\n I: Integer;\r\n Powers: array [1..8] of TRectCoord;\r\n Temp1, Temp2: TRectCoord;\r\nbegin\r\n Temp1 := CoreLn(Value);\r\n Temp2 := RectCoord(Value.X - 0.5, Value.Y);\r\n Result := CoreAdd(Temp1, Temp2);\r\n Result := CoreSub(Result, Value);\r\n Result.X := Result.X + hLn2PI;\r\n\r\n Temp1 := RectOne;\r\n Powers[1] := CoreDiv(Temp1, Value);\r\n Temp2 := CoreMul(powers[1], Powers[1]);\r\n for I := 2 to 8 do\r\n Powers[I] := CoreMul(Powers[I - 1], Temp2);\r\n for I := 8 downto 1 do\r\n begin\r\n Temp1 := RectCoord(C[I] * Powers[I].X, C[I] * Powers[I].Y);\r\n Result := CoreAdd(Result, Temp1);\r\n end;\r\nend;\r\n\r\nfunction TJclComplex.CApproxLnGamma: TJclComplex;\r\nvar\r\n ResValue: TRectCoord;\r\nbegin\r\n ResValue := CoreApproxLnGamma(RectCoord(Self));\r\n FCoord.X := ResValue.X;\r\n FCoord.Y := ResValue.Y;\r\n Result := Self;\r\nend;\r\n\r\nfunction TJclComplex.CNewApproxLnGamma: TJclComplex;\r\nvar\r\n ResValue: TRectCoord;\r\nbegin\r\n ResValue := CoreApproxLnGamma(RectCoord(Self));\r\n Result := TJclComplex.Create(ResValue.X, ResValue.Y, crRectangular);\r\n Result.FFracLen := FFracLen;\r\nend;\r\n\r\nfunction TJclComplex.CoreLnGamma(Value: TRectCoord): TRectCoord;\r\nvar\r\n LNA, Temp: TRectCoord;\r\nbegin\r\n if (Value.X <= 0.0) and (MiscalcFloat(Value.Y) = 0.0) then\r\n if MiscalcFloat(Int(Value.X - 1E-8) - Value.X) = 0.0 then\r\n begin\r\n Result := RectInfinity;\r\n Exit;\r\n end;\r\n\r\n if Value.Y < 0.0 then\r\n begin\r\n Value := RectCoord(Value.X, -Value.Y);\r\n Result := CoreLnGamma(Value);\r\n Result := RectCoord(Result.X, -Result.Y);\r\n end\r\n else\r\n begin\r\n if Value.X < 9.0 then\r\n begin\r\n LNA := CoreLn(Value);\r\n Value := RectCoord(Value.X + 1, Value.Y);\r\n Temp := CoreLnGamma(Value);\r\n Result := CoreSub(Temp, LNA);\r\n end\r\n else\r\n CoreApproxLnGamma(Value);\r\n end;\r\nend;\r\n\r\nfunction TJclComplex.CLnGamma: TJclComplex;\r\nvar\r\n ResValue: TRectCoord;\r\nbegin\r\n ResValue := CoreLnGamma(RectCoord(Self));\r\n FCoord.X := ResValue.X;\r\n FCoord.Y := ResValue.Y;\r\n Result := Self;\r\nend;\r\n\r\nfunction TJclComplex.CNewLnGamma: TJclComplex;\r\nvar\r\n ResValue: TRectCoord;\r\nbegin\r\n ResValue := CoreLnGamma(RectCoord(Self));\r\n Result := TJclComplex.Create(ResValue.X, ResValue.Y, crRectangular);\r\n Result.FFracLen := FFracLen;\r\nend;\r\n\r\nfunction TJclComplex.CoreGamma(const Value: TRectCoord): TRectCoord;\r\nvar\r\n LNZ: TRectCoord;\r\nbegin\r\n LNZ := CoreLnGamma(Value);\r\n if LNZ.X > 75.0 then\r\n Result := RectInfinity\r\n else\r\n if LNZ.X < -200.0 then\r\n Result := RectZero\r\n else\r\n Result := CoreExp(LNZ);\r\nend;\r\n\r\nfunction TJclComplex.CGamma: TJclComplex;\r\nvar\r\n ResValue: TRectCoord;\r\nbegin\r\n ResValue := CoreGamma(RectCoord(Self));\r\n FCoord.X := ResValue.X;\r\n FCoord.Y := ResValue.Y;\r\n Result := Self;\r\nend;\r\n\r\nfunction TJclComplex.CNewGamma: TJclComplex;\r\nvar\r\n ResValue: TRectCoord;\r\nbegin\r\n ResValue := CoreGamma(RectCoord(Self));\r\n Result := TJclComplex.Create(ResValue.X, ResValue.Y, crRectangular);\r\n Result.FFracLen := FFracLen;\r\nend;\r\n\r\n//=== miscellaneous ==========================================================\r\n\r\nfunction TJclComplex.AbsoluteValue: Float;\r\nbegin\r\n Result := Sqrt(Sqr(FCoord.X) + Sqr(FCoord.Y));\r\nend;\r\n\r\nfunction TJclComplex.AbsoluteValue(const Coord: TRectCoord): Float;\r\nbegin\r\n Result := Sqrt(Sqr(Coord.X) + Sqr(Coord.Y));\r\nend;\r\n\r\nfunction TJclComplex.AbsoluteValueSqr: Float;\r\nbegin\r\n Result := Sqr(FCoord.X) + Sqr(FCoord.Y);\r\nend;\r\n\r\nfunction TJclComplex.AbsoluteValueSqr(const Coord: TRectCoord): Float;\r\nbegin\r\n Result := Sqr(Coord.X) + Sqr(Coord.Y);\r\nend;\r\n\r\nfunction TJclComplex.FormatExtended(const X: Float): string;\r\nbegin\r\n Result := FloatToStrF(X, ffFixed, FFracLen, FFracLen);\r\nend;\r\n\r\nprocedure TJclComplex.SetFracLen(const X: Byte);\r\nbegin\r\n if X > MaxFracLen then\r\n FFracLen := MaxFracLen\r\n else\r\n FFracLen := X;\r\nend;\r\n\r\nfunction TJclComplex.GetRadius: Float;\r\nbegin\r\n FillCoords(crRectangular);\r\n Result := FCoord.R;\r\nend;\r\n\r\nfunction TJclComplex.GetAngle: Float;\r\nbegin\r\n FillCoords(crRectangular);\r\n Result := FCoord.Theta;\r\nend;\r\n\r\nfunction TJclComplex.NormalizeAngle(const Value: Float): Float;\r\nvar\r\n N: Integer;\r\nbegin\r\n Result := Value;\r\n if Result > Pi then\r\n begin\r\n N := Floor((Result + Pi) / TwoPi);\r\n Result := Result - N * TwoPi;\r\n end\r\n else\r\n if Result < -Pi then\r\n begin\r\n N := Floor((-Result + Pi) / TwoPi);\r\n Result := Result + N * TwoPi;\r\n end;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jcl/source/common/JclCompression.pas", "content": "{**************************************************************************************************}\r\n{ }\r\n{ Project JEDI Code Library (JCL) }\r\n{ }\r\n{ The contents of this file are subject to the Mozilla Public License Version 1.1 (the \"License\"); }\r\n{ you may not use this file except in compliance with the License. You may obtain a copy of the }\r\n{ License at http://www.mozilla.org/MPL/ }\r\n{ }\r\n{ Software distributed under the License is distributed on an \"AS IS\" basis, WITHOUT WARRANTY OF }\r\n{ ANY KIND, either express or implied. See the License for the specific language governing rights }\r\n{ and limitations under the License. }\r\n{ }\r\n{ The Original Code is JclCompression.pas. }\r\n{ }\r\n{ The Initial Developer of the Original Code is Matthias Thoma. }\r\n{ All Rights Reserved. }\r\n{ }\r\n{ Contributors: }\r\n{ Olivier Sannier (obones) }\r\n{ Florent Ouchet (outchy) }\r\n{ Jan Goyvaerts (jgsoft) }\r\n{ Uwe Schuster (uschuster) }\r\n{ }\r\n{**************************************************************************************************}\r\n{ }\r\n{ Alternatively, the contents of this file may be used under the terms of the GNU Lesser General }\r\n{ Public License (the \"LGPL License\"), in which case the provisions of the LGPL License are }\r\n{ applicable instead of those above. If you wish to allow use of your version of this file only }\r\n{ under the terms of the LGPL License and not to allow others to use your version of this file }\r\n{ under the MPL, indicate your decision by deleting the provisions above and replace them with the }\r\n{ notice and other provisions required by the LGPL License. If you do not delete the provisions }\r\n{ above, a recipient may use your version of this file under either the MPL or the LGPL License. }\r\n{ }\r\n{ For more information about the LGPL: }\r\n{ http://www.gnu.org/copyleft/lesser.html }\r\n{ }\r\n{**************************************************************************************************}\r\n{ }\r\n{ Last modified: $Date:: 2012-04-30 09:54:26 +0200 (lun. 30 avr. 2012) $ }\r\n{ Revision: $Rev:: 3785 $ }\r\n{ Author: $Author:: jgsoft $ }\r\n{ }\r\n{**************************************************************************************************}\r\n\r\nunit JclCompression;\r\n\r\n{$I jcl.inc}\r\n{$I crossplatform.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n {$IFDEF HAS_UNIT_LIBC}\r\n Libc,\r\n {$ENDIF HAS_UNIT_LIBC}\r\n {$IFDEF HAS_UNITSCOPE}\r\n {$IFDEF MSWINDOWS}\r\n Winapi.Windows, Sevenzip, Winapi.ActiveX,\r\n {$ENDIF MSWINDOWS}\r\n System.Types,\r\n System.SysUtils, System.Classes, System.Contnrs,\r\n {$IFDEF ZLIB_RTL}\r\n System.ZLib,\r\n {$ENDIF ZLIB_RTL}\r\n {$ELSE ~HAS_UNITSCOPE}\r\n {$IFDEF MSWINDOWS}\r\n Windows, Sevenzip, ActiveX,\r\n {$ENDIF MSWINDOWS}\r\n Types,\r\n SysUtils, Classes, Contnrs,\r\n {$IFDEF ZLIB_RTL}\r\n ZLib,\r\n {$ENDIF ZLIB_RTL}\r\n {$ENDIF ~HAS_UNITSCOPE}\r\n zlibh, bzip2, JclWideStrings, JclBase, JclStreams;\r\n\r\n{$IFDEF RTL230_UP}\r\n{$HPPEMIT '// To avoid ambiguity with System::Zlib::z_stream_s we force using ours'}\r\n{$HPPEMIT '#define z_stream_s Zlibh::z_stream_s'}\r\n{$ENDIF RTL230_UP}\r\n\r\n{**************************************************************************************************\r\n Class hierarchy\r\n\r\n TJclCompressionStream\r\n |\r\n |-- TJclCompressStream\r\n | |\r\n | |-- TJclZLibCompressStream handled by zlib http://www.zlib.net/\r\n | |-- TJclBZIP2CompressStream handled by bzip2 http://www.bzip.net/\r\n | |-- TJclGZIPCompressStream handled by zlib http://www.zlib.net/ + JCL\r\n |\r\n |-- TJclDecompressStream\r\n |\r\n |-- TJclZLibDecompressStream handled by zlib http://www.zlib.net/\r\n |-- TBZIP2DecompressStream handled by bzip2 http://www.bzip.net/\r\n |-- TGZIPDecompressStream handled by zlib http://www.zlib.net/ + JCL\r\n\r\n TJclCompressionArchive\r\n |\r\n |-- TJclCompressArchive\r\n | |\r\n | |-- TJclSevenzipCompressArchive\r\n | |\r\n | |-- TJclZipCompressArchive handled by sevenzip http://sevenzip.sourceforge.net/\r\n | |-- TJclBZ2CompressArchive handled by sevenzip http://sevenzip.sourceforge.net/\r\n | |-- TJcl7zCompressArchive handled by sevenzip http://sevenzip.sourceforge.net/\r\n | |-- TJclTarCompressArchive handled by sevenzip http://sevenzip.sourceforge.net/\r\n | |-- TJclGZipCompressArchive handled by sevenzip http://sevenzip.sourceforge.net/\r\n | |-- TJclXzCompressArchive handled by sevenzip http://sevenzip.sourceforge.net/\r\n | |-- TJclSwfcCompressArchive handled by sevenzip http://sevenzip.sourceforge.net/\r\n | |-- TJclWimCompressArchive handled by sevenzip http://sevenzip.sourceforge.net/\r\n |\r\n |-- TJclDecompressArchive\r\n | |\r\n | |-- TJclSevenZipDecompressArchive\r\n | |\r\n | |-- TJclZipDecompressArchive handled by sevenzip http://sevenzip.sourceforge.net/\r\n | |-- TJclBZ2DecompressArchive handled by sevenzip http://sevenzip.sourceforge.net/\r\n | |-- TJclRarDecompressArchive handled by sevenzip http://sevenzip.sourceforge.net/\r\n | |-- TJclArjDecompressArchive handled by sevenzip http://sevenzip.sourceforge.net/\r\n | |-- TJclZDecompressArchive handled by sevenzip http://sevenzip.sourceforge.net/\r\n | |-- TJclLzhDecompressArchive handled by sevenzip http://sevenzip.sourceforge.net/\r\n | |-- TJcl7zDecompressArchive handled by sevenzip http://sevenzip.sourceforge.net/\r\n | |-- TJclCabDecompressArchive handled by sevenzip http://sevenzip.sourceforge.net/\r\n | |-- TJclNsisDecompressArchive handled by sevenzip http://sevenzip.sourceforge.net/\r\n | |-- TJclLzmaDecompressArchive handled by sevenzip http://sevenzip.sourceforge.net/\r\n | |-- TJclLzma86DecompressArchive handled by sevenzip http://sevenzip.sourceforge.net/\r\n | |-- TJclPeDecompressArchive handled by sevenzip http://sevenzip.sourceforge.net/\r\n | |-- TJclElfDecompressArchive handled by sevenzip http://sevenzip.sourceforge.net/\r\n | |-- TJclMachoDecompressArchive handled by sevenzip http://sevenzip.sourceforge.net/\r\n | |-- TJclUdfDecompressArchive handled by sevenzip http://sevenzip.sourceforge.net/\r\n | |-- TJclXarDecompressArchive handled by sevenzip http://sevenzip.sourceforge.net/\r\n | |-- TJclMubDecompressArchive handled by sevenzip http://sevenzip.sourceforge.net/\r\n | |-- TJclHfsDecompressArchive handled by sevenzip http://sevenzip.sourceforge.net/\r\n | |-- TJclDmgDecompressArchive handled by sevenzip http://sevenzip.sourceforge.net/\r\n | |-- TJclCompoundDecompressArchive handled by sevenzip http://sevenzip.sourceforge.net/\r\n | |-- TJclWimDecompressArchive handled by sevenzip http://sevenzip.sourceforge.net/\r\n | |-- TJclIsoDecompressArchive handled by sevenzip http://sevenzip.sourceforge.net/\r\n | |-- TJclBkfDecompressArchive handled by sevenzip http://sevenzip.sourceforge.net/\r\n | |-- TJclChmDecompressArchive handled by sevenzip http://sevenzip.sourceforge.net/\r\n | |-- TJclSplitDecompressArchive handled by sevenzip http://sevenzip.sourceforge.net/\r\n | |-- TJclRpmDecompressArchive handled by sevenzip http://sevenzip.sourceforge.net/\r\n | |-- TJclDebDecompressArchive handled by sevenzip http://sevenzip.sourceforge.net/\r\n | |-- TJclCpioDecompressArchive handled by sevenzip http://sevenzip.sourceforge.net/\r\n | |-- TJclTarDecompressArchive handled by sevenzip http://sevenzip.sourceforge.net/\r\n | |-- TJclGZipDecompressArchive handled by sevenzip http://sevenzip.sourceforge.net/\r\n | |-- TJclXzDecompressArchive handled by sevenzip http://sevenzip.sourceforge.net/\r\n | |-- TJclNtfsDecompressArchive handled by sevenzip http://sevenzip.sourceforge.net/\r\n | |-- TJclFatDecompressArchive handled by sevenzip http://sevenzip.sourceforge.net/\r\n | |-- TJclMbrDecompressArchive handled by sevenzip http://sevenzip.sourceforge.net/\r\n | |-- TJclVhdDecompressArchive handled by sevenzip http://sevenzip.sourceforge.net/\r\n | |-- TJclMslzDecompressArchive handled by sevenzip http://sevenzip.sourceforge.net/\r\n | |-- TJclFlvDecompressArchive handled by sevenzip http://sevenzip.sourceforge.net/\r\n | |-- TJclSwfDecompressArchive handled by sevenzip http://sevenzip.sourceforge.net/\r\n | |-- TJclSwfcDecompressArchive handled by sevenzip http://sevenzip.sourceforge.net/\r\n | |-- TJclAPMDecompressArchive handled by sevenzip http://sevenzip.sourceforge.net/\r\n | |-- TJclPpmdDecompressArchive handled by sevenzip http://sevenzip.sourceforge.net/\r\n | |-- TJclTEDecompressArchive handled by sevenzip http://sevenzip.sourceforge.net/\r\n | |-- TJclUEFIcDecompressArchive handled by sevenzip http://sevenzip.sourceforge.net/\r\n | |-- TJclUEFIsDecompressArchive handled by sevenzip http://sevenzip.sourceforge.net/\r\n | |-- TJclSquashFSDecompressArchive handled by sevenzip http://sevenzip.sourceforge.net/\r\n | |-- TJclCramFSDecompressArchive handled by sevenzip http://sevenzip.sourceforge.net/\r\n |\r\n |-- TJclUpdateArchive\r\n |\r\n |-- TJclSevenzipUpdateArchive\r\n |\r\n |-- TJclZipUpdateArchive handled by sevenzip http://sevenzip.sourceforge.net/\r\n |-- TJclBZ2UpdateArchive handled by sevenzip http://sevenzip.sourceforge.net/\r\n |-- TJcl7zUpdateArchive handled by sevenzip http://sevenzip.sourceforge.net/\r\n |-- TJclTarUpdateArchive handled by sevenzip http://sevenzip.sourceforge.net/\r\n |-- TJclGZipUpdateArchive handled by sevenzip http://sevenzip.sourceforge.net/\r\n |-- TJclXzUpdateArchive handled by sevenzip http://sevenzip.sourceforge.net/\r\n |-- TJclSwfcUpdateArchive handled by sevenzip http://sevenzip.sourceforge.net/\r\n\r\n**************************************************************************************************}\r\n\r\ntype\r\n TJclCompressionStream = class(TJclStream)\r\n private\r\n FOnProgress: TNotifyEvent;\r\n FBuffer: Pointer;\r\n FBufferSize: Cardinal;\r\n FStream: TStream;\r\n protected\r\n function SetBufferSize(Size: Cardinal): Cardinal; virtual;\r\n procedure Progress(Sender: TObject); dynamic;\r\n property OnProgress: TNotifyEvent read FOnProgress write FOnProgress;\r\n public\r\n class function StreamExtensions: string; virtual;\r\n class function StreamName: string; virtual;\r\n class function StreamSubExtensions: string; virtual;\r\n\r\n constructor Create(AStream: TStream);\r\n destructor Destroy; override;\r\n\r\n function Read(var Buffer; Count: Longint): Longint; override;\r\n function Write(const Buffer; Count: Longint): Longint; override;\r\n function Seek(const Offset: Int64; Origin: TSeekOrigin): Int64; override;\r\n procedure Reset; virtual;\r\n end;\r\n\r\n TJclCompressionStreamClass = class of TJclCompressionStream;\r\n\r\n TJclCompressStream = class(TJclCompressionStream)\r\n public\r\n function Flush: Integer; dynamic; abstract;\r\n constructor Create(Destination: TStream);\r\n end;\r\n\r\n TJclCompressStreamClass = class of TJclCompressStream;\r\n\r\n TJclDecompressStream = class(TJclCompressionStream)\r\n private\r\n FOwnsStream: Boolean;\r\n public\r\n constructor Create(Source: TStream; AOwnsStream: Boolean = False);\r\n destructor Destroy; override;\r\n end;\r\n\r\n TJclDecompressStreamClass = class of TJclDecompressStream;\r\n\r\n TJclCompressionStreamFormats = class\r\n private\r\n FCompressFormats: TList;\r\n FDecompressFormats: TList;\r\n protected\r\n function GetCompressFormatCount: Integer;\r\n function GetCompressFormat(Index: Integer): TJclCompressStreamClass;\r\n function GetDecompressFormatCount: Integer;\r\n function GetDecompressFormat(Index: Integer): TJclDecompressStreamClass;\r\n public\r\n constructor Create;\r\n destructor Destroy; override;\r\n\r\n procedure RegisterFormat(AClass: TJclCompressionStreamClass);\r\n procedure UnregisterFormat(AClass: TJclCompressionStreamClass);\r\n\r\n function FindCompressFormat(const AFileName: TFileName): TJclCompressStreamClass;\r\n function FindDecompressFormat(const AFileName: TFileName): TJclDecompressStreamClass;\r\n\r\n property CompressFormatCount: Integer read GetCompressFormatCount;\r\n property CompressFormats[Index: Integer]: TJclCompressStreamClass read GetCompressFormat;\r\n property DecompressFormatCount: Integer read GetDecompressFormatCount;\r\n property DecompressFormats[Index: Integer]: TJclDecompressStreamClass read GetDecompressFormat;\r\n end;\r\n\r\n// retreive a singleton list containing registered stream classes\r\nfunction GetStreamFormats: TJclCompressionStreamFormats;\r\n\r\n// ZIP Support\r\ntype\r\n TJclCompressionLevel = Integer;\r\n\r\n TJclZLibCompressStream = class(TJclCompressStream)\r\n private\r\n FWindowBits: Integer;\r\n FMemLevel: Integer;\r\n FMethod: Integer;\r\n FStrategy: Integer;\r\n FDeflateInitialized: Boolean;\r\n FCompressionLevel: Integer;\r\n protected\r\n ZLibRecord: TZStreamRec;\r\n procedure SetCompressionLevel(Value: Integer);\r\n procedure SetStrategy(Value: Integer);\r\n procedure SetMemLevel(Value: Integer);\r\n procedure SetMethod(Value: Integer);\r\n procedure SetWindowBits(Value: Integer);\r\n public\r\n // stream description\r\n class function StreamExtensions: string; override;\r\n class function StreamName: string; override;\r\n class function StreamSubExtensions: string; override;\r\n\r\n constructor Create(Destination: TStream; CompressionLevel: TJclCompressionLevel = -1);\r\n destructor Destroy; override;\r\n\r\n function Flush: Integer; override;\r\n procedure Reset; override;\r\n function Seek(const Offset: Int64; Origin: TSeekOrigin): Int64; override;\r\n function Write(const Buffer; Count: Longint): Longint; override;\r\n\r\n property WindowBits: Integer read FWindowBits write SetWindowBits;\r\n property MemLevel: Integer read FMemLevel write SetMemLevel;\r\n property Method: Integer read FMethod write SetMethod;\r\n property Strategy: Integer read FStrategy write SetStrategy;\r\n property CompressionLevel: Integer read FCompressionLevel write SetCompressionLevel;\r\n end;\r\n\r\n{$IFDEF ZLIB_RTL}\r\nconst\r\n DEF_WBITS = 15;\r\n {$EXTERNALSYM DEF_WBITS}\r\n DEF_MEM_LEVEL = 8;\r\n {$EXTERNALSYM DEF_MEM_LEVEL}\r\n\r\ntype\r\n PBytef = PByte;\r\n {$EXTERNALSYM PBytef}\r\n{$ENDIF ZLIB_RTL}\r\n\r\ntype\r\n TJclZLibDecompressStream = class(TJclDecompressStream)\r\n private\r\n FWindowBits: Integer;\r\n FInflateInitialized: Boolean;\r\n protected\r\n ZLibRecord: TZStreamRec;\r\n procedure SetWindowBits(Value: Integer);\r\n public\r\n // stream description\r\n class function StreamExtensions: string; override;\r\n class function StreamName: string; override;\r\n class function StreamSubExtensions: string; override;\r\n\r\n constructor Create(Source: TStream; WindowBits: Integer = DEF_WBITS; AOwnsStream: Boolean = False);\r\n destructor Destroy; override;\r\n\r\n function Read(var Buffer; Count: Longint): Longint; override;\r\n function Seek(const Offset: Int64; Origin: TSeekOrigin): Int64; override;\r\n\r\n property WindowBits: Integer read FWindowBits write SetWindowBits;\r\n end;\r\n\r\n // GZIP Support\r\n\r\n//=== { GZIP helpers } =======================================================\r\n\r\ntype\r\n TJclGZIPHeader = packed record\r\n ID1: Byte;\r\n ID2: Byte;\r\n CompressionMethod: Byte;\r\n Flags: Byte;\r\n ModifiedTime: Cardinal;\r\n ExtraFlags: Byte;\r\n OS: Byte;\r\n end;\r\n\r\n TJclGZIPFooter = packed record\r\n DataCRC32: Cardinal;\r\n DataSize: Cardinal;\r\n end;\r\n\r\nconst\r\n // ID1 and ID2 fields\r\n JCL_GZIP_ID1 = $1F; // value for the ID1 field\r\n JCL_GZIP_ID2 = $8B; // value for the ID2 field\r\n\r\n // Compression Model field\r\n JCL_GZIP_CM_DEFLATE = 8; // Zlib classic\r\n\r\n // Flags field : extra fields for the header\r\n JCL_GZIP_FLAG_TEXT = $01; // file is probably ASCII text\r\n JCL_GZIP_FLAG_CRC = $02; // a CRC16 for the header is present\r\n JCL_GZIP_FLAG_EXTRA = $04; // extra fields present\r\n JCL_GZIP_FLAG_NAME = $08; // original file name is present\r\n JCL_GZIP_FLAG_COMMENT = $10; // comment is present\r\n\r\n // ExtraFlags field : compression level\r\n JCL_GZIP_EFLAG_MAX = 2; // compressor used maximum compression\r\n JCL_GZIP_EFLAG_FAST = 4; // compressor used fastest compression\r\n\r\n // OS field : file system\r\n JCL_GZIP_OS_FAT = 0; // FAT filesystem (MS-DOS, OS/2, NT/Win32)\r\n JCL_GZIP_OS_AMIGA = 1; // Amiga\r\n JCL_GZIP_OS_VMS = 2; // VMS (or OpenVMS)\r\n JCL_GZIP_OS_UNIX = 3; // Unix\r\n JCL_GZIP_OS_VM = 4; // VM/CMS\r\n JCL_GZIP_OS_ATARI = 5; // Atari TOS\r\n JCL_GZIP_OS_HPFS = 6; // HPFS filesystem (OS/2, NT)\r\n JCL_GZIP_OS_MAC = 7; // Macintosh\r\n JCL_GZIP_OS_Z = 8; // Z-System\r\n JCL_GZIP_OS_CPM = 9; // CP/M\r\n JCL_GZIP_OS_TOPS = 10; // TOPS-20\r\n JCL_GZIP_OS_NTFS = 11; // NTFS filesystem (NT)\r\n JCL_GZIP_OS_QDOS = 12; // QDOS\r\n JCL_GZIP_OS_ACORN = 13; // Acorn RISCOS\r\n JCL_GZIP_OS_UNKNOWN = 255; // unknown\r\n\r\ntype\r\n TJclGZIPSubFieldHeader = packed record\r\n SI1: Byte;\r\n SI2: Byte;\r\n Len: Word;\r\n end;\r\n\r\n// constants to identify sub fields in the extra field\r\n// source: http://www.gzip.org/format.txt\r\nconst\r\n JCL_GZIP_X_AC1 = $41; // AC Acorn RISC OS/BBC MOS file type information\r\n JCL_GZIP_X_AC2 = $43;\r\n JCL_GZIP_X_Ap1 = $41; // Ap Apollo file type information\r\n JCL_GZIP_X_Ap2 = $70;\r\n JCL_GZIP_X_cp1 = $63; // cp file compressed by cpio\r\n JCL_GZIP_X_cp2 = $70;\r\n JCL_GZIP_X_GS1 = $1D; // GS gzsig\r\n JCL_GZIP_X_GS2 = $53;\r\n JCL_GZIP_X_KN1 = $4B; // KN KeyNote assertion (RFC 2704)\r\n JCL_GZIP_X_KN2 = $4E;\r\n JCL_GZIP_X_Mc1 = $4D; // Mc Macintosh info (Type and Creator values)\r\n JCL_GZIP_X_Mc2 = $63;\r\n JCL_GZIP_X_RO1 = $52; // RO Acorn Risc OS file type information\r\n JCL_GZIP_X_RO2 = $4F;\r\n\r\ntype\r\n TJclGZIPFlag = (gfDataIsText, gfHeaderCRC16, gfExtraField, gfOriginalFileName, gfComment);\r\n TJclGZIPFlags = set of TJclGZIPFlag;\r\n TJclGZIPFatSystem = (gfsFat, gfsAmiga, gfsVMS, gfsUnix, gfsVM, gfsAtari, gfsHPFS,\r\n gfsMac, gfsZ, gfsCPM, gfsTOPS, gfsNTFS, gfsQDOS, gfsAcorn, gfsOther, gfsUnknown);\r\n\r\n // Format is described in RFC 1952, http://www.faqs.org/rfcs/rfc1952.html\r\n TJclGZIPCompressionStream = class(TJclCompressStream)\r\n private\r\n FFlags: TJclGZIPFlags;\r\n FUnixTime: Cardinal;\r\n FAutoSetTime: Boolean;\r\n FCompressionLevel: TJclCompressionLevel;\r\n FFatSystem: TJclGZIPFatSystem;\r\n FExtraField: string;\r\n FOriginalFileName: TFileName;\r\n FComment: string;\r\n FZLibStream: TJclZLibCompressStream;\r\n FOriginalSize: Cardinal;\r\n FDataCRC32: Cardinal;\r\n FHeaderWritten: Boolean;\r\n FFooterWritten: Boolean; // flag so we only write the footer once! (NEW 2007)\r\n\r\n procedure WriteHeader;\r\n function GetDosTime: TDateTime;\r\n function GetUnixTime: Cardinal;\r\n procedure SetDosTime(const Value: TDateTime);\r\n procedure SetUnixTime(Value: Cardinal);\r\n procedure ZLibStreamProgress(Sender: TObject);\r\n public\r\n // stream description\r\n class function StreamExtensions: string; override;\r\n class function StreamName: string; override;\r\n class function StreamSubExtensions: string; override;\r\n\r\n constructor Create(Destination: TStream; CompressionLevel: TJclCompressionLevel = -1);\r\n destructor Destroy; override;\r\n\r\n function Write(const Buffer; Count: Longint): Longint; override;\r\n procedure Reset; override;\r\n // IMPORTANT: In order to get a valid GZip file, Flush MUST be called after\r\n // the last call to Write.\r\n function Flush: Integer; override;\r\n\r\n property Flags: TJclGZIPFlags read FFlags write FFlags;\r\n property DosTime: TDateTime read GetDosTime write SetDosTime;\r\n property UnixTime: Cardinal read GetUnixTime write SetUnixTime;\r\n property AutoSetTime: Boolean read FAutoSetTime write FAutoSetTime;\r\n property FatSystem: TJclGZIPFatSystem read FFatSystem write FFatSystem;\r\n property ExtraField: string read FExtraField write FExtraField;\r\n // Note: In order for most decompressors to work, the original file name\r\n // must be given or they would display an empty file name in their list.\r\n // This does not affect the decompression stream below as it simply reads\r\n // the value and does not work with it\r\n property OriginalFileName: TFileName read FOriginalFileName write FOriginalFileName;\r\n property Comment: string read FComment write FComment;\r\n end;\r\n\r\n TJclGZIPDecompressionStream = class(TJclDecompressStream)\r\n private\r\n FHeader: TJclGZIPHeader;\r\n FFooter: TJclGZIPFooter;\r\n FCompressedDataStream: TJclDelegatedStream;\r\n FZLibStream: TJclZLibDecompressStream;\r\n FOriginalFileName: TFileName;\r\n FComment: string;\r\n FExtraField: string;\r\n FComputedHeaderCRC16: Word;\r\n FStoredHeaderCRC16: Word;\r\n FComputedDataCRC32: Cardinal;\r\n FCompressedDataSize: Int64;\r\n FDataSize: Int64;\r\n FDataStarted: Boolean;\r\n FDataEnded: Boolean;\r\n FAutoCheckDataCRC32: Boolean;\r\n function GetCompressedDataSize: Int64;\r\n function GetComputedDataCRC32: Cardinal;\r\n function GetDosTime: TDateTime;\r\n function GetFatSystem: TJclGZIPFatSystem;\r\n function GetFlags: TJclGZIPFlags;\r\n function GetOriginalDataSize: Cardinal;\r\n function GetStoredDataCRC32: Cardinal;\r\n function ReadCompressedData(Sender: TObject; var Buffer; Count: Longint): Longint;\r\n procedure ZLibStreamProgress(Sender: TObject);\r\n public\r\n // stream description\r\n class function StreamExtensions: string; override;\r\n class function StreamName: string; override;\r\n class function StreamSubExtensions: string; override;\r\n\r\n constructor Create(Source: TStream; CheckHeaderCRC: Boolean = True; AOwnsStream: Boolean = False);\r\n destructor Destroy; override;\r\n\r\n function Read(var Buffer; Count: Longint): Longint; override;\r\n\r\n property ComputedHeaderCRC16: Word read FComputedHeaderCRC16;\r\n property StoredHeaderCRC16: Word read FStoredHeaderCRC16;\r\n property ExtraField: string read FExtraField;\r\n property OriginalFileName: TFileName read FOriginalFileName;\r\n property Comment: string read FComment;\r\n property Flags: TJclGZIPFlags read GetFlags;\r\n property CompressionLevel: Byte read FHeader.ExtraFlags;\r\n property FatSystem: TJclGZIPFatSystem read GetFatSystem;\r\n property UnixTime: Cardinal read FHeader.ModifiedTime;\r\n property DosTime: TDateTime read GetDosTime;\r\n property ComputedDataCRC32: Cardinal read GetComputedDataCRC32;\r\n property StoredDataCRC32: Cardinal read GetStoredDataCRC32;\r\n property AutoCheckDataCRC32: Boolean read FAutoCheckDataCRC32 write FAutoCheckDataCRC32;\r\n property CompressedDataSize: Int64 read GetCompressedDataSize;\r\n property OriginalDataSize: Cardinal read GetOriginalDataSize;\r\n end;\r\n\r\n // BZIP2 Support\r\n TJclBZIP2CompressionStream = class(TJclCompressStream)\r\n private\r\n FDeflateInitialized: Boolean;\r\n FCompressionLevel: Integer;\r\n protected\r\n BZLibRecord: bz_stream;\r\n procedure SetCompressionLevel(const Value: Integer);\r\n public\r\n // stream description\r\n class function StreamExtensions: string; override;\r\n class function StreamName: string; override;\r\n class function StreamSubExtensions: string; override;\r\n\r\n constructor Create(Destination: TStream; ACompressionLevel: TJclCompressionLevel = 9);\r\n destructor Destroy; override;\r\n\r\n function Flush: Integer; override;\r\n function Seek(const Offset: Int64; Origin: TSeekOrigin): Int64; override;\r\n function Write(const Buffer; Count: Longint): Longint; override;\r\n\r\n property CompressionLevel: Integer read FCompressionLevel write SetCompressionLevel;\r\n end;\r\n\r\n TJclBZIP2DecompressionStream = class(TJclDecompressStream)\r\n private\r\n FInflateInitialized: Boolean;\r\n protected\r\n BZLibRecord: bz_stream;\r\n public\r\n // stream description\r\n class function StreamExtensions: string; override;\r\n class function StreamName: string; override;\r\n class function StreamSubExtensions: string; override;\r\n\r\n constructor Create(Source: TStream; AOwnsStream: Boolean = False); overload;\r\n destructor Destroy; override;\r\n\r\n function Read(var Buffer; Count: Longint): Longint; override;\r\n function Seek(const Offset: Int64; Origin: TSeekOrigin): Int64; override;\r\n end;\r\n\r\n EJclCompressionError = class(EJclError);\r\n\r\n // callback type used in helper functions below:\r\n TJclCompressStreamProgressCallback = procedure(FileSize, Position: Int64; UserData: Pointer) of object;\r\n\r\n{helper functions - one liners by wpostma}\r\nfunction GZipFile(SourceFile, DestinationFile: TFileName; CompressionLevel: Integer = Z_DEFAULT_COMPRESSION;\r\n ProgressCallback: TJclCompressStreamProgressCallback = nil; UserData: Pointer = nil): Boolean;\r\nfunction UnGZipFile(SourceFile, DestinationFile: TFileName;\r\n ProgressCallback: TJclCompressStreamProgressCallback = nil; UserData: Pointer = nil): Boolean;\r\nprocedure GZipStream(SourceStream, DestinationStream: TStream; CompressionLevel: Integer = Z_DEFAULT_COMPRESSION;\r\n ProgressCallback: TJclCompressStreamProgressCallback = nil; UserData: Pointer = nil);\r\nprocedure UnGZipStream(SourceStream, DestinationStream: TStream;\r\n ProgressCallback: TJclCompressStreamProgressCallback = nil; UserData: Pointer = nil);\r\n\r\nfunction BZip2File(SourceFile, DestinationFile: TFileName; CompressionLevel: Integer = 5;\r\n ProgressCallback: TJclCompressStreamProgressCallback = nil; UserData: Pointer = nil): Boolean;\r\nfunction UnBZip2File(SourceFile, DestinationFile: TFileName;\r\n ProgressCallback: TJclCompressStreamProgressCallback = nil; UserData: Pointer = nil): Boolean;\r\nprocedure BZip2Stream(SourceStream, DestinationStream: TStream; CompressionLevel: Integer = 5;\r\n ProgressCallback: TJclCompressStreamProgressCallback = nil; UserData: Pointer = nil);\r\nprocedure UnBZip2Stream(SourceStream, DestinationStream: TStream;\r\n ProgressCallback: TJclCompressStreamProgressCallback = nil; UserData: Pointer = nil);\r\n\r\n// archive ancestor classes\r\n{$IFDEF MSWINDOWS}\r\ntype\r\n TJclCompressionVolumeEvent = procedure(Sender: TObject; Index: Integer;\r\n var AFileName: TFileName; var AStream: TStream; var AOwnsStream: Boolean) of object;\r\n TJclCompressionVolumeMaxSizeEvent = procedure(Sender: TObject; Index: Integer;\r\n var AVolumeMaxSize: Int64) of object;\r\n TJclCompressionProgressEvent = procedure(Sender: TObject; const Value, MaxValue: Int64) of object;\r\n TJclCompressionRatioEvent = procedure(Sender: TObject; const InSize, OutSize: Int64) of object;\r\n\r\n TJclCompressionItemProperty = (ipPackedName, ipPackedSize, ipPackedExtension,\r\n ipFileSize, ipFileName, ipAttributes, ipCreationTime, ipLastAccessTime,\r\n ipLastWriteTime, ipComment, ipHostOS, ipHostFS, ipUser, ipGroup, ipCRC,\r\n ipStream, ipMethod, ipEncrypted);\r\n TJclCompressionItemProperties = set of TJclCompressionItemProperty;\r\n\r\n TJclCompressionItemKind = (ikFile, ikDirectory);\r\n\r\n TJclCompressionOperationSuccess = (osNoOperation, osOK, osUnsupportedMethod,\r\n osDataError, osCRCError, osUnknownError);\r\n\r\n TJclCompressionDuplicateCheck = (dcNone, dcExisting, dcAll);\r\n TJclCompressionDuplicateAction = (daOverwrite, daError, daSkip);\r\n\r\n TJclCompressionArchive = class;\r\n\r\n TJclCompressionItem = class\r\n private\r\n FArchive: TJclCompressionArchive;\r\n // source or destination\r\n FFileName: TFileName;\r\n FStream: TStream;\r\n FOwnsStream: Boolean;\r\n // miscellaneous\r\n FValidProperties: TJclCompressionItemProperties;\r\n FModifiedProperties: TJclCompressionItemProperties;\r\n FPackedIndex: Cardinal;\r\n FSelected: Boolean;\r\n FOperationSuccess: TJclCompressionOperationSuccess;\r\n // file properties\r\n FPackedName: WideString;\r\n FPackedSize: Int64;\r\n FFileSize: Int64;\r\n FAttributes: Cardinal;\r\n FPackedExtension: WideString;\r\n FCreationTime: TFileTime;\r\n FLastAccessTime: TFileTime;\r\n FLastWriteTime: TFileTime;\r\n FComment: WideString;\r\n FHostOS: WideString;\r\n FHostFS: WideString;\r\n FUser: WideString;\r\n FGroup: WideString;\r\n FCRC: Cardinal;\r\n FMethod: WideString;\r\n FEncrypted: Boolean;\r\n function WideChangeFileExt(const AFileName, AExtension: WideString): WideString;\r\n function WideExtractFileExt(const AFileName: WideString): WideString;\r\n function WideExtractFileName(const AFileName: WideString): WideString;\r\n protected\r\n // property checkers\r\n procedure CheckGetProperty(AProperty: TJclCompressionItemProperty); virtual; abstract;\r\n procedure CheckSetProperty(AProperty: TJclCompressionItemProperty); virtual; abstract;\r\n function ValidateExtraction(Index: Integer): Boolean; virtual;\r\n function DeleteOutputFile: Boolean;\r\n function UpdateFileTimes: Boolean;\r\n // property getters\r\n function GetAttributes: Cardinal;\r\n function GetComment: WideString;\r\n function GetCRC: Cardinal;\r\n function GetCreationTime: TFileTime;\r\n function GetDirectory: Boolean;\r\n function GetEncrypted: Boolean;\r\n function GetFileName: TFileName;\r\n function GetFileSize: Int64;\r\n function GetGroup: WideString;\r\n function GetHostFS: WideString;\r\n function GetHostOS: WideString;\r\n function GetItemKind: TJclCompressionItemKind;\r\n function GetLastAccessTime: TFileTime;\r\n function GetLastWriteTime: TFileTime;\r\n function GetMethod: WideString;\r\n function GetNestedArchiveName: WideString; virtual;\r\n function GetNestedArchiveStream: TStream; virtual;\r\n function GetPackedExtension: WideString;\r\n function GetPackedName: WideString;\r\n function GetPackedSize: Int64;\r\n function GetStream: TStream;\r\n function GetUser: WideString;\r\n // property setters\r\n procedure SetAttributes(Value: Cardinal);\r\n procedure SetComment(const Value: WideString);\r\n procedure SetCRC(Value: Cardinal);\r\n procedure SetCreationTime(const Value: TFileTime);\r\n procedure SetDirectory(Value: Boolean);\r\n procedure SetEncrypted(Value: Boolean);\r\n procedure SetFileName(const Value: TFileName);\r\n procedure SetFileSize(const Value: Int64);\r\n procedure SetGroup(const Value: WideString);\r\n procedure SetHostFS(const Value: WideString);\r\n procedure SetHostOS(const Value: WideString);\r\n procedure SetLastAccessTime(const Value: TFileTime);\r\n procedure SetLastWriteTime(const Value: TFileTime);\r\n procedure SetMethod(const Value: WideString);\r\n procedure SetPackedExtension(const Value: WideString);\r\n procedure SetPackedName(const Value: WideString);\r\n procedure SetPackedSize(const Value: Int64);\r\n procedure SetStream(const Value: TStream);\r\n procedure SetUser(const Value: WideString);\r\n public\r\n constructor Create(AArchive: TJclCompressionArchive);\r\n destructor Destroy; override;\r\n // release stream if owned and created from file name\r\n procedure ReleaseStream;\r\n // properties in archive\r\n property Attributes: Cardinal read GetAttributes write SetAttributes;\r\n property Comment: WideString read GetComment write SetComment;\r\n property CRC: Cardinal read GetCRC write SetCRC;\r\n property CreationTime: TFileTime read GetCreationTime write SetCreationTime;\r\n property Directory: Boolean read GetDirectory write SetDirectory;\r\n property Encrypted: Boolean read GetEncrypted write SetEncrypted;\r\n property FileSize: Int64 read GetFileSize write SetFileSize;\r\n property Group: WideString read GetGroup write SetGroup;\r\n property HostOS: WideString read GetHostOS write SetHostOS;\r\n property HostFS: WideString read GetHostFS write SetHostFS;\r\n property Kind: TJclCompressionItemKind read GetItemKind;\r\n property LastAccessTime: TFileTime read GetLastAccessTime write SetLastAccessTime;\r\n property LastWriteTime: TFileTime read GetLastWriteTime write SetLastWriteTime;\r\n property Method: WideString read GetMethod write SetMethod;\r\n property PackedExtension: WideString read GetPackedExtension write SetPackedExtension;\r\n property PackedName: WideString read GetPackedName write SetPackedName;\r\n property PackedSize: Int64 read GetPackedSize write SetPackedSize;\r\n property User: WideString read GetUser write SetUser;\r\n // source or destination\r\n property FileName: TFileName read GetFileName write SetFileName;\r\n property OwnsStream: Boolean read FOwnsStream write FOwnsStream;\r\n property Stream: TStream read GetStream write SetStream;\r\n property NestedArchiveStream: TStream read GetNestedArchiveStream;\r\n property NestedArchiveName: WideString read GetNestedArchiveName;\r\n // miscellaneous\r\n property Archive: TJclCompressionArchive read FArchive;\r\n property OperationSuccess: TJclCompressionOperationSuccess read FOperationSuccess\r\n write FOperationSuccess;\r\n property ValidProperties: TJclCompressionItemProperties read FValidProperties;\r\n property ModifiedProperties: TJclCompressionItemProperties read FModifiedProperties\r\n write FModifiedProperties;\r\n property PackedIndex: Cardinal read FPackedIndex;\r\n property Selected: Boolean read FSelected write FSelected;\r\n end;\r\n\r\n TJclCompressionItemClass = class of TJclCompressionItem;\r\n\r\n TJclCompressionVolume = class\r\n protected\r\n FFileName: TFileName;\r\n FTmpFileName: TFileName;\r\n FStream: TStream;\r\n FTmpStream: TStream;\r\n FOwnsStream: Boolean;\r\n FOwnsTmpStream: Boolean;\r\n FVolumeMaxSize: Int64;\r\n public\r\n constructor Create(AStream, ATmpStream: TStream; AOwnsStream, AOwnsTmpStream: Boolean;\r\n AFileName, ATmpFileName: TFileName; AVolumeMaxSize: Int64);\r\n destructor Destroy; override;\r\n procedure ReleaseStreams;\r\n property FileName: TFileName read FFileName;\r\n property TmpFileName: TFileName read FTmpFileName;\r\n property Stream: TStream read FStream;\r\n property TmpStream: TStream read FTmpStream;\r\n property OwnsStream: Boolean read FOwnsStream;\r\n property OwnsTmpStream: Boolean read FOwnsTmpStream;\r\n property VolumeMaxSize: Int64 read FVolumeMaxSize;\r\n end;\r\n\r\n TJclStreamAccess = (saCreate, saReadOnly, saReadOnlyDenyNone, saWriteOnly, saReadWrite);\r\n\r\n { TJclCompressionArchive is not ref-counted }\r\n TJclCompressionArchive = class(TInterfacedObject, IInterface)\r\n private\r\n FOnProgress: TJclCompressionProgressEvent;\r\n FOnRatio: TJclCompressionRatioEvent;\r\n FOnVolume: TJclCompressionVolumeEvent;\r\n FOnVolumeMaxSize: TJclCompressionVolumeMaxSizeEvent;\r\n FPassword: WideString;\r\n FVolumeIndex: Integer;\r\n FVolumeIndexOffset: Integer;\r\n FVolumeMaxSize: Int64;\r\n FVolumeFileNameMask: TFileName;\r\n FProgressMax: Int64;\r\n FCancelCurrentOperation: Boolean;\r\n FCurrentItemIndex: Integer;\r\n function GetItemCount: Integer;\r\n function GetItem(Index: Integer): TJclCompressionItem;\r\n function GetVolumeCount: Integer;\r\n function GetVolume(Index: Integer): TJclCompressionVolume;\r\n protected\r\n FVolumes: TObjectList;\r\n FItems: TObjectList;\r\n\r\n procedure InitializeArchiveProperties; virtual;\r\n\r\n function InternalOpenStream(const FileName: TFileName): TStream;\r\n function TranslateItemPath(const ItemPath, OldBase, NewBase: WideString): WideString;\r\n\r\n function DoProgress(const Value, MaxValue: Int64): Boolean;\r\n function DoRatio(const InSize, OutSize: Int64): Boolean;\r\n function NeedStream(Index: Integer): TStream;\r\n function NeedStreamMaxSize(Index: Integer): Int64;\r\n procedure ReleaseVolumes;\r\n function GetItemClass: TJclCompressionItemClass; virtual; abstract;\r\n function GetSupportsNestedArchive: Boolean; virtual;\r\n public\r\n { IInterface }\r\n // function QueryInterface(const IID: TGUID; out Obj): HRESULT; stdcall;\r\n function _AddRef: Integer; stdcall;\r\n function _Release: Integer; stdcall;\r\n public\r\n class function MultipleItemContainer: Boolean; virtual;\r\n class function VolumeAccess: TJclStreamAccess; virtual;\r\n function ItemAccess: TJclStreamAccess; virtual;\r\n class function ArchiveExtensions: string; virtual;\r\n class function ArchiveName: string; virtual;\r\n class function ArchiveSubExtensions: string; virtual;\r\n class function ArchiveSignature: TDynByteArray; virtual;\r\n\r\n constructor Create(Volume0: TStream; AVolumeMaxSize: Int64 = 0;\r\n AOwnVolume: Boolean = False); overload; virtual;\r\n constructor Create(const VolumeFileName: TFileName; AVolumeMaxSize: Int64 = 0;\r\n VolumeMask: Boolean = False); overload; virtual;\r\n // if VolumeMask is true then VolumeFileName represents a mask to get volume file names\r\n // \"myfile%d.zip\" \"myfile.zip.%.3d\" ...\r\n destructor Destroy; override;\r\n\r\n function AddVolume(const VolumeFileName: TFileName;\r\n AVolumeMaxSize: Int64 = 0): Integer; overload; virtual;\r\n function AddVolume(const VolumeFileName, TmpVolumeFileName: TFileName;\r\n AVolumeMaxSize: Int64 = 0): Integer; overload; virtual;\r\n function AddVolume(VolumeStream: TStream; AVolumeMaxSize: Int64 = 0;\r\n AOwnsStream: Boolean = False): Integer; overload; virtual;\r\n function AddVolume(VolumeStream, TmpVolumeStream: TStream; AVolumeMaxSize: Int64 = 0;\r\n AOwnsStream: Boolean = False; AOwnsTmpStream: Boolean = False): Integer; overload; virtual;\r\n\r\n // miscellaneous\r\n procedure ClearVolumes;\r\n procedure ClearItems;\r\n\r\n procedure CheckOperationSuccess;\r\n procedure ClearOperationSuccess;\r\n procedure SelectAll;\r\n procedure UnselectAll;\r\n\r\n property ItemCount: Integer read GetItemCount;\r\n property Items[Index: Integer]: TJclCompressionItem read GetItem;\r\n\r\n property VolumeCount: Integer read GetVolumeCount;\r\n property Volumes[Index: Integer]: TJclCompressionVolume read GetVolume;\r\n property VolumeMaxSize: Int64 read FVolumeMaxSize;\r\n property VolumeFileNameMask: TFileName read FVolumeFileNameMask;\r\n property VolumeIndexOffset: Integer read FVolumeIndexOffset write FVolumeIndexOffset;\r\n\r\n property CurrentItemIndex: Integer read FCurrentItemIndex; // valid during OnProgress\r\n property OnProgress: TJclCompressionProgressEvent read FOnProgress write FOnProgress;\r\n property OnRatio: TJclCompressionRatioEvent read FOnRatio write FOnRatio;\r\n\r\n // volume events\r\n property OnVolume: TJclCompressionVolumeEvent read FOnVolume write FOnVolume;\r\n property OnVolumeMaxSize: TJclCompressionVolumeMaxSizeEvent read FOnVolumeMaxSize\r\n write FOnVolumeMaxSize;\r\n property Password: WideString read FPassword write FPassword;\r\n\r\n property SupportsNestedArchive: Boolean read GetSupportsNestedArchive;\r\n property CancelCurrentOperation: Boolean read FCancelCurrentOperation write FCancelCurrentOperation;\r\n end;\r\n\r\n TJclCompressionArchiveClass = class of TJclCompressionArchive;\r\n\r\n IJclArchiveNumberOfThreads = interface\r\n ['{9CFAB801-E68E-4A51-AC49-277B297F1141}']\r\n function GetNumberOfThreads: Cardinal;\r\n procedure SetNumberOfThreads(Value: Cardinal);\r\n property NumberOfThreads: Cardinal read GetNumberOfThreads write SetNumberOfThreads;\r\n end;\r\n\r\n IJclArchiveCompressionLevel = interface\r\n ['{A6A2F55F-2860-4E44-BC20-8C5D3E322AB6}']\r\n function GetCompressionLevel: Cardinal;\r\n function GetCompressionLevelMax: Cardinal;\r\n function GetCompressionLevelMin: Cardinal;\r\n procedure SetCompressionLevel(Value: Cardinal);\r\n property CompressionLevel: Cardinal read GetCompressionLevel write SetCompressionLevel;\r\n property CompressionLevelMax: Cardinal read GetCompressionLevelMax;\r\n property CompressionLevelMin: Cardinal read GetCompressionLevelMin;\r\n end;\r\n\r\n TJclCompressionMethod = (cmCopy, cmDeflate, cmDeflate64, cmBZip2, cmLZMA, cmLZMA2, cmPPMd);\r\n TJclCompressionMethods = set of TJclCompressionMethod;\r\n\r\n IJclArchiveCompressionMethod = interface\r\n ['{2818F8E8-7D5F-4C8C-865E-9BA4512BB766}']\r\n function GetCompressionMethod: TJclCompressionMethod;\r\n function GetSupportedCompressionMethods: TJclCompressionMethods;\r\n procedure SetCompressionMethod(Value: TJclCompressionMethod);\r\n property CompressionMethod: TJclCompressionMethod read GetCompressionMethod write SetCompressionMethod;\r\n property SupportedCompressionMethods: TJclCompressionMethods read GetSupportedCompressionMethods;\r\n end;\r\n\r\n TJclEncryptionMethod = (emNone, emAES128, emAES192, emAES256, emZipCrypto);\r\n TJclEncryptionMethods = set of TJclEncryptionMethod;\r\n\r\n IJclArchiveEncryptionMethod = interface\r\n ['{643485B6-66A1-41C9-A13B-0A8453E9D0C9}']\r\n function GetEncryptionMethod: TJclEncryptionMethod;\r\n function GetSupportedEncryptionMethods: TJclEncryptionMethods;\r\n procedure SetEncryptionMethod(Value: TJclEncryptionMethod);\r\n property EncryptionMethod: TJclEncryptionMethod read GetEncryptionMethod write SetEncryptionMethod;\r\n property SupportedEncryptionMethods: TJclEncryptionMethods read GetSupportedEncryptionMethods;\r\n end;\r\n\r\n IJclArchiveDictionarySize = interface\r\n ['{D3949834-9F3B-49BC-8403-FE3CE5FDCF35}']\r\n function GetDictionarySize: Cardinal;\r\n procedure SetDictionarySize(Value: Cardinal);\r\n property DictionarySize: Cardinal read GetDictionarySize write SetDictionarySize;\r\n end;\r\n\r\n IJclArchiveNumberOfPasses = interface\r\n ['{C61B2814-50CE-4C3C-84A5-BACF8A57E3BC}']\r\n function GetNumberOfPasses: Cardinal;\r\n procedure SetNumberOfPasses(Value: Cardinal);\r\n property NumberOfPasses: Cardinal read GetNumberOfPasses write SetNumberOfPasses;\r\n end;\r\n\r\n IJclArchiveRemoveSfxBlock = interface\r\n ['{852D050D-734E-4610-902A-8FB845DB32A9}']\r\n function GetRemoveSfxBlock: Boolean;\r\n procedure SetRemoveSfxBlock(Value: Boolean);\r\n property RemoveSfxBlock: Boolean read GetRemoveSfxBlock write SetRemoveSfxBlock;\r\n end;\r\n\r\n IJclArchiveCompressHeader = interface\r\n ['{22C62A3B-A58E-4F88-9D3F-08586B542639}']\r\n function GetCompressHeader: Boolean;\r\n function GetCompressHeaderFull: Boolean;\r\n procedure SetCompressHeader(Value: Boolean);\r\n procedure SetCompressHeaderFull(Value: Boolean);\r\n property CompressHeader: Boolean read GetCompressHeader write SetCompressHeader;\r\n property CompressHeaderFull: Boolean read GetCompressHeaderFull write SetCompressHeaderFull;\r\n end;\r\n\r\n IJclArchiveEncryptHeader = interface\r\n ['{7DBA20A8-48A1-4CA2-B9AC-41C219A09A4A}']\r\n function GetEncryptHeader: Boolean;\r\n procedure SetEncryptHeader(Value: Boolean);\r\n property EncryptHeader: Boolean read GetEncryptHeader write SetEncryptHeader;\r\n end;\r\n\r\n IJclArchiveSaveCreationDateTime = interface\r\n ['{8B212BF9-C13F-4582-A4FA-A40E538EFF65}']\r\n function GetSaveCreationDateTime: Boolean;\r\n procedure SetSaveCreationDateTime(Value: Boolean);\r\n property SaveCreationDateTime: Boolean read GetSaveCreationDateTime write SetSaveCreationDateTime;\r\n end;\r\n\r\n IJclArchiveSaveLastAccessDateTime = interface\r\n ['{1A4B2906-9DD2-4584-B7A3-3639DA92AFC5}']\r\n function GetSaveLastAccessDateTime: Boolean;\r\n procedure SetSaveLastAccessDateTime(Value: Boolean);\r\n property SaveLastAccessDateTime: Boolean read GetSaveLastAccessDateTime write SetSaveLastAccessDateTime;\r\n end;\r\n\r\n IJclArchiveSaveLastWriteDateTime = interface\r\n ['{0C1729DC-35E8-43D4-8ECA-54F20CDFF87A}']\r\n function GetSaveLastWriteDateTime: Boolean;\r\n procedure SetSaveLastWriteDateTime(Value: Boolean);\r\n property SaveLastWriteDateTime: Boolean read GetSaveLastWriteDateTime write SetSaveLastWriteDateTime;\r\n end;\r\n\r\n IJclArchiveAlgorithm = interface\r\n ['{53965F1F-24CC-4548-B9E8-5AE2EB7F142D}']\r\n function GetAlgorithm: Cardinal;\r\n function GetSupportedAlgorithms: TDynCardinalArray;\r\n procedure SetAlgorithm(Value: Cardinal);\r\n property Algorithm: Cardinal read GetAlgorithm write SetAlgorithm;\r\n property SupportedAlgorithms: TDynCardinalArray read GetSupportedAlgorithms;\r\n end;\r\n\r\n IJclArchiveSolid = interface\r\n ['{6902C54C-1577-422C-B18B-E27953A28661}']\r\n function GetSolidBlockSize: Int64;\r\n function GetSolidExtension: Boolean;\r\n procedure SetSolidBlockSize(const Value: Int64);\r\n procedure SetSolidExtension(Value: Boolean);\r\n property SolidBlockSize: Int64 read GetSolidBlockSize write SetSolidBlockSize;\r\n property SolidExtension: Boolean read GetSolidExtension write SetSolidExtension;\r\n end;\r\n\r\n TJclCompressItem = class(TJclCompressionItem)\r\n protected\r\n procedure CheckGetProperty(AProperty: TJclCompressionItemProperty); override;\r\n procedure CheckSetProperty(AProperty: TJclCompressionItemProperty); override;\r\n end;\r\n\r\n TJclCompressArchive = class(TJclCompressionArchive, IInterface)\r\n private\r\n FBaseRelName: WideString;\r\n FBaseDirName: string;\r\n FAddFilesInDir: Boolean;\r\n FDuplicateAction: TJclCompressionDuplicateAction;\r\n FDuplicateCheck: TJclCompressionDuplicateCheck;\r\n procedure InternalAddFile(const Directory: string; const FileInfo: TSearchRec);\r\n procedure InternalAddDirectory(const Directory: string);\r\n protected\r\n FCompressing: Boolean;\r\n FPackedNames: TJclWideStringList;\r\n procedure CheckNotCompressing;\r\n function AddFileCheckDuplicate(NewItem: TJclCompressionItem): Integer;\r\n public\r\n class function VolumeAccess: TJclStreamAccess; override;\r\n function ItemAccess: TJclStreamAccess; override;\r\n\r\n destructor Destroy; override;\r\n \r\n function AddDirectory(const PackedName: WideString;\r\n const DirName: string = ''; RecurseIntoDir: Boolean = False;\r\n AddFilesInDir: Boolean = False): Integer; overload; virtual;\r\n function AddFile(const PackedName: WideString;\r\n const FileName: TFileName): Integer; overload; virtual;\r\n function AddFile(const PackedName: WideString; AStream: TStream;\r\n AOwnsStream: Boolean = False): Integer; overload; virtual;\r\n procedure Compress; virtual;\r\n\r\n property DuplicateCheck: TJclCompressionDuplicateCheck read FDuplicateCheck write FDuplicateCheck;\r\n property DuplicateAction: TJclCompressionDuplicateAction read FDuplicateAction write FDuplicateAction;\r\n end;\r\n\r\n TJclCompressArchiveClass = class of TJclCompressArchive;\r\n\r\n TJclCompressArchiveClassArray = array of TJclCompressArchiveClass;\r\n\r\n TJclDecompressItem = class(TJclCompressionItem)\r\n protected\r\n procedure CheckGetProperty(AProperty: TJclCompressionItemProperty); override;\r\n procedure CheckSetProperty(AProperty: TJclCompressionItemProperty); override;\r\n function ValidateExtraction(Index: Integer): Boolean; override;\r\n end;\r\n\r\n // return False not to extract this file\r\n // assign your own FileName, Stream or AOwnsStream to override default one\r\n TJclCompressionExtractEvent = function (Sender: TObject; Index: Integer;\r\n var FileName: TFileName; var Stream: TStream; var AOwnsStream: Boolean): Boolean of object;\r\n\r\n TJclDecompressArchive = class(TJclCompressionArchive, IInterface)\r\n private\r\n FOnExtract: TJclCompressionExtractEvent;\r\n FAutoCreateSubDir: Boolean;\r\n protected\r\n FDecompressing: Boolean;\r\n FListing: Boolean;\r\n FDestinationDir: string;\r\n FExtractingAllIndex: Integer;\r\n procedure CheckNotDecompressing;\r\n procedure CheckListing;\r\n\r\n function ValidateExtraction(Index: Integer; var FileName: TFileName; var AStream: TStream;\r\n var AOwnsStream: Boolean): Boolean; virtual;\r\n public\r\n class function VolumeAccess: TJclStreamAccess; override;\r\n function ItemAccess: TJclStreamAccess; override;\r\n\r\n procedure ListFiles; virtual; abstract;\r\n procedure ExtractSelected(const ADestinationDir: string = '';\r\n AAutoCreateSubDir: Boolean = True); virtual;\r\n procedure ExtractAll(const ADestinationDir: string = '';\r\n AAutoCreateSubDir: Boolean = True); virtual;\r\n\r\n property OnExtract: TJclCompressionExtractEvent read FOnExtract write FOnExtract;\r\n property DestinationDir: string read FDestinationDir;\r\n property AutoCreateSubDir: Boolean read FAutoCreateSubDir;\r\n end;\r\n\r\n TJclDecompressArchiveClass = class of TJclDecompressArchive;\r\n\r\n TJclDecompressArchiveClassArray = array of TJclDecompressArchiveClass;\r\n\r\n TJclUpdateItem = class(TJclCompressionItem)\r\n protected\r\n procedure CheckGetProperty(AProperty: TJclCompressionItemProperty); override;\r\n procedure CheckSetProperty(AProperty: TJclCompressionItemProperty); override;\r\n function ValidateExtraction(Index: Integer): Boolean; override;\r\n end;\r\n\r\n TJclUpdateArchive = class(TJclCompressArchive, IInterface)\r\n private\r\n FOnExtract: TJclCompressionExtractEvent;\r\n FAutoCreateSubDir: Boolean;\r\n protected\r\n FDecompressing: Boolean;\r\n FListing: Boolean;\r\n FDestinationDir: string;\r\n FExtractingAllIndex: Integer;\r\n procedure CheckNotDecompressing;\r\n procedure CheckListing;\r\n\r\n procedure InitializeArchiveProperties; override;\r\n\r\n function ValidateExtraction(Index: Integer; var FileName: TFileName; var AStream: TStream;\r\n var AOwnsStream: Boolean): Boolean; virtual;\r\n public\r\n class function VolumeAccess: TJclStreamAccess; override;\r\n function ItemAccess: TJclStreamAccess; override;\r\n\r\n procedure ListFiles; virtual; abstract;\r\n procedure ExtractSelected(const ADestinationDir: string = '';\r\n AAutoCreateSubDir: Boolean = True); virtual;\r\n procedure ExtractAll(const ADestinationDir: string = '';\r\n AAutoCreateSubDir: Boolean = True); virtual;\r\n procedure DeleteItem(Index: Integer); virtual; abstract;\r\n procedure RemoveItem(const PackedName: WideString); virtual; abstract;\r\n\r\n property OnExtract: TJclCompressionExtractEvent read FOnExtract write FOnExtract;\r\n property DestinationDir: string read FDestinationDir;\r\n property AutoCreateSubDir: Boolean read FAutoCreateSubDir;\r\n end;\r\n\r\n // ancestor class for all archives that update files in-place (not creating a copy of the volumes)\r\n TJclInPlaceUpdateArchive = class(TJclUpdateArchive, IInterface)\r\n end;\r\n\r\n // called when tmp volumes will replace volumes after out-of-place update\r\n TJclCompressionReplaceEvent = function (Sender: TObject; const SrcFileName, DestFileName: TFileName;\r\n var SrcStream, DestStream: TStream; var OwnsSrcStream, OwnsDestStream: Boolean): Boolean of object;\r\n\r\n // ancestor class for all archives that update files out-of-place (by creating a copy of the volumes)\r\n TJclOutOfPlaceUpdateArchive = class(TJclUpdateArchive, IInterface)\r\n private\r\n FReplaceVolumes: Boolean;\r\n FTmpVolumeIndex: Integer;\r\n FOnReplace: TJclCompressionReplaceEvent;\r\n FOnTmpVolume: TJclCompressionVolumeEvent;\r\n protected\r\n function NeedTmpStream(Index: Integer): TStream;\r\n procedure InitializeArchiveProperties; override;\r\n function InternalOpenTmpStream(const FileName: TFileName): TStream;\r\n public\r\n class function TmpVolumeAccess: TJclStreamAccess; virtual;\r\n\r\n procedure Compress; override;\r\n\r\n property ReplaceVolumes: Boolean read FReplaceVolumes write FReplaceVolumes;\r\n property OnReplace: TJclCompressionReplaceEvent read FOnReplace write FOnReplace;\r\n property OnTmpVolume: TJclCompressionVolumeEvent read FOnTmpVolume write FOnTmpVolume;\r\n end;\r\n\r\n TJclUpdateArchiveClass = class of TJclUpdateArchive;\r\n\r\n TJclUpdateArchiveClassArray = array of TJclUpdateArchiveClass;\r\n\r\n// registered archive formats\r\ntype\r\n TJclCompressionArchiveFormats = class\r\n private\r\n FCompressFormats: TList;\r\n FDecompressFormats: TList;\r\n FUpdateFormats: TList;\r\n protected\r\n function GetCompressFormatCount: Integer;\r\n function GetCompressFormat(Index: Integer): TJclCompressArchiveClass;\r\n function GetDecompressFormatCount: Integer;\r\n function GetDecompressFormat(Index: Integer): TJclDecompressArchiveClass;\r\n function GetUpdateFormatCount: Integer;\r\n function GetUpdateFormat(Index: Integer): TJclUpdateArchiveClass;\r\n public\r\n constructor Create;\r\n destructor Destroy; override;\r\n\r\n procedure RegisterFormat(AClass: TJclCompressionArchiveClass);\r\n procedure UnregisterFormat(AClass: TJclCompressionArchiveClass);\r\n\r\n // archive signatures do not give significant results for ISO/UDF (signature is not located at stream start)\r\n // need to find a generic way to match all signature before publishing the code\r\n //function SignatureMatches(Format: TJclCompressionArchiveClass; ArchiveStream: TStream; var Buffer: TDynByteArray): Boolean;\r\n function FindCompressFormat(const AFileName: TFileName): TJclCompressArchiveClass;\r\n //function FindDecompressFormat(const AFileName: TFileName; TestArchiveSignature: Boolean): TJclDecompressArchiveClass; overload;\r\n function FindDecompressFormat(const AFileName: TFileName): TJclDecompressArchiveClass; //overload;\r\n //function FindUpdateFormat(const AFileName: TFileName; TestArchiveSignature: Boolean): TJclUpdateArchiveClass; overload;\r\n function FindUpdateFormat(const AFileName: TFileName): TJclUpdateArchiveClass; //overload;\r\n\r\n function FindCompressFormats(const AFileName: TFileName): TJclCompressArchiveClassArray;\r\n function FindDecompressFormats(const AFileName: TFileName): TJclDecompressArchiveClassArray;\r\n function FindUpdateFormats(const AFileName: TFileName): TJclUpdateArchiveClassArray;\r\n\r\n property CompressFormatCount: Integer read GetCompressFormatCount;\r\n property CompressFormats[Index: Integer]: TJclCompressArchiveClass read GetCompressFormat;\r\n property DecompressFormatCount: Integer read GetDecompressFormatCount;\r\n property DecompressFormats[Index: Integer]: TJclDecompressArchiveClass read GetDecompressFormat;\r\n property UpdateFormatCount: Integer read GetUpdateFormatCount;\r\n property UpdateFormats[Index: Integer]: TJclUpdateArchiveClass read GetUpdateFormat;\r\n end;\r\n\r\n// retreive a singleton list containing archive formats\r\nfunction GetArchiveFormats: TJclCompressionArchiveFormats;\r\n\r\n// sevenzip classes for compression\r\ntype\r\n TJclSevenzipCompressArchive = class(TJclCompressArchive, IInterface)\r\n private\r\n FOutArchive: IOutArchive;\r\n protected\r\n function GetItemClass: TJclCompressionItemClass; override;\r\n function GetOutArchive: IOutArchive;\r\n public\r\n class function ArchiveCLSID: TGUID; virtual;\r\n class function ArchiveSignature: TDynByteArray; override;\r\n destructor Destroy; override;\r\n procedure Compress; override;\r\n property OutArchive: IOutArchive read GetOutArchive;\r\n end;\r\n\r\n // file formats\r\n\r\n TJclZipCompressArchive = class(TJclSevenzipCompressArchive, IJclArchiveCompressionLevel, IJclArchiveCompressionMethod,\r\n IJclArchiveEncryptionMethod, IJclArchiveDictionarySize, IJclArchiveNumberOfPasses, IJclArchiveNumberOfThreads,\r\n IJclArchiveAlgorithm, IInterface)\r\n private\r\n FNumberOfThreads: Cardinal;\r\n FEncryptionMethod: TJclEncryptionMethod;\r\n FDictionarySize: Cardinal;\r\n FCompressionLevel: Cardinal;\r\n FCompressionMethod: TJclCompressionMethod;\r\n FNumberOfPasses: Cardinal;\r\n FAlgorithm: Cardinal;\r\n protected\r\n procedure InitializeArchiveProperties; override;\r\n public\r\n class function MultipleItemContainer: Boolean; override;\r\n class function ArchiveExtensions: string; override;\r\n class function ArchiveName: string; override;\r\n class function ArchiveCLSID: TGUID; override;\r\n { IJclArchiveNumberOfThreads }\r\n function GetNumberOfThreads: Cardinal;\r\n procedure SetNumberOfThreads(Value: Cardinal);\r\n { IJclArchiveEncryptionMethod }\r\n function GetEncryptionMethod: TJclEncryptionMethod;\r\n function GetSupportedEncryptionMethods: TJclEncryptionMethods;\r\n procedure SetEncryptionMethod(Value: TJclEncryptionMethod);\r\n { IJclArchiveDictionarySize }\r\n function GetDictionarySize: Cardinal;\r\n procedure SetDictionarySize(Value: Cardinal);\r\n { IJclArchiveCompressionLevel }\r\n function GetCompressionLevel: Cardinal;\r\n function GetCompressionLevelMax: Cardinal;\r\n function GetCompressionLevelMin: Cardinal;\r\n procedure SetCompressionLevel(Value: Cardinal);\r\n { IJclArchiveCompressionMethod }\r\n function GetCompressionMethod: TJclCompressionMethod;\r\n function GetSupportedCompressionMethods: TJclCompressionMethods;\r\n procedure SetCompressionMethod(Value: TJclCompressionMethod);\r\n { IJclArchiveNumberOfPasses }\r\n function GetNumberOfPasses: Cardinal;\r\n procedure SetNumberOfPasses(Value: Cardinal);\r\n { IJclArchiveAlgoritm }\r\n function GetAlgorithm: Cardinal;\r\n function GetSupportedAlgorithms: TDynCardinalArray;\r\n procedure SetAlgorithm(Value: Cardinal);\r\n end;\r\n\r\n TJclBZ2CompressArchive = class(TJclSevenzipCompressArchive, IJclArchiveCompressionLevel, IJclArchiveDictionarySize,\r\n IJclArchiveNumberOfPasses, IJclArchiveNumberOfThreads, IInterface)\r\n private\r\n FNumberOfThreads: Cardinal;\r\n FDictionarySize: Cardinal;\r\n FCompressionLevel: Cardinal;\r\n FNumberOfPasses: Cardinal;\r\n protected\r\n procedure InitializeArchiveProperties; override;\r\n public\r\n class function ArchiveExtensions: string; override;\r\n class function ArchiveName: string; override;\r\n class function ArchiveSubExtensions: string; override;\r\n class function ArchiveCLSID: TGUID; override;\r\n { IJclArchiveNumberOfThreads }\r\n function GetNumberOfThreads: Cardinal;\r\n procedure SetNumberOfThreads(Value: Cardinal);\r\n { IJclArchiveDictionarySize }\r\n function GetDictionarySize: Cardinal;\r\n procedure SetDictionarySize(Value: Cardinal);\r\n { IJclArchiveCompressionLevel }\r\n function GetCompressionLevel: Cardinal;\r\n function GetCompressionLevelMax: Cardinal;\r\n function GetCompressionLevelMin: Cardinal;\r\n procedure SetCompressionLevel(Value: Cardinal);\r\n { IJclArchiveNumberOfPasses }\r\n function GetNumberOfPasses: Cardinal;\r\n procedure SetNumberOfPasses(Value: Cardinal);\r\n end;\r\n\r\n TJcl7zCompressArchive = class(TJclSevenzipCompressArchive, IJclArchiveCompressionLevel, IJclArchiveDictionarySize,\r\n IJclArchiveNumberOfThreads, IJclArchiveRemoveSfxBlock, IJclArchiveCompressHeader, IJclArchiveEncryptHeader,\r\n IJclArchiveSaveCreationDateTime, IJclArchiveSaveLastAccessDateTime, IJclArchiveSaveLastWriteDateTime,\r\n IJclArchiveSolid, IInterface)\r\n private\r\n FNumberOfThreads: Cardinal;\r\n FEncryptHeader: Boolean;\r\n FRemoveSfxBlock: Boolean;\r\n FDictionarySize: Cardinal;\r\n FCompressionLevel: Cardinal;\r\n FCompressHeader: Boolean;\r\n FCompressHeaderFull: Boolean;\r\n FSaveLastAccessDateTime: Boolean;\r\n FSaveCreationDateTime: Boolean;\r\n FSaveLastWriteDateTime: Boolean;\r\n FSolidBlockSize: Int64;\r\n FSolidExtension: Boolean;\r\n protected\r\n procedure InitializeArchiveProperties; override;\r\n public\r\n class function MultipleItemContainer: Boolean; override;\r\n class function ArchiveExtensions: string; override;\r\n class function ArchiveName: string; override;\r\n class function ArchiveCLSID: TGUID; override;\r\n { IJclArchiveNumberOfThreads }\r\n function GetNumberOfThreads: Cardinal;\r\n procedure SetNumberOfThreads(Value: Cardinal);\r\n { IJclArchiveEncryptHeader }\r\n function GetEncryptHeader: Boolean;\r\n procedure SetEncryptHeader(Value: Boolean);\r\n { IJclArchiveRemoveSfxBlock }\r\n function GetRemoveSfxBlock: Boolean;\r\n procedure SetRemoveSfxBlock(Value: Boolean);\r\n { IJclArchiveDictionarySize }\r\n function GetDictionarySize: Cardinal;\r\n procedure SetDictionarySize(Value: Cardinal);\r\n { IJclArchiveCompressionLevel }\r\n function GetCompressionLevel: Cardinal;\r\n function GetCompressionLevelMax: Cardinal;\r\n function GetCompressionLevelMin: Cardinal;\r\n procedure SetCompressionLevel(Value: Cardinal);\r\n { IJclArchiveCompressHeader }\r\n function GetCompressHeader: Boolean;\r\n function GetCompressHeaderFull: Boolean;\r\n procedure SetCompressHeader(Value: Boolean);\r\n procedure SetCompressHeaderFull(Value: Boolean);\r\n { IJclArchiveSaveLastAccessDateTime }\r\n function GetSaveLastAccessDateTime: Boolean;\r\n procedure SetSaveLastAccessDateTime(Value: Boolean);\r\n { IJclArchiveSaveCreationDateTime }\r\n function GetSaveCreationDateTime: Boolean;\r\n procedure SetSaveCreationDateTime(Value: Boolean);\r\n { IJclArchiveSaveLastWriteDateTime }\r\n function GetSaveLastWriteDateTime: Boolean;\r\n procedure SetSaveLastWriteDateTime(Value: Boolean);\r\n { IJclArchiveSolid }\r\n function GetSolidBlockSize: Int64;\r\n function GetSolidExtension: Boolean;\r\n procedure SetSolidBlockSize(const Value: Int64);\r\n procedure SetSolidExtension(Value: Boolean);\r\n end;\r\n\r\n TJclTarCompressArchive = class(TJclSevenzipCompressArchive, IInterface)\r\n public\r\n class function MultipleItemContainer: Boolean; override;\r\n class function ArchiveExtensions: string; override;\r\n class function ArchiveName: string; override;\r\n class function ArchiveCLSID: TGUID; override;\r\n end;\r\n\r\n TJclGZipCompressArchive = class(TJclSevenzipCompressArchive, IJclArchiveCompressionLevel, IJclArchiveNumberOfPasses,\r\n IJclArchiveAlgorithm, IInterface)\r\n private\r\n FCompressionLevel: Cardinal;\r\n FNumberOfPasses: Cardinal;\r\n FAlgorithm: Cardinal;\r\n protected\r\n procedure InitializeArchiveProperties; override;\r\n public\r\n class function ArchiveExtensions: string; override;\r\n class function ArchiveName: string; override;\r\n class function ArchiveSubExtensions: string; override;\r\n class function ArchiveCLSID: TGUID; override;\r\n { IJclArchiveCompressionLevel }\r\n function GetCompressionLevel: Cardinal;\r\n function GetCompressionLevelMax: Cardinal;\r\n function GetCompressionLevelMin: Cardinal;\r\n procedure SetCompressionLevel(Value: Cardinal);\r\n { IJclArchiveNumberOfPasses }\r\n function GetNumberOfPasses: Cardinal;\r\n procedure SetNumberOfPasses(Value: Cardinal);\r\n { IJclArchiveAlgorithm }\r\n function GetAlgorithm: Cardinal;\r\n function GetSupportedAlgorithms: TDynCardinalArray;\r\n procedure SetAlgorithm(Value: Cardinal);\r\n end;\r\n\r\n TJclXzCompressArchive = class(TJclSevenzipCompressArchive, IJclArchiveCompressionMethod, IInterface)\r\n private\r\n FCompressionMethod: TJclCompressionMethod;\r\n protected\r\n procedure InitializeArchiveProperties; override;\r\n public\r\n class function ArchiveExtensions: string; override;\r\n class function ArchiveName: string; override;\r\n class function ArchiveSubExtensions: string; override;\r\n class function ArchiveCLSID: TGUID; override;\r\n { IJclArchiveCompressionMethod }\r\n function GetCompressionMethod: TJclCompressionMethod;\r\n function GetSupportedCompressionMethods: TJclCompressionMethods;\r\n procedure SetCompressionMethod(Value: TJclCompressionMethod);\r\n end;\r\n\r\n TJclSwfcCompressArchive = class(TJclSevenzipCompressArchive, IInterface)\r\n public\r\n class function ArchiveExtensions: string; override;\r\n class function ArchiveName: string; override;\r\n class function ArchiveCLSID: TGUID; override;\r\n end;\r\n\r\n TJclWimCompressArchive = class(TJclSevenzipCompressArchive, IInterface)\r\n public\r\n class function ArchiveExtensions: string; override;\r\n class function ArchiveName: string; override;\r\n class function ArchiveCLSID: TGUID; override;\r\n end;\r\n\r\n// sevenzip classes for decompression\r\ntype\r\n TJclSevenzipDecompressItem = class(TJclDecompressItem)\r\n protected\r\n function GetNestedArchiveStream: TStream; override;\r\n end;\r\n\r\n TJclSevenzipDecompressArchive = class(TJclDecompressArchive, IInterface)\r\n private\r\n FInArchive: IInArchive;\r\n FInArchiveGetStream: IInArchiveGetStream;\r\n FOpened: Boolean;\r\n protected\r\n procedure OpenArchive;\r\n function GetInArchive: IInArchive;\r\n function GetInArchiveGetStream: IInArchiveGetStream;\r\n function GetItemClass: TJclCompressionItemClass; override;\r\n function GetSupportsNestedArchive: Boolean; override;\r\n public\r\n class function ArchiveCLSID: TGUID; virtual;\r\n class function ArchiveSignature: TDynByteArray; override;\r\n destructor Destroy; override;\r\n procedure ListFiles; override;\r\n procedure ExtractSelected(const ADestinationDir: string = '';\r\n AAutoCreateSubDir: Boolean = True); override;\r\n procedure ExtractAll(const ADestinationDir: string = '';\r\n AAutoCreateSubDir: Boolean = True); override;\r\n property InArchive: IInArchive read GetInArchive;\r\n property InArchiveGetStream: IInArchiveGetStream read GetInArchiveGetStream;\r\n end;\r\n\r\n // file formats\r\n\r\n TJclZipDecompressArchive = class(TJclSevenzipDecompressArchive, IJclArchiveNumberOfThreads, IInterface)\r\n private\r\n FNumberOfThreads: Cardinal;\r\n protected\r\n procedure InitializeArchiveProperties; override;\r\n public\r\n class function MultipleItemContainer: Boolean; override;\r\n class function ArchiveExtensions: string; override;\r\n class function ArchiveName: string; override;\r\n class function ArchiveCLSID: TGUID; override;\r\n { IJclArchiveNumberOfThreads }\r\n function GetNumberOfThreads: Cardinal;\r\n procedure SetNumberOfThreads(Value: Cardinal);\r\n end;\r\n\r\n TJclBZ2DecompressArchive = class(TJclSevenzipDecompressArchive, IJclArchiveNumberOfThreads, IInterface)\r\n private\r\n FNumberOfThreads: Cardinal;\r\n protected\r\n procedure InitializeArchiveProperties; override;\r\n public\r\n class function ArchiveExtensions: string; override;\r\n class function ArchiveName: string; override;\r\n class function ArchiveSubExtensions: string; override;\r\n class function ArchiveCLSID: TGUID; override;\r\n { IJclArchiveNumberOfThreads }\r\n function GetNumberOfThreads: Cardinal;\r\n procedure SetNumberOfThreads(Value: Cardinal);\r\n end;\r\n\r\n TJclRarDecompressArchive = class(TJclSevenzipDecompressArchive, IInterface)\r\n public\r\n class function MultipleItemContainer: Boolean; override;\r\n class function ArchiveExtensions: string; override;\r\n class function ArchiveName: string; override;\r\n class function ArchiveCLSID: TGUID; override;\r\n end;\r\n\r\n TJclArjDecompressArchive = class(TJclSevenzipDecompressArchive, IInterface)\r\n public\r\n class function MultipleItemContainer: Boolean; override;\r\n class function ArchiveExtensions: string; override;\r\n class function ArchiveName: string; override;\r\n class function ArchiveCLSID: TGUID; override;\r\n end;\r\n\r\n TJclZDecompressArchive = class(TJclSevenzipDecompressArchive, IInterface)\r\n public\r\n class function MultipleItemContainer: Boolean; override;\r\n class function ArchiveExtensions: string; override;\r\n class function ArchiveName: string; override;\r\n class function ArchiveSubExtensions: string; override;\r\n class function ArchiveCLSID: TGUID; override;\r\n end;\r\n\r\n TJclLzhDecompressArchive = class(TJclSevenzipDecompressArchive, IInterface)\r\n public\r\n class function MultipleItemContainer: Boolean; override;\r\n class function ArchiveExtensions: string; override;\r\n class function ArchiveName: string; override;\r\n class function ArchiveCLSID: TGUID; override;\r\n end;\r\n\r\n TJcl7zDecompressArchive = class(TJclSevenzipDecompressArchive, IJclArchiveNumberOfThreads, IInterface)\r\n private\r\n FNumberOfThreads: Cardinal;\r\n protected\r\n procedure InitializeArchiveProperties; override;\r\n public\r\n class function MultipleItemContainer: Boolean; override;\r\n class function ArchiveExtensions: string; override;\r\n class function ArchiveName: string; override;\r\n class function ArchiveCLSID: TGUID; override;\r\n { IJclArchiveNumberOfThreads }\r\n function GetNumberOfThreads: Cardinal;\r\n procedure SetNumberOfThreads(Value: Cardinal);\r\n end;\r\n\r\n TJclCabDecompressArchive = class(TJclSevenzipDecompressArchive, IInterface)\r\n public\r\n class function MultipleItemContainer: Boolean; override;\r\n class function ArchiveExtensions: string; override;\r\n class function ArchiveName: string; override;\r\n class function ArchiveCLSID: TGUID; override;\r\n end;\r\n\r\n TJclNsisDecompressArchive = class(TJclSevenzipDecompressArchive, IInterface)\r\n public\r\n class function MultipleItemContainer: Boolean; override;\r\n class function ArchiveExtensions: string; override;\r\n class function ArchiveName: string; override;\r\n class function ArchiveCLSID: TGUID; override;\r\n end;\r\n\r\n TJclLzmaDecompressArchive = class(TJclSevenzipDecompressArchive, IInterface)\r\n public\r\n class function MultipleItemContainer: Boolean; override;\r\n class function ArchiveExtensions: string; override;\r\n class function ArchiveName: string; override;\r\n class function ArchiveCLSID: TGUID; override;\r\n end;\r\n\r\n TJclLzma86DecompressArchive = class(TJclSevenzipDecompressArchive, IInterface)\r\n public\r\n class function MultipleItemContainer: Boolean; override;\r\n class function ArchiveExtensions: string; override;\r\n class function ArchiveName: string; override;\r\n class function ArchiveCLSID: TGUID; override;\r\n end;\r\n\r\n TJclPeDecompressArchive = class(TJclSevenzipDecompressArchive, IInterface)\r\n public\r\n class function MultipleItemContainer: Boolean; override;\r\n class function ArchiveExtensions: string; override;\r\n class function ArchiveName: string; override;\r\n class function ArchiveCLSID: TGUID; override;\r\n end;\r\n\r\n TJclElfDecompressArchive = class(TJclSevenzipDecompressArchive, IInterface)\r\n public\r\n class function MultipleItemContainer: Boolean; override;\r\n class function ArchiveExtensions: string; override;\r\n class function ArchiveName: string; override;\r\n class function ArchiveCLSID: TGUID; override;\r\n end;\r\n\r\n TJclMachoDecompressArchive = class(TJclSevenzipDecompressArchive, IInterface)\r\n public\r\n class function MultipleItemContainer: Boolean; override;\r\n class function ArchiveExtensions: string; override;\r\n class function ArchiveName: string; override;\r\n class function ArchiveCLSID: TGUID; override;\r\n end;\r\n\r\n TJclUdfDecompressArchive = class(TJclSevenzipDecompressArchive, IInterface)\r\n public\r\n class function MultipleItemContainer: Boolean; override;\r\n class function ArchiveExtensions: string; override;\r\n class function ArchiveName: string; override;\r\n class function ArchiveCLSID: TGUID; override;\r\n end;\r\n\r\n TJclXarDecompressArchive = class(TJclSevenzipDecompressArchive, IInterface)\r\n public\r\n class function MultipleItemContainer: Boolean; override;\r\n class function ArchiveExtensions: string; override;\r\n class function ArchiveName: string; override;\r\n class function ArchiveCLSID: TGUID; override;\r\n end;\r\n\r\n TJclMubDecompressArchive = class(TJclSevenzipDecompressArchive, IInterface)\r\n public\r\n class function MultipleItemContainer: Boolean; override;\r\n class function ArchiveExtensions: string; override;\r\n class function ArchiveName: string; override;\r\n class function ArchiveCLSID: TGUID; override;\r\n end;\r\n\r\n TJclHfsDecompressArchive = class(TJclSevenzipDecompressArchive, IInterface)\r\n public\r\n class function MultipleItemContainer: Boolean; override;\r\n class function ArchiveExtensions: string; override;\r\n class function ArchiveName: string; override;\r\n class function ArchiveCLSID: TGUID; override;\r\n end;\r\n\r\n TJclDmgDecompressArchive = class(TJclSevenzipDecompressArchive, IInterface)\r\n public\r\n class function MultipleItemContainer: Boolean; override;\r\n class function ArchiveExtensions: string; override;\r\n class function ArchiveName: string; override;\r\n class function ArchiveCLSID: TGUID; override;\r\n end;\r\n\r\n TJclCompoundDecompressArchive = class(TJclSevenzipDecompressArchive, IInterface)\r\n public\r\n class function MultipleItemContainer: Boolean; override;\r\n class function ArchiveExtensions: string; override;\r\n class function ArchiveName: string; override;\r\n class function ArchiveCLSID: TGUID; override;\r\n end;\r\n\r\n TJclWimDecompressArchive = class(TJclSevenzipDecompressArchive, IInterface)\r\n public\r\n class function MultipleItemContainer: Boolean; override;\r\n class function ArchiveExtensions: string; override;\r\n class function ArchiveName: string; override;\r\n class function ArchiveCLSID: TGUID; override;\r\n end;\r\n\r\n TJclIsoDecompressArchive = class(TJclSevenzipDecompressArchive, IInterface)\r\n public\r\n class function MultipleItemContainer: Boolean; override;\r\n class function ArchiveExtensions: string; override;\r\n class function ArchiveName: string; override;\r\n class function ArchiveCLSID: TGUID; override;\r\n end;\r\n\r\n // not implemented in 9.04\r\n {TJclBkfDecompressArchive = class(TJclSevenzipDecompressArchive, IInterface)\r\n protected\r\n function GetCLSID: TGUID; override;\r\n public\r\n class function MultipleItemContainer: Boolean; override;\r\n class function ArchiveExtensions: string; override;\r\n class function ArchiveName: string; override;\r\n end;}\r\n\r\n TJclChmDecompressArchive = class(TJclSevenzipDecompressArchive, IInterface)\r\n public\r\n class function MultipleItemContainer: Boolean; override;\r\n class function ArchiveExtensions: string; override;\r\n class function ArchiveName: string; override;\r\n class function ArchiveCLSID: TGUID; override;\r\n end;\r\n\r\n TJclSplitDecompressArchive = class(TJclSevenzipDecompressArchive, IInterface)\r\n public\r\n class function ArchiveExtensions: string; override;\r\n class function ArchiveName: string; override;\r\n class function ArchiveCLSID: TGUID; override;\r\n end;\r\n\r\n TJclRpmDecompressArchive = class(TJclSevenzipDecompressArchive, IInterface)\r\n public\r\n class function MultipleItemContainer: Boolean; override;\r\n class function ArchiveExtensions: string; override;\r\n class function ArchiveName: string; override;\r\n class function ArchiveCLSID: TGUID; override;\r\n end;\r\n\r\n TJclDebDecompressArchive = class(TJclSevenzipDecompressArchive, IInterface)\r\n public\r\n class function MultipleItemContainer: Boolean; override;\r\n class function ArchiveExtensions: string; override;\r\n class function ArchiveName: string; override;\r\n class function ArchiveCLSID: TGUID; override;\r\n end;\r\n\r\n TJclCpioDecompressArchive = class(TJclSevenzipDecompressArchive, IInterface)\r\n public\r\n class function MultipleItemContainer: Boolean; override;\r\n class function ArchiveExtensions: string; override;\r\n class function ArchiveName: string; override;\r\n class function ArchiveCLSID: TGUID; override;\r\n end;\r\n\r\n TJclTarDecompressArchive = class(TJclSevenzipDecompressArchive, IInterface)\r\n public\r\n class function MultipleItemContainer: Boolean; override;\r\n class function ArchiveExtensions: string; override;\r\n class function ArchiveName: string; override;\r\n class function ArchiveCLSID: TGUID; override;\r\n end;\r\n\r\n TJclGZipDecompressArchive = class(TJclSevenzipDecompressArchive, IInterface)\r\n public\r\n class function ArchiveExtensions: string; override;\r\n class function ArchiveName: string; override;\r\n class function ArchiveSubExtensions: string; override;\r\n class function ArchiveCLSID: TGUID; override;\r\n end;\r\n\r\n TJclXzDecompressArchive = class(TJclSevenzipDecompressArchive, IInterface)\r\n public\r\n class function ArchiveExtensions: string; override;\r\n class function ArchiveName: string; override;\r\n class function ArchiveSubExtensions: string; override;\r\n class function ArchiveCLSID: TGUID; override;\r\n end;\r\n\r\n TJclNtfsDecompressArchive = class(TJclSevenzipDecompressArchive, IInterface)\r\n public\r\n class function MultipleItemContainer: Boolean; override;\r\n class function ArchiveExtensions: string; override;\r\n class function ArchiveName: string; override;\r\n class function ArchiveCLSID: TGUID; override;\r\n end;\r\n\r\n TJclFatDecompressArchive = class(TJclSevenzipDecompressArchive, IInterface)\r\n public\r\n class function MultipleItemContainer: Boolean; override;\r\n class function ArchiveExtensions: string; override;\r\n class function ArchiveName: string; override;\r\n class function ArchiveCLSID: TGUID; override;\r\n end;\r\n\r\n TJclMbrDecompressArchive = class(TJclSevenzipDecompressArchive, IInterface)\r\n public\r\n class function MultipleItemContainer: Boolean; override;\r\n class function ArchiveExtensions: string; override;\r\n class function ArchiveName: string; override;\r\n class function ArchiveCLSID: TGUID; override;\r\n end;\r\n\r\n TJclVhdDecompressArchive = class(TJclSevenzipDecompressArchive, IInterface)\r\n public\r\n class function ArchiveExtensions: string; override;\r\n class function ArchiveName: string; override;\r\n class function ArchiveSubExtensions: string; override;\r\n class function ArchiveCLSID: TGUID; override;\r\n end;\r\n\r\n TJclMslzDecompressArchive = class(TJclSevenzipDecompressArchive, IInterface)\r\n public\r\n class function ArchiveExtensions: string; override;\r\n class function ArchiveName: string; override;\r\n class function ArchiveCLSID: TGUID; override;\r\n end;\r\n\r\n TJclFlvDecompressArchive = class(TJclSevenzipDecompressArchive, IInterface)\r\n public\r\n class function ArchiveExtensions: string; override;\r\n class function ArchiveName: string; override;\r\n class function ArchiveCLSID: TGUID; override;\r\n end;\r\n\r\n TJclSwfDecompressArchive = class(TJclSevenzipDecompressArchive, IInterface)\r\n public\r\n class function ArchiveExtensions: string; override;\r\n class function ArchiveName: string; override;\r\n class function ArchiveCLSID: TGUID; override;\r\n end;\r\n\r\n TJclSwfcDecompressArchive = class(TJclSevenzipDecompressArchive, IInterface)\r\n public\r\n class function ArchiveExtensions: string; override;\r\n class function ArchiveName: string; override;\r\n class function ArchiveCLSID: TGUID; override;\r\n end;\r\n\r\n TJclAPMDecompressArchive = class(TJclSevenzipDecompressArchive, IInterface)\r\n public\r\n class function ArchiveExtensions: string; override;\r\n class function ArchiveName: string; override;\r\n class function ArchiveCLSID: TGUID; override;\r\n end;\r\n\r\n TJclPpmdDecompressArchive = class(TJclSevenzipDecompressArchive, IInterface)\r\n public\r\n class function ArchiveExtensions: string; override;\r\n class function ArchiveName: string; override;\r\n class function ArchiveCLSID: TGUID; override;\r\n end;\r\n\r\n TJclTEDecompressArchive = class(TJclSevenzipDecompressArchive, IInterface)\r\n public\r\n class function ArchiveExtensions: string; override;\r\n class function ArchiveName: string; override;\r\n class function ArchiveCLSID: TGUID; override;\r\n end;\r\n\r\n TJclUEFIcDecompressArchive = class(TJclSevenzipDecompressArchive, IInterface)\r\n public\r\n class function ArchiveExtensions: string; override;\r\n class function ArchiveName: string; override;\r\n class function ArchiveCLSID: TGUID; override;\r\n end;\r\n\r\n TJclUEFIsDecompressArchive = class(TJclSevenzipDecompressArchive, IInterface)\r\n public\r\n class function ArchiveExtensions: string; override;\r\n class function ArchiveName: string; override;\r\n class function ArchiveCLSID: TGUID; override;\r\n end;\r\n\r\n TJclSquashFSDecompressArchive = class(TJclSevenzipDecompressArchive, IInterface)\r\n public\r\n class function ArchiveExtensions: string; override;\r\n class function ArchiveName: string; override;\r\n class function ArchiveCLSID: TGUID; override;\r\n end;\r\n\r\n TJclCramFSDecompressArchive = class(TJclSevenzipDecompressArchive, IInterface)\r\n public\r\n class function ArchiveExtensions: string; override;\r\n class function ArchiveName: string; override;\r\n class function ArchiveCLSID: TGUID; override;\r\n end;\r\n\r\n//sevenzip classes for updates (read and write)\r\ntype\r\n TJclSevenzipUpdateArchive = class(TJclOutOfPlaceUpdateArchive, IInterface)\r\n private\r\n FInArchive: IInArchive;\r\n FOutArchive: IOutArchive;\r\n FOpened: Boolean;\r\n protected\r\n procedure OpenArchive;\r\n function GetInArchive: IInArchive;\r\n function GetItemClass: TJclCompressionItemClass; override;\r\n function GetOutArchive: IOutArchive;\r\n public\r\n class function ArchiveCLSID: TGUID; virtual;\r\n class function ArchiveSignature: TDynByteArray; override;\r\n destructor Destroy; override;\r\n procedure ListFiles; override;\r\n procedure ExtractSelected(const ADestinationDir: string = '';\r\n AAutoCreateSubDir: Boolean = True); override;\r\n procedure ExtractAll(const ADestinationDir: string = '';\r\n AAutoCreateSubDir: Boolean = True); override;\r\n procedure Compress; override;\r\n procedure DeleteItem(Index: Integer); override;\r\n procedure RemoveItem(const PackedName: WideString); override;\r\n property InArchive: IInArchive read GetInArchive;\r\n property OutArchive: IOutArchive read GetOutArchive;\r\n end;\r\n\r\n TJclZipUpdateArchive = class(TJclSevenzipUpdateArchive, IJclArchiveCompressionLevel, IJclArchiveCompressionMethod,\r\n IJclArchiveEncryptionMethod, IJclArchiveDictionarySize, IJclArchiveNumberOfPasses, IJclArchiveNumberOfThreads,\r\n IJclArchiveAlgorithm, IInterface)\r\n private\r\n FNumberOfThreads: Cardinal;\r\n FEncryptionMethod: TJclEncryptionMethod;\r\n FDictionarySize: Cardinal;\r\n FCompressionLevel: Cardinal;\r\n FCompressionMethod: TJclCompressionMethod;\r\n FNumberOfPasses: Cardinal;\r\n FAlgorithm: Cardinal;\r\n protected\r\n procedure InitializeArchiveProperties; override;\r\n public\r\n class function MultipleItemContainer: Boolean; override;\r\n class function ArchiveExtensions: string; override;\r\n class function ArchiveName: string; override;\r\n class function ArchiveCLSID: TGUID; override;\r\n { IJclArchiveNumberOfThreads }\r\n function GetNumberOfThreads: Cardinal;\r\n procedure SetNumberOfThreads(Value: Cardinal);\r\n { IJclArchiveEncryptionMethod }\r\n function GetEncryptionMethod: TJclEncryptionMethod;\r\n function GetSupportedEncryptionMethods: TJclEncryptionMethods;\r\n procedure SetEncryptionMethod(Value: TJclEncryptionMethod);\r\n { IJclArchiveDictionarySize }\r\n function GetDictionarySize: Cardinal;\r\n procedure SetDictionarySize(Value: Cardinal);\r\n { IJclArchiveCompressionLevel }\r\n function GetCompressionLevel: Cardinal;\r\n function GetCompressionLevelMax: Cardinal;\r\n function GetCompressionLevelMin: Cardinal;\r\n procedure SetCompressionLevel(Value: Cardinal);\r\n { IJclArchiveCompressionMethod }\r\n function GetCompressionMethod: TJclCompressionMethod;\r\n function GetSupportedCompressionMethods: TJclCompressionMethods;\r\n procedure SetCompressionMethod(Value: TJclCompressionMethod);\r\n { IJclArchiveNumberOfPasses }\r\n function GetNumberOfPasses: Cardinal;\r\n procedure SetNumberOfPasses(Value: Cardinal);\r\n { IJclArchiveAlgoritm }\r\n function GetAlgorithm: Cardinal;\r\n function GetSupportedAlgorithms: TDynCardinalArray;\r\n procedure SetAlgorithm(Value: Cardinal);\r\n end;\r\n\r\n TJclBZ2UpdateArchive = class(TJclSevenzipUpdateArchive, IJclArchiveCompressionLevel, IJclArchiveDictionarySize,\r\n IJclArchiveNumberOfPasses, IJclArchiveNumberOfThreads, IInterface)\r\n private\r\n FNumberOfThreads: Cardinal;\r\n FDictionarySize: Cardinal;\r\n FCompressionLevel: Cardinal;\r\n FNumberOfPasses: Cardinal;\r\n protected\r\n procedure InitializeArchiveProperties; override;\r\n public\r\n class function ArchiveExtensions: string; override;\r\n class function ArchiveName: string; override;\r\n class function ArchiveSubExtensions: string; override;\r\n class function ArchiveCLSID: TGUID; override;\r\n { IJclArchiveNumberOfThreads }\r\n function GetNumberOfThreads: Cardinal;\r\n procedure SetNumberOfThreads(Value: Cardinal);\r\n { IJclArchiveDictionarySize }\r\n function GetDictionarySize: Cardinal;\r\n procedure SetDictionarySize(Value: Cardinal);\r\n { IJclArchiveCompressionLevel }\r\n function GetCompressionLevel: Cardinal;\r\n function GetCompressionLevelMax: Cardinal;\r\n function GetCompressionLevelMin: Cardinal;\r\n procedure SetCompressionLevel(Value: Cardinal);\r\n { IJclArchiveNumberOfPasses }\r\n function GetNumberOfPasses: Cardinal;\r\n procedure SetNumberOfPasses(Value: Cardinal);\r\n end;\r\n\r\n TJcl7zUpdateArchive = class(TJclSevenzipUpdateArchive, IJclArchiveCompressionLevel, IJclArchiveDictionarySize,\r\n IJclArchiveNumberOfThreads, IJclArchiveRemoveSfxBlock, IJclArchiveCompressHeader, IJclArchiveEncryptHeader,\r\n IJclArchiveSaveCreationDateTime, IJclArchiveSaveLastAccessDateTime, IJclArchiveSaveLastWriteDateTime, IInterface)\r\n private\r\n FNumberOfThreads: Cardinal;\r\n FEncryptHeader: Boolean;\r\n FRemoveSfxBlock: Boolean;\r\n FDictionarySize: Cardinal;\r\n FCompressionLevel: Cardinal;\r\n FCompressHeader: Boolean;\r\n FCompressHeaderFull: Boolean;\r\n FSaveLastAccessDateTime: Boolean;\r\n FSaveCreationDateTime: Boolean;\r\n FSaveLastWriteDateTime: Boolean;\r\n protected\r\n procedure InitializeArchiveProperties; override;\r\n public\r\n class function MultipleItemContainer: Boolean; override;\r\n class function ArchiveExtensions: string; override;\r\n class function ArchiveName: string; override;\r\n class function ArchiveCLSID: TGUID; override;\r\n { IJclArchiveNumberOfThreads }\r\n function GetNumberOfThreads: Cardinal;\r\n procedure SetNumberOfThreads(Value: Cardinal);\r\n { IJclArchiveEncryptHeader }\r\n function GetEncryptHeader: Boolean;\r\n procedure SetEncryptHeader(Value: Boolean);\r\n { IJclArchiveRemoveSfxBlock }\r\n function GetRemoveSfxBlock: Boolean;\r\n procedure SetRemoveSfxBlock(Value: Boolean);\r\n { IJclArchiveDictionarySize }\r\n function GetDictionarySize: Cardinal;\r\n procedure SetDictionarySize(Value: Cardinal);\r\n { IJclArchiveCompressionLevel }\r\n function GetCompressionLevel: Cardinal;\r\n function GetCompressionLevelMax: Cardinal;\r\n function GetCompressionLevelMin: Cardinal;\r\n procedure SetCompressionLevel(Value: Cardinal);\r\n { IJclArchiveCompressHeader }\r\n function GetCompressHeader: Boolean;\r\n function GetCompressHeaderFull: Boolean;\r\n procedure SetCompressHeader(Value: Boolean);\r\n procedure SetCompressHeaderFull(Value: Boolean);\r\n { IJclArchiveSaveLastAccessDateTime }\r\n function GetSaveLastAccessDateTime: Boolean;\r\n procedure SetSaveLastAccessDateTime(Value: Boolean);\r\n { IJclArchiveSaveCreationDateTime }\r\n function GetSaveCreationDateTime: Boolean;\r\n procedure SetSaveCreationDateTime(Value: Boolean);\r\n { IJclArchiveSaveLastWriteDateTime }\r\n function GetSaveLastWriteDateTime: Boolean;\r\n procedure SetSaveLastWriteDateTime(Value: Boolean);\r\n end;\r\n\r\n TJclTarUpdateArchive = class(TJclSevenzipUpdateArchive, IInterface)\r\n public\r\n class function MultipleItemContainer: Boolean; override;\r\n class function ArchiveExtensions: string; override;\r\n class function ArchiveName: string; override;\r\n class function ArchiveCLSID: TGUID; override;\r\n end;\r\n\r\n TJclGZipUpdateArchive = class(TJclSevenzipUpdateArchive, IJclArchiveCompressionLevel, IJclArchiveNumberOfPasses,\r\n IJclArchiveAlgorithm, IInterface)\r\n private\r\n FCompressionLevel: Cardinal;\r\n FNumberOfPasses: Cardinal;\r\n FAlgorithm: Cardinal;\r\n protected\r\n procedure InitializeArchiveProperties; override;\r\n public\r\n class function ArchiveExtensions: string; override;\r\n class function ArchiveName: string; override;\r\n class function ArchiveSubExtensions: string; override;\r\n class function ArchiveCLSID: TGUID; override;\r\n { IJclArchiveCompressionLevel }\r\n function GetCompressionLevel: Cardinal;\r\n function GetCompressionLevelMax: Cardinal;\r\n function GetCompressionLevelMin: Cardinal;\r\n procedure SetCompressionLevel(Value: Cardinal);\r\n { IJclArchiveNumberOfPasses }\r\n function GetNumberOfPasses: Cardinal;\r\n procedure SetNumberOfPasses(Value: Cardinal);\r\n { IJclArchiveAlgorithm }\r\n function GetAlgorithm: Cardinal;\r\n function GetSupportedAlgorithms: TDynCardinalArray;\r\n procedure SetAlgorithm(Value: Cardinal);\r\n end;\r\n\r\n TJclXzUpdateArchive = class(TJclSevenzipUpdateArchive, IJclArchiveCompressionMethod, IInterface)\r\n private\r\n FCompressionMethod: TJclCompressionMethod;\r\n protected\r\n procedure InitializeArchiveProperties; override;\r\n public\r\n class function ArchiveExtensions: string; override;\r\n class function ArchiveName: string; override;\r\n class function ArchiveSubExtensions: string; override;\r\n class function ArchiveCLSID: TGUID; override;\r\n { IJclArchiveCompressionMethod }\r\n function GetCompressionMethod: TJclCompressionMethod;\r\n function GetSupportedCompressionMethods: TJclCompressionMethods;\r\n procedure SetCompressionMethod(Value: TJclCompressionMethod);\r\n end;\r\n\r\n TJclSwfcUpdateArchive = class(TJclSevenzipUpdateArchive, IInterface)\r\n public\r\n class function ArchiveExtensions: string; override;\r\n class function ArchiveName: string; override;\r\n class function ArchiveCLSID: TGUID; override;\r\n end;\r\n\r\n// internal sevenzip stuff, do not use it directly\r\ntype\r\n TJclSevenzipOutStream = class(TInterfacedObject, ISequentialOutStream,\r\n IOutStream, IUnknown)\r\n private\r\n FArchive: TJclCompressionArchive;\r\n FItemIndex: Integer;\r\n FStream: TStream;\r\n FOwnsStream: Boolean;\r\n FTruncateOnRelease: Boolean;\r\n FMaximumPosition: Int64;\r\n procedure NeedStream;\r\n procedure ReleaseStream;\r\n public\r\n constructor Create(AArchive: TJclCompressionArchive; AItemIndex: Integer); overload;\r\n constructor Create(AStream: TStream; AOwnsStream: Boolean; ATruncateOnRelease: Boolean); overload;\r\n destructor Destroy; override;\r\n // ISequentialOutStream\r\n function Write(Data: Pointer; Size: Cardinal; ProcessedSize: PCardinal): HRESULT; stdcall;\r\n // IOutStream\r\n function Seek(Offset: Int64; SeekOrigin: Cardinal; NewPosition: PInt64): HRESULT; stdcall;\r\n function SetSize(NewSize: Int64): HRESULT; stdcall;\r\n end;\r\n\r\n TJclSevenzipNestedInStream = class(TJclStream)\r\n private\r\n FInStream: IInStream;\r\n protected\r\n procedure SetSize(const NewSize: Int64); override;\r\n public\r\n constructor Create(AInStream: IInStream);\r\n function Read(var Buffer; Count: Longint): Longint; override;\r\n function Write(const Buffer; Count: Longint): Longint; override;\r\n function Seek(const Offset: Int64; Origin: TSeekOrigin): Int64; override;\r\n end;\r\n\r\n TJclSevenzipInStream = class(TInterfacedObject, ISequentialInStream,\r\n IInStream, IStreamGetSize, IUnknown)\r\n private\r\n FArchive: TJclCompressionArchive;\r\n FItemIndex: Integer;\r\n FStream: TStream;\r\n FOwnsStream: Boolean;\r\n procedure NeedStream;\r\n procedure ReleaseStream;\r\n public\r\n constructor Create(AArchive: TJclCompressionArchive; AItemIndex: Integer); overload;\r\n constructor Create(AStream: TStream; AOwnsStream: Boolean); overload;\r\n destructor Destroy; override;\r\n // ISequentialInStream\r\n function Read(Data: Pointer; Size: Cardinal; ProcessedSize: PCardinal): HRESULT; stdcall;\r\n // IInStream\r\n function Seek(Offset: Int64; SeekOrigin: Cardinal; NewPosition: PInt64): HRESULT; stdcall;\r\n // IStreamGetSize\r\n function GetSize(Size: PInt64): HRESULT; stdcall;\r\n end;\r\n\r\n TJclSevenzipOpenCallback = class(TInterfacedObject, IArchiveOpenCallback,\r\n ICryptoGetTextPassword, IUnknown)\r\n private\r\n FArchive: TJclCompressionArchive;\r\n public\r\n constructor Create(AArchive: TJclCompressionArchive);\r\n // IArchiveOpenCallback\r\n function SetCompleted(Files: PInt64; Bytes: PInt64): HRESULT; stdcall;\r\n function SetTotal(Files: PInt64; Bytes: PInt64): HRESULT; stdcall;\r\n // ICryptoGetTextPassword\r\n function CryptoGetTextPassword(password: PBStr): HRESULT; stdcall;\r\n end;\r\n\r\n TJclSevenzipExtractCallback = class(TInterfacedObject, IUnknown, IProgress,\r\n IArchiveExtractCallback, ICryptoGetTextPassword, ICompressProgressInfo)\r\n private\r\n FArchive: TJclCompressionArchive;\r\n FLastStream: Cardinal;\r\n public\r\n constructor Create(AArchive: TJclCompressionArchive);\r\n // IArchiveExtractCallback\r\n function GetStream(Index: Cardinal; out OutStream: ISequentialOutStream;\r\n askExtractMode: Cardinal): HRESULT; stdcall;\r\n function PrepareOperation(askExtractMode: Cardinal): HRESULT; stdcall;\r\n function SetOperationResult(resultEOperationResult: Integer): HRESULT; stdcall;\r\n // IProgress\r\n function SetCompleted(CompleteValue: PInt64): HRESULT; stdcall;\r\n function SetTotal(Total: Int64): HRESULT; stdcall;\r\n // ICryptoGetTextPassword\r\n function CryptoGetTextPassword(password: PBStr): HRESULT; stdcall;\r\n // ICompressProgressInfo\r\n function SetRatioInfo(InSize: PInt64; OutSize: PInt64): HRESULT; stdcall;\r\n end;\r\n\r\n TJclSevenzipUpdateCallback = class(TInterfacedObject, IUnknown, IProgress,\r\n IArchiveUpdateCallback, IArchiveUpdateCallback2, ICryptoGetTextPassword2,\r\n ICompressProgressInfo)\r\n private\r\n FArchive: TJclCompressionArchive;\r\n FLastStream: Cardinal;\r\n public\r\n constructor Create(AArchive: TJclCompressionArchive);\r\n // IProgress\r\n function SetCompleted(CompleteValue: PInt64): HRESULT; stdcall;\r\n function SetTotal(Total: Int64): HRESULT; stdcall;\r\n // IArchiveUpdateCallback\r\n function GetProperty(Index: Cardinal; PropID: Cardinal; out Value: tagPROPVARIANT): HRESULT; stdcall;\r\n function GetStream(Index: Cardinal; out InStream: ISequentialInStream): HRESULT; stdcall;\r\n function GetUpdateItemInfo(Index: Cardinal; NewData: PInteger;\r\n NewProperties: PInteger; IndexInArchive: PCardinal): HRESULT; stdcall;\r\n function SetOperationResult(OperationResult: Integer): HRESULT; stdcall;\r\n // IArchiveUpdateCallback2\r\n function GetVolumeSize(Index: Cardinal; Size: PInt64): HRESULT; stdcall;\r\n function GetVolumeStream(Index: Cardinal;\r\n out VolumeStream: ISequentialOutStream): HRESULT; stdcall;\r\n // ICryptoGetTextPassword2\r\n function CryptoGetTextPassword2(PasswordIsDefined: PInteger;\r\n Password: PBStr): HRESULT; stdcall;\r\n // ICompressProgressInfo \r\n function SetRatioInfo(InSize: PInt64; OutSize: PInt64): HRESULT; stdcall;\r\n end;\r\n\r\ntype\r\n TWideStringSetter = procedure (const Value: WideString) of object;\r\n TCardinalSetter = procedure (Value: Cardinal) of object;\r\n TInt64Setter = procedure (const Value: Int64) of object;\r\n TFileTimeSetter = procedure (const Value: TFileTime) of object;\r\n TBoolSetter = procedure (Value: Boolean) of object;\r\n\r\nprocedure SevenzipCheck(Value: HRESULT);\r\nfunction Get7zWideStringProp(const AArchive: IInArchive; ItemIndex: Integer;\r\n PropID: Cardinal; const Setter: TWideStringSetter): Boolean;\r\nfunction Get7zCardinalProp(const AArchive: IInArchive; ItemIndex: Integer;\r\n PropID: Cardinal; const Setter: TCardinalSetter): Boolean;\r\nfunction Get7zInt64Prop(const AArchive: IInArchive; ItemIndex: Integer;\r\n PropID: Cardinal; const Setter: TInt64Setter): Boolean;\r\nfunction Get7zFileTimeProp(const AArchive: IInArchive; ItemIndex: Integer;\r\n PropID: Cardinal; const Setter: TFileTimeSetter): Boolean;\r\nfunction Get7zBoolProp(const AArchive: IInArchive; ItemIndex: Integer;\r\n PropID: Cardinal; const Setter: TBoolSetter): Boolean;\r\nprocedure Load7zFileAttribute(AInArchive: IInArchive; ItemIndex: Integer;\r\n AItem: TJclCompressionItem);\r\nprocedure GetSevenzipArchiveCompressionProperties(AJclArchive: IInterface; ASevenzipArchive: IInterface);\r\nprocedure SetSevenzipArchiveCompressionProperties(AJclArchive: IInterface; ASevenzipArchive: IInterface);\r\n\r\n\r\nfunction Create7zFile(SourceFiles: TStrings; const DestinationFile: TFileName; VolumeSize: Int64 = 0;\r\n Password: String = ''; OnArchiveProgress: TJclCompressionProgressEvent = nil;\r\n OnArchiveRatio: TJclCompressionRatioEvent = nil): Boolean; overload;\r\nfunction Create7zFile(const SourceFile, DestinationFile: TFileName; VolumeSize: Int64 = 0; Password: String = '';\r\n OnArchiveProgress: TJclCompressionProgressEvent = nil;\r\n OnArchiveRatio: TJclCompressionRatioEvent = nil): Boolean; overload;\r\n\r\n{$ENDIF MSWINDOWS}\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jcl.svn.sourceforge.net/svnroot/jcl/tags/JCL-2.4-Build4571/jcl/source/common/JclCompression.pas $';\r\n Revision: '$Revision: 3785 $';\r\n Date: '$Date: 2012-04-30 09:54:26 +0200 (lun. 30 avr. 2012) $';\r\n LogPath: 'JCL\\source\\common';\r\n Extra: '';\r\n Data: nil\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n JclUnicode, // WideSameText\r\n JclDateTime, JclFileUtils, JclResources, JclStrings, JclSysUtils;\r\n\r\nconst\r\n JclDefaultBufferSize = 131072; // 128k\r\n\r\nvar\r\n // using TObject prevents default linking of TJclCompressionStreamFormats\r\n // and TJclCompressionArchiveFormats and all classes\r\n GlobalStreamFormats: TObject;\r\n GlobalArchiveFormats: TObject;\r\n\r\n//=== { TJclCompressionStream } ==============================================\r\n\r\nconstructor TJclCompressionStream.Create(AStream: TStream);\r\nbegin\r\n inherited Create;\r\n FBuffer := nil;\r\n SetBufferSize(JclDefaultBufferSize);\r\n FStream := AStream;\r\nend;\r\n\r\ndestructor TJclCompressionStream.Destroy;\r\nbegin\r\n SetBufferSize(0);\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJclCompressionStream.Read(var Buffer; Count: Longint): Longint;\r\nbegin\r\n raise EJclCompressionError.CreateRes(@RsCompressionReadNotSupported);\r\nend;\r\n\r\nfunction TJclCompressionStream.Write(const Buffer; Count: Longint): Longint;\r\nbegin\r\n raise EJclCompressionError.CreateRes(@RsCompressionWriteNotSupported);\r\nend;\r\n\r\nfunction TJclCompressionStream.Seek(const Offset: Int64; Origin: TSeekOrigin): Int64;\r\nbegin\r\n raise EJclCompressionError.CreateRes(@RsCompressionSeekNotSupported);\r\nend;\r\n\r\nprocedure TJclCompressionStream.Reset;\r\nbegin\r\n raise EJclCompressionError.CreateRes(@RsCompressionResetNotSupported);\r\nend;\r\n\r\nfunction TJclCompressionStream.SetBufferSize(Size: Cardinal): Cardinal;\r\nbegin\r\n if FBuffer <> nil then\r\n FreeMem(FBuffer, FBufferSize);\r\n\r\n FBufferSize := Size;\r\n\r\n if FBufferSize > 0 then\r\n GetMem(FBuffer, FBufferSize)\r\n else\r\n FBuffer := nil;\r\n\r\n Result := FBufferSize;\r\nend;\r\n\r\nclass function TJclCompressionStream.StreamExtensions: string;\r\nbegin\r\n Result := '';\r\nend;\r\n\r\nclass function TJclCompressionStream.StreamName: string;\r\nbegin\r\n Result := '';\r\nend;\r\n\r\nclass function TJclCompressionStream.StreamSubExtensions: string;\r\nbegin\r\n Result := '';\r\nend;\r\n\r\nprocedure TJclCompressionStream.Progress(Sender: TObject);\r\nbegin\r\n if Assigned(FOnProgress) then\r\n FOnProgress(Sender);\r\nend;\r\n\r\n//=== { TJclCompressStream } =================================================\r\n\r\nconstructor TJclCompressStream.Create(Destination: TStream);\r\nbegin\r\n inherited Create(Destination);\r\nend;\r\n\r\n//=== { TJclDecompressStream } ===============================================\r\n\r\nconstructor TJclDecompressStream.Create(Source: TStream; AOwnsStream: Boolean);\r\nbegin\r\n inherited Create(Source);\r\n FOwnsStream := AOwnsStream;\r\nend;\r\n\r\ndestructor TJclDecompressStream.Destroy;\r\nbegin\r\n if FOwnsStream then\r\n FStream.Free;\r\n inherited Destroy;\r\nend;\r\n\r\n//=== { TJclCompressionStreamFormats } =======================================\r\n\r\nconstructor TJclCompressionStreamFormats.Create;\r\nbegin\r\n inherited Create;\r\n FCompressFormats := TList.Create;\r\n FDecompressFormats := TList.Create;\r\n RegisterFormat(TJclZLibCompressStream);\r\n RegisterFormat(TJclZLibDecompressStream);\r\n RegisterFormat(TJclGZIPCompressionStream);\r\n RegisterFormat(TJclGZIPDecompressionStream);\r\n RegisterFormat(TJclBZIP2CompressionStream);\r\n RegisterFormat(TJclBZIP2DecompressionStream);\r\nend;\r\n\r\ndestructor TJclCompressionStreamFormats.Destroy;\r\nbegin\r\n FCompressFormats.Free;\r\n FDecompressFormats.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJclCompressionStreamFormats.FindCompressFormat(const AFileName: TFileName): TJclCompressStreamClass;\r\nvar\r\n IndexFormat, IndexFilter: Integer;\r\n Filters: TStrings;\r\n AFormat: TJclCompressStreamClass;\r\nbegin\r\n Result := nil;\r\n Filters := TStringList.Create;\r\n try\r\n for IndexFormat := 0 to CompressFormatCount - 1 do\r\n begin\r\n AFormat := CompressFormats[IndexFormat];\r\n StrTokenToStrings(AFormat.StreamExtensions, DirSeparator, Filters);\r\n for IndexFilter := 0 to Filters.Count - 1 do\r\n if IsFileNameMatch(AFileName, Filters.Strings[IndexFilter]) then\r\n begin\r\n Result := AFormat;\r\n Break;\r\n end;\r\n if Result <> nil then\r\n Break;\r\n end;\r\n finally\r\n Filters.Free;\r\n end;\r\nend;\r\n\r\nfunction TJclCompressionStreamFormats.FindDecompressFormat(const AFileName: TFileName): TJclDecompressStreamClass;\r\nvar\r\n IndexFormat, IndexFilter: Integer;\r\n Filters: TStrings;\r\n AFormat: TJclDecompressStreamClass;\r\nbegin\r\n Result := nil;\r\n Filters := TStringList.Create;\r\n try\r\n for IndexFormat := 0 to DecompressFormatCount - 1 do\r\n begin\r\n AFormat := DecompressFormats[IndexFormat];\r\n StrTokenToStrings(AFormat.StreamExtensions, DirSeparator, Filters);\r\n for IndexFilter := 0 to Filters.Count - 1 do\r\n if IsFileNameMatch(AFileName, Filters.Strings[IndexFilter]) then\r\n begin\r\n Result := AFormat;\r\n Break;\r\n end;\r\n if Result <> nil then\r\n Break;\r\n end;\r\n finally\r\n Filters.Free;\r\n end;\r\nend;\r\n\r\nfunction TJclCompressionStreamFormats.GetCompressFormat(Index: Integer): TJclCompressStreamClass;\r\nbegin\r\n Result := TJclCompressStreamClass(FCompressFormats.Items[Index]);\r\nend;\r\n\r\nfunction TJclCompressionStreamFormats.GetCompressFormatCount: Integer;\r\nbegin\r\n Result := FCompressFormats.Count;\r\nend;\r\n\r\nfunction TJclCompressionStreamFormats.GetDecompressFormat(Index: Integer): TJclDecompressStreamClass;\r\nbegin\r\n Result := TJclDecompressStreamClass(FDecompressFormats.Items[Index]);\r\nend;\r\n\r\nfunction TJclCompressionStreamFormats.GetDecompressFormatCount: Integer;\r\nbegin\r\n Result := FDecompressFormats.Count;\r\nend;\r\n\r\nprocedure TJclCompressionStreamFormats.RegisterFormat(AClass: TJclCompressionStreamClass);\r\nbegin\r\n if AClass.InheritsFrom(TJclCompressStream) then\r\n FCompressFormats.Add(AClass)\r\n else\r\n if AClass.InheritsFrom(TJclDecompressStream) then\r\n FDecompressFormats.Add(AClass);\r\nend;\r\n\r\nprocedure TJclCompressionStreamFormats.UnregisterFormat(AClass: TJclCompressionStreamClass);\r\nbegin\r\n if AClass.InheritsFrom(TJclCompressStream) then\r\n FCompressFormats.Remove(AClass)\r\n else\r\n if AClass.InheritsFrom(TJclDecompressStream) then\r\n FDecompressFormats.Remove(AClass);\r\nend;\r\n\r\nfunction GetStreamFormats: TJclCompressionStreamFormats;\r\nbegin\r\n if not Assigned(GlobalStreamFormats) then\r\n GlobalStreamFormats := TJclCompressionStreamFormats.Create;\r\n Result := TJclCompressionStreamFormats(GlobalStreamFormats);\r\nend;\r\n\r\n//=== { TJclZLibCompressionStream } ==========================================\r\n\r\n{ Error checking helper }\r\n\r\nfunction ZLibCheck(const ErrCode: Integer): Integer;\r\nbegin\r\n case ErrCode of\r\n 0..High(ErrCode):\r\n Result := ErrCode; // no error\r\n Z_ERRNO:\r\n raise EJclCompressionError.CreateRes(@RsCompressionZLibZErrNo);\r\n Z_STREAM_ERROR:\r\n raise EJclCompressionError.CreateRes(@RsCompressionZLibZStreamError);\r\n Z_DATA_ERROR:\r\n raise EJclCompressionError.CreateRes(@RsCompressionZLibZDataError);\r\n Z_MEM_ERROR:\r\n raise EJclCompressionError.CreateRes(@RsCompressionZLibZMemError);\r\n Z_BUF_ERROR:\r\n raise EJclCompressionError.CreateRes(@RsCompressionZLibZBufError);\r\n Z_VERSION_ERROR:\r\n raise EJclCompressionError.CreateRes(@RsCompressionZLibZVersionError);\r\n else\r\n raise EJclCompressionError.CreateResFmt(@RsCompressionZLibError, [ErrCode]);\r\n end;\r\nend;\r\n\r\nconstructor TJclZLibCompressStream.Create(Destination: TStream; CompressionLevel: TJclCompressionLevel);\r\nbegin\r\n inherited Create(Destination);\r\n\r\n LoadZLib;\r\n\r\n Assert(FBuffer <> nil);\r\n Assert(FBufferSize > 0);\r\n\r\n // Initialize ZLib StreamRecord\r\n ZLibRecord.zalloc := nil; // Use build-in memory allocation functionality\r\n ZLibRecord.zfree := nil;\r\n ZLibRecord.next_in := nil;\r\n ZLibRecord.avail_in := 0;\r\n ZLibRecord.next_out := FBuffer;\r\n ZLibRecord.avail_out := FBufferSize;\r\n\r\n FWindowBits := DEF_WBITS;\r\n FMemLevel := DEF_MEM_LEVEL;\r\n FMethod := Z_DEFLATED;\r\n FStrategy := Z_DEFAULT_STRATEGY;\r\n FCompressionLevel := CompressionLevel;\r\n FDeflateInitialized := False;\r\nend;\r\n\r\ndestructor TJclZLibCompressStream.Destroy;\r\nbegin\r\n Flush;\r\n if FDeflateInitialized then\r\n begin\r\n ZLibRecord.next_in := nil;\r\n ZLibRecord.avail_in := 0;\r\n ZLibRecord.avail_out := 0;\r\n ZLibRecord.next_out := nil;\r\n\r\n ZLibCheck(deflateEnd(ZLibRecord));\r\n end;\r\n\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJclZLibCompressStream.Write(const Buffer; Count: Longint): Longint;\r\nbegin\r\n if not FDeflateInitialized then\r\n begin\r\n ZLibCheck(deflateInit2(ZLibRecord, FCompressionLevel, FMethod, FWindowBits, FMemLevel, FStrategy));\r\n FDeflateInitialized := True;\r\n end;\r\n\r\n ZLibRecord.next_in := @Buffer;\r\n ZLibRecord.avail_in := Count;\r\n\r\n while ZLibRecord.avail_in > 0 do\r\n begin\r\n ZLibCheck(deflate(ZLibRecord, Z_NO_FLUSH));\r\n\r\n if ZLibRecord.avail_out = 0 then // Output buffer empty. Write to stream and go on...\r\n begin\r\n FStream.WriteBuffer(FBuffer^, FBufferSize);\r\n Progress(Self);\r\n ZLibRecord.next_out := FBuffer;\r\n ZLibRecord.avail_out := FBufferSize;\r\n end;\r\n end;\r\n\r\n Result := Count;\r\nend;\r\n\r\nfunction TJclZLibCompressStream.Flush: Integer;\r\nbegin\r\n Result := 0;\r\n\r\n if FDeflateInitialized then\r\n begin\r\n ZLibRecord.next_in := nil;\r\n ZLibRecord.avail_in := 0;\r\n\r\n while (ZLibCheck(deflate(ZLibRecord, Z_FINISH)) <> Z_STREAM_END) and\r\n (ZLibRecord.avail_out = 0) do\r\n begin\r\n FStream.WriteBuffer(FBuffer^, FBufferSize);\r\n Progress(Self);\r\n\r\n ZLibRecord.next_out := FBuffer;\r\n ZLibRecord.avail_out := FBufferSize;\r\n Inc(Result, FBufferSize);\r\n end;\r\n\r\n if ZLibRecord.avail_out < FBufferSize then\r\n begin\r\n FStream.WriteBuffer(FBuffer^, FBufferSize - ZLibRecord.avail_out);\r\n Progress(Self);\r\n Inc(Result, FBufferSize - ZLibRecord.avail_out);\r\n ZLibRecord.next_out := FBuffer;\r\n ZLibRecord.avail_out := FBufferSize;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJclZLibCompressStream.Seek(const Offset: Int64; Origin: TSeekOrigin): Int64;\r\nbegin\r\n if (Offset = 0) and (Origin = soCurrent) then\r\n Result := ZLibRecord.total_in\r\n else\r\n if (Offset = 0) and (Origin = soBeginning) and (ZLibRecord.total_in = 0) then\r\n Result := 0\r\n else\r\n Result := inherited Seek(Offset, Origin);\r\nend;\r\n\r\nprocedure TJclZLibCompressStream.SetWindowBits(Value: Integer);\r\nbegin\r\n FWindowBits := Value;\r\nend;\r\n\r\nclass function TJclZLibCompressStream.StreamExtensions: string;\r\nbegin\r\n Result := LoadResString(@RsCompressionZExtensions);\r\nend;\r\n\r\nclass function TJclZLibCompressStream.StreamName: string;\r\nbegin\r\n Result := LoadResString(@RsCompressionZName);\r\nend;\r\n\r\nclass function TJclZLibCompressStream.StreamSubExtensions: string;\r\nbegin\r\n Result := LoadResString(@RsCompressionZSubExtensions);\r\nend;\r\n\r\nprocedure TJclZLibCompressStream.SetMethod(Value: Integer);\r\nbegin\r\n FMethod := Value;\r\nend;\r\n\r\nprocedure TJclZLibCompressStream.SetStrategy(Value: Integer);\r\nbegin\r\n FStrategy := Value;\r\n if FDeflateInitialized then\r\n ZLibCheck(deflateParams(ZLibRecord, FCompressionLevel, FStrategy));\r\nend;\r\n\r\nprocedure TJclZLibCompressStream.SetMemLevel(Value: Integer);\r\nbegin\r\n FMemLevel := Value;\r\nend;\r\n\r\nprocedure TJclZLibCompressStream.SetCompressionLevel(Value: Integer);\r\nbegin\r\n FCompressionLevel := Value;\r\n if FDeflateInitialized then\r\n ZLibCheck(deflateParams(ZLibRecord, FCompressionLevel, FStrategy));\r\nend;\r\n\r\nprocedure TJclZLibCompressStream.Reset;\r\nbegin\r\n if FDeflateInitialized then\r\n begin\r\n Flush;\r\n ZLibCheck(deflateReset(ZLibRecord));\r\n end;\r\nend;\r\n\r\n//=== { TJclZLibDecompressionStream } =======================================\r\n\r\nconstructor TJclZLibDecompressStream.Create(Source: TStream; WindowBits: Integer; AOwnsStream: Boolean);\r\nbegin\r\n inherited Create(Source, AOwnsStream);\r\n\r\n LoadZLib;\r\n\r\n // Initialize ZLib StreamRecord\r\n ZLibRecord.zalloc := nil; // Use build-in memory allocation functionality\r\n ZLibRecord.zfree := nil;\r\n ZLibRecord.next_in := nil;\r\n ZLibRecord.avail_in := 0;\r\n ZLibRecord.next_out := FBuffer;\r\n ZLibRecord.avail_out := FBufferSize;\r\n\r\n FInflateInitialized := False;\r\n FWindowBits := WindowBits;\r\nend;\r\n\r\ndestructor TJclZLibDecompressStream.Destroy;\r\nbegin\r\n if FInflateInitialized then\r\n begin\r\n FStream.Seek(-ZLibRecord.avail_in, soCurrent);\r\n ZLibCheck(inflateEnd(ZLibRecord));\r\n end;\r\n\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJclZLibDecompressStream.Read(var Buffer; Count: Longint): Longint;\r\nvar\r\n Res: Integer;\r\nbegin\r\n if not FInflateInitialized then\r\n begin\r\n ZLibCheck(InflateInit2(ZLibRecord, FWindowBits));\r\n FInflateInitialized := True;\r\n end;\r\n\r\n ZLibRecord.next_out := @Buffer;\r\n ZLibRecord.avail_out := Count;\r\n\r\n while ZLibRecord.avail_out > 0 do // as long as we have data\r\n begin\r\n if ZLibRecord.avail_in = 0 then\r\n begin\r\n ZLibRecord.avail_in := FStream.Read(FBuffer^, FBufferSize);\r\n\r\n if ZLibRecord.avail_in = 0 then\r\n begin\r\n Result := Count - Longint(ZLibRecord.avail_out);\r\n Exit;\r\n end;\r\n\r\n ZLibRecord.next_in := FBuffer;\r\n end;\r\n\r\n if ZLibRecord.avail_in > 0 then\r\n begin\r\n Res := inflate(ZLibRecord, Z_NO_FLUSH);\r\n ZLibCheck(Res);\r\n Progress(Self);\r\n\r\n // Suggestion by ZENsan (mantis 4546)\r\n if Res = Z_STREAM_END then\r\n begin\r\n Result := Count - Longint(ZLibRecord.avail_out);\r\n Exit;\r\n end;\r\n end;\r\n end;\r\n\r\n Result := Count;\r\nend;\r\n\r\nfunction TJclZLibDecompressStream.Seek(const Offset: Int64; Origin: TSeekOrigin): Int64;\r\nbegin\r\n if (Offset = 0) and (Origin = soCurrent) then\r\n Result := ZLibRecord.total_out\r\n else\r\n Result := inherited Seek(Offset, Origin);\r\nend;\r\n\r\nprocedure TJclZLibDecompressStream.SetWindowBits(Value: Integer);\r\nbegin\r\n FWindowBits := Value;\r\nend;\r\n\r\nclass function TJclZLibDecompressStream.StreamExtensions: string;\r\nbegin\r\n Result := LoadResString(@RsCompressionZExtensions);\r\nend;\r\n\r\nclass function TJclZLibDecompressStream.StreamName: string;\r\nbegin\r\n Result := LoadResString(@RsCompressionZName);\r\nend;\r\n\r\nclass function TJclZLibDecompressStream.StreamSubExtensions: string;\r\nbegin\r\n Result := LoadResString(@RsCompressionZSubExtensions);\r\nend;\r\n\r\n//=== { TJclGZIPCompressionStream } ==========================================\r\n\r\nconstructor TJclGZIPCompressionStream.Create(Destination: TStream; CompressionLevel: TJclCompressionLevel);\r\nbegin\r\n inherited Create(Destination);\r\n\r\n LoadZLib;\r\n\r\n FFlags := [gfHeaderCRC16, gfExtraField, gfOriginalFileName, gfComment];\r\n FAutoSetTime := True;\r\n FFatSystem := gfsUnknown;\r\n FCompressionLevel := CompressionLevel;\r\n FDataCRC32 := crc32(0, nil, 0);\r\nend;\r\n\r\ndestructor TJclGZIPCompressionStream.Destroy;\r\nbegin\r\n // BUGFIX: CRC32 and Uncompressed Size missing from GZIP output\r\n // unless you called Flush manually. This is not correct Stream behaviour.\r\n // Flush should be optional!\r\n Flush;\r\n FZLibStream.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJclGZIPCompressionStream.Flush: Integer;\r\nvar\r\n AFooter: TJclGZIPFooter;\r\nbegin\r\n if Assigned(FZLibStream) then\r\n Result := FZLibStream.Flush\r\n else\r\n Result := 0;\r\n\r\n if FFooterWritten then\r\n Exit;\r\n FFooterWritten := True;\r\n\r\n // Write footer, CRC32 followed by ISIZE\r\n AFooter.DataCRC32 := FDataCRC32;\r\n AFooter.DataSize := FOriginalSize;\r\n\r\n Inc(Result, FStream.Write(AFooter, SizeOf(AFooter)));\r\nend;\r\n\r\nfunction TJclGZIPCompressionStream.GetDosTime: TDateTime;\r\nbegin\r\n if AutoSetTime then\r\n Result := Now\r\n else\r\n Result := UnixTimeToDateTime(FUnixTime);\r\nend;\r\n\r\nfunction TJclGZIPCompressionStream.GetUnixTime: Cardinal;\r\nbegin\r\n if AutoSetTime then\r\n Result := DateTimeToUnixTime(Now)\r\n else\r\n Result := FUnixTime;\r\nend;\r\n\r\nprocedure TJclGZIPCompressionStream.Reset;\r\nbegin\r\n if Assigned(FZLibStream) then\r\n FZLibStream.Reset;\r\n\r\n FDataCRC32 := crc32(0, nil, 0);\r\n FOriginalSize := 0;\r\nend;\r\n\r\nprocedure TJclGZIPCompressionStream.SetDosTime(const Value: TDateTime);\r\nbegin\r\n AutoSetTime := False;\r\n FUnixTime := DateTimeToUnixTime(Value);\r\nend;\r\n\r\nprocedure TJclGZIPCompressionStream.SetUnixTime(Value: Cardinal);\r\nbegin\r\n AutoSetTime := False;\r\n FUnixTime := Value;\r\nend;\r\n\r\nclass function TJclGZIPCompressionStream.StreamExtensions: string;\r\nbegin\r\n Result := LoadResString(@RsCompressionGZipExtensions);\r\nend;\r\n\r\nclass function TJclGZIPCompressionStream.StreamName: string;\r\nbegin\r\n Result := LoadResString(@RsCompressionGZipName);\r\nend;\r\n\r\nclass function TJclGZIPCompressionStream.StreamSubExtensions: string;\r\nbegin\r\n Result := LoadResString(@RsCompressionGZipSubExtensions);\r\nend;\r\n\r\nfunction TJclGZIPCompressionStream.Write(const Buffer; Count: Integer): Longint;\r\nbegin\r\n if not FHeaderWritten then\r\n begin\r\n WriteHeader;\r\n FHeaderWritten := True;\r\n end;\r\n\r\n if not Assigned(FZLibStream) then\r\n begin\r\n FZLibStream := TJclZLibCompressStream.Create(FStream, FCompressionLevel);\r\n FZLibStream.WindowBits := -DEF_WBITS; // negative value for raw mode\r\n FZLibStream.OnProgress := ZLibStreamProgress;\r\n end;\r\n\r\n Result := FZLibStream.Write(Buffer, Count);\r\n FDataCRC32 := crc32(FDataCRC32, PBytef(@Buffer), Result);\r\n Inc(FOriginalSize, Result);\r\nend;\r\n\r\nprocedure TJclGZIPCompressionStream.WriteHeader;\r\nconst\r\n FatSystemToByte: array [TJclGZIPFatSystem] of Byte =\r\n (JCL_GZIP_OS_FAT, JCL_GZIP_OS_AMIGA, JCL_GZIP_OS_VMS, JCL_GZIP_OS_UNIX,\r\n JCL_GZIP_OS_VM, JCL_GZIP_OS_ATARI, JCL_GZIP_OS_HPFS, JCL_GZIP_OS_MAC,\r\n JCL_GZIP_OS_Z, JCL_GZIP_OS_CPM, JCL_GZIP_OS_TOPS, JCL_GZIP_OS_NTFS,\r\n JCL_GZIP_OS_QDOS, JCL_GZIP_OS_ACORN, JCL_GZIP_OS_UNKNOWN, JCL_GZIP_OS_UNKNOWN);\r\nvar\r\n AHeader: TJclGZIPHeader;\r\n ExtraFieldLength, HeaderCRC16: Word;\r\n HeaderCRC: Cardinal;\r\n TmpAnsiString: AnsiString;\r\n\r\n procedure StreamWriteBuffer(const Buffer; Count: Longint);\r\n begin\r\n FStream.WriteBuffer(Buffer, Count);\r\n if gfHeaderCRC16 in Flags then\r\n HeaderCRC := crc32(HeaderCRC, @Byte(Buffer), Count);\r\n end;\r\n\r\n function CheckCString(const Buffer: string): Boolean;\r\n var\r\n Index: Integer;\r\n begin\r\n Result := False;\r\n for Index := 1 to Length(Buffer) do\r\n if Buffer[Index] = #0 then\r\n Exit;\r\n Result := True;\r\n end;\r\n\r\nbegin\r\n if gfHeaderCRC16 in Flags then\r\n HeaderCRC := crc32(0, nil, 0);\r\n\r\n AHeader.ID1 := JCL_GZIP_ID1;\r\n AHeader.ID2 := JCL_GZIP_ID2;\r\n AHeader.CompressionMethod := JCL_GZIP_CM_DEFLATE;\r\n AHeader.Flags := 0;\r\n if gfDataIsText in Flags then\r\n AHeader.Flags := AHeader.Flags or JCL_GZIP_FLAG_TEXT;\r\n if gfHeaderCRC16 in Flags then\r\n AHeader.Flags := AHeader.Flags or JCL_GZIP_FLAG_CRC;\r\n if (gfExtraField in Flags) and (ExtraField <> '') then\r\n AHeader.Flags := AHeader.Flags or JCL_GZIP_FLAG_EXTRA;\r\n if (gfOriginalFileName in Flags) and (OriginalFileName <> '') then\r\n AHeader.Flags := AHeader.Flags or JCL_GZIP_FLAG_NAME;\r\n if (gfComment in Flags) and (Comment <> '') then\r\n AHeader.Flags := AHeader.Flags or JCL_GZIP_FLAG_COMMENT;\r\n\r\n if AutoSetTime then\r\n AHeader.ModifiedTime := DateTimeToUnixTime(Now)\r\n else\r\n AHeader.ModifiedTime := FUnixTime;\r\n\r\n case FCompressionLevel of\r\n Z_BEST_COMPRESSION:\r\n AHeader.ExtraFlags := JCL_GZIP_EFLAG_MAX;\r\n Z_BEST_SPEED:\r\n AHeader.ExtraFlags := JCL_GZIP_EFLAG_FAST;\r\n else\r\n AHeader.ExtraFlags := 0;\r\n end;\r\n\r\n AHeader.OS := FatSystemToByte[FatSystem];\r\n\r\n StreamWriteBuffer(AHeader, SizeOf(AHeader));\r\n\r\n if (gfExtraField in Flags) and (ExtraField <> '') then\r\n begin\r\n if Length(ExtraField) > High(Word) then\r\n raise EJclCompressionError.CreateRes(@RsCompressionGZIPExtraFieldTooLong);\r\n ExtraFieldLength := Length(ExtraField);\r\n StreamWriteBuffer(ExtraFieldLength, SizeOf(ExtraFieldLength));\r\n StreamWriteBuffer(ExtraField[1], Length(ExtraField));\r\n end;\r\n\r\n if (gfOriginalFileName in Flags) and (OriginalFileName <> '') then\r\n begin\r\n if not CheckCString(OriginalFileName) then\r\n raise EJclCompressionError.CreateRes(@RsCompressionGZIPBadString);\r\n\r\n TmpAnsiString := AnsiString(OriginalFileName);\r\n StreamWriteBuffer(TmpAnsiString[1], Length(TmpAnsiString) + 1);\r\n end;\r\n\r\n if (gfComment in Flags) and (Comment <> '') then\r\n begin\r\n if not CheckCString(Comment) then\r\n raise EJclCompressionError.CreateRes(@RsCompressionGZIPBadString);\r\n\r\n TmpAnsiString := AnsiString(Comment);\r\n StreamWriteBuffer(TmpAnsiString[1], Length(TmpAnsiString) + 1);\r\n end;\r\n\r\n if (gfHeaderCRC16 in Flags) then\r\n begin\r\n HeaderCRC16 := HeaderCRC and $FFFF;\r\n FStream.WriteBuffer(HeaderCRC16, SizeOf(HeaderCRC16));\r\n end;\r\nend;\r\n\r\nprocedure TJclGZIPCompressionStream.ZLibStreamProgress(Sender: TObject);\r\nbegin\r\n Progress(Self);\r\nend;\r\n\r\n//=== { TJclGZIPDecompressionStream } ========================================\r\n\r\nconstructor TJclGZIPDecompressionStream.Create(Source: TStream; CheckHeaderCRC: Boolean; AOwnsStream: Boolean);\r\nvar\r\n HeaderCRC: Cardinal;\r\n ComputeHeaderCRC: Boolean;\r\n ExtraFieldLength: Word;\r\n\r\n procedure ReadBuffer(var Buffer; SizeOfBuffer: Longint);\r\n begin\r\n Source.ReadBuffer(Buffer, SizeOfBuffer);\r\n if ComputeHeaderCRC then\r\n HeaderCRC := crc32(HeaderCRC, @Byte(Buffer), SizeOfBuffer);\r\n end;\r\n\r\n function ReadCString: AnsiString;\r\n var\r\n Buf: AnsiChar;\r\n begin\r\n Result := '';\r\n Buf := #0;\r\n repeat\r\n Source.ReadBuffer(Buf, SizeOf(Buf));\r\n if Buf = #0 then Break;\r\n Result := Result + Buf;\r\n until False;\r\n end;\r\n\r\nbegin\r\n inherited Create(Source, AOwnsStream);\r\n\r\n LoadZLib;\r\n\r\n FAutoCheckDataCRC32 := True;\r\n FComputedDataCRC32 := crc32(0, nil, 0);\r\n HeaderCRC := crc32(0, nil, 0);\r\n\r\n ComputeHeaderCRC := CheckHeaderCRC;\r\n ReadBuffer(FHeader, SizeOf(FHeader));\r\n if (FHeader.ID1 <> JCL_GZIP_ID1) or (FHeader.ID2 <> JCL_GZIP_ID2) then\r\n raise EJclCompressionError.CreateResFmt(@RsCompressionGZipInvalidID, [FHeader.ID1, FHeader.ID2]);\r\n if (FHeader.CompressionMethod <> JCL_GZIP_CM_DEFLATE) then\r\n raise EJclCompressionError.CreateResFmt(@RsCompressionGZipUnsupportedCM, [FHeader.CompressionMethod]);\r\n\r\n if (FHeader.Flags and JCL_GZIP_FLAG_EXTRA) <> 0 then\r\n begin\r\n ExtraFieldLength := 0;\r\n ReadBuffer(ExtraFieldLength, SizeOf(ExtraFieldLength));\r\n SetLength(FExtraField, ExtraFieldLength);\r\n ReadBuffer(FExtraField[1], ExtraFieldLength);\r\n end;\r\n\r\n if (FHeader.Flags and JCL_GZIP_FLAG_NAME) <> 0 then\r\n FOriginalFileName := TFileName(ReadCString);\r\n if (FHeader.Flags and JCL_GZIP_FLAG_COMMENT) <> 0 then\r\n FComment := string(ReadCString);\r\n\r\n if CheckHeaderCRC then\r\n begin\r\n ComputeHeaderCRC := False;\r\n FComputedHeaderCRC16 := HeaderCRC and $FFFF;\r\n end;\r\n\r\n if (FHeader.Flags and JCL_GZIP_FLAG_CRC) <> 0 then\r\n begin\r\n Source.ReadBuffer(FStoredHeaderCRC16, SizeOf(FStoredHeaderCRC16));\r\n if CheckHeaderCRC and (FComputedHeaderCRC16 <> FStoredHeaderCRC16) then\r\n raise EJclCompressionError.CreateRes(@RsCompressionGZipHeaderCRC);\r\n end;\r\nend;\r\n\r\ndestructor TJclGZIPDecompressionStream.Destroy;\r\nbegin\r\n FZLibStream.Free;\r\n FCompressedDataStream.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJclGZIPDecompressionStream.GetCompressedDataSize: Int64;\r\nbegin\r\n if not FDataStarted then\r\n Result := FStream.Size - FStream.Position - SizeOf(FFooter)\r\n else\r\n if FDataEnded then\r\n Result := FCompressedDataSize\r\n else\r\n raise EJclCompressionError.CreateRes(@RsCompressionGZipDecompressing);\r\nend;\r\n\r\nfunction TJclGZIPDecompressionStream.GetComputedDataCRC32: Cardinal;\r\nbegin\r\n if FDataEnded then\r\n Result := FComputedDataCRC32\r\n else\r\n raise EJclCompressionError.CreateRes(@RsCompressionGZipNotDecompressed);\r\nend;\r\n\r\nfunction TJclGZIPDecompressionStream.GetDosTime: TDateTime;\r\nbegin\r\n Result := UnixTimeToDateTime(FHeader.ModifiedTime);\r\nend;\r\n\r\nfunction TJclGZIPDecompressionStream.GetFatSystem: TJclGZIPFatSystem;\r\nconst\r\n ByteToFatSystem: array [JCL_GZIP_OS_FAT..JCL_GZIP_OS_ACORN] of TJclGZIPFatSystem =\r\n (gfsFat, gfsAmiga, gfsVMS, gfsUnix, gfsVM, gfsAtari, gfsHPFS, gfsMac, gfsZ,\r\n gfsCPM, gfsTOPS, gfsNTFS, gfsQDOS, gfsAcorn);\r\nbegin\r\n case FHeader.OS of\r\n JCL_GZIP_OS_FAT..JCL_GZIP_OS_ACORN:\r\n Result := ByteToFatSystem[FHeader.OS];\r\n JCL_GZIP_OS_UNKNOWN:\r\n Result := gfsUnknown;\r\n else\r\n Result := gfsOther;\r\n end;\r\nend;\r\n\r\nfunction TJclGZIPDecompressionStream.GetFlags: TJclGZIPFlags;\r\nbegin\r\n Result := [];\r\n if (FHeader.Flags and JCL_GZIP_FLAG_TEXT) <> 0 then\r\n Result := Result + [gfDataIsText];\r\n if (FHeader.Flags and JCL_GZIP_FLAG_CRC) <> 0 then\r\n Result := Result + [gfHeaderCRC16];\r\n if (FHeader.Flags and JCL_GZIP_FLAG_EXTRA) <> 0 then\r\n Result := Result + [gfExtraField];\r\n if (FHeader.Flags and JCL_GZIP_FLAG_NAME) <> 0 then\r\n Result := Result + [gfOriginalFileName];\r\n if (FHeader.Flags and JCL_GZIP_FLAG_COMMENT) <> 0 then\r\n Result := Result + [gfComment];\r\nend;\r\n\r\nfunction TJclGZIPDecompressionStream.GetOriginalDataSize: Cardinal;\r\nvar\r\n StartPos: Int64;\r\n AFooter: TJclGZIPFooter;\r\nbegin\r\n if not FDataStarted then\r\n begin\r\n StartPos := FStream.Position;\r\n try\r\n FStream.Seek(-SizeOf(AFooter), soEnd);\r\n AFooter.DataCRC32 := 0;\r\n AFooter.DataSize := 0;\r\n FStream.ReadBuffer(AFooter, SizeOf(AFooter));\r\n Result := AFooter.DataSize;\r\n finally\r\n FStream.Seek(StartPos, soBeginning);\r\n end;\r\n end\r\n else\r\n if FDataEnded then\r\n Result := FFooter.DataSize\r\n else\r\n raise EJclCompressionError.CreateRes(@RsCompressionGZipDecompressing);\r\nend;\r\n\r\nfunction TJclGZIPDecompressionStream.GetStoredDataCRC32: Cardinal;\r\nvar\r\n StartPos: Int64;\r\n AFooter: TJclGZIPFooter;\r\nbegin\r\n if not FDataStarted then\r\n begin\r\n StartPos := FStream.Position;\r\n try\r\n FStream.Seek(-SizeOf(AFooter), soEnd);\r\n AFooter.DataSize := 0;\r\n AFooter.DataCRC32 := 0;\r\n FStream.ReadBuffer(AFooter, SizeOf(AFooter));\r\n Result := AFooter.DataCRC32;\r\n finally\r\n FStream.Seek(StartPos, soBeginning);\r\n end;\r\n end\r\n else\r\n if FDataEnded then\r\n Result := FFooter.DataCRC32\r\n else\r\n raise EJclCompressionError.CreateRes(@RsCompressionGZipDecompressing);\r\nend;\r\n\r\nfunction TJclGZIPDecompressionStream.Read(var Buffer; Count: Longint): Longint;\r\nbegin\r\n if not Assigned(FZLibStream) then\r\n begin\r\n FCompressedDataStream := TJclDelegatedStream.Create;\r\n FCompressedDataStream.OnRead := ReadCompressedData;\r\n FZLibStream := TJclZLibDecompressStream.Create(FCompressedDataStream, -DEF_WBITS);\r\n FZLibStream.OnProgress := ZLibStreamProgress;\r\n end;\r\n Result := FZLibStream.Read(Buffer, Count);\r\n Inc(FDataSize, Result);\r\n FComputedDataCRC32 := crc32(FComputedDataCRC32, @Byte(Buffer), Result);\r\n if Result < Count then\r\n begin\r\n if not FDataEnded then\r\n // the decompressed stream is stopping before the compressed stream\r\n raise EJclCompressionError.CreateRes(@RsCompressionGZipInternalError);\r\n if AutoCheckDataCRC32 and (FComputedDataCRC32 <> FFooter.DataCRC32) then\r\n raise EJclCompressionError.CreateRes(@RsCompressionGZipDataCRCFailed);\r\n end;\r\nend;\r\n\r\nfunction TJclGZIPDecompressionStream.ReadCompressedData(Sender: TObject; var Buffer;\r\n Count: Longint): Longint;\r\nvar\r\n BufferAddr: PAnsiChar;\r\n FooterAddr: PAnsiChar;\r\nbegin\r\n if (Count = 0) or FDataEnded then\r\n begin\r\n Result := 0;\r\n Exit;\r\n end\r\n else\r\n if not FDataStarted then\r\n begin\r\n FDataStarted := True;\r\n // prolog\r\n if FStream.Read(FFooter, SizeOf(FFooter)) < SizeOf(FFooter) then\r\n raise EJclCompressionError.CreateRes(@RsCompressionGZipDataTruncated);\r\n end;\r\n\r\n BufferAddr := @Byte(Buffer);\r\n Move(FFooter, Buffer, SizeOf(FFooter));\r\n Result := FStream.Read(BufferAddr[SizeOf(FFooter)], Count - SizeOf(FFooter))\r\n + FStream.Read(FFooter, SizeOf(FFooter));\r\n\r\n if Result < Count then\r\n begin\r\n FDataEnded := True;\r\n // epilog\r\n FooterAddr := @FFooter;\r\n if (Count - Result) < SizeOf(FFooter) then\r\n begin\r\n // the \"real\" footer is splitted in the data and the footer\r\n // shift the valid bytes of the footer to their place\r\n Move(FFooter, FooterAddr[Count - Result], SizeOf(FFooter) - Count + Result);\r\n // the missing bytes of the footer are located after the data\r\n Move(BufferAddr[Result], FFooter, Count - Result);\r\n end\r\n else\r\n // the \"real\" footer is located in the data\r\n Move(BufferAddr[Result], FFooter, SizeOf(FFooter));\r\n end;\r\n Inc(FCompressedDataSize, Result);\r\nend;\r\n\r\nclass function TJclGZIPDecompressionStream.StreamExtensions: string;\r\nbegin\r\n Result := LoadResString(@RsCompressionGZipExtensions);\r\nend;\r\n\r\nclass function TJclGZIPDecompressionStream.StreamName: string;\r\nbegin\r\n Result := LoadResString(@RsCompressionGZipName);\r\nend;\r\n\r\nclass function TJclGZIPDecompressionStream.StreamSubExtensions: string;\r\nbegin\r\n Result := LoadResString(@RsCompressionGZipSubExtensions);\r\nend;\r\n\r\nprocedure TJclGZIPDecompressionStream.ZLibStreamProgress(Sender: TObject);\r\nbegin\r\n Progress(Self);\r\nend;\r\n\r\n//=== { TJclBZLibCompressionStream } =========================================\r\n\r\n{ Error checking helper }\r\n\r\nfunction BZIP2LibCheck(const ErrCode: Integer): Integer;\r\nbegin\r\n case ErrCode of\r\n 0..High(ErrCode):\r\n Result := ErrCode; // no error\r\n BZ_SEQUENCE_ERROR:\r\n raise EJclCompressionError.CreateRes(@RsCompressionBZIP2SequenceError);\r\n BZ_PARAM_ERROR:\r\n raise EJclCompressionError.CreateRes(@RsCompressionBZIP2ParameterError);\r\n BZ_MEM_ERROR:\r\n raise EJclCompressionError.CreateRes(@RsCompressionBZIP2MemoryError);\r\n BZ_DATA_ERROR:\r\n raise EJclCompressionError.CreateRes(@RsCompressionBZIP2DataError);\r\n BZ_DATA_ERROR_MAGIC:\r\n raise EJclCompressionError.CreateRes(@RsCompressionBZIP2HeaderError);\r\n BZ_IO_ERROR:\r\n raise EJclCompressionError.CreateRes(@RsCompressionBZIP2IOError);\r\n BZ_UNEXPECTED_EOF:\r\n raise EJclCompressionError.CreateRes(@RsCompressionBZIP2EOFError);\r\n BZ_OUTBUFF_FULL:\r\n raise EJclCompressionError.CreateRes(@RsCompressionBZIP2OutBuffError);\r\n BZ_CONFIG_ERROR:\r\n raise EJclCompressionError.CreateRes(@RsCompressionBZIP2ConfigError);\r\n else\r\n raise EJclCompressionError.CreateResFmt(@RsCompressionBZIP2Error, [ErrCode]);\r\n end;\r\nend;\r\n\r\nconstructor TJclBZIP2CompressionStream.Create(Destination: TStream; ACompressionLevel: TJclCompressionLevel);\r\nbegin\r\n inherited Create(Destination);\r\n\r\n LoadBZip2;\r\n\r\n Assert(FBuffer <> nil);\r\n Assert(FBufferSize > 0);\r\n\r\n // Initialize ZLib StreamRecord\r\n BZLibRecord.bzalloc := nil; // Use build-in memory allocation functionality\r\n BZLibRecord.bzfree := nil;\r\n BZLibRecord.next_in := nil;\r\n BZLibRecord.avail_in := 0;\r\n BZLibRecord.next_out := FBuffer;\r\n BZLibRecord.avail_out := FBufferSize;\r\n\r\n FDeflateInitialized := False;\r\n\r\n FCompressionLevel := ACompressionLevel;\r\nend;\r\n\r\ndestructor TJclBZIP2CompressionStream.Destroy;\r\nbegin\r\n Flush;\r\n if FDeflateInitialized then\r\n BZIP2LibCheck(BZ2_bzCompressEnd(BZLibRecord));\r\n\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJclBZIP2CompressionStream.Flush: Integer;\r\nbegin\r\n Result := 0;\r\n\r\n if FDeflateInitialized then\r\n begin\r\n BZLibRecord.next_in := nil;\r\n BZLibRecord.avail_in := 0;\r\n\r\n while (BZIP2LibCheck(BZ2_bzCompress(BZLibRecord, BZ_FINISH)) <> BZ_STREAM_END) and (BZLibRecord.avail_out = 0) do\r\n begin\r\n FStream.WriteBuffer(FBuffer^, FBufferSize);\r\n Progress(Self);\r\n\r\n BZLibRecord.next_out := FBuffer;\r\n BZLibRecord.avail_out := FBufferSize;\r\n Inc(Result, FBufferSize);\r\n end;\r\n\r\n if BZLibRecord.avail_out < FBufferSize then\r\n begin\r\n FStream.WriteBuffer(FBuffer^, FBufferSize - BZLibRecord.avail_out);\r\n Progress(Self);\r\n Inc(Result, FBufferSize - BZLibRecord.avail_out);\r\n BZLibRecord.next_out := FBuffer;\r\n BZLibRecord.avail_out := FBufferSize;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJclBZIP2CompressionStream.Seek(const Offset: Int64; Origin: TSeekOrigin): Int64;\r\nbegin\r\n if (Offset = 0) and (Origin = soCurrent) then\r\n Result := (BZLibRecord.total_in_hi32 shl 32) or BZLibRecord.total_in_lo32\r\n else\r\n if (Offset = 0) and (Origin = soBeginning) and (BZLibRecord.total_in_lo32 = 0) then\r\n Result := 0\r\n else\r\n Result := inherited Seek(Offset, Origin);\r\nend;\r\n\r\nprocedure TJclBZIP2CompressionStream.SetCompressionLevel(const Value: Integer);\r\nbegin\r\n if not FDeflateInitialized then\r\n FCompressionLevel := Value\r\n else\r\n raise EJclCompressionError.CreateRes(@RsCompressionBZIP2SequenceError);\r\nend;\r\n\r\nclass function TJclBZIP2CompressionStream.StreamExtensions: string;\r\nbegin\r\n Result := LoadResString(@RsCompressionBZip2Extensions);\r\nend;\r\n\r\nclass function TJclBZIP2CompressionStream.StreamName: string;\r\nbegin\r\n Result := LoadResString(@RsCompressionBZip2Name);\r\nend;\r\n\r\nclass function TJclBZIP2CompressionStream.StreamSubExtensions: string;\r\nbegin\r\n Result := LoadResString(@RsCompressionBZip2SubExtensions);\r\nend;\r\n\r\nfunction TJclBZIP2CompressionStream.Write(const Buffer; Count: Longint): Longint;\r\nbegin\r\n if not FDeflateInitialized then\r\n begin\r\n BZIP2LibCheck(BZ2_bzCompressInit(BZLibRecord, FCompressionLevel, 0, 0));\r\n FDeflateInitialized := True;\r\n end;\r\n\r\n BZLibRecord.next_in := @Buffer;\r\n BZLibRecord.avail_in := Count;\r\n\r\n while BZLibRecord.avail_in > 0 do\r\n begin\r\n BZIP2LibCheck(BZ2_bzCompress(BZLibRecord, BZ_RUN));\r\n\r\n if BZLibRecord.avail_out = 0 then // Output buffer empty. Write to stream and go on...\r\n begin\r\n FStream.WriteBuffer(FBuffer^, FBufferSize);\r\n Progress(Self);\r\n BZLibRecord.next_out := FBuffer;\r\n BZLibRecord.avail_out := FBufferSize;\r\n end;\r\n end;\r\n\r\n Result := Count;\r\nend;\r\n\r\n//=== { TJclBZip2DecompressionStream } =======================================\r\n\r\nconstructor TJclBZIP2DecompressionStream.Create(Source: TStream; AOwnsStream: Boolean);\r\nbegin\r\n inherited Create(Source, AOwnsStream);\r\n\r\n LoadBZip2;\r\n\r\n // Initialize ZLib StreamRecord\r\n BZLibRecord.bzalloc := nil; // Use build-in memory allocation functionality\r\n BZLibRecord.bzfree := nil;\r\n BZLibRecord.opaque := nil;\r\n BZLibRecord.next_in := nil;\r\n BZLibRecord.state := nil;\r\n BZLibRecord.avail_in := 0;\r\n BZLibRecord.next_out := FBuffer;\r\n BZLibRecord.avail_out := FBufferSize;\r\n\r\n FInflateInitialized := False;\r\nend;\r\n\r\ndestructor TJclBZIP2DecompressionStream.Destroy;\r\nbegin\r\n if FInflateInitialized then\r\n begin\r\n FStream.Seek(-BZLibRecord.avail_in, soCurrent);\r\n BZIP2LibCheck(BZ2_bzDecompressEnd(BZLibRecord));\r\n end;\r\n\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJclBZIP2DecompressionStream.Read(var Buffer; Count: Longint): Longint;\r\nbegin\r\n if not FInflateInitialized then\r\n begin\r\n BZIP2LibCheck(BZ2_bzDecompressInit(BZLibRecord, 0, 0));\r\n FInflateInitialized := True;\r\n end;\r\n\r\n BZLibRecord.next_out := @Buffer;\r\n BZLibRecord.avail_out := Count;\r\n Result := 0;\r\n\r\n while Result < Count do // as long as we need data\r\n begin\r\n if BZLibRecord.avail_in = 0 then // no more compressed data\r\n begin\r\n BZLibRecord.avail_in := FStream.Read(FBuffer^, FBufferSize);\r\n if BZLibRecord.avail_in = 0 then\r\n Exit;\r\n\r\n BZLibRecord.next_in := FBuffer;\r\n end;\r\n\r\n if BZLibRecord.avail_in > 0 then\r\n begin\r\n BZIP2LibCheck(BZ2_bzDecompress(BZLibRecord));\r\n Result := Count;\r\n Dec(Result, BZLibRecord.avail_out);\r\n end\r\n end;\r\n\r\n Result := Count;\r\nend;\r\n\r\nfunction TJclBZIP2DecompressionStream.Seek(const Offset: Int64; Origin: TSeekOrigin): Int64;\r\nbegin\r\n if (Offset = 0) and (Origin = soCurrent) then\r\n Result := (BZLibRecord.total_out_hi32 shl 32) or BZLibRecord.total_out_lo32\r\n else\r\n Result := inherited Seek(Offset, Origin);\r\nend;\r\n\r\nclass function TJclBZIP2DecompressionStream.StreamExtensions: string;\r\nbegin\r\n Result := LoadResString(@RsCompressionBZip2Extensions);\r\nend;\r\n\r\nclass function TJclBZIP2DecompressionStream.StreamName: string;\r\nbegin\r\n Result := LoadResString(@RsCompressionBZip2Name);\r\nend;\r\n\r\nclass function TJclBZIP2DecompressionStream.StreamSubExtensions: string;\r\nbegin\r\n Result := LoadResString(@RsCompressionBZip2SubExtensions);\r\nend;\r\n\r\nprocedure InternalCompress(SourceStream: TStream; CompressStream: TJclCompressStream;\r\n ProgressCallback: TJclCompressStreamProgressCallback; UserData: Pointer);\r\nvar\r\n SourceStreamSize, SourceStreamPosition: Int64;\r\n Buffer: Pointer;\r\n ReadBytes: Integer;\r\n EofFlag: Boolean;\r\nbegin\r\n SourceStreamSize := SourceStream.Size; // source file size\r\n SourceStreamPosition := 0;\r\n\r\n GetMem(Buffer, JclDefaultBufferSize + 2);\r\n try\r\n // ZLibStream.CopyFrom(SourceStream, 0 ); // One line way to do it! may not\r\n // // be reliable idea to do this! also,\r\n // //no progress callbacks!\r\n EofFlag := False;\r\n while not EofFlag do\r\n begin\r\n if Assigned(ProgressCallback) then\r\n ProgressCallback(SourceStreamSize, SourceStreamPosition, UserData);\r\n\r\n ReadBytes := SourceStream.Read(Buffer^, JclDefaultBufferSize);\r\n SourceStreamPosition := SourceStreamPosition + ReadBytes;\r\n\r\n CompressStream.WriteBuffer(Buffer^, ReadBytes);\r\n\r\n // short block indicates end of zlib stream\r\n EofFlag := ReadBytes < JclDefaultBufferSize;\r\n end;\r\n //CompressStream.Flush; (called by the destructor of compression streams\r\n finally\r\n FreeMem(Buffer);\r\n end;\r\n if Assigned(ProgressCallback) then\r\n ProgressCallback(SourceStreamSize, SourceStreamPosition, UserData);\r\nend;\r\n\r\nprocedure InternalDecompress(SourceStream, DestStream: TStream;\r\n DecompressStream: TJclDecompressStream;\r\n ProgressCallback: TJclCompressStreamProgressCallback; UserData: Pointer);\r\nvar\r\n SourceStreamSize: Int64;\r\n Buffer: Pointer;\r\n ReadBytes: Integer;\r\n EofFlag: Boolean;\r\nbegin\r\n SourceStreamSize := SourceStream.Size; // source file size\r\n\r\n GetMem(Buffer, JclDefaultBufferSize + 2);\r\n try\r\n // ZLibStream.CopyFrom(SourceStream, 0 ); // One line way to do it! may not\r\n // // be reliable idea to do this! also,\r\n // //no progress callbacks!\r\n EofFlag := False;\r\n while not EofFlag do\r\n begin\r\n if Assigned(ProgressCallback) then\r\n ProgressCallback(SourceStreamSize, SourceStream.Position, UserData);\r\n\r\n ReadBytes := DecompressStream.Read(Buffer^, JclDefaultBufferSize);\r\n\r\n DestStream.WriteBuffer(Buffer^, ReadBytes);\r\n\r\n // short block indicates end of zlib stream\r\n EofFlag := ReadBytes < JclDefaultBufferSize;\r\n end;\r\n finally\r\n FreeMem(Buffer);\r\n end;\r\n if Assigned(ProgressCallback) then\r\n ProgressCallback(SourceStreamSize, SourceStream.Position, UserData);\r\nend;\r\n\r\n{ Compress to a .gz file - one liner - NEW MARCH 2007 }\r\n\r\nfunction GZipFile(SourceFile, DestinationFile: TFileName; CompressionLevel: Integer;\r\n ProgressCallback: TJclCompressStreamProgressCallback; UserData: Pointer): Boolean;\r\nvar\r\n GZipStream: TJclGZIPCompressionStream;\r\n DestStream: TFileStream;\r\n SourceStream: TFileStream;\r\n GZipStreamDateTime: TDateTime;\r\nbegin\r\n Result := False;\r\n if not FileExists(SourceFile) then // can't copy what doesn't exist!\r\n Exit;\r\n\r\n GetFileLastWrite(SourceFile, GZipStreamDateTime);\r\n\r\n {destination and source streams first and second}\r\n SourceStream := TFileStream.Create(SourceFile, fmOpenRead or fmShareDenyWrite);\r\n try\r\n DestStream := TFileStream.Create(DestinationFile, fmCreate); // see SysUtils\r\n try\r\n { create compressionstream third, and copy from source,\r\n through zlib compress layer,\r\n out through file stream}\r\n GZipStream := TJclGZIPCompressionStream.Create(DestStream, CompressionLevel);\r\n try\r\n GZipStream.DosTime := GZipStreamDateTime;\r\n InternalCompress(SourceStream, GZipStream, ProgressCallback, UserData);\r\n finally\r\n GZipStream.Free;\r\n end;\r\n finally\r\n DestStream.Free;\r\n end;\r\n finally\r\n SourceStream.Free;\r\n end;\r\n Result := FileExists(DestinationFile);\r\nend;\r\n\r\n{ Decompress a .gz file }\r\n\r\nfunction UnGZipFile(SourceFile, DestinationFile: TFileName;\r\n ProgressCallback: TJclCompressStreamProgressCallback; UserData: Pointer): Boolean;\r\nvar\r\n GZipStream: TJclGZIPDecompressionStream;\r\n DestStream: TFileStream;\r\n SourceStream: TFileStream;\r\n GZipStreamDateTime: TDateTime;\r\nbegin\r\n Result := False;\r\n if not FileExists(SourceFile) then // can't copy what doesn't exist!\r\n Exit;\r\n\r\n {destination and source streams first and second}\r\n SourceStream := TFileStream.Create(SourceFile, {mode} fmOpenRead or fmShareDenyWrite);\r\n try\r\n DestStream := TFileStream.Create(DestinationFile, {mode} fmCreate); // see SysUtils\r\n try\r\n { create decompressionstream third, and copy from source,\r\n through zlib decompress layer, out through file stream\r\n }\r\n GZipStream := TJclGZIPDecompressionStream.Create(SourceStream);\r\n try\r\n InternalDecompress(SourceStream, DestStream, GZipStream, ProgressCallback, UserData);\r\n GZipStreamDateTime := GZipStream.DosTime;\r\n finally\r\n GZipStream.Free;\r\n end;\r\n finally\r\n DestStream.Free;\r\n end;\r\n finally\r\n SourceStream.Free;\r\n end;\r\n Result := FileExists(DestinationFile);\r\n if Result and (GZipStreamDateTime <> 0) then\r\n // preserve datetime when unpacking! (see JclFileUtils)\r\n SetFileLastWrite(DestinationFile, GZipStreamDateTime);\r\nend;\r\n\r\nprocedure GZipStream(SourceStream, DestinationStream: TStream; CompressionLevel: Integer = Z_DEFAULT_COMPRESSION;\r\n ProgressCallback: TJclCompressStreamProgressCallback = nil; UserData: Pointer = nil);\r\nvar\r\n GZStream: TJclGZIPCompressionStream;\r\nbegin\r\n GZStream := TJclGZIPCompressionStream.Create(DestinationStream, CompressionLevel);\r\n try\r\n InternalCompress(SourceStream, GZStream, ProgressCallback, UserData);\r\n finally\r\n GZStream.Free;\r\n end;\r\nend;\r\n\r\nprocedure UnGZipStream(SourceStream, DestinationStream: TStream;\r\n ProgressCallback: TJclCompressStreamProgressCallback = nil; UserData: Pointer = nil);\r\nvar\r\n GZipStream: TJclGZIPDecompressionStream;\r\nbegin\r\n GZipStream := TJclGZIPDecompressionStream.Create(SourceStream);\r\n try\r\n InternalDecompress(SourceStream, DestinationStream, GZipStream, ProgressCallback, UserData);\r\n finally\r\n GZipStream.Free;\r\n end;\r\nend;\r\n\r\n{ Compress to a .bz2 file - one liner }\r\n\r\nfunction BZip2File(SourceFile, DestinationFile: TFileName; CompressionLevel: Integer;\r\n ProgressCallback: TJclCompressStreamProgressCallback; UserData: Pointer): Boolean;\r\nvar\r\n BZip2Stream: TJclBZIP2CompressionStream;\r\n DestStream: TFileStream;\r\n SourceStream: TFileStream;\r\nbegin\r\n Result := False;\r\n if not FileExists(SourceFile) then // can't copy what doesn't exist!\r\n Exit;\r\n\r\n {destination and source streams first and second}\r\n SourceStream := TFileStream.Create(SourceFile, fmOpenRead or fmShareDenyWrite);\r\n try\r\n DestStream := TFileStream.Create(DestinationFile, fmCreate); // see SysUtils\r\n try\r\n { create compressionstream third, and copy from source,\r\n through zlib compress layer,\r\n out through file stream}\r\n BZip2Stream := TJclBZIP2CompressionStream.Create(DestStream, CompressionLevel);\r\n try\r\n InternalCompress(SourceStream, BZip2Stream, ProgressCallback, UserData);\r\n finally\r\n BZip2Stream.Free;\r\n end;\r\n finally\r\n DestStream.Free;\r\n end;\r\n finally\r\n SourceStream.Free;\r\n end;\r\n Result := FileExists(DestinationFile);\r\nend;\r\n\r\n{ Decompress a .bzip2 file }\r\n\r\nfunction UnBZip2File(SourceFile, DestinationFile: TFileName;\r\n ProgressCallback: TJclCompressStreamProgressCallback; UserData: Pointer): Boolean;\r\nvar\r\n BZip2Stream: TJclBZIP2DecompressionStream;\r\n DestStream: TFileStream;\r\n SourceStream: TFileStream;\r\nbegin\r\n Result := False;\r\n if not FileExists(SourceFile) then // can't copy what doesn't exist!\r\n Exit;\r\n\r\n {destination and source streams first and second}\r\n SourceStream := TFileStream.Create(SourceFile, {mode} fmOpenRead or fmShareDenyWrite);\r\n try\r\n DestStream := TFileStream.Create(DestinationFile, {mode} fmCreate); // see SysUtils\r\n try\r\n { create decompressionstream third, and copy from source,\r\n through zlib decompress layer, out through file stream\r\n }\r\n BZip2Stream := TJclBZIP2DecompressionStream.Create(SourceStream);\r\n try\r\n InternalDecompress(SourceStream, DestStream, BZip2Stream, ProgressCallback, UserData);\r\n finally\r\n BZip2Stream.Free;\r\n end;\r\n finally\r\n DestStream.Free;\r\n end;\r\n finally\r\n SourceStream.Free;\r\n end;\r\n Result := FileExists(DestinationFile);\r\nend;\r\n\r\nprocedure BZip2Stream(SourceStream, DestinationStream: TStream; CompressionLevel: Integer = 5;\r\n ProgressCallback: TJclCompressStreamProgressCallback = nil; UserData: Pointer = nil);\r\nvar\r\n BZ2Stream: TJclBZIP2CompressionStream;\r\nbegin\r\n BZ2Stream := TJclBZIP2CompressionStream.Create(DestinationStream, CompressionLevel);\r\n try\r\n InternalCompress(SourceStream, BZ2Stream, ProgressCallback, UserData);\r\n finally\r\n BZ2Stream.Free;\r\n end;\r\nend;\r\n\r\nprocedure UnBZip2Stream(SourceStream, DestinationStream: TStream;\r\n ProgressCallback: TJclCompressStreamProgressCallback = nil; UserData: Pointer = nil);\r\nvar\r\n BZip2Stream: TJclBZIP2DecompressionStream;\r\nbegin\r\n BZip2Stream := TJclBZIP2DecompressionStream.Create(SourceStream);\r\n try\r\n InternalDecompress(SourceStream, DestinationStream, BZip2Stream, ProgressCallback, UserData);\r\n finally\r\n BZip2Stream.Free;\r\n end;\r\nend;\r\n\r\n{$IFDEF MSWINDOWS}\r\n\r\nfunction OpenFileStream(const FileName: TFileName; StreamAccess: TJclStreamAccess): TStream;\r\nbegin\r\n Result := nil;\r\n case StreamAccess of\r\n saCreate:\r\n Result := TFileStream.Create(FileName, fmCreate);\r\n saReadOnly:\r\n if FileExists(FileName) then\r\n Result := TFileStream.Create(FileName, fmOpenRead or fmShareDenyWrite);\r\n saReadOnlyDenyNone:\r\n if FileExists(FileName) then\r\n Result := TFileStream.Create(FileName, fmOpenRead or fmShareDenyNone);\r\n saWriteOnly:\r\n if FileExists(FileName) then\r\n Result := TFileStream.Create(FileName, fmOpenWrite)\r\n else\r\n if FileName <> '' then\r\n Result := TFileStream.Create(FileName, fmCreate);\r\n saReadWrite:\r\n if FileExists(FileName) then\r\n Result := TFileStream.Create(FileName, fmOpenReadWrite)\r\n else\r\n if FileName <> '' then\r\n Result := TFileStream.Create(FileName, fmCreate);\r\n end;\r\nend;\r\n\r\n//=== { TJclCompressionItem } ================================================\r\n\r\nconstructor TJclCompressionItem.Create(AArchive: TJclCompressionArchive);\r\nbegin\r\n inherited Create;\r\n FArchive := AArchive;\r\n FPackedIndex := $FFFFFFFF;\r\nend;\r\n\r\nfunction TJclCompressionItem.DeleteOutputFile: Boolean;\r\nbegin\r\n Result := (FFileName <> '') and FileExists(FFileName) and FileDelete(FFileName);\r\nend;\r\n\r\ndestructor TJclCompressionItem.Destroy;\r\nbegin\r\n ReleaseStream;\r\n \r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJclCompressionItem.GetAttributes: Cardinal;\r\nbegin\r\n CheckGetProperty(ipAttributes);\r\n Result := FAttributes;\r\nend;\r\n\r\nfunction TJclCompressionItem.GetComment: WideString;\r\nbegin\r\n CheckGetProperty(ipComment);\r\n Result := FComment;\r\nend;\r\n\r\nfunction TJclCompressionItem.GetCRC: Cardinal;\r\nbegin\r\n CheckGetProperty(ipCRC);\r\n Result := FCRC;\r\nend;\r\n\r\nfunction TJclCompressionItem.GetCreationTime: TFileTime;\r\nbegin\r\n CheckGetProperty(ipCreationTime);\r\n Result := FCreationTime;\r\nend;\r\n\r\nfunction TJclCompressionItem.GetDirectory: Boolean;\r\nbegin\r\n Result := (Attributes and FILE_ATTRIBUTE_DIRECTORY) <> 0;\r\nend;\r\n\r\nfunction TJclCompressionItem.GetEncrypted: Boolean;\r\nbegin\r\n CheckGetProperty(ipEncrypted);\r\n Result := FEncrypted;\r\nend;\r\n\r\nfunction TJclCompressionItem.GetFileName: TFileName;\r\nbegin\r\n CheckGetProperty(ipFileName);\r\n Result := FFileName;\r\nend;\r\n\r\nfunction TJclCompressionItem.GetFileSize: Int64;\r\nbegin\r\n CheckGetProperty(ipFileSize);\r\n Result := FFileSize;\r\nend;\r\n\r\nfunction TJclCompressionItem.GetGroup: WideString;\r\nbegin\r\n CheckGetProperty(ipGroup);\r\n Result := FGroup;\r\nend;\r\n\r\nfunction TJclCompressionItem.GetHostFS: WideString;\r\nbegin\r\n CheckGetProperty(ipHostFS);\r\n Result := FHostFS;\r\nend;\r\n\r\nfunction TJclCompressionItem.GetHostOS: WideString;\r\nbegin\r\n CheckGetProperty(ipHostOS);\r\n Result := FHostOS;\r\nend;\r\n\r\nfunction TJclCompressionItem.GetItemKind: TJclCompressionItemKind;\r\nbegin\r\n if (Attributes and FILE_ATTRIBUTE_DIRECTORY) <> 0 then\r\n Result := ikDirectory\r\n else\r\n Result := ikFile;\r\nend;\r\n\r\nfunction TJclCompressionItem.GetLastAccessTime: TFileTime;\r\nbegin\r\n CheckGetProperty(ipLastAccessTime);\r\n Result := FLastAccessTime;\r\nend;\r\n\r\nfunction TJclCompressionItem.GetLastWriteTime: TFileTime;\r\nbegin\r\n CheckGetProperty(ipLastWriteTime);\r\n Result := FLastWriteTime;\r\nend;\r\n\r\nfunction TJclCompressionItem.GetMethod: WideString;\r\nbegin\r\n CheckGetProperty(ipMethod);\r\n Result := FMethod;\r\nend;\r\n\r\nfunction TJclCompressionItem.GetNestedArchiveName: WideString;\r\nvar\r\n ParentArchiveExtension, ArchiveFileName, ArchiveExtension: WideString;\r\n ExtensionMap: TJclWideStrings;\r\nbegin\r\n if ipPackedName in ValidProperties then\r\n Result := PackedName\r\n else\r\n begin\r\n ArchiveFileName := '';\r\n ArchiveExtension := '';\r\n\r\n // find archive file name\r\n if Archive.VolumeCount > 0 then\r\n ArchiveFileName := WideExtractFileName(WideString(Archive.Volumes[0].FileName));\r\n if (ArchiveFileName <> '') and (WideExtractFileExt(ArchiveFileName) = '.001') then\r\n ArchiveFileName := WideChangeFileExt(ArchiveFileName, '');\r\n ParentArchiveExtension := WideExtractFileExt(ArchiveFileName);\r\n ArchiveFileName := WideChangeFileExt(ArchiveFileName, '');\r\n\r\n // find item extension\r\n ArchiveExtension := WideExtractFileExt(ArchiveFileName);\r\n if ArchiveExtension <> '' then\r\n ArchiveFileName := WideChangeFileExt(ArchiveFileName, '')\r\n else\r\n if ipPackedExtension in ValidProperties then\r\n ArchiveExtension := PackedExtension\r\n else\r\n if ArchiveFileName <> '' then\r\n begin\r\n ExtensionMap := TJclWideStringList.Create;\r\n try\r\n ExtensionMap.Delimiter := ';';\r\n ExtensionMap.DelimitedText := Archive.ArchiveSubExtensions;\r\n ArchiveExtension := ExtensionMap.Values[ParentArchiveExtension];\r\n finally\r\n ExtensionMap.Free;\r\n end;\r\n end;\r\n\r\n // elaborate result\r\n if (ArchiveFileName = '') and (ArchiveExtension = '') then\r\n raise EJclCompressionError.CreateRes(@RsCompressionUnavailableProperty)\r\n else\r\n if ArchiveFileName = '' then\r\n Result := ArchiveExtension\r\n else\r\n Result := WideChangeFileExt(ArchiveFileName, ArchiveExtension);\r\n end;\r\nend;\r\n\r\nfunction TJclCompressionItem.GetNestedArchiveStream: TStream;\r\nbegin\r\n raise EJclCompressionError.CreateRes(@RsCompressionNoNestedArchive);\r\nend;\r\n\r\nfunction TJclCompressionItem.GetPackedExtension: WideString;\r\nbegin\r\n CheckGetProperty(ipPackedExtension);\r\n if FPackedName = '' then\r\n Result := FPackedExtension\r\n else\r\n Result := WideExtractFileExt(FPackedName);\r\nend;\r\n\r\nfunction TJclCompressionItem.GetPackedName: WideString;\r\nbegin\r\n CheckGetProperty(ipPackedName);\r\n Result := FPackedName;\r\nend;\r\n\r\nfunction TJclCompressionItem.GetPackedSize: Int64;\r\nbegin\r\n CheckGetProperty(ipPackedSize);\r\n Result := FPackedSize;\r\nend;\r\n\r\nfunction TJclCompressionItem.GetStream: TStream;\r\nbegin\r\n if not Assigned(FStream) and (FileName <> '') then\r\n FStream := OpenFileStream(FileName, Archive.ItemAccess);\r\n\r\n Result := FStream;\r\nend;\r\n\r\nfunction TJclCompressionItem.GetUser: WideString;\r\nbegin\r\n CheckGetProperty(ipUser);\r\n Result := FUser;\r\nend;\r\n\r\nprocedure TJclCompressionItem.ReleaseStream;\r\nbegin\r\n if OwnsStream or (FileName <> '') then\r\n FreeAndNil(FStream);\r\nend;\r\n\r\nprocedure TJclCompressionItem.SetAttributes(Value: Cardinal);\r\nbegin\r\n CheckSetProperty(ipAttributes);\r\n FAttributes := Value;\r\n Include(FModifiedProperties, ipAttributes);\r\n Include(FValidProperties, ipAttributes);\r\nend;\r\n\r\nprocedure TJclCompressionItem.SetComment(const Value: WideString);\r\nbegin\r\n CheckSetProperty(ipComment);\r\n FComment := Value;\r\n Include(FModifiedProperties, ipComment);\r\n Include(FValidProperties, ipComment);\r\nend;\r\n\r\nprocedure TJclCompressionItem.SetCRC(Value: Cardinal);\r\nbegin\r\n CheckSetProperty(ipCRC);\r\n FCRC := Value;\r\n Include(FModifiedProperties, ipCRC);\r\n Include(FValidProperties, ipCRC);\r\nend;\r\n\r\nprocedure TJclCompressionItem.SetCreationTime(const Value: TFileTime);\r\nbegin\r\n CheckSetProperty(ipCreationTime);\r\n FCreationTime := Value;\r\n Include(FModifiedProperties, ipCreationTime);\r\n Include(FValidProperties, ipCreationTime);\r\nend;\r\n\r\nprocedure TJclCompressionItem.SetDirectory(Value: Boolean);\r\nbegin\r\n CheckSetProperty(ipAttributes);\r\n if Value then\r\n FAttributes := FAttributes or FILE_ATTRIBUTE_DIRECTORY\r\n else\r\n FAttributes := FAttributes and (not FILE_ATTRIBUTE_DIRECTORY);\r\n Include(FModifiedProperties, ipAttributes);\r\n Include(FValidProperties, ipAttributes);\r\nend;\r\n\r\nprocedure TJclCompressionItem.SetEncrypted(Value: Boolean);\r\nbegin\r\n CheckSetProperty(ipEncrypted);\r\n FEncrypted := Value;\r\n Include(FModifiedProperties, ipEncrypted);\r\n Include(FValidProperties, ipEncrypted);\r\nend;\r\n\r\nprocedure TJclCompressionItem.SetFileName(const Value: TFileName);\r\nvar\r\n AFindData: TWin32FindData;\r\nbegin\r\n CheckSetProperty(ipFileName);\r\n FFileName := Value;\r\n if Value <> '' then\r\n begin\r\n Include(FModifiedProperties, ipFileName);\r\n Include(FValidProperties, ipFileName);\r\n end\r\n else\r\n begin\r\n Exclude(FModifiedProperties, ipFileName);\r\n Exclude(FValidProperties, ipFileName);\r\n end;\r\n\r\n if (Value <> '') and (FArchive is TJclCompressionArchive)\r\n and GetFileAttributesEx(PChar(Value), GetFileExInfoStandard, @AFindData) then\r\n begin\r\n FileSize := (Int64(AFindData.nFileSizeHigh) shl 32) or AFindData.nFileSizeLow;\r\n Attributes := AFindData.dwFileAttributes;\r\n CreationTime := AFindData.ftCreationTime;\r\n LastAccessTime := AFindData.ftLastAccessTime;\r\n LastWriteTime := AFindData.ftLastWriteTime;\r\n // TODO: user name and group (using file handle and GetSecurityInfo)\r\n {$IFDEF MSWINDOWS}\r\n HostOS := LoadResString(@RsCompression7zWindows);\r\n {$ENDIF MSWINDOWS}\r\n {$IFDEF UNIX}\r\n HostOS := LoadResString(@RsCompression7zUnix);\r\n {$ENDIF UNIX}\r\n end;\r\nend;\r\n\r\nprocedure TJclCompressionItem.SetFileSize(const Value: Int64);\r\nbegin\r\n CheckSetProperty(ipFileSize);\r\n FFileSize := Value;\r\n Include(FModifiedProperties, ipFileSize);\r\n Include(FValidProperties, ipFileSize);\r\nend;\r\n\r\nprocedure TJclCompressionItem.SetGroup(const Value: WideString);\r\nbegin\r\n CheckSetProperty(ipGroup);\r\n FGroup := Value;\r\n Include(FModifiedProperties, ipGroup);\r\n Include(FValidProperties, ipGroup);\r\nend;\r\n\r\nprocedure TJclCompressionItem.SetHostFS(const Value: WideString);\r\nbegin\r\n CheckSetProperty(ipHostFS);\r\n FHostFS := Value;\r\n Include(FModifiedProperties, ipHostFS);\r\n Include(FValidProperties, ipHostFS);\r\nend;\r\n\r\nprocedure TJclCompressionItem.SetHostOS(const Value: WideString);\r\nbegin\r\n CheckSetProperty(ipHostOS);\r\n FHostOS := Value;\r\n Include(FModifiedProperties, ipHostOS);\r\n Include(FValidProperties, ipHostOS);\r\nend;\r\n\r\nprocedure TJclCompressionItem.SetLastAccessTime(const Value: TFileTime);\r\nbegin\r\n CheckSetProperty(ipLastAccessTime);\r\n FLastAccessTime := Value;\r\n Include(FModifiedProperties, ipLastAccessTime);\r\n Include(FValidProperties, ipLastAccessTime);\r\nend;\r\n\r\nprocedure TJclCompressionItem.SetLastWriteTime(const Value: TFileTime);\r\nbegin\r\n CheckSetProperty(ipLastWriteTime);\r\n FLastWriteTime := Value;\r\n Include(FModifiedProperties, ipLastWriteTime);\r\n Include(FValidProperties, ipLastWriteTime);\r\nend;\r\n\r\nprocedure TJclCompressionItem.SetMethod(const Value: WideString);\r\nbegin\r\n CheckSetProperty(ipMethod);\r\n FMethod := Value;\r\n Include(FModifiedProperties, ipMethod);\r\n Include(FValidProperties, ipMethod);\r\nend;\r\n\r\nprocedure TJclCompressionItem.SetPackedExtension(const Value: WideString);\r\nbegin\r\n CheckSetProperty(ipPackedExtension);\r\n if (Value <> '') and (Value[1] <> '.') then\r\n // force heading '.'\r\n FPackedExtension := '.' + Value\r\n else\r\n FPackedExtension := Value;\r\n Include(FModifiedProperties, ipPackedExtension);\r\n Include(FValidProperties, ipPackedExtension);\r\nend;\r\n\r\nprocedure TJclCompressionItem.SetPackedName(const Value: WideString);\r\nvar\r\n PackedNamesIndex: Integer;\r\nbegin\r\n if FPackedName <> Value then\r\n begin\r\n CheckSetProperty(ipPackedName);\r\n if FArchive is TJclCompressArchive then\r\n begin\r\n PackedNamesIndex := -1;\r\n if (TJclCompressArchive(FArchive).FPackedNames <> nil) and\r\n TJclCompressArchive(FArchive).FPackedNames.Find(FPackedName, PackedNamesIndex) then\r\n begin\r\n TJclCompressArchive(FArchive).FPackedNames.Delete(PackedNamesIndex);\r\n try\r\n TJclCompressArchive(FArchive).FPackedNames.Add(Value);\r\n except\r\n raise EJclCompressionError(Format(LoadResString(@RsCompressionDuplicate), [Value]));\r\n end;\r\n end;\r\n end;\r\n FPackedName := Value;\r\n Include(FModifiedProperties, ipPackedName);\r\n Include(FValidProperties, ipPackedName);\r\n end;\r\nend;\r\n\r\nprocedure TJclCompressionItem.SetPackedSize(const Value: Int64);\r\nbegin\r\n CheckSetProperty(ipPackedSize);\r\n FPackedSize := Value;\r\n Include(FModifiedProperties, ipPackedSize);\r\n Include(FValidProperties, ipPackedSize);\r\nend;\r\n\r\nprocedure TJclCompressionItem.SetStream(const Value: TStream);\r\nbegin\r\n CheckSetProperty(ipStream);\r\n ReleaseStream;\r\n FStream := Value;\r\n if Value <> nil then begin\r\n Include(FModifiedProperties, ipStream);\r\n Include(FValidProperties, ipStream);\r\n end\r\n else begin\r\n Exclude(FModifiedProperties, ipStream);\r\n Exclude(FValidProperties, ipStream);\r\n end;\r\nend;\r\n\r\nprocedure TJclCompressionItem.SetUser(const Value: WideString);\r\nbegin\r\n CheckSetProperty(ipUser);\r\n FUser := Value;\r\n Include(FModifiedProperties, ipUser);\r\n Include(FValidProperties, ipUser);\r\nend;\r\n\r\nfunction TJclCompressionItem.UpdateFileTimes: Boolean;\r\nconst\r\n FILE_WRITE_ATTRIBUTES = $00000100;\r\nvar\r\n FileHandle: HFILE;\r\n ACreationTime, ALastAccessTime, ALastWriteTime: PFileTime;\r\nbegin\r\n ReleaseStream;\r\n Result := FFileName <> '';\r\n if Result then\r\n begin\r\n FileHandle := CreateFile(PChar(FFileName), FILE_WRITE_ATTRIBUTES, FILE_SHARE_READ, nil, OPEN_ALWAYS, 0, 0);\r\n try\r\n // creation time should be the oldest\r\n if ipCreationTime in FValidProperties then\r\n ACreationTime := @FCreationTime\r\n else\r\n if ipLastWriteTime in FValidProperties then\r\n ACreationTime := @FLastWriteTime\r\n else\r\n if ipLastAccessTime in FValidProperties then\r\n ACreationTime := @FLastAccessTime\r\n else\r\n ACreationTime := nil;\r\n\r\n // last access time may default to now if not set\r\n if ipLastAccessTime in FValidProperties then\r\n ALastAccessTime := @FLastAccessTime\r\n else\r\n ALastAccessTime := nil;\r\n\r\n // last write time may, if not set, be the creation time or last access time\r\n if ipLastWriteTime in FValidProperties then\r\n ALastWriteTime := @FLastWriteTime\r\n else\r\n if ipCreationTime in FValidProperties then\r\n ALastWriteTime := @FCreationTime\r\n else\r\n if ipLastAccessTime in FValidProperties then\r\n ALastWriteTime := @FLastAccessTime\r\n else\r\n ALastWriteTime := nil;\r\n\r\n Result := (FileHandle <> INVALID_HANDLE_VALUE) and SetFileTime(FileHandle, ACreationTime, ALastAccessTime,\r\n ALastWriteTime);\r\n finally\r\n CloseHandle(FileHandle);\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJclCompressionItem.ValidateExtraction(Index: Integer): Boolean;\r\nbegin\r\n Result := False;\r\nend;\r\n\r\nfunction TJclCompressionItem.WideChangeFileExt(const AFileName,\r\n AExtension: WideString): WideString;\r\nvar\r\n Index: Integer;\r\nbegin\r\n Result := AFileName;\r\n // Unicode version of ChangeFileExt\r\n for Index := Length(Result) downto 1 do\r\n begin\r\n case Result[Index] of\r\n '.':\r\n begin\r\n Result := Copy(Result, 1, Index - 1) + AExtension;\r\n Exit;\r\n end;\r\n DirSeparator,\r\n DirDelimiter:\r\n // no extension\r\n Break;\r\n end;\r\n end;\r\n Result := Result + AExtension;\r\nend;\r\n\r\nfunction TJclCompressionItem.WideExtractFileExt(\r\n const AFileName: WideString): WideString;\r\nvar\r\n Index: Integer;\r\nbegin\r\n Result := '';\r\n // Unicode version of ExtractFileExt\r\n for Index := Length(AFileName) downto 1 do\r\n begin\r\n case AFileName[Index] of\r\n '.':\r\n begin\r\n Result := Copy(AFileName, Index, Length(AFileName) - Index + 1);\r\n Break;\r\n end;\r\n DirSeparator,\r\n DirDelimiter:\r\n // no extension\r\n Break;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJclCompressionItem.WideExtractFileName(\r\n const AFileName: WideString): WideString;\r\nvar\r\n Index: Integer;\r\nbegin\r\n Result := AFileName;\r\n // Unicode version of ExtractFileName\r\n for Index := Length(AFileName) downto 1 do\r\n begin\r\n case AFileName[Index] of\r\n DirSeparator,\r\n DirDelimiter:\r\n begin\r\n Result := Copy(AFileName, Index + 1, Length(AFileName) - Index);\r\n Break;\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\n//=== { TJclCompressionArchiveFormats } ======================================\r\n\r\nconstructor TJclCompressionArchiveFormats.Create;\r\nbegin\r\n inherited Create;\r\n FCompressFormats := TList.Create;\r\n FDecompressFormats := TList.Create;\r\n FUpdateFormats := TList.Create;\r\n // register compression archives\r\n RegisterFormat(TJclZipCompressArchive);\r\n RegisterFormat(TJclBZ2CompressArchive);\r\n RegisterFormat(TJcl7zCompressArchive);\r\n RegisterFormat(TJclTarCompressArchive);\r\n RegisterFormat(TJclGZipCompressArchive);\r\n RegisterFormat(TJclXzCompressArchive);\r\n RegisterFormat(TJclSwfcCompressArchive);\r\n RegisterFormat(TJclWimCompressArchive);\r\n // register decompression archives\r\n RegisterFormat(TJclZipDecompressArchive);\r\n RegisterFormat(TJclBZ2DecompressArchive);\r\n RegisterFormat(TJclRarDecompressArchive);\r\n RegisterFormat(TJclArjDecompressArchive);\r\n RegisterFormat(TJclZDecompressArchive);\r\n RegisterFormat(TJclLzhDecompressArchive);\r\n RegisterFormat(TJcl7zDecompressArchive);\r\n RegisterFormat(TJclCabDecompressArchive);\r\n RegisterFormat(TJclNsisDecompressArchive);\r\n RegisterFormat(TJclLzmaDecompressArchive);\r\n RegisterFormat(TJclLzma86DecompressArchive);\r\n RegisterFormat(TJclPeDecompressArchive);\r\n RegisterFormat(TJclElfDecompressArchive);\r\n RegisterFormat(TJclMachoDecompressArchive);\r\n RegisterFormat(TJclUdfDecompressArchive);\r\n RegisterFormat(TJclXarDecompressArchive);\r\n RegisterFormat(TJclMubDecompressArchive);\r\n RegisterFormat(TJclHfsDecompressArchive);\r\n RegisterFormat(TJclDmgDecompressArchive);\r\n RegisterFormat(TJclCompoundDecompressArchive);\r\n RegisterFormat(TJclWimDecompressArchive);\r\n RegisterFormat(TJclIsoDecompressArchive);\r\n RegisterFormat(TJclChmDecompressArchive);\r\n RegisterFormat(TJclSplitDecompressArchive);\r\n RegisterFormat(TJclRpmDecompressArchive);\r\n RegisterFormat(TJclDebDecompressArchive);\r\n RegisterFormat(TJclCpioDecompressArchive);\r\n RegisterFormat(TJclTarDecompressArchive);\r\n RegisterFormat(TJclGZipDecompressArchive);\r\n RegisterFormat(TJclNtfsDecompressArchive);\r\n RegisterFormat(TJclFatDecompressArchive);\r\n RegisterFormat(TJclMbrDecompressArchive);\r\n RegisterFormat(TJclVhdDecompressArchive);\r\n RegisterFormat(TJclMslzDecompressArchive);\r\n RegisterFormat(TJclFlvDecompressArchive);\r\n RegisterFormat(TJclSwfDecompressArchive);\r\n RegisterFormat(TJclSwfcDecompressArchive);\r\n RegisterFormat(TJclAPMDecompressArchive);\r\n RegisterFormat(TJclPpmdDecompressArchive);\r\n RegisterFormat(TJclTEDecompressArchive);\r\n RegisterFormat(TJclUEFIcDecompressArchive);\r\n RegisterFormat(TJclUEFIsDecompressArchive);\r\n RegisterFormat(TJclSquashFSDecompressArchive);\r\n RegisterFormat(TJclCramFSDecompressArchive);\r\n // register update archives\r\n RegisterFormat(TJclZipUpdateArchive);\r\n RegisterFormat(TJclBZ2UpdateArchive);\r\n RegisterFormat(TJcl7zUpdateArchive);\r\n RegisterFormat(TJclTarUpdateArchive);\r\n RegisterFormat(TJclGZipUpdateArchive);\r\n RegisterFormat(TJclSwfcUpdateArchive);\r\nend;\r\n\r\ndestructor TJclCompressionArchiveFormats.Destroy;\r\nbegin\r\n FCompressFormats.Free;\r\n FDecompressFormats.Free;\r\n FUpdateFormats.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJclCompressionArchiveFormats.FindCompressFormat(const AFileName: TFileName): TJclCompressArchiveClass;\r\nvar\r\n IndexFormat, IndexFilter: Integer;\r\n Filters: TStrings;\r\n AFormat: TJclCompressArchiveClass;\r\nbegin\r\n Result := nil;\r\n Filters := TStringList.Create;\r\n try\r\n for IndexFormat := 0 to CompressFormatCount - 1 do\r\n begin\r\n AFormat := CompressFormats[IndexFormat];\r\n StrTokenToStrings(AFormat.ArchiveExtensions, DirSeparator, Filters);\r\n for IndexFilter := 0 to Filters.Count - 1 do\r\n if IsFileNameMatch(AFileName, Filters.Strings[IndexFilter]) then\r\n begin\r\n Result := AFormat;\r\n Break;\r\n end;\r\n if Result <> nil then\r\n Break;\r\n end;\r\n finally\r\n Filters.Free;\r\n end;\r\nend;\r\n\r\nfunction TJclCompressionArchiveFormats.FindCompressFormats(\r\n const AFileName: TFileName): TJclCompressArchiveClassArray;\r\nvar\r\n IndexFormat, IndexFilter: Integer;\r\n Filters: TStrings;\r\n AFormat: TJclCompressArchiveClass;\r\nbegin\r\n SetLength(Result, 0);\r\n Filters := TStringList.Create;\r\n try\r\n for IndexFormat := 0 to CompressFormatCount - 1 do\r\n begin\r\n AFormat := CompressFormats[IndexFormat];\r\n StrTokenToStrings(AFormat.ArchiveExtensions, DirSeparator, Filters);\r\n for IndexFilter := 0 to Filters.Count - 1 do\r\n if IsFileNameMatch(AFileName, Filters.Strings[IndexFilter]) then\r\n begin\r\n SetLength(Result, Length(Result) + 1);\r\n Result[High(Result)] := AFormat;\r\n Break;\r\n end;\r\n end;\r\n finally\r\n Filters.Free;\r\n end;\r\nend;\r\n\r\n{function TJclCompressionArchiveFormats.FindDecompressFormat(const AFileName: TFileName;\r\n TestArchiveSignature: Boolean): TJclDecompressArchiveClass;\r\nvar\r\n MatchingFormats: TJclDecompressArchiveClassArray;\r\n Index: Integer;\r\n ArchiveStream: TStream;\r\n Buffer: TDynByteArray;\r\nbegin\r\n SetLength(Buffer, 0);\r\n\r\n // enumerate formats based on filename\r\n MatchingFormats := FindDecompressFormats(AFileName);\r\n if (Length(MatchingFormats) >= 1) and (not TestArchiveSignature) then\r\n begin\r\n Result := MatchingFormats[0];\r\n Exit;\r\n end\r\n else\r\n Result := nil;\r\n\r\n // load archive to test signature\r\n ArchiveStream := TFileStream.Create(AFileName, fmOpenRead and fmShareDenyNone);\r\n try\r\n for Index := Low(MatchingFormats) to High(MatchingFormats) do\r\n if SignatureMatches(MatchingFormats[Index], ArchiveStream, Buffer) then\r\n begin\r\n Result := MatchingFormats[Index];\r\n Exit;\r\n end;\r\n finally\r\n ArchiveStream.Free;\r\n end;\r\nend;}\r\n\r\nfunction TJclCompressionArchiveFormats.FindDecompressFormat(const AFileName: TFileName): TJclDecompressArchiveClass;\r\nvar\r\n MatchingFormats: TJclDecompressArchiveClassArray;\r\nbegin\r\n // enumerate formats based on filename\r\n MatchingFormats := FindDecompressFormats(AFileName);\r\n if Length(MatchingFormats) >= 1 then\r\n begin\r\n Result := MatchingFormats[0];\r\n Exit;\r\n end\r\n else\r\n Result := nil;\r\nend;\r\n\r\nfunction TJclCompressionArchiveFormats.FindDecompressFormats(\r\n const AFileName: TFileName): TJclDecompressArchiveClassArray;\r\nvar\r\n IndexFormat, IndexFilter: Integer;\r\n Filters: TStrings;\r\n AFormat: TJclDecompressArchiveClass;\r\nbegin\r\n SetLength(Result, 0);\r\n Filters := TStringList.Create;\r\n try\r\n for IndexFormat := 0 to DecompressFormatCount - 1 do\r\n begin\r\n AFormat := DecompressFormats[IndexFormat];\r\n StrTokenToStrings(AFormat.ArchiveExtensions, DirSeparator, Filters);\r\n for IndexFilter := 0 to Filters.Count - 1 do\r\n if IsFileNameMatch(AFileName, Filters.Strings[IndexFilter]) then\r\n begin\r\n SetLength(Result, Length(Result) + 1);\r\n Result[High(Result)] := AFormat;\r\n Break;\r\n end;\r\n end;\r\n finally\r\n Filters.Free;\r\n end;\r\nend;\r\n\r\n{function TJclCompressionArchiveFormats.FindUpdateFormat(const AFileName: TFileName;\r\n TestArchiveSignature: Boolean): TJclUpdateArchiveClass;\r\nvar\r\n MatchingFormats: TJclUpdateArchiveClassArray;\r\n Index: Integer;\r\n ArchiveStream: TStream;\r\n Buffer: TDynByteArray;\r\nbegin\r\n SetLength(Buffer, 0);\r\n\r\n // enumerate formats based on filename\r\n MatchingFormats := FindUpdateFormats(AFileName);\r\n if (Length(MatchingFormats) >= 1) and (not TestArchiveSignature) then\r\n begin\r\n Result := MatchingFormats[0];\r\n Exit;\r\n end\r\n else\r\n Result := nil;\r\n \r\n // load archive to test signature\r\n ArchiveStream := TFileStream.Create(AFileName, fmOpenRead and fmShareDenyNone);\r\n try\r\n for Index := Low(MatchingFormats) to High(MatchingFormats) do\r\n if SignatureMatches(MatchingFormats[Index], ArchiveStream, Buffer) then\r\n begin\r\n Result := MatchingFormats[Index];\r\n Exit;\r\n end;\r\n finally\r\n ArchiveStream.Free;\r\n end;\r\nend;}\r\n\r\nfunction TJclCompressionArchiveFormats.FindUpdateFormat(const AFileName: TFileName): TJclUpdateArchiveClass;\r\nvar\r\n MatchingFormats: TJclUpdateArchiveClassArray;\r\nbegin\r\n // enumerate formats based on filename\r\n MatchingFormats := FindUpdateFormats(AFileName);\r\n if Length(MatchingFormats) >= 1 then\r\n begin\r\n Result := MatchingFormats[0];\r\n Exit;\r\n end\r\n else\r\n Result := nil;\r\nend;\r\n\r\nfunction TJclCompressionArchiveFormats.FindUpdateFormats(\r\n const AFileName: TFileName): TJclUpdateArchiveClassArray;\r\nvar\r\n IndexFormat, IndexFilter: Integer;\r\n Filters: TStrings;\r\n AFormat: TJclUpdateArchiveClass;\r\nbegin\r\n SetLength(Result, 0);\r\n Filters := TStringList.Create;\r\n try\r\n for IndexFormat := 0 to UpdateFormatCount - 1 do\r\n begin\r\n AFormat := UpdateFormats[IndexFormat];\r\n StrTokenToStrings(AFormat.ArchiveExtensions, DirSeparator, Filters);\r\n for IndexFilter := 0 to Filters.Count - 1 do\r\n if IsFileNameMatch(AFileName, Filters.Strings[IndexFilter]) then\r\n begin\r\n SetLength(Result, Length(Result) + 1);\r\n Result[High(Result)] := AFormat;\r\n Break;\r\n end;\r\n end;\r\n finally\r\n Filters.Free;\r\n end;\r\nend;\r\n\r\nfunction TJclCompressionArchiveFormats.GetCompressFormat(Index: Integer): TJclCompressArchiveClass;\r\nbegin\r\n Result := TJclCompressArchiveClass(FCompressFormats.Items[Index]);\r\nend;\r\n\r\nfunction TJclCompressionArchiveFormats.GetCompressFormatCount: Integer;\r\nbegin\r\n Result := FCompressFormats.Count;\r\nend;\r\n\r\nfunction TJclCompressionArchiveFormats.GetDecompressFormat(Index: Integer): TJclDecompressArchiveClass;\r\nbegin\r\n Result := TJclDecompressArchiveClass(FDecompressFormats.Items[Index]);\r\nend;\r\n\r\nfunction TJclCompressionArchiveFormats.GetDecompressFormatCount: Integer;\r\nbegin\r\n Result := FDecompressFormats.Count;\r\nend;\r\n\r\nfunction TJclCompressionArchiveFormats.GetUpdateFormat(Index: Integer): TJclUpdateArchiveClass;\r\nbegin\r\n Result := TJclUpdateArchiveClass(FUpdateFormats.Items[Index]);\r\nend;\r\n\r\nfunction TJclCompressionArchiveFormats.GetUpdateFormatCount: Integer;\r\nbegin\r\n Result := FUpdateFormats.Count;\r\nend;\r\n\r\nprocedure TJclCompressionArchiveFormats.RegisterFormat(AClass: TJclCompressionArchiveClass);\r\nbegin\r\n if AClass.InheritsFrom(TJclUpdateArchive) then\r\n FUpdateFormats.Add(AClass)\r\n else\r\n if AClass.InheritsFrom(TJclDecompressArchive) then\r\n FDecompressFormats.Add(AClass)\r\n else\r\n if AClass.InheritsFrom(TJclCompressArchive) then\r\n FCompressFormats.Add(AClass);\r\nend;\r\n\r\n{function TJclCompressionArchiveFormats.SignatureMatches(\r\n Format: TJclCompressionArchiveClass; ArchiveStream: TStream;\r\n var Buffer: TDynByteArray): Boolean;\r\nvar\r\n Index, StartPos, EndPos: Integer;\r\n Signature: TDynByteArray;\r\nbegin\r\n // must match empty signatures\r\n Result := True;\r\n Signature := Format.ArchiveSignature;\r\n\r\n // fill buffer if needed\r\n StartPos := Length(Buffer); // High(Buffer) + 1\r\n EndPos := Length(Signature);\r\n if StartPos < EndPos then\r\n begin\r\n SetLength(Buffer, EndPos);\r\n for Index := StartPos to EndPos - 1 do\r\n ArchiveStream.ReadBuffer(Buffer[Index], SizeOf(Buffer[Index]));\r\n end;\r\n\r\n // compare buffer and signature\r\n for Index := 0 to EndPos - 1 do\r\n if Buffer[Index] <> Signature[Index] then\r\n begin\r\n Result := False;\r\n Break;\r\n end; \r\nend;}\r\n\r\nprocedure TJclCompressionArchiveFormats.UnregisterFormat(AClass: TJclCompressionArchiveClass);\r\nbegin\r\n if AClass.InheritsFrom(TJclUpdateArchive) then\r\n FUpdateFormats.Remove(AClass)\r\n else\r\n if AClass.InheritsFrom(TJclDecompressArchive) then\r\n FDecompressFormats.Remove(AClass)\r\n else\r\n if AClass.InheritsFrom(TJclCompressArchive) then\r\n FCompressFormats.Remove(AClass);\r\nend;\r\n\r\nfunction GetArchiveFormats: TJclCompressionArchiveFormats;\r\nbegin\r\n if not Assigned(GlobalArchiveFormats) then\r\n GlobalArchiveFormats := TJclCompressionArchiveFormats.Create;\r\n Result := TJclCompressionArchiveFormats(GlobalArchiveFormats);\r\nend;\r\n\r\n//=== { TJclCompressionVolume } ==============================================\r\n\r\nconstructor TJclCompressionVolume.Create(AStream, ATmpStream: TStream; AOwnsStream, AOwnsTmpStream: Boolean;\r\n AFileName, ATmpFileName: TFileName; AVolumeMaxSize: Int64);\r\nbegin\r\n inherited Create;\r\n FStream := AStream;\r\n FTmpStream := ATmpStream;\r\n FOwnsStream := AOwnsStream;\r\n FOwnsTmpStream := AOwnsTmpStream;\r\n FFileName := AFileName;\r\n FTmpFileName := ATmpFileName;\r\n FVolumeMaxSize := AVolumeMaxSize;\r\nend;\r\n\r\ndestructor TJclCompressionVolume.Destroy;\r\nbegin\r\n ReleaseStreams;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJclCompressionVolume.ReleaseStreams;\r\nbegin\r\n if OwnsStream then\r\n FreeAndNil(FStream);\r\n if OwnsTmpStream then\r\n FreeAndNil(FTmpStream);\r\nend;\r\n\r\n//=== { TJclCompressionArchive } =============================================\r\n\r\nconstructor TJclCompressionArchive.Create(Volume0: TStream;\r\n AVolumeMaxSize: Int64 = 0; AOwnVolume: Boolean = False);\r\nbegin\r\n inherited Create;\r\n FVolumeIndex := -1;\r\n FVolumeIndexOffset := 1;\r\n FVolumeMaxSize := AVolumeMaxSize;\r\n FItems := TObjectList.Create(True);\r\n FVolumes := TObjectList.Create(True);\r\n if Assigned(Volume0) then\r\n AddVolume(Volume0, AVolumeMaxSize, AOwnVolume);\r\n InitializeArchiveProperties;\r\nend;\r\n\r\nconstructor TJclCompressionArchive.Create(const VolumeFileName: TFileName;\r\n AVolumeMaxSize: Int64 = 0; VolumeMask: Boolean = False);\r\nbegin\r\n inherited Create;\r\n FVolumeIndex := -1;\r\n FVolumeIndexOffset := 1;\r\n FVolumeMaxSize := AVolumeMaxSize;\r\n FItems := TObjectList.Create(True);\r\n FVolumes := TObjectList.Create(True);\r\n if VolumeMask then\r\n FVolumeFileNameMask := VolumeFileName\r\n else\r\n AddVolume(VolumeFileName, AVolumeMaxSize);\r\n InitializeArchiveProperties;\r\nend;\r\n\r\ndestructor TJclCompressionArchive.Destroy;\r\nbegin\r\n FItems.Free;\r\n FVolumes.Free;\r\n\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJclCompressionArchive.AddVolume(VolumeStream: TStream;\r\n AVolumeMaxSize: Int64; AOwnsStream: Boolean): Integer;\r\nbegin\r\n Result := FVolumes.Add(TJclCompressionVolume.Create(VolumeStream, nil, AOwnsStream, True, '', '', AVolumeMaxSize));\r\nend;\r\n\r\nfunction TJclCompressionArchive.AddVolume(VolumeStream, TmpVolumeStream: TStream;\r\n AVolumeMaxSize: Int64; AOwnsStream, AOwnsTmpStream: Boolean): Integer;\r\nbegin\r\n Result := FVolumes.Add(TJclCompressionVolume.Create(VolumeStream, TmpVolumeStream, AOwnsStream, AOwnsTmpStream, '', '', AVolumeMaxSize));\r\nend;\r\n\r\nfunction TJclCompressionArchive.AddVolume(const VolumeFileName: TFileName;\r\n AVolumeMaxSize: Int64): Integer;\r\nbegin\r\n Result := FVolumes.Add(TJclCompressionVolume.Create(nil, nil, True, True, VolumeFileName, '', AVolumeMaxSize));\r\nend;\r\n\r\nfunction TJclCompressionArchive.AddVolume(const VolumeFileName, TmpVolumeFileName: TFileName;\r\n AVolumeMaxSize: Int64): Integer;\r\nbegin\r\n Result := FVolumes.Add(TJclCompressionVolume.Create(nil, nil, True, True, VolumeFileName, TmpVolumeFileName, AVolumeMaxSize));\r\nend;\r\n\r\nclass function TJclCompressionArchive.ArchiveExtensions: string;\r\nbegin\r\n Result := '';\r\nend;\r\n\r\nclass function TJclCompressionArchive.ArchiveName: string;\r\nbegin\r\n Result := '';\r\nend;\r\n\r\nclass function TJclCompressionArchive.ArchiveSignature: TDynByteArray;\r\nbegin\r\n SetLength(Result, 0);\r\nend;\r\n\r\nclass function TJclCompressionArchive.ArchiveSubExtensions: string;\r\nbegin\r\n Result := '';\r\nend;\r\n\r\nprocedure TJclCompressionArchive.CheckOperationSuccess;\r\nvar\r\n Index: Integer;\r\nbegin\r\n for Index := 0 to FItems.Count - 1 do\r\n begin\r\n case TJclCompressionItem(FItems.Items[Index]).OperationSuccess of\r\n osNoOperation: ;\r\n osOK: ;\r\n osUnsupportedMethod:\r\n raise EJclCompressionError.CreateRes(@RsCompressionUnsupportedMethod);\r\n osDataError:\r\n raise EJclCompressionError.CreateRes(@RsCompressionDataError);\r\n osCRCError:\r\n raise EJclCompressionError.CreateRes(@RsCompressionCRCError);\r\n else\r\n raise EJclCompressionError.CreateRes(@RsCompressionUnknownError);\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJclCompressionArchive.ClearItems;\r\nbegin\r\n FItems.Clear;\r\nend;\r\n\r\nprocedure TJclCompressionArchive.ClearOperationSuccess;\r\nvar\r\n Index: Integer;\r\nbegin\r\n for Index := 0 to FItems.Count - 1 do\r\n TJclCompressionItem(FItems.Items[Index]).OperationSuccess := osNoOperation;\r\nend;\r\n\r\nprocedure TJclCompressionArchive.ClearVolumes;\r\nbegin\r\n FVolumes.Clear;\r\nend;\r\n\r\nprocedure TJclCompressionArchive.InitializeArchiveProperties;\r\nbegin\r\n // override to customize\r\nend;\r\n\r\nfunction TJclCompressionArchive.DoProgress(const Value, MaxValue: Int64): Boolean;\r\nbegin\r\n if Assigned(FOnProgress) then\r\n FOnProgress(Self, Value, MaxValue);\r\n Result := not FCancelCurrentOperation;\r\nend;\r\n\r\nfunction TJclCompressionArchive.DoRatio(const InSize, OutSize: Int64): Boolean;\r\nbegin\r\n if Assigned(FOnRatio) then\r\n FOnRatio(Self, InSize, OutSize);\r\n Result := not FCancelCurrentOperation;\r\nend;\r\n\r\nfunction TJclCompressionArchive.GetItem(Index: Integer): TJclCompressionItem;\r\nbegin\r\n Result := TJclCompressionItem(FItems.Items[Index]);\r\nend;\r\n\r\nfunction TJclCompressionArchive.GetItemCount: Integer;\r\nbegin\r\n Result := FItems.Count;\r\nend;\r\n\r\nfunction TJclCompressionArchive.GetSupportsNestedArchive: Boolean;\r\nbegin\r\n Result := False;\r\nend;\r\n\r\nfunction TJclCompressionArchive.GetVolume(Index: Integer): TJclCompressionVolume;\r\nbegin\r\n Result := TJclCompressionVolume(FVolumes.Items[Index]);\r\nend;\r\n\r\nfunction TJclCompressionArchive.GetVolumeCount: Integer;\r\nbegin\r\n Result := FVolumes.Count;\r\nend;\r\n\r\nfunction TJclCompressionArchive.InternalOpenStream(\r\n const FileName: TFileName): TStream;\r\nbegin\r\n Result := OpenFileStream(FileName, VolumeAccess);\r\nend;\r\n\r\nfunction TJclCompressionArchive.ItemAccess: TJclStreamAccess;\r\nbegin\r\n Result := saReadOnly;\r\nend;\r\n\r\nclass function TJclCompressionArchive.MultipleItemContainer: Boolean;\r\nbegin\r\n Result := True;\r\nend;\r\n\r\nfunction TJclCompressionArchive.NeedStream(Index: Integer): TStream;\r\nvar\r\n AVolume: TJclCompressionVolume;\r\n AOwnsStream: Boolean;\r\n AFileName: TFileName;\r\nbegin\r\n Result := nil;\r\n\r\n if Index <> FVolumeIndex then\r\n begin\r\n AOwnsStream := VolumeFileNameMask <> '';\r\n AVolume := nil;\r\n AFileName := Format(VolumeFileNameMask, [Index + VolumeIndexOffset]);\r\n if (Index >= 0) and (Index < FVolumes.Count) then\r\n begin\r\n AVolume := TJclCompressionVolume(FVolumes.Items[Index]);\r\n Result := AVolume.Stream;\r\n AOwnsStream := AVolume.OwnsStream;\r\n AFileName := AVolume.FileName;\r\n end;\r\n\r\n if Assigned(FOnVolume) then\r\n FOnVolume(Self, Index, AFileName, Result, AOwnsStream);\r\n\r\n if Assigned(AVolume) then\r\n begin\r\n if not Assigned(Result) then\r\n Result := InternalOpenStream(AFileName);\r\n AVolume.FFileName := AFileName;\r\n AVolume.FStream := Result;\r\n AVolume.FOwnsStream := AOwnsStream;\r\n end\r\n else\r\n begin\r\n while FVolumes.Count < Index do\r\n FVolumes.Add(TJclCompressionVolume.Create(nil, nil, True, True, Format(VolumeFileNameMask, [Index + VolumeIndexOffset]), '', FVolumeMaxSize));\r\n if not Assigned(Result) then\r\n Result := InternalOpenStream(AFileName);\r\n if Assigned(Result) then\r\n begin\r\n if Index < FVolumes.Count then\r\n begin\r\n AVolume := TJclCompressionVolume(FVolumes.Items[Index]);\r\n AVolume.FFileName := AFileName;\r\n AVolume.FStream := Result;\r\n AVolume.FOwnsStream := AOwnsStream;\r\n AVolume.FVolumeMaxSize := FVolumeMaxSize;\r\n end\r\n else\r\n FVolumes.Add(TJclCompressionVolume.Create(Result, nil, AOwnsStream, True, AFileName, '', FVolumeMaxSize));\r\n end;\r\n end;\r\n FVolumeIndex := Index;\r\n end\r\n else\r\n if (Index >= 0) and (Index < FVolumes.Count) then\r\n begin\r\n AVolume := TJclCompressionVolume(FVolumes.Items[Index]);\r\n Result := AVolume.Stream;\r\n if Assigned(Result) then\r\n Result.Seek(0, soBeginning);\r\n end\r\n else\r\n FVolumeIndex := Index;\r\nend;\r\n\r\nfunction TJclCompressionArchive.NeedStreamMaxSize(Index: Integer): Int64;\r\nvar\r\n AVolume: TJclCompressionVolume;\r\nbegin\r\n if (Index <> FVolumeIndex) then\r\n begin\r\n AVolume := nil;\r\n if (Index >= 0) and (Index < FVolumes.Count) then\r\n begin\r\n AVolume := TJclCompressionVolume(FVolumes.Items[Index]);\r\n FVolumeMaxSize := AVolume.VolumeMaxSize;\r\n end;\r\n if Assigned(FOnVolumeMaxSize) then\r\n FOnVolumeMaxSize(Self, Index, FVolumeMaxSize);\r\n if Assigned(AVolume) then\r\n AVolume.FVolumeMaxSize := FVolumeMaxSize\r\n else\r\n begin\r\n while FVolumes.Count < Index do\r\n FVolumes.Add(TJclCompressionVolume.Create(nil, nil, True, True, Format(VolumeFileNameMask, [Index + VolumeIndexOffset]), '', FVolumeMaxSize));\r\n if Index < FVolumes.Count then\r\n begin\r\n AVolume := TJclCompressionVolume(FVolumes.Items[Index]);\r\n AVolume.FFileName := Format(VolumeFileNameMask, [Index + VolumeIndexOffset]);\r\n AVolume.FStream := nil;\r\n AVolume.FOwnsStream := True;\r\n AVolume.FVolumeMaxSize := FVolumeMaxSize;\r\n end\r\n else\r\n FVolumes.Add(TJclCompressionVolume.Create(nil, nil, True, True, Format(VolumeFileNameMask, [Index + VolumeIndexOffset]), '', FVolumeMaxSize));\r\n end;\r\n end;\r\n Result := FVolumeMaxSize;\r\nend;\r\n\r\nprocedure TJclCompressionArchive.ReleaseVolumes;\r\nvar\r\n Index: Integer;\r\nbegin\r\n for Index := 0 to FVolumes.Count - 1 do\r\n TJclCompressionVolume(FVolumes.Items[Index]).ReleaseStreams;\r\nend;\r\n\r\nprocedure TJclCompressionArchive.SelectAll;\r\nvar\r\n Index: Integer;\r\nbegin\r\n for Index := 0 to FItems.Count - 1 do\r\n TJclCompressionItem(FItems.Items[Index]).Selected := True;\r\nend;\r\n\r\nfunction TJclCompressionArchive.TranslateItemPath(const ItemPath, OldBase,\r\n NewBase: WideString): WideString;\r\nbegin\r\n Result := PathCanonicalize(PathAddSeparator(NewBase) + PathGetRelativePath(OldBase, ItemPath));\r\nend;\r\n\r\nprocedure TJclCompressionArchive.UnselectAll;\r\nvar\r\n Index: Integer;\r\nbegin\r\n for Index := 0 to FItems.Count - 1 do\r\n TJclCompressionItem(FItems.Items[Index]).Selected := False;\r\nend;\r\n\r\nclass function TJclCompressionArchive.VolumeAccess: TJclStreamAccess;\r\nbegin\r\n Result := saReadOnly;\r\nend;\r\n\r\nfunction TJclCompressionArchive._AddRef: Integer;\r\nbegin\r\n Result := -1;\r\nend;\r\n\r\nfunction TJclCompressionArchive._Release: Integer;\r\nbegin\r\n Result := -1;\r\nend;\r\n\r\n//=== { TJclCompressItem } ===================================================\r\n\r\nprocedure TJclCompressItem.CheckGetProperty(\r\n AProperty: TJclCompressionItemProperty);\r\nbegin\r\n // always valid\r\nend;\r\n\r\nprocedure TJclCompressItem.CheckSetProperty(\r\n AProperty: TJclCompressionItemProperty);\r\nbegin\r\n if AProperty in [ipMethod] then\r\n raise EJclCompressionError.CreateRes(@RsCompressionWriteNotSupported);\r\n (Archive as TJclCompressArchive).CheckNotCompressing;\r\nend;\r\n\r\n//=== { TJclCompressArchive } ================================================\r\n\r\ndestructor TJclCompressArchive.Destroy;\r\nbegin\r\n FPackedNames.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJclCompressArchive.AddDirectory(const PackedName: WideString;\r\n const DirName: string; RecurseIntoDir: Boolean; AddFilesInDir: Boolean): Integer;\r\nvar\r\n AItem: TJclCompressionItem;\r\nbegin\r\n CheckNotCompressing;\r\n\r\n if DirName <> '' then\r\n begin\r\n FBaseRelName := PackedName;\r\n FBaseDirName := PathRemoveSeparator(DirName);\r\n FAddFilesInDir := AddFilesInDir;\r\n\r\n if RecurseIntoDir then\r\n begin\r\n Result := FItems.Count;\r\n EnumDirectories(DirName, InternalAddDirectory, True, '', nil);\r\n Exit;\r\n end;\r\n end;\r\n\r\n AItem := GetItemClass.Create(Self);\r\n try\r\n AItem.PackedName := PackedName;\r\n AItem.FileName := DirName;\r\n except\r\n AItem.Destroy;\r\n raise;\r\n end;\r\n\r\n Result := AddFileCheckDuplicate(AItem);\r\n\r\n if (DirName <> '') and AddFilesInDir then\r\n EnumFiles(PathAddSeparator(DirName) + '*', InternalAddFile, faDirectory);\r\nend;\r\n\r\nfunction TJclCompressArchive.AddFile(const PackedName: WideString;\r\n const FileName: TFileName): Integer;\r\nvar\r\n AItem: TJclCompressionItem;\r\nbegin\r\n CheckNotCompressing;\r\n\r\n AItem := GetItemClass.Create(Self);\r\n try\r\n AItem.PackedName := PackedName;\r\n AItem.FileName := FileName;\r\n except\r\n AItem.Destroy;\r\n raise;\r\n end;\r\n\r\n Result := AddFileCheckDuplicate(AItem);\r\nend;\r\n\r\nfunction TJclCompressArchive.AddFile(const PackedName: WideString;\r\n AStream: TStream; AOwnsStream: Boolean): Integer;\r\nvar\r\n AItem: TJclCompressionItem;\r\n NowFileTime: TFileTime;\r\nbegin\r\n CheckNotCompressing;\r\n\r\n AItem := GetItemClass.Create(Self);\r\n try\r\n AItem.PackedName := PackedName;\r\n AItem.Stream := AStream;\r\n AItem.OwnsStream := AOwnsStream;\r\n AItem.FileSize := AStream.Size - AStream.Position;\r\n NowFileTime := LocalDateTimeToFileTime(Now);\r\n AItem.Attributes := faReadOnly and faArchive;\r\n AItem.CreationTime := NowFileTime;\r\n AItem.LastAccessTime := NowFileTime;\r\n AItem.LastWriteTime := NowFileTime;\r\n {$IFDEF MSWINDOWS}\r\n AItem.HostOS := LoadResString(@RsCompression7zWindows);\r\n {$ENDIF MSWINDOWS}\r\n {$IFDEF UNIX}\r\n AItem.HostOS := LoadResString(@RsCompression7zUnix);\r\n {$ENDIF UNIX}\r\n except\r\n AItem.Destroy;\r\n raise;\r\n end;\r\n\r\n Result := AddFileCheckDuplicate(AItem);\r\nend;\r\n\r\nfunction TJclCompressArchive.AddFileCheckDuplicate(NewItem: TJclCompressionItem): Integer;\r\nvar\r\n I, PackedNamesIndex: Integer;\r\n S: string;\r\nbegin\r\n if FDuplicateCheck = dcNone then\r\n Result := FItems.Add(NewItem)\r\n else\r\n begin\r\n if FPackedNames = nil then\r\n begin\r\n FPackedNames := TJclWideStringList.Create;\r\n FPackedNames.Sorted := True;\r\n {$IFDEF UNIX}\r\n FPackedNames.CaseSensitive := True;\r\n {$ELSE ~UNIX}\r\n FPackedNames.CaseSensitive := False;\r\n {$ENDIF ~UNIX}\r\n FPackedNames.Duplicates := dupIgnore;\r\n for I := ItemCount - 1 downto 0 do\r\n FPackedNames.AddObject(Items[I].PackedName, Items[I]);\r\n FPackedNames.Duplicates := dupError;\r\n end;\r\n if DuplicateCheck = dcAll then\r\n begin\r\n try\r\n PackedNamesIndex := -1;\r\n FPackedNames.AddObject(NewItem.PackedName, NewItem);\r\n Result := FItems.Add(NewItem);\r\n except\r\n Result := -1;\r\n end;\r\n end\r\n else\r\n if FPackedNames.Find(NewItem.PackedName, PackedNamesIndex) then\r\n Result := -1\r\n else\r\n Result := FItems.Add(NewItem);\r\n if Result < 0 then\r\n begin\r\n case DuplicateAction of\r\n daOverwrite:\r\n begin\r\n if PackedNamesIndex < 0 then\r\n PackedNamesIndex := FPackedNames.IndexOf(NewItem.PackedName);\r\n FItems.Remove(FPackedNames.Objects[PackedNamesIndex]);\r\n Result := FItems.Add(NewItem);\r\n if DuplicateCheck = dcAll then\r\n FPackedNames.Objects[PackedNamesIndex] := NewItem\r\n else\r\n FPackedNames.Delete(PackedNamesIndex);\r\n end;\r\n daError:\r\n begin\r\n S := Format(LoadResString(@RsCompressionDuplicate), [NewItem.PackedName]);\r\n NewItem.Free;\r\n raise EJclCompressionError.Create(S);\r\n end;\r\n daSkip:\r\n begin\r\n NewItem.Free;\r\n Result := -1;\r\n end;\r\n end\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJclCompressArchive.CheckNotCompressing;\r\nbegin\r\n if FCompressing then\r\n raise EJclCompressionError.CreateRes(@RsCompressionCompressingError);\r\nend;\r\n\r\nprocedure TJclCompressArchive.Compress;\r\nbegin\r\n// Calling ReleaseVolumes here causes subsequent operations on the archive to fail with an \"unsupported method\" exception\r\n// ReleaseVolumes;\r\nend;\r\n\r\nprocedure TJclCompressArchive.InternalAddDirectory(const Directory: string);\r\nbegin\r\n AddDirectory(TranslateItemPath(Directory, FBaseDirName, FBaseRelName), Directory, False, FAddFilesInDir);\r\nend;\r\n\r\nprocedure TJclCompressArchive.InternalAddFile(const Directory: string;\r\n const FileInfo: TSearchRec);\r\nvar\r\n AFileName: TFileName;\r\n AItem: TJclCompressionItem;\r\nbegin\r\n AFileName := PathAddSeparator(Directory) + FileInfo.Name;\r\n\r\n AItem := GetItemClass.Create(Self);\r\n try\r\n AItem.PackedName := TranslateItemPath(AFileName, FBaseDirName, FBaseRelName);\r\n AItem.FileName := AFileName;\r\n except\r\n AItem.Destroy;\r\n raise;\r\n end;\r\n\r\n AddFileCheckDuplicate(AItem);\r\nend;\r\n\r\nfunction TJclCompressArchive.ItemAccess: TJclStreamAccess;\r\nbegin\r\n Result := saReadOnly;\r\nend;\r\n\r\nclass function TJclCompressArchive.VolumeAccess: TJclStreamAccess;\r\nbegin\r\n Result := saWriteOnly;\r\nend;\r\n\r\n//=== { TJclDecompressItem } =================================================\r\n\r\nprocedure TJclDecompressItem.CheckGetProperty(\r\n AProperty: TJclCompressionItemProperty);\r\nbegin\r\n // TODO\r\nend;\r\n\r\nprocedure TJclDecompressItem.CheckSetProperty(\r\n AProperty: TJclCompressionItemProperty);\r\nbegin\r\n (Archive as TJclDecompressArchive).CheckNotDecompressing;\r\nend;\r\n\r\nfunction TJclDecompressItem.ValidateExtraction(Index: Integer): Boolean;\r\nbegin\r\n Result := (FArchive as TJclDecompressArchive).ValidateExtraction(Index,\r\n FFileName, FStream, FOwnsStream);\r\nend;\r\n\r\n//=== { TJclDecompressArchive } ==============================================\r\n\r\nprocedure TJclDecompressArchive.CheckListing;\r\nbegin\r\n if not FListing then\r\n raise EJclCompressionError.CreateRes(@RsCompressionUnavailableProperty);\r\nend;\r\n\r\nprocedure TJclDecompressArchive.CheckNotDecompressing;\r\nbegin\r\n if FDecompressing then\r\n raise EJclCompressionError.CreateRes(@RsCompressionDecompressingError);\r\nend;\r\n\r\nprocedure TJclDecompressArchive.ExtractAll(const ADestinationDir: string;\r\n AAutoCreateSubDir: Boolean);\r\nbegin\r\n// Calling ReleaseVolumes here causes subsequent operations on the archive to fail with an \"unsupported method\" exception\r\n// ReleaseVolumes;\r\nend;\r\n\r\nprocedure TJclDecompressArchive.ExtractSelected(const ADestinationDir: string;\r\n AAutoCreateSubDir: Boolean);\r\nbegin\r\n// Calling ReleaseVolumes here causes subsequent operations on the archive to fail with an \"unsupported method\" exception\r\n// ReleaseVolumes;\r\nend;\r\n\r\nfunction TJclDecompressArchive.ItemAccess: TJclStreamAccess;\r\nbegin\r\n Result := saCreate;\r\nend;\r\n\r\nfunction TJclDecompressArchive.ValidateExtraction(Index: Integer;\r\n var FileName: TFileName; var AStream: TStream; var AOwnsStream: Boolean): Boolean;\r\nvar\r\n AItem: TJclCompressionItem;\r\n PackedName: TFileName;\r\nbegin\r\n if FExtractingAllIndex <> -1 then\r\n // extracting all\r\n FExtractingAllIndex := Index;\r\n\r\n AItem := Items[Index];\r\n\r\n if (FileName = '') and not Assigned(AStream) then\r\n begin\r\n PackedName := AItem.PackedName;\r\n\r\n if PackedName = '' then\r\n PackedName := ChangeFileExt(ExtractFileName(Volumes[0].FileName), AItem.PackedExtension);\r\n\r\n FileName := PathGetRelativePath(FDestinationDir, PackedName);\r\n end;\r\n Result := True;\r\n\r\n if Assigned(FOnExtract) then\r\n Result := FOnExtract(Self, Index, FileName, AStream, AOwnsStream);\r\n\r\n if Result and not Assigned(AStream) and AutoCreateSubDir then\r\n begin\r\n if (AItem.Attributes and faDirectory) <> 0 then\r\n ForceDirectories(FileName)\r\n else\r\n ForceDirectories(ExtractFilePath(FileName));\r\n end;\r\nend;\r\n\r\nclass function TJclDecompressArchive.VolumeAccess: TJclStreamAccess;\r\nbegin\r\n Result := saReadOnly;\r\nend;\r\n\r\n//=== { TJclUpdateItem } =====================================================\r\n\r\nprocedure TJclUpdateItem.CheckGetProperty(\r\n AProperty: TJclCompressionItemProperty);\r\nbegin\r\n // TODO\r\nend;\r\n\r\nprocedure TJclUpdateItem.CheckSetProperty(\r\n AProperty: TJclCompressionItemProperty);\r\nbegin\r\n (Archive as TJclCompressArchive).CheckNotCompressing;\r\nend;\r\n\r\nfunction TJclUpdateItem.ValidateExtraction(Index: Integer): Boolean;\r\nbegin\r\n Result := (Archive as TJclUpdateArchive).ValidateExtraction(Index, FFileName,\r\n FStream, FOwnsStream);\r\nend;\r\n\r\n//=== { TJclUpdateArchive } ==================================================\r\n\r\nprocedure TJclUpdateArchive.CheckListing;\r\nbegin\r\n if not FListing then\r\n raise EJclCompressionError.CreateRes(@RsCompressionUnavailableProperty);\r\nend;\r\n\r\nprocedure TJclUpdateArchive.CheckNotDecompressing;\r\nbegin\r\n if FDecompressing then\r\n raise EJclCompressionError.CreateRes(@RsCompressionDecompressingError);\r\nend;\r\n\r\nprocedure TJclUpdateArchive.ExtractAll(const ADestinationDir: string;\r\n AAutoCreateSubDir: Boolean);\r\nbegin\r\n// Calling ReleaseVolumes here causes subsequent operations on the archive to fail with an \"unsupported method\" exception\r\n// ReleaseVolumes;\r\nend;\r\n\r\nprocedure TJclUpdateArchive.ExtractSelected(const ADestinationDir: string;\r\n AAutoCreateSubDir: Boolean);\r\nbegin\r\n// Calling ReleaseVolumes here causes subsequent operations on the archive to fail with an \"unsupported method\" exception\r\n// ReleaseVolumes;\r\nend;\r\n\r\nprocedure TJclUpdateArchive.InitializeArchiveProperties;\r\nbegin\r\n inherited InitializeArchiveProperties;\r\n FDuplicateCheck := dcExisting;\r\nend;\r\n\r\nfunction TJclUpdateArchive.ItemAccess: TJclStreamAccess;\r\nbegin\r\n if FDecompressing then Result := saCreate\r\n else Result := saReadOnly;\r\nend;\r\n\r\nfunction TJclUpdateArchive.ValidateExtraction(Index: Integer;\r\n var FileName: TFileName; var AStream: TStream;\r\n var AOwnsStream: Boolean): Boolean;\r\nvar\r\n AItem: TJclCompressionItem;\r\n PackedName: TFileName;\r\nbegin\r\n if FExtractingAllIndex <> -1 then\r\n // extracting all\r\n FExtractingAllIndex := Index;\r\n\r\n AItem := Items[Index];\r\n\r\n if (FileName = '') and not Assigned(AStream) then\r\n begin\r\n PackedName := AItem.PackedName;\r\n\r\n if PackedName = '' then\r\n PackedName := ChangeFileExt(ExtractFileName(Volumes[0].FileName), AItem.PackedExtension);\r\n\r\n FileName := PathGetRelativePath(FDestinationDir, PackedName);\r\n end;\r\n Result := True;\r\n\r\n if Assigned(FOnExtract) then\r\n Result := FOnExtract(Self, Index, FileName, AStream, AOwnsStream);\r\n\r\n if Result and not Assigned(AStream) and AutoCreateSubDir then\r\n begin\r\n if (AItem.Attributes and faDirectory) <> 0 then\r\n ForceDirectories(FileName)\r\n else\r\n ForceDirectories(ExtractFilePath(FileName));\r\n end;\r\nend;\r\n\r\nclass function TJclUpdateArchive.VolumeAccess: TJclStreamAccess;\r\nbegin\r\n Result := saReadOnly;\r\nend;\r\n\r\n//=== { TJclOutOfPlaceUpdateArchive } ========================================\r\n\r\nprocedure TJclOutOfPlaceUpdateArchive.Compress;\r\nvar\r\n Index: Integer;\r\n AVolume: TJclCompressionVolume;\r\n SrcFileName, DestFileName: TFileName;\r\n SrcStream, DestStream: TStream;\r\n OwnsSrcStream, OwnsDestStream, AllHandled, Handled: Boolean;\r\n CopiedSize: Int64;\r\nbegin\r\n // release volume streams and other finalization\r\n inherited Compress;\r\n\r\n if ReplaceVolumes then\r\n begin\r\n AllHandled := True;\r\n\r\n // replace streams by tmp streams\r\n for Index := 0 to FVolumes.Count - 1 do\r\n begin\r\n AVolume := TJclCompressionVolume(FVolumes.Items[Index]);\r\n\r\n SrcFileName := AVolume.TmpFileName;\r\n DestFileName := AVolume.FileName;\r\n SrcStream := AVolume.TmpStream;\r\n DestStream := AVolume.Stream;\r\n OwnsSrcStream := AVolume.OwnsTmpStream;\r\n OwnsDestStream := AVolume.OwnsStream;\r\n\r\n Handled := Assigned(FOnReplace) and FOnReplace(Self, SrcFileName, DestFileName, SrcStream, DestStream, OwnsSrcStream, OwnsDestStream);\r\n\r\n if not Handled then\r\n begin\r\n if (SrcFileName <> '') and (DestFileName <> '') and\r\n (OwnsSrcStream or not Assigned(SrcStream)) and\r\n (OwnsDestStream or not Assigned(DestStream)) then\r\n begin\r\n // close references before moving files\r\n if OwnsSrcStream then\r\n FreeAndNil(SrcStream);\r\n if OwnsDestStream then\r\n FreeAndNil(DestStream);\r\n Handled := FileMove(SrcFileName, DestFileName, True);\r\n end\r\n else\r\n if (SrcFileName = '') and (DestFileName = '') and Assigned(SrcStream) and Assigned(DestStream) then\r\n begin\r\n // in-memory moves\r\n SrcStream.Seek(0, soBeginning);\r\n DestStream.Seek(0, soBeginning);\r\n CopiedSize := StreamCopy(SrcStream, DestStream);\r\n // reset size\r\n DestStream.Size := CopiedSize;\r\n Handled := True;\r\n end;\r\n // identity\r\n // else\r\n // Handled := False;\r\n end;\r\n\r\n // update volume information\r\n AVolume.FTmpStream := SrcStream;\r\n AVolume.FStream := DestStream;\r\n AVolume.FOwnsTmpStream := OwnsSrcStream;\r\n AVolume.FOwnsStream := OwnsDestStream;\r\n AVolume.FTmpFileName := SrcFileName;\r\n AVolume.FFileName := DestFileName;\r\n\r\n AllHandled := AllHandled and Handled;\r\n end;\r\n if not AllHandled then\r\n raise EJclCompressionError.CreateRes(@RsCompressionReplaceError);\r\n end;\r\nend;\r\n\r\nprocedure TJclOutOfPlaceUpdateArchive.InitializeArchiveProperties;\r\nbegin\r\n inherited InitializeArchiveProperties;\r\n FReplaceVolumes := True;\r\n FTmpVolumeIndex := -1;\r\nend;\r\n\r\nfunction TJclOutOfPlaceUpdateArchive.InternalOpenTmpStream(\r\n const FileName: TFileName): TStream;\r\nbegin\r\n Result := OpenFileStream(FileName, TmpVolumeAccess);\r\nend;\r\n\r\nfunction TJclOutOfPlaceUpdateArchive.NeedTmpStream(Index: Integer): TStream;\r\nvar\r\n AVolume: TJclCompressionVolume;\r\n AOwnsStream: Boolean;\r\n AFileName: TFileName;\r\nbegin\r\n Result := nil;\r\n\r\n if Index <> FTmpVolumeIndex then\r\n begin\r\n AOwnsStream := VolumeFileNameMask <> '';\r\n AVolume := nil;\r\n if VolumeFileNameMask = '' then AFileName := ''\r\n else AFileName := FindUnusedFileName(Format(VolumeFileNameMask, [Index + VolumeIndexOffset]), '.tmp');\r\n if (Index >= 0) and (Index < FVolumes.Count) then\r\n begin\r\n AVolume := TJclCompressionVolume(FVolumes.Items[Index]);\r\n Result := AVolume.TmpStream;\r\n AOwnsStream := AVolume.OwnsTmpStream;\r\n AFileName := AVolume.TmpFileName;\r\n if (AFileName = '') and (AVolume.FileName <> '') then\r\n AFileName := FindUnusedFileName(AVolume.FileName, '.tmp');\r\n end;\r\n\r\n if Assigned(FOnTmpVolume) then\r\n FOnTmpVolume(Self, Index, AFileName, Result, AOwnsStream);\r\n\r\n if Assigned(AVolume) then\r\n begin\r\n if not Assigned(Result) then\r\n Result := InternalOpenTmpStream(AFileName);\r\n AVolume.FTmpFileName := AFileName;\r\n AVolume.FTmpStream := Result;\r\n AVolume.FOwnsTmpStream := AOwnsStream;\r\n end\r\n else\r\n begin\r\n while FVolumes.Count < Index do\r\n FVolumes.Add(TJclCompressionVolume.Create(nil, nil, True, True, Format(VolumeFileNameMask, [Index + VolumeIndexOffset]), '', FVolumeMaxSize));\r\n if not Assigned(Result) then\r\n Result := InternalOpenTmpStream(AFileName);\r\n if Assigned(Result) then\r\n begin\r\n if Index < FVolumes.Count then\r\n begin\r\n AVolume := TJclCompressionVolume(FVolumes.Items[Index]);\r\n AVolume.FTmpFileName := AFileName;\r\n AVolume.FTmpStream := Result;\r\n AVolume.FOwnsTmpStream := AOwnsStream;\r\n AVolume.FVolumeMaxSize := FVolumeMaxSize;\r\n end\r\n else\r\n FVolumes.Add(TJclCompressionVolume.Create(nil, Result, True, AOwnsStream, '', AFileName, FVolumeMaxSize));\r\n end;\r\n end;\r\n FTmpVolumeIndex := Index;\r\n end\r\n else\r\n if (Index >= 0) and (Index < FVolumes.Count) then\r\n begin\r\n AVolume := TJclCompressionVolume(FVolumes.Items[Index]);\r\n Result := AVolume.TmpStream;\r\n if Assigned(Result) then\r\n Result.Seek(0, soBeginning);\r\n end\r\n else\r\n FTmpVolumeIndex := Index;\r\nend;\r\n\r\nclass function TJclOutOfPlaceUpdateArchive.TmpVolumeAccess: TJclStreamAccess;\r\nbegin\r\n Result := saWriteOnly;\r\nend;\r\n\r\n//=== { TJclSevenzipOutStream } ==============================================\r\n\r\nconstructor TJclSevenzipOutStream.Create(AArchive: TJclCompressionArchive; AItemIndex: Integer);\r\nbegin\r\n inherited Create;\r\n\r\n FArchive := AArchive;\r\n FItemIndex := AItemIndex;\r\n FStream := nil;\r\n FOwnsStream := False;\r\n FMaximumPosition := 0;\r\n FTruncateOnRelease := False;\r\nend;\r\n\r\nconstructor TJclSevenzipOutStream.Create(AStream: TStream; AOwnsStream: Boolean; ATruncateOnRelease: Boolean);\r\nbegin\r\n inherited Create;\r\n\r\n FArchive := nil;\r\n FItemIndex := -1;\r\n FStream := AStream;\r\n FOwnsStream := AOwnsStream;\r\n FMaximumPosition := 0;\r\n FTruncateOnRelease := ATruncateOnRelease;\r\nend;\r\n\r\ndestructor TJclSevenzipOutStream.Destroy;\r\nbegin\r\n ReleaseStream;\r\n\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJclSevenzipOutStream.NeedStream;\r\nbegin\r\n if Assigned(FArchive) then\r\n begin\r\n FArchive.FCurrentItemIndex := FItemIndex;\r\n if not Assigned(FStream) then\r\n FStream := FArchive.Items[FItemIndex].Stream;\r\n end;\r\nend;\r\n\r\nprocedure TJclSevenzipOutStream.ReleaseStream;\r\nbegin\r\n // truncate to the maximum position that was written\r\n if FTruncateOnRelease then\r\n FStream.Size := FMaximumPosition;\r\n\r\n if Assigned(FArchive) then\r\n FArchive.Items[FItemIndex].ReleaseStream\r\n else\r\n if FOwnsStream then\r\n FStream.Free;\r\nend;\r\n\r\nfunction TJclSevenzipOutStream.Seek(Offset: Int64; SeekOrigin: Cardinal;\r\n NewPosition: PInt64): HRESULT;\r\nvar\r\n NewPos: Int64;\r\nbegin\r\n NeedStream;\r\n\r\n if Assigned(FStream) then\r\n begin\r\n Result := S_OK;\r\n // STREAM_SEEK_SET = 0 = soBeginning\r\n // STREAM_SEEK_CUR = 1 = soCurrent\r\n // STREAM_SEEK_END = 2 = soEnd\r\n NewPos := FStream.Seek(Offset, TSeekOrigin(SeekOrigin));\r\n if Assigned(NewPosition) then\r\n NewPosition^ := NewPos;\r\n end\r\n else\r\n Result := S_FALSE;\r\nend;\r\n\r\nfunction TJclSevenzipOutStream.SetSize(NewSize: Int64): HRESULT;\r\nbegin\r\n NeedStream;\r\n\r\n if Assigned(FStream) then\r\n begin\r\n Result := S_OK;\r\n FStream.Size := NewSize;\r\n if FTruncateOnRelease and (FMaximumPosition < NewSize) then\r\n FMaximumPosition := NewSize;\r\n end\r\n else\r\n Result := S_FALSE;\r\nend;\r\n\r\nfunction TJclSevenzipOutStream.Write(Data: Pointer; Size: Cardinal;\r\n ProcessedSize: PCardinal): HRESULT;\r\nvar\r\n Processed: Cardinal;\r\n APosition: Int64;\r\nbegin\r\n NeedStream;\r\n\r\n if Assigned(FStream) then\r\n begin\r\n Result := S_OK;\r\n Processed := FStream.Write(Data^, Size);\r\n if Assigned(ProcessedSize) then\r\n ProcessedSize^ := Processed;\r\n if FTruncateOnRelease then\r\n begin\r\n APosition := FStream.Position;\r\n if FMaximumPosition < APosition then\r\n FMaximumPosition := APosition;\r\n end;\r\n end\r\n else\r\n Result := S_FALSE;\r\nend;\r\n\r\n//=== { TJclSevenzipNestedInStream } =========================================\r\n\r\nconstructor TJclSevenzipNestedInStream.Create(AInStream: IInStream);\r\nbegin\r\n inherited Create;\r\n FInStream := AInStream;\r\nend;\r\n\r\nfunction TJclSevenzipNestedInStream.Read(var Buffer; Count: Integer): Longint;\r\nbegin\r\n SevenzipCheck(FInStream.Read(@Buffer, Count, @Result));\r\nend;\r\n\r\nfunction TJclSevenzipNestedInStream.Seek(const Offset: Int64;\r\n Origin: TSeekOrigin): Int64;\r\nbegin\r\n SevenzipCheck(FInStream.Seek(Offset, Cardinal(Origin), @Result));\r\nend;\r\n\r\nprocedure TJclSevenzipNestedInStream.SetSize(const NewSize: Int64);\r\nbegin\r\n raise EJclCompressionError.CreateRes(@RsCompressionWriteNotSupported);\r\nend;\r\n\r\nfunction TJclSevenzipNestedInStream.Write(const Buffer;\r\n Count: Integer): Longint;\r\nbegin\r\n raise EJclCompressionError.CreateRes(@RsCompressionWriteNotSupported);\r\nend;\r\n\r\n//=== { TJclSevenzipInStream } ===============================================\r\n\r\nconstructor TJclSevenzipInStream.Create(AArchive: TJclCompressionArchive; AItemIndex: Integer);\r\nbegin\r\n inherited Create;\r\n\r\n FArchive := AArchive;\r\n FItemIndex := AItemIndex;\r\n FStream := nil;\r\n FOwnsStream := False;\r\nend;\r\n\r\nconstructor TJclSevenzipInStream.Create(AStream: TStream; AOwnsStream: Boolean);\r\nbegin\r\n inherited Create;\r\n\r\n FArchive := nil;\r\n FItemIndex := -1;\r\n FStream := AStream;\r\n FOwnsStream := AOwnsStream;\r\nend;\r\n\r\ndestructor TJclSevenzipInStream.Destroy;\r\nbegin\r\n ReleaseStream;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJclSevenzipInStream.GetSize(Size: PInt64): HRESULT;\r\nbegin\r\n NeedStream;\r\n\r\n if Assigned(FStream) then\r\n begin\r\n if Assigned(Size) then\r\n Size^ := FStream.Size;\r\n Result := S_OK;\r\n end\r\n else\r\n Result := S_FALSE;\r\nend;\r\n\r\nprocedure TJclSevenzipInStream.NeedStream;\r\nbegin\r\n if Assigned(FArchive) then\r\n begin\r\n FArchive.FCurrentItemIndex := FItemIndex;\r\n if not Assigned(FStream) then\r\n FStream := FArchive.Items[FItemIndex].Stream;\r\n end;\r\nend;\r\n\r\nfunction TJclSevenzipInStream.Read(Data: Pointer; Size: Cardinal;\r\n ProcessedSize: PCardinal): HRESULT;\r\nvar\r\n Processed: Cardinal;\r\nbegin\r\n NeedStream;\r\n\r\n if Assigned(FStream) then\r\n begin\r\n Processed := FStream.Read(Data^, Size);\r\n if Assigned(ProcessedSize) then\r\n ProcessedSize^ := Processed;\r\n Result := S_OK;\r\n end\r\n else\r\n Result := S_FALSE;\r\nend;\r\n\r\nprocedure TJclSevenzipInStream.ReleaseStream;\r\nbegin\r\n if Assigned(FArchive) then\r\n FArchive.Items[FItemIndex].ReleaseStream\r\n else\r\n if FOwnsStream then\r\n FStream.Free;\r\nend;\r\n\r\nfunction TJclSevenzipInStream.Seek(Offset: Int64; SeekOrigin: Cardinal;\r\n NewPosition: PInt64): HRESULT;\r\nvar\r\n NewPos: Int64;\r\nbegin\r\n NeedStream;\r\n\r\n if Assigned(FStream) then\r\n begin\r\n // STREAM_SEEK_SET = 0 = soBeginning\r\n // STREAM_SEEK_CUR = 1 = soCurrent\r\n // STREAM_SEEK_END = 2 = soEnd\r\n NewPos := FStream.Seek(Offset, TSeekOrigin(SeekOrigin));\r\n if Assigned(NewPosition) then\r\n NewPosition^ := NewPos;\r\n Result := S_OK;\r\n end\r\n else\r\n Result := S_FALSE;\r\nend;\r\n\r\n// sevenzip helper functions\r\n\r\nprocedure SevenzipCheck(Value: HRESULT);\r\nbegin\r\n if (Value <> S_OK) and (Value <> E_ABORT) then\r\n raise EJclCompressionError.CreateResFmt(@RsCompression7zReturnError, [Value, SysErrorMessage(Value)]);\r\nend;\r\n\r\nfunction Get7zWideStringProp(const AArchive: IInArchive; ItemIndex: Integer;\r\n PropID: Cardinal; const Setter: TWideStringSetter): Boolean;\r\nvar\r\n Value: TPropVariant;\r\nbegin\r\n ZeroMemory(@Value, SizeOf(Value));\r\n SevenzipCheck(AArchive.GetProperty(ItemIndex, PropID, Value));\r\n case Value.vt of\r\n VT_EMPTY, VT_NULL:\r\n Result := False;\r\n VT_LPSTR:\r\n begin\r\n Result := True;\r\n Setter(WideString(AnsiString(Value.pszVal)));\r\n end;\r\n VT_LPWSTR:\r\n begin\r\n Result := True;\r\n Setter(Value.pwszVal);\r\n end;\r\n VT_BSTR:\r\n begin\r\n Result := True;\r\n Setter(Value.bstrVal);\r\n SysFreeString(Value.bstrVal);\r\n end;\r\n VT_I1:\r\n begin\r\n Result := True;\r\n Setter(IntToStr(Value.iVal));\r\n end;\r\n VT_I2:\r\n begin\r\n Result := True;\r\n Setter(IntToStr(Value.iVal));\r\n end;\r\n VT_INT, VT_I4:\r\n begin\r\n Result := True;\r\n Setter(IntToStr(Value.lVal));\r\n end;\r\n VT_I8:\r\n begin\r\n Result := True;\r\n Setter(IntToStr(Value.hVal.QuadPart));\r\n end;\r\n VT_UI1:\r\n begin\r\n Result := True;\r\n Setter(IntToStr(Value.bVal));\r\n end;\r\n VT_UI2:\r\n begin\r\n Result := True;\r\n Setter(IntToStr(Value.uiVal));\r\n end;\r\n VT_UINT, VT_UI4:\r\n begin\r\n Result := True;\r\n Setter(IntToStr(Value.ulVal));\r\n end;\r\n VT_UI8:\r\n begin\r\n Result := True;\r\n Setter(IntToStr(Value.uhVal.QuadPart));\r\n end;\r\n else\r\n raise EJclCompressionError.CreateResFmt(@RsCompression7zUnknownValueType, [Value.vt, PropID]);\r\n end;\r\nend;\r\n\r\nfunction Get7zCardinalProp(const AArchive: IInArchive; ItemIndex: Integer;\r\n PropID: Cardinal; const Setter: TCardinalSetter): Boolean;\r\nvar\r\n Value: TPropVariant;\r\nbegin\r\n ZeroMemory(@Value, SizeOf(Value));\r\n SevenzipCheck(AArchive.GetProperty(ItemIndex, PropID, Value));\r\n case Value.vt of\r\n VT_EMPTY, VT_NULL:\r\n Result := False;\r\n VT_I1, VT_I2, VT_INT, VT_I4, VT_I8,\r\n VT_UI1, VT_UI2, VT_UINT, VT_UI4, VT_UI8:\r\n begin\r\n Result := True;\r\n case Value.vt of\r\n VT_I1:\r\n Setter(Value.iVal);\r\n VT_I2:\r\n Setter(Value.iVal);\r\n VT_INT, VT_I4:\r\n Setter(Value.lVal);\r\n VT_I8:\r\n Setter(Value.hVal.QuadPart);\r\n VT_UI1:\r\n Setter(Value.bVal);\r\n VT_UI2:\r\n Setter(Value.uiVal);\r\n VT_UINT, VT_UI4:\r\n Setter(Value.ulVal);\r\n VT_UI8:\r\n Setter(Value.uhVal.QuadPart);\r\n end;\r\n end;\r\n else\r\n raise EJclCompressionError.CreateResFmt(@RsCompression7zUnknownValueType, [Value.vt, PropID]);\r\n end;\r\nend;\r\n\r\nfunction Get7zInt64Prop(const AArchive: IInArchive; ItemIndex: Integer;\r\n PropID: Cardinal; const Setter: TInt64Setter): Boolean;\r\nvar\r\n Value: TPropVariant;\r\nbegin\r\n ZeroMemory(@Value, SizeOf(Value));\r\n SevenzipCheck(AArchive.GetProperty(ItemIndex, PropID, Value));\r\n case Value.vt of\r\n VT_EMPTY, VT_NULL:\r\n Result := False;\r\n VT_I1, VT_I2, VT_INT, VT_I4, VT_I8,\r\n VT_UI1, VT_UI2, VT_UINT, VT_UI4, VT_UI8:\r\n begin\r\n Result := True;\r\n case Value.vt of\r\n VT_I1:\r\n Setter(Value.iVal);\r\n VT_I2:\r\n Setter(Value.iVal);\r\n VT_INT, VT_I4:\r\n Setter(Value.lVal);\r\n VT_I8:\r\n Setter(Value.hVal.QuadPart);\r\n VT_UI1:\r\n Setter(Value.bVal);\r\n VT_UI2:\r\n Setter(Value.uiVal);\r\n VT_UINT, VT_UI4:\r\n Setter(Value.ulVal);\r\n VT_UI8:\r\n Setter(Value.uhVal.QuadPart);\r\n end;\r\n end;\r\n else\r\n raise EJclCompressionError.CreateResFmt(@RsCompression7zUnknownValueType, [Value.vt, PropID]);\r\n end;\r\nend;\r\n\r\nfunction Get7zFileTimeProp(const AArchive: IInArchive; ItemIndex: Integer;\r\n PropID: Cardinal; const Setter: TFileTimeSetter): Boolean;\r\nvar\r\n Value: TPropVariant;\r\nbegin\r\n ZeroMemory(@Value, SizeOf(Value));\r\n SevenzipCheck(AArchive.GetProperty(ItemIndex, PropID, Value));\r\n case Value.vt of\r\n VT_EMPTY, VT_NULL:\r\n Result := False;\r\n VT_FILETIME:\r\n begin\r\n Result := True;\r\n Setter(Value.filetime);\r\n end;\r\n else\r\n raise EJclCompressionError.CreateResFmt(@RsCompression7zUnknownValueType, [Value.vt, PropID]);\r\n end;\r\nend;\r\n\r\nfunction Get7zBoolProp(const AArchive: IInArchive; ItemIndex: Integer;\r\n PropID: Cardinal; const Setter: TBoolSetter): Boolean;\r\nvar\r\n Value: TPropVariant;\r\nbegin\r\n ZeroMemory(@Value, SizeOf(Value));\r\n SevenzipCheck(AArchive.GetProperty(ItemIndex, PropID, Value));\r\n case Value.vt of\r\n VT_EMPTY, VT_NULL:\r\n Result := False;\r\n VT_BOOL:\r\n begin\r\n Result := True;\r\n Setter(Value.bool);\r\n end;\r\n else\r\n raise EJclCompressionError.CreateResFmt(@RsCompression7zUnknownValueType, [Value.vt, PropID]);\r\n end;\r\nend;\r\n\r\n// TODO: Are changes for UTF-8 filenames (>= 4.58 beta) necessary?\r\nprocedure Load7zFileAttribute(AInArchive: IInArchive; ItemIndex: Integer;\r\n AItem: TJclCompressionItem);\r\nbegin\r\n AItem.FValidProperties := [];\r\n AItem.FPackedIndex := ItemIndex;\r\n AItem.FileName := '';\r\n AItem.Stream := nil;\r\n AItem.OwnsStream := False;\r\n\r\n // sometimes, items have neither names nor extension although other properties may succeed\r\n Get7zWideStringProp(AInArchive, ItemIndex, kpidPath, AItem.SetPackedName);\r\n Get7zWideStringProp(AInArchive, ItemIndex, kpidExtension, AItem.SetPackedExtension);\r\n Get7zCardinalProp(AInArchive, ItemIndex, kpidAttrib, AItem.SetAttributes);\r\n // SetDirectory must be after SetAttributes\r\n Get7zBoolProp(AInArchive, ItemIndex, kpidIsDir, AItem.SetDirectory);\r\n Get7zInt64Prop(AInArchive, ItemIndex, kpidSize, AItem.SetFileSize);\r\n Get7zInt64Prop(AInArchive, ItemIndex, kpidPackSize, AItem.SetPackedSize);\r\n Get7zFileTimeProp(AInArchive, ItemIndex, kpidCTime, AItem.SetCreationTime);\r\n Get7zFileTimeProp(AInArchive, ItemIndex, kpidATime, AItem.SetLastAccessTime);\r\n Get7zFileTimeProp(AInArchive, ItemIndex, kpidMTime, AItem.SetLastWriteTime);\r\n Get7zWideStringProp(AInArchive, ItemIndex, kpidComment, AItem.SetComment);\r\n Get7zWideStringProp(AInArchive, ItemIndex, kpidHostOS, AItem.SetHostOS);\r\n Get7zWideStringProp(AInArchive, ItemIndex, kpidFileSystem, AItem.SetHostFS);\r\n Get7zWideStringProp(AInArchive, ItemIndex, kpidUser, AItem.SetUser);\r\n Get7zWideStringProp(AInArchive, ItemIndex, kpidGroup, AItem.SetGroup);\r\n Get7zCardinalProp(AInArchive, ItemIndex, kpidCRC, AItem.SetCRC);\r\n Get7zWideStringProp(AInArchive, ItemIndex, kpidMethod, AItem.SetMethod);\r\n Get7zBoolProp(AInArchive, ItemIndex, kpidEncrypted, AItem.SetEncrypted);\r\n\r\n // reset modified flags\r\n AItem.ModifiedProperties := [];\r\nend;\r\n\r\nprocedure GetSevenzipArchiveCompressionProperties(AJclArchive: IInterface; ASevenzipArchive: IInterface);\r\nbegin\r\n // TODO properties from ASevenzipArchive to AJclArchive\r\nend;\r\n\r\nprocedure SetSevenzipArchiveCompressionProperties(AJclArchive: IInterface; ASevenzipArchive: IInterface);\r\nvar\r\n PropertySetter: Sevenzip.ISetProperties;\r\n InArchive, OutArchive: Boolean;\r\n Unused: IInterface;\r\n MultiThreadStrategy: IJclArchiveNumberOfThreads;\r\n CompressionMethod: IJclArchiveCompressionMethod;\r\n CompressionLevel: IJclArchiveCompressionLevel;\r\n EncryptionMethod: IJclArchiveEncryptionMethod;\r\n DictionarySize: IJclArchiveDictionarySize;\r\n NumberOfPasses: IJclArchiveNumberOfPasses;\r\n RemoveSfxBlock: IJclArchiveRemoveSfxBlock;\r\n CompressHeader: IJclArchiveCompressHeader;\r\n EncryptHeader: IJclArchiveEncryptHeader;\r\n SaveCreationDateTime: IJclArchiveSaveCreationDateTime;\r\n SaveLastAccessDateTime: IJclArchiveSaveLastAccessDateTime;\r\n SaveLastWriteDateTime: IJclArchiveSaveLastWriteDateTime;\r\n Algorithm: IJclArchiveAlgorithm;\r\n Solid: IJclArchiveSolid;\r\n PropNames: array of PWideChar;\r\n PropValues: array of TPropVariant;\r\n\r\n procedure AddProperty(const Name: PWideChar; const Value: TPropVariant);\r\n begin\r\n SetLength(PropNames, Length(PropNames)+1);\r\n PropNames[High(PropNames)] := Name;\r\n SetLength(PropValues, Length(PropValues)+1);\r\n PropValues[High(PropValues)] := Value;\r\n end;\r\n\r\n procedure AddCardinalProperty(const Name: PWideChar; Value: Cardinal);\r\n var\r\n PropValue: TPropVariant;\r\n begin\r\n PropValue.vt := VT_UI4;\r\n PropValue.ulVal := Value;\r\n AddProperty(Name, PropValue);\r\n end;\r\n\r\n procedure AddWideStringProperty(const Name: PWideChar; const Value: WideString);\r\n var\r\n PropValue: TPropVariant;\r\n begin\r\n PropValue.vt := VT_BSTR;\r\n PropValue.bstrVal := SysAllocString(PWideChar(Value));\r\n AddProperty(Name, PropValue);\r\n end;\r\n\r\n procedure AddBooleanProperty(const Name: PWideChar; Value: Boolean);\r\n var\r\n PropValue: TPropVariant;\r\n const\r\n BooleanValues: array [False..True] of WideString = ( 'OFF', 'ON' );\r\n begin\r\n PropValue.vt := VT_BSTR;\r\n PropValue.bstrVal := SysAllocString(PWideChar(BooleanValues[Value]));\r\n AddProperty(Name, PropValue);\r\n end;\r\nconst\r\n EncryptionMethodNames: array [TJclEncryptionMethod] of WideString =\r\n ( '' {emNone},\r\n kAES128MethodName {emAES128},\r\n kAES192MethodName {emAES192},\r\n kAES256MethodName {emAES256},\r\n kZipCryptoMethodName {emZipCrypto} );\r\n CompressionMethodNames: array [TJclCompressionMethod] of WideString =\r\n ( kCopyMethodName {cmCopy},\r\n kDeflateMethodName {cmDeflate},\r\n kDeflate64MethodName {cmDeflate64},\r\n kBZip2MethodName {cmBZip2},\r\n kLZMAMethodName {cmLZMA},\r\n kLZMA2MethodName {cmLZMA2},\r\n kPPMdMethodName {cmPPMd} );\r\nbegin\r\n if Supports(ASevenzipArchive, Sevenzip.ISetProperties, PropertySetter) and Assigned(PropertySetter) then\r\n begin\r\n InArchive := Supports(ASevenzipArchive, Sevenzip.IInArchive, Unused);\r\n OutArchive := Supports(ASevenzipArchive, Sevenzip.IOutArchive, Unused);\r\n if (InArchive or OutArchive) and Supports(AJclArchive, IJclArchiveNumberOfThreads, MultiThreadStrategy)\r\n and Assigned(MultiThreadStrategy) and (MultiThreadStrategy.NumberOfThreads > 1) then\r\n AddCardinalProperty('MT', MultiThreadStrategy.NumberOfThreads);\r\n\r\n if OutArchive then\r\n begin\r\n if Supports(AJclArchive, IJclArchiveCompressionMethod, CompressionMethod) and Assigned(CompressionMethod) then\r\n AddWideStringProperty('M', CompressionMethodNames[CompressionMethod.CompressionMethod]);\r\n\r\n if Supports(AJclArchive, IJclArchiveCompressionLevel, CompressionLevel) and Assigned(CompressionLevel) then\r\n AddCardinalProperty('X', CompressionLevel.CompressionLevel);\r\n\r\n if Supports(AJclArchive, IJclArchiveEncryptionMethod, EncryptionMethod) and Assigned(EncryptionMethod)\r\n and (EncryptionMethod.EncryptionMethod <> emNone) then\r\n AddWideStringProperty('EM', EncryptionMethodNames[EncryptionMethod.EncryptionMethod]);\r\n\r\n if Supports(AJclArchive, IJclArchiveDictionarySize, DictionarySize) and Assigned(DictionarySize) and\r\n Supports(AJclArchive, IJclArchiveCompressionMethod, CompressionMethod) and Assigned(CompressionMethod) and\r\n (CompressionMethod.CompressionMethod in [cmBZip2,cmLZMA,cmLZMA2]) then\r\n AddWideStringProperty('D', IntToStr(DictionarySize.DictionarySize) + 'B');\r\n\r\n if Supports(AJclArchive, IJclArchiveNumberOfPasses, NumberOfPasses) and Assigned(NumberOfPasses) then\r\n AddCardinalProperty('PASS', NumberOfPasses.NumberOfPasses);\r\n\r\n if Supports(AJclArchive, IJclArchiveRemoveSfxBlock, RemoveSfxBlock) and Assigned(RemoveSfxBlock) then\r\n AddBooleanProperty('RSFX', RemoveSfxBlock.RemoveSfxBlock);\r\n\r\n if Supports(AJclArchive, IJclArchiveCompressHeader, CompressHeader) and Assigned(CompressHeader) then\r\n begin\r\n AddBooleanProperty('HC', CompressHeader.CompressHeader);\r\n if CompressHeader.CompressHeaderFull then\r\n AddBooleanProperty('HCF', CompressHeader.CompressHeaderFull);\r\n end;\r\n\r\n if Supports(AJclArchive, IJclArchiveEncryptHeader, EncryptHeader) and Assigned(EncryptHeader) then\r\n AddBooleanProperty('HE', EncryptHeader.EncryptHeader);\r\n\r\n if Supports(AJclArchive, IJclArchiveSaveCreationDateTime, SaveCreationDateTime)\r\n and Assigned(SaveCreationDateTime) then\r\n AddBooleanProperty('TC', SaveCreationDateTime.SaveCreationDateTime);\r\n\r\n if Supports(AJclArchive, IJclArchiveSaveLastAccessDateTime, SaveLastAccessDateTime)\r\n and Assigned(SaveLastAccessDateTime) then\r\n AddBooleanProperty('TA', SaveLastAccessDateTime.SaveLastAccessDateTime);\r\n\r\n if Supports(AJclArchive, IJclArchiveSaveLastWriteDateTime, SaveLastWriteDateTime)\r\n and Assigned(SaveLastWriteDateTime) then\r\n AddBooleanProperty('TM', SaveLastWriteDateTime.SaveLastWriteDateTime);\r\n\r\n if Supports(AJclArchive, IJclArchiveAlgorithm, Algorithm) and Assigned(Algorithm) then\r\n AddCardinalProperty('A', Algorithm.Algorithm);\r\n\r\n if Supports(AJclArchive, IJclArchiveSolid, Solid) and Assigned(Solid) then\r\n begin\r\n if Solid.SolidExtension then\r\n AddWideStringProperty('S', 'E');\r\n if Solid.SolidBlockSize > 0 then\r\n AddWideStringProperty('S', IntToStr(Solid.SolidBlockSize) + 'B')\r\n else\r\n AddWideStringProperty('S', IntToStr(Solid.SolidBlockSize) + 'F');\r\n end;\r\n end;\r\n if Length(PropNames) > 0 then\r\n SevenZipCheck(PropertySetter.SetProperties(@PropNames[0], @PropValues[0], Length(PropNames)));\r\n end;\r\nend;\r\n\r\nfunction Create7zFile(SourceFiles: TStrings; const DestinationFile: TFileName; VolumeSize: Int64; Password: String;\r\n OnArchiveProgress: TJclCompressionProgressEvent; OnArchiveRatio: TJclCompressionRatioEvent): Boolean;\r\nvar\r\n ArchiveFileName: string;\r\n SourceFile : String;\r\n AFormat: TJclUpdateArchiveClass;\r\n Archive : TJclCompressionArchive;\r\n i: Integer;\r\n InnerList : tStringList;\r\n j: Integer;\r\nbegin\r\n Result := False;\r\n ArchiveFileName := DestinationFile;\r\n\r\n AFormat := GetArchiveFormats.FindUpdateFormat(ArchiveFileName);\r\n\r\n if AFormat <> nil then\r\n begin\r\n\r\n if VolumeSize <> 0 then\r\n ArchiveFileName := ArchiveFileName + '.%.3d';\r\n\r\n Archive := AFormat.Create(ArchiveFileName, VolumeSize, VolumeSize <> 0);\r\n try\r\n Archive.Password := Password;\r\n Archive.OnProgress := OnArchiveProgress;\r\n Archive.OnRatio := OnArchiveRatio;\r\n\r\n InnerList := tStringList.Create;\r\n try\r\n for i := 0 to SourceFiles.Count - 1 do\r\n begin\r\n InnerList.Clear;\r\n BuildFileList(SourceFiles[i], faAnyFile, InnerList, True);\r\n for j := 0 to InnerList.Count - 1 do\r\n begin\r\n SourceFile:=InnerList[j];\r\n (Archive as TJclCompressArchive).AddFile(ExtractFileName(SourceFile), SourceFile);\r\n Result := True;\r\n end;\r\n end;\r\n finally\r\n InnerList.Free;\r\n end;\r\n (Archive as TJclCompressArchive).Compress;\r\n finally\r\n Archive.Free;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction Create7zFile(const SourceFile, DestinationFile: TFileName; VolumeSize: Int64; Password: String;\r\n OnArchiveProgress: TJclCompressionProgressEvent; OnArchiveRatio: TJclCompressionRatioEvent): Boolean;\r\nvar\r\n SourceFiles : TStringList;\r\nbegin\r\n SourceFiles := TStringList.Create;\r\n try\r\n SourceFiles.Add(SourceFile);\r\n Result := Create7zFile(SourceFiles, DestinationFile, VolumeSize, Password, OnArchiveProgress, OnArchiveRatio);\r\n finally\r\n SourceFiles.Free;\r\n end;\r\nend;\r\n\r\nfunction Get7zArchiveSignature(const ClassID: TGUID): TDynByteArray;\r\nvar\r\n I, NumberOfFormats: Cardinal;\r\n J: Integer;\r\n PropValue: TPropVariant;\r\n Found: Boolean;\r\n Data: PAnsiChar;\r\nbegin\r\n Found := False;\r\n SetLength(Result, 0);\r\n SevenzipCheck(Sevenzip.GetNumberOfFormats(@NumberOfFormats));\r\n for I := 0 to NumberOfFormats - 1 do\r\n begin\r\n SevenzipCheck(Sevenzip.GetHandlerProperty2(I, kClassID, PropValue));\r\n if PropValue.vt = VT_BSTR then\r\n begin\r\n try\r\n if SysStringByteLen(PropValue.bstrVal) = SizeOf(TGUID) then\r\n Found := GUIDEquals(PGUID(PropValue.bstrVal)^, ClassID)\r\n else\r\n raise EJclCompressionError.CreateRes(@RsCompressionDataError);\r\n finally\r\n SysFreeString(PropValue.bstrVal);\r\n end;\r\n end\r\n else\r\n raise EJclCompressionError.CreateResFmt(@RsCompression7zUnknownValueType, [PropValue.vt, kClassID]);\r\n\r\n if Found then\r\n begin\r\n SevenzipCheck(Sevenzip.GetHandlerProperty2(I, kStartSignature, PropValue));\r\n if PropValue.vt = VT_BSTR then\r\n begin\r\n try\r\n SetLength(Result, SysStringByteLen(PropValue.bstrVal));\r\n Data := PAnsiChar(PropValue.bstrVal);\r\n for J := Low(Result) to High(Result) do\r\n Result[J] := Ord(Data[J]);\r\n finally\r\n SysFreeString(PropValue.bstrVal);\r\n end;\r\n end\r\n else\r\n if PropValue.vt <> VT_EMPTY then\r\n raise EJclCompressionError.CreateResFmt(@RsCompression7zUnknownValueType, [PropValue.vt, kClassID]);\r\n Break;\r\n end;\r\n end;\r\nend;\r\n\r\n//=== { TJclSevenzipOutputCallback } =========================================\r\n\r\nconstructor TJclSevenzipUpdateCallback.Create(\r\n AArchive: TJclCompressionArchive);\r\nbegin\r\n inherited Create;\r\n FArchive := AArchive;\r\nend;\r\n\r\nfunction TJclSevenzipUpdateCallback.CryptoGetTextPassword2(\r\n PasswordIsDefined: PInteger; Password: PBStr): HRESULT;\r\nbegin\r\n if Assigned(PasswordIsDefined) then\r\n begin\r\n if FArchive.Password <> '' then\r\n PasswordIsDefined^ := Integer($FFFFFFFF)\r\n else\r\n PasswordIsDefined^ := 0;\r\n end;\r\n if Assigned(Password) then\r\n Password^ := SysAllocString(PWideChar(FArchive.Password));\r\n Result := S_OK;\r\nend;\r\n\r\nfunction TJclSevenzipUpdateCallback.GetProperty(Index, PropID: Cardinal;\r\n out Value: tagPROPVARIANT): HRESULT;\r\nvar\r\n AItem: TJclCompressionItem;\r\nbegin\r\n Result := S_OK;\r\n AItem := FArchive.Items[Index];\r\n case PropID of\r\n kpidNoProperty:\r\n Value.vt := VT_NULL;\r\n // kpidMainSubfile: ;\r\n // kpidHandlerItemIndex: ;\r\n kpidPath:\r\n begin\r\n Value.vt := VT_BSTR;\r\n Value.bstrVal := SysAllocString(PWideChar(AItem.PackedName));\r\n end;\r\n //kpidName: (read only)\r\n{ kpidExtension:\r\n begin\r\n Value.vt := VT_BSTR;\r\n Value.bstrVal := SysAllocString(PWideChar(WideString(ExtractFileExt(FCompressionStream.FileNames[Index]))));\r\n end;}\r\n kpidIsDir:\r\n begin\r\n Value.vt := VT_BOOL;\r\n Value.bool := AItem.Kind = ikDirectory;\r\n end;\r\n kpidSize:\r\n begin\r\n Value.vt := VT_UI8;\r\n Value.uhVal.QuadPart := AItem.FileSize;\r\n end;\r\n // kpidPackSize: ;\r\n kpidAttrib:\r\n begin\r\n Value.vt := VT_UI4;\r\n Value.ulVal := AItem.Attributes;\r\n end;\r\n kpidCTime:\r\n begin\r\n Value.vt := VT_FILETIME;\r\n Value.filetime := AItem.CreationTime;\r\n end;\r\n kpidATime:\r\n begin\r\n Value.vt := VT_FILETIME;\r\n Value.filetime := AItem.LastAccessTime;\r\n end;\r\n kpidMTime:\r\n begin\r\n Value.vt := VT_FILETIME;\r\n Value.filetime := AItem.LastWriteTime;\r\n end;\r\n kpidSolid:\r\n begin\r\n Value.vt := VT_BOOL;\r\n Value.bool := True;\r\n end;\r\n // kpidCommented: ;\r\n // kpidEncrypted: ;\r\n // kpidSplitBefore: ;\r\n // kpidSplitAfter: ;\r\n // kpidDictionarySize: ;\r\n // kpidCRC: ;\r\n // kpidType: ;\r\n kpidIsAnti:\r\n begin\r\n Value.vt := VT_BOOL;\r\n Value.bool := False;\r\n end;\r\n // kpidMethod: ;\r\n // kpidHostOS: ;\r\n // kpidFileSystem: ;\r\n kpidUser:\r\n begin\r\n Value.vt := VT_BSTR;\r\n Value.bstrVal := SysAllocString(PWideChar(AItem.User));\r\n end;\r\n kpidGroup:\r\n begin\r\n Value.vt := VT_BSTR;\r\n Value.bstrVal := SysAllocString(PWideChar(AItem.Group));\r\n end;\r\n // kpidBlock: ;\r\n // kpidComment: ;\r\n // kpidPosition: ;\r\n // kpidPrefix: ;\r\n // kpidNumSubDirs: ;\r\n // kpidNumSubFiles: ;\r\n // kpidUnpackVer: ;\r\n // kpidVolume: ;\r\n // kpidIsVolume: ;\r\n // kpidOffset: ;\r\n // kpidLinks: ;\r\n // kpidNumBlocks: ;\r\n // kpidNumVolumes: ;\r\n kpidTimeType:\r\n begin\r\n Value.vt := VT_UI4;\r\n Value.ulVal := kWindows;\r\n end;\r\n // kpidBit64: ;\r\n // kpidBigEndian: ;\r\n // kpidCpu: ;\r\n // kpidPhySize: ;\r\n // kpidHeadersSize: ;\r\n // kpidChecksum: ;\r\n // kpidCharacts: ;\r\n // kpidVa: ;\r\n // kpidId: ;\r\n // kpidShortName: ;\r\n // kpidCreatorApp: ;\r\n // kpidSectorSize: ;\r\n kpidPosixAttrib:\r\n begin\r\n Value.vt := VT_EMPTY;\r\n end;\r\n // kpidLink: ;\r\n // kpidTotalSize: ;\r\n // kpidFreeSpace: ;\r\n // kpidClusterSize: ;\r\n // kpidVolumeName: ;\r\n // kpidLocalName: ;\r\n // kpidProvider: ;\r\n // kpidUserDefined: ;\r\n else\r\n Value.vt := VT_EMPTY;\r\n Result := S_FALSE;\r\n end;\r\nend;\r\n\r\nfunction TJclSevenzipUpdateCallback.GetStream(Index: Cardinal;\r\n out InStream: ISequentialInStream): HRESULT;\r\nbegin\r\n FLastStream := Index;\r\n InStream := TJclSevenzipInStream.Create(FArchive, Index);\r\n Result := S_OK;\r\nend;\r\n\r\nfunction TJclSevenzipUpdateCallback.GetUpdateItemInfo(Index: Cardinal; NewData,\r\n NewProperties: PInteger; IndexInArchive: PCardinal): HRESULT;\r\nvar\r\n CompressionItem: TJclCompressionItem;\r\nbegin\r\n CompressionItem := FArchive.Items[Index];\r\n\r\n if Assigned(NewData) then\r\n begin\r\n if ([ipFileName, ipStream] * CompressionItem.ModifiedProperties) <> [] then\r\n NewData^ := 1\r\n else\r\n NewData^ := 0;\r\n end;\r\n\r\n if Assigned(NewProperties) then\r\n begin\r\n if (CompressionItem.ModifiedProperties - [ipFileName, ipStream]) <> [] then\r\n NewProperties^ := 1\r\n else\r\n NewProperties^ := 0;\r\n end;\r\n\r\n // TODO\r\n if Assigned(IndexInArchive) then\r\n IndexInArchive^ := CompressionItem.PackedIndex;\r\n Result := S_OK;\r\nend;\r\n\r\nfunction TJclSevenzipUpdateCallback.GetVolumeSize(Index: Cardinal;\r\n Size: PInt64): HRESULT;\r\nbegin\r\n // the JCL has its own spliting engine\r\n if Assigned(Size) then\r\n Size^ := 0;\r\n Result := S_FALSE;\r\nend;\r\n\r\nfunction TJclSevenzipUpdateCallback.GetVolumeStream(Index: Cardinal;\r\n out VolumeStream: ISequentialOutStream): HRESULT;\r\nbegin\r\n VolumeStream := nil;\r\n Result := S_FALSE;\r\nend;\r\n\r\nfunction TJclSevenzipUpdateCallback.SetCompleted(\r\n CompleteValue: PInt64): HRESULT;\r\nbegin\r\n Result := S_OK;\r\n if Assigned(CompleteValue) and not FArchive.DoProgress(CompleteValue^, FArchive.FProgressMax) then\r\n Result := E_ABORT;\r\nend;\r\n\r\nfunction TJclSevenzipUpdateCallback.SetOperationResult(\r\n OperationResult: Integer): HRESULT;\r\nbegin\r\n case OperationResult of\r\n kOK:\r\n FArchive.Items[FLastStream].OperationSuccess := osOK;\r\n kUnSupportedMethod:\r\n FArchive.Items[FLastStream].OperationSuccess := osUnsupportedMethod;\r\n kDataError:\r\n FArchive.Items[FLastStream].OperationSuccess := osDataError;\r\n kCRCError:\r\n FArchive.Items[FLastStream].OperationSuccess := osCRCError;\r\n else\r\n FArchive.Items[FLastStream].OperationSuccess := osUnknownError;\r\n end;\r\n\r\n Result := S_OK;\r\nend;\r\n\r\nfunction TJclSevenzipUpdateCallback.SetRatioInfo(InSize,\r\n OutSize: PInt64): HRESULT;\r\nvar\r\n AInSize, AOutSize: Int64;\r\nbegin\r\n if Assigned(InSize) then\r\n AInSize := InSize^\r\n else\r\n AInSize := -1;\r\n if Assigned(OutSize) then\r\n AOutSize := OutSize^\r\n else\r\n AOutSize := -1;\r\n if FArchive.DoRatio(AInSize, AOutSize) then\r\n Result := S_OK\r\n else\r\n Result := E_ABORT;\r\nend;\r\n\r\nfunction TJclSevenzipUpdateCallback.SetTotal(Total: Int64): HRESULT;\r\nbegin\r\n FArchive.FProgressMax := Total;\r\n if FArchive.CancelCurrentOperation then\r\n Result := E_ABORT\r\n else\r\n Result := S_OK;\r\nend;\r\n\r\n//=== { TJclSevenzipCompressArchive } ========================================\r\n\r\nclass function TJclSevenzipCompressArchive.ArchiveCLSID: TGUID;\r\nbegin\r\n Result := GUID_NULL;\r\nend;\r\n\r\nclass function TJclSevenzipCompressArchive.ArchiveSignature: TDynByteArray;\r\nbegin\r\n Result := Get7zArchiveSignature(ArchiveCLSID);\r\nend;\r\n\r\ndestructor TJclSevenzipCompressArchive.Destroy;\r\nbegin\r\n FOutArchive := nil;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJclSevenzipCompressArchive.GetItemClass: TJclCompressionItemClass;\r\nbegin\r\n Result := TJclCompressItem;\r\nend;\r\n\r\nfunction TJclSevenzipCompressArchive.GetOutArchive: IOutArchive;\r\nvar\r\n SevenzipCLSID, InterfaceID: TGUID;\r\nbegin\r\n if not Assigned(FOutArchive) then\r\n begin\r\n SevenzipCLSID := ArchiveCLSID;\r\n InterfaceID := Sevenzip.IOutArchive;\r\n if (not Is7ZipLoaded) and (not Load7Zip) then\r\n raise EJclCompressionError.CreateRes(@RsCompression7zLoadError);\r\n if (Sevenzip.CreateObject(@SevenzipCLSID, @InterfaceID, FOutArchive) <> ERROR_SUCCESS)\r\n or not Assigned(FOutArchive) then\r\n raise EJclCompressionError.CreateResFmt(@RsCompression7zOutArchiveError, [GUIDToString(SevenzipCLSID)]);\r\n end;\r\n Result := FOutArchive;\r\nend;\r\n\r\nprocedure TJclSevenzipCompressArchive.Compress;\r\nvar\r\n OutStream: IOutStream;\r\n UpdateCallback: IArchiveUpdateCallback;\r\n SplitStream: TJclDynamicSplitStream;\r\nbegin\r\n CheckNotCompressing;\r\n\r\n FCompressing := True;\r\n try\r\n SplitStream := TJclDynamicSplitStream.Create(False);\r\n SplitStream.OnVolume := NeedStream;\r\n SplitStream.OnVolumeMaxSize := NeedStreamMaxSize;\r\n OutStream := TJclSevenzipOutStream.Create(SplitStream, True, False);\r\n UpdateCallback := TJclSevenzipUpdateCallback.Create(Self);\r\n\r\n SetSevenzipArchiveCompressionProperties(Self, OutArchive);\r\n\r\n SevenzipCheck(OutArchive.UpdateItems(OutStream, ItemCount, UpdateCallback));\r\n finally\r\n FCompressing := False;\r\n // release volumes and other finalizations\r\n inherited Compress;\r\n end;\r\nend;\r\n\r\n//=== { TJcl7zCompressArchive } ==============================================\r\n\r\nclass function TJcl7zCompressArchive.ArchiveExtensions: string;\r\nbegin\r\n Result := LoadResString(@RsCompression7zExtensions);\r\nend;\r\n\r\nclass function TJcl7zCompressArchive.ArchiveName: string;\r\nbegin\r\n Result := LoadResString(@RsCompression7zName);\r\nend;\r\n\r\nclass function TJcl7zCompressArchive.ArchiveCLSID: TGUID;\r\nbegin\r\n Result := CLSID_CFormat7z;\r\nend;\r\n\r\nfunction TJcl7zCompressArchive.GetCompressHeader: Boolean;\r\nbegin\r\n Result := FCompressHeader;\r\nend;\r\n\r\nfunction TJcl7zCompressArchive.GetCompressHeaderFull: Boolean;\r\nbegin\r\n Result := FCompressHeaderFull;\r\nend;\r\n\r\nfunction TJcl7zCompressArchive.GetCompressionLevel: Cardinal;\r\nbegin\r\n Result := FCompressionLevel;\r\nend;\r\n\r\nfunction TJcl7zCompressArchive.GetCompressionLevelMax: Cardinal;\r\nbegin\r\n Result := 9;\r\nend;\r\n\r\nfunction TJcl7zCompressArchive.GetCompressionLevelMin: Cardinal;\r\nbegin\r\n Result := 0;\r\nend;\r\n\r\nfunction TJcl7zCompressArchive.GetDictionarySize: Cardinal;\r\nbegin\r\n Result := FDictionarySize;\r\nend;\r\n\r\nfunction TJcl7zCompressArchive.GetEncryptHeader: Boolean;\r\nbegin\r\n Result := FEncryptHeader;\r\nend;\r\n\r\nfunction TJcl7zCompressArchive.GetNumberOfThreads: Cardinal;\r\nbegin\r\n Result := FNumberOfThreads;\r\nend;\r\n\r\nfunction TJcl7zCompressArchive.GetRemoveSfxBlock: Boolean;\r\nbegin\r\n Result := FRemoveSfxBlock;\r\nend;\r\n\r\nfunction TJcl7zCompressArchive.GetSaveCreationDateTime: Boolean;\r\nbegin\r\n Result := FSaveCreationDateTime;\r\nend;\r\n\r\nfunction TJcl7zCompressArchive.GetSaveLastAccessDateTime: Boolean;\r\nbegin\r\n Result := FSaveLastAccessDateTime;\r\nend;\r\n\r\nfunction TJcl7zCompressArchive.GetSaveLastWriteDateTime: Boolean;\r\nbegin\r\n Result := FSaveLastWriteDateTime;\r\nend;\r\n\r\nfunction TJcl7zCompressArchive.GetSolidBlockSize: Int64;\r\nbegin\r\n Result := FSolidBlockSize;\r\nend;\r\n\r\nfunction TJcl7zCompressArchive.GetSolidExtension: Boolean;\r\nbegin\r\n Result := FSolidExtension;\r\nend;\r\n\r\nprocedure TJcl7zCompressArchive.InitializeArchiveProperties;\r\nbegin\r\n inherited InitializeArchiveProperties;\r\n FNumberOfThreads := 1;\r\n FEncryptHeader := False;\r\n FRemoveSfxBlock := False;\r\n FDictionarySize := kLzmaDicSizeX5;\r\n FCompressionLevel := 6;\r\n FCompressHeader := False;\r\n FCompressHeaderFull := False;\r\n FSaveLastAccessDateTime := True;\r\n FSaveCreationDateTime := True;\r\n FSaveLastWriteDateTime := True;\r\n FSolidBlockSize := High(Cardinal);\r\n FSolidExtension := False;\r\nend;\r\n\r\nclass function TJcl7zCompressArchive.MultipleItemContainer: Boolean;\r\nbegin\r\n Result := True;\r\nend;\r\n\r\nprocedure TJcl7zCompressArchive.SetCompressHeader(Value: Boolean);\r\nbegin\r\n CheckNotCompressing;\r\n FCompressHeader := Value;\r\nend;\r\n\r\nprocedure TJcl7zCompressArchive.SetCompressHeaderFull(Value: Boolean);\r\nbegin\r\n CheckNotCompressing;\r\n FCompressHeaderFull := Value;\r\nend;\r\n\r\nprocedure TJcl7zCompressArchive.SetCompressionLevel(Value: Cardinal);\r\nbegin\r\n CheckNotCompressing;\r\n if Value <= 9 then\r\n begin\r\n FCompressionLevel := Value;\r\n if Value >= 9 then\r\n FDictionarySize := kLzmaDicSizeX9\r\n else\r\n if Value >= 7 then\r\n FDictionarySize := kLzmaDicSizeX7\r\n else\r\n if Value >= 5 then\r\n FDictionarySize := kLzmaDicSizeX5\r\n else\r\n if Value >= 3 then\r\n FDictionarySize := kLzmaDicSizeX3\r\n else\r\n FDictionarySize := kLzmaDicSizeX1;\r\n end\r\n else\r\n raise EJclCompressionError.CreateRes(@RsCompressionUnavailableProperty);\r\nend;\r\n\r\nprocedure TJcl7zCompressArchive.SetDictionarySize(Value: Cardinal);\r\nbegin\r\n CheckNotCompressing;\r\n FDictionarySize := Value;\r\nend;\r\n\r\nprocedure TJcl7zCompressArchive.SetEncryptHeader(Value: Boolean);\r\nbegin\r\n CheckNotCompressing;\r\n FEncryptHeader := Value;\r\nend;\r\n\r\nprocedure TJcl7zCompressArchive.SetNumberOfThreads(Value: Cardinal);\r\nbegin\r\n CheckNotCompressing;\r\n FNumberOfThreads := Value;\r\nend;\r\n\r\nprocedure TJcl7zCompressArchive.SetRemoveSfxBlock(Value: Boolean);\r\nbegin\r\n CheckNotCompressing;\r\n FRemoveSfxBlock := Value;\r\nend;\r\n\r\nprocedure TJcl7zCompressArchive.SetSaveCreationDateTime(Value: Boolean);\r\nbegin\r\n CheckNotCompressing;\r\n FSaveCreationDateTime := Value;\r\nend;\r\n\r\nprocedure TJcl7zCompressArchive.SetSaveLastAccessDateTime(Value: Boolean);\r\nbegin\r\n CheckNotCompressing;\r\n FSaveLastAccessDateTime := Value;\r\nend;\r\n\r\nprocedure TJcl7zCompressArchive.SetSaveLastWriteDateTime(Value: Boolean);\r\nbegin\r\n CheckNotCompressing;\r\n FSaveLastWriteDateTime := Value;\r\nend;\r\n\r\nprocedure TJcl7zCompressArchive.SetSolidBlockSize(const Value: Int64);\r\nbegin\r\n CheckNotCompressing;\r\n FSolidBlockSize := Value;\r\nend;\r\n\r\nprocedure TJcl7zCompressArchive.SetSolidExtension(Value: Boolean);\r\nbegin\r\n CheckNotCompressing;\r\n FSolidExtension := Value;\r\nend;\r\n\r\n//=== { TJclZipCompressArchive } =============================================\r\n\r\nclass function TJclZipCompressArchive.ArchiveExtensions: string;\r\nbegin\r\n Result := LoadResString(@RsCompressionZipExtensions);\r\nend;\r\n\r\nclass function TJclZipCompressArchive.ArchiveName: string;\r\nbegin\r\n Result := LoadResString(@RsCompressionZipName);\r\nend;\r\n\r\nclass function TJclZipCompressArchive.ArchiveCLSID: TGUID;\r\nbegin\r\n Result := CLSID_CFormatZip;\r\nend;\r\n\r\nfunction TJclZipCompressArchive.GetAlgorithm: Cardinal;\r\nbegin\r\n Result := FAlgorithm;\r\nend;\r\n\r\nfunction TJclZipCompressArchive.GetCompressionLevel: Cardinal;\r\nbegin\r\n Result := FCompressionLevel;\r\nend;\r\n\r\nfunction TJclZipCompressArchive.GetCompressionLevelMax: Cardinal;\r\nbegin\r\n Result := 9;\r\nend;\r\n\r\nfunction TJclZipCompressArchive.GetCompressionLevelMin: Cardinal;\r\nbegin\r\n Result := 0;\r\nend;\r\n\r\nfunction TJclZipCompressArchive.GetCompressionMethod: TJclCompressionMethod;\r\nbegin\r\n Result := FCompressionMethod;\r\nend;\r\n\r\nfunction TJclZipCompressArchive.GetDictionarySize: Cardinal;\r\nbegin\r\n Result := FDictionarySize;\r\nend;\r\n\r\nfunction TJclZipCompressArchive.GetEncryptionMethod: TJclEncryptionMethod;\r\nbegin\r\n Result := FEncryptionMethod;\r\nend;\r\n\r\nfunction TJclZipCompressArchive.GetNumberOfPasses: Cardinal;\r\nbegin\r\n Result := FNumberOfPasses;\r\nend;\r\n\r\nfunction TJclZipCompressArchive.GetNumberOfThreads: Cardinal;\r\nbegin\r\n Result := FNumberOfThreads;\r\nend;\r\n\r\nfunction TJclZipCompressArchive.GetSupportedAlgorithms: TDynCardinalArray;\r\nbegin\r\n SetLength(Result, 2);\r\n Result[0] := 0;\r\n Result[1] := 1;\r\nend;\r\n\r\nfunction TJclZipCompressArchive.GetSupportedCompressionMethods: TJclCompressionMethods;\r\nbegin\r\n Result := [cmCopy,cmDeflate,cmDeflate64,cmBZip2,cmLZMA,cmPPMd];\r\nend;\r\n\r\nfunction TJclZipCompressArchive.GetSupportedEncryptionMethods: TJclEncryptionMethods;\r\nbegin\r\n Result := [emNone,emAES128,emAES192,emAES256,emZipCrypto];\r\nend;\r\n\r\nprocedure TJclZipCompressArchive.InitializeArchiveProperties;\r\nbegin\r\n inherited InitializeArchiveProperties;\r\n FNumberOfThreads := 1;\r\n FEncryptionMethod := emZipCrypto;\r\n FDictionarySize := kBZip2DicSizeX5;\r\n FCompressionLevel := 7;\r\n FCompressionMethod := cmDeflate;\r\n FNumberOfPasses := kDeflateNumPassesX7;\r\n FAlgorithm := kLzAlgoX5;\r\nend;\r\n\r\nclass function TJclZipCompressArchive.MultipleItemContainer: Boolean;\r\nbegin\r\n Result := True;\r\nend;\r\n\r\nprocedure TJclZipCompressArchive.SetAlgorithm(Value: Cardinal);\r\nbegin\r\n CheckNotCompressing;\r\n if (Value = 0) or (Value = 1) then\r\n FAlgorithm := Value\r\n else\r\n raise EJclCompressionError.CreateRes(@RsCompressionUnavailableProperty);\r\nend;\r\n\r\nprocedure TJclZipCompressArchive.SetCompressionLevel(Value: Cardinal);\r\nbegin\r\n CheckNotCompressing;\r\n if Value <= 9 then\r\n begin\r\n FCompressionLevel := Value;\r\n case FCompressionMethod of\r\n cmDeflate, cmDeflate64:\r\n begin\r\n if Value >= 9 then\r\n FNumberOfPasses := kDeflateNumPassesX9\r\n else\r\n if Value >= 7 then\r\n FNumberOfPasses := kDeflateNumPassesX7\r\n else\r\n FNumberOfPasses := kDeflateNumPassesX1;\r\n if Value >= 5 then\r\n FAlgorithm := kLzAlgoX5\r\n else\r\n FAlgorithm := kLzAlgoX1;\r\n end;\r\n cmBZip2:\r\n begin\r\n if Value >= 9 then\r\n FNumberOfPasses := kBZip2NumPassesX9\r\n else\r\n if Value >= 7 then\r\n FNumberOfPasses := kBZip2NumPassesX7\r\n else\r\n FNumberOfPasses := kBZip2NumPassesX1;\r\n if Value >= 5 then\r\n FDictionarySize := kBZip2DicSizeX5\r\n else\r\n if Value >= 3 then\r\n FDictionarySize := kBZip2DicSizeX3\r\n else\r\n FDictionarySize := kBZip2DicSizeX1;\r\n end;\r\n cmLZMA:\r\n begin\r\n if Value >= 9 then\r\n FDictionarySize := kLzmaDicSizeX9\r\n else\r\n if Value >= 7 then\r\n FDictionarySize := kLzmaDicSizeX7\r\n else\r\n if Value >= 5 then\r\n FDictionarySize := kLzmaDicSizeX5\r\n else\r\n if Value >= 3 then\r\n FDictionarySize := kLzmaDicSizeX3\r\n else\r\n FDictionarySize := kLzmaDicSizeX1;\r\n if Value >= 5 then\r\n FAlgorithm := kLzAlgoX5\r\n else\r\n FAlgorithm := kLzAlgoX1;\r\n end;\r\n end;\r\n end\r\n else\r\n raise EJclCompressionError.CreateRes(@RsCompressionUnavailableProperty);\r\nend;\r\n\r\nprocedure TJclZipCompressArchive.SetCompressionMethod(Value: TJclCompressionMethod);\r\nbegin\r\n CheckNotCompressing;\r\n if Value in GetSupportedCompressionMethods then\r\n FCompressionMethod := Value\r\n else\r\n raise EJclCompressionError.CreateRes(@RsCompressionUnavailableProperty);\r\nend;\r\n\r\nprocedure TJclZipCompressArchive.SetDictionarySize(Value: Cardinal);\r\nbegin\r\n CheckNotCompressing;\r\n FDictionarySize := Value;\r\nend;\r\n\r\nprocedure TJclZipCompressArchive.SetEncryptionMethod(Value: TJclEncryptionMethod);\r\nbegin\r\n CheckNotCompressing;\r\n if Value in GetSupportedEncryptionMethods then\r\n FEncryptionMethod := Value\r\n else\r\n raise EJclCompressionError.CreateRes(@RsCompressionUnavailableProperty);\r\nend;\r\n\r\nprocedure TJclZipCompressArchive.SetNumberOfPasses(Value: Cardinal);\r\nbegin\r\n CheckNotCompressing;\r\n FNumberOfPasses := Value;\r\nend;\r\n\r\nprocedure TJclZipCompressArchive.SetNumberOfThreads(Value: Cardinal);\r\nbegin\r\n CheckNotCompressing;\r\n FNumberOfThreads := Value;\r\nend;\r\n\r\n//=== { TJclBZ2CompressArchive } =============================================\r\n\r\nclass function TJclBZ2CompressArchive.ArchiveExtensions: string;\r\nbegin\r\n Result := LoadResString(@RsCompressionBZip2Extensions);\r\nend;\r\n\r\nclass function TJclBZ2CompressArchive.ArchiveName: string;\r\nbegin\r\n Result := LoadResString(@RsCompressionBZip2Name);\r\nend;\r\n\r\nclass function TJclBZ2CompressArchive.ArchiveSubExtensions: string;\r\nbegin\r\n Result := LoadResString(@RsCompressionBZip2SubExtensions);\r\nend;\r\n\r\nclass function TJclBZ2CompressArchive.ArchiveCLSID: TGUID;\r\nbegin\r\n Result := CLSID_CFormatBZ2;\r\nend;\r\n\r\nfunction TJclBZ2CompressArchive.GetCompressionLevel: Cardinal;\r\nbegin\r\n Result := FCompressionLevel;\r\nend;\r\n\r\nfunction TJclBZ2CompressArchive.GetCompressionLevelMax: Cardinal;\r\nbegin\r\n Result := 9;\r\nend;\r\n\r\nfunction TJclBZ2CompressArchive.GetCompressionLevelMin: Cardinal;\r\nbegin\r\n Result := 0;\r\nend;\r\n\r\nfunction TJclBZ2CompressArchive.GetDictionarySize: Cardinal;\r\nbegin\r\n Result := FDictionarySize;\r\nend;\r\n\r\nfunction TJclBZ2CompressArchive.GetNumberOfPasses: Cardinal;\r\nbegin\r\n Result := FNumberOfPasses;\r\nend;\r\n\r\nfunction TJclBZ2CompressArchive.GetNumberOfThreads: Cardinal;\r\nbegin\r\n Result := FNumberOfThreads;\r\nend;\r\n\r\nprocedure TJclBZ2CompressArchive.InitializeArchiveProperties;\r\nbegin\r\n inherited InitializeArchiveProperties;\r\n FNumberOfThreads := 1;\r\n FDictionarySize := kBZip2DicSizeX5;\r\n FCompressionLevel := 7;\r\n FNumberOfPasses := kBZip2NumPassesX7;\r\nend;\r\n\r\nprocedure TJclBZ2CompressArchive.SetCompressionLevel(Value: Cardinal);\r\nbegin\r\n CheckNotCompressing;\r\n if Value <= 9 then\r\n begin\r\n FCompressionLevel := Value;\r\n if Value >= 9 then\r\n FNumberOfPasses := kBZip2NumPassesX9\r\n else\r\n if Value >= 7 then\r\n FNumberOfPasses := kBZip2NumPassesX7\r\n else\r\n FNumberOfPasses := kBZip2NumPassesX1;\r\n if Value >= 5 then\r\n FDictionarySize := kBZip2DicSizeX5\r\n else\r\n if Value >= 3 then\r\n FDictionarySize := kBZip2DicSizeX3\r\n else\r\n FDictionarySize := kBZip2DicSizeX1;\r\n end\r\n else\r\n raise EJclCompressionError.CreateRes(@RsCompressionUnavailableProperty);\r\nend;\r\n\r\nprocedure TJclBZ2CompressArchive.SetDictionarySize(Value: Cardinal);\r\nbegin\r\n CheckNotCompressing;\r\n FDictionarySize := Value;\r\nend;\r\n\r\nprocedure TJclBZ2CompressArchive.SetNumberOfPasses(Value: Cardinal);\r\nbegin\r\n CheckNotCompressing;\r\n FNumberOfPasses := Value;\r\nend;\r\n\r\nprocedure TJclBZ2CompressArchive.SetNumberOfThreads(Value: Cardinal);\r\nbegin\r\n CheckNotCompressing;\r\n FNumberOfThreads := Value;\r\nend;\r\n\r\n//=== { TJclTarCompressArchive } =============================================\r\n\r\nclass function TJclTarCompressArchive.ArchiveExtensions: string;\r\nbegin\r\n Result := LoadResString(@RsCompressionTarExtensions);\r\nend;\r\n\r\nclass function TJclTarCompressArchive.ArchiveName: string;\r\nbegin\r\n Result := LoadResString(@RsCompressionTarName);\r\nend;\r\n\r\nclass function TJclTarCompressArchive.ArchiveCLSID: TGUID;\r\nbegin\r\n Result := CLSID_CFormatTar;\r\nend;\r\n\r\nclass function TJclTarCompressArchive.MultipleItemContainer: Boolean;\r\nbegin\r\n Result := True;\r\nend;\r\n\r\n//=== { TJclGZipCompressArchive } ============================================\r\n\r\nclass function TJclGZipCompressArchive.ArchiveExtensions: string;\r\nbegin\r\n Result := LoadResString(@RsCompressionGZipExtensions);\r\nend;\r\n\r\nclass function TJclGZipCompressArchive.ArchiveName: string;\r\nbegin\r\n Result := LoadResString(@RsCompressionGZipName);\r\nend;\r\n\r\nclass function TJclGZipCompressArchive.ArchiveSubExtensions: string;\r\nbegin\r\n Result := LoadResString(@RsCompressionGZipSubExtensions);\r\nend;\r\n\r\nclass function TJclGZipCompressArchive.ArchiveCLSID: TGUID;\r\nbegin\r\n Result := CLSID_CFormatGZip;\r\nend;\r\n\r\nfunction TJclGZipCompressArchive.GetAlgorithm: Cardinal;\r\nbegin\r\n Result := FAlgorithm;\r\nend;\r\n\r\nfunction TJclGZipCompressArchive.GetCompressionLevel: Cardinal;\r\nbegin\r\n Result := FCompressionLevel;\r\nend;\r\n\r\nfunction TJclGZipCompressArchive.GetCompressionLevelMax: Cardinal;\r\nbegin\r\n Result := 9;\r\nend;\r\n\r\nfunction TJclGZipCompressArchive.GetCompressionLevelMin: Cardinal;\r\nbegin\r\n Result := 0;\r\nend;\r\n\r\nfunction TJclGZipCompressArchive.GetNumberOfPasses: Cardinal;\r\nbegin\r\n Result := FNumberOfPasses;\r\nend;\r\n\r\nfunction TJclGZipCompressArchive.GetSupportedAlgorithms: TDynCardinalArray;\r\nbegin\r\n SetLength(Result,2);\r\n Result[0] := 0;\r\n Result[1] := 1;\r\nend;\r\n\r\nprocedure TJclGZipCompressArchive.InitializeArchiveProperties;\r\nbegin\r\n inherited InitializeArchiveProperties;\r\n FCompressionLevel := 7;\r\n FNumberOfPasses := kDeflateNumPassesX7;\r\n FAlgorithm := kLzAlgoX5;\r\nend;\r\n\r\nprocedure TJclGZipCompressArchive.SetAlgorithm(Value: Cardinal);\r\nbegin\r\n CheckNotCompressing;\r\n FAlgorithm := Value;\r\nend;\r\n\r\nprocedure TJclGZipCompressArchive.SetCompressionLevel(Value: Cardinal);\r\nbegin\r\n CheckNotCompressing;\r\n if Value <= 9 then\r\n begin\r\n if Value >= 9 then\r\n FNumberOfPasses := kDeflateNumPassesX9\r\n else\r\n if Value >= 7 then\r\n FNumberOfPasses := kDeflateNumPassesX7\r\n else\r\n FNumberOfPasses := kDeflateNumPassesX1;\r\n if Value >= 5 then\r\n FAlgorithm := kLzAlgoX5\r\n else\r\n FAlgorithm := kLzAlgoX1;\r\n end\r\n else\r\n raise EJclCompressionError.CreateRes(@RsCompressionUnavailableProperty);\r\nend;\r\n\r\nprocedure TJclGZipCompressArchive.SetNumberOfPasses(Value: Cardinal);\r\nbegin\r\n CheckNotCompressing;\r\n FNumberOfPasses := Value;\r\nend;\r\n\r\n//=== { TJclXzCompressArchive } ==============================================\r\n\r\nclass function TJclXzCompressArchive.ArchiveExtensions: string;\r\nbegin\r\n Result := LoadResString(@RsCompressionXzExtensions);\r\nend;\r\n\r\nclass function TJclXzCompressArchive.ArchiveName: string;\r\nbegin\r\n Result := LoadResString(@RsCompressionXzName);\r\nend;\r\n\r\nclass function TJclXzCompressArchive.ArchiveSubExtensions: string;\r\nbegin\r\n Result := LoadResString(@RsCompressionXzSubExtensions);\r\nend;\r\n\r\nclass function TJclXzCompressArchive.ArchiveCLSID: TGUID;\r\nbegin\r\n Result := CLSID_CFormatXz;\r\nend;\r\n\r\nfunction TJclXzCompressArchive.GetCompressionMethod: TJclCompressionMethod;\r\nbegin\r\n Result := FCompressionMethod;\r\nend;\r\n\r\nfunction TJclXzCompressArchive.GetSupportedCompressionMethods: TJclCompressionMethods;\r\nbegin\r\n Result := [cmLZMA2];\r\nend;\r\n\r\nprocedure TJclXzCompressArchive.InitializeArchiveProperties;\r\nbegin\r\n inherited InitializeArchiveProperties;\r\n FCompressionMethod := cmLZMA2;\r\nend;\r\n\r\nprocedure TJclXzCompressArchive.SetCompressionMethod(\r\n Value: TJclCompressionMethod);\r\nbegin\r\n CheckNotCompressing;\r\n FCompressionMethod := Value;\r\nend;\r\n\r\n//=== { TJclSwfcCompressArchive } ============================================\r\n\r\nclass function TJclSwfcCompressArchive.ArchiveExtensions: string;\r\nbegin\r\n Result := LoadResString(@RsCompressionSwfcExtensions);\r\nend;\r\n\r\nclass function TJclSwfcCompressArchive.ArchiveName: string;\r\nbegin\r\n Result := LoadResString(@RsCompressionSwfcName);\r\nend;\r\n\r\nclass function TJclSwfcCompressArchive.ArchiveCLSID: TGUID;\r\nbegin\r\n Result := CLSID_CFormatSwfc;\r\nend;\r\n\r\n//=== { TJclWimCompressArchive } =============================================\r\n\r\nclass function TJclWimCompressArchive.ArchiveCLSID: TGUID;\r\nbegin\r\n Result := CLSID_CFormatWim;\r\nend;\r\n\r\nclass function TJclWimCompressArchive.ArchiveExtensions: string;\r\nbegin\r\n Result := LoadResString(@RsCompressionWimExtensions);\r\nend;\r\n\r\nclass function TJclWimCompressArchive.ArchiveName: string;\r\nbegin\r\n Result := LoadResString(@RsCompressionWimName);\r\nend;\r\n\r\n//=== { TJclSevenzipOpenCallback } ===========================================\r\n\r\nconstructor TJclSevenzipOpenCallback.Create(\r\n AArchive: TJclCompressionArchive);\r\nbegin\r\n inherited Create;\r\n FArchive := AArchive;\r\nend;\r\n\r\nfunction TJclSevenzipOpenCallback.CryptoGetTextPassword(\r\n password: PBStr): HRESULT;\r\nbegin\r\n if Assigned(password) then\r\n password^ := SysAllocString(PWideChar(FArchive.Password));\r\n Result := S_OK;\r\nend;\r\n\r\nfunction TJclSevenzipOpenCallback.SetCompleted(Files, Bytes: PInt64): HRESULT;\r\nbegin\r\n Result := S_OK;\r\n if Assigned(Files) and not FArchive.DoProgress(Files^, FArchive.FProgressMax) then\r\n Result := E_ABORT;\r\nend;\r\n\r\nfunction TJclSevenzipOpenCallback.SetTotal(Files, Bytes: PInt64): HRESULT;\r\nbegin\r\n if Assigned(Files) then\r\n FArchive.FProgressMax := Files^;\r\n if FArchive.CancelCurrentOperation then\r\n Result := E_ABORT\r\n else\r\n Result := S_OK;\r\nend;\r\n\r\n//=== { TJclSevenzipExtractCallback } ========================================\r\n\r\nconstructor TJclSevenzipExtractCallback.Create(\r\n AArchive: TJclCompressionArchive);\r\nbegin\r\n inherited Create;\r\n FArchive := AArchive;\r\nend;\r\n\r\nfunction TJclSevenzipExtractCallback.CryptoGetTextPassword(\r\n password: PBStr): HRESULT;\r\nbegin\r\n if Assigned(password) then\r\n password^ := SysAllocString(PWideChar(FArchive.Password));\r\n Result := S_OK;\r\nend;\r\n\r\nfunction TJclSevenzipExtractCallback.GetStream(Index: Cardinal;\r\n out OutStream: ISequentialOutStream; askExtractMode: Cardinal): HRESULT;\r\nbegin\r\n FLastStream := Index;\r\n\r\n Assert(askExtractMode in [kExtract, kTest, kSkip]);\r\n\r\n if askExtractMode in [kTest, kSkip] then\r\n begin\r\n OutStream := nil;\r\n Result := S_OK;\r\n end\r\n else\r\n if FArchive.Items[Index].ValidateExtraction(Index) then\r\n begin\r\n OutStream := TJclSevenzipOutStream.Create(FArchive, Index);\r\n Result := S_OK;\r\n end\r\n else\r\n begin\r\n OutStream := nil;\r\n Result := S_FALSE;\r\n end;\r\nend;\r\n\r\nfunction TJclSevenzipExtractCallback.PrepareOperation(\r\n askExtractMode: Cardinal): HRESULT;\r\nbegin\r\n Result := S_OK;\r\nend;\r\n\r\nfunction TJclSevenzipExtractCallback.SetCompleted(\r\n CompleteValue: PInt64): HRESULT;\r\nbegin\r\n Result := S_OK;\r\n if Assigned(CompleteValue) and not FArchive.DoProgress(CompleteValue^, FArchive.FProgressMax) then\r\n Result := E_ABORT;\r\nend;\r\n\r\nfunction TJclSevenzipExtractCallback.SetOperationResult(\r\n resultEOperationResult: Integer): HRESULT;\r\nvar\r\n LastItem: TJclCompressionItem;\r\nbegin\r\n LastItem := FArchive.Items[FLastStream];\r\n case resultEOperationResult of\r\n kOK:\r\n begin\r\n LastItem.OperationSuccess := osOK;\r\n LastItem.UpdateFileTimes;\r\n end;\r\n kUnSupportedMethod:\r\n begin\r\n LastItem.OperationSuccess := osUnsupportedMethod;\r\n LastItem.DeleteOutputFile;\r\n end;\r\n kDataError:\r\n begin\r\n LastItem.OperationSuccess := osDataError;\r\n LastItem.DeleteOutputFile;\r\n end;\r\n kCRCError:\r\n begin\r\n LastItem.OperationSuccess := osCRCError;\r\n LastItem.DeleteOutputFile;\r\n end\r\n else\r\n LastItem.OperationSuccess := osUnknownError;\r\n LastItem.DeleteOutputFile;\r\n end;\r\n\r\n Result := S_OK;\r\nend;\r\n\r\nfunction TJclSevenzipExtractCallback.SetRatioInfo(InSize,\r\n OutSize: PInt64): HRESULT;\r\nvar\r\n AInSize, AOutSize: Int64;\r\nbegin\r\n if Assigned(InSize) then\r\n AInSize := InSize^\r\n else\r\n AInSize := -1;\r\n if Assigned(OutSize) then\r\n AOutSize := OutSize^\r\n else\r\n AOutSize := -1;\r\n if FArchive.DoRatio(AInSize, AOutSize) then\r\n Result := S_OK\r\n else\r\n Result := E_ABORT;\r\nend;\r\n\r\nfunction TJclSevenzipExtractCallback.SetTotal(Total: Int64): HRESULT;\r\nbegin\r\n FArchive.FProgressMax := Total;\r\n if FArchive.CancelCurrentOperation then\r\n Result := E_ABORT\r\n else\r\n Result := S_OK;\r\nend;\r\n\r\n//=== { TJclSevenzipDecompressItem } =========================================\r\n\r\nfunction TJclSevenzipDecompressItem.GetNestedArchiveStream: TStream;\r\nvar\r\n SequentialInStream: ISequentialInStream;\r\n InStream: IInStream;\r\n InterfaceID: TGUID;\r\nbegin\r\n if Archive.SupportsNestedArchive and (Archive is TJclSevenzipDecompressArchive) then\r\n begin\r\n SevenzipCheck(TJclSevenzipDecompressArchive(Archive).InArchiveGetStream.GetStream(PackedIndex, SequentialInStream));\r\n InterfaceID := IInStream;\r\n SevenzipCheck(SequentialInStream.QueryInterface(InterfaceID, InStream));\r\n Result := TJclSevenzipNestedInStream.Create(InStream);\r\n end\r\n else\r\n Result := inherited GetNestedArchiveStream;\r\nend;\r\n\r\n//=== { TJclSevenzipDecompressArchive } ======================================\r\n\r\nclass function TJclSevenzipDecompressArchive.ArchiveCLSID: TGUID;\r\nbegin\r\n Result := GUID_NULL;\r\nend;\r\n\r\nclass function TJclSevenzipDecompressArchive.ArchiveSignature: TDynByteArray;\r\nbegin\r\n Result := Get7zArchiveSignature(ArchiveCLSID);\r\nend;\r\n\r\ndestructor TJclSevenzipDecompressArchive.Destroy;\r\nbegin\r\n FInArchive := nil;\r\n FInArchiveGetStream := nil;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJclSevenzipDecompressArchive.ExtractAll(const ADestinationDir: string;\r\n AAutoCreateSubDir: Boolean);\r\nvar\r\n AExtractCallback: IArchiveExtractCallback;\r\n Indices: array of Cardinal;\r\n NbIndices: Cardinal;\r\n Index: Integer;\r\nbegin\r\n CheckNotDecompressing;\r\n\r\n FDestinationDir := ADestinationDir;\r\n FAutoCreateSubDir := AAutoCreateSubDir;\r\n\r\n if FDestinationDir <> '' then\r\n FDestinationDir := PathAddSeparator(FDestinationDir);\r\n\r\n FDecompressing := True;\r\n FExtractingAllIndex := 0;\r\n AExtractCallback := TJclSevenzipExtractCallback.Create(Self);\r\n try\r\n OpenArchive;\r\n\r\n // seems buggy: first param \"indices\" is dereferenced without\r\n // liveness checks inside Sevenzip code\r\n //SevenzipCheck(InArchive.Extract(nil, $FFFFFFFF, 0, AExtractCallback));\r\n\r\n NbIndices := ItemCount;\r\n SetLength(Indices, NbIndices);\r\n for Index := 0 to NbIndices - 1 do\r\n begin\r\n Items[Index].Selected := True;\r\n Indices[Index] := Index;\r\n end;\r\n SevenzipCheck(InArchive.Extract(@Indices[0], NbIndices, 0, AExtractCallback));\r\n\r\n CheckOperationSuccess;\r\n finally\r\n FDestinationDir := '';\r\n FDecompressing := False;\r\n FExtractingAllIndex := -1;\r\n FCurrentItemIndex := -1;\r\n AExtractCallback := nil;\r\n // release volumes and other finalizations\r\n inherited ExtractAll(ADestinationDir, AAutoCreateSubDir);\r\n end;\r\nend;\r\n\r\nprocedure TJclSevenzipDecompressArchive.ExtractSelected(const ADestinationDir: string;\r\n AAutoCreateSubDir: Boolean);\r\nvar\r\n AExtractCallback: IArchiveExtractCallback;\r\n Indices: array of Cardinal;\r\n NbIndices: Cardinal;\r\n Index: Integer;\r\nbegin\r\n CheckNotDecompressing;\r\n\r\n FDestinationDir := ADestinationDir;\r\n FAutoCreateSubDir := AAutoCreateSubDir;\r\n\r\n if FDestinationDir <> '' then\r\n FDestinationDir := PathAddSeparator(FDestinationDir);\r\n\r\n FDecompressing := True;\r\n AExtractCallback := TJclSevenzipExtractCallback.Create(Self);\r\n try\r\n OpenArchive;\r\n\r\n NbIndices := 0;\r\n for Index := 0 to ItemCount - 1 do\r\n if Items[Index].Selected then\r\n Inc(NbIndices);\r\n\r\n SetLength(Indices, NbIndices);\r\n NbIndices := 0;\r\n for Index := 0 to ItemCount - 1 do\r\n if Items[Index].Selected then\r\n begin\r\n Indices[NbIndices] := Index;\r\n Inc(NbIndices);\r\n end;\r\n\r\n SevenzipCheck(InArchive.Extract(@Indices[0], Length(Indices), 0, AExtractCallback));\r\n CheckOperationSuccess;\r\n finally\r\n FDestinationDir := '';\r\n FDecompressing := False;\r\n AExtractCallback := nil;\r\n FCurrentItemIndex := -1;\r\n // release volumes and other finalizations\r\n inherited ExtractSelected(ADestinationDir, AAutoCreateSubDir);\r\n end;\r\nend;\r\n\r\nfunction TJclSevenzipDecompressArchive.GetInArchive: IInArchive;\r\nvar\r\n SevenzipCLSID, InterfaceID: TGUID;\r\nbegin\r\n if not Assigned(FInArchive) then\r\n begin\r\n SevenzipCLSID := ArchiveCLSID;\r\n InterfaceID := Sevenzip.IInArchive;\r\n if (not Is7ZipLoaded) and (not Load7Zip) then\r\n raise EJclCompressionError.CreateRes(@RsCompression7zLoadError);\r\n if (Sevenzip.CreateObject(@SevenzipCLSID, @InterfaceID, FInArchive) <> ERROR_SUCCESS)\r\n or not Assigned(FInArchive) then\r\n raise EJclCompressionError.CreateResFmt(@RsCompression7zInArchiveError, [GUIDToString(SevenzipCLSID)]);\r\n FExtractingAllIndex := -1;\r\n end;\r\n Result := FInArchive;\r\nend;\r\n\r\nfunction TJclSevenzipDecompressArchive.GetInArchiveGetStream: IInArchiveGetStream;\r\nvar\r\n InterfaceID: TGUID;\r\nbegin\r\n if not Assigned(FInArchiveGetStream) then\r\n begin\r\n InterfaceID := Sevenzip.IInArchiveGetStream;\r\n SevenzipCheck(InArchive.QueryInterface(InterfaceID, FInArchiveGetStream));\r\n end;\r\n Result := FInArchiveGetStream;\r\nend;\r\n\r\nfunction TJclSevenzipDecompressArchive.GetItemClass: TJclCompressionItemClass;\r\nbegin\r\n Result := TJclSevenzipDecompressItem;\r\nend;\r\n\r\nfunction TJclSevenzipDecompressArchive.GetSupportsNestedArchive: Boolean;\r\nvar\r\n InterfaceID: TGUID;\r\nbegin\r\n Result := Assigned(FInArchiveGetStream);\r\n if not Result then\r\n begin\r\n InterfaceID := Sevenzip.IInArchiveGetStream;\r\n Result := InArchive.QueryInterface(InterfaceID, FInArchiveGetStream) = ERROR_SUCCESS;\r\n end;\r\nend;\r\n\r\nprocedure TJclSevenzipDecompressArchive.ListFiles;\r\nvar\r\n NumberOfItems: Cardinal;\r\n Index: Integer;\r\n AItem: TJclCompressionItem;\r\nbegin\r\n CheckNotDecompressing;\r\n\r\n FListing := True;\r\n try\r\n ClearItems;\r\n OpenArchive;\r\n\r\n SevenzipCheck(InArchive.GetNumberOfItems(@NumberOfItems));\r\n if NumberOfItems > 0 then\r\n begin\r\n for Index := 0 to NumberOfItems - 1 do\r\n begin\r\n AItem := GetItemClass.Create(Self);\r\n Load7zFileAttribute(InArchive, Index, AItem);\r\n FItems.Add(AItem);\r\n end;\r\n end;\r\n finally\r\n FListing := False;\r\n end;\r\nend;\r\n\r\nprocedure TJclSevenzipDecompressArchive.OpenArchive;\r\nvar\r\n SplitStream: TJclDynamicSplitStream;\r\n OpenCallback: IArchiveOpenCallback;\r\n MaxCheckStartPosition: Int64;\r\n AInStream: IInStream;\r\nbegin\r\n if not FOpened then\r\n begin\r\n if (VolumeFileNameMask <> '') or (VolumeMaxSize <> 0) or (FVolumes.Count <> 0) then\r\n begin\r\n SplitStream := TJclDynamicSplitStream.Create(False);\r\n SplitStream.OnVolume := NeedStream;\r\n SplitStream.OnVolumeMaxSize := NeedStreamMaxSize;\r\n AInStream := TJclSevenzipInStream.Create(SplitStream, True);\r\n end\r\n else\r\n AInStream := TJclSevenzipInStream.Create(NeedStream(0), False);\r\n OpenCallback := TJclSevenzipOpenCallback.Create(Self);\r\n\r\n SetSevenzipArchiveCompressionProperties(Self, InArchive);\r\n\r\n MaxCheckStartPosition := 1 shl 22;\r\n SevenzipCheck(InArchive.Open(AInStream, @MaxCheckStartPosition, OpenCallback));\r\n\r\n GetSevenzipArchiveCompressionProperties(Self, InArchive);\r\n\r\n FOpened := True;\r\n end;\r\nend;\r\n\r\n//=== { TJclZipDecompressArchive } ===========================================\r\n\r\nclass function TJclZipDecompressArchive.ArchiveExtensions: string;\r\nbegin\r\n Result := LoadResString(@RsCompressionZipExtensions);\r\nend;\r\n\r\nclass function TJclZipDecompressArchive.ArchiveName: string;\r\nbegin\r\n Result := LoadResString(@RsCompressionZipName);\r\nend;\r\n\r\nclass function TJclZipDecompressArchive.ArchiveCLSID: TGUID;\r\nbegin\r\n Result := CLSID_CFormatZip;\r\nend;\r\n\r\nfunction TJclZipDecompressArchive.GetNumberOfThreads: Cardinal;\r\nbegin\r\n Result := FNumberOfThreads;\r\nend;\r\n\r\nprocedure TJclZipDecompressArchive.InitializeArchiveProperties;\r\nbegin\r\n inherited InitializeArchiveProperties;\r\n FNumberOfThreads := 1;\r\nend;\r\n\r\nclass function TJclZipDecompressArchive.MultipleItemContainer: Boolean;\r\nbegin\r\n Result := True;\r\nend;\r\n\r\nprocedure TJclZipDecompressArchive.SetNumberOfThreads(Value: Cardinal);\r\nbegin\r\n CheckNotDecompressing;\r\n FNumberOfThreads := Value;\r\nend;\r\n\r\n//=== { TJclBZ2DecompressArchive } ===========================================\r\n\r\nclass function TJclBZ2DecompressArchive.ArchiveExtensions: string;\r\nbegin\r\n Result := LoadResString(@RsCompressionBZip2Extensions);\r\nend;\r\n\r\nclass function TJclBZ2DecompressArchive.ArchiveName: string;\r\nbegin\r\n Result := LoadResString(@RsCompressionBZip2Name);\r\nend;\r\n\r\nclass function TJclBZ2DecompressArchive.ArchiveSubExtensions: string;\r\nbegin\r\n Result := LoadResString(@RsCompressionBZip2SubExtensions);\r\nend;\r\n\r\nclass function TJclBZ2DecompressArchive.ArchiveCLSID: TGUID;\r\nbegin\r\n Result := CLSID_CFormatBZ2;\r\nend;\r\n\r\nfunction TJclBZ2DecompressArchive.GetNumberOfThreads: Cardinal;\r\nbegin\r\n Result := FNumberOfThreads;\r\nend;\r\n\r\nprocedure TJclBZ2DecompressArchive.InitializeArchiveProperties;\r\nbegin\r\n inherited InitializeArchiveProperties;\r\n FNumberOfThreads := 1;\r\nend;\r\n\r\nprocedure TJclBZ2DecompressArchive.SetNumberOfThreads(Value: Cardinal);\r\nbegin\r\n CheckNotDecompressing;\r\n FNumberOfThreads := Value;\r\nend;\r\n\r\n//=== { TJclRarDecompressArchive } ===========================================\r\n\r\nclass function TJclRarDecompressArchive.ArchiveExtensions: string;\r\nbegin\r\n Result := LoadResString(@RsCompressionRarExtensions);\r\nend;\r\n\r\nclass function TJclRarDecompressArchive.ArchiveName: string;\r\nbegin\r\n Result := LoadResString(@RsCompressionRarName);\r\nend;\r\n\r\nclass function TJclRarDecompressArchive.ArchiveCLSID: TGUID;\r\nbegin\r\n Result := CLSID_CFormatRar;\r\nend;\r\n\r\nclass function TJclRarDecompressArchive.MultipleItemContainer: Boolean;\r\nbegin\r\n Result := True;\r\nend;\r\n\r\n//=== { TJclArjDecompressArchive } ===========================================\r\n\r\nclass function TJclArjDecompressArchive.ArchiveExtensions: string;\r\nbegin\r\n Result := LoadResString(@RsCompressionArjExtensions);\r\nend;\r\n\r\nclass function TJclArjDecompressArchive.ArchiveName: string;\r\nbegin\r\n Result := LoadResString(@RsCompressionArjName);\r\nend;\r\n\r\nclass function TJclArjDecompressArchive.ArchiveCLSID: TGUID;\r\nbegin\r\n Result := CLSID_CFormatArj;\r\nend;\r\n\r\nclass function TJclArjDecompressArchive.MultipleItemContainer: Boolean;\r\nbegin\r\n Result := True;\r\nend;\r\n\r\n//=== { TJclZDecompressArchive } =============================================\r\n\r\nclass function TJclZDecompressArchive.ArchiveExtensions: string;\r\nbegin\r\n Result := LoadResString(@RsCompressionZExtensions);\r\nend;\r\n\r\nclass function TJclZDecompressArchive.ArchiveName: string;\r\nbegin\r\n Result := LoadResString(@RsCompressionZName);\r\nend;\r\n\r\nclass function TJclZDecompressArchive.ArchiveSubExtensions: string;\r\nbegin\r\n Result := LoadResString(@RsCompressionZSubExtensions);\r\nend;\r\n\r\nclass function TJclZDecompressArchive.ArchiveCLSID: TGUID;\r\nbegin\r\n Result := CLSID_CFormatZ;\r\nend;\r\n\r\nclass function TJclZDecompressArchive.MultipleItemContainer: Boolean;\r\nbegin\r\n Result := True;\r\nend;\r\n\r\n//=== { TJclLzhDecompressArchive } ===========================================\r\n\r\nclass function TJclLzhDecompressArchive.ArchiveExtensions: string;\r\nbegin\r\n Result := LoadResString(@RsCompressionLzhExtensions);\r\nend;\r\n\r\nclass function TJclLzhDecompressArchive.ArchiveName: string;\r\nbegin\r\n Result := LoadResString(@RsCompressionLzhName);\r\nend;\r\n\r\nclass function TJclLzhDecompressArchive.ArchiveCLSID: TGUID;\r\nbegin\r\n Result := CLSID_CFormatLzh;\r\nend;\r\n\r\nclass function TJclLzhDecompressArchive.MultipleItemContainer: Boolean;\r\nbegin\r\n Result := True;\r\nend;\r\n\r\n//=== { TJcl7zDecompressArchive } ============================================\r\n\r\nclass function TJcl7zDecompressArchive.ArchiveExtensions: string;\r\nbegin\r\n Result := LoadResString(@RsCompression7zExtensions);\r\nend;\r\n\r\nclass function TJcl7zDecompressArchive.ArchiveName: string;\r\nbegin\r\n Result := LoadResString(@RsCompression7zName);\r\nend;\r\n\r\nclass function TJcl7zDecompressArchive.ArchiveCLSID: TGUID;\r\nbegin\r\n Result := CLSID_CFormat7z;\r\nend;\r\n\r\nfunction TJcl7zDecompressArchive.GetNumberOfThreads: Cardinal;\r\nbegin\r\n Result := FNumberOfThreads;\r\nend;\r\n\r\nprocedure TJcl7zDecompressArchive.InitializeArchiveProperties;\r\nbegin\r\n inherited InitializeArchiveProperties;\r\n FNumberOfThreads := 1;\r\nend;\r\n\r\nclass function TJcl7zDecompressArchive.MultipleItemContainer: Boolean;\r\nbegin\r\n Result := True;\r\nend;\r\n\r\nprocedure TJcl7zDecompressArchive.SetNumberOfThreads(Value: Cardinal);\r\nbegin\r\n CheckNotDecompressing;\r\n FNumberOfThreads := Value;\r\nend;\r\n\r\n//=== { TJclCabDecompressArchive } ===========================================\r\n\r\nclass function TJclCabDecompressArchive.ArchiveExtensions: string;\r\nbegin\r\n Result := LoadResString(@RsCompressionCabExtensions);\r\nend;\r\n\r\nclass function TJclCabDecompressArchive.ArchiveName: string;\r\nbegin\r\n Result := LoadResString(@RsCompressionCabName);\r\nend;\r\n\r\nclass function TJclCabDecompressArchive.ArchiveCLSID: TGUID;\r\nbegin\r\n Result := CLSID_CFormatCab;\r\nend;\r\n\r\nclass function TJclCabDecompressArchive.MultipleItemContainer: Boolean;\r\nbegin\r\n Result := True;\r\nend;\r\n\r\n//=== { TJclNsisDecompressArchive } ==========================================\r\n\r\nclass function TJclNsisDecompressArchive.ArchiveExtensions: string;\r\nbegin\r\n Result := LoadResString(@RsCompressionNsisExtensions);\r\nend;\r\n\r\nclass function TJclNsisDecompressArchive.ArchiveName: string;\r\nbegin\r\n Result := LoadResString(@RsCompressionNsisName);\r\nend;\r\n\r\nclass function TJclNsisDecompressArchive.ArchiveCLSID: TGUID;\r\nbegin\r\n Result := CLSID_CFormatNsis;\r\nend;\r\n\r\nclass function TJclNsisDecompressArchive.MultipleItemContainer: Boolean;\r\nbegin\r\n Result := True;\r\nend;\r\n\r\n//=== { TJclLzmaDecompressArchive } ==========================================\r\n\r\nclass function TJclLzmaDecompressArchive.ArchiveExtensions: string;\r\nbegin\r\n Result := LoadResString(@RsCompressionLzmaExtensions);\r\nend;\r\n\r\nclass function TJclLzmaDecompressArchive.ArchiveName: string;\r\nbegin\r\n Result := LoadResString(@RsCompressionLzmaName);\r\nend;\r\n\r\nclass function TJclLzmaDecompressArchive.ArchiveCLSID: TGUID;\r\nbegin\r\n Result := CLSID_CFormatLzma;\r\nend;\r\n\r\nclass function TJclLzmaDecompressArchive.MultipleItemContainer: Boolean;\r\nbegin\r\n Result := False;\r\nend;\r\n\r\n//=== { TJclLzma86DecompressArchive } ========================================\r\n\r\nclass function TJclLzma86DecompressArchive.ArchiveExtensions: string;\r\nbegin\r\n Result := LoadResString(@RsCompressionLzma86Extensions);\r\nend;\r\n\r\nclass function TJclLzma86DecompressArchive.ArchiveName: string;\r\nbegin\r\n Result := LoadResString(@RsCompressionLzma86Name);\r\nend;\r\n\r\nclass function TJclLzma86DecompressArchive.ArchiveCLSID: TGUID;\r\nbegin\r\n Result := CLSID_CFormatLzma86;\r\nend;\r\n\r\nclass function TJclLzma86DecompressArchive.MultipleItemContainer: Boolean;\r\nbegin\r\n Result := False;\r\nend;\r\n\r\n//=== { TJclPeDecompressArchive } ============================================\r\n\r\nclass function TJclPeDecompressArchive.ArchiveExtensions: string;\r\nbegin\r\n Result := LoadResString(@RsCompressionPeExtensions);\r\nend;\r\n\r\nclass function TJclPeDecompressArchive.ArchiveName: string;\r\nbegin\r\n Result := LoadResString(@RsCompressionPeName);\r\nend;\r\n\r\nclass function TJclPeDecompressArchive.ArchiveCLSID: TGUID;\r\nbegin\r\n Result := CLSID_CFormatPe;\r\nend;\r\n\r\nclass function TJclPeDecompressArchive.MultipleItemContainer: Boolean;\r\nbegin\r\n Result := True;\r\nend;\r\n\r\n//=== { TJclElfDecompressArchive } ===========================================\r\n\r\nclass function TJclElfDecompressArchive.ArchiveExtensions: string;\r\nbegin\r\n Result := LoadResString(@RsCompressionElfExtensions);\r\nend;\r\n\r\nclass function TJclElfDecompressArchive.ArchiveName: string;\r\nbegin\r\n Result := LoadResString(@RsCompressionElfName);\r\nend;\r\n\r\nclass function TJclElfDecompressArchive.ArchiveCLSID: TGUID;\r\nbegin\r\n Result := CLSID_CFormatElf;\r\nend;\r\n\r\nclass function TJclElfDecompressArchive.MultipleItemContainer: Boolean;\r\nbegin\r\n Result := True;\r\nend;\r\n\r\n//=== { TJclMachoDecompressArchive } =========================================\r\n\r\nclass function TJclMachoDecompressArchive.ArchiveExtensions: string;\r\nbegin\r\n Result := LoadResString(@RsCompressionMachoExtensions);\r\nend;\r\n\r\nclass function TJclMachoDecompressArchive.ArchiveName: string;\r\nbegin\r\n Result := LoadResString(@RsCompressionMachoName);\r\nend;\r\n\r\nclass function TJclMachoDecompressArchive.ArchiveCLSID: TGUID;\r\nbegin\r\n Result := CLSID_CFormatMacho;\r\nend;\r\n\r\nclass function TJclMachoDecompressArchive.MultipleItemContainer: Boolean;\r\nbegin\r\n Result := True;\r\nend;\r\n\r\n//=== { TJclUdfDecompressArchive } ==========================================\r\n\r\nclass function TJclUdfDecompressArchive.ArchiveExtensions: string;\r\nbegin\r\n Result := LoadResString(@RsCompressionUdfExtensions);\r\nend;\r\n\r\nclass function TJclUdfDecompressArchive.ArchiveName: string;\r\nbegin\r\n Result := LoadResString(@RsCompressionUdfName);\r\nend;\r\n\r\nclass function TJclUdfDecompressArchive.ArchiveCLSID: TGUID;\r\nbegin\r\n Result := CLSID_CFormatUdf;\r\nend;\r\n\r\nclass function TJclUdfDecompressArchive.MultipleItemContainer: Boolean;\r\nbegin\r\n Result := True;\r\nend;\r\n\r\n//=== { TJclXarDecompressArchive } ===========================================\r\n\r\nclass function TJclXarDecompressArchive.ArchiveExtensions: string;\r\nbegin\r\n Result := LoadResString(@RsCompressionXarExtensions);\r\nend;\r\n\r\nclass function TJclXarDecompressArchive.ArchiveName: string;\r\nbegin\r\n Result := LoadResString(@RsCompressionXarName);\r\nend;\r\n\r\nclass function TJclXarDecompressArchive.ArchiveCLSID: TGUID;\r\nbegin\r\n Result := CLSID_CFormatXar;\r\nend;\r\n\r\nclass function TJclXarDecompressArchive.MultipleItemContainer: Boolean;\r\nbegin\r\n Result := True;\r\nend;\r\n\r\n//=== { TJclMubDecompressArchive } ===========================================\r\n\r\nclass function TJclMubDecompressArchive.ArchiveExtensions: string;\r\nbegin\r\n Result := LoadResString(@RsCompressionMubExtensions);\r\nend;\r\n\r\nclass function TJclMubDecompressArchive.ArchiveName: string;\r\nbegin\r\n Result := LoadResString(@RsCompressionMubName);\r\nend;\r\n\r\nclass function TJclMubDecompressArchive.ArchiveCLSID: TGUID;\r\nbegin\r\n Result := CLSID_CFormatMub;\r\nend;\r\n\r\nclass function TJclMubDecompressArchive.MultipleItemContainer: Boolean;\r\nbegin\r\n Result := True;\r\nend;\r\n\r\n//=== { TJclHfsDecompressArchive } ===========================================\r\n\r\nclass function TJclHfsDecompressArchive.ArchiveExtensions: string;\r\nbegin\r\n Result := LoadResString(@RsCompressionHfsExtensions);\r\nend;\r\n\r\nclass function TJclHfsDecompressArchive.ArchiveName: string;\r\nbegin\r\n Result := LoadResString(@RsCompressionHfsName);\r\nend;\r\n\r\nclass function TJclHfsDecompressArchive.ArchiveCLSID: TGUID;\r\nbegin\r\n Result := CLSID_CFormatHfs;\r\nend;\r\n\r\nclass function TJclHfsDecompressArchive.MultipleItemContainer: Boolean;\r\nbegin\r\n Result := True;\r\nend;\r\n\r\n//=== { TJclDmgDecompressArchive } ===========================================\r\n\r\nclass function TJclDmgDecompressArchive.ArchiveExtensions: string;\r\nbegin\r\n Result := LoadResString(@RsCompressionDmgExtensions);\r\nend;\r\n\r\nclass function TJclDmgDecompressArchive.ArchiveName: string;\r\nbegin\r\n Result := LoadResString(@RsCompressionDmgName);\r\nend;\r\n\r\nclass function TJclDmgDecompressArchive.ArchiveCLSID: TGUID;\r\nbegin\r\n Result := CLSID_CFormatDmg;\r\nend;\r\n\r\nclass function TJclDmgDecompressArchive.MultipleItemContainer: Boolean;\r\nbegin\r\n Result := True;\r\nend;\r\n\r\n//=== { TJclCompoundDecompressArchive } ======================================\r\n\r\nclass function TJclCompoundDecompressArchive.ArchiveExtensions: string;\r\nbegin\r\n Result := LoadResString(@RsCompressionCompoundExtensions);\r\nend;\r\n\r\nclass function TJclCompoundDecompressArchive.ArchiveName: string;\r\nbegin\r\n Result := LoadResString(@RsCompressionCompoundName);\r\nend;\r\n\r\nclass function TJclCompoundDecompressArchive.ArchiveCLSID: TGUID;\r\nbegin\r\n Result := CLSID_CFormatCompound;\r\nend;\r\n\r\nclass function TJclCompoundDecompressArchive.MultipleItemContainer: Boolean;\r\nbegin\r\n Result := True;\r\nend;\r\n\r\n//=== { TJclWimDecompressArchive } ===========================================\r\n\r\nclass function TJclWimDecompressArchive.ArchiveExtensions: string;\r\nbegin\r\n Result := LoadResString(@RsCompressionWimExtensions);\r\nend;\r\n\r\nclass function TJclWimDecompressArchive.ArchiveName: string;\r\nbegin\r\n Result := LoadResString(@RsCompressionWimName);\r\nend;\r\n\r\nclass function TJclWimDecompressArchive.ArchiveCLSID: TGUID;\r\nbegin\r\n Result := CLSID_CFormatWim;\r\nend;\r\n\r\nclass function TJclWimDecompressArchive.MultipleItemContainer: Boolean;\r\nbegin\r\n Result := True;\r\nend;\r\n\r\n//=== { TJclIsoDecompressArchive } ===========================================\r\n\r\nclass function TJclIsoDecompressArchive.ArchiveExtensions: string;\r\nbegin\r\n Result := LoadResString(@RsCompressionIsoExtensions);\r\nend;\r\n\r\nclass function TJclIsoDecompressArchive.ArchiveName: string;\r\nbegin\r\n Result := LoadResString(@RsCompressionIsoName);\r\nend;\r\n\r\nclass function TJclIsoDecompressArchive.ArchiveCLSID: TGUID;\r\nbegin\r\n Result := CLSID_CFormatIso;\r\nend;\r\n\r\nclass function TJclIsoDecompressArchive.MultipleItemContainer: Boolean;\r\nbegin\r\n Result := True;\r\nend;\r\n\r\n//=== { TJclChmDecompressArchive } ===========================================\r\n\r\nclass function TJclChmDecompressArchive.ArchiveExtensions: string;\r\nbegin\r\n Result := LoadResString(@RsCompressionChmExtensions);\r\nend;\r\n\r\nclass function TJclChmDecompressArchive.ArchiveName: string;\r\nbegin\r\n Result := LoadResString(@RsCompressionChmName);\r\nend;\r\n\r\nclass function TJclChmDecompressArchive.ArchiveCLSID: TGUID;\r\nbegin\r\n Result := CLSID_CFormatChm;\r\nend;\r\n\r\nclass function TJclChmDecompressArchive.MultipleItemContainer: Boolean;\r\nbegin\r\n Result := True;\r\nend;\r\n\r\n//=== { TJclSplitDecompressArchive } =========================================\r\n\r\nclass function TJclSplitDecompressArchive.ArchiveExtensions: string;\r\nbegin\r\n Result := LoadResString(@RsCompressionSplitExtensions);\r\nend;\r\n\r\nclass function TJclSplitDecompressArchive.ArchiveName: string;\r\nbegin\r\n Result := LoadResString(@RsCompressionSplitName);\r\nend;\r\n\r\nclass function TJclSplitDecompressArchive.ArchiveCLSID: TGUID;\r\nbegin\r\n Result := CLSID_CFormatSplit;\r\nend;\r\n\r\n//=== { TJclRpmDecompressArchive } ===========================================\r\n\r\nclass function TJclRpmDecompressArchive.ArchiveExtensions: string;\r\nbegin\r\n Result := LoadResString(@RsCompressionRpmExtensions);\r\nend;\r\n\r\nclass function TJclRpmDecompressArchive.ArchiveName: string;\r\nbegin\r\n Result := LoadResString(@RsCompressionRpmName);\r\nend;\r\n\r\nclass function TJclRpmDecompressArchive.ArchiveCLSID: TGUID;\r\nbegin\r\n Result := CLSID_CFormatRpm;\r\nend;\r\n\r\nclass function TJclRpmDecompressArchive.MultipleItemContainer: Boolean;\r\nbegin\r\n Result := True;\r\nend;\r\n\r\n//=== { TJclDebDecompressArchive } ===========================================\r\n\r\nclass function TJclDebDecompressArchive.ArchiveExtensions: string;\r\nbegin\r\n Result := LoadResString(@RsCompressionDebExtensions);\r\nend;\r\n\r\nclass function TJclDebDecompressArchive.ArchiveName: string;\r\nbegin\r\n Result := LoadResString(@RsCompressionDebName);\r\nend;\r\n\r\nclass function TJclDebDecompressArchive.ArchiveCLSID: TGUID;\r\nbegin\r\n Result := CLSID_CFormatDeb;\r\nend;\r\n\r\nclass function TJclDebDecompressArchive.MultipleItemContainer: Boolean;\r\nbegin\r\n Result := True;\r\nend;\r\n\r\n//=== { TJclCpioDecompressArchive } ==========================================\r\n\r\nclass function TJclCpioDecompressArchive.ArchiveExtensions: string;\r\nbegin\r\n Result := LoadResString(@RsCompressionCpioExtensions);\r\nend;\r\n\r\nclass function TJclCpioDecompressArchive.ArchiveName: string;\r\nbegin\r\n Result := LoadResString(@RsCompressionCpioName);\r\nend;\r\n\r\nclass function TJclCpioDecompressArchive.ArchiveCLSID: TGUID;\r\nbegin\r\n Result := CLSID_CFormatCpio;\r\nend;\r\n\r\nclass function TJclCpioDecompressArchive.MultipleItemContainer: Boolean;\r\nbegin\r\n Result := True;\r\nend;\r\n\r\n//=== { TJclTarDecompressArchive } ===========================================\r\n\r\nclass function TJclTarDecompressArchive.ArchiveExtensions: string;\r\nbegin\r\n Result := LoadResString(@RsCompressionTarExtensions);\r\nend;\r\n\r\nclass function TJclTarDecompressArchive.ArchiveName: string;\r\nbegin\r\n Result := LoadResString(@RsCompressionTarName);\r\nend;\r\n\r\nclass function TJclTarDecompressArchive.ArchiveCLSID: TGUID;\r\nbegin\r\n Result := CLSID_CFormatTar;\r\nend;\r\n\r\nclass function TJclTarDecompressArchive.MultipleItemContainer: Boolean;\r\nbegin\r\n Result := True;\r\nend;\r\n\r\n//=== { TJclGZipDecompressArchive } ==========================================\r\n\r\nclass function TJclGZipDecompressArchive.ArchiveExtensions: string;\r\nbegin\r\n Result := LoadResString(@RsCompressionGZipExtensions);\r\nend;\r\n\r\nclass function TJclGZipDecompressArchive.ArchiveName: string;\r\nbegin\r\n Result := LoadResString(@RsCompressionGZipName);\r\nend;\r\n\r\nclass function TJclGZipDecompressArchive.ArchiveSubExtensions: string;\r\nbegin\r\n Result := LoadResString(@RsCompressionGZipSubExtensions);\r\nend;\r\n\r\nclass function TJclGZipDecompressArchive.ArchiveCLSID: TGUID;\r\nbegin\r\n Result := CLSID_CFormatGZip;\r\nend;\r\n\r\n//=== { TJclXzDecompressArchive } ============================================\r\n\r\nclass function TJclXzDecompressArchive.ArchiveExtensions: string;\r\nbegin\r\n Result := LoadResString(@RsCompressionXzExtensions);\r\nend;\r\n\r\nclass function TJclXzDecompressArchive.ArchiveName: string;\r\nbegin\r\n Result := LoadResString(@RsCompressionXzName);\r\nend;\r\n\r\nclass function TJclXzDecompressArchive.ArchiveSubExtensions: string;\r\nbegin\r\n Result := LoadResString(@RsCompressionXzSubExtensions);\r\nend;\r\n\r\nclass function TJclXzDecompressArchive.ArchiveCLSID: TGUID;\r\nbegin\r\n Result := CLSID_CFormatXz;\r\nend;\r\n\r\n//=== { TJclNtfsDecompressArchive } ==========================================\r\n\r\nclass function TJclNtfsDecompressArchive.ArchiveExtensions: string;\r\nbegin\r\n Result := LoadResString(@RsCompressionNtfsExtensions);\r\nend;\r\n\r\nclass function TJclNtfsDecompressArchive.ArchiveName: string;\r\nbegin\r\n Result := LoadResString(@RsCompressionNtfsName);\r\nend;\r\n\r\nclass function TJclNtfsDecompressArchive.ArchiveCLSID: TGUID;\r\nbegin\r\n Result := CLSID_CFormatNtfs;\r\nend;\r\n\r\nclass function TJclNtfsDecompressArchive.MultipleItemContainer: Boolean;\r\nbegin\r\n Result := True;\r\nend;\r\n\r\n//=== { TJclFatDecompressArchive } ===========================================\r\n\r\nclass function TJclFatDecompressArchive.ArchiveExtensions: string;\r\nbegin\r\n Result := LoadResString(@RsCompressionFatExtensions);\r\nend;\r\n\r\nclass function TJclFatDecompressArchive.ArchiveName: string;\r\nbegin\r\n Result := LoadResString(@RsCompressionFatName);\r\nend;\r\n\r\nclass function TJclFatDecompressArchive.ArchiveCLSID: TGUID;\r\nbegin\r\n Result := CLSID_CFormatFat;\r\nend;\r\n\r\nclass function TJclFatDecompressArchive.MultipleItemContainer: Boolean;\r\nbegin\r\n Result := True;\r\nend;\r\n\r\n//=== { TJclMbrDecompressArchive } ===========================================\r\n\r\nclass function TJclMbrDecompressArchive.ArchiveExtensions: string;\r\nbegin\r\n Result := LoadResString(@RsCompressionMbrExtensions);\r\nend;\r\n\r\nclass function TJclMbrDecompressArchive.ArchiveName: string;\r\nbegin\r\n Result := LoadResString(@RsCompressionMbrName);\r\nend;\r\n\r\nclass function TJclMbrDecompressArchive.ArchiveCLSID: TGUID;\r\nbegin\r\n Result := CLSID_CFormatMbr;\r\nend;\r\n\r\nclass function TJclMbrDecompressArchive.MultipleItemContainer: Boolean;\r\nbegin\r\n Result := True;\r\nend;\r\n\r\n//=== { TJclVhdDecompressArchive } ===========================================\r\n\r\nclass function TJclVhdDecompressArchive.ArchiveExtensions: string;\r\nbegin\r\n Result := LoadResString(@RsCompressionVhdExtensions);\r\nend;\r\n\r\nclass function TJclVhdDecompressArchive.ArchiveName: string;\r\nbegin\r\n Result := LoadResString(@RsCompressionVhdName);\r\nend;\r\n\r\nclass function TJclVhdDecompressArchive.ArchiveSubExtensions: string;\r\nbegin\r\n Result := LoadResString(@RsCompressionVhdSubExtensions);\r\nend;\r\n\r\nclass function TJclVhdDecompressArchive.ArchiveCLSID: TGUID;\r\nbegin\r\n Result := CLSID_CFormatVhd;\r\nend;\r\n\r\n//=== { TJclMslzDecompressArchive } ==========================================\r\n\r\nclass function TJclMslzDecompressArchive.ArchiveExtensions: string;\r\nbegin\r\n Result := LoadResString(@RsCompressionMslzExtensions);\r\nend;\r\n\r\nclass function TJclMslzDecompressArchive.ArchiveName: string;\r\nbegin\r\n Result := LoadResString(@RsCompressionMslzName);\r\nend;\r\n\r\nclass function TJclMslzDecompressArchive.ArchiveCLSID: TGUID;\r\nbegin\r\n Result := CLSID_CFormatMslz;\r\nend;\r\n\r\n//=== { TJclFlvDecompressArchive } ===========================================\r\n\r\nclass function TJclFlvDecompressArchive.ArchiveExtensions: string;\r\nbegin\r\n Result := LoadResString(@RsCompressionFlvExtensions);\r\nend;\r\n\r\nclass function TJclFlvDecompressArchive.ArchiveName: string;\r\nbegin\r\n Result := LoadResString(@RsCompressionFlvName);\r\nend;\r\n\r\nclass function TJclFlvDecompressArchive.ArchiveCLSID: TGUID;\r\nbegin\r\n Result := CLSID_CFormatFlv;\r\nend;\r\n\r\n//=== { TJclSwfDecompressArchive } ===========================================\r\n\r\nclass function TJclSwfDecompressArchive.ArchiveExtensions: string;\r\nbegin\r\n Result := LoadResString(@RsCompressionSwfExtensions);\r\nend;\r\n\r\nclass function TJclSwfDecompressArchive.ArchiveName: string;\r\nbegin\r\n Result := LoadResString(@RsCompressionSwfName);\r\nend;\r\n\r\nclass function TJclSwfDecompressArchive.ArchiveCLSID: TGUID;\r\nbegin\r\n Result := CLSID_CFormatSwf;\r\nend;\r\n\r\n//=== { TJclSwfcDecompressArchive } ==========================================\r\n\r\nclass function TJclSwfcDecompressArchive.ArchiveExtensions: string;\r\nbegin\r\n Result := LoadResString(@RsCompressionSwfcExtensions);\r\nend;\r\n\r\nclass function TJclSwfcDecompressArchive.ArchiveName: string;\r\nbegin\r\n Result := LoadResString(@RsCompressionSwfcName);\r\nend;\r\n\r\nclass function TJclSwfcDecompressArchive.ArchiveCLSID: TGUID;\r\nbegin\r\n Result := CLSID_CFormatSwfc;\r\nend;\r\n\r\n//=== { TJclAPMDecompressArchive } ===========================================\r\n\r\nclass function TJclAPMDecompressArchive.ArchiveExtensions: string;\r\nbegin\r\n Result := LoadResString(@RsCompressionApmExtensions);\r\nend;\r\n\r\nclass function TJclAPMDecompressArchive.ArchiveName: string;\r\nbegin\r\n Result := LoadResString(@RsCompressionApmName);\r\nend;\r\n\r\nclass function TJclAPMDecompressArchive.ArchiveCLSID: TGUID;\r\nbegin\r\n Result := CLSID_CFormatAPM;\r\nend;\r\n\r\n//=== { TJclPpmdDecompressArchive } ==========================================\r\n\r\nclass function TJclPpmdDecompressArchive.ArchiveExtensions: string;\r\nbegin\r\n Result := LoadResString(@RsCompressionPpmdExtensions);\r\nend;\r\n\r\nclass function TJclPpmdDecompressArchive.ArchiveName: string;\r\nbegin\r\n Result := LoadResString(@RsCompressionPpmdName);\r\nend;\r\n\r\nclass function TJclPpmdDecompressArchive.ArchiveCLSID: TGUID;\r\nbegin\r\n Result := CLSID_CFormatPpmd;\r\nend;\r\n\r\n//=== { TJclTEDecompressArchive } ============================================\r\n\r\nclass function TJclTEDecompressArchive.ArchiveExtensions: string;\r\nbegin\r\n Result := LoadResString(@RsCompressionTEExtensions);\r\nend;\r\n\r\nclass function TJclTEDecompressArchive.ArchiveName: string;\r\nbegin\r\n Result := LoadResString(@RsCompressionTEName);\r\nend;\r\n\r\nclass function TJclTEDecompressArchive.ArchiveCLSID: TGUID;\r\nbegin\r\n Result := CLSID_CFormatTE;\r\nend;\r\n\r\n//=== { TJclUEFIcDecompressArchive } =========================================\r\n\r\nclass function TJclUEFIcDecompressArchive.ArchiveExtensions: string;\r\nbegin\r\n Result := LoadResString(@RsCompressionUEFIcExtensions);\r\nend;\r\n\r\nclass function TJclUEFIcDecompressArchive.ArchiveName: string;\r\nbegin\r\n Result := LoadResString(@RsCompressionUEFIcName);\r\nend;\r\n\r\nclass function TJclUEFIcDecompressArchive.ArchiveCLSID: TGUID;\r\nbegin\r\n Result := CLSID_CFormatUEFIc;\r\nend;\r\n\r\n//=== { TJclUEFIsDecompressArchive } =========================================\r\n\r\nclass function TJclUEFIsDecompressArchive.ArchiveExtensions: string;\r\nbegin\r\n Result := LoadResString(@RsCompressionUEFIsExtensions);\r\nend;\r\n\r\nclass function TJclUEFIsDecompressArchive.ArchiveName: string;\r\nbegin\r\n Result := LoadResString(@RsCompressionUEFIsName);\r\nend;\r\n\r\nclass function TJclUEFIsDecompressArchive.ArchiveCLSID: TGUID;\r\nbegin\r\n Result := CLSID_CFormatUEFIs;\r\nend;\r\n\r\n//=== { TJclSquashFSDecompressArchive } ======================================\r\n\r\nclass function TJclSquashFSDecompressArchive.ArchiveExtensions: string;\r\nbegin\r\n Result := LoadResString(@RsCompressionSquashFSExtensions);\r\nend;\r\n\r\nclass function TJclSquashFSDecompressArchive.ArchiveName: string;\r\nbegin\r\n Result := LoadResString(@RsCompressionSquashFSName);\r\nend;\r\n\r\nclass function TJclSquashFSDecompressArchive.ArchiveCLSID: TGUID;\r\nbegin\r\n Result := CLSID_CFormatSquashFS;\r\nend;\r\n\r\n//=== { TJclCramFSDecompressArchive } ========================================\r\n\r\nclass function TJclCramFSDecompressArchive.ArchiveExtensions: string;\r\nbegin\r\n Result := LoadResString(@RsCompressionCramFSExtensions);\r\nend;\r\n\r\nclass function TJclCramFSDecompressArchive.ArchiveName: string;\r\nbegin\r\n Result := LoadResString(@RsCompressionCramFSName);\r\nend;\r\n\r\nclass function TJclCramFSDecompressArchive.ArchiveCLSID: TGUID;\r\nbegin\r\n Result := CLSID_CFormatCramFS;\r\nend;\r\n\r\n//=== { TJclSevenzipUpdateArchive } ==========================================\r\n\r\nclass function TJclSevenzipUpdateArchive.ArchiveCLSID: TGUID;\r\nbegin\r\n Result := GUID_NULL;\r\nend;\r\n\r\ndestructor TJclSevenzipUpdateArchive.Destroy;\r\nbegin\r\n FInArchive := nil;\r\n FOutArchive := nil;\r\n inherited Destroy;\r\nend;\r\n\r\nclass function TJclSevenzipUpdateArchive.ArchiveSignature: TDynByteArray;\r\nbegin\r\n Result := Get7zArchiveSignature(ArchiveCLSID);\r\nend;\r\n\r\nprocedure TJclSevenzipUpdateArchive.Compress;\r\nvar\r\n OutStream: IOutStream;\r\n UpdateCallback: IArchiveUpdateCallback;\r\n SplitStream: TJclDynamicSplitStream;\r\nbegin\r\n CheckNotCompressing;\r\n CheckNotDecompressing;\r\n\r\n FCompressing := True;\r\n try\r\n SplitStream := TJclDynamicSplitStream.Create(True);\r\n SplitStream.OnVolume := NeedTmpStream;\r\n SplitStream.OnVolumeMaxSize := NeedStreamMaxSize;\r\n OutStream := TJclSevenzipOutStream.Create(SplitStream, True, True);\r\n UpdateCallback := TJclSevenzipUpdateCallback.Create(Self);\r\n\r\n SetSevenzipArchiveCompressionProperties(Self, OutArchive);\r\n\r\n SevenzipCheck(OutArchive.UpdateItems(OutStream, ItemCount, UpdateCallback));\r\n finally\r\n FCompressing := False;\r\n // release reference to volume streams\r\n OutStream := nil;\r\n // replace streams by tmp streams\r\n inherited Compress;\r\n end;\r\nend;\r\n\r\nprocedure TJclSevenzipUpdateArchive.DeleteItem(Index: Integer);\r\nvar\r\n I, BaseLength: Integer;\r\n IsDirectory: Boolean;\r\n AItem: TJclCompressionItem;\r\n DirectoryName: WideString;\r\nbegin\r\n AItem := Items[Index];\r\n IsDirectory := (AItem.Attributes and faDirectory) <> 0;\r\n DirectoryName := AItem.PackedName + DirDelimiter;\r\n\r\n FItems.Delete(Index);\r\n\r\n if IsDirectory then\r\n begin\r\n BaseLength := Length(DirectoryName);\r\n\r\n for I := ItemCount - 1 downto 0 do\r\n if WideSameText(DirectoryName, Copy(Items[I].PackedName, 1, BaseLength)) then\r\n FItems.Delete(I);\r\n end;\r\nend;\r\n\r\nprocedure TJclSevenzipUpdateArchive.ExtractAll(const ADestinationDir: string;\r\n AAutoCreateSubDir: Boolean);\r\nvar\r\n AExtractCallback: IArchiveExtractCallback;\r\n Indices: array of Cardinal;\r\n NbIndices: Cardinal;\r\n Index: Integer;\r\nbegin\r\n CheckNotDecompressing;\r\n CheckNotCompressing;\r\n \r\n FDestinationDir := ADestinationDir;\r\n FAutoCreateSubDir := AAutoCreateSubDir;\r\n \r\n if FDestinationDir <> '' then\r\n FDestinationDir := PathAddSeparator(FDestinationDir);\r\n\r\n FDecompressing := True;\r\n FExtractingAllIndex := 0;\r\n AExtractCallback := TJclSevenzipExtractCallback.Create(Self);\r\n try\r\n OpenArchive;\r\n\r\n // seems buggy: first param \"indices\" is dereferenced without\r\n // liveness checks inside Sevenzip code\r\n //SevenzipCheck(InArchive.Extract(nil, $FFFFFFFF, 0, AExtractCallback));\r\n\r\n NbIndices := ItemCount;\r\n SetLength(Indices, NbIndices);\r\n for Index := 0 to NbIndices - 1 do\r\n begin\r\n Items[Index].Selected := True;\r\n Indices[Index] := Index;\r\n end;\r\n SevenzipCheck(InArchive.Extract(@Indices[0], NbIndices, 0, AExtractCallback));\r\n\r\n CheckOperationSuccess;\r\n finally\r\n FDestinationDir := '';\r\n FDecompressing := False;\r\n FExtractingAllIndex := -1;\r\n FCurrentItemIndex := -1;\r\n AExtractCallback := nil;\r\n // release volumes and other finalizations\r\n inherited ExtractAll(ADestinationDir, AAutoCreateSubDir);\r\n end;\r\nend;\r\n\r\nprocedure TJclSevenzipUpdateArchive.ExtractSelected(\r\n const ADestinationDir: string; AAutoCreateSubDir: Boolean);\r\nvar\r\n AExtractCallback: IArchiveExtractCallback;\r\n Indices: array of Cardinal;\r\n NbIndices: Cardinal;\r\n Index: Integer;\r\nbegin\r\n CheckNotDecompressing;\r\n CheckNotCompressing;\r\n\r\n FDestinationDir := ADestinationDir;\r\n FAutoCreateSubDir := AAutoCreateSubDir;\r\n\r\n if FDestinationDir <> '' then\r\n FDestinationDir := PathAddSeparator(FDestinationDir);\r\n\r\n FDecompressing := True;\r\n AExtractCallback := TJclSevenzipExtractCallback.Create(Self);\r\n try\r\n OpenArchive;\r\n\r\n NbIndices := 0;\r\n for Index := 0 to ItemCount - 1 do\r\n if Items[Index].Selected then\r\n Inc(NbIndices);\r\n\r\n SetLength(Indices, NbIndices);\r\n NbIndices := 0;\r\n for Index := 0 to ItemCount - 1 do\r\n if Items[Index].Selected then\r\n begin\r\n Indices[NbIndices] := Index;\r\n Inc(NbIndices);\r\n end;\r\n\r\n SevenzipCheck(InArchive.Extract(@Indices[0], Length(Indices), 0, AExtractCallback));\r\n CheckOperationSuccess;\r\n finally\r\n FDestinationDir := '';\r\n FDecompressing := False;\r\n AExtractCallback := nil;\r\n FCurrentItemIndex := -1;\r\n // release volumes and other finalizations\r\n inherited ExtractSelected(ADestinationDir, AAutoCreateSubDir);\r\n end;\r\nend;\r\n\r\nfunction TJclSevenzipUpdateArchive.GetInArchive: IInArchive;\r\nvar\r\n SevenzipCLSID, InterfaceID: TGUID;\r\nbegin\r\n if not Assigned(FInArchive) then\r\n begin\r\n SevenzipCLSID := ArchiveCLSID;\r\n InterfaceID := Sevenzip.IInArchive;\r\n if (not Is7ZipLoaded) and (not Load7Zip) then\r\n raise EJclCompressionError.CreateRes(@RsCompression7zLoadError);\r\n if (Sevenzip.CreateObject(@SevenzipCLSID, @InterfaceID, FInArchive) <> ERROR_SUCCESS)\r\n or not Assigned(FInArchive) then\r\n raise EJclCompressionError.CreateResFmt(@RsCompression7zInArchiveError, [GUIDToString(SevenzipCLSID)]);\r\n end;\r\n Result := FInArchive;\r\nend;\r\n\r\nfunction TJclSevenzipUpdateArchive.GetItemClass: TJclCompressionItemClass;\r\nbegin\r\n Result := TJclUpdateItem;\r\nend;\r\n\r\nfunction TJclSevenzipUpdateArchive.GetOutArchive: IOutArchive;\r\nvar\r\n SevenzipCLSID, InterfaceID: TGUID;\r\nbegin\r\n if not Assigned(FOutarchive) then\r\n begin\r\n SevenzipCLSID := ArchiveCLSID;\r\n InterfaceID := Sevenzip.IOutArchive;\r\n if not Supports(InArchive, InterfaceID, FOutArchive)\r\n or not Assigned(FOutArchive) then\r\n raise EJclCompressionError.CreateResFmt(@RsCompression7zOutArchiveError, [GUIDToString(SevenzipCLSID)]);\r\n end;\r\n Result := FOutArchive;\r\nend;\r\n\r\nprocedure TJclSevenzipUpdateArchive.ListFiles;\r\nvar\r\n NumberOfItems: Cardinal;\r\n Index: Integer;\r\n AItem: TJclCompressionItem;\r\nbegin\r\n CheckNotDecompressing;\r\n CheckNotCompressing;\r\n\r\n FListing := True;\r\n try\r\n ClearItems;\r\n OpenArchive;\r\n\r\n SevenzipCheck(InArchive.GetNumberOfItems(@NumberOfItems));\r\n if NumberOfItems > 0 then\r\n begin\r\n for Index := 0 to NumberOfItems - 1 do\r\n begin\r\n AItem := GetItemClass.Create(Self);\r\n Load7zFileAttribute(InArchive, Index, AItem);\r\n FItems.Add(AItem);\r\n end;\r\n end;\r\n finally\r\n FListing := False;\r\n end;\r\nend;\r\n\r\nprocedure TJclSevenzipUpdateArchive.OpenArchive;\r\nvar\r\n OpenCallback: IArchiveOpenCallback;\r\n MaxCheckStartPosition: Int64;\r\n AInStream: IInStream;\r\n SplitStream: TJclDynamicSplitStream;\r\nbegin\r\n if not FOpened then\r\n begin\r\n SplitStream := TJclDynamicSplitStream.Create(True);\r\n SplitStream.OnVolume := NeedStream;\r\n SplitStream.OnVolumeMaxSize := NeedStreamMaxSize;\r\n\r\n AInStream := TJclSevenzipInStream.Create(SplitStream, True);\r\n OpenCallback := TJclSevenzipOpenCallback.Create(Self);\r\n\r\n SetSevenzipArchiveCompressionProperties(Self, InArchive);\r\n\r\n MaxCheckStartPosition := 1 shl 22;\r\n SevenzipCheck(InArchive.Open(AInStream, @MaxCheckStartPosition, OpenCallback));\r\n\r\n GetSevenzipArchiveCompressionProperties(Self, InArchive);\r\n\r\n FOpened := True;\r\n end;\r\nend;\r\n\r\nprocedure TJclSevenzipUpdateArchive.RemoveItem(const PackedName: WideString);\r\nvar\r\n Index, BaseLength, PackedNamesIndex: Integer;\r\n IsDirectory: Boolean;\r\n AItem: TJclCompressionItem;\r\n DirectoryName: WideString;\r\nbegin\r\n IsDirectory := False;\r\n for Index := 0 to ItemCount - 1 do\r\n begin\r\n AItem := Items[Index];\r\n if WideSameText(AItem.PackedName, PackedName) then\r\n begin\r\n DirectoryName := AItem.PackedName;\r\n if (AItem.Attributes and faDirectory) <> 0 then\r\n IsDirectory := True;\r\n FItems.Delete(Index);\r\n PackedNamesIndex := -1;\r\n if (FPackedNames <> nil) and FPackedNames.Find(PackedName, PackedNamesIndex) then\r\n FPackedNames.Delete(PackedNamesIndex);\r\n Break;\r\n end;\r\n end;\r\n\r\n if IsDirectory then\r\n begin\r\n DirectoryName := PackedName + DirDelimiter;\r\n BaseLength := Length(DirectoryName);\r\n\r\n for Index := ItemCount - 1 downto 0 do\r\n if WideSameText(DirectoryName, Copy(Items[Index].PackedName, 1, BaseLength)) then\r\n begin\r\n if (FPackedNames <> nil) and FPackedNames.Find(Items[Index].PackedName, PackedNamesIndex) then\r\n FPackedNames.Delete(PackedNamesIndex);\r\n FItems.Delete(Index);\r\n end;\r\n end;\r\nend;\r\n\r\n//=== { TJclZipUpdateArchive } ===============================================\r\n\r\nclass function TJclZipUpdateArchive.ArchiveExtensions: string;\r\nbegin\r\n Result := LoadResString(@RsCompressionZipExtensions);\r\nend;\r\n\r\nclass function TJclZipUpdateArchive.ArchiveName: string;\r\nbegin\r\n Result := LoadResString(@RsCompressionZipName);\r\nend;\r\n\r\nclass function TJclZipUpdateArchive.ArchiveCLSID: TGUID;\r\nbegin\r\n Result := CLSID_CFormatZip;\r\nend;\r\n\r\nfunction TJclZipUpdateArchive.GetAlgorithm: Cardinal;\r\nbegin\r\n Result := FAlgorithm;\r\nend;\r\n\r\nfunction TJclZipUpdateArchive.GetCompressionLevel: Cardinal;\r\nbegin\r\n Result := FCompressionLevel;\r\nend;\r\n\r\nfunction TJclZipUpdateArchive.GetCompressionLevelMax: Cardinal;\r\nbegin\r\n Result := 9;\r\nend;\r\n\r\nfunction TJclZipUpdateArchive.GetCompressionLevelMin: Cardinal;\r\nbegin\r\n Result := 0;\r\nend;\r\n\r\nfunction TJclZipUpdateArchive.GetCompressionMethod: TJclCompressionMethod;\r\nbegin\r\n Result := FCompressionMethod;\r\nend;\r\n\r\nfunction TJclZipUpdateArchive.GetDictionarySize: Cardinal;\r\nbegin\r\n Result := FDictionarySize;\r\nend;\r\n\r\nfunction TJclZipUpdateArchive.GetEncryptionMethod: TJclEncryptionMethod;\r\nbegin\r\n Result := FEncryptionMethod;\r\nend;\r\n\r\nfunction TJclZipUpdateArchive.GetNumberOfPasses: Cardinal;\r\nbegin\r\n Result := FNumberOfPasses;\r\nend;\r\n\r\nfunction TJclZipUpdateArchive.GetNumberOfThreads: Cardinal;\r\nbegin\r\n Result := FNumberOfThreads;\r\nend;\r\n\r\nfunction TJclZipUpdateArchive.GetSupportedAlgorithms: TDynCardinalArray;\r\nbegin\r\n SetLength(Result,2);\r\n Result[0] := 0;\r\n Result[1] := 1;\r\nend;\r\n\r\nfunction TJclZipUpdateArchive.GetSupportedCompressionMethods: TJclCompressionMethods;\r\nbegin\r\n Result := [cmCopy,cmDeflate,cmDeflate64,cmBZip2,cmLZMA];\r\nend;\r\n\r\nfunction TJclZipUpdateArchive.GetSupportedEncryptionMethods: TJclEncryptionMethods;\r\nbegin\r\n Result := [emNone,emAES128,emAES192,emAES256,emZipCrypto];\r\nend;\r\n\r\nprocedure TJclZipUpdateArchive.InitializeArchiveProperties;\r\nbegin\r\n inherited InitializeArchiveProperties;\r\n FNumberOfThreads := 1;\r\n FEncryptionMethod := emZipCrypto;\r\n FDictionarySize := kBZip2DicSizeX5;\r\n FCompressionLevel := 7;\r\n FCompressionMethod := cmDeflate;\r\n FNumberOfPasses := kDeflateNumPassesX7;\r\n FAlgorithm := kLzAlgoX5;\r\nend;\r\n\r\nclass function TJclZipUpdateArchive.MultipleItemContainer: Boolean;\r\nbegin\r\n Result := True;\r\nend;\r\n\r\nprocedure TJclZipUpdateArchive.SetAlgorithm(Value: Cardinal);\r\nbegin\r\n CheckNotCompressing;\r\n CheckNotDecompressing;\r\n if (Value = 0) or (Value = 1) then\r\n FAlgorithm := Value\r\n else\r\n raise EJclCompressionError.CreateRes(@RsCompressionUnavailableProperty);\r\nend;\r\n\r\nprocedure TJclZipUpdateArchive.SetCompressionLevel(Value: Cardinal);\r\nbegin\r\n CheckNotCompressing;\r\n CheckNotDecompressing;\r\n if Value <= 9 then\r\n begin\r\n FCompressionLevel := Value;\r\n case FCompressionMethod of\r\n cmDeflate, cmDeflate64:\r\n begin\r\n if Value >= 9 then\r\n FNumberOfPasses := kDeflateNumPassesX9\r\n else\r\n if Value >= 7 then\r\n FNumberOfPasses := kDeflateNumPassesX7\r\n else\r\n FNumberOfPasses := kDeflateNumPassesX1;\r\n if Value >= 5 then\r\n FAlgorithm := kLzAlgoX5\r\n else\r\n FAlgorithm := kLzAlgoX1;\r\n end;\r\n cmBZip2:\r\n begin\r\n if Value >= 9 then\r\n FNumberOfPasses := kBZip2NumPassesX9\r\n else\r\n if Value >= 7 then\r\n FNumberOfPasses := kBZip2NumPassesX7\r\n else\r\n FNumberOfPasses := kBZip2NumPassesX1;\r\n if Value >= 5 then\r\n FDictionarySize := kBZip2DicSizeX5\r\n else\r\n if Value >= 3 then\r\n FDictionarySize := kBZip2DicSizeX3\r\n else\r\n FDictionarySize := kBZip2DicSizeX1;\r\n end;\r\n cmLZMA:\r\n begin\r\n if Value >= 9 then\r\n FDictionarySize := kLzmaDicSizeX9\r\n else\r\n if Value >= 7 then\r\n FDictionarySize := kLzmaDicSizeX7\r\n else\r\n if Value >= 5 then\r\n FDictionarySize := kLzmaDicSizeX5\r\n else\r\n if Value >= 3 then\r\n FDictionarySize := kLzmaDicSizeX3\r\n else\r\n FDictionarySize := kLzmaDicSizeX1;\r\n if Value >= 5 then\r\n FAlgorithm := kLzAlgoX5\r\n else\r\n FAlgorithm := kLzAlgoX1;\r\n end;\r\n end;\r\n end\r\n else\r\n raise EJclCompressionError.CreateRes(@RsCompressionUnavailableProperty);\r\nend;\r\n\r\nprocedure TJclZipUpdateArchive.SetCompressionMethod(Value: TJclCompressionMethod);\r\nbegin\r\n CheckNotCompressing;\r\n CheckNotDecompressing;\r\n if Value in GetSupportedCompressionMethods then\r\n FCompressionMethod := Value\r\n else\r\n raise EJclCompressionError.CreateRes(@RsCompressionUnavailableProperty);\r\nend;\r\n\r\nprocedure TJclZipUpdateArchive.SetDictionarySize(Value: Cardinal);\r\nbegin\r\n CheckNotCompressing;\r\n CheckNotDecompressing;\r\n FDictionarySize := Value;\r\nend;\r\n\r\nprocedure TJclZipUpdateArchive.SetEncryptionMethod(Value: TJclEncryptionMethod);\r\nbegin\r\n CheckNotCompressing;\r\n CheckNotDecompressing;\r\n if Value in GetSupportedEncryptionMethods then\r\n FEncryptionMethod := Value\r\n else\r\n raise EJclCompressionError.CreateRes(@RsCompressionUnavailableProperty);\r\nend;\r\n\r\nprocedure TJclZipUpdateArchive.SetNumberOfPasses(Value: Cardinal);\r\nbegin\r\n CheckNotCompressing;\r\n CheckNotDecompressing;\r\n FNumberOfPasses := Value;\r\nend;\r\n\r\nprocedure TJclZipUpdateArchive.SetNumberOfThreads(Value: Cardinal);\r\nbegin\r\n CheckNotCompressing;\r\n CheckNotDecompressing;\r\n FNumberOfThreads := Value;\r\nend;\r\n\r\n//=== { TJclBZ2UpdateArchive } ===============================================\r\n\r\nclass function TJclBZ2UpdateArchive.ArchiveExtensions: string;\r\nbegin\r\n Result := LoadResString(@RsCompressionBZip2Extensions);\r\nend;\r\n\r\nclass function TJclBZ2UpdateArchive.ArchiveName: string;\r\nbegin\r\n Result := LoadResString(@RsCompressionBZip2Name);\r\nend;\r\n\r\nclass function TJclBZ2UpdateArchive.ArchiveSubExtensions: string;\r\nbegin\r\n Result := LoadResString(@RsCompressionBZip2SubExtensions);\r\nend;\r\n\r\nclass function TJclBZ2UpdateArchive.ArchiveCLSID: TGUID;\r\nbegin\r\n Result := CLSID_CFormatBZ2;\r\nend;\r\n\r\nfunction TJclBZ2UpdateArchive.GetCompressionLevel: Cardinal;\r\nbegin\r\n Result := FCompressionLevel;\r\nend;\r\n\r\nfunction TJclBZ2UpdateArchive.GetCompressionLevelMax: Cardinal;\r\nbegin\r\n Result := 9;\r\nend;\r\n\r\nfunction TJclBZ2UpdateArchive.GetCompressionLevelMin: Cardinal;\r\nbegin\r\n Result := 0;\r\nend;\r\n\r\nfunction TJclBZ2UpdateArchive.GetDictionarySize: Cardinal;\r\nbegin\r\n Result := FDictionarySize;\r\nend;\r\n\r\nfunction TJclBZ2UpdateArchive.GetNumberOfPasses: Cardinal;\r\nbegin\r\n Result := FNumberOfPasses;\r\nend;\r\n\r\nfunction TJclBZ2UpdateArchive.GetNumberOfThreads: Cardinal;\r\nbegin\r\n Result := FNumberOfThreads;\r\nend;\r\n\r\nprocedure TJclBZ2UpdateArchive.InitializeArchiveProperties;\r\nbegin\r\n inherited InitializeArchiveProperties;\r\n FNumberOfThreads := 1;\r\n FDictionarySize := kBZip2DicSizeX5;\r\n FCompressionLevel := 7;\r\n FNumberOfPasses := kBZip2NumPassesX7;\r\nend;\r\n\r\nprocedure TJclBZ2UpdateArchive.SetCompressionLevel(Value: Cardinal);\r\nbegin\r\n CheckNotCompressing;\r\n CheckNotDecompressing;\r\n if Value <= 9 then\r\n begin\r\n FCompressionLevel := Value;\r\n if Value >= 9 then\r\n FNumberOfPasses := kBZip2NumPassesX9\r\n else\r\n if Value >= 7 then\r\n FNumberOfPasses := kBZip2NumPassesX7\r\n else\r\n FNumberOfPasses := kBZip2NumPassesX1;\r\n if Value >= 5 then\r\n FDictionarySize := kBZip2DicSizeX5\r\n else\r\n if Value >= 3 then\r\n FDictionarySize := kBZip2DicSizeX3\r\n else\r\n FDictionarySize := kBZip2DicSizeX1;\r\n end\r\n else\r\n raise EJclCompressionError.CreateRes(@RsCompressionUnavailableProperty);\r\nend;\r\n\r\nprocedure TJclBZ2UpdateArchive.SetDictionarySize(Value: Cardinal);\r\nbegin\r\n CheckNotCompressing;\r\n CheckNotDecompressing;\r\n FDictionarySize := Value;\r\nend;\r\n\r\nprocedure TJclBZ2UpdateArchive.SetNumberOfPasses(Value: Cardinal);\r\nbegin\r\n CheckNotCompressing;\r\n CheckNotDecompressing;\r\n FNumberOfPasses := Value;\r\nend;\r\n\r\nprocedure TJclBZ2UpdateArchive.SetNumberOfThreads(Value: Cardinal);\r\nbegin\r\n CheckNotCompressing;\r\n CheckNotDecompressing;\r\n FNumberOfThreads := Value;\r\nend;\r\n\r\n//=== { TJcl7zUpdateArchive } ================================================\r\n\r\nclass function TJcl7zUpdateArchive.ArchiveExtensions: string;\r\nbegin\r\n Result := LoadResString(@RsCompression7zExtensions);\r\nend;\r\n\r\nclass function TJcl7zUpdateArchive.ArchiveName: string;\r\nbegin\r\n Result := LoadResString(@RsCompression7zName);\r\nend;\r\n\r\nclass function TJcl7zUpdateArchive.ArchiveCLSID: TGUID;\r\nbegin\r\n Result := CLSID_CFormat7z;\r\nend;\r\n\r\nfunction TJcl7zUpdateArchive.GetCompressHeader: Boolean;\r\nbegin\r\n Result := FCompressHeader;\r\nend;\r\n\r\nfunction TJcl7zUpdateArchive.GetCompressHeaderFull: Boolean;\r\nbegin\r\n Result := FCompressHeaderFull;\r\nend;\r\n\r\nfunction TJcl7zUpdateArchive.GetCompressionLevel: Cardinal;\r\nbegin\r\n Result := FCompressionLevel;\r\nend;\r\n\r\nfunction TJcl7zUpdateArchive.GetCompressionLevelMax: Cardinal;\r\nbegin\r\n Result := 9;\r\nend;\r\n\r\nfunction TJcl7zUpdateArchive.GetCompressionLevelMin: Cardinal;\r\nbegin\r\n Result := 0;\r\nend;\r\n\r\nfunction TJcl7zUpdateArchive.GetDictionarySize: Cardinal;\r\nbegin\r\n Result := FDictionarySize;\r\nend;\r\n\r\nfunction TJcl7zUpdateArchive.GetEncryptHeader: Boolean;\r\nbegin\r\n Result := FEncryptHeader;\r\nend;\r\n\r\nfunction TJcl7zUpdateArchive.GetNumberOfThreads: Cardinal;\r\nbegin\r\n Result := FNumberOfThreads;\r\nend;\r\n\r\nfunction TJcl7zUpdateArchive.GetRemoveSfxBlock: Boolean;\r\nbegin\r\n Result := FRemoveSfxBlock;\r\nend;\r\n\r\nfunction TJcl7zUpdateArchive.GetSaveCreationDateTime: Boolean;\r\nbegin\r\n Result := FSaveCreationDateTime;\r\nend;\r\n\r\nfunction TJcl7zUpdateArchive.GetSaveLastAccessDateTime: Boolean;\r\nbegin\r\n Result := FSaveLastAccessDateTime;\r\nend;\r\n\r\nfunction TJcl7zUpdateArchive.GetSaveLastWriteDateTime: Boolean;\r\nbegin\r\n Result := FSaveLastWriteDateTime;\r\nend;\r\n\r\nprocedure TJcl7zUpdateArchive.InitializeArchiveProperties;\r\nbegin\r\n inherited InitializeArchiveProperties;\r\n FNumberOfThreads := 1;\r\n FEncryptHeader := False;\r\n FRemoveSfxBlock := False;\r\n FDictionarySize := kLzmaDicSizeX5;\r\n FCompressionLevel := 6;\r\n FCompressHeader := False;\r\n FCompressHeaderFull := False;\r\n FSaveLastAccessDateTime := True;\r\n FSaveCreationDateTime := True;\r\n FSaveLastWriteDateTime := True;\r\nend;\r\n\r\nclass function TJcl7zUpdateArchive.MultipleItemContainer: Boolean;\r\nbegin\r\n Result := True;\r\nend;\r\n\r\nprocedure TJcl7zUpdateArchive.SetCompressHeader(Value: Boolean);\r\nbegin\r\n CheckNotCompressing;\r\n CheckNotDecompressing;\r\n FCompressHeader := Value;\r\nend;\r\n\r\nprocedure TJcl7zUpdateArchive.SetCompressHeaderFull(Value: Boolean);\r\nbegin\r\n CheckNotCompressing;\r\n CheckNotDecompressing;\r\n FCompressHeaderFull := Value;\r\nend;\r\n\r\nprocedure TJcl7zUpdateArchive.SetCompressionLevel(Value: Cardinal);\r\nbegin\r\n CheckNotCompressing;\r\n CheckNotDecompressing;\r\n if Value <= 9 then\r\n begin\r\n FCompressionLevel := Value;\r\n if Value >= 9 then\r\n FDictionarySize := kLzmaDicSizeX9\r\n else\r\n if Value >= 7 then\r\n FDictionarySize := kLzmaDicSizeX7\r\n else\r\n if Value >= 5 then\r\n FDictionarySize := kLzmaDicSizeX5\r\n else\r\n if Value >= 3 then\r\n FDictionarySize := kLzmaDicSizeX3\r\n else\r\n FDictionarySize := kLzmaDicSizeX1;\r\n end\r\n else\r\n raise EJclCompressionError.CreateRes(@RsCompressionUnavailableProperty);\r\nend;\r\n\r\nprocedure TJcl7zUpdateArchive.SetDictionarySize(Value: Cardinal);\r\nbegin\r\n CheckNotCompressing;\r\n CheckNotDecompressing;\r\n FDictionarySize := Value;\r\nend;\r\n\r\nprocedure TJcl7zUpdateArchive.SetEncryptHeader(Value: Boolean);\r\nbegin\r\n CheckNotCompressing;\r\n CheckNotDecompressing;\r\n FEncryptHeader := Value;\r\nend;\r\n\r\nprocedure TJcl7zUpdateArchive.SetNumberOfThreads(Value: Cardinal);\r\nbegin\r\n CheckNotCompressing;\r\n CheckNotDecompressing;\r\n FNumberOfThreads := Value;\r\nend;\r\n\r\nprocedure TJcl7zUpdateArchive.SetRemoveSfxBlock(Value: Boolean);\r\nbegin\r\n CheckNotCompressing;\r\n CheckNotDecompressing;\r\n FRemoveSfxBlock := Value;\r\nend;\r\n\r\nprocedure TJcl7zUpdateArchive.SetSaveCreationDateTime(Value: Boolean);\r\nbegin\r\n CheckNotCompressing;\r\n CheckNotDecompressing;\r\n FSaveCreationDateTime := Value;\r\nend;\r\n\r\nprocedure TJcl7zUpdateArchive.SetSaveLastAccessDateTime(Value: Boolean);\r\nbegin\r\n CheckNotCompressing;\r\n CheckNotDecompressing;\r\n FSaveLastAccessDateTime := Value;\r\nend;\r\n\r\nprocedure TJcl7zUpdateArchive.SetSaveLastWriteDateTime(Value: Boolean);\r\nbegin\r\n CheckNotCompressing;\r\n CheckNotDecompressing;\r\n FSaveLastWriteDateTime := Value;\r\nend;\r\n\r\n//=== { TJclTarUpdateArchive } ===============================================\r\n\r\nclass function TJclTarUpdateArchive.ArchiveExtensions: string;\r\nbegin\r\n Result := LoadResString(@RsCompressionTarExtensions);\r\nend;\r\n\r\nclass function TJclTarUpdateArchive.ArchiveName: string;\r\nbegin\r\n Result := LoadResString(@RsCompressionTarName);\r\nend;\r\n\r\nclass function TJclTarUpdateArchive.ArchiveCLSID: TGUID;\r\nbegin\r\n Result := CLSID_CFormatTar;\r\nend;\r\n\r\nclass function TJclTarUpdateArchive.MultipleItemContainer: Boolean;\r\nbegin\r\n Result := True;\r\nend;\r\n\r\n//=== { TJclGZipUpdateArchive } ==============================================\r\n\r\nclass function TJclGZipUpdateArchive.ArchiveExtensions: string;\r\nbegin\r\n Result := LoadResString(@RsCompressionGZipExtensions);\r\nend;\r\n\r\nclass function TJclGZipUpdateArchive.ArchiveName: string;\r\nbegin\r\n Result := LoadResString(@RsCompressionGZipName);\r\nend;\r\n\r\nclass function TJclGZipUpdateArchive.ArchiveSubExtensions: string;\r\nbegin\r\n Result := LoadResString(@RsCompressionGZipSubExtensions);\r\nend;\r\n\r\nclass function TJclGZipUpdateArchive.ArchiveCLSID: TGUID;\r\nbegin\r\n Result := CLSID_CFormatGZip;\r\nend;\r\n\r\nfunction TJclGZipUpdateArchive.GetAlgorithm: Cardinal;\r\nbegin\r\n Result := FAlgorithm;\r\nend;\r\n\r\nfunction TJclGZipUpdateArchive.GetCompressionLevel: Cardinal;\r\nbegin\r\n Result := FCompressionLevel;\r\nend;\r\n\r\nfunction TJclGZipUpdateArchive.GetCompressionLevelMax: Cardinal;\r\nbegin\r\n Result := 9;\r\nend;\r\n\r\nfunction TJclGZipUpdateArchive.GetCompressionLevelMin: Cardinal;\r\nbegin\r\n Result := 0;\r\nend;\r\n\r\nfunction TJclGZipUpdateArchive.GetNumberOfPasses: Cardinal;\r\nbegin\r\n Result := FNumberOfPasses;\r\nend;\r\n\r\nfunction TJclGZipUpdateArchive.GetSupportedAlgorithms: TDynCardinalArray;\r\nbegin\r\n SetLength(Result,2);\r\n Result[0] := 0;\r\n Result[1] := 1;\r\nend;\r\n\r\nprocedure TJclGZipUpdateArchive.InitializeArchiveProperties;\r\nbegin\r\n inherited InitializeArchiveProperties;\r\n FCompressionLevel := 7;\r\n FNumberOfPasses := kDeflateNumPassesX7;\r\n FAlgorithm := kLzAlgoX5;\r\nend;\r\n\r\nprocedure TJclGZipUpdateArchive.SetAlgorithm(Value: Cardinal);\r\nbegin\r\n CheckNotCompressing;\r\n CheckNotDecompressing;\r\n FAlgorithm := Value;\r\nend;\r\n\r\nprocedure TJclGZipUpdateArchive.SetCompressionLevel(Value: Cardinal);\r\nbegin\r\n CheckNotCompressing;\r\n CheckNotDecompressing;\r\n if Value <= 9 then\r\n begin\r\n if Value >= 9 then\r\n FNumberOfPasses := kDeflateNumPassesX9\r\n else\r\n if Value >= 7 then\r\n FNumberOfPasses := kDeflateNumPassesX7\r\n else\r\n FNumberOfPasses := kDeflateNumPassesX1;\r\n if Value >= 5 then\r\n FAlgorithm := kLzAlgoX5\r\n else\r\n FAlgorithm := kLzAlgoX1;\r\n end\r\n else\r\n raise EJclCompressionError.CreateRes(@RsCompressionUnavailableProperty);\r\nend;\r\n\r\nprocedure TJclGZipUpdateArchive.SetNumberOfPasses(Value: Cardinal);\r\nbegin\r\n CheckNotCompressing;\r\n CheckNotDecompressing;\r\n FNumberOfPasses := Value;\r\nend;\r\n\r\n//=== { TJclXzUpdateArchive } ================================================\r\n\r\nclass function TJclXzUpdateArchive.ArchiveExtensions: string;\r\nbegin\r\n Result := LoadResString(@RsCompressionXzExtensions);\r\nend;\r\n\r\nclass function TJclXzUpdateArchive.ArchiveName: string;\r\nbegin\r\n Result := LoadResString(@RsCompressionXzExtensions);\r\nend;\r\n\r\nclass function TJclXzUpdateArchive.ArchiveSubExtensions: string;\r\nbegin\r\n Result := LoadResString(@RsCompressionXzSubExtensions);\r\nend;\r\n\r\nclass function TJclXzUpdateArchive.ArchiveCLSID: TGUID;\r\nbegin\r\n Result := CLSID_CFormatXz;\r\nend;\r\n\r\nfunction TJclXzUpdateArchive.GetCompressionMethod: TJclCompressionMethod;\r\nbegin\r\n Result := FCompressionMethod;\r\nend;\r\n\r\nfunction TJclXzUpdateArchive.GetSupportedCompressionMethods: TJclCompressionMethods;\r\nbegin\r\n Result := [cmLZMA2];\r\nend;\r\n\r\nprocedure TJclXzUpdateArchive.InitializeArchiveProperties;\r\nbegin\r\n inherited InitializeArchiveProperties;\r\n FCompressionMethod := cmLZMA2\r\nend;\r\n\r\nprocedure TJclXzUpdateArchive.SetCompressionMethod(\r\n Value: TJclCompressionMethod);\r\nbegin\r\n CheckNotDecompressing;\r\n CheckNotCompressing;\r\n FCompressionMethod := Value;\r\nend;\r\n\r\n//=== { TJclSwfcUpdateArchive } ==============================================\r\n\r\nclass function TJclSwfcUpdateArchive.ArchiveExtensions: string;\r\nbegin\r\n Result := LoadResString(@RsCompressionSwfcExtensions);\r\nend;\r\n\r\nclass function TJclSwfcUpdateArchive.ArchiveName: string;\r\nbegin\r\n Result := LoadResString(@RsCompressionSwfcName);\r\nend;\r\n\r\nclass function TJclSwfcUpdateArchive.ArchiveCLSID: TGUID;\r\nbegin\r\n Result := CLSID_CFormatSwfc;\r\nend;\r\n\r\n{$ENDIF MSWINDOWS}\r\n\r\ninitialization\r\n {$IFDEF UNITVERSIONING}\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n {$ENDIF UNITVERSIONING}\r\n\r\nfinalization\r\n {$IFDEF UNITVERSIONING}\r\n UnregisterUnitVersion(HInstance);\r\n {$ENDIF UNITVERSIONING}\r\n\r\n FreeAndNil(GlobalStreamFormats);\r\n FreeAndNil(GlobalArchiveFormats);\r\n\r\nend.\r\n\r\n" }, { "path": "External/Jedi/Jcl/source/common/JclContainerIntf.pas", "content": "{**************************************************************************************************}\r\n{ WARNING: JEDI preprocessor generated unit. Do not edit. }\r\n{**************************************************************************************************}\r\n\r\n{**************************************************************************************************}\r\n{ }\r\n{ Project JEDI Code Library (JCL) }\r\n{ }\r\n{ The contents of this file are subject to the Mozilla Public License Version 1.1 (the \"License\"); }\r\n{ you may not use this file except in compliance with the License. You may obtain a copy of the }\r\n{ License at http://www.mozilla.org/MPL/ }\r\n{ }\r\n{ Software distributed under the License is distributed on an \"AS IS\" basis, WITHOUT WARRANTY OF }\r\n{ ANY KIND, either express or implied. See the License for the specific language governing rights }\r\n{ and limitations under the License. }\r\n{ }\r\n{ The Original Code is DCL_intf.pas. }\r\n{ }\r\n{ The Initial Developer of the Original Code is Jean-Philippe BEMPEL aka RDM. Portions created by }\r\n{ Jean-Philippe BEMPEL are Copyright (C) Jean-Philippe BEMPEL (rdm_30 att yahoo dott com) }\r\n{ All rights reserved. }\r\n{ }\r\n{ Contributors: }\r\n{ Robert Marquardt (marquardt) }\r\n{ Robert Rossmair (rrossmair) }\r\n{ Florent Ouchet (outchy) }\r\n{ }\r\n{**************************************************************************************************}\r\n{ }\r\n{ The Delphi Container Library }\r\n{ }\r\n{**************************************************************************************************}\r\n{ }\r\n{ Last modified: $Date:: 2012-02-19 22:43:22 +0100 (dim. 19 févr. 2012) $ }\r\n{ Revision: $Rev:: 3735 $ }\r\n{ Author: $Author:: outchy $ }\r\n{ }\r\n{**************************************************************************************************}\r\n\r\nunit JclContainerIntf;\r\n\r\n{$I jcl.inc}\r\n\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n {$IFDEF HAS_UNITSCOPE}\r\n System.Classes,\r\n {$ELSE ~HAS_UNITSCOPE}\r\n Classes,\r\n {$ENDIF ~HAS_UNITSCOPE}\r\n JclBase,\r\n JclAnsiStrings,\r\n JclWideStrings;\r\n\r\n{$IFDEF BCB6}\r\n{$DEFINE BUGGY_DEFAULT_INDEXED_PROP}\r\n{$ENDIF BCB6}\r\n{$IFDEF BCB10}\r\n{$DEFINE BUGGY_DEFAULT_INDEXED_PROP}\r\n{$ENDIF BCB10}\r\n{$IFDEF BCB11}\r\n{$DEFINE BUGGY_DEFAULT_INDEXED_PROP}\r\n{$ENDIF BCB11}\r\n\r\nconst\r\n DefaultContainerCapacity = 16;\r\n\r\ntype\r\n // function pointer types\r\n\r\n // iterate functions Type -> (void)\r\n TIntfIterateProcedure = procedure(const AInterface: IInterface);\r\n TAnsiStrIterateProcedure = procedure(const AString: AnsiString);\r\n TWideStrIterateProcedure = procedure(const AString: WideString);\r\n {$IFDEF SUPPORTS_UNICODE_STRING}\r\n TUnicodeStrIterateProcedure = procedure(const AString: UnicodeString);\r\n {$ENDIF SUPPORTS_UNICODE_STRING}\r\n {$IFDEF CONTAINER_ANSISTR}\r\n TStrIterateProcedure = TAnsiStrIterateProcedure;\r\n {$ENDIF CONTAINER_ANSISTR}\r\n {$IFDEF CONTAINER_WIDESTR}\r\n TStrIterateProcedure = TWideStrIterateProcedure;\r\n {$ENDIF CONTAINER_WIDESTR}\r\n {$IFDEF CONTAINER_UNICODESTR}\r\n TStrIterateProcedure = TUnicodeStrIterateProcedure;\r\n {$ENDIF CONTAINER_UNICODESTR}\r\n TSingleIterateProcedure = procedure(const AValue: Single);\r\n TDoubleIterateProcedure = procedure(const AValue: Double);\r\n TExtendedIterateProcedure = procedure(const AValue: Extended);\r\n {$IFDEF MATH_SINGLE_PRECISION}\r\n TFloatIterateProcedure = TSingleIterateProcedure;\r\n {$ENDIF MATH_SINGLE_PRECISION}\r\n {$IFDEF MATH_DOUBLE_PRECISION}\r\n TFloatIterateProcedure = TDoubleIterateProcedure;\r\n {$ENDIF MATH_DOUBLE_PRECISION}\r\n {$IFDEF MATH_EXTENDED_PRECISION}\r\n TFloatIterateProcedure = TExtendedIterateProcedure;\r\n {$ENDIF MATH_EXTENDED_PRECISION}\r\n TIntegerIterateProcedure = procedure(AValue: Integer);\r\n TCardinalIterateProcedure = procedure(AValue: Cardinal);\r\n TInt64IterateProcedure = procedure(const AValue: Int64);\r\n TPtrIterateProcedure = procedure(APtr: Pointer);\r\n TIterateProcedure = procedure(AObject: TObject);\r\n\r\n {$IFDEF SUPPORTS_GENERICS}\r\n //DOM-IGNORE-BEGIN\r\n TIterateProcedure = procedure(const AItem: T);\r\n //DOM-IGNORE-END\r\n {$ENDIF SUPPORTS_GENERICS}\r\n\r\n // apply functions Type -> Type\r\n TIntfApplyFunction = function(const AInterface: IInterface): IInterface;\r\n TAnsiStrApplyFunction = function(const AString: AnsiString): AnsiString;\r\n TWideStrApplyFunction = function(const AString: WideString): WideString;\r\n {$IFDEF SUPPORTS_UNICODE_STRING}\r\n TUnicodeStrApplyFunction = function(const AString: UnicodeString): UnicodeString;\r\n {$ENDIF SUPPORTS_UNICODE_STRING}\r\n {$IFDEF CONTAINER_ANSISTR}\r\n TStrApplyFunction = TAnsiStrApplyFunction;\r\n {$ENDIF CONTAINER_ANSISTR}\r\n {$IFDEF CONTAINER_WIDESTR}\r\n TStrApplyFunction = TWideStrApplyFunction;\r\n {$ENDIF CONTAINER_WIDESTR}\r\n {$IFDEF CONTAINER_UNICODESTR}\r\n TStrApplyFunction = TUnicodeStrApplyFunction;\r\n {$ENDIF CONTAINER_UNICODESTR}\r\n TSingleApplyFunction = function(const AValue: Single): Single;\r\n TDoubleApplyFunction = function(const AValue: Double): Double;\r\n TExtendedApplyFunction = function(const AValue: Extended): Extended;\r\n {$IFDEF MATH_SINGLE_PRECISION}\r\n TFloatApplyFunction = TSingleApplyFunction;\r\n {$ENDIF MATH_SINGLE_PRECISION}\r\n {$IFDEF MATH_DOUBLE_PRECISION}\r\n TFloatApplyFunction = TDoubleApplyFunction;\r\n {$ENDIF MATH_DOUBLE_PRECISION}\r\n {$IFDEF MATH_EXTENDED_PRECISION}\r\n TFloatApplyFunction = TExtendedApplyFunction;\r\n {$ENDIF MATH_EXTENDED_PRECISION}\r\n TIntegerApplyFunction = function(AValue: Integer): Integer;\r\n TCardinalApplyFunction = function(AValue: Cardinal): Cardinal;\r\n TInt64ApplyFunction = function(const AValue: Int64): Int64;\r\n TPtrApplyFunction = function(APtr: Pointer): Pointer;\r\n TApplyFunction = function(AObject: TObject): TObject;\r\n\r\n {$IFDEF SUPPORTS_GENERICS}\r\n //DOM-IGNORE-BEGIN\r\n TApplyFunction = function(const AItem: T): T;\r\n //DOM-IGNORE-END\r\n {$ENDIF SUPPORTS_GENERICS}\r\n\r\n // comparison functions Type -> Type -> Integer\r\n TIntfCompare = function(const Obj1, Obj2: IInterface): Integer;\r\n TAnsiStrCompare = function(const Obj1, Obj2: AnsiString): Integer;\r\n TWideStrCompare = function(const Obj1, Obj2: WideString): Integer;\r\n {$IFDEF SUPPORTS_UNICODE_STRING}\r\n TUnicodeStrCompare = function(const Obj1, Obj2: UnicodeString): Integer;\r\n {$ENDIF SUPPORTS_UNICODE_STRING}\r\n {$IFDEF CONTAINER_ANSISTR}\r\n TStrCompare = TAnsiStrCompare;\r\n {$ENDIF CONTAINER_ANSISTR}\r\n {$IFDEF CONTAINER_WIDESTR}\r\n TStrCompare = TWideStrCompare;\r\n {$ENDIF CONTAINER_WIDESTR}\r\n {$IFDEF CONTAINER_UNICODESTR}\r\n TStrCompare = TUnicodeStrCompare;\r\n {$ENDIF CONTAINER_UNICODESTR}\r\n TSingleCompare = function(const Obj1, Obj2: Single): Integer;\r\n TDoubleCompare = function(const Obj1, Obj2: Double): Integer;\r\n TExtendedCompare = function(const Obj1, Obj2: Extended): Integer;\r\n {$IFDEF MATH_SINGLE_PRECISION}\r\n TFloatCompare = TSingleCompare;\r\n {$ENDIF MATH_SINGLE_PRECISION}\r\n {$IFDEF MATH_DOUBLE_PRECISION}\r\n TFloatCompare = TDoubleCompare;\r\n {$ENDIF MATH_DOUBLE_PRECISION}\r\n {$IFDEF MATH_EXTENDED_PRECISION}\r\n TFloatCompare = TExtendedCompare;\r\n {$ENDIF MATH_EXTENDED_PRECISION}\r\n TIntegerCompare = function(Obj1, Obj2: Integer): Integer;\r\n TCardinalCompare = function(Obj1, Obj2: Cardinal): Integer;\r\n TInt64Compare = function(const Obj1, Obj2: Int64): Integer;\r\n TPtrCompare = function(Obj1, Obj2: Pointer): Integer;\r\n TCompare = function(Obj1, Obj2: TObject): Integer;\r\n\r\n {$IFDEF SUPPORTS_GENERICS}\r\n //DOM-IGNORE-BEGIN\r\n TCompare = function(const Obj1, Obj2: T): Integer;\r\n //DOM-IGNORE-END\r\n {$ENDIF SUPPORTS_GENERICS}\r\n\r\n // comparison for equality functions Type -> Type -> Boolean\r\n TIntfEqualityCompare = function(const Obj1, Obj2: IInterface): Boolean;\r\n TAnsiStrEqualityCompare = function(const Obj1, Obj2: AnsiString): Boolean;\r\n TWideStrEqualityCompare = function(const Obj1, Obj2: WideString): Boolean;\r\n {$IFDEF SUPPORTS_UNICODE_STRING}\r\n TUnicodeStrEqualityCompare = function(const Obj1, Obj2: UnicodeString): Boolean;\r\n {$ENDIF SUPPORTS_UNICODE_STRING}\r\n {$IFDEF CONTAINER_ANSISTR}\r\n TStrEqualityCompare = TAnsiStrEqualityCompare;\r\n {$ENDIF CONTAINER_ANSISTR}\r\n {$IFDEF CONTAINER_WIDESTR}\r\n TStrEqualityCompare = TWideStrEqualityCompare;\r\n {$ENDIF CONTAINER_WIDESTR}\r\n {$IFDEF CONTAINER_UNICODESTR}\r\n TStrEqualityCompare = TUnicodeStrEqualityCompare;\r\n {$ENDIF CONTAINER_UNICODESTR}\r\n TSingleEqualityCompare = function(const Obj1, Obj2: Single): Boolean;\r\n TDoubleEqualityCompare = function(const Obj1, Obj2: Double): Boolean;\r\n TExtendedEqualityCompare = function(const Obj1, Obj2: Extended): Boolean;\r\n {$IFDEF MATH_SINGLE_PRECISION}\r\n TFloatEqualityCompare = TSingleEqualityCompare;\r\n {$ENDIF MATH_SINGLE_PRECISION}\r\n {$IFDEF MATH_DOUBLE_PRECISION}\r\n TFloatEqualityCompare = TDoubleEqualityCompare;\r\n {$ENDIF MATH_DOUBLE_PRECISION}\r\n {$IFDEF MATH_EXTENDED_PRECISION}\r\n TFloatEqualityCompare = TExtendedEqualityCompare;\r\n {$ENDIF MATH_EXTENDED_PRECISION}\r\n TIntegerEqualityCompare = function(Obj1, Obj2: Integer): Boolean;\r\n TCardinalEqualityCompare = function(Obj1, Obj2: Cardinal): Boolean;\r\n TInt64EqualityCompare = function(const Obj1, Obj2: Int64): Boolean;\r\n TPtrEqualityCompare = function(Obj1, Obj2: Pointer): Boolean;\r\n TEqualityCompare = function(Obj1, Obj2: TObject): Boolean;\r\n\r\n {$IFDEF SUPPORTS_GENERICS}\r\n //DOM-IGNORE-BEGIN\r\n TEqualityCompare = function(const Obj1, Obj2: T): Boolean;\r\n //DOM-IGNORE-END\r\n {$ENDIF SUPPORTS_GENERICS}\r\n\r\n // hash functions Type -> Integer\r\n TIntfHashConvert = function(const AInterface: IInterface): Integer;\r\n TAnsiStrHashConvert = function(const AString: AnsiString): Integer;\r\n TWideStrHashConvert = function(const AString: WideString): Integer;\r\n {$IFDEF SUPPORTS_UNICODE_STRING}\r\n TUnicodeStrHashConvert = function(const AString: UnicodeString): Integer;\r\n {$ENDIF SUPPORTS_UNICODE_STRING}\r\n {$IFDEF CONTAINER_ANSISTR}\r\n TStrHashConvert = TAnsiStrHashConvert;\r\n {$ENDIF CONTAINER_ANSISTR}\r\n {$IFDEF CONTAINER_WIDESTR}\r\n TStrHashConvert = TWideStrHashConvert;\r\n {$ENDIF CONTAINER_WIDESTR}\r\n {$IFDEF CONTAINER_UNICODESTR}\r\n TStrHashConvert = TUnicodeStrHashConvert;\r\n {$ENDIF CONTAINER_UNICODESTR}\r\n TSingleHashConvert = function(const AValue: Single): Integer;\r\n TDoubleHashConvert = function(const AValue: Double): Integer;\r\n TExtendedHashConvert = function(const AValue: Extended): Integer;\r\n {$IFDEF MATH_SINGLE_PRECISION}\r\n TFloatHashConvert = TSingleHashConvert;\r\n {$ENDIF MATH_SINGLE_PRECISION}\r\n {$IFDEF MATH_DOUBLE_PRECISION}\r\n TFloatHashConvert = TDoubleHashConvert;\r\n {$ENDIF MATH_DOUBLE_PRECISION}\r\n {$IFDEF MATH_EXTENDED_PRECISION}\r\n TFloatHashConvert = TExtendedHashConvert;\r\n {$ENDIF MATH_EXTENDED_PRECISION}\r\n TIntegerHashConvert = function(AValue: Integer): Integer;\r\n TCardinalHashConvert = function(AValue: Cardinal): Integer;\r\n TInt64HashConvert = function(const AValue: Int64): Integer;\r\n TPtrHashConvert = function(APtr: Pointer): Integer;\r\n THashConvert = function(AObject: TObject): Integer;\r\n\r\n {$IFDEF SUPPORTS_GENERICS}\r\n //DOM-IGNORE-BEGIN\r\n THashConvert = function(const AItem: T): Integer;\r\n //DOM-IGNORE-END\r\n {$ENDIF SUPPORTS_GENERICS}\r\n\r\n IJclLockable = interface\r\n ['{524AD65E-AE1B-4BC6-91C8-8181F0198BA9}']\r\n procedure ReadLock;\r\n procedure ReadUnlock;\r\n procedure WriteLock;\r\n procedure WriteUnlock;\r\n end;\r\n\r\n IJclAbstractIterator = interface{$IFDEF THREADSAFE}(IJclLockable){$ENDIF THREADSAFE}\r\n ['{1064D0B4-D9FC-475D-88BE-520490013B46}']\r\n procedure Assign(const Source: IJclAbstractIterator);\r\n procedure AssignTo(const Dest: IJclAbstractIterator);\r\n function GetIteratorReference: TObject;\r\n end;\r\n\r\n IJclBaseContainer = interface{$IFDEF THREADSAFE}(IJclLockable){$ENDIF THREADSAFE}\r\n ['{C517175A-028E-486A-BF27-5EF7FC3101D9}']\r\n procedure Assign(const Source: IJclBaseContainer);\r\n procedure AssignTo(const Dest: IJclBaseContainer);\r\n function GetAllowDefaultElements: Boolean;\r\n function GetContainerReference: TObject;\r\n function GetDuplicates: TDuplicates;\r\n function GetReadOnly: Boolean;\r\n function GetRemoveSingleElement: Boolean;\r\n function GetReturnDefaultElements: Boolean;\r\n function GetThreadSafe: Boolean;\r\n procedure SetAllowDefaultElements(Value: Boolean);\r\n procedure SetDuplicates(Value: TDuplicates);\r\n procedure SetReadOnly(Value: Boolean);\r\n procedure SetRemoveSingleElement(Value: Boolean);\r\n procedure SetReturnDefaultElements(Value: Boolean);\r\n procedure SetThreadSafe(Value: Boolean);\r\n property AllowDefaultElements: Boolean read GetAllowDefaultElements write SetAllowDefaultElements;\r\n property Duplicates: TDuplicates read GetDuplicates write SetDuplicates;\r\n property ReadOnly: Boolean read GetReadOnly write SetReadOnly;\r\n property RemoveSingleElement: Boolean read GetRemoveSingleElement write SetRemoveSingleElement;\r\n property ReturnDefaultElements: Boolean read GetReturnDefaultElements write SetReturnDefaultElements;\r\n property ThreadSafe: Boolean read GetThreadSafe write SetThreadSafe;\r\n end;\r\n\r\n IJclIntfContainer = interface(IJclBaseContainer)\r\n ['{44F10075-9702-4DCA-9731-D8990F234A74}']\r\n end;\r\n\r\n IJclIntfFlatContainer = interface(IJclIntfContainer)\r\n ['{15116007-6BB8-4D9D-8249-C2F49D4AB3EA}']\r\n end;\r\n\r\n IJclStrBaseContainer = interface(IJclBaseContainer)\r\n ['{9753E1D7-F093-4D5C-8B32-40403F6F700E}']\r\n function GetCaseSensitive: Boolean;\r\n procedure SetCaseSensitive(Value: Boolean);\r\n property CaseSensitive: Boolean read GetCaseSensitive write SetCaseSensitive;\r\n end;\r\n\r\n TJclAnsiStrEncoding = (seISO, seUTF8);\r\n\r\n IJclAnsiStrContainer = interface(IJclStrBaseContainer)\r\n ['{F8239357-B96F-46F1-A48E-B5DF25B5F1FA}']\r\n function GetEncoding: TJclAnsiStrEncoding;\r\n procedure SetEncoding(Value: TJclAnsiStrEncoding);\r\n property Encoding: TJclAnsiStrEncoding read GetEncoding write SetEncoding;\r\n end;\r\n\r\n IJclAnsiStrFlatContainer = interface(IJclAnsiStrContainer)\r\n ['{8A45A4D4-6317-4CDF-8314-C3E5CC6899F4}']\r\n procedure LoadFromStrings(Strings: TJclAnsiStrings);\r\n procedure SaveToStrings(Strings: TJclAnsiStrings);\r\n procedure AppendToStrings(Strings: TJclAnsiStrings);\r\n procedure AppendFromStrings(Strings: TJclAnsiStrings);\r\n function GetAsStrings: TJclAnsiStrings;\r\n function GetAsDelimited(const Separator: AnsiString = AnsiLineBreak): AnsiString;\r\n procedure AppendDelimited(const AString: AnsiString; const Separator: AnsiString = AnsiLineBreak);\r\n procedure LoadDelimited(const AString: AnsiString; const Separator: AnsiString = AnsiLineBreak);\r\n end;\r\n\r\n TJclWideStrEncoding = (seUTF16);\r\n\r\n IJclWideStrContainer = interface(IJclStrBaseContainer)\r\n ['{875E1AC4-CA22-46BC-8999-048E5B9BF11D}']\r\n function GetEncoding: TJclWideStrEncoding;\r\n procedure SetEncoding(Value: TJclWideStrEncoding);\r\n property Encoding: TJclWideStrEncoding read GetEncoding write SetEncoding;\r\n end;\r\n\r\n IJclWideStrFlatContainer = interface(IJclWideStrContainer)\r\n ['{5B001B93-CA1C-47A8-98B8-451CCB444930}']\r\n procedure LoadFromStrings(Strings: TJclWideStrings);\r\n procedure SaveToStrings(Strings: TJclWideStrings);\r\n procedure AppendToStrings(Strings: TJclWideStrings);\r\n procedure AppendFromStrings(Strings: TJclWideStrings);\r\n function GetAsStrings: TJclWideStrings;\r\n function GetAsDelimited(const Separator: WideString = WideLineBreak): WideString;\r\n procedure AppendDelimited(const AString: WideString; const Separator: WideString = WideLineBreak);\r\n procedure LoadDelimited(const AString: WideString; const Separator: WideString = WideLineBreak);\r\n end;\r\n\r\n {$IFDEF SUPPORTS_UNICODE_STRING}\r\n IJclUnicodeStrContainer = interface(IJclStrBaseContainer)\r\n ['{619BA29F-5E05-464D-B472-1C8453DBC707}']\r\n end;\r\n\r\n IJclUnicodeStrFlatContainer = interface(IJclUnicodeStrContainer)\r\n ['{3343D73E-4ADC-458E-8289-A4B83D1479D1}']\r\n procedure LoadFromStrings(Strings: TJclUnicodeStrings);\r\n procedure SaveToStrings(Strings: TJclUnicodeStrings);\r\n procedure AppendToStrings(Strings: TJclUnicodeStrings);\r\n procedure AppendFromStrings(Strings: TJclUnicodeStrings);\r\n function GetAsStrings: TJclUnicodeStrings;\r\n function GetAsDelimited(const Separator: UnicodeString = WideLineBreak): UnicodeString;\r\n procedure AppendDelimited(const AString: UnicodeString; const Separator: UnicodeString = WideLineBreak);\r\n procedure LoadDelimited(const AString: UnicodeString; const Separator: UnicodeString = WideLineBreak);\r\n end;\r\n {$ENDIF SUPPORTS_UNICODE_STRING}\r\n\r\n {$IFDEF CONTAINER_ANSISTR}\r\n IJclStrContainer = IJclAnsiStrContainer;\r\n IJclStrFlatContainer = IJclAnsiStrFlatContainer;\r\n {$ENDIF CONTAINER_ANSISTR}\r\n {$IFDEF CONTAINER_WIDESTR}\r\n IJclStrContainer = IJclWideStrContainer;\r\n IJclStrFlatContainer = IJclWideStrFlatContainer;\r\n {$ENDIF CONTAINER_WIDESTR}\r\n {$IFDEF CONTAINER_UNICODESTR}\r\n IJclStrContainer = IJclUnicodeStrContainer;\r\n IJclStrFlatContainer = IJclUnicodeStrFlatContainer;\r\n {$ENDIF CONTAINER_UNICODESTR}\r\n\r\n IJclSingleContainer = interface(IJclBaseContainer)\r\n ['{22BE88BD-87D1-4B4D-9FAB-F1B6D555C6A9}']\r\n function GetPrecision: Single;\r\n procedure SetPrecision(const Value: Single);\r\n property Precision: Single read GetPrecision write SetPrecision;\r\n end;\r\n\r\n IJclSingleFlatContainer = interface(IJclSingleContainer)\r\n ['{F16955E8-94D2-4201-809B-CC2EA39B5FDD}']\r\n end;\r\n\r\n IJclDoubleContainer = interface(IJclBaseContainer)\r\n ['{372B9354-DF6D-4CAA-A5A9-C50E1FEE5525}']\r\n function GetPrecision: Double;\r\n procedure SetPrecision(const Value: Double);\r\n property Precision: Double read GetPrecision write SetPrecision;\r\n end;\r\n\r\n IJclDoubleFlatContainer = interface(IJclDoubleContainer)\r\n ['{2F0252CE-7471-45CA-8C8D-FD3925507C00}']\r\n end;\r\n\r\n IJclExtendedContainer = interface(IJclBaseContainer)\r\n ['{431A6482-FD5C-45A7-BE53-339A3CF75AC9}']\r\n function GetPrecision: Extended;\r\n procedure SetPrecision(const Value: Extended);\r\n property Precision: Extended read GetPrecision write SetPrecision;\r\n end;\r\n\r\n IJclExtendedFlatContainer = interface(IJclExtendedContainer)\r\n ['{1D3F48A2-001E-48F7-8A54-B9F4CE837523}']\r\n end;\r\n\r\n {$IFDEF MATH_EXTENDED_PRECISION}\r\n IJclFloatContainer = IJclExtendedContainer;\r\n IJclFloatFlatContainer = IJclExtendedFlatContainer;\r\n {$ENDIF MATH_EXTENDED_PRECISION}\r\n {$IFDEF MATH_DOUBLE_PRECISION}\r\n IJclFloatContainer = IJclDoubleContainer;\r\n IJclFloatFlatContainer = IJclDoubleFlatContainer;\r\n {$ENDIF MATH_DOUBLE_PRECISION}\r\n {$IFDEF MATH_SINGLE_PRECISION}\r\n IJclFloatContainer = IJclSingleContainer;\r\n IJclFloatFlatContainer = IJclSingleFlatContainer;\r\n {$ENDIF MATH_SINGLE_PRECISION}\r\n\r\n IJclIntegerContainer = interface(IJclBaseContainer)\r\n ['{3BAF5447-9835-43A4-9FF3-E5EA7D43A7D1}']\r\n end;\r\n\r\n IJclIntegerFlatContainer = interface(IJclIntegerContainer)\r\n ['{EF4EFCD9-60CB-4525-9D20-18E55291F7CF}']\r\n end;\r\n\r\n IJclCardinalContainer = interface(IJclBaseContainer)\r\n ['{01DF05CF-62E9-46B3-8BC1-2830EEF43644}']\r\n end;\r\n\r\n IJclCardinalFlatContainer = interface(IJclCardinalContainer)\r\n ['{79E48B80-3215-47D0-A1B5-D74C495AC9D1}']\r\n end;\r\n\r\n IJclInt64Container = interface(IJclBaseContainer)\r\n ['{B560B2B6-F8C7-45F0-A5E5-920AA61C1540}']\r\n end;\r\n\r\n IJclInt64FlatContainer = interface(IJclInt64Container)\r\n ['{E740B9EF-7342-4CEF-B7FB-96C5267F5738}']\r\n end;\r\n\r\n IJclPtrContainer = interface(IJclBaseContainer)\r\n ['{E8DD2A85-1E12-4605-B517-7E3121C5624F}']\r\n end;\r\n\r\n IJclPtrFlatContainer = interface(IJclPtrContainer)\r\n ['{43C41789-DE71-4DA5-B4AC-3F53EB9459CD}']\r\n end;\r\n\r\n IJclContainer = interface(IJclBaseContainer)\r\n ['{A9EBED03-4993-426A-8449-30D98DC2AC90}']\r\n end;\r\n\r\n IJclFlatContainer = interface(IJclContainer)\r\n ['{0A070B6F-54A1-4B3D-A4E4-CFFAE2C7C57B}']\r\n end;\r\n\r\n {$IFDEF SUPPORTS_GENERICS}\r\n //DOM-IGNORE-BEGIN\r\n IJclContainer = interface(IJclBaseContainer)\r\n ['{19599A90-F392-430D-878D-A73E096C04AF}']\r\n end;\r\n\r\n IJclFlatContainer = interface(IJclContainer)\r\n ['{F562ECFB-98DC-4A82-A806-ED978B9D1667}']\r\n end;\r\n\r\n //DOM-IGNORE-END\r\n {$ENDIF SUPPORTS_GENERICS}\r\n\r\n IJclIntfEqualityComparer = interface\r\n ['{5CC2DF51-BE56-4D02-A171-31BAAC097632}']\r\n function GetEqualityCompare: TIntfEqualityCompare;\r\n procedure SetEqualityCompare(Value: TIntfEqualityCompare);\r\n function ItemsEqual(const A, B: IInterface): Boolean;\r\n property EqualityCompare: TIntfEqualityCompare read GetEqualityCompare write SetEqualityCompare;\r\n end;\r\n\r\n IJclAnsiStrEqualityComparer = interface\r\n ['{E3DB9016-F0D0-4CE0-B156-4C5DCA47FD3B}']\r\n function GetEqualityCompare: TAnsiStrEqualityCompare;\r\n procedure SetEqualityCompare(Value: TAnsiStrEqualityCompare);\r\n function ItemsEqual(const A, B: AnsiString): Boolean;\r\n property EqualityCompare: TAnsiStrEqualityCompare read GetEqualityCompare write SetEqualityCompare;\r\n end;\r\n\r\n IJclWideStrEqualityComparer = interface\r\n ['{2E5696C9-8374-4347-9DC9-B3722F47F5FB}']\r\n function GetEqualityCompare: TWideStrEqualityCompare;\r\n procedure SetEqualityCompare(Value: TWideStrEqualityCompare);\r\n function ItemsEqual(const A, B: WideString): Boolean;\r\n property EqualityCompare: TWideStrEqualityCompare read GetEqualityCompare write SetEqualityCompare;\r\n end;\r\n\r\n {$IFDEF SUPPORTS_UNICODE_STRING}\r\n IJclUnicodeStrEqualityComparer = interface\r\n ['{EDFCC1C7-79DB-4F58-BD64-5016B44EEAC0}']\r\n function GetEqualityCompare: TUnicodeStrEqualityCompare;\r\n procedure SetEqualityCompare(Value: TUnicodeStrEqualityCompare);\r\n function ItemsEqual(const A, B: UnicodeString): Boolean;\r\n property EqualityCompare: TUnicodeStrEqualityCompare read GetEqualityCompare write SetEqualityCompare;\r\n end;\r\n\r\n {$ENDIF SUPPORTS_UNICODE_STRING}\r\n\r\n {$IFDEF CONTAINER_ANSISTR}\r\n IJclStrEqualityComparer = IJclAnsiStrEqualityComparer;\r\n {$ENDIF CONTAINER_ANSISTR}\r\n {$IFDEF CONTAINER_WIDESTR}\r\n IJclStrEqualityComparer = IJclWideStrEqualityComparer;\r\n {$ENDIF CONTAINER_WIDESTR}\r\n {$IFDEF CONTAINER_UNICODESTR}\r\n IJclStrEqualityComparer = IJclUnicodeStrEqualityComparer;\r\n {$ENDIF CONTAINER_UNICODESTR}\r\n\r\n IJclSingleEqualityComparer = interface\r\n ['{4835BC5B-1A87-4864-BFE1-778F3BAF26B1}']\r\n function GetEqualityCompare: TSingleEqualityCompare;\r\n procedure SetEqualityCompare(Value: TSingleEqualityCompare);\r\n function ItemsEqual(const A, B: Single): Boolean;\r\n property EqualityCompare: TSingleEqualityCompare read GetEqualityCompare write SetEqualityCompare;\r\n end;\r\n\r\n IJclDoubleEqualityComparer = interface\r\n ['{15F0A9F0-D5DC-4978-8CDB-53B6E510262C}']\r\n function GetEqualityCompare: TDoubleEqualityCompare;\r\n procedure SetEqualityCompare(Value: TDoubleEqualityCompare);\r\n function ItemsEqual(const A, B: Double): Boolean;\r\n property EqualityCompare: TDoubleEqualityCompare read GetEqualityCompare write SetEqualityCompare;\r\n end;\r\n\r\n IJclExtendedEqualityComparer = interface\r\n ['{149883D5-4138-4570-8C5C-99F186B7E646}']\r\n function GetEqualityCompare: TExtendedEqualityCompare;\r\n procedure SetEqualityCompare(Value: TExtendedEqualityCompare);\r\n function ItemsEqual(const A, B: Extended): Boolean;\r\n property EqualityCompare: TExtendedEqualityCompare read GetEqualityCompare write SetEqualityCompare;\r\n end;\r\n\r\n {$IFDEF MATH_SINGLE_PRECISION}\r\n IJclFloatEqualityComparer = IJclSingleEqualityComparer;\r\n {$ENDIF MATH_SINGLE_PRECISION}\r\n {$IFDEF MATH_DOUBLE_PRECISION}\r\n IJclFloatEqualityComparer = IJclDoubleEqualityComparer;\r\n {$ENDIF MATH_DOUBLE_PRECISION}\r\n {$IFDEF MATH_EXTENDED_PRECISION}\r\n IJclFloatEqualityComparer = IJclExtendedEqualityComparer;\r\n {$ENDIF MATH_EXTENDED_PRECISION}\r\n\r\n IJclIntegerEqualityComparer = interface\r\n ['{AABC35E6-A779-4A44-B748-27BFCB34FDFB}']\r\n function GetEqualityCompare: TIntegerEqualityCompare;\r\n procedure SetEqualityCompare(Value: TIntegerEqualityCompare);\r\n function ItemsEqual(A, B: Integer): Boolean;\r\n property EqualityCompare: TIntegerEqualityCompare read GetEqualityCompare write SetEqualityCompare;\r\n end;\r\n\r\n IJclCardinalEqualityComparer = interface\r\n ['{B2DECF81-6ECE-4D9F-80E1-C8C884DB407C}']\r\n function GetEqualityCompare: TCardinalEqualityCompare;\r\n procedure SetEqualityCompare(Value: TCardinalEqualityCompare);\r\n function ItemsEqual(A, B: Cardinal): Boolean;\r\n property EqualityCompare: TCardinalEqualityCompare read GetEqualityCompare write SetEqualityCompare;\r\n end;\r\n\r\n IJclInt64EqualityComparer = interface\r\n ['{8B2825E2-0C81-42BA-AC0D-104344CE7E56}']\r\n function GetEqualityCompare: TInt64EqualityCompare;\r\n procedure SetEqualityCompare(Value: TInt64EqualityCompare);\r\n function ItemsEqual(const A, B: Int64): Boolean;\r\n property EqualityCompare: TInt64EqualityCompare read GetEqualityCompare write SetEqualityCompare;\r\n end;\r\n\r\n IJclPtrEqualityComparer = interface\r\n ['{C6B7CBF9-ECD9-4D70-85CC-4E2367A1D806}']\r\n function GetEqualityCompare: TPtrEqualityCompare;\r\n procedure SetEqualityCompare(Value: TPtrEqualityCompare);\r\n function ItemsEqual(A, B: Pointer): Boolean;\r\n property EqualityCompare: TPtrEqualityCompare read GetEqualityCompare write SetEqualityCompare;\r\n end;\r\n\r\n IJclEqualityComparer = interface\r\n ['{82C67986-8365-44AB-8D56-7B0CF4F6B918}']\r\n function GetEqualityCompare: TEqualityCompare;\r\n procedure SetEqualityCompare(Value: TEqualityCompare);\r\n function ItemsEqual(A, B: TObject): Boolean;\r\n property EqualityCompare: TEqualityCompare read GetEqualityCompare write SetEqualityCompare;\r\n end;\r\n\r\n\r\n {$IFDEF SUPPORTS_GENERICS}\r\n //DOM-IGNORE-BEGIN\r\n IJclEqualityComparer = interface\r\n ['{4AF79AD6-D9F4-424B-BEAA-68857F9222B4}']\r\n function GetEqualityCompare: TEqualityCompare;\r\n procedure SetEqualityCompare(Value: TEqualityCompare);\r\n function ItemsEqual(const A, B: T): Boolean;\r\n property EqualityCompare: TEqualityCompare read GetEqualityCompare write SetEqualityCompare;\r\n end;\r\n //DOM-IGNORE-END\r\n {$ENDIF SUPPORTS_GENERICS}\r\n\r\n IJclIntfComparer = interface\r\n ['{EB41B843-184B-420D-B5DA-27D055B4CD55}']\r\n function GetCompare: TIntfCompare;\r\n procedure SetCompare(Value: TIntfCompare);\r\n function ItemsCompare(const A, B: IInterface): Integer;\r\n property Compare: TIntfCompare read GetCompare write SetCompare;\r\n end;\r\n\r\n IJclAnsiStrComparer = interface\r\n ['{09063CBB-9226-4734-B2A0-A178C2343176}']\r\n function GetCompare: TAnsiStrCompare;\r\n procedure SetCompare(Value: TAnsiStrCompare);\r\n function ItemsCompare(const A, B: AnsiString): Integer;\r\n property Compare: TAnsiStrCompare read GetCompare write SetCompare;\r\n end;\r\n\r\n IJclWideStrComparer = interface\r\n ['{7A24AEDA-25B1-4E73-B2E9-5D74011E4C9C}']\r\n function GetCompare: TWideStrCompare;\r\n procedure SetCompare(Value: TWideStrCompare);\r\n function ItemsCompare(const A, B: WideString): Integer;\r\n property Compare: TWideStrCompare read GetCompare write SetCompare;\r\n end;\r\n\r\n {$IFDEF SUPPORTS_UNICODE_STRING}\r\n IJclUnicodeStrComparer = interface\r\n ['{E81E2705-0CA0-4DBD-BECC-5F9AA623A6E4}']\r\n function GetCompare: TUnicodeStrCompare;\r\n procedure SetCompare(Value: TUnicodeStrCompare);\r\n function ItemsCompare(const A, B: UnicodeString): Integer;\r\n property Compare: TUnicodeStrCompare read GetCompare write SetCompare;\r\n end;\r\n {$ENDIF SUPPORTS_UNICODE_STRING}\r\n\r\n {$IFDEF CONTAINER_ANSISTR}\r\n IJclStrComparer = IJclAnsiStrComparer;\r\n {$ENDIF CONTAINER_ANSISTR}\r\n {$IFDEF CONTAINER_WIDESTR}\r\n IJclStrComparer = IJclWideStrComparer;\r\n {$ENDIF CONTAINER_WIDESTR}\r\n {$IFDEF CONTAINER_UNICODESTR}\r\n IJclStrComparer = IJclUnicodeStrComparer;\r\n {$ENDIF CONTAINER_UNICODESTR}\r\n\r\n IJclSingleComparer = interface\r\n ['{008225CE-075E-4450-B9DE-9863CB6D347C}']\r\n function GetCompare: TSingleCompare;\r\n procedure SetCompare(Value: TSingleCompare);\r\n function ItemsCompare(const A, B: Single): Integer;\r\n property Compare: TSingleCompare read GetCompare write SetCompare;\r\n end;\r\n\r\n IJclDoubleComparer = interface\r\n ['{BC245D7F-7EB9-43D0-81B4-EE215486A5AA}']\r\n function GetCompare: TDoubleCompare;\r\n procedure SetCompare(Value: TDoubleCompare);\r\n function ItemsCompare(const A, B: Double): Integer;\r\n property Compare: TDoubleCompare read GetCompare write SetCompare;\r\n end;\r\n\r\n IJclExtendedComparer = interface\r\n ['{92657C66-C18D-4BF8-A538-A3B0140320BB}']\r\n function GetCompare: TExtendedCompare;\r\n procedure SetCompare(Value: TExtendedCompare);\r\n function ItemsCompare(const A, B: Extended): Integer;\r\n property Compare: TExtendedCompare read GetCompare write SetCompare;\r\n end;\r\n\r\n {$IFDEF MATH_SINGLE_PRECISION}\r\n IJclFloatComparer = IJclSingleComparer;\r\n {$ENDIF MATH_SINGLE_PRECISION}\r\n {$IFDEF MATH_DOUBLE_PRECISION}\r\n IJclFloatComparer = IJclDoubleComparer;\r\n {$ENDIF MATH_DOUBLE_PRECISION}\r\n {$IFDEF MATH_EXTENDED_PRECISION}\r\n IJclFloatComparer = IJclExtendedComparer;\r\n {$ENDIF MATH_EXTENDED_PRECISION}\r\n\r\n IJclIntegerComparer = interface\r\n ['{362C3A6A-CBC1-4D5F-8652-158913DC9865}']\r\n function GetCompare: TIntegerCompare;\r\n procedure SetCompare(Value: TIntegerCompare);\r\n function ItemsCompare(A, B: Integer): Integer;\r\n property Compare: TIntegerCompare read GetCompare write SetCompare;\r\n end;\r\n\r\n IJclCardinalComparer = interface\r\n ['{56E44725-00B9-4530-8CC2-72DCA9171EE0}']\r\n function GetCompare: TCardinalCompare;\r\n procedure SetCompare(Value: TCardinalCompare);\r\n function ItemsCompare(A, B: Cardinal): Integer;\r\n property Compare: TCardinalCompare read GetCompare write SetCompare;\r\n end;\r\n\r\n IJclInt64Comparer = interface\r\n ['{87C935BF-3A42-4F1F-A474-9C823939EE1C}']\r\n function GetCompare: TInt64Compare;\r\n procedure SetCompare(Value: TInt64Compare);\r\n function ItemsCompare(const A, B: Int64): Integer;\r\n property Compare: TInt64Compare read GetCompare write SetCompare;\r\n end;\r\n\r\n IJclPtrComparer = interface\r\n ['{85557D4C-A036-477E-BA73-B5EEF43A8696}']\r\n function GetCompare: TPtrCompare;\r\n procedure SetCompare(Value: TPtrCompare);\r\n function ItemsCompare(A, B: Pointer): Integer;\r\n property Compare: TPtrCompare read GetCompare write SetCompare;\r\n end;\r\n\r\n IJclComparer = interface\r\n ['{7B376028-56DC-4C4A-86A9-1AC19E3EDF75}']\r\n function GetCompare: TCompare;\r\n procedure SetCompare(Value: TCompare);\r\n function ItemsCompare(A, B: TObject): Integer;\r\n property Compare: TCompare read GetCompare write SetCompare;\r\n end;\r\n\r\n\r\n {$IFDEF SUPPORTS_GENERICS}\r\n //DOM-IGNORE-BEGIN\r\n IJclComparer = interface\r\n ['{830AFC8C-AA06-46F5-AABD-8EB46B2A9986}']\r\n function GetCompare: TCompare;\r\n procedure SetCompare(Value: TCompare);\r\n function ItemsCompare(const A, B: T): Integer;\r\n property Compare: TCompare read GetCompare write SetCompare;\r\n end;\r\n //DOM-IGNORE-END\r\n {$ENDIF SUPPORTS_GENERICS}\r\n\r\n IJclIntfHashConverter = interface\r\n ['{7BAA0791-3B45-4D0F-9CD8-D13B81694786}']\r\n function GetHashConvert: TIntfHashConvert;\r\n procedure SetHashConvert(Value: TIntfHashConvert);\r\n function Hash(const AInterface: IInterface): Integer;\r\n property HashConvert: TIntfHashConvert read GetHashConvert write SetHashConvert;\r\n end;\r\n\r\n IJclAnsiStrHashConverter = interface\r\n ['{9841014E-8A31-4C79-8AD5-EB03C4E85533}']\r\n function GetHashConvert: TAnsiStrHashConvert;\r\n procedure SetHashConvert(Value: TAnsiStrHashConvert);\r\n function Hash(const AString: AnsiString): Integer;\r\n property HashConvert: TAnsiStrHashConvert read GetHashConvert write SetHashConvert;\r\n end;\r\n\r\n IJclWideStrHashConverter = interface\r\n ['{2584118F-19AE-443E-939B-0DB18BCD0117}']\r\n function GetHashConvert: TWideStrHashConvert;\r\n procedure SetHashConvert(Value: TWideStrHashConvert);\r\n function Hash(const AString: WideString): Integer;\r\n property HashConvert: TWideStrHashConvert read GetHashConvert write SetHashConvert;\r\n end;\r\n\r\n {$IFDEF SUPPORTS_UNICODE_STRING}\r\n IJclUnicodeStrHashConverter = interface\r\n ['{08CD8171-DBAF-405F-9802-46D955C8BBE6}']\r\n function GetHashConvert: TUnicodeStrHashConvert;\r\n procedure SetHashConvert(Value: TUnicodeStrHashConvert);\r\n function Hash(const AString: UnicodeString): Integer;\r\n property HashConvert: TUnicodeStrHashConvert read GetHashConvert write SetHashConvert;\r\n end;\r\n\r\n {$ENDIF SUPPORTS_UNICODE_STRING}\r\n\r\n {$IFDEF CONTAINER_ANSISTR}\r\n IJclStrHashConverter = IJclAnsiStrHashConverter;\r\n {$ENDIF CONTAINER_ANSISTR}\r\n {$IFDEF CONTAINER_WIDESTR}\r\n IJclStrHashConverter = IJclWideStrHashConverter;\r\n {$ENDIF CONTAINER_WIDESTR}\r\n {$IFDEF CONTAINER_UNICODESTR}\r\n IJclStrHashConverter = IJclUnicodeStrHashConverter;\r\n {$ENDIF CONTAINER_UNICODESTR}\r\n\r\n IJclSingleHashConverter = interface\r\n ['{20F0E481-F1D2-48B6-A95D-FBB56AF119F5}']\r\n function GetHashConvert: TSingleHashConvert;\r\n procedure SetHashConvert(Value: TSingleHashConvert);\r\n function Hash(const AValue: Single): Integer;\r\n property HashConvert: TSingleHashConvert read GetHashConvert write SetHashConvert;\r\n end;\r\n\r\n IJclDoubleHashConverter = interface\r\n ['{193A2881-535B-4AF4-B0C3-6845A2800F80}']\r\n function GetHashConvert: TDoubleHashConvert;\r\n procedure SetHashConvert(Value: TDoubleHashConvert);\r\n function Hash(const AValue: Double): Integer;\r\n property HashConvert: TDoubleHashConvert read GetHashConvert write SetHashConvert;\r\n end;\r\n\r\n IJclExtendedHashConverter = interface\r\n ['{77CECDB9-2774-4FDC-8E5A-A80325626434}']\r\n function GetHashConvert: TExtendedHashConvert;\r\n procedure SetHashConvert(Value: TExtendedHashConvert);\r\n function Hash(const AValue: Extended): Integer;\r\n property HashConvert: TExtendedHashConvert read GetHashConvert write SetHashConvert;\r\n end;\r\n\r\n {$IFDEF MATH_SINGLE_PRECISION}\r\n IJclFloatHashConverter = IJclSingleHashConverter;\r\n {$ENDIF MATH_SINGLE_PRECISION}\r\n {$IFDEF MATH_DOUBLE_PRECISION}\r\n IJclFloatHashConverter = IJclDoubleHashConverter;\r\n {$ENDIF MATH_DOUBLE_PRECISION}\r\n {$IFDEF MATH_EXTENDED_PRECISION}\r\n IJclFloatHashConverter = IJclExtendedHashConverter;\r\n {$ENDIF MATH_EXTENDED_PRECISION}\r\n\r\n IJclIntegerHashConverter = interface\r\n ['{92C540B2-C16C-47E4-995A-644BE71878B1}']\r\n function GetHashConvert: TIntegerHashConvert;\r\n procedure SetHashConvert(Value: TIntegerHashConvert);\r\n function Hash(AValue: Integer): Integer;\r\n property HashConvert: TIntegerHashConvert read GetHashConvert write SetHashConvert;\r\n end;\r\n\r\n IJclCardinalHashConverter = interface\r\n ['{2DF04C8A-16B8-4712-BC5D-AD35014EC9F7}']\r\n function GetHashConvert: TCardinalHashConvert;\r\n procedure SetHashConvert(Value: TCardinalHashConvert);\r\n function Hash(AValue: Cardinal): Integer;\r\n property HashConvert: TCardinalHashConvert read GetHashConvert write SetHashConvert;\r\n end;\r\n\r\n IJclInt64HashConverter = interface\r\n ['{96CF2A71-9185-4E26-B283-457ABC3584E7}']\r\n function GetHashConvert: TInt64HashConvert;\r\n procedure SetHashConvert(Value: TInt64HashConvert);\r\n function Hash(const AValue: Int64): Integer;\r\n property HashConvert: TInt64HashConvert read GetHashConvert write SetHashConvert;\r\n end;\r\n\r\n IJclPtrHashConverter = interface\r\n ['{D704CC67-CFED-44E6-9504-65D5E468FCAF}']\r\n function GetHashConvert: TPtrHashConvert;\r\n procedure SetHashConvert(Value: TPtrHashConvert);\r\n function Hash(APtr: Pointer): Integer;\r\n property HashConvert: TPtrHashConvert read GetHashConvert write SetHashConvert;\r\n end;\r\n\r\n IJclHashConverter = interface\r\n ['{2D0DD6F4-162E-41D6-8A34-489E7EACABCD}']\r\n function GetHashConvert: THashConvert;\r\n procedure SetHashConvert(Value: THashConvert);\r\n function Hash(AObject: TObject): Integer;\r\n property HashConvert: THashConvert read GetHashConvert write SetHashConvert;\r\n end;\r\n\r\n\r\n {$IFDEF SUPPORTS_GENERICS}\r\n //DOM-IGNORE-BEGIN\r\n IJclHashConverter = interface\r\n ['{300AEA0E-7433-4C3E-99A6-E533212ACF42}']\r\n function GetHashConvert: THashConvert;\r\n procedure SetHashConvert(Value: THashConvert);\r\n function Hash(const AItem: T): Integer;\r\n property HashConvert: THashConvert read GetHashConvert write SetHashConvert;\r\n end;\r\n //DOM-IGNORE-END\r\n {$ENDIF SUPPORTS_GENERICS}\r\n\r\n IJclIntfCloneable = interface\r\n ['{BCF77740-FB60-4306-9BD1-448AADE5FF4E}']\r\n function IntfClone: IInterface;\r\n end;\r\n\r\n IJclCloneable = interface\r\n ['{D224AE70-2C93-4998-9479-1D513D75F2B2}']\r\n function ObjectClone: TObject;\r\n end;\r\n\r\n TJclAutoPackStrategy = (apsDisabled, apsAgressive, apsProportional, apsIncremental);\r\n\r\n // parameter signification depends on strategy\r\n // - Disabled = unused (arrays are never packed)\r\n // - Agressive = unused (arrays are always packed)\r\n // - Proportional = ratio of empty slots before the array is packed\r\n // number of empty slots is computed by this formula: Capacity div Parameter\r\n // - Incremental = amount of empty slots before the array is packed\r\n\r\n IJclPackable = interface\r\n ['{03802D2B-E0AB-4300-A777-0B8A2BD993DF}']\r\n function CalcGrowCapacity(ACapacity, ASize: Integer): Integer;\r\n function GetAutoPackParameter: Integer;\r\n function GetAutoPackStrategy: TJclAutoPackStrategy;\r\n function GetCapacity: Integer;\r\n procedure Pack; // reduce used memory by eliminating empty storage area (force)\r\n procedure SetAutoPackParameter(Value: Integer);\r\n procedure SetAutoPackStrategy(Value: TJclAutoPackStrategy);\r\n procedure SetCapacity(Value: Integer);\r\n property AutoPackParameter: Integer read GetAutoPackParameter write SetAutoPackParameter;\r\n property AutoPackStrategy: TJclAutoPackStrategy read GetAutoPackStrategy write SetAutoPackStrategy;\r\n property Capacity: Integer read GetCapacity write SetCapacity;\r\n end;\r\n\r\n TJclAutoGrowStrategy = (agsDisabled, agsAgressive, agsProportional, agsIncremental);\r\n\r\n // parameter signification depends on strategy\r\n // - Disabled = unused (arrays never grow)\r\n // - Agressive = unused (arrays always grow by 1 element)\r\n // - Proportional = ratio of empty slots to add to the array\r\n // number of empty slots is computed by this formula: Capacity div Parameter\r\n // - Incremental = amount of empty slots to add to the array\r\n\r\n IJclGrowable = interface(IJclPackable)\r\n ['{C71E8586-5688-444C-9BDD-9969D988123B}']\r\n function CalcPackCapacity(ACapacity, ASize: Integer): Integer;\r\n function GetAutoGrowParameter: Integer;\r\n function GetAutoGrowStrategy: TJclAutoGrowStrategy;\r\n procedure Grow;\r\n procedure SetAutoGrowParameter(Value: Integer);\r\n procedure SetAutoGrowStrategy(Value: TJclAutoGrowStrategy);\r\n property AutoGrowParameter: Integer read GetAutoGrowParameter write SetAutoGrowParameter;\r\n property AutoGrowStrategy: TJclAutoGrowStrategy read GetAutoGrowStrategy write SetAutoGrowStrategy;\r\n end;\r\n\r\n TFreeIntfEvent = function (var AInterface: IInterface): IInterface of object;\r\n\r\n IJclIntfOwner = interface(IInterface)\r\n ['{17C1D3FB-BB32-48F2-BD1C-D43EA05A86A8}']\r\n function GetOnFreeObject: TFreeIntfEvent;\r\n function FreeObject(var AInterface: IInterface): IInterface;\r\n procedure SetOnFreeObject(Value: TFreeIntfEvent);\r\n property OnFreeObject: TFreeIntfEvent read GetOnFreeObject write SetOnFreeObject;\r\n end;\r\n\r\n TFreeAnsiStrEvent = function (var AString: AnsiString): AnsiString of object;\r\n\r\n IJclAnsiStrOwner = interface(IInterface)\r\n ['{4F64F1F6-766A-4CFA-B51B-654116E308A8}']\r\n function GetOnFreeString: TFreeAnsiStrEvent;\r\n function FreeString(var AString: AnsiString): AnsiString;\r\n procedure SetOnFreeString(Value: TFreeAnsiStrEvent);\r\n property OnFreeString: TFreeAnsiStrEvent read GetOnFreeString write SetOnFreeString;\r\n end;\r\n\r\n TFreeWideStrEvent = function (var AString: WideString): WideString of object;\r\n\r\n IJclWideStrOwner = interface(IInterface)\r\n ['{282B7A64-BCD0-4EAE-8776-4EF92D7E3D8B}']\r\n function GetOnFreeString: TFreeWideStrEvent;\r\n function FreeString(var AString: WideString): WideString;\r\n procedure SetOnFreeString(Value: TFreeWideStrEvent);\r\n property OnFreeString: TFreeWideStrEvent read GetOnFreeString write SetOnFreeString;\r\n end;\r\n\r\n {$IFDEF SUPPORTS_UNICODE_STRING}\r\n TFreeUnicodeStrEvent = function (var AString: UnicodeString): UnicodeString of object;\r\n\r\n {$ENDIF SUPPORTS_UNICODE_STRING}\r\n\r\n {$IFDEF SUPPORTS_UNICODE_STRING}\r\n IJclUnicodeStrOwner = interface(IInterface)\r\n ['{07F402E6-DD97-4AA4-83D8-4CCD419FCCFC}']\r\n function GetOnFreeString: TFreeUnicodeStrEvent;\r\n function FreeString(var AString: UnicodeString): UnicodeString;\r\n procedure SetOnFreeString(Value: TFreeUnicodeStrEvent);\r\n property OnFreeString: TFreeUnicodeStrEvent read GetOnFreeString write SetOnFreeString;\r\n end;\r\n\r\n {$ENDIF SUPPORTS_UNICODE_STRING}\r\n\r\n {$IFDEF CONTAINER_ANSISTR}\r\n TFreeStrEvent = TFreeAnsiStrEvent;\r\n {$ENDIF CONTAINER_ANSISTR}\r\n {$IFDEF CONTAINER_WIDESTR}\r\n TFreeStrEvent = TFreeWideStrEvent;\r\n {$ENDIF CONTAINER_WIDESTR}\r\n {$IFDEF CONTAINER_UNICODESTR}\r\n TFreeStrEvent = TFreeUnicodeStrEvent;\r\n {$ENDIF CONTAINER_UNICODESTR}\r\n\r\n {$IFDEF CONTAINER_ANSISTR}\r\n IJclStrOwner = IJclAnsiStrOwner;\r\n {$ENDIF CONTAINER_ANSISTR}\r\n {$IFDEF CONTAINER_WIDESTR}\r\n IJclStrOwner = IJclWideStrOwner;\r\n {$ENDIF CONTAINER_WIDESTR}\r\n {$IFDEF CONTAINER_UNICODESTR}\r\n IJclStrOwner = IJclUnicodeStrOwner;\r\n {$ENDIF CONTAINER_UNICODESTR}\r\n\r\n TFreeSingleEvent = function (var AValue: Single): Single of object;\r\n\r\n IJclSingleOwner = interface(IInterface)\r\n ['{B002C201-70D7-4FA8-B44A-6D18E82580E5}']\r\n function GetOnFreeSingle: TFreeSingleEvent;\r\n function FreeSingle(var AValue: Single): Single;\r\n procedure SetOnFreeSingle(Value: TFreeSingleEvent);\r\n property OnFreeSingle: TFreeSingleEvent read GetOnFreeSingle write SetOnFreeSingle;\r\n end;\r\n\r\n TFreeDoubleEvent = function (var AValue: Double): Double of object;\r\n\r\n IJclDoubleOwner = interface(IInterface)\r\n ['{3BEFEDB0-C904-4400-ABEF-40FC928BB258}']\r\n function GetOnFreeDouble: TFreeDoubleEvent;\r\n function FreeDouble(var AValue: Double): Double;\r\n procedure SetOnFreeDouble(Value: TFreeDoubleEvent);\r\n property OnFreeDouble: TFreeDoubleEvent read GetOnFreeDouble write SetOnFreeDouble;\r\n end;\r\n\r\n TFreeExtendedEvent = function (var AValue: Extended): Extended of object;\r\n\r\n IJclExtendedOwner = interface(IInterface)\r\n ['{4501B203-6784-479D-8A8E-FBE3E1249CCF}']\r\n function GetOnFreeExtended: TFreeExtendedEvent;\r\n function FreeExtended(var AValue: Extended): Extended;\r\n procedure SetOnFreeExtended(Value: TFreeExtendedEvent);\r\n property OnFreeExtended: TFreeExtendedEvent read GetOnFreeExtended write SetOnFreeExtended;\r\n end;\r\n\r\n {$IFDEF MATH_SINGLE_PRECISION}\r\n TFreeFloatEvent = TFreeSingleEvent;\r\n {$ENDIF MATH_SINGLE_PRECISION}\r\n {$IFDEF MATH_DOUBLE_PRECISION}\r\n TFreeFloatEvent = TFreeDoubleEvent;\r\n {$ENDIF MATH_DOUBLE_PRECISION}\r\n {$IFDEF MATH_EXTENDED_PRECISION}\r\n TFreeFloatEvent = TFreeExtendedEvent;\r\n {$ENDIF MATH_EXTENDED_PRECISION}\r\n\r\n {$IFDEF MATH_SINGLE_PRECISION}\r\n IJclFloatOwner = IJclSingleOwner;\r\n {$ENDIF MATH_SINGLE_PRECISION}\r\n {$IFDEF MATH_DOUBLE_PRECISION}\r\n IJclFloatOwner = IJclDoubleOwner;\r\n {$ENDIF MATH_DOUBLE_PRECISION}\r\n {$IFDEF MATH_EXTENDED_PRECISION}\r\n IJclFloatOwner = IJclExtendedOwner;\r\n {$ENDIF MATH_EXTENDED_PRECISION}\r\n\r\n TFreeIntegerEvent = function (var AValue: Integer): Integer of object;\r\n\r\n IJclIntegerOwner = interface(IInterface)\r\n ['{00E37ECB-0FF0-4833-8143-EB7FBEF9E208}']\r\n function GetOnFreeInteger: TFreeIntegerEvent;\r\n function FreeInteger(var AValue: Integer): Integer;\r\n procedure SetOnFreeInteger(Value: TFreeIntegerEvent);\r\n property OnFreeInteger: TFreeIntegerEvent read GetOnFreeInteger write SetOnFreeInteger;\r\n end;\r\n\r\n TFreeCardinalEvent = function (var AValue: Cardinal): Cardinal of object;\r\n\r\n IJclCardinalOwner = interface(IInterface)\r\n ['{27B3EDEF-0ACD-4592-95F2-52A1DF5E7A39}']\r\n function GetOnFreeCardinal: TFreeCardinalEvent;\r\n function FreeCardinal(var AValue: Cardinal): Cardinal;\r\n procedure SetOnFreeCardinal(Value: TFreeCardinalEvent);\r\n property OnFreeCardinal: TFreeCardinalEvent read GetOnFreeCardinal write SetOnFreeCardinal;\r\n end;\r\n\r\n TFreeInt64Event = function (var AValue: Int64): Int64 of object;\r\n\r\n IJclInt64Owner = interface(IInterface)\r\n ['{7D4A1375-057A-42B8-8DAA-52DE30058864}']\r\n function GetOnFreeInt64: TFreeInt64Event;\r\n function FreeInt64(var AValue: Int64): Int64;\r\n procedure SetOnFreeInt64(Value: TFreeInt64Event);\r\n property OnFreeInt64: TFreeInt64Event read GetOnFreeInt64 write SetOnFreeInt64;\r\n end;\r\n\r\n TFreePtrEvent = function (var APtr: Pointer): Pointer of object;\r\n\r\n IJclPtrOwner = interface(IInterface)\r\n ['{28340328-34AD-4632-9BAC-A7387A822200}']\r\n function GetOnFreePointer: TFreePtrEvent;\r\n function FreePointer(var APtr: Pointer): Pointer;\r\n procedure SetOnFreePointer(Value: TFreePtrEvent);\r\n property OnFreePointer: TFreePtrEvent read GetOnFreePointer write SetOnFreePointer;\r\n end;\r\n\r\n TFreeObjectEvent = function (var AObject: TObject): TObject of object;\r\n\r\n IJclObjectOwner = interface(IInterface)\r\n ['{5157EA13-924E-4A56-995D-36956441025C}']\r\n function GetOnFreeObject: TFreeObjectEvent;\r\n function FreeObject(var AObject: TObject): TObject;\r\n procedure SetOnFreeObject(Value: TFreeObjectEvent);\r\n property OnFreeObject: TFreeObjectEvent read GetOnFreeObject write SetOnFreeObject;\r\n function GetOwnsObjects: Boolean;\r\n property OwnsObjects: Boolean read GetOwnsObjects;\r\n end;\r\n\r\n\r\n\r\n IJclKeyOwner = interface\r\n ['{8BE209E6-2F85-44FD-B0CD-A8363C95349A}']\r\n function FreeKey(var Key: TObject): TObject;\r\n function GetOwnsKeys: Boolean;\r\n property OwnsKeys: Boolean read GetOwnsKeys;\r\n end;\r\n\r\n IJclValueOwner = interface\r\n ['{3BCD98CE-7056-416A-A9E7-AE3AB2A62E54}']\r\n function FreeValue(var Value: TObject): TObject;\r\n function GetOwnsValues: Boolean;\r\n property OwnsValues: Boolean read GetOwnsValues;\r\n end;\r\n\r\n {$IFDEF SUPPORTS_GENERICS}\r\n //DOM-IGNORE-BEGIN\r\n\r\n TFreeItemEvent = function (var AItem: T): T of object;\r\n\r\n IJclItemOwner = interface(IInterface)\r\n ['{0CC220C1-E705-4B21-9F53-4AD340952165}']\r\n function GetOnFreeItem: TFreeItemEvent;\r\n function FreeItem(var AItem: T): T;\r\n procedure SetOnFreeItem(Value: TFreeItemEvent);\r\n property OnFreeItem: TFreeItemEvent read GetOnFreeItem write SetOnFreeItem;\r\n\r\n function GetOwnsItems: Boolean;\r\n property OwnsItems: Boolean read GetOwnsItems;\r\n end;\r\n\r\n IJclPairOwner = interface\r\n ['{321C1FF7-AA2E-4229-966A-7EC6417EA16D}']\r\n function FreeKey(var Key: TKey): TKey;\r\n function FreeValue(var Value: TValue): TValue;\r\n function GetOwnsKeys: Boolean;\r\n function GetOwnsValues: Boolean;\r\n property OwnsKeys: Boolean read GetOwnsKeys;\r\n property OwnsValues: Boolean read GetOwnsValues;\r\n end;\r\n\r\n //DOM-IGNORE-END\r\n {$ENDIF SUPPORTS_GENERICS}\r\n\r\n IJclIntfIterator = interface(IJclAbstractIterator)\r\n ['{E121A98A-7C43-4587-806B-9189E8B2F106}']\r\n function Add(const AInterface: IInterface): Boolean;\r\n procedure Extract;\r\n function GetObject: IInterface;\r\n function HasNext: Boolean;\r\n function HasPrevious: Boolean;\r\n function Insert(const AInterface: IInterface): Boolean;\r\n function IteratorEquals(const AIterator: IJclIntfIterator): Boolean;\r\n function Next: IInterface;\r\n function NextIndex: Integer;\r\n function Previous: IInterface;\r\n function PreviousIndex: Integer;\r\n procedure Remove;\r\n procedure Reset;\r\n procedure SetObject(const AInterface: IInterface);\r\n {$IFDEF SUPPORTS_FOR_IN}\r\n function MoveNext: Boolean;\r\n property Current: IInterface read GetObject;\r\n {$ENDIF SUPPORTS_FOR_IN}\r\n end;\r\n\r\n IJclAnsiStrIterator = interface(IJclAbstractIterator)\r\n ['{D5D4B681-F902-49C7-B9E1-73007C9D64F0}']\r\n function Add(const AString: AnsiString): Boolean;\r\n procedure Extract;\r\n function GetString: AnsiString;\r\n function HasNext: Boolean;\r\n function HasPrevious: Boolean;\r\n function Insert(const AString: AnsiString): Boolean;\r\n function IteratorEquals(const AIterator: IJclAnsiStrIterator): Boolean;\r\n function Next: AnsiString;\r\n function NextIndex: Integer;\r\n function Previous: AnsiString;\r\n function PreviousIndex: Integer;\r\n procedure Remove;\r\n procedure Reset;\r\n procedure SetString(const AString: AnsiString);\r\n {$IFDEF SUPPORTS_FOR_IN}\r\n function MoveNext: Boolean;\r\n property Current: AnsiString read GetString;\r\n {$ENDIF SUPPORTS_FOR_IN}\r\n end;\r\n\r\n IJclWideStrIterator = interface(IJclAbstractIterator)\r\n ['{F03BC7D4-CCDA-4C4A-AF3A-E51FDCDE8ADE}']\r\n function Add(const AString: WideString): Boolean;\r\n procedure Extract;\r\n function GetString: WideString;\r\n function HasNext: Boolean;\r\n function HasPrevious: Boolean;\r\n function Insert(const AString: WideString): Boolean;\r\n function IteratorEquals(const AIterator: IJclWideStrIterator): Boolean;\r\n function Next: WideString;\r\n function NextIndex: Integer;\r\n function Previous: WideString;\r\n function PreviousIndex: Integer;\r\n procedure Remove;\r\n procedure Reset;\r\n procedure SetString(const AString: WideString);\r\n {$IFDEF SUPPORTS_FOR_IN}\r\n function MoveNext: Boolean;\r\n property Current: WideString read GetString;\r\n {$ENDIF SUPPORTS_FOR_IN}\r\n end;\r\n\r\n {$IFDEF SUPPORTS_UNICODE_STRING}\r\n IJclUnicodeStrIterator = interface(IJclAbstractIterator)\r\n ['{B913FFDC-792A-48FB-B58E-763EFDEBA15C}']\r\n function Add(const AString: UnicodeString): Boolean;\r\n procedure Extract;\r\n function GetString: UnicodeString;\r\n function HasNext: Boolean;\r\n function HasPrevious: Boolean;\r\n function Insert(const AString: UnicodeString): Boolean;\r\n function IteratorEquals(const AIterator: IJclUnicodeStrIterator): Boolean;\r\n function Next: UnicodeString;\r\n function NextIndex: Integer;\r\n function Previous: UnicodeString;\r\n function PreviousIndex: Integer;\r\n procedure Remove;\r\n procedure Reset;\r\n procedure SetString(const AString: UnicodeString);\r\n {$IFDEF SUPPORTS_FOR_IN}\r\n function MoveNext: Boolean;\r\n property Current: UnicodeString read GetString;\r\n {$ENDIF SUPPORTS_FOR_IN}\r\n end;\r\n {$ENDIF SUPPORTS_UNICODE_STRING}\r\n\r\n {$IFDEF CONTAINER_ANSISTR}\r\n IJclStrIterator = IJclAnsiStrIterator;\r\n {$ENDIF CONTAINER_ANSISTR}\r\n {$IFDEF CONTAINER_WIDESTR}\r\n IJclStrIterator = IJclWideStrIterator;\r\n {$ENDIF CONTAINER_WIDESTR}\r\n {$IFDEF CONTAINER_UNICODESTR}\r\n IJclStrIterator = IJclUnicodeStrIterator;\r\n {$ENDIF CONTAINER_UNICODESTR}\r\n\r\n IJclSingleIterator = interface(IJclAbstractIterator)\r\n ['{FD1124F8-CB2B-4AD7-B12D-C05702F4204B}']\r\n function Add(const AValue: Single): Boolean;\r\n procedure Extract;\r\n function GetValue: Single;\r\n function HasNext: Boolean;\r\n function HasPrevious: Boolean;\r\n function Insert(const AValue: Single): Boolean;\r\n function IteratorEquals(const AIterator: IJclSingleIterator): Boolean;\r\n function Next: Single;\r\n function NextIndex: Integer;\r\n function Previous: Single;\r\n function PreviousIndex: Integer;\r\n procedure Remove;\r\n procedure Reset;\r\n procedure SetValue(const AValue: Single);\r\n {$IFDEF SUPPORTS_FOR_IN}\r\n function MoveNext: Boolean;\r\n property Current: Single read GetValue;\r\n {$ENDIF SUPPORTS_FOR_IN}\r\n end;\r\n\r\n IJclDoubleIterator = interface(IJclAbstractIterator)\r\n ['{004C154A-281C-4DA7-BF64-F3EE80ACF640}']\r\n function Add(const AValue: Double): Boolean;\r\n procedure Extract;\r\n function GetValue: Double;\r\n function HasNext: Boolean;\r\n function HasPrevious: Boolean;\r\n function Insert(const AValue: Double): Boolean;\r\n function IteratorEquals(const AIterator: IJclDoubleIterator): Boolean;\r\n function Next: Double;\r\n function NextIndex: Integer;\r\n function Previous: Double;\r\n function PreviousIndex: Integer;\r\n procedure Remove;\r\n procedure Reset;\r\n procedure SetValue(const AValue: Double);\r\n {$IFDEF SUPPORTS_FOR_IN}\r\n function MoveNext: Boolean;\r\n property Current: Double read GetValue;\r\n {$ENDIF SUPPORTS_FOR_IN}\r\n end;\r\n\r\n IJclExtendedIterator = interface(IJclAbstractIterator)\r\n ['{B89877A5-DED4-4CD9-AB90-C7D062111DE0}']\r\n function Add(const AValue: Extended): Boolean;\r\n procedure Extract;\r\n function GetValue: Extended;\r\n function HasNext: Boolean;\r\n function HasPrevious: Boolean;\r\n function Insert(const AValue: Extended): Boolean;\r\n function IteratorEquals(const AIterator: IJclExtendedIterator): Boolean;\r\n function Next: Extended;\r\n function NextIndex: Integer;\r\n function Previous: Extended;\r\n function PreviousIndex: Integer;\r\n procedure Remove;\r\n procedure Reset;\r\n procedure SetValue(const AValue: Extended);\r\n {$IFDEF SUPPORTS_FOR_IN}\r\n function MoveNext: Boolean;\r\n property Current: Extended read GetValue;\r\n {$ENDIF SUPPORTS_FOR_IN}\r\n end;\r\n\r\n {$IFDEF MATH_SINGLE_PRECISION}\r\n IJclFloatIterator = IJclSingleIterator;\r\n {$ENDIF MATH_SINGLE_PRECISION}\r\n {$IFDEF MATH_DOUBLE_PRECISION}\r\n IJclFloatIterator = IJclDoubleIterator;\r\n {$ENDIF MATH_DOUBLE_PRECISION}\r\n {$IFDEF MATH_EXTENDED_PRECISION}\r\n IJclFloatIterator = IJclExtendedIterator;\r\n {$ENDIF MATH_EXTENDED_PRECISION}\r\n\r\n IJclIntegerIterator = interface(IJclAbstractIterator)\r\n ['{1406A991-4574-48A1-83FE-2EDCA03908BE}']\r\n function Add(AValue: Integer): Boolean;\r\n procedure Extract;\r\n function GetValue: Integer;\r\n function HasNext: Boolean;\r\n function HasPrevious: Boolean;\r\n function Insert(AValue: Integer): Boolean;\r\n function IteratorEquals(const AIterator: IJclIntegerIterator): Boolean;\r\n function Next: Integer;\r\n function NextIndex: Integer;\r\n function Previous: Integer;\r\n function PreviousIndex: Integer;\r\n procedure Remove;\r\n procedure Reset;\r\n procedure SetValue(AValue: Integer);\r\n {$IFDEF SUPPORTS_FOR_IN}\r\n function MoveNext: Boolean;\r\n property Current: Integer read GetValue;\r\n {$ENDIF SUPPORTS_FOR_IN}\r\n end;\r\n\r\n IJclCardinalIterator = interface(IJclAbstractIterator)\r\n ['{72847A34-C8C4-4592-9447-CEB8161E33AD}']\r\n function Add(AValue: Cardinal): Boolean;\r\n procedure Extract;\r\n function GetValue: Cardinal;\r\n function HasNext: Boolean;\r\n function HasPrevious: Boolean;\r\n function Insert(AValue: Cardinal): Boolean;\r\n function IteratorEquals(const AIterator: IJclCardinalIterator): Boolean;\r\n function Next: Cardinal;\r\n function NextIndex: Integer;\r\n function Previous: Cardinal;\r\n function PreviousIndex: Integer;\r\n procedure Remove;\r\n procedure Reset;\r\n procedure SetValue(AValue: Cardinal);\r\n {$IFDEF SUPPORTS_FOR_IN}\r\n function MoveNext: Boolean;\r\n property Current: Cardinal read GetValue;\r\n {$ENDIF SUPPORTS_FOR_IN}\r\n end;\r\n\r\n IJclInt64Iterator = interface(IJclAbstractIterator)\r\n ['{573E5A51-BF76-43D7-9F93-46305BED20A8}']\r\n function Add(const AValue: Int64): Boolean;\r\n procedure Extract;\r\n function GetValue: Int64;\r\n function HasNext: Boolean;\r\n function HasPrevious: Boolean;\r\n function Insert(const AValue: Int64): Boolean;\r\n function IteratorEquals(const AIterator: IJclInt64Iterator): Boolean;\r\n function Next: Int64;\r\n function NextIndex: Integer;\r\n function Previous: Int64;\r\n function PreviousIndex: Integer;\r\n procedure Remove;\r\n procedure Reset;\r\n procedure SetValue(const AValue: Int64);\r\n {$IFDEF SUPPORTS_FOR_IN}\r\n function MoveNext: Boolean;\r\n property Current: Int64 read GetValue;\r\n {$ENDIF SUPPORTS_FOR_IN}\r\n end;\r\n\r\n IJclPtrIterator = interface(IJclAbstractIterator)\r\n ['{62B5501C-07AA-4D00-A85B-713B39912CDF}']\r\n function Add(APtr: Pointer): Boolean;\r\n procedure Extract;\r\n function GetPointer: Pointer;\r\n function HasNext: Boolean;\r\n function HasPrevious: Boolean;\r\n function Insert(APtr: Pointer): Boolean;\r\n function IteratorEquals(const AIterator: IJclPtrIterator): Boolean;\r\n function Next: Pointer;\r\n function NextIndex: Integer;\r\n function Previous: Pointer;\r\n function PreviousIndex: Integer;\r\n procedure Remove;\r\n procedure Reset;\r\n procedure SetPointer(APtr: Pointer);\r\n {$IFDEF SUPPORTS_FOR_IN}\r\n function MoveNext: Boolean;\r\n property Current: Pointer read GetPointer;\r\n {$ENDIF SUPPORTS_FOR_IN}\r\n end;\r\n\r\n IJclIterator = interface(IJclAbstractIterator)\r\n ['{997DF9B7-9AA2-4239-8B94-14DFFD26D790}']\r\n function Add(AObject: TObject): Boolean;\r\n procedure Extract;\r\n function GetObject: TObject;\r\n function HasNext: Boolean;\r\n function HasPrevious: Boolean;\r\n function Insert(AObject: TObject): Boolean;\r\n function IteratorEquals(const AIterator: IJclIterator): Boolean;\r\n function Next: TObject;\r\n function NextIndex: Integer;\r\n function Previous: TObject;\r\n function PreviousIndex: Integer;\r\n procedure Remove;\r\n procedure Reset;\r\n procedure SetObject(AObject: TObject);\r\n {$IFDEF SUPPORTS_FOR_IN}\r\n function MoveNext: Boolean;\r\n property Current: TObject read GetObject;\r\n {$ENDIF SUPPORTS_FOR_IN}\r\n end;\r\n\r\n\r\n {$IFDEF SUPPORTS_GENERICS}\r\n //DOM-IGNORE-BEGIN\r\n IJclIterator = interface(IJclAbstractIterator)\r\n ['{6E8547A4-5B5D-4831-8AE3-9C6D04071B11}']\r\n function Add(const AItem: T): Boolean;\r\n procedure Extract;\r\n function GetItem: T;\r\n function HasNext: Boolean;\r\n function HasPrevious: Boolean;\r\n function Insert(const AItem: T): Boolean;\r\n function IteratorEquals(const AIterator: IJclIterator): Boolean;\r\n function Next: T;\r\n function NextIndex: Integer;\r\n function Previous: T;\r\n function PreviousIndex: Integer;\r\n procedure Remove;\r\n procedure Reset;\r\n procedure SetItem(const AItem: T);\r\n {$IFDEF SUPPORTS_FOR_IN}\r\n function MoveNext: Boolean;\r\n property Current: T read GetItem;\r\n {$ENDIF SUPPORTS_FOR_IN}\r\n end;\r\n //DOM-IGNORE-END\r\n {$ENDIF SUPPORTS_GENERICS}\r\n\r\n IJclIntfTreeIterator = interface(IJclIntfIterator)\r\n ['{C97379BF-C6A9-4A90-9D7A-152E9BAD314F}']\r\n function AddChild(const AInterface: IInterface): Boolean;\r\n function ChildrenCount: Integer;\r\n procedure DeleteChild(Index: Integer);\r\n procedure DeleteChildren;\r\n procedure ExtractChild(Index: Integer);\r\n procedure ExtractChildren;\r\n function GetChild(Index: Integer): IInterface;\r\n function HasChild(Index: Integer): Boolean;\r\n function HasParent: Boolean;\r\n function IndexOfChild(const AInterface: IInterface): Integer;\r\n function InsertChild(Index: Integer; const AInterface: IInterface): Boolean;\r\n function Parent: IInterface;\r\n procedure SetChild(Index: Integer; const AInterface: IInterface);\r\n property Children[Index: Integer]: IInterface read GetChild write SetChild;\r\n end;\r\n\r\n IJclAnsiStrTreeIterator = interface(IJclAnsiStrIterator)\r\n ['{66BC5C76-758C-4E72-ABF1-EB02CF851C6D}']\r\n function AddChild(const AString: AnsiString): Boolean;\r\n function ChildrenCount: Integer;\r\n procedure DeleteChild(Index: Integer);\r\n procedure DeleteChildren;\r\n procedure ExtractChild(Index: Integer);\r\n procedure ExtractChildren;\r\n function GetChild(Index: Integer): AnsiString;\r\n function HasChild(Index: Integer): Boolean;\r\n function HasParent: Boolean;\r\n function IndexOfChild(const AString: AnsiString): Integer;\r\n function InsertChild(Index: Integer; const AString: AnsiString): Boolean;\r\n function Parent: AnsiString;\r\n procedure SetChild(Index: Integer; const AString: AnsiString);\r\n property Children[Index: Integer]: AnsiString read GetChild write SetChild;\r\n end;\r\n\r\n IJclWideStrTreeIterator = interface(IJclWideStrIterator)\r\n ['{B3168A3B-5A90-4ABF-855F-3D2B3AB6EE7F}']\r\n function AddChild(const AString: WideString): Boolean;\r\n function ChildrenCount: Integer;\r\n procedure DeleteChild(Index: Integer);\r\n procedure DeleteChildren;\r\n procedure ExtractChild(Index: Integer);\r\n procedure ExtractChildren;\r\n function GetChild(Index: Integer): WideString;\r\n function HasChild(Index: Integer): Boolean;\r\n function HasParent: Boolean;\r\n function IndexOfChild(const AString: WideString): Integer;\r\n function InsertChild(Index: Integer; const AString: WideString): Boolean;\r\n function Parent: WideString;\r\n procedure SetChild(Index: Integer; const AString: WideString);\r\n property Children[Index: Integer]: WideString read GetChild write SetChild;\r\n end;\r\n\r\n {$IFDEF SUPPORTS_UNICODE_STRING}\r\n IJclUnicodeStrTreeIterator = interface(IJclUnicodeStrIterator)\r\n ['{0B0A60DE-0403-4EE1-B1F0-10D849924CF8}']\r\n function AddChild(const AString: UnicodeString): Boolean;\r\n function ChildrenCount: Integer;\r\n procedure DeleteChild(Index: Integer);\r\n procedure DeleteChildren;\r\n procedure ExtractChild(Index: Integer);\r\n procedure ExtractChildren;\r\n function GetChild(Index: Integer): UnicodeString;\r\n function HasChild(Index: Integer): Boolean;\r\n function HasParent: Boolean;\r\n function IndexOfChild(const AString: UnicodeString): Integer;\r\n function InsertChild(Index: Integer; const AString: UnicodeString): Boolean;\r\n function Parent: UnicodeString;\r\n procedure SetChild(Index: Integer; const AString: UnicodeString);\r\n property Children[Index: Integer]: UnicodeString read GetChild write SetChild;\r\n end;\r\n {$ENDIF SUPPORTS_UNICODE_STRING}\r\n\r\n {$IFDEF CONTAINER_ANSISTR}\r\n IJclStrTreeIterator = IJclAnsiStrTreeIterator;\r\n {$ENDIF CONTAINER_ANSISTR}\r\n {$IFDEF CONTAINER_WIDESTR}\r\n IJclStrTreeIterator = IJclWideStrTreeIterator;\r\n {$ENDIF CONTAINER_WIDESTR}\r\n {$IFDEF CONTAINER_UNICODESTR}\r\n IJclStrTreeIterator = IJclUnicodeStrTreeIterator;\r\n {$ENDIF CONTAINER_UNICODESTR}\r\n\r\n IJclSingleTreeIterator = interface(IJclSingleIterator)\r\n ['{17BFDE9D-DBF7-4DC8-AC74-919C717B4726}']\r\n function AddChild(const AValue: Single): Boolean;\r\n function ChildrenCount: Integer;\r\n procedure DeleteChild(Index: Integer);\r\n procedure DeleteChildren;\r\n procedure ExtractChild(Index: Integer);\r\n procedure ExtractChildren;\r\n function GetChild(Index: Integer): Single;\r\n function HasChild(Index: Integer): Boolean;\r\n function HasParent: Boolean;\r\n function IndexOfChild(const AValue: Single): Integer;\r\n function InsertChild(Index: Integer; const AValue: Single): Boolean;\r\n function Parent: Single;\r\n procedure SetChild(Index: Integer; const AValue: Single);\r\n property Children[Index: Integer]: Single read GetChild write SetChild;\r\n end;\r\n\r\n IJclDoubleTreeIterator = interface(IJclDoubleIterator)\r\n ['{EB39B84E-D3C5-496E-A521-B8BF24579252}']\r\n function AddChild(const AValue: Double): Boolean;\r\n function ChildrenCount: Integer;\r\n procedure DeleteChild(Index: Integer);\r\n procedure DeleteChildren;\r\n procedure ExtractChild(Index: Integer);\r\n procedure ExtractChildren;\r\n function GetChild(Index: Integer): Double;\r\n function HasChild(Index: Integer): Boolean;\r\n function HasParent: Boolean;\r\n function IndexOfChild(const AValue: Double): Integer;\r\n function InsertChild(Index: Integer; const AValue: Double): Boolean;\r\n function Parent: Double;\r\n procedure SetChild(Index: Integer; const AValue: Double);\r\n property Children[Index: Integer]: Double read GetChild write SetChild;\r\n end;\r\n\r\n IJclExtendedTreeIterator = interface(IJclExtendedIterator)\r\n ['{1B40A544-FC5D-454C-8E42-CE17B015E65C}']\r\n function AddChild(const AValue: Extended): Boolean;\r\n function ChildrenCount: Integer;\r\n procedure DeleteChild(Index: Integer);\r\n procedure DeleteChildren;\r\n procedure ExtractChild(Index: Integer);\r\n procedure ExtractChildren;\r\n function GetChild(Index: Integer): Extended;\r\n function HasChild(Index: Integer): Boolean;\r\n function HasParent: Boolean;\r\n function IndexOfChild(const AValue: Extended): Integer;\r\n function InsertChild(Index: Integer; const AValue: Extended): Boolean;\r\n function Parent: Extended;\r\n procedure SetChild(Index: Integer; const AValue: Extended);\r\n property Children[Index: Integer]: Extended read GetChild write SetChild;\r\n end;\r\n\r\n {$IFDEF MATH_SINGLE_PRECISION}\r\n IJclFloatTreeIterator = IJclSingleTreeIterator;\r\n {$ENDIF MATH_SINGLE_PRECISION}\r\n {$IFDEF MATH_DOUBLE_PRECISION}\r\n IJclFloatTreeIterator = IJclDoubleTreeIterator;\r\n {$ENDIF MATH_DOUBLE_PRECISION}\r\n {$IFDEF MATH_EXTENDED_PRECISION}\r\n IJclFloatTreeIterator = IJclExtendedTreeIterator;\r\n {$ENDIF MATH_EXTENDED_PRECISION}\r\n\r\n IJclIntegerTreeIterator = interface(IJclIntegerIterator)\r\n ['{88EDC5C5-CA41-41AF-9838-AA19D07E69F5}']\r\n function AddChild(AValue: Integer): Boolean;\r\n function ChildrenCount: Integer;\r\n procedure DeleteChild(Index: Integer);\r\n procedure DeleteChildren;\r\n procedure ExtractChild(Index: Integer);\r\n procedure ExtractChildren;\r\n function GetChild(Index: Integer): Integer;\r\n function HasChild(Index: Integer): Boolean;\r\n function HasParent: Boolean;\r\n function IndexOfChild(AValue: Integer): Integer;\r\n function InsertChild(Index: Integer; AValue: Integer): Boolean;\r\n function Parent: Integer;\r\n procedure SetChild(Index: Integer; AValue: Integer);\r\n property Children[Index: Integer]: Integer read GetChild write SetChild;\r\n end;\r\n\r\n IJclCardinalTreeIterator = interface(IJclCardinalIterator)\r\n ['{FDBF493F-F79D-46EB-A59D-7193B6E6A860}']\r\n function AddChild(AValue: Cardinal): Boolean;\r\n function ChildrenCount: Integer;\r\n procedure DeleteChild(Index: Integer);\r\n procedure DeleteChildren;\r\n procedure ExtractChild(Index: Integer);\r\n procedure ExtractChildren;\r\n function GetChild(Index: Integer): Cardinal;\r\n function HasChild(Index: Integer): Boolean;\r\n function HasParent: Boolean;\r\n function IndexOfChild(AValue: Cardinal): Integer;\r\n function InsertChild(Index: Integer; AValue: Cardinal): Boolean;\r\n function Parent: Cardinal;\r\n procedure SetChild(Index: Integer; AValue: Cardinal);\r\n property Children[Index: Integer]: Cardinal read GetChild write SetChild;\r\n end;\r\n\r\n IJclInt64TreeIterator = interface(IJclInt64Iterator)\r\n ['{C5A5E504-E19B-43AC-90B9-E4B8984BFA23}']\r\n function AddChild(const AValue: Int64): Boolean;\r\n function ChildrenCount: Integer;\r\n procedure DeleteChild(Index: Integer);\r\n procedure DeleteChildren;\r\n procedure ExtractChild(Index: Integer);\r\n procedure ExtractChildren;\r\n function GetChild(Index: Integer): Int64;\r\n function HasChild(Index: Integer): Boolean;\r\n function HasParent: Boolean;\r\n function IndexOfChild(const AValue: Int64): Integer;\r\n function InsertChild(Index: Integer; const AValue: Int64): Boolean;\r\n function Parent: Int64;\r\n procedure SetChild(Index: Integer; const AValue: Int64);\r\n property Children[Index: Integer]: Int64 read GetChild write SetChild;\r\n end;\r\n\r\n IJclPtrTreeIterator = interface(IJclPtrIterator)\r\n ['{ED4C08E6-60FC-4ED3-BD19-E6605B9BD943}']\r\n function AddChild(APtr: Pointer): Boolean;\r\n function ChildrenCount: Integer;\r\n procedure DeleteChild(Index: Integer);\r\n procedure DeleteChildren;\r\n procedure ExtractChild(Index: Integer);\r\n procedure ExtractChildren;\r\n function GetChild(Index: Integer): Pointer;\r\n function HasChild(Index: Integer): Boolean;\r\n function HasParent: Boolean;\r\n function IndexOfChild(APtr: Pointer): Integer;\r\n function InsertChild(Index: Integer; APtr: Pointer): Boolean;\r\n function Parent: Pointer;\r\n procedure SetChild(Index: Integer; APtr: Pointer);\r\n property Children[Index: Integer]: Pointer read GetChild write SetChild;\r\n end;\r\n\r\n IJclTreeIterator = interface(IJclIterator)\r\n ['{8B4863B0-B6B9-426E-B5B8-7AF71D264237}']\r\n function AddChild(AObject: TObject): Boolean;\r\n function ChildrenCount: Integer;\r\n procedure DeleteChild(Index: Integer);\r\n procedure DeleteChildren;\r\n procedure ExtractChild(Index: Integer);\r\n procedure ExtractChildren;\r\n function GetChild(Index: Integer): TObject;\r\n function HasChild(Index: Integer): Boolean;\r\n function HasParent: Boolean;\r\n function IndexOfChild(AObject: TObject): Integer;\r\n function InsertChild(Index: Integer; AObject: TObject): Boolean;\r\n function Parent: TObject;\r\n procedure SetChild(Index: Integer; AObject: TObject);\r\n property Children[Index: Integer]: TObject read GetChild write SetChild;\r\n end;\r\n\r\n\r\n {$IFDEF SUPPORTS_GENERICS}\r\n //DOM-IGNORE-BEGIN\r\n IJclTreeIterator = interface(IJclIterator)\r\n ['{29A06DA4-D93A-40A5-8581-0FE85BC8384B}']\r\n function AddChild(const AItem: T): Boolean;\r\n function ChildrenCount: Integer;\r\n procedure DeleteChild(Index: Integer);\r\n procedure DeleteChildren;\r\n procedure ExtractChild(Index: Integer);\r\n procedure ExtractChildren;\r\n function GetChild(Index: Integer): T;\r\n function HasChild(Index: Integer): Boolean;\r\n function HasParent: Boolean;\r\n function IndexOfChild(const AItem: T): Integer;\r\n function InsertChild(Index: Integer; const AItem: T): Boolean;\r\n function Parent: T;\r\n procedure SetChild(Index: Integer; const AItem: T);\r\n property Children[Index: Integer]: T read GetChild write SetChild;\r\n end;\r\n //DOM-IGNORE-END\r\n {$ENDIF SUPPORTS_GENERICS}\r\n\r\n IJclIntfBinaryTreeIterator = interface(IJclIntfTreeIterator)\r\n ['{8BE874B2-0075-4EE0-8F49-665FC894D923}']\r\n function HasLeft: Boolean;\r\n function HasRight: Boolean;\r\n function Left: IInterface;\r\n function Right: IInterface;\r\n end;\r\n\r\n IJclAnsiStrBinaryTreeIterator = interface(IJclAnsiStrTreeIterator)\r\n ['{34A4A300-042C-43A9-AC23-8FC1B76BFB25}']\r\n function HasLeft: Boolean;\r\n function HasRight: Boolean;\r\n function Left: AnsiString;\r\n function Right: AnsiString;\r\n end;\r\n\r\n IJclWideStrBinaryTreeIterator = interface(IJclWideStrTreeIterator)\r\n ['{17C08EB9-6880-469E-878A-8F5EBFE905B1}']\r\n function HasLeft: Boolean;\r\n function HasRight: Boolean;\r\n function Left: WideString;\r\n function Right: WideString;\r\n end;\r\n\r\n {$IFDEF SUPPORTS_UNICODE_STRING}\r\n IJclUnicodeStrBinaryTreeIterator = interface(IJclUnicodeStrTreeIterator)\r\n ['{CA32B126-AD4B-4C33-BC47-52B09FE093BE}']\r\n function HasLeft: Boolean;\r\n function HasRight: Boolean;\r\n function Left: UnicodeString;\r\n function Right: UnicodeString;\r\n end;\r\n {$ENDIF SUPPORTS_UNICODE_STRING}\r\n\r\n {$IFDEF CONTAINER_ANSISTR}\r\n IJclStrBinaryTreeIterator = IJclAnsiStrBinaryTreeIterator;\r\n {$ENDIF CONTAINER_ANSISTR}\r\n {$IFDEF CONTAINER_WIDESTR}\r\n IJclStrBinaryTreeIterator = IJclWideStrBinaryTreeIterator;\r\n {$ENDIF CONTAINER_WIDESTR}\r\n {$IFDEF CONTAINER_UNICODESTR}\r\n IJclStrBinaryTreeIterator = IJclUnicodeStrBinaryTreeIterator;\r\n {$ENDIF CONTAINER_UNICODESTR}\r\n\r\n IJclSingleBinaryTreeIterator = interface(IJclSingleTreeIterator)\r\n ['{BC6FFB13-FA1C-4077-8273-F25A3119168B}']\r\n function HasLeft: Boolean;\r\n function HasRight: Boolean;\r\n function Left: Single;\r\n function Right: Single;\r\n end;\r\n\r\n IJclDoubleBinaryTreeIterator = interface(IJclDoubleTreeIterator)\r\n ['{CE48083C-D60C-4315-BC14-8CE77AC3269E}']\r\n function HasLeft: Boolean;\r\n function HasRight: Boolean;\r\n function Left: Double;\r\n function Right: Double;\r\n end;\r\n\r\n IJclExtendedBinaryTreeIterator = interface(IJclExtendedTreeIterator)\r\n ['{8A9FAE2A-5EF5-4165-8E8D-51F2102A4580}']\r\n function HasLeft: Boolean;\r\n function HasRight: Boolean;\r\n function Left: Extended;\r\n function Right: Extended;\r\n end;\r\n\r\n {$IFDEF MATH_SINGLE_PRECISION}\r\n IJclFloatBinaryTreeIterator = IJclSingleBinaryTreeIterator;\r\n {$ENDIF MATH_SINGLE_PRECISION}\r\n {$IFDEF MATH_DOUBLE_PRECISION}\r\n IJclFloatBinaryTreeIterator = IJclDoubleBinaryTreeIterator;\r\n {$ENDIF MATH_DOUBLE_PRECISION}\r\n {$IFDEF MATH_EXTENDED_PRECISION}\r\n IJclFloatBinaryTreeIterator = IJclExtendedBinaryTreeIterator;\r\n {$ENDIF MATH_EXTENDED_PRECISION}\r\n\r\n IJclIntegerBinaryTreeIterator = interface(IJclIntegerTreeIterator)\r\n ['{FE2BF57D-D10D-4B0C-903D-BB61700FBA0A}']\r\n function HasLeft: Boolean;\r\n function HasRight: Boolean;\r\n function Left: Integer;\r\n function Right: Integer;\r\n end;\r\n\r\n IJclCardinalBinaryTreeIterator = interface(IJclCardinalTreeIterator)\r\n ['{AAA358F5-95A1-480F-8E2A-09028BA6C397}']\r\n function HasLeft: Boolean;\r\n function HasRight: Boolean;\r\n function Left: Cardinal;\r\n function Right: Cardinal;\r\n end;\r\n\r\n IJclInt64BinaryTreeIterator = interface(IJclInt64TreeIterator)\r\n ['{5605E164-5CDD-40B1-9323-DE1CB584E289}']\r\n function HasLeft: Boolean;\r\n function HasRight: Boolean;\r\n function Left: Int64;\r\n function Right: Int64;\r\n end;\r\n\r\n IJclPtrBinaryTreeIterator = interface(IJclPtrTreeIterator)\r\n ['{75D3DF0D-C491-43F7-B078-E658197E8051}']\r\n function HasLeft: Boolean;\r\n function HasRight: Boolean;\r\n function Left: Pointer;\r\n function Right: Pointer;\r\n end;\r\n\r\n IJclBinaryTreeIterator = interface(IJclTreeIterator)\r\n ['{821DE28D-631C-4F23-A0B2-CC0F35B4C64D}']\r\n function HasLeft: Boolean;\r\n function HasRight: Boolean;\r\n function Left: TObject;\r\n function Right: TObject;\r\n end;\r\n\r\n\r\n {$IFDEF SUPPORTS_GENERICS}\r\n //DOM-IGNORE-BEGIN\r\n IJclBinaryTreeIterator = interface(IJclTreeIterator)\r\n ['{0CF5B0FC-C644-458C-BF48-2E093DAFEC26}']\r\n function HasLeft: Boolean;\r\n function HasRight: Boolean;\r\n function Left: T;\r\n function Right: T;\r\n end;\r\n //DOM-IGNORE-END\r\n {$ENDIF SUPPORTS_GENERICS}\r\n\r\n IJclIntfCollection = interface(IJclIntfFlatContainer)\r\n ['{8E178463-4575-487A-B4D5-DC2AED3C7ACA}']\r\n function Add(const AInterface: IInterface): Boolean;\r\n function AddAll(const ACollection: IJclIntfCollection): Boolean;\r\n procedure Clear;\r\n function Contains(const AInterface: IInterface): Boolean;\r\n function ContainsAll(const ACollection: IJclIntfCollection): Boolean;\r\n function CollectionEquals(const ACollection: IJclIntfCollection): Boolean;\r\n function Extract(const AInterface: IInterface): Boolean;\r\n function ExtractAll(const ACollection: IJclIntfCollection): Boolean;\r\n function First: IJclIntfIterator;\r\n function IsEmpty: Boolean;\r\n function Last: IJclIntfIterator;\r\n function Remove(const AInterface: IInterface): Boolean;\r\n function RemoveAll(const ACollection: IJclIntfCollection): Boolean;\r\n function RetainAll(const ACollection: IJclIntfCollection): Boolean;\r\n function Size: Integer;\r\n {$IFDEF SUPPORTS_FOR_IN}\r\n function GetEnumerator: IJclIntfIterator;\r\n {$ENDIF SUPPORTS_FOR_IN}\r\n end;\r\n\r\n IJclAnsiStrCollection = interface(IJclAnsiStrFlatContainer)\r\n ['{3E3CFC19-E8AF-4DD7-91FA-2DF2895FC7B9}']\r\n function Add(const AString: AnsiString): Boolean;\r\n function AddAll(const ACollection: IJclAnsiStrCollection): Boolean;\r\n procedure Clear;\r\n function Contains(const AString: AnsiString): Boolean;\r\n function ContainsAll(const ACollection: IJclAnsiStrCollection): Boolean;\r\n function CollectionEquals(const ACollection: IJclAnsiStrCollection): Boolean;\r\n function Extract(const AString: AnsiString): Boolean;\r\n function ExtractAll(const ACollection: IJclAnsiStrCollection): Boolean;\r\n function First: IJclAnsiStrIterator;\r\n function IsEmpty: Boolean;\r\n function Last: IJclAnsiStrIterator;\r\n function Remove(const AString: AnsiString): Boolean;\r\n function RemoveAll(const ACollection: IJclAnsiStrCollection): Boolean;\r\n function RetainAll(const ACollection: IJclAnsiStrCollection): Boolean;\r\n function Size: Integer;\r\n {$IFDEF SUPPORTS_FOR_IN}\r\n function GetEnumerator: IJclAnsiStrIterator;\r\n {$ENDIF SUPPORTS_FOR_IN}\r\n end;\r\n\r\n IJclWideStrCollection = interface(IJclWideStrFlatContainer)\r\n ['{CDCC0F94-4DD0-4F25-B441-6AE55D5C7466}']\r\n function Add(const AString: WideString): Boolean;\r\n function AddAll(const ACollection: IJclWideStrCollection): Boolean;\r\n procedure Clear;\r\n function Contains(const AString: WideString): Boolean;\r\n function ContainsAll(const ACollection: IJclWideStrCollection): Boolean;\r\n function CollectionEquals(const ACollection: IJclWideStrCollection): Boolean;\r\n function Extract(const AString: WideString): Boolean;\r\n function ExtractAll(const ACollection: IJclWideStrCollection): Boolean;\r\n function First: IJclWideStrIterator;\r\n function IsEmpty: Boolean;\r\n function Last: IJclWideStrIterator;\r\n function Remove(const AString: WideString): Boolean;\r\n function RemoveAll(const ACollection: IJclWideStrCollection): Boolean;\r\n function RetainAll(const ACollection: IJclWideStrCollection): Boolean;\r\n function Size: Integer;\r\n {$IFDEF SUPPORTS_FOR_IN}\r\n function GetEnumerator: IJclWideStrIterator;\r\n {$ENDIF SUPPORTS_FOR_IN}\r\n end;\r\n\r\n {$IFDEF SUPPORTS_UNICODE_STRING}\r\n IJclUnicodeStrCollection = interface(IJclUnicodeStrFlatContainer)\r\n ['{82EA7DDE-4EBF-4E0D-A380-CAF8A24C1A0D}']\r\n function Add(const AString: UnicodeString): Boolean;\r\n function AddAll(const ACollection: IJclUnicodeStrCollection): Boolean;\r\n procedure Clear;\r\n function Contains(const AString: UnicodeString): Boolean;\r\n function ContainsAll(const ACollection: IJclUnicodeStrCollection): Boolean;\r\n function CollectionEquals(const ACollection: IJclUnicodeStrCollection): Boolean;\r\n function Extract(const AString: UnicodeString): Boolean;\r\n function ExtractAll(const ACollection: IJclUnicodeStrCollection): Boolean;\r\n function First: IJclUnicodeStrIterator;\r\n function IsEmpty: Boolean;\r\n function Last: IJclUnicodeStrIterator;\r\n function Remove(const AString: UnicodeString): Boolean;\r\n function RemoveAll(const ACollection: IJclUnicodeStrCollection): Boolean;\r\n function RetainAll(const ACollection: IJclUnicodeStrCollection): Boolean;\r\n function Size: Integer;\r\n {$IFDEF SUPPORTS_FOR_IN}\r\n function GetEnumerator: IJclUnicodeStrIterator;\r\n {$ENDIF SUPPORTS_FOR_IN}\r\n end;\r\n {$ENDIF SUPPORTS_UNICODE_STRING}\r\n\r\n {$IFDEF CONTAINER_ANSISTR}\r\n IJclStrCollection = IJclAnsiStrCollection;\r\n {$ENDIF CONTAINER_ANSISTR}\r\n {$IFDEF CONTAINER_WIDESTR}\r\n IJclStrCollection = IJclWideStrCollection;\r\n {$ENDIF CONTAINER_WIDESTR}\r\n {$IFDEF CONTAINER_UNICODESTR}\r\n IJclStrCollection = IJclUnicodeStrCollection;\r\n {$ENDIF CONTAINER_UNICODESTR}\r\n\r\n IJclSingleCollection = interface(IJclSingleFlatContainer)\r\n ['{1D34D474-6588-441E-B2B3-8C021A37ED89}']\r\n function Add(const AValue: Single): Boolean;\r\n function AddAll(const ACollection: IJclSingleCollection): Boolean;\r\n procedure Clear;\r\n function Contains(const AValue: Single): Boolean;\r\n function ContainsAll(const ACollection: IJclSingleCollection): Boolean;\r\n function CollectionEquals(const ACollection: IJclSingleCollection): Boolean;\r\n function Extract(const AValue: Single): Boolean;\r\n function ExtractAll(const ACollection: IJclSingleCollection): Boolean;\r\n function First: IJclSingleIterator;\r\n function IsEmpty: Boolean;\r\n function Last: IJclSingleIterator;\r\n function Remove(const AValue: Single): Boolean;\r\n function RemoveAll(const ACollection: IJclSingleCollection): Boolean;\r\n function RetainAll(const ACollection: IJclSingleCollection): Boolean;\r\n function Size: Integer;\r\n {$IFDEF SUPPORTS_FOR_IN}\r\n function GetEnumerator: IJclSingleIterator;\r\n {$ENDIF SUPPORTS_FOR_IN}\r\n end;\r\n\r\n IJclDoubleCollection = interface(IJclDoubleFlatContainer)\r\n ['{E54C7717-C33A-4F1B-860C-4F60F303EAD3}']\r\n function Add(const AValue: Double): Boolean;\r\n function AddAll(const ACollection: IJclDoubleCollection): Boolean;\r\n procedure Clear;\r\n function Contains(const AValue: Double): Boolean;\r\n function ContainsAll(const ACollection: IJclDoubleCollection): Boolean;\r\n function CollectionEquals(const ACollection: IJclDoubleCollection): Boolean;\r\n function Extract(const AValue: Double): Boolean;\r\n function ExtractAll(const ACollection: IJclDoubleCollection): Boolean;\r\n function First: IJclDoubleIterator;\r\n function IsEmpty: Boolean;\r\n function Last: IJclDoubleIterator;\r\n function Remove(const AValue: Double): Boolean;\r\n function RemoveAll(const ACollection: IJclDoubleCollection): Boolean;\r\n function RetainAll(const ACollection: IJclDoubleCollection): Boolean;\r\n function Size: Integer;\r\n {$IFDEF SUPPORTS_FOR_IN}\r\n function GetEnumerator: IJclDoubleIterator;\r\n {$ENDIF SUPPORTS_FOR_IN}\r\n end;\r\n\r\n IJclExtendedCollection = interface(IJclExtendedFlatContainer)\r\n ['{2A1341CB-B997-4E3B-B1CA-6D60AE853C55}']\r\n function Add(const AValue: Extended): Boolean;\r\n function AddAll(const ACollection: IJclExtendedCollection): Boolean;\r\n procedure Clear;\r\n function Contains(const AValue: Extended): Boolean;\r\n function ContainsAll(const ACollection: IJclExtendedCollection): Boolean;\r\n function CollectionEquals(const ACollection: IJclExtendedCollection): Boolean;\r\n function Extract(const AValue: Extended): Boolean;\r\n function ExtractAll(const ACollection: IJclExtendedCollection): Boolean;\r\n function First: IJclExtendedIterator;\r\n function IsEmpty: Boolean;\r\n function Last: IJclExtendedIterator;\r\n function Remove(const AValue: Extended): Boolean;\r\n function RemoveAll(const ACollection: IJclExtendedCollection): Boolean;\r\n function RetainAll(const ACollection: IJclExtendedCollection): Boolean;\r\n function Size: Integer;\r\n {$IFDEF SUPPORTS_FOR_IN}\r\n function GetEnumerator: IJclExtendedIterator;\r\n {$ENDIF SUPPORTS_FOR_IN}\r\n end;\r\n\r\n {$IFDEF MATH_SINGLE_PRECISION}\r\n IJclFloatCollection = IJclSingleCollection;\r\n {$ENDIF MATH_SINGLE_PRECISION}\r\n {$IFDEF MATH_DOUBLE_PRECISION}\r\n IJclFloatCollection = IJclDoubleCollection;\r\n {$ENDIF MATH_DOUBLE_PRECISION}\r\n {$IFDEF MATH_EXTENDED_PRECISION}\r\n IJclFloatCollection = IJclExtendedCollection;\r\n {$ENDIF MATH_EXTENDED_PRECISION}\r\n\r\n IJclIntegerCollection = interface(IJclIntegerFlatContainer)\r\n ['{AF69890D-22D1-4D89-8FFD-5FAD7E0638BA}']\r\n function Add(AValue: Integer): Boolean;\r\n function AddAll(const ACollection: IJclIntegerCollection): Boolean;\r\n procedure Clear;\r\n function Contains(AValue: Integer): Boolean;\r\n function ContainsAll(const ACollection: IJclIntegerCollection): Boolean;\r\n function CollectionEquals(const ACollection: IJclIntegerCollection): Boolean;\r\n function Extract(AValue: Integer): Boolean;\r\n function ExtractAll(const ACollection: IJclIntegerCollection): Boolean;\r\n function First: IJclIntegerIterator;\r\n function IsEmpty: Boolean;\r\n function Last: IJclIntegerIterator;\r\n function Remove(AValue: Integer): Boolean;\r\n function RemoveAll(const ACollection: IJclIntegerCollection): Boolean;\r\n function RetainAll(const ACollection: IJclIntegerCollection): Boolean;\r\n function Size: Integer;\r\n {$IFDEF SUPPORTS_FOR_IN}\r\n function GetEnumerator: IJclIntegerIterator;\r\n {$ENDIF SUPPORTS_FOR_IN}\r\n end;\r\n\r\n IJclCardinalCollection = interface(IJclCardinalFlatContainer)\r\n ['{CFBD0344-58C8-4FA2-B4D7-D21D77DFBF80}']\r\n function Add(AValue: Cardinal): Boolean;\r\n function AddAll(const ACollection: IJclCardinalCollection): Boolean;\r\n procedure Clear;\r\n function Contains(AValue: Cardinal): Boolean;\r\n function ContainsAll(const ACollection: IJclCardinalCollection): Boolean;\r\n function CollectionEquals(const ACollection: IJclCardinalCollection): Boolean;\r\n function Extract(AValue: Cardinal): Boolean;\r\n function ExtractAll(const ACollection: IJclCardinalCollection): Boolean;\r\n function First: IJclCardinalIterator;\r\n function IsEmpty: Boolean;\r\n function Last: IJclCardinalIterator;\r\n function Remove(AValue: Cardinal): Boolean;\r\n function RemoveAll(const ACollection: IJclCardinalCollection): Boolean;\r\n function RetainAll(const ACollection: IJclCardinalCollection): Boolean;\r\n function Size: Integer;\r\n {$IFDEF SUPPORTS_FOR_IN}\r\n function GetEnumerator: IJclCardinalIterator;\r\n {$ENDIF SUPPORTS_FOR_IN}\r\n end;\r\n\r\n IJclInt64Collection = interface(IJclInt64FlatContainer)\r\n ['{93A45BDE-3C4C-48D6-9874-5322914DFDDA}']\r\n function Add(const AValue: Int64): Boolean;\r\n function AddAll(const ACollection: IJclInt64Collection): Boolean;\r\n procedure Clear;\r\n function Contains(const AValue: Int64): Boolean;\r\n function ContainsAll(const ACollection: IJclInt64Collection): Boolean;\r\n function CollectionEquals(const ACollection: IJclInt64Collection): Boolean;\r\n function Extract(const AValue: Int64): Boolean;\r\n function ExtractAll(const ACollection: IJclInt64Collection): Boolean;\r\n function First: IJclInt64Iterator;\r\n function IsEmpty: Boolean;\r\n function Last: IJclInt64Iterator;\r\n function Remove(const AValue: Int64): Boolean;\r\n function RemoveAll(const ACollection: IJclInt64Collection): Boolean;\r\n function RetainAll(const ACollection: IJclInt64Collection): Boolean;\r\n function Size: Integer;\r\n {$IFDEF SUPPORTS_FOR_IN}\r\n function GetEnumerator: IJclInt64Iterator;\r\n {$ENDIF SUPPORTS_FOR_IN}\r\n end;\r\n\r\n IJclPtrCollection = interface(IJclPtrFlatContainer)\r\n ['{02E909A7-5B1D-40D4-82EA-A0CD97D5C811}']\r\n function Add(APtr: Pointer): Boolean;\r\n function AddAll(const ACollection: IJclPtrCollection): Boolean;\r\n procedure Clear;\r\n function Contains(APtr: Pointer): Boolean;\r\n function ContainsAll(const ACollection: IJclPtrCollection): Boolean;\r\n function CollectionEquals(const ACollection: IJclPtrCollection): Boolean;\r\n function Extract(APtr: Pointer): Boolean;\r\n function ExtractAll(const ACollection: IJclPtrCollection): Boolean;\r\n function First: IJclPtrIterator;\r\n function IsEmpty: Boolean;\r\n function Last: IJclPtrIterator;\r\n function Remove(APtr: Pointer): Boolean;\r\n function RemoveAll(const ACollection: IJclPtrCollection): Boolean;\r\n function RetainAll(const ACollection: IJclPtrCollection): Boolean;\r\n function Size: Integer;\r\n {$IFDEF SUPPORTS_FOR_IN}\r\n function GetEnumerator: IJclPtrIterator;\r\n {$ENDIF SUPPORTS_FOR_IN}\r\n end;\r\n\r\n IJclCollection = interface(IJclFlatContainer)\r\n ['{58947EF1-CD21-4DD1-AE3D-225C3AAD7EE5}']\r\n function Add(AObject: TObject): Boolean;\r\n function AddAll(const ACollection: IJclCollection): Boolean;\r\n procedure Clear;\r\n function Contains(AObject: TObject): Boolean;\r\n function ContainsAll(const ACollection: IJclCollection): Boolean;\r\n function CollectionEquals(const ACollection: IJclCollection): Boolean;\r\n function Extract(AObject: TObject): Boolean;\r\n function ExtractAll(const ACollection: IJclCollection): Boolean;\r\n function First: IJclIterator;\r\n function IsEmpty: Boolean;\r\n function Last: IJclIterator;\r\n function Remove(AObject: TObject): Boolean;\r\n function RemoveAll(const ACollection: IJclCollection): Boolean;\r\n function RetainAll(const ACollection: IJclCollection): Boolean;\r\n function Size: Integer;\r\n {$IFDEF SUPPORTS_FOR_IN}\r\n function GetEnumerator: IJclIterator;\r\n {$ENDIF SUPPORTS_FOR_IN}\r\n end;\r\n\r\n\r\n {$IFDEF SUPPORTS_GENERICS}\r\n //DOM-IGNORE-BEGIN\r\n IJclCollection = interface(IJclBaseContainer)\r\n ['{67EE8AF3-19B0-4DCA-A730-3C9B261B8EC5}']\r\n function Add(const AItem: T): Boolean;\r\n function AddAll(const ACollection: IJclCollection): Boolean;\r\n procedure Clear;\r\n function Contains(const AItem: T): Boolean;\r\n function ContainsAll(const ACollection: IJclCollection): Boolean;\r\n function CollectionEquals(const ACollection: IJclCollection): Boolean;\r\n function Extract(const AItem: T): Boolean;\r\n function ExtractAll(const ACollection: IJclCollection): Boolean;\r\n function First: IJclIterator;\r\n function IsEmpty: Boolean;\r\n function Last: IJclIterator;\r\n function Remove(const AItem: T): Boolean;\r\n function RemoveAll(const ACollection: IJclCollection): Boolean;\r\n function RetainAll(const ACollection: IJclCollection): Boolean;\r\n function Size: Integer;\r\n {$IFDEF SUPPORTS_FOR_IN}\r\n function GetEnumerator: IJclIterator;\r\n {$ENDIF SUPPORTS_FOR_IN}\r\n end;\r\n //DOM-IGNORE-END\r\n {$ENDIF SUPPORTS_GENERICS}\r\n\r\n IJclIntfList = interface(IJclIntfCollection)\r\n ['{E14EDA4B-1DAA-4013-9E6C-CDCB365C7CF9}']\r\n function Delete(Index: Integer): IInterface;\r\n function ExtractIndex(Index: Integer): IInterface;\r\n function GetObject(Index: Integer): IInterface;\r\n function IndexOf(const AInterface: IInterface): Integer;\r\n function Insert(Index: Integer; const AInterface: IInterface): Boolean;\r\n function InsertAll(Index: Integer; const ACollection: IJclIntfCollection): Boolean;\r\n function LastIndexOf(const AInterface: IInterface): Integer;\r\n procedure SetObject(Index: Integer; const AInterface: IInterface);\r\n function SubList(First, Count: Integer): IJclIntfList;\r\n property Objects[Key: Integer]: IInterface read GetObject write SetObject; default;\r\n end;\r\n\r\n IJclAnsiStrList = interface(IJclAnsiStrCollection)\r\n ['{07DD7644-EAC6-4059-99FC-BEB7FBB73186}']\r\n function Delete(Index: Integer): AnsiString;\r\n function ExtractIndex(Index: Integer): AnsiString;\r\n function GetString(Index: Integer): AnsiString;\r\n function IndexOf(const AString: AnsiString): Integer;\r\n function Insert(Index: Integer; const AString: AnsiString): Boolean;\r\n function InsertAll(Index: Integer; const ACollection: IJclAnsiStrCollection): Boolean;\r\n function LastIndexOf(const AString: AnsiString): Integer;\r\n procedure SetString(Index: Integer; const AString: AnsiString);\r\n function SubList(First, Count: Integer): IJclAnsiStrList;\r\n property Strings[Key: Integer]: AnsiString read GetString write SetString; default;\r\n end;\r\n\r\n IJclWideStrList = interface(IJclWideStrCollection)\r\n ['{C9955874-6AC0-4CE0-8CC0-606A3F1702C6}']\r\n function Delete(Index: Integer): WideString;\r\n function ExtractIndex(Index: Integer): WideString;\r\n function GetString(Index: Integer): WideString;\r\n function IndexOf(const AString: WideString): Integer;\r\n function Insert(Index: Integer; const AString: WideString): Boolean;\r\n function InsertAll(Index: Integer; const ACollection: IJclWideStrCollection): Boolean;\r\n function LastIndexOf(const AString: WideString): Integer;\r\n procedure SetString(Index: Integer; const AString: WideString);\r\n function SubList(First, Count: Integer): IJclWideStrList;\r\n property Strings[Key: Integer]: WideString read GetString write SetString; default;\r\n end;\r\n\r\n {$IFDEF SUPPORTS_UNICODE_STRING}\r\n IJclUnicodeStrList = interface(IJclUnicodeStrCollection)\r\n ['{F4307EB4-D66E-4656-AC56-50883D0F2C83}']\r\n function Delete(Index: Integer): UnicodeString;\r\n function ExtractIndex(Index: Integer): UnicodeString;\r\n function GetString(Index: Integer): UnicodeString;\r\n function IndexOf(const AString: UnicodeString): Integer;\r\n function Insert(Index: Integer; const AString: UnicodeString): Boolean;\r\n function InsertAll(Index: Integer; const ACollection: IJclUnicodeStrCollection): Boolean;\r\n function LastIndexOf(const AString: UnicodeString): Integer;\r\n procedure SetString(Index: Integer; const AString: UnicodeString);\r\n function SubList(First, Count: Integer): IJclUnicodeStrList;\r\n property Strings[Key: Integer]: UnicodeString read GetString write SetString; default;\r\n end;\r\n {$ENDIF SUPPORTS_UNICODE_STRING}\r\n\r\n {$IFDEF CONTAINER_ANSISTR}\r\n IJclStrList = IJclAnsiStrList;\r\n {$ENDIF CONTAINER_ANSISTR}\r\n {$IFDEF CONTAINER_WIDESTR}\r\n IJclStrList = IJclWideStrList;\r\n {$ENDIF CONTAINER_WIDESTR}\r\n {$IFDEF CONTAINER_UNICODESTR}\r\n IJclStrList = IJclUnicodeStrList;\r\n {$ENDIF CONTAINER_UNICODESTR}\r\n\r\n IJclSingleList = interface(IJclSingleCollection)\r\n ['{D081324C-70A4-4AAC-BA42-7557F0262826}']\r\n function Delete(Index: Integer): Single;\r\n function ExtractIndex(Index: Integer): Single;\r\n function GetValue(Index: Integer): Single;\r\n function IndexOf(const AValue: Single): Integer;\r\n function Insert(Index: Integer; const AValue: Single): Boolean;\r\n function InsertAll(Index: Integer; const ACollection: IJclSingleCollection): Boolean;\r\n function LastIndexOf(const AValue: Single): Integer;\r\n procedure SetValue(Index: Integer; const AValue: Single);\r\n function SubList(First, Count: Integer): IJclSingleList;\r\n property Values[Key: Integer]: Single read GetValue write SetValue; default;\r\n end;\r\n\r\n IJclDoubleList = interface(IJclDoubleCollection)\r\n ['{ECA58515-3903-4312-9486-3214E03F35AB}']\r\n function Delete(Index: Integer): Double;\r\n function ExtractIndex(Index: Integer): Double;\r\n function GetValue(Index: Integer): Double;\r\n function IndexOf(const AValue: Double): Integer;\r\n function Insert(Index: Integer; const AValue: Double): Boolean;\r\n function InsertAll(Index: Integer; const ACollection: IJclDoubleCollection): Boolean;\r\n function LastIndexOf(const AValue: Double): Integer;\r\n procedure SetValue(Index: Integer; const AValue: Double);\r\n function SubList(First, Count: Integer): IJclDoubleList;\r\n property Values[Key: Integer]: Double read GetValue write SetValue; default;\r\n end;\r\n\r\n IJclExtendedList = interface(IJclExtendedCollection)\r\n ['{7463F954-F8DF-4B02-A284-FCB98746248E}']\r\n function Delete(Index: Integer): Extended;\r\n function ExtractIndex(Index: Integer): Extended;\r\n function GetValue(Index: Integer): Extended;\r\n function IndexOf(const AValue: Extended): Integer;\r\n function Insert(Index: Integer; const AValue: Extended): Boolean;\r\n function InsertAll(Index: Integer; const ACollection: IJclExtendedCollection): Boolean;\r\n function LastIndexOf(const AValue: Extended): Integer;\r\n procedure SetValue(Index: Integer; const AValue: Extended);\r\n function SubList(First, Count: Integer): IJclExtendedList;\r\n property Values[Key: Integer]: Extended read GetValue write SetValue; default;\r\n end;\r\n\r\n {$IFDEF MATH_SINGLE_PRECISION}\r\n IJclFloatList = IJclSingleList;\r\n {$ENDIF MATH_SINGLE_PRECISION}\r\n {$IFDEF MATH_DOUBLE_PRECISION}\r\n IJclFloatList = IJclDoubleList;\r\n {$ENDIF MATH_DOUBLE_PRECISION}\r\n {$IFDEF MATH_EXTENDED_PRECISION}\r\n IJclFloatList = IJclExtendedList;\r\n {$ENDIF MATH_EXTENDED_PRECISION}\r\n\r\n IJclIntegerList = interface(IJclIntegerCollection)\r\n ['{339BE91B-557D-4CE0-A854-1CBD4FE31725}']\r\n function Delete(Index: Integer): Integer;\r\n function ExtractIndex(Index: Integer): Integer;\r\n function GetValue(Index: Integer): Integer;\r\n function IndexOf(AValue: Integer): Integer;\r\n function Insert(Index: Integer; AValue: Integer): Boolean;\r\n function InsertAll(Index: Integer; const ACollection: IJclIntegerCollection): Boolean;\r\n function LastIndexOf(AValue: Integer): Integer;\r\n procedure SetValue(Index: Integer; AValue: Integer);\r\n function SubList(First, Count: Integer): IJclIntegerList;\r\n property Values[Key: Integer]: Integer read GetValue write SetValue; default;\r\n end;\r\n\r\n IJclCardinalList = interface(IJclCardinalCollection)\r\n ['{02B09EA8-DE6F-4A18-AA57-C3533E6AC4E3}']\r\n function Delete(Index: Integer): Cardinal;\r\n function ExtractIndex(Index: Integer): Cardinal;\r\n function GetValue(Index: Integer): Cardinal;\r\n function IndexOf(AValue: Cardinal): Integer;\r\n function Insert(Index: Integer; AValue: Cardinal): Boolean;\r\n function InsertAll(Index: Integer; const ACollection: IJclCardinalCollection): Boolean;\r\n function LastIndexOf(AValue: Cardinal): Integer;\r\n procedure SetValue(Index: Integer; AValue: Cardinal);\r\n function SubList(First, Count: Integer): IJclCardinalList;\r\n property Values[Key: Integer]: Cardinal read GetValue write SetValue; default;\r\n end;\r\n\r\n IJclInt64List = interface(IJclInt64Collection)\r\n ['{E8D49200-91D3-4BD0-A59B-B93EC7E2074B}']\r\n function Delete(Index: Integer): Int64;\r\n function ExtractIndex(Index: Integer): Int64;\r\n function GetValue(Index: Integer): Int64;\r\n function IndexOf(const AValue: Int64): Integer;\r\n function Insert(Index: Integer; const AValue: Int64): Boolean;\r\n function InsertAll(Index: Integer; const ACollection: IJclInt64Collection): Boolean;\r\n function LastIndexOf(const AValue: Int64): Integer;\r\n procedure SetValue(Index: Integer; const AValue: Int64);\r\n function SubList(First, Count: Integer): IJclInt64List;\r\n property Values[Key: Integer]: Int64 read GetValue write SetValue; default;\r\n end;\r\n\r\n IJclPtrList = interface(IJclPtrCollection)\r\n ['{2CF5CF1F-C012-480C-A4CE-38BDAFB15D05}']\r\n function Delete(Index: Integer): Pointer;\r\n function ExtractIndex(Index: Integer): Pointer;\r\n function GetPointer(Index: Integer): Pointer;\r\n function IndexOf(APtr: Pointer): Integer;\r\n function Insert(Index: Integer; APtr: Pointer): Boolean;\r\n function InsertAll(Index: Integer; const ACollection: IJclPtrCollection): Boolean;\r\n function LastIndexOf(APtr: Pointer): Integer;\r\n procedure SetPointer(Index: Integer; APtr: Pointer);\r\n function SubList(First, Count: Integer): IJclPtrList;\r\n property Pointers[Key: Integer]: Pointer read GetPointer write SetPointer; default;\r\n end;\r\n\r\n IJclList = interface(IJclCollection)\r\n ['{8ABC70AC-5C06-43EA-AFE0-D066379BCC28}']\r\n function Delete(Index: Integer): TObject;\r\n function ExtractIndex(Index: Integer): TObject;\r\n function GetObject(Index: Integer): TObject;\r\n function IndexOf(AObject: TObject): Integer;\r\n function Insert(Index: Integer; AObject: TObject): Boolean;\r\n function InsertAll(Index: Integer; const ACollection: IJclCollection): Boolean;\r\n function LastIndexOf(AObject: TObject): Integer;\r\n procedure SetObject(Index: Integer; AObject: TObject);\r\n function SubList(First, Count: Integer): IJclList;\r\n property Objects[Key: Integer]: TObject read GetObject write SetObject; default;\r\n end;\r\n\r\n\r\n {$IFDEF SUPPORTS_GENERICS}\r\n //DOM-IGNORE-BEGIN\r\n IJclList = interface(IJclCollection)\r\n ['{3B4BE3D7-8FF7-4163-91DF-3F73AE6935E7}']\r\n function Delete(Index: Integer): T;\r\n function ExtractIndex(Index: Integer): T;\r\n function GetItem(Index: Integer): T;\r\n function IndexOf(const AItem: T): Integer;\r\n function Insert(Index: Integer; const AItem: T): Boolean;\r\n function InsertAll(Index: Integer; const ACollection: IJclCollection): Boolean;\r\n function LastIndexOf(const AItem: T): Integer;\r\n procedure SetItem(Index: Integer; const AItem: T);\r\n function SubList(First, Count: Integer): IJclList;\r\n property Items[Key: Integer]: T read GetItem write SetItem; default;\r\n end;\r\n //DOM-IGNORE-END\r\n {$ENDIF SUPPORTS_GENERICS}\r\n\r\n // Pointer functions for sort algorithms\r\n TIntfSortProc = procedure(const AList: IJclIntfList; L, R: Integer; AComparator: TIntfCompare);\r\n TAnsiStrSortProc = procedure(const AList: IJclAnsiStrList; L, R: Integer; AComparator: TAnsiStrCompare);\r\n TWideStrSortProc = procedure(const AList: IJclWideStrList; L, R: Integer; AComparator: TWideStrCompare);\r\n {$IFDEF SUPPORTS_UNICODE_STRING}\r\n TUnicodeStrSortProc = procedure(const AList: IJclUnicodeStrList; L, R: Integer; AComparator: TUnicodeStrCompare);\r\n {$ENDIF SUPPORTS_UNICODE_STRING}\r\n {$IFDEF CONTAINER_ANSISTR}\r\n TStrSortProc = TAnsiStrSortProc;\r\n {$ENDIF CONTAINER_ANSISTR}\r\n {$IFDEF CONTAINER_WIDESTR}\r\n TStrSortProc = TWideStrSortProc;\r\n {$ENDIF CONTAINER_WIDESTR}\r\n {$IFDEF CONTAINER_UNICODESTR}\r\n TStrSortProc = TUnicodeStrSortProc;\r\n {$ENDIF CONTAINER_UNICODESTR}\r\n TSingleSortProc = procedure(const AList: IJclSingleList; L, R: Integer; AComparator: TSingleCompare);\r\n TDoubleSortProc = procedure(const AList: IJclDoubleList; L, R: Integer; AComparator: TDoubleCompare);\r\n TExtendedSortProc = procedure(const AList: IJclExtendedList; L, R: Integer; AComparator: TExtendedCompare);\r\n {$IFDEF MATH_SINGLE_PRECISION}\r\n TFloatSortProc = TSingleSortProc;\r\n {$ENDIF MATH_SINGLE_PRECISION}\r\n {$IFDEF MATH_DOUBLE_PRECISION}\r\n TFloatSortProc = TDoubleSortProc;\r\n {$ENDIF MATH_DOUBLE_PRECISION}\r\n {$IFDEF MATH_EXTENDED_PRECISION}\r\n TFloatSortProc = TExtendedSortProc;\r\n {$ENDIF MATH_EXTENDED_PRECISION}\r\n TIntegerSortProc = procedure(const AList: IJclIntegerList; L, R: Integer; AComparator: TIntegerCompare);\r\n TCardinalSortProc = procedure(const AList: IJclCardinalList; L, R: Integer; AComparator: TCardinalCompare);\r\n TInt64SortProc = procedure(const AList: IJclInt64List; L, R: Integer; AComparator: TInt64Compare);\r\n TPtrSortProc = procedure(const AList: IJclPtrList; L, R: Integer; AComparator: TPtrCompare);\r\n TSortProc = procedure(const AList: IJclList; L, R: Integer; AComparator: TCompare);\r\n\r\n {$IFDEF SUPPORTS_GENERICS}\r\n //DOM-IGNORE-BEGIN\r\n TSortProc = procedure(const AList: IJclList; L, R: Integer; AComparator: TCompare);\r\n //DOM-IGNORE-END\r\n {$ENDIF SUPPORTS_GENERICS}\r\n\r\n IJclIntfArray = interface(IJclIntfList)\r\n ['{B055B427-7817-43FC-97D4-AD1845643D63}']\r\n function GetObject(Index: Integer): IInterface;\r\n procedure SetObject(Index: Integer; const AInterface: IInterface);\r\n property Objects[Index: Integer]: IInterface read GetObject write SetObject; default;\r\n end;\r\n\r\n IJclAnsiStrArray = interface(IJclAnsiStrList)\r\n ['{4953EA83-9288-4537-9D10-544D1C992B62}']\r\n function GetString(Index: Integer): AnsiString;\r\n procedure SetString(Index: Integer; const AString: AnsiString);\r\n property Strings[Index: Integer]: AnsiString read GetString write SetString; default;\r\n end;\r\n\r\n IJclWideStrArray = interface(IJclWideStrList)\r\n ['{3CE09F9A-5CB4-4867-80D5-C2313D278D69}']\r\n function GetString(Index: Integer): WideString;\r\n procedure SetString(Index: Integer; const AString: WideString);\r\n property Strings[Index: Integer]: WideString read GetString write SetString; default;\r\n end;\r\n\r\n {$IFDEF SUPPORTS_UNICODE_STRING}\r\n IJclUnicodeStrArray = interface(IJclUnicodeStrList)\r\n ['{24312E5B-B61D-485C-9E57-AC36C93D8159}']\r\n function GetString(Index: Integer): UnicodeString;\r\n procedure SetString(Index: Integer; const AString: UnicodeString);\r\n property Strings[Index: Integer]: UnicodeString read GetString write SetString; default;\r\n end;\r\n {$ENDIF SUPPORTS_UNICODE_STRING}\r\n\r\n {$IFDEF CONTAINER_ANSISTR}\r\n IJclStrArray = IJclAnsiStrArray;\r\n {$ENDIF CONTAINER_ANSISTR}\r\n {$IFDEF CONTAINER_WIDESTR}\r\n IJclStrArray = IJclWideStrArray;\r\n {$ENDIF CONTAINER_WIDESTR}\r\n {$IFDEF CONTAINER_UNICODESTR}\r\n IJclStrArray = IJclUnicodeStrArray;\r\n {$ENDIF CONTAINER_UNICODESTR}\r\n\r\n IJclSingleArray = interface(IJclSingleList)\r\n ['{B96E2A4D-D750-4B65-B975-C619A05A29F6}']\r\n function GetValue(Index: Integer): Single;\r\n procedure SetValue(Index: Integer; const AValue: Single);\r\n property Values[Index: Integer]: Single read GetValue write SetValue; default;\r\n end;\r\n\r\n IJclDoubleArray = interface(IJclDoubleList)\r\n ['{67E66324-9757-4E85-8ECD-53396910FB39}']\r\n function GetValue(Index: Integer): Double;\r\n procedure SetValue(Index: Integer; const AValue: Double);\r\n property Values[Index: Integer]: Double read GetValue write SetValue; default;\r\n end;\r\n\r\n IJclExtendedArray = interface(IJclExtendedList)\r\n ['{D43E8D18-26B3-41A2-8D52-ED7EA2FE1AB7}']\r\n function GetValue(Index: Integer): Extended;\r\n procedure SetValue(Index: Integer; const AValue: Extended);\r\n property Values[Index: Integer]: Extended read GetValue write SetValue; default;\r\n end;\r\n\r\n {$IFDEF MATH_SINGLE_PRECISION}\r\n IJclFloatArray = IJclSingleArray;\r\n {$ENDIF MATH_SINGLE_PRECISION}\r\n {$IFDEF MATH_DOUBLE_PRECISION}\r\n IJclFloatArray = IJclDoubleArray;\r\n {$ENDIF MATH_DOUBLE_PRECISION}\r\n {$IFDEF MATH_EXTENDED_PRECISION}\r\n IJclFloatArray = IJclExtendedArray;\r\n {$ENDIF MATH_EXTENDED_PRECISION}\r\n\r\n IJclIntegerArray = interface(IJclIntegerList)\r\n ['{2B7C8B33-C0BD-4EC3-9764-63866E174781}']\r\n function GetValue(Index: Integer): Integer;\r\n procedure SetValue(Index: Integer; AValue: Integer);\r\n property Values[Index: Integer]: Integer read GetValue write SetValue; default;\r\n end;\r\n\r\n IJclCardinalArray = interface(IJclCardinalList)\r\n ['{C451F2F8-65C6-4C29-99A0-CC9C15356418}']\r\n function GetValue(Index: Integer): Cardinal;\r\n procedure SetValue(Index: Integer; AValue: Cardinal);\r\n property Values[Index: Integer]: Cardinal read GetValue write SetValue; default;\r\n end;\r\n\r\n IJclInt64Array = interface(IJclInt64List)\r\n ['{D947C43D-2D04-442A-A707-39EDE7D96FC9}']\r\n function GetValue(Index: Integer): Int64;\r\n procedure SetValue(Index: Integer; const AValue: Int64);\r\n property Values[Index: Integer]: Int64 read GetValue write SetValue; default;\r\n end;\r\n\r\n IJclPtrArray = interface(IJclPtrList)\r\n ['{D43E8D18-26B3-41A2-8D52-ED7EA2FE1AB7}']\r\n function GetPointer(Index: Integer): Pointer;\r\n procedure SetPointer(Index: Integer; APtr: Pointer);\r\n property Pointers[Index: Integer]: Pointer read GetPointer write SetPointer; default;\r\n end;\r\n\r\n IJclArray = interface(IJclList)\r\n ['{A69F6D35-54B2-4361-852E-097ED75E648A}']\r\n function GetObject(Index: Integer): TObject;\r\n procedure SetObject(Index: Integer; AObject: TObject);\r\n property Objects[Index: Integer]: TObject read GetObject write SetObject; default;\r\n end;\r\n\r\n\r\n {$IFDEF SUPPORTS_GENERICS}\r\n //DOM-IGNORE-BEGIN\r\n IJclArray = interface(IJclList)\r\n ['{38810C13-E35E-428A-B84F-D25FB994BE8E}']\r\n function GetItem(Index: Integer): T;\r\n procedure SetItem(Index: Integer; const AItem: T);\r\n property Items[Index: Integer]: T read GetItem write SetItem; default;\r\n end;\r\n //DOM-IGNORE-END\r\n {$ENDIF SUPPORTS_GENERICS}\r\n\r\n IJclIntfSet = interface(IJclIntfCollection)\r\n ['{E2D28852-9774-49B7-A739-5DBA2B705924}']\r\n procedure Intersect(const ACollection: IJclIntfCollection);\r\n procedure Subtract(const ACollection: IJclIntfCollection);\r\n procedure Union(const ACollection: IJclIntfCollection);\r\n end;\r\n\r\n IJclAnsiStrSet = interface(IJclAnsiStrCollection)\r\n ['{72204D85-2B68-4914-B9F2-09E5180C12E9}']\r\n procedure Intersect(const ACollection: IJclAnsiStrCollection);\r\n procedure Subtract(const ACollection: IJclAnsiStrCollection);\r\n procedure Union(const ACollection: IJclAnsiStrCollection);\r\n end;\r\n\r\n IJclWideStrSet = interface(IJclWideStrCollection)\r\n ['{08009E0A-ABDD-46AB-8CEE-407D4723E17C}']\r\n procedure Intersect(const ACollection: IJclWideStrCollection);\r\n procedure Subtract(const ACollection: IJclWideStrCollection);\r\n procedure Union(const ACollection: IJclWideStrCollection);\r\n end;\r\n\r\n {$IFDEF SUPPORTS_UNICODE_STRING}\r\n IJclUnicodeStrSet = interface(IJclUnicodeStrCollection)\r\n ['{440E9BCB-341F-40B6-8AED-479B2E98C92A}']\r\n procedure Intersect(const ACollection: IJclUnicodeStrCollection);\r\n procedure Subtract(const ACollection: IJclUnicodeStrCollection);\r\n procedure Union(const ACollection: IJclUnicodeStrCollection);\r\n end;\r\n {$ENDIF SUPPORTS_UNICODE_STRING}\r\n\r\n {$IFDEF CONTAINER_ANSISTR}\r\n IJclStrSet = IJclAnsiStrSet;\r\n {$ENDIF CONTAINER_ANSISTR}\r\n {$IFDEF CONTAINER_WIDESTR}\r\n IJclStrSet = IJclWideStrSet;\r\n {$ENDIF CONTAINER_WIDESTR}\r\n {$IFDEF CONTAINER_UNICODESTR}\r\n IJclStrSet = IJclUnicodeStrSet;\r\n {$ENDIF CONTAINER_UNICODESTR}\r\n\r\n IJclSingleSet = interface(IJclSingleCollection)\r\n ['{36E34A78-6A29-4503-97D5-4BF53538CEC0}']\r\n procedure Intersect(const ACollection: IJclSingleCollection);\r\n procedure Subtract(const ACollection: IJclSingleCollection);\r\n procedure Union(const ACollection: IJclSingleCollection);\r\n end;\r\n\r\n IJclDoubleSet = interface(IJclDoubleCollection)\r\n ['{4E1E4847-E934-4811-A26C-5FC8E772A623}']\r\n procedure Intersect(const ACollection: IJclDoubleCollection);\r\n procedure Subtract(const ACollection: IJclDoubleCollection);\r\n procedure Union(const ACollection: IJclDoubleCollection);\r\n end;\r\n\r\n IJclExtendedSet = interface(IJclExtendedCollection)\r\n ['{3B9CF52D-1C49-4388-A7B3-9BEE1821FFD4}']\r\n procedure Intersect(const ACollection: IJclExtendedCollection);\r\n procedure Subtract(const ACollection: IJclExtendedCollection);\r\n procedure Union(const ACollection: IJclExtendedCollection);\r\n end;\r\n\r\n {$IFDEF MATH_SINGLE_PRECISION}\r\n IJclFloatSet = IJclSingleSet;\r\n {$ENDIF MATH_SINGLE_PRECISION}\r\n {$IFDEF MATH_DOUBLE_PRECISION}\r\n IJclFloatSet = IJclDoubleSet;\r\n {$ENDIF MATH_DOUBLE_PRECISION}\r\n {$IFDEF MATH_EXTENDED_PRECISION}\r\n IJclFloatSet = IJclExtendedSet;\r\n {$ENDIF MATH_EXTENDED_PRECISION}\r\n\r\n IJclIntegerSet = interface(IJclIntegerCollection)\r\n ['{5E4D29AF-F508-465B-9008-D11FF82F25FE}']\r\n procedure Intersect(const ACollection: IJclIntegerCollection);\r\n procedure Subtract(const ACollection: IJclIntegerCollection);\r\n procedure Union(const ACollection: IJclIntegerCollection);\r\n end;\r\n\r\n IJclCardinalSet = interface(IJclCardinalCollection)\r\n ['{09858637-CE8F-42E6-97E0-2786CD68387B}']\r\n procedure Intersect(const ACollection: IJclCardinalCollection);\r\n procedure Subtract(const ACollection: IJclCardinalCollection);\r\n procedure Union(const ACollection: IJclCardinalCollection);\r\n end;\r\n\r\n IJclInt64Set = interface(IJclInt64Collection)\r\n ['{ACB3127A-48EE-4F9F-B988-6AE9057780E9}']\r\n procedure Intersect(const ACollection: IJclInt64Collection);\r\n procedure Subtract(const ACollection: IJclInt64Collection);\r\n procedure Union(const ACollection: IJclInt64Collection);\r\n end;\r\n\r\n IJclPtrSet = interface(IJclPtrCollection)\r\n ['{26717C68-4F83-4CCB-973A-7324FBD09632}']\r\n procedure Intersect(const ACollection: IJclPtrCollection);\r\n procedure Subtract(const ACollection: IJclPtrCollection);\r\n procedure Union(const ACollection: IJclPtrCollection);\r\n end;\r\n\r\n IJclSet = interface(IJclCollection)\r\n ['{0B7CDB90-8588-4260-A54C-D87101C669EA}']\r\n procedure Intersect(const ACollection: IJclCollection);\r\n procedure Subtract(const ACollection: IJclCollection);\r\n procedure Union(const ACollection: IJclCollection);\r\n end;\r\n\r\n\r\n {$IFDEF SUPPORTS_GENERICS}\r\n //DOM-IGNORE-BEGIN\r\n IJclSet = interface(IJclCollection)\r\n ['{0B7CDB90-8588-4260-A54C-D87101C669EA}']\r\n procedure Intersect(const ACollection: IJclCollection);\r\n procedure Subtract(const ACollection: IJclCollection);\r\n procedure Union(const ACollection: IJclCollection);\r\n end;\r\n //DOM-IGNORE-END\r\n {$ENDIF SUPPORTS_GENERICS}\r\n\r\n TJclTraverseOrder = (toPreOrder, toOrder, toPostOrder);\r\n\r\n IJclIntfTree = interface(IJclIntfCollection)\r\n ['{5A21688F-113D-41B4-A17C-54BDB0BD6559}']\r\n function GetRoot: IJclIntfTreeIterator;\r\n function GetTraverseOrder: TJclTraverseOrder;\r\n procedure SetTraverseOrder(Value: TJclTraverseOrder);\r\n property Root: IJclIntfTreeIterator read GetRoot;\r\n property TraverseOrder: TJclTraverseOrder read GetTraverseOrder write SetTraverseOrder;\r\n end;\r\n\r\n IJclAnsiStrTree = interface(IJclAnsiStrCollection)\r\n ['{1E1896C0-0497-47DF-83AF-A9422084636C}']\r\n function GetRoot: IJclAnsiStrTreeIterator;\r\n function GetTraverseOrder: TJclTraverseOrder;\r\n procedure SetTraverseOrder(Value: TJclTraverseOrder);\r\n property Root: IJclAnsiStrTreeIterator read GetRoot;\r\n property TraverseOrder: TJclTraverseOrder read GetTraverseOrder write SetTraverseOrder;\r\n end;\r\n\r\n IJclWideStrTree = interface(IJclWideStrCollection)\r\n ['{E325615A-7A20-4788-87FA-9051002CCD91}']\r\n function GetRoot: IJclWideStrTreeIterator;\r\n function GetTraverseOrder: TJclTraverseOrder;\r\n procedure SetTraverseOrder(Value: TJclTraverseOrder);\r\n property Root: IJclWideStrTreeIterator read GetRoot;\r\n property TraverseOrder: TJclTraverseOrder read GetTraverseOrder write SetTraverseOrder;\r\n end;\r\n\r\n {$IFDEF SUPPORTS_UNICODE_STRING}\r\n IJclUnicodeStrTree = interface(IJclUnicodeStrCollection)\r\n ['{A378BC36-1FB1-4330-A335-037DD370E81B}']\r\n function GetRoot: IJclUnicodeStrTreeIterator;\r\n function GetTraverseOrder: TJclTraverseOrder;\r\n procedure SetTraverseOrder(Value: TJclTraverseOrder);\r\n property Root: IJclUnicodeStrTreeIterator read GetRoot;\r\n property TraverseOrder: TJclTraverseOrder read GetTraverseOrder write SetTraverseOrder;\r\n end;\r\n {$ENDIF SUPPORTS_UNICODE_STRING}\r\n\r\n {$IFDEF CONTAINER_ANSISTR}\r\n IJclStrTree = IJclAnsiStrTree;\r\n {$ENDIF CONTAINER_ANSISTR}\r\n {$IFDEF CONTAINER_WIDESTR}\r\n IJclStrTree = IJclWideStrTree;\r\n {$ENDIF CONTAINER_WIDESTR}\r\n {$IFDEF CONTAINER_UNICODESTR}\r\n IJclStrTree = IJclUnicodeStrTree;\r\n {$ENDIF CONTAINER_UNICODESTR}\r\n\r\n IJclSingleTree = interface(IJclSingleCollection)\r\n ['{A90A51BC-EBD7-40D3-B0A0-C9987E7A83D0}']\r\n function GetRoot: IJclSingleTreeIterator;\r\n function GetTraverseOrder: TJclTraverseOrder;\r\n procedure SetTraverseOrder(Value: TJclTraverseOrder);\r\n property Root: IJclSingleTreeIterator read GetRoot;\r\n property TraverseOrder: TJclTraverseOrder read GetTraverseOrder write SetTraverseOrder;\r\n end;\r\n\r\n IJclDoubleTree = interface(IJclDoubleCollection)\r\n ['{69DA85B1-A0DD-407B-B5CF-5EB7C6D4B82D}']\r\n function GetRoot: IJclDoubleTreeIterator;\r\n function GetTraverseOrder: TJclTraverseOrder;\r\n procedure SetTraverseOrder(Value: TJclTraverseOrder);\r\n property Root: IJclDoubleTreeIterator read GetRoot;\r\n property TraverseOrder: TJclTraverseOrder read GetTraverseOrder write SetTraverseOrder;\r\n end;\r\n\r\n IJclExtendedTree = interface(IJclExtendedCollection)\r\n ['{9ACCCAFD-B617-43DC-AAF9-916BE324A17E}']\r\n function GetRoot: IJclExtendedTreeIterator;\r\n function GetTraverseOrder: TJclTraverseOrder;\r\n procedure SetTraverseOrder(Value: TJclTraverseOrder);\r\n property Root: IJclExtendedTreeIterator read GetRoot;\r\n property TraverseOrder: TJclTraverseOrder read GetTraverseOrder write SetTraverseOrder;\r\n end;\r\n\r\n {$IFDEF MATH_SINGLE_PRECISION}\r\n IJclFloatTree = IJclSingleTree;\r\n {$ENDIF MATH_SINGLE_PRECISION}\r\n {$IFDEF MATH_DOUBLE_PRECISION}\r\n IJclFloatTree = IJclDoubleTree;\r\n {$ENDIF MATH_DOUBLE_PRECISION}\r\n {$IFDEF MATH_EXTENDED_PRECISION}\r\n IJclFloatTree = IJclExtendedTree;\r\n {$ENDIF MATH_EXTENDED_PRECISION}\r\n\r\n IJclIntegerTree = interface(IJclIntegerCollection)\r\n ['{40A6F934-E5F3-4C74-AC02-227035C8C3C6}']\r\n function GetRoot: IJclIntegerTreeIterator;\r\n function GetTraverseOrder: TJclTraverseOrder;\r\n procedure SetTraverseOrder(Value: TJclTraverseOrder);\r\n property Root: IJclIntegerTreeIterator read GetRoot;\r\n property TraverseOrder: TJclTraverseOrder read GetTraverseOrder write SetTraverseOrder;\r\n end;\r\n\r\n IJclCardinalTree = interface(IJclCardinalCollection)\r\n ['{6C76C668-50C8-42A2-B72B-79BF102E270D}']\r\n function GetRoot: IJclCardinalTreeIterator;\r\n function GetTraverseOrder: TJclTraverseOrder;\r\n procedure SetTraverseOrder(Value: TJclTraverseOrder);\r\n property Root: IJclCardinalTreeIterator read GetRoot;\r\n property TraverseOrder: TJclTraverseOrder read GetTraverseOrder write SetTraverseOrder;\r\n end;\r\n\r\n IJclInt64Tree = interface(IJclInt64Collection)\r\n ['{1925B973-8B75-4A79-A993-DF2598FF19BE}']\r\n function GetRoot: IJclInt64TreeIterator;\r\n function GetTraverseOrder: TJclTraverseOrder;\r\n procedure SetTraverseOrder(Value: TJclTraverseOrder);\r\n property Root: IJclInt64TreeIterator read GetRoot;\r\n property TraverseOrder: TJclTraverseOrder read GetTraverseOrder write SetTraverseOrder;\r\n end;\r\n\r\n IJclPtrTree = interface(IJclPtrCollection)\r\n ['{2C1ACA3E-3F23-4E3C-984D-151CF9776E14}']\r\n function GetRoot: IJclPtrTreeIterator;\r\n function GetTraverseOrder: TJclTraverseOrder;\r\n procedure SetTraverseOrder(Value: TJclTraverseOrder);\r\n property Root: IJclPtrTreeIterator read GetRoot;\r\n property TraverseOrder: TJclTraverseOrder read GetTraverseOrder write SetTraverseOrder;\r\n end;\r\n\r\n IJclTree = interface(IJclCollection)\r\n ['{B0C658CC-FEF5-4178-A4C5-442C0DEDE207}']\r\n function GetRoot: IJclTreeIterator;\r\n function GetTraverseOrder: TJclTraverseOrder;\r\n procedure SetTraverseOrder(Value: TJclTraverseOrder);\r\n property Root: IJclTreeIterator read GetRoot;\r\n property TraverseOrder: TJclTraverseOrder read GetTraverseOrder write SetTraverseOrder;\r\n end;\r\n\r\n\r\n {$IFDEF SUPPORTS_GENERICS}\r\n //DOM-IGNORE-BEGIN\r\n IJclTree = interface(IJclCollection)\r\n ['{3F963AB5-5A75-41F9-A21B-7E7FB541A459}']\r\n function GetRoot: IJclTreeIterator;\r\n function GetTraverseOrder: TJclTraverseOrder;\r\n procedure SetTraverseOrder(Value: TJclTraverseOrder);\r\n property Root: IJclTreeIterator read GetRoot;\r\n property TraverseOrder: TJclTraverseOrder read GetTraverseOrder write SetTraverseOrder;\r\n end;\r\n //DOM-IGNORE-END\r\n {$ENDIF SUPPORTS_GENERICS}\r\n\r\n IJclIntfIntfMap = interface(IJclBaseContainer)\r\n ['{01D05399-4A05-4F3E-92F4-0C236BE77019}']\r\n procedure Clear;\r\n function ContainsKey(const Key: IInterface): Boolean;\r\n function ContainsValue(const Value: IInterface): Boolean;\r\n function Extract(const Key: IInterface): IInterface;\r\n function GetValue(const Key: IInterface): IInterface;\r\n function IsEmpty: Boolean;\r\n function KeyOfValue(const Value: IInterface): IInterface;\r\n function KeySet: IJclIntfSet;\r\n function MapEquals(const AMap: IJclIntfIntfMap): Boolean;\r\n procedure PutAll(const AMap: IJclIntfIntfMap);\r\n procedure PutValue(const Key: IInterface; const Value: IInterface);\r\n function Remove(const Key: IInterface): IInterface;\r\n function Size: Integer;\r\n function Values: IJclIntfCollection;\r\n property Items[const Key: IInterface]: IInterface read GetValue write PutValue;\r\n {$IFNDEF BUGGY_DEFAULT_INDEXED_PROP} default; {$ENDIF ~BUGGY_DEFAULT_INDEXED_PROP}\r\n end;\r\n\r\n IJclAnsiStrIntfMap = interface(IJclAnsiStrContainer)\r\n ['{A4788A96-281A-4924-AA24-03776DDAAD8A}']\r\n procedure Clear;\r\n function ContainsKey(const Key: AnsiString): Boolean;\r\n function ContainsValue(const Value: IInterface): Boolean;\r\n function Extract(const Key: AnsiString): IInterface;\r\n function GetValue(const Key: AnsiString): IInterface;\r\n function IsEmpty: Boolean;\r\n function KeyOfValue(const Value: IInterface): AnsiString;\r\n function KeySet: IJclAnsiStrSet;\r\n function MapEquals(const AMap: IJclAnsiStrIntfMap): Boolean;\r\n procedure PutAll(const AMap: IJclAnsiStrIntfMap);\r\n procedure PutValue(const Key: AnsiString; const Value: IInterface);\r\n function Remove(const Key: AnsiString): IInterface;\r\n function Size: Integer;\r\n function Values: IJclIntfCollection;\r\n property Items[const Key: AnsiString]: IInterface read GetValue write PutValue;\r\n {$IFNDEF BUGGY_DEFAULT_INDEXED_PROP} default; {$ENDIF ~BUGGY_DEFAULT_INDEXED_PROP}\r\n end;\r\n\r\n IJclIntfAnsiStrMap = interface(IJclAnsiStrContainer)\r\n ['{B10E324A-1D98-42FF-B9B4-7F99044591B2}']\r\n procedure Clear;\r\n function ContainsKey(const Key: IInterface): Boolean;\r\n function ContainsValue(const Value: AnsiString): Boolean;\r\n function Extract(const Key: IInterface): AnsiString;\r\n function GetValue(const Key: IInterface): AnsiString;\r\n function IsEmpty: Boolean;\r\n function KeyOfValue(const Value: AnsiString): IInterface;\r\n function KeySet: IJclIntfSet;\r\n function MapEquals(const AMap: IJclIntfAnsiStrMap): Boolean;\r\n procedure PutAll(const AMap: IJclIntfAnsiStrMap);\r\n procedure PutValue(const Key: IInterface; const Value: AnsiString);\r\n function Remove(const Key: IInterface): AnsiString;\r\n function Size: Integer;\r\n function Values: IJclAnsiStrCollection;\r\n property Items[const Key: IInterface]: AnsiString read GetValue write PutValue;\r\n {$IFNDEF BUGGY_DEFAULT_INDEXED_PROP} default; {$ENDIF ~BUGGY_DEFAULT_INDEXED_PROP}\r\n end;\r\n\r\n IJclAnsiStrAnsiStrMap = interface(IJclAnsiStrContainer)\r\n ['{A4788A96-281A-4924-AA24-03776DDAAD8A}']\r\n procedure Clear;\r\n function ContainsKey(const Key: AnsiString): Boolean;\r\n function ContainsValue(const Value: AnsiString): Boolean;\r\n function Extract(const Key: AnsiString): AnsiString;\r\n function GetValue(const Key: AnsiString): AnsiString;\r\n function IsEmpty: Boolean;\r\n function KeyOfValue(const Value: AnsiString): AnsiString;\r\n function KeySet: IJclAnsiStrSet;\r\n function MapEquals(const AMap: IJclAnsiStrAnsiStrMap): Boolean;\r\n procedure PutAll(const AMap: IJclAnsiStrAnsiStrMap);\r\n procedure PutValue(const Key: AnsiString; const Value: AnsiString);\r\n function Remove(const Key: AnsiString): AnsiString;\r\n function Size: Integer;\r\n function Values: IJclAnsiStrCollection;\r\n property Items[const Key: AnsiString]: AnsiString read GetValue write PutValue;\r\n {$IFNDEF BUGGY_DEFAULT_INDEXED_PROP} default; {$ENDIF ~BUGGY_DEFAULT_INDEXED_PROP}\r\n end;\r\n\r\n IJclWideStrIntfMap = interface(IJclWideStrContainer)\r\n ['{C959AB76-9CF0-4C2C-A2C6-8A1846563FAF}']\r\n procedure Clear;\r\n function ContainsKey(const Key: WideString): Boolean;\r\n function ContainsValue(const Value: IInterface): Boolean;\r\n function Extract(const Key: WideString): IInterface;\r\n function GetValue(const Key: WideString): IInterface;\r\n function IsEmpty: Boolean;\r\n function KeyOfValue(const Value: IInterface): WideString;\r\n function KeySet: IJclWideStrSet;\r\n function MapEquals(const AMap: IJclWideStrIntfMap): Boolean;\r\n procedure PutAll(const AMap: IJclWideStrIntfMap);\r\n procedure PutValue(const Key: WideString; const Value: IInterface);\r\n function Remove(const Key: WideString): IInterface;\r\n function Size: Integer;\r\n function Values: IJclIntfCollection;\r\n property Items[const Key: WideString]: IInterface read GetValue write PutValue;\r\n {$IFNDEF BUGGY_DEFAULT_INDEXED_PROP} default; {$ENDIF ~BUGGY_DEFAULT_INDEXED_PROP}\r\n end;\r\n\r\n IJclIntfWideStrMap = interface(IJclWideStrContainer)\r\n ['{D9FD7887-B840-4636-8A8F-E586663E332C}']\r\n procedure Clear;\r\n function ContainsKey(const Key: IInterface): Boolean;\r\n function ContainsValue(const Value: WideString): Boolean;\r\n function Extract(const Key: IInterface): WideString;\r\n function GetValue(const Key: IInterface): WideString;\r\n function IsEmpty: Boolean;\r\n function KeyOfValue(const Value: WideString): IInterface;\r\n function KeySet: IJclIntfSet;\r\n function MapEquals(const AMap: IJclIntfWideStrMap): Boolean;\r\n procedure PutAll(const AMap: IJclIntfWideStrMap);\r\n procedure PutValue(const Key: IInterface; const Value: WideString);\r\n function Remove(const Key: IInterface): WideString;\r\n function Size: Integer;\r\n function Values: IJclWideStrCollection;\r\n property Items[const Key: IInterface]: WideString read GetValue write PutValue;\r\n {$IFNDEF BUGGY_DEFAULT_INDEXED_PROP} default; {$ENDIF ~BUGGY_DEFAULT_INDEXED_PROP}\r\n end;\r\n\r\n IJclWideStrWideStrMap = interface(IJclWideStrContainer)\r\n ['{8E8D2735-C4FB-4F00-8802-B2102BCE3644}']\r\n procedure Clear;\r\n function ContainsKey(const Key: WideString): Boolean;\r\n function ContainsValue(const Value: WideString): Boolean;\r\n function Extract(const Key: WideString): WideString;\r\n function GetValue(const Key: WideString): WideString;\r\n function IsEmpty: Boolean;\r\n function KeyOfValue(const Value: WideString): WideString;\r\n function KeySet: IJclWideStrSet;\r\n function MapEquals(const AMap: IJclWideStrWideStrMap): Boolean;\r\n procedure PutAll(const AMap: IJclWideStrWideStrMap);\r\n procedure PutValue(const Key: WideString; const Value: WideString);\r\n function Remove(const Key: WideString): WideString;\r\n function Size: Integer;\r\n function Values: IJclWideStrCollection;\r\n property Items[const Key: WideString]: WideString read GetValue write PutValue;\r\n {$IFNDEF BUGGY_DEFAULT_INDEXED_PROP} default; {$ENDIF ~BUGGY_DEFAULT_INDEXED_PROP}\r\n end;\r\n\r\n {$IFDEF SUPPORTS_UNICODE_STRING}\r\n IJclUnicodeStrIntfMap = interface(IJclUnicodeStrContainer)\r\n ['{C83D4F5E-8E66-41E9-83F6-338B44F24BE6}']\r\n procedure Clear;\r\n function ContainsKey(const Key: UnicodeString): Boolean;\r\n function ContainsValue(const Value: IInterface): Boolean;\r\n function Extract(const Key: UnicodeString): IInterface;\r\n function GetValue(const Key: UnicodeString): IInterface;\r\n function IsEmpty: Boolean;\r\n function KeyOfValue(const Value: IInterface): UnicodeString;\r\n function KeySet: IJclUnicodeStrSet;\r\n function MapEquals(const AMap: IJclUnicodeStrIntfMap): Boolean;\r\n procedure PutAll(const AMap: IJclUnicodeStrIntfMap);\r\n procedure PutValue(const Key: UnicodeString; const Value: IInterface);\r\n function Remove(const Key: UnicodeString): IInterface;\r\n function Size: Integer;\r\n function Values: IJclIntfCollection;\r\n property Items[const Key: UnicodeString]: IInterface read GetValue write PutValue;\r\n {$IFNDEF BUGGY_DEFAULT_INDEXED_PROP} default; {$ENDIF ~BUGGY_DEFAULT_INDEXED_PROP}\r\n end;\r\n {$ENDIF SUPPORTS_UNICODE_STRING}\r\n\r\n {$IFDEF SUPPORTS_UNICODE_STRING}\r\n IJclIntfUnicodeStrMap = interface(IJclUnicodeStrContainer)\r\n ['{40F8B873-B763-4A3C-8EC4-31DB3404BF73}']\r\n procedure Clear;\r\n function ContainsKey(const Key: IInterface): Boolean;\r\n function ContainsValue(const Value: UnicodeString): Boolean;\r\n function Extract(const Key: IInterface): UnicodeString;\r\n function GetValue(const Key: IInterface): UnicodeString;\r\n function IsEmpty: Boolean;\r\n function KeyOfValue(const Value: UnicodeString): IInterface;\r\n function KeySet: IJclIntfSet;\r\n function MapEquals(const AMap: IJclIntfUnicodeStrMap): Boolean;\r\n procedure PutAll(const AMap: IJclIntfUnicodeStrMap);\r\n procedure PutValue(const Key: IInterface; const Value: UnicodeString);\r\n function Remove(const Key: IInterface): UnicodeString;\r\n function Size: Integer;\r\n function Values: IJclUnicodeStrCollection;\r\n property Items[const Key: IInterface]: UnicodeString read GetValue write PutValue;\r\n {$IFNDEF BUGGY_DEFAULT_INDEXED_PROP} default; {$ENDIF ~BUGGY_DEFAULT_INDEXED_PROP}\r\n end;\r\n {$ENDIF SUPPORTS_UNICODE_STRING}\r\n\r\n {$IFDEF SUPPORTS_UNICODE_STRING}\r\n IJclUnicodeStrUnicodeStrMap = interface(IJclUnicodeStrContainer)\r\n ['{557E1CBD-06AC-41C2-BAED-253709CBD0AE}']\r\n procedure Clear;\r\n function ContainsKey(const Key: UnicodeString): Boolean;\r\n function ContainsValue(const Value: UnicodeString): Boolean;\r\n function Extract(const Key: UnicodeString): UnicodeString;\r\n function GetValue(const Key: UnicodeString): UnicodeString;\r\n function IsEmpty: Boolean;\r\n function KeyOfValue(const Value: UnicodeString): UnicodeString;\r\n function KeySet: IJclUnicodeStrSet;\r\n function MapEquals(const AMap: IJclUnicodeStrUnicodeStrMap): Boolean;\r\n procedure PutAll(const AMap: IJclUnicodeStrUnicodeStrMap);\r\n procedure PutValue(const Key: UnicodeString; const Value: UnicodeString);\r\n function Remove(const Key: UnicodeString): UnicodeString;\r\n function Size: Integer;\r\n function Values: IJclUnicodeStrCollection;\r\n property Items[const Key: UnicodeString]: UnicodeString read GetValue write PutValue;\r\n {$IFNDEF BUGGY_DEFAULT_INDEXED_PROP} default; {$ENDIF ~BUGGY_DEFAULT_INDEXED_PROP}\r\n end;\r\n {$ENDIF SUPPORTS_UNICODE_STRING}\r\n\r\n {$IFDEF CONTAINER_ANSISTR}\r\n IJclStrIntfMap = IJclAnsiStrIntfMap;\r\n {$ENDIF CONTAINER_ANSISTR}\r\n {$IFDEF CONTAINER_WIDESTR}\r\n IJclStrIntfMap = IJclWideStrIntfMap;\r\n {$ENDIF CONTAINER_WIDESTR}\r\n {$IFDEF CONTAINER_UNICODESTR}\r\n IJclStrIntfMap = IJclUnicodeStrIntfMap;\r\n {$ENDIF CONTAINER_UNICODESTR}\r\n\r\n {$IFDEF CONTAINER_ANSISTR}\r\n IJclIntfStrMap = IJclIntfAnsiStrMap;\r\n {$ENDIF CONTAINER_ANSISTR}\r\n {$IFDEF CONTAINER_WIDESTR}\r\n IJclIntfStrMap = IJclIntfWideStrMap;\r\n {$ENDIF CONTAINER_WIDESTR}\r\n {$IFDEF CONTAINER_UNICODESTR}\r\n IJclIntfStrMap = IJclIntfUnicodeStrMap;\r\n {$ENDIF CONTAINER_UNICODESTR}\r\n\r\n {$IFDEF CONTAINER_ANSISTR}\r\n IJclStrStrMap = IJclAnsiStrAnsiStrMap;\r\n {$ENDIF CONTAINER_ANSISTR}\r\n {$IFDEF CONTAINER_WIDESTR}\r\n IJclStrStrMap = IJclWideStrWideStrMap;\r\n {$ENDIF CONTAINER_WIDESTR}\r\n {$IFDEF CONTAINER_UNICODESTR}\r\n IJclStrStrMap = IJclUnicodeStrUnicodeStrMap;\r\n {$ENDIF CONTAINER_UNICODESTR}\r\n\r\n IJclSingleIntfMap = interface(IJclSingleContainer)\r\n ['{5F5E9E8B-E648-450B-B6C0-0EC65CC2D0BA}']\r\n procedure Clear;\r\n function ContainsKey(const Key: Single): Boolean;\r\n function ContainsValue(const Value: IInterface): Boolean;\r\n function Extract(const Key: Single): IInterface;\r\n function GetValue(const Key: Single): IInterface;\r\n function IsEmpty: Boolean;\r\n function KeyOfValue(const Value: IInterface): Single;\r\n function KeySet: IJclSingleSet;\r\n function MapEquals(const AMap: IJclSingleIntfMap): Boolean;\r\n procedure PutAll(const AMap: IJclSingleIntfMap);\r\n procedure PutValue(const Key: Single; const Value: IInterface);\r\n function Remove(const Key: Single): IInterface;\r\n function Size: Integer;\r\n function Values: IJclIntfCollection;\r\n property Items[const Key: Single]: IInterface read GetValue write PutValue;\r\n {$IFNDEF BUGGY_DEFAULT_INDEXED_PROP} default; {$ENDIF ~BUGGY_DEFAULT_INDEXED_PROP}\r\n end;\r\n\r\n IJclIntfSingleMap = interface(IJclSingleContainer)\r\n ['{234D1618-FB0E-46F5-A70D-5106163A90F7}']\r\n procedure Clear;\r\n function ContainsKey(const Key: IInterface): Boolean;\r\n function ContainsValue(const Value: Single): Boolean;\r\n function Extract(const Key: IInterface): Single;\r\n function GetValue(const Key: IInterface): Single;\r\n function IsEmpty: Boolean;\r\n function KeyOfValue(const Value: Single): IInterface;\r\n function KeySet: IJclIntfSet;\r\n function MapEquals(const AMap: IJclIntfSingleMap): Boolean;\r\n procedure PutAll(const AMap: IJclIntfSingleMap);\r\n procedure PutValue(const Key: IInterface; const Value: Single);\r\n function Remove(const Key: IInterface): Single;\r\n function Size: Integer;\r\n function Values: IJclSingleCollection;\r\n property Items[const Key: IInterface]: Single read GetValue write PutValue;\r\n {$IFNDEF BUGGY_DEFAULT_INDEXED_PROP} default; {$ENDIF ~BUGGY_DEFAULT_INDEXED_PROP}\r\n end;\r\n\r\n IJclSingleSingleMap = interface(IJclSingleContainer)\r\n ['{AEB0008F-F3CF-4055-A7F3-A330D312F03F}']\r\n procedure Clear;\r\n function ContainsKey(const Key: Single): Boolean;\r\n function ContainsValue(const Value: Single): Boolean;\r\n function Extract(const Key: Single): Single;\r\n function GetValue(const Key: Single): Single;\r\n function IsEmpty: Boolean;\r\n function KeyOfValue(const Value: Single): Single;\r\n function KeySet: IJclSingleSet;\r\n function MapEquals(const AMap: IJclSingleSingleMap): Boolean;\r\n procedure PutAll(const AMap: IJclSingleSingleMap);\r\n procedure PutValue(const Key: Single; const Value: Single);\r\n function Remove(const Key: Single): Single;\r\n function Size: Integer;\r\n function Values: IJclSingleCollection;\r\n property Items[const Key: Single]: Single read GetValue write PutValue;\r\n {$IFNDEF BUGGY_DEFAULT_INDEXED_PROP} default; {$ENDIF ~BUGGY_DEFAULT_INDEXED_PROP}\r\n end;\r\n\r\n IJclDoubleIntfMap = interface(IJclDoubleContainer)\r\n ['{08968FFB-36C6-4FBA-BC09-3DCA2B5D7A50}']\r\n procedure Clear;\r\n function ContainsKey(const Key: Double): Boolean;\r\n function ContainsValue(const Value: IInterface): Boolean;\r\n function Extract(const Key: Double): IInterface;\r\n function GetValue(const Key: Double): IInterface;\r\n function IsEmpty: Boolean;\r\n function KeyOfValue(const Value: IInterface): Double;\r\n function KeySet: IJclDoubleSet;\r\n function MapEquals(const AMap: IJclDoubleIntfMap): Boolean;\r\n procedure PutAll(const AMap: IJclDoubleIntfMap);\r\n procedure PutValue(const Key: Double; const Value: IInterface);\r\n function Remove(const Key: Double): IInterface;\r\n function Size: Integer;\r\n function Values: IJclIntfCollection;\r\n property Items[const Key: Double]: IInterface read GetValue write PutValue;\r\n {$IFNDEF BUGGY_DEFAULT_INDEXED_PROP} default; {$ENDIF ~BUGGY_DEFAULT_INDEXED_PROP}\r\n end;\r\n\r\n IJclIntfDoubleMap = interface(IJclDoubleContainer)\r\n ['{B23DAF6A-6DC5-4DDD-835C-CD4633DDA010}']\r\n procedure Clear;\r\n function ContainsKey(const Key: IInterface): Boolean;\r\n function ContainsValue(const Value: Double): Boolean;\r\n function Extract(const Key: IInterface): Double;\r\n function GetValue(const Key: IInterface): Double;\r\n function IsEmpty: Boolean;\r\n function KeyOfValue(const Value: Double): IInterface;\r\n function KeySet: IJclIntfSet;\r\n function MapEquals(const AMap: IJclIntfDoubleMap): Boolean;\r\n procedure PutAll(const AMap: IJclIntfDoubleMap);\r\n procedure PutValue(const Key: IInterface; const Value: Double);\r\n function Remove(const Key: IInterface): Double;\r\n function Size: Integer;\r\n function Values: IJclDoubleCollection;\r\n property Items[const Key: IInterface]: Double read GetValue write PutValue;\r\n {$IFNDEF BUGGY_DEFAULT_INDEXED_PROP} default; {$ENDIF ~BUGGY_DEFAULT_INDEXED_PROP}\r\n end;\r\n\r\n IJclDoubleDoubleMap = interface(IJclDoubleContainer)\r\n ['{329A03B8-0B6B-4FE3-87C5-4B63447A5FFD}']\r\n procedure Clear;\r\n function ContainsKey(const Key: Double): Boolean;\r\n function ContainsValue(const Value: Double): Boolean;\r\n function Extract(const Key: Double): Double;\r\n function GetValue(const Key: Double): Double;\r\n function IsEmpty: Boolean;\r\n function KeyOfValue(const Value: Double): Double;\r\n function KeySet: IJclDoubleSet;\r\n function MapEquals(const AMap: IJclDoubleDoubleMap): Boolean;\r\n procedure PutAll(const AMap: IJclDoubleDoubleMap);\r\n procedure PutValue(const Key: Double; const Value: Double);\r\n function Remove(const Key: Double): Double;\r\n function Size: Integer;\r\n function Values: IJclDoubleCollection;\r\n property Items[const Key: Double]: Double read GetValue write PutValue;\r\n {$IFNDEF BUGGY_DEFAULT_INDEXED_PROP} default; {$ENDIF ~BUGGY_DEFAULT_INDEXED_PROP}\r\n end;\r\n\r\n IJclExtendedIntfMap = interface(IJclExtendedContainer)\r\n ['{7C0731E0-C9AB-4378-B1B0-8CE3DD60AD41}']\r\n procedure Clear;\r\n function ContainsKey(const Key: Extended): Boolean;\r\n function ContainsValue(const Value: IInterface): Boolean;\r\n function Extract(const Key: Extended): IInterface;\r\n function GetValue(const Key: Extended): IInterface;\r\n function IsEmpty: Boolean;\r\n function KeyOfValue(const Value: IInterface): Extended;\r\n function KeySet: IJclExtendedSet;\r\n function MapEquals(const AMap: IJclExtendedIntfMap): Boolean;\r\n procedure PutAll(const AMap: IJclExtendedIntfMap);\r\n procedure PutValue(const Key: Extended; const Value: IInterface);\r\n function Remove(const Key: Extended): IInterface;\r\n function Size: Integer;\r\n function Values: IJclIntfCollection;\r\n property Items[const Key: Extended]: IInterface read GetValue write PutValue;\r\n {$IFNDEF BUGGY_DEFAULT_INDEXED_PROP} default; {$ENDIF ~BUGGY_DEFAULT_INDEXED_PROP}\r\n end;\r\n\r\n IJclIntfExtendedMap = interface(IJclExtendedContainer)\r\n ['{479FCE5A-2D8A-44EE-96BC-E8DA3187DBD8}']\r\n procedure Clear;\r\n function ContainsKey(const Key: IInterface): Boolean;\r\n function ContainsValue(const Value: Extended): Boolean;\r\n function Extract(const Key: IInterface): Extended;\r\n function GetValue(const Key: IInterface): Extended;\r\n function IsEmpty: Boolean;\r\n function KeyOfValue(const Value: Extended): IInterface;\r\n function KeySet: IJclIntfSet;\r\n function MapEquals(const AMap: IJclIntfExtendedMap): Boolean;\r\n procedure PutAll(const AMap: IJclIntfExtendedMap);\r\n procedure PutValue(const Key: IInterface; const Value: Extended);\r\n function Remove(const Key: IInterface): Extended;\r\n function Size: Integer;\r\n function Values: IJclExtendedCollection;\r\n property Items[const Key: IInterface]: Extended read GetValue write PutValue;\r\n {$IFNDEF BUGGY_DEFAULT_INDEXED_PROP} default; {$ENDIF ~BUGGY_DEFAULT_INDEXED_PROP}\r\n end;\r\n\r\n IJclExtendedExtendedMap = interface(IJclExtendedContainer)\r\n ['{962C2B09-8CF5-44E8-A21A-4A7DAFB72A11}']\r\n procedure Clear;\r\n function ContainsKey(const Key: Extended): Boolean;\r\n function ContainsValue(const Value: Extended): Boolean;\r\n function Extract(const Key: Extended): Extended;\r\n function GetValue(const Key: Extended): Extended;\r\n function IsEmpty: Boolean;\r\n function KeyOfValue(const Value: Extended): Extended;\r\n function KeySet: IJclExtendedSet;\r\n function MapEquals(const AMap: IJclExtendedExtendedMap): Boolean;\r\n procedure PutAll(const AMap: IJclExtendedExtendedMap);\r\n procedure PutValue(const Key: Extended; const Value: Extended);\r\n function Remove(const Key: Extended): Extended;\r\n function Size: Integer;\r\n function Values: IJclExtendedCollection;\r\n property Items[const Key: Extended]: Extended read GetValue write PutValue;\r\n {$IFNDEF BUGGY_DEFAULT_INDEXED_PROP} default; {$ENDIF ~BUGGY_DEFAULT_INDEXED_PROP}\r\n end;\r\n\r\n {$IFDEF MATH_SINGLE_PRECISION}\r\n IJclFloatIntfMap = IJclSingleIntfMap;\r\n {$ENDIF MATH_SINGLE_PRECISION}\r\n {$IFDEF MATH_DOUBLE_PRECISION}\r\n IJclFloatIntfMap = IJclDoubleIntfMap;\r\n {$ENDIF MATH_DOUBLE_PRECISION}\r\n {$IFDEF MATH_EXTENDED_PRECISION}\r\n IJclFloatIntfMap = IJclExtendedIntfMap;\r\n {$ENDIF MATH_EXTENDED_PRECISION}\r\n\r\n {$IFDEF MATH_SINGLE_PRECISION}\r\n IJclIntfFloatMap = IJclIntfSingleMap;\r\n {$ENDIF MATH_SINGLE_PRECISION}\r\n {$IFDEF MATH_DOUBLE_PRECISION}\r\n IJclIntfFloatMap = IJclIntfDoubleMap;\r\n {$ENDIF MATH_DOUBLE_PRECISION}\r\n {$IFDEF MATH_EXTENDED_PRECISION}\r\n IJclIntfFloatMap = IJclIntfExtendedMap;\r\n {$ENDIF MATH_EXTENDED_PRECISION}\r\n\r\n {$IFDEF MATH_SINGLE_PRECISION}\r\n IJclFloatFloatMap = IJclSingleSingleMap;\r\n {$ENDIF MATH_SINGLE_PRECISION}\r\n {$IFDEF MATH_DOUBLE_PRECISION}\r\n IJclFloatFloatMap = IJclDoubleDoubleMap;\r\n {$ENDIF MATH_DOUBLE_PRECISION}\r\n {$IFDEF MATH_EXTENDED_PRECISION}\r\n IJclFloatFloatMap = IJclExtendedExtendedMap;\r\n {$ENDIF MATH_EXTENDED_PRECISION}\r\n\r\n IJclIntegerIntfMap = interface(IJclBaseContainer)\r\n ['{E535FE65-AC88-49D3-BEF2-FB30D92C2FA6}']\r\n procedure Clear;\r\n function ContainsKey(Key: Integer): Boolean;\r\n function ContainsValue(const Value: IInterface): Boolean;\r\n function Extract(Key: Integer): IInterface;\r\n function GetValue(Key: Integer): IInterface;\r\n function IsEmpty: Boolean;\r\n function KeyOfValue(const Value: IInterface): Integer;\r\n function KeySet: IJclIntegerSet;\r\n function MapEquals(const AMap: IJclIntegerIntfMap): Boolean;\r\n procedure PutAll(const AMap: IJclIntegerIntfMap);\r\n procedure PutValue(Key: Integer; const Value: IInterface);\r\n function Remove(Key: Integer): IInterface;\r\n function Size: Integer;\r\n function Values: IJclIntfCollection;\r\n property Items[Key: Integer]: IInterface read GetValue write PutValue;\r\n {$IFNDEF BUGGY_DEFAULT_INDEXED_PROP} default; {$ENDIF ~BUGGY_DEFAULT_INDEXED_PROP}\r\n end;\r\n\r\n IJclIntfIntegerMap = interface(IJclBaseContainer)\r\n ['{E01DA012-BEE0-4259-8E30-0A7A1A87BED0}']\r\n procedure Clear;\r\n function ContainsKey(const Key: IInterface): Boolean;\r\n function ContainsValue(Value: Integer): Boolean;\r\n function Extract(const Key: IInterface): Integer;\r\n function GetValue(const Key: IInterface): Integer;\r\n function IsEmpty: Boolean;\r\n function KeyOfValue(Value: Integer): IInterface;\r\n function KeySet: IJclIntfSet;\r\n function MapEquals(const AMap: IJclIntfIntegerMap): Boolean;\r\n procedure PutAll(const AMap: IJclIntfIntegerMap);\r\n procedure PutValue(const Key: IInterface; Value: Integer);\r\n function Remove(const Key: IInterface): Integer;\r\n function Size: Integer;\r\n function Values: IJclIntegerCollection;\r\n property Items[const Key: IInterface]: Integer read GetValue write PutValue;\r\n {$IFNDEF BUGGY_DEFAULT_INDEXED_PROP} default; {$ENDIF ~BUGGY_DEFAULT_INDEXED_PROP}\r\n end;\r\n\r\n IJclIntegerIntegerMap = interface(IJclBaseContainer)\r\n ['{23A46BC0-DF8D-4BD2-89D2-4DACF1EC73A1}']\r\n procedure Clear;\r\n function ContainsKey(Key: Integer): Boolean;\r\n function ContainsValue(Value: Integer): Boolean;\r\n function Extract(Key: Integer): Integer;\r\n function GetValue(Key: Integer): Integer;\r\n function IsEmpty: Boolean;\r\n function KeyOfValue(Value: Integer): Integer;\r\n function KeySet: IJclIntegerSet;\r\n function MapEquals(const AMap: IJclIntegerIntegerMap): Boolean;\r\n procedure PutAll(const AMap: IJclIntegerIntegerMap);\r\n procedure PutValue(Key: Integer; Value: Integer);\r\n function Remove(Key: Integer): Integer;\r\n function Size: Integer;\r\n function Values: IJclIntegerCollection;\r\n property Items[Key: Integer]: Integer read GetValue write PutValue;\r\n {$IFNDEF BUGGY_DEFAULT_INDEXED_PROP} default; {$ENDIF ~BUGGY_DEFAULT_INDEXED_PROP}\r\n end;\r\n\r\n IJclCardinalIntfMap = interface(IJclBaseContainer)\r\n ['{80D39FB1-0D10-49CE-8AF3-1CD98A1D4F6C}']\r\n procedure Clear;\r\n function ContainsKey(Key: Cardinal): Boolean;\r\n function ContainsValue(const Value: IInterface): Boolean;\r\n function Extract(Key: Cardinal): IInterface;\r\n function GetValue(Key: Cardinal): IInterface;\r\n function IsEmpty: Boolean;\r\n function KeyOfValue(const Value: IInterface): Cardinal;\r\n function KeySet: IJclCardinalSet;\r\n function MapEquals(const AMap: IJclCardinalIntfMap): Boolean;\r\n procedure PutAll(const AMap: IJclCardinalIntfMap);\r\n procedure PutValue(Key: Cardinal; const Value: IInterface);\r\n function Remove(Key: Cardinal): IInterface;\r\n function Size: Integer;\r\n function Values: IJclIntfCollection;\r\n property Items[Key: Cardinal]: IInterface read GetValue write PutValue;\r\n {$IFNDEF BUGGY_DEFAULT_INDEXED_PROP} default; {$ENDIF ~BUGGY_DEFAULT_INDEXED_PROP}\r\n end;\r\n\r\n IJclIntfCardinalMap = interface(IJclBaseContainer)\r\n ['{E1A724AB-6BDA-45F0-AE21-5E7E789A751B}']\r\n procedure Clear;\r\n function ContainsKey(const Key: IInterface): Boolean;\r\n function ContainsValue(Value: Cardinal): Boolean;\r\n function Extract(const Key: IInterface): Cardinal;\r\n function GetValue(const Key: IInterface): Cardinal;\r\n function IsEmpty: Boolean;\r\n function KeyOfValue(Value: Cardinal): IInterface;\r\n function KeySet: IJclIntfSet;\r\n function MapEquals(const AMap: IJclIntfCardinalMap): Boolean;\r\n procedure PutAll(const AMap: IJclIntfCardinalMap);\r\n procedure PutValue(const Key: IInterface; Value: Cardinal);\r\n function Remove(const Key: IInterface): Cardinal;\r\n function Size: Integer;\r\n function Values: IJclCardinalCollection;\r\n property Items[const Key: IInterface]: Cardinal read GetValue write PutValue;\r\n {$IFNDEF BUGGY_DEFAULT_INDEXED_PROP} default; {$ENDIF ~BUGGY_DEFAULT_INDEXED_PROP}\r\n end;\r\n\r\n IJclCardinalCardinalMap = interface(IJclBaseContainer)\r\n ['{1CD3F54C-F92F-4AF4-82B2-0829C08AA83B}']\r\n procedure Clear;\r\n function ContainsKey(Key: Cardinal): Boolean;\r\n function ContainsValue(Value: Cardinal): Boolean;\r\n function Extract(Key: Cardinal): Cardinal;\r\n function GetValue(Key: Cardinal): Cardinal;\r\n function IsEmpty: Boolean;\r\n function KeyOfValue(Value: Cardinal): Cardinal;\r\n function KeySet: IJclCardinalSet;\r\n function MapEquals(const AMap: IJclCardinalCardinalMap): Boolean;\r\n procedure PutAll(const AMap: IJclCardinalCardinalMap);\r\n procedure PutValue(Key: Cardinal; Value: Cardinal);\r\n function Remove(Key: Cardinal): Cardinal;\r\n function Size: Integer;\r\n function Values: IJclCardinalCollection;\r\n property Items[Key: Cardinal]: Cardinal read GetValue write PutValue;\r\n {$IFNDEF BUGGY_DEFAULT_INDEXED_PROP} default; {$ENDIF ~BUGGY_DEFAULT_INDEXED_PROP}\r\n end;\r\n\r\n IJclInt64IntfMap = interface(IJclBaseContainer)\r\n ['{B64FB2D1-8D45-4367-B950-98D3D05AC6A0}']\r\n procedure Clear;\r\n function ContainsKey(const Key: Int64): Boolean;\r\n function ContainsValue(const Value: IInterface): Boolean;\r\n function Extract(const Key: Int64): IInterface;\r\n function GetValue(const Key: Int64): IInterface;\r\n function IsEmpty: Boolean;\r\n function KeyOfValue(const Value: IInterface): Int64;\r\n function KeySet: IJclInt64Set;\r\n function MapEquals(const AMap: IJclInt64IntfMap): Boolean;\r\n procedure PutAll(const AMap: IJclInt64IntfMap);\r\n procedure PutValue(const Key: Int64; const Value: IInterface);\r\n function Remove(const Key: Int64): IInterface;\r\n function Size: Integer;\r\n function Values: IJclIntfCollection;\r\n property Items[const Key: Int64]: IInterface read GetValue write PutValue;\r\n {$IFNDEF BUGGY_DEFAULT_INDEXED_PROP} default; {$ENDIF ~BUGGY_DEFAULT_INDEXED_PROP}\r\n end;\r\n\r\n IJclIntfInt64Map = interface(IJclBaseContainer)\r\n ['{9886BEE3-D15B-45D2-A3FB-4D3A0ADEC8AC}']\r\n procedure Clear;\r\n function ContainsKey(const Key: IInterface): Boolean;\r\n function ContainsValue(const Value: Int64): Boolean;\r\n function Extract(const Key: IInterface): Int64;\r\n function GetValue(const Key: IInterface): Int64;\r\n function IsEmpty: Boolean;\r\n function KeyOfValue(const Value: Int64): IInterface;\r\n function KeySet: IJclIntfSet;\r\n function MapEquals(const AMap: IJclIntfInt64Map): Boolean;\r\n procedure PutAll(const AMap: IJclIntfInt64Map);\r\n procedure PutValue(const Key: IInterface; const Value: Int64);\r\n function Remove(const Key: IInterface): Int64;\r\n function Size: Integer;\r\n function Values: IJclInt64Collection;\r\n property Items[const Key: IInterface]: Int64 read GetValue write PutValue;\r\n {$IFNDEF BUGGY_DEFAULT_INDEXED_PROP} default; {$ENDIF ~BUGGY_DEFAULT_INDEXED_PROP}\r\n end;\r\n\r\n IJclInt64Int64Map = interface(IJclBaseContainer)\r\n ['{EF2A2726-408A-4984-9971-DDC1B6EFC9F5}']\r\n procedure Clear;\r\n function ContainsKey(const Key: Int64): Boolean;\r\n function ContainsValue(const Value: Int64): Boolean;\r\n function Extract(const Key: Int64): Int64;\r\n function GetValue(const Key: Int64): Int64;\r\n function IsEmpty: Boolean;\r\n function KeyOfValue(const Value: Int64): Int64;\r\n function KeySet: IJclInt64Set;\r\n function MapEquals(const AMap: IJclInt64Int64Map): Boolean;\r\n procedure PutAll(const AMap: IJclInt64Int64Map);\r\n procedure PutValue(const Key: Int64; const Value: Int64);\r\n function Remove(const Key: Int64): Int64;\r\n function Size: Integer;\r\n function Values: IJclInt64Collection;\r\n property Items[const Key: Int64]: Int64 read GetValue write PutValue;\r\n {$IFNDEF BUGGY_DEFAULT_INDEXED_PROP} default; {$ENDIF ~BUGGY_DEFAULT_INDEXED_PROP}\r\n end;\r\n\r\n IJclPtrIntfMap = interface(IJclBaseContainer)\r\n ['{B7C48542-39A0-453F-8F03-8C8CFAB0DCCF}']\r\n procedure Clear;\r\n function ContainsKey(Key: Pointer): Boolean;\r\n function ContainsValue(const Value: IInterface): Boolean;\r\n function Extract(Key: Pointer): IInterface;\r\n function GetValue(Key: Pointer): IInterface;\r\n function IsEmpty: Boolean;\r\n function KeyOfValue(const Value: IInterface): Pointer;\r\n function KeySet: IJclPtrSet;\r\n function MapEquals(const AMap: IJclPtrIntfMap): Boolean;\r\n procedure PutAll(const AMap: IJclPtrIntfMap);\r\n procedure PutValue(Key: Pointer; const Value: IInterface);\r\n function Remove(Key: Pointer): IInterface;\r\n function Size: Integer;\r\n function Values: IJclIntfCollection;\r\n property Items[Key: Pointer]: IInterface read GetValue write PutValue;\r\n {$IFNDEF BUGGY_DEFAULT_INDEXED_PROP} default; {$ENDIF ~BUGGY_DEFAULT_INDEXED_PROP}\r\n end;\r\n\r\n IJclIntfPtrMap = interface(IJclBaseContainer)\r\n ['{DA51D823-58DB-4D7C-9B8E-07E0FD560B57}']\r\n procedure Clear;\r\n function ContainsKey(const Key: IInterface): Boolean;\r\n function ContainsValue(Value: Pointer): Boolean;\r\n function Extract(const Key: IInterface): Pointer;\r\n function GetValue(const Key: IInterface): Pointer;\r\n function IsEmpty: Boolean;\r\n function KeyOfValue(Value: Pointer): IInterface;\r\n function KeySet: IJclIntfSet;\r\n function MapEquals(const AMap: IJclIntfPtrMap): Boolean;\r\n procedure PutAll(const AMap: IJclIntfPtrMap);\r\n procedure PutValue(const Key: IInterface; Value: Pointer);\r\n function Remove(const Key: IInterface): Pointer;\r\n function Size: Integer;\r\n function Values: IJclPtrCollection;\r\n property Items[const Key: IInterface]: Pointer read GetValue write PutValue;\r\n {$IFNDEF BUGGY_DEFAULT_INDEXED_PROP} default; {$ENDIF ~BUGGY_DEFAULT_INDEXED_PROP}\r\n end;\r\n\r\n IJclPtrPtrMap = interface(IJclBaseContainer)\r\n ['{1200CB0F-A766-443F-9030-5A804C11B798}']\r\n procedure Clear;\r\n function ContainsKey(Key: Pointer): Boolean;\r\n function ContainsValue(Value: Pointer): Boolean;\r\n function Extract(Key: Pointer): Pointer;\r\n function GetValue(Key: Pointer): Pointer;\r\n function IsEmpty: Boolean;\r\n function KeyOfValue(Value: Pointer): Pointer;\r\n function KeySet: IJclPtrSet;\r\n function MapEquals(const AMap: IJclPtrPtrMap): Boolean;\r\n procedure PutAll(const AMap: IJclPtrPtrMap);\r\n procedure PutValue(Key: Pointer; Value: Pointer);\r\n function Remove(Key: Pointer): Pointer;\r\n function Size: Integer;\r\n function Values: IJclPtrCollection;\r\n property Items[Key: Pointer]: Pointer read GetValue write PutValue;\r\n {$IFNDEF BUGGY_DEFAULT_INDEXED_PROP} default; {$ENDIF ~BUGGY_DEFAULT_INDEXED_PROP}\r\n end;\r\n\r\n IJclIntfMap = interface(IJclBaseContainer)\r\n ['{C70570C6-EDDB-47B4-9003-C637B486731D}']\r\n procedure Clear;\r\n function ContainsKey(const Key: IInterface): Boolean;\r\n function ContainsValue(Value: TObject): Boolean;\r\n function Extract(const Key: IInterface): TObject;\r\n function GetValue(const Key: IInterface): TObject;\r\n function IsEmpty: Boolean;\r\n function KeyOfValue(Value: TObject): IInterface;\r\n function KeySet: IJclIntfSet;\r\n function MapEquals(const AMap: IJclIntfMap): Boolean;\r\n procedure PutAll(const AMap: IJclIntfMap);\r\n procedure PutValue(const Key: IInterface; Value: TObject);\r\n function Remove(const Key: IInterface): TObject;\r\n function Size: Integer;\r\n function Values: IJclCollection;\r\n property Items[const Key: IInterface]: TObject read GetValue write PutValue;\r\n {$IFNDEF BUGGY_DEFAULT_INDEXED_PROP} default; {$ENDIF ~BUGGY_DEFAULT_INDEXED_PROP}\r\n end;\r\n\r\n IJclAnsiStrMap = interface(IJclAnsiStrContainer)\r\n ['{A7D0A882-6952-496D-A258-23D47DDCCBC4}']\r\n procedure Clear;\r\n function ContainsKey(const Key: AnsiString): Boolean;\r\n function ContainsValue(Value: TObject): Boolean;\r\n function Extract(const Key: AnsiString): TObject;\r\n function GetValue(const Key: AnsiString): TObject;\r\n function IsEmpty: Boolean;\r\n function KeyOfValue(Value: TObject): AnsiString;\r\n function KeySet: IJclAnsiStrSet;\r\n function MapEquals(const AMap: IJclAnsiStrMap): Boolean;\r\n procedure PutAll(const AMap: IJclAnsiStrMap);\r\n procedure PutValue(const Key: AnsiString; Value: TObject);\r\n function Remove(const Key: AnsiString): TObject;\r\n function Size: Integer;\r\n function Values: IJclCollection;\r\n property Items[const Key: AnsiString]: TObject read GetValue write PutValue;\r\n {$IFNDEF BUGGY_DEFAULT_INDEXED_PROP} default; {$ENDIF ~BUGGY_DEFAULT_INDEXED_PROP}\r\n end;\r\n\r\n IJclWideStrMap = interface(IJclWideStrContainer)\r\n ['{ACE8E6B4-5A56-4753-A2C6-BAE195A56B63}']\r\n procedure Clear;\r\n function ContainsKey(const Key: WideString): Boolean;\r\n function ContainsValue(Value: TObject): Boolean;\r\n function Extract(const Key: WideString): TObject;\r\n function GetValue(const Key: WideString): TObject;\r\n function IsEmpty: Boolean;\r\n function KeyOfValue(Value: TObject): WideString;\r\n function KeySet: IJclWideStrSet;\r\n function MapEquals(const AMap: IJclWideStrMap): Boolean;\r\n procedure PutAll(const AMap: IJclWideStrMap);\r\n procedure PutValue(const Key: WideString; Value: TObject);\r\n function Remove(const Key: WideString): TObject;\r\n function Size: Integer;\r\n function Values: IJclCollection;\r\n property Items[const Key: WideString]: TObject read GetValue write PutValue;\r\n {$IFNDEF BUGGY_DEFAULT_INDEXED_PROP} default; {$ENDIF ~BUGGY_DEFAULT_INDEXED_PROP}\r\n end;\r\n\r\n {$IFDEF SUPPORTS_UNICODE_STRING}\r\n IJclUnicodeStrMap = interface(IJclUnicodeStrContainer)\r\n ['{4328E033-9B92-40C6-873D-A6982CFC2B95}']\r\n procedure Clear;\r\n function ContainsKey(const Key: UnicodeString): Boolean;\r\n function ContainsValue(Value: TObject): Boolean;\r\n function Extract(const Key: UnicodeString): TObject;\r\n function GetValue(const Key: UnicodeString): TObject;\r\n function IsEmpty: Boolean;\r\n function KeyOfValue(Value: TObject): UnicodeString;\r\n function KeySet: IJclUnicodeStrSet;\r\n function MapEquals(const AMap: IJclUnicodeStrMap): Boolean;\r\n procedure PutAll(const AMap: IJclUnicodeStrMap);\r\n procedure PutValue(const Key: UnicodeString; Value: TObject);\r\n function Remove(const Key: UnicodeString): TObject;\r\n function Size: Integer;\r\n function Values: IJclCollection;\r\n property Items[const Key: UnicodeString]: TObject read GetValue write PutValue;\r\n {$IFNDEF BUGGY_DEFAULT_INDEXED_PROP} default; {$ENDIF ~BUGGY_DEFAULT_INDEXED_PROP}\r\n end;\r\n {$ENDIF SUPPORTS_UNICODE_STRING}\r\n\r\n {$IFDEF CONTAINER_ANSISTR}\r\n IJclStrMap = IJclAnsiStrMap;\r\n {$ENDIF CONTAINER_ANSISTR}\r\n {$IFDEF CONTAINER_WIDESTR}\r\n IJclStrMap = IJclWideStrMap;\r\n {$ENDIF CONTAINER_WIDESTR}\r\n {$IFDEF CONTAINER_UNICODESTR}\r\n IJclStrMap = IJclUnicodeStrMap;\r\n {$ENDIF CONTAINER_UNICODESTR}\r\n\r\n IJclSingleMap = interface(IJclSingleContainer)\r\n ['{C501920A-F252-4F94-B142-1F05AE06C3D2}']\r\n procedure Clear;\r\n function ContainsKey(const Key: Single): Boolean;\r\n function ContainsValue(Value: TObject): Boolean;\r\n function Extract(const Key: Single): TObject;\r\n function GetValue(const Key: Single): TObject;\r\n function IsEmpty: Boolean;\r\n function KeyOfValue(Value: TObject): Single;\r\n function KeySet: IJclSingleSet;\r\n function MapEquals(const AMap: IJclSingleMap): Boolean;\r\n procedure PutAll(const AMap: IJclSingleMap);\r\n procedure PutValue(const Key: Single; Value: TObject);\r\n function Remove(const Key: Single): TObject;\r\n function Size: Integer;\r\n function Values: IJclCollection;\r\n property Items[const Key: Single]: TObject read GetValue write PutValue;\r\n {$IFNDEF BUGGY_DEFAULT_INDEXED_PROP} default; {$ENDIF ~BUGGY_DEFAULT_INDEXED_PROP}\r\n end;\r\n\r\n IJclDoubleMap = interface(IJclDoubleContainer)\r\n ['{B1B994AC-49C9-418B-814B-43BAD706F355}']\r\n procedure Clear;\r\n function ContainsKey(const Key: Double): Boolean;\r\n function ContainsValue(Value: TObject): Boolean;\r\n function Extract(const Key: Double): TObject;\r\n function GetValue(const Key: Double): TObject;\r\n function IsEmpty: Boolean;\r\n function KeyOfValue(Value: TObject): Double;\r\n function KeySet: IJclDoubleSet;\r\n function MapEquals(const AMap: IJclDoubleMap): Boolean;\r\n procedure PutAll(const AMap: IJclDoubleMap);\r\n procedure PutValue(const Key: Double; Value: TObject);\r\n function Remove(const Key: Double): TObject;\r\n function Size: Integer;\r\n function Values: IJclCollection;\r\n property Items[const Key: Double]: TObject read GetValue write PutValue;\r\n {$IFNDEF BUGGY_DEFAULT_INDEXED_PROP} default; {$ENDIF ~BUGGY_DEFAULT_INDEXED_PROP}\r\n end;\r\n\r\n IJclExtendedMap = interface(IJclExtendedContainer)\r\n ['{3BCC8C87-A186-45E8-9B37-0B8E85120434}']\r\n procedure Clear;\r\n function ContainsKey(const Key: Extended): Boolean;\r\n function ContainsValue(Value: TObject): Boolean;\r\n function Extract(const Key: Extended): TObject;\r\n function GetValue(const Key: Extended): TObject;\r\n function IsEmpty: Boolean;\r\n function KeyOfValue(Value: TObject): Extended;\r\n function KeySet: IJclExtendedSet;\r\n function MapEquals(const AMap: IJclExtendedMap): Boolean;\r\n procedure PutAll(const AMap: IJclExtendedMap);\r\n procedure PutValue(const Key: Extended; Value: TObject);\r\n function Remove(const Key: Extended): TObject;\r\n function Size: Integer;\r\n function Values: IJclCollection;\r\n property Items[const Key: Extended]: TObject read GetValue write PutValue;\r\n {$IFNDEF BUGGY_DEFAULT_INDEXED_PROP} default; {$ENDIF ~BUGGY_DEFAULT_INDEXED_PROP}\r\n end;\r\n\r\n {$IFDEF MATH_SINGLE_PRECISION}\r\n IJclFloatMap = IJclSingleMap;\r\n {$ENDIF MATH_SINGLE_PRECISION}\r\n {$IFDEF MATH_DOUBLE_PRECISION}\r\n IJclFloatMap = IJclDoubleMap;\r\n {$ENDIF MATH_DOUBLE_PRECISION}\r\n {$IFDEF MATH_EXTENDED_PRECISION}\r\n IJclFloatMap = IJclExtendedMap;\r\n {$ENDIF MATH_EXTENDED_PRECISION}\r\n\r\n IJclIntegerMap = interface(IJclBaseContainer)\r\n ['{D6FA5D64-A4AF-4419-9981-56BA79BF8770}']\r\n procedure Clear;\r\n function ContainsKey(Key: Integer): Boolean;\r\n function ContainsValue(Value: TObject): Boolean;\r\n function Extract(Key: Integer): TObject;\r\n function GetValue(Key: Integer): TObject;\r\n function IsEmpty: Boolean;\r\n function KeyOfValue(Value: TObject): Integer;\r\n function KeySet: IJclIntegerSet;\r\n function MapEquals(const AMap: IJclIntegerMap): Boolean;\r\n procedure PutAll(const AMap: IJclIntegerMap);\r\n procedure PutValue(Key: Integer; Value: TObject);\r\n function Remove(Key: Integer): TObject;\r\n function Size: Integer;\r\n function Values: IJclCollection;\r\n property Items[Key: Integer]: TObject read GetValue write PutValue;\r\n {$IFNDEF BUGGY_DEFAULT_INDEXED_PROP} default; {$ENDIF ~BUGGY_DEFAULT_INDEXED_PROP}\r\n end;\r\n\r\n IJclCardinalMap = interface(IJclBaseContainer)\r\n ['{A2F92F4F-11CB-4DB2-932F-F10A14237126}']\r\n procedure Clear;\r\n function ContainsKey(Key: Cardinal): Boolean;\r\n function ContainsValue(Value: TObject): Boolean;\r\n function Extract(Key: Cardinal): TObject;\r\n function GetValue(Key: Cardinal): TObject;\r\n function IsEmpty: Boolean;\r\n function KeyOfValue(Value: TObject): Cardinal;\r\n function KeySet: IJclCardinalSet;\r\n function MapEquals(const AMap: IJclCardinalMap): Boolean;\r\n procedure PutAll(const AMap: IJclCardinalMap);\r\n procedure PutValue(Key: Cardinal; Value: TObject);\r\n function Remove(Key: Cardinal): TObject;\r\n function Size: Integer;\r\n function Values: IJclCollection;\r\n property Items[Key: Cardinal]: TObject read GetValue write PutValue;\r\n {$IFNDEF BUGGY_DEFAULT_INDEXED_PROP} default; {$ENDIF ~BUGGY_DEFAULT_INDEXED_PROP}\r\n end;\r\n\r\n IJclInt64Map = interface(IJclBaseContainer)\r\n ['{4C720CE0-7A7C-41D5-BFC1-8D58A47E648F}']\r\n procedure Clear;\r\n function ContainsKey(const Key: Int64): Boolean;\r\n function ContainsValue(Value: TObject): Boolean;\r\n function Extract(const Key: Int64): TObject;\r\n function GetValue(const Key: Int64): TObject;\r\n function IsEmpty: Boolean;\r\n function KeyOfValue(Value: TObject): Int64;\r\n function KeySet: IJclInt64Set;\r\n function MapEquals(const AMap: IJclInt64Map): Boolean;\r\n procedure PutAll(const AMap: IJclInt64Map);\r\n procedure PutValue(const Key: Int64; Value: TObject);\r\n function Remove(const Key: Int64): TObject;\r\n function Size: Integer;\r\n function Values: IJclCollection;\r\n property Items[const Key: Int64]: TObject read GetValue write PutValue;\r\n {$IFNDEF BUGGY_DEFAULT_INDEXED_PROP} default; {$ENDIF ~BUGGY_DEFAULT_INDEXED_PROP}\r\n end;\r\n\r\n IJclPtrMap = interface(IJclBaseContainer)\r\n ['{2FE029A9-026C-487D-8204-AD3A28BD2FA2}']\r\n procedure Clear;\r\n function ContainsKey(Key: Pointer): Boolean;\r\n function ContainsValue(Value: TObject): Boolean;\r\n function Extract(Key: Pointer): TObject;\r\n function GetValue(Key: Pointer): TObject;\r\n function IsEmpty: Boolean;\r\n function KeyOfValue(Value: TObject): Pointer;\r\n function KeySet: IJclPtrSet;\r\n function MapEquals(const AMap: IJclPtrMap): Boolean;\r\n procedure PutAll(const AMap: IJclPtrMap);\r\n procedure PutValue(Key: Pointer; Value: TObject);\r\n function Remove(Key: Pointer): TObject;\r\n function Size: Integer;\r\n function Values: IJclCollection;\r\n property Items[Key: Pointer]: TObject read GetValue write PutValue;\r\n {$IFNDEF BUGGY_DEFAULT_INDEXED_PROP} default; {$ENDIF ~BUGGY_DEFAULT_INDEXED_PROP}\r\n end;\r\n\r\n IJclMap = interface(IJclBaseContainer)\r\n ['{A7D0A882-6952-496D-A258-23D47DDCCBC4}']\r\n procedure Clear;\r\n function ContainsKey(Key: TObject): Boolean;\r\n function ContainsValue(Value: TObject): Boolean;\r\n function Extract(Key: TObject): TObject;\r\n function GetValue(Key: TObject): TObject;\r\n function IsEmpty: Boolean;\r\n function KeyOfValue(Value: TObject): TObject;\r\n function KeySet: IJclSet;\r\n function MapEquals(const AMap: IJclMap): Boolean;\r\n procedure PutAll(const AMap: IJclMap);\r\n procedure PutValue(Key: TObject; Value: TObject);\r\n function Remove(Key: TObject): TObject;\r\n function Size: Integer;\r\n function Values: IJclCollection;\r\n property Items[Key: TObject]: TObject read GetValue write PutValue;\r\n {$IFNDEF BUGGY_DEFAULT_INDEXED_PROP} default; {$ENDIF ~BUGGY_DEFAULT_INDEXED_PROP}\r\n end;\r\n\r\n\r\n\r\n (*IJclMultiIntfIntfMap = interface(IJclIntfIntfMap)\r\n ['{497775A5-D3F1-49FC-A641-15CC9E77F3D0}']\r\n function GetValues(const Key: IInterface): IJclIntfIterator;\r\n function Count(const Key: IInterface): Integer;\r\n end;*)\r\n\r\n {$IFDEF SUPPORTS_GENERICS}\r\n //DOM-IGNORE-BEGIN\r\n IHashable = interface\r\n function GetHashCode: Integer;\r\n end;\r\n\r\n IJclMap = interface(IJclBaseContainer)\r\n ['{22624C43-4828-4A1E-BDD4-4A7FE59AE135}']\r\n procedure Clear;\r\n function ContainsKey(const Key: TKey): Boolean;\r\n function ContainsValue(const Value: TValue): Boolean;\r\n function Extract(const Key: TKey): TValue;\r\n function GetValue(const Key: TKey): TValue;\r\n function IsEmpty: Boolean;\r\n function KeyOfValue(const Value: TValue): TKey;\r\n function KeySet: IJclSet;\r\n function MapEquals(const AMap: IJclMap): Boolean;\r\n procedure PutAll(const AMap: IJclMap);\r\n procedure PutValue(const Key: TKey; const Value: TValue);\r\n function Remove(const Key: TKey): TValue;\r\n function Size: Integer;\r\n function Values: IJclCollection;\r\n property Items[const Key: TKey]: TValue read GetValue write PutValue;\r\n {$IFNDEF BUGGY_DEFAULT_INDEXED_PROP} default; {$ENDIF ~BUGGY_DEFAULT_INDEXED_PROP}\r\n end;\r\n\r\n //DOM-IGNORE-END\r\n {$ENDIF SUPPORTS_GENERICS}\r\n\r\n IJclIntfQueue = interface(IJclIntfContainer)\r\n ['{B88756FE-5553-4106-957E-3E33120BFA99}']\r\n procedure Clear;\r\n function Contains(const AInterface: IInterface): Boolean;\r\n function Dequeue: IInterface;\r\n function Empty: Boolean;\r\n function Enqueue(const AInterface: IInterface): Boolean;\r\n function Peek: IInterface;\r\n function Size: Integer;\r\n end;\r\n\r\n IJclAnsiStrQueue = interface(IJclAnsiStrContainer)\r\n ['{5BA0ED9A-5AF3-4F79-9D80-34FA7FF15D1F}']\r\n procedure Clear;\r\n function Contains(const AString: AnsiString): Boolean;\r\n function Dequeue: AnsiString;\r\n function Empty: Boolean;\r\n function Enqueue(const AString: AnsiString): Boolean;\r\n function Peek: AnsiString;\r\n function Size: Integer;\r\n end;\r\n\r\n IJclWideStrQueue = interface(IJclWideStrContainer)\r\n ['{058BBFB7-E9B9-44B5-B676-D5B5B9A79BEF}']\r\n procedure Clear;\r\n function Contains(const AString: WideString): Boolean;\r\n function Dequeue: WideString;\r\n function Empty: Boolean;\r\n function Enqueue(const AString: WideString): Boolean;\r\n function Peek: WideString;\r\n function Size: Integer;\r\n end;\r\n\r\n {$IFDEF SUPPORTS_UNICODE_STRING}\r\n IJclUnicodeStrQueue = interface(IJclUnicodeStrContainer)\r\n ['{94A09E52-424A-486E-846B-9C2C52DC3A8F}']\r\n procedure Clear;\r\n function Contains(const AString: UnicodeString): Boolean;\r\n function Dequeue: UnicodeString;\r\n function Empty: Boolean;\r\n function Enqueue(const AString: UnicodeString): Boolean;\r\n function Peek: UnicodeString;\r\n function Size: Integer;\r\n end;\r\n {$ENDIF SUPPORTS_UNICODE_STRING}\r\n\r\n {$IFDEF CONTAINER_ANSISTR}\r\n IJclStrQueue = IJclAnsiStrQueue;\r\n {$ENDIF CONTAINER_ANSISTR}\r\n {$IFDEF CONTAINER_WIDESTR}\r\n IJclStrQueue = IJclWideStrQueue;\r\n {$ENDIF CONTAINER_WIDESTR}\r\n {$IFDEF CONTAINER_UNICODESTR}\r\n IJclStrQueue = IJclUnicodeStrQueue;\r\n {$ENDIF CONTAINER_UNICODESTR}\r\n\r\n IJclSingleQueue = interface(IJclSingleContainer)\r\n ['{67D74314-9967-4C99-8A48-6E0ADD73EC29}']\r\n procedure Clear;\r\n function Contains(const AValue: Single): Boolean;\r\n function Dequeue: Single;\r\n function Empty: Boolean;\r\n function Enqueue(const AValue: Single): Boolean;\r\n function Peek: Single;\r\n function Size: Integer;\r\n end;\r\n\r\n IJclDoubleQueue = interface(IJclDoubleContainer)\r\n ['{FA1B6D25-3456-4963-87DC-5A2E53B2963F}']\r\n procedure Clear;\r\n function Contains(const AValue: Double): Boolean;\r\n function Dequeue: Double;\r\n function Empty: Boolean;\r\n function Enqueue(const AValue: Double): Boolean;\r\n function Peek: Double;\r\n function Size: Integer;\r\n end;\r\n\r\n IJclExtendedQueue = interface(IJclExtendedContainer)\r\n ['{76F349C0-7681-4BE8-9E94-280C962780D8}']\r\n procedure Clear;\r\n function Contains(const AValue: Extended): Boolean;\r\n function Dequeue: Extended;\r\n function Empty: Boolean;\r\n function Enqueue(const AValue: Extended): Boolean;\r\n function Peek: Extended;\r\n function Size: Integer;\r\n end;\r\n\r\n {$IFDEF MATH_SINGLE_PRECISION}\r\n IJclFloatQueue = IJclSingleQueue;\r\n {$ENDIF MATH_SINGLE_PRECISION}\r\n {$IFDEF MATH_DOUBLE_PRECISION}\r\n IJclFloatQueue = IJclDoubleQueue;\r\n {$ENDIF MATH_DOUBLE_PRECISION}\r\n {$IFDEF MATH_EXTENDED_PRECISION}\r\n IJclFloatQueue = IJclExtendedQueue;\r\n {$ENDIF MATH_EXTENDED_PRECISION}\r\n\r\n IJclIntegerQueue = interface(IJclIntegerContainer)\r\n ['{4C4E174E-5D19-44CE-A248-B5589A9B68DF}']\r\n procedure Clear;\r\n function Contains(AValue: Integer): Boolean;\r\n function Dequeue: Integer;\r\n function Empty: Boolean;\r\n function Enqueue(AValue: Integer): Boolean;\r\n function Peek: Integer;\r\n function Size: Integer;\r\n end;\r\n\r\n IJclCardinalQueue = interface(IJclCardinalContainer)\r\n ['{CC1D4358-E259-4FB0-BA83-5180A0F8A6C0}']\r\n procedure Clear;\r\n function Contains(AValue: Cardinal): Boolean;\r\n function Dequeue: Cardinal;\r\n function Empty: Boolean;\r\n function Enqueue(AValue: Cardinal): Boolean;\r\n function Peek: Cardinal;\r\n function Size: Integer;\r\n end;\r\n\r\n IJclInt64Queue = interface(IJclInt64Container)\r\n ['{96B620BB-9A90-43D5-82A7-2D818A11C8E1}']\r\n procedure Clear;\r\n function Contains(const AValue: Int64): Boolean;\r\n function Dequeue: Int64;\r\n function Empty: Boolean;\r\n function Enqueue(const AValue: Int64): Boolean;\r\n function Peek: Int64;\r\n function Size: Integer;\r\n end;\r\n\r\n IJclPtrQueue = interface(IJclPtrContainer)\r\n ['{1052DD37-3035-4C44-A793-54AC4B9C0B29}']\r\n procedure Clear;\r\n function Contains(APtr: Pointer): Boolean;\r\n function Dequeue: Pointer;\r\n function Empty: Boolean;\r\n function Enqueue(APtr: Pointer): Boolean;\r\n function Peek: Pointer;\r\n function Size: Integer;\r\n end;\r\n\r\n IJclQueue = interface(IJclContainer)\r\n ['{7D0F9DE4-71EA-46EF-B879-88BCFD5D9610}']\r\n procedure Clear;\r\n function Contains(AObject: TObject): Boolean;\r\n function Dequeue: TObject;\r\n function Empty: Boolean;\r\n function Enqueue(AObject: TObject): Boolean;\r\n function Peek: TObject;\r\n function Size: Integer;\r\n end;\r\n\r\n\r\n {$IFDEF SUPPORTS_GENERICS}\r\n //DOM-IGNORE-BEGIN\r\n IJclQueue = interface(IJclBaseContainer)\r\n ['{16AB909F-2194-46CF-BD89-B4207AC0CAB8}']\r\n procedure Clear;\r\n function Contains(const AItem: T): Boolean;\r\n function Dequeue: T;\r\n function Empty: Boolean;\r\n function Enqueue(const AItem: T): Boolean;\r\n function Peek: T;\r\n function Size: Integer;\r\n end;\r\n //DOM-IGNORE-END\r\n {$ENDIF SUPPORTS_GENERICS}\r\n\r\n IJclIntfIntfSortedMap = interface(IJclIntfIntfMap)\r\n ['{265A6EB2-4BB3-459F-8813-360FD32A4971}']\r\n function FirstKey: IInterface;\r\n function HeadMap(const ToKey: IInterface): IJclIntfIntfSortedMap;\r\n function LastKey: IInterface;\r\n function SubMap(const FromKey, ToKey: IInterface): IJclIntfIntfSortedMap;\r\n function TailMap(const FromKey: IInterface): IJclIntfIntfSortedMap;\r\n end;\r\n\r\n IJclAnsiStrIntfSortedMap = interface(IJclAnsiStrIntfMap)\r\n ['{706D1C91-5416-4FDC-B6B1-F4C1E8CFCD38}']\r\n function FirstKey: AnsiString;\r\n function HeadMap(const ToKey: AnsiString): IJclAnsiStrIntfSortedMap;\r\n function LastKey: AnsiString;\r\n function SubMap(const FromKey, ToKey: AnsiString): IJclAnsiStrIntfSortedMap;\r\n function TailMap(const FromKey: AnsiString): IJclAnsiStrIntfSortedMap;\r\n end;\r\n\r\n IJclIntfAnsiStrSortedMap = interface(IJclIntfAnsiStrMap)\r\n ['{96E6AC5E-8C40-4795-9C8A-CFD098B58680}']\r\n function FirstKey: IInterface;\r\n function HeadMap(const ToKey: IInterface): IJclIntfAnsiStrSortedMap;\r\n function LastKey: IInterface;\r\n function SubMap(const FromKey, ToKey: IInterface): IJclIntfAnsiStrSortedMap;\r\n function TailMap(const FromKey: IInterface): IJclIntfAnsiStrSortedMap;\r\n end;\r\n\r\n IJclAnsiStrAnsiStrSortedMap = interface(IJclAnsiStrAnsiStrMap)\r\n ['{4F457799-5D03-413D-A46C-067DC4200CC3}']\r\n function FirstKey: AnsiString;\r\n function HeadMap(const ToKey: AnsiString): IJclAnsiStrAnsiStrSortedMap;\r\n function LastKey: AnsiString;\r\n function SubMap(const FromKey, ToKey: AnsiString): IJclAnsiStrAnsiStrSortedMap;\r\n function TailMap(const FromKey: AnsiString): IJclAnsiStrAnsiStrSortedMap;\r\n end;\r\n\r\n IJclWideStrIntfSortedMap = interface(IJclWideStrIntfMap)\r\n ['{299FDCFD-2DB7-4D64-BF18-EE3668316430}']\r\n function FirstKey: WideString;\r\n function HeadMap(const ToKey: WideString): IJclWideStrIntfSortedMap;\r\n function LastKey: WideString;\r\n function SubMap(const FromKey, ToKey: WideString): IJclWideStrIntfSortedMap;\r\n function TailMap(const FromKey: WideString): IJclWideStrIntfSortedMap;\r\n end;\r\n\r\n IJclIntfWideStrSortedMap = interface(IJclIntfWideStrMap)\r\n ['{FBE3AD2E-2781-4DC0-9E80-027027380E21}']\r\n function FirstKey: IInterface;\r\n function HeadMap(const ToKey: IInterface): IJclIntfWideStrSortedMap;\r\n function LastKey: IInterface;\r\n function SubMap(const FromKey, ToKey: IInterface): IJclIntfWideStrSortedMap;\r\n function TailMap(const FromKey: IInterface): IJclIntfWideStrSortedMap;\r\n end;\r\n\r\n IJclWideStrWideStrSortedMap = interface(IJclWideStrWideStrMap)\r\n ['{3B0757B2-2290-4AFA-880D-F9BA600E501E}']\r\n function FirstKey: WideString;\r\n function HeadMap(const ToKey: WideString): IJclWideStrWideStrSortedMap;\r\n function LastKey: WideString;\r\n function SubMap(const FromKey, ToKey: WideString): IJclWideStrWideStrSortedMap;\r\n function TailMap(const FromKey: WideString): IJclWideStrWideStrSortedMap;\r\n end;\r\n\r\n {$IFDEF SUPPORTS_UNICODE_STRING}\r\n IJclUnicodeStrIntfSortedMap = interface(IJclUnicodeStrIntfMap)\r\n ['{25FDE916-730D-449A-BA29-852D8A0470B6}']\r\n function FirstKey: UnicodeString;\r\n function HeadMap(const ToKey: UnicodeString): IJclUnicodeStrIntfSortedMap;\r\n function LastKey: UnicodeString;\r\n function SubMap(const FromKey, ToKey: UnicodeString): IJclUnicodeStrIntfSortedMap;\r\n function TailMap(const FromKey: UnicodeString): IJclUnicodeStrIntfSortedMap;\r\n end;\r\n {$ENDIF SUPPORTS_UNICODE_STRING}\r\n\r\n {$IFDEF SUPPORTS_UNICODE_STRING}\r\n IJclIntfUnicodeStrSortedMap = interface(IJclIntfUnicodeStrMap)\r\n ['{B0B0CB9B-268B-40D2-94A8-0B8B5BE2E1AC}']\r\n function FirstKey: IInterface;\r\n function HeadMap(const ToKey: IInterface): IJclIntfUnicodeStrSortedMap;\r\n function LastKey: IInterface;\r\n function SubMap(const FromKey, ToKey: IInterface): IJclIntfUnicodeStrSortedMap;\r\n function TailMap(const FromKey: IInterface): IJclIntfUnicodeStrSortedMap;\r\n end;\r\n {$ENDIF SUPPORTS_UNICODE_STRING}\r\n\r\n {$IFDEF SUPPORTS_UNICODE_STRING}\r\n IJclUnicodeStrUnicodeStrSortedMap = interface(IJclUnicodeStrUnicodeStrMap)\r\n ['{D8EACC5D-B31E-47A8-9CC9-32B15A79CACA}']\r\n function FirstKey: UnicodeString;\r\n function HeadMap(const ToKey: UnicodeString): IJclUnicodeStrUnicodeStrSortedMap;\r\n function LastKey: UnicodeString;\r\n function SubMap(const FromKey, ToKey: UnicodeString): IJclUnicodeStrUnicodeStrSortedMap;\r\n function TailMap(const FromKey: UnicodeString): IJclUnicodeStrUnicodeStrSortedMap;\r\n end;\r\n {$ENDIF SUPPORTS_UNICODE_STRING}\r\n\r\n {$IFDEF CONTAINER_ANSISTR}\r\n IJclStrIntfSortedMap = IJclAnsiStrIntfSortedMap;\r\n {$ENDIF CONTAINER_ANSISTR}\r\n {$IFDEF CONTAINER_WIDESTR}\r\n IJclStrIntfSortedMap = IJclWideStrIntfSortedMap;\r\n {$ENDIF CONTAINER_WIDESTR}\r\n {$IFDEF CONTAINER_UNICODESTR}\r\n IJclStrIntfSortedMap = IJclUnicodeStrIntfSortedMap;\r\n {$ENDIF CONTAINER_UNICODESTR}\r\n\r\n {$IFDEF CONTAINER_ANSISTR}\r\n IJclIntfStrSortedMap = IJclIntfAnsiStrSortedMap;\r\n {$ENDIF CONTAINER_ANSISTR}\r\n {$IFDEF CONTAINER_WIDESTR}\r\n IJclIntfStrSortedMap = IJclIntfWideStrSortedMap;\r\n {$ENDIF CONTAINER_WIDESTR}\r\n {$IFDEF CONTAINER_UNICODESTR}\r\n IJclIntfStrSortedMap = IJclIntfUnicodeStrSortedMap;\r\n {$ENDIF CONTAINER_UNICODESTR}\r\n\r\n {$IFDEF CONTAINER_ANSISTR}\r\n IJclStrStrSortedMap = IJclAnsiStrAnsiStrSortedMap;\r\n {$ENDIF CONTAINER_ANSISTR}\r\n {$IFDEF CONTAINER_WIDESTR}\r\n IJclStrStrSortedMap = IJclWideStrWideStrSortedMap;\r\n {$ENDIF CONTAINER_WIDESTR}\r\n {$IFDEF CONTAINER_UNICODESTR}\r\n IJclStrStrSortedMap = IJclUnicodeStrUnicodeStrSortedMap;\r\n {$ENDIF CONTAINER_UNICODESTR}\r\n\r\n IJclSingleIntfSortedMap = interface(IJclSingleIntfMap)\r\n ['{83D57068-7B8E-453E-B35B-2AB4B594A7A9}']\r\n function FirstKey: Single;\r\n function HeadMap(const ToKey: Single): IJclSingleIntfSortedMap;\r\n function LastKey: Single;\r\n function SubMap(const FromKey, ToKey: Single): IJclSingleIntfSortedMap;\r\n function TailMap(const FromKey: Single): IJclSingleIntfSortedMap;\r\n end;\r\n\r\n IJclIntfSingleSortedMap = interface(IJclIntfSingleMap)\r\n ['{B07FA192-3466-4F2A-BBF0-2DC0100B08A8}']\r\n function FirstKey: IInterface;\r\n function HeadMap(const ToKey: IInterface): IJclIntfSingleSortedMap;\r\n function LastKey: IInterface;\r\n function SubMap(const FromKey, ToKey: IInterface): IJclIntfSingleSortedMap;\r\n function TailMap(const FromKey: IInterface): IJclIntfSingleSortedMap;\r\n end;\r\n\r\n IJclSingleSingleSortedMap = interface(IJclSingleSingleMap)\r\n ['{7C6EA0B4-959D-44D5-915F-99DFC1753B00}']\r\n function FirstKey: Single;\r\n function HeadMap(const ToKey: Single): IJclSingleSingleSortedMap;\r\n function LastKey: Single;\r\n function SubMap(const FromKey, ToKey: Single): IJclSingleSingleSortedMap;\r\n function TailMap(const FromKey: Single): IJclSingleSingleSortedMap;\r\n end;\r\n\r\n IJclDoubleIntfSortedMap = interface(IJclDoubleIntfMap)\r\n ['{F36C5F4F-4F8C-4943-AA35-41623D3C21E9}']\r\n function FirstKey: Double;\r\n function HeadMap(const ToKey: Double): IJclDoubleIntfSortedMap;\r\n function LastKey: Double;\r\n function SubMap(const FromKey, ToKey: Double): IJclDoubleIntfSortedMap;\r\n function TailMap(const FromKey: Double): IJclDoubleIntfSortedMap;\r\n end;\r\n\r\n IJclIntfDoubleSortedMap = interface(IJclIntfDoubleMap)\r\n ['{0F16ADAE-F499-4857-B5EA-6F3CC9009DBA}']\r\n function FirstKey: IInterface;\r\n function HeadMap(const ToKey: IInterface): IJclIntfDoubleSortedMap;\r\n function LastKey: IInterface;\r\n function SubMap(const FromKey, ToKey: IInterface): IJclIntfDoubleSortedMap;\r\n function TailMap(const FromKey: IInterface): IJclIntfDoubleSortedMap;\r\n end;\r\n\r\n IJclDoubleDoubleSortedMap = interface(IJclDoubleDoubleMap)\r\n ['{855C858B-74CF-4338-872B-AF88A02DB537}']\r\n function FirstKey: Double;\r\n function HeadMap(const ToKey: Double): IJclDoubleDoubleSortedMap;\r\n function LastKey: Double;\r\n function SubMap(const FromKey, ToKey: Double): IJclDoubleDoubleSortedMap;\r\n function TailMap(const FromKey: Double): IJclDoubleDoubleSortedMap;\r\n end;\r\n\r\n IJclExtendedIntfSortedMap = interface(IJclExtendedIntfMap)\r\n ['{A30B8835-A319-4776-9A11-D1EEF60B9C26}']\r\n function FirstKey: Extended;\r\n function HeadMap(const ToKey: Extended): IJclExtendedIntfSortedMap;\r\n function LastKey: Extended;\r\n function SubMap(const FromKey, ToKey: Extended): IJclExtendedIntfSortedMap;\r\n function TailMap(const FromKey: Extended): IJclExtendedIntfSortedMap;\r\n end;\r\n\r\n IJclIntfExtendedSortedMap = interface(IJclIntfExtendedMap)\r\n ['{3493D6C4-3075-48B6-8E99-CB0000D3978C}']\r\n function FirstKey: IInterface;\r\n function HeadMap(const ToKey: IInterface): IJclIntfExtendedSortedMap;\r\n function LastKey: IInterface;\r\n function SubMap(const FromKey, ToKey: IInterface): IJclIntfExtendedSortedMap;\r\n function TailMap(const FromKey: IInterface): IJclIntfExtendedSortedMap;\r\n end;\r\n\r\n IJclExtendedExtendedSortedMap = interface(IJclExtendedExtendedMap)\r\n ['{8CAA505C-D9BB-47E7-92EC-6043DC4AF42C}']\r\n function FirstKey: Extended;\r\n function HeadMap(const ToKey: Extended): IJclExtendedExtendedSortedMap;\r\n function LastKey: Extended;\r\n function SubMap(const FromKey, ToKey: Extended): IJclExtendedExtendedSortedMap;\r\n function TailMap(const FromKey: Extended): IJclExtendedExtendedSortedMap;\r\n end;\r\n\r\n {$IFDEF MATH_SINGLE_PRECISION}\r\n IJclFloatIntfSortedMap = IJclSingleIntfSortedMap;\r\n {$ENDIF MATH_SINGLE_PRECISION}\r\n {$IFDEF MATH_DOUBLE_PRECISION}\r\n IJclFloatIntfSortedMap = IJclDoubleIntfSortedMap;\r\n {$ENDIF MATH_DOUBLE_PRECISION}\r\n {$IFDEF MATH_EXTENDED_PRECISION}\r\n IJclFloatIntfSortedMap = IJclExtendedIntfSortedMap;\r\n {$ENDIF MATH_EXTENDED_PRECISION}\r\n\r\n {$IFDEF MATH_SINGLE_PRECISION}\r\n IJclIntfFloatSortedMap = IJclIntfSingleSortedMap;\r\n {$ENDIF MATH_SINGLE_PRECISION}\r\n {$IFDEF MATH_DOUBLE_PRECISION}\r\n IJclIntfFloatSortedMap = IJclIntfDoubleSortedMap;\r\n {$ENDIF MATH_DOUBLE_PRECISION}\r\n {$IFDEF MATH_EXTENDED_PRECISION}\r\n IJclIntfFloatSortedMap = IJclIntfExtendedSortedMap;\r\n {$ENDIF MATH_EXTENDED_PRECISION}\r\n\r\n {$IFDEF MATH_SINGLE_PRECISION}\r\n IJclFloatFloatSortedMap = IJclSingleSingleSortedMap;\r\n {$ENDIF MATH_SINGLE_PRECISION}\r\n {$IFDEF MATH_DOUBLE_PRECISION}\r\n IJclFloatFloatSortedMap = IJclDoubleDoubleSortedMap;\r\n {$ENDIF MATH_DOUBLE_PRECISION}\r\n {$IFDEF MATH_EXTENDED_PRECISION}\r\n IJclFloatFloatSortedMap = IJclExtendedExtendedSortedMap;\r\n {$ENDIF MATH_EXTENDED_PRECISION}\r\n\r\n IJclIntegerIntfSortedMap = interface(IJclIntegerIntfMap)\r\n ['{8B22802C-61F2-4DA5-B1E9-DBB7840E7996}']\r\n function FirstKey: Integer;\r\n function HeadMap(ToKey: Integer): IJclIntegerIntfSortedMap;\r\n function LastKey: Integer;\r\n function SubMap(FromKey, ToKey: Integer): IJclIntegerIntfSortedMap;\r\n function TailMap(FromKey: Integer): IJclIntegerIntfSortedMap;\r\n end;\r\n\r\n IJclIntfIntegerSortedMap = interface(IJclIntfIntegerMap)\r\n ['{8D3C9B7E-772D-409B-A58C-0CABFAFDEFF0}']\r\n function FirstKey: IInterface;\r\n function HeadMap(const ToKey: IInterface): IJclIntfIntegerSortedMap;\r\n function LastKey: IInterface;\r\n function SubMap(const FromKey, ToKey: IInterface): IJclIntfIntegerSortedMap;\r\n function TailMap(const FromKey: IInterface): IJclIntfIntegerSortedMap;\r\n end;\r\n\r\n IJclIntegerIntegerSortedMap = interface(IJclIntegerIntegerMap)\r\n ['{8A8BA17A-F468-469C-AF99-77D64C802F7A}']\r\n function FirstKey: Integer;\r\n function HeadMap(ToKey: Integer): IJclIntegerIntegerSortedMap;\r\n function LastKey: Integer;\r\n function SubMap(FromKey, ToKey: Integer): IJclIntegerIntegerSortedMap;\r\n function TailMap(FromKey: Integer): IJclIntegerIntegerSortedMap;\r\n end;\r\n\r\n IJclCardinalIntfSortedMap = interface(IJclCardinalIntfMap)\r\n ['{BAE97425-4F2E-461B-88DD-F83D27657AFA}']\r\n function FirstKey: Cardinal;\r\n function HeadMap(ToKey: Cardinal): IJclCardinalIntfSortedMap;\r\n function LastKey: Cardinal;\r\n function SubMap(FromKey, ToKey: Cardinal): IJclCardinalIntfSortedMap;\r\n function TailMap(FromKey: Cardinal): IJclCardinalIntfSortedMap;\r\n end;\r\n\r\n IJclIntfCardinalSortedMap = interface(IJclIntfCardinalMap)\r\n ['{BC66BACF-23AE-48C4-9573-EDC3B5110BE7}']\r\n function FirstKey: IInterface;\r\n function HeadMap(const ToKey: IInterface): IJclIntfCardinalSortedMap;\r\n function LastKey: IInterface;\r\n function SubMap(const FromKey, ToKey: IInterface): IJclIntfCardinalSortedMap;\r\n function TailMap(const FromKey: IInterface): IJclIntfCardinalSortedMap;\r\n end;\r\n\r\n IJclCardinalCardinalSortedMap = interface(IJclCardinalCardinalMap)\r\n ['{182ACDA4-7D74-4D29-BB5C-4C8189DA774E}']\r\n function FirstKey: Cardinal;\r\n function HeadMap(ToKey: Cardinal): IJclCardinalCardinalSortedMap;\r\n function LastKey: Cardinal;\r\n function SubMap(FromKey, ToKey: Cardinal): IJclCardinalCardinalSortedMap;\r\n function TailMap(FromKey: Cardinal): IJclCardinalCardinalSortedMap;\r\n end;\r\n\r\n IJclInt64IntfSortedMap = interface(IJclInt64IntfMap)\r\n ['{24391756-FB02-4901-81E3-A37738B73DAD}']\r\n function FirstKey: Int64;\r\n function HeadMap(const ToKey: Int64): IJclInt64IntfSortedMap;\r\n function LastKey: Int64;\r\n function SubMap(const FromKey, ToKey: Int64): IJclInt64IntfSortedMap;\r\n function TailMap(const FromKey: Int64): IJclInt64IntfSortedMap;\r\n end;\r\n\r\n IJclIntfInt64SortedMap = interface(IJclIntfInt64Map)\r\n ['{6E2AB647-59CC-4609-82E8-6AE75AED80CA}']\r\n function FirstKey: IInterface;\r\n function HeadMap(const ToKey: IInterface): IJclIntfInt64SortedMap;\r\n function LastKey: IInterface;\r\n function SubMap(const FromKey, ToKey: IInterface): IJclIntfInt64SortedMap;\r\n function TailMap(const FromKey: IInterface): IJclIntfInt64SortedMap;\r\n end;\r\n\r\n IJclInt64Int64SortedMap = interface(IJclInt64Int64Map)\r\n ['{168581D2-9DD3-46D0-934E-EA0CCE5E3C0C}']\r\n function FirstKey: Int64;\r\n function HeadMap(const ToKey: Int64): IJclInt64Int64SortedMap;\r\n function LastKey: Int64;\r\n function SubMap(const FromKey, ToKey: Int64): IJclInt64Int64SortedMap;\r\n function TailMap(const FromKey: Int64): IJclInt64Int64SortedMap;\r\n end;\r\n\r\n IJclPtrIntfSortedMap = interface(IJclPtrIntfMap)\r\n ['{6D7B8042-3CBC-4C8F-98B5-69AFAA104532}']\r\n function FirstKey: Pointer;\r\n function HeadMap(ToKey: Pointer): IJclPtrIntfSortedMap;\r\n function LastKey: Pointer;\r\n function SubMap(FromKey, ToKey: Pointer): IJclPtrIntfSortedMap;\r\n function TailMap(FromKey: Pointer): IJclPtrIntfSortedMap;\r\n end;\r\n\r\n IJclIntfPtrSortedMap = interface(IJclIntfPtrMap)\r\n ['{B054BDA2-536F-4C16-B6BB-BB64FA0818B3}']\r\n function FirstKey: IInterface;\r\n function HeadMap(const ToKey: IInterface): IJclIntfPtrSortedMap;\r\n function LastKey: IInterface;\r\n function SubMap(const FromKey, ToKey: IInterface): IJclIntfPtrSortedMap;\r\n function TailMap(const FromKey: IInterface): IJclIntfPtrSortedMap;\r\n end;\r\n\r\n IJclPtrPtrSortedMap = interface(IJclPtrPtrMap)\r\n ['{F1FAE922-0212-41D0-BB4E-76A8AB2CAB86}']\r\n function FirstKey: Pointer;\r\n function HeadMap(ToKey: Pointer): IJclPtrPtrSortedMap;\r\n function LastKey: Pointer;\r\n function SubMap(FromKey, ToKey: Pointer): IJclPtrPtrSortedMap;\r\n function TailMap(FromKey: Pointer): IJclPtrPtrSortedMap;\r\n end;\r\n\r\n IJclIntfSortedMap = interface(IJclIntfMap)\r\n ['{3CED1477-B958-4109-9BDA-7C84B9E063B2}']\r\n function FirstKey: IInterface;\r\n function HeadMap(const ToKey: IInterface): IJclIntfSortedMap;\r\n function LastKey: IInterface;\r\n function SubMap(const FromKey, ToKey: IInterface): IJclIntfSortedMap;\r\n function TailMap(const FromKey: IInterface): IJclIntfSortedMap;\r\n end;\r\n\r\n IJclAnsiStrSortedMap = interface(IJclAnsiStrMap)\r\n ['{573F98E3-EBCD-4F28-8F35-96A7366CBF47}']\r\n function FirstKey: AnsiString;\r\n function HeadMap(const ToKey: AnsiString): IJclAnsiStrSortedMap;\r\n function LastKey: AnsiString;\r\n function SubMap(const FromKey, ToKey: AnsiString): IJclAnsiStrSortedMap;\r\n function TailMap(const FromKey: AnsiString): IJclAnsiStrSortedMap;\r\n end;\r\n\r\n IJclWideStrSortedMap = interface(IJclWideStrMap)\r\n ['{B3021EFC-DE25-4B4B-A896-ACE823CD5C01}']\r\n function FirstKey: WideString;\r\n function HeadMap(const ToKey: WideString): IJclWideStrSortedMap;\r\n function LastKey: WideString;\r\n function SubMap(const FromKey, ToKey: WideString): IJclWideStrSortedMap;\r\n function TailMap(const FromKey: WideString): IJclWideStrSortedMap;\r\n end;\r\n\r\n {$IFDEF SUPPORTS_UNICODE_STRING}\r\n IJclUnicodeStrSortedMap = interface(IJclUnicodeStrMap)\r\n ['{5510B8FC-3439-4211-8D1F-5EDD9A56D3E3}']\r\n function FirstKey: UnicodeString;\r\n function HeadMap(const ToKey: UnicodeString): IJclUnicodeStrSortedMap;\r\n function LastKey: UnicodeString;\r\n function SubMap(const FromKey, ToKey: UnicodeString): IJclUnicodeStrSortedMap;\r\n function TailMap(const FromKey: UnicodeString): IJclUnicodeStrSortedMap;\r\n end;\r\n {$ENDIF SUPPORTS_UNICODE_STRING}\r\n\r\n {$IFDEF CONTAINER_ANSISTR}\r\n IJclStrSortedMap = IJclAnsiStrSortedMap;\r\n {$ENDIF CONTAINER_ANSISTR}\r\n {$IFDEF CONTAINER_WIDESTR}\r\n IJclStrSortedMap = IJclWideStrSortedMap;\r\n {$ENDIF CONTAINER_WIDESTR}\r\n {$IFDEF CONTAINER_UNICODESTR}\r\n IJclStrSortedMap = IJclUnicodeStrSortedMap;\r\n {$ENDIF CONTAINER_UNICODESTR}\r\n\r\n IJclSingleSortedMap = interface(IJclSingleMap)\r\n ['{8C1A12BE-A7F2-4351-90B7-25DB0AAF5F94}']\r\n function FirstKey: Single;\r\n function HeadMap(const ToKey: Single): IJclSingleSortedMap;\r\n function LastKey: Single;\r\n function SubMap(const FromKey, ToKey: Single): IJclSingleSortedMap;\r\n function TailMap(const FromKey: Single): IJclSingleSortedMap;\r\n end;\r\n\r\n IJclDoubleSortedMap = interface(IJclDoubleMap)\r\n ['{8018D66B-AA54-4016-84FC-3E780FFCC38B}']\r\n function FirstKey: Double;\r\n function HeadMap(const ToKey: Double): IJclDoubleSortedMap;\r\n function LastKey: Double;\r\n function SubMap(const FromKey, ToKey: Double): IJclDoubleSortedMap;\r\n function TailMap(const FromKey: Double): IJclDoubleSortedMap;\r\n end;\r\n\r\n IJclExtendedSortedMap = interface(IJclExtendedMap)\r\n ['{2B82C65A-B3EF-477D-BEC0-3D8620A226B1}']\r\n function FirstKey: Extended;\r\n function HeadMap(const ToKey: Extended): IJclExtendedSortedMap;\r\n function LastKey: Extended;\r\n function SubMap(const FromKey, ToKey: Extended): IJclExtendedSortedMap;\r\n function TailMap(const FromKey: Extended): IJclExtendedSortedMap;\r\n end;\r\n\r\n {$IFDEF MATH_SINGLE_PRECISION}\r\n IJclFloatSortedMap = IJclSingleSortedMap;\r\n {$ENDIF MATH_SINGLE_PRECISION}\r\n {$IFDEF MATH_DOUBLE_PRECISION}\r\n IJclFloatSortedMap = IJclDoubleSortedMap;\r\n {$ENDIF MATH_DOUBLE_PRECISION}\r\n {$IFDEF MATH_EXTENDED_PRECISION}\r\n IJclFloatSortedMap = IJclExtendedSortedMap;\r\n {$ENDIF MATH_EXTENDED_PRECISION}\r\n\r\n IJclIntegerSortedMap = interface(IJclIntegerMap)\r\n ['{DD7B4C5E-6D51-44CC-9328-B38396A7E1C9}']\r\n function FirstKey: Integer;\r\n function HeadMap(ToKey: Integer): IJclIntegerSortedMap;\r\n function LastKey: Integer;\r\n function SubMap(FromKey, ToKey: Integer): IJclIntegerSortedMap;\r\n function TailMap(FromKey: Integer): IJclIntegerSortedMap;\r\n end;\r\n\r\n IJclCardinalSortedMap = interface(IJclCardinalMap)\r\n ['{4AEAF81F-D72E-4499-B10E-3D017F39915E}']\r\n function FirstKey: Cardinal;\r\n function HeadMap(ToKey: Cardinal): IJclCardinalSortedMap;\r\n function LastKey: Cardinal;\r\n function SubMap(FromKey, ToKey: Cardinal): IJclCardinalSortedMap;\r\n function TailMap(FromKey: Cardinal): IJclCardinalSortedMap;\r\n end;\r\n\r\n IJclInt64SortedMap = interface(IJclInt64Map)\r\n ['{06C03F90-7DE9-4043-AA56-AAE071D8BD50}']\r\n function FirstKey: Int64;\r\n function HeadMap(const ToKey: Int64): IJclInt64SortedMap;\r\n function LastKey: Int64;\r\n function SubMap(const FromKey, ToKey: Int64): IJclInt64SortedMap;\r\n function TailMap(const FromKey: Int64): IJclInt64SortedMap;\r\n end;\r\n\r\n IJclPtrSortedMap = interface(IJclPtrMap)\r\n ['{578918DB-6A4A-4A9D-B44E-AE3E8FF70818}']\r\n function FirstKey: Pointer;\r\n function HeadMap(ToKey: Pointer): IJclPtrSortedMap;\r\n function LastKey: Pointer;\r\n function SubMap(FromKey, ToKey: Pointer): IJclPtrSortedMap;\r\n function TailMap(FromKey: Pointer): IJclPtrSortedMap;\r\n end;\r\n\r\n IJclSortedMap = interface(IJclMap)\r\n ['{F317A70F-7851-49C2-9DCF-092D8F4D4F98}']\r\n function FirstKey: TObject;\r\n function HeadMap(ToKey: TObject): IJclSortedMap;\r\n function LastKey: TObject;\r\n function SubMap(FromKey, ToKey: TObject): IJclSortedMap;\r\n function TailMap(FromKey: TObject): IJclSortedMap;\r\n end;\r\n\r\n\r\n\r\n {$IFDEF SUPPORTS_GENERICS}\r\n //DOM-IGNORE-BEGIN\r\n IJclSortedMap = interface(IJclMap)\r\n ['{C62B75C4-891B-442E-A5D6-9954E75A5C0C}']\r\n function FirstKey: TKey;\r\n function HeadMap(const ToKey: TKey): IJclSortedMap;\r\n function LastKey: TKey;\r\n function SubMap(const FromKey, ToKey: TKey): IJclSortedMap;\r\n function TailMap(const FromKey: TKey): IJclSortedMap;\r\n end;\r\n //DOM-IGNORE-END\r\n {$ENDIF SUPPORTS_GENERICS}\r\n\r\n IJclIntfSortedSet = interface(IJclIntfSet)\r\n ['{159BE5A7-7349-42FF-BE55-9CA1B9DBA991}']\r\n function HeadSet(const Finish: IInterface): IJclIntfSortedSet;\r\n function SubSet(const Start, Finish: IInterface): IJclIntfSortedSet;\r\n function TailSet(const Start: IInterface): IJclIntfSortedSet;\r\n end;\r\n\r\n IJclAnsiStrSortedSet = interface(IJclAnsiStrSet)\r\n ['{03198146-F967-4310-868B-7AD3D52D5CBE}']\r\n function HeadSet(const Finish: AnsiString): IJclAnsiStrSortedSet;\r\n function SubSet(const Start, Finish: AnsiString): IJclAnsiStrSortedSet;\r\n function TailSet(const Start: AnsiString): IJclAnsiStrSortedSet;\r\n end;\r\n\r\n IJclWideStrSortedSet = interface(IJclWideStrSet)\r\n ['{ED9567E2-C1D3-4C00-A1D4-90D5C7E27C2D}']\r\n function HeadSet(const Finish: WideString): IJclWideStrSortedSet;\r\n function SubSet(const Start, Finish: WideString): IJclWideStrSortedSet;\r\n function TailSet(const Start: WideString): IJclWideStrSortedSet;\r\n end;\r\n\r\n {$IFDEF SUPPORTS_UNICODE_STRING}\r\n IJclUnicodeStrSortedSet = interface(IJclUnicodeStrSet)\r\n ['{172BCD6F-D23C-4014-9C8C-A77A27D6E881}']\r\n function HeadSet(const Finish: UnicodeString): IJclUnicodeStrSortedSet;\r\n function SubSet(const Start, Finish: UnicodeString): IJclUnicodeStrSortedSet;\r\n function TailSet(const Start: UnicodeString): IJclUnicodeStrSortedSet;\r\n end;\r\n {$ENDIF SUPPORTS_UNICODE_STRING}\r\n\r\n {$IFDEF CONTAINER_ANSISTR}\r\n IJclStrSortedSet = IJclAnsiStrSortedSet;\r\n {$ENDIF CONTAINER_ANSISTR}\r\n {$IFDEF CONTAINER_WIDESTR}\r\n IJclStrSortedSet = IJclWideStrSortedSet;\r\n {$ENDIF CONTAINER_WIDESTR}\r\n {$IFDEF CONTAINER_UNICODESTR}\r\n IJclStrSortedSet = IJclUnicodeStrSortedSet;\r\n {$ENDIF CONTAINER_UNICODESTR}\r\n\r\n IJclSingleSortedSet = interface(IJclSingleSet)\r\n ['{65EDA801-9E04-4119-BF9E-D7DD4AF82144}']\r\n function HeadSet(const Finish: Single): IJclSingleSortedSet;\r\n function SubSet(const Start, Finish: Single): IJclSingleSortedSet;\r\n function TailSet(const Start: Single): IJclSingleSortedSet;\r\n end;\r\n\r\n IJclDoubleSortedSet = interface(IJclDoubleSet)\r\n ['{DA0E689F-BAFE-4BCE-85E4-C38E780BC84C}']\r\n function HeadSet(const Finish: Double): IJclDoubleSortedSet;\r\n function SubSet(const Start, Finish: Double): IJclDoubleSortedSet;\r\n function TailSet(const Start: Double): IJclDoubleSortedSet;\r\n end;\r\n\r\n IJclExtendedSortedSet = interface(IJclExtendedSet)\r\n ['{A9875ED3-81A4-43A3-86BB-3429F51B278B}']\r\n function HeadSet(const Finish: Extended): IJclExtendedSortedSet;\r\n function SubSet(const Start, Finish: Extended): IJclExtendedSortedSet;\r\n function TailSet(const Start: Extended): IJclExtendedSortedSet;\r\n end;\r\n\r\n {$IFDEF MATH_SINGLE_PRECISION}\r\n IJclFloatSortedSet = IJclSingleSortedSet;\r\n {$ENDIF MATH_SINGLE_PRECISION}\r\n {$IFDEF MATH_DOUBLE_PRECISION}\r\n IJclFloatSortedSet = IJclDoubleSortedSet;\r\n {$ENDIF MATH_DOUBLE_PRECISION}\r\n {$IFDEF MATH_EXTENDED_PRECISION}\r\n IJclFloatSortedSet = IJclExtendedSortedSet;\r\n {$ENDIF MATH_EXTENDED_PRECISION}\r\n\r\n IJclIntegerSortedSet = interface(IJclIntegerSet)\r\n ['{E086C54B-4FA3-426D-AC4E-FF8E8CA3D663}']\r\n function HeadSet(Finish: Integer): IJclIntegerSortedSet;\r\n function SubSet(Start, Finish: Integer): IJclIntegerSortedSet;\r\n function TailSet(Start: Integer): IJclIntegerSortedSet;\r\n end;\r\n\r\n IJclCardinalSortedSet = interface(IJclCardinalSet)\r\n ['{2D7995C6-A784-48B6-87E9-55D394A72362}']\r\n function HeadSet(Finish: Cardinal): IJclCardinalSortedSet;\r\n function SubSet(Start, Finish: Cardinal): IJclCardinalSortedSet;\r\n function TailSet(Start: Cardinal): IJclCardinalSortedSet;\r\n end;\r\n\r\n IJclInt64SortedSet = interface(IJclInt64Set)\r\n ['{4C1C3FCA-6169-4A2F-B044-91AC2AA2E954}']\r\n function HeadSet(const Finish: Int64): IJclInt64SortedSet;\r\n function SubSet(const Start, Finish: Int64): IJclInt64SortedSet;\r\n function TailSet(const Start: Int64): IJclInt64SortedSet;\r\n end;\r\n\r\n IJclPtrSortedSet = interface(IJclPtrSet)\r\n ['{F3A3183C-0820-425C-9446-E0838F0ADAD8}']\r\n function HeadSet(Finish: Pointer): IJclPtrSortedSet;\r\n function SubSet(Start, Finish: Pointer): IJclPtrSortedSet;\r\n function TailSet(Start: Pointer): IJclPtrSortedSet;\r\n end;\r\n\r\n IJclSortedSet = interface(IJclSet)\r\n ['{A3D23E76-ADE9-446C-9B97-F49FCE895D9F}']\r\n function HeadSet(Finish: TObject): IJclSortedSet;\r\n function SubSet(Start, Finish: TObject): IJclSortedSet;\r\n function TailSet(Start: TObject): IJclSortedSet;\r\n end;\r\n\r\n\r\n {$IFDEF SUPPORTS_GENERICS}\r\n //DOM-IGNORE-BEGIN\r\n IJclSortedSet = interface(IJclSet)\r\n ['{30F836E3-2FB1-427E-A499-DFAE201633C8}']\r\n function HeadSet(const Finish: T): IJclSortedSet;\r\n function SubSet(const Start, Finish: T): IJclSortedSet;\r\n function TailSet(const Start: T): IJclSortedSet;\r\n end;\r\n //DOM-IGNORE-END\r\n {$ENDIF SUPPORTS_GENERICS}\r\n\r\n IJclIntfStack = interface(IJclIntfContainer)\r\n ['{CA1DC7A1-8D8F-4A5D-81D1-0FE32E9A4E84}']\r\n procedure Clear;\r\n function Contains(const AInterface: IInterface): Boolean;\r\n function Empty: Boolean;\r\n function Peek: IInterface;\r\n function Pop: IInterface;\r\n function Push(const AInterface: IInterface): Boolean;\r\n function Size: Integer;\r\n end;\r\n\r\n IJclAnsiStrStack = interface(IJclAnsiStrContainer)\r\n ['{649BB74C-D7BE-40D9-9F4E-32DDC3F13F3B}']\r\n procedure Clear;\r\n function Contains(const AString: AnsiString): Boolean;\r\n function Empty: Boolean;\r\n function Peek: AnsiString;\r\n function Pop: AnsiString;\r\n function Push(const AString: AnsiString): Boolean;\r\n function Size: Integer;\r\n end;\r\n\r\n IJclWideStrStack = interface(IJclWideStrContainer)\r\n ['{B2C3B165-33F1-4B7D-A2EC-0B19D12CE33C}']\r\n procedure Clear;\r\n function Contains(const AString: WideString): Boolean;\r\n function Empty: Boolean;\r\n function Peek: WideString;\r\n function Pop: WideString;\r\n function Push(const AString: WideString): Boolean;\r\n function Size: Integer;\r\n end;\r\n\r\n {$IFDEF SUPPORTS_UNICODE_STRING}\r\n IJclUnicodeStrStack = interface(IJclUnicodeStrContainer)\r\n ['{BC046C3D-E3D2-42BA-A96D-054834A70404}']\r\n procedure Clear;\r\n function Contains(const AString: UnicodeString): Boolean;\r\n function Empty: Boolean;\r\n function Peek: UnicodeString;\r\n function Pop: UnicodeString;\r\n function Push(const AString: UnicodeString): Boolean;\r\n function Size: Integer;\r\n end;\r\n {$ENDIF SUPPORTS_UNICODE_STRING}\r\n\r\n {$IFDEF CONTAINER_ANSISTR}\r\n IJclStrStack = IJclAnsiStrStack;\r\n {$ENDIF CONTAINER_ANSISTR}\r\n {$IFDEF CONTAINER_WIDESTR}\r\n IJclStrStack = IJclWideStrStack;\r\n {$ENDIF CONTAINER_WIDESTR}\r\n {$IFDEF CONTAINER_UNICODESTR}\r\n IJclStrStack = IJclUnicodeStrStack;\r\n {$ENDIF CONTAINER_UNICODESTR}\r\n\r\n IJclSingleStack = interface(IJclSingleContainer)\r\n ['{8DCE45C8-B5B3-43AB-BA08-DAD531CEB9CF}']\r\n procedure Clear;\r\n function Contains(const AValue: Single): Boolean;\r\n function Empty: Boolean;\r\n function Peek: Single;\r\n function Pop: Single;\r\n function Push(const AValue: Single): Boolean;\r\n function Size: Integer;\r\n end;\r\n\r\n IJclDoubleStack = interface(IJclDoubleContainer)\r\n ['{46DF2701-16F0-453C-B938-F04E9C1CEBF8}']\r\n procedure Clear;\r\n function Contains(const AValue: Double): Boolean;\r\n function Empty: Boolean;\r\n function Peek: Double;\r\n function Pop: Double;\r\n function Push(const AValue: Double): Boolean;\r\n function Size: Integer;\r\n end;\r\n\r\n IJclExtendedStack = interface(IJclExtendedContainer)\r\n ['{A2A30585-F561-4757-ABE1-CA511AE72CC5}']\r\n procedure Clear;\r\n function Contains(const AValue: Extended): Boolean;\r\n function Empty: Boolean;\r\n function Peek: Extended;\r\n function Pop: Extended;\r\n function Push(const AValue: Extended): Boolean;\r\n function Size: Integer;\r\n end;\r\n\r\n {$IFDEF MATH_SINGLE_PRECISION}\r\n IJclFloatStack = IJclSingleStack;\r\n {$ENDIF MATH_SINGLE_PRECISION}\r\n {$IFDEF MATH_DOUBLE_PRECISION}\r\n IJclFloatStack = IJclDoubleStack;\r\n {$ENDIF MATH_DOUBLE_PRECISION}\r\n {$IFDEF MATH_EXTENDED_PRECISION}\r\n IJclFloatStack = IJclExtendedStack;\r\n {$ENDIF MATH_EXTENDED_PRECISION}\r\n\r\n IJclIntegerStack = interface(IJclIntegerContainer)\r\n ['{9190BF0E-5B0C-4D6C-A107-20A933C9B56A}']\r\n procedure Clear;\r\n function Contains(AValue: Integer): Boolean;\r\n function Empty: Boolean;\r\n function Peek: Integer;\r\n function Pop: Integer;\r\n function Push(AValue: Integer): Boolean;\r\n function Size: Integer;\r\n end;\r\n\r\n IJclCardinalStack = interface(IJclCardinalContainer)\r\n ['{94F9EDB3-602B-49CE-9990-0AFDAC556F83}']\r\n procedure Clear;\r\n function Contains(AValue: Cardinal): Boolean;\r\n function Empty: Boolean;\r\n function Peek: Cardinal;\r\n function Pop: Cardinal;\r\n function Push(AValue: Cardinal): Boolean;\r\n function Size: Integer;\r\n end;\r\n\r\n IJclInt64Stack = interface(IJclInt64Container)\r\n ['{D689EB8F-2746-40E9-AD1B-7E656475FC64}']\r\n procedure Clear;\r\n function Contains(const AValue: Int64): Boolean;\r\n function Empty: Boolean;\r\n function Peek: Int64;\r\n function Pop: Int64;\r\n function Push(const AValue: Int64): Boolean;\r\n function Size: Integer;\r\n end;\r\n\r\n IJclPtrStack = interface(IJclPtrContainer)\r\n ['{AD11D06C-E0E1-4EDE-AA2F-BC8BDD972B73}']\r\n procedure Clear;\r\n function Contains(APtr: Pointer): Boolean;\r\n function Empty: Boolean;\r\n function Peek: Pointer;\r\n function Pop: Pointer;\r\n function Push(APtr: Pointer): Boolean;\r\n function Size: Integer;\r\n end;\r\n\r\n IJclStack = interface(IJclContainer)\r\n ['{E07E0BD8-A831-41B9-B9A0-7199BD4873B9}']\r\n procedure Clear;\r\n function Contains(AObject: TObject): Boolean;\r\n function Empty: Boolean;\r\n function Peek: TObject;\r\n function Pop: TObject;\r\n function Push(AObject: TObject): Boolean;\r\n function Size: Integer;\r\n end;\r\n\r\n\r\n {$IFDEF SUPPORTS_GENERICS}\r\n //DOM-IGNORE-BEGIN\r\n IJclStack = interface(IJclBaseContainer)\r\n ['{2F08EAC9-270D-496E-BE10-5E975918A5F2}']\r\n procedure Clear;\r\n function Contains(const AItem: T): Boolean;\r\n function Empty: Boolean;\r\n function Peek: T;\r\n function Pop: T;\r\n function Push(const AItem: T): Boolean;\r\n function Size: Integer;\r\n end;\r\n //DOM-IGNORE-END\r\n {$ENDIF SUPPORTS_GENERICS}\r\n\r\n // Exceptions\r\n EJclContainerError = class(EJclError);\r\n\r\n EJclOutOfBoundsError = class(EJclContainerError)\r\n public\r\n // RsEOutOfBounds\r\n constructor Create;\r\n end;\r\n\r\n EJclNoSuchElementError = class(EJclContainerError)\r\n public\r\n // RsEValueNotFound\r\n constructor Create(const Value: string);\r\n end;\r\n\r\n EJclDuplicateElementError = class(EJclContainerError)\r\n public\r\n // RsEDuplicateElement\r\n constructor Create;\r\n end;\r\n\r\n EJclIllegalArgumentError = class(EJclContainerError)\r\n end;\r\n\r\n EJclNoCollectionError = class(EJclIllegalArgumentError)\r\n public\r\n // RsENoCollection\r\n constructor Create;\r\n end;\r\n\r\n EJclIllegalQueueCapacityError = class(EJclIllegalArgumentError)\r\n public\r\n // RsEIllegalQueueCapacity\r\n constructor Create;\r\n end;\r\n\r\n EJclOperationNotSupportedError = class(EJclContainerError)\r\n public\r\n // RsEOperationNotSupported\r\n constructor Create;\r\n end;\r\n\r\n EJclNoEqualityComparerError = class(EJclContainerError)\r\n public\r\n // RsENoEqualityComparer\r\n constructor Create;\r\n end;\r\n\r\n EJclNoComparerError = class(EJclContainerError)\r\n public\r\n // RsENoComparer\r\n constructor Create;\r\n end;\r\n\r\n EJclNoHashConverterError = class(EJclContainerError)\r\n public\r\n // RsENoHashConverter\r\n constructor Create;\r\n end;\r\n\r\n EJclIllegalStateOperationError = class(EJclContainerError)\r\n public\r\n // RsEIllegalStateOperation\r\n constructor Create;\r\n end;\r\n\r\n EJclAssignError = class(EJclContainerError)\r\n public\r\n // RsEAssignError\r\n constructor Create;\r\n end;\r\n\r\n EJclReadOnlyError = class(EJclContainerError)\r\n public\r\n // RsEReadOnlyError\r\n constructor Create;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jcl.svn.sourceforge.net/svnroot/jcl/tags/JCL-2.4-Build4571/jcl/source/common/JclContainerIntf.pas $';\r\n Revision: '$Revision: 3735 $';\r\n Date: '$Date: 2012-02-19 22:43:22 +0100 (dim. 19 févr. 2012) $';\r\n LogPath: 'JCL\\source\\common';\r\n Extra: '';\r\n Data: nil\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n {$IFDEF HAS_UNITSCOPE}\r\n System.SysUtils,\r\n {$ELSE ~HAS_UNITSCOPE}\r\n SysUtils,\r\n {$ENDIF ~HAS_UNITSCOPE}\r\n JclResources;\r\n\r\n//=== { EJclOutOfBoundsError } ===============================================\r\n\r\nconstructor EJclOutOfBoundsError.Create;\r\nbegin\r\n inherited CreateRes(@RsEOutOfBounds);\r\nend;\r\n\r\n//=== { EJclNoSuchElementError } =============================================\r\n\r\nconstructor EJclNoSuchElementError.Create(const Value: string);\r\nbegin\r\n inherited CreateResFmt(@RsEValueNotFound, [Value]);\r\nend;\r\n\r\n//=== { EJclDuplicateElementError } ==========================================\r\n\r\nconstructor EJclDuplicateElementError.Create;\r\nbegin\r\n inherited CreateRes(@RsEDuplicateElement);\r\nend;\r\n\r\n//=== { EJclIllegalQueueCapacityError } ======================================\r\n\r\nconstructor EJclIllegalQueueCapacityError.Create;\r\nbegin\r\n inherited CreateRes(@RsEIllegalQueueCapacity);\r\nend;\r\n\r\n//=== { EJclNoCollectionError } ==============================================\r\n\r\nconstructor EJclNoCollectionError.Create;\r\nbegin\r\n inherited CreateRes(@RsENoCollection);\r\nend;\r\n\r\n//=== { EJclOperationNotSupportedError } =====================================\r\n\r\nconstructor EJclOperationNotSupportedError.Create;\r\nbegin\r\n inherited CreateRes(@RsEOperationNotSupported);\r\nend;\r\n\r\n//=== { EJclIllegalStateOperationError } =====================================\r\n\r\nconstructor EJclIllegalStateOperationError.Create;\r\nbegin\r\n inherited CreateRes(@RsEIllegalStateOperation);\r\nend;\r\n\r\n//=== { EJclNoComparerError } ================================================\r\n\r\nconstructor EJclNoComparerError.Create;\r\nbegin\r\n inherited CreateRes(@RsENoComparer);\r\nend;\r\n\r\n//=== { EJclNoEqualityComparerError } ========================================\r\n\r\nconstructor EJclNoEqualityComparerError.Create;\r\nbegin\r\n inherited CreateRes(@RsENoEqualityComparer);\r\nend;\r\n\r\n//=== { EJclNoHashConverterError } ===========================================\r\n\r\nconstructor EJclNoHashConverterError.Create;\r\nbegin\r\n inherited CreateRes(@RsENoHashConverter);\r\nend;\r\n\r\n//=== { EJclAssignError } ====================================================\r\n\r\nconstructor EJclAssignError.Create;\r\nbegin\r\n inherited CreateRes(@RsEAssignError);\r\nend;\r\n\r\n//=== { EJclReadOnlyError } ==================================================\r\n\r\nconstructor EJclReadOnlyError.Create;\r\nbegin\r\n inherited CreateRes(@RsEReadOnlyError);\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n\r\n" }, { "path": "External/Jedi/Jcl/source/common/JclCounter.pas", "content": "{**************************************************************************************************}\r\n{ }\r\n{ Project JEDI Code Library (JCL) }\r\n{ }\r\n{ The contents of this file are subject to the Mozilla Public License Version 1.1 (the \"License\"); }\r\n{ you may not use this file except in compliance with the License. You may obtain a copy of the }\r\n{ License at http://www.mozilla.org/MPL/ }\r\n{ }\r\n{ Software distributed under the License is distributed on an \"AS IS\" basis, WITHOUT WARRANTY OF }\r\n{ ANY KIND, either express or implied. See the License for the specific language governing rights }\r\n{ and limitations under the License. }\r\n{ }\r\n{ The Original Code is JclCounter.pas. }\r\n{ }\r\n{ The Initial Developers of the Original Code are Theo Bebekis and Marcel van Brakel. }\r\n{ Portions created by Marcel van Brakel are Copyright (C) Marcel van Brakel. All Rights Reserved. }\r\n{ Portions created by Theo Bebekis are Copyright (C) Theo Bebekis. All Rights Reserved. }\r\n{ }\r\n{ Contributor(s): }\r\n{ Theo Bebekis }\r\n{ Marcel van Brakel }\r\n{ Robert Marquardt (marquardt) }\r\n{ Matthias Thoma (mthoma) }\r\n{ Petr Vones (pvones) }\r\n{ }\r\n{**************************************************************************************************}\r\n{ }\r\n{ This unit contains a high performance counter class which can be used for highly accurate timing }\r\n{ }\r\n{**************************************************************************************************}\r\n{ }\r\n{ Last modified: $Date:: 2011-09-03 00:07:50 +0200 (sam. 03 sept. 2011) $ }\r\n{ Revision: $Rev:: 3599 $ }\r\n{ Author: $Author:: outchy $ }\r\n{ }\r\n{**************************************************************************************************}\r\n\r\nunit JclCounter;\r\n\r\n{$I jcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n {$IFDEF HAS_UNITSCOPE}\r\n {$IFDEF MSWINDOWS}\r\n Winapi.Windows,\r\n {$ENDIF MSWINDOWS}\r\n {$ELSE ~HAS_UNITSCOPE}\r\n {$IFDEF MSWINDOWS}\r\n Windows,\r\n {$ENDIF MSWINDOWS}\r\n {$ENDIF ~HAS_UNITSCOPE}\r\n {$IFDEF HAS_UNIT_LIBC}\r\n Libc,\r\n {$ENDIF HAS_UNIT_LIBC}\r\n JclBase;\r\n\r\ntype\r\n TJclCounter = class(TObject)\r\n private\r\n FCounting: Boolean;\r\n FElapsedTime: Float;\r\n FOverhead: Int64;\r\n FOverallElapsedTime: Float;\r\n FFrequency: Int64;\r\n FStart: Int64;\r\n FStop: Int64;\r\n {$IFDEF LINUX}\r\n FTimeval: TTimeval;\r\n {$ENDIF LINUX}\r\n protected\r\n function GetRunElapsedTime: Float;\r\n public\r\n constructor Create(const Compensate: Boolean = False);\r\n procedure Continue;\r\n procedure Start;\r\n function Stop: Float;\r\n property Counting: Boolean read FCounting;\r\n property ElapsedTime: Float read FElapsedTime;\r\n property Overhead: Int64 read FOverhead;\r\n property RunElapsedTime: Float read GetRunElapsedTime;\r\n end;\r\n\r\nprocedure ContinueCount(var Counter: TJclCounter);\r\nprocedure StartCount(var Counter: TJclCounter; const Compensate: Boolean = False);\r\nfunction StopCount(var Counter: TJclCounter): Float;\r\n\r\ntype\r\n EJclCounterError = class(EJclError);\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jcl.svn.sourceforge.net/svnroot/jcl/tags/JCL-2.4-Build4571/jcl/source/common/JclCounter.pas $';\r\n Revision: '$Revision: 3599 $';\r\n Date: '$Date: 2011-09-03 00:07:50 +0200 (sam. 03 sept. 2011) $';\r\n LogPath: 'JCL\\source\\common';\r\n Extra: '';\r\n Data: nil\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n {$IFDEF HAS_UNITSCOPE}\r\n System.SysUtils,\r\n {$ELSE ~HAS_UNITSCOPE}\r\n SysUtils,\r\n {$ENDIF ~HAS_UNITSCOPE}\r\n JclResources;\r\n\r\nprocedure NoCounterError;\r\nbegin\r\n raise EJclCounterError.CreateRes(@RsNoCounter);\r\nend;\r\n\r\nconstructor TJclCounter.Create(const Compensate: Boolean);\r\nconst\r\n Iterations: Integer = 10000;\r\nvar\r\n Count: Integer;\r\n TmpOverhead: Int64;\r\nbegin\r\n inherited Create;\r\n\r\n {$IFDEF MSWINDOWS}\r\n if not QueryPerformanceFrequency(FFrequency) then\r\n NoCounterError;\r\n {$ENDIF MSWINDOWS}\r\n {$IFDEF LINUX}\r\n FFrequency := 100000; // 1 sec = 10E6 microseconds, therefore we have to divide by 10E5\r\n {$ENDIF LINUX}\r\n\r\n FCounting := False;\r\n FOverhead := 0;\r\n\r\n if Compensate then\r\n begin\r\n // Determine overhead associated with calling of the Start and Stop methods.\r\n // This allows the Stop method to compensate for it and return a more\r\n // accurate result. Thanks to John O'Harrow (john att elmcrest dott demon dott co dott uk)\r\n TmpOverhead := 0;\r\n for Count := 0 to Iterations-1 do\r\n begin\r\n Start;\r\n Stop;\r\n TmpOverhead := TmpOverhead + (FStop - FStart);\r\n end;\r\n FOverHead := Round(TmpOverhead / Iterations);\r\n end;\r\n\r\n FOverallElapsedTime := 0;\r\n FElapsedTime := 0;\r\nend;\r\n\r\nprocedure TJclCounter.Start;\r\nbegin\r\n FCounting := True;\r\n FElapsedTime := 0;\r\n FOverallElapsedTime := 0;\r\n {$IFDEF MSWINDOWS}\r\n if not QueryPerformanceCounter(FStart) then\r\n NoCounterError;\r\n {$ENDIF MSWINDOWS}\r\n {$IFDEF LINUX}\r\n GetTimeOfDay(FTimeval, nil);\r\n FStart := FTimeval.tv_sec * 100000 + (FTimeval.tv_usec);\r\n {$ENDIF LINUX}\r\nend;\r\n\r\nfunction TJclCounter.Stop: Float;\r\nbegin\r\n {$IFDEF MSWINDOWS}\r\n if not QueryPerformanceCounter(FStop) then\r\n NoCounterError;\r\n {$ENDIF MSWINDOWS}\r\n {$IFDEF LINUX}\r\n GetTimeOfDay(FTimeval, nil);\r\n FStop := FTimeval.tv_sec * 100000 + (FTimeval.tv_usec);\r\n {$ENDIF LINUX}\r\n FCounting := False;\r\n FElapsedTime := FOverallElapsedTime + ((FStop - FStart - FOverhead) / FFrequency);\r\n FOverallElapsedTime := FElapsedTime;\r\n Result := FElapsedTime;\r\nend;\r\n\r\nfunction TJclCounter.GetRunElapsedTime: Float;\r\nvar\r\n TimeNow: Int64;\r\nbegin\r\n {$IFDEF MSWINDOWS}\r\n TimeNow := 0;\r\n if not QueryPerformanceCounter(TimeNow) then\r\n NoCounterError;\r\n {$ENDIF MSWINDOWS}\r\n {$IFDEF LINUX}\r\n GetTimeOfDay(FTimeval, nil);\r\n TimeNow := FTimeval.tv_sec * 100000 + (FTimeval.tv_usec);\r\n {$ENDIF LINUX}\r\n Result := FOverallElapsedTime + ((TimeNow - FStart - FOverhead) / FFrequency);\r\nend;\r\n\r\nprocedure TJclCounter.Continue;\r\nvar\r\n Overall: Float;\r\nbegin\r\n if not(FCounting) then\r\n begin\r\n Overall := FOverallElapsedTime;\r\n Start;\r\n FOverallElapsedTime := Overall;\r\n end;\r\nend;\r\n\r\nprocedure StartCount(var Counter: TJclCounter; const Compensate: Boolean = False);\r\nbegin\r\n Counter := TJclCounter.Create(Compensate);\r\n Counter.Start;\r\nend;\r\n\r\nfunction StopCount(var Counter: TJclCounter): Float;\r\nbegin\r\n if Counter <> nil then\r\n begin\r\n Result := Counter.Stop;\r\n FreeAndNil(Counter);\r\n end\r\n else\r\n Result := 0.0;\r\nend;\r\n\r\nprocedure ContinueCount(var Counter: TJclCounter);\r\nbegin\r\n if Counter <> nil then\r\n Counter.Continue;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jcl/source/common/JclDateTime.pas", "content": "{**************************************************************************************************}\r\n{ }\r\n{ Project JEDI Code Library (JCL) }\r\n{ }\r\n{ The contents of this file are subject to the Mozilla Public License Version 1.1 (the \"License\"); }\r\n{ you may not use this file except in compliance with the License. You may obtain a copy of the }\r\n{ License at http://www.mozilla.org/MPL/ }\r\n{ }\r\n{ Software distributed under the License is distributed on an \"AS IS\" basis, WITHOUT WARRANTY OF }\r\n{ ANY KIND, either express or implied. See the License for the specific language governing rights }\r\n{ and limitations under the License. }\r\n{ }\r\n{ The Original Code is JclDateTime.pas. }\r\n{ }\r\n{ The Initial Developer of the Original Code is Marcel van Brakel. }\r\n{ Portions created by Marcel van Brakel are Copyright Marcel van Brakel. All rights reserved. }\r\n{ }\r\n{ Contributors: }\r\n{ Anthony Steele }\r\n{ Charlie Calvert }\r\n{ Heri Bender }\r\n{ Marc Convents }\r\n{ Marcel van Brakel }\r\n{ Matthias Thoma (mthoma) }\r\n{ Michael Schnell }\r\n{ Nick Hodges }\r\n{ Petr Vones }\r\n{ Robert Marquardt (marquardt) }\r\n{ Robert Rossmair (rrossmair) }\r\n{ Uwe Schuster (uschuster) }\r\n{ }\r\n{**************************************************************************************************}\r\n{ }\r\n{ Routines for working with dates and times. Mostly conversion between the }\r\n{ different formats but also some date testing routines (is leap year? etc) }\r\n{ }\r\n{**************************************************************************************************}\r\n{ }\r\n{ Last modified: $Date:: 2011-09-03 00:07:50 +0200 (sam. 03 sept. 2011) $ }\r\n{ Revision: $Rev:: 3599 $ }\r\n{ Author: $Author:: outchy $ }\r\n{ }\r\n{**************************************************************************************************}\r\n\r\n// in Help:\r\n// We do all conversions (but thoses provided by Delphi anyway) between\r\n// TDateTime, TDosDateTime, TFileTime and TSystemTime plus\r\n// TDatetime, TDosDateTime, TFileTime, TSystemTime to string\r\n\r\nunit JclDateTime;\r\n\r\n{$I jcl.inc}\r\n{$I crossplatform.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n {$IFDEF HAS_UNITSCOPE}\r\n {$IFDEF MSWINDOWS}\r\n Winapi.Windows,\r\n {$ENDIF MSWINDOWS}\r\n System.SysUtils,\r\n {$ELSE ~HAS_UNITSCOPE}\r\n {$IFDEF MSWINDOWS}\r\n Windows,\r\n {$ENDIF MSWINDOWS}\r\n SysUtils,\r\n {$ENDIF ~HAS_UNITSCOPE}\r\n {$IFDEF HAS_UNIT_LIBC}\r\n Libc,\r\n {$ENDIF HAS_UNIT_LIBC}\r\n {$IFDEF FPC}\r\n {$IFDEF UNIX}\r\n {$IFNDEF LINUX}\r\n Unix,\r\n {$ENDIF ~LINUX}\r\n {$ENDIF FPC}\r\n {$ENDIF}\r\n JclBase, JclResources;\r\n\r\nconst\r\n // 1970-01-01T00:00:00 in TDateTime\r\n UnixTimeStart = 25569;\r\n\r\n{ Encode / Decode functions }\r\n\r\nfunction EncodeDate(const Year: Integer; Month, Day: Word): TDateTime;\r\nprocedure DecodeDate(Date: TDateTime; out Year, Month, Day: Word); overload;\r\nprocedure DecodeDate(Date: TDateTime; out Year: Integer; out Month, Day: Word); overload;\r\nprocedure DecodeDate(Date: TDateTime; out Year, Month, Day: Integer); overload;\r\n\r\nfunction CenturyOfDate(const DateTime: TDateTime): Integer;\r\nfunction CenturyBaseYear(const DateTime: TDateTime): Integer;\r\nfunction DayOfDate(const DateTime: TDateTime): Integer;\r\nfunction MonthOfDate(const DateTime: TDateTime): Integer;\r\nfunction YearOfDate(const DateTime: TDateTime): Integer;\r\nfunction DayOfTheYear(const DateTime: TDateTime; out Year: Integer): Integer; overload;\r\nfunction DayOfTheYear(const DateTime: TDateTime): Integer; overload;\r\nfunction DayOfTheYearToDateTime(const Year, Day: Integer): TDateTime;\r\nfunction HourOfTime(const DateTime: TDateTime): Integer;\r\nfunction MinuteOfTime(const DateTime: TDateTime): Integer;\r\nfunction SecondOfTime(const DateTime: TDateTime): Integer;\r\n\r\n{ ISO 8601 support }\r\n\r\nfunction GetISOYearNumberOfWeeks(const Year: Word): Word;\r\nfunction IsISOLongYear(const Year: Word): Boolean; overload;\r\nfunction IsISOLongYear(const DateTime: TDateTime): Boolean; overload;\r\nfunction ISODayOfWeek(const DateTime: TDateTime): Word;\r\nfunction ISOWeekNumber(DateTime: TDateTime; out YearOfWeekNumber, WeekDay: Integer): Integer; overload;\r\nfunction ISOWeekNumber(DateTime: TDateTime; out YearOfWeekNumber: Integer): Integer; overload;\r\nfunction ISOWeekNumber(DateTime: TDateTime): Integer; overload;\r\nfunction ISOWeekToDateTime(const Year, Week, Day: Integer): TDateTime;\r\n\r\n{ Miscellanous }\r\n\r\nfunction IsLeapYear(const Year: Integer): Boolean; overload;\r\nfunction IsLeapYear(const DateTime: TDateTime): Boolean; overload;\r\nfunction DaysInMonth(const DateTime: TDateTime): Integer;\r\nfunction Make4DigitYear(Year, Pivot: Integer): Integer;\r\nfunction MakeYear4Digit(Year, WindowsillYear: Integer): Integer;\r\nfunction EasterSunday(const Year: Integer): TDateTime;\r\nfunction FormatDateTime(Form: string; DateTime: TDateTime): string;\r\nfunction FATDatesEqual(const FileTime1, FileTime2: Int64): Boolean; overload;\r\nfunction FATDatesEqual(const FileTime1, FileTime2: TFileTime): Boolean; overload;\r\n\r\n// Conversion\r\ntype\r\n TDosDateTime = Integer;\r\n\r\nfunction HoursToMSecs(Hours: Integer): Integer;\r\nfunction MinutesToMSecs(Minutes: Integer): Integer;\r\nfunction SecondsToMSecs(Seconds: Integer): Integer;\r\n\r\nfunction TimeOfDateTimeToSeconds(DateTime: TDateTime): Integer;\r\nfunction TimeOfDateTimeToMSecs(DateTime: TDateTime): Integer;\r\n\r\nfunction DateTimeToLocalDateTime(DateTime: TDateTime): TDateTime;\r\nfunction LocalDateTimeToDateTime(DateTime: TDateTime): TDateTime;\r\n\r\n{$IFDEF MSWINDOWS}\r\nfunction DateTimeToDosDateTime(const DateTime: TDateTime): TDosDateTime;\r\nfunction DateTimeToFileTime(DateTime: TDateTime): TFileTime;\r\nfunction DateTimeToSystemTime(DateTime: TDateTime): TSystemTime; overload;\r\nprocedure DateTimeToSystemTime(DateTime: TDateTime; out SysTime: TSystemTime); overload;\r\n\r\nfunction LocalDateTimeToFileTime(DateTime: TDateTime): FileTime;\r\n{$ENDIF MSWINDOWS}\r\n\r\nfunction DosDateTimeToDateTime(const DosTime: TDosDateTime): TDateTime;\r\n{$IFDEF MSWINDOWS}\r\nfunction DosDateTimeToFileTime(DosTime: TDosDateTime): TFileTime; overload;\r\nprocedure DosDateTimeToFileTime(DTH, DTL: Word; FT: TFileTime); overload;\r\nfunction DosDateTimeToSystemTime(const DosTime: TDosDateTime): TSystemTime;\r\n{$ENDIF MSWINDOWS}\r\nfunction DosDateTimeToStr(DateTime: Integer): string;\r\n\r\nfunction FileTimeToDateTime(const FileTime: TFileTime): TDateTime;\r\n{$IFDEF MSWINDOWS}\r\nfunction FileTimeToLocalDateTime(const FileTime: TFileTime): TDateTime;\r\nfunction FileTimeToDosDateTime(const FileTime: TFileTime): TDosDateTime; overload;\r\nprocedure FileTimeToDosDateTime(const FileTime: TFileTime; out Date, Time: Word); overload;\r\nfunction FileTimeToSystemTime(const FileTime: TFileTime): TSystemTime; overload;\r\nprocedure FileTimeToSystemTime(const FileTime: TFileTime; out ST: TSystemTime); overload;\r\n{$ENDIF MSWINDOWS}\r\nfunction FileTimeToStr(const FileTime: TFileTime): string;\r\n\r\n{$IFDEF MSWINDOWS}\r\nfunction SystemTimeToDosDateTime(const SystemTime: TSystemTime): TDosDateTime;\r\nfunction SystemTimeToFileTime(const SystemTime: TSystemTime): TFileTime; overload;\r\nprocedure SystemTimeToFileTime(const SystemTime: TSystemTime; FTime: TFileTime); overload;\r\nfunction SystemTimeToStr(const SystemTime: TSystemTime): string;\r\n\r\n// Filedates\r\nfunction CreationDateTimeOfFile(const Sr: TSearchRec): TDateTime;\r\nfunction LastAccessDateTimeOfFile(const Sr: TSearchRec): TDateTime;\r\nfunction LastWriteDateTimeOfFile(const Sr: TSearchRec): TDateTime;\r\n{$ENDIF MSWINDOWS}\r\n\r\ntype\r\n TJclUnixTime32 = Longword;\r\n\r\nfunction DateTimeToUnixTime(DateTime: TDateTime): TJclUnixTime32;\r\nfunction UnixTimeToDateTime(const UnixTime: TJclUnixTime32): TDateTime;\r\n\r\n{$IFDEF MSWINDOWS}\r\nfunction FileTimeToUnixTime(const AValue: TFileTime): TJclUnixTime32;\r\nfunction UnixTimeToFileTime(const AValue: TJclUnixTime32): TFileTime;\r\n{$ENDIF MSWINDOWS}\r\n\r\n// Time stamps (formerly in JclSchedule)\r\nfunction NullStamp: TTimeStamp;\r\nfunction CompareTimeStamps(const Stamp1, Stamp2: TTimeStamp): Int64;\r\nfunction EqualTimeStamps(const Stamp1, Stamp2: TTimeStamp): Boolean;\r\nfunction IsNullTimeStamp(const Stamp: TTimeStamp): Boolean;\r\nfunction TimeStampDOW(const Stamp: TTimeStamp): Integer;\r\n\r\n// Day of week (formerly in JclSchedule)\r\nfunction FirstWeekDay(const Year, Month: Integer; out DOW: Integer): Integer; overload;\r\nfunction FirstWeekDay(const Year, Month: Integer): Integer; overload;\r\nfunction LastWeekDay(const Year, Month: Integer; out DOW: Integer): Integer; overload;\r\nfunction LastWeekDay(const Year, Month: Integer): Integer; overload;\r\nfunction IndexedWeekDay(const Year, Month: Integer; Index: Integer): Integer;\r\nfunction FirstWeekendDay(const Year, Month: Integer; out DOW: Integer): Integer; overload;\r\nfunction FirstWeekendDay(const Year, Month: Integer): Integer; overload;\r\nfunction LastWeekendDay(const Year, Month: Integer; out DOW: Integer): Integer; overload;\r\nfunction LastWeekendDay(const Year, Month: Integer): Integer; overload;\r\nfunction IndexedWeekendDay(const Year, Month: Integer; Index: Integer): Integer;\r\nfunction FirstDayOfWeek(const Year, Month, DayOfWeek: Integer): Integer;\r\nfunction LastDayOfWeek(const Year, Month, DayOfWeek: Integer): Integer;\r\nfunction IndexedDayOfWeek(const Year, Month, DayOfWeek, Index: Integer): Integer;\r\n\r\ntype\r\n EJclDateTimeError = class(EJclError);\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jcl.svn.sourceforge.net/svnroot/jcl/tags/JCL-2.4-Build4571/jcl/source/common/JclDateTime.pas $';\r\n Revision: '$Revision: 3599 $';\r\n Date: '$Date: 2011-09-03 00:07:50 +0200 (sam. 03 sept. 2011) $';\r\n LogPath: 'JCL\\source\\common';\r\n Extra: '';\r\n Data: nil\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n JclSysUtils;\r\n\r\nconst\r\n DaysInMonths: array [1..12] of Integer =\r\n (31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31);\r\n\r\n MinutesPerDay = 60 * 24;\r\n //SecondsPerMinute = 60;\r\n //SecondsPerHour = 3600;\r\n SecondsPerDay = MinutesPerDay * 60;\r\n MsecsPerMinute = 60 * 1000;\r\n MsecsPerHour = 60 * MsecsPerMinute;\r\n DaysPerYear = 365.2422454; // Solar Year\r\n DaysPerMonth = DaysPerYear / 12;\r\n DateTimeBaseDay = -693593; // 1/1/0001\r\n EncodeDateMaxYear = 9999;\r\n SolarDifference = 1.7882454; // Difference of Julian Calendar to Solar Calendar at 1/1/10000\r\n DateTimeMaxDay = 2958466; // 12/31/EncodeDateMaxYear + 1;\r\n FileTimeBase = -109205.0;\r\n FileTimeStep: Extended = 24.0 * 60.0 * 60.0 * 1000.0 * 1000.0 * 10.0; // 100 nSek per Day\r\n\r\n // Weekday to start the week\r\n // 1 : Sonday\r\n // 2 : Monday (according to ISO 8601)\r\n //ISOFirstWeekDay = 2;\r\n\r\n // minmimum number of days of the year in the first week of the year week\r\n // 1 : week one starts at 1/1\r\n // 4 : first week has at least four days (according to ISO 8601)\r\n // 7 : first full week\r\n //ISOFirstWeekMinDays = 4;\r\n\r\nfunction EncodeDate(const Year: Integer; Month, Day: Word): TDateTime; overload;\r\nbegin\r\n if (Year > 0) and (Year < EncodeDateMaxYear + 1) then\r\n Result := {$IFDEF HAS_UNITSCOPE}System.{$ENDIF}SysUtils.EncodeDate(Year, Month, Day)\r\n else\r\n begin\r\n if Year <= 0 then\r\n Result := Year * DaysPerYear + DateTimeBaseDay\r\n else // Year >= 10000\r\n // for some reason year 0 does not exist so we switch from\r\n // the last day of year -1 (-693594) to the first days of year 1\r\n Result := (Year-1) * DaysPerYear + DateTimeBaseDay + // BaseDate is 1/1/1\r\n SolarDifference; // guarantee a smooth transition at 1/1/10000\r\n Result := Trunc(Result);\r\n Result := Result + (Month - 1) * DaysPerMonth;\r\n Result := Integer(Round(Result)) + (Day - 1);\r\n end;\r\nend;\r\n\r\nprocedure DecodeDate(Date: TDateTime; out Year, Month, Day: Word);\r\nbegin\r\n {$IFDEF HAS_UNITSCOPE}System.{$ENDIF}SysUtils.DecodeDate(Date, Year, Month, Day);\r\nend;\r\n\r\nprocedure DecodeDate(Date: TDateTime; out Year, Month, Day: Integer);\r\nvar\r\n WMonth, WDay: Word;\r\nbegin\r\n DecodeDate(Date, Year, WMonth, WDay);\r\n Month := WMonth;\r\n Day := WDay;\r\nend;\r\n\r\nprocedure DecodeDate(Date: TDateTime; out Year: Integer; out Month, Day: Word);\r\nvar\r\n WYear: Word;\r\n RDays, RMonths: TDateTime;\r\nbegin\r\n if (Date >= DateTimeBaseDay) and (Date < DateTimeMaxDay) then\r\n begin\r\n {$IFDEF HAS_UNITSCOPE}System.{$ENDIF}SysUtils.DecodeDate(Date, WYear, Month, Day);\r\n Year := WYear;\r\n end\r\n else\r\n begin\r\n Year := Trunc((Date - DateTimeBaseDay) / DaysPerYear);\r\n if Year <= 0 then\r\n Year := Year - 1\r\n // for some historical reason year 0 does not exist so we switch from\r\n // the last day of year -1 (-693594) to the first days of year 1\r\n else // Year >= 10000\r\n Date := Date - SolarDifference; // guarantee a smooth transition at 1/1/10000\r\n RDays := Date - DateTimeBaseDay; // Days relative to 1/1/0001\r\n RMonths := RDays / DaysPerMonth; // \"Months\" relative to 1/1/0001\r\n RMonths := RMonths - Year * 12.0; // 12 \"Months\" per Year\r\n if RMonths < 0 then // possible truncation glitches\r\n begin\r\n RMonths := 11;\r\n Year := Year - 1;\r\n end;\r\n Month := Trunc(RMonths);\r\n RMonths := Month;\r\n Month := Month + 1;\r\n RDays := RDays - Year * DaysPerYear; // subtract Base Day ot the year\r\n RDays := RDays - RMonths * DaysPerMonth;// subtract Base Day of the month\r\n Day := Trunc(RDays)+ 1;\r\n if Year > 0 then // Year >= 10000\r\n Year := Year + 1; // BaseDate is 1/1/1\r\n end;\r\nend;\r\n\r\nprocedure ResultCheck(Val: LongBool);\r\nbegin\r\n if not Val then\r\n raise EJclDateTimeError.CreateRes(@RsDateConversion);\r\nend;\r\n\r\nfunction CenturyBaseYear(const DateTime: TDateTime): Integer;\r\nvar\r\n Y: Integer;\r\nbegin\r\n Y := YearOfDate(DateTime);\r\n Result := (Y div 100) * 100;\r\n if Y <= 0 then\r\n Result := Result - 100;\r\nend;\r\n\r\nfunction CenturyOfDate(const DateTime: TDateTime): Integer;\r\nvar\r\n Y: Integer;\r\nbegin\r\n Y := YearOfDate(DateTime);\r\n if Y > 0 then\r\n Result := (Y div 100) + 1\r\n else\r\n Result := (Y div 100) - 1;\r\nend;\r\n\r\nfunction DayOfDate(const DateTime: TDateTime): Integer;\r\nvar\r\n Y: Integer;\r\n M, D: Word;\r\nbegin\r\n DecodeDate(DateTime, Y, M, D);\r\n Result := D;\r\nend;\r\n\r\nfunction MonthOfDate(const DateTime: TDateTime): Integer;\r\nvar\r\n Y: Integer;\r\n M, D: Word;\r\nbegin\r\n DecodeDate(DateTime, Y, M, D);\r\n Result := M;\r\nend;\r\n\r\nfunction YearOfDate(const DateTime: TDateTime): Integer;\r\nvar\r\n M, D: Word;\r\nbegin\r\n DecodeDate(DateTime, Result, M, D);\r\nend;\r\n\r\nfunction DayOfTheYear(const DateTime: TDateTime; out Year: Integer): Integer;\r\nvar\r\n Month, Day: Word;\r\n DT: TDateTime;\r\nbegin\r\n DecodeDate(DateTime, Year, Month, Day);\r\n DT := EncodeDate(Year, 1, 1);\r\n Result := Trunc(DateTime);\r\n Result := Result - Trunc(DT) + 1;\r\nend;\r\n\r\nfunction DayOfTheYear(const DateTime: TDateTime): Integer;\r\nvar\r\n Year: Integer;\r\nbegin\r\n Result := DayOfTheYear(DateTime, Year);\r\nend;\r\n\r\nfunction DayOfTheYearToDateTime(const Year, Day: Integer): TDateTime;\r\nbegin\r\n Result := EncodeDate(Year, 1, 1) + Day - 1;\r\nend;\r\n\r\nfunction HourOfTime(const DateTime: TDateTime): Integer;\r\nvar\r\n H, M, S, MS: Word;\r\nbegin\r\n DecodeTime(DateTime, H, M, S, MS);\r\n Result := H;\r\nend;\r\n\r\nfunction MinuteOfTime(const DateTime: TDateTime): Integer;\r\nvar\r\n H, M, S, MS: Word;\r\nbegin\r\n DecodeTime(DateTime, H, M, S, MS);\r\n Result := M;\r\nend;\r\n\r\nfunction SecondOfTime(const DateTime: TDateTime): Integer;\r\nvar\r\n H, M, S, MS: Word;\r\nbegin\r\n DecodeTime(DateTime, H, M, S, MS);\r\n Result := S;\r\nend;\r\n\r\nfunction TimeOfDateTimeToSeconds(DateTime: TDateTime): Integer;\r\nbegin\r\n Result := Round(Frac(DateTime) * SecondsPerDay);\r\nend;\r\n\r\nfunction TimeOfDateTimeToMSecs(DateTime: TDateTime): Integer;\r\nbegin\r\n Result := Round(Frac(DateTime) * MSecsPerDay);\r\nend;\r\n\r\nfunction DaysInMonth(const DateTime: TDateTime): Integer;\r\nvar\r\n M: Integer;\r\nbegin\r\n M := MonthOfDate(DateTime);\r\n Result := DaysInMonths[M];\r\n if (M = 2) and IsLeapYear(DateTime) then\r\n Result := 29;\r\nend;\r\n\r\n// SysUtils.DayOfWeek returns the day of the week of the given date. The result is an integer between\r\n// 1 and 7, corresponding to Sunday through Saturday. ISODayOfWeek on the other hand returns an integer\r\n// between 1 and 7 where the first day is a Monday. The forumla for calculation ISODayOfTheWeek is\r\n// simply\r\n// DayOfWeek(D) - 1 if DayOfWeek(D) > 1\r\n// ISODayOfWeek (D) = 7 if DayOfWeek(D) = 1\r\n\r\nfunction ISODayOfWeek(const DateTime: TDateTime): Word;\r\nvar\r\n TmpDayOfWeek: Word;\r\nbegin\r\n TmpDayOfWeek := {$IFDEF HAS_UNITSCOPE}System.{$ENDIF}SysUtils.DayOfWeek(DateTime);\r\n if TmpDayOfWeek = 1 then\r\n Result := 7\r\n else\r\n Result := TmpDayOfWeek - 1;\r\nend;\r\n\r\n// Determines if the ISO Year is ordinary (52 weeks) or Long (53 weeks). Uses a rule first\r\n// suggested by Sven Pran (Norway) and Lars Nordentoft (Denmark) - according to\r\n// http://www.phys.uu.nl/~vgent/calendar/isocalendar.htm\r\n\r\nfunction IsISOLongYear(const DateTime: TDateTime): Boolean;\r\nvar\r\n TmpYear: Word;\r\nbegin\r\n TmpYear := YearOfDate(DateTime);\r\n Result := IsISOLongYear(TmpYear);\r\nend;\r\n\r\nfunction IsISOLongYear(const Year: Word): Boolean;\r\nvar\r\n TmpWeekday: Word;\r\nbegin\r\n TmpWeekday := ISODayOfWeek(DayOfTheYearToDateTime(Year, 1));\r\n Result := (IsLeapYear(Year) and ((TmpWeekday = 3) or (TmpWeekday = 4))) or (TmpWeekday = 4);\r\nend;\r\n\r\nfunction GetISOYearNumberOfWeeks(const Year: Word): Word;\r\nbegin\r\n Result := 52;\r\n if IsISOLongYear(Year) then\r\n Result := 53;\r\nend;\r\n\r\n// ISOWeekNumber function returns Integer 1..7 equivalent to Sunday..Saturday.\r\n// ISO 8601 weeks start with Monday and the first week of a year is the one which\r\n// includes the first Thursday\r\n\r\nfunction ISOWeekNumber(DateTime: TDateTime; out YearOfWeekNumber, WeekDay: Integer): Integer;\r\nvar\r\n TmpYear: Integer;\r\n January4th: TDateTime;\r\n FirstMonday: TDateTime;\r\nbegin\r\n // Applying the rule: The first calender week is the week that includes January, 4th\r\n TmpYear := YearOfDate(DateTime);\r\n WeekDay := ISODayOfWeek(DateTime);\r\n // adjust if we are between 12/29 and 12/31\r\n if (MonthOfDate(DateTime) = 12) and (DayOfDate(DateTime) >= 29) and\r\n (ISODayOfWeek(DateTime) <= 3) then\r\n TmpYear := TmpYear + 1;\r\n\r\n January4th := DayOfTheYearToDateTime(TmpYear, 4);\r\n FirstMonday := January4th + 1 - ISODayOfWeek(January4th);\r\n\r\n // If our date is < FirstMonday we are in the last week of the previous year\r\n if DateTime < FirstMonday then\r\n begin\r\n Result := GetISOYearNumberOfWeeks(TmpYear - 1);\r\n YearOfWeekNumber := TmpYear - 1;\r\n Exit;\r\n end\r\n else\r\n begin\r\n YearOfWeekNumber := TmpYear;\r\n Result := (Trunc(DateTime - FirstMonday) div 7) + 1;\r\n end;\r\n\r\n if Result > GetISOYearNumberOfWeeks(YearOfDate(DateTime)) then\r\n Result := GetISOYearNumberOfWeeks(YearOfDate(DateTime));\r\nend;\r\n\r\nfunction ISOWeekNumber(DateTime: TDateTime; out YearOfWeekNumber: Integer): Integer;\r\nvar\r\n Temp: Integer;\r\nbegin\r\n Result := ISOWeekNumber(DateTime, YearOfWeekNumber, Temp);\r\nend;\r\n\r\nfunction ISOWeekNumber(DateTime: TDateTime): Integer;\r\nvar\r\n Temp: Integer;\r\nbegin\r\n Result := ISOWeekNumber(DateTime, Temp, Temp);\r\nend;\r\n\r\nfunction ISOWeekToDateTime(const Year, Week, Day: Integer): TDateTime;\r\nvar\r\n January4th: TDateTime;\r\n FirstMonday: TDateTime;\r\nbegin\r\n January4th := DayOfTheYearToDateTime(Year, 4);\r\n FirstMonday := January4th + 1 - ISODayOfWeek(January4th);\r\n Result := FirstMonday + (Week - 1) * 7 + (Day - 1);\r\nend;\r\n\r\n// The original Gregorian rule for all who want to learn it\r\n// Result := (Year mod 4 = 0) and ((Year mod 100 <> 0) or (Year mod 400 = 0));\r\n\r\nfunction IsLeapYear(const Year: Integer): Boolean;\r\nbegin\r\n Result := {$IFDEF HAS_UNITSCOPE}System.{$ENDIF}SysUtils.IsLeapYear(Year);\r\nend;\r\n\r\nfunction IsLeapYear(const DateTime: TDateTime): Boolean;\r\nbegin\r\n Result := IsLeapYear(YearOfDate(DateTime));\r\nend;\r\n\r\nfunction Make4DigitYear(Year, Pivot: Integer): Integer;\r\nbegin\r\n { TODO : Make4DigitYear } \r\n Assert((Year >= 0) and (Year <= 100) and (Pivot >= 0) and (Pivot <= 100));\r\n if Year = 100 then\r\n Year := 0;\r\n if Pivot = 100 then\r\n Pivot := 0;\r\n if Year < Pivot then\r\n Result := 2000 + Year\r\n else\r\n Result := 1900 + Year;\r\nend;\r\n\r\n// \"window\" technique for years to translate 2 digits to 4 digits.\r\n// The window is 100 years wide\r\n// The windowsill year is the lower edge of the window\r\n// A windowsill year of 1900 is equivalent to putting 1900 before every 2-digit year\r\n// if WindowsillYear is 1940, then 40 is interpreted as 1940, 00 as 2000 and 39 as 2039\r\n// The system default is 1950\r\n\r\nfunction MakeYear4Digit(Year, WindowsillYear: Integer): Integer;\r\nvar\r\n CC, Y: Integer;\r\nbegin\r\n // have come across this specific problem : y2K read as year 100\r\n if Year = 100 then\r\n Year := 0;\r\n // turn 2 digit years to 4 digits\r\n Y := Year mod 100;\r\n CC := (WindowsillYear div 100) * 100;\r\n Result := Y + CC; // give the result the same century as the windowsill\r\n if Result < WindowsillYear then // cannot be lower than the windowsill\r\n Result := Result + 100;\r\n if (Year >= 100) or (Year < 0) then\r\n Assert(Year = Result); // Assert: no unwanted century translation\r\nend;\r\n\r\n// Calculates and returns Easter Day for specified year.\r\n// Originally from Mark Lussier, AppVision .\r\n// Corrected to prevent integer overflow if it is inadvertedly\r\n// passed a year of 6554 or greater.\r\n\r\nfunction EasterSunday(const Year: Integer): TDateTime;\r\nvar\r\n Month, Day, Moon, Epact, Sunday,\r\n Gold, Cent, Corx, Corz: Integer;\r\nbegin\r\n { The Golden Number of the year in the 19 year Metonic Cycle: }\r\n Gold := Year mod 19 + 1;\r\n { Calculate the Century: }\r\n Cent := Year div 100 + 1;\r\n { Number of years in which leap year was dropped in order... }\r\n { to keep in step with the sun: }\r\n Corx := (3 * Cent) div 4 - 12;\r\n { Special correction to syncronize Easter with moon's orbit: }\r\n Corz := (8 * Cent + 5) div 25 - 5;\r\n { Find Sunday: }\r\n Sunday := (Longint(5) * Year) div 4 - Corx - 10;\r\n { ^ To prevent overflow at year 6554}\r\n { Set Epact - specifies occurrence of full moon: }\r\n Epact := (11 * Gold + 20 + Corz - Corx) mod 30;\r\n if Epact < 0 then\r\n Epact := Epact + 30;\r\n if ((Epact = 25) and (Gold > 11)) or (Epact = 24) then\r\n Epact := Epact + 1;\r\n { Find Full Moon: }\r\n Moon := 44 - Epact;\r\n if Moon < 21 then\r\n Moon := Moon + 30;\r\n { Advance to Sunday: }\r\n Moon := Moon + 7 - ((Sunday + Moon) mod 7);\r\n if Moon > 31 then\r\n begin\r\n Month := 4;\r\n Day := Moon - 31;\r\n end\r\n else\r\n begin\r\n Month := 3;\r\n Day := Moon;\r\n end;\r\n Result := EncodeDate(Year, Month, Day);\r\nend;\r\n\r\n// Conversion\r\n\r\n{$IFDEF MSWINDOWS}\r\nfunction DateTimeToLocalDateTime(DateTime: TDateTime): TDateTime;\r\nvar\r\n TimeZoneInfo: TTimeZoneInformation;\r\nbegin\r\n ResetMemory(TimeZoneInfo, SizeOf(TimeZoneInfo));\r\n case GetTimeZoneInformation(TimeZoneInfo) of\r\n TIME_ZONE_ID_STANDARD, TIME_ZONE_ID_UNKNOWN:\r\n Result := DateTime - (TimeZoneInfo.Bias + TimeZoneInfo.StandardBias) / MinutesPerDay;\r\n TIME_ZONE_ID_DAYLIGHT:\r\n Result := DateTime - (TimeZoneInfo.Bias + TimeZoneInfo.DaylightBias) / MinutesPerDay;\r\n else\r\n raise EJclDateTimeError.CreateRes(@RsMakeUTCTime);\r\n end;\r\nend;\r\n{$ENDIF MSWINDOWS}\r\n\r\n{$IFDEF UNIX}\r\nfunction DateTimeToLocalDateTime(DateTime: TDateTime): TDateTime;\r\nvar\r\n {$IFDEF LINUX}\r\n TimeNow: time_t;\r\n Local, UTCTime: TUnixTime;\r\n {$ENDIF LINUX}\r\n Offset: Double;\r\nbegin\r\n {$IFDEF LINUX}\r\n TimeNow := __time(nil);\r\n UTCTime := gmtime(@TimeNow)^;\r\n Local := localtime(@TimeNow)^;\r\n Offset := difftime(mktime(UTCTime), mktime(Local));\r\n {$ELSE ~LINUX}\r\n Offset := -TZSeconds;\r\n {$ENDIF ~LINUX}\r\n Result := ((DateTime * SecsPerDay) - Offset) / SecsPerDay;\r\nend;\r\n{$ENDIF UNIX}\r\n\r\n{$IFDEF MSWINDOWS}\r\nfunction LocalDateTimeToDateTime(DateTime: TDateTime): TDateTime;\r\nvar\r\n TimeZoneInfo: TTimeZoneInformation;\r\nbegin\r\n ResetMemory(TimeZoneInfo, SizeOf(TimeZoneInfo));\r\n case GetTimeZoneInformation(TimeZoneInfo) of\r\n TIME_ZONE_ID_STANDARD, TIME_ZONE_ID_UNKNOWN:\r\n Result := DateTime + (TimeZoneInfo.Bias + TimeZoneInfo.StandardBias) / MinutesPerDay;\r\n TIME_ZONE_ID_DAYLIGHT:\r\n Result := DateTime + (TimeZoneInfo.Bias + TimeZoneInfo.DaylightBias) / MinutesPerDay;\r\n else\r\n raise EJclDateTimeError.CreateRes(@RsMakeUTCTime);\r\n end;\r\nend;\r\n{$ENDIF MSWINDOWS}\r\n\r\n{$IFDEF UNIX}\r\nfunction LocalDateTimeToDateTime(DateTime: TDateTime): TDateTime;\r\nvar\r\n {$IFDEF LINUX}\r\n TimeNow: time_t;\r\n Local, UTCTime: TUnixTime;\r\n {$ENDIF LINUX}\r\n Offset: Double;\r\nbegin\r\n {$IFDEF LINUX}\r\n TimeNow := __time(nil);\r\n UTCTime := gmtime(@TimeNow)^;\r\n Local := localtime(@TimeNow)^;\r\n Offset := difftime(mktime(UTCTime), mktime(Local));\r\n {$ELSE ~LINUX}\r\n Offset := -TZSeconds;\r\n {$ENDIF ~LINUX}\r\n Result := ((DateTime * SecsPerDay) + Offset) / SecsPerDay;\r\nend;\r\n{$ENDIF UNIX}\r\n\r\nfunction HoursToMSecs(Hours: Integer): Integer;\r\nbegin\r\n Assert(Hours < MaxInt / MsecsPerHour);\r\n Result := Hours * MsecsPerHour;\r\nend;\r\n\r\nfunction MinutesToMSecs(Minutes: Integer): Integer;\r\nbegin\r\n Assert(Minutes < MaxInt div MsecsPerMinute);\r\n Result := Minutes * MsecsPerMinute;\r\nend;\r\n\r\nfunction SecondsToMSecs(Seconds: Integer): Integer;\r\nbegin\r\n Assert(Seconds < MaxInt div 1000);\r\n Result := Seconds * 1000;\r\nend;\r\n\r\n// using system calls this can be done like this:\r\n// var\r\n// SystemTime: TSystemTime;\r\n// begin\r\n// ResultCheck(FileTimeToSystemTime(FileTime, SystemTime));\r\n// Result := SystemTimeToDateTime(SystemTime);\r\n\r\nfunction FileTimeToDateTime(const FileTime: TFileTime): TDateTime;\r\nbegin\r\n Result := Int64(FileTime) / FileTimeStep;\r\n Result := Result + FileTimeBase;\r\nend;\r\n\r\n{$IFDEF MSWINDOWS}\r\n\r\nfunction FileTimeToLocalDateTime(const FileTime: TFileTime): TDateTime;\r\nvar\r\n LocalFileTime: TFileTime;\r\nbegin\r\n LocalFileTime.dwHighDateTime := 0;\r\n LocalFileTime.dwLowDateTime := 0;\r\n ResultCheck(FileTimeToLocalFileTime(FileTime, LocalFileTime));\r\n Result := FileTimeToDateTime(LocalFileTime);\r\n { TODO : daylight saving time }\r\nend;\r\n\r\nfunction LocalDateTimeToFileTime(DateTime: TDateTime): FileTime;\r\nvar\r\n LocalFileTime: TFileTime;\r\nbegin\r\n LocalFileTime := DateTimeToFileTime(DateTime);\r\n Result.dwHighDateTime := 0;\r\n Result.dwLowDateTime := 0;\r\n ResultCheck(LocalFileTimeToFileTime(LocalFileTime, Result));\r\n { TODO : daylight saving time }\r\nend;\r\n\r\n{$ENDIF MSWINDOWS}\r\n\r\nfunction DateTimeToFileTime(DateTime: TDateTime): TFileTime;\r\nvar\r\n E: Extended;\r\n F64: Int64;\r\nbegin\r\n E := (DateTime - FileTimeBase) * FileTimeStep;\r\n F64 := Round(E);\r\n Result := TFileTime(F64);\r\nend;\r\n\r\n{$IFDEF MSWINDOWS}\r\n\r\nfunction DosDateTimeToSystemTime(const DosTime: TDosDateTime): TSystemTime;\r\nvar\r\n FileTime: TFileTime;\r\nbegin\r\n FileTime := DosDateTimeToFileTime(DosTime);\r\n Result := FileTimeToSystemTime(FileTime);\r\nend;\r\n\r\nfunction SystemTimeToDosDateTime(const SystemTime: TSystemTime): TDosDateTime;\r\nvar\r\n FileTime: TFileTime;\r\nbegin\r\n FileTime := SystemTimeToFileTime(SystemTime);\r\n Result := FileTimeToDosDateTime(FileTime);\r\nend;\r\n\r\n{$ENDIF MSWINDOWS}\r\n\r\n// DosDateTimeToDateTime performs the same action as SysUtils.FileDateToDateTime\r\n// not using SysUtils.FileDateToDateTime this can be done like that:\r\n// var\r\n// FileTime: TFileTime;\r\n// SystemTime: TSystemTime;\r\n// begin\r\n// ResultCheck(DosDateTimeToFileTime(HiWord(DosTime), LoWord(DosTime), FileTime));\r\n// ResultCheck(FileTimeToSystemTime(FileTime, SystemTime));\r\n// Result := SystemTimeToDateTime(SystemTime);\r\n\r\nfunction DosDateTimeToDateTime(const DosTime: TDosDateTime): TDateTime;\r\nbegin\r\n Result := {$IFDEF HAS_UNITSCOPE}System.{$ENDIF}SysUtils.FileDateToDateTime(DosTime);\r\nend;\r\n\r\n// DateTimeToDosDateTime performs the same action as SysUtils.DateTimeToFileDate\r\n// not using SysUtils.DateTimeToDosDateTime this can be done like that:\r\n// var\r\n// SystemTime: TSystemTime;\r\n// FileTime: TFileTime;\r\n// Date, Time: Word;\r\n// begin\r\n// DateTimeToSystemTime(DateTime, SystemTime);\r\n// ResultCheck(SystemTimeToFileTime(SystemTime, FileTime));\r\n// ResultCheck(FileTimeToDosDateTime(FileTime, Date, Time));\r\n// Result := (Date shl 16) or Time;\r\n\r\nfunction DateTimeToDosDateTime(const DateTime: TDateTime): TDosDateTime;\r\nbegin\r\n Result := {$IFDEF HAS_UNITSCOPE}System.{$ENDIF}SysUtils.DateTimeToFileDate(DateTime);\r\nend;\r\n\r\n{$IFDEF MSWINDOWS}\r\n\r\nfunction FileTimeToSystemTime(const FileTime: TFileTime): TSystemTime; overload;\r\nbegin\r\n ResultCheck({$IFDEF HAS_UNITSCOPE}Winapi.{$ENDIF}Windows.FileTimeToSystemTime(FileTime, Result));\r\nend;\r\n\r\nprocedure FileTimeToSystemTime(const FileTime: TFileTime; out ST: TSystemTime); overload;\r\nbegin\r\n {$IFDEF FPC}\r\n ST.Day := 0;\r\n {$ENDIF FPC}\r\n {$IFDEF HAS_UNITSCOPE}Winapi.{$ENDIF}Windows.FileTimeToSystemTime(FileTime, ST);\r\nend;\r\n\r\nfunction SystemTimeToFileTime(const SystemTime: TSystemTime): TFileTime; overload;\r\nbegin\r\n Result.dwHighDateTime := 0;\r\n Result.dwLowDateTime := 0;\r\n ResultCheck({$IFDEF HAS_UNITSCOPE}Winapi.{$ENDIF}Windows.SystemTimeToFileTime(SystemTime, Result));\r\nend;\r\n\r\nprocedure SystemTimeToFileTime(const SystemTime: TSystemTime; FTime: TFileTime); overload;\r\nbegin\r\n {$IFDEF HAS_UNITSCOPE}Winapi.{$ENDIF}Windows.SystemTimeToFileTime(SystemTime, FTime);\r\nend;\r\n\r\nfunction DateTimeToSystemTime(DateTime: TDateTime): TSystemTime; overload;\r\nbegin\r\n {$IFDEF HAS_UNITSCOPE}System.{$ENDIF}SysUtils.DateTimeToSystemTime(DateTime, Result);\r\nend;\r\n\r\nprocedure DateTimeToSystemTime(DateTime: TDateTime; out SysTime: TSystemTime); overload;\r\nbegin\r\n {$IFDEF HAS_UNITSCOPE}System.{$ENDIF}SysUtils.DateTimeToSystemTime(DateTime, SysTime);\r\nend;\r\n\r\nfunction DosDateTimeToFileTime(DosTime: TDosDateTime): TFileTime; overload;\r\nbegin\r\n Result.dwHighDateTime := 0;\r\n Result.dwLowDateTime := 0;\r\n ResultCheck({$IFDEF HAS_UNITSCOPE}Winapi.{$ENDIF}Windows.DosDateTimeToFileTime(HIWORD(DosTime), LOWORD(DosTime), Result));\r\nend;\r\n\r\nprocedure DosDateTimeToFileTime(DTH, DTL: Word; FT: TFileTime); overload;\r\nbegin\r\n {$IFDEF HAS_UNITSCOPE}Winapi.{$ENDIF}Windows.DosDateTimeToFileTime(DTH, DTL, FT);\r\nend;\r\n\r\nfunction FileTimeToDosDateTime(const FileTime: TFileTime): TDosDateTime; overload;\r\nvar\r\n Date, Time: Word;\r\nbegin\r\n Date := 0;\r\n Time := 0;\r\n ResultCheck({$IFDEF HAS_UNITSCOPE}Winapi.{$ENDIF}Windows.FileTimeToDosDateTime(FileTime, Date, Time));\r\n Result := (Date shl 16) or Time;\r\nend;\r\n\r\nprocedure FileTimeToDosDateTime(const FileTime: TFileTime; out Date, Time: Word); overload;\r\nbegin\r\n Date := 0;\r\n Time := 0;\r\n {$IFDEF HAS_UNITSCOPE}Winapi.{$ENDIF}Windows.FileTimeToDosDateTime(FileTime, Date, Time);\r\nend;\r\n\r\n{$ENDIF MSWINDOWS}\r\n\r\nfunction FileTimeToStr(const FileTime: TFileTime): string;\r\nvar\r\n DateTime: TDateTime;\r\nbegin\r\n DateTime := FileTimeToDateTime(FileTime);\r\n Result := DateTimeToStr(DateTime);\r\nend;\r\n\r\nfunction DosDateTimeToStr(DateTime: Integer): string;\r\nbegin\r\n Result := DateTimeToStr(DosDateTimeToDateTime(DateTime));\r\nend;\r\n\r\n{$IFDEF MSWINDOWS}\r\n\r\n// we can't do this better without copying Borland-owned code from the Delphi VCL,\r\n// as the straight forward conversion doing exactly this task is hidden\r\n// deeply inside SysUtils.pas.\r\n// So the date is converted forth and back to/from Julian date\r\n// If someone needs a faster version please take a look at SysUtils.pas->DateTimeToStr.\r\n\r\nfunction SystemTimeToStr(const SystemTime: TSystemTime): string;\r\nbegin\r\n Result := DateTimeToStr(SystemTimeToDateTime(SystemTime));\r\nend;\r\n\r\nfunction CreationDateTimeOfFile(const Sr: TSearchRec): TDateTime;\r\nbegin\r\n Result := FileTimeToDateTime(Sr.FindData.ftCreationTime);\r\nend;\r\n\r\nfunction LastAccessDateTimeOfFile(const Sr: TSearchRec): TDateTime;\r\nbegin\r\n Result := FileTimeToDateTime(Sr.FindData.ftLastAccessTime);\r\nend;\r\n\r\nfunction LastWriteDateTimeOfFile(const Sr: TSearchRec): TDateTime;\r\nbegin\r\n Result := FileTimeToDateTime(Sr.FindData.ftLastWriteTime);\r\nend;\r\n\r\n{$ENDIF MSWINDOWS}\r\n\r\n// Additional format tokens (also available in upper case):\r\n// w: Week no according to ISO\r\n// ww: Week no according to ISO forced two digits\r\n// i: Year of the ISO-week denoted by w (4 digits for 1000..9999)\r\n// ii: Year of the ISO-week denoted by w forced two digits\r\n// e: Number of the Day in the ISO-week denoted by w (ISO-Notation 1=Monday...)\r\n// f: Number of the Day in the year denoted by y\r\n// fff: Number of the Day in the year denoted by y forced three digits\r\n\r\nfunction FormatDateTime(Form: string; DateTime: TDateTime): string;\r\nvar\r\n N: Integer;\r\n ISODay, ISOWeek, ISOYear, DayOfYear, YY: Integer;\r\n\r\n procedure Digest;\r\n begin\r\n if N > 1 then\r\n begin\r\n Result := Result + Copy(Form, 1, N - 1);\r\n Delete(Form, 1, N - 1);\r\n N := 1;\r\n end;\r\n end;\r\n\r\nbegin\r\n ISOWeek := 0;\r\n DayOfYear := 0;\r\n Result := '';\r\n N := 1;\r\n while N <= Length(Form) do\r\n begin\r\n case Form[N] of\r\n '\"':\r\n begin\r\n Inc(N);\r\n Digest;\r\n N := Pos('\"', Form);\r\n if N = 0 then\r\n begin\r\n Result := Result + Form;\r\n Form := '';\r\n N := 1;\r\n end\r\n else\r\n begin\r\n Inc(N);\r\n Digest;\r\n end;\r\n end;\r\n '''':\r\n begin\r\n Inc(N);\r\n Digest;\r\n N := Pos('''', Form);\r\n if N = 0 then\r\n begin\r\n Result := Result + Form;\r\n Form := '';\r\n N := 1;\r\n end\r\n else\r\n begin\r\n Inc(N);\r\n Digest;\r\n end;\r\n end;\r\n 'i', 'I': //ISO Week Year\r\n begin\r\n Digest;\r\n if ISOWeek = 0 then\r\n ISOWeek := ISOWeekNumber(DateTime, ISOYear, ISODay);\r\n if (Length(Form) > 1) and ((Form[2] = 'i') or (Form[2] = 'I')) then\r\n begin // \r\n if (Length(Form) > 2) and ((Form[3] = 'i') or (Form[3] = 'I')) then\r\n begin\r\n if (Length(Form) > 3) and ((Form[4] = 'i') or (Form[4] = 'I')) then\r\n begin // \r\n Delete(Form, 1, 4);\r\n Result := Result + '\"' + IntToStr(ISOYear) + '\"';\r\n end\r\n else\r\n begin // \r\n Delete(Form, 1, 3);\r\n Result := Result + '\"' + IntToStr(ISOYear) + '\"';\r\n end;\r\n end\r\n else\r\n begin // \r\n Delete(Form, 1, 2);\r\n Result := Result + '\"';\r\n if ISOYear < 10 then\r\n Result := Result + '0';\r\n YY := ISOYear mod 100;\r\n if YY < 10 then\r\n Result := Result + '0';\r\n Result := Result + IntToStr(YY) + '\"';\r\n end;\r\n end\r\n else\r\n begin // \r\n Delete(Form, 1, 1);\r\n Result := Result + '\"' + IntToStr(ISOYear) + '\"';\r\n end;\r\n end;\r\n 'w', 'W': // ISO Week\r\n begin\r\n Digest;\r\n if ISOWeek = 0 then\r\n ISOWeek := ISOWeekNumber(DateTime, ISOYear, ISODay);\r\n if (Length(Form) > 1) and ((Form[2] = 'w') or (Form[2] = 'W')) then\r\n begin // \r\n Delete(Form, 1, 2);\r\n Result := Result + '\"';\r\n if ISOWeek < 10 then\r\n Result := Result + '0';\r\n Result := Result + IntToStr(ISOWeek) + '\"';\r\n end\r\n else\r\n begin // \r\n Delete(Form, 1, 1);\r\n Result := Result + '\"' + IntToStr(ISOWeek) + '\"';\r\n end;\r\n end;\r\n 'e', 'E': // ISO Week Day\r\n begin\r\n Digest;\r\n if ISOWeek = 0 then\r\n ISOWeek := ISOWeekNumber(DateTime, ISOYear, ISODay);\r\n Delete(Form, 1, 1);\r\n Result := Result + '\"' + IntToStr(ISODay) + '\"';\r\n end;\r\n 'f', 'F': // Day of the Year\r\n begin\r\n Digest;\r\n if DayOfYear = 0 then\r\n DayOfYear := DayOfTheYear(DateTime);\r\n if (Length(Form) > 1) and ((Form[2] = 'f') or (Form[2] = 'F')) then\r\n begin\r\n if (Length(Form) > 2) and ((Form[3] = 'f') or (Form[3] = 'F')) then\r\n begin // \r\n Delete(Form, 1, 3);\r\n Result := Result + '\"';\r\n if DayOfYear < 10 then\r\n Result := Result + '0';\r\n if DayOfYear < 100 then\r\n Result := Result + '0';\r\n Result := Result + IntToStr(DayOfYear) + '\"';\r\n end\r\n else\r\n begin // \r\n Delete(Form, 1, 2);\r\n Result := Result + '\"';\r\n if DayOfYear < 10 then\r\n Result := Result + '0';\r\n Result := Result + IntToStr(DayOfYear) + '\"';\r\n end;\r\n end\r\n else\r\n begin // \r\n Delete(Form, 1, 1);\r\n Result := Result + '\"' + IntToStr(DayOfYear) + '\"';\r\n end\r\n end;\r\n else\r\n Inc(N);\r\n end;\r\n end;\r\n Result := {$IFDEF HAS_UNITSCOPE}System.{$ENDIF}SysUtils.FormatDateTime(Result + Form, DateTime);\r\nend;\r\n\r\n// FAT has a granularity of 2 seconds\r\n// The intervals are 1/10 of a second\r\n\r\nfunction FATDatesEqual(const FileTime1, FileTime2: Int64): Boolean;\r\nconst\r\n ALLOWED_FAT_FILE_TIME_VARIATION = 20;\r\nbegin\r\n Result := Abs(FileTime1 - FileTime2) <= ALLOWED_FAT_FILE_TIME_VARIATION;\r\nend;\r\n\r\nfunction FATDatesEqual(const FileTime1, FileTime2: TFileTime): Boolean;\r\nbegin\r\n Result := FATDatesEqual(Int64(FileTime1), Int64(FileTime2));\r\nend;\r\n\r\n// Conversion Unix time <--> TDateTime\r\n\r\nfunction DateTimeToUnixTime(DateTime: TDateTime): TJclUnixTime32;\r\nbegin\r\n Result := Round((DateTime-UnixTimeStart) * SecondsPerDay);\r\nend;\r\n\r\nfunction UnixTimeToDateTime(const UnixTime: TJclUnixTime32): TDateTime;\r\nbegin\r\n Result:= UnixTimeStart + (UnixTime / SecondsPerDay);\r\nend;\r\n\r\n// Conversion Unix time <--> FileTime\r\n\r\n{$IFDEF MSWINDOWS}\r\n\r\nfunction UnixTimeToFileTime(const AValue: TJclUnixTime32): TFileTime;\r\nbegin\r\n Result := DateTimeToFileTime(UnixTimeToDateTime(AValue));\r\nend;\r\n\r\nfunction FileTimeToUnixTime(const AValue: TFileTime): TJclUnixTime32;\r\nbegin\r\n Result := DateTimeToUnixTime(FileTimeToDateTime(AValue));\r\nend;\r\n\r\n{$ENDIF MSWINDOWS}\r\n\r\n// Time stamps utilities\r\n\r\n// Utility functions\r\nfunction NullStamp: TTimeStamp;\r\nbegin\r\n Result.Date := 0;\r\n Result.Time := -1;\r\nend;\r\n\r\nfunction CompareTimeStamps(const Stamp1, Stamp2: TTimeStamp): Int64;\r\nbegin\r\n if Stamp1.Date < Stamp2.Date then\r\n Result := -1\r\n else\r\n if Stamp1.Date = Stamp2.Date then\r\n begin\r\n if Stamp1.Time < Stamp2.Time then\r\n Result := -1\r\n else\r\n if Stamp1.Time = Stamp2.Time then\r\n Result := 0\r\n else // If Stamp1.Time > Stamp2.Time then\r\n Result := 1;\r\n end\r\n else // if Stamp1.Date > Stamp2.Date then\r\n Result := 1;\r\n// Result := Int64(Stamp1) - Int64(Stamp2);\r\nend;\r\n\r\nfunction EqualTimeStamps(const Stamp1, Stamp2: TTimeStamp): Boolean;\r\nbegin\r\n Result := CompareTimeStamps(Stamp1, Stamp2) = 0;\r\nend;\r\n\r\nfunction IsNullTimeStamp(const Stamp: TTimeStamp): Boolean;\r\nbegin\r\n Result := CompareTimeStamps(NullStamp, Stamp) = 0;\r\nend;\r\n\r\nfunction TimeStampDOW(const Stamp: TTimeStamp): Integer;\r\nbegin\r\n Result := (Stamp.Date - 1) mod 7 + 1\r\nend;\r\n\r\n// day of week utilities\r\n\r\nfunction FirstWeekDay(const Year, Month: Integer; out DOW: Integer): Integer;\r\nbegin\r\n DOW := ISODayOfWeek(EncodeDate(Year, Month, 1));\r\n if DOW > 5 then\r\n begin\r\n Result := 9 - DOW;\r\n DOW := 1;\r\n end\r\n else\r\n Result := 1;\r\nend;\r\n\r\nfunction FirstWeekDay(const Year, Month: Integer): Integer;\r\nvar\r\n Dummy: Integer;\r\nbegin\r\n Result := FirstWeekDay(Year, Month, Dummy);\r\nend;\r\n\r\nfunction LastWeekDay(const Year, Month: Integer; out DOW: Integer): Integer;\r\nbegin\r\n DOW := ISODayOfWeek(EncodeDate(Year, Month, DaysInMonth(EncodeDate(Year, Month, 1))));\r\n if DOW > 5 then\r\n begin\r\n Result := DaysInMonth(EncodeDate(Year, Month, 1)) - (DOW - 5);\r\n DOW := 5;\r\n end\r\n else\r\n Result := DaysInMonth(EncodeDate(Year, Month, 1));\r\nend;\r\n\r\nfunction LastWeekDay(const Year, Month: Integer): Integer;\r\nvar\r\n Dummy: Integer;\r\nbegin\r\n Result := LastWeekDay(Year, Month, Dummy);\r\nend;\r\n\r\nfunction IndexedWeekDay(const Year, Month: Integer; Index: Integer): Integer;\r\nvar\r\n DOW: Integer;\r\nbegin\r\n if Index > 0 then\r\n Result := FirstWeekDay(Year, Month, DOW)\r\n else\r\n if Index < 0 then\r\n Result := LastWeekDay(Year, Month, DOW)\r\n else\r\n Result := 0;\r\n if Index > 1 then // n-th weekday from start of month\r\n begin\r\n Dec(Index);\r\n if DOW > 1 then // adjust to first monday\r\n begin\r\n if Index < (5 - DOW) then\r\n begin\r\n Inc(Result, Index);\r\n Index := 0;\r\n end\r\n else\r\n begin\r\n Dec(Index, 6 - DOW);\r\n Inc(Result, 8 - DOW);\r\n end;\r\n end;\r\n Result := Result + (7 * (Index div 5)) + (Index mod 5);\r\n end\r\n else\r\n if Index < -1 then // n-th weekday from end of month\r\n begin\r\n Index := Abs(Index) - 1;\r\n if DOW < 5 then // adjust to last friday\r\n begin\r\n if Index < DOW then\r\n begin\r\n Dec(Result, Index);\r\n Index := 0;\r\n end\r\n else\r\n begin\r\n Dec(Index, DOW);\r\n Dec(Result, DOW + 2);\r\n end;\r\n end;\r\n Result := Result - (7 * (Index div 5)) - (Index mod 5);\r\n end;\r\n if (Result < 0) or (Result > DaysInMonth(EncodeDate(Year, Month, 1))) then\r\n Result := 0;\r\nend;\r\n\r\nfunction FirstWeekendDay(const Year, Month: Integer; out DOW: Integer): Integer;\r\nbegin\r\n DOW := ISODayOfWeek(EncodeDate(Year, Month, 1));\r\n if DOW < 6 then\r\n begin\r\n Result := 7 - DOW;\r\n DOW := 6;\r\n end\r\n else\r\n Result := 1;\r\nend;\r\n\r\nfunction FirstWeekendDay(const Year, Month: Integer): Integer;\r\nvar\r\n Dummy: Integer;\r\nbegin\r\n Result := FirstWeekendDay(Year, Month, Dummy);\r\nend;\r\n\r\nfunction LastWeekendDay(const Year, Month: Integer; out DOW: Integer): Integer;\r\nbegin\r\n DOW := ISODayOfWeek(EncodeDate(Year, Month, DaysInMonth(EncodeDate(Year, Month, 1))));\r\n if DOW < 6 then\r\n begin\r\n Result := DaysInMonth(EncodeDate(Year, Month, 1)) - DOW;\r\n DOW := 7;\r\n end\r\n else\r\n Result := DaysInMonth(EncodeDate(Year, Month, 1));\r\nend;\r\n\r\nfunction LastWeekendDay(const Year, Month: Integer): Integer;\r\nvar\r\n Dummy: Integer;\r\nbegin\r\n Result := LastWeekendDay(Year, Month, Dummy);\r\nend;\r\n\r\nfunction IndexedWeekendDay(const Year, Month: Integer; Index: Integer): Integer;\r\nvar\r\n DOW: Integer;\r\nbegin\r\n if Index > 0 then\r\n Result := FirstWeekendDay(Year, Month, DOW)\r\n else\r\n if Index < 0 then\r\n Result := LastWeekendDay(Year, Month, DOW)\r\n else\r\n Result := 0;\r\n if Index > 1 then // n-th weekend day from the start of the month\r\n begin\r\n if (DOW > 6) and not Odd(Index) then // Adjust to first saturday\r\n begin\r\n Inc(Result, 6);\r\n Dec(Index);\r\n end;\r\n if Index > 1 then\r\n begin\r\n Dec(Index);\r\n Result := Result + (7 * (Index div 2)) + (Index mod 2);\r\n end;\r\n end\r\n else\r\n if Index < -1 then // n-th weekend day from the start of the month\r\n begin\r\n Index := Abs(Index);\r\n if (DOW < 7) and not Odd(Index) then // Adjust to last sunday\r\n begin\r\n Dec(Result, 6);\r\n Dec(Index);\r\n end;\r\n if Index > 1 then\r\n begin\r\n Dec(Index);\r\n Result := Result - (7 * (Index div 2)) - (Index mod 2);\r\n end;\r\n end;\r\n if (Result < 0) or (Result > DaysInMonth(EncodeDate(Year, Month, 1))) then\r\n Result := 0;\r\nend;\r\n\r\nfunction FirstDayOfWeek(const Year, Month, DayOfWeek: Integer): Integer;\r\nvar\r\n DOW: Integer;\r\nbegin\r\n DOW := ISODayOfWeek(EncodeDate(Year, Month, 1));\r\n if DOW > DayOfWeek then\r\n Result := 8 + DayOfWeek - DOW\r\n else\r\n if DOW < DayOfWeek then\r\n Result := 1 + DayOfWeek - DOW\r\n else\r\n Result := 1;\r\nend;\r\n\r\nfunction LastDayOfWeek(const Year, Month, DayOfWeek: Integer): Integer;\r\nvar\r\n DOW: Integer;\r\nbegin\r\n DOW := ISODayOfWeek(EncodeDate(Year, Month, DaysInMonth(EncodeDate(Year, Month, 1))));\r\n if DOW > DayOfWeek then\r\n Result := DaysInMonth(EncodeDate(Year, Month, 1)) - (DOW - DayOfWeek)\r\n else\r\n if DOW < DayOfWeek then\r\n Result := DaysInMonth(EncodeDate(Year, Month, 1)) - (7 - DayOfWeek + DOW)\r\n else\r\n Result := DaysInMonth(EncodeDate(Year, Month, 1));\r\nend;\r\n\r\nfunction IndexedDayOfWeek(const Year, Month, DayOfWeek, Index: Integer): Integer;\r\nbegin\r\n if Index > 0 then\r\n Result := FirstDayOfWeek(Year, Month, DayOfWeek) + 7 * (Index - 1)\r\n else\r\n if Index < 0 then\r\n Result := LastDayOfWeek(Year, Month, DayOfWeek) - 7 * (Abs(Index) - 1)\r\n else\r\n Result := 0;\r\n if (Result < 0) or (Result > DaysInMonth(EncodeDate(Year, Month, 1))) then\r\n Result := 0;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n\r\n" }, { "path": "External/Jedi/Jcl/source/common/JclDevToolsResources.pas", "content": "{**************************************************************************************************}\r\n{ }\r\n{ Project JEDI Code Library (JCL) }\r\n{ }\r\n{ The contents of this file are subject to the Mozilla Public License Version 1.1 (the \"License\"); }\r\n{ you may not use this file except in compliance with the License. You may obtain a copy of the }\r\n{ License at http://www.mozilla.org/MPL/ }\r\n{ }\r\n{ Software distributed under the License is distributed on an \"AS IS\" basis, WITHOUT WARRANTY OF }\r\n{ ANY KIND, either express or implied. See the License for the specific language governing rights }\r\n{ and limitations under the License. }\r\n{ }\r\n{ The Original Code is JclResources.pas. }\r\n{ }\r\n{ The Initial Developer of the Original Code is Marcel van Brakel. }\r\n{ Portions created by Marcel van Brakel are Copyright (C) Marcel van Brakel. All rights reserved. }\r\n{ }\r\n{ Contributors: }\r\n{ Alexei Koudinov }\r\n{ Barry Kelly }\r\n{ Flier Lu (flier) }\r\n{ Florent Ouchet (outchy) }\r\n{ Jean-Fabien Connault (cycocrew) }\r\n{ Marcel Bestebroer }\r\n{ Marcel van Brakel }\r\n{ Matthias Thoma (mthoma) }\r\n{ Peter Friese }\r\n{ Petr Vones (pvones) }\r\n{ Raymond Alexander (rayspostbox3) }\r\n{ Robert Marquardt (marquardt) }\r\n{ Robert Rossmair (rrossmair) }\r\n{ Scott Price (scottprice) }\r\n{ Uwe Schuster (uschuster) }\r\n{ }\r\n{**************************************************************************************************}\r\n{ }\r\n{ Unit which provides a central place for all resource strings used in the JCL developer tool }\r\n{ }\r\n{**************************************************************************************************}\r\n{ }\r\n{ Last modified: $Date:: 2012-03-02 07:30:10 +0100 (ven. 02 mars 2012) $ }\r\n{ Revision: $Rev:: 3754 $ }\r\n{ Author: $Author:: outchy $ }\r\n{ }\r\n{**************************************************************************************************}\r\n\r\nunit JclDevToolsResources;\r\n\r\n{$I jcl.inc}\r\n\r\ninterface\r\n\r\n{$IFDEF UNITVERSIONING}\r\nuses\r\n JclUnitVersioning;\r\n{$ENDIF UNITVERSIONING}\r\n\r\n//=== JclIDEUtils ============================================================\r\nresourcestring\r\n RsNeedUpdate = 'You should install latest Update Pack #%d for %s';\r\n RsUpdatePackName = 'Update Pack #%d';\r\n RsDelphiName = 'Delphi';\r\n RsBCBName = 'C++Builder';\r\n RsCSharpName = 'C#Builder';\r\n RsBDSName = 'Borland Developer Studio';\r\n RsRSName = 'RAD Studio';\r\n {$IFDEF MSWINDOWS}\r\n RsClientServer = 'Client/Server';\r\n RsStandard = 'Standard';\r\n {$ENDIF MSWINDOWS}\r\n RsArchitect = 'Architect';\r\n RsEnterprise = 'Enterprise';\r\n RsPersonal = 'Personal';\r\n RsProfessional = 'Professional';\r\n\r\n RsMsBuildNotSupported = 'MSBuild is not supported by this IDE';\r\n\r\n RsPackageInstallationStarted = 'Installing package %s';\r\n RsPackageInstallationFinished = 'Installation of package finished';\r\n RsPackageUninstallationStarted = 'Uninstalling package %s';\r\n RsPackageUninstallationFinished = 'Uninstallation of package finished';\r\n RsIdePackageInstallationStarted = 'Installing ide package %s';\r\n RsIdePackageInstallationFinished = 'Installation of ide package finished';\r\n RsIdePackageUninstallationStarted = 'Uninstalling ide package %s';\r\n RsIdePackageUninstallationFinished = 'Uninstallation of ide package finished';\r\n RsExpertInstallationStarted = 'Installing expert %s';\r\n RsExpertInstallationFinished = 'Installation of expert finished';\r\n RsExpertUninstallationStarted = 'Uninstalling expert %s';\r\n RsExpertUninstallationFinished = 'Uninstallation of expert finished';\r\n\r\n RsCompilingPackage = 'Compiling package %s';\r\n RsCompilingProject = 'Compiling project %s';\r\n RsCompilationOk = 'Compilation success';\r\n RsCompilationFailed = 'Compilation failure';\r\n RsCreatingJdbg = 'Creating JEDI Debug informations for %s';\r\n RsInsertingJdbg = 'Inserting JEDI Debug informations in %s';\r\n RsJdbgInfo = 'Bug unit: %s; MAP size: %d; Debug size: %d';\r\n RsJdbgInfoOk = 'JDBG successfully generated';\r\n RsJdbgInfoFailed = 'Cannot generate JDBG informations';\r\n RsDeletingFile = 'Deleting file %s';\r\n RsFileDeletionOk = 'File deletion success';\r\n RsFileDeletionFailed = 'File deletion failure';\r\n RsRegisteringPackage = 'Registering package %s';\r\n RsRegisteringIdePackage = 'Registering ide package %s';\r\n RsRegisteringExpert = 'Registering expert %s';\r\n RsRegistrationOk = 'Registration ok';\r\n RsRegistrationFailed = 'Registration failed';\r\n RsUnregisteringPackage = 'Removing from registry package %s';\r\n RsUnregisteringIdePackage = 'Removing from registry ide package %s';\r\n RsUnregisteringExpert = 'Removing from registry expert %s';\r\n RsUnregistrationOk = 'Unregistration ok';\r\n RsUnregistrationFailed = 'Unregistration failed';\r\n RsCleaningPackageCache = 'Cleaning package cache for %s';\r\n RsCleaningOk = 'Cleaning ok';\r\n RsCleaningFailed = 'Cleaning failed';\r\n\r\n RsEUnknownPackageExtension = '%s not a known package extension';\r\n RsEUnknownProjectExtension = '%s not a known project extension';\r\n RsEUnknownIdePackageExtension = '%s not a known IDE package extension';\r\n RsEIndexOufOfRange = 'Index out of range';\r\n RsECmdLineToolOutputInvalid = '%s: Output invalid, when OutputCallback assigned.';\r\n RsENotABcbPackage = '%s not a C++Builder package source file';\r\n RsENotADelphiProject = '%s not a Delphi project source file';\r\n RsENotADelphiPackage = '%s not a Delphi package source file';\r\n RsENotFound = '%s not found';\r\n RsECannotInstallRunOnly = 'A run-only package cannot be installed';\r\n RsENotABcbProject = '%s not a C++Builder project source file';\r\n RsENoSupportedPersonality = 'No personalities supported';\r\n RsEDualPackageNotSupported = 'This installation of %s doesn''t support dual packages';\r\n RsEWin64PlatformNotValid = 'This installation cannot generate binaries for Win64';\r\n RsEOSXPlatformNotValid = 'This installation cannot generate binaries for OSX';\r\n RsEPlatformNotValid = 'This installation cannot generate binaries for an unknown platform';\r\n {$IFDEF MSWINDOWS}\r\n RsENoOpenHelp = 'open help not present in Borland Developer Studio';\r\n {$ENDIF MSWINDOWS}\r\n RsERsVars = 'Query of RsVars for %s %d reported the following error \"%s\"';\r\n\r\n//=== JclMsBuild.pas =========================================================\r\nresourcestring\r\n RsEEndOfString = 'Invalid condition: end of string in condition \"%s\"';\r\n RsEMissingParenthesis = 'Invalid condition: missing parenthesis in condition \"%s\"';\r\n RsEUnknownOperator = 'Invalid condition: unknown operator in condition \"%s\"';\r\n RsEReservedProperty = 'Attempt to override or to delete a reserved MsBuild property';\r\n RsENoProjectElem = 'Project element expected, got \"%s\"';\r\n RsEUnknownSchema = 'Unknown schema \"%s\"';\r\n RsEUnknownProperty = 'Unknown property \"%s\"';\r\n RsEUnknownElement = 'Unknown element \"%s\"';\r\n RsEMultipleProjectExtensions = 'Multiple project extensions';\r\n RsEMultipleOtherwise = 'Multiple otherwise';\r\n RsEConditionNotUnique = 'Condition is not unique';\r\n RsEMissingTargetName = 'Missing target name';\r\n RsEMissingTaskName = 'Missing task name';\r\n RsEMissingAssembly = 'Missing assembly';\r\n RsEMissingTaskParameter = 'Missing task parameter';\r\n RsEMissingOutputName = 'Missing output name';\r\n RsEMSBuildPath = 'Unable to locate MSBuild.exe';\r\n RsEFunctionProperty = 'Unable to evaluate function property \"%s\"';\r\n RsERegistryProperty = 'Unable to evaluate registry property root=\"%s\" path=\"%s\" name=\"%s\"';\r\n RsELocateXmlElem = 'Unable to locate the XML element for MSBuild property \"%s\"';\r\n\r\n//=== JclUsesUtils.pas =======================================================\r\nresourcestring\r\n RsEDuplicateUnit = 'Duplicate unit ''%s''';\r\n RsEInvalidLibrary = 'Invalid library';\r\n RsEInvalidProgram = 'Invalid program';\r\n RsEInvalidUnit = 'Invalid unit';\r\n RsEInvalidUses = 'Invalid uses clause';\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jcl.svn.sourceforge.net/svnroot/jcl/tags/JCL-2.4-Build4571/jcl/source/common/JclDevToolsResources.pas $';\r\n Revision: '$Revision: 3754 $';\r\n Date: '$Date: 2012-03-02 07:30:10 +0100 (ven. 02 mars 2012) $';\r\n LogPath: 'JCL\\source\\common';\r\n Extra: '';\r\n Data: nil\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jcl/source/common/JclExprEval.pas", "content": "{**************************************************************************************************}\r\n{ }\r\n{ Project JEDI Code Library (JCL) }\r\n{ }\r\n{ The contents of this file are subject to the Mozilla Public License Version 1.1 (the \"License\"); }\r\n{ you may not use this file except in compliance with the License. You may obtain a copy of the }\r\n{ License at http://www.mozilla.org/MPL/ }\r\n{ }\r\n{ Software distributed under the License is distributed on an \"AS IS\" basis, WITHOUT WARRANTY OF }\r\n{ ANY KIND, either express or implied. See the License for the specific language governing rights }\r\n{ and limitations under the License. }\r\n{ }\r\n{ The Original Code is JclExprEval.pas. }\r\n{ }\r\n{ The Initial Developer of the Original Code is Barry Kelly. }\r\n{ Portions created by Barry Kelly are Copyright (C) Barry Kelly. All rights reserved. }\r\n{ }\r\n{ Contributor(s): }\r\n{ Barry Kelly }\r\n{ Matthias Thoma (mthoma) }\r\n{ Petr Vones (pvones) }\r\n{ Robert Marquardt (marquardt) }\r\n{ Robert Rossmair (rrossmair) }\r\n{ }\r\n{**************************************************************************************************}\r\n{ }\r\n{ This unit contains three expression evaluators, each tailored for different usage patterns. It }\r\n{ also contains the component objects, so that a customized expression evaluator can be assembled }\r\n{ relatively easily. }\r\n{ }\r\n{**************************************************************************************************}\r\n{ }\r\n{ Last modified: $Date:: 2012-09-04 16:08:04 +0200 (mar. 04 sept. 2012) $ }\r\n{ Revision: $Rev:: 3861 $ }\r\n{ Author: $Author:: outchy $ }\r\n{ }\r\n{**************************************************************************************************}\r\n\r\n// operator priority (as implemented in this unit)\r\n// all binary operators are associated from left to right\r\n// all unary operators are associated from right to left\r\n\r\n// (highest) not bnot(bitwise) +(unary) -(unary) (level 3)\r\n// * / div mod and band(bitwise) shl shr (level 2)\r\n// +(binary) -(binary) or xor bor(bitwise) bxor(bitwise) (level 1)\r\n// (lowest) < <= > >= cmp = <> (level 0)\r\n\r\n// details on cmp operator:\r\n// \"1.5 cmp 2.0\" returns -1.0 because 1.5 < 2.0\r\n// \"1.5 cmp 1.5\" returns 0.0 because 1.5 = 1.5\r\n// \"1.5 cmp 0.0\" returns 1.0 because 1.5 > 0.0\r\n\r\nunit JclExprEval;\r\n\r\n{$I jcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n {$IFDEF HAS_UNITSCOPE}\r\n System.SysUtils, System.Classes,\r\n {$ELSE ~HAS_UNITSCOPE}\r\n SysUtils, Classes,\r\n {$ENDIF ~HAS_UNITSCOPE}\r\n JclBase, JclSysUtils, JclStrHashMap, JclResources;\r\n\r\nconst\r\n cExprEvalHashSize = 127;\r\n\r\ntype\r\n EJclExprEvalError = class(EJclError);\r\n\r\ntype\r\n TFloat = JclBase.Float;\r\n\r\n TFloat32 = Single;\r\n PFloat32 = ^TFloat32;\r\n\r\n TFloat64 = Double;\r\n PFloat64 = ^TFloat64;\r\n\r\n {$IFDEF SUPPORTS_EXTENDED}\r\n TFloat80 = Extended;\r\n PFloat80 = ^TFloat80;\r\n {$ENDIF SUPPORTS_EXTENDED}\r\n\r\n TFloatFunc = function: TFloat;\r\n TFloat32Func = function: TFloat32;\r\n TFloat64Func = function: TFloat64;\r\n {$IFDEF SUPPORTS_EXTENDED}\r\n TFloat80Func = function: TFloat80;\r\n {$ENDIF SUPPORTS_EXTENDED}\r\n\r\n TUnaryFunc = function(X: TFloat): TFloat;\r\n TUnary32Func = function(X: TFloat32): TFloat32;\r\n TUnary64Func = function(X: TFloat64): TFloat64;\r\n {$IFDEF SUPPORTS_EXTENDED}\r\n TUnary80Func = function(X: TFloat80): TFloat80;\r\n {$ENDIF SUPPORTS_EXTENDED}\r\n\r\n TBinaryFunc = function(X, Y: TFloat): TFloat;\r\n TBinary32Func = function(X, Y: TFloat32): TFloat32;\r\n TBinary64Func = function(X, Y: TFloat64): TFloat64;\r\n {$IFDEF SUPPORTS_EXTENDED}\r\n TBinary80Func = function(X, Y: TFloat80): TFloat80;\r\n {$ENDIF SUPPORTS_EXTENDED}\r\n\r\n TTernaryFunc = function(X, Y, Z: TFloat): TFloat;\r\n TTernary32Func = function(X, Y, Z: TFloat32): TFloat32;\r\n TTernary64Func = function(X, Y, Z: TFloat64): TFloat64;\r\n {$IFDEF SUPPORTS_EXTENDED}\r\n TTernary80Func = function(X, Y, Z: TFloat80): TFloat80;\r\n {$ENDIF SUPPORTS_EXTENDED}\r\n\r\ntype\r\n { Forward Declarations }\r\n TExprLexer = class;\r\n TExprCompileParser = class;\r\n TExprEvalParser = class;\r\n TExprSym = class;\r\n TExprNode = class;\r\n TExprNodeFactory = class;\r\n\r\n TExprContext = class(TObject)\r\n public\r\n function Find(const AName: string): TExprSym; virtual; abstract;\r\n end;\r\n\r\n TExprHashContext = class(TExprContext)\r\n private\r\n FHashMap: TStringHashMap;\r\n public\r\n constructor Create(ACaseSensitive: Boolean = False; AHashSize: Integer = 127);\r\n destructor Destroy; override;\r\n procedure Add(ASymbol: TExprSym);\r\n procedure Remove(const AName: string);\r\n function Find(const AName: string): TExprSym; override;\r\n end;\r\n\r\n TExprSetContext = class(TExprContext)\r\n private\r\n FList: TList;\r\n FOwnsContexts: Boolean;\r\n function GetContexts(AIndex: Integer): TExprContext;\r\n function GetCount: Integer;\r\n public\r\n constructor Create(AOwnsContexts: Boolean);\r\n destructor Destroy; override;\r\n procedure Add(AContext: TExprContext);\r\n procedure Remove(AContext: TExprContext);\r\n procedure Delete(AIndex: Integer);\r\n function Extract(AContext: TExprContext): TExprContext;\r\n property Count: Integer read GetCount;\r\n property Contexts[AIndex: Integer]: TExprContext read GetContexts;\r\n property InternalList: TList read FList;\r\n function Find(const AName: string): TExprSym; override;\r\n end;\r\n\r\n TExprSym = class(TObject)\r\n private\r\n FIdent: string;\r\n FLexer: TExprLexer;\r\n FEvalParser: TExprEvalParser;\r\n FCompileParser: TExprCompileParser;\r\n FNodeFactory: TExprNodeFactory;\r\n public\r\n constructor Create(const AIdent: string);\r\n function Evaluate: TFloat; virtual; abstract;\r\n function Compile: TExprNode; virtual; abstract;\r\n property Ident: string read FIdent;\r\n property Lexer: TExprLexer read FLexer write FLexer;\r\n property CompileParser: TExprCompileParser read FCompileParser\r\n write FCompileParser;\r\n property EvalParser: TExprEvalParser read FEvalParser write FEvalParser;\r\n property NodeFactory: TExprNodeFactory read FNodeFactory write FNodeFactory;\r\n end;\r\n\r\n TExprToken = (\r\n // specials\r\n etEof,\r\n etNumber,\r\n etIdentifier,\r\n\r\n // user extension tokens\r\n etUser0, etUser1, etUser2, etUser3, etUser4, etUser5, etUser6, etUser7,\r\n etUser8, etUser9, etUser10, etUser11, etUser12, etUser13, etUser14, etUser15,\r\n etUser16, etUser17, etUser18, etUser19, etUser20, etUser21, etUser22, etUser23,\r\n etUser24, etUser25, etUser26, etUser27, etUser28, etUser29, etUser30, etUser31,\r\n\r\n // compound tokens\r\n etNotEqual, // <>\r\n etLessEqual, // <=\r\n etGreaterEqual, // >=\r\n\r\n // ASCII normal & ordinals\r\n\r\n etBang, // '!' #$21 33\r\n etDoubleQuote, // '\"' #$22 34\r\n etHash, // '#' #$23 35\r\n etDollar, // '$' #$24 36\r\n etPercent, // '%' #$25 37\r\n etAmpersand, // '&' #$26 38\r\n etSingleQuote, // '''' #$27 39\r\n etLParen, // '(' #$28 40\r\n etRParen, // ')' #$29 41\r\n etAsterisk, // '*' #$2A 42\r\n etPlus, // '+' #$2B 43\r\n etComma, // ',' #$2C 44\r\n etMinus, // '-' #$2D 45\r\n etDot, // '.' #$2E 46\r\n etForwardSlash, // '/' #$2F 47\r\n\r\n // 48..57 - numbers...\r\n\r\n etColon, // ':' #$3A 58\r\n etSemiColon, // ';' #$3B 59\r\n etLessThan, // '<' #$3C 60\r\n etEqualTo, // '=' #$3D 61\r\n etGreaterThan, // '>' #$3E 62\r\n etQuestion, // '?' #$3F 63\r\n etAt, // '@' #$40 64\r\n\r\n // 65..90 - capital letters...\r\n\r\n etLBracket, // '[' #$5B 91\r\n etBackSlash, // '\\' #$5C 92\r\n etRBracket, // ']' #$5D 93\r\n etArrow, // '^' #$5E 94\r\n // 95 - underscore\r\n etBackTick, // '`' #$60 96\r\n\r\n // 97..122 - small letters...\r\n\r\n etLBrace, // '{' #$7B 123\r\n etPipe, // '|' #$7C 124\r\n etRBrace, // '}' #$7D 125\r\n etTilde, // '~' #$7E 126\r\n et127, // '' #$7F 127\r\n etEuro, // '' #$80 128\r\n et129, // '' #$81 129\r\n et130, // '' #$82 130\r\n et131, // '' #$83 131\r\n et132, // '' #$84 132\r\n et133, // '' #$85 133\r\n et134, // '' #$86 134\r\n et135, // '' #$87 135\r\n et136, // '' #$88 136\r\n et137, // '' #$89 137\r\n et138, // '' #$8A 138\r\n et139, // '' #$8B 139\r\n et140, // '' #$8C 140\r\n et141, // '' #$8D 141\r\n et142, // '' #$8E 142\r\n et143, // '' #$8F 143\r\n et144, // '' #$90 144\r\n et145, // '' #$91 145\r\n et146, // '' #$92 146\r\n et147, // '' #$93 147\r\n et148, // '' #$94 148\r\n et149, // '' #$95 149\r\n et150, // '' #$96 150\r\n et151, // '' #$97 151\r\n et152, // '' #$98 152\r\n et153, // '' #$99 153\r\n et154, // '' #$9A 154\r\n et155, // '' #$9B 155\r\n et156, // '' #$9C 156\r\n et157, // '' #$9D 157\r\n et158, // '' #$9E 158\r\n et159, // '' #$9F 159\r\n et160, // '' #$A0 160\r\n et161, // '' #$A1 161\r\n et162, // '' #$A2 162\r\n et163, // '' #$A3 163\r\n et164, // '' #$A4 164\r\n et165, // '' #$A5 165\r\n et166, // '' #$A6 166\r\n et167, // '' #$A7 167\r\n et168, // '' #$A8 168\r\n et169, // '' #$A9 169\r\n et170, // '' #$AA 170\r\n et171, // '' #$AB 171\r\n et172, // '' #$AC 172\r\n et173, // '' #$AD 173\r\n et174, // '' #$AE 174\r\n et175, // '' #$AF 175\r\n et176, // '' #$B0 176\r\n et177, // '' #$B1 177\r\n et178, // '' #$B2 178\r\n et179, // '' #$B3 179\r\n et180, // '' #$B4 180\r\n et181, // '' #$B5 181\r\n et182, // '' #$B6 182\r\n et183, // '' #$B7 183\r\n et184, // '' #$B8 184\r\n et185, // '' #$B9 185\r\n et186, // '' #$BA 186\r\n et187, // '' #$BB 187\r\n et188, // '' #$BC 188\r\n et189, // '' #$BD 189\r\n et190, // '' #$BE 190\r\n et191, // '' #$BF 191\r\n et192, // '' #$C0 192\r\n et193, // '' #$C1 193\r\n et194, // '' #$C2 194\r\n et195, // '' #$C3 195\r\n et196, // '' #$C4 196\r\n et197, // '' #$C5 197\r\n et198, // '' #$C6 198\r\n et199, // '' #$C7 199\r\n et200, // '' #$C8 200\r\n et201, // '' #$C9 201\r\n et202, // '' #$CA 202\r\n et203, // '' #$CB 203\r\n et204, // '' #$CC 204\r\n et205, // '' #$CD 205\r\n et206, // '' #$CE 206\r\n et207, // '' #$CF 207\r\n et208, // '' #$D0 208\r\n et209, // '' #$D1 209\r\n et210, // '' #$D2 210\r\n et211, // '' #$D3 211\r\n et212, // '' #$D4 212\r\n et213, // '' #$D5 213\r\n et214, // '' #$D6 214\r\n et215, // '' #$D7 215\r\n et216, // '' #$D8 216\r\n et217, // '' #$D9 217\r\n et218, // '' #$DA 218\r\n et219, // '' #$DB 219\r\n et220, // '' #$DC 220\r\n et221, // '' #$DD 221\r\n et222, // '' #$DE 222\r\n et223, // '' #$DF 223\r\n et224, // '' #$E0 224\r\n et225, // '' #$E1 225\r\n et226, // '' #$E2 226\r\n et227, // '' #$E3 227\r\n et228, // '' #$E4 228\r\n et229, // '' #$E5 229\r\n et230, // '' #$E6 230\r\n et231, // '' #$E7 231\r\n et232, // '' #$E8 232\r\n et233, // '' #$E9 233\r\n et234, // '' #$EA 234\r\n et235, // '' #$EB 235\r\n et236, // '' #$EC 236\r\n et237, // '' #$ED 237\r\n et238, // '' #$EE 238\r\n et239, // '' #$EF 239\r\n et240, // '' #$F0 240\r\n et241, // '' #$F1 241\r\n et242, // '' #$F2 242\r\n et243, // '' #$F3 243\r\n et244, // '' #$F4 244\r\n et245, // '' #$F5 245\r\n et246, // '' #$F6 246\r\n et247, // '' #$F7 247\r\n et248, // '' #$F8 248\r\n et249, // '' #$F9 249\r\n et250, // '' #$FA 250\r\n et251, // '' #$FB 251\r\n et252, // '' #$FC 252\r\n et253, // '' #$FD 253\r\n et254, // '' #$FE 254\r\n et255, // '' #$FF 255\r\n etInvalid // invalid token type\r\n );\r\n\r\n TExprLexer = class(TObject)\r\n protected\r\n FCurrTok: TExprToken;\r\n FTokenAsNumber: TFloat;\r\n FTokenAsString: string;\r\n public\r\n constructor Create;\r\n procedure NextTok; virtual; abstract;\r\n procedure Reset; virtual;\r\n property TokenAsString: string read FTokenAsString;\r\n property TokenAsNumber: TFloat read FTokenAsNumber;\r\n property CurrTok: TExprToken read FCurrTok;\r\n end;\r\n\r\n TExprNode = class(TObject)\r\n private\r\n FDepList: TList;\r\n function GetDepCount: Integer;\r\n function GetDeps(AIndex: Integer): TExprNode;\r\n public\r\n constructor Create(const ADepList: array of TExprNode);\r\n destructor Destroy; override;\r\n procedure AddDep(ADep: TExprNode);\r\n property DepCount: Integer read GetDepCount;\r\n property Deps[AIndex: Integer]: TExprNode read GetDeps; default;\r\n property DepList: TList read FDepList;\r\n end;\r\n\r\n TExprNodeFactory = class(TObject)\r\n public\r\n function LoadVar32(ALoc: PFloat32): TExprNode; virtual; abstract;\r\n function LoadVar64(ALoc: PFloat64): TExprNode; virtual; abstract;\r\n {$IFDEF SUPPORTS_EXTENDED}\r\n function LoadVar80(ALoc: PFloat80): TExprNode; virtual; abstract;\r\n {$ENDIF SUPPORTS_EXTENDED}\r\n\r\n function LoadConst32(AValue: TFloat32): TExprNode; virtual; abstract;\r\n function LoadConst64(AValue: TFloat64): TExprNode; virtual; abstract;\r\n {$IFDEF SUPPORTS_EXTENDED}\r\n function LoadConst80(AValue: TFloat80): TExprNode; virtual; abstract;\r\n {$ENDIF SUPPORTS_EXTENDED}\r\n\r\n function CallFloatFunc(AFunc: TFloatFunc): TExprNode; virtual; abstract;\r\n function CallFloat32Func(AFunc: TFloat32Func): TExprNode; virtual; abstract;\r\n function CallFloat64Func(AFunc: TFloat64Func): TExprNode; virtual; abstract;\r\n {$IFDEF SUPPORTS_EXTENDED}\r\n function CallFloat80Func(AFunc: TFloat80Func): TExprNode; virtual; abstract;\r\n {$ENDIF SUPPORTS_EXTENDED}\r\n function CallUnaryFunc(AFunc: TUnaryFunc; X: TExprNode): TExprNode; virtual; abstract;\r\n function CallUnary32Func(AFunc: TUnary32Func; X: TExprNode): TExprNode; virtual; abstract;\r\n function CallUnary64Func(AFunc: TUnary64Func; X: TExprNode): TExprNode; virtual; abstract;\r\n {$IFDEF SUPPORTS_EXTENDED}\r\n function CallUnary80Func(AFunc: TUnary80Func; X: TExprNode): TExprNode; virtual; abstract;\r\n {$ENDIF SUPPORTS_EXTENDED}\r\n function CallBinaryFunc(AFunc: TBinaryFunc; X, Y: TExprNode): TExprNode; virtual; abstract;\r\n function CallBinary32Func(AFunc: TBinary32Func; X, Y: TExprNode): TExprNode; virtual; abstract;\r\n function CallBinary64Func(AFunc: TBinary64Func; X, Y: TExprNode): TExprNode; virtual; abstract;\r\n {$IFDEF SUPPORTS_EXTENDED}\r\n function CallBinary80Func(AFunc: TBinary80Func; X, Y: TExprNode): TExprNode; virtual; abstract;\r\n {$ENDIF SUPPORTS_EXTENDED}\r\n function CallTernaryFunc(AFunc: TTernaryFunc; X, Y, Z: TExprNode): TExprNode; virtual; abstract;\r\n function CallTernary32Func(AFunc: TTernary32Func; X, Y, Z: TExprNode): TExprNode; virtual; abstract;\r\n function CallTernary64Func(AFunc: TTernary64Func; X, Y, Z: TExprNode): TExprNode; virtual; abstract;\r\n {$IFDEF SUPPORTS_EXTENDED}\r\n function CallTernary80Func(AFunc: TTernary80Func; X, Y, Z: TExprNode): TExprNode; virtual; abstract;\r\n {$ENDIF SUPPORTS_EXTENDED}\r\n\r\n function Add(ALeft, ARight: TExprNode): TExprNode; virtual; abstract;\r\n function Subtract(ALeft, ARight: TExprNode): TExprNode; virtual; abstract;\r\n function Multiply(ALeft, ARight: TExprNode): TExprNode; virtual; abstract;\r\n function Divide(ALeft, ARight: TExprNode): TExprNode; virtual; abstract;\r\n function IntegerDivide(ALeft, ARight: TExprNode): TExprNode; virtual; abstract;\r\n function Modulo(ALeft, ARight: TExprNode): TExprNode; virtual; abstract;\r\n function Negate(AValue: TExprNode): TExprNode; virtual; abstract;\r\n\r\n function Compare(ALeft, ARight: TExprNode): TExprNode; virtual; abstract;\r\n function CompareEqual(ALeft, ARight: TExprNode): TExprNode; virtual; abstract;\r\n function CompareNotEqual(ALeft, ARight: TExprNode): TExprNode; virtual; abstract;\r\n function CompareLess(ALeft, ARight: TExprNode): TExprNode; virtual; abstract;\r\n function CompareLessEqual(ALeft, ARight: TExprNode): TExprNode; virtual; abstract;\r\n function CompareGreater(ALeft, ARight: TExprNode): TExprNode; virtual; abstract;\r\n function CompareGreaterEqual(ALeft, ARight: TExprNode): TExprNode; virtual; abstract;\r\n\r\n function LogicalAnd(ALeft, ARight: TExprNode): TExprNode; virtual; abstract;\r\n function LogicalOr(ALeft, ARight: TExprNode): TExprNode; virtual; abstract;\r\n function LogicalXor(ALeft, ARight: TExprNode): TExprNode; virtual; abstract;\r\n function LogicalNot(AValue: TExprNode): TExprNode; virtual; abstract;\r\n function BitwiseAnd(ALeft, ARight: TExprNode): TExprNode; virtual; abstract;\r\n function BitwiseOr(ALeft, ARight: TExprNode): TExprNode; virtual; abstract;\r\n function BitwiseXor(ALeft, ARight: TExprNode): TExprNode; virtual; abstract;\r\n function BitwiseNot(AValue: TExprNode): TExprNode; virtual; abstract;\r\n function ShiftLeft(ALeft, ARight: TExprNode): TExprNode; virtual; abstract;\r\n function ShiftRight(ALeft, ARight: TExprNode): TExprNode; virtual; abstract;\r\n\r\n function LoadVar(ALoc: PFloat32): TExprNode; overload;\r\n function LoadVar(ALoc: PFloat64): TExprNode; overload;\r\n {$IFDEF SUPPORTS_EXTENDED}\r\n function LoadVar(ALoc: PFloat80): TExprNode; overload;\r\n {$ENDIF SUPPORTS_EXTENDED}\r\n function LoadConst(AValue: TFloat32): TExprNode; overload;\r\n function LoadConst(AValue: TFloat64): TExprNode; overload;\r\n {$IFDEF SUPPORTS_EXTENDED}\r\n function LoadConst(AValue: TFloat80): TExprNode; overload;\r\n {$ENDIF SUPPORTS_EXTENDED}\r\n end;\r\n\r\n TExprCompileParser = class(TObject)\r\n private\r\n FContext: TExprContext;\r\n FLexer: TExprLexer;\r\n FNodeFactory: TExprNodeFactory;\r\n protected\r\n function CompileExprLevel0(ASkip: Boolean): TExprNode; virtual;\r\n function CompileExprLevel1(ASkip: Boolean): TExprNode; virtual;\r\n function CompileExprLevel2(ASkip: Boolean): TExprNode; virtual;\r\n function CompileExprLevel3(ASkip: Boolean): TExprNode; virtual;\r\n function CompileFactor: TExprNode; virtual;\r\n function CompileIdentFactor: TExprNode; virtual;\r\n public\r\n constructor Create(ALexer: TExprLexer; ANodeFactory: TExprNodeFactory);\r\n function Compile: TExprNode; virtual;\r\n property Lexer: TExprLexer read FLexer;\r\n property NodeFactory: TExprNodeFactory read FNodeFactory;\r\n property Context: TExprContext read FContext write FContext;\r\n end;\r\n\r\n TExprEvalParser = class(TObject)\r\n private\r\n FContext: TExprContext;\r\n FLexer: TExprLexer;\r\n protected\r\n function EvalExprLevel0(ASkip: Boolean): TFloat; virtual;\r\n function EvalExprLevel1(ASkip: Boolean): TFloat; virtual;\r\n function EvalExprLevel2(ASkip: Boolean): TFloat; virtual;\r\n function EvalExprLevel3(ASkip: Boolean): TFloat; virtual;\r\n function EvalFactor: TFloat; virtual;\r\n function EvalIdentFactor: TFloat; virtual;\r\n public\r\n constructor Create(ALexer: TExprLexer);\r\n function Evaluate: TFloat; virtual;\r\n\r\n property Lexer: TExprLexer read FLexer;\r\n property Context: TExprContext read FContext write FContext;\r\n end;\r\n\r\n{ some concrete class descendants follow... }\r\n\r\n TExprSimpleLexer = class(TExprLexer)\r\n protected\r\n FCurrPos: PChar;\r\n FBuf: string;\r\n procedure SetBuf(const ABuf: string);\r\n public\r\n constructor Create(const ABuf: string);\r\n\r\n procedure NextTok; override;\r\n procedure Reset; override;\r\n\r\n property Buf: string read FBuf write SetBuf;\r\n end;\r\n\r\n TExprVirtMachOp = class(TObject)\r\n private\r\n function GetOutputLoc: PFloat;\r\n protected\r\n FOutput: TFloat;\r\n public\r\n procedure Execute; virtual; abstract;\r\n property OutputLoc: PFloat read GetOutputLoc;\r\n end;\r\n\r\n TExprVirtMach = class(TObject)\r\n private\r\n FCodeList: TList;\r\n FConstList: TList;\r\n public\r\n constructor Create;\r\n destructor Destroy; override;\r\n procedure Add(AOp: TExprVirtMachOp);\r\n procedure AddConst(AOp: TExprVirtMachOp);\r\n procedure Clear;\r\n function Execute: TFloat;\r\n end;\r\n\r\n TExprVirtMachNodeFactory = class(TExprNodeFactory)\r\n private\r\n FNodeList: TList;\r\n function AddNode(ANode: TExprNode): TExprNode;\r\n procedure DoClean(AVirtMach: TExprVirtMach);\r\n procedure DoConsts(AVirtMach: TExprVirtMach);\r\n procedure DoCode(AVirtMach: TExprVirtMach);\r\n public\r\n constructor Create;\r\n destructor Destroy; override;\r\n\r\n procedure GenCode(AVirtMach: TExprVirtMach);\r\n\r\n function LoadVar32(ALoc: PFloat32): TExprNode; override;\r\n function LoadVar64(ALoc: PFloat64): TExprNode; override;\r\n {$IFDEF SUPPORTS_EXTENDED}\r\n function LoadVar80(ALoc: PFloat80): TExprNode; override;\r\n {$ENDIF SUPPORTS_EXTENDED}\r\n function LoadConst32(AValue: TFloat32): TExprNode; override;\r\n function LoadConst64(AValue: TFloat64): TExprNode; override;\r\n {$IFDEF SUPPORTS_EXTENDED}\r\n function LoadConst80(AValue: TFloat80): TExprNode; override;\r\n {$ENDIF SUPPORTS_EXTENDED}\r\n\r\n function CallFloatFunc(AFunc: TFloatFunc): TExprNode; override;\r\n function CallFloat32Func(AFunc: TFloat32Func): TExprNode; override;\r\n function CallFloat64Func(AFunc: TFloat64Func): TExprNode; override;\r\n {$IFDEF SUPPORTS_EXTENDED}\r\n function CallFloat80Func(AFunc: TFloat80Func): TExprNode; override;\r\n {$ENDIF SUPPORTS_EXTENDED}\r\n function CallUnaryFunc(AFunc: TUnaryFunc; X: TExprNode): TExprNode; override;\r\n function CallUnary32Func(AFunc: TUnary32Func; X: TExprNode): TExprNode; override;\r\n function CallUnary64Func(AFunc: TUnary64Func; X: TExprNode): TExprNode; override;\r\n {$IFDEF SUPPORTS_EXTENDED}\r\n function CallUnary80Func(AFunc: TUnary80Func; X: TExprNode): TExprNode; override;\r\n {$ENDIF SUPPORTS_EXTENDED}\r\n function CallBinaryFunc(AFunc: TBinaryFunc; X, Y: TExprNode): TExprNode; override;\r\n function CallBinary32Func(AFunc: TBinary32Func; X, Y: TExprNode): TExprNode; override;\r\n function CallBinary64Func(AFunc: TBinary64Func; X, Y: TExprNode): TExprNode; override;\r\n {$IFDEF SUPPORTS_EXTENDED}\r\n function CallBinary80Func(AFunc: TBinary80Func; X, Y: TExprNode): TExprNode; override;\r\n {$ENDIF SUPPORTS_EXTENDED}\r\n function CallTernaryFunc(AFunc: TTernaryFunc; X, Y, Z: TExprNode): TExprNode; override;\r\n function CallTernary32Func(AFunc: TTernary32Func; X, Y, Z: TExprNode): TExprNode; override;\r\n function CallTernary64Func(AFunc: TTernary64Func; X, Y, Z: TExprNode): TExprNode; override;\r\n {$IFDEF SUPPORTS_EXTENDED}\r\n function CallTernary80Func(AFunc: TTernary80Func; X, Y, Z: TExprNode): TExprNode; override;\r\n {$ENDIF SUPPORTS_EXTENDED}\r\n\r\n function Add(ALeft, ARight: TExprNode): TExprNode; override;\r\n function Subtract(ALeft, ARight: TExprNode): TExprNode; override;\r\n function Multiply(ALeft, ARight: TExprNode): TExprNode; override;\r\n function Divide(ALeft, ARight: TExprNode): TExprNode; override;\r\n function IntegerDivide(ALeft, ARight: TExprNode): TExprNode; override;\r\n function Modulo(ALeft, ARight: TExprNode): TExprNode; override;\r\n function Negate(AValue: TExprNode): TExprNode; override;\r\n\r\n function Compare(ALeft, ARight: TExprNode): TExprNode; override;\r\n function CompareEqual(ALeft, ARight: TExprNode): TExprNode; override;\r\n function CompareNotEqual(ALeft, ARight: TExprNode): TExprNode; override;\r\n function CompareLess(ALeft, ARight: TExprNode): TExprNode; override;\r\n function CompareLessEqual(ALeft, ARight: TExprNode): TExprNode; override;\r\n function CompareGreater(ALeft, ARight: TExprNode): TExprNode; override;\r\n function CompareGreaterEqual(ALeft, ARight: TExprNode): TExprNode; override;\r\n\r\n function LogicalAnd(ALeft, ARight: TExprNode): TExprNode; override;\r\n function LogicalOr(ALeft, ARight: TExprNode): TExprNode; override;\r\n function LogicalXor(ALeft, ARight: TExprNode): TExprNode; override;\r\n function LogicalNot(AValue: TExprNode): TExprNode; override;\r\n function BitwiseAnd(ALeft, ARight: TExprNode): TExprNode; override;\r\n function BitwiseOr(ALeft, ARight: TExprNode): TExprNode; override;\r\n function BitwiseXor(ALeft, ARight: TExprNode): TExprNode; override;\r\n function BitwiseNot(AValue: TExprNode): TExprNode; override;\r\n function ShiftLeft(ALeft, ARight: TExprNode): TExprNode; override;\r\n function ShiftRight(ALeft, ARight: TExprNode): TExprNode; override;\r\n end;\r\n\r\n { some concrete symbols }\r\n\r\n TExprConstSym = class(TExprSym)\r\n private\r\n FValue: TFloat;\r\n public\r\n constructor Create(const AIdent: string; AValue: TFloat);\r\n function Evaluate: TFloat; override;\r\n function Compile: TExprNode; override;\r\n end;\r\n\r\n TExprConst32Sym = class(TExprSym)\r\n private\r\n FValue: TFloat32;\r\n public\r\n constructor Create(const AIdent: string; AValue: TFloat32);\r\n function Evaluate: TFloat; override;\r\n function Compile: TExprNode; override;\r\n end;\r\n\r\n TExprConst64Sym = class(TExprSym)\r\n private\r\n FValue: TFloat64;\r\n public\r\n constructor Create(const AIdent: string; AValue: TFloat64);\r\n function Evaluate: TFloat; override;\r\n function Compile: TExprNode; override;\r\n end;\r\n\r\n {$IFDEF SUPPORTS_EXTENDED}\r\n TExprConst80Sym = class(TExprSym)\r\n private\r\n FValue: TFloat80;\r\n public\r\n constructor Create(const AIdent: string; AValue: TFloat80);\r\n function Evaluate: TFloat; override;\r\n function Compile: TExprNode; override;\r\n end;\r\n {$ENDIF SUPPORTS_EXTENDED}\r\n\r\n TExprVar32Sym = class(TExprSym)\r\n private\r\n FLoc: PFloat32;\r\n public\r\n constructor Create(const AIdent: string; ALoc: PFloat32);\r\n\r\n function Evaluate: TFloat; override;\r\n function Compile: TExprNode; override;\r\n end;\r\n\r\n TExprVar64Sym = class(TExprSym)\r\n private\r\n FLoc: PFloat64;\r\n public\r\n constructor Create(const AIdent: string; ALoc: PFloat64);\r\n\r\n function Evaluate: TFloat; override;\r\n function Compile: TExprNode; override;\r\n end;\r\n\r\n {$IFDEF SUPPORTS_EXTENDED}\r\n TExprVar80Sym = class(TExprSym)\r\n private\r\n FLoc: PFloat80;\r\n public\r\n constructor Create(const AIdent: string; ALoc: PFloat80);\r\n\r\n function Evaluate: TFloat; override;\r\n function Compile: TExprNode; override;\r\n end;\r\n {$ENDIF SUPPORTS_EXTENDED}\r\n\r\n TExprAbstractFuncSym = class(TExprSym)\r\n protected\r\n function EvalFirstArg: TFloat;\r\n function EvalNextArg: TFloat;\r\n function CompileFirstArg: TExprNode;\r\n function CompileNextArg: TExprNode;\r\n procedure EndArgs;\r\n end;\r\n\r\n TExprFuncSym = class(TExprAbstractFuncSym)\r\n private\r\n FFunc: TFloatFunc;\r\n public\r\n constructor Create(const AIdent: string; AFunc: TFloatFunc);\r\n function Evaluate: TFloat; override;\r\n function Compile: TExprNode; override;\r\n end;\r\n\r\n TExprFloat32FuncSym = class(TExprAbstractFuncSym)\r\n private\r\n FFunc: TFloat32Func;\r\n public\r\n constructor Create(const AIdent: string; AFunc: TFloat32Func);\r\n function Evaluate: TFloat; override;\r\n function Compile: TExprNode; override;\r\n end;\r\n\r\n TExprFloat64FuncSym = class(TExprAbstractFuncSym)\r\n private\r\n FFunc: TFloat64Func;\r\n public\r\n constructor Create(const AIdent: string; AFunc: TFloat64Func);\r\n function Evaluate: TFloat; override;\r\n function Compile: TExprNode; override;\r\n end;\r\n\r\n {$IFDEF SUPPORTS_EXTENDED}\r\n TExprFloat80FuncSym = class(TExprAbstractFuncSym)\r\n private\r\n FFunc: TFloat80Func;\r\n public\r\n constructor Create(const AIdent: string; AFunc: TFloat80Func);\r\n function Evaluate: TFloat; override;\r\n function Compile: TExprNode; override;\r\n end;\r\n {$ENDIF SUPPORTS_EXTENDED}\r\n\r\n TExprUnaryFuncSym = class(TExprAbstractFuncSym)\r\n private\r\n FFunc: TUnaryFunc;\r\n public\r\n constructor Create(const AIdent: string; AFunc: TUnaryFunc);\r\n function Evaluate: TFloat; override;\r\n function Compile: TExprNode; override;\r\n end;\r\n\r\n TExprUnary32FuncSym = class(TExprAbstractFuncSym)\r\n private\r\n FFunc: TUnary32Func;\r\n public\r\n constructor Create(const AIdent: string; AFunc: TUnary32Func);\r\n function Evaluate: TFloat; override;\r\n function Compile: TExprNode; override;\r\n end;\r\n\r\n TExprUnary64FuncSym = class(TExprAbstractFuncSym)\r\n private\r\n FFunc: TUnary64Func;\r\n public\r\n constructor Create(const AIdent: string; AFunc: TUnary64Func);\r\n function Evaluate: TFloat; override;\r\n function Compile: TExprNode; override;\r\n end;\r\n\r\n {$IFDEF SUPPORTS_EXTENDED}\r\n TExprUnary80FuncSym = class(TExprAbstractFuncSym)\r\n private\r\n FFunc: TUnary80Func;\r\n public\r\n constructor Create(const AIdent: string; AFunc: TUnary80Func);\r\n function Evaluate: TFloat; override;\r\n function Compile: TExprNode; override;\r\n end;\r\n {$ENDIF SUPPORTS_EXTENDED}\r\n\r\n TExprBinaryFuncSym = class(TExprAbstractFuncSym)\r\n private\r\n FFunc: TBinaryFunc;\r\n public\r\n constructor Create(const AIdent: string; AFunc: TBinaryFunc);\r\n function Evaluate: TFloat; override;\r\n function Compile: TExprNode; override;\r\n end;\r\n\r\n TExprBinary32FuncSym = class(TExprAbstractFuncSym)\r\n private\r\n FFunc: TBinary32Func;\r\n public\r\n constructor Create(const AIdent: string; AFunc: TBinary32Func);\r\n function Evaluate: TFloat; override;\r\n function Compile: TExprNode; override;\r\n end;\r\n\r\n TExprBinary64FuncSym = class(TExprAbstractFuncSym)\r\n private\r\n FFunc: TBinary64Func;\r\n public\r\n constructor Create(const AIdent: string; AFunc: TBinary64Func);\r\n function Evaluate: TFloat; override;\r\n function Compile: TExprNode; override;\r\n end;\r\n\r\n {$IFDEF SUPPORTS_EXTENDED}\r\n TExprBinary80FuncSym = class(TExprAbstractFuncSym)\r\n private\r\n FFunc: TBinary80Func;\r\n public\r\n constructor Create(const AIdent: string; AFunc: TBinary80Func);\r\n function Evaluate: TFloat; override;\r\n function Compile: TExprNode; override;\r\n end;\r\n {$ENDIF SUPPORTS_EXTENDED}\r\n\r\n TExprTernaryFuncSym = class(TExprAbstractFuncSym)\r\n private\r\n FFunc: TTernaryFunc;\r\n public\r\n constructor Create(const AIdent: string; AFunc: TTernaryFunc);\r\n function Evaluate: TFloat; override;\r\n function Compile: TExprNode; override;\r\n end;\r\n\r\n TExprTernary32FuncSym = class(TExprAbstractFuncSym)\r\n private\r\n FFunc: TTernary32Func;\r\n public\r\n constructor Create(const AIdent: string; AFunc: TTernary32Func);\r\n function Evaluate: TFloat; override;\r\n function Compile: TExprNode; override;\r\n end;\r\n\r\n TExprTernary64FuncSym = class(TExprAbstractFuncSym)\r\n private\r\n FFunc: TTernary64Func;\r\n public\r\n constructor Create(const AIdent: string; AFunc: TTernary64Func);\r\n function Evaluate: TFloat; override;\r\n function Compile: TExprNode; override;\r\n end;\r\n\r\n {$IFDEF SUPPORTS_EXTENDED}\r\n TExprTernary80FuncSym = class(TExprAbstractFuncSym)\r\n private\r\n FFunc: TTernary80Func;\r\n public\r\n constructor Create(const AIdent: string; AFunc: TTernary80Func);\r\n function Evaluate: TFloat; override;\r\n function Compile: TExprNode; override;\r\n end;\r\n {$ENDIF SUPPORTS_EXTENDED}\r\n\r\n TEasyEvaluator = class(TObject)\r\n private\r\n FOwnContext: TExprHashContext;\r\n FExtContextSet: TExprSetContext;\r\n FInternalContextSet: TExprSetContext;\r\n protected\r\n property InternalContextSet: TExprSetContext read FInternalContextSet;\r\n public\r\n constructor Create;\r\n destructor Destroy; override;\r\n\r\n procedure AddVar(const AName: string; var AVar: TFloat32); overload;\r\n procedure AddVar(const AName: string; var AVar: TFloat64); overload;\r\n {$IFDEF SUPPORTS_EXTENDED}\r\n procedure AddVar(const AName: string; var AVar: TFloat80); overload;\r\n {$ENDIF SUPPORTS_EXTENDED}\r\n\r\n procedure AddConst(const AName: string; AConst: TFloat32); overload;\r\n procedure AddConst(const AName: string; AConst: TFloat64); overload;\r\n {$IFDEF SUPPORTS_EXTENDED}\r\n procedure AddConst(const AName: string; AConst: TFloat80); overload;\r\n {$ENDIF SUPPORTS_EXTENDED}\r\n\r\n procedure AddFunc(const AName: string; AFunc: TFloat32Func); overload;\r\n procedure AddFunc(const AName: string; AFunc: TFloat64Func); overload;\r\n {$IFDEF SUPPORTS_EXTENDED}\r\n procedure AddFunc(const AName: string; AFunc: TFloat80Func); overload;\r\n {$ENDIF SUPPORTS_EXTENDED}\r\n procedure AddFunc(const AName: string; AFunc: TUnary32Func); overload;\r\n procedure AddFunc(const AName: string; AFunc: TUnary64Func); overload;\r\n {$IFDEF SUPPORTS_EXTENDED}\r\n procedure AddFunc(const AName: string; AFunc: TUnary80Func); overload;\r\n {$ENDIF SUPPORTS_EXTENDED}\r\n procedure AddFunc(const AName: string; AFunc: TBinary32Func); overload;\r\n procedure AddFunc(const AName: string; AFunc: TBinary64Func); overload;\r\n {$IFDEF SUPPORTS_EXTENDED}\r\n procedure AddFunc(const AName: string; AFunc: TBinary80Func); overload;\r\n {$ENDIF SUPPORTS_EXTENDED}\r\n procedure AddFunc(const AName: string; AFunc: TTernary32Func); overload;\r\n procedure AddFunc(const AName: string; AFunc: TTernary64Func); overload;\r\n {$IFDEF SUPPORTS_EXTENDED}\r\n procedure AddFunc(const AName: string; AFunc: TTernary80Func); overload;\r\n {$ENDIF SUPPORTS_EXTENDED}\r\n procedure Remove(const AName: string);\r\n\r\n procedure Clear; virtual;\r\n property ExtContextSet: TExprSetContext read FExtContextSet;\r\n end;\r\n\r\n TEvaluator = class(TEasyEvaluator)\r\n private\r\n FLexer: TExprSimpleLexer;\r\n FParser: TExprEvalParser;\r\n public\r\n constructor Create;\r\n destructor Destroy; override;\r\n function Evaluate(const AExpr: string): TFloat;\r\n end;\r\n\r\n TCompiledEvaluator = class(TEasyEvaluator)\r\n private\r\n FExpr: string;\r\n FVirtMach: TExprVirtMach;\r\n public\r\n constructor Create;\r\n destructor Destroy; override;\r\n procedure Compile(const AExpr: string);\r\n function Evaluate: TFloat;\r\n end;\r\n\r\n { TODO : change this definition to be just a normal function pointer, not\r\n a closure; will require a small executable memory allocater, and a\r\n couple of injected instructions. Similar concept to\r\n Forms.MakeObjectInstance.\r\n\r\n This will allow compiled expressions to be used as functions in\r\n contexts. Parameters won't be supported, though; I'll think about\r\n this. }\r\n\r\n TCompiledExpression = function: TFloat of object;\r\n\r\n TExpressionCompiler = class(TEasyEvaluator)\r\n private\r\n FExprHash: TStringHashMap;\r\n public\r\n constructor Create;\r\n destructor Destroy; override;\r\n function Compile(const AExpr: string): TCompiledExpression;\r\n procedure Remove(const AExpr: string);\r\n procedure Delete(ACompiledExpression: TCompiledExpression);\r\n procedure Clear; override;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jcl.svn.sourceforge.net/svnroot/jcl/tags/JCL-2.4-Build4571/jcl/source/common/JclExprEval.pas $';\r\n Revision: '$Revision: 3861 $';\r\n Date: '$Date: 2012-09-04 16:08:04 +0200 (mar. 04 sept. 2012) $';\r\n LogPath: 'JCL\\source\\common';\r\n Extra: '';\r\n Data: nil\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n {$IFDEF SUPPORTS_INLINE}\r\n {$IFDEF HAS_UNITSCOPE}\r\n Winapi.Windows, // inline of AnsiSameText\r\n System.Types, // inline TObjectList.Remove\r\n {$ELSE ~HAS_UNITSCOPE}\r\n Windows, // inline of AnsiSameText\r\n {$ENDIF ~HAS_UNITSCOPE}\r\n {$ENDIF SUPPORTS_INLINE}\r\n JclStrings;\r\n\r\n//=== { TExprHashContext } ===================================================\r\n\r\nconstructor TExprHashContext.Create(ACaseSensitive: Boolean; AHashSize: Integer);\r\nbegin\r\n inherited Create;\r\n if ACaseSensitive then\r\n FHashMap := TStringHashMap.Create(CaseSensitiveTraits, AHashSize)\r\n else\r\n FHashMap := TStringHashMap.Create(CaseInsensitiveTraits, AHashSize);\r\nend;\r\n\r\ndestructor TExprHashContext.Destroy;\r\nbegin\r\n FHashMap.Iterate(nil, Iterate_FreeObjects);\r\n FHashMap.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TExprHashContext.Add(ASymbol: TExprSym);\r\nbegin\r\n FHashMap.Add(ASymbol.Ident, ASymbol);\r\nend;\r\n\r\nprocedure TExprHashContext.Remove(const AName: string);\r\nbegin\r\n TObject(FHashMap.Remove(AName)).Free;\r\nend;\r\n\r\nfunction TExprHashContext.Find(const AName: string): TExprSym;\r\nbegin\r\n Result := nil;\r\n if not FHashMap.Find(AName, Result) then\r\n Result := nil;\r\nend;\r\n\r\n//=== { TExprSetContext } ====================================================\r\n\r\nconstructor TExprSetContext.Create(AOwnsContexts: Boolean);\r\nbegin\r\n inherited Create;\r\n FOwnsContexts := AOwnsContexts;\r\n FList := TList.Create;\r\nend;\r\n\r\ndestructor TExprSetContext.Destroy;\r\nbegin\r\n if FOwnsContexts then\r\n ClearObjectList(FList);\r\n FList.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TExprSetContext.Add(AContext: TExprContext);\r\nbegin\r\n FList.Add(AContext);\r\nend;\r\n\r\nprocedure TExprSetContext.Delete(AIndex: Integer);\r\nbegin\r\n if FOwnsContexts then\r\n TObject(FList[AIndex]).Free;\r\n FList.Delete(AIndex);\r\nend;\r\n\r\nfunction TExprSetContext.Extract(AContext: TExprContext): TExprContext;\r\nbegin\r\n Result := AContext;\r\n FList.Remove(AContext);\r\nend;\r\n\r\nfunction TExprSetContext.Find(const AName: string): TExprSym;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := nil;\r\n for I := Count - 1 downto 0 do\r\n begin\r\n Result := Contexts[I].Find(AName);\r\n if Result <> nil then\r\n Break;\r\n end;\r\nend;\r\n\r\nfunction TExprSetContext.GetContexts(AIndex: Integer): TExprContext;\r\nbegin\r\n Result := TExprContext(FList[AIndex]);\r\nend;\r\n\r\nfunction TExprSetContext.GetCount: Integer;\r\nbegin\r\n Result := FList.Count;\r\nend;\r\n\r\nprocedure TExprSetContext.Remove(AContext: TExprContext);\r\nbegin\r\n FList.Remove(AContext);\r\n if FOwnsContexts then\r\n AContext.Free;\r\nend;\r\n\r\n//=== { TExprSym } ===========================================================\r\n\r\nconstructor TExprSym.Create(const AIdent: string);\r\nbegin\r\n inherited Create;\r\n FIdent := AIdent;\r\nend;\r\n\r\n//=== { TExprLexer } =========================================================\r\n\r\nconstructor TExprLexer.Create;\r\nbegin\r\n inherited Create;\r\n Reset;\r\nend;\r\n\r\nprocedure TExprLexer.Reset;\r\nbegin\r\n NextTok;\r\nend;\r\n\r\n//=== { TExprCompileParser } =================================================\r\n\r\nconstructor TExprCompileParser.Create(ALexer: TExprLexer; ANodeFactory: TExprNodeFactory);\r\nbegin\r\n inherited Create;\r\n FLexer := ALexer;\r\n FNodeFactory := ANodeFactory;\r\nend;\r\n\r\nfunction TExprCompileParser.Compile: TExprNode;\r\nbegin\r\n Result := CompileExprLevel0(False);\r\nend;\r\n\r\nfunction TExprCompileParser.CompileExprLevel0(ASkip: Boolean): TExprNode;\r\nbegin\r\n Result := CompileExprLevel1(ASkip);\r\n\r\n { Utilize some of these compound instructions to test DAG optimization\r\n techniques later on.\r\n\r\n Playing a few games after much hard work, too.\r\n Functional programming is fun! :-> BJK }\r\n while True do\r\n case Lexer.CurrTok of\r\n etEqualTo: // =\r\n Result := NodeFactory.CompareEqual(Result, CompileExprLevel1(True));\r\n etNotEqual: // <>\r\n Result := NodeFactory.CompareNotEqual(Result, CompileExprLevel1(True));\r\n etLessThan: // <\r\n Result := NodeFactory.CompareLess(Result, CompileExprLevel1(True));\r\n etLessEqual: // <=\r\n Result := NodeFactory.CompareLessEqual(Result, CompileExprLevel1(True));\r\n etGreaterThan: // >\r\n Result := NodeFactory.CompareGreater(Result, CompileExprLevel1(True));\r\n etGreaterEqual: // >=\r\n Result := NodeFactory.CompareGreaterEqual(Result, CompileExprLevel1(True));\r\n etIdentifier: // cmp\r\n if AnsiSameText(Lexer.TokenAsString, 'cmp') then\r\n Result := NodeFactory.Compare(Result, CompileExprLevel1(True))\r\n else\r\n Break;\r\n else\r\n Break;\r\n end;\r\nend;\r\n\r\nfunction TExprCompileParser.CompileExprLevel1(ASkip: Boolean): TExprNode;\r\nbegin\r\n Result := CompileExprLevel2(ASkip);\r\n\r\n while True do\r\n case Lexer.CurrTok of\r\n etPlus:\r\n Result := NodeFactory.Add(Result, CompileExprLevel2(True));\r\n etMinus:\r\n Result := NodeFactory.Subtract(Result, CompileExprLevel2(True));\r\n etIdentifier: // or, xor, bor, bxor\r\n if AnsiSameText(Lexer.TokenAsString, 'or') then\r\n Result := NodeFactory.LogicalOr(Result, CompileExprLevel2(True))\r\n else\r\n if AnsiSameText(Lexer.TokenAsString, 'xor') then\r\n Result := NodeFactory.LogicalXor(Result, CompileExprLevel2(True))\r\n else\r\n if AnsiSameText(Lexer.TokenAsString, 'bor') then\r\n Result := NodeFactory.BitwiseOr(Result, CompileExprLevel2(True))\r\n else\r\n if AnsiSameText(Lexer.TokenAsString, 'bxor') then\r\n Result := NodeFactory.BitwiseXor(Result, CompileExprLevel2(True))\r\n else\r\n Break;\r\n else\r\n Break;\r\n end;\r\nend;\r\n\r\nfunction TExprCompileParser.CompileExprLevel2(ASkip: Boolean): TExprNode;\r\nbegin\r\n Result := CompileExprLevel3(ASkip);\r\n\r\n while True do\r\n case Lexer.CurrTok of\r\n etAsterisk:\r\n Result := NodeFactory.Multiply(Result, CompileExprLevel3(True));\r\n etForwardSlash:\r\n Result := NodeFactory.Divide(Result, CompileExprLevel3(True));\r\n etIdentifier: // div, mod, and, shl, shr, band\r\n if AnsiSameText(Lexer.TokenAsString, 'div') then\r\n Result := NodeFactory.IntegerDivide(Result, CompileExprLevel3(True))\r\n else\r\n if AnsiSameText(Lexer.TokenAsString, 'mod') then\r\n Result := NodeFactory.Modulo(Result, CompileExprLevel3(True))\r\n else\r\n if AnsiSameText(Lexer.TokenAsString, 'and') then\r\n Result := NodeFactory.LogicalAnd(Result, CompileExprLevel3(True))\r\n else\r\n if AnsiSameText(Lexer.TokenAsString, 'shl') then\r\n Result := NodeFactory.ShiftLeft(Result, CompileExprLevel3(True))\r\n else\r\n if AnsiSameText(Lexer.TokenAsString, 'shr') then\r\n Result := NodeFactory.ShiftRight(Result, CompileExprLevel3(True))\r\n else\r\n if AnsiSameText(Lexer.TokenAsString, 'band') then\r\n Result := NodeFactory.BitwiseAnd(Result, CompileExprLevel3(True))\r\n else\r\n Break;\r\n else\r\n Break;\r\n end;\r\nend;\r\n\r\nfunction TExprCompileParser.CompileExprLevel3(ASkip: Boolean): TExprNode;\r\nbegin\r\n if ASkip then\r\n Lexer.NextTok;\r\n\r\n case Lexer.CurrTok of\r\n etPlus:\r\n Result := CompileExprLevel3(True);\r\n etMinus:\r\n Result := NodeFactory.Negate(CompileExprLevel3(True));\r\n etIdentifier: // not, bnot\r\n if AnsiSameText(Lexer.TokenAsString, 'not') then\r\n Result := NodeFactory.LogicalNot(CompileExprLevel3(True))\r\n else\r\n if AnsiSameText(Lexer.TokenAsString, 'bnot') then\r\n Result := NodeFactory.BitwiseNot(CompileExprLevel3(True))\r\n else\r\n Result := CompileFactor;\r\n else\r\n Result := CompileFactor;\r\n end;\r\nend;\r\n\r\nfunction TExprCompileParser.CompileFactor: TExprNode;\r\nbegin\r\n case Lexer.CurrTok of\r\n etIdentifier:\r\n Result := CompileIdentFactor;\r\n etLParen:\r\n begin\r\n Result := CompileExprLevel0(True);\r\n if Lexer.CurrTok <> etRParen then\r\n raise EJclExprEvalError.CreateRes(@RsExprEvalRParenExpected);\r\n Lexer.NextTok;\r\n end;\r\n etNumber:\r\n begin\r\n Result := NodeFactory.LoadConst(Lexer.TokenAsNumber);\r\n Lexer.NextTok;\r\n end;\r\n else\r\n raise EJclExprEvalError.CreateRes(@RsExprEvalFactorExpected);\r\n end;\r\nend;\r\n\r\nfunction TExprCompileParser.CompileIdentFactor: TExprNode;\r\nvar\r\n Sym: TExprSym;\r\n oldCompileParser: TExprCompileParser;\r\n oldLexer: TExprLexer;\r\n oldNodeFactory: TExprNodeFactory;\r\nbegin\r\n { find symbol }\r\n if FContext = nil then\r\n raise EJclExprEvalError.CreateResFmt(@RsExprEvalUnknownSymbol,\r\n [Lexer.TokenAsString]);\r\n Sym := FContext.Find(Lexer.TokenAsString);\r\n if Sym = nil then\r\n raise EJclExprEvalError.CreateResFmt(@RsExprEvalUnknownSymbol,\r\n [Lexer.TokenAsString]);\r\n\r\n Lexer.NextTok;\r\n\r\n { set symbol properties }\r\n oldCompileParser := Sym.CompileParser;\r\n oldLexer := Sym.Lexer;\r\n oldNodeFactory := Sym.NodeFactory;\r\n Sym.FLexer := Lexer;\r\n Sym.FCompileParser := Self;\r\n Sym.FNodeFactory := NodeFactory;\r\n try\r\n { compile symbol }\r\n Result := Sym.Compile;\r\n finally\r\n Sym.FLexer := oldLexer;\r\n Sym.FCompileParser := oldCompileParser;\r\n Sym.FNodeFactory := oldNodeFactory;\r\n end;\r\nend;\r\n\r\n//=== { TExprEvalParser } ====================================================\r\n\r\nconstructor TExprEvalParser.Create(ALexer: TExprLexer);\r\nbegin\r\n inherited Create;\r\n FLexer := ALexer;\r\nend;\r\n\r\nfunction TExprEvalParser.Evaluate: TFloat;\r\nbegin\r\n Result := EvalExprLevel0(False);\r\n\r\n if (Lexer.CurrTok <> etEof) then\r\n begin\r\n raise EJclExprEvalError.CreateResFmt(@RsExprEvalUnknownSymbol,\r\n [Lexer.TokenAsString]);\r\n end;\r\nend;\r\n\r\nfunction TExprEvalParser.EvalExprLevel0(ASkip: Boolean): TFloat;\r\nvar\r\n RightValue: TFloat;\r\nbegin\r\n Result := EvalExprLevel1(ASkip);\r\n\r\n while True do\r\n case Lexer.CurrTok of\r\n etEqualTo: // =\r\n if Result = EvalExprLevel1(True) then\r\n Result := 1.0\r\n else\r\n Result := 0.0;\r\n etNotEqual: // <>\r\n if Result <> EvalExprLevel1(True) then\r\n Result := 1.0\r\n else\r\n Result := 0.0;\r\n etLessThan: // <\r\n if Result < EvalExprLevel1(True) then\r\n Result := 1.0\r\n else\r\n Result := 0.0;\r\n etLessEqual: // <=\r\n if Result <= EvalExprLevel1(True) then\r\n Result := 1.0\r\n else\r\n Result := 0.0;\r\n etGreaterThan: // >\r\n if Result > EvalExprLevel1(True) then\r\n Result := 1.0\r\n else\r\n Result := 0.0;\r\n etGreaterEqual: // >=\r\n if Result >= EvalExprLevel1(True) then\r\n Result := 1.0\r\n else\r\n Result := 0.0;\r\n etIdentifier: // cmp\r\n if AnsiSameText(Lexer.TokenAsString, 'cmp') then\r\n begin\r\n RightValue := EvalExprLevel1(True);\r\n if Result > RightValue then\r\n Result := 1.0\r\n else\r\n if Result = RightValue then\r\n Result := 0.0\r\n else\r\n Result := -1.0;\r\n end\r\n else\r\n Break;\r\n else\r\n Break;\r\n end;\r\nend;\r\n\r\nfunction TExprEvalParser.EvalExprLevel1(ASkip: Boolean): TFloat;\r\nbegin\r\n Result := EvalExprLevel2(ASkip);\r\n\r\n while True do\r\n case Lexer.CurrTok of\r\n etPlus:\r\n Result := Result + EvalExprLevel2(True);\r\n etMinus:\r\n Result := Result - EvalExprLevel2(True);\r\n etIdentifier: // or, xor, bor, bxor\r\n if AnsiSameText(Lexer.TokenAsString, 'or') then\r\n begin\r\n if (EvalExprLevel2(True) <> 0) or (Result <> 0) then // prevent boolean optimisations, EvalTerm must be called\r\n Result := 1.0\r\n else\r\n Result := 0.0;\r\n end\r\n else\r\n if AnsiSameText(Lexer.TokenAsString, 'xor') then\r\n begin\r\n if (Result <> 0) xor (EvalExprLevel2(True) <> 0) then\r\n Result := 1.0\r\n else\r\n result := 0.0;\r\n end\r\n else\r\n if AnsiSameText(Lexer.TokenAsString, 'bor') then\r\n Result := Round(Result) or Round(EvalExprLevel2(True))\r\n else\r\n if AnsiSameText(Lexer.TokenAsString, 'bxor') then\r\n Result := Round(Result) xor Round(EvalExprLevel2(True))\r\n else\r\n Break;\r\n else\r\n Break;\r\n end;\r\nend;\r\n\r\nfunction TExprEvalParser.EvalExprLevel2(ASkip: Boolean): TFloat;\r\nbegin\r\n Result := EvalExprLevel3(ASkip);\r\n\r\n while True do\r\n case Lexer.CurrTok of\r\n etAsterisk:\r\n Result := Result * EvalExprLevel3(True);\r\n etForwardSlash:\r\n Result := Result / EvalExprLevel3(True);\r\n etIdentifier: // div, mod, and, shl, shr, band\r\n if AnsiSameText(Lexer.TokenAsString, 'div') then\r\n Result := Round(Result) div Round(EvalExprLevel3(True))\r\n else\r\n if AnsiSameText(Lexer.TokenAsString, 'mod') then\r\n Result := Round(Result) mod Round(EvalExprLevel3(True))\r\n else\r\n if AnsiSameText(Lexer.TokenAsString, 'and') then\r\n begin\r\n if (EvalExprLevel3(True) <> 0) and (Result <> 0) then // prevent boolean optimisations, EvalTerm must be called\r\n Result := 1.0\r\n else\r\n Result := 0.0;\r\n end\r\n else\r\n if AnsiSameText(Lexer.TokenAsString, 'shl') then\r\n Result := Round(Result) shl Round(EvalExprLevel3(True))\r\n else\r\n if AnsiSameText(Lexer.TokenAsString, 'shr') then\r\n Result := Round(Result) shr Round(EvalExprLevel3(True))\r\n else\r\n if AnsiSameText(Lexer.TokenAsString, 'band') then\r\n Result := Round(Result) and Round(EvalExprLevel3(True))\r\n else\r\n Break;\r\n else\r\n Break;\r\n end;\r\nend;\r\n\r\nfunction TExprEvalParser.EvalExprLevel3(ASkip: Boolean): TFloat;\r\nbegin\r\n if ASkip then\r\n Lexer.NextTok;\r\n\r\n case Lexer.CurrTok of\r\n etPlus:\r\n Result := EvalExprLevel3(True);\r\n etMinus:\r\n Result := -EvalExprLevel3(True);\r\n etIdentifier: // not, bnot\r\n if AnsiSameText(Lexer.TokenAsString, 'not') then\r\n begin\r\n if EvalExprLevel3(True) <> 0.0 then\r\n Result := 0.0\r\n else\r\n Result := 1.0;\r\n end\r\n else\r\n if AnsiSameText(Lexer.TokenAsString, 'bnot') then\r\n Result := not Round(EvalExprLevel3(True))\r\n else\r\n Result := EvalFactor;\r\n else\r\n Result := EvalFactor;\r\n end;\r\nend;\r\n\r\nfunction TExprEvalParser.EvalFactor: TFloat;\r\nbegin\r\n case Lexer.CurrTok of\r\n etIdentifier:\r\n Result := EvalIdentFactor;\r\n etLParen:\r\n begin\r\n Result := EvalExprLevel0(True);\r\n if Lexer.CurrTok <> etRParen then\r\n raise EJclExprEvalError.CreateRes(@RsExprEvalRParenExpected);\r\n Lexer.NextTok;\r\n end;\r\n etNumber:\r\n begin\r\n Result := Lexer.TokenAsNumber;\r\n Lexer.NextTok;\r\n end;\r\n else\r\n raise EJclExprEvalError.CreateRes(@RsExprEvalFactorExpected);\r\n end;\r\nend;\r\n\r\nfunction TExprEvalParser.EvalIdentFactor: TFloat;\r\nvar\r\n Sym: TExprSym;\r\n oldEvalParser: TExprEvalParser;\r\n oldLexer: TExprLexer;\r\nbegin\r\n { find symbol }\r\n if Context = nil then\r\n raise EJclExprEvalError.CreateResFmt(@RsExprEvalUnknownSymbol,\r\n [Lexer.TokenAsString]);\r\n Sym := FContext.Find(Lexer.TokenAsString);\r\n if Sym = nil then\r\n raise EJclExprEvalError.CreateResFmt(@RsExprEvalUnknownSymbol,\r\n [Lexer.TokenAsString]);\r\n\r\n Lexer.NextTok;\r\n\r\n { set symbol properties }\r\n oldEvalParser := Sym.FEvalParser;\r\n oldLexer := Sym.Lexer;\r\n Sym.FLexer := Lexer;\r\n Sym.FEvalParser := Self;\r\n try\r\n { evaluate symbol }\r\n Result := Sym.Evaluate;\r\n finally\r\n Sym.FLexer := oldLexer;\r\n Sym.FEvalParser := oldEvalParser;\r\n end;\r\nend;\r\n\r\n//=== { TExprSimpleLexer } ===================================================\r\n\r\nconstructor TExprSimpleLexer.Create(const ABuf: string);\r\nbegin\r\n FBuf := ABuf;\r\n inherited Create;\r\nend;\r\n\r\nprocedure TExprSimpleLexer.NextTok;\r\nconst\r\n CharToTokenMap: array [AnsiChar] of TExprToken =\r\n (\r\n {#0..#31}\r\n etInvalid, etInvalid, etInvalid, etInvalid, etInvalid, etInvalid, etInvalid, etInvalid,\r\n etInvalid, etInvalid, etInvalid, etInvalid, etInvalid, etInvalid, etInvalid, etInvalid,\r\n etInvalid, etInvalid, etInvalid, etInvalid, etInvalid, etInvalid, etInvalid, etInvalid,\r\n etInvalid, etInvalid, etInvalid, etInvalid, etInvalid, etInvalid, etInvalid, etInvalid,\r\n {#32} etInvalid,\r\n {#33} etBang, {#34} etDoubleQuote, {#35} etHash, {#36} etDollar,\r\n {#37} etPercent, {#38} etAmpersand, {#39} etSingleQuote, {#40} etLParen,\r\n {#41} etRParen, {#42} etAsterisk, {#43} etPlus, {#44} etComma,\r\n {#45} etMinus, {#46} etDot, {#47} etForwardSlash,\r\n // 48..57 - numbers...\r\n etInvalid, etInvalid, etInvalid, etInvalid,\r\n etInvalid, etInvalid, etInvalid, etInvalid,\r\n etInvalid, etInvalid,\r\n {#58} etColon, {#59} etSemiColon, {#60} etLessThan, {#61} etEqualTo,\r\n {#62} etGreaterThan, {#63} etQuestion, {#64} etAt,\r\n // 65..90 - capital letters...\r\n etInvalid, etInvalid, etInvalid, etInvalid,\r\n etInvalid, etInvalid, etInvalid, etInvalid,\r\n etInvalid, etInvalid, etInvalid, etInvalid,\r\n etInvalid, etInvalid, etInvalid, etInvalid,\r\n etInvalid, etInvalid, etInvalid, etInvalid,\r\n etInvalid, etInvalid, etInvalid, etInvalid,\r\n etInvalid, etInvalid,\r\n {#91} etLBracket, {#92} etBackSlash, {#93} etRBracket, {#94} etArrow,\r\n etInvalid, // 95 - underscore\r\n {#96} etBackTick,\r\n // 97..122 - small letters...\r\n etInvalid, etInvalid, etInvalid, etInvalid,\r\n etInvalid, etInvalid, etInvalid, etInvalid,\r\n etInvalid, etInvalid, etInvalid, etInvalid,\r\n etInvalid, etInvalid, etInvalid, etInvalid,\r\n etInvalid, etInvalid, etInvalid, etInvalid,\r\n etInvalid, etInvalid, etInvalid, etInvalid,\r\n etInvalid, etInvalid,\r\n {#123} etLBrace,\r\n {#124} etPipe, {#125} etRBrace, {#126} etTilde, {#127} et127,\r\n {#128} etEuro, {#129} et129, {#130} et130, {#131} et131,\r\n {#132} et132, {#133} et133, {#134} et134, {#135} et135,\r\n {#136} et136, {#137} et137, {#138} et138, {#139} et139,\r\n {#140} et140, {#141} et141, {#142} et142, {#143} et143,\r\n {#144} et144, {#145} et145, {#146} et146, {#147} et147,\r\n {#148} et148, {#149} et149, {#150} et150, {#151} et151,\r\n {#152} et152, {#153} et153, {#154} et154, {#155} et155,\r\n {#156} et156, {#157} et157, {#158} et158, {#159} et159,\r\n {#160} et160, {#161} et161, {#162} et162, {#163} et163,\r\n {#164} et164, {#165} et165, {#166} et166, {#167} et167,\r\n {#168} et168, {#169} et169, {#170} et170, {#171} et171,\r\n {#172} et172, {#173} et173, {#174} et174, {#175} et175,\r\n {#176} et176, {#177} et177, {#178} et178, {#179} et179,\r\n {#180} et180, {#181} et181, {#182} et182, {#183} et183,\r\n {#184} et184, {#185} et185, {#186} et186, {#187} et187,\r\n {#188} et188, {#189} et189, {#190} et190, {#191} et191,\r\n {#192} et192, {#193} et193, {#194} et194, {#195} et195,\r\n {#196} et196, {#197} et197, {#198} et198, {#199} et199,\r\n {#200} et200, {#201} et201, {#202} et202, {#203} et203,\r\n {#204} et204, {#205} et205, {#206} et206, {#207} et207,\r\n {#208} et208, {#209} et209, {#210} et210, {#211} et211,\r\n {#212} et212, {#213} et213, {#214} et214, {#215} et215,\r\n {#216} et216, {#217} et217, {#218} et218, {#219} et219,\r\n {#220} et220, {#221} et221, {#222} et222, {#223} et223,\r\n {#224} et224, {#225} et225, {#226} et226, {#227} et227,\r\n {#228} et228, {#229} et229, {#230} et230, {#231} et231,\r\n {#232} et232, {#233} et233, {#234} et234, {#235} et235,\r\n {#236} et236, {#237} et237, {#238} et238, {#239} et239,\r\n {#240} et240, {#241} et241, {#242} et242, {#243} et243,\r\n {#244} et244, {#245} et245, {#246} et246, {#247} et247,\r\n {#248} et248, {#249} et249, {#250} et250, {#251} et251,\r\n {#252} et252, {#253} et253, {#254} et254, {#255} et255\r\n );\r\nvar\r\n { register variable optimization }\r\n cp: PChar;\r\n start: PChar;\r\nbegin\r\n cp := FCurrPos;\r\n\r\n { skip whitespace }\r\n while CharIsWhiteSpace(cp^) do\r\n Inc(cp);\r\n\r\n { determine token type }\r\n case cp^ of\r\n #0:\r\n FCurrTok := etEof;\r\n 'a'..'z', 'A'..'Z', '_':\r\n begin\r\n start := cp;\r\n Inc(cp);\r\n while CharIsValidIdentifierLetter(cp^) do\r\n Inc(cp);\r\n SetString(FTokenAsString, start, cp - start);\r\n FCurrTok := etIdentifier;\r\n end;\r\n '0'..'9':\r\n begin\r\n start := cp;\r\n\r\n { read in integer part of mantissa }\r\n while CharIsDigit(cp^) do\r\n Inc(cp);\r\n\r\n { check for and read in fraction part of mantissa }\r\n if (cp^ = '.') or (cp^ = JclFormatSettings.DecimalSeparator) then\r\n begin\r\n Inc(cp);\r\n while CharIsDigit(cp^) do\r\n Inc(cp);\r\n end;\r\n\r\n { check for and read in exponent }\r\n if (cp^ = 'e') or (cp^ = 'E') then\r\n begin\r\n Inc(cp);\r\n if (cp^ = '+') or (cp^ = '-') then\r\n Inc(cp);\r\n while CharIsDigit(cp^) do\r\n Inc(cp);\r\n end;\r\n\r\n { evaluate number }\r\n SetString(FTokenAsString, start, cp - start);\r\n FTokenAsNumber := StrToFloat(FTokenAsString);\r\n\r\n FCurrTok := etNumber;\r\n end;\r\n '<':\r\n begin\r\n Inc(cp);\r\n case cp^ of\r\n '=':\r\n begin\r\n FCurrTok := etLessEqual;\r\n Inc(cp);\r\n end;\r\n '>':\r\n begin\r\n FCurrTok := etNotEqual;\r\n Inc(cp);\r\n end;\r\n else\r\n FCurrTok := etLessThan;\r\n end;\r\n end;\r\n '>':\r\n begin\r\n Inc(cp);\r\n if cp^ = '=' then\r\n begin\r\n FCurrTok := etGreaterEqual;\r\n Inc(cp);\r\n end\r\n else\r\n FCurrTok := etGreaterThan;\r\n end;\r\n else\r\n { map character to token }\r\n FCurrTok := CharToTokenMap[AnsiChar(cp^)];\r\n Inc(cp);\r\n end;\r\n\r\n FCurrPos := cp;\r\nend;\r\n\r\nprocedure TExprSimpleLexer.Reset;\r\nbegin\r\n FCurrPos := PChar(FBuf);\r\n inherited Reset;\r\nend;\r\n\r\nprocedure TExprSimpleLexer.SetBuf(const ABuf: string);\r\nbegin\r\n FBuf := ABuf;\r\n Reset;\r\nend;\r\n\r\n//=== { TExprNode } ==========================================================\r\n\r\nconstructor TExprNode.Create(const ADepList: array of TExprNode);\r\nvar\r\n I: Integer;\r\nbegin\r\n inherited Create;\r\n FDepList := TList.Create;\r\n for I := Low(ADepList) to High(ADepList) do\r\n AddDep(ADepList[I]);\r\nend;\r\n\r\ndestructor TExprNode.Destroy;\r\nbegin\r\n FDepList.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TExprNode.AddDep(ADep: TExprNode);\r\nbegin\r\n FDepList.Add(ADep);\r\nend;\r\n\r\nfunction TExprNode.GetDepCount: Integer;\r\nbegin\r\n Result := FDepList.Count;\r\nend;\r\n\r\nfunction TExprNode.GetDeps(AIndex: Integer): TExprNode;\r\nbegin\r\n Result := TExprNode(FDepList[AIndex]);\r\nend;\r\n\r\n//=== { TExprNodeFactory } ===================================================\r\n\r\nfunction TExprNodeFactory.LoadVar(ALoc: PFloat32): TExprNode;\r\nbegin\r\n Result := LoadVar32(ALoc);\r\nend;\r\n\r\nfunction TExprNodeFactory.LoadVar(ALoc: PFloat64): TExprNode;\r\nbegin\r\n Result := LoadVar64(ALoc);\r\nend;\r\n\r\n{$IFDEF SUPPORTS_EXTENDED}\r\nfunction TExprNodeFactory.LoadVar(ALoc: PFloat80): TExprNode;\r\nbegin\r\n Result := LoadVar80(ALoc);\r\nend;\r\n{$ENDIF SUPPORTS_EXTENDED}\r\n\r\nfunction TExprNodeFactory.LoadConst(AValue: TFloat32): TExprNode;\r\nbegin\r\n Result := LoadConst32(AValue);\r\nend;\r\n\r\nfunction TExprNodeFactory.LoadConst(AValue: TFloat64): TExprNode;\r\nbegin\r\n Result := LoadConst64(AValue);\r\nend;\r\n\r\n{$IFDEF SUPPORTS_EXTENDED}\r\nfunction TExprNodeFactory.LoadConst(AValue: TFloat80): TExprNode;\r\nbegin\r\n Result := LoadConst80(AValue);\r\nend;\r\n{$ENDIF SUPPORTS_EXTENDED}\r\n\r\n//=== { TEvaluator } =========================================================\r\n\r\nconstructor TEvaluator.Create;\r\nbegin\r\n inherited Create;\r\n\r\n FLexer := TExprSimpleLexer.Create('');\r\n FParser := TExprEvalParser.Create(FLexer);\r\n\r\n FParser.Context := InternalContextSet;\r\nend;\r\n\r\ndestructor TEvaluator.Destroy;\r\nbegin\r\n FParser.Free;\r\n FLexer.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TEvaluator.Evaluate(const AExpr: string): TFloat;\r\nbegin\r\n FLexer.Buf := AExpr;\r\n Result := FParser.Evaluate;\r\nend;\r\n\r\n//=== { TExprVirtMachOp } ====================================================\r\n\r\nfunction TExprVirtMachOp.GetOutputLoc: PFloat;\r\nbegin\r\n Result := @FOutput;\r\nend;\r\n\r\n//=== Virtual machine operators follow =======================================\r\n\r\ntype\r\n { abstract base for var readers }\r\n TExprVarVmOp = class(TExprVirtMachOp)\r\n private\r\n FVarLoc: Pointer;\r\n public\r\n constructor Create(AVarLoc: Pointer);\r\n end;\r\n\r\n { the var readers }\r\n\r\n TExprVar32VmOp = class(TExprVarVmOp)\r\n public\r\n procedure Execute; override;\r\n end;\r\n\r\n TExprVar64VmOp = class(TExprVarVmOp)\r\n public\r\n procedure Execute; override;\r\n end;\r\n\r\n {$IFDEF SUPPORTS_EXTENDED}\r\n TExprVar80VmOp = class(TExprVarVmOp)\r\n public\r\n procedure Execute; override;\r\n end;\r\n {$ENDIF SUPPORTS_EXTENDED}\r\n\r\n { the const holder }\r\n TExprConstVmOp = class(TExprVirtMachOp)\r\n public\r\n constructor Create(AValue: TFloat);\r\n { null function }\r\n procedure Execute; override;\r\n end;\r\n\r\n { abstract unary operator }\r\n TExprUnaryVmOp = class(TExprVirtMachOp)\r\n protected\r\n FInput: PFloat;\r\n public\r\n constructor Create(AInput: PFloat);\r\n property Input: PFloat read FInput write FInput;\r\n end;\r\n\r\n TExprUnaryVmOpClass = class of TExprUnaryVmOp;\r\n\r\n { abstract binary operator }\r\n TExprBinaryVmOp = class(TExprVirtMachOp)\r\n protected\r\n FLeft: PFloat;\r\n FRight: PFloat;\r\n public\r\n constructor Create(ALeft, ARight: PFloat);\r\n property Left: PFloat read FLeft write FLeft;\r\n property Right: PFloat read FRight write FRight;\r\n end;\r\n\r\n TExprBinaryVmOpClass = class of TExprBinaryVmOp;\r\n\r\n { the 4 basic binary operators }\r\n\r\n TExprAddVmOp = class(TExprBinaryVmOp)\r\n public\r\n procedure Execute; override;\r\n end;\r\n\r\n TExprSubtractVmOp = class(TExprBinaryVmOp)\r\n public\r\n procedure Execute; override;\r\n end;\r\n\r\n TExprMultiplyVmOp = class(TExprBinaryVmOp)\r\n public\r\n procedure Execute; override;\r\n end;\r\n\r\n TExprDivideVmOp = class(TExprBinaryVmOp)\r\n public\r\n procedure Execute; override;\r\n end;\r\n\r\n TExprCompareVmOp = class(TExprBinaryVmOp)\r\n public\r\n procedure Execute; override;\r\n end;\r\n\r\n TExprGreaterVmOp = class(TExprBinaryVmOp)\r\n public\r\n procedure Execute; override;\r\n end;\r\n\r\n TExprGreaterEqualVmOp = class(TExprBinaryVmOp)\r\n public\r\n procedure Execute; override;\r\n end;\r\n\r\n TExprLessVmOp = class(TExprBinaryVmOp)\r\n public\r\n procedure Execute; override;\r\n end;\r\n\r\n TExprLessEqualVmOp = class(TExprBinaryVmOp)\r\n public\r\n procedure Execute; override;\r\n end;\r\n\r\n TExprEqualVmOp = class(TExprBinaryVmOp)\r\n public\r\n procedure Execute; override;\r\n end;\r\n\r\n TExprNotEqualVmOp = class(TExprBinaryVmOp)\r\n public\r\n procedure Execute; override;\r\n end;\r\n\r\n TExprIntegerDivideVmOp = class(TExprBinaryVmOp)\r\n public\r\n procedure Execute; override;\r\n end;\r\n\r\n TExprModuloVmOp = class(TExprBinaryVmOp)\r\n public\r\n procedure Execute; override;\r\n end;\r\n\r\n TExprShiftLeftVmOp = class(TExprBinaryVmOp)\r\n public\r\n procedure Execute; override;\r\n end;\r\n\r\n TExprShiftRightVmOp = class(TExprBinaryVmOp)\r\n public\r\n procedure Execute; override;\r\n end;\r\n\r\n TExprBitwiseAndVmOp = class(TExprBinaryVmOp)\r\n public\r\n procedure Execute; override;\r\n end;\r\n\r\n TExprBitwiseOrVmOp = class(TExprBinaryVmOp)\r\n public\r\n procedure Execute; override;\r\n end;\r\n\r\n TExprBitwiseXorVmOp = class(TExprBinaryVmOp)\r\n public\r\n procedure Execute; override;\r\n end;\r\n\r\n TExprLogicalAndVmOp = class(TExprBinaryVmOp)\r\n public\r\n procedure Execute; override;\r\n end;\r\n\r\n TExprLogicalOrVmOp = class(TExprBinaryVmOp)\r\n public\r\n procedure Execute; override;\r\n end;\r\n\r\n TExprLogicalXorVmOp = class(TExprBinaryVmOp)\r\n public\r\n procedure Execute; override;\r\n end;\r\n\r\n { the unary operators }\r\n\r\n TExprNegateVmOp = class(TExprUnaryVmOp)\r\n public\r\n procedure Execute; override;\r\n end;\r\n\r\n TExprLogicalNotVmOp = class(TExprUnaryVmOp)\r\n public\r\n procedure Execute; override;\r\n end;\r\n\r\n TExprBitwiseNotVmOp = class(TExprUnaryVmOp)\r\n public\r\n procedure Execute; override;\r\n end;\r\n\r\n { function calls }\r\n\r\n TExprCallFloatVmOp = class(TExprVirtMachOp)\r\n private\r\n FFunc: TFloatFunc;\r\n public\r\n constructor Create(AFunc: TFloatFunc);\r\n procedure Execute; override;\r\n end;\r\n\r\n TExprCallFloat32VmOp = class(TExprVirtMachOp)\r\n private\r\n FFunc: TFloat32Func;\r\n public\r\n constructor Create(AFunc: TFloat32Func);\r\n procedure Execute; override;\r\n end;\r\n\r\n TExprCallFloat64VmOp = class(TExprVirtMachOp)\r\n private\r\n FFunc: TFloat64Func;\r\n public\r\n constructor Create(AFunc: TFloat64Func);\r\n procedure Execute; override;\r\n end;\r\n\r\n {$IFDEF SUPPORTS_EXTENDED}\r\n TExprCallFloat80VmOp = class(TExprVirtMachOp)\r\n private\r\n FFunc: TFloat80Func;\r\n public\r\n constructor Create(AFunc: TFloat80Func);\r\n procedure Execute; override;\r\n end;\r\n {$ENDIF SUPPORTS_EXTENDED}\r\n\r\n TExprCallUnaryVmOp = class(TExprVirtMachOp)\r\n private\r\n FFunc: TUnaryFunc;\r\n FX: PFloat;\r\n public\r\n constructor Create(AFunc: TUnaryFunc; X: PFloat);\r\n procedure Execute; override;\r\n end;\r\n\r\n TExprCallUnary32VmOp = class(TExprVirtMachOp)\r\n private\r\n FFunc: TUnary32Func;\r\n FX: PFloat;\r\n public\r\n constructor Create(AFunc: TUnary32Func; X: PFloat);\r\n procedure Execute; override;\r\n end;\r\n\r\n TExprCallUnary64VmOp = class(TExprVirtMachOp)\r\n private\r\n FFunc: TUnary64Func;\r\n FX: PFloat;\r\n public\r\n constructor Create(AFunc: TUnary64Func; X: PFloat);\r\n procedure Execute; override;\r\n end;\r\n\r\n {$IFDEF SUPPORTS_EXTENDED}\r\n TExprCallUnary80VmOp = class(TExprVirtMachOp)\r\n private\r\n FFunc: TUnary80Func;\r\n FX: PFloat;\r\n public\r\n constructor Create(AFunc: TUnary80Func; X: PFloat);\r\n procedure Execute; override;\r\n end;\r\n {$ENDIF SUPPORTS_EXTENDED}\r\n\r\n TExprCallBinaryVmOp = class(TExprVirtMachOp)\r\n private\r\n FFunc: TBinaryFunc;\r\n FX, FY: PFloat;\r\n public\r\n constructor Create(AFunc: TBinaryFunc; X, Y: PFloat);\r\n procedure Execute; override;\r\n end;\r\n\r\n TExprCallBinary32VmOp = class(TExprVirtMachOp)\r\n private\r\n FFunc: TBinary32Func;\r\n FX, FY: PFloat;\r\n public\r\n constructor Create(AFunc: TBinary32Func; X, Y: PFloat);\r\n procedure Execute; override;\r\n end;\r\n\r\n TExprCallBinary64VmOp = class(TExprVirtMachOp)\r\n private\r\n FFunc: TBinary64Func;\r\n FX, FY: PFloat;\r\n public\r\n constructor Create(AFunc: TBinary64Func; X, Y: PFloat);\r\n procedure Execute; override;\r\n end;\r\n\r\n {$IFDEF SUPPORTS_EXTENDED}\r\n TExprCallBinary80VmOp = class(TExprVirtMachOp)\r\n private\r\n FFunc: TBinary80Func;\r\n FX, FY: PFloat;\r\n public\r\n constructor Create(AFunc: TBinary80Func; X, Y: PFloat);\r\n procedure Execute; override;\r\n end;\r\n {$ENDIF SUPPORTS_EXTENDED}\r\n\r\n TExprCallTernaryVmOp = class(TExprVirtMachOp)\r\n private\r\n FFunc: TTernaryFunc;\r\n FX, FY, FZ: PFloat;\r\n public\r\n constructor Create(AFunc: TTernaryFunc; X, Y, Z: PFloat);\r\n procedure Execute; override;\r\n end;\r\n\r\n TExprCallTernary32VmOp = class(TExprVirtMachOp)\r\n private\r\n FFunc: TTernary32Func;\r\n FX, FY, FZ: PFloat;\r\n public\r\n constructor Create(AFunc: TTernary32Func; X, Y, Z: PFloat);\r\n procedure Execute; override;\r\n end;\r\n\r\n TExprCallTernary64VmOp = class(TExprVirtMachOp)\r\n private\r\n FFunc: TTernary64Func;\r\n FX, FY, FZ: PFloat;\r\n public\r\n constructor Create(AFunc: TTernary64Func; X, Y, Z: PFloat);\r\n procedure Execute; override;\r\n end;\r\n\r\n {$IFDEF SUPPORTS_EXTENDED}\r\n TExprCallTernary80VmOp = class(TExprVirtMachOp)\r\n private\r\n FFunc: TTernary80Func;\r\n FX, FY, FZ: PFloat;\r\n public\r\n constructor Create(AFunc: TTernary80Func; X, Y, Z: PFloat);\r\n procedure Execute; override;\r\n end;\r\n {$ENDIF SUPPORTS_EXTENDED}\r\n\r\n//=== { TExprVar32VmOp } =====================================================\r\n\r\nprocedure TExprVar32VmOp.Execute;\r\nbegin\r\n FOutput := PFloat32(FVarLoc)^;\r\nend;\r\n\r\n//=== { TExprVar64VmOp } =====================================================\r\n\r\nprocedure TExprVar64VmOp.Execute;\r\nbegin\r\n FOutput := PFloat64(FVarLoc)^;\r\nend;\r\n\r\n{$IFDEF SUPPORTS_EXTENDED}\r\n\r\n//=== { TExprVar80VmOp } =====================================================\r\n\r\nprocedure TExprVar80VmOp.Execute;\r\nbegin\r\n FOutput := PFloat80(FVarLoc)^;\r\nend;\r\n\r\n{$ENDIF SUPPORTS_EXTENDED}\r\n\r\n//=== { TExprConstVmOp } =====================================================\r\n\r\nconstructor TExprConstVmOp.Create(AValue: TFloat);\r\nbegin\r\n inherited Create;\r\n FOutput := AValue;\r\nend;\r\n\r\nprocedure TExprConstVmOp.Execute;\r\nbegin\r\nend;\r\n\r\n//=== { TExprUnaryVmOp } =====================================================\r\n\r\nconstructor TExprUnaryVmOp.Create(AInput: PFloat);\r\nbegin\r\n inherited Create;\r\n FInput := AInput;\r\nend;\r\n\r\n//=== { TExprBinaryVmOp } ====================================================\r\n\r\nconstructor TExprBinaryVmOp.Create(ALeft, ARight: PFloat);\r\nbegin\r\n inherited Create;\r\n FLeft := ALeft;\r\n FRight := ARight;\r\nend;\r\n\r\n//=== { TExprAddVmOp } =======================================================\r\nprocedure TExprAddVmOp.Execute;\r\nbegin\r\n FOutput := FLeft^ + FRight^;\r\nend;\r\n\r\n//=== { TExprSubtractVmOp } ==================================================\r\n\r\nprocedure TExprSubtractVmOp.Execute;\r\nbegin\r\n FOutput := FLeft^ - FRight^;\r\nend;\r\n\r\n//=== { TExprMultiplyVmOp } ==================================================\r\n\r\nprocedure TExprMultiplyVmOp.Execute;\r\nbegin\r\n FOutput := FLeft^ * FRight^;\r\nend;\r\n\r\n//=== { TExprDivideVmOp } ====================================================\r\n\r\nprocedure TExprDivideVmOp.Execute;\r\nbegin\r\n FOutput := FLeft^ / FRight^;\r\nend;\r\n\r\n//=== { TExprCompareVmOp } ===================================================\r\n\r\nprocedure TExprCompareVmOp.Execute;\r\nbegin\r\n if FLeft^ < FRight^ then\r\n FOutput := -1.0\r\n else\r\n if FLeft^ > FRight^ then\r\n FOutput := 1.0\r\n else\r\n FOutput := 0.0;\r\nend;\r\n\r\n//=== { TExprCmpGreaterVmOp } ================================================\r\n\r\nprocedure TExprGreaterVmOp.Execute;\r\nbegin\r\n if FLeft^ > FRight^ then\r\n FOutput := 1.0\r\n else\r\n FOutput := 0.0;\r\nend;\r\n\r\n//=== { TExprCmpGreaterEqualVmOp } ===========================================\r\n\r\nprocedure TExprGreaterEqualVmOp.Execute;\r\nbegin\r\n if FLeft^ >= FRight^ then\r\n FOutput := 1.0\r\n else\r\n FOutput := 0.0;\r\nend;\r\n\r\n//=== { TExprCmpLessVmOp } ===================================================\r\n\r\nprocedure TExprLessVmOp.Execute;\r\nbegin\r\n if FLeft^ < FRight^ then\r\n FOutput := 1.0\r\n else\r\n FOutput := 0.0;\r\nend;\r\n\r\n// === { TExprCmpLessEqualVmOp } =============================================\r\n\r\nprocedure TExprLessEqualVmOp.Execute;\r\nbegin\r\n if FLeft^ <= FRight^ then\r\n FOutput := 1.0\r\n else\r\n FOutput := 0.0;\r\nend;\r\n\r\n//=== { TExprCmpEqualVmOp } ==================================================\r\n\r\nprocedure TExprEqualVmOp.Execute;\r\nbegin\r\n if FLeft^ = FRight^ then\r\n FOutput := 1.0\r\n else\r\n FOutput := 0.0;\r\nend;\r\n\r\n//=== { TExprCmpNotEqualVmOp } ===============================================\r\n\r\nprocedure TExprNotEqualVmOp.Execute;\r\nbegin\r\n if FLeft^ <> FRight^ then\r\n FOutput := 1.0\r\n else\r\n FOutput := 0.0;\r\nend;\r\n\r\n//=== { TExprDivVmOp } =======================================================\r\n\r\nprocedure TExprIntegerDivideVmOp.Execute;\r\nbegin\r\n FOutput := Round(FLeft^) div Round(FRight^);\r\nend;\r\n\r\n//=== { TExprModVmOp } =======================================================\r\n\r\nprocedure TExprModuloVmOp.Execute;\r\nbegin\r\n FOutput := Round(FLeft^) mod Round(FRight^);\r\nend;\r\n\r\n//=== { TExprShiftLeftVmOp } =================================================\r\n\r\nprocedure TExprShiftLeftVmOp.Execute;\r\nbegin\r\n FOutput := Round(FLeft^) shl Round(FRight^);\r\nend;\r\n\r\n//=== { TExprShiftRightVmOp } ================================================\r\n\r\nprocedure TExprShiftRightVmOp.Execute;\r\nbegin\r\n FOutput := Round(FLeft^) shr Round(FRight^);\r\nend;\r\n\r\n//=== { TExprBitwiseAndVmOp } ================================================\r\n\r\nprocedure TExprBitwiseAndVmOp.Execute;\r\nbegin\r\n FOutput := Round(FLeft^) and Round(FRight^);\r\nend;\r\n\r\n//=== { TExprOrVmOp } ========================================================\r\n\r\nprocedure TExprBitwiseOrVmOp.Execute;\r\nbegin\r\n FOutput := Round(FLeft^) or Round(FRight^);\r\nend;\r\n\r\n//=== { TExprXorVmOp } =======================================================\r\n\r\nprocedure TExprBitwiseXorVmOp.Execute;\r\nbegin\r\n FOutput := Round(FLeft^) xor Round(FRight^);\r\nend;\r\n\r\n//=== { TExprLogicalAndVmOp } ================================================\r\n\r\nprocedure TExprLogicalAndVmOp.Execute;\r\nbegin\r\n if (FLeft^ <> 0.0) and (FRight^ <> 0) then\r\n FOutput := 1.0\r\n else\r\n FOutput := 0.0;\r\nend;\r\n\r\n//=== { TExprLogicalOrVmOp } =================================================\r\n\r\nprocedure TExprLogicalOrVmOp.Execute;\r\nbegin\r\n if (FLeft^ <> 0.0) or (FRight^ <> 0) then\r\n FOutput := 1.0\r\n else\r\n FOutput := 0.0;\r\nend;\r\n\r\n//=== { TExprLogicalXorVmOp } ================================================\r\n\r\nprocedure TExprLogicalXorVmOp.Execute;\r\nbegin\r\n if (FLeft^ <> 0.0) xor (FRight^ <> 0) then\r\n FOutput := 1.0\r\n else\r\n FOutput := 0.0;\r\nend;\r\n\r\n//=== { TExprNegateVmOp } ====================================================\r\n\r\nprocedure TExprNegateVmOp.Execute;\r\nbegin\r\n FOutput := - FInput^;\r\nend;\r\n\r\n//=== { TExprLogicalNotVmOp } ================================================\r\n\r\nprocedure TExprLogicalNotVmOp.Execute;\r\nbegin\r\n if FInput^ <> 0.0 then\r\n FOutput := 0.0\r\n else\r\n FOutput := 1.0;\r\nend;\r\n\r\n//=== { TExprBitwiseNotVmOp } ================================================\r\n\r\nprocedure TExprBitwiseNotVmOp.Execute;\r\nbegin\r\n FOutput := not Round(FInput^);\r\nend;\r\n\r\n//=== { TExprVarVmOp } =======================================================\r\n\r\nconstructor TExprVarVmOp.Create(AVarLoc: Pointer);\r\nbegin\r\n inherited Create;\r\n FVarLoc := AVarLoc;\r\nend;\r\n\r\n//=== { TExprCallFloatVmOp } =================================================\r\n\r\nconstructor TExprCallFloatVmOp.Create(AFunc: TFloatFunc);\r\nbegin\r\n inherited Create;\r\n FFunc := AFunc;\r\nend;\r\n\r\nprocedure TExprCallFloatVmOp.Execute;\r\nbegin\r\n FOutput := FFunc;\r\nend;\r\n\r\n//=== { TExprCallFloat32VmOp } ===============================================\r\n\r\nconstructor TExprCallFloat32VmOp.Create(AFunc: TFloat32Func);\r\nbegin\r\n inherited Create;\r\n FFunc := AFunc;\r\nend;\r\n\r\nprocedure TExprCallFloat32VmOp.Execute;\r\nbegin\r\n FOutput := FFunc;\r\nend;\r\n\r\n//=== { TExprCallFloat64VmOp } ===============================================\r\n\r\nconstructor TExprCallFloat64VmOp.Create(AFunc: TFloat64Func);\r\nbegin\r\n inherited Create;\r\n FFunc := AFunc;\r\nend;\r\n\r\nprocedure TExprCallFloat64VmOp.Execute;\r\nbegin\r\n FOutput := FFunc;\r\nend;\r\n\r\n{$IFDEF SUPPORTS_EXTENDED}\r\n\r\n//=== { TExprCallFloat80VmOp } ===============================================\r\n\r\nconstructor TExprCallFloat80VmOp.Create(AFunc: TFloat80Func);\r\nbegin\r\n inherited Create;\r\n FFunc := AFunc;\r\nend;\r\n\r\nprocedure TExprCallFloat80VmOp.Execute;\r\nbegin\r\n FOutput := FFunc;\r\nend;\r\n\r\n{$ENDIF SUPPORTS_EXTENDED}\r\n\r\n//=== { TExprCallUnaryVmOp } =================================================\r\n\r\nconstructor TExprCallUnaryVmOp.Create(AFunc: TUnaryFunc; X: PFloat);\r\nbegin\r\n inherited Create;\r\n FFunc := AFunc;\r\n FX := X;\r\nend;\r\n\r\nprocedure TExprCallUnaryVmOp.Execute;\r\nbegin\r\n FOutput := FFunc(FX^);\r\nend;\r\n\r\n//=== { TExprCallUnary32VmOp } ===============================================\r\n\r\nconstructor TExprCallUnary32VmOp.Create(AFunc: TUnary32Func; X: PFloat);\r\nbegin\r\n inherited Create;\r\n FFunc := AFunc;\r\n FX := X;\r\nend;\r\n\r\nprocedure TExprCallUnary32VmOp.Execute;\r\nbegin\r\n FOutput := FFunc(FX^);\r\nend;\r\n\r\n//=== { TExprCallUnary64VmOp } ===============================================\r\n\r\nconstructor TExprCallUnary64VmOp.Create(AFunc: TUnary64Func; X: PFloat);\r\nbegin\r\n inherited Create;\r\n FFunc := AFunc;\r\n FX := X;\r\nend;\r\n\r\nprocedure TExprCallUnary64VmOp.Execute;\r\nbegin\r\n FOutput := FFunc(FX^);\r\nend;\r\n\r\n{$IFDEF SUPPORTS_EXTENDED}\r\n\r\n//=== { TExprCallUnary80VmOp } ===============================================\r\n\r\nconstructor TExprCallUnary80VmOp.Create(AFunc: TUnary80Func; X: PFloat);\r\nbegin\r\n inherited Create;\r\n FFunc := AFunc;\r\n FX := X;\r\nend;\r\n\r\nprocedure TExprCallUnary80VmOp.Execute;\r\nbegin\r\n FOutput := FFunc(FX^);\r\nend;\r\n\r\n{$ENDIF SUPPORTS_EXTENDED}\r\n\r\n//=== { TExprCallBinaryVmOp } ================================================\r\n\r\nconstructor TExprCallBinaryVmOp.Create(AFunc: TBinaryFunc; X, Y: PFloat);\r\nbegin\r\n inherited Create;\r\n FFunc := AFunc;\r\n FX := X;\r\n FY := Y;\r\nend;\r\n\r\nprocedure TExprCallBinaryVmOp.Execute;\r\nbegin\r\n FOutput := FFunc(FX^, FY^);\r\nend;\r\n\r\n//=== { TExprCallBinary32VmOp } ==============================================\r\n\r\nconstructor TExprCallBinary32VmOp.Create(AFunc: TBinary32Func; X, Y: PFloat);\r\nbegin\r\n inherited Create;\r\n FFunc := AFunc;\r\n FX := X;\r\n FY := Y;\r\nend;\r\n\r\nprocedure TExprCallBinary32VmOp.Execute;\r\nbegin\r\n FOutput := FFunc(FX^, FY^);\r\nend;\r\n\r\n//=== { TExprCallBinary64VmOp } ==============================================\r\n\r\nconstructor TExprCallBinary64VmOp.Create(AFunc: TBinary64Func; X, Y: PFloat);\r\nbegin\r\n inherited Create;\r\n FFunc := AFunc;\r\n FX := X;\r\n FY := Y;\r\nend;\r\n\r\nprocedure TExprCallBinary64VmOp.Execute;\r\nbegin\r\n FOutput := FFunc(FX^, FY^);\r\nend;\r\n\r\n{$IFDEF SUPPORTS_EXTENDED}\r\n\r\n//=== { TExprCallBinary80VmOp } ==============================================\r\n\r\nconstructor TExprCallBinary80VmOp.Create(AFunc: TBinary80Func; X, Y: PFloat);\r\nbegin\r\n inherited Create;\r\n FFunc := AFunc;\r\n FX := X;\r\n FY := Y;\r\nend;\r\n\r\nprocedure TExprCallBinary80VmOp.Execute;\r\nbegin\r\n FOutput := FFunc(FX^, FY^);\r\nend;\r\n\r\n{$ENDIF SUPPORTS_EXTENDED}\r\n\r\n//=== { TExprCallTernaryVmOp } ===============================================\r\n\r\nconstructor TExprCallTernaryVmOp.Create(AFunc: TTernaryFunc; X, Y, Z: PFloat);\r\nbegin\r\n inherited Create;\r\n FFunc := AFunc;\r\n FX := X;\r\n FY := Y;\r\n FZ := Z;\r\nend;\r\n\r\nprocedure TExprCallTernaryVmOp.Execute;\r\nbegin\r\n FOutput := FFunc(FX^, FY^, FZ^);\r\nend;\r\n\r\n//=== { TExprCallTernary32VmOp } =============================================\r\n\r\nconstructor TExprCallTernary32VmOp.Create(AFunc: TTernary32Func; X, Y, Z: PFloat);\r\nbegin\r\n inherited Create;\r\n FFunc := AFunc;\r\n FX := X;\r\n FY := Y;\r\n FZ := Z;\r\nend;\r\n\r\nprocedure TExprCallTernary32VmOp.Execute;\r\nbegin\r\n FOutput := FFunc(FX^, FY^, FZ^);\r\nend;\r\n\r\n//=== { TExprCallTernary64VmOp } =============================================\r\n\r\nconstructor TExprCallTernary64VmOp.Create(AFunc: TTernary64Func; X, Y, Z: PFloat);\r\nbegin\r\n inherited Create;\r\n FFunc := AFunc;\r\n FX := X;\r\n FY := Y;\r\n FZ := Z;\r\nend;\r\n\r\nprocedure TExprCallTernary64VmOp.Execute;\r\nbegin\r\n FOutput := FFunc(FX^, FY^, FZ^);\r\nend;\r\n\r\n{$IFDEF SUPPORTS_EXTENDED}\r\n\r\n//=== { TExprCallTernary80VmOp } =============================================\r\n\r\nconstructor TExprCallTernary80VmOp.Create(AFunc: TTernary80Func; X, Y, Z: PFloat);\r\nbegin\r\n inherited Create;\r\n FFunc := AFunc;\r\n FX := X;\r\n FY := Y;\r\n FZ := Z;\r\nend;\r\n\r\nprocedure TExprCallTernary80VmOp.Execute;\r\nbegin\r\n FOutput := FFunc(FX^, FY^, FZ^);\r\nend;\r\n\r\n{$ENDIF SUPPORTS_EXTENDED}\r\n\r\n{ End of virtual machine operators }\r\n\r\n//=== { TExprVirtMach } ======================================================\r\n\r\nconstructor TExprVirtMach.Create;\r\nbegin\r\n inherited Create;\r\n FCodeList := TList.Create;\r\n FConstList := TList.Create;\r\nend;\r\n\r\ndestructor TExprVirtMach.Destroy;\r\nbegin\r\n FreeObjectList(FCodeList);\r\n FreeObjectList(FConstList);\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TExprVirtMach.Execute: TFloat;\r\ntype\r\n PExprVirtMachOp = ^TExprVirtMachOp;\r\nvar\r\n I: Integer;\r\n pop: PExprVirtMachOp;\r\nbegin\r\n if FCodeList.Count <> 0 then\r\n begin\r\n { The code that follows is the same as this, but a lot faster\r\n for I := 0 to FCodeList.Count - 1 do\r\n TExprVirtMachOp(FCodeList[I]).Execute; }\r\n I := FCodeList.Count;\r\n pop := @FCodeList.List{$IFNDEF RTL230_UP}^{$ENDIF !RTL230_UP}[0];\r\n while I > 0 do\r\n begin\r\n pop^.Execute;\r\n Inc(pop);\r\n Dec(I);\r\n end;\r\n Result := TExprVirtMachOp(FCodeList[FCodeList.Count - 1]).FOutput;\r\n end\r\n else\r\n begin\r\n if (FConstList.Count = 1) then\r\n Result := TExprVirtMachOp(FConstList[0]).FOutput\r\n else\r\n Result := 0;\r\n end;\r\nend;\r\n\r\nprocedure TExprVirtMach.Add(AOp: TExprVirtMachOp);\r\nbegin\r\n FCodeList.Add(AOp);\r\nend;\r\n\r\nprocedure TExprVirtMach.AddConst(AOp: TExprVirtMachOp);\r\nbegin\r\n FConstList.Add(AOp);\r\nend;\r\n\r\nprocedure TExprVirtMach.Clear;\r\nbegin\r\n ClearObjectList(FCodeList);\r\n ClearObjectList(FConstList);\r\nend;\r\n\r\n//=== { TExprVirtMachNode } ==================================================\r\n\r\ntype\r\n TExprVirtMachNode = class(TExprNode)\r\n private\r\n FExprVmCode: TExprVirtMachOp;\r\n function GetVmDeps(AIndex: Integer): TExprVirtMachNode;\r\n public\r\n procedure GenCode(AVirtMach: TExprVirtMach); virtual; abstract;\r\n\r\n property ExprVmCode: TExprVirtMachOp read FExprVmCode;\r\n\r\n { this property saves typecasting to access ExprVmCode }\r\n property VmDeps[AIndex: Integer]: TExprVirtMachNode read GetVmDeps; default;\r\n end;\r\n\r\nfunction TExprVirtMachNode.GetVmDeps(AIndex: Integer): TExprVirtMachNode;\r\nbegin\r\n Result := TExprVirtMachNode(FDepList[AIndex]);\r\nend;\r\n\r\n//=== Concrete expression nodes for virtual machine ==========================\r\n\r\ntype\r\n TExprUnaryVmNode = class(TExprVirtMachNode)\r\n private\r\n FUnaryClass: TExprUnaryVmOpClass;\r\n public\r\n constructor Create(AUnaryClass: TExprUnaryVmOpClass;\r\n const ADeps: array of TExprNode);\r\n procedure GenCode(AVirtMach: TExprVirtMach); override;\r\n end;\r\n\r\n TExprBinaryVmNode = class(TExprVirtMachNode)\r\n private\r\n FBinaryClass: TExprBinaryVmOpClass;\r\n public\r\n constructor Create(ABinaryClass: TExprBinaryVmOpClass;\r\n const ADeps: array of TExprNode);\r\n procedure GenCode(AVirtMach: TExprVirtMach); override;\r\n end;\r\n\r\n TExprConstVmNode = class(TExprVirtMachNode)\r\n private\r\n FValue: TFloat;\r\n public\r\n constructor Create(AValue: TFloat);\r\n procedure GenCode(AVirtMach: TExprVirtMach); override;\r\n end;\r\n\r\n TExprVar32VmNode = class(TExprVirtMachNode)\r\n private\r\n FValue: PFloat32;\r\n public\r\n constructor Create(AValue: PFloat32);\r\n procedure GenCode(AVirtMach: TExprVirtMach); override;\r\n end;\r\n\r\n TExprVar64VmNode = class(TExprVirtMachNode)\r\n private\r\n FValue: PFloat64;\r\n public\r\n constructor Create(AValue: PFloat64);\r\n procedure GenCode(AVirtMach: TExprVirtMach); override;\r\n end;\r\n\r\n {$IFDEF SUPPORTS_EXTENDED}\r\n TExprVar80VmNode = class(TExprVirtMachNode)\r\n private\r\n FValue: PFloat80;\r\n public\r\n constructor Create(AValue: PFloat80);\r\n procedure GenCode(AVirtMach: TExprVirtMach); override;\r\n end;\r\n {$ENDIF SUPPORTS_EXTENDED}\r\n\r\n TExprCallFloatVmNode = class(TExprVirtMachNode)\r\n private\r\n FFunc: TFloatFunc;\r\n public\r\n constructor Create(AFunc: TFloatFunc);\r\n procedure GenCode(AVirtMach: TExprVirtMach); override;\r\n end;\r\n\r\n TExprCallFloat32VmNode = class(TExprVirtMachNode)\r\n private\r\n FFunc: TFloat32Func;\r\n public\r\n constructor Create(AFunc: TFloat32Func);\r\n procedure GenCode(AVirtMach: TExprVirtMach); override;\r\n end;\r\n\r\n TExprCallFloat64VmNode = class(TExprVirtMachNode)\r\n private\r\n FFunc: TFloat64Func;\r\n public\r\n constructor Create(AFunc: TFloat64Func);\r\n procedure GenCode(AVirtMach: TExprVirtMach); override;\r\n end;\r\n\r\n {$IFDEF SUPPORTS_EXTENDED}\r\n TExprCallFloat80VmNode = class(TExprVirtMachNode)\r\n private\r\n FFunc: TFloat80Func;\r\n public\r\n constructor Create(AFunc: TFloat80Func);\r\n procedure GenCode(AVirtMach: TExprVirtMach); override;\r\n end;\r\n {$ENDIF SUPPORTS_EXTENDED}\r\n\r\n TExprCallUnaryVmNode = class(TExprVirtMachNode)\r\n private\r\n FFunc: TUnaryFunc;\r\n public\r\n constructor Create(AFunc: TUnaryFunc; X: TExprNode);\r\n procedure GenCode(AVirtMach: TExprVirtMach); override;\r\n end;\r\n\r\n TExprCallUnary32VmNode = class(TExprVirtMachNode)\r\n private\r\n FFunc: TUnary32Func;\r\n public\r\n constructor Create(AFunc: TUnary32Func; X: TExprNode);\r\n procedure GenCode(AVirtMach: TExprVirtMach); override;\r\n end;\r\n\r\n TExprCallUnary64VmNode = class(TExprVirtMachNode)\r\n private\r\n FFunc: TUnary64Func;\r\n public\r\n constructor Create(AFunc: TUnary64Func; X: TExprNode);\r\n procedure GenCode(AVirtMach: TExprVirtMach); override;\r\n end;\r\n\r\n {$IFDEF SUPPORTS_EXTENDED}\r\n TExprCallUnary80VmNode = class(TExprVirtMachNode)\r\n private\r\n FFunc: TUnary80Func;\r\n public\r\n constructor Create(AFunc: TUnary80Func; X: TExprNode);\r\n procedure GenCode(AVirtMach: TExprVirtMach); override;\r\n end;\r\n {$ENDIF SUPPORTS_EXTENDED}\r\n\r\n TExprCallBinaryVmNode = class(TExprVirtMachNode)\r\n private\r\n FFunc: TBinaryFunc;\r\n public\r\n constructor Create(AFunc: TBinaryFunc; X, Y: TExprNode);\r\n procedure GenCode(AVirtMach: TExprVirtMach); override;\r\n end;\r\n\r\n TExprCallBinary32VmNode = class(TExprVirtMachNode)\r\n private\r\n FFunc: TBinary32Func;\r\n public\r\n constructor Create(AFunc: TBinary32Func; X, Y: TExprNode);\r\n procedure GenCode(AVirtMach: TExprVirtMach); override;\r\n end;\r\n\r\n TExprCallBinary64VmNode = class(TExprVirtMachNode)\r\n private\r\n FFunc: TBinary64Func;\r\n public\r\n constructor Create(AFunc: TBinary64Func; X, Y: TExprNode);\r\n procedure GenCode(AVirtMach: TExprVirtMach); override;\r\n end;\r\n\r\n {$IFDEF SUPPORTS_EXTENDED}\r\n TExprCallBinary80VmNode = class(TExprVirtMachNode)\r\n private\r\n FFunc: TBinary80Func;\r\n public\r\n constructor Create(AFunc: TBinary80Func; X, Y: TExprNode);\r\n procedure GenCode(AVirtMach: TExprVirtMach); override;\r\n end;\r\n {$ENDIF SUPPORTS_EXTENDED}\r\n\r\n TExprCallTernaryVmNode = class(TExprVirtMachNode)\r\n private\r\n FFunc: TTernaryFunc;\r\n public\r\n constructor Create(AFunc: TTernaryFunc; X, Y, Z: TExprNode);\r\n procedure GenCode(AVirtMach: TExprVirtMach); override;\r\n end;\r\n\r\n TExprCallTernary32VmNode = class(TExprVirtMachNode)\r\n private\r\n FFunc: TTernary32Func;\r\n public\r\n constructor Create(AFunc: TTernary32Func; X, Y, Z: TExprNode);\r\n procedure GenCode(AVirtMach: TExprVirtMach); override;\r\n end;\r\n\r\n TExprCallTernary64VmNode = class(TExprVirtMachNode)\r\n private\r\n FFunc: TTernary64Func;\r\n public\r\n constructor Create(AFunc: TTernary64Func; X, Y, Z: TExprNode);\r\n procedure GenCode(AVirtMach: TExprVirtMach); override;\r\n end;\r\n\r\n {$IFDEF SUPPORTS_EXTENDED}\r\n TExprCallTernary80VmNode = class(TExprVirtMachNode)\r\n private\r\n FFunc: TTernary80Func;\r\n public\r\n constructor Create(AFunc: TTernary80Func; X, Y, Z: TExprNode);\r\n procedure GenCode(AVirtMach: TExprVirtMach); override;\r\n end;\r\n {$ENDIF SUPPORTS_EXTENDED}\r\n\r\n//== { TExprUnaryVmNode } ====================================================\r\n\r\nconstructor TExprUnaryVmNode.Create(AUnaryClass: TExprUnaryVmOpClass; const ADeps: array of TExprNode);\r\nbegin\r\n FUnaryClass := AUnaryClass;\r\n inherited Create(ADeps);\r\n Assert(FDepList.Count = 1);\r\nend;\r\n\r\nprocedure TExprUnaryVmNode.GenCode(AVirtMach: TExprVirtMach);\r\nbegin\r\n FExprVmCode := FUnaryClass.Create(VmDeps[0].ExprVmCode.OutputLoc);\r\n AVirtMach.Add(FExprVmCode);\r\nend;\r\n\r\n//=== { TExprBinaryVmNode } ==================================================\r\n\r\nconstructor TExprBinaryVmNode.Create(ABinaryClass: TExprBinaryVmOpClass; const ADeps: array of TExprNode);\r\nbegin\r\n FBinaryClass := ABinaryClass;\r\n inherited Create(ADeps);\r\n Assert(FDepList.Count = 2);\r\nend;\r\n\r\nprocedure TExprBinaryVmNode.GenCode(AVirtMach: TExprVirtMach);\r\nbegin\r\n FExprVmCode := FBinaryClass.Create(\r\n VmDeps[0].ExprVmCode.OutputLoc,\r\n VmDeps[1].ExprVmCode.OutputLoc);\r\n AVirtMach.Add(FExprVmCode);\r\nend;\r\n\r\n//=== { TExprConstVmNode } ==================================================\r\n\r\nconstructor TExprConstVmNode.Create(AValue: TFloat);\r\nbegin\r\n FValue := AValue;\r\n inherited Create([]);\r\nend;\r\n\r\nprocedure TExprConstVmNode.GenCode(AVirtMach: TExprVirtMach);\r\nbegin\r\n FExprVmCode := TExprConstVmOp.Create(FValue);\r\n AVirtMach.AddConst(FExprVmCode);\r\nend;\r\n\r\n//=== { TExprVar32VmNode } ===================================================\r\n\r\nconstructor TExprVar32VmNode.Create(AValue: PFloat32);\r\nbegin\r\n FValue := AValue;\r\n inherited Create([]);\r\nend;\r\n\r\nprocedure TExprVar32VmNode.GenCode(AVirtMach: TExprVirtMach);\r\nbegin\r\n FExprVmCode := TExprVar32VmOp.Create(FValue);\r\n AVirtMach.Add(FExprVmCode);\r\nend;\r\n\r\n//=== { TExprVar64VmNode } ===================================================\r\n\r\nconstructor TExprVar64VmNode.Create(AValue: PFloat64);\r\nbegin\r\n FValue := AValue;\r\n inherited Create([]);\r\nend;\r\n\r\nprocedure TExprVar64VmNode.GenCode(AVirtMach: TExprVirtMach);\r\nbegin\r\n FExprVmCode := TExprVar64VmOp.Create(FValue);\r\n AVirtMach.Add(FExprVmCode);\r\nend;\r\n\r\n{$IFDEF SUPPORTS_EXTENDED}\r\n\r\n//=== { TExprVar80VmNode } ===================================================\r\n\r\nconstructor TExprVar80VmNode.Create(AValue: PFloat80);\r\nbegin\r\n FValue := AValue;\r\n inherited Create([]);\r\nend;\r\n\r\nprocedure TExprVar80VmNode.GenCode(AVirtMach: TExprVirtMach);\r\nbegin\r\n FExprVmCode := TExprVar80VmOp.Create(FValue);\r\n AVirtMach.Add(FExprVmCode);\r\nend;\r\n\r\n{$ENDIF SUPPORTS_EXTENDED}\r\n\r\n{ End of expression nodes for virtual machine }\r\n\r\n//=== { TExprVirtMachNodeFactory } ===========================================\r\n\r\nconstructor TExprVirtMachNodeFactory.Create;\r\nbegin\r\n inherited Create;\r\n FNodeList := TList.Create;\r\nend;\r\n\r\ndestructor TExprVirtMachNodeFactory.Destroy;\r\nbegin\r\n FreeObjectList(FNodeList);\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TExprVirtMachNodeFactory.AddNode(ANode: TExprNode): TExprNode;\r\nbegin\r\n Result := ANode;\r\n FNodeList.Add(ANode);\r\nend;\r\n\r\nprocedure TExprVirtMachNodeFactory.GenCode(AVirtMach: TExprVirtMach);\r\nbegin\r\n { TODO : optimize the expression tree into a DAG (i.e. find CSEs) and\r\n evaluate constant subexpressions, implement strength reduction, etc. }\r\n\r\n { TODO : move optimization logic (as far as possible) into ancestor classes\r\n once tested and interfaces are solid, so that other evaluation strategies\r\n can take advantage of these optimizations. }\r\n\r\n DoClean(AVirtMach);\r\n DoConsts(AVirtMach);\r\n DoCode(AVirtMach);\r\nend;\r\n\r\nfunction TExprVirtMachNodeFactory.LoadVar32(ALoc: PFloat32): TExprNode;\r\nbegin\r\n Result := AddNode(TExprVar32VmNode.Create(ALoc));\r\nend;\r\n\r\nfunction TExprVirtMachNodeFactory.LoadVar64(ALoc: PFloat64): TExprNode;\r\nbegin\r\n Result := AddNode(TExprVar64VmNode.Create(ALoc));\r\nend;\r\n\r\n{$IFDEF SUPPORTS_EXTENDED}\r\nfunction TExprVirtMachNodeFactory.LoadVar80(ALoc: PFloat80): TExprNode;\r\nbegin\r\n Result := AddNode(TExprVar80VmNode.Create(ALoc));\r\nend;\r\n{$ENDIF SUPPORTS_EXTENDED}\r\n\r\nfunction TExprVirtMachNodeFactory.LoadConst32(AValue: TFloat32): TExprNode;\r\nbegin\r\n Result := AddNode(TExprConstVmNode.Create(AValue));\r\nend;\r\n\r\nfunction TExprVirtMachNodeFactory.LoadConst64(AValue: TFloat64): TExprNode;\r\nbegin\r\n Result := AddNode(TExprConstVmNode.Create(AValue));\r\nend;\r\n\r\n{$IFDEF SUPPORTS_EXTENDED}\r\nfunction TExprVirtMachNodeFactory.LoadConst80(AValue: TFloat80): TExprNode;\r\nbegin\r\n Result := AddNode(TExprConstVmNode.Create(AValue));\r\nend;\r\n{$ENDIF SUPPORTS_EXTENDED}\r\n\r\nfunction TExprVirtMachNodeFactory.Add(ALeft, ARight: TExprNode): TExprNode;\r\nbegin\r\n Result := AddNode(TExprBinaryVmNode.Create(TExprAddVmOp, [ALeft, ARight]));\r\nend;\r\n\r\nfunction TExprVirtMachNodeFactory.Subtract(ALeft, ARight: TExprNode): TExprNode;\r\nbegin\r\n Result := AddNode(TExprBinaryVmNode.Create(TExprSubtractVmOp, [ALeft, ARight]));\r\nend;\r\n\r\nfunction TExprVirtMachNodeFactory.Multiply(ALeft, ARight: TExprNode): TExprNode;\r\nbegin\r\n Result := AddNode(TExprBinaryVmNode.Create(TExprMultiplyVmOp, [ALeft, ARight]));\r\nend;\r\n\r\nfunction TExprVirtMachNodeFactory.Divide(ALeft, ARight: TExprNode): TExprNode;\r\nbegin\r\n Result := AddNode(TExprBinaryVmNode.Create(TExprDivideVmOp, [ALeft, ARight]));\r\nend;\r\n\r\nfunction TExprVirtMachNodeFactory.IntegerDivide(ALeft, ARight: TExprNode): TExprNode;\r\nbegin\r\n Result := AddNode(TExprBinaryVmNode.Create(TExprIntegerDivideVmOp, [ALeft, ARight]));\r\nend;\r\n\r\nfunction TExprVirtMachNodeFactory.Modulo(ALeft, ARight: TExprNode): TExprNode;\r\nbegin\r\n Result := AddNode(TExprBinaryVmNode.Create(TExprModuloVmOp, [ALeft, ARight]));\r\nend;\r\n\r\nfunction TExprVirtMachNodeFactory.Negate(AValue: TExprNode): TExprNode;\r\nbegin\r\n Result := AddNode(TExprUnaryVmNode.Create(TExprNegateVmOp, [AValue]));\r\nend;\r\n\r\nprocedure TExprVirtMachNodeFactory.DoClean(AVirtMach: TExprVirtMach);\r\nvar\r\n I: Integer;\r\nbegin\r\n { clean up in preparation for code generation }\r\n AVirtMach.Clear;\r\n for I := 0 to FNodeList.Count - 1 do\r\n TExprVirtMachNode(FNodeList[I]).FExprVmCode := nil;\r\nend;\r\n\r\nprocedure TExprVirtMachNodeFactory.DoConsts(AVirtMach: TExprVirtMach);\r\nvar\r\n I: Integer;\r\n Node: TExprVirtMachNode;\r\nbegin\r\n { process consts }\r\n for I := 0 to FNodeList.Count - 1 do\r\n begin\r\n Node := TExprVirtMachNode(FNodeList[I]);\r\n if (Node is TExprConstVmNode) and (Node.ExprVmCode = nil) then\r\n Node.GenCode(AVirtMach);\r\n end;\r\nend;\r\n\r\nprocedure TExprVirtMachNodeFactory.DoCode(AVirtMach: TExprVirtMach);\r\nvar\r\n I: Integer;\r\n Node: TExprVirtMachNode;\r\nbegin\r\n { process code }\r\n for I := 0 to FNodeList.Count - 1 do\r\n begin\r\n Node := TExprVirtMachNode(FNodeList[I]);\r\n if Node.ExprVmCode = nil then\r\n Node.GenCode(AVirtMach);\r\n end;\r\nend;\r\n\r\nfunction TExprVirtMachNodeFactory.CallFloatFunc(AFunc: TFloatFunc): TExprNode;\r\nbegin\r\n Result := AddNode(TExprCallFloatVmNode.Create(AFunc));\r\nend;\r\n\r\nfunction TExprVirtMachNodeFactory.CallFloat32Func(AFunc: TFloat32Func): TExprNode;\r\nbegin\r\n Result := AddNode(TExprCallFloat32VmNode.Create(AFunc));\r\nend;\r\n\r\nfunction TExprVirtMachNodeFactory.CallFloat64Func(AFunc: TFloat64Func): TExprNode;\r\nbegin\r\n Result := AddNode(TExprCallFloat64VmNode.Create(AFunc));\r\nend;\r\n\r\n{$IFDEF SUPPORTS_EXTENDED}\r\nfunction TExprVirtMachNodeFactory.CallFloat80Func(AFunc: TFloat80Func): TExprNode;\r\nbegin\r\n Result := AddNode(TExprCallFloat80VmNode.Create(AFunc));\r\nend;\r\n{$ENDIF SUPPORTS_EXTENDED}\r\n\r\nfunction TExprVirtMachNodeFactory.CallUnaryFunc(AFunc: TUnaryFunc; X: TExprNode): TExprNode;\r\nbegin\r\n Result := AddNode(TExprCallUnaryVmNode.Create(AFunc, X));\r\nend;\r\n\r\nfunction TExprVirtMachNodeFactory.CallUnary32Func(AFunc: TUnary32Func; X: TExprNode): TExprNode;\r\nbegin\r\n Result := AddNode(TExprCallUnary32VmNode.Create(AFunc, X));\r\nend;\r\n\r\nfunction TExprVirtMachNodeFactory.CallUnary64Func(AFunc: TUnary64Func; X: TExprNode): TExprNode;\r\nbegin\r\n Result := AddNode(TExprCallUnary64VmNode.Create(AFunc, X));\r\nend;\r\n\r\n{$IFDEF SUPPORTS_EXTENDED}\r\nfunction TExprVirtMachNodeFactory.CallUnary80Func(AFunc: TUnary80Func; X: TExprNode): TExprNode;\r\nbegin\r\n Result := AddNode(TExprCallUnary80VmNode.Create(AFunc, X));\r\nend;\r\n{$ENDIF SUPPORTS_EXTENDED}\r\n\r\nfunction TExprVirtMachNodeFactory.CallBinaryFunc(AFunc: TBinaryFunc; X, Y: TExprNode): TExprNode;\r\nbegin\r\n Result := AddNode(TExprCallBinaryVmNode.Create(AFunc, X, Y));\r\nend;\r\n\r\nfunction TExprVirtMachNodeFactory.CallBinary32Func(AFunc: TBinary32Func; X, Y: TExprNode): TExprNode;\r\nbegin\r\n Result := AddNode(TExprCallBinary32VmNode.Create(AFunc, X, Y));\r\nend;\r\n\r\nfunction TExprVirtMachNodeFactory.CallBinary64Func(AFunc: TBinary64Func; X, Y: TExprNode): TExprNode;\r\nbegin\r\n Result := AddNode(TExprCallBinary64VmNode.Create(AFunc, X, Y));\r\nend;\r\n\r\n{$IFDEF SUPPORTS_EXTENDED}\r\nfunction TExprVirtMachNodeFactory.CallBinary80Func(AFunc: TBinary80Func; X, Y: TExprNode): TExprNode;\r\nbegin\r\n Result := AddNode(TExprCallBinary80VmNode.Create(AFunc, X, Y));\r\nend;\r\n{$ENDIF SUPPORTS_EXTENDED}\r\n\r\nfunction TExprVirtMachNodeFactory.CallTernaryFunc(AFunc: TTernaryFunc; X, Y, Z: TExprNode): TExprNode;\r\nbegin\r\n Result := AddNode(TExprCallTernaryVmNode.Create(AFunc, X, Y, Z));\r\nend;\r\n\r\nfunction TExprVirtMachNodeFactory.CallTernary32Func(AFunc: TTernary32Func; X, Y, Z: TExprNode): TExprNode;\r\nbegin\r\n Result := AddNode(TExprCallTernary32VmNode.Create(AFunc, X, Y, Z));\r\nend;\r\n\r\nfunction TExprVirtMachNodeFactory.CallTernary64Func(AFunc: TTernary64Func; X, Y, Z: TExprNode): TExprNode;\r\nbegin\r\n Result := AddNode(TExprCallTernary64VmNode.Create(AFunc, X, Y, Z));\r\nend;\r\n\r\n{$IFDEF SUPPORTS_EXTENDED}\r\nfunction TExprVirtMachNodeFactory.CallTernary80Func(AFunc: TTernary80Func; X, Y, Z: TExprNode): TExprNode;\r\nbegin\r\n Result := AddNode(TExprCallTernary80VmNode.Create(AFunc, X, Y, Z));\r\nend;\r\n{$ENDIF SUPPORTS_EXTENDED}\r\n\r\nfunction TExprVirtMachNodeFactory.Compare(ALeft, ARight: TExprNode): TExprNode;\r\nbegin\r\n Result := AddNode(TExprBinaryVmNode.Create(TExprCompareVmOp, [ALeft, ARight]));\r\nend;\r\n\r\nfunction TExprVirtMachNodeFactory.CompareEqual(ALeft, ARight: TExprNode): TExprNode;\r\nbegin\r\n Result := AddNode(TExprBinaryVmNode.Create(TExprEqualVmOp, [ALeft, ARight]));\r\nend;\r\n\r\nfunction TExprVirtMachNodeFactory.CompareNotEqual(ALeft, ARight: TExprNode): TExprNode;\r\nbegin\r\n Result := AddNode(TExprBinaryVmNode.Create(TExprNotEqualVmOp, [ALeft, ARight]));\r\nend;\r\n\r\nfunction TExprVirtMachNodeFactory.CompareLess(ALeft, ARight: TExprNode): TExprNode;\r\nbegin\r\n Result := AddNode(TExprBinaryVmNode.Create(TExprLessVmOp, [ALeft, ARight]));\r\nend;\r\n\r\nfunction TExprVirtMachNodeFactory.CompareLessEqual(ALeft, ARight: TExprNode): TExprNode;\r\nbegin\r\n Result := AddNode(TExprBinaryVmNode.Create(TExprLessEqualVmOp, [ALeft, ARight]));\r\nend;\r\n\r\nfunction TExprVirtMachNodeFactory.CompareGreater(ALeft, ARight: TExprNode): TExprNode;\r\nbegin\r\n Result := AddNode(TExprBinaryVmNode.Create(TExprGreaterVmOp, [ALeft, ARight]));\r\nend;\r\n\r\nfunction TExprVirtMachNodeFactory.CompareGreaterEqual(ALeft, ARight: TExprNode): TExprNode;\r\nbegin\r\n Result := AddNode(TExprBinaryVmNode.Create(TExprGreaterEqualVmOp, [ALeft, ARight]));\r\nend;\r\n\r\nfunction TExprVirtMachNodeFactory.LogicalAnd(ALeft, ARight: TExprNode): TExprNode;\r\nbegin\r\n Result := AddNode(TExprBinaryVmNode.Create(TExprLogicalAndVmOp, [ALeft, ARight]));\r\nend;\r\n\r\nfunction TExprVirtMachNodeFactory.LogicalOr(ALeft, ARight: TExprNode): TExprNode;\r\nbegin\r\n Result := AddNode(TExprBinaryVmNode.Create(TExprLogicalOrVmOp, [ALeft, ARight]));\r\nend;\r\n\r\nfunction TExprVirtMachNodeFactory.LogicalXor(ALeft, ARight: TExprNode): TExprNode;\r\nbegin\r\n Result := AddNode(TExprBinaryVmNode.Create(TExprLogicalXorVmOp, [ALeft, ARight]));\r\nend;\r\n\r\nfunction TExprVirtMachNodeFactory.LogicalNot(AValue: TExprNode): TExprNode;\r\nbegin\r\n Result := AddNode(TExprUnaryVmNode.Create(TExprLogicalNotVmOp, [AValue]));\r\nend;\r\n\r\nfunction TExprVirtMachNodeFactory.BitwiseAnd(ALeft, ARight: TExprNode): TExprNode;\r\nbegin\r\n Result := AddNode(TExprBinaryVmNode.Create(TExprBitwiseAndVmOp, [ALeft, ARight]));\r\nend;\r\n\r\nfunction TExprVirtMachNodeFactory.BitwiseOr(ALeft, ARight: TExprNode): TExprNode;\r\nbegin\r\n Result := AddNode(TExprBinaryVmNode.Create(TExprBitwiseOrVmOp, [ALeft, ARight]));\r\nend;\r\n\r\nfunction TExprVirtMachNodeFactory.BitwiseXor(ALeft, ARight: TExprNode): TExprNode;\r\nbegin\r\n Result := AddNode(TExprBinaryVmNode.Create(TExprBitwiseXorVmOp, [ALeft, ARight]));\r\nend;\r\n\r\nfunction TExprVirtMachNodeFactory.BitwiseNot(AValue: TExprNode): TExprNode;\r\nbegin\r\n Result := AddNode(TExprUnaryVmNode.Create(TExprBitwiseNotVmOp, [AValue]));\r\nend;\r\n\r\nfunction TExprVirtMachNodeFactory.ShiftLeft(ALeft, ARight: TExprNode): TExprNode;\r\nbegin\r\n Result := AddNode(TExprBinaryVmNode.Create(TExprShiftLeftVmOp, [ALeft, ARight]));\r\nend;\r\n\r\nfunction TExprVirtMachNodeFactory.ShiftRight(ALeft, ARight: TExprNode): TExprNode;\r\nbegin\r\n Result := AddNode(TExprBinaryVmNode.Create(TExprShiftRightVmOp, [ALeft, ARight]));\r\nend;\r\n\r\n//=== { TCompiledEvaluator } =================================================\r\n\r\nconstructor TCompiledEvaluator.Create;\r\nbegin\r\n inherited Create;\r\n FVirtMach := TExprVirtMach.Create;\r\nend;\r\n\r\ndestructor TCompiledEvaluator.Destroy;\r\nbegin\r\n FVirtMach.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TCompiledEvaluator.Compile(const AExpr: string);\r\nvar\r\n Lex: TExprSimpleLexer;\r\n Parse: TExprCompileParser;\r\n NodeFactory: TExprVirtMachNodeFactory;\r\nbegin\r\n if AExpr <> FExpr then\r\n begin\r\n FExpr := AExpr;\r\n FVirtMach.Clear;\r\n\r\n Parse := nil;\r\n NodeFactory := nil;\r\n Lex := TExprSimpleLexer.Create(FExpr);\r\n try\r\n NodeFactory := TExprVirtMachNodeFactory.Create;\r\n Parse := TExprCompileParser.Create(Lex, NodeFactory);\r\n Parse.Context := InternalContextSet;\r\n Parse.Compile;\r\n NodeFactory.GenCode(FVirtMach);\r\n finally\r\n Parse.Free;\r\n NodeFactory.Free;\r\n Lex.Free;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TCompiledEvaluator.Evaluate: TFloat;\r\nbegin\r\n Result := FVirtMach.Execute;\r\nend;\r\n\r\n//=== { TExprVar32Sym } ======================================================\r\n\r\nconstructor TExprVar32Sym.Create(const AIdent: string; ALoc: PFloat32);\r\nbegin\r\n Assert(ALoc <> nil);\r\n FLoc := ALoc;\r\n inherited Create(AIdent);\r\nend;\r\n\r\nfunction TExprVar32Sym.Compile: TExprNode;\r\nbegin\r\n Result := NodeFactory.LoadVar32(FLoc);\r\nend;\r\n\r\nfunction TExprVar32Sym.Evaluate: TFloat;\r\nbegin\r\n Result := FLoc^;\r\nend;\r\n\r\n//=== { TExprVar64Sym } ======================================================\r\n\r\nconstructor TExprVar64Sym.Create(const AIdent: string; ALoc: PFloat64);\r\nbegin\r\n Assert(ALoc <> nil);\r\n FLoc := ALoc;\r\n inherited Create(AIdent);\r\nend;\r\n\r\nfunction TExprVar64Sym.Compile: TExprNode;\r\nbegin\r\n Result := NodeFactory.LoadVar64(FLoc);\r\nend;\r\n\r\nfunction TExprVar64Sym.Evaluate: TFloat;\r\nbegin\r\n Result := FLoc^;\r\nend;\r\n\r\n{$IFDEF SUPPORTS_EXTENDED}\r\n\r\n//=== { TExprVar80Sym } ======================================================\r\n\r\nconstructor TExprVar80Sym.Create(const AIdent: string; ALoc: PFloat80);\r\nbegin\r\n Assert(ALoc <> nil);\r\n FLoc := ALoc;\r\n inherited Create(AIdent);\r\nend;\r\n\r\nfunction TExprVar80Sym.Compile: TExprNode;\r\nbegin\r\n Result := NodeFactory.LoadVar80(FLoc);\r\nend;\r\n\r\nfunction TExprVar80Sym.Evaluate: TFloat;\r\nbegin\r\n Result := FLoc^;\r\nend;\r\n\r\n{$ENDIF SUPPORTS_EXTENDED}\r\n\r\n//=== { TExprCallFloatVmNode } ===============================================\r\n\r\nconstructor TExprCallFloatVmNode.Create(AFunc: TFloatFunc);\r\nbegin\r\n FFunc := AFunc;\r\n inherited Create([]);\r\nend;\r\n\r\nprocedure TExprCallFloatVmNode.GenCode(AVirtMach: TExprVirtMach);\r\nbegin\r\n FExprVmCode := TExprCallFloatVmOp.Create(FFunc);\r\n AVirtMach.Add(FExprVmCode);\r\nend;\r\n\r\n//=== { TExprCallFloat32VmNode } =============================================\r\n\r\nconstructor TExprCallFloat32VmNode.Create(AFunc: TFloat32Func);\r\nbegin\r\n FFunc := AFunc;\r\n inherited Create([]);\r\nend;\r\n\r\nprocedure TExprCallFloat32VmNode.GenCode(AVirtMach: TExprVirtMach);\r\nbegin\r\n FExprVmCode := TExprCallFloat32VmOp.Create(FFunc);\r\n AVirtMach.Add(FExprVmCode);\r\nend;\r\n\r\n//=== { TExprCallFloat64VmNode } =============================================\r\n\r\nconstructor TExprCallFloat64VmNode.Create(AFunc: TFloat64Func);\r\nbegin\r\n FFunc := AFunc;\r\n inherited Create([]);\r\nend;\r\n\r\nprocedure TExprCallFloat64VmNode.GenCode(AVirtMach: TExprVirtMach);\r\nbegin\r\n FExprVmCode := TExprCallFloat64VmOp.Create(FFunc);\r\n AVirtMach.Add(FExprVmCode);\r\nend;\r\n\r\n{$IFDEF SUPPORTS_EXTENDED}\r\n\r\n//=== { TExprCallFloat80VmNode } =============================================\r\n\r\nconstructor TExprCallFloat80VmNode.Create(AFunc: TFloat80Func);\r\nbegin\r\n FFunc := AFunc;\r\n inherited Create([]);\r\nend;\r\n\r\nprocedure TExprCallFloat80VmNode.GenCode(AVirtMach: TExprVirtMach);\r\nbegin\r\n FExprVmCode := TExprCallFloat80VmOp.Create(FFunc);\r\n AVirtMach.Add(FExprVmCode);\r\nend;\r\n\r\n{$ENDIF SUPPORTS_EXTENDED}\r\n\r\n//=== { TExprCallUnaryVmNode } ===============================================\r\n\r\nconstructor TExprCallUnaryVmNode.Create(AFunc: TUnaryFunc; X: TExprNode);\r\nbegin\r\n FFunc := AFunc;\r\n inherited Create([X]);\r\nend;\r\n\r\nprocedure TExprCallUnaryVmNode.GenCode(AVirtMach: TExprVirtMach);\r\nbegin\r\n FExprVmCode := TExprCallUnaryVmOp.Create(\r\n FFunc,\r\n VmDeps[0].ExprVmCode.OutputLoc);\r\n AVirtMach.Add(FExprVmCode);\r\nend;\r\n\r\n//=== { TExprCallUnary32VmNode } =============================================\r\n\r\nconstructor TExprCallUnary32VmNode.Create(AFunc: TUnary32Func; X: TExprNode);\r\nbegin\r\n FFunc := AFunc;\r\n inherited Create([X]);\r\nend;\r\n\r\nprocedure TExprCallUnary32VmNode.GenCode(AVirtMach: TExprVirtMach);\r\nbegin\r\n FExprVmCode := TExprCallUnary32VmOp.Create(\r\n FFunc,\r\n VmDeps[0].ExprVmCode.OutputLoc);\r\n AVirtMach.Add(FExprVmCode);\r\nend;\r\n\r\n//=== { TExprCallUnary64VmNode } =============================================\r\n\r\nconstructor TExprCallUnary64VmNode.Create(AFunc: TUnary64Func; X: TExprNode);\r\nbegin\r\n FFunc := AFunc;\r\n inherited Create([X]);\r\nend;\r\n\r\nprocedure TExprCallUnary64VmNode.GenCode(AVirtMach: TExprVirtMach);\r\nbegin\r\n FExprVmCode := TExprCallUnary64VmOp.Create(\r\n FFunc,\r\n VmDeps[0].ExprVmCode.OutputLoc);\r\n AVirtMach.Add(FExprVmCode);\r\nend;\r\n\r\n{$IFDEF SUPPORTS_EXTENDED}\r\n\r\n//=== { TExprCallUnary80VmNode } =============================================\r\n\r\nconstructor TExprCallUnary80VmNode.Create(AFunc: TUnary80Func; X: TExprNode);\r\nbegin\r\n FFunc := AFunc;\r\n inherited Create([X]);\r\nend;\r\n\r\nprocedure TExprCallUnary80VmNode.GenCode(AVirtMach: TExprVirtMach);\r\nbegin\r\n FExprVmCode := TExprCallUnary80VmOp.Create(\r\n FFunc,\r\n VmDeps[0].ExprVmCode.OutputLoc);\r\n AVirtMach.Add(FExprVmCode);\r\nend;\r\n\r\n{$ENDIF SUPPORTS_EXTENDED}\r\n\r\n//=== { TExprCallBinaryVmNode } ==============================================\r\n\r\nconstructor TExprCallBinaryVmNode.Create(AFunc: TBinaryFunc; X, Y: TExprNode);\r\nbegin\r\n FFunc := AFunc;\r\n inherited Create([X, Y]);\r\nend;\r\n\r\nprocedure TExprCallBinaryVmNode.GenCode(AVirtMach: TExprVirtMach);\r\nbegin\r\n FExprVmCode := TExprCallBinaryVmOp.Create(\r\n FFunc,\r\n VmDeps[0].ExprVmCode.OutputLoc,\r\n VmDeps[1].ExprVmCode.OutputLoc);\r\n AVirtMach.Add(FExprVmCode);\r\nend;\r\n\r\n//=== { TExprCallBinary32VmNode } ============================================\r\n\r\nconstructor TExprCallBinary32VmNode.Create(AFunc: TBinary32Func; X, Y: TExprNode);\r\nbegin\r\n FFunc := AFunc;\r\n inherited Create([X, Y]);\r\nend;\r\n\r\nprocedure TExprCallBinary32VmNode.GenCode(AVirtMach: TExprVirtMach);\r\nbegin\r\n FExprVmCode := TExprCallBinary32VmOp.Create(\r\n FFunc,\r\n VmDeps[0].ExprVmCode.OutputLoc,\r\n VmDeps[1].ExprVmCode.OutputLoc);\r\n AVirtMach.Add(FExprVmCode);\r\nend;\r\n\r\n//=== { TExprCallBinary64VmNode } ============================================\r\n\r\nconstructor TExprCallBinary64VmNode.Create(AFunc: TBinary64Func; X, Y: TExprNode);\r\nbegin\r\n FFunc := AFunc;\r\n inherited Create([X, Y]);\r\nend;\r\n\r\nprocedure TExprCallBinary64VmNode.GenCode(AVirtMach: TExprVirtMach);\r\nbegin\r\n FExprVmCode := TExprCallBinary64VmOp.Create(\r\n FFunc,\r\n VmDeps[0].ExprVmCode.OutputLoc,\r\n VmDeps[1].ExprVmCode.OutputLoc);\r\n AVirtMach.Add(FExprVmCode);\r\nend;\r\n\r\n{$IFDEF SUPPORTS_EXTENDED}\r\n\r\n//=== { TExprCallBinary80VmNode } ============================================\r\n\r\nconstructor TExprCallBinary80VmNode.Create(AFunc: TBinary80Func; X, Y: TExprNode);\r\nbegin\r\n FFunc := AFunc;\r\n inherited Create([X, Y]);\r\nend;\r\n\r\nprocedure TExprCallBinary80VmNode.GenCode(AVirtMach: TExprVirtMach);\r\nbegin\r\n FExprVmCode := TExprCallBinary80VmOp.Create(\r\n FFunc,\r\n VmDeps[0].ExprVmCode.OutputLoc,\r\n VmDeps[1].ExprVmCode.OutputLoc);\r\n AVirtMach.Add(FExprVmCode);\r\nend;\r\n\r\n{$ENDIF SUPPORTS_EXTENDED}\r\n\r\n//=== { TExprCallTernaryVmNode } =============================================\r\n\r\nconstructor TExprCallTernaryVmNode.Create(AFunc: TTernaryFunc; X, Y, Z: TExprNode);\r\nbegin\r\n FFunc := AFunc;\r\n inherited Create([X, Y, Z]);\r\nend;\r\n\r\nprocedure TExprCallTernaryVmNode.GenCode(AVirtMach: TExprVirtMach);\r\nbegin\r\n FExprVmCode := TExprCallTernaryVmOp.Create(\r\n FFunc,\r\n VmDeps[0].ExprVmCode.OutputLoc,\r\n VmDeps[1].ExprVmCode.OutputLoc,\r\n VmDeps[2].ExprVmCode.OutputLoc);\r\n AVirtMach.Add(FExprVmCode);\r\nend;\r\n\r\n//=== { TExprCallTernary32VmNode } ===========================================\r\n\r\nconstructor TExprCallTernary32VmNode.Create(AFunc: TTernary32Func; X, Y, Z: TExprNode);\r\nbegin\r\n FFunc := AFunc;\r\n inherited Create([X, Y, Z]);\r\nend;\r\n\r\nprocedure TExprCallTernary32VmNode.GenCode(AVirtMach: TExprVirtMach);\r\nbegin\r\n FExprVmCode := TExprCallTernary32VmOp.Create(\r\n FFunc,\r\n VmDeps[0].ExprVmCode.OutputLoc,\r\n VmDeps[1].ExprVmCode.OutputLoc,\r\n VmDeps[2].ExprVmCode.OutputLoc);\r\n AVirtMach.Add(FExprVmCode);\r\nend;\r\n\r\n//=== { TExprCallTernary64VmNode } ===========================================\r\n\r\nconstructor TExprCallTernary64VmNode.Create(AFunc: TTernary64Func; X, Y, Z: TExprNode);\r\nbegin\r\n FFunc := AFunc;\r\n inherited Create([X, Y, Z]);\r\nend;\r\n\r\nprocedure TExprCallTernary64VmNode.GenCode(AVirtMach: TExprVirtMach);\r\nbegin\r\n FExprVmCode := TExprCallTernary64VmOp.Create(\r\n FFunc,\r\n VmDeps[0].ExprVmCode.OutputLoc,\r\n VmDeps[1].ExprVmCode.OutputLoc,\r\n VmDeps[2].ExprVmCode.OutputLoc);\r\n AVirtMach.Add(FExprVmCode);\r\nend;\r\n\r\n{$IFDEF SUPPORTS_EXTENDED}\r\n\r\n//=== { TExprCallTernary80VmNode } ===========================================\r\n\r\nconstructor TExprCallTernary80VmNode.Create(AFunc: TTernary80Func; X, Y, Z: TExprNode);\r\nbegin\r\n FFunc := AFunc;\r\n inherited Create([X, Y, Z]);\r\nend;\r\n\r\nprocedure TExprCallTernary80VmNode.GenCode(AVirtMach: TExprVirtMach);\r\nbegin\r\n FExprVmCode := TExprCallTernary80VmOp.Create(\r\n FFunc,\r\n VmDeps[0].ExprVmCode.OutputLoc,\r\n VmDeps[1].ExprVmCode.OutputLoc,\r\n VmDeps[2].ExprVmCode.OutputLoc);\r\n AVirtMach.Add(FExprVmCode);\r\nend;\r\n\r\n{$ENDIF SUPPORTS_EXTENDED}\r\n\r\n//=== { TExprAbstractFuncSym } ===============================================\r\n\r\nfunction TExprAbstractFuncSym.CompileFirstArg: TExprNode;\r\nbegin\r\n if Lexer.CurrTok <> etLParen then\r\n raise EJclExprEvalError.CreateRes(@RsExprEvalFirstArg);\r\n Result := CompileParser.CompileExprLevel0(True);\r\nend;\r\n\r\nfunction TExprAbstractFuncSym.CompileNextArg: TExprNode;\r\nbegin\r\n if Lexer.CurrTok <> etComma then\r\n raise EJclExprEvalError.CreateRes(@RsExprEvalNextArg);\r\n Result := CompileParser.CompileExprLevel0(True);\r\nend;\r\n\r\nfunction TExprAbstractFuncSym.EvalFirstArg: TFloat;\r\nbegin\r\n if Lexer.CurrTok <> etLParen then\r\n raise EJclExprEvalError.CreateRes(@RsExprEvalFirstArg);\r\n Result := EvalParser.EvalExprLevel0(True);\r\nend;\r\n\r\nfunction TExprAbstractFuncSym.EvalNextArg: TFloat;\r\nbegin\r\n if Lexer.CurrTok <> etComma then\r\n raise EJclExprEvalError.CreateRes(@RsExprEvalNextArg);\r\n Result := EvalParser.EvalExprLevel0(True);\r\nend;\r\n\r\nprocedure TExprAbstractFuncSym.EndArgs;\r\nbegin\r\n if Lexer.CurrTok <> etRParen then\r\n raise EJclExprEvalError.CreateRes(@RsExprEvalEndArgs);\r\n Lexer.NextTok;\r\nend;\r\n\r\n//=== { TExprFuncSym } =======================================================\r\n\r\nconstructor TExprFuncSym.Create(const AIdent: string; AFunc: TFloatFunc);\r\nbegin\r\n Assert(Assigned(AFunc));\r\n inherited Create(AIdent);\r\n FFunc := AFunc;\r\nend;\r\n\r\nfunction TExprFuncSym.Compile: TExprNode;\r\nbegin\r\n Result := NodeFactory.CallFloatFunc(FFunc);\r\nend;\r\n\r\nfunction TExprFuncSym.Evaluate: TFloat;\r\nbegin\r\n Result := FFunc;\r\nend;\r\n\r\n//=== { TExprFloat32FuncSym } ================================================\r\n\r\nconstructor TExprFloat32FuncSym.Create(const AIdent: string; AFunc: TFloat32Func);\r\nbegin\r\n Assert(Assigned(AFunc));\r\n inherited Create(AIdent);\r\n FFunc := AFunc;\r\nend;\r\n\r\nfunction TExprFloat32FuncSym.Compile: TExprNode;\r\nbegin\r\n Result := NodeFactory.CallFloat32Func(FFunc);\r\nend;\r\n\r\nfunction TExprFloat32FuncSym.Evaluate: TFloat;\r\nbegin\r\n Result := FFunc;\r\nend;\r\n\r\n//=== { TExprFloat64FuncSym } ================================================\r\n\r\nconstructor TExprFloat64FuncSym.Create(const AIdent: string; AFunc: TFloat64Func);\r\nbegin\r\n Assert(Assigned(AFunc));\r\n inherited Create(AIdent);\r\n FFunc := AFunc;\r\nend;\r\n\r\nfunction TExprFloat64FuncSym.Compile: TExprNode;\r\nbegin\r\n Result := NodeFactory.CallFloat64Func(FFunc);\r\nend;\r\n\r\nfunction TExprFloat64FuncSym.Evaluate: TFloat;\r\nbegin\r\n Result := FFunc;\r\nend;\r\n\r\n{$IFDEF SUPPORTS_EXTENDED}\r\n\r\n//=== { TExprFloat80FuncSym } ================================================\r\n\r\nconstructor TExprFloat80FuncSym.Create(const AIdent: string; AFunc: TFloat80Func);\r\nbegin\r\n Assert(Assigned(AFunc));\r\n inherited Create(AIdent);\r\n FFunc := AFunc;\r\nend;\r\n\r\nfunction TExprFloat80FuncSym.Compile: TExprNode;\r\nbegin\r\n Result := NodeFactory.CallFloat80Func(FFunc);\r\nend;\r\n\r\nfunction TExprFloat80FuncSym.Evaluate: TFloat;\r\nbegin\r\n Result := FFunc;\r\nend;\r\n\r\n{$ENDIF SUPPORTS_EXTENDED}\r\n\r\n//=== { TExprUnaryFuncSym } ==================================================\r\n\r\nconstructor TExprUnaryFuncSym.Create(const AIdent: string; AFunc: TUnaryFunc);\r\nbegin\r\n Assert(Assigned(AFunc));\r\n inherited Create(AIdent);\r\n FFunc := AFunc;\r\nend;\r\n\r\nfunction TExprUnaryFuncSym.Compile: TExprNode;\r\nvar\r\n X: TExprNode;\r\nbegin\r\n X := CompileFirstArg;\r\n EndArgs;\r\n Result := NodeFactory.CallUnaryFunc(FFunc, X);\r\nend;\r\n\r\nfunction TExprUnaryFuncSym.Evaluate: TFloat;\r\nvar\r\n X: TFloat;\r\nbegin\r\n X := EvalFirstArg;\r\n EndArgs;\r\n Result := FFunc(X);\r\nend;\r\n\r\n//=== { TExprUnary32FuncSym } ================================================\r\n\r\nconstructor TExprUnary32FuncSym.Create(const AIdent: string; AFunc: TUnary32Func);\r\nbegin\r\n Assert(Assigned(AFunc));\r\n inherited Create(AIdent);\r\n FFunc := AFunc;\r\nend;\r\n\r\nfunction TExprUnary32FuncSym.Compile: TExprNode;\r\nvar\r\n X: TExprNode;\r\nbegin\r\n X := CompileFirstArg;\r\n EndArgs;\r\n Result := NodeFactory.CallUnary32Func(FFunc, X);\r\nend;\r\n\r\nfunction TExprUnary32FuncSym.Evaluate: TFloat;\r\nvar\r\n X: TFloat;\r\nbegin\r\n X := EvalFirstArg;\r\n EndArgs;\r\n Result := FFunc(X);\r\nend;\r\n\r\n//=== { TExprUnary64FuncSym } ================================================\r\n\r\nconstructor TExprUnary64FuncSym.Create(const AIdent: string; AFunc: TUnary64Func);\r\nbegin\r\n Assert(Assigned(AFunc));\r\n inherited Create(AIdent);\r\n FFunc := AFunc;\r\nend;\r\n\r\nfunction TExprUnary64FuncSym.Compile: TExprNode;\r\nvar\r\n X: TExprNode;\r\nbegin\r\n X := CompileFirstArg;\r\n EndArgs;\r\n Result := NodeFactory.CallUnary64Func(FFunc, X);\r\nend;\r\n\r\nfunction TExprUnary64FuncSym.Evaluate: TFloat;\r\nvar\r\n X: TFloat;\r\nbegin\r\n X := EvalFirstArg;\r\n EndArgs;\r\n Result := FFunc(X);\r\nend;\r\n\r\n{$IFDEF SUPPORTS_EXTENDED}\r\n\r\n//=== { TExprUnary80FuncSym } ================================================\r\n\r\nconstructor TExprUnary80FuncSym.Create(const AIdent: string; AFunc: TUnary80Func);\r\nbegin\r\n Assert(Assigned(AFunc));\r\n inherited Create(AIdent);\r\n FFunc := AFunc;\r\nend;\r\n\r\nfunction TExprUnary80FuncSym.Compile: TExprNode;\r\nvar\r\n X: TExprNode;\r\nbegin\r\n X := CompileFirstArg;\r\n EndArgs;\r\n Result := NodeFactory.CallUnary80Func(FFunc, X);\r\nend;\r\n\r\nfunction TExprUnary80FuncSym.Evaluate: TFloat;\r\nvar\r\n X: TFloat;\r\nbegin\r\n X := EvalFirstArg;\r\n EndArgs;\r\n Result := FFunc(X);\r\nend;\r\n\r\n{$ENDIF SUPPORTS_EXTENDED}\r\n\r\n//=== { TExprBinaryFuncSym } =================================================\r\n\r\nconstructor TExprBinaryFuncSym.Create(const AIdent: string; AFunc: TBinaryFunc);\r\nbegin\r\n Assert(Assigned(AFunc));\r\n inherited Create(AIdent);\r\n FFunc := AFunc;\r\nend;\r\n\r\nfunction TExprBinaryFuncSym.Compile: TExprNode;\r\nvar\r\n X, Y: TExprNode;\r\nbegin\r\n // must be called this way, because evaluation order of function\r\n // parameters is not defined; we need CompileFirstArg to be called\r\n // first.\r\n X := CompileFirstArg;\r\n Y := CompileNextArg;\r\n EndArgs;\r\n Result := NodeFactory.CallBinaryFunc(FFunc, X, Y);\r\nend;\r\n\r\nfunction TExprBinaryFuncSym.Evaluate: TFloat;\r\nvar\r\n X, Y: TFloat;\r\nbegin\r\n X := EvalFirstArg;\r\n Y := EvalNextArg;\r\n EndArgs;\r\n Result := FFunc(X, Y);\r\nend;\r\n\r\n//=== { TExprBinary32FuncSym } ===============================================\r\n\r\nconstructor TExprBinary32FuncSym.Create(const AIdent: string; AFunc: TBinary32Func);\r\nbegin\r\n Assert(Assigned(AFunc));\r\n inherited Create(AIdent);\r\n FFunc := AFunc;\r\nend;\r\n\r\nfunction TExprBinary32FuncSym.Compile: TExprNode;\r\nvar\r\n X, Y: TExprNode;\r\nbegin\r\n X := CompileFirstArg;\r\n Y := CompileNextArg;\r\n EndArgs;\r\n Result := NodeFactory.CallBinary32Func(FFunc, X, Y);\r\nend;\r\n\r\nfunction TExprBinary32FuncSym.Evaluate: TFloat;\r\nvar\r\n X, Y: TFloat;\r\nbegin\r\n X := EvalFirstArg;\r\n Y := EvalNextArg;\r\n EndArgs;\r\n Result := FFunc(X, Y);\r\nend;\r\n\r\n//=== { TExprBinary64FuncSym } ===============================================\r\n\r\nconstructor TExprBinary64FuncSym.Create(const AIdent: string; AFunc: TBinary64Func);\r\nbegin\r\n Assert(Assigned(AFunc));\r\n inherited Create(AIdent);\r\n FFunc := AFunc;\r\nend;\r\n\r\nfunction TExprBinary64FuncSym.Compile: TExprNode;\r\nvar\r\n X, Y: TExprNode;\r\nbegin\r\n X := CompileFirstArg;\r\n Y := CompileNextArg;\r\n EndArgs;\r\n Result := NodeFactory.CallBinary64Func(FFunc, X, Y);\r\nend;\r\n\r\nfunction TExprBinary64FuncSym.Evaluate: TFloat;\r\nvar\r\n X, Y: TFloat;\r\nbegin\r\n X := EvalFirstArg;\r\n Y := EvalNextArg;\r\n EndArgs;\r\n Result := FFunc(X, Y);\r\nend;\r\n\r\n{$IFDEF SUPPORTS_EXTENDED}\r\n\r\n//=== { TExprBinary80FuncSym } ===============================================\r\n\r\nconstructor TExprBinary80FuncSym.Create(const AIdent: string; AFunc: TBinary80Func);\r\nbegin\r\n Assert(Assigned(AFunc));\r\n inherited Create(AIdent);\r\n FFunc := AFunc;\r\nend;\r\n\r\nfunction TExprBinary80FuncSym.Compile: TExprNode;\r\nvar\r\n X, Y: TExprNode;\r\nbegin\r\n X := CompileFirstArg;\r\n Y := CompileNextArg;\r\n EndArgs;\r\n Result := NodeFactory.CallBinary80Func(FFunc, X, Y);\r\nend;\r\n\r\nfunction TExprBinary80FuncSym.Evaluate: TFloat;\r\nvar\r\n X, Y: TFloat;\r\nbegin\r\n X := EvalFirstArg;\r\n Y := EvalNextArg;\r\n EndArgs;\r\n Result := FFunc(X, Y);\r\nend;\r\n\r\n{$ENDIF SUPPORTS_EXTENDED}\r\n\r\n//=== { TExprTernaryFuncSym } ================================================\r\n\r\nconstructor TExprTernaryFuncSym.Create(const AIdent: string; AFunc: TTernaryFunc);\r\nbegin\r\n Assert(Assigned(AFunc));\r\n inherited Create(AIdent);\r\n FFunc := AFunc;\r\nend;\r\n\r\nfunction TExprTernaryFuncSym.Compile: TExprNode;\r\nvar\r\n X, Y, Z: TExprNode;\r\nbegin\r\n X := CompileFirstArg;\r\n Y := CompileNextArg;\r\n Z := CompileNextArg;\r\n EndArgs;\r\n Result := NodeFactory.CallTernaryFunc(FFunc, X, Y, Z);\r\nend;\r\n\r\nfunction TExprTernaryFuncSym.Evaluate: TFloat;\r\nvar\r\n X, Y, Z: TFloat;\r\nbegin\r\n X := EvalFirstArg;\r\n Y := EvalNextArg;\r\n Z := EvalNextArg;\r\n EndArgs;\r\n Result := FFunc(X, Y, Z);\r\nend;\r\n\r\n//=== { TExprTernary32FuncSym } ==============================================\r\n\r\nconstructor TExprTernary32FuncSym.Create(const AIdent: string; AFunc: TTernary32Func);\r\nbegin\r\n Assert(Assigned(AFunc));\r\n inherited Create(AIdent);\r\n FFunc := AFunc;\r\nend;\r\n\r\nfunction TExprTernary32FuncSym.Compile: TExprNode;\r\nvar\r\n X, Y, Z: TExprNode;\r\nbegin\r\n X := CompileFirstArg;\r\n Y := CompileNextArg;\r\n Z := CompileNextArg;\r\n EndArgs;\r\n Result := NodeFactory.CallTernary32Func(FFunc, X, Y, Z);\r\nend;\r\n\r\nfunction TExprTernary32FuncSym.Evaluate: TFloat;\r\nvar\r\n X, Y, Z: TFloat;\r\nbegin\r\n X := EvalFirstArg;\r\n Y := EvalNextArg;\r\n Z := EvalNextArg;\r\n EndArgs;\r\n Result := FFunc(X, Y, Z);\r\nend;\r\n\r\n//=== { TExprTernary64FuncSym } ==============================================\r\n\r\nconstructor TExprTernary64FuncSym.Create(const AIdent: string; AFunc: TTernary64Func);\r\nbegin\r\n Assert(Assigned(AFunc));\r\n inherited Create(AIdent);\r\n FFunc := AFunc;\r\nend;\r\n\r\nfunction TExprTernary64FuncSym.Compile: TExprNode;\r\nvar\r\n X, Y, Z: TExprNode;\r\nbegin\r\n X := CompileFirstArg;\r\n Y := CompileNextArg;\r\n Z := CompileNextArg;\r\n EndArgs;\r\n Result := NodeFactory.CallTernary64Func(FFunc, X, Y, Z);\r\nend;\r\n\r\nfunction TExprTernary64FuncSym.Evaluate: TFloat;\r\nvar\r\n X, Y, Z: TFloat;\r\nbegin\r\n X := EvalFirstArg;\r\n Y := EvalNextArg;\r\n Z := EvalNextArg;\r\n EndArgs;\r\n Result := FFunc(X, Y, Z);\r\nend;\r\n\r\n{$IFDEF SUPPORTS_EXTENDED}\r\n\r\n//=== { TExprTernary80FuncSym } ==============================================\r\n\r\nconstructor TExprTernary80FuncSym.Create(const AIdent: string; AFunc: TTernary80Func);\r\nbegin\r\n Assert(Assigned(AFunc));\r\n inherited Create(AIdent);\r\n FFunc := AFunc;\r\nend;\r\n\r\nfunction TExprTernary80FuncSym.Compile: TExprNode;\r\nvar\r\n X, Y, Z: TExprNode;\r\nbegin\r\n X := CompileFirstArg;\r\n Y := CompileNextArg;\r\n Z := CompileNextArg;\r\n EndArgs;\r\n Result := NodeFactory.CallTernary80Func(FFunc, X, Y, Z);\r\nend;\r\n\r\nfunction TExprTernary80FuncSym.Evaluate: TFloat;\r\nvar\r\n X, Y, Z: TFloat;\r\nbegin\r\n X := EvalFirstArg;\r\n Y := EvalNextArg;\r\n Z := EvalNextArg;\r\n EndArgs;\r\n Result := FFunc(X, Y, Z);\r\nend;\r\n\r\n{$ENDIF SUPPORTS_EXTENDED}\r\n\r\n//=== { TExprConstSym } ======================================================\r\n\r\nconstructor TExprConstSym.Create(const AIdent: string; AValue: TFloat);\r\nbegin\r\n inherited Create(AIdent);\r\n FValue := AValue;\r\nend;\r\n\r\nfunction TExprConstSym.Compile: TExprNode;\r\nbegin\r\n Result := NodeFactory.LoadConst(FValue);\r\nend;\r\n\r\nfunction TExprConstSym.Evaluate: TFloat;\r\nbegin\r\n Result := FValue;\r\nend;\r\n\r\n//=== { TExprConst32Sym } ====================================================\r\n\r\nconstructor TExprConst32Sym.Create(const AIdent: string; AValue: TFloat32);\r\nbegin\r\n inherited Create(AIdent);\r\n FValue := AValue;\r\nend;\r\n\r\nfunction TExprConst32Sym.Compile: TExprNode;\r\nbegin\r\n Result := NodeFactory.LoadConst(FValue);\r\nend;\r\n\r\nfunction TExprConst32Sym.Evaluate: TFloat;\r\nbegin\r\n Result := FValue;\r\nend;\r\n\r\n//=== { TExprConst64Sym } ====================================================\r\n\r\nconstructor TExprConst64Sym.Create(const AIdent: string; AValue: TFloat64);\r\nbegin\r\n inherited Create(AIdent);\r\n FValue := AValue;\r\nend;\r\n\r\nfunction TExprConst64Sym.Compile: TExprNode;\r\nbegin\r\n Result := NodeFactory.LoadConst(FValue);\r\nend;\r\n\r\nfunction TExprConst64Sym.Evaluate: TFloat;\r\nbegin\r\n Result := FValue;\r\nend;\r\n\r\n{$IFDEF SUPPORTS_EXTENDED}\r\n\r\n//=== { TExprConst80Sym } ====================================================\r\n\r\nconstructor TExprConst80Sym.Create(const AIdent: string; AValue: TFloat80);\r\nbegin\r\n inherited Create(AIdent);\r\n FValue := AValue;\r\nend;\r\n\r\nfunction TExprConst80Sym.Compile: TExprNode;\r\nbegin\r\n Result := NodeFactory.LoadConst(FValue);\r\nend;\r\n\r\nfunction TExprConst80Sym.Evaluate: TFloat;\r\nbegin\r\n Result := FValue;\r\nend;\r\n\r\n{$ENDIF SUPPORTS_EXTENDED}\r\n\r\n//=== { TEasyEvaluator } =====================================================\r\n\r\nconstructor TEasyEvaluator.Create;\r\nbegin\r\n inherited Create;\r\n FOwnContext := TExprHashContext.Create(False, cExprEvalHashSize);\r\n FExtContextSet := TExprSetContext.Create(False);\r\n FInternalContextSet := TExprSetContext.Create(False);\r\n\r\n // user added names get precedence over external context's names\r\n FInternalContextSet.Add(FExtContextSet);\r\n FInternalContextSet.Add(FOwnContext);\r\nend;\r\n\r\ndestructor TEasyEvaluator.Destroy;\r\nbegin\r\n FInternalContextSet.Free;\r\n FOwnContext.Free;\r\n FExtContextSet.Free;\r\n inherited Destroy;\r\nend;\r\n\r\n{$IFDEF SUPPORTS_EXTENDED}\r\nprocedure TEasyEvaluator.AddConst(const AName: string; AConst: TFloat80);\r\nbegin\r\n FOwnContext.Add(TExprConst80Sym.Create(AName, AConst));\r\nend;\r\n{$ENDIF SUPPORTS_EXTENDED}\r\n\r\nprocedure TEasyEvaluator.AddConst(const AName: string; AConst: TFloat64);\r\nbegin\r\n FOwnContext.Add(TExprConst64Sym.Create(AName, AConst));\r\nend;\r\n\r\nprocedure TEasyEvaluator.AddConst(const AName: string; AConst: TFloat32);\r\nbegin\r\n FOwnContext.Add(TExprConst32Sym.Create(AName, AConst));\r\nend;\r\n\r\nprocedure TEasyEvaluator.AddVar(const AName: string; var AVar: TFloat32);\r\nbegin\r\n FOwnContext.Add(TExprVar32Sym.Create(AName, @AVar));\r\nend;\r\n\r\nprocedure TEasyEvaluator.AddVar(const AName: string; var AVar: TFloat64);\r\nbegin\r\n FOwnContext.Add(TExprVar64Sym.Create(AName, @AVar));\r\nend;\r\n\r\n{$IFDEF SUPPORTS_EXTENDED}\r\nprocedure TEasyEvaluator.AddVar(const AName: string; var AVar: TFloat80);\r\nbegin\r\n FOwnContext.Add(TExprVar80Sym.Create(AName, @AVar));\r\nend;\r\n{$ENDIF SUPPORTS_EXTENDED}\r\n\r\nprocedure TEasyEvaluator.AddFunc(const AName: string; AFunc: TFloat32Func);\r\nbegin\r\n FOwnContext.Add(TExprFloat32FuncSym.Create(AName, AFunc));\r\nend;\r\n\r\nprocedure TEasyEvaluator.AddFunc(const AName: string; AFunc: TFloat64Func);\r\nbegin\r\n FOwnContext.Add(TExprFloat64FuncSym.Create(AName, AFunc));\r\nend;\r\n\r\n{$IFDEF SUPPORTS_EXTENDED}\r\nprocedure TEasyEvaluator.AddFunc(const AName: string; AFunc: TFloat80Func);\r\nbegin\r\n FOwnContext.Add(TExprFloat80FuncSym.Create(AName, AFunc));\r\nend;\r\n{$ENDIF SUPPORTS_EXTENDED}\r\n\r\nprocedure TEasyEvaluator.AddFunc(const AName: string; AFunc: TUnary32Func);\r\nbegin\r\n FOwnContext.Add(TExprUnary32FuncSym.Create(AName, AFunc));\r\nend;\r\n\r\nprocedure TEasyEvaluator.AddFunc(const AName: string; AFunc: TUnary64Func);\r\nbegin\r\n FOwnContext.Add(TExprUnary64FuncSym.Create(AName, AFunc));\r\nend;\r\n\r\n{$IFDEF SUPPORTS_EXTENDED}\r\nprocedure TEasyEvaluator.AddFunc(const AName: string; AFunc: TUnary80Func);\r\nbegin\r\n FOwnContext.Add(TExprUnary80FuncSym.Create(AName, AFunc));\r\nend;\r\n{$ENDIF SUPPORTS_EXTENDED}\r\n\r\nprocedure TEasyEvaluator.AddFunc(const AName: string; AFunc: TBinary32Func);\r\nbegin\r\n FOwnContext.Add(TExprBinary32FuncSym.Create(AName, AFunc));\r\nend;\r\n\r\nprocedure TEasyEvaluator.AddFunc(const AName: string; AFunc: TBinary64Func);\r\nbegin\r\n FOwnContext.Add(TExprBinary64FuncSym.Create(AName, AFunc));\r\nend;\r\n\r\n{$IFDEF SUPPORTS_EXTENDED}\r\nprocedure TEasyEvaluator.AddFunc(const AName: string; AFunc: TBinary80Func);\r\nbegin\r\n FOwnContext.Add(TExprBinary80FuncSym.Create(AName, AFunc));\r\nend;\r\n{$ENDIF SUPPORTS_EXTENDED}\r\n\r\nprocedure TEasyEvaluator.AddFunc(const AName: string; AFunc: TTernary32Func);\r\nbegin\r\n FOwnContext.Add(TExprTernary32FuncSym.Create(AName, AFunc));\r\nend;\r\n\r\nprocedure TEasyEvaluator.AddFunc(const AName: string; AFunc: TTernary64Func);\r\nbegin\r\n FOwnContext.Add(TExprTernary64FuncSym.Create(AName, AFunc));\r\nend;\r\n\r\n{$IFDEF SUPPORTS_EXTENDED}\r\nprocedure TEasyEvaluator.AddFunc(const AName: string; AFunc: TTernary80Func);\r\nbegin\r\n FOwnContext.Add(TExprTernary80FuncSym.Create(AName, AFunc));\r\nend;\r\n{$ENDIF SUPPORTS_EXTENDED}\r\n\r\nprocedure TEasyEvaluator.Clear;\r\nbegin\r\n FOwnContext.FHashMap.Iterate(nil, Iterate_FreeObjects);\r\n FOwnContext.FHashMap.Clear;\r\nend;\r\n\r\nprocedure TEasyEvaluator.Remove(const AName: string);\r\nbegin\r\n FOwnContext.Remove(AName);\r\nend;\r\n\r\n//=== { TInternalCompiledExpression } ========================================\r\n\r\ntype\r\n TInternalCompiledExpression = class(TObject)\r\n private\r\n FVirtMach: TExprVirtMach;\r\n FRefCount: Integer;\r\n public\r\n constructor Create(AVirtMach: TExprVirtMach);\r\n destructor Destroy; override;\r\n property VirtMach: TExprVirtMach read FVirtMach;\r\n property RefCount: Integer read FRefCount write FRefCount;\r\n end;\r\n\r\nconstructor TInternalCompiledExpression.Create(AVirtMach: TExprVirtMach);\r\nbegin\r\n inherited Create;\r\n FVirtMach := AVirtMach;\r\nend;\r\n\r\ndestructor TInternalCompiledExpression.Destroy;\r\nbegin\r\n FVirtMach.Free;\r\n inherited Destroy;\r\nend;\r\n\r\n//=== { TExpressionCompiler } ================================================\r\n\r\nconstructor TExpressionCompiler.Create;\r\nbegin\r\n FExprHash := TStringHashMap.Create(CaseInsensitiveTraits,\r\n cExprEvalHashSize);\r\n inherited Create;\r\nend;\r\n\r\ndestructor TExpressionCompiler.Destroy;\r\nbegin\r\n FExprHash.Iterate(nil, Iterate_FreeObjects);\r\n FExprHash.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TExpressionCompiler.Compile(const AExpr: string): TCompiledExpression;\r\nvar\r\n Ice: TInternalCompiledExpression;\r\n Vm: TExprVirtMach;\r\n Parser: TExprCompileParser;\r\n Lexer: TExprSimpleLexer;\r\n NodeFactory: TExprVirtMachNodeFactory;\r\nbegin\r\n Ice := nil;\r\n if FExprHash.Find(AExpr, Ice) then\r\n begin\r\n // expression already exists, add reference\r\n Result := Ice.VirtMach.Execute;\r\n Ice.RefCount := Ice.RefCount + 1;\r\n end\r\n else\r\n begin\r\n // compile fresh expression\r\n Parser := nil;\r\n NodeFactory := nil;\r\n Lexer := TExprSimpleLexer.Create(AExpr);\r\n try\r\n NodeFactory := TExprVirtMachNodeFactory.Create;\r\n Parser := TExprCompileParser.Create(Lexer, NodeFactory);\r\n Parser.Context := InternalContextSet;\r\n Parser.Compile;\r\n\r\n Ice := nil;\r\n Vm := TExprVirtMach.Create;\r\n try\r\n NodeFactory.GenCode(Vm);\r\n Ice := TInternalCompiledExpression.Create(Vm);\r\n Ice.RefCount := 1;\r\n FExprHash.Add(AExpr, Ice);\r\n except\r\n Ice.Free;\r\n Vm.Free;\r\n raise;\r\n end;\r\n finally\r\n NodeFactory.Free;\r\n Parser.Free;\r\n Lexer.Free;\r\n end;\r\n\r\n Result := Ice.VirtMach.Execute;\r\n end;\r\nend;\r\n\r\ntype\r\n PIceFindResult = ^TIceFindResult;\r\n TIceFindResult = record\r\n Found: Boolean;\r\n Ce: TCompiledExpression;\r\n Ice: TInternalCompiledExpression;\r\n Expr: string;\r\n end;\r\n\r\nfunction IterateFindIce(AUserData: Pointer; const AStr: string; var APtr: Pointer): Boolean;\r\nvar\r\n PIfr: PIceFindResult;\r\n Ice: TInternalCompiledExpression;\r\n Ce: TCompiledExpression;\r\nbegin\r\n PIfr := AUserData;\r\n Ice := APtr;\r\n Ce := Ice.VirtMach.Execute;\r\n\r\n if (TMethod(PIfr^.Ce).Code = TMethod(Ce).Code) and\r\n (TMethod(PIfr^.Ce).Data = TMethod(Ce).Data) then\r\n begin\r\n PIfr^.Found := True;\r\n PIfr^.Ice := Ice;\r\n PIfr^.Expr := AStr;\r\n Result := False;\r\n end else\r\n Result := True;\r\nend;\r\n\r\nprocedure TExpressionCompiler.Delete(ACompiledExpression: TCompiledExpression);\r\nvar\r\n Ifr: TIceFindResult;\r\nbegin\r\n with Ifr do\r\n begin\r\n Found := False;\r\n Ce := ACompiledExpression;\r\n Ice := nil;\r\n Expr := '';\r\n FExprHash.Iterate(@Ifr, IterateFindIce);\r\n if not Found then\r\n raise EJclExprEvalError.CreateRes(@RsExprEvalExprPtrNotFound);\r\n Remove(Expr);\r\n end;\r\nend;\r\n\r\nprocedure TExpressionCompiler.Remove(const AExpr: string);\r\nvar\r\n Ice: TInternalCompiledExpression;\r\nbegin\r\n Ice := nil;\r\n if not FExprHash.Find(AExpr, Ice) then\r\n raise EJclExprEvalError.CreateResFmt(@RsExprEvalExprNotFound, [AExpr]);\r\n\r\n Ice.RefCount := Ice.RefCount - 1;\r\n Assert(Ice.RefCount >= 0, LoadResString(@RsExprEvalExprRefCountAssertion));\r\n if Ice.RefCount = 0 then\r\n begin\r\n Ice.Free;\r\n FExprHash.Remove(AExpr);\r\n end;\r\nend;\r\n\r\nprocedure TExpressionCompiler.Clear;\r\nbegin\r\n FExprHash.Iterate(nil, Iterate_FreeObjects);\r\n FExprHash.Clear;\r\n inherited Clear;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jcl/source/common/JclFileUtils.pas", "content": "{**************************************************************************************************}\r\n{ }\r\n{ Project JEDI Code Library (JCL) }\r\n{ }\r\n{ The contents of this file are subject to the Mozilla Public License Version 1.1 (the \"License\"); }\r\n{ you may not use this file except in compliance with the License. You may obtain a copy of the }\r\n{ License at http://www.mozilla.org/MPL/ }\r\n{ }\r\n{ Software distributed under the License is distributed on an \"AS IS\" basis, WITHOUT WARRANTY OF }\r\n{ ANY KIND, either express or implied. See the License for the specific language governing rights }\r\n{ and limitations under the License. }\r\n{ }\r\n{ The Original Code is JclFileUtils.pas. }\r\n{ }\r\n{ The Initial Developer of the Original Code is Marcel van Brakel. }\r\n{ Portions created by Marcel van Brakel are Copyright (C) Marcel van Brakel. All rights reserved. }\r\n{ }\r\n{ Contributors: }\r\n{ Andre Snepvangers (asnepvangers) }\r\n{ Andreas Hausladen (ahuser) }\r\n{ Anthony Steele }\r\n{ Rik Barker (rikbarker) }\r\n{ Azret Botash }\r\n{ Charlie Calvert }\r\n{ David Hervieux }\r\n{ Florent Ouchet (outchy) }\r\n{ Jean-Fabien Connault (cycocrew) }\r\n{ Jens Fudickar (jfudickar) }\r\n{ JohnML }\r\n{ John Molyneux }\r\n{ Marcel Bestebroer }\r\n{ Marcel van Brakel }\r\n{ Massimo Maria Ghisalberti }\r\n{ Matthias Thoma (mthoma) }\r\n{ Olivier Sannier (obones) }\r\n{ Pelle F. S. Liljendal }\r\n{ Robert Marquardt (marquardt) }\r\n{ Robert Rossmair (rrossmair) }\r\n{ Rudy Velthuis }\r\n{ Scott Price }\r\n{ Wim De Cleen }\r\n{ }\r\n{**************************************************************************************************}\r\n{ }\r\n{ This unit contains routines and classes for working with files, directories and path strings. }\r\n{ Additionally it contains wrapper classes for file mapping objects and version resources. }\r\n{ Generically speaking, everything that has to do with files and directories. Note that filesystem }\r\n{ specific functionality has been extracted into external units, for example JclNTFS which }\r\n{ contains NTFS specific utility routines, and that the JclShell unit contains some file related }\r\n{ routines as well but they are specific to the Windows shell. }\r\n{ }\r\n{**************************************************************************************************}\r\n{ }\r\n{ Last modified: $Date:: 2012-09-04 16:08:04 +0200 (mar. 04 sept. 2012) $ }\r\n{ Revision: $Rev:: 3861 $ }\r\n{ Author: $Author:: outchy $ }\r\n{ }\r\n{**************************************************************************************************}\r\n\r\nunit JclFileUtils;\r\n\r\n{$I jcl.inc}\r\n{$I crossplatform.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n {$IFDEF HAS_UNIT_LIBC}\r\n Libc,\r\n {$ENDIF HAS_UNIT_LIBC}\r\n {$IFDEF HAS_UNITSCOPE}\r\n {$IFDEF MSWINDOWS}\r\n Winapi.Windows, JclWin32,\r\n {$ENDIF MSWINDOWS}\r\n System.Classes, System.SysUtils,\r\n {$ELSE ~HAS_UNITSCOPE}\r\n {$IFDEF MSWINDOWS}\r\n Windows, JclWin32,\r\n {$ENDIF MSWINDOWS}\r\n Classes, SysUtils,\r\n {$ENDIF ~HAS_UNITSCOPE}\r\n JclBase, JclSysUtils;\r\n\r\n// Path Manipulation\r\n//\r\n// Various support routines for working with path strings. For example, building a path from\r\n// elements or extracting the elements from a path, interpretation of paths and transformations of\r\n// paths.\r\nconst\r\n {$IFDEF UNIX}\r\n // renamed to DirDelimiter\r\n // PathSeparator = '/';\r\n DirDelimiter = '/';\r\n DirSeparator = ':';\r\n {$ENDIF UNIX}\r\n {$IFDEF MSWINDOWS}\r\n PathDevicePrefix = '\\\\.\\';\r\n // renamed to DirDelimiter\r\n // PathSeparator = '\\';\r\n DirDelimiter = '\\';\r\n DirSeparator = ';';\r\n PathUncPrefix = '\\\\';\r\n {$ENDIF MSWINDOWS}\r\n\r\n faSymLink = $00000040 {$IFDEF SUPPORTS_PLATFORM} platform {$ENDIF}; // defined since D7\r\n faNormalFile = $00000080;\r\n faTemporary = $00000100 {$IFDEF SUPPORTS_PLATFORM} platform {$ENDIF};\r\n faSparseFile = $00000200 {$IFDEF SUPPORTS_PLATFORM} platform {$ENDIF};\r\n faReparsePoint = $00000400 {$IFDEF SUPPORTS_PLATFORM} platform {$ENDIF};\r\n faCompressed = $00000800 {$IFDEF SUPPORTS_PLATFORM} platform {$ENDIF};\r\n faOffline = $00001000 {$IFDEF SUPPORTS_PLATFORM} platform {$ENDIF};\r\n faNotContentIndexed = $00002000 {$IFDEF SUPPORTS_PLATFORM} platform {$ENDIF};\r\n faEncrypted = $00004000 {$IFDEF SUPPORTS_PLATFORM} platform {$ENDIF};\r\n\r\n // Note: faVolumeID is potentially dangerous and its usage has been discontinued\r\n // Please see QC report 6003 for details, available online at this URL:\r\n // http://qc.embarcadero.com/wc/qcmain.aspx?d=6003\r\n faRejectedByDefault = faHidden + faSysFile + faDirectory;\r\n faWindowsSpecific = faArchive + faTemporary + faSparseFile + faReparsePoint +\r\n faCompressed + faOffline + faNotContentIndexed + faEncrypted;\r\n faUnixSpecific = faSymLink;\r\n\r\ntype\r\n TCompactPath = ({cpBegin, }cpCenter, cpEnd);\r\n\r\nfunction CharIsDriveLetter(const C: char): Boolean;\r\n\r\nfunction PathAddSeparator(const Path: string): string;\r\nfunction PathAddExtension(const Path, Extension: string): string;\r\nfunction PathAppend(const Path, Append: string): string;\r\nfunction PathBuildRoot(const Drive: Byte): string;\r\nfunction PathCanonicalize(const Path: string): string;\r\nfunction PathCommonPrefix(const Path1, Path2: string): Integer;\r\n{$IFDEF MSWINDOWS}\r\nfunction PathCompactPath(const DC: HDC; const Path: string; const Width: Integer;\r\n CmpFmt: TCompactPath): string;\r\n{$ENDIF MSWINDOWS}\r\nprocedure PathExtractElements(const Source: string; var Drive, Path, FileName, Ext: string);\r\nfunction PathExtractFileDirFixed(const S: string): string;\r\nfunction PathExtractFileNameNoExt(const Path: string): string;\r\nfunction PathExtractPathDepth(const Path: string; Depth: Integer): string;\r\nfunction PathGetDepth(const Path: string): Integer;\r\n{$IFDEF MSWINDOWS}\r\nfunction PathGetLongName(const Path: string): string;\r\nfunction PathGetShortName(const Path: string): string;\r\n{$ENDIF MSWINDOWS}\r\nfunction PathGetRelativePath(Origin, Destination: string): string;\r\nfunction PathGetTempPath: string;\r\nfunction PathIsAbsolute(const Path: string): Boolean;\r\nfunction PathIsChild(const Path, Base: string): Boolean;\r\nfunction PathIsEqualOrChild(const Path, Base: string): Boolean;\r\nfunction PathIsDiskDevice(const Path: string): Boolean;\r\nfunction PathIsUNC(const Path: string): Boolean;\r\nfunction PathRemoveSeparator(const Path: string): string;\r\nfunction PathRemoveExtension(const Path: string): string;\r\n\r\n// Windows Vista uses localized path names in the Windows Explorer but these\r\n// folders do not really exist on disk. This causes all I/O operations to fail\r\n// if the user specifies such a localized directory like \"C:\\Benutzer\\MyName\\Bilder\"\r\n// instead of the physical folder \"C:\\Users\\MyName\\Pictures\".\r\n// These two functions allow to convert the user's input from localized to\r\n// physical paths and vice versa.\r\nfunction PathGetPhysicalPath(const LocalizedPath: string): string;\r\nfunction PathGetLocalizedPath(const PhysicalPath: string): string;\r\n\r\n// Files and Directories\r\n//\r\n// Routines for working with files and directories. Includes routines to extract various file\r\n// attributes or update them, volume locking and routines for creating temporary files.\r\ntype\r\n TDelTreeProgress = function (const FileName: string; Attr: DWORD): Boolean;\r\n TFileListOption = (flFullNames, flRecursive, flMaskedSubfolders);\r\n TFileListOptions = set of TFileListOption;\r\n TJclAttributeMatch = (amAny, amExact, amSubSetOf, amSuperSetOf, amCustom);\r\n TFileMatchFunc = function(const Attr: Integer; const FileInfo: TSearchRec): Boolean;\r\n TFileHandler = procedure (const FileName: string) of object;\r\n TFileHandlerEx = procedure (const Directory: string; const FileInfo: TSearchRec) of object;\r\n TFileInfoHandlerEx = procedure (const FileInfo: TSearchRec) of object;\r\n\r\nfunction BuildFileList(const Path: string; const Attr: Integer; const List: TStrings; IncludeDirectoryName: Boolean =\r\n False): Boolean;\r\nfunction AdvBuildFileList(const Path: string; const Attr: Integer; const Files: TStrings;\r\n const AttributeMatch: TJclAttributeMatch = amSuperSetOf; const Options: TFileListOptions = [];\r\n const SubfoldersMask: string = ''; const FileMatchFunc: TFileMatchFunc = nil): Boolean;\r\nfunction VerifyFileAttributeMask(var RejectedAttributes, RequiredAttributes: Integer): Boolean;\r\nfunction IsFileAttributeMatch(FileAttributes, RejectedAttributes,\r\n RequiredAttributes: Integer): Boolean;\r\nfunction FileAttributesStr(const FileInfo: TSearchRec): string;\r\nfunction IsFileNameMatch(FileName: string; const Mask: string;\r\n const CaseSensitive: Boolean = {$IFDEF MSWINDOWS} False {$ELSE} True {$ENDIF}): Boolean;\r\nprocedure EnumFiles(const Path: string; HandleFile: TFileHandlerEx;\r\n RejectedAttributes: Integer = faRejectedByDefault; RequiredAttributes: Integer = 0;\r\n Abort: PBoolean = nil); overload;\r\nprocedure EnumFiles(const Path: string; HandleFile: TFileInfoHandlerEx;\r\n RejectedAttributes: Integer = faRejectedByDefault; RequiredAttributes: Integer = 0;\r\n Abort: PBoolean = nil); overload;\r\nprocedure EnumDirectories(const Root: string; const HandleDirectory: TFileHandler;\r\n const IncludeHiddenDirectories: Boolean = False; const SubDirectoriesMask: string = '';\r\n Abort: PBoolean = nil {$IFDEF UNIX}; ResolveSymLinks: Boolean = True {$ENDIF});\r\n{$IFDEF MSWINDOWS}\r\nprocedure CreateEmptyFile(const FileName: string);\r\nfunction CloseVolume(var Volume: THandle): Boolean;\r\n{$IFNDEF FPC}\r\nfunction DeleteDirectory(const DirectoryName: string; MoveToRecycleBin: Boolean): Boolean;\r\nfunction CopyDirectory(ExistingDirectoryName, NewDirectoryName: string): Boolean;\r\nfunction MoveDirectory(ExistingDirectoryName, NewDirectoryName: string): Boolean;\r\n{$ENDIF ~FPC}\r\nfunction DelTree(const Path: string): Boolean;\r\nfunction DelTreeEx(const Path: string; AbortOnFailure: Boolean; Progress: TDelTreeProgress): Boolean;\r\nfunction DiskInDrive(Drive: Char): Boolean;\r\n{$ENDIF MSWINDOWS}\r\nfunction DirectoryExists(const Name: string {$IFDEF UNIX}; ResolveSymLinks: Boolean = True {$ENDIF}): Boolean;\r\nfunction FileCreateTemp(var Prefix: string): THandle;\r\nfunction FileBackup(const FileName: string; Move: Boolean = False): Boolean;\r\nfunction FileCopy(const ExistingFileName, NewFileName: string; ReplaceExisting: Boolean = False): Boolean;\r\nfunction FileDateTime(const FileName: string): TDateTime;\r\nfunction FileDelete(const FileName: string; MoveToRecycleBin: Boolean = False): Boolean;\r\nfunction FileExists(const FileName: string): Boolean;\r\n/// procedure FileHistory Creates a list of history files of a specified\r\n/// source file. Each version of the file get's an extention .~~ The file with\r\n/// the lowest number is the youngest file.\r\n/// \r\n/// (string) Name of the source file\r\n/// (string) Folder where the history files should be\r\n/// created. If no folder is defined the folder of the source file is used.\r\n/// (Integer) Max number of files\r\n/// (TDateTime) Timestamp how old the file has to be to\r\n/// create a new history version. For example: NOW-1/24 => Only once per hour a new\r\n/// history file is created. Default 0 means allways\r\n/// (boolean) Flag to define that the history file\r\n/// extention should replace the current extention or should be added at the\r\n/// end\r\n/// \r\nprocedure FileHistory(const FileName: string; HistoryPath: string = ''; MaxHistoryCount: Integer = 100; MinFileDate:\r\n TDateTime = 0; ReplaceExtention: Boolean = true);\r\nfunction FileMove(const ExistingFileName, NewFileName: string; ReplaceExisting: Boolean = False): Boolean;\r\nfunction FileRestore(const FileName: string): Boolean;\r\nfunction GetBackupFileName(const FileName: string): string;\r\nfunction IsBackupFileName(const FileName: string): Boolean;\r\nfunction FileGetDisplayName(const FileName: string): string;\r\nfunction FileGetGroupName(const FileName: string {$IFDEF UNIX}; ResolveSymLinks: Boolean = True {$ENDIF}): string;\r\nfunction FileGetOwnerName(const FileName: string {$IFDEF UNIX}; ResolveSymLinks: Boolean = True {$ENDIF}): string;\r\nfunction FileGetSize(const FileName: string): Int64;\r\nfunction FileGetTempName(const Prefix: string): string;\r\n{$IFDEF MSWINDOWS}\r\nfunction FileGetTypeName(const FileName: string): string;\r\n{$ENDIF MSWINDOWS}\r\nfunction FindUnusedFileName(FileName: string; const FileExt: string; NumberPrefix: string = ''): string;\r\nfunction ForceDirectories(Name: string): Boolean;\r\nfunction GetDirectorySize(const Path: string): Int64;\r\n{$IFDEF MSWINDOWS}\r\nfunction GetDriveTypeStr(const Drive: Char): string;\r\nfunction GetFileAgeCoherence(const FileName: string): Boolean;\r\n{$ENDIF MSWINDOWS}\r\nprocedure GetFileAttributeList(const Items: TStrings; const Attr: Integer);\r\n{$IFDEF MSWINDOWS}\r\nprocedure GetFileAttributeListEx(const Items: TStrings; const Attr: Integer);\r\n{$ENDIF MSWINDOWS}\r\nfunction GetFileInformation(const FileName: string; out FileInfo: TSearchRec): Boolean; overload;\r\nfunction GetFileInformation(const FileName: string): TSearchRec; overload;\r\n{$IFDEF UNIX}\r\nfunction GetFileStatus(const FileName: string; out StatBuf: TStatBuf64;\r\n const ResolveSymLinks: Boolean): Integer;\r\n{$ENDIF UNIX}\r\n{$IFDEF MSWINDOWS}\r\nfunction GetFileLastWrite(const FileName: string): TFileTime; overload;\r\nfunction GetFileLastWrite(const FileName: string; out LocalTime: TDateTime): Boolean; overload;\r\nfunction GetFileLastAccess(const FileName: string): TFileTime; overload;\r\nfunction GetFileLastAccess(const FileName: string; out LocalTime: TDateTime): Boolean; overload;\r\nfunction GetFileCreation(const FileName: string): TFileTime; overload;\r\nfunction GetFileCreation(const FileName: string; out LocalTime: TDateTime): Boolean; overload;\r\n{$ENDIF MSWINDOWS}\r\n{$IFDEF UNIX}\r\nfunction GetFileLastWrite(const FileName: string; out TimeStamp: Integer; ResolveSymLinks: Boolean = True): Boolean; overload;\r\nfunction GetFileLastWrite(const FileName: string; out LocalTime: TDateTime; ResolveSymLinks: Boolean = True): Boolean; overload;\r\nfunction GetFileLastWrite(const FileName: string; ResolveSymLinks: Boolean = True): Integer; overload;\r\nfunction GetFileLastAccess(const FileName: string; out TimeStamp: Integer; ResolveSymLinks: Boolean = True): Boolean; overload;\r\nfunction GetFileLastAccess(const FileName: string; out LocalTime: TDateTime; ResolveSymLinks: Boolean = True): Boolean; overload;\r\nfunction GetFileLastAccess(const FileName: string; ResolveSymLinks: Boolean = True): Integer; overload;\r\nfunction GetFileLastAttrChange(const FileName: string; out TimeStamp: Integer; ResolveSymLinks: Boolean = True): Boolean; overload;\r\nfunction GetFileLastAttrChange(const FileName: string; out LocalTime: TDateTime; ResolveSymLinks: Boolean = True): Boolean; overload;\r\nfunction GetFileLastAttrChange(const FileName: string; ResolveSymLinks: Boolean = True): Integer; overload;\r\n{$ENDIF UNIX}\r\nfunction GetModulePath(const Module: HMODULE): string;\r\nfunction GetSizeOfFile(const FileName: string): Int64; overload;\r\nfunction GetSizeOfFile(const FileInfo: TSearchRec): Int64; overload;\r\n{$IFDEF MSWINDOWS}\r\nfunction GetSizeOfFile(Handle: THandle): Int64; overload;\r\nfunction GetStandardFileInfo(const FileName: string): TWin32FileAttributeData;\r\n{$ENDIF MSWINDOWS}\r\nfunction IsDirectory(const FileName: string {$IFDEF UNIX}; ResolveSymLinks: Boolean = True {$ENDIF}): Boolean;\r\nfunction IsRootDirectory(const CanonicFileName: string): Boolean;\r\n{$IFDEF MSWINDOWS}\r\nfunction LockVolume(const Volume: string; var Handle: THandle): Boolean;\r\nfunction OpenVolume(const Drive: Char): THandle;\r\nfunction SetDirLastWrite(const DirName: string; const DateTime: TDateTime; RequireBackupRestorePrivileges: Boolean = True): Boolean;\r\nfunction SetDirLastAccess(const DirName: string; const DateTime: TDateTime; RequireBackupRestorePrivileges: Boolean = True): Boolean;\r\nfunction SetDirCreation(const DirName: string; const DateTime: TDateTime; RequireBackupRestorePrivileges: Boolean = True): Boolean;\r\n{$ENDIF MSWINDOWS}\r\nfunction SetFileLastWrite(const FileName: string; const DateTime: TDateTime): Boolean;\r\nfunction SetFileLastAccess(const FileName: string; const DateTime: TDateTime): Boolean;\r\n{$IFDEF MSWINDOWS}\r\nfunction SetFileCreation(const FileName: string; const DateTime: TDateTime): Boolean;\r\nprocedure ShredFile(const FileName: string; Times: Integer = 1);\r\nfunction UnlockVolume(var Handle: THandle): Boolean;\r\n{$ENDIF MSWINDOWS}\r\n\r\n{$IFDEF UNIX}\r\nfunction CreateSymbolicLink(const Name, Target: string): Boolean;\r\n{ This function gets the value of the symbolic link filename. }\r\nfunction SymbolicLinkTarget(const Name: string): string;\r\n{$ENDIF UNIX}\r\n\r\n// TJclFileAttributeMask\r\n//\r\n// File search helper class, allows to specify required/rejected attributes\r\ntype\r\n TAttributeInterest = (aiIgnored, aiRejected, aiRequired);\r\n\r\n TJclCustomFileAttrMask = class(TPersistent)\r\n private\r\n FRequiredAttr: Integer;\r\n FRejectedAttr: Integer;\r\n function GetAttr(Index: Integer): TAttributeInterest;\r\n procedure SetAttr(Index: Integer; const Value: TAttributeInterest);\r\n procedure ReadRequiredAttributes(Reader: TReader);\r\n procedure ReadRejectedAttributes(Reader: TReader);\r\n procedure WriteRequiredAttributes(Writer: TWriter);\r\n procedure WriteRejectedAttributes(Writer: TWriter);\r\n protected\r\n procedure DefineProperties(Filer: TFiler); override;\r\n property ReadOnly: TAttributeInterest index faReadOnly\r\n read GetAttr write SetAttr stored False;\r\n property Hidden: TAttributeInterest index faHidden\r\n read GetAttr write SetAttr stored False;\r\n property System: TAttributeInterest index faSysFile\r\n read GetAttr write SetAttr stored False;\r\n property Directory: TAttributeInterest index faDirectory\r\n read GetAttr write SetAttr stored False;\r\n property SymLink: TAttributeInterest index faSymLink\r\n read GetAttr write SetAttr stored False;\r\n property Normal: TAttributeInterest index faNormalFile\r\n read GetAttr write SetAttr stored False;\r\n property Archive: TAttributeInterest index faArchive\r\n read GetAttr write SetAttr stored False;\r\n property Temporary: TAttributeInterest index faTemporary\r\n read GetAttr write SetAttr stored False;\r\n property SparseFile: TAttributeInterest index faSparseFile\r\n read GetAttr write SetAttr stored False;\r\n property ReparsePoint: TAttributeInterest index faReparsePoint\r\n read GetAttr write SetAttr stored False;\r\n property Compressed: TAttributeInterest index faCompressed\r\n read GetAttr write SetAttr stored False;\r\n property OffLine: TAttributeInterest index faOffline\r\n read GetAttr write SetAttr stored False;\r\n property NotContentIndexed: TAttributeInterest index faNotContentIndexed\r\n read GetAttr write SetAttr stored False;\r\n property Encrypted: TAttributeInterest index faEncrypted\r\n read GetAttr write SetAttr stored False;\r\n public\r\n constructor Create;\r\n procedure Assign(Source: TPersistent); override;\r\n procedure Clear;\r\n function Match(FileAttributes: Integer): Boolean; overload;\r\n function Match(const FileInfo: TSearchRec): Boolean; overload;\r\n property Required: Integer read FRequiredAttr write FRequiredAttr;\r\n property Rejected: Integer read FRejectedAttr write FRejectedAttr;\r\n property Attribute[Index: Integer]: TAttributeInterest read GetAttr write SetAttr; default;\r\n end;\r\n\r\n TJclFileAttributeMask = class(TJclCustomFileAttrMask)\r\n private\r\n procedure ReadVolumeID(Reader: TReader);\r\n protected\r\n procedure DefineProperties(Filer: TFiler); override;\r\n published\r\n property ReadOnly;\r\n property Hidden;\r\n property System;\r\n property Directory;\r\n property Normal;\r\n {$IFDEF UNIX}\r\n property SymLink;\r\n {$ENDIF UNIX}\r\n {$IFDEF MSWINDOWS}\r\n property Archive;\r\n property Temporary;\r\n property SparseFile;\r\n property ReparsePoint;\r\n property Compressed;\r\n property OffLine;\r\n property NotContentIndexed;\r\n property Encrypted;\r\n {$ENDIF MSWINDOWS}\r\n end;\r\n\r\ntype\r\n TFileSearchOption = (fsIncludeSubDirectories, fsIncludeHiddenSubDirectories, fsLastChangeAfter,\r\n fsLastChangeBefore, fsMaxSize, fsMinSize);\r\n TFileSearchOptions = set of TFileSearchOption;\r\n TFileSearchTaskID = Integer;\r\n TFileSearchTerminationEvent = procedure (const ID: TFileSearchTaskID; const Aborted: Boolean) of object;\r\n TFileEnumeratorSyncMode = (smPerFile, smPerDirectory);\r\n\r\n// IJclFileSearchOptions\r\n//\r\n// Interface for file search options\r\ntype\r\n IJclFileSearchOptions = interface\r\n ['{B73D9E3D-34C5-4DA9-88EF-4CA730328FC9}']\r\n function GetAttributeMask: TJclFileAttributeMask;\r\n function GetCaseSensitiveSearch: Boolean;\r\n function GetRootDirectories: TStrings;\r\n function GetRootDirectory: string;\r\n function GetFileMask: string;\r\n function GetFileMasks: TStrings;\r\n function GetFileSizeMax: Int64;\r\n function GetFileSizeMin: Int64;\r\n function GetIncludeSubDirectories: Boolean;\r\n function GetIncludeHiddenSubDirectories: Boolean;\r\n function GetLastChangeAfter: TDateTime;\r\n function GetLastChangeBefore: TDateTime;\r\n function GetLastChangeAfterStr: string;\r\n function GetLastChangeBeforeStr: string;\r\n function GetSubDirectoryMask: string;\r\n function GetOption(const Option: TFileSearchOption): Boolean;\r\n function GetOptions: TFileSearchoptions;\r\n procedure SetAttributeMask(const Value: TJclFileAttributeMask);\r\n procedure SetCaseSensitiveSearch(const Value: Boolean);\r\n procedure SetRootDirectories(const Value: TStrings);\r\n procedure SetRootDirectory(const Value: string);\r\n procedure SetFileMask(const Value: string);\r\n procedure SetFileMasks(const Value: TStrings);\r\n procedure SetFileSizeMax(const Value: Int64);\r\n procedure SetFileSizeMin(const Value: Int64);\r\n procedure SetIncludeSubDirectories(const Value: Boolean);\r\n procedure SetIncludeHiddenSubDirectories(const Value: Boolean);\r\n procedure SetLastChangeAfter(const Value: TDateTime);\r\n procedure SetLastChangeBefore(const Value: TDateTime);\r\n procedure SetLastChangeAfterStr(const Value: string);\r\n procedure SetLastChangeBeforeStr(const Value: string);\r\n procedure SetOption(const Option: TFileSearchOption; const Value: Boolean);\r\n procedure SetOptions(const Value: TFileSearchOptions);\r\n procedure SetSubDirectoryMask(const Value: string);\r\n // properties\r\n property CaseSensitiveSearch: Boolean read GetCaseSensitiveSearch write SetCaseSensitiveSearch;\r\n property RootDirectories: TStrings read GetRootDirectories write SetRootDirectories;\r\n property RootDirectory: string read GetRootDirectory write SetRootDirectory;\r\n property FileMask: string read GetFileMask write SetFileMask;\r\n property SubDirectoryMask: string read GetSubDirectoryMask write SetSubDirectoryMask;\r\n property AttributeMask: TJclFileAttributeMask read GetAttributeMask write SetAttributeMask;\r\n property FileSizeMin: Int64 read GetFileSizeMin write SetFileSizeMin;\r\n property FileSizeMax: Int64 read GetFileSizeMax write SetFileSizeMax; // default InvalidFileSize;\r\n property LastChangeAfter: TDateTime read GetLastChangeAfter write SetLastChangeAfter;\r\n property LastChangeBefore: TDateTime read GetLastChangeBefore write SetLastChangeBefore;\r\n property LastChangeAfterAsString: string read GetLastChangeAfterStr write SetLastChangeAfterStr;\r\n property LastChangeBeforeAsString: string read GetLastChangeBeforeStr write SetLastChangeBeforeStr;\r\n property IncludeSubDirectories: Boolean read GetIncludeSubDirectories\r\n write SetIncludeSubDirectories;\r\n property IncludeHiddenSubDirectories: Boolean read GetIncludeHiddenSubDirectories\r\n write SetIncludeHiddenSubDirectories;\r\n end;\r\n\r\n// IJclFileSearchOptions\r\n//\r\n// Interface for file search options\r\ntype\r\n TJclFileSearchOptions = class(TJclInterfacedPersistent, IJclFileSearchOptions)\r\n protected\r\n FFileMasks: TStringList;\r\n FRootDirectories: TStringList;\r\n FSubDirectoryMask: string;\r\n FAttributeMask: TJclFileAttributeMask;\r\n FFileSizeMin: Int64;\r\n FFileSizeMax: Int64;\r\n FLastChangeBefore: TDateTime;\r\n FLastChangeAfter: TDateTime;\r\n FOptions: TFileSearchOptions;\r\n FCaseSensitiveSearch: Boolean;\r\n function IsLastChangeAfterStored: Boolean;\r\n function IsLastChangeBeforeStored: Boolean;\r\n public\r\n constructor Create;\r\n destructor Destroy; override;\r\n procedure Assign(Source: TPersistent); override;\r\n\r\n { IJclFileSearchOptions }\r\n function GetAttributeMask: TJclFileAttributeMask;\r\n function GetCaseSensitiveSearch: Boolean;\r\n function GetRootDirectories: TStrings;\r\n function GetRootDirectory: string;\r\n function GetFileMask: string;\r\n function GetFileMasks: TStrings;\r\n function GetFileSizeMax: Int64;\r\n function GetFileSizeMin: Int64;\r\n function GetIncludeSubDirectories: Boolean;\r\n function GetIncludeHiddenSubDirectories: Boolean;\r\n function GetLastChangeAfter: TDateTime;\r\n function GetLastChangeBefore: TDateTime;\r\n function GetLastChangeAfterStr: string;\r\n function GetLastChangeBeforeStr: string;\r\n function GetSubDirectoryMask: string;\r\n function GetOption(const Option: TFileSearchOption): Boolean;\r\n function GetOptions: TFileSearchoptions;\r\n procedure SetAttributeMask(const Value: TJclFileAttributeMask);\r\n procedure SetCaseSensitiveSearch(const Value: Boolean);\r\n procedure SetRootDirectories(const Value: TStrings);\r\n procedure SetRootDirectory(const Value: string);\r\n procedure SetFileMask(const Value: string);\r\n procedure SetFileMasks(const Value: TStrings);\r\n procedure SetFileSizeMax(const Value: Int64);\r\n procedure SetFileSizeMin(const Value: Int64);\r\n procedure SetIncludeSubDirectories(const Value: Boolean);\r\n procedure SetIncludeHiddenSubDirectories(const Value: Boolean);\r\n procedure SetLastChangeAfter(const Value: TDateTime);\r\n procedure SetLastChangeBefore(const Value: TDateTime);\r\n procedure SetLastChangeAfterStr(const Value: string);\r\n procedure SetLastChangeBeforeStr(const Value: string);\r\n procedure SetOption(const Option: TFileSearchOption; const Value: Boolean);\r\n procedure SetOptions(const Value: TFileSearchOptions);\r\n procedure SetSubDirectoryMask(const Value: string);\r\n published\r\n property CaseSensitiveSearch: Boolean read GetCaseSensitiveSearch write SetCaseSensitiveSearch\r\n default {$IFDEF MSWINDOWS} False {$ELSE} True {$ENDIF};\r\n property FileMasks: TStrings read GetFileMasks write SetFileMasks;\r\n property RootDirectories: TStrings read GetRootDirectories write SetRootDirectories;\r\n property RootDirectory: string read GetRootDirectory write SetRootDirectory;\r\n property SubDirectoryMask: string read FSubDirectoryMask write FSubDirectoryMask;\r\n property AttributeMask: TJclFileAttributeMask read FAttributeMask write SetAttributeMask;\r\n property FileSizeMin: Int64 read FFileSizeMin write FFileSizeMin;\r\n property FileSizeMax: Int64 read FFileSizeMax write FFileSizeMax;\r\n property LastChangeAfter: TDateTime read FLastChangeAfter write FLastChangeAfter\r\n stored IsLastChangeAfterStored;\r\n property LastChangeBefore: TDateTime read FLastChangeBefore write FLastChangeBefore\r\n stored IsLastChangeBeforeStored;\r\n property Options: TFileSearchOptions read FOptions write FOptions\r\n default [fsIncludeSubDirectories];\r\n end;\r\n\r\n// IJclFileEnumerator\r\n//\r\n// Interface for thread-based file search\r\ntype\r\n IJclFileEnumerator = interface(IJclFileSearchOptions)\r\n ['{F7E747ED-1C41-441F-B25B-BB314E00C4E9}']\r\n // property access methods\r\n function GetRunningTasks: Integer;\r\n function GetSynchronizationMode: TFileEnumeratorSyncMode;\r\n function GetOnEnterDirectory: TFileHandler;\r\n function GetOnTerminateTask: TFileSearchTerminationEvent;\r\n procedure SetSynchronizationMode(const Value: TFileEnumeratorSyncMode);\r\n procedure SetOnEnterDirectory(const Value: TFileHandler);\r\n procedure SetOnTerminateTask(const Value: TFileSearchTerminationEvent);\r\n // other methods\r\n function FillList(List: TStrings): TFileSearchTaskID;\r\n function ForEach(Handler: TFileHandler): TFileSearchTaskID; overload;\r\n function ForEach(Handler: TFileHandlerEx): TFileSearchTaskID; overload;\r\n procedure StopTask(ID: TFileSearchTaskID);\r\n procedure StopAllTasks(Silently: Boolean = False); // Silently: Don't call OnTerminateTask\r\n // properties\r\n property RunningTasks: Integer read GetRunningTasks;\r\n property SynchronizationMode: TFileEnumeratorSyncMode read GetSynchronizationMode\r\n write SetSynchronizationMode;\r\n property OnEnterDirectory: TFileHandler read GetOnEnterDirectory write SetOnEnterDirectory;\r\n property OnTerminateTask: TFileSearchTerminationEvent read GetOnTerminateTask\r\n write SetOnTerminateTask;\r\n end;\r\n\r\n// TJclFileEnumerator\r\n//\r\n// Class for thread-based file search\r\ntype\r\n TJclFileEnumerator = class(TJclFileSearchOptions, IInterface, IJclFileSearchOptions, IJclFileEnumerator)\r\n private\r\n FTasks: TList;\r\n FOnEnterDirectory: TFileHandler;\r\n FOnTerminateTask: TFileSearchTerminationEvent;\r\n FNextTaskID: TFileSearchTaskID;\r\n FSynchronizationMode: TFileEnumeratorSyncMode;\r\n function GetNextTaskID: TFileSearchTaskID;\r\n protected\r\n function CreateTask: TThread;\r\n procedure TaskTerminated(Sender: TObject);\r\n property NextTaskID: TFileSearchTaskID read GetNextTaskID;\r\n public\r\n constructor Create;\r\n destructor Destroy; override;\r\n\r\n { IJclFileEnumerator }\r\n function GetRunningTasks: Integer;\r\n function GetSynchronizationMode: TFileEnumeratorSyncMode;\r\n function GetOnEnterDirectory: TFileHandler;\r\n function GetOnTerminateTask: TFileSearchTerminationEvent;\r\n procedure SetSynchronizationMode(const Value: TFileEnumeratorSyncMode);\r\n procedure SetOnEnterDirectory(const Value: TFileHandler);\r\n procedure SetOnTerminateTask(const Value: TFileSearchTerminationEvent);\r\n\r\n procedure Assign(Source: TPersistent); override;\r\n function FillList(List: TStrings): TFileSearchTaskID;\r\n function ForEach(Handler: TFileHandler): TFileSearchTaskID; overload;\r\n function ForEach(Handler: TFileHandlerEx): TFileSearchTaskID; overload;\r\n procedure StopTask(ID: TFileSearchTaskID);\r\n procedure StopAllTasks(Silently: Boolean = False); // Silently: Don't call OnTerminateTask\r\n property FileMask: string read GetFileMask write SetFileMask;\r\n property IncludeSubDirectories: Boolean\r\n read GetIncludeSubDirectories write SetIncludeSubDirectories;\r\n property IncludeHiddenSubDirectories: Boolean\r\n read GetIncludeHiddenSubDirectories write SetIncludeHiddenSubDirectories;\r\n property SearchOption[const Option: TFileSearchOption]: Boolean read GetOption write SetOption;\r\n property LastChangeAfterAsString: string read GetLastChangeAfterStr write SetLastChangeAfterStr;\r\n property LastChangeBeforeAsString: string read GetLastChangeBeforeStr write SetLastChangeBeforeStr;\r\n published\r\n property RunningTasks: Integer read GetRunningTasks;\r\n property SynchronizationMode: TFileEnumeratorSyncMode read FSynchronizationMode write FSynchronizationMode\r\n default smPerDirectory;\r\n property OnEnterDirectory: TFileHandler read FOnEnterDirectory write FOnEnterDirectory;\r\n property OnTerminateTask: TFileSearchTerminationEvent read FOnTerminateTask write FOnTerminateTask;\r\n end;\r\n\r\nfunction FileSearch: IJclFileEnumerator;\r\n\r\n{$IFDEF MSWINDOWS}\r\n\r\n// TFileVersionInfo\r\n//\r\n// Class that enables reading the version information stored in a PE file.\r\n\r\ntype\r\n TFileFlag = (ffDebug, ffInfoInferred, ffPatched, ffPreRelease, ffPrivateBuild, ffSpecialBuild);\r\n TFileFlags = set of TFileFlag;\r\n\r\n PLangIdRec = ^TLangIdRec;\r\n TLangIdRec = packed record\r\n case Integer of\r\n 0: (\r\n LangId: Word;\r\n CodePage: Word);\r\n 1: (\r\n Pair: DWORD);\r\n end;\r\n\r\n EJclFileVersionInfoError = class(EJclError);\r\n\r\n TJclFileVersionInfo = class(TObject)\r\n private\r\n FBuffer: AnsiString;\r\n FFixedInfo: PVSFixedFileInfo;\r\n FFileFlags: TFileFlags;\r\n FItemList: TStringList;\r\n FItems: TStringList;\r\n FLanguages: array of TLangIdRec;\r\n FLanguageIndex: Integer;\r\n FTranslations: array of TLangIdRec;\r\n function GetFixedInfo: TVSFixedFileInfo;\r\n function GetItems: TStrings;\r\n function GetLanguageCount: Integer;\r\n function GetLanguageIds(Index: Integer): string;\r\n function GetLanguageNames(Index: Integer): string;\r\n function GetLanguages(Index: Integer): TLangIdRec;\r\n function GetTranslationCount: Integer;\r\n function GetTranslations(Index: Integer): TLangIdRec;\r\n procedure SetLanguageIndex(const Value: Integer);\r\n protected\r\n procedure CreateItemsForLanguage;\r\n procedure CheckLanguageIndex(Value: Integer);\r\n procedure ExtractData;\r\n procedure ExtractFlags;\r\n function GetBinFileVersion: string;\r\n function GetBinProductVersion: string;\r\n function GetFileOS: DWORD;\r\n function GetFileSubType: DWORD;\r\n function GetFileType: DWORD;\r\n function GetFileVersionBuild: string;\r\n function GetFileVersionMajor: string;\r\n function GetFileVersionMinor: string;\r\n function GetFileVersionRelease: string;\r\n function GetProductVersionBuild: string;\r\n function GetProductVersionMajor: string;\r\n function GetProductVersionMinor: string;\r\n function GetProductVersionRelease: string;\r\n function GetVersionKeyValue(Index: Integer): string;\r\n public\r\n constructor Attach(VersionInfoData: Pointer; Size: Integer);\r\n constructor Create(const FileName: string); overload;\r\n {$IFDEF MSWINDOWS}\r\n {$IFDEF FPC}\r\n constructor Create(const Window: HWND; Dummy: Pointer = nil); overload;\r\n {$ELSE}\r\n constructor Create(const Window: HWND); overload;\r\n {$ENDIF}\r\n constructor Create(const Module: HMODULE); overload;\r\n {$ENDIF MSWINDOWS}\r\n destructor Destroy; override;\r\n function GetCustomFieldValue(const FieldName: string): string;\r\n class function VersionLanguageId(const LangIdRec: TLangIdRec): string;\r\n class function VersionLanguageName(const LangId: Word): string;\r\n class function FileHasVersionInfo(const FileName: string): boolean;\r\n function TranslationMatchesLanguages(Exact: Boolean = True): Boolean;\r\n property BinFileVersion: string read GetBinFileVersion;\r\n property BinProductVersion: string read GetBinProductVersion;\r\n property Comments: string index 1 read GetVersionKeyValue;\r\n property CompanyName: string index 2 read GetVersionKeyValue;\r\n property FileDescription: string index 3 read GetVersionKeyValue;\r\n property FixedInfo: TVSFixedFileInfo read GetFixedInfo;\r\n property FileFlags: TFileFlags read FFileFlags;\r\n property FileOS: DWORD read GetFileOS;\r\n property FileSubType: DWORD read GetFileSubType;\r\n property FileType: DWORD read GetFileType;\r\n property FileVersion: string index 4 read GetVersionKeyValue;\r\n property FileVersionBuild: string read GetFileVersionBuild;\r\n property FileVersionMajor: string read GetFileVersionMajor;\r\n property FileVersionMinor: string read GetFileVersionMinor;\r\n property FileVersionRelease: string read GetFileVersionRelease;\r\n property Items: TStrings read GetItems;\r\n property InternalName: string index 5 read GetVersionKeyValue;\r\n property LanguageCount: Integer read GetLanguageCount;\r\n property LanguageIds[Index: Integer]: string read GetLanguageIds;\r\n property LanguageIndex: Integer read FLanguageIndex write SetLanguageIndex;\r\n property Languages[Index: Integer]: TLangIdRec read GetLanguages;\r\n property LanguageNames[Index: Integer]: string read GetLanguageNames;\r\n property LegalCopyright: string index 6 read GetVersionKeyValue;\r\n property LegalTradeMarks: string index 7 read GetVersionKeyValue;\r\n property OriginalFilename: string index 8 read GetVersionKeyValue;\r\n property PrivateBuild: string index 12 read GetVersionKeyValue;\r\n property ProductName: string index 9 read GetVersionKeyValue;\r\n property ProductVersion: string index 10 read GetVersionKeyValue;\r\n property ProductVersionBuild: string read GetProductVersionBuild;\r\n property ProductVersionMajor: string read GetProductVersionMajor;\r\n property ProductVersionMinor: string read GetProductVersionMinor;\r\n property ProductVersionRelease: string read GetProductVersionRelease;\r\n property SpecialBuild: string index 11 read GetVersionKeyValue;\r\n property TranslationCount: Integer read GetTranslationCount;\r\n property Translations[Index: Integer]: TLangIdRec read GetTranslations;\r\n end;\r\n\r\nfunction OSIdentToString(const OSIdent: DWORD): string;\r\nfunction OSFileTypeToString(const OSFileType: DWORD; const OSFileSubType: DWORD = 0): string;\r\n\r\nfunction VersionResourceAvailable(const FileName: string): Boolean; overload;\r\nfunction VersionResourceAvailable(const Window: HWND): Boolean; overload;\r\nfunction VersionResourceAvailable(const Module: HMODULE): Boolean; overload;\r\n\r\nfunction WindowToModuleFileName(const Window: HWND): string;\r\n{$ENDIF MSWINDOWS}\r\n\r\n// Version Info formatting\r\ntype\r\n TFileVersionFormat = (vfMajorMinor, vfFull);\r\n\r\nfunction FormatVersionString(const HiV, LoV: Word): string; overload;\r\nfunction FormatVersionString(const Major, Minor, Build, Revision: Word): string; overload;\r\n\r\n{$IFDEF MSWINDOWS}\r\n\r\nfunction FormatVersionString(const FixedInfo: TVSFixedFileInfo; VersionFormat: TFileVersionFormat = vfFull): string; overload;\r\n\r\n// Version Info extracting\r\nprocedure VersionExtractFileInfo(const FixedInfo: TVSFixedFileInfo; var Major, Minor, Build, Revision: Word);\r\nprocedure VersionExtractProductInfo(const FixedInfo: TVSFixedFileInfo; var Major, Minor, Build, Revision: Word);\r\n\r\n// Fixed Version Info routines\r\nfunction VersionFixedFileInfo(const FileName: string; var FixedInfo: TVSFixedFileInfo): Boolean;\r\nfunction VersionFixedFileInfoString(const FileName: string; VersionFormat: TFileVersionFormat = vfFull;\r\n const NotAvailableText: string = ''): string;\r\n\r\n{$ENDIF MSWINDOWS}\r\n\r\n// Streams\r\n//\r\n// TStream descendent classes for dealing with temporary files and for using file mapping objects.\r\ntype\r\n TJclTempFileStream = class(THandleStream)\r\n private\r\n FFileName: string;\r\n public\r\n constructor Create(const Prefix: string);\r\n destructor Destroy; override;\r\n property FileName: string read FFileName;\r\n end;\r\n\r\n{$IFDEF MSWINDOWS}\r\n\r\n TJclCustomFileMapping = class;\r\n\r\n TJclFileMappingView = class(TCustomMemoryStream)\r\n private\r\n FFileMapping: TJclCustomFileMapping;\r\n FOffsetHigh: Cardinal;\r\n FOffsetLow: Cardinal;\r\n function GetIndex: Integer;\r\n function GetOffset: Int64;\r\n public\r\n constructor Create(const FileMap: TJclCustomFileMapping;\r\n Access, Size: Cardinal; ViewOffset: Int64);\r\n constructor CreateAt(FileMap: TJclCustomFileMapping; Access,\r\n Size: Cardinal; ViewOffset: Int64; Address: Pointer);\r\n destructor Destroy; override;\r\n function Flush(const Count: Cardinal): Boolean;\r\n procedure LoadFromStream(const Stream: TStream);\r\n procedure LoadFromFile(const FileName: string);\r\n function Write(const Buffer; Count: Longint): Longint; override;\r\n property Index: Integer read GetIndex;\r\n property FileMapping: TJclCustomFileMapping read FFileMapping;\r\n property Offset: Int64 read GetOffset;\r\n end;\r\n\r\n TJclFileMappingRoundOffset = (rvDown, rvUp);\r\n\r\n TJclCustomFileMapping = class(TObject)\r\n private\r\n FExisted: Boolean;\r\n FHandle: THandle;\r\n FName: string;\r\n FRoundViewOffset: TJclFileMappingRoundOffset;\r\n FViews: TList;\r\n function GetCount: Integer;\r\n function GetView(Index: Integer): TJclFileMappingView;\r\n protected\r\n procedure ClearViews;\r\n procedure InternalCreate(const FileHandle: THandle; const Name: string;\r\n const Protect: Cardinal; MaximumSize: Int64; SecAttr: PSecurityAttributes);\r\n procedure InternalOpen(const Name: string; const InheritHandle: Boolean;\r\n const DesiredAccess: Cardinal);\r\n public\r\n constructor Create;\r\n constructor Open(const Name: string; const InheritHandle: Boolean; const DesiredAccess: Cardinal);\r\n destructor Destroy; override;\r\n function Add(const Access, Count: Cardinal; const Offset: Int64): Integer;\r\n function AddAt(const Access, Count: Cardinal; const Offset: Int64; const Address: Pointer): Integer;\r\n procedure Delete(const Index: Integer);\r\n function IndexOf(const View: TJclFileMappingView): Integer;\r\n property Count: Integer read GetCount;\r\n property Existed: Boolean read FExisted;\r\n property Handle: THandle read FHandle;\r\n property Name: string read FName;\r\n property RoundViewOffset: TJclFileMappingRoundOffset read FRoundViewOffset write FRoundViewOffset;\r\n property Views[index: Integer]: TJclFileMappingView read GetView;\r\n end;\r\n\r\n TJclFileMapping = class(TJclCustomFileMapping)\r\n private\r\n FFileHandle: THandle;\r\n public\r\n constructor Create(const FileName: string; FileMode: Cardinal;\r\n const Name: string; Protect: Cardinal; const MaximumSize: Int64;\r\n SecAttr: PSecurityAttributes); overload;\r\n constructor Create(const FileHandle: THandle; const Name: string;\r\n Protect: Cardinal; const MaximumSize: Int64;\r\n SecAttr: PSecurityAttributes); overload;\r\n destructor Destroy; override;\r\n property FileHandle: THandle read FFileHandle;\r\n end;\r\n\r\n TJclSwapFileMapping = class(TJclCustomFileMapping)\r\n public\r\n constructor Create(const Name: string; Protect: Cardinal;\r\n const MaximumSize: Int64; SecAttr: PSecurityAttributes);\r\n end;\r\n\r\n TJclFileMappingStream = class(TCustomMemoryStream)\r\n private\r\n FFileHandle: THandle;\r\n FMapping: THandle;\r\n protected\r\n procedure Close;\r\n public\r\n constructor Create(const FileName: string; FileMode: Word = fmOpenRead or fmShareDenyWrite);\r\n destructor Destroy; override;\r\n function Write(const Buffer; Count: Longint): Longint; override;\r\n end;\r\n\r\n{$ENDIF MSWINDOWS}\r\n\r\n TJclMappedTextReaderIndex = (tiNoIndex, tiFull);\r\n\r\n PPAnsiCharArray = ^TPAnsiCharArray;\r\n TPAnsiCharArray = array [0..0] of PAnsiChar;\r\n\r\n TJclAnsiMappedTextReader = class(TPersistent)\r\n private\r\n FContent: PAnsiChar;\r\n FEnd: PAnsiChar;\r\n FIndex: PPAnsiCharArray;\r\n FIndexOption: TJclMappedTextReaderIndex;\r\n FFreeStream: Boolean;\r\n FLastLineNumber: Integer;\r\n FLastPosition: PAnsiChar;\r\n FLineCount: Integer;\r\n FMemoryStream: TCustomMemoryStream;\r\n FPosition: PAnsiChar;\r\n FSize: Integer;\r\n function GetAsString: AnsiString;\r\n function GetEof: Boolean;\r\n function GetChars(Index: Integer): AnsiChar;\r\n function GetLineCount: Integer;\r\n function GetLines(LineNumber: Integer): AnsiString;\r\n function GetPosition: Integer;\r\n function GetPositionFromLine(LineNumber: Integer): Integer;\r\n procedure SetPosition(const Value: Integer);\r\n protected\r\n procedure AssignTo(Dest: TPersistent); override;\r\n procedure CreateIndex;\r\n procedure Init;\r\n function PtrFromLine(LineNumber: Integer): PAnsiChar;\r\n function StringFromPosition(var StartPos: PAnsiChar): AnsiString;\r\n public\r\n constructor Create(MemoryStream: TCustomMemoryStream; FreeStream: Boolean = True;\r\n const AIndexOption: TJclMappedTextReaderIndex = tiNoIndex); overload;\r\n constructor Create(const FileName: TFileName;\r\n const AIndexOption: TJclMappedTextReaderIndex = tiNoIndex); overload;\r\n destructor Destroy; override;\r\n procedure GoBegin;\r\n function Read: AnsiChar;\r\n function ReadLn: AnsiString;\r\n property AsString: AnsiString read GetAsString;\r\n property Chars[Index: Integer]: AnsiChar read GetChars;\r\n property Content: PAnsiChar read FContent;\r\n property Eof: Boolean read GetEof;\r\n property IndexOption: TJclMappedTextReaderIndex read FIndexOption;\r\n property Lines[LineNumber: Integer]: AnsiString read GetLines;\r\n property LineCount: Integer read GetLineCount;\r\n property PositionFromLine[LineNumber: Integer]: Integer read GetPositionFromLine;\r\n property Position: Integer read GetPosition write SetPosition;\r\n property Size: Integer read FSize;\r\n end;\r\n\r\n PPWideCharArray = ^TPWideCharArray;\r\n TPWideCharArray = array [0..0] of PWideChar;\r\n\r\n TJclWideMappedTextReader = class(TPersistent)\r\n private\r\n FContent: PWideChar;\r\n FEnd: PWideChar;\r\n FIndex: PPWideCharArray;\r\n FIndexOption: TJclMappedTextReaderIndex;\r\n FFreeStream: Boolean;\r\n FLastLineNumber: Integer;\r\n FLastPosition: PWideChar;\r\n FLineCount: Integer;\r\n FMemoryStream: TCustomMemoryStream;\r\n FPosition: PWideChar;\r\n FSize: Integer;\r\n function GetAsString: WideString;\r\n function GetEof: Boolean;\r\n function GetChars(Index: Integer): WideChar;\r\n function GetLineCount: Integer;\r\n function GetLines(LineNumber: Integer): WideString;\r\n function GetPosition: Integer;\r\n function GetPositionFromLine(LineNumber: Integer): Integer;\r\n procedure SetPosition(const Value: Integer);\r\n protected\r\n procedure AssignTo(Dest: TPersistent); override;\r\n procedure CreateIndex;\r\n procedure Init;\r\n function PtrFromLine(LineNumber: Integer): PWideChar;\r\n function StringFromPosition(var StartPos: PWideChar): WideString;\r\n public\r\n constructor Create(MemoryStream: TCustomMemoryStream; FreeStream: Boolean = True;\r\n const AIndexOption: TJclMappedTextReaderIndex = tiNoIndex); overload;\r\n constructor Create(const FileName: TFileName;\r\n const AIndexOption: TJclMappedTextReaderIndex = tiNoIndex); overload;\r\n destructor Destroy; override;\r\n procedure GoBegin;\r\n function Read: WideChar;\r\n function ReadLn: WideString;\r\n property AsString: WideString read GetAsString;\r\n property Chars[Index: Integer]: WideChar read GetChars;\r\n property Content: PWideChar read FContent;\r\n property Eof: Boolean read GetEof;\r\n property IndexOption: TJclMappedTextReaderIndex read FIndexOption;\r\n property Lines[LineNumber: Integer]: WideString read GetLines;\r\n property LineCount: Integer read GetLineCount;\r\n property PositionFromLine[LineNumber: Integer]: Integer read GetPositionFromLine;\r\n property Position: Integer read GetPosition write SetPosition;\r\n property Size: Integer read FSize;\r\n end;\r\n\r\n{ TODO : UNTESTED/UNDOCUMENTED }\r\n\r\ntype\r\n TJclFileMaskComparator = class(TObject)\r\n private\r\n FFileMask: string;\r\n FExts: array of string;\r\n FNames: array of string;\r\n FWildChars: array of Byte;\r\n FSeparator: Char;\r\n procedure CreateMultiMasks;\r\n function GetCount: Integer;\r\n function GetExts(Index: Integer): string;\r\n function GetMasks(Index: Integer): string;\r\n function GetNames(Index: Integer): string;\r\n procedure SetFileMask(const Value: string);\r\n procedure SetSeparator(const Value: Char);\r\n public\r\n constructor Create;\r\n function Compare(const NameExt: string): Boolean;\r\n property Count: Integer read GetCount;\r\n property Exts[Index: Integer]: string read GetExts;\r\n property FileMask: string read FFileMask write SetFileMask;\r\n property Masks[Index: Integer]: string read GetMasks;\r\n property Names[Index: Integer]: string read GetNames;\r\n property Separator: Char read FSeparator write SetSeparator;\r\n end;\r\n\r\n EJclPathError = class(EJclError);\r\n EJclFileUtilsError = class(EJclError);\r\n {$IFDEF UNIX}\r\n EJclTempFileStreamError = class(EJclFileUtilsError);\r\n {$ENDIF UNIX}\r\n {$IFDEF MSWINDOWS}\r\n EJclTempFileStreamError = class(EJclWin32Error);\r\n EJclFileMappingError = class(EJclWin32Error);\r\n EJclFileMappingViewError = class(EJclWin32Error);\r\n {$ENDIF MSWINDOWS}\r\n\r\nfunction SamePath(const Path1, Path2: string): Boolean;\r\n\r\n// functions to add/delete paths from a separated list of paths\r\n// on windows the separator is a semi-colon ';'\r\n// on linux the separator is a colon ':'\r\n// add items at the end\r\nprocedure PathListAddItems(var List: string; const Items: string);\r\n// add items at the end if they are not present\r\nprocedure PathListIncludeItems(var List: string; const Items: string);\r\n// delete multiple items\r\nprocedure PathListDelItems(var List: string; const Items: string);\r\n// delete one item\r\nprocedure PathListDelItem(var List: string; const Index: Integer);\r\n// return the number of item\r\nfunction PathListItemCount(const List: string): Integer;\r\n// return the Nth item\r\nfunction PathListGetItem(const List: string; const Index: Integer): string;\r\n// set the Nth item\r\nprocedure PathListSetItem(var List: string; const Index: Integer; const Value: string);\r\n// return the index of an item\r\nfunction PathListItemIndex(const List, Item: string): Integer;\r\n\r\n\r\n// additional functions to access the commandline parameters of an application\r\n\r\n// returns the name of the command line parameter at position index, which is\r\n// separated by the given separator, if the first character of the name part\r\n// is one of the AllowedPrefixCharacters, this character will be deleted.\r\nfunction ParamName (Index : Integer; const Separator : string = '=';\r\n const AllowedPrefixCharacters : string = '-/'; TrimName : Boolean = true) : string;\r\n// returns the value of the command line parameter at position index, which is\r\n// separated by the given separator\r\nfunction ParamValue (Index : Integer; const Separator : string = '='; TrimValue : Boolean = true) : string; overload;\r\n// seaches a command line parameter where the namepart is the searchname\r\n// and returns the value which is which by the given separator.\r\n// CaseSensitive defines the search type. if the first character of the name part\r\n// is one of the AllowedPrefixCharacters, this character will be deleted.\r\nfunction ParamValue (const SearchName : string; const Separator : string = '=';\r\n CaseSensitive : Boolean = False;\r\n const AllowedPrefixCharacters : string = '-/'; TrimValue : Boolean = true) : string; overload;\r\n// seaches a command line parameter where the namepart is the searchname\r\n// and returns the position index. if no separator is defined, the full paramstr is compared.\r\n// CaseSensitive defines the search type. if the first character of the name part\r\n// is one of the AllowedPrefixCharacters, this character will be deleted.\r\nfunction ParamPos (const SearchName : string; const Separator : string = '=';\r\n CaseSensitive : Boolean = False;\r\n const AllowedPrefixCharacters : string = '-/'): Integer;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jcl.svn.sourceforge.net/svnroot/jcl/tags/JCL-2.4-Build4571/jcl/source/common/JclFileUtils.pas $';\r\n Revision: '$Revision: 3861 $';\r\n Date: '$Date: 2012-09-04 16:08:04 +0200 (mar. 04 sept. 2012) $';\r\n LogPath: 'JCL\\source\\common';\r\n Extra: '';\r\n Data: nil\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n {$IFDEF HAS_UNITSCOPE}\r\n System.Types, // inlining of TList.Remove\r\n {$IFDEF HAS_UNIT_CHARACTER}\r\n System.Character,\r\n {$ENDIF HAS_UNIT_CHARACTER}\r\n System.Math,\r\n {$IFDEF MSWINDOWS}\r\n Winapi.ShellApi, Winapi.ActiveX, System.Win.ComObj, Winapi.ShlObj,\r\n JclShell, JclSysInfo, JclSecurity,\r\n {$ENDIF MSWINDOWS}\r\n {$ELSE ~HAS_UNITSCOPE}\r\n {$IFDEF HAS_UNIT_CHARACTER}\r\n Character,\r\n {$ENDIF HAS_UNIT_CHARACTER}\r\n Math,\r\n {$IFDEF MSWINDOWS}\r\n ShellApi, ActiveX, ComObj, ShlObj,\r\n JclShell, JclSysInfo, JclSecurity,\r\n {$ENDIF MSWINDOWS}\r\n {$ENDIF ~HAS_UNITSCOPE}\r\n JclDateTime, JclResources,\r\n JclStrings;\r\n\r\n{ Some general notes:\r\n\r\n This unit redeclares some functions from FileCtrl.pas to avoid a dependency on that unit in the\r\n JCL. The problem is that FileCtrl.pas uses some units (eg Forms.pas) which have ridiculous\r\n initialization requirements. They add 4KB (!) to the executable and roughly 1 second of startup.\r\n That initialization is only necessary for GUI applications and is unacceptable for high\r\n performance services or console apps.\r\n\r\n The routines which query files or directories for their attributes deliberately use FindFirst\r\n even though there may be easier ways to get at the required information. This is because FindFirst\r\n is about the only routine which doesn't cause the file's last modification/accessed time to be\r\n changed which is usually an undesired side-effect. }\r\n\r\n{$IFDEF UNIX}\r\nconst\r\n ERROR_NO_MORE_FILES = -1;\r\n INVALID_HANDLE_VALUE = THandle(-1);\r\n{$ENDIF UNIX}\r\n\r\n//=== { TJclTempFileStream } =================================================\r\n\r\nconstructor TJclTempFileStream.Create(const Prefix: string);\r\nvar\r\n FileHandle: THandle;\r\nbegin\r\n FFileName := Prefix;\r\n FileHandle := FileCreateTemp(FFileName);\r\n // (rom) is it really wise to throw an exception before calling inherited?\r\n if FileHandle = INVALID_HANDLE_VALUE then\r\n raise EJclTempFileStreamError.CreateRes(@RsFileStreamCreate);\r\n inherited Create(FileHandle);\r\nend;\r\n\r\ndestructor TJclTempFileStream.Destroy;\r\nbegin\r\n if THandle(Handle) <> INVALID_HANDLE_VALUE then\r\n FileClose(Handle);\r\n inherited Destroy;\r\nend;\r\n\r\n//=== { TJclFileMappingView } ================================================\r\n\r\n{$IFDEF MSWINDOWS}\r\n\r\nconstructor TJclFileMappingView.Create(const FileMap: TJclCustomFileMapping;\r\n Access, Size: Cardinal; ViewOffset: Int64);\r\nvar\r\n BaseAddress: Pointer;\r\n OffsetLow, OffsetHigh: Cardinal;\r\nbegin\r\n inherited Create;\r\n if FileMap = nil then\r\n raise EJclFileMappingViewError.CreateRes(@RsViewNeedsMapping);\r\n FFileMapping := FileMap;\r\n // Offset must be a multiple of system memory allocation granularity\r\n RoundToAllocGranularity64(ViewOffset, FFileMapping.RoundViewOffset = rvUp);\r\n I64ToCardinals(ViewOffset, OffsetLow, OffsetHigh);\r\n FOffsetHigh := OffsetHigh;\r\n FOffsetLow := OffsetLow;\r\n BaseAddress := MapViewOfFile(FFileMapping.Handle, Access, FOffsetHigh, FOffsetLow, Size);\r\n if BaseAddress = nil then\r\n raise EJclFileMappingViewError.CreateRes(@RsCreateFileMappingView);\r\n // If we are mapping a file and size = 0 then MapViewOfFile has mapped the entire file. We must\r\n // figure out the size ourselves before we can call SetPointer. Since in case of failure to\r\n // retrieve the size we raise an exception, we also have to explicitly unmap the view which\r\n // otherwise would have been done by the destructor.\r\n if (Size = 0) and (FileMap is TJclFileMapping) then\r\n begin\r\n Size := GetFileSize(TJclFileMapping(FileMap).FFileHandle, nil);\r\n if Size = DWORD(-1) then\r\n begin\r\n UnMapViewOfFile(BaseAddress);\r\n raise EJclFileMappingViewError.CreateRes(@RsFailedToObtainSize);\r\n end;\r\n end;\r\n SetPointer(BaseAddress, Size);\r\n FFileMapping.FViews.Add(Self);\r\nend;\r\n\r\nconstructor TJclFileMappingView.CreateAt(FileMap: TJclCustomFileMapping;\r\n Access, Size: Cardinal; ViewOffset: Int64; Address: Pointer);\r\nvar\r\n BaseAddress: Pointer;\r\n OffsetLow, OffsetHigh: Cardinal;\r\nbegin\r\n inherited Create;\r\n if FileMap = nil then\r\n raise EJclFileMappingViewError.CreateRes(@RsViewNeedsMapping);\r\n FFileMapping := FileMap;\r\n // Offset must be a multiple of system memory allocation granularity\r\n RoundToAllocGranularity64(ViewOffset, FFileMapping.RoundViewOffset = rvUp);\r\n RoundToAllocGranularityPtr(Address, FFileMapping.RoundViewOffset = rvUp);\r\n I64ToCardinals(ViewOffset, OffsetLow, OffsetHigh);\r\n FOffsetHigh := OffsetHigh;\r\n FOffsetLow := OffsetLow;\r\n BaseAddress := MapViewOfFileEx(FFileMapping.Handle, Access, FOffsetHigh,\r\n FOffsetLow, Size, Address);\r\n if BaseAddress = nil then\r\n raise EJclFileMappingViewError.CreateRes(@RsCreateFileMappingView);\r\n // If we are mapping a file and size = 0 then MapViewOfFile has mapped the entire file. We must\r\n // figure out the size ourselves before we can call SetPointer. Since in case of failure to\r\n // retrieve the size we raise an exception, we also have to explicitly unmap the view which\r\n // otherwise would have been done by the destructor.\r\n if (Size = 0) and (FileMap is TJclFileMapping) then\r\n begin\r\n Size := GetFileSize(TJclFileMapping(FileMap).FFileHandle, nil);\r\n if Size = DWORD(-1) then\r\n begin\r\n UnMapViewOfFile(BaseAddress);\r\n raise EJclFileMappingViewError.CreateRes(@RsFailedToObtainSize);\r\n end;\r\n end;\r\n SetPointer(BaseAddress, Size);\r\n FFileMapping.FViews.Add(Self);\r\nend;\r\n\r\ndestructor TJclFileMappingView.Destroy;\r\nvar\r\n IndexOfSelf: Integer;\r\nbegin\r\n if Memory <> nil then\r\n begin\r\n UnMapViewOfFile(Memory);\r\n SetPointer(nil, 0);\r\n end;\r\n if FFileMapping <> nil then\r\n begin\r\n IndexOfSelf := FFileMapping.IndexOf(Self);\r\n if IndexOfSelf <> -1 then\r\n FFileMapping.FViews.Delete(IndexOfSelf);\r\n end;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJclFileMappingView.Flush(const Count: Cardinal): Boolean;\r\nbegin\r\n Result := FlushViewOfFile(Memory, Count);\r\nend;\r\n\r\nfunction TJclFileMappingView.GetIndex: Integer;\r\nbegin\r\n Result := FFileMapping.IndexOf(Self);\r\nend;\r\n\r\nfunction TJclFileMappingView.GetOffset: Int64;\r\nbegin\r\n CardinalsToI64(Result, FOffsetLow, FOffsetHigh);\r\nend;\r\n\r\nprocedure TJclFileMappingView.LoadFromFile(const FileName: string);\r\nvar\r\n Stream: TFileStream;\r\nbegin\r\n Stream := TFileStream.Create(Filename, fmOpenRead or fmShareDenyWrite);\r\n try\r\n LoadFromStream(Stream);\r\n finally\r\n FreeAndNil(Stream);\r\n end;\r\nend;\r\n\r\nprocedure TJclFileMappingView.LoadFromStream(const Stream: TStream);\r\nbegin\r\n if Stream.Size > Size then\r\n raise EJclFileMappingViewError.CreateRes(@RsLoadFromStreamSize);\r\n Stream.Position := 0;\r\n Stream.ReadBuffer(Memory^, Stream.Size);\r\nend;\r\n\r\nfunction TJclFileMappingView.Write(const Buffer; Count: Integer): Longint;\r\nbegin\r\n Result := 0;\r\n if (Size - Position) >= Count then\r\n begin\r\n System.Move(Buffer, Pointer(TJclAddr(Memory) + TJclAddr(Position))^, Count);\r\n Position := Position + Count;\r\n Result := Count;\r\n end;\r\nend;\r\n\r\n//=== { TJclCustomFileMapping } ==============================================\r\n\r\nconstructor TJclCustomFileMapping.Create;\r\nbegin\r\n inherited Create;\r\n FViews := TList.Create;\r\n FRoundViewOffset := rvDown;\r\nend;\r\n\r\nconstructor TJclCustomFileMapping.Open(const Name: string;\r\n const InheritHandle: Boolean; const DesiredAccess: Cardinal);\r\nbegin\r\n Create;\r\n InternalOpen(Name, InheritHandle, DesiredAccess);\r\nend;\r\n\r\ndestructor TJclCustomFileMapping.Destroy;\r\nbegin\r\n ClearViews;\r\n if FHandle <> 0 then\r\n CloseHandle(FHandle);\r\n FreeAndNil(FViews);\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJclCustomFileMapping.Add(const Access, Count: Cardinal; const Offset: Int64): Integer;\r\nvar\r\n View: TJclFileMappingView;\r\nbegin\r\n // The view adds itself to the FViews list\r\n View := TJclFileMappingView.Create(Self, Access, Count, Offset);\r\n Result := View.Index;\r\nend;\r\n\r\nfunction TJclCustomFileMapping.AddAt(const Access, Count: Cardinal;\r\n const Offset: Int64; const Address: Pointer): Integer;\r\nvar\r\n View: TJclFileMappingView;\r\nbegin\r\n // The view adds itself to the FViews list\r\n View := TJclFileMappingView.CreateAt(Self, Access, Count, Offset, Address);\r\n Result := View.Index;\r\nend;\r\n\r\nprocedure TJclCustomFileMapping.ClearViews;\r\nvar\r\n I: Integer;\r\nbegin\r\n // Note that the view destructor removes the view object from the FViews list so we must loop\r\n // downwards from count to 0\r\n for I := FViews.Count - 1 downto 0 do\r\n TJclFileMappingView(FViews[I]).Free;\r\nend;\r\n\r\nprocedure TJclCustomFileMapping.Delete(const Index: Integer);\r\nbegin\r\n // Note that the view destructor removes itself from FViews\r\n TJclFileMappingView(FViews[Index]).Free;\r\nend;\r\n\r\nfunction TJclCustomFileMapping.GetCount: Integer;\r\nbegin\r\n Result := FViews.Count;\r\nend;\r\n\r\nfunction TJclCustomFileMapping.GetView(Index: Integer): TJclFileMappingView;\r\nbegin\r\n Result := TJclFileMappingView(FViews.Items[index]);\r\nend;\r\n\r\nfunction TJclCustomFileMapping.IndexOf(const View: TJclFileMappingView): Integer;\r\nbegin\r\n Result := FViews.IndexOf(View);\r\nend;\r\n\r\nprocedure TJclCustomFileMapping.InternalCreate(const FileHandle: THandle;\r\n const Name: string; const Protect: Cardinal; MaximumSize: Int64;\r\n SecAttr: PSecurityAttributes);\r\nvar\r\n MaximumSizeLow, MaximumSizeHigh: Cardinal;\r\nbegin\r\n FName := Name;\r\n I64ToCardinals(MaximumSize, MaximumSizeLow, MaximumSizeHigh);\r\n FHandle := CreateFileMapping(FileHandle, SecAttr, Protect, MaximumSizeHigh,\r\n MaximumSizeLow, PChar(Name));\r\n if FHandle = 0 then\r\n raise EJclFileMappingError.CreateRes(@RsCreateFileMapping);\r\n FExisted := GetLastError = ERROR_ALREADY_EXISTS;\r\nend;\r\n\r\nprocedure TJclCustomFileMapping.InternalOpen(const Name: string;\r\n const InheritHandle: Boolean; const DesiredAccess: Cardinal);\r\nbegin\r\n FExisted := True;\r\n FName := Name;\r\n FHandle := OpenFileMapping(DesiredAccess, InheritHandle, PChar(Name));\r\n if FHandle = 0 then\r\n raise EJclFileMappingError.CreateRes(@RsCreateFileMapping);\r\nend;\r\n\r\n//=== { TJclFileMapping } ====================================================\r\n\r\nconstructor TJclFileMapping.Create(const FileName: string; FileMode: Cardinal;\r\n const Name: string; Protect: Cardinal; const MaximumSize: Int64;\r\n SecAttr: PSecurityAttributes);\r\nbegin\r\n FFileHandle := INVALID_HANDLE_VALUE;\r\n inherited Create;\r\n FFileHandle := THandle(FileOpen(FileName, FileMode));\r\n if FFileHandle = INVALID_HANDLE_VALUE then\r\n raise EJclFileMappingError.CreateRes(@RsFileMappingOpenFile);\r\n InternalCreate(FFileHandle, Name, Protect, MaximumSize, SecAttr);\r\nend;\r\n\r\nconstructor TJclFileMapping.Create(const FileHandle: THandle; const Name: string;\r\n Protect: Cardinal; const MaximumSize: Int64; SecAttr: PSecurityAttributes);\r\nbegin\r\n FFileHandle := INVALID_HANDLE_VALUE;\r\n inherited Create;\r\n if FileHandle = INVALID_HANDLE_VALUE then\r\n raise EJclFileMappingError.CreateRes(@RsFileMappingInvalidHandle);\r\n InternalCreate(FileHandle, Name, Protect, MaximumSize, SecAttr);\r\n // Duplicate the handle into FFileHandle as opposed to assigning it directly. This will cause\r\n // FFileHandle to retrieve a unique copy which is independent of FileHandle. This makes the\r\n // remainder of the class, especially the destructor, easier. The caller will have to close it's\r\n // own copy of the handle explicitly.\r\n DuplicateHandle(GetCurrentProcess, FileHandle, GetCurrentProcess,\r\n @FFileHandle, 0, False, DUPLICATE_SAME_ACCESS);\r\nend;\r\n\r\ndestructor TJclFileMapping.Destroy;\r\nbegin\r\n if FFileHandle <> INVALID_HANDLE_VALUE then\r\n CloseHandle(FFileHandle);\r\n inherited Destroy;\r\nend;\r\n\r\n//=== { TJclSwapFileMapping } ================================================\r\n\r\nconstructor TJclSwapFileMapping.Create(const Name: string; Protect: Cardinal;\r\n const MaximumSize: Int64; SecAttr: PSecurityAttributes);\r\nbegin\r\n inherited Create;\r\n InternalCreate(INVALID_HANDLE_VALUE, Name, Protect, MaximumSize, SecAttr);\r\nend;\r\n\r\n//=== { TJclFileMappingStream } ==============================================\r\n\r\nconstructor TJclFileMappingStream.Create(const FileName: string; FileMode: Word);\r\nvar\r\n Protect, Access, Size: DWORD;\r\n BaseAddress: Pointer;\r\nbegin\r\n inherited Create;\r\n FFileHandle := THandle(FileOpen(FileName, FileMode));\r\n if FFileHandle = INVALID_HANDLE_VALUE then\r\n RaiseLastOSError;\r\n if (FileMode and $0F) = fmOpenReadWrite then\r\n begin\r\n Protect := PAGE_WRITECOPY;\r\n Access := FILE_MAP_COPY;\r\n end\r\n else\r\n begin\r\n Protect := PAGE_READONLY;\r\n Access := FILE_MAP_READ;\r\n end;\r\n FMapping := CreateFileMapping(FFileHandle, nil, Protect, 0, 0, nil);\r\n if FMapping = 0 then\r\n begin\r\n Close;\r\n raise EJclFileMappingError.CreateRes(@RsCreateFileMapping);\r\n end;\r\n BaseAddress := MapViewOfFile(FMapping, Access, 0, 0, 0);\r\n if BaseAddress = nil then\r\n begin\r\n Close;\r\n raise EJclFileMappingViewError.CreateRes(@RsCreateFileMappingView);\r\n end;\r\n Size := GetFileSize(FFileHandle, nil);\r\n if Size = DWORD(-1) then\r\n begin\r\n UnMapViewOfFile(BaseAddress);\r\n Close;\r\n raise EJclFileMappingViewError.CreateRes(@RsFailedToObtainSize);\r\n end;\r\n SetPointer(BaseAddress, Size);\r\nend;\r\n\r\ndestructor TJclFileMappingStream.Destroy;\r\nbegin\r\n Close;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJclFileMappingStream.Close;\r\nbegin\r\n if Memory <> nil then\r\n begin\r\n UnMapViewOfFile(Memory);\r\n SetPointer(nil, 0);\r\n end;\r\n if FMapping <> 0 then\r\n begin\r\n CloseHandle(FMapping);\r\n FMapping := 0;\r\n end;\r\n if FFileHandle <> INVALID_HANDLE_VALUE then\r\n begin\r\n FileClose(FFileHandle);\r\n FFileHandle := INVALID_HANDLE_VALUE;\r\n end;\r\nend;\r\n\r\nfunction TJclFileMappingStream.Write(const Buffer; Count: Integer): Longint;\r\nbegin\r\n Result := 0;\r\n if (Size - Position) >= Count then\r\n begin\r\n System.Move(Buffer, Pointer(TJclAddr(Memory) + TJclAddr(Position))^, Count);\r\n Position := Position + Count;\r\n Result := Count;\r\n end;\r\nend;\r\n\r\n{$ENDIF MSWINDOWS}\r\n\r\n//=== { TJclAnsiMappedTextReader } ===========================================\r\n\r\nconstructor TJclAnsiMappedTextReader.Create(MemoryStream: TCustomMemoryStream; FreeStream: Boolean;\r\n const AIndexOption: TJclMappedTextReaderIndex);\r\nbegin\r\n inherited Create;\r\n FMemoryStream := MemoryStream;\r\n FFreeStream := FreeStream;\r\n FIndexOption := AIndexOption;\r\n Init;\r\nend;\r\n\r\nconstructor TJclAnsiMappedTextReader.Create(const FileName: TFileName;\r\n const AIndexOption: TJclMappedTextReaderIndex);\r\nbegin\r\n inherited Create;\r\n {$IFDEF MSWINDOWS}\r\n FMemoryStream := TJclFileMappingStream.Create(FileName);\r\n {$ELSE ~ MSWINDOWS}\r\n FMemoryStream := TMemoryStream.Create;\r\n TMemoryStream(FMemoryStream).LoadFromFile(FileName);\r\n {$ENDIF ~ MSWINDOWS}\r\n FFreeStream := True;\r\n FIndexOption := AIndexOption;\r\n Init;\r\nend;\r\n\r\ndestructor TJclAnsiMappedTextReader.Destroy;\r\nbegin\r\n if FFreeStream then\r\n FMemoryStream.Free;\r\n FreeMem(FIndex);\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJclAnsiMappedTextReader.AssignTo(Dest: TPersistent);\r\nbegin\r\n if Dest is TStrings then\r\n begin\r\n GoBegin;\r\n TStrings(Dest).BeginUpdate;\r\n try\r\n while not Eof do\r\n TStrings(Dest).Add(string(ReadLn));\r\n finally\r\n TStrings(Dest).EndUpdate;\r\n end;\r\n end\r\n else\r\n inherited AssignTo(Dest);\r\nend;\r\n\r\nprocedure TJclAnsiMappedTextReader.CreateIndex;\r\nvar\r\n P, LastLineStart: PAnsiChar;\r\n I: Integer;\r\nbegin\r\n {$RANGECHECKS OFF}\r\n P := FContent;\r\n I := 0;\r\n LastLineStart := P;\r\n while P < FEnd do\r\n begin\r\n // CRLF, CR, LF and LFCR are seen as valid sets of chars for EOL marker\r\n if CharIsReturn(Char(P^)) then\r\n begin\r\n if I and $FFFF = 0 then\r\n ReallocMem(FIndex, (I + $10000) * SizeOf(Pointer));\r\n FIndex[I] := LastLineStart;\r\n Inc(I);\r\n\r\n case P^ of\r\n NativeLineFeed:\r\n begin\r\n Inc(P);\r\n if (P < FEnd) and (P^ = NativeCarriageReturn) then\r\n Inc(P);\r\n end;\r\n NativeCarriageReturn:\r\n begin\r\n Inc(P);\r\n if (P < FEnd) and (P^ = NativeLineFeed) then\r\n Inc(P);\r\n end;\r\n end;\r\n LastLineStart := P;\r\n end\r\n else\r\n Inc(P);\r\n end;\r\n if P > LastLineStart then\r\n begin\r\n ReallocMem(FIndex, (I + 1) * SizeOf(Pointer));\r\n FIndex[I] := LastLineStart;\r\n Inc(I);\r\n end\r\n else\r\n ReallocMem(FIndex, I * SizeOf(Pointer));\r\n FLineCount := I;\r\n {$IFDEF RANGECHECKS_ON}\r\n {$RANGECHECKS ON}\r\n {$ENDIF RANGECHECKS_ON}\r\nend;\r\n\r\nfunction TJclAnsiMappedTextReader.GetEof: Boolean;\r\nbegin\r\n Result := FPosition >= FEnd;\r\nend;\r\n\r\nfunction TJclAnsiMappedTextReader.GetAsString: AnsiString;\r\nbegin\r\n SetString(Result, Content, Size);\r\nend;\r\n\r\nfunction TJclAnsiMappedTextReader.GetChars(Index: Integer): AnsiChar;\r\nbegin\r\n if (Index < 0) or (Index >= Size) then\r\n raise EJclError.CreateRes(@RsFileIndexOutOfRange);\r\n Result := AnsiChar(PByte(FContent + Index)^);\r\nend;\r\n\r\nfunction TJclAnsiMappedTextReader.GetLineCount: Integer;\r\nvar\r\n P: PAnsiChar;\r\nbegin\r\n if FLineCount = -1 then\r\n begin\r\n FLineCount := 0;\r\n if FContent < FEnd then\r\n begin\r\n P := FContent;\r\n while P < FEnd do\r\n begin\r\n case P^ of\r\n NativeLineFeed:\r\n begin\r\n Inc(FLineCount);\r\n Inc(P);\r\n if (P < FEnd) and (P^ = NativeCarriageReturn) then\r\n Inc(P);\r\n end;\r\n NativeCarriageReturn:\r\n begin\r\n Inc(FLineCount);\r\n Inc(P);\r\n if (P < FEnd) and (P^ = NativeLineFeed) then\r\n Inc(P);\r\n end;\r\n else\r\n Inc(P);\r\n end;\r\n end;\r\n if (P = FEnd) and (P > FContent) and not CharIsReturn(Char((P-1)^)) then\r\n Inc(FLineCount);\r\n end;\r\n end;\r\n\r\n Result := FLineCount;\r\nend;\r\n\r\nfunction TJclAnsiMappedTextReader.GetLines(LineNumber: Integer): AnsiString;\r\nvar\r\n P: PAnsiChar;\r\nbegin\r\n P := PtrFromLine(LineNumber);\r\n Result := StringFromPosition(P);\r\nend;\r\n\r\nfunction TJclAnsiMappedTextReader.GetPosition: Integer;\r\nbegin\r\n Result := FPosition - FContent;\r\nend;\r\n\r\nprocedure TJclAnsiMappedTextReader.GoBegin;\r\nbegin\r\n Position := 0;\r\nend;\r\n\r\nprocedure TJclAnsiMappedTextReader.Init;\r\nbegin\r\n FContent := FMemoryStream.Memory;\r\n FSize := FMemoryStream.Size;\r\n FEnd := FContent + FSize;\r\n FPosition := FContent;\r\n FLineCount := -1;\r\n FLastLineNumber := 0;\r\n FLastPosition := FContent;\r\n if IndexOption = tiFull then\r\n CreateIndex;\r\nend;\r\n\r\nfunction TJclAnsiMappedTextReader.GetPositionFromLine(LineNumber: Integer): Integer;\r\nvar\r\n P: PAnsiChar;\r\nbegin\r\n P := PtrFromLine(LineNumber);\r\n if P = nil then\r\n Result := -1\r\n else\r\n Result := P - FContent;\r\nend;\r\n\r\nfunction TJclAnsiMappedTextReader.PtrFromLine(LineNumber: Integer): PAnsiChar;\r\nvar\r\n LineOffset: Integer;\r\nbegin\r\n Result := nil;\r\n {$RANGECHECKS OFF}\r\n if (IndexOption <> tiNoIndex) and (LineNumber < FLineCount) and (FIndex[LineNumber] <> nil) then\r\n Result := FIndex[LineNumber]\r\n {$IFDEF RANGECHECKS_ON}\r\n {$RANGECHECKS ON}\r\n {$ENDIF RANGECHECKS_ON}\r\n else\r\n begin\r\n LineOffset := LineNumber - FLastLineNumber;\r\n if (FLineCount <> -1) and (LineNumber > 0) then\r\n begin\r\n if -LineOffset > LineNumber then\r\n begin\r\n FLastLineNumber := 0;\r\n FLastPosition := FContent;\r\n LineOffset := LineNumber;\r\n end\r\n else\r\n if LineOffset > FLineCount - LineNumber then\r\n begin\r\n FLastLineNumber := FLineCount;\r\n FLastPosition := FEnd;\r\n LineOffset := LineNumber - FLineCount;\r\n end;\r\n end;\r\n if LineNumber <= 0 then\r\n Result := FContent\r\n else\r\n if LineOffset = 0 then\r\n Result := FLastPosition\r\n else\r\n if LineOffset > 0 then\r\n begin\r\n Result := FLastPosition;\r\n while (Result < FEnd) and (LineOffset > 0) do\r\n begin\r\n case Result^ of\r\n NativeLineFeed:\r\n begin\r\n Dec(LineOffset);\r\n Inc(Result);\r\n if (Result < FEnd) and (Result^ = NativeCarriageReturn) then\r\n Inc(Result);\r\n end;\r\n NativeCarriageReturn:\r\n begin\r\n Dec(LineOffset);\r\n Inc(Result);\r\n if (Result < FEnd) and (Result^ = NativeLineFeed) then\r\n Inc(Result);\r\n end;\r\n else\r\n Inc(Result);\r\n end;\r\n end;\r\n end\r\n else\r\n if LineOffset < 0 then\r\n begin\r\n Result := FLastPosition;\r\n while (Result > FContent) and (LineOffset < 1) do\r\n begin\r\n Dec(Result);\r\n case Result^ of\r\n NativeLineFeed:\r\n begin\r\n Inc(LineOffset);\r\n if LineOffset >= 1 then\r\n Inc(Result)\r\n else\r\n if (Result > FContent) and ((Result-1)^ = NativeCarriageReturn) then\r\n Dec(Result);\r\n end;\r\n NativeCarriageReturn:\r\n begin\r\n Inc(LineOffset);\r\n if LineOffset >= 1 then\r\n Inc(Result)\r\n else\r\n if (Result > FContent) and ((Result-1)^ = NativeLineFeed) then\r\n Dec(Result);\r\n end;\r\n end;\r\n end;\r\n end;\r\n FLastLineNumber := LineNumber;\r\n FLastPosition := Result;\r\n end;\r\nend;\r\n\r\nfunction TJclAnsiMappedTextReader.Read: AnsiChar;\r\nbegin\r\n if FPosition >= FEnd then\r\n Result := #0\r\n else\r\n begin\r\n Result := FPosition^;\r\n Inc(FPosition);\r\n end;\r\nend;\r\n\r\nfunction TJclAnsiMappedTextReader.ReadLn: AnsiString;\r\nbegin\r\n Result := StringFromPosition(FPosition);\r\nend;\r\n\r\nprocedure TJclAnsiMappedTextReader.SetPosition(const Value: Integer);\r\nbegin\r\n FPosition := FContent + Value;\r\nend;\r\n\r\nfunction TJclAnsiMappedTextReader.StringFromPosition(var StartPos: PAnsiChar): AnsiString;\r\nvar\r\n P: PAnsiChar;\r\nbegin\r\n if (StartPos = nil) or (StartPos >= FEnd) then\r\n Result := ''\r\n else\r\n begin\r\n P := StartPos;\r\n while (P < FEnd) and (not CharIsReturn(Char(P^))) do\r\n Inc(P);\r\n SetString(Result, StartPos, P - StartPos);\r\n if P < FEnd then\r\n begin\r\n case P^ of\r\n NativeLineFeed:\r\n begin\r\n Inc(P);\r\n if (P < FEnd) and (P^ = NativeCarriageReturn) then\r\n Inc(P);\r\n end;\r\n NativeCarriageReturn:\r\n begin\r\n Inc(P);\r\n if (P < FEnd) and (P^ = NativeLineFeed) then\r\n Inc(P);\r\n end;\r\n end;\r\n end;\r\n StartPos := P;\r\n end;\r\nend;\r\n\r\n//=== { TJclWideMappedTextReader } ===========================================\r\n\r\nconstructor TJclWideMappedTextReader.Create(MemoryStream: TCustomMemoryStream; FreeStream: Boolean;\r\n const AIndexOption: TJclMappedTextReaderIndex);\r\nbegin\r\n inherited Create;\r\n FMemoryStream := MemoryStream;\r\n FFreeStream := FreeStream;\r\n FIndexOption := AIndexOption;\r\n Init;\r\nend;\r\n\r\nconstructor TJclWideMappedTextReader.Create(const FileName: TFileName;\r\n const AIndexOption: TJclMappedTextReaderIndex);\r\nbegin\r\n inherited Create;\r\n {$IFDEF MSWINDOWS}\r\n FMemoryStream := TJclFileMappingStream.Create(FileName);\r\n {$ELSE ~ MSWINDOWS}\r\n FMemoryStream := TMemoryStream.Create;\r\n TMemoryStream(FMemoryStream).LoadFromFile(FileName);\r\n {$ENDIF ~ MSWINDOWS}\r\n FFreeStream := True;\r\n FIndexOption := AIndexOption;\r\n Init;\r\nend;\r\n\r\ndestructor TJclWideMappedTextReader.Destroy;\r\nbegin\r\n if FFreeStream then\r\n FMemoryStream.Free;\r\n FreeMem(FIndex);\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJclWideMappedTextReader.AssignTo(Dest: TPersistent);\r\nbegin\r\n if Dest is TStrings then\r\n begin\r\n GoBegin;\r\n TStrings(Dest).BeginUpdate;\r\n try\r\n while not Eof do\r\n TStrings(Dest).Add(string(ReadLn));\r\n finally\r\n TStrings(Dest).EndUpdate;\r\n end;\r\n end\r\n else\r\n inherited AssignTo(Dest);\r\nend;\r\n\r\nprocedure TJclWideMappedTextReader.CreateIndex;\r\nvar\r\n P, LastLineStart: PWideChar;\r\n I: Integer;\r\nbegin\r\n {$RANGECHECKS OFF}\r\n P := FContent;\r\n I := 0;\r\n LastLineStart := P;\r\n while P < FEnd do\r\n begin\r\n // CRLF, CR, LF and LFCR are seen as valid sets of chars for EOL marker\r\n if CharIsReturn(Char(P^)) then\r\n begin\r\n if I and $FFFF = 0 then\r\n ReallocMem(FIndex, (I + $10000) * SizeOf(Pointer));\r\n FIndex[I] := LastLineStart;\r\n Inc(I);\r\n\r\n case P^ of\r\n NativeLineFeed:\r\n begin\r\n Inc(P);\r\n if (P < FEnd) and (P^ = NativeCarriageReturn) then\r\n Inc(P);\r\n end;\r\n NativeCarriageReturn:\r\n begin\r\n Inc(P);\r\n if (P < FEnd) and (P^ = NativeLineFeed) then\r\n Inc(P);\r\n end;\r\n end;\r\n LastLineStart := P;\r\n end\r\n else\r\n Inc(P);\r\n end;\r\n if P > LastLineStart then\r\n begin\r\n ReallocMem(FIndex, (I + 1) * SizeOf(Pointer));\r\n FIndex[I] := LastLineStart;\r\n Inc(I);\r\n end\r\n else\r\n ReallocMem(FIndex, I * SizeOf(Pointer));\r\n FLineCount := I;\r\n {$IFDEF RANGECHECKS_ON}\r\n {$RANGECHECKS ON}\r\n {$ENDIF RANGECHECKS_ON}\r\nend;\r\n\r\nfunction TJclWideMappedTextReader.GetEof: Boolean;\r\nbegin\r\n Result := FPosition >= FEnd;\r\nend;\r\n\r\nfunction TJclWideMappedTextReader.GetAsString: WideString;\r\nbegin\r\n SetString(Result, Content, Size);\r\nend;\r\n\r\nfunction TJclWideMappedTextReader.GetChars(Index: Integer): WideChar;\r\nbegin\r\n if (Index < 0) or (Index >= Size) then\r\n raise EJclError.CreateRes(@RsFileIndexOutOfRange);\r\n Result := WideChar(PByte(FContent + Index)^);\r\nend;\r\n\r\nfunction TJclWideMappedTextReader.GetLineCount: Integer;\r\nvar\r\n P: PWideChar;\r\nbegin\r\n if FLineCount = -1 then\r\n begin\r\n FLineCount := 0;\r\n if FContent < FEnd then\r\n begin\r\n P := FContent;\r\n while P < FEnd do\r\n begin\r\n case P^ of\r\n NativeLineFeed:\r\n begin\r\n Inc(FLineCount);\r\n Inc(P);\r\n if (P < FEnd) and (P^ = NativeCarriageReturn) then\r\n Inc(P);\r\n end;\r\n NativeCarriageReturn:\r\n begin\r\n Inc(FLineCount);\r\n Inc(P);\r\n if (P < FEnd) and (P^ = NativeLineFeed) then\r\n Inc(P);\r\n end;\r\n else\r\n Inc(P);\r\n end;\r\n end;\r\n if (P = FEnd) and (P > FContent) and not CharIsReturn(Char((P-1)^)) then\r\n Inc(FLineCount);\r\n end;\r\n end;\r\n\r\n Result := FLineCount;\r\nend;\r\n\r\nfunction TJclWideMappedTextReader.GetLines(LineNumber: Integer): WideString;\r\nvar\r\n P: PWideChar;\r\nbegin\r\n P := PtrFromLine(LineNumber);\r\n Result := StringFromPosition(P);\r\nend;\r\n\r\nfunction TJclWideMappedTextReader.GetPosition: Integer;\r\nbegin\r\n Result := FPosition - FContent;\r\nend;\r\n\r\nprocedure TJclWideMappedTextReader.GoBegin;\r\nbegin\r\n Position := 0;\r\nend;\r\n\r\nprocedure TJclWideMappedTextReader.Init;\r\nbegin\r\n FContent := FMemoryStream.Memory;\r\n FSize := FMemoryStream.Size;\r\n FEnd := FContent + FSize;\r\n FPosition := FContent;\r\n FLineCount := -1;\r\n FLastLineNumber := 0;\r\n FLastPosition := FContent;\r\n if IndexOption = tiFull then\r\n CreateIndex;\r\nend;\r\n\r\nfunction TJclWideMappedTextReader.GetPositionFromLine(LineNumber: Integer): Integer;\r\nvar\r\n P: PWideChar;\r\nbegin\r\n P := PtrFromLine(LineNumber);\r\n if P = nil then\r\n Result := -1\r\n else\r\n Result := P - FContent;\r\nend;\r\n\r\nfunction TJclWideMappedTextReader.PtrFromLine(LineNumber: Integer): PWideChar;\r\nvar\r\n LineOffset: Integer;\r\nbegin\r\n Result := nil;\r\n {$RANGECHECKS OFF}\r\n if (IndexOption <> tiNoIndex) and (LineNumber < FLineCount) and (FIndex[LineNumber] <> nil) then\r\n Result := FIndex[LineNumber]\r\n {$IFDEF RANGECHECKS_ON}\r\n {$RANGECHECKS ON}\r\n {$ENDIF RANGECHECKS_ON}\r\n else\r\n begin\r\n LineOffset := LineNumber - FLastLineNumber;\r\n if (FLineCount <> -1) and (LineNumber > 0) then\r\n begin\r\n if -LineOffset > LineNumber then\r\n begin\r\n FLastLineNumber := 0;\r\n FLastPosition := FContent;\r\n LineOffset := LineNumber;\r\n end\r\n else\r\n if LineOffset > FLineCount - LineNumber then\r\n begin\r\n FLastLineNumber := FLineCount;\r\n FLastPosition := FEnd;\r\n LineOffset := LineNumber - FLineCount;\r\n end;\r\n end;\r\n if LineNumber <= 0 then\r\n Result := FContent\r\n else\r\n if LineOffset = 0 then\r\n Result := FLastPosition\r\n else\r\n if LineOffset > 0 then\r\n begin\r\n Result := FLastPosition;\r\n while (Result < FEnd) and (LineOffset > 0) do\r\n begin\r\n case Result^ of\r\n NativeLineFeed:\r\n begin\r\n Dec(LineOffset);\r\n Inc(Result);\r\n if (Result < FEnd) and (Result^ = NativeCarriageReturn) then\r\n Inc(Result);\r\n end;\r\n NativeCarriageReturn:\r\n begin\r\n Dec(LineOffset);\r\n Inc(Result);\r\n if (Result < FEnd) and (Result^ = NativeLineFeed) then\r\n Inc(Result);\r\n end;\r\n else\r\n Inc(Result);\r\n end;\r\n end;\r\n end\r\n else\r\n if LineOffset < 0 then\r\n begin\r\n Result := FLastPosition;\r\n while (Result > FContent) and (LineOffset < 1) do\r\n begin\r\n Dec(Result);\r\n case Result^ of\r\n NativeLineFeed:\r\n begin\r\n Inc(LineOffset);\r\n if LineOffset >= 1 then\r\n Inc(Result)\r\n else\r\n if (Result > FContent) and ((Result-1)^ = NativeCarriageReturn) then\r\n Dec(Result);\r\n end;\r\n NativeCarriageReturn:\r\n begin\r\n Inc(LineOffset);\r\n if LineOffset >= 1 then\r\n Inc(Result)\r\n else\r\n if (Result > FContent) and ((Result-1)^ = NativeLineFeed) then\r\n Dec(Result);\r\n end;\r\n end;\r\n end;\r\n end;\r\n FLastLineNumber := LineNumber;\r\n FLastPosition := Result;\r\n end;\r\nend;\r\n\r\nfunction TJclWideMappedTextReader.Read: WideChar;\r\nbegin\r\n if FPosition >= FEnd then\r\n Result := #0\r\n else\r\n begin\r\n Result := FPosition^;\r\n Inc(FPosition);\r\n end;\r\nend;\r\n\r\nfunction TJclWideMappedTextReader.ReadLn: WideString;\r\nbegin\r\n Result := StringFromPosition(FPosition);\r\nend;\r\n\r\nprocedure TJclWideMappedTextReader.SetPosition(const Value: Integer);\r\nbegin\r\n FPosition := FContent + Value;\r\nend;\r\n\r\nfunction TJclWideMappedTextReader.StringFromPosition(var StartPos: PWideChar): WideString;\r\nvar\r\n P: PWideChar;\r\nbegin\r\n if (StartPos = nil) or (StartPos >= FEnd) then\r\n Result := ''\r\n else\r\n begin\r\n P := StartPos;\r\n while (P < FEnd) and (not CharIsReturn(Char(P^))) do\r\n Inc(P);\r\n SetString(Result, StartPos, P - StartPos);\r\n if P < FEnd then\r\n begin\r\n case P^ of\r\n NativeLineFeed:\r\n begin\r\n Inc(P);\r\n if (P < FEnd) and (P^ = NativeCarriageReturn) then\r\n Inc(P);\r\n end;\r\n NativeCarriageReturn:\r\n begin\r\n Inc(P);\r\n if (P < FEnd) and (P^ = NativeLineFeed) then\r\n Inc(P);\r\n end;\r\n end;\r\n end;\r\n StartPos := P;\r\n end;\r\nend;\r\n\r\nfunction CharIsDriveLetter(const C: Char): Boolean;\r\nbegin\r\n case C of\r\n 'a'..'z',\r\n 'A'..'Z':\r\n Result := True;\r\n else\r\n Result := False;\r\n end;\r\nend;\r\n\r\n//=== Path manipulation ======================================================\r\n\r\nfunction PathAddSeparator(const Path: string): string;\r\nbegin\r\n Result := Path;\r\n if (Path = '') or (Path[Length(Path)] <> DirDelimiter) then\r\n Result := Path + DirDelimiter;\r\nend;\r\n\r\nfunction PathAddExtension(const Path, Extension: string): string;\r\nbegin\r\n Result := Path;\r\n // (obones) Extension may not contain the leading dot while ExtractFileExt\r\n // always returns it. Hence the need to use StrEnsurePrefix for the SameText\r\n // test to return an accurate value.\r\n if (Path <> '') and (Extension <> '') and\r\n not SameText(ExtractFileExt(Path), StrEnsurePrefix('.', Extension)) then\r\n begin\r\n if Path[Length(Path)] = '.' then\r\n Delete(Result, Length(Path), 1);\r\n if Extension[1] = '.' then\r\n Result := Result + Extension\r\n else\r\n Result := Result + '.' + Extension;\r\n end;\r\nend;\r\n\r\nfunction PathAppend(const Path, Append: string): string;\r\nvar\r\n PathLength: Integer;\r\n B1, B2: Boolean;\r\nbegin\r\n if Append = '' then\r\n Result := Path\r\n else\r\n begin\r\n PathLength := Length(Path);\r\n if PathLength = 0 then\r\n Result := Append\r\n else\r\n begin\r\n // The following code may look a bit complex but all it does is add Append to Path ensuring\r\n // that there is one and only one path separator character between them\r\n B1 := Path[PathLength] = DirDelimiter;\r\n B2 := Append[1] = DirDelimiter;\r\n if B1 and B2 then\r\n Result := Copy(Path, 1, PathLength - 1) + Append\r\n else\r\n begin\r\n if not (B1 or B2) then\r\n Result := Path + DirDelimiter + Append\r\n else\r\n Result := Path + Append;\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction PathBuildRoot(const Drive: Byte): string;\r\nbegin\r\n {$IFDEF UNIX}\r\n Result := DirDelimiter;\r\n {$ENDIF UNIX}\r\n {$IFDEF MSWINDOWS}\r\n // Remember, Win32 only allows 'a' to 'z' as drive letters (mapped to 0..25)\r\n if Drive < 26 then\r\n Result := Char(Drive + 65) + ':\\'\r\n else\r\n raise EJclPathError.CreateResFmt(@RsPathInvalidDrive, [IntToStr(Drive)]);\r\n {$ENDIF MSWINDOWS}\r\nend;\r\n\r\nfunction PathCanonicalize(const Path: string): string;\r\nvar\r\n List: TStringList;\r\n S: string;\r\n I, K: Integer;\r\n IsAbsolute: Boolean;\r\nbegin\r\n I := Pos(':', Path); // for Windows' sake\r\n K := Pos(DirDelimiter, Path);\r\n IsAbsolute := K - I = 1;\r\n if IsAbsolute then begin\r\n if Copy(Path, 1, Length(PathUncPrefix)) = PathUncPrefix then // UNC path\r\n K := 2;\r\n end else\r\n K := I;\r\n if K = 0 then\r\n S := Path\r\n else\r\n S := Copy(Path, K + 1, Length(Path));\r\n List := TStringList.Create;\r\n try\r\n StrIToStrings(S, DirDelimiter, List, True);\r\n I := 0;\r\n while I < List.Count do\r\n begin\r\n if List[I] = '.' then\r\n List.Delete(I)\r\n else\r\n if (IsAbsolute or (I > 0) and not (List[I-1] = '..')) and (List[I] = '..') then\r\n begin\r\n List.Delete(I);\r\n if I > 0 then\r\n begin\r\n Dec(I);\r\n List.Delete(I);\r\n end;\r\n end\r\n else Inc(I);\r\n end;\r\n Result := StringsToStr(List, DirDelimiter, True);\r\n finally\r\n List.Free;\r\n end;\r\n if K > 0 then\r\n Result := Copy(Path, 1, K) + Result\r\n else\r\n if Result = '' then\r\n Result := '.';\r\nend;\r\n\r\nfunction PathCommonPrefix(const Path1, Path2: string): Integer;\r\nvar\r\n Index1, Index2: Integer;\r\n LastSeparator, LenS1: Integer;\r\n S1, S2: string;\r\nbegin\r\n Result := 0;\r\n if (Path1 <> '') and (Path2 <> '') then\r\n begin\r\n // Initialize P1 to the shortest of the two paths so that the actual comparison loop below can\r\n // use the terminating #0 of that string to terminate the loop.\r\n if Length(Path1) <= Length(Path2) then\r\n begin\r\n S1 := Path1;\r\n S2 := Path2;\r\n end\r\n else\r\n begin\r\n S1 := Path2;\r\n S2 := Path1;\r\n end;\r\n Index1 := 1;\r\n Index2 := 1;\r\n LenS1 := Length(S1);\r\n LastSeparator := 0;\r\n while (S1[Index1] = S2[Index2]) and (Index1 <= LenS1) do\r\n begin\r\n Inc(Result);\r\n if (S1[Index1] = DirDelimiter) or (S1[Index1] = ':') then\r\n LastSeparator := Result;\r\n Inc(Index1);\r\n Inc(Index2);\r\n end;\r\n if (LastSeparator < Result) and (Index1 <= LenS1) then\r\n Result := LastSeparator;\r\n end;\r\nend;\r\n\r\n{$IFDEF MSWINDOWS}\r\nfunction PathCompactPath(const DC: HDC; const Path: string;\r\n const Width: Integer; CmpFmt: TCompactPath): string;\r\nconst\r\n Compacts: array [TCompactPath] of Cardinal = (DT_PATH_ELLIPSIS, DT_END_ELLIPSIS);\r\nvar\r\n TextRect: TRect;\r\n Fmt: Cardinal;\r\nbegin\r\n Result := '';\r\n if (DC <> 0) and (Path <> '') and (Width > 0) then\r\n begin\r\n { Here's a note from the Platform SDK to explain the + 5 in the call below:\r\n \"If dwDTFormat includes DT_MODIFYSTRING, the function could add up to four additional characters\r\n to this string. The buffer containing the string should be large enough to accommodate these\r\n extra characters.\" }\r\n SetString(Result, PChar(Path), Length(Path) + 4);\r\n TextRect := Rect(0, 0, Width, 255);\r\n Fmt := DT_MODIFYSTRING or DT_CALCRECT or Compacts[CmpFmt];\r\n if DrawTextEx(DC, PChar(Result), -1, TextRect, Fmt, nil) <> 0 then\r\n StrResetLength(Result)\r\n else\r\n Result := ''; // in case of error\r\n end;\r\nend;\r\n{$ENDIF MSWINDOWS}\r\n\r\nprocedure PathExtractElements(const Source: string; var Drive, Path, FileName, Ext: string);\r\nbegin\r\n Drive := ExtractFileDrive(Source);\r\n Path := ExtractFilePath(Source);\r\n // Path includes drive so remove that\r\n if Drive <> '' then\r\n Delete(Path, 1, Length(Drive));\r\n // add/remove separators\r\n Drive := PathAddSeparator(Drive);\r\n Path := PathRemoveSeparator(Path);\r\n if (Path <> '') and (Path[1] = DirDelimiter) then\r\n Delete(Path, 1, 1);\r\n // and extract the remaining elements\r\n FileName := PathExtractFileNameNoExt(Source);\r\n Ext := ExtractFileExt(Source);\r\nend;\r\n\r\nfunction PathExtractFileDirFixed(const S: string): string;\r\nbegin\r\n Result := PathAddSeparator(ExtractFileDir(S));\r\nend;\r\n\r\nfunction PathExtractFileNameNoExt(const Path: string): string;\r\nbegin\r\n Result := PathRemoveExtension(ExtractFileName(Path));\r\nend;\r\n\r\nfunction PathExtractPathDepth(const Path: string; Depth: Integer): string;\r\nvar\r\n List: TStringList;\r\n LocalPath: string;\r\n I: Integer;\r\nbegin\r\n List := TStringList.Create;\r\n try\r\n if IsDirectory(Path) then\r\n LocalPath := Path\r\n else\r\n LocalPath := ExtractFilePath(Path);\r\n StrIToStrings(LocalPath, DirDelimiter, List, True);\r\n I := Depth + 1;\r\n if PathIsUNC(LocalPath) then\r\n I := I + 2;\r\n while I < List.Count do\r\n List.Delete(I);\r\n Result := PathAddSeparator(StringsToStr(List, DirDelimiter, True));\r\n finally\r\n List.Free;\r\n end;\r\nend;\r\n\r\n// Notes: maybe this function should first apply PathCanonicalize() ?\r\n\r\nfunction PathGetDepth(const Path: string): Integer;\r\nvar\r\n List: TStringList;\r\n LocalPath: string;\r\n I, Start: Integer;\r\nbegin\r\n Result := 0;\r\n List := TStringList.Create;\r\n try\r\n if IsDirectory(Path) then\r\n LocalPath := Path\r\n else\r\n LocalPath := ExtractFilePath(Path);\r\n StrIToStrings(LocalPath, DirDelimiter, List, False);\r\n if PathIsUNC(LocalPath) then\r\n Start := 1\r\n else\r\n Start := 0;\r\n for I := Start to List.Count - 1 do\r\n begin\r\n if Pos(':', List[I]) = 0 then\r\n Inc(Result);\r\n end;\r\n finally\r\n List.Free;\r\n end;\r\nend;\r\n\r\n{$IFDEF MSWINDOWS}\r\n\r\nfunction ShellGetLongPathName(const Path: string): string;\r\n{$IFDEF FPC}\r\n// As of 2004-10-17, FPC's ShlObj unit is just a dummy\r\nbegin\r\n Result := Path;\r\nend;\r\n{$ElSE ~FPC}\r\nvar\r\n PIDL: PItemIDList;\r\n Desktop: IShellFolder;\r\n {$IFNDEF SUPPORTS_UNICODE}\r\n AnsiName: string;\r\n WideName: array [0..MAX_PATH] of WideChar;\r\n {$ENDIF ~SUPPORTS_UNICODE}\r\n Eaten, Attr: ULONG; // both unused but API requires them (incorrect translation)\r\nbegin\r\n Result := Path;\r\n if Path <> '' then\r\n begin\r\n if Succeeded(SHGetDesktopFolder(Desktop)) then\r\n begin\r\n {$IFDEF SUPPORTS_UNICODE}\r\n if Succeeded(Desktop.ParseDisplayName(0, nil, PChar(Path), Eaten, PIDL, Attr)) then\r\n try\r\n SetLength(Result, MAX_PATH);\r\n if SHGetPathFromIDList(PIDL, PChar(Result)) then\r\n StrResetLength(Result);\r\n finally\r\n CoTaskMemFree(PIDL);\r\n end;\r\n {$ELSE ~SUPPORTS_UNICODE}\r\n MultiByteToWideChar(CP_ACP, MB_PRECOMPOSED, PAnsiChar(Path), -1, WideName, MAX_PATH);\r\n if Succeeded(Desktop.ParseDisplayName(0, nil, WideName, Eaten, PIDL, Attr)) then\r\n try\r\n SetLength(AnsiName, MAX_PATH);\r\n if SHGetPathFromIDList(PIDL, PChar(AnsiName)) then\r\n StrResetLength(AnsiName);\r\n Result := AnsiName;\r\n finally\r\n CoTaskMemFree(PIDL);\r\n end;\r\n {$ENDIF ~SUPPORTS_UNICODE}\r\n end;\r\n end;\r\nend;\r\n{$ENDIF ~FPC}\r\n\r\n{ TODO : Move RTDL code over to JclWin32 when JclWin32 gets overhauled. }\r\nvar\r\n _Kernel32Handle: TModuleHandle = INVALID_MODULEHANDLE_VALUE;\r\n _GetLongPathName: function (lpszShortPath: PChar; lpszLongPath: PChar;\r\n cchBuffer: DWORD): DWORD; stdcall;\r\n\r\nfunction Kernel32Handle: HMODULE;\r\nbegin\r\n JclSysUtils.LoadModule(_Kernel32Handle, kernel32);\r\n Result := _Kernel32Handle;\r\nend;\r\n\r\nfunction RtdlGetLongPathName(const Path: string): string;\r\nbegin\r\n Result := Path;\r\n if not Assigned(_GetLongPathName) then\r\n _GetLongPathName := GetModuleSymbol(Kernel32Handle, 'GetLongPathName' + AWSuffix);\r\n if not Assigned(_GetLongPathName) then\r\n Result := ShellGetLongPathName(Path)\r\n else\r\n begin\r\n SetLength(Result, MAX_PATH);\r\n SetLength(Result, _GetLongPathName(PChar(Path), PChar(Result), MAX_PATH));\r\n end;\r\nend;\r\n\r\nfunction PathGetLongName(const Path: string): string;\r\nbegin\r\n if Pos('::', Path) > 0 then // Path contains '::{}'\r\n Result := ShellGetLongPathName(Path)\r\n else\r\n Result := RtdlGetLongPathName(Path);\r\n\r\n if Result = '' then\r\n Result := Path;\r\nend;\r\n\r\nfunction PathGetShortName(const Path: string): string;\r\nvar\r\n Required: Integer;\r\nbegin\r\n Result := Path;\r\n Required := GetShortPathName(PChar(Path), nil, 0);\r\n if Required <> 0 then\r\n begin\r\n SetLength(Result, Required);\r\n Required := GetShortPathName(PChar(Path), PChar(Result), Required);\r\n if (Required <> 0) and (Required = Length(Result) - 1) then\r\n SetLength(Result, Required)\r\n else\r\n Result := Path;\r\n end;\r\nend;\r\n\r\n{$ENDIF MSWINDOWS}\r\n\r\nfunction PathGetRelativePath(Origin, Destination: string): string;\r\nvar\r\n {$IFDEF MSWINDOWS}\r\n OrigDrive: string;\r\n DestDrive: string;\r\n {$ENDIF MSWINDOWS}\r\n OrigList: TStringList;\r\n DestList: TStringList;\r\n DiffIndex: Integer;\r\n I: Integer;\r\n\r\n function StartsFromRoot(const Path: string): Boolean;\r\n {$IFDEF MSWINDOWS}\r\n var\r\n I: Integer;\r\n begin\r\n I := Length(ExtractFileDrive(Path));\r\n Result := (Length(Path) > I) and (Path[I + 1] = DirDelimiter);\r\n end;\r\n {$ELSE ~MSWINDOWS}\r\n begin\r\n Result := Pos(DirDelimiter, Path) = 1;\r\n end;\r\n {$ENDIF ~MSWINDOWS}\r\n\r\n function Equal(const Path1, Path2: string): Boolean;\r\n begin\r\n {$IFDEF MSWINDOWS} // case insensitive\r\n Result := StrSame(Path1, Path2);\r\n {$ELSE ~MSWINDOWS} // case sensitive\r\n Result := Path1 = Path2;\r\n {$ENDIF ~MSWINDOWS}\r\n end;\r\n\r\nbegin\r\n Origin := PathCanonicalize(Origin);\r\n Destination := PathCanonicalize(Destination);\r\n {$IFDEF MSWINDOWS}\r\n OrigDrive := ExtractFileDrive(Origin);\r\n DestDrive := ExtractFileDrive(Destination);\r\n {$ENDIF MSWINDOWS}\r\n if Equal(Origin, Destination) or (Destination = '') then\r\n Result := '.'\r\n else\r\n if Origin = '' then\r\n Result := Destination\r\n else\r\n {$IFDEF MSWINDOWS}\r\n if (DestDrive <> '') and ((OrigDrive = '') or ((OrigDrive <> '') and not Equal(OrigDrive, DestDrive))) then\r\n Result := Destination\r\n else\r\n if (OrigDrive <> '') and (Pos(DirDelimiter, Destination) = 1)\r\n and not Equal(PathUncPrefix,Copy(Destination,1,Length(PathUncPrefix))) then\r\n Result := OrigDrive + Destination // prepend drive part from Origin\r\n else\r\n {$ENDIF MSWINDOWS}\r\n if StartsFromRoot(Origin) and not StartsFromRoot(Destination) then\r\n Result := StrEnsureSuffix(DirDelimiter, Origin) +\r\n StrEnsureNoPrefix(DirDelimiter, Destination)\r\n else\r\n begin\r\n // create a list of paths as separate strings\r\n OrigList := TStringList.Create;\r\n DestList := TStringList.Create;\r\n try\r\n // NOTE: DO NOT USE DELIMITER AND DELIMITEDTEXT FROM\r\n // TSTRINGS, THEY WILL SPLIT PATHS WITH SPACES !!!!\r\n StrToStrings(Origin, DirDelimiter, OrigList);\r\n StrToStrings(Destination, DirDelimiter, DestList);\r\n begin\r\n // find the first directory that is not the same\r\n DiffIndex := OrigList.Count;\r\n if DestList.Count < DiffIndex then\r\n DiffIndex := DestList.Count;\r\n for I := 0 to DiffIndex - 1 do\r\n if not Equal(OrigList[I], DestList[I]) then\r\n begin\r\n DiffIndex := I;\r\n Break;\r\n end;\r\n Result := StrRepeat('..' + DirDelimiter, OrigList.Count - DiffIndex);\r\n Result := PathRemoveSeparator(Result);\r\n for I := DiffIndex to DestList.Count - 1 do\r\n begin\r\n if Result <> '' then\r\n Result := Result + DirDelimiter;\r\n Result := Result + DestList[i];\r\n end;\r\n end;\r\n finally\r\n DestList.Free;\r\n OrigList.Free;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction PathGetTempPath: string;\r\n{$IFDEF MSWINDOWS}\r\nvar\r\n BufSize: Cardinal;\r\nbegin\r\n BufSize := {$IFDEF HAS_UNITSCOPE}Winapi.{$ENDIF}Windows.GetTempPath(0, nil);\r\n SetLength(Result, BufSize);\r\n { TODO : Check length (-1 or not) }\r\n {$IFDEF HAS_UNITSCOPE}Winapi.{$ENDIF}Windows.GetTempPath(BufSize, PChar(Result));\r\n StrResetLength(Result);\r\nend;\r\n{$ENDIF MSWINDOWS}\r\n{$IFDEF UNIX}\r\nbegin\r\n Result := GetEnvironmentVariable('TMPDIR');\r\nend;\r\n{$ENDIF UNIX}\r\n\r\nfunction PathIsAbsolute(const Path: string): Boolean;\r\n{$IFDEF MSWINDOWS}\r\nvar\r\n I: Integer;\r\n{$ENDIF MSWINDOWS}\r\nbegin\r\n Result := False;\r\n if Path <> '' then\r\n begin\r\n {$IFDEF UNIX}\r\n Result := (Path[1] = DirDelimiter);\r\n {$ENDIF UNIX}\r\n {$IFDEF MSWINDOWS}\r\n if not PathIsUnc(Path) then\r\n begin\r\n I := 0;\r\n if PathIsDiskDevice(Path) then\r\n I := Length(PathDevicePrefix);\r\n Result := (Length(Path) > I + 2) and CharIsDriveLetter(Path[I + 1]) and\r\n (Path[I + 2] = ':') and (Path[I + 3] = DirDelimiter);\r\n end\r\n else\r\n Result := True;\r\n {$ENDIF MSWINDOWS}\r\n end;\r\nend;\r\n\r\nfunction PathIsChild(const Path, Base: string): Boolean;\r\nvar\r\n L: Integer;\r\n B, P: string;\r\nbegin\r\n Result := False;\r\n B := PathRemoveSeparator(Base);\r\n P := PathRemoveSeparator(Path);\r\n // an empty path or one that's not longer than base cannot be a subdirectory\r\n L := Length(B);\r\n if (P = '') or (L >= Length(P)) then\r\n Exit;\r\n {$IFDEF MSWINDOWS}\r\n Result := AnsiSameText(StrLeft(P, L), B) and (P[L+1] = DirDelimiter);\r\n {$ENDIF MSWINDOWS}\r\n {$IFDEF UNIX}\r\n Result := AnsiSameStr(StrLeft(P, L), B) and (P[L+1] = DirDelimiter);\r\n {$ENDIF UNIX}\r\nend;\r\n\r\nfunction PathIsEqualOrChild(const Path, Base: string): Boolean;\r\nvar\r\n L: Integer;\r\n B, P: string;\r\nbegin\r\n B := PathRemoveSeparator(Base);\r\n P := PathRemoveSeparator(Path);\r\n // an empty path or one that's not longer than base cannot be a subdirectory\r\n L := Length(B);\r\n {$IFDEF MSWINDOWS}\r\n Result := AnsiSameText(P, B);\r\n {$ENDIF MSWINDOWS}\r\n {$IFDEF UNIX}\r\n Result := AnsiSameStr(P, B);\r\n {$ENDIF UNIX}\r\n if Result or (P = '') or (L >= Length(P)) then\r\n Exit;\r\n {$IFDEF MSWINDOWS}\r\n Result := AnsiSameText(StrLeft(P, L), B) and (P[L+1] = DirDelimiter);\r\n {$ENDIF MSWINDOWS}\r\n {$IFDEF UNIX}\r\n Result := AnsiSameStr(StrLeft(P, L), B) and (P[L+1] = DirDelimiter);\r\n {$ENDIF UNIX}\r\nend;\r\n\r\nfunction PathIsDiskDevice(const Path: string): Boolean;\r\n{$IFDEF UNIX}\r\nvar\r\n FullPath: string;\r\n F: PIOFile;\r\n Buffer: array [0..255] of Char;\r\n MountEntry: TMountEntry;\r\n FsTypes: TStringList;\r\n\r\n procedure GetAvailableFileSystems(const List: TStrings);\r\n var\r\n F: TextFile;\r\n S: string;\r\n begin\r\n AssignFile(F, '/proc/filesystems');\r\n Reset(F);\r\n repeat\r\n Readln(F, S);\r\n if Pos('nodev', S) = 0 then // how portable is this ?\r\n List.Add(Trim(S));\r\n until Eof(F);\r\n List.Add('supermount');\r\n CloseFile(F);\r\n end;\r\n\r\nbegin\r\n Result := False;\r\n\r\n SetLength(FullPath, _POSIX_PATH_MAX);\r\n if realpath(PChar(Path), PChar(FullPath)) = nil then\r\n RaiseLastOSError;\r\n StrResetLength(FullPath);\r\n\r\n FsTypes := TStringList.Create;\r\n try\r\n GetAvailableFileSystems(FsTypes);\r\n F := setmntent(_PATH_MOUNTED, 'r'); // PATH_MOUNTED is deprecated,\r\n // but PATH_MNTTAB is defective in Libc.pas\r\n try\r\n // get drives from mtab\r\n while not Result and (getmntent_r(F, MountEntry, Buffer, SizeOf(Buffer)) <> nil) do\r\n if FsTypes.IndexOf(MountEntry.mnt_type) <> -1 then\r\n Result := MountEntry.mnt_dir = FullPath;\r\n\r\n finally\r\n endmntent(F);\r\n end;\r\n finally\r\n FsTypes.Free;\r\n end;\r\nend;\r\n{$ENDIF UNIX}\r\n{$IFDEF MSWINDOWS}\r\nbegin\r\n Result := Copy(Path, 1, Length(PathDevicePrefix)) = PathDevicePrefix;\r\nend;\r\n{$ENDIF MSWINDOWS}\r\n\r\nfunction CharIsMachineName(const C: Char): Boolean; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\nbegin\r\n case C of\r\n 'a'..'z',\r\n 'A'..'Z',\r\n '-', '_', '.':\r\n Result := True;\r\n else\r\n Result := False;\r\n end;\r\nend;\r\n\r\nfunction CharIsInvalidPathCharacter(const C: Char): Boolean; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\nbegin\r\n case C of\r\n '<', '>', '?', '/', ',', '*', '+', '=', '[', ']', '|', ':', ';', '\"', '''':\r\n Result := True;\r\n else\r\n Result := False;\r\n end;\r\nend;\r\n\r\nfunction PathIsUNC(const Path: string): Boolean;\r\n\r\n{$IFDEF MSWINDOWS}\r\n\r\nconst\r\n cUNCSuffix = '?\\UNC';\r\n\r\nvar\r\n P: PChar;\r\n\r\n function AbsorbSeparator: Boolean;\r\n begin\r\n Result := (P <> nil) and (P^ = DirDelimiter);\r\n if Result then\r\n Inc(P);\r\n end;\r\n\r\n function AbsorbMachineName: Boolean;\r\n var\r\n NonDigitFound: Boolean;\r\n begin\r\n // a valid machine name is a string composed of the set [a-z, A-Z, 0-9, -, _] but it may not\r\n // consist entirely out of numbers\r\n Result := True;\r\n NonDigitFound := False;\r\n while (P^ <> #0) and (P^ <> DirDelimiter) do\r\n begin\r\n if CharIsMachineName(P^) then\r\n begin\r\n NonDigitFound := True;\r\n Inc(P);\r\n end\r\n else\r\n if CharIsDigit(P^) then\r\n Inc(P)\r\n else\r\n begin\r\n Result := False;\r\n Break;\r\n end;\r\n end;\r\n Result := Result and NonDigitFound;\r\n end;\r\n\r\n function AbsorbShareName: Boolean;\r\n begin\r\n // a valid share name is a string composed of a set the set !InvalidCharacters note that a\r\n // leading '$' is valid (indicates a hidden share)\r\n Result := True;\r\n while (P^ <> #0) and (P^ <> DirDelimiter) do\r\n begin\r\n if CharIsInvalidPathCharacter(P^) then\r\n begin\r\n Result := False;\r\n Break;\r\n end;\r\n Inc(P);\r\n end;\r\n end;\r\n\r\nbegin\r\n Result := Copy(Path, 1, Length(PathUncPrefix)) = PathUncPrefix;\r\n if Result then\r\n begin\r\n if Copy(Path, 1, Length(PathUncPrefix + cUNCSuffix)) = PathUncPrefix + cUNCSuffix then\r\n P := @Path[Length(PathUncPrefix + cUNCSuffix)]\r\n else\r\n begin\r\n P := @Path[Length(PathUncPrefix)];\r\n Result := AbsorbSeparator and AbsorbMachineName;\r\n end;\r\n Result := Result and AbsorbSeparator;\r\n if Result then\r\n begin\r\n Result := AbsorbShareName;\r\n // remaining, if anything, is path and or filename (optional) check those?\r\n end;\r\n end;\r\nend;\r\n\r\n{$ENDIF MSWINDOWS}\r\n\r\n{$IFDEF UNIX}\r\n\r\nbegin\r\n Result := False;\r\nend;\r\n\r\n{$ENDIF UNIX}\r\n\r\nfunction PathRemoveSeparator(const Path: string): string;\r\nvar\r\n L: Integer;\r\nbegin\r\n L := Length(Path);\r\n if (L <> 0) and (Path[L] = DirDelimiter) then\r\n Result := Copy(Path, 1, L - 1)\r\n else\r\n Result := Path;\r\nend;\r\n\r\nfunction PathRemoveExtension(const Path: string): string;\r\nvar\r\n I: Integer;\r\nbegin\r\n I := LastDelimiter(':.' + DirDelimiter, Path);\r\n if (I > 0) and (Path[I] = '.') then\r\n Result := Copy(Path, 1, I - 1)\r\n else\r\n Result := Path;\r\nend;\r\n\r\n{$IFDEF MSWINDOWS}\r\n\r\nfunction SHGetDisplayName(ShellFolder: IShellFolder; PIDL: PItemIDList; ForParsing: Boolean): string;\r\nconst\r\n Flags: array[Boolean] of DWORD = (SHGDN_NORMAL, SHGDN_FORPARSING);\r\nvar\r\n StrRet: TStrRet;\r\n P: PChar;\r\nbegin\r\n Result := '';\r\n StrRet.utype := 0;\r\n\r\n ShellFolder.GetDisplayNameOf(PIDL, Flags[ForParsing], StrRet);\r\n case StrRet.uType of\r\n STRRET_CSTR:\r\n SetString(Result, StrRet.cStr, lstrlenA(StrRet.cStr));\r\n STRRET_OFFSET:\r\n begin\r\n P := @PIDL.mkid.abID[StrRet.uOffset - SizeOf(PIDL.mkid.cb)];\r\n SetString(Result, P, PIDL.mkid.cb - StrRet.uOffset);\r\n end;\r\n STRRET_WSTR:\r\n Result := StrRet.pOleStr;\r\n end;\r\n Result := Copy(Result, 1, lstrlen(PChar(Result)));\r\nend;\r\n\r\nfunction CutFirstDirectory(var Path: string): string;\r\nvar\r\n ps: Integer;\r\nbegin\r\n ps := AnsiPos(DirDelimiter, Path);\r\n if ps > 0 then\r\n begin\r\n Result := Copy(Path, 1, ps - 1);\r\n Path := Copy(Path, ps + 1, Length(Path));\r\n end\r\n else\r\n begin\r\n Result := Path;\r\n Path := '';\r\n end;\r\nend;\r\n\r\nfunction PathGetPhysicalPath(const LocalizedPath: string): string;\r\nvar\r\n Malloc: IMalloc;\r\n DesktopFolder: IShellFolder;\r\n RootFolder: IShellFolder;\r\n Eaten: Cardinal;\r\n Attributes: Cardinal;\r\n pidl: PItemIDList;\r\n EnumIDL: IEnumIDList;\r\n Drive: WideString;\r\n Featched: Cardinal;\r\n ParsePath: WideString;\r\n Path, Name: string;\r\n Found: Boolean;\r\nbegin\r\n if StrCompareRange('\\\\', LocalizedPath, 1, 2) = 0 then\r\n begin\r\n Result := LocalizedPath;\r\n Exit;\r\n end;\r\n\r\n Drive := ExtractFileDrive(LocalizedPath);\r\n if Drive = '' then\r\n begin\r\n Result := LocalizedPath;\r\n Exit;\r\n end;\r\n Path := Copy(LocalizedPath, Length(Drive) + 2, Length(LocalizedPath));\r\n ParsePath := Drive;\r\n OLECheck( SHGetMalloc(Malloc) );\r\n OleCheck( SHGetDesktopFolder(DesktopFolder) );\r\n while Path <> '' do\r\n begin\r\n Name := CutFirstDirectory(Path);\r\n Found := False;\r\n pidl := nil;\r\n Attributes := 0;\r\n if Succeeded( DesktopFolder.ParseDisplayName(0, nil, PWideChar(ParsePath), Eaten, pidl, Attributes) ) then\r\n begin\r\n OleCheck( DesktopFolder.BindToObject(pidl, nil, IShellFolder, RootFolder) );\r\n Malloc.Free(pidl);\r\n\r\n OleCheck( RootFolder.EnumObjects(0, SHCONTF_FOLDERS or SHCONTF_NONFOLDERS or SHCONTF_INCLUDEHIDDEN, EnumIDL) );\r\n Featched := 0;\r\n while EnumIDL.Next(1, pidl, Featched) = NOERROR do\r\n begin\r\n if AnsiCompareText(Name, SHGetDisplayName(RootFolder, pidl, False)) = 0 then\r\n begin\r\n ParsePath := SHGetDisplayName(RootFolder, pidl, True);\r\n Malloc.Free(pidl);\r\n Found := True;\r\n Break;\r\n end;\r\n Malloc.Free(pidl);\r\n end;\r\n EnumIDL := nil;\r\n RootFolder := nil;\r\n end;\r\n if not Found then\r\n ParsePath := ParsePath + DirDelimiter + Name;\r\n end;\r\n Result := ParsePath;\r\nend;\r\n\r\nfunction PathGetLocalizedPath(const PhysicalPath: string): string;\r\nvar\r\n Malloc: IMalloc;\r\n DesktopFolder: IShellFolder;\r\n RootFolder: IShellFolder;\r\n Eaten: Cardinal;\r\n Attributes: Cardinal;\r\n pidl: PItemIDList;\r\n EnumIDL: IEnumIDList;\r\n Drive: WideString;\r\n Featched: Cardinal;\r\n ParsePath: WideString;\r\n Path, Name, ParseName, DisplayName: string;\r\n Found: Boolean;\r\nbegin\r\n if StrCompareRange('\\\\', PhysicalPath, 1, 2) = 0 then\r\n begin\r\n Result := PhysicalPath;\r\n Exit;\r\n end;\r\n\r\n Drive := ExtractFileDrive(PhysicalPath);\r\n if Drive = '' then\r\n begin\r\n Result := PhysicalPath;\r\n Exit;\r\n end;\r\n Path := Copy(PhysicalPath, Length(Drive) + 2, Length(PhysicalPath));\r\n ParsePath := Drive;\r\n Result := Drive;\r\n OLECheck( SHGetMalloc(Malloc) );\r\n OleCheck( SHGetDesktopFolder(DesktopFolder) );\r\n while Path <> '' do\r\n begin\r\n Name := CutFirstDirectory(Path);\r\n Found := False;\r\n pidl := nil;\r\n Attributes := 0;\r\n if Succeeded( DesktopFolder.ParseDisplayName(0, nil, PWideChar(ParsePath), Eaten, pidl, Attributes) ) then\r\n begin\r\n OleCheck( DesktopFolder.BindToObject(pidl, nil, IShellFolder, RootFolder) );\r\n Malloc.Free(pidl);\r\n\r\n OleCheck( RootFolder.EnumObjects(0, SHCONTF_FOLDERS or SHCONTF_NONFOLDERS or SHCONTF_INCLUDEHIDDEN, EnumIDL) );\r\n Featched := 0;\r\n while EnumIDL.Next(1, pidl, Featched) = NOERROR do\r\n begin\r\n ParseName := SHGetDisplayName(RootFolder, pidl, True);\r\n DisplayName := SHGetDisplayName(RootFolder, pidl, False);\r\n Malloc.Free(pidl);\r\n if (AnsiCompareText(Name, ExtractFileName(ParseName)) = 0) or\r\n (AnsiCompareText(Name, DisplayName) = 0) then\r\n begin\r\n Name := DisplayName;\r\n ParsePath := ParseName;\r\n Found := True;\r\n Break;\r\n end;\r\n end;\r\n EnumIDL := nil;\r\n RootFolder := nil;\r\n end;\r\n Result := Result + DirDelimiter + Name;\r\n if not Found then\r\n ParsePath := ParsePath + DirDelimiter + Name;\r\n end;\r\nend;\r\n\r\n{$ELSE ~MSWINDOWS}\r\nfunction PathGetPhysicalPath(const LocalizedPath: string): string;\r\nbegin\r\n Result := LocalizedPath;\r\nend;\r\n\r\nfunction PathGetLocalizedPath(const PhysicalPath: string): string;\r\nbegin\r\n Result := PhysicalPath;\r\nend;\r\n{$ENDIF ~MSWINDOWS}\r\n\r\n//=== Files and Directories ==================================================\r\n\r\n\r\n{* Extended version of JclFileUtils.BuildFileList:\r\n function parameter Path can include multiple FileMasks as:\r\n c:\\aaa\\*.pas; pro*.dpr; *.d??\r\n FileMask Seperator = ';'\r\n *}\r\n\r\nfunction BuildFileList(const Path: string; const Attr: Integer; const List: TStrings; IncludeDirectoryName: Boolean =\r\n False): Boolean;\r\nvar\r\n SearchRec: TSearchRec;\r\n IndexMask: Integer;\r\n MaskList: TStringList;\r\n Masks, Directory: string;\r\nbegin\r\n Assert(List <> nil);\r\n MaskList := TStringList.Create;\r\n try\r\n {* extract the Directory *}\r\n Directory := ExtractFileDir(Path);\r\n\r\n {* files can be searched in the current directory *}\r\n if Directory <> '' then\r\n begin\r\n Directory := PathAddSeparator(Directory);\r\n {* extract the FileMasks portion out of Path *}\r\n Masks := StrAfter(Directory, Path);\r\n end\r\n else\r\n Masks := Path;\r\n\r\n {* put the Masks into TStringlist *}\r\n StrTokenToStrings(Masks, DirSeparator, MaskList);\r\n\r\n {* search all files in the directory *}\r\n Result := FindFirst(Directory + '*', faAnyFile, SearchRec) = 0;\r\n\r\n List.BeginUpdate;\r\n try\r\n while Result do\r\n begin\r\n {* if the filename matches any mask then it is added to the list *}\r\n for IndexMask := 0 to MaskList.Count - 1 do\r\n if (SearchRec.Name <> '.') and (SearchRec.Name <> '..')\r\n and ((SearchRec.Attr and Attr) = (SearchRec.Attr and faAnyFile))\r\n and IsFileNameMatch(SearchRec.Name, MaskList.Strings[IndexMask]) then\r\n begin\r\n if IncludeDirectoryName then\r\n List.Add(Directory+SearchRec.Name)\r\n else\r\n List.Add(SearchRec.Name);\r\n Break;\r\n end;\r\n\r\n case FindNext(SearchRec) of\r\n 0:\r\n ;\r\n ERROR_NO_MORE_FILES:\r\n Break;\r\n else\r\n Result := False;\r\n end;\r\n end;\r\n finally\r\n {$IFDEF HAS_UNITSCOPE}System.{$ENDIF}SysUtils.FindClose(SearchRec);\r\n List.EndUpdate;\r\n end;\r\n finally\r\n MaskList.Free;\r\n end;\r\nend;\r\n\r\n{$IFDEF MSWINDOWS}\r\n\r\nprocedure CreateEmptyFile(const FileName: string);\r\nvar\r\n Handle: THandle;\r\nbegin\r\n Handle := CreateFile(PChar(FileName), GENERIC_READ or GENERIC_WRITE, 0, nil, CREATE_ALWAYS, 0, 0);\r\n if Handle <> INVALID_HANDLE_VALUE then\r\n CloseHandle(Handle)\r\n else\r\n RaiseLastOSError;\r\nend;\r\n{$ENDIF MSWINDOWS}\r\n\r\n{$IFDEF MSWINDOWS}\r\n\r\nfunction CloseVolume(var Volume: THandle): Boolean;\r\nbegin\r\n Result := False;\r\n if Volume <> INVALID_HANDLE_VALUE then\r\n begin\r\n Result := CloseHandle(Volume);\r\n if Result then\r\n Volume := INVALID_HANDLE_VALUE;\r\n end;\r\nend;\r\n\r\n{$IFNDEF FPC} // needs JclShell\r\n\r\nfunction DeleteDirectory(const DirectoryName: string; MoveToRecycleBin: Boolean): Boolean;\r\nbegin\r\n if MoveToRecycleBin then\r\n Result := SHDeleteFolder(0, DirectoryName, [doSilent, doAllowUndo])\r\n else\r\n Result := DelTree(DirectoryName);\r\nend;\r\n\r\nfunction CopyDirectory(ExistingDirectoryName, NewDirectoryName: string): Boolean;\r\nvar\r\n SH: SHFILEOPSTRUCT;\r\nbegin\r\n ResetMemory(SH, SizeOf(SH));\r\n SH.Wnd := 0;\r\n SH.wFunc := FO_COPY;\r\n SH.pFrom := PChar(PathRemoveSeparator(ExistingDirectoryName) + #0);\r\n SH.pTo := PChar(PathRemoveSeparator(NewDirectoryName) + #0);\r\n SH.fFlags := FOF_ALLOWUNDO or FOF_NOCONFIRMATION or FOF_NOCONFIRMMKDIR or FOF_SILENT;\r\n Result := SHFileOperation(SH) = 0;\r\nend;\r\n\r\nfunction MoveDirectory(ExistingDirectoryName, NewDirectoryName: string): Boolean;\r\nvar\r\n SH: SHFILEOPSTRUCT;\r\nbegin\r\n ResetMemory(SH, SizeOf(SH));\r\n SH.Wnd := 0;\r\n SH.wFunc := FO_MOVE;\r\n SH.pFrom := PChar(PathRemoveSeparator(ExistingDirectoryName) + #0);\r\n SH.pTo := PChar(PathRemoveSeparator(NewDirectoryName) + #0);\r\n SH.fFlags := FOF_ALLOWUNDO or FOF_NOCONFIRMATION or FOF_NOCONFIRMMKDIR or FOF_SILENT;\r\n Result := SHFileOperation(SH) = 0;\r\nend;\r\n\r\n{$ENDIF ~FPC}\r\n\r\nfunction DelTree(const Path: string): Boolean;\r\nbegin\r\n Result := DelTreeEx(Path, False, nil);\r\nend;\r\n\r\nfunction DelTreeEx(const Path: string; AbortOnFailure: Boolean; Progress: TDelTreeProgress): Boolean;\r\nvar\r\n Files: TStringList;\r\n LPath: string; // writable copy of Path\r\n FileName: string;\r\n I: Integer;\r\n PartialResult: Boolean;\r\n Attr: DWORD;\r\nbegin\r\n Assert(Path <> '', LoadResString(@RsDelTreePathIsEmpty));\r\n {$IFNDEF ASSERTIONS_ON}\r\n if Path = '' then\r\n begin\r\n Result := False;\r\n Exit;\r\n end;\r\n {$ENDIF ~ASSERTIONS_ON}\r\n Result := True;\r\n Files := TStringList.Create;\r\n try\r\n LPath := PathRemoveSeparator(Path);\r\n BuildFileList(LPath + '\\*.*', faAnyFile, Files);\r\n for I := 0 to Files.Count - 1 do\r\n begin\r\n FileName := LPath + DirDelimiter + Files[I];\r\n PartialResult := True;\r\n // If the current file is itself a directory then recursively delete it\r\n Attr := GetFileAttributes(PChar(FileName));\r\n if (Attr <> DWORD(-1)) and ((Attr and FILE_ATTRIBUTE_DIRECTORY) <> 0) then\r\n PartialResult := DelTreeEx(FileName, AbortOnFailure, Progress)\r\n else\r\n begin\r\n if Assigned(Progress) then\r\n PartialResult := Progress(FileName, Attr);\r\n if PartialResult then\r\n begin\r\n // Set attributes to normal in case it's a readonly file\r\n PartialResult := SetFileAttributes(PChar(FileName), FILE_ATTRIBUTE_NORMAL);\r\n if PartialResult then\r\n PartialResult := DeleteFile(FileName);\r\n end;\r\n end;\r\n if not PartialResult then\r\n begin\r\n Result := False;\r\n if AbortOnFailure then\r\n Break;\r\n end;\r\n end;\r\n finally\r\n FreeAndNil(Files);\r\n end;\r\n if Result then\r\n begin\r\n // Finally remove the directory itself\r\n Result := SetFileAttributes(PChar(LPath), FILE_ATTRIBUTE_NORMAL);\r\n if Result then\r\n begin\r\n {$IOCHECKS OFF}\r\n RmDir(LPath);\r\n {$IFDEF IOCHECKS_ON}\r\n {$IOCHECKS ON}\r\n {$ENDIF IOCHECKS_ON}\r\n Result := IOResult = 0;\r\n end;\r\n end;\r\nend;\r\n\r\n{$ENDIF MSWINDOWS}\r\n\r\n{$IFDEF MSWINDOWS}\r\nfunction DirectoryExists(const Name: string): Boolean;\r\nvar\r\n R: DWORD;\r\nbegin\r\n R := GetFileAttributes(PChar(Name));\r\n Result := (R <> DWORD(-1)) and ((R and FILE_ATTRIBUTE_DIRECTORY) <> 0);\r\nend;\r\n{$ENDIF MSWINDOWS}\r\n\r\n{$IFDEF UNIX}\r\nfunction DirectoryExists(const Name: string; ResolveSymLinks: Boolean): Boolean;\r\nbegin\r\n Result := IsDirectory(Name, ResolveSymLinks);\r\nend;\r\n{$ENDIF UNIX}\r\n\r\n{$IFDEF MSWINDOWS}\r\nfunction DiskInDrive(Drive: Char): Boolean;\r\nvar\r\n ErrorMode: Cardinal;\r\nbegin\r\n Result := False;\r\n Assert(CharIsDriveLetter(Drive));\r\n if CharIsDriveLetter(Drive) then\r\n begin\r\n Drive := CharUpper(Drive);\r\n { try to access the drive, it doesn't really matter how we access the drive and as such calling\r\n DiskSize is more or less a random choice. The call to SetErrorMode supresses the system provided\r\n error dialog if there is no disk in the drive and causes the to DiskSize to fail. }\r\n ErrorMode := SetErrorMode(SEM_FAILCRITICALERRORS);\r\n try\r\n Result := DiskSize(Ord(Drive) - $40) <> -1;\r\n finally\r\n SetErrorMode(ErrorMode);\r\n end;\r\n end;\r\nend;\r\n{$ENDIF MSWINDOWS}\r\n\r\nfunction FileCreateTemp(var Prefix: string): THandle;\r\n{$IFDEF MSWINDOWS}\r\nvar\r\n TempName: string;\r\nbegin\r\n Result := INVALID_HANDLE_VALUE;\r\n TempName := FileGetTempName(Prefix);\r\n if TempName <> '' then\r\n begin\r\n Result := CreateFile(PChar(TempName), GENERIC_READ or GENERIC_WRITE, 0, nil,\r\n OPEN_EXISTING, FILE_ATTRIBUTE_TEMPORARY or FILE_FLAG_DELETE_ON_CLOSE, 0);\r\n // In certain situations it's possible that CreateFile fails yet the file is actually created,\r\n // therefore explicitly delete it upon failure.\r\n if Result = INVALID_HANDLE_VALUE then\r\n DeleteFile(TempName);\r\n Prefix := TempName;\r\n end;\r\nend;\r\n{$ENDIF MSWINDOWS}\r\n{$IFDEF UNIX}\r\nvar\r\n Template: string;\r\nbegin\r\n // The mkstemp function generates a unique file name just as mktemp does, but\r\n // it also opens the file for you with open. If successful, it modifies\r\n // template in place and returns a file descriptor for that file open for\r\n // reading and writing. If mkstemp cannot create a uniquely-named file, it\r\n // returns -1. If template does not end with `XXXXXX', mkstemp returns -1 and\r\n // does not modify template.\r\n\r\n // The file is opened using mode 0600. If the file is meant to be used by\r\n // other users this mode must be changed explicitly.\r\n\r\n // Unlike mktemp, mkstemp is actually guaranteed to create a unique file that\r\n // cannot possibly clash with any other program trying to create a temporary\r\n // file. This is because it works by calling open with the O_EXCL flag, which\r\n // says you want to create a new file and get an error if the file already\r\n // exists.\r\n Template := Prefix + 'XXXXXX';\r\n Result := mkstemp(PChar(Template));\r\n Prefix := Template;\r\nend;\r\n{$ENDIF UNIX}\r\n\r\nfunction FileBackup(const FileName: string; Move: Boolean = False): Boolean;\r\nbegin\r\n if Move then\r\n Result := FileMove(FileName, GetBackupFileName(FileName), True)\r\n else\r\n Result := FileCopy(FileName, GetBackupFileName(FileName), True);\r\nend;\r\n\r\nfunction FileCopy(const ExistingFileName, NewFileName: string; ReplaceExisting: Boolean = False): Boolean;\r\nvar\r\n {$IFDEF UNIX}\r\n SrcFile, DstFile: file;\r\n Buf: array[0..511] of Byte;\r\n BytesRead: Integer;\r\n {$ENDIF UNIX}\r\n DestFileName: string;\r\nbegin\r\n if IsDirectory(NewFileName) then\r\n DestFileName := PathAddSeparator(NewFileName) + ExtractFileName(ExistingFileName)\r\n else\r\n DestFileName := NewFileName;\r\n {$IFDEF MSWINDOWS}\r\n { TODO : Use CopyFileEx where available? }\r\n Result := CopyFile(PChar(ExistingFileName), PChar(DestFileName), not ReplaceExisting);\r\n {$ENDIF MSWINDOWS}\r\n {$IFDEF UNIX}\r\n Result := False;\r\n if not FileExists(DestFileName) or ReplaceExisting then\r\n begin\r\n AssignFile(SrcFile, ExistingFileName);\r\n Reset(SrcFile, 1);\r\n AssignFile(DstFile, DestFileName);\r\n Rewrite(DstFile, 1);\r\n while not Eof(SrcFile) do\r\n begin\r\n BlockRead(SrcFile, Buf, SizeOf(Buf), BytesRead);\r\n BlockWrite(DstFile, Buf, BytesRead);\r\n end;\r\n CloseFile(DstFile);\r\n CloseFile(SrcFile);\r\n Result := True;\r\n end;\r\n {$ENDIF UNIX}\r\nend;\r\n\r\nfunction FileDateTime(const FileName: string): TDateTime;\r\n{$IFNDEF COMPILER10_UP}\r\nvar\r\n Age: Longint;\r\n{$ENDIF !COMPILER10_UP}\r\nbegin\r\n {$IFDEF COMPILER10_UP}\r\n if not FileAge(Filename, Result) then\r\n Result := 0;\r\n {$ELSE}\r\n Age := FileAge(FileName);\r\n {$IFDEF MSWINDOWS}\r\n // [roko] -1 is valid FileAge value on Linux\r\n if Age = -1 then\r\n Result := 0\r\n else\r\n {$ENDIF MSWINDOWS}\r\n Result := FileDateToDateTime(Age);\r\n {$ENDIF COMPILER10_UP}\r\nend;\r\n\r\nfunction FileDelete(const FileName: string; MoveToRecycleBin: Boolean = False): Boolean;\r\n{$IFDEF MSWINDOWS}\r\nbegin\r\n if MoveToRecycleBin then\r\n Result := SHDeleteFiles(0, FileName, [doSilent, doAllowUndo, doFilesOnly])\r\n else\r\n Result := {$IFDEF HAS_UNITSCOPE}Winapi.{$ENDIF}Windows.DeleteFile(PChar(FileName));\r\nend;\r\n{$ENDIF MSWINDOWS}\r\n{$IFDEF UNIX}\r\n { TODO : implement MoveToRecycleBin for appropriate Desktops (e.g. KDE) }\r\nbegin\r\n Result := remove(PChar(FileName)) <> -1;\r\nend;\r\n{$ENDIF UNIX}\r\n\r\nfunction FileExists(const FileName: string): Boolean;\r\n{$IFDEF MSWINDOWS}\r\nvar\r\n Attr: Cardinal;\r\n{$ENDIF MSWINDOWS}\r\nbegin\r\n if FileName <> '' then\r\n begin\r\n {$IFDEF MSWINDOWS}\r\n // FileGetSize is very slow, GetFileAttributes is much faster\r\n Attr := GetFileAttributes(Pointer(Filename));\r\n Result := (Attr <> $FFFFFFFF) and (Attr and FILE_ATTRIBUTE_DIRECTORY = 0);\r\n {$ELSE ~MSWINDOWS}\r\n // Attempt to access the file, doesn't matter how, using FileGetSize is as good as anything else.\r\n Result := FileGetSize(FileName) <> -1;\r\n {$ENDIF ~MSWINDOWS}\r\n end\r\n else\r\n Result := False;\r\nend;\r\n\r\nprocedure FileHistory(const FileName: string; HistoryPath: string = ''; MaxHistoryCount: Integer = 100; MinFileDate:\r\n TDateTime = 0; ReplaceExtention: Boolean = true);\r\n\r\n Function Extention (Number : Integer) : String;\r\n begin\r\n Result := inttostr(Number);\r\n while Length(Result) < 3 do\r\n Result := '0' + Result;\r\n Result := '.~'+Result+'~';\r\n end;\r\n\r\n procedure RenameToNumber(const RenameFileName: string; Number: Integer);\r\n var\r\n f1: string;\r\n f2: string;\r\n begin\r\n f1 := ChangeFileExt(RenameFileName,Extention(Number-1));\r\n f2 := ChangeFileExt(RenameFileName,Extention(Number));\r\n if FileExists(f2) then\r\n if Number >= MaxHistoryCount then\r\n if not FileDelete(f2) then\r\n Exception.Create('Unable to delete file \"' + f2 + '\".')\r\n else\r\n else\r\n RenameToNumber(RenameFileName, Number + 1);\r\n if FileExists(f1) then\r\n if not FileMove(f1, f2, true) then\r\n Exception.Create('Unable to rename file \"' + f1 + '\" to \"' + f2 + '\".')\r\n end;\r\n\r\nVar FirstFile : string;\r\nbegin\r\n // TODO -cMM: FileHistory default body inserted\r\n if not FileExists(FileName) or (MaxHistoryCount <= 0) then\r\n Exit;\r\n if HistoryPath = '' then\r\n HistoryPath := ExtractFilePath(FileName);\r\n FirstFile := PathAppend(HistoryPath, ExtractFileName(FileName));\r\n if ReplaceExtention then\r\n FirstFile := ChangeFileExt(FirstFile, Extention(1))\r\n else\r\n FirstFile := FirstFile+Extention(1);\r\n if (FileDateTime(FirstFile) > MinFileDate) and (MinFileDate <> 0) then\r\n Exit;\r\n RenameToNumber(FirstFile, 2);\r\n FileCopy(FileName, FirstFile, True);\r\nend;\r\n\r\n\r\nfunction FileMove(const ExistingFileName, NewFileName: string; ReplaceExisting: Boolean = False): Boolean;\r\n{$IFDEF MSWINDOWS}\r\nconst\r\n Flag: array[Boolean] of Cardinal = (0, MOVEFILE_REPLACE_EXISTING);\r\n{$ENDIF MSWINDOWS}\r\nbegin\r\n {$IFDEF MSWINDOWS}\r\n Result := MoveFileEx(PChar(ExistingFileName), PChar(NewFileName), Flag[ReplaceExisting]);\r\n {$ENDIF MSWINDOWS}\r\n {$IFDEF UNIX}\r\n Result := __rename(PChar(ExistingFileName), PChar(NewFileName)) = 0;\r\n {$ENDIF UNIX}\r\n if not Result then\r\n begin\r\n Result := FileCopy(ExistingFileName, NewFileName, ReplaceExisting);\r\n if Result then\r\n FileDelete(ExistingFileName);\r\n end;\r\nend;\r\n\r\nfunction FileRestore(const FileName: string): Boolean;\r\nvar\r\n TempFileName: string;\r\nbegin\r\n Result := False;\r\n TempFileName := FileGetTempName('');\r\n\r\n if FileMove(GetBackupFileName(FileName), TempFileName, True) then\r\n if FileBackup(FileName, False) then\r\n Result := FileMove(TempFileName, FileName, True);\r\nend;\r\n\r\nfunction GetBackupFileName(const FileName: string): string;\r\nvar\r\n NewExt: string;\r\nbegin\r\n NewExt := ExtractFileExt(FileName);\r\n if Length(NewExt) > 0 then\r\n begin\r\n NewExt[1] := '~';\r\n NewExt := '.' + NewExt\r\n end\r\n else\r\n NewExt := '.~';\r\n Result := ChangeFileExt(FileName, NewExt);\r\nend;\r\n\r\nfunction IsBackupFileName(const FileName: string): Boolean;\r\nbegin\r\n Result := (pos('.~', ExtractFileExt(FileName)) = 1);\r\nend;\r\n\r\nfunction FileGetDisplayName(const FileName: string): string;\r\n{$IFDEF MSWINDOWS}\r\nvar\r\n FileInfo: TSHFileInfo;\r\nbegin\r\n ResetMemory(FileInfo, SizeOf(FileInfo));\r\n if SHGetFileInfo(PChar(FileName), 0, FileInfo, SizeOf(FileInfo), SHGFI_DISPLAYNAME) <> 0 then\r\n Result := FileInfo.szDisplayName\r\n else\r\n Result := FileName;\r\nend;\r\n{$ELSE ~MSWINDOWS}\r\nbegin\r\n { TODO -cHelp : mention this reduced solution }\r\n Result := FileName;\r\nend;\r\n{$ENDIF ~MSWINDOWS}\r\n\r\nfunction FileGetGroupName(const FileName: string {$IFDEF UNIX}; ResolveSymLinks: Boolean = True {$ENDIF}): string;\r\n{$IFDEF MSWINDOWS}\r\nvar\r\n DomainName: WideString;\r\n TmpResult: WideString;\r\n pSD: PSecurityDescriptor;\r\n BufSize: DWORD;\r\nbegin\r\n if IsWinNT then\r\n begin\r\n BufSize := 0;\r\n GetFileSecurity(PChar(FileName), GROUP_SECURITY_INFORMATION, nil, 0, BufSize);\r\n if BufSize > 0 then\r\n begin\r\n GetMem(pSD, BufSize);\r\n GetFileSecurity(PChar(FileName), GROUP_SECURITY_INFORMATION,\r\n pSD, BufSize, BufSize);\r\n LookupAccountBySid(Pointer(TJclAddr(pSD) + TJclAddr(pSD^.Group)), TmpResult, DomainName, True);\r\n FreeMem(pSD);\r\n Result := Trim(TmpResult);\r\n end;\r\n end;\r\nend;\r\n{$ENDIF ~MSWINDOWS}\r\n{$IFDEF UNIX}\r\nvar\r\n Buf: TStatBuf64;\r\n ResultBuf: TGroup;\r\n ResultBufPtr: PGroup;\r\n Buffer: array of Char;\r\nbegin\r\n if GetFileStatus(FileName, Buf, ResolveSymLinks) = 0 then\r\n begin\r\n SetLength(Buffer, 128);\r\n while getgrgid_r(Buf.st_gid, ResultBuf, @Buffer[0], Length(Buffer), ResultBufPtr) = ERANGE do\r\n SetLength(Buffer, Length(Buffer) * 2);\r\n Result := ResultBuf.gr_name;\r\n end;\r\nend;\r\n{$ENDIF ~UNIX}\r\n\r\nfunction FileGetOwnerName(const FileName: string {$IFDEF UNIX}; ResolveSymLinks: Boolean = True {$ENDIF}): string;\r\n{$IFDEF MSWINDOWS}\r\nvar\r\n DomainName: WideString;\r\n TmpResult: WideString;\r\n pSD: PSecurityDescriptor;\r\n BufSize: DWORD;\r\nbegin\r\n if IsWinNT then\r\n begin\r\n BufSize := 0;\r\n GetFileSecurity(PChar(FileName), OWNER_SECURITY_INFORMATION, nil, 0, BufSize);\r\n if BufSize > 0 then\r\n begin\r\n GetMem(pSD, BufSize);\r\n try\r\n GetFileSecurity(PChar(FileName), OWNER_SECURITY_INFORMATION,\r\n pSD, BufSize, BufSize);\r\n LookupAccountBySid(Pointer(TJclAddr(pSD) + TJclAddr(pSD^.Owner)), TmpResult, DomainName, True);\r\n finally\r\n FreeMem(pSD);\r\n end;\r\n Result := Trim(TmpResult);\r\n end;\r\n end;\r\nend;\r\n{$ENDIF ~MSWINDOWS}\r\n{$IFDEF UNIX}\r\nvar\r\n Buf: TStatBuf64;\r\n ResultBuf: TPasswordRecord;\r\n ResultBufPtr: PPasswordRecord;\r\n Buffer: array of Char;\r\nbegin\r\n if GetFileStatus(FileName, Buf, ResolveSymLinks) = 0 then\r\n begin\r\n SetLength(Buffer, 128);\r\n while getpwuid_r(Buf.st_uid, ResultBuf, @Buffer[0], Length(Buffer), ResultBufPtr) = ERANGE do\r\n SetLength(Buffer, Length(Buffer) * 2);\r\n Result := ResultBuf.pw_name;\r\n end;\r\nend;\r\n{$ENDIF ~UNIX}\r\n\r\nfunction FileGetSize(const FileName: string): Int64;\r\n{$IFDEF MSWINDOWS}\r\nvar\r\n FileAttributesEx: WIN32_FILE_ATTRIBUTE_DATA;\r\n OldMode: Cardinal;\r\n Size: TJclULargeInteger;\r\nbegin\r\n Result := -1;\r\n OldMode := SetErrorMode(SEM_FAILCRITICALERRORS);\r\n try\r\n if GetFileAttributesEx(PChar(FileName), GetFileExInfoStandard, @FileAttributesEx) then\r\n begin\r\n Size.LowPart := FileAttributesEx.nFileSizeLow;\r\n Size.HighPart := FileAttributesEx.nFileSizeHigh;\r\n Result := Size.QuadPart;\r\n end;\r\n finally\r\n SetErrorMode(OldMode);\r\n end;\r\nend;\r\n{$ENDIF MSWINDOWS}\r\n{$IFDEF UNIX}\r\nvar\r\n Buf: TStatBuf64;\r\nbegin\r\n Result := -1;\r\n if GetFileStatus(FileName, Buf, False) = 0 then\r\n Result := Buf.st_size;\r\nend;\r\n{$ENDIF UNIX}\r\n\r\n{$IFDEF MSWINDOWS}\r\n{$IFDEF FPC}\r\n{ TODO : Move this over to JclWin32 when JclWin32 gets overhauled. }\r\nfunction GetTempFileName(lpPathName, lpPrefixString: PChar;\r\n uUnique: UINT; lpTempFileName: PChar): UINT; stdcall;\r\nexternal kernel32 name 'GetTempFileNameA';\r\n{$ENDIF FPC}\r\n{$ENDIF MSWINDOWS}\r\n\r\nfunction FileGetTempName(const Prefix: string): string;\r\n{$IFDEF MSWINDOWS}\r\nvar\r\n TempPath, TempFile: string;\r\n R: Cardinal;\r\nbegin\r\n Result := '';\r\n TempPath := PathGetTempPath;\r\n if TempPath <> '' then\r\n begin\r\n SetLength(TempFile, MAX_PATH);\r\n R := GetTempFileName(PChar(TempPath), PChar(Prefix), 0, PChar(TempFile));\r\n if R <> 0 then\r\n begin\r\n StrResetLength(TempFile);\r\n Result := TempFile;\r\n end;\r\n end;\r\nend;\r\n{$ENDIF MSWINDOWS}\r\n{$IFDEF UNIX}\r\n// Warning: Between the time the pathname is constructed and the file is created\r\n// another process might have created a file with the same name using tmpnam,\r\n// leading to a possible security hole. The implementation generates names which\r\n// can hardly be predicted, but when opening the file you should use the O_EXCL\r\n// flag. Using tmpfile or mkstemp is a safe way to avoid this problem.\r\nvar\r\n P: PChar;\r\nbegin\r\n P := tempnam(PChar(PathGetTempPath), PChar(Prefix));\r\n Result := P;\r\n Libc.free(P);\r\nend;\r\n{$ENDIF UNIX}\r\n\r\n{$IFDEF MSWINDOWS}\r\nfunction FileGetTypeName(const FileName: string): string;\r\nvar\r\n FileInfo: TSHFileInfo;\r\n RetVal: DWORD;\r\nbegin\r\n ResetMemory(FileInfo, SizeOf(FileInfo));\r\n RetVal := SHGetFileInfo(PChar(FileName), 0, FileInfo, SizeOf(FileInfo),\r\n SHGFI_TYPENAME or SHGFI_USEFILEATTRIBUTES);\r\n if RetVal <> 0 then\r\n Result := FileInfo.szTypeName;\r\n if (RetVal = 0) or (Trim(Result) = '') then\r\n begin\r\n // Lookup failed so mimic explorer behaviour by returning \"XYZ File\"\r\n Result := ExtractFileExt(FileName);\r\n Delete(Result, 1, 1);\r\n Result := TrimLeft(UpperCase(Result) + LoadResString(@RsDefaultFileTypeName));\r\n end;\r\nend;\r\n{$ENDIF MSWINDOWS}\r\n\r\nfunction FindUnusedFileName(FileName: string; const FileExt: string; NumberPrefix: string = ''): string;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := PathAddExtension(FileName, FileExt);\r\n if not FileExists(Result) then\r\n Exit;\r\n if SameText(Result, FileName) then\r\n Delete(FileName, Length(FileName) - Length(FileExt) + 1, Length(FileExt));\r\n I := 0;\r\n repeat\r\n Inc(I);\r\n Result := PathAddExtension(FileName + NumberPrefix + IntToStr(I), FileExt);\r\n until not FileExists(Result);\r\nend;\r\n\r\n// This routine is copied from FileCtrl.pas to avoid dependency on that unit.\r\n// See the remark at the top of this section\r\n\r\nfunction ForceDirectories(Name: string): Boolean;\r\nvar\r\n ExtractPath: string;\r\nbegin\r\n Result := True;\r\n if Length(Name) = 0 then\r\n raise EJclFileUtilsError.CreateRes(@RsCannotCreateDir);\r\n Name := PathRemoveSeparator(Name);\r\n {$IFDEF MSWINDOWS}\r\n ExtractPath := ExtractFilePath(Name);\r\n if ((Length(Name) = 2) and (Copy(Name, 2,1) = ':')) or DirectoryExists(Name) or (ExtractPath = Name) then\r\n Exit;\r\n {$ENDIF MSWINDOWS}\r\n {$IFDEF UNIX}\r\n if (Length(Name) = 0) or DirectoryExists(Name) then\r\n Exit;\r\n ExtractPath := ExtractFilePath(Name);\r\n {$ENDIF UNIX}\r\n Result := (ExtractPath = '') or ForceDirectories(ExtractPath);\r\n if Result then\r\n begin\r\n {$IFDEF MSWINDOWS}\r\n SetLastError(ERROR_SUCCESS);\r\n {$ENDIF MSWINDOWS}\r\n Result := Result and CreateDir(Name);\r\n {$IFDEF MSWINDOWS}\r\n Result := Result or (GetLastError = ERROR_ALREADY_EXISTS);\r\n {$ENDIF MSWINDOWS}\r\n end;\r\nend;\r\n\r\nfunction GetDirectorySize(const Path: string): Int64;\r\n\r\n function RecurseFolder(const Path: string): Int64;\r\n var\r\n F: TSearchRec;\r\n R: Integer;\r\n {$IFDEF MSWINDOWS}\r\n TempSize: TJclULargeInteger;\r\n {$ENDIF MSWINDOWS}\r\n begin\r\n Result := 0;\r\n R := {$IFDEF HAS_UNITSCOPE}System.{$ENDIF}SysUtils.FindFirst(Path + '*.*', faAnyFile, F);\r\n if R = 0 then\r\n try\r\n while R = 0 do\r\n begin\r\n if (F.Name <> '.') and (F.Name <> '..') then\r\n begin\r\n if (F.Attr and faDirectory) = faDirectory then\r\n Inc(Result, RecurseFolder(Path + F.Name + DirDelimiter))\r\n else\r\n {$IFDEF MSWINDOWS}\r\n begin\r\n TempSize.LowPart := F.FindData.nFileSizeLow;\r\n TempSize.HighPart := F.FindData.nFileSizeHigh;\r\n Inc(Result, TempSize.QuadPart);\r\n end;\r\n {$ENDIF MSWINDOWS}\r\n {$IFDEF UNIX}\r\n // SysUtils.Find* don't perceive files >= 2 GB anyway\r\n Inc(Result, Int64(F.Size));\r\n {$ENDIF UNIX}\r\n end;\r\n R := {$IFDEF HAS_UNITSCOPE}System.{$ENDIF}SysUtils.FindNext(F);\r\n end;\r\n if R <> ERROR_NO_MORE_FILES then\r\n Abort;\r\n finally\r\n {$IFDEF HAS_UNITSCOPE}System.{$ENDIF}SysUtils.FindClose(F);\r\n end;\r\n end;\r\n\r\nbegin\r\n if not DirectoryExists(PathRemoveSeparator(Path)) then\r\n Result := -1\r\n else\r\n try\r\n Result := RecurseFolder(PathAddSeparator(Path))\r\n except\r\n Result := -1;\r\n end;\r\nend;\r\n\r\n{$IFDEF MSWINDOWS}\r\n\r\nfunction GetDriveTypeStr(const Drive: Char): string;\r\nvar\r\n DriveType: Integer;\r\n DriveStr: string;\r\nbegin\r\n if not CharIsDriveLetter(Drive) then\r\n raise EJclPathError.CreateResFmt(@RsPathInvalidDrive, [Drive]);\r\n DriveStr := Drive + ':\\';\r\n DriveType := GetDriveType(PChar(DriveStr));\r\n case DriveType of\r\n DRIVE_REMOVABLE:\r\n Result := LoadResString(@RsRemovableDrive);\r\n DRIVE_FIXED:\r\n Result := LoadResString(@RsHardDisk);\r\n DRIVE_REMOTE:\r\n Result := LoadResString(@RsRemoteDrive);\r\n DRIVE_CDROM:\r\n Result := LoadResString(@RsCDRomDrive);\r\n DRIVE_RAMDISK:\r\n Result := LoadResString(@RsRamDisk);\r\n else\r\n Result := LoadResString(@RsUnknownDrive);\r\n end;\r\nend;\r\n\r\nfunction GetFileAgeCoherence(const FileName: string): Boolean;\r\nvar\r\n FileAttributesEx: WIN32_FILE_ATTRIBUTE_DATA;\r\nbegin\r\n Result := False;\r\n if GetFileAttributesEx(PChar(FileName), GetFileExInfoStandard, @FileAttributesEx) then\r\n {$IFDEF FPC}\r\n Result := CompareFileTime(@FileAttributesEx.ftCreationTime, @FileAttributesEx.ftLastWriteTime) <= 0;\r\n {$ELSE ~FPC}\r\n Result := CompareFileTime(FileAttributesEx.ftCreationTime, FileAttributesEx.ftLastWriteTime) <= 0;\r\n {$ENDIF ~FPC}\r\nend;\r\n\r\n{$ENDIF MSWINDOWS}\r\n\r\nprocedure GetFileAttributeList(const Items: TStrings; const Attr: Integer);\r\nbegin\r\n { TODO : clear list? }\r\n Assert(Assigned(Items));\r\n if not Assigned(Items) then\r\n Exit;\r\n Items.BeginUpdate;\r\n try\r\n { TODO : differentiate Windows/UNIX idents }\r\n if Attr and faDirectory = faDirectory then\r\n Items.Add(LoadResString(@RsAttrDirectory));\r\n if Attr and faReadOnly = faReadOnly then\r\n Items.Add(LoadResString(@RsAttrReadOnly));\r\n if Attr and faSysFile = faSysFile then\r\n Items.Add(LoadResString(@RsAttrSystemFile));\r\n if Attr and faArchive = faArchive then\r\n Items.Add(LoadResString(@RsAttrArchive));\r\n if Attr and faAnyFile = faAnyFile then\r\n Items.Add(LoadResString(@RsAttrAnyFile));\r\n if Attr and faHidden = faHidden then\r\n Items.Add(LoadResString(@RsAttrHidden));\r\n finally\r\n Items.EndUpdate;\r\n end;\r\nend;\r\n\r\n{$IFDEF MSWINDOWS}\r\n\r\n{ TODO : GetFileAttributeListEx - Unix version }\r\nprocedure GetFileAttributeListEx(const Items: TStrings; const Attr: Integer);\r\nbegin\r\n { TODO : clear list? }\r\n Assert(Assigned(Items));\r\n if not Assigned(Items) then\r\n Exit;\r\n Items.BeginUpdate;\r\n try\r\n if Attr and FILE_ATTRIBUTE_READONLY = FILE_ATTRIBUTE_READONLY then\r\n Items.Add(LoadResString(@RsAttrReadOnly));\r\n if Attr and FILE_ATTRIBUTE_HIDDEN = FILE_ATTRIBUTE_HIDDEN then\r\n Items.Add(LoadResString(@RsAttrHidden));\r\n if Attr and FILE_ATTRIBUTE_SYSTEM = FILE_ATTRIBUTE_SYSTEM then\r\n Items.Add(LoadResString(@RsAttrSystemFile));\r\n if Attr and FILE_ATTRIBUTE_DIRECTORY = FILE_ATTRIBUTE_DIRECTORY then\r\n Items.Add(LoadResString(@RsAttrDirectory));\r\n if Attr and FILE_ATTRIBUTE_ARCHIVE = FILE_ATTRIBUTE_ARCHIVE then\r\n Items.Add(LoadResString(@RsAttrArchive));\r\n if Attr and FILE_ATTRIBUTE_NORMAL = FILE_ATTRIBUTE_NORMAL then\r\n Items.Add(LoadResString(@RsAttrNormal));\r\n if Attr and FILE_ATTRIBUTE_TEMPORARY = FILE_ATTRIBUTE_TEMPORARY then\r\n Items.Add(LoadResString(@RsAttrTemporary));\r\n if Attr and FILE_ATTRIBUTE_COMPRESSED = FILE_ATTRIBUTE_COMPRESSED then\r\n Items.Add(LoadResString(@RsAttrCompressed));\r\n if Attr and FILE_ATTRIBUTE_OFFLINE = FILE_ATTRIBUTE_OFFLINE then\r\n Items.Add(LoadResString(@RsAttrOffline));\r\n if Attr and FILE_ATTRIBUTE_ENCRYPTED = FILE_ATTRIBUTE_ENCRYPTED then\r\n Items.Add(LoadResString(@RsAttrEncrypted));\r\n if Attr and FILE_ATTRIBUTE_REPARSE_POINT = FILE_ATTRIBUTE_REPARSE_POINT then\r\n Items.Add(LoadResString(@RsAttrReparsePoint));\r\n if Attr and FILE_ATTRIBUTE_SPARSE_FILE = FILE_ATTRIBUTE_SPARSE_FILE then\r\n Items.Add(LoadResString(@RsAttrSparseFile));\r\n finally\r\n Items.EndUpdate;\r\n end;\r\nend;\r\n\r\n{$ENDIF MSWINDOWS}\r\n\r\nfunction GetFileInformation(const FileName: string; out FileInfo: TSearchRec): Boolean;\r\nbegin\r\n Result := FindFirst(FileName, faAnyFile, FileInfo) = 0;\r\n if Result then\r\n {$IFDEF HAS_UNITSCOPE}System.{$ENDIF}SysUtils.FindClose(FileInfo);\r\nend;\r\n\r\nfunction GetFileInformation(const FileName: string): TSearchRec;\r\nbegin\r\n if not GetFileInformation(FileName, Result) then\r\n RaiseLastOSError;\r\nend;\r\n\r\n{$IFDEF UNIX}\r\n\r\n{ TODO -cHelp : Author: Robert Rossmair }\r\n\r\nfunction GetFileStatus(const FileName: string; out StatBuf: TStatBuf64;\r\n const ResolveSymLinks: Boolean): Integer;\r\nbegin\r\n if ResolveSymLinks then\r\n Result := stat64(PChar(FileName), StatBuf)\r\n else\r\n Result := lstat64(PChar(FileName), StatBuf);\r\nend;\r\n\r\n{$ENDIF UNIX}\r\n\r\n{$IFDEF MSWINDOWS}\r\n\r\nfunction GetFileLastWrite(const FileName: string): TFileTime;\r\nbegin\r\n Result := GetFileInformation(FileName).FindData.ftLastWriteTime;\r\nend;\r\n\r\nfunction GetFileLastWrite(const FileName: string; out LocalTime: TDateTime): Boolean;\r\nvar\r\n FileInfo: TSearchRec;\r\nbegin\r\n Result := GetFileInformation(FileName, FileInfo);\r\n if Result then\r\n LocalTime := FileTimeToLocalDateTime(GetFileInformation(FileName).FindData.ftLastWriteTime);\r\nend;\r\n\r\n{$ENDIF MSWINDOWS}\r\n\r\n{$IFDEF UNIX}\r\n\r\nfunction GetFileLastWrite(const FileName: string; out TimeStamp: Integer; ResolveSymLinks: Boolean): Boolean;\r\nvar\r\n Buf: TStatBuf64;\r\nbegin\r\n Result := GetFileStatus(FileName, Buf, ResolveSymLinks) = 0;\r\n if Result then\r\n TimeStamp := Buf.st_mtime\r\nend;\r\n\r\nfunction GetFileLastWrite(const FileName: string; out LocalTime: TDateTime; ResolveSymLinks: Boolean): Boolean;\r\nvar\r\n Buf: TStatBuf64;\r\nbegin\r\n Result := GetFileStatus(FileName, Buf, ResolveSymLinks) = 0;\r\n if Result then\r\n LocalTime := FileDateToDateTime(Buf.st_mtime);\r\nend;\r\n\r\nfunction GetFileLastWrite(const FileName: string; ResolveSymLinks: Boolean): Integer;\r\nvar\r\n Buf: TStatBuf64;\r\nbegin\r\n if GetFileStatus(FileName, Buf, ResolveSymLinks) = 0 then\r\n Result := Buf.st_mtime\r\n else\r\n Result := -1;\r\nend;\r\n\r\n{$ENDIF UNIX}\r\n\r\n{$IFDEF MSWINDOWS}\r\n\r\nfunction GetFileLastAccess(const FileName: string): TFileTime;\r\nbegin\r\n Result := GetFileInformation(FileName).FindData.ftLastAccessTime;\r\nend;\r\n\r\nfunction GetFileLastAccess(const FileName: string; out LocalTime: TDateTime): Boolean;\r\nvar\r\n FileInfo: TSearchRec;\r\nbegin\r\n Result := GetFileInformation(FileName, FileInfo);\r\n if Result then\r\n LocalTime := FileTimeToLocalDateTime(GetFileInformation(FileName).FindData.ftLastAccessTime);\r\nend;\r\n\r\n{$ENDIF MSWINDOWS}\r\n\r\n{$IFDEF UNIX}\r\n\r\nfunction GetFileLastAccess(const FileName: string; out TimeStamp: Integer; ResolveSymLinks: Boolean): Boolean;\r\nvar\r\n Buf: TStatBuf64;\r\nbegin\r\n Result := GetFileStatus(FileName, Buf, ResolveSymLinks) = 0;\r\n if Result then\r\n TimeStamp := Buf.st_atime\r\nend;\r\n\r\nfunction GetFileLastAccess(const FileName: string; out LocalTime: TDateTime; ResolveSymLinks: Boolean): Boolean;\r\nvar\r\n Buf: TStatBuf64;\r\nbegin\r\n Result := GetFileStatus(FileName, Buf, ResolveSymLinks) = 0;\r\n if Result then\r\n LocalTime := FileDateToDateTime(Buf.st_atime);\r\nend;\r\n\r\nfunction GetFileLastAccess(const FileName: string; ResolveSymLinks: Boolean): Integer;\r\nvar\r\n Buf: TStatBuf64;\r\nbegin\r\n if GetFileStatus(FileName, Buf, ResolveSymLinks) = 0 then\r\n Result := Buf.st_atime\r\n else\r\n Result := -1;\r\nend;\r\n\r\n{$ENDIF UNIX}\r\n\r\n{$IFDEF MSWINDOWS}\r\n\r\nfunction GetFileCreation(const FileName: string): TFileTime;\r\nbegin\r\n Result := GetFileInformation(FileName).FindData.ftCreationTime;\r\nend;\r\n\r\nfunction GetFileCreation(const FileName: string; out LocalTime: TDateTime): Boolean;\r\nvar\r\n FileInfo: TSearchRec;\r\nbegin\r\n Result := GetFileInformation(FileName, FileInfo);\r\n if Result then\r\n LocalTime := FileTimeToLocalDateTime(GetFileInformation(FileName).FindData.ftCreationTime);\r\nend;\r\n\r\n{$ENDIF MSWINDOWS}\r\n\r\n{$IFDEF UNIX}\r\n\r\nfunction GetFileLastAttrChange(const FileName: string; out TimeStamp: Integer; ResolveSymLinks: Boolean): Boolean;\r\nvar\r\n Buf: TStatBuf64;\r\nbegin\r\n Result := GetFileStatus(FileName, Buf, ResolveSymLinks) = 0;\r\n if Result then\r\n TimeStamp := Buf.st_ctime\r\nend;\r\n\r\nfunction GetFileLastAttrChange(const FileName: string; out LocalTime: TDateTime; ResolveSymLinks: Boolean): Boolean;\r\nvar\r\n Buf: TStatBuf64;\r\nbegin\r\n Result := GetFileStatus(FileName, Buf, ResolveSymLinks) = 0;\r\n if Result then\r\n LocalTime := FileDateToDateTime(Buf.st_ctime);\r\nend;\r\n\r\nfunction GetFileLastAttrChange(const FileName: string; ResolveSymLinks: Boolean): Integer;\r\nvar\r\n Buf: TStatBuf64;\r\nbegin\r\n if GetFileStatus(FileName, Buf, ResolveSymLinks) = 0 then\r\n Result := Buf.st_ctime\r\n else\r\n Result := -1;\r\nend;\r\n\r\n{$ENDIF UNIX}\r\n\r\nfunction GetModulePath(const Module: HMODULE): string;\r\nvar\r\n L: Integer;\r\nbegin\r\n L := MAX_PATH + 1;\r\n SetLength(Result, L);\r\n {$IFDEF MSWINDOWS}\r\n L := {$IFDEF HAS_UNITSCOPE}Winapi.{$ENDIF}Windows.GetModuleFileName(Module, Pointer(Result), L);\r\n {$ENDIF MSWINDOWS}\r\n {$IFDEF UNIX}\r\n {$IFDEF FPC}\r\n L := 0; // FIXME\r\n {$ELSE ~FPC}\r\n L := GetModuleFileName(Module, Pointer(Result), L);\r\n {$ENDIF ~FPC}\r\n {$ENDIF UNIX}\r\n SetLength(Result, L);\r\nend;\r\n\r\nfunction GetSizeOfFile(const FileName: string): Int64;\r\n{$IFDEF MSWINDOWS}\r\nvar\r\n FileAttributesEx: WIN32_FILE_ATTRIBUTE_DATA;\r\n Size: TJclULargeInteger;\r\nbegin\r\n Result := 0;\r\n if GetFileAttributesEx(PChar(FileName), GetFileExInfoStandard, @FileAttributesEx) then\r\n begin\r\n Size.LowPart := FileAttributesEx.nFileSizeLow;\r\n Size.HighPart := FileAttributesEx.nFileSizeHigh;\r\n Result := Size.QuadPart;\r\n end\r\n else\r\n RaiseLastOSError;\r\nend;\r\n{$ENDIF MSWINDOWS}\r\n{$IFDEF UNIX}\r\nvar\r\n Buf: TStatBuf64;\r\nbegin\r\n if GetFileStatus(FileName, Buf, False) <> 0 then\r\n RaiseLastOSError;\r\n Result := Buf.st_size;\r\nend;\r\n{$ENDIF UNIX}\r\n\r\n{$IFDEF MSWINDOWS}\r\nfunction GetSizeOfFile(Handle: THandle): Int64; overload;\r\nvar\r\n Size: TJclULargeInteger;\r\nbegin\r\n Size.LowPart := GetFileSize(Handle, @Size.HighPart);\r\n Result := Size.QuadPart;\r\nend;\r\n{$ENDIF MSWINDOWS}\r\n\r\nfunction GetSizeOfFile(const FileInfo: TSearchRec): Int64;\r\n{$IFDEF MSWINDOWS}\r\nbegin\r\n Int64Rec(Result).Lo := FileInfo.FindData.nFileSizeLow;\r\n Int64Rec(Result).Hi := FileInfo.FindData.nFileSizeHigh;\r\nend;\r\n{$ENDIF MSWINDOWS}\r\n{$IFDEF UNIX}\r\nvar\r\n Buf: TStatBuf64;\r\nbegin\r\n // rr: Note that SysUtils.FindFirst/Next ignore files >= 2 GB under Linux,\r\n // thus the following code is rather pointless at the moment of this writing.\r\n // We apparently need to write our own set of Findxxx functions to overcome this limitation.\r\n if GetFileStatus(FileInfo.PathOnly + FileInfo.Name, Buf, True) <> 0 then\r\n Result := -1\r\n else\r\n Result := Buf.st_size\r\nend;\r\n{$ENDIF UNIX}\r\n\r\n{$IFDEF MSWINDOWS}\r\n\r\n{$IFDEF FPC}\r\n{ TODO : Move this over to JclWin32 when JclWin32 gets overhauled. }\r\nfunction GetFileAttributesEx(lpFileName: PChar;\r\n fInfoLevelId: TGetFileExInfoLevels; lpFileInformation: Pointer): BOOL; stdcall;\r\nexternal kernel32 name 'GetFileAttributesExA';\r\n{$ENDIF FPC}\r\n\r\nfunction GetStandardFileInfo(const FileName: string): TWin32FileAttributeData;\r\nvar\r\n Handle: THandle;\r\n FileInfo: TByHandleFileInformation;\r\nbegin\r\n Assert(FileName <> '');\r\n { TODO : Use RTDL-Version of GetFileAttributesEx }\r\n if IsWin95 or IsWin95OSR2 or IsWinNT3 then\r\n begin\r\n Handle := CreateFile(PChar(FileName), GENERIC_READ, FILE_SHARE_READ, nil, OPEN_EXISTING, 0, 0);\r\n if Handle <> INVALID_HANDLE_VALUE then\r\n try\r\n FileInfo.dwFileAttributes := 0;\r\n if not GetFileInformationByHandle(Handle, FileInfo) then\r\n raise EJclFileUtilsError.CreateResFmt(@RsFileUtilsAttrUnavailable, [FileName]);\r\n Result.dwFileAttributes := FileInfo.dwFileAttributes;\r\n Result.ftCreationTime := FileInfo.ftCreationTime;\r\n Result.ftLastAccessTime := FileInfo.ftLastAccessTime;\r\n Result.ftLastWriteTime := FileInfo.ftLastWriteTime;\r\n Result.nFileSizeHigh := FileInfo.nFileSizeHigh;\r\n Result.nFileSizeLow := FileInfo.nFileSizeLow;\r\n finally\r\n CloseHandle(Handle);\r\n end\r\n else\r\n raise EJclFileUtilsError.CreateResFmt(@RsFileUtilsAttrUnavailable, [FileName]);\r\n end\r\n else\r\n begin\r\n if not GetFileAttributesEx(PChar(FileName), GetFileExInfoStandard, @Result) then\r\n raise EJclFileUtilsError.CreateResFmt(@RsFileUtilsAttrUnavailable, [FileName]);\r\n end;\r\nend;\r\n\r\n{$ENDIF MSWINDOWS}\r\n\r\n{$IFDEF MSWINDOWS}\r\nfunction IsDirectory(const FileName: string): Boolean;\r\nvar\r\n R: DWORD;\r\nbegin\r\n R := GetFileAttributes(PChar(FileName));\r\n Result := (R <> DWORD(-1)) and ((R and FILE_ATTRIBUTE_DIRECTORY) <> 0);\r\nend;\r\n{$ENDIF MSWINDOWS}\r\n{$IFDEF UNIX}\r\nfunction IsDirectory(const FileName: string; ResolveSymLinks: Boolean): Boolean;\r\nvar\r\n Buf: TStatBuf64;\r\nbegin\r\n Result := False;\r\n if GetFileStatus(FileName, Buf, ResolveSymLinks) = 0 then\r\n Result := S_ISDIR(Buf.st_mode);\r\nend;\r\n{$ENDIF UNIX}\r\n\r\nfunction IsRootDirectory(const CanonicFileName: string): Boolean;\r\n{$IFDEF MSWINDOWS}\r\nvar\r\n I: Integer;\r\nbegin\r\n I := Pos(':\\', CanonicFileName);\r\n Result := (I > 0) and (I + 1 = Length(CanonicFileName));\r\nend;\r\n{$ENDIF MSWINDOWS}\r\n{$IFDEF UNIX}\r\nbegin\r\n Result := CanonicFileName = DirDelimiter;\r\nend;\r\n{$ENDIF UNIX}\r\n\r\n{$IFDEF MSWINDOWS}\r\n\r\nfunction LockVolume(const Volume: string; var Handle: THandle): Boolean;\r\nvar\r\n BytesReturned: DWORD;\r\nbegin\r\n Result := False;\r\n Handle := CreateFile(PChar('\\\\.\\' + Volume), GENERIC_READ or GENERIC_WRITE,\r\n FILE_SHARE_READ or FILE_SHARE_WRITE, nil, OPEN_EXISTING,\r\n FILE_FLAG_NO_BUFFERING, 0);\r\n if Handle <> INVALID_HANDLE_VALUE then\r\n begin\r\n BytesReturned := 0;\r\n Result := DeviceIoControl(Handle, FSCTL_LOCK_VOLUME, nil, 0, nil, 0,\r\n BytesReturned, nil);\r\n if not Result then\r\n begin\r\n CloseHandle(Handle);\r\n Handle := INVALID_HANDLE_VALUE;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction OpenVolume(const Drive: Char): THandle;\r\nvar\r\n VolumeName: array [0..6] of Char;\r\nbegin\r\n VolumeName := '\\\\.\\A:';\r\n VolumeName[4] := Drive;\r\n Result := CreateFile(VolumeName, GENERIC_READ, FILE_SHARE_READ or FILE_SHARE_WRITE,\r\n nil, OPEN_EXISTING, 0, 0);\r\nend;\r\n\r\n{$ENDIF MSWINDOWS}\r\n\r\ntype\r\n // indicates the file time to set, used by SetFileTimesHelper and SetDirTimesHelper\r\n TFileTimes = (ftLastAccess, ftLastWrite {$IFDEF MSWINDOWS}, ftCreation {$ENDIF});\r\n\r\n{$IFDEF MSWINDOWS}\r\nfunction SetFileTimesHelper(const FileName: string; const DateTime: TDateTime; Times: TFileTimes): Boolean;\r\nvar\r\n Handle: THandle;\r\n FileTime: TFileTime;\r\n SystemTime: TSystemTime;\r\nbegin\r\n Result := False;\r\n Handle := CreateFile(PChar(FileName), GENERIC_WRITE, FILE_SHARE_READ, nil,\r\n OPEN_EXISTING, 0, 0);\r\n if Handle <> INVALID_HANDLE_VALUE then\r\n try\r\n //SysUtils.DateTimeToSystemTime(DateTimeToLocalDateTime(DateTime), SystemTime);\r\n {$IFDEF HAS_UNITSCOPE}System.{$ENDIF}SysUtils.DateTimeToSystemTime(DateTime, SystemTime);\r\n FileTime.dwLowDateTime := 0;\r\n FileTime.dwHighDateTime := 0;\r\n if {$IFDEF HAS_UNITSCOPE}Winapi.{$ENDIF}Windows.SystemTimeToFileTime(SystemTime, FileTime) then\r\n begin\r\n case Times of\r\n ftLastAccess:\r\n Result := SetFileTime(Handle, nil, @FileTime, nil);\r\n ftLastWrite:\r\n Result := SetFileTime(Handle, nil, nil, @FileTime);\r\n ftCreation:\r\n Result := SetFileTime(Handle, @FileTime, nil, nil);\r\n end;\r\n end;\r\n finally\r\n CloseHandle(Handle);\r\n end;\r\nend;\r\n{$ENDIF MSWINDOWS}\r\n\r\n{$IFDEF UNIX}\r\nfunction SetFileTimesHelper(const FileName: string; const DateTime: TDateTime; Times: TFileTimes): Boolean;\r\nvar\r\n FileTime: Integer;\r\n StatBuf: TStatBuf64;\r\n TimeBuf: utimbuf;\r\nbegin\r\n Result := False;\r\n FileTime := DateTimeToFileDate(DateTime);\r\n if GetFileStatus(FileName, StatBuf, False) = 0 then\r\n begin\r\n TimeBuf.actime := StatBuf.st_atime;\r\n TimeBuf.modtime := StatBuf.st_mtime;\r\n case Times of\r\n ftLastAccess:\r\n TimeBuf.actime := FileTime;\r\n ftLastWrite:\r\n TimeBuf.modtime := FileTime;\r\n end;\r\n Result := utime(PChar(FileName), @TimeBuf) = 0;\r\n end;\r\nend;\r\n{$ENDIF UNIX}\r\n\r\nfunction SetFileLastAccess(const FileName: string; const DateTime: TDateTime): Boolean;\r\nbegin\r\n Result := SetFileTimesHelper(FileName, DateTime, ftLastAccess);\r\nend;\r\n\r\nfunction SetFileLastWrite(const FileName: string; const DateTime: TDateTime): Boolean;\r\nbegin\r\n Result := SetFileTimesHelper(FileName, DateTime, ftLastWrite);\r\nend;\r\n\r\n{$IFDEF MSWINDOWS}\r\n\r\nfunction SetFileCreation(const FileName: string; const DateTime: TDateTime): Boolean;\r\nbegin\r\n Result := SetFileTimesHelper(FileName, DateTime, ftCreation);\r\nend;\r\n\r\n// utility function for SetDirTimesHelper\r\n\r\nfunction BackupPrivilegesEnabled: Boolean;\r\nbegin\r\n Result := IsPrivilegeEnabled(SE_BACKUP_NAME) and IsPrivilegeEnabled(SE_RESTORE_NAME);\r\nend;\r\n\r\nfunction SetDirTimesHelper(const DirName: string; const DateTime: TDateTime;\r\n Times: TFileTimes; RequireBackupRestorePrivileges: Boolean): Boolean;\r\nvar\r\n Handle: THandle;\r\n FileTime: TFileTime;\r\n SystemTime: TSystemTime;\r\nbegin\r\n Result := False;\r\n if IsDirectory(DirName) and (not RequireBackupRestorePrivileges or BackupPrivilegesEnabled) then\r\n begin\r\n Handle := CreateFile(PChar(DirName), GENERIC_WRITE, FILE_SHARE_READ, nil,\r\n OPEN_EXISTING, FILE_FLAG_BACKUP_SEMANTICS, 0);\r\n if Handle <> INVALID_HANDLE_VALUE then\r\n try\r\n {$IFDEF HAS_UNITSCOPE}System.{$ENDIF}SysUtils.DateTimeToSystemTime(DateTime, SystemTime);\r\n FileTime.dwLowDateTime := 0;\r\n FileTime.dwHighDateTime := 0;\r\n {$IFDEF HAS_UNITSCOPE}Winapi.{$ENDIF}Windows.SystemTimeToFileTime(SystemTime, FileTime);\r\n case Times of\r\n ftLastAccess:\r\n Result := SetFileTime(Handle, nil, @FileTime, nil);\r\n ftLastWrite:\r\n Result := SetFileTime(Handle, nil, nil, @FileTime);\r\n ftCreation:\r\n Result := SetFileTime(Handle, @FileTime, nil, nil);\r\n end;\r\n finally\r\n CloseHandle(Handle);\r\n end;\r\n end;\r\nend;\r\n\r\nfunction SetDirLastWrite(const DirName: string; const DateTime: TDateTime; RequireBackupRestorePrivileges: Boolean = True): Boolean;\r\nbegin\r\n Result := SetDirTimesHelper(DirName, DateTime, ftLastWrite, RequireBackupRestorePrivileges);\r\nend;\r\n\r\nfunction SetDirLastAccess(const DirName: string; const DateTime: TDateTime; RequireBackupRestorePrivileges: Boolean = True): Boolean;\r\nbegin\r\n Result := SetDirTimesHelper(DirName, DateTime, ftLastAccess, RequireBackupRestorePrivileges);\r\nend;\r\n\r\nfunction SetDirCreation(const DirName: string; const DateTime: TDateTime; RequireBackupRestorePrivileges: Boolean = True): Boolean;\r\nbegin\r\n Result := SetDirTimesHelper(DirName, DateTime, ftCreation, RequireBackupRestorePrivileges);\r\nend;\r\n\r\nprocedure FillByteArray(var Bytes: array of Byte; Count: Cardinal; B: Byte);\r\nbegin\r\n FillMemory(@Bytes[0], Count, B);\r\nend;\r\n\r\nprocedure ShredFile(const FileName: string; Times: Integer);\r\nconst\r\n BUFSIZE = 4096;\r\n ODD_FILL = $C1;\r\n EVEN_FILL = $3E;\r\nvar\r\n Fs: TFileStream;\r\n Size: Integer;\r\n N: Integer;\r\n ContentPtr: array of Byte;\r\nbegin\r\n Size := FileGetSize(FileName);\r\n if Size > 0 then\r\n begin\r\n if Times < 0 then\r\n Times := 2\r\n else\r\n Times := Times * 2;\r\n ContentPtr := nil;\r\n Fs := TFileStream.Create(FileName, fmOpenReadWrite);\r\n try\r\n SetLength(ContentPtr, BUFSIZE);\r\n while Times > 0 do\r\n begin\r\n if Times mod 2 = 0 then\r\n FillByteArray(ContentPtr, BUFSIZE, EVEN_FILL)\r\n else\r\n FillByteArray(ContentPtr, BUFSIZE, ODD_FILL);\r\n Fs.Seek(0, soBeginning);\r\n N := Size div BUFSIZE;\r\n while N > 0 do\r\n begin\r\n Fs.Write(ContentPtr[0], BUFSIZE);\r\n Dec(N);\r\n end;\r\n N := Size mod BUFSIZE;\r\n if N > 0 then\r\n Fs.Write(ContentPtr[0], N);\r\n FlushFileBuffers(Fs.Handle);\r\n Dec(Times);\r\n end;\r\n finally\r\n ContentPtr := nil;\r\n Fs.Free;\r\n DeleteFile(FileName);\r\n end;\r\n end\r\n else\r\n DeleteFile(FileName);\r\nend;\r\n\r\nfunction UnlockVolume(var Handle: THandle): Boolean;\r\nvar\r\n BytesReturned: DWORD;\r\nbegin\r\n Result := False;\r\n if Handle <> INVALID_HANDLE_VALUE then\r\n begin\r\n BytesReturned := 0;\r\n Result := DeviceIoControl(Handle, FSCTL_UNLOCK_VOLUME, nil, 0, nil, 0,\r\n BytesReturned, nil);\r\n if Result then\r\n begin\r\n CloseHandle(Handle);\r\n Handle := INVALID_HANDLE_VALUE;\r\n end;\r\n end;\r\nend;\r\n\r\n{$ENDIF MSWINDOWS}\r\n\r\n{$IFDEF UNIX}\r\n\r\nfunction CreateSymbolicLink(const Name, Target: string): Boolean;\r\nbegin\r\n Result := symlink(PChar(Target), PChar(Name)) = 0;\r\nend;\r\n\r\nfunction SymbolicLinkTarget(const Name: string): string;\r\nvar\r\n N, BufLen: Integer;\r\nbegin\r\n BufLen := 128;\r\n repeat\r\n Inc(BufLen, BufLen);\r\n SetLength(Result, BufLen);\r\n N := readlink(PChar(Name), PChar(Result), BufLen);\r\n if N < 0 then // Error\r\n begin\r\n Result := '';\r\n Exit;\r\n end;\r\n until N < BufLen;\r\n SetLength(Result, N);\r\nend;\r\n\r\n{$ENDIF UNIX}\r\n\r\n//=== File Version info routines =============================================\r\n\r\n{$IFDEF MSWINDOWS}\r\n\r\nconst\r\n VerKeyNames: array [1..12] of string =\r\n ('Comments',\r\n 'CompanyName',\r\n 'FileDescription',\r\n 'FileVersion',\r\n 'InternalName',\r\n 'LegalCopyright',\r\n 'LegalTradeMarks',\r\n 'OriginalFilename',\r\n 'ProductName',\r\n 'ProductVersion',\r\n 'SpecialBuild',\r\n 'PrivateBuild');\r\n\r\nfunction OSIdentToString(const OSIdent: DWORD): string;\r\nbegin\r\n case OSIdent of\r\n VOS_UNKNOWN:\r\n Result := LoadResString(@RsVosUnknown);\r\n VOS_DOS:\r\n Result := LoadResString(@RsVosDos);\r\n VOS_OS216:\r\n Result := LoadResString(@RsVosOS216);\r\n VOS_OS232:\r\n Result := LoadResString(@RsVosOS232);\r\n VOS_NT:\r\n Result := LoadResString(@RsVosNT);\r\n VOS__WINDOWS16:\r\n Result := LoadResString(@RsVosWindows16);\r\n VOS__PM16:\r\n Result := LoadResString(@RsVosPM16);\r\n VOS__PM32:\r\n Result := LoadResString(@RsVosPM32);\r\n VOS__WINDOWS32:\r\n Result := LoadResString(@RsVosWindows32);\r\n VOS_DOS_WINDOWS16:\r\n Result := LoadResString(@RsVosDosWindows16);\r\n VOS_DOS_WINDOWS32:\r\n Result := LoadResString(@RsVosDosWindows32);\r\n VOS_OS216_PM16:\r\n Result := LoadResString(@RsVosOS216PM16);\r\n VOS_OS232_PM32:\r\n Result := LoadResString(@RsVosOS232PM32);\r\n VOS_NT_WINDOWS32:\r\n Result := LoadResString(@RsVosNTWindows32);\r\n else\r\n Result := '';\r\n end;\r\n if Result = '' then\r\n Result := LoadResString(@RsVosUnknown)\r\n else\r\n Result := Format(LoadResString(@RsVosDesignedFor), [Result]);\r\nend;\r\n\r\nfunction OSFileTypeToString(const OSFileType: DWORD; const OSFileSubType: DWORD): string;\r\nbegin\r\n case OSFileType of\r\n VFT_UNKNOWN:\r\n Result := LoadResString(@RsVftUnknown);\r\n VFT_APP:\r\n Result := LoadResString(@RsVftApp);\r\n VFT_DLL:\r\n Result := LoadResString(@RsVftDll);\r\n VFT_DRV:\r\n begin\r\n case OSFileSubType of\r\n VFT2_DRV_PRINTER:\r\n Result := LoadResString(@RsVft2DrvPRINTER);\r\n VFT2_DRV_KEYBOARD:\r\n Result := LoadResString(@RsVft2DrvKEYBOARD);\r\n VFT2_DRV_LANGUAGE:\r\n Result := LoadResString(@RsVft2DrvLANGUAGE);\r\n VFT2_DRV_DISPLAY:\r\n Result := LoadResString(@RsVft2DrvDISPLAY);\r\n VFT2_DRV_MOUSE:\r\n Result := LoadResString(@RsVft2DrvMOUSE);\r\n VFT2_DRV_NETWORK:\r\n Result := LoadResString(@RsVft2DrvNETWORK);\r\n VFT2_DRV_SYSTEM:\r\n Result := LoadResString(@RsVft2DrvSYSTEM);\r\n VFT2_DRV_INSTALLABLE:\r\n Result := LoadResString(@RsVft2DrvINSTALLABLE);\r\n VFT2_DRV_SOUND:\r\n Result := LoadResString(@RsVft2DrvSOUND);\r\n VFT2_DRV_COMM:\r\n Result := LoadResString(@RsVft2DrvCOMM);\r\n else\r\n Result := '';\r\n end;\r\n Result := Result + ' ' + LoadResString(@RsVftDrv);\r\n end;\r\n VFT_FONT:\r\n begin\r\n case OSFileSubType of\r\n VFT2_FONT_RASTER:\r\n Result := LoadResString(@RsVft2FontRASTER);\r\n VFT2_FONT_VECTOR:\r\n Result := LoadResString(@RsVft2FontVECTOR);\r\n VFT2_FONT_TRUETYPE:\r\n Result := LoadResString(@RsVft2FontTRUETYPE);\r\n else\r\n Result := '';\r\n end;\r\n Result := Result + ' ' + LoadResString(@RsVftFont);\r\n end;\r\n VFT_VXD:\r\n Result := LoadResString(@RsVftVxd);\r\n VFT_STATIC_LIB:\r\n Result := LoadResString(@RsVftStaticLib);\r\n else\r\n Result := '';\r\n end;\r\n Result := TrimLeft(Result);\r\nend;\r\n\r\nfunction VersionResourceAvailable(const FileName: string): Boolean;\r\nvar\r\n Size: DWORD;\r\n Handle: DWORD;\r\n Buffer: string;\r\nbegin\r\n Result := False;\r\n Handle := 0;\r\n Size := GetFileVersionInfoSize(PChar(FileName), Handle);\r\n if Size > 0 then\r\n begin\r\n SetLength(Buffer, Size);\r\n Result := GetFileVersionInfo(PChar(FileName), Handle, Size, PChar(Buffer));\r\n end;\r\nend;\r\n\r\nfunction VersionResourceAvailable(const Window: HWND): Boolean;\r\nbegin\r\n Result := VersionResourceAvailable(WindowToModuleFileName(Window));\r\nend;\r\n\r\nfunction VersionResourceAvailable(const Module: HMODULE): Boolean;\r\nbegin\r\n if Module <> 0 then\r\n Result :=VersionResourceAvailable(GetModulePath(Module))\r\n else\r\n raise EJclError.CreateResFmt(@RsEModuleNotValid, [Module]);\r\nend;\r\n\r\nfunction WindowToModuleFileName(const Window: HWND): string;\r\ntype\r\n {$IFDEF SUPPORTS_UNICODE}\r\n TGetModuleFileNameEx = function(hProcess: THandle; hModule: HMODULE; FileName: PWideChar; nSize: DWORD): DWORD; stdcall;\r\n TQueryFullProcessImageName = function(HProcess: THandle; dwFlags: DWORD; lpExeName: PWideChar; lpdwSize: PDWORD): integer; stdcall;\r\n {$ELSE ~SUPPORTS_UNICODE}\r\n TGetModuleFileNameEx = function(hProcess: THandle; hModule: HMODULE; FileName: PAnsiChar; nSize: DWORD): DWORD; stdcall;\r\n TQueryFullProcessImageName = function(HProcess: THandle; dwFlags: DWORD; lpExeName: PAnsiChar; lpdwSize: PDWORD): integer; stdcall;\r\n {$ENDIF ~SUPPORTS_UNICODE}\r\nvar\r\n FileName: array[0..300] of Char;\r\n DllHinst: HMODULE;\r\n ProcessID: DWORD;\r\n HProcess: THandle;\r\n GetModuleFileNameExAddress: TGetModuleFileNameEx;\r\n QueryFullProcessImageNameAddress: TQueryFullProcessImageName;\r\nbegin\r\n Result := '';\r\n if Window <> 0 then\r\n begin\r\n {$IFDEF HAS_UNITSCOPE}Winapi.{$ENDIF}Windows.GetWindowThreadProcessId(Window, @ProcessID);\r\n hProcess := {$IFDEF HAS_UNITSCOPE}Winapi.{$ENDIF}Windows.OpenProcess(PROCESS_QUERY_INFORMATION or PROCESS_VM_READ, false, ProcessID);\r\n if hProcess <> 0 then\r\n begin\r\n if GetWindowsVersion() < WVWin2000 then\r\n raise EJclWin32Error.CreateRes(@RsEWindowsVersionNotSupported)\r\n else if GetWindowsVersion >=WvWinVista then\r\n begin\r\n DllHinst := LoadLibrary('Kernel32.dll');\r\n if DllHinst < HINSTANCE_ERROR then\r\n begin\r\n try\r\n {$IFDEF SUPPORTS_UNICODE}\r\n QueryFullProcessImageNameAddress := GetProcAddress(DllHinst, 'QueryFullProcessImageNameW');\r\n {$ELSE ~SUPPORTS_UNICODE}\r\n QueryFullProcessImageNameAddress := GetProcAddress(DllHinst, 'QueryFullProcessImageNameA');\r\n {$ENDIF ~SUPPORTS_UNICODE}\r\n if Assigned(QueryFullProcessImageNameAddress) then\r\n begin\r\n QueryFullProcessImageNameAddress(hProcess, 0, FileName, PDWORD(sizeof(FileName)));\r\n Result := FileName;\r\n end\r\n else\r\n begin\r\n raise EJclError.CreateResFmt(@RsEFunctionNotFound, ['Kernel32.dll', 'QueryFullProcessImageName']);\r\n end\r\n finally\r\n FreeLibrary(DllHinst);\r\n end;\r\n end\r\n else\r\n raise EJclError.CreateResFmt(@RsELibraryNotFound, ['Kernel32.dll']);\r\n end\r\n else\r\n begin\r\n DllHinst := LoadLibrary('Psapi.dll');\r\n if DllHinst < HINSTANCE_ERROR then\r\n begin\r\n try\r\n {$IFDEF SUPPORTS_UNICODE}\r\n GetModuleFileNameExAddress := GetProcAddress(DllHinst, 'GetModuleFileNameExW');\r\n {$ELSE ~SUPPORTS_UNICODE}\r\n GetModuleFileNameExAddress := GetProcAddress(DllHinst, 'GetModuleFileNameExA');\r\n {$ENDIF ~SUPPORTS_UNICODE}\r\n if Assigned(GetModuleFileNameExAddress) then\r\n begin\r\n GetModuleFileNameExAddress(hProcess, 0, FileName, sizeof(FileName));\r\n Result := FileName;\r\n end\r\n else\r\n begin\r\n raise EJclError.CreateResFmt(@RsEFunctionNotFound, ['Psapi.dll', 'GetModuleFileNameEx']);\r\n end\r\n finally\r\n FreeLibrary(DllHinst);\r\n end;\r\n end\r\n else\r\n raise EJclError.CreateResFmt(@RsELibraryNotFound, ['Psapi.dll']);\r\n end;\r\n end\r\n else\r\n raise EJclError.CreateResFmt(@RsEProcessNotValid, [ProcessID]);\r\n end\r\n else\r\n raise EJclError.CreateResFmt(@RsEWindowNotValid, [Window]);\r\nend;\r\n\r\n{$ENDIF MSWINDOWS}\r\n\r\n// Version Info formatting\r\nfunction FormatVersionString(const HiV, LoV: Word): string;\r\nbegin\r\n Result := Format('%u.%.2u', [HiV, LoV]);\r\nend;\r\n\r\nfunction FormatVersionString(const Major, Minor, Build, Revision: Word): string;\r\nbegin\r\n Result := Format('%u.%u.%u.%u', [Major, Minor, Build, Revision]);\r\nend;\r\n\r\n{$IFDEF MSWINDOWS}\r\n\r\nfunction FormatVersionString(const FixedInfo: TVSFixedFileInfo; VersionFormat: TFileVersionFormat): string;\r\nbegin\r\n case VersionFormat of\r\n vfMajorMinor:\r\n Result := Format('%u.%u', [HiWord(FixedInfo.dwFileVersionMS), LoWord(FixedInfo.dwFileVersionMS)]);\r\n vfFull:\r\n Result := Format('%u.%u.%u.%u', [HiWord(FixedInfo.dwFileVersionMS), LoWord(FixedInfo.dwFileVersionMS),\r\n HiWord(FixedInfo.dwFileVersionLS), LoWord(FixedInfo.dwFileVersionLS)]);\r\n end;\r\nend;\r\n\r\n// Version Info extracting\r\nprocedure VersionExtractFileInfo(const FixedInfo: TVSFixedFileInfo; var Major, Minor, Build, Revision: Word);\r\nbegin\r\n Major := HiWord(FixedInfo.dwFileVersionMS);\r\n Minor := LoWord(FixedInfo.dwFileVersionMS);\r\n Build := HiWord(FixedInfo.dwFileVersionLS);\r\n Revision := LoWord(FixedInfo.dwFileVersionLS);\r\nend;\r\n\r\nprocedure VersionExtractProductInfo(const FixedInfo: TVSFixedFileInfo; var Major, Minor, Build, Revision: Word);\r\nbegin\r\n Major := HiWord(FixedInfo.dwProductVersionMS);\r\n Minor := LoWord(FixedInfo.dwProductVersionMS);\r\n Build := HiWord(FixedInfo.dwProductVersionLS);\r\n Revision := LoWord(FixedInfo.dwProductVersionLS);\r\nend;\r\n\r\n// Fixed Version Info routines\r\nfunction VersionFixedFileInfo(const FileName: string; var FixedInfo: TVSFixedFileInfo): Boolean;\r\nvar\r\n Size, FixInfoLen: DWORD;\r\n Handle: DWORD;\r\n Buffer: string;\r\n FixInfoBuf: PVSFixedFileInfo;\r\nbegin\r\n Result := False;\r\n Handle := 0;\r\n Size := GetFileVersionInfoSize(PChar(FileName), Handle);\r\n if Size > 0 then\r\n begin\r\n SetLength(Buffer, Size);\r\n FixInfoLen := 0;\r\n FixInfoBuf := nil;\r\n if GetFileVersionInfo(PChar(FileName), Handle, Size, Pointer(Buffer)) and\r\n VerQueryValue(Pointer(Buffer), DirDelimiter, Pointer(FixInfoBuf), FixInfoLen) and\r\n (FixInfoLen = SizeOf(TVSFixedFileInfo)) then\r\n begin\r\n Result := True;\r\n FixedInfo := FixInfoBuf^;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction VersionFixedFileInfoString(const FileName: string; VersionFormat: TFileVersionFormat;\r\n const NotAvailableText: string): string;\r\nvar\r\n FixedInfo: TVSFixedFileInfo;\r\nbegin\r\n FixedInfo.dwSignature := 0;\r\n if VersionFixedFileInfo(FileName, FixedInfo) then\r\n Result := FormatVersionString(FixedInfo, VersionFormat)\r\n else\r\n Result := NotAvailableText;\r\nend;\r\n\r\n//=== { TJclFileVersionInfo } ================================================\r\n\r\nconstructor TJclFileVersionInfo.Attach(VersionInfoData: Pointer; Size: Integer);\r\nbegin\r\n SetLength(FBuffer, Size);\r\n CopyMemory(PAnsiChar(FBuffer), VersionInfoData, Size);\r\n ExtractData;\r\nend;\r\n\r\nconstructor TJclFileVersionInfo.Create(const FileName: string);\r\nvar\r\n Handle: DWORD;\r\n Size: DWORD;\r\nbegin\r\n if not FileExists(FileName) then\r\n raise EJclFileVersionInfoError.CreateResFmt(@RsFileUtilsFileDoesNotExist, [FileName]);\r\n Handle := 0;\r\n Size := GetFileVersionInfoSize(PChar(FileName), Handle);\r\n if Size = 0 then\r\n raise EJclFileVersionInfoError.CreateRes(@RsFileUtilsNoVersionInfo);\r\n SetLength(FBuffer, Size);\r\n Win32Check(GetFileVersionInfo(PChar(FileName), Handle, Size, PAnsiChar(FBuffer)));\r\n ExtractData;\r\nend;\r\n\r\n{$IFDEF MSWINDOWS}\r\n{$IFDEF FPC}\r\nconstructor TJclFileVersionInfo.Create(const Window: HWND; Dummy: Pointer = nil);\r\n{$ELSE}\r\nconstructor TJclFileVersionInfo.Create(const Window: HWND);\r\n{$ENDIF}\r\nbegin\r\n Create(WindowToModuleFileName(Window));\r\nend;\r\n\r\nconstructor TJclFileVersionInfo.Create(const Module: HMODULE);\r\nbegin\r\n if Module <> 0 then\r\n Create(GetModulePath(Module))\r\n else\r\n raise EJclError.CreateResFmt(@RsEModuleNotValid, [Module]);\r\nend;\r\n{$ENDIF MSWINDOWS}\r\n\r\ndestructor TJclFileVersionInfo.Destroy;\r\nbegin\r\n FreeAndNil(FItemList);\r\n FreeAndNil(FItems);\r\n inherited Destroy;\r\nend;\r\n\r\nclass function TJclFileVersionInfo.FileHasVersionInfo(const FileName: string): boolean;\r\nvar\r\n Dummy: DWord;\r\nbegin\r\n Result := GetFileVersionInfoSize(PChar(FileName), Dummy) <> 0;\r\nend;\r\n\r\nprocedure TJclFileVersionInfo.CheckLanguageIndex(Value: Integer);\r\nbegin\r\n if (Value < 0) or (Value >= LanguageCount) then\r\n raise EJclFileVersionInfoError.CreateRes(@RsFileUtilsLanguageIndex);\r\nend;\r\n\r\nprocedure TJclFileVersionInfo.CreateItemsForLanguage;\r\nvar\r\n I: Integer;\r\nbegin\r\n Items.Clear;\r\n for I := 0 to FItemList.Count - 1 do\r\n if Integer(FItemList.Objects[I]) = FLanguageIndex then\r\n Items.AddObject(FItemList[I], Pointer(FLanguages[FLanguageIndex].Pair));\r\nend;\r\n\r\nprocedure TJclFileVersionInfo.ExtractData;\r\nvar\r\n Data, EndOfData: PAnsiChar;\r\n Len, ValueLen, DataType: Word;\r\n HeaderSize: Integer;\r\n Key: string;\r\n Error, IsUnicode: Boolean;\r\n\r\n procedure Padding(var DataPtr: PAnsiChar);\r\n begin\r\n while TJclAddr(DataPtr) and 3 <> 0 do\r\n Inc(DataPtr);\r\n end;\r\n\r\n procedure GetHeader;\r\n var\r\n P: PAnsiChar;\r\n TempKey: PWideChar;\r\n begin\r\n Key := '';\r\n P := Data;\r\n Len := PWord(P)^;\r\n if Len = 0 then\r\n begin\r\n // do not raise error in the case of resources padded with 0\r\n while P < EndOfData do\r\n begin\r\n Error := P^ <> #0;\r\n if Error then\r\n Break;\r\n Inc(P);\r\n end;\r\n Exit;\r\n end;\r\n Inc(P, SizeOf(Word));\r\n ValueLen := PWord(P)^;\r\n Inc(P, SizeOf(Word));\r\n if IsUnicode then\r\n begin\r\n DataType := PWord(P)^;\r\n Inc(P, SizeOf(Word));\r\n TempKey := PWideChar(P);\r\n Inc(P, (lstrlenW(TempKey) + 1) * SizeOf(WideChar)); // length + #0#0\r\n Key := TempKey;\r\n end\r\n else\r\n begin\r\n DataType := 1;\r\n Key := string(PAnsiChar(P));\r\n Inc(P, lstrlenA(PAnsiChar(P)) + 1);\r\n end;\r\n Padding(P);\r\n HeaderSize := P - Data;\r\n Data := P;\r\n end;\r\n\r\n procedure FixKeyValue;\r\n const\r\n HexNumberCPrefix = '0x';\r\n var\r\n I: Integer;\r\n begin // GAPI32.DLL version 5.5.2803.1 contanins '04050x04E2' value\r\n repeat\r\n I := Pos(HexNumberCPrefix, Key);\r\n if I > 0 then\r\n Delete(Key, I, Length(HexNumberCPrefix));\r\n until I = 0;\r\n I := 1;\r\n while I <= Length(Key) do\r\n if CharIsHexDigit(Key[I]) then\r\n Inc(I)\r\n else\r\n Delete(Key, I, 1);\r\n end;\r\n\r\n procedure ProcessStringInfo(Size: Integer);\r\n var\r\n EndPtr, EndStringPtr: PAnsiChar;\r\n LangIndex: Integer;\r\n LangIdRec: TLangIdRec;\r\n Value: string;\r\n begin\r\n EndPtr := Data + Size;\r\n LangIndex := 0;\r\n while not Error and (Data < EndPtr) do\r\n begin\r\n GetHeader; // StringTable\r\n FixKeyValue;\r\n if (ValueLen <> 0) or (Length(Key) <> 8) then\r\n begin\r\n Error := True;\r\n Break;\r\n end;\r\n Padding(Data);\r\n LangIdRec.LangId := StrToIntDef('$' + Copy(Key, 1, 4), 0);\r\n LangIdRec.CodePage := StrToIntDef('$' + Copy(Key, 5, 4), 0);\r\n SetLength(FLanguages, LangIndex + 1);\r\n FLanguages[LangIndex] := LangIdRec;\r\n EndStringPtr := Data + Len - HeaderSize;\r\n while not Error and (Data < EndStringPtr) do\r\n begin\r\n GetHeader; // string\r\n case DataType of\r\n 0:\r\n if ValueLen in [1..4] then\r\n Value := Format('$%.*x', [ValueLen * 2, PInteger(Data)^])\r\n else\r\n begin\r\n if (ValueLen > 0) and IsUnicode then\r\n Value:=PWideChar(Data)\r\n else\r\n Value := '';\r\n end;\r\n 1:\r\n if ValueLen = 0 then\r\n Value := ''\r\n else\r\n if IsUnicode then\r\n begin\r\n Value := WideCharLenToString(PWideChar(Data), ValueLen);\r\n StrResetLength(Value);\r\n end\r\n else\r\n Value := string(PAnsiChar(Data));\r\n else\r\n Error := True;\r\n Break;\r\n end;\r\n Inc(Data, Len - HeaderSize);\r\n Padding(Data); // String.Padding\r\n FItemList.AddObject(Format('%s=%s', [Key, Value]), Pointer(LangIndex));\r\n end;\r\n Inc(LangIndex);\r\n end;\r\n end;\r\n\r\n procedure ProcessVarInfo;\r\n var\r\n TranslationIndex: Integer;\r\n begin\r\n GetHeader; // Var\r\n if SameText(Key, 'Translation') then\r\n begin\r\n SetLength(FTranslations, ValueLen div SizeOf(TLangIdRec));\r\n for TranslationIndex := 0 to Length(FTranslations) - 1 do\r\n begin\r\n FTranslations[TranslationIndex] := PLangIdRec(Data)^;\r\n Inc(Data, SizeOf(TLangIdRec));\r\n end;\r\n end;\r\n end;\r\n\r\nbegin\r\n FItemList := TStringList.Create;\r\n FItems := TStringList.Create;\r\n Data := Pointer(FBuffer);\r\n Assert(TJclAddr(Data) mod 4 = 0);\r\n IsUnicode := (PWord(Data + 4)^ in [0, 1]);\r\n Error := True;\r\n GetHeader;\r\n EndOfData := Data + Len - HeaderSize;\r\n if SameText(Key, 'VS_VERSION_INFO') and (ValueLen = SizeOf(TVSFixedFileInfo)) then\r\n begin\r\n FFixedInfo := PVSFixedFileInfo(Data);\r\n Error := FFixedInfo.dwSignature <> $FEEF04BD;\r\n Inc(Data, ValueLen); // VS_FIXEDFILEINFO\r\n Padding(Data); // VS_VERSIONINFO.Padding2\r\n while not Error and (Data < EndOfData) do\r\n begin\r\n GetHeader;\r\n Inc(Data, ValueLen); // some files (VREDIR.VXD 4.00.1111) has non zero value of ValueLen\r\n Dec(Len, HeaderSize + ValueLen);\r\n if SameText(Key, 'StringFileInfo') then\r\n ProcessStringInfo(Len)\r\n else\r\n if SameText(Key, 'VarFileInfo') then\r\n ProcessVarInfo\r\n else\r\n Break;\r\n end;\r\n ExtractFlags;\r\n CreateItemsForLanguage;\r\n end;\r\n if Error then\r\n raise EJclFileVersionInfoError.CreateRes(@RsFileUtilsNoVersionInfo);\r\nend;\r\n\r\nprocedure TJclFileVersionInfo.ExtractFlags;\r\nvar\r\n Masked: DWORD;\r\nbegin\r\n FFileFlags := [];\r\n Masked := FFixedInfo^.dwFileFlags and FFixedInfo^.dwFileFlagsMask;\r\n if (Masked and VS_FF_DEBUG) <> 0 then\r\n Include(FFileFlags, ffDebug);\r\n if (Masked and VS_FF_INFOINFERRED) <> 0 then\r\n Include(FFileFlags, ffInfoInferred);\r\n if (Masked and VS_FF_PATCHED) <> 0 then\r\n Include(FFileFlags, ffPatched);\r\n if (Masked and VS_FF_PRERELEASE) <> 0 then\r\n Include(FFileFlags, ffPreRelease);\r\n if (Masked and VS_FF_PRIVATEBUILD) <> 0 then\r\n Include(FFileFlags, ffPrivateBuild);\r\n if (Masked and VS_FF_SPECIALBUILD) <> 0 then\r\n Include(FFileFlags, ffSpecialBuild);\r\nend;\r\n\r\nfunction TJclFileVersionInfo.GetBinFileVersion: string;\r\nbegin\r\n Result := Format('%u.%u.%u.%u', [HiWord(FFixedInfo^.dwFileVersionMS),\r\n LoWord(FFixedInfo^.dwFileVersionMS), HiWord(FFixedInfo^.dwFileVersionLS),\r\n LoWord(FFixedInfo^.dwFileVersionLS)]);\r\nend;\r\n\r\nfunction TJclFileVersionInfo.GetBinProductVersion: string;\r\nbegin\r\n Result := Format('%u.%u.%u.%u', [HiWord(FFixedInfo^.dwProductVersionMS),\r\n LoWord(FFixedInfo^.dwProductVersionMS), HiWord(FFixedInfo^.dwProductVersionLS),\r\n LoWord(FFixedInfo^.dwProductVersionLS)]);\r\nend;\r\n\r\nfunction TJclFileVersionInfo.GetCustomFieldValue(const FieldName: string): string;\r\nvar\r\n ItemIndex: Integer;\r\nbegin\r\n if FieldName <> '' then\r\n begin\r\n ItemIndex := FItems.IndexOfName(FieldName);\r\n if ItemIndex <> -1 then\r\n //Return the required value, the value the user passed in was found.\r\n Result := FItems.Values[FieldName]\r\n else\r\n raise EJclFileVersionInfoError.CreateResFmt(@RsFileUtilsValueNotFound, [FieldName]);\r\n end\r\n else\r\n raise EJclFileVersionInfoError.CreateRes(@RsFileUtilsEmptyValue);\r\nend;\r\n\r\nfunction TJclFileVersionInfo.GetFileOS: DWORD;\r\nbegin\r\n Result := FFixedInfo^.dwFileOS;\r\nend;\r\n\r\nfunction TJclFileVersionInfo.GetFileSubType: DWORD;\r\nbegin\r\n Result := FFixedInfo^.dwFileSubtype;\r\nend;\r\n\r\nfunction TJclFileVersionInfo.GetFileType: DWORD;\r\nbegin\r\n Result := FFixedInfo^.dwFileType;\r\nend;\r\n\r\nfunction TJclFileVersionInfo.GetFileVersionBuild: string;\r\nvar\r\n Left: Integer;\r\nbegin\r\n Result := FileVersion;\r\n StrReplaceChar(Result, ',', '.');\r\n Left := CharLastPos(Result, '.') + 1;\r\n Result := StrMid(Result, Left, Length(Result) - Left + 1);\r\n Result := Trim(Result);\r\nend;\r\n\r\nfunction TJclFileVersionInfo.GetFileVersionMajor: string;\r\nbegin\r\n Result := FileVersion;\r\n StrReplaceChar(Result, ',', '.');\r\n Result := StrBefore('.', Result);\r\n Result := Trim(Result);\r\nend;\r\n\r\nfunction TJclFileVersionInfo.GetFileVersionMinor: string;\r\nvar\r\n Left, Right: integer;\r\nbegin\r\n Result := FileVersion;\r\n StrReplaceChar(Result, ',', '.');\r\n Left := CharPos(Result, '.') + 1; // skip major\r\n Right := CharPos(Result, '.', Left) {-1};\r\n Result := StrMid(Result, Left, Right - Left {+1});\r\n Result := Trim(Result);\r\nend;\r\n\r\nfunction TJclFileVersionInfo.GetFileVersionRelease: string;\r\nvar\r\n Left, Right: Integer;\r\nbegin\r\n Result := FileVersion;\r\n StrReplaceChar(Result, ',', '.');\r\n Left := CharPos(Result, '.') + 1; // skip major\r\n Left := CharPos(Result, '.', Left) + 1; // skip minor\r\n Right := CharPos(Result, '.', Left) {-1};\r\n Result := StrMid(Result, Left, Right - Left {+1});\r\n Result := Trim(Result);\r\nend;\r\n\r\nfunction TJclFileVersionInfo.GetFixedInfo: TVSFixedFileInfo;\r\nbegin\r\n Result := FFixedInfo^;\r\nend;\r\n\r\nfunction TJclFileVersionInfo.GetItems: TStrings;\r\nbegin\r\n Result := FItems;\r\nend;\r\n\r\nfunction TJclFileVersionInfo.GetLanguageCount: Integer;\r\nbegin\r\n Result := Length(FLanguages);\r\nend;\r\n\r\nfunction TJclFileVersionInfo.GetLanguageIds(Index: Integer): string;\r\nbegin\r\n CheckLanguageIndex(Index);\r\n Result := VersionLanguageId(FLanguages[Index]);\r\nend;\r\n\r\nfunction TJclFileVersionInfo.GetLanguages(Index: Integer): TLangIdRec;\r\nbegin\r\n CheckLanguageIndex(Index);\r\n Result := FLanguages[Index];\r\nend;\r\n\r\nfunction TJclFileVersionInfo.GetLanguageNames(Index: Integer): string;\r\nbegin\r\n CheckLanguageIndex(Index);\r\n Result := VersionLanguageName(FLanguages[Index].LangId);\r\nend;\r\n\r\nfunction TJclFileVersionInfo.GetTranslationCount: Integer;\r\nbegin\r\n Result := Length(FTranslations);\r\nend;\r\n\r\nfunction TJclFileVersionInfo.GetTranslations(Index: Integer): TLangIdRec;\r\nbegin\r\n Result := FTranslations[Index];\r\nend;\r\n\r\nfunction TJclFileVersionInfo.GetProductVersionBuild: string;\r\nvar\r\n Left: Integer;\r\nbegin\r\n Result := ProductVersion;\r\n StrReplaceChar(Result, ',', '.');\r\n Left := CharLastPos(Result, '.') + 1;\r\n Result := StrMid(Result, Left, Length(Result) - Left + 1);\r\n Result := Trim(Result);\r\nend;\r\n\r\nfunction TJclFileVersionInfo.GetProductVersionMajor: string;\r\nbegin\r\n Result := ProductVersion;\r\n StrReplaceChar(Result, ',', '.');\r\n Result := StrBefore('.', Result);\r\n Result := Trim(Result);\r\nend;\r\n\r\nfunction TJclFileVersionInfo.GetProductVersionMinor: string;\r\nvar\r\n Left, Right: integer;\r\nbegin\r\n Result := ProductVersion;\r\n StrReplaceChar(Result, ',', '.');\r\n Left := CharPos(Result, '.') + 1; // skip major\r\n Right := CharPos(Result, '.', Left) {-1};\r\n Result := StrMid(Result, Left, Right - Left {+1});\r\n Result := Trim(Result);\r\nend;\r\n\r\nfunction TJclFileVersionInfo.GetProductVersionRelease: string;\r\nvar\r\n Left, Right: Integer;\r\nbegin\r\n Result := ProductVersion;\r\n StrReplaceChar(Result, ',', '.');\r\n Left := CharPos(Result, '.') + 1; // skip major\r\n Left := CharPos(Result, '.', Left) + 1; // skip minor\r\n Right := CharPos(Result, '.', Left) {-1};\r\n Result := StrMid(Result, Left, Right - Left {+1});\r\n Result := Trim(Result);\r\nend;\r\n\r\nfunction TJclFileVersionInfo.GetVersionKeyValue(Index: Integer): string;\r\nbegin\r\n Result := Items.Values[VerKeyNames[Index]];\r\nend;\r\n\r\nprocedure TJclFileVersionInfo.SetLanguageIndex(const Value: Integer);\r\nbegin\r\n CheckLanguageIndex(Value);\r\n if FLanguageIndex <> Value then\r\n begin\r\n FLanguageIndex := Value;\r\n CreateItemsForLanguage;\r\n end;\r\nend;\r\n\r\nfunction TJclFileVersionInfo.TranslationMatchesLanguages(Exact: Boolean): Boolean;\r\nvar\r\n TransIndex, LangIndex: Integer;\r\n TranslationPair: DWORD;\r\nbegin\r\n Result := (LanguageCount = TranslationCount) or (not Exact and (TranslationCount > 0));\r\n if Result then\r\n for TransIndex := 0 to TranslationCount - 1 do\r\n begin\r\n TranslationPair := FTranslations[TransIndex].Pair;\r\n LangIndex := LanguageCount - 1;\r\n while (LangIndex >= 0) and (TranslationPair <> FLanguages[LangIndex].Pair) do\r\n Dec(LangIndex);\r\n if LangIndex < 0 then\r\n begin\r\n Result := False;\r\n Break;\r\n end;\r\n end;\r\nend;\r\n\r\nclass function TJclFileVersionInfo.VersionLanguageId(const LangIdRec: TLangIdRec): string;\r\nbegin\r\n with LangIdRec do\r\n Result := Format('%.4x%.4x', [LangId, CodePage]);\r\nend;\r\n\r\nclass function TJclFileVersionInfo.VersionLanguageName(const LangId: Word): string;\r\nvar\r\n R: DWORD;\r\nbegin\r\n SetLength(Result, MAX_PATH);\r\n R := VerLanguageName(LangId, PChar(Result), MAX_PATH);\r\n SetLength(Result, R);\r\nend;\r\n\r\n{$ENDIF MSWINDOWS}\r\n\r\n//=== { TJclFileMaskComparator } =============================================\r\n\r\nconstructor TJclFileMaskComparator.Create;\r\nbegin\r\n inherited Create;\r\n FSeparator := DirSeparator;\r\nend;\r\n\r\nfunction TJclFileMaskComparator.Compare(const NameExt: string): Boolean;\r\nvar\r\n I: Integer;\r\n NamePart, ExtPart: string;\r\n NameWild, ExtWild: Boolean;\r\nbegin\r\n Result := False;\r\n I := StrLastPos('.', NameExt);\r\n if I = 0 then\r\n begin\r\n NamePart := NameExt;\r\n ExtPart := '';\r\n end\r\n else\r\n begin\r\n NamePart := Copy(NameExt, 1, I - 1);\r\n ExtPart := Copy(NameExt, I + 1, Length(NameExt));\r\n end;\r\n for I := 0 to Length(FNames) - 1 do\r\n begin\r\n NameWild := FWildChars[I] and 1 = 1;\r\n ExtWild := FWildChars[I] and 2 = 2;\r\n if ((not NameWild and StrSame(FNames[I], NamePart)) or\r\n (NameWild and (StrMatches(FNames[I], NamePart, 1)))) and\r\n ((not ExtWild and StrSame(FExts[I], ExtPart)) or\r\n (ExtWild and (StrMatches(FExts[I], ExtPart, 1)))) then\r\n begin\r\n Result := True;\r\n Break;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJclFileMaskComparator.CreateMultiMasks;\r\nvar\r\n List: TStringList;\r\n I, N: Integer;\r\n NS, ES: string;\r\nbegin\r\n FExts := nil;\r\n FNames := nil;\r\n FWildChars := nil;\r\n List := TStringList.Create;\r\n try\r\n StrToStrings(FFileMask, FSeparator, List);\r\n SetLength(FExts, List.Count);\r\n SetLength(FNames, List.Count);\r\n SetLength(FWildChars, List.Count);\r\n for I := 0 to List.Count - 1 do\r\n begin\r\n N := StrLastPos('.', List[I]);\r\n if N = 0 then\r\n begin\r\n NS := List[I];\r\n ES := '';\r\n end\r\n else\r\n begin\r\n NS := Copy(List[I], 1, N - 1);\r\n ES := Copy(List[I], N + 1, 255);\r\n end;\r\n FNames[I] := NS;\r\n FExts[I] := ES;\r\n N := 0;\r\n if StrContainsChars(NS, CharIsWildcard, False) then\r\n N := N or 1;\r\n if StrContainsChars(ES, CharIsWildcard, False) then\r\n N := N or 2;\r\n FWildChars[I] := N;\r\n end;\r\n finally\r\n List.Free;\r\n end;\r\nend;\r\n\r\nfunction TJclFileMaskComparator.GetCount: Integer;\r\nbegin\r\n Result := Length(FWildChars);\r\nend;\r\n\r\nfunction TJclFileMaskComparator.GetExts(Index: Integer): string;\r\nbegin\r\n Result := FExts[Index];\r\nend;\r\n\r\nfunction TJclFileMaskComparator.GetMasks(Index: Integer): string;\r\nbegin\r\n Result := FNames[Index] + '.' + FExts[Index];\r\nend;\r\n\r\nfunction TJclFileMaskComparator.GetNames(Index: Integer): string;\r\nbegin\r\n Result := FNames[Index];\r\nend;\r\n\r\nprocedure TJclFileMaskComparator.SetFileMask(const Value: string);\r\nbegin\r\n FFileMask := Value;\r\n CreateMultiMasks;\r\nend;\r\n\r\nprocedure TJclFileMaskComparator.SetSeparator(const Value: Char);\r\nbegin\r\n if FSeparator <> Value then\r\n begin\r\n FSeparator := Value;\r\n CreateMultiMasks;\r\n end;\r\nend;\r\n\r\nfunction AdvBuildFileList(const Path: string; const Attr: Integer; const Files: TStrings;\r\n const AttributeMatch: TJclAttributeMatch; const Options: TFileListOptions;\r\n const SubfoldersMask: string; const FileMatchFunc: TFileMatchFunc): Boolean;\r\nvar\r\n FileMask: string;\r\n RootDir: string;\r\n Folders: TStringList;\r\n CurrentItem: Integer;\r\n Counter: Integer;\r\n FindAttr: Integer;\r\n\r\n procedure BuildFolderList;\r\n var\r\n FindInfo: TSearchRec;\r\n Rslt: Integer;\r\n begin\r\n Counter := Folders.Count - 1;\r\n CurrentItem := 0;\r\n\r\n while CurrentItem <= Counter do\r\n begin\r\n // searching for subfolders (including hidden ones)\r\n Rslt := FindFirst(Folders[CurrentItem] + '*.*', faAnyFile, FindInfo);\r\n try\r\n while Rslt = 0 do\r\n begin\r\n if (FindInfo.Name <> '.') and (FindInfo.Name <> '..') and\r\n (FindInfo.Attr and faDirectory = faDirectory) then\r\n Folders.Add(Folders[CurrentItem] + FindInfo.Name + DirDelimiter);\r\n\r\n Rslt := FindNext(FindInfo);\r\n end;\r\n finally\r\n FindClose(FindInfo);\r\n end;\r\n Counter := Folders.Count - 1;\r\n Inc(CurrentItem);\r\n end;\r\n end;\r\n\r\n procedure FillFileList(CurrentCounter: Integer);\r\n var\r\n FindInfo: TSearchRec;\r\n Rslt: Integer;\r\n CurrentFolder: string;\r\n Matches: Boolean;\r\n begin\r\n CurrentFolder := Folders[CurrentCounter];\r\n\r\n Rslt := FindFirst(CurrentFolder + FileMask, FindAttr, FindInfo);\r\n\r\n try\r\n while Rslt = 0 do\r\n begin\r\n Matches := False;\r\n\r\n case AttributeMatch of\r\n amAny:\r\n Matches := True;\r\n amExact:\r\n Matches := Attr = FindInfo.Attr;\r\n amSubSetOf:\r\n Matches := (Attr and FindInfo.Attr) = Attr;\r\n amSuperSetOf:\r\n Matches := (Attr and FindInfo.Attr) = FindInfo.Attr;\r\n amCustom:\r\n if Assigned(FileMatchFunc) then\r\n Matches := FileMatchFunc(Attr, FindInfo);\r\n end;\r\n\r\n if Matches then\r\n if flFullNames in Options then\r\n Files.Add(CurrentFolder + FindInfo.Name)\r\n else\r\n Files.Add(FindInfo.Name);\r\n\r\n Rslt := FindNext(FindInfo);\r\n end;\r\n finally\r\n FindClose(FindInfo);\r\n end;\r\n end;\r\n\r\nbegin\r\n Assert(Assigned(Files));\r\n FileMask := ExtractFileName(Path);\r\n RootDir := ExtractFilePath(Path);\r\n\r\n Folders := TStringList.Create;\r\n Files.BeginUpdate;\r\n try\r\n Folders.Add(RootDir);\r\n\r\n case AttributeMatch of\r\n amExact, amSuperSetOf:\r\n FindAttr := Attr;\r\n else\r\n FindAttr := faAnyFile;\r\n end;\r\n\r\n // here's the recursive search for nested folders\r\n\r\n if flRecursive in Options then\r\n BuildFolderList;\r\n\r\n for Counter := 0 to Folders.Count - 1 do\r\n begin\r\n if (((flMaskedSubfolders in Options) and (StrMatches(SubfoldersMask,\r\n Folders[Counter], 1))) or (not (flMaskedSubfolders in Options))) then\r\n FillFileList(Counter);\r\n end;\r\n finally\r\n Folders.Free;\r\n Files.EndUpdate;\r\n end;\r\n Result := True;\r\nend;\r\n\r\nfunction VerifyFileAttributeMask(var RejectedAttributes, RequiredAttributes: Integer): Boolean;\r\nbegin\r\n if RequiredAttributes and faNormalFile <> 0 then\r\n RejectedAttributes := not faNormalFile or RejectedAttributes;\r\n Result := RequiredAttributes and RejectedAttributes = 0;\r\nend;\r\n\r\nfunction AttributeMatch(FileAttributes, RejectedAttr, RequiredAttr: Integer): Boolean;\r\nbegin\r\n if FileAttributes = 0 then\r\n FileAttributes := faNormalFile;\r\n {$IFDEF MSWINDOWS}\r\n RequiredAttr := RequiredAttr and not faUnixSpecific;\r\n {$ENDIF MSWINDOWS}\r\n {$IFDEF UNIX}\r\n RequiredAttr := RequiredAttr and not faWindowsSpecific;\r\n {$ENDIF UNIX}\r\n Result := (FileAttributes and RejectedAttr = 0)\r\n and (FileAttributes and RequiredAttr = RequiredAttr);\r\nend;\r\n\r\nfunction IsFileAttributeMatch(FileAttributes, RejectedAttributes,\r\n RequiredAttributes: Integer): Boolean;\r\nbegin\r\n VerifyFileAttributeMask(RejectedAttributes, RequiredAttributes);\r\n Result := AttributeMatch(FileAttributes, RejectedAttributes, RequiredAttributes);\r\nend;\r\n\r\nfunction FileAttributesStr(const FileInfo: TSearchRec): string;\r\n{$IFDEF MSWINDOWS}\r\nconst\r\n SAllAttrSet = 'rahs'; // readonly, archive, hidden, system\r\n Attributes: array [1..4] of Integer =\r\n (faReadOnly, faArchive, faHidden, faSysFile);\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := SAllAttrSet;\r\n for I := Low(Attributes) to High(Attributes) do\r\n if (FileInfo.Attr and Attributes[I]) = 0 then\r\n Result[I] := '-';\r\nend;\r\n{$ENDIF MSWINDOWS}\r\n{$IFDEF UNIX}\r\nconst\r\n SAllAttrSet = 'drwxrwxrwx';\r\nvar\r\n I: Integer;\r\n Flag: Cardinal;\r\nbegin\r\n Result := SAllAttrSet;\r\n if FileInfo.Attr and faDirectory = 0 then\r\n Result[1] := '-'; // no directory\r\n Flag := 1 shl 8;\r\n for I := 2 to 10 do\r\n begin\r\n if FileInfo.Mode and Flag = 0 then\r\n Result[I] := '-';\r\n Flag := Flag shr 1;\r\n end;\r\nend;\r\n{$ENDIF UNIX}\r\n\r\nfunction IsFileNameMatch(FileName: string; const Mask: string;\r\n const CaseSensitive: Boolean): Boolean;\r\nbegin\r\n Result := True;\r\n {$IFDEF MSWINDOWS}\r\n if (Mask = '') or (Mask = '*') or (Mask = '*.*') then\r\n Exit;\r\n if Pos('.', FileName) = 0 then\r\n FileName := FileName + '.'; // file names w/o extension match '*.'\r\n {$ENDIF MSWINDOWS}\r\n {$IFDEF UNIX}\r\n if (Mask = '') or (Mask = '*') then\r\n Exit;\r\n {$ENDIF UNIX}\r\n if CaseSensitive then\r\n Result := StrMatches(Mask, FileName)\r\n else\r\n Result := StrMatches(AnsiUpperCase(Mask), AnsiUpperCase(FileName));\r\nend;\r\n\r\n// author: Robert Rossmair\r\n\r\nfunction CanonicalizedSearchPath(const Directory: string): string;\r\nbegin\r\n Result := PathCanonicalize(Directory);\r\n {$IFDEF MSWINDOWS}\r\n // avoid changing \"X:\" (current directory on drive X:) into \"X:\\\" (root dir.)\r\n if Result[Length(Result)] <> ':' then\r\n {$ENDIF MSWINDOWS}\r\n Result := PathAddSeparator(Result);\r\n // strip leading \"./\" resp. \".\\\"\r\n if Pos('.' + DirDelimiter, Result) = 1 then\r\n Result := Copy(Result, 3, Length(Result) - 2);\r\nend;\r\n\r\nprocedure EnumFiles(const Path: string; HandleFile: TFileHandlerEx;\r\n RejectedAttributes: Integer; RequiredAttributes: Integer; Abort: PBoolean);\r\nvar\r\n Directory: string;\r\n FileInfo: TSearchRec;\r\n Attr: Integer;\r\n Found: Boolean;\r\nbegin\r\n Assert(Assigned(HandleFile));\r\n Assert(VerifyFileAttributeMask(RejectedAttributes, RequiredAttributes),\r\n LoadResString(@RsFileSearchAttrInconsistency));\r\n\r\n Directory := ExtractFilePath(Path);\r\n\r\n Attr := faAnyFile and not RejectedAttributes;\r\n\r\n Found := {$IFDEF HAS_UNITSCOPE}System.{$ENDIF}SysUtils.FindFirst(Path, Attr, FileInfo) = 0;\r\n try\r\n while Found do\r\n begin\r\n if (Abort <> nil) and LongBool(Abort^) then\r\n Exit;\r\n if AttributeMatch(FileInfo.Attr, RejectedAttributes, RequiredAttributes) then\r\n if ((FileInfo.Attr and faDirectory = 0)\r\n or ((FileInfo.Name <> '.') and (FileInfo.Name <> '..'))) then\r\n HandleFile(Directory, FileInfo);\r\n Found := FindNext(FileInfo) = 0;\r\n end;\r\n finally\r\n FindClose(FileInfo);\r\n end;\r\nend;\r\n\r\nprocedure EnumFiles(const Path: string; HandleFile: TFileInfoHandlerEx;\r\n RejectedAttributes: Integer; RequiredAttributes: Integer; Abort: PBoolean);\r\nvar\r\n FileInfo: TSearchRec;\r\n Attr: Integer;\r\n Found: Boolean;\r\nbegin\r\n Assert(Assigned(HandleFile));\r\n Assert(VerifyFileAttributeMask(RejectedAttributes, RequiredAttributes),\r\n LoadResString(@RsFileSearchAttrInconsistency));\r\n\r\n Attr := faAnyFile and not RejectedAttributes;\r\n\r\n Found := {$IFDEF HAS_UNITSCOPE}System.{$ENDIF}SysUtils.FindFirst(Path, Attr, FileInfo) = 0;\r\n try\r\n while Found do\r\n begin\r\n if (Abort <> nil) and LongBool(Abort^) then\r\n Exit;\r\n if AttributeMatch(FileInfo.Attr, RejectedAttributes, RequiredAttributes) then\r\n if ((FileInfo.Attr and faDirectory = 0)\r\n or ((FileInfo.Name <> '.') and (FileInfo.Name <> '..'))) then\r\n HandleFile(FileInfo);\r\n Found := FindNext(FileInfo) = 0;\r\n end;\r\n finally\r\n FindClose(FileInfo);\r\n end;\r\nend;\r\n\r\nprocedure EnumDirectories(const Root: string; const HandleDirectory: TFileHandler;\r\n const IncludeHiddenDirectories: Boolean; const SubDirectoriesMask: string;\r\n Abort: PBoolean {$IFDEF UNIX}; ResolveSymLinks: Boolean {$ENDIF});\r\nvar\r\n RootDir: string;\r\n Attr: Integer;\r\n\r\n procedure Process(const Directory: string);\r\n var\r\n DirInfo: TSearchRec;\r\n SubDir: string;\r\n Found: Boolean;\r\n begin\r\n HandleDirectory(Directory);\r\n\r\n Found := {$IFDEF HAS_UNITSCOPE}System.{$ENDIF}SysUtils.FindFirst(Directory + '*', Attr, DirInfo) = 0;\r\n try\r\n while Found do\r\n begin\r\n if (Abort <> nil) and LongBool(Abort^) then\r\n Exit;\r\n if (DirInfo.Name <> '.') and (DirInfo.Name <> '..') and\r\n {$IFDEF UNIX}\r\n (IncludeHiddenDirectories or (Pos('.', DirInfo.Name) <> 1)) and\r\n ((DirInfo.Attr and faSymLink = 0) or ResolveSymLinks) and\r\n {$ENDIF UNIX}\r\n (DirInfo.Attr and faDirectory <> 0) then\r\n begin\r\n SubDir := Directory + DirInfo.Name + DirDelimiter;\r\n if (SubDirectoriesMask = '') or StrMatches(SubDirectoriesMask, SubDir, Length(RootDir)) then\r\n Process(SubDir);\r\n end;\r\n Found := FindNext(DirInfo) = 0;\r\n end;\r\n finally\r\n FindClose(DirInfo);\r\n end;\r\n end;\r\n\r\nbegin\r\n Assert(Assigned(HandleDirectory));\r\n RootDir := CanonicalizedSearchPath(Root);\r\n\r\n if IncludeHiddenDirectories then\r\n Attr := faDirectory + faHidden // no effect on Linux\r\n else\r\n Attr := faDirectory;\r\n\r\n Process(RootDir);\r\nend;\r\n\r\n//=== { TJclCustomFileAttributeMask } ==============================================\r\n\r\nconstructor TJclCustomFileAttrMask.Create;\r\nbegin\r\n inherited Create;\r\n FRejectedAttr := faRejectedByDefault;\r\nend;\r\n\r\nprocedure TJclCustomFileAttrMask.Assign(Source: TPersistent);\r\nbegin\r\n if Source is TJclCustomFileAttrMask then\r\n begin\r\n Required := TJclCustomFileAttrMask(Source).Required;\r\n Rejected := TJclCustomFileAttrMask(Source).Rejected;\r\n end\r\n else\r\n inherited Assign(Source);\r\nend;\r\n\r\nprocedure TJclCustomFileAttrMask.Clear;\r\nbegin\r\n Rejected := 0;\r\n Required := 0;\r\nend;\r\n\r\nprocedure TJclCustomFileAttrMask.DefineProperties(Filer: TFiler);\r\nvar\r\n Ancestor: TJclCustomFileAttrMask;\r\n Attr: Integer;\r\nbegin\r\n Attr := 0;\r\n Ancestor := TJclCustomFileAttrMask(Filer.Ancestor);\r\n if Assigned(Ancestor) then\r\n Attr := Ancestor.FRequiredAttr;\r\n Filer.DefineProperty('Required', ReadRequiredAttributes, WriteRequiredAttributes,\r\n Attr <> FRequiredAttr);\r\n if Assigned(Ancestor) then\r\n Attr := Ancestor.FRejectedAttr;\r\n Filer.DefineProperty('Rejected', ReadRejectedAttributes, WriteRejectedAttributes,\r\n Attr <> FRejectedAttr);\r\nend;\r\n\r\nfunction TJclCustomFileAttrMask.Match(FileAttributes: Integer): Boolean;\r\nbegin\r\n Result := AttributeMatch(FileAttributes, Rejected, Required);\r\nend;\r\n\r\nfunction TJclCustomFileAttrMask.Match(const FileInfo: TSearchRec): Boolean;\r\nbegin\r\n Result := Match(FileInfo.Attr);\r\nend;\r\n\r\nfunction TJclCustomFileAttrMask.GetAttr(Index: Integer): TAttributeInterest;\r\nbegin\r\n if ((FRequiredAttr and Index) <> 0) or (Index = faNormalFile) and\r\n (FRejectedAttr = not faNormalFile) then\r\n Result := aiRequired\r\n else\r\n if (FRejectedAttr and Index) <> 0 then\r\n Result := aiRejected\r\n else\r\n Result := aiIgnored;\r\nend;\r\n\r\nprocedure TJclCustomFileAttrMask.ReadRejectedAttributes(Reader: TReader);\r\nbegin\r\n FRejectedAttr := Reader.ReadInteger;\r\nend;\r\n\r\nprocedure TJclCustomFileAttrMask.ReadRequiredAttributes(Reader: TReader);\r\nbegin\r\n FRequiredAttr := Reader.ReadInteger;\r\nend;\r\n\r\nprocedure TJclCustomFileAttrMask.SetAttr(Index: Integer; const Value: TAttributeInterest);\r\nbegin\r\n case Value of\r\n aiIgnored:\r\n begin\r\n FRequiredAttr := FRequiredAttr and not Index;\r\n FRejectedAttr := FRejectedAttr and not Index;\r\n end;\r\n aiRejected:\r\n begin\r\n FRequiredAttr := FRequiredAttr and not Index;\r\n FRejectedAttr := FRejectedAttr or Index;\r\n end;\r\n aiRequired:\r\n begin\r\n if Index = faNormalFile then\r\n begin\r\n FRequiredAttr := faNormalFile;\r\n FRejectedAttr := not faNormalFile;\r\n end\r\n else\r\n begin\r\n FRequiredAttr := FRequiredAttr or Index;\r\n FRejectedAttr := FRejectedAttr and not Index;\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJclCustomFileAttrMask.WriteRejectedAttributes(Writer: TWriter);\r\nbegin\r\n Writer.WriteInteger(FRejectedAttr);\r\nend;\r\n\r\nprocedure TJclCustomFileAttrMask.WriteRequiredAttributes(Writer: TWriter);\r\nbegin\r\n Writer.WriteInteger(FRequiredAttr);\r\nend;\r\n\r\n//=== { TJclFileAttributeMask } ==============================================\r\n\r\nprocedure TJclFileAttributeMask.ReadVolumeID(Reader: TReader);\r\nbegin\r\n // Nothing, we are not interested in the value of the VolumeID property,\r\n // this procedure and the associated DefineProperty call are here only\r\n // to allow reading legacy DFMs that have this property defined.\r\nend;\r\n\r\nprocedure TJclFileAttributeMask.DefineProperties(Filer: TFiler);\r\nbegin\r\n inherited DefineProperties(Filer);\r\n\r\n Filer.DefineProperty('VolumeID', ReadVolumeID, nil, False);\r\nend;\r\n\r\n//=== { TJclFileSearchOptions } ==============================================\r\n\r\nconstructor TJclFileSearchOptions.Create;\r\nbegin\r\n inherited Create;\r\n\r\n FAttributeMask := TJclFileAttributeMask.Create;\r\n FRootDirectories := TStringList.Create;\r\n FRootDirectories.Add('.');\r\n FFileMasks := TStringList.Create;\r\n FFileMasks.Add('*');\r\n FSubDirectoryMask := '*';\r\n FOptions := [fsIncludeSubDirectories];\r\n FLastChangeAfter := MinDateTime;\r\n FLastChangeBefore := MaxDateTime;\r\n {$IFDEF UNIX}\r\n FCaseSensitiveSearch := True;\r\n {$ENDIF UNIX}\r\nend;\r\n\r\ndestructor TJclFileSearchOptions.Destroy;\r\nbegin\r\n FAttributeMask.Free;\r\n FFileMasks.Free;\r\n FRootDirectories.Free;\r\n\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJclFileSearchOptions.Assign(Source: TPersistent);\r\nvar\r\n Src: TJclFileSearchOptions;\r\nbegin\r\n if Source is TJclFileSearchOptions then\r\n begin\r\n Src := TJclFileSearchOptions(Source);\r\n FCaseSensitiveSearch := Src.FCaseSensitiveSearch;\r\n FileMasks.Assign(Src.FileMasks);\r\n RootDirectory := Src.RootDirectory;\r\n SubDirectoryMask := Src.SubDirectoryMask;\r\n AttributeMask := Src.AttributeMask;\r\n Options := Src.Options;\r\n FileSizeMin := Src.FileSizeMin;\r\n FileSizeMax := Src.FileSizeMax;\r\n LastChangeAfter := Src.LastChangeAfter;\r\n LastChangeBefore := Src.LastChangeBefore;\r\n end\r\n else\r\n inherited Assign(Source);\r\nend;\r\n\r\nfunction TJclFileSearchOptions.GetAttributeMask: TJclFileAttributeMask;\r\nbegin\r\n Result := FAttributeMask;\r\nend;\r\n\r\nfunction TJclFileSearchOptions.GetCaseSensitiveSearch: Boolean;\r\nbegin\r\n Result := FCaseSensitiveSearch;\r\nend;\r\n\r\nfunction TJclFileSearchOptions.GetFileMask: string;\r\nbegin\r\n Result := StringsToStr(FileMasks, DirSeparator, False);\r\nend;\r\n\r\nfunction TJclFileSearchOptions.GetFileMasks: TStrings;\r\nbegin\r\n Result := FFileMasks;\r\nend;\r\n\r\nfunction TJclFileSearchOptions.GetFileSizeMax: Int64;\r\nbegin\r\n Result := FFileSizeMax;\r\nend;\r\n\r\nfunction TJclFileSearchOptions.GetFileSizeMin: Int64;\r\nbegin\r\n Result := FFileSizeMin;\r\nend;\r\n\r\nfunction TJclFileSearchOptions.GetIncludeHiddenSubDirectories: Boolean;\r\nbegin\r\n Result := fsIncludeHiddenSubDirectories in Options;\r\nend;\r\n\r\nfunction TJclFileSearchOptions.GetIncludeSubDirectories: Boolean;\r\nbegin\r\n Result := fsIncludeSubDirectories in Options;\r\nend;\r\n\r\nfunction TJclFileSearchOptions.GetLastChangeAfter: TDateTime;\r\nbegin\r\n Result := FLastChangeAfter;\r\nend;\r\n\r\nfunction TJclFileSearchOptions.GetLastChangeAfterStr: string;\r\nbegin\r\n Result := DateTimeToStr(LastChangeAfter);\r\nend;\r\n\r\nfunction TJclFileSearchOptions.GetLastChangeBefore: TDateTime;\r\nbegin\r\n Result := FLastChangeBefore;\r\nend;\r\n\r\nfunction TJclFileSearchOptions.GetLastChangeBeforeStr: string;\r\nbegin\r\n Result := DateTimeToStr(LastChangeBefore);\r\nend;\r\n\r\nfunction TJclFileSearchOptions.GetOption(\r\n const Option: TFileSearchOption): Boolean;\r\nbegin\r\n Result := Option in FOptions;\r\nend;\r\n\r\nfunction TJclFileSearchOptions.GetOptions: TFileSearchoptions;\r\nbegin\r\n Result := FOptions;\r\nend;\r\n\r\nfunction TJclFileSearchOptions.GetRootDirectories: TStrings;\r\nbegin\r\n Result := FRootDirectories;\r\nend;\r\n\r\nfunction TJclFileSearchOptions.GetRootDirectory: string;\r\nbegin\r\n if FRootDirectories.Count = 1 then\r\n Result := FRootDirectories.Strings[0]\r\n else\r\n Result := '';\r\nend;\r\n\r\nfunction TJclFileSearchOptions.GetSubDirectoryMask: string;\r\nbegin\r\n Result := FSubDirectoryMask;\r\nend;\r\n\r\nfunction TJclFileSearchOptions.IsLastChangeAfterStored: Boolean;\r\nbegin\r\n Result := FLastChangeAfter <> MinDateTime;\r\nend;\r\n\r\nfunction TJclFileSearchOptions.IsLastChangeBeforeStored: Boolean;\r\nbegin\r\n Result := FLastChangeBefore <> MaxDateTime;\r\nend;\r\n\r\nprocedure TJclFileSearchOptions.SetAttributeMask(\r\n const Value: TJclFileAttributeMask);\r\nbegin\r\n FAttributeMask.Assign(Value);\r\nend;\r\n\r\nprocedure TJclFileSearchOptions.SetCaseSensitiveSearch(const Value: Boolean);\r\nbegin\r\n FCaseSensitiveSearch := Value;\r\nend;\r\n\r\nprocedure TJclFileSearchOptions.SetFileMask(const Value: string);\r\nbegin\r\n { TODO : UNIX : ? }\r\n StrToStrings(Value, DirSeparator, FFileMasks, False);\r\nend;\r\n\r\nprocedure TJclFileSearchOptions.SetFileMasks(const Value: TStrings);\r\nbegin\r\n FileMasks.Assign(Value);\r\nend;\r\n\r\nprocedure TJclFileSearchOptions.SetFileSizeMax(const Value: Int64);\r\nbegin\r\n FFileSizeMax := Value;\r\nend;\r\n\r\nprocedure TJclFileSearchOptions.SetFileSizeMin(const Value: Int64);\r\nbegin\r\n FFileSizeMin := Value;\r\nend;\r\n\r\nprocedure TJclFileSearchOptions.SetIncludeHiddenSubDirectories(\r\n const Value: Boolean);\r\nbegin\r\n SetOption(fsIncludeHiddenSubDirectories, Value);\r\nend;\r\n\r\nprocedure TJclFileSearchOptions.SetIncludeSubDirectories(const Value: Boolean);\r\nbegin\r\n SetOption(fsIncludeSubDirectories, Value);\r\nend;\r\n\r\nprocedure TJclFileSearchOptions.SetLastChangeAfter(const Value: TDateTime);\r\nbegin\r\n FLastChangeAfter := Value;\r\nend;\r\n\r\nprocedure TJclFileSearchOptions.SetLastChangeAfterStr(const Value: string);\r\nbegin\r\n if Value = '' then\r\n LastChangeAfter := MinDateTime\r\n else\r\n LastChangeAfter := StrToDateTime(Value);\r\nend;\r\n\r\nprocedure TJclFileSearchOptions.SetLastChangeBefore(const Value: TDateTime);\r\nbegin\r\n FLastChangeBefore := Value;\r\nend;\r\n\r\nprocedure TJclFileSearchOptions.SetLastChangeBeforeStr(const Value: string);\r\nbegin\r\n if Value = '' then\r\n LastChangeBefore := MaxDateTime\r\n else\r\n LastChangeBefore := StrToDateTime(Value);\r\nend;\r\n\r\nprocedure TJclFileSearchOptions.SetOption(const Option: TFileSearchOption;\r\n const Value: Boolean);\r\nbegin\r\n if Value then\r\n Include(FOptions, Option)\r\n else\r\n Exclude(FOptions, Option);\r\nend;\r\n\r\nprocedure TJclFileSearchOptions.SetOptions(const Value: TFileSearchOptions);\r\nbegin\r\n FOptions := Value;\r\nend;\r\n\r\nprocedure TJclFileSearchOptions.SetRootDirectories(const Value: TStrings);\r\nbegin\r\n FRootDirectories.Assign(Value);\r\nend;\r\n\r\nprocedure TJclFileSearchOptions.SetRootDirectory(const Value: string);\r\nbegin\r\n FRootDirectories.Clear;\r\n FRootDirectories.Add(Value);\r\nend;\r\n\r\nprocedure TJclFileSearchOptions.SetSubDirectoryMask(const Value: string);\r\nbegin\r\n FSubDirectoryMask := Value;\r\nend;\r\n\r\n//=== { TEnumFileThread } ====================================================\r\n\r\ntype\r\n TEnumFileThread = class(TThread)\r\n private\r\n FID: TFileSearchTaskID;\r\n FFileMasks: TStringList;\r\n FDirectories: TStrings;\r\n FCurrentDirectory: string;\r\n FSubDirectoryMask: string;\r\n FOnEnterDirectory: TFileHandler;\r\n FFileHandlerEx: TFileHandlerEx;\r\n FFileHandler: TFileHandler;\r\n FInternalDirHandler: TFileHandler;\r\n FInternalFileInfoHandler: TFileInfoHandlerEx;\r\n FFileInfo: TSearchRec;\r\n FRejectedAttr: Integer;\r\n FRequiredAttr: Integer;\r\n FFileSizeMin: Int64;\r\n FFileSizeMax: Int64;\r\n {$IFDEF RTL220_UP}\r\n FFileTimeMin: TDateTime;\r\n FFileTimeMax: TDateTime;\r\n {$ELSE ~RTL220_UP}\r\n FFileTimeMin: Integer;\r\n FFileTimeMax: Integer;\r\n {$ENDIF ~RTL220_UP}\r\n FSynchronizationMode: TFileEnumeratorSyncMode;\r\n FIncludeSubDirectories: Boolean;\r\n FIncludeHiddenSubDirectories: Boolean;\r\n FNotifyOnTermination: Boolean;\r\n FCaseSensitiveSearch: Boolean;\r\n FAllNamesMatch: Boolean;\r\n procedure EnterDirectory;\r\n procedure AsyncProcessDirectory(const Directory: string);\r\n procedure SyncProcessDirectory(const Directory: string);\r\n procedure AsyncProcessFile(const FileInfo: TSearchRec);\r\n procedure SyncProcessFile(const FileInfo: TSearchRec);\r\n function GetDirectories: TStrings;\r\n function GetFileMasks: TStrings;\r\n procedure SetDirectories(const Value: TStrings);\r\n procedure SetFileMasks(const Value: TStrings);\r\n protected\r\n procedure DoTerminate; override;\r\n procedure Execute; override;\r\n function FileMatch: Boolean;\r\n function FileNameMatchesMask: Boolean;\r\n procedure ProcessDirectory;\r\n procedure ProcessDirFiles;\r\n procedure ProcessFile;\r\n property AllNamesMatch: Boolean read FAllNamesMatch;\r\n property CaseSensitiveSearch: Boolean read FCaseSensitiveSearch write FCaseSensitiveSearch;\r\n property FileMasks: TStrings read GetFileMasks write SetFileMasks;\r\n property FileSizeMin: Int64 read FFileSizeMin write FFileSizeMin;\r\n property FileSizeMax: Int64 read FFileSizeMax write FFileSizeMax;\r\n {$IFDEF RTL220_UP}\r\n property FileTimeMin: TDateTime read FFileTimeMin write FFileTimeMin;\r\n property FileTimeMax: TDateTime read FFileTimeMax write FFileTimeMax;\r\n {$ELSE ~RTL220_UP}\r\n property FileTimeMin: Integer read FFileTimeMin write FFileTimeMin;\r\n property FileTimeMax: Integer read FFileTimeMax write FFileTimeMax;\r\n {$ENDIF ~RTL220_UP}\r\n property Directories: TStrings read GetDirectories write SetDirectories;\r\n property IncludeSubDirectories: Boolean\r\n read FIncludeSubDirectories write FIncludeSubDirectories;\r\n property IncludeHiddenSubDirectories: Boolean\r\n read FIncludeHiddenSubDirectories write FIncludeHiddenSubDirectories;\r\n property RejectedAttr: Integer read FRejectedAttr write FRejectedAttr;\r\n property RequiredAttr: Integer read FRequiredAttr write FRequiredAttr;\r\n property SynchronizationMode: TFileEnumeratorSyncMode\r\n read FSynchronizationMode write FSynchronizationMode;\r\n public\r\n constructor Create;\r\n destructor Destroy; override;\r\n property ID: TFileSearchTaskID read FID;\r\n {$IFDEF FPC} // protected property\r\n property Terminated;\r\n {$ENDIF FPC}\r\n end;\r\n\r\nconstructor TEnumFileThread.Create;\r\nbegin\r\n inherited Create(True);\r\n FDirectories := TStringList.Create;\r\n FFileMasks := TStringList.Create;\r\n {$IFDEF RTL220_UP}\r\n FFileTimeMin := -MaxDouble;\r\n FFileTimeMax := MaxDouble;\r\n {$ELSE ~RTL220_UP}\r\n FFileTimeMin := Low(FFileInfo.Time);\r\n FFileTimeMax := High(FFileInfo.Time);\r\n {$ENDIF ~RTL220_UP}\r\n FFileSizeMax := High(FFileSizeMax);\r\n {$IFDEF MSWINDOWS}\r\n Priority := tpIdle;\r\n {$ENDIF MSWINDOWS}\r\n {$IFDEF UNIX}\r\n {$IFDEF FPC}\r\n Priority := tpIdle;\r\n {$ELSE ~FPC}\r\n Priority := 0;\r\n {$ENDIF ~FPC}\r\n {$ENDIF UNIX}\r\n FreeOnTerminate := True;\r\n FNotifyOnTermination := True;\r\nend;\r\n\r\ndestructor TEnumFileThread.Destroy;\r\nbegin\r\n FFileMasks.Free;\r\n FDirectories.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TEnumFileThread.Execute;\r\nvar\r\n Index: Integer;\r\nbegin\r\n if SynchronizationMode = smPerDirectory then\r\n begin\r\n FInternalDirHandler := SyncProcessDirectory;\r\n FInternalFileInfoHandler := AsyncProcessFile;\r\n end\r\n else // SynchronizationMode = smPerFile\r\n begin\r\n FInternalDirHandler := AsyncProcessDirectory;\r\n FInternalFileInfoHandler := SyncProcessFile;\r\n end;\r\n\r\n if FIncludeSubDirectories then\r\n begin\r\n for Index := 0 to FDirectories.Count - 1 do\r\n EnumDirectories(FDirectories.Strings[Index], FInternalDirHandler, FIncludeHiddenSubDirectories,\r\n FSubDirectoryMask, @Terminated)\r\n end\r\n else\r\n begin\r\n for Index := 0 to FDirectories.Count - 1 do\r\n FInternalDirHandler(CanonicalizedSearchPath(FDirectories.Strings[Index]));\r\n end;\r\nend;\r\n\r\nprocedure TEnumFileThread.DoTerminate;\r\nbegin\r\n if FNotifyOnTermination then\r\n inherited DoTerminate;\r\nend;\r\n\r\nprocedure TEnumFileThread.EnterDirectory;\r\nbegin\r\n FOnEnterDirectory(FCurrentDirectory);\r\nend;\r\n\r\nprocedure TEnumFileThread.ProcessDirectory;\r\nbegin\r\n if Assigned(FOnEnterDirectory) then\r\n EnterDirectory;\r\n ProcessDirFiles;\r\nend;\r\n\r\nprocedure TEnumFileThread.AsyncProcessDirectory(const Directory: string);\r\nbegin\r\n FCurrentDirectory := Directory;\r\n if Assigned(FOnEnterDirectory) then\r\n Synchronize(EnterDirectory);\r\n ProcessDirFiles;\r\nend;\r\n\r\nprocedure TEnumFileThread.SyncProcessDirectory(const Directory: string);\r\nbegin\r\n FCurrentDirectory := Directory;\r\n Synchronize(ProcessDirectory);\r\nend;\r\n\r\nprocedure TEnumFileThread.ProcessDirFiles;\r\nbegin\r\n EnumFiles(FCurrentDirectory + '*', FInternalFileInfoHandler, FRejectedAttr, FRequiredAttr, @Terminated);\r\nend;\r\n\r\nfunction TEnumFileThread.FileMatch: Boolean;\r\nvar\r\n FileSize: Int64;\r\nbegin\r\n {$IFDEF RTL220_UP}\r\n Result := FileNameMatchesMask and (FFileInfo.TimeStamp >= FFileTimeMin) and (FFileInfo.TimeStamp <= FFileTimeMax);\r\n {$ELSE ~RTL220_UP}\r\n Result := FileNameMatchesMask and (FFileInfo.Time >= FFileTimeMin) and (FFileInfo.Time <= FFileTimeMax);\r\n {$ENDIF ~RTL220_UP}\r\n if Result then\r\n begin\r\n FileSize := GetSizeOfFile(FFileInfo);\r\n Result := (FileSize >= FFileSizeMin) and (FileSize <= FFileSizeMax);\r\n end;\r\nend;\r\n\r\nfunction TEnumFileThread.FileNameMatchesMask: Boolean;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := AllNamesMatch;\r\n if not Result then\r\n for I := 0 to FileMasks.Count - 1 do\r\n if IsFileNameMatch(FFileInfo.Name, FileMasks[I], CaseSensitiveSearch) then\r\n begin\r\n Result := True;\r\n Break;\r\n end;\r\nend;\r\n\r\nprocedure TEnumFileThread.ProcessFile;\r\nbegin\r\n if Assigned(FFileHandlerEx) then\r\n FFileHandlerEx(FCurrentDirectory, FFileInfo)\r\n else\r\n FFileHandler(FCurrentDirectory + FFileInfo.Name);\r\nend;\r\n\r\nprocedure TEnumFileThread.AsyncProcessFile(const FileInfo: TSearchRec);\r\nbegin\r\n FFileInfo := FileInfo;\r\n if FileMatch then\r\n ProcessFile;\r\nend;\r\n\r\nprocedure TEnumFileThread.SyncProcessFile(const FileInfo: TSearchRec);\r\nbegin\r\n FFileInfo := FileInfo;\r\n if FileMatch then\r\n Synchronize(ProcessFile);\r\nend;\r\n\r\nfunction TEnumFileThread.GetDirectories: TStrings;\r\nbegin\r\n Result := FDirectories;\r\nend;\r\n\r\nfunction TEnumFileThread.GetFileMasks: TStrings;\r\nbegin\r\n Result := FFileMasks;\r\nend;\r\n\r\nprocedure TEnumFileThread.SetDirectories(const Value: TStrings);\r\nbegin\r\n FDirectories.Assign(Value);\r\nend;\r\n\r\nprocedure TEnumFileThread.SetFileMasks(const Value: TStrings);\r\nvar\r\n I: Integer;\r\nbegin\r\n FAllNamesMatch := Value.Count = 0;\r\n for I := 0 to Value.Count - 1 do\r\n if (Value[I] = '*') {$IFDEF MSWINDOWS} or (Value[I] = '*.*') {$ENDIF} then\r\n begin\r\n FAllNamesMatch := True;\r\n Break;\r\n end;\r\n if FAllNamesMatch then\r\n FileMasks.Clear\r\n else\r\n FileMasks.Assign(Value);\r\nend;\r\n\r\n//=== { TJclFileEnumerator } =================================================\r\n\r\nconstructor TJclFileEnumerator.Create;\r\nbegin\r\n inherited Create;\r\n FTasks := TList.Create;\r\nend;\r\n\r\ndestructor TJclFileEnumerator.Destroy;\r\nbegin\r\n StopAllTasks(True);\r\n FTasks.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJclFileEnumerator.Assign(Source: TPersistent);\r\nvar\r\n Src: TJclFileEnumerator;\r\nbegin\r\n if Source is TJclFileEnumerator then\r\n begin\r\n Src := TJclFileEnumerator(Source);\r\n SynchronizationMode := Src.SynchronizationMode;\r\n OnEnterDirectory := Src.OnEnterDirectory;\r\n OnTerminateTask := Src.OnTerminateTask;\r\n end;\r\n inherited Assign(Source);\r\nend;\r\n\r\nfunction TJclFileEnumerator.CreateTask: TThread;\r\nvar\r\n Task: TEnumFileThread;\r\nbegin\r\n Task := TEnumFileThread.Create;\r\n Task.FID := NextTaskID;\r\n Task.CaseSensitiveSearch := FCaseSensitiveSearch;\r\n Task.FileMasks := FileMasks;\r\n Task.Directories := RootDirectories;\r\n Task.RejectedAttr := AttributeMask.Rejected;\r\n Task.RequiredAttr := AttributeMask.Required;\r\n Task.IncludeSubDirectories := IncludeSubDirectories;\r\n Task.IncludeHiddenSubDirectories := IncludeHiddenSubDirectories;\r\n if fsMinSize in Options then\r\n Task.FileSizeMin := FileSizeMin;\r\n if fsMaxSize in Options then\r\n Task.FileSizeMax := FileSizeMax;\r\n if fsLastChangeAfter in Options then\r\n Task.FFileTimeMin := {$IFDEF RTL220_UP}LastChangeAfter{$ELSE}DateTimeToFileDate(LastChangeAfter){$ENDIF};\r\n if fsLastChangeBefore in Options then\r\n Task.FFileTimeMax := {$IFDEF RTL220_UP}LastChangeBefore{$ELSE}DateTimeToFileDate(LastChangeBefore){$ENDIF};\r\n Task.SynchronizationMode := SynchronizationMode;\r\n Task.FOnEnterDirectory := OnEnterDirectory;\r\n Task.OnTerminate := TaskTerminated;\r\n FTasks.Add(Task);\r\n if FRefCount > 0 then\r\n _AddRef;\r\n Result := Task;\r\nend;\r\n\r\nfunction TJclFileEnumerator.FillList(List: TStrings): TFileSearchTaskID;\r\nbegin\r\n List.BeginUpdate;\r\n try\r\n Result := ForEach(List.Append);\r\n finally\r\n List.EndUpdate;\r\n end;\r\nend;\r\n\r\nfunction TJclFileEnumerator.ForEach(Handler: TFileHandlerEx): TFileSearchTaskID;\r\nvar\r\n Task: TEnumFileThread;\r\nbegin\r\n Task := TEnumFileThread(CreateTask);\r\n Task.FFileHandlerEx := Handler;\r\n Result := Task.ID;\r\n {$IFDEF RTL210_UP}\r\n Task.Suspended := False;\r\n {$ELSE ~RTL210_UP}\r\n Task.Resume;\r\n {$ENDIF ~RTL210_UP}\r\nend;\r\n\r\nfunction TJclFileEnumerator.ForEach(Handler: TFileHandler): TFileSearchTaskID;\r\nvar\r\n Task: TEnumFileThread;\r\nbegin\r\n Task := TEnumFileThread(CreateTask);\r\n Task.FFileHandler := Handler;\r\n Result := Task.ID;\r\n {$IFDEF RTL210_UP}\r\n Task.Suspended := False;\r\n {$ELSE ~RTL210_UP}\r\n Task.Resume;\r\n {$ENDIF ~RTL210_UP}\r\nend;\r\n\r\nfunction TJclFileEnumerator.GetRunningTasks: Integer;\r\nbegin\r\n Result := FTasks.Count;\r\nend;\r\n\r\nprocedure TJclFileEnumerator.StopTask(ID: TFileSearchTaskID);\r\nvar\r\n Task: TEnumFileThread;\r\n I: Integer;\r\nbegin\r\n for I := 0 to FTasks.Count - 1 do\r\n begin\r\n Task := TEnumFileThread(FTasks[I]);\r\n if Task.ID = ID then\r\n begin\r\n Task.Terminate;\r\n Break;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJclFileEnumerator.StopAllTasks(Silently: Boolean = False);\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := 0 to FTasks.Count - 1 do\r\n begin\r\n TEnumFileThread(FTasks[I]).FNotifyOnTermination := not Silently;\r\n TEnumFileThread(FTasks[I]).Terminate;\r\n end;\r\nend;\r\n\r\nprocedure TJclFileEnumerator.TaskTerminated(Sender: TObject);\r\nbegin\r\n FTasks.Remove(Sender);\r\n try\r\n if Assigned(FOnTerminateTask) then\r\n FOnTerminateTask(TEnumFileThread(Sender).ID, TEnumFileThread(Sender).Terminated);\r\n finally\r\n if FRefCount > 0 then\r\n _Release;\r\n end;\r\nend;\r\n\r\nfunction TJclFileEnumerator.GetNextTaskID: TFileSearchTaskID;\r\nbegin\r\n Result := FNextTaskID;\r\n Inc(FNextTaskID);\r\nend;\r\n\r\nfunction TJclFileEnumerator.GetOnEnterDirectory: TFileHandler;\r\nbegin\r\n Result := FOnEnterDirectory;\r\nend;\r\n\r\nfunction TJclFileEnumerator.GetOnTerminateTask: TFileSearchTerminationEvent;\r\nbegin\r\n Result := FOnTerminateTask;\r\nend;\r\n\r\nfunction TJclFileEnumerator.GetSynchronizationMode: TFileEnumeratorSyncMode;\r\nbegin\r\n Result := FSynchronizationMode;\r\nend;\r\n\r\nprocedure TJclFileEnumerator.SetOnEnterDirectory(\r\n const Value: TFileHandler);\r\nbegin\r\n FOnEnterDirectory := Value;\r\nend;\r\n\r\nprocedure TJclFileEnumerator.SetOnTerminateTask(\r\n const Value: TFileSearchTerminationEvent);\r\nbegin\r\n FOnTerminateTask := Value;\r\nend;\r\n\r\nprocedure TJclFileEnumerator.SetSynchronizationMode(\r\n const Value: TFileEnumeratorSyncMode);\r\nbegin\r\n FSynchronizationMode := Value;\r\nend;\r\n\r\nfunction FileSearch: IJclFileEnumerator;\r\nbegin\r\n Result := TJclFileEnumerator.Create;\r\nend;\r\n\r\nfunction SamePath(const Path1, Path2: string): Boolean;\r\nbegin\r\n {$IFDEF MSWINDOWS}\r\n Result := AnsiSameText(PathGetLongName(Path1), PathGetLongName(Path2));\r\n {$ELSE ~MSWINDOWS}\r\n Result := Path1 = Path2;\r\n {$ENDIF ~MSWINDOWS}\r\nend;\r\n\r\n// add items at the end\r\nprocedure PathListAddItems(var List: string; const Items: string);\r\nbegin\r\n ListAddItems(List, DirSeparator, Items);\r\nend;\r\n\r\n// add items at the end if they are not present\r\nprocedure PathListIncludeItems(var List: string; const Items: string);\r\nvar\r\n StrList, NewItems: TStringList;\r\n IndexNew, IndexList: Integer;\r\n Item: string;\r\n Duplicate: Boolean;\r\nbegin\r\n StrList := TStringList.Create;\r\n try\r\n StrToStrings(List, DirSeparator, StrList);\r\n\r\n NewItems := TStringList.Create;\r\n try\r\n StrToStrings(Items, DirSeparator, NewItems);\r\n\r\n for IndexNew := 0 to NewItems.Count - 1 do\r\n begin\r\n Item := NewItems.Strings[IndexNew];\r\n\r\n Duplicate := False;\r\n for IndexList := 0 to StrList.Count - 1 do\r\n if SamePath(Item, StrList.Strings[IndexList]) then\r\n begin\r\n Duplicate := True;\r\n Break;\r\n end;\r\n\r\n if not Duplicate then\r\n StrList.Add(Item);\r\n end;\r\n\r\n List := StringsToStr(StrList, DirSeparator);\r\n finally\r\n NewItems.Free;\r\n end;\r\n finally\r\n StrList.Free;\r\n end;\r\nend;\r\n\r\n// delete multiple items\r\nprocedure PathListDelItems(var List: string; const Items: string);\r\nvar\r\n StrList, RemItems: TStringList;\r\n IndexRem, IndexList: Integer;\r\n Item: string;\r\nbegin\r\n StrList := TStringList.Create;\r\n try\r\n StrToStrings(List, DirSeparator, StrList);\r\n\r\n RemItems := TStringList.Create;\r\n try\r\n StrToStrings(Items, DirSeparator, RemItems);\r\n\r\n for IndexRem := 0 to RemItems.Count - 1 do\r\n begin\r\n Item := RemItems.Strings[IndexRem];\r\n\r\n for IndexList := StrList.Count - 1 downto 0 do\r\n if SamePath(Item, StrList.Strings[IndexList]) then\r\n StrList.Delete(IndexList);\r\n end;\r\n\r\n List := StringsToStr(StrList, DirSeparator);\r\n finally\r\n RemItems.Free;\r\n end;\r\n finally\r\n StrList.Free;\r\n end;\r\nend;\r\n\r\n// delete one item\r\nprocedure PathListDelItem(var List: string; const Index: Integer);\r\nbegin\r\n ListDelItem(List, DirSeparator, Index);\r\nend;\r\n\r\n// return the number of item\r\nfunction PathListItemCount(const List: string): Integer;\r\nbegin\r\n Result := ListItemCount(List, DirSeparator);\r\nend;\r\n\r\n// return the Nth item\r\nfunction PathListGetItem(const List: string; const Index: Integer): string;\r\nbegin\r\n Result := ListGetItem(List, DirSeparator, Index);\r\nend;\r\n\r\n// set the Nth item\r\nprocedure PathListSetItem(var List: string; const Index: Integer; const Value: string);\r\nbegin\r\n ListSetItem(List, DirSeparator, Index, Value);\r\nend;\r\n\r\n// return the index of an item\r\nfunction PathListItemIndex(const List, Item: string): Integer;\r\nvar\r\n StrList: TStringList;\r\n IndexList: Integer;\r\nbegin\r\n StrList := TStringList.Create;\r\n try\r\n StrToStrings(List, DirSeparator, StrList);\r\n\r\n Result := -1;\r\n\r\n for IndexList := 0 to StrList.Count - 1 do\r\n if SamePath(StrList.Strings[IndexList], Item) then\r\n begin\r\n Result := IndexList;\r\n Break;\r\n end;\r\n finally\r\n StrList.Free;\r\n end;\r\nend;\r\n\r\n\r\n// additional functions to access the commandline parameters of an application\r\n\r\n// returns the name of the command line parameter at position index, which is\r\n// separated by the given separator, if the first character of the name part\r\n// is one of the AllowedPrefixCharacters, this character will be deleted.\r\nfunction ParamName (Index : Integer; const Separator : string = '=';\r\n const AllowedPrefixCharacters : string = '-/'; TrimName : Boolean = true) : string;\r\nvar s: string;\r\n p: Integer;\r\nbegin\r\n if (index > 0) and (index <= ParamCount) then\r\n begin\r\n s := ParamStr(index);\r\n if Pos(Copy(s, 1, 1), AllowedPrefixCharacters) > 0 then\r\n s := Copy (s, 2, Length(s)-1);\r\n p := Pos(Separator, s);\r\n if p > 0 then\r\n s := Copy (s, 1, p-1);\r\n if TrimName then\r\n s := Trim(s);\r\n Result := s;\r\n end\r\n else\r\n Result := '';\r\nend;\r\n\r\n// returns the value of the command line parameter at position index, which is\r\n// separated by the given separator\r\nfunction ParamValue (Index : Integer; const Separator : string = '='; TrimValue : Boolean = true) : string;\r\nvar s: string;\r\n p: Integer;\r\nbegin\r\n if (index > 0) and (index <= ParamCount) then\r\n begin\r\n s := ParamStr(index);\r\n p := Pos(Separator, s);\r\n if p > 0 then\r\n s := Copy (s, p+1, Length(s)-p);\r\n if TrimValue then\r\n s := Trim(s);\r\n Result := s;\r\n end\r\n else\r\n Result := '';\r\nend;\r\n\r\n// seaches a command line parameter where the namepart is the searchname\r\n// and returns the value which is which by the given separator.\r\n// CaseSensitive defines the search type. if the first character of the name part\r\n// is one of the AllowedPrefixCharacters, this character will be deleted.\r\nfunction ParamValue (const SearchName : string; const Separator : string = '=';\r\n CaseSensitive : Boolean = False;\r\n const AllowedPrefixCharacters : string = '-/'; TrimValue : Boolean = true) : string;\r\nvar pName : string;\r\n i : Integer;\r\nbegin\r\n Result := '';\r\n for i := 1 to ParamCount do\r\n begin\r\n pName := ParamName(i, Separator, AllowedPrefixCharacters, True);\r\n if (CaseSensitive and (pName = Trim(SearchName))) or\r\n (UpperCase(pName) = Trim(UpperCase(SearchName))) then\r\n begin\r\n Result := ParamValue (i, Separator, TrimValue);\r\n exit;\r\n end;\r\n end;\r\nend;\r\n\r\n// seaches a command line parameter where the namepart is the searchname\r\n// and returns the position index. if no separator is defined, the full paramstr is compared.\r\n// CaseSensitive defines the search type. if the first character of the name part\r\n// is one of the AllowedPrefixCharacters, this character will be deleted.\r\nfunction ParamPos (const SearchName : string; const Separator : string = '=';\r\n CaseSensitive : Boolean = False;\r\n const AllowedPrefixCharacters : string = '-/'): Integer;\r\nvar pName : string;\r\n i : Integer;\r\nbegin\r\n Result := -1;\r\n for i := 1 to ParamCount do\r\n begin\r\n pName := ParamName(i, Separator, AllowedPrefixCharacters, True);\r\n if (CaseSensitive and (pName = SearchName)) or\r\n (UpperCase(pName) = UpperCase(SearchName)) then\r\n begin\r\n Result := i;\r\n Exit;\r\n end;\r\n end;\r\nend;\r\n\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jcl/source/common/JclHashMaps.pas", "content": "{**************************************************************************************************}\r\n{ WARNING: JEDI preprocessor generated unit. Do not edit. }\r\n{**************************************************************************************************}\r\n\r\n{**************************************************************************************************}\r\n{ }\r\n{ Project JEDI Code Library (JCL) }\r\n{ }\r\n{ The contents of this file are subject to the Mozilla Public License Version 1.1 (the \"License\"); }\r\n{ you may not use this file except in compliance with the License. You may obtain a copy of the }\r\n{ License at http://www.mozilla.org/MPL/ }\r\n{ }\r\n{ Software distributed under the License is distributed on an \"AS IS\" basis, WITHOUT WARRANTY OF }\r\n{ ANY KIND, either express or implied. See the License for the specific language governing rights }\r\n{ and limitations under the License. }\r\n{ }\r\n{ The Original Code is HashMap.pas. }\r\n{ }\r\n{ The Initial Developer of the Original Code is Jean-Philippe BEMPEL aka RDM. Portions created by }\r\n{ Jean-Philippe BEMPEL are Copyright (C) Jean-Philippe BEMPEL (rdm_30 att yahoo dott com) }\r\n{ All rights reserved. }\r\n{ }\r\n{ Contributors: }\r\n{ Florent Ouchet (outchy) }\r\n{ }\r\n{**************************************************************************************************}\r\n{ }\r\n{ The Delphi Container Library }\r\n{ }\r\n{**************************************************************************************************}\r\n{ }\r\n{ Last modified: $Date:: 2012-03-03 11:17:49 +0100 (sam. 03 mars 2012) $ }\r\n{ Revision: $Rev:: 3755 $ }\r\n{ Author: $Author:: outchy $ }\r\n{ }\r\n{**************************************************************************************************}\r\n\r\nunit JclHashMaps;\r\n\r\n{$I jcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n {$IFDEF HAS_UNITSCOPE}\r\n System.Classes,\r\n {$ELSE ~HAS_UNITSCOPE}\r\n Classes,\r\n {$ENDIF ~HAS_UNITSCOPE}\r\n JclAlgorithms,\r\n JclBase, JclSynch,\r\n JclContainerIntf, JclAbstractContainers, JclArrayLists, JclArraySets;\r\n\r\n\r\ntype\r\n TJclIntfIntfHashMapEntry = record\r\n Key: IInterface;\r\n Value: IInterface;\r\n end;\r\n\r\n TJclIntfIntfHashMapEntryArray = array of TJclIntfIntfHashMapEntry;\r\n\r\n TJclIntfIntfHashMapBucket = class\r\n public\r\n Size: Integer;\r\n Entries: TJclIntfIntfHashMapEntryArray;\r\n procedure FinalizeArrayBeforeMove(var List: TJclIntfIntfHashMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\n {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\n procedure InitializeArray(var List: TJclIntfIntfHashMapEntryArray; FromIndex, Count: SizeInt);\r\n {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\n procedure InitializeArrayAfterMove(var List: TJclIntfIntfHashMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\n {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\n\r\n procedure MoveArray(var List: TJclIntfIntfHashMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\n end;\r\n\r\n TJclIntfIntfHashMap = class(TJclIntfAbstractContainer, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclIntfCloneable, IJclCloneable, IJclGrowable, IJclPackable, IJclBaseContainer, IJclIntfContainer,\r\n IJclIntfIntfMap)\r\n protected\r\n function CreateEmptyContainer: TJclAbstractContainerBase; override;\r\n function FreeKey(var Key: IInterface): IInterface;\r\n function FreeValue(var Value: IInterface): IInterface;\r\n function KeysEqual(const A, B: IInterface): Boolean;\r\n function ValuesEqual(const A, B: IInterface): Boolean;\r\n private\r\n FBuckets: array of TJclIntfIntfHashMapBucket;\r\n FHashToRangeFunction: TJclHashToRangeFunction;\r\n protected\r\n procedure AssignDataTo(Dest: TJclAbstractContainerBase); override;\r\n procedure AssignPropertiesTo(Dest: TJclAbstractContainerBase); override;\r\n public\r\n constructor Create(ACapacity: Integer);\r\n destructor Destroy; override;\r\n property HashToRangeFunction: TJclHashToRangeFunction read FHashToRangeFunction write FHashToRangeFunction;\r\n { IJclPackable }\r\n procedure Pack; override;\r\n procedure SetCapacity(Value: Integer); override;\r\n { IJclIntfIntfMap }\r\n procedure Clear;\r\n function ContainsKey(const Key: IInterface): Boolean;\r\n function ContainsValue(const Value: IInterface): Boolean;\r\n function Extract(const Key: IInterface): IInterface;\r\n function GetValue(const Key: IInterface): IInterface;\r\n function IsEmpty: Boolean;\r\n function KeyOfValue(const Value: IInterface): IInterface;\r\n function KeySet: IJclIntfSet;\r\n function MapEquals(const AMap: IJclIntfIntfMap): Boolean;\r\n procedure PutAll(const AMap: IJclIntfIntfMap);\r\n procedure PutValue(const Key: IInterface; const Value: IInterface);\r\n function Remove(const Key: IInterface): IInterface;\r\n function Size: Integer;\r\n function Values: IJclIntfCollection;\r\n end;\r\n\r\n TJclAnsiStrIntfHashMapEntry = record\r\n Key: AnsiString;\r\n Value: IInterface;\r\n end;\r\n\r\n TJclAnsiStrIntfHashMapEntryArray = array of TJclAnsiStrIntfHashMapEntry;\r\n\r\n TJclAnsiStrIntfHashMapBucket = class\r\n public\r\n Size: Integer;\r\n Entries: TJclAnsiStrIntfHashMapEntryArray;\r\n procedure FinalizeArrayBeforeMove(var List: TJclAnsiStrIntfHashMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\n {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\n procedure InitializeArray(var List: TJclAnsiStrIntfHashMapEntryArray; FromIndex, Count: SizeInt);\r\n {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\n procedure InitializeArrayAfterMove(var List: TJclAnsiStrIntfHashMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\n {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\n\r\n procedure MoveArray(var List: TJclAnsiStrIntfHashMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\n end;\r\n\r\n TJclAnsiStrIntfHashMap = class(TJclAnsiStrAbstractContainer, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclIntfCloneable, IJclCloneable, IJclGrowable, IJclPackable, IJclBaseContainer, IJclStrBaseContainer, IJclAnsiStrContainer, IJclIntfContainer,\r\n IJclAnsiStrIntfMap)\r\n protected\r\n function CreateEmptyContainer: TJclAbstractContainerBase; override;\r\n function FreeKey(var Key: AnsiString): AnsiString;\r\n function FreeValue(var Value: IInterface): IInterface;\r\n function KeysEqual(const A, B: AnsiString): Boolean;\r\n function ValuesEqual(const A, B: IInterface): Boolean;\r\n private\r\n FBuckets: array of TJclAnsiStrIntfHashMapBucket;\r\n FHashToRangeFunction: TJclHashToRangeFunction;\r\n protected\r\n procedure AssignDataTo(Dest: TJclAbstractContainerBase); override;\r\n procedure AssignPropertiesTo(Dest: TJclAbstractContainerBase); override;\r\n public\r\n constructor Create(ACapacity: Integer);\r\n destructor Destroy; override;\r\n property HashToRangeFunction: TJclHashToRangeFunction read FHashToRangeFunction write FHashToRangeFunction;\r\n { IJclPackable }\r\n procedure Pack; override;\r\n procedure SetCapacity(Value: Integer); override;\r\n { IJclAnsiStrIntfMap }\r\n procedure Clear;\r\n function ContainsKey(const Key: AnsiString): Boolean;\r\n function ContainsValue(const Value: IInterface): Boolean;\r\n function Extract(const Key: AnsiString): IInterface;\r\n function GetValue(const Key: AnsiString): IInterface;\r\n function IsEmpty: Boolean;\r\n function KeyOfValue(const Value: IInterface): AnsiString;\r\n function KeySet: IJclAnsiStrSet;\r\n function MapEquals(const AMap: IJclAnsiStrIntfMap): Boolean;\r\n procedure PutAll(const AMap: IJclAnsiStrIntfMap);\r\n procedure PutValue(const Key: AnsiString; const Value: IInterface);\r\n function Remove(const Key: AnsiString): IInterface;\r\n function Size: Integer;\r\n function Values: IJclIntfCollection;\r\n end;\r\n\r\n TJclIntfAnsiStrHashMapEntry = record\r\n Key: IInterface;\r\n Value: AnsiString;\r\n end;\r\n\r\n TJclIntfAnsiStrHashMapEntryArray = array of TJclIntfAnsiStrHashMapEntry;\r\n\r\n TJclIntfAnsiStrHashMapBucket = class\r\n public\r\n Size: Integer;\r\n Entries: TJclIntfAnsiStrHashMapEntryArray;\r\n procedure FinalizeArrayBeforeMove(var List: TJclIntfAnsiStrHashMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\n {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\n procedure InitializeArray(var List: TJclIntfAnsiStrHashMapEntryArray; FromIndex, Count: SizeInt);\r\n {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\n procedure InitializeArrayAfterMove(var List: TJclIntfAnsiStrHashMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\n {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\n\r\n procedure MoveArray(var List: TJclIntfAnsiStrHashMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\n end;\r\n\r\n TJclIntfAnsiStrHashMap = class(TJclAnsiStrAbstractContainer, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclIntfCloneable, IJclCloneable, IJclGrowable, IJclPackable, IJclBaseContainer, IJclStrBaseContainer, IJclIntfContainer, IJclAnsiStrContainer,\r\n IJclIntfAnsiStrMap)\r\n protected\r\n function CreateEmptyContainer: TJclAbstractContainerBase; override;\r\n function FreeKey(var Key: IInterface): IInterface;\r\n function FreeValue(var Value: AnsiString): AnsiString;\r\n function Hash(const AInterface: IInterface): Integer; reintroduce;\r\n function KeysEqual(const A, B: IInterface): Boolean;\r\n function ValuesEqual(const A, B: AnsiString): Boolean;\r\n private\r\n FBuckets: array of TJclIntfAnsiStrHashMapBucket;\r\n FHashToRangeFunction: TJclHashToRangeFunction;\r\n protected\r\n procedure AssignDataTo(Dest: TJclAbstractContainerBase); override;\r\n procedure AssignPropertiesTo(Dest: TJclAbstractContainerBase); override;\r\n public\r\n constructor Create(ACapacity: Integer);\r\n destructor Destroy; override;\r\n property HashToRangeFunction: TJclHashToRangeFunction read FHashToRangeFunction write FHashToRangeFunction;\r\n { IJclPackable }\r\n procedure Pack; override;\r\n procedure SetCapacity(Value: Integer); override;\r\n { IJclIntfAnsiStrMap }\r\n procedure Clear;\r\n function ContainsKey(const Key: IInterface): Boolean;\r\n function ContainsValue(const Value: AnsiString): Boolean;\r\n function Extract(const Key: IInterface): AnsiString;\r\n function GetValue(const Key: IInterface): AnsiString;\r\n function IsEmpty: Boolean;\r\n function KeyOfValue(const Value: AnsiString): IInterface;\r\n function KeySet: IJclIntfSet;\r\n function MapEquals(const AMap: IJclIntfAnsiStrMap): Boolean;\r\n procedure PutAll(const AMap: IJclIntfAnsiStrMap);\r\n procedure PutValue(const Key: IInterface; const Value: AnsiString);\r\n function Remove(const Key: IInterface): AnsiString;\r\n function Size: Integer;\r\n function Values: IJclAnsiStrCollection;\r\n end;\r\n\r\n TJclAnsiStrAnsiStrHashMapEntry = record\r\n Key: AnsiString;\r\n Value: AnsiString;\r\n end;\r\n\r\n TJclAnsiStrAnsiStrHashMapEntryArray = array of TJclAnsiStrAnsiStrHashMapEntry;\r\n\r\n TJclAnsiStrAnsiStrHashMapBucket = class\r\n public\r\n Size: Integer;\r\n Entries: TJclAnsiStrAnsiStrHashMapEntryArray;\r\n procedure FinalizeArrayBeforeMove(var List: TJclAnsiStrAnsiStrHashMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\n {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\n procedure InitializeArray(var List: TJclAnsiStrAnsiStrHashMapEntryArray; FromIndex, Count: SizeInt);\r\n {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\n procedure InitializeArrayAfterMove(var List: TJclAnsiStrAnsiStrHashMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\n {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\n\r\n procedure MoveArray(var List: TJclAnsiStrAnsiStrHashMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\n end;\r\n\r\n TJclAnsiStrAnsiStrHashMap = class(TJclAnsiStrAbstractContainer, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclIntfCloneable, IJclCloneable, IJclGrowable, IJclPackable, IJclBaseContainer, IJclStrBaseContainer, IJclAnsiStrContainer,\r\n IJclAnsiStrAnsiStrMap)\r\n protected\r\n function CreateEmptyContainer: TJclAbstractContainerBase; override;\r\n function FreeKey(var Key: AnsiString): AnsiString;\r\n function FreeValue(var Value: AnsiString): AnsiString;\r\n function KeysEqual(const A, B: AnsiString): Boolean;\r\n function ValuesEqual(const A, B: AnsiString): Boolean;\r\n private\r\n FBuckets: array of TJclAnsiStrAnsiStrHashMapBucket;\r\n FHashToRangeFunction: TJclHashToRangeFunction;\r\n protected\r\n procedure AssignDataTo(Dest: TJclAbstractContainerBase); override;\r\n procedure AssignPropertiesTo(Dest: TJclAbstractContainerBase); override;\r\n public\r\n constructor Create(ACapacity: Integer);\r\n destructor Destroy; override;\r\n property HashToRangeFunction: TJclHashToRangeFunction read FHashToRangeFunction write FHashToRangeFunction;\r\n { IJclPackable }\r\n procedure Pack; override;\r\n procedure SetCapacity(Value: Integer); override;\r\n { IJclAnsiStrAnsiStrMap }\r\n procedure Clear;\r\n function ContainsKey(const Key: AnsiString): Boolean;\r\n function ContainsValue(const Value: AnsiString): Boolean;\r\n function Extract(const Key: AnsiString): AnsiString;\r\n function GetValue(const Key: AnsiString): AnsiString;\r\n function IsEmpty: Boolean;\r\n function KeyOfValue(const Value: AnsiString): AnsiString;\r\n function KeySet: IJclAnsiStrSet;\r\n function MapEquals(const AMap: IJclAnsiStrAnsiStrMap): Boolean;\r\n procedure PutAll(const AMap: IJclAnsiStrAnsiStrMap);\r\n procedure PutValue(const Key: AnsiString; const Value: AnsiString);\r\n function Remove(const Key: AnsiString): AnsiString;\r\n function Size: Integer;\r\n function Values: IJclAnsiStrCollection;\r\n end;\r\n\r\n TJclWideStrIntfHashMapEntry = record\r\n Key: WideString;\r\n Value: IInterface;\r\n end;\r\n\r\n TJclWideStrIntfHashMapEntryArray = array of TJclWideStrIntfHashMapEntry;\r\n\r\n TJclWideStrIntfHashMapBucket = class\r\n public\r\n Size: Integer;\r\n Entries: TJclWideStrIntfHashMapEntryArray;\r\n procedure FinalizeArrayBeforeMove(var List: TJclWideStrIntfHashMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\n {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\n procedure InitializeArray(var List: TJclWideStrIntfHashMapEntryArray; FromIndex, Count: SizeInt);\r\n {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\n procedure InitializeArrayAfterMove(var List: TJclWideStrIntfHashMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\n {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\n\r\n procedure MoveArray(var List: TJclWideStrIntfHashMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\n end;\r\n\r\n TJclWideStrIntfHashMap = class(TJclWideStrAbstractContainer, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclIntfCloneable, IJclCloneable, IJclGrowable, IJclPackable, IJclBaseContainer, IJclStrBaseContainer, IJclWideStrContainer, IJclIntfContainer,\r\n IJclWideStrIntfMap)\r\n protected\r\n function CreateEmptyContainer: TJclAbstractContainerBase; override;\r\n function FreeKey(var Key: WideString): WideString;\r\n function FreeValue(var Value: IInterface): IInterface;\r\n function KeysEqual(const A, B: WideString): Boolean;\r\n function ValuesEqual(const A, B: IInterface): Boolean;\r\n private\r\n FBuckets: array of TJclWideStrIntfHashMapBucket;\r\n FHashToRangeFunction: TJclHashToRangeFunction;\r\n protected\r\n procedure AssignDataTo(Dest: TJclAbstractContainerBase); override;\r\n procedure AssignPropertiesTo(Dest: TJclAbstractContainerBase); override;\r\n public\r\n constructor Create(ACapacity: Integer);\r\n destructor Destroy; override;\r\n property HashToRangeFunction: TJclHashToRangeFunction read FHashToRangeFunction write FHashToRangeFunction;\r\n { IJclPackable }\r\n procedure Pack; override;\r\n procedure SetCapacity(Value: Integer); override;\r\n { IJclWideStrIntfMap }\r\n procedure Clear;\r\n function ContainsKey(const Key: WideString): Boolean;\r\n function ContainsValue(const Value: IInterface): Boolean;\r\n function Extract(const Key: WideString): IInterface;\r\n function GetValue(const Key: WideString): IInterface;\r\n function IsEmpty: Boolean;\r\n function KeyOfValue(const Value: IInterface): WideString;\r\n function KeySet: IJclWideStrSet;\r\n function MapEquals(const AMap: IJclWideStrIntfMap): Boolean;\r\n procedure PutAll(const AMap: IJclWideStrIntfMap);\r\n procedure PutValue(const Key: WideString; const Value: IInterface);\r\n function Remove(const Key: WideString): IInterface;\r\n function Size: Integer;\r\n function Values: IJclIntfCollection;\r\n end;\r\n\r\n TJclIntfWideStrHashMapEntry = record\r\n Key: IInterface;\r\n Value: WideString;\r\n end;\r\n\r\n TJclIntfWideStrHashMapEntryArray = array of TJclIntfWideStrHashMapEntry;\r\n\r\n TJclIntfWideStrHashMapBucket = class\r\n public\r\n Size: Integer;\r\n Entries: TJclIntfWideStrHashMapEntryArray;\r\n procedure FinalizeArrayBeforeMove(var List: TJclIntfWideStrHashMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\n {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\n procedure InitializeArray(var List: TJclIntfWideStrHashMapEntryArray; FromIndex, Count: SizeInt);\r\n {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\n procedure InitializeArrayAfterMove(var List: TJclIntfWideStrHashMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\n {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\n\r\n procedure MoveArray(var List: TJclIntfWideStrHashMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\n end;\r\n\r\n TJclIntfWideStrHashMap = class(TJclWideStrAbstractContainer, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclIntfCloneable, IJclCloneable, IJclGrowable, IJclPackable, IJclBaseContainer, IJclStrBaseContainer, IJclIntfContainer, IJclWideStrContainer,\r\n IJclIntfWideStrMap)\r\n protected\r\n function CreateEmptyContainer: TJclAbstractContainerBase; override;\r\n function FreeKey(var Key: IInterface): IInterface;\r\n function FreeValue(var Value: WideString): WideString;\r\n function Hash(const AInterface: IInterface): Integer; reintroduce;\r\n function KeysEqual(const A, B: IInterface): Boolean;\r\n function ValuesEqual(const A, B: WideString): Boolean;\r\n private\r\n FBuckets: array of TJclIntfWideStrHashMapBucket;\r\n FHashToRangeFunction: TJclHashToRangeFunction;\r\n protected\r\n procedure AssignDataTo(Dest: TJclAbstractContainerBase); override;\r\n procedure AssignPropertiesTo(Dest: TJclAbstractContainerBase); override;\r\n public\r\n constructor Create(ACapacity: Integer);\r\n destructor Destroy; override;\r\n property HashToRangeFunction: TJclHashToRangeFunction read FHashToRangeFunction write FHashToRangeFunction;\r\n { IJclPackable }\r\n procedure Pack; override;\r\n procedure SetCapacity(Value: Integer); override;\r\n { IJclIntfWideStrMap }\r\n procedure Clear;\r\n function ContainsKey(const Key: IInterface): Boolean;\r\n function ContainsValue(const Value: WideString): Boolean;\r\n function Extract(const Key: IInterface): WideString;\r\n function GetValue(const Key: IInterface): WideString;\r\n function IsEmpty: Boolean;\r\n function KeyOfValue(const Value: WideString): IInterface;\r\n function KeySet: IJclIntfSet;\r\n function MapEquals(const AMap: IJclIntfWideStrMap): Boolean;\r\n procedure PutAll(const AMap: IJclIntfWideStrMap);\r\n procedure PutValue(const Key: IInterface; const Value: WideString);\r\n function Remove(const Key: IInterface): WideString;\r\n function Size: Integer;\r\n function Values: IJclWideStrCollection;\r\n end;\r\n\r\n TJclWideStrWideStrHashMapEntry = record\r\n Key: WideString;\r\n Value: WideString;\r\n end;\r\n\r\n TJclWideStrWideStrHashMapEntryArray = array of TJclWideStrWideStrHashMapEntry;\r\n\r\n TJclWideStrWideStrHashMapBucket = class\r\n public\r\n Size: Integer;\r\n Entries: TJclWideStrWideStrHashMapEntryArray;\r\n procedure FinalizeArrayBeforeMove(var List: TJclWideStrWideStrHashMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\n {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\n procedure InitializeArray(var List: TJclWideStrWideStrHashMapEntryArray; FromIndex, Count: SizeInt);\r\n {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\n procedure InitializeArrayAfterMove(var List: TJclWideStrWideStrHashMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\n {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\n\r\n procedure MoveArray(var List: TJclWideStrWideStrHashMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\n end;\r\n\r\n TJclWideStrWideStrHashMap = class(TJclWideStrAbstractContainer, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclIntfCloneable, IJclCloneable, IJclGrowable, IJclPackable, IJclBaseContainer, IJclStrBaseContainer, IJclWideStrContainer,\r\n IJclWideStrWideStrMap)\r\n protected\r\n function CreateEmptyContainer: TJclAbstractContainerBase; override;\r\n function FreeKey(var Key: WideString): WideString;\r\n function FreeValue(var Value: WideString): WideString;\r\n function KeysEqual(const A, B: WideString): Boolean;\r\n function ValuesEqual(const A, B: WideString): Boolean;\r\n private\r\n FBuckets: array of TJclWideStrWideStrHashMapBucket;\r\n FHashToRangeFunction: TJclHashToRangeFunction;\r\n protected\r\n procedure AssignDataTo(Dest: TJclAbstractContainerBase); override;\r\n procedure AssignPropertiesTo(Dest: TJclAbstractContainerBase); override;\r\n public\r\n constructor Create(ACapacity: Integer);\r\n destructor Destroy; override;\r\n property HashToRangeFunction: TJclHashToRangeFunction read FHashToRangeFunction write FHashToRangeFunction;\r\n { IJclPackable }\r\n procedure Pack; override;\r\n procedure SetCapacity(Value: Integer); override;\r\n { IJclWideStrWideStrMap }\r\n procedure Clear;\r\n function ContainsKey(const Key: WideString): Boolean;\r\n function ContainsValue(const Value: WideString): Boolean;\r\n function Extract(const Key: WideString): WideString;\r\n function GetValue(const Key: WideString): WideString;\r\n function IsEmpty: Boolean;\r\n function KeyOfValue(const Value: WideString): WideString;\r\n function KeySet: IJclWideStrSet;\r\n function MapEquals(const AMap: IJclWideStrWideStrMap): Boolean;\r\n procedure PutAll(const AMap: IJclWideStrWideStrMap);\r\n procedure PutValue(const Key: WideString; const Value: WideString);\r\n function Remove(const Key: WideString): WideString;\r\n function Size: Integer;\r\n function Values: IJclWideStrCollection;\r\n end;\r\n\r\n {$IFDEF SUPPORTS_UNICODE_STRING}\r\n TJclUnicodeStrIntfHashMapEntry = record\r\n Key: UnicodeString;\r\n Value: IInterface;\r\n end;\r\n\r\n TJclUnicodeStrIntfHashMapEntryArray = array of TJclUnicodeStrIntfHashMapEntry;\r\n\r\n TJclUnicodeStrIntfHashMapBucket = class\r\n public\r\n Size: Integer;\r\n Entries: TJclUnicodeStrIntfHashMapEntryArray;\r\n procedure FinalizeArrayBeforeMove(var List: TJclUnicodeStrIntfHashMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\n {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\n procedure InitializeArray(var List: TJclUnicodeStrIntfHashMapEntryArray; FromIndex, Count: SizeInt);\r\n {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\n procedure InitializeArrayAfterMove(var List: TJclUnicodeStrIntfHashMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\n {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\n\r\n procedure MoveArray(var List: TJclUnicodeStrIntfHashMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\n end;\r\n {$ENDIF SUPPORTS_UNICODE_STRING}\r\n\r\n {$IFDEF SUPPORTS_UNICODE_STRING}\r\n TJclUnicodeStrIntfHashMap = class(TJclUnicodeStrAbstractContainer, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclIntfCloneable, IJclCloneable, IJclGrowable, IJclPackable, IJclBaseContainer, IJclStrBaseContainer, IJclUnicodeStrContainer, IJclIntfContainer,\r\n IJclUnicodeStrIntfMap)\r\n protected\r\n function CreateEmptyContainer: TJclAbstractContainerBase; override;\r\n function FreeKey(var Key: UnicodeString): UnicodeString;\r\n function FreeValue(var Value: IInterface): IInterface;\r\n function KeysEqual(const A, B: UnicodeString): Boolean;\r\n function ValuesEqual(const A, B: IInterface): Boolean;\r\n private\r\n FBuckets: array of TJclUnicodeStrIntfHashMapBucket;\r\n FHashToRangeFunction: TJclHashToRangeFunction;\r\n protected\r\n procedure AssignDataTo(Dest: TJclAbstractContainerBase); override;\r\n procedure AssignPropertiesTo(Dest: TJclAbstractContainerBase); override;\r\n public\r\n constructor Create(ACapacity: Integer);\r\n destructor Destroy; override;\r\n property HashToRangeFunction: TJclHashToRangeFunction read FHashToRangeFunction write FHashToRangeFunction;\r\n { IJclPackable }\r\n procedure Pack; override;\r\n procedure SetCapacity(Value: Integer); override;\r\n { IJclUnicodeStrIntfMap }\r\n procedure Clear;\r\n function ContainsKey(const Key: UnicodeString): Boolean;\r\n function ContainsValue(const Value: IInterface): Boolean;\r\n function Extract(const Key: UnicodeString): IInterface;\r\n function GetValue(const Key: UnicodeString): IInterface;\r\n function IsEmpty: Boolean;\r\n function KeyOfValue(const Value: IInterface): UnicodeString;\r\n function KeySet: IJclUnicodeStrSet;\r\n function MapEquals(const AMap: IJclUnicodeStrIntfMap): Boolean;\r\n procedure PutAll(const AMap: IJclUnicodeStrIntfMap);\r\n procedure PutValue(const Key: UnicodeString; const Value: IInterface);\r\n function Remove(const Key: UnicodeString): IInterface;\r\n function Size: Integer;\r\n function Values: IJclIntfCollection;\r\n end;\r\n {$ENDIF SUPPORTS_UNICODE_STRING}\r\n\r\n {$IFDEF SUPPORTS_UNICODE_STRING}\r\n TJclIntfUnicodeStrHashMapEntry = record\r\n Key: IInterface;\r\n Value: UnicodeString;\r\n end;\r\n\r\n TJclIntfUnicodeStrHashMapEntryArray = array of TJclIntfUnicodeStrHashMapEntry;\r\n\r\n TJclIntfUnicodeStrHashMapBucket = class\r\n public\r\n Size: Integer;\r\n Entries: TJclIntfUnicodeStrHashMapEntryArray;\r\n procedure FinalizeArrayBeforeMove(var List: TJclIntfUnicodeStrHashMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\n {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\n procedure InitializeArray(var List: TJclIntfUnicodeStrHashMapEntryArray; FromIndex, Count: SizeInt);\r\n {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\n procedure InitializeArrayAfterMove(var List: TJclIntfUnicodeStrHashMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\n {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\n\r\n procedure MoveArray(var List: TJclIntfUnicodeStrHashMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\n end;\r\n {$ENDIF SUPPORTS_UNICODE_STRING}\r\n\r\n {$IFDEF SUPPORTS_UNICODE_STRING}\r\n TJclIntfUnicodeStrHashMap = class(TJclUnicodeStrAbstractContainer, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclIntfCloneable, IJclCloneable, IJclGrowable, IJclPackable, IJclBaseContainer, IJclStrBaseContainer, IJclIntfContainer, IJclUnicodeStrContainer,\r\n IJclIntfUnicodeStrMap)\r\n protected\r\n function CreateEmptyContainer: TJclAbstractContainerBase; override;\r\n function FreeKey(var Key: IInterface): IInterface;\r\n function FreeValue(var Value: UnicodeString): UnicodeString;\r\n function Hash(const AInterface: IInterface): Integer; reintroduce;\r\n function KeysEqual(const A, B: IInterface): Boolean;\r\n function ValuesEqual(const A, B: UnicodeString): Boolean;\r\n private\r\n FBuckets: array of TJclIntfUnicodeStrHashMapBucket;\r\n FHashToRangeFunction: TJclHashToRangeFunction;\r\n protected\r\n procedure AssignDataTo(Dest: TJclAbstractContainerBase); override;\r\n procedure AssignPropertiesTo(Dest: TJclAbstractContainerBase); override;\r\n public\r\n constructor Create(ACapacity: Integer);\r\n destructor Destroy; override;\r\n property HashToRangeFunction: TJclHashToRangeFunction read FHashToRangeFunction write FHashToRangeFunction;\r\n { IJclPackable }\r\n procedure Pack; override;\r\n procedure SetCapacity(Value: Integer); override;\r\n { IJclIntfUnicodeStrMap }\r\n procedure Clear;\r\n function ContainsKey(const Key: IInterface): Boolean;\r\n function ContainsValue(const Value: UnicodeString): Boolean;\r\n function Extract(const Key: IInterface): UnicodeString;\r\n function GetValue(const Key: IInterface): UnicodeString;\r\n function IsEmpty: Boolean;\r\n function KeyOfValue(const Value: UnicodeString): IInterface;\r\n function KeySet: IJclIntfSet;\r\n function MapEquals(const AMap: IJclIntfUnicodeStrMap): Boolean;\r\n procedure PutAll(const AMap: IJclIntfUnicodeStrMap);\r\n procedure PutValue(const Key: IInterface; const Value: UnicodeString);\r\n function Remove(const Key: IInterface): UnicodeString;\r\n function Size: Integer;\r\n function Values: IJclUnicodeStrCollection;\r\n end;\r\n {$ENDIF SUPPORTS_UNICODE_STRING}\r\n\r\n {$IFDEF SUPPORTS_UNICODE_STRING}\r\n TJclUnicodeStrUnicodeStrHashMapEntry = record\r\n Key: UnicodeString;\r\n Value: UnicodeString;\r\n end;\r\n\r\n TJclUnicodeStrUnicodeStrHashMapEntryArray = array of TJclUnicodeStrUnicodeStrHashMapEntry;\r\n\r\n TJclUnicodeStrUnicodeStrHashMapBucket = class\r\n public\r\n Size: Integer;\r\n Entries: TJclUnicodeStrUnicodeStrHashMapEntryArray;\r\n procedure FinalizeArrayBeforeMove(var List: TJclUnicodeStrUnicodeStrHashMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\n {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\n procedure InitializeArray(var List: TJclUnicodeStrUnicodeStrHashMapEntryArray; FromIndex, Count: SizeInt);\r\n {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\n procedure InitializeArrayAfterMove(var List: TJclUnicodeStrUnicodeStrHashMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\n {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\n\r\n procedure MoveArray(var List: TJclUnicodeStrUnicodeStrHashMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\n end;\r\n {$ENDIF SUPPORTS_UNICODE_STRING}\r\n\r\n {$IFDEF SUPPORTS_UNICODE_STRING}\r\n TJclUnicodeStrUnicodeStrHashMap = class(TJclUnicodeStrAbstractContainer, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclIntfCloneable, IJclCloneable, IJclGrowable, IJclPackable, IJclBaseContainer, IJclStrBaseContainer, IJclUnicodeStrContainer,\r\n IJclUnicodeStrUnicodeStrMap)\r\n protected\r\n function CreateEmptyContainer: TJclAbstractContainerBase; override;\r\n function FreeKey(var Key: UnicodeString): UnicodeString;\r\n function FreeValue(var Value: UnicodeString): UnicodeString;\r\n function KeysEqual(const A, B: UnicodeString): Boolean;\r\n function ValuesEqual(const A, B: UnicodeString): Boolean;\r\n private\r\n FBuckets: array of TJclUnicodeStrUnicodeStrHashMapBucket;\r\n FHashToRangeFunction: TJclHashToRangeFunction;\r\n protected\r\n procedure AssignDataTo(Dest: TJclAbstractContainerBase); override;\r\n procedure AssignPropertiesTo(Dest: TJclAbstractContainerBase); override;\r\n public\r\n constructor Create(ACapacity: Integer);\r\n destructor Destroy; override;\r\n property HashToRangeFunction: TJclHashToRangeFunction read FHashToRangeFunction write FHashToRangeFunction;\r\n { IJclPackable }\r\n procedure Pack; override;\r\n procedure SetCapacity(Value: Integer); override;\r\n { IJclUnicodeStrUnicodeStrMap }\r\n procedure Clear;\r\n function ContainsKey(const Key: UnicodeString): Boolean;\r\n function ContainsValue(const Value: UnicodeString): Boolean;\r\n function Extract(const Key: UnicodeString): UnicodeString;\r\n function GetValue(const Key: UnicodeString): UnicodeString;\r\n function IsEmpty: Boolean;\r\n function KeyOfValue(const Value: UnicodeString): UnicodeString;\r\n function KeySet: IJclUnicodeStrSet;\r\n function MapEquals(const AMap: IJclUnicodeStrUnicodeStrMap): Boolean;\r\n procedure PutAll(const AMap: IJclUnicodeStrUnicodeStrMap);\r\n procedure PutValue(const Key: UnicodeString; const Value: UnicodeString);\r\n function Remove(const Key: UnicodeString): UnicodeString;\r\n function Size: Integer;\r\n function Values: IJclUnicodeStrCollection;\r\n end;\r\n {$ENDIF SUPPORTS_UNICODE_STRING}\r\n\r\n {$IFDEF CONTAINER_ANSISTR}\r\n TJclStrIntfHashMapEntry = TJclAnsiStrIntfHashMapEntry;\r\n TJclStrIntfHashMapBucket = TJclAnsiStrIntfHashMapBucket;\r\n {$ENDIF CONTAINER_ANSISTR}\r\n {$IFDEF CONTAINER_WIDESTR}\r\n TJclStrIntfHashMapEntry = TJclWideStrIntfHashMapEntry;\r\n TJclStrIntfHashMapBucket = TJclWideStrIntfHashMapBucket;\r\n {$ENDIF CONTAINER_WIDESTR}\r\n {$IFDEF CONTAINER_UNICODESTR}\r\n TJclStrIntfHashMapEntry = TJclUnicodeStrIntfHashMapEntry;\r\n TJclStrIntfHashMapBucket = TJclUnicodeStrIntfHashMapBucket;\r\n {$ENDIF CONTAINER_UNICODESTR}\r\n\r\n {$IFDEF CONTAINER_ANSISTR}\r\n TJclStrIntfHashMap = TJclAnsiStrIntfHashMap;\r\n {$ENDIF CONTAINER_ANSISTR}\r\n {$IFDEF CONTAINER_WIDESTR}\r\n TJclStrIntfHashMap = TJclWideStrIntfHashMap;\r\n {$ENDIF CONTAINER_WIDESTR}\r\n {$IFDEF CONTAINER_UNICODESTR}\r\n TJclStrIntfHashMap = TJclUnicodeStrIntfHashMap;\r\n {$ENDIF CONTAINER_UNICODESTR}\r\n\r\n {$IFDEF CONTAINER_ANSISTR}\r\n TJclIntfStrHashMapEntry = TJclIntfAnsiStrHashMapEntry;\r\n TJclIntfStrHashMapBucket = TJclIntfAnsiStrHashMapBucket;\r\n {$ENDIF CONTAINER_ANSISTR}\r\n {$IFDEF CONTAINER_WIDESTR}\r\n TJclIntfStrHashMapEntry = TJclIntfWideStrHashMapEntry;\r\n TJclIntfStrHashMapBucket = TJclIntfWideStrHashMapBucket;\r\n {$ENDIF CONTAINER_WIDESTR}\r\n {$IFDEF CONTAINER_UNICODESTR}\r\n TJclIntfStrHashMapEntry = TJclIntfUnicodeStrHashMapEntry;\r\n TJclIntfStrHashMapBucket = TJclIntfUnicodeStrHashMapBucket;\r\n {$ENDIF CONTAINER_UNICODESTR}\r\n\r\n {$IFDEF CONTAINER_ANSISTR}\r\n TJclIntfStrHashMap = TJclIntfAnsiStrHashMap;\r\n {$ENDIF CONTAINER_ANSISTR}\r\n {$IFDEF CONTAINER_WIDESTR}\r\n TJclIntfStrHashMap = TJclIntfWideStrHashMap;\r\n {$ENDIF CONTAINER_WIDESTR}\r\n {$IFDEF CONTAINER_UNICODESTR}\r\n TJclIntfStrHashMap = TJclIntfUnicodeStrHashMap;\r\n {$ENDIF CONTAINER_UNICODESTR}\r\n\r\n {$IFDEF CONTAINER_ANSISTR}\r\n TJclStrStrHashMapEntry = TJclAnsiStrAnsiStrHashMapEntry;\r\n TJclStrStrHashMapBucket = TJclAnsiStrAnsiStrHashMapBucket;\r\n {$ENDIF CONTAINER_ANSISTR}\r\n {$IFDEF CONTAINER_WIDESTR}\r\n TJclStrStrHashMapEntry = TJclWideStrWideStrHashMapEntry;\r\n TJclStrStrHashMapBucket = TJclWideStrWideStrHashMapBucket;\r\n {$ENDIF CONTAINER_WIDESTR}\r\n {$IFDEF CONTAINER_UNICODESTR}\r\n TJclStrStrHashMapEntry = TJclUnicodeStrUnicodeStrHashMapEntry;\r\n TJclStrStrHashMapBucket = TJclUnicodeStrUnicodeStrHashMapBucket;\r\n {$ENDIF CONTAINER_UNICODESTR}\r\n\r\n {$IFDEF CONTAINER_ANSISTR}\r\n TJclStrStrHashMap = TJclAnsiStrAnsiStrHashMap;\r\n {$ENDIF CONTAINER_ANSISTR}\r\n {$IFDEF CONTAINER_WIDESTR}\r\n TJclStrStrHashMap = TJclWideStrWideStrHashMap;\r\n {$ENDIF CONTAINER_WIDESTR}\r\n {$IFDEF CONTAINER_UNICODESTR}\r\n TJclStrStrHashMap = TJclUnicodeStrUnicodeStrHashMap;\r\n {$ENDIF CONTAINER_UNICODESTR}\r\n\r\n TJclSingleIntfHashMapEntry = record\r\n Key: Single;\r\n Value: IInterface;\r\n end;\r\n\r\n TJclSingleIntfHashMapEntryArray = array of TJclSingleIntfHashMapEntry;\r\n\r\n TJclSingleIntfHashMapBucket = class\r\n public\r\n Size: Integer;\r\n Entries: TJclSingleIntfHashMapEntryArray;\r\n procedure FinalizeArrayBeforeMove(var List: TJclSingleIntfHashMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\n {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\n procedure InitializeArray(var List: TJclSingleIntfHashMapEntryArray; FromIndex, Count: SizeInt);\r\n {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\n procedure InitializeArrayAfterMove(var List: TJclSingleIntfHashMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\n {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\n\r\n procedure MoveArray(var List: TJclSingleIntfHashMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\n end;\r\n\r\n TJclSingleIntfHashMap = class(TJclSingleAbstractContainer, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclIntfCloneable, IJclCloneable, IJclGrowable, IJclPackable, IJclBaseContainer, IJclSingleContainer, IJclIntfContainer,\r\n IJclSingleIntfMap)\r\n protected\r\n function CreateEmptyContainer: TJclAbstractContainerBase; override;\r\n function FreeKey(var Key: Single): Single;\r\n function FreeValue(var Value: IInterface): IInterface;\r\n function KeysEqual(const A, B: Single): Boolean;\r\n function ValuesEqual(const A, B: IInterface): Boolean;\r\n private\r\n FBuckets: array of TJclSingleIntfHashMapBucket;\r\n FHashToRangeFunction: TJclHashToRangeFunction;\r\n protected\r\n procedure AssignDataTo(Dest: TJclAbstractContainerBase); override;\r\n procedure AssignPropertiesTo(Dest: TJclAbstractContainerBase); override;\r\n public\r\n constructor Create(ACapacity: Integer);\r\n destructor Destroy; override;\r\n property HashToRangeFunction: TJclHashToRangeFunction read FHashToRangeFunction write FHashToRangeFunction;\r\n { IJclPackable }\r\n procedure Pack; override;\r\n procedure SetCapacity(Value: Integer); override;\r\n { IJclSingleIntfMap }\r\n procedure Clear;\r\n function ContainsKey(const Key: Single): Boolean;\r\n function ContainsValue(const Value: IInterface): Boolean;\r\n function Extract(const Key: Single): IInterface;\r\n function GetValue(const Key: Single): IInterface;\r\n function IsEmpty: Boolean;\r\n function KeyOfValue(const Value: IInterface): Single;\r\n function KeySet: IJclSingleSet;\r\n function MapEquals(const AMap: IJclSingleIntfMap): Boolean;\r\n procedure PutAll(const AMap: IJclSingleIntfMap);\r\n procedure PutValue(const Key: Single; const Value: IInterface);\r\n function Remove(const Key: Single): IInterface;\r\n function Size: Integer;\r\n function Values: IJclIntfCollection;\r\n end;\r\n\r\n TJclIntfSingleHashMapEntry = record\r\n Key: IInterface;\r\n Value: Single;\r\n end;\r\n\r\n TJclIntfSingleHashMapEntryArray = array of TJclIntfSingleHashMapEntry;\r\n\r\n TJclIntfSingleHashMapBucket = class\r\n public\r\n Size: Integer;\r\n Entries: TJclIntfSingleHashMapEntryArray;\r\n procedure FinalizeArrayBeforeMove(var List: TJclIntfSingleHashMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\n {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\n procedure InitializeArray(var List: TJclIntfSingleHashMapEntryArray; FromIndex, Count: SizeInt);\r\n {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\n procedure InitializeArrayAfterMove(var List: TJclIntfSingleHashMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\n {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\n\r\n procedure MoveArray(var List: TJclIntfSingleHashMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\n end;\r\n\r\n TJclIntfSingleHashMap = class(TJclSingleAbstractContainer, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclIntfCloneable, IJclCloneable, IJclGrowable, IJclPackable, IJclBaseContainer, IJclIntfContainer, IJclSingleContainer,\r\n IJclIntfSingleMap)\r\n protected\r\n function CreateEmptyContainer: TJclAbstractContainerBase; override;\r\n function FreeKey(var Key: IInterface): IInterface;\r\n function FreeValue(var Value: Single): Single;\r\n function Hash(const AInterface: IInterface): Integer; reintroduce;\r\n function KeysEqual(const A, B: IInterface): Boolean;\r\n function ValuesEqual(const A, B: Single): Boolean;\r\n private\r\n FBuckets: array of TJclIntfSingleHashMapBucket;\r\n FHashToRangeFunction: TJclHashToRangeFunction;\r\n protected\r\n procedure AssignDataTo(Dest: TJclAbstractContainerBase); override;\r\n procedure AssignPropertiesTo(Dest: TJclAbstractContainerBase); override;\r\n public\r\n constructor Create(ACapacity: Integer);\r\n destructor Destroy; override;\r\n property HashToRangeFunction: TJclHashToRangeFunction read FHashToRangeFunction write FHashToRangeFunction;\r\n { IJclPackable }\r\n procedure Pack; override;\r\n procedure SetCapacity(Value: Integer); override;\r\n { IJclIntfSingleMap }\r\n procedure Clear;\r\n function ContainsKey(const Key: IInterface): Boolean;\r\n function ContainsValue(const Value: Single): Boolean;\r\n function Extract(const Key: IInterface): Single;\r\n function GetValue(const Key: IInterface): Single;\r\n function IsEmpty: Boolean;\r\n function KeyOfValue(const Value: Single): IInterface;\r\n function KeySet: IJclIntfSet;\r\n function MapEquals(const AMap: IJclIntfSingleMap): Boolean;\r\n procedure PutAll(const AMap: IJclIntfSingleMap);\r\n procedure PutValue(const Key: IInterface; const Value: Single);\r\n function Remove(const Key: IInterface): Single;\r\n function Size: Integer;\r\n function Values: IJclSingleCollection;\r\n end;\r\n\r\n TJclSingleSingleHashMapEntry = record\r\n Key: Single;\r\n Value: Single;\r\n end;\r\n\r\n TJclSingleSingleHashMapEntryArray = array of TJclSingleSingleHashMapEntry;\r\n\r\n TJclSingleSingleHashMapBucket = class\r\n public\r\n Size: Integer;\r\n Entries: TJclSingleSingleHashMapEntryArray;\r\n procedure InitializeArrayAfterMove(var List: TJclSingleSingleHashMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\n {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\n procedure MoveArray(var List: TJclSingleSingleHashMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\n end;\r\n\r\n TJclSingleSingleHashMap = class(TJclSingleAbstractContainer, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclIntfCloneable, IJclCloneable, IJclGrowable, IJclPackable, IJclBaseContainer, IJclSingleContainer,\r\n IJclSingleSingleMap)\r\n protected\r\n function CreateEmptyContainer: TJclAbstractContainerBase; override;\r\n function FreeKey(var Key: Single): Single;\r\n function FreeValue(var Value: Single): Single;\r\n function KeysEqual(const A, B: Single): Boolean;\r\n function ValuesEqual(const A, B: Single): Boolean;\r\n private\r\n FBuckets: array of TJclSingleSingleHashMapBucket;\r\n FHashToRangeFunction: TJclHashToRangeFunction;\r\n protected\r\n procedure AssignDataTo(Dest: TJclAbstractContainerBase); override;\r\n procedure AssignPropertiesTo(Dest: TJclAbstractContainerBase); override;\r\n public\r\n constructor Create(ACapacity: Integer);\r\n destructor Destroy; override;\r\n property HashToRangeFunction: TJclHashToRangeFunction read FHashToRangeFunction write FHashToRangeFunction;\r\n { IJclPackable }\r\n procedure Pack; override;\r\n procedure SetCapacity(Value: Integer); override;\r\n { IJclSingleSingleMap }\r\n procedure Clear;\r\n function ContainsKey(const Key: Single): Boolean;\r\n function ContainsValue(const Value: Single): Boolean;\r\n function Extract(const Key: Single): Single;\r\n function GetValue(const Key: Single): Single;\r\n function IsEmpty: Boolean;\r\n function KeyOfValue(const Value: Single): Single;\r\n function KeySet: IJclSingleSet;\r\n function MapEquals(const AMap: IJclSingleSingleMap): Boolean;\r\n procedure PutAll(const AMap: IJclSingleSingleMap);\r\n procedure PutValue(const Key: Single; const Value: Single);\r\n function Remove(const Key: Single): Single;\r\n function Size: Integer;\r\n function Values: IJclSingleCollection;\r\n end;\r\n\r\n TJclDoubleIntfHashMapEntry = record\r\n Key: Double;\r\n Value: IInterface;\r\n end;\r\n\r\n TJclDoubleIntfHashMapEntryArray = array of TJclDoubleIntfHashMapEntry;\r\n\r\n TJclDoubleIntfHashMapBucket = class\r\n public\r\n Size: Integer;\r\n Entries: TJclDoubleIntfHashMapEntryArray;\r\n procedure FinalizeArrayBeforeMove(var List: TJclDoubleIntfHashMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\n {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\n procedure InitializeArray(var List: TJclDoubleIntfHashMapEntryArray; FromIndex, Count: SizeInt);\r\n {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\n procedure InitializeArrayAfterMove(var List: TJclDoubleIntfHashMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\n {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\n\r\n procedure MoveArray(var List: TJclDoubleIntfHashMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\n end;\r\n\r\n TJclDoubleIntfHashMap = class(TJclDoubleAbstractContainer, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclIntfCloneable, IJclCloneable, IJclGrowable, IJclPackable, IJclBaseContainer, IJclDoubleContainer, IJclIntfContainer,\r\n IJclDoubleIntfMap)\r\n protected\r\n function CreateEmptyContainer: TJclAbstractContainerBase; override;\r\n function FreeKey(var Key: Double): Double;\r\n function FreeValue(var Value: IInterface): IInterface;\r\n function KeysEqual(const A, B: Double): Boolean;\r\n function ValuesEqual(const A, B: IInterface): Boolean;\r\n private\r\n FBuckets: array of TJclDoubleIntfHashMapBucket;\r\n FHashToRangeFunction: TJclHashToRangeFunction;\r\n protected\r\n procedure AssignDataTo(Dest: TJclAbstractContainerBase); override;\r\n procedure AssignPropertiesTo(Dest: TJclAbstractContainerBase); override;\r\n public\r\n constructor Create(ACapacity: Integer);\r\n destructor Destroy; override;\r\n property HashToRangeFunction: TJclHashToRangeFunction read FHashToRangeFunction write FHashToRangeFunction;\r\n { IJclPackable }\r\n procedure Pack; override;\r\n procedure SetCapacity(Value: Integer); override;\r\n { IJclDoubleIntfMap }\r\n procedure Clear;\r\n function ContainsKey(const Key: Double): Boolean;\r\n function ContainsValue(const Value: IInterface): Boolean;\r\n function Extract(const Key: Double): IInterface;\r\n function GetValue(const Key: Double): IInterface;\r\n function IsEmpty: Boolean;\r\n function KeyOfValue(const Value: IInterface): Double;\r\n function KeySet: IJclDoubleSet;\r\n function MapEquals(const AMap: IJclDoubleIntfMap): Boolean;\r\n procedure PutAll(const AMap: IJclDoubleIntfMap);\r\n procedure PutValue(const Key: Double; const Value: IInterface);\r\n function Remove(const Key: Double): IInterface;\r\n function Size: Integer;\r\n function Values: IJclIntfCollection;\r\n end;\r\n\r\n TJclIntfDoubleHashMapEntry = record\r\n Key: IInterface;\r\n Value: Double;\r\n end;\r\n\r\n TJclIntfDoubleHashMapEntryArray = array of TJclIntfDoubleHashMapEntry;\r\n\r\n TJclIntfDoubleHashMapBucket = class\r\n public\r\n Size: Integer;\r\n Entries: TJclIntfDoubleHashMapEntryArray;\r\n procedure FinalizeArrayBeforeMove(var List: TJclIntfDoubleHashMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\n {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\n procedure InitializeArray(var List: TJclIntfDoubleHashMapEntryArray; FromIndex, Count: SizeInt);\r\n {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\n procedure InitializeArrayAfterMove(var List: TJclIntfDoubleHashMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\n {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\n\r\n procedure MoveArray(var List: TJclIntfDoubleHashMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\n end;\r\n\r\n TJclIntfDoubleHashMap = class(TJclDoubleAbstractContainer, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclIntfCloneable, IJclCloneable, IJclGrowable, IJclPackable, IJclBaseContainer, IJclIntfContainer, IJclDoubleContainer,\r\n IJclIntfDoubleMap)\r\n protected\r\n function CreateEmptyContainer: TJclAbstractContainerBase; override;\r\n function FreeKey(var Key: IInterface): IInterface;\r\n function FreeValue(var Value: Double): Double;\r\n function Hash(const AInterface: IInterface): Integer; reintroduce;\r\n function KeysEqual(const A, B: IInterface): Boolean;\r\n function ValuesEqual(const A, B: Double): Boolean;\r\n private\r\n FBuckets: array of TJclIntfDoubleHashMapBucket;\r\n FHashToRangeFunction: TJclHashToRangeFunction;\r\n protected\r\n procedure AssignDataTo(Dest: TJclAbstractContainerBase); override;\r\n procedure AssignPropertiesTo(Dest: TJclAbstractContainerBase); override;\r\n public\r\n constructor Create(ACapacity: Integer);\r\n destructor Destroy; override;\r\n property HashToRangeFunction: TJclHashToRangeFunction read FHashToRangeFunction write FHashToRangeFunction;\r\n { IJclPackable }\r\n procedure Pack; override;\r\n procedure SetCapacity(Value: Integer); override;\r\n { IJclIntfDoubleMap }\r\n procedure Clear;\r\n function ContainsKey(const Key: IInterface): Boolean;\r\n function ContainsValue(const Value: Double): Boolean;\r\n function Extract(const Key: IInterface): Double;\r\n function GetValue(const Key: IInterface): Double;\r\n function IsEmpty: Boolean;\r\n function KeyOfValue(const Value: Double): IInterface;\r\n function KeySet: IJclIntfSet;\r\n function MapEquals(const AMap: IJclIntfDoubleMap): Boolean;\r\n procedure PutAll(const AMap: IJclIntfDoubleMap);\r\n procedure PutValue(const Key: IInterface; const Value: Double);\r\n function Remove(const Key: IInterface): Double;\r\n function Size: Integer;\r\n function Values: IJclDoubleCollection;\r\n end;\r\n\r\n TJclDoubleDoubleHashMapEntry = record\r\n Key: Double;\r\n Value: Double;\r\n end;\r\n\r\n TJclDoubleDoubleHashMapEntryArray = array of TJclDoubleDoubleHashMapEntry;\r\n\r\n TJclDoubleDoubleHashMapBucket = class\r\n public\r\n Size: Integer;\r\n Entries: TJclDoubleDoubleHashMapEntryArray;\r\n procedure InitializeArrayAfterMove(var List: TJclDoubleDoubleHashMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\n {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\n procedure MoveArray(var List: TJclDoubleDoubleHashMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\n end;\r\n\r\n TJclDoubleDoubleHashMap = class(TJclDoubleAbstractContainer, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclIntfCloneable, IJclCloneable, IJclGrowable, IJclPackable, IJclBaseContainer, IJclDoubleContainer,\r\n IJclDoubleDoubleMap)\r\n protected\r\n function CreateEmptyContainer: TJclAbstractContainerBase; override;\r\n function FreeKey(var Key: Double): Double;\r\n function FreeValue(var Value: Double): Double;\r\n function KeysEqual(const A, B: Double): Boolean;\r\n function ValuesEqual(const A, B: Double): Boolean;\r\n private\r\n FBuckets: array of TJclDoubleDoubleHashMapBucket;\r\n FHashToRangeFunction: TJclHashToRangeFunction;\r\n protected\r\n procedure AssignDataTo(Dest: TJclAbstractContainerBase); override;\r\n procedure AssignPropertiesTo(Dest: TJclAbstractContainerBase); override;\r\n public\r\n constructor Create(ACapacity: Integer);\r\n destructor Destroy; override;\r\n property HashToRangeFunction: TJclHashToRangeFunction read FHashToRangeFunction write FHashToRangeFunction;\r\n { IJclPackable }\r\n procedure Pack; override;\r\n procedure SetCapacity(Value: Integer); override;\r\n { IJclDoubleDoubleMap }\r\n procedure Clear;\r\n function ContainsKey(const Key: Double): Boolean;\r\n function ContainsValue(const Value: Double): Boolean;\r\n function Extract(const Key: Double): Double;\r\n function GetValue(const Key: Double): Double;\r\n function IsEmpty: Boolean;\r\n function KeyOfValue(const Value: Double): Double;\r\n function KeySet: IJclDoubleSet;\r\n function MapEquals(const AMap: IJclDoubleDoubleMap): Boolean;\r\n procedure PutAll(const AMap: IJclDoubleDoubleMap);\r\n procedure PutValue(const Key: Double; const Value: Double);\r\n function Remove(const Key: Double): Double;\r\n function Size: Integer;\r\n function Values: IJclDoubleCollection;\r\n end;\r\n\r\n TJclExtendedIntfHashMapEntry = record\r\n Key: Extended;\r\n Value: IInterface;\r\n end;\r\n\r\n TJclExtendedIntfHashMapEntryArray = array of TJclExtendedIntfHashMapEntry;\r\n\r\n TJclExtendedIntfHashMapBucket = class\r\n public\r\n Size: Integer;\r\n Entries: TJclExtendedIntfHashMapEntryArray;\r\n procedure FinalizeArrayBeforeMove(var List: TJclExtendedIntfHashMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\n {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\n procedure InitializeArray(var List: TJclExtendedIntfHashMapEntryArray; FromIndex, Count: SizeInt);\r\n {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\n procedure InitializeArrayAfterMove(var List: TJclExtendedIntfHashMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\n {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\n\r\n procedure MoveArray(var List: TJclExtendedIntfHashMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\n end;\r\n\r\n TJclExtendedIntfHashMap = class(TJclExtendedAbstractContainer, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclIntfCloneable, IJclCloneable, IJclGrowable, IJclPackable, IJclBaseContainer, IJclExtendedContainer, IJclIntfContainer,\r\n IJclExtendedIntfMap)\r\n protected\r\n function CreateEmptyContainer: TJclAbstractContainerBase; override;\r\n function FreeKey(var Key: Extended): Extended;\r\n function FreeValue(var Value: IInterface): IInterface;\r\n function KeysEqual(const A, B: Extended): Boolean;\r\n function ValuesEqual(const A, B: IInterface): Boolean;\r\n private\r\n FBuckets: array of TJclExtendedIntfHashMapBucket;\r\n FHashToRangeFunction: TJclHashToRangeFunction;\r\n protected\r\n procedure AssignDataTo(Dest: TJclAbstractContainerBase); override;\r\n procedure AssignPropertiesTo(Dest: TJclAbstractContainerBase); override;\r\n public\r\n constructor Create(ACapacity: Integer);\r\n destructor Destroy; override;\r\n property HashToRangeFunction: TJclHashToRangeFunction read FHashToRangeFunction write FHashToRangeFunction;\r\n { IJclPackable }\r\n procedure Pack; override;\r\n procedure SetCapacity(Value: Integer); override;\r\n { IJclExtendedIntfMap }\r\n procedure Clear;\r\n function ContainsKey(const Key: Extended): Boolean;\r\n function ContainsValue(const Value: IInterface): Boolean;\r\n function Extract(const Key: Extended): IInterface;\r\n function GetValue(const Key: Extended): IInterface;\r\n function IsEmpty: Boolean;\r\n function KeyOfValue(const Value: IInterface): Extended;\r\n function KeySet: IJclExtendedSet;\r\n function MapEquals(const AMap: IJclExtendedIntfMap): Boolean;\r\n procedure PutAll(const AMap: IJclExtendedIntfMap);\r\n procedure PutValue(const Key: Extended; const Value: IInterface);\r\n function Remove(const Key: Extended): IInterface;\r\n function Size: Integer;\r\n function Values: IJclIntfCollection;\r\n end;\r\n\r\n TJclIntfExtendedHashMapEntry = record\r\n Key: IInterface;\r\n Value: Extended;\r\n end;\r\n\r\n TJclIntfExtendedHashMapEntryArray = array of TJclIntfExtendedHashMapEntry;\r\n\r\n TJclIntfExtendedHashMapBucket = class\r\n public\r\n Size: Integer;\r\n Entries: TJclIntfExtendedHashMapEntryArray;\r\n procedure FinalizeArrayBeforeMove(var List: TJclIntfExtendedHashMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\n {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\n procedure InitializeArray(var List: TJclIntfExtendedHashMapEntryArray; FromIndex, Count: SizeInt);\r\n {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\n procedure InitializeArrayAfterMove(var List: TJclIntfExtendedHashMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\n {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\n\r\n procedure MoveArray(var List: TJclIntfExtendedHashMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\n end;\r\n\r\n TJclIntfExtendedHashMap = class(TJclExtendedAbstractContainer, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclIntfCloneable, IJclCloneable, IJclGrowable, IJclPackable, IJclBaseContainer, IJclIntfContainer, IJclExtendedContainer,\r\n IJclIntfExtendedMap)\r\n protected\r\n function CreateEmptyContainer: TJclAbstractContainerBase; override;\r\n function FreeKey(var Key: IInterface): IInterface;\r\n function FreeValue(var Value: Extended): Extended;\r\n function Hash(const AInterface: IInterface): Integer; reintroduce;\r\n function KeysEqual(const A, B: IInterface): Boolean;\r\n function ValuesEqual(const A, B: Extended): Boolean;\r\n private\r\n FBuckets: array of TJclIntfExtendedHashMapBucket;\r\n FHashToRangeFunction: TJclHashToRangeFunction;\r\n protected\r\n procedure AssignDataTo(Dest: TJclAbstractContainerBase); override;\r\n procedure AssignPropertiesTo(Dest: TJclAbstractContainerBase); override;\r\n public\r\n constructor Create(ACapacity: Integer);\r\n destructor Destroy; override;\r\n property HashToRangeFunction: TJclHashToRangeFunction read FHashToRangeFunction write FHashToRangeFunction;\r\n { IJclPackable }\r\n procedure Pack; override;\r\n procedure SetCapacity(Value: Integer); override;\r\n { IJclIntfExtendedMap }\r\n procedure Clear;\r\n function ContainsKey(const Key: IInterface): Boolean;\r\n function ContainsValue(const Value: Extended): Boolean;\r\n function Extract(const Key: IInterface): Extended;\r\n function GetValue(const Key: IInterface): Extended;\r\n function IsEmpty: Boolean;\r\n function KeyOfValue(const Value: Extended): IInterface;\r\n function KeySet: IJclIntfSet;\r\n function MapEquals(const AMap: IJclIntfExtendedMap): Boolean;\r\n procedure PutAll(const AMap: IJclIntfExtendedMap);\r\n procedure PutValue(const Key: IInterface; const Value: Extended);\r\n function Remove(const Key: IInterface): Extended;\r\n function Size: Integer;\r\n function Values: IJclExtendedCollection;\r\n end;\r\n\r\n TJclExtendedExtendedHashMapEntry = record\r\n Key: Extended;\r\n Value: Extended;\r\n end;\r\n\r\n TJclExtendedExtendedHashMapEntryArray = array of TJclExtendedExtendedHashMapEntry;\r\n\r\n TJclExtendedExtendedHashMapBucket = class\r\n public\r\n Size: Integer;\r\n Entries: TJclExtendedExtendedHashMapEntryArray;\r\n procedure InitializeArrayAfterMove(var List: TJclExtendedExtendedHashMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\n {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\n procedure MoveArray(var List: TJclExtendedExtendedHashMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\n end;\r\n\r\n TJclExtendedExtendedHashMap = class(TJclExtendedAbstractContainer, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclIntfCloneable, IJclCloneable, IJclGrowable, IJclPackable, IJclBaseContainer, IJclExtendedContainer,\r\n IJclExtendedExtendedMap)\r\n protected\r\n function CreateEmptyContainer: TJclAbstractContainerBase; override;\r\n function FreeKey(var Key: Extended): Extended;\r\n function FreeValue(var Value: Extended): Extended;\r\n function KeysEqual(const A, B: Extended): Boolean;\r\n function ValuesEqual(const A, B: Extended): Boolean;\r\n private\r\n FBuckets: array of TJclExtendedExtendedHashMapBucket;\r\n FHashToRangeFunction: TJclHashToRangeFunction;\r\n protected\r\n procedure AssignDataTo(Dest: TJclAbstractContainerBase); override;\r\n procedure AssignPropertiesTo(Dest: TJclAbstractContainerBase); override;\r\n public\r\n constructor Create(ACapacity: Integer);\r\n destructor Destroy; override;\r\n property HashToRangeFunction: TJclHashToRangeFunction read FHashToRangeFunction write FHashToRangeFunction;\r\n { IJclPackable }\r\n procedure Pack; override;\r\n procedure SetCapacity(Value: Integer); override;\r\n { IJclExtendedExtendedMap }\r\n procedure Clear;\r\n function ContainsKey(const Key: Extended): Boolean;\r\n function ContainsValue(const Value: Extended): Boolean;\r\n function Extract(const Key: Extended): Extended;\r\n function GetValue(const Key: Extended): Extended;\r\n function IsEmpty: Boolean;\r\n function KeyOfValue(const Value: Extended): Extended;\r\n function KeySet: IJclExtendedSet;\r\n function MapEquals(const AMap: IJclExtendedExtendedMap): Boolean;\r\n procedure PutAll(const AMap: IJclExtendedExtendedMap);\r\n procedure PutValue(const Key: Extended; const Value: Extended);\r\n function Remove(const Key: Extended): Extended;\r\n function Size: Integer;\r\n function Values: IJclExtendedCollection;\r\n end;\r\n\r\n {$IFDEF MATH_SINGLE_PRECISION}\r\n TJclFloatIntfHashMapEntry = TJclSingleIntfHashMapEntry;\r\n TJclFloatIntfHashMapBucket = TJclSingleIntfHashMapBucket;\r\n {$ENDIF MATH_SINGLE_PRECISION}\r\n {$IFDEF MATH_DOUBLE_PRECISION}\r\n TJclFloatIntfHashMapEntry = TJclDoubleIntfHashMapEntry;\r\n TJclFloatIntfHashMapBucket = TJclDoubleIntfHashMapBucket;\r\n {$ENDIF MATH_DOUBLE_PRECISION}\r\n {$IFDEF MATH_EXTENDED_PRECISION}\r\n TJclFloatIntfHashMapEntry = TJclExtendedIntfHashMapEntry;\r\n TJclFloatIntfHashMapBucket = TJclExtendedIntfHashMapBucket;\r\n {$ENDIF MATH_EXTENDED_PRECISION}\r\n\r\n {$IFDEF MATH_SINGLE_PRECISION}\r\n TJclFloatIntfHashMap = TJclSingleIntfHashMap;\r\n {$ENDIF MATH_SINGLE_PRECISION}\r\n {$IFDEF MATH_DOUBLE_PRECISION}\r\n TJclFloatIntfHashMap = TJclDoubleIntfHashMap;\r\n {$ENDIF MATH_DOUBLE_PRECISION}\r\n {$IFDEF MATH_EXTENDED_PRECISION}\r\n TJclFloatIntfHashMap = TJclExtendedIntfHashMap;\r\n {$ENDIF MATH_EXTENDED_PRECISION}\r\n\r\n {$IFDEF MATH_SINGLE_PRECISION}\r\n TJclIntfFloatHashMapEntry = TJclIntfSingleHashMapEntry;\r\n TJclIntfFloatHashMapBucket = TJclIntfSingleHashMapBucket;\r\n {$ENDIF MATH_SINGLE_PRECISION}\r\n {$IFDEF MATH_DOUBLE_PRECISION}\r\n TJclIntfFloatHashMapEntry = TJclIntfDoubleHashMapEntry;\r\n TJclIntfFloatHashMapBucket = TJclIntfDoubleHashMapBucket;\r\n {$ENDIF MATH_DOUBLE_PRECISION}\r\n {$IFDEF MATH_EXTENDED_PRECISION}\r\n TJclIntfFloatHashMapEntry = TJclIntfExtendedHashMapEntry;\r\n TJclIntfFloatHashMapBucket = TJclIntfExtendedHashMapBucket;\r\n {$ENDIF MATH_EXTENDED_PRECISION}\r\n\r\n {$IFDEF MATH_SINGLE_PRECISION}\r\n TJclIntfFloatHashMap = TJclIntfSingleHashMap;\r\n {$ENDIF MATH_SINGLE_PRECISION}\r\n {$IFDEF MATH_DOUBLE_PRECISION}\r\n TJclIntfFloatHashMap = TJclIntfDoubleHashMap;\r\n {$ENDIF MATH_DOUBLE_PRECISION}\r\n {$IFDEF MATH_EXTENDED_PRECISION}\r\n TJclIntfFloatHashMap = TJclIntfExtendedHashMap;\r\n {$ENDIF MATH_EXTENDED_PRECISION}\r\n\r\n {$IFDEF MATH_SINGLE_PRECISION}\r\n TJclFloatFloatHashMapEntry = TJclSingleSingleHashMapEntry;\r\n TJclFloatFloatHashMapBucket = TJclSingleSingleHashMapBucket;\r\n {$ENDIF MATH_SINGLE_PRECISION}\r\n {$IFDEF MATH_DOUBLE_PRECISION}\r\n TJclFloatFloatHashMapEntry = TJclDoubleDoubleHashMapEntry;\r\n TJclFloatFloatHashMapBucket = TJclDoubleDoubleHashMapBucket;\r\n {$ENDIF MATH_DOUBLE_PRECISION}\r\n {$IFDEF MATH_EXTENDED_PRECISION}\r\n TJclFloatFloatHashMapEntry = TJclExtendedExtendedHashMapEntry;\r\n TJclFloatFloatHashMapBucket = TJclExtendedExtendedHashMapBucket;\r\n {$ENDIF MATH_EXTENDED_PRECISION}\r\n\r\n {$IFDEF MATH_SINGLE_PRECISION}\r\n TJclFloatFloatHashMap = TJclSingleSingleHashMap;\r\n {$ENDIF MATH_SINGLE_PRECISION}\r\n {$IFDEF MATH_DOUBLE_PRECISION}\r\n TJclFloatFloatHashMap = TJclDoubleDoubleHashMap;\r\n {$ENDIF MATH_DOUBLE_PRECISION}\r\n {$IFDEF MATH_EXTENDED_PRECISION}\r\n TJclFloatFloatHashMap = TJclExtendedExtendedHashMap;\r\n {$ENDIF MATH_EXTENDED_PRECISION}\r\n\r\n TJclIntegerIntfHashMapEntry = record\r\n Key: Integer;\r\n Value: IInterface;\r\n end;\r\n\r\n TJclIntegerIntfHashMapEntryArray = array of TJclIntegerIntfHashMapEntry;\r\n\r\n TJclIntegerIntfHashMapBucket = class\r\n public\r\n Size: Integer;\r\n Entries: TJclIntegerIntfHashMapEntryArray;\r\n procedure FinalizeArrayBeforeMove(var List: TJclIntegerIntfHashMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\n {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\n procedure InitializeArray(var List: TJclIntegerIntfHashMapEntryArray; FromIndex, Count: SizeInt);\r\n {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\n procedure InitializeArrayAfterMove(var List: TJclIntegerIntfHashMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\n {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\n\r\n procedure MoveArray(var List: TJclIntegerIntfHashMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\n end;\r\n\r\n TJclIntegerIntfHashMap = class(TJclIntegerAbstractContainer, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclIntfCloneable, IJclCloneable, IJclGrowable, IJclPackable, IJclBaseContainer, IJclIntegerContainer, IJclIntfContainer,\r\n IJclIntegerIntfMap)\r\n protected\r\n function CreateEmptyContainer: TJclAbstractContainerBase; override;\r\n function FreeKey(var Key: Integer): Integer;\r\n function FreeValue(var Value: IInterface): IInterface;\r\n function KeysEqual(A, B: Integer): Boolean;\r\n function ValuesEqual(const A, B: IInterface): Boolean;\r\n private\r\n FBuckets: array of TJclIntegerIntfHashMapBucket;\r\n FHashToRangeFunction: TJclHashToRangeFunction;\r\n protected\r\n procedure AssignDataTo(Dest: TJclAbstractContainerBase); override;\r\n procedure AssignPropertiesTo(Dest: TJclAbstractContainerBase); override;\r\n public\r\n constructor Create(ACapacity: Integer);\r\n destructor Destroy; override;\r\n property HashToRangeFunction: TJclHashToRangeFunction read FHashToRangeFunction write FHashToRangeFunction;\r\n { IJclPackable }\r\n procedure Pack; override;\r\n procedure SetCapacity(Value: Integer); override;\r\n { IJclIntegerIntfMap }\r\n procedure Clear;\r\n function ContainsKey(Key: Integer): Boolean;\r\n function ContainsValue(const Value: IInterface): Boolean;\r\n function Extract(Key: Integer): IInterface;\r\n function GetValue(Key: Integer): IInterface;\r\n function IsEmpty: Boolean;\r\n function KeyOfValue(const Value: IInterface): Integer;\r\n function KeySet: IJclIntegerSet;\r\n function MapEquals(const AMap: IJclIntegerIntfMap): Boolean;\r\n procedure PutAll(const AMap: IJclIntegerIntfMap);\r\n procedure PutValue(Key: Integer; const Value: IInterface);\r\n function Remove(Key: Integer): IInterface;\r\n function Size: Integer;\r\n function Values: IJclIntfCollection;\r\n end;\r\n\r\n TJclIntfIntegerHashMapEntry = record\r\n Key: IInterface;\r\n Value: Integer;\r\n end;\r\n\r\n TJclIntfIntegerHashMapEntryArray = array of TJclIntfIntegerHashMapEntry;\r\n\r\n TJclIntfIntegerHashMapBucket = class\r\n public\r\n Size: Integer;\r\n Entries: TJclIntfIntegerHashMapEntryArray;\r\n procedure FinalizeArrayBeforeMove(var List: TJclIntfIntegerHashMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\n {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\n procedure InitializeArray(var List: TJclIntfIntegerHashMapEntryArray; FromIndex, Count: SizeInt);\r\n {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\n procedure InitializeArrayAfterMove(var List: TJclIntfIntegerHashMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\n {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\n\r\n procedure MoveArray(var List: TJclIntfIntegerHashMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\n end;\r\n\r\n TJclIntfIntegerHashMap = class(TJclIntegerAbstractContainer, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclIntfCloneable, IJclCloneable, IJclGrowable, IJclPackable, IJclBaseContainer, IJclIntfContainer, IJclIntegerContainer,\r\n IJclIntfIntegerMap)\r\n protected\r\n function CreateEmptyContainer: TJclAbstractContainerBase; override;\r\n function FreeKey(var Key: IInterface): IInterface;\r\n function FreeValue(var Value: Integer): Integer;\r\n function Hash(const AInterface: IInterface): Integer; reintroduce;\r\n function KeysEqual(const A, B: IInterface): Boolean;\r\n function ValuesEqual(A, B: Integer): Boolean;\r\n private\r\n FBuckets: array of TJclIntfIntegerHashMapBucket;\r\n FHashToRangeFunction: TJclHashToRangeFunction;\r\n protected\r\n procedure AssignDataTo(Dest: TJclAbstractContainerBase); override;\r\n procedure AssignPropertiesTo(Dest: TJclAbstractContainerBase); override;\r\n public\r\n constructor Create(ACapacity: Integer);\r\n destructor Destroy; override;\r\n property HashToRangeFunction: TJclHashToRangeFunction read FHashToRangeFunction write FHashToRangeFunction;\r\n { IJclPackable }\r\n procedure Pack; override;\r\n procedure SetCapacity(Value: Integer); override;\r\n { IJclIntfIntegerMap }\r\n procedure Clear;\r\n function ContainsKey(const Key: IInterface): Boolean;\r\n function ContainsValue(Value: Integer): Boolean;\r\n function Extract(const Key: IInterface): Integer;\r\n function GetValue(const Key: IInterface): Integer;\r\n function IsEmpty: Boolean;\r\n function KeyOfValue(Value: Integer): IInterface;\r\n function KeySet: IJclIntfSet;\r\n function MapEquals(const AMap: IJclIntfIntegerMap): Boolean;\r\n procedure PutAll(const AMap: IJclIntfIntegerMap);\r\n procedure PutValue(const Key: IInterface; Value: Integer);\r\n function Remove(const Key: IInterface): Integer;\r\n function Size: Integer;\r\n function Values: IJclIntegerCollection;\r\n end;\r\n\r\n TJclIntegerIntegerHashMapEntry = record\r\n Key: Integer;\r\n Value: Integer;\r\n end;\r\n\r\n TJclIntegerIntegerHashMapEntryArray = array of TJclIntegerIntegerHashMapEntry;\r\n\r\n TJclIntegerIntegerHashMapBucket = class\r\n public\r\n Size: Integer;\r\n Entries: TJclIntegerIntegerHashMapEntryArray;\r\n procedure InitializeArrayAfterMove(var List: TJclIntegerIntegerHashMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\n {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\n procedure MoveArray(var List: TJclIntegerIntegerHashMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\n end;\r\n\r\n TJclIntegerIntegerHashMap = class(TJclIntegerAbstractContainer, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclIntfCloneable, IJclCloneable, IJclGrowable, IJclPackable, IJclBaseContainer, IJclIntegerContainer,\r\n IJclIntegerIntegerMap)\r\n protected\r\n function CreateEmptyContainer: TJclAbstractContainerBase; override;\r\n function FreeKey(var Key: Integer): Integer;\r\n function FreeValue(var Value: Integer): Integer;\r\n function KeysEqual(A, B: Integer): Boolean;\r\n function ValuesEqual(A, B: Integer): Boolean;\r\n private\r\n FBuckets: array of TJclIntegerIntegerHashMapBucket;\r\n FHashToRangeFunction: TJclHashToRangeFunction;\r\n protected\r\n procedure AssignDataTo(Dest: TJclAbstractContainerBase); override;\r\n procedure AssignPropertiesTo(Dest: TJclAbstractContainerBase); override;\r\n public\r\n constructor Create(ACapacity: Integer);\r\n destructor Destroy; override;\r\n property HashToRangeFunction: TJclHashToRangeFunction read FHashToRangeFunction write FHashToRangeFunction;\r\n { IJclPackable }\r\n procedure Pack; override;\r\n procedure SetCapacity(Value: Integer); override;\r\n { IJclIntegerIntegerMap }\r\n procedure Clear;\r\n function ContainsKey(Key: Integer): Boolean;\r\n function ContainsValue(Value: Integer): Boolean;\r\n function Extract(Key: Integer): Integer;\r\n function GetValue(Key: Integer): Integer;\r\n function IsEmpty: Boolean;\r\n function KeyOfValue(Value: Integer): Integer;\r\n function KeySet: IJclIntegerSet;\r\n function MapEquals(const AMap: IJclIntegerIntegerMap): Boolean;\r\n procedure PutAll(const AMap: IJclIntegerIntegerMap);\r\n procedure PutValue(Key: Integer; Value: Integer);\r\n function Remove(Key: Integer): Integer;\r\n function Size: Integer;\r\n function Values: IJclIntegerCollection;\r\n end;\r\n\r\n TJclCardinalIntfHashMapEntry = record\r\n Key: Cardinal;\r\n Value: IInterface;\r\n end;\r\n\r\n TJclCardinalIntfHashMapEntryArray = array of TJclCardinalIntfHashMapEntry;\r\n\r\n TJclCardinalIntfHashMapBucket = class\r\n public\r\n Size: Integer;\r\n Entries: TJclCardinalIntfHashMapEntryArray;\r\n procedure FinalizeArrayBeforeMove(var List: TJclCardinalIntfHashMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\n {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\n procedure InitializeArray(var List: TJclCardinalIntfHashMapEntryArray; FromIndex, Count: SizeInt);\r\n {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\n procedure InitializeArrayAfterMove(var List: TJclCardinalIntfHashMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\n {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\n\r\n procedure MoveArray(var List: TJclCardinalIntfHashMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\n end;\r\n\r\n TJclCardinalIntfHashMap = class(TJclCardinalAbstractContainer, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclIntfCloneable, IJclCloneable, IJclGrowable, IJclPackable, IJclBaseContainer, IJclCardinalContainer, IJclIntfContainer,\r\n IJclCardinalIntfMap)\r\n protected\r\n function CreateEmptyContainer: TJclAbstractContainerBase; override;\r\n function FreeKey(var Key: Cardinal): Cardinal;\r\n function FreeValue(var Value: IInterface): IInterface;\r\n function KeysEqual(A, B: Cardinal): Boolean;\r\n function ValuesEqual(const A, B: IInterface): Boolean;\r\n private\r\n FBuckets: array of TJclCardinalIntfHashMapBucket;\r\n FHashToRangeFunction: TJclHashToRangeFunction;\r\n protected\r\n procedure AssignDataTo(Dest: TJclAbstractContainerBase); override;\r\n procedure AssignPropertiesTo(Dest: TJclAbstractContainerBase); override;\r\n public\r\n constructor Create(ACapacity: Integer);\r\n destructor Destroy; override;\r\n property HashToRangeFunction: TJclHashToRangeFunction read FHashToRangeFunction write FHashToRangeFunction;\r\n { IJclPackable }\r\n procedure Pack; override;\r\n procedure SetCapacity(Value: Integer); override;\r\n { IJclCardinalIntfMap }\r\n procedure Clear;\r\n function ContainsKey(Key: Cardinal): Boolean;\r\n function ContainsValue(const Value: IInterface): Boolean;\r\n function Extract(Key: Cardinal): IInterface;\r\n function GetValue(Key: Cardinal): IInterface;\r\n function IsEmpty: Boolean;\r\n function KeyOfValue(const Value: IInterface): Cardinal;\r\n function KeySet: IJclCardinalSet;\r\n function MapEquals(const AMap: IJclCardinalIntfMap): Boolean;\r\n procedure PutAll(const AMap: IJclCardinalIntfMap);\r\n procedure PutValue(Key: Cardinal; const Value: IInterface);\r\n function Remove(Key: Cardinal): IInterface;\r\n function Size: Integer;\r\n function Values: IJclIntfCollection;\r\n end;\r\n\r\n TJclIntfCardinalHashMapEntry = record\r\n Key: IInterface;\r\n Value: Cardinal;\r\n end;\r\n\r\n TJclIntfCardinalHashMapEntryArray = array of TJclIntfCardinalHashMapEntry;\r\n\r\n TJclIntfCardinalHashMapBucket = class\r\n public\r\n Size: Integer;\r\n Entries: TJclIntfCardinalHashMapEntryArray;\r\n procedure FinalizeArrayBeforeMove(var List: TJclIntfCardinalHashMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\n {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\n procedure InitializeArray(var List: TJclIntfCardinalHashMapEntryArray; FromIndex, Count: SizeInt);\r\n {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\n procedure InitializeArrayAfterMove(var List: TJclIntfCardinalHashMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\n {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\n\r\n procedure MoveArray(var List: TJclIntfCardinalHashMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\n end;\r\n\r\n TJclIntfCardinalHashMap = class(TJclCardinalAbstractContainer, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclIntfCloneable, IJclCloneable, IJclGrowable, IJclPackable, IJclBaseContainer, IJclIntfContainer, IJclCardinalContainer,\r\n IJclIntfCardinalMap)\r\n protected\r\n function CreateEmptyContainer: TJclAbstractContainerBase; override;\r\n function FreeKey(var Key: IInterface): IInterface;\r\n function FreeValue(var Value: Cardinal): Cardinal;\r\n function Hash(const AInterface: IInterface): Integer; reintroduce;\r\n function KeysEqual(const A, B: IInterface): Boolean;\r\n function ValuesEqual(A, B: Cardinal): Boolean;\r\n private\r\n FBuckets: array of TJclIntfCardinalHashMapBucket;\r\n FHashToRangeFunction: TJclHashToRangeFunction;\r\n protected\r\n procedure AssignDataTo(Dest: TJclAbstractContainerBase); override;\r\n procedure AssignPropertiesTo(Dest: TJclAbstractContainerBase); override;\r\n public\r\n constructor Create(ACapacity: Integer);\r\n destructor Destroy; override;\r\n property HashToRangeFunction: TJclHashToRangeFunction read FHashToRangeFunction write FHashToRangeFunction;\r\n { IJclPackable }\r\n procedure Pack; override;\r\n procedure SetCapacity(Value: Integer); override;\r\n { IJclIntfCardinalMap }\r\n procedure Clear;\r\n function ContainsKey(const Key: IInterface): Boolean;\r\n function ContainsValue(Value: Cardinal): Boolean;\r\n function Extract(const Key: IInterface): Cardinal;\r\n function GetValue(const Key: IInterface): Cardinal;\r\n function IsEmpty: Boolean;\r\n function KeyOfValue(Value: Cardinal): IInterface;\r\n function KeySet: IJclIntfSet;\r\n function MapEquals(const AMap: IJclIntfCardinalMap): Boolean;\r\n procedure PutAll(const AMap: IJclIntfCardinalMap);\r\n procedure PutValue(const Key: IInterface; Value: Cardinal);\r\n function Remove(const Key: IInterface): Cardinal;\r\n function Size: Integer;\r\n function Values: IJclCardinalCollection;\r\n end;\r\n\r\n TJclCardinalCardinalHashMapEntry = record\r\n Key: Cardinal;\r\n Value: Cardinal;\r\n end;\r\n\r\n TJclCardinalCardinalHashMapEntryArray = array of TJclCardinalCardinalHashMapEntry;\r\n\r\n TJclCardinalCardinalHashMapBucket = class\r\n public\r\n Size: Integer;\r\n Entries: TJclCardinalCardinalHashMapEntryArray;\r\n procedure InitializeArrayAfterMove(var List: TJclCardinalCardinalHashMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\n {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\n procedure MoveArray(var List: TJclCardinalCardinalHashMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\n end;\r\n\r\n TJclCardinalCardinalHashMap = class(TJclCardinalAbstractContainer, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclIntfCloneable, IJclCloneable, IJclGrowable, IJclPackable, IJclBaseContainer, IJclCardinalContainer,\r\n IJclCardinalCardinalMap)\r\n protected\r\n function CreateEmptyContainer: TJclAbstractContainerBase; override;\r\n function FreeKey(var Key: Cardinal): Cardinal;\r\n function FreeValue(var Value: Cardinal): Cardinal;\r\n function KeysEqual(A, B: Cardinal): Boolean;\r\n function ValuesEqual(A, B: Cardinal): Boolean;\r\n private\r\n FBuckets: array of TJclCardinalCardinalHashMapBucket;\r\n FHashToRangeFunction: TJclHashToRangeFunction;\r\n protected\r\n procedure AssignDataTo(Dest: TJclAbstractContainerBase); override;\r\n procedure AssignPropertiesTo(Dest: TJclAbstractContainerBase); override;\r\n public\r\n constructor Create(ACapacity: Integer);\r\n destructor Destroy; override;\r\n property HashToRangeFunction: TJclHashToRangeFunction read FHashToRangeFunction write FHashToRangeFunction;\r\n { IJclPackable }\r\n procedure Pack; override;\r\n procedure SetCapacity(Value: Integer); override;\r\n { IJclCardinalCardinalMap }\r\n procedure Clear;\r\n function ContainsKey(Key: Cardinal): Boolean;\r\n function ContainsValue(Value: Cardinal): Boolean;\r\n function Extract(Key: Cardinal): Cardinal;\r\n function GetValue(Key: Cardinal): Cardinal;\r\n function IsEmpty: Boolean;\r\n function KeyOfValue(Value: Cardinal): Cardinal;\r\n function KeySet: IJclCardinalSet;\r\n function MapEquals(const AMap: IJclCardinalCardinalMap): Boolean;\r\n procedure PutAll(const AMap: IJclCardinalCardinalMap);\r\n procedure PutValue(Key: Cardinal; Value: Cardinal);\r\n function Remove(Key: Cardinal): Cardinal;\r\n function Size: Integer;\r\n function Values: IJclCardinalCollection;\r\n end;\r\n\r\n TJclInt64IntfHashMapEntry = record\r\n Key: Int64;\r\n Value: IInterface;\r\n end;\r\n\r\n TJclInt64IntfHashMapEntryArray = array of TJclInt64IntfHashMapEntry;\r\n\r\n TJclInt64IntfHashMapBucket = class\r\n public\r\n Size: Integer;\r\n Entries: TJclInt64IntfHashMapEntryArray;\r\n procedure FinalizeArrayBeforeMove(var List: TJclInt64IntfHashMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\n {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\n procedure InitializeArray(var List: TJclInt64IntfHashMapEntryArray; FromIndex, Count: SizeInt);\r\n {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\n procedure InitializeArrayAfterMove(var List: TJclInt64IntfHashMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\n {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\n\r\n procedure MoveArray(var List: TJclInt64IntfHashMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\n end;\r\n\r\n TJclInt64IntfHashMap = class(TJclInt64AbstractContainer, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclIntfCloneable, IJclCloneable, IJclGrowable, IJclPackable, IJclBaseContainer, IJclInt64Container, IJclIntfContainer,\r\n IJclInt64IntfMap)\r\n protected\r\n function CreateEmptyContainer: TJclAbstractContainerBase; override;\r\n function FreeKey(var Key: Int64): Int64;\r\n function FreeValue(var Value: IInterface): IInterface;\r\n function KeysEqual(const A, B: Int64): Boolean;\r\n function ValuesEqual(const A, B: IInterface): Boolean;\r\n private\r\n FBuckets: array of TJclInt64IntfHashMapBucket;\r\n FHashToRangeFunction: TJclHashToRangeFunction;\r\n protected\r\n procedure AssignDataTo(Dest: TJclAbstractContainerBase); override;\r\n procedure AssignPropertiesTo(Dest: TJclAbstractContainerBase); override;\r\n public\r\n constructor Create(ACapacity: Integer);\r\n destructor Destroy; override;\r\n property HashToRangeFunction: TJclHashToRangeFunction read FHashToRangeFunction write FHashToRangeFunction;\r\n { IJclPackable }\r\n procedure Pack; override;\r\n procedure SetCapacity(Value: Integer); override;\r\n { IJclInt64IntfMap }\r\n procedure Clear;\r\n function ContainsKey(const Key: Int64): Boolean;\r\n function ContainsValue(const Value: IInterface): Boolean;\r\n function Extract(const Key: Int64): IInterface;\r\n function GetValue(const Key: Int64): IInterface;\r\n function IsEmpty: Boolean;\r\n function KeyOfValue(const Value: IInterface): Int64;\r\n function KeySet: IJclInt64Set;\r\n function MapEquals(const AMap: IJclInt64IntfMap): Boolean;\r\n procedure PutAll(const AMap: IJclInt64IntfMap);\r\n procedure PutValue(const Key: Int64; const Value: IInterface);\r\n function Remove(const Key: Int64): IInterface;\r\n function Size: Integer;\r\n function Values: IJclIntfCollection;\r\n end;\r\n\r\n TJclIntfInt64HashMapEntry = record\r\n Key: IInterface;\r\n Value: Int64;\r\n end;\r\n\r\n TJclIntfInt64HashMapEntryArray = array of TJclIntfInt64HashMapEntry;\r\n\r\n TJclIntfInt64HashMapBucket = class\r\n public\r\n Size: Integer;\r\n Entries: TJclIntfInt64HashMapEntryArray;\r\n procedure FinalizeArrayBeforeMove(var List: TJclIntfInt64HashMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\n {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\n procedure InitializeArray(var List: TJclIntfInt64HashMapEntryArray; FromIndex, Count: SizeInt);\r\n {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\n procedure InitializeArrayAfterMove(var List: TJclIntfInt64HashMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\n {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\n\r\n procedure MoveArray(var List: TJclIntfInt64HashMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\n end;\r\n\r\n TJclIntfInt64HashMap = class(TJclInt64AbstractContainer, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclIntfCloneable, IJclCloneable, IJclGrowable, IJclPackable, IJclBaseContainer, IJclIntfContainer, IJclInt64Container,\r\n IJclIntfInt64Map)\r\n protected\r\n function CreateEmptyContainer: TJclAbstractContainerBase; override;\r\n function FreeKey(var Key: IInterface): IInterface;\r\n function FreeValue(var Value: Int64): Int64;\r\n function Hash(const AInterface: IInterface): Integer; reintroduce;\r\n function KeysEqual(const A, B: IInterface): Boolean;\r\n function ValuesEqual(const A, B: Int64): Boolean;\r\n private\r\n FBuckets: array of TJclIntfInt64HashMapBucket;\r\n FHashToRangeFunction: TJclHashToRangeFunction;\r\n protected\r\n procedure AssignDataTo(Dest: TJclAbstractContainerBase); override;\r\n procedure AssignPropertiesTo(Dest: TJclAbstractContainerBase); override;\r\n public\r\n constructor Create(ACapacity: Integer);\r\n destructor Destroy; override;\r\n property HashToRangeFunction: TJclHashToRangeFunction read FHashToRangeFunction write FHashToRangeFunction;\r\n { IJclPackable }\r\n procedure Pack; override;\r\n procedure SetCapacity(Value: Integer); override;\r\n { IJclIntfInt64Map }\r\n procedure Clear;\r\n function ContainsKey(const Key: IInterface): Boolean;\r\n function ContainsValue(const Value: Int64): Boolean;\r\n function Extract(const Key: IInterface): Int64;\r\n function GetValue(const Key: IInterface): Int64;\r\n function IsEmpty: Boolean;\r\n function KeyOfValue(const Value: Int64): IInterface;\r\n function KeySet: IJclIntfSet;\r\n function MapEquals(const AMap: IJclIntfInt64Map): Boolean;\r\n procedure PutAll(const AMap: IJclIntfInt64Map);\r\n procedure PutValue(const Key: IInterface; const Value: Int64);\r\n function Remove(const Key: IInterface): Int64;\r\n function Size: Integer;\r\n function Values: IJclInt64Collection;\r\n end;\r\n\r\n TJclInt64Int64HashMapEntry = record\r\n Key: Int64;\r\n Value: Int64;\r\n end;\r\n\r\n TJclInt64Int64HashMapEntryArray = array of TJclInt64Int64HashMapEntry;\r\n\r\n TJclInt64Int64HashMapBucket = class\r\n public\r\n Size: Integer;\r\n Entries: TJclInt64Int64HashMapEntryArray;\r\n procedure InitializeArrayAfterMove(var List: TJclInt64Int64HashMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\n {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\n procedure MoveArray(var List: TJclInt64Int64HashMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\n end;\r\n\r\n TJclInt64Int64HashMap = class(TJclInt64AbstractContainer, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclIntfCloneable, IJclCloneable, IJclGrowable, IJclPackable, IJclBaseContainer, IJclInt64Container,\r\n IJclInt64Int64Map)\r\n protected\r\n function CreateEmptyContainer: TJclAbstractContainerBase; override;\r\n function FreeKey(var Key: Int64): Int64;\r\n function FreeValue(var Value: Int64): Int64;\r\n function KeysEqual(const A, B: Int64): Boolean;\r\n function ValuesEqual(const A, B: Int64): Boolean;\r\n private\r\n FBuckets: array of TJclInt64Int64HashMapBucket;\r\n FHashToRangeFunction: TJclHashToRangeFunction;\r\n protected\r\n procedure AssignDataTo(Dest: TJclAbstractContainerBase); override;\r\n procedure AssignPropertiesTo(Dest: TJclAbstractContainerBase); override;\r\n public\r\n constructor Create(ACapacity: Integer);\r\n destructor Destroy; override;\r\n property HashToRangeFunction: TJclHashToRangeFunction read FHashToRangeFunction write FHashToRangeFunction;\r\n { IJclPackable }\r\n procedure Pack; override;\r\n procedure SetCapacity(Value: Integer); override;\r\n { IJclInt64Int64Map }\r\n procedure Clear;\r\n function ContainsKey(const Key: Int64): Boolean;\r\n function ContainsValue(const Value: Int64): Boolean;\r\n function Extract(const Key: Int64): Int64;\r\n function GetValue(const Key: Int64): Int64;\r\n function IsEmpty: Boolean;\r\n function KeyOfValue(const Value: Int64): Int64;\r\n function KeySet: IJclInt64Set;\r\n function MapEquals(const AMap: IJclInt64Int64Map): Boolean;\r\n procedure PutAll(const AMap: IJclInt64Int64Map);\r\n procedure PutValue(const Key: Int64; const Value: Int64);\r\n function Remove(const Key: Int64): Int64;\r\n function Size: Integer;\r\n function Values: IJclInt64Collection;\r\n end;\r\n\r\n TJclPtrIntfHashMapEntry = record\r\n Key: Pointer;\r\n Value: IInterface;\r\n end;\r\n\r\n TJclPtrIntfHashMapEntryArray = array of TJclPtrIntfHashMapEntry;\r\n\r\n TJclPtrIntfHashMapBucket = class\r\n public\r\n Size: Integer;\r\n Entries: TJclPtrIntfHashMapEntryArray;\r\n procedure FinalizeArrayBeforeMove(var List: TJclPtrIntfHashMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\n {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\n procedure InitializeArray(var List: TJclPtrIntfHashMapEntryArray; FromIndex, Count: SizeInt);\r\n {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\n procedure InitializeArrayAfterMove(var List: TJclPtrIntfHashMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\n {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\n\r\n procedure MoveArray(var List: TJclPtrIntfHashMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\n end;\r\n\r\n TJclPtrIntfHashMap = class(TJclPtrAbstractContainer, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclIntfCloneable, IJclCloneable, IJclGrowable, IJclPackable, IJclBaseContainer, IJclPtrContainer, IJclIntfContainer,\r\n IJclPtrIntfMap)\r\n protected\r\n function CreateEmptyContainer: TJclAbstractContainerBase; override;\r\n function FreeKey(var Key: Pointer): Pointer;\r\n function FreeValue(var Value: IInterface): IInterface;\r\n function KeysEqual(A, B: Pointer): Boolean;\r\n function ValuesEqual(const A, B: IInterface): Boolean;\r\n private\r\n FBuckets: array of TJclPtrIntfHashMapBucket;\r\n FHashToRangeFunction: TJclHashToRangeFunction;\r\n protected\r\n procedure AssignDataTo(Dest: TJclAbstractContainerBase); override;\r\n procedure AssignPropertiesTo(Dest: TJclAbstractContainerBase); override;\r\n public\r\n constructor Create(ACapacity: Integer);\r\n destructor Destroy; override;\r\n property HashToRangeFunction: TJclHashToRangeFunction read FHashToRangeFunction write FHashToRangeFunction;\r\n { IJclPackable }\r\n procedure Pack; override;\r\n procedure SetCapacity(Value: Integer); override;\r\n { IJclPtrIntfMap }\r\n procedure Clear;\r\n function ContainsKey(Key: Pointer): Boolean;\r\n function ContainsValue(const Value: IInterface): Boolean;\r\n function Extract(Key: Pointer): IInterface;\r\n function GetValue(Key: Pointer): IInterface;\r\n function IsEmpty: Boolean;\r\n function KeyOfValue(const Value: IInterface): Pointer;\r\n function KeySet: IJclPtrSet;\r\n function MapEquals(const AMap: IJclPtrIntfMap): Boolean;\r\n procedure PutAll(const AMap: IJclPtrIntfMap);\r\n procedure PutValue(Key: Pointer; const Value: IInterface);\r\n function Remove(Key: Pointer): IInterface;\r\n function Size: Integer;\r\n function Values: IJclIntfCollection;\r\n end;\r\n\r\n TJclIntfPtrHashMapEntry = record\r\n Key: IInterface;\r\n Value: Pointer;\r\n end;\r\n\r\n TJclIntfPtrHashMapEntryArray = array of TJclIntfPtrHashMapEntry;\r\n\r\n TJclIntfPtrHashMapBucket = class\r\n public\r\n Size: Integer;\r\n Entries: TJclIntfPtrHashMapEntryArray;\r\n procedure FinalizeArrayBeforeMove(var List: TJclIntfPtrHashMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\n {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\n procedure InitializeArray(var List: TJclIntfPtrHashMapEntryArray; FromIndex, Count: SizeInt);\r\n {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\n procedure InitializeArrayAfterMove(var List: TJclIntfPtrHashMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\n {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\n\r\n procedure MoveArray(var List: TJclIntfPtrHashMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\n end;\r\n\r\n TJclIntfPtrHashMap = class(TJclPtrAbstractContainer, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclIntfCloneable, IJclCloneable, IJclGrowable, IJclPackable, IJclBaseContainer, IJclIntfContainer, IJclPtrContainer,\r\n IJclIntfPtrMap)\r\n protected\r\n function CreateEmptyContainer: TJclAbstractContainerBase; override;\r\n function FreeKey(var Key: IInterface): IInterface;\r\n function FreeValue(var Value: Pointer): Pointer;\r\n function Hash(const AInterface: IInterface): Integer; reintroduce;\r\n function KeysEqual(const A, B: IInterface): Boolean;\r\n function ValuesEqual(A, B: Pointer): Boolean;\r\n private\r\n FBuckets: array of TJclIntfPtrHashMapBucket;\r\n FHashToRangeFunction: TJclHashToRangeFunction;\r\n protected\r\n procedure AssignDataTo(Dest: TJclAbstractContainerBase); override;\r\n procedure AssignPropertiesTo(Dest: TJclAbstractContainerBase); override;\r\n public\r\n constructor Create(ACapacity: Integer);\r\n destructor Destroy; override;\r\n property HashToRangeFunction: TJclHashToRangeFunction read FHashToRangeFunction write FHashToRangeFunction;\r\n { IJclPackable }\r\n procedure Pack; override;\r\n procedure SetCapacity(Value: Integer); override;\r\n { IJclIntfPtrMap }\r\n procedure Clear;\r\n function ContainsKey(const Key: IInterface): Boolean;\r\n function ContainsValue(Value: Pointer): Boolean;\r\n function Extract(const Key: IInterface): Pointer;\r\n function GetValue(const Key: IInterface): Pointer;\r\n function IsEmpty: Boolean;\r\n function KeyOfValue(Value: Pointer): IInterface;\r\n function KeySet: IJclIntfSet;\r\n function MapEquals(const AMap: IJclIntfPtrMap): Boolean;\r\n procedure PutAll(const AMap: IJclIntfPtrMap);\r\n procedure PutValue(const Key: IInterface; Value: Pointer);\r\n function Remove(const Key: IInterface): Pointer;\r\n function Size: Integer;\r\n function Values: IJclPtrCollection;\r\n end;\r\n\r\n TJclPtrPtrHashMapEntry = record\r\n Key: Pointer;\r\n Value: Pointer;\r\n end;\r\n\r\n TJclPtrPtrHashMapEntryArray = array of TJclPtrPtrHashMapEntry;\r\n\r\n TJclPtrPtrHashMapBucket = class\r\n public\r\n Size: Integer;\r\n Entries: TJclPtrPtrHashMapEntryArray;\r\n procedure InitializeArrayAfterMove(var List: TJclPtrPtrHashMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\n {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\n procedure MoveArray(var List: TJclPtrPtrHashMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\n end;\r\n\r\n TJclPtrPtrHashMap = class(TJclPtrAbstractContainer, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclIntfCloneable, IJclCloneable, IJclGrowable, IJclPackable, IJclBaseContainer, IJclPtrContainer,\r\n IJclPtrPtrMap)\r\n protected\r\n function CreateEmptyContainer: TJclAbstractContainerBase; override;\r\n function FreeKey(var Key: Pointer): Pointer;\r\n function FreeValue(var Value: Pointer): Pointer;\r\n function KeysEqual(A, B: Pointer): Boolean;\r\n function ValuesEqual(A, B: Pointer): Boolean;\r\n private\r\n FBuckets: array of TJclPtrPtrHashMapBucket;\r\n FHashToRangeFunction: TJclHashToRangeFunction;\r\n protected\r\n procedure AssignDataTo(Dest: TJclAbstractContainerBase); override;\r\n procedure AssignPropertiesTo(Dest: TJclAbstractContainerBase); override;\r\n public\r\n constructor Create(ACapacity: Integer);\r\n destructor Destroy; override;\r\n property HashToRangeFunction: TJclHashToRangeFunction read FHashToRangeFunction write FHashToRangeFunction;\r\n { IJclPackable }\r\n procedure Pack; override;\r\n procedure SetCapacity(Value: Integer); override;\r\n { IJclPtrPtrMap }\r\n procedure Clear;\r\n function ContainsKey(Key: Pointer): Boolean;\r\n function ContainsValue(Value: Pointer): Boolean;\r\n function Extract(Key: Pointer): Pointer;\r\n function GetValue(Key: Pointer): Pointer;\r\n function IsEmpty: Boolean;\r\n function KeyOfValue(Value: Pointer): Pointer;\r\n function KeySet: IJclPtrSet;\r\n function MapEquals(const AMap: IJclPtrPtrMap): Boolean;\r\n procedure PutAll(const AMap: IJclPtrPtrMap);\r\n procedure PutValue(Key: Pointer; Value: Pointer);\r\n function Remove(Key: Pointer): Pointer;\r\n function Size: Integer;\r\n function Values: IJclPtrCollection;\r\n end;\r\n\r\n TJclIntfHashMapEntry = record\r\n Key: IInterface;\r\n Value: TObject;\r\n end;\r\n\r\n TJclIntfHashMapEntryArray = array of TJclIntfHashMapEntry;\r\n\r\n TJclIntfHashMapBucket = class\r\n public\r\n Size: Integer;\r\n Entries: TJclIntfHashMapEntryArray;\r\n procedure FinalizeArrayBeforeMove(var List: TJclIntfHashMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\n {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\n procedure InitializeArray(var List: TJclIntfHashMapEntryArray; FromIndex, Count: SizeInt);\r\n {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\n procedure InitializeArrayAfterMove(var List: TJclIntfHashMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\n {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\n\r\n procedure MoveArray(var List: TJclIntfHashMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\n end;\r\n\r\n TJclIntfHashMap = class(TJclIntfAbstractContainer, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclIntfCloneable, IJclCloneable, IJclGrowable, IJclPackable, IJclBaseContainer, IJclIntfContainer, IJclContainer, IJclValueOwner,\r\n IJclIntfMap)\r\n private\r\n FOwnsValues: Boolean;\r\n protected\r\n function CreateEmptyContainer: TJclAbstractContainerBase; override;\r\n function FreeKey(var Key: IInterface): IInterface;\r\n function KeysEqual(const A, B: IInterface): Boolean;\r\n function ValuesEqual(A, B: TObject): Boolean;\r\n public\r\n { IJclValueOwner }\r\n function FreeValue(var Value: TObject): TObject;\r\n function GetOwnsValues: Boolean;\r\n property OwnsValues: Boolean read FOwnsValues;\r\n private\r\n FBuckets: array of TJclIntfHashMapBucket;\r\n FHashToRangeFunction: TJclHashToRangeFunction;\r\n protected\r\n procedure AssignDataTo(Dest: TJclAbstractContainerBase); override;\r\n procedure AssignPropertiesTo(Dest: TJclAbstractContainerBase); override;\r\n public\r\n constructor Create(ACapacity: Integer; AOwnsValues: Boolean);\r\n destructor Destroy; override;\r\n property HashToRangeFunction: TJclHashToRangeFunction read FHashToRangeFunction write FHashToRangeFunction;\r\n { IJclPackable }\r\n procedure Pack; override;\r\n procedure SetCapacity(Value: Integer); override;\r\n { IJclIntfMap }\r\n procedure Clear;\r\n function ContainsKey(const Key: IInterface): Boolean;\r\n function ContainsValue(Value: TObject): Boolean;\r\n function Extract(const Key: IInterface): TObject;\r\n function GetValue(const Key: IInterface): TObject;\r\n function IsEmpty: Boolean;\r\n function KeyOfValue(Value: TObject): IInterface;\r\n function KeySet: IJclIntfSet;\r\n function MapEquals(const AMap: IJclIntfMap): Boolean;\r\n procedure PutAll(const AMap: IJclIntfMap);\r\n procedure PutValue(const Key: IInterface; Value: TObject);\r\n function Remove(const Key: IInterface): TObject;\r\n function Size: Integer;\r\n function Values: IJclCollection;\r\n end;\r\n\r\n TJclAnsiStrHashMapEntry = record\r\n Key: AnsiString;\r\n Value: TObject;\r\n end;\r\n\r\n TJclAnsiStrHashMapEntryArray = array of TJclAnsiStrHashMapEntry;\r\n\r\n TJclAnsiStrHashMapBucket = class\r\n public\r\n Size: Integer;\r\n Entries: TJclAnsiStrHashMapEntryArray;\r\n procedure FinalizeArrayBeforeMove(var List: TJclAnsiStrHashMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\n {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\n procedure InitializeArray(var List: TJclAnsiStrHashMapEntryArray; FromIndex, Count: SizeInt);\r\n {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\n procedure InitializeArrayAfterMove(var List: TJclAnsiStrHashMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\n {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\n\r\n procedure MoveArray(var List: TJclAnsiStrHashMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\n end;\r\n\r\n TJclAnsiStrHashMap = class(TJclAnsiStrAbstractContainer, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclIntfCloneable, IJclCloneable, IJclGrowable, IJclPackable, IJclBaseContainer, IJclStrBaseContainer, IJclAnsiStrContainer, IJclContainer, IJclValueOwner,\r\n IJclAnsiStrMap)\r\n private\r\n FOwnsValues: Boolean;\r\n protected\r\n function CreateEmptyContainer: TJclAbstractContainerBase; override;\r\n function FreeKey(var Key: AnsiString): AnsiString;\r\n function KeysEqual(const A, B: AnsiString): Boolean;\r\n function ValuesEqual(A, B: TObject): Boolean;\r\n public\r\n { IJclValueOwner }\r\n function FreeValue(var Value: TObject): TObject;\r\n function GetOwnsValues: Boolean;\r\n property OwnsValues: Boolean read FOwnsValues;\r\n private\r\n FBuckets: array of TJclAnsiStrHashMapBucket;\r\n FHashToRangeFunction: TJclHashToRangeFunction;\r\n protected\r\n procedure AssignDataTo(Dest: TJclAbstractContainerBase); override;\r\n procedure AssignPropertiesTo(Dest: TJclAbstractContainerBase); override;\r\n public\r\n constructor Create(ACapacity: Integer; AOwnsValues: Boolean);\r\n destructor Destroy; override;\r\n property HashToRangeFunction: TJclHashToRangeFunction read FHashToRangeFunction write FHashToRangeFunction;\r\n { IJclPackable }\r\n procedure Pack; override;\r\n procedure SetCapacity(Value: Integer); override;\r\n { IJclAnsiStrMap }\r\n procedure Clear;\r\n function ContainsKey(const Key: AnsiString): Boolean;\r\n function ContainsValue(Value: TObject): Boolean;\r\n function Extract(const Key: AnsiString): TObject;\r\n function GetValue(const Key: AnsiString): TObject;\r\n function IsEmpty: Boolean;\r\n function KeyOfValue(Value: TObject): AnsiString;\r\n function KeySet: IJclAnsiStrSet;\r\n function MapEquals(const AMap: IJclAnsiStrMap): Boolean;\r\n procedure PutAll(const AMap: IJclAnsiStrMap);\r\n procedure PutValue(const Key: AnsiString; Value: TObject);\r\n function Remove(const Key: AnsiString): TObject;\r\n function Size: Integer;\r\n function Values: IJclCollection;\r\n end;\r\n\r\n TJclWideStrHashMapEntry = record\r\n Key: WideString;\r\n Value: TObject;\r\n end;\r\n\r\n TJclWideStrHashMapEntryArray = array of TJclWideStrHashMapEntry;\r\n\r\n TJclWideStrHashMapBucket = class\r\n public\r\n Size: Integer;\r\n Entries: TJclWideStrHashMapEntryArray;\r\n procedure FinalizeArrayBeforeMove(var List: TJclWideStrHashMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\n {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\n procedure InitializeArray(var List: TJclWideStrHashMapEntryArray; FromIndex, Count: SizeInt);\r\n {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\n procedure InitializeArrayAfterMove(var List: TJclWideStrHashMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\n {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\n\r\n procedure MoveArray(var List: TJclWideStrHashMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\n end;\r\n\r\n TJclWideStrHashMap = class(TJclWideStrAbstractContainer, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclIntfCloneable, IJclCloneable, IJclGrowable, IJclPackable, IJclBaseContainer, IJclStrBaseContainer, IJclWideStrContainer, IJclContainer, IJclValueOwner,\r\n IJclWideStrMap)\r\n private\r\n FOwnsValues: Boolean;\r\n protected\r\n function CreateEmptyContainer: TJclAbstractContainerBase; override;\r\n function FreeKey(var Key: WideString): WideString;\r\n function KeysEqual(const A, B: WideString): Boolean;\r\n function ValuesEqual(A, B: TObject): Boolean;\r\n public\r\n { IJclValueOwner }\r\n function FreeValue(var Value: TObject): TObject;\r\n function GetOwnsValues: Boolean;\r\n property OwnsValues: Boolean read FOwnsValues;\r\n private\r\n FBuckets: array of TJclWideStrHashMapBucket;\r\n FHashToRangeFunction: TJclHashToRangeFunction;\r\n protected\r\n procedure AssignDataTo(Dest: TJclAbstractContainerBase); override;\r\n procedure AssignPropertiesTo(Dest: TJclAbstractContainerBase); override;\r\n public\r\n constructor Create(ACapacity: Integer; AOwnsValues: Boolean);\r\n destructor Destroy; override;\r\n property HashToRangeFunction: TJclHashToRangeFunction read FHashToRangeFunction write FHashToRangeFunction;\r\n { IJclPackable }\r\n procedure Pack; override;\r\n procedure SetCapacity(Value: Integer); override;\r\n { IJclWideStrMap }\r\n procedure Clear;\r\n function ContainsKey(const Key: WideString): Boolean;\r\n function ContainsValue(Value: TObject): Boolean;\r\n function Extract(const Key: WideString): TObject;\r\n function GetValue(const Key: WideString): TObject;\r\n function IsEmpty: Boolean;\r\n function KeyOfValue(Value: TObject): WideString;\r\n function KeySet: IJclWideStrSet;\r\n function MapEquals(const AMap: IJclWideStrMap): Boolean;\r\n procedure PutAll(const AMap: IJclWideStrMap);\r\n procedure PutValue(const Key: WideString; Value: TObject);\r\n function Remove(const Key: WideString): TObject;\r\n function Size: Integer;\r\n function Values: IJclCollection;\r\n end;\r\n\r\n {$IFDEF SUPPORTS_UNICODE_STRING}\r\n TJclUnicodeStrHashMapEntry = record\r\n Key: UnicodeString;\r\n Value: TObject;\r\n end;\r\n\r\n TJclUnicodeStrHashMapEntryArray = array of TJclUnicodeStrHashMapEntry;\r\n\r\n TJclUnicodeStrHashMapBucket = class\r\n public\r\n Size: Integer;\r\n Entries: TJclUnicodeStrHashMapEntryArray;\r\n procedure FinalizeArrayBeforeMove(var List: TJclUnicodeStrHashMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\n {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\n procedure InitializeArray(var List: TJclUnicodeStrHashMapEntryArray; FromIndex, Count: SizeInt);\r\n {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\n procedure InitializeArrayAfterMove(var List: TJclUnicodeStrHashMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\n {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\n\r\n procedure MoveArray(var List: TJclUnicodeStrHashMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\n end;\r\n {$ENDIF SUPPORTS_UNICODE_STRING}\r\n\r\n {$IFDEF SUPPORTS_UNICODE_STRING}\r\n TJclUnicodeStrHashMap = class(TJclUnicodeStrAbstractContainer, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclIntfCloneable, IJclCloneable, IJclGrowable, IJclPackable, IJclBaseContainer, IJclStrBaseContainer, IJclUnicodeStrContainer, IJclContainer, IJclValueOwner,\r\n IJclUnicodeStrMap)\r\n private\r\n FOwnsValues: Boolean;\r\n protected\r\n function CreateEmptyContainer: TJclAbstractContainerBase; override;\r\n function FreeKey(var Key: UnicodeString): UnicodeString;\r\n function KeysEqual(const A, B: UnicodeString): Boolean;\r\n function ValuesEqual(A, B: TObject): Boolean;\r\n public\r\n { IJclValueOwner }\r\n function FreeValue(var Value: TObject): TObject;\r\n function GetOwnsValues: Boolean;\r\n property OwnsValues: Boolean read FOwnsValues;\r\n private\r\n FBuckets: array of TJclUnicodeStrHashMapBucket;\r\n FHashToRangeFunction: TJclHashToRangeFunction;\r\n protected\r\n procedure AssignDataTo(Dest: TJclAbstractContainerBase); override;\r\n procedure AssignPropertiesTo(Dest: TJclAbstractContainerBase); override;\r\n public\r\n constructor Create(ACapacity: Integer; AOwnsValues: Boolean);\r\n destructor Destroy; override;\r\n property HashToRangeFunction: TJclHashToRangeFunction read FHashToRangeFunction write FHashToRangeFunction;\r\n { IJclPackable }\r\n procedure Pack; override;\r\n procedure SetCapacity(Value: Integer); override;\r\n { IJclUnicodeStrMap }\r\n procedure Clear;\r\n function ContainsKey(const Key: UnicodeString): Boolean;\r\n function ContainsValue(Value: TObject): Boolean;\r\n function Extract(const Key: UnicodeString): TObject;\r\n function GetValue(const Key: UnicodeString): TObject;\r\n function IsEmpty: Boolean;\r\n function KeyOfValue(Value: TObject): UnicodeString;\r\n function KeySet: IJclUnicodeStrSet;\r\n function MapEquals(const AMap: IJclUnicodeStrMap): Boolean;\r\n procedure PutAll(const AMap: IJclUnicodeStrMap);\r\n procedure PutValue(const Key: UnicodeString; Value: TObject);\r\n function Remove(const Key: UnicodeString): TObject;\r\n function Size: Integer;\r\n function Values: IJclCollection;\r\n end;\r\n {$ENDIF SUPPORTS_UNICODE_STRING}\r\n\r\n {$IFDEF CONTAINER_ANSISTR}\r\n TJclStrHashMapEntry = TJclAnsiStrHashMapEntry;\r\n TJclStrHashMapBucket = TJclAnsiStrHashMapBucket;\r\n {$ENDIF CONTAINER_ANSISTR}\r\n {$IFDEF CONTAINER_WIDESTR}\r\n TJclStrHashMapEntry = TJclWideStrHashMapEntry;\r\n TJclStrHashMapBucket = TJclWideStrHashMapBucket;\r\n {$ENDIF CONTAINER_WIDESTR}\r\n {$IFDEF CONTAINER_UNICODESTR}\r\n TJclStrHashMapEntry = TJclUnicodeStrHashMapEntry;\r\n TJclStrHashMapBucket = TJclUnicodeStrHashMapBucket;\r\n {$ENDIF CONTAINER_UNICODESTR}\r\n\r\n {$IFDEF CONTAINER_ANSISTR}\r\n TJclStrHashMap = TJclAnsiStrHashMap;\r\n {$ENDIF CONTAINER_ANSISTR}\r\n {$IFDEF CONTAINER_WIDESTR}\r\n TJclStrHashMap = TJclWideStrHashMap;\r\n {$ENDIF CONTAINER_WIDESTR}\r\n {$IFDEF CONTAINER_UNICODESTR}\r\n TJclStrHashMap = TJclUnicodeStrHashMap;\r\n {$ENDIF CONTAINER_UNICODESTR}\r\n\r\n TJclSingleHashMapEntry = record\r\n Key: Single;\r\n Value: TObject;\r\n end;\r\n\r\n TJclSingleHashMapEntryArray = array of TJclSingleHashMapEntry;\r\n\r\n TJclSingleHashMapBucket = class\r\n public\r\n Size: Integer;\r\n Entries: TJclSingleHashMapEntryArray;\r\n procedure InitializeArrayAfterMove(var List: TJclSingleHashMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\n {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\n procedure MoveArray(var List: TJclSingleHashMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\n end;\r\n\r\n TJclSingleHashMap = class(TJclSingleAbstractContainer, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclIntfCloneable, IJclCloneable, IJclGrowable, IJclPackable, IJclBaseContainer, IJclSingleContainer, IJclContainer, IJclValueOwner,\r\n IJclSingleMap)\r\n private\r\n FOwnsValues: Boolean;\r\n protected\r\n function CreateEmptyContainer: TJclAbstractContainerBase; override;\r\n function FreeKey(var Key: Single): Single;\r\n function KeysEqual(const A, B: Single): Boolean;\r\n function ValuesEqual(A, B: TObject): Boolean;\r\n public\r\n { IJclValueOwner }\r\n function FreeValue(var Value: TObject): TObject;\r\n function GetOwnsValues: Boolean;\r\n property OwnsValues: Boolean read FOwnsValues;\r\n private\r\n FBuckets: array of TJclSingleHashMapBucket;\r\n FHashToRangeFunction: TJclHashToRangeFunction;\r\n protected\r\n procedure AssignDataTo(Dest: TJclAbstractContainerBase); override;\r\n procedure AssignPropertiesTo(Dest: TJclAbstractContainerBase); override;\r\n public\r\n constructor Create(ACapacity: Integer; AOwnsValues: Boolean);\r\n destructor Destroy; override;\r\n property HashToRangeFunction: TJclHashToRangeFunction read FHashToRangeFunction write FHashToRangeFunction;\r\n { IJclPackable }\r\n procedure Pack; override;\r\n procedure SetCapacity(Value: Integer); override;\r\n { IJclSingleMap }\r\n procedure Clear;\r\n function ContainsKey(const Key: Single): Boolean;\r\n function ContainsValue(Value: TObject): Boolean;\r\n function Extract(const Key: Single): TObject;\r\n function GetValue(const Key: Single): TObject;\r\n function IsEmpty: Boolean;\r\n function KeyOfValue(Value: TObject): Single;\r\n function KeySet: IJclSingleSet;\r\n function MapEquals(const AMap: IJclSingleMap): Boolean;\r\n procedure PutAll(const AMap: IJclSingleMap);\r\n procedure PutValue(const Key: Single; Value: TObject);\r\n function Remove(const Key: Single): TObject;\r\n function Size: Integer;\r\n function Values: IJclCollection;\r\n end;\r\n\r\n TJclDoubleHashMapEntry = record\r\n Key: Double;\r\n Value: TObject;\r\n end;\r\n\r\n TJclDoubleHashMapEntryArray = array of TJclDoubleHashMapEntry;\r\n\r\n TJclDoubleHashMapBucket = class\r\n public\r\n Size: Integer;\r\n Entries: TJclDoubleHashMapEntryArray;\r\n procedure InitializeArrayAfterMove(var List: TJclDoubleHashMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\n {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\n procedure MoveArray(var List: TJclDoubleHashMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\n end;\r\n\r\n TJclDoubleHashMap = class(TJclDoubleAbstractContainer, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclIntfCloneable, IJclCloneable, IJclGrowable, IJclPackable, IJclBaseContainer, IJclDoubleContainer, IJclContainer, IJclValueOwner,\r\n IJclDoubleMap)\r\n private\r\n FOwnsValues: Boolean;\r\n protected\r\n function CreateEmptyContainer: TJclAbstractContainerBase; override;\r\n function FreeKey(var Key: Double): Double;\r\n function KeysEqual(const A, B: Double): Boolean;\r\n function ValuesEqual(A, B: TObject): Boolean;\r\n public\r\n { IJclValueOwner }\r\n function FreeValue(var Value: TObject): TObject;\r\n function GetOwnsValues: Boolean;\r\n property OwnsValues: Boolean read FOwnsValues;\r\n private\r\n FBuckets: array of TJclDoubleHashMapBucket;\r\n FHashToRangeFunction: TJclHashToRangeFunction;\r\n protected\r\n procedure AssignDataTo(Dest: TJclAbstractContainerBase); override;\r\n procedure AssignPropertiesTo(Dest: TJclAbstractContainerBase); override;\r\n public\r\n constructor Create(ACapacity: Integer; AOwnsValues: Boolean);\r\n destructor Destroy; override;\r\n property HashToRangeFunction: TJclHashToRangeFunction read FHashToRangeFunction write FHashToRangeFunction;\r\n { IJclPackable }\r\n procedure Pack; override;\r\n procedure SetCapacity(Value: Integer); override;\r\n { IJclDoubleMap }\r\n procedure Clear;\r\n function ContainsKey(const Key: Double): Boolean;\r\n function ContainsValue(Value: TObject): Boolean;\r\n function Extract(const Key: Double): TObject;\r\n function GetValue(const Key: Double): TObject;\r\n function IsEmpty: Boolean;\r\n function KeyOfValue(Value: TObject): Double;\r\n function KeySet: IJclDoubleSet;\r\n function MapEquals(const AMap: IJclDoubleMap): Boolean;\r\n procedure PutAll(const AMap: IJclDoubleMap);\r\n procedure PutValue(const Key: Double; Value: TObject);\r\n function Remove(const Key: Double): TObject;\r\n function Size: Integer;\r\n function Values: IJclCollection;\r\n end;\r\n\r\n TJclExtendedHashMapEntry = record\r\n Key: Extended;\r\n Value: TObject;\r\n end;\r\n\r\n TJclExtendedHashMapEntryArray = array of TJclExtendedHashMapEntry;\r\n\r\n TJclExtendedHashMapBucket = class\r\n public\r\n Size: Integer;\r\n Entries: TJclExtendedHashMapEntryArray;\r\n procedure InitializeArrayAfterMove(var List: TJclExtendedHashMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\n {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\n procedure MoveArray(var List: TJclExtendedHashMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\n end;\r\n\r\n TJclExtendedHashMap = class(TJclExtendedAbstractContainer, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclIntfCloneable, IJclCloneable, IJclGrowable, IJclPackable, IJclBaseContainer, IJclExtendedContainer, IJclContainer, IJclValueOwner,\r\n IJclExtendedMap)\r\n private\r\n FOwnsValues: Boolean;\r\n protected\r\n function CreateEmptyContainer: TJclAbstractContainerBase; override;\r\n function FreeKey(var Key: Extended): Extended;\r\n function KeysEqual(const A, B: Extended): Boolean;\r\n function ValuesEqual(A, B: TObject): Boolean;\r\n public\r\n { IJclValueOwner }\r\n function FreeValue(var Value: TObject): TObject;\r\n function GetOwnsValues: Boolean;\r\n property OwnsValues: Boolean read FOwnsValues;\r\n private\r\n FBuckets: array of TJclExtendedHashMapBucket;\r\n FHashToRangeFunction: TJclHashToRangeFunction;\r\n protected\r\n procedure AssignDataTo(Dest: TJclAbstractContainerBase); override;\r\n procedure AssignPropertiesTo(Dest: TJclAbstractContainerBase); override;\r\n public\r\n constructor Create(ACapacity: Integer; AOwnsValues: Boolean);\r\n destructor Destroy; override;\r\n property HashToRangeFunction: TJclHashToRangeFunction read FHashToRangeFunction write FHashToRangeFunction;\r\n { IJclPackable }\r\n procedure Pack; override;\r\n procedure SetCapacity(Value: Integer); override;\r\n { IJclExtendedMap }\r\n procedure Clear;\r\n function ContainsKey(const Key: Extended): Boolean;\r\n function ContainsValue(Value: TObject): Boolean;\r\n function Extract(const Key: Extended): TObject;\r\n function GetValue(const Key: Extended): TObject;\r\n function IsEmpty: Boolean;\r\n function KeyOfValue(Value: TObject): Extended;\r\n function KeySet: IJclExtendedSet;\r\n function MapEquals(const AMap: IJclExtendedMap): Boolean;\r\n procedure PutAll(const AMap: IJclExtendedMap);\r\n procedure PutValue(const Key: Extended; Value: TObject);\r\n function Remove(const Key: Extended): TObject;\r\n function Size: Integer;\r\n function Values: IJclCollection;\r\n end;\r\n\r\n {$IFDEF MATH_SINGLE_PRECISION}\r\n TJclFloatHashMapEntry = TJclSingleHashMapEntry;\r\n TJclFloatHashMapBucket = TJclSingleHashMapBucket;\r\n {$ENDIF MATH_SINGLE_PRECISION}\r\n {$IFDEF MATH_DOUBLE_PRECISION}\r\n TJclFloatHashMapEntry = TJclDoubleHashMapEntry;\r\n TJclFloatHashMapBucket = TJclDoubleHashMapBucket;\r\n {$ENDIF MATH_DOUBLE_PRECISION}\r\n {$IFDEF MATH_EXTENDED_PRECISION}\r\n TJclFloatHashMapEntry = TJclExtendedHashMapEntry;\r\n TJclFloatHashMapBucket = TJclExtendedHashMapBucket;\r\n {$ENDIF MATH_EXTENDED_PRECISION}\r\n\r\n {$IFDEF MATH_SINGLE_PRECISION}\r\n TJclFloatHashMap = TJclSingleHashMap;\r\n {$ENDIF MATH_SINGLE_PRECISION}\r\n {$IFDEF MATH_DOUBLE_PRECISION}\r\n TJclFloatHashMap = TJclDoubleHashMap;\r\n {$ENDIF MATH_DOUBLE_PRECISION}\r\n {$IFDEF MATH_EXTENDED_PRECISION}\r\n TJclFloatHashMap = TJclExtendedHashMap;\r\n {$ENDIF MATH_EXTENDED_PRECISION}\r\n\r\n TJclIntegerHashMapEntry = record\r\n Key: Integer;\r\n Value: TObject;\r\n end;\r\n\r\n TJclIntegerHashMapEntryArray = array of TJclIntegerHashMapEntry;\r\n\r\n TJclIntegerHashMapBucket = class\r\n public\r\n Size: Integer;\r\n Entries: TJclIntegerHashMapEntryArray;\r\n procedure InitializeArrayAfterMove(var List: TJclIntegerHashMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\n {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\n procedure MoveArray(var List: TJclIntegerHashMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\n end;\r\n\r\n TJclIntegerHashMap = class(TJclIntegerAbstractContainer, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclIntfCloneable, IJclCloneable, IJclGrowable, IJclPackable, IJclBaseContainer, IJclIntegerContainer, IJclContainer, IJclValueOwner,\r\n IJclIntegerMap)\r\n private\r\n FOwnsValues: Boolean;\r\n protected\r\n function CreateEmptyContainer: TJclAbstractContainerBase; override;\r\n function FreeKey(var Key: Integer): Integer;\r\n function KeysEqual(A, B: Integer): Boolean;\r\n function ValuesEqual(A, B: TObject): Boolean;\r\n public\r\n { IJclValueOwner }\r\n function FreeValue(var Value: TObject): TObject;\r\n function GetOwnsValues: Boolean;\r\n property OwnsValues: Boolean read FOwnsValues;\r\n private\r\n FBuckets: array of TJclIntegerHashMapBucket;\r\n FHashToRangeFunction: TJclHashToRangeFunction;\r\n protected\r\n procedure AssignDataTo(Dest: TJclAbstractContainerBase); override;\r\n procedure AssignPropertiesTo(Dest: TJclAbstractContainerBase); override;\r\n public\r\n constructor Create(ACapacity: Integer; AOwnsValues: Boolean);\r\n destructor Destroy; override;\r\n property HashToRangeFunction: TJclHashToRangeFunction read FHashToRangeFunction write FHashToRangeFunction;\r\n { IJclPackable }\r\n procedure Pack; override;\r\n procedure SetCapacity(Value: Integer); override;\r\n { IJclIntegerMap }\r\n procedure Clear;\r\n function ContainsKey(Key: Integer): Boolean;\r\n function ContainsValue(Value: TObject): Boolean;\r\n function Extract(Key: Integer): TObject;\r\n function GetValue(Key: Integer): TObject;\r\n function IsEmpty: Boolean;\r\n function KeyOfValue(Value: TObject): Integer;\r\n function KeySet: IJclIntegerSet;\r\n function MapEquals(const AMap: IJclIntegerMap): Boolean;\r\n procedure PutAll(const AMap: IJclIntegerMap);\r\n procedure PutValue(Key: Integer; Value: TObject);\r\n function Remove(Key: Integer): TObject;\r\n function Size: Integer;\r\n function Values: IJclCollection;\r\n end;\r\n\r\n TJclCardinalHashMapEntry = record\r\n Key: Cardinal;\r\n Value: TObject;\r\n end;\r\n\r\n TJclCardinalHashMapEntryArray = array of TJclCardinalHashMapEntry;\r\n\r\n TJclCardinalHashMapBucket = class\r\n public\r\n Size: Integer;\r\n Entries: TJclCardinalHashMapEntryArray;\r\n procedure InitializeArrayAfterMove(var List: TJclCardinalHashMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\n {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\n procedure MoveArray(var List: TJclCardinalHashMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\n end;\r\n\r\n TJclCardinalHashMap = class(TJclCardinalAbstractContainer, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclIntfCloneable, IJclCloneable, IJclGrowable, IJclPackable, IJclBaseContainer, IJclCardinalContainer, IJclContainer, IJclValueOwner,\r\n IJclCardinalMap)\r\n private\r\n FOwnsValues: Boolean;\r\n protected\r\n function CreateEmptyContainer: TJclAbstractContainerBase; override;\r\n function FreeKey(var Key: Cardinal): Cardinal;\r\n function KeysEqual(A, B: Cardinal): Boolean;\r\n function ValuesEqual(A, B: TObject): Boolean;\r\n public\r\n { IJclValueOwner }\r\n function FreeValue(var Value: TObject): TObject;\r\n function GetOwnsValues: Boolean;\r\n property OwnsValues: Boolean read FOwnsValues;\r\n private\r\n FBuckets: array of TJclCardinalHashMapBucket;\r\n FHashToRangeFunction: TJclHashToRangeFunction;\r\n protected\r\n procedure AssignDataTo(Dest: TJclAbstractContainerBase); override;\r\n procedure AssignPropertiesTo(Dest: TJclAbstractContainerBase); override;\r\n public\r\n constructor Create(ACapacity: Integer; AOwnsValues: Boolean);\r\n destructor Destroy; override;\r\n property HashToRangeFunction: TJclHashToRangeFunction read FHashToRangeFunction write FHashToRangeFunction;\r\n { IJclPackable }\r\n procedure Pack; override;\r\n procedure SetCapacity(Value: Integer); override;\r\n { IJclCardinalMap }\r\n procedure Clear;\r\n function ContainsKey(Key: Cardinal): Boolean;\r\n function ContainsValue(Value: TObject): Boolean;\r\n function Extract(Key: Cardinal): TObject;\r\n function GetValue(Key: Cardinal): TObject;\r\n function IsEmpty: Boolean;\r\n function KeyOfValue(Value: TObject): Cardinal;\r\n function KeySet: IJclCardinalSet;\r\n function MapEquals(const AMap: IJclCardinalMap): Boolean;\r\n procedure PutAll(const AMap: IJclCardinalMap);\r\n procedure PutValue(Key: Cardinal; Value: TObject);\r\n function Remove(Key: Cardinal): TObject;\r\n function Size: Integer;\r\n function Values: IJclCollection;\r\n end;\r\n\r\n TJclInt64HashMapEntry = record\r\n Key: Int64;\r\n Value: TObject;\r\n end;\r\n\r\n TJclInt64HashMapEntryArray = array of TJclInt64HashMapEntry;\r\n\r\n TJclInt64HashMapBucket = class\r\n public\r\n Size: Integer;\r\n Entries: TJclInt64HashMapEntryArray;\r\n procedure InitializeArrayAfterMove(var List: TJclInt64HashMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\n {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\n procedure MoveArray(var List: TJclInt64HashMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\n end;\r\n\r\n TJclInt64HashMap = class(TJclInt64AbstractContainer, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclIntfCloneable, IJclCloneable, IJclGrowable, IJclPackable, IJclBaseContainer, IJclInt64Container, IJclContainer, IJclValueOwner,\r\n IJclInt64Map)\r\n private\r\n FOwnsValues: Boolean;\r\n protected\r\n function CreateEmptyContainer: TJclAbstractContainerBase; override;\r\n function FreeKey(var Key: Int64): Int64;\r\n function KeysEqual(const A, B: Int64): Boolean;\r\n function ValuesEqual(A, B: TObject): Boolean;\r\n public\r\n { IJclValueOwner }\r\n function FreeValue(var Value: TObject): TObject;\r\n function GetOwnsValues: Boolean;\r\n property OwnsValues: Boolean read FOwnsValues;\r\n private\r\n FBuckets: array of TJclInt64HashMapBucket;\r\n FHashToRangeFunction: TJclHashToRangeFunction;\r\n protected\r\n procedure AssignDataTo(Dest: TJclAbstractContainerBase); override;\r\n procedure AssignPropertiesTo(Dest: TJclAbstractContainerBase); override;\r\n public\r\n constructor Create(ACapacity: Integer; AOwnsValues: Boolean);\r\n destructor Destroy; override;\r\n property HashToRangeFunction: TJclHashToRangeFunction read FHashToRangeFunction write FHashToRangeFunction;\r\n { IJclPackable }\r\n procedure Pack; override;\r\n procedure SetCapacity(Value: Integer); override;\r\n { IJclInt64Map }\r\n procedure Clear;\r\n function ContainsKey(const Key: Int64): Boolean;\r\n function ContainsValue(Value: TObject): Boolean;\r\n function Extract(const Key: Int64): TObject;\r\n function GetValue(const Key: Int64): TObject;\r\n function IsEmpty: Boolean;\r\n function KeyOfValue(Value: TObject): Int64;\r\n function KeySet: IJclInt64Set;\r\n function MapEquals(const AMap: IJclInt64Map): Boolean;\r\n procedure PutAll(const AMap: IJclInt64Map);\r\n procedure PutValue(const Key: Int64; Value: TObject);\r\n function Remove(const Key: Int64): TObject;\r\n function Size: Integer;\r\n function Values: IJclCollection;\r\n end;\r\n\r\n TJclPtrHashMapEntry = record\r\n Key: Pointer;\r\n Value: TObject;\r\n end;\r\n\r\n TJclPtrHashMapEntryArray = array of TJclPtrHashMapEntry;\r\n\r\n TJclPtrHashMapBucket = class\r\n public\r\n Size: Integer;\r\n Entries: TJclPtrHashMapEntryArray;\r\n procedure InitializeArrayAfterMove(var List: TJclPtrHashMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\n {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\n procedure MoveArray(var List: TJclPtrHashMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\n end;\r\n\r\n TJclPtrHashMap = class(TJclPtrAbstractContainer, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclIntfCloneable, IJclCloneable, IJclGrowable, IJclPackable, IJclBaseContainer, IJclPtrContainer, IJclContainer, IJclValueOwner,\r\n IJclPtrMap)\r\n private\r\n FOwnsValues: Boolean;\r\n protected\r\n function CreateEmptyContainer: TJclAbstractContainerBase; override;\r\n function FreeKey(var Key: Pointer): Pointer;\r\n function KeysEqual(A, B: Pointer): Boolean;\r\n function ValuesEqual(A, B: TObject): Boolean;\r\n public\r\n { IJclValueOwner }\r\n function FreeValue(var Value: TObject): TObject;\r\n function GetOwnsValues: Boolean;\r\n property OwnsValues: Boolean read FOwnsValues;\r\n private\r\n FBuckets: array of TJclPtrHashMapBucket;\r\n FHashToRangeFunction: TJclHashToRangeFunction;\r\n protected\r\n procedure AssignDataTo(Dest: TJclAbstractContainerBase); override;\r\n procedure AssignPropertiesTo(Dest: TJclAbstractContainerBase); override;\r\n public\r\n constructor Create(ACapacity: Integer; AOwnsValues: Boolean);\r\n destructor Destroy; override;\r\n property HashToRangeFunction: TJclHashToRangeFunction read FHashToRangeFunction write FHashToRangeFunction;\r\n { IJclPackable }\r\n procedure Pack; override;\r\n procedure SetCapacity(Value: Integer); override;\r\n { IJclPtrMap }\r\n procedure Clear;\r\n function ContainsKey(Key: Pointer): Boolean;\r\n function ContainsValue(Value: TObject): Boolean;\r\n function Extract(Key: Pointer): TObject;\r\n function GetValue(Key: Pointer): TObject;\r\n function IsEmpty: Boolean;\r\n function KeyOfValue(Value: TObject): Pointer;\r\n function KeySet: IJclPtrSet;\r\n function MapEquals(const AMap: IJclPtrMap): Boolean;\r\n procedure PutAll(const AMap: IJclPtrMap);\r\n procedure PutValue(Key: Pointer; Value: TObject);\r\n function Remove(Key: Pointer): TObject;\r\n function Size: Integer;\r\n function Values: IJclCollection;\r\n end;\r\n\r\n TJclHashMapEntry = record\r\n Key: TObject;\r\n Value: TObject;\r\n end;\r\n\r\n TJclHashMapEntryArray = array of TJclHashMapEntry;\r\n\r\n TJclHashMapBucket = class\r\n public\r\n Size: Integer;\r\n Entries: TJclHashMapEntryArray;\r\n procedure InitializeArrayAfterMove(var List: TJclHashMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\n {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\n procedure MoveArray(var List: TJclHashMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\n end;\r\n\r\n TJclHashMap = class(TJclAbstractContainerBase, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclIntfCloneable, IJclCloneable, IJclGrowable, IJclPackable, IJclBaseContainer, IJclContainer, IJclKeyOwner, IJclValueOwner,\r\n IJclMap)\r\n private\r\n FOwnsKeys: Boolean;\r\n FOwnsValues: Boolean;\r\n protected\r\n function CreateEmptyContainer: TJclAbstractContainerBase; override;\r\n function Hash(AObject: TObject): Integer;\r\n function KeysEqual(A, B: TObject): Boolean;\r\n function ValuesEqual(A, B: TObject): Boolean;\r\n public\r\n { IJclKeyOwner }\r\n function FreeKey(var Key: TObject): TObject;\r\n function GetOwnsKeys: Boolean;\r\n property OwnsKeys: Boolean read FOwnsKeys;\r\n { IJclValueOwner }\r\n function FreeValue(var Value: TObject): TObject;\r\n function GetOwnsValues: Boolean;\r\n property OwnsValues: Boolean read FOwnsValues;\r\n private\r\n FBuckets: array of TJclHashMapBucket;\r\n FHashToRangeFunction: TJclHashToRangeFunction;\r\n protected\r\n procedure AssignDataTo(Dest: TJclAbstractContainerBase); override;\r\n procedure AssignPropertiesTo(Dest: TJclAbstractContainerBase); override;\r\n public\r\n constructor Create(ACapacity: Integer; AOwnsValues: Boolean; AOwnsKeys: Boolean);\r\n destructor Destroy; override;\r\n property HashToRangeFunction: TJclHashToRangeFunction read FHashToRangeFunction write FHashToRangeFunction;\r\n { IJclPackable }\r\n procedure Pack; override;\r\n procedure SetCapacity(Value: Integer); override;\r\n { IJclMap }\r\n procedure Clear;\r\n function ContainsKey(Key: TObject): Boolean;\r\n function ContainsValue(Value: TObject): Boolean;\r\n function Extract(Key: TObject): TObject;\r\n function GetValue(Key: TObject): TObject;\r\n function IsEmpty: Boolean;\r\n function KeyOfValue(Value: TObject): TObject;\r\n function KeySet: IJclSet;\r\n function MapEquals(const AMap: IJclMap): Boolean;\r\n procedure PutAll(const AMap: IJclMap);\r\n procedure PutValue(Key: TObject; Value: TObject);\r\n function Remove(Key: TObject): TObject;\r\n function Size: Integer;\r\n function Values: IJclCollection;\r\n end;\r\n\r\n\r\n {$IFDEF SUPPORTS_GENERICS}\r\n //DOM-IGNORE-BEGIN\r\n\r\n TJclHashEntry = record\r\n Key: TKey;\r\n Value: TValue;\r\n end;\r\n\r\n TJclBucket = class\r\n public\r\n type\r\n THashEntryArray = array of TJclHashEntry;\r\n public\r\n Size: Integer;\r\n Entries: THashEntryArray;\r\n procedure FinalizeArrayBeforeMove(var List: THashEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\n {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\n procedure InitializeArray(var List: THashEntryArray; FromIndex, Count: SizeInt);\r\n {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\n procedure InitializeArrayAfterMove(var List: THashEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\n {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\n\r\n procedure MoveArray(var List: THashEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\n end;\r\n\r\n TJclHashMap = class(TJclAbstractContainerBase, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclIntfCloneable, IJclCloneable, IJclGrowable, IJclPackable, IJclBaseContainer, IJclPairOwner,\r\n IJclMap)\r\n protected\r\n type\r\n TBucket = TJclBucket;\r\n private\r\n FOwnsKeys: Boolean;\r\n FOwnsValues: Boolean;\r\n protected\r\n function Hash(const AKey: TKey): Integer; virtual; abstract;\r\n function KeysEqual(const A, B: TKey): Boolean; virtual; abstract;\r\n function ValuesEqual(const A, B: TValue): Boolean; virtual; abstract;\r\n function CreateEmptyArrayList(ACapacity: Integer; AOwnsObjects: Boolean): IJclCollection; virtual; abstract;\r\n function CreateEmptyArraySet(ACapacity: Integer; AOwnsObjects: Boolean): IJclSet; virtual; abstract;\r\n public\r\n { IJclPairOwner }\r\n function FreeKey(var Key: TKey): TKey;\r\n function FreeValue(var Value: TValue): TValue;\r\n function GetOwnsKeys: Boolean;\r\n function GetOwnsValues: Boolean;\r\n property OwnsKeys: Boolean read FOwnsKeys;\r\n property OwnsValues: Boolean read FOwnsValues;\r\n private\r\n FBuckets: array of TBucket;\r\n FHashToRangeFunction: TJclHashToRangeFunction;\r\n protected\r\n procedure AssignDataTo(Dest: TJclAbstractContainerBase); override;\r\n procedure AssignPropertiesTo(Dest: TJclAbstractContainerBase); override;\r\n public\r\n constructor Create(ACapacity: Integer; AOwnsValues: Boolean; AOwnsKeys: Boolean);\r\n destructor Destroy; override;\r\n property HashToRangeFunction: TJclHashToRangeFunction read FHashToRangeFunction write FHashToRangeFunction;\r\n { IJclPackable }\r\n procedure Pack; override;\r\n procedure SetCapacity(Value: Integer); override;\r\n { IJclMap }\r\n procedure Clear;\r\n function ContainsKey(const Key: TKey): Boolean;\r\n function ContainsValue(const Value: TValue): Boolean;\r\n function Extract(const Key: TKey): TValue;\r\n function GetValue(const Key: TKey): TValue;\r\n function IsEmpty: Boolean;\r\n function KeyOfValue(const Value: TValue): TKey;\r\n function KeySet: IJclSet;\r\n function MapEquals(const AMap: IJclMap): Boolean;\r\n procedure PutAll(const AMap: IJclMap);\r\n procedure PutValue(const Key: TKey; const Value: TValue);\r\n function Remove(const Key: TKey): TValue;\r\n function Size: Integer;\r\n function Values: IJclCollection;\r\n end;\r\n\r\n // E = external helper to compare and hash items\r\n // KeyComparer is used only when getting KeySet\r\n // GetHashCode and Equals methods of KeyEqualityComparer are used\r\n // GetHashCode of ValueEqualityComparer is not used\r\n TJclHashMapE = class(TJclHashMap, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclIntfCloneable, IJclCloneable, IJclPackable, IJclBaseContainer, IJclMap, IJclPairOwner)\r\n protected\r\n type\r\n TArrayList = TJclArrayListE;\r\n TArraySet = TJclArraySetE;\r\n private\r\n FKeyEqualityComparer: IJclEqualityComparer;\r\n FKeyHashConverter: IJclHashConverter;\r\n FKeyComparer: IJclComparer;\r\n FValueEqualityComparer: IJclEqualityComparer;\r\n protected\r\n procedure AssignPropertiesTo(Dest: TJclAbstractContainerBase); override;\r\n function Hash(const AKey: TKey): Integer; override;\r\n function KeysEqual(const A, B: TKey): Boolean; override;\r\n function ValuesEqual(const A, B: TValue): Boolean; override;\r\n function CreateEmptyArrayList(ACapacity: Integer; AOwnsObjects: Boolean): IJclCollection; override;\r\n function CreateEmptyContainer: TJclAbstractContainerBase; override;\r\n function CreateEmptyArraySet(ACapacity: Integer; AOwnsObjects: Boolean): IJclSet; override;\r\n public\r\n constructor Create(const AKeyEqualityComparer: IJclEqualityComparer;\r\n const AKeyHashConverter: IJclHashConverter; const AValueEqualityComparer: IJclEqualityComparer;\r\n const AKeyComparer: IJclComparer; ACapacity: Integer; AOwnsValues: Boolean; AOwnsKeys: Boolean);\r\n\r\n property KeyEqualityComparer: IJclEqualityComparer read FKeyEqualityComparer write FKeyEqualityComparer;\r\n property KeyHashConverter: IJclHashConverter read FKeyHashConverter write FKeyHashConverter;\r\n property KeyComparer: IJclComparer read FKeyComparer write FKeyComparer;\r\n property ValueEqualityComparer: IJclEqualityComparer read FValueEqualityComparer write FValueEqualityComparer;\r\n end;\r\n\r\n // F = Functions to compare and hash items\r\n // KeyComparer is used only when getting KeySet\r\n TJclHashMapF = class(TJclHashMap, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclIntfCloneable, IJclCloneable, IJclPackable, IJclBaseContainer, IJclMap, IJclPairOwner)\r\n protected\r\n type\r\n TArrayList = TJclArrayListF;\r\n TArraySet = TJclArraySetF;\r\n private\r\n FKeyEqualityCompare: TEqualityCompare;\r\n FKeyHash: THashConvert;\r\n FKeyCompare: TCompare;\r\n FValueEqualityCompare: TEqualityCompare;\r\n protected\r\n procedure AssignPropertiesTo(Dest: TJclAbstractContainerBase); override;\r\n function Hash(const AKey: TKey): Integer; override;\r\n function KeysEqual(const A, B: TKey): Boolean; override;\r\n function ValuesEqual(const A, B: TValue): Boolean; override;\r\n function CreateEmptyArrayList(ACapacity: Integer; AOwnsObjects: Boolean): IJclCollection; override;\r\n function CreateEmptyContainer: TJclAbstractContainerBase; override;\r\n function CreateEmptyArraySet(ACapacity: Integer; AOwnsObjects: Boolean): IJclSet; override;\r\n public\r\n constructor Create(AKeyEqualityCompare: TEqualityCompare; AKeyHash: THashConvert;\r\n AValueEqualityCompare: TEqualityCompare; AKeyCompare: TCompare;\r\n ACapacity: Integer; AOwnsValues: Boolean; AOwnsKeys: Boolean);\r\n\r\n property KeyEqualityCompare: TEqualityCompare read FKeyEqualityCompare write FKeyEqualityCompare;\r\n property KeyCompare: TCompare read FKeyCompare write FKeyCompare;\r\n property KeyHash: THashConvert read FKeyHash write FKeyHash;\r\n property ValueEqualityCompare: TEqualityCompare read FValueEqualityCompare write FValueEqualityCompare;\r\n end;\r\n\r\n // I = items can compare themselves to an other, items can create hash value from themselves\r\n TJclHashMapI, IEquatable, IHashable; TValue: IEquatable> = class(TJclHashMap,\r\n {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE} IJclIntfCloneable, IJclCloneable, IJclPackable, IJclBaseContainer,\r\n IJclMap, IJclPairOwner)\r\n protected\r\n type\r\n TArrayList = TJclArrayListI;\r\n TArraySet = TJclArraySetI;\r\n protected\r\n function Hash(const AKey: TKey): Integer; override;\r\n function KeysEqual(const A, B: TKey): Boolean; override;\r\n function ValuesEqual(const A, B: TValue): Boolean; override;\r\n function CreateEmptyArrayList(ACapacity: Integer; AOwnsObjects: Boolean): IJclCollection; override;\r\n function CreateEmptyContainer: TJclAbstractContainerBase; override;\r\n function CreateEmptyArraySet(ACapacity: Integer; AOwnsObjects: Boolean): IJclSet; override;\r\n end;\r\n\r\n //DOM-IGNORE-END\r\n {$ENDIF SUPPORTS_GENERICS}\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jcl.svn.sourceforge.net/svnroot/jcl/tags/JCL-2.4-Build4571/jcl/source/common/JclHashMaps.pas $';\r\n Revision: '$Revision: 3755 $';\r\n Date: '$Date: 2012-03-03 11:17:49 +0100 (sam. 03 mars 2012) $';\r\n LogPath: 'JCL\\source\\common';\r\n Extra: '';\r\n Data: nil\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n {$IFDEF HAS_UNITSCOPE}\r\n System.SysUtils,\r\n {$ELSE ~HAS_UNITSCOPE}\r\n SysUtils,\r\n {$ENDIF ~HAS_UNITSCOPE}\r\n JclResources;\r\n\r\n//=== { TJclIntfIntfHashMapBucket } ==========================================\r\n\r\nprocedure TJclIntfIntfHashMapBucket.FinalizeArrayBeforeMove(var List: TJclIntfIntfHashMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\nbegin\r\n Assert(Count > 0);\r\n if FromIndex < ToIndex then\r\n begin\r\n if Count > (ToIndex - FromIndex) then\r\n Finalize(List[FromIndex + Count], ToIndex - FromIndex)\r\n else\r\n Finalize(List[ToIndex], Count);\r\n end\r\n else\r\n if FromIndex > ToIndex then\r\n begin\r\n if Count > (FromIndex - ToIndex) then\r\n Count := FromIndex - ToIndex;\r\n Finalize(List[ToIndex], Count)\r\n end;\r\nend;\r\n\r\nprocedure TJclIntfIntfHashMapBucket.InitializeArray(var List: TJclIntfIntfHashMapEntryArray; FromIndex, Count: SizeInt);\r\nbegin\r\n {$IFDEF FPC}\r\n while Count > 0 do\r\n begin\r\n Initialize(List[FromIndex]);\r\n Inc(FromIndex);\r\n Dec(Count);\r\n end;\r\n {$ELSE ~FPC}\r\n Initialize(List[FromIndex], Count);\r\n {$ENDIF ~FPC}\r\nend;\r\n\r\nprocedure TJclIntfIntfHashMapBucket.InitializeArrayAfterMove(var List: TJclIntfIntfHashMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\nbegin\r\n { Keep reference counting working }\r\n if FromIndex < ToIndex then\r\n begin\r\n if (ToIndex - FromIndex) < Count then\r\n Count := ToIndex - FromIndex;\r\n InitializeArray(List, FromIndex, Count);\r\n end\r\n else\r\n if FromIndex > ToIndex then\r\n begin\r\n if (FromIndex - ToIndex) < Count then\r\n InitializeArray(List, ToIndex + Count, FromIndex - ToIndex)\r\n else\r\n InitializeArray(List, FromIndex, Count);\r\n end;\r\nend;\r\n\r\nprocedure TJclIntfIntfHashMapBucket.MoveArray(var List: TJclIntfIntfHashMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\nbegin\r\n if Count > 0 then\r\n begin\r\n FinalizeArrayBeforeMove(List, FromIndex, ToIndex, Count);\r\n Move(List[FromIndex], List[ToIndex], Count * SizeOf(List[0]));\r\n InitializeArrayAfterMove(List, FromIndex, ToIndex, Count);\r\n end;\r\nend;\r\n\r\n//=== { TJclIntfIntfHashMap } ==========================================\r\n\r\nconstructor TJclIntfIntfHashMap.Create(ACapacity: Integer);\r\nbegin\r\n inherited Create;\r\n SetCapacity(ACapacity);\r\n FHashToRangeFunction := JclSimpleHashToRange;\r\nend;\r\n\r\ndestructor TJclIntfIntfHashMap.Destroy;\r\nbegin\r\n FReadOnly := False;\r\n Clear;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJclIntfIntfHashMap.AssignDataTo(Dest: TJclAbstractContainerBase);\r\nvar\r\n I, J: Integer;\r\n SelfBucket, NewBucket: TJclIntfIntfHashMapBucket;\r\n ADest: TJclIntfIntfHashMap;\r\n AMap: IJclIntfIntfMap;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n inherited AssignDataTo(Dest);\r\n if Dest is TJclIntfIntfHashMap then\r\n begin\r\n ADest := TJclIntfIntfHashMap(Dest);\r\n ADest.Clear;\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n SelfBucket := FBuckets[I];\r\n if SelfBucket <> nil then\r\n begin\r\n NewBucket := TJclIntfIntfHashMapBucket.Create;\r\n SetLength(NewBucket.Entries, SelfBucket.Size);\r\n for J := 0 to SelfBucket.Size - 1 do\r\n begin\r\n NewBucket.Entries[J].Key := SelfBucket.Entries[J].Key;\r\n NewBucket.Entries[J].Value := SelfBucket.Entries[J].Value;\r\n end;\r\n NewBucket.Size := SelfBucket.Size;\r\n ADest.FBuckets[I] := NewBucket;\r\n end;\r\n end;\r\n end\r\n else\r\n if Supports(IInterface(Dest), IJclIntfIntfMap, AMap) then\r\n begin\r\n AMap.Clear;\r\n AMap.PutAll(Self);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclIntfIntfHashMap.AssignPropertiesTo(Dest: TJclAbstractContainerBase);\r\nbegin\r\n inherited AssignPropertiesto(Dest);\r\n if Dest is TJclIntfIntfHashMap then\r\n TJclIntfIntfHashMap(Dest).FHashToRangeFunction := FHashToRangeFunction;\r\nend;\r\n\r\nprocedure TJclIntfIntfHashMap.Clear;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclIntfIntfHashMapBucket;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n begin\r\n for J := 0 to Bucket.Size - 1 do\r\n begin\r\n FreeKey(Bucket.Entries[J].Key);\r\n FreeValue(Bucket.Entries[J].Value);\r\n end;\r\n FreeAndNil(FBuckets[I]);\r\n end;\r\n end;\r\n FSize := 0;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfIntfHashMap.ContainsKey(const Key: IInterface): Boolean;\r\nvar\r\n I: Integer;\r\n Bucket: TJclIntfIntfHashMapBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n Bucket := FBuckets[FHashToRangeFunction(Hash(Key), FCapacity)];\r\n if Bucket <> nil then\r\n for I := 0 to Bucket.Size - 1 do\r\n if KeysEqual(Bucket.Entries[I].Key, Key) then\r\n begin\r\n Result := True;\r\n Break;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfIntfHashMap.ContainsValue(const Value: IInterface): Boolean;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclIntfIntfHashMapBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n for J := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[J];\r\n if Bucket <> nil then\r\n for I := 0 to Bucket.Size - 1 do\r\n if ValuesEqual(Bucket.Entries[I].Value, Value) then\r\n begin\r\n Result := True;\r\n Break;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfIntfHashMap.Extract(const Key: IInterface): IInterface;\r\nvar\r\n Bucket: TJclIntfIntfHashMapBucket;\r\n I, NewCapacity: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := nil;\r\n Bucket := FBuckets[FHashToRangeFunction(Hash(Key), FCapacity)];\r\n if Bucket <> nil then\r\n begin\r\n for I := 0 to Bucket.Size - 1 do\r\n if KeysEqual(Bucket.Entries[I].Key, Key) then\r\n begin\r\n Result := Bucket.Entries[I].Value;\r\n Bucket.Entries[I].Value := nil;\r\n FreeKey(Bucket.Entries[I].Key);\r\n if I < Length(Bucket.Entries) - 1 then\r\n Bucket.MoveArray(Bucket.Entries, I + 1, I, Bucket.Size - I - 1);\r\n Dec(Bucket.Size);\r\n Dec(FSize);\r\n Break;\r\n end;\r\n\r\n NewCapacity := CalcPackCapacity(Length(Bucket.Entries), Bucket.Size);\r\n if NewCapacity < Length(Bucket.Entries) then\r\n SetLength(Bucket.Entries, NewCapacity);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfIntfHashMap.GetValue(const Key: IInterface): IInterface;\r\nvar\r\n I: Integer;\r\n Bucket: TJclIntfIntfHashMapBucket;\r\n Found: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Found := False;\r\n Result := nil;\r\n Bucket := FBuckets[FHashToRangeFunction(Hash(Key), FCapacity)];\r\n if Bucket <> nil then\r\n for I := 0 to Bucket.Size - 1 do\r\n if KeysEqual(Bucket.Entries[I].Key, Key) then\r\n begin\r\n Result := Bucket.Entries[I].Value;\r\n Found := True;\r\n Break;\r\n end;\r\n if (not Found) and (not FReturnDefaultElements) then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfIntfHashMap.IsEmpty: Boolean;\r\nbegin\r\n Result := FSize = 0;\r\nend;\r\n\r\nfunction TJclIntfIntfHashMap.KeyOfValue(const Value: IInterface): IInterface;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclIntfIntfHashMapBucket;\r\n Found: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Found := False;\r\n Result := nil;\r\n for J := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[J];\r\n if Bucket <> nil then\r\n for I := 0 to Bucket.Size - 1 do\r\n if ValuesEqual(Bucket.Entries[I].Value, Value) then\r\n begin\r\n Result := Bucket.Entries[I].Key;\r\n Found := True;\r\n Break;\r\n end;\r\n end;\r\n if (not Found) and (not FReturnDefaultElements) then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfIntfHashMap.KeySet: IJclIntfSet;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclIntfIntfHashMapBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := TJclIntfArraySet.Create(FSize);\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n for J := 0 to Bucket.Size - 1 do\r\n Result.Add(Bucket.Entries[J].Key);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfIntfHashMap.MapEquals(const AMap: IJclIntfIntfMap): Boolean;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclIntfIntfHashMapBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if AMap = nil then\r\n Exit;\r\n if FSize <> AMap.Size then\r\n Exit;\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n for J := 0 to Bucket.Size - 1 do\r\n if AMap.ContainsKey(Bucket.Entries[J].Key) then\r\n begin\r\n if not ValuesEqual(AMap.GetValue(Bucket.Entries[J].Key), Bucket.Entries[J].Value) then\r\n Exit;\r\n end\r\n else\r\n Exit;\r\n end;\r\n Result := True;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclIntfIntfHashMap.Pack;\r\nvar\r\n I: Integer;\r\n Bucket: TJclIntfIntfHashMapBucket;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n begin\r\n if Bucket.Size > 0 then\r\n SetLength(Bucket.Entries, Bucket.Size)\r\n else\r\n FreeAndNil(FBuckets[I]);\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclIntfIntfHashMap.PutAll(const AMap: IJclIntfIntfMap);\r\nvar\r\n It: IJclIntfIterator;\r\n Key: IInterface;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if AMap = nil then\r\n Exit;\r\n It := AMap.KeySet.First;\r\n while It.HasNext do\r\n begin\r\n Key := It.Next;\r\n PutValue(Key, AMap.GetValue(Key));\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclIntfIntfHashMap.PutValue(const Key: IInterface; const Value: IInterface);\r\nvar\r\n Index: Integer;\r\n Bucket: TJclIntfIntfHashMapBucket;\r\n I: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FAllowDefaultElements or (not KeysEqual(Key, nil) and not ValuesEqual(Value, nil)) then\r\n begin\r\n Index := FHashToRangeFunction(Hash(Key), FCapacity);\r\n Bucket := FBuckets[Index];\r\n if Bucket <> nil then\r\n begin\r\n for I := 0 to Bucket.Size - 1 do\r\n if KeysEqual(Bucket.Entries[I].Key, Key) then\r\n begin\r\n FreeValue(Bucket.Entries[I].Value);\r\n Bucket.Entries[I].Value := Value;\r\n Exit;\r\n end;\r\n end\r\n else\r\n begin\r\n Bucket := TJclIntfIntfHashMapBucket.Create;\r\n SetLength(Bucket.Entries, 1);\r\n FBuckets[Index] := Bucket;\r\n end;\r\n\r\n if Bucket.Size = Length(Bucket.Entries) then\r\n SetLength(Bucket.Entries, CalcGrowCapacity(Bucket.Size, Bucket.Size));\r\n\r\n if Bucket.Size < Length(Bucket.Entries) then\r\n begin\r\n Bucket.Entries[Bucket.Size].Key := Key;\r\n Bucket.Entries[Bucket.Size].Value := Value;\r\n Inc(Bucket.Size);\r\n Inc(FSize);\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfIntfHashMap.Remove(const Key: IInterface): IInterface;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := Extract(Key);\r\n Result := FreeValue(Result);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclIntfIntfHashMap.SetCapacity(Value: Integer);\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FSize = 0 then\r\n begin\r\n SetLength(FBuckets, Value);\r\n inherited SetCapacity(Value);\r\n end\r\n else\r\n raise EJclOperationNotSupportedError.Create;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfIntfHashMap.Size: Integer;\r\nbegin\r\n Result := FSize;\r\nend;\r\n\r\nfunction TJclIntfIntfHashMap.Values: IJclIntfCollection;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclIntfIntfHashMapBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := TJclIntfArrayList.Create(FSize);\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n for J := 0 to Bucket.Size - 1 do\r\n Result.Add(Bucket.Entries[J].Value);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfIntfHashMap.CreateEmptyContainer: TJclAbstractContainerBase;\r\nbegin\r\n Result := TJclIntfIntfHashMap.Create(FCapacity);\r\n AssignPropertiesTo(Result);\r\nend;\r\n\r\nfunction TJclIntfIntfHashMap.FreeKey(var Key: IInterface): IInterface;\r\nbegin\r\n Result := Key;\r\n Key := nil;\r\nend;\r\n\r\nfunction TJclIntfIntfHashMap.FreeValue(var Value: IInterface): IInterface;\r\nbegin\r\n Result := Value;\r\n Value := nil;\r\nend;\r\n\r\nfunction TJclIntfIntfHashMap.KeysEqual(const A, B: IInterface): Boolean;\r\nbegin\r\n Result := ItemsEqual(A, B);\r\nend;\r\n\r\nfunction TJclIntfIntfHashMap.ValuesEqual(const A, B: IInterface): Boolean;\r\nbegin\r\n Result := ItemsEqual(A, B);\r\nend;\r\n\r\n//=== { TJclAnsiStrIntfHashMapBucket } ==========================================\r\n\r\nprocedure TJclAnsiStrIntfHashMapBucket.FinalizeArrayBeforeMove(var List: TJclAnsiStrIntfHashMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\nbegin\r\n Assert(Count > 0);\r\n if FromIndex < ToIndex then\r\n begin\r\n if Count > (ToIndex - FromIndex) then\r\n Finalize(List[FromIndex + Count], ToIndex - FromIndex)\r\n else\r\n Finalize(List[ToIndex], Count);\r\n end\r\n else\r\n if FromIndex > ToIndex then\r\n begin\r\n if Count > (FromIndex - ToIndex) then\r\n Count := FromIndex - ToIndex;\r\n Finalize(List[ToIndex], Count)\r\n end;\r\nend;\r\n\r\nprocedure TJclAnsiStrIntfHashMapBucket.InitializeArray(var List: TJclAnsiStrIntfHashMapEntryArray; FromIndex, Count: SizeInt);\r\nbegin\r\n {$IFDEF FPC}\r\n while Count > 0 do\r\n begin\r\n Initialize(List[FromIndex]);\r\n Inc(FromIndex);\r\n Dec(Count);\r\n end;\r\n {$ELSE ~FPC}\r\n Initialize(List[FromIndex], Count);\r\n {$ENDIF ~FPC}\r\nend;\r\n\r\nprocedure TJclAnsiStrIntfHashMapBucket.InitializeArrayAfterMove(var List: TJclAnsiStrIntfHashMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\nbegin\r\n { Keep reference counting working }\r\n if FromIndex < ToIndex then\r\n begin\r\n if (ToIndex - FromIndex) < Count then\r\n Count := ToIndex - FromIndex;\r\n InitializeArray(List, FromIndex, Count);\r\n end\r\n else\r\n if FromIndex > ToIndex then\r\n begin\r\n if (FromIndex - ToIndex) < Count then\r\n InitializeArray(List, ToIndex + Count, FromIndex - ToIndex)\r\n else\r\n InitializeArray(List, FromIndex, Count);\r\n end;\r\nend;\r\n\r\nprocedure TJclAnsiStrIntfHashMapBucket.MoveArray(var List: TJclAnsiStrIntfHashMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\nbegin\r\n if Count > 0 then\r\n begin\r\n FinalizeArrayBeforeMove(List, FromIndex, ToIndex, Count);\r\n Move(List[FromIndex], List[ToIndex], Count * SizeOf(List[0]));\r\n InitializeArrayAfterMove(List, FromIndex, ToIndex, Count);\r\n end;\r\nend;\r\n\r\n//=== { TJclAnsiStrIntfHashMap } ==========================================\r\n\r\nconstructor TJclAnsiStrIntfHashMap.Create(ACapacity: Integer);\r\nbegin\r\n inherited Create;\r\n SetCapacity(ACapacity);\r\n FHashToRangeFunction := JclSimpleHashToRange;\r\nend;\r\n\r\ndestructor TJclAnsiStrIntfHashMap.Destroy;\r\nbegin\r\n FReadOnly := False;\r\n Clear;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJclAnsiStrIntfHashMap.AssignDataTo(Dest: TJclAbstractContainerBase);\r\nvar\r\n I, J: Integer;\r\n SelfBucket, NewBucket: TJclAnsiStrIntfHashMapBucket;\r\n ADest: TJclAnsiStrIntfHashMap;\r\n AMap: IJclAnsiStrIntfMap;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n inherited AssignDataTo(Dest);\r\n if Dest is TJclAnsiStrIntfHashMap then\r\n begin\r\n ADest := TJclAnsiStrIntfHashMap(Dest);\r\n ADest.Clear;\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n SelfBucket := FBuckets[I];\r\n if SelfBucket <> nil then\r\n begin\r\n NewBucket := TJclAnsiStrIntfHashMapBucket.Create;\r\n SetLength(NewBucket.Entries, SelfBucket.Size);\r\n for J := 0 to SelfBucket.Size - 1 do\r\n begin\r\n NewBucket.Entries[J].Key := SelfBucket.Entries[J].Key;\r\n NewBucket.Entries[J].Value := SelfBucket.Entries[J].Value;\r\n end;\r\n NewBucket.Size := SelfBucket.Size;\r\n ADest.FBuckets[I] := NewBucket;\r\n end;\r\n end;\r\n end\r\n else\r\n if Supports(IInterface(Dest), IJclAnsiStrIntfMap, AMap) then\r\n begin\r\n AMap.Clear;\r\n AMap.PutAll(Self);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclAnsiStrIntfHashMap.AssignPropertiesTo(Dest: TJclAbstractContainerBase);\r\nbegin\r\n inherited AssignPropertiesto(Dest);\r\n if Dest is TJclAnsiStrIntfHashMap then\r\n TJclAnsiStrIntfHashMap(Dest).FHashToRangeFunction := FHashToRangeFunction;\r\nend;\r\n\r\nprocedure TJclAnsiStrIntfHashMap.Clear;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclAnsiStrIntfHashMapBucket;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n begin\r\n for J := 0 to Bucket.Size - 1 do\r\n begin\r\n FreeKey(Bucket.Entries[J].Key);\r\n FreeValue(Bucket.Entries[J].Value);\r\n end;\r\n FreeAndNil(FBuckets[I]);\r\n end;\r\n end;\r\n FSize := 0;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclAnsiStrIntfHashMap.ContainsKey(const Key: AnsiString): Boolean;\r\nvar\r\n I: Integer;\r\n Bucket: TJclAnsiStrIntfHashMapBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n Bucket := FBuckets[FHashToRangeFunction(Hash(Key), FCapacity)];\r\n if Bucket <> nil then\r\n for I := 0 to Bucket.Size - 1 do\r\n if KeysEqual(Bucket.Entries[I].Key, Key) then\r\n begin\r\n Result := True;\r\n Break;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclAnsiStrIntfHashMap.ContainsValue(const Value: IInterface): Boolean;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclAnsiStrIntfHashMapBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n for J := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[J];\r\n if Bucket <> nil then\r\n for I := 0 to Bucket.Size - 1 do\r\n if ValuesEqual(Bucket.Entries[I].Value, Value) then\r\n begin\r\n Result := True;\r\n Break;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclAnsiStrIntfHashMap.Extract(const Key: AnsiString): IInterface;\r\nvar\r\n Bucket: TJclAnsiStrIntfHashMapBucket;\r\n I, NewCapacity: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := nil;\r\n Bucket := FBuckets[FHashToRangeFunction(Hash(Key), FCapacity)];\r\n if Bucket <> nil then\r\n begin\r\n for I := 0 to Bucket.Size - 1 do\r\n if KeysEqual(Bucket.Entries[I].Key, Key) then\r\n begin\r\n Result := Bucket.Entries[I].Value;\r\n Bucket.Entries[I].Value := nil;\r\n FreeKey(Bucket.Entries[I].Key);\r\n if I < Length(Bucket.Entries) - 1 then\r\n Bucket.MoveArray(Bucket.Entries, I + 1, I, Bucket.Size - I - 1);\r\n Dec(Bucket.Size);\r\n Dec(FSize);\r\n Break;\r\n end;\r\n\r\n NewCapacity := CalcPackCapacity(Length(Bucket.Entries), Bucket.Size);\r\n if NewCapacity < Length(Bucket.Entries) then\r\n SetLength(Bucket.Entries, NewCapacity);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclAnsiStrIntfHashMap.GetValue(const Key: AnsiString): IInterface;\r\nvar\r\n I: Integer;\r\n Bucket: TJclAnsiStrIntfHashMapBucket;\r\n Found: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Found := False;\r\n Result := nil;\r\n Bucket := FBuckets[FHashToRangeFunction(Hash(Key), FCapacity)];\r\n if Bucket <> nil then\r\n for I := 0 to Bucket.Size - 1 do\r\n if KeysEqual(Bucket.Entries[I].Key, Key) then\r\n begin\r\n Result := Bucket.Entries[I].Value;\r\n Found := True;\r\n Break;\r\n end;\r\n if (not Found) and (not FReturnDefaultElements) then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclAnsiStrIntfHashMap.IsEmpty: Boolean;\r\nbegin\r\n Result := FSize = 0;\r\nend;\r\n\r\nfunction TJclAnsiStrIntfHashMap.KeyOfValue(const Value: IInterface): AnsiString;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclAnsiStrIntfHashMapBucket;\r\n Found: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Found := False;\r\n Result := '';\r\n for J := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[J];\r\n if Bucket <> nil then\r\n for I := 0 to Bucket.Size - 1 do\r\n if ValuesEqual(Bucket.Entries[I].Value, Value) then\r\n begin\r\n Result := Bucket.Entries[I].Key;\r\n Found := True;\r\n Break;\r\n end;\r\n end;\r\n if (not Found) and (not FReturnDefaultElements) then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclAnsiStrIntfHashMap.KeySet: IJclAnsiStrSet;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclAnsiStrIntfHashMapBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := TJclAnsiStrArraySet.Create(FSize);\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n for J := 0 to Bucket.Size - 1 do\r\n Result.Add(Bucket.Entries[J].Key);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclAnsiStrIntfHashMap.MapEquals(const AMap: IJclAnsiStrIntfMap): Boolean;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclAnsiStrIntfHashMapBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if AMap = nil then\r\n Exit;\r\n if FSize <> AMap.Size then\r\n Exit;\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n for J := 0 to Bucket.Size - 1 do\r\n if AMap.ContainsKey(Bucket.Entries[J].Key) then\r\n begin\r\n if not ValuesEqual(AMap.GetValue(Bucket.Entries[J].Key), Bucket.Entries[J].Value) then\r\n Exit;\r\n end\r\n else\r\n Exit;\r\n end;\r\n Result := True;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclAnsiStrIntfHashMap.Pack;\r\nvar\r\n I: Integer;\r\n Bucket: TJclAnsiStrIntfHashMapBucket;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n begin\r\n if Bucket.Size > 0 then\r\n SetLength(Bucket.Entries, Bucket.Size)\r\n else\r\n FreeAndNil(FBuckets[I]);\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclAnsiStrIntfHashMap.PutAll(const AMap: IJclAnsiStrIntfMap);\r\nvar\r\n It: IJclAnsiStrIterator;\r\n Key: AnsiString;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if AMap = nil then\r\n Exit;\r\n It := AMap.KeySet.First;\r\n while It.HasNext do\r\n begin\r\n Key := It.Next;\r\n PutValue(Key, AMap.GetValue(Key));\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclAnsiStrIntfHashMap.PutValue(const Key: AnsiString; const Value: IInterface);\r\nvar\r\n Index: Integer;\r\n Bucket: TJclAnsiStrIntfHashMapBucket;\r\n I: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FAllowDefaultElements or (not KeysEqual(Key, '') and not ValuesEqual(Value, nil)) then\r\n begin\r\n Index := FHashToRangeFunction(Hash(Key), FCapacity);\r\n Bucket := FBuckets[Index];\r\n if Bucket <> nil then\r\n begin\r\n for I := 0 to Bucket.Size - 1 do\r\n if KeysEqual(Bucket.Entries[I].Key, Key) then\r\n begin\r\n FreeValue(Bucket.Entries[I].Value);\r\n Bucket.Entries[I].Value := Value;\r\n Exit;\r\n end;\r\n end\r\n else\r\n begin\r\n Bucket := TJclAnsiStrIntfHashMapBucket.Create;\r\n SetLength(Bucket.Entries, 1);\r\n FBuckets[Index] := Bucket;\r\n end;\r\n\r\n if Bucket.Size = Length(Bucket.Entries) then\r\n SetLength(Bucket.Entries, CalcGrowCapacity(Bucket.Size, Bucket.Size));\r\n\r\n if Bucket.Size < Length(Bucket.Entries) then\r\n begin\r\n Bucket.Entries[Bucket.Size].Key := Key;\r\n Bucket.Entries[Bucket.Size].Value := Value;\r\n Inc(Bucket.Size);\r\n Inc(FSize);\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclAnsiStrIntfHashMap.Remove(const Key: AnsiString): IInterface;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := Extract(Key);\r\n Result := FreeValue(Result);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclAnsiStrIntfHashMap.SetCapacity(Value: Integer);\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FSize = 0 then\r\n begin\r\n SetLength(FBuckets, Value);\r\n inherited SetCapacity(Value);\r\n end\r\n else\r\n raise EJclOperationNotSupportedError.Create;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclAnsiStrIntfHashMap.Size: Integer;\r\nbegin\r\n Result := FSize;\r\nend;\r\n\r\nfunction TJclAnsiStrIntfHashMap.Values: IJclIntfCollection;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclAnsiStrIntfHashMapBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := TJclIntfArrayList.Create(FSize);\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n for J := 0 to Bucket.Size - 1 do\r\n Result.Add(Bucket.Entries[J].Value);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclAnsiStrIntfHashMap.CreateEmptyContainer: TJclAbstractContainerBase;\r\nbegin\r\n Result := TJclAnsiStrIntfHashMap.Create(FCapacity);\r\n AssignPropertiesTo(Result);\r\nend;\r\n\r\nfunction TJclAnsiStrIntfHashMap.FreeKey(var Key: AnsiString): AnsiString;\r\nbegin\r\n Result := Key;\r\n Key := '';\r\nend;\r\n\r\nfunction TJclAnsiStrIntfHashMap.FreeValue(var Value: IInterface): IInterface;\r\nbegin\r\n Result := Value;\r\n Value := nil;\r\nend;\r\n\r\nfunction TJclAnsiStrIntfHashMap.KeysEqual(const A, B: AnsiString): Boolean;\r\nbegin\r\n Result := ItemsEqual(A, B);\r\nend;\r\n\r\nfunction TJclAnsiStrIntfHashMap.ValuesEqual(const A, B: IInterface): Boolean;\r\nbegin\r\n Result := IntfSimpleEqualityCompare(A, B);\r\nend;\r\n\r\n//=== { TJclIntfAnsiStrHashMapBucket } ==========================================\r\n\r\nprocedure TJclIntfAnsiStrHashMapBucket.FinalizeArrayBeforeMove(var List: TJclIntfAnsiStrHashMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\nbegin\r\n Assert(Count > 0);\r\n if FromIndex < ToIndex then\r\n begin\r\n if Count > (ToIndex - FromIndex) then\r\n Finalize(List[FromIndex + Count], ToIndex - FromIndex)\r\n else\r\n Finalize(List[ToIndex], Count);\r\n end\r\n else\r\n if FromIndex > ToIndex then\r\n begin\r\n if Count > (FromIndex - ToIndex) then\r\n Count := FromIndex - ToIndex;\r\n Finalize(List[ToIndex], Count)\r\n end;\r\nend;\r\n\r\nprocedure TJclIntfAnsiStrHashMapBucket.InitializeArray(var List: TJclIntfAnsiStrHashMapEntryArray; FromIndex, Count: SizeInt);\r\nbegin\r\n {$IFDEF FPC}\r\n while Count > 0 do\r\n begin\r\n Initialize(List[FromIndex]);\r\n Inc(FromIndex);\r\n Dec(Count);\r\n end;\r\n {$ELSE ~FPC}\r\n Initialize(List[FromIndex], Count);\r\n {$ENDIF ~FPC}\r\nend;\r\n\r\nprocedure TJclIntfAnsiStrHashMapBucket.InitializeArrayAfterMove(var List: TJclIntfAnsiStrHashMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\nbegin\r\n { Keep reference counting working }\r\n if FromIndex < ToIndex then\r\n begin\r\n if (ToIndex - FromIndex) < Count then\r\n Count := ToIndex - FromIndex;\r\n InitializeArray(List, FromIndex, Count);\r\n end\r\n else\r\n if FromIndex > ToIndex then\r\n begin\r\n if (FromIndex - ToIndex) < Count then\r\n InitializeArray(List, ToIndex + Count, FromIndex - ToIndex)\r\n else\r\n InitializeArray(List, FromIndex, Count);\r\n end;\r\nend;\r\n\r\nprocedure TJclIntfAnsiStrHashMapBucket.MoveArray(var List: TJclIntfAnsiStrHashMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\nbegin\r\n if Count > 0 then\r\n begin\r\n FinalizeArrayBeforeMove(List, FromIndex, ToIndex, Count);\r\n Move(List[FromIndex], List[ToIndex], Count * SizeOf(List[0]));\r\n InitializeArrayAfterMove(List, FromIndex, ToIndex, Count);\r\n end;\r\nend;\r\n\r\n//=== { TJclIntfAnsiStrHashMap } ==========================================\r\n\r\nconstructor TJclIntfAnsiStrHashMap.Create(ACapacity: Integer);\r\nbegin\r\n inherited Create;\r\n SetCapacity(ACapacity);\r\n FHashToRangeFunction := JclSimpleHashToRange;\r\nend;\r\n\r\ndestructor TJclIntfAnsiStrHashMap.Destroy;\r\nbegin\r\n FReadOnly := False;\r\n Clear;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJclIntfAnsiStrHashMap.AssignDataTo(Dest: TJclAbstractContainerBase);\r\nvar\r\n I, J: Integer;\r\n SelfBucket, NewBucket: TJclIntfAnsiStrHashMapBucket;\r\n ADest: TJclIntfAnsiStrHashMap;\r\n AMap: IJclIntfAnsiStrMap;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n inherited AssignDataTo(Dest);\r\n if Dest is TJclIntfAnsiStrHashMap then\r\n begin\r\n ADest := TJclIntfAnsiStrHashMap(Dest);\r\n ADest.Clear;\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n SelfBucket := FBuckets[I];\r\n if SelfBucket <> nil then\r\n begin\r\n NewBucket := TJclIntfAnsiStrHashMapBucket.Create;\r\n SetLength(NewBucket.Entries, SelfBucket.Size);\r\n for J := 0 to SelfBucket.Size - 1 do\r\n begin\r\n NewBucket.Entries[J].Key := SelfBucket.Entries[J].Key;\r\n NewBucket.Entries[J].Value := SelfBucket.Entries[J].Value;\r\n end;\r\n NewBucket.Size := SelfBucket.Size;\r\n ADest.FBuckets[I] := NewBucket;\r\n end;\r\n end;\r\n end\r\n else\r\n if Supports(IInterface(Dest), IJclIntfAnsiStrMap, AMap) then\r\n begin\r\n AMap.Clear;\r\n AMap.PutAll(Self);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclIntfAnsiStrHashMap.AssignPropertiesTo(Dest: TJclAbstractContainerBase);\r\nbegin\r\n inherited AssignPropertiesto(Dest);\r\n if Dest is TJclIntfAnsiStrHashMap then\r\n TJclIntfAnsiStrHashMap(Dest).FHashToRangeFunction := FHashToRangeFunction;\r\nend;\r\n\r\nprocedure TJclIntfAnsiStrHashMap.Clear;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclIntfAnsiStrHashMapBucket;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n begin\r\n for J := 0 to Bucket.Size - 1 do\r\n begin\r\n FreeKey(Bucket.Entries[J].Key);\r\n FreeValue(Bucket.Entries[J].Value);\r\n end;\r\n FreeAndNil(FBuckets[I]);\r\n end;\r\n end;\r\n FSize := 0;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfAnsiStrHashMap.ContainsKey(const Key: IInterface): Boolean;\r\nvar\r\n I: Integer;\r\n Bucket: TJclIntfAnsiStrHashMapBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n Bucket := FBuckets[FHashToRangeFunction(Hash(Key), FCapacity)];\r\n if Bucket <> nil then\r\n for I := 0 to Bucket.Size - 1 do\r\n if KeysEqual(Bucket.Entries[I].Key, Key) then\r\n begin\r\n Result := True;\r\n Break;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfAnsiStrHashMap.ContainsValue(const Value: AnsiString): Boolean;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclIntfAnsiStrHashMapBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n for J := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[J];\r\n if Bucket <> nil then\r\n for I := 0 to Bucket.Size - 1 do\r\n if ValuesEqual(Bucket.Entries[I].Value, Value) then\r\n begin\r\n Result := True;\r\n Break;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfAnsiStrHashMap.Extract(const Key: IInterface): AnsiString;\r\nvar\r\n Bucket: TJclIntfAnsiStrHashMapBucket;\r\n I, NewCapacity: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := '';\r\n Bucket := FBuckets[FHashToRangeFunction(Hash(Key), FCapacity)];\r\n if Bucket <> nil then\r\n begin\r\n for I := 0 to Bucket.Size - 1 do\r\n if KeysEqual(Bucket.Entries[I].Key, Key) then\r\n begin\r\n Result := Bucket.Entries[I].Value;\r\n Bucket.Entries[I].Value := '';\r\n FreeKey(Bucket.Entries[I].Key);\r\n if I < Length(Bucket.Entries) - 1 then\r\n Bucket.MoveArray(Bucket.Entries, I + 1, I, Bucket.Size - I - 1);\r\n Dec(Bucket.Size);\r\n Dec(FSize);\r\n Break;\r\n end;\r\n\r\n NewCapacity := CalcPackCapacity(Length(Bucket.Entries), Bucket.Size);\r\n if NewCapacity < Length(Bucket.Entries) then\r\n SetLength(Bucket.Entries, NewCapacity);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfAnsiStrHashMap.GetValue(const Key: IInterface): AnsiString;\r\nvar\r\n I: Integer;\r\n Bucket: TJclIntfAnsiStrHashMapBucket;\r\n Found: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Found := False;\r\n Result := '';\r\n Bucket := FBuckets[FHashToRangeFunction(Hash(Key), FCapacity)];\r\n if Bucket <> nil then\r\n for I := 0 to Bucket.Size - 1 do\r\n if KeysEqual(Bucket.Entries[I].Key, Key) then\r\n begin\r\n Result := Bucket.Entries[I].Value;\r\n Found := True;\r\n Break;\r\n end;\r\n if (not Found) and (not FReturnDefaultElements) then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfAnsiStrHashMap.IsEmpty: Boolean;\r\nbegin\r\n Result := FSize = 0;\r\nend;\r\n\r\nfunction TJclIntfAnsiStrHashMap.KeyOfValue(const Value: AnsiString): IInterface;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclIntfAnsiStrHashMapBucket;\r\n Found: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Found := False;\r\n Result := nil;\r\n for J := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[J];\r\n if Bucket <> nil then\r\n for I := 0 to Bucket.Size - 1 do\r\n if ValuesEqual(Bucket.Entries[I].Value, Value) then\r\n begin\r\n Result := Bucket.Entries[I].Key;\r\n Found := True;\r\n Break;\r\n end;\r\n end;\r\n if (not Found) and (not FReturnDefaultElements) then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfAnsiStrHashMap.KeySet: IJclIntfSet;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclIntfAnsiStrHashMapBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := TJclIntfArraySet.Create(FSize);\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n for J := 0 to Bucket.Size - 1 do\r\n Result.Add(Bucket.Entries[J].Key);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfAnsiStrHashMap.MapEquals(const AMap: IJclIntfAnsiStrMap): Boolean;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclIntfAnsiStrHashMapBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if AMap = nil then\r\n Exit;\r\n if FSize <> AMap.Size then\r\n Exit;\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n for J := 0 to Bucket.Size - 1 do\r\n if AMap.ContainsKey(Bucket.Entries[J].Key) then\r\n begin\r\n if not ValuesEqual(AMap.GetValue(Bucket.Entries[J].Key), Bucket.Entries[J].Value) then\r\n Exit;\r\n end\r\n else\r\n Exit;\r\n end;\r\n Result := True;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclIntfAnsiStrHashMap.Pack;\r\nvar\r\n I: Integer;\r\n Bucket: TJclIntfAnsiStrHashMapBucket;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n begin\r\n if Bucket.Size > 0 then\r\n SetLength(Bucket.Entries, Bucket.Size)\r\n else\r\n FreeAndNil(FBuckets[I]);\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclIntfAnsiStrHashMap.PutAll(const AMap: IJclIntfAnsiStrMap);\r\nvar\r\n It: IJclIntfIterator;\r\n Key: IInterface;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if AMap = nil then\r\n Exit;\r\n It := AMap.KeySet.First;\r\n while It.HasNext do\r\n begin\r\n Key := It.Next;\r\n PutValue(Key, AMap.GetValue(Key));\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclIntfAnsiStrHashMap.PutValue(const Key: IInterface; const Value: AnsiString);\r\nvar\r\n Index: Integer;\r\n Bucket: TJclIntfAnsiStrHashMapBucket;\r\n I: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FAllowDefaultElements or (not KeysEqual(Key, nil) and not ValuesEqual(Value, '')) then\r\n begin\r\n Index := FHashToRangeFunction(Hash(Key), FCapacity);\r\n Bucket := FBuckets[Index];\r\n if Bucket <> nil then\r\n begin\r\n for I := 0 to Bucket.Size - 1 do\r\n if KeysEqual(Bucket.Entries[I].Key, Key) then\r\n begin\r\n FreeValue(Bucket.Entries[I].Value);\r\n Bucket.Entries[I].Value := Value;\r\n Exit;\r\n end;\r\n end\r\n else\r\n begin\r\n Bucket := TJclIntfAnsiStrHashMapBucket.Create;\r\n SetLength(Bucket.Entries, 1);\r\n FBuckets[Index] := Bucket;\r\n end;\r\n\r\n if Bucket.Size = Length(Bucket.Entries) then\r\n SetLength(Bucket.Entries, CalcGrowCapacity(Bucket.Size, Bucket.Size));\r\n\r\n if Bucket.Size < Length(Bucket.Entries) then\r\n begin\r\n Bucket.Entries[Bucket.Size].Key := Key;\r\n Bucket.Entries[Bucket.Size].Value := Value;\r\n Inc(Bucket.Size);\r\n Inc(FSize);\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfAnsiStrHashMap.Remove(const Key: IInterface): AnsiString;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := Extract(Key);\r\n Result := FreeValue(Result);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclIntfAnsiStrHashMap.SetCapacity(Value: Integer);\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FSize = 0 then\r\n begin\r\n SetLength(FBuckets, Value);\r\n inherited SetCapacity(Value);\r\n end\r\n else\r\n raise EJclOperationNotSupportedError.Create;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfAnsiStrHashMap.Size: Integer;\r\nbegin\r\n Result := FSize;\r\nend;\r\n\r\nfunction TJclIntfAnsiStrHashMap.Values: IJclAnsiStrCollection;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclIntfAnsiStrHashMapBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := TJclAnsiStrArrayList.Create(FSize);\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n for J := 0 to Bucket.Size - 1 do\r\n Result.Add(Bucket.Entries[J].Value);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfAnsiStrHashMap.CreateEmptyContainer: TJclAbstractContainerBase;\r\nbegin\r\n Result := TJclIntfAnsiStrHashMap.Create(FCapacity);\r\n AssignPropertiesTo(Result);\r\nend;\r\n\r\nfunction TJclIntfAnsiStrHashMap.FreeKey(var Key: IInterface): IInterface;\r\nbegin\r\n Result := Key;\r\n Key := nil;\r\nend;\r\n\r\nfunction TJclIntfAnsiStrHashMap.FreeValue(var Value: AnsiString): AnsiString;\r\nbegin\r\n Result := Value;\r\n Value := '';\r\nend;\r\n\r\nfunction TJclIntfAnsiStrHashMap.Hash(const AInterface: IInterface): Integer;\r\nbegin\r\n Result := IntfSimpleHashConvert(AInterface);\r\nend;\r\n\r\nfunction TJclIntfAnsiStrHashMap.KeysEqual(const A, B: IInterface): Boolean;\r\nbegin\r\n Result := IntfSimpleEqualityCompare(A, B);\r\nend;\r\n\r\nfunction TJclIntfAnsiStrHashMap.ValuesEqual(const A, B: AnsiString): Boolean;\r\nbegin\r\n Result := ItemsEqual(A, B);\r\nend;\r\n\r\n//=== { TJclAnsiStrAnsiStrHashMapBucket } ==========================================\r\n\r\nprocedure TJclAnsiStrAnsiStrHashMapBucket.FinalizeArrayBeforeMove(var List: TJclAnsiStrAnsiStrHashMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\nbegin\r\n Assert(Count > 0);\r\n if FromIndex < ToIndex then\r\n begin\r\n if Count > (ToIndex - FromIndex) then\r\n Finalize(List[FromIndex + Count], ToIndex - FromIndex)\r\n else\r\n Finalize(List[ToIndex], Count);\r\n end\r\n else\r\n if FromIndex > ToIndex then\r\n begin\r\n if Count > (FromIndex - ToIndex) then\r\n Count := FromIndex - ToIndex;\r\n Finalize(List[ToIndex], Count)\r\n end;\r\nend;\r\n\r\nprocedure TJclAnsiStrAnsiStrHashMapBucket.InitializeArray(var List: TJclAnsiStrAnsiStrHashMapEntryArray; FromIndex, Count: SizeInt);\r\nbegin\r\n {$IFDEF FPC}\r\n while Count > 0 do\r\n begin\r\n Initialize(List[FromIndex]);\r\n Inc(FromIndex);\r\n Dec(Count);\r\n end;\r\n {$ELSE ~FPC}\r\n Initialize(List[FromIndex], Count);\r\n {$ENDIF ~FPC}\r\nend;\r\n\r\nprocedure TJclAnsiStrAnsiStrHashMapBucket.InitializeArrayAfterMove(var List: TJclAnsiStrAnsiStrHashMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\nbegin\r\n { Keep reference counting working }\r\n if FromIndex < ToIndex then\r\n begin\r\n if (ToIndex - FromIndex) < Count then\r\n Count := ToIndex - FromIndex;\r\n InitializeArray(List, FromIndex, Count);\r\n end\r\n else\r\n if FromIndex > ToIndex then\r\n begin\r\n if (FromIndex - ToIndex) < Count then\r\n InitializeArray(List, ToIndex + Count, FromIndex - ToIndex)\r\n else\r\n InitializeArray(List, FromIndex, Count);\r\n end;\r\nend;\r\n\r\nprocedure TJclAnsiStrAnsiStrHashMapBucket.MoveArray(var List: TJclAnsiStrAnsiStrHashMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\nbegin\r\n if Count > 0 then\r\n begin\r\n FinalizeArrayBeforeMove(List, FromIndex, ToIndex, Count);\r\n Move(List[FromIndex], List[ToIndex], Count * SizeOf(List[0]));\r\n InitializeArrayAfterMove(List, FromIndex, ToIndex, Count);\r\n end;\r\nend;\r\n\r\n//=== { TJclAnsiStrAnsiStrHashMap } ==========================================\r\n\r\nconstructor TJclAnsiStrAnsiStrHashMap.Create(ACapacity: Integer);\r\nbegin\r\n inherited Create;\r\n SetCapacity(ACapacity);\r\n FHashToRangeFunction := JclSimpleHashToRange;\r\nend;\r\n\r\ndestructor TJclAnsiStrAnsiStrHashMap.Destroy;\r\nbegin\r\n FReadOnly := False;\r\n Clear;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJclAnsiStrAnsiStrHashMap.AssignDataTo(Dest: TJclAbstractContainerBase);\r\nvar\r\n I, J: Integer;\r\n SelfBucket, NewBucket: TJclAnsiStrAnsiStrHashMapBucket;\r\n ADest: TJclAnsiStrAnsiStrHashMap;\r\n AMap: IJclAnsiStrAnsiStrMap;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n inherited AssignDataTo(Dest);\r\n if Dest is TJclAnsiStrAnsiStrHashMap then\r\n begin\r\n ADest := TJclAnsiStrAnsiStrHashMap(Dest);\r\n ADest.Clear;\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n SelfBucket := FBuckets[I];\r\n if SelfBucket <> nil then\r\n begin\r\n NewBucket := TJclAnsiStrAnsiStrHashMapBucket.Create;\r\n SetLength(NewBucket.Entries, SelfBucket.Size);\r\n for J := 0 to SelfBucket.Size - 1 do\r\n begin\r\n NewBucket.Entries[J].Key := SelfBucket.Entries[J].Key;\r\n NewBucket.Entries[J].Value := SelfBucket.Entries[J].Value;\r\n end;\r\n NewBucket.Size := SelfBucket.Size;\r\n ADest.FBuckets[I] := NewBucket;\r\n end;\r\n end;\r\n end\r\n else\r\n if Supports(IInterface(Dest), IJclAnsiStrAnsiStrMap, AMap) then\r\n begin\r\n AMap.Clear;\r\n AMap.PutAll(Self);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclAnsiStrAnsiStrHashMap.AssignPropertiesTo(Dest: TJclAbstractContainerBase);\r\nbegin\r\n inherited AssignPropertiesto(Dest);\r\n if Dest is TJclAnsiStrAnsiStrHashMap then\r\n TJclAnsiStrAnsiStrHashMap(Dest).FHashToRangeFunction := FHashToRangeFunction;\r\nend;\r\n\r\nprocedure TJclAnsiStrAnsiStrHashMap.Clear;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclAnsiStrAnsiStrHashMapBucket;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n begin\r\n for J := 0 to Bucket.Size - 1 do\r\n begin\r\n FreeKey(Bucket.Entries[J].Key);\r\n FreeValue(Bucket.Entries[J].Value);\r\n end;\r\n FreeAndNil(FBuckets[I]);\r\n end;\r\n end;\r\n FSize := 0;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclAnsiStrAnsiStrHashMap.ContainsKey(const Key: AnsiString): Boolean;\r\nvar\r\n I: Integer;\r\n Bucket: TJclAnsiStrAnsiStrHashMapBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n Bucket := FBuckets[FHashToRangeFunction(Hash(Key), FCapacity)];\r\n if Bucket <> nil then\r\n for I := 0 to Bucket.Size - 1 do\r\n if KeysEqual(Bucket.Entries[I].Key, Key) then\r\n begin\r\n Result := True;\r\n Break;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclAnsiStrAnsiStrHashMap.ContainsValue(const Value: AnsiString): Boolean;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclAnsiStrAnsiStrHashMapBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n for J := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[J];\r\n if Bucket <> nil then\r\n for I := 0 to Bucket.Size - 1 do\r\n if ValuesEqual(Bucket.Entries[I].Value, Value) then\r\n begin\r\n Result := True;\r\n Break;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclAnsiStrAnsiStrHashMap.Extract(const Key: AnsiString): AnsiString;\r\nvar\r\n Bucket: TJclAnsiStrAnsiStrHashMapBucket;\r\n I, NewCapacity: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := '';\r\n Bucket := FBuckets[FHashToRangeFunction(Hash(Key), FCapacity)];\r\n if Bucket <> nil then\r\n begin\r\n for I := 0 to Bucket.Size - 1 do\r\n if KeysEqual(Bucket.Entries[I].Key, Key) then\r\n begin\r\n Result := Bucket.Entries[I].Value;\r\n Bucket.Entries[I].Value := '';\r\n FreeKey(Bucket.Entries[I].Key);\r\n if I < Length(Bucket.Entries) - 1 then\r\n Bucket.MoveArray(Bucket.Entries, I + 1, I, Bucket.Size - I - 1);\r\n Dec(Bucket.Size);\r\n Dec(FSize);\r\n Break;\r\n end;\r\n\r\n NewCapacity := CalcPackCapacity(Length(Bucket.Entries), Bucket.Size);\r\n if NewCapacity < Length(Bucket.Entries) then\r\n SetLength(Bucket.Entries, NewCapacity);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclAnsiStrAnsiStrHashMap.GetValue(const Key: AnsiString): AnsiString;\r\nvar\r\n I: Integer;\r\n Bucket: TJclAnsiStrAnsiStrHashMapBucket;\r\n Found: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Found := False;\r\n Result := '';\r\n Bucket := FBuckets[FHashToRangeFunction(Hash(Key), FCapacity)];\r\n if Bucket <> nil then\r\n for I := 0 to Bucket.Size - 1 do\r\n if KeysEqual(Bucket.Entries[I].Key, Key) then\r\n begin\r\n Result := Bucket.Entries[I].Value;\r\n Found := True;\r\n Break;\r\n end;\r\n if (not Found) and (not FReturnDefaultElements) then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclAnsiStrAnsiStrHashMap.IsEmpty: Boolean;\r\nbegin\r\n Result := FSize = 0;\r\nend;\r\n\r\nfunction TJclAnsiStrAnsiStrHashMap.KeyOfValue(const Value: AnsiString): AnsiString;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclAnsiStrAnsiStrHashMapBucket;\r\n Found: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Found := False;\r\n Result := '';\r\n for J := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[J];\r\n if Bucket <> nil then\r\n for I := 0 to Bucket.Size - 1 do\r\n if ValuesEqual(Bucket.Entries[I].Value, Value) then\r\n begin\r\n Result := Bucket.Entries[I].Key;\r\n Found := True;\r\n Break;\r\n end;\r\n end;\r\n if (not Found) and (not FReturnDefaultElements) then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclAnsiStrAnsiStrHashMap.KeySet: IJclAnsiStrSet;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclAnsiStrAnsiStrHashMapBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := TJclAnsiStrArraySet.Create(FSize);\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n for J := 0 to Bucket.Size - 1 do\r\n Result.Add(Bucket.Entries[J].Key);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclAnsiStrAnsiStrHashMap.MapEquals(const AMap: IJclAnsiStrAnsiStrMap): Boolean;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclAnsiStrAnsiStrHashMapBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if AMap = nil then\r\n Exit;\r\n if FSize <> AMap.Size then\r\n Exit;\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n for J := 0 to Bucket.Size - 1 do\r\n if AMap.ContainsKey(Bucket.Entries[J].Key) then\r\n begin\r\n if not ValuesEqual(AMap.GetValue(Bucket.Entries[J].Key), Bucket.Entries[J].Value) then\r\n Exit;\r\n end\r\n else\r\n Exit;\r\n end;\r\n Result := True;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclAnsiStrAnsiStrHashMap.Pack;\r\nvar\r\n I: Integer;\r\n Bucket: TJclAnsiStrAnsiStrHashMapBucket;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n begin\r\n if Bucket.Size > 0 then\r\n SetLength(Bucket.Entries, Bucket.Size)\r\n else\r\n FreeAndNil(FBuckets[I]);\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclAnsiStrAnsiStrHashMap.PutAll(const AMap: IJclAnsiStrAnsiStrMap);\r\nvar\r\n It: IJclAnsiStrIterator;\r\n Key: AnsiString;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if AMap = nil then\r\n Exit;\r\n It := AMap.KeySet.First;\r\n while It.HasNext do\r\n begin\r\n Key := It.Next;\r\n PutValue(Key, AMap.GetValue(Key));\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclAnsiStrAnsiStrHashMap.PutValue(const Key: AnsiString; const Value: AnsiString);\r\nvar\r\n Index: Integer;\r\n Bucket: TJclAnsiStrAnsiStrHashMapBucket;\r\n I: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FAllowDefaultElements or (not KeysEqual(Key, '') and not ValuesEqual(Value, '')) then\r\n begin\r\n Index := FHashToRangeFunction(Hash(Key), FCapacity);\r\n Bucket := FBuckets[Index];\r\n if Bucket <> nil then\r\n begin\r\n for I := 0 to Bucket.Size - 1 do\r\n if KeysEqual(Bucket.Entries[I].Key, Key) then\r\n begin\r\n FreeValue(Bucket.Entries[I].Value);\r\n Bucket.Entries[I].Value := Value;\r\n Exit;\r\n end;\r\n end\r\n else\r\n begin\r\n Bucket := TJclAnsiStrAnsiStrHashMapBucket.Create;\r\n SetLength(Bucket.Entries, 1);\r\n FBuckets[Index] := Bucket;\r\n end;\r\n\r\n if Bucket.Size = Length(Bucket.Entries) then\r\n SetLength(Bucket.Entries, CalcGrowCapacity(Bucket.Size, Bucket.Size));\r\n\r\n if Bucket.Size < Length(Bucket.Entries) then\r\n begin\r\n Bucket.Entries[Bucket.Size].Key := Key;\r\n Bucket.Entries[Bucket.Size].Value := Value;\r\n Inc(Bucket.Size);\r\n Inc(FSize);\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclAnsiStrAnsiStrHashMap.Remove(const Key: AnsiString): AnsiString;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := Extract(Key);\r\n Result := FreeValue(Result);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclAnsiStrAnsiStrHashMap.SetCapacity(Value: Integer);\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FSize = 0 then\r\n begin\r\n SetLength(FBuckets, Value);\r\n inherited SetCapacity(Value);\r\n end\r\n else\r\n raise EJclOperationNotSupportedError.Create;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclAnsiStrAnsiStrHashMap.Size: Integer;\r\nbegin\r\n Result := FSize;\r\nend;\r\n\r\nfunction TJclAnsiStrAnsiStrHashMap.Values: IJclAnsiStrCollection;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclAnsiStrAnsiStrHashMapBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := TJclAnsiStrArrayList.Create(FSize);\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n for J := 0 to Bucket.Size - 1 do\r\n Result.Add(Bucket.Entries[J].Value);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclAnsiStrAnsiStrHashMap.CreateEmptyContainer: TJclAbstractContainerBase;\r\nbegin\r\n Result := TJclAnsiStrAnsiStrHashMap.Create(FCapacity);\r\n AssignPropertiesTo(Result);\r\nend;\r\n\r\nfunction TJclAnsiStrAnsiStrHashMap.FreeKey(var Key: AnsiString): AnsiString;\r\nbegin\r\n Result := Key;\r\n Key := '';\r\nend;\r\n\r\nfunction TJclAnsiStrAnsiStrHashMap.FreeValue(var Value: AnsiString): AnsiString;\r\nbegin\r\n Result := Value;\r\n Value := '';\r\nend;\r\n\r\nfunction TJclAnsiStrAnsiStrHashMap.KeysEqual(const A, B: AnsiString): Boolean;\r\nbegin\r\n Result := ItemsEqual(A, B);\r\nend;\r\n\r\nfunction TJclAnsiStrAnsiStrHashMap.ValuesEqual(const A, B: AnsiString): Boolean;\r\nbegin\r\n Result := ItemsEqual(A, B);\r\nend;\r\n\r\n//=== { TJclWideStrIntfHashMapBucket } ==========================================\r\n\r\nprocedure TJclWideStrIntfHashMapBucket.FinalizeArrayBeforeMove(var List: TJclWideStrIntfHashMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\nbegin\r\n Assert(Count > 0);\r\n if FromIndex < ToIndex then\r\n begin\r\n if Count > (ToIndex - FromIndex) then\r\n Finalize(List[FromIndex + Count], ToIndex - FromIndex)\r\n else\r\n Finalize(List[ToIndex], Count);\r\n end\r\n else\r\n if FromIndex > ToIndex then\r\n begin\r\n if Count > (FromIndex - ToIndex) then\r\n Count := FromIndex - ToIndex;\r\n Finalize(List[ToIndex], Count)\r\n end;\r\nend;\r\n\r\nprocedure TJclWideStrIntfHashMapBucket.InitializeArray(var List: TJclWideStrIntfHashMapEntryArray; FromIndex, Count: SizeInt);\r\nbegin\r\n {$IFDEF FPC}\r\n while Count > 0 do\r\n begin\r\n Initialize(List[FromIndex]);\r\n Inc(FromIndex);\r\n Dec(Count);\r\n end;\r\n {$ELSE ~FPC}\r\n Initialize(List[FromIndex], Count);\r\n {$ENDIF ~FPC}\r\nend;\r\n\r\nprocedure TJclWideStrIntfHashMapBucket.InitializeArrayAfterMove(var List: TJclWideStrIntfHashMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\nbegin\r\n { Keep reference counting working }\r\n if FromIndex < ToIndex then\r\n begin\r\n if (ToIndex - FromIndex) < Count then\r\n Count := ToIndex - FromIndex;\r\n InitializeArray(List, FromIndex, Count);\r\n end\r\n else\r\n if FromIndex > ToIndex then\r\n begin\r\n if (FromIndex - ToIndex) < Count then\r\n InitializeArray(List, ToIndex + Count, FromIndex - ToIndex)\r\n else\r\n InitializeArray(List, FromIndex, Count);\r\n end;\r\nend;\r\n\r\nprocedure TJclWideStrIntfHashMapBucket.MoveArray(var List: TJclWideStrIntfHashMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\nbegin\r\n if Count > 0 then\r\n begin\r\n FinalizeArrayBeforeMove(List, FromIndex, ToIndex, Count);\r\n Move(List[FromIndex], List[ToIndex], Count * SizeOf(List[0]));\r\n InitializeArrayAfterMove(List, FromIndex, ToIndex, Count);\r\n end;\r\nend;\r\n\r\n//=== { TJclWideStrIntfHashMap } ==========================================\r\n\r\nconstructor TJclWideStrIntfHashMap.Create(ACapacity: Integer);\r\nbegin\r\n inherited Create;\r\n SetCapacity(ACapacity);\r\n FHashToRangeFunction := JclSimpleHashToRange;\r\nend;\r\n\r\ndestructor TJclWideStrIntfHashMap.Destroy;\r\nbegin\r\n FReadOnly := False;\r\n Clear;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJclWideStrIntfHashMap.AssignDataTo(Dest: TJclAbstractContainerBase);\r\nvar\r\n I, J: Integer;\r\n SelfBucket, NewBucket: TJclWideStrIntfHashMapBucket;\r\n ADest: TJclWideStrIntfHashMap;\r\n AMap: IJclWideStrIntfMap;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n inherited AssignDataTo(Dest);\r\n if Dest is TJclWideStrIntfHashMap then\r\n begin\r\n ADest := TJclWideStrIntfHashMap(Dest);\r\n ADest.Clear;\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n SelfBucket := FBuckets[I];\r\n if SelfBucket <> nil then\r\n begin\r\n NewBucket := TJclWideStrIntfHashMapBucket.Create;\r\n SetLength(NewBucket.Entries, SelfBucket.Size);\r\n for J := 0 to SelfBucket.Size - 1 do\r\n begin\r\n NewBucket.Entries[J].Key := SelfBucket.Entries[J].Key;\r\n NewBucket.Entries[J].Value := SelfBucket.Entries[J].Value;\r\n end;\r\n NewBucket.Size := SelfBucket.Size;\r\n ADest.FBuckets[I] := NewBucket;\r\n end;\r\n end;\r\n end\r\n else\r\n if Supports(IInterface(Dest), IJclWideStrIntfMap, AMap) then\r\n begin\r\n AMap.Clear;\r\n AMap.PutAll(Self);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclWideStrIntfHashMap.AssignPropertiesTo(Dest: TJclAbstractContainerBase);\r\nbegin\r\n inherited AssignPropertiesto(Dest);\r\n if Dest is TJclWideStrIntfHashMap then\r\n TJclWideStrIntfHashMap(Dest).FHashToRangeFunction := FHashToRangeFunction;\r\nend;\r\n\r\nprocedure TJclWideStrIntfHashMap.Clear;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclWideStrIntfHashMapBucket;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n begin\r\n for J := 0 to Bucket.Size - 1 do\r\n begin\r\n FreeKey(Bucket.Entries[J].Key);\r\n FreeValue(Bucket.Entries[J].Value);\r\n end;\r\n FreeAndNil(FBuckets[I]);\r\n end;\r\n end;\r\n FSize := 0;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclWideStrIntfHashMap.ContainsKey(const Key: WideString): Boolean;\r\nvar\r\n I: Integer;\r\n Bucket: TJclWideStrIntfHashMapBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n Bucket := FBuckets[FHashToRangeFunction(Hash(Key), FCapacity)];\r\n if Bucket <> nil then\r\n for I := 0 to Bucket.Size - 1 do\r\n if KeysEqual(Bucket.Entries[I].Key, Key) then\r\n begin\r\n Result := True;\r\n Break;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclWideStrIntfHashMap.ContainsValue(const Value: IInterface): Boolean;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclWideStrIntfHashMapBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n for J := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[J];\r\n if Bucket <> nil then\r\n for I := 0 to Bucket.Size - 1 do\r\n if ValuesEqual(Bucket.Entries[I].Value, Value) then\r\n begin\r\n Result := True;\r\n Break;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclWideStrIntfHashMap.Extract(const Key: WideString): IInterface;\r\nvar\r\n Bucket: TJclWideStrIntfHashMapBucket;\r\n I, NewCapacity: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := nil;\r\n Bucket := FBuckets[FHashToRangeFunction(Hash(Key), FCapacity)];\r\n if Bucket <> nil then\r\n begin\r\n for I := 0 to Bucket.Size - 1 do\r\n if KeysEqual(Bucket.Entries[I].Key, Key) then\r\n begin\r\n Result := Bucket.Entries[I].Value;\r\n Bucket.Entries[I].Value := nil;\r\n FreeKey(Bucket.Entries[I].Key);\r\n if I < Length(Bucket.Entries) - 1 then\r\n Bucket.MoveArray(Bucket.Entries, I + 1, I, Bucket.Size - I - 1);\r\n Dec(Bucket.Size);\r\n Dec(FSize);\r\n Break;\r\n end;\r\n\r\n NewCapacity := CalcPackCapacity(Length(Bucket.Entries), Bucket.Size);\r\n if NewCapacity < Length(Bucket.Entries) then\r\n SetLength(Bucket.Entries, NewCapacity);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclWideStrIntfHashMap.GetValue(const Key: WideString): IInterface;\r\nvar\r\n I: Integer;\r\n Bucket: TJclWideStrIntfHashMapBucket;\r\n Found: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Found := False;\r\n Result := nil;\r\n Bucket := FBuckets[FHashToRangeFunction(Hash(Key), FCapacity)];\r\n if Bucket <> nil then\r\n for I := 0 to Bucket.Size - 1 do\r\n if KeysEqual(Bucket.Entries[I].Key, Key) then\r\n begin\r\n Result := Bucket.Entries[I].Value;\r\n Found := True;\r\n Break;\r\n end;\r\n if (not Found) and (not FReturnDefaultElements) then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclWideStrIntfHashMap.IsEmpty: Boolean;\r\nbegin\r\n Result := FSize = 0;\r\nend;\r\n\r\nfunction TJclWideStrIntfHashMap.KeyOfValue(const Value: IInterface): WideString;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclWideStrIntfHashMapBucket;\r\n Found: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Found := False;\r\n Result := '';\r\n for J := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[J];\r\n if Bucket <> nil then\r\n for I := 0 to Bucket.Size - 1 do\r\n if ValuesEqual(Bucket.Entries[I].Value, Value) then\r\n begin\r\n Result := Bucket.Entries[I].Key;\r\n Found := True;\r\n Break;\r\n end;\r\n end;\r\n if (not Found) and (not FReturnDefaultElements) then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclWideStrIntfHashMap.KeySet: IJclWideStrSet;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclWideStrIntfHashMapBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := TJclWideStrArraySet.Create(FSize);\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n for J := 0 to Bucket.Size - 1 do\r\n Result.Add(Bucket.Entries[J].Key);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclWideStrIntfHashMap.MapEquals(const AMap: IJclWideStrIntfMap): Boolean;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclWideStrIntfHashMapBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if AMap = nil then\r\n Exit;\r\n if FSize <> AMap.Size then\r\n Exit;\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n for J := 0 to Bucket.Size - 1 do\r\n if AMap.ContainsKey(Bucket.Entries[J].Key) then\r\n begin\r\n if not ValuesEqual(AMap.GetValue(Bucket.Entries[J].Key), Bucket.Entries[J].Value) then\r\n Exit;\r\n end\r\n else\r\n Exit;\r\n end;\r\n Result := True;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclWideStrIntfHashMap.Pack;\r\nvar\r\n I: Integer;\r\n Bucket: TJclWideStrIntfHashMapBucket;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n begin\r\n if Bucket.Size > 0 then\r\n SetLength(Bucket.Entries, Bucket.Size)\r\n else\r\n FreeAndNil(FBuckets[I]);\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclWideStrIntfHashMap.PutAll(const AMap: IJclWideStrIntfMap);\r\nvar\r\n It: IJclWideStrIterator;\r\n Key: WideString;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if AMap = nil then\r\n Exit;\r\n It := AMap.KeySet.First;\r\n while It.HasNext do\r\n begin\r\n Key := It.Next;\r\n PutValue(Key, AMap.GetValue(Key));\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclWideStrIntfHashMap.PutValue(const Key: WideString; const Value: IInterface);\r\nvar\r\n Index: Integer;\r\n Bucket: TJclWideStrIntfHashMapBucket;\r\n I: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FAllowDefaultElements or (not KeysEqual(Key, '') and not ValuesEqual(Value, nil)) then\r\n begin\r\n Index := FHashToRangeFunction(Hash(Key), FCapacity);\r\n Bucket := FBuckets[Index];\r\n if Bucket <> nil then\r\n begin\r\n for I := 0 to Bucket.Size - 1 do\r\n if KeysEqual(Bucket.Entries[I].Key, Key) then\r\n begin\r\n FreeValue(Bucket.Entries[I].Value);\r\n Bucket.Entries[I].Value := Value;\r\n Exit;\r\n end;\r\n end\r\n else\r\n begin\r\n Bucket := TJclWideStrIntfHashMapBucket.Create;\r\n SetLength(Bucket.Entries, 1);\r\n FBuckets[Index] := Bucket;\r\n end;\r\n\r\n if Bucket.Size = Length(Bucket.Entries) then\r\n SetLength(Bucket.Entries, CalcGrowCapacity(Bucket.Size, Bucket.Size));\r\n\r\n if Bucket.Size < Length(Bucket.Entries) then\r\n begin\r\n Bucket.Entries[Bucket.Size].Key := Key;\r\n Bucket.Entries[Bucket.Size].Value := Value;\r\n Inc(Bucket.Size);\r\n Inc(FSize);\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclWideStrIntfHashMap.Remove(const Key: WideString): IInterface;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := Extract(Key);\r\n Result := FreeValue(Result);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclWideStrIntfHashMap.SetCapacity(Value: Integer);\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FSize = 0 then\r\n begin\r\n SetLength(FBuckets, Value);\r\n inherited SetCapacity(Value);\r\n end\r\n else\r\n raise EJclOperationNotSupportedError.Create;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclWideStrIntfHashMap.Size: Integer;\r\nbegin\r\n Result := FSize;\r\nend;\r\n\r\nfunction TJclWideStrIntfHashMap.Values: IJclIntfCollection;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclWideStrIntfHashMapBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := TJclIntfArrayList.Create(FSize);\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n for J := 0 to Bucket.Size - 1 do\r\n Result.Add(Bucket.Entries[J].Value);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclWideStrIntfHashMap.CreateEmptyContainer: TJclAbstractContainerBase;\r\nbegin\r\n Result := TJclWideStrIntfHashMap.Create(FCapacity);\r\n AssignPropertiesTo(Result);\r\nend;\r\n\r\nfunction TJclWideStrIntfHashMap.FreeKey(var Key: WideString): WideString;\r\nbegin\r\n Result := Key;\r\n Key := '';\r\nend;\r\n\r\nfunction TJclWideStrIntfHashMap.FreeValue(var Value: IInterface): IInterface;\r\nbegin\r\n Result := Value;\r\n Value := nil;\r\nend;\r\n\r\nfunction TJclWideStrIntfHashMap.KeysEqual(const A, B: WideString): Boolean;\r\nbegin\r\n Result := ItemsEqual(A, B);\r\nend;\r\n\r\nfunction TJclWideStrIntfHashMap.ValuesEqual(const A, B: IInterface): Boolean;\r\nbegin\r\n Result := IntfSimpleEqualityCompare(A, B);\r\nend;\r\n\r\n//=== { TJclIntfWideStrHashMapBucket } ==========================================\r\n\r\nprocedure TJclIntfWideStrHashMapBucket.FinalizeArrayBeforeMove(var List: TJclIntfWideStrHashMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\nbegin\r\n Assert(Count > 0);\r\n if FromIndex < ToIndex then\r\n begin\r\n if Count > (ToIndex - FromIndex) then\r\n Finalize(List[FromIndex + Count], ToIndex - FromIndex)\r\n else\r\n Finalize(List[ToIndex], Count);\r\n end\r\n else\r\n if FromIndex > ToIndex then\r\n begin\r\n if Count > (FromIndex - ToIndex) then\r\n Count := FromIndex - ToIndex;\r\n Finalize(List[ToIndex], Count)\r\n end;\r\nend;\r\n\r\nprocedure TJclIntfWideStrHashMapBucket.InitializeArray(var List: TJclIntfWideStrHashMapEntryArray; FromIndex, Count: SizeInt);\r\nbegin\r\n {$IFDEF FPC}\r\n while Count > 0 do\r\n begin\r\n Initialize(List[FromIndex]);\r\n Inc(FromIndex);\r\n Dec(Count);\r\n end;\r\n {$ELSE ~FPC}\r\n Initialize(List[FromIndex], Count);\r\n {$ENDIF ~FPC}\r\nend;\r\n\r\nprocedure TJclIntfWideStrHashMapBucket.InitializeArrayAfterMove(var List: TJclIntfWideStrHashMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\nbegin\r\n { Keep reference counting working }\r\n if FromIndex < ToIndex then\r\n begin\r\n if (ToIndex - FromIndex) < Count then\r\n Count := ToIndex - FromIndex;\r\n InitializeArray(List, FromIndex, Count);\r\n end\r\n else\r\n if FromIndex > ToIndex then\r\n begin\r\n if (FromIndex - ToIndex) < Count then\r\n InitializeArray(List, ToIndex + Count, FromIndex - ToIndex)\r\n else\r\n InitializeArray(List, FromIndex, Count);\r\n end;\r\nend;\r\n\r\nprocedure TJclIntfWideStrHashMapBucket.MoveArray(var List: TJclIntfWideStrHashMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\nbegin\r\n if Count > 0 then\r\n begin\r\n FinalizeArrayBeforeMove(List, FromIndex, ToIndex, Count);\r\n Move(List[FromIndex], List[ToIndex], Count * SizeOf(List[0]));\r\n InitializeArrayAfterMove(List, FromIndex, ToIndex, Count);\r\n end;\r\nend;\r\n\r\n//=== { TJclIntfWideStrHashMap } ==========================================\r\n\r\nconstructor TJclIntfWideStrHashMap.Create(ACapacity: Integer);\r\nbegin\r\n inherited Create;\r\n SetCapacity(ACapacity);\r\n FHashToRangeFunction := JclSimpleHashToRange;\r\nend;\r\n\r\ndestructor TJclIntfWideStrHashMap.Destroy;\r\nbegin\r\n FReadOnly := False;\r\n Clear;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJclIntfWideStrHashMap.AssignDataTo(Dest: TJclAbstractContainerBase);\r\nvar\r\n I, J: Integer;\r\n SelfBucket, NewBucket: TJclIntfWideStrHashMapBucket;\r\n ADest: TJclIntfWideStrHashMap;\r\n AMap: IJclIntfWideStrMap;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n inherited AssignDataTo(Dest);\r\n if Dest is TJclIntfWideStrHashMap then\r\n begin\r\n ADest := TJclIntfWideStrHashMap(Dest);\r\n ADest.Clear;\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n SelfBucket := FBuckets[I];\r\n if SelfBucket <> nil then\r\n begin\r\n NewBucket := TJclIntfWideStrHashMapBucket.Create;\r\n SetLength(NewBucket.Entries, SelfBucket.Size);\r\n for J := 0 to SelfBucket.Size - 1 do\r\n begin\r\n NewBucket.Entries[J].Key := SelfBucket.Entries[J].Key;\r\n NewBucket.Entries[J].Value := SelfBucket.Entries[J].Value;\r\n end;\r\n NewBucket.Size := SelfBucket.Size;\r\n ADest.FBuckets[I] := NewBucket;\r\n end;\r\n end;\r\n end\r\n else\r\n if Supports(IInterface(Dest), IJclIntfWideStrMap, AMap) then\r\n begin\r\n AMap.Clear;\r\n AMap.PutAll(Self);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclIntfWideStrHashMap.AssignPropertiesTo(Dest: TJclAbstractContainerBase);\r\nbegin\r\n inherited AssignPropertiesto(Dest);\r\n if Dest is TJclIntfWideStrHashMap then\r\n TJclIntfWideStrHashMap(Dest).FHashToRangeFunction := FHashToRangeFunction;\r\nend;\r\n\r\nprocedure TJclIntfWideStrHashMap.Clear;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclIntfWideStrHashMapBucket;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n begin\r\n for J := 0 to Bucket.Size - 1 do\r\n begin\r\n FreeKey(Bucket.Entries[J].Key);\r\n FreeValue(Bucket.Entries[J].Value);\r\n end;\r\n FreeAndNil(FBuckets[I]);\r\n end;\r\n end;\r\n FSize := 0;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfWideStrHashMap.ContainsKey(const Key: IInterface): Boolean;\r\nvar\r\n I: Integer;\r\n Bucket: TJclIntfWideStrHashMapBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n Bucket := FBuckets[FHashToRangeFunction(Hash(Key), FCapacity)];\r\n if Bucket <> nil then\r\n for I := 0 to Bucket.Size - 1 do\r\n if KeysEqual(Bucket.Entries[I].Key, Key) then\r\n begin\r\n Result := True;\r\n Break;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfWideStrHashMap.ContainsValue(const Value: WideString): Boolean;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclIntfWideStrHashMapBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n for J := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[J];\r\n if Bucket <> nil then\r\n for I := 0 to Bucket.Size - 1 do\r\n if ValuesEqual(Bucket.Entries[I].Value, Value) then\r\n begin\r\n Result := True;\r\n Break;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfWideStrHashMap.Extract(const Key: IInterface): WideString;\r\nvar\r\n Bucket: TJclIntfWideStrHashMapBucket;\r\n I, NewCapacity: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := '';\r\n Bucket := FBuckets[FHashToRangeFunction(Hash(Key), FCapacity)];\r\n if Bucket <> nil then\r\n begin\r\n for I := 0 to Bucket.Size - 1 do\r\n if KeysEqual(Bucket.Entries[I].Key, Key) then\r\n begin\r\n Result := Bucket.Entries[I].Value;\r\n Bucket.Entries[I].Value := '';\r\n FreeKey(Bucket.Entries[I].Key);\r\n if I < Length(Bucket.Entries) - 1 then\r\n Bucket.MoveArray(Bucket.Entries, I + 1, I, Bucket.Size - I - 1);\r\n Dec(Bucket.Size);\r\n Dec(FSize);\r\n Break;\r\n end;\r\n\r\n NewCapacity := CalcPackCapacity(Length(Bucket.Entries), Bucket.Size);\r\n if NewCapacity < Length(Bucket.Entries) then\r\n SetLength(Bucket.Entries, NewCapacity);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfWideStrHashMap.GetValue(const Key: IInterface): WideString;\r\nvar\r\n I: Integer;\r\n Bucket: TJclIntfWideStrHashMapBucket;\r\n Found: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Found := False;\r\n Result := '';\r\n Bucket := FBuckets[FHashToRangeFunction(Hash(Key), FCapacity)];\r\n if Bucket <> nil then\r\n for I := 0 to Bucket.Size - 1 do\r\n if KeysEqual(Bucket.Entries[I].Key, Key) then\r\n begin\r\n Result := Bucket.Entries[I].Value;\r\n Found := True;\r\n Break;\r\n end;\r\n if (not Found) and (not FReturnDefaultElements) then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfWideStrHashMap.IsEmpty: Boolean;\r\nbegin\r\n Result := FSize = 0;\r\nend;\r\n\r\nfunction TJclIntfWideStrHashMap.KeyOfValue(const Value: WideString): IInterface;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclIntfWideStrHashMapBucket;\r\n Found: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Found := False;\r\n Result := nil;\r\n for J := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[J];\r\n if Bucket <> nil then\r\n for I := 0 to Bucket.Size - 1 do\r\n if ValuesEqual(Bucket.Entries[I].Value, Value) then\r\n begin\r\n Result := Bucket.Entries[I].Key;\r\n Found := True;\r\n Break;\r\n end;\r\n end;\r\n if (not Found) and (not FReturnDefaultElements) then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfWideStrHashMap.KeySet: IJclIntfSet;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclIntfWideStrHashMapBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := TJclIntfArraySet.Create(FSize);\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n for J := 0 to Bucket.Size - 1 do\r\n Result.Add(Bucket.Entries[J].Key);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfWideStrHashMap.MapEquals(const AMap: IJclIntfWideStrMap): Boolean;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclIntfWideStrHashMapBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if AMap = nil then\r\n Exit;\r\n if FSize <> AMap.Size then\r\n Exit;\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n for J := 0 to Bucket.Size - 1 do\r\n if AMap.ContainsKey(Bucket.Entries[J].Key) then\r\n begin\r\n if not ValuesEqual(AMap.GetValue(Bucket.Entries[J].Key), Bucket.Entries[J].Value) then\r\n Exit;\r\n end\r\n else\r\n Exit;\r\n end;\r\n Result := True;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclIntfWideStrHashMap.Pack;\r\nvar\r\n I: Integer;\r\n Bucket: TJclIntfWideStrHashMapBucket;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n begin\r\n if Bucket.Size > 0 then\r\n SetLength(Bucket.Entries, Bucket.Size)\r\n else\r\n FreeAndNil(FBuckets[I]);\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclIntfWideStrHashMap.PutAll(const AMap: IJclIntfWideStrMap);\r\nvar\r\n It: IJclIntfIterator;\r\n Key: IInterface;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if AMap = nil then\r\n Exit;\r\n It := AMap.KeySet.First;\r\n while It.HasNext do\r\n begin\r\n Key := It.Next;\r\n PutValue(Key, AMap.GetValue(Key));\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclIntfWideStrHashMap.PutValue(const Key: IInterface; const Value: WideString);\r\nvar\r\n Index: Integer;\r\n Bucket: TJclIntfWideStrHashMapBucket;\r\n I: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FAllowDefaultElements or (not KeysEqual(Key, nil) and not ValuesEqual(Value, '')) then\r\n begin\r\n Index := FHashToRangeFunction(Hash(Key), FCapacity);\r\n Bucket := FBuckets[Index];\r\n if Bucket <> nil then\r\n begin\r\n for I := 0 to Bucket.Size - 1 do\r\n if KeysEqual(Bucket.Entries[I].Key, Key) then\r\n begin\r\n FreeValue(Bucket.Entries[I].Value);\r\n Bucket.Entries[I].Value := Value;\r\n Exit;\r\n end;\r\n end\r\n else\r\n begin\r\n Bucket := TJclIntfWideStrHashMapBucket.Create;\r\n SetLength(Bucket.Entries, 1);\r\n FBuckets[Index] := Bucket;\r\n end;\r\n\r\n if Bucket.Size = Length(Bucket.Entries) then\r\n SetLength(Bucket.Entries, CalcGrowCapacity(Bucket.Size, Bucket.Size));\r\n\r\n if Bucket.Size < Length(Bucket.Entries) then\r\n begin\r\n Bucket.Entries[Bucket.Size].Key := Key;\r\n Bucket.Entries[Bucket.Size].Value := Value;\r\n Inc(Bucket.Size);\r\n Inc(FSize);\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfWideStrHashMap.Remove(const Key: IInterface): WideString;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := Extract(Key);\r\n Result := FreeValue(Result);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclIntfWideStrHashMap.SetCapacity(Value: Integer);\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FSize = 0 then\r\n begin\r\n SetLength(FBuckets, Value);\r\n inherited SetCapacity(Value);\r\n end\r\n else\r\n raise EJclOperationNotSupportedError.Create;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfWideStrHashMap.Size: Integer;\r\nbegin\r\n Result := FSize;\r\nend;\r\n\r\nfunction TJclIntfWideStrHashMap.Values: IJclWideStrCollection;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclIntfWideStrHashMapBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := TJclWideStrArrayList.Create(FSize);\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n for J := 0 to Bucket.Size - 1 do\r\n Result.Add(Bucket.Entries[J].Value);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfWideStrHashMap.CreateEmptyContainer: TJclAbstractContainerBase;\r\nbegin\r\n Result := TJclIntfWideStrHashMap.Create(FCapacity);\r\n AssignPropertiesTo(Result);\r\nend;\r\n\r\nfunction TJclIntfWideStrHashMap.FreeKey(var Key: IInterface): IInterface;\r\nbegin\r\n Result := Key;\r\n Key := nil;\r\nend;\r\n\r\nfunction TJclIntfWideStrHashMap.FreeValue(var Value: WideString): WideString;\r\nbegin\r\n Result := Value;\r\n Value := '';\r\nend;\r\n\r\nfunction TJclIntfWideStrHashMap.Hash(const AInterface: IInterface): Integer;\r\nbegin\r\n Result := IntfSimpleHashConvert(AInterface);\r\nend;\r\n\r\nfunction TJclIntfWideStrHashMap.KeysEqual(const A, B: IInterface): Boolean;\r\nbegin\r\n Result := IntfSimpleEqualityCompare(A, B);\r\nend;\r\n\r\nfunction TJclIntfWideStrHashMap.ValuesEqual(const A, B: WideString): Boolean;\r\nbegin\r\n Result := ItemsEqual(A, B);\r\nend;\r\n\r\n//=== { TJclWideStrWideStrHashMapBucket } ==========================================\r\n\r\nprocedure TJclWideStrWideStrHashMapBucket.FinalizeArrayBeforeMove(var List: TJclWideStrWideStrHashMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\nbegin\r\n Assert(Count > 0);\r\n if FromIndex < ToIndex then\r\n begin\r\n if Count > (ToIndex - FromIndex) then\r\n Finalize(List[FromIndex + Count], ToIndex - FromIndex)\r\n else\r\n Finalize(List[ToIndex], Count);\r\n end\r\n else\r\n if FromIndex > ToIndex then\r\n begin\r\n if Count > (FromIndex - ToIndex) then\r\n Count := FromIndex - ToIndex;\r\n Finalize(List[ToIndex], Count)\r\n end;\r\nend;\r\n\r\nprocedure TJclWideStrWideStrHashMapBucket.InitializeArray(var List: TJclWideStrWideStrHashMapEntryArray; FromIndex, Count: SizeInt);\r\nbegin\r\n {$IFDEF FPC}\r\n while Count > 0 do\r\n begin\r\n Initialize(List[FromIndex]);\r\n Inc(FromIndex);\r\n Dec(Count);\r\n end;\r\n {$ELSE ~FPC}\r\n Initialize(List[FromIndex], Count);\r\n {$ENDIF ~FPC}\r\nend;\r\n\r\nprocedure TJclWideStrWideStrHashMapBucket.InitializeArrayAfterMove(var List: TJclWideStrWideStrHashMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\nbegin\r\n { Keep reference counting working }\r\n if FromIndex < ToIndex then\r\n begin\r\n if (ToIndex - FromIndex) < Count then\r\n Count := ToIndex - FromIndex;\r\n InitializeArray(List, FromIndex, Count);\r\n end\r\n else\r\n if FromIndex > ToIndex then\r\n begin\r\n if (FromIndex - ToIndex) < Count then\r\n InitializeArray(List, ToIndex + Count, FromIndex - ToIndex)\r\n else\r\n InitializeArray(List, FromIndex, Count);\r\n end;\r\nend;\r\n\r\nprocedure TJclWideStrWideStrHashMapBucket.MoveArray(var List: TJclWideStrWideStrHashMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\nbegin\r\n if Count > 0 then\r\n begin\r\n FinalizeArrayBeforeMove(List, FromIndex, ToIndex, Count);\r\n Move(List[FromIndex], List[ToIndex], Count * SizeOf(List[0]));\r\n InitializeArrayAfterMove(List, FromIndex, ToIndex, Count);\r\n end;\r\nend;\r\n\r\n//=== { TJclWideStrWideStrHashMap } ==========================================\r\n\r\nconstructor TJclWideStrWideStrHashMap.Create(ACapacity: Integer);\r\nbegin\r\n inherited Create;\r\n SetCapacity(ACapacity);\r\n FHashToRangeFunction := JclSimpleHashToRange;\r\nend;\r\n\r\ndestructor TJclWideStrWideStrHashMap.Destroy;\r\nbegin\r\n FReadOnly := False;\r\n Clear;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJclWideStrWideStrHashMap.AssignDataTo(Dest: TJclAbstractContainerBase);\r\nvar\r\n I, J: Integer;\r\n SelfBucket, NewBucket: TJclWideStrWideStrHashMapBucket;\r\n ADest: TJclWideStrWideStrHashMap;\r\n AMap: IJclWideStrWideStrMap;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n inherited AssignDataTo(Dest);\r\n if Dest is TJclWideStrWideStrHashMap then\r\n begin\r\n ADest := TJclWideStrWideStrHashMap(Dest);\r\n ADest.Clear;\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n SelfBucket := FBuckets[I];\r\n if SelfBucket <> nil then\r\n begin\r\n NewBucket := TJclWideStrWideStrHashMapBucket.Create;\r\n SetLength(NewBucket.Entries, SelfBucket.Size);\r\n for J := 0 to SelfBucket.Size - 1 do\r\n begin\r\n NewBucket.Entries[J].Key := SelfBucket.Entries[J].Key;\r\n NewBucket.Entries[J].Value := SelfBucket.Entries[J].Value;\r\n end;\r\n NewBucket.Size := SelfBucket.Size;\r\n ADest.FBuckets[I] := NewBucket;\r\n end;\r\n end;\r\n end\r\n else\r\n if Supports(IInterface(Dest), IJclWideStrWideStrMap, AMap) then\r\n begin\r\n AMap.Clear;\r\n AMap.PutAll(Self);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclWideStrWideStrHashMap.AssignPropertiesTo(Dest: TJclAbstractContainerBase);\r\nbegin\r\n inherited AssignPropertiesto(Dest);\r\n if Dest is TJclWideStrWideStrHashMap then\r\n TJclWideStrWideStrHashMap(Dest).FHashToRangeFunction := FHashToRangeFunction;\r\nend;\r\n\r\nprocedure TJclWideStrWideStrHashMap.Clear;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclWideStrWideStrHashMapBucket;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n begin\r\n for J := 0 to Bucket.Size - 1 do\r\n begin\r\n FreeKey(Bucket.Entries[J].Key);\r\n FreeValue(Bucket.Entries[J].Value);\r\n end;\r\n FreeAndNil(FBuckets[I]);\r\n end;\r\n end;\r\n FSize := 0;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclWideStrWideStrHashMap.ContainsKey(const Key: WideString): Boolean;\r\nvar\r\n I: Integer;\r\n Bucket: TJclWideStrWideStrHashMapBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n Bucket := FBuckets[FHashToRangeFunction(Hash(Key), FCapacity)];\r\n if Bucket <> nil then\r\n for I := 0 to Bucket.Size - 1 do\r\n if KeysEqual(Bucket.Entries[I].Key, Key) then\r\n begin\r\n Result := True;\r\n Break;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclWideStrWideStrHashMap.ContainsValue(const Value: WideString): Boolean;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclWideStrWideStrHashMapBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n for J := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[J];\r\n if Bucket <> nil then\r\n for I := 0 to Bucket.Size - 1 do\r\n if ValuesEqual(Bucket.Entries[I].Value, Value) then\r\n begin\r\n Result := True;\r\n Break;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclWideStrWideStrHashMap.Extract(const Key: WideString): WideString;\r\nvar\r\n Bucket: TJclWideStrWideStrHashMapBucket;\r\n I, NewCapacity: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := '';\r\n Bucket := FBuckets[FHashToRangeFunction(Hash(Key), FCapacity)];\r\n if Bucket <> nil then\r\n begin\r\n for I := 0 to Bucket.Size - 1 do\r\n if KeysEqual(Bucket.Entries[I].Key, Key) then\r\n begin\r\n Result := Bucket.Entries[I].Value;\r\n Bucket.Entries[I].Value := '';\r\n FreeKey(Bucket.Entries[I].Key);\r\n if I < Length(Bucket.Entries) - 1 then\r\n Bucket.MoveArray(Bucket.Entries, I + 1, I, Bucket.Size - I - 1);\r\n Dec(Bucket.Size);\r\n Dec(FSize);\r\n Break;\r\n end;\r\n\r\n NewCapacity := CalcPackCapacity(Length(Bucket.Entries), Bucket.Size);\r\n if NewCapacity < Length(Bucket.Entries) then\r\n SetLength(Bucket.Entries, NewCapacity);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclWideStrWideStrHashMap.GetValue(const Key: WideString): WideString;\r\nvar\r\n I: Integer;\r\n Bucket: TJclWideStrWideStrHashMapBucket;\r\n Found: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Found := False;\r\n Result := '';\r\n Bucket := FBuckets[FHashToRangeFunction(Hash(Key), FCapacity)];\r\n if Bucket <> nil then\r\n for I := 0 to Bucket.Size - 1 do\r\n if KeysEqual(Bucket.Entries[I].Key, Key) then\r\n begin\r\n Result := Bucket.Entries[I].Value;\r\n Found := True;\r\n Break;\r\n end;\r\n if (not Found) and (not FReturnDefaultElements) then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclWideStrWideStrHashMap.IsEmpty: Boolean;\r\nbegin\r\n Result := FSize = 0;\r\nend;\r\n\r\nfunction TJclWideStrWideStrHashMap.KeyOfValue(const Value: WideString): WideString;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclWideStrWideStrHashMapBucket;\r\n Found: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Found := False;\r\n Result := '';\r\n for J := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[J];\r\n if Bucket <> nil then\r\n for I := 0 to Bucket.Size - 1 do\r\n if ValuesEqual(Bucket.Entries[I].Value, Value) then\r\n begin\r\n Result := Bucket.Entries[I].Key;\r\n Found := True;\r\n Break;\r\n end;\r\n end;\r\n if (not Found) and (not FReturnDefaultElements) then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclWideStrWideStrHashMap.KeySet: IJclWideStrSet;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclWideStrWideStrHashMapBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := TJclWideStrArraySet.Create(FSize);\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n for J := 0 to Bucket.Size - 1 do\r\n Result.Add(Bucket.Entries[J].Key);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclWideStrWideStrHashMap.MapEquals(const AMap: IJclWideStrWideStrMap): Boolean;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclWideStrWideStrHashMapBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if AMap = nil then\r\n Exit;\r\n if FSize <> AMap.Size then\r\n Exit;\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n for J := 0 to Bucket.Size - 1 do\r\n if AMap.ContainsKey(Bucket.Entries[J].Key) then\r\n begin\r\n if not ValuesEqual(AMap.GetValue(Bucket.Entries[J].Key), Bucket.Entries[J].Value) then\r\n Exit;\r\n end\r\n else\r\n Exit;\r\n end;\r\n Result := True;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclWideStrWideStrHashMap.Pack;\r\nvar\r\n I: Integer;\r\n Bucket: TJclWideStrWideStrHashMapBucket;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n begin\r\n if Bucket.Size > 0 then\r\n SetLength(Bucket.Entries, Bucket.Size)\r\n else\r\n FreeAndNil(FBuckets[I]);\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclWideStrWideStrHashMap.PutAll(const AMap: IJclWideStrWideStrMap);\r\nvar\r\n It: IJclWideStrIterator;\r\n Key: WideString;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if AMap = nil then\r\n Exit;\r\n It := AMap.KeySet.First;\r\n while It.HasNext do\r\n begin\r\n Key := It.Next;\r\n PutValue(Key, AMap.GetValue(Key));\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclWideStrWideStrHashMap.PutValue(const Key: WideString; const Value: WideString);\r\nvar\r\n Index: Integer;\r\n Bucket: TJclWideStrWideStrHashMapBucket;\r\n I: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FAllowDefaultElements or (not KeysEqual(Key, '') and not ValuesEqual(Value, '')) then\r\n begin\r\n Index := FHashToRangeFunction(Hash(Key), FCapacity);\r\n Bucket := FBuckets[Index];\r\n if Bucket <> nil then\r\n begin\r\n for I := 0 to Bucket.Size - 1 do\r\n if KeysEqual(Bucket.Entries[I].Key, Key) then\r\n begin\r\n FreeValue(Bucket.Entries[I].Value);\r\n Bucket.Entries[I].Value := Value;\r\n Exit;\r\n end;\r\n end\r\n else\r\n begin\r\n Bucket := TJclWideStrWideStrHashMapBucket.Create;\r\n SetLength(Bucket.Entries, 1);\r\n FBuckets[Index] := Bucket;\r\n end;\r\n\r\n if Bucket.Size = Length(Bucket.Entries) then\r\n SetLength(Bucket.Entries, CalcGrowCapacity(Bucket.Size, Bucket.Size));\r\n\r\n if Bucket.Size < Length(Bucket.Entries) then\r\n begin\r\n Bucket.Entries[Bucket.Size].Key := Key;\r\n Bucket.Entries[Bucket.Size].Value := Value;\r\n Inc(Bucket.Size);\r\n Inc(FSize);\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclWideStrWideStrHashMap.Remove(const Key: WideString): WideString;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := Extract(Key);\r\n Result := FreeValue(Result);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclWideStrWideStrHashMap.SetCapacity(Value: Integer);\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FSize = 0 then\r\n begin\r\n SetLength(FBuckets, Value);\r\n inherited SetCapacity(Value);\r\n end\r\n else\r\n raise EJclOperationNotSupportedError.Create;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclWideStrWideStrHashMap.Size: Integer;\r\nbegin\r\n Result := FSize;\r\nend;\r\n\r\nfunction TJclWideStrWideStrHashMap.Values: IJclWideStrCollection;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclWideStrWideStrHashMapBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := TJclWideStrArrayList.Create(FSize);\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n for J := 0 to Bucket.Size - 1 do\r\n Result.Add(Bucket.Entries[J].Value);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclWideStrWideStrHashMap.CreateEmptyContainer: TJclAbstractContainerBase;\r\nbegin\r\n Result := TJclWideStrWideStrHashMap.Create(FCapacity);\r\n AssignPropertiesTo(Result);\r\nend;\r\n\r\nfunction TJclWideStrWideStrHashMap.FreeKey(var Key: WideString): WideString;\r\nbegin\r\n Result := Key;\r\n Key := '';\r\nend;\r\n\r\nfunction TJclWideStrWideStrHashMap.FreeValue(var Value: WideString): WideString;\r\nbegin\r\n Result := Value;\r\n Value := '';\r\nend;\r\n\r\nfunction TJclWideStrWideStrHashMap.KeysEqual(const A, B: WideString): Boolean;\r\nbegin\r\n Result := ItemsEqual(A, B);\r\nend;\r\n\r\nfunction TJclWideStrWideStrHashMap.ValuesEqual(const A, B: WideString): Boolean;\r\nbegin\r\n Result := ItemsEqual(A, B);\r\nend;\r\n\r\n{$IFDEF SUPPORTS_UNICODE_STRING}\r\n//=== { TJclUnicodeStrIntfHashMapBucket } ==========================================\r\n\r\nprocedure TJclUnicodeStrIntfHashMapBucket.FinalizeArrayBeforeMove(var List: TJclUnicodeStrIntfHashMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\nbegin\r\n Assert(Count > 0);\r\n if FromIndex < ToIndex then\r\n begin\r\n if Count > (ToIndex - FromIndex) then\r\n Finalize(List[FromIndex + Count], ToIndex - FromIndex)\r\n else\r\n Finalize(List[ToIndex], Count);\r\n end\r\n else\r\n if FromIndex > ToIndex then\r\n begin\r\n if Count > (FromIndex - ToIndex) then\r\n Count := FromIndex - ToIndex;\r\n Finalize(List[ToIndex], Count)\r\n end;\r\nend;\r\n\r\nprocedure TJclUnicodeStrIntfHashMapBucket.InitializeArray(var List: TJclUnicodeStrIntfHashMapEntryArray; FromIndex, Count: SizeInt);\r\nbegin\r\n {$IFDEF FPC}\r\n while Count > 0 do\r\n begin\r\n Initialize(List[FromIndex]);\r\n Inc(FromIndex);\r\n Dec(Count);\r\n end;\r\n {$ELSE ~FPC}\r\n Initialize(List[FromIndex], Count);\r\n {$ENDIF ~FPC}\r\nend;\r\n\r\nprocedure TJclUnicodeStrIntfHashMapBucket.InitializeArrayAfterMove(var List: TJclUnicodeStrIntfHashMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\nbegin\r\n { Keep reference counting working }\r\n if FromIndex < ToIndex then\r\n begin\r\n if (ToIndex - FromIndex) < Count then\r\n Count := ToIndex - FromIndex;\r\n InitializeArray(List, FromIndex, Count);\r\n end\r\n else\r\n if FromIndex > ToIndex then\r\n begin\r\n if (FromIndex - ToIndex) < Count then\r\n InitializeArray(List, ToIndex + Count, FromIndex - ToIndex)\r\n else\r\n InitializeArray(List, FromIndex, Count);\r\n end;\r\nend;\r\n\r\nprocedure TJclUnicodeStrIntfHashMapBucket.MoveArray(var List: TJclUnicodeStrIntfHashMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\nbegin\r\n if Count > 0 then\r\n begin\r\n FinalizeArrayBeforeMove(List, FromIndex, ToIndex, Count);\r\n Move(List[FromIndex], List[ToIndex], Count * SizeOf(List[0]));\r\n InitializeArrayAfterMove(List, FromIndex, ToIndex, Count);\r\n end;\r\nend;\r\n\r\n\r\n{$ENDIF SUPPORTS_UNICODE_STRING}\r\n\r\n{$IFDEF SUPPORTS_UNICODE_STRING}\r\n//=== { TJclUnicodeStrIntfHashMap } ==========================================\r\n\r\nconstructor TJclUnicodeStrIntfHashMap.Create(ACapacity: Integer);\r\nbegin\r\n inherited Create;\r\n SetCapacity(ACapacity);\r\n FHashToRangeFunction := JclSimpleHashToRange;\r\nend;\r\n\r\ndestructor TJclUnicodeStrIntfHashMap.Destroy;\r\nbegin\r\n FReadOnly := False;\r\n Clear;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJclUnicodeStrIntfHashMap.AssignDataTo(Dest: TJclAbstractContainerBase);\r\nvar\r\n I, J: Integer;\r\n SelfBucket, NewBucket: TJclUnicodeStrIntfHashMapBucket;\r\n ADest: TJclUnicodeStrIntfHashMap;\r\n AMap: IJclUnicodeStrIntfMap;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n inherited AssignDataTo(Dest);\r\n if Dest is TJclUnicodeStrIntfHashMap then\r\n begin\r\n ADest := TJclUnicodeStrIntfHashMap(Dest);\r\n ADest.Clear;\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n SelfBucket := FBuckets[I];\r\n if SelfBucket <> nil then\r\n begin\r\n NewBucket := TJclUnicodeStrIntfHashMapBucket.Create;\r\n SetLength(NewBucket.Entries, SelfBucket.Size);\r\n for J := 0 to SelfBucket.Size - 1 do\r\n begin\r\n NewBucket.Entries[J].Key := SelfBucket.Entries[J].Key;\r\n NewBucket.Entries[J].Value := SelfBucket.Entries[J].Value;\r\n end;\r\n NewBucket.Size := SelfBucket.Size;\r\n ADest.FBuckets[I] := NewBucket;\r\n end;\r\n end;\r\n end\r\n else\r\n if Supports(IInterface(Dest), IJclUnicodeStrIntfMap, AMap) then\r\n begin\r\n AMap.Clear;\r\n AMap.PutAll(Self);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclUnicodeStrIntfHashMap.AssignPropertiesTo(Dest: TJclAbstractContainerBase);\r\nbegin\r\n inherited AssignPropertiesto(Dest);\r\n if Dest is TJclUnicodeStrIntfHashMap then\r\n TJclUnicodeStrIntfHashMap(Dest).FHashToRangeFunction := FHashToRangeFunction;\r\nend;\r\n\r\nprocedure TJclUnicodeStrIntfHashMap.Clear;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclUnicodeStrIntfHashMapBucket;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n begin\r\n for J := 0 to Bucket.Size - 1 do\r\n begin\r\n FreeKey(Bucket.Entries[J].Key);\r\n FreeValue(Bucket.Entries[J].Value);\r\n end;\r\n FreeAndNil(FBuckets[I]);\r\n end;\r\n end;\r\n FSize := 0;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclUnicodeStrIntfHashMap.ContainsKey(const Key: UnicodeString): Boolean;\r\nvar\r\n I: Integer;\r\n Bucket: TJclUnicodeStrIntfHashMapBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n Bucket := FBuckets[FHashToRangeFunction(Hash(Key), FCapacity)];\r\n if Bucket <> nil then\r\n for I := 0 to Bucket.Size - 1 do\r\n if KeysEqual(Bucket.Entries[I].Key, Key) then\r\n begin\r\n Result := True;\r\n Break;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclUnicodeStrIntfHashMap.ContainsValue(const Value: IInterface): Boolean;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclUnicodeStrIntfHashMapBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n for J := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[J];\r\n if Bucket <> nil then\r\n for I := 0 to Bucket.Size - 1 do\r\n if ValuesEqual(Bucket.Entries[I].Value, Value) then\r\n begin\r\n Result := True;\r\n Break;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclUnicodeStrIntfHashMap.Extract(const Key: UnicodeString): IInterface;\r\nvar\r\n Bucket: TJclUnicodeStrIntfHashMapBucket;\r\n I, NewCapacity: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := nil;\r\n Bucket := FBuckets[FHashToRangeFunction(Hash(Key), FCapacity)];\r\n if Bucket <> nil then\r\n begin\r\n for I := 0 to Bucket.Size - 1 do\r\n if KeysEqual(Bucket.Entries[I].Key, Key) then\r\n begin\r\n Result := Bucket.Entries[I].Value;\r\n Bucket.Entries[I].Value := nil;\r\n FreeKey(Bucket.Entries[I].Key);\r\n if I < Length(Bucket.Entries) - 1 then\r\n Bucket.MoveArray(Bucket.Entries, I + 1, I, Bucket.Size - I - 1);\r\n Dec(Bucket.Size);\r\n Dec(FSize);\r\n Break;\r\n end;\r\n\r\n NewCapacity := CalcPackCapacity(Length(Bucket.Entries), Bucket.Size);\r\n if NewCapacity < Length(Bucket.Entries) then\r\n SetLength(Bucket.Entries, NewCapacity);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclUnicodeStrIntfHashMap.GetValue(const Key: UnicodeString): IInterface;\r\nvar\r\n I: Integer;\r\n Bucket: TJclUnicodeStrIntfHashMapBucket;\r\n Found: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Found := False;\r\n Result := nil;\r\n Bucket := FBuckets[FHashToRangeFunction(Hash(Key), FCapacity)];\r\n if Bucket <> nil then\r\n for I := 0 to Bucket.Size - 1 do\r\n if KeysEqual(Bucket.Entries[I].Key, Key) then\r\n begin\r\n Result := Bucket.Entries[I].Value;\r\n Found := True;\r\n Break;\r\n end;\r\n if (not Found) and (not FReturnDefaultElements) then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclUnicodeStrIntfHashMap.IsEmpty: Boolean;\r\nbegin\r\n Result := FSize = 0;\r\nend;\r\n\r\nfunction TJclUnicodeStrIntfHashMap.KeyOfValue(const Value: IInterface): UnicodeString;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclUnicodeStrIntfHashMapBucket;\r\n Found: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Found := False;\r\n Result := '';\r\n for J := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[J];\r\n if Bucket <> nil then\r\n for I := 0 to Bucket.Size - 1 do\r\n if ValuesEqual(Bucket.Entries[I].Value, Value) then\r\n begin\r\n Result := Bucket.Entries[I].Key;\r\n Found := True;\r\n Break;\r\n end;\r\n end;\r\n if (not Found) and (not FReturnDefaultElements) then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclUnicodeStrIntfHashMap.KeySet: IJclUnicodeStrSet;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclUnicodeStrIntfHashMapBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := TJclUnicodeStrArraySet.Create(FSize);\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n for J := 0 to Bucket.Size - 1 do\r\n Result.Add(Bucket.Entries[J].Key);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclUnicodeStrIntfHashMap.MapEquals(const AMap: IJclUnicodeStrIntfMap): Boolean;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclUnicodeStrIntfHashMapBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if AMap = nil then\r\n Exit;\r\n if FSize <> AMap.Size then\r\n Exit;\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n for J := 0 to Bucket.Size - 1 do\r\n if AMap.ContainsKey(Bucket.Entries[J].Key) then\r\n begin\r\n if not ValuesEqual(AMap.GetValue(Bucket.Entries[J].Key), Bucket.Entries[J].Value) then\r\n Exit;\r\n end\r\n else\r\n Exit;\r\n end;\r\n Result := True;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclUnicodeStrIntfHashMap.Pack;\r\nvar\r\n I: Integer;\r\n Bucket: TJclUnicodeStrIntfHashMapBucket;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n begin\r\n if Bucket.Size > 0 then\r\n SetLength(Bucket.Entries, Bucket.Size)\r\n else\r\n FreeAndNil(FBuckets[I]);\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclUnicodeStrIntfHashMap.PutAll(const AMap: IJclUnicodeStrIntfMap);\r\nvar\r\n It: IJclUnicodeStrIterator;\r\n Key: UnicodeString;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if AMap = nil then\r\n Exit;\r\n It := AMap.KeySet.First;\r\n while It.HasNext do\r\n begin\r\n Key := It.Next;\r\n PutValue(Key, AMap.GetValue(Key));\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclUnicodeStrIntfHashMap.PutValue(const Key: UnicodeString; const Value: IInterface);\r\nvar\r\n Index: Integer;\r\n Bucket: TJclUnicodeStrIntfHashMapBucket;\r\n I: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FAllowDefaultElements or (not KeysEqual(Key, '') and not ValuesEqual(Value, nil)) then\r\n begin\r\n Index := FHashToRangeFunction(Hash(Key), FCapacity);\r\n Bucket := FBuckets[Index];\r\n if Bucket <> nil then\r\n begin\r\n for I := 0 to Bucket.Size - 1 do\r\n if KeysEqual(Bucket.Entries[I].Key, Key) then\r\n begin\r\n FreeValue(Bucket.Entries[I].Value);\r\n Bucket.Entries[I].Value := Value;\r\n Exit;\r\n end;\r\n end\r\n else\r\n begin\r\n Bucket := TJclUnicodeStrIntfHashMapBucket.Create;\r\n SetLength(Bucket.Entries, 1);\r\n FBuckets[Index] := Bucket;\r\n end;\r\n\r\n if Bucket.Size = Length(Bucket.Entries) then\r\n SetLength(Bucket.Entries, CalcGrowCapacity(Bucket.Size, Bucket.Size));\r\n\r\n if Bucket.Size < Length(Bucket.Entries) then\r\n begin\r\n Bucket.Entries[Bucket.Size].Key := Key;\r\n Bucket.Entries[Bucket.Size].Value := Value;\r\n Inc(Bucket.Size);\r\n Inc(FSize);\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclUnicodeStrIntfHashMap.Remove(const Key: UnicodeString): IInterface;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := Extract(Key);\r\n Result := FreeValue(Result);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclUnicodeStrIntfHashMap.SetCapacity(Value: Integer);\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FSize = 0 then\r\n begin\r\n SetLength(FBuckets, Value);\r\n inherited SetCapacity(Value);\r\n end\r\n else\r\n raise EJclOperationNotSupportedError.Create;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclUnicodeStrIntfHashMap.Size: Integer;\r\nbegin\r\n Result := FSize;\r\nend;\r\n\r\nfunction TJclUnicodeStrIntfHashMap.Values: IJclIntfCollection;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclUnicodeStrIntfHashMapBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := TJclIntfArrayList.Create(FSize);\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n for J := 0 to Bucket.Size - 1 do\r\n Result.Add(Bucket.Entries[J].Value);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclUnicodeStrIntfHashMap.CreateEmptyContainer: TJclAbstractContainerBase;\r\nbegin\r\n Result := TJclUnicodeStrIntfHashMap.Create(FCapacity);\r\n AssignPropertiesTo(Result);\r\nend;\r\n\r\nfunction TJclUnicodeStrIntfHashMap.FreeKey(var Key: UnicodeString): UnicodeString;\r\nbegin\r\n Result := Key;\r\n Key := '';\r\nend;\r\n\r\nfunction TJclUnicodeStrIntfHashMap.FreeValue(var Value: IInterface): IInterface;\r\nbegin\r\n Result := Value;\r\n Value := nil;\r\nend;\r\n\r\nfunction TJclUnicodeStrIntfHashMap.KeysEqual(const A, B: UnicodeString): Boolean;\r\nbegin\r\n Result := ItemsEqual(A, B);\r\nend;\r\n\r\nfunction TJclUnicodeStrIntfHashMap.ValuesEqual(const A, B: IInterface): Boolean;\r\nbegin\r\n Result := IntfSimpleEqualityCompare(A, B);\r\nend;\r\n\r\n{$ENDIF SUPPORTS_UNICODE_STRING}\r\n\r\n{$IFDEF SUPPORTS_UNICODE_STRING}\r\n//=== { TJclIntfUnicodeStrHashMapBucket } ==========================================\r\n\r\nprocedure TJclIntfUnicodeStrHashMapBucket.FinalizeArrayBeforeMove(var List: TJclIntfUnicodeStrHashMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\nbegin\r\n Assert(Count > 0);\r\n if FromIndex < ToIndex then\r\n begin\r\n if Count > (ToIndex - FromIndex) then\r\n Finalize(List[FromIndex + Count], ToIndex - FromIndex)\r\n else\r\n Finalize(List[ToIndex], Count);\r\n end\r\n else\r\n if FromIndex > ToIndex then\r\n begin\r\n if Count > (FromIndex - ToIndex) then\r\n Count := FromIndex - ToIndex;\r\n Finalize(List[ToIndex], Count)\r\n end;\r\nend;\r\n\r\nprocedure TJclIntfUnicodeStrHashMapBucket.InitializeArray(var List: TJclIntfUnicodeStrHashMapEntryArray; FromIndex, Count: SizeInt);\r\nbegin\r\n {$IFDEF FPC}\r\n while Count > 0 do\r\n begin\r\n Initialize(List[FromIndex]);\r\n Inc(FromIndex);\r\n Dec(Count);\r\n end;\r\n {$ELSE ~FPC}\r\n Initialize(List[FromIndex], Count);\r\n {$ENDIF ~FPC}\r\nend;\r\n\r\nprocedure TJclIntfUnicodeStrHashMapBucket.InitializeArrayAfterMove(var List: TJclIntfUnicodeStrHashMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\nbegin\r\n { Keep reference counting working }\r\n if FromIndex < ToIndex then\r\n begin\r\n if (ToIndex - FromIndex) < Count then\r\n Count := ToIndex - FromIndex;\r\n InitializeArray(List, FromIndex, Count);\r\n end\r\n else\r\n if FromIndex > ToIndex then\r\n begin\r\n if (FromIndex - ToIndex) < Count then\r\n InitializeArray(List, ToIndex + Count, FromIndex - ToIndex)\r\n else\r\n InitializeArray(List, FromIndex, Count);\r\n end;\r\nend;\r\n\r\nprocedure TJclIntfUnicodeStrHashMapBucket.MoveArray(var List: TJclIntfUnicodeStrHashMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\nbegin\r\n if Count > 0 then\r\n begin\r\n FinalizeArrayBeforeMove(List, FromIndex, ToIndex, Count);\r\n Move(List[FromIndex], List[ToIndex], Count * SizeOf(List[0]));\r\n InitializeArrayAfterMove(List, FromIndex, ToIndex, Count);\r\n end;\r\nend;\r\n\r\n\r\n{$ENDIF SUPPORTS_UNICODE_STRING}\r\n\r\n{$IFDEF SUPPORTS_UNICODE_STRING}\r\n//=== { TJclIntfUnicodeStrHashMap } ==========================================\r\n\r\nconstructor TJclIntfUnicodeStrHashMap.Create(ACapacity: Integer);\r\nbegin\r\n inherited Create;\r\n SetCapacity(ACapacity);\r\n FHashToRangeFunction := JclSimpleHashToRange;\r\nend;\r\n\r\ndestructor TJclIntfUnicodeStrHashMap.Destroy;\r\nbegin\r\n FReadOnly := False;\r\n Clear;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJclIntfUnicodeStrHashMap.AssignDataTo(Dest: TJclAbstractContainerBase);\r\nvar\r\n I, J: Integer;\r\n SelfBucket, NewBucket: TJclIntfUnicodeStrHashMapBucket;\r\n ADest: TJclIntfUnicodeStrHashMap;\r\n AMap: IJclIntfUnicodeStrMap;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n inherited AssignDataTo(Dest);\r\n if Dest is TJclIntfUnicodeStrHashMap then\r\n begin\r\n ADest := TJclIntfUnicodeStrHashMap(Dest);\r\n ADest.Clear;\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n SelfBucket := FBuckets[I];\r\n if SelfBucket <> nil then\r\n begin\r\n NewBucket := TJclIntfUnicodeStrHashMapBucket.Create;\r\n SetLength(NewBucket.Entries, SelfBucket.Size);\r\n for J := 0 to SelfBucket.Size - 1 do\r\n begin\r\n NewBucket.Entries[J].Key := SelfBucket.Entries[J].Key;\r\n NewBucket.Entries[J].Value := SelfBucket.Entries[J].Value;\r\n end;\r\n NewBucket.Size := SelfBucket.Size;\r\n ADest.FBuckets[I] := NewBucket;\r\n end;\r\n end;\r\n end\r\n else\r\n if Supports(IInterface(Dest), IJclIntfUnicodeStrMap, AMap) then\r\n begin\r\n AMap.Clear;\r\n AMap.PutAll(Self);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclIntfUnicodeStrHashMap.AssignPropertiesTo(Dest: TJclAbstractContainerBase);\r\nbegin\r\n inherited AssignPropertiesto(Dest);\r\n if Dest is TJclIntfUnicodeStrHashMap then\r\n TJclIntfUnicodeStrHashMap(Dest).FHashToRangeFunction := FHashToRangeFunction;\r\nend;\r\n\r\nprocedure TJclIntfUnicodeStrHashMap.Clear;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclIntfUnicodeStrHashMapBucket;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n begin\r\n for J := 0 to Bucket.Size - 1 do\r\n begin\r\n FreeKey(Bucket.Entries[J].Key);\r\n FreeValue(Bucket.Entries[J].Value);\r\n end;\r\n FreeAndNil(FBuckets[I]);\r\n end;\r\n end;\r\n FSize := 0;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfUnicodeStrHashMap.ContainsKey(const Key: IInterface): Boolean;\r\nvar\r\n I: Integer;\r\n Bucket: TJclIntfUnicodeStrHashMapBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n Bucket := FBuckets[FHashToRangeFunction(Hash(Key), FCapacity)];\r\n if Bucket <> nil then\r\n for I := 0 to Bucket.Size - 1 do\r\n if KeysEqual(Bucket.Entries[I].Key, Key) then\r\n begin\r\n Result := True;\r\n Break;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfUnicodeStrHashMap.ContainsValue(const Value: UnicodeString): Boolean;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclIntfUnicodeStrHashMapBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n for J := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[J];\r\n if Bucket <> nil then\r\n for I := 0 to Bucket.Size - 1 do\r\n if ValuesEqual(Bucket.Entries[I].Value, Value) then\r\n begin\r\n Result := True;\r\n Break;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfUnicodeStrHashMap.Extract(const Key: IInterface): UnicodeString;\r\nvar\r\n Bucket: TJclIntfUnicodeStrHashMapBucket;\r\n I, NewCapacity: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := '';\r\n Bucket := FBuckets[FHashToRangeFunction(Hash(Key), FCapacity)];\r\n if Bucket <> nil then\r\n begin\r\n for I := 0 to Bucket.Size - 1 do\r\n if KeysEqual(Bucket.Entries[I].Key, Key) then\r\n begin\r\n Result := Bucket.Entries[I].Value;\r\n Bucket.Entries[I].Value := '';\r\n FreeKey(Bucket.Entries[I].Key);\r\n if I < Length(Bucket.Entries) - 1 then\r\n Bucket.MoveArray(Bucket.Entries, I + 1, I, Bucket.Size - I - 1);\r\n Dec(Bucket.Size);\r\n Dec(FSize);\r\n Break;\r\n end;\r\n\r\n NewCapacity := CalcPackCapacity(Length(Bucket.Entries), Bucket.Size);\r\n if NewCapacity < Length(Bucket.Entries) then\r\n SetLength(Bucket.Entries, NewCapacity);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfUnicodeStrHashMap.GetValue(const Key: IInterface): UnicodeString;\r\nvar\r\n I: Integer;\r\n Bucket: TJclIntfUnicodeStrHashMapBucket;\r\n Found: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Found := False;\r\n Result := '';\r\n Bucket := FBuckets[FHashToRangeFunction(Hash(Key), FCapacity)];\r\n if Bucket <> nil then\r\n for I := 0 to Bucket.Size - 1 do\r\n if KeysEqual(Bucket.Entries[I].Key, Key) then\r\n begin\r\n Result := Bucket.Entries[I].Value;\r\n Found := True;\r\n Break;\r\n end;\r\n if (not Found) and (not FReturnDefaultElements) then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfUnicodeStrHashMap.IsEmpty: Boolean;\r\nbegin\r\n Result := FSize = 0;\r\nend;\r\n\r\nfunction TJclIntfUnicodeStrHashMap.KeyOfValue(const Value: UnicodeString): IInterface;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclIntfUnicodeStrHashMapBucket;\r\n Found: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Found := False;\r\n Result := nil;\r\n for J := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[J];\r\n if Bucket <> nil then\r\n for I := 0 to Bucket.Size - 1 do\r\n if ValuesEqual(Bucket.Entries[I].Value, Value) then\r\n begin\r\n Result := Bucket.Entries[I].Key;\r\n Found := True;\r\n Break;\r\n end;\r\n end;\r\n if (not Found) and (not FReturnDefaultElements) then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfUnicodeStrHashMap.KeySet: IJclIntfSet;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclIntfUnicodeStrHashMapBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := TJclIntfArraySet.Create(FSize);\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n for J := 0 to Bucket.Size - 1 do\r\n Result.Add(Bucket.Entries[J].Key);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfUnicodeStrHashMap.MapEquals(const AMap: IJclIntfUnicodeStrMap): Boolean;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclIntfUnicodeStrHashMapBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if AMap = nil then\r\n Exit;\r\n if FSize <> AMap.Size then\r\n Exit;\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n for J := 0 to Bucket.Size - 1 do\r\n if AMap.ContainsKey(Bucket.Entries[J].Key) then\r\n begin\r\n if not ValuesEqual(AMap.GetValue(Bucket.Entries[J].Key), Bucket.Entries[J].Value) then\r\n Exit;\r\n end\r\n else\r\n Exit;\r\n end;\r\n Result := True;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclIntfUnicodeStrHashMap.Pack;\r\nvar\r\n I: Integer;\r\n Bucket: TJclIntfUnicodeStrHashMapBucket;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n begin\r\n if Bucket.Size > 0 then\r\n SetLength(Bucket.Entries, Bucket.Size)\r\n else\r\n FreeAndNil(FBuckets[I]);\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclIntfUnicodeStrHashMap.PutAll(const AMap: IJclIntfUnicodeStrMap);\r\nvar\r\n It: IJclIntfIterator;\r\n Key: IInterface;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if AMap = nil then\r\n Exit;\r\n It := AMap.KeySet.First;\r\n while It.HasNext do\r\n begin\r\n Key := It.Next;\r\n PutValue(Key, AMap.GetValue(Key));\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclIntfUnicodeStrHashMap.PutValue(const Key: IInterface; const Value: UnicodeString);\r\nvar\r\n Index: Integer;\r\n Bucket: TJclIntfUnicodeStrHashMapBucket;\r\n I: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FAllowDefaultElements or (not KeysEqual(Key, nil) and not ValuesEqual(Value, '')) then\r\n begin\r\n Index := FHashToRangeFunction(Hash(Key), FCapacity);\r\n Bucket := FBuckets[Index];\r\n if Bucket <> nil then\r\n begin\r\n for I := 0 to Bucket.Size - 1 do\r\n if KeysEqual(Bucket.Entries[I].Key, Key) then\r\n begin\r\n FreeValue(Bucket.Entries[I].Value);\r\n Bucket.Entries[I].Value := Value;\r\n Exit;\r\n end;\r\n end\r\n else\r\n begin\r\n Bucket := TJclIntfUnicodeStrHashMapBucket.Create;\r\n SetLength(Bucket.Entries, 1);\r\n FBuckets[Index] := Bucket;\r\n end;\r\n\r\n if Bucket.Size = Length(Bucket.Entries) then\r\n SetLength(Bucket.Entries, CalcGrowCapacity(Bucket.Size, Bucket.Size));\r\n\r\n if Bucket.Size < Length(Bucket.Entries) then\r\n begin\r\n Bucket.Entries[Bucket.Size].Key := Key;\r\n Bucket.Entries[Bucket.Size].Value := Value;\r\n Inc(Bucket.Size);\r\n Inc(FSize);\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfUnicodeStrHashMap.Remove(const Key: IInterface): UnicodeString;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := Extract(Key);\r\n Result := FreeValue(Result);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclIntfUnicodeStrHashMap.SetCapacity(Value: Integer);\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FSize = 0 then\r\n begin\r\n SetLength(FBuckets, Value);\r\n inherited SetCapacity(Value);\r\n end\r\n else\r\n raise EJclOperationNotSupportedError.Create;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfUnicodeStrHashMap.Size: Integer;\r\nbegin\r\n Result := FSize;\r\nend;\r\n\r\nfunction TJclIntfUnicodeStrHashMap.Values: IJclUnicodeStrCollection;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclIntfUnicodeStrHashMapBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := TJclUnicodeStrArrayList.Create(FSize);\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n for J := 0 to Bucket.Size - 1 do\r\n Result.Add(Bucket.Entries[J].Value);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfUnicodeStrHashMap.CreateEmptyContainer: TJclAbstractContainerBase;\r\nbegin\r\n Result := TJclIntfUnicodeStrHashMap.Create(FCapacity);\r\n AssignPropertiesTo(Result);\r\nend;\r\n\r\nfunction TJclIntfUnicodeStrHashMap.FreeKey(var Key: IInterface): IInterface;\r\nbegin\r\n Result := Key;\r\n Key := nil;\r\nend;\r\n\r\nfunction TJclIntfUnicodeStrHashMap.FreeValue(var Value: UnicodeString): UnicodeString;\r\nbegin\r\n Result := Value;\r\n Value := '';\r\nend;\r\n\r\nfunction TJclIntfUnicodeStrHashMap.Hash(const AInterface: IInterface): Integer;\r\nbegin\r\n Result := IntfSimpleHashConvert(AInterface);\r\nend;\r\n\r\nfunction TJclIntfUnicodeStrHashMap.KeysEqual(const A, B: IInterface): Boolean;\r\nbegin\r\n Result := IntfSimpleEqualityCompare(A, B);\r\nend;\r\n\r\nfunction TJclIntfUnicodeStrHashMap.ValuesEqual(const A, B: UnicodeString): Boolean;\r\nbegin\r\n Result := ItemsEqual(A, B);\r\nend;\r\n\r\n{$ENDIF SUPPORTS_UNICODE_STRING}\r\n\r\n{$IFDEF SUPPORTS_UNICODE_STRING}\r\n//=== { TJclUnicodeStrUnicodeStrHashMapBucket } ==========================================\r\n\r\nprocedure TJclUnicodeStrUnicodeStrHashMapBucket.FinalizeArrayBeforeMove(var List: TJclUnicodeStrUnicodeStrHashMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\nbegin\r\n Assert(Count > 0);\r\n if FromIndex < ToIndex then\r\n begin\r\n if Count > (ToIndex - FromIndex) then\r\n Finalize(List[FromIndex + Count], ToIndex - FromIndex)\r\n else\r\n Finalize(List[ToIndex], Count);\r\n end\r\n else\r\n if FromIndex > ToIndex then\r\n begin\r\n if Count > (FromIndex - ToIndex) then\r\n Count := FromIndex - ToIndex;\r\n Finalize(List[ToIndex], Count)\r\n end;\r\nend;\r\n\r\nprocedure TJclUnicodeStrUnicodeStrHashMapBucket.InitializeArray(var List: TJclUnicodeStrUnicodeStrHashMapEntryArray; FromIndex, Count: SizeInt);\r\nbegin\r\n {$IFDEF FPC}\r\n while Count > 0 do\r\n begin\r\n Initialize(List[FromIndex]);\r\n Inc(FromIndex);\r\n Dec(Count);\r\n end;\r\n {$ELSE ~FPC}\r\n Initialize(List[FromIndex], Count);\r\n {$ENDIF ~FPC}\r\nend;\r\n\r\nprocedure TJclUnicodeStrUnicodeStrHashMapBucket.InitializeArrayAfterMove(var List: TJclUnicodeStrUnicodeStrHashMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\nbegin\r\n { Keep reference counting working }\r\n if FromIndex < ToIndex then\r\n begin\r\n if (ToIndex - FromIndex) < Count then\r\n Count := ToIndex - FromIndex;\r\n InitializeArray(List, FromIndex, Count);\r\n end\r\n else\r\n if FromIndex > ToIndex then\r\n begin\r\n if (FromIndex - ToIndex) < Count then\r\n InitializeArray(List, ToIndex + Count, FromIndex - ToIndex)\r\n else\r\n InitializeArray(List, FromIndex, Count);\r\n end;\r\nend;\r\n\r\nprocedure TJclUnicodeStrUnicodeStrHashMapBucket.MoveArray(var List: TJclUnicodeStrUnicodeStrHashMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\nbegin\r\n if Count > 0 then\r\n begin\r\n FinalizeArrayBeforeMove(List, FromIndex, ToIndex, Count);\r\n Move(List[FromIndex], List[ToIndex], Count * SizeOf(List[0]));\r\n InitializeArrayAfterMove(List, FromIndex, ToIndex, Count);\r\n end;\r\nend;\r\n\r\n\r\n{$ENDIF SUPPORTS_UNICODE_STRING}\r\n\r\n{$IFDEF SUPPORTS_UNICODE_STRING}\r\n//=== { TJclUnicodeStrUnicodeStrHashMap } ==========================================\r\n\r\nconstructor TJclUnicodeStrUnicodeStrHashMap.Create(ACapacity: Integer);\r\nbegin\r\n inherited Create;\r\n SetCapacity(ACapacity);\r\n FHashToRangeFunction := JclSimpleHashToRange;\r\nend;\r\n\r\ndestructor TJclUnicodeStrUnicodeStrHashMap.Destroy;\r\nbegin\r\n FReadOnly := False;\r\n Clear;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJclUnicodeStrUnicodeStrHashMap.AssignDataTo(Dest: TJclAbstractContainerBase);\r\nvar\r\n I, J: Integer;\r\n SelfBucket, NewBucket: TJclUnicodeStrUnicodeStrHashMapBucket;\r\n ADest: TJclUnicodeStrUnicodeStrHashMap;\r\n AMap: IJclUnicodeStrUnicodeStrMap;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n inherited AssignDataTo(Dest);\r\n if Dest is TJclUnicodeStrUnicodeStrHashMap then\r\n begin\r\n ADest := TJclUnicodeStrUnicodeStrHashMap(Dest);\r\n ADest.Clear;\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n SelfBucket := FBuckets[I];\r\n if SelfBucket <> nil then\r\n begin\r\n NewBucket := TJclUnicodeStrUnicodeStrHashMapBucket.Create;\r\n SetLength(NewBucket.Entries, SelfBucket.Size);\r\n for J := 0 to SelfBucket.Size - 1 do\r\n begin\r\n NewBucket.Entries[J].Key := SelfBucket.Entries[J].Key;\r\n NewBucket.Entries[J].Value := SelfBucket.Entries[J].Value;\r\n end;\r\n NewBucket.Size := SelfBucket.Size;\r\n ADest.FBuckets[I] := NewBucket;\r\n end;\r\n end;\r\n end\r\n else\r\n if Supports(IInterface(Dest), IJclUnicodeStrUnicodeStrMap, AMap) then\r\n begin\r\n AMap.Clear;\r\n AMap.PutAll(Self);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclUnicodeStrUnicodeStrHashMap.AssignPropertiesTo(Dest: TJclAbstractContainerBase);\r\nbegin\r\n inherited AssignPropertiesto(Dest);\r\n if Dest is TJclUnicodeStrUnicodeStrHashMap then\r\n TJclUnicodeStrUnicodeStrHashMap(Dest).FHashToRangeFunction := FHashToRangeFunction;\r\nend;\r\n\r\nprocedure TJclUnicodeStrUnicodeStrHashMap.Clear;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclUnicodeStrUnicodeStrHashMapBucket;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n begin\r\n for J := 0 to Bucket.Size - 1 do\r\n begin\r\n FreeKey(Bucket.Entries[J].Key);\r\n FreeValue(Bucket.Entries[J].Value);\r\n end;\r\n FreeAndNil(FBuckets[I]);\r\n end;\r\n end;\r\n FSize := 0;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclUnicodeStrUnicodeStrHashMap.ContainsKey(const Key: UnicodeString): Boolean;\r\nvar\r\n I: Integer;\r\n Bucket: TJclUnicodeStrUnicodeStrHashMapBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n Bucket := FBuckets[FHashToRangeFunction(Hash(Key), FCapacity)];\r\n if Bucket <> nil then\r\n for I := 0 to Bucket.Size - 1 do\r\n if KeysEqual(Bucket.Entries[I].Key, Key) then\r\n begin\r\n Result := True;\r\n Break;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclUnicodeStrUnicodeStrHashMap.ContainsValue(const Value: UnicodeString): Boolean;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclUnicodeStrUnicodeStrHashMapBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n for J := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[J];\r\n if Bucket <> nil then\r\n for I := 0 to Bucket.Size - 1 do\r\n if ValuesEqual(Bucket.Entries[I].Value, Value) then\r\n begin\r\n Result := True;\r\n Break;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclUnicodeStrUnicodeStrHashMap.Extract(const Key: UnicodeString): UnicodeString;\r\nvar\r\n Bucket: TJclUnicodeStrUnicodeStrHashMapBucket;\r\n I, NewCapacity: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := '';\r\n Bucket := FBuckets[FHashToRangeFunction(Hash(Key), FCapacity)];\r\n if Bucket <> nil then\r\n begin\r\n for I := 0 to Bucket.Size - 1 do\r\n if KeysEqual(Bucket.Entries[I].Key, Key) then\r\n begin\r\n Result := Bucket.Entries[I].Value;\r\n Bucket.Entries[I].Value := '';\r\n FreeKey(Bucket.Entries[I].Key);\r\n if I < Length(Bucket.Entries) - 1 then\r\n Bucket.MoveArray(Bucket.Entries, I + 1, I, Bucket.Size - I - 1);\r\n Dec(Bucket.Size);\r\n Dec(FSize);\r\n Break;\r\n end;\r\n\r\n NewCapacity := CalcPackCapacity(Length(Bucket.Entries), Bucket.Size);\r\n if NewCapacity < Length(Bucket.Entries) then\r\n SetLength(Bucket.Entries, NewCapacity);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclUnicodeStrUnicodeStrHashMap.GetValue(const Key: UnicodeString): UnicodeString;\r\nvar\r\n I: Integer;\r\n Bucket: TJclUnicodeStrUnicodeStrHashMapBucket;\r\n Found: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Found := False;\r\n Result := '';\r\n Bucket := FBuckets[FHashToRangeFunction(Hash(Key), FCapacity)];\r\n if Bucket <> nil then\r\n for I := 0 to Bucket.Size - 1 do\r\n if KeysEqual(Bucket.Entries[I].Key, Key) then\r\n begin\r\n Result := Bucket.Entries[I].Value;\r\n Found := True;\r\n Break;\r\n end;\r\n if (not Found) and (not FReturnDefaultElements) then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclUnicodeStrUnicodeStrHashMap.IsEmpty: Boolean;\r\nbegin\r\n Result := FSize = 0;\r\nend;\r\n\r\nfunction TJclUnicodeStrUnicodeStrHashMap.KeyOfValue(const Value: UnicodeString): UnicodeString;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclUnicodeStrUnicodeStrHashMapBucket;\r\n Found: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Found := False;\r\n Result := '';\r\n for J := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[J];\r\n if Bucket <> nil then\r\n for I := 0 to Bucket.Size - 1 do\r\n if ValuesEqual(Bucket.Entries[I].Value, Value) then\r\n begin\r\n Result := Bucket.Entries[I].Key;\r\n Found := True;\r\n Break;\r\n end;\r\n end;\r\n if (not Found) and (not FReturnDefaultElements) then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclUnicodeStrUnicodeStrHashMap.KeySet: IJclUnicodeStrSet;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclUnicodeStrUnicodeStrHashMapBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := TJclUnicodeStrArraySet.Create(FSize);\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n for J := 0 to Bucket.Size - 1 do\r\n Result.Add(Bucket.Entries[J].Key);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclUnicodeStrUnicodeStrHashMap.MapEquals(const AMap: IJclUnicodeStrUnicodeStrMap): Boolean;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclUnicodeStrUnicodeStrHashMapBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if AMap = nil then\r\n Exit;\r\n if FSize <> AMap.Size then\r\n Exit;\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n for J := 0 to Bucket.Size - 1 do\r\n if AMap.ContainsKey(Bucket.Entries[J].Key) then\r\n begin\r\n if not ValuesEqual(AMap.GetValue(Bucket.Entries[J].Key), Bucket.Entries[J].Value) then\r\n Exit;\r\n end\r\n else\r\n Exit;\r\n end;\r\n Result := True;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclUnicodeStrUnicodeStrHashMap.Pack;\r\nvar\r\n I: Integer;\r\n Bucket: TJclUnicodeStrUnicodeStrHashMapBucket;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n begin\r\n if Bucket.Size > 0 then\r\n SetLength(Bucket.Entries, Bucket.Size)\r\n else\r\n FreeAndNil(FBuckets[I]);\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclUnicodeStrUnicodeStrHashMap.PutAll(const AMap: IJclUnicodeStrUnicodeStrMap);\r\nvar\r\n It: IJclUnicodeStrIterator;\r\n Key: UnicodeString;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if AMap = nil then\r\n Exit;\r\n It := AMap.KeySet.First;\r\n while It.HasNext do\r\n begin\r\n Key := It.Next;\r\n PutValue(Key, AMap.GetValue(Key));\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclUnicodeStrUnicodeStrHashMap.PutValue(const Key: UnicodeString; const Value: UnicodeString);\r\nvar\r\n Index: Integer;\r\n Bucket: TJclUnicodeStrUnicodeStrHashMapBucket;\r\n I: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FAllowDefaultElements or (not KeysEqual(Key, '') and not ValuesEqual(Value, '')) then\r\n begin\r\n Index := FHashToRangeFunction(Hash(Key), FCapacity);\r\n Bucket := FBuckets[Index];\r\n if Bucket <> nil then\r\n begin\r\n for I := 0 to Bucket.Size - 1 do\r\n if KeysEqual(Bucket.Entries[I].Key, Key) then\r\n begin\r\n FreeValue(Bucket.Entries[I].Value);\r\n Bucket.Entries[I].Value := Value;\r\n Exit;\r\n end;\r\n end\r\n else\r\n begin\r\n Bucket := TJclUnicodeStrUnicodeStrHashMapBucket.Create;\r\n SetLength(Bucket.Entries, 1);\r\n FBuckets[Index] := Bucket;\r\n end;\r\n\r\n if Bucket.Size = Length(Bucket.Entries) then\r\n SetLength(Bucket.Entries, CalcGrowCapacity(Bucket.Size, Bucket.Size));\r\n\r\n if Bucket.Size < Length(Bucket.Entries) then\r\n begin\r\n Bucket.Entries[Bucket.Size].Key := Key;\r\n Bucket.Entries[Bucket.Size].Value := Value;\r\n Inc(Bucket.Size);\r\n Inc(FSize);\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclUnicodeStrUnicodeStrHashMap.Remove(const Key: UnicodeString): UnicodeString;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := Extract(Key);\r\n Result := FreeValue(Result);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclUnicodeStrUnicodeStrHashMap.SetCapacity(Value: Integer);\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FSize = 0 then\r\n begin\r\n SetLength(FBuckets, Value);\r\n inherited SetCapacity(Value);\r\n end\r\n else\r\n raise EJclOperationNotSupportedError.Create;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclUnicodeStrUnicodeStrHashMap.Size: Integer;\r\nbegin\r\n Result := FSize;\r\nend;\r\n\r\nfunction TJclUnicodeStrUnicodeStrHashMap.Values: IJclUnicodeStrCollection;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclUnicodeStrUnicodeStrHashMapBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := TJclUnicodeStrArrayList.Create(FSize);\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n for J := 0 to Bucket.Size - 1 do\r\n Result.Add(Bucket.Entries[J].Value);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclUnicodeStrUnicodeStrHashMap.CreateEmptyContainer: TJclAbstractContainerBase;\r\nbegin\r\n Result := TJclUnicodeStrUnicodeStrHashMap.Create(FCapacity);\r\n AssignPropertiesTo(Result);\r\nend;\r\n\r\nfunction TJclUnicodeStrUnicodeStrHashMap.FreeKey(var Key: UnicodeString): UnicodeString;\r\nbegin\r\n Result := Key;\r\n Key := '';\r\nend;\r\n\r\nfunction TJclUnicodeStrUnicodeStrHashMap.FreeValue(var Value: UnicodeString): UnicodeString;\r\nbegin\r\n Result := Value;\r\n Value := '';\r\nend;\r\n\r\nfunction TJclUnicodeStrUnicodeStrHashMap.KeysEqual(const A, B: UnicodeString): Boolean;\r\nbegin\r\n Result := ItemsEqual(A, B);\r\nend;\r\n\r\nfunction TJclUnicodeStrUnicodeStrHashMap.ValuesEqual(const A, B: UnicodeString): Boolean;\r\nbegin\r\n Result := ItemsEqual(A, B);\r\nend;\r\n\r\n{$ENDIF SUPPORTS_UNICODE_STRING}\r\n\r\n//=== { TJclSingleIntfHashMapBucket } ==========================================\r\n\r\nprocedure TJclSingleIntfHashMapBucket.FinalizeArrayBeforeMove(var List: TJclSingleIntfHashMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\nbegin\r\n Assert(Count > 0);\r\n if FromIndex < ToIndex then\r\n begin\r\n if Count > (ToIndex - FromIndex) then\r\n Finalize(List[FromIndex + Count], ToIndex - FromIndex)\r\n else\r\n Finalize(List[ToIndex], Count);\r\n end\r\n else\r\n if FromIndex > ToIndex then\r\n begin\r\n if Count > (FromIndex - ToIndex) then\r\n Count := FromIndex - ToIndex;\r\n Finalize(List[ToIndex], Count)\r\n end;\r\nend;\r\n\r\nprocedure TJclSingleIntfHashMapBucket.InitializeArray(var List: TJclSingleIntfHashMapEntryArray; FromIndex, Count: SizeInt);\r\nbegin\r\n {$IFDEF FPC}\r\n while Count > 0 do\r\n begin\r\n Initialize(List[FromIndex]);\r\n Inc(FromIndex);\r\n Dec(Count);\r\n end;\r\n {$ELSE ~FPC}\r\n Initialize(List[FromIndex], Count);\r\n {$ENDIF ~FPC}\r\nend;\r\n\r\nprocedure TJclSingleIntfHashMapBucket.InitializeArrayAfterMove(var List: TJclSingleIntfHashMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\nbegin\r\n { Keep reference counting working }\r\n if FromIndex < ToIndex then\r\n begin\r\n if (ToIndex - FromIndex) < Count then\r\n Count := ToIndex - FromIndex;\r\n InitializeArray(List, FromIndex, Count);\r\n end\r\n else\r\n if FromIndex > ToIndex then\r\n begin\r\n if (FromIndex - ToIndex) < Count then\r\n InitializeArray(List, ToIndex + Count, FromIndex - ToIndex)\r\n else\r\n InitializeArray(List, FromIndex, Count);\r\n end;\r\nend;\r\n\r\nprocedure TJclSingleIntfHashMapBucket.MoveArray(var List: TJclSingleIntfHashMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\nbegin\r\n if Count > 0 then\r\n begin\r\n FinalizeArrayBeforeMove(List, FromIndex, ToIndex, Count);\r\n Move(List[FromIndex], List[ToIndex], Count * SizeOf(List[0]));\r\n InitializeArrayAfterMove(List, FromIndex, ToIndex, Count);\r\n end;\r\nend;\r\n\r\n//=== { TJclSingleIntfHashMap } ==========================================\r\n\r\nconstructor TJclSingleIntfHashMap.Create(ACapacity: Integer);\r\nbegin\r\n inherited Create;\r\n SetCapacity(ACapacity);\r\n FHashToRangeFunction := JclSimpleHashToRange;\r\nend;\r\n\r\ndestructor TJclSingleIntfHashMap.Destroy;\r\nbegin\r\n FReadOnly := False;\r\n Clear;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJclSingleIntfHashMap.AssignDataTo(Dest: TJclAbstractContainerBase);\r\nvar\r\n I, J: Integer;\r\n SelfBucket, NewBucket: TJclSingleIntfHashMapBucket;\r\n ADest: TJclSingleIntfHashMap;\r\n AMap: IJclSingleIntfMap;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n inherited AssignDataTo(Dest);\r\n if Dest is TJclSingleIntfHashMap then\r\n begin\r\n ADest := TJclSingleIntfHashMap(Dest);\r\n ADest.Clear;\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n SelfBucket := FBuckets[I];\r\n if SelfBucket <> nil then\r\n begin\r\n NewBucket := TJclSingleIntfHashMapBucket.Create;\r\n SetLength(NewBucket.Entries, SelfBucket.Size);\r\n for J := 0 to SelfBucket.Size - 1 do\r\n begin\r\n NewBucket.Entries[J].Key := SelfBucket.Entries[J].Key;\r\n NewBucket.Entries[J].Value := SelfBucket.Entries[J].Value;\r\n end;\r\n NewBucket.Size := SelfBucket.Size;\r\n ADest.FBuckets[I] := NewBucket;\r\n end;\r\n end;\r\n end\r\n else\r\n if Supports(IInterface(Dest), IJclSingleIntfMap, AMap) then\r\n begin\r\n AMap.Clear;\r\n AMap.PutAll(Self);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclSingleIntfHashMap.AssignPropertiesTo(Dest: TJclAbstractContainerBase);\r\nbegin\r\n inherited AssignPropertiesto(Dest);\r\n if Dest is TJclSingleIntfHashMap then\r\n TJclSingleIntfHashMap(Dest).FHashToRangeFunction := FHashToRangeFunction;\r\nend;\r\n\r\nprocedure TJclSingleIntfHashMap.Clear;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclSingleIntfHashMapBucket;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n begin\r\n for J := 0 to Bucket.Size - 1 do\r\n begin\r\n FreeKey(Bucket.Entries[J].Key);\r\n FreeValue(Bucket.Entries[J].Value);\r\n end;\r\n FreeAndNil(FBuckets[I]);\r\n end;\r\n end;\r\n FSize := 0;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSingleIntfHashMap.ContainsKey(const Key: Single): Boolean;\r\nvar\r\n I: Integer;\r\n Bucket: TJclSingleIntfHashMapBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n Bucket := FBuckets[FHashToRangeFunction(Hash(Key), FCapacity)];\r\n if Bucket <> nil then\r\n for I := 0 to Bucket.Size - 1 do\r\n if KeysEqual(Bucket.Entries[I].Key, Key) then\r\n begin\r\n Result := True;\r\n Break;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSingleIntfHashMap.ContainsValue(const Value: IInterface): Boolean;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclSingleIntfHashMapBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n for J := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[J];\r\n if Bucket <> nil then\r\n for I := 0 to Bucket.Size - 1 do\r\n if ValuesEqual(Bucket.Entries[I].Value, Value) then\r\n begin\r\n Result := True;\r\n Break;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSingleIntfHashMap.Extract(const Key: Single): IInterface;\r\nvar\r\n Bucket: TJclSingleIntfHashMapBucket;\r\n I, NewCapacity: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := nil;\r\n Bucket := FBuckets[FHashToRangeFunction(Hash(Key), FCapacity)];\r\n if Bucket <> nil then\r\n begin\r\n for I := 0 to Bucket.Size - 1 do\r\n if KeysEqual(Bucket.Entries[I].Key, Key) then\r\n begin\r\n Result := Bucket.Entries[I].Value;\r\n Bucket.Entries[I].Value := nil;\r\n FreeKey(Bucket.Entries[I].Key);\r\n if I < Length(Bucket.Entries) - 1 then\r\n Bucket.MoveArray(Bucket.Entries, I + 1, I, Bucket.Size - I - 1);\r\n Dec(Bucket.Size);\r\n Dec(FSize);\r\n Break;\r\n end;\r\n\r\n NewCapacity := CalcPackCapacity(Length(Bucket.Entries), Bucket.Size);\r\n if NewCapacity < Length(Bucket.Entries) then\r\n SetLength(Bucket.Entries, NewCapacity);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSingleIntfHashMap.GetValue(const Key: Single): IInterface;\r\nvar\r\n I: Integer;\r\n Bucket: TJclSingleIntfHashMapBucket;\r\n Found: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Found := False;\r\n Result := nil;\r\n Bucket := FBuckets[FHashToRangeFunction(Hash(Key), FCapacity)];\r\n if Bucket <> nil then\r\n for I := 0 to Bucket.Size - 1 do\r\n if KeysEqual(Bucket.Entries[I].Key, Key) then\r\n begin\r\n Result := Bucket.Entries[I].Value;\r\n Found := True;\r\n Break;\r\n end;\r\n if (not Found) and (not FReturnDefaultElements) then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSingleIntfHashMap.IsEmpty: Boolean;\r\nbegin\r\n Result := FSize = 0;\r\nend;\r\n\r\nfunction TJclSingleIntfHashMap.KeyOfValue(const Value: IInterface): Single;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclSingleIntfHashMapBucket;\r\n Found: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Found := False;\r\n Result := 0.0;\r\n for J := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[J];\r\n if Bucket <> nil then\r\n for I := 0 to Bucket.Size - 1 do\r\n if ValuesEqual(Bucket.Entries[I].Value, Value) then\r\n begin\r\n Result := Bucket.Entries[I].Key;\r\n Found := True;\r\n Break;\r\n end;\r\n end;\r\n if (not Found) and (not FReturnDefaultElements) then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSingleIntfHashMap.KeySet: IJclSingleSet;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclSingleIntfHashMapBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := TJclSingleArraySet.Create(FSize);\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n for J := 0 to Bucket.Size - 1 do\r\n Result.Add(Bucket.Entries[J].Key);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSingleIntfHashMap.MapEquals(const AMap: IJclSingleIntfMap): Boolean;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclSingleIntfHashMapBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if AMap = nil then\r\n Exit;\r\n if FSize <> AMap.Size then\r\n Exit;\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n for J := 0 to Bucket.Size - 1 do\r\n if AMap.ContainsKey(Bucket.Entries[J].Key) then\r\n begin\r\n if not ValuesEqual(AMap.GetValue(Bucket.Entries[J].Key), Bucket.Entries[J].Value) then\r\n Exit;\r\n end\r\n else\r\n Exit;\r\n end;\r\n Result := True;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclSingleIntfHashMap.Pack;\r\nvar\r\n I: Integer;\r\n Bucket: TJclSingleIntfHashMapBucket;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n begin\r\n if Bucket.Size > 0 then\r\n SetLength(Bucket.Entries, Bucket.Size)\r\n else\r\n FreeAndNil(FBuckets[I]);\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclSingleIntfHashMap.PutAll(const AMap: IJclSingleIntfMap);\r\nvar\r\n It: IJclSingleIterator;\r\n Key: Single;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if AMap = nil then\r\n Exit;\r\n It := AMap.KeySet.First;\r\n while It.HasNext do\r\n begin\r\n Key := It.Next;\r\n PutValue(Key, AMap.GetValue(Key));\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclSingleIntfHashMap.PutValue(const Key: Single; const Value: IInterface);\r\nvar\r\n Index: Integer;\r\n Bucket: TJclSingleIntfHashMapBucket;\r\n I: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FAllowDefaultElements or (not KeysEqual(Key, 0.0) and not ValuesEqual(Value, nil)) then\r\n begin\r\n Index := FHashToRangeFunction(Hash(Key), FCapacity);\r\n Bucket := FBuckets[Index];\r\n if Bucket <> nil then\r\n begin\r\n for I := 0 to Bucket.Size - 1 do\r\n if KeysEqual(Bucket.Entries[I].Key, Key) then\r\n begin\r\n FreeValue(Bucket.Entries[I].Value);\r\n Bucket.Entries[I].Value := Value;\r\n Exit;\r\n end;\r\n end\r\n else\r\n begin\r\n Bucket := TJclSingleIntfHashMapBucket.Create;\r\n SetLength(Bucket.Entries, 1);\r\n FBuckets[Index] := Bucket;\r\n end;\r\n\r\n if Bucket.Size = Length(Bucket.Entries) then\r\n SetLength(Bucket.Entries, CalcGrowCapacity(Bucket.Size, Bucket.Size));\r\n\r\n if Bucket.Size < Length(Bucket.Entries) then\r\n begin\r\n Bucket.Entries[Bucket.Size].Key := Key;\r\n Bucket.Entries[Bucket.Size].Value := Value;\r\n Inc(Bucket.Size);\r\n Inc(FSize);\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSingleIntfHashMap.Remove(const Key: Single): IInterface;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := Extract(Key);\r\n Result := FreeValue(Result);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclSingleIntfHashMap.SetCapacity(Value: Integer);\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FSize = 0 then\r\n begin\r\n SetLength(FBuckets, Value);\r\n inherited SetCapacity(Value);\r\n end\r\n else\r\n raise EJclOperationNotSupportedError.Create;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSingleIntfHashMap.Size: Integer;\r\nbegin\r\n Result := FSize;\r\nend;\r\n\r\nfunction TJclSingleIntfHashMap.Values: IJclIntfCollection;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclSingleIntfHashMapBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := TJclIntfArrayList.Create(FSize);\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n for J := 0 to Bucket.Size - 1 do\r\n Result.Add(Bucket.Entries[J].Value);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSingleIntfHashMap.CreateEmptyContainer: TJclAbstractContainerBase;\r\nbegin\r\n Result := TJclSingleIntfHashMap.Create(FCapacity);\r\n AssignPropertiesTo(Result);\r\nend;\r\n\r\nfunction TJclSingleIntfHashMap.FreeKey(var Key: Single): Single;\r\nbegin\r\n Result := Key;\r\n Key := 0.0;\r\nend;\r\n\r\nfunction TJclSingleIntfHashMap.FreeValue(var Value: IInterface): IInterface;\r\nbegin\r\n Result := Value;\r\n Value := nil;\r\nend;\r\n\r\nfunction TJclSingleIntfHashMap.KeysEqual(const A, B: Single): Boolean;\r\nbegin\r\n Result := ItemsEqual(A, B);\r\nend;\r\n\r\nfunction TJclSingleIntfHashMap.ValuesEqual(const A, B: IInterface): Boolean;\r\nbegin\r\n Result := IntfSimpleEqualityCompare(A, B);\r\nend;\r\n\r\n//=== { TJclIntfSingleHashMapBucket } ==========================================\r\n\r\nprocedure TJclIntfSingleHashMapBucket.FinalizeArrayBeforeMove(var List: TJclIntfSingleHashMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\nbegin\r\n Assert(Count > 0);\r\n if FromIndex < ToIndex then\r\n begin\r\n if Count > (ToIndex - FromIndex) then\r\n Finalize(List[FromIndex + Count], ToIndex - FromIndex)\r\n else\r\n Finalize(List[ToIndex], Count);\r\n end\r\n else\r\n if FromIndex > ToIndex then\r\n begin\r\n if Count > (FromIndex - ToIndex) then\r\n Count := FromIndex - ToIndex;\r\n Finalize(List[ToIndex], Count)\r\n end;\r\nend;\r\n\r\nprocedure TJclIntfSingleHashMapBucket.InitializeArray(var List: TJclIntfSingleHashMapEntryArray; FromIndex, Count: SizeInt);\r\nbegin\r\n {$IFDEF FPC}\r\n while Count > 0 do\r\n begin\r\n Initialize(List[FromIndex]);\r\n Inc(FromIndex);\r\n Dec(Count);\r\n end;\r\n {$ELSE ~FPC}\r\n Initialize(List[FromIndex], Count);\r\n {$ENDIF ~FPC}\r\nend;\r\n\r\nprocedure TJclIntfSingleHashMapBucket.InitializeArrayAfterMove(var List: TJclIntfSingleHashMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\nbegin\r\n { Keep reference counting working }\r\n if FromIndex < ToIndex then\r\n begin\r\n if (ToIndex - FromIndex) < Count then\r\n Count := ToIndex - FromIndex;\r\n InitializeArray(List, FromIndex, Count);\r\n end\r\n else\r\n if FromIndex > ToIndex then\r\n begin\r\n if (FromIndex - ToIndex) < Count then\r\n InitializeArray(List, ToIndex + Count, FromIndex - ToIndex)\r\n else\r\n InitializeArray(List, FromIndex, Count);\r\n end;\r\nend;\r\n\r\nprocedure TJclIntfSingleHashMapBucket.MoveArray(var List: TJclIntfSingleHashMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\nbegin\r\n if Count > 0 then\r\n begin\r\n FinalizeArrayBeforeMove(List, FromIndex, ToIndex, Count);\r\n Move(List[FromIndex], List[ToIndex], Count * SizeOf(List[0]));\r\n InitializeArrayAfterMove(List, FromIndex, ToIndex, Count);\r\n end;\r\nend;\r\n\r\n//=== { TJclIntfSingleHashMap } ==========================================\r\n\r\nconstructor TJclIntfSingleHashMap.Create(ACapacity: Integer);\r\nbegin\r\n inherited Create;\r\n SetCapacity(ACapacity);\r\n FHashToRangeFunction := JclSimpleHashToRange;\r\nend;\r\n\r\ndestructor TJclIntfSingleHashMap.Destroy;\r\nbegin\r\n FReadOnly := False;\r\n Clear;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJclIntfSingleHashMap.AssignDataTo(Dest: TJclAbstractContainerBase);\r\nvar\r\n I, J: Integer;\r\n SelfBucket, NewBucket: TJclIntfSingleHashMapBucket;\r\n ADest: TJclIntfSingleHashMap;\r\n AMap: IJclIntfSingleMap;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n inherited AssignDataTo(Dest);\r\n if Dest is TJclIntfSingleHashMap then\r\n begin\r\n ADest := TJclIntfSingleHashMap(Dest);\r\n ADest.Clear;\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n SelfBucket := FBuckets[I];\r\n if SelfBucket <> nil then\r\n begin\r\n NewBucket := TJclIntfSingleHashMapBucket.Create;\r\n SetLength(NewBucket.Entries, SelfBucket.Size);\r\n for J := 0 to SelfBucket.Size - 1 do\r\n begin\r\n NewBucket.Entries[J].Key := SelfBucket.Entries[J].Key;\r\n NewBucket.Entries[J].Value := SelfBucket.Entries[J].Value;\r\n end;\r\n NewBucket.Size := SelfBucket.Size;\r\n ADest.FBuckets[I] := NewBucket;\r\n end;\r\n end;\r\n end\r\n else\r\n if Supports(IInterface(Dest), IJclIntfSingleMap, AMap) then\r\n begin\r\n AMap.Clear;\r\n AMap.PutAll(Self);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclIntfSingleHashMap.AssignPropertiesTo(Dest: TJclAbstractContainerBase);\r\nbegin\r\n inherited AssignPropertiesto(Dest);\r\n if Dest is TJclIntfSingleHashMap then\r\n TJclIntfSingleHashMap(Dest).FHashToRangeFunction := FHashToRangeFunction;\r\nend;\r\n\r\nprocedure TJclIntfSingleHashMap.Clear;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclIntfSingleHashMapBucket;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n begin\r\n for J := 0 to Bucket.Size - 1 do\r\n begin\r\n FreeKey(Bucket.Entries[J].Key);\r\n FreeValue(Bucket.Entries[J].Value);\r\n end;\r\n FreeAndNil(FBuckets[I]);\r\n end;\r\n end;\r\n FSize := 0;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfSingleHashMap.ContainsKey(const Key: IInterface): Boolean;\r\nvar\r\n I: Integer;\r\n Bucket: TJclIntfSingleHashMapBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n Bucket := FBuckets[FHashToRangeFunction(Hash(Key), FCapacity)];\r\n if Bucket <> nil then\r\n for I := 0 to Bucket.Size - 1 do\r\n if KeysEqual(Bucket.Entries[I].Key, Key) then\r\n begin\r\n Result := True;\r\n Break;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfSingleHashMap.ContainsValue(const Value: Single): Boolean;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclIntfSingleHashMapBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n for J := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[J];\r\n if Bucket <> nil then\r\n for I := 0 to Bucket.Size - 1 do\r\n if ValuesEqual(Bucket.Entries[I].Value, Value) then\r\n begin\r\n Result := True;\r\n Break;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfSingleHashMap.Extract(const Key: IInterface): Single;\r\nvar\r\n Bucket: TJclIntfSingleHashMapBucket;\r\n I, NewCapacity: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := 0.0;\r\n Bucket := FBuckets[FHashToRangeFunction(Hash(Key), FCapacity)];\r\n if Bucket <> nil then\r\n begin\r\n for I := 0 to Bucket.Size - 1 do\r\n if KeysEqual(Bucket.Entries[I].Key, Key) then\r\n begin\r\n Result := Bucket.Entries[I].Value;\r\n Bucket.Entries[I].Value := 0.0;\r\n FreeKey(Bucket.Entries[I].Key);\r\n if I < Length(Bucket.Entries) - 1 then\r\n Bucket.MoveArray(Bucket.Entries, I + 1, I, Bucket.Size - I - 1);\r\n Dec(Bucket.Size);\r\n Dec(FSize);\r\n Break;\r\n end;\r\n\r\n NewCapacity := CalcPackCapacity(Length(Bucket.Entries), Bucket.Size);\r\n if NewCapacity < Length(Bucket.Entries) then\r\n SetLength(Bucket.Entries, NewCapacity);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfSingleHashMap.GetValue(const Key: IInterface): Single;\r\nvar\r\n I: Integer;\r\n Bucket: TJclIntfSingleHashMapBucket;\r\n Found: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Found := False;\r\n Result := 0.0;\r\n Bucket := FBuckets[FHashToRangeFunction(Hash(Key), FCapacity)];\r\n if Bucket <> nil then\r\n for I := 0 to Bucket.Size - 1 do\r\n if KeysEqual(Bucket.Entries[I].Key, Key) then\r\n begin\r\n Result := Bucket.Entries[I].Value;\r\n Found := True;\r\n Break;\r\n end;\r\n if (not Found) and (not FReturnDefaultElements) then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfSingleHashMap.IsEmpty: Boolean;\r\nbegin\r\n Result := FSize = 0;\r\nend;\r\n\r\nfunction TJclIntfSingleHashMap.KeyOfValue(const Value: Single): IInterface;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclIntfSingleHashMapBucket;\r\n Found: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Found := False;\r\n Result := nil;\r\n for J := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[J];\r\n if Bucket <> nil then\r\n for I := 0 to Bucket.Size - 1 do\r\n if ValuesEqual(Bucket.Entries[I].Value, Value) then\r\n begin\r\n Result := Bucket.Entries[I].Key;\r\n Found := True;\r\n Break;\r\n end;\r\n end;\r\n if (not Found) and (not FReturnDefaultElements) then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfSingleHashMap.KeySet: IJclIntfSet;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclIntfSingleHashMapBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := TJclIntfArraySet.Create(FSize);\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n for J := 0 to Bucket.Size - 1 do\r\n Result.Add(Bucket.Entries[J].Key);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfSingleHashMap.MapEquals(const AMap: IJclIntfSingleMap): Boolean;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclIntfSingleHashMapBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if AMap = nil then\r\n Exit;\r\n if FSize <> AMap.Size then\r\n Exit;\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n for J := 0 to Bucket.Size - 1 do\r\n if AMap.ContainsKey(Bucket.Entries[J].Key) then\r\n begin\r\n if not ValuesEqual(AMap.GetValue(Bucket.Entries[J].Key), Bucket.Entries[J].Value) then\r\n Exit;\r\n end\r\n else\r\n Exit;\r\n end;\r\n Result := True;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclIntfSingleHashMap.Pack;\r\nvar\r\n I: Integer;\r\n Bucket: TJclIntfSingleHashMapBucket;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n begin\r\n if Bucket.Size > 0 then\r\n SetLength(Bucket.Entries, Bucket.Size)\r\n else\r\n FreeAndNil(FBuckets[I]);\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclIntfSingleHashMap.PutAll(const AMap: IJclIntfSingleMap);\r\nvar\r\n It: IJclIntfIterator;\r\n Key: IInterface;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if AMap = nil then\r\n Exit;\r\n It := AMap.KeySet.First;\r\n while It.HasNext do\r\n begin\r\n Key := It.Next;\r\n PutValue(Key, AMap.GetValue(Key));\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclIntfSingleHashMap.PutValue(const Key: IInterface; const Value: Single);\r\nvar\r\n Index: Integer;\r\n Bucket: TJclIntfSingleHashMapBucket;\r\n I: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FAllowDefaultElements or (not KeysEqual(Key, nil) and not ValuesEqual(Value, 0.0)) then\r\n begin\r\n Index := FHashToRangeFunction(Hash(Key), FCapacity);\r\n Bucket := FBuckets[Index];\r\n if Bucket <> nil then\r\n begin\r\n for I := 0 to Bucket.Size - 1 do\r\n if KeysEqual(Bucket.Entries[I].Key, Key) then\r\n begin\r\n FreeValue(Bucket.Entries[I].Value);\r\n Bucket.Entries[I].Value := Value;\r\n Exit;\r\n end;\r\n end\r\n else\r\n begin\r\n Bucket := TJclIntfSingleHashMapBucket.Create;\r\n SetLength(Bucket.Entries, 1);\r\n FBuckets[Index] := Bucket;\r\n end;\r\n\r\n if Bucket.Size = Length(Bucket.Entries) then\r\n SetLength(Bucket.Entries, CalcGrowCapacity(Bucket.Size, Bucket.Size));\r\n\r\n if Bucket.Size < Length(Bucket.Entries) then\r\n begin\r\n Bucket.Entries[Bucket.Size].Key := Key;\r\n Bucket.Entries[Bucket.Size].Value := Value;\r\n Inc(Bucket.Size);\r\n Inc(FSize);\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfSingleHashMap.Remove(const Key: IInterface): Single;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := Extract(Key);\r\n Result := FreeValue(Result);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclIntfSingleHashMap.SetCapacity(Value: Integer);\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FSize = 0 then\r\n begin\r\n SetLength(FBuckets, Value);\r\n inherited SetCapacity(Value);\r\n end\r\n else\r\n raise EJclOperationNotSupportedError.Create;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfSingleHashMap.Size: Integer;\r\nbegin\r\n Result := FSize;\r\nend;\r\n\r\nfunction TJclIntfSingleHashMap.Values: IJclSingleCollection;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclIntfSingleHashMapBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := TJclSingleArrayList.Create(FSize);\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n for J := 0 to Bucket.Size - 1 do\r\n Result.Add(Bucket.Entries[J].Value);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfSingleHashMap.CreateEmptyContainer: TJclAbstractContainerBase;\r\nbegin\r\n Result := TJclIntfSingleHashMap.Create(FCapacity);\r\n AssignPropertiesTo(Result);\r\nend;\r\n\r\nfunction TJclIntfSingleHashMap.FreeKey(var Key: IInterface): IInterface;\r\nbegin\r\n Result := Key;\r\n Key := nil;\r\nend;\r\n\r\nfunction TJclIntfSingleHashMap.FreeValue(var Value: Single): Single;\r\nbegin\r\n Result := Value;\r\n Value := 0.0;\r\nend;\r\n\r\nfunction TJclIntfSingleHashMap.Hash(const AInterface: IInterface): Integer;\r\nbegin\r\n Result := IntfSimpleHashConvert(AInterface);\r\nend;\r\n\r\nfunction TJclIntfSingleHashMap.KeysEqual(const A, B: IInterface): Boolean;\r\nbegin\r\n Result := IntfSimpleEqualityCompare(A, B);\r\nend;\r\n\r\nfunction TJclIntfSingleHashMap.ValuesEqual(const A, B: Single): Boolean;\r\nbegin\r\n Result := ItemsEqual(A, B);\r\nend;\r\n\r\n//=== { TJclSingleSingleHashMapBucket } ==========================================\r\n\r\nprocedure TJclSingleSingleHashMapBucket.InitializeArrayAfterMove(var List: TJclSingleSingleHashMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\nbegin\r\n { Clean array }\r\n if FromIndex < ToIndex then\r\n begin\r\n if (ToIndex - FromIndex) < Count then\r\n Count := ToIndex - FromIndex;\r\n FillChar(List[FromIndex], Count * SizeOf(List[0]), 0);\r\n end\r\n else\r\n if FromIndex > ToIndex then\r\n begin\r\n if (FromIndex - ToIndex) < Count then\r\n FillChar(List[ToIndex + Count], (FromIndex - ToIndex) * SizeOf(List[0]), 0)\r\n else\r\n FillChar(List[FromIndex], Count * SizeOf(List[0]), 0);\r\n end;\r\nend;\r\n\r\nprocedure TJclSingleSingleHashMapBucket.MoveArray(var List: TJclSingleSingleHashMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\nbegin\r\n if Count > 0 then\r\n begin\r\n Move(List[FromIndex], List[ToIndex], Count * SizeOf(List[0]));\r\n InitializeArrayAfterMove(List, FromIndex, ToIndex, Count);\r\n end;\r\nend;\r\n\r\n//=== { TJclSingleSingleHashMap } ==========================================\r\n\r\nconstructor TJclSingleSingleHashMap.Create(ACapacity: Integer);\r\nbegin\r\n inherited Create;\r\n SetCapacity(ACapacity);\r\n FHashToRangeFunction := JclSimpleHashToRange;\r\nend;\r\n\r\ndestructor TJclSingleSingleHashMap.Destroy;\r\nbegin\r\n FReadOnly := False;\r\n Clear;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJclSingleSingleHashMap.AssignDataTo(Dest: TJclAbstractContainerBase);\r\nvar\r\n I, J: Integer;\r\n SelfBucket, NewBucket: TJclSingleSingleHashMapBucket;\r\n ADest: TJclSingleSingleHashMap;\r\n AMap: IJclSingleSingleMap;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n inherited AssignDataTo(Dest);\r\n if Dest is TJclSingleSingleHashMap then\r\n begin\r\n ADest := TJclSingleSingleHashMap(Dest);\r\n ADest.Clear;\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n SelfBucket := FBuckets[I];\r\n if SelfBucket <> nil then\r\n begin\r\n NewBucket := TJclSingleSingleHashMapBucket.Create;\r\n SetLength(NewBucket.Entries, SelfBucket.Size);\r\n for J := 0 to SelfBucket.Size - 1 do\r\n begin\r\n NewBucket.Entries[J].Key := SelfBucket.Entries[J].Key;\r\n NewBucket.Entries[J].Value := SelfBucket.Entries[J].Value;\r\n end;\r\n NewBucket.Size := SelfBucket.Size;\r\n ADest.FBuckets[I] := NewBucket;\r\n end;\r\n end;\r\n end\r\n else\r\n if Supports(IInterface(Dest), IJclSingleSingleMap, AMap) then\r\n begin\r\n AMap.Clear;\r\n AMap.PutAll(Self);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclSingleSingleHashMap.AssignPropertiesTo(Dest: TJclAbstractContainerBase);\r\nbegin\r\n inherited AssignPropertiesto(Dest);\r\n if Dest is TJclSingleSingleHashMap then\r\n TJclSingleSingleHashMap(Dest).FHashToRangeFunction := FHashToRangeFunction;\r\nend;\r\n\r\nprocedure TJclSingleSingleHashMap.Clear;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclSingleSingleHashMapBucket;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n begin\r\n for J := 0 to Bucket.Size - 1 do\r\n begin\r\n FreeKey(Bucket.Entries[J].Key);\r\n FreeValue(Bucket.Entries[J].Value);\r\n end;\r\n FreeAndNil(FBuckets[I]);\r\n end;\r\n end;\r\n FSize := 0;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSingleSingleHashMap.ContainsKey(const Key: Single): Boolean;\r\nvar\r\n I: Integer;\r\n Bucket: TJclSingleSingleHashMapBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n Bucket := FBuckets[FHashToRangeFunction(Hash(Key), FCapacity)];\r\n if Bucket <> nil then\r\n for I := 0 to Bucket.Size - 1 do\r\n if KeysEqual(Bucket.Entries[I].Key, Key) then\r\n begin\r\n Result := True;\r\n Break;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSingleSingleHashMap.ContainsValue(const Value: Single): Boolean;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclSingleSingleHashMapBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n for J := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[J];\r\n if Bucket <> nil then\r\n for I := 0 to Bucket.Size - 1 do\r\n if ValuesEqual(Bucket.Entries[I].Value, Value) then\r\n begin\r\n Result := True;\r\n Break;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSingleSingleHashMap.Extract(const Key: Single): Single;\r\nvar\r\n Bucket: TJclSingleSingleHashMapBucket;\r\n I, NewCapacity: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := 0.0;\r\n Bucket := FBuckets[FHashToRangeFunction(Hash(Key), FCapacity)];\r\n if Bucket <> nil then\r\n begin\r\n for I := 0 to Bucket.Size - 1 do\r\n if KeysEqual(Bucket.Entries[I].Key, Key) then\r\n begin\r\n Result := Bucket.Entries[I].Value;\r\n Bucket.Entries[I].Value := 0.0;\r\n FreeKey(Bucket.Entries[I].Key);\r\n if I < Length(Bucket.Entries) - 1 then\r\n Bucket.MoveArray(Bucket.Entries, I + 1, I, Bucket.Size - I - 1);\r\n Dec(Bucket.Size);\r\n Dec(FSize);\r\n Break;\r\n end;\r\n\r\n NewCapacity := CalcPackCapacity(Length(Bucket.Entries), Bucket.Size);\r\n if NewCapacity < Length(Bucket.Entries) then\r\n SetLength(Bucket.Entries, NewCapacity);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSingleSingleHashMap.GetValue(const Key: Single): Single;\r\nvar\r\n I: Integer;\r\n Bucket: TJclSingleSingleHashMapBucket;\r\n Found: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Found := False;\r\n Result := 0.0;\r\n Bucket := FBuckets[FHashToRangeFunction(Hash(Key), FCapacity)];\r\n if Bucket <> nil then\r\n for I := 0 to Bucket.Size - 1 do\r\n if KeysEqual(Bucket.Entries[I].Key, Key) then\r\n begin\r\n Result := Bucket.Entries[I].Value;\r\n Found := True;\r\n Break;\r\n end;\r\n if (not Found) and (not FReturnDefaultElements) then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSingleSingleHashMap.IsEmpty: Boolean;\r\nbegin\r\n Result := FSize = 0;\r\nend;\r\n\r\nfunction TJclSingleSingleHashMap.KeyOfValue(const Value: Single): Single;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclSingleSingleHashMapBucket;\r\n Found: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Found := False;\r\n Result := 0.0;\r\n for J := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[J];\r\n if Bucket <> nil then\r\n for I := 0 to Bucket.Size - 1 do\r\n if ValuesEqual(Bucket.Entries[I].Value, Value) then\r\n begin\r\n Result := Bucket.Entries[I].Key;\r\n Found := True;\r\n Break;\r\n end;\r\n end;\r\n if (not Found) and (not FReturnDefaultElements) then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSingleSingleHashMap.KeySet: IJclSingleSet;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclSingleSingleHashMapBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := TJclSingleArraySet.Create(FSize);\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n for J := 0 to Bucket.Size - 1 do\r\n Result.Add(Bucket.Entries[J].Key);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSingleSingleHashMap.MapEquals(const AMap: IJclSingleSingleMap): Boolean;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclSingleSingleHashMapBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if AMap = nil then\r\n Exit;\r\n if FSize <> AMap.Size then\r\n Exit;\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n for J := 0 to Bucket.Size - 1 do\r\n if AMap.ContainsKey(Bucket.Entries[J].Key) then\r\n begin\r\n if not ValuesEqual(AMap.GetValue(Bucket.Entries[J].Key), Bucket.Entries[J].Value) then\r\n Exit;\r\n end\r\n else\r\n Exit;\r\n end;\r\n Result := True;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclSingleSingleHashMap.Pack;\r\nvar\r\n I: Integer;\r\n Bucket: TJclSingleSingleHashMapBucket;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n begin\r\n if Bucket.Size > 0 then\r\n SetLength(Bucket.Entries, Bucket.Size)\r\n else\r\n FreeAndNil(FBuckets[I]);\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclSingleSingleHashMap.PutAll(const AMap: IJclSingleSingleMap);\r\nvar\r\n It: IJclSingleIterator;\r\n Key: Single;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if AMap = nil then\r\n Exit;\r\n It := AMap.KeySet.First;\r\n while It.HasNext do\r\n begin\r\n Key := It.Next;\r\n PutValue(Key, AMap.GetValue(Key));\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclSingleSingleHashMap.PutValue(const Key: Single; const Value: Single);\r\nvar\r\n Index: Integer;\r\n Bucket: TJclSingleSingleHashMapBucket;\r\n I: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FAllowDefaultElements or (not KeysEqual(Key, 0.0) and not ValuesEqual(Value, 0.0)) then\r\n begin\r\n Index := FHashToRangeFunction(Hash(Key), FCapacity);\r\n Bucket := FBuckets[Index];\r\n if Bucket <> nil then\r\n begin\r\n for I := 0 to Bucket.Size - 1 do\r\n if KeysEqual(Bucket.Entries[I].Key, Key) then\r\n begin\r\n FreeValue(Bucket.Entries[I].Value);\r\n Bucket.Entries[I].Value := Value;\r\n Exit;\r\n end;\r\n end\r\n else\r\n begin\r\n Bucket := TJclSingleSingleHashMapBucket.Create;\r\n SetLength(Bucket.Entries, 1);\r\n FBuckets[Index] := Bucket;\r\n end;\r\n\r\n if Bucket.Size = Length(Bucket.Entries) then\r\n SetLength(Bucket.Entries, CalcGrowCapacity(Bucket.Size, Bucket.Size));\r\n\r\n if Bucket.Size < Length(Bucket.Entries) then\r\n begin\r\n Bucket.Entries[Bucket.Size].Key := Key;\r\n Bucket.Entries[Bucket.Size].Value := Value;\r\n Inc(Bucket.Size);\r\n Inc(FSize);\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSingleSingleHashMap.Remove(const Key: Single): Single;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := Extract(Key);\r\n Result := FreeValue(Result);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclSingleSingleHashMap.SetCapacity(Value: Integer);\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FSize = 0 then\r\n begin\r\n SetLength(FBuckets, Value);\r\n inherited SetCapacity(Value);\r\n end\r\n else\r\n raise EJclOperationNotSupportedError.Create;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSingleSingleHashMap.Size: Integer;\r\nbegin\r\n Result := FSize;\r\nend;\r\n\r\nfunction TJclSingleSingleHashMap.Values: IJclSingleCollection;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclSingleSingleHashMapBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := TJclSingleArrayList.Create(FSize);\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n for J := 0 to Bucket.Size - 1 do\r\n Result.Add(Bucket.Entries[J].Value);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSingleSingleHashMap.CreateEmptyContainer: TJclAbstractContainerBase;\r\nbegin\r\n Result := TJclSingleSingleHashMap.Create(FCapacity);\r\n AssignPropertiesTo(Result);\r\nend;\r\n\r\nfunction TJclSingleSingleHashMap.FreeKey(var Key: Single): Single;\r\nbegin\r\n Result := Key;\r\n Key := 0.0;\r\nend;\r\n\r\nfunction TJclSingleSingleHashMap.FreeValue(var Value: Single): Single;\r\nbegin\r\n Result := Value;\r\n Value := 0.0;\r\nend;\r\n\r\nfunction TJclSingleSingleHashMap.KeysEqual(const A, B: Single): Boolean;\r\nbegin\r\n Result := ItemsEqual(A, B);\r\nend;\r\n\r\nfunction TJclSingleSingleHashMap.ValuesEqual(const A, B: Single): Boolean;\r\nbegin\r\n Result := ItemsEqual(A, B);\r\nend;\r\n\r\n//=== { TJclDoubleIntfHashMapBucket } ==========================================\r\n\r\nprocedure TJclDoubleIntfHashMapBucket.FinalizeArrayBeforeMove(var List: TJclDoubleIntfHashMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\nbegin\r\n Assert(Count > 0);\r\n if FromIndex < ToIndex then\r\n begin\r\n if Count > (ToIndex - FromIndex) then\r\n Finalize(List[FromIndex + Count], ToIndex - FromIndex)\r\n else\r\n Finalize(List[ToIndex], Count);\r\n end\r\n else\r\n if FromIndex > ToIndex then\r\n begin\r\n if Count > (FromIndex - ToIndex) then\r\n Count := FromIndex - ToIndex;\r\n Finalize(List[ToIndex], Count)\r\n end;\r\nend;\r\n\r\nprocedure TJclDoubleIntfHashMapBucket.InitializeArray(var List: TJclDoubleIntfHashMapEntryArray; FromIndex, Count: SizeInt);\r\nbegin\r\n {$IFDEF FPC}\r\n while Count > 0 do\r\n begin\r\n Initialize(List[FromIndex]);\r\n Inc(FromIndex);\r\n Dec(Count);\r\n end;\r\n {$ELSE ~FPC}\r\n Initialize(List[FromIndex], Count);\r\n {$ENDIF ~FPC}\r\nend;\r\n\r\nprocedure TJclDoubleIntfHashMapBucket.InitializeArrayAfterMove(var List: TJclDoubleIntfHashMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\nbegin\r\n { Keep reference counting working }\r\n if FromIndex < ToIndex then\r\n begin\r\n if (ToIndex - FromIndex) < Count then\r\n Count := ToIndex - FromIndex;\r\n InitializeArray(List, FromIndex, Count);\r\n end\r\n else\r\n if FromIndex > ToIndex then\r\n begin\r\n if (FromIndex - ToIndex) < Count then\r\n InitializeArray(List, ToIndex + Count, FromIndex - ToIndex)\r\n else\r\n InitializeArray(List, FromIndex, Count);\r\n end;\r\nend;\r\n\r\nprocedure TJclDoubleIntfHashMapBucket.MoveArray(var List: TJclDoubleIntfHashMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\nbegin\r\n if Count > 0 then\r\n begin\r\n FinalizeArrayBeforeMove(List, FromIndex, ToIndex, Count);\r\n Move(List[FromIndex], List[ToIndex], Count * SizeOf(List[0]));\r\n InitializeArrayAfterMove(List, FromIndex, ToIndex, Count);\r\n end;\r\nend;\r\n\r\n//=== { TJclDoubleIntfHashMap } ==========================================\r\n\r\nconstructor TJclDoubleIntfHashMap.Create(ACapacity: Integer);\r\nbegin\r\n inherited Create;\r\n SetCapacity(ACapacity);\r\n FHashToRangeFunction := JclSimpleHashToRange;\r\nend;\r\n\r\ndestructor TJclDoubleIntfHashMap.Destroy;\r\nbegin\r\n FReadOnly := False;\r\n Clear;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJclDoubleIntfHashMap.AssignDataTo(Dest: TJclAbstractContainerBase);\r\nvar\r\n I, J: Integer;\r\n SelfBucket, NewBucket: TJclDoubleIntfHashMapBucket;\r\n ADest: TJclDoubleIntfHashMap;\r\n AMap: IJclDoubleIntfMap;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n inherited AssignDataTo(Dest);\r\n if Dest is TJclDoubleIntfHashMap then\r\n begin\r\n ADest := TJclDoubleIntfHashMap(Dest);\r\n ADest.Clear;\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n SelfBucket := FBuckets[I];\r\n if SelfBucket <> nil then\r\n begin\r\n NewBucket := TJclDoubleIntfHashMapBucket.Create;\r\n SetLength(NewBucket.Entries, SelfBucket.Size);\r\n for J := 0 to SelfBucket.Size - 1 do\r\n begin\r\n NewBucket.Entries[J].Key := SelfBucket.Entries[J].Key;\r\n NewBucket.Entries[J].Value := SelfBucket.Entries[J].Value;\r\n end;\r\n NewBucket.Size := SelfBucket.Size;\r\n ADest.FBuckets[I] := NewBucket;\r\n end;\r\n end;\r\n end\r\n else\r\n if Supports(IInterface(Dest), IJclDoubleIntfMap, AMap) then\r\n begin\r\n AMap.Clear;\r\n AMap.PutAll(Self);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclDoubleIntfHashMap.AssignPropertiesTo(Dest: TJclAbstractContainerBase);\r\nbegin\r\n inherited AssignPropertiesto(Dest);\r\n if Dest is TJclDoubleIntfHashMap then\r\n TJclDoubleIntfHashMap(Dest).FHashToRangeFunction := FHashToRangeFunction;\r\nend;\r\n\r\nprocedure TJclDoubleIntfHashMap.Clear;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclDoubleIntfHashMapBucket;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n begin\r\n for J := 0 to Bucket.Size - 1 do\r\n begin\r\n FreeKey(Bucket.Entries[J].Key);\r\n FreeValue(Bucket.Entries[J].Value);\r\n end;\r\n FreeAndNil(FBuckets[I]);\r\n end;\r\n end;\r\n FSize := 0;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclDoubleIntfHashMap.ContainsKey(const Key: Double): Boolean;\r\nvar\r\n I: Integer;\r\n Bucket: TJclDoubleIntfHashMapBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n Bucket := FBuckets[FHashToRangeFunction(Hash(Key), FCapacity)];\r\n if Bucket <> nil then\r\n for I := 0 to Bucket.Size - 1 do\r\n if KeysEqual(Bucket.Entries[I].Key, Key) then\r\n begin\r\n Result := True;\r\n Break;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclDoubleIntfHashMap.ContainsValue(const Value: IInterface): Boolean;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclDoubleIntfHashMapBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n for J := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[J];\r\n if Bucket <> nil then\r\n for I := 0 to Bucket.Size - 1 do\r\n if ValuesEqual(Bucket.Entries[I].Value, Value) then\r\n begin\r\n Result := True;\r\n Break;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclDoubleIntfHashMap.Extract(const Key: Double): IInterface;\r\nvar\r\n Bucket: TJclDoubleIntfHashMapBucket;\r\n I, NewCapacity: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := nil;\r\n Bucket := FBuckets[FHashToRangeFunction(Hash(Key), FCapacity)];\r\n if Bucket <> nil then\r\n begin\r\n for I := 0 to Bucket.Size - 1 do\r\n if KeysEqual(Bucket.Entries[I].Key, Key) then\r\n begin\r\n Result := Bucket.Entries[I].Value;\r\n Bucket.Entries[I].Value := nil;\r\n FreeKey(Bucket.Entries[I].Key);\r\n if I < Length(Bucket.Entries) - 1 then\r\n Bucket.MoveArray(Bucket.Entries, I + 1, I, Bucket.Size - I - 1);\r\n Dec(Bucket.Size);\r\n Dec(FSize);\r\n Break;\r\n end;\r\n\r\n NewCapacity := CalcPackCapacity(Length(Bucket.Entries), Bucket.Size);\r\n if NewCapacity < Length(Bucket.Entries) then\r\n SetLength(Bucket.Entries, NewCapacity);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclDoubleIntfHashMap.GetValue(const Key: Double): IInterface;\r\nvar\r\n I: Integer;\r\n Bucket: TJclDoubleIntfHashMapBucket;\r\n Found: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Found := False;\r\n Result := nil;\r\n Bucket := FBuckets[FHashToRangeFunction(Hash(Key), FCapacity)];\r\n if Bucket <> nil then\r\n for I := 0 to Bucket.Size - 1 do\r\n if KeysEqual(Bucket.Entries[I].Key, Key) then\r\n begin\r\n Result := Bucket.Entries[I].Value;\r\n Found := True;\r\n Break;\r\n end;\r\n if (not Found) and (not FReturnDefaultElements) then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclDoubleIntfHashMap.IsEmpty: Boolean;\r\nbegin\r\n Result := FSize = 0;\r\nend;\r\n\r\nfunction TJclDoubleIntfHashMap.KeyOfValue(const Value: IInterface): Double;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclDoubleIntfHashMapBucket;\r\n Found: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Found := False;\r\n Result := 0.0;\r\n for J := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[J];\r\n if Bucket <> nil then\r\n for I := 0 to Bucket.Size - 1 do\r\n if ValuesEqual(Bucket.Entries[I].Value, Value) then\r\n begin\r\n Result := Bucket.Entries[I].Key;\r\n Found := True;\r\n Break;\r\n end;\r\n end;\r\n if (not Found) and (not FReturnDefaultElements) then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclDoubleIntfHashMap.KeySet: IJclDoubleSet;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclDoubleIntfHashMapBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := TJclDoubleArraySet.Create(FSize);\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n for J := 0 to Bucket.Size - 1 do\r\n Result.Add(Bucket.Entries[J].Key);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclDoubleIntfHashMap.MapEquals(const AMap: IJclDoubleIntfMap): Boolean;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclDoubleIntfHashMapBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if AMap = nil then\r\n Exit;\r\n if FSize <> AMap.Size then\r\n Exit;\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n for J := 0 to Bucket.Size - 1 do\r\n if AMap.ContainsKey(Bucket.Entries[J].Key) then\r\n begin\r\n if not ValuesEqual(AMap.GetValue(Bucket.Entries[J].Key), Bucket.Entries[J].Value) then\r\n Exit;\r\n end\r\n else\r\n Exit;\r\n end;\r\n Result := True;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclDoubleIntfHashMap.Pack;\r\nvar\r\n I: Integer;\r\n Bucket: TJclDoubleIntfHashMapBucket;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n begin\r\n if Bucket.Size > 0 then\r\n SetLength(Bucket.Entries, Bucket.Size)\r\n else\r\n FreeAndNil(FBuckets[I]);\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclDoubleIntfHashMap.PutAll(const AMap: IJclDoubleIntfMap);\r\nvar\r\n It: IJclDoubleIterator;\r\n Key: Double;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if AMap = nil then\r\n Exit;\r\n It := AMap.KeySet.First;\r\n while It.HasNext do\r\n begin\r\n Key := It.Next;\r\n PutValue(Key, AMap.GetValue(Key));\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclDoubleIntfHashMap.PutValue(const Key: Double; const Value: IInterface);\r\nvar\r\n Index: Integer;\r\n Bucket: TJclDoubleIntfHashMapBucket;\r\n I: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FAllowDefaultElements or (not KeysEqual(Key, 0.0) and not ValuesEqual(Value, nil)) then\r\n begin\r\n Index := FHashToRangeFunction(Hash(Key), FCapacity);\r\n Bucket := FBuckets[Index];\r\n if Bucket <> nil then\r\n begin\r\n for I := 0 to Bucket.Size - 1 do\r\n if KeysEqual(Bucket.Entries[I].Key, Key) then\r\n begin\r\n FreeValue(Bucket.Entries[I].Value);\r\n Bucket.Entries[I].Value := Value;\r\n Exit;\r\n end;\r\n end\r\n else\r\n begin\r\n Bucket := TJclDoubleIntfHashMapBucket.Create;\r\n SetLength(Bucket.Entries, 1);\r\n FBuckets[Index] := Bucket;\r\n end;\r\n\r\n if Bucket.Size = Length(Bucket.Entries) then\r\n SetLength(Bucket.Entries, CalcGrowCapacity(Bucket.Size, Bucket.Size));\r\n\r\n if Bucket.Size < Length(Bucket.Entries) then\r\n begin\r\n Bucket.Entries[Bucket.Size].Key := Key;\r\n Bucket.Entries[Bucket.Size].Value := Value;\r\n Inc(Bucket.Size);\r\n Inc(FSize);\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclDoubleIntfHashMap.Remove(const Key: Double): IInterface;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := Extract(Key);\r\n Result := FreeValue(Result);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclDoubleIntfHashMap.SetCapacity(Value: Integer);\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FSize = 0 then\r\n begin\r\n SetLength(FBuckets, Value);\r\n inherited SetCapacity(Value);\r\n end\r\n else\r\n raise EJclOperationNotSupportedError.Create;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclDoubleIntfHashMap.Size: Integer;\r\nbegin\r\n Result := FSize;\r\nend;\r\n\r\nfunction TJclDoubleIntfHashMap.Values: IJclIntfCollection;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclDoubleIntfHashMapBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := TJclIntfArrayList.Create(FSize);\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n for J := 0 to Bucket.Size - 1 do\r\n Result.Add(Bucket.Entries[J].Value);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclDoubleIntfHashMap.CreateEmptyContainer: TJclAbstractContainerBase;\r\nbegin\r\n Result := TJclDoubleIntfHashMap.Create(FCapacity);\r\n AssignPropertiesTo(Result);\r\nend;\r\n\r\nfunction TJclDoubleIntfHashMap.FreeKey(var Key: Double): Double;\r\nbegin\r\n Result := Key;\r\n Key := 0.0;\r\nend;\r\n\r\nfunction TJclDoubleIntfHashMap.FreeValue(var Value: IInterface): IInterface;\r\nbegin\r\n Result := Value;\r\n Value := nil;\r\nend;\r\n\r\nfunction TJclDoubleIntfHashMap.KeysEqual(const A, B: Double): Boolean;\r\nbegin\r\n Result := ItemsEqual(A, B);\r\nend;\r\n\r\nfunction TJclDoubleIntfHashMap.ValuesEqual(const A, B: IInterface): Boolean;\r\nbegin\r\n Result := IntfSimpleEqualityCompare(A, B);\r\nend;\r\n\r\n//=== { TJclIntfDoubleHashMapBucket } ==========================================\r\n\r\nprocedure TJclIntfDoubleHashMapBucket.FinalizeArrayBeforeMove(var List: TJclIntfDoubleHashMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\nbegin\r\n Assert(Count > 0);\r\n if FromIndex < ToIndex then\r\n begin\r\n if Count > (ToIndex - FromIndex) then\r\n Finalize(List[FromIndex + Count], ToIndex - FromIndex)\r\n else\r\n Finalize(List[ToIndex], Count);\r\n end\r\n else\r\n if FromIndex > ToIndex then\r\n begin\r\n if Count > (FromIndex - ToIndex) then\r\n Count := FromIndex - ToIndex;\r\n Finalize(List[ToIndex], Count)\r\n end;\r\nend;\r\n\r\nprocedure TJclIntfDoubleHashMapBucket.InitializeArray(var List: TJclIntfDoubleHashMapEntryArray; FromIndex, Count: SizeInt);\r\nbegin\r\n {$IFDEF FPC}\r\n while Count > 0 do\r\n begin\r\n Initialize(List[FromIndex]);\r\n Inc(FromIndex);\r\n Dec(Count);\r\n end;\r\n {$ELSE ~FPC}\r\n Initialize(List[FromIndex], Count);\r\n {$ENDIF ~FPC}\r\nend;\r\n\r\nprocedure TJclIntfDoubleHashMapBucket.InitializeArrayAfterMove(var List: TJclIntfDoubleHashMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\nbegin\r\n { Keep reference counting working }\r\n if FromIndex < ToIndex then\r\n begin\r\n if (ToIndex - FromIndex) < Count then\r\n Count := ToIndex - FromIndex;\r\n InitializeArray(List, FromIndex, Count);\r\n end\r\n else\r\n if FromIndex > ToIndex then\r\n begin\r\n if (FromIndex - ToIndex) < Count then\r\n InitializeArray(List, ToIndex + Count, FromIndex - ToIndex)\r\n else\r\n InitializeArray(List, FromIndex, Count);\r\n end;\r\nend;\r\n\r\nprocedure TJclIntfDoubleHashMapBucket.MoveArray(var List: TJclIntfDoubleHashMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\nbegin\r\n if Count > 0 then\r\n begin\r\n FinalizeArrayBeforeMove(List, FromIndex, ToIndex, Count);\r\n Move(List[FromIndex], List[ToIndex], Count * SizeOf(List[0]));\r\n InitializeArrayAfterMove(List, FromIndex, ToIndex, Count);\r\n end;\r\nend;\r\n\r\n//=== { TJclIntfDoubleHashMap } ==========================================\r\n\r\nconstructor TJclIntfDoubleHashMap.Create(ACapacity: Integer);\r\nbegin\r\n inherited Create;\r\n SetCapacity(ACapacity);\r\n FHashToRangeFunction := JclSimpleHashToRange;\r\nend;\r\n\r\ndestructor TJclIntfDoubleHashMap.Destroy;\r\nbegin\r\n FReadOnly := False;\r\n Clear;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJclIntfDoubleHashMap.AssignDataTo(Dest: TJclAbstractContainerBase);\r\nvar\r\n I, J: Integer;\r\n SelfBucket, NewBucket: TJclIntfDoubleHashMapBucket;\r\n ADest: TJclIntfDoubleHashMap;\r\n AMap: IJclIntfDoubleMap;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n inherited AssignDataTo(Dest);\r\n if Dest is TJclIntfDoubleHashMap then\r\n begin\r\n ADest := TJclIntfDoubleHashMap(Dest);\r\n ADest.Clear;\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n SelfBucket := FBuckets[I];\r\n if SelfBucket <> nil then\r\n begin\r\n NewBucket := TJclIntfDoubleHashMapBucket.Create;\r\n SetLength(NewBucket.Entries, SelfBucket.Size);\r\n for J := 0 to SelfBucket.Size - 1 do\r\n begin\r\n NewBucket.Entries[J].Key := SelfBucket.Entries[J].Key;\r\n NewBucket.Entries[J].Value := SelfBucket.Entries[J].Value;\r\n end;\r\n NewBucket.Size := SelfBucket.Size;\r\n ADest.FBuckets[I] := NewBucket;\r\n end;\r\n end;\r\n end\r\n else\r\n if Supports(IInterface(Dest), IJclIntfDoubleMap, AMap) then\r\n begin\r\n AMap.Clear;\r\n AMap.PutAll(Self);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclIntfDoubleHashMap.AssignPropertiesTo(Dest: TJclAbstractContainerBase);\r\nbegin\r\n inherited AssignPropertiesto(Dest);\r\n if Dest is TJclIntfDoubleHashMap then\r\n TJclIntfDoubleHashMap(Dest).FHashToRangeFunction := FHashToRangeFunction;\r\nend;\r\n\r\nprocedure TJclIntfDoubleHashMap.Clear;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclIntfDoubleHashMapBucket;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n begin\r\n for J := 0 to Bucket.Size - 1 do\r\n begin\r\n FreeKey(Bucket.Entries[J].Key);\r\n FreeValue(Bucket.Entries[J].Value);\r\n end;\r\n FreeAndNil(FBuckets[I]);\r\n end;\r\n end;\r\n FSize := 0;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfDoubleHashMap.ContainsKey(const Key: IInterface): Boolean;\r\nvar\r\n I: Integer;\r\n Bucket: TJclIntfDoubleHashMapBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n Bucket := FBuckets[FHashToRangeFunction(Hash(Key), FCapacity)];\r\n if Bucket <> nil then\r\n for I := 0 to Bucket.Size - 1 do\r\n if KeysEqual(Bucket.Entries[I].Key, Key) then\r\n begin\r\n Result := True;\r\n Break;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfDoubleHashMap.ContainsValue(const Value: Double): Boolean;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclIntfDoubleHashMapBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n for J := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[J];\r\n if Bucket <> nil then\r\n for I := 0 to Bucket.Size - 1 do\r\n if ValuesEqual(Bucket.Entries[I].Value, Value) then\r\n begin\r\n Result := True;\r\n Break;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfDoubleHashMap.Extract(const Key: IInterface): Double;\r\nvar\r\n Bucket: TJclIntfDoubleHashMapBucket;\r\n I, NewCapacity: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := 0.0;\r\n Bucket := FBuckets[FHashToRangeFunction(Hash(Key), FCapacity)];\r\n if Bucket <> nil then\r\n begin\r\n for I := 0 to Bucket.Size - 1 do\r\n if KeysEqual(Bucket.Entries[I].Key, Key) then\r\n begin\r\n Result := Bucket.Entries[I].Value;\r\n Bucket.Entries[I].Value := 0.0;\r\n FreeKey(Bucket.Entries[I].Key);\r\n if I < Length(Bucket.Entries) - 1 then\r\n Bucket.MoveArray(Bucket.Entries, I + 1, I, Bucket.Size - I - 1);\r\n Dec(Bucket.Size);\r\n Dec(FSize);\r\n Break;\r\n end;\r\n\r\n NewCapacity := CalcPackCapacity(Length(Bucket.Entries), Bucket.Size);\r\n if NewCapacity < Length(Bucket.Entries) then\r\n SetLength(Bucket.Entries, NewCapacity);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfDoubleHashMap.GetValue(const Key: IInterface): Double;\r\nvar\r\n I: Integer;\r\n Bucket: TJclIntfDoubleHashMapBucket;\r\n Found: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Found := False;\r\n Result := 0.0;\r\n Bucket := FBuckets[FHashToRangeFunction(Hash(Key), FCapacity)];\r\n if Bucket <> nil then\r\n for I := 0 to Bucket.Size - 1 do\r\n if KeysEqual(Bucket.Entries[I].Key, Key) then\r\n begin\r\n Result := Bucket.Entries[I].Value;\r\n Found := True;\r\n Break;\r\n end;\r\n if (not Found) and (not FReturnDefaultElements) then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfDoubleHashMap.IsEmpty: Boolean;\r\nbegin\r\n Result := FSize = 0;\r\nend;\r\n\r\nfunction TJclIntfDoubleHashMap.KeyOfValue(const Value: Double): IInterface;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclIntfDoubleHashMapBucket;\r\n Found: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Found := False;\r\n Result := nil;\r\n for J := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[J];\r\n if Bucket <> nil then\r\n for I := 0 to Bucket.Size - 1 do\r\n if ValuesEqual(Bucket.Entries[I].Value, Value) then\r\n begin\r\n Result := Bucket.Entries[I].Key;\r\n Found := True;\r\n Break;\r\n end;\r\n end;\r\n if (not Found) and (not FReturnDefaultElements) then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfDoubleHashMap.KeySet: IJclIntfSet;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclIntfDoubleHashMapBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := TJclIntfArraySet.Create(FSize);\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n for J := 0 to Bucket.Size - 1 do\r\n Result.Add(Bucket.Entries[J].Key);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfDoubleHashMap.MapEquals(const AMap: IJclIntfDoubleMap): Boolean;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclIntfDoubleHashMapBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if AMap = nil then\r\n Exit;\r\n if FSize <> AMap.Size then\r\n Exit;\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n for J := 0 to Bucket.Size - 1 do\r\n if AMap.ContainsKey(Bucket.Entries[J].Key) then\r\n begin\r\n if not ValuesEqual(AMap.GetValue(Bucket.Entries[J].Key), Bucket.Entries[J].Value) then\r\n Exit;\r\n end\r\n else\r\n Exit;\r\n end;\r\n Result := True;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclIntfDoubleHashMap.Pack;\r\nvar\r\n I: Integer;\r\n Bucket: TJclIntfDoubleHashMapBucket;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n begin\r\n if Bucket.Size > 0 then\r\n SetLength(Bucket.Entries, Bucket.Size)\r\n else\r\n FreeAndNil(FBuckets[I]);\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclIntfDoubleHashMap.PutAll(const AMap: IJclIntfDoubleMap);\r\nvar\r\n It: IJclIntfIterator;\r\n Key: IInterface;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if AMap = nil then\r\n Exit;\r\n It := AMap.KeySet.First;\r\n while It.HasNext do\r\n begin\r\n Key := It.Next;\r\n PutValue(Key, AMap.GetValue(Key));\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclIntfDoubleHashMap.PutValue(const Key: IInterface; const Value: Double);\r\nvar\r\n Index: Integer;\r\n Bucket: TJclIntfDoubleHashMapBucket;\r\n I: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FAllowDefaultElements or (not KeysEqual(Key, nil) and not ValuesEqual(Value, 0.0)) then\r\n begin\r\n Index := FHashToRangeFunction(Hash(Key), FCapacity);\r\n Bucket := FBuckets[Index];\r\n if Bucket <> nil then\r\n begin\r\n for I := 0 to Bucket.Size - 1 do\r\n if KeysEqual(Bucket.Entries[I].Key, Key) then\r\n begin\r\n FreeValue(Bucket.Entries[I].Value);\r\n Bucket.Entries[I].Value := Value;\r\n Exit;\r\n end;\r\n end\r\n else\r\n begin\r\n Bucket := TJclIntfDoubleHashMapBucket.Create;\r\n SetLength(Bucket.Entries, 1);\r\n FBuckets[Index] := Bucket;\r\n end;\r\n\r\n if Bucket.Size = Length(Bucket.Entries) then\r\n SetLength(Bucket.Entries, CalcGrowCapacity(Bucket.Size, Bucket.Size));\r\n\r\n if Bucket.Size < Length(Bucket.Entries) then\r\n begin\r\n Bucket.Entries[Bucket.Size].Key := Key;\r\n Bucket.Entries[Bucket.Size].Value := Value;\r\n Inc(Bucket.Size);\r\n Inc(FSize);\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfDoubleHashMap.Remove(const Key: IInterface): Double;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := Extract(Key);\r\n Result := FreeValue(Result);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclIntfDoubleHashMap.SetCapacity(Value: Integer);\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FSize = 0 then\r\n begin\r\n SetLength(FBuckets, Value);\r\n inherited SetCapacity(Value);\r\n end\r\n else\r\n raise EJclOperationNotSupportedError.Create;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfDoubleHashMap.Size: Integer;\r\nbegin\r\n Result := FSize;\r\nend;\r\n\r\nfunction TJclIntfDoubleHashMap.Values: IJclDoubleCollection;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclIntfDoubleHashMapBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := TJclDoubleArrayList.Create(FSize);\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n for J := 0 to Bucket.Size - 1 do\r\n Result.Add(Bucket.Entries[J].Value);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfDoubleHashMap.CreateEmptyContainer: TJclAbstractContainerBase;\r\nbegin\r\n Result := TJclIntfDoubleHashMap.Create(FCapacity);\r\n AssignPropertiesTo(Result);\r\nend;\r\n\r\nfunction TJclIntfDoubleHashMap.FreeKey(var Key: IInterface): IInterface;\r\nbegin\r\n Result := Key;\r\n Key := nil;\r\nend;\r\n\r\nfunction TJclIntfDoubleHashMap.FreeValue(var Value: Double): Double;\r\nbegin\r\n Result := Value;\r\n Value := 0.0;\r\nend;\r\n\r\nfunction TJclIntfDoubleHashMap.Hash(const AInterface: IInterface): Integer;\r\nbegin\r\n Result := IntfSimpleHashConvert(AInterface);\r\nend;\r\n\r\nfunction TJclIntfDoubleHashMap.KeysEqual(const A, B: IInterface): Boolean;\r\nbegin\r\n Result := IntfSimpleEqualityCompare(A, B);\r\nend;\r\n\r\nfunction TJclIntfDoubleHashMap.ValuesEqual(const A, B: Double): Boolean;\r\nbegin\r\n Result := ItemsEqual(A, B);\r\nend;\r\n\r\n//=== { TJclDoubleDoubleHashMapBucket } ==========================================\r\n\r\nprocedure TJclDoubleDoubleHashMapBucket.InitializeArrayAfterMove(var List: TJclDoubleDoubleHashMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\nbegin\r\n { Clean array }\r\n if FromIndex < ToIndex then\r\n begin\r\n if (ToIndex - FromIndex) < Count then\r\n Count := ToIndex - FromIndex;\r\n FillChar(List[FromIndex], Count * SizeOf(List[0]), 0);\r\n end\r\n else\r\n if FromIndex > ToIndex then\r\n begin\r\n if (FromIndex - ToIndex) < Count then\r\n FillChar(List[ToIndex + Count], (FromIndex - ToIndex) * SizeOf(List[0]), 0)\r\n else\r\n FillChar(List[FromIndex], Count * SizeOf(List[0]), 0);\r\n end;\r\nend;\r\n\r\nprocedure TJclDoubleDoubleHashMapBucket.MoveArray(var List: TJclDoubleDoubleHashMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\nbegin\r\n if Count > 0 then\r\n begin\r\n Move(List[FromIndex], List[ToIndex], Count * SizeOf(List[0]));\r\n InitializeArrayAfterMove(List, FromIndex, ToIndex, Count);\r\n end;\r\nend;\r\n\r\n//=== { TJclDoubleDoubleHashMap } ==========================================\r\n\r\nconstructor TJclDoubleDoubleHashMap.Create(ACapacity: Integer);\r\nbegin\r\n inherited Create;\r\n SetCapacity(ACapacity);\r\n FHashToRangeFunction := JclSimpleHashToRange;\r\nend;\r\n\r\ndestructor TJclDoubleDoubleHashMap.Destroy;\r\nbegin\r\n FReadOnly := False;\r\n Clear;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJclDoubleDoubleHashMap.AssignDataTo(Dest: TJclAbstractContainerBase);\r\nvar\r\n I, J: Integer;\r\n SelfBucket, NewBucket: TJclDoubleDoubleHashMapBucket;\r\n ADest: TJclDoubleDoubleHashMap;\r\n AMap: IJclDoubleDoubleMap;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n inherited AssignDataTo(Dest);\r\n if Dest is TJclDoubleDoubleHashMap then\r\n begin\r\n ADest := TJclDoubleDoubleHashMap(Dest);\r\n ADest.Clear;\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n SelfBucket := FBuckets[I];\r\n if SelfBucket <> nil then\r\n begin\r\n NewBucket := TJclDoubleDoubleHashMapBucket.Create;\r\n SetLength(NewBucket.Entries, SelfBucket.Size);\r\n for J := 0 to SelfBucket.Size - 1 do\r\n begin\r\n NewBucket.Entries[J].Key := SelfBucket.Entries[J].Key;\r\n NewBucket.Entries[J].Value := SelfBucket.Entries[J].Value;\r\n end;\r\n NewBucket.Size := SelfBucket.Size;\r\n ADest.FBuckets[I] := NewBucket;\r\n end;\r\n end;\r\n end\r\n else\r\n if Supports(IInterface(Dest), IJclDoubleDoubleMap, AMap) then\r\n begin\r\n AMap.Clear;\r\n AMap.PutAll(Self);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclDoubleDoubleHashMap.AssignPropertiesTo(Dest: TJclAbstractContainerBase);\r\nbegin\r\n inherited AssignPropertiesto(Dest);\r\n if Dest is TJclDoubleDoubleHashMap then\r\n TJclDoubleDoubleHashMap(Dest).FHashToRangeFunction := FHashToRangeFunction;\r\nend;\r\n\r\nprocedure TJclDoubleDoubleHashMap.Clear;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclDoubleDoubleHashMapBucket;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n begin\r\n for J := 0 to Bucket.Size - 1 do\r\n begin\r\n FreeKey(Bucket.Entries[J].Key);\r\n FreeValue(Bucket.Entries[J].Value);\r\n end;\r\n FreeAndNil(FBuckets[I]);\r\n end;\r\n end;\r\n FSize := 0;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclDoubleDoubleHashMap.ContainsKey(const Key: Double): Boolean;\r\nvar\r\n I: Integer;\r\n Bucket: TJclDoubleDoubleHashMapBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n Bucket := FBuckets[FHashToRangeFunction(Hash(Key), FCapacity)];\r\n if Bucket <> nil then\r\n for I := 0 to Bucket.Size - 1 do\r\n if KeysEqual(Bucket.Entries[I].Key, Key) then\r\n begin\r\n Result := True;\r\n Break;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclDoubleDoubleHashMap.ContainsValue(const Value: Double): Boolean;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclDoubleDoubleHashMapBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n for J := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[J];\r\n if Bucket <> nil then\r\n for I := 0 to Bucket.Size - 1 do\r\n if ValuesEqual(Bucket.Entries[I].Value, Value) then\r\n begin\r\n Result := True;\r\n Break;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclDoubleDoubleHashMap.Extract(const Key: Double): Double;\r\nvar\r\n Bucket: TJclDoubleDoubleHashMapBucket;\r\n I, NewCapacity: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := 0.0;\r\n Bucket := FBuckets[FHashToRangeFunction(Hash(Key), FCapacity)];\r\n if Bucket <> nil then\r\n begin\r\n for I := 0 to Bucket.Size - 1 do\r\n if KeysEqual(Bucket.Entries[I].Key, Key) then\r\n begin\r\n Result := Bucket.Entries[I].Value;\r\n Bucket.Entries[I].Value := 0.0;\r\n FreeKey(Bucket.Entries[I].Key);\r\n if I < Length(Bucket.Entries) - 1 then\r\n Bucket.MoveArray(Bucket.Entries, I + 1, I, Bucket.Size - I - 1);\r\n Dec(Bucket.Size);\r\n Dec(FSize);\r\n Break;\r\n end;\r\n\r\n NewCapacity := CalcPackCapacity(Length(Bucket.Entries), Bucket.Size);\r\n if NewCapacity < Length(Bucket.Entries) then\r\n SetLength(Bucket.Entries, NewCapacity);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclDoubleDoubleHashMap.GetValue(const Key: Double): Double;\r\nvar\r\n I: Integer;\r\n Bucket: TJclDoubleDoubleHashMapBucket;\r\n Found: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Found := False;\r\n Result := 0.0;\r\n Bucket := FBuckets[FHashToRangeFunction(Hash(Key), FCapacity)];\r\n if Bucket <> nil then\r\n for I := 0 to Bucket.Size - 1 do\r\n if KeysEqual(Bucket.Entries[I].Key, Key) then\r\n begin\r\n Result := Bucket.Entries[I].Value;\r\n Found := True;\r\n Break;\r\n end;\r\n if (not Found) and (not FReturnDefaultElements) then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclDoubleDoubleHashMap.IsEmpty: Boolean;\r\nbegin\r\n Result := FSize = 0;\r\nend;\r\n\r\nfunction TJclDoubleDoubleHashMap.KeyOfValue(const Value: Double): Double;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclDoubleDoubleHashMapBucket;\r\n Found: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Found := False;\r\n Result := 0.0;\r\n for J := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[J];\r\n if Bucket <> nil then\r\n for I := 0 to Bucket.Size - 1 do\r\n if ValuesEqual(Bucket.Entries[I].Value, Value) then\r\n begin\r\n Result := Bucket.Entries[I].Key;\r\n Found := True;\r\n Break;\r\n end;\r\n end;\r\n if (not Found) and (not FReturnDefaultElements) then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclDoubleDoubleHashMap.KeySet: IJclDoubleSet;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclDoubleDoubleHashMapBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := TJclDoubleArraySet.Create(FSize);\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n for J := 0 to Bucket.Size - 1 do\r\n Result.Add(Bucket.Entries[J].Key);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclDoubleDoubleHashMap.MapEquals(const AMap: IJclDoubleDoubleMap): Boolean;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclDoubleDoubleHashMapBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if AMap = nil then\r\n Exit;\r\n if FSize <> AMap.Size then\r\n Exit;\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n for J := 0 to Bucket.Size - 1 do\r\n if AMap.ContainsKey(Bucket.Entries[J].Key) then\r\n begin\r\n if not ValuesEqual(AMap.GetValue(Bucket.Entries[J].Key), Bucket.Entries[J].Value) then\r\n Exit;\r\n end\r\n else\r\n Exit;\r\n end;\r\n Result := True;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclDoubleDoubleHashMap.Pack;\r\nvar\r\n I: Integer;\r\n Bucket: TJclDoubleDoubleHashMapBucket;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n begin\r\n if Bucket.Size > 0 then\r\n SetLength(Bucket.Entries, Bucket.Size)\r\n else\r\n FreeAndNil(FBuckets[I]);\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclDoubleDoubleHashMap.PutAll(const AMap: IJclDoubleDoubleMap);\r\nvar\r\n It: IJclDoubleIterator;\r\n Key: Double;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if AMap = nil then\r\n Exit;\r\n It := AMap.KeySet.First;\r\n while It.HasNext do\r\n begin\r\n Key := It.Next;\r\n PutValue(Key, AMap.GetValue(Key));\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclDoubleDoubleHashMap.PutValue(const Key: Double; const Value: Double);\r\nvar\r\n Index: Integer;\r\n Bucket: TJclDoubleDoubleHashMapBucket;\r\n I: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FAllowDefaultElements or (not KeysEqual(Key, 0.0) and not ValuesEqual(Value, 0.0)) then\r\n begin\r\n Index := FHashToRangeFunction(Hash(Key), FCapacity);\r\n Bucket := FBuckets[Index];\r\n if Bucket <> nil then\r\n begin\r\n for I := 0 to Bucket.Size - 1 do\r\n if KeysEqual(Bucket.Entries[I].Key, Key) then\r\n begin\r\n FreeValue(Bucket.Entries[I].Value);\r\n Bucket.Entries[I].Value := Value;\r\n Exit;\r\n end;\r\n end\r\n else\r\n begin\r\n Bucket := TJclDoubleDoubleHashMapBucket.Create;\r\n SetLength(Bucket.Entries, 1);\r\n FBuckets[Index] := Bucket;\r\n end;\r\n\r\n if Bucket.Size = Length(Bucket.Entries) then\r\n SetLength(Bucket.Entries, CalcGrowCapacity(Bucket.Size, Bucket.Size));\r\n\r\n if Bucket.Size < Length(Bucket.Entries) then\r\n begin\r\n Bucket.Entries[Bucket.Size].Key := Key;\r\n Bucket.Entries[Bucket.Size].Value := Value;\r\n Inc(Bucket.Size);\r\n Inc(FSize);\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclDoubleDoubleHashMap.Remove(const Key: Double): Double;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := Extract(Key);\r\n Result := FreeValue(Result);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclDoubleDoubleHashMap.SetCapacity(Value: Integer);\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FSize = 0 then\r\n begin\r\n SetLength(FBuckets, Value);\r\n inherited SetCapacity(Value);\r\n end\r\n else\r\n raise EJclOperationNotSupportedError.Create;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclDoubleDoubleHashMap.Size: Integer;\r\nbegin\r\n Result := FSize;\r\nend;\r\n\r\nfunction TJclDoubleDoubleHashMap.Values: IJclDoubleCollection;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclDoubleDoubleHashMapBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := TJclDoubleArrayList.Create(FSize);\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n for J := 0 to Bucket.Size - 1 do\r\n Result.Add(Bucket.Entries[J].Value);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclDoubleDoubleHashMap.CreateEmptyContainer: TJclAbstractContainerBase;\r\nbegin\r\n Result := TJclDoubleDoubleHashMap.Create(FCapacity);\r\n AssignPropertiesTo(Result);\r\nend;\r\n\r\nfunction TJclDoubleDoubleHashMap.FreeKey(var Key: Double): Double;\r\nbegin\r\n Result := Key;\r\n Key := 0.0;\r\nend;\r\n\r\nfunction TJclDoubleDoubleHashMap.FreeValue(var Value: Double): Double;\r\nbegin\r\n Result := Value;\r\n Value := 0.0;\r\nend;\r\n\r\nfunction TJclDoubleDoubleHashMap.KeysEqual(const A, B: Double): Boolean;\r\nbegin\r\n Result := ItemsEqual(A, B);\r\nend;\r\n\r\nfunction TJclDoubleDoubleHashMap.ValuesEqual(const A, B: Double): Boolean;\r\nbegin\r\n Result := ItemsEqual(A, B);\r\nend;\r\n\r\n//=== { TJclExtendedIntfHashMapBucket } ==========================================\r\n\r\nprocedure TJclExtendedIntfHashMapBucket.FinalizeArrayBeforeMove(var List: TJclExtendedIntfHashMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\nbegin\r\n Assert(Count > 0);\r\n if FromIndex < ToIndex then\r\n begin\r\n if Count > (ToIndex - FromIndex) then\r\n Finalize(List[FromIndex + Count], ToIndex - FromIndex)\r\n else\r\n Finalize(List[ToIndex], Count);\r\n end\r\n else\r\n if FromIndex > ToIndex then\r\n begin\r\n if Count > (FromIndex - ToIndex) then\r\n Count := FromIndex - ToIndex;\r\n Finalize(List[ToIndex], Count)\r\n end;\r\nend;\r\n\r\nprocedure TJclExtendedIntfHashMapBucket.InitializeArray(var List: TJclExtendedIntfHashMapEntryArray; FromIndex, Count: SizeInt);\r\nbegin\r\n {$IFDEF FPC}\r\n while Count > 0 do\r\n begin\r\n Initialize(List[FromIndex]);\r\n Inc(FromIndex);\r\n Dec(Count);\r\n end;\r\n {$ELSE ~FPC}\r\n Initialize(List[FromIndex], Count);\r\n {$ENDIF ~FPC}\r\nend;\r\n\r\nprocedure TJclExtendedIntfHashMapBucket.InitializeArrayAfterMove(var List: TJclExtendedIntfHashMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\nbegin\r\n { Keep reference counting working }\r\n if FromIndex < ToIndex then\r\n begin\r\n if (ToIndex - FromIndex) < Count then\r\n Count := ToIndex - FromIndex;\r\n InitializeArray(List, FromIndex, Count);\r\n end\r\n else\r\n if FromIndex > ToIndex then\r\n begin\r\n if (FromIndex - ToIndex) < Count then\r\n InitializeArray(List, ToIndex + Count, FromIndex - ToIndex)\r\n else\r\n InitializeArray(List, FromIndex, Count);\r\n end;\r\nend;\r\n\r\nprocedure TJclExtendedIntfHashMapBucket.MoveArray(var List: TJclExtendedIntfHashMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\nbegin\r\n if Count > 0 then\r\n begin\r\n FinalizeArrayBeforeMove(List, FromIndex, ToIndex, Count);\r\n Move(List[FromIndex], List[ToIndex], Count * SizeOf(List[0]));\r\n InitializeArrayAfterMove(List, FromIndex, ToIndex, Count);\r\n end;\r\nend;\r\n\r\n//=== { TJclExtendedIntfHashMap } ==========================================\r\n\r\nconstructor TJclExtendedIntfHashMap.Create(ACapacity: Integer);\r\nbegin\r\n inherited Create;\r\n SetCapacity(ACapacity);\r\n FHashToRangeFunction := JclSimpleHashToRange;\r\nend;\r\n\r\ndestructor TJclExtendedIntfHashMap.Destroy;\r\nbegin\r\n FReadOnly := False;\r\n Clear;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJclExtendedIntfHashMap.AssignDataTo(Dest: TJclAbstractContainerBase);\r\nvar\r\n I, J: Integer;\r\n SelfBucket, NewBucket: TJclExtendedIntfHashMapBucket;\r\n ADest: TJclExtendedIntfHashMap;\r\n AMap: IJclExtendedIntfMap;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n inherited AssignDataTo(Dest);\r\n if Dest is TJclExtendedIntfHashMap then\r\n begin\r\n ADest := TJclExtendedIntfHashMap(Dest);\r\n ADest.Clear;\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n SelfBucket := FBuckets[I];\r\n if SelfBucket <> nil then\r\n begin\r\n NewBucket := TJclExtendedIntfHashMapBucket.Create;\r\n SetLength(NewBucket.Entries, SelfBucket.Size);\r\n for J := 0 to SelfBucket.Size - 1 do\r\n begin\r\n NewBucket.Entries[J].Key := SelfBucket.Entries[J].Key;\r\n NewBucket.Entries[J].Value := SelfBucket.Entries[J].Value;\r\n end;\r\n NewBucket.Size := SelfBucket.Size;\r\n ADest.FBuckets[I] := NewBucket;\r\n end;\r\n end;\r\n end\r\n else\r\n if Supports(IInterface(Dest), IJclExtendedIntfMap, AMap) then\r\n begin\r\n AMap.Clear;\r\n AMap.PutAll(Self);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclExtendedIntfHashMap.AssignPropertiesTo(Dest: TJclAbstractContainerBase);\r\nbegin\r\n inherited AssignPropertiesto(Dest);\r\n if Dest is TJclExtendedIntfHashMap then\r\n TJclExtendedIntfHashMap(Dest).FHashToRangeFunction := FHashToRangeFunction;\r\nend;\r\n\r\nprocedure TJclExtendedIntfHashMap.Clear;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclExtendedIntfHashMapBucket;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n begin\r\n for J := 0 to Bucket.Size - 1 do\r\n begin\r\n FreeKey(Bucket.Entries[J].Key);\r\n FreeValue(Bucket.Entries[J].Value);\r\n end;\r\n FreeAndNil(FBuckets[I]);\r\n end;\r\n end;\r\n FSize := 0;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclExtendedIntfHashMap.ContainsKey(const Key: Extended): Boolean;\r\nvar\r\n I: Integer;\r\n Bucket: TJclExtendedIntfHashMapBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n Bucket := FBuckets[FHashToRangeFunction(Hash(Key), FCapacity)];\r\n if Bucket <> nil then\r\n for I := 0 to Bucket.Size - 1 do\r\n if KeysEqual(Bucket.Entries[I].Key, Key) then\r\n begin\r\n Result := True;\r\n Break;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclExtendedIntfHashMap.ContainsValue(const Value: IInterface): Boolean;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclExtendedIntfHashMapBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n for J := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[J];\r\n if Bucket <> nil then\r\n for I := 0 to Bucket.Size - 1 do\r\n if ValuesEqual(Bucket.Entries[I].Value, Value) then\r\n begin\r\n Result := True;\r\n Break;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclExtendedIntfHashMap.Extract(const Key: Extended): IInterface;\r\nvar\r\n Bucket: TJclExtendedIntfHashMapBucket;\r\n I, NewCapacity: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := nil;\r\n Bucket := FBuckets[FHashToRangeFunction(Hash(Key), FCapacity)];\r\n if Bucket <> nil then\r\n begin\r\n for I := 0 to Bucket.Size - 1 do\r\n if KeysEqual(Bucket.Entries[I].Key, Key) then\r\n begin\r\n Result := Bucket.Entries[I].Value;\r\n Bucket.Entries[I].Value := nil;\r\n FreeKey(Bucket.Entries[I].Key);\r\n if I < Length(Bucket.Entries) - 1 then\r\n Bucket.MoveArray(Bucket.Entries, I + 1, I, Bucket.Size - I - 1);\r\n Dec(Bucket.Size);\r\n Dec(FSize);\r\n Break;\r\n end;\r\n\r\n NewCapacity := CalcPackCapacity(Length(Bucket.Entries), Bucket.Size);\r\n if NewCapacity < Length(Bucket.Entries) then\r\n SetLength(Bucket.Entries, NewCapacity);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclExtendedIntfHashMap.GetValue(const Key: Extended): IInterface;\r\nvar\r\n I: Integer;\r\n Bucket: TJclExtendedIntfHashMapBucket;\r\n Found: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Found := False;\r\n Result := nil;\r\n Bucket := FBuckets[FHashToRangeFunction(Hash(Key), FCapacity)];\r\n if Bucket <> nil then\r\n for I := 0 to Bucket.Size - 1 do\r\n if KeysEqual(Bucket.Entries[I].Key, Key) then\r\n begin\r\n Result := Bucket.Entries[I].Value;\r\n Found := True;\r\n Break;\r\n end;\r\n if (not Found) and (not FReturnDefaultElements) then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclExtendedIntfHashMap.IsEmpty: Boolean;\r\nbegin\r\n Result := FSize = 0;\r\nend;\r\n\r\nfunction TJclExtendedIntfHashMap.KeyOfValue(const Value: IInterface): Extended;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclExtendedIntfHashMapBucket;\r\n Found: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Found := False;\r\n Result := 0.0;\r\n for J := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[J];\r\n if Bucket <> nil then\r\n for I := 0 to Bucket.Size - 1 do\r\n if ValuesEqual(Bucket.Entries[I].Value, Value) then\r\n begin\r\n Result := Bucket.Entries[I].Key;\r\n Found := True;\r\n Break;\r\n end;\r\n end;\r\n if (not Found) and (not FReturnDefaultElements) then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclExtendedIntfHashMap.KeySet: IJclExtendedSet;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclExtendedIntfHashMapBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := TJclExtendedArraySet.Create(FSize);\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n for J := 0 to Bucket.Size - 1 do\r\n Result.Add(Bucket.Entries[J].Key);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclExtendedIntfHashMap.MapEquals(const AMap: IJclExtendedIntfMap): Boolean;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclExtendedIntfHashMapBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if AMap = nil then\r\n Exit;\r\n if FSize <> AMap.Size then\r\n Exit;\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n for J := 0 to Bucket.Size - 1 do\r\n if AMap.ContainsKey(Bucket.Entries[J].Key) then\r\n begin\r\n if not ValuesEqual(AMap.GetValue(Bucket.Entries[J].Key), Bucket.Entries[J].Value) then\r\n Exit;\r\n end\r\n else\r\n Exit;\r\n end;\r\n Result := True;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclExtendedIntfHashMap.Pack;\r\nvar\r\n I: Integer;\r\n Bucket: TJclExtendedIntfHashMapBucket;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n begin\r\n if Bucket.Size > 0 then\r\n SetLength(Bucket.Entries, Bucket.Size)\r\n else\r\n FreeAndNil(FBuckets[I]);\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclExtendedIntfHashMap.PutAll(const AMap: IJclExtendedIntfMap);\r\nvar\r\n It: IJclExtendedIterator;\r\n Key: Extended;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if AMap = nil then\r\n Exit;\r\n It := AMap.KeySet.First;\r\n while It.HasNext do\r\n begin\r\n Key := It.Next;\r\n PutValue(Key, AMap.GetValue(Key));\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclExtendedIntfHashMap.PutValue(const Key: Extended; const Value: IInterface);\r\nvar\r\n Index: Integer;\r\n Bucket: TJclExtendedIntfHashMapBucket;\r\n I: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FAllowDefaultElements or (not KeysEqual(Key, 0.0) and not ValuesEqual(Value, nil)) then\r\n begin\r\n Index := FHashToRangeFunction(Hash(Key), FCapacity);\r\n Bucket := FBuckets[Index];\r\n if Bucket <> nil then\r\n begin\r\n for I := 0 to Bucket.Size - 1 do\r\n if KeysEqual(Bucket.Entries[I].Key, Key) then\r\n begin\r\n FreeValue(Bucket.Entries[I].Value);\r\n Bucket.Entries[I].Value := Value;\r\n Exit;\r\n end;\r\n end\r\n else\r\n begin\r\n Bucket := TJclExtendedIntfHashMapBucket.Create;\r\n SetLength(Bucket.Entries, 1);\r\n FBuckets[Index] := Bucket;\r\n end;\r\n\r\n if Bucket.Size = Length(Bucket.Entries) then\r\n SetLength(Bucket.Entries, CalcGrowCapacity(Bucket.Size, Bucket.Size));\r\n\r\n if Bucket.Size < Length(Bucket.Entries) then\r\n begin\r\n Bucket.Entries[Bucket.Size].Key := Key;\r\n Bucket.Entries[Bucket.Size].Value := Value;\r\n Inc(Bucket.Size);\r\n Inc(FSize);\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclExtendedIntfHashMap.Remove(const Key: Extended): IInterface;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := Extract(Key);\r\n Result := FreeValue(Result);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclExtendedIntfHashMap.SetCapacity(Value: Integer);\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FSize = 0 then\r\n begin\r\n SetLength(FBuckets, Value);\r\n inherited SetCapacity(Value);\r\n end\r\n else\r\n raise EJclOperationNotSupportedError.Create;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclExtendedIntfHashMap.Size: Integer;\r\nbegin\r\n Result := FSize;\r\nend;\r\n\r\nfunction TJclExtendedIntfHashMap.Values: IJclIntfCollection;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclExtendedIntfHashMapBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := TJclIntfArrayList.Create(FSize);\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n for J := 0 to Bucket.Size - 1 do\r\n Result.Add(Bucket.Entries[J].Value);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclExtendedIntfHashMap.CreateEmptyContainer: TJclAbstractContainerBase;\r\nbegin\r\n Result := TJclExtendedIntfHashMap.Create(FCapacity);\r\n AssignPropertiesTo(Result);\r\nend;\r\n\r\nfunction TJclExtendedIntfHashMap.FreeKey(var Key: Extended): Extended;\r\nbegin\r\n Result := Key;\r\n Key := 0.0;\r\nend;\r\n\r\nfunction TJclExtendedIntfHashMap.FreeValue(var Value: IInterface): IInterface;\r\nbegin\r\n Result := Value;\r\n Value := nil;\r\nend;\r\n\r\nfunction TJclExtendedIntfHashMap.KeysEqual(const A, B: Extended): Boolean;\r\nbegin\r\n Result := ItemsEqual(A, B);\r\nend;\r\n\r\nfunction TJclExtendedIntfHashMap.ValuesEqual(const A, B: IInterface): Boolean;\r\nbegin\r\n Result := IntfSimpleEqualityCompare(A, B);\r\nend;\r\n\r\n//=== { TJclIntfExtendedHashMapBucket } ==========================================\r\n\r\nprocedure TJclIntfExtendedHashMapBucket.FinalizeArrayBeforeMove(var List: TJclIntfExtendedHashMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\nbegin\r\n Assert(Count > 0);\r\n if FromIndex < ToIndex then\r\n begin\r\n if Count > (ToIndex - FromIndex) then\r\n Finalize(List[FromIndex + Count], ToIndex - FromIndex)\r\n else\r\n Finalize(List[ToIndex], Count);\r\n end\r\n else\r\n if FromIndex > ToIndex then\r\n begin\r\n if Count > (FromIndex - ToIndex) then\r\n Count := FromIndex - ToIndex;\r\n Finalize(List[ToIndex], Count)\r\n end;\r\nend;\r\n\r\nprocedure TJclIntfExtendedHashMapBucket.InitializeArray(var List: TJclIntfExtendedHashMapEntryArray; FromIndex, Count: SizeInt);\r\nbegin\r\n {$IFDEF FPC}\r\n while Count > 0 do\r\n begin\r\n Initialize(List[FromIndex]);\r\n Inc(FromIndex);\r\n Dec(Count);\r\n end;\r\n {$ELSE ~FPC}\r\n Initialize(List[FromIndex], Count);\r\n {$ENDIF ~FPC}\r\nend;\r\n\r\nprocedure TJclIntfExtendedHashMapBucket.InitializeArrayAfterMove(var List: TJclIntfExtendedHashMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\nbegin\r\n { Keep reference counting working }\r\n if FromIndex < ToIndex then\r\n begin\r\n if (ToIndex - FromIndex) < Count then\r\n Count := ToIndex - FromIndex;\r\n InitializeArray(List, FromIndex, Count);\r\n end\r\n else\r\n if FromIndex > ToIndex then\r\n begin\r\n if (FromIndex - ToIndex) < Count then\r\n InitializeArray(List, ToIndex + Count, FromIndex - ToIndex)\r\n else\r\n InitializeArray(List, FromIndex, Count);\r\n end;\r\nend;\r\n\r\nprocedure TJclIntfExtendedHashMapBucket.MoveArray(var List: TJclIntfExtendedHashMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\nbegin\r\n if Count > 0 then\r\n begin\r\n FinalizeArrayBeforeMove(List, FromIndex, ToIndex, Count);\r\n Move(List[FromIndex], List[ToIndex], Count * SizeOf(List[0]));\r\n InitializeArrayAfterMove(List, FromIndex, ToIndex, Count);\r\n end;\r\nend;\r\n\r\n//=== { TJclIntfExtendedHashMap } ==========================================\r\n\r\nconstructor TJclIntfExtendedHashMap.Create(ACapacity: Integer);\r\nbegin\r\n inherited Create;\r\n SetCapacity(ACapacity);\r\n FHashToRangeFunction := JclSimpleHashToRange;\r\nend;\r\n\r\ndestructor TJclIntfExtendedHashMap.Destroy;\r\nbegin\r\n FReadOnly := False;\r\n Clear;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJclIntfExtendedHashMap.AssignDataTo(Dest: TJclAbstractContainerBase);\r\nvar\r\n I, J: Integer;\r\n SelfBucket, NewBucket: TJclIntfExtendedHashMapBucket;\r\n ADest: TJclIntfExtendedHashMap;\r\n AMap: IJclIntfExtendedMap;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n inherited AssignDataTo(Dest);\r\n if Dest is TJclIntfExtendedHashMap then\r\n begin\r\n ADest := TJclIntfExtendedHashMap(Dest);\r\n ADest.Clear;\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n SelfBucket := FBuckets[I];\r\n if SelfBucket <> nil then\r\n begin\r\n NewBucket := TJclIntfExtendedHashMapBucket.Create;\r\n SetLength(NewBucket.Entries, SelfBucket.Size);\r\n for J := 0 to SelfBucket.Size - 1 do\r\n begin\r\n NewBucket.Entries[J].Key := SelfBucket.Entries[J].Key;\r\n NewBucket.Entries[J].Value := SelfBucket.Entries[J].Value;\r\n end;\r\n NewBucket.Size := SelfBucket.Size;\r\n ADest.FBuckets[I] := NewBucket;\r\n end;\r\n end;\r\n end\r\n else\r\n if Supports(IInterface(Dest), IJclIntfExtendedMap, AMap) then\r\n begin\r\n AMap.Clear;\r\n AMap.PutAll(Self);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclIntfExtendedHashMap.AssignPropertiesTo(Dest: TJclAbstractContainerBase);\r\nbegin\r\n inherited AssignPropertiesto(Dest);\r\n if Dest is TJclIntfExtendedHashMap then\r\n TJclIntfExtendedHashMap(Dest).FHashToRangeFunction := FHashToRangeFunction;\r\nend;\r\n\r\nprocedure TJclIntfExtendedHashMap.Clear;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclIntfExtendedHashMapBucket;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n begin\r\n for J := 0 to Bucket.Size - 1 do\r\n begin\r\n FreeKey(Bucket.Entries[J].Key);\r\n FreeValue(Bucket.Entries[J].Value);\r\n end;\r\n FreeAndNil(FBuckets[I]);\r\n end;\r\n end;\r\n FSize := 0;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfExtendedHashMap.ContainsKey(const Key: IInterface): Boolean;\r\nvar\r\n I: Integer;\r\n Bucket: TJclIntfExtendedHashMapBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n Bucket := FBuckets[FHashToRangeFunction(Hash(Key), FCapacity)];\r\n if Bucket <> nil then\r\n for I := 0 to Bucket.Size - 1 do\r\n if KeysEqual(Bucket.Entries[I].Key, Key) then\r\n begin\r\n Result := True;\r\n Break;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfExtendedHashMap.ContainsValue(const Value: Extended): Boolean;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclIntfExtendedHashMapBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n for J := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[J];\r\n if Bucket <> nil then\r\n for I := 0 to Bucket.Size - 1 do\r\n if ValuesEqual(Bucket.Entries[I].Value, Value) then\r\n begin\r\n Result := True;\r\n Break;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfExtendedHashMap.Extract(const Key: IInterface): Extended;\r\nvar\r\n Bucket: TJclIntfExtendedHashMapBucket;\r\n I, NewCapacity: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := 0.0;\r\n Bucket := FBuckets[FHashToRangeFunction(Hash(Key), FCapacity)];\r\n if Bucket <> nil then\r\n begin\r\n for I := 0 to Bucket.Size - 1 do\r\n if KeysEqual(Bucket.Entries[I].Key, Key) then\r\n begin\r\n Result := Bucket.Entries[I].Value;\r\n Bucket.Entries[I].Value := 0.0;\r\n FreeKey(Bucket.Entries[I].Key);\r\n if I < Length(Bucket.Entries) - 1 then\r\n Bucket.MoveArray(Bucket.Entries, I + 1, I, Bucket.Size - I - 1);\r\n Dec(Bucket.Size);\r\n Dec(FSize);\r\n Break;\r\n end;\r\n\r\n NewCapacity := CalcPackCapacity(Length(Bucket.Entries), Bucket.Size);\r\n if NewCapacity < Length(Bucket.Entries) then\r\n SetLength(Bucket.Entries, NewCapacity);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfExtendedHashMap.GetValue(const Key: IInterface): Extended;\r\nvar\r\n I: Integer;\r\n Bucket: TJclIntfExtendedHashMapBucket;\r\n Found: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Found := False;\r\n Result := 0.0;\r\n Bucket := FBuckets[FHashToRangeFunction(Hash(Key), FCapacity)];\r\n if Bucket <> nil then\r\n for I := 0 to Bucket.Size - 1 do\r\n if KeysEqual(Bucket.Entries[I].Key, Key) then\r\n begin\r\n Result := Bucket.Entries[I].Value;\r\n Found := True;\r\n Break;\r\n end;\r\n if (not Found) and (not FReturnDefaultElements) then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfExtendedHashMap.IsEmpty: Boolean;\r\nbegin\r\n Result := FSize = 0;\r\nend;\r\n\r\nfunction TJclIntfExtendedHashMap.KeyOfValue(const Value: Extended): IInterface;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclIntfExtendedHashMapBucket;\r\n Found: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Found := False;\r\n Result := nil;\r\n for J := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[J];\r\n if Bucket <> nil then\r\n for I := 0 to Bucket.Size - 1 do\r\n if ValuesEqual(Bucket.Entries[I].Value, Value) then\r\n begin\r\n Result := Bucket.Entries[I].Key;\r\n Found := True;\r\n Break;\r\n end;\r\n end;\r\n if (not Found) and (not FReturnDefaultElements) then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfExtendedHashMap.KeySet: IJclIntfSet;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclIntfExtendedHashMapBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := TJclIntfArraySet.Create(FSize);\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n for J := 0 to Bucket.Size - 1 do\r\n Result.Add(Bucket.Entries[J].Key);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfExtendedHashMap.MapEquals(const AMap: IJclIntfExtendedMap): Boolean;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclIntfExtendedHashMapBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if AMap = nil then\r\n Exit;\r\n if FSize <> AMap.Size then\r\n Exit;\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n for J := 0 to Bucket.Size - 1 do\r\n if AMap.ContainsKey(Bucket.Entries[J].Key) then\r\n begin\r\n if not ValuesEqual(AMap.GetValue(Bucket.Entries[J].Key), Bucket.Entries[J].Value) then\r\n Exit;\r\n end\r\n else\r\n Exit;\r\n end;\r\n Result := True;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclIntfExtendedHashMap.Pack;\r\nvar\r\n I: Integer;\r\n Bucket: TJclIntfExtendedHashMapBucket;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n begin\r\n if Bucket.Size > 0 then\r\n SetLength(Bucket.Entries, Bucket.Size)\r\n else\r\n FreeAndNil(FBuckets[I]);\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclIntfExtendedHashMap.PutAll(const AMap: IJclIntfExtendedMap);\r\nvar\r\n It: IJclIntfIterator;\r\n Key: IInterface;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if AMap = nil then\r\n Exit;\r\n It := AMap.KeySet.First;\r\n while It.HasNext do\r\n begin\r\n Key := It.Next;\r\n PutValue(Key, AMap.GetValue(Key));\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclIntfExtendedHashMap.PutValue(const Key: IInterface; const Value: Extended);\r\nvar\r\n Index: Integer;\r\n Bucket: TJclIntfExtendedHashMapBucket;\r\n I: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FAllowDefaultElements or (not KeysEqual(Key, nil) and not ValuesEqual(Value, 0.0)) then\r\n begin\r\n Index := FHashToRangeFunction(Hash(Key), FCapacity);\r\n Bucket := FBuckets[Index];\r\n if Bucket <> nil then\r\n begin\r\n for I := 0 to Bucket.Size - 1 do\r\n if KeysEqual(Bucket.Entries[I].Key, Key) then\r\n begin\r\n FreeValue(Bucket.Entries[I].Value);\r\n Bucket.Entries[I].Value := Value;\r\n Exit;\r\n end;\r\n end\r\n else\r\n begin\r\n Bucket := TJclIntfExtendedHashMapBucket.Create;\r\n SetLength(Bucket.Entries, 1);\r\n FBuckets[Index] := Bucket;\r\n end;\r\n\r\n if Bucket.Size = Length(Bucket.Entries) then\r\n SetLength(Bucket.Entries, CalcGrowCapacity(Bucket.Size, Bucket.Size));\r\n\r\n if Bucket.Size < Length(Bucket.Entries) then\r\n begin\r\n Bucket.Entries[Bucket.Size].Key := Key;\r\n Bucket.Entries[Bucket.Size].Value := Value;\r\n Inc(Bucket.Size);\r\n Inc(FSize);\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfExtendedHashMap.Remove(const Key: IInterface): Extended;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := Extract(Key);\r\n Result := FreeValue(Result);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclIntfExtendedHashMap.SetCapacity(Value: Integer);\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FSize = 0 then\r\n begin\r\n SetLength(FBuckets, Value);\r\n inherited SetCapacity(Value);\r\n end\r\n else\r\n raise EJclOperationNotSupportedError.Create;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfExtendedHashMap.Size: Integer;\r\nbegin\r\n Result := FSize;\r\nend;\r\n\r\nfunction TJclIntfExtendedHashMap.Values: IJclExtendedCollection;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclIntfExtendedHashMapBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := TJclExtendedArrayList.Create(FSize);\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n for J := 0 to Bucket.Size - 1 do\r\n Result.Add(Bucket.Entries[J].Value);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfExtendedHashMap.CreateEmptyContainer: TJclAbstractContainerBase;\r\nbegin\r\n Result := TJclIntfExtendedHashMap.Create(FCapacity);\r\n AssignPropertiesTo(Result);\r\nend;\r\n\r\nfunction TJclIntfExtendedHashMap.FreeKey(var Key: IInterface): IInterface;\r\nbegin\r\n Result := Key;\r\n Key := nil;\r\nend;\r\n\r\nfunction TJclIntfExtendedHashMap.FreeValue(var Value: Extended): Extended;\r\nbegin\r\n Result := Value;\r\n Value := 0.0;\r\nend;\r\n\r\nfunction TJclIntfExtendedHashMap.Hash(const AInterface: IInterface): Integer;\r\nbegin\r\n Result := IntfSimpleHashConvert(AInterface);\r\nend;\r\n\r\nfunction TJclIntfExtendedHashMap.KeysEqual(const A, B: IInterface): Boolean;\r\nbegin\r\n Result := IntfSimpleEqualityCompare(A, B);\r\nend;\r\n\r\nfunction TJclIntfExtendedHashMap.ValuesEqual(const A, B: Extended): Boolean;\r\nbegin\r\n Result := ItemsEqual(A, B);\r\nend;\r\n\r\n//=== { TJclExtendedExtendedHashMapBucket } ==========================================\r\n\r\nprocedure TJclExtendedExtendedHashMapBucket.InitializeArrayAfterMove(var List: TJclExtendedExtendedHashMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\nbegin\r\n { Clean array }\r\n if FromIndex < ToIndex then\r\n begin\r\n if (ToIndex - FromIndex) < Count then\r\n Count := ToIndex - FromIndex;\r\n FillChar(List[FromIndex], Count * SizeOf(List[0]), 0);\r\n end\r\n else\r\n if FromIndex > ToIndex then\r\n begin\r\n if (FromIndex - ToIndex) < Count then\r\n FillChar(List[ToIndex + Count], (FromIndex - ToIndex) * SizeOf(List[0]), 0)\r\n else\r\n FillChar(List[FromIndex], Count * SizeOf(List[0]), 0);\r\n end;\r\nend;\r\n\r\nprocedure TJclExtendedExtendedHashMapBucket.MoveArray(var List: TJclExtendedExtendedHashMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\nbegin\r\n if Count > 0 then\r\n begin\r\n Move(List[FromIndex], List[ToIndex], Count * SizeOf(List[0]));\r\n InitializeArrayAfterMove(List, FromIndex, ToIndex, Count);\r\n end;\r\nend;\r\n\r\n//=== { TJclExtendedExtendedHashMap } ==========================================\r\n\r\nconstructor TJclExtendedExtendedHashMap.Create(ACapacity: Integer);\r\nbegin\r\n inherited Create;\r\n SetCapacity(ACapacity);\r\n FHashToRangeFunction := JclSimpleHashToRange;\r\nend;\r\n\r\ndestructor TJclExtendedExtendedHashMap.Destroy;\r\nbegin\r\n FReadOnly := False;\r\n Clear;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJclExtendedExtendedHashMap.AssignDataTo(Dest: TJclAbstractContainerBase);\r\nvar\r\n I, J: Integer;\r\n SelfBucket, NewBucket: TJclExtendedExtendedHashMapBucket;\r\n ADest: TJclExtendedExtendedHashMap;\r\n AMap: IJclExtendedExtendedMap;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n inherited AssignDataTo(Dest);\r\n if Dest is TJclExtendedExtendedHashMap then\r\n begin\r\n ADest := TJclExtendedExtendedHashMap(Dest);\r\n ADest.Clear;\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n SelfBucket := FBuckets[I];\r\n if SelfBucket <> nil then\r\n begin\r\n NewBucket := TJclExtendedExtendedHashMapBucket.Create;\r\n SetLength(NewBucket.Entries, SelfBucket.Size);\r\n for J := 0 to SelfBucket.Size - 1 do\r\n begin\r\n NewBucket.Entries[J].Key := SelfBucket.Entries[J].Key;\r\n NewBucket.Entries[J].Value := SelfBucket.Entries[J].Value;\r\n end;\r\n NewBucket.Size := SelfBucket.Size;\r\n ADest.FBuckets[I] := NewBucket;\r\n end;\r\n end;\r\n end\r\n else\r\n if Supports(IInterface(Dest), IJclExtendedExtendedMap, AMap) then\r\n begin\r\n AMap.Clear;\r\n AMap.PutAll(Self);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclExtendedExtendedHashMap.AssignPropertiesTo(Dest: TJclAbstractContainerBase);\r\nbegin\r\n inherited AssignPropertiesto(Dest);\r\n if Dest is TJclExtendedExtendedHashMap then\r\n TJclExtendedExtendedHashMap(Dest).FHashToRangeFunction := FHashToRangeFunction;\r\nend;\r\n\r\nprocedure TJclExtendedExtendedHashMap.Clear;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclExtendedExtendedHashMapBucket;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n begin\r\n for J := 0 to Bucket.Size - 1 do\r\n begin\r\n FreeKey(Bucket.Entries[J].Key);\r\n FreeValue(Bucket.Entries[J].Value);\r\n end;\r\n FreeAndNil(FBuckets[I]);\r\n end;\r\n end;\r\n FSize := 0;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclExtendedExtendedHashMap.ContainsKey(const Key: Extended): Boolean;\r\nvar\r\n I: Integer;\r\n Bucket: TJclExtendedExtendedHashMapBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n Bucket := FBuckets[FHashToRangeFunction(Hash(Key), FCapacity)];\r\n if Bucket <> nil then\r\n for I := 0 to Bucket.Size - 1 do\r\n if KeysEqual(Bucket.Entries[I].Key, Key) then\r\n begin\r\n Result := True;\r\n Break;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclExtendedExtendedHashMap.ContainsValue(const Value: Extended): Boolean;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclExtendedExtendedHashMapBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n for J := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[J];\r\n if Bucket <> nil then\r\n for I := 0 to Bucket.Size - 1 do\r\n if ValuesEqual(Bucket.Entries[I].Value, Value) then\r\n begin\r\n Result := True;\r\n Break;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclExtendedExtendedHashMap.Extract(const Key: Extended): Extended;\r\nvar\r\n Bucket: TJclExtendedExtendedHashMapBucket;\r\n I, NewCapacity: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := 0.0;\r\n Bucket := FBuckets[FHashToRangeFunction(Hash(Key), FCapacity)];\r\n if Bucket <> nil then\r\n begin\r\n for I := 0 to Bucket.Size - 1 do\r\n if KeysEqual(Bucket.Entries[I].Key, Key) then\r\n begin\r\n Result := Bucket.Entries[I].Value;\r\n Bucket.Entries[I].Value := 0.0;\r\n FreeKey(Bucket.Entries[I].Key);\r\n if I < Length(Bucket.Entries) - 1 then\r\n Bucket.MoveArray(Bucket.Entries, I + 1, I, Bucket.Size - I - 1);\r\n Dec(Bucket.Size);\r\n Dec(FSize);\r\n Break;\r\n end;\r\n\r\n NewCapacity := CalcPackCapacity(Length(Bucket.Entries), Bucket.Size);\r\n if NewCapacity < Length(Bucket.Entries) then\r\n SetLength(Bucket.Entries, NewCapacity);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclExtendedExtendedHashMap.GetValue(const Key: Extended): Extended;\r\nvar\r\n I: Integer;\r\n Bucket: TJclExtendedExtendedHashMapBucket;\r\n Found: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Found := False;\r\n Result := 0.0;\r\n Bucket := FBuckets[FHashToRangeFunction(Hash(Key), FCapacity)];\r\n if Bucket <> nil then\r\n for I := 0 to Bucket.Size - 1 do\r\n if KeysEqual(Bucket.Entries[I].Key, Key) then\r\n begin\r\n Result := Bucket.Entries[I].Value;\r\n Found := True;\r\n Break;\r\n end;\r\n if (not Found) and (not FReturnDefaultElements) then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclExtendedExtendedHashMap.IsEmpty: Boolean;\r\nbegin\r\n Result := FSize = 0;\r\nend;\r\n\r\nfunction TJclExtendedExtendedHashMap.KeyOfValue(const Value: Extended): Extended;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclExtendedExtendedHashMapBucket;\r\n Found: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Found := False;\r\n Result := 0.0;\r\n for J := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[J];\r\n if Bucket <> nil then\r\n for I := 0 to Bucket.Size - 1 do\r\n if ValuesEqual(Bucket.Entries[I].Value, Value) then\r\n begin\r\n Result := Bucket.Entries[I].Key;\r\n Found := True;\r\n Break;\r\n end;\r\n end;\r\n if (not Found) and (not FReturnDefaultElements) then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclExtendedExtendedHashMap.KeySet: IJclExtendedSet;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclExtendedExtendedHashMapBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := TJclExtendedArraySet.Create(FSize);\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n for J := 0 to Bucket.Size - 1 do\r\n Result.Add(Bucket.Entries[J].Key);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclExtendedExtendedHashMap.MapEquals(const AMap: IJclExtendedExtendedMap): Boolean;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclExtendedExtendedHashMapBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if AMap = nil then\r\n Exit;\r\n if FSize <> AMap.Size then\r\n Exit;\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n for J := 0 to Bucket.Size - 1 do\r\n if AMap.ContainsKey(Bucket.Entries[J].Key) then\r\n begin\r\n if not ValuesEqual(AMap.GetValue(Bucket.Entries[J].Key), Bucket.Entries[J].Value) then\r\n Exit;\r\n end\r\n else\r\n Exit;\r\n end;\r\n Result := True;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclExtendedExtendedHashMap.Pack;\r\nvar\r\n I: Integer;\r\n Bucket: TJclExtendedExtendedHashMapBucket;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n begin\r\n if Bucket.Size > 0 then\r\n SetLength(Bucket.Entries, Bucket.Size)\r\n else\r\n FreeAndNil(FBuckets[I]);\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclExtendedExtendedHashMap.PutAll(const AMap: IJclExtendedExtendedMap);\r\nvar\r\n It: IJclExtendedIterator;\r\n Key: Extended;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if AMap = nil then\r\n Exit;\r\n It := AMap.KeySet.First;\r\n while It.HasNext do\r\n begin\r\n Key := It.Next;\r\n PutValue(Key, AMap.GetValue(Key));\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclExtendedExtendedHashMap.PutValue(const Key: Extended; const Value: Extended);\r\nvar\r\n Index: Integer;\r\n Bucket: TJclExtendedExtendedHashMapBucket;\r\n I: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FAllowDefaultElements or (not KeysEqual(Key, 0.0) and not ValuesEqual(Value, 0.0)) then\r\n begin\r\n Index := FHashToRangeFunction(Hash(Key), FCapacity);\r\n Bucket := FBuckets[Index];\r\n if Bucket <> nil then\r\n begin\r\n for I := 0 to Bucket.Size - 1 do\r\n if KeysEqual(Bucket.Entries[I].Key, Key) then\r\n begin\r\n FreeValue(Bucket.Entries[I].Value);\r\n Bucket.Entries[I].Value := Value;\r\n Exit;\r\n end;\r\n end\r\n else\r\n begin\r\n Bucket := TJclExtendedExtendedHashMapBucket.Create;\r\n SetLength(Bucket.Entries, 1);\r\n FBuckets[Index] := Bucket;\r\n end;\r\n\r\n if Bucket.Size = Length(Bucket.Entries) then\r\n SetLength(Bucket.Entries, CalcGrowCapacity(Bucket.Size, Bucket.Size));\r\n\r\n if Bucket.Size < Length(Bucket.Entries) then\r\n begin\r\n Bucket.Entries[Bucket.Size].Key := Key;\r\n Bucket.Entries[Bucket.Size].Value := Value;\r\n Inc(Bucket.Size);\r\n Inc(FSize);\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclExtendedExtendedHashMap.Remove(const Key: Extended): Extended;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := Extract(Key);\r\n Result := FreeValue(Result);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclExtendedExtendedHashMap.SetCapacity(Value: Integer);\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FSize = 0 then\r\n begin\r\n SetLength(FBuckets, Value);\r\n inherited SetCapacity(Value);\r\n end\r\n else\r\n raise EJclOperationNotSupportedError.Create;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclExtendedExtendedHashMap.Size: Integer;\r\nbegin\r\n Result := FSize;\r\nend;\r\n\r\nfunction TJclExtendedExtendedHashMap.Values: IJclExtendedCollection;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclExtendedExtendedHashMapBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := TJclExtendedArrayList.Create(FSize);\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n for J := 0 to Bucket.Size - 1 do\r\n Result.Add(Bucket.Entries[J].Value);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclExtendedExtendedHashMap.CreateEmptyContainer: TJclAbstractContainerBase;\r\nbegin\r\n Result := TJclExtendedExtendedHashMap.Create(FCapacity);\r\n AssignPropertiesTo(Result);\r\nend;\r\n\r\nfunction TJclExtendedExtendedHashMap.FreeKey(var Key: Extended): Extended;\r\nbegin\r\n Result := Key;\r\n Key := 0.0;\r\nend;\r\n\r\nfunction TJclExtendedExtendedHashMap.FreeValue(var Value: Extended): Extended;\r\nbegin\r\n Result := Value;\r\n Value := 0.0;\r\nend;\r\n\r\nfunction TJclExtendedExtendedHashMap.KeysEqual(const A, B: Extended): Boolean;\r\nbegin\r\n Result := ItemsEqual(A, B);\r\nend;\r\n\r\nfunction TJclExtendedExtendedHashMap.ValuesEqual(const A, B: Extended): Boolean;\r\nbegin\r\n Result := ItemsEqual(A, B);\r\nend;\r\n\r\n//=== { TJclIntegerIntfHashMapBucket } ==========================================\r\n\r\nprocedure TJclIntegerIntfHashMapBucket.FinalizeArrayBeforeMove(var List: TJclIntegerIntfHashMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\nbegin\r\n Assert(Count > 0);\r\n if FromIndex < ToIndex then\r\n begin\r\n if Count > (ToIndex - FromIndex) then\r\n Finalize(List[FromIndex + Count], ToIndex - FromIndex)\r\n else\r\n Finalize(List[ToIndex], Count);\r\n end\r\n else\r\n if FromIndex > ToIndex then\r\n begin\r\n if Count > (FromIndex - ToIndex) then\r\n Count := FromIndex - ToIndex;\r\n Finalize(List[ToIndex], Count)\r\n end;\r\nend;\r\n\r\nprocedure TJclIntegerIntfHashMapBucket.InitializeArray(var List: TJclIntegerIntfHashMapEntryArray; FromIndex, Count: SizeInt);\r\nbegin\r\n {$IFDEF FPC}\r\n while Count > 0 do\r\n begin\r\n Initialize(List[FromIndex]);\r\n Inc(FromIndex);\r\n Dec(Count);\r\n end;\r\n {$ELSE ~FPC}\r\n Initialize(List[FromIndex], Count);\r\n {$ENDIF ~FPC}\r\nend;\r\n\r\nprocedure TJclIntegerIntfHashMapBucket.InitializeArrayAfterMove(var List: TJclIntegerIntfHashMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\nbegin\r\n { Keep reference counting working }\r\n if FromIndex < ToIndex then\r\n begin\r\n if (ToIndex - FromIndex) < Count then\r\n Count := ToIndex - FromIndex;\r\n InitializeArray(List, FromIndex, Count);\r\n end\r\n else\r\n if FromIndex > ToIndex then\r\n begin\r\n if (FromIndex - ToIndex) < Count then\r\n InitializeArray(List, ToIndex + Count, FromIndex - ToIndex)\r\n else\r\n InitializeArray(List, FromIndex, Count);\r\n end;\r\nend;\r\n\r\nprocedure TJclIntegerIntfHashMapBucket.MoveArray(var List: TJclIntegerIntfHashMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\nbegin\r\n if Count > 0 then\r\n begin\r\n FinalizeArrayBeforeMove(List, FromIndex, ToIndex, Count);\r\n Move(List[FromIndex], List[ToIndex], Count * SizeOf(List[0]));\r\n InitializeArrayAfterMove(List, FromIndex, ToIndex, Count);\r\n end;\r\nend;\r\n\r\n//=== { TJclIntegerIntfHashMap } ==========================================\r\n\r\nconstructor TJclIntegerIntfHashMap.Create(ACapacity: Integer);\r\nbegin\r\n inherited Create;\r\n SetCapacity(ACapacity);\r\n FHashToRangeFunction := JclSimpleHashToRange;\r\nend;\r\n\r\ndestructor TJclIntegerIntfHashMap.Destroy;\r\nbegin\r\n FReadOnly := False;\r\n Clear;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJclIntegerIntfHashMap.AssignDataTo(Dest: TJclAbstractContainerBase);\r\nvar\r\n I, J: Integer;\r\n SelfBucket, NewBucket: TJclIntegerIntfHashMapBucket;\r\n ADest: TJclIntegerIntfHashMap;\r\n AMap: IJclIntegerIntfMap;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n inherited AssignDataTo(Dest);\r\n if Dest is TJclIntegerIntfHashMap then\r\n begin\r\n ADest := TJclIntegerIntfHashMap(Dest);\r\n ADest.Clear;\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n SelfBucket := FBuckets[I];\r\n if SelfBucket <> nil then\r\n begin\r\n NewBucket := TJclIntegerIntfHashMapBucket.Create;\r\n SetLength(NewBucket.Entries, SelfBucket.Size);\r\n for J := 0 to SelfBucket.Size - 1 do\r\n begin\r\n NewBucket.Entries[J].Key := SelfBucket.Entries[J].Key;\r\n NewBucket.Entries[J].Value := SelfBucket.Entries[J].Value;\r\n end;\r\n NewBucket.Size := SelfBucket.Size;\r\n ADest.FBuckets[I] := NewBucket;\r\n end;\r\n end;\r\n end\r\n else\r\n if Supports(IInterface(Dest), IJclIntegerIntfMap, AMap) then\r\n begin\r\n AMap.Clear;\r\n AMap.PutAll(Self);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclIntegerIntfHashMap.AssignPropertiesTo(Dest: TJclAbstractContainerBase);\r\nbegin\r\n inherited AssignPropertiesto(Dest);\r\n if Dest is TJclIntegerIntfHashMap then\r\n TJclIntegerIntfHashMap(Dest).FHashToRangeFunction := FHashToRangeFunction;\r\nend;\r\n\r\nprocedure TJclIntegerIntfHashMap.Clear;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclIntegerIntfHashMapBucket;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n begin\r\n for J := 0 to Bucket.Size - 1 do\r\n begin\r\n FreeKey(Bucket.Entries[J].Key);\r\n FreeValue(Bucket.Entries[J].Value);\r\n end;\r\n FreeAndNil(FBuckets[I]);\r\n end;\r\n end;\r\n FSize := 0;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntegerIntfHashMap.ContainsKey(Key: Integer): Boolean;\r\nvar\r\n I: Integer;\r\n Bucket: TJclIntegerIntfHashMapBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n Bucket := FBuckets[FHashToRangeFunction(Hash(Key), FCapacity)];\r\n if Bucket <> nil then\r\n for I := 0 to Bucket.Size - 1 do\r\n if KeysEqual(Bucket.Entries[I].Key, Key) then\r\n begin\r\n Result := True;\r\n Break;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntegerIntfHashMap.ContainsValue(const Value: IInterface): Boolean;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclIntegerIntfHashMapBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n for J := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[J];\r\n if Bucket <> nil then\r\n for I := 0 to Bucket.Size - 1 do\r\n if ValuesEqual(Bucket.Entries[I].Value, Value) then\r\n begin\r\n Result := True;\r\n Break;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntegerIntfHashMap.Extract(Key: Integer): IInterface;\r\nvar\r\n Bucket: TJclIntegerIntfHashMapBucket;\r\n I, NewCapacity: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := nil;\r\n Bucket := FBuckets[FHashToRangeFunction(Hash(Key), FCapacity)];\r\n if Bucket <> nil then\r\n begin\r\n for I := 0 to Bucket.Size - 1 do\r\n if KeysEqual(Bucket.Entries[I].Key, Key) then\r\n begin\r\n Result := Bucket.Entries[I].Value;\r\n Bucket.Entries[I].Value := nil;\r\n FreeKey(Bucket.Entries[I].Key);\r\n if I < Length(Bucket.Entries) - 1 then\r\n Bucket.MoveArray(Bucket.Entries, I + 1, I, Bucket.Size - I - 1);\r\n Dec(Bucket.Size);\r\n Dec(FSize);\r\n Break;\r\n end;\r\n\r\n NewCapacity := CalcPackCapacity(Length(Bucket.Entries), Bucket.Size);\r\n if NewCapacity < Length(Bucket.Entries) then\r\n SetLength(Bucket.Entries, NewCapacity);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntegerIntfHashMap.GetValue(Key: Integer): IInterface;\r\nvar\r\n I: Integer;\r\n Bucket: TJclIntegerIntfHashMapBucket;\r\n Found: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Found := False;\r\n Result := nil;\r\n Bucket := FBuckets[FHashToRangeFunction(Hash(Key), FCapacity)];\r\n if Bucket <> nil then\r\n for I := 0 to Bucket.Size - 1 do\r\n if KeysEqual(Bucket.Entries[I].Key, Key) then\r\n begin\r\n Result := Bucket.Entries[I].Value;\r\n Found := True;\r\n Break;\r\n end;\r\n if (not Found) and (not FReturnDefaultElements) then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntegerIntfHashMap.IsEmpty: Boolean;\r\nbegin\r\n Result := FSize = 0;\r\nend;\r\n\r\nfunction TJclIntegerIntfHashMap.KeyOfValue(const Value: IInterface): Integer;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclIntegerIntfHashMapBucket;\r\n Found: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Found := False;\r\n Result := 0;\r\n for J := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[J];\r\n if Bucket <> nil then\r\n for I := 0 to Bucket.Size - 1 do\r\n if ValuesEqual(Bucket.Entries[I].Value, Value) then\r\n begin\r\n Result := Bucket.Entries[I].Key;\r\n Found := True;\r\n Break;\r\n end;\r\n end;\r\n if (not Found) and (not FReturnDefaultElements) then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntegerIntfHashMap.KeySet: IJclIntegerSet;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclIntegerIntfHashMapBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := TJclIntegerArraySet.Create(FSize);\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n for J := 0 to Bucket.Size - 1 do\r\n Result.Add(Bucket.Entries[J].Key);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntegerIntfHashMap.MapEquals(const AMap: IJclIntegerIntfMap): Boolean;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclIntegerIntfHashMapBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if AMap = nil then\r\n Exit;\r\n if FSize <> AMap.Size then\r\n Exit;\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n for J := 0 to Bucket.Size - 1 do\r\n if AMap.ContainsKey(Bucket.Entries[J].Key) then\r\n begin\r\n if not ValuesEqual(AMap.GetValue(Bucket.Entries[J].Key), Bucket.Entries[J].Value) then\r\n Exit;\r\n end\r\n else\r\n Exit;\r\n end;\r\n Result := True;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclIntegerIntfHashMap.Pack;\r\nvar\r\n I: Integer;\r\n Bucket: TJclIntegerIntfHashMapBucket;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n begin\r\n if Bucket.Size > 0 then\r\n SetLength(Bucket.Entries, Bucket.Size)\r\n else\r\n FreeAndNil(FBuckets[I]);\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclIntegerIntfHashMap.PutAll(const AMap: IJclIntegerIntfMap);\r\nvar\r\n It: IJclIntegerIterator;\r\n Key: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if AMap = nil then\r\n Exit;\r\n It := AMap.KeySet.First;\r\n while It.HasNext do\r\n begin\r\n Key := It.Next;\r\n PutValue(Key, AMap.GetValue(Key));\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclIntegerIntfHashMap.PutValue(Key: Integer; const Value: IInterface);\r\nvar\r\n Index: Integer;\r\n Bucket: TJclIntegerIntfHashMapBucket;\r\n I: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FAllowDefaultElements or (not KeysEqual(Key, 0) and not ValuesEqual(Value, nil)) then\r\n begin\r\n Index := FHashToRangeFunction(Hash(Key), FCapacity);\r\n Bucket := FBuckets[Index];\r\n if Bucket <> nil then\r\n begin\r\n for I := 0 to Bucket.Size - 1 do\r\n if KeysEqual(Bucket.Entries[I].Key, Key) then\r\n begin\r\n FreeValue(Bucket.Entries[I].Value);\r\n Bucket.Entries[I].Value := Value;\r\n Exit;\r\n end;\r\n end\r\n else\r\n begin\r\n Bucket := TJclIntegerIntfHashMapBucket.Create;\r\n SetLength(Bucket.Entries, 1);\r\n FBuckets[Index] := Bucket;\r\n end;\r\n\r\n if Bucket.Size = Length(Bucket.Entries) then\r\n SetLength(Bucket.Entries, CalcGrowCapacity(Bucket.Size, Bucket.Size));\r\n\r\n if Bucket.Size < Length(Bucket.Entries) then\r\n begin\r\n Bucket.Entries[Bucket.Size].Key := Key;\r\n Bucket.Entries[Bucket.Size].Value := Value;\r\n Inc(Bucket.Size);\r\n Inc(FSize);\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntegerIntfHashMap.Remove(Key: Integer): IInterface;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := Extract(Key);\r\n Result := FreeValue(Result);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclIntegerIntfHashMap.SetCapacity(Value: Integer);\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FSize = 0 then\r\n begin\r\n SetLength(FBuckets, Value);\r\n inherited SetCapacity(Value);\r\n end\r\n else\r\n raise EJclOperationNotSupportedError.Create;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntegerIntfHashMap.Size: Integer;\r\nbegin\r\n Result := FSize;\r\nend;\r\n\r\nfunction TJclIntegerIntfHashMap.Values: IJclIntfCollection;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclIntegerIntfHashMapBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := TJclIntfArrayList.Create(FSize);\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n for J := 0 to Bucket.Size - 1 do\r\n Result.Add(Bucket.Entries[J].Value);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntegerIntfHashMap.CreateEmptyContainer: TJclAbstractContainerBase;\r\nbegin\r\n Result := TJclIntegerIntfHashMap.Create(FCapacity);\r\n AssignPropertiesTo(Result);\r\nend;\r\n\r\nfunction TJclIntegerIntfHashMap.FreeKey(var Key: Integer): Integer;\r\nbegin\r\n Result := Key;\r\n Key := 0;\r\nend;\r\n\r\nfunction TJclIntegerIntfHashMap.FreeValue(var Value: IInterface): IInterface;\r\nbegin\r\n Result := Value;\r\n Value := nil;\r\nend;\r\n\r\nfunction TJclIntegerIntfHashMap.KeysEqual(A, B: Integer): Boolean;\r\nbegin\r\n Result := ItemsEqual(A, B);\r\nend;\r\n\r\nfunction TJclIntegerIntfHashMap.ValuesEqual(const A, B: IInterface): Boolean;\r\nbegin\r\n Result := IntfSimpleEqualityCompare(A, B);\r\nend;\r\n\r\n//=== { TJclIntfIntegerHashMapBucket } ==========================================\r\n\r\nprocedure TJclIntfIntegerHashMapBucket.FinalizeArrayBeforeMove(var List: TJclIntfIntegerHashMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\nbegin\r\n Assert(Count > 0);\r\n if FromIndex < ToIndex then\r\n begin\r\n if Count > (ToIndex - FromIndex) then\r\n Finalize(List[FromIndex + Count], ToIndex - FromIndex)\r\n else\r\n Finalize(List[ToIndex], Count);\r\n end\r\n else\r\n if FromIndex > ToIndex then\r\n begin\r\n if Count > (FromIndex - ToIndex) then\r\n Count := FromIndex - ToIndex;\r\n Finalize(List[ToIndex], Count)\r\n end;\r\nend;\r\n\r\nprocedure TJclIntfIntegerHashMapBucket.InitializeArray(var List: TJclIntfIntegerHashMapEntryArray; FromIndex, Count: SizeInt);\r\nbegin\r\n {$IFDEF FPC}\r\n while Count > 0 do\r\n begin\r\n Initialize(List[FromIndex]);\r\n Inc(FromIndex);\r\n Dec(Count);\r\n end;\r\n {$ELSE ~FPC}\r\n Initialize(List[FromIndex], Count);\r\n {$ENDIF ~FPC}\r\nend;\r\n\r\nprocedure TJclIntfIntegerHashMapBucket.InitializeArrayAfterMove(var List: TJclIntfIntegerHashMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\nbegin\r\n { Keep reference counting working }\r\n if FromIndex < ToIndex then\r\n begin\r\n if (ToIndex - FromIndex) < Count then\r\n Count := ToIndex - FromIndex;\r\n InitializeArray(List, FromIndex, Count);\r\n end\r\n else\r\n if FromIndex > ToIndex then\r\n begin\r\n if (FromIndex - ToIndex) < Count then\r\n InitializeArray(List, ToIndex + Count, FromIndex - ToIndex)\r\n else\r\n InitializeArray(List, FromIndex, Count);\r\n end;\r\nend;\r\n\r\nprocedure TJclIntfIntegerHashMapBucket.MoveArray(var List: TJclIntfIntegerHashMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\nbegin\r\n if Count > 0 then\r\n begin\r\n FinalizeArrayBeforeMove(List, FromIndex, ToIndex, Count);\r\n Move(List[FromIndex], List[ToIndex], Count * SizeOf(List[0]));\r\n InitializeArrayAfterMove(List, FromIndex, ToIndex, Count);\r\n end;\r\nend;\r\n\r\n//=== { TJclIntfIntegerHashMap } ==========================================\r\n\r\nconstructor TJclIntfIntegerHashMap.Create(ACapacity: Integer);\r\nbegin\r\n inherited Create;\r\n SetCapacity(ACapacity);\r\n FHashToRangeFunction := JclSimpleHashToRange;\r\nend;\r\n\r\ndestructor TJclIntfIntegerHashMap.Destroy;\r\nbegin\r\n FReadOnly := False;\r\n Clear;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJclIntfIntegerHashMap.AssignDataTo(Dest: TJclAbstractContainerBase);\r\nvar\r\n I, J: Integer;\r\n SelfBucket, NewBucket: TJclIntfIntegerHashMapBucket;\r\n ADest: TJclIntfIntegerHashMap;\r\n AMap: IJclIntfIntegerMap;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n inherited AssignDataTo(Dest);\r\n if Dest is TJclIntfIntegerHashMap then\r\n begin\r\n ADest := TJclIntfIntegerHashMap(Dest);\r\n ADest.Clear;\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n SelfBucket := FBuckets[I];\r\n if SelfBucket <> nil then\r\n begin\r\n NewBucket := TJclIntfIntegerHashMapBucket.Create;\r\n SetLength(NewBucket.Entries, SelfBucket.Size);\r\n for J := 0 to SelfBucket.Size - 1 do\r\n begin\r\n NewBucket.Entries[J].Key := SelfBucket.Entries[J].Key;\r\n NewBucket.Entries[J].Value := SelfBucket.Entries[J].Value;\r\n end;\r\n NewBucket.Size := SelfBucket.Size;\r\n ADest.FBuckets[I] := NewBucket;\r\n end;\r\n end;\r\n end\r\n else\r\n if Supports(IInterface(Dest), IJclIntfIntegerMap, AMap) then\r\n begin\r\n AMap.Clear;\r\n AMap.PutAll(Self);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclIntfIntegerHashMap.AssignPropertiesTo(Dest: TJclAbstractContainerBase);\r\nbegin\r\n inherited AssignPropertiesto(Dest);\r\n if Dest is TJclIntfIntegerHashMap then\r\n TJclIntfIntegerHashMap(Dest).FHashToRangeFunction := FHashToRangeFunction;\r\nend;\r\n\r\nprocedure TJclIntfIntegerHashMap.Clear;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclIntfIntegerHashMapBucket;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n begin\r\n for J := 0 to Bucket.Size - 1 do\r\n begin\r\n FreeKey(Bucket.Entries[J].Key);\r\n FreeValue(Bucket.Entries[J].Value);\r\n end;\r\n FreeAndNil(FBuckets[I]);\r\n end;\r\n end;\r\n FSize := 0;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfIntegerHashMap.ContainsKey(const Key: IInterface): Boolean;\r\nvar\r\n I: Integer;\r\n Bucket: TJclIntfIntegerHashMapBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n Bucket := FBuckets[FHashToRangeFunction(Hash(Key), FCapacity)];\r\n if Bucket <> nil then\r\n for I := 0 to Bucket.Size - 1 do\r\n if KeysEqual(Bucket.Entries[I].Key, Key) then\r\n begin\r\n Result := True;\r\n Break;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfIntegerHashMap.ContainsValue(Value: Integer): Boolean;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclIntfIntegerHashMapBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n for J := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[J];\r\n if Bucket <> nil then\r\n for I := 0 to Bucket.Size - 1 do\r\n if ValuesEqual(Bucket.Entries[I].Value, Value) then\r\n begin\r\n Result := True;\r\n Break;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfIntegerHashMap.Extract(const Key: IInterface): Integer;\r\nvar\r\n Bucket: TJclIntfIntegerHashMapBucket;\r\n I, NewCapacity: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := 0;\r\n Bucket := FBuckets[FHashToRangeFunction(Hash(Key), FCapacity)];\r\n if Bucket <> nil then\r\n begin\r\n for I := 0 to Bucket.Size - 1 do\r\n if KeysEqual(Bucket.Entries[I].Key, Key) then\r\n begin\r\n Result := Bucket.Entries[I].Value;\r\n Bucket.Entries[I].Value := 0;\r\n FreeKey(Bucket.Entries[I].Key);\r\n if I < Length(Bucket.Entries) - 1 then\r\n Bucket.MoveArray(Bucket.Entries, I + 1, I, Bucket.Size - I - 1);\r\n Dec(Bucket.Size);\r\n Dec(FSize);\r\n Break;\r\n end;\r\n\r\n NewCapacity := CalcPackCapacity(Length(Bucket.Entries), Bucket.Size);\r\n if NewCapacity < Length(Bucket.Entries) then\r\n SetLength(Bucket.Entries, NewCapacity);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfIntegerHashMap.GetValue(const Key: IInterface): Integer;\r\nvar\r\n I: Integer;\r\n Bucket: TJclIntfIntegerHashMapBucket;\r\n Found: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Found := False;\r\n Result := 0;\r\n Bucket := FBuckets[FHashToRangeFunction(Hash(Key), FCapacity)];\r\n if Bucket <> nil then\r\n for I := 0 to Bucket.Size - 1 do\r\n if KeysEqual(Bucket.Entries[I].Key, Key) then\r\n begin\r\n Result := Bucket.Entries[I].Value;\r\n Found := True;\r\n Break;\r\n end;\r\n if (not Found) and (not FReturnDefaultElements) then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfIntegerHashMap.IsEmpty: Boolean;\r\nbegin\r\n Result := FSize = 0;\r\nend;\r\n\r\nfunction TJclIntfIntegerHashMap.KeyOfValue(Value: Integer): IInterface;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclIntfIntegerHashMapBucket;\r\n Found: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Found := False;\r\n Result := nil;\r\n for J := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[J];\r\n if Bucket <> nil then\r\n for I := 0 to Bucket.Size - 1 do\r\n if ValuesEqual(Bucket.Entries[I].Value, Value) then\r\n begin\r\n Result := Bucket.Entries[I].Key;\r\n Found := True;\r\n Break;\r\n end;\r\n end;\r\n if (not Found) and (not FReturnDefaultElements) then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfIntegerHashMap.KeySet: IJclIntfSet;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclIntfIntegerHashMapBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := TJclIntfArraySet.Create(FSize);\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n for J := 0 to Bucket.Size - 1 do\r\n Result.Add(Bucket.Entries[J].Key);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfIntegerHashMap.MapEquals(const AMap: IJclIntfIntegerMap): Boolean;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclIntfIntegerHashMapBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if AMap = nil then\r\n Exit;\r\n if FSize <> AMap.Size then\r\n Exit;\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n for J := 0 to Bucket.Size - 1 do\r\n if AMap.ContainsKey(Bucket.Entries[J].Key) then\r\n begin\r\n if not ValuesEqual(AMap.GetValue(Bucket.Entries[J].Key), Bucket.Entries[J].Value) then\r\n Exit;\r\n end\r\n else\r\n Exit;\r\n end;\r\n Result := True;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclIntfIntegerHashMap.Pack;\r\nvar\r\n I: Integer;\r\n Bucket: TJclIntfIntegerHashMapBucket;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n begin\r\n if Bucket.Size > 0 then\r\n SetLength(Bucket.Entries, Bucket.Size)\r\n else\r\n FreeAndNil(FBuckets[I]);\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclIntfIntegerHashMap.PutAll(const AMap: IJclIntfIntegerMap);\r\nvar\r\n It: IJclIntfIterator;\r\n Key: IInterface;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if AMap = nil then\r\n Exit;\r\n It := AMap.KeySet.First;\r\n while It.HasNext do\r\n begin\r\n Key := It.Next;\r\n PutValue(Key, AMap.GetValue(Key));\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclIntfIntegerHashMap.PutValue(const Key: IInterface; Value: Integer);\r\nvar\r\n Index: Integer;\r\n Bucket: TJclIntfIntegerHashMapBucket;\r\n I: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FAllowDefaultElements or (not KeysEqual(Key, nil) and not ValuesEqual(Value, 0)) then\r\n begin\r\n Index := FHashToRangeFunction(Hash(Key), FCapacity);\r\n Bucket := FBuckets[Index];\r\n if Bucket <> nil then\r\n begin\r\n for I := 0 to Bucket.Size - 1 do\r\n if KeysEqual(Bucket.Entries[I].Key, Key) then\r\n begin\r\n FreeValue(Bucket.Entries[I].Value);\r\n Bucket.Entries[I].Value := Value;\r\n Exit;\r\n end;\r\n end\r\n else\r\n begin\r\n Bucket := TJclIntfIntegerHashMapBucket.Create;\r\n SetLength(Bucket.Entries, 1);\r\n FBuckets[Index] := Bucket;\r\n end;\r\n\r\n if Bucket.Size = Length(Bucket.Entries) then\r\n SetLength(Bucket.Entries, CalcGrowCapacity(Bucket.Size, Bucket.Size));\r\n\r\n if Bucket.Size < Length(Bucket.Entries) then\r\n begin\r\n Bucket.Entries[Bucket.Size].Key := Key;\r\n Bucket.Entries[Bucket.Size].Value := Value;\r\n Inc(Bucket.Size);\r\n Inc(FSize);\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfIntegerHashMap.Remove(const Key: IInterface): Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := Extract(Key);\r\n Result := FreeValue(Result);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclIntfIntegerHashMap.SetCapacity(Value: Integer);\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FSize = 0 then\r\n begin\r\n SetLength(FBuckets, Value);\r\n inherited SetCapacity(Value);\r\n end\r\n else\r\n raise EJclOperationNotSupportedError.Create;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfIntegerHashMap.Size: Integer;\r\nbegin\r\n Result := FSize;\r\nend;\r\n\r\nfunction TJclIntfIntegerHashMap.Values: IJclIntegerCollection;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclIntfIntegerHashMapBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := TJclIntegerArrayList.Create(FSize);\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n for J := 0 to Bucket.Size - 1 do\r\n Result.Add(Bucket.Entries[J].Value);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfIntegerHashMap.CreateEmptyContainer: TJclAbstractContainerBase;\r\nbegin\r\n Result := TJclIntfIntegerHashMap.Create(FCapacity);\r\n AssignPropertiesTo(Result);\r\nend;\r\n\r\nfunction TJclIntfIntegerHashMap.FreeKey(var Key: IInterface): IInterface;\r\nbegin\r\n Result := Key;\r\n Key := nil;\r\nend;\r\n\r\nfunction TJclIntfIntegerHashMap.FreeValue(var Value: Integer): Integer;\r\nbegin\r\n Result := Value;\r\n Value := 0;\r\nend;\r\n\r\nfunction TJclIntfIntegerHashMap.Hash(const AInterface: IInterface): Integer;\r\nbegin\r\n Result := IntfSimpleHashConvert(AInterface);\r\nend;\r\n\r\nfunction TJclIntfIntegerHashMap.KeysEqual(const A, B: IInterface): Boolean;\r\nbegin\r\n Result := IntfSimpleEqualityCompare(A, B);\r\nend;\r\n\r\nfunction TJclIntfIntegerHashMap.ValuesEqual(A, B: Integer): Boolean;\r\nbegin\r\n Result := ItemsEqual(A, B);\r\nend;\r\n\r\n//=== { TJclIntegerIntegerHashMapBucket } ==========================================\r\n\r\nprocedure TJclIntegerIntegerHashMapBucket.InitializeArrayAfterMove(var List: TJclIntegerIntegerHashMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\nbegin\r\n { Clean array }\r\n if FromIndex < ToIndex then\r\n begin\r\n if (ToIndex - FromIndex) < Count then\r\n Count := ToIndex - FromIndex;\r\n FillChar(List[FromIndex], Count * SizeOf(List[0]), 0);\r\n end\r\n else\r\n if FromIndex > ToIndex then\r\n begin\r\n if (FromIndex - ToIndex) < Count then\r\n FillChar(List[ToIndex + Count], (FromIndex - ToIndex) * SizeOf(List[0]), 0)\r\n else\r\n FillChar(List[FromIndex], Count * SizeOf(List[0]), 0);\r\n end;\r\nend;\r\n\r\nprocedure TJclIntegerIntegerHashMapBucket.MoveArray(var List: TJclIntegerIntegerHashMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\nbegin\r\n if Count > 0 then\r\n begin\r\n Move(List[FromIndex], List[ToIndex], Count * SizeOf(List[0]));\r\n InitializeArrayAfterMove(List, FromIndex, ToIndex, Count);\r\n end;\r\nend;\r\n\r\n//=== { TJclIntegerIntegerHashMap } ==========================================\r\n\r\nconstructor TJclIntegerIntegerHashMap.Create(ACapacity: Integer);\r\nbegin\r\n inherited Create;\r\n SetCapacity(ACapacity);\r\n FHashToRangeFunction := JclSimpleHashToRange;\r\nend;\r\n\r\ndestructor TJclIntegerIntegerHashMap.Destroy;\r\nbegin\r\n FReadOnly := False;\r\n Clear;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJclIntegerIntegerHashMap.AssignDataTo(Dest: TJclAbstractContainerBase);\r\nvar\r\n I, J: Integer;\r\n SelfBucket, NewBucket: TJclIntegerIntegerHashMapBucket;\r\n ADest: TJclIntegerIntegerHashMap;\r\n AMap: IJclIntegerIntegerMap;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n inherited AssignDataTo(Dest);\r\n if Dest is TJclIntegerIntegerHashMap then\r\n begin\r\n ADest := TJclIntegerIntegerHashMap(Dest);\r\n ADest.Clear;\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n SelfBucket := FBuckets[I];\r\n if SelfBucket <> nil then\r\n begin\r\n NewBucket := TJclIntegerIntegerHashMapBucket.Create;\r\n SetLength(NewBucket.Entries, SelfBucket.Size);\r\n for J := 0 to SelfBucket.Size - 1 do\r\n begin\r\n NewBucket.Entries[J].Key := SelfBucket.Entries[J].Key;\r\n NewBucket.Entries[J].Value := SelfBucket.Entries[J].Value;\r\n end;\r\n NewBucket.Size := SelfBucket.Size;\r\n ADest.FBuckets[I] := NewBucket;\r\n end;\r\n end;\r\n end\r\n else\r\n if Supports(IInterface(Dest), IJclIntegerIntegerMap, AMap) then\r\n begin\r\n AMap.Clear;\r\n AMap.PutAll(Self);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclIntegerIntegerHashMap.AssignPropertiesTo(Dest: TJclAbstractContainerBase);\r\nbegin\r\n inherited AssignPropertiesto(Dest);\r\n if Dest is TJclIntegerIntegerHashMap then\r\n TJclIntegerIntegerHashMap(Dest).FHashToRangeFunction := FHashToRangeFunction;\r\nend;\r\n\r\nprocedure TJclIntegerIntegerHashMap.Clear;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclIntegerIntegerHashMapBucket;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n begin\r\n for J := 0 to Bucket.Size - 1 do\r\n begin\r\n FreeKey(Bucket.Entries[J].Key);\r\n FreeValue(Bucket.Entries[J].Value);\r\n end;\r\n FreeAndNil(FBuckets[I]);\r\n end;\r\n end;\r\n FSize := 0;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntegerIntegerHashMap.ContainsKey(Key: Integer): Boolean;\r\nvar\r\n I: Integer;\r\n Bucket: TJclIntegerIntegerHashMapBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n Bucket := FBuckets[FHashToRangeFunction(Hash(Key), FCapacity)];\r\n if Bucket <> nil then\r\n for I := 0 to Bucket.Size - 1 do\r\n if KeysEqual(Bucket.Entries[I].Key, Key) then\r\n begin\r\n Result := True;\r\n Break;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntegerIntegerHashMap.ContainsValue(Value: Integer): Boolean;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclIntegerIntegerHashMapBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n for J := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[J];\r\n if Bucket <> nil then\r\n for I := 0 to Bucket.Size - 1 do\r\n if ValuesEqual(Bucket.Entries[I].Value, Value) then\r\n begin\r\n Result := True;\r\n Break;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntegerIntegerHashMap.Extract(Key: Integer): Integer;\r\nvar\r\n Bucket: TJclIntegerIntegerHashMapBucket;\r\n I, NewCapacity: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := 0;\r\n Bucket := FBuckets[FHashToRangeFunction(Hash(Key), FCapacity)];\r\n if Bucket <> nil then\r\n begin\r\n for I := 0 to Bucket.Size - 1 do\r\n if KeysEqual(Bucket.Entries[I].Key, Key) then\r\n begin\r\n Result := Bucket.Entries[I].Value;\r\n Bucket.Entries[I].Value := 0;\r\n FreeKey(Bucket.Entries[I].Key);\r\n if I < Length(Bucket.Entries) - 1 then\r\n Bucket.MoveArray(Bucket.Entries, I + 1, I, Bucket.Size - I - 1);\r\n Dec(Bucket.Size);\r\n Dec(FSize);\r\n Break;\r\n end;\r\n\r\n NewCapacity := CalcPackCapacity(Length(Bucket.Entries), Bucket.Size);\r\n if NewCapacity < Length(Bucket.Entries) then\r\n SetLength(Bucket.Entries, NewCapacity);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntegerIntegerHashMap.GetValue(Key: Integer): Integer;\r\nvar\r\n I: Integer;\r\n Bucket: TJclIntegerIntegerHashMapBucket;\r\n Found: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Found := False;\r\n Result := 0;\r\n Bucket := FBuckets[FHashToRangeFunction(Hash(Key), FCapacity)];\r\n if Bucket <> nil then\r\n for I := 0 to Bucket.Size - 1 do\r\n if KeysEqual(Bucket.Entries[I].Key, Key) then\r\n begin\r\n Result := Bucket.Entries[I].Value;\r\n Found := True;\r\n Break;\r\n end;\r\n if (not Found) and (not FReturnDefaultElements) then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntegerIntegerHashMap.IsEmpty: Boolean;\r\nbegin\r\n Result := FSize = 0;\r\nend;\r\n\r\nfunction TJclIntegerIntegerHashMap.KeyOfValue(Value: Integer): Integer;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclIntegerIntegerHashMapBucket;\r\n Found: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Found := False;\r\n Result := 0;\r\n for J := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[J];\r\n if Bucket <> nil then\r\n for I := 0 to Bucket.Size - 1 do\r\n if ValuesEqual(Bucket.Entries[I].Value, Value) then\r\n begin\r\n Result := Bucket.Entries[I].Key;\r\n Found := True;\r\n Break;\r\n end;\r\n end;\r\n if (not Found) and (not FReturnDefaultElements) then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntegerIntegerHashMap.KeySet: IJclIntegerSet;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclIntegerIntegerHashMapBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := TJclIntegerArraySet.Create(FSize);\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n for J := 0 to Bucket.Size - 1 do\r\n Result.Add(Bucket.Entries[J].Key);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntegerIntegerHashMap.MapEquals(const AMap: IJclIntegerIntegerMap): Boolean;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclIntegerIntegerHashMapBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if AMap = nil then\r\n Exit;\r\n if FSize <> AMap.Size then\r\n Exit;\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n for J := 0 to Bucket.Size - 1 do\r\n if AMap.ContainsKey(Bucket.Entries[J].Key) then\r\n begin\r\n if not ValuesEqual(AMap.GetValue(Bucket.Entries[J].Key), Bucket.Entries[J].Value) then\r\n Exit;\r\n end\r\n else\r\n Exit;\r\n end;\r\n Result := True;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclIntegerIntegerHashMap.Pack;\r\nvar\r\n I: Integer;\r\n Bucket: TJclIntegerIntegerHashMapBucket;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n begin\r\n if Bucket.Size > 0 then\r\n SetLength(Bucket.Entries, Bucket.Size)\r\n else\r\n FreeAndNil(FBuckets[I]);\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclIntegerIntegerHashMap.PutAll(const AMap: IJclIntegerIntegerMap);\r\nvar\r\n It: IJclIntegerIterator;\r\n Key: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if AMap = nil then\r\n Exit;\r\n It := AMap.KeySet.First;\r\n while It.HasNext do\r\n begin\r\n Key := It.Next;\r\n PutValue(Key, AMap.GetValue(Key));\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclIntegerIntegerHashMap.PutValue(Key: Integer; Value: Integer);\r\nvar\r\n Index: Integer;\r\n Bucket: TJclIntegerIntegerHashMapBucket;\r\n I: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FAllowDefaultElements or (not KeysEqual(Key, 0) and not ValuesEqual(Value, 0)) then\r\n begin\r\n Index := FHashToRangeFunction(Hash(Key), FCapacity);\r\n Bucket := FBuckets[Index];\r\n if Bucket <> nil then\r\n begin\r\n for I := 0 to Bucket.Size - 1 do\r\n if KeysEqual(Bucket.Entries[I].Key, Key) then\r\n begin\r\n FreeValue(Bucket.Entries[I].Value);\r\n Bucket.Entries[I].Value := Value;\r\n Exit;\r\n end;\r\n end\r\n else\r\n begin\r\n Bucket := TJclIntegerIntegerHashMapBucket.Create;\r\n SetLength(Bucket.Entries, 1);\r\n FBuckets[Index] := Bucket;\r\n end;\r\n\r\n if Bucket.Size = Length(Bucket.Entries) then\r\n SetLength(Bucket.Entries, CalcGrowCapacity(Bucket.Size, Bucket.Size));\r\n\r\n if Bucket.Size < Length(Bucket.Entries) then\r\n begin\r\n Bucket.Entries[Bucket.Size].Key := Key;\r\n Bucket.Entries[Bucket.Size].Value := Value;\r\n Inc(Bucket.Size);\r\n Inc(FSize);\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntegerIntegerHashMap.Remove(Key: Integer): Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := Extract(Key);\r\n Result := FreeValue(Result);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclIntegerIntegerHashMap.SetCapacity(Value: Integer);\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FSize = 0 then\r\n begin\r\n SetLength(FBuckets, Value);\r\n inherited SetCapacity(Value);\r\n end\r\n else\r\n raise EJclOperationNotSupportedError.Create;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntegerIntegerHashMap.Size: Integer;\r\nbegin\r\n Result := FSize;\r\nend;\r\n\r\nfunction TJclIntegerIntegerHashMap.Values: IJclIntegerCollection;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclIntegerIntegerHashMapBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := TJclIntegerArrayList.Create(FSize);\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n for J := 0 to Bucket.Size - 1 do\r\n Result.Add(Bucket.Entries[J].Value);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntegerIntegerHashMap.CreateEmptyContainer: TJclAbstractContainerBase;\r\nbegin\r\n Result := TJclIntegerIntegerHashMap.Create(FCapacity);\r\n AssignPropertiesTo(Result);\r\nend;\r\n\r\nfunction TJclIntegerIntegerHashMap.FreeKey(var Key: Integer): Integer;\r\nbegin\r\n Result := Key;\r\n Key := 0;\r\nend;\r\n\r\nfunction TJclIntegerIntegerHashMap.FreeValue(var Value: Integer): Integer;\r\nbegin\r\n Result := Value;\r\n Value := 0;\r\nend;\r\n\r\nfunction TJclIntegerIntegerHashMap.KeysEqual(A, B: Integer): Boolean;\r\nbegin\r\n Result := ItemsEqual(A, B);\r\nend;\r\n\r\nfunction TJclIntegerIntegerHashMap.ValuesEqual(A, B: Integer): Boolean;\r\nbegin\r\n Result := ItemsEqual(A, B);\r\nend;\r\n\r\n//=== { TJclCardinalIntfHashMapBucket } ==========================================\r\n\r\nprocedure TJclCardinalIntfHashMapBucket.FinalizeArrayBeforeMove(var List: TJclCardinalIntfHashMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\nbegin\r\n Assert(Count > 0);\r\n if FromIndex < ToIndex then\r\n begin\r\n if Count > (ToIndex - FromIndex) then\r\n Finalize(List[FromIndex + Count], ToIndex - FromIndex)\r\n else\r\n Finalize(List[ToIndex], Count);\r\n end\r\n else\r\n if FromIndex > ToIndex then\r\n begin\r\n if Count > (FromIndex - ToIndex) then\r\n Count := FromIndex - ToIndex;\r\n Finalize(List[ToIndex], Count)\r\n end;\r\nend;\r\n\r\nprocedure TJclCardinalIntfHashMapBucket.InitializeArray(var List: TJclCardinalIntfHashMapEntryArray; FromIndex, Count: SizeInt);\r\nbegin\r\n {$IFDEF FPC}\r\n while Count > 0 do\r\n begin\r\n Initialize(List[FromIndex]);\r\n Inc(FromIndex);\r\n Dec(Count);\r\n end;\r\n {$ELSE ~FPC}\r\n Initialize(List[FromIndex], Count);\r\n {$ENDIF ~FPC}\r\nend;\r\n\r\nprocedure TJclCardinalIntfHashMapBucket.InitializeArrayAfterMove(var List: TJclCardinalIntfHashMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\nbegin\r\n { Keep reference counting working }\r\n if FromIndex < ToIndex then\r\n begin\r\n if (ToIndex - FromIndex) < Count then\r\n Count := ToIndex - FromIndex;\r\n InitializeArray(List, FromIndex, Count);\r\n end\r\n else\r\n if FromIndex > ToIndex then\r\n begin\r\n if (FromIndex - ToIndex) < Count then\r\n InitializeArray(List, ToIndex + Count, FromIndex - ToIndex)\r\n else\r\n InitializeArray(List, FromIndex, Count);\r\n end;\r\nend;\r\n\r\nprocedure TJclCardinalIntfHashMapBucket.MoveArray(var List: TJclCardinalIntfHashMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\nbegin\r\n if Count > 0 then\r\n begin\r\n FinalizeArrayBeforeMove(List, FromIndex, ToIndex, Count);\r\n Move(List[FromIndex], List[ToIndex], Count * SizeOf(List[0]));\r\n InitializeArrayAfterMove(List, FromIndex, ToIndex, Count);\r\n end;\r\nend;\r\n\r\n//=== { TJclCardinalIntfHashMap } ==========================================\r\n\r\nconstructor TJclCardinalIntfHashMap.Create(ACapacity: Integer);\r\nbegin\r\n inherited Create;\r\n SetCapacity(ACapacity);\r\n FHashToRangeFunction := JclSimpleHashToRange;\r\nend;\r\n\r\ndestructor TJclCardinalIntfHashMap.Destroy;\r\nbegin\r\n FReadOnly := False;\r\n Clear;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJclCardinalIntfHashMap.AssignDataTo(Dest: TJclAbstractContainerBase);\r\nvar\r\n I, J: Integer;\r\n SelfBucket, NewBucket: TJclCardinalIntfHashMapBucket;\r\n ADest: TJclCardinalIntfHashMap;\r\n AMap: IJclCardinalIntfMap;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n inherited AssignDataTo(Dest);\r\n if Dest is TJclCardinalIntfHashMap then\r\n begin\r\n ADest := TJclCardinalIntfHashMap(Dest);\r\n ADest.Clear;\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n SelfBucket := FBuckets[I];\r\n if SelfBucket <> nil then\r\n begin\r\n NewBucket := TJclCardinalIntfHashMapBucket.Create;\r\n SetLength(NewBucket.Entries, SelfBucket.Size);\r\n for J := 0 to SelfBucket.Size - 1 do\r\n begin\r\n NewBucket.Entries[J].Key := SelfBucket.Entries[J].Key;\r\n NewBucket.Entries[J].Value := SelfBucket.Entries[J].Value;\r\n end;\r\n NewBucket.Size := SelfBucket.Size;\r\n ADest.FBuckets[I] := NewBucket;\r\n end;\r\n end;\r\n end\r\n else\r\n if Supports(IInterface(Dest), IJclCardinalIntfMap, AMap) then\r\n begin\r\n AMap.Clear;\r\n AMap.PutAll(Self);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclCardinalIntfHashMap.AssignPropertiesTo(Dest: TJclAbstractContainerBase);\r\nbegin\r\n inherited AssignPropertiesto(Dest);\r\n if Dest is TJclCardinalIntfHashMap then\r\n TJclCardinalIntfHashMap(Dest).FHashToRangeFunction := FHashToRangeFunction;\r\nend;\r\n\r\nprocedure TJclCardinalIntfHashMap.Clear;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclCardinalIntfHashMapBucket;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n begin\r\n for J := 0 to Bucket.Size - 1 do\r\n begin\r\n FreeKey(Bucket.Entries[J].Key);\r\n FreeValue(Bucket.Entries[J].Value);\r\n end;\r\n FreeAndNil(FBuckets[I]);\r\n end;\r\n end;\r\n FSize := 0;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclCardinalIntfHashMap.ContainsKey(Key: Cardinal): Boolean;\r\nvar\r\n I: Integer;\r\n Bucket: TJclCardinalIntfHashMapBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n Bucket := FBuckets[FHashToRangeFunction(Hash(Key), FCapacity)];\r\n if Bucket <> nil then\r\n for I := 0 to Bucket.Size - 1 do\r\n if KeysEqual(Bucket.Entries[I].Key, Key) then\r\n begin\r\n Result := True;\r\n Break;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclCardinalIntfHashMap.ContainsValue(const Value: IInterface): Boolean;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclCardinalIntfHashMapBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n for J := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[J];\r\n if Bucket <> nil then\r\n for I := 0 to Bucket.Size - 1 do\r\n if ValuesEqual(Bucket.Entries[I].Value, Value) then\r\n begin\r\n Result := True;\r\n Break;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclCardinalIntfHashMap.Extract(Key: Cardinal): IInterface;\r\nvar\r\n Bucket: TJclCardinalIntfHashMapBucket;\r\n I, NewCapacity: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := nil;\r\n Bucket := FBuckets[FHashToRangeFunction(Hash(Key), FCapacity)];\r\n if Bucket <> nil then\r\n begin\r\n for I := 0 to Bucket.Size - 1 do\r\n if KeysEqual(Bucket.Entries[I].Key, Key) then\r\n begin\r\n Result := Bucket.Entries[I].Value;\r\n Bucket.Entries[I].Value := nil;\r\n FreeKey(Bucket.Entries[I].Key);\r\n if I < Length(Bucket.Entries) - 1 then\r\n Bucket.MoveArray(Bucket.Entries, I + 1, I, Bucket.Size - I - 1);\r\n Dec(Bucket.Size);\r\n Dec(FSize);\r\n Break;\r\n end;\r\n\r\n NewCapacity := CalcPackCapacity(Length(Bucket.Entries), Bucket.Size);\r\n if NewCapacity < Length(Bucket.Entries) then\r\n SetLength(Bucket.Entries, NewCapacity);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclCardinalIntfHashMap.GetValue(Key: Cardinal): IInterface;\r\nvar\r\n I: Integer;\r\n Bucket: TJclCardinalIntfHashMapBucket;\r\n Found: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Found := False;\r\n Result := nil;\r\n Bucket := FBuckets[FHashToRangeFunction(Hash(Key), FCapacity)];\r\n if Bucket <> nil then\r\n for I := 0 to Bucket.Size - 1 do\r\n if KeysEqual(Bucket.Entries[I].Key, Key) then\r\n begin\r\n Result := Bucket.Entries[I].Value;\r\n Found := True;\r\n Break;\r\n end;\r\n if (not Found) and (not FReturnDefaultElements) then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclCardinalIntfHashMap.IsEmpty: Boolean;\r\nbegin\r\n Result := FSize = 0;\r\nend;\r\n\r\nfunction TJclCardinalIntfHashMap.KeyOfValue(const Value: IInterface): Cardinal;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclCardinalIntfHashMapBucket;\r\n Found: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Found := False;\r\n Result := 0;\r\n for J := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[J];\r\n if Bucket <> nil then\r\n for I := 0 to Bucket.Size - 1 do\r\n if ValuesEqual(Bucket.Entries[I].Value, Value) then\r\n begin\r\n Result := Bucket.Entries[I].Key;\r\n Found := True;\r\n Break;\r\n end;\r\n end;\r\n if (not Found) and (not FReturnDefaultElements) then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclCardinalIntfHashMap.KeySet: IJclCardinalSet;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclCardinalIntfHashMapBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := TJclCardinalArraySet.Create(FSize);\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n for J := 0 to Bucket.Size - 1 do\r\n Result.Add(Bucket.Entries[J].Key);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclCardinalIntfHashMap.MapEquals(const AMap: IJclCardinalIntfMap): Boolean;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclCardinalIntfHashMapBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if AMap = nil then\r\n Exit;\r\n if FSize <> AMap.Size then\r\n Exit;\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n for J := 0 to Bucket.Size - 1 do\r\n if AMap.ContainsKey(Bucket.Entries[J].Key) then\r\n begin\r\n if not ValuesEqual(AMap.GetValue(Bucket.Entries[J].Key), Bucket.Entries[J].Value) then\r\n Exit;\r\n end\r\n else\r\n Exit;\r\n end;\r\n Result := True;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclCardinalIntfHashMap.Pack;\r\nvar\r\n I: Integer;\r\n Bucket: TJclCardinalIntfHashMapBucket;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n begin\r\n if Bucket.Size > 0 then\r\n SetLength(Bucket.Entries, Bucket.Size)\r\n else\r\n FreeAndNil(FBuckets[I]);\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclCardinalIntfHashMap.PutAll(const AMap: IJclCardinalIntfMap);\r\nvar\r\n It: IJclCardinalIterator;\r\n Key: Cardinal;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if AMap = nil then\r\n Exit;\r\n It := AMap.KeySet.First;\r\n while It.HasNext do\r\n begin\r\n Key := It.Next;\r\n PutValue(Key, AMap.GetValue(Key));\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclCardinalIntfHashMap.PutValue(Key: Cardinal; const Value: IInterface);\r\nvar\r\n Index: Integer;\r\n Bucket: TJclCardinalIntfHashMapBucket;\r\n I: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FAllowDefaultElements or (not KeysEqual(Key, 0) and not ValuesEqual(Value, nil)) then\r\n begin\r\n Index := FHashToRangeFunction(Hash(Key), FCapacity);\r\n Bucket := FBuckets[Index];\r\n if Bucket <> nil then\r\n begin\r\n for I := 0 to Bucket.Size - 1 do\r\n if KeysEqual(Bucket.Entries[I].Key, Key) then\r\n begin\r\n FreeValue(Bucket.Entries[I].Value);\r\n Bucket.Entries[I].Value := Value;\r\n Exit;\r\n end;\r\n end\r\n else\r\n begin\r\n Bucket := TJclCardinalIntfHashMapBucket.Create;\r\n SetLength(Bucket.Entries, 1);\r\n FBuckets[Index] := Bucket;\r\n end;\r\n\r\n if Bucket.Size = Length(Bucket.Entries) then\r\n SetLength(Bucket.Entries, CalcGrowCapacity(Bucket.Size, Bucket.Size));\r\n\r\n if Bucket.Size < Length(Bucket.Entries) then\r\n begin\r\n Bucket.Entries[Bucket.Size].Key := Key;\r\n Bucket.Entries[Bucket.Size].Value := Value;\r\n Inc(Bucket.Size);\r\n Inc(FSize);\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclCardinalIntfHashMap.Remove(Key: Cardinal): IInterface;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := Extract(Key);\r\n Result := FreeValue(Result);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclCardinalIntfHashMap.SetCapacity(Value: Integer);\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FSize = 0 then\r\n begin\r\n SetLength(FBuckets, Value);\r\n inherited SetCapacity(Value);\r\n end\r\n else\r\n raise EJclOperationNotSupportedError.Create;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclCardinalIntfHashMap.Size: Integer;\r\nbegin\r\n Result := FSize;\r\nend;\r\n\r\nfunction TJclCardinalIntfHashMap.Values: IJclIntfCollection;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclCardinalIntfHashMapBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := TJclIntfArrayList.Create(FSize);\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n for J := 0 to Bucket.Size - 1 do\r\n Result.Add(Bucket.Entries[J].Value);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclCardinalIntfHashMap.CreateEmptyContainer: TJclAbstractContainerBase;\r\nbegin\r\n Result := TJclCardinalIntfHashMap.Create(FCapacity);\r\n AssignPropertiesTo(Result);\r\nend;\r\n\r\nfunction TJclCardinalIntfHashMap.FreeKey(var Key: Cardinal): Cardinal;\r\nbegin\r\n Result := Key;\r\n Key := 0;\r\nend;\r\n\r\nfunction TJclCardinalIntfHashMap.FreeValue(var Value: IInterface): IInterface;\r\nbegin\r\n Result := Value;\r\n Value := nil;\r\nend;\r\n\r\nfunction TJclCardinalIntfHashMap.KeysEqual(A, B: Cardinal): Boolean;\r\nbegin\r\n Result := ItemsEqual(A, B);\r\nend;\r\n\r\nfunction TJclCardinalIntfHashMap.ValuesEqual(const A, B: IInterface): Boolean;\r\nbegin\r\n Result := IntfSimpleEqualityCompare(A, B);\r\nend;\r\n\r\n//=== { TJclIntfCardinalHashMapBucket } ==========================================\r\n\r\nprocedure TJclIntfCardinalHashMapBucket.FinalizeArrayBeforeMove(var List: TJclIntfCardinalHashMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\nbegin\r\n Assert(Count > 0);\r\n if FromIndex < ToIndex then\r\n begin\r\n if Count > (ToIndex - FromIndex) then\r\n Finalize(List[FromIndex + Count], ToIndex - FromIndex)\r\n else\r\n Finalize(List[ToIndex], Count);\r\n end\r\n else\r\n if FromIndex > ToIndex then\r\n begin\r\n if Count > (FromIndex - ToIndex) then\r\n Count := FromIndex - ToIndex;\r\n Finalize(List[ToIndex], Count)\r\n end;\r\nend;\r\n\r\nprocedure TJclIntfCardinalHashMapBucket.InitializeArray(var List: TJclIntfCardinalHashMapEntryArray; FromIndex, Count: SizeInt);\r\nbegin\r\n {$IFDEF FPC}\r\n while Count > 0 do\r\n begin\r\n Initialize(List[FromIndex]);\r\n Inc(FromIndex);\r\n Dec(Count);\r\n end;\r\n {$ELSE ~FPC}\r\n Initialize(List[FromIndex], Count);\r\n {$ENDIF ~FPC}\r\nend;\r\n\r\nprocedure TJclIntfCardinalHashMapBucket.InitializeArrayAfterMove(var List: TJclIntfCardinalHashMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\nbegin\r\n { Keep reference counting working }\r\n if FromIndex < ToIndex then\r\n begin\r\n if (ToIndex - FromIndex) < Count then\r\n Count := ToIndex - FromIndex;\r\n InitializeArray(List, FromIndex, Count);\r\n end\r\n else\r\n if FromIndex > ToIndex then\r\n begin\r\n if (FromIndex - ToIndex) < Count then\r\n InitializeArray(List, ToIndex + Count, FromIndex - ToIndex)\r\n else\r\n InitializeArray(List, FromIndex, Count);\r\n end;\r\nend;\r\n\r\nprocedure TJclIntfCardinalHashMapBucket.MoveArray(var List: TJclIntfCardinalHashMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\nbegin\r\n if Count > 0 then\r\n begin\r\n FinalizeArrayBeforeMove(List, FromIndex, ToIndex, Count);\r\n Move(List[FromIndex], List[ToIndex], Count * SizeOf(List[0]));\r\n InitializeArrayAfterMove(List, FromIndex, ToIndex, Count);\r\n end;\r\nend;\r\n\r\n//=== { TJclIntfCardinalHashMap } ==========================================\r\n\r\nconstructor TJclIntfCardinalHashMap.Create(ACapacity: Integer);\r\nbegin\r\n inherited Create;\r\n SetCapacity(ACapacity);\r\n FHashToRangeFunction := JclSimpleHashToRange;\r\nend;\r\n\r\ndestructor TJclIntfCardinalHashMap.Destroy;\r\nbegin\r\n FReadOnly := False;\r\n Clear;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJclIntfCardinalHashMap.AssignDataTo(Dest: TJclAbstractContainerBase);\r\nvar\r\n I, J: Integer;\r\n SelfBucket, NewBucket: TJclIntfCardinalHashMapBucket;\r\n ADest: TJclIntfCardinalHashMap;\r\n AMap: IJclIntfCardinalMap;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n inherited AssignDataTo(Dest);\r\n if Dest is TJclIntfCardinalHashMap then\r\n begin\r\n ADest := TJclIntfCardinalHashMap(Dest);\r\n ADest.Clear;\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n SelfBucket := FBuckets[I];\r\n if SelfBucket <> nil then\r\n begin\r\n NewBucket := TJclIntfCardinalHashMapBucket.Create;\r\n SetLength(NewBucket.Entries, SelfBucket.Size);\r\n for J := 0 to SelfBucket.Size - 1 do\r\n begin\r\n NewBucket.Entries[J].Key := SelfBucket.Entries[J].Key;\r\n NewBucket.Entries[J].Value := SelfBucket.Entries[J].Value;\r\n end;\r\n NewBucket.Size := SelfBucket.Size;\r\n ADest.FBuckets[I] := NewBucket;\r\n end;\r\n end;\r\n end\r\n else\r\n if Supports(IInterface(Dest), IJclIntfCardinalMap, AMap) then\r\n begin\r\n AMap.Clear;\r\n AMap.PutAll(Self);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclIntfCardinalHashMap.AssignPropertiesTo(Dest: TJclAbstractContainerBase);\r\nbegin\r\n inherited AssignPropertiesto(Dest);\r\n if Dest is TJclIntfCardinalHashMap then\r\n TJclIntfCardinalHashMap(Dest).FHashToRangeFunction := FHashToRangeFunction;\r\nend;\r\n\r\nprocedure TJclIntfCardinalHashMap.Clear;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclIntfCardinalHashMapBucket;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n begin\r\n for J := 0 to Bucket.Size - 1 do\r\n begin\r\n FreeKey(Bucket.Entries[J].Key);\r\n FreeValue(Bucket.Entries[J].Value);\r\n end;\r\n FreeAndNil(FBuckets[I]);\r\n end;\r\n end;\r\n FSize := 0;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfCardinalHashMap.ContainsKey(const Key: IInterface): Boolean;\r\nvar\r\n I: Integer;\r\n Bucket: TJclIntfCardinalHashMapBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n Bucket := FBuckets[FHashToRangeFunction(Hash(Key), FCapacity)];\r\n if Bucket <> nil then\r\n for I := 0 to Bucket.Size - 1 do\r\n if KeysEqual(Bucket.Entries[I].Key, Key) then\r\n begin\r\n Result := True;\r\n Break;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfCardinalHashMap.ContainsValue(Value: Cardinal): Boolean;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclIntfCardinalHashMapBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n for J := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[J];\r\n if Bucket <> nil then\r\n for I := 0 to Bucket.Size - 1 do\r\n if ValuesEqual(Bucket.Entries[I].Value, Value) then\r\n begin\r\n Result := True;\r\n Break;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfCardinalHashMap.Extract(const Key: IInterface): Cardinal;\r\nvar\r\n Bucket: TJclIntfCardinalHashMapBucket;\r\n I, NewCapacity: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := 0;\r\n Bucket := FBuckets[FHashToRangeFunction(Hash(Key), FCapacity)];\r\n if Bucket <> nil then\r\n begin\r\n for I := 0 to Bucket.Size - 1 do\r\n if KeysEqual(Bucket.Entries[I].Key, Key) then\r\n begin\r\n Result := Bucket.Entries[I].Value;\r\n Bucket.Entries[I].Value := 0;\r\n FreeKey(Bucket.Entries[I].Key);\r\n if I < Length(Bucket.Entries) - 1 then\r\n Bucket.MoveArray(Bucket.Entries, I + 1, I, Bucket.Size - I - 1);\r\n Dec(Bucket.Size);\r\n Dec(FSize);\r\n Break;\r\n end;\r\n\r\n NewCapacity := CalcPackCapacity(Length(Bucket.Entries), Bucket.Size);\r\n if NewCapacity < Length(Bucket.Entries) then\r\n SetLength(Bucket.Entries, NewCapacity);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfCardinalHashMap.GetValue(const Key: IInterface): Cardinal;\r\nvar\r\n I: Integer;\r\n Bucket: TJclIntfCardinalHashMapBucket;\r\n Found: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Found := False;\r\n Result := 0;\r\n Bucket := FBuckets[FHashToRangeFunction(Hash(Key), FCapacity)];\r\n if Bucket <> nil then\r\n for I := 0 to Bucket.Size - 1 do\r\n if KeysEqual(Bucket.Entries[I].Key, Key) then\r\n begin\r\n Result := Bucket.Entries[I].Value;\r\n Found := True;\r\n Break;\r\n end;\r\n if (not Found) and (not FReturnDefaultElements) then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfCardinalHashMap.IsEmpty: Boolean;\r\nbegin\r\n Result := FSize = 0;\r\nend;\r\n\r\nfunction TJclIntfCardinalHashMap.KeyOfValue(Value: Cardinal): IInterface;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclIntfCardinalHashMapBucket;\r\n Found: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Found := False;\r\n Result := nil;\r\n for J := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[J];\r\n if Bucket <> nil then\r\n for I := 0 to Bucket.Size - 1 do\r\n if ValuesEqual(Bucket.Entries[I].Value, Value) then\r\n begin\r\n Result := Bucket.Entries[I].Key;\r\n Found := True;\r\n Break;\r\n end;\r\n end;\r\n if (not Found) and (not FReturnDefaultElements) then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfCardinalHashMap.KeySet: IJclIntfSet;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclIntfCardinalHashMapBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := TJclIntfArraySet.Create(FSize);\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n for J := 0 to Bucket.Size - 1 do\r\n Result.Add(Bucket.Entries[J].Key);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfCardinalHashMap.MapEquals(const AMap: IJclIntfCardinalMap): Boolean;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclIntfCardinalHashMapBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if AMap = nil then\r\n Exit;\r\n if FSize <> AMap.Size then\r\n Exit;\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n for J := 0 to Bucket.Size - 1 do\r\n if AMap.ContainsKey(Bucket.Entries[J].Key) then\r\n begin\r\n if not ValuesEqual(AMap.GetValue(Bucket.Entries[J].Key), Bucket.Entries[J].Value) then\r\n Exit;\r\n end\r\n else\r\n Exit;\r\n end;\r\n Result := True;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclIntfCardinalHashMap.Pack;\r\nvar\r\n I: Integer;\r\n Bucket: TJclIntfCardinalHashMapBucket;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n begin\r\n if Bucket.Size > 0 then\r\n SetLength(Bucket.Entries, Bucket.Size)\r\n else\r\n FreeAndNil(FBuckets[I]);\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclIntfCardinalHashMap.PutAll(const AMap: IJclIntfCardinalMap);\r\nvar\r\n It: IJclIntfIterator;\r\n Key: IInterface;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if AMap = nil then\r\n Exit;\r\n It := AMap.KeySet.First;\r\n while It.HasNext do\r\n begin\r\n Key := It.Next;\r\n PutValue(Key, AMap.GetValue(Key));\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclIntfCardinalHashMap.PutValue(const Key: IInterface; Value: Cardinal);\r\nvar\r\n Index: Integer;\r\n Bucket: TJclIntfCardinalHashMapBucket;\r\n I: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FAllowDefaultElements or (not KeysEqual(Key, nil) and not ValuesEqual(Value, 0)) then\r\n begin\r\n Index := FHashToRangeFunction(Hash(Key), FCapacity);\r\n Bucket := FBuckets[Index];\r\n if Bucket <> nil then\r\n begin\r\n for I := 0 to Bucket.Size - 1 do\r\n if KeysEqual(Bucket.Entries[I].Key, Key) then\r\n begin\r\n FreeValue(Bucket.Entries[I].Value);\r\n Bucket.Entries[I].Value := Value;\r\n Exit;\r\n end;\r\n end\r\n else\r\n begin\r\n Bucket := TJclIntfCardinalHashMapBucket.Create;\r\n SetLength(Bucket.Entries, 1);\r\n FBuckets[Index] := Bucket;\r\n end;\r\n\r\n if Bucket.Size = Length(Bucket.Entries) then\r\n SetLength(Bucket.Entries, CalcGrowCapacity(Bucket.Size, Bucket.Size));\r\n\r\n if Bucket.Size < Length(Bucket.Entries) then\r\n begin\r\n Bucket.Entries[Bucket.Size].Key := Key;\r\n Bucket.Entries[Bucket.Size].Value := Value;\r\n Inc(Bucket.Size);\r\n Inc(FSize);\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfCardinalHashMap.Remove(const Key: IInterface): Cardinal;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := Extract(Key);\r\n Result := FreeValue(Result);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclIntfCardinalHashMap.SetCapacity(Value: Integer);\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FSize = 0 then\r\n begin\r\n SetLength(FBuckets, Value);\r\n inherited SetCapacity(Value);\r\n end\r\n else\r\n raise EJclOperationNotSupportedError.Create;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfCardinalHashMap.Size: Integer;\r\nbegin\r\n Result := FSize;\r\nend;\r\n\r\nfunction TJclIntfCardinalHashMap.Values: IJclCardinalCollection;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclIntfCardinalHashMapBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := TJclCardinalArrayList.Create(FSize);\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n for J := 0 to Bucket.Size - 1 do\r\n Result.Add(Bucket.Entries[J].Value);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfCardinalHashMap.CreateEmptyContainer: TJclAbstractContainerBase;\r\nbegin\r\n Result := TJclIntfCardinalHashMap.Create(FCapacity);\r\n AssignPropertiesTo(Result);\r\nend;\r\n\r\nfunction TJclIntfCardinalHashMap.FreeKey(var Key: IInterface): IInterface;\r\nbegin\r\n Result := Key;\r\n Key := nil;\r\nend;\r\n\r\nfunction TJclIntfCardinalHashMap.FreeValue(var Value: Cardinal): Cardinal;\r\nbegin\r\n Result := Value;\r\n Value := 0;\r\nend;\r\n\r\nfunction TJclIntfCardinalHashMap.Hash(const AInterface: IInterface): Integer;\r\nbegin\r\n Result := IntfSimpleHashConvert(AInterface);\r\nend;\r\n\r\nfunction TJclIntfCardinalHashMap.KeysEqual(const A, B: IInterface): Boolean;\r\nbegin\r\n Result := IntfSimpleEqualityCompare(A, B);\r\nend;\r\n\r\nfunction TJclIntfCardinalHashMap.ValuesEqual(A, B: Cardinal): Boolean;\r\nbegin\r\n Result := ItemsEqual(A, B);\r\nend;\r\n\r\n//=== { TJclCardinalCardinalHashMapBucket } ==========================================\r\n\r\nprocedure TJclCardinalCardinalHashMapBucket.InitializeArrayAfterMove(var List: TJclCardinalCardinalHashMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\nbegin\r\n { Clean array }\r\n if FromIndex < ToIndex then\r\n begin\r\n if (ToIndex - FromIndex) < Count then\r\n Count := ToIndex - FromIndex;\r\n FillChar(List[FromIndex], Count * SizeOf(List[0]), 0);\r\n end\r\n else\r\n if FromIndex > ToIndex then\r\n begin\r\n if (FromIndex - ToIndex) < Count then\r\n FillChar(List[ToIndex + Count], (FromIndex - ToIndex) * SizeOf(List[0]), 0)\r\n else\r\n FillChar(List[FromIndex], Count * SizeOf(List[0]), 0);\r\n end;\r\nend;\r\n\r\nprocedure TJclCardinalCardinalHashMapBucket.MoveArray(var List: TJclCardinalCardinalHashMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\nbegin\r\n if Count > 0 then\r\n begin\r\n Move(List[FromIndex], List[ToIndex], Count * SizeOf(List[0]));\r\n InitializeArrayAfterMove(List, FromIndex, ToIndex, Count);\r\n end;\r\nend;\r\n\r\n//=== { TJclCardinalCardinalHashMap } ==========================================\r\n\r\nconstructor TJclCardinalCardinalHashMap.Create(ACapacity: Integer);\r\nbegin\r\n inherited Create;\r\n SetCapacity(ACapacity);\r\n FHashToRangeFunction := JclSimpleHashToRange;\r\nend;\r\n\r\ndestructor TJclCardinalCardinalHashMap.Destroy;\r\nbegin\r\n FReadOnly := False;\r\n Clear;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJclCardinalCardinalHashMap.AssignDataTo(Dest: TJclAbstractContainerBase);\r\nvar\r\n I, J: Integer;\r\n SelfBucket, NewBucket: TJclCardinalCardinalHashMapBucket;\r\n ADest: TJclCardinalCardinalHashMap;\r\n AMap: IJclCardinalCardinalMap;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n inherited AssignDataTo(Dest);\r\n if Dest is TJclCardinalCardinalHashMap then\r\n begin\r\n ADest := TJclCardinalCardinalHashMap(Dest);\r\n ADest.Clear;\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n SelfBucket := FBuckets[I];\r\n if SelfBucket <> nil then\r\n begin\r\n NewBucket := TJclCardinalCardinalHashMapBucket.Create;\r\n SetLength(NewBucket.Entries, SelfBucket.Size);\r\n for J := 0 to SelfBucket.Size - 1 do\r\n begin\r\n NewBucket.Entries[J].Key := SelfBucket.Entries[J].Key;\r\n NewBucket.Entries[J].Value := SelfBucket.Entries[J].Value;\r\n end;\r\n NewBucket.Size := SelfBucket.Size;\r\n ADest.FBuckets[I] := NewBucket;\r\n end;\r\n end;\r\n end\r\n else\r\n if Supports(IInterface(Dest), IJclCardinalCardinalMap, AMap) then\r\n begin\r\n AMap.Clear;\r\n AMap.PutAll(Self);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclCardinalCardinalHashMap.AssignPropertiesTo(Dest: TJclAbstractContainerBase);\r\nbegin\r\n inherited AssignPropertiesto(Dest);\r\n if Dest is TJclCardinalCardinalHashMap then\r\n TJclCardinalCardinalHashMap(Dest).FHashToRangeFunction := FHashToRangeFunction;\r\nend;\r\n\r\nprocedure TJclCardinalCardinalHashMap.Clear;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclCardinalCardinalHashMapBucket;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n begin\r\n for J := 0 to Bucket.Size - 1 do\r\n begin\r\n FreeKey(Bucket.Entries[J].Key);\r\n FreeValue(Bucket.Entries[J].Value);\r\n end;\r\n FreeAndNil(FBuckets[I]);\r\n end;\r\n end;\r\n FSize := 0;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclCardinalCardinalHashMap.ContainsKey(Key: Cardinal): Boolean;\r\nvar\r\n I: Integer;\r\n Bucket: TJclCardinalCardinalHashMapBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n Bucket := FBuckets[FHashToRangeFunction(Hash(Key), FCapacity)];\r\n if Bucket <> nil then\r\n for I := 0 to Bucket.Size - 1 do\r\n if KeysEqual(Bucket.Entries[I].Key, Key) then\r\n begin\r\n Result := True;\r\n Break;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclCardinalCardinalHashMap.ContainsValue(Value: Cardinal): Boolean;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclCardinalCardinalHashMapBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n for J := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[J];\r\n if Bucket <> nil then\r\n for I := 0 to Bucket.Size - 1 do\r\n if ValuesEqual(Bucket.Entries[I].Value, Value) then\r\n begin\r\n Result := True;\r\n Break;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclCardinalCardinalHashMap.Extract(Key: Cardinal): Cardinal;\r\nvar\r\n Bucket: TJclCardinalCardinalHashMapBucket;\r\n I, NewCapacity: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := 0;\r\n Bucket := FBuckets[FHashToRangeFunction(Hash(Key), FCapacity)];\r\n if Bucket <> nil then\r\n begin\r\n for I := 0 to Bucket.Size - 1 do\r\n if KeysEqual(Bucket.Entries[I].Key, Key) then\r\n begin\r\n Result := Bucket.Entries[I].Value;\r\n Bucket.Entries[I].Value := 0;\r\n FreeKey(Bucket.Entries[I].Key);\r\n if I < Length(Bucket.Entries) - 1 then\r\n Bucket.MoveArray(Bucket.Entries, I + 1, I, Bucket.Size - I - 1);\r\n Dec(Bucket.Size);\r\n Dec(FSize);\r\n Break;\r\n end;\r\n\r\n NewCapacity := CalcPackCapacity(Length(Bucket.Entries), Bucket.Size);\r\n if NewCapacity < Length(Bucket.Entries) then\r\n SetLength(Bucket.Entries, NewCapacity);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclCardinalCardinalHashMap.GetValue(Key: Cardinal): Cardinal;\r\nvar\r\n I: Integer;\r\n Bucket: TJclCardinalCardinalHashMapBucket;\r\n Found: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Found := False;\r\n Result := 0;\r\n Bucket := FBuckets[FHashToRangeFunction(Hash(Key), FCapacity)];\r\n if Bucket <> nil then\r\n for I := 0 to Bucket.Size - 1 do\r\n if KeysEqual(Bucket.Entries[I].Key, Key) then\r\n begin\r\n Result := Bucket.Entries[I].Value;\r\n Found := True;\r\n Break;\r\n end;\r\n if (not Found) and (not FReturnDefaultElements) then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclCardinalCardinalHashMap.IsEmpty: Boolean;\r\nbegin\r\n Result := FSize = 0;\r\nend;\r\n\r\nfunction TJclCardinalCardinalHashMap.KeyOfValue(Value: Cardinal): Cardinal;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclCardinalCardinalHashMapBucket;\r\n Found: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Found := False;\r\n Result := 0;\r\n for J := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[J];\r\n if Bucket <> nil then\r\n for I := 0 to Bucket.Size - 1 do\r\n if ValuesEqual(Bucket.Entries[I].Value, Value) then\r\n begin\r\n Result := Bucket.Entries[I].Key;\r\n Found := True;\r\n Break;\r\n end;\r\n end;\r\n if (not Found) and (not FReturnDefaultElements) then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclCardinalCardinalHashMap.KeySet: IJclCardinalSet;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclCardinalCardinalHashMapBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := TJclCardinalArraySet.Create(FSize);\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n for J := 0 to Bucket.Size - 1 do\r\n Result.Add(Bucket.Entries[J].Key);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclCardinalCardinalHashMap.MapEquals(const AMap: IJclCardinalCardinalMap): Boolean;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclCardinalCardinalHashMapBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if AMap = nil then\r\n Exit;\r\n if FSize <> AMap.Size then\r\n Exit;\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n for J := 0 to Bucket.Size - 1 do\r\n if AMap.ContainsKey(Bucket.Entries[J].Key) then\r\n begin\r\n if not ValuesEqual(AMap.GetValue(Bucket.Entries[J].Key), Bucket.Entries[J].Value) then\r\n Exit;\r\n end\r\n else\r\n Exit;\r\n end;\r\n Result := True;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclCardinalCardinalHashMap.Pack;\r\nvar\r\n I: Integer;\r\n Bucket: TJclCardinalCardinalHashMapBucket;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n begin\r\n if Bucket.Size > 0 then\r\n SetLength(Bucket.Entries, Bucket.Size)\r\n else\r\n FreeAndNil(FBuckets[I]);\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclCardinalCardinalHashMap.PutAll(const AMap: IJclCardinalCardinalMap);\r\nvar\r\n It: IJclCardinalIterator;\r\n Key: Cardinal;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if AMap = nil then\r\n Exit;\r\n It := AMap.KeySet.First;\r\n while It.HasNext do\r\n begin\r\n Key := It.Next;\r\n PutValue(Key, AMap.GetValue(Key));\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclCardinalCardinalHashMap.PutValue(Key: Cardinal; Value: Cardinal);\r\nvar\r\n Index: Integer;\r\n Bucket: TJclCardinalCardinalHashMapBucket;\r\n I: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FAllowDefaultElements or (not KeysEqual(Key, 0) and not ValuesEqual(Value, 0)) then\r\n begin\r\n Index := FHashToRangeFunction(Hash(Key), FCapacity);\r\n Bucket := FBuckets[Index];\r\n if Bucket <> nil then\r\n begin\r\n for I := 0 to Bucket.Size - 1 do\r\n if KeysEqual(Bucket.Entries[I].Key, Key) then\r\n begin\r\n FreeValue(Bucket.Entries[I].Value);\r\n Bucket.Entries[I].Value := Value;\r\n Exit;\r\n end;\r\n end\r\n else\r\n begin\r\n Bucket := TJclCardinalCardinalHashMapBucket.Create;\r\n SetLength(Bucket.Entries, 1);\r\n FBuckets[Index] := Bucket;\r\n end;\r\n\r\n if Bucket.Size = Length(Bucket.Entries) then\r\n SetLength(Bucket.Entries, CalcGrowCapacity(Bucket.Size, Bucket.Size));\r\n\r\n if Bucket.Size < Length(Bucket.Entries) then\r\n begin\r\n Bucket.Entries[Bucket.Size].Key := Key;\r\n Bucket.Entries[Bucket.Size].Value := Value;\r\n Inc(Bucket.Size);\r\n Inc(FSize);\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclCardinalCardinalHashMap.Remove(Key: Cardinal): Cardinal;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := Extract(Key);\r\n Result := FreeValue(Result);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclCardinalCardinalHashMap.SetCapacity(Value: Integer);\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FSize = 0 then\r\n begin\r\n SetLength(FBuckets, Value);\r\n inherited SetCapacity(Value);\r\n end\r\n else\r\n raise EJclOperationNotSupportedError.Create;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclCardinalCardinalHashMap.Size: Integer;\r\nbegin\r\n Result := FSize;\r\nend;\r\n\r\nfunction TJclCardinalCardinalHashMap.Values: IJclCardinalCollection;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclCardinalCardinalHashMapBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := TJclCardinalArrayList.Create(FSize);\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n for J := 0 to Bucket.Size - 1 do\r\n Result.Add(Bucket.Entries[J].Value);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclCardinalCardinalHashMap.CreateEmptyContainer: TJclAbstractContainerBase;\r\nbegin\r\n Result := TJclCardinalCardinalHashMap.Create(FCapacity);\r\n AssignPropertiesTo(Result);\r\nend;\r\n\r\nfunction TJclCardinalCardinalHashMap.FreeKey(var Key: Cardinal): Cardinal;\r\nbegin\r\n Result := Key;\r\n Key := 0;\r\nend;\r\n\r\nfunction TJclCardinalCardinalHashMap.FreeValue(var Value: Cardinal): Cardinal;\r\nbegin\r\n Result := Value;\r\n Value := 0;\r\nend;\r\n\r\nfunction TJclCardinalCardinalHashMap.KeysEqual(A, B: Cardinal): Boolean;\r\nbegin\r\n Result := ItemsEqual(A, B);\r\nend;\r\n\r\nfunction TJclCardinalCardinalHashMap.ValuesEqual(A, B: Cardinal): Boolean;\r\nbegin\r\n Result := ItemsEqual(A, B);\r\nend;\r\n\r\n//=== { TJclInt64IntfHashMapBucket } ==========================================\r\n\r\nprocedure TJclInt64IntfHashMapBucket.FinalizeArrayBeforeMove(var List: TJclInt64IntfHashMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\nbegin\r\n Assert(Count > 0);\r\n if FromIndex < ToIndex then\r\n begin\r\n if Count > (ToIndex - FromIndex) then\r\n Finalize(List[FromIndex + Count], ToIndex - FromIndex)\r\n else\r\n Finalize(List[ToIndex], Count);\r\n end\r\n else\r\n if FromIndex > ToIndex then\r\n begin\r\n if Count > (FromIndex - ToIndex) then\r\n Count := FromIndex - ToIndex;\r\n Finalize(List[ToIndex], Count)\r\n end;\r\nend;\r\n\r\nprocedure TJclInt64IntfHashMapBucket.InitializeArray(var List: TJclInt64IntfHashMapEntryArray; FromIndex, Count: SizeInt);\r\nbegin\r\n {$IFDEF FPC}\r\n while Count > 0 do\r\n begin\r\n Initialize(List[FromIndex]);\r\n Inc(FromIndex);\r\n Dec(Count);\r\n end;\r\n {$ELSE ~FPC}\r\n Initialize(List[FromIndex], Count);\r\n {$ENDIF ~FPC}\r\nend;\r\n\r\nprocedure TJclInt64IntfHashMapBucket.InitializeArrayAfterMove(var List: TJclInt64IntfHashMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\nbegin\r\n { Keep reference counting working }\r\n if FromIndex < ToIndex then\r\n begin\r\n if (ToIndex - FromIndex) < Count then\r\n Count := ToIndex - FromIndex;\r\n InitializeArray(List, FromIndex, Count);\r\n end\r\n else\r\n if FromIndex > ToIndex then\r\n begin\r\n if (FromIndex - ToIndex) < Count then\r\n InitializeArray(List, ToIndex + Count, FromIndex - ToIndex)\r\n else\r\n InitializeArray(List, FromIndex, Count);\r\n end;\r\nend;\r\n\r\nprocedure TJclInt64IntfHashMapBucket.MoveArray(var List: TJclInt64IntfHashMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\nbegin\r\n if Count > 0 then\r\n begin\r\n FinalizeArrayBeforeMove(List, FromIndex, ToIndex, Count);\r\n Move(List[FromIndex], List[ToIndex], Count * SizeOf(List[0]));\r\n InitializeArrayAfterMove(List, FromIndex, ToIndex, Count);\r\n end;\r\nend;\r\n\r\n//=== { TJclInt64IntfHashMap } ==========================================\r\n\r\nconstructor TJclInt64IntfHashMap.Create(ACapacity: Integer);\r\nbegin\r\n inherited Create;\r\n SetCapacity(ACapacity);\r\n FHashToRangeFunction := JclSimpleHashToRange;\r\nend;\r\n\r\ndestructor TJclInt64IntfHashMap.Destroy;\r\nbegin\r\n FReadOnly := False;\r\n Clear;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJclInt64IntfHashMap.AssignDataTo(Dest: TJclAbstractContainerBase);\r\nvar\r\n I, J: Integer;\r\n SelfBucket, NewBucket: TJclInt64IntfHashMapBucket;\r\n ADest: TJclInt64IntfHashMap;\r\n AMap: IJclInt64IntfMap;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n inherited AssignDataTo(Dest);\r\n if Dest is TJclInt64IntfHashMap then\r\n begin\r\n ADest := TJclInt64IntfHashMap(Dest);\r\n ADest.Clear;\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n SelfBucket := FBuckets[I];\r\n if SelfBucket <> nil then\r\n begin\r\n NewBucket := TJclInt64IntfHashMapBucket.Create;\r\n SetLength(NewBucket.Entries, SelfBucket.Size);\r\n for J := 0 to SelfBucket.Size - 1 do\r\n begin\r\n NewBucket.Entries[J].Key := SelfBucket.Entries[J].Key;\r\n NewBucket.Entries[J].Value := SelfBucket.Entries[J].Value;\r\n end;\r\n NewBucket.Size := SelfBucket.Size;\r\n ADest.FBuckets[I] := NewBucket;\r\n end;\r\n end;\r\n end\r\n else\r\n if Supports(IInterface(Dest), IJclInt64IntfMap, AMap) then\r\n begin\r\n AMap.Clear;\r\n AMap.PutAll(Self);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclInt64IntfHashMap.AssignPropertiesTo(Dest: TJclAbstractContainerBase);\r\nbegin\r\n inherited AssignPropertiesto(Dest);\r\n if Dest is TJclInt64IntfHashMap then\r\n TJclInt64IntfHashMap(Dest).FHashToRangeFunction := FHashToRangeFunction;\r\nend;\r\n\r\nprocedure TJclInt64IntfHashMap.Clear;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclInt64IntfHashMapBucket;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n begin\r\n for J := 0 to Bucket.Size - 1 do\r\n begin\r\n FreeKey(Bucket.Entries[J].Key);\r\n FreeValue(Bucket.Entries[J].Value);\r\n end;\r\n FreeAndNil(FBuckets[I]);\r\n end;\r\n end;\r\n FSize := 0;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclInt64IntfHashMap.ContainsKey(const Key: Int64): Boolean;\r\nvar\r\n I: Integer;\r\n Bucket: TJclInt64IntfHashMapBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n Bucket := FBuckets[FHashToRangeFunction(Hash(Key), FCapacity)];\r\n if Bucket <> nil then\r\n for I := 0 to Bucket.Size - 1 do\r\n if KeysEqual(Bucket.Entries[I].Key, Key) then\r\n begin\r\n Result := True;\r\n Break;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclInt64IntfHashMap.ContainsValue(const Value: IInterface): Boolean;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclInt64IntfHashMapBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n for J := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[J];\r\n if Bucket <> nil then\r\n for I := 0 to Bucket.Size - 1 do\r\n if ValuesEqual(Bucket.Entries[I].Value, Value) then\r\n begin\r\n Result := True;\r\n Break;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclInt64IntfHashMap.Extract(const Key: Int64): IInterface;\r\nvar\r\n Bucket: TJclInt64IntfHashMapBucket;\r\n I, NewCapacity: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := nil;\r\n Bucket := FBuckets[FHashToRangeFunction(Hash(Key), FCapacity)];\r\n if Bucket <> nil then\r\n begin\r\n for I := 0 to Bucket.Size - 1 do\r\n if KeysEqual(Bucket.Entries[I].Key, Key) then\r\n begin\r\n Result := Bucket.Entries[I].Value;\r\n Bucket.Entries[I].Value := nil;\r\n FreeKey(Bucket.Entries[I].Key);\r\n if I < Length(Bucket.Entries) - 1 then\r\n Bucket.MoveArray(Bucket.Entries, I + 1, I, Bucket.Size - I - 1);\r\n Dec(Bucket.Size);\r\n Dec(FSize);\r\n Break;\r\n end;\r\n\r\n NewCapacity := CalcPackCapacity(Length(Bucket.Entries), Bucket.Size);\r\n if NewCapacity < Length(Bucket.Entries) then\r\n SetLength(Bucket.Entries, NewCapacity);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclInt64IntfHashMap.GetValue(const Key: Int64): IInterface;\r\nvar\r\n I: Integer;\r\n Bucket: TJclInt64IntfHashMapBucket;\r\n Found: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Found := False;\r\n Result := nil;\r\n Bucket := FBuckets[FHashToRangeFunction(Hash(Key), FCapacity)];\r\n if Bucket <> nil then\r\n for I := 0 to Bucket.Size - 1 do\r\n if KeysEqual(Bucket.Entries[I].Key, Key) then\r\n begin\r\n Result := Bucket.Entries[I].Value;\r\n Found := True;\r\n Break;\r\n end;\r\n if (not Found) and (not FReturnDefaultElements) then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclInt64IntfHashMap.IsEmpty: Boolean;\r\nbegin\r\n Result := FSize = 0;\r\nend;\r\n\r\nfunction TJclInt64IntfHashMap.KeyOfValue(const Value: IInterface): Int64;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclInt64IntfHashMapBucket;\r\n Found: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Found := False;\r\n Result := 0;\r\n for J := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[J];\r\n if Bucket <> nil then\r\n for I := 0 to Bucket.Size - 1 do\r\n if ValuesEqual(Bucket.Entries[I].Value, Value) then\r\n begin\r\n Result := Bucket.Entries[I].Key;\r\n Found := True;\r\n Break;\r\n end;\r\n end;\r\n if (not Found) and (not FReturnDefaultElements) then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclInt64IntfHashMap.KeySet: IJclInt64Set;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclInt64IntfHashMapBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := TJclInt64ArraySet.Create(FSize);\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n for J := 0 to Bucket.Size - 1 do\r\n Result.Add(Bucket.Entries[J].Key);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclInt64IntfHashMap.MapEquals(const AMap: IJclInt64IntfMap): Boolean;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclInt64IntfHashMapBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if AMap = nil then\r\n Exit;\r\n if FSize <> AMap.Size then\r\n Exit;\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n for J := 0 to Bucket.Size - 1 do\r\n if AMap.ContainsKey(Bucket.Entries[J].Key) then\r\n begin\r\n if not ValuesEqual(AMap.GetValue(Bucket.Entries[J].Key), Bucket.Entries[J].Value) then\r\n Exit;\r\n end\r\n else\r\n Exit;\r\n end;\r\n Result := True;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclInt64IntfHashMap.Pack;\r\nvar\r\n I: Integer;\r\n Bucket: TJclInt64IntfHashMapBucket;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n begin\r\n if Bucket.Size > 0 then\r\n SetLength(Bucket.Entries, Bucket.Size)\r\n else\r\n FreeAndNil(FBuckets[I]);\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclInt64IntfHashMap.PutAll(const AMap: IJclInt64IntfMap);\r\nvar\r\n It: IJclInt64Iterator;\r\n Key: Int64;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if AMap = nil then\r\n Exit;\r\n It := AMap.KeySet.First;\r\n while It.HasNext do\r\n begin\r\n Key := It.Next;\r\n PutValue(Key, AMap.GetValue(Key));\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclInt64IntfHashMap.PutValue(const Key: Int64; const Value: IInterface);\r\nvar\r\n Index: Integer;\r\n Bucket: TJclInt64IntfHashMapBucket;\r\n I: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FAllowDefaultElements or (not KeysEqual(Key, 0) and not ValuesEqual(Value, nil)) then\r\n begin\r\n Index := FHashToRangeFunction(Hash(Key), FCapacity);\r\n Bucket := FBuckets[Index];\r\n if Bucket <> nil then\r\n begin\r\n for I := 0 to Bucket.Size - 1 do\r\n if KeysEqual(Bucket.Entries[I].Key, Key) then\r\n begin\r\n FreeValue(Bucket.Entries[I].Value);\r\n Bucket.Entries[I].Value := Value;\r\n Exit;\r\n end;\r\n end\r\n else\r\n begin\r\n Bucket := TJclInt64IntfHashMapBucket.Create;\r\n SetLength(Bucket.Entries, 1);\r\n FBuckets[Index] := Bucket;\r\n end;\r\n\r\n if Bucket.Size = Length(Bucket.Entries) then\r\n SetLength(Bucket.Entries, CalcGrowCapacity(Bucket.Size, Bucket.Size));\r\n\r\n if Bucket.Size < Length(Bucket.Entries) then\r\n begin\r\n Bucket.Entries[Bucket.Size].Key := Key;\r\n Bucket.Entries[Bucket.Size].Value := Value;\r\n Inc(Bucket.Size);\r\n Inc(FSize);\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclInt64IntfHashMap.Remove(const Key: Int64): IInterface;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := Extract(Key);\r\n Result := FreeValue(Result);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclInt64IntfHashMap.SetCapacity(Value: Integer);\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FSize = 0 then\r\n begin\r\n SetLength(FBuckets, Value);\r\n inherited SetCapacity(Value);\r\n end\r\n else\r\n raise EJclOperationNotSupportedError.Create;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclInt64IntfHashMap.Size: Integer;\r\nbegin\r\n Result := FSize;\r\nend;\r\n\r\nfunction TJclInt64IntfHashMap.Values: IJclIntfCollection;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclInt64IntfHashMapBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := TJclIntfArrayList.Create(FSize);\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n for J := 0 to Bucket.Size - 1 do\r\n Result.Add(Bucket.Entries[J].Value);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclInt64IntfHashMap.CreateEmptyContainer: TJclAbstractContainerBase;\r\nbegin\r\n Result := TJclInt64IntfHashMap.Create(FCapacity);\r\n AssignPropertiesTo(Result);\r\nend;\r\n\r\nfunction TJclInt64IntfHashMap.FreeKey(var Key: Int64): Int64;\r\nbegin\r\n Result := Key;\r\n Key := 0;\r\nend;\r\n\r\nfunction TJclInt64IntfHashMap.FreeValue(var Value: IInterface): IInterface;\r\nbegin\r\n Result := Value;\r\n Value := nil;\r\nend;\r\n\r\nfunction TJclInt64IntfHashMap.KeysEqual(const A, B: Int64): Boolean;\r\nbegin\r\n Result := ItemsEqual(A, B);\r\nend;\r\n\r\nfunction TJclInt64IntfHashMap.ValuesEqual(const A, B: IInterface): Boolean;\r\nbegin\r\n Result := IntfSimpleEqualityCompare(A, B);\r\nend;\r\n\r\n//=== { TJclIntfInt64HashMapBucket } ==========================================\r\n\r\nprocedure TJclIntfInt64HashMapBucket.FinalizeArrayBeforeMove(var List: TJclIntfInt64HashMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\nbegin\r\n Assert(Count > 0);\r\n if FromIndex < ToIndex then\r\n begin\r\n if Count > (ToIndex - FromIndex) then\r\n Finalize(List[FromIndex + Count], ToIndex - FromIndex)\r\n else\r\n Finalize(List[ToIndex], Count);\r\n end\r\n else\r\n if FromIndex > ToIndex then\r\n begin\r\n if Count > (FromIndex - ToIndex) then\r\n Count := FromIndex - ToIndex;\r\n Finalize(List[ToIndex], Count)\r\n end;\r\nend;\r\n\r\nprocedure TJclIntfInt64HashMapBucket.InitializeArray(var List: TJclIntfInt64HashMapEntryArray; FromIndex, Count: SizeInt);\r\nbegin\r\n {$IFDEF FPC}\r\n while Count > 0 do\r\n begin\r\n Initialize(List[FromIndex]);\r\n Inc(FromIndex);\r\n Dec(Count);\r\n end;\r\n {$ELSE ~FPC}\r\n Initialize(List[FromIndex], Count);\r\n {$ENDIF ~FPC}\r\nend;\r\n\r\nprocedure TJclIntfInt64HashMapBucket.InitializeArrayAfterMove(var List: TJclIntfInt64HashMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\nbegin\r\n { Keep reference counting working }\r\n if FromIndex < ToIndex then\r\n begin\r\n if (ToIndex - FromIndex) < Count then\r\n Count := ToIndex - FromIndex;\r\n InitializeArray(List, FromIndex, Count);\r\n end\r\n else\r\n if FromIndex > ToIndex then\r\n begin\r\n if (FromIndex - ToIndex) < Count then\r\n InitializeArray(List, ToIndex + Count, FromIndex - ToIndex)\r\n else\r\n InitializeArray(List, FromIndex, Count);\r\n end;\r\nend;\r\n\r\nprocedure TJclIntfInt64HashMapBucket.MoveArray(var List: TJclIntfInt64HashMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\nbegin\r\n if Count > 0 then\r\n begin\r\n FinalizeArrayBeforeMove(List, FromIndex, ToIndex, Count);\r\n Move(List[FromIndex], List[ToIndex], Count * SizeOf(List[0]));\r\n InitializeArrayAfterMove(List, FromIndex, ToIndex, Count);\r\n end;\r\nend;\r\n\r\n//=== { TJclIntfInt64HashMap } ==========================================\r\n\r\nconstructor TJclIntfInt64HashMap.Create(ACapacity: Integer);\r\nbegin\r\n inherited Create;\r\n SetCapacity(ACapacity);\r\n FHashToRangeFunction := JclSimpleHashToRange;\r\nend;\r\n\r\ndestructor TJclIntfInt64HashMap.Destroy;\r\nbegin\r\n FReadOnly := False;\r\n Clear;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJclIntfInt64HashMap.AssignDataTo(Dest: TJclAbstractContainerBase);\r\nvar\r\n I, J: Integer;\r\n SelfBucket, NewBucket: TJclIntfInt64HashMapBucket;\r\n ADest: TJclIntfInt64HashMap;\r\n AMap: IJclIntfInt64Map;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n inherited AssignDataTo(Dest);\r\n if Dest is TJclIntfInt64HashMap then\r\n begin\r\n ADest := TJclIntfInt64HashMap(Dest);\r\n ADest.Clear;\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n SelfBucket := FBuckets[I];\r\n if SelfBucket <> nil then\r\n begin\r\n NewBucket := TJclIntfInt64HashMapBucket.Create;\r\n SetLength(NewBucket.Entries, SelfBucket.Size);\r\n for J := 0 to SelfBucket.Size - 1 do\r\n begin\r\n NewBucket.Entries[J].Key := SelfBucket.Entries[J].Key;\r\n NewBucket.Entries[J].Value := SelfBucket.Entries[J].Value;\r\n end;\r\n NewBucket.Size := SelfBucket.Size;\r\n ADest.FBuckets[I] := NewBucket;\r\n end;\r\n end;\r\n end\r\n else\r\n if Supports(IInterface(Dest), IJclIntfInt64Map, AMap) then\r\n begin\r\n AMap.Clear;\r\n AMap.PutAll(Self);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclIntfInt64HashMap.AssignPropertiesTo(Dest: TJclAbstractContainerBase);\r\nbegin\r\n inherited AssignPropertiesto(Dest);\r\n if Dest is TJclIntfInt64HashMap then\r\n TJclIntfInt64HashMap(Dest).FHashToRangeFunction := FHashToRangeFunction;\r\nend;\r\n\r\nprocedure TJclIntfInt64HashMap.Clear;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclIntfInt64HashMapBucket;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n begin\r\n for J := 0 to Bucket.Size - 1 do\r\n begin\r\n FreeKey(Bucket.Entries[J].Key);\r\n FreeValue(Bucket.Entries[J].Value);\r\n end;\r\n FreeAndNil(FBuckets[I]);\r\n end;\r\n end;\r\n FSize := 0;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfInt64HashMap.ContainsKey(const Key: IInterface): Boolean;\r\nvar\r\n I: Integer;\r\n Bucket: TJclIntfInt64HashMapBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n Bucket := FBuckets[FHashToRangeFunction(Hash(Key), FCapacity)];\r\n if Bucket <> nil then\r\n for I := 0 to Bucket.Size - 1 do\r\n if KeysEqual(Bucket.Entries[I].Key, Key) then\r\n begin\r\n Result := True;\r\n Break;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfInt64HashMap.ContainsValue(const Value: Int64): Boolean;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclIntfInt64HashMapBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n for J := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[J];\r\n if Bucket <> nil then\r\n for I := 0 to Bucket.Size - 1 do\r\n if ValuesEqual(Bucket.Entries[I].Value, Value) then\r\n begin\r\n Result := True;\r\n Break;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfInt64HashMap.Extract(const Key: IInterface): Int64;\r\nvar\r\n Bucket: TJclIntfInt64HashMapBucket;\r\n I, NewCapacity: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := 0;\r\n Bucket := FBuckets[FHashToRangeFunction(Hash(Key), FCapacity)];\r\n if Bucket <> nil then\r\n begin\r\n for I := 0 to Bucket.Size - 1 do\r\n if KeysEqual(Bucket.Entries[I].Key, Key) then\r\n begin\r\n Result := Bucket.Entries[I].Value;\r\n Bucket.Entries[I].Value := 0;\r\n FreeKey(Bucket.Entries[I].Key);\r\n if I < Length(Bucket.Entries) - 1 then\r\n Bucket.MoveArray(Bucket.Entries, I + 1, I, Bucket.Size - I - 1);\r\n Dec(Bucket.Size);\r\n Dec(FSize);\r\n Break;\r\n end;\r\n\r\n NewCapacity := CalcPackCapacity(Length(Bucket.Entries), Bucket.Size);\r\n if NewCapacity < Length(Bucket.Entries) then\r\n SetLength(Bucket.Entries, NewCapacity);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfInt64HashMap.GetValue(const Key: IInterface): Int64;\r\nvar\r\n I: Integer;\r\n Bucket: TJclIntfInt64HashMapBucket;\r\n Found: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Found := False;\r\n Result := 0;\r\n Bucket := FBuckets[FHashToRangeFunction(Hash(Key), FCapacity)];\r\n if Bucket <> nil then\r\n for I := 0 to Bucket.Size - 1 do\r\n if KeysEqual(Bucket.Entries[I].Key, Key) then\r\n begin\r\n Result := Bucket.Entries[I].Value;\r\n Found := True;\r\n Break;\r\n end;\r\n if (not Found) and (not FReturnDefaultElements) then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfInt64HashMap.IsEmpty: Boolean;\r\nbegin\r\n Result := FSize = 0;\r\nend;\r\n\r\nfunction TJclIntfInt64HashMap.KeyOfValue(const Value: Int64): IInterface;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclIntfInt64HashMapBucket;\r\n Found: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Found := False;\r\n Result := nil;\r\n for J := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[J];\r\n if Bucket <> nil then\r\n for I := 0 to Bucket.Size - 1 do\r\n if ValuesEqual(Bucket.Entries[I].Value, Value) then\r\n begin\r\n Result := Bucket.Entries[I].Key;\r\n Found := True;\r\n Break;\r\n end;\r\n end;\r\n if (not Found) and (not FReturnDefaultElements) then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfInt64HashMap.KeySet: IJclIntfSet;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclIntfInt64HashMapBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := TJclIntfArraySet.Create(FSize);\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n for J := 0 to Bucket.Size - 1 do\r\n Result.Add(Bucket.Entries[J].Key);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfInt64HashMap.MapEquals(const AMap: IJclIntfInt64Map): Boolean;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclIntfInt64HashMapBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if AMap = nil then\r\n Exit;\r\n if FSize <> AMap.Size then\r\n Exit;\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n for J := 0 to Bucket.Size - 1 do\r\n if AMap.ContainsKey(Bucket.Entries[J].Key) then\r\n begin\r\n if not ValuesEqual(AMap.GetValue(Bucket.Entries[J].Key), Bucket.Entries[J].Value) then\r\n Exit;\r\n end\r\n else\r\n Exit;\r\n end;\r\n Result := True;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclIntfInt64HashMap.Pack;\r\nvar\r\n I: Integer;\r\n Bucket: TJclIntfInt64HashMapBucket;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n begin\r\n if Bucket.Size > 0 then\r\n SetLength(Bucket.Entries, Bucket.Size)\r\n else\r\n FreeAndNil(FBuckets[I]);\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclIntfInt64HashMap.PutAll(const AMap: IJclIntfInt64Map);\r\nvar\r\n It: IJclIntfIterator;\r\n Key: IInterface;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if AMap = nil then\r\n Exit;\r\n It := AMap.KeySet.First;\r\n while It.HasNext do\r\n begin\r\n Key := It.Next;\r\n PutValue(Key, AMap.GetValue(Key));\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclIntfInt64HashMap.PutValue(const Key: IInterface; const Value: Int64);\r\nvar\r\n Index: Integer;\r\n Bucket: TJclIntfInt64HashMapBucket;\r\n I: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FAllowDefaultElements or (not KeysEqual(Key, nil) and not ValuesEqual(Value, 0)) then\r\n begin\r\n Index := FHashToRangeFunction(Hash(Key), FCapacity);\r\n Bucket := FBuckets[Index];\r\n if Bucket <> nil then\r\n begin\r\n for I := 0 to Bucket.Size - 1 do\r\n if KeysEqual(Bucket.Entries[I].Key, Key) then\r\n begin\r\n FreeValue(Bucket.Entries[I].Value);\r\n Bucket.Entries[I].Value := Value;\r\n Exit;\r\n end;\r\n end\r\n else\r\n begin\r\n Bucket := TJclIntfInt64HashMapBucket.Create;\r\n SetLength(Bucket.Entries, 1);\r\n FBuckets[Index] := Bucket;\r\n end;\r\n\r\n if Bucket.Size = Length(Bucket.Entries) then\r\n SetLength(Bucket.Entries, CalcGrowCapacity(Bucket.Size, Bucket.Size));\r\n\r\n if Bucket.Size < Length(Bucket.Entries) then\r\n begin\r\n Bucket.Entries[Bucket.Size].Key := Key;\r\n Bucket.Entries[Bucket.Size].Value := Value;\r\n Inc(Bucket.Size);\r\n Inc(FSize);\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfInt64HashMap.Remove(const Key: IInterface): Int64;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := Extract(Key);\r\n Result := FreeValue(Result);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclIntfInt64HashMap.SetCapacity(Value: Integer);\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FSize = 0 then\r\n begin\r\n SetLength(FBuckets, Value);\r\n inherited SetCapacity(Value);\r\n end\r\n else\r\n raise EJclOperationNotSupportedError.Create;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfInt64HashMap.Size: Integer;\r\nbegin\r\n Result := FSize;\r\nend;\r\n\r\nfunction TJclIntfInt64HashMap.Values: IJclInt64Collection;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclIntfInt64HashMapBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := TJclInt64ArrayList.Create(FSize);\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n for J := 0 to Bucket.Size - 1 do\r\n Result.Add(Bucket.Entries[J].Value);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfInt64HashMap.CreateEmptyContainer: TJclAbstractContainerBase;\r\nbegin\r\n Result := TJclIntfInt64HashMap.Create(FCapacity);\r\n AssignPropertiesTo(Result);\r\nend;\r\n\r\nfunction TJclIntfInt64HashMap.FreeKey(var Key: IInterface): IInterface;\r\nbegin\r\n Result := Key;\r\n Key := nil;\r\nend;\r\n\r\nfunction TJclIntfInt64HashMap.FreeValue(var Value: Int64): Int64;\r\nbegin\r\n Result := Value;\r\n Value := 0;\r\nend;\r\n\r\nfunction TJclIntfInt64HashMap.Hash(const AInterface: IInterface): Integer;\r\nbegin\r\n Result := IntfSimpleHashConvert(AInterface);\r\nend;\r\n\r\nfunction TJclIntfInt64HashMap.KeysEqual(const A, B: IInterface): Boolean;\r\nbegin\r\n Result := IntfSimpleEqualityCompare(A, B);\r\nend;\r\n\r\nfunction TJclIntfInt64HashMap.ValuesEqual(const A, B: Int64): Boolean;\r\nbegin\r\n Result := ItemsEqual(A, B);\r\nend;\r\n\r\n//=== { TJclInt64Int64HashMapBucket } ==========================================\r\n\r\nprocedure TJclInt64Int64HashMapBucket.InitializeArrayAfterMove(var List: TJclInt64Int64HashMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\nbegin\r\n { Clean array }\r\n if FromIndex < ToIndex then\r\n begin\r\n if (ToIndex - FromIndex) < Count then\r\n Count := ToIndex - FromIndex;\r\n FillChar(List[FromIndex], Count * SizeOf(List[0]), 0);\r\n end\r\n else\r\n if FromIndex > ToIndex then\r\n begin\r\n if (FromIndex - ToIndex) < Count then\r\n FillChar(List[ToIndex + Count], (FromIndex - ToIndex) * SizeOf(List[0]), 0)\r\n else\r\n FillChar(List[FromIndex], Count * SizeOf(List[0]), 0);\r\n end;\r\nend;\r\n\r\nprocedure TJclInt64Int64HashMapBucket.MoveArray(var List: TJclInt64Int64HashMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\nbegin\r\n if Count > 0 then\r\n begin\r\n Move(List[FromIndex], List[ToIndex], Count * SizeOf(List[0]));\r\n InitializeArrayAfterMove(List, FromIndex, ToIndex, Count);\r\n end;\r\nend;\r\n\r\n//=== { TJclInt64Int64HashMap } ==========================================\r\n\r\nconstructor TJclInt64Int64HashMap.Create(ACapacity: Integer);\r\nbegin\r\n inherited Create;\r\n SetCapacity(ACapacity);\r\n FHashToRangeFunction := JclSimpleHashToRange;\r\nend;\r\n\r\ndestructor TJclInt64Int64HashMap.Destroy;\r\nbegin\r\n FReadOnly := False;\r\n Clear;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJclInt64Int64HashMap.AssignDataTo(Dest: TJclAbstractContainerBase);\r\nvar\r\n I, J: Integer;\r\n SelfBucket, NewBucket: TJclInt64Int64HashMapBucket;\r\n ADest: TJclInt64Int64HashMap;\r\n AMap: IJclInt64Int64Map;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n inherited AssignDataTo(Dest);\r\n if Dest is TJclInt64Int64HashMap then\r\n begin\r\n ADest := TJclInt64Int64HashMap(Dest);\r\n ADest.Clear;\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n SelfBucket := FBuckets[I];\r\n if SelfBucket <> nil then\r\n begin\r\n NewBucket := TJclInt64Int64HashMapBucket.Create;\r\n SetLength(NewBucket.Entries, SelfBucket.Size);\r\n for J := 0 to SelfBucket.Size - 1 do\r\n begin\r\n NewBucket.Entries[J].Key := SelfBucket.Entries[J].Key;\r\n NewBucket.Entries[J].Value := SelfBucket.Entries[J].Value;\r\n end;\r\n NewBucket.Size := SelfBucket.Size;\r\n ADest.FBuckets[I] := NewBucket;\r\n end;\r\n end;\r\n end\r\n else\r\n if Supports(IInterface(Dest), IJclInt64Int64Map, AMap) then\r\n begin\r\n AMap.Clear;\r\n AMap.PutAll(Self);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclInt64Int64HashMap.AssignPropertiesTo(Dest: TJclAbstractContainerBase);\r\nbegin\r\n inherited AssignPropertiesto(Dest);\r\n if Dest is TJclInt64Int64HashMap then\r\n TJclInt64Int64HashMap(Dest).FHashToRangeFunction := FHashToRangeFunction;\r\nend;\r\n\r\nprocedure TJclInt64Int64HashMap.Clear;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclInt64Int64HashMapBucket;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n begin\r\n for J := 0 to Bucket.Size - 1 do\r\n begin\r\n FreeKey(Bucket.Entries[J].Key);\r\n FreeValue(Bucket.Entries[J].Value);\r\n end;\r\n FreeAndNil(FBuckets[I]);\r\n end;\r\n end;\r\n FSize := 0;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclInt64Int64HashMap.ContainsKey(const Key: Int64): Boolean;\r\nvar\r\n I: Integer;\r\n Bucket: TJclInt64Int64HashMapBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n Bucket := FBuckets[FHashToRangeFunction(Hash(Key), FCapacity)];\r\n if Bucket <> nil then\r\n for I := 0 to Bucket.Size - 1 do\r\n if KeysEqual(Bucket.Entries[I].Key, Key) then\r\n begin\r\n Result := True;\r\n Break;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclInt64Int64HashMap.ContainsValue(const Value: Int64): Boolean;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclInt64Int64HashMapBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n for J := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[J];\r\n if Bucket <> nil then\r\n for I := 0 to Bucket.Size - 1 do\r\n if ValuesEqual(Bucket.Entries[I].Value, Value) then\r\n begin\r\n Result := True;\r\n Break;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclInt64Int64HashMap.Extract(const Key: Int64): Int64;\r\nvar\r\n Bucket: TJclInt64Int64HashMapBucket;\r\n I, NewCapacity: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := 0;\r\n Bucket := FBuckets[FHashToRangeFunction(Hash(Key), FCapacity)];\r\n if Bucket <> nil then\r\n begin\r\n for I := 0 to Bucket.Size - 1 do\r\n if KeysEqual(Bucket.Entries[I].Key, Key) then\r\n begin\r\n Result := Bucket.Entries[I].Value;\r\n Bucket.Entries[I].Value := 0;\r\n FreeKey(Bucket.Entries[I].Key);\r\n if I < Length(Bucket.Entries) - 1 then\r\n Bucket.MoveArray(Bucket.Entries, I + 1, I, Bucket.Size - I - 1);\r\n Dec(Bucket.Size);\r\n Dec(FSize);\r\n Break;\r\n end;\r\n\r\n NewCapacity := CalcPackCapacity(Length(Bucket.Entries), Bucket.Size);\r\n if NewCapacity < Length(Bucket.Entries) then\r\n SetLength(Bucket.Entries, NewCapacity);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclInt64Int64HashMap.GetValue(const Key: Int64): Int64;\r\nvar\r\n I: Integer;\r\n Bucket: TJclInt64Int64HashMapBucket;\r\n Found: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Found := False;\r\n Result := 0;\r\n Bucket := FBuckets[FHashToRangeFunction(Hash(Key), FCapacity)];\r\n if Bucket <> nil then\r\n for I := 0 to Bucket.Size - 1 do\r\n if KeysEqual(Bucket.Entries[I].Key, Key) then\r\n begin\r\n Result := Bucket.Entries[I].Value;\r\n Found := True;\r\n Break;\r\n end;\r\n if (not Found) and (not FReturnDefaultElements) then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclInt64Int64HashMap.IsEmpty: Boolean;\r\nbegin\r\n Result := FSize = 0;\r\nend;\r\n\r\nfunction TJclInt64Int64HashMap.KeyOfValue(const Value: Int64): Int64;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclInt64Int64HashMapBucket;\r\n Found: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Found := False;\r\n Result := 0;\r\n for J := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[J];\r\n if Bucket <> nil then\r\n for I := 0 to Bucket.Size - 1 do\r\n if ValuesEqual(Bucket.Entries[I].Value, Value) then\r\n begin\r\n Result := Bucket.Entries[I].Key;\r\n Found := True;\r\n Break;\r\n end;\r\n end;\r\n if (not Found) and (not FReturnDefaultElements) then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclInt64Int64HashMap.KeySet: IJclInt64Set;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclInt64Int64HashMapBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := TJclInt64ArraySet.Create(FSize);\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n for J := 0 to Bucket.Size - 1 do\r\n Result.Add(Bucket.Entries[J].Key);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclInt64Int64HashMap.MapEquals(const AMap: IJclInt64Int64Map): Boolean;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclInt64Int64HashMapBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if AMap = nil then\r\n Exit;\r\n if FSize <> AMap.Size then\r\n Exit;\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n for J := 0 to Bucket.Size - 1 do\r\n if AMap.ContainsKey(Bucket.Entries[J].Key) then\r\n begin\r\n if not ValuesEqual(AMap.GetValue(Bucket.Entries[J].Key), Bucket.Entries[J].Value) then\r\n Exit;\r\n end\r\n else\r\n Exit;\r\n end;\r\n Result := True;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclInt64Int64HashMap.Pack;\r\nvar\r\n I: Integer;\r\n Bucket: TJclInt64Int64HashMapBucket;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n begin\r\n if Bucket.Size > 0 then\r\n SetLength(Bucket.Entries, Bucket.Size)\r\n else\r\n FreeAndNil(FBuckets[I]);\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclInt64Int64HashMap.PutAll(const AMap: IJclInt64Int64Map);\r\nvar\r\n It: IJclInt64Iterator;\r\n Key: Int64;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if AMap = nil then\r\n Exit;\r\n It := AMap.KeySet.First;\r\n while It.HasNext do\r\n begin\r\n Key := It.Next;\r\n PutValue(Key, AMap.GetValue(Key));\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclInt64Int64HashMap.PutValue(const Key: Int64; const Value: Int64);\r\nvar\r\n Index: Integer;\r\n Bucket: TJclInt64Int64HashMapBucket;\r\n I: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FAllowDefaultElements or (not KeysEqual(Key, 0) and not ValuesEqual(Value, 0)) then\r\n begin\r\n Index := FHashToRangeFunction(Hash(Key), FCapacity);\r\n Bucket := FBuckets[Index];\r\n if Bucket <> nil then\r\n begin\r\n for I := 0 to Bucket.Size - 1 do\r\n if KeysEqual(Bucket.Entries[I].Key, Key) then\r\n begin\r\n FreeValue(Bucket.Entries[I].Value);\r\n Bucket.Entries[I].Value := Value;\r\n Exit;\r\n end;\r\n end\r\n else\r\n begin\r\n Bucket := TJclInt64Int64HashMapBucket.Create;\r\n SetLength(Bucket.Entries, 1);\r\n FBuckets[Index] := Bucket;\r\n end;\r\n\r\n if Bucket.Size = Length(Bucket.Entries) then\r\n SetLength(Bucket.Entries, CalcGrowCapacity(Bucket.Size, Bucket.Size));\r\n\r\n if Bucket.Size < Length(Bucket.Entries) then\r\n begin\r\n Bucket.Entries[Bucket.Size].Key := Key;\r\n Bucket.Entries[Bucket.Size].Value := Value;\r\n Inc(Bucket.Size);\r\n Inc(FSize);\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclInt64Int64HashMap.Remove(const Key: Int64): Int64;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := Extract(Key);\r\n Result := FreeValue(Result);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclInt64Int64HashMap.SetCapacity(Value: Integer);\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FSize = 0 then\r\n begin\r\n SetLength(FBuckets, Value);\r\n inherited SetCapacity(Value);\r\n end\r\n else\r\n raise EJclOperationNotSupportedError.Create;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclInt64Int64HashMap.Size: Integer;\r\nbegin\r\n Result := FSize;\r\nend;\r\n\r\nfunction TJclInt64Int64HashMap.Values: IJclInt64Collection;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclInt64Int64HashMapBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := TJclInt64ArrayList.Create(FSize);\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n for J := 0 to Bucket.Size - 1 do\r\n Result.Add(Bucket.Entries[J].Value);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclInt64Int64HashMap.CreateEmptyContainer: TJclAbstractContainerBase;\r\nbegin\r\n Result := TJclInt64Int64HashMap.Create(FCapacity);\r\n AssignPropertiesTo(Result);\r\nend;\r\n\r\nfunction TJclInt64Int64HashMap.FreeKey(var Key: Int64): Int64;\r\nbegin\r\n Result := Key;\r\n Key := 0;\r\nend;\r\n\r\nfunction TJclInt64Int64HashMap.FreeValue(var Value: Int64): Int64;\r\nbegin\r\n Result := Value;\r\n Value := 0;\r\nend;\r\n\r\nfunction TJclInt64Int64HashMap.KeysEqual(const A, B: Int64): Boolean;\r\nbegin\r\n Result := ItemsEqual(A, B);\r\nend;\r\n\r\nfunction TJclInt64Int64HashMap.ValuesEqual(const A, B: Int64): Boolean;\r\nbegin\r\n Result := ItemsEqual(A, B);\r\nend;\r\n\r\n//=== { TJclPtrIntfHashMapBucket } ==========================================\r\n\r\nprocedure TJclPtrIntfHashMapBucket.FinalizeArrayBeforeMove(var List: TJclPtrIntfHashMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\nbegin\r\n Assert(Count > 0);\r\n if FromIndex < ToIndex then\r\n begin\r\n if Count > (ToIndex - FromIndex) then\r\n Finalize(List[FromIndex + Count], ToIndex - FromIndex)\r\n else\r\n Finalize(List[ToIndex], Count);\r\n end\r\n else\r\n if FromIndex > ToIndex then\r\n begin\r\n if Count > (FromIndex - ToIndex) then\r\n Count := FromIndex - ToIndex;\r\n Finalize(List[ToIndex], Count)\r\n end;\r\nend;\r\n\r\nprocedure TJclPtrIntfHashMapBucket.InitializeArray(var List: TJclPtrIntfHashMapEntryArray; FromIndex, Count: SizeInt);\r\nbegin\r\n {$IFDEF FPC}\r\n while Count > 0 do\r\n begin\r\n Initialize(List[FromIndex]);\r\n Inc(FromIndex);\r\n Dec(Count);\r\n end;\r\n {$ELSE ~FPC}\r\n Initialize(List[FromIndex], Count);\r\n {$ENDIF ~FPC}\r\nend;\r\n\r\nprocedure TJclPtrIntfHashMapBucket.InitializeArrayAfterMove(var List: TJclPtrIntfHashMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\nbegin\r\n { Keep reference counting working }\r\n if FromIndex < ToIndex then\r\n begin\r\n if (ToIndex - FromIndex) < Count then\r\n Count := ToIndex - FromIndex;\r\n InitializeArray(List, FromIndex, Count);\r\n end\r\n else\r\n if FromIndex > ToIndex then\r\n begin\r\n if (FromIndex - ToIndex) < Count then\r\n InitializeArray(List, ToIndex + Count, FromIndex - ToIndex)\r\n else\r\n InitializeArray(List, FromIndex, Count);\r\n end;\r\nend;\r\n\r\nprocedure TJclPtrIntfHashMapBucket.MoveArray(var List: TJclPtrIntfHashMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\nbegin\r\n if Count > 0 then\r\n begin\r\n FinalizeArrayBeforeMove(List, FromIndex, ToIndex, Count);\r\n Move(List[FromIndex], List[ToIndex], Count * SizeOf(List[0]));\r\n InitializeArrayAfterMove(List, FromIndex, ToIndex, Count);\r\n end;\r\nend;\r\n\r\n//=== { TJclPtrIntfHashMap } ==========================================\r\n\r\nconstructor TJclPtrIntfHashMap.Create(ACapacity: Integer);\r\nbegin\r\n inherited Create;\r\n SetCapacity(ACapacity);\r\n FHashToRangeFunction := JclSimpleHashToRange;\r\nend;\r\n\r\ndestructor TJclPtrIntfHashMap.Destroy;\r\nbegin\r\n FReadOnly := False;\r\n Clear;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJclPtrIntfHashMap.AssignDataTo(Dest: TJclAbstractContainerBase);\r\nvar\r\n I, J: Integer;\r\n SelfBucket, NewBucket: TJclPtrIntfHashMapBucket;\r\n ADest: TJclPtrIntfHashMap;\r\n AMap: IJclPtrIntfMap;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n inherited AssignDataTo(Dest);\r\n if Dest is TJclPtrIntfHashMap then\r\n begin\r\n ADest := TJclPtrIntfHashMap(Dest);\r\n ADest.Clear;\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n SelfBucket := FBuckets[I];\r\n if SelfBucket <> nil then\r\n begin\r\n NewBucket := TJclPtrIntfHashMapBucket.Create;\r\n SetLength(NewBucket.Entries, SelfBucket.Size);\r\n for J := 0 to SelfBucket.Size - 1 do\r\n begin\r\n NewBucket.Entries[J].Key := SelfBucket.Entries[J].Key;\r\n NewBucket.Entries[J].Value := SelfBucket.Entries[J].Value;\r\n end;\r\n NewBucket.Size := SelfBucket.Size;\r\n ADest.FBuckets[I] := NewBucket;\r\n end;\r\n end;\r\n end\r\n else\r\n if Supports(IInterface(Dest), IJclPtrIntfMap, AMap) then\r\n begin\r\n AMap.Clear;\r\n AMap.PutAll(Self);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclPtrIntfHashMap.AssignPropertiesTo(Dest: TJclAbstractContainerBase);\r\nbegin\r\n inherited AssignPropertiesto(Dest);\r\n if Dest is TJclPtrIntfHashMap then\r\n TJclPtrIntfHashMap(Dest).FHashToRangeFunction := FHashToRangeFunction;\r\nend;\r\n\r\nprocedure TJclPtrIntfHashMap.Clear;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclPtrIntfHashMapBucket;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n begin\r\n for J := 0 to Bucket.Size - 1 do\r\n begin\r\n FreeKey(Bucket.Entries[J].Key);\r\n FreeValue(Bucket.Entries[J].Value);\r\n end;\r\n FreeAndNil(FBuckets[I]);\r\n end;\r\n end;\r\n FSize := 0;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclPtrIntfHashMap.ContainsKey(Key: Pointer): Boolean;\r\nvar\r\n I: Integer;\r\n Bucket: TJclPtrIntfHashMapBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n Bucket := FBuckets[FHashToRangeFunction(Hash(Key), FCapacity)];\r\n if Bucket <> nil then\r\n for I := 0 to Bucket.Size - 1 do\r\n if KeysEqual(Bucket.Entries[I].Key, Key) then\r\n begin\r\n Result := True;\r\n Break;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclPtrIntfHashMap.ContainsValue(const Value: IInterface): Boolean;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclPtrIntfHashMapBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n for J := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[J];\r\n if Bucket <> nil then\r\n for I := 0 to Bucket.Size - 1 do\r\n if ValuesEqual(Bucket.Entries[I].Value, Value) then\r\n begin\r\n Result := True;\r\n Break;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclPtrIntfHashMap.Extract(Key: Pointer): IInterface;\r\nvar\r\n Bucket: TJclPtrIntfHashMapBucket;\r\n I, NewCapacity: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := nil;\r\n Bucket := FBuckets[FHashToRangeFunction(Hash(Key), FCapacity)];\r\n if Bucket <> nil then\r\n begin\r\n for I := 0 to Bucket.Size - 1 do\r\n if KeysEqual(Bucket.Entries[I].Key, Key) then\r\n begin\r\n Result := Bucket.Entries[I].Value;\r\n Bucket.Entries[I].Value := nil;\r\n FreeKey(Bucket.Entries[I].Key);\r\n if I < Length(Bucket.Entries) - 1 then\r\n Bucket.MoveArray(Bucket.Entries, I + 1, I, Bucket.Size - I - 1);\r\n Dec(Bucket.Size);\r\n Dec(FSize);\r\n Break;\r\n end;\r\n\r\n NewCapacity := CalcPackCapacity(Length(Bucket.Entries), Bucket.Size);\r\n if NewCapacity < Length(Bucket.Entries) then\r\n SetLength(Bucket.Entries, NewCapacity);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclPtrIntfHashMap.GetValue(Key: Pointer): IInterface;\r\nvar\r\n I: Integer;\r\n Bucket: TJclPtrIntfHashMapBucket;\r\n Found: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Found := False;\r\n Result := nil;\r\n Bucket := FBuckets[FHashToRangeFunction(Hash(Key), FCapacity)];\r\n if Bucket <> nil then\r\n for I := 0 to Bucket.Size - 1 do\r\n if KeysEqual(Bucket.Entries[I].Key, Key) then\r\n begin\r\n Result := Bucket.Entries[I].Value;\r\n Found := True;\r\n Break;\r\n end;\r\n if (not Found) and (not FReturnDefaultElements) then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclPtrIntfHashMap.IsEmpty: Boolean;\r\nbegin\r\n Result := FSize = 0;\r\nend;\r\n\r\nfunction TJclPtrIntfHashMap.KeyOfValue(const Value: IInterface): Pointer;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclPtrIntfHashMapBucket;\r\n Found: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Found := False;\r\n Result := nil;\r\n for J := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[J];\r\n if Bucket <> nil then\r\n for I := 0 to Bucket.Size - 1 do\r\n if ValuesEqual(Bucket.Entries[I].Value, Value) then\r\n begin\r\n Result := Bucket.Entries[I].Key;\r\n Found := True;\r\n Break;\r\n end;\r\n end;\r\n if (not Found) and (not FReturnDefaultElements) then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclPtrIntfHashMap.KeySet: IJclPtrSet;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclPtrIntfHashMapBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := TJclPtrArraySet.Create(FSize);\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n for J := 0 to Bucket.Size - 1 do\r\n Result.Add(Bucket.Entries[J].Key);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclPtrIntfHashMap.MapEquals(const AMap: IJclPtrIntfMap): Boolean;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclPtrIntfHashMapBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if AMap = nil then\r\n Exit;\r\n if FSize <> AMap.Size then\r\n Exit;\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n for J := 0 to Bucket.Size - 1 do\r\n if AMap.ContainsKey(Bucket.Entries[J].Key) then\r\n begin\r\n if not ValuesEqual(AMap.GetValue(Bucket.Entries[J].Key), Bucket.Entries[J].Value) then\r\n Exit;\r\n end\r\n else\r\n Exit;\r\n end;\r\n Result := True;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclPtrIntfHashMap.Pack;\r\nvar\r\n I: Integer;\r\n Bucket: TJclPtrIntfHashMapBucket;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n begin\r\n if Bucket.Size > 0 then\r\n SetLength(Bucket.Entries, Bucket.Size)\r\n else\r\n FreeAndNil(FBuckets[I]);\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclPtrIntfHashMap.PutAll(const AMap: IJclPtrIntfMap);\r\nvar\r\n It: IJclPtrIterator;\r\n Key: Pointer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if AMap = nil then\r\n Exit;\r\n It := AMap.KeySet.First;\r\n while It.HasNext do\r\n begin\r\n Key := It.Next;\r\n PutValue(Key, AMap.GetValue(Key));\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclPtrIntfHashMap.PutValue(Key: Pointer; const Value: IInterface);\r\nvar\r\n Index: Integer;\r\n Bucket: TJclPtrIntfHashMapBucket;\r\n I: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FAllowDefaultElements or (not KeysEqual(Key, nil) and not ValuesEqual(Value, nil)) then\r\n begin\r\n Index := FHashToRangeFunction(Hash(Key), FCapacity);\r\n Bucket := FBuckets[Index];\r\n if Bucket <> nil then\r\n begin\r\n for I := 0 to Bucket.Size - 1 do\r\n if KeysEqual(Bucket.Entries[I].Key, Key) then\r\n begin\r\n FreeValue(Bucket.Entries[I].Value);\r\n Bucket.Entries[I].Value := Value;\r\n Exit;\r\n end;\r\n end\r\n else\r\n begin\r\n Bucket := TJclPtrIntfHashMapBucket.Create;\r\n SetLength(Bucket.Entries, 1);\r\n FBuckets[Index] := Bucket;\r\n end;\r\n\r\n if Bucket.Size = Length(Bucket.Entries) then\r\n SetLength(Bucket.Entries, CalcGrowCapacity(Bucket.Size, Bucket.Size));\r\n\r\n if Bucket.Size < Length(Bucket.Entries) then\r\n begin\r\n Bucket.Entries[Bucket.Size].Key := Key;\r\n Bucket.Entries[Bucket.Size].Value := Value;\r\n Inc(Bucket.Size);\r\n Inc(FSize);\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclPtrIntfHashMap.Remove(Key: Pointer): IInterface;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := Extract(Key);\r\n Result := FreeValue(Result);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclPtrIntfHashMap.SetCapacity(Value: Integer);\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FSize = 0 then\r\n begin\r\n SetLength(FBuckets, Value);\r\n inherited SetCapacity(Value);\r\n end\r\n else\r\n raise EJclOperationNotSupportedError.Create;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclPtrIntfHashMap.Size: Integer;\r\nbegin\r\n Result := FSize;\r\nend;\r\n\r\nfunction TJclPtrIntfHashMap.Values: IJclIntfCollection;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclPtrIntfHashMapBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := TJclIntfArrayList.Create(FSize);\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n for J := 0 to Bucket.Size - 1 do\r\n Result.Add(Bucket.Entries[J].Value);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclPtrIntfHashMap.CreateEmptyContainer: TJclAbstractContainerBase;\r\nbegin\r\n Result := TJclPtrIntfHashMap.Create(FCapacity);\r\n AssignPropertiesTo(Result);\r\nend;\r\n\r\nfunction TJclPtrIntfHashMap.FreeKey(var Key: Pointer): Pointer;\r\nbegin\r\n Result := Key;\r\n Key := nil;\r\nend;\r\n\r\nfunction TJclPtrIntfHashMap.FreeValue(var Value: IInterface): IInterface;\r\nbegin\r\n Result := Value;\r\n Value := nil;\r\nend;\r\n\r\nfunction TJclPtrIntfHashMap.KeysEqual(A, B: Pointer): Boolean;\r\nbegin\r\n Result := ItemsEqual(A, B);\r\nend;\r\n\r\nfunction TJclPtrIntfHashMap.ValuesEqual(const A, B: IInterface): Boolean;\r\nbegin\r\n Result := IntfSimpleEqualityCompare(A, B);\r\nend;\r\n\r\n//=== { TJclIntfPtrHashMapBucket } ==========================================\r\n\r\nprocedure TJclIntfPtrHashMapBucket.FinalizeArrayBeforeMove(var List: TJclIntfPtrHashMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\nbegin\r\n Assert(Count > 0);\r\n if FromIndex < ToIndex then\r\n begin\r\n if Count > (ToIndex - FromIndex) then\r\n Finalize(List[FromIndex + Count], ToIndex - FromIndex)\r\n else\r\n Finalize(List[ToIndex], Count);\r\n end\r\n else\r\n if FromIndex > ToIndex then\r\n begin\r\n if Count > (FromIndex - ToIndex) then\r\n Count := FromIndex - ToIndex;\r\n Finalize(List[ToIndex], Count)\r\n end;\r\nend;\r\n\r\nprocedure TJclIntfPtrHashMapBucket.InitializeArray(var List: TJclIntfPtrHashMapEntryArray; FromIndex, Count: SizeInt);\r\nbegin\r\n {$IFDEF FPC}\r\n while Count > 0 do\r\n begin\r\n Initialize(List[FromIndex]);\r\n Inc(FromIndex);\r\n Dec(Count);\r\n end;\r\n {$ELSE ~FPC}\r\n Initialize(List[FromIndex], Count);\r\n {$ENDIF ~FPC}\r\nend;\r\n\r\nprocedure TJclIntfPtrHashMapBucket.InitializeArrayAfterMove(var List: TJclIntfPtrHashMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\nbegin\r\n { Keep reference counting working }\r\n if FromIndex < ToIndex then\r\n begin\r\n if (ToIndex - FromIndex) < Count then\r\n Count := ToIndex - FromIndex;\r\n InitializeArray(List, FromIndex, Count);\r\n end\r\n else\r\n if FromIndex > ToIndex then\r\n begin\r\n if (FromIndex - ToIndex) < Count then\r\n InitializeArray(List, ToIndex + Count, FromIndex - ToIndex)\r\n else\r\n InitializeArray(List, FromIndex, Count);\r\n end;\r\nend;\r\n\r\nprocedure TJclIntfPtrHashMapBucket.MoveArray(var List: TJclIntfPtrHashMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\nbegin\r\n if Count > 0 then\r\n begin\r\n FinalizeArrayBeforeMove(List, FromIndex, ToIndex, Count);\r\n Move(List[FromIndex], List[ToIndex], Count * SizeOf(List[0]));\r\n InitializeArrayAfterMove(List, FromIndex, ToIndex, Count);\r\n end;\r\nend;\r\n\r\n//=== { TJclIntfPtrHashMap } ==========================================\r\n\r\nconstructor TJclIntfPtrHashMap.Create(ACapacity: Integer);\r\nbegin\r\n inherited Create;\r\n SetCapacity(ACapacity);\r\n FHashToRangeFunction := JclSimpleHashToRange;\r\nend;\r\n\r\ndestructor TJclIntfPtrHashMap.Destroy;\r\nbegin\r\n FReadOnly := False;\r\n Clear;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJclIntfPtrHashMap.AssignDataTo(Dest: TJclAbstractContainerBase);\r\nvar\r\n I, J: Integer;\r\n SelfBucket, NewBucket: TJclIntfPtrHashMapBucket;\r\n ADest: TJclIntfPtrHashMap;\r\n AMap: IJclIntfPtrMap;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n inherited AssignDataTo(Dest);\r\n if Dest is TJclIntfPtrHashMap then\r\n begin\r\n ADest := TJclIntfPtrHashMap(Dest);\r\n ADest.Clear;\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n SelfBucket := FBuckets[I];\r\n if SelfBucket <> nil then\r\n begin\r\n NewBucket := TJclIntfPtrHashMapBucket.Create;\r\n SetLength(NewBucket.Entries, SelfBucket.Size);\r\n for J := 0 to SelfBucket.Size - 1 do\r\n begin\r\n NewBucket.Entries[J].Key := SelfBucket.Entries[J].Key;\r\n NewBucket.Entries[J].Value := SelfBucket.Entries[J].Value;\r\n end;\r\n NewBucket.Size := SelfBucket.Size;\r\n ADest.FBuckets[I] := NewBucket;\r\n end;\r\n end;\r\n end\r\n else\r\n if Supports(IInterface(Dest), IJclIntfPtrMap, AMap) then\r\n begin\r\n AMap.Clear;\r\n AMap.PutAll(Self);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclIntfPtrHashMap.AssignPropertiesTo(Dest: TJclAbstractContainerBase);\r\nbegin\r\n inherited AssignPropertiesto(Dest);\r\n if Dest is TJclIntfPtrHashMap then\r\n TJclIntfPtrHashMap(Dest).FHashToRangeFunction := FHashToRangeFunction;\r\nend;\r\n\r\nprocedure TJclIntfPtrHashMap.Clear;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclIntfPtrHashMapBucket;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n begin\r\n for J := 0 to Bucket.Size - 1 do\r\n begin\r\n FreeKey(Bucket.Entries[J].Key);\r\n FreeValue(Bucket.Entries[J].Value);\r\n end;\r\n FreeAndNil(FBuckets[I]);\r\n end;\r\n end;\r\n FSize := 0;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfPtrHashMap.ContainsKey(const Key: IInterface): Boolean;\r\nvar\r\n I: Integer;\r\n Bucket: TJclIntfPtrHashMapBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n Bucket := FBuckets[FHashToRangeFunction(Hash(Key), FCapacity)];\r\n if Bucket <> nil then\r\n for I := 0 to Bucket.Size - 1 do\r\n if KeysEqual(Bucket.Entries[I].Key, Key) then\r\n begin\r\n Result := True;\r\n Break;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfPtrHashMap.ContainsValue(Value: Pointer): Boolean;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclIntfPtrHashMapBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n for J := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[J];\r\n if Bucket <> nil then\r\n for I := 0 to Bucket.Size - 1 do\r\n if ValuesEqual(Bucket.Entries[I].Value, Value) then\r\n begin\r\n Result := True;\r\n Break;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfPtrHashMap.Extract(const Key: IInterface): Pointer;\r\nvar\r\n Bucket: TJclIntfPtrHashMapBucket;\r\n I, NewCapacity: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := nil;\r\n Bucket := FBuckets[FHashToRangeFunction(Hash(Key), FCapacity)];\r\n if Bucket <> nil then\r\n begin\r\n for I := 0 to Bucket.Size - 1 do\r\n if KeysEqual(Bucket.Entries[I].Key, Key) then\r\n begin\r\n Result := Bucket.Entries[I].Value;\r\n Bucket.Entries[I].Value := nil;\r\n FreeKey(Bucket.Entries[I].Key);\r\n if I < Length(Bucket.Entries) - 1 then\r\n Bucket.MoveArray(Bucket.Entries, I + 1, I, Bucket.Size - I - 1);\r\n Dec(Bucket.Size);\r\n Dec(FSize);\r\n Break;\r\n end;\r\n\r\n NewCapacity := CalcPackCapacity(Length(Bucket.Entries), Bucket.Size);\r\n if NewCapacity < Length(Bucket.Entries) then\r\n SetLength(Bucket.Entries, NewCapacity);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfPtrHashMap.GetValue(const Key: IInterface): Pointer;\r\nvar\r\n I: Integer;\r\n Bucket: TJclIntfPtrHashMapBucket;\r\n Found: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Found := False;\r\n Result := nil;\r\n Bucket := FBuckets[FHashToRangeFunction(Hash(Key), FCapacity)];\r\n if Bucket <> nil then\r\n for I := 0 to Bucket.Size - 1 do\r\n if KeysEqual(Bucket.Entries[I].Key, Key) then\r\n begin\r\n Result := Bucket.Entries[I].Value;\r\n Found := True;\r\n Break;\r\n end;\r\n if (not Found) and (not FReturnDefaultElements) then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfPtrHashMap.IsEmpty: Boolean;\r\nbegin\r\n Result := FSize = 0;\r\nend;\r\n\r\nfunction TJclIntfPtrHashMap.KeyOfValue(Value: Pointer): IInterface;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclIntfPtrHashMapBucket;\r\n Found: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Found := False;\r\n Result := nil;\r\n for J := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[J];\r\n if Bucket <> nil then\r\n for I := 0 to Bucket.Size - 1 do\r\n if ValuesEqual(Bucket.Entries[I].Value, Value) then\r\n begin\r\n Result := Bucket.Entries[I].Key;\r\n Found := True;\r\n Break;\r\n end;\r\n end;\r\n if (not Found) and (not FReturnDefaultElements) then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfPtrHashMap.KeySet: IJclIntfSet;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclIntfPtrHashMapBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := TJclIntfArraySet.Create(FSize);\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n for J := 0 to Bucket.Size - 1 do\r\n Result.Add(Bucket.Entries[J].Key);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfPtrHashMap.MapEquals(const AMap: IJclIntfPtrMap): Boolean;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclIntfPtrHashMapBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if AMap = nil then\r\n Exit;\r\n if FSize <> AMap.Size then\r\n Exit;\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n for J := 0 to Bucket.Size - 1 do\r\n if AMap.ContainsKey(Bucket.Entries[J].Key) then\r\n begin\r\n if not ValuesEqual(AMap.GetValue(Bucket.Entries[J].Key), Bucket.Entries[J].Value) then\r\n Exit;\r\n end\r\n else\r\n Exit;\r\n end;\r\n Result := True;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclIntfPtrHashMap.Pack;\r\nvar\r\n I: Integer;\r\n Bucket: TJclIntfPtrHashMapBucket;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n begin\r\n if Bucket.Size > 0 then\r\n SetLength(Bucket.Entries, Bucket.Size)\r\n else\r\n FreeAndNil(FBuckets[I]);\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclIntfPtrHashMap.PutAll(const AMap: IJclIntfPtrMap);\r\nvar\r\n It: IJclIntfIterator;\r\n Key: IInterface;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if AMap = nil then\r\n Exit;\r\n It := AMap.KeySet.First;\r\n while It.HasNext do\r\n begin\r\n Key := It.Next;\r\n PutValue(Key, AMap.GetValue(Key));\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclIntfPtrHashMap.PutValue(const Key: IInterface; Value: Pointer);\r\nvar\r\n Index: Integer;\r\n Bucket: TJclIntfPtrHashMapBucket;\r\n I: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FAllowDefaultElements or (not KeysEqual(Key, nil) and not ValuesEqual(Value, nil)) then\r\n begin\r\n Index := FHashToRangeFunction(Hash(Key), FCapacity);\r\n Bucket := FBuckets[Index];\r\n if Bucket <> nil then\r\n begin\r\n for I := 0 to Bucket.Size - 1 do\r\n if KeysEqual(Bucket.Entries[I].Key, Key) then\r\n begin\r\n FreeValue(Bucket.Entries[I].Value);\r\n Bucket.Entries[I].Value := Value;\r\n Exit;\r\n end;\r\n end\r\n else\r\n begin\r\n Bucket := TJclIntfPtrHashMapBucket.Create;\r\n SetLength(Bucket.Entries, 1);\r\n FBuckets[Index] := Bucket;\r\n end;\r\n\r\n if Bucket.Size = Length(Bucket.Entries) then\r\n SetLength(Bucket.Entries, CalcGrowCapacity(Bucket.Size, Bucket.Size));\r\n\r\n if Bucket.Size < Length(Bucket.Entries) then\r\n begin\r\n Bucket.Entries[Bucket.Size].Key := Key;\r\n Bucket.Entries[Bucket.Size].Value := Value;\r\n Inc(Bucket.Size);\r\n Inc(FSize);\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfPtrHashMap.Remove(const Key: IInterface): Pointer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := Extract(Key);\r\n Result := FreeValue(Result);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclIntfPtrHashMap.SetCapacity(Value: Integer);\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FSize = 0 then\r\n begin\r\n SetLength(FBuckets, Value);\r\n inherited SetCapacity(Value);\r\n end\r\n else\r\n raise EJclOperationNotSupportedError.Create;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfPtrHashMap.Size: Integer;\r\nbegin\r\n Result := FSize;\r\nend;\r\n\r\nfunction TJclIntfPtrHashMap.Values: IJclPtrCollection;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclIntfPtrHashMapBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := TJclPtrArrayList.Create(FSize);\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n for J := 0 to Bucket.Size - 1 do\r\n Result.Add(Bucket.Entries[J].Value);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfPtrHashMap.CreateEmptyContainer: TJclAbstractContainerBase;\r\nbegin\r\n Result := TJclIntfPtrHashMap.Create(FCapacity);\r\n AssignPropertiesTo(Result);\r\nend;\r\n\r\nfunction TJclIntfPtrHashMap.FreeKey(var Key: IInterface): IInterface;\r\nbegin\r\n Result := Key;\r\n Key := nil;\r\nend;\r\n\r\nfunction TJclIntfPtrHashMap.FreeValue(var Value: Pointer): Pointer;\r\nbegin\r\n Result := Value;\r\n Value := nil;\r\nend;\r\n\r\nfunction TJclIntfPtrHashMap.Hash(const AInterface: IInterface): Integer;\r\nbegin\r\n Result := IntfSimpleHashConvert(AInterface);\r\nend;\r\n\r\nfunction TJclIntfPtrHashMap.KeysEqual(const A, B: IInterface): Boolean;\r\nbegin\r\n Result := IntfSimpleEqualityCompare(A, B);\r\nend;\r\n\r\nfunction TJclIntfPtrHashMap.ValuesEqual(A, B: Pointer): Boolean;\r\nbegin\r\n Result := ItemsEqual(A, B);\r\nend;\r\n\r\n//=== { TJclPtrPtrHashMapBucket } ==========================================\r\n\r\nprocedure TJclPtrPtrHashMapBucket.InitializeArrayAfterMove(var List: TJclPtrPtrHashMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\nbegin\r\n { Clean array }\r\n if FromIndex < ToIndex then\r\n begin\r\n if (ToIndex - FromIndex) < Count then\r\n Count := ToIndex - FromIndex;\r\n FillChar(List[FromIndex], Count * SizeOf(List[0]), 0);\r\n end\r\n else\r\n if FromIndex > ToIndex then\r\n begin\r\n if (FromIndex - ToIndex) < Count then\r\n FillChar(List[ToIndex + Count], (FromIndex - ToIndex) * SizeOf(List[0]), 0)\r\n else\r\n FillChar(List[FromIndex], Count * SizeOf(List[0]), 0);\r\n end;\r\nend;\r\n\r\nprocedure TJclPtrPtrHashMapBucket.MoveArray(var List: TJclPtrPtrHashMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\nbegin\r\n if Count > 0 then\r\n begin\r\n Move(List[FromIndex], List[ToIndex], Count * SizeOf(List[0]));\r\n InitializeArrayAfterMove(List, FromIndex, ToIndex, Count);\r\n end;\r\nend;\r\n\r\n//=== { TJclPtrPtrHashMap } ==========================================\r\n\r\nconstructor TJclPtrPtrHashMap.Create(ACapacity: Integer);\r\nbegin\r\n inherited Create;\r\n SetCapacity(ACapacity);\r\n FHashToRangeFunction := JclSimpleHashToRange;\r\nend;\r\n\r\ndestructor TJclPtrPtrHashMap.Destroy;\r\nbegin\r\n FReadOnly := False;\r\n Clear;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJclPtrPtrHashMap.AssignDataTo(Dest: TJclAbstractContainerBase);\r\nvar\r\n I, J: Integer;\r\n SelfBucket, NewBucket: TJclPtrPtrHashMapBucket;\r\n ADest: TJclPtrPtrHashMap;\r\n AMap: IJclPtrPtrMap;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n inherited AssignDataTo(Dest);\r\n if Dest is TJclPtrPtrHashMap then\r\n begin\r\n ADest := TJclPtrPtrHashMap(Dest);\r\n ADest.Clear;\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n SelfBucket := FBuckets[I];\r\n if SelfBucket <> nil then\r\n begin\r\n NewBucket := TJclPtrPtrHashMapBucket.Create;\r\n SetLength(NewBucket.Entries, SelfBucket.Size);\r\n for J := 0 to SelfBucket.Size - 1 do\r\n begin\r\n NewBucket.Entries[J].Key := SelfBucket.Entries[J].Key;\r\n NewBucket.Entries[J].Value := SelfBucket.Entries[J].Value;\r\n end;\r\n NewBucket.Size := SelfBucket.Size;\r\n ADest.FBuckets[I] := NewBucket;\r\n end;\r\n end;\r\n end\r\n else\r\n if Supports(IInterface(Dest), IJclPtrPtrMap, AMap) then\r\n begin\r\n AMap.Clear;\r\n AMap.PutAll(Self);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclPtrPtrHashMap.AssignPropertiesTo(Dest: TJclAbstractContainerBase);\r\nbegin\r\n inherited AssignPropertiesto(Dest);\r\n if Dest is TJclPtrPtrHashMap then\r\n TJclPtrPtrHashMap(Dest).FHashToRangeFunction := FHashToRangeFunction;\r\nend;\r\n\r\nprocedure TJclPtrPtrHashMap.Clear;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclPtrPtrHashMapBucket;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n begin\r\n for J := 0 to Bucket.Size - 1 do\r\n begin\r\n FreeKey(Bucket.Entries[J].Key);\r\n FreeValue(Bucket.Entries[J].Value);\r\n end;\r\n FreeAndNil(FBuckets[I]);\r\n end;\r\n end;\r\n FSize := 0;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclPtrPtrHashMap.ContainsKey(Key: Pointer): Boolean;\r\nvar\r\n I: Integer;\r\n Bucket: TJclPtrPtrHashMapBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n Bucket := FBuckets[FHashToRangeFunction(Hash(Key), FCapacity)];\r\n if Bucket <> nil then\r\n for I := 0 to Bucket.Size - 1 do\r\n if KeysEqual(Bucket.Entries[I].Key, Key) then\r\n begin\r\n Result := True;\r\n Break;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclPtrPtrHashMap.ContainsValue(Value: Pointer): Boolean;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclPtrPtrHashMapBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n for J := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[J];\r\n if Bucket <> nil then\r\n for I := 0 to Bucket.Size - 1 do\r\n if ValuesEqual(Bucket.Entries[I].Value, Value) then\r\n begin\r\n Result := True;\r\n Break;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclPtrPtrHashMap.Extract(Key: Pointer): Pointer;\r\nvar\r\n Bucket: TJclPtrPtrHashMapBucket;\r\n I, NewCapacity: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := nil;\r\n Bucket := FBuckets[FHashToRangeFunction(Hash(Key), FCapacity)];\r\n if Bucket <> nil then\r\n begin\r\n for I := 0 to Bucket.Size - 1 do\r\n if KeysEqual(Bucket.Entries[I].Key, Key) then\r\n begin\r\n Result := Bucket.Entries[I].Value;\r\n Bucket.Entries[I].Value := nil;\r\n FreeKey(Bucket.Entries[I].Key);\r\n if I < Length(Bucket.Entries) - 1 then\r\n Bucket.MoveArray(Bucket.Entries, I + 1, I, Bucket.Size - I - 1);\r\n Dec(Bucket.Size);\r\n Dec(FSize);\r\n Break;\r\n end;\r\n\r\n NewCapacity := CalcPackCapacity(Length(Bucket.Entries), Bucket.Size);\r\n if NewCapacity < Length(Bucket.Entries) then\r\n SetLength(Bucket.Entries, NewCapacity);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclPtrPtrHashMap.GetValue(Key: Pointer): Pointer;\r\nvar\r\n I: Integer;\r\n Bucket: TJclPtrPtrHashMapBucket;\r\n Found: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Found := False;\r\n Result := nil;\r\n Bucket := FBuckets[FHashToRangeFunction(Hash(Key), FCapacity)];\r\n if Bucket <> nil then\r\n for I := 0 to Bucket.Size - 1 do\r\n if KeysEqual(Bucket.Entries[I].Key, Key) then\r\n begin\r\n Result := Bucket.Entries[I].Value;\r\n Found := True;\r\n Break;\r\n end;\r\n if (not Found) and (not FReturnDefaultElements) then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclPtrPtrHashMap.IsEmpty: Boolean;\r\nbegin\r\n Result := FSize = 0;\r\nend;\r\n\r\nfunction TJclPtrPtrHashMap.KeyOfValue(Value: Pointer): Pointer;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclPtrPtrHashMapBucket;\r\n Found: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Found := False;\r\n Result := nil;\r\n for J := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[J];\r\n if Bucket <> nil then\r\n for I := 0 to Bucket.Size - 1 do\r\n if ValuesEqual(Bucket.Entries[I].Value, Value) then\r\n begin\r\n Result := Bucket.Entries[I].Key;\r\n Found := True;\r\n Break;\r\n end;\r\n end;\r\n if (not Found) and (not FReturnDefaultElements) then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclPtrPtrHashMap.KeySet: IJclPtrSet;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclPtrPtrHashMapBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := TJclPtrArraySet.Create(FSize);\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n for J := 0 to Bucket.Size - 1 do\r\n Result.Add(Bucket.Entries[J].Key);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclPtrPtrHashMap.MapEquals(const AMap: IJclPtrPtrMap): Boolean;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclPtrPtrHashMapBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if AMap = nil then\r\n Exit;\r\n if FSize <> AMap.Size then\r\n Exit;\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n for J := 0 to Bucket.Size - 1 do\r\n if AMap.ContainsKey(Bucket.Entries[J].Key) then\r\n begin\r\n if not ValuesEqual(AMap.GetValue(Bucket.Entries[J].Key), Bucket.Entries[J].Value) then\r\n Exit;\r\n end\r\n else\r\n Exit;\r\n end;\r\n Result := True;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclPtrPtrHashMap.Pack;\r\nvar\r\n I: Integer;\r\n Bucket: TJclPtrPtrHashMapBucket;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n begin\r\n if Bucket.Size > 0 then\r\n SetLength(Bucket.Entries, Bucket.Size)\r\n else\r\n FreeAndNil(FBuckets[I]);\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclPtrPtrHashMap.PutAll(const AMap: IJclPtrPtrMap);\r\nvar\r\n It: IJclPtrIterator;\r\n Key: Pointer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if AMap = nil then\r\n Exit;\r\n It := AMap.KeySet.First;\r\n while It.HasNext do\r\n begin\r\n Key := It.Next;\r\n PutValue(Key, AMap.GetValue(Key));\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclPtrPtrHashMap.PutValue(Key: Pointer; Value: Pointer);\r\nvar\r\n Index: Integer;\r\n Bucket: TJclPtrPtrHashMapBucket;\r\n I: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FAllowDefaultElements or (not KeysEqual(Key, nil) and not ValuesEqual(Value, nil)) then\r\n begin\r\n Index := FHashToRangeFunction(Hash(Key), FCapacity);\r\n Bucket := FBuckets[Index];\r\n if Bucket <> nil then\r\n begin\r\n for I := 0 to Bucket.Size - 1 do\r\n if KeysEqual(Bucket.Entries[I].Key, Key) then\r\n begin\r\n FreeValue(Bucket.Entries[I].Value);\r\n Bucket.Entries[I].Value := Value;\r\n Exit;\r\n end;\r\n end\r\n else\r\n begin\r\n Bucket := TJclPtrPtrHashMapBucket.Create;\r\n SetLength(Bucket.Entries, 1);\r\n FBuckets[Index] := Bucket;\r\n end;\r\n\r\n if Bucket.Size = Length(Bucket.Entries) then\r\n SetLength(Bucket.Entries, CalcGrowCapacity(Bucket.Size, Bucket.Size));\r\n\r\n if Bucket.Size < Length(Bucket.Entries) then\r\n begin\r\n Bucket.Entries[Bucket.Size].Key := Key;\r\n Bucket.Entries[Bucket.Size].Value := Value;\r\n Inc(Bucket.Size);\r\n Inc(FSize);\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclPtrPtrHashMap.Remove(Key: Pointer): Pointer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := Extract(Key);\r\n Result := FreeValue(Result);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclPtrPtrHashMap.SetCapacity(Value: Integer);\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FSize = 0 then\r\n begin\r\n SetLength(FBuckets, Value);\r\n inherited SetCapacity(Value);\r\n end\r\n else\r\n raise EJclOperationNotSupportedError.Create;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclPtrPtrHashMap.Size: Integer;\r\nbegin\r\n Result := FSize;\r\nend;\r\n\r\nfunction TJclPtrPtrHashMap.Values: IJclPtrCollection;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclPtrPtrHashMapBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := TJclPtrArrayList.Create(FSize);\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n for J := 0 to Bucket.Size - 1 do\r\n Result.Add(Bucket.Entries[J].Value);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclPtrPtrHashMap.CreateEmptyContainer: TJclAbstractContainerBase;\r\nbegin\r\n Result := TJclPtrPtrHashMap.Create(FCapacity);\r\n AssignPropertiesTo(Result);\r\nend;\r\n\r\nfunction TJclPtrPtrHashMap.FreeKey(var Key: Pointer): Pointer;\r\nbegin\r\n Result := Key;\r\n Key := nil;\r\nend;\r\n\r\nfunction TJclPtrPtrHashMap.FreeValue(var Value: Pointer): Pointer;\r\nbegin\r\n Result := Value;\r\n Value := nil;\r\nend;\r\n\r\nfunction TJclPtrPtrHashMap.KeysEqual(A, B: Pointer): Boolean;\r\nbegin\r\n Result := ItemsEqual(A, B);\r\nend;\r\n\r\nfunction TJclPtrPtrHashMap.ValuesEqual(A, B: Pointer): Boolean;\r\nbegin\r\n Result := ItemsEqual(A, B);\r\nend;\r\n\r\n//=== { TJclIntfHashMapBucket } ==========================================\r\n\r\nprocedure TJclIntfHashMapBucket.FinalizeArrayBeforeMove(var List: TJclIntfHashMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\nbegin\r\n Assert(Count > 0);\r\n if FromIndex < ToIndex then\r\n begin\r\n if Count > (ToIndex - FromIndex) then\r\n Finalize(List[FromIndex + Count], ToIndex - FromIndex)\r\n else\r\n Finalize(List[ToIndex], Count);\r\n end\r\n else\r\n if FromIndex > ToIndex then\r\n begin\r\n if Count > (FromIndex - ToIndex) then\r\n Count := FromIndex - ToIndex;\r\n Finalize(List[ToIndex], Count)\r\n end;\r\nend;\r\n\r\nprocedure TJclIntfHashMapBucket.InitializeArray(var List: TJclIntfHashMapEntryArray; FromIndex, Count: SizeInt);\r\nbegin\r\n {$IFDEF FPC}\r\n while Count > 0 do\r\n begin\r\n Initialize(List[FromIndex]);\r\n Inc(FromIndex);\r\n Dec(Count);\r\n end;\r\n {$ELSE ~FPC}\r\n Initialize(List[FromIndex], Count);\r\n {$ENDIF ~FPC}\r\nend;\r\n\r\nprocedure TJclIntfHashMapBucket.InitializeArrayAfterMove(var List: TJclIntfHashMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\nbegin\r\n { Keep reference counting working }\r\n if FromIndex < ToIndex then\r\n begin\r\n if (ToIndex - FromIndex) < Count then\r\n Count := ToIndex - FromIndex;\r\n InitializeArray(List, FromIndex, Count);\r\n end\r\n else\r\n if FromIndex > ToIndex then\r\n begin\r\n if (FromIndex - ToIndex) < Count then\r\n InitializeArray(List, ToIndex + Count, FromIndex - ToIndex)\r\n else\r\n InitializeArray(List, FromIndex, Count);\r\n end;\r\nend;\r\n\r\nprocedure TJclIntfHashMapBucket.MoveArray(var List: TJclIntfHashMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\nbegin\r\n if Count > 0 then\r\n begin\r\n FinalizeArrayBeforeMove(List, FromIndex, ToIndex, Count);\r\n Move(List[FromIndex], List[ToIndex], Count * SizeOf(List[0]));\r\n InitializeArrayAfterMove(List, FromIndex, ToIndex, Count);\r\n end;\r\nend;\r\n\r\n//=== { TJclIntfHashMap } ==========================================\r\n\r\nconstructor TJclIntfHashMap.Create(ACapacity: Integer; AOwnsValues: Boolean);\r\nbegin\r\n inherited Create;\r\n FOwnsValues := AOwnsValues;\r\n SetCapacity(ACapacity);\r\n FHashToRangeFunction := JclSimpleHashToRange;\r\nend;\r\n\r\ndestructor TJclIntfHashMap.Destroy;\r\nbegin\r\n FReadOnly := False;\r\n Clear;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJclIntfHashMap.AssignDataTo(Dest: TJclAbstractContainerBase);\r\nvar\r\n I, J: Integer;\r\n SelfBucket, NewBucket: TJclIntfHashMapBucket;\r\n ADest: TJclIntfHashMap;\r\n AMap: IJclIntfMap;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n inherited AssignDataTo(Dest);\r\n if Dest is TJclIntfHashMap then\r\n begin\r\n ADest := TJclIntfHashMap(Dest);\r\n ADest.Clear;\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n SelfBucket := FBuckets[I];\r\n if SelfBucket <> nil then\r\n begin\r\n NewBucket := TJclIntfHashMapBucket.Create;\r\n SetLength(NewBucket.Entries, SelfBucket.Size);\r\n for J := 0 to SelfBucket.Size - 1 do\r\n begin\r\n NewBucket.Entries[J].Key := SelfBucket.Entries[J].Key;\r\n NewBucket.Entries[J].Value := SelfBucket.Entries[J].Value;\r\n end;\r\n NewBucket.Size := SelfBucket.Size;\r\n ADest.FBuckets[I] := NewBucket;\r\n end;\r\n end;\r\n end\r\n else\r\n if Supports(IInterface(Dest), IJclIntfMap, AMap) then\r\n begin\r\n AMap.Clear;\r\n AMap.PutAll(Self);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclIntfHashMap.AssignPropertiesTo(Dest: TJclAbstractContainerBase);\r\nbegin\r\n inherited AssignPropertiesto(Dest);\r\n if Dest is TJclIntfHashMap then\r\n TJclIntfHashMap(Dest).FHashToRangeFunction := FHashToRangeFunction;\r\nend;\r\n\r\nprocedure TJclIntfHashMap.Clear;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclIntfHashMapBucket;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n begin\r\n for J := 0 to Bucket.Size - 1 do\r\n begin\r\n FreeKey(Bucket.Entries[J].Key);\r\n FreeValue(Bucket.Entries[J].Value);\r\n end;\r\n FreeAndNil(FBuckets[I]);\r\n end;\r\n end;\r\n FSize := 0;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfHashMap.ContainsKey(const Key: IInterface): Boolean;\r\nvar\r\n I: Integer;\r\n Bucket: TJclIntfHashMapBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n Bucket := FBuckets[FHashToRangeFunction(Hash(Key), FCapacity)];\r\n if Bucket <> nil then\r\n for I := 0 to Bucket.Size - 1 do\r\n if KeysEqual(Bucket.Entries[I].Key, Key) then\r\n begin\r\n Result := True;\r\n Break;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfHashMap.ContainsValue(Value: TObject): Boolean;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclIntfHashMapBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n for J := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[J];\r\n if Bucket <> nil then\r\n for I := 0 to Bucket.Size - 1 do\r\n if ValuesEqual(Bucket.Entries[I].Value, Value) then\r\n begin\r\n Result := True;\r\n Break;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfHashMap.Extract(const Key: IInterface): TObject;\r\nvar\r\n Bucket: TJclIntfHashMapBucket;\r\n I, NewCapacity: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := nil;\r\n Bucket := FBuckets[FHashToRangeFunction(Hash(Key), FCapacity)];\r\n if Bucket <> nil then\r\n begin\r\n for I := 0 to Bucket.Size - 1 do\r\n if KeysEqual(Bucket.Entries[I].Key, Key) then\r\n begin\r\n Result := Bucket.Entries[I].Value;\r\n Bucket.Entries[I].Value := nil;\r\n FreeKey(Bucket.Entries[I].Key);\r\n if I < Length(Bucket.Entries) - 1 then\r\n Bucket.MoveArray(Bucket.Entries, I + 1, I, Bucket.Size - I - 1);\r\n Dec(Bucket.Size);\r\n Dec(FSize);\r\n Break;\r\n end;\r\n\r\n NewCapacity := CalcPackCapacity(Length(Bucket.Entries), Bucket.Size);\r\n if NewCapacity < Length(Bucket.Entries) then\r\n SetLength(Bucket.Entries, NewCapacity);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfHashMap.GetValue(const Key: IInterface): TObject;\r\nvar\r\n I: Integer;\r\n Bucket: TJclIntfHashMapBucket;\r\n Found: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Found := False;\r\n Result := nil;\r\n Bucket := FBuckets[FHashToRangeFunction(Hash(Key), FCapacity)];\r\n if Bucket <> nil then\r\n for I := 0 to Bucket.Size - 1 do\r\n if KeysEqual(Bucket.Entries[I].Key, Key) then\r\n begin\r\n Result := Bucket.Entries[I].Value;\r\n Found := True;\r\n Break;\r\n end;\r\n if (not Found) and (not FReturnDefaultElements) then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfHashMap.IsEmpty: Boolean;\r\nbegin\r\n Result := FSize = 0;\r\nend;\r\n\r\nfunction TJclIntfHashMap.KeyOfValue(Value: TObject): IInterface;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclIntfHashMapBucket;\r\n Found: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Found := False;\r\n Result := nil;\r\n for J := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[J];\r\n if Bucket <> nil then\r\n for I := 0 to Bucket.Size - 1 do\r\n if ValuesEqual(Bucket.Entries[I].Value, Value) then\r\n begin\r\n Result := Bucket.Entries[I].Key;\r\n Found := True;\r\n Break;\r\n end;\r\n end;\r\n if (not Found) and (not FReturnDefaultElements) then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfHashMap.KeySet: IJclIntfSet;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclIntfHashMapBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := TJclIntfArraySet.Create(FSize);\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n for J := 0 to Bucket.Size - 1 do\r\n Result.Add(Bucket.Entries[J].Key);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfHashMap.MapEquals(const AMap: IJclIntfMap): Boolean;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclIntfHashMapBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if AMap = nil then\r\n Exit;\r\n if FSize <> AMap.Size then\r\n Exit;\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n for J := 0 to Bucket.Size - 1 do\r\n if AMap.ContainsKey(Bucket.Entries[J].Key) then\r\n begin\r\n if not ValuesEqual(AMap.GetValue(Bucket.Entries[J].Key), Bucket.Entries[J].Value) then\r\n Exit;\r\n end\r\n else\r\n Exit;\r\n end;\r\n Result := True;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclIntfHashMap.Pack;\r\nvar\r\n I: Integer;\r\n Bucket: TJclIntfHashMapBucket;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n begin\r\n if Bucket.Size > 0 then\r\n SetLength(Bucket.Entries, Bucket.Size)\r\n else\r\n FreeAndNil(FBuckets[I]);\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclIntfHashMap.PutAll(const AMap: IJclIntfMap);\r\nvar\r\n It: IJclIntfIterator;\r\n Key: IInterface;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if AMap = nil then\r\n Exit;\r\n It := AMap.KeySet.First;\r\n while It.HasNext do\r\n begin\r\n Key := It.Next;\r\n PutValue(Key, AMap.GetValue(Key));\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclIntfHashMap.PutValue(const Key: IInterface; Value: TObject);\r\nvar\r\n Index: Integer;\r\n Bucket: TJclIntfHashMapBucket;\r\n I: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FAllowDefaultElements or (not KeysEqual(Key, nil) and not ValuesEqual(Value, nil)) then\r\n begin\r\n Index := FHashToRangeFunction(Hash(Key), FCapacity);\r\n Bucket := FBuckets[Index];\r\n if Bucket <> nil then\r\n begin\r\n for I := 0 to Bucket.Size - 1 do\r\n if KeysEqual(Bucket.Entries[I].Key, Key) then\r\n begin\r\n FreeValue(Bucket.Entries[I].Value);\r\n Bucket.Entries[I].Value := Value;\r\n Exit;\r\n end;\r\n end\r\n else\r\n begin\r\n Bucket := TJclIntfHashMapBucket.Create;\r\n SetLength(Bucket.Entries, 1);\r\n FBuckets[Index] := Bucket;\r\n end;\r\n\r\n if Bucket.Size = Length(Bucket.Entries) then\r\n SetLength(Bucket.Entries, CalcGrowCapacity(Bucket.Size, Bucket.Size));\r\n\r\n if Bucket.Size < Length(Bucket.Entries) then\r\n begin\r\n Bucket.Entries[Bucket.Size].Key := Key;\r\n Bucket.Entries[Bucket.Size].Value := Value;\r\n Inc(Bucket.Size);\r\n Inc(FSize);\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfHashMap.Remove(const Key: IInterface): TObject;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := Extract(Key);\r\n Result := FreeValue(Result);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclIntfHashMap.SetCapacity(Value: Integer);\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FSize = 0 then\r\n begin\r\n SetLength(FBuckets, Value);\r\n inherited SetCapacity(Value);\r\n end\r\n else\r\n raise EJclOperationNotSupportedError.Create;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfHashMap.Size: Integer;\r\nbegin\r\n Result := FSize;\r\nend;\r\n\r\nfunction TJclIntfHashMap.Values: IJclCollection;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclIntfHashMapBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := TJclArrayList.Create(FSize, False);\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n for J := 0 to Bucket.Size - 1 do\r\n Result.Add(Bucket.Entries[J].Value);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfHashMap.CreateEmptyContainer: TJclAbstractContainerBase;\r\nbegin\r\n Result := TJclIntfHashMap.Create(FCapacity, False);\r\n AssignPropertiesTo(Result);\r\nend;\r\n\r\nfunction TJclIntfHashMap.FreeKey(var Key: IInterface): IInterface;\r\nbegin\r\n Result := Key;\r\n Key := nil;\r\nend;\r\n\r\nfunction TJclIntfHashMap.FreeValue(var Value: TObject): TObject;\r\nbegin\r\n if FOwnsValues then\r\n begin\r\n Result := nil;\r\n FreeAndNil(Value);\r\n end\r\n else\r\n begin\r\n Result := Value;\r\n Value := nil;\r\n end;\r\nend;\r\n\r\nfunction TJclIntfHashMap.GetOwnsValues: Boolean;\r\nbegin\r\n Result := FOwnsValues;\r\nend;\r\n\r\nfunction TJclIntfHashMap.KeysEqual(const A, B: IInterface): Boolean;\r\nbegin\r\n Result := ItemsEqual(A, B);\r\nend;\r\n\r\nfunction TJclIntfHashMap.ValuesEqual(A, B: TObject): Boolean;\r\nbegin\r\n Result := SimpleEqualityCompare(A, B);\r\nend;\r\n\r\n//=== { TJclAnsiStrHashMapBucket } ==========================================\r\n\r\nprocedure TJclAnsiStrHashMapBucket.FinalizeArrayBeforeMove(var List: TJclAnsiStrHashMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\nbegin\r\n Assert(Count > 0);\r\n if FromIndex < ToIndex then\r\n begin\r\n if Count > (ToIndex - FromIndex) then\r\n Finalize(List[FromIndex + Count], ToIndex - FromIndex)\r\n else\r\n Finalize(List[ToIndex], Count);\r\n end\r\n else\r\n if FromIndex > ToIndex then\r\n begin\r\n if Count > (FromIndex - ToIndex) then\r\n Count := FromIndex - ToIndex;\r\n Finalize(List[ToIndex], Count)\r\n end;\r\nend;\r\n\r\nprocedure TJclAnsiStrHashMapBucket.InitializeArray(var List: TJclAnsiStrHashMapEntryArray; FromIndex, Count: SizeInt);\r\nbegin\r\n {$IFDEF FPC}\r\n while Count > 0 do\r\n begin\r\n Initialize(List[FromIndex]);\r\n Inc(FromIndex);\r\n Dec(Count);\r\n end;\r\n {$ELSE ~FPC}\r\n Initialize(List[FromIndex], Count);\r\n {$ENDIF ~FPC}\r\nend;\r\n\r\nprocedure TJclAnsiStrHashMapBucket.InitializeArrayAfterMove(var List: TJclAnsiStrHashMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\nbegin\r\n { Keep reference counting working }\r\n if FromIndex < ToIndex then\r\n begin\r\n if (ToIndex - FromIndex) < Count then\r\n Count := ToIndex - FromIndex;\r\n InitializeArray(List, FromIndex, Count);\r\n end\r\n else\r\n if FromIndex > ToIndex then\r\n begin\r\n if (FromIndex - ToIndex) < Count then\r\n InitializeArray(List, ToIndex + Count, FromIndex - ToIndex)\r\n else\r\n InitializeArray(List, FromIndex, Count);\r\n end;\r\nend;\r\n\r\nprocedure TJclAnsiStrHashMapBucket.MoveArray(var List: TJclAnsiStrHashMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\nbegin\r\n if Count > 0 then\r\n begin\r\n FinalizeArrayBeforeMove(List, FromIndex, ToIndex, Count);\r\n Move(List[FromIndex], List[ToIndex], Count * SizeOf(List[0]));\r\n InitializeArrayAfterMove(List, FromIndex, ToIndex, Count);\r\n end;\r\nend;\r\n\r\n//=== { TJclAnsiStrHashMap } ==========================================\r\n\r\nconstructor TJclAnsiStrHashMap.Create(ACapacity: Integer; AOwnsValues: Boolean);\r\nbegin\r\n inherited Create;\r\n FOwnsValues := AOwnsValues;\r\n SetCapacity(ACapacity);\r\n FHashToRangeFunction := JclSimpleHashToRange;\r\nend;\r\n\r\ndestructor TJclAnsiStrHashMap.Destroy;\r\nbegin\r\n FReadOnly := False;\r\n Clear;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJclAnsiStrHashMap.AssignDataTo(Dest: TJclAbstractContainerBase);\r\nvar\r\n I, J: Integer;\r\n SelfBucket, NewBucket: TJclAnsiStrHashMapBucket;\r\n ADest: TJclAnsiStrHashMap;\r\n AMap: IJclAnsiStrMap;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n inherited AssignDataTo(Dest);\r\n if Dest is TJclAnsiStrHashMap then\r\n begin\r\n ADest := TJclAnsiStrHashMap(Dest);\r\n ADest.Clear;\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n SelfBucket := FBuckets[I];\r\n if SelfBucket <> nil then\r\n begin\r\n NewBucket := TJclAnsiStrHashMapBucket.Create;\r\n SetLength(NewBucket.Entries, SelfBucket.Size);\r\n for J := 0 to SelfBucket.Size - 1 do\r\n begin\r\n NewBucket.Entries[J].Key := SelfBucket.Entries[J].Key;\r\n NewBucket.Entries[J].Value := SelfBucket.Entries[J].Value;\r\n end;\r\n NewBucket.Size := SelfBucket.Size;\r\n ADest.FBuckets[I] := NewBucket;\r\n end;\r\n end;\r\n end\r\n else\r\n if Supports(IInterface(Dest), IJclAnsiStrMap, AMap) then\r\n begin\r\n AMap.Clear;\r\n AMap.PutAll(Self);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclAnsiStrHashMap.AssignPropertiesTo(Dest: TJclAbstractContainerBase);\r\nbegin\r\n inherited AssignPropertiesto(Dest);\r\n if Dest is TJclAnsiStrHashMap then\r\n TJclAnsiStrHashMap(Dest).FHashToRangeFunction := FHashToRangeFunction;\r\nend;\r\n\r\nprocedure TJclAnsiStrHashMap.Clear;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclAnsiStrHashMapBucket;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n begin\r\n for J := 0 to Bucket.Size - 1 do\r\n begin\r\n FreeKey(Bucket.Entries[J].Key);\r\n FreeValue(Bucket.Entries[J].Value);\r\n end;\r\n FreeAndNil(FBuckets[I]);\r\n end;\r\n end;\r\n FSize := 0;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclAnsiStrHashMap.ContainsKey(const Key: AnsiString): Boolean;\r\nvar\r\n I: Integer;\r\n Bucket: TJclAnsiStrHashMapBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n Bucket := FBuckets[FHashToRangeFunction(Hash(Key), FCapacity)];\r\n if Bucket <> nil then\r\n for I := 0 to Bucket.Size - 1 do\r\n if KeysEqual(Bucket.Entries[I].Key, Key) then\r\n begin\r\n Result := True;\r\n Break;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclAnsiStrHashMap.ContainsValue(Value: TObject): Boolean;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclAnsiStrHashMapBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n for J := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[J];\r\n if Bucket <> nil then\r\n for I := 0 to Bucket.Size - 1 do\r\n if ValuesEqual(Bucket.Entries[I].Value, Value) then\r\n begin\r\n Result := True;\r\n Break;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclAnsiStrHashMap.Extract(const Key: AnsiString): TObject;\r\nvar\r\n Bucket: TJclAnsiStrHashMapBucket;\r\n I, NewCapacity: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := nil;\r\n Bucket := FBuckets[FHashToRangeFunction(Hash(Key), FCapacity)];\r\n if Bucket <> nil then\r\n begin\r\n for I := 0 to Bucket.Size - 1 do\r\n if KeysEqual(Bucket.Entries[I].Key, Key) then\r\n begin\r\n Result := Bucket.Entries[I].Value;\r\n Bucket.Entries[I].Value := nil;\r\n FreeKey(Bucket.Entries[I].Key);\r\n if I < Length(Bucket.Entries) - 1 then\r\n Bucket.MoveArray(Bucket.Entries, I + 1, I, Bucket.Size - I - 1);\r\n Dec(Bucket.Size);\r\n Dec(FSize);\r\n Break;\r\n end;\r\n\r\n NewCapacity := CalcPackCapacity(Length(Bucket.Entries), Bucket.Size);\r\n if NewCapacity < Length(Bucket.Entries) then\r\n SetLength(Bucket.Entries, NewCapacity);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclAnsiStrHashMap.GetValue(const Key: AnsiString): TObject;\r\nvar\r\n I: Integer;\r\n Bucket: TJclAnsiStrHashMapBucket;\r\n Found: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Found := False;\r\n Result := nil;\r\n Bucket := FBuckets[FHashToRangeFunction(Hash(Key), FCapacity)];\r\n if Bucket <> nil then\r\n for I := 0 to Bucket.Size - 1 do\r\n if KeysEqual(Bucket.Entries[I].Key, Key) then\r\n begin\r\n Result := Bucket.Entries[I].Value;\r\n Found := True;\r\n Break;\r\n end;\r\n if (not Found) and (not FReturnDefaultElements) then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclAnsiStrHashMap.IsEmpty: Boolean;\r\nbegin\r\n Result := FSize = 0;\r\nend;\r\n\r\nfunction TJclAnsiStrHashMap.KeyOfValue(Value: TObject): AnsiString;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclAnsiStrHashMapBucket;\r\n Found: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Found := False;\r\n Result := '';\r\n for J := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[J];\r\n if Bucket <> nil then\r\n for I := 0 to Bucket.Size - 1 do\r\n if ValuesEqual(Bucket.Entries[I].Value, Value) then\r\n begin\r\n Result := Bucket.Entries[I].Key;\r\n Found := True;\r\n Break;\r\n end;\r\n end;\r\n if (not Found) and (not FReturnDefaultElements) then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclAnsiStrHashMap.KeySet: IJclAnsiStrSet;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclAnsiStrHashMapBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := TJclAnsiStrArraySet.Create(FSize);\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n for J := 0 to Bucket.Size - 1 do\r\n Result.Add(Bucket.Entries[J].Key);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclAnsiStrHashMap.MapEquals(const AMap: IJclAnsiStrMap): Boolean;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclAnsiStrHashMapBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if AMap = nil then\r\n Exit;\r\n if FSize <> AMap.Size then\r\n Exit;\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n for J := 0 to Bucket.Size - 1 do\r\n if AMap.ContainsKey(Bucket.Entries[J].Key) then\r\n begin\r\n if not ValuesEqual(AMap.GetValue(Bucket.Entries[J].Key), Bucket.Entries[J].Value) then\r\n Exit;\r\n end\r\n else\r\n Exit;\r\n end;\r\n Result := True;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclAnsiStrHashMap.Pack;\r\nvar\r\n I: Integer;\r\n Bucket: TJclAnsiStrHashMapBucket;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n begin\r\n if Bucket.Size > 0 then\r\n SetLength(Bucket.Entries, Bucket.Size)\r\n else\r\n FreeAndNil(FBuckets[I]);\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclAnsiStrHashMap.PutAll(const AMap: IJclAnsiStrMap);\r\nvar\r\n It: IJclAnsiStrIterator;\r\n Key: AnsiString;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if AMap = nil then\r\n Exit;\r\n It := AMap.KeySet.First;\r\n while It.HasNext do\r\n begin\r\n Key := It.Next;\r\n PutValue(Key, AMap.GetValue(Key));\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclAnsiStrHashMap.PutValue(const Key: AnsiString; Value: TObject);\r\nvar\r\n Index: Integer;\r\n Bucket: TJclAnsiStrHashMapBucket;\r\n I: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FAllowDefaultElements or (not KeysEqual(Key, '') and not ValuesEqual(Value, nil)) then\r\n begin\r\n Index := FHashToRangeFunction(Hash(Key), FCapacity);\r\n Bucket := FBuckets[Index];\r\n if Bucket <> nil then\r\n begin\r\n for I := 0 to Bucket.Size - 1 do\r\n if KeysEqual(Bucket.Entries[I].Key, Key) then\r\n begin\r\n FreeValue(Bucket.Entries[I].Value);\r\n Bucket.Entries[I].Value := Value;\r\n Exit;\r\n end;\r\n end\r\n else\r\n begin\r\n Bucket := TJclAnsiStrHashMapBucket.Create;\r\n SetLength(Bucket.Entries, 1);\r\n FBuckets[Index] := Bucket;\r\n end;\r\n\r\n if Bucket.Size = Length(Bucket.Entries) then\r\n SetLength(Bucket.Entries, CalcGrowCapacity(Bucket.Size, Bucket.Size));\r\n\r\n if Bucket.Size < Length(Bucket.Entries) then\r\n begin\r\n Bucket.Entries[Bucket.Size].Key := Key;\r\n Bucket.Entries[Bucket.Size].Value := Value;\r\n Inc(Bucket.Size);\r\n Inc(FSize);\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclAnsiStrHashMap.Remove(const Key: AnsiString): TObject;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := Extract(Key);\r\n Result := FreeValue(Result);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclAnsiStrHashMap.SetCapacity(Value: Integer);\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FSize = 0 then\r\n begin\r\n SetLength(FBuckets, Value);\r\n inherited SetCapacity(Value);\r\n end\r\n else\r\n raise EJclOperationNotSupportedError.Create;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclAnsiStrHashMap.Size: Integer;\r\nbegin\r\n Result := FSize;\r\nend;\r\n\r\nfunction TJclAnsiStrHashMap.Values: IJclCollection;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclAnsiStrHashMapBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := TJclArrayList.Create(FSize, False);\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n for J := 0 to Bucket.Size - 1 do\r\n Result.Add(Bucket.Entries[J].Value);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclAnsiStrHashMap.CreateEmptyContainer: TJclAbstractContainerBase;\r\nbegin\r\n Result := TJclAnsiStrHashMap.Create(FCapacity, False);\r\n AssignPropertiesTo(Result);\r\nend;\r\n\r\nfunction TJclAnsiStrHashMap.FreeKey(var Key: AnsiString): AnsiString;\r\nbegin\r\n Result := Key;\r\n Key := '';\r\nend;\r\n\r\nfunction TJclAnsiStrHashMap.FreeValue(var Value: TObject): TObject;\r\nbegin\r\n if FOwnsValues then\r\n begin\r\n Result := nil;\r\n FreeAndNil(Value);\r\n end\r\n else\r\n begin\r\n Result := Value;\r\n Value := nil;\r\n end;\r\nend;\r\n\r\nfunction TJclAnsiStrHashMap.GetOwnsValues: Boolean;\r\nbegin\r\n Result := FOwnsValues;\r\nend;\r\n\r\nfunction TJclAnsiStrHashMap.KeysEqual(const A, B: AnsiString): Boolean;\r\nbegin\r\n Result := ItemsEqual(A, B);\r\nend;\r\n\r\nfunction TJclAnsiStrHashMap.ValuesEqual(A, B: TObject): Boolean;\r\nbegin\r\n Result := SimpleEqualityCompare(A, B);\r\nend;\r\n\r\n//=== { TJclWideStrHashMapBucket } ==========================================\r\n\r\nprocedure TJclWideStrHashMapBucket.FinalizeArrayBeforeMove(var List: TJclWideStrHashMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\nbegin\r\n Assert(Count > 0);\r\n if FromIndex < ToIndex then\r\n begin\r\n if Count > (ToIndex - FromIndex) then\r\n Finalize(List[FromIndex + Count], ToIndex - FromIndex)\r\n else\r\n Finalize(List[ToIndex], Count);\r\n end\r\n else\r\n if FromIndex > ToIndex then\r\n begin\r\n if Count > (FromIndex - ToIndex) then\r\n Count := FromIndex - ToIndex;\r\n Finalize(List[ToIndex], Count)\r\n end;\r\nend;\r\n\r\nprocedure TJclWideStrHashMapBucket.InitializeArray(var List: TJclWideStrHashMapEntryArray; FromIndex, Count: SizeInt);\r\nbegin\r\n {$IFDEF FPC}\r\n while Count > 0 do\r\n begin\r\n Initialize(List[FromIndex]);\r\n Inc(FromIndex);\r\n Dec(Count);\r\n end;\r\n {$ELSE ~FPC}\r\n Initialize(List[FromIndex], Count);\r\n {$ENDIF ~FPC}\r\nend;\r\n\r\nprocedure TJclWideStrHashMapBucket.InitializeArrayAfterMove(var List: TJclWideStrHashMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\nbegin\r\n { Keep reference counting working }\r\n if FromIndex < ToIndex then\r\n begin\r\n if (ToIndex - FromIndex) < Count then\r\n Count := ToIndex - FromIndex;\r\n InitializeArray(List, FromIndex, Count);\r\n end\r\n else\r\n if FromIndex > ToIndex then\r\n begin\r\n if (FromIndex - ToIndex) < Count then\r\n InitializeArray(List, ToIndex + Count, FromIndex - ToIndex)\r\n else\r\n InitializeArray(List, FromIndex, Count);\r\n end;\r\nend;\r\n\r\nprocedure TJclWideStrHashMapBucket.MoveArray(var List: TJclWideStrHashMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\nbegin\r\n if Count > 0 then\r\n begin\r\n FinalizeArrayBeforeMove(List, FromIndex, ToIndex, Count);\r\n Move(List[FromIndex], List[ToIndex], Count * SizeOf(List[0]));\r\n InitializeArrayAfterMove(List, FromIndex, ToIndex, Count);\r\n end;\r\nend;\r\n\r\n//=== { TJclWideStrHashMap } ==========================================\r\n\r\nconstructor TJclWideStrHashMap.Create(ACapacity: Integer; AOwnsValues: Boolean);\r\nbegin\r\n inherited Create;\r\n FOwnsValues := AOwnsValues;\r\n SetCapacity(ACapacity);\r\n FHashToRangeFunction := JclSimpleHashToRange;\r\nend;\r\n\r\ndestructor TJclWideStrHashMap.Destroy;\r\nbegin\r\n FReadOnly := False;\r\n Clear;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJclWideStrHashMap.AssignDataTo(Dest: TJclAbstractContainerBase);\r\nvar\r\n I, J: Integer;\r\n SelfBucket, NewBucket: TJclWideStrHashMapBucket;\r\n ADest: TJclWideStrHashMap;\r\n AMap: IJclWideStrMap;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n inherited AssignDataTo(Dest);\r\n if Dest is TJclWideStrHashMap then\r\n begin\r\n ADest := TJclWideStrHashMap(Dest);\r\n ADest.Clear;\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n SelfBucket := FBuckets[I];\r\n if SelfBucket <> nil then\r\n begin\r\n NewBucket := TJclWideStrHashMapBucket.Create;\r\n SetLength(NewBucket.Entries, SelfBucket.Size);\r\n for J := 0 to SelfBucket.Size - 1 do\r\n begin\r\n NewBucket.Entries[J].Key := SelfBucket.Entries[J].Key;\r\n NewBucket.Entries[J].Value := SelfBucket.Entries[J].Value;\r\n end;\r\n NewBucket.Size := SelfBucket.Size;\r\n ADest.FBuckets[I] := NewBucket;\r\n end;\r\n end;\r\n end\r\n else\r\n if Supports(IInterface(Dest), IJclWideStrMap, AMap) then\r\n begin\r\n AMap.Clear;\r\n AMap.PutAll(Self);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclWideStrHashMap.AssignPropertiesTo(Dest: TJclAbstractContainerBase);\r\nbegin\r\n inherited AssignPropertiesto(Dest);\r\n if Dest is TJclWideStrHashMap then\r\n TJclWideStrHashMap(Dest).FHashToRangeFunction := FHashToRangeFunction;\r\nend;\r\n\r\nprocedure TJclWideStrHashMap.Clear;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclWideStrHashMapBucket;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n begin\r\n for J := 0 to Bucket.Size - 1 do\r\n begin\r\n FreeKey(Bucket.Entries[J].Key);\r\n FreeValue(Bucket.Entries[J].Value);\r\n end;\r\n FreeAndNil(FBuckets[I]);\r\n end;\r\n end;\r\n FSize := 0;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclWideStrHashMap.ContainsKey(const Key: WideString): Boolean;\r\nvar\r\n I: Integer;\r\n Bucket: TJclWideStrHashMapBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n Bucket := FBuckets[FHashToRangeFunction(Hash(Key), FCapacity)];\r\n if Bucket <> nil then\r\n for I := 0 to Bucket.Size - 1 do\r\n if KeysEqual(Bucket.Entries[I].Key, Key) then\r\n begin\r\n Result := True;\r\n Break;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclWideStrHashMap.ContainsValue(Value: TObject): Boolean;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclWideStrHashMapBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n for J := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[J];\r\n if Bucket <> nil then\r\n for I := 0 to Bucket.Size - 1 do\r\n if ValuesEqual(Bucket.Entries[I].Value, Value) then\r\n begin\r\n Result := True;\r\n Break;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclWideStrHashMap.Extract(const Key: WideString): TObject;\r\nvar\r\n Bucket: TJclWideStrHashMapBucket;\r\n I, NewCapacity: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := nil;\r\n Bucket := FBuckets[FHashToRangeFunction(Hash(Key), FCapacity)];\r\n if Bucket <> nil then\r\n begin\r\n for I := 0 to Bucket.Size - 1 do\r\n if KeysEqual(Bucket.Entries[I].Key, Key) then\r\n begin\r\n Result := Bucket.Entries[I].Value;\r\n Bucket.Entries[I].Value := nil;\r\n FreeKey(Bucket.Entries[I].Key);\r\n if I < Length(Bucket.Entries) - 1 then\r\n Bucket.MoveArray(Bucket.Entries, I + 1, I, Bucket.Size - I - 1);\r\n Dec(Bucket.Size);\r\n Dec(FSize);\r\n Break;\r\n end;\r\n\r\n NewCapacity := CalcPackCapacity(Length(Bucket.Entries), Bucket.Size);\r\n if NewCapacity < Length(Bucket.Entries) then\r\n SetLength(Bucket.Entries, NewCapacity);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclWideStrHashMap.GetValue(const Key: WideString): TObject;\r\nvar\r\n I: Integer;\r\n Bucket: TJclWideStrHashMapBucket;\r\n Found: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Found := False;\r\n Result := nil;\r\n Bucket := FBuckets[FHashToRangeFunction(Hash(Key), FCapacity)];\r\n if Bucket <> nil then\r\n for I := 0 to Bucket.Size - 1 do\r\n if KeysEqual(Bucket.Entries[I].Key, Key) then\r\n begin\r\n Result := Bucket.Entries[I].Value;\r\n Found := True;\r\n Break;\r\n end;\r\n if (not Found) and (not FReturnDefaultElements) then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclWideStrHashMap.IsEmpty: Boolean;\r\nbegin\r\n Result := FSize = 0;\r\nend;\r\n\r\nfunction TJclWideStrHashMap.KeyOfValue(Value: TObject): WideString;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclWideStrHashMapBucket;\r\n Found: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Found := False;\r\n Result := '';\r\n for J := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[J];\r\n if Bucket <> nil then\r\n for I := 0 to Bucket.Size - 1 do\r\n if ValuesEqual(Bucket.Entries[I].Value, Value) then\r\n begin\r\n Result := Bucket.Entries[I].Key;\r\n Found := True;\r\n Break;\r\n end;\r\n end;\r\n if (not Found) and (not FReturnDefaultElements) then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclWideStrHashMap.KeySet: IJclWideStrSet;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclWideStrHashMapBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := TJclWideStrArraySet.Create(FSize);\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n for J := 0 to Bucket.Size - 1 do\r\n Result.Add(Bucket.Entries[J].Key);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclWideStrHashMap.MapEquals(const AMap: IJclWideStrMap): Boolean;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclWideStrHashMapBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if AMap = nil then\r\n Exit;\r\n if FSize <> AMap.Size then\r\n Exit;\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n for J := 0 to Bucket.Size - 1 do\r\n if AMap.ContainsKey(Bucket.Entries[J].Key) then\r\n begin\r\n if not ValuesEqual(AMap.GetValue(Bucket.Entries[J].Key), Bucket.Entries[J].Value) then\r\n Exit;\r\n end\r\n else\r\n Exit;\r\n end;\r\n Result := True;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclWideStrHashMap.Pack;\r\nvar\r\n I: Integer;\r\n Bucket: TJclWideStrHashMapBucket;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n begin\r\n if Bucket.Size > 0 then\r\n SetLength(Bucket.Entries, Bucket.Size)\r\n else\r\n FreeAndNil(FBuckets[I]);\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclWideStrHashMap.PutAll(const AMap: IJclWideStrMap);\r\nvar\r\n It: IJclWideStrIterator;\r\n Key: WideString;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if AMap = nil then\r\n Exit;\r\n It := AMap.KeySet.First;\r\n while It.HasNext do\r\n begin\r\n Key := It.Next;\r\n PutValue(Key, AMap.GetValue(Key));\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclWideStrHashMap.PutValue(const Key: WideString; Value: TObject);\r\nvar\r\n Index: Integer;\r\n Bucket: TJclWideStrHashMapBucket;\r\n I: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FAllowDefaultElements or (not KeysEqual(Key, '') and not ValuesEqual(Value, nil)) then\r\n begin\r\n Index := FHashToRangeFunction(Hash(Key), FCapacity);\r\n Bucket := FBuckets[Index];\r\n if Bucket <> nil then\r\n begin\r\n for I := 0 to Bucket.Size - 1 do\r\n if KeysEqual(Bucket.Entries[I].Key, Key) then\r\n begin\r\n FreeValue(Bucket.Entries[I].Value);\r\n Bucket.Entries[I].Value := Value;\r\n Exit;\r\n end;\r\n end\r\n else\r\n begin\r\n Bucket := TJclWideStrHashMapBucket.Create;\r\n SetLength(Bucket.Entries, 1);\r\n FBuckets[Index] := Bucket;\r\n end;\r\n\r\n if Bucket.Size = Length(Bucket.Entries) then\r\n SetLength(Bucket.Entries, CalcGrowCapacity(Bucket.Size, Bucket.Size));\r\n\r\n if Bucket.Size < Length(Bucket.Entries) then\r\n begin\r\n Bucket.Entries[Bucket.Size].Key := Key;\r\n Bucket.Entries[Bucket.Size].Value := Value;\r\n Inc(Bucket.Size);\r\n Inc(FSize);\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclWideStrHashMap.Remove(const Key: WideString): TObject;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := Extract(Key);\r\n Result := FreeValue(Result);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclWideStrHashMap.SetCapacity(Value: Integer);\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FSize = 0 then\r\n begin\r\n SetLength(FBuckets, Value);\r\n inherited SetCapacity(Value);\r\n end\r\n else\r\n raise EJclOperationNotSupportedError.Create;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclWideStrHashMap.Size: Integer;\r\nbegin\r\n Result := FSize;\r\nend;\r\n\r\nfunction TJclWideStrHashMap.Values: IJclCollection;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclWideStrHashMapBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := TJclArrayList.Create(FSize, False);\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n for J := 0 to Bucket.Size - 1 do\r\n Result.Add(Bucket.Entries[J].Value);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclWideStrHashMap.CreateEmptyContainer: TJclAbstractContainerBase;\r\nbegin\r\n Result := TJclWideStrHashMap.Create(FCapacity, False);\r\n AssignPropertiesTo(Result);\r\nend;\r\n\r\nfunction TJclWideStrHashMap.FreeKey(var Key: WideString): WideString;\r\nbegin\r\n Result := Key;\r\n Key := '';\r\nend;\r\n\r\nfunction TJclWideStrHashMap.FreeValue(var Value: TObject): TObject;\r\nbegin\r\n if FOwnsValues then\r\n begin\r\n Result := nil;\r\n FreeAndNil(Value);\r\n end\r\n else\r\n begin\r\n Result := Value;\r\n Value := nil;\r\n end;\r\nend;\r\n\r\nfunction TJclWideStrHashMap.GetOwnsValues: Boolean;\r\nbegin\r\n Result := FOwnsValues;\r\nend;\r\n\r\nfunction TJclWideStrHashMap.KeysEqual(const A, B: WideString): Boolean;\r\nbegin\r\n Result := ItemsEqual(A, B);\r\nend;\r\n\r\nfunction TJclWideStrHashMap.ValuesEqual(A, B: TObject): Boolean;\r\nbegin\r\n Result := SimpleEqualityCompare(A, B);\r\nend;\r\n\r\n{$IFDEF SUPPORTS_UNICODE_STRING}\r\n//=== { TJclUnicodeStrHashMapBucket } ==========================================\r\n\r\nprocedure TJclUnicodeStrHashMapBucket.FinalizeArrayBeforeMove(var List: TJclUnicodeStrHashMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\nbegin\r\n Assert(Count > 0);\r\n if FromIndex < ToIndex then\r\n begin\r\n if Count > (ToIndex - FromIndex) then\r\n Finalize(List[FromIndex + Count], ToIndex - FromIndex)\r\n else\r\n Finalize(List[ToIndex], Count);\r\n end\r\n else\r\n if FromIndex > ToIndex then\r\n begin\r\n if Count > (FromIndex - ToIndex) then\r\n Count := FromIndex - ToIndex;\r\n Finalize(List[ToIndex], Count)\r\n end;\r\nend;\r\n\r\nprocedure TJclUnicodeStrHashMapBucket.InitializeArray(var List: TJclUnicodeStrHashMapEntryArray; FromIndex, Count: SizeInt);\r\nbegin\r\n {$IFDEF FPC}\r\n while Count > 0 do\r\n begin\r\n Initialize(List[FromIndex]);\r\n Inc(FromIndex);\r\n Dec(Count);\r\n end;\r\n {$ELSE ~FPC}\r\n Initialize(List[FromIndex], Count);\r\n {$ENDIF ~FPC}\r\nend;\r\n\r\nprocedure TJclUnicodeStrHashMapBucket.InitializeArrayAfterMove(var List: TJclUnicodeStrHashMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\nbegin\r\n { Keep reference counting working }\r\n if FromIndex < ToIndex then\r\n begin\r\n if (ToIndex - FromIndex) < Count then\r\n Count := ToIndex - FromIndex;\r\n InitializeArray(List, FromIndex, Count);\r\n end\r\n else\r\n if FromIndex > ToIndex then\r\n begin\r\n if (FromIndex - ToIndex) < Count then\r\n InitializeArray(List, ToIndex + Count, FromIndex - ToIndex)\r\n else\r\n InitializeArray(List, FromIndex, Count);\r\n end;\r\nend;\r\n\r\nprocedure TJclUnicodeStrHashMapBucket.MoveArray(var List: TJclUnicodeStrHashMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\nbegin\r\n if Count > 0 then\r\n begin\r\n FinalizeArrayBeforeMove(List, FromIndex, ToIndex, Count);\r\n Move(List[FromIndex], List[ToIndex], Count * SizeOf(List[0]));\r\n InitializeArrayAfterMove(List, FromIndex, ToIndex, Count);\r\n end;\r\nend;\r\n\r\n\r\n{$ENDIF SUPPORTS_UNICODE_STRING}\r\n\r\n{$IFDEF SUPPORTS_UNICODE_STRING}\r\n//=== { TJclUnicodeStrHashMap } ==========================================\r\n\r\nconstructor TJclUnicodeStrHashMap.Create(ACapacity: Integer; AOwnsValues: Boolean);\r\nbegin\r\n inherited Create;\r\n FOwnsValues := AOwnsValues;\r\n SetCapacity(ACapacity);\r\n FHashToRangeFunction := JclSimpleHashToRange;\r\nend;\r\n\r\ndestructor TJclUnicodeStrHashMap.Destroy;\r\nbegin\r\n FReadOnly := False;\r\n Clear;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJclUnicodeStrHashMap.AssignDataTo(Dest: TJclAbstractContainerBase);\r\nvar\r\n I, J: Integer;\r\n SelfBucket, NewBucket: TJclUnicodeStrHashMapBucket;\r\n ADest: TJclUnicodeStrHashMap;\r\n AMap: IJclUnicodeStrMap;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n inherited AssignDataTo(Dest);\r\n if Dest is TJclUnicodeStrHashMap then\r\n begin\r\n ADest := TJclUnicodeStrHashMap(Dest);\r\n ADest.Clear;\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n SelfBucket := FBuckets[I];\r\n if SelfBucket <> nil then\r\n begin\r\n NewBucket := TJclUnicodeStrHashMapBucket.Create;\r\n SetLength(NewBucket.Entries, SelfBucket.Size);\r\n for J := 0 to SelfBucket.Size - 1 do\r\n begin\r\n NewBucket.Entries[J].Key := SelfBucket.Entries[J].Key;\r\n NewBucket.Entries[J].Value := SelfBucket.Entries[J].Value;\r\n end;\r\n NewBucket.Size := SelfBucket.Size;\r\n ADest.FBuckets[I] := NewBucket;\r\n end;\r\n end;\r\n end\r\n else\r\n if Supports(IInterface(Dest), IJclUnicodeStrMap, AMap) then\r\n begin\r\n AMap.Clear;\r\n AMap.PutAll(Self);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclUnicodeStrHashMap.AssignPropertiesTo(Dest: TJclAbstractContainerBase);\r\nbegin\r\n inherited AssignPropertiesto(Dest);\r\n if Dest is TJclUnicodeStrHashMap then\r\n TJclUnicodeStrHashMap(Dest).FHashToRangeFunction := FHashToRangeFunction;\r\nend;\r\n\r\nprocedure TJclUnicodeStrHashMap.Clear;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclUnicodeStrHashMapBucket;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n begin\r\n for J := 0 to Bucket.Size - 1 do\r\n begin\r\n FreeKey(Bucket.Entries[J].Key);\r\n FreeValue(Bucket.Entries[J].Value);\r\n end;\r\n FreeAndNil(FBuckets[I]);\r\n end;\r\n end;\r\n FSize := 0;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclUnicodeStrHashMap.ContainsKey(const Key: UnicodeString): Boolean;\r\nvar\r\n I: Integer;\r\n Bucket: TJclUnicodeStrHashMapBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n Bucket := FBuckets[FHashToRangeFunction(Hash(Key), FCapacity)];\r\n if Bucket <> nil then\r\n for I := 0 to Bucket.Size - 1 do\r\n if KeysEqual(Bucket.Entries[I].Key, Key) then\r\n begin\r\n Result := True;\r\n Break;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclUnicodeStrHashMap.ContainsValue(Value: TObject): Boolean;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclUnicodeStrHashMapBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n for J := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[J];\r\n if Bucket <> nil then\r\n for I := 0 to Bucket.Size - 1 do\r\n if ValuesEqual(Bucket.Entries[I].Value, Value) then\r\n begin\r\n Result := True;\r\n Break;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclUnicodeStrHashMap.Extract(const Key: UnicodeString): TObject;\r\nvar\r\n Bucket: TJclUnicodeStrHashMapBucket;\r\n I, NewCapacity: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := nil;\r\n Bucket := FBuckets[FHashToRangeFunction(Hash(Key), FCapacity)];\r\n if Bucket <> nil then\r\n begin\r\n for I := 0 to Bucket.Size - 1 do\r\n if KeysEqual(Bucket.Entries[I].Key, Key) then\r\n begin\r\n Result := Bucket.Entries[I].Value;\r\n Bucket.Entries[I].Value := nil;\r\n FreeKey(Bucket.Entries[I].Key);\r\n if I < Length(Bucket.Entries) - 1 then\r\n Bucket.MoveArray(Bucket.Entries, I + 1, I, Bucket.Size - I - 1);\r\n Dec(Bucket.Size);\r\n Dec(FSize);\r\n Break;\r\n end;\r\n\r\n NewCapacity := CalcPackCapacity(Length(Bucket.Entries), Bucket.Size);\r\n if NewCapacity < Length(Bucket.Entries) then\r\n SetLength(Bucket.Entries, NewCapacity);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclUnicodeStrHashMap.GetValue(const Key: UnicodeString): TObject;\r\nvar\r\n I: Integer;\r\n Bucket: TJclUnicodeStrHashMapBucket;\r\n Found: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Found := False;\r\n Result := nil;\r\n Bucket := FBuckets[FHashToRangeFunction(Hash(Key), FCapacity)];\r\n if Bucket <> nil then\r\n for I := 0 to Bucket.Size - 1 do\r\n if KeysEqual(Bucket.Entries[I].Key, Key) then\r\n begin\r\n Result := Bucket.Entries[I].Value;\r\n Found := True;\r\n Break;\r\n end;\r\n if (not Found) and (not FReturnDefaultElements) then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclUnicodeStrHashMap.IsEmpty: Boolean;\r\nbegin\r\n Result := FSize = 0;\r\nend;\r\n\r\nfunction TJclUnicodeStrHashMap.KeyOfValue(Value: TObject): UnicodeString;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclUnicodeStrHashMapBucket;\r\n Found: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Found := False;\r\n Result := '';\r\n for J := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[J];\r\n if Bucket <> nil then\r\n for I := 0 to Bucket.Size - 1 do\r\n if ValuesEqual(Bucket.Entries[I].Value, Value) then\r\n begin\r\n Result := Bucket.Entries[I].Key;\r\n Found := True;\r\n Break;\r\n end;\r\n end;\r\n if (not Found) and (not FReturnDefaultElements) then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclUnicodeStrHashMap.KeySet: IJclUnicodeStrSet;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclUnicodeStrHashMapBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := TJclUnicodeStrArraySet.Create(FSize);\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n for J := 0 to Bucket.Size - 1 do\r\n Result.Add(Bucket.Entries[J].Key);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclUnicodeStrHashMap.MapEquals(const AMap: IJclUnicodeStrMap): Boolean;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclUnicodeStrHashMapBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if AMap = nil then\r\n Exit;\r\n if FSize <> AMap.Size then\r\n Exit;\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n for J := 0 to Bucket.Size - 1 do\r\n if AMap.ContainsKey(Bucket.Entries[J].Key) then\r\n begin\r\n if not ValuesEqual(AMap.GetValue(Bucket.Entries[J].Key), Bucket.Entries[J].Value) then\r\n Exit;\r\n end\r\n else\r\n Exit;\r\n end;\r\n Result := True;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclUnicodeStrHashMap.Pack;\r\nvar\r\n I: Integer;\r\n Bucket: TJclUnicodeStrHashMapBucket;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n begin\r\n if Bucket.Size > 0 then\r\n SetLength(Bucket.Entries, Bucket.Size)\r\n else\r\n FreeAndNil(FBuckets[I]);\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclUnicodeStrHashMap.PutAll(const AMap: IJclUnicodeStrMap);\r\nvar\r\n It: IJclUnicodeStrIterator;\r\n Key: UnicodeString;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if AMap = nil then\r\n Exit;\r\n It := AMap.KeySet.First;\r\n while It.HasNext do\r\n begin\r\n Key := It.Next;\r\n PutValue(Key, AMap.GetValue(Key));\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclUnicodeStrHashMap.PutValue(const Key: UnicodeString; Value: TObject);\r\nvar\r\n Index: Integer;\r\n Bucket: TJclUnicodeStrHashMapBucket;\r\n I: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FAllowDefaultElements or (not KeysEqual(Key, '') and not ValuesEqual(Value, nil)) then\r\n begin\r\n Index := FHashToRangeFunction(Hash(Key), FCapacity);\r\n Bucket := FBuckets[Index];\r\n if Bucket <> nil then\r\n begin\r\n for I := 0 to Bucket.Size - 1 do\r\n if KeysEqual(Bucket.Entries[I].Key, Key) then\r\n begin\r\n FreeValue(Bucket.Entries[I].Value);\r\n Bucket.Entries[I].Value := Value;\r\n Exit;\r\n end;\r\n end\r\n else\r\n begin\r\n Bucket := TJclUnicodeStrHashMapBucket.Create;\r\n SetLength(Bucket.Entries, 1);\r\n FBuckets[Index] := Bucket;\r\n end;\r\n\r\n if Bucket.Size = Length(Bucket.Entries) then\r\n SetLength(Bucket.Entries, CalcGrowCapacity(Bucket.Size, Bucket.Size));\r\n\r\n if Bucket.Size < Length(Bucket.Entries) then\r\n begin\r\n Bucket.Entries[Bucket.Size].Key := Key;\r\n Bucket.Entries[Bucket.Size].Value := Value;\r\n Inc(Bucket.Size);\r\n Inc(FSize);\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclUnicodeStrHashMap.Remove(const Key: UnicodeString): TObject;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := Extract(Key);\r\n Result := FreeValue(Result);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclUnicodeStrHashMap.SetCapacity(Value: Integer);\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FSize = 0 then\r\n begin\r\n SetLength(FBuckets, Value);\r\n inherited SetCapacity(Value);\r\n end\r\n else\r\n raise EJclOperationNotSupportedError.Create;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclUnicodeStrHashMap.Size: Integer;\r\nbegin\r\n Result := FSize;\r\nend;\r\n\r\nfunction TJclUnicodeStrHashMap.Values: IJclCollection;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclUnicodeStrHashMapBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := TJclArrayList.Create(FSize, False);\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n for J := 0 to Bucket.Size - 1 do\r\n Result.Add(Bucket.Entries[J].Value);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclUnicodeStrHashMap.CreateEmptyContainer: TJclAbstractContainerBase;\r\nbegin\r\n Result := TJclUnicodeStrHashMap.Create(FCapacity, False);\r\n AssignPropertiesTo(Result);\r\nend;\r\n\r\nfunction TJclUnicodeStrHashMap.FreeKey(var Key: UnicodeString): UnicodeString;\r\nbegin\r\n Result := Key;\r\n Key := '';\r\nend;\r\n\r\nfunction TJclUnicodeStrHashMap.FreeValue(var Value: TObject): TObject;\r\nbegin\r\n if FOwnsValues then\r\n begin\r\n Result := nil;\r\n FreeAndNil(Value);\r\n end\r\n else\r\n begin\r\n Result := Value;\r\n Value := nil;\r\n end;\r\nend;\r\n\r\nfunction TJclUnicodeStrHashMap.GetOwnsValues: Boolean;\r\nbegin\r\n Result := FOwnsValues;\r\nend;\r\n\r\nfunction TJclUnicodeStrHashMap.KeysEqual(const A, B: UnicodeString): Boolean;\r\nbegin\r\n Result := ItemsEqual(A, B);\r\nend;\r\n\r\nfunction TJclUnicodeStrHashMap.ValuesEqual(A, B: TObject): Boolean;\r\nbegin\r\n Result := SimpleEqualityCompare(A, B);\r\nend;\r\n\r\n{$ENDIF SUPPORTS_UNICODE_STRING}\r\n\r\n//=== { TJclSingleHashMapBucket } ==========================================\r\n\r\nprocedure TJclSingleHashMapBucket.InitializeArrayAfterMove(var List: TJclSingleHashMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\nbegin\r\n { Clean array }\r\n if FromIndex < ToIndex then\r\n begin\r\n if (ToIndex - FromIndex) < Count then\r\n Count := ToIndex - FromIndex;\r\n FillChar(List[FromIndex], Count * SizeOf(List[0]), 0);\r\n end\r\n else\r\n if FromIndex > ToIndex then\r\n begin\r\n if (FromIndex - ToIndex) < Count then\r\n FillChar(List[ToIndex + Count], (FromIndex - ToIndex) * SizeOf(List[0]), 0)\r\n else\r\n FillChar(List[FromIndex], Count * SizeOf(List[0]), 0);\r\n end;\r\nend;\r\n\r\nprocedure TJclSingleHashMapBucket.MoveArray(var List: TJclSingleHashMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\nbegin\r\n if Count > 0 then\r\n begin\r\n Move(List[FromIndex], List[ToIndex], Count * SizeOf(List[0]));\r\n InitializeArrayAfterMove(List, FromIndex, ToIndex, Count);\r\n end;\r\nend;\r\n\r\n//=== { TJclSingleHashMap } ==========================================\r\n\r\nconstructor TJclSingleHashMap.Create(ACapacity: Integer; AOwnsValues: Boolean);\r\nbegin\r\n inherited Create;\r\n FOwnsValues := AOwnsValues;\r\n SetCapacity(ACapacity);\r\n FHashToRangeFunction := JclSimpleHashToRange;\r\nend;\r\n\r\ndestructor TJclSingleHashMap.Destroy;\r\nbegin\r\n FReadOnly := False;\r\n Clear;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJclSingleHashMap.AssignDataTo(Dest: TJclAbstractContainerBase);\r\nvar\r\n I, J: Integer;\r\n SelfBucket, NewBucket: TJclSingleHashMapBucket;\r\n ADest: TJclSingleHashMap;\r\n AMap: IJclSingleMap;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n inherited AssignDataTo(Dest);\r\n if Dest is TJclSingleHashMap then\r\n begin\r\n ADest := TJclSingleHashMap(Dest);\r\n ADest.Clear;\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n SelfBucket := FBuckets[I];\r\n if SelfBucket <> nil then\r\n begin\r\n NewBucket := TJclSingleHashMapBucket.Create;\r\n SetLength(NewBucket.Entries, SelfBucket.Size);\r\n for J := 0 to SelfBucket.Size - 1 do\r\n begin\r\n NewBucket.Entries[J].Key := SelfBucket.Entries[J].Key;\r\n NewBucket.Entries[J].Value := SelfBucket.Entries[J].Value;\r\n end;\r\n NewBucket.Size := SelfBucket.Size;\r\n ADest.FBuckets[I] := NewBucket;\r\n end;\r\n end;\r\n end\r\n else\r\n if Supports(IInterface(Dest), IJclSingleMap, AMap) then\r\n begin\r\n AMap.Clear;\r\n AMap.PutAll(Self);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclSingleHashMap.AssignPropertiesTo(Dest: TJclAbstractContainerBase);\r\nbegin\r\n inherited AssignPropertiesto(Dest);\r\n if Dest is TJclSingleHashMap then\r\n TJclSingleHashMap(Dest).FHashToRangeFunction := FHashToRangeFunction;\r\nend;\r\n\r\nprocedure TJclSingleHashMap.Clear;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclSingleHashMapBucket;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n begin\r\n for J := 0 to Bucket.Size - 1 do\r\n begin\r\n FreeKey(Bucket.Entries[J].Key);\r\n FreeValue(Bucket.Entries[J].Value);\r\n end;\r\n FreeAndNil(FBuckets[I]);\r\n end;\r\n end;\r\n FSize := 0;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSingleHashMap.ContainsKey(const Key: Single): Boolean;\r\nvar\r\n I: Integer;\r\n Bucket: TJclSingleHashMapBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n Bucket := FBuckets[FHashToRangeFunction(Hash(Key), FCapacity)];\r\n if Bucket <> nil then\r\n for I := 0 to Bucket.Size - 1 do\r\n if KeysEqual(Bucket.Entries[I].Key, Key) then\r\n begin\r\n Result := True;\r\n Break;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSingleHashMap.ContainsValue(Value: TObject): Boolean;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclSingleHashMapBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n for J := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[J];\r\n if Bucket <> nil then\r\n for I := 0 to Bucket.Size - 1 do\r\n if ValuesEqual(Bucket.Entries[I].Value, Value) then\r\n begin\r\n Result := True;\r\n Break;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSingleHashMap.Extract(const Key: Single): TObject;\r\nvar\r\n Bucket: TJclSingleHashMapBucket;\r\n I, NewCapacity: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := nil;\r\n Bucket := FBuckets[FHashToRangeFunction(Hash(Key), FCapacity)];\r\n if Bucket <> nil then\r\n begin\r\n for I := 0 to Bucket.Size - 1 do\r\n if KeysEqual(Bucket.Entries[I].Key, Key) then\r\n begin\r\n Result := Bucket.Entries[I].Value;\r\n Bucket.Entries[I].Value := nil;\r\n FreeKey(Bucket.Entries[I].Key);\r\n if I < Length(Bucket.Entries) - 1 then\r\n Bucket.MoveArray(Bucket.Entries, I + 1, I, Bucket.Size - I - 1);\r\n Dec(Bucket.Size);\r\n Dec(FSize);\r\n Break;\r\n end;\r\n\r\n NewCapacity := CalcPackCapacity(Length(Bucket.Entries), Bucket.Size);\r\n if NewCapacity < Length(Bucket.Entries) then\r\n SetLength(Bucket.Entries, NewCapacity);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSingleHashMap.GetValue(const Key: Single): TObject;\r\nvar\r\n I: Integer;\r\n Bucket: TJclSingleHashMapBucket;\r\n Found: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Found := False;\r\n Result := nil;\r\n Bucket := FBuckets[FHashToRangeFunction(Hash(Key), FCapacity)];\r\n if Bucket <> nil then\r\n for I := 0 to Bucket.Size - 1 do\r\n if KeysEqual(Bucket.Entries[I].Key, Key) then\r\n begin\r\n Result := Bucket.Entries[I].Value;\r\n Found := True;\r\n Break;\r\n end;\r\n if (not Found) and (not FReturnDefaultElements) then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSingleHashMap.IsEmpty: Boolean;\r\nbegin\r\n Result := FSize = 0;\r\nend;\r\n\r\nfunction TJclSingleHashMap.KeyOfValue(Value: TObject): Single;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclSingleHashMapBucket;\r\n Found: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Found := False;\r\n Result := 0.0;\r\n for J := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[J];\r\n if Bucket <> nil then\r\n for I := 0 to Bucket.Size - 1 do\r\n if ValuesEqual(Bucket.Entries[I].Value, Value) then\r\n begin\r\n Result := Bucket.Entries[I].Key;\r\n Found := True;\r\n Break;\r\n end;\r\n end;\r\n if (not Found) and (not FReturnDefaultElements) then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSingleHashMap.KeySet: IJclSingleSet;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclSingleHashMapBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := TJclSingleArraySet.Create(FSize);\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n for J := 0 to Bucket.Size - 1 do\r\n Result.Add(Bucket.Entries[J].Key);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSingleHashMap.MapEquals(const AMap: IJclSingleMap): Boolean;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclSingleHashMapBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if AMap = nil then\r\n Exit;\r\n if FSize <> AMap.Size then\r\n Exit;\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n for J := 0 to Bucket.Size - 1 do\r\n if AMap.ContainsKey(Bucket.Entries[J].Key) then\r\n begin\r\n if not ValuesEqual(AMap.GetValue(Bucket.Entries[J].Key), Bucket.Entries[J].Value) then\r\n Exit;\r\n end\r\n else\r\n Exit;\r\n end;\r\n Result := True;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclSingleHashMap.Pack;\r\nvar\r\n I: Integer;\r\n Bucket: TJclSingleHashMapBucket;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n begin\r\n if Bucket.Size > 0 then\r\n SetLength(Bucket.Entries, Bucket.Size)\r\n else\r\n FreeAndNil(FBuckets[I]);\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclSingleHashMap.PutAll(const AMap: IJclSingleMap);\r\nvar\r\n It: IJclSingleIterator;\r\n Key: Single;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if AMap = nil then\r\n Exit;\r\n It := AMap.KeySet.First;\r\n while It.HasNext do\r\n begin\r\n Key := It.Next;\r\n PutValue(Key, AMap.GetValue(Key));\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclSingleHashMap.PutValue(const Key: Single; Value: TObject);\r\nvar\r\n Index: Integer;\r\n Bucket: TJclSingleHashMapBucket;\r\n I: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FAllowDefaultElements or (not KeysEqual(Key, 0.0) and not ValuesEqual(Value, nil)) then\r\n begin\r\n Index := FHashToRangeFunction(Hash(Key), FCapacity);\r\n Bucket := FBuckets[Index];\r\n if Bucket <> nil then\r\n begin\r\n for I := 0 to Bucket.Size - 1 do\r\n if KeysEqual(Bucket.Entries[I].Key, Key) then\r\n begin\r\n FreeValue(Bucket.Entries[I].Value);\r\n Bucket.Entries[I].Value := Value;\r\n Exit;\r\n end;\r\n end\r\n else\r\n begin\r\n Bucket := TJclSingleHashMapBucket.Create;\r\n SetLength(Bucket.Entries, 1);\r\n FBuckets[Index] := Bucket;\r\n end;\r\n\r\n if Bucket.Size = Length(Bucket.Entries) then\r\n SetLength(Bucket.Entries, CalcGrowCapacity(Bucket.Size, Bucket.Size));\r\n\r\n if Bucket.Size < Length(Bucket.Entries) then\r\n begin\r\n Bucket.Entries[Bucket.Size].Key := Key;\r\n Bucket.Entries[Bucket.Size].Value := Value;\r\n Inc(Bucket.Size);\r\n Inc(FSize);\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSingleHashMap.Remove(const Key: Single): TObject;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := Extract(Key);\r\n Result := FreeValue(Result);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclSingleHashMap.SetCapacity(Value: Integer);\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FSize = 0 then\r\n begin\r\n SetLength(FBuckets, Value);\r\n inherited SetCapacity(Value);\r\n end\r\n else\r\n raise EJclOperationNotSupportedError.Create;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSingleHashMap.Size: Integer;\r\nbegin\r\n Result := FSize;\r\nend;\r\n\r\nfunction TJclSingleHashMap.Values: IJclCollection;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclSingleHashMapBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := TJclArrayList.Create(FSize, False);\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n for J := 0 to Bucket.Size - 1 do\r\n Result.Add(Bucket.Entries[J].Value);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSingleHashMap.CreateEmptyContainer: TJclAbstractContainerBase;\r\nbegin\r\n Result := TJclSingleHashMap.Create(FCapacity, False);\r\n AssignPropertiesTo(Result);\r\nend;\r\n\r\nfunction TJclSingleHashMap.FreeKey(var Key: Single): Single;\r\nbegin\r\n Result := Key;\r\n Key := 0.0;\r\nend;\r\n\r\nfunction TJclSingleHashMap.FreeValue(var Value: TObject): TObject;\r\nbegin\r\n if FOwnsValues then\r\n begin\r\n Result := nil;\r\n FreeAndNil(Value);\r\n end\r\n else\r\n begin\r\n Result := Value;\r\n Value := nil;\r\n end;\r\nend;\r\n\r\nfunction TJclSingleHashMap.GetOwnsValues: Boolean;\r\nbegin\r\n Result := FOwnsValues;\r\nend;\r\n\r\nfunction TJclSingleHashMap.KeysEqual(const A, B: Single): Boolean;\r\nbegin\r\n Result := ItemsEqual(A, B);\r\nend;\r\n\r\nfunction TJclSingleHashMap.ValuesEqual(A, B: TObject): Boolean;\r\nbegin\r\n Result := SimpleEqualityCompare(A, B);\r\nend;\r\n\r\n//=== { TJclDoubleHashMapBucket } ==========================================\r\n\r\nprocedure TJclDoubleHashMapBucket.InitializeArrayAfterMove(var List: TJclDoubleHashMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\nbegin\r\n { Clean array }\r\n if FromIndex < ToIndex then\r\n begin\r\n if (ToIndex - FromIndex) < Count then\r\n Count := ToIndex - FromIndex;\r\n FillChar(List[FromIndex], Count * SizeOf(List[0]), 0);\r\n end\r\n else\r\n if FromIndex > ToIndex then\r\n begin\r\n if (FromIndex - ToIndex) < Count then\r\n FillChar(List[ToIndex + Count], (FromIndex - ToIndex) * SizeOf(List[0]), 0)\r\n else\r\n FillChar(List[FromIndex], Count * SizeOf(List[0]), 0);\r\n end;\r\nend;\r\n\r\nprocedure TJclDoubleHashMapBucket.MoveArray(var List: TJclDoubleHashMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\nbegin\r\n if Count > 0 then\r\n begin\r\n Move(List[FromIndex], List[ToIndex], Count * SizeOf(List[0]));\r\n InitializeArrayAfterMove(List, FromIndex, ToIndex, Count);\r\n end;\r\nend;\r\n\r\n//=== { TJclDoubleHashMap } ==========================================\r\n\r\nconstructor TJclDoubleHashMap.Create(ACapacity: Integer; AOwnsValues: Boolean);\r\nbegin\r\n inherited Create;\r\n FOwnsValues := AOwnsValues;\r\n SetCapacity(ACapacity);\r\n FHashToRangeFunction := JclSimpleHashToRange;\r\nend;\r\n\r\ndestructor TJclDoubleHashMap.Destroy;\r\nbegin\r\n FReadOnly := False;\r\n Clear;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJclDoubleHashMap.AssignDataTo(Dest: TJclAbstractContainerBase);\r\nvar\r\n I, J: Integer;\r\n SelfBucket, NewBucket: TJclDoubleHashMapBucket;\r\n ADest: TJclDoubleHashMap;\r\n AMap: IJclDoubleMap;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n inherited AssignDataTo(Dest);\r\n if Dest is TJclDoubleHashMap then\r\n begin\r\n ADest := TJclDoubleHashMap(Dest);\r\n ADest.Clear;\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n SelfBucket := FBuckets[I];\r\n if SelfBucket <> nil then\r\n begin\r\n NewBucket := TJclDoubleHashMapBucket.Create;\r\n SetLength(NewBucket.Entries, SelfBucket.Size);\r\n for J := 0 to SelfBucket.Size - 1 do\r\n begin\r\n NewBucket.Entries[J].Key := SelfBucket.Entries[J].Key;\r\n NewBucket.Entries[J].Value := SelfBucket.Entries[J].Value;\r\n end;\r\n NewBucket.Size := SelfBucket.Size;\r\n ADest.FBuckets[I] := NewBucket;\r\n end;\r\n end;\r\n end\r\n else\r\n if Supports(IInterface(Dest), IJclDoubleMap, AMap) then\r\n begin\r\n AMap.Clear;\r\n AMap.PutAll(Self);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclDoubleHashMap.AssignPropertiesTo(Dest: TJclAbstractContainerBase);\r\nbegin\r\n inherited AssignPropertiesto(Dest);\r\n if Dest is TJclDoubleHashMap then\r\n TJclDoubleHashMap(Dest).FHashToRangeFunction := FHashToRangeFunction;\r\nend;\r\n\r\nprocedure TJclDoubleHashMap.Clear;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclDoubleHashMapBucket;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n begin\r\n for J := 0 to Bucket.Size - 1 do\r\n begin\r\n FreeKey(Bucket.Entries[J].Key);\r\n FreeValue(Bucket.Entries[J].Value);\r\n end;\r\n FreeAndNil(FBuckets[I]);\r\n end;\r\n end;\r\n FSize := 0;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclDoubleHashMap.ContainsKey(const Key: Double): Boolean;\r\nvar\r\n I: Integer;\r\n Bucket: TJclDoubleHashMapBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n Bucket := FBuckets[FHashToRangeFunction(Hash(Key), FCapacity)];\r\n if Bucket <> nil then\r\n for I := 0 to Bucket.Size - 1 do\r\n if KeysEqual(Bucket.Entries[I].Key, Key) then\r\n begin\r\n Result := True;\r\n Break;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclDoubleHashMap.ContainsValue(Value: TObject): Boolean;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclDoubleHashMapBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n for J := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[J];\r\n if Bucket <> nil then\r\n for I := 0 to Bucket.Size - 1 do\r\n if ValuesEqual(Bucket.Entries[I].Value, Value) then\r\n begin\r\n Result := True;\r\n Break;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclDoubleHashMap.Extract(const Key: Double): TObject;\r\nvar\r\n Bucket: TJclDoubleHashMapBucket;\r\n I, NewCapacity: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := nil;\r\n Bucket := FBuckets[FHashToRangeFunction(Hash(Key), FCapacity)];\r\n if Bucket <> nil then\r\n begin\r\n for I := 0 to Bucket.Size - 1 do\r\n if KeysEqual(Bucket.Entries[I].Key, Key) then\r\n begin\r\n Result := Bucket.Entries[I].Value;\r\n Bucket.Entries[I].Value := nil;\r\n FreeKey(Bucket.Entries[I].Key);\r\n if I < Length(Bucket.Entries) - 1 then\r\n Bucket.MoveArray(Bucket.Entries, I + 1, I, Bucket.Size - I - 1);\r\n Dec(Bucket.Size);\r\n Dec(FSize);\r\n Break;\r\n end;\r\n\r\n NewCapacity := CalcPackCapacity(Length(Bucket.Entries), Bucket.Size);\r\n if NewCapacity < Length(Bucket.Entries) then\r\n SetLength(Bucket.Entries, NewCapacity);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclDoubleHashMap.GetValue(const Key: Double): TObject;\r\nvar\r\n I: Integer;\r\n Bucket: TJclDoubleHashMapBucket;\r\n Found: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Found := False;\r\n Result := nil;\r\n Bucket := FBuckets[FHashToRangeFunction(Hash(Key), FCapacity)];\r\n if Bucket <> nil then\r\n for I := 0 to Bucket.Size - 1 do\r\n if KeysEqual(Bucket.Entries[I].Key, Key) then\r\n begin\r\n Result := Bucket.Entries[I].Value;\r\n Found := True;\r\n Break;\r\n end;\r\n if (not Found) and (not FReturnDefaultElements) then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclDoubleHashMap.IsEmpty: Boolean;\r\nbegin\r\n Result := FSize = 0;\r\nend;\r\n\r\nfunction TJclDoubleHashMap.KeyOfValue(Value: TObject): Double;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclDoubleHashMapBucket;\r\n Found: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Found := False;\r\n Result := 0.0;\r\n for J := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[J];\r\n if Bucket <> nil then\r\n for I := 0 to Bucket.Size - 1 do\r\n if ValuesEqual(Bucket.Entries[I].Value, Value) then\r\n begin\r\n Result := Bucket.Entries[I].Key;\r\n Found := True;\r\n Break;\r\n end;\r\n end;\r\n if (not Found) and (not FReturnDefaultElements) then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclDoubleHashMap.KeySet: IJclDoubleSet;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclDoubleHashMapBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := TJclDoubleArraySet.Create(FSize);\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n for J := 0 to Bucket.Size - 1 do\r\n Result.Add(Bucket.Entries[J].Key);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclDoubleHashMap.MapEquals(const AMap: IJclDoubleMap): Boolean;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclDoubleHashMapBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if AMap = nil then\r\n Exit;\r\n if FSize <> AMap.Size then\r\n Exit;\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n for J := 0 to Bucket.Size - 1 do\r\n if AMap.ContainsKey(Bucket.Entries[J].Key) then\r\n begin\r\n if not ValuesEqual(AMap.GetValue(Bucket.Entries[J].Key), Bucket.Entries[J].Value) then\r\n Exit;\r\n end\r\n else\r\n Exit;\r\n end;\r\n Result := True;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclDoubleHashMap.Pack;\r\nvar\r\n I: Integer;\r\n Bucket: TJclDoubleHashMapBucket;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n begin\r\n if Bucket.Size > 0 then\r\n SetLength(Bucket.Entries, Bucket.Size)\r\n else\r\n FreeAndNil(FBuckets[I]);\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclDoubleHashMap.PutAll(const AMap: IJclDoubleMap);\r\nvar\r\n It: IJclDoubleIterator;\r\n Key: Double;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if AMap = nil then\r\n Exit;\r\n It := AMap.KeySet.First;\r\n while It.HasNext do\r\n begin\r\n Key := It.Next;\r\n PutValue(Key, AMap.GetValue(Key));\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclDoubleHashMap.PutValue(const Key: Double; Value: TObject);\r\nvar\r\n Index: Integer;\r\n Bucket: TJclDoubleHashMapBucket;\r\n I: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FAllowDefaultElements or (not KeysEqual(Key, 0.0) and not ValuesEqual(Value, nil)) then\r\n begin\r\n Index := FHashToRangeFunction(Hash(Key), FCapacity);\r\n Bucket := FBuckets[Index];\r\n if Bucket <> nil then\r\n begin\r\n for I := 0 to Bucket.Size - 1 do\r\n if KeysEqual(Bucket.Entries[I].Key, Key) then\r\n begin\r\n FreeValue(Bucket.Entries[I].Value);\r\n Bucket.Entries[I].Value := Value;\r\n Exit;\r\n end;\r\n end\r\n else\r\n begin\r\n Bucket := TJclDoubleHashMapBucket.Create;\r\n SetLength(Bucket.Entries, 1);\r\n FBuckets[Index] := Bucket;\r\n end;\r\n\r\n if Bucket.Size = Length(Bucket.Entries) then\r\n SetLength(Bucket.Entries, CalcGrowCapacity(Bucket.Size, Bucket.Size));\r\n\r\n if Bucket.Size < Length(Bucket.Entries) then\r\n begin\r\n Bucket.Entries[Bucket.Size].Key := Key;\r\n Bucket.Entries[Bucket.Size].Value := Value;\r\n Inc(Bucket.Size);\r\n Inc(FSize);\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclDoubleHashMap.Remove(const Key: Double): TObject;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := Extract(Key);\r\n Result := FreeValue(Result);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclDoubleHashMap.SetCapacity(Value: Integer);\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FSize = 0 then\r\n begin\r\n SetLength(FBuckets, Value);\r\n inherited SetCapacity(Value);\r\n end\r\n else\r\n raise EJclOperationNotSupportedError.Create;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclDoubleHashMap.Size: Integer;\r\nbegin\r\n Result := FSize;\r\nend;\r\n\r\nfunction TJclDoubleHashMap.Values: IJclCollection;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclDoubleHashMapBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := TJclArrayList.Create(FSize, False);\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n for J := 0 to Bucket.Size - 1 do\r\n Result.Add(Bucket.Entries[J].Value);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclDoubleHashMap.CreateEmptyContainer: TJclAbstractContainerBase;\r\nbegin\r\n Result := TJclDoubleHashMap.Create(FCapacity, False);\r\n AssignPropertiesTo(Result);\r\nend;\r\n\r\nfunction TJclDoubleHashMap.FreeKey(var Key: Double): Double;\r\nbegin\r\n Result := Key;\r\n Key := 0.0;\r\nend;\r\n\r\nfunction TJclDoubleHashMap.FreeValue(var Value: TObject): TObject;\r\nbegin\r\n if FOwnsValues then\r\n begin\r\n Result := nil;\r\n FreeAndNil(Value);\r\n end\r\n else\r\n begin\r\n Result := Value;\r\n Value := nil;\r\n end;\r\nend;\r\n\r\nfunction TJclDoubleHashMap.GetOwnsValues: Boolean;\r\nbegin\r\n Result := FOwnsValues;\r\nend;\r\n\r\nfunction TJclDoubleHashMap.KeysEqual(const A, B: Double): Boolean;\r\nbegin\r\n Result := ItemsEqual(A, B);\r\nend;\r\n\r\nfunction TJclDoubleHashMap.ValuesEqual(A, B: TObject): Boolean;\r\nbegin\r\n Result := SimpleEqualityCompare(A, B);\r\nend;\r\n\r\n//=== { TJclExtendedHashMapBucket } ==========================================\r\n\r\nprocedure TJclExtendedHashMapBucket.InitializeArrayAfterMove(var List: TJclExtendedHashMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\nbegin\r\n { Clean array }\r\n if FromIndex < ToIndex then\r\n begin\r\n if (ToIndex - FromIndex) < Count then\r\n Count := ToIndex - FromIndex;\r\n FillChar(List[FromIndex], Count * SizeOf(List[0]), 0);\r\n end\r\n else\r\n if FromIndex > ToIndex then\r\n begin\r\n if (FromIndex - ToIndex) < Count then\r\n FillChar(List[ToIndex + Count], (FromIndex - ToIndex) * SizeOf(List[0]), 0)\r\n else\r\n FillChar(List[FromIndex], Count * SizeOf(List[0]), 0);\r\n end;\r\nend;\r\n\r\nprocedure TJclExtendedHashMapBucket.MoveArray(var List: TJclExtendedHashMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\nbegin\r\n if Count > 0 then\r\n begin\r\n Move(List[FromIndex], List[ToIndex], Count * SizeOf(List[0]));\r\n InitializeArrayAfterMove(List, FromIndex, ToIndex, Count);\r\n end;\r\nend;\r\n\r\n//=== { TJclExtendedHashMap } ==========================================\r\n\r\nconstructor TJclExtendedHashMap.Create(ACapacity: Integer; AOwnsValues: Boolean);\r\nbegin\r\n inherited Create;\r\n FOwnsValues := AOwnsValues;\r\n SetCapacity(ACapacity);\r\n FHashToRangeFunction := JclSimpleHashToRange;\r\nend;\r\n\r\ndestructor TJclExtendedHashMap.Destroy;\r\nbegin\r\n FReadOnly := False;\r\n Clear;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJclExtendedHashMap.AssignDataTo(Dest: TJclAbstractContainerBase);\r\nvar\r\n I, J: Integer;\r\n SelfBucket, NewBucket: TJclExtendedHashMapBucket;\r\n ADest: TJclExtendedHashMap;\r\n AMap: IJclExtendedMap;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n inherited AssignDataTo(Dest);\r\n if Dest is TJclExtendedHashMap then\r\n begin\r\n ADest := TJclExtendedHashMap(Dest);\r\n ADest.Clear;\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n SelfBucket := FBuckets[I];\r\n if SelfBucket <> nil then\r\n begin\r\n NewBucket := TJclExtendedHashMapBucket.Create;\r\n SetLength(NewBucket.Entries, SelfBucket.Size);\r\n for J := 0 to SelfBucket.Size - 1 do\r\n begin\r\n NewBucket.Entries[J].Key := SelfBucket.Entries[J].Key;\r\n NewBucket.Entries[J].Value := SelfBucket.Entries[J].Value;\r\n end;\r\n NewBucket.Size := SelfBucket.Size;\r\n ADest.FBuckets[I] := NewBucket;\r\n end;\r\n end;\r\n end\r\n else\r\n if Supports(IInterface(Dest), IJclExtendedMap, AMap) then\r\n begin\r\n AMap.Clear;\r\n AMap.PutAll(Self);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclExtendedHashMap.AssignPropertiesTo(Dest: TJclAbstractContainerBase);\r\nbegin\r\n inherited AssignPropertiesto(Dest);\r\n if Dest is TJclExtendedHashMap then\r\n TJclExtendedHashMap(Dest).FHashToRangeFunction := FHashToRangeFunction;\r\nend;\r\n\r\nprocedure TJclExtendedHashMap.Clear;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclExtendedHashMapBucket;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n begin\r\n for J := 0 to Bucket.Size - 1 do\r\n begin\r\n FreeKey(Bucket.Entries[J].Key);\r\n FreeValue(Bucket.Entries[J].Value);\r\n end;\r\n FreeAndNil(FBuckets[I]);\r\n end;\r\n end;\r\n FSize := 0;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclExtendedHashMap.ContainsKey(const Key: Extended): Boolean;\r\nvar\r\n I: Integer;\r\n Bucket: TJclExtendedHashMapBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n Bucket := FBuckets[FHashToRangeFunction(Hash(Key), FCapacity)];\r\n if Bucket <> nil then\r\n for I := 0 to Bucket.Size - 1 do\r\n if KeysEqual(Bucket.Entries[I].Key, Key) then\r\n begin\r\n Result := True;\r\n Break;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclExtendedHashMap.ContainsValue(Value: TObject): Boolean;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclExtendedHashMapBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n for J := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[J];\r\n if Bucket <> nil then\r\n for I := 0 to Bucket.Size - 1 do\r\n if ValuesEqual(Bucket.Entries[I].Value, Value) then\r\n begin\r\n Result := True;\r\n Break;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclExtendedHashMap.Extract(const Key: Extended): TObject;\r\nvar\r\n Bucket: TJclExtendedHashMapBucket;\r\n I, NewCapacity: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := nil;\r\n Bucket := FBuckets[FHashToRangeFunction(Hash(Key), FCapacity)];\r\n if Bucket <> nil then\r\n begin\r\n for I := 0 to Bucket.Size - 1 do\r\n if KeysEqual(Bucket.Entries[I].Key, Key) then\r\n begin\r\n Result := Bucket.Entries[I].Value;\r\n Bucket.Entries[I].Value := nil;\r\n FreeKey(Bucket.Entries[I].Key);\r\n if I < Length(Bucket.Entries) - 1 then\r\n Bucket.MoveArray(Bucket.Entries, I + 1, I, Bucket.Size - I - 1);\r\n Dec(Bucket.Size);\r\n Dec(FSize);\r\n Break;\r\n end;\r\n\r\n NewCapacity := CalcPackCapacity(Length(Bucket.Entries), Bucket.Size);\r\n if NewCapacity < Length(Bucket.Entries) then\r\n SetLength(Bucket.Entries, NewCapacity);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclExtendedHashMap.GetValue(const Key: Extended): TObject;\r\nvar\r\n I: Integer;\r\n Bucket: TJclExtendedHashMapBucket;\r\n Found: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Found := False;\r\n Result := nil;\r\n Bucket := FBuckets[FHashToRangeFunction(Hash(Key), FCapacity)];\r\n if Bucket <> nil then\r\n for I := 0 to Bucket.Size - 1 do\r\n if KeysEqual(Bucket.Entries[I].Key, Key) then\r\n begin\r\n Result := Bucket.Entries[I].Value;\r\n Found := True;\r\n Break;\r\n end;\r\n if (not Found) and (not FReturnDefaultElements) then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclExtendedHashMap.IsEmpty: Boolean;\r\nbegin\r\n Result := FSize = 0;\r\nend;\r\n\r\nfunction TJclExtendedHashMap.KeyOfValue(Value: TObject): Extended;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclExtendedHashMapBucket;\r\n Found: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Found := False;\r\n Result := 0.0;\r\n for J := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[J];\r\n if Bucket <> nil then\r\n for I := 0 to Bucket.Size - 1 do\r\n if ValuesEqual(Bucket.Entries[I].Value, Value) then\r\n begin\r\n Result := Bucket.Entries[I].Key;\r\n Found := True;\r\n Break;\r\n end;\r\n end;\r\n if (not Found) and (not FReturnDefaultElements) then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclExtendedHashMap.KeySet: IJclExtendedSet;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclExtendedHashMapBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := TJclExtendedArraySet.Create(FSize);\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n for J := 0 to Bucket.Size - 1 do\r\n Result.Add(Bucket.Entries[J].Key);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclExtendedHashMap.MapEquals(const AMap: IJclExtendedMap): Boolean;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclExtendedHashMapBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if AMap = nil then\r\n Exit;\r\n if FSize <> AMap.Size then\r\n Exit;\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n for J := 0 to Bucket.Size - 1 do\r\n if AMap.ContainsKey(Bucket.Entries[J].Key) then\r\n begin\r\n if not ValuesEqual(AMap.GetValue(Bucket.Entries[J].Key), Bucket.Entries[J].Value) then\r\n Exit;\r\n end\r\n else\r\n Exit;\r\n end;\r\n Result := True;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclExtendedHashMap.Pack;\r\nvar\r\n I: Integer;\r\n Bucket: TJclExtendedHashMapBucket;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n begin\r\n if Bucket.Size > 0 then\r\n SetLength(Bucket.Entries, Bucket.Size)\r\n else\r\n FreeAndNil(FBuckets[I]);\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclExtendedHashMap.PutAll(const AMap: IJclExtendedMap);\r\nvar\r\n It: IJclExtendedIterator;\r\n Key: Extended;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if AMap = nil then\r\n Exit;\r\n It := AMap.KeySet.First;\r\n while It.HasNext do\r\n begin\r\n Key := It.Next;\r\n PutValue(Key, AMap.GetValue(Key));\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclExtendedHashMap.PutValue(const Key: Extended; Value: TObject);\r\nvar\r\n Index: Integer;\r\n Bucket: TJclExtendedHashMapBucket;\r\n I: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FAllowDefaultElements or (not KeysEqual(Key, 0.0) and not ValuesEqual(Value, nil)) then\r\n begin\r\n Index := FHashToRangeFunction(Hash(Key), FCapacity);\r\n Bucket := FBuckets[Index];\r\n if Bucket <> nil then\r\n begin\r\n for I := 0 to Bucket.Size - 1 do\r\n if KeysEqual(Bucket.Entries[I].Key, Key) then\r\n begin\r\n FreeValue(Bucket.Entries[I].Value);\r\n Bucket.Entries[I].Value := Value;\r\n Exit;\r\n end;\r\n end\r\n else\r\n begin\r\n Bucket := TJclExtendedHashMapBucket.Create;\r\n SetLength(Bucket.Entries, 1);\r\n FBuckets[Index] := Bucket;\r\n end;\r\n\r\n if Bucket.Size = Length(Bucket.Entries) then\r\n SetLength(Bucket.Entries, CalcGrowCapacity(Bucket.Size, Bucket.Size));\r\n\r\n if Bucket.Size < Length(Bucket.Entries) then\r\n begin\r\n Bucket.Entries[Bucket.Size].Key := Key;\r\n Bucket.Entries[Bucket.Size].Value := Value;\r\n Inc(Bucket.Size);\r\n Inc(FSize);\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclExtendedHashMap.Remove(const Key: Extended): TObject;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := Extract(Key);\r\n Result := FreeValue(Result);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclExtendedHashMap.SetCapacity(Value: Integer);\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FSize = 0 then\r\n begin\r\n SetLength(FBuckets, Value);\r\n inherited SetCapacity(Value);\r\n end\r\n else\r\n raise EJclOperationNotSupportedError.Create;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclExtendedHashMap.Size: Integer;\r\nbegin\r\n Result := FSize;\r\nend;\r\n\r\nfunction TJclExtendedHashMap.Values: IJclCollection;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclExtendedHashMapBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := TJclArrayList.Create(FSize, False);\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n for J := 0 to Bucket.Size - 1 do\r\n Result.Add(Bucket.Entries[J].Value);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclExtendedHashMap.CreateEmptyContainer: TJclAbstractContainerBase;\r\nbegin\r\n Result := TJclExtendedHashMap.Create(FCapacity, False);\r\n AssignPropertiesTo(Result);\r\nend;\r\n\r\nfunction TJclExtendedHashMap.FreeKey(var Key: Extended): Extended;\r\nbegin\r\n Result := Key;\r\n Key := 0.0;\r\nend;\r\n\r\nfunction TJclExtendedHashMap.FreeValue(var Value: TObject): TObject;\r\nbegin\r\n if FOwnsValues then\r\n begin\r\n Result := nil;\r\n FreeAndNil(Value);\r\n end\r\n else\r\n begin\r\n Result := Value;\r\n Value := nil;\r\n end;\r\nend;\r\n\r\nfunction TJclExtendedHashMap.GetOwnsValues: Boolean;\r\nbegin\r\n Result := FOwnsValues;\r\nend;\r\n\r\nfunction TJclExtendedHashMap.KeysEqual(const A, B: Extended): Boolean;\r\nbegin\r\n Result := ItemsEqual(A, B);\r\nend;\r\n\r\nfunction TJclExtendedHashMap.ValuesEqual(A, B: TObject): Boolean;\r\nbegin\r\n Result := SimpleEqualityCompare(A, B);\r\nend;\r\n\r\n//=== { TJclIntegerHashMapBucket } ==========================================\r\n\r\nprocedure TJclIntegerHashMapBucket.InitializeArrayAfterMove(var List: TJclIntegerHashMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\nbegin\r\n { Clean array }\r\n if FromIndex < ToIndex then\r\n begin\r\n if (ToIndex - FromIndex) < Count then\r\n Count := ToIndex - FromIndex;\r\n FillChar(List[FromIndex], Count * SizeOf(List[0]), 0);\r\n end\r\n else\r\n if FromIndex > ToIndex then\r\n begin\r\n if (FromIndex - ToIndex) < Count then\r\n FillChar(List[ToIndex + Count], (FromIndex - ToIndex) * SizeOf(List[0]), 0)\r\n else\r\n FillChar(List[FromIndex], Count * SizeOf(List[0]), 0);\r\n end;\r\nend;\r\n\r\nprocedure TJclIntegerHashMapBucket.MoveArray(var List: TJclIntegerHashMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\nbegin\r\n if Count > 0 then\r\n begin\r\n Move(List[FromIndex], List[ToIndex], Count * SizeOf(List[0]));\r\n InitializeArrayAfterMove(List, FromIndex, ToIndex, Count);\r\n end;\r\nend;\r\n\r\n//=== { TJclIntegerHashMap } ==========================================\r\n\r\nconstructor TJclIntegerHashMap.Create(ACapacity: Integer; AOwnsValues: Boolean);\r\nbegin\r\n inherited Create;\r\n FOwnsValues := AOwnsValues;\r\n SetCapacity(ACapacity);\r\n FHashToRangeFunction := JclSimpleHashToRange;\r\nend;\r\n\r\ndestructor TJclIntegerHashMap.Destroy;\r\nbegin\r\n FReadOnly := False;\r\n Clear;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJclIntegerHashMap.AssignDataTo(Dest: TJclAbstractContainerBase);\r\nvar\r\n I, J: Integer;\r\n SelfBucket, NewBucket: TJclIntegerHashMapBucket;\r\n ADest: TJclIntegerHashMap;\r\n AMap: IJclIntegerMap;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n inherited AssignDataTo(Dest);\r\n if Dest is TJclIntegerHashMap then\r\n begin\r\n ADest := TJclIntegerHashMap(Dest);\r\n ADest.Clear;\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n SelfBucket := FBuckets[I];\r\n if SelfBucket <> nil then\r\n begin\r\n NewBucket := TJclIntegerHashMapBucket.Create;\r\n SetLength(NewBucket.Entries, SelfBucket.Size);\r\n for J := 0 to SelfBucket.Size - 1 do\r\n begin\r\n NewBucket.Entries[J].Key := SelfBucket.Entries[J].Key;\r\n NewBucket.Entries[J].Value := SelfBucket.Entries[J].Value;\r\n end;\r\n NewBucket.Size := SelfBucket.Size;\r\n ADest.FBuckets[I] := NewBucket;\r\n end;\r\n end;\r\n end\r\n else\r\n if Supports(IInterface(Dest), IJclIntegerMap, AMap) then\r\n begin\r\n AMap.Clear;\r\n AMap.PutAll(Self);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclIntegerHashMap.AssignPropertiesTo(Dest: TJclAbstractContainerBase);\r\nbegin\r\n inherited AssignPropertiesto(Dest);\r\n if Dest is TJclIntegerHashMap then\r\n TJclIntegerHashMap(Dest).FHashToRangeFunction := FHashToRangeFunction;\r\nend;\r\n\r\nprocedure TJclIntegerHashMap.Clear;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclIntegerHashMapBucket;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n begin\r\n for J := 0 to Bucket.Size - 1 do\r\n begin\r\n FreeKey(Bucket.Entries[J].Key);\r\n FreeValue(Bucket.Entries[J].Value);\r\n end;\r\n FreeAndNil(FBuckets[I]);\r\n end;\r\n end;\r\n FSize := 0;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntegerHashMap.ContainsKey(Key: Integer): Boolean;\r\nvar\r\n I: Integer;\r\n Bucket: TJclIntegerHashMapBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n Bucket := FBuckets[FHashToRangeFunction(Hash(Key), FCapacity)];\r\n if Bucket <> nil then\r\n for I := 0 to Bucket.Size - 1 do\r\n if KeysEqual(Bucket.Entries[I].Key, Key) then\r\n begin\r\n Result := True;\r\n Break;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntegerHashMap.ContainsValue(Value: TObject): Boolean;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclIntegerHashMapBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n for J := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[J];\r\n if Bucket <> nil then\r\n for I := 0 to Bucket.Size - 1 do\r\n if ValuesEqual(Bucket.Entries[I].Value, Value) then\r\n begin\r\n Result := True;\r\n Break;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntegerHashMap.Extract(Key: Integer): TObject;\r\nvar\r\n Bucket: TJclIntegerHashMapBucket;\r\n I, NewCapacity: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := nil;\r\n Bucket := FBuckets[FHashToRangeFunction(Hash(Key), FCapacity)];\r\n if Bucket <> nil then\r\n begin\r\n for I := 0 to Bucket.Size - 1 do\r\n if KeysEqual(Bucket.Entries[I].Key, Key) then\r\n begin\r\n Result := Bucket.Entries[I].Value;\r\n Bucket.Entries[I].Value := nil;\r\n FreeKey(Bucket.Entries[I].Key);\r\n if I < Length(Bucket.Entries) - 1 then\r\n Bucket.MoveArray(Bucket.Entries, I + 1, I, Bucket.Size - I - 1);\r\n Dec(Bucket.Size);\r\n Dec(FSize);\r\n Break;\r\n end;\r\n\r\n NewCapacity := CalcPackCapacity(Length(Bucket.Entries), Bucket.Size);\r\n if NewCapacity < Length(Bucket.Entries) then\r\n SetLength(Bucket.Entries, NewCapacity);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntegerHashMap.GetValue(Key: Integer): TObject;\r\nvar\r\n I: Integer;\r\n Bucket: TJclIntegerHashMapBucket;\r\n Found: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Found := False;\r\n Result := nil;\r\n Bucket := FBuckets[FHashToRangeFunction(Hash(Key), FCapacity)];\r\n if Bucket <> nil then\r\n for I := 0 to Bucket.Size - 1 do\r\n if KeysEqual(Bucket.Entries[I].Key, Key) then\r\n begin\r\n Result := Bucket.Entries[I].Value;\r\n Found := True;\r\n Break;\r\n end;\r\n if (not Found) and (not FReturnDefaultElements) then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntegerHashMap.IsEmpty: Boolean;\r\nbegin\r\n Result := FSize = 0;\r\nend;\r\n\r\nfunction TJclIntegerHashMap.KeyOfValue(Value: TObject): Integer;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclIntegerHashMapBucket;\r\n Found: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Found := False;\r\n Result := 0;\r\n for J := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[J];\r\n if Bucket <> nil then\r\n for I := 0 to Bucket.Size - 1 do\r\n if ValuesEqual(Bucket.Entries[I].Value, Value) then\r\n begin\r\n Result := Bucket.Entries[I].Key;\r\n Found := True;\r\n Break;\r\n end;\r\n end;\r\n if (not Found) and (not FReturnDefaultElements) then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntegerHashMap.KeySet: IJclIntegerSet;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclIntegerHashMapBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := TJclIntegerArraySet.Create(FSize);\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n for J := 0 to Bucket.Size - 1 do\r\n Result.Add(Bucket.Entries[J].Key);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntegerHashMap.MapEquals(const AMap: IJclIntegerMap): Boolean;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclIntegerHashMapBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if AMap = nil then\r\n Exit;\r\n if FSize <> AMap.Size then\r\n Exit;\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n for J := 0 to Bucket.Size - 1 do\r\n if AMap.ContainsKey(Bucket.Entries[J].Key) then\r\n begin\r\n if not ValuesEqual(AMap.GetValue(Bucket.Entries[J].Key), Bucket.Entries[J].Value) then\r\n Exit;\r\n end\r\n else\r\n Exit;\r\n end;\r\n Result := True;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclIntegerHashMap.Pack;\r\nvar\r\n I: Integer;\r\n Bucket: TJclIntegerHashMapBucket;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n begin\r\n if Bucket.Size > 0 then\r\n SetLength(Bucket.Entries, Bucket.Size)\r\n else\r\n FreeAndNil(FBuckets[I]);\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclIntegerHashMap.PutAll(const AMap: IJclIntegerMap);\r\nvar\r\n It: IJclIntegerIterator;\r\n Key: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if AMap = nil then\r\n Exit;\r\n It := AMap.KeySet.First;\r\n while It.HasNext do\r\n begin\r\n Key := It.Next;\r\n PutValue(Key, AMap.GetValue(Key));\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclIntegerHashMap.PutValue(Key: Integer; Value: TObject);\r\nvar\r\n Index: Integer;\r\n Bucket: TJclIntegerHashMapBucket;\r\n I: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FAllowDefaultElements or (not KeysEqual(Key, 0) and not ValuesEqual(Value, nil)) then\r\n begin\r\n Index := FHashToRangeFunction(Hash(Key), FCapacity);\r\n Bucket := FBuckets[Index];\r\n if Bucket <> nil then\r\n begin\r\n for I := 0 to Bucket.Size - 1 do\r\n if KeysEqual(Bucket.Entries[I].Key, Key) then\r\n begin\r\n FreeValue(Bucket.Entries[I].Value);\r\n Bucket.Entries[I].Value := Value;\r\n Exit;\r\n end;\r\n end\r\n else\r\n begin\r\n Bucket := TJclIntegerHashMapBucket.Create;\r\n SetLength(Bucket.Entries, 1);\r\n FBuckets[Index] := Bucket;\r\n end;\r\n\r\n if Bucket.Size = Length(Bucket.Entries) then\r\n SetLength(Bucket.Entries, CalcGrowCapacity(Bucket.Size, Bucket.Size));\r\n\r\n if Bucket.Size < Length(Bucket.Entries) then\r\n begin\r\n Bucket.Entries[Bucket.Size].Key := Key;\r\n Bucket.Entries[Bucket.Size].Value := Value;\r\n Inc(Bucket.Size);\r\n Inc(FSize);\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntegerHashMap.Remove(Key: Integer): TObject;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := Extract(Key);\r\n Result := FreeValue(Result);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclIntegerHashMap.SetCapacity(Value: Integer);\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FSize = 0 then\r\n begin\r\n SetLength(FBuckets, Value);\r\n inherited SetCapacity(Value);\r\n end\r\n else\r\n raise EJclOperationNotSupportedError.Create;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntegerHashMap.Size: Integer;\r\nbegin\r\n Result := FSize;\r\nend;\r\n\r\nfunction TJclIntegerHashMap.Values: IJclCollection;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclIntegerHashMapBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := TJclArrayList.Create(FSize, False);\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n for J := 0 to Bucket.Size - 1 do\r\n Result.Add(Bucket.Entries[J].Value);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntegerHashMap.CreateEmptyContainer: TJclAbstractContainerBase;\r\nbegin\r\n Result := TJclIntegerHashMap.Create(FCapacity, False);\r\n AssignPropertiesTo(Result);\r\nend;\r\n\r\nfunction TJclIntegerHashMap.FreeKey(var Key: Integer): Integer;\r\nbegin\r\n Result := Key;\r\n Key := 0;\r\nend;\r\n\r\nfunction TJclIntegerHashMap.FreeValue(var Value: TObject): TObject;\r\nbegin\r\n if FOwnsValues then\r\n begin\r\n Result := nil;\r\n FreeAndNil(Value);\r\n end\r\n else\r\n begin\r\n Result := Value;\r\n Value := nil;\r\n end;\r\nend;\r\n\r\nfunction TJclIntegerHashMap.GetOwnsValues: Boolean;\r\nbegin\r\n Result := FOwnsValues;\r\nend;\r\n\r\nfunction TJclIntegerHashMap.KeysEqual(A, B: Integer): Boolean;\r\nbegin\r\n Result := ItemsEqual(A, B);\r\nend;\r\n\r\nfunction TJclIntegerHashMap.ValuesEqual(A, B: TObject): Boolean;\r\nbegin\r\n Result := SimpleEqualityCompare(A, B);\r\nend;\r\n\r\n//=== { TJclCardinalHashMapBucket } ==========================================\r\n\r\nprocedure TJclCardinalHashMapBucket.InitializeArrayAfterMove(var List: TJclCardinalHashMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\nbegin\r\n { Clean array }\r\n if FromIndex < ToIndex then\r\n begin\r\n if (ToIndex - FromIndex) < Count then\r\n Count := ToIndex - FromIndex;\r\n FillChar(List[FromIndex], Count * SizeOf(List[0]), 0);\r\n end\r\n else\r\n if FromIndex > ToIndex then\r\n begin\r\n if (FromIndex - ToIndex) < Count then\r\n FillChar(List[ToIndex + Count], (FromIndex - ToIndex) * SizeOf(List[0]), 0)\r\n else\r\n FillChar(List[FromIndex], Count * SizeOf(List[0]), 0);\r\n end;\r\nend;\r\n\r\nprocedure TJclCardinalHashMapBucket.MoveArray(var List: TJclCardinalHashMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\nbegin\r\n if Count > 0 then\r\n begin\r\n Move(List[FromIndex], List[ToIndex], Count * SizeOf(List[0]));\r\n InitializeArrayAfterMove(List, FromIndex, ToIndex, Count);\r\n end;\r\nend;\r\n\r\n//=== { TJclCardinalHashMap } ==========================================\r\n\r\nconstructor TJclCardinalHashMap.Create(ACapacity: Integer; AOwnsValues: Boolean);\r\nbegin\r\n inherited Create;\r\n FOwnsValues := AOwnsValues;\r\n SetCapacity(ACapacity);\r\n FHashToRangeFunction := JclSimpleHashToRange;\r\nend;\r\n\r\ndestructor TJclCardinalHashMap.Destroy;\r\nbegin\r\n FReadOnly := False;\r\n Clear;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJclCardinalHashMap.AssignDataTo(Dest: TJclAbstractContainerBase);\r\nvar\r\n I, J: Integer;\r\n SelfBucket, NewBucket: TJclCardinalHashMapBucket;\r\n ADest: TJclCardinalHashMap;\r\n AMap: IJclCardinalMap;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n inherited AssignDataTo(Dest);\r\n if Dest is TJclCardinalHashMap then\r\n begin\r\n ADest := TJclCardinalHashMap(Dest);\r\n ADest.Clear;\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n SelfBucket := FBuckets[I];\r\n if SelfBucket <> nil then\r\n begin\r\n NewBucket := TJclCardinalHashMapBucket.Create;\r\n SetLength(NewBucket.Entries, SelfBucket.Size);\r\n for J := 0 to SelfBucket.Size - 1 do\r\n begin\r\n NewBucket.Entries[J].Key := SelfBucket.Entries[J].Key;\r\n NewBucket.Entries[J].Value := SelfBucket.Entries[J].Value;\r\n end;\r\n NewBucket.Size := SelfBucket.Size;\r\n ADest.FBuckets[I] := NewBucket;\r\n end;\r\n end;\r\n end\r\n else\r\n if Supports(IInterface(Dest), IJclCardinalMap, AMap) then\r\n begin\r\n AMap.Clear;\r\n AMap.PutAll(Self);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclCardinalHashMap.AssignPropertiesTo(Dest: TJclAbstractContainerBase);\r\nbegin\r\n inherited AssignPropertiesto(Dest);\r\n if Dest is TJclCardinalHashMap then\r\n TJclCardinalHashMap(Dest).FHashToRangeFunction := FHashToRangeFunction;\r\nend;\r\n\r\nprocedure TJclCardinalHashMap.Clear;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclCardinalHashMapBucket;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n begin\r\n for J := 0 to Bucket.Size - 1 do\r\n begin\r\n FreeKey(Bucket.Entries[J].Key);\r\n FreeValue(Bucket.Entries[J].Value);\r\n end;\r\n FreeAndNil(FBuckets[I]);\r\n end;\r\n end;\r\n FSize := 0;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclCardinalHashMap.ContainsKey(Key: Cardinal): Boolean;\r\nvar\r\n I: Integer;\r\n Bucket: TJclCardinalHashMapBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n Bucket := FBuckets[FHashToRangeFunction(Hash(Key), FCapacity)];\r\n if Bucket <> nil then\r\n for I := 0 to Bucket.Size - 1 do\r\n if KeysEqual(Bucket.Entries[I].Key, Key) then\r\n begin\r\n Result := True;\r\n Break;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclCardinalHashMap.ContainsValue(Value: TObject): Boolean;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclCardinalHashMapBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n for J := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[J];\r\n if Bucket <> nil then\r\n for I := 0 to Bucket.Size - 1 do\r\n if ValuesEqual(Bucket.Entries[I].Value, Value) then\r\n begin\r\n Result := True;\r\n Break;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclCardinalHashMap.Extract(Key: Cardinal): TObject;\r\nvar\r\n Bucket: TJclCardinalHashMapBucket;\r\n I, NewCapacity: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := nil;\r\n Bucket := FBuckets[FHashToRangeFunction(Hash(Key), FCapacity)];\r\n if Bucket <> nil then\r\n begin\r\n for I := 0 to Bucket.Size - 1 do\r\n if KeysEqual(Bucket.Entries[I].Key, Key) then\r\n begin\r\n Result := Bucket.Entries[I].Value;\r\n Bucket.Entries[I].Value := nil;\r\n FreeKey(Bucket.Entries[I].Key);\r\n if I < Length(Bucket.Entries) - 1 then\r\n Bucket.MoveArray(Bucket.Entries, I + 1, I, Bucket.Size - I - 1);\r\n Dec(Bucket.Size);\r\n Dec(FSize);\r\n Break;\r\n end;\r\n\r\n NewCapacity := CalcPackCapacity(Length(Bucket.Entries), Bucket.Size);\r\n if NewCapacity < Length(Bucket.Entries) then\r\n SetLength(Bucket.Entries, NewCapacity);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclCardinalHashMap.GetValue(Key: Cardinal): TObject;\r\nvar\r\n I: Integer;\r\n Bucket: TJclCardinalHashMapBucket;\r\n Found: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Found := False;\r\n Result := nil;\r\n Bucket := FBuckets[FHashToRangeFunction(Hash(Key), FCapacity)];\r\n if Bucket <> nil then\r\n for I := 0 to Bucket.Size - 1 do\r\n if KeysEqual(Bucket.Entries[I].Key, Key) then\r\n begin\r\n Result := Bucket.Entries[I].Value;\r\n Found := True;\r\n Break;\r\n end;\r\n if (not Found) and (not FReturnDefaultElements) then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclCardinalHashMap.IsEmpty: Boolean;\r\nbegin\r\n Result := FSize = 0;\r\nend;\r\n\r\nfunction TJclCardinalHashMap.KeyOfValue(Value: TObject): Cardinal;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclCardinalHashMapBucket;\r\n Found: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Found := False;\r\n Result := 0;\r\n for J := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[J];\r\n if Bucket <> nil then\r\n for I := 0 to Bucket.Size - 1 do\r\n if ValuesEqual(Bucket.Entries[I].Value, Value) then\r\n begin\r\n Result := Bucket.Entries[I].Key;\r\n Found := True;\r\n Break;\r\n end;\r\n end;\r\n if (not Found) and (not FReturnDefaultElements) then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclCardinalHashMap.KeySet: IJclCardinalSet;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclCardinalHashMapBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := TJclCardinalArraySet.Create(FSize);\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n for J := 0 to Bucket.Size - 1 do\r\n Result.Add(Bucket.Entries[J].Key);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclCardinalHashMap.MapEquals(const AMap: IJclCardinalMap): Boolean;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclCardinalHashMapBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if AMap = nil then\r\n Exit;\r\n if FSize <> AMap.Size then\r\n Exit;\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n for J := 0 to Bucket.Size - 1 do\r\n if AMap.ContainsKey(Bucket.Entries[J].Key) then\r\n begin\r\n if not ValuesEqual(AMap.GetValue(Bucket.Entries[J].Key), Bucket.Entries[J].Value) then\r\n Exit;\r\n end\r\n else\r\n Exit;\r\n end;\r\n Result := True;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclCardinalHashMap.Pack;\r\nvar\r\n I: Integer;\r\n Bucket: TJclCardinalHashMapBucket;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n begin\r\n if Bucket.Size > 0 then\r\n SetLength(Bucket.Entries, Bucket.Size)\r\n else\r\n FreeAndNil(FBuckets[I]);\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclCardinalHashMap.PutAll(const AMap: IJclCardinalMap);\r\nvar\r\n It: IJclCardinalIterator;\r\n Key: Cardinal;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if AMap = nil then\r\n Exit;\r\n It := AMap.KeySet.First;\r\n while It.HasNext do\r\n begin\r\n Key := It.Next;\r\n PutValue(Key, AMap.GetValue(Key));\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclCardinalHashMap.PutValue(Key: Cardinal; Value: TObject);\r\nvar\r\n Index: Integer;\r\n Bucket: TJclCardinalHashMapBucket;\r\n I: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FAllowDefaultElements or (not KeysEqual(Key, 0) and not ValuesEqual(Value, nil)) then\r\n begin\r\n Index := FHashToRangeFunction(Hash(Key), FCapacity);\r\n Bucket := FBuckets[Index];\r\n if Bucket <> nil then\r\n begin\r\n for I := 0 to Bucket.Size - 1 do\r\n if KeysEqual(Bucket.Entries[I].Key, Key) then\r\n begin\r\n FreeValue(Bucket.Entries[I].Value);\r\n Bucket.Entries[I].Value := Value;\r\n Exit;\r\n end;\r\n end\r\n else\r\n begin\r\n Bucket := TJclCardinalHashMapBucket.Create;\r\n SetLength(Bucket.Entries, 1);\r\n FBuckets[Index] := Bucket;\r\n end;\r\n\r\n if Bucket.Size = Length(Bucket.Entries) then\r\n SetLength(Bucket.Entries, CalcGrowCapacity(Bucket.Size, Bucket.Size));\r\n\r\n if Bucket.Size < Length(Bucket.Entries) then\r\n begin\r\n Bucket.Entries[Bucket.Size].Key := Key;\r\n Bucket.Entries[Bucket.Size].Value := Value;\r\n Inc(Bucket.Size);\r\n Inc(FSize);\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclCardinalHashMap.Remove(Key: Cardinal): TObject;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := Extract(Key);\r\n Result := FreeValue(Result);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclCardinalHashMap.SetCapacity(Value: Integer);\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FSize = 0 then\r\n begin\r\n SetLength(FBuckets, Value);\r\n inherited SetCapacity(Value);\r\n end\r\n else\r\n raise EJclOperationNotSupportedError.Create;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclCardinalHashMap.Size: Integer;\r\nbegin\r\n Result := FSize;\r\nend;\r\n\r\nfunction TJclCardinalHashMap.Values: IJclCollection;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclCardinalHashMapBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := TJclArrayList.Create(FSize, False);\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n for J := 0 to Bucket.Size - 1 do\r\n Result.Add(Bucket.Entries[J].Value);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclCardinalHashMap.CreateEmptyContainer: TJclAbstractContainerBase;\r\nbegin\r\n Result := TJclCardinalHashMap.Create(FCapacity, False);\r\n AssignPropertiesTo(Result);\r\nend;\r\n\r\nfunction TJclCardinalHashMap.FreeKey(var Key: Cardinal): Cardinal;\r\nbegin\r\n Result := Key;\r\n Key := 0;\r\nend;\r\n\r\nfunction TJclCardinalHashMap.FreeValue(var Value: TObject): TObject;\r\nbegin\r\n if FOwnsValues then\r\n begin\r\n Result := nil;\r\n FreeAndNil(Value);\r\n end\r\n else\r\n begin\r\n Result := Value;\r\n Value := nil;\r\n end;\r\nend;\r\n\r\nfunction TJclCardinalHashMap.GetOwnsValues: Boolean;\r\nbegin\r\n Result := FOwnsValues;\r\nend;\r\n\r\nfunction TJclCardinalHashMap.KeysEqual(A, B: Cardinal): Boolean;\r\nbegin\r\n Result := ItemsEqual(A, B);\r\nend;\r\n\r\nfunction TJclCardinalHashMap.ValuesEqual(A, B: TObject): Boolean;\r\nbegin\r\n Result := SimpleEqualityCompare(A, B);\r\nend;\r\n\r\n//=== { TJclInt64HashMapBucket } ==========================================\r\n\r\nprocedure TJclInt64HashMapBucket.InitializeArrayAfterMove(var List: TJclInt64HashMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\nbegin\r\n { Clean array }\r\n if FromIndex < ToIndex then\r\n begin\r\n if (ToIndex - FromIndex) < Count then\r\n Count := ToIndex - FromIndex;\r\n FillChar(List[FromIndex], Count * SizeOf(List[0]), 0);\r\n end\r\n else\r\n if FromIndex > ToIndex then\r\n begin\r\n if (FromIndex - ToIndex) < Count then\r\n FillChar(List[ToIndex + Count], (FromIndex - ToIndex) * SizeOf(List[0]), 0)\r\n else\r\n FillChar(List[FromIndex], Count * SizeOf(List[0]), 0);\r\n end;\r\nend;\r\n\r\nprocedure TJclInt64HashMapBucket.MoveArray(var List: TJclInt64HashMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\nbegin\r\n if Count > 0 then\r\n begin\r\n Move(List[FromIndex], List[ToIndex], Count * SizeOf(List[0]));\r\n InitializeArrayAfterMove(List, FromIndex, ToIndex, Count);\r\n end;\r\nend;\r\n\r\n//=== { TJclInt64HashMap } ==========================================\r\n\r\nconstructor TJclInt64HashMap.Create(ACapacity: Integer; AOwnsValues: Boolean);\r\nbegin\r\n inherited Create;\r\n FOwnsValues := AOwnsValues;\r\n SetCapacity(ACapacity);\r\n FHashToRangeFunction := JclSimpleHashToRange;\r\nend;\r\n\r\ndestructor TJclInt64HashMap.Destroy;\r\nbegin\r\n FReadOnly := False;\r\n Clear;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJclInt64HashMap.AssignDataTo(Dest: TJclAbstractContainerBase);\r\nvar\r\n I, J: Integer;\r\n SelfBucket, NewBucket: TJclInt64HashMapBucket;\r\n ADest: TJclInt64HashMap;\r\n AMap: IJclInt64Map;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n inherited AssignDataTo(Dest);\r\n if Dest is TJclInt64HashMap then\r\n begin\r\n ADest := TJclInt64HashMap(Dest);\r\n ADest.Clear;\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n SelfBucket := FBuckets[I];\r\n if SelfBucket <> nil then\r\n begin\r\n NewBucket := TJclInt64HashMapBucket.Create;\r\n SetLength(NewBucket.Entries, SelfBucket.Size);\r\n for J := 0 to SelfBucket.Size - 1 do\r\n begin\r\n NewBucket.Entries[J].Key := SelfBucket.Entries[J].Key;\r\n NewBucket.Entries[J].Value := SelfBucket.Entries[J].Value;\r\n end;\r\n NewBucket.Size := SelfBucket.Size;\r\n ADest.FBuckets[I] := NewBucket;\r\n end;\r\n end;\r\n end\r\n else\r\n if Supports(IInterface(Dest), IJclInt64Map, AMap) then\r\n begin\r\n AMap.Clear;\r\n AMap.PutAll(Self);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclInt64HashMap.AssignPropertiesTo(Dest: TJclAbstractContainerBase);\r\nbegin\r\n inherited AssignPropertiesto(Dest);\r\n if Dest is TJclInt64HashMap then\r\n TJclInt64HashMap(Dest).FHashToRangeFunction := FHashToRangeFunction;\r\nend;\r\n\r\nprocedure TJclInt64HashMap.Clear;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclInt64HashMapBucket;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n begin\r\n for J := 0 to Bucket.Size - 1 do\r\n begin\r\n FreeKey(Bucket.Entries[J].Key);\r\n FreeValue(Bucket.Entries[J].Value);\r\n end;\r\n FreeAndNil(FBuckets[I]);\r\n end;\r\n end;\r\n FSize := 0;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclInt64HashMap.ContainsKey(const Key: Int64): Boolean;\r\nvar\r\n I: Integer;\r\n Bucket: TJclInt64HashMapBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n Bucket := FBuckets[FHashToRangeFunction(Hash(Key), FCapacity)];\r\n if Bucket <> nil then\r\n for I := 0 to Bucket.Size - 1 do\r\n if KeysEqual(Bucket.Entries[I].Key, Key) then\r\n begin\r\n Result := True;\r\n Break;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclInt64HashMap.ContainsValue(Value: TObject): Boolean;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclInt64HashMapBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n for J := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[J];\r\n if Bucket <> nil then\r\n for I := 0 to Bucket.Size - 1 do\r\n if ValuesEqual(Bucket.Entries[I].Value, Value) then\r\n begin\r\n Result := True;\r\n Break;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclInt64HashMap.Extract(const Key: Int64): TObject;\r\nvar\r\n Bucket: TJclInt64HashMapBucket;\r\n I, NewCapacity: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := nil;\r\n Bucket := FBuckets[FHashToRangeFunction(Hash(Key), FCapacity)];\r\n if Bucket <> nil then\r\n begin\r\n for I := 0 to Bucket.Size - 1 do\r\n if KeysEqual(Bucket.Entries[I].Key, Key) then\r\n begin\r\n Result := Bucket.Entries[I].Value;\r\n Bucket.Entries[I].Value := nil;\r\n FreeKey(Bucket.Entries[I].Key);\r\n if I < Length(Bucket.Entries) - 1 then\r\n Bucket.MoveArray(Bucket.Entries, I + 1, I, Bucket.Size - I - 1);\r\n Dec(Bucket.Size);\r\n Dec(FSize);\r\n Break;\r\n end;\r\n\r\n NewCapacity := CalcPackCapacity(Length(Bucket.Entries), Bucket.Size);\r\n if NewCapacity < Length(Bucket.Entries) then\r\n SetLength(Bucket.Entries, NewCapacity);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclInt64HashMap.GetValue(const Key: Int64): TObject;\r\nvar\r\n I: Integer;\r\n Bucket: TJclInt64HashMapBucket;\r\n Found: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Found := False;\r\n Result := nil;\r\n Bucket := FBuckets[FHashToRangeFunction(Hash(Key), FCapacity)];\r\n if Bucket <> nil then\r\n for I := 0 to Bucket.Size - 1 do\r\n if KeysEqual(Bucket.Entries[I].Key, Key) then\r\n begin\r\n Result := Bucket.Entries[I].Value;\r\n Found := True;\r\n Break;\r\n end;\r\n if (not Found) and (not FReturnDefaultElements) then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclInt64HashMap.IsEmpty: Boolean;\r\nbegin\r\n Result := FSize = 0;\r\nend;\r\n\r\nfunction TJclInt64HashMap.KeyOfValue(Value: TObject): Int64;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclInt64HashMapBucket;\r\n Found: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Found := False;\r\n Result := 0;\r\n for J := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[J];\r\n if Bucket <> nil then\r\n for I := 0 to Bucket.Size - 1 do\r\n if ValuesEqual(Bucket.Entries[I].Value, Value) then\r\n begin\r\n Result := Bucket.Entries[I].Key;\r\n Found := True;\r\n Break;\r\n end;\r\n end;\r\n if (not Found) and (not FReturnDefaultElements) then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclInt64HashMap.KeySet: IJclInt64Set;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclInt64HashMapBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := TJclInt64ArraySet.Create(FSize);\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n for J := 0 to Bucket.Size - 1 do\r\n Result.Add(Bucket.Entries[J].Key);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclInt64HashMap.MapEquals(const AMap: IJclInt64Map): Boolean;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclInt64HashMapBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if AMap = nil then\r\n Exit;\r\n if FSize <> AMap.Size then\r\n Exit;\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n for J := 0 to Bucket.Size - 1 do\r\n if AMap.ContainsKey(Bucket.Entries[J].Key) then\r\n begin\r\n if not ValuesEqual(AMap.GetValue(Bucket.Entries[J].Key), Bucket.Entries[J].Value) then\r\n Exit;\r\n end\r\n else\r\n Exit;\r\n end;\r\n Result := True;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclInt64HashMap.Pack;\r\nvar\r\n I: Integer;\r\n Bucket: TJclInt64HashMapBucket;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n begin\r\n if Bucket.Size > 0 then\r\n SetLength(Bucket.Entries, Bucket.Size)\r\n else\r\n FreeAndNil(FBuckets[I]);\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclInt64HashMap.PutAll(const AMap: IJclInt64Map);\r\nvar\r\n It: IJclInt64Iterator;\r\n Key: Int64;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if AMap = nil then\r\n Exit;\r\n It := AMap.KeySet.First;\r\n while It.HasNext do\r\n begin\r\n Key := It.Next;\r\n PutValue(Key, AMap.GetValue(Key));\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclInt64HashMap.PutValue(const Key: Int64; Value: TObject);\r\nvar\r\n Index: Integer;\r\n Bucket: TJclInt64HashMapBucket;\r\n I: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FAllowDefaultElements or (not KeysEqual(Key, 0) and not ValuesEqual(Value, nil)) then\r\n begin\r\n Index := FHashToRangeFunction(Hash(Key), FCapacity);\r\n Bucket := FBuckets[Index];\r\n if Bucket <> nil then\r\n begin\r\n for I := 0 to Bucket.Size - 1 do\r\n if KeysEqual(Bucket.Entries[I].Key, Key) then\r\n begin\r\n FreeValue(Bucket.Entries[I].Value);\r\n Bucket.Entries[I].Value := Value;\r\n Exit;\r\n end;\r\n end\r\n else\r\n begin\r\n Bucket := TJclInt64HashMapBucket.Create;\r\n SetLength(Bucket.Entries, 1);\r\n FBuckets[Index] := Bucket;\r\n end;\r\n\r\n if Bucket.Size = Length(Bucket.Entries) then\r\n SetLength(Bucket.Entries, CalcGrowCapacity(Bucket.Size, Bucket.Size));\r\n\r\n if Bucket.Size < Length(Bucket.Entries) then\r\n begin\r\n Bucket.Entries[Bucket.Size].Key := Key;\r\n Bucket.Entries[Bucket.Size].Value := Value;\r\n Inc(Bucket.Size);\r\n Inc(FSize);\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclInt64HashMap.Remove(const Key: Int64): TObject;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := Extract(Key);\r\n Result := FreeValue(Result);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclInt64HashMap.SetCapacity(Value: Integer);\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FSize = 0 then\r\n begin\r\n SetLength(FBuckets, Value);\r\n inherited SetCapacity(Value);\r\n end\r\n else\r\n raise EJclOperationNotSupportedError.Create;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclInt64HashMap.Size: Integer;\r\nbegin\r\n Result := FSize;\r\nend;\r\n\r\nfunction TJclInt64HashMap.Values: IJclCollection;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclInt64HashMapBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := TJclArrayList.Create(FSize, False);\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n for J := 0 to Bucket.Size - 1 do\r\n Result.Add(Bucket.Entries[J].Value);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclInt64HashMap.CreateEmptyContainer: TJclAbstractContainerBase;\r\nbegin\r\n Result := TJclInt64HashMap.Create(FCapacity, False);\r\n AssignPropertiesTo(Result);\r\nend;\r\n\r\nfunction TJclInt64HashMap.FreeKey(var Key: Int64): Int64;\r\nbegin\r\n Result := Key;\r\n Key := 0;\r\nend;\r\n\r\nfunction TJclInt64HashMap.FreeValue(var Value: TObject): TObject;\r\nbegin\r\n if FOwnsValues then\r\n begin\r\n Result := nil;\r\n FreeAndNil(Value);\r\n end\r\n else\r\n begin\r\n Result := Value;\r\n Value := nil;\r\n end;\r\nend;\r\n\r\nfunction TJclInt64HashMap.GetOwnsValues: Boolean;\r\nbegin\r\n Result := FOwnsValues;\r\nend;\r\n\r\nfunction TJclInt64HashMap.KeysEqual(const A, B: Int64): Boolean;\r\nbegin\r\n Result := ItemsEqual(A, B);\r\nend;\r\n\r\nfunction TJclInt64HashMap.ValuesEqual(A, B: TObject): Boolean;\r\nbegin\r\n Result := SimpleEqualityCompare(A, B);\r\nend;\r\n\r\n//=== { TJclPtrHashMapBucket } ==========================================\r\n\r\nprocedure TJclPtrHashMapBucket.InitializeArrayAfterMove(var List: TJclPtrHashMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\nbegin\r\n { Clean array }\r\n if FromIndex < ToIndex then\r\n begin\r\n if (ToIndex - FromIndex) < Count then\r\n Count := ToIndex - FromIndex;\r\n FillChar(List[FromIndex], Count * SizeOf(List[0]), 0);\r\n end\r\n else\r\n if FromIndex > ToIndex then\r\n begin\r\n if (FromIndex - ToIndex) < Count then\r\n FillChar(List[ToIndex + Count], (FromIndex - ToIndex) * SizeOf(List[0]), 0)\r\n else\r\n FillChar(List[FromIndex], Count * SizeOf(List[0]), 0);\r\n end;\r\nend;\r\n\r\nprocedure TJclPtrHashMapBucket.MoveArray(var List: TJclPtrHashMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\nbegin\r\n if Count > 0 then\r\n begin\r\n Move(List[FromIndex], List[ToIndex], Count * SizeOf(List[0]));\r\n InitializeArrayAfterMove(List, FromIndex, ToIndex, Count);\r\n end;\r\nend;\r\n\r\n//=== { TJclPtrHashMap } ==========================================\r\n\r\nconstructor TJclPtrHashMap.Create(ACapacity: Integer; AOwnsValues: Boolean);\r\nbegin\r\n inherited Create;\r\n FOwnsValues := AOwnsValues;\r\n SetCapacity(ACapacity);\r\n FHashToRangeFunction := JclSimpleHashToRange;\r\nend;\r\n\r\ndestructor TJclPtrHashMap.Destroy;\r\nbegin\r\n FReadOnly := False;\r\n Clear;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJclPtrHashMap.AssignDataTo(Dest: TJclAbstractContainerBase);\r\nvar\r\n I, J: Integer;\r\n SelfBucket, NewBucket: TJclPtrHashMapBucket;\r\n ADest: TJclPtrHashMap;\r\n AMap: IJclPtrMap;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n inherited AssignDataTo(Dest);\r\n if Dest is TJclPtrHashMap then\r\n begin\r\n ADest := TJclPtrHashMap(Dest);\r\n ADest.Clear;\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n SelfBucket := FBuckets[I];\r\n if SelfBucket <> nil then\r\n begin\r\n NewBucket := TJclPtrHashMapBucket.Create;\r\n SetLength(NewBucket.Entries, SelfBucket.Size);\r\n for J := 0 to SelfBucket.Size - 1 do\r\n begin\r\n NewBucket.Entries[J].Key := SelfBucket.Entries[J].Key;\r\n NewBucket.Entries[J].Value := SelfBucket.Entries[J].Value;\r\n end;\r\n NewBucket.Size := SelfBucket.Size;\r\n ADest.FBuckets[I] := NewBucket;\r\n end;\r\n end;\r\n end\r\n else\r\n if Supports(IInterface(Dest), IJclPtrMap, AMap) then\r\n begin\r\n AMap.Clear;\r\n AMap.PutAll(Self);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclPtrHashMap.AssignPropertiesTo(Dest: TJclAbstractContainerBase);\r\nbegin\r\n inherited AssignPropertiesto(Dest);\r\n if Dest is TJclPtrHashMap then\r\n TJclPtrHashMap(Dest).FHashToRangeFunction := FHashToRangeFunction;\r\nend;\r\n\r\nprocedure TJclPtrHashMap.Clear;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclPtrHashMapBucket;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n begin\r\n for J := 0 to Bucket.Size - 1 do\r\n begin\r\n FreeKey(Bucket.Entries[J].Key);\r\n FreeValue(Bucket.Entries[J].Value);\r\n end;\r\n FreeAndNil(FBuckets[I]);\r\n end;\r\n end;\r\n FSize := 0;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclPtrHashMap.ContainsKey(Key: Pointer): Boolean;\r\nvar\r\n I: Integer;\r\n Bucket: TJclPtrHashMapBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n Bucket := FBuckets[FHashToRangeFunction(Hash(Key), FCapacity)];\r\n if Bucket <> nil then\r\n for I := 0 to Bucket.Size - 1 do\r\n if KeysEqual(Bucket.Entries[I].Key, Key) then\r\n begin\r\n Result := True;\r\n Break;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclPtrHashMap.ContainsValue(Value: TObject): Boolean;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclPtrHashMapBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n for J := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[J];\r\n if Bucket <> nil then\r\n for I := 0 to Bucket.Size - 1 do\r\n if ValuesEqual(Bucket.Entries[I].Value, Value) then\r\n begin\r\n Result := True;\r\n Break;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclPtrHashMap.Extract(Key: Pointer): TObject;\r\nvar\r\n Bucket: TJclPtrHashMapBucket;\r\n I, NewCapacity: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := nil;\r\n Bucket := FBuckets[FHashToRangeFunction(Hash(Key), FCapacity)];\r\n if Bucket <> nil then\r\n begin\r\n for I := 0 to Bucket.Size - 1 do\r\n if KeysEqual(Bucket.Entries[I].Key, Key) then\r\n begin\r\n Result := Bucket.Entries[I].Value;\r\n Bucket.Entries[I].Value := nil;\r\n FreeKey(Bucket.Entries[I].Key);\r\n if I < Length(Bucket.Entries) - 1 then\r\n Bucket.MoveArray(Bucket.Entries, I + 1, I, Bucket.Size - I - 1);\r\n Dec(Bucket.Size);\r\n Dec(FSize);\r\n Break;\r\n end;\r\n\r\n NewCapacity := CalcPackCapacity(Length(Bucket.Entries), Bucket.Size);\r\n if NewCapacity < Length(Bucket.Entries) then\r\n SetLength(Bucket.Entries, NewCapacity);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclPtrHashMap.GetValue(Key: Pointer): TObject;\r\nvar\r\n I: Integer;\r\n Bucket: TJclPtrHashMapBucket;\r\n Found: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Found := False;\r\n Result := nil;\r\n Bucket := FBuckets[FHashToRangeFunction(Hash(Key), FCapacity)];\r\n if Bucket <> nil then\r\n for I := 0 to Bucket.Size - 1 do\r\n if KeysEqual(Bucket.Entries[I].Key, Key) then\r\n begin\r\n Result := Bucket.Entries[I].Value;\r\n Found := True;\r\n Break;\r\n end;\r\n if (not Found) and (not FReturnDefaultElements) then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclPtrHashMap.IsEmpty: Boolean;\r\nbegin\r\n Result := FSize = 0;\r\nend;\r\n\r\nfunction TJclPtrHashMap.KeyOfValue(Value: TObject): Pointer;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclPtrHashMapBucket;\r\n Found: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Found := False;\r\n Result := nil;\r\n for J := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[J];\r\n if Bucket <> nil then\r\n for I := 0 to Bucket.Size - 1 do\r\n if ValuesEqual(Bucket.Entries[I].Value, Value) then\r\n begin\r\n Result := Bucket.Entries[I].Key;\r\n Found := True;\r\n Break;\r\n end;\r\n end;\r\n if (not Found) and (not FReturnDefaultElements) then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclPtrHashMap.KeySet: IJclPtrSet;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclPtrHashMapBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := TJclPtrArraySet.Create(FSize);\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n for J := 0 to Bucket.Size - 1 do\r\n Result.Add(Bucket.Entries[J].Key);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclPtrHashMap.MapEquals(const AMap: IJclPtrMap): Boolean;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclPtrHashMapBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if AMap = nil then\r\n Exit;\r\n if FSize <> AMap.Size then\r\n Exit;\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n for J := 0 to Bucket.Size - 1 do\r\n if AMap.ContainsKey(Bucket.Entries[J].Key) then\r\n begin\r\n if not ValuesEqual(AMap.GetValue(Bucket.Entries[J].Key), Bucket.Entries[J].Value) then\r\n Exit;\r\n end\r\n else\r\n Exit;\r\n end;\r\n Result := True;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclPtrHashMap.Pack;\r\nvar\r\n I: Integer;\r\n Bucket: TJclPtrHashMapBucket;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n begin\r\n if Bucket.Size > 0 then\r\n SetLength(Bucket.Entries, Bucket.Size)\r\n else\r\n FreeAndNil(FBuckets[I]);\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclPtrHashMap.PutAll(const AMap: IJclPtrMap);\r\nvar\r\n It: IJclPtrIterator;\r\n Key: Pointer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if AMap = nil then\r\n Exit;\r\n It := AMap.KeySet.First;\r\n while It.HasNext do\r\n begin\r\n Key := It.Next;\r\n PutValue(Key, AMap.GetValue(Key));\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclPtrHashMap.PutValue(Key: Pointer; Value: TObject);\r\nvar\r\n Index: Integer;\r\n Bucket: TJclPtrHashMapBucket;\r\n I: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FAllowDefaultElements or (not KeysEqual(Key, nil) and not ValuesEqual(Value, nil)) then\r\n begin\r\n Index := FHashToRangeFunction(Hash(Key), FCapacity);\r\n Bucket := FBuckets[Index];\r\n if Bucket <> nil then\r\n begin\r\n for I := 0 to Bucket.Size - 1 do\r\n if KeysEqual(Bucket.Entries[I].Key, Key) then\r\n begin\r\n FreeValue(Bucket.Entries[I].Value);\r\n Bucket.Entries[I].Value := Value;\r\n Exit;\r\n end;\r\n end\r\n else\r\n begin\r\n Bucket := TJclPtrHashMapBucket.Create;\r\n SetLength(Bucket.Entries, 1);\r\n FBuckets[Index] := Bucket;\r\n end;\r\n\r\n if Bucket.Size = Length(Bucket.Entries) then\r\n SetLength(Bucket.Entries, CalcGrowCapacity(Bucket.Size, Bucket.Size));\r\n\r\n if Bucket.Size < Length(Bucket.Entries) then\r\n begin\r\n Bucket.Entries[Bucket.Size].Key := Key;\r\n Bucket.Entries[Bucket.Size].Value := Value;\r\n Inc(Bucket.Size);\r\n Inc(FSize);\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclPtrHashMap.Remove(Key: Pointer): TObject;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := Extract(Key);\r\n Result := FreeValue(Result);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclPtrHashMap.SetCapacity(Value: Integer);\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FSize = 0 then\r\n begin\r\n SetLength(FBuckets, Value);\r\n inherited SetCapacity(Value);\r\n end\r\n else\r\n raise EJclOperationNotSupportedError.Create;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclPtrHashMap.Size: Integer;\r\nbegin\r\n Result := FSize;\r\nend;\r\n\r\nfunction TJclPtrHashMap.Values: IJclCollection;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclPtrHashMapBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := TJclArrayList.Create(FSize, False);\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n for J := 0 to Bucket.Size - 1 do\r\n Result.Add(Bucket.Entries[J].Value);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclPtrHashMap.CreateEmptyContainer: TJclAbstractContainerBase;\r\nbegin\r\n Result := TJclPtrHashMap.Create(FCapacity, False);\r\n AssignPropertiesTo(Result);\r\nend;\r\n\r\nfunction TJclPtrHashMap.FreeKey(var Key: Pointer): Pointer;\r\nbegin\r\n Result := Key;\r\n Key := nil;\r\nend;\r\n\r\nfunction TJclPtrHashMap.FreeValue(var Value: TObject): TObject;\r\nbegin\r\n if FOwnsValues then\r\n begin\r\n Result := nil;\r\n FreeAndNil(Value);\r\n end\r\n else\r\n begin\r\n Result := Value;\r\n Value := nil;\r\n end;\r\nend;\r\n\r\nfunction TJclPtrHashMap.GetOwnsValues: Boolean;\r\nbegin\r\n Result := FOwnsValues;\r\nend;\r\n\r\nfunction TJclPtrHashMap.KeysEqual(A, B: Pointer): Boolean;\r\nbegin\r\n Result := ItemsEqual(A, B);\r\nend;\r\n\r\nfunction TJclPtrHashMap.ValuesEqual(A, B: TObject): Boolean;\r\nbegin\r\n Result := SimpleEqualityCompare(A, B);\r\nend;\r\n\r\n//=== { TJclHashMapBucket } ==========================================\r\n\r\nprocedure TJclHashMapBucket.InitializeArrayAfterMove(var List: TJclHashMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\nbegin\r\n { Clean array }\r\n if FromIndex < ToIndex then\r\n begin\r\n if (ToIndex - FromIndex) < Count then\r\n Count := ToIndex - FromIndex;\r\n FillChar(List[FromIndex], Count * SizeOf(List[0]), 0);\r\n end\r\n else\r\n if FromIndex > ToIndex then\r\n begin\r\n if (FromIndex - ToIndex) < Count then\r\n FillChar(List[ToIndex + Count], (FromIndex - ToIndex) * SizeOf(List[0]), 0)\r\n else\r\n FillChar(List[FromIndex], Count * SizeOf(List[0]), 0);\r\n end;\r\nend;\r\n\r\nprocedure TJclHashMapBucket.MoveArray(var List: TJclHashMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\nbegin\r\n if Count > 0 then\r\n begin\r\n Move(List[FromIndex], List[ToIndex], Count * SizeOf(List[0]));\r\n InitializeArrayAfterMove(List, FromIndex, ToIndex, Count);\r\n end;\r\nend;\r\n\r\n//=== { TJclHashMap } ==========================================\r\n\r\nconstructor TJclHashMap.Create(ACapacity: Integer; AOwnsValues: Boolean; AOwnsKeys: Boolean);\r\nbegin\r\n inherited Create;\r\n FOwnsKeys := AOwnsKeys;\r\n FOwnsValues := AOwnsValues;\r\n SetCapacity(ACapacity);\r\n FHashToRangeFunction := JclSimpleHashToRange;\r\nend;\r\n\r\ndestructor TJclHashMap.Destroy;\r\nbegin\r\n FReadOnly := False;\r\n Clear;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJclHashMap.AssignDataTo(Dest: TJclAbstractContainerBase);\r\nvar\r\n I, J: Integer;\r\n SelfBucket, NewBucket: TJclHashMapBucket;\r\n ADest: TJclHashMap;\r\n AMap: IJclMap;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n inherited AssignDataTo(Dest);\r\n if Dest is TJclHashMap then\r\n begin\r\n ADest := TJclHashMap(Dest);\r\n ADest.Clear;\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n SelfBucket := FBuckets[I];\r\n if SelfBucket <> nil then\r\n begin\r\n NewBucket := TJclHashMapBucket.Create;\r\n SetLength(NewBucket.Entries, SelfBucket.Size);\r\n for J := 0 to SelfBucket.Size - 1 do\r\n begin\r\n NewBucket.Entries[J].Key := SelfBucket.Entries[J].Key;\r\n NewBucket.Entries[J].Value := SelfBucket.Entries[J].Value;\r\n end;\r\n NewBucket.Size := SelfBucket.Size;\r\n ADest.FBuckets[I] := NewBucket;\r\n end;\r\n end;\r\n end\r\n else\r\n if Supports(IInterface(Dest), IJclMap, AMap) then\r\n begin\r\n AMap.Clear;\r\n AMap.PutAll(Self);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclHashMap.AssignPropertiesTo(Dest: TJclAbstractContainerBase);\r\nbegin\r\n inherited AssignPropertiesto(Dest);\r\n if Dest is TJclHashMap then\r\n TJclHashMap(Dest).FHashToRangeFunction := FHashToRangeFunction;\r\nend;\r\n\r\nprocedure TJclHashMap.Clear;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclHashMapBucket;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n begin\r\n for J := 0 to Bucket.Size - 1 do\r\n begin\r\n FreeKey(Bucket.Entries[J].Key);\r\n FreeValue(Bucket.Entries[J].Value);\r\n end;\r\n FreeAndNil(FBuckets[I]);\r\n end;\r\n end;\r\n FSize := 0;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclHashMap.ContainsKey(Key: TObject): Boolean;\r\nvar\r\n I: Integer;\r\n Bucket: TJclHashMapBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n Bucket := FBuckets[FHashToRangeFunction(Hash(Key), FCapacity)];\r\n if Bucket <> nil then\r\n for I := 0 to Bucket.Size - 1 do\r\n if KeysEqual(Bucket.Entries[I].Key, Key) then\r\n begin\r\n Result := True;\r\n Break;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclHashMap.ContainsValue(Value: TObject): Boolean;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclHashMapBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n for J := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[J];\r\n if Bucket <> nil then\r\n for I := 0 to Bucket.Size - 1 do\r\n if ValuesEqual(Bucket.Entries[I].Value, Value) then\r\n begin\r\n Result := True;\r\n Break;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclHashMap.Extract(Key: TObject): TObject;\r\nvar\r\n Bucket: TJclHashMapBucket;\r\n I, NewCapacity: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := nil;\r\n Bucket := FBuckets[FHashToRangeFunction(Hash(Key), FCapacity)];\r\n if Bucket <> nil then\r\n begin\r\n for I := 0 to Bucket.Size - 1 do\r\n if KeysEqual(Bucket.Entries[I].Key, Key) then\r\n begin\r\n Result := Bucket.Entries[I].Value;\r\n Bucket.Entries[I].Value := nil;\r\n FreeKey(Bucket.Entries[I].Key);\r\n if I < Length(Bucket.Entries) - 1 then\r\n Bucket.MoveArray(Bucket.Entries, I + 1, I, Bucket.Size - I - 1);\r\n Dec(Bucket.Size);\r\n Dec(FSize);\r\n Break;\r\n end;\r\n\r\n NewCapacity := CalcPackCapacity(Length(Bucket.Entries), Bucket.Size);\r\n if NewCapacity < Length(Bucket.Entries) then\r\n SetLength(Bucket.Entries, NewCapacity);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclHashMap.GetValue(Key: TObject): TObject;\r\nvar\r\n I: Integer;\r\n Bucket: TJclHashMapBucket;\r\n Found: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Found := False;\r\n Result := nil;\r\n Bucket := FBuckets[FHashToRangeFunction(Hash(Key), FCapacity)];\r\n if Bucket <> nil then\r\n for I := 0 to Bucket.Size - 1 do\r\n if KeysEqual(Bucket.Entries[I].Key, Key) then\r\n begin\r\n Result := Bucket.Entries[I].Value;\r\n Found := True;\r\n Break;\r\n end;\r\n if (not Found) and (not FReturnDefaultElements) then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclHashMap.IsEmpty: Boolean;\r\nbegin\r\n Result := FSize = 0;\r\nend;\r\n\r\nfunction TJclHashMap.KeyOfValue(Value: TObject): TObject;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclHashMapBucket;\r\n Found: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Found := False;\r\n Result := nil;\r\n for J := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[J];\r\n if Bucket <> nil then\r\n for I := 0 to Bucket.Size - 1 do\r\n if ValuesEqual(Bucket.Entries[I].Value, Value) then\r\n begin\r\n Result := Bucket.Entries[I].Key;\r\n Found := True;\r\n Break;\r\n end;\r\n end;\r\n if (not Found) and (not FReturnDefaultElements) then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclHashMap.KeySet: IJclSet;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclHashMapBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := TJclArraySet.Create(FSize, False);\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n for J := 0 to Bucket.Size - 1 do\r\n Result.Add(Bucket.Entries[J].Key);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclHashMap.MapEquals(const AMap: IJclMap): Boolean;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclHashMapBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if AMap = nil then\r\n Exit;\r\n if FSize <> AMap.Size then\r\n Exit;\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n for J := 0 to Bucket.Size - 1 do\r\n if AMap.ContainsKey(Bucket.Entries[J].Key) then\r\n begin\r\n if not ValuesEqual(AMap.GetValue(Bucket.Entries[J].Key), Bucket.Entries[J].Value) then\r\n Exit;\r\n end\r\n else\r\n Exit;\r\n end;\r\n Result := True;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclHashMap.Pack;\r\nvar\r\n I: Integer;\r\n Bucket: TJclHashMapBucket;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n begin\r\n if Bucket.Size > 0 then\r\n SetLength(Bucket.Entries, Bucket.Size)\r\n else\r\n FreeAndNil(FBuckets[I]);\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclHashMap.PutAll(const AMap: IJclMap);\r\nvar\r\n It: IJclIterator;\r\n Key: TObject;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if AMap = nil then\r\n Exit;\r\n It := AMap.KeySet.First;\r\n while It.HasNext do\r\n begin\r\n Key := It.Next;\r\n PutValue(Key, AMap.GetValue(Key));\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclHashMap.PutValue(Key: TObject; Value: TObject);\r\nvar\r\n Index: Integer;\r\n Bucket: TJclHashMapBucket;\r\n I: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FAllowDefaultElements or (not KeysEqual(Key, nil) and not ValuesEqual(Value, nil)) then\r\n begin\r\n Index := FHashToRangeFunction(Hash(Key), FCapacity);\r\n Bucket := FBuckets[Index];\r\n if Bucket <> nil then\r\n begin\r\n for I := 0 to Bucket.Size - 1 do\r\n if KeysEqual(Bucket.Entries[I].Key, Key) then\r\n begin\r\n FreeValue(Bucket.Entries[I].Value);\r\n Bucket.Entries[I].Value := Value;\r\n Exit;\r\n end;\r\n end\r\n else\r\n begin\r\n Bucket := TJclHashMapBucket.Create;\r\n SetLength(Bucket.Entries, 1);\r\n FBuckets[Index] := Bucket;\r\n end;\r\n\r\n if Bucket.Size = Length(Bucket.Entries) then\r\n SetLength(Bucket.Entries, CalcGrowCapacity(Bucket.Size, Bucket.Size));\r\n\r\n if Bucket.Size < Length(Bucket.Entries) then\r\n begin\r\n Bucket.Entries[Bucket.Size].Key := Key;\r\n Bucket.Entries[Bucket.Size].Value := Value;\r\n Inc(Bucket.Size);\r\n Inc(FSize);\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclHashMap.Remove(Key: TObject): TObject;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := Extract(Key);\r\n Result := FreeValue(Result);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclHashMap.SetCapacity(Value: Integer);\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FSize = 0 then\r\n begin\r\n SetLength(FBuckets, Value);\r\n inherited SetCapacity(Value);\r\n end\r\n else\r\n raise EJclOperationNotSupportedError.Create;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclHashMap.Size: Integer;\r\nbegin\r\n Result := FSize;\r\nend;\r\n\r\nfunction TJclHashMap.Values: IJclCollection;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclHashMapBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := TJclArrayList.Create(FSize, False);\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n for J := 0 to Bucket.Size - 1 do\r\n Result.Add(Bucket.Entries[J].Value);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclHashMap.CreateEmptyContainer: TJclAbstractContainerBase;\r\nbegin\r\n Result := TJclHashMap.Create(FCapacity, False, False);\r\n AssignPropertiesTo(Result);\r\nend;\r\n\r\nfunction TJclHashMap.FreeKey(var Key: TObject): TObject;\r\nbegin\r\n if FOwnsKeys then\r\n begin\r\n Result := nil;\r\n FreeAndNil(Key);\r\n end\r\n else\r\n begin\r\n Result := Key;\r\n Key := nil;\r\n end;\r\nend;\r\n\r\nfunction TJclHashMap.FreeValue(var Value: TObject): TObject;\r\nbegin\r\n if FOwnsValues then\r\n begin\r\n Result := nil;\r\n FreeAndNil(Value);\r\n end\r\n else\r\n begin\r\n Result := Value;\r\n Value := nil;\r\n end;\r\nend;\r\n\r\nfunction TJclHashMap.GetOwnsKeys: Boolean;\r\nbegin\r\n Result := FOwnsKeys;\r\nend;\r\n\r\nfunction TJclHashMap.GetOwnsValues: Boolean;\r\nbegin\r\n Result := FOwnsValues;\r\nend;\r\n\r\nfunction TJclHashMap.Hash(AObject: TObject): Integer;\r\nbegin\r\n Result := SimpleHashConvert(AObject);\r\nend;\r\n\r\nfunction TJclHashMap.KeysEqual(A, B: TObject): Boolean;\r\nbegin\r\n Result := SimpleEqualityCompare(A, B);\r\nend;\r\n\r\nfunction TJclHashMap.ValuesEqual(A, B: TObject): Boolean;\r\nbegin\r\n Result := SimpleEqualityCompare(A, B);\r\nend;\r\n\r\n\r\n{$IFDEF SUPPORTS_GENERICS}\r\n//DOM-IGNORE-BEGIN\r\n\r\n//=== { TJclBucket } ==========================================\r\n\r\nprocedure TJclBucket.FinalizeArrayBeforeMove(var List: THashEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\nbegin\r\n Assert(Count > 0);\r\n if FromIndex < ToIndex then\r\n begin\r\n if Count > (ToIndex - FromIndex) then\r\n Finalize(List[FromIndex + Count], ToIndex - FromIndex)\r\n else\r\n Finalize(List[ToIndex], Count);\r\n end\r\n else\r\n if FromIndex > ToIndex then\r\n begin\r\n if Count > (FromIndex - ToIndex) then\r\n Count := FromIndex - ToIndex;\r\n Finalize(List[ToIndex], Count)\r\n end;\r\nend;\r\n\r\nprocedure TJclBucket.InitializeArray(var List: THashEntryArray; FromIndex, Count: SizeInt);\r\nbegin\r\n {$IFDEF FPC}\r\n while Count > 0 do\r\n begin\r\n Initialize(List[FromIndex]);\r\n Inc(FromIndex);\r\n Dec(Count);\r\n end;\r\n {$ELSE ~FPC}\r\n Initialize(List[FromIndex], Count);\r\n {$ENDIF ~FPC}\r\nend;\r\n\r\nprocedure TJclBucket.InitializeArrayAfterMove(var List: THashEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\nbegin\r\n { Keep reference counting working }\r\n if FromIndex < ToIndex then\r\n begin\r\n if (ToIndex - FromIndex) < Count then\r\n Count := ToIndex - FromIndex;\r\n InitializeArray(List, FromIndex, Count);\r\n end\r\n else\r\n if FromIndex > ToIndex then\r\n begin\r\n if (FromIndex - ToIndex) < Count then\r\n InitializeArray(List, ToIndex + Count, FromIndex - ToIndex)\r\n else\r\n InitializeArray(List, FromIndex, Count);\r\n end;\r\nend;\r\n\r\nprocedure TJclBucket.MoveArray(var List: THashEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\nbegin\r\n if Count > 0 then\r\n begin\r\n FinalizeArrayBeforeMove(List, FromIndex, ToIndex, Count);\r\n Move(List[FromIndex], List[ToIndex], Count * SizeOf(List[0]));\r\n InitializeArrayAfterMove(List, FromIndex, ToIndex, Count);\r\n end;\r\nend;\r\n\r\n//=== { TJclHashMap } ==========================================\r\n\r\nconstructor TJclHashMap.Create(ACapacity: Integer; AOwnsValues: Boolean; AOwnsKeys: Boolean);\r\nbegin\r\n inherited Create;\r\n\r\n FOwnsKeys := AOwnsKeys;\r\n FOwnsValues := AOwnsValues;\r\n SetCapacity(ACapacity);\r\n FHashToRangeFunction := JclSimpleHashToRange;\r\nend;\r\n\r\ndestructor TJclHashMap.Destroy;\r\nbegin\r\n FReadOnly := False;\r\n Clear;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJclHashMap.AssignDataTo(Dest: TJclAbstractContainerBase);\r\nvar\r\n I, J: Integer;\r\n SelfBucket, NewBucket: TBucket;\r\n ADest: TJclHashMap;\r\n AMap: IJclMap;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n inherited AssignDataTo(Dest);\r\n if Dest is TJclHashMap then\r\n begin\r\n ADest := TJclHashMap(Dest);\r\n ADest.Clear;\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n SelfBucket := FBuckets[I];\r\n if SelfBucket <> nil then\r\n begin\r\n NewBucket := TBucket.Create;\r\n SetLength(NewBucket.Entries, SelfBucket.Size);\r\n for J := 0 to SelfBucket.Size - 1 do\r\n begin\r\n NewBucket.Entries[J].Key := SelfBucket.Entries[J].Key;\r\n NewBucket.Entries[J].Value := SelfBucket.Entries[J].Value;\r\n end;\r\n NewBucket.Size := SelfBucket.Size;\r\n ADest.FBuckets[I] := NewBucket;\r\n end;\r\n end;\r\n end\r\n else\r\n if Supports(IInterface(Dest), IJclMap, AMap) then\r\n begin\r\n AMap.Clear;\r\n AMap.PutAll(Self);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclHashMap.AssignPropertiesTo(Dest: TJclAbstractContainerBase);\r\nbegin\r\n inherited AssignPropertiesto(Dest);\r\n if Dest is TJclHashMap then\r\n TJclHashMap(Dest).FHashToRangeFunction := FHashToRangeFunction;\r\nend;\r\n\r\nprocedure TJclHashMap.Clear;\r\nvar\r\n I, J: Integer;\r\n Bucket: TBucket;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n begin\r\n for J := 0 to Bucket.Size - 1 do\r\n begin\r\n FreeKey(Bucket.Entries[J].Key);\r\n FreeValue(Bucket.Entries[J].Value);\r\n end;\r\n FreeAndNil(FBuckets[I]);\r\n end;\r\n end;\r\n FSize := 0;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclHashMap.ContainsKey(const Key: TKey): Boolean;\r\nvar\r\n I: Integer;\r\n Bucket: TBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n Bucket := FBuckets[FHashToRangeFunction(Hash(Key), FCapacity)];\r\n if Bucket <> nil then\r\n for I := 0 to Bucket.Size - 1 do\r\n if KeysEqual(Bucket.Entries[I].Key, Key) then\r\n begin\r\n Result := True;\r\n Break;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclHashMap.ContainsValue(const Value: TValue): Boolean;\r\nvar\r\n I, J: Integer;\r\n Bucket: TBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n for J := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[J];\r\n if Bucket <> nil then\r\n for I := 0 to Bucket.Size - 1 do\r\n if ValuesEqual(Bucket.Entries[I].Value, Value) then\r\n begin\r\n Result := True;\r\n Break;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclHashMap.Extract(const Key: TKey): TValue;\r\nvar\r\n Bucket: TBucket;\r\n I, NewCapacity: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := Default(TValue);\r\n Bucket := FBuckets[FHashToRangeFunction(Hash(Key), FCapacity)];\r\n if Bucket <> nil then\r\n begin\r\n for I := 0 to Bucket.Size - 1 do\r\n if KeysEqual(Bucket.Entries[I].Key, Key) then\r\n begin\r\n Result := Bucket.Entries[I].Value;\r\n Bucket.Entries[I].Value := Default(TValue);\r\n FreeKey(Bucket.Entries[I].Key);\r\n if I < Length(Bucket.Entries) - 1 then\r\n Bucket.MoveArray(Bucket.Entries, I + 1, I, Bucket.Size - I - 1);\r\n Dec(Bucket.Size);\r\n Dec(FSize);\r\n Break;\r\n end;\r\n\r\n NewCapacity := CalcPackCapacity(Length(Bucket.Entries), Bucket.Size);\r\n if NewCapacity < Length(Bucket.Entries) then\r\n SetLength(Bucket.Entries, NewCapacity);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclHashMap.GetValue(const Key: TKey): TValue;\r\nvar\r\n I: Integer;\r\n Bucket: TBucket;\r\n Found: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Found := False;\r\n Result := Default(TValue);\r\n Bucket := FBuckets[FHashToRangeFunction(Hash(Key), FCapacity)];\r\n if Bucket <> nil then\r\n for I := 0 to Bucket.Size - 1 do\r\n if KeysEqual(Bucket.Entries[I].Key, Key) then\r\n begin\r\n Result := Bucket.Entries[I].Value;\r\n Found := True;\r\n Break;\r\n end;\r\n if (not Found) and (not FReturnDefaultElements) then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclHashMap.IsEmpty: Boolean;\r\nbegin\r\n Result := FSize = 0;\r\nend;\r\n\r\nfunction TJclHashMap.KeyOfValue(const Value: TValue): TKey;\r\nvar\r\n I, J: Integer;\r\n Bucket: TBucket;\r\n Found: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Found := False;\r\n Result := Default(TKey);\r\n for J := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[J];\r\n if Bucket <> nil then\r\n for I := 0 to Bucket.Size - 1 do\r\n if ValuesEqual(Bucket.Entries[I].Value, Value) then\r\n begin\r\n Result := Bucket.Entries[I].Key;\r\n Found := True;\r\n Break;\r\n end;\r\n end;\r\n if (not Found) and (not FReturnDefaultElements) then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclHashMap.KeySet: IJclSet;\r\nvar\r\n I, J: Integer;\r\n Bucket: TBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := CreateEmptyArraySet(FSize, False);\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n for J := 0 to Bucket.Size - 1 do\r\n Result.Add(Bucket.Entries[J].Key);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclHashMap.MapEquals(const AMap: IJclMap): Boolean;\r\nvar\r\n I, J: Integer;\r\n Bucket: TBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if AMap = nil then\r\n Exit;\r\n if FSize <> AMap.Size then\r\n Exit;\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n for J := 0 to Bucket.Size - 1 do\r\n if AMap.ContainsKey(Bucket.Entries[J].Key) then\r\n begin\r\n if not ValuesEqual(AMap.GetValue(Bucket.Entries[J].Key), Bucket.Entries[J].Value) then\r\n Exit;\r\n end\r\n else\r\n Exit;\r\n end;\r\n Result := True;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclHashMap.Pack;\r\nvar\r\n I: Integer;\r\n Bucket: TBucket;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n begin\r\n if Bucket.Size > 0 then\r\n SetLength(Bucket.Entries, Bucket.Size)\r\n else\r\n FreeAndNil(FBuckets[I]);\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclHashMap.PutAll(const AMap: IJclMap);\r\nvar\r\n It: IJclIterator;\r\n Key: TKey;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if AMap = nil then\r\n Exit;\r\n It := AMap.KeySet.First;\r\n while It.HasNext do\r\n begin\r\n Key := It.Next;\r\n PutValue(Key, AMap.GetValue(Key));\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclHashMap.PutValue(const Key: TKey; const Value: TValue);\r\nvar\r\n Index: Integer;\r\n Bucket: TBucket;\r\n I: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FAllowDefaultElements or (not KeysEqual(Key, Default(TKey)) and not ValuesEqual(Value, Default(TValue))) then\r\n begin\r\n Index := FHashToRangeFunction(Hash(Key), FCapacity);\r\n Bucket := FBuckets[Index];\r\n if Bucket <> nil then\r\n begin\r\n for I := 0 to Bucket.Size - 1 do\r\n if KeysEqual(Bucket.Entries[I].Key, Key) then\r\n begin\r\n FreeValue(Bucket.Entries[I].Value);\r\n Bucket.Entries[I].Value := Value;\r\n Exit;\r\n end;\r\n end\r\n else\r\n begin\r\n Bucket := TBucket.Create;\r\n SetLength(Bucket.Entries, 1);\r\n FBuckets[Index] := Bucket;\r\n end;\r\n\r\n if Bucket.Size = Length(Bucket.Entries) then\r\n SetLength(Bucket.Entries, CalcGrowCapacity(Bucket.Size, Bucket.Size));\r\n\r\n if Bucket.Size < Length(Bucket.Entries) then\r\n begin\r\n Bucket.Entries[Bucket.Size].Key := Key;\r\n Bucket.Entries[Bucket.Size].Value := Value;\r\n Inc(Bucket.Size);\r\n Inc(FSize);\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclHashMap.Remove(const Key: TKey): TValue;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := Extract(Key);\r\n Result := FreeValue(Result);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclHashMap.SetCapacity(Value: Integer);\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FSize = 0 then\r\n begin\r\n SetLength(FBuckets, Value);\r\n inherited SetCapacity(Value);\r\n end\r\n else\r\n raise EJclOperationNotSupportedError.Create;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclHashMap.Size: Integer;\r\nbegin\r\n Result := FSize;\r\nend;\r\n\r\nfunction TJclHashMap.Values: IJclCollection;\r\nvar\r\n I, J: Integer;\r\n Bucket: TBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := CreateEmptyArrayList(FSize, False);\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n for J := 0 to Bucket.Size - 1 do\r\n Result.Add(Bucket.Entries[J].Value);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclHashMap.FreeKey(var Key: TKey): TKey;\r\nbegin\r\n if FOwnsKeys then\r\n begin\r\n Result := Default(TKey);\r\n FreeAndNil(Key);\r\n end\r\n else\r\n begin\r\n Result := Key;\r\n Key := Default(TKey);\r\n end;\r\nend;\r\n\r\nfunction TJclHashMap.FreeValue(var Value: TValue): TValue;\r\nbegin\r\n if FOwnsValues then\r\n begin\r\n Result := Default(TValue);\r\n FreeAndNil(Value);\r\n end\r\n else\r\n begin\r\n Result := Value;\r\n Value := Default(TValue);\r\n end;\r\nend;\r\n\r\nfunction TJclHashMap.GetOwnsKeys: Boolean;\r\nbegin\r\n Result := FOwnsKeys;\r\nend;\r\n\r\nfunction TJclHashMap.GetOwnsValues: Boolean;\r\nbegin\r\n Result := FOwnsValues;\r\nend;\r\n\r\n//=== { TJclHashMapE } =========================================\r\n\r\nconstructor TJclHashMapE.Create(const AKeyEqualityComparer: IJclEqualityComparer;\r\n const AKeyHashConverter: IJclHashConverter; const AValueEqualityComparer: IJclEqualityComparer;\r\n const AKeyComparer: IJclComparer; ACapacity: Integer; AOwnsValues: Boolean; AOwnsKeys: Boolean);\r\nbegin\r\n inherited Create(ACapacity, AOwnsKeys, AOwnsValues);\r\n FKeyEqualityComparer := AKeyEqualityComparer;\r\n FKeyHashConverter := AKeyHashConverter;\r\n FValueEqualityComparer := AValueEqualityComparer;\r\n FKeyComparer := AKeyComparer;\r\nend;\r\n\r\nprocedure TJclHashMapE.AssignPropertiesTo(Dest: TJclAbstractContainerBase);\r\nvar\r\n ADest: TJclHashMapE;\r\nbegin\r\n inherited AssignPropertiesTo(Dest);\r\n if Dest is TJclHashMapE then\r\n begin\r\n ADest := TJclHashMapE(Dest);\r\n ADest.FKeyEqualityComparer := FKeyEqualityComparer;\r\n ADest.FKeyHashConverter := FKeyHashConverter;\r\n ADest.FValueEqualityComparer := FValueEqualityComparer;\r\n ADest.FKeyComparer := FKeyComparer;\r\n end;\r\nend;\r\n\r\nfunction TJclHashMapE.CreateEmptyArrayList(ACapacity: Integer; AOwnsObjects: Boolean): IJclCollection;\r\nbegin\r\n Result := TArrayList.Create(ValueEqualityComparer, ACapacity, AOwnsObjects);\r\nend;\r\n\r\nfunction TJclHashMapE.CreateEmptyArraySet(ACapacity: Integer; AOwnsObjects: Boolean): IJclSet;\r\nbegin\r\n Result := TArraySet.Create(KeyComparer, ACapacity, AOwnsObjects);\r\nend;\r\n\r\nfunction TJclHashMapE.CreateEmptyContainer: TJclAbstractContainerBase;\r\nbegin\r\n Result := TJclHashMapE.Create(KeyEqualityComparer, KeyHashConverter, ValueEqualityComparer,\r\n KeyComparer, FCapacity, False, False);\r\n AssignPropertiesTo(Result);\r\nend;\r\n\r\nfunction TJclHashMapE.Hash(const AKey: TKey): Integer;\r\nbegin\r\n if KeyEqualityComparer = nil then\r\n raise EJclNoHashConverterError.Create;\r\n Result := KeyHashConverter.Hash(AKey);\r\nend;\r\n\r\nfunction TJclHashMapE.KeysEqual(const A, B: TKey): Boolean;\r\nbegin\r\n if KeyEqualityComparer = nil then\r\n raise EJclNoEqualityComparerError.Create;\r\n Result := KeyEqualityComparer.ItemsEqual(A, B);\r\nend;\r\n\r\nfunction TJclHashMapE.ValuesEqual(const A, B: TValue): Boolean;\r\nbegin\r\n if ValueEqualityComparer = nil then\r\n raise EJclNoEqualityComparerError.Create;\r\n Result := ValueEqualityComparer.ItemsEqual(A, B);\r\nend;\r\n\r\n//=== { TJclHashMapF } =========================================\r\n\r\nconstructor TJclHashMapF.Create(AKeyEqualityCompare: TEqualityCompare;\r\n AKeyHash: THashConvert; AValueEqualityCompare: TEqualityCompare; AKeyCompare: TCompare;\r\n ACapacity: Integer; AOwnsValues: Boolean; AOwnsKeys: Boolean);\r\nbegin\r\n inherited Create(ACapacity, AOwnsKeys, AOwnsValues);\r\n FKeyEqualityCompare := AKeyEqualityCompare;\r\n FKeyHash := AKeyHash;\r\n FValueEqualityCompare := AValueEqualityCompare;\r\n FKeyCompare := AKeyCompare;\r\nend;\r\n\r\nprocedure TJclHashMapF.AssignPropertiesTo(Dest: TJclAbstractContainerBase);\r\nvar\r\n ADest: TJclHashMapF;\r\nbegin\r\n inherited AssignPropertiesTo(Dest);\r\n if Dest is TJclHashMapF then\r\n begin\r\n ADest := TJclHashMapF(Dest);\r\n ADest.FKeyEqualityCompare := FKeyEqualityCompare;\r\n ADest.FKeyHash := FKeyHash;\r\n ADest.FValueEqualityCompare := FValueEqualityCompare;\r\n ADest.FKeyCompare := FKeyCompare;\r\n end;\r\nend;\r\n\r\nfunction TJclHashMapF.CreateEmptyArrayList(ACapacity: Integer; AOwnsObjects: Boolean): IJclCollection;\r\nbegin\r\n Result := TArrayList.Create(ValueEqualityCompare, ACapacity, AOwnsObjects);\r\nend;\r\n\r\nfunction TJclHashMapF.CreateEmptyArraySet(ACapacity: Integer; AOwnsObjects: Boolean): IJclSet;\r\nbegin\r\n Result := TArraySet.Create(KeyCompare, ACapacity, AOwnsObjects);\r\nend;\r\n\r\nfunction TJclHashMapF.CreateEmptyContainer: TJclAbstractContainerBase;\r\nbegin\r\n Result := TJclHashMapF.Create(KeyEqualityCompare, KeyHash, ValueEqualityCompare, KeyCompare, FCapacity,\r\n False, False);\r\n AssignPropertiesTo(Result);\r\nend;\r\n\r\nfunction TJclHashMapF.Hash(const AKey: TKey): Integer;\r\nbegin\r\n if not Assigned(KeyHash) then\r\n raise EJclNoHashConverterError.Create;\r\n Result := KeyHash(AKey);\r\nend;\r\n\r\nfunction TJclHashMapF.KeysEqual(const A, B: TKey): Boolean;\r\nbegin\r\n if not Assigned(KeyEqualityCompare) then\r\n raise EJclNoEqualityComparerError.Create;\r\n Result := KeyEqualityCompare(A, B);\r\nend;\r\n\r\nfunction TJclHashMapF.ValuesEqual(const A, B: TValue): Boolean;\r\nbegin\r\n if not Assigned(ValueEqualityCompare) then\r\n raise EJclNoEqualityComparerError.Create;\r\n Result := ValueEqualityCompare(A, B);\r\nend;\r\n\r\n//=== { TJclHashMapI } =========================================\r\n\r\nfunction TJclHashMapI.CreateEmptyArrayList(ACapacity: Integer; AOwnsObjects: Boolean): IJclCollection;\r\nbegin\r\n Result := TArrayList.Create(ACapacity, AOwnsObjects);\r\nend;\r\n\r\nfunction TJclHashMapI.CreateEmptyArraySet(ACapacity: Integer; AOwnsObjects: Boolean): IJclSet;\r\nbegin\r\n Result := TArraySet.Create(ACapacity, AOwnsObjects);\r\nend;\r\n\r\nfunction TJclHashMapI.CreateEmptyContainer: TJclAbstractContainerBase;\r\nbegin\r\n Result := TJclHashMapI.Create(FCapacity, False, False);\r\n AssignPropertiesTo(Result);\r\nend;\r\n\r\nfunction TJclHashMapI.Hash(const AKey: TKey): Integer;\r\nbegin\r\n Result := AKey.GetHashCode;\r\nend;\r\n\r\nfunction TJclHashMapI.KeysEqual(const A, B: TKey): Boolean;\r\nbegin\r\n Result := A.Equals(B);\r\nend;\r\n\r\nfunction TJclHashMapI.ValuesEqual(const A, B: TValue): Boolean;\r\nbegin\r\n Result := A.Equals(B);\r\nend;\r\n\r\n//DOM-IGNORE-END\r\n{$ENDIF SUPPORTS_GENERICS}\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n\r\n" }, { "path": "External/Jedi/Jcl/source/common/JclHashSets.pas", "content": "{**************************************************************************************************}\r\n{ WARNING: JEDI preprocessor generated unit. Do not edit. }\r\n{**************************************************************************************************}\r\n\r\n{**************************************************************************************************}\r\n{ }\r\n{ Project JEDI Code Library (JCL) }\r\n{ }\r\n{ The contents of this file are subject to the Mozilla Public License Version 1.1 (the \"License\"); }\r\n{ you may not use this file except in compliance with the License. You may obtain a copy of the }\r\n{ License at http://www.mozilla.org/MPL/ }\r\n{ }\r\n{ Software distributed under the License is distributed on an \"AS IS\" basis, WITHOUT WARRANTY OF }\r\n{ ANY KIND, either express or implied. See the License for the specific language governing rights }\r\n{ and limitations under the License. }\r\n{ }\r\n{ The Original Code is HashSet.pas. }\r\n{ }\r\n{ The Initial Developer of the Original Code is Jean-Philippe BEMPEL aka RDM. Portions created by }\r\n{ Jean-Philippe BEMPEL are Copyright (C) Jean-Philippe BEMPEL (rdm_30 att yahoo dott com) }\r\n{ All rights reserved. }\r\n{ }\r\n{ Contributors: }\r\n{ Florent Ouchet (outchy) }\r\n{ }\r\n{**************************************************************************************************}\r\n{ }\r\n{ The Delphi Container Library }\r\n{ }\r\n{**************************************************************************************************}\r\n{ }\r\n{ Last modified: $Date:: 2012-02-23 21:46:07 +0100 (jeu. 23 févr. 2012) $ }\r\n{ Revision: $Rev:: 3740 $ }\r\n{ Author: $Author:: outchy $ }\r\n{ }\r\n{**************************************************************************************************}\r\n\r\nunit JclHashSets;\r\n\r\n{$I jcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n {$IFDEF HAS_UNITSCOPE}\r\n System.SysUtils, System.Classes,\r\n {$ELSE ~HAS_UNITSCOPE}\r\n SysUtils, Classes,\r\n {$ENDIF ~HAS_UNITSCOPE}\r\n JclAlgorithms,\r\n JclBase, JclAbstractContainers, JclContainerIntf, JclSynch;\r\n\r\n\r\ntype\r\n TItrStart = (isFirst, isLast);\r\n\r\n TJclIntfHashSetBucket = class\r\n public\r\n Size: Integer;\r\n Entries: TDynIInterfaceArray;\r\n end;\r\n\r\n TJclIntfHashSet = class(TJclIntfAbstractContainer, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclIntfCloneable, IJclCloneable, IJclPackable, IJclGrowable, IJclBaseContainer,\r\n IJclIntfContainer, IJclIntfFlatContainer, IJclIntfEqualityComparer, IJclIntfHashConverter,\r\n IJclIntfCollection, IJclIntfSet)\r\n protected\r\n function CreateEmptyContainer: TJclAbstractContainerBase; override;\r\n private\r\n FBuckets: array of TJclIntfHashSetBucket;\r\n FHashToRangeFunction: TJclHashToRangeFunction;\r\n protected\r\n procedure AssignDataTo(Dest: TJclAbstractContainerBase); override;\r\n procedure AssignPropertiesTo(Dest: TJclAbstractContainerBase); override;\r\n public\r\n constructor Create(ACapacity: Integer); overload;\r\n destructor Destroy; override;\r\n property HashToRangeFunction: TJclHashToRangeFunction read FHashToRangeFunction write FHashToRangeFunction;\r\n { IJclPackable }\r\n procedure Pack; override;\r\n procedure SetCapacity(Value: Integer); override;\r\n { IJclIntfCollection }\r\n function Add(const AInterface: IInterface): Boolean;\r\n function AddAll(const ACollection: IJclIntfCollection): Boolean;\r\n procedure Clear;\r\n function CollectionEquals(const ACollection: IJclIntfCollection): Boolean;\r\n function Contains(const AInterface: IInterface): Boolean;\r\n function ContainsAll(const ACollection: IJclIntfCollection): Boolean;\r\n function Extract(const AInterface: IInterface): Boolean;\r\n function ExtractAll(const ACollection: IJclIntfCollection): Boolean;\r\n function First: IJclIntfIterator;\r\n function IsEmpty: Boolean;\r\n function Last: IJclIntfIterator;\r\n function Remove(const AInterface: IInterface): Boolean;\r\n function RemoveAll(const ACollection: IJclIntfCollection): Boolean;\r\n function RetainAll(const ACollection: IJclIntfCollection): Boolean;\r\n function Size: Integer;\r\n {$IFDEF SUPPORTS_FOR_IN}\r\n function GetEnumerator: IJclIntfIterator;\r\n {$ENDIF SUPPORTS_FOR_IN}\r\n { IJclIntfSet }\r\n procedure Intersect(const ACollection: IJclIntfCollection);\r\n procedure Subtract(const ACollection: IJclIntfCollection);\r\n procedure Union(const ACollection: IJclIntfCollection);\r\n end;\r\n\r\n TJclIntfHashSetIterator = class(TJclAbstractIterator, IJclIntfIterator)\r\n protected\r\n FBucketIndex: Integer;\r\n FItemIndex: Integer;\r\n FStart: TItrStart;\r\n FOwnHashSet: TJclIntfHashSet;\r\n procedure AssignPropertiesTo(Dest: TJclAbstractIterator); override;\r\n function CreateEmptyIterator: TJclAbstractIterator; override;\r\n public\r\n constructor Create(AOwnHashSet: TJclIntfHashSet; ABucketIndex: Integer; AItemIndex: Integer; AValid: Boolean; AStart: TItrStart);\r\n { IJclIntfIterator }\r\n function Add(const AInterface: IInterface): Boolean;\r\n procedure Extract;\r\n function GetObject: IInterface;\r\n function HasNext: Boolean;\r\n function HasPrevious: Boolean;\r\n function Insert(const AInterface: IInterface): Boolean;\r\n function IteratorEquals(const AIterator: IJclIntfIterator): Boolean;\r\n function Next: IInterface;\r\n function NextIndex: Integer;\r\n function Previous: IInterface;\r\n function PreviousIndex: Integer;\r\n procedure Remove;\r\n procedure Reset;\r\n procedure SetObject(const AInterface: IInterface);\r\n {$IFDEF SUPPORTS_FOR_IN}\r\n function MoveNext: Boolean;\r\n property Current: IInterface read GetObject;\r\n {$ENDIF SUPPORTS_FOR_IN}\r\n end;\r\n\r\n TJclAnsiStrHashSetBucket = class\r\n public\r\n Size: Integer;\r\n Entries: TDynAnsiStringArray;\r\n end;\r\n\r\n TJclAnsiStrHashSet = class(TJclAnsiStrAbstractCollection, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclIntfCloneable, IJclCloneable, IJclPackable, IJclGrowable, IJclBaseContainer,\r\n IJclAnsiStrContainer, IJclAnsiStrFlatContainer, IJclAnsiStrEqualityComparer, IJclAnsiStrHashConverter, IJclStrBaseContainer,\r\n IJclAnsiStrCollection, IJclAnsiStrSet)\r\n protected\r\n function CreateEmptyContainer: TJclAbstractContainerBase; override;\r\n private\r\n FBuckets: array of TJclAnsiStrHashSetBucket;\r\n FHashToRangeFunction: TJclHashToRangeFunction;\r\n protected\r\n procedure AssignDataTo(Dest: TJclAbstractContainerBase); override;\r\n procedure AssignPropertiesTo(Dest: TJclAbstractContainerBase); override;\r\n public\r\n constructor Create(ACapacity: Integer); overload;\r\n destructor Destroy; override;\r\n property HashToRangeFunction: TJclHashToRangeFunction read FHashToRangeFunction write FHashToRangeFunction;\r\n { IJclPackable }\r\n procedure Pack; override;\r\n procedure SetCapacity(Value: Integer); override;\r\n { IJclAnsiStrCollection }\r\n function Add(const AString: AnsiString): Boolean; override;\r\n function AddAll(const ACollection: IJclAnsiStrCollection): Boolean; override;\r\n procedure Clear; override;\r\n function CollectionEquals(const ACollection: IJclAnsiStrCollection): Boolean; override;\r\n function Contains(const AString: AnsiString): Boolean; override;\r\n function ContainsAll(const ACollection: IJclAnsiStrCollection): Boolean; override;\r\n function Extract(const AString: AnsiString): Boolean; override;\r\n function ExtractAll(const ACollection: IJclAnsiStrCollection): Boolean; override;\r\n function First: IJclAnsiStrIterator; override;\r\n function IsEmpty: Boolean; override;\r\n function Last: IJclAnsiStrIterator; override;\r\n function Remove(const AString: AnsiString): Boolean; override;\r\n function RemoveAll(const ACollection: IJclAnsiStrCollection): Boolean; override;\r\n function RetainAll(const ACollection: IJclAnsiStrCollection): Boolean; override;\r\n function Size: Integer; override;\r\n {$IFDEF SUPPORTS_FOR_IN}\r\n function GetEnumerator: IJclAnsiStrIterator; override;\r\n {$ENDIF SUPPORTS_FOR_IN}\r\n { IJclAnsiStrSet }\r\n procedure Intersect(const ACollection: IJclAnsiStrCollection);\r\n procedure Subtract(const ACollection: IJclAnsiStrCollection);\r\n procedure Union(const ACollection: IJclAnsiStrCollection);\r\n end;\r\n\r\n TJclAnsiStrHashSetIterator = class(TJclAbstractIterator, IJclAnsiStrIterator)\r\n protected\r\n FBucketIndex: Integer;\r\n FItemIndex: Integer;\r\n FStart: TItrStart;\r\n FOwnHashSet: TJclAnsiStrHashSet;\r\n procedure AssignPropertiesTo(Dest: TJclAbstractIterator); override;\r\n function CreateEmptyIterator: TJclAbstractIterator; override;\r\n public\r\n constructor Create(AOwnHashSet: TJclAnsiStrHashSet; ABucketIndex: Integer; AItemIndex: Integer; AValid: Boolean; AStart: TItrStart);\r\n { IJclAnsiStrIterator }\r\n function Add(const AString: AnsiString): Boolean;\r\n procedure Extract;\r\n function GetString: AnsiString;\r\n function HasNext: Boolean;\r\n function HasPrevious: Boolean;\r\n function Insert(const AString: AnsiString): Boolean;\r\n function IteratorEquals(const AIterator: IJclAnsiStrIterator): Boolean;\r\n function Next: AnsiString;\r\n function NextIndex: Integer;\r\n function Previous: AnsiString;\r\n function PreviousIndex: Integer;\r\n procedure Remove;\r\n procedure Reset;\r\n procedure SetString(const AString: AnsiString);\r\n {$IFDEF SUPPORTS_FOR_IN}\r\n function MoveNext: Boolean;\r\n property Current: AnsiString read GetString;\r\n {$ENDIF SUPPORTS_FOR_IN}\r\n end;\r\n\r\n TJclWideStrHashSetBucket = class\r\n public\r\n Size: Integer;\r\n Entries: TDynWideStringArray;\r\n end;\r\n\r\n TJclWideStrHashSet = class(TJclWideStrAbstractCollection, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclIntfCloneable, IJclCloneable, IJclPackable, IJclGrowable, IJclBaseContainer,\r\n IJclWideStrContainer, IJclWideStrFlatContainer, IJclWideStrEqualityComparer, IJclWideStrHashConverter, IJclStrBaseContainer,\r\n IJclWideStrCollection, IJclWideStrSet)\r\n protected\r\n function CreateEmptyContainer: TJclAbstractContainerBase; override;\r\n private\r\n FBuckets: array of TJclWideStrHashSetBucket;\r\n FHashToRangeFunction: TJclHashToRangeFunction;\r\n protected\r\n procedure AssignDataTo(Dest: TJclAbstractContainerBase); override;\r\n procedure AssignPropertiesTo(Dest: TJclAbstractContainerBase); override;\r\n public\r\n constructor Create(ACapacity: Integer); overload;\r\n destructor Destroy; override;\r\n property HashToRangeFunction: TJclHashToRangeFunction read FHashToRangeFunction write FHashToRangeFunction;\r\n { IJclPackable }\r\n procedure Pack; override;\r\n procedure SetCapacity(Value: Integer); override;\r\n { IJclWideStrCollection }\r\n function Add(const AString: WideString): Boolean; override;\r\n function AddAll(const ACollection: IJclWideStrCollection): Boolean; override;\r\n procedure Clear; override;\r\n function CollectionEquals(const ACollection: IJclWideStrCollection): Boolean; override;\r\n function Contains(const AString: WideString): Boolean; override;\r\n function ContainsAll(const ACollection: IJclWideStrCollection): Boolean; override;\r\n function Extract(const AString: WideString): Boolean; override;\r\n function ExtractAll(const ACollection: IJclWideStrCollection): Boolean; override;\r\n function First: IJclWideStrIterator; override;\r\n function IsEmpty: Boolean; override;\r\n function Last: IJclWideStrIterator; override;\r\n function Remove(const AString: WideString): Boolean; override;\r\n function RemoveAll(const ACollection: IJclWideStrCollection): Boolean; override;\r\n function RetainAll(const ACollection: IJclWideStrCollection): Boolean; override;\r\n function Size: Integer; override;\r\n {$IFDEF SUPPORTS_FOR_IN}\r\n function GetEnumerator: IJclWideStrIterator; override;\r\n {$ENDIF SUPPORTS_FOR_IN}\r\n { IJclWideStrSet }\r\n procedure Intersect(const ACollection: IJclWideStrCollection);\r\n procedure Subtract(const ACollection: IJclWideStrCollection);\r\n procedure Union(const ACollection: IJclWideStrCollection);\r\n end;\r\n\r\n TJclWideStrHashSetIterator = class(TJclAbstractIterator, IJclWideStrIterator)\r\n protected\r\n FBucketIndex: Integer;\r\n FItemIndex: Integer;\r\n FStart: TItrStart;\r\n FOwnHashSet: TJclWideStrHashSet;\r\n procedure AssignPropertiesTo(Dest: TJclAbstractIterator); override;\r\n function CreateEmptyIterator: TJclAbstractIterator; override;\r\n public\r\n constructor Create(AOwnHashSet: TJclWideStrHashSet; ABucketIndex: Integer; AItemIndex: Integer; AValid: Boolean; AStart: TItrStart);\r\n { IJclWideStrIterator }\r\n function Add(const AString: WideString): Boolean;\r\n procedure Extract;\r\n function GetString: WideString;\r\n function HasNext: Boolean;\r\n function HasPrevious: Boolean;\r\n function Insert(const AString: WideString): Boolean;\r\n function IteratorEquals(const AIterator: IJclWideStrIterator): Boolean;\r\n function Next: WideString;\r\n function NextIndex: Integer;\r\n function Previous: WideString;\r\n function PreviousIndex: Integer;\r\n procedure Remove;\r\n procedure Reset;\r\n procedure SetString(const AString: WideString);\r\n {$IFDEF SUPPORTS_FOR_IN}\r\n function MoveNext: Boolean;\r\n property Current: WideString read GetString;\r\n {$ENDIF SUPPORTS_FOR_IN}\r\n end;\r\n\r\n {$IFDEF SUPPORTS_UNICODE_STRING}\r\n TJclUnicodeStrHashSetBucket = class\r\n public\r\n Size: Integer;\r\n Entries: TDynUnicodeStringArray;\r\n end;\r\n\r\n {$ENDIF SUPPORTS_UNICODE_STRING}\r\n\r\n {$IFDEF SUPPORTS_UNICODE_STRING}\r\n TJclUnicodeStrHashSet = class(TJclUnicodeStrAbstractCollection, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclIntfCloneable, IJclCloneable, IJclPackable, IJclGrowable, IJclBaseContainer,\r\n IJclUnicodeStrContainer, IJclUnicodeStrFlatContainer, IJclUnicodeStrEqualityComparer, IJclUnicodeStrHashConverter, IJclStrBaseContainer,\r\n IJclUnicodeStrCollection, IJclUnicodeStrSet)\r\n protected\r\n function CreateEmptyContainer: TJclAbstractContainerBase; override;\r\n private\r\n FBuckets: array of TJclUnicodeStrHashSetBucket;\r\n FHashToRangeFunction: TJclHashToRangeFunction;\r\n protected\r\n procedure AssignDataTo(Dest: TJclAbstractContainerBase); override;\r\n procedure AssignPropertiesTo(Dest: TJclAbstractContainerBase); override;\r\n public\r\n constructor Create(ACapacity: Integer); overload;\r\n destructor Destroy; override;\r\n property HashToRangeFunction: TJclHashToRangeFunction read FHashToRangeFunction write FHashToRangeFunction;\r\n { IJclPackable }\r\n procedure Pack; override;\r\n procedure SetCapacity(Value: Integer); override;\r\n { IJclUnicodeStrCollection }\r\n function Add(const AString: UnicodeString): Boolean; override;\r\n function AddAll(const ACollection: IJclUnicodeStrCollection): Boolean; override;\r\n procedure Clear; override;\r\n function CollectionEquals(const ACollection: IJclUnicodeStrCollection): Boolean; override;\r\n function Contains(const AString: UnicodeString): Boolean; override;\r\n function ContainsAll(const ACollection: IJclUnicodeStrCollection): Boolean; override;\r\n function Extract(const AString: UnicodeString): Boolean; override;\r\n function ExtractAll(const ACollection: IJclUnicodeStrCollection): Boolean; override;\r\n function First: IJclUnicodeStrIterator; override;\r\n function IsEmpty: Boolean; override;\r\n function Last: IJclUnicodeStrIterator; override;\r\n function Remove(const AString: UnicodeString): Boolean; override;\r\n function RemoveAll(const ACollection: IJclUnicodeStrCollection): Boolean; override;\r\n function RetainAll(const ACollection: IJclUnicodeStrCollection): Boolean; override;\r\n function Size: Integer; override;\r\n {$IFDEF SUPPORTS_FOR_IN}\r\n function GetEnumerator: IJclUnicodeStrIterator; override;\r\n {$ENDIF SUPPORTS_FOR_IN}\r\n { IJclUnicodeStrSet }\r\n procedure Intersect(const ACollection: IJclUnicodeStrCollection);\r\n procedure Subtract(const ACollection: IJclUnicodeStrCollection);\r\n procedure Union(const ACollection: IJclUnicodeStrCollection);\r\n end;\r\n {$ENDIF SUPPORTS_UNICODE_STRING}\r\n\r\n {$IFDEF SUPPORTS_UNICODE_STRING}\r\n TJclUnicodeStrHashSetIterator = class(TJclAbstractIterator, IJclUnicodeStrIterator)\r\n protected\r\n FBucketIndex: Integer;\r\n FItemIndex: Integer;\r\n FStart: TItrStart;\r\n FOwnHashSet: TJclUnicodeStrHashSet;\r\n procedure AssignPropertiesTo(Dest: TJclAbstractIterator); override;\r\n function CreateEmptyIterator: TJclAbstractIterator; override;\r\n public\r\n constructor Create(AOwnHashSet: TJclUnicodeStrHashSet; ABucketIndex: Integer; AItemIndex: Integer; AValid: Boolean; AStart: TItrStart);\r\n { IJclUnicodeStrIterator }\r\n function Add(const AString: UnicodeString): Boolean;\r\n procedure Extract;\r\n function GetString: UnicodeString;\r\n function HasNext: Boolean;\r\n function HasPrevious: Boolean;\r\n function Insert(const AString: UnicodeString): Boolean;\r\n function IteratorEquals(const AIterator: IJclUnicodeStrIterator): Boolean;\r\n function Next: UnicodeString;\r\n function NextIndex: Integer;\r\n function Previous: UnicodeString;\r\n function PreviousIndex: Integer;\r\n procedure Remove;\r\n procedure Reset;\r\n procedure SetString(const AString: UnicodeString);\r\n {$IFDEF SUPPORTS_FOR_IN}\r\n function MoveNext: Boolean;\r\n property Current: UnicodeString read GetString;\r\n {$ENDIF SUPPORTS_FOR_IN}\r\n end;\r\n {$ENDIF SUPPORTS_UNICODE_STRING}\r\n\r\n {$IFDEF CONTAINER_ANSISTR}\r\n TJclStrHashSetBucket = TJclAnsiStrHashSetBucket;\r\n {$ENDIF CONTAINER_ANSISTR}\r\n {$IFDEF CONTAINER_WIDESTR}\r\n TJclStrHashSetBucket = TJclWideStrHashSetBucket;\r\n {$ENDIF CONTAINER_WIDESTR}\r\n {$IFDEF CONTAINER_UNICODESTR}\r\n TJclStrHashSetBucket = TJclUnicodeStrHashSetBucket;\r\n {$ENDIF CONTAINER_UNICODESTR}\r\n\r\n {$IFDEF CONTAINER_ANSISTR}\r\n TJclStrHashSet = TJclAnsiStrHashSet;\r\n {$ENDIF CONTAINER_ANSISTR}\r\n {$IFDEF CONTAINER_WIDESTR}\r\n TJclStrHashSet = TJclWideStrHashSet;\r\n {$ENDIF CONTAINER_WIDESTR}\r\n {$IFDEF CONTAINER_UNICODESTR}\r\n TJclStrHashSet = TJclUnicodeStrHashSet;\r\n {$ENDIF CONTAINER_UNICODESTR}\r\n\r\n {$IFDEF CONTAINER_ANSISTR}\r\n TJclStrHashSetIterator = TJclAnsiStrHashSetIterator;\r\n {$ENDIF CONTAINER_ANSISTR}\r\n {$IFDEF CONTAINER_WIDESTR}\r\n TJclStrHashSetIterator = TJclWideStrHashSetIterator;\r\n {$ENDIF CONTAINER_WIDESTR}\r\n {$IFDEF CONTAINER_UNICODESTR}\r\n TJclStrHashSetIterator = TJclUnicodeStrHashSetIterator;\r\n {$ENDIF CONTAINER_UNICODESTR}\r\n\r\n TJclSingleHashSetBucket = class\r\n public\r\n Size: Integer;\r\n Entries: TDynSingleArray;\r\n end;\r\n\r\n TJclSingleHashSet = class(TJclSingleAbstractContainer, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclIntfCloneable, IJclCloneable, IJclPackable, IJclGrowable, IJclBaseContainer,\r\n IJclSingleContainer, IJclSingleFlatContainer, IJclSingleEqualityComparer, IJclSingleHashConverter,\r\n IJclSingleCollection, IJclSingleSet)\r\n protected\r\n function CreateEmptyContainer: TJclAbstractContainerBase; override;\r\n private\r\n FBuckets: array of TJclSingleHashSetBucket;\r\n FHashToRangeFunction: TJclHashToRangeFunction;\r\n protected\r\n procedure AssignDataTo(Dest: TJclAbstractContainerBase); override;\r\n procedure AssignPropertiesTo(Dest: TJclAbstractContainerBase); override;\r\n public\r\n constructor Create(ACapacity: Integer); overload;\r\n destructor Destroy; override;\r\n property HashToRangeFunction: TJclHashToRangeFunction read FHashToRangeFunction write FHashToRangeFunction;\r\n { IJclPackable }\r\n procedure Pack; override;\r\n procedure SetCapacity(Value: Integer); override;\r\n { IJclSingleCollection }\r\n function Add(const AValue: Single): Boolean;\r\n function AddAll(const ACollection: IJclSingleCollection): Boolean;\r\n procedure Clear;\r\n function CollectionEquals(const ACollection: IJclSingleCollection): Boolean;\r\n function Contains(const AValue: Single): Boolean;\r\n function ContainsAll(const ACollection: IJclSingleCollection): Boolean;\r\n function Extract(const AValue: Single): Boolean;\r\n function ExtractAll(const ACollection: IJclSingleCollection): Boolean;\r\n function First: IJclSingleIterator;\r\n function IsEmpty: Boolean;\r\n function Last: IJclSingleIterator;\r\n function Remove(const AValue: Single): Boolean;\r\n function RemoveAll(const ACollection: IJclSingleCollection): Boolean;\r\n function RetainAll(const ACollection: IJclSingleCollection): Boolean;\r\n function Size: Integer;\r\n {$IFDEF SUPPORTS_FOR_IN}\r\n function GetEnumerator: IJclSingleIterator;\r\n {$ENDIF SUPPORTS_FOR_IN}\r\n { IJclSingleSet }\r\n procedure Intersect(const ACollection: IJclSingleCollection);\r\n procedure Subtract(const ACollection: IJclSingleCollection);\r\n procedure Union(const ACollection: IJclSingleCollection);\r\n end;\r\n\r\n TJclSingleHashSetIterator = class(TJclAbstractIterator, IJclSingleIterator)\r\n protected\r\n FBucketIndex: Integer;\r\n FItemIndex: Integer;\r\n FStart: TItrStart;\r\n FOwnHashSet: TJclSingleHashSet;\r\n procedure AssignPropertiesTo(Dest: TJclAbstractIterator); override;\r\n function CreateEmptyIterator: TJclAbstractIterator; override;\r\n public\r\n constructor Create(AOwnHashSet: TJclSingleHashSet; ABucketIndex: Integer; AItemIndex: Integer; AValid: Boolean; AStart: TItrStart);\r\n { IJclSingleIterator }\r\n function Add(const AValue: Single): Boolean;\r\n procedure Extract;\r\n function GetValue: Single;\r\n function HasNext: Boolean;\r\n function HasPrevious: Boolean;\r\n function Insert(const AValue: Single): Boolean;\r\n function IteratorEquals(const AIterator: IJclSingleIterator): Boolean;\r\n function Next: Single;\r\n function NextIndex: Integer;\r\n function Previous: Single;\r\n function PreviousIndex: Integer;\r\n procedure Remove;\r\n procedure Reset;\r\n procedure SetValue(const AValue: Single);\r\n {$IFDEF SUPPORTS_FOR_IN}\r\n function MoveNext: Boolean;\r\n property Current: Single read GetValue;\r\n {$ENDIF SUPPORTS_FOR_IN}\r\n end;\r\n\r\n TJclDoubleHashSetBucket = class\r\n public\r\n Size: Integer;\r\n Entries: TDynDoubleArray;\r\n end;\r\n\r\n TJclDoubleHashSet = class(TJclDoubleAbstractContainer, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclIntfCloneable, IJclCloneable, IJclPackable, IJclGrowable, IJclBaseContainer,\r\n IJclDoubleContainer, IJclDoubleFlatContainer, IJclDoubleEqualityComparer, IJclDoubleHashConverter,\r\n IJclDoubleCollection, IJclDoubleSet)\r\n protected\r\n function CreateEmptyContainer: TJclAbstractContainerBase; override;\r\n private\r\n FBuckets: array of TJclDoubleHashSetBucket;\r\n FHashToRangeFunction: TJclHashToRangeFunction;\r\n protected\r\n procedure AssignDataTo(Dest: TJclAbstractContainerBase); override;\r\n procedure AssignPropertiesTo(Dest: TJclAbstractContainerBase); override;\r\n public\r\n constructor Create(ACapacity: Integer); overload;\r\n destructor Destroy; override;\r\n property HashToRangeFunction: TJclHashToRangeFunction read FHashToRangeFunction write FHashToRangeFunction;\r\n { IJclPackable }\r\n procedure Pack; override;\r\n procedure SetCapacity(Value: Integer); override;\r\n { IJclDoubleCollection }\r\n function Add(const AValue: Double): Boolean;\r\n function AddAll(const ACollection: IJclDoubleCollection): Boolean;\r\n procedure Clear;\r\n function CollectionEquals(const ACollection: IJclDoubleCollection): Boolean;\r\n function Contains(const AValue: Double): Boolean;\r\n function ContainsAll(const ACollection: IJclDoubleCollection): Boolean;\r\n function Extract(const AValue: Double): Boolean;\r\n function ExtractAll(const ACollection: IJclDoubleCollection): Boolean;\r\n function First: IJclDoubleIterator;\r\n function IsEmpty: Boolean;\r\n function Last: IJclDoubleIterator;\r\n function Remove(const AValue: Double): Boolean;\r\n function RemoveAll(const ACollection: IJclDoubleCollection): Boolean;\r\n function RetainAll(const ACollection: IJclDoubleCollection): Boolean;\r\n function Size: Integer;\r\n {$IFDEF SUPPORTS_FOR_IN}\r\n function GetEnumerator: IJclDoubleIterator;\r\n {$ENDIF SUPPORTS_FOR_IN}\r\n { IJclDoubleSet }\r\n procedure Intersect(const ACollection: IJclDoubleCollection);\r\n procedure Subtract(const ACollection: IJclDoubleCollection);\r\n procedure Union(const ACollection: IJclDoubleCollection);\r\n end;\r\n\r\n TJclDoubleHashSetIterator = class(TJclAbstractIterator, IJclDoubleIterator)\r\n protected\r\n FBucketIndex: Integer;\r\n FItemIndex: Integer;\r\n FStart: TItrStart;\r\n FOwnHashSet: TJclDoubleHashSet;\r\n procedure AssignPropertiesTo(Dest: TJclAbstractIterator); override;\r\n function CreateEmptyIterator: TJclAbstractIterator; override;\r\n public\r\n constructor Create(AOwnHashSet: TJclDoubleHashSet; ABucketIndex: Integer; AItemIndex: Integer; AValid: Boolean; AStart: TItrStart);\r\n { IJclDoubleIterator }\r\n function Add(const AValue: Double): Boolean;\r\n procedure Extract;\r\n function GetValue: Double;\r\n function HasNext: Boolean;\r\n function HasPrevious: Boolean;\r\n function Insert(const AValue: Double): Boolean;\r\n function IteratorEquals(const AIterator: IJclDoubleIterator): Boolean;\r\n function Next: Double;\r\n function NextIndex: Integer;\r\n function Previous: Double;\r\n function PreviousIndex: Integer;\r\n procedure Remove;\r\n procedure Reset;\r\n procedure SetValue(const AValue: Double);\r\n {$IFDEF SUPPORTS_FOR_IN}\r\n function MoveNext: Boolean;\r\n property Current: Double read GetValue;\r\n {$ENDIF SUPPORTS_FOR_IN}\r\n end;\r\n\r\n TJclExtendedHashSetBucket = class\r\n public\r\n Size: Integer;\r\n Entries: TDynExtendedArray;\r\n end;\r\n\r\n TJclExtendedHashSet = class(TJclExtendedAbstractContainer, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclIntfCloneable, IJclCloneable, IJclPackable, IJclGrowable, IJclBaseContainer,\r\n IJclExtendedContainer, IJclExtendedFlatContainer, IJclExtendedEqualityComparer, IJclExtendedHashConverter,\r\n IJclExtendedCollection, IJclExtendedSet)\r\n protected\r\n function CreateEmptyContainer: TJclAbstractContainerBase; override;\r\n private\r\n FBuckets: array of TJclExtendedHashSetBucket;\r\n FHashToRangeFunction: TJclHashToRangeFunction;\r\n protected\r\n procedure AssignDataTo(Dest: TJclAbstractContainerBase); override;\r\n procedure AssignPropertiesTo(Dest: TJclAbstractContainerBase); override;\r\n public\r\n constructor Create(ACapacity: Integer); overload;\r\n destructor Destroy; override;\r\n property HashToRangeFunction: TJclHashToRangeFunction read FHashToRangeFunction write FHashToRangeFunction;\r\n { IJclPackable }\r\n procedure Pack; override;\r\n procedure SetCapacity(Value: Integer); override;\r\n { IJclExtendedCollection }\r\n function Add(const AValue: Extended): Boolean;\r\n function AddAll(const ACollection: IJclExtendedCollection): Boolean;\r\n procedure Clear;\r\n function CollectionEquals(const ACollection: IJclExtendedCollection): Boolean;\r\n function Contains(const AValue: Extended): Boolean;\r\n function ContainsAll(const ACollection: IJclExtendedCollection): Boolean;\r\n function Extract(const AValue: Extended): Boolean;\r\n function ExtractAll(const ACollection: IJclExtendedCollection): Boolean;\r\n function First: IJclExtendedIterator;\r\n function IsEmpty: Boolean;\r\n function Last: IJclExtendedIterator;\r\n function Remove(const AValue: Extended): Boolean;\r\n function RemoveAll(const ACollection: IJclExtendedCollection): Boolean;\r\n function RetainAll(const ACollection: IJclExtendedCollection): Boolean;\r\n function Size: Integer;\r\n {$IFDEF SUPPORTS_FOR_IN}\r\n function GetEnumerator: IJclExtendedIterator;\r\n {$ENDIF SUPPORTS_FOR_IN}\r\n { IJclExtendedSet }\r\n procedure Intersect(const ACollection: IJclExtendedCollection);\r\n procedure Subtract(const ACollection: IJclExtendedCollection);\r\n procedure Union(const ACollection: IJclExtendedCollection);\r\n end;\r\n\r\n TJclExtendedHashSetIterator = class(TJclAbstractIterator, IJclExtendedIterator)\r\n protected\r\n FBucketIndex: Integer;\r\n FItemIndex: Integer;\r\n FStart: TItrStart;\r\n FOwnHashSet: TJclExtendedHashSet;\r\n procedure AssignPropertiesTo(Dest: TJclAbstractIterator); override;\r\n function CreateEmptyIterator: TJclAbstractIterator; override;\r\n public\r\n constructor Create(AOwnHashSet: TJclExtendedHashSet; ABucketIndex: Integer; AItemIndex: Integer; AValid: Boolean; AStart: TItrStart);\r\n { IJclExtendedIterator }\r\n function Add(const AValue: Extended): Boolean;\r\n procedure Extract;\r\n function GetValue: Extended;\r\n function HasNext: Boolean;\r\n function HasPrevious: Boolean;\r\n function Insert(const AValue: Extended): Boolean;\r\n function IteratorEquals(const AIterator: IJclExtendedIterator): Boolean;\r\n function Next: Extended;\r\n function NextIndex: Integer;\r\n function Previous: Extended;\r\n function PreviousIndex: Integer;\r\n procedure Remove;\r\n procedure Reset;\r\n procedure SetValue(const AValue: Extended);\r\n {$IFDEF SUPPORTS_FOR_IN}\r\n function MoveNext: Boolean;\r\n property Current: Extended read GetValue;\r\n {$ENDIF SUPPORTS_FOR_IN}\r\n end;\r\n\r\n {$IFDEF MATH_SINGLE_PRECISION}\r\n TJclFloatHashSetBucket = TJclSingleHashSetBucket;\r\n {$ENDIF MATH_SINGLE_PRECISION}\r\n {$IFDEF MATH_DOUBLE_PRECISION}\r\n TJclFloatHashSetBucket = TJclDoubleHashSetBucket;\r\n {$ENDIF MATH_DOUBLE_PRECISION}\r\n {$IFDEF MATH_EXTENDED_PRECISION}\r\n TJclFloatHashSetBucket = TJclExtendedHashSetBucket;\r\n {$ENDIF MATH_EXTENDED_PRECISION}\r\n\r\n {$IFDEF MATH_SINGLE_PRECISION}\r\n TJclFloatHashSet = TJclSingleHashSet;\r\n {$ENDIF MATH_SINGLE_PRECISION}\r\n {$IFDEF MATH_DOUBLE_PRECISION}\r\n TJclFloatHashSet = TJclDoubleHashSet;\r\n {$ENDIF MATH_DOUBLE_PRECISION}\r\n {$IFDEF MATH_EXTENDED_PRECISION}\r\n TJclFloatHashSet = TJclExtendedHashSet;\r\n {$ENDIF MATH_EXTENDED_PRECISION}\r\n\r\n {$IFDEF MATH_SINGLE_PRECISION}\r\n TJclFloatHashSetIterator = TJclSingleHashSetIterator;\r\n {$ENDIF MATH_SINGLE_PRECISION}\r\n {$IFDEF MATH_DOUBLE_PRECISION}\r\n TJclFloatHashSetIterator = TJclDoubleHashSetIterator;\r\n {$ENDIF MATH_DOUBLE_PRECISION}\r\n {$IFDEF MATH_EXTENDED_PRECISION}\r\n TJclFloatHashSetIterator = TJclExtendedHashSetIterator;\r\n {$ENDIF MATH_EXTENDED_PRECISION}\r\n\r\n TJclIntegerHashSetBucket = class\r\n public\r\n Size: Integer;\r\n Entries: TDynIntegerArray;\r\n end;\r\n\r\n TJclIntegerHashSet = class(TJclIntegerAbstractContainer, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclIntfCloneable, IJclCloneable, IJclPackable, IJclGrowable, IJclBaseContainer,\r\n IJclIntegerContainer, IJclIntegerFlatContainer, IJclIntegerEqualityComparer, IJclIntegerHashConverter,\r\n IJclIntegerCollection, IJclIntegerSet)\r\n protected\r\n function CreateEmptyContainer: TJclAbstractContainerBase; override;\r\n private\r\n FBuckets: array of TJclIntegerHashSetBucket;\r\n FHashToRangeFunction: TJclHashToRangeFunction;\r\n protected\r\n procedure AssignDataTo(Dest: TJclAbstractContainerBase); override;\r\n procedure AssignPropertiesTo(Dest: TJclAbstractContainerBase); override;\r\n public\r\n constructor Create(ACapacity: Integer); overload;\r\n destructor Destroy; override;\r\n property HashToRangeFunction: TJclHashToRangeFunction read FHashToRangeFunction write FHashToRangeFunction;\r\n { IJclPackable }\r\n procedure Pack; override;\r\n procedure SetCapacity(Value: Integer); override;\r\n { IJclIntegerCollection }\r\n function Add(AValue: Integer): Boolean;\r\n function AddAll(const ACollection: IJclIntegerCollection): Boolean;\r\n procedure Clear;\r\n function CollectionEquals(const ACollection: IJclIntegerCollection): Boolean;\r\n function Contains(AValue: Integer): Boolean;\r\n function ContainsAll(const ACollection: IJclIntegerCollection): Boolean;\r\n function Extract(AValue: Integer): Boolean;\r\n function ExtractAll(const ACollection: IJclIntegerCollection): Boolean;\r\n function First: IJclIntegerIterator;\r\n function IsEmpty: Boolean;\r\n function Last: IJclIntegerIterator;\r\n function Remove(AValue: Integer): Boolean;\r\n function RemoveAll(const ACollection: IJclIntegerCollection): Boolean;\r\n function RetainAll(const ACollection: IJclIntegerCollection): Boolean;\r\n function Size: Integer;\r\n {$IFDEF SUPPORTS_FOR_IN}\r\n function GetEnumerator: IJclIntegerIterator;\r\n {$ENDIF SUPPORTS_FOR_IN}\r\n { IJclIntegerSet }\r\n procedure Intersect(const ACollection: IJclIntegerCollection);\r\n procedure Subtract(const ACollection: IJclIntegerCollection);\r\n procedure Union(const ACollection: IJclIntegerCollection);\r\n end;\r\n\r\n TJclIntegerHashSetIterator = class(TJclAbstractIterator, IJclIntegerIterator)\r\n protected\r\n FBucketIndex: Integer;\r\n FItemIndex: Integer;\r\n FStart: TItrStart;\r\n FOwnHashSet: TJclIntegerHashSet;\r\n procedure AssignPropertiesTo(Dest: TJclAbstractIterator); override;\r\n function CreateEmptyIterator: TJclAbstractIterator; override;\r\n public\r\n constructor Create(AOwnHashSet: TJclIntegerHashSet; ABucketIndex: Integer; AItemIndex: Integer; AValid: Boolean; AStart: TItrStart);\r\n { IJclIntegerIterator }\r\n function Add(AValue: Integer): Boolean;\r\n procedure Extract;\r\n function GetValue: Integer;\r\n function HasNext: Boolean;\r\n function HasPrevious: Boolean;\r\n function Insert(AValue: Integer): Boolean;\r\n function IteratorEquals(const AIterator: IJclIntegerIterator): Boolean;\r\n function Next: Integer;\r\n function NextIndex: Integer;\r\n function Previous: Integer;\r\n function PreviousIndex: Integer;\r\n procedure Remove;\r\n procedure Reset;\r\n procedure SetValue(AValue: Integer);\r\n {$IFDEF SUPPORTS_FOR_IN}\r\n function MoveNext: Boolean;\r\n property Current: Integer read GetValue;\r\n {$ENDIF SUPPORTS_FOR_IN}\r\n end;\r\n\r\n TJclCardinalHashSetBucket = class\r\n public\r\n Size: Integer;\r\n Entries: TDynCardinalArray;\r\n end;\r\n\r\n TJclCardinalHashSet = class(TJclCardinalAbstractContainer, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclIntfCloneable, IJclCloneable, IJclPackable, IJclGrowable, IJclBaseContainer,\r\n IJclCardinalContainer, IJclCardinalFlatContainer, IJclCardinalEqualityComparer, IJclCardinalHashConverter,\r\n IJclCardinalCollection, IJclCardinalSet)\r\n protected\r\n function CreateEmptyContainer: TJclAbstractContainerBase; override;\r\n private\r\n FBuckets: array of TJclCardinalHashSetBucket;\r\n FHashToRangeFunction: TJclHashToRangeFunction;\r\n protected\r\n procedure AssignDataTo(Dest: TJclAbstractContainerBase); override;\r\n procedure AssignPropertiesTo(Dest: TJclAbstractContainerBase); override;\r\n public\r\n constructor Create(ACapacity: Integer); overload;\r\n destructor Destroy; override;\r\n property HashToRangeFunction: TJclHashToRangeFunction read FHashToRangeFunction write FHashToRangeFunction;\r\n { IJclPackable }\r\n procedure Pack; override;\r\n procedure SetCapacity(Value: Integer); override;\r\n { IJclCardinalCollection }\r\n function Add(AValue: Cardinal): Boolean;\r\n function AddAll(const ACollection: IJclCardinalCollection): Boolean;\r\n procedure Clear;\r\n function CollectionEquals(const ACollection: IJclCardinalCollection): Boolean;\r\n function Contains(AValue: Cardinal): Boolean;\r\n function ContainsAll(const ACollection: IJclCardinalCollection): Boolean;\r\n function Extract(AValue: Cardinal): Boolean;\r\n function ExtractAll(const ACollection: IJclCardinalCollection): Boolean;\r\n function First: IJclCardinalIterator;\r\n function IsEmpty: Boolean;\r\n function Last: IJclCardinalIterator;\r\n function Remove(AValue: Cardinal): Boolean;\r\n function RemoveAll(const ACollection: IJclCardinalCollection): Boolean;\r\n function RetainAll(const ACollection: IJclCardinalCollection): Boolean;\r\n function Size: Integer;\r\n {$IFDEF SUPPORTS_FOR_IN}\r\n function GetEnumerator: IJclCardinalIterator;\r\n {$ENDIF SUPPORTS_FOR_IN}\r\n { IJclCardinalSet }\r\n procedure Intersect(const ACollection: IJclCardinalCollection);\r\n procedure Subtract(const ACollection: IJclCardinalCollection);\r\n procedure Union(const ACollection: IJclCardinalCollection);\r\n end;\r\n\r\n TJclCardinalHashSetIterator = class(TJclAbstractIterator, IJclCardinalIterator)\r\n protected\r\n FBucketIndex: Integer;\r\n FItemIndex: Integer;\r\n FStart: TItrStart;\r\n FOwnHashSet: TJclCardinalHashSet;\r\n procedure AssignPropertiesTo(Dest: TJclAbstractIterator); override;\r\n function CreateEmptyIterator: TJclAbstractIterator; override;\r\n public\r\n constructor Create(AOwnHashSet: TJclCardinalHashSet; ABucketIndex: Integer; AItemIndex: Integer; AValid: Boolean; AStart: TItrStart);\r\n { IJclCardinalIterator }\r\n function Add(AValue: Cardinal): Boolean;\r\n procedure Extract;\r\n function GetValue: Cardinal;\r\n function HasNext: Boolean;\r\n function HasPrevious: Boolean;\r\n function Insert(AValue: Cardinal): Boolean;\r\n function IteratorEquals(const AIterator: IJclCardinalIterator): Boolean;\r\n function Next: Cardinal;\r\n function NextIndex: Integer;\r\n function Previous: Cardinal;\r\n function PreviousIndex: Integer;\r\n procedure Remove;\r\n procedure Reset;\r\n procedure SetValue(AValue: Cardinal);\r\n {$IFDEF SUPPORTS_FOR_IN}\r\n function MoveNext: Boolean;\r\n property Current: Cardinal read GetValue;\r\n {$ENDIF SUPPORTS_FOR_IN}\r\n end;\r\n\r\n TJclInt64HashSetBucket = class\r\n public\r\n Size: Integer;\r\n Entries: TDynInt64Array;\r\n end;\r\n\r\n TJclInt64HashSet = class(TJclInt64AbstractContainer, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclIntfCloneable, IJclCloneable, IJclPackable, IJclGrowable, IJclBaseContainer,\r\n IJclInt64Container, IJclInt64FlatContainer, IJclInt64EqualityComparer, IJclInt64HashConverter,\r\n IJclInt64Collection, IJclInt64Set)\r\n protected\r\n function CreateEmptyContainer: TJclAbstractContainerBase; override;\r\n private\r\n FBuckets: array of TJclInt64HashSetBucket;\r\n FHashToRangeFunction: TJclHashToRangeFunction;\r\n protected\r\n procedure AssignDataTo(Dest: TJclAbstractContainerBase); override;\r\n procedure AssignPropertiesTo(Dest: TJclAbstractContainerBase); override;\r\n public\r\n constructor Create(ACapacity: Integer); overload;\r\n destructor Destroy; override;\r\n property HashToRangeFunction: TJclHashToRangeFunction read FHashToRangeFunction write FHashToRangeFunction;\r\n { IJclPackable }\r\n procedure Pack; override;\r\n procedure SetCapacity(Value: Integer); override;\r\n { IJclInt64Collection }\r\n function Add(const AValue: Int64): Boolean;\r\n function AddAll(const ACollection: IJclInt64Collection): Boolean;\r\n procedure Clear;\r\n function CollectionEquals(const ACollection: IJclInt64Collection): Boolean;\r\n function Contains(const AValue: Int64): Boolean;\r\n function ContainsAll(const ACollection: IJclInt64Collection): Boolean;\r\n function Extract(const AValue: Int64): Boolean;\r\n function ExtractAll(const ACollection: IJclInt64Collection): Boolean;\r\n function First: IJclInt64Iterator;\r\n function IsEmpty: Boolean;\r\n function Last: IJclInt64Iterator;\r\n function Remove(const AValue: Int64): Boolean;\r\n function RemoveAll(const ACollection: IJclInt64Collection): Boolean;\r\n function RetainAll(const ACollection: IJclInt64Collection): Boolean;\r\n function Size: Integer;\r\n {$IFDEF SUPPORTS_FOR_IN}\r\n function GetEnumerator: IJclInt64Iterator;\r\n {$ENDIF SUPPORTS_FOR_IN}\r\n { IJclInt64Set }\r\n procedure Intersect(const ACollection: IJclInt64Collection);\r\n procedure Subtract(const ACollection: IJclInt64Collection);\r\n procedure Union(const ACollection: IJclInt64Collection);\r\n end;\r\n\r\n TJclInt64HashSetIterator = class(TJclAbstractIterator, IJclInt64Iterator)\r\n protected\r\n FBucketIndex: Integer;\r\n FItemIndex: Integer;\r\n FStart: TItrStart;\r\n FOwnHashSet: TJclInt64HashSet;\r\n procedure AssignPropertiesTo(Dest: TJclAbstractIterator); override;\r\n function CreateEmptyIterator: TJclAbstractIterator; override;\r\n public\r\n constructor Create(AOwnHashSet: TJclInt64HashSet; ABucketIndex: Integer; AItemIndex: Integer; AValid: Boolean; AStart: TItrStart);\r\n { IJclInt64Iterator }\r\n function Add(const AValue: Int64): Boolean;\r\n procedure Extract;\r\n function GetValue: Int64;\r\n function HasNext: Boolean;\r\n function HasPrevious: Boolean;\r\n function Insert(const AValue: Int64): Boolean;\r\n function IteratorEquals(const AIterator: IJclInt64Iterator): Boolean;\r\n function Next: Int64;\r\n function NextIndex: Integer;\r\n function Previous: Int64;\r\n function PreviousIndex: Integer;\r\n procedure Remove;\r\n procedure Reset;\r\n procedure SetValue(const AValue: Int64);\r\n {$IFDEF SUPPORTS_FOR_IN}\r\n function MoveNext: Boolean;\r\n property Current: Int64 read GetValue;\r\n {$ENDIF SUPPORTS_FOR_IN}\r\n end;\r\n\r\n TJclPtrHashSetBucket = class\r\n public\r\n Size: Integer;\r\n Entries: TDynPointerArray;\r\n end;\r\n\r\n TJclPtrHashSet = class(TJclPtrAbstractContainer, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclIntfCloneable, IJclCloneable, IJclPackable, IJclGrowable, IJclBaseContainer,\r\n IJclPtrContainer, IJclPtrFlatContainer, IJclPtrEqualityComparer, IJclPtrHashConverter,\r\n IJclPtrCollection, IJclPtrSet)\r\n protected\r\n function CreateEmptyContainer: TJclAbstractContainerBase; override;\r\n private\r\n FBuckets: array of TJclPtrHashSetBucket;\r\n FHashToRangeFunction: TJclHashToRangeFunction;\r\n protected\r\n procedure AssignDataTo(Dest: TJclAbstractContainerBase); override;\r\n procedure AssignPropertiesTo(Dest: TJclAbstractContainerBase); override;\r\n public\r\n constructor Create(ACapacity: Integer); overload;\r\n destructor Destroy; override;\r\n property HashToRangeFunction: TJclHashToRangeFunction read FHashToRangeFunction write FHashToRangeFunction;\r\n { IJclPackable }\r\n procedure Pack; override;\r\n procedure SetCapacity(Value: Integer); override;\r\n { IJclPtrCollection }\r\n function Add(APtr: Pointer): Boolean;\r\n function AddAll(const ACollection: IJclPtrCollection): Boolean;\r\n procedure Clear;\r\n function CollectionEquals(const ACollection: IJclPtrCollection): Boolean;\r\n function Contains(APtr: Pointer): Boolean;\r\n function ContainsAll(const ACollection: IJclPtrCollection): Boolean;\r\n function Extract(APtr: Pointer): Boolean;\r\n function ExtractAll(const ACollection: IJclPtrCollection): Boolean;\r\n function First: IJclPtrIterator;\r\n function IsEmpty: Boolean;\r\n function Last: IJclPtrIterator;\r\n function Remove(APtr: Pointer): Boolean;\r\n function RemoveAll(const ACollection: IJclPtrCollection): Boolean;\r\n function RetainAll(const ACollection: IJclPtrCollection): Boolean;\r\n function Size: Integer;\r\n {$IFDEF SUPPORTS_FOR_IN}\r\n function GetEnumerator: IJclPtrIterator;\r\n {$ENDIF SUPPORTS_FOR_IN}\r\n { IJclPtrSet }\r\n procedure Intersect(const ACollection: IJclPtrCollection);\r\n procedure Subtract(const ACollection: IJclPtrCollection);\r\n procedure Union(const ACollection: IJclPtrCollection);\r\n end;\r\n\r\n TJclPtrHashSetIterator = class(TJclAbstractIterator, IJclPtrIterator)\r\n protected\r\n FBucketIndex: Integer;\r\n FItemIndex: Integer;\r\n FStart: TItrStart;\r\n FOwnHashSet: TJclPtrHashSet;\r\n procedure AssignPropertiesTo(Dest: TJclAbstractIterator); override;\r\n function CreateEmptyIterator: TJclAbstractIterator; override;\r\n public\r\n constructor Create(AOwnHashSet: TJclPtrHashSet; ABucketIndex: Integer; AItemIndex: Integer; AValid: Boolean; AStart: TItrStart);\r\n { IJclPtrIterator }\r\n function Add(APtr: Pointer): Boolean;\r\n procedure Extract;\r\n function GetPointer: Pointer;\r\n function HasNext: Boolean;\r\n function HasPrevious: Boolean;\r\n function Insert(APtr: Pointer): Boolean;\r\n function IteratorEquals(const AIterator: IJclPtrIterator): Boolean;\r\n function Next: Pointer;\r\n function NextIndex: Integer;\r\n function Previous: Pointer;\r\n function PreviousIndex: Integer;\r\n procedure Remove;\r\n procedure Reset;\r\n procedure SetPointer(APtr: Pointer);\r\n {$IFDEF SUPPORTS_FOR_IN}\r\n function MoveNext: Boolean;\r\n property Current: Pointer read GetPointer;\r\n {$ENDIF SUPPORTS_FOR_IN}\r\n end;\r\n\r\n TJclHashSetBucket = class\r\n public\r\n Size: Integer;\r\n Entries: TDynObjectArray;\r\n end;\r\n\r\n TJclHashSet = class(TJclAbstractContainer, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclIntfCloneable, IJclCloneable, IJclPackable, IJclGrowable, IJclBaseContainer,\r\n IJclContainer, IJclFlatContainer, IJclEqualityComparer, IJclHashConverter, IJclObjectOwner,\r\n IJclCollection, IJclSet)\r\n protected\r\n function CreateEmptyContainer: TJclAbstractContainerBase; override;\r\n private\r\n FBuckets: array of TJclHashSetBucket;\r\n FHashToRangeFunction: TJclHashToRangeFunction;\r\n protected\r\n procedure AssignDataTo(Dest: TJclAbstractContainerBase); override;\r\n procedure AssignPropertiesTo(Dest: TJclAbstractContainerBase); override;\r\n public\r\n constructor Create(ACapacity: Integer; AOwnsObjects: Boolean); overload;\r\n destructor Destroy; override;\r\n property HashToRangeFunction: TJclHashToRangeFunction read FHashToRangeFunction write FHashToRangeFunction;\r\n { IJclPackable }\r\n procedure Pack; override;\r\n procedure SetCapacity(Value: Integer); override;\r\n { IJclCollection }\r\n function Add(AObject: TObject): Boolean;\r\n function AddAll(const ACollection: IJclCollection): Boolean;\r\n procedure Clear;\r\n function CollectionEquals(const ACollection: IJclCollection): Boolean;\r\n function Contains(AObject: TObject): Boolean;\r\n function ContainsAll(const ACollection: IJclCollection): Boolean;\r\n function Extract(AObject: TObject): Boolean;\r\n function ExtractAll(const ACollection: IJclCollection): Boolean;\r\n function First: IJclIterator;\r\n function IsEmpty: Boolean;\r\n function Last: IJclIterator;\r\n function Remove(AObject: TObject): Boolean;\r\n function RemoveAll(const ACollection: IJclCollection): Boolean;\r\n function RetainAll(const ACollection: IJclCollection): Boolean;\r\n function Size: Integer;\r\n {$IFDEF SUPPORTS_FOR_IN}\r\n function GetEnumerator: IJclIterator;\r\n {$ENDIF SUPPORTS_FOR_IN}\r\n { IJclSet }\r\n procedure Intersect(const ACollection: IJclCollection);\r\n procedure Subtract(const ACollection: IJclCollection);\r\n procedure Union(const ACollection: IJclCollection);\r\n end;\r\n\r\n TJclHashSetIterator = class(TJclAbstractIterator, IJclIterator)\r\n protected\r\n FBucketIndex: Integer;\r\n FItemIndex: Integer;\r\n FStart: TItrStart;\r\n FOwnHashSet: TJclHashSet;\r\n procedure AssignPropertiesTo(Dest: TJclAbstractIterator); override;\r\n function CreateEmptyIterator: TJclAbstractIterator; override;\r\n public\r\n constructor Create(AOwnHashSet: TJclHashSet; ABucketIndex: Integer; AItemIndex: Integer; AValid: Boolean; AStart: TItrStart);\r\n { IJclIterator }\r\n function Add(AObject: TObject): Boolean;\r\n procedure Extract;\r\n function GetObject: TObject;\r\n function HasNext: Boolean;\r\n function HasPrevious: Boolean;\r\n function Insert(AObject: TObject): Boolean;\r\n function IteratorEquals(const AIterator: IJclIterator): Boolean;\r\n function Next: TObject;\r\n function NextIndex: Integer;\r\n function Previous: TObject;\r\n function PreviousIndex: Integer;\r\n procedure Remove;\r\n procedure Reset;\r\n procedure SetObject(AObject: TObject);\r\n {$IFDEF SUPPORTS_FOR_IN}\r\n function MoveNext: Boolean;\r\n property Current: TObject read GetObject;\r\n {$ENDIF SUPPORTS_FOR_IN}\r\n end;\r\n\r\n\r\n {$IFDEF SUPPORTS_GENERICS}\r\n //DOM-IGNORE-BEGIN\r\n\r\n TJclHashSetBucket = class\r\n public\r\n type\r\n TDynArray = array of T;\r\n public\r\n Size: Integer;\r\n Entries: TDynArray;\r\n procedure MoveArray(var List: TDynArray; FromIndex, ToIndex, Count: SizeInt);\r\n end;\r\n\r\n TJclHashSet = class(TJclAbstractContainer, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclIntfCloneable, IJclCloneable, IJclPackable, IJclGrowable, IJclBaseContainer,\r\n IJclContainer, IJclFlatContainer, IJclEqualityComparer, IJclHashConverter, IJclItemOwner,\r\n IJclCollection, IJclSet)\r\n private\r\n FBuckets: array of TJclHashSetBucket;\r\n FHashToRangeFunction: TJclHashToRangeFunction;\r\n protected\r\n procedure AssignDataTo(Dest: TJclAbstractContainerBase); override;\r\n procedure AssignPropertiesTo(Dest: TJclAbstractContainerBase); override;\r\n public\r\n constructor Create(ACapacity: Integer; AOwnsItems: Boolean); overload;\r\n destructor Destroy; override;\r\n property HashToRangeFunction: TJclHashToRangeFunction read FHashToRangeFunction write FHashToRangeFunction;\r\n { IJclPackable }\r\n procedure Pack; override;\r\n procedure SetCapacity(Value: Integer); override;\r\n { IJclCollection }\r\n function Add(const AItem: T): Boolean;\r\n function AddAll(const ACollection: IJclCollection): Boolean;\r\n procedure Clear;\r\n function CollectionEquals(const ACollection: IJclCollection): Boolean;\r\n function Contains(const AItem: T): Boolean;\r\n function ContainsAll(const ACollection: IJclCollection): Boolean;\r\n function Extract(const AItem: T): Boolean;\r\n function ExtractAll(const ACollection: IJclCollection): Boolean;\r\n function First: IJclIterator;\r\n function IsEmpty: Boolean;\r\n function Last: IJclIterator;\r\n function Remove(const AItem: T): Boolean;\r\n function RemoveAll(const ACollection: IJclCollection): Boolean;\r\n function RetainAll(const ACollection: IJclCollection): Boolean;\r\n function Size: Integer;\r\n {$IFDEF SUPPORTS_FOR_IN}\r\n function GetEnumerator: IJclIterator;\r\n {$ENDIF SUPPORTS_FOR_IN}\r\n { IJclSet }\r\n procedure Intersect(const ACollection: IJclCollection);\r\n procedure Subtract(const ACollection: IJclCollection);\r\n procedure Union(const ACollection: IJclCollection);\r\n end;\r\n\r\n TJclHashSetIterator = class(TJclAbstractIterator, IJclIterator)\r\n protected\r\n FBucketIndex: Integer;\r\n FItemIndex: Integer;\r\n FStart: TItrStart;\r\n FOwnHashSet: TJclHashSet;\r\n procedure AssignPropertiesTo(Dest: TJclAbstractIterator); override;\r\n function CreateEmptyIterator: TJclAbstractIterator; override;\r\n public\r\n constructor Create(AOwnHashSet: TJclHashSet; ABucketIndex: Integer; AItemIndex: Integer; AValid: Boolean; AStart: TItrStart);\r\n { IJclIterator }\r\n function Add(const AItem: T): Boolean;\r\n procedure Extract;\r\n function GetItem: T;\r\n function HasNext: Boolean;\r\n function HasPrevious: Boolean;\r\n function Insert(const AItem: T): Boolean;\r\n function IteratorEquals(const AIterator: IJclIterator): Boolean;\r\n function Next: T;\r\n function NextIndex: Integer;\r\n function Previous: T;\r\n function PreviousIndex: Integer;\r\n procedure Remove;\r\n procedure Reset;\r\n procedure SetItem(const AItem: T);\r\n {$IFDEF SUPPORTS_FOR_IN}\r\n function MoveNext: Boolean;\r\n property Current: T read GetItem;\r\n {$ENDIF SUPPORTS_FOR_IN}\r\n end;\r\n\r\n // E = External helper to compare items for equality\r\n TJclHashSetE = class(TJclHashSet, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclIntfCloneable, IJclCloneable, IJclPackable, IJclGrowable, IJclBaseContainer, IJclContainer,\r\n IJclEqualityComparer, IJclHashConverter, IJclItemOwner, IJclCollection, IJclSet)\r\n private\r\n FEqualityComparer: IJclEqualityComparer;\r\n FHashConverter: IJclHashConverter;\r\n protected\r\n procedure AssignPropertiesTo(Dest: TJclAbstractContainerBase); override;\r\n function CreateEmptyContainer: TJclAbstractContainerBase; override;\r\n public\r\n constructor Create(const AEqualityComparer: IJclEqualityComparer; const AHashConverter: IJclHashConverter;\r\n ACapacity: Integer; AOwnsItems: Boolean); overload;\r\n { IJclEqualityComparer }\r\n function ItemsEqual(const A, B: T): Boolean; override;\r\n property EqualityComparer: IJclEqualityComparer read FEqualityComparer write FEqualityComparer;\r\n { IJclHashConverter }\r\n function Hash(const AItem: T): Integer; override;\r\n property HashConverter: IJclHashConverter read FHashConverter write FHashConverter;\r\n end;\r\n\r\n // F = Function to compare items for equality\r\n TJclHashSetF = class(TJclHashSet, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclIntfCloneable, IJclCloneable, IJclPackable, IJclGrowable, IJclBaseContainer, IJclContainer,\r\n IJclEqualityComparer, IJclHashConverter, IJclItemOwner,\r\n IJclCollection, IJclSet)\r\n protected\r\n function CreateEmptyContainer: TJclAbstractContainerBase; override;\r\n public\r\n constructor Create(const AEqualityCompare: TEqualityCompare; const AHashConvert: THashConvert;\r\n ACapacity: Integer; AOwnsItems: Boolean); overload;\r\n end;\r\n\r\n // I = Items can compare themselves to others\r\n TJclHashSetI, IHashable> = class(TJclHashSet, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclIntfCloneable, IJclCloneable, IJclPackable, IJclGrowable, IJclBaseContainer, IJclContainer,\r\n IJclEqualityComparer, IJclHashConverter, IJclItemOwner,\r\n IJclCollection, IJclSet)\r\n protected\r\n function CreateEmptyContainer: TJclAbstractContainerBase; override;\r\n public\r\n { IJclEqualityComparer }\r\n function ItemsEqual(const A, B: T): Boolean; override;\r\n { IJclHashConverter }\r\n function Hash(const AItem: T): Integer; override;\r\n end;\r\n\r\n //DOM-IGNORE-END\r\n {$ENDIF SUPPORTS_GENERICS}\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jcl.svn.sourceforge.net/svnroot/jcl/tags/JCL-2.4-Build4571/jcl/source/common/JclHashSets.pas $';\r\n Revision: '$Revision: 3740 $';\r\n Date: '$Date: 2012-02-23 21:46:07 +0100 (jeu. 23 févr. 2012) $';\r\n LogPath: 'JCL\\source\\common';\r\n Extra: '';\r\n Data: nil\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\n//=== { TJclIntfHashSet } ====================================================\r\n\r\nconstructor TJclIntfHashSet.Create(ACapacity: Integer);\r\nbegin\r\n inherited Create();\r\n SetCapacity(ACapacity);\r\n FHashToRangeFunction := JclSimpleHashToRange;\r\nend;\r\n\r\ndestructor TJclIntfHashSet.Destroy;\r\nbegin\r\n FReadOnly := False;\r\n Clear;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJclIntfHashSet.Add(const AInterface: IInterface): Boolean;\r\nvar\r\n Index: Integer;\r\n Bucket: TJclIntfHashSetBucket;\r\n I: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if FAllowDefaultElements or (not ItemsEqual(AInterface, nil)) then\r\n begin\r\n Index := FHashToRangeFunction(Hash(AInterface), FCapacity);\r\n Bucket := FBuckets[Index];\r\n if Bucket <> nil then\r\n begin\r\n for I := 0 to Bucket.Size - 1 do\r\n if ItemsEqual(Bucket.Entries[I], AInterface) then\r\n Exit;\r\n end\r\n else\r\n begin\r\n Bucket := TJclIntfHashSetBucket.Create;\r\n SetLength(Bucket.Entries, 1);\r\n FBuckets[Index] := Bucket;\r\n end;\r\n\r\n if Bucket.Size = Length(Bucket.Entries) then\r\n SetLength(Bucket.Entries, CalcGrowCapacity(Bucket.Size, Bucket.Size));\r\n\r\n if Bucket.Size < Length(Bucket.Entries) then\r\n begin\r\n Bucket.Entries[Bucket.Size] := AInterface;\r\n Inc(Bucket.Size);\r\n Inc(FSize);\r\n Result := True;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfHashSet.AddAll(const ACollection: IJclIntfCollection): Boolean;\r\nvar\r\n It: IJclIntfIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n Result := Add(It.Next) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclIntfHashSet.AssignDataTo(Dest: TJclAbstractContainerBase);\r\nvar\r\n I, J: Integer;\r\n SelfBucket, NewBucket: TJclIntfHashSetBucket;\r\n ADest: TJclIntfHashSet;\r\n ACollection: IJclIntfCollection;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n inherited AssignDataTo(Dest);\r\n if Dest is TJclIntfHashSet then\r\n begin\r\n ADest := TJclIntfHashSet(Dest);\r\n ADest.Clear;\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n SelfBucket := FBuckets[I];\r\n if SelfBucket <> nil then\r\n begin\r\n NewBucket := TJclIntfHashSetBucket.Create;\r\n SetLength(NewBucket.Entries, SelfBucket.Size);\r\n for J := 0 to SelfBucket.Size - 1 do\r\n NewBucket.Entries[J] := SelfBucket.Entries[J];\r\n NewBucket.Size := SelfBucket.Size;\r\n ADest.FBuckets[I] := NewBucket;\r\n end;\r\n end;\r\n end\r\n else\r\n if Supports(IInterface(Dest), IJclIntfCollection, ACollection) then\r\n begin\r\n ACollection.Clear;\r\n ACollection.AddAll(Self);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclIntfHashSet.AssignPropertiesTo(Dest: TJclAbstractContainerBase);\r\nbegin\r\n inherited AssignPropertiesto(Dest);\r\n if Dest is TJclIntfHashSet then\r\n TJclIntfHashSet(Dest).FHashToRangeFunction := FHashToRangeFunction;\r\nend;\r\n\r\nprocedure TJclIntfHashSet.Clear;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclIntfHashSetBucket;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n begin\r\n for J := 0 to Bucket.Size - 1 do\r\n FreeObject(Bucket.Entries[J]);\r\n FreeAndNil(FBuckets[I]);\r\n end;\r\n end;\r\n FSize := 0;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfHashSet.CollectionEquals(const ACollection: IJclIntfCollection): Boolean;\r\nvar\r\n I, J: Integer;\r\n It: IJclIntfIterator;\r\n Bucket: TJclIntfHashSetBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n if FSize <> ACollection.Size then\r\n Exit;\r\n It := ACollection.First;\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n for J := 0 to Bucket.Size - 1 do\r\n if not ItemsEqual(Bucket.Entries[J], It.Next) then\r\n Exit;\r\n end;\r\n Result := True;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfHashSet.Contains(const AInterface: IInterface): Boolean;\r\nvar\r\n I: Integer;\r\n Bucket: TJclIntfHashSetBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n Bucket := FBuckets[FHashToRangeFunction(Hash(AInterface), FCapacity)];\r\n if Bucket <> nil then\r\n for I := 0 to Bucket.Size - 1 do\r\n if ItemsEqual(Bucket.Entries[I], AInterface) then\r\n begin\r\n Result := True;\r\n Break;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfHashSet.ContainsAll(const ACollection: IJclIntfCollection): Boolean;\r\nvar\r\n It: IJclIntfIterator;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := True;\r\n if ACollection = nil then\r\n Exit;\r\n It := ACollection.First;\r\n while Result and It.HasNext do\r\n Result := Contains(It.Next);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfHashSet.Extract(const AInterface: IInterface): Boolean;\r\nvar\r\n Bucket: TJclIntfHashSetBucket;\r\n I, NewCapacity: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n Bucket := FBuckets[FHashToRangeFunction(Hash(AInterface), FCapacity)];\r\n if Bucket <> nil then\r\n begin\r\n for I := 0 to Bucket.Size - 1 do\r\n if ItemsEqual(Bucket.Entries[I], AInterface) then\r\n begin\r\n Result := True;\r\n Bucket.Entries[I] := nil;\r\n if I < Length(Bucket.Entries) - 1 then\r\n MoveArray(Bucket.Entries, I + 1, I, Bucket.Size - I - 1);\r\n Dec(Bucket.Size);\r\n Dec(FSize);\r\n Break;\r\n end;\r\n\r\n NewCapacity := CalcPackCapacity(Length(Bucket.Entries), Bucket.Size);\r\n if NewCapacity < Length(Bucket.Entries) then\r\n SetLength(Bucket.Entries, NewCapacity);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfHashSet.ExtractAll(const ACollection: IJclIntfCollection): Boolean;\r\nvar\r\n It: IJclIntfIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n Result := Extract(It.Next) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfHashSet.First: IJclIntfIterator;\r\nvar\r\n ABucketIndex, AItemIndex: Integer;\r\n ABucket: TJclIntfHashSetBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n ABucketIndex := 0;\r\n ABucket := nil;\r\n while ABucketIndex < FCapacity do\r\n begin\r\n ABucket := FBuckets[ABucketIndex];\r\n if (ABucket <> nil) and (ABucket.Size > 0) then\r\n Break;\r\n Inc(ABucketIndex);\r\n end;\r\n if ABucket <> nil then\r\n AItemIndex := 0\r\n else\r\n AItemIndex := -1;\r\n Result := TJclIntfHashSetIterator.Create(Self, ABucketIndex, AItemIndex, False, isFirst);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\n{$IFDEF SUPPORTS_FOR_IN}\r\nfunction TJclIntfHashSet.GetEnumerator: IJclIntfIterator;\r\nbegin\r\n Result := First;\r\nend;\r\n{$ENDIF SUPPORTS_FOR_IN}\r\n\r\nprocedure TJclIntfHashSet.Intersect(const ACollection: IJclIntfCollection);\r\nbegin\r\n RetainAll(ACollection);\r\nend;\r\n\r\nfunction TJclIntfHashSet.IsEmpty: Boolean;\r\nbegin\r\n Result := FSize = 0;\r\nend;\r\n\r\nfunction TJclIntfHashSet.Last: IJclIntfIterator;\r\nvar\r\n ABucketIndex, AItemIndex: Integer;\r\n ABucket: TJclIntfHashSetBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n ABucketIndex := FCapacity - 1;\r\n ABucket := nil;\r\n while ABucketIndex >= 0 do\r\n begin\r\n ABucket := FBuckets[ABucketIndex];\r\n if (ABucket <> nil) and (ABucket.Size > 0) then\r\n Break;\r\n Dec(ABucketIndex);\r\n end;\r\n if ABucket <> nil then\r\n AItemIndex := ABucket.Size - 1\r\n else\r\n AItemIndex := -1;\r\n Result := TJclIntfHashSetIterator.Create(Self, ABucketIndex, AItemIndex, False, isLast);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclIntfHashSet.Pack;\r\nvar\r\n I: Integer;\r\n Bucket: TJclIntfHashSetBucket;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n begin\r\n if Bucket.Size > 0 then\r\n SetLength(Bucket.Entries, Bucket.Size)\r\n else\r\n FreeAndNil(FBuckets[I]);\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfHashSet.Remove(const AInterface: IInterface): Boolean;\r\nvar\r\n Extracted: IInterface;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := Extract(AInterface);\r\n if Result then\r\n begin\r\n Extracted := AInterface;\r\n FreeObject(Extracted);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfHashSet.RemoveAll(const ACollection: IJclIntfCollection): Boolean;\r\nvar\r\n It: IJclIntfIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n Result := Remove(It.Next) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfHashSet.RetainAll(const ACollection: IJclIntfCollection): Boolean;\r\nvar\r\n I, J, NewCapacity: Integer;\r\n Bucket: TJclIntfHashSetBucket;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n begin\r\n for J := Bucket.Size - 1 downto 0 do\r\n if not ACollection.Contains(Bucket.Entries[I]) then\r\n begin\r\n Bucket.Entries[J] := FreeObject(Bucket.Entries[J]);\r\n if J < Length(Bucket.Entries) - 1 then\r\n MoveArray(Bucket.Entries, J + 1, J, Bucket.Size - J - 1);\r\n Dec(Bucket.Size);\r\n Dec(FSize);\r\n end;\r\n\r\n NewCapacity := CalcPackCapacity(Length(Bucket.Entries), Bucket.Size);\r\n if NewCapacity < Length(Bucket.Entries) then\r\n SetLength(Bucket.Entries, NewCapacity);\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclIntfHashSet.SetCapacity(Value: Integer);\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FSize = 0 then\r\n begin\r\n SetLength(FBuckets, Value);\r\n inherited SetCapacity(Value);\r\n end\r\n else\r\n raise EJclOperationNotSupportedError.Create;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfHashSet.Size: Integer;\r\nbegin\r\n Result := FSize;\r\nend;\r\n\r\nprocedure TJclIntfHashSet.Subtract(const ACollection: IJclIntfCollection);\r\nbegin\r\n RemoveAll(ACollection);\r\nend;\r\n\r\nprocedure TJclIntfHashSet.Union(const ACollection: IJclIntfCollection);\r\nbegin\r\n AddAll(ACollection);\r\nend;\r\n\r\n\r\nfunction TJclIntfHashSet.CreateEmptyContainer: TJclAbstractContainerBase;\r\nbegin\r\n Result := TJclIntfHashSet.Create(Size);\r\n AssignPropertiesTo(Result);\r\nend;\r\n\r\n//=== { TJclIntfHashSetIterator } ============================================\r\n\r\nconstructor TJclIntfHashSetIterator.Create(AOwnHashSet: TJclIntfHashSet;\r\n ABucketIndex, AItemIndex: Integer; AValid: Boolean; AStart: TItrStart);\r\nbegin\r\n inherited Create(AValid);\r\n FOwnHashSet := AOwnHashSet;\r\n FBucketIndex := ABucketIndex;\r\n FItemIndex := AItemIndex;\r\n FStart := AStart;\r\nend;\r\n\r\nfunction TJclIntfHashSetIterator.Add(const AInterface: IInterface): Boolean;\r\nbegin\r\n Result := FOwnHashSet.Add(AInterface);\r\nend;\r\n\r\nprocedure TJclIntfHashSetIterator.AssignPropertiesTo(Dest: TJclAbstractIterator);\r\nvar\r\n ADest: TJclIntfHashSetIterator;\r\nbegin\r\n inherited AssignPropertiesTo(Dest);\r\n if Dest is TJclIntfHashSetIterator then\r\n begin\r\n ADest := TJclIntfHashSetIterator(Dest);\r\n ADest.FBucketIndex := FBucketIndex;\r\n ADest.FItemIndex := FItemIndex;\r\n ADest.FOwnHashSet := FOwnHashSet;\r\n ADest.FStart := FStart;\r\n end;\r\nend;\r\n\r\nfunction TJclIntfHashSetIterator.CreateEmptyIterator: TJclAbstractIterator;\r\nbegin\r\n Result := TJclIntfHashSetIterator.Create(FOwnHashSet, FBucketIndex, FItemIndex, Valid, FStart);\r\nend;\r\n\r\nprocedure TJclIntfHashSetIterator.Extract;\r\nvar\r\n AInterface: IInterface;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnHashSet.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n CheckValid;\r\n AInterface := GetObject;\r\n Valid := False;\r\n FOwnHashSet.Extract(AInterface);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnHashSet.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfHashSetIterator.GetObject: IInterface;\r\nvar\r\n ABucket: TJclIntfHashSetBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnHashSet.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n CheckValid;\r\n Result := nil;\r\n ABucket := FOwnHashSet.FBuckets[FBucketIndex - 1];\r\n if (ABucket <> nil) and (FItemIndex < ABucket.Size) then\r\n Result := ABucket.Entries[FItemIndex]\r\n else\r\n if not FOwnHashSet.ReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnHashSet.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfHashSetIterator.HasNext: Boolean;\r\nvar\r\n ABucketIndex, AItemIndex: Integer;\r\n ABucket: TJclIntfHashSetBucket;\r\n SkipCurrent: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnHashSet.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := True;\r\n ABucketIndex := FBucketIndex;\r\n AItemIndex := FItemIndex;\r\n SkipCurrent := Valid;\r\n while ABucketIndex < FOwnHashSet.FCapacity do\r\n begin\r\n ABucket := FOwnHashSet.FBuckets[ABucketIndex];\r\n if ABucket <> nil then\r\n begin\r\n if (AItemIndex < (ABucket.Size - 1)) or\r\n ((not SkipCurrent) and (AItemIndex < ABucket.Size)) then\r\n Exit;\r\n end;\r\n AItemIndex := 0;\r\n Inc(ABucketIndex);\r\n SkipCurrent := False;\r\n end;\r\n Result := False;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnHashSet.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfHashSetIterator.HasPrevious: Boolean;\r\nvar\r\n ABucketIndex, AItemIndex: Integer;\r\n ABucket: TJclIntfHashSetBucket;\r\n SkipCurrent: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnHashSet.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := True;\r\n ABucketIndex := FBucketIndex;\r\n AItemIndex := FItemIndex;\r\n SkipCurrent := Valid;\r\n while ABucketIndex >= 0 do\r\n begin\r\n ABucket := FOwnHashSet.FBuckets[ABucketIndex];\r\n if ABucket <> nil then\r\n begin\r\n if (AItemIndex > 0) or\r\n ((not SkipCurrent) and (AItemIndex >= 0)) then\r\n Exit;\r\n end;\r\n AItemIndex := MaxInt;\r\n Dec(ABucketIndex);\r\n SkipCurrent := False;\r\n end;\r\n Result := False;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnHashSet.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfHashSetIterator.Insert(const AInterface: IInterface): Boolean;\r\nbegin\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nfunction TJclIntfHashSetIterator.IteratorEquals(const AIterator: IJclIntfIterator): Boolean;\r\nvar\r\n Obj: TObject;\r\n ItrObj: TJclIntfHashSetIterator;\r\nbegin\r\n Result := False;\r\n if AIterator = nil then\r\n Exit;\r\n Obj := AIterator.GetIteratorReference;\r\n if Obj is TJclIntfHashSetIterator then\r\n begin\r\n ItrObj := TJclIntfHashSetIterator(Obj);\r\n Result := (FOwnHashSet = ItrObj.FOwnHashSet) and (FBucketIndex = ItrObj.FBucketIndex) and (FItemIndex = ItrObj.FItemIndex) and (Valid = ItrObj.Valid);\r\n end;\r\nend;\r\n\r\n{$IFDEF SUPPORTS_FOR_IN}\r\nfunction TJclIntfHashSetIterator.MoveNext: Boolean;\r\nvar\r\n ABucket: TJclIntfHashSetBucket;\r\n SkipCurrent: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnHashSet.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Valid then\r\n begin\r\n SkipCurrent := True;\r\n while FBucketIndex < FOwnHashSet.FCapacity do\r\n begin\r\n ABucket := FOwnHashSet.FBuckets[FBucketIndex];\r\n if ABucket <> nil then\r\n begin\r\n if (not SkipCurrent) and (FItemIndex < ABucket.Size) then\r\n Break;\r\n if FItemIndex < (ABucket.Size - 1) then\r\n begin\r\n Inc(FItemIndex);\r\n Break;\r\n end;\r\n end;\r\n FItemIndex := 0;\r\n Inc(FBucketIndex);\r\n SkipCurrent := False;\r\n end;\r\n end\r\n else\r\n Valid := True;\r\n\r\n Result := (FBucketIndex >= 0) and (FItemIndex >= 0) and\r\n (FBucketIndex < FOwnHashSet.FCapacity);\r\n if Result then\r\n begin\r\n ABucket := FOwnHashSet.FBuckets[FBucketIndex];\r\n Result := (ABucket <> nil) and (FItemIndex < ABucket.Size);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnHashSet.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n{$ENDIF SUPPORTS_FOR_IN}\r\n\r\nfunction TJclIntfHashSetIterator.Next: IInterface;\r\nvar\r\n ABucket: TJclIntfHashSetBucket;\r\n SkipCurrent: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnHashSet.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Valid then\r\n begin\r\n SkipCurrent := True;\r\n while FBucketIndex < FOwnHashSet.FCapacity do\r\n begin\r\n ABucket := FOwnHashSet.FBuckets[FBucketIndex];\r\n if ABucket <> nil then\r\n begin\r\n if (not SkipCurrent) and (FItemIndex < ABucket.Size) then\r\n Break;\r\n if FItemIndex < (ABucket.Size - 1) then\r\n begin\r\n Inc(FItemIndex);\r\n Break;\r\n end;\r\n end;\r\n FItemIndex := 0;\r\n Inc(FBucketIndex);\r\n SkipCurrent := False;\r\n end;\r\n end\r\n else\r\n Valid := True;\r\n\r\n Result := nil;\r\n if (FBucketIndex >= 0) and (FItemIndex >= 0) and\r\n (FBucketIndex < FOwnHashSet.FCapacity) then\r\n begin\r\n ABucket := FOwnHashSet.FBuckets[FBucketIndex];\r\n if (ABucket <> nil) and\r\n (FItemIndex < ABucket.Size) then\r\n Result := ABucket.Entries[FItemIndex]\r\n else\r\n if not FOwnHashSet.ReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n end\r\n else\r\n if not FOwnHashSet.ReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnHashSet.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfHashSetIterator.NextIndex: Integer;\r\nbegin\r\n // No index\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nfunction TJclIntfHashSetIterator.Previous: IInterface;\r\nvar\r\n ABucket: TJclIntfHashSetBucket;\r\n SkipCurrent: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnHashSet.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Valid then\r\n begin\r\n SkipCurrent := True;\r\n while FBucketIndex >= 0 do\r\n begin\r\n ABucket := FOwnHashSet.FBuckets[FBucketIndex];\r\n if (ABucket <> nil) and (FItemIndex < 0) then\r\n FItemIndex := ABucket.Size - 1;\r\n if ABucket <> nil then\r\n begin\r\n if (not SkipCurrent) and (FItemIndex >= 0) and (FItemIndex < ABucket.Size) then\r\n Break;\r\n if (FItemIndex > 0) and (FItemIndex < ABucket.Size) then\r\n begin\r\n Dec(FItemIndex);\r\n Break;\r\n end;\r\n end;\r\n FItemIndex := -1;\r\n Dec(FBucketIndex);\r\n SkipCurrent := False;\r\n end;\r\n end\r\n else\r\n Valid := True;\r\n\r\n Result := nil;\r\n if (FBucketIndex >= 0) and (FItemIndex >= 0) and\r\n (FBucketIndex < FOwnHashSet.FCapacity) then\r\n begin\r\n ABucket := FOwnHashSet.FBuckets[FBucketIndex];\r\n if (ABucket <> nil) and\r\n (FItemIndex < ABucket.Size) then\r\n Result := ABucket.Entries[FItemIndex]\r\n else\r\n if not FOwnHashSet.ReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n end\r\n else\r\n if not FOwnHashSet.ReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnHashSet.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfHashSetIterator.PreviousIndex: Integer;\r\nbegin\r\n // No index\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nprocedure TJclIntfHashSetIterator.Remove;\r\nbegin\r\n\r\nend;\r\n\r\nprocedure TJclIntfHashSetIterator.Reset;\r\nvar\r\n ABucket: TJclIntfHashSetBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnHashSet.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Valid := False;\r\n case FStart of\r\n isFirst:\r\n begin\r\n FBucketIndex := 0;\r\n ABucket := nil;\r\n while FBucketIndex < FOwnHashSet.FCapacity do\r\n begin\r\n ABucket := FOwnHashSet.FBuckets[FBucketIndex];\r\n if (ABucket <> nil) and (ABucket.Size > 0) then\r\n Break;\r\n Inc(FBucketIndex);\r\n end;\r\n if ABucket <> nil then\r\n FItemIndex := 0\r\n else\r\n FItemIndex := -1;\r\n end;\r\n isLast:\r\n begin\r\n FBucketIndex := FOwnHashSet.FCapacity - 1;\r\n ABucket := nil;\r\n while FBucketIndex >= 0 do\r\n begin\r\n ABucket := FOwnHashSet.FBuckets[FBucketIndex];\r\n if (ABucket <> nil) and (ABucket.Size > 0) then\r\n Break;\r\n Dec(FBucketIndex);\r\n end;\r\n if ABucket <> nil then\r\n FItemIndex := ABucket.Size - 1\r\n else\r\n FItemIndex := -1;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnHashSet.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclIntfHashSetIterator.SetObject(const AInterface: IInterface);\r\nbegin\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n//=== { TJclAnsiStrHashSet } ====================================================\r\n\r\nconstructor TJclAnsiStrHashSet.Create(ACapacity: Integer);\r\nbegin\r\n inherited Create();\r\n SetCapacity(ACapacity);\r\n FHashToRangeFunction := JclSimpleHashToRange;\r\nend;\r\n\r\ndestructor TJclAnsiStrHashSet.Destroy;\r\nbegin\r\n FReadOnly := False;\r\n Clear;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJclAnsiStrHashSet.Add(const AString: AnsiString): Boolean;\r\nvar\r\n Index: Integer;\r\n Bucket: TJclAnsiStrHashSetBucket;\r\n I: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if FAllowDefaultElements or (not ItemsEqual(AString, '')) then\r\n begin\r\n Index := FHashToRangeFunction(Hash(AString), FCapacity);\r\n Bucket := FBuckets[Index];\r\n if Bucket <> nil then\r\n begin\r\n for I := 0 to Bucket.Size - 1 do\r\n if ItemsEqual(Bucket.Entries[I], AString) then\r\n Exit;\r\n end\r\n else\r\n begin\r\n Bucket := TJclAnsiStrHashSetBucket.Create;\r\n SetLength(Bucket.Entries, 1);\r\n FBuckets[Index] := Bucket;\r\n end;\r\n\r\n if Bucket.Size = Length(Bucket.Entries) then\r\n SetLength(Bucket.Entries, CalcGrowCapacity(Bucket.Size, Bucket.Size));\r\n\r\n if Bucket.Size < Length(Bucket.Entries) then\r\n begin\r\n Bucket.Entries[Bucket.Size] := AString;\r\n Inc(Bucket.Size);\r\n Inc(FSize);\r\n Result := True;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclAnsiStrHashSet.AddAll(const ACollection: IJclAnsiStrCollection): Boolean;\r\nvar\r\n It: IJclAnsiStrIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n Result := Add(It.Next) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclAnsiStrHashSet.AssignDataTo(Dest: TJclAbstractContainerBase);\r\nvar\r\n I, J: Integer;\r\n SelfBucket, NewBucket: TJclAnsiStrHashSetBucket;\r\n ADest: TJclAnsiStrHashSet;\r\n ACollection: IJclAnsiStrCollection;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n inherited AssignDataTo(Dest);\r\n if Dest is TJclAnsiStrHashSet then\r\n begin\r\n ADest := TJclAnsiStrHashSet(Dest);\r\n ADest.Clear;\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n SelfBucket := FBuckets[I];\r\n if SelfBucket <> nil then\r\n begin\r\n NewBucket := TJclAnsiStrHashSetBucket.Create;\r\n SetLength(NewBucket.Entries, SelfBucket.Size);\r\n for J := 0 to SelfBucket.Size - 1 do\r\n NewBucket.Entries[J] := SelfBucket.Entries[J];\r\n NewBucket.Size := SelfBucket.Size;\r\n ADest.FBuckets[I] := NewBucket;\r\n end;\r\n end;\r\n end\r\n else\r\n if Supports(IInterface(Dest), IJclAnsiStrCollection, ACollection) then\r\n begin\r\n ACollection.Clear;\r\n ACollection.AddAll(Self);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclAnsiStrHashSet.AssignPropertiesTo(Dest: TJclAbstractContainerBase);\r\nbegin\r\n inherited AssignPropertiesto(Dest);\r\n if Dest is TJclAnsiStrHashSet then\r\n TJclAnsiStrHashSet(Dest).FHashToRangeFunction := FHashToRangeFunction;\r\nend;\r\n\r\nprocedure TJclAnsiStrHashSet.Clear;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclAnsiStrHashSetBucket;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n begin\r\n for J := 0 to Bucket.Size - 1 do\r\n FreeString(Bucket.Entries[J]);\r\n FreeAndNil(FBuckets[I]);\r\n end;\r\n end;\r\n FSize := 0;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclAnsiStrHashSet.CollectionEquals(const ACollection: IJclAnsiStrCollection): Boolean;\r\nvar\r\n I, J: Integer;\r\n It: IJclAnsiStrIterator;\r\n Bucket: TJclAnsiStrHashSetBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n if FSize <> ACollection.Size then\r\n Exit;\r\n It := ACollection.First;\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n for J := 0 to Bucket.Size - 1 do\r\n if not ItemsEqual(Bucket.Entries[J], It.Next) then\r\n Exit;\r\n end;\r\n Result := True;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclAnsiStrHashSet.Contains(const AString: AnsiString): Boolean;\r\nvar\r\n I: Integer;\r\n Bucket: TJclAnsiStrHashSetBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n Bucket := FBuckets[FHashToRangeFunction(Hash(AString), FCapacity)];\r\n if Bucket <> nil then\r\n for I := 0 to Bucket.Size - 1 do\r\n if ItemsEqual(Bucket.Entries[I], AString) then\r\n begin\r\n Result := True;\r\n Break;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclAnsiStrHashSet.ContainsAll(const ACollection: IJclAnsiStrCollection): Boolean;\r\nvar\r\n It: IJclAnsiStrIterator;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := True;\r\n if ACollection = nil then\r\n Exit;\r\n It := ACollection.First;\r\n while Result and It.HasNext do\r\n Result := Contains(It.Next);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclAnsiStrHashSet.Extract(const AString: AnsiString): Boolean;\r\nvar\r\n Bucket: TJclAnsiStrHashSetBucket;\r\n I, NewCapacity: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n Bucket := FBuckets[FHashToRangeFunction(Hash(AString), FCapacity)];\r\n if Bucket <> nil then\r\n begin\r\n for I := 0 to Bucket.Size - 1 do\r\n if ItemsEqual(Bucket.Entries[I], AString) then\r\n begin\r\n Result := True;\r\n Bucket.Entries[I] := '';\r\n if I < Length(Bucket.Entries) - 1 then\r\n MoveArray(Bucket.Entries, I + 1, I, Bucket.Size - I - 1);\r\n Dec(Bucket.Size);\r\n Dec(FSize);\r\n Break;\r\n end;\r\n\r\n NewCapacity := CalcPackCapacity(Length(Bucket.Entries), Bucket.Size);\r\n if NewCapacity < Length(Bucket.Entries) then\r\n SetLength(Bucket.Entries, NewCapacity);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclAnsiStrHashSet.ExtractAll(const ACollection: IJclAnsiStrCollection): Boolean;\r\nvar\r\n It: IJclAnsiStrIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n Result := Extract(It.Next) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclAnsiStrHashSet.First: IJclAnsiStrIterator;\r\nvar\r\n ABucketIndex, AItemIndex: Integer;\r\n ABucket: TJclAnsiStrHashSetBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n ABucketIndex := 0;\r\n ABucket := nil;\r\n while ABucketIndex < FCapacity do\r\n begin\r\n ABucket := FBuckets[ABucketIndex];\r\n if (ABucket <> nil) and (ABucket.Size > 0) then\r\n Break;\r\n Inc(ABucketIndex);\r\n end;\r\n if ABucket <> nil then\r\n AItemIndex := 0\r\n else\r\n AItemIndex := -1;\r\n Result := TJclAnsiStrHashSetIterator.Create(Self, ABucketIndex, AItemIndex, False, isFirst);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\n{$IFDEF SUPPORTS_FOR_IN}\r\nfunction TJclAnsiStrHashSet.GetEnumerator: IJclAnsiStrIterator;\r\nbegin\r\n Result := First;\r\nend;\r\n{$ENDIF SUPPORTS_FOR_IN}\r\n\r\nprocedure TJclAnsiStrHashSet.Intersect(const ACollection: IJclAnsiStrCollection);\r\nbegin\r\n RetainAll(ACollection);\r\nend;\r\n\r\nfunction TJclAnsiStrHashSet.IsEmpty: Boolean;\r\nbegin\r\n Result := FSize = 0;\r\nend;\r\n\r\nfunction TJclAnsiStrHashSet.Last: IJclAnsiStrIterator;\r\nvar\r\n ABucketIndex, AItemIndex: Integer;\r\n ABucket: TJclAnsiStrHashSetBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n ABucketIndex := FCapacity - 1;\r\n ABucket := nil;\r\n while ABucketIndex >= 0 do\r\n begin\r\n ABucket := FBuckets[ABucketIndex];\r\n if (ABucket <> nil) and (ABucket.Size > 0) then\r\n Break;\r\n Dec(ABucketIndex);\r\n end;\r\n if ABucket <> nil then\r\n AItemIndex := ABucket.Size - 1\r\n else\r\n AItemIndex := -1;\r\n Result := TJclAnsiStrHashSetIterator.Create(Self, ABucketIndex, AItemIndex, False, isLast);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclAnsiStrHashSet.Pack;\r\nvar\r\n I: Integer;\r\n Bucket: TJclAnsiStrHashSetBucket;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n begin\r\n if Bucket.Size > 0 then\r\n SetLength(Bucket.Entries, Bucket.Size)\r\n else\r\n FreeAndNil(FBuckets[I]);\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclAnsiStrHashSet.Remove(const AString: AnsiString): Boolean;\r\nvar\r\n Extracted: AnsiString;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := Extract(AString);\r\n if Result then\r\n begin\r\n Extracted := AString;\r\n FreeString(Extracted);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclAnsiStrHashSet.RemoveAll(const ACollection: IJclAnsiStrCollection): Boolean;\r\nvar\r\n It: IJclAnsiStrIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n Result := Remove(It.Next) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclAnsiStrHashSet.RetainAll(const ACollection: IJclAnsiStrCollection): Boolean;\r\nvar\r\n I, J, NewCapacity: Integer;\r\n Bucket: TJclAnsiStrHashSetBucket;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n begin\r\n for J := Bucket.Size - 1 downto 0 do\r\n if not ACollection.Contains(Bucket.Entries[I]) then\r\n begin\r\n Bucket.Entries[J] := FreeString(Bucket.Entries[J]);\r\n if J < Length(Bucket.Entries) - 1 then\r\n MoveArray(Bucket.Entries, J + 1, J, Bucket.Size - J - 1);\r\n Dec(Bucket.Size);\r\n Dec(FSize);\r\n end;\r\n\r\n NewCapacity := CalcPackCapacity(Length(Bucket.Entries), Bucket.Size);\r\n if NewCapacity < Length(Bucket.Entries) then\r\n SetLength(Bucket.Entries, NewCapacity);\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclAnsiStrHashSet.SetCapacity(Value: Integer);\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FSize = 0 then\r\n begin\r\n SetLength(FBuckets, Value);\r\n inherited SetCapacity(Value);\r\n end\r\n else\r\n raise EJclOperationNotSupportedError.Create;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclAnsiStrHashSet.Size: Integer;\r\nbegin\r\n Result := FSize;\r\nend;\r\n\r\nprocedure TJclAnsiStrHashSet.Subtract(const ACollection: IJclAnsiStrCollection);\r\nbegin\r\n RemoveAll(ACollection);\r\nend;\r\n\r\nprocedure TJclAnsiStrHashSet.Union(const ACollection: IJclAnsiStrCollection);\r\nbegin\r\n AddAll(ACollection);\r\nend;\r\n\r\n\r\nfunction TJclAnsiStrHashSet.CreateEmptyContainer: TJclAbstractContainerBase;\r\nbegin\r\n Result := TJclAnsiStrHashSet.Create(Size);\r\n AssignPropertiesTo(Result);\r\nend;\r\n\r\n//=== { TJclAnsiStrHashSetIterator } ============================================\r\n\r\nconstructor TJclAnsiStrHashSetIterator.Create(AOwnHashSet: TJclAnsiStrHashSet;\r\n ABucketIndex, AItemIndex: Integer; AValid: Boolean; AStart: TItrStart);\r\nbegin\r\n inherited Create(AValid);\r\n FOwnHashSet := AOwnHashSet;\r\n FBucketIndex := ABucketIndex;\r\n FItemIndex := AItemIndex;\r\n FStart := AStart;\r\nend;\r\n\r\nfunction TJclAnsiStrHashSetIterator.Add(const AString: AnsiString): Boolean;\r\nbegin\r\n Result := FOwnHashSet.Add(AString);\r\nend;\r\n\r\nprocedure TJclAnsiStrHashSetIterator.AssignPropertiesTo(Dest: TJclAbstractIterator);\r\nvar\r\n ADest: TJclAnsiStrHashSetIterator;\r\nbegin\r\n inherited AssignPropertiesTo(Dest);\r\n if Dest is TJclAnsiStrHashSetIterator then\r\n begin\r\n ADest := TJclAnsiStrHashSetIterator(Dest);\r\n ADest.FBucketIndex := FBucketIndex;\r\n ADest.FItemIndex := FItemIndex;\r\n ADest.FOwnHashSet := FOwnHashSet;\r\n ADest.FStart := FStart;\r\n end;\r\nend;\r\n\r\nfunction TJclAnsiStrHashSetIterator.CreateEmptyIterator: TJclAbstractIterator;\r\nbegin\r\n Result := TJclAnsiStrHashSetIterator.Create(FOwnHashSet, FBucketIndex, FItemIndex, Valid, FStart);\r\nend;\r\n\r\nprocedure TJclAnsiStrHashSetIterator.Extract;\r\nvar\r\n AString: AnsiString;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnHashSet.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n CheckValid;\r\n AString := GetString;\r\n Valid := False;\r\n FOwnHashSet.Extract(AString);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnHashSet.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclAnsiStrHashSetIterator.GetString: AnsiString;\r\nvar\r\n ABucket: TJclAnsiStrHashSetBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnHashSet.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n CheckValid;\r\n Result := '';\r\n ABucket := FOwnHashSet.FBuckets[FBucketIndex - 1];\r\n if (ABucket <> nil) and (FItemIndex < ABucket.Size) then\r\n Result := ABucket.Entries[FItemIndex]\r\n else\r\n if not FOwnHashSet.ReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnHashSet.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclAnsiStrHashSetIterator.HasNext: Boolean;\r\nvar\r\n ABucketIndex, AItemIndex: Integer;\r\n ABucket: TJclAnsiStrHashSetBucket;\r\n SkipCurrent: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnHashSet.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := True;\r\n ABucketIndex := FBucketIndex;\r\n AItemIndex := FItemIndex;\r\n SkipCurrent := Valid;\r\n while ABucketIndex < FOwnHashSet.FCapacity do\r\n begin\r\n ABucket := FOwnHashSet.FBuckets[ABucketIndex];\r\n if ABucket <> nil then\r\n begin\r\n if (AItemIndex < (ABucket.Size - 1)) or\r\n ((not SkipCurrent) and (AItemIndex < ABucket.Size)) then\r\n Exit;\r\n end;\r\n AItemIndex := 0;\r\n Inc(ABucketIndex);\r\n SkipCurrent := False;\r\n end;\r\n Result := False;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnHashSet.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclAnsiStrHashSetIterator.HasPrevious: Boolean;\r\nvar\r\n ABucketIndex, AItemIndex: Integer;\r\n ABucket: TJclAnsiStrHashSetBucket;\r\n SkipCurrent: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnHashSet.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := True;\r\n ABucketIndex := FBucketIndex;\r\n AItemIndex := FItemIndex;\r\n SkipCurrent := Valid;\r\n while ABucketIndex >= 0 do\r\n begin\r\n ABucket := FOwnHashSet.FBuckets[ABucketIndex];\r\n if ABucket <> nil then\r\n begin\r\n if (AItemIndex > 0) or\r\n ((not SkipCurrent) and (AItemIndex >= 0)) then\r\n Exit;\r\n end;\r\n AItemIndex := MaxInt;\r\n Dec(ABucketIndex);\r\n SkipCurrent := False;\r\n end;\r\n Result := False;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnHashSet.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclAnsiStrHashSetIterator.Insert(const AString: AnsiString): Boolean;\r\nbegin\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nfunction TJclAnsiStrHashSetIterator.IteratorEquals(const AIterator: IJclAnsiStrIterator): Boolean;\r\nvar\r\n Obj: TObject;\r\n ItrObj: TJclAnsiStrHashSetIterator;\r\nbegin\r\n Result := False;\r\n if AIterator = nil then\r\n Exit;\r\n Obj := AIterator.GetIteratorReference;\r\n if Obj is TJclAnsiStrHashSetIterator then\r\n begin\r\n ItrObj := TJclAnsiStrHashSetIterator(Obj);\r\n Result := (FOwnHashSet = ItrObj.FOwnHashSet) and (FBucketIndex = ItrObj.FBucketIndex) and (FItemIndex = ItrObj.FItemIndex) and (Valid = ItrObj.Valid);\r\n end;\r\nend;\r\n\r\n{$IFDEF SUPPORTS_FOR_IN}\r\nfunction TJclAnsiStrHashSetIterator.MoveNext: Boolean;\r\nvar\r\n ABucket: TJclAnsiStrHashSetBucket;\r\n SkipCurrent: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnHashSet.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Valid then\r\n begin\r\n SkipCurrent := True;\r\n while FBucketIndex < FOwnHashSet.FCapacity do\r\n begin\r\n ABucket := FOwnHashSet.FBuckets[FBucketIndex];\r\n if ABucket <> nil then\r\n begin\r\n if (not SkipCurrent) and (FItemIndex < ABucket.Size) then\r\n Break;\r\n if FItemIndex < (ABucket.Size - 1) then\r\n begin\r\n Inc(FItemIndex);\r\n Break;\r\n end;\r\n end;\r\n FItemIndex := 0;\r\n Inc(FBucketIndex);\r\n SkipCurrent := False;\r\n end;\r\n end\r\n else\r\n Valid := True;\r\n\r\n Result := (FBucketIndex >= 0) and (FItemIndex >= 0) and\r\n (FBucketIndex < FOwnHashSet.FCapacity);\r\n if Result then\r\n begin\r\n ABucket := FOwnHashSet.FBuckets[FBucketIndex];\r\n Result := (ABucket <> nil) and (FItemIndex < ABucket.Size);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnHashSet.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n{$ENDIF SUPPORTS_FOR_IN}\r\n\r\nfunction TJclAnsiStrHashSetIterator.Next: AnsiString;\r\nvar\r\n ABucket: TJclAnsiStrHashSetBucket;\r\n SkipCurrent: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnHashSet.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Valid then\r\n begin\r\n SkipCurrent := True;\r\n while FBucketIndex < FOwnHashSet.FCapacity do\r\n begin\r\n ABucket := FOwnHashSet.FBuckets[FBucketIndex];\r\n if ABucket <> nil then\r\n begin\r\n if (not SkipCurrent) and (FItemIndex < ABucket.Size) then\r\n Break;\r\n if FItemIndex < (ABucket.Size - 1) then\r\n begin\r\n Inc(FItemIndex);\r\n Break;\r\n end;\r\n end;\r\n FItemIndex := 0;\r\n Inc(FBucketIndex);\r\n SkipCurrent := False;\r\n end;\r\n end\r\n else\r\n Valid := True;\r\n\r\n Result := '';\r\n if (FBucketIndex >= 0) and (FItemIndex >= 0) and\r\n (FBucketIndex < FOwnHashSet.FCapacity) then\r\n begin\r\n ABucket := FOwnHashSet.FBuckets[FBucketIndex];\r\n if (ABucket <> nil) and\r\n (FItemIndex < ABucket.Size) then\r\n Result := ABucket.Entries[FItemIndex]\r\n else\r\n if not FOwnHashSet.ReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n end\r\n else\r\n if not FOwnHashSet.ReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnHashSet.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclAnsiStrHashSetIterator.NextIndex: Integer;\r\nbegin\r\n // No index\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nfunction TJclAnsiStrHashSetIterator.Previous: AnsiString;\r\nvar\r\n ABucket: TJclAnsiStrHashSetBucket;\r\n SkipCurrent: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnHashSet.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Valid then\r\n begin\r\n SkipCurrent := True;\r\n while FBucketIndex >= 0 do\r\n begin\r\n ABucket := FOwnHashSet.FBuckets[FBucketIndex];\r\n if (ABucket <> nil) and (FItemIndex < 0) then\r\n FItemIndex := ABucket.Size - 1;\r\n if ABucket <> nil then\r\n begin\r\n if (not SkipCurrent) and (FItemIndex >= 0) and (FItemIndex < ABucket.Size) then\r\n Break;\r\n if (FItemIndex > 0) and (FItemIndex < ABucket.Size) then\r\n begin\r\n Dec(FItemIndex);\r\n Break;\r\n end;\r\n end;\r\n FItemIndex := -1;\r\n Dec(FBucketIndex);\r\n SkipCurrent := False;\r\n end;\r\n end\r\n else\r\n Valid := True;\r\n\r\n Result := '';\r\n if (FBucketIndex >= 0) and (FItemIndex >= 0) and\r\n (FBucketIndex < FOwnHashSet.FCapacity) then\r\n begin\r\n ABucket := FOwnHashSet.FBuckets[FBucketIndex];\r\n if (ABucket <> nil) and\r\n (FItemIndex < ABucket.Size) then\r\n Result := ABucket.Entries[FItemIndex]\r\n else\r\n if not FOwnHashSet.ReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n end\r\n else\r\n if not FOwnHashSet.ReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnHashSet.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclAnsiStrHashSetIterator.PreviousIndex: Integer;\r\nbegin\r\n // No index\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nprocedure TJclAnsiStrHashSetIterator.Remove;\r\nbegin\r\n\r\nend;\r\n\r\nprocedure TJclAnsiStrHashSetIterator.Reset;\r\nvar\r\n ABucket: TJclAnsiStrHashSetBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnHashSet.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Valid := False;\r\n case FStart of\r\n isFirst:\r\n begin\r\n FBucketIndex := 0;\r\n ABucket := nil;\r\n while FBucketIndex < FOwnHashSet.FCapacity do\r\n begin\r\n ABucket := FOwnHashSet.FBuckets[FBucketIndex];\r\n if (ABucket <> nil) and (ABucket.Size > 0) then\r\n Break;\r\n Inc(FBucketIndex);\r\n end;\r\n if ABucket <> nil then\r\n FItemIndex := 0\r\n else\r\n FItemIndex := -1;\r\n end;\r\n isLast:\r\n begin\r\n FBucketIndex := FOwnHashSet.FCapacity - 1;\r\n ABucket := nil;\r\n while FBucketIndex >= 0 do\r\n begin\r\n ABucket := FOwnHashSet.FBuckets[FBucketIndex];\r\n if (ABucket <> nil) and (ABucket.Size > 0) then\r\n Break;\r\n Dec(FBucketIndex);\r\n end;\r\n if ABucket <> nil then\r\n FItemIndex := ABucket.Size - 1\r\n else\r\n FItemIndex := -1;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnHashSet.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclAnsiStrHashSetIterator.SetString(const AString: AnsiString);\r\nbegin\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n//=== { TJclWideStrHashSet } ====================================================\r\n\r\nconstructor TJclWideStrHashSet.Create(ACapacity: Integer);\r\nbegin\r\n inherited Create();\r\n SetCapacity(ACapacity);\r\n FHashToRangeFunction := JclSimpleHashToRange;\r\nend;\r\n\r\ndestructor TJclWideStrHashSet.Destroy;\r\nbegin\r\n FReadOnly := False;\r\n Clear;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJclWideStrHashSet.Add(const AString: WideString): Boolean;\r\nvar\r\n Index: Integer;\r\n Bucket: TJclWideStrHashSetBucket;\r\n I: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if FAllowDefaultElements or (not ItemsEqual(AString, '')) then\r\n begin\r\n Index := FHashToRangeFunction(Hash(AString), FCapacity);\r\n Bucket := FBuckets[Index];\r\n if Bucket <> nil then\r\n begin\r\n for I := 0 to Bucket.Size - 1 do\r\n if ItemsEqual(Bucket.Entries[I], AString) then\r\n Exit;\r\n end\r\n else\r\n begin\r\n Bucket := TJclWideStrHashSetBucket.Create;\r\n SetLength(Bucket.Entries, 1);\r\n FBuckets[Index] := Bucket;\r\n end;\r\n\r\n if Bucket.Size = Length(Bucket.Entries) then\r\n SetLength(Bucket.Entries, CalcGrowCapacity(Bucket.Size, Bucket.Size));\r\n\r\n if Bucket.Size < Length(Bucket.Entries) then\r\n begin\r\n Bucket.Entries[Bucket.Size] := AString;\r\n Inc(Bucket.Size);\r\n Inc(FSize);\r\n Result := True;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclWideStrHashSet.AddAll(const ACollection: IJclWideStrCollection): Boolean;\r\nvar\r\n It: IJclWideStrIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n Result := Add(It.Next) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclWideStrHashSet.AssignDataTo(Dest: TJclAbstractContainerBase);\r\nvar\r\n I, J: Integer;\r\n SelfBucket, NewBucket: TJclWideStrHashSetBucket;\r\n ADest: TJclWideStrHashSet;\r\n ACollection: IJclWideStrCollection;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n inherited AssignDataTo(Dest);\r\n if Dest is TJclWideStrHashSet then\r\n begin\r\n ADest := TJclWideStrHashSet(Dest);\r\n ADest.Clear;\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n SelfBucket := FBuckets[I];\r\n if SelfBucket <> nil then\r\n begin\r\n NewBucket := TJclWideStrHashSetBucket.Create;\r\n SetLength(NewBucket.Entries, SelfBucket.Size);\r\n for J := 0 to SelfBucket.Size - 1 do\r\n NewBucket.Entries[J] := SelfBucket.Entries[J];\r\n NewBucket.Size := SelfBucket.Size;\r\n ADest.FBuckets[I] := NewBucket;\r\n end;\r\n end;\r\n end\r\n else\r\n if Supports(IInterface(Dest), IJclWideStrCollection, ACollection) then\r\n begin\r\n ACollection.Clear;\r\n ACollection.AddAll(Self);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclWideStrHashSet.AssignPropertiesTo(Dest: TJclAbstractContainerBase);\r\nbegin\r\n inherited AssignPropertiesto(Dest);\r\n if Dest is TJclWideStrHashSet then\r\n TJclWideStrHashSet(Dest).FHashToRangeFunction := FHashToRangeFunction;\r\nend;\r\n\r\nprocedure TJclWideStrHashSet.Clear;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclWideStrHashSetBucket;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n begin\r\n for J := 0 to Bucket.Size - 1 do\r\n FreeString(Bucket.Entries[J]);\r\n FreeAndNil(FBuckets[I]);\r\n end;\r\n end;\r\n FSize := 0;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclWideStrHashSet.CollectionEquals(const ACollection: IJclWideStrCollection): Boolean;\r\nvar\r\n I, J: Integer;\r\n It: IJclWideStrIterator;\r\n Bucket: TJclWideStrHashSetBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n if FSize <> ACollection.Size then\r\n Exit;\r\n It := ACollection.First;\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n for J := 0 to Bucket.Size - 1 do\r\n if not ItemsEqual(Bucket.Entries[J], It.Next) then\r\n Exit;\r\n end;\r\n Result := True;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclWideStrHashSet.Contains(const AString: WideString): Boolean;\r\nvar\r\n I: Integer;\r\n Bucket: TJclWideStrHashSetBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n Bucket := FBuckets[FHashToRangeFunction(Hash(AString), FCapacity)];\r\n if Bucket <> nil then\r\n for I := 0 to Bucket.Size - 1 do\r\n if ItemsEqual(Bucket.Entries[I], AString) then\r\n begin\r\n Result := True;\r\n Break;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclWideStrHashSet.ContainsAll(const ACollection: IJclWideStrCollection): Boolean;\r\nvar\r\n It: IJclWideStrIterator;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := True;\r\n if ACollection = nil then\r\n Exit;\r\n It := ACollection.First;\r\n while Result and It.HasNext do\r\n Result := Contains(It.Next);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclWideStrHashSet.Extract(const AString: WideString): Boolean;\r\nvar\r\n Bucket: TJclWideStrHashSetBucket;\r\n I, NewCapacity: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n Bucket := FBuckets[FHashToRangeFunction(Hash(AString), FCapacity)];\r\n if Bucket <> nil then\r\n begin\r\n for I := 0 to Bucket.Size - 1 do\r\n if ItemsEqual(Bucket.Entries[I], AString) then\r\n begin\r\n Result := True;\r\n Bucket.Entries[I] := '';\r\n if I < Length(Bucket.Entries) - 1 then\r\n MoveArray(Bucket.Entries, I + 1, I, Bucket.Size - I - 1);\r\n Dec(Bucket.Size);\r\n Dec(FSize);\r\n Break;\r\n end;\r\n\r\n NewCapacity := CalcPackCapacity(Length(Bucket.Entries), Bucket.Size);\r\n if NewCapacity < Length(Bucket.Entries) then\r\n SetLength(Bucket.Entries, NewCapacity);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclWideStrHashSet.ExtractAll(const ACollection: IJclWideStrCollection): Boolean;\r\nvar\r\n It: IJclWideStrIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n Result := Extract(It.Next) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclWideStrHashSet.First: IJclWideStrIterator;\r\nvar\r\n ABucketIndex, AItemIndex: Integer;\r\n ABucket: TJclWideStrHashSetBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n ABucketIndex := 0;\r\n ABucket := nil;\r\n while ABucketIndex < FCapacity do\r\n begin\r\n ABucket := FBuckets[ABucketIndex];\r\n if (ABucket <> nil) and (ABucket.Size > 0) then\r\n Break;\r\n Inc(ABucketIndex);\r\n end;\r\n if ABucket <> nil then\r\n AItemIndex := 0\r\n else\r\n AItemIndex := -1;\r\n Result := TJclWideStrHashSetIterator.Create(Self, ABucketIndex, AItemIndex, False, isFirst);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\n{$IFDEF SUPPORTS_FOR_IN}\r\nfunction TJclWideStrHashSet.GetEnumerator: IJclWideStrIterator;\r\nbegin\r\n Result := First;\r\nend;\r\n{$ENDIF SUPPORTS_FOR_IN}\r\n\r\nprocedure TJclWideStrHashSet.Intersect(const ACollection: IJclWideStrCollection);\r\nbegin\r\n RetainAll(ACollection);\r\nend;\r\n\r\nfunction TJclWideStrHashSet.IsEmpty: Boolean;\r\nbegin\r\n Result := FSize = 0;\r\nend;\r\n\r\nfunction TJclWideStrHashSet.Last: IJclWideStrIterator;\r\nvar\r\n ABucketIndex, AItemIndex: Integer;\r\n ABucket: TJclWideStrHashSetBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n ABucketIndex := FCapacity - 1;\r\n ABucket := nil;\r\n while ABucketIndex >= 0 do\r\n begin\r\n ABucket := FBuckets[ABucketIndex];\r\n if (ABucket <> nil) and (ABucket.Size > 0) then\r\n Break;\r\n Dec(ABucketIndex);\r\n end;\r\n if ABucket <> nil then\r\n AItemIndex := ABucket.Size - 1\r\n else\r\n AItemIndex := -1;\r\n Result := TJclWideStrHashSetIterator.Create(Self, ABucketIndex, AItemIndex, False, isLast);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclWideStrHashSet.Pack;\r\nvar\r\n I: Integer;\r\n Bucket: TJclWideStrHashSetBucket;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n begin\r\n if Bucket.Size > 0 then\r\n SetLength(Bucket.Entries, Bucket.Size)\r\n else\r\n FreeAndNil(FBuckets[I]);\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclWideStrHashSet.Remove(const AString: WideString): Boolean;\r\nvar\r\n Extracted: WideString;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := Extract(AString);\r\n if Result then\r\n begin\r\n Extracted := AString;\r\n FreeString(Extracted);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclWideStrHashSet.RemoveAll(const ACollection: IJclWideStrCollection): Boolean;\r\nvar\r\n It: IJclWideStrIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n Result := Remove(It.Next) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclWideStrHashSet.RetainAll(const ACollection: IJclWideStrCollection): Boolean;\r\nvar\r\n I, J, NewCapacity: Integer;\r\n Bucket: TJclWideStrHashSetBucket;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n begin\r\n for J := Bucket.Size - 1 downto 0 do\r\n if not ACollection.Contains(Bucket.Entries[I]) then\r\n begin\r\n Bucket.Entries[J] := FreeString(Bucket.Entries[J]);\r\n if J < Length(Bucket.Entries) - 1 then\r\n MoveArray(Bucket.Entries, J + 1, J, Bucket.Size - J - 1);\r\n Dec(Bucket.Size);\r\n Dec(FSize);\r\n end;\r\n\r\n NewCapacity := CalcPackCapacity(Length(Bucket.Entries), Bucket.Size);\r\n if NewCapacity < Length(Bucket.Entries) then\r\n SetLength(Bucket.Entries, NewCapacity);\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclWideStrHashSet.SetCapacity(Value: Integer);\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FSize = 0 then\r\n begin\r\n SetLength(FBuckets, Value);\r\n inherited SetCapacity(Value);\r\n end\r\n else\r\n raise EJclOperationNotSupportedError.Create;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclWideStrHashSet.Size: Integer;\r\nbegin\r\n Result := FSize;\r\nend;\r\n\r\nprocedure TJclWideStrHashSet.Subtract(const ACollection: IJclWideStrCollection);\r\nbegin\r\n RemoveAll(ACollection);\r\nend;\r\n\r\nprocedure TJclWideStrHashSet.Union(const ACollection: IJclWideStrCollection);\r\nbegin\r\n AddAll(ACollection);\r\nend;\r\n\r\n\r\nfunction TJclWideStrHashSet.CreateEmptyContainer: TJclAbstractContainerBase;\r\nbegin\r\n Result := TJclWideStrHashSet.Create(Size);\r\n AssignPropertiesTo(Result);\r\nend;\r\n\r\n//=== { TJclWideStrHashSetIterator } ============================================\r\n\r\nconstructor TJclWideStrHashSetIterator.Create(AOwnHashSet: TJclWideStrHashSet;\r\n ABucketIndex, AItemIndex: Integer; AValid: Boolean; AStart: TItrStart);\r\nbegin\r\n inherited Create(AValid);\r\n FOwnHashSet := AOwnHashSet;\r\n FBucketIndex := ABucketIndex;\r\n FItemIndex := AItemIndex;\r\n FStart := AStart;\r\nend;\r\n\r\nfunction TJclWideStrHashSetIterator.Add(const AString: WideString): Boolean;\r\nbegin\r\n Result := FOwnHashSet.Add(AString);\r\nend;\r\n\r\nprocedure TJclWideStrHashSetIterator.AssignPropertiesTo(Dest: TJclAbstractIterator);\r\nvar\r\n ADest: TJclWideStrHashSetIterator;\r\nbegin\r\n inherited AssignPropertiesTo(Dest);\r\n if Dest is TJclWideStrHashSetIterator then\r\n begin\r\n ADest := TJclWideStrHashSetIterator(Dest);\r\n ADest.FBucketIndex := FBucketIndex;\r\n ADest.FItemIndex := FItemIndex;\r\n ADest.FOwnHashSet := FOwnHashSet;\r\n ADest.FStart := FStart;\r\n end;\r\nend;\r\n\r\nfunction TJclWideStrHashSetIterator.CreateEmptyIterator: TJclAbstractIterator;\r\nbegin\r\n Result := TJclWideStrHashSetIterator.Create(FOwnHashSet, FBucketIndex, FItemIndex, Valid, FStart);\r\nend;\r\n\r\nprocedure TJclWideStrHashSetIterator.Extract;\r\nvar\r\n AString: WideString;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnHashSet.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n CheckValid;\r\n AString := GetString;\r\n Valid := False;\r\n FOwnHashSet.Extract(AString);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnHashSet.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclWideStrHashSetIterator.GetString: WideString;\r\nvar\r\n ABucket: TJclWideStrHashSetBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnHashSet.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n CheckValid;\r\n Result := '';\r\n ABucket := FOwnHashSet.FBuckets[FBucketIndex - 1];\r\n if (ABucket <> nil) and (FItemIndex < ABucket.Size) then\r\n Result := ABucket.Entries[FItemIndex]\r\n else\r\n if not FOwnHashSet.ReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnHashSet.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclWideStrHashSetIterator.HasNext: Boolean;\r\nvar\r\n ABucketIndex, AItemIndex: Integer;\r\n ABucket: TJclWideStrHashSetBucket;\r\n SkipCurrent: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnHashSet.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := True;\r\n ABucketIndex := FBucketIndex;\r\n AItemIndex := FItemIndex;\r\n SkipCurrent := Valid;\r\n while ABucketIndex < FOwnHashSet.FCapacity do\r\n begin\r\n ABucket := FOwnHashSet.FBuckets[ABucketIndex];\r\n if ABucket <> nil then\r\n begin\r\n if (AItemIndex < (ABucket.Size - 1)) or\r\n ((not SkipCurrent) and (AItemIndex < ABucket.Size)) then\r\n Exit;\r\n end;\r\n AItemIndex := 0;\r\n Inc(ABucketIndex);\r\n SkipCurrent := False;\r\n end;\r\n Result := False;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnHashSet.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclWideStrHashSetIterator.HasPrevious: Boolean;\r\nvar\r\n ABucketIndex, AItemIndex: Integer;\r\n ABucket: TJclWideStrHashSetBucket;\r\n SkipCurrent: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnHashSet.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := True;\r\n ABucketIndex := FBucketIndex;\r\n AItemIndex := FItemIndex;\r\n SkipCurrent := Valid;\r\n while ABucketIndex >= 0 do\r\n begin\r\n ABucket := FOwnHashSet.FBuckets[ABucketIndex];\r\n if ABucket <> nil then\r\n begin\r\n if (AItemIndex > 0) or\r\n ((not SkipCurrent) and (AItemIndex >= 0)) then\r\n Exit;\r\n end;\r\n AItemIndex := MaxInt;\r\n Dec(ABucketIndex);\r\n SkipCurrent := False;\r\n end;\r\n Result := False;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnHashSet.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclWideStrHashSetIterator.Insert(const AString: WideString): Boolean;\r\nbegin\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nfunction TJclWideStrHashSetIterator.IteratorEquals(const AIterator: IJclWideStrIterator): Boolean;\r\nvar\r\n Obj: TObject;\r\n ItrObj: TJclWideStrHashSetIterator;\r\nbegin\r\n Result := False;\r\n if AIterator = nil then\r\n Exit;\r\n Obj := AIterator.GetIteratorReference;\r\n if Obj is TJclWideStrHashSetIterator then\r\n begin\r\n ItrObj := TJclWideStrHashSetIterator(Obj);\r\n Result := (FOwnHashSet = ItrObj.FOwnHashSet) and (FBucketIndex = ItrObj.FBucketIndex) and (FItemIndex = ItrObj.FItemIndex) and (Valid = ItrObj.Valid);\r\n end;\r\nend;\r\n\r\n{$IFDEF SUPPORTS_FOR_IN}\r\nfunction TJclWideStrHashSetIterator.MoveNext: Boolean;\r\nvar\r\n ABucket: TJclWideStrHashSetBucket;\r\n SkipCurrent: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnHashSet.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Valid then\r\n begin\r\n SkipCurrent := True;\r\n while FBucketIndex < FOwnHashSet.FCapacity do\r\n begin\r\n ABucket := FOwnHashSet.FBuckets[FBucketIndex];\r\n if ABucket <> nil then\r\n begin\r\n if (not SkipCurrent) and (FItemIndex < ABucket.Size) then\r\n Break;\r\n if FItemIndex < (ABucket.Size - 1) then\r\n begin\r\n Inc(FItemIndex);\r\n Break;\r\n end;\r\n end;\r\n FItemIndex := 0;\r\n Inc(FBucketIndex);\r\n SkipCurrent := False;\r\n end;\r\n end\r\n else\r\n Valid := True;\r\n\r\n Result := (FBucketIndex >= 0) and (FItemIndex >= 0) and\r\n (FBucketIndex < FOwnHashSet.FCapacity);\r\n if Result then\r\n begin\r\n ABucket := FOwnHashSet.FBuckets[FBucketIndex];\r\n Result := (ABucket <> nil) and (FItemIndex < ABucket.Size);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnHashSet.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n{$ENDIF SUPPORTS_FOR_IN}\r\n\r\nfunction TJclWideStrHashSetIterator.Next: WideString;\r\nvar\r\n ABucket: TJclWideStrHashSetBucket;\r\n SkipCurrent: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnHashSet.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Valid then\r\n begin\r\n SkipCurrent := True;\r\n while FBucketIndex < FOwnHashSet.FCapacity do\r\n begin\r\n ABucket := FOwnHashSet.FBuckets[FBucketIndex];\r\n if ABucket <> nil then\r\n begin\r\n if (not SkipCurrent) and (FItemIndex < ABucket.Size) then\r\n Break;\r\n if FItemIndex < (ABucket.Size - 1) then\r\n begin\r\n Inc(FItemIndex);\r\n Break;\r\n end;\r\n end;\r\n FItemIndex := 0;\r\n Inc(FBucketIndex);\r\n SkipCurrent := False;\r\n end;\r\n end\r\n else\r\n Valid := True;\r\n\r\n Result := '';\r\n if (FBucketIndex >= 0) and (FItemIndex >= 0) and\r\n (FBucketIndex < FOwnHashSet.FCapacity) then\r\n begin\r\n ABucket := FOwnHashSet.FBuckets[FBucketIndex];\r\n if (ABucket <> nil) and\r\n (FItemIndex < ABucket.Size) then\r\n Result := ABucket.Entries[FItemIndex]\r\n else\r\n if not FOwnHashSet.ReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n end\r\n else\r\n if not FOwnHashSet.ReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnHashSet.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclWideStrHashSetIterator.NextIndex: Integer;\r\nbegin\r\n // No index\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nfunction TJclWideStrHashSetIterator.Previous: WideString;\r\nvar\r\n ABucket: TJclWideStrHashSetBucket;\r\n SkipCurrent: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnHashSet.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Valid then\r\n begin\r\n SkipCurrent := True;\r\n while FBucketIndex >= 0 do\r\n begin\r\n ABucket := FOwnHashSet.FBuckets[FBucketIndex];\r\n if (ABucket <> nil) and (FItemIndex < 0) then\r\n FItemIndex := ABucket.Size - 1;\r\n if ABucket <> nil then\r\n begin\r\n if (not SkipCurrent) and (FItemIndex >= 0) and (FItemIndex < ABucket.Size) then\r\n Break;\r\n if (FItemIndex > 0) and (FItemIndex < ABucket.Size) then\r\n begin\r\n Dec(FItemIndex);\r\n Break;\r\n end;\r\n end;\r\n FItemIndex := -1;\r\n Dec(FBucketIndex);\r\n SkipCurrent := False;\r\n end;\r\n end\r\n else\r\n Valid := True;\r\n\r\n Result := '';\r\n if (FBucketIndex >= 0) and (FItemIndex >= 0) and\r\n (FBucketIndex < FOwnHashSet.FCapacity) then\r\n begin\r\n ABucket := FOwnHashSet.FBuckets[FBucketIndex];\r\n if (ABucket <> nil) and\r\n (FItemIndex < ABucket.Size) then\r\n Result := ABucket.Entries[FItemIndex]\r\n else\r\n if not FOwnHashSet.ReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n end\r\n else\r\n if not FOwnHashSet.ReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnHashSet.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclWideStrHashSetIterator.PreviousIndex: Integer;\r\nbegin\r\n // No index\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nprocedure TJclWideStrHashSetIterator.Remove;\r\nbegin\r\n\r\nend;\r\n\r\nprocedure TJclWideStrHashSetIterator.Reset;\r\nvar\r\n ABucket: TJclWideStrHashSetBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnHashSet.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Valid := False;\r\n case FStart of\r\n isFirst:\r\n begin\r\n FBucketIndex := 0;\r\n ABucket := nil;\r\n while FBucketIndex < FOwnHashSet.FCapacity do\r\n begin\r\n ABucket := FOwnHashSet.FBuckets[FBucketIndex];\r\n if (ABucket <> nil) and (ABucket.Size > 0) then\r\n Break;\r\n Inc(FBucketIndex);\r\n end;\r\n if ABucket <> nil then\r\n FItemIndex := 0\r\n else\r\n FItemIndex := -1;\r\n end;\r\n isLast:\r\n begin\r\n FBucketIndex := FOwnHashSet.FCapacity - 1;\r\n ABucket := nil;\r\n while FBucketIndex >= 0 do\r\n begin\r\n ABucket := FOwnHashSet.FBuckets[FBucketIndex];\r\n if (ABucket <> nil) and (ABucket.Size > 0) then\r\n Break;\r\n Dec(FBucketIndex);\r\n end;\r\n if ABucket <> nil then\r\n FItemIndex := ABucket.Size - 1\r\n else\r\n FItemIndex := -1;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnHashSet.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclWideStrHashSetIterator.SetString(const AString: WideString);\r\nbegin\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n{$IFDEF SUPPORTS_UNICODE_STRING}\r\n//=== { TJclUnicodeStrHashSet } ====================================================\r\n\r\nconstructor TJclUnicodeStrHashSet.Create(ACapacity: Integer);\r\nbegin\r\n inherited Create();\r\n SetCapacity(ACapacity);\r\n FHashToRangeFunction := JclSimpleHashToRange;\r\nend;\r\n\r\ndestructor TJclUnicodeStrHashSet.Destroy;\r\nbegin\r\n FReadOnly := False;\r\n Clear;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJclUnicodeStrHashSet.Add(const AString: UnicodeString): Boolean;\r\nvar\r\n Index: Integer;\r\n Bucket: TJclUnicodeStrHashSetBucket;\r\n I: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if FAllowDefaultElements or (not ItemsEqual(AString, '')) then\r\n begin\r\n Index := FHashToRangeFunction(Hash(AString), FCapacity);\r\n Bucket := FBuckets[Index];\r\n if Bucket <> nil then\r\n begin\r\n for I := 0 to Bucket.Size - 1 do\r\n if ItemsEqual(Bucket.Entries[I], AString) then\r\n Exit;\r\n end\r\n else\r\n begin\r\n Bucket := TJclUnicodeStrHashSetBucket.Create;\r\n SetLength(Bucket.Entries, 1);\r\n FBuckets[Index] := Bucket;\r\n end;\r\n\r\n if Bucket.Size = Length(Bucket.Entries) then\r\n SetLength(Bucket.Entries, CalcGrowCapacity(Bucket.Size, Bucket.Size));\r\n\r\n if Bucket.Size < Length(Bucket.Entries) then\r\n begin\r\n Bucket.Entries[Bucket.Size] := AString;\r\n Inc(Bucket.Size);\r\n Inc(FSize);\r\n Result := True;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclUnicodeStrHashSet.AddAll(const ACollection: IJclUnicodeStrCollection): Boolean;\r\nvar\r\n It: IJclUnicodeStrIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n Result := Add(It.Next) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclUnicodeStrHashSet.AssignDataTo(Dest: TJclAbstractContainerBase);\r\nvar\r\n I, J: Integer;\r\n SelfBucket, NewBucket: TJclUnicodeStrHashSetBucket;\r\n ADest: TJclUnicodeStrHashSet;\r\n ACollection: IJclUnicodeStrCollection;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n inherited AssignDataTo(Dest);\r\n if Dest is TJclUnicodeStrHashSet then\r\n begin\r\n ADest := TJclUnicodeStrHashSet(Dest);\r\n ADest.Clear;\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n SelfBucket := FBuckets[I];\r\n if SelfBucket <> nil then\r\n begin\r\n NewBucket := TJclUnicodeStrHashSetBucket.Create;\r\n SetLength(NewBucket.Entries, SelfBucket.Size);\r\n for J := 0 to SelfBucket.Size - 1 do\r\n NewBucket.Entries[J] := SelfBucket.Entries[J];\r\n NewBucket.Size := SelfBucket.Size;\r\n ADest.FBuckets[I] := NewBucket;\r\n end;\r\n end;\r\n end\r\n else\r\n if Supports(IInterface(Dest), IJclUnicodeStrCollection, ACollection) then\r\n begin\r\n ACollection.Clear;\r\n ACollection.AddAll(Self);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclUnicodeStrHashSet.AssignPropertiesTo(Dest: TJclAbstractContainerBase);\r\nbegin\r\n inherited AssignPropertiesto(Dest);\r\n if Dest is TJclUnicodeStrHashSet then\r\n TJclUnicodeStrHashSet(Dest).FHashToRangeFunction := FHashToRangeFunction;\r\nend;\r\n\r\nprocedure TJclUnicodeStrHashSet.Clear;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclUnicodeStrHashSetBucket;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n begin\r\n for J := 0 to Bucket.Size - 1 do\r\n FreeString(Bucket.Entries[J]);\r\n FreeAndNil(FBuckets[I]);\r\n end;\r\n end;\r\n FSize := 0;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclUnicodeStrHashSet.CollectionEquals(const ACollection: IJclUnicodeStrCollection): Boolean;\r\nvar\r\n I, J: Integer;\r\n It: IJclUnicodeStrIterator;\r\n Bucket: TJclUnicodeStrHashSetBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n if FSize <> ACollection.Size then\r\n Exit;\r\n It := ACollection.First;\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n for J := 0 to Bucket.Size - 1 do\r\n if not ItemsEqual(Bucket.Entries[J], It.Next) then\r\n Exit;\r\n end;\r\n Result := True;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclUnicodeStrHashSet.Contains(const AString: UnicodeString): Boolean;\r\nvar\r\n I: Integer;\r\n Bucket: TJclUnicodeStrHashSetBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n Bucket := FBuckets[FHashToRangeFunction(Hash(AString), FCapacity)];\r\n if Bucket <> nil then\r\n for I := 0 to Bucket.Size - 1 do\r\n if ItemsEqual(Bucket.Entries[I], AString) then\r\n begin\r\n Result := True;\r\n Break;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclUnicodeStrHashSet.ContainsAll(const ACollection: IJclUnicodeStrCollection): Boolean;\r\nvar\r\n It: IJclUnicodeStrIterator;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := True;\r\n if ACollection = nil then\r\n Exit;\r\n It := ACollection.First;\r\n while Result and It.HasNext do\r\n Result := Contains(It.Next);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclUnicodeStrHashSet.Extract(const AString: UnicodeString): Boolean;\r\nvar\r\n Bucket: TJclUnicodeStrHashSetBucket;\r\n I, NewCapacity: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n Bucket := FBuckets[FHashToRangeFunction(Hash(AString), FCapacity)];\r\n if Bucket <> nil then\r\n begin\r\n for I := 0 to Bucket.Size - 1 do\r\n if ItemsEqual(Bucket.Entries[I], AString) then\r\n begin\r\n Result := True;\r\n Bucket.Entries[I] := '';\r\n if I < Length(Bucket.Entries) - 1 then\r\n MoveArray(Bucket.Entries, I + 1, I, Bucket.Size - I - 1);\r\n Dec(Bucket.Size);\r\n Dec(FSize);\r\n Break;\r\n end;\r\n\r\n NewCapacity := CalcPackCapacity(Length(Bucket.Entries), Bucket.Size);\r\n if NewCapacity < Length(Bucket.Entries) then\r\n SetLength(Bucket.Entries, NewCapacity);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclUnicodeStrHashSet.ExtractAll(const ACollection: IJclUnicodeStrCollection): Boolean;\r\nvar\r\n It: IJclUnicodeStrIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n Result := Extract(It.Next) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclUnicodeStrHashSet.First: IJclUnicodeStrIterator;\r\nvar\r\n ABucketIndex, AItemIndex: Integer;\r\n ABucket: TJclUnicodeStrHashSetBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n ABucketIndex := 0;\r\n ABucket := nil;\r\n while ABucketIndex < FCapacity do\r\n begin\r\n ABucket := FBuckets[ABucketIndex];\r\n if (ABucket <> nil) and (ABucket.Size > 0) then\r\n Break;\r\n Inc(ABucketIndex);\r\n end;\r\n if ABucket <> nil then\r\n AItemIndex := 0\r\n else\r\n AItemIndex := -1;\r\n Result := TJclUnicodeStrHashSetIterator.Create(Self, ABucketIndex, AItemIndex, False, isFirst);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\n{$IFDEF SUPPORTS_FOR_IN}\r\nfunction TJclUnicodeStrHashSet.GetEnumerator: IJclUnicodeStrIterator;\r\nbegin\r\n Result := First;\r\nend;\r\n{$ENDIF SUPPORTS_FOR_IN}\r\n\r\nprocedure TJclUnicodeStrHashSet.Intersect(const ACollection: IJclUnicodeStrCollection);\r\nbegin\r\n RetainAll(ACollection);\r\nend;\r\n\r\nfunction TJclUnicodeStrHashSet.IsEmpty: Boolean;\r\nbegin\r\n Result := FSize = 0;\r\nend;\r\n\r\nfunction TJclUnicodeStrHashSet.Last: IJclUnicodeStrIterator;\r\nvar\r\n ABucketIndex, AItemIndex: Integer;\r\n ABucket: TJclUnicodeStrHashSetBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n ABucketIndex := FCapacity - 1;\r\n ABucket := nil;\r\n while ABucketIndex >= 0 do\r\n begin\r\n ABucket := FBuckets[ABucketIndex];\r\n if (ABucket <> nil) and (ABucket.Size > 0) then\r\n Break;\r\n Dec(ABucketIndex);\r\n end;\r\n if ABucket <> nil then\r\n AItemIndex := ABucket.Size - 1\r\n else\r\n AItemIndex := -1;\r\n Result := TJclUnicodeStrHashSetIterator.Create(Self, ABucketIndex, AItemIndex, False, isLast);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclUnicodeStrHashSet.Pack;\r\nvar\r\n I: Integer;\r\n Bucket: TJclUnicodeStrHashSetBucket;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n begin\r\n if Bucket.Size > 0 then\r\n SetLength(Bucket.Entries, Bucket.Size)\r\n else\r\n FreeAndNil(FBuckets[I]);\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclUnicodeStrHashSet.Remove(const AString: UnicodeString): Boolean;\r\nvar\r\n Extracted: UnicodeString;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := Extract(AString);\r\n if Result then\r\n begin\r\n Extracted := AString;\r\n FreeString(Extracted);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclUnicodeStrHashSet.RemoveAll(const ACollection: IJclUnicodeStrCollection): Boolean;\r\nvar\r\n It: IJclUnicodeStrIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n Result := Remove(It.Next) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclUnicodeStrHashSet.RetainAll(const ACollection: IJclUnicodeStrCollection): Boolean;\r\nvar\r\n I, J, NewCapacity: Integer;\r\n Bucket: TJclUnicodeStrHashSetBucket;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n begin\r\n for J := Bucket.Size - 1 downto 0 do\r\n if not ACollection.Contains(Bucket.Entries[I]) then\r\n begin\r\n Bucket.Entries[J] := FreeString(Bucket.Entries[J]);\r\n if J < Length(Bucket.Entries) - 1 then\r\n MoveArray(Bucket.Entries, J + 1, J, Bucket.Size - J - 1);\r\n Dec(Bucket.Size);\r\n Dec(FSize);\r\n end;\r\n\r\n NewCapacity := CalcPackCapacity(Length(Bucket.Entries), Bucket.Size);\r\n if NewCapacity < Length(Bucket.Entries) then\r\n SetLength(Bucket.Entries, NewCapacity);\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclUnicodeStrHashSet.SetCapacity(Value: Integer);\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FSize = 0 then\r\n begin\r\n SetLength(FBuckets, Value);\r\n inherited SetCapacity(Value);\r\n end\r\n else\r\n raise EJclOperationNotSupportedError.Create;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclUnicodeStrHashSet.Size: Integer;\r\nbegin\r\n Result := FSize;\r\nend;\r\n\r\nprocedure TJclUnicodeStrHashSet.Subtract(const ACollection: IJclUnicodeStrCollection);\r\nbegin\r\n RemoveAll(ACollection);\r\nend;\r\n\r\nprocedure TJclUnicodeStrHashSet.Union(const ACollection: IJclUnicodeStrCollection);\r\nbegin\r\n AddAll(ACollection);\r\nend;\r\n\r\n\r\nfunction TJclUnicodeStrHashSet.CreateEmptyContainer: TJclAbstractContainerBase;\r\nbegin\r\n Result := TJclUnicodeStrHashSet.Create(Size);\r\n AssignPropertiesTo(Result);\r\nend;\r\n\r\n{$ENDIF SUPPORTS_UNICODE_STRING}\r\n\r\n{$IFDEF SUPPORTS_UNICODE_STRING}\r\n//=== { TJclUnicodeStrHashSetIterator } ============================================\r\n\r\nconstructor TJclUnicodeStrHashSetIterator.Create(AOwnHashSet: TJclUnicodeStrHashSet;\r\n ABucketIndex, AItemIndex: Integer; AValid: Boolean; AStart: TItrStart);\r\nbegin\r\n inherited Create(AValid);\r\n FOwnHashSet := AOwnHashSet;\r\n FBucketIndex := ABucketIndex;\r\n FItemIndex := AItemIndex;\r\n FStart := AStart;\r\nend;\r\n\r\nfunction TJclUnicodeStrHashSetIterator.Add(const AString: UnicodeString): Boolean;\r\nbegin\r\n Result := FOwnHashSet.Add(AString);\r\nend;\r\n\r\nprocedure TJclUnicodeStrHashSetIterator.AssignPropertiesTo(Dest: TJclAbstractIterator);\r\nvar\r\n ADest: TJclUnicodeStrHashSetIterator;\r\nbegin\r\n inherited AssignPropertiesTo(Dest);\r\n if Dest is TJclUnicodeStrHashSetIterator then\r\n begin\r\n ADest := TJclUnicodeStrHashSetIterator(Dest);\r\n ADest.FBucketIndex := FBucketIndex;\r\n ADest.FItemIndex := FItemIndex;\r\n ADest.FOwnHashSet := FOwnHashSet;\r\n ADest.FStart := FStart;\r\n end;\r\nend;\r\n\r\nfunction TJclUnicodeStrHashSetIterator.CreateEmptyIterator: TJclAbstractIterator;\r\nbegin\r\n Result := TJclUnicodeStrHashSetIterator.Create(FOwnHashSet, FBucketIndex, FItemIndex, Valid, FStart);\r\nend;\r\n\r\nprocedure TJclUnicodeStrHashSetIterator.Extract;\r\nvar\r\n AString: UnicodeString;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnHashSet.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n CheckValid;\r\n AString := GetString;\r\n Valid := False;\r\n FOwnHashSet.Extract(AString);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnHashSet.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclUnicodeStrHashSetIterator.GetString: UnicodeString;\r\nvar\r\n ABucket: TJclUnicodeStrHashSetBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnHashSet.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n CheckValid;\r\n Result := '';\r\n ABucket := FOwnHashSet.FBuckets[FBucketIndex - 1];\r\n if (ABucket <> nil) and (FItemIndex < ABucket.Size) then\r\n Result := ABucket.Entries[FItemIndex]\r\n else\r\n if not FOwnHashSet.ReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnHashSet.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclUnicodeStrHashSetIterator.HasNext: Boolean;\r\nvar\r\n ABucketIndex, AItemIndex: Integer;\r\n ABucket: TJclUnicodeStrHashSetBucket;\r\n SkipCurrent: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnHashSet.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := True;\r\n ABucketIndex := FBucketIndex;\r\n AItemIndex := FItemIndex;\r\n SkipCurrent := Valid;\r\n while ABucketIndex < FOwnHashSet.FCapacity do\r\n begin\r\n ABucket := FOwnHashSet.FBuckets[ABucketIndex];\r\n if ABucket <> nil then\r\n begin\r\n if (AItemIndex < (ABucket.Size - 1)) or\r\n ((not SkipCurrent) and (AItemIndex < ABucket.Size)) then\r\n Exit;\r\n end;\r\n AItemIndex := 0;\r\n Inc(ABucketIndex);\r\n SkipCurrent := False;\r\n end;\r\n Result := False;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnHashSet.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclUnicodeStrHashSetIterator.HasPrevious: Boolean;\r\nvar\r\n ABucketIndex, AItemIndex: Integer;\r\n ABucket: TJclUnicodeStrHashSetBucket;\r\n SkipCurrent: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnHashSet.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := True;\r\n ABucketIndex := FBucketIndex;\r\n AItemIndex := FItemIndex;\r\n SkipCurrent := Valid;\r\n while ABucketIndex >= 0 do\r\n begin\r\n ABucket := FOwnHashSet.FBuckets[ABucketIndex];\r\n if ABucket <> nil then\r\n begin\r\n if (AItemIndex > 0) or\r\n ((not SkipCurrent) and (AItemIndex >= 0)) then\r\n Exit;\r\n end;\r\n AItemIndex := MaxInt;\r\n Dec(ABucketIndex);\r\n SkipCurrent := False;\r\n end;\r\n Result := False;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnHashSet.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclUnicodeStrHashSetIterator.Insert(const AString: UnicodeString): Boolean;\r\nbegin\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nfunction TJclUnicodeStrHashSetIterator.IteratorEquals(const AIterator: IJclUnicodeStrIterator): Boolean;\r\nvar\r\n Obj: TObject;\r\n ItrObj: TJclUnicodeStrHashSetIterator;\r\nbegin\r\n Result := False;\r\n if AIterator = nil then\r\n Exit;\r\n Obj := AIterator.GetIteratorReference;\r\n if Obj is TJclUnicodeStrHashSetIterator then\r\n begin\r\n ItrObj := TJclUnicodeStrHashSetIterator(Obj);\r\n Result := (FOwnHashSet = ItrObj.FOwnHashSet) and (FBucketIndex = ItrObj.FBucketIndex) and (FItemIndex = ItrObj.FItemIndex) and (Valid = ItrObj.Valid);\r\n end;\r\nend;\r\n\r\n{$IFDEF SUPPORTS_FOR_IN}\r\nfunction TJclUnicodeStrHashSetIterator.MoveNext: Boolean;\r\nvar\r\n ABucket: TJclUnicodeStrHashSetBucket;\r\n SkipCurrent: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnHashSet.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Valid then\r\n begin\r\n SkipCurrent := True;\r\n while FBucketIndex < FOwnHashSet.FCapacity do\r\n begin\r\n ABucket := FOwnHashSet.FBuckets[FBucketIndex];\r\n if ABucket <> nil then\r\n begin\r\n if (not SkipCurrent) and (FItemIndex < ABucket.Size) then\r\n Break;\r\n if FItemIndex < (ABucket.Size - 1) then\r\n begin\r\n Inc(FItemIndex);\r\n Break;\r\n end;\r\n end;\r\n FItemIndex := 0;\r\n Inc(FBucketIndex);\r\n SkipCurrent := False;\r\n end;\r\n end\r\n else\r\n Valid := True;\r\n\r\n Result := (FBucketIndex >= 0) and (FItemIndex >= 0) and\r\n (FBucketIndex < FOwnHashSet.FCapacity);\r\n if Result then\r\n begin\r\n ABucket := FOwnHashSet.FBuckets[FBucketIndex];\r\n Result := (ABucket <> nil) and (FItemIndex < ABucket.Size);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnHashSet.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n{$ENDIF SUPPORTS_FOR_IN}\r\n\r\nfunction TJclUnicodeStrHashSetIterator.Next: UnicodeString;\r\nvar\r\n ABucket: TJclUnicodeStrHashSetBucket;\r\n SkipCurrent: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnHashSet.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Valid then\r\n begin\r\n SkipCurrent := True;\r\n while FBucketIndex < FOwnHashSet.FCapacity do\r\n begin\r\n ABucket := FOwnHashSet.FBuckets[FBucketIndex];\r\n if ABucket <> nil then\r\n begin\r\n if (not SkipCurrent) and (FItemIndex < ABucket.Size) then\r\n Break;\r\n if FItemIndex < (ABucket.Size - 1) then\r\n begin\r\n Inc(FItemIndex);\r\n Break;\r\n end;\r\n end;\r\n FItemIndex := 0;\r\n Inc(FBucketIndex);\r\n SkipCurrent := False;\r\n end;\r\n end\r\n else\r\n Valid := True;\r\n\r\n Result := '';\r\n if (FBucketIndex >= 0) and (FItemIndex >= 0) and\r\n (FBucketIndex < FOwnHashSet.FCapacity) then\r\n begin\r\n ABucket := FOwnHashSet.FBuckets[FBucketIndex];\r\n if (ABucket <> nil) and\r\n (FItemIndex < ABucket.Size) then\r\n Result := ABucket.Entries[FItemIndex]\r\n else\r\n if not FOwnHashSet.ReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n end\r\n else\r\n if not FOwnHashSet.ReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnHashSet.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclUnicodeStrHashSetIterator.NextIndex: Integer;\r\nbegin\r\n // No index\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nfunction TJclUnicodeStrHashSetIterator.Previous: UnicodeString;\r\nvar\r\n ABucket: TJclUnicodeStrHashSetBucket;\r\n SkipCurrent: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnHashSet.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Valid then\r\n begin\r\n SkipCurrent := True;\r\n while FBucketIndex >= 0 do\r\n begin\r\n ABucket := FOwnHashSet.FBuckets[FBucketIndex];\r\n if (ABucket <> nil) and (FItemIndex < 0) then\r\n FItemIndex := ABucket.Size - 1;\r\n if ABucket <> nil then\r\n begin\r\n if (not SkipCurrent) and (FItemIndex >= 0) and (FItemIndex < ABucket.Size) then\r\n Break;\r\n if (FItemIndex > 0) and (FItemIndex < ABucket.Size) then\r\n begin\r\n Dec(FItemIndex);\r\n Break;\r\n end;\r\n end;\r\n FItemIndex := -1;\r\n Dec(FBucketIndex);\r\n SkipCurrent := False;\r\n end;\r\n end\r\n else\r\n Valid := True;\r\n\r\n Result := '';\r\n if (FBucketIndex >= 0) and (FItemIndex >= 0) and\r\n (FBucketIndex < FOwnHashSet.FCapacity) then\r\n begin\r\n ABucket := FOwnHashSet.FBuckets[FBucketIndex];\r\n if (ABucket <> nil) and\r\n (FItemIndex < ABucket.Size) then\r\n Result := ABucket.Entries[FItemIndex]\r\n else\r\n if not FOwnHashSet.ReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n end\r\n else\r\n if not FOwnHashSet.ReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnHashSet.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclUnicodeStrHashSetIterator.PreviousIndex: Integer;\r\nbegin\r\n // No index\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nprocedure TJclUnicodeStrHashSetIterator.Remove;\r\nbegin\r\n\r\nend;\r\n\r\nprocedure TJclUnicodeStrHashSetIterator.Reset;\r\nvar\r\n ABucket: TJclUnicodeStrHashSetBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnHashSet.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Valid := False;\r\n case FStart of\r\n isFirst:\r\n begin\r\n FBucketIndex := 0;\r\n ABucket := nil;\r\n while FBucketIndex < FOwnHashSet.FCapacity do\r\n begin\r\n ABucket := FOwnHashSet.FBuckets[FBucketIndex];\r\n if (ABucket <> nil) and (ABucket.Size > 0) then\r\n Break;\r\n Inc(FBucketIndex);\r\n end;\r\n if ABucket <> nil then\r\n FItemIndex := 0\r\n else\r\n FItemIndex := -1;\r\n end;\r\n isLast:\r\n begin\r\n FBucketIndex := FOwnHashSet.FCapacity - 1;\r\n ABucket := nil;\r\n while FBucketIndex >= 0 do\r\n begin\r\n ABucket := FOwnHashSet.FBuckets[FBucketIndex];\r\n if (ABucket <> nil) and (ABucket.Size > 0) then\r\n Break;\r\n Dec(FBucketIndex);\r\n end;\r\n if ABucket <> nil then\r\n FItemIndex := ABucket.Size - 1\r\n else\r\n FItemIndex := -1;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnHashSet.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclUnicodeStrHashSetIterator.SetString(const AString: UnicodeString);\r\nbegin\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\n{$ENDIF SUPPORTS_UNICODE_STRING}\r\n//=== { TJclSingleHashSet } ====================================================\r\n\r\nconstructor TJclSingleHashSet.Create(ACapacity: Integer);\r\nbegin\r\n inherited Create();\r\n SetCapacity(ACapacity);\r\n FHashToRangeFunction := JclSimpleHashToRange;\r\nend;\r\n\r\ndestructor TJclSingleHashSet.Destroy;\r\nbegin\r\n FReadOnly := False;\r\n Clear;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJclSingleHashSet.Add(const AValue: Single): Boolean;\r\nvar\r\n Index: Integer;\r\n Bucket: TJclSingleHashSetBucket;\r\n I: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if FAllowDefaultElements or (not ItemsEqual(AValue, 0.0)) then\r\n begin\r\n Index := FHashToRangeFunction(Hash(AValue), FCapacity);\r\n Bucket := FBuckets[Index];\r\n if Bucket <> nil then\r\n begin\r\n for I := 0 to Bucket.Size - 1 do\r\n if ItemsEqual(Bucket.Entries[I], AValue) then\r\n Exit;\r\n end\r\n else\r\n begin\r\n Bucket := TJclSingleHashSetBucket.Create;\r\n SetLength(Bucket.Entries, 1);\r\n FBuckets[Index] := Bucket;\r\n end;\r\n\r\n if Bucket.Size = Length(Bucket.Entries) then\r\n SetLength(Bucket.Entries, CalcGrowCapacity(Bucket.Size, Bucket.Size));\r\n\r\n if Bucket.Size < Length(Bucket.Entries) then\r\n begin\r\n Bucket.Entries[Bucket.Size] := AValue;\r\n Inc(Bucket.Size);\r\n Inc(FSize);\r\n Result := True;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSingleHashSet.AddAll(const ACollection: IJclSingleCollection): Boolean;\r\nvar\r\n It: IJclSingleIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n Result := Add(It.Next) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclSingleHashSet.AssignDataTo(Dest: TJclAbstractContainerBase);\r\nvar\r\n I, J: Integer;\r\n SelfBucket, NewBucket: TJclSingleHashSetBucket;\r\n ADest: TJclSingleHashSet;\r\n ACollection: IJclSingleCollection;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n inherited AssignDataTo(Dest);\r\n if Dest is TJclSingleHashSet then\r\n begin\r\n ADest := TJclSingleHashSet(Dest);\r\n ADest.Clear;\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n SelfBucket := FBuckets[I];\r\n if SelfBucket <> nil then\r\n begin\r\n NewBucket := TJclSingleHashSetBucket.Create;\r\n SetLength(NewBucket.Entries, SelfBucket.Size);\r\n for J := 0 to SelfBucket.Size - 1 do\r\n NewBucket.Entries[J] := SelfBucket.Entries[J];\r\n NewBucket.Size := SelfBucket.Size;\r\n ADest.FBuckets[I] := NewBucket;\r\n end;\r\n end;\r\n end\r\n else\r\n if Supports(IInterface(Dest), IJclSingleCollection, ACollection) then\r\n begin\r\n ACollection.Clear;\r\n ACollection.AddAll(Self);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclSingleHashSet.AssignPropertiesTo(Dest: TJclAbstractContainerBase);\r\nbegin\r\n inherited AssignPropertiesto(Dest);\r\n if Dest is TJclSingleHashSet then\r\n TJclSingleHashSet(Dest).FHashToRangeFunction := FHashToRangeFunction;\r\nend;\r\n\r\nprocedure TJclSingleHashSet.Clear;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclSingleHashSetBucket;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n begin\r\n for J := 0 to Bucket.Size - 1 do\r\n FreeSingle(Bucket.Entries[J]);\r\n FreeAndNil(FBuckets[I]);\r\n end;\r\n end;\r\n FSize := 0;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSingleHashSet.CollectionEquals(const ACollection: IJclSingleCollection): Boolean;\r\nvar\r\n I, J: Integer;\r\n It: IJclSingleIterator;\r\n Bucket: TJclSingleHashSetBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n if FSize <> ACollection.Size then\r\n Exit;\r\n It := ACollection.First;\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n for J := 0 to Bucket.Size - 1 do\r\n if not ItemsEqual(Bucket.Entries[J], It.Next) then\r\n Exit;\r\n end;\r\n Result := True;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSingleHashSet.Contains(const AValue: Single): Boolean;\r\nvar\r\n I: Integer;\r\n Bucket: TJclSingleHashSetBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n Bucket := FBuckets[FHashToRangeFunction(Hash(AValue), FCapacity)];\r\n if Bucket <> nil then\r\n for I := 0 to Bucket.Size - 1 do\r\n if ItemsEqual(Bucket.Entries[I], AValue) then\r\n begin\r\n Result := True;\r\n Break;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSingleHashSet.ContainsAll(const ACollection: IJclSingleCollection): Boolean;\r\nvar\r\n It: IJclSingleIterator;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := True;\r\n if ACollection = nil then\r\n Exit;\r\n It := ACollection.First;\r\n while Result and It.HasNext do\r\n Result := Contains(It.Next);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSingleHashSet.Extract(const AValue: Single): Boolean;\r\nvar\r\n Bucket: TJclSingleHashSetBucket;\r\n I, NewCapacity: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n Bucket := FBuckets[FHashToRangeFunction(Hash(AValue), FCapacity)];\r\n if Bucket <> nil then\r\n begin\r\n for I := 0 to Bucket.Size - 1 do\r\n if ItemsEqual(Bucket.Entries[I], AValue) then\r\n begin\r\n Result := True;\r\n Bucket.Entries[I] := 0.0;\r\n if I < Length(Bucket.Entries) - 1 then\r\n MoveArray(Bucket.Entries, I + 1, I, Bucket.Size - I - 1);\r\n Dec(Bucket.Size);\r\n Dec(FSize);\r\n Break;\r\n end;\r\n\r\n NewCapacity := CalcPackCapacity(Length(Bucket.Entries), Bucket.Size);\r\n if NewCapacity < Length(Bucket.Entries) then\r\n SetLength(Bucket.Entries, NewCapacity);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSingleHashSet.ExtractAll(const ACollection: IJclSingleCollection): Boolean;\r\nvar\r\n It: IJclSingleIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n Result := Extract(It.Next) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSingleHashSet.First: IJclSingleIterator;\r\nvar\r\n ABucketIndex, AItemIndex: Integer;\r\n ABucket: TJclSingleHashSetBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n ABucketIndex := 0;\r\n ABucket := nil;\r\n while ABucketIndex < FCapacity do\r\n begin\r\n ABucket := FBuckets[ABucketIndex];\r\n if (ABucket <> nil) and (ABucket.Size > 0) then\r\n Break;\r\n Inc(ABucketIndex);\r\n end;\r\n if ABucket <> nil then\r\n AItemIndex := 0\r\n else\r\n AItemIndex := -1;\r\n Result := TJclSingleHashSetIterator.Create(Self, ABucketIndex, AItemIndex, False, isFirst);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\n{$IFDEF SUPPORTS_FOR_IN}\r\nfunction TJclSingleHashSet.GetEnumerator: IJclSingleIterator;\r\nbegin\r\n Result := First;\r\nend;\r\n{$ENDIF SUPPORTS_FOR_IN}\r\n\r\nprocedure TJclSingleHashSet.Intersect(const ACollection: IJclSingleCollection);\r\nbegin\r\n RetainAll(ACollection);\r\nend;\r\n\r\nfunction TJclSingleHashSet.IsEmpty: Boolean;\r\nbegin\r\n Result := FSize = 0;\r\nend;\r\n\r\nfunction TJclSingleHashSet.Last: IJclSingleIterator;\r\nvar\r\n ABucketIndex, AItemIndex: Integer;\r\n ABucket: TJclSingleHashSetBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n ABucketIndex := FCapacity - 1;\r\n ABucket := nil;\r\n while ABucketIndex >= 0 do\r\n begin\r\n ABucket := FBuckets[ABucketIndex];\r\n if (ABucket <> nil) and (ABucket.Size > 0) then\r\n Break;\r\n Dec(ABucketIndex);\r\n end;\r\n if ABucket <> nil then\r\n AItemIndex := ABucket.Size - 1\r\n else\r\n AItemIndex := -1;\r\n Result := TJclSingleHashSetIterator.Create(Self, ABucketIndex, AItemIndex, False, isLast);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclSingleHashSet.Pack;\r\nvar\r\n I: Integer;\r\n Bucket: TJclSingleHashSetBucket;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n begin\r\n if Bucket.Size > 0 then\r\n SetLength(Bucket.Entries, Bucket.Size)\r\n else\r\n FreeAndNil(FBuckets[I]);\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSingleHashSet.Remove(const AValue: Single): Boolean;\r\nvar\r\n Extracted: Single;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := Extract(AValue);\r\n if Result then\r\n begin\r\n Extracted := AValue;\r\n FreeSingle(Extracted);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSingleHashSet.RemoveAll(const ACollection: IJclSingleCollection): Boolean;\r\nvar\r\n It: IJclSingleIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n Result := Remove(It.Next) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSingleHashSet.RetainAll(const ACollection: IJclSingleCollection): Boolean;\r\nvar\r\n I, J, NewCapacity: Integer;\r\n Bucket: TJclSingleHashSetBucket;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n begin\r\n for J := Bucket.Size - 1 downto 0 do\r\n if not ACollection.Contains(Bucket.Entries[I]) then\r\n begin\r\n Bucket.Entries[J] := FreeSingle(Bucket.Entries[J]);\r\n if J < Length(Bucket.Entries) - 1 then\r\n MoveArray(Bucket.Entries, J + 1, J, Bucket.Size - J - 1);\r\n Dec(Bucket.Size);\r\n Dec(FSize);\r\n end;\r\n\r\n NewCapacity := CalcPackCapacity(Length(Bucket.Entries), Bucket.Size);\r\n if NewCapacity < Length(Bucket.Entries) then\r\n SetLength(Bucket.Entries, NewCapacity);\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclSingleHashSet.SetCapacity(Value: Integer);\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FSize = 0 then\r\n begin\r\n SetLength(FBuckets, Value);\r\n inherited SetCapacity(Value);\r\n end\r\n else\r\n raise EJclOperationNotSupportedError.Create;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSingleHashSet.Size: Integer;\r\nbegin\r\n Result := FSize;\r\nend;\r\n\r\nprocedure TJclSingleHashSet.Subtract(const ACollection: IJclSingleCollection);\r\nbegin\r\n RemoveAll(ACollection);\r\nend;\r\n\r\nprocedure TJclSingleHashSet.Union(const ACollection: IJclSingleCollection);\r\nbegin\r\n AddAll(ACollection);\r\nend;\r\n\r\n\r\nfunction TJclSingleHashSet.CreateEmptyContainer: TJclAbstractContainerBase;\r\nbegin\r\n Result := TJclSingleHashSet.Create(Size);\r\n AssignPropertiesTo(Result);\r\nend;\r\n\r\n//=== { TJclSingleHashSetIterator } ============================================\r\n\r\nconstructor TJclSingleHashSetIterator.Create(AOwnHashSet: TJclSingleHashSet;\r\n ABucketIndex, AItemIndex: Integer; AValid: Boolean; AStart: TItrStart);\r\nbegin\r\n inherited Create(AValid);\r\n FOwnHashSet := AOwnHashSet;\r\n FBucketIndex := ABucketIndex;\r\n FItemIndex := AItemIndex;\r\n FStart := AStart;\r\nend;\r\n\r\nfunction TJclSingleHashSetIterator.Add(const AValue: Single): Boolean;\r\nbegin\r\n Result := FOwnHashSet.Add(AValue);\r\nend;\r\n\r\nprocedure TJclSingleHashSetIterator.AssignPropertiesTo(Dest: TJclAbstractIterator);\r\nvar\r\n ADest: TJclSingleHashSetIterator;\r\nbegin\r\n inherited AssignPropertiesTo(Dest);\r\n if Dest is TJclSingleHashSetIterator then\r\n begin\r\n ADest := TJclSingleHashSetIterator(Dest);\r\n ADest.FBucketIndex := FBucketIndex;\r\n ADest.FItemIndex := FItemIndex;\r\n ADest.FOwnHashSet := FOwnHashSet;\r\n ADest.FStart := FStart;\r\n end;\r\nend;\r\n\r\nfunction TJclSingleHashSetIterator.CreateEmptyIterator: TJclAbstractIterator;\r\nbegin\r\n Result := TJclSingleHashSetIterator.Create(FOwnHashSet, FBucketIndex, FItemIndex, Valid, FStart);\r\nend;\r\n\r\nprocedure TJclSingleHashSetIterator.Extract;\r\nvar\r\n AValue: Single;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnHashSet.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n CheckValid;\r\n AValue := GetValue;\r\n Valid := False;\r\n FOwnHashSet.Extract(AValue);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnHashSet.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSingleHashSetIterator.GetValue: Single;\r\nvar\r\n ABucket: TJclSingleHashSetBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnHashSet.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n CheckValid;\r\n Result := 0.0;\r\n ABucket := FOwnHashSet.FBuckets[FBucketIndex - 1];\r\n if (ABucket <> nil) and (FItemIndex < ABucket.Size) then\r\n Result := ABucket.Entries[FItemIndex]\r\n else\r\n if not FOwnHashSet.ReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnHashSet.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSingleHashSetIterator.HasNext: Boolean;\r\nvar\r\n ABucketIndex, AItemIndex: Integer;\r\n ABucket: TJclSingleHashSetBucket;\r\n SkipCurrent: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnHashSet.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := True;\r\n ABucketIndex := FBucketIndex;\r\n AItemIndex := FItemIndex;\r\n SkipCurrent := Valid;\r\n while ABucketIndex < FOwnHashSet.FCapacity do\r\n begin\r\n ABucket := FOwnHashSet.FBuckets[ABucketIndex];\r\n if ABucket <> nil then\r\n begin\r\n if (AItemIndex < (ABucket.Size - 1)) or\r\n ((not SkipCurrent) and (AItemIndex < ABucket.Size)) then\r\n Exit;\r\n end;\r\n AItemIndex := 0;\r\n Inc(ABucketIndex);\r\n SkipCurrent := False;\r\n end;\r\n Result := False;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnHashSet.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSingleHashSetIterator.HasPrevious: Boolean;\r\nvar\r\n ABucketIndex, AItemIndex: Integer;\r\n ABucket: TJclSingleHashSetBucket;\r\n SkipCurrent: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnHashSet.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := True;\r\n ABucketIndex := FBucketIndex;\r\n AItemIndex := FItemIndex;\r\n SkipCurrent := Valid;\r\n while ABucketIndex >= 0 do\r\n begin\r\n ABucket := FOwnHashSet.FBuckets[ABucketIndex];\r\n if ABucket <> nil then\r\n begin\r\n if (AItemIndex > 0) or\r\n ((not SkipCurrent) and (AItemIndex >= 0)) then\r\n Exit;\r\n end;\r\n AItemIndex := MaxInt;\r\n Dec(ABucketIndex);\r\n SkipCurrent := False;\r\n end;\r\n Result := False;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnHashSet.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSingleHashSetIterator.Insert(const AValue: Single): Boolean;\r\nbegin\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nfunction TJclSingleHashSetIterator.IteratorEquals(const AIterator: IJclSingleIterator): Boolean;\r\nvar\r\n Obj: TObject;\r\n ItrObj: TJclSingleHashSetIterator;\r\nbegin\r\n Result := False;\r\n if AIterator = nil then\r\n Exit;\r\n Obj := AIterator.GetIteratorReference;\r\n if Obj is TJclSingleHashSetIterator then\r\n begin\r\n ItrObj := TJclSingleHashSetIterator(Obj);\r\n Result := (FOwnHashSet = ItrObj.FOwnHashSet) and (FBucketIndex = ItrObj.FBucketIndex) and (FItemIndex = ItrObj.FItemIndex) and (Valid = ItrObj.Valid);\r\n end;\r\nend;\r\n\r\n{$IFDEF SUPPORTS_FOR_IN}\r\nfunction TJclSingleHashSetIterator.MoveNext: Boolean;\r\nvar\r\n ABucket: TJclSingleHashSetBucket;\r\n SkipCurrent: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnHashSet.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Valid then\r\n begin\r\n SkipCurrent := True;\r\n while FBucketIndex < FOwnHashSet.FCapacity do\r\n begin\r\n ABucket := FOwnHashSet.FBuckets[FBucketIndex];\r\n if ABucket <> nil then\r\n begin\r\n if (not SkipCurrent) and (FItemIndex < ABucket.Size) then\r\n Break;\r\n if FItemIndex < (ABucket.Size - 1) then\r\n begin\r\n Inc(FItemIndex);\r\n Break;\r\n end;\r\n end;\r\n FItemIndex := 0;\r\n Inc(FBucketIndex);\r\n SkipCurrent := False;\r\n end;\r\n end\r\n else\r\n Valid := True;\r\n\r\n Result := (FBucketIndex >= 0) and (FItemIndex >= 0) and\r\n (FBucketIndex < FOwnHashSet.FCapacity);\r\n if Result then\r\n begin\r\n ABucket := FOwnHashSet.FBuckets[FBucketIndex];\r\n Result := (ABucket <> nil) and (FItemIndex < ABucket.Size);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnHashSet.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n{$ENDIF SUPPORTS_FOR_IN}\r\n\r\nfunction TJclSingleHashSetIterator.Next: Single;\r\nvar\r\n ABucket: TJclSingleHashSetBucket;\r\n SkipCurrent: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnHashSet.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Valid then\r\n begin\r\n SkipCurrent := True;\r\n while FBucketIndex < FOwnHashSet.FCapacity do\r\n begin\r\n ABucket := FOwnHashSet.FBuckets[FBucketIndex];\r\n if ABucket <> nil then\r\n begin\r\n if (not SkipCurrent) and (FItemIndex < ABucket.Size) then\r\n Break;\r\n if FItemIndex < (ABucket.Size - 1) then\r\n begin\r\n Inc(FItemIndex);\r\n Break;\r\n end;\r\n end;\r\n FItemIndex := 0;\r\n Inc(FBucketIndex);\r\n SkipCurrent := False;\r\n end;\r\n end\r\n else\r\n Valid := True;\r\n\r\n Result := 0.0;\r\n if (FBucketIndex >= 0) and (FItemIndex >= 0) and\r\n (FBucketIndex < FOwnHashSet.FCapacity) then\r\n begin\r\n ABucket := FOwnHashSet.FBuckets[FBucketIndex];\r\n if (ABucket <> nil) and\r\n (FItemIndex < ABucket.Size) then\r\n Result := ABucket.Entries[FItemIndex]\r\n else\r\n if not FOwnHashSet.ReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n end\r\n else\r\n if not FOwnHashSet.ReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnHashSet.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSingleHashSetIterator.NextIndex: Integer;\r\nbegin\r\n // No index\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nfunction TJclSingleHashSetIterator.Previous: Single;\r\nvar\r\n ABucket: TJclSingleHashSetBucket;\r\n SkipCurrent: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnHashSet.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Valid then\r\n begin\r\n SkipCurrent := True;\r\n while FBucketIndex >= 0 do\r\n begin\r\n ABucket := FOwnHashSet.FBuckets[FBucketIndex];\r\n if (ABucket <> nil) and (FItemIndex < 0) then\r\n FItemIndex := ABucket.Size - 1;\r\n if ABucket <> nil then\r\n begin\r\n if (not SkipCurrent) and (FItemIndex >= 0) and (FItemIndex < ABucket.Size) then\r\n Break;\r\n if (FItemIndex > 0) and (FItemIndex < ABucket.Size) then\r\n begin\r\n Dec(FItemIndex);\r\n Break;\r\n end;\r\n end;\r\n FItemIndex := -1;\r\n Dec(FBucketIndex);\r\n SkipCurrent := False;\r\n end;\r\n end\r\n else\r\n Valid := True;\r\n\r\n Result := 0.0;\r\n if (FBucketIndex >= 0) and (FItemIndex >= 0) and\r\n (FBucketIndex < FOwnHashSet.FCapacity) then\r\n begin\r\n ABucket := FOwnHashSet.FBuckets[FBucketIndex];\r\n if (ABucket <> nil) and\r\n (FItemIndex < ABucket.Size) then\r\n Result := ABucket.Entries[FItemIndex]\r\n else\r\n if not FOwnHashSet.ReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n end\r\n else\r\n if not FOwnHashSet.ReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnHashSet.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSingleHashSetIterator.PreviousIndex: Integer;\r\nbegin\r\n // No index\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nprocedure TJclSingleHashSetIterator.Remove;\r\nbegin\r\n\r\nend;\r\n\r\nprocedure TJclSingleHashSetIterator.Reset;\r\nvar\r\n ABucket: TJclSingleHashSetBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnHashSet.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Valid := False;\r\n case FStart of\r\n isFirst:\r\n begin\r\n FBucketIndex := 0;\r\n ABucket := nil;\r\n while FBucketIndex < FOwnHashSet.FCapacity do\r\n begin\r\n ABucket := FOwnHashSet.FBuckets[FBucketIndex];\r\n if (ABucket <> nil) and (ABucket.Size > 0) then\r\n Break;\r\n Inc(FBucketIndex);\r\n end;\r\n if ABucket <> nil then\r\n FItemIndex := 0\r\n else\r\n FItemIndex := -1;\r\n end;\r\n isLast:\r\n begin\r\n FBucketIndex := FOwnHashSet.FCapacity - 1;\r\n ABucket := nil;\r\n while FBucketIndex >= 0 do\r\n begin\r\n ABucket := FOwnHashSet.FBuckets[FBucketIndex];\r\n if (ABucket <> nil) and (ABucket.Size > 0) then\r\n Break;\r\n Dec(FBucketIndex);\r\n end;\r\n if ABucket <> nil then\r\n FItemIndex := ABucket.Size - 1\r\n else\r\n FItemIndex := -1;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnHashSet.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclSingleHashSetIterator.SetValue(const AValue: Single);\r\nbegin\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n//=== { TJclDoubleHashSet } ====================================================\r\n\r\nconstructor TJclDoubleHashSet.Create(ACapacity: Integer);\r\nbegin\r\n inherited Create();\r\n SetCapacity(ACapacity);\r\n FHashToRangeFunction := JclSimpleHashToRange;\r\nend;\r\n\r\ndestructor TJclDoubleHashSet.Destroy;\r\nbegin\r\n FReadOnly := False;\r\n Clear;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJclDoubleHashSet.Add(const AValue: Double): Boolean;\r\nvar\r\n Index: Integer;\r\n Bucket: TJclDoubleHashSetBucket;\r\n I: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if FAllowDefaultElements or (not ItemsEqual(AValue, 0.0)) then\r\n begin\r\n Index := FHashToRangeFunction(Hash(AValue), FCapacity);\r\n Bucket := FBuckets[Index];\r\n if Bucket <> nil then\r\n begin\r\n for I := 0 to Bucket.Size - 1 do\r\n if ItemsEqual(Bucket.Entries[I], AValue) then\r\n Exit;\r\n end\r\n else\r\n begin\r\n Bucket := TJclDoubleHashSetBucket.Create;\r\n SetLength(Bucket.Entries, 1);\r\n FBuckets[Index] := Bucket;\r\n end;\r\n\r\n if Bucket.Size = Length(Bucket.Entries) then\r\n SetLength(Bucket.Entries, CalcGrowCapacity(Bucket.Size, Bucket.Size));\r\n\r\n if Bucket.Size < Length(Bucket.Entries) then\r\n begin\r\n Bucket.Entries[Bucket.Size] := AValue;\r\n Inc(Bucket.Size);\r\n Inc(FSize);\r\n Result := True;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclDoubleHashSet.AddAll(const ACollection: IJclDoubleCollection): Boolean;\r\nvar\r\n It: IJclDoubleIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n Result := Add(It.Next) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclDoubleHashSet.AssignDataTo(Dest: TJclAbstractContainerBase);\r\nvar\r\n I, J: Integer;\r\n SelfBucket, NewBucket: TJclDoubleHashSetBucket;\r\n ADest: TJclDoubleHashSet;\r\n ACollection: IJclDoubleCollection;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n inherited AssignDataTo(Dest);\r\n if Dest is TJclDoubleHashSet then\r\n begin\r\n ADest := TJclDoubleHashSet(Dest);\r\n ADest.Clear;\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n SelfBucket := FBuckets[I];\r\n if SelfBucket <> nil then\r\n begin\r\n NewBucket := TJclDoubleHashSetBucket.Create;\r\n SetLength(NewBucket.Entries, SelfBucket.Size);\r\n for J := 0 to SelfBucket.Size - 1 do\r\n NewBucket.Entries[J] := SelfBucket.Entries[J];\r\n NewBucket.Size := SelfBucket.Size;\r\n ADest.FBuckets[I] := NewBucket;\r\n end;\r\n end;\r\n end\r\n else\r\n if Supports(IInterface(Dest), IJclDoubleCollection, ACollection) then\r\n begin\r\n ACollection.Clear;\r\n ACollection.AddAll(Self);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclDoubleHashSet.AssignPropertiesTo(Dest: TJclAbstractContainerBase);\r\nbegin\r\n inherited AssignPropertiesto(Dest);\r\n if Dest is TJclDoubleHashSet then\r\n TJclDoubleHashSet(Dest).FHashToRangeFunction := FHashToRangeFunction;\r\nend;\r\n\r\nprocedure TJclDoubleHashSet.Clear;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclDoubleHashSetBucket;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n begin\r\n for J := 0 to Bucket.Size - 1 do\r\n FreeDouble(Bucket.Entries[J]);\r\n FreeAndNil(FBuckets[I]);\r\n end;\r\n end;\r\n FSize := 0;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclDoubleHashSet.CollectionEquals(const ACollection: IJclDoubleCollection): Boolean;\r\nvar\r\n I, J: Integer;\r\n It: IJclDoubleIterator;\r\n Bucket: TJclDoubleHashSetBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n if FSize <> ACollection.Size then\r\n Exit;\r\n It := ACollection.First;\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n for J := 0 to Bucket.Size - 1 do\r\n if not ItemsEqual(Bucket.Entries[J], It.Next) then\r\n Exit;\r\n end;\r\n Result := True;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclDoubleHashSet.Contains(const AValue: Double): Boolean;\r\nvar\r\n I: Integer;\r\n Bucket: TJclDoubleHashSetBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n Bucket := FBuckets[FHashToRangeFunction(Hash(AValue), FCapacity)];\r\n if Bucket <> nil then\r\n for I := 0 to Bucket.Size - 1 do\r\n if ItemsEqual(Bucket.Entries[I], AValue) then\r\n begin\r\n Result := True;\r\n Break;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclDoubleHashSet.ContainsAll(const ACollection: IJclDoubleCollection): Boolean;\r\nvar\r\n It: IJclDoubleIterator;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := True;\r\n if ACollection = nil then\r\n Exit;\r\n It := ACollection.First;\r\n while Result and It.HasNext do\r\n Result := Contains(It.Next);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclDoubleHashSet.Extract(const AValue: Double): Boolean;\r\nvar\r\n Bucket: TJclDoubleHashSetBucket;\r\n I, NewCapacity: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n Bucket := FBuckets[FHashToRangeFunction(Hash(AValue), FCapacity)];\r\n if Bucket <> nil then\r\n begin\r\n for I := 0 to Bucket.Size - 1 do\r\n if ItemsEqual(Bucket.Entries[I], AValue) then\r\n begin\r\n Result := True;\r\n Bucket.Entries[I] := 0.0;\r\n if I < Length(Bucket.Entries) - 1 then\r\n MoveArray(Bucket.Entries, I + 1, I, Bucket.Size - I - 1);\r\n Dec(Bucket.Size);\r\n Dec(FSize);\r\n Break;\r\n end;\r\n\r\n NewCapacity := CalcPackCapacity(Length(Bucket.Entries), Bucket.Size);\r\n if NewCapacity < Length(Bucket.Entries) then\r\n SetLength(Bucket.Entries, NewCapacity);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclDoubleHashSet.ExtractAll(const ACollection: IJclDoubleCollection): Boolean;\r\nvar\r\n It: IJclDoubleIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n Result := Extract(It.Next) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclDoubleHashSet.First: IJclDoubleIterator;\r\nvar\r\n ABucketIndex, AItemIndex: Integer;\r\n ABucket: TJclDoubleHashSetBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n ABucketIndex := 0;\r\n ABucket := nil;\r\n while ABucketIndex < FCapacity do\r\n begin\r\n ABucket := FBuckets[ABucketIndex];\r\n if (ABucket <> nil) and (ABucket.Size > 0) then\r\n Break;\r\n Inc(ABucketIndex);\r\n end;\r\n if ABucket <> nil then\r\n AItemIndex := 0\r\n else\r\n AItemIndex := -1;\r\n Result := TJclDoubleHashSetIterator.Create(Self, ABucketIndex, AItemIndex, False, isFirst);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\n{$IFDEF SUPPORTS_FOR_IN}\r\nfunction TJclDoubleHashSet.GetEnumerator: IJclDoubleIterator;\r\nbegin\r\n Result := First;\r\nend;\r\n{$ENDIF SUPPORTS_FOR_IN}\r\n\r\nprocedure TJclDoubleHashSet.Intersect(const ACollection: IJclDoubleCollection);\r\nbegin\r\n RetainAll(ACollection);\r\nend;\r\n\r\nfunction TJclDoubleHashSet.IsEmpty: Boolean;\r\nbegin\r\n Result := FSize = 0;\r\nend;\r\n\r\nfunction TJclDoubleHashSet.Last: IJclDoubleIterator;\r\nvar\r\n ABucketIndex, AItemIndex: Integer;\r\n ABucket: TJclDoubleHashSetBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n ABucketIndex := FCapacity - 1;\r\n ABucket := nil;\r\n while ABucketIndex >= 0 do\r\n begin\r\n ABucket := FBuckets[ABucketIndex];\r\n if (ABucket <> nil) and (ABucket.Size > 0) then\r\n Break;\r\n Dec(ABucketIndex);\r\n end;\r\n if ABucket <> nil then\r\n AItemIndex := ABucket.Size - 1\r\n else\r\n AItemIndex := -1;\r\n Result := TJclDoubleHashSetIterator.Create(Self, ABucketIndex, AItemIndex, False, isLast);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclDoubleHashSet.Pack;\r\nvar\r\n I: Integer;\r\n Bucket: TJclDoubleHashSetBucket;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n begin\r\n if Bucket.Size > 0 then\r\n SetLength(Bucket.Entries, Bucket.Size)\r\n else\r\n FreeAndNil(FBuckets[I]);\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclDoubleHashSet.Remove(const AValue: Double): Boolean;\r\nvar\r\n Extracted: Double;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := Extract(AValue);\r\n if Result then\r\n begin\r\n Extracted := AValue;\r\n FreeDouble(Extracted);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclDoubleHashSet.RemoveAll(const ACollection: IJclDoubleCollection): Boolean;\r\nvar\r\n It: IJclDoubleIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n Result := Remove(It.Next) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclDoubleHashSet.RetainAll(const ACollection: IJclDoubleCollection): Boolean;\r\nvar\r\n I, J, NewCapacity: Integer;\r\n Bucket: TJclDoubleHashSetBucket;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n begin\r\n for J := Bucket.Size - 1 downto 0 do\r\n if not ACollection.Contains(Bucket.Entries[I]) then\r\n begin\r\n Bucket.Entries[J] := FreeDouble(Bucket.Entries[J]);\r\n if J < Length(Bucket.Entries) - 1 then\r\n MoveArray(Bucket.Entries, J + 1, J, Bucket.Size - J - 1);\r\n Dec(Bucket.Size);\r\n Dec(FSize);\r\n end;\r\n\r\n NewCapacity := CalcPackCapacity(Length(Bucket.Entries), Bucket.Size);\r\n if NewCapacity < Length(Bucket.Entries) then\r\n SetLength(Bucket.Entries, NewCapacity);\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclDoubleHashSet.SetCapacity(Value: Integer);\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FSize = 0 then\r\n begin\r\n SetLength(FBuckets, Value);\r\n inherited SetCapacity(Value);\r\n end\r\n else\r\n raise EJclOperationNotSupportedError.Create;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclDoubleHashSet.Size: Integer;\r\nbegin\r\n Result := FSize;\r\nend;\r\n\r\nprocedure TJclDoubleHashSet.Subtract(const ACollection: IJclDoubleCollection);\r\nbegin\r\n RemoveAll(ACollection);\r\nend;\r\n\r\nprocedure TJclDoubleHashSet.Union(const ACollection: IJclDoubleCollection);\r\nbegin\r\n AddAll(ACollection);\r\nend;\r\n\r\n\r\nfunction TJclDoubleHashSet.CreateEmptyContainer: TJclAbstractContainerBase;\r\nbegin\r\n Result := TJclDoubleHashSet.Create(Size);\r\n AssignPropertiesTo(Result);\r\nend;\r\n\r\n//=== { TJclDoubleHashSetIterator } ============================================\r\n\r\nconstructor TJclDoubleHashSetIterator.Create(AOwnHashSet: TJclDoubleHashSet;\r\n ABucketIndex, AItemIndex: Integer; AValid: Boolean; AStart: TItrStart);\r\nbegin\r\n inherited Create(AValid);\r\n FOwnHashSet := AOwnHashSet;\r\n FBucketIndex := ABucketIndex;\r\n FItemIndex := AItemIndex;\r\n FStart := AStart;\r\nend;\r\n\r\nfunction TJclDoubleHashSetIterator.Add(const AValue: Double): Boolean;\r\nbegin\r\n Result := FOwnHashSet.Add(AValue);\r\nend;\r\n\r\nprocedure TJclDoubleHashSetIterator.AssignPropertiesTo(Dest: TJclAbstractIterator);\r\nvar\r\n ADest: TJclDoubleHashSetIterator;\r\nbegin\r\n inherited AssignPropertiesTo(Dest);\r\n if Dest is TJclDoubleHashSetIterator then\r\n begin\r\n ADest := TJclDoubleHashSetIterator(Dest);\r\n ADest.FBucketIndex := FBucketIndex;\r\n ADest.FItemIndex := FItemIndex;\r\n ADest.FOwnHashSet := FOwnHashSet;\r\n ADest.FStart := FStart;\r\n end;\r\nend;\r\n\r\nfunction TJclDoubleHashSetIterator.CreateEmptyIterator: TJclAbstractIterator;\r\nbegin\r\n Result := TJclDoubleHashSetIterator.Create(FOwnHashSet, FBucketIndex, FItemIndex, Valid, FStart);\r\nend;\r\n\r\nprocedure TJclDoubleHashSetIterator.Extract;\r\nvar\r\n AValue: Double;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnHashSet.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n CheckValid;\r\n AValue := GetValue;\r\n Valid := False;\r\n FOwnHashSet.Extract(AValue);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnHashSet.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclDoubleHashSetIterator.GetValue: Double;\r\nvar\r\n ABucket: TJclDoubleHashSetBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnHashSet.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n CheckValid;\r\n Result := 0.0;\r\n ABucket := FOwnHashSet.FBuckets[FBucketIndex - 1];\r\n if (ABucket <> nil) and (FItemIndex < ABucket.Size) then\r\n Result := ABucket.Entries[FItemIndex]\r\n else\r\n if not FOwnHashSet.ReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnHashSet.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclDoubleHashSetIterator.HasNext: Boolean;\r\nvar\r\n ABucketIndex, AItemIndex: Integer;\r\n ABucket: TJclDoubleHashSetBucket;\r\n SkipCurrent: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnHashSet.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := True;\r\n ABucketIndex := FBucketIndex;\r\n AItemIndex := FItemIndex;\r\n SkipCurrent := Valid;\r\n while ABucketIndex < FOwnHashSet.FCapacity do\r\n begin\r\n ABucket := FOwnHashSet.FBuckets[ABucketIndex];\r\n if ABucket <> nil then\r\n begin\r\n if (AItemIndex < (ABucket.Size - 1)) or\r\n ((not SkipCurrent) and (AItemIndex < ABucket.Size)) then\r\n Exit;\r\n end;\r\n AItemIndex := 0;\r\n Inc(ABucketIndex);\r\n SkipCurrent := False;\r\n end;\r\n Result := False;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnHashSet.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclDoubleHashSetIterator.HasPrevious: Boolean;\r\nvar\r\n ABucketIndex, AItemIndex: Integer;\r\n ABucket: TJclDoubleHashSetBucket;\r\n SkipCurrent: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnHashSet.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := True;\r\n ABucketIndex := FBucketIndex;\r\n AItemIndex := FItemIndex;\r\n SkipCurrent := Valid;\r\n while ABucketIndex >= 0 do\r\n begin\r\n ABucket := FOwnHashSet.FBuckets[ABucketIndex];\r\n if ABucket <> nil then\r\n begin\r\n if (AItemIndex > 0) or\r\n ((not SkipCurrent) and (AItemIndex >= 0)) then\r\n Exit;\r\n end;\r\n AItemIndex := MaxInt;\r\n Dec(ABucketIndex);\r\n SkipCurrent := False;\r\n end;\r\n Result := False;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnHashSet.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclDoubleHashSetIterator.Insert(const AValue: Double): Boolean;\r\nbegin\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nfunction TJclDoubleHashSetIterator.IteratorEquals(const AIterator: IJclDoubleIterator): Boolean;\r\nvar\r\n Obj: TObject;\r\n ItrObj: TJclDoubleHashSetIterator;\r\nbegin\r\n Result := False;\r\n if AIterator = nil then\r\n Exit;\r\n Obj := AIterator.GetIteratorReference;\r\n if Obj is TJclDoubleHashSetIterator then\r\n begin\r\n ItrObj := TJclDoubleHashSetIterator(Obj);\r\n Result := (FOwnHashSet = ItrObj.FOwnHashSet) and (FBucketIndex = ItrObj.FBucketIndex) and (FItemIndex = ItrObj.FItemIndex) and (Valid = ItrObj.Valid);\r\n end;\r\nend;\r\n\r\n{$IFDEF SUPPORTS_FOR_IN}\r\nfunction TJclDoubleHashSetIterator.MoveNext: Boolean;\r\nvar\r\n ABucket: TJclDoubleHashSetBucket;\r\n SkipCurrent: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnHashSet.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Valid then\r\n begin\r\n SkipCurrent := True;\r\n while FBucketIndex < FOwnHashSet.FCapacity do\r\n begin\r\n ABucket := FOwnHashSet.FBuckets[FBucketIndex];\r\n if ABucket <> nil then\r\n begin\r\n if (not SkipCurrent) and (FItemIndex < ABucket.Size) then\r\n Break;\r\n if FItemIndex < (ABucket.Size - 1) then\r\n begin\r\n Inc(FItemIndex);\r\n Break;\r\n end;\r\n end;\r\n FItemIndex := 0;\r\n Inc(FBucketIndex);\r\n SkipCurrent := False;\r\n end;\r\n end\r\n else\r\n Valid := True;\r\n\r\n Result := (FBucketIndex >= 0) and (FItemIndex >= 0) and\r\n (FBucketIndex < FOwnHashSet.FCapacity);\r\n if Result then\r\n begin\r\n ABucket := FOwnHashSet.FBuckets[FBucketIndex];\r\n Result := (ABucket <> nil) and (FItemIndex < ABucket.Size);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnHashSet.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n{$ENDIF SUPPORTS_FOR_IN}\r\n\r\nfunction TJclDoubleHashSetIterator.Next: Double;\r\nvar\r\n ABucket: TJclDoubleHashSetBucket;\r\n SkipCurrent: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnHashSet.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Valid then\r\n begin\r\n SkipCurrent := True;\r\n while FBucketIndex < FOwnHashSet.FCapacity do\r\n begin\r\n ABucket := FOwnHashSet.FBuckets[FBucketIndex];\r\n if ABucket <> nil then\r\n begin\r\n if (not SkipCurrent) and (FItemIndex < ABucket.Size) then\r\n Break;\r\n if FItemIndex < (ABucket.Size - 1) then\r\n begin\r\n Inc(FItemIndex);\r\n Break;\r\n end;\r\n end;\r\n FItemIndex := 0;\r\n Inc(FBucketIndex);\r\n SkipCurrent := False;\r\n end;\r\n end\r\n else\r\n Valid := True;\r\n\r\n Result := 0.0;\r\n if (FBucketIndex >= 0) and (FItemIndex >= 0) and\r\n (FBucketIndex < FOwnHashSet.FCapacity) then\r\n begin\r\n ABucket := FOwnHashSet.FBuckets[FBucketIndex];\r\n if (ABucket <> nil) and\r\n (FItemIndex < ABucket.Size) then\r\n Result := ABucket.Entries[FItemIndex]\r\n else\r\n if not FOwnHashSet.ReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n end\r\n else\r\n if not FOwnHashSet.ReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnHashSet.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclDoubleHashSetIterator.NextIndex: Integer;\r\nbegin\r\n // No index\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nfunction TJclDoubleHashSetIterator.Previous: Double;\r\nvar\r\n ABucket: TJclDoubleHashSetBucket;\r\n SkipCurrent: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnHashSet.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Valid then\r\n begin\r\n SkipCurrent := True;\r\n while FBucketIndex >= 0 do\r\n begin\r\n ABucket := FOwnHashSet.FBuckets[FBucketIndex];\r\n if (ABucket <> nil) and (FItemIndex < 0) then\r\n FItemIndex := ABucket.Size - 1;\r\n if ABucket <> nil then\r\n begin\r\n if (not SkipCurrent) and (FItemIndex >= 0) and (FItemIndex < ABucket.Size) then\r\n Break;\r\n if (FItemIndex > 0) and (FItemIndex < ABucket.Size) then\r\n begin\r\n Dec(FItemIndex);\r\n Break;\r\n end;\r\n end;\r\n FItemIndex := -1;\r\n Dec(FBucketIndex);\r\n SkipCurrent := False;\r\n end;\r\n end\r\n else\r\n Valid := True;\r\n\r\n Result := 0.0;\r\n if (FBucketIndex >= 0) and (FItemIndex >= 0) and\r\n (FBucketIndex < FOwnHashSet.FCapacity) then\r\n begin\r\n ABucket := FOwnHashSet.FBuckets[FBucketIndex];\r\n if (ABucket <> nil) and\r\n (FItemIndex < ABucket.Size) then\r\n Result := ABucket.Entries[FItemIndex]\r\n else\r\n if not FOwnHashSet.ReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n end\r\n else\r\n if not FOwnHashSet.ReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnHashSet.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclDoubleHashSetIterator.PreviousIndex: Integer;\r\nbegin\r\n // No index\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nprocedure TJclDoubleHashSetIterator.Remove;\r\nbegin\r\n\r\nend;\r\n\r\nprocedure TJclDoubleHashSetIterator.Reset;\r\nvar\r\n ABucket: TJclDoubleHashSetBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnHashSet.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Valid := False;\r\n case FStart of\r\n isFirst:\r\n begin\r\n FBucketIndex := 0;\r\n ABucket := nil;\r\n while FBucketIndex < FOwnHashSet.FCapacity do\r\n begin\r\n ABucket := FOwnHashSet.FBuckets[FBucketIndex];\r\n if (ABucket <> nil) and (ABucket.Size > 0) then\r\n Break;\r\n Inc(FBucketIndex);\r\n end;\r\n if ABucket <> nil then\r\n FItemIndex := 0\r\n else\r\n FItemIndex := -1;\r\n end;\r\n isLast:\r\n begin\r\n FBucketIndex := FOwnHashSet.FCapacity - 1;\r\n ABucket := nil;\r\n while FBucketIndex >= 0 do\r\n begin\r\n ABucket := FOwnHashSet.FBuckets[FBucketIndex];\r\n if (ABucket <> nil) and (ABucket.Size > 0) then\r\n Break;\r\n Dec(FBucketIndex);\r\n end;\r\n if ABucket <> nil then\r\n FItemIndex := ABucket.Size - 1\r\n else\r\n FItemIndex := -1;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnHashSet.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclDoubleHashSetIterator.SetValue(const AValue: Double);\r\nbegin\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n//=== { TJclExtendedHashSet } ====================================================\r\n\r\nconstructor TJclExtendedHashSet.Create(ACapacity: Integer);\r\nbegin\r\n inherited Create();\r\n SetCapacity(ACapacity);\r\n FHashToRangeFunction := JclSimpleHashToRange;\r\nend;\r\n\r\ndestructor TJclExtendedHashSet.Destroy;\r\nbegin\r\n FReadOnly := False;\r\n Clear;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJclExtendedHashSet.Add(const AValue: Extended): Boolean;\r\nvar\r\n Index: Integer;\r\n Bucket: TJclExtendedHashSetBucket;\r\n I: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if FAllowDefaultElements or (not ItemsEqual(AValue, 0.0)) then\r\n begin\r\n Index := FHashToRangeFunction(Hash(AValue), FCapacity);\r\n Bucket := FBuckets[Index];\r\n if Bucket <> nil then\r\n begin\r\n for I := 0 to Bucket.Size - 1 do\r\n if ItemsEqual(Bucket.Entries[I], AValue) then\r\n Exit;\r\n end\r\n else\r\n begin\r\n Bucket := TJclExtendedHashSetBucket.Create;\r\n SetLength(Bucket.Entries, 1);\r\n FBuckets[Index] := Bucket;\r\n end;\r\n\r\n if Bucket.Size = Length(Bucket.Entries) then\r\n SetLength(Bucket.Entries, CalcGrowCapacity(Bucket.Size, Bucket.Size));\r\n\r\n if Bucket.Size < Length(Bucket.Entries) then\r\n begin\r\n Bucket.Entries[Bucket.Size] := AValue;\r\n Inc(Bucket.Size);\r\n Inc(FSize);\r\n Result := True;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclExtendedHashSet.AddAll(const ACollection: IJclExtendedCollection): Boolean;\r\nvar\r\n It: IJclExtendedIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n Result := Add(It.Next) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclExtendedHashSet.AssignDataTo(Dest: TJclAbstractContainerBase);\r\nvar\r\n I, J: Integer;\r\n SelfBucket, NewBucket: TJclExtendedHashSetBucket;\r\n ADest: TJclExtendedHashSet;\r\n ACollection: IJclExtendedCollection;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n inherited AssignDataTo(Dest);\r\n if Dest is TJclExtendedHashSet then\r\n begin\r\n ADest := TJclExtendedHashSet(Dest);\r\n ADest.Clear;\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n SelfBucket := FBuckets[I];\r\n if SelfBucket <> nil then\r\n begin\r\n NewBucket := TJclExtendedHashSetBucket.Create;\r\n SetLength(NewBucket.Entries, SelfBucket.Size);\r\n for J := 0 to SelfBucket.Size - 1 do\r\n NewBucket.Entries[J] := SelfBucket.Entries[J];\r\n NewBucket.Size := SelfBucket.Size;\r\n ADest.FBuckets[I] := NewBucket;\r\n end;\r\n end;\r\n end\r\n else\r\n if Supports(IInterface(Dest), IJclExtendedCollection, ACollection) then\r\n begin\r\n ACollection.Clear;\r\n ACollection.AddAll(Self);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclExtendedHashSet.AssignPropertiesTo(Dest: TJclAbstractContainerBase);\r\nbegin\r\n inherited AssignPropertiesto(Dest);\r\n if Dest is TJclExtendedHashSet then\r\n TJclExtendedHashSet(Dest).FHashToRangeFunction := FHashToRangeFunction;\r\nend;\r\n\r\nprocedure TJclExtendedHashSet.Clear;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclExtendedHashSetBucket;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n begin\r\n for J := 0 to Bucket.Size - 1 do\r\n FreeExtended(Bucket.Entries[J]);\r\n FreeAndNil(FBuckets[I]);\r\n end;\r\n end;\r\n FSize := 0;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclExtendedHashSet.CollectionEquals(const ACollection: IJclExtendedCollection): Boolean;\r\nvar\r\n I, J: Integer;\r\n It: IJclExtendedIterator;\r\n Bucket: TJclExtendedHashSetBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n if FSize <> ACollection.Size then\r\n Exit;\r\n It := ACollection.First;\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n for J := 0 to Bucket.Size - 1 do\r\n if not ItemsEqual(Bucket.Entries[J], It.Next) then\r\n Exit;\r\n end;\r\n Result := True;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclExtendedHashSet.Contains(const AValue: Extended): Boolean;\r\nvar\r\n I: Integer;\r\n Bucket: TJclExtendedHashSetBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n Bucket := FBuckets[FHashToRangeFunction(Hash(AValue), FCapacity)];\r\n if Bucket <> nil then\r\n for I := 0 to Bucket.Size - 1 do\r\n if ItemsEqual(Bucket.Entries[I], AValue) then\r\n begin\r\n Result := True;\r\n Break;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclExtendedHashSet.ContainsAll(const ACollection: IJclExtendedCollection): Boolean;\r\nvar\r\n It: IJclExtendedIterator;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := True;\r\n if ACollection = nil then\r\n Exit;\r\n It := ACollection.First;\r\n while Result and It.HasNext do\r\n Result := Contains(It.Next);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclExtendedHashSet.Extract(const AValue: Extended): Boolean;\r\nvar\r\n Bucket: TJclExtendedHashSetBucket;\r\n I, NewCapacity: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n Bucket := FBuckets[FHashToRangeFunction(Hash(AValue), FCapacity)];\r\n if Bucket <> nil then\r\n begin\r\n for I := 0 to Bucket.Size - 1 do\r\n if ItemsEqual(Bucket.Entries[I], AValue) then\r\n begin\r\n Result := True;\r\n Bucket.Entries[I] := 0.0;\r\n if I < Length(Bucket.Entries) - 1 then\r\n MoveArray(Bucket.Entries, I + 1, I, Bucket.Size - I - 1);\r\n Dec(Bucket.Size);\r\n Dec(FSize);\r\n Break;\r\n end;\r\n\r\n NewCapacity := CalcPackCapacity(Length(Bucket.Entries), Bucket.Size);\r\n if NewCapacity < Length(Bucket.Entries) then\r\n SetLength(Bucket.Entries, NewCapacity);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclExtendedHashSet.ExtractAll(const ACollection: IJclExtendedCollection): Boolean;\r\nvar\r\n It: IJclExtendedIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n Result := Extract(It.Next) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclExtendedHashSet.First: IJclExtendedIterator;\r\nvar\r\n ABucketIndex, AItemIndex: Integer;\r\n ABucket: TJclExtendedHashSetBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n ABucketIndex := 0;\r\n ABucket := nil;\r\n while ABucketIndex < FCapacity do\r\n begin\r\n ABucket := FBuckets[ABucketIndex];\r\n if (ABucket <> nil) and (ABucket.Size > 0) then\r\n Break;\r\n Inc(ABucketIndex);\r\n end;\r\n if ABucket <> nil then\r\n AItemIndex := 0\r\n else\r\n AItemIndex := -1;\r\n Result := TJclExtendedHashSetIterator.Create(Self, ABucketIndex, AItemIndex, False, isFirst);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\n{$IFDEF SUPPORTS_FOR_IN}\r\nfunction TJclExtendedHashSet.GetEnumerator: IJclExtendedIterator;\r\nbegin\r\n Result := First;\r\nend;\r\n{$ENDIF SUPPORTS_FOR_IN}\r\n\r\nprocedure TJclExtendedHashSet.Intersect(const ACollection: IJclExtendedCollection);\r\nbegin\r\n RetainAll(ACollection);\r\nend;\r\n\r\nfunction TJclExtendedHashSet.IsEmpty: Boolean;\r\nbegin\r\n Result := FSize = 0;\r\nend;\r\n\r\nfunction TJclExtendedHashSet.Last: IJclExtendedIterator;\r\nvar\r\n ABucketIndex, AItemIndex: Integer;\r\n ABucket: TJclExtendedHashSetBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n ABucketIndex := FCapacity - 1;\r\n ABucket := nil;\r\n while ABucketIndex >= 0 do\r\n begin\r\n ABucket := FBuckets[ABucketIndex];\r\n if (ABucket <> nil) and (ABucket.Size > 0) then\r\n Break;\r\n Dec(ABucketIndex);\r\n end;\r\n if ABucket <> nil then\r\n AItemIndex := ABucket.Size - 1\r\n else\r\n AItemIndex := -1;\r\n Result := TJclExtendedHashSetIterator.Create(Self, ABucketIndex, AItemIndex, False, isLast);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclExtendedHashSet.Pack;\r\nvar\r\n I: Integer;\r\n Bucket: TJclExtendedHashSetBucket;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n begin\r\n if Bucket.Size > 0 then\r\n SetLength(Bucket.Entries, Bucket.Size)\r\n else\r\n FreeAndNil(FBuckets[I]);\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclExtendedHashSet.Remove(const AValue: Extended): Boolean;\r\nvar\r\n Extracted: Extended;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := Extract(AValue);\r\n if Result then\r\n begin\r\n Extracted := AValue;\r\n FreeExtended(Extracted);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclExtendedHashSet.RemoveAll(const ACollection: IJclExtendedCollection): Boolean;\r\nvar\r\n It: IJclExtendedIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n Result := Remove(It.Next) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclExtendedHashSet.RetainAll(const ACollection: IJclExtendedCollection): Boolean;\r\nvar\r\n I, J, NewCapacity: Integer;\r\n Bucket: TJclExtendedHashSetBucket;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n begin\r\n for J := Bucket.Size - 1 downto 0 do\r\n if not ACollection.Contains(Bucket.Entries[I]) then\r\n begin\r\n Bucket.Entries[J] := FreeExtended(Bucket.Entries[J]);\r\n if J < Length(Bucket.Entries) - 1 then\r\n MoveArray(Bucket.Entries, J + 1, J, Bucket.Size - J - 1);\r\n Dec(Bucket.Size);\r\n Dec(FSize);\r\n end;\r\n\r\n NewCapacity := CalcPackCapacity(Length(Bucket.Entries), Bucket.Size);\r\n if NewCapacity < Length(Bucket.Entries) then\r\n SetLength(Bucket.Entries, NewCapacity);\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclExtendedHashSet.SetCapacity(Value: Integer);\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FSize = 0 then\r\n begin\r\n SetLength(FBuckets, Value);\r\n inherited SetCapacity(Value);\r\n end\r\n else\r\n raise EJclOperationNotSupportedError.Create;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclExtendedHashSet.Size: Integer;\r\nbegin\r\n Result := FSize;\r\nend;\r\n\r\nprocedure TJclExtendedHashSet.Subtract(const ACollection: IJclExtendedCollection);\r\nbegin\r\n RemoveAll(ACollection);\r\nend;\r\n\r\nprocedure TJclExtendedHashSet.Union(const ACollection: IJclExtendedCollection);\r\nbegin\r\n AddAll(ACollection);\r\nend;\r\n\r\n\r\nfunction TJclExtendedHashSet.CreateEmptyContainer: TJclAbstractContainerBase;\r\nbegin\r\n Result := TJclExtendedHashSet.Create(Size);\r\n AssignPropertiesTo(Result);\r\nend;\r\n\r\n//=== { TJclExtendedHashSetIterator } ============================================\r\n\r\nconstructor TJclExtendedHashSetIterator.Create(AOwnHashSet: TJclExtendedHashSet;\r\n ABucketIndex, AItemIndex: Integer; AValid: Boolean; AStart: TItrStart);\r\nbegin\r\n inherited Create(AValid);\r\n FOwnHashSet := AOwnHashSet;\r\n FBucketIndex := ABucketIndex;\r\n FItemIndex := AItemIndex;\r\n FStart := AStart;\r\nend;\r\n\r\nfunction TJclExtendedHashSetIterator.Add(const AValue: Extended): Boolean;\r\nbegin\r\n Result := FOwnHashSet.Add(AValue);\r\nend;\r\n\r\nprocedure TJclExtendedHashSetIterator.AssignPropertiesTo(Dest: TJclAbstractIterator);\r\nvar\r\n ADest: TJclExtendedHashSetIterator;\r\nbegin\r\n inherited AssignPropertiesTo(Dest);\r\n if Dest is TJclExtendedHashSetIterator then\r\n begin\r\n ADest := TJclExtendedHashSetIterator(Dest);\r\n ADest.FBucketIndex := FBucketIndex;\r\n ADest.FItemIndex := FItemIndex;\r\n ADest.FOwnHashSet := FOwnHashSet;\r\n ADest.FStart := FStart;\r\n end;\r\nend;\r\n\r\nfunction TJclExtendedHashSetIterator.CreateEmptyIterator: TJclAbstractIterator;\r\nbegin\r\n Result := TJclExtendedHashSetIterator.Create(FOwnHashSet, FBucketIndex, FItemIndex, Valid, FStart);\r\nend;\r\n\r\nprocedure TJclExtendedHashSetIterator.Extract;\r\nvar\r\n AValue: Extended;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnHashSet.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n CheckValid;\r\n AValue := GetValue;\r\n Valid := False;\r\n FOwnHashSet.Extract(AValue);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnHashSet.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclExtendedHashSetIterator.GetValue: Extended;\r\nvar\r\n ABucket: TJclExtendedHashSetBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnHashSet.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n CheckValid;\r\n Result := 0.0;\r\n ABucket := FOwnHashSet.FBuckets[FBucketIndex - 1];\r\n if (ABucket <> nil) and (FItemIndex < ABucket.Size) then\r\n Result := ABucket.Entries[FItemIndex]\r\n else\r\n if not FOwnHashSet.ReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnHashSet.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclExtendedHashSetIterator.HasNext: Boolean;\r\nvar\r\n ABucketIndex, AItemIndex: Integer;\r\n ABucket: TJclExtendedHashSetBucket;\r\n SkipCurrent: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnHashSet.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := True;\r\n ABucketIndex := FBucketIndex;\r\n AItemIndex := FItemIndex;\r\n SkipCurrent := Valid;\r\n while ABucketIndex < FOwnHashSet.FCapacity do\r\n begin\r\n ABucket := FOwnHashSet.FBuckets[ABucketIndex];\r\n if ABucket <> nil then\r\n begin\r\n if (AItemIndex < (ABucket.Size - 1)) or\r\n ((not SkipCurrent) and (AItemIndex < ABucket.Size)) then\r\n Exit;\r\n end;\r\n AItemIndex := 0;\r\n Inc(ABucketIndex);\r\n SkipCurrent := False;\r\n end;\r\n Result := False;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnHashSet.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclExtendedHashSetIterator.HasPrevious: Boolean;\r\nvar\r\n ABucketIndex, AItemIndex: Integer;\r\n ABucket: TJclExtendedHashSetBucket;\r\n SkipCurrent: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnHashSet.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := True;\r\n ABucketIndex := FBucketIndex;\r\n AItemIndex := FItemIndex;\r\n SkipCurrent := Valid;\r\n while ABucketIndex >= 0 do\r\n begin\r\n ABucket := FOwnHashSet.FBuckets[ABucketIndex];\r\n if ABucket <> nil then\r\n begin\r\n if (AItemIndex > 0) or\r\n ((not SkipCurrent) and (AItemIndex >= 0)) then\r\n Exit;\r\n end;\r\n AItemIndex := MaxInt;\r\n Dec(ABucketIndex);\r\n SkipCurrent := False;\r\n end;\r\n Result := False;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnHashSet.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclExtendedHashSetIterator.Insert(const AValue: Extended): Boolean;\r\nbegin\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nfunction TJclExtendedHashSetIterator.IteratorEquals(const AIterator: IJclExtendedIterator): Boolean;\r\nvar\r\n Obj: TObject;\r\n ItrObj: TJclExtendedHashSetIterator;\r\nbegin\r\n Result := False;\r\n if AIterator = nil then\r\n Exit;\r\n Obj := AIterator.GetIteratorReference;\r\n if Obj is TJclExtendedHashSetIterator then\r\n begin\r\n ItrObj := TJclExtendedHashSetIterator(Obj);\r\n Result := (FOwnHashSet = ItrObj.FOwnHashSet) and (FBucketIndex = ItrObj.FBucketIndex) and (FItemIndex = ItrObj.FItemIndex) and (Valid = ItrObj.Valid);\r\n end;\r\nend;\r\n\r\n{$IFDEF SUPPORTS_FOR_IN}\r\nfunction TJclExtendedHashSetIterator.MoveNext: Boolean;\r\nvar\r\n ABucket: TJclExtendedHashSetBucket;\r\n SkipCurrent: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnHashSet.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Valid then\r\n begin\r\n SkipCurrent := True;\r\n while FBucketIndex < FOwnHashSet.FCapacity do\r\n begin\r\n ABucket := FOwnHashSet.FBuckets[FBucketIndex];\r\n if ABucket <> nil then\r\n begin\r\n if (not SkipCurrent) and (FItemIndex < ABucket.Size) then\r\n Break;\r\n if FItemIndex < (ABucket.Size - 1) then\r\n begin\r\n Inc(FItemIndex);\r\n Break;\r\n end;\r\n end;\r\n FItemIndex := 0;\r\n Inc(FBucketIndex);\r\n SkipCurrent := False;\r\n end;\r\n end\r\n else\r\n Valid := True;\r\n\r\n Result := (FBucketIndex >= 0) and (FItemIndex >= 0) and\r\n (FBucketIndex < FOwnHashSet.FCapacity);\r\n if Result then\r\n begin\r\n ABucket := FOwnHashSet.FBuckets[FBucketIndex];\r\n Result := (ABucket <> nil) and (FItemIndex < ABucket.Size);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnHashSet.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n{$ENDIF SUPPORTS_FOR_IN}\r\n\r\nfunction TJclExtendedHashSetIterator.Next: Extended;\r\nvar\r\n ABucket: TJclExtendedHashSetBucket;\r\n SkipCurrent: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnHashSet.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Valid then\r\n begin\r\n SkipCurrent := True;\r\n while FBucketIndex < FOwnHashSet.FCapacity do\r\n begin\r\n ABucket := FOwnHashSet.FBuckets[FBucketIndex];\r\n if ABucket <> nil then\r\n begin\r\n if (not SkipCurrent) and (FItemIndex < ABucket.Size) then\r\n Break;\r\n if FItemIndex < (ABucket.Size - 1) then\r\n begin\r\n Inc(FItemIndex);\r\n Break;\r\n end;\r\n end;\r\n FItemIndex := 0;\r\n Inc(FBucketIndex);\r\n SkipCurrent := False;\r\n end;\r\n end\r\n else\r\n Valid := True;\r\n\r\n Result := 0.0;\r\n if (FBucketIndex >= 0) and (FItemIndex >= 0) and\r\n (FBucketIndex < FOwnHashSet.FCapacity) then\r\n begin\r\n ABucket := FOwnHashSet.FBuckets[FBucketIndex];\r\n if (ABucket <> nil) and\r\n (FItemIndex < ABucket.Size) then\r\n Result := ABucket.Entries[FItemIndex]\r\n else\r\n if not FOwnHashSet.ReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n end\r\n else\r\n if not FOwnHashSet.ReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnHashSet.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclExtendedHashSetIterator.NextIndex: Integer;\r\nbegin\r\n // No index\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nfunction TJclExtendedHashSetIterator.Previous: Extended;\r\nvar\r\n ABucket: TJclExtendedHashSetBucket;\r\n SkipCurrent: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnHashSet.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Valid then\r\n begin\r\n SkipCurrent := True;\r\n while FBucketIndex >= 0 do\r\n begin\r\n ABucket := FOwnHashSet.FBuckets[FBucketIndex];\r\n if (ABucket <> nil) and (FItemIndex < 0) then\r\n FItemIndex := ABucket.Size - 1;\r\n if ABucket <> nil then\r\n begin\r\n if (not SkipCurrent) and (FItemIndex >= 0) and (FItemIndex < ABucket.Size) then\r\n Break;\r\n if (FItemIndex > 0) and (FItemIndex < ABucket.Size) then\r\n begin\r\n Dec(FItemIndex);\r\n Break;\r\n end;\r\n end;\r\n FItemIndex := -1;\r\n Dec(FBucketIndex);\r\n SkipCurrent := False;\r\n end;\r\n end\r\n else\r\n Valid := True;\r\n\r\n Result := 0.0;\r\n if (FBucketIndex >= 0) and (FItemIndex >= 0) and\r\n (FBucketIndex < FOwnHashSet.FCapacity) then\r\n begin\r\n ABucket := FOwnHashSet.FBuckets[FBucketIndex];\r\n if (ABucket <> nil) and\r\n (FItemIndex < ABucket.Size) then\r\n Result := ABucket.Entries[FItemIndex]\r\n else\r\n if not FOwnHashSet.ReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n end\r\n else\r\n if not FOwnHashSet.ReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnHashSet.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclExtendedHashSetIterator.PreviousIndex: Integer;\r\nbegin\r\n // No index\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nprocedure TJclExtendedHashSetIterator.Remove;\r\nbegin\r\n\r\nend;\r\n\r\nprocedure TJclExtendedHashSetIterator.Reset;\r\nvar\r\n ABucket: TJclExtendedHashSetBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnHashSet.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Valid := False;\r\n case FStart of\r\n isFirst:\r\n begin\r\n FBucketIndex := 0;\r\n ABucket := nil;\r\n while FBucketIndex < FOwnHashSet.FCapacity do\r\n begin\r\n ABucket := FOwnHashSet.FBuckets[FBucketIndex];\r\n if (ABucket <> nil) and (ABucket.Size > 0) then\r\n Break;\r\n Inc(FBucketIndex);\r\n end;\r\n if ABucket <> nil then\r\n FItemIndex := 0\r\n else\r\n FItemIndex := -1;\r\n end;\r\n isLast:\r\n begin\r\n FBucketIndex := FOwnHashSet.FCapacity - 1;\r\n ABucket := nil;\r\n while FBucketIndex >= 0 do\r\n begin\r\n ABucket := FOwnHashSet.FBuckets[FBucketIndex];\r\n if (ABucket <> nil) and (ABucket.Size > 0) then\r\n Break;\r\n Dec(FBucketIndex);\r\n end;\r\n if ABucket <> nil then\r\n FItemIndex := ABucket.Size - 1\r\n else\r\n FItemIndex := -1;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnHashSet.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclExtendedHashSetIterator.SetValue(const AValue: Extended);\r\nbegin\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n//=== { TJclIntegerHashSet } ====================================================\r\n\r\nconstructor TJclIntegerHashSet.Create(ACapacity: Integer);\r\nbegin\r\n inherited Create();\r\n SetCapacity(ACapacity);\r\n FHashToRangeFunction := JclSimpleHashToRange;\r\nend;\r\n\r\ndestructor TJclIntegerHashSet.Destroy;\r\nbegin\r\n FReadOnly := False;\r\n Clear;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJclIntegerHashSet.Add(AValue: Integer): Boolean;\r\nvar\r\n Index: Integer;\r\n Bucket: TJclIntegerHashSetBucket;\r\n I: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if FAllowDefaultElements or (not ItemsEqual(AValue, 0)) then\r\n begin\r\n Index := FHashToRangeFunction(Hash(AValue), FCapacity);\r\n Bucket := FBuckets[Index];\r\n if Bucket <> nil then\r\n begin\r\n for I := 0 to Bucket.Size - 1 do\r\n if ItemsEqual(Bucket.Entries[I], AValue) then\r\n Exit;\r\n end\r\n else\r\n begin\r\n Bucket := TJclIntegerHashSetBucket.Create;\r\n SetLength(Bucket.Entries, 1);\r\n FBuckets[Index] := Bucket;\r\n end;\r\n\r\n if Bucket.Size = Length(Bucket.Entries) then\r\n SetLength(Bucket.Entries, CalcGrowCapacity(Bucket.Size, Bucket.Size));\r\n\r\n if Bucket.Size < Length(Bucket.Entries) then\r\n begin\r\n Bucket.Entries[Bucket.Size] := AValue;\r\n Inc(Bucket.Size);\r\n Inc(FSize);\r\n Result := True;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntegerHashSet.AddAll(const ACollection: IJclIntegerCollection): Boolean;\r\nvar\r\n It: IJclIntegerIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n Result := Add(It.Next) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclIntegerHashSet.AssignDataTo(Dest: TJclAbstractContainerBase);\r\nvar\r\n I, J: Integer;\r\n SelfBucket, NewBucket: TJclIntegerHashSetBucket;\r\n ADest: TJclIntegerHashSet;\r\n ACollection: IJclIntegerCollection;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n inherited AssignDataTo(Dest);\r\n if Dest is TJclIntegerHashSet then\r\n begin\r\n ADest := TJclIntegerHashSet(Dest);\r\n ADest.Clear;\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n SelfBucket := FBuckets[I];\r\n if SelfBucket <> nil then\r\n begin\r\n NewBucket := TJclIntegerHashSetBucket.Create;\r\n SetLength(NewBucket.Entries, SelfBucket.Size);\r\n for J := 0 to SelfBucket.Size - 1 do\r\n NewBucket.Entries[J] := SelfBucket.Entries[J];\r\n NewBucket.Size := SelfBucket.Size;\r\n ADest.FBuckets[I] := NewBucket;\r\n end;\r\n end;\r\n end\r\n else\r\n if Supports(IInterface(Dest), IJclIntegerCollection, ACollection) then\r\n begin\r\n ACollection.Clear;\r\n ACollection.AddAll(Self);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclIntegerHashSet.AssignPropertiesTo(Dest: TJclAbstractContainerBase);\r\nbegin\r\n inherited AssignPropertiesto(Dest);\r\n if Dest is TJclIntegerHashSet then\r\n TJclIntegerHashSet(Dest).FHashToRangeFunction := FHashToRangeFunction;\r\nend;\r\n\r\nprocedure TJclIntegerHashSet.Clear;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclIntegerHashSetBucket;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n begin\r\n for J := 0 to Bucket.Size - 1 do\r\n FreeInteger(Bucket.Entries[J]);\r\n FreeAndNil(FBuckets[I]);\r\n end;\r\n end;\r\n FSize := 0;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntegerHashSet.CollectionEquals(const ACollection: IJclIntegerCollection): Boolean;\r\nvar\r\n I, J: Integer;\r\n It: IJclIntegerIterator;\r\n Bucket: TJclIntegerHashSetBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n if FSize <> ACollection.Size then\r\n Exit;\r\n It := ACollection.First;\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n for J := 0 to Bucket.Size - 1 do\r\n if not ItemsEqual(Bucket.Entries[J], It.Next) then\r\n Exit;\r\n end;\r\n Result := True;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntegerHashSet.Contains(AValue: Integer): Boolean;\r\nvar\r\n I: Integer;\r\n Bucket: TJclIntegerHashSetBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n Bucket := FBuckets[FHashToRangeFunction(Hash(AValue), FCapacity)];\r\n if Bucket <> nil then\r\n for I := 0 to Bucket.Size - 1 do\r\n if ItemsEqual(Bucket.Entries[I], AValue) then\r\n begin\r\n Result := True;\r\n Break;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntegerHashSet.ContainsAll(const ACollection: IJclIntegerCollection): Boolean;\r\nvar\r\n It: IJclIntegerIterator;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := True;\r\n if ACollection = nil then\r\n Exit;\r\n It := ACollection.First;\r\n while Result and It.HasNext do\r\n Result := Contains(It.Next);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntegerHashSet.Extract(AValue: Integer): Boolean;\r\nvar\r\n Bucket: TJclIntegerHashSetBucket;\r\n I, NewCapacity: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n Bucket := FBuckets[FHashToRangeFunction(Hash(AValue), FCapacity)];\r\n if Bucket <> nil then\r\n begin\r\n for I := 0 to Bucket.Size - 1 do\r\n if ItemsEqual(Bucket.Entries[I], AValue) then\r\n begin\r\n Result := True;\r\n Bucket.Entries[I] := 0;\r\n if I < Length(Bucket.Entries) - 1 then\r\n MoveArray(Bucket.Entries, I + 1, I, Bucket.Size - I - 1);\r\n Dec(Bucket.Size);\r\n Dec(FSize);\r\n Break;\r\n end;\r\n\r\n NewCapacity := CalcPackCapacity(Length(Bucket.Entries), Bucket.Size);\r\n if NewCapacity < Length(Bucket.Entries) then\r\n SetLength(Bucket.Entries, NewCapacity);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntegerHashSet.ExtractAll(const ACollection: IJclIntegerCollection): Boolean;\r\nvar\r\n It: IJclIntegerIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n Result := Extract(It.Next) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntegerHashSet.First: IJclIntegerIterator;\r\nvar\r\n ABucketIndex, AItemIndex: Integer;\r\n ABucket: TJclIntegerHashSetBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n ABucketIndex := 0;\r\n ABucket := nil;\r\n while ABucketIndex < FCapacity do\r\n begin\r\n ABucket := FBuckets[ABucketIndex];\r\n if (ABucket <> nil) and (ABucket.Size > 0) then\r\n Break;\r\n Inc(ABucketIndex);\r\n end;\r\n if ABucket <> nil then\r\n AItemIndex := 0\r\n else\r\n AItemIndex := -1;\r\n Result := TJclIntegerHashSetIterator.Create(Self, ABucketIndex, AItemIndex, False, isFirst);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\n{$IFDEF SUPPORTS_FOR_IN}\r\nfunction TJclIntegerHashSet.GetEnumerator: IJclIntegerIterator;\r\nbegin\r\n Result := First;\r\nend;\r\n{$ENDIF SUPPORTS_FOR_IN}\r\n\r\nprocedure TJclIntegerHashSet.Intersect(const ACollection: IJclIntegerCollection);\r\nbegin\r\n RetainAll(ACollection);\r\nend;\r\n\r\nfunction TJclIntegerHashSet.IsEmpty: Boolean;\r\nbegin\r\n Result := FSize = 0;\r\nend;\r\n\r\nfunction TJclIntegerHashSet.Last: IJclIntegerIterator;\r\nvar\r\n ABucketIndex, AItemIndex: Integer;\r\n ABucket: TJclIntegerHashSetBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n ABucketIndex := FCapacity - 1;\r\n ABucket := nil;\r\n while ABucketIndex >= 0 do\r\n begin\r\n ABucket := FBuckets[ABucketIndex];\r\n if (ABucket <> nil) and (ABucket.Size > 0) then\r\n Break;\r\n Dec(ABucketIndex);\r\n end;\r\n if ABucket <> nil then\r\n AItemIndex := ABucket.Size - 1\r\n else\r\n AItemIndex := -1;\r\n Result := TJclIntegerHashSetIterator.Create(Self, ABucketIndex, AItemIndex, False, isLast);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclIntegerHashSet.Pack;\r\nvar\r\n I: Integer;\r\n Bucket: TJclIntegerHashSetBucket;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n begin\r\n if Bucket.Size > 0 then\r\n SetLength(Bucket.Entries, Bucket.Size)\r\n else\r\n FreeAndNil(FBuckets[I]);\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntegerHashSet.Remove(AValue: Integer): Boolean;\r\nvar\r\n Extracted: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := Extract(AValue);\r\n if Result then\r\n begin\r\n Extracted := AValue;\r\n FreeInteger(Extracted);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntegerHashSet.RemoveAll(const ACollection: IJclIntegerCollection): Boolean;\r\nvar\r\n It: IJclIntegerIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n Result := Remove(It.Next) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntegerHashSet.RetainAll(const ACollection: IJclIntegerCollection): Boolean;\r\nvar\r\n I, J, NewCapacity: Integer;\r\n Bucket: TJclIntegerHashSetBucket;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n begin\r\n for J := Bucket.Size - 1 downto 0 do\r\n if not ACollection.Contains(Bucket.Entries[I]) then\r\n begin\r\n Bucket.Entries[J] := FreeInteger(Bucket.Entries[J]);\r\n if J < Length(Bucket.Entries) - 1 then\r\n MoveArray(Bucket.Entries, J + 1, J, Bucket.Size - J - 1);\r\n Dec(Bucket.Size);\r\n Dec(FSize);\r\n end;\r\n\r\n NewCapacity := CalcPackCapacity(Length(Bucket.Entries), Bucket.Size);\r\n if NewCapacity < Length(Bucket.Entries) then\r\n SetLength(Bucket.Entries, NewCapacity);\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclIntegerHashSet.SetCapacity(Value: Integer);\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FSize = 0 then\r\n begin\r\n SetLength(FBuckets, Value);\r\n inherited SetCapacity(Value);\r\n end\r\n else\r\n raise EJclOperationNotSupportedError.Create;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntegerHashSet.Size: Integer;\r\nbegin\r\n Result := FSize;\r\nend;\r\n\r\nprocedure TJclIntegerHashSet.Subtract(const ACollection: IJclIntegerCollection);\r\nbegin\r\n RemoveAll(ACollection);\r\nend;\r\n\r\nprocedure TJclIntegerHashSet.Union(const ACollection: IJclIntegerCollection);\r\nbegin\r\n AddAll(ACollection);\r\nend;\r\n\r\n\r\nfunction TJclIntegerHashSet.CreateEmptyContainer: TJclAbstractContainerBase;\r\nbegin\r\n Result := TJclIntegerHashSet.Create(Size);\r\n AssignPropertiesTo(Result);\r\nend;\r\n\r\n//=== { TJclIntegerHashSetIterator } ============================================\r\n\r\nconstructor TJclIntegerHashSetIterator.Create(AOwnHashSet: TJclIntegerHashSet;\r\n ABucketIndex, AItemIndex: Integer; AValid: Boolean; AStart: TItrStart);\r\nbegin\r\n inherited Create(AValid);\r\n FOwnHashSet := AOwnHashSet;\r\n FBucketIndex := ABucketIndex;\r\n FItemIndex := AItemIndex;\r\n FStart := AStart;\r\nend;\r\n\r\nfunction TJclIntegerHashSetIterator.Add(AValue: Integer): Boolean;\r\nbegin\r\n Result := FOwnHashSet.Add(AValue);\r\nend;\r\n\r\nprocedure TJclIntegerHashSetIterator.AssignPropertiesTo(Dest: TJclAbstractIterator);\r\nvar\r\n ADest: TJclIntegerHashSetIterator;\r\nbegin\r\n inherited AssignPropertiesTo(Dest);\r\n if Dest is TJclIntegerHashSetIterator then\r\n begin\r\n ADest := TJclIntegerHashSetIterator(Dest);\r\n ADest.FBucketIndex := FBucketIndex;\r\n ADest.FItemIndex := FItemIndex;\r\n ADest.FOwnHashSet := FOwnHashSet;\r\n ADest.FStart := FStart;\r\n end;\r\nend;\r\n\r\nfunction TJclIntegerHashSetIterator.CreateEmptyIterator: TJclAbstractIterator;\r\nbegin\r\n Result := TJclIntegerHashSetIterator.Create(FOwnHashSet, FBucketIndex, FItemIndex, Valid, FStart);\r\nend;\r\n\r\nprocedure TJclIntegerHashSetIterator.Extract;\r\nvar\r\n AValue: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnHashSet.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n CheckValid;\r\n AValue := GetValue;\r\n Valid := False;\r\n FOwnHashSet.Extract(AValue);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnHashSet.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntegerHashSetIterator.GetValue: Integer;\r\nvar\r\n ABucket: TJclIntegerHashSetBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnHashSet.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n CheckValid;\r\n Result := 0;\r\n ABucket := FOwnHashSet.FBuckets[FBucketIndex - 1];\r\n if (ABucket <> nil) and (FItemIndex < ABucket.Size) then\r\n Result := ABucket.Entries[FItemIndex]\r\n else\r\n if not FOwnHashSet.ReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnHashSet.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntegerHashSetIterator.HasNext: Boolean;\r\nvar\r\n ABucketIndex, AItemIndex: Integer;\r\n ABucket: TJclIntegerHashSetBucket;\r\n SkipCurrent: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnHashSet.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := True;\r\n ABucketIndex := FBucketIndex;\r\n AItemIndex := FItemIndex;\r\n SkipCurrent := Valid;\r\n while ABucketIndex < FOwnHashSet.FCapacity do\r\n begin\r\n ABucket := FOwnHashSet.FBuckets[ABucketIndex];\r\n if ABucket <> nil then\r\n begin\r\n if (AItemIndex < (ABucket.Size - 1)) or\r\n ((not SkipCurrent) and (AItemIndex < ABucket.Size)) then\r\n Exit;\r\n end;\r\n AItemIndex := 0;\r\n Inc(ABucketIndex);\r\n SkipCurrent := False;\r\n end;\r\n Result := False;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnHashSet.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntegerHashSetIterator.HasPrevious: Boolean;\r\nvar\r\n ABucketIndex, AItemIndex: Integer;\r\n ABucket: TJclIntegerHashSetBucket;\r\n SkipCurrent: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnHashSet.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := True;\r\n ABucketIndex := FBucketIndex;\r\n AItemIndex := FItemIndex;\r\n SkipCurrent := Valid;\r\n while ABucketIndex >= 0 do\r\n begin\r\n ABucket := FOwnHashSet.FBuckets[ABucketIndex];\r\n if ABucket <> nil then\r\n begin\r\n if (AItemIndex > 0) or\r\n ((not SkipCurrent) and (AItemIndex >= 0)) then\r\n Exit;\r\n end;\r\n AItemIndex := MaxInt;\r\n Dec(ABucketIndex);\r\n SkipCurrent := False;\r\n end;\r\n Result := False;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnHashSet.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntegerHashSetIterator.Insert(AValue: Integer): Boolean;\r\nbegin\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nfunction TJclIntegerHashSetIterator.IteratorEquals(const AIterator: IJclIntegerIterator): Boolean;\r\nvar\r\n Obj: TObject;\r\n ItrObj: TJclIntegerHashSetIterator;\r\nbegin\r\n Result := False;\r\n if AIterator = nil then\r\n Exit;\r\n Obj := AIterator.GetIteratorReference;\r\n if Obj is TJclIntegerHashSetIterator then\r\n begin\r\n ItrObj := TJclIntegerHashSetIterator(Obj);\r\n Result := (FOwnHashSet = ItrObj.FOwnHashSet) and (FBucketIndex = ItrObj.FBucketIndex) and (FItemIndex = ItrObj.FItemIndex) and (Valid = ItrObj.Valid);\r\n end;\r\nend;\r\n\r\n{$IFDEF SUPPORTS_FOR_IN}\r\nfunction TJclIntegerHashSetIterator.MoveNext: Boolean;\r\nvar\r\n ABucket: TJclIntegerHashSetBucket;\r\n SkipCurrent: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnHashSet.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Valid then\r\n begin\r\n SkipCurrent := True;\r\n while FBucketIndex < FOwnHashSet.FCapacity do\r\n begin\r\n ABucket := FOwnHashSet.FBuckets[FBucketIndex];\r\n if ABucket <> nil then\r\n begin\r\n if (not SkipCurrent) and (FItemIndex < ABucket.Size) then\r\n Break;\r\n if FItemIndex < (ABucket.Size - 1) then\r\n begin\r\n Inc(FItemIndex);\r\n Break;\r\n end;\r\n end;\r\n FItemIndex := 0;\r\n Inc(FBucketIndex);\r\n SkipCurrent := False;\r\n end;\r\n end\r\n else\r\n Valid := True;\r\n\r\n Result := (FBucketIndex >= 0) and (FItemIndex >= 0) and\r\n (FBucketIndex < FOwnHashSet.FCapacity);\r\n if Result then\r\n begin\r\n ABucket := FOwnHashSet.FBuckets[FBucketIndex];\r\n Result := (ABucket <> nil) and (FItemIndex < ABucket.Size);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnHashSet.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n{$ENDIF SUPPORTS_FOR_IN}\r\n\r\nfunction TJclIntegerHashSetIterator.Next: Integer;\r\nvar\r\n ABucket: TJclIntegerHashSetBucket;\r\n SkipCurrent: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnHashSet.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Valid then\r\n begin\r\n SkipCurrent := True;\r\n while FBucketIndex < FOwnHashSet.FCapacity do\r\n begin\r\n ABucket := FOwnHashSet.FBuckets[FBucketIndex];\r\n if ABucket <> nil then\r\n begin\r\n if (not SkipCurrent) and (FItemIndex < ABucket.Size) then\r\n Break;\r\n if FItemIndex < (ABucket.Size - 1) then\r\n begin\r\n Inc(FItemIndex);\r\n Break;\r\n end;\r\n end;\r\n FItemIndex := 0;\r\n Inc(FBucketIndex);\r\n SkipCurrent := False;\r\n end;\r\n end\r\n else\r\n Valid := True;\r\n\r\n Result := 0;\r\n if (FBucketIndex >= 0) and (FItemIndex >= 0) and\r\n (FBucketIndex < FOwnHashSet.FCapacity) then\r\n begin\r\n ABucket := FOwnHashSet.FBuckets[FBucketIndex];\r\n if (ABucket <> nil) and\r\n (FItemIndex < ABucket.Size) then\r\n Result := ABucket.Entries[FItemIndex]\r\n else\r\n if not FOwnHashSet.ReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n end\r\n else\r\n if not FOwnHashSet.ReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnHashSet.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntegerHashSetIterator.NextIndex: Integer;\r\nbegin\r\n // No index\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nfunction TJclIntegerHashSetIterator.Previous: Integer;\r\nvar\r\n ABucket: TJclIntegerHashSetBucket;\r\n SkipCurrent: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnHashSet.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Valid then\r\n begin\r\n SkipCurrent := True;\r\n while FBucketIndex >= 0 do\r\n begin\r\n ABucket := FOwnHashSet.FBuckets[FBucketIndex];\r\n if (ABucket <> nil) and (FItemIndex < 0) then\r\n FItemIndex := ABucket.Size - 1;\r\n if ABucket <> nil then\r\n begin\r\n if (not SkipCurrent) and (FItemIndex >= 0) and (FItemIndex < ABucket.Size) then\r\n Break;\r\n if (FItemIndex > 0) and (FItemIndex < ABucket.Size) then\r\n begin\r\n Dec(FItemIndex);\r\n Break;\r\n end;\r\n end;\r\n FItemIndex := -1;\r\n Dec(FBucketIndex);\r\n SkipCurrent := False;\r\n end;\r\n end\r\n else\r\n Valid := True;\r\n\r\n Result := 0;\r\n if (FBucketIndex >= 0) and (FItemIndex >= 0) and\r\n (FBucketIndex < FOwnHashSet.FCapacity) then\r\n begin\r\n ABucket := FOwnHashSet.FBuckets[FBucketIndex];\r\n if (ABucket <> nil) and\r\n (FItemIndex < ABucket.Size) then\r\n Result := ABucket.Entries[FItemIndex]\r\n else\r\n if not FOwnHashSet.ReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n end\r\n else\r\n if not FOwnHashSet.ReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnHashSet.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntegerHashSetIterator.PreviousIndex: Integer;\r\nbegin\r\n // No index\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nprocedure TJclIntegerHashSetIterator.Remove;\r\nbegin\r\n\r\nend;\r\n\r\nprocedure TJclIntegerHashSetIterator.Reset;\r\nvar\r\n ABucket: TJclIntegerHashSetBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnHashSet.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Valid := False;\r\n case FStart of\r\n isFirst:\r\n begin\r\n FBucketIndex := 0;\r\n ABucket := nil;\r\n while FBucketIndex < FOwnHashSet.FCapacity do\r\n begin\r\n ABucket := FOwnHashSet.FBuckets[FBucketIndex];\r\n if (ABucket <> nil) and (ABucket.Size > 0) then\r\n Break;\r\n Inc(FBucketIndex);\r\n end;\r\n if ABucket <> nil then\r\n FItemIndex := 0\r\n else\r\n FItemIndex := -1;\r\n end;\r\n isLast:\r\n begin\r\n FBucketIndex := FOwnHashSet.FCapacity - 1;\r\n ABucket := nil;\r\n while FBucketIndex >= 0 do\r\n begin\r\n ABucket := FOwnHashSet.FBuckets[FBucketIndex];\r\n if (ABucket <> nil) and (ABucket.Size > 0) then\r\n Break;\r\n Dec(FBucketIndex);\r\n end;\r\n if ABucket <> nil then\r\n FItemIndex := ABucket.Size - 1\r\n else\r\n FItemIndex := -1;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnHashSet.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclIntegerHashSetIterator.SetValue(AValue: Integer);\r\nbegin\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n//=== { TJclCardinalHashSet } ====================================================\r\n\r\nconstructor TJclCardinalHashSet.Create(ACapacity: Integer);\r\nbegin\r\n inherited Create();\r\n SetCapacity(ACapacity);\r\n FHashToRangeFunction := JclSimpleHashToRange;\r\nend;\r\n\r\ndestructor TJclCardinalHashSet.Destroy;\r\nbegin\r\n FReadOnly := False;\r\n Clear;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJclCardinalHashSet.Add(AValue: Cardinal): Boolean;\r\nvar\r\n Index: Integer;\r\n Bucket: TJclCardinalHashSetBucket;\r\n I: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if FAllowDefaultElements or (not ItemsEqual(AValue, 0)) then\r\n begin\r\n Index := FHashToRangeFunction(Hash(AValue), FCapacity);\r\n Bucket := FBuckets[Index];\r\n if Bucket <> nil then\r\n begin\r\n for I := 0 to Bucket.Size - 1 do\r\n if ItemsEqual(Bucket.Entries[I], AValue) then\r\n Exit;\r\n end\r\n else\r\n begin\r\n Bucket := TJclCardinalHashSetBucket.Create;\r\n SetLength(Bucket.Entries, 1);\r\n FBuckets[Index] := Bucket;\r\n end;\r\n\r\n if Bucket.Size = Length(Bucket.Entries) then\r\n SetLength(Bucket.Entries, CalcGrowCapacity(Bucket.Size, Bucket.Size));\r\n\r\n if Bucket.Size < Length(Bucket.Entries) then\r\n begin\r\n Bucket.Entries[Bucket.Size] := AValue;\r\n Inc(Bucket.Size);\r\n Inc(FSize);\r\n Result := True;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclCardinalHashSet.AddAll(const ACollection: IJclCardinalCollection): Boolean;\r\nvar\r\n It: IJclCardinalIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n Result := Add(It.Next) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclCardinalHashSet.AssignDataTo(Dest: TJclAbstractContainerBase);\r\nvar\r\n I, J: Integer;\r\n SelfBucket, NewBucket: TJclCardinalHashSetBucket;\r\n ADest: TJclCardinalHashSet;\r\n ACollection: IJclCardinalCollection;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n inherited AssignDataTo(Dest);\r\n if Dest is TJclCardinalHashSet then\r\n begin\r\n ADest := TJclCardinalHashSet(Dest);\r\n ADest.Clear;\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n SelfBucket := FBuckets[I];\r\n if SelfBucket <> nil then\r\n begin\r\n NewBucket := TJclCardinalHashSetBucket.Create;\r\n SetLength(NewBucket.Entries, SelfBucket.Size);\r\n for J := 0 to SelfBucket.Size - 1 do\r\n NewBucket.Entries[J] := SelfBucket.Entries[J];\r\n NewBucket.Size := SelfBucket.Size;\r\n ADest.FBuckets[I] := NewBucket;\r\n end;\r\n end;\r\n end\r\n else\r\n if Supports(IInterface(Dest), IJclCardinalCollection, ACollection) then\r\n begin\r\n ACollection.Clear;\r\n ACollection.AddAll(Self);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclCardinalHashSet.AssignPropertiesTo(Dest: TJclAbstractContainerBase);\r\nbegin\r\n inherited AssignPropertiesto(Dest);\r\n if Dest is TJclCardinalHashSet then\r\n TJclCardinalHashSet(Dest).FHashToRangeFunction := FHashToRangeFunction;\r\nend;\r\n\r\nprocedure TJclCardinalHashSet.Clear;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclCardinalHashSetBucket;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n begin\r\n for J := 0 to Bucket.Size - 1 do\r\n FreeCardinal(Bucket.Entries[J]);\r\n FreeAndNil(FBuckets[I]);\r\n end;\r\n end;\r\n FSize := 0;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclCardinalHashSet.CollectionEquals(const ACollection: IJclCardinalCollection): Boolean;\r\nvar\r\n I, J: Integer;\r\n It: IJclCardinalIterator;\r\n Bucket: TJclCardinalHashSetBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n if FSize <> ACollection.Size then\r\n Exit;\r\n It := ACollection.First;\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n for J := 0 to Bucket.Size - 1 do\r\n if not ItemsEqual(Bucket.Entries[J], It.Next) then\r\n Exit;\r\n end;\r\n Result := True;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclCardinalHashSet.Contains(AValue: Cardinal): Boolean;\r\nvar\r\n I: Integer;\r\n Bucket: TJclCardinalHashSetBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n Bucket := FBuckets[FHashToRangeFunction(Hash(AValue), FCapacity)];\r\n if Bucket <> nil then\r\n for I := 0 to Bucket.Size - 1 do\r\n if ItemsEqual(Bucket.Entries[I], AValue) then\r\n begin\r\n Result := True;\r\n Break;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclCardinalHashSet.ContainsAll(const ACollection: IJclCardinalCollection): Boolean;\r\nvar\r\n It: IJclCardinalIterator;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := True;\r\n if ACollection = nil then\r\n Exit;\r\n It := ACollection.First;\r\n while Result and It.HasNext do\r\n Result := Contains(It.Next);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclCardinalHashSet.Extract(AValue: Cardinal): Boolean;\r\nvar\r\n Bucket: TJclCardinalHashSetBucket;\r\n I, NewCapacity: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n Bucket := FBuckets[FHashToRangeFunction(Hash(AValue), FCapacity)];\r\n if Bucket <> nil then\r\n begin\r\n for I := 0 to Bucket.Size - 1 do\r\n if ItemsEqual(Bucket.Entries[I], AValue) then\r\n begin\r\n Result := True;\r\n Bucket.Entries[I] := 0;\r\n if I < Length(Bucket.Entries) - 1 then\r\n MoveArray(Bucket.Entries, I + 1, I, Bucket.Size - I - 1);\r\n Dec(Bucket.Size);\r\n Dec(FSize);\r\n Break;\r\n end;\r\n\r\n NewCapacity := CalcPackCapacity(Length(Bucket.Entries), Bucket.Size);\r\n if NewCapacity < Length(Bucket.Entries) then\r\n SetLength(Bucket.Entries, NewCapacity);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclCardinalHashSet.ExtractAll(const ACollection: IJclCardinalCollection): Boolean;\r\nvar\r\n It: IJclCardinalIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n Result := Extract(It.Next) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclCardinalHashSet.First: IJclCardinalIterator;\r\nvar\r\n ABucketIndex, AItemIndex: Integer;\r\n ABucket: TJclCardinalHashSetBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n ABucketIndex := 0;\r\n ABucket := nil;\r\n while ABucketIndex < FCapacity do\r\n begin\r\n ABucket := FBuckets[ABucketIndex];\r\n if (ABucket <> nil) and (ABucket.Size > 0) then\r\n Break;\r\n Inc(ABucketIndex);\r\n end;\r\n if ABucket <> nil then\r\n AItemIndex := 0\r\n else\r\n AItemIndex := -1;\r\n Result := TJclCardinalHashSetIterator.Create(Self, ABucketIndex, AItemIndex, False, isFirst);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\n{$IFDEF SUPPORTS_FOR_IN}\r\nfunction TJclCardinalHashSet.GetEnumerator: IJclCardinalIterator;\r\nbegin\r\n Result := First;\r\nend;\r\n{$ENDIF SUPPORTS_FOR_IN}\r\n\r\nprocedure TJclCardinalHashSet.Intersect(const ACollection: IJclCardinalCollection);\r\nbegin\r\n RetainAll(ACollection);\r\nend;\r\n\r\nfunction TJclCardinalHashSet.IsEmpty: Boolean;\r\nbegin\r\n Result := FSize = 0;\r\nend;\r\n\r\nfunction TJclCardinalHashSet.Last: IJclCardinalIterator;\r\nvar\r\n ABucketIndex, AItemIndex: Integer;\r\n ABucket: TJclCardinalHashSetBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n ABucketIndex := FCapacity - 1;\r\n ABucket := nil;\r\n while ABucketIndex >= 0 do\r\n begin\r\n ABucket := FBuckets[ABucketIndex];\r\n if (ABucket <> nil) and (ABucket.Size > 0) then\r\n Break;\r\n Dec(ABucketIndex);\r\n end;\r\n if ABucket <> nil then\r\n AItemIndex := ABucket.Size - 1\r\n else\r\n AItemIndex := -1;\r\n Result := TJclCardinalHashSetIterator.Create(Self, ABucketIndex, AItemIndex, False, isLast);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclCardinalHashSet.Pack;\r\nvar\r\n I: Integer;\r\n Bucket: TJclCardinalHashSetBucket;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n begin\r\n if Bucket.Size > 0 then\r\n SetLength(Bucket.Entries, Bucket.Size)\r\n else\r\n FreeAndNil(FBuckets[I]);\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclCardinalHashSet.Remove(AValue: Cardinal): Boolean;\r\nvar\r\n Extracted: Cardinal;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := Extract(AValue);\r\n if Result then\r\n begin\r\n Extracted := AValue;\r\n FreeCardinal(Extracted);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclCardinalHashSet.RemoveAll(const ACollection: IJclCardinalCollection): Boolean;\r\nvar\r\n It: IJclCardinalIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n Result := Remove(It.Next) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclCardinalHashSet.RetainAll(const ACollection: IJclCardinalCollection): Boolean;\r\nvar\r\n I, J, NewCapacity: Integer;\r\n Bucket: TJclCardinalHashSetBucket;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n begin\r\n for J := Bucket.Size - 1 downto 0 do\r\n if not ACollection.Contains(Bucket.Entries[I]) then\r\n begin\r\n Bucket.Entries[J] := FreeCardinal(Bucket.Entries[J]);\r\n if J < Length(Bucket.Entries) - 1 then\r\n MoveArray(Bucket.Entries, J + 1, J, Bucket.Size - J - 1);\r\n Dec(Bucket.Size);\r\n Dec(FSize);\r\n end;\r\n\r\n NewCapacity := CalcPackCapacity(Length(Bucket.Entries), Bucket.Size);\r\n if NewCapacity < Length(Bucket.Entries) then\r\n SetLength(Bucket.Entries, NewCapacity);\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclCardinalHashSet.SetCapacity(Value: Integer);\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FSize = 0 then\r\n begin\r\n SetLength(FBuckets, Value);\r\n inherited SetCapacity(Value);\r\n end\r\n else\r\n raise EJclOperationNotSupportedError.Create;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclCardinalHashSet.Size: Integer;\r\nbegin\r\n Result := FSize;\r\nend;\r\n\r\nprocedure TJclCardinalHashSet.Subtract(const ACollection: IJclCardinalCollection);\r\nbegin\r\n RemoveAll(ACollection);\r\nend;\r\n\r\nprocedure TJclCardinalHashSet.Union(const ACollection: IJclCardinalCollection);\r\nbegin\r\n AddAll(ACollection);\r\nend;\r\n\r\n\r\nfunction TJclCardinalHashSet.CreateEmptyContainer: TJclAbstractContainerBase;\r\nbegin\r\n Result := TJclCardinalHashSet.Create(Size);\r\n AssignPropertiesTo(Result);\r\nend;\r\n\r\n//=== { TJclCardinalHashSetIterator } ============================================\r\n\r\nconstructor TJclCardinalHashSetIterator.Create(AOwnHashSet: TJclCardinalHashSet;\r\n ABucketIndex, AItemIndex: Integer; AValid: Boolean; AStart: TItrStart);\r\nbegin\r\n inherited Create(AValid);\r\n FOwnHashSet := AOwnHashSet;\r\n FBucketIndex := ABucketIndex;\r\n FItemIndex := AItemIndex;\r\n FStart := AStart;\r\nend;\r\n\r\nfunction TJclCardinalHashSetIterator.Add(AValue: Cardinal): Boolean;\r\nbegin\r\n Result := FOwnHashSet.Add(AValue);\r\nend;\r\n\r\nprocedure TJclCardinalHashSetIterator.AssignPropertiesTo(Dest: TJclAbstractIterator);\r\nvar\r\n ADest: TJclCardinalHashSetIterator;\r\nbegin\r\n inherited AssignPropertiesTo(Dest);\r\n if Dest is TJclCardinalHashSetIterator then\r\n begin\r\n ADest := TJclCardinalHashSetIterator(Dest);\r\n ADest.FBucketIndex := FBucketIndex;\r\n ADest.FItemIndex := FItemIndex;\r\n ADest.FOwnHashSet := FOwnHashSet;\r\n ADest.FStart := FStart;\r\n end;\r\nend;\r\n\r\nfunction TJclCardinalHashSetIterator.CreateEmptyIterator: TJclAbstractIterator;\r\nbegin\r\n Result := TJclCardinalHashSetIterator.Create(FOwnHashSet, FBucketIndex, FItemIndex, Valid, FStart);\r\nend;\r\n\r\nprocedure TJclCardinalHashSetIterator.Extract;\r\nvar\r\n AValue: Cardinal;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnHashSet.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n CheckValid;\r\n AValue := GetValue;\r\n Valid := False;\r\n FOwnHashSet.Extract(AValue);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnHashSet.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclCardinalHashSetIterator.GetValue: Cardinal;\r\nvar\r\n ABucket: TJclCardinalHashSetBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnHashSet.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n CheckValid;\r\n Result := 0;\r\n ABucket := FOwnHashSet.FBuckets[FBucketIndex - 1];\r\n if (ABucket <> nil) and (FItemIndex < ABucket.Size) then\r\n Result := ABucket.Entries[FItemIndex]\r\n else\r\n if not FOwnHashSet.ReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnHashSet.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclCardinalHashSetIterator.HasNext: Boolean;\r\nvar\r\n ABucketIndex, AItemIndex: Integer;\r\n ABucket: TJclCardinalHashSetBucket;\r\n SkipCurrent: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnHashSet.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := True;\r\n ABucketIndex := FBucketIndex;\r\n AItemIndex := FItemIndex;\r\n SkipCurrent := Valid;\r\n while ABucketIndex < FOwnHashSet.FCapacity do\r\n begin\r\n ABucket := FOwnHashSet.FBuckets[ABucketIndex];\r\n if ABucket <> nil then\r\n begin\r\n if (AItemIndex < (ABucket.Size - 1)) or\r\n ((not SkipCurrent) and (AItemIndex < ABucket.Size)) then\r\n Exit;\r\n end;\r\n AItemIndex := 0;\r\n Inc(ABucketIndex);\r\n SkipCurrent := False;\r\n end;\r\n Result := False;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnHashSet.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclCardinalHashSetIterator.HasPrevious: Boolean;\r\nvar\r\n ABucketIndex, AItemIndex: Integer;\r\n ABucket: TJclCardinalHashSetBucket;\r\n SkipCurrent: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnHashSet.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := True;\r\n ABucketIndex := FBucketIndex;\r\n AItemIndex := FItemIndex;\r\n SkipCurrent := Valid;\r\n while ABucketIndex >= 0 do\r\n begin\r\n ABucket := FOwnHashSet.FBuckets[ABucketIndex];\r\n if ABucket <> nil then\r\n begin\r\n if (AItemIndex > 0) or\r\n ((not SkipCurrent) and (AItemIndex >= 0)) then\r\n Exit;\r\n end;\r\n AItemIndex := MaxInt;\r\n Dec(ABucketIndex);\r\n SkipCurrent := False;\r\n end;\r\n Result := False;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnHashSet.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclCardinalHashSetIterator.Insert(AValue: Cardinal): Boolean;\r\nbegin\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nfunction TJclCardinalHashSetIterator.IteratorEquals(const AIterator: IJclCardinalIterator): Boolean;\r\nvar\r\n Obj: TObject;\r\n ItrObj: TJclCardinalHashSetIterator;\r\nbegin\r\n Result := False;\r\n if AIterator = nil then\r\n Exit;\r\n Obj := AIterator.GetIteratorReference;\r\n if Obj is TJclCardinalHashSetIterator then\r\n begin\r\n ItrObj := TJclCardinalHashSetIterator(Obj);\r\n Result := (FOwnHashSet = ItrObj.FOwnHashSet) and (FBucketIndex = ItrObj.FBucketIndex) and (FItemIndex = ItrObj.FItemIndex) and (Valid = ItrObj.Valid);\r\n end;\r\nend;\r\n\r\n{$IFDEF SUPPORTS_FOR_IN}\r\nfunction TJclCardinalHashSetIterator.MoveNext: Boolean;\r\nvar\r\n ABucket: TJclCardinalHashSetBucket;\r\n SkipCurrent: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnHashSet.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Valid then\r\n begin\r\n SkipCurrent := True;\r\n while FBucketIndex < FOwnHashSet.FCapacity do\r\n begin\r\n ABucket := FOwnHashSet.FBuckets[FBucketIndex];\r\n if ABucket <> nil then\r\n begin\r\n if (not SkipCurrent) and (FItemIndex < ABucket.Size) then\r\n Break;\r\n if FItemIndex < (ABucket.Size - 1) then\r\n begin\r\n Inc(FItemIndex);\r\n Break;\r\n end;\r\n end;\r\n FItemIndex := 0;\r\n Inc(FBucketIndex);\r\n SkipCurrent := False;\r\n end;\r\n end\r\n else\r\n Valid := True;\r\n\r\n Result := (FBucketIndex >= 0) and (FItemIndex >= 0) and\r\n (FBucketIndex < FOwnHashSet.FCapacity);\r\n if Result then\r\n begin\r\n ABucket := FOwnHashSet.FBuckets[FBucketIndex];\r\n Result := (ABucket <> nil) and (FItemIndex < ABucket.Size);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnHashSet.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n{$ENDIF SUPPORTS_FOR_IN}\r\n\r\nfunction TJclCardinalHashSetIterator.Next: Cardinal;\r\nvar\r\n ABucket: TJclCardinalHashSetBucket;\r\n SkipCurrent: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnHashSet.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Valid then\r\n begin\r\n SkipCurrent := True;\r\n while FBucketIndex < FOwnHashSet.FCapacity do\r\n begin\r\n ABucket := FOwnHashSet.FBuckets[FBucketIndex];\r\n if ABucket <> nil then\r\n begin\r\n if (not SkipCurrent) and (FItemIndex < ABucket.Size) then\r\n Break;\r\n if FItemIndex < (ABucket.Size - 1) then\r\n begin\r\n Inc(FItemIndex);\r\n Break;\r\n end;\r\n end;\r\n FItemIndex := 0;\r\n Inc(FBucketIndex);\r\n SkipCurrent := False;\r\n end;\r\n end\r\n else\r\n Valid := True;\r\n\r\n Result := 0;\r\n if (FBucketIndex >= 0) and (FItemIndex >= 0) and\r\n (FBucketIndex < FOwnHashSet.FCapacity) then\r\n begin\r\n ABucket := FOwnHashSet.FBuckets[FBucketIndex];\r\n if (ABucket <> nil) and\r\n (FItemIndex < ABucket.Size) then\r\n Result := ABucket.Entries[FItemIndex]\r\n else\r\n if not FOwnHashSet.ReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n end\r\n else\r\n if not FOwnHashSet.ReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnHashSet.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclCardinalHashSetIterator.NextIndex: Integer;\r\nbegin\r\n // No index\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nfunction TJclCardinalHashSetIterator.Previous: Cardinal;\r\nvar\r\n ABucket: TJclCardinalHashSetBucket;\r\n SkipCurrent: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnHashSet.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Valid then\r\n begin\r\n SkipCurrent := True;\r\n while FBucketIndex >= 0 do\r\n begin\r\n ABucket := FOwnHashSet.FBuckets[FBucketIndex];\r\n if (ABucket <> nil) and (FItemIndex < 0) then\r\n FItemIndex := ABucket.Size - 1;\r\n if ABucket <> nil then\r\n begin\r\n if (not SkipCurrent) and (FItemIndex >= 0) and (FItemIndex < ABucket.Size) then\r\n Break;\r\n if (FItemIndex > 0) and (FItemIndex < ABucket.Size) then\r\n begin\r\n Dec(FItemIndex);\r\n Break;\r\n end;\r\n end;\r\n FItemIndex := -1;\r\n Dec(FBucketIndex);\r\n SkipCurrent := False;\r\n end;\r\n end\r\n else\r\n Valid := True;\r\n\r\n Result := 0;\r\n if (FBucketIndex >= 0) and (FItemIndex >= 0) and\r\n (FBucketIndex < FOwnHashSet.FCapacity) then\r\n begin\r\n ABucket := FOwnHashSet.FBuckets[FBucketIndex];\r\n if (ABucket <> nil) and\r\n (FItemIndex < ABucket.Size) then\r\n Result := ABucket.Entries[FItemIndex]\r\n else\r\n if not FOwnHashSet.ReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n end\r\n else\r\n if not FOwnHashSet.ReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnHashSet.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclCardinalHashSetIterator.PreviousIndex: Integer;\r\nbegin\r\n // No index\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nprocedure TJclCardinalHashSetIterator.Remove;\r\nbegin\r\n\r\nend;\r\n\r\nprocedure TJclCardinalHashSetIterator.Reset;\r\nvar\r\n ABucket: TJclCardinalHashSetBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnHashSet.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Valid := False;\r\n case FStart of\r\n isFirst:\r\n begin\r\n FBucketIndex := 0;\r\n ABucket := nil;\r\n while FBucketIndex < FOwnHashSet.FCapacity do\r\n begin\r\n ABucket := FOwnHashSet.FBuckets[FBucketIndex];\r\n if (ABucket <> nil) and (ABucket.Size > 0) then\r\n Break;\r\n Inc(FBucketIndex);\r\n end;\r\n if ABucket <> nil then\r\n FItemIndex := 0\r\n else\r\n FItemIndex := -1;\r\n end;\r\n isLast:\r\n begin\r\n FBucketIndex := FOwnHashSet.FCapacity - 1;\r\n ABucket := nil;\r\n while FBucketIndex >= 0 do\r\n begin\r\n ABucket := FOwnHashSet.FBuckets[FBucketIndex];\r\n if (ABucket <> nil) and (ABucket.Size > 0) then\r\n Break;\r\n Dec(FBucketIndex);\r\n end;\r\n if ABucket <> nil then\r\n FItemIndex := ABucket.Size - 1\r\n else\r\n FItemIndex := -1;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnHashSet.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclCardinalHashSetIterator.SetValue(AValue: Cardinal);\r\nbegin\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n//=== { TJclInt64HashSet } ====================================================\r\n\r\nconstructor TJclInt64HashSet.Create(ACapacity: Integer);\r\nbegin\r\n inherited Create();\r\n SetCapacity(ACapacity);\r\n FHashToRangeFunction := JclSimpleHashToRange;\r\nend;\r\n\r\ndestructor TJclInt64HashSet.Destroy;\r\nbegin\r\n FReadOnly := False;\r\n Clear;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJclInt64HashSet.Add(const AValue: Int64): Boolean;\r\nvar\r\n Index: Integer;\r\n Bucket: TJclInt64HashSetBucket;\r\n I: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if FAllowDefaultElements or (not ItemsEqual(AValue, 0)) then\r\n begin\r\n Index := FHashToRangeFunction(Hash(AValue), FCapacity);\r\n Bucket := FBuckets[Index];\r\n if Bucket <> nil then\r\n begin\r\n for I := 0 to Bucket.Size - 1 do\r\n if ItemsEqual(Bucket.Entries[I], AValue) then\r\n Exit;\r\n end\r\n else\r\n begin\r\n Bucket := TJclInt64HashSetBucket.Create;\r\n SetLength(Bucket.Entries, 1);\r\n FBuckets[Index] := Bucket;\r\n end;\r\n\r\n if Bucket.Size = Length(Bucket.Entries) then\r\n SetLength(Bucket.Entries, CalcGrowCapacity(Bucket.Size, Bucket.Size));\r\n\r\n if Bucket.Size < Length(Bucket.Entries) then\r\n begin\r\n Bucket.Entries[Bucket.Size] := AValue;\r\n Inc(Bucket.Size);\r\n Inc(FSize);\r\n Result := True;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclInt64HashSet.AddAll(const ACollection: IJclInt64Collection): Boolean;\r\nvar\r\n It: IJclInt64Iterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n Result := Add(It.Next) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclInt64HashSet.AssignDataTo(Dest: TJclAbstractContainerBase);\r\nvar\r\n I, J: Integer;\r\n SelfBucket, NewBucket: TJclInt64HashSetBucket;\r\n ADest: TJclInt64HashSet;\r\n ACollection: IJclInt64Collection;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n inherited AssignDataTo(Dest);\r\n if Dest is TJclInt64HashSet then\r\n begin\r\n ADest := TJclInt64HashSet(Dest);\r\n ADest.Clear;\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n SelfBucket := FBuckets[I];\r\n if SelfBucket <> nil then\r\n begin\r\n NewBucket := TJclInt64HashSetBucket.Create;\r\n SetLength(NewBucket.Entries, SelfBucket.Size);\r\n for J := 0 to SelfBucket.Size - 1 do\r\n NewBucket.Entries[J] := SelfBucket.Entries[J];\r\n NewBucket.Size := SelfBucket.Size;\r\n ADest.FBuckets[I] := NewBucket;\r\n end;\r\n end;\r\n end\r\n else\r\n if Supports(IInterface(Dest), IJclInt64Collection, ACollection) then\r\n begin\r\n ACollection.Clear;\r\n ACollection.AddAll(Self);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclInt64HashSet.AssignPropertiesTo(Dest: TJclAbstractContainerBase);\r\nbegin\r\n inherited AssignPropertiesto(Dest);\r\n if Dest is TJclInt64HashSet then\r\n TJclInt64HashSet(Dest).FHashToRangeFunction := FHashToRangeFunction;\r\nend;\r\n\r\nprocedure TJclInt64HashSet.Clear;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclInt64HashSetBucket;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n begin\r\n for J := 0 to Bucket.Size - 1 do\r\n FreeInt64(Bucket.Entries[J]);\r\n FreeAndNil(FBuckets[I]);\r\n end;\r\n end;\r\n FSize := 0;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclInt64HashSet.CollectionEquals(const ACollection: IJclInt64Collection): Boolean;\r\nvar\r\n I, J: Integer;\r\n It: IJclInt64Iterator;\r\n Bucket: TJclInt64HashSetBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n if FSize <> ACollection.Size then\r\n Exit;\r\n It := ACollection.First;\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n for J := 0 to Bucket.Size - 1 do\r\n if not ItemsEqual(Bucket.Entries[J], It.Next) then\r\n Exit;\r\n end;\r\n Result := True;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclInt64HashSet.Contains(const AValue: Int64): Boolean;\r\nvar\r\n I: Integer;\r\n Bucket: TJclInt64HashSetBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n Bucket := FBuckets[FHashToRangeFunction(Hash(AValue), FCapacity)];\r\n if Bucket <> nil then\r\n for I := 0 to Bucket.Size - 1 do\r\n if ItemsEqual(Bucket.Entries[I], AValue) then\r\n begin\r\n Result := True;\r\n Break;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclInt64HashSet.ContainsAll(const ACollection: IJclInt64Collection): Boolean;\r\nvar\r\n It: IJclInt64Iterator;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := True;\r\n if ACollection = nil then\r\n Exit;\r\n It := ACollection.First;\r\n while Result and It.HasNext do\r\n Result := Contains(It.Next);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclInt64HashSet.Extract(const AValue: Int64): Boolean;\r\nvar\r\n Bucket: TJclInt64HashSetBucket;\r\n I, NewCapacity: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n Bucket := FBuckets[FHashToRangeFunction(Hash(AValue), FCapacity)];\r\n if Bucket <> nil then\r\n begin\r\n for I := 0 to Bucket.Size - 1 do\r\n if ItemsEqual(Bucket.Entries[I], AValue) then\r\n begin\r\n Result := True;\r\n Bucket.Entries[I] := 0;\r\n if I < Length(Bucket.Entries) - 1 then\r\n MoveArray(Bucket.Entries, I + 1, I, Bucket.Size - I - 1);\r\n Dec(Bucket.Size);\r\n Dec(FSize);\r\n Break;\r\n end;\r\n\r\n NewCapacity := CalcPackCapacity(Length(Bucket.Entries), Bucket.Size);\r\n if NewCapacity < Length(Bucket.Entries) then\r\n SetLength(Bucket.Entries, NewCapacity);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclInt64HashSet.ExtractAll(const ACollection: IJclInt64Collection): Boolean;\r\nvar\r\n It: IJclInt64Iterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n Result := Extract(It.Next) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclInt64HashSet.First: IJclInt64Iterator;\r\nvar\r\n ABucketIndex, AItemIndex: Integer;\r\n ABucket: TJclInt64HashSetBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n ABucketIndex := 0;\r\n ABucket := nil;\r\n while ABucketIndex < FCapacity do\r\n begin\r\n ABucket := FBuckets[ABucketIndex];\r\n if (ABucket <> nil) and (ABucket.Size > 0) then\r\n Break;\r\n Inc(ABucketIndex);\r\n end;\r\n if ABucket <> nil then\r\n AItemIndex := 0\r\n else\r\n AItemIndex := -1;\r\n Result := TJclInt64HashSetIterator.Create(Self, ABucketIndex, AItemIndex, False, isFirst);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\n{$IFDEF SUPPORTS_FOR_IN}\r\nfunction TJclInt64HashSet.GetEnumerator: IJclInt64Iterator;\r\nbegin\r\n Result := First;\r\nend;\r\n{$ENDIF SUPPORTS_FOR_IN}\r\n\r\nprocedure TJclInt64HashSet.Intersect(const ACollection: IJclInt64Collection);\r\nbegin\r\n RetainAll(ACollection);\r\nend;\r\n\r\nfunction TJclInt64HashSet.IsEmpty: Boolean;\r\nbegin\r\n Result := FSize = 0;\r\nend;\r\n\r\nfunction TJclInt64HashSet.Last: IJclInt64Iterator;\r\nvar\r\n ABucketIndex, AItemIndex: Integer;\r\n ABucket: TJclInt64HashSetBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n ABucketIndex := FCapacity - 1;\r\n ABucket := nil;\r\n while ABucketIndex >= 0 do\r\n begin\r\n ABucket := FBuckets[ABucketIndex];\r\n if (ABucket <> nil) and (ABucket.Size > 0) then\r\n Break;\r\n Dec(ABucketIndex);\r\n end;\r\n if ABucket <> nil then\r\n AItemIndex := ABucket.Size - 1\r\n else\r\n AItemIndex := -1;\r\n Result := TJclInt64HashSetIterator.Create(Self, ABucketIndex, AItemIndex, False, isLast);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclInt64HashSet.Pack;\r\nvar\r\n I: Integer;\r\n Bucket: TJclInt64HashSetBucket;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n begin\r\n if Bucket.Size > 0 then\r\n SetLength(Bucket.Entries, Bucket.Size)\r\n else\r\n FreeAndNil(FBuckets[I]);\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclInt64HashSet.Remove(const AValue: Int64): Boolean;\r\nvar\r\n Extracted: Int64;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := Extract(AValue);\r\n if Result then\r\n begin\r\n Extracted := AValue;\r\n FreeInt64(Extracted);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclInt64HashSet.RemoveAll(const ACollection: IJclInt64Collection): Boolean;\r\nvar\r\n It: IJclInt64Iterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n Result := Remove(It.Next) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclInt64HashSet.RetainAll(const ACollection: IJclInt64Collection): Boolean;\r\nvar\r\n I, J, NewCapacity: Integer;\r\n Bucket: TJclInt64HashSetBucket;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n begin\r\n for J := Bucket.Size - 1 downto 0 do\r\n if not ACollection.Contains(Bucket.Entries[I]) then\r\n begin\r\n Bucket.Entries[J] := FreeInt64(Bucket.Entries[J]);\r\n if J < Length(Bucket.Entries) - 1 then\r\n MoveArray(Bucket.Entries, J + 1, J, Bucket.Size - J - 1);\r\n Dec(Bucket.Size);\r\n Dec(FSize);\r\n end;\r\n\r\n NewCapacity := CalcPackCapacity(Length(Bucket.Entries), Bucket.Size);\r\n if NewCapacity < Length(Bucket.Entries) then\r\n SetLength(Bucket.Entries, NewCapacity);\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclInt64HashSet.SetCapacity(Value: Integer);\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FSize = 0 then\r\n begin\r\n SetLength(FBuckets, Value);\r\n inherited SetCapacity(Value);\r\n end\r\n else\r\n raise EJclOperationNotSupportedError.Create;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclInt64HashSet.Size: Integer;\r\nbegin\r\n Result := FSize;\r\nend;\r\n\r\nprocedure TJclInt64HashSet.Subtract(const ACollection: IJclInt64Collection);\r\nbegin\r\n RemoveAll(ACollection);\r\nend;\r\n\r\nprocedure TJclInt64HashSet.Union(const ACollection: IJclInt64Collection);\r\nbegin\r\n AddAll(ACollection);\r\nend;\r\n\r\n\r\nfunction TJclInt64HashSet.CreateEmptyContainer: TJclAbstractContainerBase;\r\nbegin\r\n Result := TJclInt64HashSet.Create(Size);\r\n AssignPropertiesTo(Result);\r\nend;\r\n\r\n//=== { TJclInt64HashSetIterator } ============================================\r\n\r\nconstructor TJclInt64HashSetIterator.Create(AOwnHashSet: TJclInt64HashSet;\r\n ABucketIndex, AItemIndex: Integer; AValid: Boolean; AStart: TItrStart);\r\nbegin\r\n inherited Create(AValid);\r\n FOwnHashSet := AOwnHashSet;\r\n FBucketIndex := ABucketIndex;\r\n FItemIndex := AItemIndex;\r\n FStart := AStart;\r\nend;\r\n\r\nfunction TJclInt64HashSetIterator.Add(const AValue: Int64): Boolean;\r\nbegin\r\n Result := FOwnHashSet.Add(AValue);\r\nend;\r\n\r\nprocedure TJclInt64HashSetIterator.AssignPropertiesTo(Dest: TJclAbstractIterator);\r\nvar\r\n ADest: TJclInt64HashSetIterator;\r\nbegin\r\n inherited AssignPropertiesTo(Dest);\r\n if Dest is TJclInt64HashSetIterator then\r\n begin\r\n ADest := TJclInt64HashSetIterator(Dest);\r\n ADest.FBucketIndex := FBucketIndex;\r\n ADest.FItemIndex := FItemIndex;\r\n ADest.FOwnHashSet := FOwnHashSet;\r\n ADest.FStart := FStart;\r\n end;\r\nend;\r\n\r\nfunction TJclInt64HashSetIterator.CreateEmptyIterator: TJclAbstractIterator;\r\nbegin\r\n Result := TJclInt64HashSetIterator.Create(FOwnHashSet, FBucketIndex, FItemIndex, Valid, FStart);\r\nend;\r\n\r\nprocedure TJclInt64HashSetIterator.Extract;\r\nvar\r\n AValue: Int64;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnHashSet.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n CheckValid;\r\n AValue := GetValue;\r\n Valid := False;\r\n FOwnHashSet.Extract(AValue);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnHashSet.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclInt64HashSetIterator.GetValue: Int64;\r\nvar\r\n ABucket: TJclInt64HashSetBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnHashSet.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n CheckValid;\r\n Result := 0;\r\n ABucket := FOwnHashSet.FBuckets[FBucketIndex - 1];\r\n if (ABucket <> nil) and (FItemIndex < ABucket.Size) then\r\n Result := ABucket.Entries[FItemIndex]\r\n else\r\n if not FOwnHashSet.ReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnHashSet.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclInt64HashSetIterator.HasNext: Boolean;\r\nvar\r\n ABucketIndex, AItemIndex: Integer;\r\n ABucket: TJclInt64HashSetBucket;\r\n SkipCurrent: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnHashSet.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := True;\r\n ABucketIndex := FBucketIndex;\r\n AItemIndex := FItemIndex;\r\n SkipCurrent := Valid;\r\n while ABucketIndex < FOwnHashSet.FCapacity do\r\n begin\r\n ABucket := FOwnHashSet.FBuckets[ABucketIndex];\r\n if ABucket <> nil then\r\n begin\r\n if (AItemIndex < (ABucket.Size - 1)) or\r\n ((not SkipCurrent) and (AItemIndex < ABucket.Size)) then\r\n Exit;\r\n end;\r\n AItemIndex := 0;\r\n Inc(ABucketIndex);\r\n SkipCurrent := False;\r\n end;\r\n Result := False;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnHashSet.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclInt64HashSetIterator.HasPrevious: Boolean;\r\nvar\r\n ABucketIndex, AItemIndex: Integer;\r\n ABucket: TJclInt64HashSetBucket;\r\n SkipCurrent: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnHashSet.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := True;\r\n ABucketIndex := FBucketIndex;\r\n AItemIndex := FItemIndex;\r\n SkipCurrent := Valid;\r\n while ABucketIndex >= 0 do\r\n begin\r\n ABucket := FOwnHashSet.FBuckets[ABucketIndex];\r\n if ABucket <> nil then\r\n begin\r\n if (AItemIndex > 0) or\r\n ((not SkipCurrent) and (AItemIndex >= 0)) then\r\n Exit;\r\n end;\r\n AItemIndex := MaxInt;\r\n Dec(ABucketIndex);\r\n SkipCurrent := False;\r\n end;\r\n Result := False;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnHashSet.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclInt64HashSetIterator.Insert(const AValue: Int64): Boolean;\r\nbegin\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nfunction TJclInt64HashSetIterator.IteratorEquals(const AIterator: IJclInt64Iterator): Boolean;\r\nvar\r\n Obj: TObject;\r\n ItrObj: TJclInt64HashSetIterator;\r\nbegin\r\n Result := False;\r\n if AIterator = nil then\r\n Exit;\r\n Obj := AIterator.GetIteratorReference;\r\n if Obj is TJclInt64HashSetIterator then\r\n begin\r\n ItrObj := TJclInt64HashSetIterator(Obj);\r\n Result := (FOwnHashSet = ItrObj.FOwnHashSet) and (FBucketIndex = ItrObj.FBucketIndex) and (FItemIndex = ItrObj.FItemIndex) and (Valid = ItrObj.Valid);\r\n end;\r\nend;\r\n\r\n{$IFDEF SUPPORTS_FOR_IN}\r\nfunction TJclInt64HashSetIterator.MoveNext: Boolean;\r\nvar\r\n ABucket: TJclInt64HashSetBucket;\r\n SkipCurrent: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnHashSet.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Valid then\r\n begin\r\n SkipCurrent := True;\r\n while FBucketIndex < FOwnHashSet.FCapacity do\r\n begin\r\n ABucket := FOwnHashSet.FBuckets[FBucketIndex];\r\n if ABucket <> nil then\r\n begin\r\n if (not SkipCurrent) and (FItemIndex < ABucket.Size) then\r\n Break;\r\n if FItemIndex < (ABucket.Size - 1) then\r\n begin\r\n Inc(FItemIndex);\r\n Break;\r\n end;\r\n end;\r\n FItemIndex := 0;\r\n Inc(FBucketIndex);\r\n SkipCurrent := False;\r\n end;\r\n end\r\n else\r\n Valid := True;\r\n\r\n Result := (FBucketIndex >= 0) and (FItemIndex >= 0) and\r\n (FBucketIndex < FOwnHashSet.FCapacity);\r\n if Result then\r\n begin\r\n ABucket := FOwnHashSet.FBuckets[FBucketIndex];\r\n Result := (ABucket <> nil) and (FItemIndex < ABucket.Size);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnHashSet.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n{$ENDIF SUPPORTS_FOR_IN}\r\n\r\nfunction TJclInt64HashSetIterator.Next: Int64;\r\nvar\r\n ABucket: TJclInt64HashSetBucket;\r\n SkipCurrent: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnHashSet.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Valid then\r\n begin\r\n SkipCurrent := True;\r\n while FBucketIndex < FOwnHashSet.FCapacity do\r\n begin\r\n ABucket := FOwnHashSet.FBuckets[FBucketIndex];\r\n if ABucket <> nil then\r\n begin\r\n if (not SkipCurrent) and (FItemIndex < ABucket.Size) then\r\n Break;\r\n if FItemIndex < (ABucket.Size - 1) then\r\n begin\r\n Inc(FItemIndex);\r\n Break;\r\n end;\r\n end;\r\n FItemIndex := 0;\r\n Inc(FBucketIndex);\r\n SkipCurrent := False;\r\n end;\r\n end\r\n else\r\n Valid := True;\r\n\r\n Result := 0;\r\n if (FBucketIndex >= 0) and (FItemIndex >= 0) and\r\n (FBucketIndex < FOwnHashSet.FCapacity) then\r\n begin\r\n ABucket := FOwnHashSet.FBuckets[FBucketIndex];\r\n if (ABucket <> nil) and\r\n (FItemIndex < ABucket.Size) then\r\n Result := ABucket.Entries[FItemIndex]\r\n else\r\n if not FOwnHashSet.ReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n end\r\n else\r\n if not FOwnHashSet.ReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnHashSet.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclInt64HashSetIterator.NextIndex: Integer;\r\nbegin\r\n // No index\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nfunction TJclInt64HashSetIterator.Previous: Int64;\r\nvar\r\n ABucket: TJclInt64HashSetBucket;\r\n SkipCurrent: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnHashSet.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Valid then\r\n begin\r\n SkipCurrent := True;\r\n while FBucketIndex >= 0 do\r\n begin\r\n ABucket := FOwnHashSet.FBuckets[FBucketIndex];\r\n if (ABucket <> nil) and (FItemIndex < 0) then\r\n FItemIndex := ABucket.Size - 1;\r\n if ABucket <> nil then\r\n begin\r\n if (not SkipCurrent) and (FItemIndex >= 0) and (FItemIndex < ABucket.Size) then\r\n Break;\r\n if (FItemIndex > 0) and (FItemIndex < ABucket.Size) then\r\n begin\r\n Dec(FItemIndex);\r\n Break;\r\n end;\r\n end;\r\n FItemIndex := -1;\r\n Dec(FBucketIndex);\r\n SkipCurrent := False;\r\n end;\r\n end\r\n else\r\n Valid := True;\r\n\r\n Result := 0;\r\n if (FBucketIndex >= 0) and (FItemIndex >= 0) and\r\n (FBucketIndex < FOwnHashSet.FCapacity) then\r\n begin\r\n ABucket := FOwnHashSet.FBuckets[FBucketIndex];\r\n if (ABucket <> nil) and\r\n (FItemIndex < ABucket.Size) then\r\n Result := ABucket.Entries[FItemIndex]\r\n else\r\n if not FOwnHashSet.ReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n end\r\n else\r\n if not FOwnHashSet.ReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnHashSet.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclInt64HashSetIterator.PreviousIndex: Integer;\r\nbegin\r\n // No index\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nprocedure TJclInt64HashSetIterator.Remove;\r\nbegin\r\n\r\nend;\r\n\r\nprocedure TJclInt64HashSetIterator.Reset;\r\nvar\r\n ABucket: TJclInt64HashSetBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnHashSet.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Valid := False;\r\n case FStart of\r\n isFirst:\r\n begin\r\n FBucketIndex := 0;\r\n ABucket := nil;\r\n while FBucketIndex < FOwnHashSet.FCapacity do\r\n begin\r\n ABucket := FOwnHashSet.FBuckets[FBucketIndex];\r\n if (ABucket <> nil) and (ABucket.Size > 0) then\r\n Break;\r\n Inc(FBucketIndex);\r\n end;\r\n if ABucket <> nil then\r\n FItemIndex := 0\r\n else\r\n FItemIndex := -1;\r\n end;\r\n isLast:\r\n begin\r\n FBucketIndex := FOwnHashSet.FCapacity - 1;\r\n ABucket := nil;\r\n while FBucketIndex >= 0 do\r\n begin\r\n ABucket := FOwnHashSet.FBuckets[FBucketIndex];\r\n if (ABucket <> nil) and (ABucket.Size > 0) then\r\n Break;\r\n Dec(FBucketIndex);\r\n end;\r\n if ABucket <> nil then\r\n FItemIndex := ABucket.Size - 1\r\n else\r\n FItemIndex := -1;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnHashSet.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclInt64HashSetIterator.SetValue(const AValue: Int64);\r\nbegin\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n//=== { TJclPtrHashSet } ====================================================\r\n\r\nconstructor TJclPtrHashSet.Create(ACapacity: Integer);\r\nbegin\r\n inherited Create();\r\n SetCapacity(ACapacity);\r\n FHashToRangeFunction := JclSimpleHashToRange;\r\nend;\r\n\r\ndestructor TJclPtrHashSet.Destroy;\r\nbegin\r\n FReadOnly := False;\r\n Clear;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJclPtrHashSet.Add(APtr: Pointer): Boolean;\r\nvar\r\n Index: Integer;\r\n Bucket: TJclPtrHashSetBucket;\r\n I: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if FAllowDefaultElements or (not ItemsEqual(APtr, nil)) then\r\n begin\r\n Index := FHashToRangeFunction(Hash(APtr), FCapacity);\r\n Bucket := FBuckets[Index];\r\n if Bucket <> nil then\r\n begin\r\n for I := 0 to Bucket.Size - 1 do\r\n if ItemsEqual(Bucket.Entries[I], APtr) then\r\n Exit;\r\n end\r\n else\r\n begin\r\n Bucket := TJclPtrHashSetBucket.Create;\r\n SetLength(Bucket.Entries, 1);\r\n FBuckets[Index] := Bucket;\r\n end;\r\n\r\n if Bucket.Size = Length(Bucket.Entries) then\r\n SetLength(Bucket.Entries, CalcGrowCapacity(Bucket.Size, Bucket.Size));\r\n\r\n if Bucket.Size < Length(Bucket.Entries) then\r\n begin\r\n Bucket.Entries[Bucket.Size] := APtr;\r\n Inc(Bucket.Size);\r\n Inc(FSize);\r\n Result := True;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclPtrHashSet.AddAll(const ACollection: IJclPtrCollection): Boolean;\r\nvar\r\n It: IJclPtrIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n Result := Add(It.Next) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclPtrHashSet.AssignDataTo(Dest: TJclAbstractContainerBase);\r\nvar\r\n I, J: Integer;\r\n SelfBucket, NewBucket: TJclPtrHashSetBucket;\r\n ADest: TJclPtrHashSet;\r\n ACollection: IJclPtrCollection;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n inherited AssignDataTo(Dest);\r\n if Dest is TJclPtrHashSet then\r\n begin\r\n ADest := TJclPtrHashSet(Dest);\r\n ADest.Clear;\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n SelfBucket := FBuckets[I];\r\n if SelfBucket <> nil then\r\n begin\r\n NewBucket := TJclPtrHashSetBucket.Create;\r\n SetLength(NewBucket.Entries, SelfBucket.Size);\r\n for J := 0 to SelfBucket.Size - 1 do\r\n NewBucket.Entries[J] := SelfBucket.Entries[J];\r\n NewBucket.Size := SelfBucket.Size;\r\n ADest.FBuckets[I] := NewBucket;\r\n end;\r\n end;\r\n end\r\n else\r\n if Supports(IInterface(Dest), IJclPtrCollection, ACollection) then\r\n begin\r\n ACollection.Clear;\r\n ACollection.AddAll(Self);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclPtrHashSet.AssignPropertiesTo(Dest: TJclAbstractContainerBase);\r\nbegin\r\n inherited AssignPropertiesto(Dest);\r\n if Dest is TJclPtrHashSet then\r\n TJclPtrHashSet(Dest).FHashToRangeFunction := FHashToRangeFunction;\r\nend;\r\n\r\nprocedure TJclPtrHashSet.Clear;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclPtrHashSetBucket;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n begin\r\n for J := 0 to Bucket.Size - 1 do\r\n FreePointer(Bucket.Entries[J]);\r\n FreeAndNil(FBuckets[I]);\r\n end;\r\n end;\r\n FSize := 0;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclPtrHashSet.CollectionEquals(const ACollection: IJclPtrCollection): Boolean;\r\nvar\r\n I, J: Integer;\r\n It: IJclPtrIterator;\r\n Bucket: TJclPtrHashSetBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n if FSize <> ACollection.Size then\r\n Exit;\r\n It := ACollection.First;\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n for J := 0 to Bucket.Size - 1 do\r\n if not ItemsEqual(Bucket.Entries[J], It.Next) then\r\n Exit;\r\n end;\r\n Result := True;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclPtrHashSet.Contains(APtr: Pointer): Boolean;\r\nvar\r\n I: Integer;\r\n Bucket: TJclPtrHashSetBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n Bucket := FBuckets[FHashToRangeFunction(Hash(APtr), FCapacity)];\r\n if Bucket <> nil then\r\n for I := 0 to Bucket.Size - 1 do\r\n if ItemsEqual(Bucket.Entries[I], APtr) then\r\n begin\r\n Result := True;\r\n Break;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclPtrHashSet.ContainsAll(const ACollection: IJclPtrCollection): Boolean;\r\nvar\r\n It: IJclPtrIterator;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := True;\r\n if ACollection = nil then\r\n Exit;\r\n It := ACollection.First;\r\n while Result and It.HasNext do\r\n Result := Contains(It.Next);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclPtrHashSet.Extract(APtr: Pointer): Boolean;\r\nvar\r\n Bucket: TJclPtrHashSetBucket;\r\n I, NewCapacity: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n Bucket := FBuckets[FHashToRangeFunction(Hash(APtr), FCapacity)];\r\n if Bucket <> nil then\r\n begin\r\n for I := 0 to Bucket.Size - 1 do\r\n if ItemsEqual(Bucket.Entries[I], APtr) then\r\n begin\r\n Result := True;\r\n Bucket.Entries[I] := nil;\r\n if I < Length(Bucket.Entries) - 1 then\r\n MoveArray(Bucket.Entries, I + 1, I, Bucket.Size - I - 1);\r\n Dec(Bucket.Size);\r\n Dec(FSize);\r\n Break;\r\n end;\r\n\r\n NewCapacity := CalcPackCapacity(Length(Bucket.Entries), Bucket.Size);\r\n if NewCapacity < Length(Bucket.Entries) then\r\n SetLength(Bucket.Entries, NewCapacity);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclPtrHashSet.ExtractAll(const ACollection: IJclPtrCollection): Boolean;\r\nvar\r\n It: IJclPtrIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n Result := Extract(It.Next) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclPtrHashSet.First: IJclPtrIterator;\r\nvar\r\n ABucketIndex, AItemIndex: Integer;\r\n ABucket: TJclPtrHashSetBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n ABucketIndex := 0;\r\n ABucket := nil;\r\n while ABucketIndex < FCapacity do\r\n begin\r\n ABucket := FBuckets[ABucketIndex];\r\n if (ABucket <> nil) and (ABucket.Size > 0) then\r\n Break;\r\n Inc(ABucketIndex);\r\n end;\r\n if ABucket <> nil then\r\n AItemIndex := 0\r\n else\r\n AItemIndex := -1;\r\n Result := TJclPtrHashSetIterator.Create(Self, ABucketIndex, AItemIndex, False, isFirst);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\n{$IFDEF SUPPORTS_FOR_IN}\r\nfunction TJclPtrHashSet.GetEnumerator: IJclPtrIterator;\r\nbegin\r\n Result := First;\r\nend;\r\n{$ENDIF SUPPORTS_FOR_IN}\r\n\r\nprocedure TJclPtrHashSet.Intersect(const ACollection: IJclPtrCollection);\r\nbegin\r\n RetainAll(ACollection);\r\nend;\r\n\r\nfunction TJclPtrHashSet.IsEmpty: Boolean;\r\nbegin\r\n Result := FSize = 0;\r\nend;\r\n\r\nfunction TJclPtrHashSet.Last: IJclPtrIterator;\r\nvar\r\n ABucketIndex, AItemIndex: Integer;\r\n ABucket: TJclPtrHashSetBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n ABucketIndex := FCapacity - 1;\r\n ABucket := nil;\r\n while ABucketIndex >= 0 do\r\n begin\r\n ABucket := FBuckets[ABucketIndex];\r\n if (ABucket <> nil) and (ABucket.Size > 0) then\r\n Break;\r\n Dec(ABucketIndex);\r\n end;\r\n if ABucket <> nil then\r\n AItemIndex := ABucket.Size - 1\r\n else\r\n AItemIndex := -1;\r\n Result := TJclPtrHashSetIterator.Create(Self, ABucketIndex, AItemIndex, False, isLast);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclPtrHashSet.Pack;\r\nvar\r\n I: Integer;\r\n Bucket: TJclPtrHashSetBucket;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n begin\r\n if Bucket.Size > 0 then\r\n SetLength(Bucket.Entries, Bucket.Size)\r\n else\r\n FreeAndNil(FBuckets[I]);\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclPtrHashSet.Remove(APtr: Pointer): Boolean;\r\nvar\r\n Extracted: Pointer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := Extract(APtr);\r\n if Result then\r\n begin\r\n Extracted := APtr;\r\n FreePointer(Extracted);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclPtrHashSet.RemoveAll(const ACollection: IJclPtrCollection): Boolean;\r\nvar\r\n It: IJclPtrIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n Result := Remove(It.Next) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclPtrHashSet.RetainAll(const ACollection: IJclPtrCollection): Boolean;\r\nvar\r\n I, J, NewCapacity: Integer;\r\n Bucket: TJclPtrHashSetBucket;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n begin\r\n for J := Bucket.Size - 1 downto 0 do\r\n if not ACollection.Contains(Bucket.Entries[I]) then\r\n begin\r\n Bucket.Entries[J] := FreePointer(Bucket.Entries[J]);\r\n if J < Length(Bucket.Entries) - 1 then\r\n MoveArray(Bucket.Entries, J + 1, J, Bucket.Size - J - 1);\r\n Dec(Bucket.Size);\r\n Dec(FSize);\r\n end;\r\n\r\n NewCapacity := CalcPackCapacity(Length(Bucket.Entries), Bucket.Size);\r\n if NewCapacity < Length(Bucket.Entries) then\r\n SetLength(Bucket.Entries, NewCapacity);\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclPtrHashSet.SetCapacity(Value: Integer);\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FSize = 0 then\r\n begin\r\n SetLength(FBuckets, Value);\r\n inherited SetCapacity(Value);\r\n end\r\n else\r\n raise EJclOperationNotSupportedError.Create;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclPtrHashSet.Size: Integer;\r\nbegin\r\n Result := FSize;\r\nend;\r\n\r\nprocedure TJclPtrHashSet.Subtract(const ACollection: IJclPtrCollection);\r\nbegin\r\n RemoveAll(ACollection);\r\nend;\r\n\r\nprocedure TJclPtrHashSet.Union(const ACollection: IJclPtrCollection);\r\nbegin\r\n AddAll(ACollection);\r\nend;\r\n\r\n\r\nfunction TJclPtrHashSet.CreateEmptyContainer: TJclAbstractContainerBase;\r\nbegin\r\n Result := TJclPtrHashSet.Create(Size);\r\n AssignPropertiesTo(Result);\r\nend;\r\n\r\n//=== { TJclPtrHashSetIterator } ============================================\r\n\r\nconstructor TJclPtrHashSetIterator.Create(AOwnHashSet: TJclPtrHashSet;\r\n ABucketIndex, AItemIndex: Integer; AValid: Boolean; AStart: TItrStart);\r\nbegin\r\n inherited Create(AValid);\r\n FOwnHashSet := AOwnHashSet;\r\n FBucketIndex := ABucketIndex;\r\n FItemIndex := AItemIndex;\r\n FStart := AStart;\r\nend;\r\n\r\nfunction TJclPtrHashSetIterator.Add(APtr: Pointer): Boolean;\r\nbegin\r\n Result := FOwnHashSet.Add(APtr);\r\nend;\r\n\r\nprocedure TJclPtrHashSetIterator.AssignPropertiesTo(Dest: TJclAbstractIterator);\r\nvar\r\n ADest: TJclPtrHashSetIterator;\r\nbegin\r\n inherited AssignPropertiesTo(Dest);\r\n if Dest is TJclPtrHashSetIterator then\r\n begin\r\n ADest := TJclPtrHashSetIterator(Dest);\r\n ADest.FBucketIndex := FBucketIndex;\r\n ADest.FItemIndex := FItemIndex;\r\n ADest.FOwnHashSet := FOwnHashSet;\r\n ADest.FStart := FStart;\r\n end;\r\nend;\r\n\r\nfunction TJclPtrHashSetIterator.CreateEmptyIterator: TJclAbstractIterator;\r\nbegin\r\n Result := TJclPtrHashSetIterator.Create(FOwnHashSet, FBucketIndex, FItemIndex, Valid, FStart);\r\nend;\r\n\r\nprocedure TJclPtrHashSetIterator.Extract;\r\nvar\r\n APtr: Pointer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnHashSet.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n CheckValid;\r\n APtr := GetPointer;\r\n Valid := False;\r\n FOwnHashSet.Extract(APtr);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnHashSet.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclPtrHashSetIterator.GetPointer: Pointer;\r\nvar\r\n ABucket: TJclPtrHashSetBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnHashSet.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n CheckValid;\r\n Result := nil;\r\n ABucket := FOwnHashSet.FBuckets[FBucketIndex - 1];\r\n if (ABucket <> nil) and (FItemIndex < ABucket.Size) then\r\n Result := ABucket.Entries[FItemIndex]\r\n else\r\n if not FOwnHashSet.ReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnHashSet.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclPtrHashSetIterator.HasNext: Boolean;\r\nvar\r\n ABucketIndex, AItemIndex: Integer;\r\n ABucket: TJclPtrHashSetBucket;\r\n SkipCurrent: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnHashSet.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := True;\r\n ABucketIndex := FBucketIndex;\r\n AItemIndex := FItemIndex;\r\n SkipCurrent := Valid;\r\n while ABucketIndex < FOwnHashSet.FCapacity do\r\n begin\r\n ABucket := FOwnHashSet.FBuckets[ABucketIndex];\r\n if ABucket <> nil then\r\n begin\r\n if (AItemIndex < (ABucket.Size - 1)) or\r\n ((not SkipCurrent) and (AItemIndex < ABucket.Size)) then\r\n Exit;\r\n end;\r\n AItemIndex := 0;\r\n Inc(ABucketIndex);\r\n SkipCurrent := False;\r\n end;\r\n Result := False;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnHashSet.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclPtrHashSetIterator.HasPrevious: Boolean;\r\nvar\r\n ABucketIndex, AItemIndex: Integer;\r\n ABucket: TJclPtrHashSetBucket;\r\n SkipCurrent: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnHashSet.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := True;\r\n ABucketIndex := FBucketIndex;\r\n AItemIndex := FItemIndex;\r\n SkipCurrent := Valid;\r\n while ABucketIndex >= 0 do\r\n begin\r\n ABucket := FOwnHashSet.FBuckets[ABucketIndex];\r\n if ABucket <> nil then\r\n begin\r\n if (AItemIndex > 0) or\r\n ((not SkipCurrent) and (AItemIndex >= 0)) then\r\n Exit;\r\n end;\r\n AItemIndex := MaxInt;\r\n Dec(ABucketIndex);\r\n SkipCurrent := False;\r\n end;\r\n Result := False;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnHashSet.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclPtrHashSetIterator.Insert(APtr: Pointer): Boolean;\r\nbegin\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nfunction TJclPtrHashSetIterator.IteratorEquals(const AIterator: IJclPtrIterator): Boolean;\r\nvar\r\n Obj: TObject;\r\n ItrObj: TJclPtrHashSetIterator;\r\nbegin\r\n Result := False;\r\n if AIterator = nil then\r\n Exit;\r\n Obj := AIterator.GetIteratorReference;\r\n if Obj is TJclPtrHashSetIterator then\r\n begin\r\n ItrObj := TJclPtrHashSetIterator(Obj);\r\n Result := (FOwnHashSet = ItrObj.FOwnHashSet) and (FBucketIndex = ItrObj.FBucketIndex) and (FItemIndex = ItrObj.FItemIndex) and (Valid = ItrObj.Valid);\r\n end;\r\nend;\r\n\r\n{$IFDEF SUPPORTS_FOR_IN}\r\nfunction TJclPtrHashSetIterator.MoveNext: Boolean;\r\nvar\r\n ABucket: TJclPtrHashSetBucket;\r\n SkipCurrent: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnHashSet.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Valid then\r\n begin\r\n SkipCurrent := True;\r\n while FBucketIndex < FOwnHashSet.FCapacity do\r\n begin\r\n ABucket := FOwnHashSet.FBuckets[FBucketIndex];\r\n if ABucket <> nil then\r\n begin\r\n if (not SkipCurrent) and (FItemIndex < ABucket.Size) then\r\n Break;\r\n if FItemIndex < (ABucket.Size - 1) then\r\n begin\r\n Inc(FItemIndex);\r\n Break;\r\n end;\r\n end;\r\n FItemIndex := 0;\r\n Inc(FBucketIndex);\r\n SkipCurrent := False;\r\n end;\r\n end\r\n else\r\n Valid := True;\r\n\r\n Result := (FBucketIndex >= 0) and (FItemIndex >= 0) and\r\n (FBucketIndex < FOwnHashSet.FCapacity);\r\n if Result then\r\n begin\r\n ABucket := FOwnHashSet.FBuckets[FBucketIndex];\r\n Result := (ABucket <> nil) and (FItemIndex < ABucket.Size);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnHashSet.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n{$ENDIF SUPPORTS_FOR_IN}\r\n\r\nfunction TJclPtrHashSetIterator.Next: Pointer;\r\nvar\r\n ABucket: TJclPtrHashSetBucket;\r\n SkipCurrent: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnHashSet.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Valid then\r\n begin\r\n SkipCurrent := True;\r\n while FBucketIndex < FOwnHashSet.FCapacity do\r\n begin\r\n ABucket := FOwnHashSet.FBuckets[FBucketIndex];\r\n if ABucket <> nil then\r\n begin\r\n if (not SkipCurrent) and (FItemIndex < ABucket.Size) then\r\n Break;\r\n if FItemIndex < (ABucket.Size - 1) then\r\n begin\r\n Inc(FItemIndex);\r\n Break;\r\n end;\r\n end;\r\n FItemIndex := 0;\r\n Inc(FBucketIndex);\r\n SkipCurrent := False;\r\n end;\r\n end\r\n else\r\n Valid := True;\r\n\r\n Result := nil;\r\n if (FBucketIndex >= 0) and (FItemIndex >= 0) and\r\n (FBucketIndex < FOwnHashSet.FCapacity) then\r\n begin\r\n ABucket := FOwnHashSet.FBuckets[FBucketIndex];\r\n if (ABucket <> nil) and\r\n (FItemIndex < ABucket.Size) then\r\n Result := ABucket.Entries[FItemIndex]\r\n else\r\n if not FOwnHashSet.ReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n end\r\n else\r\n if not FOwnHashSet.ReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnHashSet.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclPtrHashSetIterator.NextIndex: Integer;\r\nbegin\r\n // No index\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nfunction TJclPtrHashSetIterator.Previous: Pointer;\r\nvar\r\n ABucket: TJclPtrHashSetBucket;\r\n SkipCurrent: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnHashSet.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Valid then\r\n begin\r\n SkipCurrent := True;\r\n while FBucketIndex >= 0 do\r\n begin\r\n ABucket := FOwnHashSet.FBuckets[FBucketIndex];\r\n if (ABucket <> nil) and (FItemIndex < 0) then\r\n FItemIndex := ABucket.Size - 1;\r\n if ABucket <> nil then\r\n begin\r\n if (not SkipCurrent) and (FItemIndex >= 0) and (FItemIndex < ABucket.Size) then\r\n Break;\r\n if (FItemIndex > 0) and (FItemIndex < ABucket.Size) then\r\n begin\r\n Dec(FItemIndex);\r\n Break;\r\n end;\r\n end;\r\n FItemIndex := -1;\r\n Dec(FBucketIndex);\r\n SkipCurrent := False;\r\n end;\r\n end\r\n else\r\n Valid := True;\r\n\r\n Result := nil;\r\n if (FBucketIndex >= 0) and (FItemIndex >= 0) and\r\n (FBucketIndex < FOwnHashSet.FCapacity) then\r\n begin\r\n ABucket := FOwnHashSet.FBuckets[FBucketIndex];\r\n if (ABucket <> nil) and\r\n (FItemIndex < ABucket.Size) then\r\n Result := ABucket.Entries[FItemIndex]\r\n else\r\n if not FOwnHashSet.ReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n end\r\n else\r\n if not FOwnHashSet.ReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnHashSet.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclPtrHashSetIterator.PreviousIndex: Integer;\r\nbegin\r\n // No index\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nprocedure TJclPtrHashSetIterator.Remove;\r\nbegin\r\n\r\nend;\r\n\r\nprocedure TJclPtrHashSetIterator.Reset;\r\nvar\r\n ABucket: TJclPtrHashSetBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnHashSet.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Valid := False;\r\n case FStart of\r\n isFirst:\r\n begin\r\n FBucketIndex := 0;\r\n ABucket := nil;\r\n while FBucketIndex < FOwnHashSet.FCapacity do\r\n begin\r\n ABucket := FOwnHashSet.FBuckets[FBucketIndex];\r\n if (ABucket <> nil) and (ABucket.Size > 0) then\r\n Break;\r\n Inc(FBucketIndex);\r\n end;\r\n if ABucket <> nil then\r\n FItemIndex := 0\r\n else\r\n FItemIndex := -1;\r\n end;\r\n isLast:\r\n begin\r\n FBucketIndex := FOwnHashSet.FCapacity - 1;\r\n ABucket := nil;\r\n while FBucketIndex >= 0 do\r\n begin\r\n ABucket := FOwnHashSet.FBuckets[FBucketIndex];\r\n if (ABucket <> nil) and (ABucket.Size > 0) then\r\n Break;\r\n Dec(FBucketIndex);\r\n end;\r\n if ABucket <> nil then\r\n FItemIndex := ABucket.Size - 1\r\n else\r\n FItemIndex := -1;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnHashSet.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclPtrHashSetIterator.SetPointer(APtr: Pointer);\r\nbegin\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n//=== { TJclHashSet } ====================================================\r\n\r\nconstructor TJclHashSet.Create(ACapacity: Integer; AOwnsObjects: Boolean);\r\nbegin\r\n inherited Create(AOwnsObjects);\r\n SetCapacity(ACapacity);\r\n FHashToRangeFunction := JclSimpleHashToRange;\r\nend;\r\n\r\ndestructor TJclHashSet.Destroy;\r\nbegin\r\n FReadOnly := False;\r\n Clear;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJclHashSet.Add(AObject: TObject): Boolean;\r\nvar\r\n Index: Integer;\r\n Bucket: TJclHashSetBucket;\r\n I: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if FAllowDefaultElements or (not ItemsEqual(AObject, nil)) then\r\n begin\r\n Index := FHashToRangeFunction(Hash(AObject), FCapacity);\r\n Bucket := FBuckets[Index];\r\n if Bucket <> nil then\r\n begin\r\n for I := 0 to Bucket.Size - 1 do\r\n if ItemsEqual(Bucket.Entries[I], AObject) then\r\n Exit;\r\n end\r\n else\r\n begin\r\n Bucket := TJclHashSetBucket.Create;\r\n SetLength(Bucket.Entries, 1);\r\n FBuckets[Index] := Bucket;\r\n end;\r\n\r\n if Bucket.Size = Length(Bucket.Entries) then\r\n SetLength(Bucket.Entries, CalcGrowCapacity(Bucket.Size, Bucket.Size));\r\n\r\n if Bucket.Size < Length(Bucket.Entries) then\r\n begin\r\n Bucket.Entries[Bucket.Size] := AObject;\r\n Inc(Bucket.Size);\r\n Inc(FSize);\r\n Result := True;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclHashSet.AddAll(const ACollection: IJclCollection): Boolean;\r\nvar\r\n It: IJclIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n Result := Add(It.Next) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclHashSet.AssignDataTo(Dest: TJclAbstractContainerBase);\r\nvar\r\n I, J: Integer;\r\n SelfBucket, NewBucket: TJclHashSetBucket;\r\n ADest: TJclHashSet;\r\n ACollection: IJclCollection;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n inherited AssignDataTo(Dest);\r\n if Dest is TJclHashSet then\r\n begin\r\n ADest := TJclHashSet(Dest);\r\n ADest.Clear;\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n SelfBucket := FBuckets[I];\r\n if SelfBucket <> nil then\r\n begin\r\n NewBucket := TJclHashSetBucket.Create;\r\n SetLength(NewBucket.Entries, SelfBucket.Size);\r\n for J := 0 to SelfBucket.Size - 1 do\r\n NewBucket.Entries[J] := SelfBucket.Entries[J];\r\n NewBucket.Size := SelfBucket.Size;\r\n ADest.FBuckets[I] := NewBucket;\r\n end;\r\n end;\r\n end\r\n else\r\n if Supports(IInterface(Dest), IJclCollection, ACollection) then\r\n begin\r\n ACollection.Clear;\r\n ACollection.AddAll(Self);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclHashSet.AssignPropertiesTo(Dest: TJclAbstractContainerBase);\r\nbegin\r\n inherited AssignPropertiesto(Dest);\r\n if Dest is TJclHashSet then\r\n TJclHashSet(Dest).FHashToRangeFunction := FHashToRangeFunction;\r\nend;\r\n\r\nprocedure TJclHashSet.Clear;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclHashSetBucket;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n begin\r\n for J := 0 to Bucket.Size - 1 do\r\n FreeObject(Bucket.Entries[J]);\r\n FreeAndNil(FBuckets[I]);\r\n end;\r\n end;\r\n FSize := 0;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclHashSet.CollectionEquals(const ACollection: IJclCollection): Boolean;\r\nvar\r\n I, J: Integer;\r\n It: IJclIterator;\r\n Bucket: TJclHashSetBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n if FSize <> ACollection.Size then\r\n Exit;\r\n It := ACollection.First;\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n for J := 0 to Bucket.Size - 1 do\r\n if not ItemsEqual(Bucket.Entries[J], It.Next) then\r\n Exit;\r\n end;\r\n Result := True;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclHashSet.Contains(AObject: TObject): Boolean;\r\nvar\r\n I: Integer;\r\n Bucket: TJclHashSetBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n Bucket := FBuckets[FHashToRangeFunction(Hash(AObject), FCapacity)];\r\n if Bucket <> nil then\r\n for I := 0 to Bucket.Size - 1 do\r\n if ItemsEqual(Bucket.Entries[I], AObject) then\r\n begin\r\n Result := True;\r\n Break;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclHashSet.ContainsAll(const ACollection: IJclCollection): Boolean;\r\nvar\r\n It: IJclIterator;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := True;\r\n if ACollection = nil then\r\n Exit;\r\n It := ACollection.First;\r\n while Result and It.HasNext do\r\n Result := Contains(It.Next);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclHashSet.Extract(AObject: TObject): Boolean;\r\nvar\r\n Bucket: TJclHashSetBucket;\r\n I, NewCapacity: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n Bucket := FBuckets[FHashToRangeFunction(Hash(AObject), FCapacity)];\r\n if Bucket <> nil then\r\n begin\r\n for I := 0 to Bucket.Size - 1 do\r\n if ItemsEqual(Bucket.Entries[I], AObject) then\r\n begin\r\n Result := True;\r\n Bucket.Entries[I] := nil;\r\n if I < Length(Bucket.Entries) - 1 then\r\n MoveArray(Bucket.Entries, I + 1, I, Bucket.Size - I - 1);\r\n Dec(Bucket.Size);\r\n Dec(FSize);\r\n Break;\r\n end;\r\n\r\n NewCapacity := CalcPackCapacity(Length(Bucket.Entries), Bucket.Size);\r\n if NewCapacity < Length(Bucket.Entries) then\r\n SetLength(Bucket.Entries, NewCapacity);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclHashSet.ExtractAll(const ACollection: IJclCollection): Boolean;\r\nvar\r\n It: IJclIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n Result := Extract(It.Next) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclHashSet.First: IJclIterator;\r\nvar\r\n ABucketIndex, AItemIndex: Integer;\r\n ABucket: TJclHashSetBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n ABucketIndex := 0;\r\n ABucket := nil;\r\n while ABucketIndex < FCapacity do\r\n begin\r\n ABucket := FBuckets[ABucketIndex];\r\n if (ABucket <> nil) and (ABucket.Size > 0) then\r\n Break;\r\n Inc(ABucketIndex);\r\n end;\r\n if ABucket <> nil then\r\n AItemIndex := 0\r\n else\r\n AItemIndex := -1;\r\n Result := TJclHashSetIterator.Create(Self, ABucketIndex, AItemIndex, False, isFirst);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\n{$IFDEF SUPPORTS_FOR_IN}\r\nfunction TJclHashSet.GetEnumerator: IJclIterator;\r\nbegin\r\n Result := First;\r\nend;\r\n{$ENDIF SUPPORTS_FOR_IN}\r\n\r\nprocedure TJclHashSet.Intersect(const ACollection: IJclCollection);\r\nbegin\r\n RetainAll(ACollection);\r\nend;\r\n\r\nfunction TJclHashSet.IsEmpty: Boolean;\r\nbegin\r\n Result := FSize = 0;\r\nend;\r\n\r\nfunction TJclHashSet.Last: IJclIterator;\r\nvar\r\n ABucketIndex, AItemIndex: Integer;\r\n ABucket: TJclHashSetBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n ABucketIndex := FCapacity - 1;\r\n ABucket := nil;\r\n while ABucketIndex >= 0 do\r\n begin\r\n ABucket := FBuckets[ABucketIndex];\r\n if (ABucket <> nil) and (ABucket.Size > 0) then\r\n Break;\r\n Dec(ABucketIndex);\r\n end;\r\n if ABucket <> nil then\r\n AItemIndex := ABucket.Size - 1\r\n else\r\n AItemIndex := -1;\r\n Result := TJclHashSetIterator.Create(Self, ABucketIndex, AItemIndex, False, isLast);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclHashSet.Pack;\r\nvar\r\n I: Integer;\r\n Bucket: TJclHashSetBucket;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n begin\r\n if Bucket.Size > 0 then\r\n SetLength(Bucket.Entries, Bucket.Size)\r\n else\r\n FreeAndNil(FBuckets[I]);\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclHashSet.Remove(AObject: TObject): Boolean;\r\nvar\r\n Extracted: TObject;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := Extract(AObject);\r\n if Result then\r\n begin\r\n Extracted := AObject;\r\n FreeObject(Extracted);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclHashSet.RemoveAll(const ACollection: IJclCollection): Boolean;\r\nvar\r\n It: IJclIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n Result := Remove(It.Next) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclHashSet.RetainAll(const ACollection: IJclCollection): Boolean;\r\nvar\r\n I, J, NewCapacity: Integer;\r\n Bucket: TJclHashSetBucket;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n begin\r\n for J := Bucket.Size - 1 downto 0 do\r\n if not ACollection.Contains(Bucket.Entries[I]) then\r\n begin\r\n Bucket.Entries[J] := FreeObject(Bucket.Entries[J]);\r\n if J < Length(Bucket.Entries) - 1 then\r\n MoveArray(Bucket.Entries, J + 1, J, Bucket.Size - J - 1);\r\n Dec(Bucket.Size);\r\n Dec(FSize);\r\n end;\r\n\r\n NewCapacity := CalcPackCapacity(Length(Bucket.Entries), Bucket.Size);\r\n if NewCapacity < Length(Bucket.Entries) then\r\n SetLength(Bucket.Entries, NewCapacity);\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclHashSet.SetCapacity(Value: Integer);\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FSize = 0 then\r\n begin\r\n SetLength(FBuckets, Value);\r\n inherited SetCapacity(Value);\r\n end\r\n else\r\n raise EJclOperationNotSupportedError.Create;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclHashSet.Size: Integer;\r\nbegin\r\n Result := FSize;\r\nend;\r\n\r\nprocedure TJclHashSet.Subtract(const ACollection: IJclCollection);\r\nbegin\r\n RemoveAll(ACollection);\r\nend;\r\n\r\nprocedure TJclHashSet.Union(const ACollection: IJclCollection);\r\nbegin\r\n AddAll(ACollection);\r\nend;\r\n\r\n\r\nfunction TJclHashSet.CreateEmptyContainer: TJclAbstractContainerBase;\r\nbegin\r\n Result := TJclHashSet.Create(Size, False);\r\n AssignPropertiesTo(Result);\r\nend;\r\n\r\n//=== { TJclHashSetIterator } ============================================\r\n\r\nconstructor TJclHashSetIterator.Create(AOwnHashSet: TJclHashSet;\r\n ABucketIndex, AItemIndex: Integer; AValid: Boolean; AStart: TItrStart);\r\nbegin\r\n inherited Create(AValid);\r\n FOwnHashSet := AOwnHashSet;\r\n FBucketIndex := ABucketIndex;\r\n FItemIndex := AItemIndex;\r\n FStart := AStart;\r\nend;\r\n\r\nfunction TJclHashSetIterator.Add(AObject: TObject): Boolean;\r\nbegin\r\n Result := FOwnHashSet.Add(AObject);\r\nend;\r\n\r\nprocedure TJclHashSetIterator.AssignPropertiesTo(Dest: TJclAbstractIterator);\r\nvar\r\n ADest: TJclHashSetIterator;\r\nbegin\r\n inherited AssignPropertiesTo(Dest);\r\n if Dest is TJclHashSetIterator then\r\n begin\r\n ADest := TJclHashSetIterator(Dest);\r\n ADest.FBucketIndex := FBucketIndex;\r\n ADest.FItemIndex := FItemIndex;\r\n ADest.FOwnHashSet := FOwnHashSet;\r\n ADest.FStart := FStart;\r\n end;\r\nend;\r\n\r\nfunction TJclHashSetIterator.CreateEmptyIterator: TJclAbstractIterator;\r\nbegin\r\n Result := TJclHashSetIterator.Create(FOwnHashSet, FBucketIndex, FItemIndex, Valid, FStart);\r\nend;\r\n\r\nprocedure TJclHashSetIterator.Extract;\r\nvar\r\n AObject: TObject;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnHashSet.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n CheckValid;\r\n AObject := GetObject;\r\n Valid := False;\r\n FOwnHashSet.Extract(AObject);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnHashSet.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclHashSetIterator.GetObject: TObject;\r\nvar\r\n ABucket: TJclHashSetBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnHashSet.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n CheckValid;\r\n Result := nil;\r\n ABucket := FOwnHashSet.FBuckets[FBucketIndex - 1];\r\n if (ABucket <> nil) and (FItemIndex < ABucket.Size) then\r\n Result := ABucket.Entries[FItemIndex]\r\n else\r\n if not FOwnHashSet.ReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnHashSet.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclHashSetIterator.HasNext: Boolean;\r\nvar\r\n ABucketIndex, AItemIndex: Integer;\r\n ABucket: TJclHashSetBucket;\r\n SkipCurrent: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnHashSet.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := True;\r\n ABucketIndex := FBucketIndex;\r\n AItemIndex := FItemIndex;\r\n SkipCurrent := Valid;\r\n while ABucketIndex < FOwnHashSet.FCapacity do\r\n begin\r\n ABucket := FOwnHashSet.FBuckets[ABucketIndex];\r\n if ABucket <> nil then\r\n begin\r\n if (AItemIndex < (ABucket.Size - 1)) or\r\n ((not SkipCurrent) and (AItemIndex < ABucket.Size)) then\r\n Exit;\r\n end;\r\n AItemIndex := 0;\r\n Inc(ABucketIndex);\r\n SkipCurrent := False;\r\n end;\r\n Result := False;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnHashSet.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclHashSetIterator.HasPrevious: Boolean;\r\nvar\r\n ABucketIndex, AItemIndex: Integer;\r\n ABucket: TJclHashSetBucket;\r\n SkipCurrent: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnHashSet.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := True;\r\n ABucketIndex := FBucketIndex;\r\n AItemIndex := FItemIndex;\r\n SkipCurrent := Valid;\r\n while ABucketIndex >= 0 do\r\n begin\r\n ABucket := FOwnHashSet.FBuckets[ABucketIndex];\r\n if ABucket <> nil then\r\n begin\r\n if (AItemIndex > 0) or\r\n ((not SkipCurrent) and (AItemIndex >= 0)) then\r\n Exit;\r\n end;\r\n AItemIndex := MaxInt;\r\n Dec(ABucketIndex);\r\n SkipCurrent := False;\r\n end;\r\n Result := False;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnHashSet.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclHashSetIterator.Insert(AObject: TObject): Boolean;\r\nbegin\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nfunction TJclHashSetIterator.IteratorEquals(const AIterator: IJclIterator): Boolean;\r\nvar\r\n Obj: TObject;\r\n ItrObj: TJclHashSetIterator;\r\nbegin\r\n Result := False;\r\n if AIterator = nil then\r\n Exit;\r\n Obj := AIterator.GetIteratorReference;\r\n if Obj is TJclHashSetIterator then\r\n begin\r\n ItrObj := TJclHashSetIterator(Obj);\r\n Result := (FOwnHashSet = ItrObj.FOwnHashSet) and (FBucketIndex = ItrObj.FBucketIndex) and (FItemIndex = ItrObj.FItemIndex) and (Valid = ItrObj.Valid);\r\n end;\r\nend;\r\n\r\n{$IFDEF SUPPORTS_FOR_IN}\r\nfunction TJclHashSetIterator.MoveNext: Boolean;\r\nvar\r\n ABucket: TJclHashSetBucket;\r\n SkipCurrent: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnHashSet.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Valid then\r\n begin\r\n SkipCurrent := True;\r\n while FBucketIndex < FOwnHashSet.FCapacity do\r\n begin\r\n ABucket := FOwnHashSet.FBuckets[FBucketIndex];\r\n if ABucket <> nil then\r\n begin\r\n if (not SkipCurrent) and (FItemIndex < ABucket.Size) then\r\n Break;\r\n if FItemIndex < (ABucket.Size - 1) then\r\n begin\r\n Inc(FItemIndex);\r\n Break;\r\n end;\r\n end;\r\n FItemIndex := 0;\r\n Inc(FBucketIndex);\r\n SkipCurrent := False;\r\n end;\r\n end\r\n else\r\n Valid := True;\r\n\r\n Result := (FBucketIndex >= 0) and (FItemIndex >= 0) and\r\n (FBucketIndex < FOwnHashSet.FCapacity);\r\n if Result then\r\n begin\r\n ABucket := FOwnHashSet.FBuckets[FBucketIndex];\r\n Result := (ABucket <> nil) and (FItemIndex < ABucket.Size);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnHashSet.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n{$ENDIF SUPPORTS_FOR_IN}\r\n\r\nfunction TJclHashSetIterator.Next: TObject;\r\nvar\r\n ABucket: TJclHashSetBucket;\r\n SkipCurrent: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnHashSet.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Valid then\r\n begin\r\n SkipCurrent := True;\r\n while FBucketIndex < FOwnHashSet.FCapacity do\r\n begin\r\n ABucket := FOwnHashSet.FBuckets[FBucketIndex];\r\n if ABucket <> nil then\r\n begin\r\n if (not SkipCurrent) and (FItemIndex < ABucket.Size) then\r\n Break;\r\n if FItemIndex < (ABucket.Size - 1) then\r\n begin\r\n Inc(FItemIndex);\r\n Break;\r\n end;\r\n end;\r\n FItemIndex := 0;\r\n Inc(FBucketIndex);\r\n SkipCurrent := False;\r\n end;\r\n end\r\n else\r\n Valid := True;\r\n\r\n Result := nil;\r\n if (FBucketIndex >= 0) and (FItemIndex >= 0) and\r\n (FBucketIndex < FOwnHashSet.FCapacity) then\r\n begin\r\n ABucket := FOwnHashSet.FBuckets[FBucketIndex];\r\n if (ABucket <> nil) and\r\n (FItemIndex < ABucket.Size) then\r\n Result := ABucket.Entries[FItemIndex]\r\n else\r\n if not FOwnHashSet.ReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n end\r\n else\r\n if not FOwnHashSet.ReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnHashSet.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclHashSetIterator.NextIndex: Integer;\r\nbegin\r\n // No index\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nfunction TJclHashSetIterator.Previous: TObject;\r\nvar\r\n ABucket: TJclHashSetBucket;\r\n SkipCurrent: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnHashSet.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Valid then\r\n begin\r\n SkipCurrent := True;\r\n while FBucketIndex >= 0 do\r\n begin\r\n ABucket := FOwnHashSet.FBuckets[FBucketIndex];\r\n if (ABucket <> nil) and (FItemIndex < 0) then\r\n FItemIndex := ABucket.Size - 1;\r\n if ABucket <> nil then\r\n begin\r\n if (not SkipCurrent) and (FItemIndex >= 0) and (FItemIndex < ABucket.Size) then\r\n Break;\r\n if (FItemIndex > 0) and (FItemIndex < ABucket.Size) then\r\n begin\r\n Dec(FItemIndex);\r\n Break;\r\n end;\r\n end;\r\n FItemIndex := -1;\r\n Dec(FBucketIndex);\r\n SkipCurrent := False;\r\n end;\r\n end\r\n else\r\n Valid := True;\r\n\r\n Result := nil;\r\n if (FBucketIndex >= 0) and (FItemIndex >= 0) and\r\n (FBucketIndex < FOwnHashSet.FCapacity) then\r\n begin\r\n ABucket := FOwnHashSet.FBuckets[FBucketIndex];\r\n if (ABucket <> nil) and\r\n (FItemIndex < ABucket.Size) then\r\n Result := ABucket.Entries[FItemIndex]\r\n else\r\n if not FOwnHashSet.ReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n end\r\n else\r\n if not FOwnHashSet.ReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnHashSet.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclHashSetIterator.PreviousIndex: Integer;\r\nbegin\r\n // No index\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nprocedure TJclHashSetIterator.Remove;\r\nbegin\r\n\r\nend;\r\n\r\nprocedure TJclHashSetIterator.Reset;\r\nvar\r\n ABucket: TJclHashSetBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnHashSet.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Valid := False;\r\n case FStart of\r\n isFirst:\r\n begin\r\n FBucketIndex := 0;\r\n ABucket := nil;\r\n while FBucketIndex < FOwnHashSet.FCapacity do\r\n begin\r\n ABucket := FOwnHashSet.FBuckets[FBucketIndex];\r\n if (ABucket <> nil) and (ABucket.Size > 0) then\r\n Break;\r\n Inc(FBucketIndex);\r\n end;\r\n if ABucket <> nil then\r\n FItemIndex := 0\r\n else\r\n FItemIndex := -1;\r\n end;\r\n isLast:\r\n begin\r\n FBucketIndex := FOwnHashSet.FCapacity - 1;\r\n ABucket := nil;\r\n while FBucketIndex >= 0 do\r\n begin\r\n ABucket := FOwnHashSet.FBuckets[FBucketIndex];\r\n if (ABucket <> nil) and (ABucket.Size > 0) then\r\n Break;\r\n Dec(FBucketIndex);\r\n end;\r\n if ABucket <> nil then\r\n FItemIndex := ABucket.Size - 1\r\n else\r\n FItemIndex := -1;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnHashSet.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclHashSetIterator.SetObject(AObject: TObject);\r\nbegin\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\n{$IFDEF SUPPORTS_GENERICS}\r\n//DOM-IGNORE-BEGIN\r\n\r\n//=== { TJclHashSetBucket } =================================================\r\n\r\nprocedure TJclHashSetBucket.MoveArray(var List: TDynArray; FromIndex, ToIndex, Count: SizeInt);\r\nvar\r\n I: SizeInt;\r\nbegin\r\n if FromIndex < ToIndex then\r\n begin\r\n for I := Count - 1 downto 0 do\r\n List[ToIndex + I] := List[FromIndex + I];\r\n\r\n if (ToIndex - FromIndex) < Count then\r\n // overlapped source and target\r\n for I := 0 to ToIndex - FromIndex - 1 do\r\n List[FromIndex + I] := Default(T)\r\n else\r\n // independant\r\n for I := 0 to Count - 1 do\r\n List[FromIndex + I] := Default(T);\r\n end\r\n else\r\n begin\r\n for I := 0 to Count - 1 do\r\n List[ToIndex + I] := List[FromIndex + I];\r\n\r\n if (FromIndex - ToIndex) < Count then\r\n // overlapped source and target\r\n for I := Count - FromIndex + ToIndex to Count - 1 do\r\n List[FromIndex + I] := Default(T)\r\n else\r\n // independant\r\n for I := 0 to Count - 1 do\r\n List[FromIndex + I] := Default(T);\r\n end; \r\nend;\r\n\r\n//=== { TJclHashSet } ====================================================\r\n\r\nconstructor TJclHashSet.Create(ACapacity: Integer; AOwnsItems: Boolean);\r\nbegin\r\n inherited Create(AOwnsItems);\r\n SetCapacity(ACapacity);\r\n FHashToRangeFunction := JclSimpleHashToRange;\r\nend;\r\n\r\ndestructor TJclHashSet.Destroy;\r\nbegin\r\n FReadOnly := False;\r\n Clear;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJclHashSet.Add(const AItem: T): Boolean;\r\nvar\r\n Index: Integer;\r\n Bucket: TJclHashSetBucket;\r\n I: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if FAllowDefaultElements or (not ItemsEqual(AItem, Default(T))) then\r\n begin\r\n Index := FHashToRangeFunction(Hash(AItem), FCapacity);\r\n Bucket := FBuckets[Index];\r\n if Bucket <> nil then\r\n begin\r\n for I := 0 to Bucket.Size - 1 do\r\n if ItemsEqual(Bucket.Entries[I], AItem) then\r\n Exit;\r\n end\r\n else\r\n begin\r\n Bucket := TJclHashSetBucket.Create;\r\n SetLength(Bucket.Entries, 1);\r\n FBuckets[Index] := Bucket;\r\n end;\r\n\r\n if Bucket.Size = Length(Bucket.Entries) then\r\n SetLength(Bucket.Entries, CalcGrowCapacity(Bucket.Size, Bucket.Size));\r\n\r\n if Bucket.Size < Length(Bucket.Entries) then\r\n begin\r\n Bucket.Entries[Bucket.Size] := AItem;\r\n Inc(Bucket.Size);\r\n Inc(FSize);\r\n Result := True;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclHashSet.AddAll(const ACollection: IJclCollection): Boolean;\r\nvar\r\n It: IJclIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n Result := Add(It.Next) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclHashSet.AssignDataTo(Dest: TJclAbstractContainerBase);\r\nvar\r\n I, J: Integer;\r\n SelfBucket, NewBucket: TJclHashSetBucket;\r\n ADest: TJclHashSet;\r\n ACollection: IJclCollection;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n inherited AssignDataTo(Dest);\r\n if Dest is TJclHashSet then\r\n begin\r\n ADest := TJclHashSet(Dest);\r\n ADest.Clear;\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n SelfBucket := FBuckets[I];\r\n if SelfBucket <> nil then\r\n begin\r\n NewBucket := TJclHashSetBucket.Create;\r\n SetLength(NewBucket.Entries, SelfBucket.Size);\r\n for J := 0 to SelfBucket.Size - 1 do\r\n NewBucket.Entries[J] := SelfBucket.Entries[J];\r\n NewBucket.Size := SelfBucket.Size;\r\n ADest.FBuckets[I] := NewBucket;\r\n end;\r\n end;\r\n end\r\n else\r\n if Supports(IInterface(Dest), IJclCollection, ACollection) then\r\n begin\r\n ACollection.Clear;\r\n ACollection.AddAll(Self);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclHashSet.AssignPropertiesTo(Dest: TJclAbstractContainerBase);\r\nbegin\r\n inherited AssignPropertiesto(Dest);\r\n if Dest is TJclHashSet then\r\n TJclHashSet(Dest).FHashToRangeFunction := FHashToRangeFunction;\r\nend;\r\n\r\nprocedure TJclHashSet.Clear;\r\nvar\r\n I, J: Integer;\r\n Bucket: TJclHashSetBucket;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n begin\r\n for J := 0 to Bucket.Size - 1 do\r\n FreeItem(Bucket.Entries[J]);\r\n FreeAndNil(FBuckets[I]);\r\n end;\r\n end;\r\n FSize := 0;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclHashSet.CollectionEquals(const ACollection: IJclCollection): Boolean;\r\nvar\r\n I, J: Integer;\r\n It: IJclIterator;\r\n Bucket: TJclHashSetBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n if FSize <> ACollection.Size then\r\n Exit;\r\n It := ACollection.First;\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n for J := 0 to Bucket.Size - 1 do\r\n if not ItemsEqual(Bucket.Entries[J], It.Next) then\r\n Exit;\r\n end;\r\n Result := True;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclHashSet.Contains(const AItem: T): Boolean;\r\nvar\r\n I: Integer;\r\n Bucket: TJclHashSetBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n Bucket := FBuckets[FHashToRangeFunction(Hash(AItem), FCapacity)];\r\n if Bucket <> nil then\r\n for I := 0 to Bucket.Size - 1 do\r\n if ItemsEqual(Bucket.Entries[I], AItem) then\r\n begin\r\n Result := True;\r\n Break;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclHashSet.ContainsAll(const ACollection: IJclCollection): Boolean;\r\nvar\r\n It: IJclIterator;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := True;\r\n if ACollection = nil then\r\n Exit;\r\n It := ACollection.First;\r\n while Result and It.HasNext do\r\n Result := Contains(It.Next);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclHashSet.Extract(const AItem: T): Boolean;\r\nvar\r\n Bucket: TJclHashSetBucket;\r\n I, NewCapacity: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n Bucket := FBuckets[FHashToRangeFunction(Hash(AItem), FCapacity)];\r\n if Bucket <> nil then\r\n begin\r\n for I := 0 to Bucket.Size - 1 do\r\n if ItemsEqual(Bucket.Entries[I], AItem) then\r\n begin\r\n Result := True;\r\n Bucket.Entries[I] := Default(T);\r\n if I < Length(Bucket.Entries) - 1 then\r\n Bucket.MoveArray(Bucket.Entries, I + 1, I, Bucket.Size - I - 1);\r\n Dec(Bucket.Size);\r\n Dec(FSize);\r\n Break;\r\n end;\r\n\r\n NewCapacity := CalcPackCapacity(Length(Bucket.Entries), Bucket.Size);\r\n if NewCapacity < Length(Bucket.Entries) then\r\n SetLength(Bucket.Entries, NewCapacity);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclHashSet.ExtractAll(const ACollection: IJclCollection): Boolean;\r\nvar\r\n It: IJclIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n Result := Extract(It.Next) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclHashSet.First: IJclIterator;\r\nvar\r\n ABucketIndex, AItemIndex: Integer;\r\n ABucket: TJclHashSetBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n ABucketIndex := 0;\r\n ABucket := nil;\r\n while ABucketIndex < FCapacity do\r\n begin\r\n ABucket := FBuckets[ABucketIndex];\r\n if (ABucket <> nil) and (ABucket.Size > 0) then\r\n Break;\r\n Inc(ABucketIndex);\r\n end;\r\n if ABucket <> nil then\r\n AItemIndex := 0\r\n else\r\n AItemIndex := -1;\r\n Result := TJclHashSetIterator.Create(Self, ABucketIndex, AItemIndex, False, isFirst);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\n{$IFDEF SUPPORTS_FOR_IN}\r\nfunction TJclHashSet.GetEnumerator: IJclIterator;\r\nbegin\r\n Result := First;\r\nend;\r\n{$ENDIF SUPPORTS_FOR_IN}\r\n\r\nprocedure TJclHashSet.Intersect(const ACollection: IJclCollection);\r\nbegin\r\n RetainAll(ACollection);\r\nend;\r\n\r\nfunction TJclHashSet.IsEmpty: Boolean;\r\nbegin\r\n Result := FSize = 0;\r\nend;\r\n\r\nfunction TJclHashSet.Last: IJclIterator;\r\nvar\r\n ABucketIndex, AItemIndex: Integer;\r\n ABucket: TJclHashSetBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n ABucketIndex := FCapacity - 1;\r\n ABucket := nil;\r\n while ABucketIndex >= 0 do\r\n begin\r\n ABucket := FBuckets[ABucketIndex];\r\n if (ABucket <> nil) and (ABucket.Size > 0) then\r\n Break;\r\n Dec(ABucketIndex);\r\n end;\r\n if ABucket <> nil then\r\n AItemIndex := ABucket.Size - 1\r\n else\r\n AItemIndex := -1;\r\n Result := TJclHashSetIterator.Create(Self, ABucketIndex, AItemIndex, False, isLast);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclHashSet.Pack;\r\nvar\r\n I: Integer;\r\n Bucket: TJclHashSetBucket;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n begin\r\n if Bucket.Size > 0 then\r\n SetLength(Bucket.Entries, Bucket.Size)\r\n else\r\n FreeAndNil(FBuckets[I]);\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclHashSet.Remove(const AItem: T): Boolean;\r\nvar\r\n Extracted: T;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := Extract(AItem);\r\n if Result then\r\n begin\r\n Extracted := AItem;\r\n FreeItem(Extracted);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclHashSet.RemoveAll(const ACollection: IJclCollection): Boolean;\r\nvar\r\n It: IJclIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n Result := Remove(It.Next) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclHashSet.RetainAll(const ACollection: IJclCollection): Boolean;\r\nvar\r\n I, J, NewCapacity: Integer;\r\n Bucket: TJclHashSetBucket;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n for I := 0 to FCapacity - 1 do\r\n begin\r\n Bucket := FBuckets[I];\r\n if Bucket <> nil then\r\n begin\r\n for J := Bucket.Size - 1 downto 0 do\r\n if not ACollection.Contains(Bucket.Entries[I]) then\r\n begin\r\n Bucket.Entries[J] := FreeItem(Bucket.Entries[J]);\r\n if J < Length(Bucket.Entries) - 1 then\r\n Bucket.MoveArray(Bucket.Entries, J + 1, J, Bucket.Size - J - 1);\r\n Dec(Bucket.Size);\r\n Dec(FSize);\r\n end;\r\n\r\n NewCapacity := CalcPackCapacity(Length(Bucket.Entries), Bucket.Size);\r\n if NewCapacity < Length(Bucket.Entries) then\r\n SetLength(Bucket.Entries, NewCapacity);\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclHashSet.SetCapacity(Value: Integer);\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FSize = 0 then\r\n begin\r\n SetLength(FBuckets, Value);\r\n inherited SetCapacity(Value);\r\n end\r\n else\r\n raise EJclOperationNotSupportedError.Create;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclHashSet.Size: Integer;\r\nbegin\r\n Result := FSize;\r\nend;\r\n\r\nprocedure TJclHashSet.Subtract(const ACollection: IJclCollection);\r\nbegin\r\n RemoveAll(ACollection);\r\nend;\r\n\r\nprocedure TJclHashSet.Union(const ACollection: IJclCollection);\r\nbegin\r\n AddAll(ACollection);\r\nend;\r\n\r\n//=== { TJclHashSetIterator } ============================================\r\n\r\nconstructor TJclHashSetIterator.Create(AOwnHashSet: TJclHashSet;\r\n ABucketIndex, AItemIndex: Integer; AValid: Boolean; AStart: TItrStart);\r\nbegin\r\n inherited Create(AValid);\r\n FOwnHashSet := AOwnHashSet;\r\n FBucketIndex := ABucketIndex;\r\n FItemIndex := AItemIndex;\r\n FStart := AStart;\r\nend;\r\n\r\nfunction TJclHashSetIterator.Add(const AItem: T): Boolean;\r\nbegin\r\n Result := FOwnHashSet.Add(AItem);\r\nend;\r\n\r\nprocedure TJclHashSetIterator.AssignPropertiesTo(Dest: TJclAbstractIterator);\r\nvar\r\n ADest: TJclHashSetIterator;\r\nbegin\r\n inherited AssignPropertiesTo(Dest);\r\n if Dest is TJclHashSetIterator then\r\n begin\r\n ADest := TJclHashSetIterator(Dest);\r\n ADest.FBucketIndex := FBucketIndex;\r\n ADest.FItemIndex := FItemIndex;\r\n ADest.FOwnHashSet := FOwnHashSet;\r\n ADest.FStart := FStart;\r\n end;\r\nend;\r\n\r\nfunction TJclHashSetIterator.CreateEmptyIterator: TJclAbstractIterator;\r\nbegin\r\n Result := TJclHashSetIterator.Create(FOwnHashSet, FBucketIndex, FItemIndex, Valid, FStart);\r\nend;\r\n\r\nprocedure TJclHashSetIterator.Extract;\r\nvar\r\n AItem: T;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnHashSet.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n CheckValid;\r\n AItem := GetItem;\r\n Valid := False;\r\n FOwnHashSet.Extract(AItem);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnHashSet.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclHashSetIterator.GetItem: T;\r\nvar\r\n ABucket: TJclHashSetBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnHashSet.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n CheckValid;\r\n Result := Default(T);\r\n ABucket := FOwnHashSet.FBuckets[FBucketIndex - 1];\r\n if (ABucket <> nil) and (FItemIndex < ABucket.Size) then\r\n Result := ABucket.Entries[FItemIndex]\r\n else\r\n if not FOwnHashSet.ReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnHashSet.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclHashSetIterator.HasNext: Boolean;\r\nvar\r\n ABucketIndex, AItemIndex: Integer;\r\n ABucket: TJclHashSetBucket;\r\n SkipCurrent: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnHashSet.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := True;\r\n ABucketIndex := FBucketIndex;\r\n AItemIndex := FItemIndex;\r\n SkipCurrent := Valid;\r\n while ABucketIndex < FOwnHashSet.FCapacity do\r\n begin\r\n ABucket := FOwnHashSet.FBuckets[ABucketIndex];\r\n if ABucket <> nil then\r\n begin\r\n if (AItemIndex < (ABucket.Size - 1)) or\r\n ((not SkipCurrent) and (AItemIndex < ABucket.Size)) then\r\n Exit;\r\n end;\r\n AItemIndex := 0;\r\n Inc(ABucketIndex);\r\n SkipCurrent := False;\r\n end;\r\n Result := False;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnHashSet.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclHashSetIterator.HasPrevious: Boolean;\r\nvar\r\n ABucketIndex, AItemIndex: Integer;\r\n ABucket: TJclHashSetBucket;\r\n SkipCurrent: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnHashSet.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := True;\r\n ABucketIndex := FBucketIndex;\r\n AItemIndex := FItemIndex;\r\n SkipCurrent := Valid;\r\n while ABucketIndex >= 0 do\r\n begin\r\n ABucket := FOwnHashSet.FBuckets[ABucketIndex];\r\n if ABucket <> nil then\r\n begin\r\n if (AItemIndex > 0) or\r\n ((not SkipCurrent) and (AItemIndex >= 0)) then\r\n Exit;\r\n end;\r\n AItemIndex := MaxInt;\r\n Dec(ABucketIndex);\r\n SkipCurrent := False;\r\n end;\r\n Result := False;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnHashSet.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclHashSetIterator.Insert(const AItem: T): Boolean;\r\nbegin\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nfunction TJclHashSetIterator.IteratorEquals(const AIterator: IJclIterator): Boolean;\r\nvar\r\n Obj: TObject;\r\n ItrObj: TJclHashSetIterator;\r\nbegin\r\n Result := False;\r\n if AIterator = nil then\r\n Exit;\r\n Obj := AIterator.GetIteratorReference;\r\n if Obj is TJclHashSetIterator then\r\n begin\r\n ItrObj := TJclHashSetIterator(Obj);\r\n Result := (FOwnHashSet = ItrObj.FOwnHashSet) and (FBucketIndex = ItrObj.FBucketIndex) and (FItemIndex = ItrObj.FItemIndex) and (Valid = ItrObj.Valid);\r\n end;\r\nend;\r\n\r\n{$IFDEF SUPPORTS_FOR_IN}\r\nfunction TJclHashSetIterator.MoveNext: Boolean;\r\nvar\r\n ABucket: TJclHashSetBucket;\r\n SkipCurrent: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnHashSet.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Valid then\r\n begin\r\n SkipCurrent := True;\r\n while FBucketIndex < FOwnHashSet.FCapacity do\r\n begin\r\n ABucket := FOwnHashSet.FBuckets[FBucketIndex];\r\n if ABucket <> nil then\r\n begin\r\n if (not SkipCurrent) and (FItemIndex < ABucket.Size) then\r\n Break;\r\n if FItemIndex < (ABucket.Size - 1) then\r\n begin\r\n Inc(FItemIndex);\r\n Break;\r\n end;\r\n end;\r\n FItemIndex := 0;\r\n Inc(FBucketIndex);\r\n SkipCurrent := False;\r\n end;\r\n end\r\n else\r\n Valid := True;\r\n\r\n Result := (FBucketIndex >= 0) and (FItemIndex >= 0) and\r\n (FBucketIndex < FOwnHashSet.FCapacity);\r\n if Result then\r\n begin\r\n ABucket := FOwnHashSet.FBuckets[FBucketIndex];\r\n Result := (ABucket <> nil) and (FItemIndex < ABucket.Size);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnHashSet.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n{$ENDIF SUPPORTS_FOR_IN}\r\n\r\nfunction TJclHashSetIterator.Next: T;\r\nvar\r\n ABucket: TJclHashSetBucket;\r\n SkipCurrent: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnHashSet.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Valid then\r\n begin\r\n SkipCurrent := True;\r\n while FBucketIndex < FOwnHashSet.FCapacity do\r\n begin\r\n ABucket := FOwnHashSet.FBuckets[FBucketIndex];\r\n if ABucket <> nil then\r\n begin\r\n if (not SkipCurrent) and (FItemIndex < ABucket.Size) then\r\n Break;\r\n if FItemIndex < (ABucket.Size - 1) then\r\n begin\r\n Inc(FItemIndex);\r\n Break;\r\n end;\r\n end;\r\n FItemIndex := 0;\r\n Inc(FBucketIndex);\r\n SkipCurrent := False;\r\n end;\r\n end\r\n else\r\n Valid := True;\r\n\r\n Result := Default(T);\r\n if (FBucketIndex >= 0) and (FItemIndex >= 0) and\r\n (FBucketIndex < FOwnHashSet.FCapacity) then\r\n begin\r\n ABucket := FOwnHashSet.FBuckets[FBucketIndex];\r\n if (ABucket <> nil) and\r\n (FItemIndex < ABucket.Size) then\r\n Result := ABucket.Entries[FItemIndex]\r\n else\r\n if not FOwnHashSet.ReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n end\r\n else\r\n if not FOwnHashSet.ReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnHashSet.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclHashSetIterator.NextIndex: Integer;\r\nbegin\r\n // No index\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nfunction TJclHashSetIterator.Previous: T;\r\nvar\r\n ABucket: TJclHashSetBucket;\r\n SkipCurrent: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnHashSet.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Valid then\r\n begin\r\n SkipCurrent := True;\r\n while FBucketIndex >= 0 do\r\n begin\r\n ABucket := FOwnHashSet.FBuckets[FBucketIndex];\r\n if (ABucket <> nil) and (FItemIndex < 0) then\r\n FItemIndex := ABucket.Size - 1;\r\n if ABucket <> nil then\r\n begin\r\n if (not SkipCurrent) and (FItemIndex >= 0) and (FItemIndex < ABucket.Size) then\r\n Break;\r\n if (FItemIndex > 0) and (FItemIndex < ABucket.Size) then\r\n begin\r\n Dec(FItemIndex);\r\n Break;\r\n end;\r\n end;\r\n FItemIndex := -1;\r\n Dec(FBucketIndex);\r\n SkipCurrent := False;\r\n end;\r\n end\r\n else\r\n Valid := True;\r\n\r\n Result := Default(T);\r\n if (FBucketIndex >= 0) and (FItemIndex >= 0) and\r\n (FBucketIndex < FOwnHashSet.FCapacity) then\r\n begin\r\n ABucket := FOwnHashSet.FBuckets[FBucketIndex];\r\n if (ABucket <> nil) and\r\n (FItemIndex < ABucket.Size) then\r\n Result := ABucket.Entries[FItemIndex]\r\n else\r\n if not FOwnHashSet.ReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n end\r\n else\r\n if not FOwnHashSet.ReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnHashSet.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclHashSetIterator.PreviousIndex: Integer;\r\nbegin\r\n // No index\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nprocedure TJclHashSetIterator.Remove;\r\nbegin\r\n\r\nend;\r\n\r\nprocedure TJclHashSetIterator.Reset;\r\nvar\r\n ABucket: TJclHashSetBucket;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnHashSet.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Valid := False;\r\n case FStart of\r\n isFirst:\r\n begin\r\n FBucketIndex := 0;\r\n ABucket := nil;\r\n while FBucketIndex < FOwnHashSet.FCapacity do\r\n begin\r\n ABucket := FOwnHashSet.FBuckets[FBucketIndex];\r\n if (ABucket <> nil) and (ABucket.Size > 0) then\r\n Break;\r\n Inc(FBucketIndex);\r\n end;\r\n if ABucket <> nil then\r\n FItemIndex := 0\r\n else\r\n FItemIndex := -1;\r\n end;\r\n isLast:\r\n begin\r\n FBucketIndex := FOwnHashSet.FCapacity - 1;\r\n ABucket := nil;\r\n while FBucketIndex >= 0 do\r\n begin\r\n ABucket := FOwnHashSet.FBuckets[FBucketIndex];\r\n if (ABucket <> nil) and (ABucket.Size > 0) then\r\n Break;\r\n Dec(FBucketIndex);\r\n end;\r\n if ABucket <> nil then\r\n FItemIndex := ABucket.Size - 1\r\n else\r\n FItemIndex := -1;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnHashSet.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclHashSetIterator.SetItem(const AItem: T);\r\nbegin\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\n//=== { TJclHashSetE } ====================================================\r\n\r\nconstructor TJclHashSetE.Create(const AEqualityComparer: IJclEqualityComparer;\r\n const AHashConverter: IJclHashConverter; ACapacity: Integer; AOwnsItems: Boolean);\r\nbegin\r\n inherited Create(ACapacity, AOwnsItems);\r\n FEqualityComparer := AEqualityComparer;\r\n FHashConverter := AHashConverter;\r\nend;\r\n\r\nprocedure TJclHashSetE.AssignPropertiesTo(Dest: TJclAbstractContainerBase);\r\nvar\r\n ADest: TJclHashSetE;\r\nbegin\r\n inherited AssignPropertiesTo(Dest);\r\n if Dest is TJclHashSetE then\r\n begin\r\n ADest := TJclHashSetE(Dest);\r\n ADest.FEqualityComparer := FEqualityComparer;\r\n ADest.FHashConverter := FHashConverter;\r\n end;\r\nend;\r\n\r\nfunction TJclHashSetE.CreateEmptyContainer: TJclAbstractContainerBase;\r\nbegin\r\n Result := TJclHashSetE.Create(EqualityComparer, HashConverter, FSize, False);\r\n AssignPropertiesTo(Result);\r\nend;\r\n\r\nfunction TJclHashSetE.ItemsEqual(const A, B: T): Boolean;\r\nbegin\r\n if EqualityComparer <> nil then\r\n Result := EqualityComparer.ItemsEqual(A, B)\r\n else\r\n Result := inherited ItemsEqual(A, B);\r\nend;\r\n\r\nfunction TJclHashSetE.Hash(const AItem: T): Integer;\r\nbegin\r\n if HashConverter <> nil then\r\n Result := HashConverter.Hash(AItem)\r\n else\r\n Result := inherited Hash(AItem);\r\nend;\r\n\r\n//=== { TJclHashSetF } ====================================================\r\n\r\nconstructor TJclHashSetF.Create(const AEqualityCompare: TEqualityCompare;\r\n const AHashConvert: THashConvert; ACapacity: Integer; AOwnsItems: Boolean);\r\nbegin\r\n inherited Create(ACapacity, AOwnsItems);\r\n SetEqualityCompare(AEqualityCompare);\r\n SetHashConvert(AHashConvert);\r\nend;\r\n\r\nfunction TJclHashSetF.CreateEmptyContainer: TJclAbstractContainerBase;\r\nbegin\r\n Result := TJclHashSetF.Create(EqualityCompare, HashConvert, FSize, False);\r\n AssignPropertiesTo(Result);\r\nend;\r\n\r\n//=== { TJclHashSetI } ====================================================\r\n\r\nfunction TJclHashSetI.CreateEmptyContainer: TJclAbstractContainerBase;\r\nbegin\r\n Result := TJclHashSetI.Create(FSize, False);\r\n AssignPropertiesTo(Result);\r\nend;\r\n\r\nfunction TJclHashSetI.ItemsEqual(const A, B: T): Boolean;\r\nbegin\r\n if Assigned(FEqualityCompare) then\r\n Result := FEqualityCompare(A, B)\r\n else\r\n Result := A.Equals(B);\r\nend;\r\n\r\nfunction TJclHashSetI.Hash(const AItem: T): Integer;\r\nbegin\r\n if Assigned(FHashConvert) then\r\n Result := FHashConvert(AItem)\r\n else\r\n Result := AItem.GetHashCode;\r\nend;\r\n\r\n//DOM-IGNORE-END\r\n{$ENDIF SUPPORTS_GENERICS}\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n\r\n" }, { "path": "External/Jedi/Jcl/source/common/JclIDEUtils.pas", "content": "{**************************************************************************************************}\r\n{ }\r\n{ Project JEDI Code Library (JCL) }\r\n{ }\r\n{ The contents of this file are subject to the Mozilla Public License Version 1.1 (the \"License\"); }\r\n{ you may not use this file except in compliance with the License. You may obtain a copy of the }\r\n{ License at http://www.mozilla.org/MPL/ }\r\n{ }\r\n{ Software distributed under the License is distributed on an \"AS IS\" basis, WITHOUT WARRANTY OF }\r\n{ ANY KIND, either express or implied. See the License for the specific language governing rights }\r\n{ and limitations under the License. }\r\n{ }\r\n{ The Original Code is DelphiInstall.pas. }\r\n{ }\r\n{ The Initial Developer of the Original Code is Petr Vones. Portions created by Petr Vones are }\r\n{ Copyright (C) of Petr Vones. All Rights Reserved. }\r\n{ }\r\n{ Contributor(s): }\r\n{ Andreas Hausladen (ahuser) }\r\n{ Florent Ouchet (outchy) }\r\n{ Robert Marquardt (marquardt) }\r\n{ Robert Rossmair (rrossmair) - crossplatform & BCB support }\r\n{ Uwe Schuster (uschuster) }\r\n{ }\r\n{**************************************************************************************************}\r\n{ }\r\n{ Routines for getting information about installed versions of Delphi/C++Builder and performing }\r\n{ basic installation tasks. }\r\n{ }\r\n{ Important notes for C#Builder 1 and Delphi 8: }\r\n{ These products were not shipped with their native compilers, but the toolkit to build design }\r\n{ packages is available in codecentral (http://cc.embarcadero.com): }\r\n{ - \"IDE Integration pack for C#Builder 1.0\" http://cc.embarcadero.com/Item/21334 }\r\n{ - \"IDE Integration pack for Delphi 8\" http://cc.embarcadero.com/Item/21333 }\r\n{ It's recommended to extract zip files using the standard pattern of Delphi directories: }\r\n{ - Binary files go to \\bin (DCC32.EXE, RLINK32.DLL and lnkdfm7*.dll) }\r\n{ - Compiler files go to \\lib (designide.dcp, rtl.dcp, SysInit.dcu, vcl.dcp, vclactnband.dcp, }\r\n{ vcljpg.dcp and vclx.dcp) }\r\n{ - ToolsAPI files go to \\source\\ToolsAPI (PaletteAPI.pas, PropInspAPI.pas and ToolsAPI.pas) }\r\n{ Don't mix C#Builder 1 files with Delphi 8 and vice-versa otherwise the compilation will fail }\r\n{ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! }\r\n{ !!!!!!!! The DCPPath for these releases have to $(BDS)\\lib !!!!!!!!! }\r\n{ !!!!!!!! or the directory where compiler files were extracted !!!!!!!!! }\r\n{ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! }\r\n{ The default BPL output directory for these products is set to $(BDSPROJECTSDIR)\\bpl, it may not }\r\n{ exist since the product installers don't create it }\r\n{ }\r\n{**************************************************************************************************}\r\n{ }\r\n{ Last modified: $Date:: 2012-09-04 16:08:04 +0200 (mar. 04 sept. 2012) $ }\r\n{ Revision: $Rev:: 3861 $ }\r\n{ Author: $Author:: outchy $ }\r\n{ }\r\n{**************************************************************************************************}\r\n\r\nunit JclIDEUtils;\r\n\r\n{$I jcl.inc}\r\n{$I crossplatform.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n {$IFDEF HAS_UNITSCOPE}\r\n {$IFDEF MSWINDOWS}\r\n Winapi.Windows, Winapi.ShlObj, JclHelpUtils,\r\n {$ENDIF MSWINDOWS}\r\n System.Classes, System.SysUtils, System.IniFiles, System.Contnrs,\r\n {$ELSE ~HAS_UNITSCOPE}\r\n {$IFDEF MSWINDOWS}\r\n Windows, ShlObj, JclHelpUtils,\r\n {$ENDIF MSWINDOWS}\r\n Classes, SysUtils, IniFiles, Contnrs,\r\n {$ENDIF ~HAS_UNITSCOPE}\r\n JclBase, JclSysUtils, JclCompilerUtils;\r\n\r\n// Various definitions\r\ntype\r\n EJclBorRADException = class(EJclError);\r\n\r\n TJclBorRADToolKind = (brDelphi, brCppBuilder, brBorlandDevStudio);\r\n TJclBorRADToolEdition = (deSTD, dePRO, deCSS, deARC);\r\n TJclBorRADToolPath = string;\r\n\r\nconst\r\n SupportedDelphiVersions = [5, 6, 7, 8, 9, 10, 11, 12, 14, 15, 16, 17];\r\n SupportedBCBVersions = [5, 6, 10, 11, 12, 14, 15, 16, 17];\r\n SupportedBDSVersions = [1, 2, 3, 4, 5, 6, 7, 8, 9, 10];\r\n\r\n // Object Repository\r\n BorRADToolRepositoryPagesSection = 'Repository Pages';\r\n\r\n BorRADToolRepositoryDialogsPage = 'Dialogs';\r\n BorRADToolRepositoryFormsPage = 'Forms';\r\n BorRADToolRepositoryProjectsPage = 'Projects';\r\n BorRADToolRepositoryDataModulesPage = 'Data Modules';\r\n\r\n BorRADToolRepositoryObjectType = 'Type';\r\n BorRADToolRepositoryFormTemplate = 'FormTemplate';\r\n BorRADToolRepositoryProjectTemplate = 'ProjectTemplate';\r\n BorRADToolRepositoryObjectName = 'Name';\r\n BorRADToolRepositoryObjectPage = 'Page';\r\n BorRADToolRepositoryObjectIcon = 'Icon';\r\n BorRADToolRepositoryObjectDescr = 'Description';\r\n BorRADToolRepositoryObjectAuthor = 'Author';\r\n BorRADToolRepositoryObjectAncestor = 'Ancestor';\r\n BorRADToolRepositoryObjectDesigner = 'Designer'; // Delphi 6+ only\r\n BorRADToolRepositoryDesignerDfm = 'dfm';\r\n BorRADToolRepositoryDesignerXfm = 'xfm';\r\n BorRADToolRepositoryObjectNewForm = 'DefaultNewForm';\r\n BorRADToolRepositoryObjectMainForm = 'DefaultMainForm';\r\n\r\n CompilerExtensionDCP = '.dcp';\r\n CompilerExtensionBPI = '.bpi';\r\n CompilerExtensionLIB = '.lib';\r\n CompilerExtensionTDS = '.tds';\r\n CompilerExtensionMAP = '.map';\r\n CompilerExtensionDRC = '.drc';\r\n CompilerExtensionDEF = '.def';\r\n SourceExtensionCPP = '.cpp';\r\n SourceExtensionH = '.h';\r\n SourceExtensionPAS = '.pas';\r\n SourceExtensionDFM = '.dfm';\r\n SourceExtensionXFM = '.xfm';\r\n SourceDescriptionPAS = 'Pascal source file';\r\n SourceDescriptionCPP = 'C++ source file';\r\n\r\n DesignerVCL = 'VCL';\r\n DesignerCLX = 'CLX';\r\n\r\n ProjectTypePackage = 'package';\r\n ProjectTypeLibrary = 'library';\r\n ProjectTypeProgram = 'program';\r\n\r\n Personality32Bit = '32 bit';\r\n Personality64Bit = '64 bit';\r\n PersonalityDelphi = 'Delphi';\r\n PersonalityDelphiOSX = 'Delphi for OSX';\r\n PersonalityDelphiDotNet = 'Delphi.net';\r\n PersonalityBCB = 'C++Builder';\r\n PersonalityCSB = 'C#Builder';\r\n PersonalityVB = 'Visual Basic';\r\n PersonalityDesign = 'Design';\r\n PersonalityUnknown = 'Unknown personality';\r\n PersonalityBDS = 'Borland Developer Studio';\r\n\r\n BorRADToolEditionIDs: array [TJclBorRADToolEdition] of PChar =\r\n ('STD', 'PRO', 'CSS', 'ARC'); // 'ARC' is an assumption\r\n\r\n BDSPlatformWin32 = 'Win32';\r\n BDSPlatformWin64 = 'Win64';\r\n BDSPlatformOSX32 = 'OSX32';\r\n\r\n// Installed versions information classes\r\ntype\r\n TJclBorPersonality = (bpDelphi32, bpDelphi64, bpDelphiOSX32, bpBCBuilder32, bpBCBuilder64,\r\n bpDelphiNet32, bpDelphiNet64, bpCSBuilder32, bpCSBuilder64,\r\n bpVisualBasic32, bpVisualBasic64, bpDesign, bpUnknown);\r\n\r\n TJclBorPersonalities = set of TJclBorPersonality;\r\n\r\n TJclBorDesigner = (bdVCL, bdCLX);\r\n\r\n TJclBorDesigners = set of TJClBorDesigner;\r\n\r\n TJclBDSPlatform = (bpWin32, bpWin64, bpOSX32);\r\n\r\nconst\r\n JclBorPersonalityDescription: array [TJclBorPersonality] of string =\r\n (\r\n Personality32Bit + ' ' + PersonalityDelphi,\r\n Personality64Bit + ' ' + PersonalityDelphi,\r\n Personality32Bit + ' ' + PersonalityDelphiOSX,\r\n Personality32Bit + ' ' + PersonalityBCB,\r\n Personality64Bit + ' ' + PersonalityBCB,\r\n Personality32Bit + ' ' + PersonalityDelphiDotNet,\r\n Personality64Bit + ' ' + PersonalityDelphiDotNet,\r\n Personality32Bit + ' ' + PersonalityCSB,\r\n Personality64Bit + ' ' + PersonalityCSB,\r\n Personality32Bit + ' ' + PersonalityVB,\r\n Personality64Bit + ' ' + PersonalityVB,\r\n PersonalityDesign,\r\n PersonalityUnknown\r\n );\r\n\r\n JclBorDesignerDescription: array [TJclBorDesigner] of string =\r\n (DesignerVCL, DesignerCLX);\r\n JclBorDesignerFormExtension: array [TJclBorDesigner] of string =\r\n (SourceExtensionDFM, SourceExtensionXFM);\r\n\r\ntype\r\n TJclBorRADToolInstallation = class;\r\n\r\n TJclBorRADToolInstallationObject = class(TInterfacedObject)\r\n private\r\n FInstallation: TJclBorRADToolInstallation;\r\n public\r\n constructor Create(AInstallation: TJclBorRADToolInstallation);\r\n property Installation: TJclBorRADToolInstallation read FInstallation;\r\n end;\r\n\r\n TJclBorRADToolIdeTool = class(TJclBorRADToolInstallationObject)\r\n private\r\n FKey: string;\r\n function GetCount: Integer;\r\n function GetParameters(Index: Integer): string;\r\n function GetPath(Index: Integer): string;\r\n function GetTitle(Index: Integer): string;\r\n function GetWorkingDir(Index: Integer): string;\r\n procedure SetCount(const Value: Integer);\r\n procedure SetParameters(Index: Integer; const Value: string);\r\n procedure SetPath(Index: Integer; const Value: string);\r\n procedure SetTitle(Index: Integer; const Value: string);\r\n procedure SetWorkingDir(Index: Integer; const Value: string);\r\n protected\r\n procedure CheckIndex(Index: Integer);\r\n public\r\n constructor Create(AInstallation: TJclBorRADToolInstallation);\r\n property Count: Integer read GetCount write SetCount;\r\n function IndexOfPath(const Value: string): Integer;\r\n function IndexOfTitle(const Value: string): Integer;\r\n procedure RemoveIndex(const Index: Integer);\r\n property Key: string read FKey;\r\n property Title[Index: Integer]: string read GetTitle write SetTitle;\r\n property Path[Index: Integer]: string read GetPath write SetPath;\r\n property Parameters[Index: Integer]: string read GetParameters write SetParameters;\r\n property WorkingDir[Index: Integer]: string read GetWorkingDir write SetWorkingDir;\r\n end;\r\n\r\n TJclBorRADToolIdePackages = class(TJclBorRADToolInstallationObject)\r\n private\r\n FDisabledPackages: TStringList;\r\n FKnownPackages: TStringList;\r\n FKnownIDEPackages: TStringList;\r\n FExperts: TStringList;\r\n function GetCount: Integer;\r\n function GetIDECount: Integer;\r\n function GetExpertCount: Integer;\r\n function GetPackageDescriptions(Index: Integer): string;\r\n function GetIDEPackageDescriptions(Index: Integer): string;\r\n function GetExpertDescriptions(Index: Integer): string;\r\n function GetPackageDisabled(Index: Integer): Boolean;\r\n function GetPackageFileNames(Index: Integer): string;\r\n function GetIDEPackageFileNames(Index: Integer): string;\r\n function GetExpertFileNames(Index: Integer): string;\r\n protected\r\n function PackageEntryToFileName(const Entry: string): string;\r\n procedure ReadPackages;\r\n procedure RemoveDisabled(const FileName: string);\r\n public\r\n constructor Create(AInstallation: TJclBorRADToolInstallation);\r\n destructor Destroy; override;\r\n function AddPackage(const FileName, Description: string): Boolean;\r\n function AddIDEPackage(const FileName, Description: string): Boolean;\r\n function AddExpert(const FileName, Description: string): Boolean;\r\n function RemovePackage(const FileName: string): Boolean;\r\n function RemoveIDEPackage(const FileName: string): Boolean;\r\n function RemoveExpert(const FileName: string): Boolean;\r\n property Count: Integer read GetCount;\r\n property IDECount: Integer read GetIDECount;\r\n property ExpertCount: Integer read GetExpertCount;\r\n property PackageDescriptions[Index: Integer]: string read GetPackageDescriptions;\r\n property IDEPackageDescriptions[Index: Integer]: string read GetIDEPackageDescriptions;\r\n property ExpertDescriptions[Index: Integer]: string read GetExpertDescriptions;\r\n property PackageFileNames[Index: Integer]: string read GetPackageFileNames;\r\n property IDEPackageFileNames[Index: Integer]: string read GetIDEPackageFileNames;\r\n property ExpertFileNames[Index: Integer]: string read GetExpertFileNames;\r\n property PackageDisabled[Index: Integer]: Boolean read GetPackageDisabled;\r\n end;\r\n\r\n TJclBorRADToolPalette = class(TJclBorRADToolInstallationObject)\r\n private\r\n FKey: string;\r\n FTabNames: TStringList;\r\n function GetComponentsOnTab(Index: Integer): string;\r\n function GetHiddenComponentsOnTab(Index: Integer): string;\r\n function GetTabNameCount: Integer;\r\n function GetTabNames(Index: Integer): string;\r\n procedure ReadTabNames;\r\n public\r\n constructor Create(AInstallation: TJclBorRADToolInstallation);\r\n destructor Destroy; override;\r\n procedure ComponentsOnTabToStrings(Index: Integer; Strings: TStrings; IncludeUnitName: Boolean = False;\r\n IncludeHiddenComponents: Boolean = True);\r\n function DeleteTabName(const TabName: string): Boolean;\r\n function TabNameExists(const TabName: string): Boolean;\r\n property ComponentsOnTab[Index: Integer]: string read GetComponentsOnTab;\r\n property HiddenComponentsOnTab[Index: Integer]: string read GetHiddenComponentsOnTab;\r\n property Key: string read FKey;\r\n property TabNames[Index: Integer]: string read GetTabNames;\r\n property TabNameCount: Integer read GetTabNameCount;\r\n end;\r\n\r\n TJclBorRADToolRepository = class(TJclBorRADToolInstallationObject)\r\n private\r\n FIniFile: TIniFile;\r\n FFileName: string;\r\n FPages: TStringList;\r\n function GetIniFile: TIniFile;\r\n function GetPages: TStrings;\r\n public\r\n constructor Create(AInstallation: TJclBorRADToolInstallation);\r\n destructor Destroy; override;\r\n procedure AddObject(const FileName, ObjectType, PageName, ObjectName, IconFileName, Description,\r\n Author, Designer: string; const Ancestor: string = '');\r\n procedure CloseIniFile;\r\n function FindPage(const Name: string; OptionalIndex: Integer): string;\r\n procedure RemoveObjects(const PartialPath, FileName, ObjectType: string);\r\n property FileName: string read FFileName;\r\n property IniFile: TIniFile read GetIniFile;\r\n property Pages: TStrings read GetPages;\r\n end;\r\n\r\n TCommandLineTool = (clAsm, clBcc32, clBcc64, clDcc32, clDcc64, clDccOSX32, clDccIL, clMake, clProj2Mak);\r\n TCommandLineTools = set of TCommandLineTool;\r\n\r\n TJclBorRADToolInstallationClass = class of TJclBorRADToolInstallation;\r\n\r\n TJclBorRADToolInstallation = class(TObject)\r\n private\r\n FConfigData: TCustomIniFile;\r\n FConfigDataLocation: string;\r\n FRootKey: Cardinal;\r\n FGlobals: TStringList;\r\n FRootDir: string;\r\n FBinFolderName: string;\r\n FBCC32: TJclBCC32;\r\n FDCC: TJclDCC32;\r\n FDCC32: TJclDCC32;\r\n FBpr2Mak: TJclBpr2Mak;\r\n FMake: IJclCommandLineTool;\r\n FEditionStr: string;\r\n FEdition: TJclBorRADToolEdition;\r\n FEnvironmentVariables: TStringList;\r\n FIdePackages: TJclBorRADToolIdePackages;\r\n FIdeTools: TJclBorRADToolIdeTool;\r\n FInstalledUpdatePack: Integer;\r\n {$IFDEF MSWINDOWS}\r\n FOpenHelp: TJclBorlandOpenHelp;\r\n {$ENDIF MSWINDOWS}\r\n FPalette: TJclBorRADToolPalette;\r\n FRepository: TJclBorRADToolRepository;\r\n FVersionNumber: Integer; // Delphi 2005: 3 - Delphi 7: 7 - Delphi 2007: 11\r\n FVersionNumberStr: string;\r\n FIDEVersionNumber: Integer; // Delphi 2005: 3 - Delphi 7: 7 - Delphi 2007: 11\r\n FIDEVersionNumberStr: string;\r\n FMapCreate: Boolean;\r\n {$IFDEF MSWINDOWS}\r\n FJdbgCreate: Boolean;\r\n FJdbgInsert: Boolean;\r\n FMapDelete: Boolean;\r\n {$ENDIF MSWINDOWS}\r\n FCommandLineTools: TCommandLineTools;\r\n FPersonalities: TJclBorPersonalities;\r\n FOutputCallback: TTextHandler;\r\n function GetSupportsLibSuffix: Boolean;\r\n function GetBCC32: TJclBCC32;\r\n function GetDCC: TJclDCC32;\r\n function GetDCC32: TJclDCC32;\r\n function GetBpr2Mak: TJclBpr2Mak;\r\n function GetMake: IJclCommandLineTool;\r\n function GetDescription: string;\r\n function GetEditionAsText: string;\r\n function GetIdeExeFileName: string;\r\n function GetGlobals: TStrings;\r\n function GetIdeExeBuildNumber: string;\r\n function GetIdePackages: TJclBorRADToolIdePackages;\r\n function GetIsTurboExplorer: Boolean;\r\n function GetLatestUpdatePack: Integer;\r\n function GetPalette: TJclBorRADToolPalette;\r\n function GetRepository: TJclBorRADToolRepository;\r\n function GetUpdateNeeded: Boolean;\r\n function GetDefaultBDSCommonDir: string;\r\n procedure SetDCC(const Value: TJclDCC32);\r\n protected\r\n function ProcessMapFile(const BinaryFileName: string): Boolean;\r\n\r\n // compilation functions\r\n function CompileDelphiPackage(const PackageName, BPLPath, DCPPath: string): Boolean; overload; virtual;\r\n function CompileDelphiPackage(const PackageName, BPLPath, DCPPath, ExtraOptions: string): Boolean;\r\n overload; virtual;\r\n function CompileDelphiProject(const ProjectName, OutputDir, DcpSearchPath: string): Boolean; virtual;\r\n function CompileBCBPackage(const PackageName, BPLPath, DCPPath: string): Boolean; virtual;\r\n function CompileBCBProject(const ProjectName, OutputDir, DcpSearchPath: string): Boolean; virtual;\r\n\r\n // installation (=compilation+registration) / uninstallation(=unregistration+deletion) functions\r\n function InstallDelphiPackage(const PackageName, BPLPath, DCPPath: string): Boolean; virtual;\r\n function UninstallDelphiPackage(const PackageName, BPLPath, DCPPath: string): Boolean; virtual;\r\n function InstallBCBPackage(const PackageName, BPLPath, DCPPath: string): Boolean; virtual;\r\n function UninstallBCBPackage(const PackageName, BPLPath, DCPPath: string): Boolean; virtual;\r\n function InstallDelphiIdePackage(const PackageName, BPLPath, DCPPath: string): Boolean; virtual;\r\n function UninstallDelphiIdePackage(const PackageName, BPLPath, DCPPath: string): Boolean; virtual;\r\n function InstallBCBIdePackage(const PackageName, BPLPath, DCPPath: string): Boolean; virtual;\r\n function UninstallBCBIdePackage(const PackageName, BPLPath, DCPPath: string): Boolean; virtual;\r\n function InstallDelphiExpert(const ProjectName, OutputDir, DcpSearchPath: string): Boolean; virtual;\r\n function UninstallDelphiExpert(const ProjectName, OutputDir: string): Boolean; virtual;\r\n function InstallBCBExpert(const ProjectName, OutputDir, DcpSearchPath: string): Boolean; virtual;\r\n function UninstallBCBExpert(const ProjectName, OutputDir: string): Boolean; virtual;\r\n\r\n procedure ReadInformation;\r\n //function AddMissingPathItems(var Path: string; const NewPath: string): Boolean;\r\n function RemoveFromPath(var Path: string; const ItemsToRemove: string): Boolean;\r\n function GetDCPOutputPath(APlatform: TJclBDSPlatform): string; virtual;\r\n function GetBPLOutputPath(APlatform: TJclBDSPlatform): string; virtual;\r\n function GetEnvironmentVariables: TStrings; virtual;\r\n function GetVclIncludeDir(APlatform: TJclBDSPlatform): string; virtual;\r\n function GetName: string; virtual;\r\n procedure OutputString(const AText: string);\r\n function OutputFileDelete(const FileName: string): Boolean;\r\n procedure SetOutputCallback(const Value: TTextHandler); virtual;\r\n\r\n function GetDebugDCUPath(APlatform: TJclBDSPlatform): TJclBorRADToolPath; virtual;\r\n function GetRawDebugDCUPath(APlatform: TJclBDSPlatform): TJclBorRADToolPath; virtual;\r\n procedure SetRawDebugDCUPath(APlatform: TJclBDSPlatform; const Value: TJclBorRADToolPath); virtual;\r\n function GetLibrarySearchPath(APlatform: TJclBDSPlatform): TJclBorRADToolPath; virtual;\r\n function GetRawLibrarySearchPath(APlatform: TJclBDSPlatform): TJclBorRADToolPath; virtual;\r\n procedure SetRawLibrarySearchPath(APlatform: TJclBDSPlatform; const Value: TJclBorRADToolPath); virtual;\r\n function GetLibraryBrowsingPath(APlatform: TJclBDSPlatform): TJclBorRADToolPath; virtual;\r\n function GetRawLibraryBrowsingPath(APlatform: TJclBDSPlatform): TJclBorRADToolPath; virtual;\r\n procedure SetRawLibraryBrowsingPath(APlatform: TJclBDSPlatform; const Value: TJclBorRADToolPath); virtual;\r\n\r\n function GetLibFolderName(APlatform: TJclBDSPlatform): string; virtual;\r\n function GetObjFolderName(APlatform: TJclBDSPlatform): string; virtual;\r\n function GetLibDebugFolderName(APlatform: TJclBDSPlatform): string; virtual;\r\n\r\n function GetValid: Boolean; virtual;\r\n function GetLongPathBug: Boolean;\r\n function GetCompilerSettingsFormat: TJclCompilerSettingsFormat;\r\n function GetSupportsNoConfig: Boolean;\r\n function GetSupportsPlatform: Boolean;\r\n\r\n procedure CheckPlatform(APlatform: TJclBDSPlatform);\r\n procedure CheckCBuilderPlatform(APlatform: TJclBDSPlatform);\r\n public\r\n constructor Create(const AConfigDataLocation: string; ARootKey: Cardinal = 0); virtual;\r\n\r\n destructor Destroy; override;\r\n class procedure ExtractPaths(const Path: TJclBorRADToolPath; List: TStrings);\r\n class function GetLatestUpdatePackForVersion(Version: Integer): Integer; virtual;\r\n class function PackageSourceFileExtension: string; virtual;\r\n class function ProjectSourceFileExtension: string; virtual;\r\n class function RadToolKind: TJclBorRadToolKind; virtual;\r\n {class} function RadToolName: string; virtual;\r\n function AnyInstanceRunning: Boolean;\r\n function AddToDebugDCUPath(const Path: string; APlatform: TJclBDSPlatform): Boolean;\r\n function AddToLibrarySearchPath(const Path: string; APlatform: TJclBDSPlatform): Boolean;\r\n function AddToLibraryBrowsingPath(const Path: string; APlatform: TJclBDSPlatform): Boolean;\r\n function FindFolderInPath(Folder: string; List: TStrings): Integer;\r\n // package functions\r\n // install = package compile + registration\r\n // uninstall = unregistration + deletion\r\n function CompilePackage(const PackageName, BPLPath, DCPPath: string): Boolean; virtual;\r\n function InstallPackage(const PackageName, BPLPath, DCPPath: string): Boolean; virtual;\r\n function UninstallPackage(const PackageName, BPLPath, DCPPath: string): Boolean; virtual;\r\n function InstallIDEPackage(const PackageName, BPLPath, DCPPath: string): Boolean; virtual;\r\n function UninstallIDEPackage(const PackageName, BPLPath, DCPPath: string): Boolean; virtual;\r\n\r\n // project functions\r\n function CompileProject(const ProjectName, OutputDir, DcpSearchPath: string): Boolean; virtual;\r\n // expert functions\r\n // install = project compile + registration\r\n // uninstall = unregistration + deletion\r\n function InstallExpert(const ProjectName, OutputDir, DcpSearchPath: string): Boolean; virtual;\r\n function UninstallExpert(const ProjectName, OutputDir: string): Boolean; virtual;\r\n\r\n // registration/unregistration functions\r\n function RegisterPackage(const BinaryFileName, Description: string): Boolean; overload; virtual;\r\n function RegisterPackage(const PackageName, BPLPath, Description: string): Boolean; overload; virtual;\r\n function UnregisterPackage(const BinaryFileName: string): Boolean; overload; virtual;\r\n function UnregisterPackage(const PackageName, BPLPath: string): Boolean; overload; virtual;\r\n function RegisterIDEPackage(const BinaryFileName, Description: string): Boolean; overload; virtual;\r\n function RegisterIDEPackage(const PackageName, BPLPath, Description: string): Boolean; overload; virtual;\r\n function UnregisterIDEPackage(const BinaryFileName: string): Boolean; overload; virtual;\r\n function UnregisterIDEPackage(const PackageName, BPLPath: string): Boolean; overload; virtual;\r\n function RegisterExpert(const BinaryFileName, Description: string): Boolean; overload; virtual;\r\n function RegisterExpert(const ProjectName, OutputDir, Description: string): Boolean; overload; virtual;\r\n function UnregisterExpert(const BinaryFileName: string): Boolean; overload; virtual;\r\n function UnregisterExpert(const ProjectName, OutputDir: string): Boolean; overload; virtual;\r\n\r\n function GetDefaultProjectsDir: string; virtual;\r\n function GetCommonProjectsDir: string; virtual;\r\n function RemoveFromDebugDCUPath(const Path: string; APlatform: TJclBDSPlatform): Boolean;\r\n function RemoveFromLibrarySearchPath(const Path: string; APlatform: TJclBDSPlatform): Boolean;\r\n function RemoveFromLibraryBrowsingPath(const Path: string; APlatform: TJclBDSPlatform): Boolean;\r\n function SubstitutePath(const Path: string): string;\r\n function SupportsVisualCLX: Boolean;\r\n function SupportsVCL: Boolean;\r\n property LibFolderName[APlatform: TJclBDSPlatform]: string read GetLibFolderName;\r\n property ObjFolderName[APlatform: TJclBDSPlatform]: string read GetObjFolderName;\r\n property LibDebugFolderName[APlatform: TJclBDSPlatform]: string read GetLibDebugFolderName;\r\n // Command line tools\r\n property CommandLineTools: TCommandLineTools read FCommandLineTools;\r\n property BCC32: TJclBCC32 read GetBCC32;\r\n property DCC: TJclDCC32 read GetDCC write SetDCC;\r\n property DCC32: TJclDCC32 read GetDCC32;\r\n property Bpr2Mak: TJclBpr2Mak read GetBpr2Mak;\r\n property Make: IJclCommandLineTool read GetMake;\r\n // Paths\r\n property BinFolderName: string read FBinFolderName;\r\n property BPLOutputPath[APlatform: TJclBDSPlatform]: string read GetBPLOutputPath;\r\n property DebugDCUPath[APlatform: TJclBDSPlatform]: TJclBorRADToolPath read GetDebugDCUPath {$IFDEF KEEP_DEPRECATED}write SetRawDebugDCUPath{$ENDIF};\r\n property RawDebugDCUPath[APlatform: TJclBDSPlatform]: TJclBorRADToolPath read GetRawDebugDCUPath write SetRawDebugDCUPath;\r\n property DCPOutputPath[APlatform: TJclBDSPlatform]: string read GetDCPOutputPath;\r\n property DefaultProjectsDir: string read GetDefaultProjectsDir;\r\n property CommonProjectsDir: string read GetCommonProjectsDir;\r\n //\r\n property Description: string read GetDescription;\r\n property Edition: TJclBorRADToolEdition read FEdition;\r\n property EditionAsText: string read GetEditionAsText;\r\n property EnvironmentVariables: TStrings read GetEnvironmentVariables;\r\n property IdePackages: TJclBorRADToolIdePackages read GetIdePackages;\r\n property IdeTools: TJclBorRADToolIdeTool read FIdeTools;\r\n property IdeExeBuildNumber: string read GetIdeExeBuildNumber;\r\n property IdeExeFileName: string read GetIdeExeFileName;\r\n property InstalledUpdatePack: Integer read FInstalledUpdatePack;\r\n property LatestUpdatePack: Integer read GetLatestUpdatePack;\r\n property LibrarySearchPath[APlatform: TJclBDSPlatform]: TJclBorRADToolPath read GetLibrarySearchPath {$IFDEF KEEP_DEPRECATED}write SetRawLibrarySearchPath{$ENDIF};\r\n property RawLibrarySearchPath[APlatform: TJclBDSPlatform]: TJclBorRADToolPath read GetRawLibrarySearchPath write SetRawLibrarySearchPath;\r\n property LibraryBrowsingPath[APlatform: TJclBDSPlatform]: TJclBorRADToolPath read GetLibraryBrowsingPath {$IFDEF KEEP_DEPRECATED}write SetRawLibraryBrowsingPath{$ENDIF};\r\n property RawLibraryBrowsingPath[APlatform: TJclBDSPlatform]: TJclBorRADToolPath read GetRawLibraryBrowsingPath write SetRawLibraryBrowsingPath;\r\n {$IFDEF MSWINDOWS}\r\n property OpenHelp: TJclBorlandOpenHelp read FOpenHelp;\r\n {$ENDIF MSWINDOWS}\r\n property MapCreate: Boolean read FMapCreate write FMapCreate;\r\n {$IFDEF MSWINDOWS}\r\n property JdbgCreate: Boolean read FJdbgCreate write FJdbgCreate;\r\n property JdbgInsert: Boolean read FJdbgInsert write FJdbgInsert;\r\n property MapDelete: Boolean read FMapDelete write FMapDelete;\r\n {$ENDIF MSWINDOWS}\r\n property ConfigData: TCustomIniFile read FConfigData;\r\n property ConfigDataLocation: string read FConfigDataLocation;\r\n property Globals: TStrings read GetGlobals;\r\n property Name: string read GetName;\r\n property Palette: TJclBorRADToolPalette read GetPalette;\r\n property Repository: TJclBorRADToolRepository read GetRepository;\r\n property RootDir: string read FRootDir;\r\n property UpdateNeeded: Boolean read GetUpdateNeeded;\r\n property Valid: Boolean read GetValid;\r\n property VclIncludeDir[APlatform: TJclBDSPlatform]: string read GetVclIncludeDir;\r\n property IDEVersionNumber: Integer read FIDEVersionNumber;\r\n property IDEVersionNumberStr: string read FIDEVersionNumberStr;\r\n property VersionNumber: Integer read FVersionNumber;\r\n property VersionNumberStr: string read FVersionNumberStr;\r\n property Personalities: TJclBorPersonalities read FPersonalities;\r\n property SupportsLibSuffix: Boolean read GetSupportsLibSuffix;\r\n property OutputCallback: TTextHandler read FOutputCallback write SetOutputCallback;\r\n property IsTurboExplorer: Boolean read GetIsTurboExplorer;\r\n property RootKey: Cardinal read FRootKey;\r\n property LongPathBug: Boolean read GetLongPathBug;\r\n property CompilerSettingsFormat: TJclCompilerSettingsFormat read GetCompilerSettingsFormat;\r\n property SupportsNoConfig: Boolean read GetSupportsNoConfig;\r\n property SupportsPlatform: Boolean read GetSupportsPlatform;\r\n end;\r\n\r\n TJclBCBInstallation = class(TJclBorRADToolInstallation)\r\n protected\r\n function GetEnvironmentVariables: TStrings; override;\r\n public\r\n constructor Create(const AConfigDataLocation: string; ARootKey: Cardinal = 0); override;\r\n destructor Destroy; override;\r\n class function PackageSourceFileExtension: string; override;\r\n class function ProjectSourceFileExtension: string; override;\r\n class function RadToolKind: TJclBorRadToolKind; override;\r\n {class }function RadToolName: string; override;\r\n class function GetLatestUpdatePackForVersion(Version: Integer): Integer; override;\r\n end;\r\n\r\n TJclDelphiInstallation = class(TJclBorRADToolInstallation)\r\n protected\r\n function GetEnvironmentVariables: TStrings; override;\r\n public\r\n constructor Create(const AConfigDataLocation: string; ARootKey: Cardinal = 0); override;\r\n destructor Destroy; override;\r\n class function PackageSourceFileExtension: string; override;\r\n class function ProjectSourceFileExtension: string; override;\r\n class function RadToolKind: TJclBorRadToolKind; override;\r\n class function GetLatestUpdatePackForVersion(Version: Integer): Integer; override;\r\n function InstallPackage(const PackageName, BPLPath, DCPPath: string): Boolean; reintroduce;\r\n {class }function RadToolName: string; override;\r\n end;\r\n\r\n {$IFDEF MSWINDOWS}\r\n TJclBDSInstallation = class(TJclBorRADToolInstallation)\r\n private\r\n FDualPackageInstallation: Boolean;\r\n FHelp2Manager: TJclHelp2Manager;\r\n FDCCIL: TJclDCCIL;\r\n FDCC64: TJclDCC64;\r\n FDCCOSX32: TJclDCCOSX32;\r\n FBCC64: TJclBCC64;\r\n FPdbCreate: Boolean;\r\n procedure SetDualPackageInstallation(const Value: Boolean);\r\n function GetCppPathsKeyName: string;\r\n function GetCppBrowsingPath(APlatform: TJclBDSPlatform): TJclBorRADToolPath;\r\n function GetRawCppBrowsingPath(APlatform: TJclBDSPlatform): TJclBorRADToolPath;\r\n function GetCppSearchPath(APlatform: TJclBDSPlatform): TJclBorRADToolPath;\r\n function GetRawCppSearchPath(APlatform: TJclBDSPlatform): TJclBorRADToolPath;\r\n function GetCppLibraryPath(APlatform: TJclBDSPlatform): TJclBorRADToolPath;\r\n function GetRawCppLibraryPath(APlatform: TJclBDSPlatform): TJclBorRADToolPath;\r\n function GetCppIncludePath(APlatform: TJclBDSPlatform): TJclBorRADToolPath;\r\n function GetRawCppIncludePath(APlatform: TJclBDSPlatform): TJclBorRADToolPath;\r\n procedure SetRawCppBrowsingPath(APlatform: TJclBDSPlatform; const Value: TJclBorRADToolPath);\r\n procedure SetRawCppSearchPath(APlatform: TJclBDSPlatform; const Value: TJclBorRADToolPath);\r\n procedure SetRawCppLibraryPath(APlatform: TJclBDSPlatform; const Value: TJclBorRADToolPath);\r\n procedure SetRawCppIncludePath(APlatform: TJclBDSPlatform; const Value: TJclBorRADToolPath);\r\n function GetMaxDelphiCLRVersion: string;\r\n function GetDCC64: TJclDCC64;\r\n function GetDCCOSX32: TJclDCCOSX32;\r\n function GetDCCIL: TJclDCCIL;\r\n function GetBCC64: TJclBCC64;\r\n\r\n function GetMsBuildEnvOptionsFileName: string;\r\n function GetMsBuildEnvironmentFileName: string;\r\n function GetMsBuildEnvOption(const OptionName: string; APlatform: TJclBDSPlatform; Raw: Boolean): string;\r\n procedure SetMsBuildEnvOption(const OptionName, Value: string; APlatform: TJclBDSPlatform);\r\n function GetBDSPlatformStr(APlatform: TJclBDSPlatform): string;\r\n protected\r\n function GetDCPOutputPath(APlatform: TJclBDSPlatform): string; override;\r\n function GetBPLOutputPath(APlatform: TJclBDSPlatform): string; override;\r\n function GetEnvironmentVariables: TStrings; override;\r\n function CompileDelphiPackage(const PackageName, BPLPath, DCPPath, ExtraOptions: string): Boolean; override;\r\n function CompileDelphiProject(const ProjectName, OutputDir: string;\r\n const DcpSearchPath: string): Boolean; override;\r\n function GetVclIncludeDir(APlatform: TJclBDSPlatform): string; override;\r\n function GetName: string; override;\r\n procedure SetOutputCallback(const Value: TTextHandler); override;\r\n function GetLibDebugFolderName(APlatform: TJclBDSPlatform): string; override;\r\n function GetLibFolderName(APlatform: TJclBDSPlatform): string; override;\r\n\r\n function GetDebugDCUPath(APlatform: TJclBDSPlatform): TJclBorRADToolPath; override;\r\n function GetRawDebugDCUPath(APlatform: TJclBDSPlatform): TJclBorRADToolPath; override;\r\n procedure SetRawDebugDCUPath(APlatform: TJclBDSPlatform; const Value: TJclBorRADToolPath); override;\r\n function GetLibrarySearchPath(APlatform: TJclBDSPlatform): TJclBorRADToolPath; override;\r\n function GetRawLibrarySearchPath(APlatform: TJclBDSPlatform): TJclBorRADToolPath; override;\r\n procedure SetRawLibrarySearchPath(APlatform: TJclBDSPlatform; const Value: TJclBorRADToolPath); override;\r\n function GetLibraryBrowsingPath(APlatform: TJclBDSPlatform): TJclBorRADToolPath; override;\r\n function GetRawLibraryBrowsingPath(APlatform: TJclBDSPlatform): TJclBorRADToolPath; override;\r\n procedure SetRawLibraryBrowsingPath(APlatform: TJclBDSPlatform; const Value: TJclBorRADToolPath); override;\r\n\r\n function GetValid: Boolean; override;\r\n public\r\n constructor Create(const AConfigDataLocation: string; ARootKey: Cardinal = 0); override;\r\n destructor Destroy; override;\r\n class function PackageSourceFileExtension: string; override;\r\n class function ProjectSourceFileExtension: string; override;\r\n class function RadToolKind: TJclBorRadToolKind; override;\r\n class function GetLatestUpdatePackForVersion(Version: Integer): Integer; override;\r\n function GetDefaultProjectsDir: string; override;\r\n function GetCommonProjectsDir: string; override;\r\n class function GetDefaultProjectsDirectory(const RootDir: string; IDEVersionNumber: Integer): string;\r\n class function GetCommonProjectsDirectory(const RootDir: string; IDEVersionNumber: Integer): string;\r\n class procedure GetRADStudioVars(const RootDir: string; IDEVersionNumber: Integer; Variables: TStrings);\r\n class function GetRADStudioVarsFileName(const RootDir: string; IDEVersionNumber: Integer): TFileName;\r\n {class }function RadToolName: string; overload; override;\r\n class function RadToolName(IDEVersionNumber: Integer): string; reintroduce; overload;\r\n\r\n function AddToCppSearchPath(const Path: string; APlatform: TJclBDSPlatform): Boolean;\r\n function AddToCppBrowsingPath(const Path: string; APlatform: TJclBDSPlatform): Boolean;\r\n function AddToCppLibraryPath(const Path: string; APlatform: TJclBDSPlatform): Boolean;\r\n function AddToCppIncludePath(const Path: string; APlatform: TJclBDSPlatform): Boolean;\r\n function RemoveFromCppSearchPath(const Path: string; APlatform: TJclBDSPlatform): Boolean;\r\n function RemoveFromCppBrowsingPath(const Path: string; APlatform: TJclBDSPlatform): Boolean;\r\n function RemoveFromCppLibraryPath(const Path: string; APlatform: TJclBDSPlatform): Boolean;\r\n function RemoveFromCppIncludePath(const Path: string; APlatform: TJclBDSPlatform): Boolean;\r\n\r\n property CppSearchPath[APlatform: TJclBDSPlatform]: TJclBorRADToolPath read GetCppSearchPath {$IFDEF KEEP_DEPRECATED}write SetRawCppSearchPath{$ENDIF};\r\n property RawCppSearchPath[APlatform: TJclBDSPlatform]: TJclBorRADToolPath read GetRawCppSearchPath write SetRawCppSearchPath;\r\n property CppBrowsingPath[APlatform: TJclBDSPlatform]: TJclBorRADToolPath read GetCppBrowsingPath {$IFDEF KEEP_DEPRECATED}write SetRawCppBrowsingPath{$ENDIF};\r\n property RawCppBrowsingPath[APlatform: TJclBDSPlatform]: TJclBorRADToolPath read GetRawCppBrowsingPath write SetRawCppBrowsingPath;\r\n // Only exists in BDS 5 and upper\r\n property CppLibraryPath[APlatform: TJclBDSPlatform]: TJclBorRADToolPath read GetCppLibraryPath {$IFDEF KEEP_DEPRECATED}write SetRawCppLibraryPath{$ENDIF};\r\n property RawCppLibraryPath[APlatform: TJclBDSPlatform]: TJclBorRADToolPath read GetRawCppLibraryPath write SetRawCppLibraryPath;\r\n property CppIncludePath[APlatform: TJclBDSPlatform]: TJclBorRADToolPath read GetCppIncludePath {$IFDEF KEEP_DEPRECATED}write SetRawCppIncludePath{$ENDIF};\r\n property RawCppIncludePath[APlatform: TJclBDSPlatform]: TJclBorRADToolPath read GetRawCppIncludePath write SetRawCppIncludePath;\r\n\r\n function RegisterPackage(const BinaryFileName, Description: string): Boolean; override;\r\n function UnregisterPackage(const BinaryFileName: string): Boolean; override;\r\n function CleanPackageCache(const BinaryFileName: string): Boolean;\r\n\r\n function CompileDelphiDotNetProject(const ProjectName, OutputDir: string; PEFormat: TJclBDSPlatform = bpWin32;\r\n const ExtraOptions: string = ''): Boolean;\r\n\r\n property DualPackageInstallation: Boolean read FDualPackageInstallation write SetDualPackageInstallation;\r\n property Help2Manager: TJclHelp2Manager read FHelp2Manager;\r\n property DCC64: TJclDCC64 read GetDCC64;\r\n property DCCOSX32: TJclDCCOSX32 read GetDCCOSX32;\r\n property BCC64: TJclBCC64 read GetBCC64;\r\n property DCCIL: TJclDCCIL read GetDCCIL;\r\n property MaxDelphiCLRVersion: string read GetMaxDelphiCLRVersion;\r\n property PdbCreate: Boolean read FPdbCreate write FPdbCreate;\r\n end;\r\n {$ENDIF MSWINDOWS}\r\n\r\n TTraverseMethod = function(Installation: TJclBorRADToolInstallation): Boolean of object;\r\n\r\n TJclBorRADToolInstallations = class(TObject)\r\n private\r\n FList: TObjectList;\r\n function GetBDSInstallationFromVersion(\r\n VersionNumber: Integer): TJclBorRADToolInstallation;\r\n function GetBDSVersionInstalled(VersionNumber: Integer): Boolean;\r\n function GetCount: Integer;\r\n function GetInstallations(Index: Integer): TJclBorRADToolInstallation;\r\n function GetBCBVersionInstalled(VersionNumber: Integer): Boolean;\r\n function GetDelphiVersionInstalled(VersionNumber: Integer): Boolean;\r\n function GetBCBInstallationFromVersion(VersionNumber: Integer): TJclBorRADToolInstallation;\r\n function GetDelphiInstallationFromVersion(VersionNumber: Integer): TJclBorRADToolInstallation;\r\n protected\r\n procedure ReadInstallations;\r\n public\r\n constructor Create;\r\n destructor Destroy; override;\r\n function AnyInstanceRunning: Boolean;\r\n function AnyUpdatePackNeeded(var Text: string): Boolean;\r\n function Iterate(TraverseMethod: TTraverseMethod): Boolean;\r\n property Count: Integer read GetCount;\r\n property Installations[Index: Integer]: TJclBorRADToolInstallation read GetInstallations; default;\r\n property BCBInstallationFromVersion[VersionNumber: Integer]: TJclBorRADToolInstallation\r\n read GetBCBInstallationFromVersion;\r\n property DelphiInstallationFromVersion[VersionNumber: Integer]: TJclBorRADToolInstallation\r\n read GetDelphiInstallationFromVersion;\r\n property BDSInstallationFromVersion[VersionNumber: Integer]: TJclBorRADToolInstallation\r\n read GetBDSInstallationFromVersion;\r\n property BCBVersionInstalled[VersionNumber: Integer]: Boolean read GetBCBVersionInstalled;\r\n property DelphiVersionInstalled[VersionNumber: Integer]: Boolean read GetDelphiVersionInstalled;\r\n property BDSVersionInstalled[VersionNumber: Integer]: Boolean read GetBDSVersionInstalled;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jcl.svn.sourceforge.net/svnroot/jcl/tags/JCL-2.4-Build4571/jcl/source/common/JclIDEUtils.pas $';\r\n Revision: '$Revision: 3861 $';\r\n Date: '$Date: 2012-09-04 16:08:04 +0200 (mar. 04 sept. 2012) $';\r\n LogPath: 'JCL\\source\\common';\r\n Extra: '';\r\n Data: nil\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n {$IFDEF HAS_UNITSCOPE}\r\n System.SysConst,\r\n {$IFDEF MSWINDOWS}\r\n System.Win.Registry,\r\n JclRegistry,\r\n JclDebug,\r\n {$ENDIF MSWINDOWS}\r\n {$ELSE ~HAS_UNITSCOPE}\r\n SysConst,\r\n {$IFDEF MSWINDOWS}\r\n Registry,\r\n JclRegistry,\r\n JclDebug,\r\n {$ENDIF MSWINDOWS}\r\n {$ENDIF ~HAS_UNITSCOPE}\r\n {$IFDEF HAS_UNIT_LIBC}\r\n Libc,\r\n {$ENDIF HAS_UNIT_LIBC}\r\n JclFileUtils, JclLogic, JclDevToolsResources,\r\n JclAnsiStrings, JclWideStrings, JclStrings,\r\n JclSysInfo, JclMsBuild, JclSimpleXml;\r\n\r\n// Internal\r\n\r\n{$IFDEF MSWINDOWS}\r\ntype\r\n TBDSVersionInfo = record\r\n Name: PResStringRec;\r\n VersionStr: string;\r\n Version: Integer;\r\n CoreIdeVersion: string;\r\n Supported: Boolean;\r\n end;\r\n{$ENDIF MSWINDOWS}\r\n\r\nconst\r\n {$IFDEF MSWINDOWS}\r\n BCBKeyName = '\\SOFTWARE\\Borland\\C++Builder';\r\n BDSKeyName = '\\SOFTWARE\\Borland\\BDS';\r\n CDSKeyName = '\\SOFTWARE\\CodeGear\\BDS';\r\n EDSKeyName = '\\SOFTWARE\\Embarcadero\\BDS';\r\n DelphiKeyName = '\\SOFTWARE\\Borland\\Delphi';\r\n\r\n RADStudioDirName = 'RAD Studio';\r\n\r\n BDSVersions: array [1..10] of TBDSVersionInfo = (\r\n (\r\n Name: @RsCSharpName;\r\n VersionStr: '1.0';\r\n Version: 1;\r\n CoreIdeVersion: '71';\r\n Supported: True),\r\n (\r\n Name: @RsDelphiName;\r\n VersionStr: '8';\r\n Version: 8;\r\n CoreIdeVersion: '71';\r\n Supported: True),\r\n (\r\n Name: @RsDelphiName;\r\n VersionStr: '2005';\r\n Version: 9;\r\n CoreIdeVersion: '90';\r\n Supported: True),\r\n (\r\n Name: @RsBDSName;\r\n VersionStr: '2006';\r\n Version: 10;\r\n CoreIdeVersion: '100';\r\n Supported: True),\r\n (\r\n Name: @RsRSName;\r\n VersionStr: '2007';\r\n Version: 11;\r\n CoreIdeVersion: '100';\r\n Supported: True),\r\n (\r\n Name: @RsRSName;\r\n VersionStr: '2009';\r\n Version: 12;\r\n CoreIdeVersion: '120';\r\n Supported: True),\r\n (\r\n Name: @RsRSName;\r\n VersionStr: '2010';\r\n Version: 14;\r\n CoreIdeVersion: '140';\r\n Supported: True),\r\n (\r\n Name: @RsRSName;\r\n VersionStr: 'XE';\r\n Version: 15;\r\n CoreIdeVersion: '150';\r\n Supported: True),\r\n (\r\n Name: @RsRSName;\r\n VersionStr: 'XE2';\r\n Version: 16;\r\n CoreIdeVersion: '160';\r\n Supported: True),\r\n (\r\n Name: @RsRSName;\r\n VersionStr: 'XE3';\r\n Version: 17;\r\n CoreIdeVersion: '170';\r\n Supported: True)\r\n );\r\n {$ENDIF MSWINDOWS}\r\n\r\n RootDirValueName = 'RootDir';\r\n\r\n EditionValueName = 'Edition';\r\n VersionValueName = 'Version';\r\n\r\n DebuggingKeyName = 'Debugging';\r\n DebugDCUPathValueName = 'Debug DCUs Path';\r\n\r\n GlobalsKeyName = 'Globals';\r\n\r\n LibraryKeyName = 'Library';\r\n LibrarySearchPathValueName = 'Search Path';\r\n LibraryBrowsingPathValueName = 'Browsing Path';\r\n LibraryBPLOutputValueName = 'Package DPL Output';\r\n LibraryDCPOutputValueName = 'Package DCP Output';\r\n BDSDebugDCUPathValueName = 'Debug DCU Path';\r\n\r\n CppPathsKeyName = 'CppPaths';\r\n CppPathsV5UpperKeyName = 'C++\\Paths';\r\n CppBrowsingPathValueName = 'BrowsingPath';\r\n CppSearchPathValueName = 'SearchPath';\r\n CppLibraryPathValueName = 'LibraryPath';\r\n CppIncludePathValueName = 'IncludePath';\r\n\r\n TransferKeyName = 'Transfer';\r\n TransferCountValueName = 'Count';\r\n TransferPathValueName = 'Path%d';\r\n TransferParamsValueName = 'Params%d';\r\n TransferTitleValueName = 'Title%d';\r\n TransferWorkDirValueName = 'WorkingDir%d';\r\n\r\n DisabledPackagesKeyName = 'Disabled Packages';\r\n EnvVariablesKeyName = 'Environment Variables';\r\n EnvVariableBDSValueName = 'BDS';\r\n EnvVariableBDSPROJDIRValueName = 'BDSPROJECTSDIR';\r\n EnvVariableBDSCOMDIRValueName = 'BDSCOMMONDIR';\r\n KnownPackagesKeyName = 'Known Packages';\r\n KnownIDEPackagesKeyName = 'Known IDE Packages';\r\n ExpertsKeyName = 'Experts';\r\n PackageCacheKeyName = 'Package Cache';\r\n\r\n PaletteKeyName = 'Palette';\r\n PaletteHiddenTag = '.Hidden';\r\n\r\n {$IFDEF MSWINDOWS}\r\n VclIncludeDirName = '%s\\Include\\Vcl\\';\r\n {$IFDEF BCB}\r\n BorRADToolRepositoryFileName = 'bcb.dro';\r\n {$ELSE BCB}\r\n BorRADToolRepositoryFileName = 'delphi32.dro';\r\n {$ENDIF BCB}\r\n {$ENDIF MSWINDOWS}\r\n\r\n // MsBuild options\r\n MsBuildWin32DCPOutputNodeName = 'Win32DCPOutput';\r\n MsBuildWin32LibraryPathNodeName = 'Win32LibraryPath';\r\n MsBuildWin32BrowsingPathNodeName = 'Win32BrowsingPath';\r\n MsBuildWin32DebugDCUPathNodeName = 'Win32DebugDCUPath';\r\n MsBuildWin32DLLOutputPathNodeName = 'Win32DLLOutputPath';\r\n MsBuildDelphiDCPOutputNodeName = 'DelphiDCPOutput';\r\n MsBuildDelphiLibraryPathNodeName = 'DelphiLibraryPath';\r\n MsBuildDelphiBrowsingPathNodeName = 'DelphiBrowsingPath';\r\n MsBuildDelphiDebugDCUPathNodeName = 'DelphiDebugDCUPath';\r\n MsBuildDelphiDLLOutputPathNodeName = 'DelphiDLLOutputPath';\r\n MsBuildDelphiHPPOutputPathNodeName = 'DelphiHPPOutputPath';\r\n MsBuildCBuilderBPLOutputPathNodeName = 'CBuilderBPLOutputPath';\r\n MsBuildCBuilderBrowsingPathNodeName = 'CBuilderBrowsingPath';\r\n MsBuildCBuilderLibraryPathNodeName = 'CBuilderLibraryPath';\r\n MsBuildCBuilderIncludePathNodeName = 'CBuilderIncludePath';\r\n\r\n{$IFDEF MSWINDOWS}\r\n\r\ntype\r\n WideStringArray = array of WideString;\r\n\r\n TLoadResRec = record\r\n EnglishStr: WideStringArray;\r\n ResId: array of Integer;\r\n end;\r\n PLoadResRec = ^TLoadResRec;\r\n\r\n// helper function to find strings in current string table\r\nfunction LoadResCallBack(hModule: HMODULE; lpszType, lpszName: PChar;\r\n lParam: PLoadResRec): BOOL; stdcall;\r\nvar\r\n ResInfo, ResHData, ResSize, ResIndex: Cardinal;\r\n ResData: PWord;\r\n StrLength: Word;\r\n StrIndex, ResOffset, MatchCount, MatchLen: Integer;\r\nbegin\r\n Result := True;\r\n MatchCount := 0;\r\n\r\n ResInfo := FindResource(hModule, lpszName, lpszType);\r\n if ResInfo <> 0 then\r\n begin\r\n ResHData := LoadResource(hModule, ResInfo);\r\n if ResHData <> 0 then\r\n begin\r\n ResData := LockResource(ResHData);\r\n if Assigned(ResData) then\r\n begin\r\n ResSize := SizeofResource(hModule, ResInfo) div 2;\r\n ResIndex := 0;\r\n ResOffset := 0;\r\n while ResIndex < ResSize do\r\n begin\r\n StrLength := ResData^;\r\n Inc(ResData);\r\n Inc(ResIndex);\r\n // for each requested strings\r\n for StrIndex := Low(lParam^.EnglishStr) to High(lParam^.EnglishStr) do\r\n begin\r\n MatchLen := Length(lParam^.EnglishStr[StrIndex]);\r\n if (lParam^.ResId[StrIndex] = 0) and (StrLength = MatchLen)\r\n and (StrLICompW(PWideChar(lParam^.EnglishStr[StrIndex]), PWideChar(ResData), MatchLen) = 0) then\r\n begin // http://support.microsoft.com/kb/q196774/\r\n lParam^.ResId[StrIndex] := (PWord(@lpszName)^ - 1) * 16 + ResOffset;\r\n Inc(MatchCount);\r\n if MatchCount = Length(lParam^.EnglishStr) then\r\n begin\r\n Result := False;\r\n Break; // all requests were translated to ResId\r\n end;\r\n end;\r\n end;\r\n Inc(ResOffset);\r\n Inc(ResData, StrLength);\r\n Inc(ResIndex, StrLength);\r\n end;\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction LoadResStrings(const BaseBinName: string;\r\n const ResEn: array of WideString): WideStringArray;\r\nvar\r\n H: HMODULE;\r\n LocaleName: array [0..4] of Char;\r\n FileName: string;\r\n Index, NbRes: Integer;\r\n LoadResRec: TLoadResRec;\r\nbegin\r\n NbRes := Length(ResEn);\r\n SetLength(LoadResRec.EnglishStr, NbRes);\r\n SetLength(LoadResRec.ResId, NbRes);\r\n SetLength(Result, NbRes);\r\n\r\n for Index := Low(ResEn) to High(ResEn) do\r\n LoadResRec.EnglishStr[Index] := ResEn[Index];\r\n\r\n H := LoadLibraryEx(PChar(ChangeFileExt(BaseBinName, BinaryExtensionPackage)), 0,\r\n LOAD_LIBRARY_AS_DATAFILE or DONT_RESOLVE_DLL_REFERENCES);\r\n if H <> 0 then\r\n try\r\n EnumResourceNames(H, RT_STRING, @LoadResCallBack, LPARAM(@LoadResRec));\r\n finally\r\n FreeLibrary(H);\r\n end;\r\n\r\n FileName := '';\r\n\r\n ResetMemory(LocaleName, SizeOf(LocaleName));\r\n GetLocaleInfo(GetThreadLocale, LOCALE_SABBREVLANGNAME, LocaleName, SizeOf(LocaleName));\r\n if LocaleName[0] <> #0 then\r\n begin\r\n FileName := BaseBinName;\r\n if FileExists(FileName + LocaleName) then\r\n FileName := FileName + LocaleName\r\n else\r\n begin\r\n LocaleName[2] := #0;\r\n if FileExists(FileName + LocaleName) then\r\n FileName := FileName + LocaleName\r\n else\r\n FileName := '';\r\n end;\r\n end;\r\n\r\n if FileName <> '' then\r\n begin\r\n H := LoadLibraryEx(PChar(FileName), 0, LOAD_LIBRARY_AS_DATAFILE or DONT_RESOLVE_DLL_REFERENCES);\r\n if H <> 0 then\r\n try\r\n for Index := 0 to NbRes - 1 do\r\n begin\r\n SetLength(Result[Index], 1024);\r\n SetLength(Result[Index],\r\n LoadStringW(H, LoadResRec.ResId[Index], PWideChar(Result[Index]), Length(Result[Index]) - 1));\r\n end;\r\n finally\r\n FreeLibrary(H);\r\n end;\r\n end\r\n else\r\n Result := LoadResRec.EnglishStr;\r\nend;\r\n\r\n{$ENDIF MSWINDOWS}\r\n\r\n//=== { TJclBorRADToolInstallationObject } ===================================\r\n\r\nconstructor TJclBorRADToolInstallationObject.Create(AInstallation: TJclBorRADToolInstallation);\r\nbegin\r\n FInstallation := AInstallation;\r\nend;\r\n\r\n//== { TJclBorRADToolIdeTool } ===============================================\r\n\r\nconstructor TJclBorRADToolIdeTool.Create(AInstallation: TJclBorRADToolInstallation);\r\nbegin\r\n inherited Create(AInstallation);\r\n FKey := TransferKeyName;\r\nend;\r\n\r\nprocedure TJclBorRADToolIdeTool.CheckIndex(Index: Integer);\r\nbegin\r\n if (Index < 0) or (Index >= Count) then\r\n raise EJclError.CreateRes(@RsEIndexOufOfRange);\r\nend;\r\n\r\nfunction TJclBorRADToolIdeTool.GetCount: Integer;\r\nbegin\r\n Result := Installation.ConfigData.ReadInteger(Key, TransferCountValueName, 0);\r\nend;\r\n\r\nfunction TJclBorRADToolIdeTool.GetParameters(Index: Integer): string;\r\nbegin\r\n CheckIndex(Index);\r\n Result := Installation.ConfigData.ReadString(Key, Format(TransferParamsValueName, [Index]), '');\r\nend;\r\n\r\nfunction TJclBorRADToolIdeTool.GetPath(Index: Integer): string;\r\nbegin\r\n CheckIndex(Index);\r\n Result := Installation.ConfigData.ReadString(Key, Format(TransferPathValueName, [Index]), '');\r\nend;\r\n\r\nfunction TJclBorRADToolIdeTool.GetTitle(Index: Integer): string;\r\nbegin\r\n CheckIndex(Index);\r\n Result := Installation.ConfigData.ReadString(Key, Format(TransferTitleValueName, [Index]), '');\r\nend;\r\n\r\nfunction TJclBorRADToolIdeTool.GetWorkingDir(Index: Integer): string;\r\nbegin\r\n CheckIndex(Index);\r\n Result := Installation.ConfigData.ReadString(Key, Format(TransferWorkDirValueName, [Index]), '');\r\nend;\r\n\r\nfunction TJclBorRADToolIdeTool.IndexOfPath(const Value: string): Integer;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := -1;\r\n for I := 0 to Count - 1 do\r\n if SamePath(Path[I], Value) then\r\n begin\r\n Result := I;\r\n Break;\r\n end;\r\nend;\r\n\r\nfunction TJclBorRADToolIdeTool.IndexOfTitle(const Value: string): Integer;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := -1;\r\n for I := 0 to Count - 1 do\r\n if Title[I] = Value then\r\n begin\r\n Result := I;\r\n Break;\r\n end;\r\nend;\r\n\r\nprocedure TJclBorRADToolIdeTool.RemoveIndex(const Index: Integer);\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := Index to Count - 2 do\r\n begin\r\n Parameters[I] := Parameters[I + 1];\r\n Path[I] := Path[I + 1];\r\n Title[I] := Title[I + 1];\r\n WorkingDir[Index] := WorkingDir[I + 1];\r\n end;\r\n Count := Count - 1;\r\nend;\r\n\r\nprocedure TJclBorRADToolIdeTool.SetCount(const Value: Integer);\r\nbegin\r\n if Value > Count then\r\n Installation.ConfigData.WriteInteger(Key, TransferCountValueName, Value);\r\nend;\r\n\r\nprocedure TJclBorRADToolIdeTool.SetParameters(Index: Integer; const Value: string);\r\nbegin\r\n CheckIndex(Index);\r\n Installation.ConfigData.WriteString(Key, Format(TransferParamsValueName, [Index]), Value);\r\nend;\r\n\r\nprocedure TJclBorRADToolIdeTool.SetPath(Index: Integer; const Value: string);\r\nbegin\r\n CheckIndex(Index);\r\n Installation.ConfigData.WriteString(Key, Format(TransferPathValueName, [Index]), Value);\r\nend;\r\n\r\nprocedure TJclBorRADToolIdeTool.SetTitle(Index: Integer; const Value: string);\r\nbegin\r\n CheckIndex(Index);\r\n Installation.ConfigData.WriteString(Key, Format(TransferTitleValueName, [Index]), Value);\r\nend;\r\n\r\nprocedure TJclBorRADToolIdeTool.SetWorkingDir(Index: Integer; const Value: string);\r\nbegin\r\n CheckIndex(Index);\r\n Installation.ConfigData.WriteString(Key, Format(TransferWorkDirValueName, [Index]), Value);\r\nend;\r\n\r\n//=== { TJclBorRADToolIdePackages } ==========================================\r\n\r\nconstructor TJclBorRADToolIdePackages.Create(AInstallation: TJclBorRADToolInstallation);\r\nbegin\r\n inherited Create(AInstallation);\r\n FDisabledPackages := TStringList.Create;\r\n FDisabledPackages.Sorted := True;\r\n FDisabledPackages.Duplicates := dupIgnore;\r\n FKnownPackages := TStringList.Create;\r\n FKnownPackages.Sorted := True;\r\n FKnownPackages.Duplicates := dupIgnore;\r\n FKnownIDEPackages := TStringList.Create;\r\n FKnownIDEPackages.Sorted := True;\r\n FKnownIDEPackages.Duplicates := dupIgnore;\r\n FExperts := TStringList.Create;\r\n FExperts.Sorted := True;\r\n FExperts.Duplicates := dupIgnore;\r\n ReadPackages;\r\nend;\r\n\r\ndestructor TJclBorRADToolIdePackages.Destroy;\r\nbegin\r\n FreeAndNil(FDisabledPackages);\r\n FreeAndNil(FKnownPackages);\r\n FreeAndNil(FKnownIDEPackages);\r\n FreeAndNil(FExperts);\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJclBorRADToolIdePackages.AddPackage(const FileName, Description: string): Boolean;\r\nbegin\r\n Result := True;\r\n RemoveDisabled(FileName);\r\n Installation.ConfigData.WriteString(KnownPackagesKeyName, FileName, Description);\r\n ReadPackages;\r\nend;\r\n\r\nfunction TJclBorRADToolIdePackages.AddExpert(const FileName, Description: string): Boolean;\r\nbegin\r\n Result := True;\r\n RemoveDisabled(FileName);\r\n Installation.ConfigData.WriteString(ExpertsKeyName, Description, FileName);\r\n ReadPackages;\r\nend;\r\n\r\nfunction TJclBorRADToolIdePackages.AddIDEPackage(const FileName, Description: string): Boolean;\r\nbegin\r\n Result := True;\r\n RemoveDisabled(FileName);\r\n Installation.ConfigData.WriteString(KnownIDEPackagesKeyName, FileName, Description);\r\n ReadPackages;\r\nend;\r\n\r\nfunction TJclBorRADToolIdePackages.GetCount: Integer;\r\nbegin\r\n Result := FKnownPackages.Count;\r\nend;\r\n\r\nfunction TJclBorRADToolIdePackages.GetExpertCount: Integer;\r\nbegin\r\n Result := FExperts.Count;\r\nend;\r\n\r\nfunction TJclBorRADToolIdePackages.GetExpertDescriptions(Index: Integer): string;\r\nbegin\r\n Result := FExperts.Names[Index];\r\nend;\r\n\r\nfunction TJclBorRADToolIdePackages.GetExpertFileNames(Index: Integer): string;\r\nbegin\r\n Result := PackageEntryToFileName(FExperts.Values[FExperts.Names[Index]]);\r\nend;\r\n\r\nfunction TJclBorRADToolIdePackages.GetIDECount: Integer;\r\nbegin\r\n Result := FKnownIDEPackages.Count;\r\nend;\r\n\r\nfunction TJclBorRADToolIdePackages.GetPackageDescriptions(Index: Integer): string;\r\nbegin\r\n Result := FKnownPackages.Values[FKnownPackages.Names[Index]];\r\nend;\r\n\r\nfunction TJclBorRADToolIdePackages.GetIDEPackageDescriptions(Index: Integer): string;\r\nbegin\r\n Result := FKnownPackages.Values[FKnownIDEPackages.Names[Index]];\r\nend;\r\n\r\nfunction TJclBorRADToolIdePackages.GetPackageDisabled(Index: Integer): Boolean;\r\nbegin\r\n Result := Boolean(FKnownPackages.Objects[Index]);\r\nend;\r\n\r\nfunction TJclBorRADToolIdePackages.GetPackageFileNames(Index: Integer): string;\r\nbegin\r\n Result := PackageEntryToFileName(FKnownPackages.Names[Index]);\r\nend;\r\n\r\nfunction TJclBorRADToolIdePackages.GetIDEPackageFileNames(Index: Integer): string;\r\nbegin\r\n Result := PackageEntryToFileName(FKnownIDEPackages.Names[Index]);\r\nend;\r\n\r\nfunction TJclBorRADToolIdePackages.PackageEntryToFileName(const Entry: string): string;\r\nbegin\r\n Result := Installation.SubstitutePath(Entry);\r\nend;\r\n\r\nprocedure TJclBorRADToolIdePackages.ReadPackages;\r\nvar\r\n I: Integer;\r\n\r\n procedure ReadPackageList(const Name: string; List: TStringList);\r\n var\r\n ListIsSorted: Boolean;\r\n begin\r\n ListIsSorted := List.Sorted;\r\n List.Sorted := False;\r\n List.Clear;\r\n Installation.ConfigData.ReadSectionValues(Name, List);\r\n List.Sorted := ListIsSorted;\r\n end;\r\n\r\nbegin\r\n if Installation.RadToolKind = brBorlandDevStudio then\r\n ReadPackageList(KnownIDEPackagesKeyName, FKnownIDEPackages);\r\n ReadPackageList(KnownPackagesKeyName, FKnownPackages);\r\n ReadPackageList(DisabledPackagesKeyName, FDisabledPackages);\r\n ReadPackageList(ExpertsKeyName, FExperts);\r\n for I := 0 to Count - 1 do\r\n if FDisabledPackages.IndexOfName(FKnownPackages.Names[I]) <> -1 then\r\n FKnownPackages.Objects[I] := Pointer(True);\r\nend;\r\n\r\nprocedure TJclBorRADToolIdePackages.RemoveDisabled(const FileName: string);\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := 0 to FDisabledPackages.Count - 1 do\r\n if SamePath(FileName, PackageEntryToFileName(FDisabledPackages.Names[I])) then\r\n begin\r\n Installation.ConfigData.DeleteKey(DisabledPackagesKeyName, FDisabledPackages.Names[I]);\r\n ReadPackages;\r\n Break;\r\n end;\r\nend;\r\n\r\nfunction TJclBorRADToolIdePackages.RemoveExpert(const FileName: string): Boolean;\r\nvar\r\n I: Integer;\r\n KnownExpertDescription, KnownExpert, KnownExpertFileName: string;\r\nbegin\r\n Result := False;\r\n for I := 0 to FExperts.Count - 1 do\r\n begin\r\n KnownExpertDescription := FExperts.Names[I];\r\n KnownExpert := FExperts.Values[KnownExpertDescription];\r\n KnownExpertFileName := PackageEntryToFileName(KnownExpert);\r\n if SamePath(FileName, KnownExpertFileName) then\r\n begin\r\n RemoveDisabled(KnownExpertFileName);\r\n Installation.ConfigData.DeleteKey(ExpertsKeyName, KnownExpertDescription);\r\n ReadPackages;\r\n Result := True;\r\n Break;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJclBorRADToolIdePackages.RemovePackage(const FileName: string): Boolean;\r\nvar\r\n I: Integer;\r\n KnownPackage, KnownPackageFileName: string;\r\nbegin\r\n Result := False;\r\n for I := 0 to FKnownPackages.Count - 1 do\r\n begin\r\n KnownPackage := FKnownPackages.Names[I];\r\n KnownPackageFileName := PackageEntryToFileName(KnownPackage);\r\n if SamePath(FileName, KnownPackageFileName) then\r\n begin\r\n RemoveDisabled(KnownPackageFileName);\r\n Installation.ConfigData.DeleteKey(KnownPackagesKeyName, KnownPackage);\r\n ReadPackages;\r\n Result := True;\r\n Break;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJclBorRADToolIdePackages.RemoveIDEPackage(const FileName: string): Boolean;\r\nvar\r\n I: Integer;\r\n KnownIDEPackage, KnownIDEPackageFileName: string;\r\nbegin\r\n Result := False;\r\n for I := 0 to FKnownIDEPackages.Count - 1 do\r\n begin\r\n KnownIDEPackage := FKnownIDEPackages.Names[I];\r\n KnownIDEPackageFileName := PackageEntryToFileName(KnownIDEPackage);\r\n if SamePath(FileName, KnownIDEPackageFileName) then\r\n begin\r\n RemoveDisabled(KnownIDEPackageFileName);\r\n Installation.ConfigData.DeleteKey(KnownIDEPackagesKeyName, KnownIDEPackage);\r\n ReadPackages;\r\n Result := True;\r\n Break;\r\n end;\r\n end;\r\nend;\r\n\r\n//=== { TJclBorRADToolPalette } ==============================================\r\n\r\nconstructor TJclBorRADToolPalette.Create(AInstallation: TJclBorRADToolInstallation);\r\nbegin\r\n inherited Create(AInstallation);\r\n FKey := PaletteKeyName;\r\n FTabNames := TStringList.Create;\r\n FTabNames.Sorted := True;\r\n ReadTabNames;\r\nend;\r\n\r\ndestructor TJclBorRADToolPalette.Destroy;\r\nbegin\r\n FreeAndNil(FTabNames);\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJclBorRADToolPalette.ComponentsOnTabToStrings(Index: Integer; Strings: TStrings;\r\n IncludeUnitName: Boolean; IncludeHiddenComponents: Boolean);\r\nvar\r\n TempList: TStringList;\r\n\r\n procedure ProcessList(Hidden: Boolean);\r\n var\r\n D, I: Integer;\r\n List, S: string;\r\n begin\r\n if Hidden then\r\n List := HiddenComponentsOnTab[Index]\r\n else\r\n List := ComponentsOnTab[Index];\r\n List := StrEnsureSuffix(';', List);\r\n while Length(List) > 1 do\r\n begin\r\n D := Pos(';', List);\r\n S := Trim(Copy(List, 1, D - 1));\r\n if not IncludeUnitName then\r\n Delete(S, 1, Pos('.', S));\r\n if Hidden then\r\n begin\r\n I := TempList.IndexOf(S);\r\n if I = -1 then\r\n TempList.AddObject(S, Pointer(True))\r\n else\r\n TempList.Objects[I] := Pointer(True);\r\n end\r\n else\r\n TempList.Add(S);\r\n Delete(List, 1, D);\r\n end;\r\n end;\r\n\r\nbegin\r\n TempList := TStringList.Create;\r\n try\r\n TempList.Duplicates := dupError;\r\n ProcessList(False);\r\n TempList.Sorted := True;\r\n if IncludeHiddenComponents then\r\n ProcessList(True);\r\n Strings.AddStrings(TempList);\r\n finally\r\n TempList.Free;\r\n end;\r\nend;\r\n\r\nfunction TJclBorRADToolPalette.DeleteTabName(const TabName: string): Boolean;\r\nvar\r\n I: Integer;\r\nbegin\r\n I := FTabNames.IndexOf(TabName);\r\n Result := I >= 0;\r\n if Result then\r\n begin\r\n Installation.ConfigData.DeleteKey(Key, FTabNames[I]);\r\n Installation.ConfigData.DeleteKey(Key, FTabNames[I] + PaletteHiddenTag);\r\n FTabNames.Delete(I);\r\n end;\r\nend;\r\n\r\nfunction TJclBorRADToolPalette.GetComponentsOnTab(Index: Integer): string;\r\nbegin\r\n Result := Installation.ConfigData.ReadString(Key, FTabNames[Index], '');\r\nend;\r\n\r\nfunction TJclBorRADToolPalette.GetHiddenComponentsOnTab(Index: Integer): string;\r\nbegin\r\n Result := Installation.ConfigData.ReadString(Key, FTabNames[Index] + PaletteHiddenTag, '');\r\nend;\r\n\r\nfunction TJclBorRADToolPalette.GetTabNameCount: Integer;\r\nbegin\r\n Result := FTabNames.Count;\r\nend;\r\n\r\nfunction TJclBorRADToolPalette.GetTabNames(Index: Integer): string;\r\nbegin\r\n Result := FTabNames[Index];\r\nend;\r\n\r\nprocedure TJclBorRADToolPalette.ReadTabNames;\r\nvar\r\n TempList: TStringList;\r\n I: Integer;\r\n S: string;\r\nbegin\r\n if Installation.ConfigData.SectionExists(Key) then\r\n begin\r\n TempList := TStringList.Create;\r\n try\r\n Installation.ConfigData.ReadSection(Key, TempList);\r\n for I := 0 to TempList.Count - 1 do\r\n begin\r\n S := TempList[I];\r\n if Pos(PaletteHiddenTag, S) = 0 then\r\n FTabNames.Add(S);\r\n end;\r\n finally\r\n TempList.Free;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJclBorRADToolPalette.TabNameExists(const TabName: string): Boolean;\r\nbegin\r\n Result := FTabNames.IndexOf(TabName) <> -1;\r\nend;\r\n\r\n//=== { TJclBorRADToolRepository } ===========================================\r\n\r\nconstructor TJclBorRADToolRepository.Create(AInstallation: TJclBorRADToolInstallation);\r\nbegin\r\n inherited Create(AInstallation);\r\n FFileName := AInstallation.BinFolderName + BorRADToolRepositoryFileName;\r\n FPages := TStringList.Create;\r\n IniFile.ReadSection(BorRADToolRepositoryPagesSection, FPages);\r\n CloseIniFile;\r\nend;\r\n\r\ndestructor TJclBorRADToolRepository.Destroy;\r\nbegin\r\n FreeAndNil(FPages);\r\n FreeAndNil(FIniFile);\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJclBorRADToolRepository.AddObject(const FileName, ObjectType, PageName, ObjectName,\r\n IconFileName, Description, Author, Designer: string; const Ancestor: string);\r\nvar\r\n SectionName: string;\r\nbegin\r\n GetIniFile;\r\n SectionName := AnsiUpperCase(PathRemoveExtension(FileName));\r\n FIniFile.EraseSection(FileName);\r\n FIniFile.EraseSection(SectionName);\r\n FIniFile.WriteString(SectionName, BorRADToolRepositoryObjectType, ObjectType);\r\n FIniFile.WriteString(SectionName, BorRADToolRepositoryObjectName, ObjectName);\r\n FIniFile.WriteString(SectionName, BorRADToolRepositoryObjectPage, PageName);\r\n FIniFile.WriteString(SectionName, BorRADToolRepositoryObjectIcon, IconFileName);\r\n FIniFile.WriteString(SectionName, BorRADToolRepositoryObjectDescr, Description);\r\n FIniFile.WriteString(SectionName, BorRADToolRepositoryObjectAuthor, Author);\r\n if Ancestor <> '' then\r\n FIniFile.WriteString(SectionName, BorRADToolRepositoryObjectAncestor, Ancestor);\r\n if (Installation.RadToolKind = brBorlandDevStudio) or (Installation.VersionNumber >= 6) then\r\n FIniFile.WriteString(SectionName, BorRADToolRepositoryObjectDesigner, Designer);\r\n FIniFile.WriteBool(SectionName, BorRADToolRepositoryObjectNewForm, False);\r\n FIniFile.WriteBool(SectionName, BorRADToolRepositoryObjectMainForm, False);\r\n CloseIniFile;\r\nend;\r\n\r\nprocedure TJclBorRADToolRepository.CloseIniFile;\r\nbegin\r\n FreeAndNil(FIniFile);\r\nend;\r\n\r\nfunction TJclBorRADToolRepository.FindPage(const Name: string; OptionalIndex: Integer): string;\r\nvar\r\n I: Integer;\r\nbegin\r\n I := Pages.IndexOf(Name);\r\n if I >= 0 then\r\n Result := Pages[I]\r\n else\r\n if OptionalIndex < Pages.Count then\r\n Result := Pages[OptionalIndex]\r\n else\r\n Result := '';\r\nend;\r\n\r\nfunction TJclBorRADToolRepository.GetIniFile: TIniFile;\r\nbegin\r\n if not Assigned(FIniFile) then\r\n FIniFile := TIniFile.Create(FileName);\r\n Result := FIniFile;\r\nend;\r\n\r\nfunction TJclBorRADToolRepository.GetPages: TStrings;\r\nbegin\r\n Result := FPages;\r\nend;\r\n\r\nprocedure TJclBorRADToolRepository.RemoveObjects(const PartialPath, FileName, ObjectType: string);\r\nvar\r\n Sections: TStringList;\r\n I: Integer;\r\n SectionName, FileNamePart, PathPart, DialogFileName: string;\r\nbegin\r\n Sections := TStringList.Create;\r\n try\r\n GetIniFile;\r\n FIniFile.ReadSections(Sections);\r\n for I := 0 to Sections.Count - 1 do\r\n begin\r\n SectionName := Sections[I];\r\n if FIniFile.ReadString(SectionName, BorRADToolRepositoryObjectType, '') = ObjectType then\r\n begin\r\n FileNamePart := PathExtractFileNameNoExt(SectionName);\r\n PathPart := StrRight(PathAddSeparator(ExtractFilePath(SectionName)), Length(PartialPath));\r\n DialogFileName := PathExtractFileNameNoExt(FileName);\r\n if StrSame(FileNamePart, DialogFileName) and StrSame(PathPart, PartialPath) then\r\n FIniFile.EraseSection(SectionName);\r\n end;\r\n end;\r\n finally\r\n Sections.Free;\r\n end;\r\nend;\r\n\r\n//=== { TJclBorRADToolInstallation } =========================================\r\n\r\nconstructor TJclBorRADToolInstallation.Create(const AConfigDataLocation: string; ARootKey: Cardinal);\r\n{$IFDEF MSWINDOWS}\r\nvar\r\n HelpPrefix: string;\r\n{$ENDIF MSWINDOWS}\r\nbegin\r\n inherited Create;\r\n FConfigDataLocation := AConfigDataLocation;\r\n FConfigData := TRegistryIniFile.Create(AConfigDataLocation);\r\n if ARootKey = 0 then\r\n FRootKey := Cardinal(HKCU)\r\n else\r\n FRootKey := ARootKey;\r\n TRegistryIniFile(FConfigData).RegIniFile.RootKey := RootKey;\r\n TRegistryIniFile(FConfigData).RegIniFile.OpenKey(AConfigDataLocation, True);\r\n FGlobals := TStringList.Create;\r\n ReadInformation;\r\n FIdeTools := TJclBorRADToolIdeTool.Create(Self);\r\n {$IFDEF MSWINDOWS}\r\n case RadToolKind of\r\n brDelphi:\r\n if VersionNumber <= 6 then\r\n HelpPrefix := 'delphi' + IntToStr(VersionNumber)\r\n else\r\n HelpPrefix := 'd' + IntToStr(VersionNumber);\r\n brCppBuilder:\r\n HelpPrefix := 'bcb' + IntToStr(VersionNumber);\r\n else\r\n HelpPrefix := '';\r\n end;\r\n FOpenHelp := TJclBorlandOpenHelp.Create(RootDir, HelpPrefix);\r\n {$ENDIF ~MSWINDOWS}\r\n FMapCreate := False;\r\n {$IFDEF MSWINDOWS}\r\n FJdbgCreate := False;\r\n FJdbgInsert := False;\r\n FMapDelete := False;\r\n if FileExists(BinFolderName + AsmExeName) then\r\n Include(FCommandLineTools, clAsm);\r\n {$ENDIF ~MSWINDOWS}\r\n if FileExists(BinFolderName + BCC32ExeName) then\r\n Include(FCommandLineTools, clBcc32);\r\n if FileExists(BinFolderName + BCC64ExeName) then\r\n Include(FCommandLineTools, clBcc64);\r\n if FileExists(BinFolderName + DCC32ExeName) then\r\n Include(FCommandLineTools, clDcc32);\r\n if FileExists(BinFolderName + DCC64ExeName) then\r\n Include(FCommandLineTools, clDcc64);\r\n if FileExists(BinFolderName + DCCOSX32ExeName) then\r\n Include(FCommandLineTools, clDccOSX32);\r\n {$IFDEF MSWINDOWS}\r\n if FileExists(BinFolderName + DCCILExeName) then\r\n Include(FCommandLineTools, clDccIL);\r\n {$ENDIF ~MSWINDOWS}\r\n if FileExists(BinFolderName + MakeExeName) then\r\n Include(FCommandLineTools, clMake);\r\n if FileExists(BinFolderName + Bpr2MakExeName) then\r\n Include(FCommandLineTools, clProj2Mak);\r\nend;\r\n\r\ndestructor TJclBorRADToolInstallation.Destroy;\r\nbegin\r\n FreeAndNil(FRepository);\r\n FreeAndNil(FDCC32);\r\n FreeAndNil(FBCC32);\r\n FreeAndNil(FBpr2Mak);\r\n FreeAndNil(FIdePackages);\r\n FreeAndNil(FIdeTools);\r\n {$IFDEF MSWINDOWS}\r\n FreeAndNil(FOpenHelp);\r\n {$ENDIF MSWINDOWS}\r\n FreeAndNil(FPalette);\r\n FreeAndNil(FGlobals);\r\n FreeAndNil(FEnvironmentVariables);\r\n FreeAndNil(FConfigData);\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJclBorRADToolInstallation.AddToDebugDCUPath(const Path: string; APlatform: TJclBDSPlatform): Boolean;\r\nvar\r\n TempRawDebugDCUPath: TJclBorRADToolPath;\r\nbegin\r\n CheckPlatform(APlatform);\r\n\r\n if Path <> '' then\r\n begin\r\n TempRawDebugDCUPath := RawDebugDCUPath[APlatform];\r\n PathListIncludeItems(TempRawDebugDCUPath, Path);\r\n Result := True;\r\n RawDebugDCUPath[APlatform] := TempRawDebugDCUPath;\r\n end\r\n else\r\n Result := False;\r\nend;\r\n\r\nfunction TJclBorRADToolInstallation.AddToLibrarySearchPath(const Path: string; APlatform: TJclBDSPlatform): Boolean;\r\nvar\r\n TempRawLibraryPath: TJclBorRADToolPath;\r\nbegin\r\n CheckPlatform(APlatform);\r\n\r\n if Path <> '' then\r\n begin\r\n TempRawLibraryPath := RawLibrarySearchPath[APlatform];\r\n PathListIncludeItems(TempRawLibraryPath, Path);\r\n Result := True;\r\n RawLibrarySearchPath[APlatform] := TempRawLibraryPath;\r\n end\r\n else\r\n Result := False;\r\nend;\r\n\r\nfunction TJclBorRADToolInstallation.AddToLibraryBrowsingPath(const Path: string; APlatform: TJclBDSPlatform): Boolean;\r\nvar\r\n TempRawLibraryPath: TJclBorRADToolPath;\r\nbegin\r\n CheckPlatform(APlatform);\r\n\r\n if Path <> '' then\r\n begin\r\n TempRawLibraryPath := RawLibraryBrowsingPath[APlatform];\r\n PathListIncludeItems(TempRawLibraryPath, Path);\r\n Result := True;\r\n RawLibraryBrowsingPath[APlatform] := TempRawLibraryPath;\r\n end\r\n else\r\n Result := False;\r\nend;\r\n\r\nfunction TJclBorRADToolInstallation.AnyInstanceRunning: Boolean;\r\nvar\r\n Processes: TStringList;\r\n I: Integer;\r\nbegin\r\n Result := False;\r\n Processes := TStringList.Create;\r\n try\r\n if RunningProcessesList(Processes) then\r\n begin\r\n for I := 0 to Processes.Count - 1 do\r\n if AnsiSameText(IdeExeFileName, Processes[I]) then\r\n begin\r\n Result := True;\r\n Break;\r\n end;\r\n end;\r\n finally\r\n Processes.Free;\r\n end;\r\nend;\r\n\r\nclass procedure TJclBorRADToolInstallation.ExtractPaths(const Path: TJclBorRADToolPath; List: TStrings);\r\nbegin\r\n StrToStrings(Path, PathSep, List);\r\nend;\r\n\r\nprocedure TJclBorRADToolInstallation.CheckCBuilderPlatform(APlatform: TJclBDSPlatform);\r\nbegin\r\n if ((APlatform = bpWin32) and not (bpBCBuilder32 in Personalities)) or\r\n ((APlatform = bpWin64) and not (bpBCBuilder64 in Personalities)) then\r\n raise EJclBorRADException.CreateRes(@RsEPlatformNotValid);\r\nend;\r\n\r\nprocedure TJclBorRADToolInstallation.CheckPlatform(APlatform: TJclBDSPlatform);\r\nbegin\r\n if ((APlatform = bpWin32) and ([bpDelphi32,bpBCBuilder32] * Personalities = [])) or\r\n ((APlatform = bpWin64) and ([bpDelphi64,bpBCBuilder64] * Personalities = [])) or\r\n ((APlatform = bpOSX32) and ([bpDelphiOSX32] * Personalities = [])) then\r\n raise EJclBorRADException.CreateRes(@RsEPlatformNotValid);\r\nend;\r\n\r\nfunction TJclBorRADToolInstallation.CompileBCBPackage(const PackageName, BPLPath, DCPPath: string): Boolean;\r\nvar\r\n SaveDir, PackagePath, MakeFileName: string;\r\nbegin\r\n OutputString(Format(LoadResString(@RsCompilingPackage), [PackageName]));\r\n\r\n if not IsBCBPackage(PackageName) then\r\n raise EJclBorRADException.CreateResFmt(@RsENotABCBPackage, [PackageName]);\r\n\r\n PackagePath := PathRemoveSeparator(ExtractFilePath(PackageName));\r\n SaveDir := GetCurrentDir;\r\n SetCurrentDir(PackagePath);\r\n try\r\n MakeFileName := StrTrimQuotes(ChangeFileExt(PackageName, '.mak'));\r\n if clProj2Mak in CommandLineTools then // let bpr2mak generate make file from .bpk\r\n Result := Bpr2Mak.Execute(StringsToStr(Bpr2Mak.Options, ' ') + ' ' + ExtractFileName(PackageName))\r\n else\r\n // If make file exists (and doesn't need to be created by bpr2mak)\r\n Result := FileExists(MakeFileName);\r\n\r\n if MapCreate then\r\n Make.Options.Add('-DMAPFLAGS=-s');\r\n\r\n Result := Result and\r\n Make.Execute(Format('%s -f%s', [StringsToStr(Make.Options, ' '), StrDoubleQuote(MakeFileName)])) and\r\n ProcessMapFile(BinaryFileName(BPLPath, PackageName));\r\n finally\r\n SetCurrentDir(SaveDir);\r\n end;\r\n\r\n if Result then\r\n OutputString(LoadResString(@RsCompilationOk))\r\n else\r\n OutputString(LoadResString(@RsCompilationFailed));\r\nend;\r\n\r\nfunction TJclBorRADToolInstallation.CompileBCBProject(const ProjectName, OutputDir, DcpSearchPath: string): Boolean;\r\nvar\r\n SaveDir, PackagePath, MakeFileName: string;\r\nbegin\r\n OutputString(Format(LoadResString(@RsCompilingProject), [ProjectName]));\r\n\r\n if not IsBCBProject(ProjectName) then\r\n raise EJclBorRADException.CreateResFmt(@RsENotADelphiProject, [ProjectName]);\r\n\r\n PackagePath := PathRemoveSeparator(ExtractFilePath(ProjectName));\r\n SaveDir := GetCurrentDir;\r\n SetCurrentDir(PackagePath);\r\n try\r\n MakeFileName := StrTrimQuotes(ChangeFileExt(ProjectName, '.mak'));\r\n if clProj2Mak in CommandLineTools then // let bpr2mak generate make file from .bpk\r\n Result := Bpr2Mak.Execute(StringsToStr(Bpr2Mak.Options, ' ') + ' ' + ExtractFileName(ProjectName))\r\n else\r\n // If make file exists (and doesn't need to be created by bpr2mak)\r\n Result := FileExists(MakeFileName);\r\n\r\n if MapCreate then\r\n Make.Options.Add('-DMAPFLAGS=-s');\r\n\r\n Result := Result and\r\n Make.Execute(Format('%s -f%s', [StringsToStr(Make.Options, ' '), StrDoubleQuote(MakeFileName)])) and\r\n ProcessMapFile(BinaryFileName(OutputDir, ProjectName));\r\n finally\r\n SetCurrentDir(SaveDir);\r\n end;\r\n\r\n if Result then\r\n OutputString(LoadResString(@RsCompilationOk))\r\n else\r\n OutputString(LoadResString(@RsCompilationFailed));\r\nend;\r\n\r\nfunction TJclBorRADToolInstallation.CompileDelphiPackage(const PackageName,\r\n BPLPath, DCPPath: string): Boolean;\r\nbegin\r\n Result := CompileDelphiPackage(PackageName, BPLPath, DCPPath, '');\r\nend;\r\n\r\nfunction TJclBorRADToolInstallation.CompileDelphiPackage(const PackageName,\r\n BPLPath, DCPPath, ExtraOptions: string): Boolean;\r\nvar\r\n NewOptions: string;\r\nbegin\r\n OutputString(Format(LoadResString(@RsCompilingPackage), [PackageName]));\r\n\r\n if not IsDelphiPackage(PackageName) then\r\n raise EJclBorRADException.CreateResFmt(@RsENotADelphiPackage, [PackageName]);\r\n\r\n if MapCreate then\r\n NewOptions := ExtraOptions + ' -GD'\r\n else\r\n NewOptions := ExtraOptions;\r\n\r\n Result := DCC.MakePackage(PackageName, BPLPath, DCPPath, NewOptions) and\r\n ProcessMapFile(BinaryFileName(BPLPath, PackageName));\r\n\r\n if Result then\r\n OutputString(LoadResString(@RsCompilationOk))\r\n else\r\n OutputString(LoadResString(@RsCompilationFailed));\r\nend;\r\n\r\nfunction TJclBorRADToolInstallation.CompileDelphiProject(const ProjectName,\r\n OutputDir, DcpSearchPath: string): Boolean;\r\nvar\r\n ExtraOptions: string;\r\nbegin\r\n OutputString(Format(LoadResString(@RsCompilingProject), [ProjectName]));\r\n\r\n if not IsDelphiProject(ProjectName) then\r\n raise EJclBorRADException.CreateResFmt(@RsENotADelphiProject, [ProjectName]);\r\n\r\n if MapCreate then\r\n ExtraOptions := '-GD'\r\n else\r\n ExtraOptions := '';\r\n\r\n Result := DCC32.MakeProject(ProjectName, OutputDir, DcpSearchPath, ExtraOptions) and\r\n ProcessMapFile(BinaryFileName(OutputDir, ProjectName));\r\n\r\n if Result then\r\n OutputString(LoadResString(@RsCompilationOk))\r\n else\r\n OutputString(LoadResString(@RsCompilationFailed));\r\nend;\r\n\r\nfunction TJclBorRADToolInstallation.CompilePackage(const PackageName, BPLPath,\r\n DCPPath: string): Boolean;\r\nvar\r\n PackageExtension: string;\r\nbegin\r\n PackageExtension := ExtractFileExt(PackageName);\r\n if SameText(PackageExtension, SourceExtensionBCBPackage) then\r\n Result := CompileBCBPackage(PackageName, BPLPath, DCPPath)\r\n else\r\n if SameText(PackageExtension, SourceExtensionDelphiPackage) then\r\n Result := CompileDelphiPackage(PackageName, BPLPath, DCPPath)\r\n else\r\n raise EJclBorRadException.CreateResFmt(@RsEUnknownPackageExtension, [PackageExtension]);\r\nend;\r\n\r\nfunction TJclBorRADToolInstallation.CompileProject(const ProjectName,\r\n OutputDir, DcpSearchPath: string): Boolean;\r\nvar\r\n ProjectExtension: string;\r\nbegin\r\n ProjectExtension := ExtractFileExt(ProjectName);\r\n if SameText(ProjectExtension, SourceExtensionBCBProject) then\r\n Result := CompileBCBProject(ProjectName, OutputDir, DcpSearchPath)\r\n else\r\n if SameText(ProjectExtension, SourceExtensionDelphiProject) then\r\n Result := CompileDelphiProject(ProjectName, OutputDir, DcpSearchPath)\r\n else\r\n raise EJclBorRadException.CreateResFmt(@RsEUnknownProjectExtension, [ProjectExtension]);\r\nend;\r\n\r\nfunction TJclBorRADToolInstallation.FindFolderInPath(Folder: string; List: TStrings): Integer;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := -1;\r\n Folder := PathRemoveSeparator(Folder);\r\n for I := 0 to List.Count - 1 do\r\n if SamePath(Folder, PathRemoveSeparator(SubstitutePath(List[I]))) then\r\n begin\r\n Result := I;\r\n Break;\r\n end;\r\nend;\r\n\r\nfunction TJclBorRADToolInstallation.GetBPLOutputPath(APlatform: TJclBDSPlatform): string;\r\nbegin\r\n CheckPlatform(APlatform);\r\n Result := SubstitutePath(ConfigData.ReadString(LibraryKeyName, LibraryBPLOutputValueName, ''));\r\nend;\r\n\r\nfunction TJclBorRADToolInstallation.GetBpr2Mak: TJclBpr2Mak;\r\nbegin\r\n if not Assigned(FBpr2Mak) then\r\n begin\r\n if not (clProj2Mak in CommandLineTools) then\r\n raise EJclBorRadException.CreateResFmt(@RsENotFound, [Bpr2MakExeName]);\r\n FBpr2Mak := TJclBpr2Mak.Create(BinFolderName, LongPathBug, CompilerSettingsFormat);\r\n end;\r\n Result := FBpr2Mak;\r\nend;\r\n\r\nfunction TJclBorRADToolInstallation.GetBCC32: TJclBCC32;\r\nbegin\r\n if not Assigned(FBCC32) then\r\n begin\r\n if not (clBcc32 in CommandLineTools) then\r\n raise EJclBorRadException.CreateResFmt(@RsENotFound, [Bcc32ExeName]);\r\n FBCC32 := TJclBCC32.Create(BinFolderName, LongPathBug, CompilerSettingsFormat);\r\n end;\r\n Result := FBCC32;\r\nend;\r\n\r\nfunction TJclBorRADToolInstallation.GetCommonProjectsDir: string;\r\nbegin\r\n Result := DefaultProjectsDir;\r\nend;\r\n\r\nfunction TJclBorRADToolInstallation.GetCompilerSettingsFormat: TJclCompilerSettingsFormat;\r\nbegin\r\n if (RadToolKind = brBorlandDevStudio) and (VersionNumber >= 5) then\r\n Result := csfMsBuild\r\n else\r\n if RadToolKind = brBorlandDevStudio then\r\n Result := csfBDSProj\r\n else\r\n Result := csfDOF;\r\nend;\r\n\r\nfunction TJclBorRADToolInstallation.GetDCC: TJclDCC32;\r\nbegin\r\n if Assigned(FDCC) then\r\n Result := FDCC\r\n else\r\n Result := DCC32;\r\nend;\r\n\r\nfunction TJclBorRADToolInstallation.GetDCC32: TJclDCC32;\r\nbegin\r\n if not Assigned(FDCC32) then\r\n begin\r\n if not (clDcc32 in CommandLineTools) then\r\n raise EJclBorRadException.CreateResFmt(@RsENotFound, [Dcc32ExeName]);\r\n FDCC32 := TJclDCC32.Create(BinFolderName, LongPathBug, CompilerSettingsFormat,\r\n SupportsNoConfig, SupportsPlatform, DCPOutputPath[bpWin32], LibFolderName[bpWin32], LibDebugFolderName[bpWin32], ObjFolderName[bpWin32]);\r\n FDCC32.OnEnvironmentVariables := GetEnvironmentVariables;\r\n end;\r\n Result := FDCC32;\r\nend;\r\n\r\nfunction TJclBorRADToolInstallation.GetDCPOutputPath(APlatform: TJclBDSPlatform): string;\r\nbegin\r\n CheckPlatform(APlatform);\r\n Result := SubstitutePath(ConfigData.ReadString(LibraryKeyName, LibraryDCPOutputValueName, ''));\r\nend;\r\n\r\nfunction TJclBorRADToolInstallation.GetDebugDCUPath(APlatform: TJclBDSPlatform): string;\r\nbegin\r\n CheckPlatform(APlatform);\r\n Result := ConfigData.ReadString(DebuggingKeyName, DebugDCUPathValueName, '');\r\nend;\r\n\r\nfunction TJclBorRADToolInstallation.GetDefaultProjectsDir: string;\r\nbegin\r\n Result := Globals.Values['DefaultProjectsDirectory'];\r\n if Result = '' then\r\n Result := PathAddSeparator(RootDir) + 'Projects';\r\nend;\r\n\r\nfunction TJclBorRADToolInstallation.GetDescription: TJclBorRADToolPath;\r\nbegin\r\n Result := Format('%s %s', [Name, EditionAsText]);\r\n if InstalledUpdatePack > 0 then\r\n Result := Result + ' ' + Format(LoadResString(@RsUpdatePackName), [InstalledUpdatePack]);\r\nend;\r\n\r\nfunction TJclBorRADToolInstallation.GetEditionAsText: string;\r\nbegin\r\n Result := FEditionStr;\r\n if Length(FEditionStr) = 3 then\r\n case Edition of\r\n deSTD:\r\n if (VersionNumber >= 6) or (RadToolKind = brBorlandDevStudio) then\r\n Result := LoadResString(@RsPersonal)\r\n else\r\n Result := LoadResString(@RsStandard);\r\n dePRO:\r\n Result := LoadResString(@RsProfessional);\r\n deCSS:\r\n if (VersionNumber >= 5) or (RadToolKind = brBorlandDevStudio) then\r\n Result := LoadResString(@RsEnterprise)\r\n else\r\n Result := LoadResString(@RsClientServer);\r\n deARC:\r\n Result := LoadResString(@RsArchitect);\r\n end;\r\nend;\r\n\r\nfunction TJclBorRADToolInstallation.GetDefaultBDSCommonDir: string;\r\nconst\r\n CSIDL_COMMON_DOCUMENTS = $002E; // All Users\\Documents\r\nvar\r\n CommonDocuments: array[0..MAX_PATH] of Char;\r\nbegin\r\n if (RadToolKind = brBorlandDevStudio) and (IDEVersionNumber >= 6) and\r\n SHGetSpecialFolderPath(GetActiveWindow, CommonDocuments, CSIDL_COMMON_DOCUMENTS, False) then\r\n Result := IncludeTrailingPathDelimiter(CommonDocuments) + RADStudioDirName + PathDelim + Format('%d.0', [IDEVersionNumber])\r\n else\r\n Result := GetEnvironmentVariable(EnvVariableBDSCOMDIRValueName);\r\nend;\r\n\r\nfunction TJclBorRADToolInstallation.GetEnvironmentVariables: TStrings;\r\nvar\r\n EnvNames: TStringList;\r\n EnvVarKeyName, EnvVarValue: string;\r\n I: Integer;\r\nbegin\r\n if FEnvironmentVariables = nil then\r\n begin\r\n FEnvironmentVariables := TStringList.Create;\r\n\r\n // at first get system environment variables\r\n JclSysInfo.GetEnvironmentVars(FEnvironmentVariables, True);\r\n\r\n // Overwrite BDSCommonDir because it conflicts with older versions and\r\n // the RAD Studio 2009 setup doesn't update the environment variable anymore\r\n if (RadToolKind = brBorlandDevStudio) and (IDEVersionNumber >= 6) then\r\n FEnvironmentVariables.Values[EnvVariableBDSCOMDIRValueName] := GetDefaultBDSCommonDir;\r\n\r\n // read environment variable overrides\r\n if ((VersionNumber >= 6) or (RadToolKind = brBorlandDevStudio)) and\r\n ConfigData.SectionExists(EnvVariablesKeyName) then\r\n begin\r\n EnvNames := TStringList.Create;\r\n try\r\n ConfigData.ReadSection(EnvVariablesKeyName, EnvNames);\r\n for I := 0 to EnvNames.Count - 1 do\r\n begin\r\n EnvVarKeyName := EnvNames[I];\r\n EnvVarValue := ConfigData.ReadString(EnvVariablesKeyName, EnvVarKeyName, '');\r\n ExpandEnvironmentVarCustom(EnvVarValue, FEnvironmentVariables);\r\n FEnvironmentVariables.Values[EnvVarKeyName] := EnvVarValue;\r\n end;\r\n finally\r\n EnvNames.Free;\r\n end;\r\n end;\r\n\r\n // remove empty environment variables\r\n for I := FEnvironmentVariables.count-1 downto 0 do\r\n if FEnvironmentVariables.Names[I] = EmptyStr then\r\n FEnvironmentVariables.Delete(I);\r\n end;\r\n Result := FEnvironmentVariables;\r\nend;\r\n\r\nfunction TJclBorRADToolInstallation.GetGlobals: TStrings;\r\nbegin\r\n Result := FGlobals;\r\nend;\r\n\r\nfunction TJclBorRADToolInstallation.GetIdeExeFileName: string;\r\nbegin\r\n Result := Globals.Values['App'];\r\nend;\r\n\r\nfunction TJclBorRADToolInstallation.GetIdeExeBuildNumber: string;\r\nbegin\r\n Result := VersionFixedFileInfoString(IdeExeFileName, vfFull);\r\nend;\r\n\r\nfunction TJclBorRADToolInstallation.GetIdePackages: TJclBorRADToolIdePackages;\r\nbegin\r\n if not Assigned(FIdePackages) then\r\n FIdePackages := TJclBorRADToolIdePackages.Create(Self);\r\n Result := FIdePackages;\r\nend;\r\n\r\nfunction TJclBorRADToolInstallation.GetIsTurboExplorer: Boolean;\r\nbegin\r\n Result := (RadToolKind = brBorlandDevStudio) and (VersionNumber = 4) and not (clDcc32 in CommandLineTools);\r\nend;\r\n\r\nfunction TJclBorRADToolInstallation.GetLatestUpdatePack: Integer;\r\nbegin\r\n Result := GetLatestUpdatePackForVersion(VersionNumber);\r\nend;\r\n\r\nclass function TJclBorRADToolInstallation.GetLatestUpdatePackForVersion(Version: Integer): Integer;\r\nbegin\r\n {$IFDEF MSWINDOWS}\r\n raise EAbstractError.CreateResFmt(@SAbstractError, ['']); // BCB doesn't support abstract keyword\r\n // dummy; BCB doesn't like abstract class functions\r\n {$ELSE MSWINDOWS}\r\n Result := 0;\r\n {$ENDIF MSWINDOWS}\r\nend;\r\n\r\nfunction TJclBorRADToolInstallation.GetLibrarySearchPath(APlatform: TJclBDSPlatform): TJclBorRADToolPath;\r\nbegin\r\n CheckPlatform(APlatform);\r\n Result := ConfigData.ReadString(LibraryKeyName, LibrarySearchPathValueName, '');\r\nend;\r\n\r\nfunction TJclBorRADToolInstallation.GetLongPathBug: Boolean;\r\nbegin\r\n Result := (RadToolKind in [brDelphi, brCppBuilder]) or (VersionNumber < 3);\r\nend;\r\n\r\nfunction TJclBorRADToolInstallation.GetMake: IJclCommandLineTool;\r\nbegin\r\n if not Assigned(FMake) then\r\n begin\r\n if not (clMake in CommandLineTools) then\r\n raise EJclBorRadException.CreateResFmt(@RsENotFound, [MakeExeName]);\r\n FMake := TJclBorlandMake.Create(BinFolderName, LongPathBug, CompilerSettingsFormat);\r\n // Set option \"-l+\", which enables use of long command lines. Should be\r\n // default, but there have been reports indicating that's not always the case.\r\n FMake.Options.Add('-l+');\r\n end;\r\n Result := FMake;\r\nend;\r\n\r\nfunction TJclBorRADToolInstallation.GetLibDebugFolderName(APlatform: TJclBDSPlatform): string;\r\nbegin\r\n CheckPlatform(APlatform);\r\n Result := LibFolderName[APlatform] + PathAddSeparator('debug');\r\nend;\r\n\r\nfunction TJclBorRADToolInstallation.GetLibFolderName(APlatform: TJclBDSPlatform): string;\r\nbegin\r\n CheckPlatform(APlatform);\r\n Result := PathAddSeparator(RootDir) + PathAddSeparator('lib');\r\nend;\r\n\r\nfunction TJclBorRADToolInstallation.GetLibraryBrowsingPath(APlatform: TJclBDSPlatform): TJclBorRADToolPath;\r\nbegin\r\n CheckPlatform(APlatform);\r\n Result := ConfigData.ReadString(LibraryKeyName, LibraryBrowsingPathValueName, '');\r\nend;\r\n\r\nfunction TJclBorRADToolInstallation.GetName: string;\r\nbegin\r\n Result := Format('%s %d', [RADToolName, IDEVersionNumber]);\r\nend;\r\n\r\nfunction TJclBorRADToolInstallation.GetObjFolderName(APlatform: TJclBDSPlatform): string;\r\nbegin\r\n CheckPlatform(APlatform);\r\n Result := LibFolderName[APlatform] + PathAddSeparator('obj');\r\n if not DirectoryExists(Result) then\r\n Result := '';\r\nend;\r\n\r\nfunction TJclBorRADToolInstallation.GetPalette: TJclBorRADToolPalette;\r\nbegin\r\n if not Assigned(FPalette) then\r\n FPalette := TJclBorRADToolPalette.Create(Self);\r\n Result := FPalette;\r\nend;\r\n\r\nfunction TJclBorRADToolInstallation.GetRawDebugDCUPath(APlatform: TJclBDSPlatform): string;\r\nbegin\r\n CheckPlatform(APlatform);\r\n Result := GetDebugDCUPath(APlatform);\r\nend;\r\n\r\nfunction TJclBorRADToolInstallation.GetRawLibrarySearchPath(APlatform: TJclBDSPlatform): TJclBorRADToolPath;\r\nbegin\r\n CheckPlatform(APlatform);\r\n Result := GetLibrarySearchPath(APlatform);\r\nend;\r\n\r\nfunction TJclBorRADToolInstallation.GetRawLibraryBrowsingPath(APlatform: TJclBDSPlatform): TJclBorRADToolPath;\r\nbegin\r\n CheckPlatform(APlatform);\r\n Result := GetLibraryBrowsingPath(APlatform);\r\nend;\r\n\r\nfunction TJclBorRADToolInstallation.GetRepository: TJclBorRADToolRepository;\r\nbegin\r\n if not Assigned(FRepository) then\r\n FRepository := TJclBorRADToolRepository.Create(Self);\r\n Result := FRepository;\r\nend;\r\n\r\nfunction TJclBorRADToolInstallation.GetSupportsLibSuffix: Boolean;\r\nbegin\r\n Result := (RadToolKind = brBorlandDevStudio) or (VersionNumber >= 6);\r\nend;\r\n\r\nfunction TJclBorRADToolInstallation.GetSupportsNoConfig: Boolean;\r\nbegin\r\n Result := (RadToolKind = brBorlandDevStudio) and (VersionNumber >= 4);\r\nend;\r\n\r\nfunction TJclBorRADToolInstallation.GetSupportsPlatform: Boolean;\r\nbegin\r\n Result := (RadToolKind = brBorlandDevStudio) and (VersionNumber >= 9);\r\nend;\r\n\r\nfunction TJclBorRADToolInstallation.GetUpdateNeeded: Boolean;\r\nbegin\r\n Result := InstalledUpdatePack < LatestUpdatePack;\r\nend;\r\n\r\nfunction TJclBorRADToolInstallation.GetValid: Boolean;\r\nbegin\r\n Result := (ConfigData.FileName <> '') and (RootDir <> '') and FileExists(IdeExeFileName);\r\nend;\r\n\r\nfunction TJclBorRADToolInstallation.GetVclIncludeDir(APlatform: TJclBDSPlatform): string;\r\nbegin\r\n CheckCBuilderPlatform(APlatform);\r\n Result := Format(VclIncludeDirName, [RootDir]);\r\n if not DirectoryExists(Result) then\r\n Result := '';\r\nend;\r\n\r\nfunction TJclBorRADToolInstallation.InstallBCBExpert(const ProjectName, OutputDir, DcpSearchPath: string): Boolean;\r\nvar\r\n Unused, Description: string;\r\nbegin\r\n OutputString(Format(LoadResString(@RsExpertInstallationStarted), [ProjectName]));\r\n\r\n GetBPRFileInfo(ProjectName, Unused, @Description);\r\n\r\n Result := CompileBCBProject(ProjectName, OutputDir, DcpSearchPath) and\r\n RegisterExpert(BinaryFileName(OutputDir, ProjectName), Description);\r\n\r\n OutputString(LoadResString(@RsExpertInstallationFinished));\r\nend;\r\n\r\nfunction TJclBorRADToolInstallation.InstallBCBIdePackage(const PackageName, BPLPath, DCPPath: string): Boolean;\r\nvar\r\n RunOnly: Boolean;\r\n Unused, Description: string;\r\nbegin\r\n OutputString(Format(LoadResString(@RsIdePackageInstallationStarted), [PackageName]));\r\n\r\n GetBPKFileInfo(PackageName, RunOnly, @Unused, @Description);\r\n if RunOnly then\r\n raise EJclBorRadException.CreateResFmt(@RsECannotInstallRunOnly, [PackageName]);\r\n\r\n Result := CompileBCBPackage(PackageName, BPLPath, DCPPath) and\r\n RegisterIdePackage(BinaryFileName(BPLPath, PackageName), Description);\r\n\r\n OutputString(LoadResString(@RsIdePackageInstallationFinished));\r\nend;\r\n\r\nfunction TJclBorRADToolInstallation.InstallBCBPackage(const PackageName, BPLPath, DCPPath: string): Boolean;\r\nvar\r\n RunOnly: Boolean;\r\n Unused, Description: string;\r\nbegin\r\n OutputString(Format(LoadResString(@RsPackageInstallationStarted), [PackageName]));\r\n\r\n GetBPKFileInfo(PackageName, RunOnly, @Unused, @Description);\r\n if RunOnly then\r\n raise EJclBorRadException.CreateResFmt(@RsECannotInstallRunOnly, [PackageName]);\r\n\r\n Result := CompileBCBPackage(PackageName, BPLPath, DCPPath) and\r\n RegisterPackage(BinaryFileName(BPLPath, PackageName), Description);\r\n\r\n OutputString(LoadResString(@RsPackageInstallationFinished));\r\nend;\r\n\r\nfunction TJclBorRADToolInstallation.InstallDelphiExpert(const ProjectName, OutputDir, DcpSearchPath: string): Boolean;\r\nvar\r\n BaseName: string;\r\nbegin\r\n OutputString(Format(LoadResString(@RsExpertInstallationStarted), [ProjectName]));\r\n\r\n BaseName := PathExtractFileNameNoExt(ProjectName);\r\n\r\n Result := CompileDelphiProject(ProjectName, OutputDir, DcpSearchPath) and\r\n RegisterExpert(BinaryFileName(OutputDir, ProjectName), BaseName);\r\n\r\n OutputString(LoadResString(@RsExpertInstallationFinished));\r\nend;\r\n\r\nfunction TJclBorRADToolInstallation.InstallDelphiIdePackage(const PackageName, BPLPath, DCPPath: string): Boolean;\r\nvar\r\n RunOnly: Boolean;\r\n Unused, Description: string;\r\nbegin\r\n OutputString(Format(LoadResString(@RsIdePackageInstallationStarted), [PackageName]));\r\n\r\n GetDPKFileInfo(PackageName, RunOnly, @Unused, @Description);\r\n if RunOnly then\r\n raise EJclBorRadException.CreateResFmt(@RsECannotInstallRunOnly, [PackageName]);\r\n\r\n Result := CompileDelphiPackage(PackageName, BPLPath, DCPPath) and\r\n RegisterIdePackage(BinaryFileName(BPLPath, PackageName), Description);\r\n\r\n OutputString(LoadResString(@RsIdePackageInstallationFinished));\r\nend;\r\n\r\nfunction TJclBorRADToolInstallation.InstallDelphiPackage(const PackageName, BPLPath, DCPPath: string): Boolean;\r\nvar\r\n RunOnly: Boolean;\r\n Unused, Description: string;\r\nbegin\r\n OutputString(Format(LoadResString(@RsPackageInstallationStarted), [PackageName]));\r\n\r\n GetDPKFileInfo(PackageName, RunOnly, @Unused, @Description);\r\n if RunOnly then\r\n raise EJclBorRadException.CreateResFmt(@RsECannotInstallRunOnly, [PackageName]);\r\n\r\n Result := CompileDelphiPackage(PackageName, BPLPath, DCPPath) and\r\n RegisterPackage(BinaryFileName(BPLPath, PackageName), Description);\r\n\r\n OutputString(LoadResString(@RsPackageInstallationFinished));\r\nend;\r\n\r\nfunction TJclBorRADToolInstallation.InstallExpert(const ProjectName, OutputDir, DcpSearchPath: string): Boolean;\r\nvar\r\n ProjectExtension: string;\r\nbegin\r\n ProjectExtension := ExtractFileExt(ProjectName);\r\n if SameText(ProjectExtension, SourceExtensionBCBProject) then\r\n Result := InstallBCBExpert(ProjectName, OutputDir, DcpSearchPath)\r\n else\r\n if SameText(ProjectExtension, SourceExtensionDelphiProject) then\r\n Result := InstallDelphiExpert(ProjectName, OutputDir, DcpSearchPath)\r\n else\r\n raise EJclBorRADException.CreateResFmt(@RsEUnknownProjectExtension, [ProjectExtension]);\r\nend;\r\n\r\nfunction TJclBorRADToolInstallation.InstallIDEPackage(const PackageName, BPLPath, DCPPath: string): Boolean;\r\nvar\r\n PackageExtension: string;\r\nbegin\r\n PackageExtension := ExtractFileExt(PackageName);\r\n if SameText(PackageExtension, SourceExtensionBCBPackage) then\r\n Result := InstallBCBIdePackage(PackageName, BPLPath, DCPPath)\r\n else\r\n if SameText(PackageExtension, SourceExtensionDelphiPackage) then\r\n Result := InstallDelphiIdePackage(PackageName, BPLPath, DCPPath)\r\n else\r\n raise EJclBorRADException.CreateResFmt(@RsEUnknownIdePackageExtension, [PackageExtension]);\r\nend;\r\n\r\nfunction TJclBorRADToolInstallation.InstallPackage(const PackageName, BPLPath, DCPPath: string): Boolean;\r\nvar\r\n PackageExtension: string;\r\nbegin\r\n PackageExtension := ExtractFileExt(PackageName);\r\n if SameText(PackageExtension, SourceExtensionBCBPackage) then\r\n Result := InstallBCBPackage(PackageName, BPLPath, DCPPath)\r\n else\r\n if SameText(PackageExtension, SourceExtensionDelphiPackage) then\r\n Result := InstallDelphiPackage(PackageName, BPLPath, DCPPath)\r\n else\r\n raise EJclBorRADException.CreateResFmt(@RsEUnknownPackageExtension, [PackageExtension]);\r\nend;\r\n\r\nfunction TJclBorRADToolInstallation.ProcessMapFile(const BinaryFileName: string): Boolean;\r\n{$IFDEF MSWINDOWS}\r\nvar\r\n MAPFileName, LinkerBugUnit: string;\r\n MAPFileSize, JclDebugDataSize: Integer;\r\n{$ENDIF MSWINDOWS}\r\nbegin\r\n {$IFDEF MSWINDOWS}\r\n if JdbgCreate then\r\n begin\r\n MAPFileName := ChangeFileExt(BinaryFileName, CompilerExtensionMAP);\r\n\r\n if JdbgInsert then\r\n begin\r\n OutputString(Format(LoadResString(@RsInsertingJdbg), [BinaryFileName]));\r\n Result := InsertDebugDataIntoExecutableFile(BinaryFileName, MAPFileName,\r\n LinkerBugUnit, MAPFileSize, JclDebugDataSize);\r\n OutputString(Format(LoadResString(@RsJdbgInfo), [LinkerBugUnit, MAPFileSize, JclDebugDataSize]));\r\n end\r\n else\r\n begin\r\n OutputString(Format(LoadResString(@RsCreatingJdbg), [BinaryFileName]));\r\n Result := ConvertMapFileToJdbgFile(MAPFileName);\r\n end;\r\n if Result then\r\n begin\r\n OutputString(LoadResString(@RsJdbgInfoOk));\r\n if MapDelete then\r\n OutputFileDelete(MAPFileName);\r\n end\r\n else\r\n OutputString(LoadResString(@RsJdbgInfoFailed));\r\n end\r\n else\r\n Result := True;\r\n {$ELSE MSWINDOWS}\r\n Result := True;\r\n {$ENDIF MSWINDOWS}\r\nend;\r\n\r\nfunction TJclBorRADToolInstallation.OutputFileDelete(const FileName: string): Boolean;\r\nbegin\r\n OutputString(Format(LoadResString(@RsDeletingFile), [FileName]));\r\n Result := FileDelete(FileName);\r\n if Result then\r\n OutputString(LoadResString(@RsFileDeletionOk))\r\n else\r\n OutputString(LoadResString(@RsFileDeletionFailed));\r\nend;\r\n\r\nprocedure TJclBorRADToolInstallation.OutputString(const AText: string);\r\nbegin\r\n if Assigned(FOutputCallback) then\r\n OutputCallback(AText);\r\nend;\r\n\r\nclass function TJclBorRADToolInstallation.PackageSourceFileExtension: string;\r\nbegin\r\n {$IFDEF MSWINDOWS}\r\n raise EAbstractError.CreateResFmt(@SAbstractError, ['']); // BCB doesn't support abstract keyword\r\n {$ELSE MSWINDOWS}\r\n Result := '';\r\n {$ENDIF MSWINDOWS}\r\nend;\r\n\r\nclass function TJclBorRADToolInstallation.ProjectSourceFileExtension: string;\r\nbegin\r\n {$IFDEF MSWINDOWS}\r\n raise EAbstractError.CreateResFmt(@SAbstractError, ['']); // BCB doesn't support abstract keyword\r\n {$ELSE MSWINDOWS}\r\n Result := '';\r\n {$ENDIF MSWINDOWS}\r\nend;\r\n\r\nclass function TJclBorRADToolInstallation.RADToolKind: TJclBorRADToolKind;\r\nbegin\r\n {$IFDEF MSWINDOWS}\r\n raise EAbstractError.CreateResFmt(@SAbstractError, ['']); // BCB doesn't support abstract keyword\r\n {$ELSE MSWINDOWS}\r\n Result := brDelphi;\r\n {$ENDIF MSWINDOWS}\r\nend;\r\n\r\n{class }function TJclBorRADToolInstallation.RADToolName: string;\r\nbegin\r\n {$IFDEF MSWINDOWS}\r\n raise EAbstractError.CreateResFmt(@SAbstractError, ['']); // BCB doesn't support abstract keyword\r\n {$ELSE MSWINDOWS}\r\n Result := '';\r\n {$ENDIF MSWINDOWS}\r\nend;\r\n\r\nprocedure TJclBorRADToolInstallation.ReadInformation;\r\n function FormatVersionNumber(const Num: Integer): string;\r\n begin\r\n Result := '';\r\n case RadToolKind of\r\n brDelphi:\r\n Result := Format('d%d', [Num]);\r\n brCppBuilder:\r\n Result := Format('c%d', [Num]);\r\n brBorlandDevStudio:\r\n case Num of\r\n 1:\r\n Result := 'cs1';\r\n else\r\n if Num < 7 then\r\n Result := Format('d%d', [Num + 6]) // BDS 2 goes to D8\r\n else\r\n Result := Format('d%d', [Num + 7]); // BDS 7 goes to D14\r\n end;\r\n end;\r\n end;\r\n\r\nconst\r\n BinDir = 'bin\\';\r\n UpdateKeyName = 'Update #';\r\n BDSUpdateKeyName = 'UpdatePackInstalled';\r\nvar\r\n KeyLen, I: Integer;\r\n Key, GlobalKey: string;\r\n Ed: TJclBorRADToolEdition;\r\n GlobalsBuffer: TStrings;\r\n Version: Extended;\r\nbegin\r\n Key := ConfigData.FileName;\r\n GlobalKey := StrEnsureSuffix('\\', Key) + GlobalsKeyName;\r\n GlobalsBuffer := TStringList.Create;\r\n try\r\n // overriden settings first\r\n RegGetValueNamesAndValues(HKCU, GlobalKey, GlobalsBuffer);\r\n Globals.AddStrings(GlobalsBuffer);\r\n RegGetValueNamesAndValues(HKCU, Key, GlobalsBuffer);\r\n Globals.AddStrings(GlobalsBuffer);\r\n RegGetValueNamesAndValues(HKLM, GlobalKey, GlobalsBuffer);\r\n Globals.AddStrings(GlobalsBuffer);\r\n RegGetValueNamesAndValues(HKLM, Key, GlobalsBuffer);\r\n Globals.AddStrings(GlobalsBuffer);\r\n finally\r\n GlobalsBuffer.Free;\r\n end;\r\n\r\n I := StrLastPos('\\', Key);\r\n if I > 0 then\r\n Key := Copy(Key, I + 1, Length(Key) - I);\r\n\r\n Key := StrReplaceChar(Key, '.', {$IFDEF RTL220_UP}FormatSettings.{$ENDIF}DecimalSeparator);\r\n Version := StrToFloatSafe(Key);\r\n if Frac(Version) = 0 then\r\n FIDEVersionNumber := Round(Version)\r\n else\r\n FIDEVersionNumber := 0;\r\n\r\n // If this is Spacely, then consider the version is equal to 4 (BDS2006)\r\n // as it is a non breaking version (dcu wise)\r\n\r\n { ahuser: Delphi 2007 is a non breaking version in the case that you can use\r\n BDS 2006 compiled units in Delphi 2007. But it completely breaks the BDS 2006\r\n installation because if BDS 2006 uses the Delphi 2007 compile DCUs the\r\n resulting executable is broken and will do strange things. So treat Delphi 2007\r\n as version 11 what it actually is. }\r\n {if (FIDEVersionNumber = 5) and (RadToolKind = brBorlandDevStudio) then\r\n FVersionNumber := 4\r\n else}\r\n FVersionNumber := FIDEVersionNumber;\r\n\r\n FVersionNumberStr := FormatVersionNumber(VersionNumber);\r\n FIDEVersionNumberStr := FormatVersionNumber(IDEVersionNumber);\r\n\r\n FRootDir := PathRemoveSeparator(Globals.Values[RootDirValueName]);\r\n FBinFolderName := PathAddSeparator(RootDir) + BinDir;\r\n\r\n FEditionStr := Globals.Values[EditionValueName];\r\n if FEditionStr = '' then\r\n FEditionStr := Globals.Values[VersionValueName];\r\n { TODO : Edition detection for BDS }\r\n for Ed := Low(Ed) to High(Ed) do\r\n if StrIPos(BorRADToolEditionIDs[Ed], FEditionStr) = 1 then\r\n FEdition := Ed;\r\n\r\n if RadToolKind = brBorlandDevStudio then\r\n FInstalledUpdatePack := StrToIntDef(Globals.Values[BDSUpdateKeyName], 0)\r\n else\r\n for I := 0 to Globals.Count - 1 do\r\n begin\r\n Key := Globals.Names[I];\r\n KeyLen := Length(UpdateKeyName);\r\n if (Pos(UpdateKeyName, Key) = 1) and (Length(Key) > KeyLen) and StrIsDigit(Key[KeyLen + 1]) then\r\n FInstalledUpdatePack := Max(FInstalledUpdatePack, Integer(Ord(Key[KeyLen + 1]) - 48));\r\n end;\r\nend;\r\n\r\nfunction TJclBorRADToolInstallation.RegisterExpert(const ProjectName, OutputDir, Description: string): Boolean;\r\nbegin\r\n Result := RegisterExpert(BinaryFileName(OutputDir, ProjectName), Description);\r\nend;\r\n\r\nfunction TJclBorRADToolInstallation.RegisterExpert(const BinaryFileName, Description: string): Boolean;\r\nvar\r\n InternalDescription: string;\r\nbegin\r\n OutputString(Format(LoadResString(@RsRegisteringExpert), [BinaryFileName]));\r\n\r\n if Description = '' then\r\n InternalDescription := PathExtractFileNameNoExt(BinaryFileName)\r\n else\r\n InternalDescription := Description;\r\n\r\n Result := IdePackages.AddExpert(BinaryFileName, InternalDescription);\r\n if Result then\r\n OutputString(LoadResString(@RsRegistrationOk))\r\n else\r\n OutputString(LoadResString(@RsRegistrationFailed));\r\nend;\r\n\r\nfunction TJclBorRADToolInstallation.RegisterIDEPackage(const PackageName, BPLPath, Description: string): Boolean;\r\nbegin\r\n Result := RegisterIDEPackage(BinaryFileName(BPLPath, PackageName), Description);\r\nend;\r\n\r\nfunction TJclBorRADToolInstallation.RegisterIDEPackage(const BinaryFileName, Description: string): Boolean;\r\nvar\r\n InternalDescription: string;\r\nbegin\r\n OutputString(Format(LoadResString(@RsRegisteringIdePackage), [BinaryFileName]));\r\n\r\n if Description = '' then\r\n InternalDescription := PathExtractFileNameNoExt(BinaryFileName)\r\n else\r\n InternalDescription := Description;\r\n\r\n Result := IdePackages.AddIDEPackage(BinaryFileName, InternalDescription);\r\n if Result then\r\n OutputString(LoadResString(@RsRegistrationOk))\r\n else\r\n OutputString(LoadResString(@RsRegistrationFailed));\r\nend;\r\n\r\nfunction TJclBorRADToolInstallation.RegisterPackage(const PackageName, BPLPath, Description: string): Boolean;\r\nbegin\r\n Result := RegisterPackage(BinaryFileName(BPLPath, PackageName), Description);\r\nend;\r\n\r\nfunction TJclBorRADToolInstallation.RegisterPackage(const BinaryFileName, Description: string): Boolean;\r\nvar\r\n InternalDescription: string;\r\nbegin\r\n OutputString(Format(LoadResString(@RsRegisteringPackage), [BinaryFileName]));\r\n\r\n if Description = '' then\r\n InternalDescription := PathExtractFileNameNoExt(BinaryFileName)\r\n else\r\n InternalDescription := Description;\r\n\r\n Result := IdePackages.AddPackage(BinaryFileName, InternalDescription);\r\n if Result then\r\n OutputString(LoadResString(@RsRegistrationOk))\r\n else\r\n OutputString(LoadResString(@RsRegistrationFailed));\r\nend;\r\n\r\nfunction TJclBorRADToolInstallation.RemoveFromDebugDCUPath(const Path: string; APlatform: TJclBDSPlatform): Boolean;\r\nvar\r\n TempRawDebugDCUPath: TJclBorRADToolPath;\r\nbegin\r\n CheckPlatform(APlatform);\r\n\r\n TempRawDebugDCUPath := RawDebugDCUPath[APlatform];\r\n Result := RemoveFromPath(TempRawDebugDCUPath, Path);\r\n RawDebugDCUPath[APlatform] := TempRawDebugDCUPath;\r\nend;\r\n\r\nfunction TJclBorRADToolInstallation.RemoveFromLibrarySearchPath(const Path: string; APlatform: TJclBDSPlatform): Boolean;\r\nvar\r\n TempRawLibraryPath: TJclBorRADToolPath;\r\nbegin\r\n CheckPlatform(APlatform);\r\n\r\n TempRawLibraryPath := RawLibrarySearchPath[APlatform];\r\n Result := RemoveFromPath(TempRawLibraryPath, Path);\r\n RawLibrarySearchPath[APlatform] := TempRawLibraryPath;\r\nend;\r\n\r\nfunction TJclBorRADToolInstallation.RemoveFromLibraryBrowsingPath(const Path: string; APlatform: TJclBDSPlatform): Boolean;\r\nvar\r\n TempRawLibraryPath: TJclBorRADToolPath;\r\nbegin\r\n CheckPlatform(APlatform);\r\n\r\n TempRawLibraryPath := RawLibraryBrowsingPath[APlatform];\r\n Result := RemoveFromPath(TempRawLibraryPath, Path);\r\n RawLibraryBrowsingPath[APlatform] := TempRawLibraryPath;\r\nend;\r\n\r\nfunction TJclBorRADToolInstallation.RemoveFromPath(var Path: string; const ItemsToRemove: string): Boolean;\r\nvar\r\n PathItems, RemoveItems: TStringList;\r\n Folder: string;\r\n I, J: Integer;\r\nbegin\r\n Result := False;\r\n PathItems := nil;\r\n RemoveItems := nil;\r\n try\r\n PathItems := TStringList.Create;\r\n RemoveItems := TStringList.Create;\r\n ExtractPaths(Path, PathItems);\r\n ExtractPaths(ItemsToRemove, RemoveItems);\r\n for I := 0 to RemoveItems.Count - 1 do\r\n begin\r\n Folder := RemoveItems[I];\r\n J := FindFolderInPath(Folder, PathItems);\r\n if J <> -1 then\r\n begin\r\n PathItems.Delete(J);\r\n Result := True;\r\n end;\r\n end;\r\n Path := StringsToStr(PathItems, PathSep, False);\r\n finally\r\n PathItems.Free;\r\n RemoveItems.Free;\r\n end;\r\nend;\r\n\r\nprocedure TJclBorRADToolInstallation.SetDCC(const Value: TJclDCC32);\r\nbegin\r\n FDCC := Value;\r\nend;\r\n\r\nprocedure TJclBorRADToolInstallation.SetOutputCallback(const Value: TTextHandler);\r\nbegin\r\n FOutputCallback := Value;\r\n //if clAsm in CommandLineTools then\r\n // Asm.OutputCallback := Value;\r\n if clBcc32 in CommandLineTools then\r\n Bcc32.OutputCallback := Value;\r\n if clDcc32 in CommandLineTools then\r\n Dcc32.OutputCallback := Value;\r\n //if clDccIL in CommandLineTools then\r\n // DccIL.OutputCallback := Value;\r\n if clMake in CommandLineTools then\r\n Make.OutputCallback := Value;\r\n if clProj2Mak in CommandLineTools then\r\n Bpr2Mak.OutputCallback := Value;\r\nend;\r\n\r\nprocedure TJclBorRADToolInstallation.SetRawDebugDCUPath(APlatform: TJclBDSPlatform; const Value: TJclBorRADToolPath);\r\nbegin\r\n CheckPlatform(APlatform);\r\n ConfigData.WriteString(DebuggingKeyName, DebugDCUPathValueName, Value);\r\nend;\r\n\r\nprocedure TJclBorRADToolInstallation.SetRawLibrarySearchPath(APlatform: TJclBDSPlatform; const Value: TJclBorRADToolPath);\r\nbegin\r\n CheckPlatform(APlatform);\r\n ConfigData.WriteString(LibraryKeyName, LibrarySearchPathValueName, Value);\r\nend;\r\n\r\nprocedure TJclBorRADToolInstallation.SetRawLibraryBrowsingPath(APlatform: TJclBDSPlatform; const Value: TJclBorRADToolPath);\r\nbegin\r\n CheckPlatform(APlatform);\r\n ConfigData.WriteString(LibraryKeyName, LibraryBrowsingPathValueName, Value);\r\nend;\r\n\r\nfunction TJclBorRADToolInstallation.SubstitutePath(const Path: string): string;\r\nvar\r\n I: Integer;\r\n Name: string;\r\nbegin\r\n Result := Path;\r\n if Pos('$(', Result) > 0 then\r\n with EnvironmentVariables do\r\n for I := 0 to Count - 1 do\r\n begin\r\n Name := Names[I];\r\n Result := StringReplace(Result, Format('$(%s)', [Name]), Values[Name], [rfReplaceAll, rfIgnoreCase]);\r\n end;\r\n // remove duplicate path delimiters '\\\\'\r\n Result := StringReplace(Result, DirDelimiter + DirDelimiter, DirDelimiter, [rfReplaceAll]);\r\nend;\r\n\r\nfunction TJclBorRADToolInstallation.SupportsVCL: Boolean;\r\nconst\r\n VclDcp = 'vcl.dcp';\r\nbegin\r\n Result := ((RadToolKind <> brBorlandDevStudio) and (VersionNumber = 5)) or\r\n FileExists(LibFolderName[bpWin32] + VclDcp) or FileExists(ObjFolderName[bpWin32] + VclDcp);\r\nend;\r\n\r\nfunction TJclBorRADToolInstallation.SupportsVisualCLX: Boolean;\r\nconst\r\n VisualClxDcp = 'visualclx.dcp';\r\nbegin\r\n Result := (Edition <> deSTD) and (VersionNumber in [6, 7]) and (RadToolKind <> brBorlandDevStudio) and\r\n (FileExists(LibFolderName[bpWin32] + VisualClxDcp) or FileExists(ObjFolderName[bpWin32] + VisualClxDcp));\r\nend;\r\n\r\nfunction TJclBorRADToolInstallation.UninstallBCBExpert(const ProjectName, OutputDir: string): Boolean;\r\nvar\r\n DllFileName: string;\r\nbegin\r\n OutputString(Format(LoadResString(@RsExpertUninstallationStarted), [ProjectName]));\r\n\r\n if not IsBCBProject(ProjectName) then\r\n raise EJclBorRADException.CreateResFmt(@RsENotABCBProject, [ProjectName]);\r\n\r\n DllFileName := BinaryFileName(OutputDir, ProjectName);\r\n // important: remove from experts /before/ deleting;\r\n // otherwise PathGetLongPathName won't work\r\n Result := UnregisterExpert(DllFileName);\r\n\r\n if Result then\r\n OutputFileDelete(DllFileName);\r\n\r\n OutputString(LoadResString(@RsExpertUninstallationFinished));\r\nend;\r\n\r\nfunction TJclBorRADToolInstallation.UninstallBCBIdePackage(const PackageName, BPLPath, DCPPath: string): Boolean;\r\nvar\r\n MAPFileName, TDSFileName,\r\n BPIFileName, LIBFileName, BPLFileName: string;\r\n RunOnly: Boolean;\r\nbegin\r\n OutputString(Format(LoadResString(@RsIdePackageUninstallationStarted), [PackageName]));\r\n\r\n if not IsBCBPackage(PackageName) then\r\n raise EJclBorRADException.CreateResFmt(@RsENotABCBPackage, [PackageName]);\r\n\r\n GetBPKFileInfo(PackageName, RunOnly);\r\n\r\n BPLFileName := BinaryFileName(BPLPath, PackageName);\r\n\r\n // important: remove from IDE packages /before/ deleting;\r\n // otherwise PathGetLongPathName won't work\r\n Result := (RunOnly or UnregisterIdePackage(BPLFileName));\r\n\r\n // Don't delete binaries if removal of design time package failed\r\n if Result then\r\n begin\r\n OutputFileDelete(BPLFileName);\r\n\r\n BPIFileName := PathAddSeparator(DCPPath) + PathExtractFileNameNoExt(PackageName) + CompilerExtensionBPI;\r\n OutputFileDelete(BPIFileName);\r\n\r\n LIBFileName := ChangeFileExt(BPIFileName, CompilerExtensionLIB);\r\n OutputFileDelete(LIBFileName);\r\n\r\n MAPFileName := ChangeFileExt(BPLFileName, CompilerExtensionMAP);\r\n OutputFileDelete(MAPFileName);\r\n\r\n TDSFileName := ChangeFileExt(BPLFileName, CompilerExtensionTDS);\r\n OutputFileDelete(TDSFileName);\r\n end;\r\n\r\n OutputString(LoadResString(@RsIdePackageUninstallationFinished));\r\nend;\r\n\r\nfunction TJclBorRADToolInstallation.UninstallBCBPackage(const PackageName, BPLPath, DCPPath: string): Boolean;\r\nvar\r\n MAPFileName, TDSFileName, TmpBinaryFileName,\r\n BPIFileName, LIBFileName, BPLFileName: string;\r\n RunOnly: Boolean;\r\nbegin\r\n OutputString(Format(LoadResString(@RsPackageUninstallationStarted), [PackageName]));\r\n\r\n if not IsBCBPackage(PackageName) then\r\n raise EJclBorRADException.CreateResFmt(@RsENotABCBPackage, [PackageName]);\r\n\r\n GetBPKFileInfo(PackageName, RunOnly, @TmpBinaryFileName);\r\n\r\n BPLFileName := BinaryFileName(BPLPath, PackageName);\r\n\r\n // important: remove from IDE packages /before/ deleting;\r\n // otherwise PathGetLongPathName won't work\r\n Result := (RunOnly or UnregisterPackage(BPLFileName));\r\n\r\n // Don't delete binaries if removal of design time package failed\r\n if Result then\r\n begin\r\n OutputFileDelete(BPLFileName);\r\n\r\n BPIFileName := PathAddSeparator(DCPPath) + PathExtractFileNameNoExt(PackageName) + CompilerExtensionBPI;\r\n OutputFileDelete(BPIFileName);\r\n\r\n LIBFileName := ChangeFileExt(BPIFileName, CompilerExtensionLIB);\r\n OutputFileDelete(LIBFileName);\r\n\r\n MAPFileName := ChangeFileExt(BPLFileName, CompilerExtensionMAP);\r\n OutputFileDelete(MAPFileName);\r\n\r\n TDSFileName := ChangeFileExt(BPLFileName, CompilerExtensionTDS);\r\n OutputFileDelete(TDSFileName);\r\n end;\r\n\r\n OutputString(LoadResString(@RsPackageUninstallationFinished));\r\nend;\r\n\r\nfunction TJclBorRADToolInstallation.UninstallDelphiExpert(const ProjectName, OutputDir: string): Boolean;\r\nvar\r\n DllFileName: string;\r\nbegin\r\n OutputString(Format(LoadResString(@RsExpertUninstallationStarted), [ProjectName]));\r\n\r\n if not IsDelphiProject(ProjectName) then\r\n raise EJclBorRADException.CreateResFmt(@RsENotADelphiProject, [ProjectName]);\r\n\r\n DllFileName := BinaryFileName(OutputDir, ProjectName);\r\n // important: remove from experts /before/ deleting;\r\n // otherwise PathGetLongPathName won't work\r\n Result := UnregisterExpert(DllFileName);\r\n\r\n if Result then\r\n OutputFileDelete(DllFileName);\r\n\r\n OutputString(LoadResString(@RsExpertUninstallationFinished));\r\nend;\r\n\r\nfunction TJclBorRADToolInstallation.UninstallDelphiIdePackage(const PackageName, BPLPath, DCPPath: string): Boolean;\r\nvar\r\n MAPFileName,\r\n BPLFileName, DCPFileName: string;\r\n BaseName: string;\r\n RunOnly: Boolean;\r\nbegin\r\n OutputString(Format(LoadResString(@RsIdePackageUninstallationStarted), [PackageName]));\r\n\r\n if not IsDelphiPackage(PackageName) then\r\n raise EJclBorRADException.CreateResFmt(@RsENotADelphiPackage, [PackageName]);\r\n\r\n GetDPKFileInfo(PackageName, RunOnly);\r\n BaseName := PathExtractFileNameNoExt(PackageName);\r\n\r\n BPLFileName := BinaryFileName(BPLPath, PackageName);\r\n\r\n // important: remove from IDE packages /before/ deleting;\r\n // otherwise PathGetLongPathName won't work\r\n Result := RunOnly or UnregisterIdePackage(BPLFileName);\r\n\r\n // Don't delete binaries if removal of design time package failed\r\n if Result then\r\n begin\r\n OutputFileDelete(BPLFileName);\r\n\r\n DCPFileName := PathAddSeparator(DCPPath) + BaseName + CompilerExtensionDCP;\r\n OutputFileDelete(DCPFileName);\r\n\r\n MAPFileName := ChangeFileExt(BPLFileName, CompilerExtensionMAP);\r\n OutputFileDelete(MAPFileName);\r\n end;\r\n\r\n OutputString(LoadResString(@RsIdePackageUninstallationFinished));\r\nend;\r\n\r\nfunction TJclBorRADToolInstallation.UninstallDelphiPackage(const PackageName, BPLPath, DCPPath: string): Boolean;\r\nvar\r\n MAPFileName, BPLFileName, DCPFileName: string;\r\n BaseName: string;\r\n RunOnly: Boolean;\r\nbegin\r\n OutputString(Format(LoadResString(@RsPackageUninstallationStarted), [PackageName]));\r\n\r\n if not IsDelphiPackage(PackageName) then\r\n raise EJclBorRADException.CreateResFmt(@RsENotADelphiPackage, [PackageName]);\r\n\r\n GetDPKFileInfo(PackageName, RunOnly);\r\n BaseName := PathExtractFileNameNoExt(PackageName);\r\n\r\n BPLFileName := BinaryFileName(BPLPath, PackageName);\r\n\r\n // important: remove from IDE packages /before/ deleting;\r\n // otherwise PathGetLongPathName won't work\r\n Result := RunOnly or UnregisterPackage(BPLFileName);\r\n\r\n // Don't delete binaries if removal of design time package failed\r\n if Result then\r\n begin\r\n OutputFileDelete(BPLFileName);\r\n\r\n DCPFileName := PathAddSeparator(DCPPath) + BaseName + CompilerExtensionDCP;\r\n OutputFileDelete(DCPFileName);\r\n\r\n MAPFileName := ChangeFileExt(BPLFileName, CompilerExtensionMAP);\r\n OutputFileDelete(MAPFileName);\r\n end;\r\n\r\n OutputString(LoadResString(@RsPackageUninstallationFinished));\r\nend;\r\n\r\nfunction TJclBorRADToolInstallation.UninstallExpert(const ProjectName, OutputDir: string): Boolean;\r\nvar\r\n ProjectExtension: string;\r\nbegin\r\n ProjectExtension := ExtractFileExt(ProjectName);\r\n if SameText(ProjectExtension, SourceExtensionBCBProject) then\r\n Result := UninstallBCBExpert(ProjectName, OutputDir)\r\n else\r\n if SameText(ProjectExtension, SourceExtensionDelphiProject) then\r\n Result := UninstallDelphiExpert(ProjectName, OutputDir)\r\n else\r\n raise EJclBorRadException.CreateResFmt(@RsEUnknownProjectExtension, [ProjectExtension]);\r\nend;\r\n\r\nfunction TJclBorRADToolInstallation.UninstallIDEPackage(const PackageName, BPLPath, DCPPath: string): Boolean;\r\nvar\r\n PackageExtension: string;\r\nbegin\r\n PackageExtension := ExtractFileExt(PackageName);\r\n if SameText(PackageExtension, SourceExtensionBCBPackage) then\r\n Result := UninstallBCBIdePackage(PackageName, BPLPath, DCPPath)\r\n else\r\n if SameText(PackageExtension, SourceExtensionDelphiPackage) then\r\n Result := UninstallDelphiIdePackage(PackageName, BPLPath, DCPPath)\r\n else\r\n raise EJclBorRadException.CreateResFmt(@RsEUnknownIdePackageExtension, [PackageExtension]);\r\nend;\r\n\r\nfunction TJclBorRADToolInstallation.UninstallPackage(const PackageName, BPLPath, DCPPath: string): Boolean;\r\nvar\r\n PackageExtension: string;\r\nbegin\r\n PackageExtension := ExtractFileExt(PackageName);\r\n if SameText(PackageExtension, SourceExtensionBCBPackage) then\r\n Result := UninstallBCBPackage(PackageName, BPLPath, DCPPath)\r\n else\r\n if SameText(PackageExtension, SourceExtensionDelphiPackage) then\r\n Result := UninstallDelphiPackage(PackageName, BPLPath, DCPPath)\r\n else\r\n raise EJclBorRadException.CreateResFmt(@RsEUnknownPackageExtension, [PackageExtension]);\r\nend;\r\n\r\nfunction TJclBorRADToolInstallation.UnregisterExpert(const ProjectName, OutputDir: string): Boolean;\r\nbegin\r\n Result := UnregisterExpert(BinaryFileName(OutputDir, ProjectName));\r\nend;\r\n\r\nfunction TJclBorRADToolInstallation.UnregisterExpert(const BinaryFileName: string): Boolean;\r\nbegin\r\n OutputString(Format(LoadResString(@RsUnregisteringExpert), [BinaryFileName]));\r\n\r\n Result := IdePackages.RemoveExpert(BinaryFileName);\r\n if Result then\r\n OutputString(LoadResString(@RsUnregistrationOk))\r\n else\r\n OutputString(LoadResString(@RsUnregistrationFailed));\r\nend;\r\n\r\nfunction TJclBorRADToolInstallation.UnregisterIDEPackage(const PackageName, BPLPath: string): Boolean;\r\nbegin\r\n Result := UnregisterIDEPackage(BinaryFileName(BPLPath, PackageName));\r\nend;\r\n\r\nfunction TJclBorRADToolInstallation.UnregisterIDEPackage(const BinaryFileName: string): Boolean;\r\nbegin\r\n OutputString(Format(LoadResString(@RsUnregisteringIDEPackage), [BinaryFileName]));\r\n\r\n Result := IdePackages.RemoveIDEPackage(BinaryFileName);\r\n if Result then\r\n OutputString(LoadResString(@RsUnregistrationOk))\r\n else\r\n OutputString(LoadResString(@RsUnregistrationFailed));\r\nend;\r\n\r\nfunction TJclBorRADToolInstallation.UnregisterPackage(const PackageName, BPLPath: string): Boolean;\r\nbegin\r\n Result := UnregisterPackage(BinaryFileName(BPLPath, PackageName));\r\nend;\r\n\r\nfunction TJclBorRADToolInstallation.UnregisterPackage(const BinaryFileName: string): Boolean;\r\nbegin\r\n OutputString(Format(LoadResString(@RsUnregisteringPackage), [BinaryFileName]));\r\n\r\n Result := IdePackages.RemovePackage(BinaryFileName);\r\n if Result then\r\n OutputString(LoadResString(@RsUnregistrationOk))\r\n else\r\n OutputString(LoadResString(@RsUnregistrationFailed));\r\nend;\r\n\r\n//=== { TJclBCBInstallation } ================================================\r\n\r\nconstructor TJclBCBInstallation.Create(const AConfigDataLocation: string; ARootKey: Cardinal);\r\nbegin\r\n inherited Create(AConfigDataLocation, ARootKey);\r\n FPersonalities := [bpBCBuilder32];\r\n if clDcc32 in CommandLineTools then\r\n Include(FPersonalities, bpDelphi32);\r\nend;\r\n\r\ndestructor TJclBCBInstallation.Destroy;\r\nbegin\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJclBCBInstallation.GetEnvironmentVariables: TStrings;\r\nbegin\r\n Result := inherited GetEnvironmentVariables;\r\n if Assigned(Result) then\r\n Result.Values['BCB'] := PathRemoveSeparator(RootDir);\r\nend;\r\n\r\nclass function TJclBCBInstallation.GetLatestUpdatePackForVersion(Version: Integer): Integer;\r\nbegin\r\n case Version of\r\n 5:\r\n Result := 0;\r\n 6:\r\n Result := 4;\r\n 10:\r\n Result := 0;\r\n else\r\n Result := 0;\r\n end;\r\nend;\r\n\r\nclass function TJclBCBInstallation.PackageSourceFileExtension: string;\r\nbegin\r\n Result := SourceExtensionBCBPackage;\r\nend;\r\n\r\nclass function TJclBCBInstallation.ProjectSourceFileExtension: string;\r\nbegin\r\n Result := SourceExtensionBCBProject;\r\nend;\r\n\r\nclass function TJclBCBInstallation.RadToolKind: TJclBorRadToolKind;\r\nbegin\r\n Result := brCppBuilder;\r\nend;\r\n\r\nfunction TJclBCBInstallation.RADToolName: string;\r\nbegin\r\n Result := LoadResString(@RsBCBName);\r\nend;\r\n\r\n//=== { TJclDelphiInstallation } =============================================\r\n\r\nconstructor TJclDelphiInstallation.Create(const AConfigDataLocation: string; ARootKey: Cardinal);\r\nbegin\r\n inherited Create(AConfigDataLocation, ARootKey);\r\n FPersonalities := [bpDelphi32];\r\nend;\r\n\r\ndestructor TJclDelphiInstallation.Destroy;\r\nbegin\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJclDelphiInstallation.GetEnvironmentVariables: TStrings;\r\nbegin\r\n Result := inherited GetEnvironmentVariables;\r\n if Assigned(Result) then\r\n Result.Values['DELPHI'] := PathRemoveSeparator(RootDir);\r\nend;\r\n\r\nclass function TJclDelphiInstallation.GetLatestUpdatePackForVersion(Version: Integer): Integer;\r\nbegin\r\n case Version of\r\n 5:\r\n Result := 1;\r\n 6:\r\n Result := 2;\r\n 7:\r\n Result := 0;\r\n else\r\n Result := 0;\r\n end;\r\nend;\r\n\r\nfunction TJclDelphiInstallation.InstallPackage(const PackageName, BPLPath, DCPPath: string): Boolean;\r\nbegin\r\n Result := InstallDelphiPackage(PackageName, BPLPath, DCPPath);\r\nend;\r\n\r\nclass function TJclDelphiInstallation.PackageSourceFileExtension: string;\r\nbegin\r\n Result := SourceExtensionDelphiPackage;\r\nend;\r\n\r\nclass function TJclDelphiInstallation.ProjectSourceFileExtension: string;\r\nbegin\r\n Result := SourceExtensionDelphiProject;\r\nend;\r\n\r\nclass function TJclDelphiInstallation.RadToolKind: TJclBorRadToolKind;\r\nbegin\r\n Result := brDelphi;\r\nend;\r\n\r\nfunction TJclDelphiInstallation.RADToolName: string;\r\nbegin\r\n Result := LoadResString(@RsDelphiName);\r\nend;\r\n\r\n//=== { TJclBDSInstallation } ==================================================\r\n\r\n{$IFDEF MSWINDOWS}\r\n\r\nconstructor TJclBDSInstallation.Create(const AConfigDataLocation: string; ARootKey: Cardinal = 0);\r\nconst\r\n PersonalitiesSection = 'Personalities';\r\nbegin\r\n inherited Create(AConfigDataLocation, ARootKey);\r\n FHelp2Manager := TJclHelp2Manager.Create(IDEVersionNumber);\r\n\r\n if ConfigData.ReadString(PersonalitiesSection, 'C#Builder', '') <> '' then\r\n Include(FPersonalities, bpCSBuilder32);\r\n if ConfigData.ReadString(PersonalitiesSection, 'BCB', '') <> '' then\r\n Include(FPersonalities, bpBCBuilder32);\r\n if ConfigData.ReadString(PersonalitiesSection, 'Delphi.Win32', '') <> '' then\r\n Include(FPersonalities, bpDelphi32);\r\n if (ConfigData.ReadString(PersonalitiesSection, 'Delphi.NET', '') <> '') or\r\n (ConfigData.ReadString(PersonalitiesSection, 'Delphi8', '') <> '') then\r\n begin\r\n Include(FPersonalities, bpDelphiNet32);\r\n if VersionNumber >= 5 then\r\n Include(FPersonalities, bpDelphiNet64);\r\n end;\r\n\r\n if clDcc32 in CommandLineTools then\r\n Include(FPersonalities, bpDelphi32);\r\n if clDcc64 in CommandLineTools then\r\n Include(FPersonalities, bpDelphi64);\r\n if clDccOSX32 in CommandLineTools then\r\n Include(FPersonalities, bpDelphiOSX32);\r\n if clBcc64 in CommandLineTools then\r\n Include(FPersonalities, bpBCBuilder64);\r\nend;\r\n\r\ndestructor TJclBDSInstallation.Destroy;\r\nbegin\r\n FreeAndNil(FDCCIL);\r\n FreeAndNil(FDCC64);\r\n FreeAndNil(FBCC64);\r\n FreeAndNil(FDCCOSX32);\r\n FreeAndNil(FHelp2Manager);\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJclBDSInstallation.AddToCppBrowsingPath(const Path: string; APlatform: TJclBDSPlatform): Boolean;\r\nvar\r\n TempRawCppPath: TJclBorRADToolPath;\r\nbegin\r\n CheckCBuilderPlatform(APlatform);\r\n\r\n if Path <> '' then\r\n begin\r\n TempRawCppPath := RawCppBrowsingPath[APlatform];\r\n PathListIncludeItems(TempRawCppPath, Path);\r\n Result := True;\r\n RawCppBrowsingPath[APlatform] := TempRawCppPath;\r\n end\r\n else\r\n Result := False;\r\nend;\r\n\r\nfunction TJclBDSInstallation.AddToCppSearchPath(const Path: string; APlatform: TJclBDSPlatform): Boolean;\r\nvar\r\n TempRawCppPath: TJclBorRADToolPath;\r\nbegin\r\n CheckCBuilderPlatform(APlatform);\r\n\r\n if Path <> '' then\r\n begin\r\n TempRawCppPath := RawCppSearchPath[APlatform];\r\n PathListIncludeItems(TempRawCppPath, Path);\r\n Result := True;\r\n RawCppSearchPath[APlatform] := TempRawCppPath;\r\n end\r\n else\r\n Result := False;\r\nend;\r\n\r\nfunction TJclBDSInstallation.AddToCppLibraryPath(const Path: string; APlatform: TJclBDSPlatform): Boolean;\r\nvar\r\n TempRawLibraryPath: TJclBorRADToolPath;\r\nbegin\r\n CheckCBuilderPlatform(APlatform);\r\n\r\n if (IDEVersionNumber >= 5) and (Path <> '') then\r\n begin\r\n TempRawLibraryPath := RawCppLibraryPath[APlatform];\r\n PathListIncludeItems(TempRawLibraryPath, Path);\r\n Result := True;\r\n RawCppLibraryPath[APlatform] := TempRawLibraryPath;\r\n end\r\n else\r\n Result := False;\r\nend;\r\n\r\nfunction TJclBDSInstallation.AddToCppIncludePath(const Path: string; APlatform: TJclBDSPlatform): Boolean;\r\nvar\r\n TempRawIncludePath: TJclBorRADToolPath;\r\nbegin\r\n CheckCBuilderPlatform(APlatform);\r\n\r\n if (IDEVersionNumber >= 5) and (Path <> '') then\r\n begin\r\n TempRawIncludePath := RawCppIncludePath[APlatform];\r\n PathListIncludeItems(TempRawIncludePath, Path);\r\n Result := True;\r\n RawCppIncludePath[APlatform] := TempRawIncludePath;\r\n end\r\n else\r\n Result := False;\r\nend;\r\n\r\nfunction TJclBDSInstallation.CleanPackageCache(const BinaryFileName: string): Boolean;\r\nvar\r\n FileName, KeyName: string;\r\nbegin\r\n Result := True;\r\n\r\n if VersionNumber >= 3 then\r\n begin\r\n FileName := ExtractFileName(BinaryFileName);\r\n\r\n try\r\n OutputString(Format(LoadResString(@RsCleaningPackageCache), [FileName]));\r\n KeyName := PathAddSeparator(ConfigDataLocation) + PackageCacheKeyName + '\\' + FileName;\r\n\r\n if RegKeyExists(RootKey, KeyName) then\r\n Result := RegDeleteKeyTree(RootKey, KeyName);\r\n\r\n if Result then\r\n OutputString(LoadResString(@RsCleaningOk))\r\n else\r\n OutputString(LoadResString(@RsCleaningFailed));\r\n except\r\n // trap possible exceptions\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJclBDSInstallation.CompileDelphiDotNetProject(const ProjectName,\r\n OutputDir: string; PEFormat: TJclBDSPlatform; const ExtraOptions: string): Boolean;\r\nvar\r\n DCCILOptions, PlatformOption, PdbOption: string;\r\nbegin\r\n if VersionNumber >= 2 then // C#Builder 1 doesn't have any Delphi.net compiler\r\n begin\r\n if IsDelphiProject(ProjectName) then\r\n OutputString(Format(LoadResString(@RsCompilingProject), [ProjectName]))\r\n else\r\n if IsDelphiPackage(ProjectName) then\r\n OutputString(Format(LoadResString(@RsCompilingPackage), [ProjectName]))\r\n else\r\n raise EJclBorRADException.CreateResFmt(@RsENotADelphiProject, [ProjectName]);\r\n\r\n PlatformOption := '';\r\n case PEFormat of\r\n bpWin32:\r\n if VersionNumber >= 3 then\r\n PlatformOption := 'x86';\r\n bpWin64:\r\n if VersionNumber >= 3 then\r\n PlatformOption := 'x64'\r\n else\r\n raise EJclBorRADException.CreateRes(@RsEWin64PlatformNotValid);\r\n bpOSX32:\r\n raise EJclBorRADException.CreateRes(@RsEOSXPlatformNotValid);\r\n else\r\n raise EJclBorRADException.CreateRes(@RsEPlatformNotValid);\r\n end;\r\n\r\n if PdbCreate then\r\n PdbOption := '-V'\r\n else\r\n PdbOption := '';\r\n\r\n DCCILOptions := Format('%s --platform:%s %s', [ExtraOptions, PlatformOption, PdbOption]);\r\n\r\n Result := DCCIL.MakeProject(ProjectName, OutputDir, DCCILOptions);\r\n\r\n if Result then\r\n OutputString(LoadResString(@RsCompilationOk))\r\n else\r\n OutputString(LoadResString(@RsCompilationFailed));\r\n end\r\n else\r\n raise EJclBorRADException.CreateRes(@RsENoSupportedPersonality);\r\nend;\r\n\r\nfunction TJclBDSInstallation.CompileDelphiPackage(const PackageName, BPLPath, DCPPath, ExtraOptions: string): Boolean;\r\nvar\r\n NewOptions: string;\r\nbegin\r\n if DualPackageInstallation then\r\n begin\r\n if not (bpBCBuilder32 in Personalities) then\r\n raise EJclBorRadException.CreateResFmt(@RsEDualPackageNotSupported, [Name]);\r\n\r\n NewOptions := Format('%s -JL -NB\"%s\" -NO\"%s\"',\r\n [ExtraOptions, PathRemoveSeparator(DcpPath),\r\n PathRemoveSeparator(DcpPath)]);\r\n end\r\n else\r\n NewOptions := ExtraOptions;\r\n\r\n Result := inherited CompileDelphiPackage(PackageName, BPLPath, DCPPath, NewOptions);\r\nend;\r\n\r\nfunction TJclBDSInstallation.CompileDelphiProject(const ProjectName, OutputDir, DcpSearchPath: string): Boolean;\r\nvar\r\n ExtraOptions: string;\r\nbegin\r\n if VersionNumber <= 2 then\r\n begin\r\n OutputString(Format(LoadResString(@RsCompilingProject), [ProjectName]));\r\n\r\n if not IsDelphiProject(ProjectName) then\r\n raise EJclBorRADException.CreateResFmt(@RsENotADelphiProject, [ProjectName]);\r\n\r\n if MapCreate then\r\n ExtraOptions := '-GD'\r\n else\r\n ExtraOptions := '';\r\n\r\n Result := DCC32.MakeProject(ProjectName, OutputDir, DcpSearchPath, ExtraOptions) and\r\n ProcessMapFile(BinaryFileName(OutputDir, ProjectName));\r\n\r\n if Result then\r\n OutputString(LoadResString(@RsCompilationOk))\r\n else\r\n OutputString(LoadResString(@RsCompilationFailed));\r\n end\r\n else\r\n Result := inherited CompileDelphiProject(ProjectName, DcpSearchPath, OutputDir);\r\nend;\r\n\r\nfunction TJclBDSInstallation.GetBDSPlatformStr(APlatform: TJclBDSPlatform): string;\r\nbegin\r\n Result := '';\r\n case APlatform of\r\n bpWin32:\r\n Result := BDSPlatformWin32;\r\n bpWin64:\r\n Result := BDSPlatformWin64;\r\n bpOSX32:\r\n Result := BDSPlatformOSX32;\r\n else\r\n raise EJclBorRADException.CreateRes(@RsEPlatformNotValid);\r\n end;\r\nend;\r\n\r\nfunction TJclBDSInstallation.GetBPLOutputPath(APlatform: TJclBDSPlatform): string;\r\nbegin\r\n CheckPlatform(APlatform);\r\n\r\n // BDS 1 (C#Builder 1) and BDS 2 (Delphi 8) don't have a valid BPL output path\r\n // set in the registry\r\n case IDEVersionNumber of\r\n 1, 2:\r\n Result := PathAddSeparator(GetDefaultProjectsDir) + 'bpl';\r\n 3, 4:\r\n Result := inherited GetBPLOutputPath(APlatform);\r\n 5, 6, 7:\r\n begin\r\n Result := GetMsBuildEnvOption(MsBuildCBuilderBPLOutputPathNodeName, APlatform, False);\r\n if Result = '' then\r\n Result := GetMsBuildEnvOption(MsBuildWin32DLLOutputPathNodeName, APlatform, False);\r\n end;\r\n else\r\n Result := GetMsBuildEnvOption(MsBuildCBuilderBPLOutputPathNodeName, APlatform, False);\r\n if Result = '' then\r\n Result := GetMsBuildEnvOption(MsBuildDelphiDLLOutputPathNodeName, APlatform, False);\r\n end;\r\nend;\r\n\r\nfunction TJclBDSInstallation.GetCommonProjectsDir: string;\r\nbegin\r\n Result := GetCommonProjectsDirectory(RootDir, IDEVersionNumber);\r\nend;\r\n\r\nclass function TJclBDSInstallation.GetCommonProjectsDirectory(const RootDir: string;\r\n IDEVersionNumber: Integer): string;\r\nvar\r\n Variables: TStrings;\r\nbegin\r\n if IDEVersionNumber >= 5 then\r\n begin\r\n Result := '';\r\n\r\n Variables := TStringList.Create;\r\n try\r\n GetRADStudioVars(RootDir, IDEVersionNumber, Variables);\r\n Result := Variables.Values[EnvVariableBDSCOMDIRValueName];\r\n finally\r\n Variables.Free;\r\n end;\r\n\r\n if Result = '' then\r\n begin\r\n Result := LoadResStrings(RootDir + '\\Bin\\coreide' + BDSVersions[IDEVersionNumber].CoreIdeVersion + '.',\r\n ['RAD Studio'])[0];\r\n\r\n Result := Format('%s%s%d.0',\r\n [PathAddSeparator(GetCommonDocumentsFolder), PathAddSeparator(Result), IDEVersionNumber]);\r\n end;\r\n end\r\n else\r\n Result := GetDefaultProjectsDirectory(RootDir, IDEVersionNumber);\r\nend;\r\n\r\nfunction TJclBDSInstallation.GetCppPathsKeyName: string;\r\nbegin\r\n if IDEVersionNumber >= 5 then\r\n Result := CppPathsV5UpperKeyName\r\n else\r\n Result := CppPathsKeyName;\r\nend;\r\n\r\nfunction TJclBDSInstallation.GetCppBrowsingPath(APlatform: TJclBDSPlatform): TJclBorRADToolPath;\r\nbegin\r\n CheckCBuilderPlatform(APlatform);\r\n if IDEVersionNumber >= 5 then\r\n // use EnvOptions.proj\r\n Result := GetMsBuildEnvOption(MsBuildCBuilderBrowsingPathNodeName, APlatform, False)\r\n else\r\n Result := ConfigData.ReadString(GetCppPathsKeyName, CppBrowsingPathValueName, '');\r\nend;\r\n\r\nfunction TJclBDSInstallation.GetCppSearchPath(APlatform: TJclBDSPlatform): TJclBorRADToolPath;\r\nbegin\r\n CheckCBuilderPlatform(APlatform);\r\n // CPP search path is only in the registry\r\n Result := ConfigData.ReadString(GetCppPathsKeyName, CppSearchPathValueName, '');\r\nend;\r\n\r\nfunction TJclBDSInstallation.GetCppLibraryPath(APlatform: TJclBDSPlatform): TJclBorRADToolPath;\r\nbegin\r\n CheckCBuilderPlatform(APlatform);\r\n if IDEVersionNumber >= 5 then\r\n // use EnvOptions.proj\r\n Result := GetMsBuildEnvOption(MsBuildCBuilderLibraryPathNodeName, APlatform, False)\r\n else\r\n Result := ConfigData.ReadString(GetCppPathsKeyName, CppLibraryPathValueName, '');\r\nend;\r\n\r\nfunction TJclBDSInstallation.GetCppIncludePath(APlatform: TJclBDSPlatform): TJclBorRADToolPath;\r\nbegin\r\n CheckCBuilderPlatform(APlatform);\r\n if IDEVersionNumber >= 5 then\r\n // use EnvOptions.proj\r\n Result := GetMsBuildEnvOption(MsBuildCBuilderIncludePathNodeName, APlatform, False)\r\n else\r\n Result := ConfigData.ReadString(GetCppPathsKeyName, CppIncludePathValueName, '');\r\nend;\r\n\r\nfunction TJclBDSInstallation.GetDCC64: TJclDCC64;\r\nbegin\r\n if not Assigned(FDCC64) then\r\n begin\r\n if not (clDcc64 in CommandLineTools) then\r\n raise EJclBorRadException.CreateResFmt(@RsENotFound, [Dcc64ExeName]);\r\n FDCC64 := TJclDCC64.Create(BinFolderName, LongPathBug, CompilerSettingsFormat,\r\n SupportsNoConfig, SupportsPlatform, DCPOutputPath[bpWin64], LibFolderName[bpWin64],\r\n LibDebugFolderName[bpWin64], ObjFolderName[bpWin64]);\r\n end;\r\n Result := FDCC64;\r\nend;\r\n\r\nfunction TJclBDSInstallation.GetDCCOSX32: TJclDCCOSX32;\r\nbegin\r\n if not Assigned(FDCCOSX32) then\r\n begin\r\n if not (clDccOSX32 in CommandLineTools) then\r\n raise EJclBorRadException.CreateResFmt(@RsENotFound, [DccOSX32ExeName]);\r\n FDCCOSX32 := TJclDCCOSX32.Create(BinFolderName, LongPathBug, CompilerSettingsFormat,\r\n SupportsNoConfig, SupportsPlatform, DCPOutputPath[bpOSX32], LibFolderName[bpOSX32],\r\n LibDebugFolderName[bpOSX32], ObjFolderName[bpOSX32]);\r\n end;\r\n Result := FDCCOSX32;\r\nend;\r\n\r\nfunction TJclBDSInstallation.GetBCC64: TJclBCC64;\r\nbegin\r\n if not Assigned(FBCC64) then\r\n begin\r\n if not (clBcc64 in CommandLineTools) then\r\n raise EJclBorRadException.CreateResFmt(@RsENotFound, [Bcc64ExeName]);\r\n FBCC64 := TJclBCC64.Create(BinFolderName, LongPathBug, CompilerSettingsFormat);\r\n //SupportsNoConfig, SupportsPlatform, DCPOutputPath[bpWin64], LibFolderName[bpWin64],\r\n //LibDebugFolderName[bpWin64], ObjFolderName[bpWin64]);\r\n end;\r\n Result := FBCC64;\r\nend;\r\n\r\nfunction TJclBDSInstallation.GetDCCIL: TJclDCCIL;\r\nbegin\r\n if not Assigned(FDCCIL) then\r\n begin\r\n if not (clDccIL in CommandLineTools) then\r\n raise EJclBorRadException.CreateResFmt(@RsENotFound, [DccILExeName]);\r\n FDCCIL := TJclDCCIL.Create(BinFolderName, LongPathBug, CompilerSettingsFormat,\r\n SupportsNoConfig, SupportsPlatform, DCPOutputPath[bpWin32], LibFolderName[bpWin32], LibDebugFolderName[bpWin32], ObjFolderName[bpWin32]);\r\n end;\r\n Result := FDCCIL;\r\nend;\r\n\r\nfunction TJclBDSInstallation.GetDCPOutputPath(APlatform: TJclBDSPlatform): string;\r\nbegin\r\n CheckPlatform(APlatform);\r\n\r\n case IDEVersionNumber of\r\n 1, 2:\r\n // hard-coded\r\n Result := PathAddSeparator(RootDir) + 'lib';\r\n 3, 4:\r\n // use registry\r\n Result := inherited GetDCPOutputPath(APlatform);\r\n 5, 6, 7:\r\n // use EnvOptions.proj\r\n Result := GetMsBuildEnvOption(MsBuildWin32DCPOutputNodeName, APlatform, False);\r\n else\r\n // use EnvOptions.proj\r\n Result := GetMsBuildEnvOption(MsBuildDelphiDCPOutputNodeName, APlatform, False);\r\n end;\r\nend;\r\n\r\nfunction TJclBDSInstallation.GetDebugDCUPath(APlatform: TJclBDSPlatform): TJclBorRADToolPath;\r\nbegin\r\n CheckPlatform(APlatform);\r\n\r\n if IDEVersionNumber >= 8 then\r\n // use EnvOptions.proj\r\n Result := GetMsBuildEnvOption(MsBuildDelphiDebugDCUPathNodeName, APlatform, False)\r\n else\r\n if IDEVersionNumber >= 5 then\r\n // use EnvOptions.proj\r\n Result := GetMsBuildEnvOption(MsBuildWin32DebugDCUPathNodeName, APlatform, False)\r\n else\r\n // use registry\r\n Result := ConfigData.ReadString(LibraryKeyName, BDSDebugDCUPathValueName, '');\r\nend;\r\n\r\nfunction TJclBDSInstallation.GetDefaultProjectsDir: string;\r\nbegin\r\n Result := GetDefaultProjectsDirectory(RootDir, IDEVersionNumber);\r\nend;\r\n\r\nclass function TJclBDSInstallation.GetDefaultProjectsDirectory(const RootDir: string;\r\n IDEVersionNumber: Integer): string;\r\nvar\r\n LocStr: WideStringArray;\r\nbegin\r\n LocStr := LoadResStrings(RootDir + '\\Bin\\coreide' + BDSVersions[IDEVersionNumber].CoreIdeVersion + '.',\r\n ['Borland Studio Projects', 'RAD Studio', 'Projects']);\r\n\r\n if IDEVersionNumber < 5 then\r\n Result := LocStr[0]\r\n else\r\n Result := LocStr[1] + NativeBackslash + LocStr[2];\r\n\r\n Result := PathAddSeparator(GetPersonalFolder) + Result;\r\nend;\r\n\r\nfunction TJclBDSInstallation.GetEnvironmentVariables: TStrings;\r\nvar\r\n UserVariables: TStrings;\r\n Index: Integer;\r\n EnvOptionName, EnvOptionValue: string;\r\nbegin\r\n if not Assigned(FEnvironmentVariables) then\r\n begin\r\n Result := inherited GetEnvironmentVariables;\r\n if Assigned(Result) and (IDEVersionNumber >= 5) then\r\n begin\r\n UserVariables := TStringList.Create;\r\n try\r\n UserVariables.Assign(Result);\r\n Result.Clear;\r\n GetRADStudioVars(RootDir, IDEVersionNumber, Result);\r\n for Index := 0 to UserVariables.Count - 1 do\r\n begin\r\n EnvOptionName := UserVariables.Names[Index];\r\n EnvOptionValue := UserVariables.Values[EnvOptionName];\r\n ExpandEnvironmentVarCustom(EnvOptionValue, Result);\r\n Result.Values[EnvOptionName] := EnvOptionValue;\r\n end;\r\n finally\r\n UserVariables.Free;\r\n end;\r\n end\r\n else\r\n if Assigned(Result) then\r\n begin\r\n // adding default values\r\n if Result.Values[EnvVariableBDSValueName] = '' then\r\n Result.Values[EnvVariableBDSValueName] := PathRemoveSeparator(RootDir);\r\n if Result.Values[EnvVariableBDSPROJDIRValueName] = '' then\r\n Result.Values[EnvVariableBDSPROJDIRValueName] := DefaultProjectsDir;\r\n if Result.Values[EnvVariableBDSCOMDIRValueName] = '' then\r\n Result.Values[EnvVariableBDSCOMDIRValueName] := CommonProjectsDir;\r\n end;\r\n end\r\n else\r\n Result := FEnvironmentVariables;\r\nend;\r\n\r\nclass function TJclBDSInstallation.GetLatestUpdatePackForVersion(Version: Integer): Integer;\r\nbegin\r\n case Version of\r\n 9:\r\n Result := 1; // personal version is only update pack 1\r\n 10:\r\n Result := 1; // update 1 is out\r\n else\r\n Result := 0;\r\n end;\r\nend;\r\n\r\nfunction TJclBDSInstallation.GetLibDebugFolderName(APlatform: TJclBDSPlatform): string;\r\nbegin\r\n CheckPlatform(APlatform);\r\n\r\n if (RadToolKind = brBorlandDevStudio) and (VersionNumber >= 8) then\r\n Result := PathAddSeparator(RootDir) + PathAddSeparator('lib\\' + GetBDSPlatformStr(APlatform) + '\\debug')\r\n else\r\n Result := inherited GetLibDebugFolderName(APlatform);\r\nend;\r\n\r\nfunction TJclBDSInstallation.GetLibFolderName(APlatform: TJclBDSPlatform): string;\r\nbegin\r\n CheckPlatform(APlatform);\r\n\r\n if (RadToolKind = brBorlandDevStudio) and (VersionNumber >= 8) then\r\n Result := PathAddSeparator(RootDir) + PathAddSeparator('lib\\' + GetBDSPlatformStr(APlatform) + '\\release')\r\n else\r\n Result := inherited GetLibFolderName(APlatform);\r\nend;\r\n\r\nclass procedure TJclBDSInstallation.GetRADStudioVars(const RootDir: string; IDEVersionNumber: Integer; Variables: TStrings);\r\nvar\r\n RsVarsOutput, ComSpec, RsVarsError: string;\r\nbegin\r\n if IDEVersionNumber >= 5 then\r\n begin\r\n RsVarsOutput := '';\r\n RsVarsError := '';\r\n if GetEnvironmentVar('COMSPEC', ComSpec) and (JclSysUtils.Execute(Format('%s /C \" \"%s\" && set\"',\r\n [ComSpec, GetRADStudioVarsFileName(RootDir, IDEVersionNumber)]), RsVarsOutput, RsVarsError) = 0) then\r\n Variables.Text := RsVarsOutput\r\n else\r\n raise EJclBorRADException.CreateResFmt(@RsERsVars, [RadToolName(IDEVersionNumber), IDEVersionNumber, RsVarsError]);\r\n end;\r\nend;\r\n\r\nclass function TJclBDSInstallation.GetRADStudioVarsFileName(const RootDir: string; IDEVersionNumber: Integer): TFileName;\r\nbegin\r\n if IDEVersionNumber >= 5 then\r\n Result := Format('%s%sbin%srsvars.bat', [ExtractShortPathName(RootDir), DirDelimiter, DirDelimiter])\r\n else\r\n raise EJclBorRADException.CreateResFmt(@RsERsVars, [RadToolName(IDEVersionNumber), IDEVersionNumber, LoadResString(@RsMsBuildNotSupported)]);\r\nend;\r\n\r\nfunction TJclBDSInstallation.GetValid: Boolean;\r\nbegin\r\n Result := inherited GetValid;\r\n if Result and (IDEVersionNumber >= 5) then\r\n Result := FileExists(GetMsBuildEnvOptionsFileName) and FileExists(GetRADStudioVarsFileName(RootDir, IDEVersionNumber));\r\nend;\r\n\r\nfunction TJclBDSInstallation.GetLibraryBrowsingPath(APlatform: TJclBDSPlatform): TJclBorRADToolPath;\r\nbegin\r\n CheckPlatform(APlatform);\r\n\r\n if IDEVersionNumber >= 8 then\r\n // use EnvOptions.proj\r\n Result := GetMsBuildEnvOption(MsBuildDelphiBrowsingPathNodeName, APlatform, False)\r\n else\r\n if IDEVersionNumber >= 5 then\r\n // use EnvOptions.proj\r\n Result := GetMsBuildEnvOption(MsBuildWin32BrowsingPathNodeName, APlatform, False)\r\n else\r\n // use registry\r\n Result := inherited GetLibraryBrowsingPath(APlatform);\r\nend;\r\n\r\nfunction TJclBDSInstallation.GetLibrarySearchPath(APlatform: TJclBDSPlatform): TJclBorRADToolPath;\r\nbegin\r\n CheckPlatform(APlatform);\r\n\r\n if IDEVersionNumber >= 8 then\r\n // use EnvOptions.proj\r\n Result := GetMsBuildEnvOption(MsBuildDelphiLibraryPathNodeName, APlatform, False)\r\n else\r\n if IDEVersionNumber >= 5 then\r\n // use EnvOptions.proj\r\n Result := GetMsBuildEnvOption(MsBuildWin32LibraryPathNodeName, APlatform, False)\r\n else\r\n // use registry\r\n Result := inherited GetLibrarySearchPath(APlatform);\r\nend;\r\n\r\nfunction TJclBDSInstallation.GetMaxDelphiCLRVersion: string;\r\nbegin\r\n Result := DCCIL.MaxCLRVersion;\r\nend;\r\n\r\nfunction TJclBDSInstallation.GetName: string;\r\nbegin\r\n // The name comes from the IDEVersionNumber\r\n if IDEVersionNumber in [Low(BDSVersions)..High(BDSVersions)] then\r\n Result := Format('%s %s', [RadToolName, BDSVersions[IDEVersionNumber].VersionStr])\r\n else\r\n Result := Format('%s ***%s***', [RadToolName, IDEVersionNumber]);\r\nend;\r\n\r\nfunction TJclBDSInstallation.GetMsBuildEnvironmentFileName: string;\r\nbegin\r\n Result := PathAddSeparator(ExtractFilePath(GetMsBuildEnvOptionsFileName)) + 'environment.proj';\r\nend;\r\n\r\nfunction TJclBDSInstallation.GetMsBuildEnvOption(const OptionName: string; APlatform: TJclBDSPlatform; Raw: Boolean): string;\r\nvar\r\n EnvOptions: TJclMsBuildParser;\r\n MsBuildEnvironmentFileName: string;\r\nbegin\r\n Result := '';\r\n\r\n if IDEVersionNumber < 5 then\r\n raise EJclBorRADException.CreateResFmt(@RsERsVars, [RadToolName(IDEVersionNumber), IDEVersionNumber, LoadResString(@RsMsBuildNotSupported)]);\r\n\r\n MsBuildEnvironmentFileName := GetMsBuildEnvironmentFileName;\r\n\r\n if FileExists(MsBuildEnvironmentFileName) then\r\n EnvOptions := TJclMsBuildParser.Create(GetMsBuildEnvOptionsFileName, [MsBuildEnvironmentFileName])\r\n else\r\n EnvOptions := TJclMsBuildParser.Create(GetMsBuildEnvOptionsFileName);\r\n try\r\n EnvOptions.Init;\r\n\r\n // add custom \"environment\" variables\r\n EnvOptions.Properties.EnvironmentProperties.Assign(EnvironmentVariables);\r\n\r\n if SupportsPlatform then\r\n EnvOptions.Properties.GlobalProperties.Values['Platform'] := GetBDSPlatformStr(APlatform);\r\n EnvOptions.Parse;\r\n\r\n if Raw then\r\n Result := EnvOptions.Properties.RawValues[OptionName]\r\n else\r\n Result := EnvOptions.Properties.Values[OptionName];\r\n finally\r\n EnvOptions.Free;\r\n end;\r\nend;\r\n\r\nfunction TJclBDSInstallation.GetMsBuildEnvOptionsFileName: string;\r\nvar\r\n AppdataFolder: string;\r\nbegin\r\n if IDEVersionNumber >= 5 then\r\n begin\r\n if (RootKey = 0) or (RootKey = HKCU) then\r\n AppdataFolder := GetAppdataFolder\r\n else\r\n AppdataFolder := RegReadString(RootKey, 'Software\\Microsoft\\Windows\\CurrentVersion\\Explorer\\Shell Folders', 'AppData');\r\n\r\n if IDEVersionNumber >= 8 then\r\n Result := Format('%sEmbarcadero\\BDS\\%d.0\\EnvOptions.proj',\r\n [PathAddSeparator(AppdataFolder), IDEVersionNumber])\r\n else\r\n if IDEVersionNumber >= 6 then\r\n Result := Format('%sCodeGear\\BDS\\%d.0\\EnvOptions.proj',\r\n [PathAddSeparator(AppdataFolder), IDEVersionNumber])\r\n else\r\n Result := Format('%sBorland\\BDS\\%d.0\\EnvOptions.proj',\r\n [PathAddSeparator(AppdataFolder), IDEVersionNumber]);\r\n end\r\n else\r\n raise EJclBorRADException.CreateRes(@RsMsBuildNotSupported);\r\nend;\r\n\r\nfunction TJclBDSInstallation.GetRawCppBrowsingPath(APlatform: TJclBDSPlatform): TJclBorRADToolPath;\r\nbegin\r\n CheckCBuilderPlatform(APlatform);\r\n\r\n if IDEVersionNumber >= 5 then\r\n // use EnvOptions.proj\r\n Result := GetMsBuildEnvOption(MsBuildCBuilderBrowsingPathNodeName, APlatform, True)\r\n else\r\n Result := ConfigData.ReadString(GetCppPathsKeyName, CppBrowsingPathValueName, '');\r\nend;\r\n\r\nfunction TJclBDSInstallation.GetRawCppSearchPath(APlatform: TJclBDSPlatform): TJclBorRADToolPath;\r\nbegin\r\n CheckCBuilderPlatform(APlatform);\r\n\r\n Result := GetCppSearchPath(APlatform);\r\nend;\r\n\r\nfunction TJclBDSInstallation.GetRawCppLibraryPath(APlatform: TJclBDSPlatform): TJclBorRADToolPath;\r\nbegin\r\n CheckCBuilderPlatform(APlatform);\r\n\r\n if IDEVersionNumber >= 5 then\r\n // use EnvOptions.proj\r\n Result := GetMsBuildEnvOption(MsBuildCBuilderLibraryPathNodeName, APlatform, True)\r\n else\r\n Result := ConfigData.ReadString(GetCppPathsKeyName, CppLibraryPathValueName, '');\r\nend;\r\n\r\nfunction TJclBDSInstallation.GetRawCppIncludePath(APlatform: TJclBDSPlatform): TJclBorRADToolPath;\r\nbegin\r\n CheckCBuilderPlatform(APlatform);\r\n\r\n if IDEVersionNumber >= 5 then\r\n // use EnvOptions.proj\r\n Result := GetMsBuildEnvOption(MsBuildCBuilderIncludePathNodeName, APlatform, True)\r\n else\r\n Result := ConfigData.ReadString(GetCppPathsKeyName, CppIncludePathValueName, '');\r\nend;\r\n\r\nfunction TJclBDSInstallation.GetRawDebugDCUPath(APlatform: TJclBDSPlatform): TJclBorRADToolPath;\r\nbegin\r\n CheckPlatform(APlatform);\r\n\r\n if IDEVersionNumber >= 8 then\r\n // use EnvOptions.proj\r\n Result := GetMsBuildEnvOption(MsBuildDelphiDebugDCUPathNodeName, APlatform, True)\r\n else\r\n if IDEVersionNumber >= 5 then\r\n // use EnvOptions.proj\r\n Result := GetMsBuildEnvOption(MsBuildWin32DebugDCUPathNodeName, APlatform, True)\r\n else\r\n // use registry\r\n Result := ConfigData.ReadString(LibraryKeyName, BDSDebugDCUPathValueName, '');\r\nend;\r\n\r\nfunction TJclBDSInstallation.GetRawLibraryBrowsingPath(APlatform: TJclBDSPlatform): TJclBorRADToolPath;\r\nbegin\r\n CheckPlatform(APlatform);\r\n\r\n if IDEVersionNumber >= 8 then\r\n // use EnvOptions.proj\r\n Result := GetMsBuildEnvOption(MsBuildDelphiBrowsingPathNodeName, APlatform, True)\r\n else\r\n if IDEVersionNumber >= 5 then\r\n // use EnvOptions.proj\r\n Result := GetMsBuildEnvOption(MsBuildWin32BrowsingPathNodeName, APlatform, True)\r\n else\r\n // use registry\r\n Result := inherited GetRawLibraryBrowsingPath(APlatform);\r\nend;\r\n\r\nfunction TJclBDSInstallation.GetRawLibrarySearchPath(APlatform: TJclBDSPlatform): TJclBorRADToolPath;\r\nbegin\r\n CheckPlatform(APlatform);\r\n\r\n if IDEVersionNumber >= 8 then\r\n // use EnvOptions.proj\r\n Result := GetMsBuildEnvOption(MsBuildDelphiLibraryPathNodeName, APlatform, True)\r\n else\r\n if IDEVersionNumber >= 5 then\r\n // use EnvOptions.proj\r\n Result := GetMsBuildEnvOption(MsBuildWin32LibraryPathNodeName, APlatform, True)\r\n else\r\n // use registry\r\n Result := inherited GetRawLibrarySearchPath(APlatform);\r\nend;\r\n\r\nfunction TJclBDSInstallation.GetVclIncludeDir(APlatform: TJclBDSPlatform): string;\r\nbegin\r\n CheckCBuilderPlatform(APlatform);\r\n\r\n if (RadToolKind = brBorlandDevStudio) and (IDEVersionNumber >= 8) then\r\n begin\r\n CheckPlatform(APlatform);\r\n Result := GetMsBuildEnvOption(MsBuildDelphiHPPOutputPathNodeName, APlatform, False);\r\n if Result = '' then\r\n Result := SubstitutePath('$(BDSCOMMONDIR)\\hpp');\r\n end\r\n else\r\n Result := inherited GetVclIncludeDir(APlatform);\r\nend;\r\n\r\nclass function TJclBDSInstallation.PackageSourceFileExtension: string;\r\nbegin\r\n Result := SourceExtensionDelphiPackage;\r\nend;\r\n\r\nclass function TJclBDSInstallation.ProjectSourceFileExtension: string;\r\nbegin\r\n Result := SourceExtensionDelphiProject;\r\nend;\r\n\r\nclass function TJclBDSInstallation.RadToolKind: TJclBorRadToolKind;\r\nbegin\r\n Result := brBorlandDevStudio;\r\nend;\r\n\r\nclass function TJclBDSInstallation.RadToolName(\r\n IDEVersionNumber: Integer): string;\r\nbegin\r\n if IDEVersionNumber in [Low(BDSVersions)..High(BDSVersions)] then\r\n Result := LoadResString(BDSVersions[IDEVersionNumber].Name)\r\n else\r\n Result := LoadResString(@RsBDSName);\r\nend;\r\n\r\nfunction TJclBDSInstallation.RadToolName: string;\r\nbegin\r\n // The name comes from IDEVersionNumber\r\n Result := RadToolName(IDEVersionNumber);\r\n if IDEVersionNumber in [Low(BDSVersions)..High(BDSVersions)] then\r\n begin\r\n // IDE Version 5 comes in three flavors:\r\n // - Delphi only (Spacely)\r\n // - C++Builder only (Cogswell)\r\n // - Delphi and C++Builder\r\n if (IDEVersionNumber = 5) and (Personalities = [bpDelphi32]) then\r\n Result := LoadResString(@RsDelphiName)\r\n else\r\n if (IDEVersionNumber = 5) and (Personalities = [bpBCBuilder32]) then\r\n Result := LoadResString(@RsBCBName);\r\n end;\r\nend;\r\n\r\nfunction TJclBDSInstallation.RegisterPackage(const BinaryFileName, Description: string): Boolean;\r\nbegin\r\n if VersionNumber >= 3 then\r\n CleanPackageCache(BinaryFileName);\r\n\r\n Result := inherited RegisterPackage(BinaryFileName, Description);\r\nend;\r\n\r\nfunction TJclBDSInstallation.RemoveFromCppBrowsingPath(const Path: string; APlatform: TJclBDSPlatform): Boolean;\r\nvar\r\n TempRawCppPath: TJclBorRADToolPath;\r\nbegin\r\n CheckCBuilderPlatform(APlatform);\r\n\r\n if Path <> '' then\r\n begin\r\n TempRawCppPath := RawCppBrowsingPath[APlatform];\r\n Result := RemoveFromPath(TempRawCppPath, Path);\r\n RawCppBrowsingPath[APlatform] := TempRawCppPath;\r\n end\r\n else\r\n Result := False;\r\nend;\r\n\r\nfunction TJclBDSInstallation.RemoveFromCppSearchPath(const Path: string; APlatform: TJclBDSPlatform): Boolean;\r\nvar\r\n TempRawCppPath: TJclBorRADToolPath;\r\nbegin\r\n CheckCBuilderPlatform(APlatform);\r\n\r\n if Path <> '' then\r\n begin\r\n TempRawCppPath := RawCppSearchPath[APlatform];\r\n Result := RemoveFromPath(TempRawCppPath, Path);\r\n RawCppSearchPath[APlatform] := TempRawCppPath;\r\n end\r\n else\r\n Result := False;\r\nend;\r\n\r\nfunction TJclBDSInstallation.RemoveFromCppLibraryPath(const Path: string; APlatform: TJclBDSPlatform): Boolean;\r\nvar\r\n TempRawLibraryPath: TJclBorRADToolPath;\r\nbegin\r\n CheckCBuilderPlatform(APlatform);\r\n\r\n if (IDEVersionNumber >= 5) and (Path <> '') then\r\n begin\r\n TempRawLibraryPath := RawCppLibraryPath[APlatform];\r\n Result := RemoveFromPath(TempRawLibraryPath, Path);\r\n RawCppLibraryPath[APlatform] := TempRawLibraryPath;\r\n end\r\n else\r\n Result := False;\r\nend;\r\n\r\nfunction TJclBDSInstallation.RemoveFromCppIncludePath(const Path: string; APlatform: TJclBDSPlatform): Boolean;\r\nvar\r\n TempRawIncludePath: TJclBorRADToolPath;\r\nbegin\r\n CheckCBuilderPlatform(APlatform);\r\n\r\n if (IDEVersionNumber >= 5) and (Path <> '') then\r\n begin\r\n TempRawIncludePath := RawCppIncludePath[APlatform];\r\n Result := RemoveFromPath(TempRawIncludePath, Path);\r\n RawCppIncludePath[APlatform] := TempRawIncludePath;\r\n end\r\n else\r\n Result := False;\r\nend;\r\n\r\nprocedure TJclBDSInstallation.SetDualPackageInstallation(const Value: Boolean);\r\nbegin\r\n if Value and not (bpBCBuilder32 in Personalities) then\r\n raise EJclBorRadException.CreateResFmt(@RsEDualPackageNotSupported, [Name]);\r\n FDualPackageInstallation := Value;\r\nend;\r\n\r\nprocedure TJclBDSInstallation.SetMsBuildEnvOption(const OptionName, Value: string; APlatform: TJclBDSPlatform);\r\nvar\r\n EnvOptionsFileName, BakEnvOptionsFileName: string;\r\n EnvOptions: TJclMsBuildParser;\r\nbegin\r\n if IDEVersionNumber < 5 then\r\n raise EJclBorRADException.CreateResFmt(@RsERsVars, [RadToolName(IDEVersionNumber), IDEVersionNumber, LoadResString(@RsMsBuildNotSupported)]);\r\n\r\n EnvOptionsFileName := GetMsBuildEnvOptionsFileName;\r\n EnvOptions := TJclMsBuildParser.Create(EnvOptionsFileName);\r\n try\r\n EnvOptions.Init;\r\n\r\n // add custom \"environment\" variables\r\n EnvOptions.Properties.EnvironmentProperties.Assign(EnvironmentVariables);\r\n\r\n if SupportsPlatform then\r\n EnvOptions.Properties.GlobalProperties.Values['Platform'] := GetBDSPlatformStr(APlatform);\r\n EnvOptions.Parse;\r\n \r\n EnvOptions.Properties.RawValues[OptionName] := Value;\r\n\r\n { Do not overwrite the original file if something goes wrong }\r\n BakEnvOptionsFileName := EnvOptionsFileName + '.bak';\r\n DeleteFile(BakEnvOptionsFileName);\r\n RenameFile(EnvOptionsFileName, BakEnvOptionsFileName);\r\n try\r\n EnvOptions.Xml.Options := EnvOptions.Xml.Options + [sxoDoNotSaveProlog];\r\n EnvOptions.Save;\r\n DeleteFile(BakEnvOptionsFileName);\r\n except\r\n DeleteFile(EnvOptionsFileName);\r\n RenameFile(BakEnvOptionsFileName, EnvOptionsFileName);\r\n raise;\r\n end;\r\n finally\r\n EnvOptions.Free;\r\n end;\r\nend;\r\n\r\nprocedure TJclBDSInstallation.SetOutputCallback(const Value: TTextHandler);\r\nbegin\r\n inherited SetOutputCallback(Value);\r\n if clDcc64 in CommandLineTools then\r\n DCC64.OutputCallback := Value;\r\n if clDccOSX32 in CommandLineTools then\r\n DCCOSX32.OutputCallback := Value;\r\n if clBcc64 in CommandLineTools then\r\n BCC64.OutputCallback := Value;\r\n if clDccIL in CommandLineTools then\r\n DCCIL.OutputCallback := Value;\r\nend;\r\n\r\nprocedure TJclBDSInstallation.SetRawCppBrowsingPath(APlatform: TJclBDSPlatform; const Value: TJclBorRADToolPath);\r\nbegin\r\n CheckCBuilderPlatform(APlatform);\r\n\r\n // update registry\r\n ConfigData.WriteString(GetCppPathsKeyName, CppBrowsingPathValueName, Value);\r\n // update EnvOptions.dproj\r\n if IDEVersionNumber >= 5 then\r\n SetMsBuildEnvOption(MsBuildCBuilderBrowsingPathNodeName, Value, APlatform);\r\nend;\r\n\r\nprocedure TJclBDSInstallation.SetRawCppSearchPath(APlatform: TJclBDSPlatform; const Value: TJclBorRADToolPath);\r\nbegin\r\n CheckCBuilderPlatform(APlatform);\r\n ConfigData.WriteString(GetCppPathsKeyName, CppSearchPathValueName, Value);\r\nend;\r\n\r\nprocedure TJclBDSInstallation.SetRawCppLibraryPath(APlatform: TJclBDSPlatform; const Value: TJclBorRADToolPath);\r\nbegin\r\n CheckCBuilderPlatform(APlatform);\r\n\r\n // update registry\r\n ConfigData.WriteString(GetCppPathsKeyName, CppLibraryPathValueName, Value);\r\n // update EnvOptions.dproj\r\n if IDEVersionNumber >= 5 then\r\n SetMsBuildEnvOption(MsBuildCBuilderLibraryPathNodeName, Value, APlatform);\r\nend;\r\n\r\nprocedure TJclBDSInstallation.SetRawCppIncludePath(APlatform: TJclBDSPlatform; const Value: TJclBorRADToolPath);\r\nbegin\r\n CheckCBuilderPlatform(APlatform);\r\n\r\n if IDEVersionNumber >= 5 then\r\n begin\r\n // update registry\r\n ConfigData.WriteString(GetCppPathsKeyName, CppIncludePathValueName, Value);\r\n // update EnvOptions.dproj\r\n SetMsBuildEnvOption(MsBuildCBuilderIncludePathNodeName, Value, APlatform);\r\n end;\r\nend;\r\n\r\nprocedure TJclBDSInstallation.SetRawDebugDCUPath(APlatform: TJclBDSPlatform; const Value: TJclBorRADToolPath);\r\nbegin\r\n CheckPlatform(APlatform);\r\n\r\n if IDEVersionNumber >= 9 then\r\n begin\r\n // update registry\r\n ConfigData.WriteString(LibraryKeyName + '\\' + GetBDSPlatformStr(APlatform), BDSDebugDCUPathValueName, Value);\r\n // update EnvOptions.dproj\r\n SetMsBuildEnvOption(MsBuildDelphiDebugDCUPathNodeName, Value, APlatform);\r\n end\r\n else\r\n begin\r\n // update registry\r\n ConfigData.WriteString(LibraryKeyName, BDSDebugDCUPathValueName, Value);\r\n // update EnvOptions.dproj\r\n if IDEVersionNumber >= 8 then\r\n SetMsBuildEnvOption(MsBuildDelphiDebugDCUPathNodeName, Value, APlatform)\r\n else\r\n if IDEVersionNumber >= 5 then\r\n SetMsBuildEnvOption(MsBuildWin32DebugDCUPathNodeName, Value, APlatform);\r\n end;\r\nend;\r\n\r\nprocedure TJclBDSInstallation.SetRawLibraryBrowsingPath(APlatform: TJclBDSPlatform; const Value: TJclBorRADToolPath);\r\nbegin\r\n CheckPlatform(APlatform);\r\n\r\n if IDEVersionNumber >= 9 then\r\n begin\r\n // update registry\r\n ConfigData.WriteString(LibraryKeyName + '\\' + GetBDSPlatformStr(APlatform), LibraryBrowsingPathValueName, Value);\r\n // update EnvOptions.dproj\r\n SetMsBuildEnvOption(MsBuildDelphiBrowsingPathNodeName, Value, APlatform);\r\n end\r\n else\r\n begin\r\n // update registry\r\n ConfigData.WriteString(LibraryKeyName, LibraryBrowsingPathValueName, Value);\r\n // update EnvOptions.dproj\r\n if IDEVersionNumber >= 8 then\r\n SetMsBuildEnvOption(MsBuildDelphiBrowsingPathNodeName, Value, APlatform)\r\n else\r\n if IDEVersionNumber >= 5 then\r\n SetMsBuildEnvOption(MsBuildWin32BrowsingPathNodeName, Value, APlatform);\r\n end;\r\nend;\r\n\r\nprocedure TJclBDSInstallation.SetRawLibrarySearchPath(APlatform: TJclBDSPlatform; const Value: TJclBorRADToolPath);\r\nbegin\r\n CheckPlatform(APlatform);\r\n\r\n if IDEVersionNumber >= 9 then\r\n begin\r\n // update registry\r\n ConfigData.WriteString(LibraryKeyName + '\\' + GetBDSPlatformStr(APlatform), LibrarySearchPathValueName, Value);\r\n // update EnvOptions.dproj\r\n SetMsBuildEnvOption(MsBuildDelphiLibraryPathNodeName, Value, APlatform);\r\n end\r\n else\r\n begin\r\n // update registry\r\n ConfigData.WriteString(LibraryKeyName, LibrarySearchPathValueName, Value);\r\n // update EnvOptions.dproj\r\n if IDEVersionNumber >= 8 then\r\n SetMsBuildEnvOption(MsBuildDelphiLibraryPathNodeName, Value, APlatform)\r\n else\r\n if IDEVersionNumber >= 5 then\r\n SetMsBuildEnvOption(MsBuildWin32LibraryPathNodeName, Value, APlatform);\r\n end;\r\nend;\r\n\r\nfunction TJclBDSInstallation.UnregisterPackage(const BinaryFileName: string): Boolean;\r\nbegin\r\n if IDEVersionNumber >= 3 then\r\n CleanPackageCache(BinaryFileName);\r\n Result := inherited UnregisterPackage(BinaryFileName);\r\nend;\r\n\r\n{$ENDIF MSWINDOWS}\r\n\r\n//=== { TJclBorRADToolInstallations } ========================================\r\n\r\nconstructor TJclBorRADToolInstallations.Create;\r\nbegin\r\n FList := TObjectList.Create;\r\n ReadInstallations;\r\nend;\r\n\r\ndestructor TJclBorRADToolInstallations.Destroy;\r\nbegin\r\n FreeAndNil(FList);\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJclBorRADToolInstallations.AnyInstanceRunning: Boolean;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := False;\r\n for I := 0 to Count - 1 do\r\n if Installations[I].AnyInstanceRunning then\r\n begin\r\n Result := True;\r\n Break;\r\n end;\r\nend;\r\n\r\nfunction TJclBorRADToolInstallations.AnyUpdatePackNeeded(var Text: string): Boolean;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := False;\r\n for I := 0 to Count - 1 do\r\n if Installations[I].UpdateNeeded then\r\n begin\r\n Result := True;\r\n Text := Format(LoadResString(@RsNeedUpdate), [Installations[I].LatestUpdatePack, Installations[I].Name]);\r\n Break;\r\n end;\r\nend;\r\n\r\nfunction TJclBorRADToolInstallations.GetCount: Integer;\r\nbegin\r\n Result := FList.Count;\r\nend;\r\n\r\nfunction TJclBorRADToolInstallations.GetBCBInstallationFromVersion(VersionNumber: Integer): TJclBorRADToolInstallation;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := nil;\r\n for I := 0 to Count - 1 do\r\n case Installations[I].RadToolKind of\r\n brCppBuilder:\r\n if Installations[I].IDEVersionNumber = VersionNumber then\r\n begin\r\n Result := Installations[I];\r\n Break;\r\n end;\r\n brBorlandDevStudio:\r\n if ((VersionNumber >= 14) and (Installations[I].IDEVersionNumber = (VersionNumber - 7))) or\r\n ((VersionNumber >= 10) and (Installations[I].IDEVersionNumber = (VersionNumber - 6))) then\r\n begin\r\n Result := Installations[I];\r\n Break;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJclBorRADToolInstallations.GetDelphiInstallationFromVersion(\r\n VersionNumber: Integer): TJclBorRADToolInstallation;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := nil;\r\n for I := 0 to Count - 1 do\r\n case Installations[I].RadToolKind of\r\n brDelphi:\r\n if Installations[I].IDEVersionNumber = VersionNumber then\r\n begin\r\n Result := Installations[I];\r\n Break;\r\n end;\r\n brBorlandDevStudio:\r\n if ((VersionNumber >= 14) and (Installations[I].IDEVersionNumber = (VersionNumber - 7))) or\r\n ((VersionNumber >= 8) and (Installations[I].IDEVersionNumber = (VersionNumber - 6))) then\r\n begin\r\n Result := Installations[I];\r\n Break;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJclBorRADToolInstallations.GetInstallations(Index: Integer): TJclBorRADToolInstallation;\r\nbegin\r\n Result := TJclBorRADToolInstallation(FList[Index]);\r\nend;\r\n\r\nfunction TJclBorRADToolInstallations.GetBCBVersionInstalled(VersionNumber: Integer): Boolean;\r\nbegin\r\n Result := BCBInstallationFromVersion[VersionNumber] <> nil;\r\nend;\r\n\r\nfunction TJclBorRADToolInstallations.GetBDSInstallationFromVersion(VersionNumber: Integer): TJclBorRADToolInstallation;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := nil;\r\n for I := 0 to Count - 1 do\r\n if (Installations[I].IDEVersionNumber = VersionNumber) and\r\n (Installations[I].RadToolKind = brBorlandDevStudio) then\r\n begin\r\n Result := Installations[I];\r\n Break;\r\n end;\r\nend;\r\n\r\nfunction TJclBorRADToolInstallations.GetBDSVersionInstalled(VersionNumber: Integer): Boolean;\r\nbegin\r\n Result := BDSInstallationFromVersion[VersionNumber] <> nil;\r\nend;\r\n\r\nfunction TJclBorRADToolInstallations.GetDelphiVersionInstalled(VersionNumber: Integer): Boolean;\r\nbegin\r\n Result := DelphiInstallationFromVersion[VersionNumber] <> nil;\r\nend;\r\n\r\nfunction TJclBorRADToolInstallations.Iterate(TraverseMethod: TTraverseMethod): Boolean;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := True;\r\n for I := 0 to Count - 1 do\r\n Result := Result and TraverseMethod(Installations[I]);\r\nend;\r\n\r\nprocedure TJclBorRADToolInstallations.ReadInstallations;\r\nvar\r\n VersionNumbers: TStringList;\r\n\r\n function EnumVersions(const KeyName: string; const Personalities: array of string;\r\n CreateClass: TJclBorRADToolInstallationClass): Boolean;\r\n var\r\n I, J: Integer;\r\n VersionKeyName, PersonalitiesKeyName: string;\r\n PersonalitiesList: TStrings;\r\n Installation: TJclBorRADToolInstallation;\r\n begin\r\n Result := False;\r\n if RegKeyExists(HKEY_LOCAL_MACHINE, KeyName) and\r\n RegGetKeyNames(HKEY_LOCAL_MACHINE, KeyName, VersionNumbers) then\r\n for I := 0 to VersionNumbers.Count - 1 do\r\n if StrIsSubSet(VersionNumbers[I], CharIsFracDigit) then\r\n begin\r\n VersionKeyName := KeyName + DirDelimiter + VersionNumbers[I];\r\n if RegKeyExists(HKEY_LOCAL_MACHINE, VersionKeyName) then\r\n begin\r\n if Length(Personalities) = 0 then\r\n begin\r\n try\r\n Installation := CreateClass.Create(VersionKeyName);\r\n if Installation.Valid then\r\n FList.Add(Installation);\r\n finally\r\n Result := True;\r\n end;\r\n end\r\n else\r\n begin\r\n PersonalitiesList := TStringList.Create;\r\n try\r\n PersonalitiesKeyName := VersionKeyName + '\\Personalities';\r\n if RegKeyExists(HKEY_LOCAL_MACHINE, PersonalitiesKeyName) then\r\n RegGetValueNames(HKEY_LOCAL_MACHINE, PersonalitiesKeyName, PersonalitiesList);\r\n\r\n for J := Low(Personalities) to High(Personalities) do\r\n if PersonalitiesList.IndexOf(Personalities[J]) >= 0 then\r\n begin\r\n try\r\n Installation := CreateClass.Create(VersionKeyName);\r\n if Installation.Valid then\r\n FList.Add(Installation)\r\n else\r\n Installation.Free;\r\n finally\r\n Result := True;\r\n end;\r\n Break;\r\n end;\r\n finally\r\n PersonalitiesList.Free;\r\n end;\r\n end;\r\n end;\r\n end;\r\n end;\r\n\r\nbegin\r\n FList.Clear;\r\n VersionNumbers := TStringList.Create;\r\n try\r\n EnumVersions(DelphiKeyName, [], TJclDelphiInstallation);\r\n EnumVersions(BCBKeyName, [], TJclBCBInstallation);\r\n EnumVersions(BDSKeyName, ['Delphi.Win32', 'BCB', 'Delphi8', 'C#Builder'], TJclBDSInstallation);\r\n EnumVersions(CDSKeyName, ['Delphi.Win32', 'BCB', 'Delphi8', 'C#Builder'], TJclBDSInstallation);\r\n EnumVersions(EDSKeyName, ['Delphi.Win32', 'BCB', 'Delphi8', 'C#Builder'], TJclBDSInstallation);\r\n finally\r\n VersionNumbers.Free;\r\n end;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n\r\n" }, { "path": "External/Jedi/Jcl/source/common/JclIniFiles.pas", "content": "{**************************************************************************************************}\r\n{ }\r\n{ Project JEDI Code Library (JCL) }\r\n{ }\r\n{ The contents of this file are subject to the Mozilla Public License Version 1.1 (the \"License\"); }\r\n{ you may not use this file except in compliance with the License. You may obtain a copy of the }\r\n{ License at http://www.mozilla.org/MPL/ }\r\n{ }\r\n{ Software distributed under the License is distributed on an \"AS IS\" basis, WITHOUT WARRANTY OF }\r\n{ ANY KIND, either express or implied. See the License for the specific language governing rights }\r\n{ and limitations under the License. }\r\n{ }\r\n{ The Original Code is JclIniFiles.pas. }\r\n{ }\r\n{ The Initial Developer of the Original Code is John C Molyneux. }\r\n{ Portions created by John C Molyneux are Copyright (C) John C Molyneux. }\r\n{ }\r\n{ Contributors: }\r\n{ Eric S. Fisher }\r\n{ John C Molyneux }\r\n{ Petr Vones (pvones) }\r\n{ Robert Marquardt (marquardt) }\r\n{ Robert Rossmair (rrossmair) }\r\n{ }\r\n{**************************************************************************************************}\r\n{ }\r\n{ Last modified: $Date:: 2011-09-03 00:07:50 +0200 (sam. 03 sept. 2011) $ }\r\n{ Revision: $Rev:: 3599 $ }\r\n{ Author: $Author:: outchy $ }\r\n{ }\r\n{**************************************************************************************************}\r\n\r\nunit JclIniFiles;\r\n\r\n{$I jcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n {$IFDEF HAS_UNITSCOPE}\r\n System.SysUtils, System.Classes, System.IniFiles;\r\n {$ELSE ~HAS_UNITSCOPE}\r\n SysUtils, Classes, IniFiles;\r\n {$ENDIF ~HAS_UNITSCOPE}\r\n\r\n// Initialization (ini) Files\r\nfunction IniReadBool(const FileName, Section, Line: string): Boolean; // John C Molyneux\r\nfunction IniReadInteger(const FileName, Section, Line: string): Integer; // John C Molyneux\r\nfunction IniReadString(const FileName, Section, Line: string): string; // John C Molyneux\r\nprocedure IniWriteBool(const FileName, Section, Line: string; Value: Boolean); // John C Molyneux\r\nprocedure IniWriteInteger(const FileName, Section, Line: string; Value: Integer); // John C Molyneux\r\nprocedure IniWriteString(const FileName, Section, Line, Value: string); // John C Molyneux\r\n\r\n// Initialization (ini) Files helper routines\r\nprocedure IniReadStrings(IniFile: TCustomIniFile; const Section: string; Strings: TStrings);\r\nprocedure IniWriteStrings(IniFile: TCustomIniFile; const Section: string; Strings: TStrings);\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jcl.svn.sourceforge.net/svnroot/jcl/tags/JCL-2.4-Build4571/jcl/source/common/JclIniFiles.pas $';\r\n Revision: '$Revision: 3599 $';\r\n Date: '$Date: 2011-09-03 00:07:50 +0200 (sam. 03 sept. 2011) $';\r\n LogPath: 'JCL\\source\\common';\r\n Extra: '';\r\n Data: nil\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\n// Initialization Files\r\nfunction IniReadBool(const FileName, Section, Line: string): Boolean;\r\nvar\r\n Ini: TIniFile;\r\nbegin\r\n Ini := TIniFile.Create(FileName);\r\n try\r\n Result := Ini.ReadBool(Section, Line, False);\r\n finally\r\n Ini.Free;\r\n end;\r\nend;\r\n\r\nfunction IniReadInteger(const FileName, Section, Line: string): Integer;\r\nvar\r\n Ini: TIniFile;\r\nbegin\r\n Ini := TIniFile.Create(FileName);\r\n try\r\n Result := Ini.ReadInteger(Section, Line, 0);\r\n finally\r\n Ini.Free;\r\n end;\r\nend;\r\n\r\nfunction IniReadString(const FileName, Section, Line: string): string;\r\nvar\r\n Ini: TIniFile;\r\nbegin\r\n Ini := TIniFile.Create(FileName);\r\n try\r\n Result := Ini.ReadString(Section, Line, '');\r\n finally\r\n Ini.Free;\r\n end;\r\nend;\r\n\r\nprocedure IniWriteBool(const FileName, Section, Line: string; Value: Boolean);\r\nvar\r\n Ini: TIniFile;\r\nbegin\r\n Ini := TIniFile.Create(FileName);\r\n try\r\n Ini.WriteBool(Section, Line, Value);\r\n finally\r\n Ini.Free;\r\n end;\r\nend;\r\n\r\nprocedure IniWriteInteger(const FileName, Section, Line: string; Value: Integer);\r\nvar\r\n Ini: TIniFile;\r\nbegin\r\n Ini := TIniFile.Create(FileName);\r\n try\r\n Ini.WriteInteger(Section, Line, Value);\r\n finally\r\n Ini.Free;\r\n end;\r\nend;\r\n\r\nprocedure IniWriteString(const FileName, Section, Line, Value: string);\r\nvar\r\n Ini: TIniFile;\r\nbegin\r\n Ini := TIniFile.Create(FileName);\r\n try\r\n Ini.WriteString(Section, Line, Value);\r\n finally\r\n Ini.Free;\r\n end;\r\nend;\r\n\r\n// Initialization (ini) Files helper routines\r\nconst\r\n ItemCountName = 'Count';\r\n\r\nprocedure IniReadStrings(IniFile: TCustomIniFile; const Section: string; Strings: TStrings);\r\nvar\r\n Count, I: Integer;\r\nbegin\r\n with IniFile do\r\n begin\r\n Strings.BeginUpdate;\r\n try\r\n Strings.Clear;\r\n Count := ReadInteger(Section, ItemCountName, 0);\r\n for I := 0 to Count - 1 do\r\n Strings.Add(ReadString(Section, IntToStr(I), ''));\r\n finally\r\n Strings.EndUpdate;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure IniWriteStrings(IniFile: TCustomIniFile; const Section: string; Strings: TStrings);\r\nvar\r\n I: Integer;\r\nbegin\r\n with IniFile do\r\n begin\r\n EraseSection(Section);\r\n WriteInteger(Section, ItemCountName, Strings.Count);\r\n for I := 0 to Strings.Count - 1 do\r\n WriteString(Section, IntToStr(I), Strings[I]);\r\n end;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jcl/source/common/JclLinkedLists.pas", "content": "{**************************************************************************************************}\r\n{ WARNING: JEDI preprocessor generated unit. Do not edit. }\r\n{**************************************************************************************************}\r\n\r\n{**************************************************************************************************}\r\n{ }\r\n{ Project JEDI Code Library (JCL) }\r\n{ }\r\n{ The contents of this file are subject to the Mozilla Public License Version 1.1 (the \"License\"); }\r\n{ you may not use this file except in compliance with the License. You may obtain a copy of the }\r\n{ License at http://www.mozilla.org/MPL/ }\r\n{ }\r\n{ Software distributed under the License is distributed on an \"AS IS\" basis, WITHOUT WARRANTY OF }\r\n{ ANY KIND, either express or implied. See the License for the specific language governing rights }\r\n{ and limitations under the License. }\r\n{ }\r\n{ The Original Code is LinkedList.pas. }\r\n{ }\r\n{ The Initial Developer of the Original Code is Jean-Philippe BEMPEL aka RDM. Portions created by }\r\n{ Jean-Philippe BEMPEL are Copyright (C) Jean-Philippe BEMPEL (rdm_30 att yahoo dott com) }\r\n{ All rights reserved. }\r\n{ }\r\n{ Contributors: }\r\n{ Florent Ouchet (outchy) }\r\n{ }\r\n{**************************************************************************************************}\r\n{ }\r\n{ The Delphi Container Library }\r\n{ }\r\n{**************************************************************************************************}\r\n{ }\r\n{ Last modified: $Date:: 2012-02-21 18:37:18 +0100 (mar. 21 févr. 2012) $ }\r\n{ Revision: $Rev:: 3739 $ }\r\n{ Author: $Author:: outchy $ }\r\n{ }\r\n{**************************************************************************************************}\r\n\r\nunit JclLinkedLists;\r\n\r\n{$I jcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n {$IFDEF SUPPORTS_GENERICS}\r\n JclAlgorithms,\r\n {$ENDIF SUPPORTS_GENERICS}\r\n {$IFDEF HAS_UNITSCOPE}\r\n System.Classes,\r\n {$ELSE ~HAS_UNITSCOPE}\r\n Classes,\r\n {$ENDIF ~HAS_UNITSCOPE}\r\n JclBase, JclAbstractContainers, JclContainerIntf, JclSynch;\r\n\r\n\r\ntype\r\n TItrStart = (isFirst, isLast);\r\n\r\n TJclIntfLinkedListItem = class\r\n public\r\n Value: IInterface;\r\n Next: TJclIntfLinkedListItem;\r\n Previous: TJclIntfLinkedListItem;\r\n end;\r\n\r\n TJclIntfLinkedList = class(TJclIntfAbstractContainer, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclIntfCloneable, IJclCloneable, IJclBaseContainer, IJclIntfContainer,\r\n IJclIntfFlatContainer, IJclIntfEqualityComparer,\r\n IJclIntfCollection, IJclIntfList)\r\n protected\r\n function CreateEmptyContainer: TJclAbstractContainerBase; override;\r\n private\r\n FStart: TJclIntfLinkedListItem;\r\n FEnd: TJclIntfLinkedListItem;\r\n protected\r\n procedure AssignDataTo(Dest: TJclAbstractContainerBase); override;\r\n public\r\n constructor Create(const ACollection: IJclIntfCollection);\r\n destructor Destroy; override;\r\n { IJclIntfCollection }\r\n function Add(const AInterface: IInterface): Boolean;\r\n function AddAll(const ACollection: IJclIntfCollection): Boolean;\r\n procedure Clear;\r\n function CollectionEquals(const ACollection: IJclIntfCollection): Boolean;\r\n function Contains(const AInterface: IInterface): Boolean;\r\n function ContainsAll(const ACollection: IJclIntfCollection): Boolean;\r\n function Extract(const AInterface: IInterface): Boolean;\r\n function ExtractAll(const ACollection: IJclIntfCollection): Boolean;\r\n function First: IJclIntfIterator;\r\n function IsEmpty: Boolean;\r\n function Last: IJclIntfIterator;\r\n function Remove(const AInterface: IInterface): Boolean;\r\n function RemoveAll(const ACollection: IJclIntfCollection): Boolean;\r\n function RetainAll(const ACollection: IJclIntfCollection): Boolean;\r\n function Size: Integer;\r\n {$IFDEF SUPPORTS_FOR_IN}\r\n function GetEnumerator: IJclIntfIterator;\r\n {$ENDIF SUPPORTS_FOR_IN}\r\n { IJclIntfList }\r\n function Delete(Index: Integer): IInterface;\r\n function ExtractIndex(Index: Integer): IInterface;\r\n function GetObject(Index: Integer): IInterface;\r\n function IndexOf(const AInterface: IInterface): Integer;\r\n function Insert(Index: Integer; const AInterface: IInterface): Boolean;\r\n function InsertAll(Index: Integer; const ACollection: IJclIntfCollection): Boolean;\r\n function LastIndexOf(const AInterface: IInterface): Integer;\r\n procedure SetObject(Index: Integer; const AInterface: IInterface);\r\n function SubList(First, Count: Integer): IJclIntfList;\r\n end;\r\n\r\n TJclIntfLinkedListIterator = class(TJclAbstractIterator, IJclIntfIterator, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclIntfCloneable, IJclCloneable)\r\n private\r\n FCursor: TJclIntfLinkedListItem;\r\n FStart: TItrStart;\r\n FOwnList: TJclIntfLinkedList;\r\n FEqualityComparer: IJclIntfEqualityComparer;\r\n public\r\n procedure AssignPropertiesTo(Dest: TJclAbstractIterator); override;\r\n function CreateEmptyIterator: TJclAbstractIterator; override;\r\n public\r\n constructor Create(AOwnList: TJclIntfLinkedList; ACursor: TJclIntfLinkedListItem; AValid: Boolean; AStart: TItrStart);\r\n { IJclIntfIterator }\r\n function Add(const AInterface: IInterface): Boolean;\r\n procedure Extract;\r\n function GetObject: IInterface;\r\n function HasNext: Boolean;\r\n function HasPrevious: Boolean;\r\n function Insert(const AInterface: IInterface): Boolean;\r\n function IteratorEquals(const AIterator: IJclIntfIterator): Boolean;\r\n function Next: IInterface;\r\n function NextIndex: Integer;\r\n function Previous: IInterface;\r\n function PreviousIndex: Integer;\r\n procedure Remove;\r\n procedure Reset;\r\n procedure SetObject(const AInterface: IInterface);\r\n {$IFDEF SUPPORTS_FOR_IN}\r\n function MoveNext: Boolean;\r\n property Current: IInterface read GetObject;\r\n {$ENDIF SUPPORTS_FOR_IN}\r\n end;\r\n\r\n TJclAnsiStrLinkedListItem = class\r\n public\r\n Value: AnsiString;\r\n Next: TJclAnsiStrLinkedListItem;\r\n Previous: TJclAnsiStrLinkedListItem;\r\n end;\r\n\r\n TJclAnsiStrLinkedList = class(TJclAnsiStrAbstractCollection, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclIntfCloneable, IJclCloneable, IJclBaseContainer, IJclAnsiStrContainer,\r\n IJclAnsiStrFlatContainer, IJclAnsiStrEqualityComparer, IJclStrBaseContainer,\r\n IJclAnsiStrCollection, IJclAnsiStrList)\r\n protected\r\n function CreateEmptyContainer: TJclAbstractContainerBase; override;\r\n private\r\n FStart: TJclAnsiStrLinkedListItem;\r\n FEnd: TJclAnsiStrLinkedListItem;\r\n protected\r\n procedure AssignDataTo(Dest: TJclAbstractContainerBase); override;\r\n public\r\n constructor Create(const ACollection: IJclAnsiStrCollection);\r\n destructor Destroy; override;\r\n { IJclAnsiStrCollection }\r\n function Add(const AString: AnsiString): Boolean; override;\r\n function AddAll(const ACollection: IJclAnsiStrCollection): Boolean; override;\r\n procedure Clear; override;\r\n function CollectionEquals(const ACollection: IJclAnsiStrCollection): Boolean; override;\r\n function Contains(const AString: AnsiString): Boolean; override;\r\n function ContainsAll(const ACollection: IJclAnsiStrCollection): Boolean; override;\r\n function Extract(const AString: AnsiString): Boolean; override;\r\n function ExtractAll(const ACollection: IJclAnsiStrCollection): Boolean; override;\r\n function First: IJclAnsiStrIterator; override;\r\n function IsEmpty: Boolean; override;\r\n function Last: IJclAnsiStrIterator; override;\r\n function Remove(const AString: AnsiString): Boolean; override;\r\n function RemoveAll(const ACollection: IJclAnsiStrCollection): Boolean; override;\r\n function RetainAll(const ACollection: IJclAnsiStrCollection): Boolean; override;\r\n function Size: Integer; override;\r\n {$IFDEF SUPPORTS_FOR_IN}\r\n function GetEnumerator: IJclAnsiStrIterator; override;\r\n {$ENDIF SUPPORTS_FOR_IN}\r\n { IJclAnsiStrList }\r\n function Delete(Index: Integer): AnsiString;\r\n function ExtractIndex(Index: Integer): AnsiString;\r\n function GetString(Index: Integer): AnsiString;\r\n function IndexOf(const AString: AnsiString): Integer;\r\n function Insert(Index: Integer; const AString: AnsiString): Boolean;\r\n function InsertAll(Index: Integer; const ACollection: IJclAnsiStrCollection): Boolean;\r\n function LastIndexOf(const AString: AnsiString): Integer;\r\n procedure SetString(Index: Integer; const AString: AnsiString);\r\n function SubList(First, Count: Integer): IJclAnsiStrList;\r\n end;\r\n\r\n TJclAnsiStrLinkedListIterator = class(TJclAbstractIterator, IJclAnsiStrIterator, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclIntfCloneable, IJclCloneable)\r\n private\r\n FCursor: TJclAnsiStrLinkedListItem;\r\n FStart: TItrStart;\r\n FOwnList: TJclAnsiStrLinkedList;\r\n FEqualityComparer: IJclAnsiStrEqualityComparer;\r\n public\r\n procedure AssignPropertiesTo(Dest: TJclAbstractIterator); override;\r\n function CreateEmptyIterator: TJclAbstractIterator; override;\r\n public\r\n constructor Create(AOwnList: TJclAnsiStrLinkedList; ACursor: TJclAnsiStrLinkedListItem; AValid: Boolean; AStart: TItrStart);\r\n { IJclAnsiStrIterator }\r\n function Add(const AString: AnsiString): Boolean;\r\n procedure Extract;\r\n function GetString: AnsiString;\r\n function HasNext: Boolean;\r\n function HasPrevious: Boolean;\r\n function Insert(const AString: AnsiString): Boolean;\r\n function IteratorEquals(const AIterator: IJclAnsiStrIterator): Boolean;\r\n function Next: AnsiString;\r\n function NextIndex: Integer;\r\n function Previous: AnsiString;\r\n function PreviousIndex: Integer;\r\n procedure Remove;\r\n procedure Reset;\r\n procedure SetString(const AString: AnsiString);\r\n {$IFDEF SUPPORTS_FOR_IN}\r\n function MoveNext: Boolean;\r\n property Current: AnsiString read GetString;\r\n {$ENDIF SUPPORTS_FOR_IN}\r\n end;\r\n\r\n TJclWideStrLinkedListItem = class\r\n public\r\n Value: WideString;\r\n Next: TJclWideStrLinkedListItem;\r\n Previous: TJclWideStrLinkedListItem;\r\n end;\r\n\r\n TJclWideStrLinkedList = class(TJclWideStrAbstractCollection, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclIntfCloneable, IJclCloneable, IJclBaseContainer, IJclWideStrContainer,\r\n IJclWideStrFlatContainer, IJclWideStrEqualityComparer, IJclStrBaseContainer,\r\n IJclWideStrCollection, IJclWideStrList)\r\n protected\r\n function CreateEmptyContainer: TJclAbstractContainerBase; override;\r\n private\r\n FStart: TJclWideStrLinkedListItem;\r\n FEnd: TJclWideStrLinkedListItem;\r\n protected\r\n procedure AssignDataTo(Dest: TJclAbstractContainerBase); override;\r\n public\r\n constructor Create(const ACollection: IJclWideStrCollection);\r\n destructor Destroy; override;\r\n { IJclWideStrCollection }\r\n function Add(const AString: WideString): Boolean; override;\r\n function AddAll(const ACollection: IJclWideStrCollection): Boolean; override;\r\n procedure Clear; override;\r\n function CollectionEquals(const ACollection: IJclWideStrCollection): Boolean; override;\r\n function Contains(const AString: WideString): Boolean; override;\r\n function ContainsAll(const ACollection: IJclWideStrCollection): Boolean; override;\r\n function Extract(const AString: WideString): Boolean; override;\r\n function ExtractAll(const ACollection: IJclWideStrCollection): Boolean; override;\r\n function First: IJclWideStrIterator; override;\r\n function IsEmpty: Boolean; override;\r\n function Last: IJclWideStrIterator; override;\r\n function Remove(const AString: WideString): Boolean; override;\r\n function RemoveAll(const ACollection: IJclWideStrCollection): Boolean; override;\r\n function RetainAll(const ACollection: IJclWideStrCollection): Boolean; override;\r\n function Size: Integer; override;\r\n {$IFDEF SUPPORTS_FOR_IN}\r\n function GetEnumerator: IJclWideStrIterator; override;\r\n {$ENDIF SUPPORTS_FOR_IN}\r\n { IJclWideStrList }\r\n function Delete(Index: Integer): WideString;\r\n function ExtractIndex(Index: Integer): WideString;\r\n function GetString(Index: Integer): WideString;\r\n function IndexOf(const AString: WideString): Integer;\r\n function Insert(Index: Integer; const AString: WideString): Boolean;\r\n function InsertAll(Index: Integer; const ACollection: IJclWideStrCollection): Boolean;\r\n function LastIndexOf(const AString: WideString): Integer;\r\n procedure SetString(Index: Integer; const AString: WideString);\r\n function SubList(First, Count: Integer): IJclWideStrList;\r\n end;\r\n\r\n TJclWideStrLinkedListIterator = class(TJclAbstractIterator, IJclWideStrIterator, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclIntfCloneable, IJclCloneable)\r\n private\r\n FCursor: TJclWideStrLinkedListItem;\r\n FStart: TItrStart;\r\n FOwnList: TJclWideStrLinkedList;\r\n FEqualityComparer: IJclWideStrEqualityComparer;\r\n public\r\n procedure AssignPropertiesTo(Dest: TJclAbstractIterator); override;\r\n function CreateEmptyIterator: TJclAbstractIterator; override;\r\n public\r\n constructor Create(AOwnList: TJclWideStrLinkedList; ACursor: TJclWideStrLinkedListItem; AValid: Boolean; AStart: TItrStart);\r\n { IJclWideStrIterator }\r\n function Add(const AString: WideString): Boolean;\r\n procedure Extract;\r\n function GetString: WideString;\r\n function HasNext: Boolean;\r\n function HasPrevious: Boolean;\r\n function Insert(const AString: WideString): Boolean;\r\n function IteratorEquals(const AIterator: IJclWideStrIterator): Boolean;\r\n function Next: WideString;\r\n function NextIndex: Integer;\r\n function Previous: WideString;\r\n function PreviousIndex: Integer;\r\n procedure Remove;\r\n procedure Reset;\r\n procedure SetString(const AString: WideString);\r\n {$IFDEF SUPPORTS_FOR_IN}\r\n function MoveNext: Boolean;\r\n property Current: WideString read GetString;\r\n {$ENDIF SUPPORTS_FOR_IN}\r\n end;\r\n\r\n {$IFDEF SUPPORTS_UNICODE_STRING}\r\n TJclUnicodeStrLinkedListItem = class\r\n public\r\n Value: UnicodeString;\r\n Next: TJclUnicodeStrLinkedListItem;\r\n Previous: TJclUnicodeStrLinkedListItem;\r\n end;\r\n {$ENDIF SUPPORTS_UNICODE_STRING}\r\n\r\n {$IFDEF SUPPORTS_UNICODE_STRING}\r\n TJclUnicodeStrLinkedList = class(TJclUnicodeStrAbstractCollection, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclIntfCloneable, IJclCloneable, IJclBaseContainer, IJclUnicodeStrContainer,\r\n IJclUnicodeStrFlatContainer, IJclUnicodeStrEqualityComparer, IJclStrBaseContainer,\r\n IJclUnicodeStrCollection, IJclUnicodeStrList)\r\n protected\r\n function CreateEmptyContainer: TJclAbstractContainerBase; override;\r\n private\r\n FStart: TJclUnicodeStrLinkedListItem;\r\n FEnd: TJclUnicodeStrLinkedListItem;\r\n protected\r\n procedure AssignDataTo(Dest: TJclAbstractContainerBase); override;\r\n public\r\n constructor Create(const ACollection: IJclUnicodeStrCollection);\r\n destructor Destroy; override;\r\n { IJclUnicodeStrCollection }\r\n function Add(const AString: UnicodeString): Boolean; override;\r\n function AddAll(const ACollection: IJclUnicodeStrCollection): Boolean; override;\r\n procedure Clear; override;\r\n function CollectionEquals(const ACollection: IJclUnicodeStrCollection): Boolean; override;\r\n function Contains(const AString: UnicodeString): Boolean; override;\r\n function ContainsAll(const ACollection: IJclUnicodeStrCollection): Boolean; override;\r\n function Extract(const AString: UnicodeString): Boolean; override;\r\n function ExtractAll(const ACollection: IJclUnicodeStrCollection): Boolean; override;\r\n function First: IJclUnicodeStrIterator; override;\r\n function IsEmpty: Boolean; override;\r\n function Last: IJclUnicodeStrIterator; override;\r\n function Remove(const AString: UnicodeString): Boolean; override;\r\n function RemoveAll(const ACollection: IJclUnicodeStrCollection): Boolean; override;\r\n function RetainAll(const ACollection: IJclUnicodeStrCollection): Boolean; override;\r\n function Size: Integer; override;\r\n {$IFDEF SUPPORTS_FOR_IN}\r\n function GetEnumerator: IJclUnicodeStrIterator; override;\r\n {$ENDIF SUPPORTS_FOR_IN}\r\n { IJclUnicodeStrList }\r\n function Delete(Index: Integer): UnicodeString;\r\n function ExtractIndex(Index: Integer): UnicodeString;\r\n function GetString(Index: Integer): UnicodeString;\r\n function IndexOf(const AString: UnicodeString): Integer;\r\n function Insert(Index: Integer; const AString: UnicodeString): Boolean;\r\n function InsertAll(Index: Integer; const ACollection: IJclUnicodeStrCollection): Boolean;\r\n function LastIndexOf(const AString: UnicodeString): Integer;\r\n procedure SetString(Index: Integer; const AString: UnicodeString);\r\n function SubList(First, Count: Integer): IJclUnicodeStrList;\r\n end;\r\n {$ENDIF SUPPORTS_UNICODE_STRING}\r\n\r\n {$IFDEF SUPPORTS_UNICODE_STRING}\r\n TJclUnicodeStrLinkedListIterator = class(TJclAbstractIterator, IJclUnicodeStrIterator, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclIntfCloneable, IJclCloneable)\r\n private\r\n FCursor: TJclUnicodeStrLinkedListItem;\r\n FStart: TItrStart;\r\n FOwnList: TJclUnicodeStrLinkedList;\r\n FEqualityComparer: IJclUnicodeStrEqualityComparer;\r\n public\r\n procedure AssignPropertiesTo(Dest: TJclAbstractIterator); override;\r\n function CreateEmptyIterator: TJclAbstractIterator; override;\r\n public\r\n constructor Create(AOwnList: TJclUnicodeStrLinkedList; ACursor: TJclUnicodeStrLinkedListItem; AValid: Boolean; AStart: TItrStart);\r\n { IJclUnicodeStrIterator }\r\n function Add(const AString: UnicodeString): Boolean;\r\n procedure Extract;\r\n function GetString: UnicodeString;\r\n function HasNext: Boolean;\r\n function HasPrevious: Boolean;\r\n function Insert(const AString: UnicodeString): Boolean;\r\n function IteratorEquals(const AIterator: IJclUnicodeStrIterator): Boolean;\r\n function Next: UnicodeString;\r\n function NextIndex: Integer;\r\n function Previous: UnicodeString;\r\n function PreviousIndex: Integer;\r\n procedure Remove;\r\n procedure Reset;\r\n procedure SetString(const AString: UnicodeString);\r\n {$IFDEF SUPPORTS_FOR_IN}\r\n function MoveNext: Boolean;\r\n property Current: UnicodeString read GetString;\r\n {$ENDIF SUPPORTS_FOR_IN}\r\n end;\r\n {$ENDIF SUPPORTS_UNICODE_STRING}\r\n\r\n {$IFDEF CONTAINER_ANSISTR}\r\n TJclStrLinkedListItem = TJclAnsiStrLinkedListItem;\r\n {$ENDIF CONTAINER_ANSISTR}\r\n {$IFDEF CONTAINER_WIDESTR}\r\n TJclStrLinkedListItem = TJclWideStrLinkedListItem;\r\n {$ENDIF CONTAINER_WIDESTR}\r\n {$IFDEF CONTAINER_UNICODESTR}\r\n TJclStrLinkedListItem = TJclUnicodeStrLinkedListItem;\r\n {$ENDIF CONTAINER_UNICODESTR}\r\n\r\n {$IFDEF CONTAINER_ANSISTR}\r\n TJclStrLinkedList = TJclAnsiStrLinkedList;\r\n {$ENDIF CONTAINER_ANSISTR}\r\n {$IFDEF CONTAINER_WIDESTR}\r\n TJclStrLinkedList = TJclWideStrLinkedList;\r\n {$ENDIF CONTAINER_WIDESTR}\r\n {$IFDEF CONTAINER_UNICODESTR}\r\n TJclStrLinkedList = TJclUnicodeStrLinkedList;\r\n {$ENDIF CONTAINER_UNICODESTR}\r\n\r\n {$IFDEF CONTAINER_ANSISTR}\r\n TJclStrLinkedListIterator = TJclAnsiStrLinkedListIterator;\r\n {$ENDIF CONTAINER_ANSISTR}\r\n {$IFDEF CONTAINER_WIDESTR}\r\n TJclStrLinkedListIterator = TJclWideStrLinkedListIterator;\r\n {$ENDIF CONTAINER_WIDESTR}\r\n {$IFDEF CONTAINER_UNICODESTR}\r\n TJclStrLinkedListIterator = TJclUnicodeStrLinkedListIterator;\r\n {$ENDIF CONTAINER_UNICODESTR}\r\n\r\n TJclSingleLinkedListItem = class\r\n public\r\n Value: Single;\r\n Next: TJclSingleLinkedListItem;\r\n Previous: TJclSingleLinkedListItem;\r\n end;\r\n\r\n TJclSingleLinkedList = class(TJclSingleAbstractContainer, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclIntfCloneable, IJclCloneable, IJclBaseContainer, IJclSingleContainer,\r\n IJclSingleFlatContainer, IJclSingleEqualityComparer,\r\n IJclSingleCollection, IJclSingleList)\r\n protected\r\n function CreateEmptyContainer: TJclAbstractContainerBase; override;\r\n private\r\n FStart: TJclSingleLinkedListItem;\r\n FEnd: TJclSingleLinkedListItem;\r\n protected\r\n procedure AssignDataTo(Dest: TJclAbstractContainerBase); override;\r\n public\r\n constructor Create(const ACollection: IJclSingleCollection);\r\n destructor Destroy; override;\r\n { IJclSingleCollection }\r\n function Add(const AValue: Single): Boolean;\r\n function AddAll(const ACollection: IJclSingleCollection): Boolean;\r\n procedure Clear;\r\n function CollectionEquals(const ACollection: IJclSingleCollection): Boolean;\r\n function Contains(const AValue: Single): Boolean;\r\n function ContainsAll(const ACollection: IJclSingleCollection): Boolean;\r\n function Extract(const AValue: Single): Boolean;\r\n function ExtractAll(const ACollection: IJclSingleCollection): Boolean;\r\n function First: IJclSingleIterator;\r\n function IsEmpty: Boolean;\r\n function Last: IJclSingleIterator;\r\n function Remove(const AValue: Single): Boolean;\r\n function RemoveAll(const ACollection: IJclSingleCollection): Boolean;\r\n function RetainAll(const ACollection: IJclSingleCollection): Boolean;\r\n function Size: Integer;\r\n {$IFDEF SUPPORTS_FOR_IN}\r\n function GetEnumerator: IJclSingleIterator;\r\n {$ENDIF SUPPORTS_FOR_IN}\r\n { IJclSingleList }\r\n function Delete(Index: Integer): Single;\r\n function ExtractIndex(Index: Integer): Single;\r\n function GetValue(Index: Integer): Single;\r\n function IndexOf(const AValue: Single): Integer;\r\n function Insert(Index: Integer; const AValue: Single): Boolean;\r\n function InsertAll(Index: Integer; const ACollection: IJclSingleCollection): Boolean;\r\n function LastIndexOf(const AValue: Single): Integer;\r\n procedure SetValue(Index: Integer; const AValue: Single);\r\n function SubList(First, Count: Integer): IJclSingleList;\r\n end;\r\n\r\n TJclSingleLinkedListIterator = class(TJclAbstractIterator, IJclSingleIterator, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclIntfCloneable, IJclCloneable)\r\n private\r\n FCursor: TJclSingleLinkedListItem;\r\n FStart: TItrStart;\r\n FOwnList: TJclSingleLinkedList;\r\n FEqualityComparer: IJclSingleEqualityComparer;\r\n public\r\n procedure AssignPropertiesTo(Dest: TJclAbstractIterator); override;\r\n function CreateEmptyIterator: TJclAbstractIterator; override;\r\n public\r\n constructor Create(AOwnList: TJclSingleLinkedList; ACursor: TJclSingleLinkedListItem; AValid: Boolean; AStart: TItrStart);\r\n { IJclSingleIterator }\r\n function Add(const AValue: Single): Boolean;\r\n procedure Extract;\r\n function GetValue: Single;\r\n function HasNext: Boolean;\r\n function HasPrevious: Boolean;\r\n function Insert(const AValue: Single): Boolean;\r\n function IteratorEquals(const AIterator: IJclSingleIterator): Boolean;\r\n function Next: Single;\r\n function NextIndex: Integer;\r\n function Previous: Single;\r\n function PreviousIndex: Integer;\r\n procedure Remove;\r\n procedure Reset;\r\n procedure SetValue(const AValue: Single);\r\n {$IFDEF SUPPORTS_FOR_IN}\r\n function MoveNext: Boolean;\r\n property Current: Single read GetValue;\r\n {$ENDIF SUPPORTS_FOR_IN}\r\n end;\r\n\r\n TJclDoubleLinkedListItem = class\r\n public\r\n Value: Double;\r\n Next: TJclDoubleLinkedListItem;\r\n Previous: TJclDoubleLinkedListItem;\r\n end;\r\n\r\n TJclDoubleLinkedList = class(TJclDoubleAbstractContainer, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclIntfCloneable, IJclCloneable, IJclBaseContainer, IJclDoubleContainer,\r\n IJclDoubleFlatContainer, IJclDoubleEqualityComparer,\r\n IJclDoubleCollection, IJclDoubleList)\r\n protected\r\n function CreateEmptyContainer: TJclAbstractContainerBase; override;\r\n private\r\n FStart: TJclDoubleLinkedListItem;\r\n FEnd: TJclDoubleLinkedListItem;\r\n protected\r\n procedure AssignDataTo(Dest: TJclAbstractContainerBase); override;\r\n public\r\n constructor Create(const ACollection: IJclDoubleCollection);\r\n destructor Destroy; override;\r\n { IJclDoubleCollection }\r\n function Add(const AValue: Double): Boolean;\r\n function AddAll(const ACollection: IJclDoubleCollection): Boolean;\r\n procedure Clear;\r\n function CollectionEquals(const ACollection: IJclDoubleCollection): Boolean;\r\n function Contains(const AValue: Double): Boolean;\r\n function ContainsAll(const ACollection: IJclDoubleCollection): Boolean;\r\n function Extract(const AValue: Double): Boolean;\r\n function ExtractAll(const ACollection: IJclDoubleCollection): Boolean;\r\n function First: IJclDoubleIterator;\r\n function IsEmpty: Boolean;\r\n function Last: IJclDoubleIterator;\r\n function Remove(const AValue: Double): Boolean;\r\n function RemoveAll(const ACollection: IJclDoubleCollection): Boolean;\r\n function RetainAll(const ACollection: IJclDoubleCollection): Boolean;\r\n function Size: Integer;\r\n {$IFDEF SUPPORTS_FOR_IN}\r\n function GetEnumerator: IJclDoubleIterator;\r\n {$ENDIF SUPPORTS_FOR_IN}\r\n { IJclDoubleList }\r\n function Delete(Index: Integer): Double;\r\n function ExtractIndex(Index: Integer): Double;\r\n function GetValue(Index: Integer): Double;\r\n function IndexOf(const AValue: Double): Integer;\r\n function Insert(Index: Integer; const AValue: Double): Boolean;\r\n function InsertAll(Index: Integer; const ACollection: IJclDoubleCollection): Boolean;\r\n function LastIndexOf(const AValue: Double): Integer;\r\n procedure SetValue(Index: Integer; const AValue: Double);\r\n function SubList(First, Count: Integer): IJclDoubleList;\r\n end;\r\n\r\n TJclDoubleLinkedListIterator = class(TJclAbstractIterator, IJclDoubleIterator, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclIntfCloneable, IJclCloneable)\r\n private\r\n FCursor: TJclDoubleLinkedListItem;\r\n FStart: TItrStart;\r\n FOwnList: TJclDoubleLinkedList;\r\n FEqualityComparer: IJclDoubleEqualityComparer;\r\n public\r\n procedure AssignPropertiesTo(Dest: TJclAbstractIterator); override;\r\n function CreateEmptyIterator: TJclAbstractIterator; override;\r\n public\r\n constructor Create(AOwnList: TJclDoubleLinkedList; ACursor: TJclDoubleLinkedListItem; AValid: Boolean; AStart: TItrStart);\r\n { IJclDoubleIterator }\r\n function Add(const AValue: Double): Boolean;\r\n procedure Extract;\r\n function GetValue: Double;\r\n function HasNext: Boolean;\r\n function HasPrevious: Boolean;\r\n function Insert(const AValue: Double): Boolean;\r\n function IteratorEquals(const AIterator: IJclDoubleIterator): Boolean;\r\n function Next: Double;\r\n function NextIndex: Integer;\r\n function Previous: Double;\r\n function PreviousIndex: Integer;\r\n procedure Remove;\r\n procedure Reset;\r\n procedure SetValue(const AValue: Double);\r\n {$IFDEF SUPPORTS_FOR_IN}\r\n function MoveNext: Boolean;\r\n property Current: Double read GetValue;\r\n {$ENDIF SUPPORTS_FOR_IN}\r\n end;\r\n\r\n TJclExtendedLinkedListItem = class\r\n public\r\n Value: Extended;\r\n Next: TJclExtendedLinkedListItem;\r\n Previous: TJclExtendedLinkedListItem;\r\n end;\r\n\r\n TJclExtendedLinkedList = class(TJclExtendedAbstractContainer, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclIntfCloneable, IJclCloneable, IJclBaseContainer, IJclExtendedContainer,\r\n IJclExtendedFlatContainer, IJclExtendedEqualityComparer,\r\n IJclExtendedCollection, IJclExtendedList)\r\n protected\r\n function CreateEmptyContainer: TJclAbstractContainerBase; override;\r\n private\r\n FStart: TJclExtendedLinkedListItem;\r\n FEnd: TJclExtendedLinkedListItem;\r\n protected\r\n procedure AssignDataTo(Dest: TJclAbstractContainerBase); override;\r\n public\r\n constructor Create(const ACollection: IJclExtendedCollection);\r\n destructor Destroy; override;\r\n { IJclExtendedCollection }\r\n function Add(const AValue: Extended): Boolean;\r\n function AddAll(const ACollection: IJclExtendedCollection): Boolean;\r\n procedure Clear;\r\n function CollectionEquals(const ACollection: IJclExtendedCollection): Boolean;\r\n function Contains(const AValue: Extended): Boolean;\r\n function ContainsAll(const ACollection: IJclExtendedCollection): Boolean;\r\n function Extract(const AValue: Extended): Boolean;\r\n function ExtractAll(const ACollection: IJclExtendedCollection): Boolean;\r\n function First: IJclExtendedIterator;\r\n function IsEmpty: Boolean;\r\n function Last: IJclExtendedIterator;\r\n function Remove(const AValue: Extended): Boolean;\r\n function RemoveAll(const ACollection: IJclExtendedCollection): Boolean;\r\n function RetainAll(const ACollection: IJclExtendedCollection): Boolean;\r\n function Size: Integer;\r\n {$IFDEF SUPPORTS_FOR_IN}\r\n function GetEnumerator: IJclExtendedIterator;\r\n {$ENDIF SUPPORTS_FOR_IN}\r\n { IJclExtendedList }\r\n function Delete(Index: Integer): Extended;\r\n function ExtractIndex(Index: Integer): Extended;\r\n function GetValue(Index: Integer): Extended;\r\n function IndexOf(const AValue: Extended): Integer;\r\n function Insert(Index: Integer; const AValue: Extended): Boolean;\r\n function InsertAll(Index: Integer; const ACollection: IJclExtendedCollection): Boolean;\r\n function LastIndexOf(const AValue: Extended): Integer;\r\n procedure SetValue(Index: Integer; const AValue: Extended);\r\n function SubList(First, Count: Integer): IJclExtendedList;\r\n end;\r\n\r\n TJclExtendedLinkedListIterator = class(TJclAbstractIterator, IJclExtendedIterator, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclIntfCloneable, IJclCloneable)\r\n private\r\n FCursor: TJclExtendedLinkedListItem;\r\n FStart: TItrStart;\r\n FOwnList: TJclExtendedLinkedList;\r\n FEqualityComparer: IJclExtendedEqualityComparer;\r\n public\r\n procedure AssignPropertiesTo(Dest: TJclAbstractIterator); override;\r\n function CreateEmptyIterator: TJclAbstractIterator; override;\r\n public\r\n constructor Create(AOwnList: TJclExtendedLinkedList; ACursor: TJclExtendedLinkedListItem; AValid: Boolean; AStart: TItrStart);\r\n { IJclExtendedIterator }\r\n function Add(const AValue: Extended): Boolean;\r\n procedure Extract;\r\n function GetValue: Extended;\r\n function HasNext: Boolean;\r\n function HasPrevious: Boolean;\r\n function Insert(const AValue: Extended): Boolean;\r\n function IteratorEquals(const AIterator: IJclExtendedIterator): Boolean;\r\n function Next: Extended;\r\n function NextIndex: Integer;\r\n function Previous: Extended;\r\n function PreviousIndex: Integer;\r\n procedure Remove;\r\n procedure Reset;\r\n procedure SetValue(const AValue: Extended);\r\n {$IFDEF SUPPORTS_FOR_IN}\r\n function MoveNext: Boolean;\r\n property Current: Extended read GetValue;\r\n {$ENDIF SUPPORTS_FOR_IN}\r\n end;\r\n\r\n {$IFDEF MATH_SINGLE_PRECISION}\r\n TJclFloatLinkedListItem = TJclSingleLinkedListItem;\r\n {$ENDIF MATH_SINGLE_PRECISION}\r\n {$IFDEF MATH_DOUBLE_PRECISION}\r\n TJclFloatLinkedListItem = TJclDoubleLinkedListItem;\r\n {$ENDIF MATH_DOUBLE_PRECISION}\r\n {$IFDEF MATH_EXTENDED_PRECISION}\r\n TJclFloatLinkedListItem = TJclExtendedLinkedListItem;\r\n {$ENDIF MATH_EXTENDED_PRECISION}\r\n\r\n {$IFDEF MATH_SINGLE_PRECISION}\r\n TJclFloatLinkedList = TJclSingleLinkedList;\r\n {$ENDIF MATH_SINGLE_PRECISION}\r\n {$IFDEF MATH_DOUBLE_PRECISION}\r\n TJclFloatLinkedList = TJclDoubleLinkedList;\r\n {$ENDIF MATH_DOUBLE_PRECISION}\r\n {$IFDEF MATH_EXTENDED_PRECISION}\r\n TJclFloatLinkedList = TJclExtendedLinkedList;\r\n {$ENDIF MATH_EXTENDED_PRECISION}\r\n\r\n {$IFDEF MATH_SINGLE_PRECISION}\r\n TJclFloatLinkedListIterator = TJclSingleLinkedListIterator;\r\n {$ENDIF MATH_SINGLE_PRECISION}\r\n {$IFDEF MATH_DOUBLE_PRECISION}\r\n TJclFloatLinkedListIterator = TJclDoubleLinkedListIterator;\r\n {$ENDIF MATH_DOUBLE_PRECISION}\r\n {$IFDEF MATH_EXTENDED_PRECISION}\r\n TJclFloatLinkedListIterator = TJclExtendedLinkedListIterator;\r\n {$ENDIF MATH_EXTENDED_PRECISION}\r\n\r\n TJclIntegerLinkedListItem = class\r\n public\r\n Value: Integer;\r\n Next: TJclIntegerLinkedListItem;\r\n Previous: TJclIntegerLinkedListItem;\r\n end;\r\n\r\n TJclIntegerLinkedList = class(TJclIntegerAbstractContainer, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclIntfCloneable, IJclCloneable, IJclBaseContainer, IJclIntegerContainer,\r\n IJclIntegerFlatContainer, IJclIntegerEqualityComparer,\r\n IJclIntegerCollection, IJclIntegerList)\r\n protected\r\n function CreateEmptyContainer: TJclAbstractContainerBase; override;\r\n private\r\n FStart: TJclIntegerLinkedListItem;\r\n FEnd: TJclIntegerLinkedListItem;\r\n protected\r\n procedure AssignDataTo(Dest: TJclAbstractContainerBase); override;\r\n public\r\n constructor Create(const ACollection: IJclIntegerCollection);\r\n destructor Destroy; override;\r\n { IJclIntegerCollection }\r\n function Add(AValue: Integer): Boolean;\r\n function AddAll(const ACollection: IJclIntegerCollection): Boolean;\r\n procedure Clear;\r\n function CollectionEquals(const ACollection: IJclIntegerCollection): Boolean;\r\n function Contains(AValue: Integer): Boolean;\r\n function ContainsAll(const ACollection: IJclIntegerCollection): Boolean;\r\n function Extract(AValue: Integer): Boolean;\r\n function ExtractAll(const ACollection: IJclIntegerCollection): Boolean;\r\n function First: IJclIntegerIterator;\r\n function IsEmpty: Boolean;\r\n function Last: IJclIntegerIterator;\r\n function Remove(AValue: Integer): Boolean;\r\n function RemoveAll(const ACollection: IJclIntegerCollection): Boolean;\r\n function RetainAll(const ACollection: IJclIntegerCollection): Boolean;\r\n function Size: Integer;\r\n {$IFDEF SUPPORTS_FOR_IN}\r\n function GetEnumerator: IJclIntegerIterator;\r\n {$ENDIF SUPPORTS_FOR_IN}\r\n { IJclIntegerList }\r\n function Delete(Index: Integer): Integer;\r\n function ExtractIndex(Index: Integer): Integer;\r\n function GetValue(Index: Integer): Integer;\r\n function IndexOf(AValue: Integer): Integer;\r\n function Insert(Index: Integer; AValue: Integer): Boolean;\r\n function InsertAll(Index: Integer; const ACollection: IJclIntegerCollection): Boolean;\r\n function LastIndexOf(AValue: Integer): Integer;\r\n procedure SetValue(Index: Integer; AValue: Integer);\r\n function SubList(First, Count: Integer): IJclIntegerList;\r\n end;\r\n\r\n TJclIntegerLinkedListIterator = class(TJclAbstractIterator, IJclIntegerIterator, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclIntfCloneable, IJclCloneable)\r\n private\r\n FCursor: TJclIntegerLinkedListItem;\r\n FStart: TItrStart;\r\n FOwnList: TJclIntegerLinkedList;\r\n FEqualityComparer: IJclIntegerEqualityComparer;\r\n public\r\n procedure AssignPropertiesTo(Dest: TJclAbstractIterator); override;\r\n function CreateEmptyIterator: TJclAbstractIterator; override;\r\n public\r\n constructor Create(AOwnList: TJclIntegerLinkedList; ACursor: TJclIntegerLinkedListItem; AValid: Boolean; AStart: TItrStart);\r\n { IJclIntegerIterator }\r\n function Add(AValue: Integer): Boolean;\r\n procedure Extract;\r\n function GetValue: Integer;\r\n function HasNext: Boolean;\r\n function HasPrevious: Boolean;\r\n function Insert(AValue: Integer): Boolean;\r\n function IteratorEquals(const AIterator: IJclIntegerIterator): Boolean;\r\n function Next: Integer;\r\n function NextIndex: Integer;\r\n function Previous: Integer;\r\n function PreviousIndex: Integer;\r\n procedure Remove;\r\n procedure Reset;\r\n procedure SetValue(AValue: Integer);\r\n {$IFDEF SUPPORTS_FOR_IN}\r\n function MoveNext: Boolean;\r\n property Current: Integer read GetValue;\r\n {$ENDIF SUPPORTS_FOR_IN}\r\n end;\r\n\r\n TJclCardinalLinkedListItem = class\r\n public\r\n Value: Cardinal;\r\n Next: TJclCardinalLinkedListItem;\r\n Previous: TJclCardinalLinkedListItem;\r\n end;\r\n\r\n TJclCardinalLinkedList = class(TJclCardinalAbstractContainer, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclIntfCloneable, IJclCloneable, IJclBaseContainer, IJclCardinalContainer,\r\n IJclCardinalFlatContainer, IJclCardinalEqualityComparer,\r\n IJclCardinalCollection, IJclCardinalList)\r\n protected\r\n function CreateEmptyContainer: TJclAbstractContainerBase; override;\r\n private\r\n FStart: TJclCardinalLinkedListItem;\r\n FEnd: TJclCardinalLinkedListItem;\r\n protected\r\n procedure AssignDataTo(Dest: TJclAbstractContainerBase); override;\r\n public\r\n constructor Create(const ACollection: IJclCardinalCollection);\r\n destructor Destroy; override;\r\n { IJclCardinalCollection }\r\n function Add(AValue: Cardinal): Boolean;\r\n function AddAll(const ACollection: IJclCardinalCollection): Boolean;\r\n procedure Clear;\r\n function CollectionEquals(const ACollection: IJclCardinalCollection): Boolean;\r\n function Contains(AValue: Cardinal): Boolean;\r\n function ContainsAll(const ACollection: IJclCardinalCollection): Boolean;\r\n function Extract(AValue: Cardinal): Boolean;\r\n function ExtractAll(const ACollection: IJclCardinalCollection): Boolean;\r\n function First: IJclCardinalIterator;\r\n function IsEmpty: Boolean;\r\n function Last: IJclCardinalIterator;\r\n function Remove(AValue: Cardinal): Boolean;\r\n function RemoveAll(const ACollection: IJclCardinalCollection): Boolean;\r\n function RetainAll(const ACollection: IJclCardinalCollection): Boolean;\r\n function Size: Integer;\r\n {$IFDEF SUPPORTS_FOR_IN}\r\n function GetEnumerator: IJclCardinalIterator;\r\n {$ENDIF SUPPORTS_FOR_IN}\r\n { IJclCardinalList }\r\n function Delete(Index: Integer): Cardinal;\r\n function ExtractIndex(Index: Integer): Cardinal;\r\n function GetValue(Index: Integer): Cardinal;\r\n function IndexOf(AValue: Cardinal): Integer;\r\n function Insert(Index: Integer; AValue: Cardinal): Boolean;\r\n function InsertAll(Index: Integer; const ACollection: IJclCardinalCollection): Boolean;\r\n function LastIndexOf(AValue: Cardinal): Integer;\r\n procedure SetValue(Index: Integer; AValue: Cardinal);\r\n function SubList(First, Count: Integer): IJclCardinalList;\r\n end;\r\n\r\n TJclCardinalLinkedListIterator = class(TJclAbstractIterator, IJclCardinalIterator, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclIntfCloneable, IJclCloneable)\r\n private\r\n FCursor: TJclCardinalLinkedListItem;\r\n FStart: TItrStart;\r\n FOwnList: TJclCardinalLinkedList;\r\n FEqualityComparer: IJclCardinalEqualityComparer;\r\n public\r\n procedure AssignPropertiesTo(Dest: TJclAbstractIterator); override;\r\n function CreateEmptyIterator: TJclAbstractIterator; override;\r\n public\r\n constructor Create(AOwnList: TJclCardinalLinkedList; ACursor: TJclCardinalLinkedListItem; AValid: Boolean; AStart: TItrStart);\r\n { IJclCardinalIterator }\r\n function Add(AValue: Cardinal): Boolean;\r\n procedure Extract;\r\n function GetValue: Cardinal;\r\n function HasNext: Boolean;\r\n function HasPrevious: Boolean;\r\n function Insert(AValue: Cardinal): Boolean;\r\n function IteratorEquals(const AIterator: IJclCardinalIterator): Boolean;\r\n function Next: Cardinal;\r\n function NextIndex: Integer;\r\n function Previous: Cardinal;\r\n function PreviousIndex: Integer;\r\n procedure Remove;\r\n procedure Reset;\r\n procedure SetValue(AValue: Cardinal);\r\n {$IFDEF SUPPORTS_FOR_IN}\r\n function MoveNext: Boolean;\r\n property Current: Cardinal read GetValue;\r\n {$ENDIF SUPPORTS_FOR_IN}\r\n end;\r\n\r\n TJclInt64LinkedListItem = class\r\n public\r\n Value: Int64;\r\n Next: TJclInt64LinkedListItem;\r\n Previous: TJclInt64LinkedListItem;\r\n end;\r\n\r\n TJclInt64LinkedList = class(TJclInt64AbstractContainer, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclIntfCloneable, IJclCloneable, IJclBaseContainer, IJclInt64Container,\r\n IJclInt64FlatContainer, IJclInt64EqualityComparer,\r\n IJclInt64Collection, IJclInt64List)\r\n protected\r\n function CreateEmptyContainer: TJclAbstractContainerBase; override;\r\n private\r\n FStart: TJclInt64LinkedListItem;\r\n FEnd: TJclInt64LinkedListItem;\r\n protected\r\n procedure AssignDataTo(Dest: TJclAbstractContainerBase); override;\r\n public\r\n constructor Create(const ACollection: IJclInt64Collection);\r\n destructor Destroy; override;\r\n { IJclInt64Collection }\r\n function Add(const AValue: Int64): Boolean;\r\n function AddAll(const ACollection: IJclInt64Collection): Boolean;\r\n procedure Clear;\r\n function CollectionEquals(const ACollection: IJclInt64Collection): Boolean;\r\n function Contains(const AValue: Int64): Boolean;\r\n function ContainsAll(const ACollection: IJclInt64Collection): Boolean;\r\n function Extract(const AValue: Int64): Boolean;\r\n function ExtractAll(const ACollection: IJclInt64Collection): Boolean;\r\n function First: IJclInt64Iterator;\r\n function IsEmpty: Boolean;\r\n function Last: IJclInt64Iterator;\r\n function Remove(const AValue: Int64): Boolean;\r\n function RemoveAll(const ACollection: IJclInt64Collection): Boolean;\r\n function RetainAll(const ACollection: IJclInt64Collection): Boolean;\r\n function Size: Integer;\r\n {$IFDEF SUPPORTS_FOR_IN}\r\n function GetEnumerator: IJclInt64Iterator;\r\n {$ENDIF SUPPORTS_FOR_IN}\r\n { IJclInt64List }\r\n function Delete(Index: Integer): Int64;\r\n function ExtractIndex(Index: Integer): Int64;\r\n function GetValue(Index: Integer): Int64;\r\n function IndexOf(const AValue: Int64): Integer;\r\n function Insert(Index: Integer; const AValue: Int64): Boolean;\r\n function InsertAll(Index: Integer; const ACollection: IJclInt64Collection): Boolean;\r\n function LastIndexOf(const AValue: Int64): Integer;\r\n procedure SetValue(Index: Integer; const AValue: Int64);\r\n function SubList(First, Count: Integer): IJclInt64List;\r\n end;\r\n\r\n TJclInt64LinkedListIterator = class(TJclAbstractIterator, IJclInt64Iterator, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclIntfCloneable, IJclCloneable)\r\n private\r\n FCursor: TJclInt64LinkedListItem;\r\n FStart: TItrStart;\r\n FOwnList: TJclInt64LinkedList;\r\n FEqualityComparer: IJclInt64EqualityComparer;\r\n public\r\n procedure AssignPropertiesTo(Dest: TJclAbstractIterator); override;\r\n function CreateEmptyIterator: TJclAbstractIterator; override;\r\n public\r\n constructor Create(AOwnList: TJclInt64LinkedList; ACursor: TJclInt64LinkedListItem; AValid: Boolean; AStart: TItrStart);\r\n { IJclInt64Iterator }\r\n function Add(const AValue: Int64): Boolean;\r\n procedure Extract;\r\n function GetValue: Int64;\r\n function HasNext: Boolean;\r\n function HasPrevious: Boolean;\r\n function Insert(const AValue: Int64): Boolean;\r\n function IteratorEquals(const AIterator: IJclInt64Iterator): Boolean;\r\n function Next: Int64;\r\n function NextIndex: Integer;\r\n function Previous: Int64;\r\n function PreviousIndex: Integer;\r\n procedure Remove;\r\n procedure Reset;\r\n procedure SetValue(const AValue: Int64);\r\n {$IFDEF SUPPORTS_FOR_IN}\r\n function MoveNext: Boolean;\r\n property Current: Int64 read GetValue;\r\n {$ENDIF SUPPORTS_FOR_IN}\r\n end;\r\n\r\n TJclPtrLinkedListItem = class\r\n public\r\n Value: Pointer;\r\n Next: TJclPtrLinkedListItem;\r\n Previous: TJclPtrLinkedListItem;\r\n end;\r\n\r\n TJclPtrLinkedList = class(TJclPtrAbstractContainer, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclIntfCloneable, IJclCloneable, IJclBaseContainer, IJclPtrContainer,\r\n IJclPtrFlatContainer, IJclPtrEqualityComparer,\r\n IJclPtrCollection, IJclPtrList)\r\n protected\r\n function CreateEmptyContainer: TJclAbstractContainerBase; override;\r\n private\r\n FStart: TJclPtrLinkedListItem;\r\n FEnd: TJclPtrLinkedListItem;\r\n protected\r\n procedure AssignDataTo(Dest: TJclAbstractContainerBase); override;\r\n public\r\n constructor Create(const ACollection: IJclPtrCollection);\r\n destructor Destroy; override;\r\n { IJclPtrCollection }\r\n function Add(APtr: Pointer): Boolean;\r\n function AddAll(const ACollection: IJclPtrCollection): Boolean;\r\n procedure Clear;\r\n function CollectionEquals(const ACollection: IJclPtrCollection): Boolean;\r\n function Contains(APtr: Pointer): Boolean;\r\n function ContainsAll(const ACollection: IJclPtrCollection): Boolean;\r\n function Extract(APtr: Pointer): Boolean;\r\n function ExtractAll(const ACollection: IJclPtrCollection): Boolean;\r\n function First: IJclPtrIterator;\r\n function IsEmpty: Boolean;\r\n function Last: IJclPtrIterator;\r\n function Remove(APtr: Pointer): Boolean;\r\n function RemoveAll(const ACollection: IJclPtrCollection): Boolean;\r\n function RetainAll(const ACollection: IJclPtrCollection): Boolean;\r\n function Size: Integer;\r\n {$IFDEF SUPPORTS_FOR_IN}\r\n function GetEnumerator: IJclPtrIterator;\r\n {$ENDIF SUPPORTS_FOR_IN}\r\n { IJclPtrList }\r\n function Delete(Index: Integer): Pointer;\r\n function ExtractIndex(Index: Integer): Pointer;\r\n function GetPointer(Index: Integer): Pointer;\r\n function IndexOf(APtr: Pointer): Integer;\r\n function Insert(Index: Integer; APtr: Pointer): Boolean;\r\n function InsertAll(Index: Integer; const ACollection: IJclPtrCollection): Boolean;\r\n function LastIndexOf(APtr: Pointer): Integer;\r\n procedure SetPointer(Index: Integer; APtr: Pointer);\r\n function SubList(First, Count: Integer): IJclPtrList;\r\n end;\r\n\r\n TJclPtrLinkedListIterator = class(TJclAbstractIterator, IJclPtrIterator, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclIntfCloneable, IJclCloneable)\r\n private\r\n FCursor: TJclPtrLinkedListItem;\r\n FStart: TItrStart;\r\n FOwnList: TJclPtrLinkedList;\r\n FEqualityComparer: IJclPtrEqualityComparer;\r\n public\r\n procedure AssignPropertiesTo(Dest: TJclAbstractIterator); override;\r\n function CreateEmptyIterator: TJclAbstractIterator; override;\r\n public\r\n constructor Create(AOwnList: TJclPtrLinkedList; ACursor: TJclPtrLinkedListItem; AValid: Boolean; AStart: TItrStart);\r\n { IJclPtrIterator }\r\n function Add(APtr: Pointer): Boolean;\r\n procedure Extract;\r\n function GetPointer: Pointer;\r\n function HasNext: Boolean;\r\n function HasPrevious: Boolean;\r\n function Insert(APtr: Pointer): Boolean;\r\n function IteratorEquals(const AIterator: IJclPtrIterator): Boolean;\r\n function Next: Pointer;\r\n function NextIndex: Integer;\r\n function Previous: Pointer;\r\n function PreviousIndex: Integer;\r\n procedure Remove;\r\n procedure Reset;\r\n procedure SetPointer(APtr: Pointer);\r\n {$IFDEF SUPPORTS_FOR_IN}\r\n function MoveNext: Boolean;\r\n property Current: Pointer read GetPointer;\r\n {$ENDIF SUPPORTS_FOR_IN}\r\n end;\r\n\r\n TJclLinkedListItem = class\r\n public\r\n Value: TObject;\r\n Next: TJclLinkedListItem;\r\n Previous: TJclLinkedListItem;\r\n end;\r\n\r\n TJclLinkedList = class(TJclAbstractContainer, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclIntfCloneable, IJclCloneable, IJclBaseContainer, IJclContainer,\r\n IJclFlatContainer, IJclEqualityComparer, IJclObjectOwner,\r\n IJclCollection, IJclList)\r\n protected\r\n function CreateEmptyContainer: TJclAbstractContainerBase; override;\r\n private\r\n FStart: TJclLinkedListItem;\r\n FEnd: TJclLinkedListItem;\r\n protected\r\n procedure AssignDataTo(Dest: TJclAbstractContainerBase); override;\r\n public\r\n constructor Create(const ACollection: IJclCollection; AOwnsObjects: Boolean);\r\n destructor Destroy; override;\r\n { IJclCollection }\r\n function Add(AObject: TObject): Boolean;\r\n function AddAll(const ACollection: IJclCollection): Boolean;\r\n procedure Clear;\r\n function CollectionEquals(const ACollection: IJclCollection): Boolean;\r\n function Contains(AObject: TObject): Boolean;\r\n function ContainsAll(const ACollection: IJclCollection): Boolean;\r\n function Extract(AObject: TObject): Boolean;\r\n function ExtractAll(const ACollection: IJclCollection): Boolean;\r\n function First: IJclIterator;\r\n function IsEmpty: Boolean;\r\n function Last: IJclIterator;\r\n function Remove(AObject: TObject): Boolean;\r\n function RemoveAll(const ACollection: IJclCollection): Boolean;\r\n function RetainAll(const ACollection: IJclCollection): Boolean;\r\n function Size: Integer;\r\n {$IFDEF SUPPORTS_FOR_IN}\r\n function GetEnumerator: IJclIterator;\r\n {$ENDIF SUPPORTS_FOR_IN}\r\n { IJclList }\r\n function Delete(Index: Integer): TObject;\r\n function ExtractIndex(Index: Integer): TObject;\r\n function GetObject(Index: Integer): TObject;\r\n function IndexOf(AObject: TObject): Integer;\r\n function Insert(Index: Integer; AObject: TObject): Boolean;\r\n function InsertAll(Index: Integer; const ACollection: IJclCollection): Boolean;\r\n function LastIndexOf(AObject: TObject): Integer;\r\n procedure SetObject(Index: Integer; AObject: TObject);\r\n function SubList(First, Count: Integer): IJclList;\r\n end;\r\n\r\n TJclLinkedListIterator = class(TJclAbstractIterator, IJclIterator, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclIntfCloneable, IJclCloneable)\r\n private\r\n FCursor: TJclLinkedListItem;\r\n FStart: TItrStart;\r\n FOwnList: TJclLinkedList;\r\n FEqualityComparer: IJclEqualityComparer;\r\n public\r\n procedure AssignPropertiesTo(Dest: TJclAbstractIterator); override;\r\n function CreateEmptyIterator: TJclAbstractIterator; override;\r\n public\r\n constructor Create(AOwnList: TJclLinkedList; ACursor: TJclLinkedListItem; AValid: Boolean; AStart: TItrStart);\r\n { IJclIterator }\r\n function Add(AObject: TObject): Boolean;\r\n procedure Extract;\r\n function GetObject: TObject;\r\n function HasNext: Boolean;\r\n function HasPrevious: Boolean;\r\n function Insert(AObject: TObject): Boolean;\r\n function IteratorEquals(const AIterator: IJclIterator): Boolean;\r\n function Next: TObject;\r\n function NextIndex: Integer;\r\n function Previous: TObject;\r\n function PreviousIndex: Integer;\r\n procedure Remove;\r\n procedure Reset;\r\n procedure SetObject(AObject: TObject);\r\n {$IFDEF SUPPORTS_FOR_IN}\r\n function MoveNext: Boolean;\r\n property Current: TObject read GetObject;\r\n {$ENDIF SUPPORTS_FOR_IN}\r\n end;\r\n\r\n\r\n {$IFDEF SUPPORTS_GENERICS}\r\n //DOM-IGNORE-BEGIN\r\n\r\n TJclLinkedListItem = class\r\n public\r\n Value: T;\r\n Next: TJclLinkedListItem;\r\n Previous: TJclLinkedListItem;\r\n end;\r\n\r\n TJclLinkedListIterator = class;\r\n\r\n TJclLinkedList = class(TJclAbstractContainer, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclIntfCloneable, IJclCloneable, IJclBaseContainer, IJclContainer,\r\n IJclFlatContainer, IJclEqualityComparer,IJclItemOwner,\r\n IJclCollection, IJclList)\r\n protected\r\n type\r\n TLinkedListItem = TJclLinkedListItem;\r\n TLinkedListIterator = TJclLinkedListIterator;\r\n private\r\n FStart: TLinkedListItem;\r\n FEnd: TLinkedListItem;\r\n protected\r\n procedure AssignDataTo(Dest: TJclAbstractContainerBase); override;\r\n public\r\n constructor Create(const ACollection: IJclCollection; AOwnsItems: Boolean);\r\n destructor Destroy; override;\r\n { IJclCollection }\r\n function Add(const AItem: T): Boolean;\r\n function AddAll(const ACollection: IJclCollection): Boolean;\r\n procedure Clear;\r\n function CollectionEquals(const ACollection: IJclCollection): Boolean;\r\n function Contains(const AItem: T): Boolean;\r\n function ContainsAll(const ACollection: IJclCollection): Boolean;\r\n function Extract(const AItem: T): Boolean;\r\n function ExtractAll(const ACollection: IJclCollection): Boolean;\r\n function First: IJclIterator;\r\n function IsEmpty: Boolean;\r\n function Last: IJclIterator;\r\n function Remove(const AItem: T): Boolean;\r\n function RemoveAll(const ACollection: IJclCollection): Boolean;\r\n function RetainAll(const ACollection: IJclCollection): Boolean;\r\n function Size: Integer;\r\n {$IFDEF SUPPORTS_FOR_IN}\r\n function GetEnumerator: IJclIterator;\r\n {$ENDIF SUPPORTS_FOR_IN}\r\n { IJclList }\r\n function Delete(Index: Integer): T;\r\n function ExtractIndex(Index: Integer): T;\r\n function GetItem(Index: Integer): T;\r\n function IndexOf(const AItem: T): Integer;\r\n function Insert(Index: Integer; const AItem: T): Boolean;\r\n function InsertAll(Index: Integer; const ACollection: IJclCollection): Boolean;\r\n function LastIndexOf(const AItem: T): Integer;\r\n procedure SetItem(Index: Integer; const AItem: T);\r\n function SubList(First, Count: Integer): IJclList;\r\n end;\r\n\r\n TJclLinkedListIterator = class(TJclAbstractIterator, IJclIterator, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclIntfCloneable, IJclCloneable)\r\n private\r\n FCursor: TJclLinkedList.TLinkedListItem;\r\n FStart: TItrStart;\r\n FOwnList: IJclList;\r\n FEqualityComparer: IJclEqualityComparer;\r\n public\r\n procedure AssignPropertiesTo(Dest: TJclAbstractIterator); override;\r\n function CreateEmptyIterator: TJclAbstractIterator; override;\r\n public\r\n constructor Create(AOwnList: IJclList; ACursor: TJclLinkedList.TLinkedListItem; AValid: Boolean; AStart: TItrStart);\r\n { IJclIterator }\r\n function Add(const AItem: T): Boolean;\r\n procedure Extract;\r\n function GetItem: T;\r\n function HasNext: Boolean;\r\n function HasPrevious: Boolean;\r\n function Insert(const AItem: T): Boolean;\r\n function IteratorEquals(const AIterator: IJclIterator): Boolean;\r\n function Next: T;\r\n function NextIndex: Integer;\r\n function Previous: T;\r\n function PreviousIndex: Integer;\r\n procedure Remove;\r\n procedure Reset;\r\n procedure SetItem(const AItem: T);\r\n {$IFDEF SUPPORTS_FOR_IN}\r\n function MoveNext: Boolean;\r\n property Current: T read GetItem;\r\n {$ENDIF SUPPORTS_FOR_IN}\r\n end;\r\n\r\n // E = External helper to compare items\r\n // GetHashCode is never called\r\n TJclLinkedListE = class(TJclLinkedList, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclIntfCloneable, IJclCloneable, IJclBaseContainer, IJclContainer, IJclCollection, IJclList, IJclEqualityComparer,\r\n IJclItemOwner)\r\n private\r\n FEqualityComparer: IJclEqualityComparer;\r\n protected\r\n procedure AssignPropertiesTo(Dest: TJclAbstractContainerBase); override;\r\n function CreateEmptyContainer: TJclAbstractContainerBase; override;\r\n public\r\n constructor Create(const AEqualityComparer: IJclEqualityComparer; const ACollection: IJclCollection;\r\n AOwnsItems: Boolean);\r\n { IJclEqualityComparer }\r\n function ItemsEqual(const A, B: T): Boolean; override;\r\n property EqualityComparer: IJclEqualityComparer read FEqualityComparer write FEqualityComparer;\r\n end;\r\n\r\n // F = Function to compare items for equality\r\n TJclLinkedListF = class(TJclLinkedList, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclIntfCloneable, IJclCloneable, IJclBaseContainer, IJclContainer, IJclCollection, IJclList, IJclEqualityComparer,\r\n IJclItemOwner)\r\n protected\r\n function CreateEmptyContainer: TJclAbstractContainerBase; override;\r\n public\r\n constructor Create(const AEqualityCompare: TEqualityCompare; const ACollection: IJclCollection;\r\n AOwnsItems: Boolean);\r\n end;\r\n\r\n // I = Items can compare themselves to an other\r\n TJclLinkedListI> = class(TJclLinkedList, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclIntfCloneable, IJclCloneable, IJclBaseContainer, IJclContainer, IJclCollection, IJclList, IJclEqualityComparer,\r\n IJclItemOwner)\r\n protected\r\n function CreateEmptyContainer: TJclAbstractContainerBase; override;\r\n public\r\n { IJclEqualityComparer }\r\n function ItemsEqual(const A, B: T): Boolean; override;\r\n end;\r\n\r\n //DOM-IGNORE-END\r\n {$ENDIF SUPPORTS_GENERICS}\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jcl.svn.sourceforge.net/svnroot/jcl/tags/JCL-2.4-Build4571/jcl/source/common/JclLinkedLists.pas $';\r\n Revision: '$Revision: 3739 $';\r\n Date: '$Date: 2012-02-21 18:37:18 +0100 (mar. 21 févr. 2012) $';\r\n LogPath: 'JCL\\source\\common';\r\n Extra: '';\r\n Data: nil\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n {$IFDEF HAS_UNITSCOPE}\r\n System.SysUtils;\r\n {$ELSE ~HAS_UNITSCOPE}\r\n SysUtils;\r\n {$ENDIF ~HAS_UNITSCOPE}\r\n\r\n//=== { TJclIntfLinkedList } ==================================================\r\n\r\nconstructor TJclIntfLinkedList.Create(const ACollection: IJclIntfCollection);\r\nbegin\r\n inherited Create();\r\n FStart := nil;\r\n FEnd := nil;\r\n if ACollection <> nil then\r\n AddAll(ACollection);\r\nend;\r\n\r\ndestructor TJclIntfLinkedList.Destroy;\r\nbegin\r\n FReadOnly := False;\r\n Clear;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJclIntfLinkedList.Add(const AInterface: IInterface): Boolean;\r\nvar\r\n NewItem: TJclIntfLinkedListItem;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := FAllowDefaultElements or not ItemsEqual(AInterface, nil);\r\n if Result then\r\n begin\r\n if FDuplicates <> dupAccept then\r\n begin\r\n NewItem := FStart;\r\n while NewItem <> nil do\r\n begin\r\n if ItemsEqual(AInterface, NewItem.Value) then\r\n begin\r\n Result := CheckDuplicate;\r\n Break;\r\n end;\r\n NewItem := NewItem.Next;\r\n end;\r\n end;\r\n if Result then\r\n begin\r\n NewItem := TJclIntfLinkedListItem.Create;\r\n NewItem.Value := AInterface;\r\n if FStart <> nil then\r\n begin\r\n NewItem.Next := nil;\r\n NewItem.Previous := FEnd;\r\n FEnd.Next := NewItem;\r\n FEnd := NewItem;\r\n end\r\n else\r\n begin\r\n FStart := NewItem;\r\n FEnd := NewItem;\r\n end;\r\n Inc(FSize);\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfLinkedList.AddAll(const ACollection: IJclIntfCollection): Boolean;\r\nvar\r\n It: IJclIntfIterator;\r\n Item: IInterface;\r\n AddItem: Boolean;\r\n NewItem: TJclIntfLinkedListItem;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n begin\r\n Item := It.Next;\r\n AddItem := FAllowDefaultElements or not ItemsEqual(Item, nil);\r\n if AddItem then\r\n begin\r\n if FDuplicates <> dupAccept then\r\n begin\r\n NewItem := FStart;\r\n while NewItem <> nil do\r\n begin\r\n if ItemsEqual(Item, NewItem.Value) then\r\n begin\r\n AddItem := CheckDuplicate;\r\n Break;\r\n end;\r\n NewItem := NewItem.Next;\r\n end;\r\n end;\r\n if AddItem then\r\n begin\r\n NewItem := TJclIntfLinkedListItem.Create;\r\n NewItem.Value := Item;\r\n if FStart <> nil then\r\n begin\r\n NewItem.Next := nil;\r\n NewItem.Previous := FEnd;\r\n FEnd.Next := NewItem;\r\n FEnd := NewItem;\r\n end\r\n else\r\n begin\r\n FStart := NewItem;\r\n FEnd := NewItem;\r\n end;\r\n Inc(FSize);\r\n end;\r\n end;\r\n Result := AddItem and Result;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclIntfLinkedList.AssignDataTo(Dest: TJclAbstractContainerBase);\r\nvar\r\n ACollection: IJclIntfCollection;\r\nbegin\r\n inherited AssignDataTo(Dest);\r\n if Supports(IInterface(Dest), IJclIntfCollection, ACollection) then\r\n begin\r\n ACollection.Clear;\r\n ACollection.AddAll(Self);\r\n end;\r\nend;\r\n\r\nprocedure TJclIntfLinkedList.Clear;\r\nvar\r\n Old, Current: TJclIntfLinkedListItem;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Current := FStart;\r\n while Current <> nil do\r\n begin\r\n FreeObject(Current.Value);\r\n Old := Current;\r\n Current := Current.Next;\r\n Old.Free;\r\n end;\r\n FSize := 0;\r\n\r\n //Daniele Teti 27/12/2004\r\n FStart := nil;\r\n FEnd := nil;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfLinkedList.CollectionEquals(const ACollection: IJclIntfCollection): Boolean;\r\nvar\r\n It, ItSelf: IJclIntfIterator;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n if FSize <> ACollection.Size then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n ItSelf := First;\r\n while ItSelf.HasNext and It.HasNext do\r\n if not ItemsEqual(ItSelf.Next, It.Next) then\r\n begin\r\n Result := False;\r\n Break;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfLinkedList.Contains(const AInterface: IInterface): Boolean;\r\nvar\r\n Current: TJclIntfLinkedListItem;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n Current := FStart;\r\n while Current <> nil do\r\n begin\r\n if ItemsEqual(Current.Value, AInterface) then\r\n begin\r\n Result := True;\r\n Break;\r\n end;\r\n Current := Current.Next;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfLinkedList.ContainsAll(const ACollection: IJclIntfCollection): Boolean;\r\nvar\r\n It: IJclIntfIterator;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n while Result and It.HasNext do\r\n Result := Contains(It.Next);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfLinkedList.Delete(Index: Integer): IInterface;\r\nvar\r\n Current: TJclIntfLinkedListItem;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := nil;\r\n if (Index >= 0) and (Index < FSize) then\r\n begin\r\n Current := FStart;\r\n while Current <> nil do\r\n begin\r\n if Index = 0 then\r\n begin\r\n if Current.Previous <> nil then\r\n Current.Previous.Next := Current.Next\r\n else\r\n FStart := Current.Next;\r\n if Current.Next <> nil then\r\n Current.Next.Previous := Current.Previous\r\n else\r\n FEnd := Current.Previous;\r\n Result := FreeObject(Current.Value);\r\n Current.Free;\r\n Dec(FSize);\r\n Break;\r\n end;\r\n Dec(Index);\r\n Current := Current.Next;\r\n end;\r\n end\r\n else\r\n raise EJclOutOfBoundsError.Create;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfLinkedList.Extract(const AInterface: IInterface): Boolean;\r\nvar\r\n Current: TJclIntfLinkedListItem;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n Current := FStart;\r\n while Current <> nil do\r\n begin\r\n if ItemsEqual(Current.Value, AInterface) then\r\n begin\r\n if Current.Previous <> nil then\r\n Current.Previous.Next := Current.Next\r\n else\r\n FStart := Current.Next;\r\n if Current.Next <> nil then\r\n Current.Next.Previous := Current.Previous\r\n else\r\n FEnd := Current.Previous;\r\n Current.Value := nil;\r\n Current.Free;\r\n Dec(FSize);\r\n Result := True;\r\n if FRemoveSingleElement then\r\n Break;\r\n end;\r\n Current := Current.Next;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfLinkedList.ExtractAll(const ACollection: IJclIntfCollection): Boolean;\r\nvar\r\n It: IJclIntfIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := True;\r\n if ACollection = nil then\r\n Exit;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n Result := Extract(It.Next) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfLinkedList.ExtractIndex(Index: Integer): IInterface;\r\nvar\r\n Current: TJclIntfLinkedListItem;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := nil;\r\n if (Index >= 0) and (Index < FSize) then\r\n begin\r\n Current := FStart;\r\n while Current <> nil do\r\n begin\r\n if Index = 0 then\r\n begin\r\n if Current.Previous <> nil then\r\n Current.Previous.Next := Current.Next\r\n else\r\n FStart := Current.Next;\r\n if Current.Next <> nil then\r\n Current.Next.Previous := Current.Previous\r\n else\r\n FEnd := Current.Previous;\r\n Result := Current.Value;\r\n Current.Free;\r\n Dec(FSize);\r\n Break;\r\n end;\r\n Dec(Index);\r\n Current := Current.Next;\r\n end;\r\n end\r\n else\r\n raise EJclOutOfBoundsError.Create;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfLinkedList.First: IJclIntfIterator;\r\nbegin\r\n Result := TJclIntfLinkedListIterator.Create(Self, FStart, False, isFirst);\r\nend;\r\n\r\n{$IFDEF SUPPORTS_FOR_IN}\r\nfunction TJclIntfLinkedList.GetEnumerator: IJclIntfIterator;\r\nbegin\r\n Result := TJclIntfLinkedListIterator.Create(Self, FStart, False, isFirst);\r\nend;\r\n{$ENDIF SUPPORTS_FOR_IN}\r\n\r\nfunction TJclIntfLinkedList.GetObject(Index: Integer): IInterface;\r\nvar\r\n Current: TJclIntfLinkedListItem;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := nil;\r\n Current := FStart;\r\n while (Current <> nil) and (Index > 0) do\r\n begin\r\n Current := Current.Next;\r\n Dec(Index);\r\n end;\r\n if Current <> nil then\r\n Result := Current.Value\r\n else\r\n if not FReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfLinkedList.IndexOf(const AInterface: IInterface): Integer;\r\nvar\r\n Current: TJclIntfLinkedListItem;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Current := FStart;\r\n Result := 0;\r\n while (Current <> nil) and not ItemsEqual(Current.Value, AInterface) do\r\n begin\r\n Inc(Result);\r\n Current := Current.Next;\r\n end;\r\n if Current = nil then\r\n Result := -1;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfLinkedList.Insert(Index: Integer; const AInterface: IInterface): Boolean;\r\nvar\r\n Current, NewItem: TJclIntfLinkedListItem;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := FAllowDefaultElements or not ItemsEqual(AInterface, nil);\r\n if (Index < 0) or (Index > FSize) then\r\n raise EJclOutOfBoundsError.Create;\r\n if Result then\r\n begin\r\n if FDuplicates <> dupAccept then\r\n begin\r\n Current := FStart;\r\n while Current <> nil do\r\n begin\r\n if ItemsEqual(AInterface, Current.Value) then\r\n begin\r\n Result := CheckDuplicate;\r\n Break;\r\n end;\r\n Current := Current.Next;\r\n end;\r\n end;\r\n if Result then\r\n begin\r\n NewItem := TJclIntfLinkedListItem.Create;\r\n NewItem.Value := AInterface;\r\n if Index = 0 then\r\n begin\r\n NewItem.Next := FStart;\r\n if FStart <> nil then\r\n FStart.Previous := NewItem;\r\n FStart := NewItem;\r\n if FSize = 0 then\r\n FEnd := NewItem;\r\n Inc(FSize);\r\n end\r\n else\r\n if Index = FSize then\r\n begin\r\n NewItem.Previous := FEnd;\r\n FEnd.Next := NewItem;\r\n FEnd := NewItem;\r\n Inc(FSize);\r\n end\r\n else\r\n begin\r\n Current := FStart;\r\n while (Current <> nil) and (Index > 0) do\r\n begin\r\n Current := Current.Next;\r\n Dec(Index);\r\n end;\r\n if Current <> nil then\r\n begin\r\n NewItem.Next := Current;\r\n NewItem.Previous := Current.Previous;\r\n if Current.Previous <> nil then\r\n Current.Previous.Next := NewItem;\r\n Current.Previous := NewItem;\r\n Inc(FSize);\r\n end;\r\n end;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfLinkedList.InsertAll(Index: Integer; const ACollection: IJclIntfCollection): Boolean;\r\nvar\r\n It: IJclIntfIterator;\r\n Current, NewItem, Test: TJclIntfLinkedListItem;\r\n AddItem: Boolean;\r\n Item: IInterface;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if (Index < 0) or (Index > FSize) then\r\n raise EJclOutOfBoundsError.Create;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n if Index = 0 then\r\n begin\r\n It := ACollection.Last;\r\n while It.HasPrevious do\r\n begin\r\n Item := It.Previous;\r\n AddItem := FAllowDefaultElements or not ItemsEqual(Item, nil);\r\n if AddItem then\r\n begin\r\n if FDuplicates <> dupAccept then\r\n begin\r\n Test := FStart;\r\n while Test <> nil do\r\n begin\r\n if ItemsEqual(Item, Test.Value) then\r\n begin\r\n Result := CheckDuplicate;\r\n Break;\r\n end;\r\n Test := Test.Next;\r\n end;\r\n end;\r\n if AddItem then\r\n begin\r\n NewItem := TJclIntfLinkedListItem.Create;\r\n NewItem.Value := Item;\r\n NewItem.Next := FStart;\r\n if FStart <> nil then\r\n FStart.Previous := NewItem;\r\n FStart := NewItem;\r\n if FSize = 0 then\r\n FEnd := NewItem;\r\n Inc(FSize);\r\n end;\r\n end;\r\n Result := Result and AddItem;\r\n end;\r\n end\r\n else\r\n if Index = Size then\r\n begin\r\n It := ACollection.First;\r\n while It.HasNext do\r\n begin\r\n Item := It.Next;\r\n AddItem := FAllowDefaultElements or not ItemsEqual(Item, nil);\r\n if AddItem then\r\n begin\r\n if FDuplicates <> dupAccept then\r\n begin\r\n Test := FStart;\r\n while Test <> nil do\r\n begin\r\n if ItemsEqual(Item, Test.Value) then\r\n begin\r\n Result := CheckDuplicate;\r\n Break;\r\n end;\r\n Test := Test.Next;\r\n end;\r\n end;\r\n if AddItem then\r\n begin\r\n NewItem := TJclIntfLinkedListItem.Create;\r\n NewItem.Value := Item;\r\n NewItem.Previous := FEnd;\r\n if FEnd <> nil then\r\n FEnd.Next := NewItem;\r\n FEnd := NewItem;\r\n Inc(FSize);\r\n end;\r\n end;\r\n Result := Result and AddItem;\r\n end;\r\n end\r\n else\r\n begin\r\n Current := FStart;\r\n while (Current <> nil) and (Index > 0) do\r\n begin\r\n Current := Current.Next;\r\n Dec(Index);\r\n end;\r\n if Current <> nil then\r\n begin\r\n It := ACollection.First;\r\n while It.HasNext do\r\n begin\r\n Item := It.Next;\r\n AddItem := FAllowDefaultElements or not ItemsEqual(Item, nil);\r\n if AddItem then\r\n begin\r\n if FDuplicates <> dupAccept then\r\n begin\r\n Test := FStart;\r\n while Test <> nil do\r\n begin\r\n if ItemsEqual(Item, Test.Value) then\r\n begin\r\n Result := CheckDuplicate;\r\n Break;\r\n end;\r\n Test := Test.Next;\r\n end;\r\n end;\r\n if AddItem then\r\n begin\r\n NewItem := TJclIntfLinkedListItem.Create;\r\n NewItem.Value := Item;\r\n NewItem.Next := Current;\r\n NewItem.Previous := Current.Previous;\r\n if Current.Previous <> nil then\r\n Current.Previous.Next := NewItem;\r\n Current.Previous := NewItem;\r\n Inc(FSize);\r\n end;\r\n end;\r\n Result := Result and AddItem;\r\n end;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfLinkedList.IsEmpty: Boolean;\r\nbegin\r\n Result := FSize = 0;\r\nend;\r\n\r\nfunction TJclIntfLinkedList.Last: IJclIntfIterator;\r\nbegin\r\n Result := TJclIntfLinkedListIterator.Create(Self, FEnd, False, isLast);\r\nend;\r\n\r\nfunction TJclIntfLinkedList.LastIndexOf(const AInterface: IInterface): Integer;\r\nvar\r\n Current: TJclIntfLinkedListItem;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := -1;\r\n if FEnd <> nil then\r\n begin\r\n Current := FEnd;\r\n Result := FSize - 1;\r\n while (Current <> nil) and not ItemsEqual(Current.Value, AInterface) do\r\n begin\r\n Dec(Result);\r\n Current := Current.Previous;\r\n end;\r\n if Current = nil then\r\n Result := -1;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfLinkedList.Remove(const AInterface: IInterface): Boolean;\r\nvar\r\n Extracted: IInterface;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := Extract(AInterface);\r\n if Result then\r\n begin\r\n Extracted := AInterface;\r\n FreeObject(Extracted);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfLinkedList.RemoveAll(const ACollection: IJclIntfCollection): Boolean;\r\nvar\r\n It: IJclIntfIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := True;\r\n if ACollection = nil then\r\n Exit;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n Result := Remove(It.Next) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfLinkedList.RetainAll(const ACollection: IJclIntfCollection): Boolean;\r\nvar\r\n It: IJclIntfIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := First;\r\n while It.HasNext do\r\n if not ACollection.Contains(It.Next) then\r\n It.Remove;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclIntfLinkedList.SetObject(Index: Integer; const AInterface: IInterface);\r\nvar\r\n Current: TJclIntfLinkedListItem;\r\n ReplaceItem: Boolean;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n ReplaceItem := FAllowDefaultElements or not ItemsEqual(AInterface, nil);\r\n if ReplaceItem then\r\n begin\r\n if FDuplicates <> dupAccept then\r\n begin\r\n Current := FStart;\r\n while Current <> nil do\r\n begin\r\n if ItemsEqual(AInterface, Current.Value) then\r\n begin\r\n ReplaceItem := CheckDuplicate;\r\n Break;\r\n end;\r\n Current := Current.Next;\r\n end;\r\n end;\r\n if ReplaceItem then\r\n begin\r\n Current := FStart;\r\n while Current <> nil do\r\n begin\r\n if Index = 0 then\r\n begin\r\n FreeObject(Current.Value);\r\n Current.Value := AInterface;\r\n Break;\r\n end;\r\n Dec(Index);\r\n Current := Current.Next;\r\n end;\r\n end;\r\n end;\r\n if not ReplaceItem then\r\n Delete(Index);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfLinkedList.Size: Integer;\r\nbegin\r\n Result := FSize;\r\nend;\r\n\r\nfunction TJclIntfLinkedList.SubList(First, Count: Integer): IJclIntfList;\r\nvar\r\n Current: TJclIntfLinkedListItem;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := CreateEmptyContainer as IJclIntfList;\r\n Current := FStart;\r\n while (Current <> nil) and (First > 0) do\r\n begin\r\n Dec(First);\r\n Current := Current.Next;\r\n end;\r\n while (Current <> nil) and (Count > 0) do\r\n begin\r\n Result.Add(Current.Value);\r\n Dec(Count);\r\n Current := Current.Next;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfLinkedList.CreateEmptyContainer: TJclAbstractContainerBase;\r\nbegin\r\n Result := TJclIntfLinkedList.Create(nil);\r\n AssignPropertiesTo(Result);\r\nend;\r\n\r\n//=== { TJclIntfLinkedListIterator } ============================================================\r\n\r\nconstructor TJclIntfLinkedListIterator.Create(AOwnList: TJclIntfLinkedList; ACursor: TJclIntfLinkedListItem; AValid: Boolean; AStart: TItrStart);\r\nbegin\r\n inherited Create(AValid);\r\n FCursor := ACursor;\r\n FOwnList := AOwnList;\r\n FStart := AStart;\r\n FEqualityComparer := AOwnList as IJclIntfEqualityComparer;\r\nend;\r\n\r\nfunction TJclIntfLinkedListIterator.Add(const AInterface: IInterface): Boolean;\r\nbegin\r\n Result := FOwnList.Add(AInterface);\r\nend;\r\n\r\nprocedure TJclIntfLinkedListIterator.AssignPropertiesTo(Dest: TJclAbstractIterator);\r\nvar\r\n ADest: TJclIntfLinkedListIterator;\r\nbegin\r\n inherited AssignPropertiesTo(Dest);\r\n if Dest is TJclIntfLinkedListIterator then\r\n begin\r\n ADest := TJclIntfLinkedListIterator(Dest);\r\n ADest.FCursor := FCursor;\r\n ADest.FOwnList := FOwnList;\r\n ADest.FEqualityComparer := FEqualityComparer;\r\n ADest.FStart := FStart;\r\n end;\r\nend;\r\n\r\nfunction TJclIntfLinkedListIterator.CreateEmptyIterator: TJclAbstractIterator;\r\nbegin\r\n Result := TJclIntfLinkedListIterator.Create(FOwnList, FCursor, Valid, FStart);\r\nend;\r\n\r\nprocedure TJclIntfLinkedListIterator.Extract;\r\nvar\r\n OldCursor: TJclIntfLinkedListItem;\r\nbegin\r\n if FOwnList.ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n FOwnList.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n CheckValid;\r\n Valid := False;\r\n if FCursor <> nil then\r\n begin\r\n if FCursor.Next <> nil then\r\n FCursor.Next.Previous := FCursor.Previous;\r\n if FCursor.Previous <> nil then\r\n FCursor.Previous.Next := FCursor.Next;\r\n OldCursor := FCursor;\r\n FCursor := FCursor.Next;\r\n OldCursor.Free;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnList.WriteUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfLinkedListIterator.GetObject: IInterface;\r\nbegin\r\n CheckValid;\r\n Result := nil;\r\n if FCursor <> nil then\r\n Result := FCursor.Value\r\n else\r\n if not FOwnList.ReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\nend;\r\n\r\nfunction TJclIntfLinkedListIterator.HasNext: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnList.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Valid then\r\n Result := (FCursor <> nil) and (FCursor.Next <> nil)\r\n else\r\n Result := FCursor <> nil;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnList.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfLinkedListIterator.HasPrevious: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnList.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Valid then\r\n Result := (FCursor <> nil) and (FCursor.Previous <> nil)\r\n else\r\n Result := FCursor <> nil;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnList.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfLinkedListIterator.Insert(const AInterface: IInterface): Boolean;\r\nvar\r\n NewCursor: TJclIntfLinkedListItem;\r\nbegin\r\n if FOwnList.ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n FOwnList.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n CheckValid;\r\n Result := FCursor <> nil;\r\n if Result then\r\n begin\r\n Result := FOwnList.AllowDefaultElements or not FEqualityComparer.ItemsEqual(AInterface, nil);\r\n if Result then\r\n begin\r\n case FOwnList.Duplicates of\r\n dupIgnore:\r\n Result := not FOwnList.Contains(AInterface);\r\n dupAccept:\r\n Result := True;\r\n dupError:\r\n begin\r\n Result := FOwnList.Contains(AInterface);\r\n if not Result then\r\n raise EJclDuplicateElementError.Create;\r\n end;\r\n end;\r\n if Result then\r\n begin\r\n NewCursor := TJclIntfLinkedListItem.Create;\r\n NewCursor.Value := AInterface;\r\n NewCursor.Next := FCursor;\r\n NewCursor.Previous := FCursor.Previous;\r\n if FCursor.Previous <> nil then\r\n FCursor.Previous.Next := NewCursor;\r\n FCursor.Previous := NewCursor;\r\n FCursor := NewCursor;\r\n end;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnList.WriteUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfLinkedListIterator.IteratorEquals(const AIterator: IJclIntfIterator): Boolean;\r\nvar\r\n Obj: TObject;\r\n ItrObj: TJclIntfLinkedListIterator;\r\nbegin\r\n Result := False;\r\n if AIterator = nil then\r\n Exit;\r\n Obj := AIterator.GetIteratorReference;\r\n if Obj is TJclIntfLinkedListIterator then\r\n begin\r\n ItrObj := TJclIntfLinkedListIterator(Obj);\r\n Result := (FOwnList = ItrObj.FOwnList) and (FCursor = ItrObj.FCursor) and (Valid = ItrObj.Valid);\r\n end;\r\nend;\r\n\r\n{$IFDEF SUPPORTS_FOR_IN}\r\nfunction TJclIntfLinkedListIterator.MoveNext: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnList.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Valid and (FCursor <> nil) then\r\n FCursor := FCursor.Next\r\n else\r\n Valid := True;\r\n Result := FCursor <> nil;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnList.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n{$ENDIF SUPPORTS_FOR_IN}\r\n\r\nfunction TJclIntfLinkedListIterator.Next: IInterface;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnList.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Valid and (FCursor <> nil) then\r\n FCursor := FCursor.Next\r\n else\r\n Valid := True;\r\n if FCursor <> nil then\r\n Result := FCursor.Value\r\n else\r\n Result := nil;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnList.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfLinkedListIterator.NextIndex: Integer;\r\nbegin\r\n // No Index\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nfunction TJclIntfLinkedListIterator.Previous: IInterface;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnList.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Valid and (FCursor <> nil) then\r\n FCursor := FCursor.Previous\r\n else\r\n Valid := True;\r\n if FCursor <> nil then\r\n Result := FCursor.Value\r\n else\r\n Result := nil;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnList.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfLinkedListIterator.PreviousIndex: Integer;\r\nbegin\r\n // No Index\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nprocedure TJclIntfLinkedListIterator.Remove;\r\nvar\r\n OldCursor: TJclIntfLinkedListItem;\r\nbegin\r\n if FOwnList.ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n FOwnList.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n CheckValid;\r\n Valid := False;\r\n if FCursor <> nil then\r\n begin\r\n FCursor.Value := nil;\r\n if FCursor.Next <> nil then\r\n FCursor.Next.Previous := FCursor.Previous;\r\n if FCursor.Previous <> nil then\r\n FCursor.Previous.Next := FCursor.Next;\r\n OldCursor := FCursor;\r\n FCursor := FCursor.Next;\r\n OldCursor.Free;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnList.WriteUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclIntfLinkedListIterator.Reset;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnList.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Valid := False;\r\n case FStart of\r\n isFirst:\r\n begin\r\n while (FCursor <> nil) and (FCursor.Previous <> nil) do\r\n FCursor := FCursor.Previous;\r\n end;\r\n isLast:\r\n begin\r\n while (FCursor <> nil) and (FCursor.Next <> nil) do\r\n FCursor := FCursor.Next;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnList.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclIntfLinkedListIterator.SetObject(const AInterface: IInterface);\r\nbegin\r\n if FOwnList.ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n FOwnList.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n CheckValid;\r\n FCursor.Value := nil;\r\n FCursor.Value := AInterface;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnList.WriteUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\n//=== { TJclAnsiStrLinkedList } ==================================================\r\n\r\nconstructor TJclAnsiStrLinkedList.Create(const ACollection: IJclAnsiStrCollection);\r\nbegin\r\n inherited Create();\r\n FStart := nil;\r\n FEnd := nil;\r\n if ACollection <> nil then\r\n AddAll(ACollection);\r\nend;\r\n\r\ndestructor TJclAnsiStrLinkedList.Destroy;\r\nbegin\r\n FReadOnly := False;\r\n Clear;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJclAnsiStrLinkedList.Add(const AString: AnsiString): Boolean;\r\nvar\r\n NewItem: TJclAnsiStrLinkedListItem;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := FAllowDefaultElements or not ItemsEqual(AString, '');\r\n if Result then\r\n begin\r\n if FDuplicates <> dupAccept then\r\n begin\r\n NewItem := FStart;\r\n while NewItem <> nil do\r\n begin\r\n if ItemsEqual(AString, NewItem.Value) then\r\n begin\r\n Result := CheckDuplicate;\r\n Break;\r\n end;\r\n NewItem := NewItem.Next;\r\n end;\r\n end;\r\n if Result then\r\n begin\r\n NewItem := TJclAnsiStrLinkedListItem.Create;\r\n NewItem.Value := AString;\r\n if FStart <> nil then\r\n begin\r\n NewItem.Next := nil;\r\n NewItem.Previous := FEnd;\r\n FEnd.Next := NewItem;\r\n FEnd := NewItem;\r\n end\r\n else\r\n begin\r\n FStart := NewItem;\r\n FEnd := NewItem;\r\n end;\r\n Inc(FSize);\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclAnsiStrLinkedList.AddAll(const ACollection: IJclAnsiStrCollection): Boolean;\r\nvar\r\n It: IJclAnsiStrIterator;\r\n Item: AnsiString;\r\n AddItem: Boolean;\r\n NewItem: TJclAnsiStrLinkedListItem;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n begin\r\n Item := It.Next;\r\n AddItem := FAllowDefaultElements or not ItemsEqual(Item, '');\r\n if AddItem then\r\n begin\r\n if FDuplicates <> dupAccept then\r\n begin\r\n NewItem := FStart;\r\n while NewItem <> nil do\r\n begin\r\n if ItemsEqual(Item, NewItem.Value) then\r\n begin\r\n AddItem := CheckDuplicate;\r\n Break;\r\n end;\r\n NewItem := NewItem.Next;\r\n end;\r\n end;\r\n if AddItem then\r\n begin\r\n NewItem := TJclAnsiStrLinkedListItem.Create;\r\n NewItem.Value := Item;\r\n if FStart <> nil then\r\n begin\r\n NewItem.Next := nil;\r\n NewItem.Previous := FEnd;\r\n FEnd.Next := NewItem;\r\n FEnd := NewItem;\r\n end\r\n else\r\n begin\r\n FStart := NewItem;\r\n FEnd := NewItem;\r\n end;\r\n Inc(FSize);\r\n end;\r\n end;\r\n Result := AddItem and Result;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclAnsiStrLinkedList.AssignDataTo(Dest: TJclAbstractContainerBase);\r\nvar\r\n ACollection: IJclAnsiStrCollection;\r\nbegin\r\n inherited AssignDataTo(Dest);\r\n if Supports(IInterface(Dest), IJclAnsiStrCollection, ACollection) then\r\n begin\r\n ACollection.Clear;\r\n ACollection.AddAll(Self);\r\n end;\r\nend;\r\n\r\nprocedure TJclAnsiStrLinkedList.Clear;\r\nvar\r\n Old, Current: TJclAnsiStrLinkedListItem;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Current := FStart;\r\n while Current <> nil do\r\n begin\r\n FreeString(Current.Value);\r\n Old := Current;\r\n Current := Current.Next;\r\n Old.Free;\r\n end;\r\n FSize := 0;\r\n\r\n //Daniele Teti 27/12/2004\r\n FStart := nil;\r\n FEnd := nil;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclAnsiStrLinkedList.CollectionEquals(const ACollection: IJclAnsiStrCollection): Boolean;\r\nvar\r\n It, ItSelf: IJclAnsiStrIterator;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n if FSize <> ACollection.Size then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n ItSelf := First;\r\n while ItSelf.HasNext and It.HasNext do\r\n if not ItemsEqual(ItSelf.Next, It.Next) then\r\n begin\r\n Result := False;\r\n Break;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclAnsiStrLinkedList.Contains(const AString: AnsiString): Boolean;\r\nvar\r\n Current: TJclAnsiStrLinkedListItem;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n Current := FStart;\r\n while Current <> nil do\r\n begin\r\n if ItemsEqual(Current.Value, AString) then\r\n begin\r\n Result := True;\r\n Break;\r\n end;\r\n Current := Current.Next;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclAnsiStrLinkedList.ContainsAll(const ACollection: IJclAnsiStrCollection): Boolean;\r\nvar\r\n It: IJclAnsiStrIterator;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n while Result and It.HasNext do\r\n Result := Contains(It.Next);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclAnsiStrLinkedList.Delete(Index: Integer): AnsiString;\r\nvar\r\n Current: TJclAnsiStrLinkedListItem;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := '';\r\n if (Index >= 0) and (Index < FSize) then\r\n begin\r\n Current := FStart;\r\n while Current <> nil do\r\n begin\r\n if Index = 0 then\r\n begin\r\n if Current.Previous <> nil then\r\n Current.Previous.Next := Current.Next\r\n else\r\n FStart := Current.Next;\r\n if Current.Next <> nil then\r\n Current.Next.Previous := Current.Previous\r\n else\r\n FEnd := Current.Previous;\r\n Result := FreeString(Current.Value);\r\n Current.Free;\r\n Dec(FSize);\r\n Break;\r\n end;\r\n Dec(Index);\r\n Current := Current.Next;\r\n end;\r\n end\r\n else\r\n raise EJclOutOfBoundsError.Create;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclAnsiStrLinkedList.Extract(const AString: AnsiString): Boolean;\r\nvar\r\n Current: TJclAnsiStrLinkedListItem;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n Current := FStart;\r\n while Current <> nil do\r\n begin\r\n if ItemsEqual(Current.Value, AString) then\r\n begin\r\n if Current.Previous <> nil then\r\n Current.Previous.Next := Current.Next\r\n else\r\n FStart := Current.Next;\r\n if Current.Next <> nil then\r\n Current.Next.Previous := Current.Previous\r\n else\r\n FEnd := Current.Previous;\r\n Current.Value := '';\r\n Current.Free;\r\n Dec(FSize);\r\n Result := True;\r\n if FRemoveSingleElement then\r\n Break;\r\n end;\r\n Current := Current.Next;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclAnsiStrLinkedList.ExtractAll(const ACollection: IJclAnsiStrCollection): Boolean;\r\nvar\r\n It: IJclAnsiStrIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := True;\r\n if ACollection = nil then\r\n Exit;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n Result := Extract(It.Next) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclAnsiStrLinkedList.ExtractIndex(Index: Integer): AnsiString;\r\nvar\r\n Current: TJclAnsiStrLinkedListItem;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := '';\r\n if (Index >= 0) and (Index < FSize) then\r\n begin\r\n Current := FStart;\r\n while Current <> nil do\r\n begin\r\n if Index = 0 then\r\n begin\r\n if Current.Previous <> nil then\r\n Current.Previous.Next := Current.Next\r\n else\r\n FStart := Current.Next;\r\n if Current.Next <> nil then\r\n Current.Next.Previous := Current.Previous\r\n else\r\n FEnd := Current.Previous;\r\n Result := Current.Value;\r\n Current.Free;\r\n Dec(FSize);\r\n Break;\r\n end;\r\n Dec(Index);\r\n Current := Current.Next;\r\n end;\r\n end\r\n else\r\n raise EJclOutOfBoundsError.Create;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclAnsiStrLinkedList.First: IJclAnsiStrIterator;\r\nbegin\r\n Result := TJclAnsiStrLinkedListIterator.Create(Self, FStart, False, isFirst);\r\nend;\r\n\r\n{$IFDEF SUPPORTS_FOR_IN}\r\nfunction TJclAnsiStrLinkedList.GetEnumerator: IJclAnsiStrIterator;\r\nbegin\r\n Result := TJclAnsiStrLinkedListIterator.Create(Self, FStart, False, isFirst);\r\nend;\r\n{$ENDIF SUPPORTS_FOR_IN}\r\n\r\nfunction TJclAnsiStrLinkedList.GetString(Index: Integer): AnsiString;\r\nvar\r\n Current: TJclAnsiStrLinkedListItem;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := '';\r\n Current := FStart;\r\n while (Current <> nil) and (Index > 0) do\r\n begin\r\n Current := Current.Next;\r\n Dec(Index);\r\n end;\r\n if Current <> nil then\r\n Result := Current.Value\r\n else\r\n if not FReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclAnsiStrLinkedList.IndexOf(const AString: AnsiString): Integer;\r\nvar\r\n Current: TJclAnsiStrLinkedListItem;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Current := FStart;\r\n Result := 0;\r\n while (Current <> nil) and not ItemsEqual(Current.Value, AString) do\r\n begin\r\n Inc(Result);\r\n Current := Current.Next;\r\n end;\r\n if Current = nil then\r\n Result := -1;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclAnsiStrLinkedList.Insert(Index: Integer; const AString: AnsiString): Boolean;\r\nvar\r\n Current, NewItem: TJclAnsiStrLinkedListItem;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := FAllowDefaultElements or not ItemsEqual(AString, '');\r\n if (Index < 0) or (Index > FSize) then\r\n raise EJclOutOfBoundsError.Create;\r\n if Result then\r\n begin\r\n if FDuplicates <> dupAccept then\r\n begin\r\n Current := FStart;\r\n while Current <> nil do\r\n begin\r\n if ItemsEqual(AString, Current.Value) then\r\n begin\r\n Result := CheckDuplicate;\r\n Break;\r\n end;\r\n Current := Current.Next;\r\n end;\r\n end;\r\n if Result then\r\n begin\r\n NewItem := TJclAnsiStrLinkedListItem.Create;\r\n NewItem.Value := AString;\r\n if Index = 0 then\r\n begin\r\n NewItem.Next := FStart;\r\n if FStart <> nil then\r\n FStart.Previous := NewItem;\r\n FStart := NewItem;\r\n if FSize = 0 then\r\n FEnd := NewItem;\r\n Inc(FSize);\r\n end\r\n else\r\n if Index = FSize then\r\n begin\r\n NewItem.Previous := FEnd;\r\n FEnd.Next := NewItem;\r\n FEnd := NewItem;\r\n Inc(FSize);\r\n end\r\n else\r\n begin\r\n Current := FStart;\r\n while (Current <> nil) and (Index > 0) do\r\n begin\r\n Current := Current.Next;\r\n Dec(Index);\r\n end;\r\n if Current <> nil then\r\n begin\r\n NewItem.Next := Current;\r\n NewItem.Previous := Current.Previous;\r\n if Current.Previous <> nil then\r\n Current.Previous.Next := NewItem;\r\n Current.Previous := NewItem;\r\n Inc(FSize);\r\n end;\r\n end;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclAnsiStrLinkedList.InsertAll(Index: Integer; const ACollection: IJclAnsiStrCollection): Boolean;\r\nvar\r\n It: IJclAnsiStrIterator;\r\n Current, NewItem, Test: TJclAnsiStrLinkedListItem;\r\n AddItem: Boolean;\r\n Item: AnsiString;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if (Index < 0) or (Index > FSize) then\r\n raise EJclOutOfBoundsError.Create;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n if Index = 0 then\r\n begin\r\n It := ACollection.Last;\r\n while It.HasPrevious do\r\n begin\r\n Item := It.Previous;\r\n AddItem := FAllowDefaultElements or not ItemsEqual(Item, '');\r\n if AddItem then\r\n begin\r\n if FDuplicates <> dupAccept then\r\n begin\r\n Test := FStart;\r\n while Test <> nil do\r\n begin\r\n if ItemsEqual(Item, Test.Value) then\r\n begin\r\n Result := CheckDuplicate;\r\n Break;\r\n end;\r\n Test := Test.Next;\r\n end;\r\n end;\r\n if AddItem then\r\n begin\r\n NewItem := TJclAnsiStrLinkedListItem.Create;\r\n NewItem.Value := Item;\r\n NewItem.Next := FStart;\r\n if FStart <> nil then\r\n FStart.Previous := NewItem;\r\n FStart := NewItem;\r\n if FSize = 0 then\r\n FEnd := NewItem;\r\n Inc(FSize);\r\n end;\r\n end;\r\n Result := Result and AddItem;\r\n end;\r\n end\r\n else\r\n if Index = Size then\r\n begin\r\n It := ACollection.First;\r\n while It.HasNext do\r\n begin\r\n Item := It.Next;\r\n AddItem := FAllowDefaultElements or not ItemsEqual(Item, '');\r\n if AddItem then\r\n begin\r\n if FDuplicates <> dupAccept then\r\n begin\r\n Test := FStart;\r\n while Test <> nil do\r\n begin\r\n if ItemsEqual(Item, Test.Value) then\r\n begin\r\n Result := CheckDuplicate;\r\n Break;\r\n end;\r\n Test := Test.Next;\r\n end;\r\n end;\r\n if AddItem then\r\n begin\r\n NewItem := TJclAnsiStrLinkedListItem.Create;\r\n NewItem.Value := Item;\r\n NewItem.Previous := FEnd;\r\n if FEnd <> nil then\r\n FEnd.Next := NewItem;\r\n FEnd := NewItem;\r\n Inc(FSize);\r\n end;\r\n end;\r\n Result := Result and AddItem;\r\n end;\r\n end\r\n else\r\n begin\r\n Current := FStart;\r\n while (Current <> nil) and (Index > 0) do\r\n begin\r\n Current := Current.Next;\r\n Dec(Index);\r\n end;\r\n if Current <> nil then\r\n begin\r\n It := ACollection.First;\r\n while It.HasNext do\r\n begin\r\n Item := It.Next;\r\n AddItem := FAllowDefaultElements or not ItemsEqual(Item, '');\r\n if AddItem then\r\n begin\r\n if FDuplicates <> dupAccept then\r\n begin\r\n Test := FStart;\r\n while Test <> nil do\r\n begin\r\n if ItemsEqual(Item, Test.Value) then\r\n begin\r\n Result := CheckDuplicate;\r\n Break;\r\n end;\r\n Test := Test.Next;\r\n end;\r\n end;\r\n if AddItem then\r\n begin\r\n NewItem := TJclAnsiStrLinkedListItem.Create;\r\n NewItem.Value := Item;\r\n NewItem.Next := Current;\r\n NewItem.Previous := Current.Previous;\r\n if Current.Previous <> nil then\r\n Current.Previous.Next := NewItem;\r\n Current.Previous := NewItem;\r\n Inc(FSize);\r\n end;\r\n end;\r\n Result := Result and AddItem;\r\n end;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclAnsiStrLinkedList.IsEmpty: Boolean;\r\nbegin\r\n Result := FSize = 0;\r\nend;\r\n\r\nfunction TJclAnsiStrLinkedList.Last: IJclAnsiStrIterator;\r\nbegin\r\n Result := TJclAnsiStrLinkedListIterator.Create(Self, FEnd, False, isLast);\r\nend;\r\n\r\nfunction TJclAnsiStrLinkedList.LastIndexOf(const AString: AnsiString): Integer;\r\nvar\r\n Current: TJclAnsiStrLinkedListItem;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := -1;\r\n if FEnd <> nil then\r\n begin\r\n Current := FEnd;\r\n Result := FSize - 1;\r\n while (Current <> nil) and not ItemsEqual(Current.Value, AString) do\r\n begin\r\n Dec(Result);\r\n Current := Current.Previous;\r\n end;\r\n if Current = nil then\r\n Result := -1;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclAnsiStrLinkedList.Remove(const AString: AnsiString): Boolean;\r\nvar\r\n Extracted: AnsiString;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := Extract(AString);\r\n if Result then\r\n begin\r\n Extracted := AString;\r\n FreeString(Extracted);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclAnsiStrLinkedList.RemoveAll(const ACollection: IJclAnsiStrCollection): Boolean;\r\nvar\r\n It: IJclAnsiStrIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := True;\r\n if ACollection = nil then\r\n Exit;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n Result := Remove(It.Next) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclAnsiStrLinkedList.RetainAll(const ACollection: IJclAnsiStrCollection): Boolean;\r\nvar\r\n It: IJclAnsiStrIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := First;\r\n while It.HasNext do\r\n if not ACollection.Contains(It.Next) then\r\n It.Remove;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclAnsiStrLinkedList.SetString(Index: Integer; const AString: AnsiString);\r\nvar\r\n Current: TJclAnsiStrLinkedListItem;\r\n ReplaceItem: Boolean;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n ReplaceItem := FAllowDefaultElements or not ItemsEqual(AString, '');\r\n if ReplaceItem then\r\n begin\r\n if FDuplicates <> dupAccept then\r\n begin\r\n Current := FStart;\r\n while Current <> nil do\r\n begin\r\n if ItemsEqual(AString, Current.Value) then\r\n begin\r\n ReplaceItem := CheckDuplicate;\r\n Break;\r\n end;\r\n Current := Current.Next;\r\n end;\r\n end;\r\n if ReplaceItem then\r\n begin\r\n Current := FStart;\r\n while Current <> nil do\r\n begin\r\n if Index = 0 then\r\n begin\r\n FreeString(Current.Value);\r\n Current.Value := AString;\r\n Break;\r\n end;\r\n Dec(Index);\r\n Current := Current.Next;\r\n end;\r\n end;\r\n end;\r\n if not ReplaceItem then\r\n Delete(Index);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclAnsiStrLinkedList.Size: Integer;\r\nbegin\r\n Result := FSize;\r\nend;\r\n\r\nfunction TJclAnsiStrLinkedList.SubList(First, Count: Integer): IJclAnsiStrList;\r\nvar\r\n Current: TJclAnsiStrLinkedListItem;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := CreateEmptyContainer as IJclAnsiStrList;\r\n Current := FStart;\r\n while (Current <> nil) and (First > 0) do\r\n begin\r\n Dec(First);\r\n Current := Current.Next;\r\n end;\r\n while (Current <> nil) and (Count > 0) do\r\n begin\r\n Result.Add(Current.Value);\r\n Dec(Count);\r\n Current := Current.Next;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclAnsiStrLinkedList.CreateEmptyContainer: TJclAbstractContainerBase;\r\nbegin\r\n Result := TJclAnsiStrLinkedList.Create(nil);\r\n AssignPropertiesTo(Result);\r\nend;\r\n\r\n//=== { TJclAnsiStrLinkedListIterator } ============================================================\r\n\r\nconstructor TJclAnsiStrLinkedListIterator.Create(AOwnList: TJclAnsiStrLinkedList; ACursor: TJclAnsiStrLinkedListItem; AValid: Boolean; AStart: TItrStart);\r\nbegin\r\n inherited Create(AValid);\r\n FCursor := ACursor;\r\n FOwnList := AOwnList;\r\n FStart := AStart;\r\n FEqualityComparer := AOwnList as IJclAnsiStrEqualityComparer;\r\nend;\r\n\r\nfunction TJclAnsiStrLinkedListIterator.Add(const AString: AnsiString): Boolean;\r\nbegin\r\n Result := FOwnList.Add(AString);\r\nend;\r\n\r\nprocedure TJclAnsiStrLinkedListIterator.AssignPropertiesTo(Dest: TJclAbstractIterator);\r\nvar\r\n ADest: TJclAnsiStrLinkedListIterator;\r\nbegin\r\n inherited AssignPropertiesTo(Dest);\r\n if Dest is TJclAnsiStrLinkedListIterator then\r\n begin\r\n ADest := TJclAnsiStrLinkedListIterator(Dest);\r\n ADest.FCursor := FCursor;\r\n ADest.FOwnList := FOwnList;\r\n ADest.FEqualityComparer := FEqualityComparer;\r\n ADest.FStart := FStart;\r\n end;\r\nend;\r\n\r\nfunction TJclAnsiStrLinkedListIterator.CreateEmptyIterator: TJclAbstractIterator;\r\nbegin\r\n Result := TJclAnsiStrLinkedListIterator.Create(FOwnList, FCursor, Valid, FStart);\r\nend;\r\n\r\nprocedure TJclAnsiStrLinkedListIterator.Extract;\r\nvar\r\n OldCursor: TJclAnsiStrLinkedListItem;\r\nbegin\r\n if FOwnList.ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n FOwnList.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n CheckValid;\r\n Valid := False;\r\n if FCursor <> nil then\r\n begin\r\n if FCursor.Next <> nil then\r\n FCursor.Next.Previous := FCursor.Previous;\r\n if FCursor.Previous <> nil then\r\n FCursor.Previous.Next := FCursor.Next;\r\n OldCursor := FCursor;\r\n FCursor := FCursor.Next;\r\n OldCursor.Free;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnList.WriteUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclAnsiStrLinkedListIterator.GetString: AnsiString;\r\nbegin\r\n CheckValid;\r\n Result := '';\r\n if FCursor <> nil then\r\n Result := FCursor.Value\r\n else\r\n if not FOwnList.ReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\nend;\r\n\r\nfunction TJclAnsiStrLinkedListIterator.HasNext: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnList.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Valid then\r\n Result := (FCursor <> nil) and (FCursor.Next <> nil)\r\n else\r\n Result := FCursor <> nil;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnList.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclAnsiStrLinkedListIterator.HasPrevious: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnList.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Valid then\r\n Result := (FCursor <> nil) and (FCursor.Previous <> nil)\r\n else\r\n Result := FCursor <> nil;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnList.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclAnsiStrLinkedListIterator.Insert(const AString: AnsiString): Boolean;\r\nvar\r\n NewCursor: TJclAnsiStrLinkedListItem;\r\nbegin\r\n if FOwnList.ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n FOwnList.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n CheckValid;\r\n Result := FCursor <> nil;\r\n if Result then\r\n begin\r\n Result := FOwnList.AllowDefaultElements or not FEqualityComparer.ItemsEqual(AString, '');\r\n if Result then\r\n begin\r\n case FOwnList.Duplicates of\r\n dupIgnore:\r\n Result := not FOwnList.Contains(AString);\r\n dupAccept:\r\n Result := True;\r\n dupError:\r\n begin\r\n Result := FOwnList.Contains(AString);\r\n if not Result then\r\n raise EJclDuplicateElementError.Create;\r\n end;\r\n end;\r\n if Result then\r\n begin\r\n NewCursor := TJclAnsiStrLinkedListItem.Create;\r\n NewCursor.Value := AString;\r\n NewCursor.Next := FCursor;\r\n NewCursor.Previous := FCursor.Previous;\r\n if FCursor.Previous <> nil then\r\n FCursor.Previous.Next := NewCursor;\r\n FCursor.Previous := NewCursor;\r\n FCursor := NewCursor;\r\n end;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnList.WriteUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclAnsiStrLinkedListIterator.IteratorEquals(const AIterator: IJclAnsiStrIterator): Boolean;\r\nvar\r\n Obj: TObject;\r\n ItrObj: TJclAnsiStrLinkedListIterator;\r\nbegin\r\n Result := False;\r\n if AIterator = nil then\r\n Exit;\r\n Obj := AIterator.GetIteratorReference;\r\n if Obj is TJclAnsiStrLinkedListIterator then\r\n begin\r\n ItrObj := TJclAnsiStrLinkedListIterator(Obj);\r\n Result := (FOwnList = ItrObj.FOwnList) and (FCursor = ItrObj.FCursor) and (Valid = ItrObj.Valid);\r\n end;\r\nend;\r\n\r\n{$IFDEF SUPPORTS_FOR_IN}\r\nfunction TJclAnsiStrLinkedListIterator.MoveNext: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnList.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Valid and (FCursor <> nil) then\r\n FCursor := FCursor.Next\r\n else\r\n Valid := True;\r\n Result := FCursor <> nil;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnList.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n{$ENDIF SUPPORTS_FOR_IN}\r\n\r\nfunction TJclAnsiStrLinkedListIterator.Next: AnsiString;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnList.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Valid and (FCursor <> nil) then\r\n FCursor := FCursor.Next\r\n else\r\n Valid := True;\r\n if FCursor <> nil then\r\n Result := FCursor.Value\r\n else\r\n Result := '';\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnList.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclAnsiStrLinkedListIterator.NextIndex: Integer;\r\nbegin\r\n // No Index\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nfunction TJclAnsiStrLinkedListIterator.Previous: AnsiString;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnList.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Valid and (FCursor <> nil) then\r\n FCursor := FCursor.Previous\r\n else\r\n Valid := True;\r\n if FCursor <> nil then\r\n Result := FCursor.Value\r\n else\r\n Result := '';\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnList.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclAnsiStrLinkedListIterator.PreviousIndex: Integer;\r\nbegin\r\n // No Index\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nprocedure TJclAnsiStrLinkedListIterator.Remove;\r\nvar\r\n OldCursor: TJclAnsiStrLinkedListItem;\r\nbegin\r\n if FOwnList.ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n FOwnList.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n CheckValid;\r\n Valid := False;\r\n if FCursor <> nil then\r\n begin\r\n FCursor.Value := '';\r\n if FCursor.Next <> nil then\r\n FCursor.Next.Previous := FCursor.Previous;\r\n if FCursor.Previous <> nil then\r\n FCursor.Previous.Next := FCursor.Next;\r\n OldCursor := FCursor;\r\n FCursor := FCursor.Next;\r\n OldCursor.Free;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnList.WriteUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclAnsiStrLinkedListIterator.Reset;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnList.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Valid := False;\r\n case FStart of\r\n isFirst:\r\n begin\r\n while (FCursor <> nil) and (FCursor.Previous <> nil) do\r\n FCursor := FCursor.Previous;\r\n end;\r\n isLast:\r\n begin\r\n while (FCursor <> nil) and (FCursor.Next <> nil) do\r\n FCursor := FCursor.Next;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnList.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclAnsiStrLinkedListIterator.SetString(const AString: AnsiString);\r\nbegin\r\n if FOwnList.ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n FOwnList.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n CheckValid;\r\n FCursor.Value := '';\r\n FCursor.Value := AString;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnList.WriteUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\n//=== { TJclWideStrLinkedList } ==================================================\r\n\r\nconstructor TJclWideStrLinkedList.Create(const ACollection: IJclWideStrCollection);\r\nbegin\r\n inherited Create();\r\n FStart := nil;\r\n FEnd := nil;\r\n if ACollection <> nil then\r\n AddAll(ACollection);\r\nend;\r\n\r\ndestructor TJclWideStrLinkedList.Destroy;\r\nbegin\r\n FReadOnly := False;\r\n Clear;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJclWideStrLinkedList.Add(const AString: WideString): Boolean;\r\nvar\r\n NewItem: TJclWideStrLinkedListItem;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := FAllowDefaultElements or not ItemsEqual(AString, '');\r\n if Result then\r\n begin\r\n if FDuplicates <> dupAccept then\r\n begin\r\n NewItem := FStart;\r\n while NewItem <> nil do\r\n begin\r\n if ItemsEqual(AString, NewItem.Value) then\r\n begin\r\n Result := CheckDuplicate;\r\n Break;\r\n end;\r\n NewItem := NewItem.Next;\r\n end;\r\n end;\r\n if Result then\r\n begin\r\n NewItem := TJclWideStrLinkedListItem.Create;\r\n NewItem.Value := AString;\r\n if FStart <> nil then\r\n begin\r\n NewItem.Next := nil;\r\n NewItem.Previous := FEnd;\r\n FEnd.Next := NewItem;\r\n FEnd := NewItem;\r\n end\r\n else\r\n begin\r\n FStart := NewItem;\r\n FEnd := NewItem;\r\n end;\r\n Inc(FSize);\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclWideStrLinkedList.AddAll(const ACollection: IJclWideStrCollection): Boolean;\r\nvar\r\n It: IJclWideStrIterator;\r\n Item: WideString;\r\n AddItem: Boolean;\r\n NewItem: TJclWideStrLinkedListItem;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n begin\r\n Item := It.Next;\r\n AddItem := FAllowDefaultElements or not ItemsEqual(Item, '');\r\n if AddItem then\r\n begin\r\n if FDuplicates <> dupAccept then\r\n begin\r\n NewItem := FStart;\r\n while NewItem <> nil do\r\n begin\r\n if ItemsEqual(Item, NewItem.Value) then\r\n begin\r\n AddItem := CheckDuplicate;\r\n Break;\r\n end;\r\n NewItem := NewItem.Next;\r\n end;\r\n end;\r\n if AddItem then\r\n begin\r\n NewItem := TJclWideStrLinkedListItem.Create;\r\n NewItem.Value := Item;\r\n if FStart <> nil then\r\n begin\r\n NewItem.Next := nil;\r\n NewItem.Previous := FEnd;\r\n FEnd.Next := NewItem;\r\n FEnd := NewItem;\r\n end\r\n else\r\n begin\r\n FStart := NewItem;\r\n FEnd := NewItem;\r\n end;\r\n Inc(FSize);\r\n end;\r\n end;\r\n Result := AddItem and Result;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclWideStrLinkedList.AssignDataTo(Dest: TJclAbstractContainerBase);\r\nvar\r\n ACollection: IJclWideStrCollection;\r\nbegin\r\n inherited AssignDataTo(Dest);\r\n if Supports(IInterface(Dest), IJclWideStrCollection, ACollection) then\r\n begin\r\n ACollection.Clear;\r\n ACollection.AddAll(Self);\r\n end;\r\nend;\r\n\r\nprocedure TJclWideStrLinkedList.Clear;\r\nvar\r\n Old, Current: TJclWideStrLinkedListItem;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Current := FStart;\r\n while Current <> nil do\r\n begin\r\n FreeString(Current.Value);\r\n Old := Current;\r\n Current := Current.Next;\r\n Old.Free;\r\n end;\r\n FSize := 0;\r\n\r\n //Daniele Teti 27/12/2004\r\n FStart := nil;\r\n FEnd := nil;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclWideStrLinkedList.CollectionEquals(const ACollection: IJclWideStrCollection): Boolean;\r\nvar\r\n It, ItSelf: IJclWideStrIterator;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n if FSize <> ACollection.Size then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n ItSelf := First;\r\n while ItSelf.HasNext and It.HasNext do\r\n if not ItemsEqual(ItSelf.Next, It.Next) then\r\n begin\r\n Result := False;\r\n Break;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclWideStrLinkedList.Contains(const AString: WideString): Boolean;\r\nvar\r\n Current: TJclWideStrLinkedListItem;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n Current := FStart;\r\n while Current <> nil do\r\n begin\r\n if ItemsEqual(Current.Value, AString) then\r\n begin\r\n Result := True;\r\n Break;\r\n end;\r\n Current := Current.Next;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclWideStrLinkedList.ContainsAll(const ACollection: IJclWideStrCollection): Boolean;\r\nvar\r\n It: IJclWideStrIterator;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n while Result and It.HasNext do\r\n Result := Contains(It.Next);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclWideStrLinkedList.Delete(Index: Integer): WideString;\r\nvar\r\n Current: TJclWideStrLinkedListItem;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := '';\r\n if (Index >= 0) and (Index < FSize) then\r\n begin\r\n Current := FStart;\r\n while Current <> nil do\r\n begin\r\n if Index = 0 then\r\n begin\r\n if Current.Previous <> nil then\r\n Current.Previous.Next := Current.Next\r\n else\r\n FStart := Current.Next;\r\n if Current.Next <> nil then\r\n Current.Next.Previous := Current.Previous\r\n else\r\n FEnd := Current.Previous;\r\n Result := FreeString(Current.Value);\r\n Current.Free;\r\n Dec(FSize);\r\n Break;\r\n end;\r\n Dec(Index);\r\n Current := Current.Next;\r\n end;\r\n end\r\n else\r\n raise EJclOutOfBoundsError.Create;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclWideStrLinkedList.Extract(const AString: WideString): Boolean;\r\nvar\r\n Current: TJclWideStrLinkedListItem;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n Current := FStart;\r\n while Current <> nil do\r\n begin\r\n if ItemsEqual(Current.Value, AString) then\r\n begin\r\n if Current.Previous <> nil then\r\n Current.Previous.Next := Current.Next\r\n else\r\n FStart := Current.Next;\r\n if Current.Next <> nil then\r\n Current.Next.Previous := Current.Previous\r\n else\r\n FEnd := Current.Previous;\r\n Current.Value := '';\r\n Current.Free;\r\n Dec(FSize);\r\n Result := True;\r\n if FRemoveSingleElement then\r\n Break;\r\n end;\r\n Current := Current.Next;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclWideStrLinkedList.ExtractAll(const ACollection: IJclWideStrCollection): Boolean;\r\nvar\r\n It: IJclWideStrIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := True;\r\n if ACollection = nil then\r\n Exit;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n Result := Extract(It.Next) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclWideStrLinkedList.ExtractIndex(Index: Integer): WideString;\r\nvar\r\n Current: TJclWideStrLinkedListItem;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := '';\r\n if (Index >= 0) and (Index < FSize) then\r\n begin\r\n Current := FStart;\r\n while Current <> nil do\r\n begin\r\n if Index = 0 then\r\n begin\r\n if Current.Previous <> nil then\r\n Current.Previous.Next := Current.Next\r\n else\r\n FStart := Current.Next;\r\n if Current.Next <> nil then\r\n Current.Next.Previous := Current.Previous\r\n else\r\n FEnd := Current.Previous;\r\n Result := Current.Value;\r\n Current.Free;\r\n Dec(FSize);\r\n Break;\r\n end;\r\n Dec(Index);\r\n Current := Current.Next;\r\n end;\r\n end\r\n else\r\n raise EJclOutOfBoundsError.Create;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclWideStrLinkedList.First: IJclWideStrIterator;\r\nbegin\r\n Result := TJclWideStrLinkedListIterator.Create(Self, FStart, False, isFirst);\r\nend;\r\n\r\n{$IFDEF SUPPORTS_FOR_IN}\r\nfunction TJclWideStrLinkedList.GetEnumerator: IJclWideStrIterator;\r\nbegin\r\n Result := TJclWideStrLinkedListIterator.Create(Self, FStart, False, isFirst);\r\nend;\r\n{$ENDIF SUPPORTS_FOR_IN}\r\n\r\nfunction TJclWideStrLinkedList.GetString(Index: Integer): WideString;\r\nvar\r\n Current: TJclWideStrLinkedListItem;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := '';\r\n Current := FStart;\r\n while (Current <> nil) and (Index > 0) do\r\n begin\r\n Current := Current.Next;\r\n Dec(Index);\r\n end;\r\n if Current <> nil then\r\n Result := Current.Value\r\n else\r\n if not FReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclWideStrLinkedList.IndexOf(const AString: WideString): Integer;\r\nvar\r\n Current: TJclWideStrLinkedListItem;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Current := FStart;\r\n Result := 0;\r\n while (Current <> nil) and not ItemsEqual(Current.Value, AString) do\r\n begin\r\n Inc(Result);\r\n Current := Current.Next;\r\n end;\r\n if Current = nil then\r\n Result := -1;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclWideStrLinkedList.Insert(Index: Integer; const AString: WideString): Boolean;\r\nvar\r\n Current, NewItem: TJclWideStrLinkedListItem;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := FAllowDefaultElements or not ItemsEqual(AString, '');\r\n if (Index < 0) or (Index > FSize) then\r\n raise EJclOutOfBoundsError.Create;\r\n if Result then\r\n begin\r\n if FDuplicates <> dupAccept then\r\n begin\r\n Current := FStart;\r\n while Current <> nil do\r\n begin\r\n if ItemsEqual(AString, Current.Value) then\r\n begin\r\n Result := CheckDuplicate;\r\n Break;\r\n end;\r\n Current := Current.Next;\r\n end;\r\n end;\r\n if Result then\r\n begin\r\n NewItem := TJclWideStrLinkedListItem.Create;\r\n NewItem.Value := AString;\r\n if Index = 0 then\r\n begin\r\n NewItem.Next := FStart;\r\n if FStart <> nil then\r\n FStart.Previous := NewItem;\r\n FStart := NewItem;\r\n if FSize = 0 then\r\n FEnd := NewItem;\r\n Inc(FSize);\r\n end\r\n else\r\n if Index = FSize then\r\n begin\r\n NewItem.Previous := FEnd;\r\n FEnd.Next := NewItem;\r\n FEnd := NewItem;\r\n Inc(FSize);\r\n end\r\n else\r\n begin\r\n Current := FStart;\r\n while (Current <> nil) and (Index > 0) do\r\n begin\r\n Current := Current.Next;\r\n Dec(Index);\r\n end;\r\n if Current <> nil then\r\n begin\r\n NewItem.Next := Current;\r\n NewItem.Previous := Current.Previous;\r\n if Current.Previous <> nil then\r\n Current.Previous.Next := NewItem;\r\n Current.Previous := NewItem;\r\n Inc(FSize);\r\n end;\r\n end;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclWideStrLinkedList.InsertAll(Index: Integer; const ACollection: IJclWideStrCollection): Boolean;\r\nvar\r\n It: IJclWideStrIterator;\r\n Current, NewItem, Test: TJclWideStrLinkedListItem;\r\n AddItem: Boolean;\r\n Item: WideString;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if (Index < 0) or (Index > FSize) then\r\n raise EJclOutOfBoundsError.Create;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n if Index = 0 then\r\n begin\r\n It := ACollection.Last;\r\n while It.HasPrevious do\r\n begin\r\n Item := It.Previous;\r\n AddItem := FAllowDefaultElements or not ItemsEqual(Item, '');\r\n if AddItem then\r\n begin\r\n if FDuplicates <> dupAccept then\r\n begin\r\n Test := FStart;\r\n while Test <> nil do\r\n begin\r\n if ItemsEqual(Item, Test.Value) then\r\n begin\r\n Result := CheckDuplicate;\r\n Break;\r\n end;\r\n Test := Test.Next;\r\n end;\r\n end;\r\n if AddItem then\r\n begin\r\n NewItem := TJclWideStrLinkedListItem.Create;\r\n NewItem.Value := Item;\r\n NewItem.Next := FStart;\r\n if FStart <> nil then\r\n FStart.Previous := NewItem;\r\n FStart := NewItem;\r\n if FSize = 0 then\r\n FEnd := NewItem;\r\n Inc(FSize);\r\n end;\r\n end;\r\n Result := Result and AddItem;\r\n end;\r\n end\r\n else\r\n if Index = Size then\r\n begin\r\n It := ACollection.First;\r\n while It.HasNext do\r\n begin\r\n Item := It.Next;\r\n AddItem := FAllowDefaultElements or not ItemsEqual(Item, '');\r\n if AddItem then\r\n begin\r\n if FDuplicates <> dupAccept then\r\n begin\r\n Test := FStart;\r\n while Test <> nil do\r\n begin\r\n if ItemsEqual(Item, Test.Value) then\r\n begin\r\n Result := CheckDuplicate;\r\n Break;\r\n end;\r\n Test := Test.Next;\r\n end;\r\n end;\r\n if AddItem then\r\n begin\r\n NewItem := TJclWideStrLinkedListItem.Create;\r\n NewItem.Value := Item;\r\n NewItem.Previous := FEnd;\r\n if FEnd <> nil then\r\n FEnd.Next := NewItem;\r\n FEnd := NewItem;\r\n Inc(FSize);\r\n end;\r\n end;\r\n Result := Result and AddItem;\r\n end;\r\n end\r\n else\r\n begin\r\n Current := FStart;\r\n while (Current <> nil) and (Index > 0) do\r\n begin\r\n Current := Current.Next;\r\n Dec(Index);\r\n end;\r\n if Current <> nil then\r\n begin\r\n It := ACollection.First;\r\n while It.HasNext do\r\n begin\r\n Item := It.Next;\r\n AddItem := FAllowDefaultElements or not ItemsEqual(Item, '');\r\n if AddItem then\r\n begin\r\n if FDuplicates <> dupAccept then\r\n begin\r\n Test := FStart;\r\n while Test <> nil do\r\n begin\r\n if ItemsEqual(Item, Test.Value) then\r\n begin\r\n Result := CheckDuplicate;\r\n Break;\r\n end;\r\n Test := Test.Next;\r\n end;\r\n end;\r\n if AddItem then\r\n begin\r\n NewItem := TJclWideStrLinkedListItem.Create;\r\n NewItem.Value := Item;\r\n NewItem.Next := Current;\r\n NewItem.Previous := Current.Previous;\r\n if Current.Previous <> nil then\r\n Current.Previous.Next := NewItem;\r\n Current.Previous := NewItem;\r\n Inc(FSize);\r\n end;\r\n end;\r\n Result := Result and AddItem;\r\n end;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclWideStrLinkedList.IsEmpty: Boolean;\r\nbegin\r\n Result := FSize = 0;\r\nend;\r\n\r\nfunction TJclWideStrLinkedList.Last: IJclWideStrIterator;\r\nbegin\r\n Result := TJclWideStrLinkedListIterator.Create(Self, FEnd, False, isLast);\r\nend;\r\n\r\nfunction TJclWideStrLinkedList.LastIndexOf(const AString: WideString): Integer;\r\nvar\r\n Current: TJclWideStrLinkedListItem;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := -1;\r\n if FEnd <> nil then\r\n begin\r\n Current := FEnd;\r\n Result := FSize - 1;\r\n while (Current <> nil) and not ItemsEqual(Current.Value, AString) do\r\n begin\r\n Dec(Result);\r\n Current := Current.Previous;\r\n end;\r\n if Current = nil then\r\n Result := -1;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclWideStrLinkedList.Remove(const AString: WideString): Boolean;\r\nvar\r\n Extracted: WideString;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := Extract(AString);\r\n if Result then\r\n begin\r\n Extracted := AString;\r\n FreeString(Extracted);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclWideStrLinkedList.RemoveAll(const ACollection: IJclWideStrCollection): Boolean;\r\nvar\r\n It: IJclWideStrIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := True;\r\n if ACollection = nil then\r\n Exit;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n Result := Remove(It.Next) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclWideStrLinkedList.RetainAll(const ACollection: IJclWideStrCollection): Boolean;\r\nvar\r\n It: IJclWideStrIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := First;\r\n while It.HasNext do\r\n if not ACollection.Contains(It.Next) then\r\n It.Remove;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclWideStrLinkedList.SetString(Index: Integer; const AString: WideString);\r\nvar\r\n Current: TJclWideStrLinkedListItem;\r\n ReplaceItem: Boolean;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n ReplaceItem := FAllowDefaultElements or not ItemsEqual(AString, '');\r\n if ReplaceItem then\r\n begin\r\n if FDuplicates <> dupAccept then\r\n begin\r\n Current := FStart;\r\n while Current <> nil do\r\n begin\r\n if ItemsEqual(AString, Current.Value) then\r\n begin\r\n ReplaceItem := CheckDuplicate;\r\n Break;\r\n end;\r\n Current := Current.Next;\r\n end;\r\n end;\r\n if ReplaceItem then\r\n begin\r\n Current := FStart;\r\n while Current <> nil do\r\n begin\r\n if Index = 0 then\r\n begin\r\n FreeString(Current.Value);\r\n Current.Value := AString;\r\n Break;\r\n end;\r\n Dec(Index);\r\n Current := Current.Next;\r\n end;\r\n end;\r\n end;\r\n if not ReplaceItem then\r\n Delete(Index);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclWideStrLinkedList.Size: Integer;\r\nbegin\r\n Result := FSize;\r\nend;\r\n\r\nfunction TJclWideStrLinkedList.SubList(First, Count: Integer): IJclWideStrList;\r\nvar\r\n Current: TJclWideStrLinkedListItem;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := CreateEmptyContainer as IJclWideStrList;\r\n Current := FStart;\r\n while (Current <> nil) and (First > 0) do\r\n begin\r\n Dec(First);\r\n Current := Current.Next;\r\n end;\r\n while (Current <> nil) and (Count > 0) do\r\n begin\r\n Result.Add(Current.Value);\r\n Dec(Count);\r\n Current := Current.Next;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclWideStrLinkedList.CreateEmptyContainer: TJclAbstractContainerBase;\r\nbegin\r\n Result := TJclWideStrLinkedList.Create(nil);\r\n AssignPropertiesTo(Result);\r\nend;\r\n\r\n//=== { TJclWideStrLinkedListIterator } ============================================================\r\n\r\nconstructor TJclWideStrLinkedListIterator.Create(AOwnList: TJclWideStrLinkedList; ACursor: TJclWideStrLinkedListItem; AValid: Boolean; AStart: TItrStart);\r\nbegin\r\n inherited Create(AValid);\r\n FCursor := ACursor;\r\n FOwnList := AOwnList;\r\n FStart := AStart;\r\n FEqualityComparer := AOwnList as IJclWideStrEqualityComparer;\r\nend;\r\n\r\nfunction TJclWideStrLinkedListIterator.Add(const AString: WideString): Boolean;\r\nbegin\r\n Result := FOwnList.Add(AString);\r\nend;\r\n\r\nprocedure TJclWideStrLinkedListIterator.AssignPropertiesTo(Dest: TJclAbstractIterator);\r\nvar\r\n ADest: TJclWideStrLinkedListIterator;\r\nbegin\r\n inherited AssignPropertiesTo(Dest);\r\n if Dest is TJclWideStrLinkedListIterator then\r\n begin\r\n ADest := TJclWideStrLinkedListIterator(Dest);\r\n ADest.FCursor := FCursor;\r\n ADest.FOwnList := FOwnList;\r\n ADest.FEqualityComparer := FEqualityComparer;\r\n ADest.FStart := FStart;\r\n end;\r\nend;\r\n\r\nfunction TJclWideStrLinkedListIterator.CreateEmptyIterator: TJclAbstractIterator;\r\nbegin\r\n Result := TJclWideStrLinkedListIterator.Create(FOwnList, FCursor, Valid, FStart);\r\nend;\r\n\r\nprocedure TJclWideStrLinkedListIterator.Extract;\r\nvar\r\n OldCursor: TJclWideStrLinkedListItem;\r\nbegin\r\n if FOwnList.ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n FOwnList.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n CheckValid;\r\n Valid := False;\r\n if FCursor <> nil then\r\n begin\r\n if FCursor.Next <> nil then\r\n FCursor.Next.Previous := FCursor.Previous;\r\n if FCursor.Previous <> nil then\r\n FCursor.Previous.Next := FCursor.Next;\r\n OldCursor := FCursor;\r\n FCursor := FCursor.Next;\r\n OldCursor.Free;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnList.WriteUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclWideStrLinkedListIterator.GetString: WideString;\r\nbegin\r\n CheckValid;\r\n Result := '';\r\n if FCursor <> nil then\r\n Result := FCursor.Value\r\n else\r\n if not FOwnList.ReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\nend;\r\n\r\nfunction TJclWideStrLinkedListIterator.HasNext: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnList.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Valid then\r\n Result := (FCursor <> nil) and (FCursor.Next <> nil)\r\n else\r\n Result := FCursor <> nil;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnList.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclWideStrLinkedListIterator.HasPrevious: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnList.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Valid then\r\n Result := (FCursor <> nil) and (FCursor.Previous <> nil)\r\n else\r\n Result := FCursor <> nil;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnList.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclWideStrLinkedListIterator.Insert(const AString: WideString): Boolean;\r\nvar\r\n NewCursor: TJclWideStrLinkedListItem;\r\nbegin\r\n if FOwnList.ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n FOwnList.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n CheckValid;\r\n Result := FCursor <> nil;\r\n if Result then\r\n begin\r\n Result := FOwnList.AllowDefaultElements or not FEqualityComparer.ItemsEqual(AString, '');\r\n if Result then\r\n begin\r\n case FOwnList.Duplicates of\r\n dupIgnore:\r\n Result := not FOwnList.Contains(AString);\r\n dupAccept:\r\n Result := True;\r\n dupError:\r\n begin\r\n Result := FOwnList.Contains(AString);\r\n if not Result then\r\n raise EJclDuplicateElementError.Create;\r\n end;\r\n end;\r\n if Result then\r\n begin\r\n NewCursor := TJclWideStrLinkedListItem.Create;\r\n NewCursor.Value := AString;\r\n NewCursor.Next := FCursor;\r\n NewCursor.Previous := FCursor.Previous;\r\n if FCursor.Previous <> nil then\r\n FCursor.Previous.Next := NewCursor;\r\n FCursor.Previous := NewCursor;\r\n FCursor := NewCursor;\r\n end;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnList.WriteUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclWideStrLinkedListIterator.IteratorEquals(const AIterator: IJclWideStrIterator): Boolean;\r\nvar\r\n Obj: TObject;\r\n ItrObj: TJclWideStrLinkedListIterator;\r\nbegin\r\n Result := False;\r\n if AIterator = nil then\r\n Exit;\r\n Obj := AIterator.GetIteratorReference;\r\n if Obj is TJclWideStrLinkedListIterator then\r\n begin\r\n ItrObj := TJclWideStrLinkedListIterator(Obj);\r\n Result := (FOwnList = ItrObj.FOwnList) and (FCursor = ItrObj.FCursor) and (Valid = ItrObj.Valid);\r\n end;\r\nend;\r\n\r\n{$IFDEF SUPPORTS_FOR_IN}\r\nfunction TJclWideStrLinkedListIterator.MoveNext: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnList.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Valid and (FCursor <> nil) then\r\n FCursor := FCursor.Next\r\n else\r\n Valid := True;\r\n Result := FCursor <> nil;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnList.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n{$ENDIF SUPPORTS_FOR_IN}\r\n\r\nfunction TJclWideStrLinkedListIterator.Next: WideString;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnList.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Valid and (FCursor <> nil) then\r\n FCursor := FCursor.Next\r\n else\r\n Valid := True;\r\n if FCursor <> nil then\r\n Result := FCursor.Value\r\n else\r\n Result := '';\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnList.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclWideStrLinkedListIterator.NextIndex: Integer;\r\nbegin\r\n // No Index\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nfunction TJclWideStrLinkedListIterator.Previous: WideString;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnList.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Valid and (FCursor <> nil) then\r\n FCursor := FCursor.Previous\r\n else\r\n Valid := True;\r\n if FCursor <> nil then\r\n Result := FCursor.Value\r\n else\r\n Result := '';\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnList.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclWideStrLinkedListIterator.PreviousIndex: Integer;\r\nbegin\r\n // No Index\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nprocedure TJclWideStrLinkedListIterator.Remove;\r\nvar\r\n OldCursor: TJclWideStrLinkedListItem;\r\nbegin\r\n if FOwnList.ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n FOwnList.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n CheckValid;\r\n Valid := False;\r\n if FCursor <> nil then\r\n begin\r\n FCursor.Value := '';\r\n if FCursor.Next <> nil then\r\n FCursor.Next.Previous := FCursor.Previous;\r\n if FCursor.Previous <> nil then\r\n FCursor.Previous.Next := FCursor.Next;\r\n OldCursor := FCursor;\r\n FCursor := FCursor.Next;\r\n OldCursor.Free;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnList.WriteUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclWideStrLinkedListIterator.Reset;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnList.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Valid := False;\r\n case FStart of\r\n isFirst:\r\n begin\r\n while (FCursor <> nil) and (FCursor.Previous <> nil) do\r\n FCursor := FCursor.Previous;\r\n end;\r\n isLast:\r\n begin\r\n while (FCursor <> nil) and (FCursor.Next <> nil) do\r\n FCursor := FCursor.Next;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnList.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclWideStrLinkedListIterator.SetString(const AString: WideString);\r\nbegin\r\n if FOwnList.ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n FOwnList.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n CheckValid;\r\n FCursor.Value := '';\r\n FCursor.Value := AString;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnList.WriteUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\n{$IFDEF SUPPORTS_UNICODE_STRING}\r\n//=== { TJclUnicodeStrLinkedList } ==================================================\r\n\r\nconstructor TJclUnicodeStrLinkedList.Create(const ACollection: IJclUnicodeStrCollection);\r\nbegin\r\n inherited Create();\r\n FStart := nil;\r\n FEnd := nil;\r\n if ACollection <> nil then\r\n AddAll(ACollection);\r\nend;\r\n\r\ndestructor TJclUnicodeStrLinkedList.Destroy;\r\nbegin\r\n FReadOnly := False;\r\n Clear;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJclUnicodeStrLinkedList.Add(const AString: UnicodeString): Boolean;\r\nvar\r\n NewItem: TJclUnicodeStrLinkedListItem;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := FAllowDefaultElements or not ItemsEqual(AString, '');\r\n if Result then\r\n begin\r\n if FDuplicates <> dupAccept then\r\n begin\r\n NewItem := FStart;\r\n while NewItem <> nil do\r\n begin\r\n if ItemsEqual(AString, NewItem.Value) then\r\n begin\r\n Result := CheckDuplicate;\r\n Break;\r\n end;\r\n NewItem := NewItem.Next;\r\n end;\r\n end;\r\n if Result then\r\n begin\r\n NewItem := TJclUnicodeStrLinkedListItem.Create;\r\n NewItem.Value := AString;\r\n if FStart <> nil then\r\n begin\r\n NewItem.Next := nil;\r\n NewItem.Previous := FEnd;\r\n FEnd.Next := NewItem;\r\n FEnd := NewItem;\r\n end\r\n else\r\n begin\r\n FStart := NewItem;\r\n FEnd := NewItem;\r\n end;\r\n Inc(FSize);\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclUnicodeStrLinkedList.AddAll(const ACollection: IJclUnicodeStrCollection): Boolean;\r\nvar\r\n It: IJclUnicodeStrIterator;\r\n Item: UnicodeString;\r\n AddItem: Boolean;\r\n NewItem: TJclUnicodeStrLinkedListItem;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n begin\r\n Item := It.Next;\r\n AddItem := FAllowDefaultElements or not ItemsEqual(Item, '');\r\n if AddItem then\r\n begin\r\n if FDuplicates <> dupAccept then\r\n begin\r\n NewItem := FStart;\r\n while NewItem <> nil do\r\n begin\r\n if ItemsEqual(Item, NewItem.Value) then\r\n begin\r\n AddItem := CheckDuplicate;\r\n Break;\r\n end;\r\n NewItem := NewItem.Next;\r\n end;\r\n end;\r\n if AddItem then\r\n begin\r\n NewItem := TJclUnicodeStrLinkedListItem.Create;\r\n NewItem.Value := Item;\r\n if FStart <> nil then\r\n begin\r\n NewItem.Next := nil;\r\n NewItem.Previous := FEnd;\r\n FEnd.Next := NewItem;\r\n FEnd := NewItem;\r\n end\r\n else\r\n begin\r\n FStart := NewItem;\r\n FEnd := NewItem;\r\n end;\r\n Inc(FSize);\r\n end;\r\n end;\r\n Result := AddItem and Result;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclUnicodeStrLinkedList.AssignDataTo(Dest: TJclAbstractContainerBase);\r\nvar\r\n ACollection: IJclUnicodeStrCollection;\r\nbegin\r\n inherited AssignDataTo(Dest);\r\n if Supports(IInterface(Dest), IJclUnicodeStrCollection, ACollection) then\r\n begin\r\n ACollection.Clear;\r\n ACollection.AddAll(Self);\r\n end;\r\nend;\r\n\r\nprocedure TJclUnicodeStrLinkedList.Clear;\r\nvar\r\n Old, Current: TJclUnicodeStrLinkedListItem;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Current := FStart;\r\n while Current <> nil do\r\n begin\r\n FreeString(Current.Value);\r\n Old := Current;\r\n Current := Current.Next;\r\n Old.Free;\r\n end;\r\n FSize := 0;\r\n\r\n //Daniele Teti 27/12/2004\r\n FStart := nil;\r\n FEnd := nil;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclUnicodeStrLinkedList.CollectionEquals(const ACollection: IJclUnicodeStrCollection): Boolean;\r\nvar\r\n It, ItSelf: IJclUnicodeStrIterator;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n if FSize <> ACollection.Size then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n ItSelf := First;\r\n while ItSelf.HasNext and It.HasNext do\r\n if not ItemsEqual(ItSelf.Next, It.Next) then\r\n begin\r\n Result := False;\r\n Break;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclUnicodeStrLinkedList.Contains(const AString: UnicodeString): Boolean;\r\nvar\r\n Current: TJclUnicodeStrLinkedListItem;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n Current := FStart;\r\n while Current <> nil do\r\n begin\r\n if ItemsEqual(Current.Value, AString) then\r\n begin\r\n Result := True;\r\n Break;\r\n end;\r\n Current := Current.Next;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclUnicodeStrLinkedList.ContainsAll(const ACollection: IJclUnicodeStrCollection): Boolean;\r\nvar\r\n It: IJclUnicodeStrIterator;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n while Result and It.HasNext do\r\n Result := Contains(It.Next);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclUnicodeStrLinkedList.Delete(Index: Integer): UnicodeString;\r\nvar\r\n Current: TJclUnicodeStrLinkedListItem;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := '';\r\n if (Index >= 0) and (Index < FSize) then\r\n begin\r\n Current := FStart;\r\n while Current <> nil do\r\n begin\r\n if Index = 0 then\r\n begin\r\n if Current.Previous <> nil then\r\n Current.Previous.Next := Current.Next\r\n else\r\n FStart := Current.Next;\r\n if Current.Next <> nil then\r\n Current.Next.Previous := Current.Previous\r\n else\r\n FEnd := Current.Previous;\r\n Result := FreeString(Current.Value);\r\n Current.Free;\r\n Dec(FSize);\r\n Break;\r\n end;\r\n Dec(Index);\r\n Current := Current.Next;\r\n end;\r\n end\r\n else\r\n raise EJclOutOfBoundsError.Create;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclUnicodeStrLinkedList.Extract(const AString: UnicodeString): Boolean;\r\nvar\r\n Current: TJclUnicodeStrLinkedListItem;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n Current := FStart;\r\n while Current <> nil do\r\n begin\r\n if ItemsEqual(Current.Value, AString) then\r\n begin\r\n if Current.Previous <> nil then\r\n Current.Previous.Next := Current.Next\r\n else\r\n FStart := Current.Next;\r\n if Current.Next <> nil then\r\n Current.Next.Previous := Current.Previous\r\n else\r\n FEnd := Current.Previous;\r\n Current.Value := '';\r\n Current.Free;\r\n Dec(FSize);\r\n Result := True;\r\n if FRemoveSingleElement then\r\n Break;\r\n end;\r\n Current := Current.Next;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclUnicodeStrLinkedList.ExtractAll(const ACollection: IJclUnicodeStrCollection): Boolean;\r\nvar\r\n It: IJclUnicodeStrIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := True;\r\n if ACollection = nil then\r\n Exit;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n Result := Extract(It.Next) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclUnicodeStrLinkedList.ExtractIndex(Index: Integer): UnicodeString;\r\nvar\r\n Current: TJclUnicodeStrLinkedListItem;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := '';\r\n if (Index >= 0) and (Index < FSize) then\r\n begin\r\n Current := FStart;\r\n while Current <> nil do\r\n begin\r\n if Index = 0 then\r\n begin\r\n if Current.Previous <> nil then\r\n Current.Previous.Next := Current.Next\r\n else\r\n FStart := Current.Next;\r\n if Current.Next <> nil then\r\n Current.Next.Previous := Current.Previous\r\n else\r\n FEnd := Current.Previous;\r\n Result := Current.Value;\r\n Current.Free;\r\n Dec(FSize);\r\n Break;\r\n end;\r\n Dec(Index);\r\n Current := Current.Next;\r\n end;\r\n end\r\n else\r\n raise EJclOutOfBoundsError.Create;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclUnicodeStrLinkedList.First: IJclUnicodeStrIterator;\r\nbegin\r\n Result := TJclUnicodeStrLinkedListIterator.Create(Self, FStart, False, isFirst);\r\nend;\r\n\r\n{$IFDEF SUPPORTS_FOR_IN}\r\nfunction TJclUnicodeStrLinkedList.GetEnumerator: IJclUnicodeStrIterator;\r\nbegin\r\n Result := TJclUnicodeStrLinkedListIterator.Create(Self, FStart, False, isFirst);\r\nend;\r\n{$ENDIF SUPPORTS_FOR_IN}\r\n\r\nfunction TJclUnicodeStrLinkedList.GetString(Index: Integer): UnicodeString;\r\nvar\r\n Current: TJclUnicodeStrLinkedListItem;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := '';\r\n Current := FStart;\r\n while (Current <> nil) and (Index > 0) do\r\n begin\r\n Current := Current.Next;\r\n Dec(Index);\r\n end;\r\n if Current <> nil then\r\n Result := Current.Value\r\n else\r\n if not FReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclUnicodeStrLinkedList.IndexOf(const AString: UnicodeString): Integer;\r\nvar\r\n Current: TJclUnicodeStrLinkedListItem;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Current := FStart;\r\n Result := 0;\r\n while (Current <> nil) and not ItemsEqual(Current.Value, AString) do\r\n begin\r\n Inc(Result);\r\n Current := Current.Next;\r\n end;\r\n if Current = nil then\r\n Result := -1;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclUnicodeStrLinkedList.Insert(Index: Integer; const AString: UnicodeString): Boolean;\r\nvar\r\n Current, NewItem: TJclUnicodeStrLinkedListItem;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := FAllowDefaultElements or not ItemsEqual(AString, '');\r\n if (Index < 0) or (Index > FSize) then\r\n raise EJclOutOfBoundsError.Create;\r\n if Result then\r\n begin\r\n if FDuplicates <> dupAccept then\r\n begin\r\n Current := FStart;\r\n while Current <> nil do\r\n begin\r\n if ItemsEqual(AString, Current.Value) then\r\n begin\r\n Result := CheckDuplicate;\r\n Break;\r\n end;\r\n Current := Current.Next;\r\n end;\r\n end;\r\n if Result then\r\n begin\r\n NewItem := TJclUnicodeStrLinkedListItem.Create;\r\n NewItem.Value := AString;\r\n if Index = 0 then\r\n begin\r\n NewItem.Next := FStart;\r\n if FStart <> nil then\r\n FStart.Previous := NewItem;\r\n FStart := NewItem;\r\n if FSize = 0 then\r\n FEnd := NewItem;\r\n Inc(FSize);\r\n end\r\n else\r\n if Index = FSize then\r\n begin\r\n NewItem.Previous := FEnd;\r\n FEnd.Next := NewItem;\r\n FEnd := NewItem;\r\n Inc(FSize);\r\n end\r\n else\r\n begin\r\n Current := FStart;\r\n while (Current <> nil) and (Index > 0) do\r\n begin\r\n Current := Current.Next;\r\n Dec(Index);\r\n end;\r\n if Current <> nil then\r\n begin\r\n NewItem.Next := Current;\r\n NewItem.Previous := Current.Previous;\r\n if Current.Previous <> nil then\r\n Current.Previous.Next := NewItem;\r\n Current.Previous := NewItem;\r\n Inc(FSize);\r\n end;\r\n end;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclUnicodeStrLinkedList.InsertAll(Index: Integer; const ACollection: IJclUnicodeStrCollection): Boolean;\r\nvar\r\n It: IJclUnicodeStrIterator;\r\n Current, NewItem, Test: TJclUnicodeStrLinkedListItem;\r\n AddItem: Boolean;\r\n Item: UnicodeString;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if (Index < 0) or (Index > FSize) then\r\n raise EJclOutOfBoundsError.Create;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n if Index = 0 then\r\n begin\r\n It := ACollection.Last;\r\n while It.HasPrevious do\r\n begin\r\n Item := It.Previous;\r\n AddItem := FAllowDefaultElements or not ItemsEqual(Item, '');\r\n if AddItem then\r\n begin\r\n if FDuplicates <> dupAccept then\r\n begin\r\n Test := FStart;\r\n while Test <> nil do\r\n begin\r\n if ItemsEqual(Item, Test.Value) then\r\n begin\r\n Result := CheckDuplicate;\r\n Break;\r\n end;\r\n Test := Test.Next;\r\n end;\r\n end;\r\n if AddItem then\r\n begin\r\n NewItem := TJclUnicodeStrLinkedListItem.Create;\r\n NewItem.Value := Item;\r\n NewItem.Next := FStart;\r\n if FStart <> nil then\r\n FStart.Previous := NewItem;\r\n FStart := NewItem;\r\n if FSize = 0 then\r\n FEnd := NewItem;\r\n Inc(FSize);\r\n end;\r\n end;\r\n Result := Result and AddItem;\r\n end;\r\n end\r\n else\r\n if Index = Size then\r\n begin\r\n It := ACollection.First;\r\n while It.HasNext do\r\n begin\r\n Item := It.Next;\r\n AddItem := FAllowDefaultElements or not ItemsEqual(Item, '');\r\n if AddItem then\r\n begin\r\n if FDuplicates <> dupAccept then\r\n begin\r\n Test := FStart;\r\n while Test <> nil do\r\n begin\r\n if ItemsEqual(Item, Test.Value) then\r\n begin\r\n Result := CheckDuplicate;\r\n Break;\r\n end;\r\n Test := Test.Next;\r\n end;\r\n end;\r\n if AddItem then\r\n begin\r\n NewItem := TJclUnicodeStrLinkedListItem.Create;\r\n NewItem.Value := Item;\r\n NewItem.Previous := FEnd;\r\n if FEnd <> nil then\r\n FEnd.Next := NewItem;\r\n FEnd := NewItem;\r\n Inc(FSize);\r\n end;\r\n end;\r\n Result := Result and AddItem;\r\n end;\r\n end\r\n else\r\n begin\r\n Current := FStart;\r\n while (Current <> nil) and (Index > 0) do\r\n begin\r\n Current := Current.Next;\r\n Dec(Index);\r\n end;\r\n if Current <> nil then\r\n begin\r\n It := ACollection.First;\r\n while It.HasNext do\r\n begin\r\n Item := It.Next;\r\n AddItem := FAllowDefaultElements or not ItemsEqual(Item, '');\r\n if AddItem then\r\n begin\r\n if FDuplicates <> dupAccept then\r\n begin\r\n Test := FStart;\r\n while Test <> nil do\r\n begin\r\n if ItemsEqual(Item, Test.Value) then\r\n begin\r\n Result := CheckDuplicate;\r\n Break;\r\n end;\r\n Test := Test.Next;\r\n end;\r\n end;\r\n if AddItem then\r\n begin\r\n NewItem := TJclUnicodeStrLinkedListItem.Create;\r\n NewItem.Value := Item;\r\n NewItem.Next := Current;\r\n NewItem.Previous := Current.Previous;\r\n if Current.Previous <> nil then\r\n Current.Previous.Next := NewItem;\r\n Current.Previous := NewItem;\r\n Inc(FSize);\r\n end;\r\n end;\r\n Result := Result and AddItem;\r\n end;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclUnicodeStrLinkedList.IsEmpty: Boolean;\r\nbegin\r\n Result := FSize = 0;\r\nend;\r\n\r\nfunction TJclUnicodeStrLinkedList.Last: IJclUnicodeStrIterator;\r\nbegin\r\n Result := TJclUnicodeStrLinkedListIterator.Create(Self, FEnd, False, isLast);\r\nend;\r\n\r\nfunction TJclUnicodeStrLinkedList.LastIndexOf(const AString: UnicodeString): Integer;\r\nvar\r\n Current: TJclUnicodeStrLinkedListItem;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := -1;\r\n if FEnd <> nil then\r\n begin\r\n Current := FEnd;\r\n Result := FSize - 1;\r\n while (Current <> nil) and not ItemsEqual(Current.Value, AString) do\r\n begin\r\n Dec(Result);\r\n Current := Current.Previous;\r\n end;\r\n if Current = nil then\r\n Result := -1;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclUnicodeStrLinkedList.Remove(const AString: UnicodeString): Boolean;\r\nvar\r\n Extracted: UnicodeString;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := Extract(AString);\r\n if Result then\r\n begin\r\n Extracted := AString;\r\n FreeString(Extracted);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclUnicodeStrLinkedList.RemoveAll(const ACollection: IJclUnicodeStrCollection): Boolean;\r\nvar\r\n It: IJclUnicodeStrIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := True;\r\n if ACollection = nil then\r\n Exit;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n Result := Remove(It.Next) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclUnicodeStrLinkedList.RetainAll(const ACollection: IJclUnicodeStrCollection): Boolean;\r\nvar\r\n It: IJclUnicodeStrIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := First;\r\n while It.HasNext do\r\n if not ACollection.Contains(It.Next) then\r\n It.Remove;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclUnicodeStrLinkedList.SetString(Index: Integer; const AString: UnicodeString);\r\nvar\r\n Current: TJclUnicodeStrLinkedListItem;\r\n ReplaceItem: Boolean;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n ReplaceItem := FAllowDefaultElements or not ItemsEqual(AString, '');\r\n if ReplaceItem then\r\n begin\r\n if FDuplicates <> dupAccept then\r\n begin\r\n Current := FStart;\r\n while Current <> nil do\r\n begin\r\n if ItemsEqual(AString, Current.Value) then\r\n begin\r\n ReplaceItem := CheckDuplicate;\r\n Break;\r\n end;\r\n Current := Current.Next;\r\n end;\r\n end;\r\n if ReplaceItem then\r\n begin\r\n Current := FStart;\r\n while Current <> nil do\r\n begin\r\n if Index = 0 then\r\n begin\r\n FreeString(Current.Value);\r\n Current.Value := AString;\r\n Break;\r\n end;\r\n Dec(Index);\r\n Current := Current.Next;\r\n end;\r\n end;\r\n end;\r\n if not ReplaceItem then\r\n Delete(Index);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclUnicodeStrLinkedList.Size: Integer;\r\nbegin\r\n Result := FSize;\r\nend;\r\n\r\nfunction TJclUnicodeStrLinkedList.SubList(First, Count: Integer): IJclUnicodeStrList;\r\nvar\r\n Current: TJclUnicodeStrLinkedListItem;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := CreateEmptyContainer as IJclUnicodeStrList;\r\n Current := FStart;\r\n while (Current <> nil) and (First > 0) do\r\n begin\r\n Dec(First);\r\n Current := Current.Next;\r\n end;\r\n while (Current <> nil) and (Count > 0) do\r\n begin\r\n Result.Add(Current.Value);\r\n Dec(Count);\r\n Current := Current.Next;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclUnicodeStrLinkedList.CreateEmptyContainer: TJclAbstractContainerBase;\r\nbegin\r\n Result := TJclUnicodeStrLinkedList.Create(nil);\r\n AssignPropertiesTo(Result);\r\nend;\r\n\r\n{$ENDIF SUPPORTS_UNICODE_STRING}\r\n\r\n{$IFDEF SUPPORTS_UNICODE_STRING}\r\n//=== { TJclUnicodeStrLinkedListIterator } ============================================================\r\n\r\nconstructor TJclUnicodeStrLinkedListIterator.Create(AOwnList: TJclUnicodeStrLinkedList; ACursor: TJclUnicodeStrLinkedListItem; AValid: Boolean; AStart: TItrStart);\r\nbegin\r\n inherited Create(AValid);\r\n FCursor := ACursor;\r\n FOwnList := AOwnList;\r\n FStart := AStart;\r\n FEqualityComparer := AOwnList as IJclUnicodeStrEqualityComparer;\r\nend;\r\n\r\nfunction TJclUnicodeStrLinkedListIterator.Add(const AString: UnicodeString): Boolean;\r\nbegin\r\n Result := FOwnList.Add(AString);\r\nend;\r\n\r\nprocedure TJclUnicodeStrLinkedListIterator.AssignPropertiesTo(Dest: TJclAbstractIterator);\r\nvar\r\n ADest: TJclUnicodeStrLinkedListIterator;\r\nbegin\r\n inherited AssignPropertiesTo(Dest);\r\n if Dest is TJclUnicodeStrLinkedListIterator then\r\n begin\r\n ADest := TJclUnicodeStrLinkedListIterator(Dest);\r\n ADest.FCursor := FCursor;\r\n ADest.FOwnList := FOwnList;\r\n ADest.FEqualityComparer := FEqualityComparer;\r\n ADest.FStart := FStart;\r\n end;\r\nend;\r\n\r\nfunction TJclUnicodeStrLinkedListIterator.CreateEmptyIterator: TJclAbstractIterator;\r\nbegin\r\n Result := TJclUnicodeStrLinkedListIterator.Create(FOwnList, FCursor, Valid, FStart);\r\nend;\r\n\r\nprocedure TJclUnicodeStrLinkedListIterator.Extract;\r\nvar\r\n OldCursor: TJclUnicodeStrLinkedListItem;\r\nbegin\r\n if FOwnList.ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n FOwnList.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n CheckValid;\r\n Valid := False;\r\n if FCursor <> nil then\r\n begin\r\n if FCursor.Next <> nil then\r\n FCursor.Next.Previous := FCursor.Previous;\r\n if FCursor.Previous <> nil then\r\n FCursor.Previous.Next := FCursor.Next;\r\n OldCursor := FCursor;\r\n FCursor := FCursor.Next;\r\n OldCursor.Free;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnList.WriteUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclUnicodeStrLinkedListIterator.GetString: UnicodeString;\r\nbegin\r\n CheckValid;\r\n Result := '';\r\n if FCursor <> nil then\r\n Result := FCursor.Value\r\n else\r\n if not FOwnList.ReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\nend;\r\n\r\nfunction TJclUnicodeStrLinkedListIterator.HasNext: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnList.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Valid then\r\n Result := (FCursor <> nil) and (FCursor.Next <> nil)\r\n else\r\n Result := FCursor <> nil;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnList.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclUnicodeStrLinkedListIterator.HasPrevious: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnList.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Valid then\r\n Result := (FCursor <> nil) and (FCursor.Previous <> nil)\r\n else\r\n Result := FCursor <> nil;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnList.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclUnicodeStrLinkedListIterator.Insert(const AString: UnicodeString): Boolean;\r\nvar\r\n NewCursor: TJclUnicodeStrLinkedListItem;\r\nbegin\r\n if FOwnList.ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n FOwnList.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n CheckValid;\r\n Result := FCursor <> nil;\r\n if Result then\r\n begin\r\n Result := FOwnList.AllowDefaultElements or not FEqualityComparer.ItemsEqual(AString, '');\r\n if Result then\r\n begin\r\n case FOwnList.Duplicates of\r\n dupIgnore:\r\n Result := not FOwnList.Contains(AString);\r\n dupAccept:\r\n Result := True;\r\n dupError:\r\n begin\r\n Result := FOwnList.Contains(AString);\r\n if not Result then\r\n raise EJclDuplicateElementError.Create;\r\n end;\r\n end;\r\n if Result then\r\n begin\r\n NewCursor := TJclUnicodeStrLinkedListItem.Create;\r\n NewCursor.Value := AString;\r\n NewCursor.Next := FCursor;\r\n NewCursor.Previous := FCursor.Previous;\r\n if FCursor.Previous <> nil then\r\n FCursor.Previous.Next := NewCursor;\r\n FCursor.Previous := NewCursor;\r\n FCursor := NewCursor;\r\n end;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnList.WriteUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclUnicodeStrLinkedListIterator.IteratorEquals(const AIterator: IJclUnicodeStrIterator): Boolean;\r\nvar\r\n Obj: TObject;\r\n ItrObj: TJclUnicodeStrLinkedListIterator;\r\nbegin\r\n Result := False;\r\n if AIterator = nil then\r\n Exit;\r\n Obj := AIterator.GetIteratorReference;\r\n if Obj is TJclUnicodeStrLinkedListIterator then\r\n begin\r\n ItrObj := TJclUnicodeStrLinkedListIterator(Obj);\r\n Result := (FOwnList = ItrObj.FOwnList) and (FCursor = ItrObj.FCursor) and (Valid = ItrObj.Valid);\r\n end;\r\nend;\r\n\r\n{$IFDEF SUPPORTS_FOR_IN}\r\nfunction TJclUnicodeStrLinkedListIterator.MoveNext: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnList.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Valid and (FCursor <> nil) then\r\n FCursor := FCursor.Next\r\n else\r\n Valid := True;\r\n Result := FCursor <> nil;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnList.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n{$ENDIF SUPPORTS_FOR_IN}\r\n\r\nfunction TJclUnicodeStrLinkedListIterator.Next: UnicodeString;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnList.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Valid and (FCursor <> nil) then\r\n FCursor := FCursor.Next\r\n else\r\n Valid := True;\r\n if FCursor <> nil then\r\n Result := FCursor.Value\r\n else\r\n Result := '';\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnList.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclUnicodeStrLinkedListIterator.NextIndex: Integer;\r\nbegin\r\n // No Index\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nfunction TJclUnicodeStrLinkedListIterator.Previous: UnicodeString;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnList.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Valid and (FCursor <> nil) then\r\n FCursor := FCursor.Previous\r\n else\r\n Valid := True;\r\n if FCursor <> nil then\r\n Result := FCursor.Value\r\n else\r\n Result := '';\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnList.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclUnicodeStrLinkedListIterator.PreviousIndex: Integer;\r\nbegin\r\n // No Index\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nprocedure TJclUnicodeStrLinkedListIterator.Remove;\r\nvar\r\n OldCursor: TJclUnicodeStrLinkedListItem;\r\nbegin\r\n if FOwnList.ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n FOwnList.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n CheckValid;\r\n Valid := False;\r\n if FCursor <> nil then\r\n begin\r\n FCursor.Value := '';\r\n if FCursor.Next <> nil then\r\n FCursor.Next.Previous := FCursor.Previous;\r\n if FCursor.Previous <> nil then\r\n FCursor.Previous.Next := FCursor.Next;\r\n OldCursor := FCursor;\r\n FCursor := FCursor.Next;\r\n OldCursor.Free;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnList.WriteUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclUnicodeStrLinkedListIterator.Reset;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnList.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Valid := False;\r\n case FStart of\r\n isFirst:\r\n begin\r\n while (FCursor <> nil) and (FCursor.Previous <> nil) do\r\n FCursor := FCursor.Previous;\r\n end;\r\n isLast:\r\n begin\r\n while (FCursor <> nil) and (FCursor.Next <> nil) do\r\n FCursor := FCursor.Next;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnList.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclUnicodeStrLinkedListIterator.SetString(const AString: UnicodeString);\r\nbegin\r\n if FOwnList.ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n FOwnList.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n CheckValid;\r\n FCursor.Value := '';\r\n FCursor.Value := AString;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnList.WriteUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n{$ENDIF SUPPORTS_UNICODE_STRING}\r\n\r\n//=== { TJclSingleLinkedList } ==================================================\r\n\r\nconstructor TJclSingleLinkedList.Create(const ACollection: IJclSingleCollection);\r\nbegin\r\n inherited Create();\r\n FStart := nil;\r\n FEnd := nil;\r\n if ACollection <> nil then\r\n AddAll(ACollection);\r\nend;\r\n\r\ndestructor TJclSingleLinkedList.Destroy;\r\nbegin\r\n FReadOnly := False;\r\n Clear;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJclSingleLinkedList.Add(const AValue: Single): Boolean;\r\nvar\r\n NewItem: TJclSingleLinkedListItem;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := FAllowDefaultElements or not ItemsEqual(AValue, 0.0);\r\n if Result then\r\n begin\r\n if FDuplicates <> dupAccept then\r\n begin\r\n NewItem := FStart;\r\n while NewItem <> nil do\r\n begin\r\n if ItemsEqual(AValue, NewItem.Value) then\r\n begin\r\n Result := CheckDuplicate;\r\n Break;\r\n end;\r\n NewItem := NewItem.Next;\r\n end;\r\n end;\r\n if Result then\r\n begin\r\n NewItem := TJclSingleLinkedListItem.Create;\r\n NewItem.Value := AValue;\r\n if FStart <> nil then\r\n begin\r\n NewItem.Next := nil;\r\n NewItem.Previous := FEnd;\r\n FEnd.Next := NewItem;\r\n FEnd := NewItem;\r\n end\r\n else\r\n begin\r\n FStart := NewItem;\r\n FEnd := NewItem;\r\n end;\r\n Inc(FSize);\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSingleLinkedList.AddAll(const ACollection: IJclSingleCollection): Boolean;\r\nvar\r\n It: IJclSingleIterator;\r\n Item: Single;\r\n AddItem: Boolean;\r\n NewItem: TJclSingleLinkedListItem;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n begin\r\n Item := It.Next;\r\n AddItem := FAllowDefaultElements or not ItemsEqual(Item, 0.0);\r\n if AddItem then\r\n begin\r\n if FDuplicates <> dupAccept then\r\n begin\r\n NewItem := FStart;\r\n while NewItem <> nil do\r\n begin\r\n if ItemsEqual(Item, NewItem.Value) then\r\n begin\r\n AddItem := CheckDuplicate;\r\n Break;\r\n end;\r\n NewItem := NewItem.Next;\r\n end;\r\n end;\r\n if AddItem then\r\n begin\r\n NewItem := TJclSingleLinkedListItem.Create;\r\n NewItem.Value := Item;\r\n if FStart <> nil then\r\n begin\r\n NewItem.Next := nil;\r\n NewItem.Previous := FEnd;\r\n FEnd.Next := NewItem;\r\n FEnd := NewItem;\r\n end\r\n else\r\n begin\r\n FStart := NewItem;\r\n FEnd := NewItem;\r\n end;\r\n Inc(FSize);\r\n end;\r\n end;\r\n Result := AddItem and Result;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclSingleLinkedList.AssignDataTo(Dest: TJclAbstractContainerBase);\r\nvar\r\n ACollection: IJclSingleCollection;\r\nbegin\r\n inherited AssignDataTo(Dest);\r\n if Supports(IInterface(Dest), IJclSingleCollection, ACollection) then\r\n begin\r\n ACollection.Clear;\r\n ACollection.AddAll(Self);\r\n end;\r\nend;\r\n\r\nprocedure TJclSingleLinkedList.Clear;\r\nvar\r\n Old, Current: TJclSingleLinkedListItem;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Current := FStart;\r\n while Current <> nil do\r\n begin\r\n FreeSingle(Current.Value);\r\n Old := Current;\r\n Current := Current.Next;\r\n Old.Free;\r\n end;\r\n FSize := 0;\r\n\r\n //Daniele Teti 27/12/2004\r\n FStart := nil;\r\n FEnd := nil;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSingleLinkedList.CollectionEquals(const ACollection: IJclSingleCollection): Boolean;\r\nvar\r\n It, ItSelf: IJclSingleIterator;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n if FSize <> ACollection.Size then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n ItSelf := First;\r\n while ItSelf.HasNext and It.HasNext do\r\n if not ItemsEqual(ItSelf.Next, It.Next) then\r\n begin\r\n Result := False;\r\n Break;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSingleLinkedList.Contains(const AValue: Single): Boolean;\r\nvar\r\n Current: TJclSingleLinkedListItem;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n Current := FStart;\r\n while Current <> nil do\r\n begin\r\n if ItemsEqual(Current.Value, AValue) then\r\n begin\r\n Result := True;\r\n Break;\r\n end;\r\n Current := Current.Next;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSingleLinkedList.ContainsAll(const ACollection: IJclSingleCollection): Boolean;\r\nvar\r\n It: IJclSingleIterator;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n while Result and It.HasNext do\r\n Result := Contains(It.Next);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSingleLinkedList.Delete(Index: Integer): Single;\r\nvar\r\n Current: TJclSingleLinkedListItem;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := 0.0;\r\n if (Index >= 0) and (Index < FSize) then\r\n begin\r\n Current := FStart;\r\n while Current <> nil do\r\n begin\r\n if Index = 0 then\r\n begin\r\n if Current.Previous <> nil then\r\n Current.Previous.Next := Current.Next\r\n else\r\n FStart := Current.Next;\r\n if Current.Next <> nil then\r\n Current.Next.Previous := Current.Previous\r\n else\r\n FEnd := Current.Previous;\r\n Result := FreeSingle(Current.Value);\r\n Current.Free;\r\n Dec(FSize);\r\n Break;\r\n end;\r\n Dec(Index);\r\n Current := Current.Next;\r\n end;\r\n end\r\n else\r\n raise EJclOutOfBoundsError.Create;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSingleLinkedList.Extract(const AValue: Single): Boolean;\r\nvar\r\n Current: TJclSingleLinkedListItem;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n Current := FStart;\r\n while Current <> nil do\r\n begin\r\n if ItemsEqual(Current.Value, AValue) then\r\n begin\r\n if Current.Previous <> nil then\r\n Current.Previous.Next := Current.Next\r\n else\r\n FStart := Current.Next;\r\n if Current.Next <> nil then\r\n Current.Next.Previous := Current.Previous\r\n else\r\n FEnd := Current.Previous;\r\n Current.Value := 0.0;\r\n Current.Free;\r\n Dec(FSize);\r\n Result := True;\r\n if FRemoveSingleElement then\r\n Break;\r\n end;\r\n Current := Current.Next;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSingleLinkedList.ExtractAll(const ACollection: IJclSingleCollection): Boolean;\r\nvar\r\n It: IJclSingleIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := True;\r\n if ACollection = nil then\r\n Exit;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n Result := Extract(It.Next) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSingleLinkedList.ExtractIndex(Index: Integer): Single;\r\nvar\r\n Current: TJclSingleLinkedListItem;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := 0.0;\r\n if (Index >= 0) and (Index < FSize) then\r\n begin\r\n Current := FStart;\r\n while Current <> nil do\r\n begin\r\n if Index = 0 then\r\n begin\r\n if Current.Previous <> nil then\r\n Current.Previous.Next := Current.Next\r\n else\r\n FStart := Current.Next;\r\n if Current.Next <> nil then\r\n Current.Next.Previous := Current.Previous\r\n else\r\n FEnd := Current.Previous;\r\n Result := Current.Value;\r\n Current.Free;\r\n Dec(FSize);\r\n Break;\r\n end;\r\n Dec(Index);\r\n Current := Current.Next;\r\n end;\r\n end\r\n else\r\n raise EJclOutOfBoundsError.Create;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSingleLinkedList.First: IJclSingleIterator;\r\nbegin\r\n Result := TJclSingleLinkedListIterator.Create(Self, FStart, False, isFirst);\r\nend;\r\n\r\n{$IFDEF SUPPORTS_FOR_IN}\r\nfunction TJclSingleLinkedList.GetEnumerator: IJclSingleIterator;\r\nbegin\r\n Result := TJclSingleLinkedListIterator.Create(Self, FStart, False, isFirst);\r\nend;\r\n{$ENDIF SUPPORTS_FOR_IN}\r\n\r\nfunction TJclSingleLinkedList.GetValue(Index: Integer): Single;\r\nvar\r\n Current: TJclSingleLinkedListItem;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := 0.0;\r\n Current := FStart;\r\n while (Current <> nil) and (Index > 0) do\r\n begin\r\n Current := Current.Next;\r\n Dec(Index);\r\n end;\r\n if Current <> nil then\r\n Result := Current.Value\r\n else\r\n if not FReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSingleLinkedList.IndexOf(const AValue: Single): Integer;\r\nvar\r\n Current: TJclSingleLinkedListItem;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Current := FStart;\r\n Result := 0;\r\n while (Current <> nil) and not ItemsEqual(Current.Value, AValue) do\r\n begin\r\n Inc(Result);\r\n Current := Current.Next;\r\n end;\r\n if Current = nil then\r\n Result := -1;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSingleLinkedList.Insert(Index: Integer; const AValue: Single): Boolean;\r\nvar\r\n Current, NewItem: TJclSingleLinkedListItem;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := FAllowDefaultElements or not ItemsEqual(AValue, 0.0);\r\n if (Index < 0) or (Index > FSize) then\r\n raise EJclOutOfBoundsError.Create;\r\n if Result then\r\n begin\r\n if FDuplicates <> dupAccept then\r\n begin\r\n Current := FStart;\r\n while Current <> nil do\r\n begin\r\n if ItemsEqual(AValue, Current.Value) then\r\n begin\r\n Result := CheckDuplicate;\r\n Break;\r\n end;\r\n Current := Current.Next;\r\n end;\r\n end;\r\n if Result then\r\n begin\r\n NewItem := TJclSingleLinkedListItem.Create;\r\n NewItem.Value := AValue;\r\n if Index = 0 then\r\n begin\r\n NewItem.Next := FStart;\r\n if FStart <> nil then\r\n FStart.Previous := NewItem;\r\n FStart := NewItem;\r\n if FSize = 0 then\r\n FEnd := NewItem;\r\n Inc(FSize);\r\n end\r\n else\r\n if Index = FSize then\r\n begin\r\n NewItem.Previous := FEnd;\r\n FEnd.Next := NewItem;\r\n FEnd := NewItem;\r\n Inc(FSize);\r\n end\r\n else\r\n begin\r\n Current := FStart;\r\n while (Current <> nil) and (Index > 0) do\r\n begin\r\n Current := Current.Next;\r\n Dec(Index);\r\n end;\r\n if Current <> nil then\r\n begin\r\n NewItem.Next := Current;\r\n NewItem.Previous := Current.Previous;\r\n if Current.Previous <> nil then\r\n Current.Previous.Next := NewItem;\r\n Current.Previous := NewItem;\r\n Inc(FSize);\r\n end;\r\n end;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSingleLinkedList.InsertAll(Index: Integer; const ACollection: IJclSingleCollection): Boolean;\r\nvar\r\n It: IJclSingleIterator;\r\n Current, NewItem, Test: TJclSingleLinkedListItem;\r\n AddItem: Boolean;\r\n Item: Single;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if (Index < 0) or (Index > FSize) then\r\n raise EJclOutOfBoundsError.Create;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n if Index = 0 then\r\n begin\r\n It := ACollection.Last;\r\n while It.HasPrevious do\r\n begin\r\n Item := It.Previous;\r\n AddItem := FAllowDefaultElements or not ItemsEqual(Item, 0.0);\r\n if AddItem then\r\n begin\r\n if FDuplicates <> dupAccept then\r\n begin\r\n Test := FStart;\r\n while Test <> nil do\r\n begin\r\n if ItemsEqual(Item, Test.Value) then\r\n begin\r\n Result := CheckDuplicate;\r\n Break;\r\n end;\r\n Test := Test.Next;\r\n end;\r\n end;\r\n if AddItem then\r\n begin\r\n NewItem := TJclSingleLinkedListItem.Create;\r\n NewItem.Value := Item;\r\n NewItem.Next := FStart;\r\n if FStart <> nil then\r\n FStart.Previous := NewItem;\r\n FStart := NewItem;\r\n if FSize = 0 then\r\n FEnd := NewItem;\r\n Inc(FSize);\r\n end;\r\n end;\r\n Result := Result and AddItem;\r\n end;\r\n end\r\n else\r\n if Index = Size then\r\n begin\r\n It := ACollection.First;\r\n while It.HasNext do\r\n begin\r\n Item := It.Next;\r\n AddItem := FAllowDefaultElements or not ItemsEqual(Item, 0.0);\r\n if AddItem then\r\n begin\r\n if FDuplicates <> dupAccept then\r\n begin\r\n Test := FStart;\r\n while Test <> nil do\r\n begin\r\n if ItemsEqual(Item, Test.Value) then\r\n begin\r\n Result := CheckDuplicate;\r\n Break;\r\n end;\r\n Test := Test.Next;\r\n end;\r\n end;\r\n if AddItem then\r\n begin\r\n NewItem := TJclSingleLinkedListItem.Create;\r\n NewItem.Value := Item;\r\n NewItem.Previous := FEnd;\r\n if FEnd <> nil then\r\n FEnd.Next := NewItem;\r\n FEnd := NewItem;\r\n Inc(FSize);\r\n end;\r\n end;\r\n Result := Result and AddItem;\r\n end;\r\n end\r\n else\r\n begin\r\n Current := FStart;\r\n while (Current <> nil) and (Index > 0) do\r\n begin\r\n Current := Current.Next;\r\n Dec(Index);\r\n end;\r\n if Current <> nil then\r\n begin\r\n It := ACollection.First;\r\n while It.HasNext do\r\n begin\r\n Item := It.Next;\r\n AddItem := FAllowDefaultElements or not ItemsEqual(Item, 0.0);\r\n if AddItem then\r\n begin\r\n if FDuplicates <> dupAccept then\r\n begin\r\n Test := FStart;\r\n while Test <> nil do\r\n begin\r\n if ItemsEqual(Item, Test.Value) then\r\n begin\r\n Result := CheckDuplicate;\r\n Break;\r\n end;\r\n Test := Test.Next;\r\n end;\r\n end;\r\n if AddItem then\r\n begin\r\n NewItem := TJclSingleLinkedListItem.Create;\r\n NewItem.Value := Item;\r\n NewItem.Next := Current;\r\n NewItem.Previous := Current.Previous;\r\n if Current.Previous <> nil then\r\n Current.Previous.Next := NewItem;\r\n Current.Previous := NewItem;\r\n Inc(FSize);\r\n end;\r\n end;\r\n Result := Result and AddItem;\r\n end;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSingleLinkedList.IsEmpty: Boolean;\r\nbegin\r\n Result := FSize = 0;\r\nend;\r\n\r\nfunction TJclSingleLinkedList.Last: IJclSingleIterator;\r\nbegin\r\n Result := TJclSingleLinkedListIterator.Create(Self, FEnd, False, isLast);\r\nend;\r\n\r\nfunction TJclSingleLinkedList.LastIndexOf(const AValue: Single): Integer;\r\nvar\r\n Current: TJclSingleLinkedListItem;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := -1;\r\n if FEnd <> nil then\r\n begin\r\n Current := FEnd;\r\n Result := FSize - 1;\r\n while (Current <> nil) and not ItemsEqual(Current.Value, AValue) do\r\n begin\r\n Dec(Result);\r\n Current := Current.Previous;\r\n end;\r\n if Current = nil then\r\n Result := -1;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSingleLinkedList.Remove(const AValue: Single): Boolean;\r\nvar\r\n Extracted: Single;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := Extract(AValue);\r\n if Result then\r\n begin\r\n Extracted := AValue;\r\n FreeSingle(Extracted);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSingleLinkedList.RemoveAll(const ACollection: IJclSingleCollection): Boolean;\r\nvar\r\n It: IJclSingleIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := True;\r\n if ACollection = nil then\r\n Exit;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n Result := Remove(It.Next) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSingleLinkedList.RetainAll(const ACollection: IJclSingleCollection): Boolean;\r\nvar\r\n It: IJclSingleIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := First;\r\n while It.HasNext do\r\n if not ACollection.Contains(It.Next) then\r\n It.Remove;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclSingleLinkedList.SetValue(Index: Integer; const AValue: Single);\r\nvar\r\n Current: TJclSingleLinkedListItem;\r\n ReplaceItem: Boolean;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n ReplaceItem := FAllowDefaultElements or not ItemsEqual(AValue, 0.0);\r\n if ReplaceItem then\r\n begin\r\n if FDuplicates <> dupAccept then\r\n begin\r\n Current := FStart;\r\n while Current <> nil do\r\n begin\r\n if ItemsEqual(AValue, Current.Value) then\r\n begin\r\n ReplaceItem := CheckDuplicate;\r\n Break;\r\n end;\r\n Current := Current.Next;\r\n end;\r\n end;\r\n if ReplaceItem then\r\n begin\r\n Current := FStart;\r\n while Current <> nil do\r\n begin\r\n if Index = 0 then\r\n begin\r\n FreeSingle(Current.Value);\r\n Current.Value := AValue;\r\n Break;\r\n end;\r\n Dec(Index);\r\n Current := Current.Next;\r\n end;\r\n end;\r\n end;\r\n if not ReplaceItem then\r\n Delete(Index);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSingleLinkedList.Size: Integer;\r\nbegin\r\n Result := FSize;\r\nend;\r\n\r\nfunction TJclSingleLinkedList.SubList(First, Count: Integer): IJclSingleList;\r\nvar\r\n Current: TJclSingleLinkedListItem;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := CreateEmptyContainer as IJclSingleList;\r\n Current := FStart;\r\n while (Current <> nil) and (First > 0) do\r\n begin\r\n Dec(First);\r\n Current := Current.Next;\r\n end;\r\n while (Current <> nil) and (Count > 0) do\r\n begin\r\n Result.Add(Current.Value);\r\n Dec(Count);\r\n Current := Current.Next;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSingleLinkedList.CreateEmptyContainer: TJclAbstractContainerBase;\r\nbegin\r\n Result := TJclSingleLinkedList.Create(nil);\r\n AssignPropertiesTo(Result);\r\nend;\r\n\r\n//=== { TJclSingleLinkedListIterator } ============================================================\r\n\r\nconstructor TJclSingleLinkedListIterator.Create(AOwnList: TJclSingleLinkedList; ACursor: TJclSingleLinkedListItem; AValid: Boolean; AStart: TItrStart);\r\nbegin\r\n inherited Create(AValid);\r\n FCursor := ACursor;\r\n FOwnList := AOwnList;\r\n FStart := AStart;\r\n FEqualityComparer := AOwnList as IJclSingleEqualityComparer;\r\nend;\r\n\r\nfunction TJclSingleLinkedListIterator.Add(const AValue: Single): Boolean;\r\nbegin\r\n Result := FOwnList.Add(AValue);\r\nend;\r\n\r\nprocedure TJclSingleLinkedListIterator.AssignPropertiesTo(Dest: TJclAbstractIterator);\r\nvar\r\n ADest: TJclSingleLinkedListIterator;\r\nbegin\r\n inherited AssignPropertiesTo(Dest);\r\n if Dest is TJclSingleLinkedListIterator then\r\n begin\r\n ADest := TJclSingleLinkedListIterator(Dest);\r\n ADest.FCursor := FCursor;\r\n ADest.FOwnList := FOwnList;\r\n ADest.FEqualityComparer := FEqualityComparer;\r\n ADest.FStart := FStart;\r\n end;\r\nend;\r\n\r\nfunction TJclSingleLinkedListIterator.CreateEmptyIterator: TJclAbstractIterator;\r\nbegin\r\n Result := TJclSingleLinkedListIterator.Create(FOwnList, FCursor, Valid, FStart);\r\nend;\r\n\r\nprocedure TJclSingleLinkedListIterator.Extract;\r\nvar\r\n OldCursor: TJclSingleLinkedListItem;\r\nbegin\r\n if FOwnList.ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n FOwnList.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n CheckValid;\r\n Valid := False;\r\n if FCursor <> nil then\r\n begin\r\n if FCursor.Next <> nil then\r\n FCursor.Next.Previous := FCursor.Previous;\r\n if FCursor.Previous <> nil then\r\n FCursor.Previous.Next := FCursor.Next;\r\n OldCursor := FCursor;\r\n FCursor := FCursor.Next;\r\n OldCursor.Free;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnList.WriteUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSingleLinkedListIterator.GetValue: Single;\r\nbegin\r\n CheckValid;\r\n Result := 0.0;\r\n if FCursor <> nil then\r\n Result := FCursor.Value\r\n else\r\n if not FOwnList.ReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\nend;\r\n\r\nfunction TJclSingleLinkedListIterator.HasNext: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnList.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Valid then\r\n Result := (FCursor <> nil) and (FCursor.Next <> nil)\r\n else\r\n Result := FCursor <> nil;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnList.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSingleLinkedListIterator.HasPrevious: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnList.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Valid then\r\n Result := (FCursor <> nil) and (FCursor.Previous <> nil)\r\n else\r\n Result := FCursor <> nil;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnList.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSingleLinkedListIterator.Insert(const AValue: Single): Boolean;\r\nvar\r\n NewCursor: TJclSingleLinkedListItem;\r\nbegin\r\n if FOwnList.ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n FOwnList.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n CheckValid;\r\n Result := FCursor <> nil;\r\n if Result then\r\n begin\r\n Result := FOwnList.AllowDefaultElements or not FEqualityComparer.ItemsEqual(AValue, 0.0);\r\n if Result then\r\n begin\r\n case FOwnList.Duplicates of\r\n dupIgnore:\r\n Result := not FOwnList.Contains(AValue);\r\n dupAccept:\r\n Result := True;\r\n dupError:\r\n begin\r\n Result := FOwnList.Contains(AValue);\r\n if not Result then\r\n raise EJclDuplicateElementError.Create;\r\n end;\r\n end;\r\n if Result then\r\n begin\r\n NewCursor := TJclSingleLinkedListItem.Create;\r\n NewCursor.Value := AValue;\r\n NewCursor.Next := FCursor;\r\n NewCursor.Previous := FCursor.Previous;\r\n if FCursor.Previous <> nil then\r\n FCursor.Previous.Next := NewCursor;\r\n FCursor.Previous := NewCursor;\r\n FCursor := NewCursor;\r\n end;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnList.WriteUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSingleLinkedListIterator.IteratorEquals(const AIterator: IJclSingleIterator): Boolean;\r\nvar\r\n Obj: TObject;\r\n ItrObj: TJclSingleLinkedListIterator;\r\nbegin\r\n Result := False;\r\n if AIterator = nil then\r\n Exit;\r\n Obj := AIterator.GetIteratorReference;\r\n if Obj is TJclSingleLinkedListIterator then\r\n begin\r\n ItrObj := TJclSingleLinkedListIterator(Obj);\r\n Result := (FOwnList = ItrObj.FOwnList) and (FCursor = ItrObj.FCursor) and (Valid = ItrObj.Valid);\r\n end;\r\nend;\r\n\r\n{$IFDEF SUPPORTS_FOR_IN}\r\nfunction TJclSingleLinkedListIterator.MoveNext: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnList.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Valid and (FCursor <> nil) then\r\n FCursor := FCursor.Next\r\n else\r\n Valid := True;\r\n Result := FCursor <> nil;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnList.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n{$ENDIF SUPPORTS_FOR_IN}\r\n\r\nfunction TJclSingleLinkedListIterator.Next: Single;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnList.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Valid and (FCursor <> nil) then\r\n FCursor := FCursor.Next\r\n else\r\n Valid := True;\r\n if FCursor <> nil then\r\n Result := FCursor.Value\r\n else\r\n Result := 0.0;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnList.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSingleLinkedListIterator.NextIndex: Integer;\r\nbegin\r\n // No Index\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nfunction TJclSingleLinkedListIterator.Previous: Single;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnList.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Valid and (FCursor <> nil) then\r\n FCursor := FCursor.Previous\r\n else\r\n Valid := True;\r\n if FCursor <> nil then\r\n Result := FCursor.Value\r\n else\r\n Result := 0.0;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnList.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSingleLinkedListIterator.PreviousIndex: Integer;\r\nbegin\r\n // No Index\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nprocedure TJclSingleLinkedListIterator.Remove;\r\nvar\r\n OldCursor: TJclSingleLinkedListItem;\r\nbegin\r\n if FOwnList.ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n FOwnList.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n CheckValid;\r\n Valid := False;\r\n if FCursor <> nil then\r\n begin\r\n FCursor.Value := 0.0;\r\n if FCursor.Next <> nil then\r\n FCursor.Next.Previous := FCursor.Previous;\r\n if FCursor.Previous <> nil then\r\n FCursor.Previous.Next := FCursor.Next;\r\n OldCursor := FCursor;\r\n FCursor := FCursor.Next;\r\n OldCursor.Free;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnList.WriteUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclSingleLinkedListIterator.Reset;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnList.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Valid := False;\r\n case FStart of\r\n isFirst:\r\n begin\r\n while (FCursor <> nil) and (FCursor.Previous <> nil) do\r\n FCursor := FCursor.Previous;\r\n end;\r\n isLast:\r\n begin\r\n while (FCursor <> nil) and (FCursor.Next <> nil) do\r\n FCursor := FCursor.Next;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnList.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclSingleLinkedListIterator.SetValue(const AValue: Single);\r\nbegin\r\n if FOwnList.ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n FOwnList.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n CheckValid;\r\n FCursor.Value := 0.0;\r\n FCursor.Value := AValue;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnList.WriteUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\n//=== { TJclDoubleLinkedList } ==================================================\r\n\r\nconstructor TJclDoubleLinkedList.Create(const ACollection: IJclDoubleCollection);\r\nbegin\r\n inherited Create();\r\n FStart := nil;\r\n FEnd := nil;\r\n if ACollection <> nil then\r\n AddAll(ACollection);\r\nend;\r\n\r\ndestructor TJclDoubleLinkedList.Destroy;\r\nbegin\r\n FReadOnly := False;\r\n Clear;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJclDoubleLinkedList.Add(const AValue: Double): Boolean;\r\nvar\r\n NewItem: TJclDoubleLinkedListItem;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := FAllowDefaultElements or not ItemsEqual(AValue, 0.0);\r\n if Result then\r\n begin\r\n if FDuplicates <> dupAccept then\r\n begin\r\n NewItem := FStart;\r\n while NewItem <> nil do\r\n begin\r\n if ItemsEqual(AValue, NewItem.Value) then\r\n begin\r\n Result := CheckDuplicate;\r\n Break;\r\n end;\r\n NewItem := NewItem.Next;\r\n end;\r\n end;\r\n if Result then\r\n begin\r\n NewItem := TJclDoubleLinkedListItem.Create;\r\n NewItem.Value := AValue;\r\n if FStart <> nil then\r\n begin\r\n NewItem.Next := nil;\r\n NewItem.Previous := FEnd;\r\n FEnd.Next := NewItem;\r\n FEnd := NewItem;\r\n end\r\n else\r\n begin\r\n FStart := NewItem;\r\n FEnd := NewItem;\r\n end;\r\n Inc(FSize);\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclDoubleLinkedList.AddAll(const ACollection: IJclDoubleCollection): Boolean;\r\nvar\r\n It: IJclDoubleIterator;\r\n Item: Double;\r\n AddItem: Boolean;\r\n NewItem: TJclDoubleLinkedListItem;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n begin\r\n Item := It.Next;\r\n AddItem := FAllowDefaultElements or not ItemsEqual(Item, 0.0);\r\n if AddItem then\r\n begin\r\n if FDuplicates <> dupAccept then\r\n begin\r\n NewItem := FStart;\r\n while NewItem <> nil do\r\n begin\r\n if ItemsEqual(Item, NewItem.Value) then\r\n begin\r\n AddItem := CheckDuplicate;\r\n Break;\r\n end;\r\n NewItem := NewItem.Next;\r\n end;\r\n end;\r\n if AddItem then\r\n begin\r\n NewItem := TJclDoubleLinkedListItem.Create;\r\n NewItem.Value := Item;\r\n if FStart <> nil then\r\n begin\r\n NewItem.Next := nil;\r\n NewItem.Previous := FEnd;\r\n FEnd.Next := NewItem;\r\n FEnd := NewItem;\r\n end\r\n else\r\n begin\r\n FStart := NewItem;\r\n FEnd := NewItem;\r\n end;\r\n Inc(FSize);\r\n end;\r\n end;\r\n Result := AddItem and Result;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclDoubleLinkedList.AssignDataTo(Dest: TJclAbstractContainerBase);\r\nvar\r\n ACollection: IJclDoubleCollection;\r\nbegin\r\n inherited AssignDataTo(Dest);\r\n if Supports(IInterface(Dest), IJclDoubleCollection, ACollection) then\r\n begin\r\n ACollection.Clear;\r\n ACollection.AddAll(Self);\r\n end;\r\nend;\r\n\r\nprocedure TJclDoubleLinkedList.Clear;\r\nvar\r\n Old, Current: TJclDoubleLinkedListItem;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Current := FStart;\r\n while Current <> nil do\r\n begin\r\n FreeDouble(Current.Value);\r\n Old := Current;\r\n Current := Current.Next;\r\n Old.Free;\r\n end;\r\n FSize := 0;\r\n\r\n //Daniele Teti 27/12/2004\r\n FStart := nil;\r\n FEnd := nil;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclDoubleLinkedList.CollectionEquals(const ACollection: IJclDoubleCollection): Boolean;\r\nvar\r\n It, ItSelf: IJclDoubleIterator;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n if FSize <> ACollection.Size then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n ItSelf := First;\r\n while ItSelf.HasNext and It.HasNext do\r\n if not ItemsEqual(ItSelf.Next, It.Next) then\r\n begin\r\n Result := False;\r\n Break;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclDoubleLinkedList.Contains(const AValue: Double): Boolean;\r\nvar\r\n Current: TJclDoubleLinkedListItem;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n Current := FStart;\r\n while Current <> nil do\r\n begin\r\n if ItemsEqual(Current.Value, AValue) then\r\n begin\r\n Result := True;\r\n Break;\r\n end;\r\n Current := Current.Next;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclDoubleLinkedList.ContainsAll(const ACollection: IJclDoubleCollection): Boolean;\r\nvar\r\n It: IJclDoubleIterator;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n while Result and It.HasNext do\r\n Result := Contains(It.Next);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclDoubleLinkedList.Delete(Index: Integer): Double;\r\nvar\r\n Current: TJclDoubleLinkedListItem;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := 0.0;\r\n if (Index >= 0) and (Index < FSize) then\r\n begin\r\n Current := FStart;\r\n while Current <> nil do\r\n begin\r\n if Index = 0 then\r\n begin\r\n if Current.Previous <> nil then\r\n Current.Previous.Next := Current.Next\r\n else\r\n FStart := Current.Next;\r\n if Current.Next <> nil then\r\n Current.Next.Previous := Current.Previous\r\n else\r\n FEnd := Current.Previous;\r\n Result := FreeDouble(Current.Value);\r\n Current.Free;\r\n Dec(FSize);\r\n Break;\r\n end;\r\n Dec(Index);\r\n Current := Current.Next;\r\n end;\r\n end\r\n else\r\n raise EJclOutOfBoundsError.Create;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclDoubleLinkedList.Extract(const AValue: Double): Boolean;\r\nvar\r\n Current: TJclDoubleLinkedListItem;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n Current := FStart;\r\n while Current <> nil do\r\n begin\r\n if ItemsEqual(Current.Value, AValue) then\r\n begin\r\n if Current.Previous <> nil then\r\n Current.Previous.Next := Current.Next\r\n else\r\n FStart := Current.Next;\r\n if Current.Next <> nil then\r\n Current.Next.Previous := Current.Previous\r\n else\r\n FEnd := Current.Previous;\r\n Current.Value := 0.0;\r\n Current.Free;\r\n Dec(FSize);\r\n Result := True;\r\n if FRemoveSingleElement then\r\n Break;\r\n end;\r\n Current := Current.Next;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclDoubleLinkedList.ExtractAll(const ACollection: IJclDoubleCollection): Boolean;\r\nvar\r\n It: IJclDoubleIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := True;\r\n if ACollection = nil then\r\n Exit;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n Result := Extract(It.Next) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclDoubleLinkedList.ExtractIndex(Index: Integer): Double;\r\nvar\r\n Current: TJclDoubleLinkedListItem;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := 0.0;\r\n if (Index >= 0) and (Index < FSize) then\r\n begin\r\n Current := FStart;\r\n while Current <> nil do\r\n begin\r\n if Index = 0 then\r\n begin\r\n if Current.Previous <> nil then\r\n Current.Previous.Next := Current.Next\r\n else\r\n FStart := Current.Next;\r\n if Current.Next <> nil then\r\n Current.Next.Previous := Current.Previous\r\n else\r\n FEnd := Current.Previous;\r\n Result := Current.Value;\r\n Current.Free;\r\n Dec(FSize);\r\n Break;\r\n end;\r\n Dec(Index);\r\n Current := Current.Next;\r\n end;\r\n end\r\n else\r\n raise EJclOutOfBoundsError.Create;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclDoubleLinkedList.First: IJclDoubleIterator;\r\nbegin\r\n Result := TJclDoubleLinkedListIterator.Create(Self, FStart, False, isFirst);\r\nend;\r\n\r\n{$IFDEF SUPPORTS_FOR_IN}\r\nfunction TJclDoubleLinkedList.GetEnumerator: IJclDoubleIterator;\r\nbegin\r\n Result := TJclDoubleLinkedListIterator.Create(Self, FStart, False, isFirst);\r\nend;\r\n{$ENDIF SUPPORTS_FOR_IN}\r\n\r\nfunction TJclDoubleLinkedList.GetValue(Index: Integer): Double;\r\nvar\r\n Current: TJclDoubleLinkedListItem;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := 0.0;\r\n Current := FStart;\r\n while (Current <> nil) and (Index > 0) do\r\n begin\r\n Current := Current.Next;\r\n Dec(Index);\r\n end;\r\n if Current <> nil then\r\n Result := Current.Value\r\n else\r\n if not FReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclDoubleLinkedList.IndexOf(const AValue: Double): Integer;\r\nvar\r\n Current: TJclDoubleLinkedListItem;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Current := FStart;\r\n Result := 0;\r\n while (Current <> nil) and not ItemsEqual(Current.Value, AValue) do\r\n begin\r\n Inc(Result);\r\n Current := Current.Next;\r\n end;\r\n if Current = nil then\r\n Result := -1;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclDoubleLinkedList.Insert(Index: Integer; const AValue: Double): Boolean;\r\nvar\r\n Current, NewItem: TJclDoubleLinkedListItem;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := FAllowDefaultElements or not ItemsEqual(AValue, 0.0);\r\n if (Index < 0) or (Index > FSize) then\r\n raise EJclOutOfBoundsError.Create;\r\n if Result then\r\n begin\r\n if FDuplicates <> dupAccept then\r\n begin\r\n Current := FStart;\r\n while Current <> nil do\r\n begin\r\n if ItemsEqual(AValue, Current.Value) then\r\n begin\r\n Result := CheckDuplicate;\r\n Break;\r\n end;\r\n Current := Current.Next;\r\n end;\r\n end;\r\n if Result then\r\n begin\r\n NewItem := TJclDoubleLinkedListItem.Create;\r\n NewItem.Value := AValue;\r\n if Index = 0 then\r\n begin\r\n NewItem.Next := FStart;\r\n if FStart <> nil then\r\n FStart.Previous := NewItem;\r\n FStart := NewItem;\r\n if FSize = 0 then\r\n FEnd := NewItem;\r\n Inc(FSize);\r\n end\r\n else\r\n if Index = FSize then\r\n begin\r\n NewItem.Previous := FEnd;\r\n FEnd.Next := NewItem;\r\n FEnd := NewItem;\r\n Inc(FSize);\r\n end\r\n else\r\n begin\r\n Current := FStart;\r\n while (Current <> nil) and (Index > 0) do\r\n begin\r\n Current := Current.Next;\r\n Dec(Index);\r\n end;\r\n if Current <> nil then\r\n begin\r\n NewItem.Next := Current;\r\n NewItem.Previous := Current.Previous;\r\n if Current.Previous <> nil then\r\n Current.Previous.Next := NewItem;\r\n Current.Previous := NewItem;\r\n Inc(FSize);\r\n end;\r\n end;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclDoubleLinkedList.InsertAll(Index: Integer; const ACollection: IJclDoubleCollection): Boolean;\r\nvar\r\n It: IJclDoubleIterator;\r\n Current, NewItem, Test: TJclDoubleLinkedListItem;\r\n AddItem: Boolean;\r\n Item: Double;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if (Index < 0) or (Index > FSize) then\r\n raise EJclOutOfBoundsError.Create;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n if Index = 0 then\r\n begin\r\n It := ACollection.Last;\r\n while It.HasPrevious do\r\n begin\r\n Item := It.Previous;\r\n AddItem := FAllowDefaultElements or not ItemsEqual(Item, 0.0);\r\n if AddItem then\r\n begin\r\n if FDuplicates <> dupAccept then\r\n begin\r\n Test := FStart;\r\n while Test <> nil do\r\n begin\r\n if ItemsEqual(Item, Test.Value) then\r\n begin\r\n Result := CheckDuplicate;\r\n Break;\r\n end;\r\n Test := Test.Next;\r\n end;\r\n end;\r\n if AddItem then\r\n begin\r\n NewItem := TJclDoubleLinkedListItem.Create;\r\n NewItem.Value := Item;\r\n NewItem.Next := FStart;\r\n if FStart <> nil then\r\n FStart.Previous := NewItem;\r\n FStart := NewItem;\r\n if FSize = 0 then\r\n FEnd := NewItem;\r\n Inc(FSize);\r\n end;\r\n end;\r\n Result := Result and AddItem;\r\n end;\r\n end\r\n else\r\n if Index = Size then\r\n begin\r\n It := ACollection.First;\r\n while It.HasNext do\r\n begin\r\n Item := It.Next;\r\n AddItem := FAllowDefaultElements or not ItemsEqual(Item, 0.0);\r\n if AddItem then\r\n begin\r\n if FDuplicates <> dupAccept then\r\n begin\r\n Test := FStart;\r\n while Test <> nil do\r\n begin\r\n if ItemsEqual(Item, Test.Value) then\r\n begin\r\n Result := CheckDuplicate;\r\n Break;\r\n end;\r\n Test := Test.Next;\r\n end;\r\n end;\r\n if AddItem then\r\n begin\r\n NewItem := TJclDoubleLinkedListItem.Create;\r\n NewItem.Value := Item;\r\n NewItem.Previous := FEnd;\r\n if FEnd <> nil then\r\n FEnd.Next := NewItem;\r\n FEnd := NewItem;\r\n Inc(FSize);\r\n end;\r\n end;\r\n Result := Result and AddItem;\r\n end;\r\n end\r\n else\r\n begin\r\n Current := FStart;\r\n while (Current <> nil) and (Index > 0) do\r\n begin\r\n Current := Current.Next;\r\n Dec(Index);\r\n end;\r\n if Current <> nil then\r\n begin\r\n It := ACollection.First;\r\n while It.HasNext do\r\n begin\r\n Item := It.Next;\r\n AddItem := FAllowDefaultElements or not ItemsEqual(Item, 0.0);\r\n if AddItem then\r\n begin\r\n if FDuplicates <> dupAccept then\r\n begin\r\n Test := FStart;\r\n while Test <> nil do\r\n begin\r\n if ItemsEqual(Item, Test.Value) then\r\n begin\r\n Result := CheckDuplicate;\r\n Break;\r\n end;\r\n Test := Test.Next;\r\n end;\r\n end;\r\n if AddItem then\r\n begin\r\n NewItem := TJclDoubleLinkedListItem.Create;\r\n NewItem.Value := Item;\r\n NewItem.Next := Current;\r\n NewItem.Previous := Current.Previous;\r\n if Current.Previous <> nil then\r\n Current.Previous.Next := NewItem;\r\n Current.Previous := NewItem;\r\n Inc(FSize);\r\n end;\r\n end;\r\n Result := Result and AddItem;\r\n end;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclDoubleLinkedList.IsEmpty: Boolean;\r\nbegin\r\n Result := FSize = 0;\r\nend;\r\n\r\nfunction TJclDoubleLinkedList.Last: IJclDoubleIterator;\r\nbegin\r\n Result := TJclDoubleLinkedListIterator.Create(Self, FEnd, False, isLast);\r\nend;\r\n\r\nfunction TJclDoubleLinkedList.LastIndexOf(const AValue: Double): Integer;\r\nvar\r\n Current: TJclDoubleLinkedListItem;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := -1;\r\n if FEnd <> nil then\r\n begin\r\n Current := FEnd;\r\n Result := FSize - 1;\r\n while (Current <> nil) and not ItemsEqual(Current.Value, AValue) do\r\n begin\r\n Dec(Result);\r\n Current := Current.Previous;\r\n end;\r\n if Current = nil then\r\n Result := -1;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclDoubleLinkedList.Remove(const AValue: Double): Boolean;\r\nvar\r\n Extracted: Double;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := Extract(AValue);\r\n if Result then\r\n begin\r\n Extracted := AValue;\r\n FreeDouble(Extracted);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclDoubleLinkedList.RemoveAll(const ACollection: IJclDoubleCollection): Boolean;\r\nvar\r\n It: IJclDoubleIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := True;\r\n if ACollection = nil then\r\n Exit;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n Result := Remove(It.Next) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclDoubleLinkedList.RetainAll(const ACollection: IJclDoubleCollection): Boolean;\r\nvar\r\n It: IJclDoubleIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := First;\r\n while It.HasNext do\r\n if not ACollection.Contains(It.Next) then\r\n It.Remove;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclDoubleLinkedList.SetValue(Index: Integer; const AValue: Double);\r\nvar\r\n Current: TJclDoubleLinkedListItem;\r\n ReplaceItem: Boolean;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n ReplaceItem := FAllowDefaultElements or not ItemsEqual(AValue, 0.0);\r\n if ReplaceItem then\r\n begin\r\n if FDuplicates <> dupAccept then\r\n begin\r\n Current := FStart;\r\n while Current <> nil do\r\n begin\r\n if ItemsEqual(AValue, Current.Value) then\r\n begin\r\n ReplaceItem := CheckDuplicate;\r\n Break;\r\n end;\r\n Current := Current.Next;\r\n end;\r\n end;\r\n if ReplaceItem then\r\n begin\r\n Current := FStart;\r\n while Current <> nil do\r\n begin\r\n if Index = 0 then\r\n begin\r\n FreeDouble(Current.Value);\r\n Current.Value := AValue;\r\n Break;\r\n end;\r\n Dec(Index);\r\n Current := Current.Next;\r\n end;\r\n end;\r\n end;\r\n if not ReplaceItem then\r\n Delete(Index);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclDoubleLinkedList.Size: Integer;\r\nbegin\r\n Result := FSize;\r\nend;\r\n\r\nfunction TJclDoubleLinkedList.SubList(First, Count: Integer): IJclDoubleList;\r\nvar\r\n Current: TJclDoubleLinkedListItem;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := CreateEmptyContainer as IJclDoubleList;\r\n Current := FStart;\r\n while (Current <> nil) and (First > 0) do\r\n begin\r\n Dec(First);\r\n Current := Current.Next;\r\n end;\r\n while (Current <> nil) and (Count > 0) do\r\n begin\r\n Result.Add(Current.Value);\r\n Dec(Count);\r\n Current := Current.Next;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclDoubleLinkedList.CreateEmptyContainer: TJclAbstractContainerBase;\r\nbegin\r\n Result := TJclDoubleLinkedList.Create(nil);\r\n AssignPropertiesTo(Result);\r\nend;\r\n\r\n//=== { TJclDoubleLinkedListIterator } ============================================================\r\n\r\nconstructor TJclDoubleLinkedListIterator.Create(AOwnList: TJclDoubleLinkedList; ACursor: TJclDoubleLinkedListItem; AValid: Boolean; AStart: TItrStart);\r\nbegin\r\n inherited Create(AValid);\r\n FCursor := ACursor;\r\n FOwnList := AOwnList;\r\n FStart := AStart;\r\n FEqualityComparer := AOwnList as IJclDoubleEqualityComparer;\r\nend;\r\n\r\nfunction TJclDoubleLinkedListIterator.Add(const AValue: Double): Boolean;\r\nbegin\r\n Result := FOwnList.Add(AValue);\r\nend;\r\n\r\nprocedure TJclDoubleLinkedListIterator.AssignPropertiesTo(Dest: TJclAbstractIterator);\r\nvar\r\n ADest: TJclDoubleLinkedListIterator;\r\nbegin\r\n inherited AssignPropertiesTo(Dest);\r\n if Dest is TJclDoubleLinkedListIterator then\r\n begin\r\n ADest := TJclDoubleLinkedListIterator(Dest);\r\n ADest.FCursor := FCursor;\r\n ADest.FOwnList := FOwnList;\r\n ADest.FEqualityComparer := FEqualityComparer;\r\n ADest.FStart := FStart;\r\n end;\r\nend;\r\n\r\nfunction TJclDoubleLinkedListIterator.CreateEmptyIterator: TJclAbstractIterator;\r\nbegin\r\n Result := TJclDoubleLinkedListIterator.Create(FOwnList, FCursor, Valid, FStart);\r\nend;\r\n\r\nprocedure TJclDoubleLinkedListIterator.Extract;\r\nvar\r\n OldCursor: TJclDoubleLinkedListItem;\r\nbegin\r\n if FOwnList.ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n FOwnList.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n CheckValid;\r\n Valid := False;\r\n if FCursor <> nil then\r\n begin\r\n if FCursor.Next <> nil then\r\n FCursor.Next.Previous := FCursor.Previous;\r\n if FCursor.Previous <> nil then\r\n FCursor.Previous.Next := FCursor.Next;\r\n OldCursor := FCursor;\r\n FCursor := FCursor.Next;\r\n OldCursor.Free;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnList.WriteUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclDoubleLinkedListIterator.GetValue: Double;\r\nbegin\r\n CheckValid;\r\n Result := 0.0;\r\n if FCursor <> nil then\r\n Result := FCursor.Value\r\n else\r\n if not FOwnList.ReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\nend;\r\n\r\nfunction TJclDoubleLinkedListIterator.HasNext: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnList.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Valid then\r\n Result := (FCursor <> nil) and (FCursor.Next <> nil)\r\n else\r\n Result := FCursor <> nil;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnList.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclDoubleLinkedListIterator.HasPrevious: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnList.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Valid then\r\n Result := (FCursor <> nil) and (FCursor.Previous <> nil)\r\n else\r\n Result := FCursor <> nil;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnList.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclDoubleLinkedListIterator.Insert(const AValue: Double): Boolean;\r\nvar\r\n NewCursor: TJclDoubleLinkedListItem;\r\nbegin\r\n if FOwnList.ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n FOwnList.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n CheckValid;\r\n Result := FCursor <> nil;\r\n if Result then\r\n begin\r\n Result := FOwnList.AllowDefaultElements or not FEqualityComparer.ItemsEqual(AValue, 0.0);\r\n if Result then\r\n begin\r\n case FOwnList.Duplicates of\r\n dupIgnore:\r\n Result := not FOwnList.Contains(AValue);\r\n dupAccept:\r\n Result := True;\r\n dupError:\r\n begin\r\n Result := FOwnList.Contains(AValue);\r\n if not Result then\r\n raise EJclDuplicateElementError.Create;\r\n end;\r\n end;\r\n if Result then\r\n begin\r\n NewCursor := TJclDoubleLinkedListItem.Create;\r\n NewCursor.Value := AValue;\r\n NewCursor.Next := FCursor;\r\n NewCursor.Previous := FCursor.Previous;\r\n if FCursor.Previous <> nil then\r\n FCursor.Previous.Next := NewCursor;\r\n FCursor.Previous := NewCursor;\r\n FCursor := NewCursor;\r\n end;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnList.WriteUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclDoubleLinkedListIterator.IteratorEquals(const AIterator: IJclDoubleIterator): Boolean;\r\nvar\r\n Obj: TObject;\r\n ItrObj: TJclDoubleLinkedListIterator;\r\nbegin\r\n Result := False;\r\n if AIterator = nil then\r\n Exit;\r\n Obj := AIterator.GetIteratorReference;\r\n if Obj is TJclDoubleLinkedListIterator then\r\n begin\r\n ItrObj := TJclDoubleLinkedListIterator(Obj);\r\n Result := (FOwnList = ItrObj.FOwnList) and (FCursor = ItrObj.FCursor) and (Valid = ItrObj.Valid);\r\n end;\r\nend;\r\n\r\n{$IFDEF SUPPORTS_FOR_IN}\r\nfunction TJclDoubleLinkedListIterator.MoveNext: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnList.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Valid and (FCursor <> nil) then\r\n FCursor := FCursor.Next\r\n else\r\n Valid := True;\r\n Result := FCursor <> nil;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnList.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n{$ENDIF SUPPORTS_FOR_IN}\r\n\r\nfunction TJclDoubleLinkedListIterator.Next: Double;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnList.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Valid and (FCursor <> nil) then\r\n FCursor := FCursor.Next\r\n else\r\n Valid := True;\r\n if FCursor <> nil then\r\n Result := FCursor.Value\r\n else\r\n Result := 0.0;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnList.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclDoubleLinkedListIterator.NextIndex: Integer;\r\nbegin\r\n // No Index\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nfunction TJclDoubleLinkedListIterator.Previous: Double;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnList.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Valid and (FCursor <> nil) then\r\n FCursor := FCursor.Previous\r\n else\r\n Valid := True;\r\n if FCursor <> nil then\r\n Result := FCursor.Value\r\n else\r\n Result := 0.0;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnList.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclDoubleLinkedListIterator.PreviousIndex: Integer;\r\nbegin\r\n // No Index\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nprocedure TJclDoubleLinkedListIterator.Remove;\r\nvar\r\n OldCursor: TJclDoubleLinkedListItem;\r\nbegin\r\n if FOwnList.ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n FOwnList.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n CheckValid;\r\n Valid := False;\r\n if FCursor <> nil then\r\n begin\r\n FCursor.Value := 0.0;\r\n if FCursor.Next <> nil then\r\n FCursor.Next.Previous := FCursor.Previous;\r\n if FCursor.Previous <> nil then\r\n FCursor.Previous.Next := FCursor.Next;\r\n OldCursor := FCursor;\r\n FCursor := FCursor.Next;\r\n OldCursor.Free;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnList.WriteUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclDoubleLinkedListIterator.Reset;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnList.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Valid := False;\r\n case FStart of\r\n isFirst:\r\n begin\r\n while (FCursor <> nil) and (FCursor.Previous <> nil) do\r\n FCursor := FCursor.Previous;\r\n end;\r\n isLast:\r\n begin\r\n while (FCursor <> nil) and (FCursor.Next <> nil) do\r\n FCursor := FCursor.Next;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnList.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclDoubleLinkedListIterator.SetValue(const AValue: Double);\r\nbegin\r\n if FOwnList.ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n FOwnList.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n CheckValid;\r\n FCursor.Value := 0.0;\r\n FCursor.Value := AValue;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnList.WriteUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\n//=== { TJclExtendedLinkedList } ==================================================\r\n\r\nconstructor TJclExtendedLinkedList.Create(const ACollection: IJclExtendedCollection);\r\nbegin\r\n inherited Create();\r\n FStart := nil;\r\n FEnd := nil;\r\n if ACollection <> nil then\r\n AddAll(ACollection);\r\nend;\r\n\r\ndestructor TJclExtendedLinkedList.Destroy;\r\nbegin\r\n FReadOnly := False;\r\n Clear;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJclExtendedLinkedList.Add(const AValue: Extended): Boolean;\r\nvar\r\n NewItem: TJclExtendedLinkedListItem;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := FAllowDefaultElements or not ItemsEqual(AValue, 0.0);\r\n if Result then\r\n begin\r\n if FDuplicates <> dupAccept then\r\n begin\r\n NewItem := FStart;\r\n while NewItem <> nil do\r\n begin\r\n if ItemsEqual(AValue, NewItem.Value) then\r\n begin\r\n Result := CheckDuplicate;\r\n Break;\r\n end;\r\n NewItem := NewItem.Next;\r\n end;\r\n end;\r\n if Result then\r\n begin\r\n NewItem := TJclExtendedLinkedListItem.Create;\r\n NewItem.Value := AValue;\r\n if FStart <> nil then\r\n begin\r\n NewItem.Next := nil;\r\n NewItem.Previous := FEnd;\r\n FEnd.Next := NewItem;\r\n FEnd := NewItem;\r\n end\r\n else\r\n begin\r\n FStart := NewItem;\r\n FEnd := NewItem;\r\n end;\r\n Inc(FSize);\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclExtendedLinkedList.AddAll(const ACollection: IJclExtendedCollection): Boolean;\r\nvar\r\n It: IJclExtendedIterator;\r\n Item: Extended;\r\n AddItem: Boolean;\r\n NewItem: TJclExtendedLinkedListItem;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n begin\r\n Item := It.Next;\r\n AddItem := FAllowDefaultElements or not ItemsEqual(Item, 0.0);\r\n if AddItem then\r\n begin\r\n if FDuplicates <> dupAccept then\r\n begin\r\n NewItem := FStart;\r\n while NewItem <> nil do\r\n begin\r\n if ItemsEqual(Item, NewItem.Value) then\r\n begin\r\n AddItem := CheckDuplicate;\r\n Break;\r\n end;\r\n NewItem := NewItem.Next;\r\n end;\r\n end;\r\n if AddItem then\r\n begin\r\n NewItem := TJclExtendedLinkedListItem.Create;\r\n NewItem.Value := Item;\r\n if FStart <> nil then\r\n begin\r\n NewItem.Next := nil;\r\n NewItem.Previous := FEnd;\r\n FEnd.Next := NewItem;\r\n FEnd := NewItem;\r\n end\r\n else\r\n begin\r\n FStart := NewItem;\r\n FEnd := NewItem;\r\n end;\r\n Inc(FSize);\r\n end;\r\n end;\r\n Result := AddItem and Result;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclExtendedLinkedList.AssignDataTo(Dest: TJclAbstractContainerBase);\r\nvar\r\n ACollection: IJclExtendedCollection;\r\nbegin\r\n inherited AssignDataTo(Dest);\r\n if Supports(IInterface(Dest), IJclExtendedCollection, ACollection) then\r\n begin\r\n ACollection.Clear;\r\n ACollection.AddAll(Self);\r\n end;\r\nend;\r\n\r\nprocedure TJclExtendedLinkedList.Clear;\r\nvar\r\n Old, Current: TJclExtendedLinkedListItem;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Current := FStart;\r\n while Current <> nil do\r\n begin\r\n FreeExtended(Current.Value);\r\n Old := Current;\r\n Current := Current.Next;\r\n Old.Free;\r\n end;\r\n FSize := 0;\r\n\r\n //Daniele Teti 27/12/2004\r\n FStart := nil;\r\n FEnd := nil;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclExtendedLinkedList.CollectionEquals(const ACollection: IJclExtendedCollection): Boolean;\r\nvar\r\n It, ItSelf: IJclExtendedIterator;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n if FSize <> ACollection.Size then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n ItSelf := First;\r\n while ItSelf.HasNext and It.HasNext do\r\n if not ItemsEqual(ItSelf.Next, It.Next) then\r\n begin\r\n Result := False;\r\n Break;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclExtendedLinkedList.Contains(const AValue: Extended): Boolean;\r\nvar\r\n Current: TJclExtendedLinkedListItem;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n Current := FStart;\r\n while Current <> nil do\r\n begin\r\n if ItemsEqual(Current.Value, AValue) then\r\n begin\r\n Result := True;\r\n Break;\r\n end;\r\n Current := Current.Next;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclExtendedLinkedList.ContainsAll(const ACollection: IJclExtendedCollection): Boolean;\r\nvar\r\n It: IJclExtendedIterator;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n while Result and It.HasNext do\r\n Result := Contains(It.Next);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclExtendedLinkedList.Delete(Index: Integer): Extended;\r\nvar\r\n Current: TJclExtendedLinkedListItem;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := 0.0;\r\n if (Index >= 0) and (Index < FSize) then\r\n begin\r\n Current := FStart;\r\n while Current <> nil do\r\n begin\r\n if Index = 0 then\r\n begin\r\n if Current.Previous <> nil then\r\n Current.Previous.Next := Current.Next\r\n else\r\n FStart := Current.Next;\r\n if Current.Next <> nil then\r\n Current.Next.Previous := Current.Previous\r\n else\r\n FEnd := Current.Previous;\r\n Result := FreeExtended(Current.Value);\r\n Current.Free;\r\n Dec(FSize);\r\n Break;\r\n end;\r\n Dec(Index);\r\n Current := Current.Next;\r\n end;\r\n end\r\n else\r\n raise EJclOutOfBoundsError.Create;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclExtendedLinkedList.Extract(const AValue: Extended): Boolean;\r\nvar\r\n Current: TJclExtendedLinkedListItem;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n Current := FStart;\r\n while Current <> nil do\r\n begin\r\n if ItemsEqual(Current.Value, AValue) then\r\n begin\r\n if Current.Previous <> nil then\r\n Current.Previous.Next := Current.Next\r\n else\r\n FStart := Current.Next;\r\n if Current.Next <> nil then\r\n Current.Next.Previous := Current.Previous\r\n else\r\n FEnd := Current.Previous;\r\n Current.Value := 0.0;\r\n Current.Free;\r\n Dec(FSize);\r\n Result := True;\r\n if FRemoveSingleElement then\r\n Break;\r\n end;\r\n Current := Current.Next;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclExtendedLinkedList.ExtractAll(const ACollection: IJclExtendedCollection): Boolean;\r\nvar\r\n It: IJclExtendedIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := True;\r\n if ACollection = nil then\r\n Exit;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n Result := Extract(It.Next) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclExtendedLinkedList.ExtractIndex(Index: Integer): Extended;\r\nvar\r\n Current: TJclExtendedLinkedListItem;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := 0.0;\r\n if (Index >= 0) and (Index < FSize) then\r\n begin\r\n Current := FStart;\r\n while Current <> nil do\r\n begin\r\n if Index = 0 then\r\n begin\r\n if Current.Previous <> nil then\r\n Current.Previous.Next := Current.Next\r\n else\r\n FStart := Current.Next;\r\n if Current.Next <> nil then\r\n Current.Next.Previous := Current.Previous\r\n else\r\n FEnd := Current.Previous;\r\n Result := Current.Value;\r\n Current.Free;\r\n Dec(FSize);\r\n Break;\r\n end;\r\n Dec(Index);\r\n Current := Current.Next;\r\n end;\r\n end\r\n else\r\n raise EJclOutOfBoundsError.Create;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclExtendedLinkedList.First: IJclExtendedIterator;\r\nbegin\r\n Result := TJclExtendedLinkedListIterator.Create(Self, FStart, False, isFirst);\r\nend;\r\n\r\n{$IFDEF SUPPORTS_FOR_IN}\r\nfunction TJclExtendedLinkedList.GetEnumerator: IJclExtendedIterator;\r\nbegin\r\n Result := TJclExtendedLinkedListIterator.Create(Self, FStart, False, isFirst);\r\nend;\r\n{$ENDIF SUPPORTS_FOR_IN}\r\n\r\nfunction TJclExtendedLinkedList.GetValue(Index: Integer): Extended;\r\nvar\r\n Current: TJclExtendedLinkedListItem;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := 0.0;\r\n Current := FStart;\r\n while (Current <> nil) and (Index > 0) do\r\n begin\r\n Current := Current.Next;\r\n Dec(Index);\r\n end;\r\n if Current <> nil then\r\n Result := Current.Value\r\n else\r\n if not FReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclExtendedLinkedList.IndexOf(const AValue: Extended): Integer;\r\nvar\r\n Current: TJclExtendedLinkedListItem;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Current := FStart;\r\n Result := 0;\r\n while (Current <> nil) and not ItemsEqual(Current.Value, AValue) do\r\n begin\r\n Inc(Result);\r\n Current := Current.Next;\r\n end;\r\n if Current = nil then\r\n Result := -1;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclExtendedLinkedList.Insert(Index: Integer; const AValue: Extended): Boolean;\r\nvar\r\n Current, NewItem: TJclExtendedLinkedListItem;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := FAllowDefaultElements or not ItemsEqual(AValue, 0.0);\r\n if (Index < 0) or (Index > FSize) then\r\n raise EJclOutOfBoundsError.Create;\r\n if Result then\r\n begin\r\n if FDuplicates <> dupAccept then\r\n begin\r\n Current := FStart;\r\n while Current <> nil do\r\n begin\r\n if ItemsEqual(AValue, Current.Value) then\r\n begin\r\n Result := CheckDuplicate;\r\n Break;\r\n end;\r\n Current := Current.Next;\r\n end;\r\n end;\r\n if Result then\r\n begin\r\n NewItem := TJclExtendedLinkedListItem.Create;\r\n NewItem.Value := AValue;\r\n if Index = 0 then\r\n begin\r\n NewItem.Next := FStart;\r\n if FStart <> nil then\r\n FStart.Previous := NewItem;\r\n FStart := NewItem;\r\n if FSize = 0 then\r\n FEnd := NewItem;\r\n Inc(FSize);\r\n end\r\n else\r\n if Index = FSize then\r\n begin\r\n NewItem.Previous := FEnd;\r\n FEnd.Next := NewItem;\r\n FEnd := NewItem;\r\n Inc(FSize);\r\n end\r\n else\r\n begin\r\n Current := FStart;\r\n while (Current <> nil) and (Index > 0) do\r\n begin\r\n Current := Current.Next;\r\n Dec(Index);\r\n end;\r\n if Current <> nil then\r\n begin\r\n NewItem.Next := Current;\r\n NewItem.Previous := Current.Previous;\r\n if Current.Previous <> nil then\r\n Current.Previous.Next := NewItem;\r\n Current.Previous := NewItem;\r\n Inc(FSize);\r\n end;\r\n end;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclExtendedLinkedList.InsertAll(Index: Integer; const ACollection: IJclExtendedCollection): Boolean;\r\nvar\r\n It: IJclExtendedIterator;\r\n Current, NewItem, Test: TJclExtendedLinkedListItem;\r\n AddItem: Boolean;\r\n Item: Extended;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if (Index < 0) or (Index > FSize) then\r\n raise EJclOutOfBoundsError.Create;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n if Index = 0 then\r\n begin\r\n It := ACollection.Last;\r\n while It.HasPrevious do\r\n begin\r\n Item := It.Previous;\r\n AddItem := FAllowDefaultElements or not ItemsEqual(Item, 0.0);\r\n if AddItem then\r\n begin\r\n if FDuplicates <> dupAccept then\r\n begin\r\n Test := FStart;\r\n while Test <> nil do\r\n begin\r\n if ItemsEqual(Item, Test.Value) then\r\n begin\r\n Result := CheckDuplicate;\r\n Break;\r\n end;\r\n Test := Test.Next;\r\n end;\r\n end;\r\n if AddItem then\r\n begin\r\n NewItem := TJclExtendedLinkedListItem.Create;\r\n NewItem.Value := Item;\r\n NewItem.Next := FStart;\r\n if FStart <> nil then\r\n FStart.Previous := NewItem;\r\n FStart := NewItem;\r\n if FSize = 0 then\r\n FEnd := NewItem;\r\n Inc(FSize);\r\n end;\r\n end;\r\n Result := Result and AddItem;\r\n end;\r\n end\r\n else\r\n if Index = Size then\r\n begin\r\n It := ACollection.First;\r\n while It.HasNext do\r\n begin\r\n Item := It.Next;\r\n AddItem := FAllowDefaultElements or not ItemsEqual(Item, 0.0);\r\n if AddItem then\r\n begin\r\n if FDuplicates <> dupAccept then\r\n begin\r\n Test := FStart;\r\n while Test <> nil do\r\n begin\r\n if ItemsEqual(Item, Test.Value) then\r\n begin\r\n Result := CheckDuplicate;\r\n Break;\r\n end;\r\n Test := Test.Next;\r\n end;\r\n end;\r\n if AddItem then\r\n begin\r\n NewItem := TJclExtendedLinkedListItem.Create;\r\n NewItem.Value := Item;\r\n NewItem.Previous := FEnd;\r\n if FEnd <> nil then\r\n FEnd.Next := NewItem;\r\n FEnd := NewItem;\r\n Inc(FSize);\r\n end;\r\n end;\r\n Result := Result and AddItem;\r\n end;\r\n end\r\n else\r\n begin\r\n Current := FStart;\r\n while (Current <> nil) and (Index > 0) do\r\n begin\r\n Current := Current.Next;\r\n Dec(Index);\r\n end;\r\n if Current <> nil then\r\n begin\r\n It := ACollection.First;\r\n while It.HasNext do\r\n begin\r\n Item := It.Next;\r\n AddItem := FAllowDefaultElements or not ItemsEqual(Item, 0.0);\r\n if AddItem then\r\n begin\r\n if FDuplicates <> dupAccept then\r\n begin\r\n Test := FStart;\r\n while Test <> nil do\r\n begin\r\n if ItemsEqual(Item, Test.Value) then\r\n begin\r\n Result := CheckDuplicate;\r\n Break;\r\n end;\r\n Test := Test.Next;\r\n end;\r\n end;\r\n if AddItem then\r\n begin\r\n NewItem := TJclExtendedLinkedListItem.Create;\r\n NewItem.Value := Item;\r\n NewItem.Next := Current;\r\n NewItem.Previous := Current.Previous;\r\n if Current.Previous <> nil then\r\n Current.Previous.Next := NewItem;\r\n Current.Previous := NewItem;\r\n Inc(FSize);\r\n end;\r\n end;\r\n Result := Result and AddItem;\r\n end;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclExtendedLinkedList.IsEmpty: Boolean;\r\nbegin\r\n Result := FSize = 0;\r\nend;\r\n\r\nfunction TJclExtendedLinkedList.Last: IJclExtendedIterator;\r\nbegin\r\n Result := TJclExtendedLinkedListIterator.Create(Self, FEnd, False, isLast);\r\nend;\r\n\r\nfunction TJclExtendedLinkedList.LastIndexOf(const AValue: Extended): Integer;\r\nvar\r\n Current: TJclExtendedLinkedListItem;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := -1;\r\n if FEnd <> nil then\r\n begin\r\n Current := FEnd;\r\n Result := FSize - 1;\r\n while (Current <> nil) and not ItemsEqual(Current.Value, AValue) do\r\n begin\r\n Dec(Result);\r\n Current := Current.Previous;\r\n end;\r\n if Current = nil then\r\n Result := -1;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclExtendedLinkedList.Remove(const AValue: Extended): Boolean;\r\nvar\r\n Extracted: Extended;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := Extract(AValue);\r\n if Result then\r\n begin\r\n Extracted := AValue;\r\n FreeExtended(Extracted);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclExtendedLinkedList.RemoveAll(const ACollection: IJclExtendedCollection): Boolean;\r\nvar\r\n It: IJclExtendedIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := True;\r\n if ACollection = nil then\r\n Exit;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n Result := Remove(It.Next) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclExtendedLinkedList.RetainAll(const ACollection: IJclExtendedCollection): Boolean;\r\nvar\r\n It: IJclExtendedIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := First;\r\n while It.HasNext do\r\n if not ACollection.Contains(It.Next) then\r\n It.Remove;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclExtendedLinkedList.SetValue(Index: Integer; const AValue: Extended);\r\nvar\r\n Current: TJclExtendedLinkedListItem;\r\n ReplaceItem: Boolean;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n ReplaceItem := FAllowDefaultElements or not ItemsEqual(AValue, 0.0);\r\n if ReplaceItem then\r\n begin\r\n if FDuplicates <> dupAccept then\r\n begin\r\n Current := FStart;\r\n while Current <> nil do\r\n begin\r\n if ItemsEqual(AValue, Current.Value) then\r\n begin\r\n ReplaceItem := CheckDuplicate;\r\n Break;\r\n end;\r\n Current := Current.Next;\r\n end;\r\n end;\r\n if ReplaceItem then\r\n begin\r\n Current := FStart;\r\n while Current <> nil do\r\n begin\r\n if Index = 0 then\r\n begin\r\n FreeExtended(Current.Value);\r\n Current.Value := AValue;\r\n Break;\r\n end;\r\n Dec(Index);\r\n Current := Current.Next;\r\n end;\r\n end;\r\n end;\r\n if not ReplaceItem then\r\n Delete(Index);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclExtendedLinkedList.Size: Integer;\r\nbegin\r\n Result := FSize;\r\nend;\r\n\r\nfunction TJclExtendedLinkedList.SubList(First, Count: Integer): IJclExtendedList;\r\nvar\r\n Current: TJclExtendedLinkedListItem;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := CreateEmptyContainer as IJclExtendedList;\r\n Current := FStart;\r\n while (Current <> nil) and (First > 0) do\r\n begin\r\n Dec(First);\r\n Current := Current.Next;\r\n end;\r\n while (Current <> nil) and (Count > 0) do\r\n begin\r\n Result.Add(Current.Value);\r\n Dec(Count);\r\n Current := Current.Next;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclExtendedLinkedList.CreateEmptyContainer: TJclAbstractContainerBase;\r\nbegin\r\n Result := TJclExtendedLinkedList.Create(nil);\r\n AssignPropertiesTo(Result);\r\nend;\r\n\r\n//=== { TJclExtendedLinkedListIterator } ============================================================\r\n\r\nconstructor TJclExtendedLinkedListIterator.Create(AOwnList: TJclExtendedLinkedList; ACursor: TJclExtendedLinkedListItem; AValid: Boolean; AStart: TItrStart);\r\nbegin\r\n inherited Create(AValid);\r\n FCursor := ACursor;\r\n FOwnList := AOwnList;\r\n FStart := AStart;\r\n FEqualityComparer := AOwnList as IJclExtendedEqualityComparer;\r\nend;\r\n\r\nfunction TJclExtendedLinkedListIterator.Add(const AValue: Extended): Boolean;\r\nbegin\r\n Result := FOwnList.Add(AValue);\r\nend;\r\n\r\nprocedure TJclExtendedLinkedListIterator.AssignPropertiesTo(Dest: TJclAbstractIterator);\r\nvar\r\n ADest: TJclExtendedLinkedListIterator;\r\nbegin\r\n inherited AssignPropertiesTo(Dest);\r\n if Dest is TJclExtendedLinkedListIterator then\r\n begin\r\n ADest := TJclExtendedLinkedListIterator(Dest);\r\n ADest.FCursor := FCursor;\r\n ADest.FOwnList := FOwnList;\r\n ADest.FEqualityComparer := FEqualityComparer;\r\n ADest.FStart := FStart;\r\n end;\r\nend;\r\n\r\nfunction TJclExtendedLinkedListIterator.CreateEmptyIterator: TJclAbstractIterator;\r\nbegin\r\n Result := TJclExtendedLinkedListIterator.Create(FOwnList, FCursor, Valid, FStart);\r\nend;\r\n\r\nprocedure TJclExtendedLinkedListIterator.Extract;\r\nvar\r\n OldCursor: TJclExtendedLinkedListItem;\r\nbegin\r\n if FOwnList.ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n FOwnList.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n CheckValid;\r\n Valid := False;\r\n if FCursor <> nil then\r\n begin\r\n if FCursor.Next <> nil then\r\n FCursor.Next.Previous := FCursor.Previous;\r\n if FCursor.Previous <> nil then\r\n FCursor.Previous.Next := FCursor.Next;\r\n OldCursor := FCursor;\r\n FCursor := FCursor.Next;\r\n OldCursor.Free;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnList.WriteUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclExtendedLinkedListIterator.GetValue: Extended;\r\nbegin\r\n CheckValid;\r\n Result := 0.0;\r\n if FCursor <> nil then\r\n Result := FCursor.Value\r\n else\r\n if not FOwnList.ReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\nend;\r\n\r\nfunction TJclExtendedLinkedListIterator.HasNext: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnList.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Valid then\r\n Result := (FCursor <> nil) and (FCursor.Next <> nil)\r\n else\r\n Result := FCursor <> nil;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnList.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclExtendedLinkedListIterator.HasPrevious: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnList.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Valid then\r\n Result := (FCursor <> nil) and (FCursor.Previous <> nil)\r\n else\r\n Result := FCursor <> nil;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnList.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclExtendedLinkedListIterator.Insert(const AValue: Extended): Boolean;\r\nvar\r\n NewCursor: TJclExtendedLinkedListItem;\r\nbegin\r\n if FOwnList.ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n FOwnList.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n CheckValid;\r\n Result := FCursor <> nil;\r\n if Result then\r\n begin\r\n Result := FOwnList.AllowDefaultElements or not FEqualityComparer.ItemsEqual(AValue, 0.0);\r\n if Result then\r\n begin\r\n case FOwnList.Duplicates of\r\n dupIgnore:\r\n Result := not FOwnList.Contains(AValue);\r\n dupAccept:\r\n Result := True;\r\n dupError:\r\n begin\r\n Result := FOwnList.Contains(AValue);\r\n if not Result then\r\n raise EJclDuplicateElementError.Create;\r\n end;\r\n end;\r\n if Result then\r\n begin\r\n NewCursor := TJclExtendedLinkedListItem.Create;\r\n NewCursor.Value := AValue;\r\n NewCursor.Next := FCursor;\r\n NewCursor.Previous := FCursor.Previous;\r\n if FCursor.Previous <> nil then\r\n FCursor.Previous.Next := NewCursor;\r\n FCursor.Previous := NewCursor;\r\n FCursor := NewCursor;\r\n end;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnList.WriteUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclExtendedLinkedListIterator.IteratorEquals(const AIterator: IJclExtendedIterator): Boolean;\r\nvar\r\n Obj: TObject;\r\n ItrObj: TJclExtendedLinkedListIterator;\r\nbegin\r\n Result := False;\r\n if AIterator = nil then\r\n Exit;\r\n Obj := AIterator.GetIteratorReference;\r\n if Obj is TJclExtendedLinkedListIterator then\r\n begin\r\n ItrObj := TJclExtendedLinkedListIterator(Obj);\r\n Result := (FOwnList = ItrObj.FOwnList) and (FCursor = ItrObj.FCursor) and (Valid = ItrObj.Valid);\r\n end;\r\nend;\r\n\r\n{$IFDEF SUPPORTS_FOR_IN}\r\nfunction TJclExtendedLinkedListIterator.MoveNext: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnList.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Valid and (FCursor <> nil) then\r\n FCursor := FCursor.Next\r\n else\r\n Valid := True;\r\n Result := FCursor <> nil;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnList.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n{$ENDIF SUPPORTS_FOR_IN}\r\n\r\nfunction TJclExtendedLinkedListIterator.Next: Extended;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnList.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Valid and (FCursor <> nil) then\r\n FCursor := FCursor.Next\r\n else\r\n Valid := True;\r\n if FCursor <> nil then\r\n Result := FCursor.Value\r\n else\r\n Result := 0.0;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnList.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclExtendedLinkedListIterator.NextIndex: Integer;\r\nbegin\r\n // No Index\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nfunction TJclExtendedLinkedListIterator.Previous: Extended;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnList.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Valid and (FCursor <> nil) then\r\n FCursor := FCursor.Previous\r\n else\r\n Valid := True;\r\n if FCursor <> nil then\r\n Result := FCursor.Value\r\n else\r\n Result := 0.0;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnList.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclExtendedLinkedListIterator.PreviousIndex: Integer;\r\nbegin\r\n // No Index\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nprocedure TJclExtendedLinkedListIterator.Remove;\r\nvar\r\n OldCursor: TJclExtendedLinkedListItem;\r\nbegin\r\n if FOwnList.ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n FOwnList.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n CheckValid;\r\n Valid := False;\r\n if FCursor <> nil then\r\n begin\r\n FCursor.Value := 0.0;\r\n if FCursor.Next <> nil then\r\n FCursor.Next.Previous := FCursor.Previous;\r\n if FCursor.Previous <> nil then\r\n FCursor.Previous.Next := FCursor.Next;\r\n OldCursor := FCursor;\r\n FCursor := FCursor.Next;\r\n OldCursor.Free;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnList.WriteUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclExtendedLinkedListIterator.Reset;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnList.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Valid := False;\r\n case FStart of\r\n isFirst:\r\n begin\r\n while (FCursor <> nil) and (FCursor.Previous <> nil) do\r\n FCursor := FCursor.Previous;\r\n end;\r\n isLast:\r\n begin\r\n while (FCursor <> nil) and (FCursor.Next <> nil) do\r\n FCursor := FCursor.Next;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnList.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclExtendedLinkedListIterator.SetValue(const AValue: Extended);\r\nbegin\r\n if FOwnList.ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n FOwnList.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n CheckValid;\r\n FCursor.Value := 0.0;\r\n FCursor.Value := AValue;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnList.WriteUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\n//=== { TJclIntegerLinkedList } ==================================================\r\n\r\nconstructor TJclIntegerLinkedList.Create(const ACollection: IJclIntegerCollection);\r\nbegin\r\n inherited Create();\r\n FStart := nil;\r\n FEnd := nil;\r\n if ACollection <> nil then\r\n AddAll(ACollection);\r\nend;\r\n\r\ndestructor TJclIntegerLinkedList.Destroy;\r\nbegin\r\n FReadOnly := False;\r\n Clear;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJclIntegerLinkedList.Add(AValue: Integer): Boolean;\r\nvar\r\n NewItem: TJclIntegerLinkedListItem;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := FAllowDefaultElements or not ItemsEqual(AValue, 0);\r\n if Result then\r\n begin\r\n if FDuplicates <> dupAccept then\r\n begin\r\n NewItem := FStart;\r\n while NewItem <> nil do\r\n begin\r\n if ItemsEqual(AValue, NewItem.Value) then\r\n begin\r\n Result := CheckDuplicate;\r\n Break;\r\n end;\r\n NewItem := NewItem.Next;\r\n end;\r\n end;\r\n if Result then\r\n begin\r\n NewItem := TJclIntegerLinkedListItem.Create;\r\n NewItem.Value := AValue;\r\n if FStart <> nil then\r\n begin\r\n NewItem.Next := nil;\r\n NewItem.Previous := FEnd;\r\n FEnd.Next := NewItem;\r\n FEnd := NewItem;\r\n end\r\n else\r\n begin\r\n FStart := NewItem;\r\n FEnd := NewItem;\r\n end;\r\n Inc(FSize);\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntegerLinkedList.AddAll(const ACollection: IJclIntegerCollection): Boolean;\r\nvar\r\n It: IJclIntegerIterator;\r\n Item: Integer;\r\n AddItem: Boolean;\r\n NewItem: TJclIntegerLinkedListItem;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n begin\r\n Item := It.Next;\r\n AddItem := FAllowDefaultElements or not ItemsEqual(Item, 0);\r\n if AddItem then\r\n begin\r\n if FDuplicates <> dupAccept then\r\n begin\r\n NewItem := FStart;\r\n while NewItem <> nil do\r\n begin\r\n if ItemsEqual(Item, NewItem.Value) then\r\n begin\r\n AddItem := CheckDuplicate;\r\n Break;\r\n end;\r\n NewItem := NewItem.Next;\r\n end;\r\n end;\r\n if AddItem then\r\n begin\r\n NewItem := TJclIntegerLinkedListItem.Create;\r\n NewItem.Value := Item;\r\n if FStart <> nil then\r\n begin\r\n NewItem.Next := nil;\r\n NewItem.Previous := FEnd;\r\n FEnd.Next := NewItem;\r\n FEnd := NewItem;\r\n end\r\n else\r\n begin\r\n FStart := NewItem;\r\n FEnd := NewItem;\r\n end;\r\n Inc(FSize);\r\n end;\r\n end;\r\n Result := AddItem and Result;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclIntegerLinkedList.AssignDataTo(Dest: TJclAbstractContainerBase);\r\nvar\r\n ACollection: IJclIntegerCollection;\r\nbegin\r\n inherited AssignDataTo(Dest);\r\n if Supports(IInterface(Dest), IJclIntegerCollection, ACollection) then\r\n begin\r\n ACollection.Clear;\r\n ACollection.AddAll(Self);\r\n end;\r\nend;\r\n\r\nprocedure TJclIntegerLinkedList.Clear;\r\nvar\r\n Old, Current: TJclIntegerLinkedListItem;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Current := FStart;\r\n while Current <> nil do\r\n begin\r\n FreeInteger(Current.Value);\r\n Old := Current;\r\n Current := Current.Next;\r\n Old.Free;\r\n end;\r\n FSize := 0;\r\n\r\n //Daniele Teti 27/12/2004\r\n FStart := nil;\r\n FEnd := nil;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntegerLinkedList.CollectionEquals(const ACollection: IJclIntegerCollection): Boolean;\r\nvar\r\n It, ItSelf: IJclIntegerIterator;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n if FSize <> ACollection.Size then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n ItSelf := First;\r\n while ItSelf.HasNext and It.HasNext do\r\n if not ItemsEqual(ItSelf.Next, It.Next) then\r\n begin\r\n Result := False;\r\n Break;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntegerLinkedList.Contains(AValue: Integer): Boolean;\r\nvar\r\n Current: TJclIntegerLinkedListItem;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n Current := FStart;\r\n while Current <> nil do\r\n begin\r\n if ItemsEqual(Current.Value, AValue) then\r\n begin\r\n Result := True;\r\n Break;\r\n end;\r\n Current := Current.Next;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntegerLinkedList.ContainsAll(const ACollection: IJclIntegerCollection): Boolean;\r\nvar\r\n It: IJclIntegerIterator;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n while Result and It.HasNext do\r\n Result := Contains(It.Next);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntegerLinkedList.Delete(Index: Integer): Integer;\r\nvar\r\n Current: TJclIntegerLinkedListItem;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := 0;\r\n if (Index >= 0) and (Index < FSize) then\r\n begin\r\n Current := FStart;\r\n while Current <> nil do\r\n begin\r\n if Index = 0 then\r\n begin\r\n if Current.Previous <> nil then\r\n Current.Previous.Next := Current.Next\r\n else\r\n FStart := Current.Next;\r\n if Current.Next <> nil then\r\n Current.Next.Previous := Current.Previous\r\n else\r\n FEnd := Current.Previous;\r\n Result := FreeInteger(Current.Value);\r\n Current.Free;\r\n Dec(FSize);\r\n Break;\r\n end;\r\n Dec(Index);\r\n Current := Current.Next;\r\n end;\r\n end\r\n else\r\n raise EJclOutOfBoundsError.Create;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntegerLinkedList.Extract(AValue: Integer): Boolean;\r\nvar\r\n Current: TJclIntegerLinkedListItem;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n Current := FStart;\r\n while Current <> nil do\r\n begin\r\n if ItemsEqual(Current.Value, AValue) then\r\n begin\r\n if Current.Previous <> nil then\r\n Current.Previous.Next := Current.Next\r\n else\r\n FStart := Current.Next;\r\n if Current.Next <> nil then\r\n Current.Next.Previous := Current.Previous\r\n else\r\n FEnd := Current.Previous;\r\n Current.Value := 0;\r\n Current.Free;\r\n Dec(FSize);\r\n Result := True;\r\n if FRemoveSingleElement then\r\n Break;\r\n end;\r\n Current := Current.Next;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntegerLinkedList.ExtractAll(const ACollection: IJclIntegerCollection): Boolean;\r\nvar\r\n It: IJclIntegerIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := True;\r\n if ACollection = nil then\r\n Exit;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n Result := Extract(It.Next) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntegerLinkedList.ExtractIndex(Index: Integer): Integer;\r\nvar\r\n Current: TJclIntegerLinkedListItem;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := 0;\r\n if (Index >= 0) and (Index < FSize) then\r\n begin\r\n Current := FStart;\r\n while Current <> nil do\r\n begin\r\n if Index = 0 then\r\n begin\r\n if Current.Previous <> nil then\r\n Current.Previous.Next := Current.Next\r\n else\r\n FStart := Current.Next;\r\n if Current.Next <> nil then\r\n Current.Next.Previous := Current.Previous\r\n else\r\n FEnd := Current.Previous;\r\n Result := Current.Value;\r\n Current.Free;\r\n Dec(FSize);\r\n Break;\r\n end;\r\n Dec(Index);\r\n Current := Current.Next;\r\n end;\r\n end\r\n else\r\n raise EJclOutOfBoundsError.Create;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntegerLinkedList.First: IJclIntegerIterator;\r\nbegin\r\n Result := TJclIntegerLinkedListIterator.Create(Self, FStart, False, isFirst);\r\nend;\r\n\r\n{$IFDEF SUPPORTS_FOR_IN}\r\nfunction TJclIntegerLinkedList.GetEnumerator: IJclIntegerIterator;\r\nbegin\r\n Result := TJclIntegerLinkedListIterator.Create(Self, FStart, False, isFirst);\r\nend;\r\n{$ENDIF SUPPORTS_FOR_IN}\r\n\r\nfunction TJclIntegerLinkedList.GetValue(Index: Integer): Integer;\r\nvar\r\n Current: TJclIntegerLinkedListItem;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := 0;\r\n Current := FStart;\r\n while (Current <> nil) and (Index > 0) do\r\n begin\r\n Current := Current.Next;\r\n Dec(Index);\r\n end;\r\n if Current <> nil then\r\n Result := Current.Value\r\n else\r\n if not FReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntegerLinkedList.IndexOf(AValue: Integer): Integer;\r\nvar\r\n Current: TJclIntegerLinkedListItem;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Current := FStart;\r\n Result := 0;\r\n while (Current <> nil) and not ItemsEqual(Current.Value, AValue) do\r\n begin\r\n Inc(Result);\r\n Current := Current.Next;\r\n end;\r\n if Current = nil then\r\n Result := -1;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntegerLinkedList.Insert(Index: Integer; AValue: Integer): Boolean;\r\nvar\r\n Current, NewItem: TJclIntegerLinkedListItem;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := FAllowDefaultElements or not ItemsEqual(AValue, 0);\r\n if (Index < 0) or (Index > FSize) then\r\n raise EJclOutOfBoundsError.Create;\r\n if Result then\r\n begin\r\n if FDuplicates <> dupAccept then\r\n begin\r\n Current := FStart;\r\n while Current <> nil do\r\n begin\r\n if ItemsEqual(AValue, Current.Value) then\r\n begin\r\n Result := CheckDuplicate;\r\n Break;\r\n end;\r\n Current := Current.Next;\r\n end;\r\n end;\r\n if Result then\r\n begin\r\n NewItem := TJclIntegerLinkedListItem.Create;\r\n NewItem.Value := AValue;\r\n if Index = 0 then\r\n begin\r\n NewItem.Next := FStart;\r\n if FStart <> nil then\r\n FStart.Previous := NewItem;\r\n FStart := NewItem;\r\n if FSize = 0 then\r\n FEnd := NewItem;\r\n Inc(FSize);\r\n end\r\n else\r\n if Index = FSize then\r\n begin\r\n NewItem.Previous := FEnd;\r\n FEnd.Next := NewItem;\r\n FEnd := NewItem;\r\n Inc(FSize);\r\n end\r\n else\r\n begin\r\n Current := FStart;\r\n while (Current <> nil) and (Index > 0) do\r\n begin\r\n Current := Current.Next;\r\n Dec(Index);\r\n end;\r\n if Current <> nil then\r\n begin\r\n NewItem.Next := Current;\r\n NewItem.Previous := Current.Previous;\r\n if Current.Previous <> nil then\r\n Current.Previous.Next := NewItem;\r\n Current.Previous := NewItem;\r\n Inc(FSize);\r\n end;\r\n end;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntegerLinkedList.InsertAll(Index: Integer; const ACollection: IJclIntegerCollection): Boolean;\r\nvar\r\n It: IJclIntegerIterator;\r\n Current, NewItem, Test: TJclIntegerLinkedListItem;\r\n AddItem: Boolean;\r\n Item: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if (Index < 0) or (Index > FSize) then\r\n raise EJclOutOfBoundsError.Create;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n if Index = 0 then\r\n begin\r\n It := ACollection.Last;\r\n while It.HasPrevious do\r\n begin\r\n Item := It.Previous;\r\n AddItem := FAllowDefaultElements or not ItemsEqual(Item, 0);\r\n if AddItem then\r\n begin\r\n if FDuplicates <> dupAccept then\r\n begin\r\n Test := FStart;\r\n while Test <> nil do\r\n begin\r\n if ItemsEqual(Item, Test.Value) then\r\n begin\r\n Result := CheckDuplicate;\r\n Break;\r\n end;\r\n Test := Test.Next;\r\n end;\r\n end;\r\n if AddItem then\r\n begin\r\n NewItem := TJclIntegerLinkedListItem.Create;\r\n NewItem.Value := Item;\r\n NewItem.Next := FStart;\r\n if FStart <> nil then\r\n FStart.Previous := NewItem;\r\n FStart := NewItem;\r\n if FSize = 0 then\r\n FEnd := NewItem;\r\n Inc(FSize);\r\n end;\r\n end;\r\n Result := Result and AddItem;\r\n end;\r\n end\r\n else\r\n if Index = Size then\r\n begin\r\n It := ACollection.First;\r\n while It.HasNext do\r\n begin\r\n Item := It.Next;\r\n AddItem := FAllowDefaultElements or not ItemsEqual(Item, 0);\r\n if AddItem then\r\n begin\r\n if FDuplicates <> dupAccept then\r\n begin\r\n Test := FStart;\r\n while Test <> nil do\r\n begin\r\n if ItemsEqual(Item, Test.Value) then\r\n begin\r\n Result := CheckDuplicate;\r\n Break;\r\n end;\r\n Test := Test.Next;\r\n end;\r\n end;\r\n if AddItem then\r\n begin\r\n NewItem := TJclIntegerLinkedListItem.Create;\r\n NewItem.Value := Item;\r\n NewItem.Previous := FEnd;\r\n if FEnd <> nil then\r\n FEnd.Next := NewItem;\r\n FEnd := NewItem;\r\n Inc(FSize);\r\n end;\r\n end;\r\n Result := Result and AddItem;\r\n end;\r\n end\r\n else\r\n begin\r\n Current := FStart;\r\n while (Current <> nil) and (Index > 0) do\r\n begin\r\n Current := Current.Next;\r\n Dec(Index);\r\n end;\r\n if Current <> nil then\r\n begin\r\n It := ACollection.First;\r\n while It.HasNext do\r\n begin\r\n Item := It.Next;\r\n AddItem := FAllowDefaultElements or not ItemsEqual(Item, 0);\r\n if AddItem then\r\n begin\r\n if FDuplicates <> dupAccept then\r\n begin\r\n Test := FStart;\r\n while Test <> nil do\r\n begin\r\n if ItemsEqual(Item, Test.Value) then\r\n begin\r\n Result := CheckDuplicate;\r\n Break;\r\n end;\r\n Test := Test.Next;\r\n end;\r\n end;\r\n if AddItem then\r\n begin\r\n NewItem := TJclIntegerLinkedListItem.Create;\r\n NewItem.Value := Item;\r\n NewItem.Next := Current;\r\n NewItem.Previous := Current.Previous;\r\n if Current.Previous <> nil then\r\n Current.Previous.Next := NewItem;\r\n Current.Previous := NewItem;\r\n Inc(FSize);\r\n end;\r\n end;\r\n Result := Result and AddItem;\r\n end;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntegerLinkedList.IsEmpty: Boolean;\r\nbegin\r\n Result := FSize = 0;\r\nend;\r\n\r\nfunction TJclIntegerLinkedList.Last: IJclIntegerIterator;\r\nbegin\r\n Result := TJclIntegerLinkedListIterator.Create(Self, FEnd, False, isLast);\r\nend;\r\n\r\nfunction TJclIntegerLinkedList.LastIndexOf(AValue: Integer): Integer;\r\nvar\r\n Current: TJclIntegerLinkedListItem;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := -1;\r\n if FEnd <> nil then\r\n begin\r\n Current := FEnd;\r\n Result := FSize - 1;\r\n while (Current <> nil) and not ItemsEqual(Current.Value, AValue) do\r\n begin\r\n Dec(Result);\r\n Current := Current.Previous;\r\n end;\r\n if Current = nil then\r\n Result := -1;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntegerLinkedList.Remove(AValue: Integer): Boolean;\r\nvar\r\n Extracted: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := Extract(AValue);\r\n if Result then\r\n begin\r\n Extracted := AValue;\r\n FreeInteger(Extracted);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntegerLinkedList.RemoveAll(const ACollection: IJclIntegerCollection): Boolean;\r\nvar\r\n It: IJclIntegerIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := True;\r\n if ACollection = nil then\r\n Exit;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n Result := Remove(It.Next) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntegerLinkedList.RetainAll(const ACollection: IJclIntegerCollection): Boolean;\r\nvar\r\n It: IJclIntegerIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := First;\r\n while It.HasNext do\r\n if not ACollection.Contains(It.Next) then\r\n It.Remove;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclIntegerLinkedList.SetValue(Index: Integer; AValue: Integer);\r\nvar\r\n Current: TJclIntegerLinkedListItem;\r\n ReplaceItem: Boolean;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n ReplaceItem := FAllowDefaultElements or not ItemsEqual(AValue, 0);\r\n if ReplaceItem then\r\n begin\r\n if FDuplicates <> dupAccept then\r\n begin\r\n Current := FStart;\r\n while Current <> nil do\r\n begin\r\n if ItemsEqual(AValue, Current.Value) then\r\n begin\r\n ReplaceItem := CheckDuplicate;\r\n Break;\r\n end;\r\n Current := Current.Next;\r\n end;\r\n end;\r\n if ReplaceItem then\r\n begin\r\n Current := FStart;\r\n while Current <> nil do\r\n begin\r\n if Index = 0 then\r\n begin\r\n FreeInteger(Current.Value);\r\n Current.Value := AValue;\r\n Break;\r\n end;\r\n Dec(Index);\r\n Current := Current.Next;\r\n end;\r\n end;\r\n end;\r\n if not ReplaceItem then\r\n Delete(Index);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntegerLinkedList.Size: Integer;\r\nbegin\r\n Result := FSize;\r\nend;\r\n\r\nfunction TJclIntegerLinkedList.SubList(First, Count: Integer): IJclIntegerList;\r\nvar\r\n Current: TJclIntegerLinkedListItem;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := CreateEmptyContainer as IJclIntegerList;\r\n Current := FStart;\r\n while (Current <> nil) and (First > 0) do\r\n begin\r\n Dec(First);\r\n Current := Current.Next;\r\n end;\r\n while (Current <> nil) and (Count > 0) do\r\n begin\r\n Result.Add(Current.Value);\r\n Dec(Count);\r\n Current := Current.Next;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntegerLinkedList.CreateEmptyContainer: TJclAbstractContainerBase;\r\nbegin\r\n Result := TJclIntegerLinkedList.Create(nil);\r\n AssignPropertiesTo(Result);\r\nend;\r\n\r\n//=== { TJclIntegerLinkedListIterator } ============================================================\r\n\r\nconstructor TJclIntegerLinkedListIterator.Create(AOwnList: TJclIntegerLinkedList; ACursor: TJclIntegerLinkedListItem; AValid: Boolean; AStart: TItrStart);\r\nbegin\r\n inherited Create(AValid);\r\n FCursor := ACursor;\r\n FOwnList := AOwnList;\r\n FStart := AStart;\r\n FEqualityComparer := AOwnList as IJclIntegerEqualityComparer;\r\nend;\r\n\r\nfunction TJclIntegerLinkedListIterator.Add(AValue: Integer): Boolean;\r\nbegin\r\n Result := FOwnList.Add(AValue);\r\nend;\r\n\r\nprocedure TJclIntegerLinkedListIterator.AssignPropertiesTo(Dest: TJclAbstractIterator);\r\nvar\r\n ADest: TJclIntegerLinkedListIterator;\r\nbegin\r\n inherited AssignPropertiesTo(Dest);\r\n if Dest is TJclIntegerLinkedListIterator then\r\n begin\r\n ADest := TJclIntegerLinkedListIterator(Dest);\r\n ADest.FCursor := FCursor;\r\n ADest.FOwnList := FOwnList;\r\n ADest.FEqualityComparer := FEqualityComparer;\r\n ADest.FStart := FStart;\r\n end;\r\nend;\r\n\r\nfunction TJclIntegerLinkedListIterator.CreateEmptyIterator: TJclAbstractIterator;\r\nbegin\r\n Result := TJclIntegerLinkedListIterator.Create(FOwnList, FCursor, Valid, FStart);\r\nend;\r\n\r\nprocedure TJclIntegerLinkedListIterator.Extract;\r\nvar\r\n OldCursor: TJclIntegerLinkedListItem;\r\nbegin\r\n if FOwnList.ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n FOwnList.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n CheckValid;\r\n Valid := False;\r\n if FCursor <> nil then\r\n begin\r\n if FCursor.Next <> nil then\r\n FCursor.Next.Previous := FCursor.Previous;\r\n if FCursor.Previous <> nil then\r\n FCursor.Previous.Next := FCursor.Next;\r\n OldCursor := FCursor;\r\n FCursor := FCursor.Next;\r\n OldCursor.Free;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnList.WriteUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntegerLinkedListIterator.GetValue: Integer;\r\nbegin\r\n CheckValid;\r\n Result := 0;\r\n if FCursor <> nil then\r\n Result := FCursor.Value\r\n else\r\n if not FOwnList.ReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\nend;\r\n\r\nfunction TJclIntegerLinkedListIterator.HasNext: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnList.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Valid then\r\n Result := (FCursor <> nil) and (FCursor.Next <> nil)\r\n else\r\n Result := FCursor <> nil;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnList.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntegerLinkedListIterator.HasPrevious: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnList.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Valid then\r\n Result := (FCursor <> nil) and (FCursor.Previous <> nil)\r\n else\r\n Result := FCursor <> nil;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnList.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntegerLinkedListIterator.Insert(AValue: Integer): Boolean;\r\nvar\r\n NewCursor: TJclIntegerLinkedListItem;\r\nbegin\r\n if FOwnList.ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n FOwnList.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n CheckValid;\r\n Result := FCursor <> nil;\r\n if Result then\r\n begin\r\n Result := FOwnList.AllowDefaultElements or not FEqualityComparer.ItemsEqual(AValue, 0);\r\n if Result then\r\n begin\r\n case FOwnList.Duplicates of\r\n dupIgnore:\r\n Result := not FOwnList.Contains(AValue);\r\n dupAccept:\r\n Result := True;\r\n dupError:\r\n begin\r\n Result := FOwnList.Contains(AValue);\r\n if not Result then\r\n raise EJclDuplicateElementError.Create;\r\n end;\r\n end;\r\n if Result then\r\n begin\r\n NewCursor := TJclIntegerLinkedListItem.Create;\r\n NewCursor.Value := AValue;\r\n NewCursor.Next := FCursor;\r\n NewCursor.Previous := FCursor.Previous;\r\n if FCursor.Previous <> nil then\r\n FCursor.Previous.Next := NewCursor;\r\n FCursor.Previous := NewCursor;\r\n FCursor := NewCursor;\r\n end;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnList.WriteUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntegerLinkedListIterator.IteratorEquals(const AIterator: IJclIntegerIterator): Boolean;\r\nvar\r\n Obj: TObject;\r\n ItrObj: TJclIntegerLinkedListIterator;\r\nbegin\r\n Result := False;\r\n if AIterator = nil then\r\n Exit;\r\n Obj := AIterator.GetIteratorReference;\r\n if Obj is TJclIntegerLinkedListIterator then\r\n begin\r\n ItrObj := TJclIntegerLinkedListIterator(Obj);\r\n Result := (FOwnList = ItrObj.FOwnList) and (FCursor = ItrObj.FCursor) and (Valid = ItrObj.Valid);\r\n end;\r\nend;\r\n\r\n{$IFDEF SUPPORTS_FOR_IN}\r\nfunction TJclIntegerLinkedListIterator.MoveNext: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnList.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Valid and (FCursor <> nil) then\r\n FCursor := FCursor.Next\r\n else\r\n Valid := True;\r\n Result := FCursor <> nil;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnList.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n{$ENDIF SUPPORTS_FOR_IN}\r\n\r\nfunction TJclIntegerLinkedListIterator.Next: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnList.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Valid and (FCursor <> nil) then\r\n FCursor := FCursor.Next\r\n else\r\n Valid := True;\r\n if FCursor <> nil then\r\n Result := FCursor.Value\r\n else\r\n Result := 0;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnList.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntegerLinkedListIterator.NextIndex: Integer;\r\nbegin\r\n // No Index\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nfunction TJclIntegerLinkedListIterator.Previous: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnList.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Valid and (FCursor <> nil) then\r\n FCursor := FCursor.Previous\r\n else\r\n Valid := True;\r\n if FCursor <> nil then\r\n Result := FCursor.Value\r\n else\r\n Result := 0;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnList.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntegerLinkedListIterator.PreviousIndex: Integer;\r\nbegin\r\n // No Index\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nprocedure TJclIntegerLinkedListIterator.Remove;\r\nvar\r\n OldCursor: TJclIntegerLinkedListItem;\r\nbegin\r\n if FOwnList.ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n FOwnList.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n CheckValid;\r\n Valid := False;\r\n if FCursor <> nil then\r\n begin\r\n FCursor.Value := 0;\r\n if FCursor.Next <> nil then\r\n FCursor.Next.Previous := FCursor.Previous;\r\n if FCursor.Previous <> nil then\r\n FCursor.Previous.Next := FCursor.Next;\r\n OldCursor := FCursor;\r\n FCursor := FCursor.Next;\r\n OldCursor.Free;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnList.WriteUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclIntegerLinkedListIterator.Reset;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnList.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Valid := False;\r\n case FStart of\r\n isFirst:\r\n begin\r\n while (FCursor <> nil) and (FCursor.Previous <> nil) do\r\n FCursor := FCursor.Previous;\r\n end;\r\n isLast:\r\n begin\r\n while (FCursor <> nil) and (FCursor.Next <> nil) do\r\n FCursor := FCursor.Next;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnList.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclIntegerLinkedListIterator.SetValue(AValue: Integer);\r\nbegin\r\n if FOwnList.ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n FOwnList.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n CheckValid;\r\n FCursor.Value := 0;\r\n FCursor.Value := AValue;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnList.WriteUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\n//=== { TJclCardinalLinkedList } ==================================================\r\n\r\nconstructor TJclCardinalLinkedList.Create(const ACollection: IJclCardinalCollection);\r\nbegin\r\n inherited Create();\r\n FStart := nil;\r\n FEnd := nil;\r\n if ACollection <> nil then\r\n AddAll(ACollection);\r\nend;\r\n\r\ndestructor TJclCardinalLinkedList.Destroy;\r\nbegin\r\n FReadOnly := False;\r\n Clear;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJclCardinalLinkedList.Add(AValue: Cardinal): Boolean;\r\nvar\r\n NewItem: TJclCardinalLinkedListItem;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := FAllowDefaultElements or not ItemsEqual(AValue, 0);\r\n if Result then\r\n begin\r\n if FDuplicates <> dupAccept then\r\n begin\r\n NewItem := FStart;\r\n while NewItem <> nil do\r\n begin\r\n if ItemsEqual(AValue, NewItem.Value) then\r\n begin\r\n Result := CheckDuplicate;\r\n Break;\r\n end;\r\n NewItem := NewItem.Next;\r\n end;\r\n end;\r\n if Result then\r\n begin\r\n NewItem := TJclCardinalLinkedListItem.Create;\r\n NewItem.Value := AValue;\r\n if FStart <> nil then\r\n begin\r\n NewItem.Next := nil;\r\n NewItem.Previous := FEnd;\r\n FEnd.Next := NewItem;\r\n FEnd := NewItem;\r\n end\r\n else\r\n begin\r\n FStart := NewItem;\r\n FEnd := NewItem;\r\n end;\r\n Inc(FSize);\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclCardinalLinkedList.AddAll(const ACollection: IJclCardinalCollection): Boolean;\r\nvar\r\n It: IJclCardinalIterator;\r\n Item: Cardinal;\r\n AddItem: Boolean;\r\n NewItem: TJclCardinalLinkedListItem;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n begin\r\n Item := It.Next;\r\n AddItem := FAllowDefaultElements or not ItemsEqual(Item, 0);\r\n if AddItem then\r\n begin\r\n if FDuplicates <> dupAccept then\r\n begin\r\n NewItem := FStart;\r\n while NewItem <> nil do\r\n begin\r\n if ItemsEqual(Item, NewItem.Value) then\r\n begin\r\n AddItem := CheckDuplicate;\r\n Break;\r\n end;\r\n NewItem := NewItem.Next;\r\n end;\r\n end;\r\n if AddItem then\r\n begin\r\n NewItem := TJclCardinalLinkedListItem.Create;\r\n NewItem.Value := Item;\r\n if FStart <> nil then\r\n begin\r\n NewItem.Next := nil;\r\n NewItem.Previous := FEnd;\r\n FEnd.Next := NewItem;\r\n FEnd := NewItem;\r\n end\r\n else\r\n begin\r\n FStart := NewItem;\r\n FEnd := NewItem;\r\n end;\r\n Inc(FSize);\r\n end;\r\n end;\r\n Result := AddItem and Result;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclCardinalLinkedList.AssignDataTo(Dest: TJclAbstractContainerBase);\r\nvar\r\n ACollection: IJclCardinalCollection;\r\nbegin\r\n inherited AssignDataTo(Dest);\r\n if Supports(IInterface(Dest), IJclCardinalCollection, ACollection) then\r\n begin\r\n ACollection.Clear;\r\n ACollection.AddAll(Self);\r\n end;\r\nend;\r\n\r\nprocedure TJclCardinalLinkedList.Clear;\r\nvar\r\n Old, Current: TJclCardinalLinkedListItem;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Current := FStart;\r\n while Current <> nil do\r\n begin\r\n FreeCardinal(Current.Value);\r\n Old := Current;\r\n Current := Current.Next;\r\n Old.Free;\r\n end;\r\n FSize := 0;\r\n\r\n //Daniele Teti 27/12/2004\r\n FStart := nil;\r\n FEnd := nil;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclCardinalLinkedList.CollectionEquals(const ACollection: IJclCardinalCollection): Boolean;\r\nvar\r\n It, ItSelf: IJclCardinalIterator;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n if FSize <> ACollection.Size then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n ItSelf := First;\r\n while ItSelf.HasNext and It.HasNext do\r\n if not ItemsEqual(ItSelf.Next, It.Next) then\r\n begin\r\n Result := False;\r\n Break;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclCardinalLinkedList.Contains(AValue: Cardinal): Boolean;\r\nvar\r\n Current: TJclCardinalLinkedListItem;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n Current := FStart;\r\n while Current <> nil do\r\n begin\r\n if ItemsEqual(Current.Value, AValue) then\r\n begin\r\n Result := True;\r\n Break;\r\n end;\r\n Current := Current.Next;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclCardinalLinkedList.ContainsAll(const ACollection: IJclCardinalCollection): Boolean;\r\nvar\r\n It: IJclCardinalIterator;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n while Result and It.HasNext do\r\n Result := Contains(It.Next);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclCardinalLinkedList.Delete(Index: Integer): Cardinal;\r\nvar\r\n Current: TJclCardinalLinkedListItem;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := 0;\r\n if (Index >= 0) and (Index < FSize) then\r\n begin\r\n Current := FStart;\r\n while Current <> nil do\r\n begin\r\n if Index = 0 then\r\n begin\r\n if Current.Previous <> nil then\r\n Current.Previous.Next := Current.Next\r\n else\r\n FStart := Current.Next;\r\n if Current.Next <> nil then\r\n Current.Next.Previous := Current.Previous\r\n else\r\n FEnd := Current.Previous;\r\n Result := FreeCardinal(Current.Value);\r\n Current.Free;\r\n Dec(FSize);\r\n Break;\r\n end;\r\n Dec(Index);\r\n Current := Current.Next;\r\n end;\r\n end\r\n else\r\n raise EJclOutOfBoundsError.Create;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclCardinalLinkedList.Extract(AValue: Cardinal): Boolean;\r\nvar\r\n Current: TJclCardinalLinkedListItem;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n Current := FStart;\r\n while Current <> nil do\r\n begin\r\n if ItemsEqual(Current.Value, AValue) then\r\n begin\r\n if Current.Previous <> nil then\r\n Current.Previous.Next := Current.Next\r\n else\r\n FStart := Current.Next;\r\n if Current.Next <> nil then\r\n Current.Next.Previous := Current.Previous\r\n else\r\n FEnd := Current.Previous;\r\n Current.Value := 0;\r\n Current.Free;\r\n Dec(FSize);\r\n Result := True;\r\n if FRemoveSingleElement then\r\n Break;\r\n end;\r\n Current := Current.Next;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclCardinalLinkedList.ExtractAll(const ACollection: IJclCardinalCollection): Boolean;\r\nvar\r\n It: IJclCardinalIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := True;\r\n if ACollection = nil then\r\n Exit;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n Result := Extract(It.Next) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclCardinalLinkedList.ExtractIndex(Index: Integer): Cardinal;\r\nvar\r\n Current: TJclCardinalLinkedListItem;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := 0;\r\n if (Index >= 0) and (Index < FSize) then\r\n begin\r\n Current := FStart;\r\n while Current <> nil do\r\n begin\r\n if Index = 0 then\r\n begin\r\n if Current.Previous <> nil then\r\n Current.Previous.Next := Current.Next\r\n else\r\n FStart := Current.Next;\r\n if Current.Next <> nil then\r\n Current.Next.Previous := Current.Previous\r\n else\r\n FEnd := Current.Previous;\r\n Result := Current.Value;\r\n Current.Free;\r\n Dec(FSize);\r\n Break;\r\n end;\r\n Dec(Index);\r\n Current := Current.Next;\r\n end;\r\n end\r\n else\r\n raise EJclOutOfBoundsError.Create;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclCardinalLinkedList.First: IJclCardinalIterator;\r\nbegin\r\n Result := TJclCardinalLinkedListIterator.Create(Self, FStart, False, isFirst);\r\nend;\r\n\r\n{$IFDEF SUPPORTS_FOR_IN}\r\nfunction TJclCardinalLinkedList.GetEnumerator: IJclCardinalIterator;\r\nbegin\r\n Result := TJclCardinalLinkedListIterator.Create(Self, FStart, False, isFirst);\r\nend;\r\n{$ENDIF SUPPORTS_FOR_IN}\r\n\r\nfunction TJclCardinalLinkedList.GetValue(Index: Integer): Cardinal;\r\nvar\r\n Current: TJclCardinalLinkedListItem;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := 0;\r\n Current := FStart;\r\n while (Current <> nil) and (Index > 0) do\r\n begin\r\n Current := Current.Next;\r\n Dec(Index);\r\n end;\r\n if Current <> nil then\r\n Result := Current.Value\r\n else\r\n if not FReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclCardinalLinkedList.IndexOf(AValue: Cardinal): Integer;\r\nvar\r\n Current: TJclCardinalLinkedListItem;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Current := FStart;\r\n Result := 0;\r\n while (Current <> nil) and not ItemsEqual(Current.Value, AValue) do\r\n begin\r\n Inc(Result);\r\n Current := Current.Next;\r\n end;\r\n if Current = nil then\r\n Result := -1;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclCardinalLinkedList.Insert(Index: Integer; AValue: Cardinal): Boolean;\r\nvar\r\n Current, NewItem: TJclCardinalLinkedListItem;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := FAllowDefaultElements or not ItemsEqual(AValue, 0);\r\n if (Index < 0) or (Index > FSize) then\r\n raise EJclOutOfBoundsError.Create;\r\n if Result then\r\n begin\r\n if FDuplicates <> dupAccept then\r\n begin\r\n Current := FStart;\r\n while Current <> nil do\r\n begin\r\n if ItemsEqual(AValue, Current.Value) then\r\n begin\r\n Result := CheckDuplicate;\r\n Break;\r\n end;\r\n Current := Current.Next;\r\n end;\r\n end;\r\n if Result then\r\n begin\r\n NewItem := TJclCardinalLinkedListItem.Create;\r\n NewItem.Value := AValue;\r\n if Index = 0 then\r\n begin\r\n NewItem.Next := FStart;\r\n if FStart <> nil then\r\n FStart.Previous := NewItem;\r\n FStart := NewItem;\r\n if FSize = 0 then\r\n FEnd := NewItem;\r\n Inc(FSize);\r\n end\r\n else\r\n if Index = FSize then\r\n begin\r\n NewItem.Previous := FEnd;\r\n FEnd.Next := NewItem;\r\n FEnd := NewItem;\r\n Inc(FSize);\r\n end\r\n else\r\n begin\r\n Current := FStart;\r\n while (Current <> nil) and (Index > 0) do\r\n begin\r\n Current := Current.Next;\r\n Dec(Index);\r\n end;\r\n if Current <> nil then\r\n begin\r\n NewItem.Next := Current;\r\n NewItem.Previous := Current.Previous;\r\n if Current.Previous <> nil then\r\n Current.Previous.Next := NewItem;\r\n Current.Previous := NewItem;\r\n Inc(FSize);\r\n end;\r\n end;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclCardinalLinkedList.InsertAll(Index: Integer; const ACollection: IJclCardinalCollection): Boolean;\r\nvar\r\n It: IJclCardinalIterator;\r\n Current, NewItem, Test: TJclCardinalLinkedListItem;\r\n AddItem: Boolean;\r\n Item: Cardinal;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if (Index < 0) or (Index > FSize) then\r\n raise EJclOutOfBoundsError.Create;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n if Index = 0 then\r\n begin\r\n It := ACollection.Last;\r\n while It.HasPrevious do\r\n begin\r\n Item := It.Previous;\r\n AddItem := FAllowDefaultElements or not ItemsEqual(Item, 0);\r\n if AddItem then\r\n begin\r\n if FDuplicates <> dupAccept then\r\n begin\r\n Test := FStart;\r\n while Test <> nil do\r\n begin\r\n if ItemsEqual(Item, Test.Value) then\r\n begin\r\n Result := CheckDuplicate;\r\n Break;\r\n end;\r\n Test := Test.Next;\r\n end;\r\n end;\r\n if AddItem then\r\n begin\r\n NewItem := TJclCardinalLinkedListItem.Create;\r\n NewItem.Value := Item;\r\n NewItem.Next := FStart;\r\n if FStart <> nil then\r\n FStart.Previous := NewItem;\r\n FStart := NewItem;\r\n if FSize = 0 then\r\n FEnd := NewItem;\r\n Inc(FSize);\r\n end;\r\n end;\r\n Result := Result and AddItem;\r\n end;\r\n end\r\n else\r\n if Index = Size then\r\n begin\r\n It := ACollection.First;\r\n while It.HasNext do\r\n begin\r\n Item := It.Next;\r\n AddItem := FAllowDefaultElements or not ItemsEqual(Item, 0);\r\n if AddItem then\r\n begin\r\n if FDuplicates <> dupAccept then\r\n begin\r\n Test := FStart;\r\n while Test <> nil do\r\n begin\r\n if ItemsEqual(Item, Test.Value) then\r\n begin\r\n Result := CheckDuplicate;\r\n Break;\r\n end;\r\n Test := Test.Next;\r\n end;\r\n end;\r\n if AddItem then\r\n begin\r\n NewItem := TJclCardinalLinkedListItem.Create;\r\n NewItem.Value := Item;\r\n NewItem.Previous := FEnd;\r\n if FEnd <> nil then\r\n FEnd.Next := NewItem;\r\n FEnd := NewItem;\r\n Inc(FSize);\r\n end;\r\n end;\r\n Result := Result and AddItem;\r\n end;\r\n end\r\n else\r\n begin\r\n Current := FStart;\r\n while (Current <> nil) and (Index > 0) do\r\n begin\r\n Current := Current.Next;\r\n Dec(Index);\r\n end;\r\n if Current <> nil then\r\n begin\r\n It := ACollection.First;\r\n while It.HasNext do\r\n begin\r\n Item := It.Next;\r\n AddItem := FAllowDefaultElements or not ItemsEqual(Item, 0);\r\n if AddItem then\r\n begin\r\n if FDuplicates <> dupAccept then\r\n begin\r\n Test := FStart;\r\n while Test <> nil do\r\n begin\r\n if ItemsEqual(Item, Test.Value) then\r\n begin\r\n Result := CheckDuplicate;\r\n Break;\r\n end;\r\n Test := Test.Next;\r\n end;\r\n end;\r\n if AddItem then\r\n begin\r\n NewItem := TJclCardinalLinkedListItem.Create;\r\n NewItem.Value := Item;\r\n NewItem.Next := Current;\r\n NewItem.Previous := Current.Previous;\r\n if Current.Previous <> nil then\r\n Current.Previous.Next := NewItem;\r\n Current.Previous := NewItem;\r\n Inc(FSize);\r\n end;\r\n end;\r\n Result := Result and AddItem;\r\n end;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclCardinalLinkedList.IsEmpty: Boolean;\r\nbegin\r\n Result := FSize = 0;\r\nend;\r\n\r\nfunction TJclCardinalLinkedList.Last: IJclCardinalIterator;\r\nbegin\r\n Result := TJclCardinalLinkedListIterator.Create(Self, FEnd, False, isLast);\r\nend;\r\n\r\nfunction TJclCardinalLinkedList.LastIndexOf(AValue: Cardinal): Integer;\r\nvar\r\n Current: TJclCardinalLinkedListItem;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := -1;\r\n if FEnd <> nil then\r\n begin\r\n Current := FEnd;\r\n Result := FSize - 1;\r\n while (Current <> nil) and not ItemsEqual(Current.Value, AValue) do\r\n begin\r\n Dec(Result);\r\n Current := Current.Previous;\r\n end;\r\n if Current = nil then\r\n Result := -1;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclCardinalLinkedList.Remove(AValue: Cardinal): Boolean;\r\nvar\r\n Extracted: Cardinal;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := Extract(AValue);\r\n if Result then\r\n begin\r\n Extracted := AValue;\r\n FreeCardinal(Extracted);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclCardinalLinkedList.RemoveAll(const ACollection: IJclCardinalCollection): Boolean;\r\nvar\r\n It: IJclCardinalIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := True;\r\n if ACollection = nil then\r\n Exit;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n Result := Remove(It.Next) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclCardinalLinkedList.RetainAll(const ACollection: IJclCardinalCollection): Boolean;\r\nvar\r\n It: IJclCardinalIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := First;\r\n while It.HasNext do\r\n if not ACollection.Contains(It.Next) then\r\n It.Remove;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclCardinalLinkedList.SetValue(Index: Integer; AValue: Cardinal);\r\nvar\r\n Current: TJclCardinalLinkedListItem;\r\n ReplaceItem: Boolean;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n ReplaceItem := FAllowDefaultElements or not ItemsEqual(AValue, 0);\r\n if ReplaceItem then\r\n begin\r\n if FDuplicates <> dupAccept then\r\n begin\r\n Current := FStart;\r\n while Current <> nil do\r\n begin\r\n if ItemsEqual(AValue, Current.Value) then\r\n begin\r\n ReplaceItem := CheckDuplicate;\r\n Break;\r\n end;\r\n Current := Current.Next;\r\n end;\r\n end;\r\n if ReplaceItem then\r\n begin\r\n Current := FStart;\r\n while Current <> nil do\r\n begin\r\n if Index = 0 then\r\n begin\r\n FreeCardinal(Current.Value);\r\n Current.Value := AValue;\r\n Break;\r\n end;\r\n Dec(Index);\r\n Current := Current.Next;\r\n end;\r\n end;\r\n end;\r\n if not ReplaceItem then\r\n Delete(Index);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclCardinalLinkedList.Size: Integer;\r\nbegin\r\n Result := FSize;\r\nend;\r\n\r\nfunction TJclCardinalLinkedList.SubList(First, Count: Integer): IJclCardinalList;\r\nvar\r\n Current: TJclCardinalLinkedListItem;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := CreateEmptyContainer as IJclCardinalList;\r\n Current := FStart;\r\n while (Current <> nil) and (First > 0) do\r\n begin\r\n Dec(First);\r\n Current := Current.Next;\r\n end;\r\n while (Current <> nil) and (Count > 0) do\r\n begin\r\n Result.Add(Current.Value);\r\n Dec(Count);\r\n Current := Current.Next;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclCardinalLinkedList.CreateEmptyContainer: TJclAbstractContainerBase;\r\nbegin\r\n Result := TJclCardinalLinkedList.Create(nil);\r\n AssignPropertiesTo(Result);\r\nend;\r\n\r\n//=== { TJclCardinalLinkedListIterator } ============================================================\r\n\r\nconstructor TJclCardinalLinkedListIterator.Create(AOwnList: TJclCardinalLinkedList; ACursor: TJclCardinalLinkedListItem; AValid: Boolean; AStart: TItrStart);\r\nbegin\r\n inherited Create(AValid);\r\n FCursor := ACursor;\r\n FOwnList := AOwnList;\r\n FStart := AStart;\r\n FEqualityComparer := AOwnList as IJclCardinalEqualityComparer;\r\nend;\r\n\r\nfunction TJclCardinalLinkedListIterator.Add(AValue: Cardinal): Boolean;\r\nbegin\r\n Result := FOwnList.Add(AValue);\r\nend;\r\n\r\nprocedure TJclCardinalLinkedListIterator.AssignPropertiesTo(Dest: TJclAbstractIterator);\r\nvar\r\n ADest: TJclCardinalLinkedListIterator;\r\nbegin\r\n inherited AssignPropertiesTo(Dest);\r\n if Dest is TJclCardinalLinkedListIterator then\r\n begin\r\n ADest := TJclCardinalLinkedListIterator(Dest);\r\n ADest.FCursor := FCursor;\r\n ADest.FOwnList := FOwnList;\r\n ADest.FEqualityComparer := FEqualityComparer;\r\n ADest.FStart := FStart;\r\n end;\r\nend;\r\n\r\nfunction TJclCardinalLinkedListIterator.CreateEmptyIterator: TJclAbstractIterator;\r\nbegin\r\n Result := TJclCardinalLinkedListIterator.Create(FOwnList, FCursor, Valid, FStart);\r\nend;\r\n\r\nprocedure TJclCardinalLinkedListIterator.Extract;\r\nvar\r\n OldCursor: TJclCardinalLinkedListItem;\r\nbegin\r\n if FOwnList.ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n FOwnList.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n CheckValid;\r\n Valid := False;\r\n if FCursor <> nil then\r\n begin\r\n if FCursor.Next <> nil then\r\n FCursor.Next.Previous := FCursor.Previous;\r\n if FCursor.Previous <> nil then\r\n FCursor.Previous.Next := FCursor.Next;\r\n OldCursor := FCursor;\r\n FCursor := FCursor.Next;\r\n OldCursor.Free;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnList.WriteUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclCardinalLinkedListIterator.GetValue: Cardinal;\r\nbegin\r\n CheckValid;\r\n Result := 0;\r\n if FCursor <> nil then\r\n Result := FCursor.Value\r\n else\r\n if not FOwnList.ReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\nend;\r\n\r\nfunction TJclCardinalLinkedListIterator.HasNext: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnList.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Valid then\r\n Result := (FCursor <> nil) and (FCursor.Next <> nil)\r\n else\r\n Result := FCursor <> nil;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnList.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclCardinalLinkedListIterator.HasPrevious: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnList.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Valid then\r\n Result := (FCursor <> nil) and (FCursor.Previous <> nil)\r\n else\r\n Result := FCursor <> nil;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnList.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclCardinalLinkedListIterator.Insert(AValue: Cardinal): Boolean;\r\nvar\r\n NewCursor: TJclCardinalLinkedListItem;\r\nbegin\r\n if FOwnList.ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n FOwnList.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n CheckValid;\r\n Result := FCursor <> nil;\r\n if Result then\r\n begin\r\n Result := FOwnList.AllowDefaultElements or not FEqualityComparer.ItemsEqual(AValue, 0);\r\n if Result then\r\n begin\r\n case FOwnList.Duplicates of\r\n dupIgnore:\r\n Result := not FOwnList.Contains(AValue);\r\n dupAccept:\r\n Result := True;\r\n dupError:\r\n begin\r\n Result := FOwnList.Contains(AValue);\r\n if not Result then\r\n raise EJclDuplicateElementError.Create;\r\n end;\r\n end;\r\n if Result then\r\n begin\r\n NewCursor := TJclCardinalLinkedListItem.Create;\r\n NewCursor.Value := AValue;\r\n NewCursor.Next := FCursor;\r\n NewCursor.Previous := FCursor.Previous;\r\n if FCursor.Previous <> nil then\r\n FCursor.Previous.Next := NewCursor;\r\n FCursor.Previous := NewCursor;\r\n FCursor := NewCursor;\r\n end;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnList.WriteUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclCardinalLinkedListIterator.IteratorEquals(const AIterator: IJclCardinalIterator): Boolean;\r\nvar\r\n Obj: TObject;\r\n ItrObj: TJclCardinalLinkedListIterator;\r\nbegin\r\n Result := False;\r\n if AIterator = nil then\r\n Exit;\r\n Obj := AIterator.GetIteratorReference;\r\n if Obj is TJclCardinalLinkedListIterator then\r\n begin\r\n ItrObj := TJclCardinalLinkedListIterator(Obj);\r\n Result := (FOwnList = ItrObj.FOwnList) and (FCursor = ItrObj.FCursor) and (Valid = ItrObj.Valid);\r\n end;\r\nend;\r\n\r\n{$IFDEF SUPPORTS_FOR_IN}\r\nfunction TJclCardinalLinkedListIterator.MoveNext: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnList.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Valid and (FCursor <> nil) then\r\n FCursor := FCursor.Next\r\n else\r\n Valid := True;\r\n Result := FCursor <> nil;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnList.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n{$ENDIF SUPPORTS_FOR_IN}\r\n\r\nfunction TJclCardinalLinkedListIterator.Next: Cardinal;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnList.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Valid and (FCursor <> nil) then\r\n FCursor := FCursor.Next\r\n else\r\n Valid := True;\r\n if FCursor <> nil then\r\n Result := FCursor.Value\r\n else\r\n Result := 0;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnList.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclCardinalLinkedListIterator.NextIndex: Integer;\r\nbegin\r\n // No Index\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nfunction TJclCardinalLinkedListIterator.Previous: Cardinal;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnList.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Valid and (FCursor <> nil) then\r\n FCursor := FCursor.Previous\r\n else\r\n Valid := True;\r\n if FCursor <> nil then\r\n Result := FCursor.Value\r\n else\r\n Result := 0;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnList.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclCardinalLinkedListIterator.PreviousIndex: Integer;\r\nbegin\r\n // No Index\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nprocedure TJclCardinalLinkedListIterator.Remove;\r\nvar\r\n OldCursor: TJclCardinalLinkedListItem;\r\nbegin\r\n if FOwnList.ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n FOwnList.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n CheckValid;\r\n Valid := False;\r\n if FCursor <> nil then\r\n begin\r\n FCursor.Value := 0;\r\n if FCursor.Next <> nil then\r\n FCursor.Next.Previous := FCursor.Previous;\r\n if FCursor.Previous <> nil then\r\n FCursor.Previous.Next := FCursor.Next;\r\n OldCursor := FCursor;\r\n FCursor := FCursor.Next;\r\n OldCursor.Free;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnList.WriteUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclCardinalLinkedListIterator.Reset;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnList.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Valid := False;\r\n case FStart of\r\n isFirst:\r\n begin\r\n while (FCursor <> nil) and (FCursor.Previous <> nil) do\r\n FCursor := FCursor.Previous;\r\n end;\r\n isLast:\r\n begin\r\n while (FCursor <> nil) and (FCursor.Next <> nil) do\r\n FCursor := FCursor.Next;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnList.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclCardinalLinkedListIterator.SetValue(AValue: Cardinal);\r\nbegin\r\n if FOwnList.ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n FOwnList.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n CheckValid;\r\n FCursor.Value := 0;\r\n FCursor.Value := AValue;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnList.WriteUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\n//=== { TJclInt64LinkedList } ==================================================\r\n\r\nconstructor TJclInt64LinkedList.Create(const ACollection: IJclInt64Collection);\r\nbegin\r\n inherited Create();\r\n FStart := nil;\r\n FEnd := nil;\r\n if ACollection <> nil then\r\n AddAll(ACollection);\r\nend;\r\n\r\ndestructor TJclInt64LinkedList.Destroy;\r\nbegin\r\n FReadOnly := False;\r\n Clear;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJclInt64LinkedList.Add(const AValue: Int64): Boolean;\r\nvar\r\n NewItem: TJclInt64LinkedListItem;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := FAllowDefaultElements or not ItemsEqual(AValue, 0);\r\n if Result then\r\n begin\r\n if FDuplicates <> dupAccept then\r\n begin\r\n NewItem := FStart;\r\n while NewItem <> nil do\r\n begin\r\n if ItemsEqual(AValue, NewItem.Value) then\r\n begin\r\n Result := CheckDuplicate;\r\n Break;\r\n end;\r\n NewItem := NewItem.Next;\r\n end;\r\n end;\r\n if Result then\r\n begin\r\n NewItem := TJclInt64LinkedListItem.Create;\r\n NewItem.Value := AValue;\r\n if FStart <> nil then\r\n begin\r\n NewItem.Next := nil;\r\n NewItem.Previous := FEnd;\r\n FEnd.Next := NewItem;\r\n FEnd := NewItem;\r\n end\r\n else\r\n begin\r\n FStart := NewItem;\r\n FEnd := NewItem;\r\n end;\r\n Inc(FSize);\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclInt64LinkedList.AddAll(const ACollection: IJclInt64Collection): Boolean;\r\nvar\r\n It: IJclInt64Iterator;\r\n Item: Int64;\r\n AddItem: Boolean;\r\n NewItem: TJclInt64LinkedListItem;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n begin\r\n Item := It.Next;\r\n AddItem := FAllowDefaultElements or not ItemsEqual(Item, 0);\r\n if AddItem then\r\n begin\r\n if FDuplicates <> dupAccept then\r\n begin\r\n NewItem := FStart;\r\n while NewItem <> nil do\r\n begin\r\n if ItemsEqual(Item, NewItem.Value) then\r\n begin\r\n AddItem := CheckDuplicate;\r\n Break;\r\n end;\r\n NewItem := NewItem.Next;\r\n end;\r\n end;\r\n if AddItem then\r\n begin\r\n NewItem := TJclInt64LinkedListItem.Create;\r\n NewItem.Value := Item;\r\n if FStart <> nil then\r\n begin\r\n NewItem.Next := nil;\r\n NewItem.Previous := FEnd;\r\n FEnd.Next := NewItem;\r\n FEnd := NewItem;\r\n end\r\n else\r\n begin\r\n FStart := NewItem;\r\n FEnd := NewItem;\r\n end;\r\n Inc(FSize);\r\n end;\r\n end;\r\n Result := AddItem and Result;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclInt64LinkedList.AssignDataTo(Dest: TJclAbstractContainerBase);\r\nvar\r\n ACollection: IJclInt64Collection;\r\nbegin\r\n inherited AssignDataTo(Dest);\r\n if Supports(IInterface(Dest), IJclInt64Collection, ACollection) then\r\n begin\r\n ACollection.Clear;\r\n ACollection.AddAll(Self);\r\n end;\r\nend;\r\n\r\nprocedure TJclInt64LinkedList.Clear;\r\nvar\r\n Old, Current: TJclInt64LinkedListItem;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Current := FStart;\r\n while Current <> nil do\r\n begin\r\n FreeInt64(Current.Value);\r\n Old := Current;\r\n Current := Current.Next;\r\n Old.Free;\r\n end;\r\n FSize := 0;\r\n\r\n //Daniele Teti 27/12/2004\r\n FStart := nil;\r\n FEnd := nil;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclInt64LinkedList.CollectionEquals(const ACollection: IJclInt64Collection): Boolean;\r\nvar\r\n It, ItSelf: IJclInt64Iterator;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n if FSize <> ACollection.Size then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n ItSelf := First;\r\n while ItSelf.HasNext and It.HasNext do\r\n if not ItemsEqual(ItSelf.Next, It.Next) then\r\n begin\r\n Result := False;\r\n Break;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclInt64LinkedList.Contains(const AValue: Int64): Boolean;\r\nvar\r\n Current: TJclInt64LinkedListItem;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n Current := FStart;\r\n while Current <> nil do\r\n begin\r\n if ItemsEqual(Current.Value, AValue) then\r\n begin\r\n Result := True;\r\n Break;\r\n end;\r\n Current := Current.Next;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclInt64LinkedList.ContainsAll(const ACollection: IJclInt64Collection): Boolean;\r\nvar\r\n It: IJclInt64Iterator;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n while Result and It.HasNext do\r\n Result := Contains(It.Next);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclInt64LinkedList.Delete(Index: Integer): Int64;\r\nvar\r\n Current: TJclInt64LinkedListItem;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := 0;\r\n if (Index >= 0) and (Index < FSize) then\r\n begin\r\n Current := FStart;\r\n while Current <> nil do\r\n begin\r\n if Index = 0 then\r\n begin\r\n if Current.Previous <> nil then\r\n Current.Previous.Next := Current.Next\r\n else\r\n FStart := Current.Next;\r\n if Current.Next <> nil then\r\n Current.Next.Previous := Current.Previous\r\n else\r\n FEnd := Current.Previous;\r\n Result := FreeInt64(Current.Value);\r\n Current.Free;\r\n Dec(FSize);\r\n Break;\r\n end;\r\n Dec(Index);\r\n Current := Current.Next;\r\n end;\r\n end\r\n else\r\n raise EJclOutOfBoundsError.Create;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclInt64LinkedList.Extract(const AValue: Int64): Boolean;\r\nvar\r\n Current: TJclInt64LinkedListItem;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n Current := FStart;\r\n while Current <> nil do\r\n begin\r\n if ItemsEqual(Current.Value, AValue) then\r\n begin\r\n if Current.Previous <> nil then\r\n Current.Previous.Next := Current.Next\r\n else\r\n FStart := Current.Next;\r\n if Current.Next <> nil then\r\n Current.Next.Previous := Current.Previous\r\n else\r\n FEnd := Current.Previous;\r\n Current.Value := 0;\r\n Current.Free;\r\n Dec(FSize);\r\n Result := True;\r\n if FRemoveSingleElement then\r\n Break;\r\n end;\r\n Current := Current.Next;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclInt64LinkedList.ExtractAll(const ACollection: IJclInt64Collection): Boolean;\r\nvar\r\n It: IJclInt64Iterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := True;\r\n if ACollection = nil then\r\n Exit;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n Result := Extract(It.Next) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclInt64LinkedList.ExtractIndex(Index: Integer): Int64;\r\nvar\r\n Current: TJclInt64LinkedListItem;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := 0;\r\n if (Index >= 0) and (Index < FSize) then\r\n begin\r\n Current := FStart;\r\n while Current <> nil do\r\n begin\r\n if Index = 0 then\r\n begin\r\n if Current.Previous <> nil then\r\n Current.Previous.Next := Current.Next\r\n else\r\n FStart := Current.Next;\r\n if Current.Next <> nil then\r\n Current.Next.Previous := Current.Previous\r\n else\r\n FEnd := Current.Previous;\r\n Result := Current.Value;\r\n Current.Free;\r\n Dec(FSize);\r\n Break;\r\n end;\r\n Dec(Index);\r\n Current := Current.Next;\r\n end;\r\n end\r\n else\r\n raise EJclOutOfBoundsError.Create;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclInt64LinkedList.First: IJclInt64Iterator;\r\nbegin\r\n Result := TJclInt64LinkedListIterator.Create(Self, FStart, False, isFirst);\r\nend;\r\n\r\n{$IFDEF SUPPORTS_FOR_IN}\r\nfunction TJclInt64LinkedList.GetEnumerator: IJclInt64Iterator;\r\nbegin\r\n Result := TJclInt64LinkedListIterator.Create(Self, FStart, False, isFirst);\r\nend;\r\n{$ENDIF SUPPORTS_FOR_IN}\r\n\r\nfunction TJclInt64LinkedList.GetValue(Index: Integer): Int64;\r\nvar\r\n Current: TJclInt64LinkedListItem;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := 0;\r\n Current := FStart;\r\n while (Current <> nil) and (Index > 0) do\r\n begin\r\n Current := Current.Next;\r\n Dec(Index);\r\n end;\r\n if Current <> nil then\r\n Result := Current.Value\r\n else\r\n if not FReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclInt64LinkedList.IndexOf(const AValue: Int64): Integer;\r\nvar\r\n Current: TJclInt64LinkedListItem;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Current := FStart;\r\n Result := 0;\r\n while (Current <> nil) and not ItemsEqual(Current.Value, AValue) do\r\n begin\r\n Inc(Result);\r\n Current := Current.Next;\r\n end;\r\n if Current = nil then\r\n Result := -1;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclInt64LinkedList.Insert(Index: Integer; const AValue: Int64): Boolean;\r\nvar\r\n Current, NewItem: TJclInt64LinkedListItem;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := FAllowDefaultElements or not ItemsEqual(AValue, 0);\r\n if (Index < 0) or (Index > FSize) then\r\n raise EJclOutOfBoundsError.Create;\r\n if Result then\r\n begin\r\n if FDuplicates <> dupAccept then\r\n begin\r\n Current := FStart;\r\n while Current <> nil do\r\n begin\r\n if ItemsEqual(AValue, Current.Value) then\r\n begin\r\n Result := CheckDuplicate;\r\n Break;\r\n end;\r\n Current := Current.Next;\r\n end;\r\n end;\r\n if Result then\r\n begin\r\n NewItem := TJclInt64LinkedListItem.Create;\r\n NewItem.Value := AValue;\r\n if Index = 0 then\r\n begin\r\n NewItem.Next := FStart;\r\n if FStart <> nil then\r\n FStart.Previous := NewItem;\r\n FStart := NewItem;\r\n if FSize = 0 then\r\n FEnd := NewItem;\r\n Inc(FSize);\r\n end\r\n else\r\n if Index = FSize then\r\n begin\r\n NewItem.Previous := FEnd;\r\n FEnd.Next := NewItem;\r\n FEnd := NewItem;\r\n Inc(FSize);\r\n end\r\n else\r\n begin\r\n Current := FStart;\r\n while (Current <> nil) and (Index > 0) do\r\n begin\r\n Current := Current.Next;\r\n Dec(Index);\r\n end;\r\n if Current <> nil then\r\n begin\r\n NewItem.Next := Current;\r\n NewItem.Previous := Current.Previous;\r\n if Current.Previous <> nil then\r\n Current.Previous.Next := NewItem;\r\n Current.Previous := NewItem;\r\n Inc(FSize);\r\n end;\r\n end;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclInt64LinkedList.InsertAll(Index: Integer; const ACollection: IJclInt64Collection): Boolean;\r\nvar\r\n It: IJclInt64Iterator;\r\n Current, NewItem, Test: TJclInt64LinkedListItem;\r\n AddItem: Boolean;\r\n Item: Int64;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if (Index < 0) or (Index > FSize) then\r\n raise EJclOutOfBoundsError.Create;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n if Index = 0 then\r\n begin\r\n It := ACollection.Last;\r\n while It.HasPrevious do\r\n begin\r\n Item := It.Previous;\r\n AddItem := FAllowDefaultElements or not ItemsEqual(Item, 0);\r\n if AddItem then\r\n begin\r\n if FDuplicates <> dupAccept then\r\n begin\r\n Test := FStart;\r\n while Test <> nil do\r\n begin\r\n if ItemsEqual(Item, Test.Value) then\r\n begin\r\n Result := CheckDuplicate;\r\n Break;\r\n end;\r\n Test := Test.Next;\r\n end;\r\n end;\r\n if AddItem then\r\n begin\r\n NewItem := TJclInt64LinkedListItem.Create;\r\n NewItem.Value := Item;\r\n NewItem.Next := FStart;\r\n if FStart <> nil then\r\n FStart.Previous := NewItem;\r\n FStart := NewItem;\r\n if FSize = 0 then\r\n FEnd := NewItem;\r\n Inc(FSize);\r\n end;\r\n end;\r\n Result := Result and AddItem;\r\n end;\r\n end\r\n else\r\n if Index = Size then\r\n begin\r\n It := ACollection.First;\r\n while It.HasNext do\r\n begin\r\n Item := It.Next;\r\n AddItem := FAllowDefaultElements or not ItemsEqual(Item, 0);\r\n if AddItem then\r\n begin\r\n if FDuplicates <> dupAccept then\r\n begin\r\n Test := FStart;\r\n while Test <> nil do\r\n begin\r\n if ItemsEqual(Item, Test.Value) then\r\n begin\r\n Result := CheckDuplicate;\r\n Break;\r\n end;\r\n Test := Test.Next;\r\n end;\r\n end;\r\n if AddItem then\r\n begin\r\n NewItem := TJclInt64LinkedListItem.Create;\r\n NewItem.Value := Item;\r\n NewItem.Previous := FEnd;\r\n if FEnd <> nil then\r\n FEnd.Next := NewItem;\r\n FEnd := NewItem;\r\n Inc(FSize);\r\n end;\r\n end;\r\n Result := Result and AddItem;\r\n end;\r\n end\r\n else\r\n begin\r\n Current := FStart;\r\n while (Current <> nil) and (Index > 0) do\r\n begin\r\n Current := Current.Next;\r\n Dec(Index);\r\n end;\r\n if Current <> nil then\r\n begin\r\n It := ACollection.First;\r\n while It.HasNext do\r\n begin\r\n Item := It.Next;\r\n AddItem := FAllowDefaultElements or not ItemsEqual(Item, 0);\r\n if AddItem then\r\n begin\r\n if FDuplicates <> dupAccept then\r\n begin\r\n Test := FStart;\r\n while Test <> nil do\r\n begin\r\n if ItemsEqual(Item, Test.Value) then\r\n begin\r\n Result := CheckDuplicate;\r\n Break;\r\n end;\r\n Test := Test.Next;\r\n end;\r\n end;\r\n if AddItem then\r\n begin\r\n NewItem := TJclInt64LinkedListItem.Create;\r\n NewItem.Value := Item;\r\n NewItem.Next := Current;\r\n NewItem.Previous := Current.Previous;\r\n if Current.Previous <> nil then\r\n Current.Previous.Next := NewItem;\r\n Current.Previous := NewItem;\r\n Inc(FSize);\r\n end;\r\n end;\r\n Result := Result and AddItem;\r\n end;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclInt64LinkedList.IsEmpty: Boolean;\r\nbegin\r\n Result := FSize = 0;\r\nend;\r\n\r\nfunction TJclInt64LinkedList.Last: IJclInt64Iterator;\r\nbegin\r\n Result := TJclInt64LinkedListIterator.Create(Self, FEnd, False, isLast);\r\nend;\r\n\r\nfunction TJclInt64LinkedList.LastIndexOf(const AValue: Int64): Integer;\r\nvar\r\n Current: TJclInt64LinkedListItem;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := -1;\r\n if FEnd <> nil then\r\n begin\r\n Current := FEnd;\r\n Result := FSize - 1;\r\n while (Current <> nil) and not ItemsEqual(Current.Value, AValue) do\r\n begin\r\n Dec(Result);\r\n Current := Current.Previous;\r\n end;\r\n if Current = nil then\r\n Result := -1;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclInt64LinkedList.Remove(const AValue: Int64): Boolean;\r\nvar\r\n Extracted: Int64;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := Extract(AValue);\r\n if Result then\r\n begin\r\n Extracted := AValue;\r\n FreeInt64(Extracted);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclInt64LinkedList.RemoveAll(const ACollection: IJclInt64Collection): Boolean;\r\nvar\r\n It: IJclInt64Iterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := True;\r\n if ACollection = nil then\r\n Exit;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n Result := Remove(It.Next) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclInt64LinkedList.RetainAll(const ACollection: IJclInt64Collection): Boolean;\r\nvar\r\n It: IJclInt64Iterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := First;\r\n while It.HasNext do\r\n if not ACollection.Contains(It.Next) then\r\n It.Remove;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclInt64LinkedList.SetValue(Index: Integer; const AValue: Int64);\r\nvar\r\n Current: TJclInt64LinkedListItem;\r\n ReplaceItem: Boolean;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n ReplaceItem := FAllowDefaultElements or not ItemsEqual(AValue, 0);\r\n if ReplaceItem then\r\n begin\r\n if FDuplicates <> dupAccept then\r\n begin\r\n Current := FStart;\r\n while Current <> nil do\r\n begin\r\n if ItemsEqual(AValue, Current.Value) then\r\n begin\r\n ReplaceItem := CheckDuplicate;\r\n Break;\r\n end;\r\n Current := Current.Next;\r\n end;\r\n end;\r\n if ReplaceItem then\r\n begin\r\n Current := FStart;\r\n while Current <> nil do\r\n begin\r\n if Index = 0 then\r\n begin\r\n FreeInt64(Current.Value);\r\n Current.Value := AValue;\r\n Break;\r\n end;\r\n Dec(Index);\r\n Current := Current.Next;\r\n end;\r\n end;\r\n end;\r\n if not ReplaceItem then\r\n Delete(Index);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclInt64LinkedList.Size: Integer;\r\nbegin\r\n Result := FSize;\r\nend;\r\n\r\nfunction TJclInt64LinkedList.SubList(First, Count: Integer): IJclInt64List;\r\nvar\r\n Current: TJclInt64LinkedListItem;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := CreateEmptyContainer as IJclInt64List;\r\n Current := FStart;\r\n while (Current <> nil) and (First > 0) do\r\n begin\r\n Dec(First);\r\n Current := Current.Next;\r\n end;\r\n while (Current <> nil) and (Count > 0) do\r\n begin\r\n Result.Add(Current.Value);\r\n Dec(Count);\r\n Current := Current.Next;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclInt64LinkedList.CreateEmptyContainer: TJclAbstractContainerBase;\r\nbegin\r\n Result := TJclInt64LinkedList.Create(nil);\r\n AssignPropertiesTo(Result);\r\nend;\r\n\r\n//=== { TJclInt64LinkedListIterator } ============================================================\r\n\r\nconstructor TJclInt64LinkedListIterator.Create(AOwnList: TJclInt64LinkedList; ACursor: TJclInt64LinkedListItem; AValid: Boolean; AStart: TItrStart);\r\nbegin\r\n inherited Create(AValid);\r\n FCursor := ACursor;\r\n FOwnList := AOwnList;\r\n FStart := AStart;\r\n FEqualityComparer := AOwnList as IJclInt64EqualityComparer;\r\nend;\r\n\r\nfunction TJclInt64LinkedListIterator.Add(const AValue: Int64): Boolean;\r\nbegin\r\n Result := FOwnList.Add(AValue);\r\nend;\r\n\r\nprocedure TJclInt64LinkedListIterator.AssignPropertiesTo(Dest: TJclAbstractIterator);\r\nvar\r\n ADest: TJclInt64LinkedListIterator;\r\nbegin\r\n inherited AssignPropertiesTo(Dest);\r\n if Dest is TJclInt64LinkedListIterator then\r\n begin\r\n ADest := TJclInt64LinkedListIterator(Dest);\r\n ADest.FCursor := FCursor;\r\n ADest.FOwnList := FOwnList;\r\n ADest.FEqualityComparer := FEqualityComparer;\r\n ADest.FStart := FStart;\r\n end;\r\nend;\r\n\r\nfunction TJclInt64LinkedListIterator.CreateEmptyIterator: TJclAbstractIterator;\r\nbegin\r\n Result := TJclInt64LinkedListIterator.Create(FOwnList, FCursor, Valid, FStart);\r\nend;\r\n\r\nprocedure TJclInt64LinkedListIterator.Extract;\r\nvar\r\n OldCursor: TJclInt64LinkedListItem;\r\nbegin\r\n if FOwnList.ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n FOwnList.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n CheckValid;\r\n Valid := False;\r\n if FCursor <> nil then\r\n begin\r\n if FCursor.Next <> nil then\r\n FCursor.Next.Previous := FCursor.Previous;\r\n if FCursor.Previous <> nil then\r\n FCursor.Previous.Next := FCursor.Next;\r\n OldCursor := FCursor;\r\n FCursor := FCursor.Next;\r\n OldCursor.Free;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnList.WriteUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclInt64LinkedListIterator.GetValue: Int64;\r\nbegin\r\n CheckValid;\r\n Result := 0;\r\n if FCursor <> nil then\r\n Result := FCursor.Value\r\n else\r\n if not FOwnList.ReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\nend;\r\n\r\nfunction TJclInt64LinkedListIterator.HasNext: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnList.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Valid then\r\n Result := (FCursor <> nil) and (FCursor.Next <> nil)\r\n else\r\n Result := FCursor <> nil;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnList.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclInt64LinkedListIterator.HasPrevious: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnList.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Valid then\r\n Result := (FCursor <> nil) and (FCursor.Previous <> nil)\r\n else\r\n Result := FCursor <> nil;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnList.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclInt64LinkedListIterator.Insert(const AValue: Int64): Boolean;\r\nvar\r\n NewCursor: TJclInt64LinkedListItem;\r\nbegin\r\n if FOwnList.ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n FOwnList.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n CheckValid;\r\n Result := FCursor <> nil;\r\n if Result then\r\n begin\r\n Result := FOwnList.AllowDefaultElements or not FEqualityComparer.ItemsEqual(AValue, 0);\r\n if Result then\r\n begin\r\n case FOwnList.Duplicates of\r\n dupIgnore:\r\n Result := not FOwnList.Contains(AValue);\r\n dupAccept:\r\n Result := True;\r\n dupError:\r\n begin\r\n Result := FOwnList.Contains(AValue);\r\n if not Result then\r\n raise EJclDuplicateElementError.Create;\r\n end;\r\n end;\r\n if Result then\r\n begin\r\n NewCursor := TJclInt64LinkedListItem.Create;\r\n NewCursor.Value := AValue;\r\n NewCursor.Next := FCursor;\r\n NewCursor.Previous := FCursor.Previous;\r\n if FCursor.Previous <> nil then\r\n FCursor.Previous.Next := NewCursor;\r\n FCursor.Previous := NewCursor;\r\n FCursor := NewCursor;\r\n end;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnList.WriteUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclInt64LinkedListIterator.IteratorEquals(const AIterator: IJclInt64Iterator): Boolean;\r\nvar\r\n Obj: TObject;\r\n ItrObj: TJclInt64LinkedListIterator;\r\nbegin\r\n Result := False;\r\n if AIterator = nil then\r\n Exit;\r\n Obj := AIterator.GetIteratorReference;\r\n if Obj is TJclInt64LinkedListIterator then\r\n begin\r\n ItrObj := TJclInt64LinkedListIterator(Obj);\r\n Result := (FOwnList = ItrObj.FOwnList) and (FCursor = ItrObj.FCursor) and (Valid = ItrObj.Valid);\r\n end;\r\nend;\r\n\r\n{$IFDEF SUPPORTS_FOR_IN}\r\nfunction TJclInt64LinkedListIterator.MoveNext: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnList.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Valid and (FCursor <> nil) then\r\n FCursor := FCursor.Next\r\n else\r\n Valid := True;\r\n Result := FCursor <> nil;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnList.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n{$ENDIF SUPPORTS_FOR_IN}\r\n\r\nfunction TJclInt64LinkedListIterator.Next: Int64;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnList.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Valid and (FCursor <> nil) then\r\n FCursor := FCursor.Next\r\n else\r\n Valid := True;\r\n if FCursor <> nil then\r\n Result := FCursor.Value\r\n else\r\n Result := 0;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnList.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclInt64LinkedListIterator.NextIndex: Integer;\r\nbegin\r\n // No Index\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nfunction TJclInt64LinkedListIterator.Previous: Int64;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnList.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Valid and (FCursor <> nil) then\r\n FCursor := FCursor.Previous\r\n else\r\n Valid := True;\r\n if FCursor <> nil then\r\n Result := FCursor.Value\r\n else\r\n Result := 0;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnList.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclInt64LinkedListIterator.PreviousIndex: Integer;\r\nbegin\r\n // No Index\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nprocedure TJclInt64LinkedListIterator.Remove;\r\nvar\r\n OldCursor: TJclInt64LinkedListItem;\r\nbegin\r\n if FOwnList.ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n FOwnList.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n CheckValid;\r\n Valid := False;\r\n if FCursor <> nil then\r\n begin\r\n FCursor.Value := 0;\r\n if FCursor.Next <> nil then\r\n FCursor.Next.Previous := FCursor.Previous;\r\n if FCursor.Previous <> nil then\r\n FCursor.Previous.Next := FCursor.Next;\r\n OldCursor := FCursor;\r\n FCursor := FCursor.Next;\r\n OldCursor.Free;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnList.WriteUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclInt64LinkedListIterator.Reset;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnList.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Valid := False;\r\n case FStart of\r\n isFirst:\r\n begin\r\n while (FCursor <> nil) and (FCursor.Previous <> nil) do\r\n FCursor := FCursor.Previous;\r\n end;\r\n isLast:\r\n begin\r\n while (FCursor <> nil) and (FCursor.Next <> nil) do\r\n FCursor := FCursor.Next;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnList.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclInt64LinkedListIterator.SetValue(const AValue: Int64);\r\nbegin\r\n if FOwnList.ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n FOwnList.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n CheckValid;\r\n FCursor.Value := 0;\r\n FCursor.Value := AValue;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnList.WriteUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\n//=== { TJclPtrLinkedList } ==================================================\r\n\r\nconstructor TJclPtrLinkedList.Create(const ACollection: IJclPtrCollection);\r\nbegin\r\n inherited Create();\r\n FStart := nil;\r\n FEnd := nil;\r\n if ACollection <> nil then\r\n AddAll(ACollection);\r\nend;\r\n\r\ndestructor TJclPtrLinkedList.Destroy;\r\nbegin\r\n FReadOnly := False;\r\n Clear;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJclPtrLinkedList.Add(APtr: Pointer): Boolean;\r\nvar\r\n NewItem: TJclPtrLinkedListItem;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := FAllowDefaultElements or not ItemsEqual(APtr, nil);\r\n if Result then\r\n begin\r\n if FDuplicates <> dupAccept then\r\n begin\r\n NewItem := FStart;\r\n while NewItem <> nil do\r\n begin\r\n if ItemsEqual(APtr, NewItem.Value) then\r\n begin\r\n Result := CheckDuplicate;\r\n Break;\r\n end;\r\n NewItem := NewItem.Next;\r\n end;\r\n end;\r\n if Result then\r\n begin\r\n NewItem := TJclPtrLinkedListItem.Create;\r\n NewItem.Value := APtr;\r\n if FStart <> nil then\r\n begin\r\n NewItem.Next := nil;\r\n NewItem.Previous := FEnd;\r\n FEnd.Next := NewItem;\r\n FEnd := NewItem;\r\n end\r\n else\r\n begin\r\n FStart := NewItem;\r\n FEnd := NewItem;\r\n end;\r\n Inc(FSize);\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclPtrLinkedList.AddAll(const ACollection: IJclPtrCollection): Boolean;\r\nvar\r\n It: IJclPtrIterator;\r\n Item: Pointer;\r\n AddItem: Boolean;\r\n NewItem: TJclPtrLinkedListItem;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n begin\r\n Item := It.Next;\r\n AddItem := FAllowDefaultElements or not ItemsEqual(Item, nil);\r\n if AddItem then\r\n begin\r\n if FDuplicates <> dupAccept then\r\n begin\r\n NewItem := FStart;\r\n while NewItem <> nil do\r\n begin\r\n if ItemsEqual(Item, NewItem.Value) then\r\n begin\r\n AddItem := CheckDuplicate;\r\n Break;\r\n end;\r\n NewItem := NewItem.Next;\r\n end;\r\n end;\r\n if AddItem then\r\n begin\r\n NewItem := TJclPtrLinkedListItem.Create;\r\n NewItem.Value := Item;\r\n if FStart <> nil then\r\n begin\r\n NewItem.Next := nil;\r\n NewItem.Previous := FEnd;\r\n FEnd.Next := NewItem;\r\n FEnd := NewItem;\r\n end\r\n else\r\n begin\r\n FStart := NewItem;\r\n FEnd := NewItem;\r\n end;\r\n Inc(FSize);\r\n end;\r\n end;\r\n Result := AddItem and Result;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclPtrLinkedList.AssignDataTo(Dest: TJclAbstractContainerBase);\r\nvar\r\n ACollection: IJclPtrCollection;\r\nbegin\r\n inherited AssignDataTo(Dest);\r\n if Supports(IInterface(Dest), IJclPtrCollection, ACollection) then\r\n begin\r\n ACollection.Clear;\r\n ACollection.AddAll(Self);\r\n end;\r\nend;\r\n\r\nprocedure TJclPtrLinkedList.Clear;\r\nvar\r\n Old, Current: TJclPtrLinkedListItem;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Current := FStart;\r\n while Current <> nil do\r\n begin\r\n FreePointer(Current.Value);\r\n Old := Current;\r\n Current := Current.Next;\r\n Old.Free;\r\n end;\r\n FSize := 0;\r\n\r\n //Daniele Teti 27/12/2004\r\n FStart := nil;\r\n FEnd := nil;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclPtrLinkedList.CollectionEquals(const ACollection: IJclPtrCollection): Boolean;\r\nvar\r\n It, ItSelf: IJclPtrIterator;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n if FSize <> ACollection.Size then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n ItSelf := First;\r\n while ItSelf.HasNext and It.HasNext do\r\n if not ItemsEqual(ItSelf.Next, It.Next) then\r\n begin\r\n Result := False;\r\n Break;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclPtrLinkedList.Contains(APtr: Pointer): Boolean;\r\nvar\r\n Current: TJclPtrLinkedListItem;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n Current := FStart;\r\n while Current <> nil do\r\n begin\r\n if ItemsEqual(Current.Value, APtr) then\r\n begin\r\n Result := True;\r\n Break;\r\n end;\r\n Current := Current.Next;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclPtrLinkedList.ContainsAll(const ACollection: IJclPtrCollection): Boolean;\r\nvar\r\n It: IJclPtrIterator;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n while Result and It.HasNext do\r\n Result := Contains(It.Next);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclPtrLinkedList.Delete(Index: Integer): Pointer;\r\nvar\r\n Current: TJclPtrLinkedListItem;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := nil;\r\n if (Index >= 0) and (Index < FSize) then\r\n begin\r\n Current := FStart;\r\n while Current <> nil do\r\n begin\r\n if Index = 0 then\r\n begin\r\n if Current.Previous <> nil then\r\n Current.Previous.Next := Current.Next\r\n else\r\n FStart := Current.Next;\r\n if Current.Next <> nil then\r\n Current.Next.Previous := Current.Previous\r\n else\r\n FEnd := Current.Previous;\r\n Result := FreePointer(Current.Value);\r\n Current.Free;\r\n Dec(FSize);\r\n Break;\r\n end;\r\n Dec(Index);\r\n Current := Current.Next;\r\n end;\r\n end\r\n else\r\n raise EJclOutOfBoundsError.Create;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclPtrLinkedList.Extract(APtr: Pointer): Boolean;\r\nvar\r\n Current: TJclPtrLinkedListItem;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n Current := FStart;\r\n while Current <> nil do\r\n begin\r\n if ItemsEqual(Current.Value, APtr) then\r\n begin\r\n if Current.Previous <> nil then\r\n Current.Previous.Next := Current.Next\r\n else\r\n FStart := Current.Next;\r\n if Current.Next <> nil then\r\n Current.Next.Previous := Current.Previous\r\n else\r\n FEnd := Current.Previous;\r\n Current.Value := nil;\r\n Current.Free;\r\n Dec(FSize);\r\n Result := True;\r\n if FRemoveSingleElement then\r\n Break;\r\n end;\r\n Current := Current.Next;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclPtrLinkedList.ExtractAll(const ACollection: IJclPtrCollection): Boolean;\r\nvar\r\n It: IJclPtrIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := True;\r\n if ACollection = nil then\r\n Exit;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n Result := Extract(It.Next) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclPtrLinkedList.ExtractIndex(Index: Integer): Pointer;\r\nvar\r\n Current: TJclPtrLinkedListItem;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := nil;\r\n if (Index >= 0) and (Index < FSize) then\r\n begin\r\n Current := FStart;\r\n while Current <> nil do\r\n begin\r\n if Index = 0 then\r\n begin\r\n if Current.Previous <> nil then\r\n Current.Previous.Next := Current.Next\r\n else\r\n FStart := Current.Next;\r\n if Current.Next <> nil then\r\n Current.Next.Previous := Current.Previous\r\n else\r\n FEnd := Current.Previous;\r\n Result := Current.Value;\r\n Current.Free;\r\n Dec(FSize);\r\n Break;\r\n end;\r\n Dec(Index);\r\n Current := Current.Next;\r\n end;\r\n end\r\n else\r\n raise EJclOutOfBoundsError.Create;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclPtrLinkedList.First: IJclPtrIterator;\r\nbegin\r\n Result := TJclPtrLinkedListIterator.Create(Self, FStart, False, isFirst);\r\nend;\r\n\r\n{$IFDEF SUPPORTS_FOR_IN}\r\nfunction TJclPtrLinkedList.GetEnumerator: IJclPtrIterator;\r\nbegin\r\n Result := TJclPtrLinkedListIterator.Create(Self, FStart, False, isFirst);\r\nend;\r\n{$ENDIF SUPPORTS_FOR_IN}\r\n\r\nfunction TJclPtrLinkedList.GetPointer(Index: Integer): Pointer;\r\nvar\r\n Current: TJclPtrLinkedListItem;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := nil;\r\n Current := FStart;\r\n while (Current <> nil) and (Index > 0) do\r\n begin\r\n Current := Current.Next;\r\n Dec(Index);\r\n end;\r\n if Current <> nil then\r\n Result := Current.Value\r\n else\r\n if not FReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclPtrLinkedList.IndexOf(APtr: Pointer): Integer;\r\nvar\r\n Current: TJclPtrLinkedListItem;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Current := FStart;\r\n Result := 0;\r\n while (Current <> nil) and not ItemsEqual(Current.Value, APtr) do\r\n begin\r\n Inc(Result);\r\n Current := Current.Next;\r\n end;\r\n if Current = nil then\r\n Result := -1;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclPtrLinkedList.Insert(Index: Integer; APtr: Pointer): Boolean;\r\nvar\r\n Current, NewItem: TJclPtrLinkedListItem;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := FAllowDefaultElements or not ItemsEqual(APtr, nil);\r\n if (Index < 0) or (Index > FSize) then\r\n raise EJclOutOfBoundsError.Create;\r\n if Result then\r\n begin\r\n if FDuplicates <> dupAccept then\r\n begin\r\n Current := FStart;\r\n while Current <> nil do\r\n begin\r\n if ItemsEqual(APtr, Current.Value) then\r\n begin\r\n Result := CheckDuplicate;\r\n Break;\r\n end;\r\n Current := Current.Next;\r\n end;\r\n end;\r\n if Result then\r\n begin\r\n NewItem := TJclPtrLinkedListItem.Create;\r\n NewItem.Value := APtr;\r\n if Index = 0 then\r\n begin\r\n NewItem.Next := FStart;\r\n if FStart <> nil then\r\n FStart.Previous := NewItem;\r\n FStart := NewItem;\r\n if FSize = 0 then\r\n FEnd := NewItem;\r\n Inc(FSize);\r\n end\r\n else\r\n if Index = FSize then\r\n begin\r\n NewItem.Previous := FEnd;\r\n FEnd.Next := NewItem;\r\n FEnd := NewItem;\r\n Inc(FSize);\r\n end\r\n else\r\n begin\r\n Current := FStart;\r\n while (Current <> nil) and (Index > 0) do\r\n begin\r\n Current := Current.Next;\r\n Dec(Index);\r\n end;\r\n if Current <> nil then\r\n begin\r\n NewItem.Next := Current;\r\n NewItem.Previous := Current.Previous;\r\n if Current.Previous <> nil then\r\n Current.Previous.Next := NewItem;\r\n Current.Previous := NewItem;\r\n Inc(FSize);\r\n end;\r\n end;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclPtrLinkedList.InsertAll(Index: Integer; const ACollection: IJclPtrCollection): Boolean;\r\nvar\r\n It: IJclPtrIterator;\r\n Current, NewItem, Test: TJclPtrLinkedListItem;\r\n AddItem: Boolean;\r\n Item: Pointer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if (Index < 0) or (Index > FSize) then\r\n raise EJclOutOfBoundsError.Create;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n if Index = 0 then\r\n begin\r\n It := ACollection.Last;\r\n while It.HasPrevious do\r\n begin\r\n Item := It.Previous;\r\n AddItem := FAllowDefaultElements or not ItemsEqual(Item, nil);\r\n if AddItem then\r\n begin\r\n if FDuplicates <> dupAccept then\r\n begin\r\n Test := FStart;\r\n while Test <> nil do\r\n begin\r\n if ItemsEqual(Item, Test.Value) then\r\n begin\r\n Result := CheckDuplicate;\r\n Break;\r\n end;\r\n Test := Test.Next;\r\n end;\r\n end;\r\n if AddItem then\r\n begin\r\n NewItem := TJclPtrLinkedListItem.Create;\r\n NewItem.Value := Item;\r\n NewItem.Next := FStart;\r\n if FStart <> nil then\r\n FStart.Previous := NewItem;\r\n FStart := NewItem;\r\n if FSize = 0 then\r\n FEnd := NewItem;\r\n Inc(FSize);\r\n end;\r\n end;\r\n Result := Result and AddItem;\r\n end;\r\n end\r\n else\r\n if Index = Size then\r\n begin\r\n It := ACollection.First;\r\n while It.HasNext do\r\n begin\r\n Item := It.Next;\r\n AddItem := FAllowDefaultElements or not ItemsEqual(Item, nil);\r\n if AddItem then\r\n begin\r\n if FDuplicates <> dupAccept then\r\n begin\r\n Test := FStart;\r\n while Test <> nil do\r\n begin\r\n if ItemsEqual(Item, Test.Value) then\r\n begin\r\n Result := CheckDuplicate;\r\n Break;\r\n end;\r\n Test := Test.Next;\r\n end;\r\n end;\r\n if AddItem then\r\n begin\r\n NewItem := TJclPtrLinkedListItem.Create;\r\n NewItem.Value := Item;\r\n NewItem.Previous := FEnd;\r\n if FEnd <> nil then\r\n FEnd.Next := NewItem;\r\n FEnd := NewItem;\r\n Inc(FSize);\r\n end;\r\n end;\r\n Result := Result and AddItem;\r\n end;\r\n end\r\n else\r\n begin\r\n Current := FStart;\r\n while (Current <> nil) and (Index > 0) do\r\n begin\r\n Current := Current.Next;\r\n Dec(Index);\r\n end;\r\n if Current <> nil then\r\n begin\r\n It := ACollection.First;\r\n while It.HasNext do\r\n begin\r\n Item := It.Next;\r\n AddItem := FAllowDefaultElements or not ItemsEqual(Item, nil);\r\n if AddItem then\r\n begin\r\n if FDuplicates <> dupAccept then\r\n begin\r\n Test := FStart;\r\n while Test <> nil do\r\n begin\r\n if ItemsEqual(Item, Test.Value) then\r\n begin\r\n Result := CheckDuplicate;\r\n Break;\r\n end;\r\n Test := Test.Next;\r\n end;\r\n end;\r\n if AddItem then\r\n begin\r\n NewItem := TJclPtrLinkedListItem.Create;\r\n NewItem.Value := Item;\r\n NewItem.Next := Current;\r\n NewItem.Previous := Current.Previous;\r\n if Current.Previous <> nil then\r\n Current.Previous.Next := NewItem;\r\n Current.Previous := NewItem;\r\n Inc(FSize);\r\n end;\r\n end;\r\n Result := Result and AddItem;\r\n end;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclPtrLinkedList.IsEmpty: Boolean;\r\nbegin\r\n Result := FSize = 0;\r\nend;\r\n\r\nfunction TJclPtrLinkedList.Last: IJclPtrIterator;\r\nbegin\r\n Result := TJclPtrLinkedListIterator.Create(Self, FEnd, False, isLast);\r\nend;\r\n\r\nfunction TJclPtrLinkedList.LastIndexOf(APtr: Pointer): Integer;\r\nvar\r\n Current: TJclPtrLinkedListItem;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := -1;\r\n if FEnd <> nil then\r\n begin\r\n Current := FEnd;\r\n Result := FSize - 1;\r\n while (Current <> nil) and not ItemsEqual(Current.Value, APtr) do\r\n begin\r\n Dec(Result);\r\n Current := Current.Previous;\r\n end;\r\n if Current = nil then\r\n Result := -1;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclPtrLinkedList.Remove(APtr: Pointer): Boolean;\r\nvar\r\n Extracted: Pointer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := Extract(APtr);\r\n if Result then\r\n begin\r\n Extracted := APtr;\r\n FreePointer(Extracted);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclPtrLinkedList.RemoveAll(const ACollection: IJclPtrCollection): Boolean;\r\nvar\r\n It: IJclPtrIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := True;\r\n if ACollection = nil then\r\n Exit;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n Result := Remove(It.Next) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclPtrLinkedList.RetainAll(const ACollection: IJclPtrCollection): Boolean;\r\nvar\r\n It: IJclPtrIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := First;\r\n while It.HasNext do\r\n if not ACollection.Contains(It.Next) then\r\n It.Remove;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclPtrLinkedList.SetPointer(Index: Integer; APtr: Pointer);\r\nvar\r\n Current: TJclPtrLinkedListItem;\r\n ReplaceItem: Boolean;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n ReplaceItem := FAllowDefaultElements or not ItemsEqual(APtr, nil);\r\n if ReplaceItem then\r\n begin\r\n if FDuplicates <> dupAccept then\r\n begin\r\n Current := FStart;\r\n while Current <> nil do\r\n begin\r\n if ItemsEqual(APtr, Current.Value) then\r\n begin\r\n ReplaceItem := CheckDuplicate;\r\n Break;\r\n end;\r\n Current := Current.Next;\r\n end;\r\n end;\r\n if ReplaceItem then\r\n begin\r\n Current := FStart;\r\n while Current <> nil do\r\n begin\r\n if Index = 0 then\r\n begin\r\n FreePointer(Current.Value);\r\n Current.Value := APtr;\r\n Break;\r\n end;\r\n Dec(Index);\r\n Current := Current.Next;\r\n end;\r\n end;\r\n end;\r\n if not ReplaceItem then\r\n Delete(Index);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclPtrLinkedList.Size: Integer;\r\nbegin\r\n Result := FSize;\r\nend;\r\n\r\nfunction TJclPtrLinkedList.SubList(First, Count: Integer): IJclPtrList;\r\nvar\r\n Current: TJclPtrLinkedListItem;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := CreateEmptyContainer as IJclPtrList;\r\n Current := FStart;\r\n while (Current <> nil) and (First > 0) do\r\n begin\r\n Dec(First);\r\n Current := Current.Next;\r\n end;\r\n while (Current <> nil) and (Count > 0) do\r\n begin\r\n Result.Add(Current.Value);\r\n Dec(Count);\r\n Current := Current.Next;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclPtrLinkedList.CreateEmptyContainer: TJclAbstractContainerBase;\r\nbegin\r\n Result := TJclPtrLinkedList.Create(nil);\r\n AssignPropertiesTo(Result);\r\nend;\r\n\r\n//=== { TJclPtrLinkedListIterator } ============================================================\r\n\r\nconstructor TJclPtrLinkedListIterator.Create(AOwnList: TJclPtrLinkedList; ACursor: TJclPtrLinkedListItem; AValid: Boolean; AStart: TItrStart);\r\nbegin\r\n inherited Create(AValid);\r\n FCursor := ACursor;\r\n FOwnList := AOwnList;\r\n FStart := AStart;\r\n FEqualityComparer := AOwnList as IJclPtrEqualityComparer;\r\nend;\r\n\r\nfunction TJclPtrLinkedListIterator.Add(APtr: Pointer): Boolean;\r\nbegin\r\n Result := FOwnList.Add(APtr);\r\nend;\r\n\r\nprocedure TJclPtrLinkedListIterator.AssignPropertiesTo(Dest: TJclAbstractIterator);\r\nvar\r\n ADest: TJclPtrLinkedListIterator;\r\nbegin\r\n inherited AssignPropertiesTo(Dest);\r\n if Dest is TJclPtrLinkedListIterator then\r\n begin\r\n ADest := TJclPtrLinkedListIterator(Dest);\r\n ADest.FCursor := FCursor;\r\n ADest.FOwnList := FOwnList;\r\n ADest.FEqualityComparer := FEqualityComparer;\r\n ADest.FStart := FStart;\r\n end;\r\nend;\r\n\r\nfunction TJclPtrLinkedListIterator.CreateEmptyIterator: TJclAbstractIterator;\r\nbegin\r\n Result := TJclPtrLinkedListIterator.Create(FOwnList, FCursor, Valid, FStart);\r\nend;\r\n\r\nprocedure TJclPtrLinkedListIterator.Extract;\r\nvar\r\n OldCursor: TJclPtrLinkedListItem;\r\nbegin\r\n if FOwnList.ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n FOwnList.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n CheckValid;\r\n Valid := False;\r\n if FCursor <> nil then\r\n begin\r\n if FCursor.Next <> nil then\r\n FCursor.Next.Previous := FCursor.Previous;\r\n if FCursor.Previous <> nil then\r\n FCursor.Previous.Next := FCursor.Next;\r\n OldCursor := FCursor;\r\n FCursor := FCursor.Next;\r\n OldCursor.Free;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnList.WriteUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclPtrLinkedListIterator.GetPointer: Pointer;\r\nbegin\r\n CheckValid;\r\n Result := nil;\r\n if FCursor <> nil then\r\n Result := FCursor.Value\r\n else\r\n if not FOwnList.ReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\nend;\r\n\r\nfunction TJclPtrLinkedListIterator.HasNext: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnList.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Valid then\r\n Result := (FCursor <> nil) and (FCursor.Next <> nil)\r\n else\r\n Result := FCursor <> nil;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnList.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclPtrLinkedListIterator.HasPrevious: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnList.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Valid then\r\n Result := (FCursor <> nil) and (FCursor.Previous <> nil)\r\n else\r\n Result := FCursor <> nil;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnList.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclPtrLinkedListIterator.Insert(APtr: Pointer): Boolean;\r\nvar\r\n NewCursor: TJclPtrLinkedListItem;\r\nbegin\r\n if FOwnList.ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n FOwnList.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n CheckValid;\r\n Result := FCursor <> nil;\r\n if Result then\r\n begin\r\n Result := FOwnList.AllowDefaultElements or not FEqualityComparer.ItemsEqual(APtr, nil);\r\n if Result then\r\n begin\r\n case FOwnList.Duplicates of\r\n dupIgnore:\r\n Result := not FOwnList.Contains(APtr);\r\n dupAccept:\r\n Result := True;\r\n dupError:\r\n begin\r\n Result := FOwnList.Contains(APtr);\r\n if not Result then\r\n raise EJclDuplicateElementError.Create;\r\n end;\r\n end;\r\n if Result then\r\n begin\r\n NewCursor := TJclPtrLinkedListItem.Create;\r\n NewCursor.Value := APtr;\r\n NewCursor.Next := FCursor;\r\n NewCursor.Previous := FCursor.Previous;\r\n if FCursor.Previous <> nil then\r\n FCursor.Previous.Next := NewCursor;\r\n FCursor.Previous := NewCursor;\r\n FCursor := NewCursor;\r\n end;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnList.WriteUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclPtrLinkedListIterator.IteratorEquals(const AIterator: IJclPtrIterator): Boolean;\r\nvar\r\n Obj: TObject;\r\n ItrObj: TJclPtrLinkedListIterator;\r\nbegin\r\n Result := False;\r\n if AIterator = nil then\r\n Exit;\r\n Obj := AIterator.GetIteratorReference;\r\n if Obj is TJclPtrLinkedListIterator then\r\n begin\r\n ItrObj := TJclPtrLinkedListIterator(Obj);\r\n Result := (FOwnList = ItrObj.FOwnList) and (FCursor = ItrObj.FCursor) and (Valid = ItrObj.Valid);\r\n end;\r\nend;\r\n\r\n{$IFDEF SUPPORTS_FOR_IN}\r\nfunction TJclPtrLinkedListIterator.MoveNext: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnList.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Valid and (FCursor <> nil) then\r\n FCursor := FCursor.Next\r\n else\r\n Valid := True;\r\n Result := FCursor <> nil;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnList.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n{$ENDIF SUPPORTS_FOR_IN}\r\n\r\nfunction TJclPtrLinkedListIterator.Next: Pointer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnList.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Valid and (FCursor <> nil) then\r\n FCursor := FCursor.Next\r\n else\r\n Valid := True;\r\n if FCursor <> nil then\r\n Result := FCursor.Value\r\n else\r\n Result := nil;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnList.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclPtrLinkedListIterator.NextIndex: Integer;\r\nbegin\r\n // No Index\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nfunction TJclPtrLinkedListIterator.Previous: Pointer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnList.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Valid and (FCursor <> nil) then\r\n FCursor := FCursor.Previous\r\n else\r\n Valid := True;\r\n if FCursor <> nil then\r\n Result := FCursor.Value\r\n else\r\n Result := nil;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnList.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclPtrLinkedListIterator.PreviousIndex: Integer;\r\nbegin\r\n // No Index\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nprocedure TJclPtrLinkedListIterator.Remove;\r\nvar\r\n OldCursor: TJclPtrLinkedListItem;\r\nbegin\r\n if FOwnList.ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n FOwnList.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n CheckValid;\r\n Valid := False;\r\n if FCursor <> nil then\r\n begin\r\n FCursor.Value := nil;\r\n if FCursor.Next <> nil then\r\n FCursor.Next.Previous := FCursor.Previous;\r\n if FCursor.Previous <> nil then\r\n FCursor.Previous.Next := FCursor.Next;\r\n OldCursor := FCursor;\r\n FCursor := FCursor.Next;\r\n OldCursor.Free;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnList.WriteUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclPtrLinkedListIterator.Reset;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnList.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Valid := False;\r\n case FStart of\r\n isFirst:\r\n begin\r\n while (FCursor <> nil) and (FCursor.Previous <> nil) do\r\n FCursor := FCursor.Previous;\r\n end;\r\n isLast:\r\n begin\r\n while (FCursor <> nil) and (FCursor.Next <> nil) do\r\n FCursor := FCursor.Next;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnList.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclPtrLinkedListIterator.SetPointer(APtr: Pointer);\r\nbegin\r\n if FOwnList.ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n FOwnList.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n CheckValid;\r\n FCursor.Value := nil;\r\n FCursor.Value := APtr;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnList.WriteUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\n//=== { TJclLinkedList } ==================================================\r\n\r\nconstructor TJclLinkedList.Create(const ACollection: IJclCollection; AOwnsObjects: Boolean);\r\nbegin\r\n inherited Create(AOwnsObjects);\r\n FStart := nil;\r\n FEnd := nil;\r\n if ACollection <> nil then\r\n AddAll(ACollection);\r\nend;\r\n\r\ndestructor TJclLinkedList.Destroy;\r\nbegin\r\n FReadOnly := False;\r\n Clear;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJclLinkedList.Add(AObject: TObject): Boolean;\r\nvar\r\n NewItem: TJclLinkedListItem;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := FAllowDefaultElements or not ItemsEqual(AObject, nil);\r\n if Result then\r\n begin\r\n if FDuplicates <> dupAccept then\r\n begin\r\n NewItem := FStart;\r\n while NewItem <> nil do\r\n begin\r\n if ItemsEqual(AObject, NewItem.Value) then\r\n begin\r\n Result := CheckDuplicate;\r\n Break;\r\n end;\r\n NewItem := NewItem.Next;\r\n end;\r\n end;\r\n if Result then\r\n begin\r\n NewItem := TJclLinkedListItem.Create;\r\n NewItem.Value := AObject;\r\n if FStart <> nil then\r\n begin\r\n NewItem.Next := nil;\r\n NewItem.Previous := FEnd;\r\n FEnd.Next := NewItem;\r\n FEnd := NewItem;\r\n end\r\n else\r\n begin\r\n FStart := NewItem;\r\n FEnd := NewItem;\r\n end;\r\n Inc(FSize);\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclLinkedList.AddAll(const ACollection: IJclCollection): Boolean;\r\nvar\r\n It: IJclIterator;\r\n Item: TObject;\r\n AddItem: Boolean;\r\n NewItem: TJclLinkedListItem;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n begin\r\n Item := It.Next;\r\n AddItem := FAllowDefaultElements or not ItemsEqual(Item, nil);\r\n if AddItem then\r\n begin\r\n if FDuplicates <> dupAccept then\r\n begin\r\n NewItem := FStart;\r\n while NewItem <> nil do\r\n begin\r\n if ItemsEqual(Item, NewItem.Value) then\r\n begin\r\n AddItem := CheckDuplicate;\r\n Break;\r\n end;\r\n NewItem := NewItem.Next;\r\n end;\r\n end;\r\n if AddItem then\r\n begin\r\n NewItem := TJclLinkedListItem.Create;\r\n NewItem.Value := Item;\r\n if FStart <> nil then\r\n begin\r\n NewItem.Next := nil;\r\n NewItem.Previous := FEnd;\r\n FEnd.Next := NewItem;\r\n FEnd := NewItem;\r\n end\r\n else\r\n begin\r\n FStart := NewItem;\r\n FEnd := NewItem;\r\n end;\r\n Inc(FSize);\r\n end;\r\n end;\r\n Result := AddItem and Result;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclLinkedList.AssignDataTo(Dest: TJclAbstractContainerBase);\r\nvar\r\n ACollection: IJclCollection;\r\nbegin\r\n inherited AssignDataTo(Dest);\r\n if Supports(IInterface(Dest), IJclCollection, ACollection) then\r\n begin\r\n ACollection.Clear;\r\n ACollection.AddAll(Self);\r\n end;\r\nend;\r\n\r\nprocedure TJclLinkedList.Clear;\r\nvar\r\n Old, Current: TJclLinkedListItem;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Current := FStart;\r\n while Current <> nil do\r\n begin\r\n FreeObject(Current.Value);\r\n Old := Current;\r\n Current := Current.Next;\r\n Old.Free;\r\n end;\r\n FSize := 0;\r\n\r\n //Daniele Teti 27/12/2004\r\n FStart := nil;\r\n FEnd := nil;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclLinkedList.CollectionEquals(const ACollection: IJclCollection): Boolean;\r\nvar\r\n It, ItSelf: IJclIterator;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n if FSize <> ACollection.Size then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n ItSelf := First;\r\n while ItSelf.HasNext and It.HasNext do\r\n if not ItemsEqual(ItSelf.Next, It.Next) then\r\n begin\r\n Result := False;\r\n Break;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclLinkedList.Contains(AObject: TObject): Boolean;\r\nvar\r\n Current: TJclLinkedListItem;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n Current := FStart;\r\n while Current <> nil do\r\n begin\r\n if ItemsEqual(Current.Value, AObject) then\r\n begin\r\n Result := True;\r\n Break;\r\n end;\r\n Current := Current.Next;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclLinkedList.ContainsAll(const ACollection: IJclCollection): Boolean;\r\nvar\r\n It: IJclIterator;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n while Result and It.HasNext do\r\n Result := Contains(It.Next);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclLinkedList.Delete(Index: Integer): TObject;\r\nvar\r\n Current: TJclLinkedListItem;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := nil;\r\n if (Index >= 0) and (Index < FSize) then\r\n begin\r\n Current := FStart;\r\n while Current <> nil do\r\n begin\r\n if Index = 0 then\r\n begin\r\n if Current.Previous <> nil then\r\n Current.Previous.Next := Current.Next\r\n else\r\n FStart := Current.Next;\r\n if Current.Next <> nil then\r\n Current.Next.Previous := Current.Previous\r\n else\r\n FEnd := Current.Previous;\r\n Result := FreeObject(Current.Value);\r\n Current.Free;\r\n Dec(FSize);\r\n Break;\r\n end;\r\n Dec(Index);\r\n Current := Current.Next;\r\n end;\r\n end\r\n else\r\n raise EJclOutOfBoundsError.Create;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclLinkedList.Extract(AObject: TObject): Boolean;\r\nvar\r\n Current: TJclLinkedListItem;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n Current := FStart;\r\n while Current <> nil do\r\n begin\r\n if ItemsEqual(Current.Value, AObject) then\r\n begin\r\n if Current.Previous <> nil then\r\n Current.Previous.Next := Current.Next\r\n else\r\n FStart := Current.Next;\r\n if Current.Next <> nil then\r\n Current.Next.Previous := Current.Previous\r\n else\r\n FEnd := Current.Previous;\r\n Current.Value := nil;\r\n Current.Free;\r\n Dec(FSize);\r\n Result := True;\r\n if FRemoveSingleElement then\r\n Break;\r\n end;\r\n Current := Current.Next;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclLinkedList.ExtractAll(const ACollection: IJclCollection): Boolean;\r\nvar\r\n It: IJclIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := True;\r\n if ACollection = nil then\r\n Exit;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n Result := Extract(It.Next) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclLinkedList.ExtractIndex(Index: Integer): TObject;\r\nvar\r\n Current: TJclLinkedListItem;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := nil;\r\n if (Index >= 0) and (Index < FSize) then\r\n begin\r\n Current := FStart;\r\n while Current <> nil do\r\n begin\r\n if Index = 0 then\r\n begin\r\n if Current.Previous <> nil then\r\n Current.Previous.Next := Current.Next\r\n else\r\n FStart := Current.Next;\r\n if Current.Next <> nil then\r\n Current.Next.Previous := Current.Previous\r\n else\r\n FEnd := Current.Previous;\r\n Result := Current.Value;\r\n Current.Free;\r\n Dec(FSize);\r\n Break;\r\n end;\r\n Dec(Index);\r\n Current := Current.Next;\r\n end;\r\n end\r\n else\r\n raise EJclOutOfBoundsError.Create;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclLinkedList.First: IJclIterator;\r\nbegin\r\n Result := TJclLinkedListIterator.Create(Self, FStart, False, isFirst);\r\nend;\r\n\r\n{$IFDEF SUPPORTS_FOR_IN}\r\nfunction TJclLinkedList.GetEnumerator: IJclIterator;\r\nbegin\r\n Result := TJclLinkedListIterator.Create(Self, FStart, False, isFirst);\r\nend;\r\n{$ENDIF SUPPORTS_FOR_IN}\r\n\r\nfunction TJclLinkedList.GetObject(Index: Integer): TObject;\r\nvar\r\n Current: TJclLinkedListItem;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := nil;\r\n Current := FStart;\r\n while (Current <> nil) and (Index > 0) do\r\n begin\r\n Current := Current.Next;\r\n Dec(Index);\r\n end;\r\n if Current <> nil then\r\n Result := Current.Value\r\n else\r\n if not FReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclLinkedList.IndexOf(AObject: TObject): Integer;\r\nvar\r\n Current: TJclLinkedListItem;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Current := FStart;\r\n Result := 0;\r\n while (Current <> nil) and not ItemsEqual(Current.Value, AObject) do\r\n begin\r\n Inc(Result);\r\n Current := Current.Next;\r\n end;\r\n if Current = nil then\r\n Result := -1;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclLinkedList.Insert(Index: Integer; AObject: TObject): Boolean;\r\nvar\r\n Current, NewItem: TJclLinkedListItem;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := FAllowDefaultElements or not ItemsEqual(AObject, nil);\r\n if (Index < 0) or (Index > FSize) then\r\n raise EJclOutOfBoundsError.Create;\r\n if Result then\r\n begin\r\n if FDuplicates <> dupAccept then\r\n begin\r\n Current := FStart;\r\n while Current <> nil do\r\n begin\r\n if ItemsEqual(AObject, Current.Value) then\r\n begin\r\n Result := CheckDuplicate;\r\n Break;\r\n end;\r\n Current := Current.Next;\r\n end;\r\n end;\r\n if Result then\r\n begin\r\n NewItem := TJclLinkedListItem.Create;\r\n NewItem.Value := AObject;\r\n if Index = 0 then\r\n begin\r\n NewItem.Next := FStart;\r\n if FStart <> nil then\r\n FStart.Previous := NewItem;\r\n FStart := NewItem;\r\n if FSize = 0 then\r\n FEnd := NewItem;\r\n Inc(FSize);\r\n end\r\n else\r\n if Index = FSize then\r\n begin\r\n NewItem.Previous := FEnd;\r\n FEnd.Next := NewItem;\r\n FEnd := NewItem;\r\n Inc(FSize);\r\n end\r\n else\r\n begin\r\n Current := FStart;\r\n while (Current <> nil) and (Index > 0) do\r\n begin\r\n Current := Current.Next;\r\n Dec(Index);\r\n end;\r\n if Current <> nil then\r\n begin\r\n NewItem.Next := Current;\r\n NewItem.Previous := Current.Previous;\r\n if Current.Previous <> nil then\r\n Current.Previous.Next := NewItem;\r\n Current.Previous := NewItem;\r\n Inc(FSize);\r\n end;\r\n end;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclLinkedList.InsertAll(Index: Integer; const ACollection: IJclCollection): Boolean;\r\nvar\r\n It: IJclIterator;\r\n Current, NewItem, Test: TJclLinkedListItem;\r\n AddItem: Boolean;\r\n Item: TObject;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if (Index < 0) or (Index > FSize) then\r\n raise EJclOutOfBoundsError.Create;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n if Index = 0 then\r\n begin\r\n It := ACollection.Last;\r\n while It.HasPrevious do\r\n begin\r\n Item := It.Previous;\r\n AddItem := FAllowDefaultElements or not ItemsEqual(Item, nil);\r\n if AddItem then\r\n begin\r\n if FDuplicates <> dupAccept then\r\n begin\r\n Test := FStart;\r\n while Test <> nil do\r\n begin\r\n if ItemsEqual(Item, Test.Value) then\r\n begin\r\n Result := CheckDuplicate;\r\n Break;\r\n end;\r\n Test := Test.Next;\r\n end;\r\n end;\r\n if AddItem then\r\n begin\r\n NewItem := TJclLinkedListItem.Create;\r\n NewItem.Value := Item;\r\n NewItem.Next := FStart;\r\n if FStart <> nil then\r\n FStart.Previous := NewItem;\r\n FStart := NewItem;\r\n if FSize = 0 then\r\n FEnd := NewItem;\r\n Inc(FSize);\r\n end;\r\n end;\r\n Result := Result and AddItem;\r\n end;\r\n end\r\n else\r\n if Index = Size then\r\n begin\r\n It := ACollection.First;\r\n while It.HasNext do\r\n begin\r\n Item := It.Next;\r\n AddItem := FAllowDefaultElements or not ItemsEqual(Item, nil);\r\n if AddItem then\r\n begin\r\n if FDuplicates <> dupAccept then\r\n begin\r\n Test := FStart;\r\n while Test <> nil do\r\n begin\r\n if ItemsEqual(Item, Test.Value) then\r\n begin\r\n Result := CheckDuplicate;\r\n Break;\r\n end;\r\n Test := Test.Next;\r\n end;\r\n end;\r\n if AddItem then\r\n begin\r\n NewItem := TJclLinkedListItem.Create;\r\n NewItem.Value := Item;\r\n NewItem.Previous := FEnd;\r\n if FEnd <> nil then\r\n FEnd.Next := NewItem;\r\n FEnd := NewItem;\r\n Inc(FSize);\r\n end;\r\n end;\r\n Result := Result and AddItem;\r\n end;\r\n end\r\n else\r\n begin\r\n Current := FStart;\r\n while (Current <> nil) and (Index > 0) do\r\n begin\r\n Current := Current.Next;\r\n Dec(Index);\r\n end;\r\n if Current <> nil then\r\n begin\r\n It := ACollection.First;\r\n while It.HasNext do\r\n begin\r\n Item := It.Next;\r\n AddItem := FAllowDefaultElements or not ItemsEqual(Item, nil);\r\n if AddItem then\r\n begin\r\n if FDuplicates <> dupAccept then\r\n begin\r\n Test := FStart;\r\n while Test <> nil do\r\n begin\r\n if ItemsEqual(Item, Test.Value) then\r\n begin\r\n Result := CheckDuplicate;\r\n Break;\r\n end;\r\n Test := Test.Next;\r\n end;\r\n end;\r\n if AddItem then\r\n begin\r\n NewItem := TJclLinkedListItem.Create;\r\n NewItem.Value := Item;\r\n NewItem.Next := Current;\r\n NewItem.Previous := Current.Previous;\r\n if Current.Previous <> nil then\r\n Current.Previous.Next := NewItem;\r\n Current.Previous := NewItem;\r\n Inc(FSize);\r\n end;\r\n end;\r\n Result := Result and AddItem;\r\n end;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclLinkedList.IsEmpty: Boolean;\r\nbegin\r\n Result := FSize = 0;\r\nend;\r\n\r\nfunction TJclLinkedList.Last: IJclIterator;\r\nbegin\r\n Result := TJclLinkedListIterator.Create(Self, FEnd, False, isLast);\r\nend;\r\n\r\nfunction TJclLinkedList.LastIndexOf(AObject: TObject): Integer;\r\nvar\r\n Current: TJclLinkedListItem;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := -1;\r\n if FEnd <> nil then\r\n begin\r\n Current := FEnd;\r\n Result := FSize - 1;\r\n while (Current <> nil) and not ItemsEqual(Current.Value, AObject) do\r\n begin\r\n Dec(Result);\r\n Current := Current.Previous;\r\n end;\r\n if Current = nil then\r\n Result := -1;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclLinkedList.Remove(AObject: TObject): Boolean;\r\nvar\r\n Extracted: TObject;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := Extract(AObject);\r\n if Result then\r\n begin\r\n Extracted := AObject;\r\n FreeObject(Extracted);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclLinkedList.RemoveAll(const ACollection: IJclCollection): Boolean;\r\nvar\r\n It: IJclIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := True;\r\n if ACollection = nil then\r\n Exit;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n Result := Remove(It.Next) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclLinkedList.RetainAll(const ACollection: IJclCollection): Boolean;\r\nvar\r\n It: IJclIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := First;\r\n while It.HasNext do\r\n if not ACollection.Contains(It.Next) then\r\n It.Remove;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclLinkedList.SetObject(Index: Integer; AObject: TObject);\r\nvar\r\n Current: TJclLinkedListItem;\r\n ReplaceItem: Boolean;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n ReplaceItem := FAllowDefaultElements or not ItemsEqual(AObject, nil);\r\n if ReplaceItem then\r\n begin\r\n if FDuplicates <> dupAccept then\r\n begin\r\n Current := FStart;\r\n while Current <> nil do\r\n begin\r\n if ItemsEqual(AObject, Current.Value) then\r\n begin\r\n ReplaceItem := CheckDuplicate;\r\n Break;\r\n end;\r\n Current := Current.Next;\r\n end;\r\n end;\r\n if ReplaceItem then\r\n begin\r\n Current := FStart;\r\n while Current <> nil do\r\n begin\r\n if Index = 0 then\r\n begin\r\n FreeObject(Current.Value);\r\n Current.Value := AObject;\r\n Break;\r\n end;\r\n Dec(Index);\r\n Current := Current.Next;\r\n end;\r\n end;\r\n end;\r\n if not ReplaceItem then\r\n Delete(Index);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclLinkedList.Size: Integer;\r\nbegin\r\n Result := FSize;\r\nend;\r\n\r\nfunction TJclLinkedList.SubList(First, Count: Integer): IJclList;\r\nvar\r\n Current: TJclLinkedListItem;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := CreateEmptyContainer as IJclList;\r\n Current := FStart;\r\n while (Current <> nil) and (First > 0) do\r\n begin\r\n Dec(First);\r\n Current := Current.Next;\r\n end;\r\n while (Current <> nil) and (Count > 0) do\r\n begin\r\n Result.Add(Current.Value);\r\n Dec(Count);\r\n Current := Current.Next;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclLinkedList.CreateEmptyContainer: TJclAbstractContainerBase;\r\nbegin\r\n Result := TJclLinkedList.Create(nil, False);\r\n AssignPropertiesTo(Result);\r\nend;\r\n\r\n//=== { TJclLinkedListIterator } ============================================================\r\n\r\nconstructor TJclLinkedListIterator.Create(AOwnList: TJclLinkedList; ACursor: TJclLinkedListItem; AValid: Boolean; AStart: TItrStart);\r\nbegin\r\n inherited Create(AValid);\r\n FCursor := ACursor;\r\n FOwnList := AOwnList;\r\n FStart := AStart;\r\n FEqualityComparer := AOwnList as IJclEqualityComparer;\r\nend;\r\n\r\nfunction TJclLinkedListIterator.Add(AObject: TObject): Boolean;\r\nbegin\r\n Result := FOwnList.Add(AObject);\r\nend;\r\n\r\nprocedure TJclLinkedListIterator.AssignPropertiesTo(Dest: TJclAbstractIterator);\r\nvar\r\n ADest: TJclLinkedListIterator;\r\nbegin\r\n inherited AssignPropertiesTo(Dest);\r\n if Dest is TJclLinkedListIterator then\r\n begin\r\n ADest := TJclLinkedListIterator(Dest);\r\n ADest.FCursor := FCursor;\r\n ADest.FOwnList := FOwnList;\r\n ADest.FEqualityComparer := FEqualityComparer;\r\n ADest.FStart := FStart;\r\n end;\r\nend;\r\n\r\nfunction TJclLinkedListIterator.CreateEmptyIterator: TJclAbstractIterator;\r\nbegin\r\n Result := TJclLinkedListIterator.Create(FOwnList, FCursor, Valid, FStart);\r\nend;\r\n\r\nprocedure TJclLinkedListIterator.Extract;\r\nvar\r\n OldCursor: TJclLinkedListItem;\r\nbegin\r\n if FOwnList.ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n FOwnList.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n CheckValid;\r\n Valid := False;\r\n if FCursor <> nil then\r\n begin\r\n if FCursor.Next <> nil then\r\n FCursor.Next.Previous := FCursor.Previous;\r\n if FCursor.Previous <> nil then\r\n FCursor.Previous.Next := FCursor.Next;\r\n OldCursor := FCursor;\r\n FCursor := FCursor.Next;\r\n OldCursor.Free;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnList.WriteUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclLinkedListIterator.GetObject: TObject;\r\nbegin\r\n CheckValid;\r\n Result := nil;\r\n if FCursor <> nil then\r\n Result := FCursor.Value\r\n else\r\n if not FOwnList.ReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\nend;\r\n\r\nfunction TJclLinkedListIterator.HasNext: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnList.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Valid then\r\n Result := (FCursor <> nil) and (FCursor.Next <> nil)\r\n else\r\n Result := FCursor <> nil;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnList.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclLinkedListIterator.HasPrevious: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnList.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Valid then\r\n Result := (FCursor <> nil) and (FCursor.Previous <> nil)\r\n else\r\n Result := FCursor <> nil;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnList.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclLinkedListIterator.Insert(AObject: TObject): Boolean;\r\nvar\r\n NewCursor: TJclLinkedListItem;\r\nbegin\r\n if FOwnList.ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n FOwnList.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n CheckValid;\r\n Result := FCursor <> nil;\r\n if Result then\r\n begin\r\n Result := FOwnList.AllowDefaultElements or not FEqualityComparer.ItemsEqual(AObject, nil);\r\n if Result then\r\n begin\r\n case FOwnList.Duplicates of\r\n dupIgnore:\r\n Result := not FOwnList.Contains(AObject);\r\n dupAccept:\r\n Result := True;\r\n dupError:\r\n begin\r\n Result := FOwnList.Contains(AObject);\r\n if not Result then\r\n raise EJclDuplicateElementError.Create;\r\n end;\r\n end;\r\n if Result then\r\n begin\r\n NewCursor := TJclLinkedListItem.Create;\r\n NewCursor.Value := AObject;\r\n NewCursor.Next := FCursor;\r\n NewCursor.Previous := FCursor.Previous;\r\n if FCursor.Previous <> nil then\r\n FCursor.Previous.Next := NewCursor;\r\n FCursor.Previous := NewCursor;\r\n FCursor := NewCursor;\r\n end;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnList.WriteUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclLinkedListIterator.IteratorEquals(const AIterator: IJclIterator): Boolean;\r\nvar\r\n Obj: TObject;\r\n ItrObj: TJclLinkedListIterator;\r\nbegin\r\n Result := False;\r\n if AIterator = nil then\r\n Exit;\r\n Obj := AIterator.GetIteratorReference;\r\n if Obj is TJclLinkedListIterator then\r\n begin\r\n ItrObj := TJclLinkedListIterator(Obj);\r\n Result := (FOwnList = ItrObj.FOwnList) and (FCursor = ItrObj.FCursor) and (Valid = ItrObj.Valid);\r\n end;\r\nend;\r\n\r\n{$IFDEF SUPPORTS_FOR_IN}\r\nfunction TJclLinkedListIterator.MoveNext: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnList.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Valid and (FCursor <> nil) then\r\n FCursor := FCursor.Next\r\n else\r\n Valid := True;\r\n Result := FCursor <> nil;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnList.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n{$ENDIF SUPPORTS_FOR_IN}\r\n\r\nfunction TJclLinkedListIterator.Next: TObject;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnList.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Valid and (FCursor <> nil) then\r\n FCursor := FCursor.Next\r\n else\r\n Valid := True;\r\n if FCursor <> nil then\r\n Result := FCursor.Value\r\n else\r\n Result := nil;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnList.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclLinkedListIterator.NextIndex: Integer;\r\nbegin\r\n // No Index\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nfunction TJclLinkedListIterator.Previous: TObject;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnList.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Valid and (FCursor <> nil) then\r\n FCursor := FCursor.Previous\r\n else\r\n Valid := True;\r\n if FCursor <> nil then\r\n Result := FCursor.Value\r\n else\r\n Result := nil;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnList.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclLinkedListIterator.PreviousIndex: Integer;\r\nbegin\r\n // No Index\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nprocedure TJclLinkedListIterator.Remove;\r\nvar\r\n OldCursor: TJclLinkedListItem;\r\nbegin\r\n if FOwnList.ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n FOwnList.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n CheckValid;\r\n Valid := False;\r\n if FCursor <> nil then\r\n begin\r\n (FownList as IJclObjectOwner).FreeObject(FCursor.Value);\r\n if FCursor.Next <> nil then\r\n FCursor.Next.Previous := FCursor.Previous;\r\n if FCursor.Previous <> nil then\r\n FCursor.Previous.Next := FCursor.Next;\r\n OldCursor := FCursor;\r\n FCursor := FCursor.Next;\r\n OldCursor.Free;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnList.WriteUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclLinkedListIterator.Reset;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnList.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Valid := False;\r\n case FStart of\r\n isFirst:\r\n begin\r\n while (FCursor <> nil) and (FCursor.Previous <> nil) do\r\n FCursor := FCursor.Previous;\r\n end;\r\n isLast:\r\n begin\r\n while (FCursor <> nil) and (FCursor.Next <> nil) do\r\n FCursor := FCursor.Next;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnList.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclLinkedListIterator.SetObject(AObject: TObject);\r\nbegin\r\n if FOwnList.ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n FOwnList.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n CheckValid;\r\n (FownList as IJclObjectOwner).FreeObject(FCursor.Value);\r\n FCursor.Value := AObject;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnList.WriteUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\n\r\n{$IFDEF SUPPORTS_GENERICS}\r\n//DOM-IGNORE-BEGIN\r\n\r\n//=== { TJclLinkedList } ==================================================\r\n\r\nconstructor TJclLinkedList.Create(const ACollection: IJclCollection; AOwnsItems: Boolean);\r\nbegin\r\n inherited Create(AOwnsItems);\r\n FStart := nil;\r\n FEnd := nil;\r\n if ACollection <> nil then\r\n AddAll(ACollection);\r\nend;\r\n\r\ndestructor TJclLinkedList.Destroy;\r\nbegin\r\n FReadOnly := False;\r\n Clear;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJclLinkedList.Add(const AItem: T): Boolean;\r\nvar\r\n NewItem: TLinkedListItem;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := FAllowDefaultElements or not ItemsEqual(AItem, Default(T));\r\n if Result then\r\n begin\r\n if FDuplicates <> dupAccept then\r\n begin\r\n NewItem := FStart;\r\n while NewItem <> nil do\r\n begin\r\n if ItemsEqual(AItem, NewItem.Value) then\r\n begin\r\n Result := CheckDuplicate;\r\n Break;\r\n end;\r\n NewItem := NewItem.Next;\r\n end;\r\n end;\r\n if Result then\r\n begin\r\n NewItem := TLinkedListItem.Create;\r\n NewItem.Value := AItem;\r\n if FStart <> nil then\r\n begin\r\n NewItem.Next := nil;\r\n NewItem.Previous := FEnd;\r\n FEnd.Next := NewItem;\r\n FEnd := NewItem;\r\n end\r\n else\r\n begin\r\n FStart := NewItem;\r\n FEnd := NewItem;\r\n end;\r\n Inc(FSize);\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclLinkedList.AddAll(const ACollection: IJclCollection): Boolean;\r\nvar\r\n It: IJclIterator;\r\n Item: T;\r\n AddItem: Boolean;\r\n NewItem: TLinkedListItem;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n begin\r\n Item := It.Next;\r\n AddItem := FAllowDefaultElements or not ItemsEqual(Item, Default(T));\r\n if AddItem then\r\n begin\r\n if FDuplicates <> dupAccept then\r\n begin\r\n NewItem := FStart;\r\n while NewItem <> nil do\r\n begin\r\n if ItemsEqual(Item, NewItem.Value) then\r\n begin\r\n AddItem := CheckDuplicate;\r\n Break;\r\n end;\r\n NewItem := NewItem.Next;\r\n end;\r\n end;\r\n if AddItem then\r\n begin\r\n NewItem := TLinkedListItem.Create;\r\n NewItem.Value := Item;\r\n if FStart <> nil then\r\n begin\r\n NewItem.Next := nil;\r\n NewItem.Previous := FEnd;\r\n FEnd.Next := NewItem;\r\n FEnd := NewItem;\r\n end\r\n else\r\n begin\r\n FStart := NewItem;\r\n FEnd := NewItem;\r\n end;\r\n Inc(FSize);\r\n end;\r\n end;\r\n Result := AddItem and Result;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclLinkedList.AssignDataTo(Dest: TJclAbstractContainerBase);\r\nvar\r\n ACollection: IJclCollection;\r\nbegin\r\n inherited AssignDataTo(Dest);\r\n if Supports(IInterface(Dest), IJclCollection, ACollection) then\r\n begin\r\n ACollection.Clear;\r\n ACollection.AddAll(Self);\r\n end;\r\nend;\r\n\r\nprocedure TJclLinkedList.Clear;\r\nvar\r\n Old, Current: TLinkedListItem;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Current := FStart;\r\n while Current <> nil do\r\n begin\r\n FreeItem(Current.Value);\r\n Old := Current;\r\n Current := Current.Next;\r\n Old.Free;\r\n end;\r\n FSize := 0;\r\n\r\n //Daniele Teti 27/12/2004\r\n FStart := nil;\r\n FEnd := nil;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclLinkedList.CollectionEquals(const ACollection: IJclCollection): Boolean;\r\nvar\r\n It, ItSelf: IJclIterator;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n if FSize <> ACollection.Size then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n ItSelf := First;\r\n while ItSelf.HasNext and It.HasNext do\r\n if not ItemsEqual(ItSelf.Next, It.Next) then\r\n begin\r\n Result := False;\r\n Break;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclLinkedList.Contains(const AItem: T): Boolean;\r\nvar\r\n Current: TLinkedListItem;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n Current := FStart;\r\n while Current <> nil do\r\n begin\r\n if ItemsEqual(Current.Value, AItem) then\r\n begin\r\n Result := True;\r\n Break;\r\n end;\r\n Current := Current.Next;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclLinkedList.ContainsAll(const ACollection: IJclCollection): Boolean;\r\nvar\r\n It: IJclIterator;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n while Result and It.HasNext do\r\n Result := Contains(It.Next);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclLinkedList.Delete(Index: Integer): T;\r\nvar\r\n Current: TLinkedListItem;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := Default(T);\r\n if (Index >= 0) and (Index < FSize) then\r\n begin\r\n Current := FStart;\r\n while Current <> nil do\r\n begin\r\n if Index = 0 then\r\n begin\r\n if Current.Previous <> nil then\r\n Current.Previous.Next := Current.Next\r\n else\r\n FStart := Current.Next;\r\n if Current.Next <> nil then\r\n Current.Next.Previous := Current.Previous\r\n else\r\n FEnd := Current.Previous;\r\n Result := FreeItem(Current.Value);\r\n Current.Free;\r\n Dec(FSize);\r\n Break;\r\n end;\r\n Dec(Index);\r\n Current := Current.Next;\r\n end;\r\n end\r\n else\r\n raise EJclOutOfBoundsError.Create;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclLinkedList.Extract(const AItem: T): Boolean;\r\nvar\r\n Current: TLinkedListItem;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n Current := FStart;\r\n while Current <> nil do\r\n begin\r\n if ItemsEqual(Current.Value, AItem) then\r\n begin\r\n if Current.Previous <> nil then\r\n Current.Previous.Next := Current.Next\r\n else\r\n FStart := Current.Next;\r\n if Current.Next <> nil then\r\n Current.Next.Previous := Current.Previous\r\n else\r\n FEnd := Current.Previous;\r\n Current.Value := Default(T);\r\n Current.Free;\r\n Dec(FSize);\r\n Result := True;\r\n if FRemoveSingleElement then\r\n Break;\r\n end;\r\n Current := Current.Next;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclLinkedList.ExtractAll(const ACollection: IJclCollection): Boolean;\r\nvar\r\n It: IJclIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := True;\r\n if ACollection = nil then\r\n Exit;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n Result := Extract(It.Next) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclLinkedList.ExtractIndex(Index: Integer): T;\r\nvar\r\n Current: TLinkedListItem;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := Default(T);\r\n if (Index >= 0) and (Index < FSize) then\r\n begin\r\n Current := FStart;\r\n while Current <> nil do\r\n begin\r\n if Index = 0 then\r\n begin\r\n if Current.Previous <> nil then\r\n Current.Previous.Next := Current.Next\r\n else\r\n FStart := Current.Next;\r\n if Current.Next <> nil then\r\n Current.Next.Previous := Current.Previous\r\n else\r\n FEnd := Current.Previous;\r\n Result := Current.Value;\r\n Current.Free;\r\n Dec(FSize);\r\n Break;\r\n end;\r\n Dec(Index);\r\n Current := Current.Next;\r\n end;\r\n end\r\n else\r\n raise EJclOutOfBoundsError.Create;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclLinkedList.First: IJclIterator;\r\nbegin\r\n Result := TLinkedListIterator.Create(Self, FStart, False, isFirst);\r\nend;\r\n\r\n{$IFDEF SUPPORTS_FOR_IN}\r\nfunction TJclLinkedList.GetEnumerator: IJclIterator;\r\nbegin\r\n Result := TLinkedListIterator.Create(Self, FStart, False, isFirst);\r\nend;\r\n{$ENDIF SUPPORTS_FOR_IN}\r\n\r\nfunction TJclLinkedList.GetItem(Index: Integer): T;\r\nvar\r\n Current: TLinkedListItem;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := Default(T);\r\n Current := FStart;\r\n while (Current <> nil) and (Index > 0) do\r\n begin\r\n Current := Current.Next;\r\n Dec(Index);\r\n end;\r\n if Current <> nil then\r\n Result := Current.Value\r\n else\r\n if not FReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclLinkedList.IndexOf(const AItem: T): Integer;\r\nvar\r\n Current: TLinkedListItem;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Current := FStart;\r\n Result := 0;\r\n while (Current <> nil) and not ItemsEqual(Current.Value, AItem) do\r\n begin\r\n Inc(Result);\r\n Current := Current.Next;\r\n end;\r\n if Current = nil then\r\n Result := -1;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclLinkedList.Insert(Index: Integer; const AItem: T): Boolean;\r\nvar\r\n Current, NewItem: TLinkedListItem;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := FAllowDefaultElements or not ItemsEqual(AItem, Default(T));\r\n if (Index < 0) or (Index > FSize) then\r\n raise EJclOutOfBoundsError.Create;\r\n if Result then\r\n begin\r\n if FDuplicates <> dupAccept then\r\n begin\r\n Current := FStart;\r\n while Current <> nil do\r\n begin\r\n if ItemsEqual(AItem, Current.Value) then\r\n begin\r\n Result := CheckDuplicate;\r\n Break;\r\n end;\r\n Current := Current.Next;\r\n end;\r\n end;\r\n if Result then\r\n begin\r\n NewItem := TLinkedListItem.Create;\r\n NewItem.Value := AItem;\r\n if Index = 0 then\r\n begin\r\n NewItem.Next := FStart;\r\n if FStart <> nil then\r\n FStart.Previous := NewItem;\r\n FStart := NewItem;\r\n if FSize = 0 then\r\n FEnd := NewItem;\r\n Inc(FSize);\r\n end\r\n else\r\n if Index = FSize then\r\n begin\r\n NewItem.Previous := FEnd;\r\n FEnd.Next := NewItem;\r\n FEnd := NewItem;\r\n Inc(FSize);\r\n end\r\n else\r\n begin\r\n Current := FStart;\r\n while (Current <> nil) and (Index > 0) do\r\n begin\r\n Current := Current.Next;\r\n Dec(Index);\r\n end;\r\n if Current <> nil then\r\n begin\r\n NewItem.Next := Current;\r\n NewItem.Previous := Current.Previous;\r\n if Current.Previous <> nil then\r\n Current.Previous.Next := NewItem;\r\n Current.Previous := NewItem;\r\n Inc(FSize);\r\n end;\r\n end;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclLinkedList.InsertAll(Index: Integer; const ACollection: IJclCollection): Boolean;\r\nvar\r\n It: IJclIterator;\r\n Current, NewItem, Test: TLinkedListItem;\r\n AddItem: Boolean;\r\n Item: T;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if (Index < 0) or (Index > FSize) then\r\n raise EJclOutOfBoundsError.Create;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n if Index = 0 then\r\n begin\r\n It := ACollection.Last;\r\n while It.HasPrevious do\r\n begin\r\n Item := It.Previous;\r\n AddItem := FAllowDefaultElements or not ItemsEqual(Item, Default(T));\r\n if AddItem then\r\n begin\r\n if FDuplicates <> dupAccept then\r\n begin\r\n Test := FStart;\r\n while Test <> nil do\r\n begin\r\n if ItemsEqual(Item, Test.Value) then\r\n begin\r\n Result := CheckDuplicate;\r\n Break;\r\n end;\r\n Test := Test.Next;\r\n end;\r\n end;\r\n if AddItem then\r\n begin\r\n NewItem := TLinkedListItem.Create;\r\n NewItem.Value := Item;\r\n NewItem.Next := FStart;\r\n if FStart <> nil then\r\n FStart.Previous := NewItem;\r\n FStart := NewItem;\r\n if FSize = 0 then\r\n FEnd := NewItem;\r\n Inc(FSize);\r\n end;\r\n end;\r\n Result := Result and AddItem;\r\n end;\r\n end\r\n else\r\n if Index = Size then\r\n begin\r\n It := ACollection.First;\r\n while It.HasNext do\r\n begin\r\n Item := It.Next;\r\n AddItem := FAllowDefaultElements or not ItemsEqual(Item, Default(T));\r\n if AddItem then\r\n begin\r\n if FDuplicates <> dupAccept then\r\n begin\r\n Test := FStart;\r\n while Test <> nil do\r\n begin\r\n if ItemsEqual(Item, Test.Value) then\r\n begin\r\n Result := CheckDuplicate;\r\n Break;\r\n end;\r\n Test := Test.Next;\r\n end;\r\n end;\r\n if AddItem then\r\n begin\r\n NewItem := TLinkedListItem.Create;\r\n NewItem.Value := Item;\r\n NewItem.Previous := FEnd;\r\n if FEnd <> nil then\r\n FEnd.Next := NewItem;\r\n FEnd := NewItem;\r\n Inc(FSize);\r\n end;\r\n end;\r\n Result := Result and AddItem;\r\n end;\r\n end\r\n else\r\n begin\r\n Current := FStart;\r\n while (Current <> nil) and (Index > 0) do\r\n begin\r\n Current := Current.Next;\r\n Dec(Index);\r\n end;\r\n if Current <> nil then\r\n begin\r\n It := ACollection.First;\r\n while It.HasNext do\r\n begin\r\n Item := It.Next;\r\n AddItem := FAllowDefaultElements or not ItemsEqual(Item, Default(T));\r\n if AddItem then\r\n begin\r\n if FDuplicates <> dupAccept then\r\n begin\r\n Test := FStart;\r\n while Test <> nil do\r\n begin\r\n if ItemsEqual(Item, Test.Value) then\r\n begin\r\n Result := CheckDuplicate;\r\n Break;\r\n end;\r\n Test := Test.Next;\r\n end;\r\n end;\r\n if AddItem then\r\n begin\r\n NewItem := TLinkedListItem.Create;\r\n NewItem.Value := Item;\r\n NewItem.Next := Current;\r\n NewItem.Previous := Current.Previous;\r\n if Current.Previous <> nil then\r\n Current.Previous.Next := NewItem;\r\n Current.Previous := NewItem;\r\n Inc(FSize);\r\n end;\r\n end;\r\n Result := Result and AddItem;\r\n end;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclLinkedList.IsEmpty: Boolean;\r\nbegin\r\n Result := FSize = 0;\r\nend;\r\n\r\nfunction TJclLinkedList.Last: IJclIterator;\r\nbegin\r\n Result := TLinkedListIterator.Create(Self, FEnd, False, isLast);\r\nend;\r\n\r\nfunction TJclLinkedList.LastIndexOf(const AItem: T): Integer;\r\nvar\r\n Current: TLinkedListItem;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := -1;\r\n if FEnd <> nil then\r\n begin\r\n Current := FEnd;\r\n Result := FSize - 1;\r\n while (Current <> nil) and not ItemsEqual(Current.Value, AItem) do\r\n begin\r\n Dec(Result);\r\n Current := Current.Previous;\r\n end;\r\n if Current = nil then\r\n Result := -1;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclLinkedList.Remove(const AItem: T): Boolean;\r\nvar\r\n Extracted: T;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := Extract(AItem);\r\n if Result then\r\n begin\r\n Extracted := AItem;\r\n FreeItem(Extracted);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclLinkedList.RemoveAll(const ACollection: IJclCollection): Boolean;\r\nvar\r\n It: IJclIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := True;\r\n if ACollection = nil then\r\n Exit;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n Result := Remove(It.Next) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclLinkedList.RetainAll(const ACollection: IJclCollection): Boolean;\r\nvar\r\n It: IJclIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := First;\r\n while It.HasNext do\r\n if not ACollection.Contains(It.Next) then\r\n It.Remove;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclLinkedList.SetItem(Index: Integer; const AItem: T);\r\nvar\r\n Current: TLinkedListItem;\r\n ReplaceItem: Boolean;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n ReplaceItem := FAllowDefaultElements or not ItemsEqual(AItem, Default(T));\r\n if ReplaceItem then\r\n begin\r\n if FDuplicates <> dupAccept then\r\n begin\r\n Current := FStart;\r\n while Current <> nil do\r\n begin\r\n if ItemsEqual(AItem, Current.Value) then\r\n begin\r\n ReplaceItem := CheckDuplicate;\r\n Break;\r\n end;\r\n Current := Current.Next;\r\n end;\r\n end;\r\n if ReplaceItem then\r\n begin\r\n Current := FStart;\r\n while Current <> nil do\r\n begin\r\n if Index = 0 then\r\n begin\r\n FreeItem(Current.Value);\r\n Current.Value := AItem;\r\n Break;\r\n end;\r\n Dec(Index);\r\n Current := Current.Next;\r\n end;\r\n end;\r\n end;\r\n if not ReplaceItem then\r\n Delete(Index);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclLinkedList.Size: Integer;\r\nbegin\r\n Result := FSize;\r\nend;\r\n\r\nfunction TJclLinkedList.SubList(First, Count: Integer): IJclList;\r\nvar\r\n Current: TLinkedListItem;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := CreateEmptyContainer as IJclList;\r\n Current := FStart;\r\n while (Current <> nil) and (First > 0) do\r\n begin\r\n Dec(First);\r\n Current := Current.Next;\r\n end;\r\n while (Current <> nil) and (Count > 0) do\r\n begin\r\n Result.Add(Current.Value);\r\n Dec(Count);\r\n Current := Current.Next;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\n//=== { TJclLinkedListIterator } ============================================================\r\n\r\nconstructor TJclLinkedListIterator.Create(AOwnList: IJclList; ACursor: TJclLinkedList.TLinkedListItem; AValid: Boolean; AStart: TItrStart);\r\nbegin\r\n inherited Create(AValid);\r\n FCursor := ACursor;\r\n FOwnList := AOwnList;\r\n FStart := AStart;\r\n FEqualityComparer := AOwnList as IJclEqualityComparer;\r\nend;\r\n\r\nfunction TJclLinkedListIterator.Add(const AItem: T): Boolean;\r\nbegin\r\n Result := FOwnList.Add(AItem);\r\nend;\r\n\r\nprocedure TJclLinkedListIterator.AssignPropertiesTo(Dest: TJclAbstractIterator);\r\nvar\r\n ADest: TJclLinkedListIterator;\r\nbegin\r\n inherited AssignPropertiesTo(Dest);\r\n if Dest is TJclLinkedListIterator then\r\n begin\r\n ADest := TJclLinkedListIterator(Dest);\r\n ADest.FCursor := FCursor;\r\n ADest.FOwnList := FOwnList;\r\n ADest.FEqualityComparer := FEqualityComparer;\r\n ADest.FStart := FStart;\r\n end;\r\nend;\r\n\r\nfunction TJclLinkedListIterator.CreateEmptyIterator: TJclAbstractIterator;\r\nbegin\r\n Result := TJclLinkedListIterator.Create(FOwnList, FCursor, Valid, FStart);\r\nend;\r\n\r\nprocedure TJclLinkedListIterator.Extract;\r\nvar\r\n OldCursor: TJclLinkedList.TLinkedListItem;\r\nbegin\r\n if FOwnList.ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n FOwnList.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n CheckValid;\r\n Valid := False;\r\n if FCursor <> nil then\r\n begin\r\n if FCursor.Next <> nil then\r\n FCursor.Next.Previous := FCursor.Previous;\r\n if FCursor.Previous <> nil then\r\n FCursor.Previous.Next := FCursor.Next;\r\n OldCursor := FCursor;\r\n FCursor := FCursor.Next;\r\n OldCursor.Free;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnList.WriteUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclLinkedListIterator.GetItem: T;\r\nbegin\r\n CheckValid;\r\n Result := Default(T);\r\n if FCursor <> nil then\r\n Result := FCursor.Value\r\n else\r\n if not FOwnList.ReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\nend;\r\n\r\nfunction TJclLinkedListIterator.HasNext: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnList.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Valid then\r\n Result := (FCursor <> nil) and (FCursor.Next <> nil)\r\n else\r\n Result := FCursor <> nil;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnList.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclLinkedListIterator.HasPrevious: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnList.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Valid then\r\n Result := (FCursor <> nil) and (FCursor.Previous <> nil)\r\n else\r\n Result := FCursor <> nil;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnList.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclLinkedListIterator.Insert(const AItem: T): Boolean;\r\nvar\r\n NewCursor: TJclLinkedList.TLinkedListItem;\r\nbegin\r\n if FOwnList.ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n FOwnList.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n CheckValid;\r\n Result := FCursor <> nil;\r\n if Result then\r\n begin\r\n Result := FOwnList.AllowDefaultElements or not FEqualityComparer.ItemsEqual(AItem, Default(T));\r\n if Result then\r\n begin\r\n case FOwnList.Duplicates of\r\n dupIgnore:\r\n Result := not FOwnList.Contains(AItem);\r\n dupAccept:\r\n Result := True;\r\n dupError:\r\n begin\r\n Result := FOwnList.Contains(AItem);\r\n if not Result then\r\n raise EJclDuplicateElementError.Create;\r\n end;\r\n end;\r\n if Result then\r\n begin\r\n NewCursor := TJclLinkedList.TLinkedListItem.Create;\r\n NewCursor.Value := AItem;\r\n NewCursor.Next := FCursor;\r\n NewCursor.Previous := FCursor.Previous;\r\n if FCursor.Previous <> nil then\r\n FCursor.Previous.Next := NewCursor;\r\n FCursor.Previous := NewCursor;\r\n FCursor := NewCursor;\r\n end;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnList.WriteUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclLinkedListIterator.IteratorEquals(const AIterator: IJclIterator): Boolean;\r\nvar\r\n Obj: TObject;\r\n ItrObj: TJclLinkedListIterator;\r\nbegin\r\n Result := False;\r\n if AIterator = nil then\r\n Exit;\r\n Obj := AIterator.GetIteratorReference;\r\n if Obj is TJclLinkedListIterator then\r\n begin\r\n ItrObj := TJclLinkedListIterator(Obj);\r\n Result := (FOwnList = ItrObj.FOwnList) and (FCursor = ItrObj.FCursor) and (Valid = ItrObj.Valid);\r\n end;\r\nend;\r\n\r\n{$IFDEF SUPPORTS_FOR_IN}\r\nfunction TJclLinkedListIterator.MoveNext: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnList.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Valid and (FCursor <> nil) then\r\n FCursor := FCursor.Next\r\n else\r\n Valid := True;\r\n Result := FCursor <> nil;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnList.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n{$ENDIF SUPPORTS_FOR_IN}\r\n\r\nfunction TJclLinkedListIterator.Next: T;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnList.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Valid and (FCursor <> nil) then\r\n FCursor := FCursor.Next\r\n else\r\n Valid := True;\r\n if FCursor <> nil then\r\n Result := FCursor.Value\r\n else\r\n Result := Default(T);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnList.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclLinkedListIterator.NextIndex: Integer;\r\nbegin\r\n // No Index\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nfunction TJclLinkedListIterator.Previous: T;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnList.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Valid and (FCursor <> nil) then\r\n FCursor := FCursor.Previous\r\n else\r\n Valid := True;\r\n if FCursor <> nil then\r\n Result := FCursor.Value\r\n else\r\n Result := Default(T);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnList.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclLinkedListIterator.PreviousIndex: Integer;\r\nbegin\r\n // No Index\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nprocedure TJclLinkedListIterator.Remove;\r\nvar\r\n OldCursor: TJclLinkedList.TLinkedListItem;\r\nbegin\r\n if FOwnList.ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n FOwnList.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n CheckValid;\r\n Valid := False;\r\n if FCursor <> nil then\r\n begin\r\n (FownList as IJclItemOwner).FreeItem(FCursor.Value);\r\n if FCursor.Next <> nil then\r\n FCursor.Next.Previous := FCursor.Previous;\r\n if FCursor.Previous <> nil then\r\n FCursor.Previous.Next := FCursor.Next;\r\n OldCursor := FCursor;\r\n FCursor := FCursor.Next;\r\n OldCursor.Free;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnList.WriteUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclLinkedListIterator.Reset;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnList.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Valid := False;\r\n case FStart of\r\n isFirst:\r\n begin\r\n while (FCursor <> nil) and (FCursor.Previous <> nil) do\r\n FCursor := FCursor.Previous;\r\n end;\r\n isLast:\r\n begin\r\n while (FCursor <> nil) and (FCursor.Next <> nil) do\r\n FCursor := FCursor.Next;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnList.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclLinkedListIterator.SetItem(const AItem: T);\r\nbegin\r\n if FOwnList.ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n FOwnList.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n CheckValid;\r\n (FownList as IJclItemOwner).FreeItem(FCursor.Value);\r\n FCursor.Value := AItem;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnList.WriteUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\n//=== { TJclLinkedListE } =================================================\r\n\r\nconstructor TJclLinkedListE.Create(const AEqualityComparer: IJclEqualityComparer;\r\n const ACollection: IJclCollection; AOwnsItems: Boolean);\r\nbegin\r\n inherited Create(ACollection, AOwnsItems);\r\n FEqualityComparer := AEqualityComparer;\r\nend;\r\n\r\nprocedure TJclLinkedListE.AssignPropertiesTo(Dest: TJclAbstractContainerBase);\r\nbegin\r\n inherited AssignPropertiesTo(Dest);\r\n if Dest is TJclLinkedListE then\r\n TJclLinkedListE(Dest).FEqualityComparer := FEqualityComparer;\r\nend;\r\n\r\nfunction TJclLinkedListE.CreateEmptyContainer: TJclAbstractContainerBase;\r\nbegin\r\n Result := TJclLinkedListE.Create(EqualityComparer, nil, False);\r\n AssignPropertiesTo(Result);\r\nend;\r\n\r\nfunction TJclLinkedListE.ItemsEqual(const A, B: T): Boolean;\r\nbegin\r\n if EqualityComparer <> nil then\r\n Result := EqualityComparer.ItemsEqual(A, B)\r\n else\r\n Result := inherited ItemsEqual(A, B);\r\nend;\r\n\r\n//=== { TJclLinkedListF } =================================================\r\n\r\nconstructor TJclLinkedListF.Create(const AEqualityCompare: TEqualityCompare;\r\n const ACollection: IJclCollection; AOwnsItems: Boolean);\r\nbegin\r\n inherited Create(ACollection, AOwnsItems);\r\n SetEqualityCompare(AEqualityCompare);\r\nend;\r\n\r\nfunction TJclLinkedListF.CreateEmptyContainer: TJclAbstractContainerBase;\r\nbegin\r\n Result := TJclLinkedListF.Create(EqualityCompare, nil, False);\r\n AssignPropertiesTo(Result);\r\nend;\r\n\r\n//=== { TJclLinkedListI } =================================================\r\n\r\nfunction TJclLinkedListI.CreateEmptyContainer: TJclAbstractContainerBase;\r\nbegin\r\n Result := TJclLinkedListI.Create(nil, False);\r\n AssignPropertiesTo(Result);\r\nend;\r\n\r\nfunction TJclLinkedListI.ItemsEqual(const A, B: T): Boolean;\r\nbegin\r\n if Assigned(FEqualityCompare) then\r\n Result := FEqualityCompare(A, B)\r\n else\r\n if Assigned(FCompare) then\r\n Result := FCompare(A, B) = 0\r\n else\r\n Result := A.Equals(B);\r\nend;\r\n\r\n//DOM-IGNORE-END\r\n{$ENDIF SUPPORTS_GENERICS}\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n\r\n" }, { "path": "External/Jedi/Jcl/source/common/JclLogic.pas", "content": "{**************************************************************************************************}\r\n{ }\r\n{ Project JEDI Code Library (JCL) }\r\n{ }\r\n{ The contents of this file are subject to the Mozilla Public License Version 1.1 (the \"License\"); }\r\n{ you may not use this file except in compliance with the License. You may obtain a copy of the }\r\n{ License at http://www.mozilla.org/MPL/ }\r\n{ }\r\n{ Software distributed under the License is distributed on an \"AS IS\" basis, WITHOUT WARRANTY OF }\r\n{ ANY KIND, either express or implied. See the License for the specific language governing rights }\r\n{ and limitations under the License. }\r\n{ }\r\n{ The Original Code is JclLogic.pas. }\r\n{ }\r\n{ The Initial Developer of the Original Code is Marcel van Brakel. }\r\n{ Portions created by Marcel van Brakel are Copyright (C) Marcel van Brakel. All rights reserved. }\r\n{ }\r\n{ Contributor(s): }\r\n{ Marcel Bestebroer (marcelb) }\r\n{ Marcel van Brakel }\r\n{ ESB Consultancy }\r\n{ Martin Kimmings }\r\n{ Robert Marquardt (marquardt) }\r\n{ Chris Morris }\r\n{ Andreas Schmidt shmia at bizerba.de }\r\n{ Michael Schnell }\r\n{ Matthias Thoma (mthoma) }\r\n{ Petr Vones (pvones) }\r\n{ }\r\n{**************************************************************************************************}\r\n{ }\r\n{ Various routines to perform various arithmetic and logical operations on one or more ordinal }\r\n{ values (integer numbers). This includes various bit manipulation routines, min/max testing and }\r\n{ conversion to string. }\r\n{ }\r\n{**************************************************************************************************}\r\n{ }\r\n{ Last modified: $Date:: 2011-09-03 00:07:50 +0200 (sam. 03 sept. 2011) $ }\r\n{ Revision: $Rev:: 3599 $ }\r\n{ Author: $Author:: outchy $ }\r\n{ }\r\n{**************************************************************************************************}\r\n\r\n{.$DEFINE PUREPASCAL}\r\n\r\nunit JclLogic;\r\n\r\n{$I jcl.inc}\r\n{$RANGECHECKS OFF}\r\n\r\ninterface\r\n\r\n{$IFDEF UNITVERSIONING}\r\nuses\r\n JclUnitVersioning;\r\n{$ENDIF UNITVERSIONING}\r\n\r\n// Conversion\r\nfunction OrdToBinary(Value: Byte): string; overload;\r\nfunction OrdToBinary(Value: ShortInt): string; overload;\r\nfunction OrdToBinary(Value: SmallInt): string; overload;\r\nfunction OrdToBinary(Value: Word): string; overload;\r\nfunction OrdToBinary(Value: Integer): string; overload;\r\nfunction OrdToBinary(Value: Cardinal): string; overload;\r\nfunction OrdToBinary(Value: Int64): string; overload;\r\n\r\n// Bit manipulation\r\ntype\r\n TBitRange = Byte;\r\n TBooleanArray = array of Boolean;\r\n\r\nfunction BitsHighest(X: Byte): Integer; overload;\r\nfunction BitsHighest(X: ShortInt): Integer; overload;\r\nfunction BitsHighest(X: SmallInt): Integer; overload;\r\nfunction BitsHighest(X: Word): Integer; overload;\r\nfunction BitsHighest(X: Integer): Integer; overload;\r\nfunction BitsHighest(X: Cardinal): Integer; overload;\r\nfunction BitsHighest(X: Int64): Integer; overload;\r\n\r\nfunction BitsLowest(X: Byte): Integer; overload;\r\nfunction BitsLowest(X: Shortint): Integer; overload;\r\nfunction BitsLowest(X: Smallint): Integer; overload;\r\nfunction BitsLowest(X: Word): Integer; overload;\r\nfunction BitsLowest(X: Cardinal): Integer; overload;\r\nfunction BitsLowest(X: Integer): Integer; overload;\r\nfunction BitsLowest(X: Int64): Integer; overload;\r\n\r\nfunction ClearBit(const Value: Byte; const Bit: TBitRange): Byte; overload;\r\nfunction ClearBit(const Value: Shortint; const Bit: TBitRange): Shortint; overload;\r\nfunction ClearBit(const Value: Smallint; const Bit: TBitRange): Smallint; overload;\r\nfunction ClearBit(const Value: Word; const Bit: TBitRange): Word; overload;\r\nfunction ClearBit(const Value: Integer; const Bit: TBitRange): Integer; overload;\r\nfunction ClearBit(const Value: Cardinal; const Bit: TBitRange): Cardinal; overload;\r\nfunction ClearBit(const Value: Int64; const Bit: TBitRange): Int64; overload;\r\nprocedure ClearBitBuffer(var Value; const Bit: Cardinal); overload;\r\n{$IFDEF CPU64}\r\nprocedure ClearBitBuffer(var Value; const Bit: Int64); overload;\r\n{$ENDIF CPU64}\r\n\r\nfunction CountBitsSet(X: Byte): Integer; overload;\r\nfunction CountBitsSet(X: Word): Integer; overload;\r\nfunction CountBitsSet(X: Smallint): Integer; overload;\r\nfunction CountBitsSet(X: ShortInt): Integer; overload;\r\nfunction CountBitsSet(X: Integer): Integer; overload;\r\nfunction CountBitsSet(X: Cardinal): Integer; overload;\r\nfunction CountBitsSet(X: Int64): Integer; overload;\r\nfunction CountBitsSet(P: Pointer; Count: Cardinal): Cardinal; overload;\r\n\r\nfunction CountBitsCleared(X: Byte): Integer; overload;\r\nfunction CountBitsCleared(X: Shortint): Integer; overload;\r\nfunction CountBitsCleared(X: Smallint): Integer; overload;\r\nfunction CountBitsCleared(X: Word): Integer; overload;\r\nfunction CountBitsCleared(X: Integer): Integer; overload;\r\nfunction CountBitsCleared(X: Cardinal): Integer; overload;\r\nfunction CountBitsCleared(X: Int64): Integer; overload;\r\nfunction CountBitsCleared(P: Pointer; Count: Cardinal): Cardinal; overload;\r\n\r\nfunction LRot(const Value: Byte; const Count: TBitRange): Byte; overload;\r\nfunction LRot(const Value: Word; const Count: TBitRange): Word; overload;\r\nfunction LRot(const Value: Integer; const Count: TBitRange): Integer; overload;\r\nfunction LRot(const Value: Int64; const Count: TBitRange): Int64; overload;\r\nfunction ReverseBits(Value: Byte): Byte; overload;\r\nfunction ReverseBits(Value: Shortint): Shortint; overload;\r\nfunction ReverseBits(Value: Smallint): Smallint; overload;\r\nfunction ReverseBits(Value: Word): Word; overload;\r\nfunction ReverseBits(Value: Integer): Integer; overload;\r\nfunction ReverseBits(Value: Cardinal): Cardinal; overload;\r\nfunction ReverseBits(Value: Int64): Int64; overload;\r\nfunction ReverseBits(P: Pointer; Count: Integer): Pointer; overload;\r\n\r\nfunction RRot(const Value: Byte; const Count: TBitRange): Byte; overload;\r\nfunction RRot(const Value: Word; const Count: TBitRange): Word; overload;\r\nfunction RRot(const Value: Integer; const Count: TBitRange): Integer; overload;\r\nfunction RRot(const Value: Int64; const Count: TBitRange): Int64; overload;\r\n\r\nfunction Sar(const Value: Shortint; const Count: TBitRange): Shortint; overload;\r\nfunction Sar(const Value: Smallint; const Count: TBitRange): Smallint; overload;\r\nfunction Sar(const Value: Integer; const Count: TBitRange): Integer; overload;\r\n\r\nfunction SetBit(const Value: Byte; const Bit: TBitRange): Byte; overload;\r\nfunction SetBit(const Value: Shortint; const Bit: TBitRange): Shortint; overload;\r\nfunction SetBit(const Value: Smallint; const Bit: TBitRange): Smallint; overload;\r\nfunction SetBit(const Value: Word; const Bit: TBitRange): Word; overload;\r\nfunction SetBit(const Value: Cardinal; const Bit: TBitRange): Cardinal; overload;\r\nfunction SetBit(const Value: Integer; const Bit: TBitRange): Integer; overload;\r\nfunction SetBit(const Value: Int64; const Bit: TBitRange): Int64; overload;\r\nprocedure SetBitBuffer(var Value; const Bit: Cardinal); overload;\r\n{$IFDEF CPU64}\r\nprocedure SetBitBuffer(var Value; const Bit: Int64); overload;\r\n{$ENDIF CPU64}\r\n\r\nfunction TestBit(const Value: Byte; const Bit: TBitRange): Boolean; overload;\r\nfunction TestBit(const Value: Shortint; const Bit: TBitRange): Boolean; overload;\r\nfunction TestBit(const Value: Smallint; const Bit: TBitRange): Boolean; overload;\r\nfunction TestBit(const Value: Word; const Bit: TBitRange): Boolean; overload;\r\nfunction TestBit(const Value: Cardinal; const Bit: TBitRange): Boolean; overload;\r\nfunction TestBit(const Value: Integer; const Bit: TBitRange): Boolean; overload;\r\nfunction TestBit(const Value: Int64; const Bit: TBitRange): Boolean; overload;\r\nfunction TestBitBuffer(const Value; const Bit: Cardinal): Boolean; overload;\r\n{$IFDEF CPU64}\r\nfunction TestBitBuffer(const Value; const Bit: Int64): Boolean; overload;\r\n{$ENDIF CPU64}\r\n\r\nfunction TestBits(const Value, Mask: Byte): Boolean; overload;\r\nfunction TestBits(const Value, Mask: Shortint): Boolean; overload;\r\nfunction TestBits(const Value, Mask: Smallint): Boolean; overload;\r\nfunction TestBits(const Value, Mask: Word): Boolean; overload;\r\nfunction TestBits(const Value, Mask: Cardinal): Boolean; overload;\r\nfunction TestBits(const Value, Mask: Integer): Boolean; overload;\r\nfunction TestBits(const Value, Mask: Int64): Boolean; overload;\r\n\r\nfunction ToggleBit(const Value: Byte; const Bit: TBitRange): Byte; overload;\r\nfunction ToggleBit(const Value: Shortint; const Bit: TBitRange): Shortint; overload;\r\nfunction ToggleBit(const Value: Smallint; const Bit: TBitRange): Smallint; overload;\r\nfunction ToggleBit(const Value: Word; const Bit: TBitRange): Word; overload;\r\nfunction ToggleBit(const Value: Cardinal; const Bit: TBitRange): Cardinal; overload;\r\nfunction ToggleBit(const Value: Integer; const Bit: TBitRange): Integer; overload;\r\nfunction ToggleBit(const Value: Int64; const Bit: TBitRange): Int64; overload;\r\nprocedure ToggleBitBuffer(var Value; const Bit: Cardinal); overload;\r\n{$IFDEF CPU64}\r\nprocedure ToggleBitBuffer(var Value; const Bit: Int64); overload;\r\n{$ENDIF CPU64}\r\n\r\nprocedure BooleansToBits(var Dest: Byte; const B: TBooleanArray); overload;\r\nprocedure BooleansToBits(var Dest: Word; const B: TBooleanArray); overload;\r\nprocedure BooleansToBits(var Dest: Integer; const B: TBooleanArray); overload;\r\nprocedure BooleansToBits(var Dest: Int64; const B: TBooleanArray); overload;\r\n\r\nprocedure BitsToBooleans(const Bits: Byte; var B: TBooleanArray; AllBits: Boolean = False); overload;\r\nprocedure BitsToBooleans(const Bits: Word; var B: TBooleanArray; AllBits: Boolean = False); overload;\r\nprocedure BitsToBooleans(const Bits: Integer; var B: TBooleanArray; AllBits: Boolean = False); overload;\r\nprocedure BitsToBooleans(const Bits: Int64; var B: TBooleanArray; AllBits: Boolean = False); overload;\r\n\r\nfunction BitsNeeded(const X: Byte): Integer; overload;\r\nfunction BitsNeeded(const X: Word): Integer; overload;\r\nfunction BitsNeeded(const X: Integer): Integer; overload;\r\nfunction BitsNeeded(const X: Int64): Integer; overload;\r\n\r\nfunction Digits(const X: Cardinal): Integer;\r\n\r\nfunction ReverseBytes(Value: Word): Word; overload;\r\nfunction ReverseBytes(Value: Smallint): Smallint; overload;\r\nfunction ReverseBytes(Value: Integer): Integer; overload;\r\nfunction ReverseBytes(Value: Cardinal): Cardinal; overload;\r\nfunction ReverseBytes(Value: Int64): Int64; overload;\r\nfunction ReverseBytes(P: Pointer; Count: Integer): Pointer; overload;\r\n\r\n// Arithmetic\r\nprocedure SwapOrd(var I, J: Byte); overload;\r\nprocedure SwapOrd(var I, J: Shortint); overload;\r\nprocedure SwapOrd(var I, J: Smallint); overload;\r\nprocedure SwapOrd(var I, J: Word); overload;\r\nprocedure SwapOrd(var I, J: Integer); overload;\r\nprocedure SwapOrd(var I, J: Cardinal); overload;\r\nprocedure SwapOrd(var I, J: Int64); overload;\r\n\r\nfunction IncLimit(var B: Byte; const Limit: Byte; const Incr: Byte = 1): Byte; overload;\r\nfunction IncLimit(var B: Shortint; const Limit: Shortint; const Incr: Shortint = 1): Shortint; overload;\r\nfunction IncLimit(var B: Smallint; const Limit: Smallint; const Incr: Smallint = 1): Smallint; overload;\r\nfunction IncLimit(var B: Word; const Limit: Word; const Incr: Word = 1): Word; overload;\r\nfunction IncLimit(var B: Integer; const Limit: Integer; const Incr: Integer = 1): Integer; overload;\r\nfunction IncLimit(var B: Cardinal; const Limit: Cardinal; const Incr: Cardinal = 1): Cardinal; overload;\r\nfunction IncLimit(var B: Int64; const Limit: Int64; const Incr: Int64 = 1): Int64; overload;\r\n\r\nfunction DecLimit(var B: Byte; const Limit: Byte; const Decr: Byte = 1): Byte; overload;\r\nfunction DecLimit(var B: Shortint; const Limit: Shortint; const Decr: Shortint = 1): Shortint; overload;\r\nfunction DecLimit(var B: Smallint; const Limit: Smallint; const Decr: Smallint = 1): Smallint; overload;\r\nfunction DecLimit(var B: Word; const Limit: Word; const Decr: Word = 1): Word; overload;\r\nfunction DecLimit(var B: Integer; const Limit: Integer; const Decr: Integer = 1): Integer; overload;\r\nfunction DecLimit(var B: Cardinal; const Limit: Cardinal; const Decr: Cardinal = 1): Cardinal; overload;\r\nfunction DecLimit(var B: Int64; const Limit: Int64; const Decr: Int64 = 1): Int64; overload;\r\n\r\nfunction IncLimitClamp(var B: Byte; const Limit: Byte; const Incr: Byte = 1): Byte; overload;\r\nfunction IncLimitClamp(var B: Shortint; const Limit: Shortint; const Incr: Shortint = 1): Shortint; overload;\r\nfunction IncLimitClamp(var B: Smallint; const Limit: Smallint; const Incr: Smallint = 1): Smallint; overload;\r\nfunction IncLimitClamp(var B: Word; const Limit: Word; const Incr: Word = 1): Word; overload;\r\nfunction IncLimitClamp(var B: Integer; const Limit: Integer; const Incr: Integer = 1): Integer; overload;\r\nfunction IncLimitClamp(var B: Cardinal; const Limit: Cardinal; const Incr: Cardinal = 1): Cardinal; overload;\r\nfunction IncLimitClamp(var B: Int64; const Limit: Int64; const Incr: Int64 = 1): Int64; overload;\r\n\r\nfunction DecLimitClamp(var B: Byte; const Limit: Byte; const Decr: Byte = 1): Byte; overload;\r\nfunction DecLimitClamp(var B: Shortint; const Limit: Shortint; const Decr: Shortint = 1): Shortint; overload;\r\nfunction DecLimitClamp(var B: Smallint; const Limit: Smallint; const Decr: Smallint = 1): Smallint; overload;\r\nfunction DecLimitClamp(var B: Word; const Limit: Word; const Decr: Word = 1): Word; overload;\r\nfunction DecLimitClamp(var B: Integer; const Limit: Integer; const Decr: Integer = 1): Integer; overload;\r\nfunction DecLimitClamp(var B: Cardinal; const Limit: Cardinal; const Decr: Cardinal = 1): Cardinal; overload;\r\nfunction DecLimitClamp(var B: Int64; const Limit: Int64; const Decr: Int64 = 1): Int64; overload;\r\n\r\nfunction Max(const B1, B2: Byte): Byte; overload;\r\nfunction Max(const B1, B2: Shortint): Shortint; overload;\r\nfunction Max(const B1, B2: Smallint): Smallint; overload;\r\nfunction Max(const B1, B2: Word): Word; overload;\r\nfunction Max(const B1, B2: Integer): Integer; overload;\r\nfunction Max(const B1, B2: Cardinal): Cardinal; overload;\r\nfunction Max(const B1, B2: Int64): Int64; overload;\r\n\r\nfunction Min(const B1, B2: Byte): Byte; overload;\r\nfunction Min(const B1, B2: Shortint): Shortint; overload;\r\nfunction Min(const B1, B2: Smallint): Smallint; overload;\r\nfunction Min(const B1, B2: Word): Word; overload;\r\nfunction Min(const B1, B2: Integer): Integer; overload;\r\nfunction Min(const B1, B2: Cardinal): Cardinal; overload;\r\nfunction Min(const B1, B2: Int64): Int64; overload;\r\n\r\nconst\r\n // Constants defining the number of bits in each Integer type\r\n\r\n BitsPerNibble = 4;\r\n BitsPerByte = 8;\r\n BitsPerShortint = SizeOf(Shortint) * BitsPerByte;\r\n BitsPerSmallint = SizeOf(Smallint) * BitsPerByte;\r\n BitsPerWord = SizeOf(Word) * BitsPerByte;\r\n BitsPerInteger = SizeOf(Integer) * BitsPerByte;\r\n BitsPerCardinal = SizeOf(Cardinal) * BitsPerByte;\r\n BitsPerInt64 = SizeOf(Int64) * BitsPerByte;\r\n\r\n // Constants defining the number of nibbles in each Integer type\r\n\r\n NibblesPerByte = BitsPerByte div BitsPerNibble;\r\n NibblesPerShortint = SizeOf(Shortint) * NibblesPerByte;\r\n NibblesPerSmallint = SizeOf(Smallint) * NibblesPerByte;\r\n NibblesPerWord = SizeOf(Word) * NibblesPerByte;\r\n NibblesPerInteger = SizeOf(Integer) * NibblesPerByte;\r\n NibblesPerCardinal = SizeOf(Cardinal) * NibblesPerByte;\r\n NibblesPerInt64 = SizeOf(Int64) * NibblesPerByte;\r\n\r\n // Constants defining a mask with all bits set for each Integer type\r\n\r\n NibbleMask = $F;\r\n ByteMask = Byte($FF);\r\n ShortintMask = Shortint($FF);\r\n SmallintMask = Smallint($FFFF);\r\n WordMask = Word($FFFF);\r\n IntegerMask = Integer($FFFFFFFF);\r\n CardinalMask = Cardinal($FFFFFFFF);\r\n Int64Mask = Int64($FFFFFFFFFFFFFFFF);\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jcl.svn.sourceforge.net/svnroot/jcl/tags/JCL-2.4-Build4571/jcl/source/common/JclLogic.pas $';\r\n Revision: '$Revision: 3599 $';\r\n Date: '$Date: 2011-09-03 00:07:50 +0200 (sam. 03 sept. 2011) $';\r\n LogPath: 'JCL\\source\\common';\r\n Extra: '';\r\n Data: nil\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n JclBase;\r\n\r\n// Conversion\r\nfunction OrdToBinary(Value: Byte): string;\r\nvar\r\n I: Integer;\r\nbegin\r\n SetLength(Result, BitsPerByte);\r\n for I := Length(Result) - 1 downto 0 do\r\n begin\r\n Result[I + 1] := Chr(48 + (Value and $00000001));\r\n Value := Value shr 1;\r\n end;\r\nend;\r\n\r\nfunction OrdToBinary(Value: Shortint): string;\r\nvar\r\n I: Integer;\r\nbegin\r\n SetLength(Result, BitsPerShortint);\r\n for I := Length(Result) - 1 downto 0 do\r\n begin\r\n Result[I + 1] := Chr(48 + (Value and $00000001));\r\n Value := Value shr 1;\r\n end;\r\nend;\r\n\r\nfunction OrdToBinary(Value: Smallint): string;\r\nvar\r\n I: Integer;\r\n S: Smallint;\r\nbegin\r\n SetLength(Result, BitsPerSmallint);\r\n S := Value;\r\n for I := Length(Result) - 1 downto 0 do\r\n begin\r\n Result[I + 1] := Chr(48 + (S and $00000001));\r\n S := S shr 1;\r\n end;\r\nend;\r\n\r\nfunction OrdToBinary(Value: Word): string;\r\nvar\r\n I: Integer;\r\nbegin\r\n SetLength(Result, BitsPerWord);\r\n for I := Length(Result) - 1 downto 0 do\r\n begin\r\n Result[I + 1] := Chr(48 + (Value and $00000001));\r\n Value := Value shr 1;\r\n end;\r\nend;\r\n\r\nfunction OrdToBinary(Value: Integer): string;\r\nvar\r\n I: Integer;\r\nbegin\r\n SetLength(Result, BitsPerInteger);\r\n for I := Length(Result) - 1 downto 0 do\r\n begin\r\n Result[I + 1] := Chr(48 + (Value and $00000001));\r\n Value := Value shr 1;\r\n end;\r\nend;\r\n\r\nfunction OrdToBinary(Value: Cardinal): string;\r\nvar\r\n I: Integer;\r\nbegin\r\n SetLength(Result, BitsPerCardinal);\r\n for I := Length(Result) - 1 downto 0 do\r\n begin\r\n Result[I + 1] := Chr(48 + (Value and $00000001));\r\n Value := Value shr 1;\r\n end;\r\nend;\r\n\r\nfunction OrdToBinary(Value: Int64): string;\r\nvar\r\n I: Integer;\r\nbegin\r\n SetLength(Result, BitsPerInt64);\r\n for I := Length(Result) - 1 downto 0 do\r\n begin\r\n Result[I + 1] := Chr(48 + (Value and Int64(1)));\r\n Value := Value shr Int64(1);\r\n end;\r\nend;\r\n\r\n\r\n// Bit manipulation\r\nfunction BitsHighest(X: Cardinal): Integer;\r\nasm\r\n {$IFDEF CPU32}\r\n // --> EAX X\r\n // <-- EAX\r\n MOV ECX, EAX\r\n MOV EAX, -1\r\n BSR EAX, ECX\r\n JNZ @@End\r\n MOV EAX, -1\r\n@@End:\r\n {$ENDIF CPU32}\r\n {$IFDEF CPU64}\r\n // --> ECX X\r\n // <-- RAX\r\n MOV EAX, -1\r\n MOV R10D, EAX\r\n BSR EAX, ECX\r\n CMOVZ EAX, R10D\r\n {$ENDIF CPU64}\r\nend;\r\n\r\nfunction BitsHighest(X: Integer): Integer;\r\nasm\r\n {$IFDEF CPU32}\r\n // --> EAX X\r\n // <-- EAX\r\n MOV ECX, EAX\r\n MOV EAX, -1\r\n BSR EAX, ECX\r\n JNZ @@End\r\n MOV EAX, -1\r\n@@End:\r\n {$ENDIF CPU32}\r\n {$IFDEF CPU64}\r\n // --> ECX X\r\n // <-- RAX\r\n MOV EAX, -1\r\n MOV R10D, EAX\r\n BSR EAX, ECX\r\n CMOVZ EAX, R10D\r\n {$ENDIF CPU64}\r\nend;\r\n\r\nfunction BitsHighest(X: Byte): Integer;\r\nbegin\r\n Result := BitsHighest(Cardinal(X));\r\nend;\r\n\r\nfunction BitsHighest(X: Word): Integer;\r\nbegin\r\n Result := BitsHighest(Cardinal(X));\r\nend;\r\n\r\nfunction BitsHighest(X: SmallInt): Integer;\r\nbegin\r\n Result := BitsHighest(Integer(X));\r\nend;\r\n\r\nfunction BitsHighest(X: ShortInt): Integer;\r\nbegin\r\n Result := BitsHighest(Integer(X));\r\nend;\r\n\r\nfunction BitsHighest(X: Int64): Integer;\r\n{$IFDEF CPU32}\r\nbegin\r\n if TJclULargeInteger(X).HighPart = 0 then\r\n Result := BitsHighest(TJclULargeInteger(X).LowPart)\r\n else\r\n Result := BitsHighest(TJclULargeInteger(X).HighPart) + 32;\r\nend;\r\n{$ENDIF CPU32}\r\n{$IFDEF CPU64}\r\nasm\r\n // --> RCX X\r\n // <-- RAX\r\n\r\n // this is much shorter than \"MOV RAX, -1\"\r\n XOR RAX, RAX\r\n DEC EAX\r\n\r\n MOV R10, RAX\r\n BSR RAX, RCX\r\n CMOVZ RAX, R10\r\nend;\r\n{$ENDIF CPU64}\r\n\r\nfunction BitsLowest(X: Cardinal): Integer;\r\nasm\r\n {$IFDEF CPU32}\r\n // --> EAX X\r\n // <-- EAX\r\n MOV ECX, EAX\r\n MOV EAX, -1\r\n BSF EAX, ECX\r\n JNZ @@End\r\n MOV EAX, -1\r\n@@End:\r\n {$ENDIF CPU32}\r\n {$IFDEF CPU64}\r\n // --> RCX X\r\n // <-- EAX\r\n MOV EAX, -1\r\n MOV R10D, EAX\r\n BSF EAX, ECX\r\n CMOVZ EAX, R10D\r\n {$ENDIF CPU64}\r\nend;\r\n\r\nfunction BitsLowest(X: Integer): Integer;\r\nasm\r\n {$IFDEF CPU32}\r\n // --> EAX X\r\n // <-- EAX\r\n MOV ECX, EAX\r\n MOV EAX, -1\r\n BSF EAX, ECX\r\n JNZ @@End\r\n MOV EAX, -1\r\n@@End:\r\n {$ENDIF CPU32}\r\n {$IFDEF CPU64}\r\n // --> RCX X\r\n // <-- EAX\r\n MOV EAX, -1\r\n MOV R10D, EAX\r\n BSF EAX, ECX\r\n CMOVZ EAX, R10D\r\n {$ENDIF CPU64}\r\nend;\r\n\r\nfunction BitsLowest(X: Byte): Integer;\r\nbegin\r\n Result := BitsLowest(Cardinal(X));\r\nend;\r\n\r\nfunction BitsLowest(X: Shortint): Integer;\r\nbegin\r\n Result := BitsLowest(Integer(X));\r\nend;\r\n\r\nfunction BitsLowest(X: Smallint): Integer;\r\nbegin\r\n Result := BitsLowest(Integer(X));\r\nend;\r\n\r\nfunction BitsLowest(X: Word): Integer;\r\nbegin\r\n Result := BitsLowest(Cardinal(X));\r\nend;\r\n\r\nfunction BitsLowest(X: Int64): Integer;\r\n{$IFDEF CPU32}\r\nbegin\r\n if TJclULargeInteger(X).LowPart = 0 then\r\n Result := BitsLowest(TJclULargeInteger(X).HighPart) + 32\r\n else\r\n Result := BitsLowest(TJclULargeInteger(X).LowPart);\r\nend;\r\n{$ENDIF CPU32}\r\n{$IFDEF CPU64}\r\nasm\r\n // --> RCX X\r\n // <-- RAX\r\n\r\n // this is much shorter than \"MOV RAX, -1\"\r\n XOR RAX, RAX\r\n DEC EAX\r\n\r\n MOV R10, RAX\r\n BSF RAX, RCX\r\n CMOVZ RAX, R10\r\nend;\r\n{$ENDIF CPU64}\r\n\r\nfunction ClearBit(const Value: Byte; const Bit: TBitRange): Byte;\r\nasm\r\n // 32 --> AL Value\r\n // DL Bit\r\n // <-- AL Result\r\n // 64 --> CL Value\r\n // DL Bit\r\n // <-- AL Result\r\n AND EDX, BitsPerByte - 1 // modulo BitsPerByte\r\n {$IFDEF CPU64}\r\n MOVZX EAX, CL\r\n {$ENDIF CPU64}\r\n BTR EAX, EDX\r\nend;\r\n\r\nfunction ClearBit(const Value: Shortint; const Bit: TBitRange): Shortint;\r\nasm\r\n // 32 --> AL Value\r\n // DL Bit\r\n // <-- AL Result\r\n // 64 --> CL Value\r\n // DL Bit\r\n // <-- AL Result\r\n AND EDX, BitsPerShortint - 1 // modulo BitsPerShortint\r\n {$IFDEF CPU64}\r\n MOVZX EAX, CL\r\n {$ENDIF CPU64}\r\n BTR EAX, EDX\r\nend;\r\n\r\nfunction ClearBit(const Value: Smallint; const Bit: TBitRange): Smallint;\r\nasm\r\n // 32 --> AX Value\r\n // DL Bit\r\n // <-- AX Result\r\n // 64 --> CX Value\r\n // DL Bit\r\n // <-- AX Result\r\n AND EDX, BitsPerSmallint - 1 // modulo BitsPerSmallint\r\n {$IFDEF CPU64}\r\n MOVZX EAX, CX\r\n {$ENDIF CPU64}\r\n BTR EAX, EDX\r\nend;\r\n\r\nfunction ClearBit(const Value: Word; const Bit: TBitRange): Word;\r\nasm\r\n // 32 --> AX Value\r\n // DL Bit\r\n // <-- AX Result\r\n // 64 --> CX Value\r\n // DL Bit\r\n // <-- AX Result\r\n AND EDX, BitsPerWord - 1 // modulo BitsPerWord\r\n {$IFDEF CPU64}\r\n MOVZX EAX, CX\r\n {$ENDIF CPU64}\r\n BTR EAX, EDX\r\nend;\r\n\r\nfunction ClearBit(const Value: Cardinal; const Bit: TBitRange): Cardinal;\r\nasm\r\n // 32 --> EAX Value\r\n // DL Bit\r\n // <-- EAX Result\r\n // 64 --> ECX Value\r\n // DL Bit\r\n // <-- EAX Result\r\n {$IFDEF CPU64}\r\n MOV EAX, ECX\r\n {$ENDIF CPU64}\r\n BTR EAX, EDX\r\nend;\r\n\r\nfunction ClearBit(const Value: Integer; const Bit: TBitRange): Integer;\r\nasm\r\n // 32 --> EAX Value\r\n // DL Bit\r\n // <-- EAX Result\r\n // 64 --> ECX Value\r\n // DL Bit\r\n // <-- EAX Result\r\n {$IFDEF CPU64}\r\n MOV EAX, ECX\r\n {$ENDIF CPU64}\r\n BTR EAX, EDX\r\nend;\r\n\r\nfunction ClearBit(const Value: Int64; const Bit: TBitRange): Int64;\r\n{$IFDEF CPU32}\r\nbegin\r\n Result := Value and not (Int64(1) shl (Bit and (BitsPerInt64 - 1)));\r\nend;\r\n{$ENDIF CPU32}\r\n{$IFDEF CPU64}\r\nasm\r\n // --> RCX Value\r\n // DL Bit\r\n // <-- RAX Result\r\n MOV RAX, RCX\r\n BTR RAX, RDX\r\nend;\r\n{$ENDIF CPU64}\r\n\r\nprocedure ClearBitBuffer(var Value; const Bit: Cardinal);\r\n{$IFDEF PUREPASCAL}\r\nvar\r\n P: PByte;\r\n BitOfs: TBitRange;\r\nbegin\r\n P := Addr(Value);\r\n Inc(P, Bit div 8);\r\n BitOfs := Bit mod 8;\r\n P^ := ClearBit(P^, BitOfs);\r\nend;\r\n{$ELSE ~PUREPASCAL}\r\nasm\r\n // 32 --> EAX Value\r\n // EDX Bit\r\n // 64 --> RCX Value\r\n // EDX Bit\r\n BTR [Value], Bit\r\nend;\r\n{$ENDIF ~PUREPASCAL}\r\n\r\n{$IFDEF CPU64}\r\nprocedure ClearBitBuffer(var Value; const Bit: Int64);\r\n{$IFDEF PUREPASCAL}\r\nvar\r\n P: PByte;\r\n BitOfs: TBitRange;\r\nbegin\r\n P := Addr(Value);\r\n Inc(P, Bit div 8);\r\n BitOfs := Bit mod 8;\r\n P^ := ClearBit(P^, BitOfs);\r\nend;\r\n{$ELSE ~PUREPASCAL}\r\nasm\r\n // 64 --> RCX Value\r\n // RDX Bit\r\n BTR [Value], Bit\r\nend;\r\n{$ENDIF ~PUREPASCAL}\r\n{$ENDIF CPU64}\r\n\r\nconst\r\n BitSetPerNibble: array[0..15] of Integer = (0,1,1,2,1,2,2,3,1,2,2,3,2,3,3,4);\r\n\r\nfunction CountBitsSet(X: Cardinal): Integer;\r\nvar\r\n Index: Integer;\r\nbegin\r\n Result := 0;\r\n for Index := 0 to NibblesPerCardinal - 1 do\r\n begin\r\n Inc(Result, BitSetPerNibble[X and $F]);\r\n X := X shr BitsPerNibble;\r\n end;\r\nend;\r\n\r\nfunction CountBitsSet(X: Byte): Integer;\r\nbegin\r\n Result := BitSetPerNibble[X shr BitsPerNibble] + BitSetPerNibble[X and $F];\r\nend;\r\n\r\nfunction CountBitsSet(X: Word): Integer;\r\nvar\r\n Index: Integer;\r\nbegin\r\n Result := 0;\r\n for Index := 0 to NibblesPerWord - 1 do\r\n begin\r\n Inc(Result, BitSetPerNibble[X and $F]);\r\n X := X shr BitsPerNibble;\r\n end;\r\nend;\r\n\r\nfunction CountBitsSet(X: Smallint): Integer;\r\nvar\r\n Index: Integer;\r\nbegin\r\n Result := 0;\r\n for Index := 0 to NibblesPerSmallint - 1 do\r\n begin\r\n Inc(Result, BitSetPerNibble[X and $F]);\r\n X := X shr BitsPerNibble;\r\n end;\r\nend;\r\n\r\nfunction CountBitsSet(X: ShortInt): Integer;\r\nbegin\r\n Result := BitSetPerNibble[X shr BitsPerNibble] + BitSetPerNibble[X and $F];\r\nend;\r\n\r\nfunction CountBitsSet(X: Integer): Integer;\r\nvar\r\n Index: Integer;\r\nbegin\r\n Result := 0;\r\n for Index := 0 to NibblesPerInteger - 1 do\r\n begin\r\n Inc(Result, BitSetPerNibble[X and $F]);\r\n X := X shr BitsPerNibble;\r\n end;\r\nend;\r\n\r\nfunction CountBitsSet(P: Pointer; Count: Cardinal): Cardinal;\r\nvar\r\n b: Byte;\r\nbegin\r\n Result := 0;\r\n while Count > 0 do\r\n begin\r\n b := PByte(P)^;\r\n\r\n // lower Nibble\r\n Inc(Result, BitSetPerNibble[b and $0F]);\r\n // upper Nibble\r\n Inc(Result, BitSetPerNibble[b shr BitsPerNibble]);\r\n\r\n Dec(Count);\r\n Inc(PByte(P));\r\n end;\r\nend;\r\n\r\nfunction CountBitsSet(X: Int64): Integer;\r\nbegin\r\n Result := CountBitsSet(TJclULargeInteger(X).LowPart) + CountBitsSet(TJclULargeInteger(X).HighPart);\r\nend;\r\n\r\nfunction CountBitsCleared(X: Byte): Integer;\r\nbegin\r\n Result := BitsPerByte - CountBitsSet(Byte(X));\r\nend;\r\n\r\nfunction CountBitsCleared(X: Shortint): Integer;\r\nbegin\r\n Result := BitsPerShortint - CountBitsSet(Byte(X));\r\nend;\r\n\r\nfunction CountBitsCleared(X: Smallint): Integer;\r\nbegin\r\n Result := BitsPerSmallint - CountBitsSet(Word(X));\r\nend;\r\n\r\nfunction CountBitsCleared(X: Word): Integer;\r\nbegin\r\n Result := BitsPerWord - CountBitsSet(Word(X));\r\nend;\r\n\r\nfunction CountBitsCleared(X: Integer): Integer;\r\nbegin\r\n Result := BitsPerInteger - CountBitsSet(Integer(X));\r\nend;\r\n\r\nfunction CountBitsCleared(X: Cardinal): Integer;\r\nbegin\r\n Result := BitsPerCardinal - CountBitsSet(Cardinal(X));\r\nend;\r\n\r\nfunction CountBitsCleared(X: Int64): Integer;\r\nbegin\r\n Result := BitsPerInt64 - CountBitsSet(Int64(X));\r\nend;\r\n\r\nfunction CountBitsCleared(P: Pointer; Count: Cardinal): Cardinal;\r\nbegin\r\n Result := Count * BitsPerByte - CountBitsSet(P, Count);\r\nend;\r\n\r\nfunction LRot(const Value: Byte; const Count: TBitRange): Byte;\r\nasm\r\n {$IFDEF CPU32}\r\n // --> AL Value\r\n // DL Count\r\n // <-- AL Result\r\n MOV CL, DL\r\n ROL AL, CL\r\n {$ENDIF CPU32}\r\n {$IFDEF CPU64}\r\n // --> CL Value\r\n // DL Count\r\n // <-- AL Result\r\n MOV AL, CL\r\n MOV CL, DL\r\n ROL AL, CL\r\n {$ENDIF CPU64}\r\nend;\r\n\r\nfunction LRot(const Value: Word; const Count: TBitRange): Word;\r\nasm\r\n {$IFDEF CPU32}\r\n // --> AX Value\r\n // DL Count\r\n // <-- AX Result\r\n MOV CL, DL\r\n ROL AX, CL\r\n {$ENDIF CPU32}\r\n {$IFDEF CPU64}\r\n // --> CX Value\r\n // DL Count\r\n // <-- AX Result\r\n MOV AX, CX\r\n MOV CL, DL\r\n ROL AX, CL\r\n {$ENDIF CPU64}\r\nend;\r\n\r\nfunction LRot(const Value: Integer; const Count: TBitRange): Integer;\r\nasm\r\n {$IFDEF CPU32}\r\n // --> EAX Value\r\n // DL Count\r\n // <-- EAX Result\r\n MOV CL, DL\r\n ROL EAX, CL\r\n {$ENDIF CPU32}\r\n {$IFDEF CPU64}\r\n // --> ECX Value\r\n // DL Count\r\n // <-- EAX Result\r\n MOV EAX, ECX\r\n MOV CL, DL\r\n ROL EAX, CL\r\n {$ENDIF CPU64}\r\nend;\r\n\r\nfunction LRot(const Value: Int64; const Count: TBitRange): Int64;\r\n{$IFDEF CPU32}\r\nasm\r\n // --> Value on stack\r\n // AL Count\r\n // <-- EDX:EAX Result\r\n\r\n PUSH ESI\r\n PUSH EDI\r\n\r\n MOV CL, Count\r\n MOV EDX, DWORD PTR [Value + 4]\r\n MOV EAX, DWORD PTR [Value]\r\n\r\n // Count := Count mod 64\r\n AND CL, $3F\r\n JZ @@End\r\n\r\n CMP CL, 32\r\n JL @@RolBits\r\n\r\n // Count >= 32: \"rol Count\" = \"rol 32\" + \"rol (32 - Count)\"\r\n@@Swap:\r\n // \"rol 32\"\r\n XCHG EAX, EDX\r\n // Count := 32 - Count\r\n SUB CL, 32\r\n\r\n@@RolBits:\r\n MOV EDI, EDX\r\n MOV ESI, EAX\r\n\r\n // shift the bits\r\n SHL EDX, CL\r\n SHL EAX, CL\r\n\r\n // CounterShiftCount := 32 - Count\r\n NEG CL\r\n ADD CL, 32\r\n // bitwise-or the counter shifted bits\r\n SHR EDI, CL\r\n SHR ESI, CL\r\n OR EAX, EDI\r\n OR EDX, ESI\r\n\r\n@@End:\r\n POP EDI\r\n POP ESI\r\nend;\r\n{$ENDIF CPU32}\r\n{$IFDEF CPU64}\r\nasm\r\n // --> RCX Value\r\n // DL Count\r\n // <-- RAX Result\r\n MOV RAX, RCX\r\n MOV CL, DL\r\n ROL RAX, CL\r\nend;\r\n{$ENDIF CPU64}\r\n\r\nfunction RRot(const Value: Int64; const Count: TBitRange): Int64;\r\n{$IFDEF CPU32}\r\nbegin\r\n Result := LRot(Value, 64 - (Count and $3F));\r\nend;\r\n{$ENDIF CPU32}\r\n{$IFDEF CPU64}\r\nasm\r\n // --> RCX Value\r\n // DL Count\r\n // <-- RAX Result\r\n MOV RAX, RCX\r\n MOV CL, DL\r\n ROR RAX, CL\r\nend;\r\n{$ENDIF CPU64}\r\n\r\nconst\r\n // Lookup table of bit reversed nibbles, used by simple overloads of ReverseBits\r\n RevNibbles: array [0..NibbleMask] of Byte =\r\n ($0, $8, $4, $C, $2, $A, $6, $E, $1, $9, $5, $D, $3, $B, $7, $F);\r\n\r\nfunction ReverseBits(Value: Byte): Byte;\r\nbegin\r\n Result := RevNibbles[Value shr BitsPerNibble] or\r\n (RevNibbles[Value and NibbleMask] shl BitsPerNibble);\r\nend;\r\n\r\nfunction ReverseBits(Value: Shortint): Shortint;\r\nbegin\r\n Result := RevNibbles[Byte(Value) shr BitsPerNibble] or\r\n (RevNibbles[Value and NibbleMask] shl BitsPerNibble);\r\nend;\r\n\r\nfunction ReverseBits(Value: Smallint): Smallint;\r\nbegin\r\n Result := ReverseBits(Word(Value));\r\nend;\r\n\r\nfunction ReverseBits(Value: Word): Word;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := 0;\r\n for I := 0 to NibblesPerWord - 1 do\r\n begin\r\n Result := (Result shl BitsPerNibble) or RevNibbles[Value and NibbleMask];\r\n Value := Value shr BitsPerNibble;\r\n end;\r\nend;\r\n\r\nfunction ReverseBits(Value: Integer): Integer;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := 0;\r\n for I := 0 to NibblesPerInteger - 1 do\r\n begin\r\n Result := (Result shl BitsPerNibble) or RevNibbles[Value and NibbleMask];\r\n Value := Value shr BitsPerNibble;\r\n end;\r\nend;\r\n\r\nfunction ReverseBits(Value: Cardinal): Cardinal;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := 0;\r\n for I := 0 to NibblesPerCardinal - 1 do\r\n begin\r\n Result := (Result shl BitsPerNibble) or RevNibbles[Value and NibbleMask];\r\n Value := Value shr BitsPerNibble;\r\n end;\r\nend;\r\n\r\nfunction ReverseBits(Value: Int64): Int64;\r\nbegin\r\n TJclULargeInteger(Result).LowPart := ReverseBits(TJclULargeInteger(Value).HighPart);\r\n TJclULargeInteger(Result).HighPart := ReverseBits(TJclULargeInteger(Value).LowPart);\r\nend;\r\n\r\nconst\r\n // Lookup table of reversed bytes, used by pointer overload of ReverseBits\r\n ReverseTable: array [0..ByteMask] of Byte = (\r\n $00, $80, $40, $C0, $20, $A0, $60, $E0,\r\n $10, $90, $50, $D0, $30, $B0, $70, $F0,\r\n $08, $88, $48, $C8, $28, $A8, $68, $E8,\r\n $18, $98, $58, $D8, $38, $B8, $78, $F8,\r\n $04, $84, $44, $C4, $24, $A4, $64, $E4,\r\n $14, $94, $54, $D4, $34, $B4, $74, $F4,\r\n $0C, $8C, $4C, $CC, $2C, $AC, $6C, $EC,\r\n $1C, $9C, $5C, $DC, $3C, $BC, $7C, $FC,\r\n $02, $82, $42, $C2, $22, $A2, $62, $E2,\r\n $12, $92, $52, $D2, $32, $B2, $72, $F2,\r\n $0A, $8A, $4A, $CA, $2A, $AA, $6A, $EA,\r\n $1A, $9A, $5A, $DA, $3A, $BA, $7A, $FA,\r\n $06, $86, $46, $C6, $26, $A6, $66, $E6,\r\n $16, $96, $56, $D6, $36, $B6, $76, $F6,\r\n $0E, $8E, $4E, $CE, $2E, $AE, $6E, $EE,\r\n $1E, $9E, $5E, $DE, $3E, $BE, $7E, $FE,\r\n $01, $81, $41, $C1, $21, $A1, $61, $E1,\r\n $11, $91, $51, $D1, $31, $B1, $71, $F1,\r\n $09, $89, $49, $C9, $29, $A9, $69, $E9,\r\n $19, $99, $59, $D9, $39, $B9, $79, $F9,\r\n $05, $85, $45, $C5, $25, $A5, $65, $E5,\r\n $15, $95, $55, $D5, $35, $B5, $75, $F5,\r\n $0D, $8D, $4D, $CD, $2D, $AD, $6D, $ED,\r\n $1D, $9D, $5D, $DD, $3D, $BD, $7D, $FD,\r\n $03, $83, $43, $C3, $23, $A3, $63, $E3,\r\n $13, $93, $53, $D3, $33, $B3, $73, $F3,\r\n $0B, $8B, $4B, $CB, $2B, $AB, $6B, $EB,\r\n $1B, $9B, $5B, $DB, $3B, $BB, $7B, $FB,\r\n $07, $87, $47, $C7, $27, $A7, $67, $E7,\r\n $17, $97, $57, $D7, $37, $B7, $77, $F7,\r\n $0F, $8F, $4F, $CF, $2F, $AF, $6F, $EF,\r\n $1F, $9F, $5F, $DF, $3F, $BF, $7F, $FF);\r\n\r\nfunction ReverseBits(P: Pointer; Count: Integer): Pointer;\r\nvar\r\n P1, P2: PByte;\r\n T: Byte;\r\nbegin\r\n if (P <> nil) and (Count > 0) then\r\n begin\r\n P1 := P;\r\n P2 := P;\r\n Inc(P2, Count - 1);\r\n while TJclAddr(P1) < TJclAddr(P2) do\r\n begin\r\n T := ReverseTable[P1^];\r\n P1^ := ReverseTable[P2^];\r\n P2^ := T;\r\n Inc(P1);\r\n Dec(P2);\r\n end;\r\n if P1 = P2 then\r\n P1^ := ReverseTable[P1^];\r\n end;\r\n Result := P;\r\nend;\r\n\r\nfunction RRot(const Value: Byte; const Count: TBitRange): Byte;\r\nasm\r\n {$IFDEF CPU32}\r\n // --> AL Value\r\n // DL Count\r\n // <-- AL Result\r\n MOV CL, DL\r\n ROR AL, CL\r\n {$ENDIF CPU32}\r\n {$IFDEF CPU64}\r\n // --> CL Value\r\n // DL Count\r\n // <-- AL Result\r\n MOV AL, CL\r\n MOV CL, DL\r\n ROR AL, CL\r\n {$ENDIF CPU64}\r\nend;\r\n\r\nfunction RRot(const Value: Word; const Count: TBitRange): Word;\r\nasm\r\n {$IFDEF CPU32}\r\n // --> AX Value\r\n // DL Count\r\n // <-- AX Result\r\n MOV CL, DL\r\n ROR AX, CL\r\n {$ENDIF CPU32}\r\n {$IFDEF CPU64}\r\n // --> CX Value\r\n // DL Count\r\n // <-- AX Result\r\n MOV AX, CX\r\n MOV CL, DL\r\n ROR AX, CL\r\n {$ENDIF CPU64}\r\nend;\r\n\r\nfunction RRot(const Value: Integer; const Count: TBitRange): Integer;\r\nasm\r\n {$IFDEF CPU32}\r\n // --> EAX Value\r\n // DL Count\r\n // <-- EAX Result\r\n MOV CL, DL\r\n ROR EAX, CL\r\n {$ENDIF CPU32}\r\n {$IFDEF CPU64}\r\n // --> ECX Value\r\n // DL Count\r\n // <-- EAX Result\r\n MOV EAX, ECX\r\n MOV CL, DL\r\n ROR EAX, CL\r\n {$ENDIF CPU64}\r\nend;\r\n\r\nfunction Sar(const Value: Shortint; const Count: TBitRange): Shortint;\r\nasm\r\n {$IFDEF CPU32}\r\n // --> AL Value\r\n // DL Count\r\n // <-- AL Result\r\n MOV CL, DL\r\n SAR AL, CL\r\n {$ENDIF CPU32}\r\n {$IFDEF CPU64}\r\n // --> CL Value\r\n // DL Count\r\n // <-- AL Result\r\n MOV AL, CL\r\n MOV CL, DL\r\n SAR AL, CL\r\n {$ENDIF CPU64}\r\nend;\r\n\r\nfunction Sar(const Value: Smallint; const Count: TBitRange): Smallint;\r\nasm\r\n {$IFDEF CPU32}\r\n // --> AX Value\r\n // DL Count\r\n // <-- AX Result\r\n MOV CL, DL\r\n SAR AX, CL\r\n {$ENDIF CPU32}\r\n {$IFDEF CPU64}\r\n // --> CX Value\r\n // DL Count\r\n // <-- AX Result\r\n MOV AX, CX\r\n MOV CL, DL\r\n SAR AX, CL\r\n {$ENDIF CPU64}\r\nend;\r\n\r\nfunction Sar(const Value: Integer; const Count: TBitRange): Integer;\r\nasm\r\n {$IFDEF CPU32}\r\n // --> EAX Value\r\n // DL Count\r\n // <-- EAX Result\r\n MOV CL, DL\r\n SAR EAX, CL\r\n {$ENDIF CPU32}\r\n {$IFDEF CPU64}\r\n // --> ECX Value\r\n // DL Count\r\n // <-- EAX Result\r\n MOV EAX, ECX\r\n MOV CL, DL\r\n SAR EAX, CL\r\n {$ENDIF CPU64}\r\nend;\r\n\r\nfunction SetBit(const Value: Byte; const Bit: TBitRange): Byte;\r\nasm\r\n // 32 --> AL Value\r\n // DL Bit\r\n // <-- AL Result\r\n // 64 --> CL Value\r\n // DL Bit\r\n // <-- AL Result\r\n AND EDX, BitsPerByte - 1 // modulo BitsPerByte\r\n {$IFDEF CPU64}\r\n MOVZX EAX, CL\r\n {$ENDIF CPU64}\r\n BTS EAX, EDX\r\nend;\r\n\r\nfunction SetBit(const Value: Shortint; const Bit: TBitRange): Shortint;\r\nasm\r\n // 32 --> AL Value\r\n // DL Bit\r\n // <-- AL Result\r\n // 64 --> CL Value\r\n // DL Bit\r\n // <-- AL Result\r\n AND EDX, BitsPerShortInt - 1 // modulo BitsPerShortInt\r\n {$IFDEF CPU64}\r\n MOVZX EAX, CL\r\n {$ENDIF CPU64}\r\n BTS EAX, EDX\r\nend;\r\n\r\nfunction SetBit(const Value: Smallint; const Bit: TBitRange): Smallint;\r\nasm\r\n // 32 --> AX Value\r\n // DL Bit\r\n // <-- AX Result\r\n // 64 --> CX Value\r\n // DL Bit\r\n // <-- AX Result\r\n AND EDX, BitsPerSmallInt - 1 // modulo BitsPerSmallInt\r\n {$IFDEF CPU64}\r\n MOVZX EAX, CX\r\n {$ENDIF CPU64}\r\n BTS EAX, EDX\r\nend;\r\n\r\nfunction SetBit(const Value: Word; const Bit: TBitRange): Word;\r\nasm\r\n // 32 --> AX Value\r\n // DL Bit\r\n // <-- AX Result\r\n // 64 --> CX Value\r\n // DL Bit\r\n // <-- AX Result\r\n AND EDX, BitsPerWord - 1 // modulo BitsPerWord\r\n {$IFDEF CPU64}\r\n MOVZX EAX, CX\r\n {$ENDIF CPU64}\r\n BTS EAX, EDX\r\nend;\r\n\r\nfunction SetBit(const Value: Cardinal; const Bit: TBitRange): Cardinal;\r\nasm\r\n // 32 --> EAX Value\r\n // DL Bit\r\n // <-- EAX Result\r\n // 64 --> ECX Value\r\n // DL Bit\r\n // <-- EAX Result\r\n {$IFDEF CPU64}\r\n MOV EAX, ECX\r\n {$ENDIF CPU64}\r\n BTS EAX, EDX\r\nend;\r\n\r\nfunction SetBit(const Value: Integer; const Bit: TBitRange): Integer;\r\nasm\r\n // 32 --> EAX Value\r\n // DL Bit\r\n // <-- EAX Result\r\n // 64 --> ECX Value\r\n // DL Bit\r\n // <-- EAX Result\r\n {$IFDEF CPU64}\r\n MOV EAX, ECX\r\n {$ENDIF CPU64}\r\n BTS EAX, EDX\r\nend;\r\n\r\nfunction SetBit(const Value: Int64; const Bit: TBitRange): Int64;\r\n{$IFDEF CPU32}\r\nbegin\r\n Result := Value or (Int64(1) shl (Bit and (BitsPerInt64 - 1)));\r\nend;\r\n{$ENDIF CPU32}\r\n{$IFDEF CPU64}\r\nasm\r\n // --> RCX Value\r\n // DL Bit\r\n // <-- RAX Result\r\n MOV RAX, RCX\r\n BTS RAX, RDX\r\nend;\r\n{$ENDIF CPU64}\r\n\r\nprocedure SetBitBuffer(var Value; const Bit: Cardinal);\r\n{$IFDEF PUREPASCAL}\r\nvar\r\n P: PByte;\r\n BitOfs: TBitRange;\r\nbegin\r\n P := Addr(Value);\r\n Inc(P, Bit div 8);\r\n BitOfs := Bit mod 8;\r\n P^ := SetBit(P^, BitOfs);\r\nend;\r\n{$ELSE ~PUREPASCAL}\r\nasm\r\n BTS [Value], Bit\r\nend;\r\n{$ENDIF ~PUREPASCAL}\r\n\r\n{$IFDEF CPU64}\r\nprocedure SetBitBuffer(var Value; const Bit: Int64);\r\n{$IFDEF PUREPASCAL}\r\nvar\r\n P: PByte;\r\n BitOfs: TBitRange;\r\nbegin\r\n P := Addr(Value);\r\n Inc(P, Bit div 8);\r\n BitOfs := Bit mod 8;\r\n P^ := SetBit(P^, BitOfs);\r\nend;\r\n{$ELSE ~PUREPASCAL}\r\nasm\r\n BTS [Value], Bit\r\nend;\r\n{$ENDIF ~PUREPASCAL}\r\n{$ENDIF CPU64}\r\n\r\nfunction TestBit(const Value: Byte; const Bit: TBitRange): Boolean;\r\n{$IFDEF PUREPASCAL}\r\nbegin\r\n Result := (Value shr (Bit and (BitsPerByte - 1))) and 1 <> 0;\r\nend;\r\n{$ELSE ~PUREPASCAL}\r\nasm\r\n // 32 --> AL Value\r\n // DL Bit\r\n // <-- AL Result\r\n // 64 --> CL Value\r\n // DL Bit\r\n // <-- AL Result\r\n AND EDX, BitsPerByte - 1 // modulo BitsPerByte\r\n {$IFDEF CPU64}\r\n MOVZX EAX, CL\r\n {$ENDIF CPU64}\r\n BT EAX, EDX\r\n SETC AL\r\nend;\r\n{$ENDIF ~PUREPASCAL}\r\n\r\nfunction TestBit(const Value: Shortint; const Bit: TBitRange): Boolean;\r\n{$IFDEF PUREPASCAL}\r\nbegin\r\n Result := (Value shr (Bit and (BitsPerShortint - 1))) and 1 <> 0;\r\nend;\r\n{$ELSE ~PUREPASCAL}\r\nasm\r\n // 32 --> AL Value\r\n // DL Bit\r\n // <-- AL Result\r\n // 64 --> CL Value\r\n // DL Bit\r\n // <-- AL Result\r\n AND EDX, BitsPerShortInt - 1 // modulo BitsPerShortInt\r\n {$IFDEF CPU64}\r\n MOVZX EAX, CL\r\n {$ENDIF CPU64}\r\n BT EAX, EDX\r\n SETC AL\r\nend;\r\n{$ENDIF ~PUREPASCAL}\r\n\r\nfunction TestBit(const Value: Smallint; const Bit: TBitRange): Boolean;\r\n{$IFDEF PUREPASCAL}\r\nbegin\r\n Result := (Value shr (Bit and (BitsPerSmallint - 1))) and 1 <> 0;\r\nend;\r\n{$ELSE ~PUREPASCAL}\r\nasm\r\n // 32 --> AX Value\r\n // DL Bit\r\n // <-- AX Result\r\n // 64 --> CX Value\r\n // DL Bit\r\n // <-- AX Result\r\n AND EDX, BitsPerSmallInt - 1 // modulo BitsPerSmallInt\r\n {$IFDEF CPU64}\r\n MOVZX EAX, CX\r\n {$ENDIF CPU64}\r\n BT EAX, EDX\r\n SETC AL\r\nend;\r\n{$ENDIF ~PUREPASCAL}\r\n\r\nfunction TestBit(const Value: Word; const Bit: TBitRange): Boolean;\r\n{$IFDEF PUREPASCAL}\r\nbegin\r\n Result := (Value shr (Bit and (BitsPerWord - 1))) and 1 <> 0;\r\nend;\r\n{$ELSE ~PUREPASCAL}\r\nasm\r\n // 32 --> AX Value\r\n // DL Bit\r\n // <-- AX Result\r\n // 64 --> CX Value\r\n // DL Bit\r\n // <-- AX Result\r\n AND EDX, BitsPerWord - 1 // modulo BitsPerWord\r\n {$IFDEF CPU64}\r\n MOVZX EAX, CX\r\n {$ENDIF CPU64}\r\n BT EAX, EDX\r\n SETC AL\r\nend;\r\n{$ENDIF ~PUREPASCAL}\r\n\r\nfunction TestBit(const Value: Cardinal; const Bit: TBitRange): Boolean;\r\n{$IFDEF PUREPASCAL}\r\nbegin\r\n Result := (Value shr (Bit and (BitsPerCardinal - 1))) and 1 <> 0;\r\nend;\r\n{$ELSE ~PUREPASCAL}\r\nasm\r\n // 32 --> EAX Value\r\n // DL Bit\r\n // <-- EAX Result\r\n // 64 --> ECX Value\r\n // DL Bit\r\n // <-- EAX Result\r\n {$IFDEF CPU64}\r\n MOV EAX, ECX\r\n {$ENDIF CPU64}\r\n BT EAX, EDX\r\n SETC AL\r\nend;\r\n{$ENDIF ~PUREPASCAL}\r\n\r\nfunction TestBit(const Value: Integer; const Bit: TBitRange): Boolean;\r\n{$IFDEF PUREPASCAL}\r\nbegin\r\n Result := (Value shr (Bit and (BitsPerInteger - 1))) and 1 <> 0;\r\nend;\r\n{$ELSE ~PUREPASCAL}\r\nasm\r\n // 32 --> EAX Value\r\n // DL Bit\r\n // <-- EAX Result\r\n // 64 --> ECX Value\r\n // DL Bit\r\n // <-- EAX Result\r\n {$IFDEF CPU64}\r\n MOV EAX, ECX\r\n {$ENDIF CPU64}\r\n BT EAX, EDX\r\n SETC AL\r\nend;\r\n{$ENDIF ~PUREPASCAL}\r\n\r\nfunction TestBit(const Value: Int64; const Bit: TBitRange): Boolean;\r\n{$IFDEF CPU32}\r\nbegin\r\n Result := (Value shr (Bit and (BitsPerInt64 - 1))) and 1 <> 0;\r\nend;\r\n{$ENDIF CPU32}\r\n{$IFDEF CPU64}\r\nasm\r\n // --> RCX Value\r\n // DL Bit\r\n // <-- RAX Result\r\n MOV RAX, RCX\r\n BT RAX, RDX\r\n SETC AL\r\nend;\r\n{$ENDIF ~PUREPASCAL}\r\n\r\nfunction TestBitBuffer(const Value; const Bit: Cardinal): Boolean;\r\n{$IFDEF PUREPASCAL}\r\nvar\r\n P: PByte;\r\n BitOfs: TBitRange;\r\nbegin\r\n P := Addr(Value);\r\n Inc(P, Bit div 8);\r\n BitOfs := Bit mod 8;\r\n Result := TestBit(P^, BitOfs);\r\nend;\r\n{$ELSE ~PUREPASCAL}\r\nasm\r\n BT [Value], Bit\r\n SETC AL\r\nend;\r\n{$ENDIF ~PUREPASCAL}\r\n\r\n{$IFDEF CPU64}\r\nfunction TestBitBuffer(const Value; const Bit: Int64): Boolean;\r\n{$IFDEF PUREPASCAL}\r\nvar\r\n P: PByte;\r\n BitOfs: TBitRange;\r\nbegin\r\n P := Addr(Value);\r\n Inc(P, Bit div 8);\r\n BitOfs := Bit mod 8;\r\n Result := TestBit(P^, BitOfs);\r\nend;\r\n{$ELSE ~PUREPASCAL}\r\nasm\r\n BT [Value], Bit\r\n SETC AL\r\nend;\r\n{$ENDIF ~PUREPASCAL}\r\n{$ENDIF CPU64}\r\n\r\nfunction TestBits(const Value, Mask: Byte): Boolean;\r\nbegin\r\n Result := (Value and Mask) = Mask;\r\nend;\r\n\r\nfunction TestBits(const Value, Mask: Shortint): Boolean;\r\nbegin\r\n Result := (Value and Mask) = Mask;\r\nend;\r\n\r\nfunction TestBits(const Value, Mask: Smallint): Boolean;\r\nbegin\r\n Result := (Value and Mask) = Mask;\r\nend;\r\n\r\nfunction TestBits(const Value, Mask: Word): Boolean;\r\nbegin\r\n Result := (Value and Mask) = Mask;\r\nend;\r\n\r\nfunction TestBits(const Value, Mask: Cardinal): Boolean;\r\nbegin\r\n Result := (Value and Mask) = Mask;\r\nend;\r\n\r\nfunction TestBits(const Value, Mask: Integer): Boolean;\r\nbegin\r\n Result := (Value and Mask) = Mask;\r\nend;\r\n\r\nfunction TestBits(const Value, Mask: Int64): Boolean;\r\nbegin\r\n Result := (Value and Mask) = Mask;\r\nend;\r\n\r\nfunction ToggleBit(const Value: Byte; const Bit: TBitRange): Byte;\r\n{$IFDEF PUREPASCAL}\r\nbegin\r\n Result := Value xor (1 shl (Bit and (BitsPerByte - 1)));\r\nend;\r\n{$ELSE ~PUREPASCAL}\r\nasm\r\n // 32 --> AL Value\r\n // DL Bit\r\n // <-- AL Result\r\n // 64 --> CL Value\r\n // DL Bit\r\n // <-- AL Result\r\n AND EDX, BitsPerByte - 1 // modulo BitsPerByte\r\n {$IFDEF CPU64}\r\n MOVZX EAX, CL\r\n {$ENDIF CPU64}\r\n BTC EAX, EDX\r\nend;\r\n{$ENDIF ~PUREPASCAL}\r\n\r\nfunction ToggleBit(const Value: Shortint; const Bit: TBitRange): Shortint;\r\n{$IFDEF PUREPASCAL}\r\nbegin\r\n Result := Value xor (1 shl (Bit and (BitsPerShortint - 1)));\r\nend;\r\n{$ELSE ~PUREPASCAL}\r\nasm\r\n // 32 --> AL Value\r\n // DL Bit\r\n // <-- AL Result\r\n // 64 --> CL Value\r\n // DL Bit\r\n // <-- AL Result\r\n AND EDX, BitsPerShortInt - 1 // modulo BitsPerShortInt\r\n {$IFDEF CPU64}\r\n MOVZX EAX, CL\r\n {$ENDIF CPU64}\r\n BTC EAX, EDX\r\nend;\r\n{$ENDIF ~PUREPASCAL}\r\n\r\nfunction ToggleBit(const Value: Smallint; const Bit: TBitRange): Smallint;\r\n{$IFDEF PUREPASCAL}\r\nbegin\r\n Result := Value xor (1 shl (Bit and (BitsPerSmallint - 1)));\r\nend;\r\n{$ELSE ~PUREPASCAL}\r\nasm\r\n // 32 --> AX Value\r\n // DL Bit\r\n // <-- AX Result\r\n // 64 --> CX Value\r\n // DL Bit\r\n // <-- AX Result\r\n AND EDX, BitsPerSmallInt - 1 // modulo BitsPerSmallInt\r\n {$IFDEF CPU64}\r\n MOVZX EAX, CX\r\n {$ENDIF CPU64}\r\n BTC EAX, EDX\r\nend;\r\n{$ENDIF ~PUREPASCAL}\r\n\r\nfunction ToggleBit(const Value: Word; const Bit: TBitRange): Word;\r\n{$IFDEF PUREPASCAL}\r\nbegin\r\n Result := Value xor (1 shl (Bit and (BitsPerWord - 1)));\r\nend;\r\n{$ELSE ~PUREPASCAL}\r\nasm\r\n // 32 --> AX Value\r\n // DL Bit\r\n // <-- AX Result\r\n // 64 --> CX Value\r\n // DL Bit\r\n // <-- AX Result\r\n AND EDX, BitsPerWord - 1 // modulo BitsPerWord\r\n {$IFDEF CPU64}\r\n MOVZX EAX, CX\r\n {$ENDIF CPU64}\r\n BTC EAX, EDX\r\nend;\r\n{$ENDIF ~PUREPASCAL}\r\n\r\nfunction ToggleBit(const Value: Cardinal; const Bit: TBitRange): Cardinal;\r\n{$IFDEF PUREPASCAL}\r\nbegin\r\n Result := Value xor (1 shl (Bit and (BitsPerCardinal - 1)));\r\nend;\r\n{$ELSE ~PUREPASCAL}\r\nasm\r\n // 32 --> EAX Value\r\n // DL Bit\r\n // <-- EAX Result\r\n // 64 --> ECX Value\r\n // DL Bit\r\n // <-- EAX Result\r\n {$IFDEF CPU64}\r\n MOV EAX, ECX\r\n {$ENDIF CPU64}\r\n BTC EAX, EDX\r\nend;\r\n{$ENDIF ~PUREPASCAL}\r\n\r\nfunction ToggleBit(const Value: Integer; const Bit: TBitRange): Integer;\r\n{$IFDEF PUREPASCAL}\r\nbegin\r\n Result := Value xor (1 shl (Bit and (BitsPerInteger - 1)));\r\nend;\r\n{$ELSE ~PUREPASCAL}\r\nasm\r\n // 32 --> EAX Value\r\n // DL Bit\r\n // <-- EAX Result\r\n // 64 --> ECX Value\r\n // DL Bit\r\n // <-- EAX Result\r\n {$IFDEF CPU64}\r\n MOV EAX, ECX\r\n {$ENDIF CPU64}\r\n BTC EAX, EDX\r\nend;\r\n{$ENDIF ~PUREPASCAL}\r\n\r\nfunction ToggleBit(const Value: Int64; const Bit: TBitRange): Int64;\r\n{$IFDEF CPU32}\r\nbegin\r\n Result := Value xor (Int64(1) shl (Bit and (BitsPerInt64 - 1)));\r\nend;\r\n{$ENDIF CPU32}\r\n{$IFDEF CPU64}\r\nasm\r\n // --> RCX Value\r\n // DL Bit\r\n // <-- RAX Result\r\n MOV RAX, RCX\r\n BTC RAX, RDX\r\nend;\r\n{$ENDIF CPU64}\r\n\r\nprocedure ToggleBitBuffer(var Value; const Bit: Cardinal);\r\n{$IFDEF PUREPASCAL}\r\nvar\r\n P: PByte;\r\n BitOfs: TBitRange;\r\nbegin\r\n P := Addr(Value);\r\n Inc(P, Bit div 8);\r\n BitOfs := Bit mod 8;\r\n P^ := ToggleBit(P^, BitOfs);\r\nend;\r\n{$ELSE ~PUREPASCAL}\r\nasm\r\n BTC [Value], Bit\r\nend;\r\n{$ENDIF ~PUREPASCAL}\r\n\r\n{$IFDEF CPU64}\r\nprocedure ToggleBitBuffer(var Value; const Bit: Int64);\r\n{$IFDEF PUREPASCAL}\r\nvar\r\n P: PByte;\r\n BitOfs: TBitRange;\r\nbegin\r\n P := Addr(Value);\r\n Inc(P, Bit div 8);\r\n BitOfs := Bit mod 8;\r\n P^ := ToggleBit(P^, BitOfs);\r\nend;\r\n{$ELSE ~PUREPASCAL}\r\nasm\r\n BTC [Value], Bit\r\nend;\r\n{$ENDIF ~PUREPASCAL}\r\n{$ENDIF CPU64}\r\n\r\nprocedure BooleansToBits(var Dest: Byte; const B: TBooleanArray);\r\nvar\r\n I, H: Integer;\r\nbegin\r\n Dest := 0;\r\n H := Min(Byte(BitsPerByte - 1), High(B));\r\n for I := 0 to H do\r\n if B[I] then\r\n Dest := SetBit(Dest, TBitRange(I));\r\nend;\r\n\r\nprocedure BooleansToBits(var Dest: Word; const B: TBooleanArray);\r\nvar\r\n I, H: Integer;\r\nbegin\r\n Dest := 0;\r\n H := Min(Word(BitsPerWord - 1), High(B));\r\n for I := 0 to H do\r\n if B[I] then\r\n Dest := SetBit(Dest, TBitRange(I));\r\nend;\r\n\r\nprocedure BooleansToBits(var Dest: Integer; const B: TBooleanArray);\r\nvar\r\n I, H: Integer;\r\nbegin\r\n Dest := 0;\r\n H := Min(Integer(BitsPerInteger - 1), High(B));\r\n for I := 0 to H do\r\n if B[I] then\r\n Dest := SetBit(Dest, TBitRange(I));\r\nend;\r\n\r\nprocedure BooleansToBits(var Dest: Int64; const B: TBooleanArray);\r\nvar\r\n I, H: Integer;\r\nbegin\r\n Dest := 0;\r\n H := Min(Int64(BitsPerInt64 - 1), High(B));\r\n for I := 0 to H do\r\n if B[I] then\r\n Dest := SetBit(Dest, TBitRange(I));\r\nend;\r\n\r\nprocedure BitsToBooleans(const Bits: Byte; var B: TBooleanArray; AllBits: Boolean);\r\nvar\r\n I: Integer;\r\nbegin\r\n if AllBits then\r\n SetLength(B, BitsPerByte)\r\n else\r\n SetLength(B, BitsNeeded(Bits));\r\n for I := 0 to High(B) do\r\n B[I] := TestBit(Bits, TBitRange(I));\r\nend;\r\n\r\nprocedure BitsToBooleans(const Bits: Word; var B: TBooleanArray; AllBits: Boolean);\r\nvar\r\n I: Integer;\r\nbegin\r\n if AllBits then\r\n SetLength(B, BitsPerWord)\r\n else\r\n SetLength(B, BitsNeeded(Bits));\r\n for I := 0 to High(B) do\r\n B[I] := TestBit(Bits, TBitRange(I));\r\nend;\r\n\r\nprocedure BitsToBooleans(const Bits: Integer; var B: TBooleanArray; AllBits: Boolean);\r\nvar\r\n I: Integer;\r\nbegin\r\n if AllBits then\r\n SetLength(B, BitsPerInteger)\r\n else\r\n SetLength(B, BitsNeeded(Bits));\r\n for I := 0 to High(B) do\r\n B[I] := TestBit(Bits, TBitRange(I));\r\nend;\r\n\r\nprocedure BitsToBooleans(const Bits: Int64; var B: TBooleanArray; AllBits: Boolean);\r\nvar\r\n I: Integer;\r\nbegin\r\n if AllBits then\r\n SetLength(B, BitsPerInt64)\r\n else\r\n SetLength(B, BitsNeeded(Bits));\r\n for I := 0 to High(B) do\r\n B[I] := TestBit(Bits, TBitRange(I));\r\nend;\r\n\r\nfunction Digits(const X: Cardinal): Integer;\r\nvar\r\n Val: Cardinal;\r\nbegin\r\n Result := 0;\r\n Val := X;\r\n repeat\r\n Inc(Result);\r\n Val := Val div 10;\r\n until Val = 0;\r\nend;\r\n\r\nfunction BitsNeeded(const X: Byte): Integer;\r\nbegin\r\n Result := BitsHighest(X) + 1;\r\n if Result = 0 then\r\n Result := 1;\r\nend;\r\n\r\nfunction BitsNeeded(const X: Word): Integer;\r\nbegin\r\n Result := BitsHighest(X) + 1;\r\n if Result = 0 then\r\n Result := 1;\r\nend;\r\n\r\nfunction BitsNeeded(const X: Integer): Integer;\r\nbegin\r\n Result := BitsHighest(X) + 1;\r\n if Result = 0 then\r\n Result := 1;\r\nend;\r\n\r\nfunction BitsNeeded(const X: Int64): Integer;\r\nbegin\r\n Result := BitsHighest(X) + 1;\r\n if Result = 0 then\r\n Result := 1;\r\nend;\r\n\r\nfunction ReverseBytes(Value: Word): Word;\r\n{$IFDEF PUREPASCAL}\r\nbegin\r\n Result := (Value shr 8) or (Value shl 8);\r\nend;\r\n{$ELSE ~PUREPASCAL}\r\nasm\r\n {$IFDEF CPU32}\r\n // --> AX Value\r\n // <-- AX Value\r\n XCHG AL, AH\r\n {$ENDIF CPU32}\r\n {$IFDEF CPU64}\r\n // --> CX Value\r\n // <-- AX Value\r\n MOV CL, AH\r\n MOV CH, AL\r\n {$ENDIF CPU64}\r\nend;\r\n{$ENDIF ~PUREPASCAL}\r\n\r\nfunction ReverseBytes(Value: Smallint): Smallint;\r\n{$IFDEF PUREPASCAL}\r\nasm\r\n XCHG AL, AH\r\nend;\r\n{$ELSE ~PUREPASCAL}\r\nasm\r\n {$IFDEF CPU32}\r\n // --> AX Value\r\n // <-- AX Value\r\n XCHG AL, AH\r\n {$ENDIF CPU32}\r\n {$IFDEF CPU64}\r\n // --> CX Value\r\n // <-- AX Value\r\n MOV CL, AH\r\n MOV CH, AL\r\n {$ENDIF CPU64}\r\nend;\r\n{$ENDIF ~PUREPASCAL}\r\n\r\nfunction ReverseBytes(Value: Integer): Integer;\r\n{$IFDEF PUREPASCAL}\r\nbegin\r\n Result := (Value shr 24) or (Value shl 24) or ((Value and $00FF0000) shr 8) or ((Value and $0000FF00) shl 8);\r\nend;\r\n{$ELSE ~PUREPASCAL}\r\nasm\r\n {$IFDEF CPU32}\r\n // --> EAX Value\r\n // <-- EAX Value\r\n BSWAP EAX\r\n {$ENDIF CPU32}\r\n {$IFDEF CPU64}\r\n // --> ECX Value\r\n // <-- EAX Value\r\n MOV EAX, ECX\r\n BSWAP EAX\r\n {$ENDIF CPU64}\r\nend;\r\n{$ENDIF ~PUREPASCAL}\r\n\r\nfunction ReverseBytes(Value: Cardinal): Cardinal;\r\n{$IFDEF PUREPASCAL}\r\nbegin\r\n Result := (Value shr 24) or (Value shl 24) or ((Value and $00FF0000) shr 8) or ((Value and $0000FF00) shl 8);\r\nend;\r\n{$ELSE ~PUREPASCAL}\r\nasm\r\n {$IFDEF CPU32}\r\n // --> EAX Value\r\n // <-- EAX Value\r\n BSWAP EAX\r\n {$ENDIF CPU32}\r\n {$IFDEF CPU64}\r\n // --> ECX Value\r\n // <-- EAX Value\r\n MOV EAX, ECX\r\n BSWAP EAX\r\n {$ENDIF CPU64}\r\nend;\r\n{$ENDIF ~PUREPASCAL}\r\n\r\nfunction ReverseBytes(Value: Int64): Int64;\r\n{$IFDEF CPU32}\r\nvar\r\n Lo, Hi: Cardinal;\r\nbegin\r\n // low and hi DWORD swap\r\n Lo := TJclULargeInteger(Value).HighPart;\r\n Hi := TJclULargeInteger(Value).LowPart;\r\n TJclULargeInteger(Result).HighPart := (Hi shr 24) or (Hi shl 24) or ((Hi and $00FF0000) shr 8) or ((Hi and $0000FF00) shl 8);\r\n TJclULargeInteger(Result).LowPart := (Lo shr 24) or (Lo shl 24) or ((Lo and $00FF0000) shr 8) or ((Lo and $0000FF00) shl 8);\r\nend;\r\n{$ENDIF CPU32}\r\n{$IFDEF CPU64}\r\nasm\r\n // --> RCX Value\r\n // <-- RAX Result\r\n MOV RAX, RCX\r\n BSWAP RAX\r\nend;\r\n{$ENDIF CPU64}\r\n\r\nfunction ReverseBytes(P: Pointer; Count: Integer): Pointer;\r\nvar\r\n P1, P2: PByte;\r\n T: Byte;\r\nbegin\r\n if (P <> nil) and (Count > 0) then\r\n begin\r\n P1 := P;\r\n P2 := P;\r\n Inc(P2, Count - 1);\r\n while TJclAddr(P1) < TJclAddr(P2) do\r\n begin\r\n T := P1^;\r\n P1^ := P2^;\r\n P2^ := T;\r\n Inc(P1);\r\n Dec(P2);\r\n end;\r\n end;\r\n Result := P;\r\nend;\r\n\r\n// Arithmetic\r\nprocedure SwapOrd(var I, J: Byte);\r\nvar\r\n T: Byte;\r\nbegin\r\n T := I;\r\n I := J;\r\n J := T;\r\nend;\r\n\r\nprocedure SwapOrd(var I, J: Cardinal);\r\nvar\r\n T: Cardinal;\r\nbegin\r\n T := I;\r\n I := J;\r\n J := T;\r\nend;\r\n\r\nprocedure SwapOrd(var I, J: Integer);\r\nvar\r\n T: Integer;\r\nbegin\r\n T := I;\r\n I := J;\r\n J := T;\r\nend;\r\n\r\nprocedure SwapOrd(var I, J: Int64);\r\nvar\r\n T: Int64;\r\nbegin\r\n T := I;\r\n I := J;\r\n J := T;\r\nend;\r\n\r\nprocedure SwapOrd(var I, J: Shortint);\r\nvar\r\n T: Shortint;\r\nbegin\r\n T := I;\r\n I := J;\r\n J := T;\r\nend;\r\n\r\nprocedure SwapOrd(var I, J: Smallint);\r\nvar\r\n T: Smallint;\r\nbegin\r\n T := I;\r\n I := J;\r\n J := T;\r\nend;\r\n\r\nprocedure SwapOrd(var I, J: Word);\r\nvar\r\n T: Word;\r\nbegin\r\n T := I;\r\n I := J;\r\n J := T;\r\nend;\r\n\r\nfunction IncLimit(var B: Byte; const Limit, Incr: Byte): Byte;\r\nbegin\r\n if (B + Incr) <= Limit then\r\n Inc(B, Incr);\r\n Result := B;\r\nend;\r\n\r\nfunction IncLimit(var B: Shortint; const Limit, Incr: Shortint): Shortint;\r\nbegin\r\n if (B + Incr) <= Limit then\r\n Inc(B, Incr);\r\n Result := B;\r\nend;\r\n\r\nfunction IncLimit(var B: Smallint; const Limit, Incr: Smallint): Smallint;\r\nbegin\r\n if (B + Incr) <= Limit then\r\n Inc(B, Incr);\r\n Result := B;\r\nend;\r\n\r\nfunction IncLimit(var B: Word; const Limit, Incr: Word): Word;\r\nbegin\r\n if (B + Incr) <= Limit then\r\n Inc(B, Incr);\r\n Result := B;\r\nend;\r\n\r\nfunction IncLimit(var B: Integer; const Limit, Incr: Integer): Integer;\r\nbegin\r\n if (B + Incr) <= Limit then\r\n Inc(B, Incr);\r\n Result := B;\r\nend;\r\n\r\nfunction IncLimit(var B: Cardinal; const Limit, Incr: Cardinal): Cardinal;\r\nbegin\r\n if (B + Incr) <= Limit then\r\n Inc(B, Incr);\r\n Result := B;\r\nend;\r\n\r\nfunction IncLimit(var B: Int64; const Limit, Incr: Int64): Int64;\r\nbegin\r\n if (B + Incr) <= Limit then\r\n Inc(B, Incr);\r\n Result := B;\r\nend;\r\n\r\nfunction DecLimit(var B: Byte; const Limit, Decr: Byte): Byte;\r\nbegin\r\n if (B - Decr) >= Limit then\r\n Dec(B, Decr);\r\n Result := B;\r\nend;\r\n\r\nfunction DecLimit(var B: Shortint; const Limit, Decr: Shortint): shortint;\r\nbegin\r\n if (B - Decr) >= Limit then\r\n Dec(B, Decr);\r\n Result := B;\r\nend;\r\n\r\nfunction DecLimit(var B: Smallint; const Limit, Decr: Smallint): Smallint;\r\nbegin\r\n if (B - Decr) >= Limit then\r\n Dec(B, Decr);\r\n Result := B;\r\nend;\r\n\r\nfunction DecLimit(var B: Word; const Limit, Decr: Word): Word;\r\nbegin\r\n if (B - Decr) >= Limit then\r\n Dec(B, Decr);\r\n Result := B;\r\nend;\r\n\r\nfunction DecLimit(var B: Integer; const Limit, Decr: Integer): Integer;\r\nbegin\r\n if (B - Decr) >= Limit then\r\n Dec(B, Decr);\r\n Result := B;\r\nend;\r\n\r\nfunction DecLimit(var B: Cardinal; const Limit, Decr: Cardinal): Cardinal;\r\nbegin\r\n if (B - Decr) >= Limit then\r\n Dec(B, Decr);\r\n Result := B;\r\nend;\r\n\r\nfunction DecLimit(var B: Int64; const Limit, Decr: Int64): Int64;\r\nbegin\r\n if (B - Decr) >= Limit then\r\n Dec(B, Decr);\r\n Result := B;\r\nend;\r\n\r\nfunction IncLimitClamp(var B: Byte; const Limit, Incr: Byte): Byte;\r\nbegin\r\n if (B + Incr) <= Limit then\r\n Inc(B, Incr)\r\n else\r\n B := Limit;\r\n Result := B;\r\nend;\r\n\r\nfunction IncLimitClamp(var B: Shortint; const Limit, Incr: Shortint): Shortint;\r\nbegin\r\n if (B + Incr) <= Limit then\r\n Inc(B, Incr)\r\n else\r\n B := Limit;\r\n Result := B;\r\nend;\r\n\r\nfunction IncLimitClamp(var B: Smallint; const Limit, Incr: Smallint): Smallint;\r\nbegin\r\n if (B + Incr) <= Limit then\r\n Inc(B, Incr)\r\n else\r\n B := Limit;\r\n Result := B;\r\nend;\r\n\r\nfunction IncLimitClamp(var B: Word; const Limit, Incr: Word): Word;\r\nbegin\r\n if (B + Incr) <= Limit then\r\n Inc(B, Incr)\r\n else\r\n B := Limit;\r\n Result := B;\r\nend;\r\n\r\nfunction IncLimitClamp(var B: Integer; const Limit, Incr: Integer): Integer;\r\nbegin\r\n if (B + Incr) <= Limit then\r\n Inc(B, Incr)\r\n else\r\n B := Limit;\r\n Result := B;\r\nend;\r\n\r\nfunction IncLimitClamp(var B: Cardinal; const Limit, Incr: Cardinal): Cardinal;\r\nbegin\r\n if (B + Incr) <= Limit then\r\n Inc(B, Incr)\r\n else\r\n B := Limit;\r\n Result := B;\r\nend;\r\n\r\nfunction IncLimitClamp(var B: Int64; const Limit, Incr: Int64): Int64;\r\nbegin\r\n if (B + Incr) <= Limit then\r\n Inc(B, Incr)\r\n else\r\n B := Limit;\r\n Result := B;\r\nend;\r\n\r\nfunction DecLimitClamp(var B: Byte; const Limit, Decr: Byte): Byte;\r\nbegin\r\n if (B - Decr) >= Limit then\r\n Dec(B, Decr)\r\n else\r\n B := Limit;\r\n Result := B;\r\nend;\r\n\r\nfunction DecLimitClamp(var B: Shortint; const Limit, Decr: Shortint): Shortint;\r\nbegin\r\n if (B - Decr) >= Limit then\r\n Dec(B, Decr)\r\n else\r\n B := Limit;\r\n Result := B;\r\nend;\r\n\r\nfunction DecLimitClamp(var B: Smallint; const Limit, Decr: Smallint): Smallint;\r\nbegin\r\n if (B - Decr) >= Limit then\r\n Dec(B, Decr)\r\n else\r\n B := Limit;\r\n Result := B;\r\nend;\r\n\r\nfunction DecLimitClamp(var B: Word; const Limit, Decr: Word): Word;\r\nbegin\r\n if (B - Decr) >= Limit then\r\n Dec(B, Decr)\r\n else\r\n B := Limit;\r\n Result := B;\r\nend;\r\n\r\nfunction DecLimitClamp(var B: Integer; const Limit, Decr: Integer): Integer;\r\nbegin\r\n if (B - Decr) >= Limit then\r\n Dec(B, Decr)\r\n else\r\n B := Limit;\r\n Result := B;\r\nend;\r\n\r\nfunction DecLimitClamp(var B: Cardinal; const Limit, Decr: Cardinal): Cardinal;\r\nbegin\r\n if (B - Decr) >= Limit then\r\n Dec(B, Decr)\r\n else\r\n B := Limit;\r\n Result := B;\r\nend;\r\n\r\nfunction DecLimitClamp(var B: Int64; const Limit, Decr: Int64): Int64;\r\nbegin\r\n if (B - Decr) >= Limit then\r\n Dec(B, Decr)\r\n else\r\n B := Limit;\r\n Result := B;\r\nend;\r\n\r\nfunction Max(const B1, B2: Byte): Byte;\r\nbegin\r\n if B1 > B2 then\r\n Result := B1\r\n else\r\n Result := B2;\r\nend;\r\n\r\nfunction Min(const B1, B2: Byte): Byte;\r\nbegin\r\n if B1 < B2 then\r\n Result := B1\r\n else\r\n Result := B2;\r\nend;\r\n\r\nfunction Max(const B1, B2: Shortint): Shortint;\r\nbegin\r\n if B1 > B2 then\r\n Result := B1\r\n else\r\n Result := B2;\r\nend;\r\n\r\nfunction Max(const B1, B2: Smallint): Smallint;\r\nbegin\r\n if B1 > B2 then\r\n Result := B1\r\n else\r\n Result := B2;\r\nend;\r\n\r\nfunction Min(const B1, B2: Shortint): Shortint;\r\nbegin\r\n if B1 < B2 then\r\n Result := B1\r\n else\r\n Result := B2;\r\nend;\r\n\r\nfunction Min(const B1, B2: Smallint): Smallint;\r\nbegin\r\n if B1 < B2 then\r\n Result := B1\r\n else\r\n Result := B2;\r\nend;\r\n\r\nfunction Max(const B1, B2: Word): Word;\r\nbegin\r\n if B1 > B2 then\r\n Result := B1\r\n else\r\n Result := B2;\r\nend;\r\n\r\nfunction Max(const B1, B2: Int64): Int64;\r\nbegin\r\n if B1 > B2 then\r\n Result := B1\r\n else\r\n Result := B2;\r\nend;\r\n\r\nfunction Min(const B1, B2: Word): Word;\r\nbegin\r\n if B1 < B2 then\r\n Result := B1\r\n else\r\n Result := B2;\r\nend;\r\n\r\nfunction Max(const B1, B2: Integer): Integer;\r\nbegin\r\n if B1 > B2 then\r\n Result := B1\r\n else\r\n Result := B2;\r\nend;\r\n\r\nfunction Min(const B1, B2: Integer): Integer;\r\nbegin\r\n if B1 < B2 then\r\n Result := B1\r\n else\r\n Result := B2;\r\nend;\r\n\r\nfunction Max(const B1, B2: Cardinal): Cardinal;\r\nbegin\r\n if B1 > B2 then\r\n Result := B1\r\n else\r\n Result := B2;\r\nend;\r\n\r\nfunction Min(const B1, B2: Cardinal): Cardinal;\r\nbegin\r\n if B1 < B2 then\r\n Result := B1\r\n else\r\n Result := B2;\r\nend;\r\n\r\nfunction Min(const B1, B2: Int64): Int64;\r\nbegin\r\n if B1 < B2 then\r\n Result := B1\r\n else\r\n Result := B2;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jcl/source/common/JclMIDI.pas", "content": "{**************************************************************************************************}\r\n{ }\r\n{ Project JEDI Code Library (JCL) }\r\n{ }\r\n{ The contents of this file are subject to the Mozilla Public License Version 1.1 (the \"License\"); }\r\n{ you may not use this file except in compliance with the License. You may obtain a copy of the }\r\n{ License at http://www.mozilla.org/MPL/ }\r\n{ }\r\n{ Software distributed under the License is distributed on an \"AS IS\" basis, WITHOUT WARRANTY OF }\r\n{ ANY KIND, either express or implied. See the License for the specific language governing rights }\r\n{ and limitations under the License. }\r\n{ }\r\n{ The Original Code is JclMIDI.pas. }\r\n{ }\r\n{ The Initial Developer of the Original Code is Robert Rossmair. }\r\n{ Portions created by Robert Rossmair are Copyright (C) Robert Rossmair. All rights reserved. }\r\n{ }\r\n{ Contributor(s): }\r\n{ Robert Rossmair }\r\n{ }\r\n{**************************************************************************************************}\r\n{ }\r\n{ Platform-independent MIDI declarations }\r\n{ }\r\n{**************************************************************************************************}\r\n{ }\r\n{ Last modified: $Date:: 2011-09-03 00:07:50 +0200 (sam. 03 sept. 2011) $ }\r\n{ Revision: $Rev:: 3599 $ }\r\n{ Author: $Author:: outchy $ }\r\n{ }\r\n{**************************************************************************************************}\r\n\r\nunit JclMIDI;\r\n\r\n{$I jcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n {$IFDEF HAS_UNITSCOPE}\r\n System.Classes,\r\n {$ELSE ~HAS_UNITSCOPE}\r\n Classes,\r\n {$ENDIF ~HAS_UNITSCOPE}\r\n JclBase;\r\n\r\n// manifest constants for MIDI message protocol\r\nconst\r\n // MIDI Status Bytes for Channel Voice Messages\r\n MIDIMsgNoteOff = $80;\r\n MIDIMsgNoteOn = $90;\r\n MIDIMsgPolyKeyPressure = $A0;\r\n MIDIMsgControlChange = $B0;\r\n MIDIMsgProgramChange = $C0;\r\n MIDIMsgChannelKeyPressure = $D0;\r\n MIDIMsgAftertouch = MIDIMsgChannelKeyPressure; // Synonym\r\n MIDIMsgPitchWheelChange = $E0;\r\n // MIDI Status Bytes for System Common Messages\r\n MIDIMsgSysEx = $F0;\r\n MIDIMsgMTCQtrFrame = $F1; // MIDI Time Code Qtr. Frame\r\n MIDIMsgSongPositionPtr = $F2;\r\n MIDIMsgSongSelect = $F3;\r\n MIDIMsgTuneRequest = $F6;\r\n MIDIMsgEOX = $F7; // marks end of system exclusive message\r\n\r\n // MIDI Status Bytes for System Real-Time Messages\r\n MIDIMsgTimingClock = $F8;\r\n MIDIMsgStartSequence = $FA;\r\n MIDIMsgContinueSequence = $FB;\r\n MIDIMsgStopSequence = $FC;\r\n MIDIMsgActiveSensing = $FE;\r\n MIDIMsgSystemReset = $FF;\r\n\r\n // MIDICC...: MIDI Control Change Messages\r\n\r\n // Continuous Controllers MSB\r\n MIDICCBankSelect = $00;\r\n MIDICCModulationWheel = $01;\r\n MIDICCBreathControl = $02;\r\n MIDICCFootController = $04;\r\n MIDICCPortamentoTime = $05;\r\n MIDICCDataEntry = $06;\r\n MIDICCChannelVolume = $07;\r\n MIDICCMainVolume = MIDICCChannelVolume;\r\n MIDICCBalance = $08;\r\n MIDICCPan = $0A;\r\n MIDICCExpression = $0B;\r\n MIDICCEffectControl = $0C;\r\n MIDICCEffectControl2 = $0D;\r\n MIDICCGeneralPurpose1 = $10;\r\n MIDICCGeneralPurpose2 = $11;\r\n MIDICCGeneralPurpose3 = $12;\r\n MIDICCGeneralPurpose4 = $13;\r\n // Continuous Controllers LSB\r\n MIDICCBankSelectLSB = $20;\r\n MIDICCModulationWheelLSB = $21;\r\n MIDICCBreathControlLSB = $22;\r\n MIDICCFootControllerLSB = $24;\r\n MIDICCPortamentoTimeLSB = $25;\r\n MIDICCDataEntryLSB = $26;\r\n MIDICCChannelVolumeLSB = $27;\r\n MIDICCMainVolumeLSB = MIDICCChannelVolumeLSB;\r\n MIDICCBalanceLSB = $28;\r\n MIDICCPanLSB = $2A;\r\n MIDICCExpressionLSB = $2B;\r\n MIDICCEffectControlLSB = $2C;\r\n MIDICCEffectControl2LSB = $2D;\r\n MIDICCGeneralPurpose1LSB = $30;\r\n MIDICCGeneralPurpose2LSB = $31;\r\n MIDICCGeneralPurpose3LSB = $32;\r\n MIDICCGeneralPurpose4LSB = $33;\r\n // Switches\r\n MIDICCSustain = $40;\r\n MIDICCPortamento = $41;\r\n MIDICCSustenuto = $42;\r\n MIDICCSoftPedal = $43;\r\n MIDICCLegato = $44;\r\n MIDICCHold2 = $45;\r\n\r\n MIDICCSound1 = $46; // (Sound Variation)\r\n MIDICCSound2 = $47; // (Timbre/Harmonic Intens.)\r\n MIDICCSound3 = $48; // (Release Time)\r\n MIDICCSound4 = $49; // (Attack Time)\r\n MIDICCSound5 = $4A; // (Brightness)\r\n MIDICCSound6 = $4B; // (Decay Time)\r\n MIDICCSound7 = $4C; // (Vibrato Rate)\r\n MIDICCSound8 = $4D; // (Vibrato Depth)\r\n MIDICCSound9 = $4E; // (Vibrato Delay)\r\n MIDICCSound10 = $4F; //\r\n\r\n MIDICCGeneralPurpose5 = $50;\r\n MIDICCGeneralPurpose6 = $51;\r\n MIDICCGeneralPurpose7 = $52;\r\n MIDICCGeneralPurpose8 = $53;\r\n MIDICCPortamentoControl = $54;\r\n\r\n MIDICCReverbSendLevel = $5B;\r\n MIDICCEffects2Depth = $5C;\r\n MIDICCTremoloDepth = MIDICCEffects2Depth;\r\n MIDICCChorusSendLevel = $5D;\r\n MIDICCEffects4Depth = $5E;\r\n MIDICCCelesteDepth = MIDICCEffects4Depth;\r\n MIDICCEffects5Depth = $5F;\r\n MIDICCPhaserDepth = MIDICCEffects5Depth;\r\n\r\n MIDICCDataEntryInc = $60;\r\n MIDICCDataEntryDec = $61;\r\n MIDICCNonRegParamNumLSB = $62;\r\n MIDICCNonRegParamNumMSB = $63;\r\n MIDICCRegParamNumLSB = $64;\r\n MIDICCRegParamNumMSB = $65;\r\n\r\n// Registered Parameter Numbers [CC# 65H,64H]\r\n// -----------------------------------------------------------\r\n// CC#65 (MSB) | CC#64 (LSB) | Function\r\n// Hex|Dec| | Hex|Dec| |\r\n// - - - - - - | - - - - - - |- - - - - - - - - - - - - - - -\r\n// 00 = 0 | 00 = 0 | Pitch Bend Sensitivity\r\n// 00 = 0 | 01 = 1 | Channel Fine Tuning\r\n// 00 = 0 | 02 = 2 | Channel Coarse Tuning\r\n// 00 = 0 | 03 = 3 | Tuning Program Change\r\n// 00 = 0 | 04 = 4 | Tuning Bank Select\r\n\r\n // Channel Mode Messages (Control Change >= $78)\r\n MIDICCAllSoundOff = $78;\r\n MIDICCResetAllControllers = $79;\r\n MIDICCLocalControl = $7A;\r\n MIDICCAllNotesOff = $7B;\r\n\r\n MIDICCOmniModeOff = $7C;\r\n MIDICCOmniModeOn = $7D;\r\n MIDICCMonoModeOn = $7E;\r\n MIDICCPolyModeOn = $7F;\r\n\r\ntype\r\n TMIDIChannel = 1..16;\r\n TMIDIDataByte = 0..$7F; // 7 bits\r\n TMIDIDataWord = 0..$3FFF; // 14 bits\r\n TMIDIStatusByte = $80..$FF;\r\n TMIDIVelocity = TMIDIDataByte;\r\n TMIDIKey = TMIDIDataByte;\r\n TMIDINote = TMIDIKey;\r\n\r\nconst\r\n // Helper definitions\r\n MIDIDataMask = $7F;\r\n MIDIDataWordMask = $3FFF;\r\n MIDIChannelMsgMask = $F0;\r\n MIDIInvalidStatus = TMIDIStatusByte(0);\r\n BitsPerMIDIDataByte = 7;\r\n BitsPerMIDIDataWord = BitsPerMIDIDataByte * 2;\r\n MIDIPitchWheelCenter = 1 shl (BitsPerMIDIDataWord - 1);\r\n\r\ntype\r\n TMIDINotes = set of TMIDINote;\r\n\r\n TSingleNoteTuningData = packed record\r\n case Integer of\r\n 0:\r\n (Key: TMIDINote; Frequency: array [0..2] of TMIDIDataByte);\r\n 1:\r\n (DWord: LongWord);\r\n end;\r\n\r\n EJclMIDIError = class(EJclError);\r\n\r\n// MIDI Out\r\n IJclMIDIOut = interface\r\n ['{A29C3EBD-EB70-4C72-BEC5-700AF57FD4C8}']\r\n // property access methods\r\n function GetActiveNotes(Channel: TMIDIChannel): TMIDINotes;\r\n function GetName: string;\r\n function GetMIDIStatus: TMIDIStatusByte;\r\n function GetRunningStatusEnabled: Boolean;\r\n procedure SetRunningStatusEnabled(const Value: Boolean);\r\n // General message send method\r\n procedure SendMessage(const Data: array of Byte);\r\n // Channel Voice Messages\r\n procedure SendNoteOff(Channel: TMIDIChannel; Key: TMIDINote; Velocity: TMIDIDataByte = $40);\r\n procedure SendNoteOn(Channel: TMIDIChannel; Key: TMIDINote; Velocity: TMIDIDataByte);\r\n procedure SendPolyphonicKeyPressure(Channel: TMIDIChannel; Key: TMIDINote; Value: TMIDIDataByte);\r\n procedure SendControlChange(Channel: TMIDIChannel; ControllerNum, Value: TMIDIDataByte);\r\n // High Resolution \"macro\" for controller numbers <= $13, sends upper 7 bits first,\r\n // lower 7 bits per additional LSB message afterwards\r\n procedure SendControlChangeHR(Channel: TMIDIChannel; ControllerNum: TMIDIDataByte; Value: TMIDIDataWord);\r\n procedure SendSwitchChange(Channel: TMIDIChannel; ControllerNum: TMIDIDataByte; Value: Boolean);\r\n procedure SendProgramChange(Channel: TMIDIChannel; ProgramNum: TMIDIDataByte);\r\n procedure SendChannelPressure(Channel: TMIDIChannel; Value: TMIDIDataByte);\r\n procedure SendPitchWheelChange(Channel: TMIDIChannel; Value: TMIDIDataWord);\r\n procedure SendPitchWheelPos(Channel: TMIDIChannel; Value: Single);\r\n // Control Change Messages\r\n procedure SelectProgram(Channel: TMIDIChannel; BankNum: TMIDIDataWord; ProgramNum: TMIDIDataByte);\r\n procedure SendModulationWheelChange(Channel: TMIDIChannel; Value: TMidiDataByte);\r\n procedure SendBreathControlChange(Channel: TMIDIChannel; Value: TMidiDataByte);\r\n procedure SendFootControllerChange(Channel: TMIDIChannel; Value: TMidiDataByte);\r\n procedure SendPortamentoTimeChange(Channel: TMIDIChannel; Value: TMidiDataByte);\r\n procedure SendDataEntry(Channel: TMIDIChannel; Value: TMidiDataByte);\r\n procedure SendChannelVolumeChange(Channel: TMIDIChannel; Value: TMidiDataByte);\r\n procedure SendBalanceChange(Channel: TMIDIChannel; Value: TMidiDataByte);\r\n procedure SendPanChange(Channel: TMIDIChannel; Value: TMidiDataByte);\r\n procedure SendExpressionChange(Channel: TMIDIChannel; Value: TMidiDataByte);\r\n // \"high resolution\" variants\r\n procedure SendModulationWheelChangeHR(Channel: TMIDIChannel; Value: TMidiDataWord);\r\n procedure SendBreathControlChangeHR(Channel: TMIDIChannel; Value: TMidiDataWord);\r\n procedure SendFootControllerChangeHR(Channel: TMIDIChannel; Value: TMidiDataWord);\r\n procedure SendPortamentoTimeChangeHR(Channel: TMIDIChannel; Value: TMidiDataWord);\r\n procedure SendDataEntryHR(Channel: TMIDIChannel; Value: TMidiDataWord);\r\n procedure SendChannelVolumeChangeHR(Channel: TMIDIChannel; Value: TMidiDataWord);\r\n procedure SendBalanceChangeHR(Channel: TMIDIChannel; Value: TMidiDataWord);\r\n procedure SendPanChangeHR(Channel: TMIDIChannel; Value: TMidiDataWord);\r\n procedure SendExpressionChangeHR(Channel: TMIDIChannel; Value: TMidiDataWord);\r\n // Control Change Messages: Switches\r\n procedure SwitchSustain(Channel: TMIDIChannel; Value: Boolean);\r\n procedure SwitchPortamento(Channel: TMIDIChannel; Value: Boolean);\r\n procedure SwitchSostenuto(Channel: TMIDIChannel; Value: Boolean);\r\n procedure SwitchSoftPedal(Channel: TMIDIChannel; Value: Boolean);\r\n procedure SwitchLegato(Channel: TMIDIChannel; Value: Boolean);\r\n procedure SwitchHold2(Channel: TMIDIChannel; Value: Boolean);\r\n // Channel Mode Messages\r\n procedure SwitchAllSoundOff(Channel: TMIDIChannel);\r\n procedure ResetAllControllers(Channel: TMIDIChannel);\r\n procedure SwitchLocalControl(Channel: TMIDIChannel; Value: Boolean);\r\n procedure SwitchAllNotesOff(Channel: TMIDIChannel);\r\n procedure SwitchOmniModeOff(Channel: TMIDIChannel);\r\n procedure SwitchOmniModeOn(Channel: TMIDIChannel);\r\n procedure SwitchMonoModeOn(Channel: TMIDIChannel; ChannelCount: Integer);\r\n procedure SwitchPolyModeOn(Channel: TMIDIChannel);\r\n //\r\n procedure SendSingleNoteTuningChange(const TargetDeviceID, TuningProgramNum: TMidiDataByte;\r\n const TuningData: array of TSingleNoteTuningData);\r\n function NoteIsOn(Channel: TMIDIChannel; Key: TMIDINote): Boolean;\r\n procedure SwitchActiveNotesOff(Channel: TMIDIChannel); overload;\r\n procedure SwitchActiveNotesOff; overload;\r\n // Properties\r\n property ActiveNotes[Channel: TMIDIChannel]: TMIDINotes read GetActiveNotes;\r\n property Name: string read GetName;\r\n property LocalControl[Channel: TMIDIChannel]: Boolean write SwitchLocalControl;\r\n property MIDIStatus: TMIDIStatusByte read GetMIDIStatus;\r\n // Tribute to some braindead devices which cannot handle running status (e.g. ESS Solo 1 Win2k driver)\r\n property RunningStatusEnabled: Boolean read GetRunningStatusEnabled write SetRunningStatusEnabled;\r\n end;\r\n\r\n // Abstract MIDI Out device class\r\n TJclMIDIOut = class(TInterfacedObject, IJclMIDIOut)\r\n private\r\n FMIDIStatus: TMIDIStatusByte;\r\n FRunningStatusEnabled: Boolean;\r\n FActiveNotes: array [TMIDIChannel] of TMIDINotes;\r\n protected\r\n function IsRunningStatus(StatusByte: TMIDIStatusByte): Boolean;\r\n procedure SendChannelMessage(Msg: TMIDIStatusByte; Channel: TMIDIChannel;\r\n Data1, Data2: TMIDIDataByte);\r\n procedure DoSendMessage(const Data: array of Byte); virtual; abstract;\r\n public\r\n destructor Destroy; override;\r\n { IJclMIDIOut }\r\n // property access methods\r\n function GetActiveNotes(Channel: TMIDIChannel): TMIDINotes;\r\n function GetName: string; virtual; abstract;\r\n function GetMIDIStatus: TMIDIStatusByte;\r\n function GetRunningStatusEnabled: Boolean;\r\n procedure SetRunningStatusEnabled(const Value: Boolean);\r\n // General message send method\r\n procedure SendMessage(const Data: array of Byte); // Channel Voice Messages\r\n procedure SendNoteOff(Channel: TMIDIChannel; Key: TMIDINote; Velocity: TMIDIDataByte = $40);\r\n procedure SendNoteOn(Channel: TMIDIChannel; Key: TMIDINote; Velocity: TMIDIDataByte);\r\n procedure SendPolyphonicKeyPressure(Channel: TMIDIChannel; Key: TMIDINote; Value: TMIDIDataByte);\r\n procedure SendControlChange(Channel: TMIDIChannel; ControllerNum, Value: TMIDIDataByte);\r\n procedure SendControlChangeHR(Channel: TMIDIChannel; ControllerNum: TMIDIDataByte; Value: TMIDIDataWord);\r\n procedure SendSwitchChange(Channel: TMIDIChannel; ControllerNum: TMIDIDataByte; Value: Boolean);\r\n procedure SendProgramChange(Channel: TMIDIChannel; ProgramNum: TMIDIDataByte);\r\n procedure SendChannelPressure(Channel: TMIDIChannel; Value: TMIDIDataByte);\r\n procedure SendPitchWheelChange(Channel: TMIDIChannel; Value: TMIDIDataWord);\r\n procedure SendPitchWheelPos(Channel: TMIDIChannel; Value: Single);\r\n // Control Change Messages\r\n procedure SelectProgram(Channel: TMIDIChannel; BankNum: TMIDIDataWord; ProgramNum: TMIDIDataByte);\r\n procedure SendModulationWheelChange(Channel: TMIDIChannel; Value: TMidiDataByte);\r\n procedure SendBreathControlChange(Channel: TMIDIChannel; Value: TMidiDataByte);\r\n procedure SendFootControllerChange(Channel: TMIDIChannel; Value: TMidiDataByte);\r\n procedure SendPortamentoTimeChange(Channel: TMIDIChannel; Value: TMidiDataByte);\r\n procedure SendDataEntry(Channel: TMIDIChannel; Value: TMidiDataByte);\r\n procedure SendChannelVolumeChange(Channel: TMIDIChannel; Value: TMidiDataByte);\r\n procedure SendBalanceChange(Channel: TMIDIChannel; Value: TMidiDataByte);\r\n procedure SendPanChange(Channel: TMIDIChannel; Value: TMidiDataByte);\r\n procedure SendExpressionChange(Channel: TMIDIChannel; Value: TMidiDataByte);\r\n // ...high Resolution\r\n procedure SendModulationWheelChangeHR(Channel: TMIDIChannel; Value: TMidiDataWord);\r\n procedure SendBreathControlChangeHR(Channel: TMIDIChannel; Value: TMidiDataWord);\r\n procedure SendFootControllerChangeHR(Channel: TMIDIChannel; Value: TMidiDataWord);\r\n procedure SendPortamentoTimeChangeHR(Channel: TMIDIChannel; Value: TMidiDataWord);\r\n procedure SendDataEntryHR(Channel: TMIDIChannel; Value: TMidiDataWord);\r\n procedure SendChannelVolumeChangeHR(Channel: TMIDIChannel; Value: TMidiDataWord);\r\n procedure SendBalanceChangeHR(Channel: TMIDIChannel; Value: TMidiDataWord);\r\n procedure SendPanChangeHR(Channel: TMIDIChannel; Value: TMidiDataWord);\r\n procedure SendExpressionChangeHR(Channel: TMIDIChannel; Value: TMidiDataWord);\r\n // Control Change Messages: Switches\r\n procedure SwitchSustain(Channel: TMIDIChannel; Value: Boolean);\r\n procedure SwitchPortamento(Channel: TMIDIChannel; Value: Boolean);\r\n procedure SwitchSostenuto(Channel: TMIDIChannel; Value: Boolean);\r\n procedure SwitchSoftPedal(Channel: TMIDIChannel; Value: Boolean);\r\n procedure SwitchLegato(Channel: TMIDIChannel; Value: Boolean);\r\n procedure SwitchHold2(Channel: TMIDIChannel; Value: Boolean);\r\n // Channel Mode Messages\r\n procedure SwitchAllSoundOff(Channel: TMIDIChannel);\r\n procedure ResetAllControllers(Channel: TMIDIChannel);\r\n procedure SwitchLocalControl(Channel: TMIDIChannel; Value: Boolean);\r\n procedure SwitchAllNotesOff(Channel: TMIDIChannel);\r\n procedure SwitchOmniModeOff(Channel: TMIDIChannel);\r\n procedure SwitchOmniModeOn(Channel: TMIDIChannel);\r\n procedure SwitchMonoModeOn(Channel: TMIDIChannel; ChannelCount: Integer);\r\n procedure SwitchPolyModeOn(Channel: TMIDIChannel);\r\n //\r\n procedure SendSingleNoteTuningChange(const TargetDeviceID, TuningProgramNum: TMidiDataByte;\r\n const TuningData: array of TSingleNoteTuningData);\r\n function NoteIsOn(Channel: TMIDIChannel; Key: TMIDINote): Boolean;\r\n procedure SwitchActiveNotesOff(Channel: TMIDIChannel); overload;\r\n procedure SwitchActiveNotesOff; overload;\r\n property ActiveNotes[Channel: TMIDIChannel]: TMIDINotes read GetActiveNotes;\r\n property Name: string read GetName;\r\n property RunningStatusEnabled: Boolean read GetRunningStatusEnabled write SetRunningStatusEnabled;\r\n end;\r\n\r\nfunction MIDIOut(DeviceID: Cardinal = 0): IJclMIDIOut;\r\nprocedure GetMidiOutputs(const List: TStrings);\r\nfunction MIDISingleNoteTuningData(Key: TMIDINote; Frequency: Single): TSingleNoteTuningData;\r\nfunction MIDINoteToStr(Note: TMIDINote): string;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jcl.svn.sourceforge.net/svnroot/jcl/tags/JCL-2.4-Build4571/jcl/source/common/JclMIDI.pas $';\r\n Revision: '$Revision: 3599 $';\r\n Date: '$Date: 2011-09-03 00:07:50 +0200 (sam. 03 sept. 2011) $';\r\n LogPath: 'JCL\\source\\common';\r\n Extra: '';\r\n Data: nil\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n {$IFDEF HAS_UNITSCOPE}\r\n System.SysUtils,\r\n {$ELSE ~HAS_UNITSCOPE}\r\n SysUtils,\r\n {$ENDIF ~HAS_UNITSCOPE}\r\n {$IFDEF MSWINDOWS}\r\n JclWinMIDI,\r\n {$ENDIF MSWINDOWS}\r\n {$IFDEF UNIX}\r\n //JclUnixMIDI,\r\n {$ENDIF UNIX}\r\n JclResources;\r\n\r\n{$IFDEF UNIX}\r\nprocedure ErrorNotImplemented;\r\nbegin\r\n raise EJclInternalError.CreateRes(@RsMidiNotImplemented);\r\nend;\r\n{$ENDIF UNIX}\r\n\r\nfunction MIDIOut(DeviceID: Cardinal = 0): IJclMIDIOut;\r\nbegin\r\n Result := nil;\r\n {$IFDEF MSWINDOWS}\r\n Result := JclWinMIDI.MIDIOut(DeviceID);\r\n {$ENDIF MSWINDOWS}\r\n {$IFDEF UNIX}\r\n { TODO -oRobert Rossmair : Unix MIDI Out }\r\n //Result := JclUnixMIDI.MidiOut(DeviceID);\r\n ErrorNotImplemented;\r\n {$ENDIF UNIX}\r\nend;\r\n\r\nprocedure GetMidiOutputs(const List: TStrings);\r\nbegin\r\n {$IFDEF MSWINDOWS}\r\n JclWinMIDI.GetMidiOutputs(List);\r\n {$ENDIF MSWINDOWS}\r\n {$IFDEF UNIX}\r\n { TODO -oRobert Rossmair : Unix GetMIDIOutputs }\r\n //JclUnixMIDI.GetMidiOutputs(List);\r\n ErrorNotImplemented;\r\n {$ENDIF UNIX}\r\nend;\r\n\r\nfunction MIDISingleNoteTuningData(Key: TMIDINote; Frequency: Single): TSingleNoteTuningData;\r\nvar\r\n F: Cardinal;\r\nbegin\r\n Result.Key := Key;\r\n F := Trunc(Frequency * (1 shl BitsPerMIDIDataWord));\r\n Result.Frequency[0] := (F shr BitsPerMIDIDataWord) and MIDIDataMask;\r\n Result.Frequency[1] := (F shr BitsPerMIDIDataByte) and MIDIDataMask;\r\n Result.Frequency[2] := F and MIDIDataMask;\r\nend;\r\n\r\nprocedure CheckMIDIChannelNum(Channel: TMIDIChannel);\r\nbegin\r\n if (Integer(Channel) < Low(TMIDIChannel)) or (Integer(Channel) > High(TMIDIChannel)) then\r\n raise EJclMIDIError.CreateResFmt(@RsMidiInvalidChannelNum, [Channel]);\r\nend;\r\n\r\nfunction MIDINoteToStr(Note: TMIDINote): string;\r\nconst\r\n HalftonesPerOctave = 12;\r\nbegin\r\n case Note mod HalftonesPerOctave of\r\n 0:\r\n Result := LoadResString(@RsOctaveC);\r\n 1:\r\n Result := LoadResString(@RsOctaveCSharp);\r\n 2:\r\n Result := LoadResString(@RsOctaveD);\r\n 3:\r\n Result := LoadResString(@RsOctaveDSharp);\r\n 4:\r\n Result := LoadResString(@RsOctaveE);\r\n 5:\r\n Result := LoadResString(@RsOctaveF);\r\n 6:\r\n Result := LoadResString(@RsOctaveFSharp);\r\n 7:\r\n Result := LoadResString(@RsOctaveG);\r\n 8:\r\n Result := LoadResString(@RsOctaveGSharp);\r\n 9:\r\n Result := LoadResString(@RsOctaveA);\r\n 10:\r\n Result := LoadResString(@RsOctaveASharp);\r\n 11:\r\n Result := LoadResString(@RsOctaveB);\r\n end;\r\n Result := Format('%s%d', [Result, Note div HalftonesPerOctave - 2]);\r\nend;\r\n\r\n// TJclMIDIOut\r\ndestructor TJclMIDIOut.Destroy;\r\nbegin\r\n SwitchActiveNotesOff;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJclMIDIOut.GetActiveNotes(Channel: TMIDIChannel): TMIDINotes;\r\nbegin\r\n CheckMIDIChannelNum(Channel);\r\n Result := FActiveNotes[Channel];\r\nend;\r\n\r\nprocedure TJclMIDIOut.SendChannelMessage(Msg: TMIDIStatusByte;\r\n Channel: TMIDIChannel; Data1, Data2: TMIDIDataByte);\r\nbegin\r\n SendMessage([Msg or (Channel - Low(Channel)), Data1, Data2]);\r\nend;\r\n\r\nfunction TJclMIDIOut.GetRunningStatusEnabled: Boolean;\r\nbegin\r\n Result := FRunningStatusEnabled;\r\nend;\r\n\r\nfunction TJclMIDIOut.NoteIsOn(Channel: TMIDIChannel; Key: TMIDINote): Boolean;\r\nbegin\r\n Result := Key in FActiveNotes[Channel];\r\nend;\r\n\r\nprocedure TJclMIDIOut.SendNoteOff(Channel: TMIDIChannel; Key: TMIDINote; Velocity: TMIDIDataByte);\r\nbegin\r\n SendChannelMessage(MIDIMsgNoteOff, Channel, Key, Velocity);\r\n Exclude(FActiveNotes[Channel], Key);\r\nend;\r\n\r\nprocedure TJclMIDIOut.SendNoteOn(Channel: TMIDIChannel; Key: TMIDINote; Velocity: TMIDIDataByte);\r\nbegin\r\n SendChannelMessage(MIDIMsgNoteOn, Channel, Key, Velocity);\r\n Include(FActiveNotes[Channel], Key);\r\nend;\r\n\r\nprocedure TJclMIDIOut.SendPolyphonicKeyPressure(Channel: TMIDIChannel;\r\n Key: TMIDINote; Value: TMIDIDataByte);\r\nbegin\r\n SendChannelMessage(MIDIMsgPolyKeyPressure, Channel, Key, Value);\r\nend;\r\n\r\nprocedure TJclMIDIOut.SendControlChange(Channel: TMIDIChannel; ControllerNum, Value: TMIDIDataByte);\r\nbegin\r\n SendChannelMessage(MIDIMsgControlChange, Channel, ControllerNum, Value);\r\nend;\r\n\r\nprocedure TJclMIDIOut.SendControlChangeHR(Channel: TMIDIChannel; ControllerNum: TMIDIDataByte;\r\n Value: TMIDIDataWord);\r\nbegin\r\n SendControlChange(Channel, ControllerNum, Value shr BitsPerMIDIDataByte and MIDIDataMask);\r\n if ControllerNum <= $13 then\r\n SendControlChange(Channel, ControllerNum or $20, Value and MIDIDataMask);\r\nend;\r\n\r\nprocedure TJclMIDIOut.SendSwitchChange(Channel: TMIDIChannel; ControllerNum: TMIDIDataByte; Value: Boolean);\r\nconst\r\n DataByte: array [Boolean] of Byte = ($00, $7F);\r\nbegin\r\n SendChannelMessage(MIDIMsgControlChange, Channel, ControllerNum, DataByte[Value]);\r\nend;\r\n\r\nprocedure TJclMIDIOut.SendProgramChange(Channel: TMIDIChannel; ProgramNum: TMIDIDataByte);\r\nbegin\r\n SendChannelMessage(MIDIMsgProgramChange, Channel, ProgramNum, 0);\r\nend;\r\n\r\nprocedure TJclMIDIOut.SendChannelPressure(Channel: TMIDIChannel; Value: TMIDIDataByte);\r\nbegin\r\n SendChannelMessage(MIDIMsgChannelKeyPressure, Channel, Value, 0);\r\nend;\r\n\r\nprocedure TJclMIDIOut.SendPitchWheelChange(Channel: TMIDIChannel; Value: TMIDIDataWord);\r\nbegin\r\n SendChannelMessage(MIDIMsgPitchWheelChange, Channel, Value and MidiDataMask, Value shr BitsPerMIDIDataByte);\r\nend;\r\n\r\nprocedure TJclMIDIOut.SendPitchWheelPos(Channel: TMIDIChannel; Value: Single);\r\nvar\r\n Temp: TMIDIDataWord;\r\nbegin\r\n if Value < 0 then\r\n Temp := Round(Value * (1 shl 13))\r\n else\r\n Temp := Round(Value * (1 shl 13 - 1));\r\n SendPitchWheelChange(Channel, Temp);\r\nend;\r\n\r\nprocedure TJclMIDIOut.SwitchAllSoundOff(Channel: TMIDIChannel);\r\nbegin\r\n SendControlChange(Channel, MIDICCAllSoundOff, 0);\r\nend;\r\n\r\nprocedure TJclMIDIOut.SwitchLocalControl(Channel: TMIDIChannel; Value: Boolean);\r\nbegin\r\n SendSwitchChange(Channel, MIDICCLocalControl, Value);\r\nend;\r\n\r\nprocedure TJclMIDIOut.ResetAllControllers(Channel: TMIDIChannel);\r\nbegin\r\n SendControlChange(Channel, MIDICCResetAllControllers, 0);\r\nend;\r\n\r\nprocedure TJclMIDIOut.SwitchAllNotesOff(Channel: TMIDIChannel);\r\nbegin\r\n CheckMIDIChannelNum(Channel);\r\n SendControlChange(Channel, MIDICCAllNotesOff, 0);\r\n FActiveNotes[Channel] := [];\r\nend;\r\n\r\nprocedure TJclMIDIOut.SetRunningStatusEnabled(const Value: Boolean);\r\nbegin\r\n FMIDIStatus := MIDIInvalidStatus;\r\n FRunningStatusEnabled := Value;\r\nend;\r\n\r\nprocedure TJclMIDIOut.SendSingleNoteTuningChange(const TargetDeviceID, TuningProgramNum: TMidiDataByte;\r\n const TuningData: array of TSingleNoteTuningData);\r\nvar\r\n BufSize, Count: Integer;\r\n Buf: array of Byte;\r\nbegin\r\n Count := High(TuningData) - Low(TuningData) + 1;\r\n BufSize := 8 + Count * SizeOf(TSingleNoteTuningData);\r\n SetLength(Buf, BufSize);\r\n Buf[0] := MIDIMsgSysEx; // Universal Real Time SysEx header, first byte\r\n Buf[1] := $7F; // second byte\r\n Buf[2] := TargetDeviceID; // ID of target device (?)\r\n Buf[3] := 8; // sub-ID#1 (MIDI Tuning)\r\n Buf[4] := 2; // sub-ID#2 (note change)\r\n Buf[5] := TuningProgramNum; // tuning program number (0 127)\r\n Buf[6] := Count;\r\n Move(TuningData, Buf[7], Count * SizeOf(TSingleNoteTuningData));\r\n Buf[BufSize - 1] := MIDIMsgEOX;\r\n SendMessage(Buf);\r\nend;\r\n\r\nprocedure TJclMIDIOut.SwitchActiveNotesOff(Channel: TMIDIChannel);\r\nvar\r\n Note: TMIDINote;\r\nbegin\r\n CheckMIDIChannelNum(Channel);\r\n if FActiveNotes[Channel] <> [] then\r\n for Note := Low(Note) to High(Note) do\r\n if Note in FActiveNotes[Channel] then\r\n SendNoteOff(Channel, Note, $7F);\r\nend;\r\n\r\nprocedure TJclMIDIOut.SwitchActiveNotesOff;\r\nvar\r\n Channel: TMIDIChannel;\r\nbegin\r\n for Channel := Low(Channel) to High(Channel) do\r\n SwitchActiveNotesOff(Channel);\r\nend;\r\n\r\nprocedure TJclMIDIOut.SelectProgram(Channel: TMIDIChannel;\r\n BankNum: TMIDIDataWord; ProgramNum: TMIDIDataByte);\r\nbegin\r\n SendControlChangeHR(Channel, MIDICCBankSelect, BankNum);\r\n SendProgramChange(Channel, ProgramNum);\r\nend;\r\n\r\nprocedure TJclMIDIOut.SendMessage(const Data: array of Byte);\r\nbegin\r\n if IsRunningStatus(Data[0]) then\r\n {$IFDEF FPC}\r\n DoSendMessage(PJclByteArray(@Data[1])^)\r\n {$ELSE ~FPC}\r\n DoSendMessage(Slice(Data, 1))\r\n {$ENDIF ~FPC}\r\n else\r\n DoSendMessage(Data);\r\nend;\r\n\r\nfunction TJclMIDIOut.GetMIDIStatus: TMIDIStatusByte;\r\nbegin\r\n Result := FMIDIStatus;\r\nend;\r\n\r\nfunction TJclMIDIOut.IsRunningStatus(StatusByte: TMIDIStatusByte): Boolean;\r\nbegin\r\n Result := (StatusByte = FMIDIStatus) and\r\n ((StatusByte and $F0) <> $F0) and // is channel message\r\n RunningStatusEnabled;\r\nend;\r\n\r\nprocedure TJclMIDIOut.SendBalanceChange(Channel: TMIDIChannel; Value: TMidiDataByte);\r\nbegin\r\n SendControlChange(Channel, MIDICCBalance, Value);\r\nend;\r\n\r\nprocedure TJclMIDIOut.SendBalanceChangeHR(Channel: TMIDIChannel; Value: TMidiDataWord);\r\nbegin\r\n SendControlChangeHR(Channel, MIDICCBalance, Value);\r\nend;\r\n\r\nprocedure TJclMIDIOut.SendBreathControlChange(Channel: TMIDIChannel; Value: TMidiDataByte);\r\nbegin\r\n SendControlChange(Channel, MIDICCBreathControl, Value);\r\nend;\r\n\r\nprocedure TJclMIDIOut.SendBreathControlChangeHR(Channel: TMIDIChannel; Value: TMidiDataWord);\r\nbegin\r\n SendControlChangeHR(Channel, MIDICCBreathControl, Value);\r\nend;\r\n\r\nprocedure TJclMIDIOut.SendDataEntry(Channel: TMIDIChannel; Value: TMidiDataByte);\r\nbegin\r\n SendControlChange(Channel, MIDICCDataEntry, Value);\r\nend;\r\n\r\nprocedure TJclMIDIOut.SendDataEntryHR(Channel: TMIDIChannel; Value: TMidiDataWord);\r\nbegin\r\n SendControlChangeHR(Channel, MIDICCDataEntry, Value);\r\nend;\r\n\r\nprocedure TJclMIDIOut.SendExpressionChange(Channel: TMIDIChannel; Value: TMidiDataByte);\r\nbegin\r\n SendControlChange(Channel, MIDICCExpression, Value);\r\nend;\r\n\r\nprocedure TJclMIDIOut.SendExpressionChangeHR(Channel: TMIDIChannel; Value: TMidiDataWord);\r\nbegin\r\n SendControlChangeHR(Channel, MIDICCExpression, Value);\r\nend;\r\n\r\nprocedure TJclMIDIOut.SendFootControllerChange(Channel: TMIDIChannel; Value: TMidiDataByte);\r\nbegin\r\n SendControlChange(Channel, MIDICCFootController, Value);\r\nend;\r\n\r\nprocedure TJclMIDIOut.SendFootControllerChangeHR(Channel: TMIDIChannel; Value: TMidiDataWord);\r\nbegin\r\n SendControlChangeHR(Channel, MIDICCFootController, Value);\r\nend;\r\n\r\nprocedure TJclMIDIOut.SwitchHold2(Channel: TMIDIChannel; Value: Boolean);\r\nbegin\r\n SendSwitchChange(Channel, MIDICCHold2, Value);\r\nend;\r\n\r\nprocedure TJclMIDIOut.SwitchLegato(Channel: TMIDIChannel; Value: Boolean);\r\nbegin\r\n SendSwitchChange(Channel, MIDICCLegato, Value);\r\nend;\r\n\r\nprocedure TJclMIDIOut.SendChannelVolumeChange(Channel: TMIDIChannel;\r\n Value: TMidiDataByte);\r\nbegin\r\n SendControlChange(Channel, MIDICCChannelVolume, Value);\r\nend;\r\n\r\nprocedure TJclMIDIOut.SendChannelVolumeChangeHR(Channel: TMIDIChannel;\r\n Value: TMidiDataWord);\r\nbegin\r\n SendControlChangeHR(Channel, MIDICCChannelVolume, Value);\r\nend;\r\n\r\nprocedure TJclMIDIOut.SendModulationWheelChange(Channel: TMIDIChannel;\r\n Value: TMidiDataByte);\r\nbegin\r\n SendControlChange(Channel, MIDICCModulationWheel, Value);\r\nend;\r\n\r\nprocedure TJclMIDIOut.SendModulationWheelChangeHR(Channel: TMIDIChannel; Value: TMidiDataWord);\r\nbegin\r\n SendControlChangeHR(Channel, MIDICCModulationWheel, Value);\r\nend;\r\n\r\nprocedure TJclMIDIOut.SendPanChange(Channel: TMIDIChannel; Value: TMidiDataByte);\r\nbegin\r\n SendControlChange(Channel, MIDICCPan, Value);\r\nend;\r\n\r\nprocedure TJclMIDIOut.SendPanChangeHR(Channel: TMIDIChannel; Value: TMidiDataWord);\r\nbegin\r\n SendControlChangeHR(Channel, MIDICCPan, Value);\r\nend;\r\n\r\nprocedure TJclMIDIOut.SwitchPortamento(Channel: TMIDIChannel; Value: Boolean);\r\nbegin\r\n SendSwitchChange(Channel, MIDICCPortamento, Value);\r\nend;\r\n\r\nprocedure TJclMIDIOut.SendPortamentoTimeChange(Channel: TMIDIChannel;\r\n Value: TMidiDataByte);\r\nbegin\r\n SendControlChange(Channel, MIDICCPortamentoTime, Value);\r\nend;\r\n\r\nprocedure TJclMIDIOut.SendPortamentoTimeChangeHR(Channel: TMIDIChannel;\r\n Value: TMidiDataWord);\r\nbegin\r\n SendControlChangeHR(Channel, MIDICCPortamentoTime, Value);\r\nend;\r\n\r\nprocedure TJclMIDIOut.SwitchSoftPedal(Channel: TMIDIChannel; Value: Boolean);\r\nbegin\r\n SendSwitchChange(Channel, MIDICCSoftPedal, Value);\r\nend;\r\n\r\nprocedure TJclMIDIOut.SwitchSustain(Channel: TMIDIChannel; Value: Boolean);\r\nbegin\r\n SendSwitchChange(Channel, MIDICCSustain, Value);\r\nend;\r\n\r\nprocedure TJclMIDIOut.SwitchSostenuto(Channel: TMIDIChannel; Value: Boolean);\r\nbegin\r\n SendSwitchChange(Channel, MIDICCSustenuto, Value);\r\nend;\r\n\r\nprocedure TJclMIDIOut.SwitchOmniModeOff(Channel: TMIDIChannel);\r\nbegin\r\n SendControlChange(Channel, MIDICCOmniModeOff, 0);\r\n FActiveNotes[Channel] := []; // implicit All Notes Off\r\nend;\r\n\r\nprocedure TJclMIDIOut.SwitchOmniModeOn(Channel: TMIDIChannel);\r\nbegin\r\n SendControlChange(Channel, MIDICCOmniModeOn, 0);\r\n FActiveNotes[Channel] := []; // implicit All Notes Off\r\nend;\r\n\r\nprocedure TJclMIDIOut.SwitchMonoModeOn(Channel: TMIDIChannel; ChannelCount: Integer);\r\nbegin\r\n SendControlChange(Channel, MIDICCMonoModeOn, ChannelCount);\r\n FActiveNotes[Channel] := []; // implicit All Notes Off\r\nend;\r\n\r\nprocedure TJclMIDIOut.SwitchPolyModeOn(Channel: TMIDIChannel);\r\nbegin\r\n SendControlChange(Channel, MIDICCPolyModeOn, 0);\r\n FActiveNotes[Channel] := []; // implicit All Notes Off\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jcl/source/common/JclMath.pas", "content": "{**************************************************************************************************}\r\n{ }\r\n{ Project JEDI Code Library (JCL) }\r\n{ }\r\n{ The contents of this file are subject to the Mozilla Public License Version 1.1 (the \"License\"); }\r\n{ you may not use this file except in compliance with the License. You may obtain a copy of the }\r\n{ License at http://www.mozilla.org/MPL/ }\r\n{ }\r\n{ Software distributed under the License is distributed on an \"AS IS\" basis, WITHOUT WARRANTY OF }\r\n{ ANY KIND, either express or implied. See the License for the specific language governing rights }\r\n{ and limitations under the License. }\r\n{ }\r\n{ The Original Code is JclMath.pas. }\r\n{ }\r\n{ The Initial Developers of the Original Code are Clayton Collie, David Butler, ESB Consultancy, }\r\n{ Jean Debord, Marcel van Brakel and Michael Schnell. }\r\n{ Portions created by these individuals are Copyright (C) of these individuals. }\r\n{ All Rights Reserved. }\r\n{ }\r\n{ Contributors: }\r\n{ Ernesto Benestante }\r\n{ Marcel van Brakel }\r\n{ Aleksei Koudinov }\r\n{ Robert Marquardt (marquardt) }\r\n{ Robert Rossmair (rrossmair) }\r\n{ Matthias Thoma (mthoma) }\r\n{ Mark Vaughan }\r\n{ Andreas Hausladen }\r\n{ unknown }\r\n{ }\r\n{**************************************************************************************************}\r\n{ }\r\n{ Various mathematics classes and routines. Includes prime numbers, rational numbers, }\r\n{ complex numbers, generic floating point routines, hyperbolic and transcendenatal routines, }\r\n{ NAN and INF support and more. }\r\n{ }\r\n{**************************************************************************************************}\r\n{ }\r\n{ Last modified: $Date:: 2011-09-03 00:07:50 +0200 (sam. 03 sept. 2011) $ }\r\n{ Revision: $Rev:: 3599 $ }\r\n{ Author: $Author:: outchy $ }\r\n{ }\r\n{**************************************************************************************************}\r\n\r\nunit JclMath;\r\n\r\n{$I jcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n {$IFDEF HAS_UNITSCOPE}\r\n System.SysUtils, System.Classes,\r\n {$ELSE ~HAS_UNITSCOPE}\r\n SysUtils, Classes,\r\n {$ENDIF ~HAS_UNITSCOPE}\r\n JclBase;\r\n\r\n{ Mathematical constants }\r\n\r\nconst\r\n Bernstein: Float = 0.2801694990238691330364364912307; // Bernstein constant\r\n Cbrt2: Float = 1.2599210498948731647672106072782; // CubeRoot(2)\r\n Cbrt3: Float = 1.4422495703074083823216383107801; // CubeRoot(3)\r\n Cbrt10: Float = 2.1544346900318837217592935665194; // CubeRoot(10)\r\n Cbrt100: Float = 4.6415888336127788924100763509194; // CubeRoot(100)\r\n CbrtPi: Float = 1.4645918875615232630201425272638; // CubeRoot(PI)\r\n Catalan: Float = 0.9159655941772190150546035149324; // Catalan constant\r\n Pi: Float = 3.1415926535897932384626433832795; // PI\r\n PiOn2: Float = 1.5707963267948966192313216916398; // PI / 2\r\n PiOn3: Float = 1.0471975511965977461542144610932; // PI / 3\r\n PiOn4: Float = 0.78539816339744830961566084581988; // PI / 4\r\n Sqrt2: Float = 1.4142135623730950488016887242097; // Sqrt(2)\r\n Sqrt3: Float = 1.7320508075688772935274463415059; // Sqrt(3)\r\n Sqrt5: Float = 2.2360679774997896964091736687313; // Sqrt(5)\r\n Sqrt10: Float = 3.1622776601683793319988935444327; // Sqrt(10)\r\n SqrtPi: Float = 1.7724538509055160272981674833411; // Sqrt(PI)\r\n Sqrt2Pi: Float = 2.506628274631000502415765284811; // Sqrt(2 * PI)\r\n TwoPi: Float = 6.283185307179586476925286766559; // 2 * PI\r\n ThreePi: Float = 9.4247779607693797153879301498385; // 3 * PI\r\n Ln2: Float = 0.69314718055994530941723212145818; // Ln(2)\r\n Ln10: Float = 2.3025850929940456840179914546844; // Ln(10)\r\n LnPi: Float = 1.1447298858494001741434273513531; // Ln(PI)\r\n Log2: Float = 0.30102999566398119521373889472449; // Log10(2)\r\n Log3: Float = 0.47712125471966243729502790325512; // Log10(3)\r\n LogPi: Float = 0.4971498726941338543512682882909; // Log10(PI)\r\n LogE: Float = 0.43429448190325182765112891891661; // Log10(E)\r\n E: Float = 2.7182818284590452353602874713527; // Natural constant\r\n hLn2Pi: Float = 0.91893853320467274178032973640562; // Ln(2*PI)/2\r\n inv2Pi: Float = 0.15915494309189533576888376337251436203445964574046; // 0.5 / Pi\r\n TwoToPower63: Float = 9223372036854775808.0; // 2^63\r\n GoldenMean: Float = 1.618033988749894848204586834365638; // GoldenMean\r\n EulerMascheroni: Float = 0.5772156649015328606065120900824; // Euler GAMMA\r\n\r\nconst\r\n MaxAngle: Float = 9223372036854775808.0; // 2^63 Rad\r\n\r\n {$IFDEF MATH_EXTENDED_PRECISION}\r\n MaxTanH: Float = 5678.2617031470719747459655389854; // Ln(2^16384)/2\r\n MaxFactorial = 1754;\r\n MaxFloatingPoint: Float = 1.189731495357231765085759326628E+4932; // 2^16384\r\n MinFloatingPoint: Float = 3.3621031431120935062626778173218E-4932; // 2^(-16382)\r\n {$ENDIF MATH_EXTENDED_PRECISION}\r\n {$IFDEF MATH_DOUBLE_PRECISION}\r\n MaxTanH: Float = 354.89135644669199842162284618659; // Ln(2^1024)/2\r\n MaxFactorial = 170;\r\n MaxFloatingPoint: Float = 1.797693134862315907729305190789E+308; // 2^1024\r\n MinFloatingPoint: Float = 2.2250738585072013830902327173324E-308; // 2^(-1022)\r\n {$ENDIF MATH_DOUBLE_PRECISION}\r\n {$IFDEF MATH_SINGLE_PRECISION}\r\n MaxTanH: Float = 44.361419555836499802702855773323; // Ln(2^128)/2\r\n MaxFactorial = 33;\r\n MaxFloatingPoint: Float = 3.4028236692093846346337460743177E+38; // 2^128\r\n MinFloatingPoint: Float = 1.1754943508222875079687365372222E-38; // 2^(-126)\r\n {$ENDIF MATH_SINGLE_PRECISION}\r\n\r\nconst\r\n PiExt = 3.1415926535897932384626433832795;\r\n RatioDegToRad : Extended = PiExt / 180.0;\r\n RatioRadToDeg : Extended = 180.0 / PiExt;\r\n RatioGradToRad : Extended = PiExt / 200.0;\r\n RatioRadToGrad : Extended = 200.0 / PiExt;\r\n RatioDegToGrad : Extended = 200.0 / 180.0;\r\n RatioGradToDeg : Extended = 180.0 / 200.0;\r\n\r\nvar\r\n PrecisionTolerance: Float = 0.0000001;\r\n EpsSingle: Single;\r\n EpsDouble: Double;\r\n {$IFDEF SUPPORTS_EXTENDED}\r\n EpsExtended: Extended;\r\n {$ENDIF SUPPORTS_EXTENDED}\r\n Epsilon: Float;\r\n ThreeEpsSingle: Single;\r\n ThreeEpsDouble: Double;\r\n {$IFDEF SUPPORTS_EXTENDED}\r\n ThreeEpsExtended: Extended;\r\n {$ENDIF SUPPORTS_EXTENDED}\r\n ThreeEpsilon: Float;\r\n\r\ntype\r\n TPrimalityTestMethod = (ptTrialDivision {$IFDEF CPU32}, ptRabinMiller{$ENDIF CPU32});\r\n\r\n// swaps 2 bytes\r\nprocedure SwapOrd(var X, Y: Integer); {$IFDEF SUPPORTS_INLINE}inline;{$ENDIF}\r\n\r\n// converts double to hex\r\nfunction DoubleToHex(const D: Double): string; {$IFDEF SUPPORTS_INLINE}inline;{$ENDIF}\r\n// converts hex to double\r\nfunction HexToDouble(const Hex: string): Double;\r\n\r\n// Converts degrees to radians.\r\n{$IFDEF SUPPORTS_EXTENDED}\r\nfunction DegToRad(const Value: Extended): Extended; overload; {$IFDEF SUPPORTS_INLINE}inline;{$ENDIF}\r\n{$ENDIF SUPPORTS_EXTENDED}\r\nfunction DegToRad(const Value: Double): Double; overload; {$IFDEF SUPPORTS_INLINE}inline;{$ENDIF}\r\nfunction DegToRad(const Value: Single): Single; overload; {$IFDEF SUPPORTS_INLINE}inline;{$ENDIF}\r\nprocedure FastDegToRad;\r\n\r\n// Converts radians to degrees.\r\n{$IFDEF SUPPORTS_EXTENDED}\r\nfunction RadToDeg(const Value: Extended): Extended; overload; {$IFDEF SUPPORTS_INLINE}inline;{$ENDIF}\r\n{$ENDIF SUPPORTS_EXTENDED}\r\nfunction RadToDeg(const Value: Double): Double; overload; {$IFDEF SUPPORTS_INLINE}inline;{$ENDIF}\r\nfunction RadToDeg(const Value: Single): Single; overload; {$IFDEF SUPPORTS_INLINE}inline;{$ENDIF}\r\nprocedure FastRadToDeg;\r\n\r\n// Converts grads to radians.\r\n{$IFDEF SUPPORTS_EXTENDED}\r\nfunction GradToRad(const Value: Extended): Extended; overload; {$IFDEF SUPPORTS_INLINE}inline;{$ENDIF}\r\n{$ENDIF SUPPORTS_EXTENDED}\r\nfunction GradToRad(const Value: Double): Double; overload; {$IFDEF SUPPORTS_INLINE}inline;{$ENDIF}\r\nfunction GradToRad(const Value: Single): Single; overload; {$IFDEF SUPPORTS_INLINE}inline;{$ENDIF}\r\nprocedure FastGradToRad;\r\n\r\n// Converts radians to grads.\r\n{$IFDEF SUPPORTS_EXTENDED}\r\nfunction RadToGrad(const Value: Extended): Extended; overload; {$IFDEF SUPPORTS_INLINE}inline;{$ENDIF}\r\n{$ENDIF SUPPORTS_EXTENDED}\r\nfunction RadToGrad(const Value: Double): Double; overload; {$IFDEF SUPPORTS_INLINE}inline;{$ENDIF}\r\nfunction RadToGrad(const Value: Single): Single; overload; {$IFDEF SUPPORTS_INLINE}inline;{$ENDIF}\r\nprocedure FastRadToGrad;\r\n\r\n// Converts degrees to grads.\r\n{$IFDEF SUPPORTS_EXTENDED}\r\nfunction DegToGrad(const Value: Extended): Extended; overload; {$IFDEF SUPPORTS_INLINE}inline;{$ENDIF}\r\n{$ENDIF SUPPORTS_EXTENDED}\r\nfunction DegToGrad(const Value: Double): Double; overload; {$IFDEF SUPPORTS_INLINE}inline;{$ENDIF}\r\nfunction DegToGrad(const Value: Single): Single; overload; {$IFDEF SUPPORTS_INLINE}inline;{$ENDIF}\r\nprocedure FastDegToGrad;\r\n\r\n// Converts grads to degrees.\r\n{$IFDEF SUPPORTS_EXTENDED}\r\nfunction GradToDeg(const Value: Extended): Extended; overload; {$IFDEF SUPPORTS_INLINE}inline;{$ENDIF}\r\n{$ENDIF SUPPORTS_EXTENDED}\r\nfunction GradToDeg(const Value: Double): Double; overload; {$IFDEF SUPPORTS_INLINE}inline;{$ENDIF}\r\nfunction GradToDeg(const Value: Single): Single; overload; {$IFDEF SUPPORTS_INLINE}inline;{$ENDIF}\r\nprocedure FastGradToDeg;\r\n\r\n{ Logarithmic }\r\n\r\nfunction LogBase10(X: Float): Float;\r\nfunction LogBase2(X: Float): Float;\r\nfunction LogBaseN(Base, X: Float): Float;\r\n\r\n{ Transcendental }\r\n\r\nfunction ArcCos(X: Float): Float;\r\nfunction ArcCot(X: Float): Float; {$IFDEF SUPPORTS_INLINE}inline;{$ENDIF}\r\nfunction ArcCsc(X: Float): Float; {$IFDEF SUPPORTS_INLINE}inline;{$ENDIF}\r\nfunction ArcSec(X: Float): Float;\r\nfunction ArcSin(X: Float): Float;\r\nfunction ArcTan(X: Float): Float;\r\nfunction ArcTan2(Y, X: Float): Float;\r\nfunction Cos(X: Float): Float; overload;\r\nfunction Cot(X: Float): Float; overload;\r\nfunction Coversine(X: Float): Float; {$IFDEF SUPPORTS_INLINE}inline;{$ENDIF}\r\nfunction Csc(X: Float): Float; overload;\r\nfunction Exsecans(X: Float): Float; {$IFDEF SUPPORTS_INLINE}inline;{$ENDIF}\r\nfunction Haversine(X: Float): Float; {$IFDEF SUPPORTS_INLINE}inline;{$ENDIF}\r\nfunction Sec(X: Float): Float; overload;\r\nfunction Sin(X: Float): Float; overload;\r\nprocedure SinCos(X: Single; out Sin, Cos: Single); overload;\r\nprocedure SinCos(X: Double; out Sin, Cos: Double); overload;\r\n{$IFDEF SUPPORTS_EXTENDED}\r\nprocedure SinCos(X: Extended; out Sin, Cos: Extended); overload;\r\n{$ENDIF SUPPORTS_EXTENDED}\r\nfunction Tan(X: Float): Float; overload;\r\nfunction Versine(X: Float): Float; {$IFDEF SUPPORTS_INLINE}inline;{$ENDIF}\r\n\r\n{ Hyperbolic }\r\n\r\nfunction ArcCosH(X: Float): Float;\r\nfunction ArcCotH(X: Float): Float;\r\nfunction ArcCscH(X: Float): Float;\r\nfunction ArcSecH(X: Float): Float;\r\nfunction ArcSinH(X: Float): Float;\r\nfunction ArcTanH(X: Float): Float;\r\nfunction CosH(X: Float): Float; overload;\r\nfunction CotH(X: Float): Float; overload; {$IFDEF SUPPORTS_INLINE}inline;{$ENDIF}\r\nfunction CscH(X: Float): Float; overload;\r\nfunction SecH(X: Float): Float; overload;\r\nfunction SinH(X: Float): Float; overload; {IFDEF SUPPORTS_INLINE inline; ENDIF}\r\nfunction TanH(X: Float): Float; overload;\r\n\r\n{ Coordinate conversion }\r\n\r\nfunction DegMinSecToFloat(const Degs, Mins, Secs: Float): Float; // obsolete (see JclUnitConv)\r\nprocedure FloatToDegMinSec(const X: Float; var Degs, Mins, Secs: Float); // obsolete (see JclUnitConv)\r\n\r\n{ Exponential }\r\n\r\nfunction Exp(const X: Float): Float; overload;\r\nfunction Power(const Base, Exponent: Float): Float; overload;\r\nfunction PowerInt(const X: Float; N: Integer): Float; overload;\r\nfunction TenToY(const Y: Float): Float; {$IFDEF SUPPORTS_INLINE}inline;{$ENDIF}\r\nfunction TruncPower(const Base, Exponent: Float): Float; {$IFDEF SUPPORTS_INLINE}inline;{$ENDIF}\r\nfunction TwoToY(const Y: Float): Float; {$IFDEF SUPPORTS_INLINE}inline;{$ENDIF}\r\n\r\n{ Floating point numbers support routines }\r\n\r\nfunction IsFloatZero(const X: Float): Boolean; {$IFDEF SUPPORTS_INLINE}inline;{$ENDIF}\r\nfunction FloatsEqual(const X, Y: Float): Boolean;\r\nfunction MaxFloat(const X, Y: Float): Float; {$IFDEF SUPPORTS_INLINE}inline;{$ENDIF}\r\nfunction MinFloat(const X, Y: Float): Float; {$IFDEF SUPPORTS_INLINE}inline;{$ENDIF}\r\nfunction ModFloat(const X, Y: Float): Float;\r\nfunction RemainderFloat(const X, Y: Float): Float; {$IFDEF SUPPORTS_INLINE}inline;{$ENDIF}\r\nfunction SetPrecisionTolerance(NewTolerance: Float): Float; {$IFDEF SUPPORTS_INLINE}inline;{$ENDIF}\r\nprocedure SwapFloats(var X, Y: Float); {$IFDEF SUPPORTS_INLINE}inline;{$ENDIF}\r\nprocedure CalcMachineEpsSingle;\r\nprocedure CalcMachineEpsDouble;\r\n{$IFDEF SUPPORTS_EXTENDED}\r\nprocedure CalcMachineEpsExtended;\r\n{$ENDIF SUPPORTS_EXTENDED}\r\nprocedure CalcMachineEps;\r\nprocedure SetPrecisionToleranceToEpsilon; {$IFDEF SUPPORTS_INLINE}inline;{$ENDIF}\r\n\r\n{ Miscellaneous }\r\n\r\nfunction Ackermann(const A, B: Integer): Integer;\r\nfunction Ceiling(const X: Float): Integer;\r\nfunction CommercialRound(const X: Float): Int64;\r\nfunction Factorial(const N: Integer): Float;\r\nfunction Fibonacci(const N: Integer): Integer;\r\nfunction Floor(const X: Float): Integer;\r\nfunction GCD(X, Y: Cardinal): Cardinal;\r\nfunction ISqrt(const I: Smallint): Smallint;\r\nfunction LCM(const X, Y: Cardinal): Cardinal;\r\nfunction NormalizeAngle(const Angle: Float): Float;\r\nfunction Pythagoras(const X, Y: Float): Float;\r\nfunction Sgn(const X: Float): Integer;\r\nfunction Signe(const X, Y: Float): Float;\r\n\r\n{ Ranges }\r\nfunction EnsureRange(const AValue, AMin, AMax: Integer): Integer; overload;\r\nfunction EnsureRange(const AValue, AMin, AMax: Int64): Int64; overload;\r\nfunction EnsureRange(const AValue, AMin, AMax: Double): Double; overload;\r\n\r\n{ Prime numbers }\r\n\r\nfunction IsRelativePrime(const X, Y: Cardinal): Boolean; {$IFDEF SUPPORTS_INLINE}inline;{$ENDIF}\r\nfunction IsPrimeTD(N: Cardinal): Boolean;\r\n{$IFDEF CPU32}\r\nfunction IsPrimeRM(N: Cardinal): Boolean;\r\n{$ENDIF CPU32}\r\nfunction IsPrimeFactor(const F, N: Cardinal): Boolean; {$IFDEF SUPPORTS_INLINE}inline;{$ENDIF}\r\nfunction PrimeFactors(N: Cardinal): TDynCardinalArray;\r\n\r\nvar\r\n IsPrime: function(N: Cardinal): Boolean = IsPrimeTD;\r\n\r\nprocedure SetPrimalityTest(const Method: TPrimalityTestMethod);\r\n\r\n{ Floating point value classification }\r\n\r\ntype\r\n TFloatingPointClass =\r\n (\r\n fpZero, // zero\r\n fpNormal, // normal finite <> 0\r\n fpDenormal, // denormalized finite\r\n fpInfinite, // infinite\r\n fpNaN, // not a number\r\n fpInvalid, // unsupported floating point format\r\n fpEmpty // should not happen\r\n );\r\n\r\nconst\r\n Infinity = 1/0; // tricky\r\n {$EXTERNALSYM Infinity}\r\n NaN = 0/0; // tricky\r\n {$EXTERNALSYM NaN}\r\n NegInfinity = -Infinity;\r\n {$EXTERNALSYM NegInfinity}\r\n\r\n{$HPPEMIT 'static const Infinity = 1.0 / 0.0;'}\r\n{$HPPEMIT 'static const NaN = 0.0 / 0.0;'}\r\n{$HPPEMIT 'static const NegInfinity = -1.0 / 0.0;'}\r\n\r\n{$IFDEF CPU32}\r\n\r\nfunction FloatingPointClass(const Value: Single): TFloatingPointClass; overload;\r\nfunction FloatingPointClass(const Value: Double): TFloatingPointClass; overload;\r\n{$IFDEF SUPPORTS_EXTENDED}\r\nfunction FloatingPointClass(const Value: Extended): TFloatingPointClass; overload;\r\n{$ENDIF SUPPORTS_EXTENDED}\r\n\r\n{ NaN and INF support }\r\n\r\ntype\r\n TNaNTag = type Integer;\r\n\r\nconst\r\n LowValidNaNTag = -$3FFFFF;\r\n HighValidNaNTag = $3FFFFE;\r\n\r\nfunction IsInfinite(const Value: Single): Boolean; overload; {$IFDEF SUPPORTS_INLINE}inline;{$ENDIF}\r\nfunction IsInfinite(const Value: Double): Boolean; overload; {$IFDEF SUPPORTS_INLINE}inline;{$ENDIF}\r\n{$IFDEF SUPPORTS_EXTENDED}\r\nfunction IsInfinite(const Value: Extended): Boolean; overload; {$IFDEF SUPPORTS_INLINE}inline;{$ENDIF}\r\n{$ENDIF SUPPORTS_EXTENDED}\r\n\r\nfunction IsNaN(const Value: Single): Boolean; overload; {$IFDEF SUPPORTS_INLINE}inline;{$ENDIF}\r\nfunction IsNaN(const Value: Double): Boolean; overload; {$IFDEF SUPPORTS_INLINE}inline;{$ENDIF}\r\n{$IFDEF SUPPORTS_EXTENDED}\r\nfunction IsNaN(const Value: Extended): Boolean; overload; {$IFDEF SUPPORTS_INLINE}inline;{$ENDIF}\r\n{$ENDIF SUPPORTS_EXTENDED}\r\n\r\nfunction IsSpecialValue(const X: Float): Boolean; {$IFDEF SUPPORTS_INLINE}inline;{$ENDIF}\r\n\r\nprocedure MakeQuietNaN(var X: Single; Tag: TNaNTag = 0); overload;\r\nprocedure MakeQuietNaN(var X: Double; Tag: TNaNTag = 0); overload;\r\n{$IFDEF SUPPORTS_EXTENDED}\r\nprocedure MakeQuietNaN(var X: Extended; Tag: TNaNTag = 0); overload;\r\n{$ENDIF SUPPORTS_EXTENDED}\r\n\r\nprocedure MakeSignalingNaN(var X: Single; Tag: TNaNTag = 0); overload;\r\nprocedure MakeSignalingNaN(var X: Double; Tag: TNaNTag = 0); overload;\r\n{$IFDEF SUPPORTS_EXTENDED}\r\nprocedure MakeSignalingNaN(var X: Extended; Tag: TNaNTag = 0); overload;\r\n{$ENDIF SUPPORTS_EXTENDED}\r\n\r\n{ Mine*Buffer fills \"Buffer\" with consecutive tagged signaling NaNs.\r\n\r\n This allows for real number arrays which enforce initialization: any attempt\r\n to load an uninitialized array element into the FPU will raise an exception\r\n either of class EInvalidOp (Windows 9x/ME) or EJclNaNSignal (Windows NT).\r\n\r\n Under Windows NT it is thus possible to derive the violating array index from\r\n the EJclNaNSignal object's Tag property. }\r\n\r\nprocedure MineSingleBuffer(var Buffer; Count: Integer; StartTag: TNaNTag = 0);\r\nprocedure MineDoubleBuffer(var Buffer; Count: Integer; StartTag: TNaNTag = 0);\r\n\r\nfunction MinedSingleArray(Length: Integer): TDynSingleArray;\r\nfunction MinedDoubleArray(Length: Integer): TDynDoubleArray;\r\n\r\nfunction GetNaNTag(const NaN: Single): TNaNTag; overload;\r\nfunction GetNaNTag(const NaN: Double): TNaNTag; overload;\r\n{$IFDEF SUPPORTS_EXTENDED}\r\nfunction GetNaNTag(const NaN: Extended): TNaNTag; overload;\r\n{$ENDIF SUPPORTS_EXTENDED}\r\n\r\n{$ENDIF CPU32}\r\n\r\n{ Set support }\r\n\r\ntype\r\n TJclASet = class(TObject)\r\n public\r\n function GetBit(const Idx: Integer): Boolean; virtual; abstract;\r\n procedure SetBit(const Idx: Integer; const Value: Boolean); virtual; abstract;\r\n procedure Clear; virtual; abstract;\r\n procedure Invert; virtual; abstract;\r\n function GetRange(const Low, High: Integer; const Value: Boolean): Boolean; virtual; abstract;\r\n procedure SetRange(const Low, High: Integer; const Value: Boolean); virtual; abstract;\r\n end;\r\n\r\ntype\r\n TJclFlatSet = class(TJclASet)\r\n private\r\n FBits: TBits;\r\n public\r\n constructor Create;\r\n destructor Destroy; override;\r\n procedure Clear; override;\r\n procedure Invert; override;\r\n procedure SetRange(const Low, High: Integer; const Value: Boolean); override;\r\n function GetBit(const Idx: Integer): Boolean; override;\r\n function GetRange(const Low, High: Integer; const Value: Boolean): Boolean; override;\r\n procedure SetBit(const Idx: Integer; const Value: Boolean); override;\r\n end;\r\n\r\ntype\r\n {$IFNDEF FPC}\r\n TPointerArray = array [0..MaxLongint div 256] of Pointer;\r\n PPointerArray = ^TPointerArray;\r\n {$ENDIF ~FPC}\r\n TDelphiSet = set of Byte; // 256 elements\r\n PDelphiSet = ^TDelphiSet;\r\n\r\nconst\r\n EmptyDelphiSet: TDelphiSet = [];\r\n CompleteDelphiSet: TDelphiSet = [0..255];\r\n\r\ntype\r\n TJclSparseFlatSet = class(TJclASet)\r\n private\r\n FSetList: PPointerArray;\r\n FSetListEntries: Integer;\r\n public\r\n destructor Destroy; override;\r\n procedure Clear; override;\r\n procedure Invert; override;\r\n function GetBit(const Idx: Integer): Boolean; override;\r\n procedure SetBit(const Idx: Integer; const Value: Boolean); override;\r\n procedure SetRange(const Low, High: Integer; const Value: Boolean); override;\r\n function GetRange(const Low, High: Integer; const Value: Boolean): Boolean; override;\r\n end;\r\n\r\n{ Rational numbers }\r\n\r\ntype\r\n TJclRational = class(TObject)\r\n private\r\n FT: Integer;\r\n FN: Integer;\r\n function GetAsString: string;\r\n procedure SetAsString(const S: string);\r\n function GetAsFloat: Float;\r\n procedure SetAsFloat(const R: Float);\r\n protected\r\n procedure Simplify;\r\n public\r\n constructor Create; overload;\r\n constructor Create(const R: Float); overload;\r\n constructor Create(const Numerator: Integer; const Denominator: Integer = 1); overload;\r\n\r\n property Numerator: Integer read FT;\r\n property Denominator: Integer read FN;\r\n property AsString: string read GetAsString write SetAsString;\r\n property AsFloat: Float read GetAsFloat write SetAsFloat;\r\n\r\n procedure Assign(const R: TJclRational); overload; {$IFDEF SUPPORTS_INLINE}inline;{$ENDIF}\r\n procedure Assign(const R: Float); overload;\r\n procedure Assign(const Numerator: Integer; const Denominator: Integer = 1); overload;\r\n\r\n procedure AssignZero; {$IFDEF SUPPORTS_INLINE}inline;{$ENDIF}\r\n procedure AssignOne; {$IFDEF SUPPORTS_INLINE}inline;{$ENDIF}\r\n function Duplicate: TJclRational; {$IFDEF SUPPORTS_INLINE}inline;{$ENDIF}\r\n\r\n function IsEqual(const R: TJclRational): Boolean; reintroduce; overload; {$IFDEF SUPPORTS_INLINE}inline;{$ENDIF}\r\n function IsEqual(const Numerator: Integer; const Denominator: Integer = 1) : Boolean; reintroduce; overload; {$IFDEF SUPPORTS_INLINE}inline;{$ENDIF}\r\n function IsEqual(const R: Float): Boolean; reintroduce; overload; {$IFDEF SUPPORTS_INLINE}inline;{$ENDIF}\r\n\r\n function IsZero: Boolean; {$IFDEF SUPPORTS_INLINE}inline;{$ENDIF}\r\n function IsOne: Boolean; {$IFDEF SUPPORTS_INLINE}inline;{$ENDIF}\r\n\r\n procedure Add(const R: TJclRational); overload;\r\n procedure Add(const V: Float); overload; {$IFDEF SUPPORTS_INLINE}inline;{$ENDIF}\r\n procedure Add(const V: Integer); overload; {$IFDEF SUPPORTS_INLINE}inline;{$ENDIF}\r\n\r\n procedure Subtract(const R: TJclRational); overload;\r\n procedure Subtract(const V: Float); overload; {$IFDEF SUPPORTS_INLINE}inline;{$ENDIF}\r\n procedure Subtract(const V: Integer); overload; {$IFDEF SUPPORTS_INLINE}inline;{$ENDIF}\r\n\r\n procedure Negate; {$IFDEF SUPPORTS_INLINE}inline;{$ENDIF}\r\n procedure Abs;\r\n function Sgn: Integer;\r\n\r\n procedure Multiply(const R: TJclRational); overload;\r\n procedure Multiply(const V: Float); overload; {$IFDEF SUPPORTS_INLINE}inline;{$ENDIF}\r\n procedure Multiply(const V: Integer); overload; {$IFDEF SUPPORTS_INLINE}inline;{$ENDIF}\r\n\r\n procedure Reciprocal;\r\n\r\n procedure Divide(const R: TJclRational); overload;\r\n procedure Divide(const V: Float); overload; {$IFDEF SUPPORTS_INLINE}inline;{$ENDIF}\r\n procedure Divide(const V: Integer); overload;\r\n\r\n procedure Sqrt; {$IFDEF SUPPORTS_INLINE}inline;{$ENDIF}\r\n procedure Sqr; {$IFDEF SUPPORTS_INLINE}inline;{$ENDIF}\r\n\r\n procedure Power(const R: TJclRational); overload;\r\n procedure Power(const V: Integer); overload;\r\n procedure Power(const V: Float); overload;\r\n end;\r\n\r\ntype\r\n EJclMathError = class(EJclError);\r\n\r\n {$IFDEF CPU32}\r\n EJclNaNSignal = class(EJclMathError)\r\n private\r\n FTag: TNaNTag;\r\n public\r\n constructor Create(ATag: TNaNTag; Dummy: Boolean = False);\r\n property Tag: TNaNTag read FTag;\r\n end;\r\n {$ENDIF CPU32}\r\n\r\nprocedure DomainCheck(Err: Boolean);\r\n\r\n{ Checksums }\r\n\r\nfunction GetParity(Buffer: TDynByteArray; Len: Integer): Boolean; overload;\r\nfunction GetParity(Buffer: PByte; Len: Integer): Boolean; overload;\r\n\r\n{ CRC-16 }\r\n\r\ntype\r\n TCrc16Table = array [0..255] of Word;\r\n\r\nvar\r\n // CRC16Polynom = $1021;\r\n Crc16DefaultTable: TCrc16Table = (\r\n $0000, $1021, $2042, $3063, $4084, $50A5, $60C6, $70E7,\r\n $8108, $9129, $A14A, $B16B, $C18C, $D1AD, $E1CE, $F1EF,\r\n $1231, $0210, $3273, $2252, $52B5, $4294, $72F7, $62D6,\r\n $9339, $8318, $B37B, $A35A, $D3BD, $C39C, $F3FF, $E3DE,\r\n $2462, $3443, $0420, $1401, $64E6, $74C7, $44A4, $5485,\r\n $A56A, $B54B, $8528, $9509, $E5EE, $F5CF, $C5AC, $D58D,\r\n $3653, $2672, $1611, $0630, $76D7, $66F6, $5695, $46B4,\r\n $B75B, $A77A, $9719, $8738, $F7DF, $E7FE, $D79D, $C7BC,\r\n $48C4, $58E5, $6886, $78A7, $0840, $1861, $2802, $3823,\r\n $C9CC, $D9ED, $E98E, $F9AF, $8948, $9969, $A90A, $B92B,\r\n $5AF5, $4AD4, $7AB7, $6A96, $1A71, $0A50, $3A33, $2A12,\r\n $DBFD, $CBDC, $FBBF, $EB9E, $9B79, $8B58, $BB3B, $AB1A,\r\n $6CA6, $7C87, $4CE4, $5CC5, $2C22, $3C03, $0C60, $1C41,\r\n $EDAE, $FD8F, $CDEC, $DDCD, $AD2A, $BD0B, $8D68, $9D49,\r\n $7E97, $6EB6, $5ED5, $4EF4, $3E13, $2E32, $1E51, $0E70,\r\n $FF9F, $EFBE, $DFDD, $CFFC, $BF1B, $AF3A, $9F59, $8F78,\r\n $9188, $81A9, $B1CA, $A1EB, $D10C, $C12D, $F14E, $E16F,\r\n $1080, $00A1, $30C2, $20E3, $5004, $4025, $7046, $6067,\r\n $83B9, $9398, $A3FB, $B3DA, $C33D, $D31C, $E37F, $F35E,\r\n $02B1, $1290, $22F3, $32D2, $4235, $5214, $6277, $7256,\r\n $B5EA, $A5CB, $95A8, $8589, $F56E, $E54F, $D52C, $C50D,\r\n $34E2, $24C3, $14A0, $0481, $7466, $6447, $5424, $4405,\r\n $A7DB, $B7FA, $8799, $97B8, $E75F, $F77E, $C71D, $D73C,\r\n $26D3, $36F2, $0691, $16B0, $6657, $7676, $4615, $5634,\r\n $D94C, $C96D, $F90E, $E92F, $99C8, $89E9, $B98A, $A9AB,\r\n $5844, $4865, $7806, $6827, $18C0, $08E1, $3882, $28A3,\r\n $CB7D, $DB5C, $EB3F, $FB1E, $8BF9, $9BD8, $ABBB, $BB9A,\r\n $4A75, $5A54, $6A37, $7A16, $0AF1, $1AD0, $2AB3, $3A92,\r\n $FD2E, $ED0F, $DD6C, $CD4D, $BDAA, $AD8B, $9DE8, $8DC9,\r\n $7C26, $6C07, $5C64, $4C45, $3CA2, $2C83, $1CE0, $0CC1,\r\n $EF1F, $FF3E, $CF5D, $DF7C, $AF9B, $BFBA, $8FD9, $9FF8,\r\n $6E17, $7E36, $4E55, $5E74, $2E93, $3EB2, $0ED1, $1EF0\r\n );\r\n Crc16DefaultStart: Cardinal = $FFFF;\r\n\r\nconst\r\n Crc16PolynomCCITT = $1021;\r\n Crc16PolynomIBM = $8005;\r\n Crc16Bits = 16;\r\n Crc16Bytes = 2;\r\n Crc16HighBit = $8000;\r\n NotCrc16HighBit = $7FFF;\r\n\r\n// for backward compatibility (default polynom = CCITT = $1021)\r\nfunction Crc16_P(X: PJclByteArray; N: Integer; Crc: Word = 0): Word; overload;\r\nfunction Crc16(const X: array of Byte; N: Integer; Crc: Word = 0): Word; overload;\r\nfunction Crc16_A(const X: array of Byte; Crc: Word = 0): Word; overload;\r\n\r\nfunction CheckCrc16_P(X: PJclByteArray; N: Integer; Crc: Word): Integer; overload;\r\nfunction CheckCrc16(var X: array of Byte; N: Integer; Crc: Word): Integer; overload;\r\nfunction CheckCrc16_A(var X: array of Byte; Crc: Word): Integer; overload;\r\n\r\n// change the default polynom\r\nprocedure InitCrc16(Polynom, Start: Word); overload;\r\n\r\n// arbitrary polynom\r\nfunction Crc16_P(const Crc16Table: TCrc16Table; X: PJclByteArray; N: Integer; Crc: Word = 0): Word; overload;\r\nfunction Crc16(const Crc16Table: TCrc16Table; const X: array of Byte; N: Integer; Crc: Word = 0): Word; overload;\r\nfunction Crc16_A(const Crc16Table: TCrc16Table; const X: array of Byte; Crc: Word = 0): Word; overload;\r\n\r\nfunction CheckCrc16_P(const Crc16Table: TCrc16Table; X: PJclByteArray; N: Integer; Crc: Word): Integer; overload;\r\nfunction CheckCrc16(const Crc16Table: TCrc16Table; var X: array of Byte; N: Integer; Crc: Word): Integer; overload;\r\nfunction CheckCrc16_A(const Crc16Table: TCrc16Table; var X: array of Byte; Crc: Word): Integer; overload;\r\n\r\n// initialize a table\r\nprocedure InitCrc16(Polynom, Start: Word; out Crc16Table: TCrc16Table); overload;\r\n\r\n{ CRC-32 }\r\n\r\ntype\r\n TCrc32Table = array [0..255] of Cardinal;\r\n\r\nvar\r\n // CRC32Polynom = $04C11DB7;\r\n Crc32DefaultTable: TCrc32Table = (\r\n $00000000, $04C11DB7, $09823B6E, $0D4326D9, $130476DC, $17C56B6B, $1A864DB2, $1E475005,\r\n $2608EDB8, $22C9F00F, $2F8AD6D6, $2B4BCB61, $350C9B64, $31CD86D3, $3C8EA00A, $384FBDBD,\r\n $4C11DB70, $48D0C6C7, $4593E01E, $4152FDA9, $5F15ADAC, $5BD4B01B, $569796C2, $52568B75,\r\n $6A1936C8, $6ED82B7F, $639B0DA6, $675A1011, $791D4014, $7DDC5DA3, $709F7B7A, $745E66CD,\r\n $9823B6E0, $9CE2AB57, $91A18D8E, $95609039, $8B27C03C, $8FE6DD8B, $82A5FB52, $8664E6E5,\r\n $BE2B5B58, $BAEA46EF, $B7A96036, $B3687D81, $AD2F2D84, $A9EE3033, $A4AD16EA, $A06C0B5D,\r\n $D4326D90, $D0F37027, $DDB056FE, $D9714B49, $C7361B4C, $C3F706FB, $CEB42022, $CA753D95,\r\n $F23A8028, $F6FB9D9F, $FBB8BB46, $FF79A6F1, $E13EF6F4, $E5FFEB43, $E8BCCD9A, $EC7DD02D,\r\n $34867077, $30476DC0, $3D044B19, $39C556AE, $278206AB, $23431B1C, $2E003DC5, $2AC12072,\r\n $128E9DCF, $164F8078, $1B0CA6A1, $1FCDBB16, $018AEB13, $054BF6A4, $0808D07D, $0CC9CDCA,\r\n $7897AB07, $7C56B6B0, $71159069, $75D48DDE, $6B93DDDB, $6F52C06C, $6211E6B5, $66D0FB02,\r\n $5E9F46BF, $5A5E5B08, $571D7DD1, $53DC6066, $4D9B3063, $495A2DD4, $44190B0D, $40D816BA,\r\n $ACA5C697, $A864DB20, $A527FDF9, $A1E6E04E, $BFA1B04B, $BB60ADFC, $B6238B25, $B2E29692,\r\n $8AAD2B2F, $8E6C3698, $832F1041, $87EE0DF6, $99A95DF3, $9D684044, $902B669D, $94EA7B2A,\r\n $E0B41DE7, $E4750050, $E9362689, $EDF73B3E, $F3B06B3B, $F771768C, $FA325055, $FEF34DE2,\r\n $C6BCF05F, $C27DEDE8, $CF3ECB31, $CBFFD686, $D5B88683, $D1799B34, $DC3ABDED, $D8FBA05A,\r\n $690CE0EE, $6DCDFD59, $608EDB80, $644FC637, $7A089632, $7EC98B85, $738AAD5C, $774BB0EB,\r\n $4F040D56, $4BC510E1, $46863638, $42472B8F, $5C007B8A, $58C1663D, $558240E4, $51435D53,\r\n $251D3B9E, $21DC2629, $2C9F00F0, $285E1D47, $36194D42, $32D850F5, $3F9B762C, $3B5A6B9B,\r\n $0315D626, $07D4CB91, $0A97ED48, $0E56F0FF, $1011A0FA, $14D0BD4D, $19939B94, $1D528623,\r\n $F12F560E, $F5EE4BB9, $F8AD6D60, $FC6C70D7, $E22B20D2, $E6EA3D65, $EBA91BBC, $EF68060B,\r\n $D727BBB6, $D3E6A601, $DEA580D8, $DA649D6F, $C423CD6A, $C0E2D0DD, $CDA1F604, $C960EBB3,\r\n $BD3E8D7E, $B9FF90C9, $B4BCB610, $B07DABA7, $AE3AFBA2, $AAFBE615, $A7B8C0CC, $A379DD7B,\r\n $9B3660C6, $9FF77D71, $92B45BA8, $9675461F, $8832161A, $8CF30BAD, $81B02D74, $857130C3,\r\n $5D8A9099, $594B8D2E, $5408ABF7, $50C9B640, $4E8EE645, $4A4FFBF2, $470CDD2B, $43CDC09C,\r\n $7B827D21, $7F436096, $7200464F, $76C15BF8, $68860BFD, $6C47164A, $61043093, $65C52D24,\r\n $119B4BE9, $155A565E, $18197087, $1CD86D30, $029F3D35, $065E2082, $0B1D065B, $0FDC1BEC,\r\n $3793A651, $3352BBE6, $3E119D3F, $3AD08088, $2497D08D, $2056CD3A, $2D15EBE3, $29D4F654,\r\n $C5A92679, $C1683BCE, $CC2B1D17, $C8EA00A0, $D6AD50A5, $D26C4D12, $DF2F6BCB, $DBEE767C,\r\n $E3A1CBC1, $E760D676, $EA23F0AF, $EEE2ED18, $F0A5BD1D, $F464A0AA, $F9278673, $FDE69BC4,\r\n $89B8FD09, $8D79E0BE, $803AC667, $84FBDBD0, $9ABC8BD5, $9E7D9662, $933EB0BB, $97FFAD0C,\r\n $AFB010B1, $AB710D06, $A6322BDF, $A2F33668, $BCB4666D, $B8757BDA, $B5365D03, $B1F740B4\r\n );\r\n Crc32DefaultStart: Cardinal = $FFFFFFFF;\r\n\r\nconst\r\n Crc32PolynomIEEE = $04C11DB7;\r\n Crc32PolynomCastagnoli = $1EDC6F41;\r\n Crc32Koopman = $741B8CD7;\r\n Crc32Bits = 32;\r\n Crc32Bytes = 4;\r\n Crc32HighBit = $80000000;\r\n NotCrc32HighBit = $7FFFFFFF;\r\n\r\n// for backward compatibility (default polynom = IEEE = $04C11DB7)\r\nfunction Crc32_P(X: PJclByteArray; N: Integer; Crc: Cardinal = 0): Cardinal; overload;\r\nfunction Crc32(const X: array of Byte; N: Integer; Crc: Cardinal = 0): Cardinal; overload;\r\nfunction Crc32_A(const X: array of Byte; Crc: Cardinal = 0): Cardinal; overload;\r\n\r\nfunction CheckCrc32_P(X: PJclByteArray; N: Integer; Crc: Cardinal): Integer; overload;\r\nfunction CheckCrc32(var X: array of Byte; N: Integer; Crc: Cardinal): Integer; overload;\r\nfunction CheckCrc32_A(var X: array of Byte; Crc: Cardinal): Integer; overload;\r\n\r\n// change the default polynom\r\nprocedure InitCrc32(Polynom, Start: Cardinal); overload;\r\n\r\n// arbitrary polynom\r\nfunction Crc32_P(const Crc32Table: TCrc32Table; X: PJclByteArray; N: Integer; Crc: Cardinal = 0): Cardinal; overload;\r\nfunction Crc32(const Crc32Table: TCrc32Table; const X: array of Byte; N: Integer; Crc: Cardinal = 0): Cardinal; overload;\r\nfunction Crc32_A(const Crc32Table: TCrc32Table; const X: array of Byte; Crc: Cardinal = 0): Cardinal; overload;\r\n\r\nfunction CheckCrc32_P(const Crc32Table: TCrc32Table; X: PJclByteArray; N: Integer; Crc: Cardinal): Integer; overload;\r\nfunction CheckCrc32(const Crc32Table: TCrc32Table; var X: array of Byte; N: Integer; Crc: Cardinal): Integer; overload;\r\nfunction CheckCrc32_A(const Crc32Table: TCrc32Table; var X: array of Byte; Crc: Cardinal): Integer; overload;\r\n\r\n// initialize a table\r\nprocedure InitCrc32(Polynom, Start: Cardinal; out Crc32Table: TCrc32Table); overload;\r\n\r\n{ Complex numbers }\r\n\r\ntype\r\n TRectComplex = record\r\n Re: Float;\r\n Im: Float;\r\n {$IFDEF SUPPORTS_CLASS_OPERATORS}\r\n class operator Implicit(const Value: Float): TRectComplex;\r\n class operator Equal(const Z1, Z2: TRectComplex): Boolean;\r\n class operator NotEqual(const Z1, Z2: TRectComplex): Boolean;\r\n class operator Add(const Z1, Z2: TRectComplex): TRectComplex;\r\n class operator Subtract(const Z1, Z2: TRectComplex): TRectComplex;\r\n class operator Multiply(const Z1, Z2: TRectComplex): TRectComplex;\r\n class operator Divide(const Z1, Z2: TRectComplex): TRectComplex;\r\n class operator Negative(const Z: TRectComplex): TRectComplex;\r\n class operator Positive(const Z: TRectComplex): TRectComplex;\r\n function AsString: string;\r\n function Conjugate: TRectComplex;\r\n function IsZero: Boolean;\r\n function IsInfinite: Boolean;\r\n {$ENDIF SUPPORTS_CLASS_OPERATORS}\r\n end;\r\n\r\n TPolarComplex = record\r\n Radius: Float;\r\n Angle: Float;\r\n {$IFDEF SUPPORTS_CLASS_OPERATORS}\r\n class operator Implicit(const Value: Float): TPolarComplex;\r\n class operator Implicit(const Z: TPolarComplex): TRectComplex;\r\n class operator Implicit(const Z: TRectComplex): TPolarComplex;\r\n {$IFNDEF CPPBUILDER}\r\n // OK with Delphi, but will yield errors in .hpp files:\r\n class operator Explicit(const Z: TPolarComplex): TRectComplex;\r\n class operator Explicit(const Z: TRectComplex): TPolarComplex;\r\n {$ENDIF CPPBUILDER}\r\n class operator Equal(const Z1, Z2: TPolarComplex): Boolean;\r\n class operator NotEqual(const Z1, Z2: TPolarComplex): Boolean;\r\n class operator Add(const Z1, Z2: TPolarComplex): TRectComplex;\r\n class operator Subtract(const Z1, Z2: TPolarComplex): TRectComplex;\r\n class operator Multiply(const Z1, Z2: TPolarComplex): TPolarComplex;\r\n class operator Divide(const Z1, Z2: TPolarComplex): TPolarComplex;\r\n class operator Negative(const Z: TPolarComplex): TPolarComplex;\r\n class operator Positive(const Z: TPolarComplex): TPolarComplex;\r\n function AsString: string;\r\n function Conjugate: TPolarComplex;\r\n function IsZero: Boolean;\r\n function IsInfinite: Boolean;\r\n function Power(const Exponent: TRectComplex): TPolarComplex; overload;\r\n function Power(const Exponent: Float): TPolarComplex; overload;\r\n function Power(const Exponent: Integer): TPolarComplex; overload;\r\n // computes the kth nth root, k in 1..n\r\n function Root(const K, N: Cardinal): TPolarComplex;\r\n {$ENDIF SUPPORTS_CLASS_OPERATORS}\r\n end;\r\n\r\n{$IFDEF DEBUG}\r\nvar\r\n // accumulated count of (computational costly) TRectComplex <-> TPolarComplex conversions\r\n ComplexTypeConversions: Cardinal;\r\n{$ENDIF DEBUG}\r\n\r\n// sets format string for ComplexToStr(TRectComplex) and TRectComplex.AsString\r\nprocedure SetRectComplexFormatStr(const S: string);\r\n// sets format string for ComplexToStr(TPolarComplex) and TPolarComplex.AsString\r\nprocedure SetPolarComplexFormatStr(const S: string);\r\n\r\nfunction ComplexToStr(const Z: TRectComplex): string; overload;\r\nfunction ComplexToStr(const Z: TPolarComplex): string; overload;\r\n\r\nfunction RectComplex(const Re: Float; const Im: Float = 0): TRectComplex; overload;\r\nfunction RectComplex(const Z: TPolarComplex): TRectComplex; overload;\r\nfunction PolarComplex(const Radius: Float; const Angle: Float = 0): TPolarComplex; overload;\r\nfunction PolarComplex(const Z: TRectComplex): TPolarComplex; overload;\r\n\r\nfunction Equal(const Z1, Z2: TRectComplex): Boolean; overload;\r\nfunction Equal(const Z1, Z2: TPolarComplex): Boolean; overload;\r\n\r\nfunction IsZero(const Z: TRectComplex): Boolean; overload;\r\nfunction IsZero(const Z: TPolarComplex): Boolean; overload;\r\n{$IFDEF CPU32}\r\nfunction IsInfinite(const Z: TRectComplex): Boolean; overload;\r\nfunction IsInfinite(const Z: TPolarComplex): Boolean; overload;\r\n{$ENDIF CPU32}\r\n\r\nfunction Norm(const Z: TRectComplex): Float; overload;\r\nfunction Norm(const Z: TPolarComplex): Float; overload;\r\nfunction AbsSqr(const Z: TRectComplex): Float; overload;\r\nfunction AbsSqr(const Z: TPolarComplex): Float; overload;\r\nfunction Conjugate(const Z: TRectComplex): TRectComplex; overload;\r\nfunction Conjugate(const Z: TPolarComplex): TPolarComplex; overload;\r\nfunction Inv(const Z: TRectComplex): TRectComplex; overload;\r\nfunction Inv(const Z: TPolarComplex): TPolarComplex; overload;\r\nfunction Neg(const Z: TRectComplex): TRectComplex; overload;\r\nfunction Neg(const Z: TPolarComplex): TPolarComplex; overload;\r\n\r\nfunction Sum(const Z1, Z2: TRectComplex): TRectComplex; overload;\r\nfunction Sum(const Z: array of TRectComplex): TRectComplex; overload;\r\nfunction Diff(const Z1, Z2: TRectComplex): TRectComplex;\r\nfunction Product(const Z1, Z2: TRectComplex): TRectComplex; overload;\r\nfunction Product(const Z1, Z2: TPolarComplex): TPolarComplex; overload;\r\nfunction Product(const Z: array of TPolarComplex): TPolarComplex; overload;\r\nfunction Quotient(const Z1, Z2: TRectComplex): TRectComplex; overload;\r\nfunction Quotient(const Z1, Z2: TPolarComplex): TPolarComplex; overload;\r\n\r\nfunction Ln(const Z: TPolarComplex): TRectComplex;\r\nfunction Exp(const Z: TRectComplex): TPolarComplex; overload;\r\nfunction Power(const Z: TPolarComplex; const Exponent: TRectComplex): TPolarComplex; overload;\r\nfunction Power(const Z: TPolarComplex; const Exponent: Float): TPolarComplex; overload;\r\nfunction PowerInt(const Z: TPolarComplex; const Exponent: Integer): TPolarComplex; overload;\r\n// a complex number has n different nth roots in the complex plane\r\n// Root() computes the kth nth root, k in 1..n\r\nfunction Root(const Z: TPolarComplex; const K, N: Cardinal): TPolarComplex;\r\n\r\nfunction Cos(const Z: TRectComplex): TRectComplex; overload;\r\nfunction Sin(const Z: TRectComplex): TRectComplex; overload;\r\nfunction Tan(const Z: TRectComplex): TRectComplex; overload;\r\nfunction Cot(const Z: TRectComplex): TRectComplex; overload;\r\nfunction Sec(const Z: TRectComplex): TRectComplex; overload;\r\nfunction Csc(const Z: TRectComplex): TRectComplex; overload;\r\n\r\nfunction CosH(const Z: TRectComplex): TRectComplex; overload;\r\nfunction SinH(const Z: TRectComplex): TRectComplex; overload;\r\nfunction TanH(const Z: TRectComplex): TRectComplex; overload;\r\nfunction CotH(const Z: TRectComplex): TRectComplex; overload;\r\nfunction SecH(const Z: TRectComplex): TRectComplex; overload;\r\nfunction CscH(const Z: TRectComplex): TRectComplex; overload;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jcl.svn.sourceforge.net/svnroot/jcl/tags/JCL-2.4-Build4571/jcl/source/common/JclMath.pas $';\r\n Revision: '$Revision: 3599 $';\r\n Date: '$Date: 2011-09-03 00:07:50 +0200 (sam. 03 sept. 2011) $';\r\n LogPath: 'JCL\\source\\common';\r\n Extra: '';\r\n Data: nil\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\n{$IFDEF DELPHI64_TEMPORARY}\r\n {$DEFINE USE_MATH_UNIT}\r\n{$ENDIF DELPHI64_TEMPORARY}\r\n\r\nuses\r\n {$IFDEF HAS_UNITSCOPE}\r\n {$IFDEF MSWINDOWS}\r\n {$IFNDEF FPC}\r\n Winapi.Windows,\r\n {$ENDIF ~FPC}\r\n {$ENDIF MSWINDOWS}\r\n {$ELSE ~HAS_UNITSCOPE}\r\n {$IFDEF MSWINDOWS}\r\n {$IFNDEF FPC}\r\n Windows,\r\n {$ENDIF ~FPC}\r\n {$ENDIF MSWINDOWS}\r\n {$ENDIF ~HAS_UNITSCOPE}\r\n {$IFDEF USE_MATH_UNIT}\r\n System.Math,\r\n {$ENDIF USE_MATH_UNIT}\r\n Jcl8087,\r\n JclResources,\r\n JclSynch;\r\n\r\n// Note (rrossmair): Usage of the \"assembler\" directive seems to be an Free Pascal requirement\r\n// (it's obsolete in Delphi since v. 2 I believe).\r\n\r\n// Internal helper routines\r\n// Linux: Get Global Offset Table (GOT) adress for Position Independent Code\r\n// (PIC, used by shared objects)\r\n\r\n{$IFDEF PIC}\r\nfunction GetGOT: Pointer; export;\r\nbegin\r\n asm\r\n {$IFDEF CPU32}\r\n MOV Result, EBX\r\n {$ENDIF CPU32}\r\n {$IFDEF CPU64}\r\n XOR Result, RBX\r\n {$ENDIF CPU64}\r\n end;\r\nend;\r\n{$ENDIF PIC}\r\n\r\n// to keep name space usage low\r\nconst\r\n JclMathSgn: function(const X: Float): Integer = Sgn;\r\n JclMathPower: function(const Base, Exponent: Float): Float = Power;\r\n\r\n// to be independent from JclLogic\r\n\r\nfunction Min(const X, Y: Integer): Integer;\r\nbegin\r\n if X < Y then\r\n Result := X\r\n else\r\n Result := Y;\r\nend;\r\n\r\n// to be independent from JCLLogic\r\n\r\nprocedure SwapOrd(var X, Y: Integer);\r\nvar\r\n Temp: Integer;\r\nbegin\r\n Temp := X;\r\n X := Y;\r\n Y := Temp;\r\nend;\r\n\r\nfunction DoubleToHex(const D: Double): string;\r\nvar\r\n Overlay: array [1..2] of Longint absolute D;\r\nbegin\r\n // Look at element 2 before element 1 because of \"Little Endian\" order.\r\n Result := IntToHex(Overlay[2], 8) + IntToHex(Overlay[1], 8);\r\nend;\r\n\r\nfunction HexToDouble(const Hex: string): Double;\r\nvar\r\n D: Double;\r\n Overlay: array [1..2] of Longint absolute D;\r\nbegin\r\n if Length(Hex) <> 16 then\r\n raise EJclMathError.CreateRes(@RsUnexpectedValue);\r\n Overlay[1] := StrToInt('$' + Copy(Hex, 9, 8));\r\n Overlay[2] := StrToInt('$' + Copy(Hex, 1, 8));\r\n Result := D;\r\nend;\r\n\r\n// Converts degrees to radians.\r\n\r\n{$IFDEF SUPPORTS_EXTENDED}\r\nfunction DegToRad(const Value: Extended): Extended;\r\nbegin\r\n Result := Value * RatioDegToRad;\r\nend;\r\n{$ENDIF SUPPORTS_EXTENDED}\r\n\r\nfunction DegToRad(const Value: Double): Double;\r\nbegin\r\n Result := Value * RatioDegToRad;\r\nend;\r\n\r\nfunction DegToRad(const Value: Single): Single;\r\nbegin\r\n Result := Value * RatioDegToRad;\r\nend;\r\n\r\n// Expects degrees in ST(0), leaves radians in ST(0)\r\n// ST(0) := ST(0) * PI / 180\r\nprocedure FastDegToRad; assembler;\r\nasm\r\n {$IFDEF PIC}\r\n CALL GetGOT\r\n {$IFDEF CPU32}\r\n FLD [EAX][RatioDegToRad]\r\n {$ENDIF CPU32}\r\n {$IFDEF CPU64}\r\n FLD [RAX][RatioDegToRad]\r\n {$ENDIF CPU64}\r\n {$ELSE ~PIC}\r\n FLD [RatioDegToRad]\r\n {$ENDIF ~PIC}\r\n FMULP\r\n FWAIT\r\nend;\r\n\r\n// Converts radians to degrees.\r\n\r\n{$IFDEF SUPPORTS_EXTENDED}\r\nfunction RadToDeg(const Value: Extended): Extended;\r\nbegin\r\n Result := Value * RatioRadToDeg;\r\nend;\r\n{$ENDIF SUPPORTS_EXTENDED}\r\n\r\nfunction RadToDeg(const Value: Double): Double;\r\nbegin\r\n Result := Value * RatioRadToDeg;\r\nend;\r\n\r\nfunction RadToDeg(const Value: Single): Single;\r\nbegin\r\n Result := Value * RatioRadToDeg;\r\nend;\r\n\r\n// Expects radians in ST(0), leaves degrees in ST(0)\r\n// ST(0) := ST(0) * (180 / PI);\r\nprocedure FastRadToDeg; assembler;\r\nasm\r\n {$IFDEF PIC}\r\n CALL GetGOT\r\n {$IFDEF CPU32}\r\n FLD [EAX][RatioRadToDeg]\r\n {$ENDIF CPU32}\r\n {$IFDEF CPU64}\r\n FLD [RAX][RatioRadToDeg]\r\n {$ENDIF CPU64}\r\n {$ELSE ~PIC}\r\n FLD [RatioRadToDeg]\r\n {$ENDIF ~PIC}\r\n FMULP\r\n FWAIT\r\nend;\r\n\r\n// Converts grads to radians.\r\n\r\n{$IFDEF SUPPORTS_EXTENDED}\r\nfunction GradToRad(const Value: Extended): Extended;\r\nbegin\r\n Result := Value * RatioGradToRad;\r\nend;\r\n{$ENDIF SUPPORTS_EXTENDED}\r\n\r\nfunction GradToRad(const Value: Double): Double;\r\nbegin\r\n Result := Value * RatioGradToRad;\r\nend;\r\n\r\nfunction GradToRad(const Value: Single): Single;\r\nbegin\r\n Result := Value * RatioGradToRad;\r\nend;\r\n\r\n// Expects grads in ST(0), leaves radians in ST(0)\r\n// ST(0) := ST(0) * PI / 200\r\nprocedure FastGradToRad; assembler;\r\nasm\r\n {$IFDEF PIC}\r\n CALL GetGOT\r\n {$IFDEF CPU32}\r\n FLD [EAX][RatioGradToRad]\r\n {$ENDIF CPU32}\r\n {$IFDEF CPU64}\r\n FLD [RAX][RatioGradToRad]\r\n {$ENDIF CPU64}\r\n {$ELSE ~PIC}\r\n FLD [RatioGradToRad]\r\n {$ENDIF ~PIC}\r\n FMULP\r\n FWAIT\r\nend;\r\n\r\n// Converts radians to grads.\r\n\r\n{$IFDEF SUPPORTS_EXTENDED}\r\nfunction RadToGrad(const Value: Extended): Extended;\r\nbegin\r\n Result := Value * RatioRadToGrad;\r\nend;\r\n{$ENDIF SUPPORTS_EXTENDED}\r\n\r\nfunction RadToGrad(const Value: Double): Double;\r\nbegin\r\n Result := Value * RatioRadToGrad;\r\nend;\r\n\r\nfunction RadToGrad(const Value: Single): Single;\r\nbegin\r\n Result := Value * RatioRadToGrad;\r\nend;\r\n\r\n// Expects radians in ST(0), leaves grads in ST(0)\r\n// ST(0) := ST(0) * (200 / PI);\r\nprocedure FastRadToGrad; assembler;\r\nasm\r\n {$IFDEF PIC}\r\n CALL GetGOT\r\n {$IFDEF CPU32}\r\n FLD [EAX][RatioRadToGrad]\r\n {$ENDIF CPU32}\r\n {$IFDEF CPU64}\r\n FLD [RAX][RatioRadToGrad]\r\n {$ENDIF CPU64}\r\n {$ELSE ~PIC}\r\n FLD [RatioRadToGrad]\r\n {$ENDIF ~PIC}\r\n FMULP\r\n FWAIT\r\nend;\r\n\r\n// Converts degrees to grads.\r\n\r\n{$IFDEF SUPPORTS_EXTENDED}\r\nfunction DegToGrad(const Value: Extended): Extended;\r\nbegin\r\n Result := Value * RatioDegToGrad;\r\nend;\r\n{$ENDIF SUPPORTS_EXTENDED}\r\n\r\nfunction DegToGrad(const Value: Double): Double;\r\nbegin\r\n Result := Value * RatioDegToGrad;\r\nend;\r\n\r\nfunction DegToGrad(const Value: Single): Single;\r\nbegin\r\n Result := Value * RatioDegToGrad;\r\nend;\r\n\r\n// Expects Degrees in ST(0), leaves grads in ST(0)\r\n// ST(0) := ST(0) * (200 / 180);\r\nprocedure FastDegToGrad; assembler;\r\nasm\r\n {$IFDEF PIC}\r\n CALL GetGOT\r\n {$IFDEF CPU32}\r\n FLD [EAX][RatioDegToGrad]\r\n {$ENDIF CPU32}\r\n {$IFDEF CPU64}\r\n FLD [RAX][RatioDegToGrad]\r\n {$ENDIF CPU64}\r\n {$ELSE ~PIC}\r\n FLD [RatioDegToGrad]\r\n {$ENDIF ~PIC}\r\n FMULP\r\n FWAIT\r\nend;\r\n\r\n// Converts grads to degrees.\r\n\r\n{$IFDEF SUPPORTS_EXTENDED}\r\nfunction GradToDeg(const Value: Extended): Extended;\r\nbegin\r\n Result := Value * RatioGradToDeg;\r\nend;\r\n{$ENDIF SUPPORTS_EXTENDED}\r\n\r\nfunction GradToDeg(const Value: Double): Double;\r\nbegin\r\n Result := Value * RatioGradToDeg;\r\nend;\r\n\r\nfunction GradToDeg(const Value: Single): Single;\r\nbegin\r\n Result := Value * RatioGradToDeg;\r\nend;\r\n\r\n// Expects grads in ST(0), leaves radians in ST(0)\r\n// ST(0) := ST(0) * PI / 200\r\nprocedure FastGradToDeg; assembler;\r\nasm\r\n {$IFDEF PIC}\r\n CALL GetGOT\r\n {$IFDEF CPU32}\r\n FLD [EAX][RatioGradToDeg]\r\n {$ENDIF CPU32}\r\n {$IFDEF CPU64}\r\n FLD [RAX][RatioGradToDeg]\r\n {$ENDIF CPU64}\r\n {$ELSE ~PIC}\r\n FLD [RatioGradToDeg]\r\n {$ENDIF ~PIC}\r\n FMULP\r\n FWAIT\r\nend;\r\n\r\nprocedure DomainCheck(Err: Boolean);\r\nbegin\r\n if Err then\r\n raise EJclMathError.CreateRes(@RsMathDomainError);\r\nend;\r\n\r\n//=== Logarithmic ============================================================\r\n\r\nfunction LogBase10(X: Float): Float;\r\nbegin\r\n DomainCheck(X <= 0.0);\r\n {$IFDEF USE_MATH_UNIT}\r\n Result := System.Math.Log10(X);\r\n {$ELSE ~USE_MATH_UNIT}\r\n asm\r\n FLDLG2\r\n FLD X\r\n FYL2X\r\n FWAIT\r\n FSTP Result\r\n end;\r\n {$ENDIF ~USE_MATH_UNIT}\r\nend;\r\n\r\nfunction LogBase2(X: Float): Float;\r\nbegin\r\n DomainCheck(X <= 0.0);\r\n {$IFDEF USE_MATH_UNIT}\r\n Result := System.Math.Log2(X);\r\n {$ELSE ~USE_MATH_UNIT}\r\n asm\r\n FLD1\r\n FLD X\r\n FYL2X\r\n FWAIT\r\n FSTP Result\r\n end;\r\n {$ENDIF ~USE_MATH_UNIT}\r\nend;\r\n\r\nfunction LogBaseN(Base, X: Float): Float;\r\nbegin\r\n DomainCheck((X <= 0.0) or (Base <= 0.0) or (Base = 1.0));\r\n {$IFDEF USE_MATH_UNIT}\r\n Result := System.Math.LogN(Base, X);\r\n {$ELSE ~USE_MATH_UNIT}\r\n asm\r\n FLD1\r\n FLD X\r\n FYL2X\r\n FLD1\r\n FLD Base\r\n FYL2X\r\n FDIVP ST(1), ST(0)\r\n FWAIT\r\n FSTP Result\r\n end;\r\n {$ENDIF ~USE_MATH_UNIT}\r\nend;\r\n\r\n//=== Transcendental =========================================================\r\n\r\nfunction ArcCos(X: Float): Float;\r\nbegin\r\n DomainCheck(Abs(X) > 1.0);\r\n {$IFDEF USE_MATH_UNIT}\r\n Result := System.Math.ArcCos(X);\r\n {$ELSE ~USE_MATH_UNIT}\r\n asm\r\n FLD X\r\n FLD ST(0)\r\n FMUL ST(0), ST(0)\r\n FLD1\r\n FSUBRP ST(1), ST(0)\r\n FSQRT\r\n FXCH\r\n FPATAN\r\n FWAIT\r\n FSTP Result\r\n end;\r\n {$ENDIF ~USE_MATH_UNIT}\r\nend;\r\n\r\nfunction ArcCot(X: Float): Float;\r\nbegin\r\n DomainCheck(X = 0);\r\n Result := ArcTan(1 / X);\r\nend;\r\n\r\nfunction ArcCsc(X: Float): Float;\r\nbegin\r\n Result := ArcSec(X / Sqrt(X * X -1));\r\nend;\r\n\r\nfunction ArcSec(X: Float): Float;\r\nbegin\r\n DomainCheck((X > -1) and (X < 1));\r\n {$IFDEF USE_MATH_UNIT}\r\n Result := System.Math.ArcSec(X);\r\n {$ELSE ~USE_MATH_UNIT}\r\n // FArcTan(Sqrt(X*X - 1));\r\n asm\r\n FLD1\r\n FLD X\r\n FLD ST(0)\r\n FMULP\r\n FSUBRP ST(1), ST(0)\r\n FSQRT\r\n FLD1\r\n FPATAN\r\n FWAIT\r\n FSTP Result\r\n end;\r\n {$ENDIF ~USE_MATH_UNIT}\r\nend;\r\n\r\nfunction ArcSin(X: Float): Float;\r\nbegin\r\n DomainCheck(Abs(X) > 1.0);\r\n {$IFDEF USE_MATH_UNIT}\r\n Result := System.Math.ArcSin(X);\r\n {$ELSE ~USE_MATH_UNIT}\r\n asm\r\n FLD X\r\n FLD ST(0)\r\n FMUL ST(0), ST(0)\r\n FLD1\r\n FSUBRP ST(1), ST(0)\r\n FSQRT\r\n FPATAN\r\n FWAIT\r\n FSTP Result\r\n end;\r\n {$ENDIF ~USE_MATH_UNIT}\r\nend;\r\n\r\n{$IFDEF CPU32}\r\nfunction ArcTan(X: Float): Float; assembler;\r\nasm\r\n FLD X\r\n FLD1\r\n FPATAN\r\n FWAIT\r\nend;\r\n{$ENDIF CPU32}\r\n\r\n{$IFDEF CPU64}\r\nfunction ArcTan(X: Float): Float;\r\nbegin\r\n {$IFDEF USE_MATH_UNIT}\r\n System.Error(rePlatformNotImplemented);\r\n Result := NaN; \r\n {$ELSE ~USE_MATH_UNIT}\r\n asm\r\n FLD X\r\n FLD1\r\n FPATAN\r\n FWAIT\r\n FSTP Result\r\n end;\r\n {$ENDIF ~USE_MATH_UNIT}\r\nend;\r\n{$ENDIF CPU64}\r\n\r\n{$IFDEF CPU32}\r\nfunction ArcTan2(Y, X: Float): Float; assembler;\r\nasm\r\n FLD Y\r\n FLD X\r\n FPATAN\r\n FWAIT\r\nend;\r\n{$ENDIF CPU32}\r\n\r\n{$IFDEF CPU64}\r\nfunction ArcTan2(Y, X: Float): Float;\r\nbegin\r\n {$IFDEF USE_MATH_UNIT}\r\n Result := System.Math.ArcTan2(Y, X);\r\n {$ELSE ~USE_MATH_UNIT}\r\n asm\r\n FLD Y\r\n FLD X\r\n FPATAN\r\n FWAIT\r\n FSTP Result\r\n end;\r\n {$ENDIF ~USE_MATH_UNIT}\r\nend;\r\n{$ENDIF CPU64}\r\n\r\nfunction Cos(X: Float): Float;\r\nbegin\r\n DomainCheck(Abs(X) > MaxAngle);\r\n {$IFDEF USE_MATH_UNIT}\r\n System.Error(rePlatformNotImplemented);\r\n Result := NaN;\r\n {$ELSE ~USE_MATH_UNIT}\r\n asm\r\n FLD X\r\n FCOS\r\n FWAIT\r\n FSTP Result\r\n end;\r\n {$ENDIF ~USE_MATH_UNIT}\r\nend;\r\n\r\nfunction Cot(X: Float): Float;\r\nbegin\r\n DomainCheck(Abs(X) > MaxAngle);\r\n {$IFDEF USE_MATH_UNIT}\r\n Result := System.Math.Cot(X);\r\n {$ELSE ~USE_MATH_UNIT}\r\n { TODO : Cot = 1 / Tan -> Tan(X) <> 0.0 }\r\n asm\r\n FLD X\r\n FPTAN\r\n FDIVRP ST(1), ST(0)\r\n FWAIT\r\n FSTP Result\r\n end;\r\n {$ENDIF ~USE_MATH_UNIT}\r\nend;\r\n\r\nfunction Coversine(X: Float): Float;\r\nbegin\r\n Result := 1 - JclMath.Sin(X);\r\nend;\r\n\r\nfunction Csc(X: Float): Float;\r\nvar\r\n Y: Float;\r\nbegin\r\n DomainCheck(Abs(X) > MaxAngle);\r\n\r\n Y := JclMath.Sin(X);\r\n DomainCheck(Y = 0.0);\r\n Result := 1.0 / Y;\r\nend;\r\n\r\nfunction Exsecans(X: Float): Float;\r\nbegin\r\n Result := JclMath.Sec(X) - 1;\r\nend;\r\n\r\nfunction Haversine(X: Float): Float;\r\nbegin\r\n Result := 0.5 * (1 - JclMath.Cos(X));\r\nend;\r\n\r\nfunction Sec(X: Float): Float;\r\nbegin\r\n DomainCheck(Abs(X) > MaxAngle);\r\n {$IFDEF USE_MATH_UNIT}\r\n Result := System.Math.Sec(X);\r\n {$ELSE ~USE_MATH_UNIT}\r\n { TODO : Sec = 1 / Cos -> Cos(X) <> 0! }\r\n asm\r\n FLD X\r\n FCOS\r\n FLD1\r\n FDIVRP ST(1), ST(0)\r\n FWAIT\r\n FSTP Result\r\n end;\r\n {$ENDIF ~USE_MATH_UNIT}\r\nend;\r\n\r\nfunction Sin(X: Float): Float;\r\nbegin\r\n {$IFNDEF MATH_EXT_SPECIALVALUES}\r\n DomainCheck(Abs(X) > MaxAngle);\r\n {$ENDIF ~MATH_EXT_SPECIALVALUES}\r\n {$IFDEF USE_MATH_UNIT}\r\n System.Error(rePlatformNotImplemented);\r\n Result := NaN;\r\n {$ELSE ~USE_MATH_UNIT}\r\n asm\r\n FLD X\r\n FSIN\r\n FWAIT\r\n FSTP Result\r\n end;\r\n {$ENDIF ~USE_MATH_UNIT}\r\nend;\r\n\r\n{$IFDEF SUPPORTS_EXTENDED}\r\nprocedure SinCos(X: Extended; out Sin, Cos: Extended);\r\nbegin\r\n DomainCheck(Abs(X) > MaxAngle);\r\n {$IFDEF USE_MATH_UNIT}\r\n System.Math.SinCos(X, Sin, Cos);\r\n {$ELSE ~USE_MATH_UNIT}\r\n asm\r\n FLD X\r\n {$IFDEF CPU32}\r\n MOV EDX, Cos\r\n MOV EAX, Sin\r\n FSINCOS\r\n FSTP Extended PTR [EDX]\r\n FSTP Extended PTR [EAX]\r\n {$ENDIF CPU32}\r\n {$IFDEF CPU64}\r\n MOV RDX, Cos\r\n MOV RAX, Sin\r\n FSINCOS\r\n FSTP Extended PTR [RDX]\r\n FSTP Extended PTR [RAX]\r\n {$ENDIF CPU64}\r\n FWAIT\r\n end;\r\n {$ENDIF ~USE_MATH_UNIT}\r\nend;\r\n{$ENDIF SUPPORTS_EXTENDED}\r\n\r\nprocedure SinCos(X: Double; out Sin, Cos: Double);\r\nbegin\r\n DomainCheck(Abs(X) > MaxAngle);\r\n {$IFDEF USE_MATH_UNIT}\r\n System.Math.SinCos(X, Sin, Cos);\r\n {$ELSE ~USE_MATH_UNIT}\r\n asm\r\n FLD X\r\n {$IFDEF CPU32}\r\n MOV EDX, Cos\r\n MOV EAX, Sin\r\n FSINCOS\r\n FSTP Double PTR [EDX]\r\n FSTP Double PTR [EAX]\r\n {$ENDIF CPU32}\r\n {$IFDEF CPU64}\r\n MOV RDX, Cos\r\n MOV RAX, Sin\r\n FSINCOS\r\n FSTP Double PTR [RDX]\r\n FSTP Double PTR [RAX]\r\n {$ENDIF CPU64}\r\n FWAIT\r\n end;\r\n {$ENDIF ~USE_MATH_UNIT}\r\nend;\r\n\r\nprocedure SinCos(X: Single; out Sin, Cos: Single);\r\nbegin\r\n DomainCheck(Abs(X) > MaxAngle);\r\n {$IFDEF USE_MATH_UNIT}\r\n System.Math.SinCos(X, Sin, Cos);\r\n {$ELSE ~USE_MATH_UNIT}\r\n asm\r\n FLD X\r\n {$IFDEF CPU32}\r\n MOV EDX, Cos\r\n MOV EAX, Sin\r\n FSINCOS\r\n FSTP Single PTR [EDX]\r\n FSTP Single PTR [EAX]\r\n {$ENDIF CPU32}\r\n {$IFDEF CPU64}\r\n MOV RDX, Cos\r\n MOV RAX, Sin\r\n FSINCOS\r\n FSTP Single PTR [RDX]\r\n FSTP Single PTR [RAX]\r\n {$ENDIF CPU64}\r\n FWAIT\r\n end;\r\n {$ENDIF ~USE_MATH_UNIT}\r\nend;\r\n\r\nfunction Tan(X: Float): Float;\r\nbegin\r\n DomainCheck(Abs(X) > MaxAngle);\r\n {$IFDEF USE_MATH_UNIT}\r\n Result := System.Math.Tan(X);\r\n {$ELSE ~USE_MATH_UNIT}\r\n asm\r\n FLD X\r\n FPTAN\r\n FSTP ST(0)\r\n FWAIT\r\n FSTP Result\r\n end;\r\n {$ENDIF ~USE_MATH_UNIT}\r\nend;\r\n\r\nfunction Versine(X: Float): Float;\r\nbegin\r\n Result := 1 - JclMath.Cos(X);\r\nend;\r\n\r\n//=== Hyperbolic =============================================================\r\n\r\nfunction ArcCosH(X: Float): Float;\r\nbegin\r\n DomainCheck(X < 1.0);\r\n {$IFDEF USE_MATH_UNIT}\r\n Result := System.Math.ArcCosh(X);\r\n {$ELSE ~USE_MATH_UNIT}\r\n asm\r\n FLDLN2\r\n FLD X\r\n FLD ST(0)\r\n FMUL ST(0), ST(0)\r\n FLD1\r\n FSUBP ST(1), ST(0)\r\n FSQRT\r\n FADDP ST(1), ST(0)\r\n FYL2X\r\n FSTP Result\r\n end;\r\n {$ENDIF ~USE_MATH_UNIT}\r\nend;\r\n\r\nfunction ArcCotH(X: Float): Float;\r\nbegin\r\n DomainCheck(Abs(X) = 1.0);\r\n Result := 0.5 * System.Ln((X + 1.0) / (X - 1.0));\r\nend;\r\n\r\nfunction ArcCscH(X: Float): Float;\r\nbegin\r\n DomainCheck(X = 0);\r\n Result := System.Ln((Sgn(X) * Sqrt(Sqr(X) + 1.0) + 1.0) / X);\r\nend;\r\n\r\nfunction ArcSecH(X: Float): Float;\r\nbegin\r\n DomainCheck(Abs(X) > 1.0);\r\n Result := System.Ln((Sqrt(1.0 - Sqr(X)) + 1.0) / X);\r\nend;\r\n\r\n{$IFDEF CPU32}\r\nfunction ArcSinH(X: Float): Float; assembler;\r\nasm\r\n FLDLN2\r\n FLD X\r\n FLD ST(0)\r\n FMUL ST(0), ST(0)\r\n FLD1\r\n FADDP ST(1), ST(0)\r\n FSQRT\r\n FADDP ST(1), ST(0)\r\n FYL2X\r\nend;\r\n{$ENDIF CPU32}\r\n\r\n{$IFDEF CPU64}\r\nfunction ArcSinH(X: Float): Float;\r\nbegin\r\n {$IFDEF USE_MATH_UNIT}\r\n Result := System.Math.ArcSinh(X);\r\n {$ELSE ~USE_MATH_UNIT}\r\n asm\r\n FLDLN2\r\n FLD X\r\n FLD ST(0)\r\n FMUL ST(0), ST(0)\r\n FLD1\r\n FADDP ST(1), ST(0)\r\n FSQRT\r\n FADDP ST(1), ST(0)\r\n FYL2X\r\n FSTP Result\r\n end;\r\n {$ENDIF ~USE_MATH_UNIT}\r\nend;\r\n{$ENDIF CPU64}\r\n\r\nfunction ArcTanH(X: Float): Float;\r\nbegin\r\n DomainCheck(Abs(X) >= 1.0);\r\n {$IFDEF USE_MATH_UNIT}\r\n Result := System.Math.ArcTanh(X);\r\n {$ELSE ~USE_MATH_UNIT}\r\n asm\r\n FLDLN2\r\n FLD X\r\n FLD ST(0)\r\n FLD1\r\n FADDP ST(1), ST(0)\r\n FXCH\r\n FLD1\r\n FSUBRP ST(1), ST(0)\r\n FDIVP ST(1), ST(0)\r\n FSQRT\r\n FYL2X\r\n FWAIT\r\n FSTP Result\r\n end;\r\n {$ENDIF ~USE_MATH_UNIT}\r\nend;\r\n\r\nfunction CosH(X: Float): Float;\r\n{$IFDEF PUREPASCAL}\r\nbegin\r\n Result := 0.5 * (Exp(X) + Exp(-X));\r\nend;\r\n{$ELSE ~PUREPASCAL}\r\nconst\r\n RoundDown: Word = $177F;\r\n OneHalf: Float = 0.5;\r\n{$IFNDEF USE_MATH_UNIT}\r\nvar\r\n ControlWW: Word;\r\n{$ENDIF ~USE_MATH_UNIT}\r\nbegin\r\n {$IFDEF USE_MATH_UNIT}\r\n Result := System.Math.Cosh(X);\r\n {$ELSE ~USE_MATH_UNIT}\r\n asm\r\n {$IFDEF PIC}\r\n CALL GetGOT\r\n {$ENDIF PIC}\r\n FLD X { TODO : Legal values for X? }\r\n FLDL2E\r\n FMULP ST(1), ST(0)\r\n FSTCW ControlWW\r\n {$IFDEF PIC}\r\n {$IFDEF CPU32}\r\n FLDCW [EAX].RoundDown\r\n {$ENDIF CPU32}\r\n {$IFDEF CPU64}\r\n FLDCW [RAX].RoundDown\r\n {$ENDIF CPU64}\r\n {$ELSE ~PIC}\r\n FLDCW RoundDown\r\n {$ENDIF ~PIC}\r\n FLD ST(0)\r\n FRNDINT\r\n FLDCW ControlWW\r\n FXCH\r\n FSUB ST(0), ST(1)\r\n F2XM1\r\n FLD1\r\n FADDP ST(1), ST(0)\r\n FSCALE\r\n FST ST(1)\r\n FLD1\r\n FDIVRP ST(1), ST(0)\r\n FADDP ST(1), ST(0)\r\n {$IFDEF PIC}\r\n {$IFDEF CPU32}\r\n FLD [EAX].OneHalf\r\n {$ENDIF CPU32}\r\n {$IFDEF CPU64}\r\n FLD [RAX].OneHalf\r\n {$ENDIF CPU64}\r\n {$ELSE ~PIC}\r\n FLD OneHalf\r\n {$ENDIF ~PIC}\r\n FMULP ST(1), ST(0)\r\n FWAIT\r\n FSTP Result\r\n end;\r\n {$ENDIF ~USE_MATH_UNIT}\r\nend;\r\n{$ENDIF ~PUREPASCAL}\r\n\r\nfunction CotH(X: Float): Float;\r\nbegin\r\n Result := 1 / JclMath.TanH(X);\r\nend;\r\n\r\nfunction CscH(X: Float): Float;\r\nbegin\r\n Result := JclMath.Exp(X) - JclMath.Exp(-X);\r\n DomainCheck(Result = 0.0);\r\n Result := 2.0 / Result;\r\nend;\r\n\r\nfunction SecH(X: Float): Float;\r\nbegin\r\n Result := JclMath.Exp(X) + JclMath.Exp(-X);\r\n DomainCheck(Result = 0.0);\r\n Result := 2.0 / Result;\r\nend;\r\n\r\nfunction SinH(X: Float): Float;\r\n{$IFDEF PUREPASCAL}\r\nbegin\r\n Result := 0.5 * (JclMath.Exp(X) - JclMath.Exp(-X));\r\nend;\r\n{$ELSE ~PUREPASCAL}\r\nconst\r\n RoundDown: Word = $177F;\r\n OneHalf: Float = 0.5;\r\n{$IFNDEF USE_MATH_UNIT}\r\nvar\r\n ControlWW: Word;\r\n{$ENDIF ~USE_MATH_UNIT}\r\nbegin\r\n {$IFDEF USE_MATH_UNIT}\r\n Result := System.Math.Sinh(X);\r\n {$ELSE ~USE_MATH_UNIT}\r\n asm\r\n {$IFDEF PIC}\r\n CALL GetGOT\r\n {$ENDIF PIC}\r\n FLD X { TODO : Legal values for X? }\r\n FLDL2E\r\n FMULP ST(1), ST(0)\r\n FSTCW ControlWW\r\n {$IFDEF PIC}\r\n {$IFDEF CPU32}\r\n FLDCW [EAX].RoundDown\r\n {$ENDIF CPU32}\r\n {$IFDEF CPU64}\r\n FLDCW [RAX].RoundDown\r\n {$ENDIF CPU64}\r\n {$ELSE ~PIC}\r\n FLDCW RoundDown\r\n {$ENDIF ~PIC}\r\n FLD ST(0)\r\n FRNDINT\r\n FLDCW ControlWW\r\n FXCH\r\n FSUB ST(0), ST(1)\r\n F2XM1\r\n FLD1\r\n FADDP ST(1), ST(0)\r\n FSCALE\r\n FST ST(1)\r\n FLD1\r\n FDIVRP ST(1), ST(0)\r\n FSUBP ST(1), ST(0)\r\n {$IFDEF PIC}\r\n {$IFDEF CPU32}\r\n FLD [EAX].OneHalf\r\n {$ENDIF CPU32}\r\n {$IFDEF CPU64}\r\n FLD [RAX].OneHalf\r\n {$ENDIF CPU64}\r\n {$ELSE ~PIC}\r\n FLD OneHalf\r\n {$ENDIF ~PIC}\r\n FMULP ST(1), ST(0)\r\n FWAIT\r\n FSTP Result\r\n end;\r\n {$ENDIF ~USE_MATH_UNIT}\r\nend;\r\n{$ENDIF ~PUREPASCAL}\r\n\r\nfunction TanH(X: Float): Float;\r\nbegin\r\n if X > MaxTanH then\r\n Result := 1.0\r\n else\r\n begin\r\n if X < -MaxTanH then\r\n Result := -1.0\r\n else\r\n begin\r\n Result := JclMath.Exp(X);\r\n Result := Result * Result;\r\n Result := (Result - 1.0) / (Result + 1.0);\r\n end;\r\n end;\r\nend;\r\n\r\n//=== Coordinate conversion ==================================================\r\n\r\nfunction DegMinSecToFloat(const Degs, Mins, Secs: Float): Float; // obsolete\r\nbegin\r\n Result := Degs + (Mins / 60.0) + (Secs / 3600.0);\r\nend;\r\n\r\nprocedure FloatToDegMinSec(const X: Float; var Degs, Mins, Secs: Float); // obsolete\r\nvar\r\n Y: Float;\r\nbegin\r\n Degs := System.Int(X);\r\n Y := Frac(X) * 60;\r\n Mins := System.Int(Y);\r\n Secs := Frac(Y) * 60;\r\nend;\r\n\r\n//=== Exponential ============================================================\r\n\r\nfunction Exp(const X: Float): Float;\r\nbegin\r\n {$IFDEF MATH_EXT_EXTREMEVALUES}\r\n {$IFDEF CPU32}\r\n if IsSpecialValue(X) then\r\n begin\r\n if IsNaN(X) or (X = Infinity) then\r\n Result := X\r\n else\r\n Result := 0;\r\n Exit;\r\n end;\r\n {$ENDIF CPU32}\r\n {$ENDIF MATH_EXT_EXTREMEVALUES}\r\n\r\n Result := System.Exp(X);\r\nend;\r\n\r\nfunction Power(const Base, Exponent: Float): Float;\r\nvar\r\n IsAnInteger, IsOdd: Boolean;\r\nbegin\r\n if (Exponent = 0.0) or (Base = 1.0) then\r\n Result := 1\r\n else\r\n if Base = 0.0 then\r\n begin\r\n if Exponent > 0.0 then\r\n Result := 0.0\r\n else\r\n {$IFDEF MATH_EXT_EXTREMEVALUES}\r\n Result := Infinity;\r\n {$ELSE ~MATH_EXT_EXTREMEVALUES}\r\n raise EJclMathError.CreateRes(@RsPowerInfinite);\r\n {$ENDIF ~MATH_EXT_EXTREMEVALUES}\r\n end\r\n else\r\n if Base > 0.0 then\r\n Result := JclMath.Exp(Exponent * System.Ln(Base))\r\n else\r\n begin\r\n IsAnInteger := (Frac(Exponent) = 0.0);\r\n if IsAnInteger then\r\n begin\r\n Result := JclMath.Exp(Exponent * System.Ln(Abs(Base)));\r\n IsOdd := Abs(Round(ModFloat(Exponent, 2))) = 1;\r\n if IsOdd then\r\n Result := -Result;\r\n end\r\n else\r\n raise EJclMathError.CreateRes(@RsPowerComplex);\r\n end;\r\nend;\r\n\r\nfunction PowerInt(const X: Float; N: Integer): Float;\r\nvar\r\n M: Integer;\r\n T: Float;\r\n Xc: Float;\r\nbegin\r\n if X = 0.0 then\r\n begin\r\n if N = 0 then\r\n Result := 1.0\r\n else\r\n if N > 0 then\r\n Result := 0.0\r\n else\r\n Result := MaxFloatingPoint;\r\n Exit;\r\n end;\r\n\r\n if N = 0 then\r\n begin\r\n Result := 1.0;\r\n Exit;\r\n end;\r\n\r\n // Legendre's algorithm for minimizing the number of multiplications\r\n T := 1.0;\r\n M := Abs(N);\r\n Xc := X;\r\n repeat\r\n if Odd(M) then\r\n begin\r\n Dec(M);\r\n T := T * Xc;\r\n end\r\n else\r\n begin\r\n M := M div 2;\r\n Xc := Sqr(Xc);\r\n end;\r\n until M = 0;\r\n\r\n if N > 0 then\r\n Result := T\r\n else\r\n Result := 1.0 / T;\r\nend;\r\n\r\nfunction TenToY(const Y: Float): Float;\r\nbegin\r\n if Y = 0.0 then\r\n Result := 1.0\r\n else\r\n Result := JclMath.Exp(Y * Ln10);\r\nend;\r\n\r\nfunction TruncPower(const Base, Exponent: Float): Float;\r\nbegin\r\n if Base > 0 then\r\n Result := JclMath.Power(Base, Exponent)\r\n else\r\n Result := 0;\r\nend;\r\n\r\nfunction TwoToY(const Y: Float): Float;\r\nbegin\r\n if Y = 0.0 then\r\n Result := 1.0\r\n else\r\n Result := JclMath.Exp(Y * Ln2);\r\nend;\r\n\r\n//=== Floating point support routines ========================================\r\n\r\nfunction IsFloatZero(const X: Float): Boolean;\r\nbegin\r\n Result := Abs(X) < PrecisionTolerance;\r\nend;\r\n\r\nfunction FloatsEqual(const X, Y: Float): Boolean;\r\nbegin\r\n try\r\n if Y = 0 then\r\n // catch exact equality\r\n Result := (X = Y) or (Abs(1 - Y/X ) <= PrecisionTolerance)\r\n else\r\n // catch exact equality\r\n Result := (X = Y) or (Abs(1 - X/Y ) <= PrecisionTolerance);\r\n except\r\n Result := False; // catch real rare overflow e.g. 1.0e3000/1.0e-3000\r\n end\r\nend;\r\n\r\nfunction MaxFloat(const X, Y: Float): Float;\r\nbegin\r\n if X < Y then\r\n Result := Y\r\n else\r\n Result := X;\r\nend;\r\n\r\nfunction MinFloat(const X, Y: Float): Float;\r\nbegin\r\n if X > Y then\r\n Result := Y\r\n else\r\n Result := X;\r\nend;\r\n\r\nfunction ModFloat(const X, Y: Float): Float;\r\nvar\r\n Z: Float;\r\nbegin\r\n Result := X / Y;\r\n Z := System.Int(Result);\r\n if Frac(Result) < 0.0 then\r\n Z := Z - 1.0;\r\n Result := X - Y * Z;\r\nend;\r\n\r\nfunction RemainderFloat(const X, Y: Float): Float;\r\nbegin\r\n Result := X - System.Int(X / Y) * Y;\r\nend;\r\n\r\nprocedure SwapFloats(var X, Y: Float);\r\nvar\r\n T: Float;\r\nbegin\r\n T := X;\r\n X := Y;\r\n Y := T;\r\nend;\r\n\r\nprocedure CalcMachineEpsSingle;\r\nvar\r\n One: Single;\r\n T: Single;\r\nbegin\r\n One := 1.0;\r\n EpsSingle := One;\r\n repeat\r\n EpsSingle := 0.5 * EpsSingle;\r\n T := One + EpsSingle;\r\n until One = T;\r\n EpsSingle := 2.0 * EpsSingle;\r\n ThreeEpsSingle := 3.0 * EpsSingle;\r\nend;\r\n\r\nprocedure CalcMachineEpsDouble;\r\nvar\r\n One: Double;\r\n T: Double;\r\nbegin\r\n One := 1.0;\r\n EpsDouble := One;\r\n repeat\r\n EpsDouble := 0.5 * EpsDouble;\r\n T := One + EpsDouble;\r\n until One = T;\r\n EpsDouble := 2.0 * EpsDouble;\r\n ThreeEpsDouble := 3.0 * EpsDouble;\r\nend;\r\n\r\n{$IFDEF SUPPORTS_EXTENDED}\r\nprocedure CalcMachineEpsExtended;\r\nvar\r\n One: Extended;\r\n T: Extended;\r\nbegin\r\n One := 1.0;\r\n EpsExtended := One;\r\n repeat\r\n EpsExtended := 0.5 * EpsExtended;\r\n T := One + EpsExtended;\r\n until One = T;\r\n EpsExtended := 2.0 * EpsExtended;\r\n ThreeEpsExtended := 3.0 * EpsExtended;\r\nend;\r\n{$ENDIF SUPPORTS_EXTENDED}\r\n\r\nprocedure CalcMachineEps;\r\nbegin\r\n {$IFDEF MATH_EXTENDED_PRECISION}\r\n CalcMachineEpsExtended;\r\n Epsilon := EpsExtended;\r\n ThreeEpsilon := ThreeEpsExtended;\r\n {$ENDIF MATH_EXTENDED_PRECISION}\r\n {$IFDEF MATH_DOUBLE_PRECISION}\r\n CalcMachineEpsDouble;\r\n Epsilon := EpsDouble;\r\n ThreeEpsilon := ThreeEpsDouble;\r\n {$ENDIF MATH_DOUBLE_PRECISION}\r\n {$IFDEF MATH_SINGLE_PRECISION}\r\n CalcMachineEpsSingle;\r\n Epsilon := EpsSingle;\r\n ThreeEpsilon := ThreeEpsSingle;\r\n {$ENDIF MATH_SINGLE_PRECISION}\r\nend;\r\n\r\nprocedure SetPrecisionToleranceToEpsilon;\r\nbegin\r\n CalcMachineEps;\r\n PrecisionTolerance := Epsilon;\r\nend;\r\n\r\nfunction SetPrecisionTolerance(NewTolerance: Float): Float;\r\nbegin\r\n Result := PrecisionTolerance;\r\n PrecisionTolerance := NewTolerance;\r\nend;\r\n\r\n//=== Miscellaneous ==========================================================\r\n\r\nfunction Ceiling(const X: Float): Integer;\r\nbegin\r\n Result := Integer(Trunc(X));\r\n if Frac(X) > 0 then\r\n Inc(Result);\r\nend;\r\n\r\nfunction CommercialRound(const X: Float): Int64;\r\nbegin\r\n Result := Trunc(X);\r\n if Frac(Abs(X)) >= 0.5 then\r\n Result := Result + Sgn(X);\r\nend;\r\n\r\nconst\r\n PreCompFactsCount = 33; // all factorials that fit in a Single\r\n\r\n {$IFDEF MATH_SINGLE_PRECISION}\r\n PreCompFacts: array [0..PreCompFactsCount] of Float =\r\n (\r\n 1.0,\r\n 1.0,\r\n 2.0,\r\n 6.0,\r\n 24.0,\r\n 120.0,\r\n 720.0,\r\n 5040.0,\r\n 40320.0,\r\n 362880.0,\r\n 3628800.0,\r\n 39916800.0,\r\n 479001600.0,\r\n 6227020800.0,\r\n 87178289152.0,\r\n 1307674279936.0,\r\n 20922788478976.0,\r\n 355687414628352.0,\r\n 6.4023735304192E15,\r\n 1.21645096004223E17,\r\n 2.43290202316367E18,\r\n 5.10909408371697E19,\r\n 1.12400072480601E21,\r\n 2.58520174445945E22,\r\n 6.20448454699065E23,\r\n 1.55112110792462E25,\r\n 4.03291499589617E26,\r\n 1.08888704151327E28,\r\n 3.04888371623715E29,\r\n 8.8417630793192E30,\r\n 2.65252889961724E32,\r\n 8.22283968552752E33,\r\n 2.63130869936881E35,\r\n 8.68331850984666E36\r\n );\r\n {$ENDIF MATH_SINGLE_PRECISION}\r\n {$IFDEF MATH_DOUBLE_PRECISION}\r\n PreCompFacts: array [0..PreCompFactsCount] of Float =\r\n (\r\n 1.0,\r\n 1.0,\r\n 2.0,\r\n 6.0,\r\n 24.0,\r\n 120.0,\r\n 720.0,\r\n 5040.0,\r\n 40320.0,\r\n 362880.0,\r\n 3628800.0,\r\n 39916800.0,\r\n 479001600.0,\r\n 6227020800.0,\r\n 87178291200.0,\r\n 1307674368000.0,\r\n 20922789888000.0,\r\n 355687428096000.0,\r\n 6.402373705728E15,\r\n 1.21645100408832E17,\r\n 2.43290200817664E18,\r\n 5.10909421717094E19,\r\n 1.12400072777761E21,\r\n 2.5852016738885E22,\r\n 6.20448401733239E23,\r\n 1.5511210043331E25,\r\n 4.03291461126606E26,\r\n 1.08888694504184E28,\r\n 3.04888344611714E29,\r\n 8.8417619937397E30,\r\n 2.65252859812191E32,\r\n 8.22283865417792E33,\r\n 2.63130836933694E35,\r\n 8.68331761881189E36\r\n );\r\n {$ENDIF MATH_DOUBLE_PRECISION}\r\n {$IFDEF MATH_EXTENDED_PRECISION}\r\n PreCompFacts: array [0..PreCompFactsCount] of Float =\r\n (\r\n 1.0,\r\n 1.0,\r\n 2.0,\r\n 6.0,\r\n 24.0,\r\n 120.0,\r\n 720.0,\r\n 5040.0,\r\n 40320.0,\r\n 362880.0,\r\n 3628800.0,\r\n 39916800.0,\r\n 479001600.0,\r\n 6227020800.0,\r\n 87178291200.0,\r\n 1307674368000.0,\r\n 20922789888000.0,\r\n 355687428096000.0,\r\n 6.402373705728E15,\r\n 1.21645100408832E17,\r\n 2.43290200817664E18,\r\n 5.10909421717094E19,\r\n 1.12400072777761E21,\r\n 2.5852016738885E22,\r\n 6.20448401733239E23,\r\n 1.5511210043331E25,\r\n 4.03291461126606E26,\r\n 1.08888694504184E28,\r\n 3.04888344611714E29,\r\n 8.8417619937397E30,\r\n 2.65252859812191E32,\r\n 8.22283865417792E33,\r\n 2.63130836933694E35,\r\n 8.68331761881189E36\r\n );\r\n {$ENDIF MATH_EXTENDED_PRECISION}\r\n\r\nfunction Factorial(const N: Integer): Float;\r\nvar\r\n I: Integer;\r\nbegin\r\n if (N < 0) or (N > MaxFactorial) then\r\n Result := 0.0\r\n else\r\n begin\r\n if N <= PreCompFactsCount then\r\n Result := PreCompFacts[N]\r\n else\r\n begin { TODO : Change following by: Gamma(N + 1) }\r\n Result := PreCompFacts[PreCompFactsCount];\r\n for I := PreCompFactsCount + 1 to N do\r\n Result := Result * I;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction Floor(const X: Float): Integer;\r\nbegin\r\n Result := Integer(Trunc(X));\r\n if Frac(X) < 0 then\r\n Dec(Result);\r\nend;\r\n\r\nfunction GCD(X, Y: Cardinal): Cardinal;\r\n{$IFDEF PUREPASCAL}\r\nbegin\r\n Result := X;\r\n while Y <> 0 do\r\n begin\r\n X := Result;\r\n Result := Y;\r\n Y := X mod Y;\r\n end;\r\nend;\r\n{$ELSE ~PUREPASCAL}\r\nassembler;\r\n{ Euclid's algorithm }\r\nasm\r\n // 32 --> EAX X\r\n // EDX Y\r\n // <-- EAX Result\r\n // 64 --> ECX X\r\n // EDX Y\r\n // <-- EAX Result\r\n {$IFDEF CPU64}\r\n MOV EAX, ECX\r\n {$ENDIF CPU64}\r\n JMP @01 // We start with EAX <- X, EDX <- Y, and check to see if Y=0\r\n@00:\r\n MOV ECX, EDX // ECX <- EDX prepare for division\r\n XOR EDX, EDX // clear EDX for Division\r\n DIV ECX // EAX <- EDX:EAX div ECX, EDX <- EDX:EAX mod ECX\r\n MOV EAX, ECX // EAX <- ECX, and repeat if EDX <> 0\r\n@01:\r\n AND EDX, EDX // test to see if EDX is zero, without changing EDX\r\n JNZ @00 // when EDX is zero EAX has the Result\r\nend;\r\n{$ENDIF ~PUREPASCAL}\r\n\r\nfunction ISqrt(const I: Smallint): Smallint;\r\n{$IFDEF PUREPASCAL}\r\nvar\r\n b, d: Smallint;\r\nbegin\r\n Result := -1;\r\n d := -1;\r\n b := 0;\r\n repeat\r\n Inc(Result);\r\n Inc(d, 2);\r\n b := b + d;\r\n until b > I;\r\nend;\r\n{$ELSE ~PUREPASCAL}\r\nassembler;\r\nasm\r\n // 32 --> AX I\r\n // <-- AX Result\r\n // 64 --> CX I\r\n // <-- AX Result\r\n {$IFDEF CPU32}\r\n PUSH EBX\r\n MOV CX, AX // load argument\r\n {$ENDIF CPU32}\r\n {$IFDEF CPU64}\r\n PUSH RBX\r\n {$ENDIF CPU64}\r\n\r\n MOV AX, -1 // init Result\r\n CWD // init odd numbers to -1\r\n XOR BX, BX // init perfect squares to 0\r\n@LOOP:\r\n INC AX // increment Result\r\n INC DX // compute\r\n INC DX // next odd number\r\n ADD BX, DX // next perfect square\r\n CMP BX, CX // perfect square > argument ?\r\n JBE @LOOP // until square greater than argument\r\n\r\n {$IFDEF CPU32}\r\n POP EBX\r\n {$ENDIF CPU32}\r\n {$IFDEF CPU64}\r\n POP RBX\r\n {$ENDIF CPU64}\r\nend;\r\n{$ENDIF ~PUREPASCAL}\r\n\r\nfunction LCM(const X, Y: Cardinal): Cardinal;\r\nvar\r\n E: Cardinal;\r\nbegin\r\n E := GCD(X, Y);\r\n if E > 0 then\r\n Result := (X div E) * Y\r\n else\r\n Result := 0;\r\nend;\r\n\r\nfunction NormalizeAngle(const Angle: Float): Float;\r\nbegin\r\n Result := Angle;\r\n if Result = 0 then\r\n Exit;\r\n\r\n {$IFDEF MATH_ANGLE_DEGREES}\r\n Result := DegToRad(Result);\r\n {$ENDIF MATH_ANGLE_DEGREES}\r\n {$IFDEF MATH_ANGLE_GRADS}\r\n Result := GradToRad(Result);\r\n {$ENDIF MATH_ANGLE_GRADS}\r\n\r\n if (Result < -Pi) or (Result >= Pi) then\r\n begin\r\n Result := Frac(Result * Inv2Pi);\r\n if Result < 0 then\r\n Result := Result + 1.0\r\n else\r\n Result := Result - 1.0;\r\n Result := Result * TwoPi;\r\n end;\r\n\r\n {$IFDEF MATH_ANGLE_DEGREES}\r\n Result := RadToDeg(Result);\r\n {$ENDIF MATH_ANGLE_DEGREES}\r\n {$IFDEF MATH_ANGLE_GRADS}\r\n Result := RadToGrad(Result);\r\n {$ENDIF MATH_ANGLE_GRADS}\r\nend;\r\n\r\nfunction Pythagoras(const X, Y: Float): Float;\r\nvar\r\n AbsX, AbsY: Float;\r\nbegin\r\n AbsX := Abs(X);\r\n AbsY := Abs(Y);\r\n\r\n if AbsX > AbsY then\r\n Result := AbsX * Sqrt(1.0 + Sqr(AbsY / AbsX))\r\n else\r\n if AbsY = 0.0 then\r\n Result := 0.0\r\n else\r\n Result := AbsY * Sqrt(1.0 + Sqr(AbsX / AbsY));\r\nend;\r\n\r\nfunction Sgn(const X: Float): Integer;\r\nbegin\r\n if X > 0.0 then\r\n Result := 1\r\n else\r\n if X < 0.0 then\r\n Result := -1\r\n else\r\n Result := 0;\r\nend;\r\n\r\nfunction Signe(const X, Y: Float): Float;\r\nbegin\r\n if X > 0.0 then\r\n begin\r\n if Y > 0.0 then\r\n Result := X\r\n else\r\n Result := -X;\r\n end\r\n else\r\n begin\r\n if Y < 0.0 then\r\n Result := X\r\n else\r\n Result := -X;\r\n end;\r\nend;\r\n\r\nfunction Ackermann(const A, B: Integer): Integer;\r\nbegin\r\n if A = 0 then\r\n begin\r\n Result := B + 1;\r\n Exit;\r\n end;\r\n\r\n if B = 0 then\r\n Result := Ackermann(A - 1, 1)\r\n else\r\n Result := Ackermann(A - 1, Ackermann(A, B - 1));\r\nend;\r\n\r\nfunction Fibonacci(const N: Integer): Integer;\r\nvar\r\n I: Integer;\r\n P1, P2: Integer;\r\nbegin\r\n Assert(N >= 0);\r\n Result := 0;\r\n P1 := 1;\r\n P2 := 1;\r\n\r\n if (N = 1) or (N = 2) then\r\n Result := 1\r\n else\r\n for I := 3 to N do\r\n begin\r\n Result := P1 + P2;\r\n P1 := P2;\r\n P2 := Result;\r\n end;\r\nend;\r\n\r\n//=== { TJclFlatSet } ========================================================\r\n\r\nconstructor TJclFlatSet.Create;\r\nbegin\r\n inherited Create;\r\n FBits := TBits.Create;\r\nend;\r\n\r\ndestructor TJclFlatSet.Destroy;\r\nbegin\r\n FBits.Free;\r\n FBits := nil;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJclFlatSet.Clear;\r\nbegin\r\n FBits.Size := 0;\r\nend;\r\n\r\nprocedure TJclFlatSet.Invert;\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := 0 to FBits.Size - 1 do\r\n FBits[I] := not FBits[I];\r\nend;\r\n\r\nprocedure TJclFlatSet.SetRange(const Low, High: Integer; const Value: Boolean);\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := High downto Low do\r\n FBits[I] := Value;\r\nend;\r\n\r\nfunction TJclFlatSet.GetBit(const Idx: Integer): Boolean;\r\nbegin\r\n Result := FBits[Idx];\r\nend;\r\n\r\nfunction TJclFlatSet.GetRange(const Low, High: Integer; const Value: Boolean): Boolean;\r\nvar\r\n I: Integer;\r\nbegin\r\n if not Value and (High >= FBits.Size) then\r\n begin\r\n Result := False;\r\n Exit;\r\n end;\r\n for I := Low to Min(High, FBits.Size - 1) do\r\n if FBits[I] <> Value then\r\n begin\r\n Result := False;\r\n Exit;\r\n end;\r\n Result := True;\r\nend;\r\n\r\nprocedure TJclFlatSet.SetBit(const Idx: Integer; const Value: Boolean);\r\nbegin\r\n FBits[Idx] := Value;\r\nend;\r\n\r\n//== { TJclSparseFlatSet } ===================================================\r\n\r\ndestructor TJclSparseFlatSet.Destroy;\r\nbegin\r\n Clear;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJclSparseFlatSet.Clear;\r\nvar\r\n F: Integer;\r\nbegin\r\n if FSetList <> nil then\r\n begin\r\n for F := 0 to FSetListEntries - 1 do\r\n if FSetList^[F] <> nil then\r\n Dispose(PDelphiSet(FSetList^[F]));\r\n FreeMem(FSetList, FSetListEntries * SizeOf(Pointer));\r\n FSetList := nil;\r\n FSetListEntries := 0;\r\n end;\r\nend;\r\n\r\nprocedure TJclSparseFlatSet.Invert;\r\nvar\r\n F: Integer;\r\nbegin\r\n for F := 0 to FSetListEntries - 1 do\r\n if FSetList^[F] <> nil then\r\n PDelphiSet(FSetList^[F])^ := CompleteDelphiSet - PDelphiSet(FSetList^[F])^;\r\nend;\r\n\r\nfunction TJclSparseFlatSet.GetBit(const Idx: Integer): Boolean;\r\nvar\r\n SetIdx: Integer;\r\nbegin\r\n SetIdx := Idx shr 8;\r\n Result := (SetIdx < FSetListEntries) and (FSetList^[SetIdx] <> nil) and\r\n (Byte(Idx and $FF) in PDelphiSet(FSetList^[SetIdx])^);\r\nend;\r\n\r\nprocedure TJclSparseFlatSet.SetBit(const Idx: Integer; const Value: Boolean);\r\nvar\r\n I, SetIdx: Integer;\r\n S: PDelphiSet;\r\nbegin\r\n SetIdx := Idx shr 8;\r\n if SetIdx >= FSetListEntries then\r\n if Value then\r\n begin\r\n I := FSetListEntries;\r\n FSetListEntries := SetIdx + 1;\r\n ReallocMem(FSetList, FSetListEntries * SizeOf(Pointer));\r\n FillChar(FSetList^[I], (FSetListEntries - I) * SizeOf(Pointer), #0);\r\n end\r\n else\r\n Exit;\r\n S := FSetList^[SetIdx];\r\n if S = nil then\r\n if Value then\r\n begin\r\n New(S);\r\n S^ := [];\r\n FSetList^[SetIdx] := S;\r\n end\r\n else\r\n Exit;\r\n Include(S^, Byte(Idx and $FF));\r\nend;\r\n\r\nprocedure TJclSparseFlatSet.SetRange(const Low, High: Integer; const Value: Boolean);\r\nvar\r\n I, LowSet, HighSet: Integer;\r\n\r\n procedure SetValue(const S: TDelphiSet; const SetIdx: Integer);\r\n var\r\n D: PDelphiSet;\r\n begin\r\n D := FSetList^[SetIdx];\r\n if D = nil then\r\n begin\r\n if Value then\r\n begin\r\n New(D);\r\n D^ := S;\r\n FSetList^[SetIdx] := D;\r\n end;\r\n end\r\n else\r\n if Value then\r\n D^ := D^ + S\r\n else\r\n D^ := D^ - S;\r\n end;\r\n\r\nbegin\r\n LowSet := Low shr 8;\r\n HighSet := High shr 8;\r\n if HighSet >= FSetListEntries then\r\n begin\r\n I := FSetListEntries;\r\n FSetListEntries := HighSet + 1;\r\n ReallocMem(FSetList, FSetListEntries * SizeOf(Pointer));\r\n FillChar(FSetList^[I], (FSetListEntries - I) * SizeOf(Pointer), #0);\r\n end;\r\n if LowSet = HighSet then\r\n SetValue([Byte(Low and $FF)..Byte(High and $FF)], LowSet)\r\n else\r\n begin\r\n SetValue([Byte(Low and $FF)..$FF], LowSet);\r\n SetValue([0..Byte(High and $FF)], HighSet);\r\n for I := LowSet + 1 to HighSet - 1 do\r\n SetValue(CompleteDelphiSet, I);\r\n end;\r\nend;\r\n\r\nfunction TJclSparseFlatSet.GetRange(const Low, High: Integer; const Value: Boolean): Boolean;\r\nvar\r\n I: Integer;\r\nbegin\r\n if not Value and (High >= FSetListEntries) then\r\n begin\r\n Result := False;\r\n Exit;\r\n end;\r\n for I := Low to Min(High, FSetListEntries) do\r\n if GetBit(I) <> Value then\r\n begin\r\n Result := False;\r\n Exit;\r\n end;\r\n Result := True;\r\nend;\r\n\r\n//=== Ranges =================================================================\r\n\r\nfunction EnsureRange(const AValue, AMin, AMax: Integer): Integer;\r\nbegin\r\n Result := AValue;\r\n Assert(AMin <= AMax);\r\n if Result < AMin then\r\n Result := AMin;\r\n if Result > AMax then\r\n Result := AMax;\r\nend;\r\n\r\nfunction EnsureRange(const AValue, AMin, AMax: Int64): Int64;\r\nbegin\r\n Result := AValue;\r\n Assert(AMin <= AMax);\r\n if Result < AMin then\r\n Result := AMin;\r\n if Result > AMax then\r\n Result := AMax;\r\nend;\r\n\r\nfunction EnsureRange(const AValue, AMin, AMax: Double): Double;\r\nbegin\r\n Result := AValue;\r\n Assert(AMin <= AMax);\r\n if Result < AMin then\r\n Result := AMin;\r\n if Result > AMax then\r\n Result := AMax;\r\nend;\r\n\r\n//=== Prime numbers ==========================================================\r\n\r\nconst\r\n PrimeCacheLimit = 65537; // 4K lookup table. Note: Sqr(65537) > MaxLongint\r\n\r\nvar\r\n PrimeSet: TJclFlatSet = nil;\r\n\r\nprocedure InitPrimeSet;\r\nvar\r\n I, J, MaxI, MaxJ : Integer;\r\nbegin\r\n PrimeSet := TJclFlatSet.Create;\r\n PrimeSet.SetRange(1, PrimeCacheLimit div 2, True);\r\n PrimeSet.SetBit(0, False); // 1 is no prime\r\n MaxI := Trunc(Sqrt(PrimeCacheLimit));\r\n I := 3;\r\n repeat\r\n if PrimeSet.GetBit(I div 2) then\r\n begin\r\n MaxJ := PrimeCacheLimit div I;\r\n J := 3;\r\n repeat\r\n PrimeSet.SetBit((I*J) div 2, False);\r\n Inc(J,2);\r\n until J > MaxJ;\r\n end;\r\n Inc(I, 2);\r\n until I > MaxI;\r\nend;\r\n\r\nfunction IsPrimeTD(N: Cardinal): Boolean;\r\n{ Trial Division Algorithm }\r\nvar\r\n I, Max: Cardinal;\r\n R: Extended;\r\nbegin\r\n if N = 2 then\r\n begin\r\n Result := True;\r\n Exit;\r\n end;\r\n if (N and 1) = 0 then //Zero or even\r\n begin\r\n Result := False;\r\n Exit;\r\n end;\r\n if PrimeSet = nil then // initialize look-up table\r\n InitPrimeSet;\r\n if N <= PrimeCacheLimit then // do look-up\r\n Result := PrimeSet.GetBit(N div 2)\r\n else\r\n begin // calculate\r\n R := N;\r\n Max := Round(Sqrt (R));\r\n if Max > PrimeCacheLimit then\r\n begin\r\n raise EJclMathError.CreateRes(@RsUnexpectedValue);\r\n Exit;\r\n end;\r\n I := 1;\r\n repeat\r\n Inc(I,2);\r\n if PrimeSet.GetBit(I div 2) then\r\n if N mod I = 0 then\r\n begin\r\n Result := False;\r\n Exit;\r\n end;\r\n until I >= Max;\r\n Result := True;\r\n end;\r\nend;\r\n\r\n{$IFDEF CPU32}\r\n// OF: need a complete rewrite for CPU64\r\n// OF: why is there less pop than push?\r\n\r\n{ Rabin-Miller Strong Primality Test }\r\n\r\nfunction IsPrimeRM(N: Cardinal): Boolean; assembler;\r\nasm\r\n // 32 --> EAX N\r\n // <-- AL Result\r\n TEST EAX,1 // Odd(N) ??\r\n JNZ @@1\r\n CMP EAX,2 // N == 2 ??\r\n SETE AL\r\n RET\r\n@@1: CMP EAX,73\r\n JBE @@C\r\n PUSH ESI\r\n PUSH EDI\r\n PUSH EBX\r\n PUSH EBP\r\n PUSH EAX // save N as Param for @@5\r\n MOV EBP, EAX\r\n DEC EBP // M == N -1, Exponent\r\n MOV ECX,32 // calc remaining Bits of M and shift M'\r\n MOV ESI,EBP\r\n@@2: DEC ECX\r\n SHL ESI,1\r\n JNC @@2\r\n PUSH ECX // save Bits as Param for @@5\r\n PUSH ESI // save M' as Param for @@5\r\n CMP EAX,08A8D7Fh // N >= 9080191 ??\r\n JAE @@3\r\n// now if (N < 9080191) and SPP(31, N) and SPP(73, N) then N is prime\r\n MOV EAX,31\r\n CALL @@5\r\n JC @@4\r\n MOV EAX,73\r\n PUSH OFFSET @@4\r\n JMP @@5\r\n// now if (N < 4759123141) and SPP(2, N) and SPP(7, N) and SPP(61, N) then N is prime\r\n@@3: MOV EAX,2\r\n CALL @@5\r\n JC @@4\r\n MOV EAX,7\r\n CALL @@5\r\n JC @@4\r\n MOV EAX,61\r\n CALL @@5\r\n@@4: SETNC AL\r\n ADD ESP,4 * 3\r\n POP EBP\r\n POP EBX\r\n POP EDI\r\n POP ESI\r\n RET\r\n// do a Strong Pseudo Prime Test\r\n@@5:\r\n MOV EBX,[ESP + 12] // N on stack\r\n MOV ECX,[ESP + 8] // remaining Bits\r\n MOV ESI,[ESP + 4] // M'\r\n MOV EDI,EAX // T = b, temp. Base\r\n@@6: DEC ECX\r\n MUL EAX\r\n DIV EBX\r\n MOV EAX,EDX\r\n SHL ESI,1\r\n JNC @@7\r\n MUL EDI\r\n DIV EBX\r\n AND ESI,ESI\r\n MOV EAX,EDX\r\n@@7: JNZ @@6\r\n CMP EAX,1 // b^((N -1)(2^s)) mod N == 1 mod N ??\r\n JE @@A\r\n@@8: CMP EAX,EBP // b^((N -1)(2^s)) mod N == -1 mod N ??\r\n JE @@A\r\n DEC ECX // second part to 2^s\r\n JNG @@9\r\n MUL EAX\r\n DIV EBX\r\n CMP EDX,1\r\n MOV EAX,EDX\r\n JNE @@8\r\n@@9: STC\r\n@@A: RET\r\n@@B: DB 3,5,7,11,13,17,19,23,29,31,37,41,43,47,53,59,61,67,71,73\r\n@@C: MOV ECX,19\r\n MOV EDX,OFFSET @@B\r\n@@D: CMP AL,[EDX + ECX]\r\n JE @@E\r\n DEC ECX\r\n JNL @@D\r\n@@E: SETE AL\r\nend;\r\n{$ENDIF CPU32}\r\n\r\nfunction PrimeFactors(N: Cardinal): TDynCardinalArray;\r\nvar\r\n I, L, Max: Cardinal;\r\n R: Extended;\r\nbegin\r\n SetLength(Result, 0);\r\n if N <= 1 then\r\n Exit\r\n else\r\n begin\r\n if PrimeSet = nil then\r\n InitPrimeSet;\r\n L := 0;\r\n R := N;\r\n R := Sqrt(R);\r\n Max := Round(R); // only one factor can be > Sqrt (N)\r\n if N mod 2 = 0 then // test even at first\r\n begin // 2 is a prime factor\r\n Inc(L);\r\n SetLength(Result, L);\r\n Result[L - 1] := 2;\r\n repeat\r\n N := N div 2;\r\n if N = 1 then // no more factors\r\n Exit;\r\n until N mod 2 <> 0;\r\n end;\r\n I := 3; // test all odd factors\r\n repeat\r\n if (N mod I = 0) and IsPrime(I) then\r\n begin // I is a prime factor\r\n Inc(L);\r\n SetLength(Result, L);\r\n Result[L - 1] := I;\r\n repeat\r\n N := N div I;\r\n if N = 1 then // no more factors\r\n Exit;\r\n until N mod I <> 0;\r\n end;\r\n Inc(I, 2);\r\n until I > Max;\r\n Inc(L); // final factor (> Sqrt(N))\r\n SetLength(Result, L);\r\n Result[L - 1] := N;\r\n end;\r\nend;\r\n\r\nfunction IsPrimeFactor(const F, N: Cardinal): Boolean;\r\nbegin\r\n Result := (N mod F = 0) and IsPrime(F);\r\nend;\r\n\r\nfunction IsRelativePrime(const X, Y: Cardinal): Boolean;\r\nbegin\r\n Result := GCD(X, Y) = 1;\r\nend;\r\n\r\nprocedure SetPrimalityTest(const Method: TPrimalityTestMethod);\r\nbegin\r\n case Method of\r\n ptTrialDivision:\r\n IsPrime := IsPrimeTD;\r\n {$IFDEF CPU32}\r\n ptRabinMiller:\r\n IsPrime := IsPrimeRM;\r\n {$ENDIF CPU32}\r\n end;\r\nend;\r\n\r\n{$IFDEF CPU32}\r\n\r\n//=== Floating point value classification ====================================\r\n\r\ntype\r\n TC3C2C0 = 0..6;\r\n\r\nconst\r\n FPClasses: array [TC3C2C0] of TFloatingPointClass =\r\n (\r\n fpInvalid,\r\n fpNaN,\r\n fpNormal,\r\n fpInfinite,\r\n fpZero,\r\n fpEmpty,\r\n fpDenormal\r\n );\r\n\r\n// _C3C2C0 returns the set of condition code flags C0, C2, and C3 of the FPU status word\r\n// to indicate the class of value or number in register ST(0) as follows:\r\n// C0 in Bit 0 of EAX\r\n// C2 in Bit 1 of EAX\r\n// C3 in Bit 2 of EAX\r\n\r\nfunction _C3C2C0: TC3C2C0; assembler;\r\n// In: ST(0) Value to examine\r\nasm\r\n FXAM\r\n XOR EDX, EDX\r\n FNSTSW AX\r\n FFREE ST(0)\r\n FINCSTP\r\n BT EAX, 14 // C3\r\n RCL EDX, 1\r\n BT EAX, 10 // C2\r\n RCL EDX, 1\r\n BT EAX, 8 // C0\r\n RCL EDX, 1\r\n MOV EAX, EDX\r\nend;\r\n\r\nfunction C3C2C0(const Value: Single): TC3C2C0; overload; assembler;\r\nasm\r\n FLD Value\r\n CALL _C3C2C0\r\nend;\r\n\r\nfunction C3C2C0(const Value: Double): TC3C2C0; overload; assembler;\r\nasm\r\n FLD Value\r\n CALL _C3C2C0\r\nend;\r\n\r\n{$IFDEF SUPPORTS_EXTENDED}\r\nfunction C3C2C0(const Value: Extended): TC3C2C0; overload; assembler;\r\nasm\r\n FLD Value\r\n CALL _C3C2C0\r\nend;\r\n{$ENDIF SUPPORTS_EXTENDED}\r\n\r\nfunction FloatingPointClass(const Value: Single): TFloatingPointClass; overload;\r\nbegin\r\n Result := FPClasses[C3C2C0(Value)];\r\nend;\r\n\r\nfunction FloatingPointClass(const Value: Double): TFloatingPointClass; overload;\r\nbegin\r\n Result := FPClasses[C3C2C0(Value)];\r\nend;\r\n\r\n{$IFDEF SUPPORTS_EXTENDED}\r\nfunction FloatingPointClass(const Value: Extended): TFloatingPointClass; overload;\r\nbegin\r\n Result := FPClasses[C3C2C0(Value)];\r\nend;\r\n{$ENDIF SUPPORTS_EXTENDED}\r\n\r\n//=== NaN and Infinity support ===============================================\r\n\r\nfunction IsInfinite(const Value: Single): Boolean; overload;\r\nbegin\r\n Result := FloatingPointClass(Value) = fpInfinite;\r\nend;\r\n\r\nfunction IsInfinite(const Value: Double): Boolean; overload;\r\nbegin\r\n Result := FloatingPointClass(Value) = fpInfinite;\r\nend;\r\n\r\n{$IFDEF SUPPORTS_EXTENDED}\r\nfunction IsInfinite(const Value: Extended): Boolean; overload;\r\nbegin\r\n Result := FloatingPointClass(Value) = fpInfinite;\r\nend;\r\n{$ENDIF SUPPORTS_EXTENDED}\r\n\r\nconst\r\n sSignBit = 31;\r\n dSignBit = 63;\r\n xSignBit = 79;\r\n\r\ntype\r\n TSingleBits = set of 0..sSignBit;\r\n TDoubleBits = set of 0..dSignBit;\r\n TExtendedBits = set of 0..xSignBit;\r\n\r\n sFractionBits = 0..22; // Single type fraction bits\r\n dFractionBits = 0..51; // Double type fraction bits\r\n xFractionBits = 0..62; // Extended type fraction bits\r\n\r\n sExponentBits = 23..sSignBit-1;\r\n dExponentBits = 52..dSignBit-1;\r\n xExponentBits = 64..xSignBit-1;\r\n\r\n {$IFNDEF FPC}\r\n QWord = Int64;\r\n {$ENDIF ~FPC}\r\n\r\n PExtendedRec = ^TExtendedRec;\r\n TExtendedRec = packed record\r\n Significand: QWord;\r\n Exponent: Word;\r\n end;\r\n\r\nconst\r\n ZeroTag = $3FFFFF;\r\n InvalidTag = TNaNTag($80000000);\r\n NaNTagMask = $3FFFFF;\r\n\r\n sNaNQuietFlag = High(sFractionBits);\r\n dNaNQuietFlag = High(dFractionBits);\r\n xNaNQuietFlag = High(xFractionBits);\r\n\r\n dNaNTagShift = High(dFractionBits) - High(sFractionBits);\r\n xNaNTagShift = High(xFractionBits) - High(sFractionBits);\r\n\r\n sNaNBits = $7F800000;\r\n dNaNBits = $7FF0000000000000;\r\n\r\n sQuietNaNBits = sNaNBits or (1 shl sNaNQuietFlag);\r\n dQuietNaNBits = dNaNBits or (Int64(1) shl dNaNQuietFlag);\r\n\r\nfunction IsNaN(const Value: Single): Boolean; overload;\r\nbegin\r\n Result := FloatingPointClass(Value) = fpNaN;\r\nend;\r\n\r\nfunction IsNaN(const Value: Double): Boolean; overload;\r\nbegin\r\n Result := FloatingPointClass(Value) = fpNaN;\r\nend;\r\n\r\n{$IFDEF SUPPORTS_EXTENDED}\r\nfunction IsNaN(const Value: Extended): Boolean; overload;\r\nbegin\r\n Result := FloatingPointClass(Value) = fpNaN;\r\nend;\r\n{$ENDIF SUPPORTS_EXTENDED}\r\n\r\nprocedure CheckNaN(const Value: Single); overload;\r\nvar\r\n SaveExMask: T8087Exceptions;\r\nbegin\r\n SaveExMask := Mask8087Exceptions([emInvalidOp]);\r\n try\r\n if FloatingPointClass(Value) <> fpNaN then\r\n raise EJclMathError.CreateRes(@RsNoNaN);\r\n finally\r\n SetMasked8087Exceptions(SaveExMask);\r\n end;\r\nend;\r\n\r\nprocedure CheckNaN(const Value: Double); overload;\r\nvar\r\n SaveExMask: T8087Exceptions;\r\nbegin\r\n SaveExMask := Mask8087Exceptions([emInvalidOp]);\r\n try\r\n if FloatingPointClass(Value) <> fpNaN then\r\n raise EJclMathError.CreateRes(@RsNoNaN);\r\n finally\r\n SetMasked8087Exceptions(SaveExMask);\r\n end;\r\nend;\r\n\r\n{$IFDEF SUPPORTS_EXTENDED}\r\nprocedure CheckNaN(const Value: Extended); overload;\r\nvar\r\n SaveExMask: T8087Exceptions;\r\nbegin\r\n SaveExMask := Mask8087Exceptions([emInvalidOp]);\r\n try\r\n if FloatingPointClass(Value) <> fpNaN then\r\n raise EJclMathError.CreateRes(@RsNoNaN);\r\n finally\r\n SetMasked8087Exceptions(SaveExMask);\r\n end;\r\nend;\r\n{$ENDIF SUPPORTS_EXTENDED}\r\n\r\nfunction GetNaNTag(const NaN: Single): TNaNTag;\r\nvar\r\n Temp: Integer;\r\nbegin\r\n CheckNaN(NaN);\r\n Temp := PLongint(@NaN)^ and NaNTagMask;\r\n if sSignBit in TSingleBits(NaN) then\r\n Result := -Temp\r\n else\r\n if Temp = ZeroTag then\r\n Result := 0\r\n else\r\n Result := Temp;\r\nend;\r\n\r\nfunction GetNaNTag(const NaN: Double): TNaNTag;\r\nvar\r\n Temp: Integer;\r\nbegin\r\n CheckNaN(NaN);\r\n Temp := (PInt64(@NaN)^ shr dNaNTagShift) and NaNTagMask;\r\n {$IFDEF FPC}\r\n if Int64(NaN) < 0 then\r\n {$ELSE ~FPC}\r\n if dSignBit in TDoubleBits(NaN) then\r\n {$ENDIF ~FPC}\r\n Result := -Temp\r\n else\r\n if Temp = ZeroTag then\r\n Result := 0\r\n else\r\n Result := Temp;\r\nend;\r\n\r\n{$IFDEF SUPPORTS_EXTENDED}\r\nfunction GetNaNTag(const NaN: Extended): TNaNTag;\r\nvar\r\n Temp: Integer;\r\nbegin\r\n CheckNaN(NaN);\r\n Temp := (PExtendedRec(@NaN)^.Significand shr xNaNTagShift) and NaNTagMask;\r\n {$IFDEF FPC}\r\n if (TExtendedRec(NaN).Exponent and $8000) <> 0 then\r\n {$ELSE ~FPC}\r\n if xSignBit in TExtendedBits(NaN) then\r\n {$ENDIF ~FPC}\r\n Result := -Temp\r\n else\r\n if Temp = ZeroTag then\r\n Result := 0\r\n else\r\n Result := Temp;\r\nend;\r\n{$ENDIF SUPPORTS_EXTENDED}\r\n\r\n{$IFDEF MSWINDOWS}\r\n// ExceptObjProc is not used in FPC\r\n{$IFNDEF FPC}\r\n\r\ntype\r\n TRealType = (rtUndef, rtSingle, rtDouble, rtExtended);\r\n\r\n { ExceptionInformation record for FPU exceptions under WinNT,\r\n where documented? }\r\n PFPUExceptionInfo = ^TFPUExceptionInfo;\r\n TFPUExceptionInfo = packed record\r\n Unknown: array [0..7] of Longint;\r\n ControlWord: Word;\r\n Dummy1: Word;\r\n StatusWord: Word;\r\n Dummy2: Word;\r\n TagWord: Word;\r\n Dummy3: Word;\r\n InstructionPtr: Pointer;\r\n UnknownW: Word;\r\n OpCode: Word; // Note: 5 most significant bits of first opcode byte\r\n // (always 11011b) not stored in FPU opcode register\r\n OperandPtr: Pointer;\r\n UnknownL: Longint;\r\n end;\r\n\r\n TExceptObjProc = function(P: PExceptionRecord): Exception;\r\n\r\nvar\r\n PrevExceptObjProc: TExceptObjProc;\r\n ExceptObjProcInitialized: Integer = 0;\r\n\r\nfunction GetExceptionObject(P: PExceptionRecord): Exception;\r\nvar\r\n Tag: TNaNTag;\r\n FPUExceptInfo: PFPUExceptionInfo;\r\n OPtr: Pointer;\r\n OType: TRealType;\r\n\r\n function GetOperandType(OpCode: Word): TRealType;\r\n var\r\n NNN: 0..7;\r\n begin\r\n Result := rtUndef;\r\n NNN := (Lo(OpCode) shr 3) and 7; // NNN field of ModR/M byte\r\n if Lo(OpCode) <= $BF then\r\n case Hi(OpCode) of // 3 least significant bits of first opcode byte\r\n 0:\r\n Result := rtSingle;\r\n 1:\r\n if NNN < 4 then\r\n Result := rtSingle;\r\n // Extended signaling NaNs don't cause exceptions on FLD/FST(P) ?!\r\n 3:\r\n if NNN = 5 then\r\n Result := rtExtended;\r\n 4:\r\n Result := rtDouble;\r\n 5:\r\n if NNN = 0 then\r\n Result := rtDouble;\r\n end;\r\n end;\r\n\r\nbegin\r\n Tag := InvalidTag; // shut up compiler warning\r\n OType := rtUndef;\r\n if P^.ExceptionCode = STATUS_FLOAT_INVALID_OPERATION then\r\n begin\r\n FPUExceptInfo := @P^.ExceptionInformation;\r\n OPtr := FPUExceptInfo^.OperandPtr;\r\n OType := GetOperandType(FPUExceptInfo^.OpCode);\r\n case OType of\r\n rtSingle:\r\n Tag := GetNaNTag(PSingle(OPtr)^);\r\n rtDouble:\r\n Tag := GetNaNTag(PDouble(OPtr)^);\r\n rtExtended:\r\n Tag := GetNaNTag(PExtended(OPtr)^);\r\n end;\r\n end;\r\n\r\n if OType = rtUndef then\r\n Result := PrevExceptObjProc(P)\r\n else\r\n Result := EJclNaNSignal.Create(Tag);\r\nend;\r\n\r\nprocedure InitExceptObjProc;\r\nbegin\r\n if LockedExchange(ExceptObjProcInitialized, 1) = 0 then\r\n if Win32Platform = VER_PLATFORM_WIN32_NT then\r\n {$IFDEF FPC}\r\n PrevExceptObjProc := Pointer(InterlockedExchange(TJclAddr(ExceptObjProc), TJclAddr(@GetExceptionObject)));\r\n {$ELSE ~FPC}\r\n PrevExceptObjProc := Pointer(InterlockedExchange(Integer(ExceptObjProc), Integer(@GetExceptionObject)));\r\n {$ENDIF ~FPC}\r\nend;\r\n{$ENDIF ~FPC}\r\n{$ENDIF MSWINDOWS}\r\n\r\nprocedure CheckTag(Tag: TNaNTag);\r\nbegin\r\n if (Tag < LowValidNaNTag) or (Tag > HighValidNaNTag) then\r\n raise EJclMathError.CreateResFmt(@RsNaNTagError, [Tag]);\r\nend;\r\n\r\nprocedure MakeQuietNaN(var X: Single; Tag: TNaNTag);\r\nvar\r\n Bits: LongWord;\r\nbegin\r\n CheckTag(Tag);\r\n if Tag = 0 then\r\n Bits := ZeroTag or sQuietNaNBits\r\n else\r\n Bits := Abs(Tag) or sQuietNaNBits;\r\n if Tag < 0 then\r\n Include(TSingleBits(Bits), sSignBit);\r\n PLongWord(@X)^ := Bits;\r\nend;\r\n\r\nprocedure MakeQuietNaN(var X: Double; Tag: TNaNTag);\r\nvar\r\n Bits: Int64;\r\nbegin\r\n CheckTag(Tag);\r\n if Tag = 0 then\r\n Bits := ZeroTag\r\n else\r\n Bits := Abs(Tag);\r\n PInt64(@X)^ := (Bits shl dNaNTagShift) or dQuietNaNBits;\r\n if Tag < 0 then\r\n {$IFDEF FPC}\r\n QWord(X) := QWord(X) or (1 shl dSignBit);\r\n {$ELSE ~FPC}\r\n Include(TDoubleBits(X), dSignBit);\r\n {$ENDIF ~FPC}\r\nend;\r\n\r\n{$IFDEF SUPPORTS_EXTENDED}\r\nprocedure MakeQuietNaN(var X: Extended; Tag: TNaNTag);\r\nconst\r\n QuietNaNSignificand = $C000000000000000;\r\n QuietNaNExponent = $7FFF;\r\nvar\r\n Bits: Int64;\r\nbegin\r\n CheckTag(Tag);\r\n if Tag = 0 then\r\n Bits := ZeroTag\r\n else\r\n Bits := Abs(Tag);\r\n TExtendedRec(X).Significand := (Bits shl xNaNTagShift) or QuietNaNSignificand;\r\n TExtendedRec(X).Exponent := QuietNaNExponent;\r\n if Tag < 0 then\r\n {$IFDEF FPC}\r\n TExtendedRec(X).Exponent := TExtendedRec(X).Exponent or $8000;\r\n {$ELSE ~FPC}\r\n Include(TExtendedBits(X), xSignBit);\r\n {$ENDIF ~FPC}\r\nend;\r\n{$ENDIF SUPPORTS_EXTENDED}\r\n\r\nprocedure MakeSignalingNaN(var X: Single; Tag: TNaNTag);\r\nbegin\r\n {$IFDEF MSWINDOWS}\r\n {$IFNDEF FPC}\r\n InitExceptObjProc;\r\n {$ENDIF ~FPC}\r\n {$ENDIF MSWINDOWS}\r\n MakeQuietNaN(X, Tag);\r\n Exclude(TSingleBits(X), sNaNQuietFlag);\r\nend;\r\n\r\nprocedure MakeSignalingNaN(var X: Double; Tag: TNaNTag);\r\nbegin\r\n {$IFDEF MSWINDOWS}\r\n {$IFNDEF FPC}\r\n InitExceptObjProc;\r\n {$ENDIF ~FPC}\r\n {$ENDIF MSWINDOWS}\r\n {$IFDEF FPC}\r\n MakeQuietNaN(X, Tag);\r\n QWord(X) := QWord(X) and not (1 shl dNaNQuietFlag);\r\n {$ELSE ~FPC}\r\n MakeQuietNaN(X, Tag);\r\n Exclude(TDoubleBits(X), dNaNQuietFlag);\r\n {$ENDIF ~FPC}\r\nend;\r\n\r\n{$IFDEF SUPPORTS_EXTENDED}\r\nprocedure MakeSignalingNaN(var X: Extended; Tag: TNaNTag);\r\nbegin\r\n {$IFDEF FPC}\r\n MakeQuietNaN(X, Tag);\r\n TExtendedRec(X).Significand := TExtendedRec(X).Significand and not (1 shl xNaNQuietFlag);\r\n {$ELSE ~FPC}\r\n {$IFDEF MSWINDOWS}\r\n InitExceptObjProc;\r\n {$ENDIF MSWINDOWS}\r\n MakeQuietNaN(X, Tag);\r\n Exclude(TExtendedBits(X), xNaNQuietFlag);\r\n {$ENDIF ~FPC}\r\nend;\r\n{$ENDIF SUPPORTS_EXTENDED}\r\n\r\nprocedure MineSingleBuffer(var Buffer; Count: Integer; StartTag: TNaNTag);\r\nvar\r\n Tag, StopTag: TNaNTag;\r\n P: PLongint;\r\nbegin\r\n {$IFDEF MSWINDOWS}\r\n {$IFNDEF FPC}\r\n InitExceptObjProc;\r\n {$ENDIF ~FPC}\r\n {$ENDIF MSWINDOWS}\r\n StopTag := StartTag + Count - 1;\r\n CheckTag(StartTag);\r\n CheckTag(StopTag);\r\n P := @Buffer;\r\n for Tag := StartTag to StopTag do\r\n begin\r\n if Tag > 0 then\r\n P^ := sNaNBits or Tag\r\n else\r\n if Tag < 0 then\r\n P^ := sNaNBits or Longint($80000000) or -Tag\r\n else\r\n P^ := sNaNBits or ZeroTag;\r\n Inc(P);\r\n end;\r\nend;\r\n\r\nprocedure MineDoubleBuffer(var Buffer; Count: Integer; StartTag: TNaNTag);\r\nvar\r\n Tag, StopTag: TNaNTag;\r\n P: PInt64;\r\nbegin\r\n {$IFDEF MSWINDOWS}\r\n {$IFNDEF FPC}\r\n InitExceptObjProc;\r\n {$ENDIF ~FPC}\r\n {$ENDIF MSWINDOWS}\r\n StopTag := StartTag + Count - 1;\r\n CheckTag(StartTag);\r\n CheckTag(StopTag);\r\n P := @Buffer;\r\n for Tag := StartTag to StopTag do\r\n begin\r\n if Tag > 0 then\r\n P^ := dNaNBits or (Int64(Tag) shl dNaNTagShift)\r\n else\r\n if Tag < 0 then\r\n P^ := dNaNBits or $8000000000000000 or (Int64(-Tag) shl dNaNTagShift)\r\n else\r\n P^ := dNaNBits or (Int64(ZeroTag) shl dNaNTagShift);\r\n Inc(P);\r\n end;\r\nend;\r\n\r\nfunction MinedSingleArray(Length: Integer): TDynSingleArray;\r\nbegin\r\n SetLength(Result, Length);\r\n MineSingleBuffer(Result[0], Length, 0);\r\nend;\r\n\r\nfunction MinedDoubleArray(Length: Integer): TDynDoubleArray;\r\nbegin\r\n SetLength(Result, Length);\r\n MineDoubleBuffer(Result[0], Length, 0);\r\nend;\r\n\r\nfunction IsSpecialValue(const X: Float): Boolean;\r\nbegin\r\n Result := IsNaN(X) or IsInfinite(X);\r\nend;\r\n\r\n//=== { EJclNaNSignal } ======================================================\r\n\r\nconstructor EJclNaNSignal.Create(ATag: TNaNTag; Dummy: Boolean);\r\nbegin\r\n FTag := ATag;\r\n CreateResFmt(@RsNaNSignal, [ATag]);\r\nend;\r\n\r\n{$ENDIF CPU32}\r\n\r\n//=== { TJclRational } =======================================================\r\n\r\nconstructor TJclRational.Create(const Numerator: Integer; const Denominator: Integer);\r\nbegin\r\n inherited Create;\r\n Assign(Numerator, Denominator);\r\nend;\r\n\r\nconstructor TJclRational.Create;\r\nbegin\r\n inherited Create;\r\n AssignZero;\r\nend;\r\n\r\nconstructor TJclRational.Create(const R: Float);\r\nbegin\r\n inherited Create;\r\n Assign(R);\r\nend;\r\n\r\nprocedure TJclRational.Simplify;\r\nvar\r\n I: Integer;\r\nbegin\r\n if FN < 0 then\r\n begin\r\n FT := -FT;\r\n FN := -FN;\r\n end;\r\n\r\n if (FT = 1) or (FN = 1) or (FT = 0) then\r\n Exit;\r\n\r\n I := GCD(System.Abs(FT), FN);\r\n FT := FT div I;\r\n FN := FN div I;\r\nend;\r\n\r\nprocedure TJclRational.Assign(const Numerator: Integer; const Denominator: Integer);\r\nbegin\r\n if Denominator = 0 then\r\n raise EJclMathError.CreateRes(@RsInvalidRational);\r\n FT := Numerator;\r\n FN := Denominator;\r\n if FN <> 1 then\r\n Simplify;\r\nend;\r\n\r\nprocedure TJclRational.Assign(const R: TJclRational);\r\nbegin\r\n FT := R.FT;\r\n FN := R.FN;\r\nend;\r\n\r\nprocedure TJclRational.Assign(const R: Float);\r\nvar\r\n T: TJclRational;\r\n Z: Integer;\r\n\r\n function CalcFrac(const R: Float; const Level: Integer): TJclRational;\r\n var\r\n I: Float;\r\n Z: Integer;\r\n begin\r\n if IsFloatZero(R) or (Level = 12) then // 0 (if Level = 12 we get an approximation)\r\n Result := TJclRational.Create\r\n else\r\n if FloatsEqual(R, 1.0) then // 1\r\n begin\r\n Result := TJclRational.Create;\r\n Result.AssignOne;\r\n end\r\n else\r\n if IsFloatZero(Frac(R * 1E8)) then // terminating decimal (<8)\r\n Result := TJclRational.Create(Trunc(R * 1E8), 100000000)\r\n else\r\n begin // recursive process\r\n I := 1.0 / R;\r\n Result := CalcFrac(Frac(I), Level + 1);\r\n Z := Trunc(I);\r\n Result.Add(Z);\r\n Result.Reciprocal;\r\n end;\r\n end;\r\n\r\nbegin\r\n T := CalcFrac(Frac(R), 1);\r\n try\r\n Z := Trunc(R);\r\n T.Add(Z);\r\n Assign(T);\r\n finally\r\n T.Free;\r\n end;\r\nend;\r\n\r\nprocedure TJclRational.AssignOne;\r\nbegin\r\n FT := 1;\r\n FN := 1;\r\nend;\r\n\r\nprocedure TJclRational.AssignZero;\r\nbegin\r\n FT := 0;\r\n FN := 1;\r\nend;\r\n\r\nfunction TJclRational.IsEqual(const Numerator: Integer; const Denominator: Integer): Boolean;\r\nvar\r\n R: TJclRational;\r\nbegin\r\n R := TJclRational.Create(Numerator, Denominator);\r\n Result := IsEqual(R);\r\n R.Free;\r\nend;\r\n\r\nfunction TJclRational.IsEqual(const R: TJclRational): Boolean;\r\nbegin\r\n Result := (FT = R.FT) and (FN = R.FN);\r\nend;\r\n\r\nfunction TJclRational.IsEqual(const R: Float): Boolean;\r\nbegin\r\n Result := FloatsEqual(R, GetAsFloat);\r\nend;\r\n\r\nfunction TJclRational.IsOne: Boolean;\r\nbegin\r\n Result := (FT = 1) and (FN = 1);\r\nend;\r\n\r\nfunction TJclRational.IsZero: Boolean;\r\nbegin\r\n Result := FT = 0;\r\nend;\r\n\r\nfunction TJclRational.Duplicate: TJclRational;\r\nbegin\r\n Result := TJclRational.Create(FT, FN);\r\nend;\r\n\r\nprocedure TJclRational.SetAsFloat(const R: Float);\r\nbegin\r\n Assign(R);\r\nend;\r\n\r\nprocedure TJclRational.SetAsString(const S: string);\r\nvar\r\n F: Integer;\r\nbegin\r\n F := Pos('/', S);\r\n if F = 0 then\r\n Assign(StrToFloat(S))\r\n else\r\n Assign(StrToInt(Trim(Copy(S,1,F - 1))), StrToInt(Trim(Copy(S, F + 1,Length(s)))));\r\nend;\r\n\r\nfunction TJclRational.GetAsFloat: Float;\r\nbegin\r\n Result := FT / FN;\r\nend;\r\n\r\nfunction TJclRational.GetAsString: string;\r\nbegin\r\n Result := IntToStr(FT) + '/' + IntToStr(FN);\r\nend;\r\n\r\nprocedure TJclRational.Add(const R: TJclRational);\r\nbegin\r\n FT := FT * R.FN + R.FT * FN;\r\n FN := FN * R.FN;\r\n Simplify;\r\nend;\r\n\r\nprocedure TJclRational.Add(const V: Integer);\r\nbegin\r\n Inc(FT, FN * V);\r\nend;\r\n\r\nprocedure TJclRational.Add(const V: Float);\r\nbegin\r\n Assign(GetAsFloat + V);\r\nend;\r\n\r\nprocedure TJclRational.Subtract(const V: Float);\r\nbegin\r\n Assign(GetAsFloat - V);\r\nend;\r\n\r\nprocedure TJclRational.Subtract(const R: TJclRational);\r\nbegin\r\n FT := FT * R.FN - R.FT * FN;\r\n FN := FN * R.FN;\r\n Simplify;\r\nend;\r\n\r\nprocedure TJclRational.Subtract(const V: Integer);\r\nbegin\r\n Dec(FT, FN * V);\r\nend;\r\n\r\nprocedure TJclRational.Negate;\r\nbegin\r\n FT := -FT;\r\nend;\r\n\r\nprocedure TJclRational.Abs;\r\nbegin\r\n FT := System.Abs(FT);\r\n FN := System.Abs(FN);\r\nend;\r\n\r\nfunction TJclRational.Sgn: Integer;\r\nbegin\r\n if FT = 0 then\r\n Result := 0\r\n else\r\n begin\r\n if JclMathSgn(FT) = JclMathSgn(FN) then\r\n Result := 1\r\n else\r\n Result := -1;\r\n end;\r\nend;\r\n\r\nprocedure TJclRational.Divide(const V: Integer);\r\nbegin\r\n if V = 0 then\r\n raise EJclMathError.CreateRes(@RsDivByZero);\r\n\r\n FN := FN * V;\r\n Simplify;\r\nend;\r\n\r\nprocedure TJclRational.Divide(const R: TJclRational);\r\nbegin\r\n if R.FT = 0 then\r\n raise EJclMathError.CreateRes(@RsRationalDivByZero);\r\n\r\n FT := FT * R.FN;\r\n FN := FN * R.FT;\r\n Simplify;\r\nend;\r\n\r\nprocedure TJclRational.Divide(const V: Float);\r\nbegin\r\n Assign(GetAsFloat / V);\r\nend;\r\n\r\nprocedure TJclRational.Reciprocal;\r\nbegin\r\n if FT = 0 then\r\n raise EJclMathError.CreateRes(@RsRationalDivByZero);\r\n\r\n SwapOrd(FT, FN);\r\nend;\r\n\r\nprocedure TJclRational.Multiply(const R: TJclRational);\r\nbegin\r\n FT := FT * R.FT;\r\n FN := FN * R.FN;\r\n Simplify;\r\nend;\r\n\r\nprocedure TJclRational.Multiply(const V: Integer);\r\nbegin\r\n FT := FT * V;\r\n Simplify;\r\nend;\r\n\r\nprocedure TJclRational.Multiply(const V: Float);\r\nbegin\r\n Assign(GetAsFloat * V);\r\nend;\r\n\r\nprocedure TJclRational.Power(const R: TJclRational);\r\nbegin\r\n Assign(JclMathPower(GetAsFloat, R.GetAsFloat));\r\nend;\r\n\r\nprocedure TJclRational.Power(const V: Integer);\r\nvar\r\n T, N: Extended;\r\nbegin\r\n T := FT;\r\n N := FN;\r\n FT := Round(JclMathPower(T, V));\r\n FN := Round(JclMathPower(N, V));\r\nend;\r\n\r\nprocedure TJclRational.Power(const V: Float);\r\nbegin\r\n Assign(JclMathPower(FT, V) / JclMathPower(FN, V));\r\nend;\r\n\r\nprocedure TJclRational.Sqrt;\r\nbegin\r\n Assign(System.Sqrt(FT / FN));\r\nend;\r\n\r\nprocedure TJclRational.Sqr;\r\nbegin\r\n FT := System.Sqr(FT);\r\n FN := System.Sqr(FN);\r\nend;\r\n\r\n//=== Checksums ==============================================================\r\n\r\n// See also: CountBitsSet in JclLogic (bug fixing etc.) - similar algorithm!\r\n\r\nfunction GetParity(Buffer: TDynByteArray; Len: Integer): Boolean;\r\nconst\r\n lu: packed array [0..15] of Byte =\r\n (0, 1, 1, 2, 1, 2, 2, 3, 1, 2, 2, 3, 2, 3, 3, 4);\r\nvar\r\n b: Byte;\r\n BitsSet: Cardinal;\r\n Index: Cardinal;\r\nbegin\r\n BitsSet := 0;\r\n Index := 0;\r\n if Len > Length(Buffer) then\r\n Len := Length(Buffer);\r\n while Len > 0 do\r\n begin\r\n b := Buffer[Index];\r\n // lower Nibble\r\n Inc(BitsSet, lu[b and $0F]);\r\n // upper Nibble\r\n Inc(BitsSet, lu[b shr 4]);\r\n\r\n Dec(Len);\r\n Inc(Index);\r\n end;\r\n\r\n Result := (BitsSet mod 2) = 0;\r\nend;\r\n\r\nfunction GetParity(Buffer: PByte; Len: Integer): Boolean;\r\nconst\r\n lu: packed array [0..15] of Byte =\r\n (0, 1, 1, 2, 1, 2, 2, 3, 1, 2, 2, 3, 2, 3, 3, 4);\r\nvar\r\n b: Byte;\r\n BitsSet: Cardinal;\r\nbegin\r\n BitsSet := 0;\r\n while Len > 0 do\r\n begin\r\n b := PByte(Buffer)^;\r\n // lower Nibble\r\n Inc(BitsSet, lu[b and $0F]);\r\n // upper Nibble\r\n Inc(BitsSet, lu[b shr 4]);\r\n\r\n Dec(Len);\r\n Inc(PByte(Buffer));\r\n end;\r\n\r\n Result := (BitsSet mod 2) = 0;\r\nend;\r\n\r\n// CRC 16\r\n\r\nfunction Crc16Corr(const Crc16Table: TCrc16Table; Crc: Word; N: Integer): Integer;\r\nvar\r\n I: Integer;\r\n// CrcX : Cardinal;\r\nbegin\r\n // calculate Syndrome\r\n// CrcX := CrC;\r\n for I := 1 to Crc16Bytes do\r\n // a 16 bit value shr 8 is a Byte, explictit type conversion to Byte adds an ASM instruction\r\n Crc := Crc16Table[Crc shr (CRC16Bits - 8)] xor Word(Crc shl 8);\r\n I := -1;\r\n repeat\r\n Inc(I);\r\n if (Crc and 1) <> 0 then\r\n Crc := ((Crc xor Crc16Table[1]) shr 1) or Crc16HighBit\r\n// Crc16Table[1] = Crc16Polynom\r\n else\r\n Crc := (Crc shr 1) and NotCrc16HighBit;\r\n until (Crc = Crc16HighBit) or (I = (N + Crc16Bytes) * 8);\r\n if Crc <> Crc16HighBit then\r\n Result := -1000 // not correctable\r\n else\r\n // I = No. of single faulty bit\r\n // (high bit first,\r\n // starting from lowest with CRC bits)\r\n Result := I - Crc16Bits;\r\n // Result < 0 faulty CRC-bit\r\n // Result >= 0 No. of faulty data bit\r\nend;\r\n\r\nfunction Crc16_P(const Crc16Table: TCrc16Table; X: PJclByteArray; N: Integer; Crc: Word): Word;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := Crc16DefaultStart;\r\n for I := 0 to N - 1 do // The CRC Bytes are located at the end of the information\r\n // a 16 bit value shr 8 is a Byte, explictit type conversion to Byte adds an ASM instruction\r\n Result := Crc16Table[Result shr (CRC16Bits - 8)] xor Word((Result shl 8)) xor X[I];\r\n for I := 0 to Crc16Bytes - 1 do\r\n begin\r\n // a 16 bit value shr 8 is a Byte, explictit type conversion to Byte adds an ASM instruction\r\n Result := Crc16Table[Result shr (CRC16Bits-8)] xor Word((Result shl 8)) xor (Crc shr (CRC16Bits-8));\r\n Crc := Word(Crc shl 8);\r\n end;\r\nend;\r\n\r\nfunction Crc16_P(X: PJclByteArray; N: Integer; Crc: Word): Word;\r\nbegin\r\n Result := Crc16_P(Crc16DefaultTable, X, N, Crc);\r\nend;\r\n\r\nfunction CheckCrc16_P(const Crc16Table: TCrc16Table; X: PJclByteArray; N: Integer; Crc: Word): Integer;\r\n// checks and corrects a single bit in up to 2^15-16 Bit -> 2^12-2 = 4094 Byte\r\nvar\r\n I, J: Integer;\r\n C: Byte;\r\nbegin\r\n Crc := Crc16_P(Crc16Table, X, N, Crc);\r\n if Crc = 0 then\r\n Result := 0 // No CRC-error\r\n else\r\n begin\r\n J := Crc16Corr(Crc16Table, Crc, N);\r\n if J < -(Crc16Bytes * 8 + 1) then\r\n Result := -1 // non-correctable error (more than one wrong bit)\r\n else\r\n begin\r\n if J < 0 then\r\n Result := 1 // one faulty Bit in CRC itself\r\n else\r\n begin // Bit J is faulty\r\n I := J and 7; // I <= 7 (faulty Bit in Byte)\r\n C := 1 shl I; // C <= 128\r\n I := J shr 3; // I: Index of faulty Byte\r\n X[N - 1 - I] := X[N - 1 - I] xor C; // correct faulty bit\r\n Result := 1; // Correctable error\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction CheckCrc16_P(X: PJclByteArray; N: Integer; Crc: Word): Integer;\r\nbegin\r\n Result := CheckCrc16_P(Crc16DefaultTable, X, N, Crc);\r\nend;\r\n\r\nfunction Crc16(const Crc16Table: TCrc16Table; const X: array of Byte; N: Integer; Crc: Word): Word;\r\nbegin\r\n Result := Crc16_P(Crc16Table, @X, N, Crc);\r\nend;\r\n\r\nfunction Crc16(const X: array of Byte; N: Integer; Crc: Word): Word;\r\nbegin\r\n Result := Crc16_P(Crc16DefaultTable, @X, N, Crc);\r\nend;\r\n\r\nfunction CheckCrc16(const Crc16Table: TCrc16Table; var X: array of Byte; N: Integer; Crc: Word): Integer;\r\nbegin\r\n Result := CheckCRC16_P(Crc16Table, @X, N, CRC);\r\nend;\r\n\r\nfunction CheckCrc16(var X: array of Byte; N: Integer; Crc: Word): Integer;\r\nbegin\r\n Result := CheckCRC16_P(Crc16DefaultTable, @X, N, CRC);\r\nend;\r\n\r\nfunction Crc16_A(const Crc16Table: TCrc16Table; const X: array of Byte; Crc: Word): Word;\r\nbegin\r\n Result := Crc16_P(Crc16Table, @X, Length(X), Crc);\r\nend;\r\n\r\nfunction Crc16_A(const X: array of Byte; Crc: Word): Word;\r\nbegin\r\n Result := Crc16_P(Crc16DefaultTable, @X, Length(X), Crc);\r\nend;\r\n\r\nfunction CheckCrc16_A(const Crc16Table: TCrc16Table; var X: array of Byte; Crc: Word): Integer;\r\nbegin\r\n Result := CheckCrc16_P(Crc16Table, @X, Length(X), Crc);\r\nend;\r\n\r\nfunction CheckCrc16_A(var X: array of Byte; Crc: Word): Integer;\r\nbegin\r\n Result := CheckCrc16_P(Crc16DefaultTable, @X, Length(X), Crc);\r\nend;\r\n\r\n// The CRC Table can be generated like this:\r\n// const Crc16Start0 = 0; !!\r\n\r\nfunction Crc16_Bitwise(const X: array of Byte; N: Integer; Crc: Word; Polynom: Word): Word;\r\nconst\r\n Crc16Start0 = 0; //Generating the table\r\nvar\r\n I, J: Integer;\r\n Sr, SrHighBit: Word;\r\n B: Byte;\r\nbegin\r\n Sr := Crc16Start0;\r\n SrHighBit := 0;\r\n for I := 0 to N - 1 + Crc16Bytes do\r\n begin\r\n if I >= N then\r\n begin\r\n B := Crc shr (Crc16Bits - 8);\r\n Crc := Crc shl 8;\r\n end\r\n else\r\n B := X[I];\r\n for J := 1 to 8 do\r\n begin\r\n if SrHighBit <> 0 then\r\n Sr := Sr xor Polynom;\r\n SrHighBit := Sr and Crc16HighBit;\r\n Sr := (Word (Sr shl 1)) or ((B shr 7) and 1);\r\n B := Byte(B shl 1);\r\n end;\r\n end;\r\n if SrHighBit <> 0 then\r\n Sr := Sr xor Polynom;\r\n Result := Sr;\r\nend;\r\n\r\nprocedure InitCrc16(Polynom, Start: Word; out Crc16Table: TCrc16Table);\r\nvar\r\n X: array [0..0] of Byte;\r\n I: Integer;\r\nbegin\r\n for I := 0 to 255 do\r\n begin\r\n X[0] := I;\r\n Crc16Table[I] := Crc16_Bitwise(X, 1, 0, Polynom); { only with crcstart=0 !!!!}\r\n end;\r\n Crc16DefaultStart := Start;\r\nend;\r\n\r\nprocedure InitCrc16(Polynom, Start: Word);\r\nbegin\r\n InitCrc16(Polynom, Start, Crc16DefaultTable);\r\nend;\r\n\r\n// CRC 32\r\n\r\nfunction Crc32Corr(const Crc32Table: TCrc32Table; Crc: Cardinal; N: Integer): Integer;\r\nvar\r\n I: Integer;\r\nbegin\r\n // calculate Syndrome\r\n for I := 1 to Crc32Bytes do\r\n Crc := Crc32Table[Crc shr (CRC32Bits - 8)] xor (Crc shl 8);\r\n I := -1;\r\n repeat\r\n Inc(I);\r\n if (Crc and 1) <> 0 then\r\n Crc := ((Crc xor Crc32Table[1]) shr 1) or Crc32HighBit\r\n// Crc32Table[1] = Crc32Polynom\r\n else\r\n Crc := (Crc shr 1) and NotCrc32HighBit;\r\n until (Crc = Crc32HighBit) or (I = (N + Crc32Bytes) * 8);\r\n if Crc <> Crc32HighBit then\r\n Result := -1000 // not correctable\r\n else\r\n // I = No. of single faulty bit\r\n // (high bit first,\r\n // starting from lowest with CRC bits)\r\n Result := I - Crc32Bits;\r\n // Result < 0 faulty CRC-bit\r\n // Result >= 0 No. of faulty data bit\r\nend;\r\n\r\nfunction Crc32_P(const Crc32Table: TCrc32Table; X: PJclByteArray; N: Integer; Crc: Cardinal): Cardinal;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := Crc32DefaultStart;\r\n for I := 0 to N - 1 do // The CRC Bytes are located at the end of the information\r\n // a 32 bit value shr 24 is a Byte, explictit type conversion to Byte adds an ASM instruction\r\n Result := Crc32Table[Result shr (CRC32Bits-8)] xor (Result shl 8) xor X[I];\r\n for I := 0 to Crc32Bytes - 1 do\r\n begin\r\n // a 32 bit value shr 24 is a Byte, explictit type conversion to Byte adds an ASM instruction\r\n Result := Crc32Table[Result shr (CRC32Bits-8)] xor (Result shl 8) xor (Crc shr (CRC32Bits-8));\r\n Crc := Crc shl 8;\r\n end;\r\nend;\r\n\r\nfunction Crc32_P(X: PJclByteArray; N: Integer; Crc: Cardinal): Cardinal;\r\nbegin\r\n Result := Crc32_P(Crc32DefaultTable, X, N, Crc);\r\nend;\r\n\r\nfunction CheckCrc32_P(const Crc32Table: TCrc32Table; X: PJclByteArray; N: Integer; Crc: Cardinal): Integer;\r\n// checks and corrects a single bit in up to 2^31-32 Bit -> 2^28-4 = 268435452 Byte\r\nvar\r\n I, J: Integer;\r\n C: Byte;\r\nbegin\r\n Crc := Crc32_P(Crc32Table, X, N, Crc);\r\n if Crc = 0 then\r\n Result := 0 // No CRC-error\r\n else\r\n begin\r\n J := Crc32Corr(Crc32Table, Crc, N);\r\n if J < -(Crc32Bytes * 8 + 1) then\r\n Result := -1 // non-correctable error (more than one wrong bit)\r\n else\r\n begin\r\n if J < 0 then\r\n Result := 1 // one faulty Bit in CRC itself\r\n else\r\n begin // Bit J is faulty\r\n I := J and 7; // I <= 7 (faulty Bit in Byte)\r\n C := 1 shl I; // C <= 128\r\n I := J shr 3; // I: Index of faulty Byte\r\n X[N - 1 - I] := X[N - 1 - I] xor C; // correct faulty bit\r\n Result := 1; // Correctable error\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction CheckCrc32_P(X: PJclByteArray; N: Integer; Crc: Cardinal): Integer;\r\nbegin\r\n Result := CheckCrc32_P(Crc32DefaultTable, X, N, Crc);\r\nend;\r\n\r\nfunction Crc32(const Crc32Table: TCrc32Table; const X: array of Byte; N: Integer; Crc: Cardinal): Cardinal;\r\nbegin\r\n Result := Crc32_P(Crc32Table, @X, N, Crc);\r\nend;\r\n\r\nfunction Crc32(const X: array of Byte; N: Integer; Crc: Cardinal): Cardinal;\r\nbegin\r\n Result := Crc32_P(Crc32DefaultTable, @X, N, Crc);\r\nend;\r\n\r\nfunction CheckCrc32(const Crc32Table: TCrc32Table; var X: array of Byte; N: Integer; Crc: Cardinal): Integer;\r\nbegin\r\n Result := CheckCRC32_P(Crc32Table, @X, N, CRC);\r\nend;\r\n\r\nfunction CheckCrc32(var X: array of Byte; N: Integer; Crc: Cardinal): Integer;\r\nbegin\r\n Result := CheckCRC32_P(Crc32DefaultTable, @X, N, CRC);\r\nend;\r\n\r\nfunction Crc32_A(const Crc32Table: TCrc32Table; const X: array of Byte; Crc: Cardinal): Cardinal;\r\nbegin\r\n Result := Crc32_P(Crc32Table, @X, Length(X), Crc);\r\nend;\r\n\r\nfunction Crc32_A(const X: array of Byte; Crc: Cardinal): Cardinal;\r\nbegin\r\n Result := Crc32_P(Crc32DefaultTable, @X, Length(X), Crc);\r\nend;\r\n\r\nfunction CheckCrc32_A(const Crc32Table: TCrc32Table; var X: array of Byte; Crc: Cardinal): Integer;\r\nbegin\r\n Result := CheckCrc32_P(Crc32Table, @X, Length(X), Crc);\r\nend;\r\n\r\nfunction CheckCrc32_A(var X: array of Byte; Crc: Cardinal): Integer;\r\nbegin\r\n Result := CheckCrc32_P(Crc32DefaultTable, @X, Length(X), Crc);\r\nend;\r\n\r\n// The CRC Table can be generated like this:\r\n// const Crc32Start0 = 0; !!\r\n\r\nfunction Crc32_Bitwise(const X: array of Byte; N: Integer; Crc: Cardinal; Polynom: Cardinal) : Cardinal;\r\nconst\r\n Crc32Start0 = 0; //Generating the table\r\nvar\r\n I, J: Integer;\r\n Sr, SrHighBit: Cardinal;\r\n B: Byte;\r\nbegin\r\n Sr := Crc32Start0;\r\n SrHighBit := 0;\r\n for I := 0 to N - 1 + Crc32Bytes do\r\n begin\r\n if I >= N then\r\n begin\r\n B := Crc shr (Crc32Bits - 8);\r\n Crc := Crc shl 8;\r\n end\r\n else\r\n B := X[I];\r\n for J := 1 to 8 do\r\n begin\r\n if SrHighBit <> 0 then\r\n Sr := Sr xor Polynom;\r\n SrHighBit := Sr and Crc32HighBit;\r\n Sr := (Sr shl 1) or ((B shr 7) and 1);\r\n B := Byte(B shl 1);\r\n end\r\n end;\r\n\r\n if SrHighBit <> 0 then\r\n Sr := Sr xor Polynom;\r\n Result := Sr;\r\nend;\r\n\r\nprocedure InitCrc32(Polynom, Start: Cardinal; out Crc32Table: TCrc32Table);\r\nvar\r\n X: array [0..0] of Byte;\r\n I: Integer;\r\nbegin\r\n for I := 0 to 255 do\r\n begin\r\n X[0] := I;\r\n Crc32Table[I] := Crc32_Bitwise(X, 1, 0, Polynom);\r\n end;\r\n Crc32DefaultStart := Start;\r\nend;\r\n\r\nprocedure InitCrc32(Polynom, Start: Cardinal);\r\nbegin\r\n InitCrc32(Polynom, Start, Crc32DefaultTable);\r\nend;\r\n\r\n//=== complex numbers support ================================================\r\n\r\nconst\r\n RectOne: TRectComplex = (Re: 1.0; Im: 0.0);\r\n RectZero: TRectComplex = (Re: 0.0; Im: 0.0);\r\n\r\nvar\r\n RectComplexFormatStr: string = '%g + %gi';\r\n PolarComplexFormatStr: string = '%g e^%gi';\r\n\r\nprocedure SetRectComplexFormatStr(const S: string);\r\nbegin\r\n RectComplexFormatStr := S;\r\nend;\r\n\r\nprocedure SetPolarComplexFormatStr(const S: string);\r\nbegin\r\n PolarComplexFormatStr := S;\r\nend;\r\n\r\nfunction ComplexToStr(const Z: TRectComplex): string;\r\nbegin\r\n Result := Format(RectComplexFormatStr, [Z.Re, Z.Im]);\r\nend;\r\n\r\nfunction ComplexToStr(const Z: TPolarComplex): string;\r\nbegin\r\n Result := Format(PolarComplexFormatStr, [Z.Radius, Z.Angle]);\r\nend;\r\n\r\nfunction RectComplex(const Re: Float; const Im: Float = 0): TRectComplex;\r\nbegin\r\n Result.Re := Re;\r\n Result.Im := Im;\r\nend;\r\n\r\nfunction RectComplex(const Z: TPolarComplex): TRectComplex;\r\nvar\r\n ASin, ACos: Float;\r\nbegin\r\n {$IFDEF DEBUG}\r\n Inc(ComplexTypeConversions);\r\n {$ENDIF DEBUG}\r\n JclMath.SinCos(Z.Angle, ASin, ACos);\r\n Result.Re := Z.Radius * ACos;\r\n Result.Im := Z.Radius * ASin;\r\nend;\r\n\r\nfunction PolarComplex(const Radius: Float; const Angle: Float = 0): TPolarComplex;\r\nbegin\r\n if Radius < 0 then\r\n begin\r\n Result.Radius := -Radius;\r\n Result.Angle := Pi;\r\n end\r\n else\r\n begin\r\n Result.Radius := Radius;\r\n Result.Angle := 0.0;\r\n end;\r\nend;\r\n\r\nfunction PolarComplex(const Z: TRectComplex): TPolarComplex;\r\nbegin\r\n {$IFDEF DEBUG}\r\n Inc(ComplexTypeConversions);\r\n {$ENDIF DEBUG}\r\n Result.Radius := Norm(Z);\r\n Result.Angle := ArcTan2(Z.Im, Z.Re);\r\nend;\r\n\r\nfunction Equal(const Z1, Z2: TRectComplex): Boolean;\r\nbegin\r\n Result := (Z1.Re = Z2.Re) and (Z1.Im = Z2.Im);\r\nend;\r\n\r\nfunction Equal(const Z1, Z2: TPolarComplex): Boolean;\r\nbegin\r\n Result := (Z1.Radius = Z2.Radius)\r\n and ((Z1.Radius = 0) or IsFloatZero(NormalizeAngle(Z1.Angle - Z2.Angle)));\r\nend;\r\n\r\nfunction IsZero(const Z: TRectComplex): Boolean;\r\nbegin\r\n Result := IsFloatZero(Z.Re) and IsFloatZero(Z.Im);\r\nend;\r\n\r\nfunction IsZero(const Z: TPolarComplex): Boolean;\r\nbegin\r\n Result := IsFloatZero(Z.Radius);\r\nend;\r\n\r\n{$IFDEF CPU32}\r\n\r\nfunction IsInfinite(const Z: TRectComplex): Boolean;\r\nbegin\r\n Result := IsInfinite(Z.Re) or IsInfinite(Z.Im);\r\nend;\r\n\r\nfunction IsInfinite(const Z: TPolarComplex): Boolean;\r\nbegin\r\n Result := IsInfinite(Z.Radius);\r\nend;\r\n\r\n{$ENDIF CPU32}\r\n\r\nfunction Norm(const Z: TRectComplex): Float;\r\nbegin\r\n Result := Sqrt(Sqr(Z.Re) + Sqr(Z.Im));\r\nend;\r\n\r\nfunction Norm(const Z: TPolarComplex): Float;\r\nbegin\r\n Result := Z.Radius;\r\nend;\r\n\r\nfunction AbsSqr(const Z: TRectComplex): Float;\r\nbegin\r\n Result := Sqr(Z.Re) + Sqr(Z.Im);\r\nend;\r\n\r\nfunction AbsSqr(const Z: TPolarComplex): Float;\r\nbegin\r\n Result := Sqr(Z.Radius);\r\nend;\r\n\r\nfunction Conjugate(const Z: TRectComplex): TRectComplex;\r\nbegin\r\n Result.Re := Z.Re;\r\n Result.Im := -Z.Im;\r\nend;\r\n\r\nfunction Conjugate(const Z: TPolarComplex): TPolarComplex;\r\nbegin\r\n Result.Radius := Z.Radius;\r\n Result.Angle := -Z.Angle;\r\nend;\r\n\r\nfunction Inv(const Z: TRectComplex): TRectComplex;\r\nvar\r\n Denom: Float;\r\nbegin\r\n Denom := Sqr(Z.Re) + Sqr(Z.Im);\r\n Result.Re := Z.Re / Denom;\r\n Result.Im := -Z.Im / Denom;\r\nend;\r\n\r\nfunction Inv(const Z: TPolarComplex): TPolarComplex;\r\nbegin\r\n Result.Radius := 1 / Z.Radius;\r\n Result.Angle := - Z.Angle;\r\nend;\r\n\r\nfunction Neg(const Z: TRectComplex): TRectComplex;\r\nbegin\r\n Result.Re := -Z.Re;\r\n Result.Im := -Z.Im;\r\nend;\r\n\r\nfunction Neg(const Z: TPolarComplex): TPolarComplex;\r\nbegin\r\n Result.Radius := Z.Radius;\r\n Result.Angle := NormalizeAngle(Z.Angle + Pi);\r\nend;\r\n\r\nfunction Sum(const Z1, Z2: TRectComplex): TRectComplex;\r\nbegin\r\n Result.Re := Z1.Re + Z2.Re;\r\n Result.Im := Z1.Im + Z2.Im;\r\nend;\r\n\r\nfunction Sum(const Z: array of TRectComplex): TRectComplex;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := RectZero;\r\n for I := Low(Z) to High(Z) do\r\n begin\r\n Result.Re := Result.Re + Z[I].Re;\r\n Result.Im := Result.Im + Z[I].Im;\r\n end;\r\nend;\r\n\r\nfunction Diff(const Z1, Z2: TRectComplex): TRectComplex;\r\nbegin\r\n Result.Re := Z1.Re - Z2.Re;\r\n Result.Im := Z1.Im - Z2.Im;\r\nend;\r\n\r\nfunction Product(const Z1, Z2: TRectComplex): TRectComplex;\r\nbegin\r\n Result.Re := Z1.Re * Z2.Re - Z1.Im * Z2.Im;\r\n Result.Im := Z1.Re * Z2.Im + Z1.Im * Z2.Re;\r\nend;\r\n\r\nfunction Product(const Z1, Z2: TPolarComplex): TPolarComplex;\r\nbegin\r\n Result.Radius := Z1.Radius * Z2.Radius;\r\n Result.Angle := NormalizeAngle(Z1.Angle + Z2.Angle);\r\nend;\r\n\r\nfunction Product(const Z: array of TPolarComplex): TPolarComplex;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result.Radius := 1.0;\r\n Result.Angle := 0;\r\n for I := Low(Z) to High(Z) do\r\n begin\r\n Result.Radius := Result.Radius * Z[I].Radius;\r\n Result.Angle := Result.Angle + Z[I].Angle;\r\n end;\r\n Result.Angle := NormalizeAngle(Result.Angle);\r\nend;\r\n\r\n\r\nfunction Quotient(const Z1, Z2: TRectComplex): TRectComplex;\r\nvar\r\n Denom: Float;\r\nbegin\r\n Denom := Sqr(Z2.Re) + Sqr(Z2.Im);\r\n Result.Re := (Z1.Re * Z2.Re + Z1.Im * Z2.Im) / Denom;\r\n Result.Im := (Z1.Im * Z2.Re - Z1.Re * Z2.Im) / Denom;\r\nend;\r\n\r\nfunction Quotient(const Z1, Z2: TPolarComplex): TPolarComplex;\r\nbegin\r\n Result.Radius := Z1.Radius / Z2.Radius;\r\n Result.Angle := NormalizeAngle(Z1.Angle - Z2.Angle);\r\nend;\r\n\r\nfunction Ln(const Z: TPolarComplex): TRectComplex;\r\nbegin\r\n Result.Re := System.Ln(Z.Radius);\r\n Result.Im := NormalizeAngle(Z.Angle);\r\nend;\r\n\r\nfunction Exp(const Z: TRectComplex): TPolarComplex;\r\nbegin\r\n Result.Radius := System.Exp(Z.Re);\r\n Result.Angle := Z.Im;\r\nend;\r\n\r\nfunction Power(const Z: TPolarComplex; const Exponent: Float): TPolarComplex;\r\nbegin\r\n Result.Radius := JclMath.Power(Z.Radius, Exponent);\r\n Result.Angle := NormalizeAngle(Exponent * Z.Angle);\r\nend;\r\n\r\nfunction Power(const Z: TPolarComplex; const Exponent: TRectComplex): TPolarComplex;\r\nbegin\r\n Result := Exp(Product(Exponent, Ln(Z)));\r\nend;\r\n\r\nfunction PowerInt(const Z: TPolarComplex; const Exponent: Integer): TPolarComplex;\r\nbegin\r\n Result.Radius := PowerInt(Z.Radius, Exponent);\r\n Result.Angle := NormalizeAngle(Exponent * Z.Angle);\r\nend;\r\n\r\nfunction Root(const Z: TPolarComplex; const K, N: Cardinal): TPolarComplex;\r\nbegin\r\n Result.Radius := JclMath.Power(Z.Radius, 1.0 / N);\r\n Result.Angle := NormalizeAngle((Z.Angle + K * TwoPi) / N);\r\nend;\r\n\r\n//=== complex trigonometric functions ========================================\r\n\r\nfunction Cos(const Z: TRectComplex): TRectComplex;\r\nvar\r\n ACos, ASin: Float;\r\nbegin\r\n JclMath.SinCos(Z.Re, ASin, ACos);\r\n Result.Re := ACos * JclMath.CosH(Z.Im);\r\n Result.Im := -ASin * JclMath.SinH(Z.Im);\r\nend;\r\n\r\nfunction Sin(const Z: TRectComplex): TRectComplex;\r\nvar\r\n ACos, ASin: Float;\r\nbegin\r\n JclMath.SinCos(Z.Re, ASin, ACos);\r\n Result.Re := ASin * JclMath.CosH(Z.Im);\r\n Result.Im := ACos * JclMath.SinH(Z.Im);\r\nend;\r\n\r\nfunction Tan(const Z: TRectComplex): TRectComplex;\r\nvar\r\n Denom: Float;\r\n ACos, ASin: Float;\r\nbegin\r\n JclMath.SinCos(2.0 * Z.Re, ASin, ACos);\r\n Denom := ACos + JclMath.CosH(2.0 * Z.Im);\r\n Result.Re := ASin / Denom;\r\n Result.Im := JclMath.SinH(2.0 * Z.Im) / Denom;\r\nend;\r\n\r\nfunction Cot(const Z: TRectComplex): TRectComplex;\r\nvar\r\n Denom: Float;\r\n ACos, ASin: Float;\r\nbegin\r\n JclMath.SinCos(2.0 * Z.Re, ASin, ACos);\r\n Denom := JclMath.CosH(2.0 * Z.Im) - ACos;\r\n Result.Re := ASin / Denom;\r\n Result.Im := -JclMath.SinH(2.0 * Z.Im) / Denom;\r\nend;\r\n\r\nfunction Sec(const Z: TRectComplex): TRectComplex;\r\nbegin\r\n Result := Quotient(RectOne, Cos(Z));\r\nend;\r\n\r\nfunction Csc(const Z: TRectComplex): TRectComplex;\r\nbegin\r\n Result := Quotient(RectOne, Sin(Z));\r\nend;\r\n\r\n//=== complex hyperbolic functions ===========================================\r\n\r\nfunction CosH(const Z: TRectComplex): TRectComplex;\r\nvar\r\n ACos, ASin: Float;\r\nbegin\r\n JclMath.SinCos(Z.Im, ASin, ACos);\r\n Result.Re := JclMath.CosH(Z.Re) * ACos;\r\n Result.Im := JclMath.SinH(Z.Re) * ASin;\r\nend;\r\n\r\nfunction SinH(const Z: TRectComplex): TRectComplex;\r\nvar\r\n ACos, ASin: Float;\r\nbegin\r\n JclMath.SinCos(Z.Im, ASin, ACos);\r\n Result.Re := JclMath.SinH(Z.Re) * ACos;\r\n Result.Im := JclMath.CosH(Z.Re) * ASin;\r\nend;\r\n\r\nfunction TanH(const Z: TRectComplex): TRectComplex;\r\nvar\r\n Denom: Float;\r\n ACos, ASin: Float;\r\nbegin\r\n JclMath.SinCos(2.0 * Z.Im, ASin, ACos);\r\n Denom := JclMath.CosH(2.0 * Z.Re) + ACos;\r\n Result.Re := JclMath.SinH(2.0 * Z.Re) / Denom;\r\n Result.Im := ASin / Denom;\r\nend;\r\n\r\nfunction CotH(const Z: TRectComplex): TRectComplex;\r\nvar\r\n Denom: Float;\r\n ACos, ASin: Float;\r\nbegin\r\n JclMath.SinCos(2.0 * Z.Im, ASin, ACos);\r\n Denom := JclMath.CosH(2.0 * Z.Re) - ACos;\r\n Result.Re := JclMath.SinH(2.0 * Z.Re) / Denom;\r\n Result.Im := -ASin / Denom;\r\nend;\r\n\r\nfunction SecH(const Z: TRectComplex): TRectComplex;\r\nbegin\r\n Result := Quotient(RectOne, CosH(Z));\r\nend;\r\n\r\nfunction CscH(const Z: TRectComplex): TRectComplex;\r\nbegin\r\n Result := Quotient(RectOne, SinH(Z));\r\nend;\r\n\r\n{$IFDEF SUPPORTS_CLASS_OPERATORS}\r\n\r\n{ TRectComplex }\r\n\r\nclass operator TRectComplex.Implicit(const Value: Float): TRectComplex;\r\nbegin\r\n Result := RectComplex(Value);\r\nend;\r\n\r\nclass operator TRectComplex.Equal(const Z1, Z2: TRectComplex): Boolean;\r\nbegin\r\n Result := Equal(Z1, Z2);\r\nend;\r\n\r\nclass operator TRectComplex.NotEqual(const Z1, Z2: TRectComplex): Boolean;\r\nbegin\r\n Result := not Equal(Z1, Z2);\r\nend;\r\n\r\nclass operator TRectComplex.Add(const Z1, Z2: TRectComplex): TRectComplex;\r\nbegin\r\n Result := Sum(Z1, Z2);\r\nend;\r\n\r\nclass operator TRectComplex.Subtract(const Z1, Z2: TRectComplex): TRectComplex;\r\nbegin\r\n Result := Diff(Z1, Z2);\r\nend;\r\n\r\nclass operator TRectComplex.Multiply(const Z1, Z2: TRectComplex): TRectComplex;\r\nbegin\r\n Result := Product(Z1, Z2);\r\nend;\r\n\r\nclass operator TRectComplex.Divide(const Z1, Z2: TRectComplex): TRectComplex;\r\nbegin\r\n Result := Quotient(Z1, Z2);\r\nend;\r\n\r\nclass operator TRectComplex.Negative(const Z: TRectComplex): TRectComplex;\r\nbegin\r\n Result := Neg(Z);\r\nend;\r\n\r\nclass operator TRectComplex.Positive(const Z: TRectComplex): TRectComplex;\r\nbegin\r\n Result := Z;\r\nend;\r\n\r\nfunction TRectComplex.AsString: string;\r\nbegin\r\n Result := ComplexToStr(Self);\r\nend;\r\n\r\nfunction TRectComplex.Conjugate: TRectComplex;\r\nbegin\r\n Result := JclMath.Conjugate(Self);\r\nend;\r\n\r\nfunction TRectComplex.IsZero: Boolean;\r\nbegin\r\n Result := JclMath.IsZero(Self);\r\nend;\r\n\r\nfunction TRectComplex.IsInfinite: Boolean;\r\nbegin\r\n {$IFDEF DELPHI64_TEMPORARY}\r\n //IsInfinite is disabled for 64-bit, because BASM is not 64-bit compatible (see logmessage of public repo @3070)\r\n System.Error(rePlatformNotImplemented);\r\n Result := False;\r\n {$ELSE ~DELPHI64_TEMPORARY}\r\n Result := JclMath.IsInfinite(Self);\r\n {$ENDIF ~DELPHI64_TEMPORARY}\r\nend;\r\n\r\n{ TPolarComplex }\r\n\r\nclass operator TPolarComplex.Implicit(const Value: Float): TPolarComplex;\r\nbegin\r\n Result := PolarComplex(Value);\r\nend;\r\n\r\nclass operator TPolarComplex.Implicit(const Z: TPolarComplex): TRectComplex;\r\nbegin\r\n Result := RectComplex(Z);\r\nend;\r\n\r\nclass operator TPolarComplex.Implicit(const Z: TRectComplex): TPolarComplex;\r\nbegin\r\n Result := PolarComplex(Z);\r\nend;\r\n\r\n{$IFNDEF CPPBUILDER}\r\nclass operator TPolarComplex.Explicit(const Z: TPolarComplex): TRectComplex;\r\nbegin\r\n Result := RectComplex(Z);\r\nend;\r\n\r\nclass operator TPolarComplex.Explicit(const Z: TRectComplex): TPolarComplex;\r\nbegin\r\n Result := PolarComplex(Z);\r\nend;\r\n{$ENDIF CPPBUILDER}\r\n\r\nclass operator TPolarComplex.Equal(const Z1, Z2: TPolarComplex): Boolean;\r\nbegin\r\n Result := Equal(Z1, Z2);\r\nend;\r\n\r\nclass operator TPolarComplex.NotEqual(const Z1, Z2: TPolarComplex): Boolean;\r\nbegin\r\n Result := not Equal(Z1, Z2);\r\nend;\r\n\r\nclass operator TPolarComplex.Add(const Z1, Z2: TPolarComplex): TRectComplex;\r\nbegin\r\n Result := Sum(Z1, Z2);\r\nend;\r\n\r\nclass operator TPolarComplex.Subtract(const Z1, Z2: TPolarComplex): TRectComplex;\r\nbegin\r\n Result := Diff(Z1, Z2);\r\nend;\r\n\r\nclass operator TPolarComplex.Multiply(const Z1, Z2: TPolarComplex): TPolarComplex;\r\nbegin\r\n Result := Product(Z1, Z2);\r\nend;\r\n\r\nclass operator TPolarComplex.Divide(const Z1, Z2: TPolarComplex): TPolarComplex;\r\nbegin\r\n Result := Quotient(Z1, Z2);\r\nend;\r\n\r\nclass operator TPolarComplex.Negative(const Z: TPolarComplex): TPolarComplex;\r\nbegin\r\n Result := Neg(Z);\r\nend;\r\n\r\nclass operator TPolarComplex.Positive(const Z: TPolarComplex): TPolarComplex;\r\nbegin\r\n Result := Z;\r\nend;\r\n\r\nfunction TPolarComplex.AsString: string;\r\nbegin\r\n Result := ComplexToStr(Self);\r\nend;\r\n\r\nfunction TPolarComplex.Conjugate: TPolarComplex;\r\nbegin\r\n Result := JclMath.Conjugate(Self);\r\nend;\r\n\r\nfunction TPolarComplex.IsZero: Boolean;\r\nbegin\r\n Result := JclMath.IsZero(Self);\r\nend;\r\n\r\nfunction TPolarComplex.IsInfinite: Boolean;\r\nbegin\r\n {$IFDEF DELPHI64_TEMPORARY}\r\n //IsInfinite is disabled for 64-bit, because BASM is not 64-bit compatible (see logmessage of public repo @3070)\r\n System.Error(rePlatformNotImplemented);\r\n Result := False;\r\n {$ELSE ~DELPHI64_TEMPORARY}\r\n Result := JclMath.IsInfinite(Self);\r\n {$ENDIF ~DELPHI64_TEMPORARY}\r\nend;\r\n\r\nfunction TPolarComplex.Power(const Exponent: TRectComplex): TPolarComplex;\r\nbegin\r\n Result := JclMath.Power(Self, Exponent);\r\nend;\r\n\r\nfunction TPolarComplex.Power(const Exponent: Float): TPolarComplex;\r\nbegin\r\n Result := JclMath.Power(Self, Exponent);\r\nend;\r\n\r\nfunction TPolarComplex.Power(const Exponent: Integer): TPolarComplex;\r\nbegin\r\n Result := JclMath.PowerInt(Self, Exponent);\r\nend;\r\n\r\nfunction TPolarComplex.Root(const K, N: Cardinal): TPolarComplex;\r\nbegin\r\n Result := JclMath.Root(Self, K, N);\r\nend;\r\n\r\n{$ENDIF SUPPORTS_CLASS_OPERATORS}\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jcl/source/common/JclMime.pas", "content": "{**************************************************************************************************}\r\n{ }\r\n{ Project JEDI Code Library (JCL) }\r\n{ }\r\n{ The contents of this file are subject to the Mozilla Public License Version 1.1 (the \"License\"); }\r\n{ you may not use this file except in compliance with the License. You may obtain a copy of the }\r\n{ License at http://www.mozilla.org/MPL/ }\r\n{ }\r\n{ Software distributed under the License is distributed on an \"AS IS\" basis, WITHOUT WARRANTY OF }\r\n{ ANY KIND, either express or implied. See the License for the specific language governing rights }\r\n{ and limitations under the License. }\r\n{ }\r\n{ The Original Code is JclMime.pas. }\r\n{ }\r\n{ The Initial Developer of the Original Code is Ralf Junker. }\r\n{ Portions created by Ralf Junker are Copyright (C) Ralf Junker. All rights reserved. }\r\n{ }\r\n{ Contributors: }\r\n{ Marcel van Brakel }\r\n{ Ralf Junker }\r\n{ Robert Marquardt (marquardt) }\r\n{ Robert Rossmair (rrossmair) }\r\n{ Matthias Thoma (mthoma) }\r\n{ Petr Vones (pvones) }\r\n{ edbored }\r\n{ }\r\n{**************************************************************************************************}\r\n{ }\r\n{ Lightning fast Mime (Base64) Encoding and Decoding routines. Coded by Ralf Junker }\r\n{ (ralfjunker att gmx dott de). }\r\n{ }\r\n{**************************************************************************************************}\r\n{ Migration Guide from JCL 1.90 and older: }\r\n{ }\r\n{ These new functions now support line breaks (CRLF) as required by RFC 2045. }\r\n{ Inserting line breaks is the default behaviour in RFC 2045 therefor the encoding functions now }\r\n{ encode with line breaks. }\r\n{ }\r\n{ This may require changes to your code: }\r\n{ Encoding without inserting line breaks is possible using the corresponding NoCRLF procedures: }\r\n{ }\r\n{ MimeEncode => MimeEncodeNoCRLF }\r\n{ MimeEncodeString => MimeEncodeStringNoCRLF }\r\n{ MimeEncodeStream => MimeEncodeStreamNoCRLF }\r\n{ MimeEncodedSize => MimeEncodedSizeNoCRLF }\r\n{ }\r\n{**************************************************************************************************}\r\n{ }\r\n{ Last modified: $Date:: 2011-09-03 00:07:50 +0200 (sam. 03 sept. 2011) $ }\r\n{ Revision: $Rev:: 3599 $ }\r\n{ Author: $Author:: outchy $ }\r\n{ }\r\n{**************************************************************************************************}\r\n\r\nunit JclMime;\r\n\r\n{$I jcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n {$IFDEF HAS_UNITSCOPE}\r\n System.SysUtils, System.Classes,\r\n {$ELSE ~HAS_UNITSCOPE}\r\n SysUtils, Classes,\r\n {$ENDIF ~HAS_UNITSCOPE}\r\n JclBase;\r\n\r\nfunction MimeEncodeString(const S: AnsiString): AnsiString;\r\nfunction MimeEncodeStringNoCRLF(const S: AnsiString): AnsiString;\r\nfunction MimeDecodeString(const S: AnsiString): AnsiString;\r\nfunction MimeEncodedSize(const InputSize: SizeInt): SizeInt;\r\nfunction MimeEncodedSizeNoCRLF(const InputSize: SizeInt): SizeInt;\r\nfunction MimeDecodedSize(const InputSize: SizeInt): SizeInt;\r\nprocedure DecodeHttpBasicAuthentication(const BasicCredentials: AnsiString;\r\n out UserId, PassWord: AnsiString);\r\n\r\nprocedure MimeEncode(const InputBuffer: TDynByteArray; InputOffset: SizeInt;\r\n const InputByteCount: SizeInt; out OutputBuffer: TDynByteArray; OutputOffset: SizeInt = 0); overload;\r\nprocedure MimeEncodeNoCRLF(const InputBuffer: TDynByteArray; InputOffset: SizeInt;\r\n const InputByteCount: SizeInt; out OutputBuffer: TDynByteArray; OutputOffset: SizeInt = 0); overload;\r\nprocedure MimeEncodeFullLines(const InputBuffer: TDynByteArray; InputOffset: SizeInt;\r\n const InputByteCount: SizeInt; out OutputBuffer: TDynByteArray; OutputOffset: SizeInt = 0); overload;\r\nfunction MimeDecode(const InputBuffer: TDynByteArray; InputOffset: SizeInt;\r\n const InputByteCount: SizeInt; out OutputBuffer: TDynByteArray; OutputOffset: SizeInt = 0): SizeInt; overload;\r\nfunction MimeDecodePartial(const InputBuffer: TDynByteArray; InputOffset: SizeInt;\r\n const InputByteCount: SizeInt; out OutputBuffer: TDynByteArray; OutputOffset: SizeInt;\r\n var ByteBuffer: Cardinal; var ByteBufferSpace: Cardinal): SizeInt; overload;\r\nfunction MimeDecodePartialEnd(out OutputBuffer: TDynByteArray; OutputOffset: SizeInt;\r\n const ByteBuffer: Cardinal; const ByteBufferSpace: Cardinal): SizeInt; overload;\r\n\r\nprocedure MimeEncode(const InputBuffer: TDynByteArray; const InputByteCount: SizeInt;\r\n out OutputBuffer: TDynByteArray); overload;\r\nprocedure MimeEncodeNoCRLF(const InputBuffer: TDynByteArray; const InputByteCount: SizeInt;\r\n out OutputBuffer: TDynByteArray); overload;\r\nprocedure MimeEncodeFullLines(const InputBuffer: TDynByteArray; const InputByteCount: SizeInt;\r\n out OutputBuffer: TDynByteArray); overload;\r\nfunction MimeDecode(const InputBuffer: TDynByteArray; const InputByteCount: SizeInt;\r\n out OutputBuffer: TDynByteArray): SizeInt; overload;\r\nfunction MimeDecodePartial(const InputBuffer: TDynByteArray; const InputByteCount: SizeInt;\r\n out OutputBuffer: TDynByteArray; var ByteBuffer: Cardinal; var ByteBufferSpace: Cardinal): SizeInt; overload;\r\nfunction MimeDecodePartialEnd(out OutputBuffer: TDynByteArray; const ByteBuffer: Cardinal;\r\n const ByteBufferSpace: Cardinal): SizeInt; overload;\r\n\r\nprocedure MimeEncode(const InputBuffer; const InputByteCount: SizeInt; out OutputBuffer); overload;\r\nprocedure MimeEncodeNoCRLF(const InputBuffer; const InputByteCount: SizeInt; out OutputBuffer); overload;\r\nprocedure MimeEncodeFullLines(const InputBuffer; const InputByteCount: SizeInt; out OutputBuffer); overload;\r\nfunction MimeDecode(const InputBuffer; const InputByteCount: SizeInt; out OutputBuffer): SizeInt; overload;\r\nfunction MimeDecodePartial(const InputBuffer; const InputByteCount: SizeInt; out OutputBuffer;\r\n var ByteBuffer: Cardinal; var ByteBufferSpace: Cardinal): SizeInt; overload;\r\nfunction MimeDecodePartialEnd(out OutputBuffer; const ByteBuffer: Cardinal;\r\n const ByteBufferSpace: Cardinal): SizeInt; overload;\r\n\r\nprocedure MimeEncodeFile(const InputFileName, OutputFileName: TFileName);\r\nprocedure MimeEncodeFileNoCRLF(const InputFileName, OutputFileName: TFileName);\r\nprocedure MimeDecodeFile(const InputFileName, OutputFileName: TFileName);\r\nprocedure MimeEncodeStream(const InputStream: TStream; const OutputStream: TStream);\r\nprocedure MimeEncodeStreamNoCRLF(const InputStream: TStream; const OutputStream: TStream);\r\nprocedure MimeDecodeStream(const InputStream: TStream; const OutputStream: TStream);\r\n\r\nconst\r\n MIME_ENCODED_LINE_BREAK = 76;\r\n MIME_DECODED_LINE_BREAK = MIME_ENCODED_LINE_BREAK div 4 * 3;\r\n MIME_BUFFER_SIZE = MIME_DECODED_LINE_BREAK * 3 * 4 * 4;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jcl.svn.sourceforge.net/svnroot/jcl/tags/JCL-2.4-Build4571/jcl/source/common/JclMime.pas $';\r\n Revision: '$Revision: 3599 $';\r\n Date: '$Date: 2011-09-03 00:07:50 +0200 (sam. 03 sept. 2011) $';\r\n LogPath: 'JCL\\source\\common';\r\n Extra: '';\r\n Data: nil\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\n// Caution: For MimeEncodeStream and all other kinds of multi-buffered\r\n// Mime encodings (i.e. Files etc.), BufferSize must be set to a multiple of 3.\r\n// Even though the implementation of the Mime decoding routines below\r\n// do not require a particular buffer size, they work fastest with sizes of\r\n// multiples of four. The chosen size is a multiple of 3 and of 4 as well.\r\n// The following numbers are, in addition, also divisible by 1024:\r\n// $2400, $3000, $3C00, $4800, $5400, $6000, $6C00.\r\n\r\nconst\r\n { The mime encoding table. Do not alter. }\r\n MIME_ENCODE_TABLE: array [0..63] of Byte = (\r\n 065, 066, 067, 068, 069, 070, 071, 072, // 00 - 07\r\n 073, 074, 075, 076, 077, 078, 079, 080, // 08 - 15\r\n 081, 082, 083, 084, 085, 086, 087, 088, // 16 - 23\r\n 089, 090, 097, 098, 099, 100, 101, 102, // 24 - 31\r\n 103, 104, 105, 106, 107, 108, 109, 110, // 32 - 39\r\n 111, 112, 113, 114, 115, 116, 117, 118, // 40 - 47\r\n 119, 120, 121, 122, 048, 049, 050, 051, // 48 - 55\r\n 052, 053, 054, 055, 056, 057, 043, 047); // 56 - 63\r\n\r\n MIME_PAD_CHAR = Byte('=');\r\n\r\n MIME_DECODE_TABLE: array [Byte] of Byte = (\r\n 255, 255, 255, 255, 255, 255, 255, 255, // 0 - 7\r\n 255, 255, 255, 255, 255, 255, 255, 255, // 8 - 15\r\n 255, 255, 255, 255, 255, 255, 255, 255, // 16 - 23\r\n 255, 255, 255, 255, 255, 255, 255, 255, // 24 - 31\r\n 255, 255, 255, 255, 255, 255, 255, 255, // 32 - 39\r\n 255, 255, 255, 062, 255, 255, 255, 063, // 40 - 47\r\n 052, 053, 054, 055, 056, 057, 058, 059, // 48 - 55\r\n 060, 061, 255, 255, 255, 255, 255, 255, // 56 - 63\r\n 255, 000, 001, 002, 003, 004, 005, 006, // 64 - 71\r\n 007, 008, 009, 010, 011, 012, 013, 014, // 72 - 79\r\n 015, 016, 017, 018, 019, 020, 021, 022, // 80 - 87\r\n 023, 024, 025, 255, 255, 255, 255, 255, // 88 - 95\r\n 255, 026, 027, 028, 029, 030, 031, 032, // 96 - 103\r\n 033, 034, 035, 036, 037, 038, 039, 040, // 104 - 111\r\n 041, 042, 043, 044, 045, 046, 047, 048, // 112 - 119\r\n 049, 050, 051, 255, 255, 255, 255, 255, // 120 - 127\r\n 255, 255, 255, 255, 255, 255, 255, 255,\r\n 255, 255, 255, 255, 255, 255, 255, 255,\r\n 255, 255, 255, 255, 255, 255, 255, 255,\r\n 255, 255, 255, 255, 255, 255, 255, 255,\r\n 255, 255, 255, 255, 255, 255, 255, 255,\r\n 255, 255, 255, 255, 255, 255, 255, 255,\r\n 255, 255, 255, 255, 255, 255, 255, 255,\r\n 255, 255, 255, 255, 255, 255, 255, 255,\r\n 255, 255, 255, 255, 255, 255, 255, 255,\r\n 255, 255, 255, 255, 255, 255, 255, 255,\r\n 255, 255, 255, 255, 255, 255, 255, 255,\r\n 255, 255, 255, 255, 255, 255, 255, 255,\r\n 255, 255, 255, 255, 255, 255, 255, 255,\r\n 255, 255, 255, 255, 255, 255, 255, 255,\r\n 255, 255, 255, 255, 255, 255, 255, 255,\r\n 255, 255, 255, 255, 255, 255, 255, 255);\r\n\r\nprocedure MimeEncode(const InputBuffer: TDynByteArray; const InputByteCount: SizeInt;\r\n out OutputBuffer: TDynByteArray);\r\nbegin\r\n MimeEncode(InputBuffer, 0, InputByteCount, OutputBuffer, 0);\r\nend;\r\n\r\nprocedure MimeEncodeNoCRLF(const InputBuffer: TDynByteArray; const InputByteCount: SizeInt;\r\n out OutputBuffer: TDynByteArray);\r\nbegin\r\n MimeEncodeNoCRLF(InputBuffer, 0, InputByteCount, OutputBuffer, 0);\r\nend;\r\n\r\nprocedure MimeEncodeFullLines(const InputBuffer: TDynByteArray; const InputByteCount: SizeInt;\r\n out OutputBuffer: TDynByteArray);\r\nbegin\r\n MimeEncodeFullLines(InputBuffer, 0, InputByteCount, OutputBuffer, 0);\r\nend;\r\n\r\nfunction MimeDecode(const InputBuffer: TDynByteArray; const InputByteCount: SizeInt;\r\n out OutputBuffer: TDynByteArray): SizeInt;\r\nbegin\r\n Result := MimeDecode(InputBuffer, 0, InputByteCount, OutputBuffer, 0);\r\nend;\r\n\r\nfunction MimeDecodePartial(const InputBuffer: TDynByteArray; const InputByteCount: SizeInt;\r\n out OutputBuffer: TDynByteArray; var ByteBuffer: Cardinal; var ByteBufferSpace: Cardinal): SizeInt;\r\nbegin\r\n Result := MimeDecodePartial(InputBuffer, 0, InputByteCount, OutputBuffer, 0, ByteBuffer, ByteBufferSpace);\r\nend;\r\n\r\nfunction MimeDecodePartialEnd(out OutputBuffer: TDynByteArray; const ByteBuffer: Cardinal;\r\n const ByteBufferSpace: Cardinal): SizeInt;\r\nbegin\r\n Result := MimeDecodePartialEnd(OutputBuffer, 0, ByteBuffer, ByteBufferSpace);\r\nend;\r\n\r\ntype\r\n PByte4 = ^TByte4;\r\n TByte4 = packed record\r\n B1: Byte;\r\n B2: Byte;\r\n B3: Byte;\r\n B4: Byte;\r\n end;\r\n\r\n PByte3 = ^TByte3;\r\n TByte3 = packed record\r\n B1: Byte;\r\n B2: Byte;\r\n B3: Byte;\r\n end;\r\n\r\n// Wrapper functions & procedures\r\nfunction MimeEncodeString(const S: AnsiString): AnsiString;\r\nvar\r\n L: SizeInt;\r\nbegin\r\n if S <> '' then\r\n begin\r\n L := Length(S);\r\n SetLength(Result, MimeEncodedSize(L));\r\n MimeEncode(PAnsiChar(S)^, L, PAnsiChar(Result)^);\r\n end\r\n else\r\n Result := '';\r\nend;\r\n\r\nfunction MimeEncodeStringNoCRLF(const S: AnsiString): AnsiString;\r\nvar\r\n L: SizeInt;\r\nbegin\r\n if S <> '' then\r\n begin\r\n L := Length(S);\r\n SetLength(Result, MimeEncodedSizeNoCRLF(L));\r\n MimeEncodeNoCRLF(PAnsiChar(S)^, L, PAnsiChar(Result)^);\r\n end\r\n else\r\n Result := '';\r\nend;\r\n\r\nfunction MimeDecodeString(const S: AnsiString): AnsiString;\r\nvar\r\n ByteBuffer, ByteBufferSpace: Cardinal;\r\n L: SizeInt;\r\n P, R: PAnsiChar;\r\nbegin\r\n if S <> '' then\r\n begin\r\n L := Length(S);\r\n SetLength(Result, MimeDecodedSize(L));\r\n ByteBuffer := 0;\r\n ByteBufferSpace := 4;\r\n P := PAnsiChar(S);\r\n R := PAnsiChar(Result);\r\n L := MimeDecodePartial(P^, L, R^, ByteBuffer, ByteBufferSpace);\r\n Inc(R, L);\r\n Inc(L, MimeDecodePartialEnd(R^, ByteBuffer, ByteBufferSpace));\r\n SetLength(Result, L);\r\n end\r\n else\r\n Result := '';\r\nend;\r\n\r\nprocedure DecodeHttpBasicAuthentication(const BasicCredentials: AnsiString; out UserId, PassWord: AnsiString);\r\nconst\r\n LBasic = 6; { Length ('Basic ') }\r\nvar\r\n DecodedPtr, P: PAnsiChar;\r\n I, L: SizeInt;\r\nbegin\r\n UserId := '';\r\n PassWord := '';\r\n\r\n P := PAnsiChar(BasicCredentials);\r\n if P = nil then\r\n Exit;\r\n\r\n L := Length(BasicCredentials);\r\n if L <= LBasic then\r\n Exit;\r\n\r\n Dec(L, LBasic);\r\n Inc(P, LBasic);\r\n\r\n GetMem(DecodedPtr, MimeDecodedSize(L));\r\n L := MimeDecode(P^, L, DecodedPtr^);\r\n\r\n { Look for colon (':'). }\r\n I := 0;\r\n P := DecodedPtr;\r\n while (L > 0) and (P[I] <> ':') do\r\n begin\r\n Inc(I);\r\n Dec(L);\r\n end;\r\n\r\n { Store UserId and Password. }\r\n SetString(UserId, DecodedPtr, I);\r\n if L > 1 then\r\n SetString(PassWord, DecodedPtr + I + 1, L - 1)\r\n else\r\n PassWord := '';\r\n\r\n FreeMem(DecodedPtr);\r\nend;\r\n\r\n// Helper functions\r\nfunction MimeEncodedSize(const InputSize: SizeInt): SizeInt;\r\nbegin\r\n if InputSize > 0 then\r\n Result := (InputSize + 2) div 3 * 4 + (InputSize - 1) div MIME_DECODED_LINE_BREAK * 2\r\n else\r\n Result := InputSize;\r\nend;\r\n\r\nfunction MimeEncodedSizeNoCRLF(const InputSize: SizeInt): SizeInt;\r\nbegin\r\n Result := (InputSize + 2) div 3 * 4;\r\nend;\r\n\r\nfunction MimeDecodedSize(const InputSize: SizeInt): SizeInt;\r\nbegin\r\n Result := (InputSize + 3) div 4 * 3;\r\nend;\r\n\r\n\r\n// Primary functions & procedures\r\nprocedure MimeEncode(const InputBuffer: TDynByteArray; InputOffset: SizeInt;\r\n const InputByteCount: SizeInt;\r\n out OutputBuffer: TDynByteArray; OutputOffset: SizeInt);\r\nvar\r\n IDelta, ODelta: SizeInt;\r\nbegin\r\n MimeEncodeFullLines(InputBuffer, InputOffset, InputByteCount, OutputBuffer, OutputOffset);\r\n IDelta := InputByteCount div MIME_DECODED_LINE_BREAK; // Number of lines processed so far.\r\n ODelta := IDelta * (MIME_ENCODED_LINE_BREAK + 2);\r\n IDelta := IDelta * MIME_DECODED_LINE_BREAK;\r\n MimeEncodeNoCRLF(InputBuffer, InputOffset + IDelta, InputByteCount - IDelta, OutputBuffer, OutputOffset + ODelta);\r\nend;\r\n\r\n// Primary functions & procedures\r\nprocedure MimeEncode(const InputBuffer; const InputByteCount: SizeInt; out OutputBuffer);\r\nvar\r\n IDelta, ODelta: SizeInt;\r\n I, O: PByte;\r\nbegin\r\n MimeEncodeFullLines(InputBuffer, InputByteCount, OutputBuffer);\r\n IDelta := InputByteCount div MIME_DECODED_LINE_BREAK; // Number of lines processed so far.\r\n ODelta := IDelta * (MIME_ENCODED_LINE_BREAK + 2);\r\n IDelta := IDelta * MIME_DECODED_LINE_BREAK;\r\n I := @InputBuffer;\r\n Inc(I, IDelta);\r\n O := @OutputBuffer;\r\n Inc(O, ODelta);\r\n MimeEncodeNoCRLF(I^, InputByteCount - IDelta, O^);\r\nend;\r\n\r\nprocedure MimeEncodeFullLines(const InputBuffer: TDynByteArray; InputOffset: SizeInt;\r\n const InputByteCount: SizeInt; out OutputBuffer: TDynByteArray; OutputOffset: SizeInt);\r\nvar\r\n B, InnerLimit, OuterLimit: SizeInt;\r\n InIndex: SizeInt;\r\n OutIndex: SizeInt;\r\nbegin\r\n { Do we have enough input to encode a full line? }\r\n if InputByteCount < MIME_DECODED_LINE_BREAK then\r\n Exit;\r\n\r\n InIndex := InputOffset;\r\n OutIndex := OutputOffset;\r\n\r\n InnerLimit := InIndex;\r\n Inc(InnerLimit, MIME_DECODED_LINE_BREAK);\r\n\r\n OuterLimit := InIndex;\r\n Inc(OuterLimit, InputByteCount);\r\n\r\n { Multiple line loop. }\r\n repeat\r\n { Single line loop. }\r\n repeat\r\n { Read 3 bytes from InputBuffer. }\r\n B := InputBuffer[InIndex + 0];\r\n B := B shl 8;\r\n B := B or InputBuffer[InIndex + 1];\r\n B := B shl 8;\r\n B := B or InputBuffer[InIndex + 2];\r\n Inc(InIndex, 3);\r\n { Write 4 bytes to OutputBuffer (in reverse order). }\r\n OutputBuffer[OutIndex + 3] := MIME_ENCODE_TABLE[B and $3F];\r\n B := B shr 6;\r\n OutputBuffer[OutIndex + 2] := MIME_ENCODE_TABLE[B and $3F];\r\n B := B shr 6;\r\n OutputBuffer[OutIndex + 1] := MIME_ENCODE_TABLE[B and $3F];\r\n B := B shr 6;\r\n OutputBuffer[OutIndex + 0] := MIME_ENCODE_TABLE[B];\r\n Inc(OutIndex, 3);\r\n until InIndex >= InnerLimit;\r\n\r\n { Write line break (CRLF). }\r\n OutputBuffer[OutIndex + 0] := 13;\r\n OutputBuffer[OutIndex + 1] := 10;\r\n Inc(OutIndex, 2);\r\n\r\n Inc(InnerLimit, MIME_DECODED_LINE_BREAK);\r\n until InnerLimit > OuterLimit;\r\nend;\r\n\r\nprocedure MimeEncodeFullLines(const InputBuffer; const InputByteCount: SizeInt; out OutputBuffer);\r\nvar\r\n B: Cardinal;\r\n InnerLimit, OuterLimit: TJclAddr;\r\n InPtr: PByte3;\r\n OutPtr: PByte4;\r\nbegin\r\n { Do we have enough input to encode a full line? }\r\n if InputByteCount < MIME_DECODED_LINE_BREAK then\r\n Exit;\r\n\r\n InPtr := @InputBuffer;\r\n OutPtr := @OutputBuffer;\r\n\r\n InnerLimit := TJclAddr(InPtr);\r\n Inc(InnerLimit, MIME_DECODED_LINE_BREAK);\r\n\r\n OuterLimit := TJclAddr(InPtr);\r\n Inc(OuterLimit, InputByteCount);\r\n\r\n { Multiple line loop. }\r\n repeat\r\n { Single line loop. }\r\n repeat\r\n { Read 3 bytes from InputBuffer. }\r\n B := InPtr^.B1;\r\n B := B shl 8;\r\n B := B or InPtr^.B2;\r\n B := B shl 8;\r\n B := B or InPtr^.B3;\r\n Inc(InPtr);\r\n { Write 4 bytes to OutputBuffer (in reverse order). }\r\n OutPtr^.B4 := MIME_ENCODE_TABLE[B and $3F];\r\n B := B shr 6;\r\n OutPtr^.B3 := MIME_ENCODE_TABLE[B and $3F];\r\n B := B shr 6;\r\n OutPtr^.B2 := MIME_ENCODE_TABLE[B and $3F];\r\n B := B shr 6;\r\n OutPtr^.B1 := MIME_ENCODE_TABLE[B];\r\n Inc(OutPtr);\r\n until TJclAddr(InPtr) >= InnerLimit;\r\n\r\n { Write line break (CRLF). }\r\n OutPtr^.B1 := 13;\r\n OutPtr^.B2 := 10;\r\n Inc(TJclAddr(OutPtr), 2);\r\n\r\n Inc(InnerLimit, MIME_DECODED_LINE_BREAK);\r\n until InnerLimit > OuterLimit;\r\nend;\r\n\r\nprocedure MimeEncodeNoCRLF(const InputBuffer: TDynByteArray; InputOffset: SizeInt;\r\n const InputByteCount: SizeInt; out OutputBuffer: TDynByteArray; OutputOffset: SizeInt);\r\nvar\r\n B, InnerLimit, OuterLimit: SizeInt;\r\n InIndex: SizeInt;\r\n OutIndex: SizeInt;\r\nbegin\r\n if InputByteCount = 0 then\r\n Exit;\r\n\r\n InIndex := InputOffset;\r\n OutIndex := OutputOffset;\r\n\r\n OuterLimit := InputByteCount div 3 * 3;\r\n\r\n InnerLimit := InIndex;\r\n Inc(InnerLimit, OuterLimit);\r\n\r\n { Last line loop. }\r\n while InIndex < InnerLimit do\r\n begin\r\n { Read 3 bytes from InputBuffer. }\r\n B := InputBuffer[InIndex + 0];\r\n B := B shl 8;\r\n B := B or InputBuffer[InIndex + 1];\r\n B := B shl 8;\r\n B := B or InputBuffer[InIndex + 2];\r\n Inc(InIndex, 3);\r\n { Write 4 bytes to OutputBuffer (in reverse order). }\r\n OutputBuffer[OutIndex + 3] := MIME_ENCODE_TABLE[B and $3F];\r\n B := B shr 6;\r\n OutputBuffer[OutIndex + 2] := MIME_ENCODE_TABLE[B and $3F];\r\n B := B shr 6;\r\n OutputBuffer[OutIndex + 1] := MIME_ENCODE_TABLE[B and $3F];\r\n B := B shr 6;\r\n OutputBuffer[OutIndex + 0] := MIME_ENCODE_TABLE[B];\r\n Inc(OutIndex, 3);\r\n end;\r\n\r\n { End of data & padding. }\r\n case InputByteCount - OuterLimit of\r\n 1:\r\n begin\r\n B := InputBuffer[InIndex + 0];\r\n B := B shl 4;\r\n OutputBuffer[OutIndex + 1] := MIME_ENCODE_TABLE[B and $3F];\r\n B := B shr 6;\r\n OutputBuffer[OutIndex + 0] := MIME_ENCODE_TABLE[B];\r\n OutputBuffer[OutIndex + 2] := MIME_PAD_CHAR; { Pad remaining 2 bytes. }\r\n OutputBuffer[OutIndex + 3] := MIME_PAD_CHAR;\r\n end;\r\n 2:\r\n begin\r\n B := InputBuffer[InIndex + 0];\r\n B := B shl 8;\r\n B := B or InputBuffer[InIndex + 1];\r\n B := B shl 2;\r\n OutputBuffer[OutIndex + 2] := MIME_ENCODE_TABLE[B and $3F];\r\n B := B shr 6;\r\n OutputBuffer[OutIndex + 1] := MIME_ENCODE_TABLE[B and $3F];\r\n B := B shr 6;\r\n OutputBuffer[OutIndex + 0] := MIME_ENCODE_TABLE[B];\r\n OutputBuffer[OutIndex + 3] := MIME_PAD_CHAR; { Pad remaining byte. }\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure MimeEncodeNoCRLF(const InputBuffer; const InputByteCount: SizeInt; out OutputBuffer);\r\nvar\r\n B: Cardinal;\r\n InnerLimit, OuterLimit: SizeInt;\r\n InPtr: PByte3;\r\n OutPtr: PByte4;\r\nbegin\r\n if InputByteCount = 0 then\r\n Exit;\r\n\r\n InPtr := @InputBuffer;\r\n OutPtr := @OutputBuffer;\r\n\r\n OuterLimit := InputByteCount div 3 * 3;\r\n\r\n InnerLimit := TJclAddr(InPtr);\r\n Inc(InnerLimit, OuterLimit);\r\n\r\n { Last line loop. }\r\n while TJclAddr(InPtr) < TJclAddr(InnerLimit) do\r\n begin\r\n { Read 3 bytes from InputBuffer. }\r\n B := InPtr^.B1;\r\n B := B shl 8;\r\n B := B or InPtr^.B2;\r\n B := B shl 8;\r\n B := B or InPtr^.B3;\r\n Inc(InPtr);\r\n { Write 4 bytes to OutputBuffer (in reverse order). }\r\n OutPtr^.B4 := MIME_ENCODE_TABLE[B and $3F];\r\n B := B shr 6;\r\n OutPtr^.B3 := MIME_ENCODE_TABLE[B and $3F];\r\n B := B shr 6;\r\n OutPtr^.B2 := MIME_ENCODE_TABLE[B and $3F];\r\n B := B shr 6;\r\n OutPtr^.B1 := MIME_ENCODE_TABLE[B];\r\n Inc(OutPtr);\r\n end;\r\n\r\n { End of data & padding. }\r\n case InputByteCount - OuterLimit of\r\n 1:\r\n begin\r\n B := InPtr^.B1;\r\n B := B shl 4;\r\n OutPtr.B2 := MIME_ENCODE_TABLE[B and $3F];\r\n B := B shr 6;\r\n OutPtr.B1 := MIME_ENCODE_TABLE[B];\r\n OutPtr.B3 := MIME_PAD_CHAR; { Pad remaining 2 bytes. }\r\n OutPtr.B4 := MIME_PAD_CHAR;\r\n end;\r\n 2:\r\n begin\r\n B := InPtr^.B1;\r\n B := B shl 8;\r\n B := B or InPtr^.B2;\r\n B := B shl 2;\r\n OutPtr.B3 := MIME_ENCODE_TABLE[B and $3F];\r\n B := B shr 6;\r\n OutPtr.B2 := MIME_ENCODE_TABLE[B and $3F];\r\n B := B shr 6;\r\n OutPtr.B1 := MIME_ENCODE_TABLE[B];\r\n OutPtr.B4 := MIME_PAD_CHAR; { Pad remaining byte. }\r\n end;\r\n end;\r\nend;\r\n\r\n// Decoding Core\r\nfunction MimeDecode(const InputBuffer: TDynByteArray; InputOffset: SizeInt;\r\n const InputByteCount: SizeInt; out OutputBuffer: TDynByteArray; OutputOffset: SizeInt): SizeInt;\r\nvar\r\n ByteBuffer, ByteBufferSpace: Cardinal;\r\nbegin\r\n ByteBuffer := 0;\r\n ByteBufferSpace := 4;\r\n Result := MimeDecodePartial(InputBuffer, InputOffset, InputByteCount, OutputBuffer, OutputOffset, ByteBuffer, ByteBufferSpace);\r\n Inc(Result, MimeDecodePartialEnd(OutputBuffer, OutputOffset + Result, ByteBuffer, ByteBufferSpace));\r\nend;\r\n\r\n// Decoding Core\r\nfunction MimeDecode(const InputBuffer; const InputByteCount: SizeInt; out OutputBuffer): SizeInt;\r\nvar\r\n ByteBuffer, ByteBufferSpace: Cardinal;\r\n O: PByte;\r\nbegin\r\n ByteBuffer := 0;\r\n ByteBufferSpace := 4;\r\n Result := MimeDecodePartial(InputBuffer, InputByteCount, OutputBuffer, ByteBuffer, ByteBufferSpace);\r\n O := @OutputBuffer;\r\n Inc(O, Result);\r\n Inc(Result, MimeDecodePartialEnd(O^, ByteBuffer, ByteBufferSpace));\r\nend;\r\n\r\nfunction MimeDecodePartial(const InputBuffer: TDynByteArray; InputOffset: SizeInt;\r\n const InputByteCount: SizeInt; out OutputBuffer: TDynByteArray; OutputOffset: SizeInt;\r\n var ByteBuffer: Cardinal; var ByteBufferSpace: Cardinal): SizeInt;\r\nvar\r\n LByteBuffer, LByteBufferSpace, C: Cardinal;\r\n InIndex, OuterLimit: SizeInt;\r\n OutIndex: SizeInt;\r\nbegin\r\n if InputByteCount > 0 then\r\n begin\r\n InIndex := InputOffset;\r\n OuterLimit := InIndex + InputByteCount;\r\n OutIndex := OutputOffset;\r\n LByteBuffer := ByteBuffer;\r\n LByteBufferSpace := ByteBufferSpace;\r\n while InIndex < OuterLimit do\r\n begin\r\n { Read from InputBuffer. }\r\n C := MIME_DECODE_TABLE[InputBuffer[InIndex]];\r\n Inc(InIndex);\r\n if C = $FF then\r\n Continue;\r\n LByteBuffer := LByteBuffer shl 6;\r\n LByteBuffer := LByteBuffer or C;\r\n Dec(LByteBufferSpace);\r\n { Have we read 4 bytes from InputBuffer? }\r\n if LByteBufferSpace <> 0 then\r\n Continue;\r\n\r\n { Write 3 bytes to OutputBuffer (in reverse order). }\r\n OutputBuffer[OutIndex + 2] := Byte(LByteBuffer);\r\n LByteBuffer := LByteBuffer shr 8;\r\n OutputBuffer[OutIndex + 1] := Byte(LByteBuffer);\r\n LByteBuffer := LByteBuffer shr 8;\r\n OutputBuffer[OutIndex + 0] := Byte(LByteBuffer);\r\n LByteBuffer := 0;\r\n Inc(OutIndex, 3);\r\n LByteBufferSpace := 4;\r\n end;\r\n ByteBuffer := LByteBuffer;\r\n ByteBufferSpace := LByteBufferSpace;\r\n Result := OutIndex - OutputOffset;\r\n end\r\n else\r\n Result := 0;\r\nend;\r\n\r\nfunction MimeDecodePartial(const InputBuffer; const InputByteCount: SizeInt; out OutputBuffer;\r\n var ByteBuffer: Cardinal; var ByteBufferSpace: Cardinal): SizeInt;\r\nvar\r\n LByteBuffer, LByteBufferSpace, C: Cardinal;\r\n InPtr, OuterLimit: PByte;\r\n OutPtr: PByte3;\r\nbegin\r\n if InputByteCount > 0 then\r\n begin\r\n InPtr := @InputBuffer;\r\n OuterLimit := Pointer(TJclAddr(InPtr) + TJclAddr(InputByteCount));\r\n OutPtr := @OutputBuffer;\r\n LByteBuffer := ByteBuffer;\r\n LByteBufferSpace := ByteBufferSpace;\r\n while InPtr <> OuterLimit do\r\n begin\r\n { Read from InputBuffer. }\r\n C := MIME_DECODE_TABLE[InPtr^];\r\n Inc(InPtr);\r\n if C = $FF then\r\n Continue;\r\n LByteBuffer := LByteBuffer shl 6;\r\n LByteBuffer := LByteBuffer or C;\r\n Dec(LByteBufferSpace);\r\n { Have we read 4 bytes from InputBuffer? }\r\n if LByteBufferSpace <> 0 then\r\n Continue;\r\n\r\n { Write 3 bytes to OutputBuffer (in reverse order). }\r\n OutPtr^.B3 := Byte(LByteBuffer);\r\n LByteBuffer := LByteBuffer shr 8;\r\n OutPtr^.B2 := Byte(LByteBuffer);\r\n LByteBuffer := LByteBuffer shr 8;\r\n OutPtr^.B1 := Byte(LByteBuffer);\r\n LByteBuffer := 0;\r\n Inc(OutPtr);\r\n LByteBufferSpace := 4;\r\n end;\r\n ByteBuffer := LByteBuffer;\r\n ByteBufferSpace := LByteBufferSpace;\r\n Result := SizeInt(TJclAddr(OutPtr) - TJclAddr(@OutputBuffer));\r\n end\r\n else\r\n Result := 0;\r\nend;\r\n\r\nfunction MimeDecodePartialEnd(out OutputBuffer: TDynByteArray; OutputOffset: SizeInt;\r\n const ByteBuffer: Cardinal; const ByteBufferSpace: Cardinal): SizeInt;\r\nvar\r\n LByteBuffer: Cardinal;\r\nbegin\r\n case ByteBufferSpace of\r\n 1:\r\n begin\r\n LByteBuffer := ByteBuffer shr 2;\r\n OutputBuffer[OutputOffset + 1] := Byte(LByteBuffer);\r\n LByteBuffer := LByteBuffer shr 8;\r\n OutputBuffer[OutputOffset + 0] := Byte(LByteBuffer);\r\n Result := 2;\r\n end;\r\n 2:\r\n begin\r\n LByteBuffer := ByteBuffer shr 4;\r\n OutputBuffer[OutputOffset + 0] := Byte(LByteBuffer);\r\n Result := 1;\r\n end;\r\n else\r\n Result := 0;\r\n end;\r\nend;\r\n\r\nfunction MimeDecodePartialEnd(out OutputBuffer; const ByteBuffer: Cardinal;\r\n const ByteBufferSpace: Cardinal): SizeInt;\r\nvar\r\n LByteBuffer: Cardinal;\r\nbegin\r\n case ByteBufferSpace of\r\n 1:\r\n begin\r\n LByteBuffer := ByteBuffer shr 2;\r\n PByte3(@OutputBuffer)^.B2 := Byte(LByteBuffer);\r\n LByteBuffer := LByteBuffer shr 8;\r\n PByte3(@OutputBuffer)^.B1 := Byte(LByteBuffer);\r\n Result := 2;\r\n end;\r\n 2:\r\n begin\r\n LByteBuffer := ByteBuffer shr 4;\r\n PByte3(@OutputBuffer)^.B1 := Byte(LByteBuffer);\r\n Result := 1;\r\n end;\r\n else\r\n Result := 0;\r\n end;\r\nend;\r\n\r\n// File Encoding & Decoding\r\nprocedure MimeEncodeFile(const InputFileName, OutputFileName: TFileName);\r\nvar\r\n InputStream, OutputStream: TFileStream;\r\nbegin\r\n InputStream := TFileStream.Create(InputFileName, fmOpenRead or fmShareDenyWrite);\r\n try\r\n OutputStream := TFileStream.Create(OutputFileName, fmCreate);\r\n try\r\n MimeEncodeStream(InputStream, OutputStream);\r\n finally\r\n OutputStream.Free;\r\n end;\r\n finally\r\n InputStream.Free;\r\n end;\r\nend;\r\n\r\nprocedure MimeEncodeFileNoCRLF(const InputFileName, OutputFileName: TFileName);\r\nvar\r\n InputStream, OutputStream: TFileStream;\r\nbegin\r\n InputStream := TFileStream.Create(InputFileName, fmOpenRead or fmShareDenyWrite);\r\n try\r\n OutputStream := TFileStream.Create(OutputFileName, fmCreate);\r\n try\r\n MimeEncodeStreamNoCRLF(InputStream, OutputStream);\r\n finally\r\n OutputStream.Free;\r\n end;\r\n finally\r\n InputStream.Free;\r\n end;\r\nend;\r\n\r\nprocedure MimeDecodeFile(const InputFileName, OutputFileName: TFileName);\r\nvar\r\n InputStream, OutputStream: TFileStream;\r\nbegin\r\n InputStream := TFileStream.Create(InputFileName, fmOpenRead or fmShareDenyWrite);\r\n try\r\n OutputStream := TFileStream.Create(OutputFileName, fmCreate);\r\n try\r\n MimeDecodeStream(InputStream, OutputStream);\r\n finally\r\n OutputStream.Free;\r\n end;\r\n finally\r\n InputStream.Free;\r\n end;\r\nend;\r\n\r\n// Stream Encoding & Decoding\r\nprocedure MimeEncodeStream(const InputStream: TStream; const OutputStream: TStream);\r\nvar\r\n InputBuffer: array [0..MIME_BUFFER_SIZE - 1] of Byte;\r\n OutputBuffer: array [0..(MIME_BUFFER_SIZE + 2) div 3 * 4 + MIME_BUFFER_SIZE div MIME_DECODED_LINE_BREAK * 2 - 1] of Byte;\r\n BytesRead: SizeInt;\r\n IDelta, ODelta: SizeInt;\r\n I, O: PByte;\r\nbegin\r\n InputBuffer[0] := 0;\r\n BytesRead := InputStream.Read(InputBuffer, SizeOf(InputBuffer));\r\n\r\n while BytesRead = Length(InputBuffer) do\r\n begin\r\n MimeEncodeFullLines(InputBuffer, Length(InputBuffer), OutputBuffer);\r\n OutputStream.Write(OutputBuffer, Length(OutputBuffer));\r\n BytesRead := InputStream.Read(InputBuffer, Length(InputBuffer));\r\n end;\r\n\r\n MimeEncodeFullLines(InputBuffer, BytesRead, OutputBuffer);\r\n\r\n IDelta := BytesRead div MIME_DECODED_LINE_BREAK; // Number of lines processed.\r\n ODelta := IDelta * (MIME_ENCODED_LINE_BREAK + 2);\r\n IDelta := IDelta * MIME_DECODED_LINE_BREAK;\r\n\r\n I := @InputBuffer;\r\n Inc(I, IDelta);\r\n O := @OutputBuffer;\r\n Inc(O, ODelta);\r\n\r\n MimeEncodeNoCRLF(I^, BytesRead - IDelta, O^);\r\n\r\n OutputStream.Write(OutputBuffer, MimeEncodedSize(BytesRead));\r\nend;\r\n\r\nprocedure MimeEncodeStreamNoCRLF(const InputStream: TStream; const OutputStream: TStream);\r\nvar\r\n InputBuffer: array [0..MIME_BUFFER_SIZE - 1] of Byte;\r\n OutputBuffer: array [0..((MIME_BUFFER_SIZE + 2) div 3) * 4 - 1] of Byte;\r\n BytesRead: SizeInt;\r\nbegin\r\n InputBuffer[0] := 0;\r\n BytesRead := InputStream.Read(InputBuffer, SizeOf(InputBuffer));\r\n\r\n while BytesRead = Length(InputBuffer) do\r\n begin\r\n MimeEncodeNoCRLF(InputBuffer, Length(InputBuffer), OutputBuffer);\r\n OutputStream.Write(OutputBuffer, Length(OutputBuffer));\r\n BytesRead := InputStream.Read(InputBuffer, Length(InputBuffer));\r\n end;\r\n\r\n MimeEncodeNoCRLF(InputBuffer, BytesRead, OutputBuffer);\r\n OutputStream.Write(OutputBuffer, MimeEncodedSizeNoCRLF(BytesRead));\r\nend;\r\n\r\nprocedure MimeDecodeStream(const InputStream: TStream; const OutputStream: TStream);\r\nvar\r\n ByteBuffer, ByteBufferSpace: Cardinal;\r\n InputBuffer: array [0..MIME_BUFFER_SIZE - 1] of Byte;\r\n OutputBuffer: array [0..(MIME_BUFFER_SIZE + 3) div 4 * 3 - 1] of Byte;\r\n BytesRead: SizeInt;\r\nbegin\r\n ByteBuffer := 0;\r\n ByteBufferSpace := 4;\r\n InputBuffer[0] := 0;\r\n BytesRead := InputStream.Read(InputBuffer, SizeOf(InputBuffer));\r\n\r\n while BytesRead > 0 do\r\n begin\r\n OutputStream.Write(OutputBuffer, MimeDecodePartial(InputBuffer, BytesRead, OutputBuffer, ByteBuffer, ByteBufferSpace));\r\n BytesRead := InputStream.Read(InputBuffer, Length(InputBuffer));\r\n end;\r\n OutputStream.Write(OutputBuffer, MimeDecodePartialEnd(OutputBuffer, ByteBuffer, ByteBufferSpace));\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jcl/source/common/JclNotify.pas", "content": "{**************************************************************************************************}\r\n{ }\r\n{ Project JEDI Code Library (JCL) }\r\n{ }\r\n{ The contents of this file are subject to the Mozilla Public License Version 1.1 (the \"License\"); }\r\n{ you may not use this file except in compliance with the License. You may obtain a copy of the }\r\n{ License at http://www.mozilla.org/MPL/ }\r\n{ }\r\n{ Software distributed under the License is distributed on an \"AS IS\" basis, WITHOUT WARRANTY OF }\r\n{ ANY KIND, either express or implied. See the License for the specific language governing rights }\r\n{ and limitations under the License. }\r\n{ }\r\n{ The Original Code is JclNotify.pas. }\r\n{ }\r\n{ The Initial Developer of the Original Code is Marcel Bestebroer. }\r\n{ Portions created by Marcel Bestebroer are Copyright Marcel Bestebroer. All rights reserved. }\r\n{ }\r\n{ Contributors: }\r\n{ - }\r\n{ }\r\n{**************************************************************************************************}\r\n{ }\r\n{ This unit contains generic JCL notification/listener pattern interfaces and base implementations }\r\n{ }\r\n{**************************************************************************************************}\r\n{ }\r\n{ Last modified: $Date:: 2011-09-03 00:07:50 +0200 (sam. 03 sept. 2011) $ }\r\n{ Revision: $Rev:: 3599 $ }\r\n{ Author: $Author:: outchy $ }\r\n{ }\r\n{**************************************************************************************************}\r\n\r\nunit JclNotify;\r\n\r\n{$I jcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n JclBase,\r\n {$IFDEF THREADSAFE}\r\n JclSynch,\r\n {$ENDIF THREADSAFE}\r\n {$IFDEF HAS_UNITSCOPE}\r\n System.Classes;\r\n {$ELSE ~HAS_UNITSCOPE}\r\n Classes;\r\n {$ENDIF ~HAS_UNITSCOPE}\r\n\r\n { The following interfaces provide a basic notifier/listener setup. Whenever code issues a notification through the\r\n IJclNotifier.Notify method, all listeners registered with the notifier will receive the message (through the\r\n listener's Notification method). Since this setup doesn't care which or how many listeners are actually responding,\r\n it can greatly simplify code that need some form of notification. }\r\ntype\r\n // forward declarations\r\n IJclListener = interface;\r\n IJclNotificationMessage = interface;\r\n IJclNotifier = interface;\r\n\r\n IJclListener = interface\r\n ['{26A52ECC-4C22-4B71-BC88-D0EB98AF4ED5}']\r\n procedure Notification(msg: IJclNotificationMessage); stdcall;\r\n end;\r\n\r\n IJclNotificationMessage = interface\r\n ['{2618CCC6-0C7D-47EE-9A91-7A7F5264385D}']\r\n end;\r\n\r\n IJclNotifier = interface\r\n ['{CAAD7814-DD04-497C-91AC-558C2D5BFF81}']\r\n procedure Add(listener: IJclListener); stdcall;\r\n procedure Remove(listener: IJclListener); stdcall;\r\n procedure Notify(msg: IJclNotificationMessage); stdcall;\r\n end;\r\n\r\n { The following classes provide a basic notifier/listener implementation. Note that using one of these classes does\r\n not imply the usage of the related classes; the notifier can be used in conjection with any class implementing\r\n IJclListener and vice versa. }\r\ntype\r\n TJclBaseListener = class (TInterfacedObject, IJclListener)\r\n public\r\n { IJclListener }\r\n procedure Notification(msg: IJclNotificationMessage); virtual; stdcall;\r\n end;\r\n\r\n TJclBaseNotificationMessage = class (TInterfacedObject, IJclNotificationMessage)\r\n end;\r\n\r\n TJclBaseNotifier = class (TInterfacedObject, IJclNotifier)\r\n public\r\n constructor Create;\r\n destructor Destroy; override;\r\n private\r\n FListeners: TInterfaceList;\r\n {$IFDEF THREADSAFE}\r\n FSynchronizer: TJclMultiReadExclusiveWrite;\r\n {$ENDIF THREADSAFE}\r\n public\r\n { IJclNotifier }\r\n procedure Add(listener: IJclListener); stdcall;\r\n procedure Notify(msg: IJclNotificationMessage); stdcall;\r\n procedure Remove(listener: IJclListener); stdcall;\r\n end;\r\n\r\ntype\r\n TJclMethodArray = array of TMethod;\r\n\r\n // base class for all object methods broadcasts\r\n TJclMethodBroadCast = class\r\n protected\r\n FHandlers: TJclMethodArray;\r\n FHandlerCount: Integer;\r\n function GetHandler(Index: Integer): TMethod;\r\n public\r\n function AddHandler(const AHandler: TMethod): Integer;\r\n procedure RemoveHandler(const AHandler: TMethod);\r\n procedure DeleteHandler(Index: Integer);\r\n property HandlerCount: Integer read FHandlerCount;\r\n end;\r\n\r\n // This class broadcasts a notification event to a list of handlers\r\n TJclNotifyEventBroadcast = class(TJclMethodBroadCast)\r\n protected\r\n function GetHandler(Index: Integer): TNotifyEvent;\r\n public\r\n function AddHandler(const AHandler: TNotifyEvent): Integer;\r\n procedure RemoveHandler(const AHandler: TNotifyEvent);\r\n procedure Notify(Sender: TObject);\r\n property Handlers[Index: Integer]: TNotifyEvent read GetHandler;\r\n end;\r\n\r\n TJclProcedureEvent = procedure of object;\r\n\r\n // This class broadcasts an event to a list of handlers\r\n TJclProcedureEventBroadcast = class(TJclMethodBroadCast)\r\n protected\r\n function GetHandler(Index: Integer): TJclProcedureEvent;\r\n public\r\n function AddHandler(const AHandler: TJclProcedureEvent): Integer;\r\n procedure RemoveHandler(const AHandler: TJclProcedureEvent);\r\n procedure CallAllProcedures;\r\n property Handlers[Index: Integer]: TJclProcedureEvent read GetHandler;\r\n end;\r\n\r\n TJclBooleanProcedureEvent = procedure(Value: Boolean) of object;\r\n\r\n // This class broadcasts an event to a list of handlers\r\n TJclBooleanProcedureEventBroadcast = class(TJclMethodBroadCast)\r\n protected\r\n function GetHandler(Index: Integer): TJclBooleanProcedureEvent;\r\n public\r\n function AddHandler(const AHandler: TJclBooleanProcedureEvent): Integer;\r\n procedure RemoveHandler(const AHandler: TJclBooleanProcedureEvent);\r\n procedure CallAllProcedures(Value: Boolean);\r\n property Handlers[Index: Integer]: TJclBooleanProcedureEvent read GetHandler;\r\n end;\r\n\r\n TJclBooleanEvent = function: Boolean of object;\r\n\r\n // This class broadcasts a predicate to a list of handlers\r\n TJclBooleanEventBroadcast = class(TJclMethodBroadCast)\r\n protected\r\n function GetHandler(Index: Integer): TJclBooleanEvent;\r\n public\r\n function AddHandler(const AHandler: TJclBooleanEvent): Integer;\r\n procedure RemoveHandler(const AHandler: TJclBooleanEvent);\r\n function LogicalAnd: Boolean;\r\n property Handlers[Index: Integer]: TJclBooleanEvent read GetHandler;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jcl.svn.sourceforge.net/svnroot/jcl/tags/JCL-2.4-Build4571/jcl/source/common/JclNotify.pas $';\r\n Revision: '$Revision: 3599 $';\r\n Date: '$Date: 2011-09-03 00:07:50 +0200 (sam. 03 sept. 2011) $';\r\n LogPath: 'JCL\\source\\common';\r\n Extra: '';\r\n Data: nil\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n {$IFDEF HAS_UNITSCOPE}\r\n System.SysUtils;\r\n {$ELSE ~HAS_UNITSCOPE}\r\n SysUtils;\r\n {$ENDIF ~HAS_UNITSCOPE}\r\n\r\n//=== { TJclBaseNotifier } ===================================================\r\n\r\nconstructor TJclBaseNotifier.Create;\r\nbegin\r\n inherited Create;\r\n FListeners := TInterfaceList.Create;\r\n {$IFDEF THREADSAFE}\r\n FSynchronizer := TJclMultiReadExclusiveWrite.Create(mpReaders);\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\ndestructor TJclBaseNotifier.Destroy;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FSynchronizer.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n FreeAndNil(FListeners);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FSynchronizer.EndWrite;\r\n FreeAndNil(FSynchronizer);\r\n end;\r\n {$ENDIF THREADSAFE}\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJclBaseNotifier.Add(listener: IJclListener);\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FSynchronizer.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FListeners.IndexOf(listener) < 0 then\r\n FListeners.Add(listener);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FSynchronizer.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclBaseNotifier.Notify(msg: IJclNotificationMessage);\r\nvar\r\n idx: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FSynchronizer.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n for idx := 0 to FListeners.Count - 1 do\r\n IJclListener(FListeners[idx]).Notification(msg);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FSynchronizer.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclBaseNotifier.Remove(listener: IJclListener);\r\nvar\r\n idx: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FSynchronizer.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n idx := FListeners.IndexOf(listener);\r\n if idx >= 0 then\r\n FListeners.Delete(idx);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FSynchronizer.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\n//=== { TJclBaseListener } ===================================================\r\n\r\nprocedure TJclBaseListener.Notification(msg: IJclNotificationMessage);\r\nbegin\r\n // do nothing; descendants should override this method to process incoming notifications\r\nend;\r\n\r\n//=== { TNotifyEventBroadcast } ==============================================\r\n\r\nfunction TJclMethodBroadcast.AddHandler(\r\n const AHandler: TMethod): Integer;\r\nvar\r\n HandlerLength: Integer;\r\nbegin\r\n HandlerLength := Length(FHandlers);\r\n if FHandlerCount >= HandlerLength then\r\n begin\r\n if HandlerLength > 0 then\r\n HandlerLength := HandlerLength * 2\r\n else\r\n HandlerLength := 4;\r\n SetLength(FHandlers, HandlerLength);\r\n end;\r\n Result := FHandlerCount;\r\n Inc(FHandlerCount);\r\n FHandlers[Result] := AHandler;\r\nend;\r\n\r\nprocedure TJclMethodBroadcast.DeleteHandler(Index: Integer);\r\nvar\r\n I: Integer;\r\n HandlerLength: Integer;\r\nbegin\r\n for I := Index to FHandlerCount - 2 do\r\n FHandlers[I] := FHandlers[I + 1];\r\n\r\n HandlerLength := Length(FHandlers);\r\n Dec(FHandlerCount);\r\n if (FHandlerCount > 0) and ((2 * FHandlerCount) < HandlerLength) then\r\n begin\r\n HandlerLength := HandlerLength div 2;\r\n SetLength(FHandlers, HandlerLength);\r\n end;\r\nend;\r\n\r\nfunction TJclMethodBroadcast.GetHandler(Index: Integer): TMethod;\r\nbegin\r\n Result := FHandlers[Index];\r\nend;\r\n\r\nprocedure TJclMethodBroadcast.RemoveHandler(const AHandler: TMethod);\r\nvar\r\n Index: Integer;\r\nbegin\r\n for Index := FHandlerCount - 1 downto 0 do\r\n if (TMethod(FHandlers[Index]).Code = TMethod(AHandler).Code) and\r\n (TMethod(FHandlers[Index]).Data = TMethod(AHandler).Data) then\r\n DeleteHandler(Index);\r\nend;\r\n\r\n//=== { TJclNotifyEventBroadcast } ===========================================\r\n\r\nfunction TJclNotifyEventBroadcast.AddHandler(\r\n const AHandler: TNotifyEvent): Integer;\r\nbegin\r\n Result := inherited AddHandler(TMethod(AHandler));\r\nend;\r\n\r\nfunction TJclNotifyEventBroadcast.GetHandler(Index: Integer): TNotifyEvent;\r\nbegin\r\n Result := TNotifyEvent(inherited GetHandler(Index));\r\nend;\r\n\r\nprocedure TJclNotifyEventBroadcast.Notify(Sender: TObject);\r\nvar\r\n Index: Integer;\r\nbegin\r\n for Index := 0 to FHandlerCount - 1 do\r\n TNotifyEvent(FHandlers[Index])(Sender);\r\nend;\r\n\r\nprocedure TJclNotifyEventBroadcast.RemoveHandler(const AHandler: TNotifyEvent);\r\nbegin\r\n inherited RemoveHandler(TMethod(AHandler));\r\nend;\r\n\r\n//=== { TJclProcedureBroadcast } =============================================\r\n\r\nfunction TJclProcedureEventBroadcast.AddHandler(\r\n const AHandler: TJclProcedureEvent): Integer;\r\nbegin\r\n Result := inherited AddHandler(TMethod(AHandler));\r\nend;\r\n\r\nfunction TJclProcedureEventBroadcast.GetHandler(Index: Integer): TJclProcedureEvent;\r\nbegin\r\n Result := TJclProcedureEvent(inherited GetHandler(Index));\r\nend;\r\n\r\nprocedure TJclProcedureEventBroadcast.CallAllProcedures;\r\nvar\r\n Index: Integer;\r\nbegin\r\n for Index := 0 to FHandlerCount - 1 do\r\n TJclProcedureEvent(FHandlers[Index]);\r\nend;\r\n\r\nprocedure TJclProcedureEventBroadcast.RemoveHandler(const AHandler: TJclProcedureEvent);\r\nbegin\r\n inherited RemoveHandler(TMethod(AHandler));\r\nend;\r\n\r\n//=== { TJclBooleanProcedureBroadcast } =============================================\r\n\r\nfunction TJclBooleanProcedureEventBroadcast.AddHandler(\r\n const AHandler: TJclBooleanProcedureEvent): Integer;\r\nbegin\r\n Result := inherited AddHandler(TMethod(AHandler));\r\nend;\r\n\r\nfunction TJclBooleanProcedureEventBroadcast.GetHandler(Index: Integer): TJclBooleanProcedureEvent;\r\nbegin\r\n Result := TJclBooleanProcedureEvent(inherited GetHandler(Index));\r\nend;\r\n\r\nprocedure TJclBooleanProcedureEventBroadcast.CallAllProcedures(Value: Boolean);\r\nvar\r\n Index: Integer;\r\nbegin\r\n for Index := 0 to FHandlerCount - 1 do\r\n TJclBooleanProcedureEvent(FHandlers[Index])(Value);\r\nend;\r\n\r\nprocedure TJclBooleanProcedureEventBroadcast.RemoveHandler(const AHandler: TJclBooleanProcedureEvent);\r\nbegin\r\n inherited RemoveHandler(TMethod(AHandler));\r\nend;\r\n\r\n//=== { TJclBooleanEventBroadcast } ==========================================\r\n\r\nfunction TJclBooleanEventBroadcast.AddHandler(\r\n const AHandler: TJclBooleanEvent): Integer;\r\nbegin\r\n Result := inherited AddHandler(TMethod(AHandler));\r\nend;\r\n\r\nfunction TJclBooleanEventBroadcast.GetHandler(Index: Integer): TJclBooleanEvent;\r\nbegin\r\n Result := TJclBooleanEvent(inherited GetHandler(Index));\r\nend;\r\n\r\nfunction TJclBooleanEventBroadcast.LogicalAnd: Boolean;\r\nvar\r\n Index: Integer;\r\nbegin\r\n Result := True;\r\n for Index := 0 to FHandlerCount - 1 do\r\n begin\r\n Result := TJclBooleanEvent(FHandlers[Index]);\r\n if not Result then\r\n Break;\r\n end;\r\nend;\r\n\r\nprocedure TJclBooleanEventBroadcast.RemoveHandler(\r\n const AHandler: TJclBooleanEvent);\r\nbegin\r\n inherited RemoveHandler(TMethod(AHandler));\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jcl/source/common/JclPCRE.pas", "content": "{**************************************************************************************************}\r\n{ }\r\n{ Project JEDI Code Library (JCL) }\r\n{ }\r\n{ The contents of this file are subject to the Mozilla Public License Version 1.1 (the \"License\"); }\r\n{ you may not use this file except in compliance with the License. You may obtain a copy of the }\r\n{ License at http://www.mozilla.org/MPL/ }\r\n{ }\r\n{ Software distributed under the License is distributed on an \"AS IS\" basis, WITHOUT WARRANTY OF }\r\n{ ANY KIND, either express or implied. See the License for the specific language governing rights }\r\n{ and limitations under the License. }\r\n{ }\r\n{ The Original Code is JclPCRE.pas. }\r\n{ }\r\n{ The Initial Developer of the Original Code is Peter Thornqvist. }\r\n{ Portions created by Peter Thornqvist are Copyright (C) of Peter Thornqvist. All rights reserved. }\r\n{ }\r\n{ Contributor(s): }\r\n{ Robert Rossmair (rrossmair) }\r\n{ Mario R. Carro }\r\n{ Florent Ouchet (outchy) }\r\n{ }\r\n{**************************************************************************************************}\r\n{ }\r\n{ Class wrapper for PCRE (PERL Compatible Regular Expression) }\r\n{ }\r\n{**************************************************************************************************}\r\n{ }\r\n{ Last modified: $Date:: 2012-09-04 16:08:04 +0200 (mar. 04 sept. 2012) $ }\r\n{ Revision: $Rev:: 3861 $ }\r\n{ Author: $Author:: outchy $ }\r\n{ }\r\n{**************************************************************************************************}\r\n\r\nunit JclPCRE;\r\n\r\n{$I jcl.inc}\r\n\r\n{$RANGECHECKS OFF}\r\n\r\ninterface\r\n\r\nuses\r\n pcre,\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n {$IFDEF HAS_UNIT_LIBC}\r\n Libc,\r\n {$ENDIF HAS_UNIT_LIBC}\r\n {$IFDEF HAS_UNITSCOPE}\r\n System.Classes, System.SysUtils,\r\n {$IFDEF PCRE_RTL}\r\n System.RegularExpressionsAPI,\r\n {$ENDIF PCRE_RTL}\r\n {$ELSE ~HAS_UNITSCOPE}\r\n Classes, SysUtils,\r\n {$IFDEF PCRE_RTL}\r\n RegularExpressionsAPI,\r\n {$ENDIF PCRE_RTL}\r\n {$ENDIF ~HAS_UNITSCOPE}\r\n JclBase, JclStringConversions;\r\n\r\nconst\r\n JCL_PCRE_CALLOUT_NOERROR = 0;\r\n JCL_PCRE_CALLOUT_FAILCONTINUE = 1;\r\n\r\n JCL_PCRE_ERROR_NOJIT = -996;\r\n JCL_PCRE_ERROR_NOUTF8 = -997;\r\n JCL_PCRE_ERROR_NOUTF16 = -997;\r\n JCL_PCRE_ERROR_CALLOUTERROR = -998;\r\n JCL_PCRE_ERROR_STUDYFAILED = -999;\r\n\r\ntype\r\n EPCREError = class(EJclError)\r\n private\r\n FErrorCode: Integer;\r\n public\r\n constructor CreateRes(ResStringRec: PResStringRec; ErrorCode: Integer);\r\n property ErrorCode: Integer read FErrorCode;\r\n end;\r\n\r\n TPCREIntArray = array [0 .. 0] of Integer;\r\n PPCREIntArray = ^TPCREIntArray;\r\n\r\n TJclRegExOption = (roIgnoreCase, roMultiLine, roDotAll, roExtended,\r\n roAnchored, roDollarEndOnly, roExtra, roNotBOL, roNotEOL, roUnGreedy,\r\n roNotEmpty, roUTF8, roNoAutoCapture, roNoUTF8Check, roAutoCallout,\r\n roPartial, roDfaShortest, roDfaRestart, roFirstLine, roDupNames,\r\n roNewLineCR, roNewLineLF, roNewLineCRLF, roNewLineAny, roBSRAnyCRLF,\r\n roBSRUnicode, roJavascriptCompat, roNoStartOptimize, roPartialHard,\r\n roNotEmptyAtStart, roUCP);\r\n TJclRegExOptions = set of TJclRegExOption;\r\n\r\nconst\r\n roUTF16 = roUTF8;\r\n roNoUTF16Check = roNoUTF8Check;\r\n\r\ntype\r\n TJclRegExBase = class;\r\n\r\n TJclCaptureRange = record\r\n FirstPos: Integer;\r\n LastPos: Integer;\r\n end;\r\n\r\n TJclRegExCallout = procedure (Sender: TJclRegExBase;\r\n Index, MatchStart, SubjectPos, LastCapture, PatternPos, NextItemLength: Integer;\r\n var ErrorCode: Integer) of object;\r\n TPCRECalloutIndex = 0 .. 255;\r\n\r\n TJclRegExBase = class(TObject)\r\n private\r\n FOptions: TJclRegExOptions;\r\n FPattern: string;\r\n FDfaMode: Boolean;\r\n FSubject: string;\r\n\r\n FViewChanges: Boolean;\r\n FChangedCaptures: TList;\r\n FResultValues: array of string;\r\n\r\n FErrorCode: Integer;\r\n FErrorMessage: string;\r\n FErrorOffset: Integer;\r\n\r\n FVector: PPCREIntArray;\r\n FVectorSize: Integer;\r\n FCaptureCount: Integer;\r\n\r\n FOnCallout: TJclRegExCallout;\r\n\r\n protected\r\n function GetResult: string; virtual;\r\n function GetCapture(Index: Integer): string; virtual; abstract;\r\n procedure SetCapture(Index: Integer; const Value: string); virtual;\r\n function GetCaptureRange(Index: Integer): TJclCaptureRange; virtual; abstract;\r\n function GetNamedCapture(const Name: string): string; virtual; abstract;\r\n procedure SetNamedCapture(const Name, Value: string); virtual; abstract;\r\n function GetCaptureNameCount: Integer; virtual; abstract;\r\n function GetCaptureName(Index: Integer): string; virtual; abstract;\r\n function GetAPIOptions(RunTime, DFA: Boolean): Integer; virtual;\r\n\r\n function SupportsWideChar: Boolean; virtual;\r\n public\r\n destructor Destroy; override;\r\n\r\n property Options: TJclRegExOptions read FOptions write FOptions;\r\n function Compile(const Pattern: string; Study: Boolean;\r\n UserLocale: Boolean = False; JITCompile: Boolean = False): Boolean; virtual; abstract;\r\n property Pattern: string read FPattern;\r\n property DfaMode: Boolean read FDfaMode write FDfaMode;\r\n function Match(const Subject: string; StartOffset: Cardinal = 1): Boolean; virtual; abstract;\r\n property Subject: string read FSubject;\r\n property Result: string read GetResult;\r\n\r\n property ViewChanges: Boolean read FViewChanges write FViewChanges;\r\n property CaptureCount: Integer read FCaptureCount write FCaptureCount;\r\n property Captures[Index: Integer]: string read GetCapture write SetCapture;\r\n property CaptureRanges[Index: Integer]: TJclCaptureRange read GetCaptureRange;\r\n\r\n property NamedCaptures[const Name: string]: string\r\n read GetNamedCapture write SetNamedCapture;\r\n property CaptureNameCount: Integer read GetCaptureNameCount;\r\n property CaptureNames[Index: Integer]: string read GetCaptureName;\r\n function IndexOfName(const Name: string): Integer; virtual; abstract;\r\n function IsNameValid(const Name: string): Boolean; virtual; abstract;\r\n\r\n property ErrorCode: Integer read FErrorCode;\r\n property ErrorMessage: string read FErrorMessage;\r\n property ErrorOffset: Integer read FErrorOffset;\r\n\r\n property OnCallout: TJclRegExCallout read FOnCallout write FOnCallout;\r\n end;\r\n\r\n {$IFDEF PCRE_8}\r\n TJclAnsiRegEx = class(TJclRegExBase)\r\n private\r\n FCode: PPCRE;\r\n FExtra: PPCREExtra;\r\n protected\r\n function CalloutHandler(var CalloutBlock: pcre_callout_block): Integer;\r\n function GetAPIOptions(RunTime, DFA: Boolean): Integer; override;\r\n function GetCapture(Index: Integer): string; override;\r\n function GetCaptureName(Index: Integer): string; override;\r\n function GetCaptureNameCount: Integer; override;\r\n function GetCaptureRange(Index: Integer): TJclCaptureRange; override;\r\n function GetNamedCapture(const Name: string): string; override;\r\n procedure SetNamedCapture(const Name, Value: string); override;\r\n public\r\n destructor Destroy; override;\r\n function Compile(const Pattern: string; Study: Boolean;\r\n UserLocale: Boolean = False; JITCompile: Boolean = False): Boolean; override;\r\n function Match(const Subject: string; StartOffset: Cardinal = 1): Boolean; override;\r\n function IndexOfName(const Name: string): Integer; override;\r\n function IsNameValid(const Name: string): Boolean; override;\r\n end;\r\n\r\n TJclAnsiRegExOption = TJclRegExOption;\r\n TJclAnsiRegExOptions = TJclRegExOptions;\r\n TJclAnsiCaptureRange = TJclCaptureRange;\r\n TJclAnsiRegExCallout = TJclRegExCallout;\r\n {$ENDIF PCRE_8}\r\n\r\n {$IFDEF PCRE_16}\r\n TJclWideRegEx = class(TJclRegExBase)\r\n private\r\n FCode: PPCRE16;\r\n FExtra: PPCRE16Extra;\r\n protected\r\n function CalloutHandler(var CalloutBlock: pcre16_callout_block): Integer;\r\n function GetAPIOptions(RunTime, DFA: Boolean): Integer; override;\r\n function GetCapture(Index: Integer): string; override;\r\n function GetCaptureName(Index: Integer): string; override;\r\n function GetCaptureNameCount: Integer; override;\r\n function GetCaptureRange(Index: Integer): TJclCaptureRange; override;\r\n function GetNamedCapture(const Name: string): string; override;\r\n procedure SetNamedCapture(const Name, Value: string); override;\r\n function SupportsWideChar: Boolean; override;\r\n public\r\n destructor Destroy; override;\r\n function Compile(const Pattern: string; Study: Boolean;\r\n UserLocale: Boolean = False; JITCompile: Boolean = False): Boolean; override;\r\n function Match(const Subject: string; StartOffset: Cardinal = 1): Boolean; override;\r\n function IndexOfName(const Name: string): Integer; override;\r\n function IsNameValid(const Name: string): Boolean; override;\r\n end;\r\n\r\n TJclWideRegExOption = TJclRegExOption;\r\n TJclWideRegExOptions = TJclRegExOptions;\r\n TJclWideCaptureRange = TJclCaptureRange;\r\n TJclWideRegExCallout = TJclRegExCallout;\r\n {$ENDIF PCRE_16}\r\n\r\n {$IFDEF JCL_PCRE_8}\r\n TJclRegEx = TJclAnsiRegEx;\r\n {$ENDIF JCL_PCRE_8}\r\n {$IFDEF JCL_PCRE_16}\r\n TJclRegEx = TJclWideRegEx;\r\n {$ENDIF JCL_PCRE_16}\r\n\r\n{$IFDEF PCRE_8}\r\nprocedure InitializeLocaleSupport;\r\nprocedure TerminateLocaleSupport;\r\n{$ENDIF PCRE_8}\r\n\r\n{$IFDEF PCRE_16}\r\nprocedure InitializeLocaleSupport16;\r\nprocedure TerminateLocaleSupport16;\r\n{$ENDIF PCRE_16}\r\n\r\n{$IFDEF JCL_PCRE}\r\n// Args is an array of pairs (CaptureIndex, Value) or (CaptureName, Value).\r\n// For example: NewIp := StrReplaceRegEx(DirIP, '(\\d+)\\.(\\d+)\\.(\\d+)\\.(\\d+)', [3, '128', 4, '254']);\r\nfunction StrReplaceRegEx(const Subject, Pattern: string; Args: array of const): string;\r\n{$ENDIF JCL_PCRE}\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jcl.svn.sourceforge.net/svnroot/jcl/tags/JCL-2.4-Build4571/jcl/source/common/JclPCRE.pas $';\r\n Revision: '$Revision: 3861 $';\r\n Date: '$Date: 2012-09-04 16:08:04 +0200 (mar. 04 sept. 2012) $';\r\n LogPath: 'JCL\\source\\common';\r\n Extra: '';\r\n Data: nil\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n {$IFDEF HAS_UNITSCOPE}\r\n System.SysConst,\r\n {$ELSE ~HAS_UNITSCOPE}\r\n SysConst,\r\n {$ENDIF ~HAS_UNITSCOPE}\r\n JclResources;\r\n\r\nfunction EncodeAnsiString(const S: string; ToUTF8: Boolean): AnsiString; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF SUPPORTS_INLINE}\r\nbegin\r\n if ToUTF8 then\r\n Result := StringToUTF8(S)\r\n else\r\n Result := AnsiString(S);\r\nend;\r\n\r\nfunction EncodeWideString(const S: string; ToUTF16: Boolean): WideString; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF SUPPORTS_INLINE}\r\nbegin\r\n if ToUTF16 then\r\n Result := StringToUTF16(S)\r\n else\r\n Result := WideString(S);\r\nend;\r\n\r\nfunction DecodeAnsiString(const S: AnsiString; IsUTF8: Boolean): string; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF SUPPORTS_INLINE}\r\nbegin\r\n if IsUTF8 then\r\n Result := UTF8ToString(S)\r\n else\r\n Result := string(S);\r\nend;\r\n\r\nfunction DecodeWideString(const S: WideString; IsUTF16: Boolean): string; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF SUPPORTS_INLINE}\r\nbegin\r\n if IsUTF16 then\r\n Result := UTF16ToString(S)\r\n else\r\n Result := string(S);\r\nend;\r\n\r\nfunction TranslateAnsiIndex(const S: string; ToUTF8: Boolean; Index: SizeInt): SizeInt;\r\nvar\r\n UTF8Buffer: TUTF8String;\r\n UTF8Pos, StrPos, StrLen: SizeInt;\r\n Ch: UCS4;\r\nbegin\r\n if ToUTF8 then\r\n begin\r\n SetLength(UTF8Buffer, 6);\r\n StrPos := 1;\r\n StrLen := Length(S);\r\n while (StrPos > 0) and (StrPos <= StrLen) and (Index > 1) do\r\n begin\r\n UTF8Pos := 1;\r\n Ch := StringGetNextChar(S, StrPos);\r\n if (StrPos > 0) and UTF8SetNextChar(UTF8Buffer, UTF8Pos, Ch) and (UTF8Pos > 0) then\r\n Dec(Index, UTF8Pos - 1);\r\n end;\r\n if StrPos <= 0 then\r\n raise EJclUnexpectedEOSequenceError.Create\r\n else\r\n if StrPos > StrLen then\r\n Result := StrLen + 1\r\n else\r\n Result := StrPos;\r\n end\r\n else\r\n Result := Index;\r\nend;\r\n\r\nfunction TranslateWideIndex(const S: string; ToUTF16: Boolean; Index: SizeInt): SizeInt;\r\nvar\r\n UTF16Buffer: TUTF16String;\r\n UTF16Pos, StrPos, StrLen: SizeInt;\r\n Ch: UCS4;\r\nbegin\r\n if ToUTF16 then\r\n begin\r\n SetLength(UTF16Buffer, 2);\r\n StrPos := 1;\r\n StrLen := Length(S);\r\n while (StrPos > 0) and (StrPos <= StrLen) and (Index > 1) do\r\n begin\r\n UTF16Pos := 1;\r\n Ch := StringGetNextChar(S, StrPos);\r\n if (StrPos > 0) and UTF16SetNextChar(UTF16Buffer, UTF16Pos, Ch) and (UTF16Pos > 0) then\r\n Dec(Index, UTF16Pos - 1);\r\n end;\r\n if StrPos <= 0 then\r\n raise EJclUnexpectedEOSequenceError.Create\r\n else\r\n if StrPos > StrLen then\r\n Result := StrLen + 1\r\n else\r\n Result := StrPos;\r\n end\r\n else\r\n Result := Index;\r\nend;\r\n\r\n{$IFDEF JCL_PCRE}\r\nvar\r\n {$IFDEF PCRE_8}\r\n GTables: PAnsiChar;\r\n {$ENDIF PCRE_8}\r\n {$IFDEF PCRE_16}\r\n GTables16: PAnsiChar;\r\n {$ENDIF PCRE_16}\r\n{$ENDIF JCL_PCRE}\r\n\r\n{$IFDEF RTL230_UP}\r\n {$IFDEF PCRE_RTL}\r\n {$DEFINE PCRE_EXPORT_CDECL}\r\n {$ENDIF PCRE_RTL}\r\n{$ENDIF RTL230_UP}\r\n\r\ntype\r\n {$IFDEF PCRE_RTL}\r\n {$IFDEF BDS10_UP}\r\n TPCREGetMemInteger = NativeUInt;\r\n {$ELSE ~BDS10_UP}\r\n TPCREGetMemInteger = Integer;\r\n {$ENDIF ~BDS10_UP}\r\n {$ELSE ~PCRE_RTL}\r\n TPCREGetMemInteger = SizeInt;\r\n {$ENDIF ~PCRE_RTL}\r\n\r\nfunction JclPCREGetMem(Size: TPCREGetMemInteger): Pointer; {$IFDEF PCRE_EXPORT_CDECL} cdecl; {$ENDIF PCRE_EXPORT_CDECL}\r\nbegin\r\n GetMem(Result, Size);\r\nend;\r\n\r\nfunction JclPCRE16GetMem(Size: SizeInt): Pointer; {$IFDEF PCRE_EXPORT_CDECL} cdecl; {$ENDIF PCRE_EXPORT_CDECL}\r\nbegin\r\n GetMem(Result, Size);\r\nend;\r\n\r\nprocedure JclPCREFreeMem(P: Pointer); {$IFDEF PCRE_EXPORT_CDECL} cdecl; {$ENDIF PCRE_EXPORT_CDECL}\r\nbegin\r\n FreeMem(P);\r\nend;\r\n\r\nprocedure JclPCRE16FreeMem(P: Pointer); {$IFDEF PCRE_EXPORT_CDECL} cdecl; {$ENDIF PCRE_EXPORT_CDECL}\r\nbegin\r\n FreeMem(P);\r\nend;\r\n\r\n{$IFDEF PCRE_8}\r\nfunction JclPCRECallout(var callout_block: pcre_callout_block): Integer; {$IFDEF PCRE_EXPORT_CDECL} cdecl; {$ENDIF PCRE_EXPORT_CDECL}\r\nbegin\r\n Result := TJclAnsiRegEx(callout_block.callout_data).CalloutHandler(callout_block);\r\nend;\r\n{$ENDIF PCRE_8}\r\n\r\n{$IFDEF PCRE_16}\r\nfunction JclPCRE16Callout(var callout_block: pcre16_callout_block): Integer; {$IFDEF PCRE_EXPORT_CDECL} cdecl; {$ENDIF PCRE_EXPORT_CDECL}\r\nbegin\r\n Result := TJclWideRegEx(callout_block.callout_data).CalloutHandler(callout_block);\r\nend;\r\n{$ENDIF PCRE_16}\r\n\r\nfunction PCRECheck(Value: Integer; Wide: Boolean): Boolean;\r\nvar\r\n PErr: PResStringRec;\r\nbegin\r\n Result := Value >= 0;\r\n if Result then Exit;\r\n\r\n case Value of\r\n PCRE_ERROR_NOMATCH:\r\n PErr := @RsErrNoMatch;\r\n PCRE_ERROR_NULL:\r\n PErr := @RsErrNull;\r\n PCRE_ERROR_BADOPTION:\r\n PErr := @RsErrBadOption;\r\n PCRE_ERROR_BADMAGIC:\r\n PErr := @RsErrBadMagic;\r\n PCRE_ERROR_UNKNOWN_NODE:\r\n PErr := @RsErrUnknownNode;\r\n PCRE_ERROR_NOMEMORY:\r\n PErr := @RsErrNoMemory;\r\n PCRE_ERROR_NOSUBSTRING:\r\n PErr := @RsErrNoSubString;\r\n PCRE_ERROR_MATCHLIMIT:\r\n PErr := @RsErrMatchLimit;\r\n PCRE_ERROR_CALLOUT:\r\n PErr := @RsErrCallout;\r\n PCRE_ERROR_BADUTF8:\r\n if Wide then\r\n PErr := @RsErrBadUTF16\r\n else\r\n PErr := @RsErrBadUTF8;\r\n PCRE_ERROR_BADUTF8_OFFSET:\r\n if Wide then\r\n PErr := @RsErrBadUTF16Offset\r\n else\r\n PErr := @RsErrBadUTF8Offset;\r\n PCRE_ERROR_PARTIAL:\r\n PErr := @RsErrPartial;\r\n PCRE_ERROR_BADPARTIAL:\r\n PErr := @RsErrBadPartial;\r\n PCRE_ERROR_INTERNAL:\r\n PErr := @RsErrInternal;\r\n PCRE_ERROR_BADCOUNT:\r\n PErr := @RsErrBadCount;\r\n PCRE_ERROR_DFA_UITEM:\r\n PErr := @RsErrDfaUItem;\r\n PCRE_ERROR_DFA_UCOND:\r\n PErr := @RsErrDfaUCond;\r\n PCRE_ERROR_DFA_UMLIMIT:\r\n PErr := @RsErrDfaUMLimit;\r\n PCRE_ERROR_DFA_WSSIZE:\r\n PErr := @RsErrDfaWSSize;\r\n PCRE_ERROR_DFA_RECURSE:\r\n PErr := @RsErrDfaRecurse;\r\n PCRE_ERROR_RECURSIONLIMIT:\r\n PErr := @RsErrRecursionLimit;\r\n PCRE_ERROR_NULLWSLIMIT:\r\n PErr := @RsErrNullWsLimit;\r\n PCRE_ERROR_BADNEWLINE:\r\n PErr := @RsErrBadNewLine;\r\n {$IFNDEF PCRE_RTL}\r\n PCRE_ERROR_BADOFFSET:\r\n PErr := @RsErrBadOffset;\r\n PCRE_ERROR_SHORTUTF8:\r\n if Wide then\r\n PErr := @RsErrShortUTF16\r\n else\r\n PErr := @RsErrShortUTF8;\r\n PCRE_ERROR_RECURSELOOP:\r\n PErr := @RsErrRecurseLoop;\r\n PCRE_ERROR_JITSTACKLIMIT:\r\n PErr := @RsErrJITStackLimit;\r\n PCRE_ERROR_BADMODE:\r\n PErr := @RsErrBadMode;\r\n PCRE_ERROR_BADENDIANNESS:\r\n PErr := @RsErrBadEndianness;\r\n PCRE_ERROR_DFA_BADRESTART:\r\n PErr := @RsErrBadRestart;\r\n {$ENDIF ~PCRE_RTL}\r\n JCL_PCRE_ERROR_STUDYFAILED:\r\n PErr := @RsErrStudyFailed;\r\n JCL_PCRE_ERROR_CALLOUTERROR:\r\n PErr := @RsErrCalloutError;\r\n JCL_PCRE_ERROR_NOUTF8:\r\n if Wide then\r\n PErr := @RsErrNoUTF16Support\r\n else\r\n PErr := @RsErrNoUTF8Support;\r\n JCL_PCRE_ERROR_NOJIT:\r\n PErr := @RsErrNoJITSupport;\r\n else\r\n PErr := @RsErrUnknownError;\r\n end;\r\n\r\n raise EPCREError.CreateRes(PErr, Value);\r\nend;\r\n\r\n//=== { TJclRegEx } ===========================================================\r\n\r\ndestructor TJclRegExBase.Destroy;\r\nbegin\r\n if Assigned(FVector) then\r\n FreeMem(FVector);\r\n if Assigned(FChangedCaptures) then\r\n FChangedCaptures.Free;\r\n\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJclRegExBase.GetAPIOptions(RunTime, DFA: Boolean): Integer;\r\nconst\r\n {$IFDEF PCRE_RTL}\r\n PCRE_PARTIAL_HARD = $08000000;\r\n PCRE_NOTEMPTY_ATSTART = $10000000;\r\n PCRE_UCP = $20000000;\r\n {$ENDIF PCRE_RTL}\r\n { roIgnoreCase, roMultiLine, roDotAll, roExtended,\r\n roAnchored, roDollarEndOnly, roExtra, roNotBOL, roNotEOL, roUnGreedy,\r\n roNotEmpty, roUTF8, roNoAutoCapture, roNoUTF8Check, roAutoCallout,\r\n roPartial, roDfaShortest, roDfaRestart, roFirstLine, roDupNames,\r\n roNewLineCR, roNewLineLF, roNewLineCRLF, roNewLineAny, roBSRAnyCRLF,\r\n roBSRUnicode, roJavascriptCompat, roNoStartOptimize, roPartialHard,\r\n roNotEmptyAtStart, roUCP }\r\n cDesignOptions: array [TJclRegExOption] of Integer =\r\n (PCRE_CASELESS, PCRE_MULTILINE, PCRE_DOTALL, PCRE_EXTENDED, PCRE_ANCHORED,\r\n PCRE_DOLLAR_ENDONLY, PCRE_EXTRA, 0, 0, PCRE_UNGREEDY, 0, PCRE_UTF8,\r\n PCRE_NO_AUTO_CAPTURE, PCRE_NO_UTF8_CHECK, PCRE_AUTO_CALLOUT, 0, 0, 0,\r\n PCRE_FIRSTLINE, PCRE_DUPNAMES, PCRE_NEWLINE_CR, PCRE_NEWLINE_LF,\r\n PCRE_NEWLINE_CRLF, PCRE_NEWLINE_ANY, PCRE_BSR_ANYCRLF, PCRE_BSR_UNICODE,\r\n PCRE_JAVASCRIPT_COMPAT, PCRE_NO_START_OPTIMIZE, 0, 0, PCRE_UCP);\r\n cRunOptions: array [TJclRegExOption] of Integer =\r\n (0, 0, 0, 0, PCRE_ANCHORED, 0, 0, PCRE_NOTBOL, PCRE_NOTEOL,\r\n 0, PCRE_NOTEMPTY, 0, 0, PCRE_NO_UTF8_CHECK, 0, PCRE_PARTIAL, 0, 0,\r\n 0, 0, PCRE_NEWLINE_CR, PCRE_NEWLINE_LF, PCRE_NEWLINE_CRLF,\r\n PCRE_NEWLINE_ANY, PCRE_BSR_ANYCRLF, PCRE_BSR_UNICODE,\r\n 0, PCRE_NO_START_OPTIMIZE, PCRE_PARTIAL_HARD,\r\n PCRE_NOTEMPTY_ATSTART, 0);\r\n cDFARunOptions: array [TJclRegExOption] of Integer =\r\n (0, 0, 0, 0, PCRE_ANCHORED, 0, 0, PCRE_NOTBOL, PCRE_NOTEOL,\r\n 0, PCRE_NOTEMPTY, 0, 0, PCRE_NO_UTF8_CHECK, 0, PCRE_PARTIAL,\r\n PCRE_DFA_SHORTEST, PCRE_DFA_RESTART, 0, 0, PCRE_NEWLINE_CR,\r\n PCRE_NEWLINE_LF, PCRE_NEWLINE_CRLF, PCRE_NEWLINE_ANY, PCRE_BSR_ANYCRLF,\r\n PCRE_BSR_UNICODE, 0, PCRE_NO_START_OPTIMIZE, PCRE_PARTIAL_HARD,\r\n PCRE_NOTEMPTY_ATSTART, 0);\r\nvar\r\n I: TJclRegExOption;\r\nbegin\r\n Result := 0;\r\n if RunTime and DFA then\r\n begin\r\n for I := Low(TJclRegExOption) to High(TJclRegExOption) do\r\n if I in Options then\r\n Result := Result or cDFARunOptions[I];\r\n end\r\n else\r\n if RunTime then\r\n begin\r\n for I := Low(TJclRegExOption) to High(TJclRegExOption) do\r\n if I in Options then\r\n Result := Result or cRunOptions[I];\r\n end\r\n else\r\n begin\r\n for I := Low(TJclRegExOption) to High(TJclRegExOption) do\r\n if I in Options then\r\n Result := Result or cDesignOptions[I];\r\n end;\r\nend;\r\n\r\nfunction TJclRegExBase.GetResult: string;\r\nvar\r\n Index, CaptureIndex: Integer;\r\n Pos: Integer;\r\n Range: TJclCaptureRange;\r\nbegin\r\n if Assigned(FChangedCaptures) and (FChangedCaptures.Count > 0) then\r\n begin\r\n Pos := 1;\r\n Result := '';\r\n for Index := 0 to FChangedCaptures.Count - 1 do\r\n begin\r\n CaptureIndex := SizeInt(FChangedCaptures[Index]);\r\n Range := GetCaptureRange(CaptureIndex);\r\n\r\n Result := Result +\r\n Copy(FSubject, Pos, Range.FirstPos - Pos) +\r\n FResultValues[CaptureIndex];\r\n\r\n Pos := Range.LastPos + 1;\r\n end;\r\n if Pos <= Length(FSubject) then\r\n Result := Result + Copy(FSubject, Pos, Length(FSubject) - Pos + 1);\r\n end\r\n else\r\n Result := FSubject;\r\nend;\r\n\r\nprocedure TJclRegExBase.SetCapture(Index: Integer; const Value: string);\r\nbegin\r\n if (Index < 0) or (Index >= FCaptureCount) then\r\n PCRECheck(PCRE_ERROR_NOSUBSTRING, SupportsWideChar)\r\n else\r\n begin\r\n if (not Assigned(FChangedCaptures)) or (FChangedCaptures.Count = 0) then\r\n begin\r\n if not Assigned(FChangedCaptures) then\r\n FChangedCaptures := TList.Create;\r\n\r\n // Always resize to the max length to avoid repeated allocations.\r\n FChangedCaptures.Capacity := FCaptureCount;\r\n SetLength(FResultValues, FCaptureCount);\r\n end;\r\n\r\n if FChangedCaptures.IndexOf(Pointer(SizeInt(Index))) < 0 then\r\n FChangedCaptures.Add(Pointer(SizeInt(Index)));\r\n FResultValues[Index] := Value;\r\n end;\r\nend;\r\n\r\nfunction TJclRegExBase.SupportsWideChar: Boolean;\r\nbegin\r\n Result := False;\r\nend;\r\n\r\n{$IFDEF PCRE_8}\r\nprocedure InitializeLocaleSupport;\r\nbegin\r\n if not Assigned(GTables) then\r\n GTables := pcre_maketables;\r\nend;\r\n\r\nprocedure TerminateLocaleSupport;\r\nbegin\r\n if Assigned(GTables) then\r\n begin\r\n CallPCREFree(GTables);\r\n GTables := nil;\r\n end;\r\nend;\r\n{$ENDIF PCRE_8}\r\n\r\n{$IFDEF PCRE_16}\r\nprocedure InitializeLocaleSupport16;\r\nbegin\r\n if not Assigned(GTables16) then\r\n GTables16 := pcre16_maketables;\r\nend;\r\n\r\nprocedure TerminateLocaleSupport16;\r\nbegin\r\n if Assigned(GTables16) then\r\n begin\r\n CallPCRE16Free(GTables16);\r\n GTables16 := nil;\r\n end;\r\nend;\r\n{$ENDIF PCRE_16}\r\n\r\n{$IFDEF JCL_PCRE}\r\n// TODO: Better/specific error messages, show index when available.\r\nfunction StrReplaceRegEx(const Subject, Pattern: string; Args: array of const): string;\r\n\r\n function ArgToString(Index: Integer): string;\r\n begin\r\n // TODO: Any other type?\r\n case TVarRec(Args[Index]).VType of\r\n vtPChar:\r\n Result := string(AnsiString(TVarRec(Args[Index]).VPChar));\r\n vtPWideChar:\r\n Result := string(WideString(TVarRec(Args[Index]).VPWideChar));\r\n vtString:\r\n Result := string(TVarRec(Args[Index]).VString^);\r\n vtAnsiString:\r\n Result := string(AnsiString(TVarRec(Args[Index]).VAnsiString));\r\n vtWideString:\r\n Result := string(WideString(TVarRec(Args[Index]).VWideString));\r\n {$IFDEF SUPPORTS_UNICODE_STRING}\r\n vtUnicodeString:\r\n Result := string(UnicodeString(TVarRec(Args[Index]).VUnicodeString));\r\n {$ENDIF SUPPORTS_UNICODE_STRING}\r\n vtChar:\r\n Result := string(AnsiString(TVarRec(Args[Index]).VChar));\r\n vtWideChar:\r\n Result := string(WideString(TVarRec(Args[Index]).VWideChar));\r\n else\r\n raise EConvertError.Create(SInvalidFormat);\r\n end;\r\n end;\r\n\r\nvar\r\n Re: TJclRegExBase;\r\n Index, ArgIndex: Integer;\r\n Value: string;\r\nbegin\r\n if Odd(Length(Args)) then\r\n raise EConvertError.Create(SArgumentMissing)\r\n else\r\n begin\r\n Re := TJclRegEx.Create;\r\n try\r\n if Re.Compile(Pattern, False) and Re.Match(Subject) then\r\n begin\r\n for Index := 0 to Length(Args) div 2 - 1 do\r\n begin\r\n ArgIndex := Index * 2;\r\n Value := ArgToString(ArgIndex + 1);\r\n\r\n if TVarRec(Args[ArgIndex]).VType = vtInteger then\r\n Re.Captures[TVarRec(Args[ArgIndex]).VInteger] := Value\r\n else\r\n Re.NamedCaptures[ArgToString(ArgIndex)] := Value;\r\n end;\r\n\r\n Result := Re.Result;\r\n end\r\n else\r\n raise EConvertError.Create(SInvalidFormat);\r\n finally\r\n Re.Free;\r\n end;\r\n end;\r\nend;\r\n{$ENDIF JCL_PCRE}\r\n\r\n//=== { EPCREError } =========================================================\r\n\r\nconstructor EPCREError.CreateRes(ResStringRec: PResStringRec; ErrorCode: Integer);\r\nbegin\r\n FErrorCode := ErrorCode;\r\n inherited CreateRes(ResStringRec);\r\nend;\r\n\r\nprocedure LibNotLoadedHandler; {$IFDEF PCRE_EXPORT_CDECL} cdecl; {$ENDIF PCRE_EXPORT_CDECL}\r\nbegin\r\n raise EPCREError.CreateRes(@RsErrLibNotLoaded, 0);\r\nend;\r\n\r\n{$IFDEF PCRE_8}\r\n\r\n//=== { TJclAnsiRegEx } ======================================================\r\n\r\ndestructor TJclAnsiRegEx.Destroy;\r\nbegin\r\n if Assigned(FCode) then\r\n CallPCREFree(FCode);\r\n if Assigned(FExtra) then\r\n {$IFDEF PCRE_RTL}\r\n CallPCREFree(FExtra);\r\n {$ELSE ~PCRE_RTL}\r\n pcre_free_study(FExtra);\r\n {$ENDIF ~PCRE_RTL}\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJclAnsiRegEx.CalloutHandler(var CalloutBlock: pcre_callout_block): Integer;\r\nbegin\r\n try\r\n Result := JCL_PCRE_CALLOUT_NOERROR;\r\n if Assigned(FOnCallout) then\r\n begin\r\n with CalloutBlock do\r\n begin\r\n FCaptureCount := capture_top;\r\n FOnCallout(Self, callout_number, start_match + 1, current_position + 1,\r\n capture_last, pattern_position + 1, next_item_length, Result);\r\n end;\r\n end;\r\n except\r\n on E: Exception do\r\n begin\r\n FErrorMessage := E.Message;\r\n Result := JCL_PCRE_ERROR_CALLOUTERROR;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJclAnsiRegEx.Compile(const Pattern: string; Study, UserLocale, JITCompile: Boolean): Boolean;\r\nvar\r\n ErrMsgPtr: PAnsiChar;\r\n Tables: PAnsiChar;\r\n StudyOptions: Integer;\r\n {$IFNDEF PCRE_RTL}\r\n ConfigJIT: Integer;\r\n {$ENDIF ~PCRE_RTL}\r\nbegin\r\n if UserLocale then\r\n begin\r\n InitializeLocaleSupport;\r\n Tables := GTables;\r\n end\r\n else\r\n Tables := nil;\r\n\r\n FPattern := Pattern;\r\n if FPattern = '' then\r\n PCRECheck(PCRE_ERROR_NULL, SupportsWideChar);\r\n\r\n if Assigned(FCode) then\r\n begin\r\n CallPCREFree(FCode);\r\n FCode := nil;\r\n end;\r\n FCode := pcre_compile2(PAnsiChar(EncodeAnsiString(FPattern, roUTF8 in Options)), GetAPIOptions(False, DfaMode),\r\n @FErrorCode, @ErrMsgPtr, @FErrorOffset, Tables);\r\n Inc(FErrorOffset);\r\n FErrorMessage := string(AnsiString(ErrMsgPtr));\r\n Result := Assigned(FCode);\r\n if Result then\r\n begin\r\n if Study then\r\n begin\r\n {$IFDEF PCRE_RTL}\r\n if Assigned(FExtra) then\r\n CallPCREFree(FExtra);\r\n if JITCompile then\r\n raise EPCREError.CreateRes(@RsErrNoJITSupport, 0);\r\n StudyOptions := 0;\r\n {$ELSE ~PCRE_RTL}\r\n if Assigned(FExtra) then\r\n pcre_free_study(FExtra);\r\n if JITCompile then\r\n begin\r\n PCRECheck(pcre_config(PCRE_CONFIG_JIT, @ConfigJIT), SupportsWideChar);\r\n if ConfigJIT = 0 then\r\n raise EPCREError.CreateRes(@RsErrNoJITSupport, 0);\r\n StudyOptions := PCRE_STUDY_JIT_COMPILE;\r\n end\r\n else\r\n StudyOptions := 0;\r\n {$ENDIF ~PCRE_RTL}\r\n FExtra := pcre_study(FCode, StudyOptions, @ErrMsgPtr);\r\n Result := Assigned(FExtra) or (not Assigned(ErrMsgPtr));\r\n if not Result then\r\n begin\r\n FErrorCode := JCL_PCRE_ERROR_STUDYFAILED;\r\n FErrorMessage := string(AnsiString(ErrMsgPtr));\r\n end;\r\n end;\r\n\r\n if FDfaMode then\r\n FVectorSize := FCaptureCount\r\n else\r\n begin\r\n PCRECheck(pcre_fullinfo(FCode, FExtra, PCRE_INFO_CAPTURECOUNT, @FCaptureCount), SupportsWideChar);\r\n FVectorSize := (FCaptureCount + 1) * 3;\r\n end;\r\n ReAllocMem(FVector, FVectorSize * SizeOf(FVector[0]));\r\n end;\r\nend;\r\n\r\nfunction TJclAnsiRegEx.GetAPIOptions(RunTime, DFA: Boolean): Integer;\r\nvar\r\n ConfigUTF8: Integer;\r\nbegin\r\n PCRECheck(pcre_config(PCRE_CONFIG_UTF8, @ConfigUTF8), SupportsWideChar);\r\n if (roUTF8 in Options) and (ConfigUTF8 = 0) then\r\n PCRECheck(JCL_PCRE_ERROR_NOUTF8, SupportsWideChar);\r\n\r\n Result := inherited GetAPIOptions(RunTime, DFA);\r\nend;\r\n\r\nfunction TJclAnsiRegEx.GetCapture(Index: Integer): string;\r\nvar\r\n FromPos, ToPos: SizeInt;\r\nbegin\r\n if (Index < 0) or (Index >= FCaptureCount) then\r\n PCRECheck(PCRE_ERROR_NOSUBSTRING, SupportsWideChar)\r\n else\r\n begin\r\n if FViewChanges and (FChangedCaptures.IndexOf(Pointer(SizeInt(Index))) >= 0) then\r\n begin\r\n Result := FResultValues[Index];\r\n Exit;\r\n end;\r\n\r\n Index := Index * 2;\r\n FromPos := TranslateAnsiIndex(FSubject, roUTF8 in Options, FVector^[Index] + 1);\r\n ToPos := TranslateAnsiIndex(FSubject, roUTF8 in Options, FVector^[Index + 1] + 1) - 1;\r\n Result := Copy(FSubject, FromPos, ToPos - FromPos + 1);\r\n end;\r\nend;\r\n\r\nfunction TJclAnsiRegEx.GetCaptureNameCount: Integer;\r\nbegin\r\n PCRECheck(pcre_fullinfo(FCode, FExtra, PCRE_INFO_NAMECOUNT, @Result), SupportsWideChar);\r\nend;\r\n\r\nfunction TJclAnsiRegEx.GetCaptureName(Index: Integer): string;\r\nvar\r\n NameTable: PAnsiChar;\r\n EntrySize: Integer;\r\nbegin\r\n PCRECheck(pcre_fullinfo(FCode, FExtra, PCRE_INFO_NAMETABLE, @NameTable), SupportsWideChar);\r\n PCRECheck(pcre_fullinfo(FCode, FExtra, PCRE_INFO_NAMEENTRYSIZE, @EntrySize), SupportsWideChar);\r\n\r\n NameTable := NameTable + EntrySize * Index + 2;\r\n Result := DecodeAnsiString(AnsiString(NameTable), roUTF8 in Options);\r\nend;\r\n\r\nfunction TJclAnsiRegEx.GetCaptureRange(Index: Integer): TJclCaptureRange;\r\nbegin\r\n if (Index < 0) or (Index >= FCaptureCount) then\r\n PCRECheck(PCRE_ERROR_NOSUBSTRING, SupportsWideChar)\r\n else\r\n begin\r\n Index := Index * 2;\r\n Result.FirstPos := TranslateAnsiIndex(FSubject, roUTF8 in Options, FVector^[Index] + 1);\r\n Result.LastPos := TranslateAnsiIndex(FSubject, roUTF8 in Options, FVector^[Index + 1] + 1) - 1;\r\n end;\r\nend;\r\n\r\nfunction TJclAnsiRegEx.GetNamedCapture(const Name: string): string;\r\nvar\r\n Index: Integer;\r\nbegin\r\n Index := pcre_get_stringnumber(FCode, PAnsiChar(EncodeAnsiString(Name, roUTF8 in Options)));\r\n PCRECheck(Index, SupportsWideChar);\r\n\r\n Result := GetCapture(Index);\r\nend;\r\n\r\nfunction TJclAnsiRegEx.IndexOfName(const Name: string): Integer;\r\nbegin\r\n Result := pcre_get_stringnumber(FCode, PAnsiChar(EncodeAnsiString(Name, roUTF8 in Options)));\r\nend;\r\n\r\nfunction TJclAnsiRegEx.IsNameValid(const Name: string): Boolean;\r\nbegin\r\n Result := pcre_get_stringnumber(FCode, PAnsiChar(EncodeAnsiString(Name, roUTF8 in Options))) >= 0;\r\nend;\r\n\r\nfunction TJclAnsiRegEx.Match(const Subject: string; StartOffset: Cardinal): Boolean;\r\nvar\r\n LocalExtra: real_pcre_extra;\r\n Extra: Pointer;\r\n WorkSpace: array [0 .. 19] of Integer;\r\n ExecRslt: Integer;\r\n EncodedSubject: AnsiString;\r\nbegin\r\n if Assigned(FOnCallout) then\r\n begin\r\n if Assigned(FExtra) then\r\n begin\r\n LocalExtra.flags := PCRE_EXTRA_STUDY_DATA or PCRE_EXTRA_CALLOUT_DATA;\r\n LocalExtra.study_data := FExtra;\r\n end\r\n else\r\n LocalExtra.flags := PCRE_EXTRA_CALLOUT_DATA;\r\n LocalExtra.callout_data := Self;\r\n Extra := @LocalExtra;\r\n SetPCRECalloutCallback(JclPCRECallout);\r\n end\r\n else\r\n begin\r\n Extra := FExtra;\r\n SetPCRECalloutCallback(nil);\r\n end;\r\n\r\n FSubject := Subject;\r\n if Assigned(FChangedCaptures) then\r\n FChangedCaptures.Clear;\r\n EncodedSubject := EncodeAnsiString(FSubject, roUTF8 in Options);\r\n\r\n // convert index\r\n if roUTF8 in Options then\r\n StartOffset := Length(EncodeAnsiString(Copy(FSubject, 1, StartOffset - 1), True)) + 1;\r\n\r\n if FDfaMode then\r\n begin\r\n ExecRslt := pcre_dfa_exec(FCode, Extra, PAnsiChar(EncodedSubject), Length(EncodedSubject),\r\n StartOffset - 1, GetAPIOptions(True, DfaMode), PInteger(FVector), FVectorSize, @Workspace, 20);\r\n end\r\n else\r\n begin\r\n ExecRslt := pcre_exec(FCode, Extra, PAnsiChar(EncodedSubject), Length(EncodedSubject),\r\n StartOffset - 1, GetAPIOptions(True, DfaMode), PInteger(FVector), FVectorSize);\r\n end;\r\n Result := ExecRslt >= 0;\r\n if Result then\r\n begin\r\n FCaptureCount := ExecRslt;\r\n FErrorCode := 0;\r\n end\r\n else\r\n begin\r\n FErrorCode := ExecRslt;\r\n if FErrorCode <> PCRE_ERROR_NOMATCH then\r\n PCRECheck(FErrorCode, SupportsWideChar);\r\n end;\r\nend;\r\n\r\nprocedure TJclAnsiRegEx.SetNamedCapture(const Name, Value: string);\r\nvar\r\n Index: Integer;\r\nbegin\r\n Index := pcre_get_stringnumber(FCode, PAnsiChar(EncodeAnsiString(Name, roUTF8 in Options)));\r\n PCRECheck(Index, SupportsWideChar);\r\n\r\n SetCapture(Index, Value);\r\nend;\r\n\r\n{$ENDIF PCRE_8}\r\n\r\n{$IFDEF PCRE_16}\r\n\r\n//=== { TJclWideRegEx } ======================================================\r\n\r\ndestructor TJclWideRegEx.Destroy;\r\nbegin\r\n if Assigned(FCode) then\r\n CallPCRE16Free(FCode);\r\n if Assigned(FExtra) then\r\n {$IFDEF PCRE_RTL}\r\n CallPCRE16Free(FExtra);\r\n {$ELSE ~PCRE_RTL}\r\n pcre16_free_study(FExtra);\r\n {$ENDIF ~PCRE_RTL}\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJclWideRegEx.CalloutHandler(var CalloutBlock: pcre16_callout_block): Integer;\r\nbegin\r\n try\r\n Result := JCL_PCRE_CALLOUT_NOERROR;\r\n if Assigned(FOnCallout) then\r\n begin\r\n with CalloutBlock do\r\n begin\r\n FCaptureCount := capture_top;\r\n FOnCallout(Self, callout_number, start_match + 1, current_position + 1,\r\n capture_last, pattern_position + 1, next_item_length, Result);\r\n end;\r\n end;\r\n except\r\n on E: Exception do\r\n begin\r\n FErrorMessage := E.Message;\r\n Result := JCL_PCRE_ERROR_CALLOUTERROR;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJclWideRegEx.Compile(const Pattern: string; Study, UserLocale, JITCompile: Boolean): Boolean;\r\nvar\r\n ErrMsgPtr: PAnsiChar;\r\n Tables: PAnsiChar;\r\n StudyOptions: Integer;\r\n {$IFNDEF PCRE_RTL}\r\n ConfigJIT: Integer;\r\n {$ENDIF ~PCRE_RTL}\r\nbegin\r\n if UserLocale then\r\n begin\r\n InitializeLocaleSupport16;\r\n Tables := GTables16;\r\n end\r\n else\r\n Tables := nil;\r\n\r\n FPattern := Pattern;\r\n if FPattern = '' then\r\n PCRECheck(PCRE_ERROR_NULL, SupportsWideChar);\r\n\r\n if Assigned(FCode) then\r\n begin\r\n CallPCRE16Free(FCode);\r\n FCode := nil;\r\n end;\r\n FCode := pcre16_compile2(PWideChar(EncodeWideString(FPattern, roUTF16 in Options)), GetAPIOptions(False, DfaMode),\r\n @FErrorCode, @ErrMsgPtr, @FErrorOffset, Tables);\r\n Inc(FErrorOffset);\r\n FErrorMessage := string(AnsiString(ErrMsgPtr));\r\n Result := Assigned(FCode);\r\n if Result then\r\n begin\r\n if Study then\r\n begin\r\n {$IFDEF PCRE_RTL}\r\n if Assigned(FExtra) then\r\n CallPCRE16Free(FExtra);\r\n if JITCompile then\r\n raise EPCREError.CreateRes(@RsErrNoJITSupport, 0);\r\n StudyOptions := 0;\r\n {$ELSE ~PCRE_RTL}\r\n if Assigned(FExtra) then\r\n pcre16_free_study(FExtra);\r\n if JITCompile then\r\n begin\r\n PCRECheck(pcre16_config(PCRE_CONFIG_JIT, @ConfigJIT), SupportsWideChar);\r\n if ConfigJIT = 0 then\r\n raise EPCREError.CreateRes(@RsErrNoJITSupport, 0);\r\n StudyOptions := PCRE_STUDY_JIT_COMPILE;\r\n end\r\n else\r\n StudyOptions := 0;\r\n {$ENDIF ~PCRE_RTL}\r\n FExtra := pcre16_study(FCode, StudyOptions, @ErrMsgPtr);\r\n Result := Assigned(FExtra) or (not Assigned(ErrMsgPtr));\r\n if not Result then\r\n begin\r\n FErrorCode := JCL_PCRE_ERROR_STUDYFAILED;\r\n FErrorMessage := string(AnsiString(ErrMsgPtr));\r\n end;\r\n end;\r\n\r\n if FDfaMode then\r\n FVectorSize := FCaptureCount\r\n else\r\n begin\r\n PCRECheck(pcre16_fullinfo(FCode, FExtra, PCRE_INFO_CAPTURECOUNT, @FCaptureCount), SupportsWideChar);\r\n FVectorSize := (FCaptureCount + 1) * 3;\r\n end;\r\n ReAllocMem(FVector, FVectorSize * SizeOf(FVector[0]));\r\n end;\r\nend;\r\n\r\nfunction TJclWideRegEx.GetAPIOptions(RunTime, DFA: Boolean): Integer;\r\nvar\r\n ConfigUTF16: Integer;\r\nbegin\r\n PCRECheck(pcre16_config(PCRE_CONFIG_UTF16, @ConfigUTF16), SupportsWideChar);\r\n if (roUTF16 in Options) and (ConfigUTF16 = 0) then\r\n PCRECheck(JCL_PCRE_ERROR_NOUTF16, SupportsWideChar);\r\n\r\n Result := inherited GetAPIOptions(RunTime, DFA);\r\nend;\r\n\r\nfunction TJclWideRegEx.GetCapture(Index: Integer): string;\r\nvar\r\n FromPos, ToPos: SizeInt;\r\nbegin\r\n if (Index < 0) or (Index >= FCaptureCount) then\r\n PCRECheck(PCRE_ERROR_NOSUBSTRING, SupportsWideChar)\r\n else\r\n begin\r\n if FViewChanges and (FChangedCaptures.IndexOf(Pointer(SizeInt(Index))) >= 0) then\r\n begin\r\n Result := FResultValues[Index];\r\n Exit;\r\n end;\r\n\r\n Index := Index * 2;\r\n FromPos := TranslateWideIndex(FSubject, roUTF16 in Options, FVector^[Index] + 1);\r\n ToPos := TranslateWideIndex(FSubject, roUTF16 in Options, FVector^[Index + 1] + 1) - 1;\r\n Result := Copy(FSubject, FromPos, ToPos - FromPos + 1);\r\n end;\r\nend;\r\n\r\nfunction TJclWideRegEx.GetCaptureName(Index: Integer): string;\r\nvar\r\n NameTable: PWideChar;\r\n EntrySize: Integer;\r\nbegin\r\n PCRECheck(pcre16_fullinfo(FCode, FExtra, PCRE_INFO_NAMETABLE, @NameTable), SupportsWideChar);\r\n PCRECheck(pcre16_fullinfo(FCode, FExtra, PCRE_INFO_NAMEENTRYSIZE, @EntrySize), SupportsWideChar);\r\n\r\n NameTable := NameTable + EntrySize * Index + 2;\r\n Result := DecodeWideString(WideString(NameTable), roUTF16 in Options);\r\nend;\r\n\r\nfunction TJclWideRegEx.GetCaptureNameCount: Integer;\r\nbegin\r\n PCRECheck(pcre16_fullinfo(FCode, FExtra, PCRE_INFO_NAMECOUNT, @Result), SupportsWideChar);\r\nend;\r\n\r\nfunction TJclWideRegEx.GetCaptureRange(Index: Integer): TJclCaptureRange;\r\nbegin\r\n if (Index < 0) or (Index >= FCaptureCount) then\r\n PCRECheck(PCRE_ERROR_NOSUBSTRING, SupportsWideChar)\r\n else\r\n begin\r\n Index := Index * 2;\r\n Result.FirstPos := TranslateWideIndex(FSubject, roUTF16 in Options, FVector^[Index] + 1);\r\n Result.LastPos := TranslateWideIndex(FSubject, roUTF16 in Options, FVector^[Index + 1] + 1) - 1;\r\n end;\r\nend;\r\n\r\nfunction TJclWideRegEx.GetNamedCapture(const Name: string): string;\r\nvar\r\n Index: Integer;\r\nbegin\r\n Index := pcre16_get_stringnumber(FCode, PWideChar(EncodeWideString(Name, roUTF16 in Options)));\r\n PCRECheck(Index, SupportsWideChar);\r\n\r\n Result := GetCapture(Index);\r\nend;\r\n\r\nfunction TJclWideRegEx.IndexOfName(const Name: string): Integer;\r\nbegin\r\n Result := pcre16_get_stringnumber(FCode, PWideChar(EncodeWideString(Name, roUTF16 in Options)));\r\nend;\r\n\r\nfunction TJclWideRegEx.IsNameValid(const Name: string): Boolean;\r\nbegin\r\n Result := pcre16_get_stringnumber(FCode, PWideChar(EncodeWideString(Name, roUTF16 in Options))) >= 0;\r\nend;\r\n\r\nfunction TJclWideRegEx.Match(const Subject: string; StartOffset: Cardinal): Boolean;\r\nvar\r\n LocalExtra: real_pcre16_extra;\r\n Extra: Pointer;\r\n WorkSpace: array [0 .. 19] of Integer;\r\n ExecRslt: Integer;\r\n EncodedSubject: WideString;\r\nbegin\r\n if Assigned(FOnCallout) then\r\n begin\r\n if Assigned(FExtra) then\r\n begin\r\n LocalExtra.flags := PCRE_EXTRA_STUDY_DATA or PCRE_EXTRA_CALLOUT_DATA;\r\n LocalExtra.study_data := FExtra;\r\n end\r\n else\r\n LocalExtra.flags := PCRE_EXTRA_CALLOUT_DATA;\r\n LocalExtra.callout_data := Self;\r\n Extra := @LocalExtra;\r\n SetPCRE16CalloutCallback(JclPCRE16Callout);\r\n end\r\n else\r\n begin\r\n Extra := FExtra;\r\n SetPCRE16CalloutCallback(nil);\r\n end;\r\n\r\n FSubject := Subject;\r\n if Assigned(FChangedCaptures) then\r\n FChangedCaptures.Clear;\r\n EncodedSubject := EncodeWideString(FSubject, roUTF16 in Options);\r\n\r\n // convert index\r\n if roUTF16 in Options then\r\n StartOffset := Length(EncodeWideString(Copy(FSubject, 1, StartOffset - 1), True)) + 1;\r\n\r\n if FDfaMode then\r\n begin\r\n ExecRslt := pcre16_dfa_exec(FCode, Extra, PWideChar(EncodedSubject), Length(EncodedSubject),\r\n StartOffset - 1, GetAPIOptions(True, DfaMode), PInteger(FVector), FVectorSize, @Workspace, 20);\r\n end\r\n else\r\n begin\r\n ExecRslt := pcre16_exec(FCode, Extra, PWideChar(EncodedSubject), Length(EncodedSubject),\r\n StartOffset - 1, GetAPIOptions(True, DfaMode), PInteger(FVector), FVectorSize);\r\n end;\r\n Result := ExecRslt >= 0;\r\n if Result then\r\n begin\r\n FCaptureCount := ExecRslt;\r\n FErrorCode := 0;\r\n end\r\n else\r\n begin\r\n FErrorCode := ExecRslt;\r\n if FErrorCode <> PCRE_ERROR_NOMATCH then\r\n PCRECheck(FErrorCode, SupportsWideChar);\r\n end;\r\nend;\r\n\r\nprocedure TJclWideRegEx.SetNamedCapture(const Name, Value: string);\r\nvar\r\n Index: Integer;\r\nbegin\r\n Index := pcre16_get_stringnumber(FCode, PWideChar(EncodeWideString(Name, roUTF16 in Options)));\r\n PCRECheck(Index, SupportsWideChar);\r\n\r\n SetCapture(Index, Value);\r\nend;\r\n\r\nfunction TJclWideRegEx.SupportsWideChar: Boolean;\r\nbegin\r\n Result := True;\r\nend;\r\n{$ENDIF PCRE_16}\r\n\r\ninitialization\r\n {$IFNDEF PCRE_RTL}\r\n pcre.LibNotLoadedHandler := LibNotLoadedHandler;\r\n {$ENDIF ~PCRE_RTL}\r\n if LoadPCRE then\r\n begin\r\n {$IFDEF PCRE_8}\r\n SetPCREMallocCallback(JclPCREGetMem);\r\n SetPCREFreeCallback(JclPCREFreeMem);\r\n {$ENDIF PCRE_8}\r\n {$IFDEF PCRE_16}\r\n SetPCRE16MallocCallback(JclPCRE16GetMem);\r\n SetPCRE16FreeCallback(JclPCRE16FreeMem);\r\n {$ENDIF PCRE_16}\r\n end;\r\n {$IFDEF UNITVERSIONING}\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n {$ENDIF UNITVERSIONING}\r\n\r\nfinalization\r\n {$IFDEF PCRE_8}\r\n TerminateLocaleSupport;\r\n {$ENDIF PCRE_8}\r\n {$IFDEF PCRE_16}\r\n TerminateLocaleSupport16;\r\n {$ENDIF PCRE_16}\r\n {$IFDEF UNITVERSIONING}\r\n UnregisterUnitVersion(HInstance);\r\n {$ENDIF UNITVERSIONING}\r\n UnloadPCRE;\r\n\r\nend.\r\n\r\n" }, { "path": "External/Jedi/Jcl/source/common/JclPreProcessorAlgorithmsTemplates.pas", "content": "{**************************************************************************************************}\r\n{ }\r\n{ Project JEDI Code Library (JCL) }\r\n{ }\r\n{ The contents of this file are subject to the Mozilla Public License Version 1.1 (the \"License\"); }\r\n{ you may not use this file except in compliance with the License. You may obtain a copy of the }\r\n{ License at http://www.mozilla.org/MPL/ }\r\n{ }\r\n{ Software distributed under the License is distributed on an \"AS IS\" basis, WITHOUT WARRANTY OF }\r\n{ ANY KIND, either express or implied. See the License for the specific language governing rights }\r\n{ and limitations under the License. }\r\n{ }\r\n{ The Original Code is JclAlgorithmsTemplates.pas. }\r\n{ }\r\n{ The Initial Developer of the Original Code is Florent Ouchet }\r\n{ }\r\n{ Portions created by Florent Ouchet are Copyright (C) of Florent Ouchet. All rights reserved. }\r\n{ }\r\n{ Contributors: }\r\n{ }\r\n{**************************************************************************************************}\r\n{ }\r\n{ Last modified: $Date:: 2012-02-23 21:46:07 +0100 (jeu. 23 févr. 2012) $ }\r\n{ Revision: $Rev:: 3740 $ }\r\n{ Author: $Author:: outchy $ }\r\n{ }\r\n{**************************************************************************************************}\r\n\r\nunit JclPreProcessorAlgorithmsTemplates;\r\n\r\ninterface\r\n\r\n{$I jcl.inc}\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n JclPreProcessorContainerTypes,\r\n JclPreProcessorContainerTemplates,\r\n JclPreProcessorContainer1DTemplates;\r\n\r\ntype\r\n TJclAlgorithmsIntParams = class(TJclContainerInterfaceParams)\r\n protected\r\n // function CodeUnit: string; override;\r\n end;\r\n\r\n TJclAlgorithmsIntProcParams = class(TJclAlgorithmsIntParams)\r\n protected\r\n FOverload: string;\r\n public\r\n property Overload: string read FOverload write FOverload;\r\n end;\r\n\r\n TJclAlgorithmsImpProcParams = class(TJclContainerImplementationParams)\r\n protected\r\n // function CodeUnit: string; override;\r\n end;\r\n\r\n (* MOVEARRAYINT(MOVEARRAYPROCEDURENAME, DYNARRAYTYPENAME, OVERLOAD) *)\r\n TJclMoveArrayIntParams = class(TJclAlgorithmsIntProcParams)\r\n published\r\n property Overload;\r\n property MoveArrayProcedureName: string index taMoveArrayProcedureName read GetTypeAttribute write SetTypeAttribute stored IsTypeAttributeStored;\r\n property DynArrayTypeName: string index taDynArrayTypeName read GetTypeAttribute write SetTypeAttribute stored False;\r\n end;\r\n\r\n (* MOVEARRAYIMP(MOVEARRAYPROCEDURENAME, DYNARRAYTYPENAME, DEFAULTVALUE) *)\r\n TJclMoveArrayImpParams = class(TJclAlgorithmsImpProcParams)\r\n published\r\n property MoveArrayProcedureName: string index taMoveArrayProcedureName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property DynArrayTypeName: string index taDynArrayTypeName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property DefaultValue: string index taDefaultValue read GetTypeAttribute write SetTypeAttribute stored False;\r\n end;\r\n\r\n (* ITERATEINT(ITERATEPROCEDURENAME, ITRINTERFACENAME, ITERATEPROCEDURETYPENAME, OVERLOAD) *)\r\n TJclIterateIntParams = class(TJclAlgorithmsIntProcParams)\r\n published\r\n property Overload;\r\n property IterateProcedureName: string index taIterateProcedureName read GetTypeAttribute write SetTypeAttribute stored IsTypeAttributeStored;\r\n property ItrInterfaceName: string index taIteratorInterfaceName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property IterateProcedureTypeName: string index taIterateProcedureTypeName read GetTypeAttribute write SetTypeAttribute stored False;\r\n end;\r\n\r\n (* ITERATEIMP(ITERATEPROCEDURENAME, ITRINTERFACENAME, ITERATEPROCEDURETYPENAME) *)\r\n TJclIterateImpParams = class(TJclAlgorithmsImpProcParams)\r\n published\r\n property IterateProcedureName: string index taIterateProcedureName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property ItrInterfaceName: string index taIteratorInterfaceName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property IterateProcedureTypeName: string index taIterateProcedureTypeName read GetTypeAttribute write SetTypeAttribute stored False;\r\n end;\r\n\r\n (* APPLYINT(APPLYPROCEDURENAME, ITRINTERFACENAME, APPLYFUNCTIONTYPENAME, OVERLOAD) *)\r\n TJclApplyIntParams = class(TJclAlgorithmsIntProcParams)\r\n published\r\n property Overload;\r\n property ApplyProcedureName: string index taApplyProcedureName read GetTypeAttribute write SetTypeAttribute stored IsTypeAttributeStored;\r\n property ItrInterfaceName: string index taIteratorInterfaceName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property ApplyFunctionTypeName: string index taApplyFunctionTypeName read GetTypeAttribute write SetTypeAttribute stored False;\r\n end;\r\n\r\n (* APPLYIMP(APPLYPROCEDURENAME, ITRINTERFACENAME, APPLYFUNCTIONNAME, SETTERPROCEDURENAME) *)\r\n TJclApplyImpParams = class(TJclAlgorithmsImpProcParams)\r\n published\r\n property ApplyProcedureName: string index taApplyProcedureName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property ItrInterfaceName: string index taIteratorInterfaceName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property ApplyFunctionTypeName: string index taApplyFunctionTypeName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property SetterProcedureName: string index taSetterProcedureName read GetTypeAttribute write SetTypeAttribute stored False;\r\n end;\r\n\r\n (* SIMPLECOMPAREINT(SIMPLECOMPAREFUNCTIONNAME, CONSTKEYWORD, TYPENAME) *)\r\n TJclSimpleCompareIntParams = class(TJclAlgorithmsIntParams)\r\n published\r\n property SimpleCompareFunctionName: string index taSimpleCompareFunctionName read GetTypeAttribute write SetTypeAttribute stored IsTypeAttributeStored;\r\n property ConstKeyword: string index taConstKeyword read GetTypeAttribute write SetTypeAttribute stored False;\r\n property TypeName: string index taTypeName read GetTypeAttribute write SetTypeAttribute stored False;\r\n end;\r\n\r\n (* SIMPLEEQUALITYCOMPAREINT(SIMPLEEQUALITYCOMPAREFUNCTIONNAME, CONSTKEYWORD, TYPENAME) *)\r\n TJclSimpleEqualityCompareIntParams = class(TJclAlgorithmsIntParams)\r\n published\r\n property SimpleEqualityCompareFunctionName: string index taSimpleEqualityCompareFunctionName read GetTypeAttribute write SetTypeAttribute stored IsTypeAttributeStored;\r\n property ConstKeyword: string index taConstKeyword read GetTypeAttribute write SetTypeAttribute stored False;\r\n property TypeName: string index taTypeName read GetTypeAttribute write SetTypeAttribute stored False;\r\n end;\r\n\r\n (* SIMPLEHASHCONVERTINT(SIMPLEHASHCONVERTFUNCTIONNAME, CONSTKEYWORD, PARAMETERNAME, TYPENAME) *)\r\n TJclSimpleHashConvertIntParams = class(TJclAlgorithmsIntParams)\r\n published\r\n property SimpleHashConvertFunctionName: string index taSimpleHashConvertFunctionName read GetTypeAttribute write SetTypeAttribute stored IsTypeAttributeStored;\r\n property ConstKeyword: string index taConstKeyword read GetTypeAttribute write SetTypeAttribute stored False;\r\n property ParameterName: string index taParameterName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property TypeName: string index taTypeName read GetTypeAttribute write SetTypeAttribute stored False;\r\n end;\r\n\r\n (* FINDINT(FINDFUNCTIONNAME, ITRINTERFACENAME, CONSTKEYWORD, PARAMETERNAME, TYPENAME, COMPAREFUNCTIONTYPENAME, OVERLOAD) *)\r\n TJclFindIntParams = class(TJclAlgorithmsIntProcParams)\r\n published\r\n property FindFunctionName: string index taFindFunctionName read GetTypeAttribute write SetTypeAttribute stored IsTypeAttributeStored;\r\n property ItrInterfaceName: string index taIteratorInterfaceName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property ConstKeyword: string index taConstKeyword read GetTypeAttribute write SetTypeAttribute stored False;\r\n property ParameterName: string index taParameterName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property TypeName: string index taTypeName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property CompareFunctionTypeName: string index taCompareFunctionTypeName read GetTypeAttribute write SetTypeAttribute stored False;\r\n end;\r\n\r\n (* FINDIMP(FINDFUNCTIONNAME, ITRINTERFACENAME, CONSTKEYWORD, PARAMETERNAME, TYPENAME, COMPAREFUNCTIONTYPENAME) *)\r\n TJclFindImpParams = class(TJclAlgorithmsImpProcParams)\r\n published\r\n property FindFunctionName: string index taFindFunctionName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property ItrInterfaceName: string index taIteratorInterfaceName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property ConstKeyword: string index taConstKeyword read GetTypeAttribute write SetTypeAttribute stored False;\r\n property ParameterName: string index taParameterName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property TypeName: string index taTypeName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property CompareFunctionTypeName: string index taCompareFunctionTypeName read GetTypeAttribute write SetTypeAttribute stored False;\r\n end;\r\n\r\n (* FINDEQINT(FINDFUNCTIONNAME,ITRINTERFACENAME, CONSTKEYWORD, PARAMETERNAME, TYPENAME, CALLBACKTYPE, OVERLOAD) *)\r\n TJclFindEqIntParams = class(TJclAlgorithmsIntProcParams)\r\n published\r\n property FindFunctionName: string index taFindFunctionName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property ItrInterfaceName: string index taIteratorInterfaceName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property ConstKeyword: string index taConstKeyword read GetTypeAttribute write SetTypeAttribute stored False;\r\n property ParameterName: string index taParameterName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property TypeName: string index taTypeName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property EqualityCompareFunctionTypeName: string index taEqualityCompareFunctionTypeName read GetTypeAttribute write SetTypeAttribute stored False;\r\n end;\r\n\r\n (* FINDEQIMP(FINDFUNCTIONNAME, ITRINTERFACENAME, CONSTKEYWORD, PARAMETERNAME, TYPENAME, EQUALITYCOMPAREFUNCTIONTYPENAME) *)\r\n TJclFindEqImpParams = class(TJclAlgorithmsImpProcParams)\r\n published\r\n property FindFunctionName: string index taFindFunctionName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property ItrInterfaceName: string index taIteratorInterfaceName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property ConstKeyword: string index taConstKeyword read GetTypeAttribute write SetTypeAttribute stored False;\r\n property ParameterName: string index taParameterName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property TypeName: string index taTypeName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property EqualityCompareFunctionTypeName: string index taEqualityCompareFunctionTypeName read GetTypeAttribute write SetTypeAttribute stored False;\r\n end;\r\n\r\n (* COUNTOBJECTINT(COUNTOBJECTFUNCTIONNAME, ITRINTERFACENAME, CONSTKEYWORD, PARAMETERNAME, TYPENAME, COMPAREFUNCTIONTYPENAME, OVERLOAD) *)\r\n TJclCountObjectIntParams = class(TJclAlgorithmsIntProcParams)\r\n published\r\n property CountObjectFunctionName: string index taCountObjectFunctionName read GetTypeAttribute write SetTypeAttribute stored IsTypeAttributeStored;\r\n property ItrInterfaceName: string index taIteratorInterfaceName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property ConstKeyword: string index taConstKeyword read GetTypeAttribute write SetTypeAttribute stored False;\r\n property ParameterName: string index taParameterName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property TypeName: string index taTypeName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property CompareFunctionTypeName: string index taCompareFunctionTypeName read GetTypeAttribute write SetTypeAttribute stored False;\r\n end;\r\n\r\n (* COUNTOBJECTIMP(COUNTOBJECTFUNCTIONNAME, ITRINTERFACENAME, CONSTKEYWORD, PARAMETERNAME, TYPENAME, COMPAREFUNCTIONTYPENAME) *)\r\n TJclCountObjectImpParams = class(TJclAlgorithmsImpProcParams)\r\n published\r\n property CountObjectFunctionName: string index taCountObjectFunctionName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property ItrInterfaceName: string index taIteratorInterfaceName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property ConstKeyword: string index taConstKeyword read GetTypeAttribute write SetTypeAttribute stored False;\r\n property ParameterName: string index taParameterName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property TypeName: string index taTypeName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property CompareFunctionTypeName: string index taCompareFunctionTypeName read GetTypeAttribute write SetTypeAttribute stored False;\r\n end;\r\n\r\n (* COUNTOBJECTEQINT(COUNTOBJECTFUNCTIONNAME, ITRINTERFACENAME, CONSTKEYWORD, PARAMETERNAME, TYPENAME, EQUALITYCOMPAREFUNCTIONTYPENAME, OVERLOAD) *)\r\n TJclCountObjectEqIntParams = class(TJclAlgorithmsIntProcParams)\r\n published\r\n property CountObjectFunctionName: string index taCountObjectFunctionName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property ItrInterfaceName: string index taIteratorInterfaceName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property ConstKeyword: string index taConstKeyword read GetTypeAttribute write SetTypeAttribute stored False;\r\n property ParameterName: string index taParameterName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property TypeName: string index taTypeName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property EqualityCompareFunctionTypeName: string index taEqualityCompareFunctionTypeName read GetTypeAttribute write SetTypeAttribute stored False;\r\n end;\r\n\r\n (* COUNTOBJECTEQIMP(COUNTOBJECTFUNCTIONNAME, ITRINTERFACENAME, CONSTKEYWORD, PARAMETERNAME, TYPENAME, EQUALITYCOMPAREFUNCTIONTYPENAME) *)\r\n TJclCountObjectEqImpParams = class(TJclAlgorithmsImpProcParams)\r\n published\r\n property CountObjectFunctionName: string index taCountObjectFunctionName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property ItrInterfaceName: string index taIteratorInterfaceName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property ConstKeyword: string index taConstKeyword read GetTypeAttribute write SetTypeAttribute stored False;\r\n property ParameterName: string index taParameterName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property TypeName: string index taTypeName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property EqualityCompareFunctionTypeName: string index taEqualityCompareFunctionTypeName read GetTypeAttribute write SetTypeAttribute stored False;\r\n end;\r\n\r\n (* COPYINT(COPYPROCEDURENAME, ITRINTERFACENAME, OVERLOAD) *)\r\n TJclCopyIntParams = class(TJclAlgorithmsIntProcParams)\r\n published\r\n property CopyProcedureName: string index taCopyProcedureName read GetTypeAttribute write SetTypeAttribute stored IsTypeAttributeStored;\r\n property ItrInterfaceName: string index taIteratorInterfaceName read GetTypeAttribute write SetTypeAttribute stored False;\r\n end;\r\n\r\n (* COPYIMP(COPYPROCEDURENAME, ITRINTERFACENAME, SETTERPROCEDURENAME) *)\r\n TJclCopyImpParams = class(TJclAlgorithmsImpProcParams)\r\n published\r\n property CopyProcedureName: string index taCopyProcedureName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property ItrInterfaceName: string index taIteratorInterfaceName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property SetterProcedureName: string index taSetterProcedureName read GetTypeAttribute write SetTypeAttribute stored False;\r\n end;\r\n\r\n (* GENERATEINT(GENERATEPROCEDURENAME, LISTINTERFACENAME, CONSTKEYWORD, PARAMETERNAME, TYPENAME, OVERLOAD) *)\r\n TJclGenerateIntParams = class(TJclAlgorithmsIntProcParams)\r\n published\r\n property GenerateProcedureName: string index taGenerateProcedureName read GetTypeAttribute write SetTypeAttribute stored IsTypeAttributeStored;\r\n property ListInterfaceName: string index taListInterfaceName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property ConstKeyword: string index taConstKeyword read GetTypeAttribute write SetTypeAttribute stored False;\r\n property ParameterName: string index taParameterName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property TypeName: string index taTypeName read GetTypeAttribute write SetTypeAttribute stored False;\r\n end;\r\n\r\n (* GENERATEIMP(GENERATEPROCEDURENAME, LISTINTERFACENAME, CONSTKEYWORD, PARAMETERNAME, TYPENAME) *)\r\n TJclGenerateImpParams = class(TJclAlgorithmsImpProcParams)\r\n published\r\n property GenerateProcedureName: string index taGenerateProcedureName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property ListInterfaceName: string index taListInterfaceName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property ConstKeyword: string index taConstKeyword read GetTypeAttribute write SetTypeAttribute stored False;\r\n property ParameterName: string index taParameterName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property TypeName: string index taTypeName read GetTypeAttribute write SetTypeAttribute stored False;\r\n end;\r\n\r\n (* FILLINT(FILLPROCEDURENAME, ITRINTERFACENAME, CONSTKEYWORD, PARAMETERNAME, TYPENAME, OVERLOAD) *)\r\n TJclFillIntParams = class(TJclAlgorithmsIntProcParams)\r\n published\r\n property FillProcedureName: string index taFillProcedureName read GetTypeAttribute write SetTypeAttribute stored IsTypeAttributeStored;\r\n property ItrInterfaceName: string index taIteratorInterfaceName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property ConstKeyword: string index taConstKeyword read GetTypeAttribute write SetTypeAttribute stored False;\r\n property ParameterName: string index taParameterName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property TypeName: string index taTypeName read GetTypeAttribute write SetTypeAttribute stored False;\r\n end;\r\n\r\n (* FILLIMP(FILLPROCEDURENAME, ITRINTERFACENAME, CONSTKEYWORD, PARAMETERNAME, TYPENAME, SETTERPROCEDURENAME) *)\r\n TJclFillImpParams = class(TJclAlgorithmsImpProcParams)\r\n published\r\n property FillProcedureName: string index taFillProcedureName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property ItrInterfaceName: string index taIteratorInterfaceName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property ConstKeyword: string index taConstKeyword read GetTypeAttribute write SetTypeAttribute stored False;\r\n property ParameterName: string index taParameterName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property TypeName: string index taTypeName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property SetterProcedureName: string index taSetterProcedureName read GetTypeAttribute write SetTypeAttribute stored False;\r\n end;\r\n\r\n (* REVERSEINT(REVERSEPROCEDURENAME, ITRINTERFACENAME, OVERLOAD) *)\r\n TJclReverseIntParams = class(TJclAlgorithmsIntProcParams)\r\n published\r\n property ReverseProcedureName: string index taReverseProcedureName read GetTypeAttribute write SetTypeAttribute stored IsTypeAttributeStored;\r\n property ItrInterfaceName: string index taIteratorInterfaceName read GetTypeAttribute write SetTypeAttribute stored False;\r\n end;\r\n\r\n (* REVERSEIMP(REVERSEPROCEDURENAME, ITRINTERFACENAME, TYPENAME, GETTERFUNCTIONNAME, SETTERPROCEDURENAME) *)\r\n TJclReverseImpParams = class(TJclAlgorithmsImpProcParams)\r\n published\r\n property ReverseProcedureName: string index taReverseProcedureName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property ItrInterfaceName: string index taIteratorInterfaceName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property TypeName: string index taTypeName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property GetterFunctionName: string index taGetterFunctionName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property SetterProcedureName: string index taSetterProcedureName read GetTypeAttribute write SetTypeAttribute stored False;\r\n end;\r\n\r\n (* SORTINT(SORTPROCEDURENAME, LISTINTERFACENAME, LEFT, RIGHT, COMPAREFUNCTIONTYPENAME, OVERLOAD) *)\r\n TJclSortIntParams = class(TJclAlgorithmsIntProcParams)\r\n private\r\n FLeft: string;\r\n FRight: string;\r\n function GetLeft: string;\r\n function GetRight: string;\r\n function IsLeftStored: Boolean;\r\n function IsRightStored: Boolean;\r\n published\r\n property SortProcedureName: string index taSortProcedureName read GetTypeAttribute write SetTypeAttribute stored IsTypeAttributeStored;\r\n property ListInterfaceName: string index taListInterfaceName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property Left: string read GetLeft write FLeft stored IsLeftStored;\r\n property Right: string read GetRight write FRight stored IsRightStored;\r\n property CompareFunctionTypeName: string index taCompareFunctionTypeName read GetTypeAttribute write SetTypeAttribute stored False;\r\n end;\r\n\r\n (* QUICKSORTINT(QUICKSORTPROCEDURENAME, LISTINTERFACENAME, LEFT, RIGHT, COMPAREFUNCTIONTYPENAME, OVERLOAD) *)\r\n TJclQuickSortIntParams = class(TJclAlgorithmsIntProcParams)\r\n private\r\n FLeft: string;\r\n FRight: string;\r\n function GetLeft: string;\r\n function GetRight: string;\r\n function IsLeftStored: Boolean;\r\n function IsRightStored: Boolean;\r\n published\r\n property QuickSortProcedureName: string index taQuickSortProcedureName read GetTypeAttribute write SetTypeAttribute stored IsTypeAttributeStored;\r\n property ListInterfaceName: string index taListInterfaceName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property Left: string read GetLeft write FLeft stored IsLeftStored;\r\n property Right: string read GetRight write FRight stored IsRightStored;\r\n property CompareFunctionTypeName: string index taCompareFunctionTypeName read GetTypeAttribute write SetTypeAttribute stored False;\r\n end;\r\n\r\n (* QUICKSORTIMP(QUICKSORTPROCEDURENAME, LISTINTERFACENAME, LEFT, RIGHT, COMPAREFUNCTIONTYPENAME, TYPENAME, GETTERFUNCTIONNAME, SETTERPROCEDURENAME) *)\r\n TJclQuickSortImpParams = class(TJclAlgorithmsImpProcParams)\r\n private\r\n function GetLeft: string;\r\n function GetRight: string;\r\n procedure SetLeft(const Value: string);\r\n procedure SetRight(const Value: string);\r\n published\r\n property QuickSortProcedureName: string index taQuickSortProcedureName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property ListInterfaceName: string index taListInterfaceName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property Left: string read GetLeft write SetLeft stored False;\r\n property Right: string read GetRight write SetRight stored False;\r\n property CompareFunctionTypeName: string index taCompareFunctionTypeName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property TypeName: string index taTypeName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property GetterFunctionName: string index taGetterFunctionName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property SetterProcedureName: string index taSetterProcedureName read GetTypeAttribute write SetTypeAttribute stored False;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jcl.svn.sourceforge.net/svnroot/jcl/tags/JCL-2.4-Build4571/jcl/source/common/JclPreProcessorAlgorithmsTemplates.pas $';\r\n Revision: '$Revision: 3740 $';\r\n Date: '$Date: 2012-02-23 21:46:07 +0100 (jeu. 23 févr. 2012) $';\r\n LogPath: 'JCL\\source\\common';\r\n Extra: '';\r\n Data: nil\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nprocedure RegisterJclContainers;\r\nbegin\r\n RegisterContainerParams('MOVEARRAYINT', TJclMoveArrayIntParams);\r\n RegisterContainerParams('ITERATEINT', TJclIterateIntParams);\r\n RegisterContainerParams('APPLYINT', TJclApplyIntParams);\r\n RegisterContainerParams('SIMPLECOMPAREINT', TJclSimpleCompareIntParams);\r\n RegisterContainerParams('SIMPLEEQUALITYCOMPAREINT', TJclSimpleEqualityCompareIntParams);\r\n RegisterContainerParams('SIMPLEHASHCONVERTINT', TJclSimpleHashConvertIntParams);\r\n RegisterContainerParams('FINDINT', TJclFindIntParams);\r\n RegisterContainerParams('FINDEQINT', TJclFindEqIntParams);\r\n RegisterContainerParams('COUNTOBJECTINT', TJclCountObjectIntParams);\r\n RegisterContainerParams('COUNTOBJECTEQINT', TJclCountObjectEqIntParams);\r\n RegisterContainerParams('COPYINT', TJclCopyIntParams);\r\n RegisterContainerParams('GENERATEINT', TJclGenerateIntParams);\r\n RegisterContainerParams('FILLINT', TJclFillIntParams);\r\n RegisterContainerParams('REVERSEINT', TJclReverseIntParams);\r\n RegisterContainerParams('SORTINT', TJclSortIntParams);\r\n RegisterContainerParams('QUICKSORTINT', TJclQuickSortIntParams);\r\n\r\n RegisterContainerParams('MOVEARRAYIMP', TJclMoveArrayImpParams, TJclMoveArrayIntParams);\r\n RegisterContainerParams('ITERATEIMP', TJclIterateImpParams, TJclIterateIntParams);\r\n RegisterContainerParams('APPLYIMP', TJclApplyImpParams, TJclApplyIntParams);\r\n RegisterContainerParams('FINDIMP', TJclFindImpParams, TJclFindIntParams);\r\n RegisterContainerParams('FINDEQIMP', TJclFindEqImpParams, TJclFindEqIntParams);\r\n RegisterContainerParams('COUNTOBJECTIMP', TJclCountObjectImpParams, TJclCountObjectIntParams);\r\n RegisterContainerParams('COUNTOBJECTEQIMP', TJclCountObjectEqImpParams, TJclCountObjectEqIntParams);\r\n RegisterContainerParams('COPYIMP', TJclCopyImpParams, TJclCopyIntParams);\r\n RegisterContainerParams('GENERATEIMP', TJclGenerateImpParams, TJclGenerateIntParams);\r\n RegisterContainerParams('FILLIMP', TJclFillImpParams, TJclFillIntParams);\r\n RegisterContainerParams('REVERSEIMP', TJclReverseImpParams, TJclReverseIntParams);\r\n RegisterContainerParams('QUICKSORTIMP', TJclQuickSortImpParams, TJclQuickSortIntParams);\r\nend;\r\n\r\n//=== { TJclSortIntParams } ==================================================\r\n\r\nfunction TJclSortIntParams.GetLeft: string;\r\nbegin\r\n Result := FLeft;\r\n if Result = '' then\r\n Result := 'L';\r\nend;\r\n\r\nfunction TJclSortIntParams.GetRight: string;\r\nbegin\r\n Result := FRight;\r\n if Result = '' then\r\n Result := 'R';\r\nend;\r\n\r\nfunction TJclSortIntParams.IsLeftStored: Boolean;\r\nbegin\r\n Result := FLeft <> '';\r\nend;\r\n\r\nfunction TJclSortIntParams.IsRightStored: Boolean;\r\nbegin\r\n Result := FRight <> '';\r\nend;\r\n\r\n//=== { TJclQuickSortIntParams } =============================================\r\n\r\nfunction TJclQuickSortIntParams.GetLeft: string;\r\nbegin\r\n Result := FLeft;\r\n if Result = '' then\r\n Result := 'L';\r\nend;\r\n\r\nfunction TJclQuickSortIntParams.GetRight: string;\r\nbegin\r\n Result := FRight;\r\n if Result = '' then\r\n Result := 'R';\r\nend;\r\n\r\nfunction TJclQuickSortIntParams.IsLeftStored: Boolean;\r\nbegin\r\n Result := FLeft <> '';\r\nend;\r\n\r\nfunction TJclQuickSortIntParams.IsRightStored: Boolean;\r\nbegin\r\n Result := FRight <> '';\r\nend;\r\n\r\n//=== { TJclQuickSortImpParams } =============================================\r\n\r\nfunction TJclQuickSortImpParams.GetLeft: string;\r\nbegin\r\n Result := (InterfaceParams as TJclQuickSortIntParams).Left;\r\nend;\r\n\r\nfunction TJclQuickSortImpParams.GetRight: string;\r\nbegin\r\n Result := (InterfaceParams as TJclQuickSortIntParams).Right;\r\nend;\r\n\r\nprocedure TJclQuickSortImpParams.SetLeft(const Value: string);\r\nbegin\r\n (InterfaceParams as TJclQuickSortIntParams).Left := Value;\r\nend;\r\n\r\nprocedure TJclQuickSortImpParams.SetRight(const Value: string);\r\nbegin\r\n (InterfaceParams as TJclQuickSortIntParams).Right := Value;\r\nend;\r\n\r\ninitialization\r\n RegisterJclContainers;\r\n {$IFDEF UNITVERSIONING}\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n {$ENDIF UNITVERSIONING}\r\n\r\nfinalization\r\n {$IFDEF UNITVERSIONING}\r\n UnregisterUnitVersion(HInstance);\r\n {$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n\r\n" }, { "path": "External/Jedi/Jcl/source/common/JclPreProcessorArrayListsTemplates.pas", "content": "{**************************************************************************************************}\r\n{ }\r\n{ Project JEDI Code Library (JCL) }\r\n{ }\r\n{ The contents of this file are subject to the Mozilla Public License Version 1.1 (the \"License\"); }\r\n{ you may not use this file except in compliance with the License. You may obtain a copy of the }\r\n{ License at http://www.mozilla.org/MPL/ }\r\n{ }\r\n{ Software distributed under the License is distributed on an \"AS IS\" basis, WITHOUT WARRANTY OF }\r\n{ ANY KIND, either express or implied. See the License for the specific language governing rights }\r\n{ and limitations under the License. }\r\n{ }\r\n{ The Original Code is JclArrayListsTemplates.pas. }\r\n{ }\r\n{ The Initial Developer of the Original Code is Florent Ouchet }\r\n{ }\r\n{ Portions created by Florent Ouchet are Copyright (C) of Florent Ouchet. All rights reserved. }\r\n{ }\r\n{ Contributors: }\r\n{ }\r\n{**************************************************************************************************}\r\n{ }\r\n{ Last modified: $Date:: 2012-02-23 21:46:07 +0100 (jeu. 23 févr. 2012) $ }\r\n{ Revision: $Rev:: 3740 $ }\r\n{ Author: $Author:: outchy $ }\r\n{ }\r\n{**************************************************************************************************}\r\n\r\nunit JclPreProcessorArrayListsTemplates;\r\n\r\ninterface\r\n\r\n{$I jcl.inc}\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n JclPreProcessorContainerTypes,\r\n JclPreProcessorContainerTemplates,\r\n JclPreProcessorContainer1DTemplates;\r\n\r\ntype\r\n (* JCLARRAYLISTINT(SELFCLASSNAME, ANCESTORCLASSNAME, BASECONTAINERINTERFACENAME,\r\n FLATCONTAINERINTERFACENAME, COLLECTIONINTERFACENAME, LISTINTERFACENAME,\r\n ARRAYINTERFACENAME, ITRINTERFACENAME, DYNARRAYTYPE, EQUALITYCOMPARERINTERFACENAME,\r\n INTERFACEADDITIONAL, SECTIONADDITIONAL, COLLECTIONFLAGS, OWNERSHIPDECLARATION,\r\n CONSTKEYWORD, PARAMETERNAME, TYPENAME, GETTERFUNCTIONNAME, SETTERPROCEDURENAME) *)\r\n TJclArrayListIntParams = class(TJclCollectionInterfaceParams)\r\n protected\r\n // function CodeUnit: string; override;\r\n public\r\n function AliasAttributeIDs: TAllTypeAttributeIDs; override;\r\n published\r\n property SelfClassName: string index taArrayListClassName read GetTypeAttribute write SetTypeAttribute stored IsTypeAttributeStored;\r\n property AncestorClassName;\r\n property BaseContainerInterfaceName: string index taContainerInterfaceName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property FlatContainerInterfaceName: string index taFlatContainerInterfaceName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property CollectionInterfaceName: string index taCollectionInterfaceName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property EqualityComparerInterfaceName: string index taEqualityComparerInterfaceName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property ListInterfaceName: string index taListInterfaceName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property ArrayInterfaceName: string index taArrayInterfaceName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property ItrInterfaceName: string index taIteratorInterfaceName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property DynArrayType: string index taDynArrayTypeName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property InterfaceAdditional;\r\n property SectionAdditional;\r\n property CollectionFlags;\r\n property OwnershipDeclaration;\r\n property ConstKeyword: string index taConstKeyword read GetTypeAttribute write SetTypeAttribute stored False;\r\n property ParameterName: string index taParameterName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property TypeName: string index taTypeName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property GetterFunctionName: string index taGetterFunctionName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property SetterProcedureName: string index taSetterProcedureName read GetTypeAttribute write SetTypeAttribute stored False;\r\n end;\r\n\r\n (* JCLARRAYLISTITRINT(SELFCLASSNAME, ITRINTERFACENAME, LISTCLASSNAME, CONSTKEYWORD, PARAMETERNAME,\r\n TYPENAME, GETTERFUNCTIONNAME, SETTERPROCEDURENAME) *)\r\n TJclArrayListItrIntParams = class(TJclContainerInterfaceParams)\r\n protected\r\n // function CodeUnit: string; override;\r\n public\r\n function AliasAttributeIDs: TAllTypeAttributeIDs; override;\r\n published\r\n property SelfClassName: string index taArrayIteratorClassName read GetTypeAttribute write SetTypeAttribute stored IsTypeAttributeStored;\r\n property ItrInterfaceName: string index taIteratorInterfaceName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property ListClassName: string index taArrayListClassName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property ConstKeyword: string index taConstKeyword read GetTypeAttribute write SetTypeAttribute stored False;\r\n property ParameterName: string index taParameterName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property TypeName: string index taTypeName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property GetterFunctionName: string index taGetterFunctionName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property SetterProcedureName: string index taSetterProcedureName read GetTypeAttribute write SetTypeAttribute stored False;\r\n end;\r\n\r\n (* JCLARRAYLISTIMP(SELFCLASSNAME, OWNERSHIPDECLARATION, OWNERSHIPPARAMETERNAME, COLLECTIONINTERFACENAME,\r\n ITRINTERFACENAME, ITRCLASSNAME, LISTINTERFACENAME, MOVEARRAYPROCEDURENAME,\r\n CONSTKEYWORD, PARAMETERNAME, GETTERFUNCTIONNAME,\r\n SETTERPROCEDURENAME, RELEASERFUNCTIONNAME, TYPENAME, DEFAULTVALUE) *)\r\n TJclArrayListImpParams = class(TJclCollectionImplementationParams)\r\n protected\r\n // function CodeUnit: string; override;\r\n public\r\n function GetConstructorParameters: string; override;\r\n function GetSelfClassName: string; override;\r\n published\r\n property SelfClassName: string index taArrayListClassName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property OwnershipDeclaration;\r\n property OwnershipParameterName: string index taOwnershipParameterName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property CollectionInterfaceName: string index taCollectionInterfaceName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property ItrInterfaceName: string index taIteratorInterfaceName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property ItrClassName: string index taArrayIteratorClassName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property ListInterfaceName: string index taListInterfaceName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property MoveArrayProcedureName: string index taMoveArrayProcedureName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property ConstKeyword: string index taConstKeyword read GetTypeAttribute write SetTypeAttribute stored False;\r\n property ParameterName: string index taParameterName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property GetterFunctionName: string index taGetterFunctionName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property SetterProcedureName: string index taSetterProcedureName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property ReleaserFunctionName: string index taReleaserFunctionName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property TypeName: string index taTypeName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property DefaultValue: string index taDefaultValue read GetTypeAttribute write SetTypeAttribute stored False;\r\n property MacroFooter;\r\n end;\r\n\r\n (* JCLARRAYLISTITRIMP(SELFCLASSNAME, ITRINTERFACENAME, LISTCLASSNAME,\r\n CONSTKEYWORD, PARAMETERNAME, TYPENAME, GETTERFUNCTIONNAME, SETTERPROCEDURENAME) *)\r\n TJclArrayListItrImpParams = class(TJclContainerImplementationParams)\r\n protected\r\n // function CodeUnit: string; override;\r\n published\r\n property SelfClassName: string index taArrayIteratorClassName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property ItrInterfaceName: string index taIteratorInterfaceName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property ListClassName: string index taArrayListClassName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property ConstKeyword: string index taConstKeyword read GetTypeAttribute write SetTypeAttribute stored False;\r\n property ParameterName: string index taParameterName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property TypeName: string index taTypeName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property GetterFunctionName: string index taGetterFunctionName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property SetterProcedureName: string index taSetterProcedureName read GetTypeAttribute write SetTypeAttribute stored False;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jcl.svn.sourceforge.net/svnroot/jcl/tags/JCL-2.4-Build4571/jcl/source/common/JclPreProcessorArrayListsTemplates.pas $';\r\n Revision: '$Revision: 3740 $';\r\n Date: '$Date: 2012-02-23 21:46:07 +0100 (jeu. 23 févr. 2012) $';\r\n LogPath: 'JCL\\source\\common';\r\n Extra: '';\r\n Data: nil\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n {$IFDEF HAS_UNITSCOPE}\r\n System.SysUtils,\r\n {$ELSE ~HAS_UNITSCOPE}\r\n SysUtils,\r\n {$ENDIF ~HAS_UNITSCOPE}\r\n JclStrings;\r\n\r\nprocedure RegisterJclContainers;\r\nbegin\r\n RegisterContainerParams('JCLARRAYLISTINT', TJclArrayListIntParams);\r\n RegisterContainerParams('JCLARRAYLISTITRINT', TJclArrayListItrIntParams);\r\n RegisterContainerParams('JCLARRAYLISTIMP', TJclArrayListImpParams, TJclArrayListIntParams);\r\n RegisterContainerParams('JCLARRAYLISTITRIMP', TJclArrayListItrImpParams, TJclArrayListItrIntParams);\r\nend;\r\n\r\n//=== { TJclArrayListIntParams } =============================================\r\n\r\nfunction TJclArrayListIntParams.AliasAttributeIDs: TAllTypeAttributeIDs;\r\nbegin\r\n Result := [taArrayListClassName];\r\nend;\r\n\r\n//=== { TJclArrayListItrIntParams } ==========================================\r\n\r\nfunction TJclArrayListItrIntParams.AliasAttributeIDs: TAllTypeAttributeIDs;\r\nbegin\r\n Result := [taArrayIteratorClassName];\r\nend;\r\n\r\n//=== { TJclArrayListImpParams } =============================================\r\n\r\nfunction TJclArrayListImpParams.GetConstructorParameters: string;\r\nbegin\r\n Result := 'FSize';\r\nend;\r\n\r\nfunction TJclArrayListImpParams.GetSelfClassName: string;\r\nbegin\r\n Result := SelfClassName;\r\nend;\r\n\r\ninitialization\r\n RegisterJclContainers;\r\n {$IFDEF UNITVERSIONING}\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n {$ENDIF UNITVERSIONING}\r\n\r\nfinalization\r\n {$IFDEF UNITVERSIONING}\r\n UnregisterUnitVersion(HInstance);\r\n {$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n\r\n" }, { "path": "External/Jedi/Jcl/source/common/JclPreProcessorArraySetsTemplates.pas", "content": "{**************************************************************************************************}\r\n{ }\r\n{ Project JEDI Code Library (JCL) }\r\n{ }\r\n{ The contents of this file are subject to the Mozilla Public License Version 1.1 (the \"License\"); }\r\n{ you may not use this file except in compliance with the License. You may obtain a copy of the }\r\n{ License at http://www.mozilla.org/MPL/ }\r\n{ }\r\n{ Software distributed under the License is distributed on an \"AS IS\" basis, WITHOUT WARRANTY OF }\r\n{ ANY KIND, either express or implied. See the License for the specific language governing rights }\r\n{ and limitations under the License. }\r\n{ }\r\n{ The Original Code is JclArraySetsTemplates.pas. }\r\n{ }\r\n{ The Initial Developer of the Original Code is Florent Ouchet }\r\n{ }\r\n{ Portions created by Florent Ouchet are Copyright (C) of Florent Ouchet. All rights reserved. }\r\n{ }\r\n{ Contributors: }\r\n{ }\r\n{**************************************************************************************************}\r\n{ }\r\n{ Last modified: $Date:: 2012-02-20 19:48:39 +0100 (lun. 20 févr. 2012) $ }\r\n{ Revision: $Rev:: 3737 $ }\r\n{ Author: $Author:: outchy $ }\r\n{ }\r\n{**************************************************************************************************}\r\n\r\nunit JclPreProcessorArraySetsTemplates;\r\n\r\ninterface\r\n\r\n{$I jcl.inc}\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n JclPreProcessorContainerTypes,\r\n JclPreProcessorContainerTemplates,\r\n JclPreProcessorContainer1DTemplates;\r\n\r\ntype\r\n (* JCLARRAYSETINT(SELFCLASSNAME, ANCESTORCLASSNAME, BASECONTAINERINTERFACENAME,\r\n FLATCONTAINERINTERFACENAME, COLLECTIONINTERFACENAME, LISTINTERFACENAME,\r\n ARRAYINTERFACENAME, SETINTERFACENAME, EQUALITYCOMPARERINTERFACENAME,\r\n COMPARERINTERFACENAME, INTERFACEADDITIONAL, SECTIONADDITIONAL,\r\n COLLECTIONFLAGS, CONSTKEYWORD, PARAMETERNAME, TYPENAME) *)\r\n TJclArraySetIntParams = class(TJclCollectionInterfaceParams)\r\n protected\r\n // function CodeUnit: string; override;\r\n public\r\n function AliasAttributeIDs: TAllTypeAttributeIDs; override;\r\n published\r\n property SelfClassName: string index taArraySetClassName read GetTypeAttribute write SetTypeAttribute stored IsTypeAttributeStored;\r\n property AncestorClassName: string index taArrayListClassName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property BaseContainerInterfaceName: string index taContainerInterfaceName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property FlatContainerInterfaceName: string index taFlatContainerInterfaceName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property CollectionInterfaceName: string index taCollectionInterfaceName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property EqualityComparerInterfaceName: string index taEqualityComparerInterfaceName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property ComparerInterfaceName: string index taComparerInterfaceName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property ListInterfaceName: string index taListInterfaceName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property ArrayInterfaceName: string index taArrayInterfaceName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property SetInterfaceName: string index taSetInterfaceName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property InterfaceAdditional;\r\n property SectionAdditional;\r\n property CollectionFlags;\r\n property ConstKeyword: string index taConstKeyword read GetTypeAttribute write SetTypeAttribute stored False;\r\n property ParameterName: string index taParameterName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property TypeName: string index taTypeName read GetTypeAttribute write SetTypeAttribute stored False;\r\n end;\r\n\r\n (* JCLARRAYSETIMP(SELFCLASSNAME, COLLECTIONINTERFACENAME, ITRINTERFACENAME, CONSTKEYWORD,\r\n PARAMETERNAME, TYPENAME, DEFAULTVALUE, GETTERFUNCTIONNAME) *)\r\n TJclArraySetImpParams = class(TJclCollectionImplementationParams)\r\n protected\r\n // function CodeUnit: string; override;\r\n public\r\n function GetConstructorParameters: string; override;\r\n function GetSelfClassName: string; override;\r\n published\r\n property SelfClassName: string index taArraySetClassName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property CollectionInterfaceName: string index taCollectionInterfaceName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property ItrInterfaceName: string index taIteratorInterfaceName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property ConstKeyword: string index taConstKeyword read GetTypeAttribute write SetTypeAttribute stored False;\r\n property ParameterName: string index taParameterName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property TypeName: string index taTypeName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property DefaultValue: string index taDefaultValue read GetTypeAttribute write SetTypeAttribute stored False;\r\n property GetterFunctionName: string index taGetterFunctionName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property MacroFooter;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jcl.svn.sourceforge.net/svnroot/jcl/tags/JCL-2.4-Build4571/jcl/source/common/JclPreProcessorArraySetsTemplates.pas $';\r\n Revision: '$Revision: 3737 $';\r\n Date: '$Date: 2012-02-20 19:48:39 +0100 (lun. 20 févr. 2012) $';\r\n LogPath: 'JCL\\source\\common';\r\n Extra: '';\r\n Data: nil\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n {$IFDEF HAS_UNITSCOPE}\r\n System.SysUtils,\r\n {$ELSE ~HAS_UNITSCOPE}\r\n SysUtils,\r\n {$ENDIF ~HAS_UNITSCOPE}\r\n JclStrings;\r\n\r\nprocedure RegisterJclContainers;\r\nbegin\r\n RegisterContainerParams('JCLARRAYSETINT', TJclArraySetIntParams);\r\n RegisterContainerParams('JCLARRAYSETIMP', TJclArraySetImpParams, TJclArraySetIntParams);\r\nend;\r\n\r\n//=== { TJclArraySetIntParams } ==============================================\r\n\r\nfunction TJclArraySetIntParams.AliasAttributeIDs: TAllTypeAttributeIDs;\r\nbegin\r\n Result := [taArraySetClassName];\r\nend;\r\n\r\n//=== { TJclArraySetImpParams } ==============================================\r\n\r\nfunction TJclArraySetImpParams.GetConstructorParameters: string;\r\nbegin\r\n Result := 'Size';\r\nend;\r\n\r\nfunction TJclArraySetImpParams.GetSelfClassName: string;\r\nbegin\r\n Result := SelfClassName;\r\nend;\r\n\r\ninitialization\r\n RegisterJclContainers;\r\n {$IFDEF UNITVERSIONING}\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n {$ENDIF UNITVERSIONING}\r\n\r\nfinalization\r\n {$IFDEF UNITVERSIONING}\r\n UnregisterUnitVersion(HInstance);\r\n {$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n\r\n" }, { "path": "External/Jedi/Jcl/source/common/JclPreProcessorBinaryTreesTemplates.pas", "content": "{**************************************************************************************************}\r\n{ }\r\n{ Project JEDI Code Library (JCL) }\r\n{ }\r\n{ The contents of this file are subject to the Mozilla Public License Version 1.1 (the \"License\"); }\r\n{ you may not use this file except in compliance with the License. You may obtain a copy of the }\r\n{ License at http://www.mozilla.org/MPL/ }\r\n{ }\r\n{ Software distributed under the License is distributed on an \"AS IS\" basis, WITHOUT WARRANTY OF }\r\n{ ANY KIND, either express or implied. See the License for the specific language governing rights }\r\n{ and limitations under the License. }\r\n{ }\r\n{ The Original Code is JclBinaryTreesTemplates.pas. }\r\n{ }\r\n{ The Initial Developer of the Original Code is Florent Ouchet }\r\n{ }\r\n{ Portions created by Florent Ouchet are Copyright (C) of Florent Ouchet. All rights reserved. }\r\n{ }\r\n{ Contributors: }\r\n{ }\r\n{**************************************************************************************************}\r\n{ }\r\n{ Last modified: $Date:: 2012-02-20 19:48:39 +0100 (lun. 20 févr. 2012) $ }\r\n{ Revision: $Rev:: 3737 $ }\r\n{ Author: $Author:: outchy $ }\r\n{ }\r\n{**************************************************************************************************}\r\n\r\nunit JclPreProcessorBinaryTreesTemplates;\r\n\r\ninterface\r\n\r\n{$I jcl.inc}\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n JclPreProcessorContainerTypes,\r\n JclPreProcessorContainerTemplates,\r\n JclPreProcessorContainer1DTemplates;\r\n\r\ntype\r\n (* JCLBINARYTREETYPESINT(NODETYPENAME, TYPENAME) *)\r\n TJclBinaryTreeTypeIntParams = class(TJclContainerInterfaceParams)\r\n public\r\n function AliasAttributeIDs: TAllTypeAttributeIDs; override;\r\n published\r\n property NodeTypeName: string index taBinaryTreeNodeTypeName read GetTypeAttribute write SetTypeAttribute stored IsTypeAttributeStored;\r\n property TypeName: string index taTypeName read GetTypeAttribute write SetTypeAttribute stored False;\r\n end;\r\n\r\n (* JCLBINARYTREEINT(NODETYPENAME, SELFCLASSNAME, ANCESTORCLASSNAME, BASECONTAINERINTERFACENAME,\r\n FLATCONTAINERINTERFACENAME, COLLECTIONINTERFACENAME,\r\n TREEINTERFACENAME, STDITRINTERFACENAME, TREEITRINTERFACENAME,\r\n EQUALITYCOMPARERINTERFACENAME, COMPARERINTERFACENAME, INTERFACEADDITIONAL,\r\n SECTIONADDITIONAL, CONSTRUCTORPARAMETERS, COLLECTIONFLAGS, CONSTKEYWORD,\r\n PARAMETERNAME, TYPENAME) *)\r\n TJclBinaryTreeIntParams = class(TJclCollectionInterfaceParams)\r\n private\r\n FConstructorDeclarations: string;\r\n protected\r\n // function CodeUnit: string; override;\r\n function GetConstructorDeclarations: string;\r\n public\r\n function AliasAttributeIDs: TAllTypeAttributeIDs; override;\r\n procedure ResetDefault(Value: Boolean); override;\r\n published\r\n property NodeTypeName: string index taBinaryTreeNodeTypeName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property SelfClassName: string index taBinaryTreeClassName read GetTypeAttribute write SetTypeAttribute stored IsTypeAttributeStored;\r\n property AncestorClassName;\r\n property BaseContainerInterfaceName: string index taContainerInterfaceName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property FlatContainerInterfaceName: string index taFlatContainerInterfaceName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property CollectionInterfaceName: string index taCollectionInterfaceName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property CompareFunctionTypeName: string index taCompareFunctionTypeName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property EqualityComparerInterfaceName: string index taEqualityComparerInterfaceName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property ComparerInterfaceName: string index taComparerInterfaceName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property TreeInterfaceName: string index taTreeInterfaceName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property StdItrInterfaceName: string index taIteratorInterfaceName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property TreeItrInterfaceName: string index taTreeIteratorInterfaceName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property InterfaceAdditional;\r\n property SectionAdditional;\r\n property ConstructorDeclarations: string read GetConstructorDeclarations write FConstructorDeclarations;\r\n property OwnershipDeclaration;\r\n property CollectionFlags;\r\n property ConstKeyword: string index taConstKeyword read GetTypeAttribute write SetTypeAttribute stored False;\r\n property ParameterName: string index taParameterName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property TypeName: string index taTypeName read GetTypeAttribute write SetTypeAttribute stored False;\r\n end;\r\n\r\n (* JCLBINARYTREEITRINT(BASEITRCLASSNAME, PREORDERITRCLASSNAME, INORDERITRCLASSNAME, POSTORDERITRCLASSNAME,\r\n STDITRINTERFACENAME, STDTREEITRINTERFACENAME, BINTREEITRINTERFACENAME,\r\n COLLECTIONINTERFACENAME, EQUALITYCOMPARERINTERFACENAME, NODETYPENAME,\r\n CONSTKEYWORD, PARAMETERNAME, TYPENAME, GETTERFUNCTIONNAME, SETTERPROCEDURENAME) *)\r\n TJclBinaryTreeItrIntParams = class(TJclContainerInterfaceParams)\r\n protected\r\n // function CodeUnit: string; override;\r\n public\r\n function AliasAttributeIDs: TAllTypeAttributeIDs; override;\r\n published\r\n property BaseItrClassName: string index taBinaryTreeBaseIteratorClassName read GetTypeAttribute write SetTypeAttribute stored IsTypeAttributeStored;\r\n property PreOrderItrClassName: string index taBinaryTreePreOrderIteratorClassName read GetTypeAttribute write SetTypeAttribute stored IsTypeAttributeStored;\r\n property InOrderItrClassName: string index taBinaryTreeInOrderIteratorClassName read GetTypeAttribute write SetTypeAttribute stored IsTypeAttributeStored;\r\n property PostOrderItrClassName: string index taBinaryTreePostOrderIteratorClassName read GetTypeAttribute write SetTypeAttribute stored IsTypeAttributeStored;\r\n property StdItrInterfaceName: string index taIteratorInterfaceName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property StdTreeItrInterfaceName: string index taTreeIteratorInterfaceName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property BinTreeItrInterfaceName: string index taBinaryTreeIteratorInterfaceName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property CollectionInterfaceName: string index taCollectionInterfaceName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property EqualityComparerInterfaceName: string index taEqualityComparerInterfaceName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property NodeTypeName: string index taBinaryTreeNodeTypeName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property ConstKeyword: string index taConstKeyword read GetTypeAttribute write SetTypeAttribute stored False;\r\n property ParameterName: string index taParameterName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property TypeName: string index taTypeName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property GetterFunctionName: string index taGetterFunctionName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property SetterProcedureName: string index taSetterProcedureName read GetTypeAttribute write SetTypeAttribute stored False;\r\n end;\r\n\r\n (* JCLBINARYTREEIMP(SELFCLASSNAME, NODETYPENAME, PREORDERITRCLASSNAME, INORDERITRCLASSNAME,\r\n POSTORDERITRCLASSNAME, COLLECTIONINTERFACENAME, STDITRINTERFACENAME,\r\n TREEITRINTERFACENAME, CONSTRUCTORPARAMETERS, CONSTRUCTORASSIGNMENTS,\r\n OWNERSHIPPARAMETERNAME, CONSTKEYWORD, PARAMETERNAME, TYPENAME, DEFAULTVALUE,\r\n RELEASERFUNCTIONNAME) *)\r\n TJclBinaryTreeImpParams = class(TJclCollectionImplementationParams)\r\n private\r\n FConstructorAssignments: string;\r\n FConstructorDeclarations: string;\r\n protected\r\n // function CodeUnit: string; override;\r\n function GetConstructorAssignments: string;\r\n function GetConstructorDeclarations: string;\r\n public\r\n function GetConstructorParameters: string; override;\r\n function GetSelfClassName: string; override;\r\n procedure ResetDefault(Value: Boolean); override;\r\n published\r\n property SelfClassName: string index taBinaryTreeClassName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property NodeTypeName: string index taBinaryTreeNodeTypeName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property PreOrderItrClassName: string index taBinaryTreePreOrderIteratorClassName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property InOrderItrClassName: string index taBinaryTreeInOrderIteratorClassName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property PostOrderItrClassName: string index taBinaryTreePostOrderIteratorClassName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property CollectionInterfaceName: string index taCollectionInterfaceName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property StdItrInterfaceName: string index taIteratorInterfaceName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property TreeItrInterfaceName: string index taTreeIteratorInterfaceName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property ConstructorDeclarations: string read GetConstructorDeclarations write FConstructorDeclarations;\r\n property ConstructorAssignments: string read GetConstructorAssignments write FConstructorAssignments;\r\n property CompareFunctionTypeName: string index taCompareFunctionTypeName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property OwnershipDeclaration;\r\n property OwnershipParameterName: string index taOwnershipParameterName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property ConstKeyword: string index taConstKeyword read GetTypeAttribute write SetTypeAttribute stored False;\r\n property ParameterName: string index taParameterName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property ReleaserFunctionName: string index taReleaserFunctionName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property TypeName: string index taTypeName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property DefaultValue: string index taDefaultValue read GetTypeAttribute write SetTypeAttribute stored False;\r\n property MacroFooter;\r\n end;\r\n\r\n (* JCLBINARYTREEITRIMP(BASEITRCLASSNAME, PREORDERITRCLASSNAME, INORDERITRCLASSNAME, POSTORDERITRCLASSNAME,\r\n STDITRINTERFACENAME, COLLECTIONINTERFACENAME, EQUALITYCOMPARERINTERFACENAME,\r\n NODETYPENAME, CONSTKEYWORD, PARAMETERNAME, TYPENAME, DEFAULTVALUE,\r\n GETTERFUNCTIONNAME, SETTERPROCEDURENAME, RELEASERFUNCTIONNAME) *)\r\n TJclBinaryTreeItrImpParams = class(TJclContainerImplementationParams)\r\n protected\r\n // function CodeUnit: string; override;\r\n published\r\n property BaseItrClassName: string index taBinaryTreeBaseIteratorClassName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property PreOrderItrClassName: string index taBinaryTreePreOrderIteratorClassName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property InOrderItrClassName: string index taBinaryTreeInOrderIteratorClassName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property PostOrderItrClassName: string index taBinaryTreePostOrderIteratorClassName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property StdItrInterfaceName: string index taIteratorInterfaceName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property CollectionInterfaceName: string index taCollectionInterfaceName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property EqualityComparerInterfaceName: string index taEqualityComparerInterfaceName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property NodeTypeName: string index taBinaryTreeNodeTypeName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property ConstKeyword: string index taConstKeyword read GetTypeAttribute write SetTypeAttribute stored False;\r\n property ParameterName: string index taParameterName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property TypeName: string index taTypeName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property DefaultValue: string index taDefaultValue read GetTypeAttribute write SetTypeAttribute stored False;\r\n property GetterFunctionName: string index taGetterFunctionName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property SetterProcedureName: string index taSetterProcedureName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property ReleaserFunctionName: string index taReleaserFunctionName read GetTypeAttribute write SetTypeAttribute stored False;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jcl.svn.sourceforge.net/svnroot/jcl/tags/JCL-2.4-Build4571/jcl/source/common/JclPreProcessorBinaryTreesTemplates.pas $';\r\n Revision: '$Revision: 3737 $';\r\n Date: '$Date: 2012-02-20 19:48:39 +0100 (lun. 20 févr. 2012) $';\r\n LogPath: 'JCL\\source\\common';\r\n Extra: '';\r\n Data: nil\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n {$IFDEF HAS_UNITSCOPE}\r\n System.SysUtils,\r\n {$ELSE ~HAS_UNITSCOPE}\r\n SysUtils,\r\n {$ENDIF ~HAS_UNITSCOPE}\r\n JclStrings;\r\n\r\nprocedure RegisterJclContainers;\r\nbegin\r\n RegisterContainerParams('JCLBINARYTREETYPESINT', TJclBinaryTreeTypeIntParams);\r\n RegisterContainerParams('JCLBINARYTREEINT', TJclBinaryTreeIntParams);\r\n RegisterContainerParams('JCLBINARYTREEITRINT', TJclBinaryTreeItrIntParams);\r\n RegisterContainerParams('JCLBINARYTREEIMP', TJclBinaryTreeImpParams, TJclBinaryTreeIntParams);\r\n RegisterContainerParams('JCLBINARYTREEITRIMP', TJclBinaryTreeItrImpParams, TJclBinaryTreeItrIntParams);\r\nend;\r\n\r\n//=== { TJclBinaryTreeTypeIntParams } ========================================\r\n\r\nfunction TJclBinaryTreeTypeIntParams.AliasAttributeIDs: TAllTypeAttributeIDs;\r\nbegin\r\n Result := [taBinaryTreeNodeTypeName];\r\nend;\r\n\r\n//=== { TJclBinaryTreeIntParams } ============================================\r\n\r\nfunction TJclBinaryTreeIntParams.AliasAttributeIDs: TAllTypeAttributeIDs;\r\nbegin\r\n Result := [taBinaryTreeClassName];\r\nend;\r\n\r\nfunction TJclBinaryTreeIntParams.GetConstructorDeclarations: string;\r\nbegin\r\n Result := FConstructorDeclarations;\r\n if (Result = '') and TypeInfo.KnownType then\r\n Result := 'ACompare: ' + CompareFunctionTypeName;\r\nend;\r\n\r\nprocedure TJclBinaryTreeIntParams.ResetDefault(Value: Boolean);\r\nbegin\r\n inherited ResetDefault(Value);\r\n FConstructorDeclarations := '';\r\n if not Value then\r\n FConstructorDeclarations := GetConstructorDeclarations;\r\nend;\r\n\r\n//=== { TJclBinaryTreeItrIntParams } =========================================\r\n\r\nfunction TJclBinaryTreeItrIntParams.AliasAttributeIDs: TAllTypeAttributeIDs;\r\nbegin\r\n Result := [taBinaryTreeBaseIteratorClassName, taBinaryTreePreOrderIteratorClassName,\r\n taBinaryTreeInOrderIteratorClassName, taBinaryTreePostOrderIteratorClassName];\r\nend;\r\n\r\n//=== { TJclBinaryTreeImpParams } ============================================\r\n\r\nfunction TJclBinaryTreeImpParams.GetConstructorAssignments: string;\r\nbegin\r\n Result := FConstructorAssignments;\r\n if (Result = '') and TypeInfo.KnownType then\r\n Result := NativeLineBreak + ' SetCompare(ACompare);';\r\nend;\r\n\r\nfunction TJclBinaryTreeImpParams.GetConstructorDeclarations: string;\r\nbegin\r\n Result := FConstructorDeclarations;\r\n if (Result = '') and TypeInfo.KnownType then\r\n Result := 'ACompare: ' + CompareFunctionTypeName;\r\nend;\r\n\r\nfunction TJclBinaryTreeImpParams.GetConstructorParameters: string;\r\nbegin\r\n Result := 'Compare';\r\nend;\r\n\r\nfunction TJclBinaryTreeImpParams.GetSelfClassName: string;\r\nbegin\r\n Result := SelfClassName;\r\nend;\r\n\r\nprocedure TJclBinaryTreeImpParams.ResetDefault(Value: Boolean);\r\nbegin\r\n inherited ResetDefault(Value);\r\n FConstructorAssignments := '';\r\n FConstructorDeclarations := '';\r\n if not Value then\r\n begin\r\n FConstructorAssignments := GetConstructorAssignments;\r\n FConstructorDeclarations := GetConstructorDeclarations;\r\n end;\r\nend;\r\n\r\ninitialization\r\n RegisterJclContainers;\r\n {$IFDEF UNITVERSIONING}\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n {$ENDIF UNITVERSIONING}\r\n\r\nfinalization\r\n {$IFDEF UNITVERSIONING}\r\n UnregisterUnitVersion(HInstance);\r\n {$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n\r\n" }, { "path": "External/Jedi/Jcl/source/common/JclPreProcessorContainer1DTemplates.pas", "content": "{**************************************************************************************************}\r\n{ }\r\n{ Project JEDI Code Library (JCL) }\r\n{ }\r\n{ The contents of this file are subject to the Mozilla Public License Version 1.1 (the \"License\"); }\r\n{ you may not use this file except in compliance with the License. You may obtain a copy of the }\r\n{ License at http://www.mozilla.org/MPL/ }\r\n{ }\r\n{ Software distributed under the License is distributed on an \"AS IS\" basis, WITHOUT WARRANTY OF }\r\n{ ANY KIND, either express or implied. See the License for the specific language governing rights }\r\n{ and limitations under the License. }\r\n{ }\r\n{ The Original Code is JclContainer1DTemplates.pas. }\r\n{ }\r\n{ The Initial Developer of the Original Code is Florent Ouchet }\r\n{ }\r\n{ Portions created by Florent Ouchet are Copyright (C) of Florent Ouchet. All rights reserved. }\r\n{ }\r\n{ Contributors: }\r\n{ }\r\n{**************************************************************************************************}\r\n{ }\r\n{ Last modified: $Date:: 2012-02-20 19:48:39 +0100 (lun. 20 févr. 2012) $ }\r\n{ Revision: $Rev:: 3737 $ }\r\n{ Author: $Author:: outchy $ }\r\n{ }\r\n{**************************************************************************************************}\r\n\r\nunit JclPreProcessorContainer1DTemplates;\r\n\r\ninterface\r\n\r\n{$I jcl.inc}\r\n\r\nuses\r\n {$IFDEF HAS_UNITSCOPE}\r\n System.Classes,\r\n {$ELSE ~HAS_UNITSCOPE}\r\n Classes,\r\n {$ENDIF ~HAS_UNITSCOPE}\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n JclBase,\r\n JclPreProcessorContainerTypes;\r\n\r\n{$TYPEINFO ON}\r\n\r\ntype\r\n TJclContainerTypeInfo = class\r\n private\r\n FCustomTypeAttributes: TTypeAttributes;\r\n FKnownTypeAttributes: PKnownTypeAttributes;\r\n FOnKnownTypeChange: TNotifyEvent;\r\n function GetCustomTypeAttribute(Index: TTypeAttributeID): string;\r\n function GetTypeName: string;\r\n protected\r\n function GetFloatType: Boolean;\r\n function GetKnownType: Boolean;\r\n function GetOwnershipDeclaration: string;\r\n function GetStringType: Boolean;\r\n function GetTObjectType: Boolean;\r\n function GetTypeAttribute(Index: TTypeAttributeID): string;\r\n procedure SetKnownType(Value: Boolean);\r\n procedure SetTypeAttribute(Index: TTypeAttributeID; const Value: string);\r\n procedure SetTypeName(const Value: string);\r\n public\r\n property FloatType: Boolean read GetFloatType;\r\n property KnownType: Boolean read GetKnownType write SetKnownType;\r\n property StringType: Boolean read GetStringType;\r\n property TObjectType: Boolean read GetTObjectType;\r\n property KnownTypeAttributes: PKnownTypeAttributes read FKnownTypeAttributes;\r\n property CustomTypeAttributes[Index: TTypeAttributeID]: string read GetCustomTypeAttribute;\r\n property TypeAttributes[Index: TTypeAttributeID]: string read GetTypeAttribute write SetTypeAttribute;\r\n property TypeName: string read GetTypeName write SetTypeName stored True;\r\n property OwnershipDeclaration: string read GetOwnershipDeclaration;\r\n property OnKnownTypeChange: TNotifyEvent read FOnKnownTypeChange write FOnKnownTypeChange;\r\n end;\r\n\r\n TJclContainerInterfaceParams = class(TJclInterfaceParams)\r\n private\r\n FTypeInfo: TJclContainerTypeInfo;\r\n protected\r\n function GetOwnershipDeclaration: string; virtual;\r\n function GetTypeAttribute(Index: TTypeAttributeID): string;\r\n function IsTypeAttributeStored(Index: TTypeAttributeID): Boolean;\r\n procedure SetTypeAttribute(Index: TTypeAttributeID; const Value: string);\r\n public\r\n property TypeInfo: TJclContainerTypeInfo read FTypeInfo write FTypeInfo;\r\n property OwnershipDeclaration: string read GetOwnershipDeclaration;\r\n end;\r\n\r\n TJclClassInterfaceParams = class(TJclContainerInterfaceParams)\r\n protected\r\n FAncestorClassName: string;\r\n FInterfaceAdditional: string;\r\n FSectionAdditional: string;\r\n function GetAncestorClassName: string; virtual;\r\n function GetInterfaceAdditional: string; virtual;\r\n function GetSectionAdditional: string; virtual;\r\n public\r\n property AncestorClassName: string read GetAncestorClassName write FAncestorClassName;\r\n property InterfaceAdditional: string read GetInterfaceAdditional write FInterfaceAdditional;\r\n property SectionAdditional: string read GetSectionAdditional write FSectionAdditional;\r\n end;\r\n\r\n TJclCollectionInterfaceParams = class(TJclClassInterfaceParams)\r\n protected\r\n FCollectionFlags: string;\r\n function GetAncestorClassName: string; override;\r\n function GetCollectionFlags: string; virtual;\r\n public\r\n property CollectionFlags: string read GetCollectionFlags write FCollectionFlags;\r\n end;\r\n\r\n TJclTypeParams = class(TJclContainerInterfaceParams)\r\n published\r\n property TypeName: string index taTypeName read GetTypeAttribute write SetTypeAttribute stored IsTypeAttributeStored;\r\n property Condition: string index taCondition read GetTypeAttribute write SetTypeAttribute stored IsTypeAttributeStored;\r\n property Defines: string index taDefines read GetTypeAttribute write SetTypeAttribute stored IsTypeAttributeStored;\r\n property Undefs: string index taUndefs read GetTypeAttribute write SetTypeAttribute stored IsTypeAttributeStored;\r\n property Alias: string index taAlias read GetTypeAttribute write SetTypeAttribute stored IsTypeAttributeStored;\r\n property AliasCondition: string index taAliasCondition read GetTypeAttribute write SetTypeAttribute stored IsTypeAttributeStored;\r\n property DefaultValue: string index taDefaultValue read GetTypeAttribute write SetTypeAttribute stored IsTypeAttributeStored;\r\n property ConstKeyword: string index taConstKeyword read GetTypeAttribute write SetTypeAttribute stored IsTypeAttributeStored;\r\n property OwnershipParameterName: string index taOwnershipParameterName read GetTypeAttribute write SetTypeAttribute stored IsTypeAttributeStored;\r\n property ReleaserFunctionName: string index taReleaserFunctionName read GetTypeAttribute write SetTypeAttribute stored IsTypeAttributeStored;\r\n property GetterFunctionName: string index taGetterFunctionName read GetTypeAttribute write SetTypeAttribute stored IsTypeAttributeStored;\r\n property SetterProcedureName: string index taSetterProcedureName read GetTypeAttribute write SetTypeAttribute stored IsTypeAttributeStored;\r\n property ParameterName: string index taParameterName read GetTypeAttribute write SetTypeAttribute stored IsTypeAttributeStored;\r\n property DynArrayTypeName: string index taDynArrayTypeName read GetTypeAttribute write SetTypeAttribute stored IsTypeAttributeStored;\r\n property ArrayPropertyName: string index taArrayPropertyName read GetTypeAttribute write SetTypeAttribute stored IsTypeAttributeStored;\r\n property BaseContainerClassName: string index taBaseContainerClassName read GetTypeAttribute write SetTypeAttribute stored IsTypeAttributeStored;\r\n property BaseCollectionClassName: string index taBaseCollectionClassName read GetTypeAttribute write SetTypeAttribute stored IsTypeAttributeStored;\r\n property ContainerInterfaceName: string index taContainerInterfaceName read GetTypeAttribute write SetTypeAttribute stored IsTypeAttributeStored;\r\n property ContainerInterfaceGUID: string index taContainerInterfaceGUID read GetTypeAttribute write SetTypeAttribute stored IsTypeAttributeStored;\r\n property FlatContainerInterfaceName: string index taFlatContainerInterfaceName read GetTypeAttribute write SetTypeAttribute stored IsTypeAttributeStored;\r\n property FlatContainerInterfaceGUID: string index taFlatContainerInterfaceGUID read GetTypeAttribute write SetTypeAttribute stored IsTypeAttributeStored;\r\n end;\r\n\r\n TJclContainerImplementationParams = class(TJclImplementationParams)\r\n private\r\n function GetTypeInfo: TJclContainerTypeInfo;\r\n protected\r\n function GetOwnershipDeclaration: string; virtual;\r\n function GetTypeAttribute(Index: TTypeAttributeID): string;\r\n function IsTypeAttributeStored(Index: TTypeAttributeID): Boolean;\r\n procedure SetTypeAttribute(Index: TTypeAttributeID; const Value: string);\r\n public\r\n property OwnershipDeclaration: string read GetOwnershipDeclaration;\r\n property TypeInfo: TJclContainerTypeInfo read GetTypeInfo;\r\n end;\r\n\r\n TJclClassImplementationParams = class(TJclContainerImplementationParams)\r\n protected\r\n FMacroFooter: string;\r\n function GetConstructorParameters: string; virtual; abstract;\r\n function GetSelfClassName: string; virtual; abstract;\r\n public\r\n function GetMacroFooter: string; override;\r\n procedure ResetDefault(Value: Boolean); override;\r\n property MacroFooter: string read GetMacroFooter write FMacroFooter;\r\n end;\r\n\r\n TJclCollectionImplementationParams = class(TJclClassImplementationParams)\r\n\r\n end;\r\n\r\n{$IFNDEF TYPEINFO_ON}\r\n {$TYPEINFO OFF}\r\n{$ENDIF ~TYPEINFO_ON}\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jcl.svn.sourceforge.net/svnroot/jcl/tags/JCL-2.4-Build4571/jcl/source/common/JclPreProcessorContainer1DTemplates.pas $';\r\n Revision: '$Revision: 3737 $';\r\n Date: '$Date: 2012-02-20 19:48:39 +0100 (lun. 20 févr. 2012) $';\r\n LogPath: 'JCL\\source\\common';\r\n Extra: '';\r\n Data: nil\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n {$IFDEF HAS_UNITSCOPE}\r\n {$IFDEF MSWINDOWS}\r\n Winapi.Windows,\r\n {$ENDIF MSWINDOWS}\r\n {$IFDEF HAS_UNIT_RTLCONSTS}\r\n System.RTLConsts,\r\n {$ENDIF HAS_UNIT_RTLCONTST}\r\n System.TypInfo,\r\n System.SysUtils,\r\n Winapi.ActiveX,\r\n System.Win.ComObj,\r\n {$ELSE ~HAS_UNITSCOPE}\r\n {$IFDEF MSWINDOWS}\r\n Windows,\r\n {$ENDIF MSWINDOWS}\r\n {$IFDEF HAS_UNIT_RTLCONSTS}\r\n RTLConsts,\r\n {$ENDIF HAS_UNIT_RTLCONTST}\r\n TypInfo,\r\n SysUtils,\r\n ActiveX,\r\n ComObj,\r\n {$ENDIF ~HAS_UNITSCOPE}\r\n JclRTTI,\r\n JclSysUtils,\r\n JclContainerIntf,\r\n JclPreProcessorContainerKnownTypes,\r\n JclPreProcessorContainerTemplates;\r\n\r\nprocedure RegisterJclContainers;\r\nbegin\r\n RegisterContainerParams('', TJclTypeParams);\r\nend;\r\n\r\n//=== { TJclContainerTypeInfo } ==============================================\r\n\r\nfunction TJclContainerTypeInfo.GetTypeAttribute(Index: TTypeAttributeID): string;\r\nbegin\r\n if (Index >= Low(TTypeAttributeID)) and (Index <= High(TTypeAttributeID)) then\r\n begin\r\n if FCustomTypeAttributes[Index] = '' then\r\n begin\r\n if Assigned(FKnownTypeAttributes) then\r\n Result := FKnownTypeAttributes^[Index]\r\n else\r\n Result := Format(TypeAttributeInfos[Index].DefaultValue, [TypeName]);\r\n end\r\n else\r\n Result := FCustomTypeAttributes[Index];\r\n end\r\n else\r\n begin\r\n System.Error(reRangeError);\r\n Result := '';\r\n end;\r\nend;\r\n\r\nfunction TJclContainerTypeInfo.GetTypeName: string;\r\nbegin\r\n Result := FCustomTypeAttributes[taTypeName];\r\nend;\r\n\r\nfunction TJclContainerTypeInfo.GetCustomTypeAttribute(Index: TTypeAttributeID): string;\r\nbegin\r\n if (Index >= Low(TTypeAttributeID)) and (Index <= High(TTypeAttributeID)) then\r\n Result := FCustomTypeAttributes[Index]\r\n else\r\n begin\r\n System.Error(reRangeError);\r\n Result := '';\r\n end;\r\nend;\r\n\r\nfunction TJclContainerTypeInfo.GetFloatType: Boolean;\r\nbegin\r\n Result := KnownType;\r\n if Result then\r\n Result := (TypeName = SingleKnownType[taTypeName]) or\r\n (TypeName = DoubleKnownType[taTypeName]) or\r\n (TypeName = ExtendedKnownType[taTypeName]) or\r\n (TypeName = FloatKnownType[taTypeName]);\r\nend;\r\n\r\nfunction TJclContainerTypeInfo.GetKnownType: Boolean;\r\nvar\r\n Index: TTypeAttributeID;\r\nbegin\r\n Result := Assigned(FKnownTypeAttributes);\r\n for Index := Low(TTypeAttributeID) to High(TTypeAttributeID) do\r\n if Index <> taTypeName then\r\n begin\r\n Result := Result and (FCustomTypeAttributes[Index] = '');\r\n if not Result then\r\n Break;\r\n end;\r\nend;\r\n\r\nfunction TJclContainerTypeInfo.GetOwnershipDeclaration: string;\r\nbegin\r\n Result := GetTypeAttribute(taOwnershipParameterName);\r\n if Result <> '' then\r\n Result := Format('%s: Boolean', [Result]);\r\nend;\r\n\r\nfunction TJclContainerTypeInfo.GetTObjectType: Boolean;\r\nbegin\r\n Result := KnownType and (TypeName = TObjectKnownType[taTypeName]);\r\nend;\r\n\r\nfunction TJclContainerTypeInfo.GetStringType: Boolean;\r\nbegin\r\n Result := KnownType;\r\n if Result then\r\n Result := (TypeName = AnsiStringKnownType[taTypeName]) or\r\n (TypeName = WideStringKnownType[taTypeName]) or\r\n (TypeName = UnicodeStringKnownType[taTypeName]) or\r\n (TypeName = StringKnownType[taTypeName]);\r\nend;\r\n\r\nprocedure TJclContainerTypeInfo.SetKnownType(Value: Boolean);\r\nvar\r\n Index: TTypeAttributeID;\r\n NewGUID: TGUID;\r\nbegin\r\n if Value then\r\n begin\r\n // reset to default values\r\n for Index := Low(TTypeAttributeID) to High(TTypeAttributeID) do\r\n if Index <> taTypeName then\r\n FCustomTypeAttributes[Index] := '';\r\n end\r\n else\r\n if {not Value and} Assigned(FKnownTypeAttributes) then\r\n begin\r\n // copy with new GUIDs\r\n for Index := Low(TTypeAttributeID) to High(TTypeAttributeID) do\r\n if Index <> taTypeName then\r\n begin\r\n if TypeAttributeInfos[Index].IsGUID then\r\n begin\r\n OleCheck(CoCreateGuid(NewGUID));\r\n FCustomTypeAttributes[Index] := GUIDToString(NewGUID);\r\n end\r\n else\r\n FCustomTypeAttributes[Index] := FKnownTypeAttributes[Index];\r\n end;\r\n end\r\n else\r\n begin\r\n {not Value and not Assigned(FKnownTypeAttributes)}\r\n // default names with new GUIDs\r\n for Index := Low(TTypeAttributeID) to High(TTypeAttributeID) do\r\n if Index <> taTypeName then\r\n begin\r\n if TypeAttributeInfos[Index].IsGUID then\r\n begin\r\n OleCheck(CoCreateGuid(NewGUID));\r\n FCustomTypeAttributes[Index] := GUIDToString(NewGUID);\r\n end\r\n else\r\n FCustomTypeAttributes[Index] := Format(TypeAttributeInfos[Index].DefaultValue, [TypeName]);\r\n end;\r\n end;\r\n if Assigned(FOnKnownTypeChange) then\r\n FOnKnownTypeChange(Self);\r\nend;\r\n\r\nprocedure TJclContainerTypeInfo.SetTypeAttribute(Index: TTypeAttributeID;\r\n const Value: string);\r\nbegin\r\n if (Index >= Low(TTypeAttributeID)) and (Index <= High(TTypeAttributeID)) then\r\n FCustomTypeAttributes[Index] := Value\r\n else\r\n System.Error(reRangeError);\r\nend;\r\n\r\nprocedure TJclContainerTypeInfo.SetTypeName(const Value: string);\r\nbegin\r\n FCustomTypeAttributes[taTypeName] := Value;\r\n FKnownTypeAttributes := IsKnownType(Value);\r\n if Assigned(FKnownTypeAttributes) then\r\n SetKnownType(True);\r\nend;\r\n\r\n//=== { TJclContainerInterfaceParams } =======================================\r\n\r\nfunction TJclContainerInterfaceParams.GetOwnershipDeclaration: string;\r\nbegin\r\n Result := TypeInfo.OwnershipDeclaration;\r\n if Result <> '' then\r\n Result := '; ' + Result;\r\nend;\r\n\r\nfunction TJclContainerInterfaceParams.GetTypeAttribute(Index: TTypeAttributeID): string;\r\nbegin\r\n Result := TypeInfo.TypeAttributes[Index];\r\nend;\r\n\r\nfunction TJclContainerInterfaceParams.IsTypeAttributeStored(Index: TTypeAttributeID): Boolean;\r\nbegin\r\n Result := TypeInfo.CustomTypeAttributes[Index] <> '';\r\nend;\r\n\r\nprocedure TJclContainerInterfaceParams.SetTypeAttribute(Index: TTypeAttributeID;\r\n const Value: string);\r\nbegin\r\n TypeInfo.TypeAttributes[Index] := Value;\r\nend;\r\n\r\n//=== { TJclClassInterfaceParams } ===========================================\r\n\r\nfunction TJclClassInterfaceParams.GetAncestorClassName: string;\r\nbegin\r\n Result := FAncestorClassName;\r\n if Result = '' then\r\n Result := TypeInfo.TypeAttributes[taBaseContainerClassName];\r\nend;\r\n\r\nfunction TJclClassInterfaceParams.GetInterfaceAdditional: string;\r\nbegin\r\n Result := FInterfaceAdditional;\r\n if Result = '' then\r\n begin\r\n if TypeInfo.StringType then\r\n Result := ' IJclStrBaseContainer,'\r\n else\r\n if TypeInfo.TObjectType then\r\n Result := ' IJclObjectOwner,';\r\n end;\r\nend;\r\n\r\nfunction TJclClassInterfaceParams.GetSectionAdditional: string;\r\nbegin\r\n Result := FSectionAdditional;\r\n if (Result = '') and TypeInfo.KnownType then\r\n Result := NativeLineBreak +\r\n 'protected' + NativeLineBreak +\r\n ' function CreateEmptyContainer: TJclAbstractContainerBase; override;';\r\nend;\r\n\r\n//=== { TJclCollectionInterfaceParams } ======================================\r\n\r\nfunction TJclCollectionInterfaceParams.GetAncestorClassName: string;\r\nbegin\r\n Result := FAncestorClassName;\r\n if Result = '' then\r\n begin\r\n if TypeInfo.TypeAttributes[taBaseCollectionClassName] <> '' then\r\n Result := TypeInfo.TypeAttributes[taBaseCollectionClassName]\r\n else\r\n Result := inherited GetAncestorClassName;\r\n end;\r\nend;\r\n\r\nfunction TJclCollectionInterfaceParams.GetCollectionFlags: string;\r\nbegin\r\n Result := FCollectionFlags;\r\n if (Result = '') and (TypeInfo.TypeAttributes[taBaseCollectionClassName] <> '') then\r\n Result := ' override;';\r\nend;\r\n\r\n//=== { TJclContainerImplementationParams } =======================================\r\n\r\nfunction TJclContainerImplementationParams.GetOwnershipDeclaration: string;\r\nbegin\r\n Result := (InterfaceParams as TJclContainerInterfaceParams).OwnershipDeclaration;\r\nend;\r\n\r\nfunction TJclContainerImplementationParams.GetTypeAttribute(Index: TTypeAttributeID): string;\r\nbegin\r\n Result := (InterfaceParams as TJclContainerInterfaceParams).GetTypeAttribute(Index);\r\nend;\r\n\r\nfunction TJclContainerImplementationParams.GetTypeInfo: TJclContainerTypeInfo;\r\nbegin\r\n Result := (InterfaceParams as TJclContainerInterfaceParams).TypeInfo;\r\nend;\r\n\r\nfunction TJclContainerImplementationParams.IsTypeAttributeStored(Index: TTypeAttributeID): Boolean;\r\nbegin\r\n Result := (InterfaceParams as TJclContainerInterfaceParams).IsTypeAttributeStored(Index);\r\nend;\r\n\r\nprocedure TJclContainerImplementationParams.SetTypeAttribute(Index: TTypeAttributeID;\r\n const Value: string);\r\nbegin\r\n (InterfaceParams as TJclContainerInterfaceParams).SetTypeAttribute(Index, Value);\r\nend;\r\n\r\n//=== { TJclClassImplementationParams } ======================================\r\n\r\nfunction TJclClassImplementationParams.GetMacroFooter: string;\r\nvar\r\n Ownership, SelfClassName, ConstructorParameters: string;\r\nbegin\r\n if GetTypeAttribute(taOwnershipParameterName) <> '' then\r\n Ownership := 'False'\r\n else\r\n Ownership := '';\r\n\r\n SelfClassName := GetSelfClassName;\r\n ConstructorParameters := GetConstructorParameters;\r\n\r\n Result := FMacroFooter;\r\n\r\n if (Result = '') and TypeInfo.KnownType then\r\n begin\r\n if (ConstructorParameters <> '') and (Ownership <> '') then\r\n ConstructorParameters := ConstructorParameters + ', ' + Ownership\r\n else\r\n if ConstructorParameters = '' then\r\n ConstructorParameters := Ownership;\r\n if ConstructorParameters <> '' then\r\n ConstructorParameters := '(' + ConstructorParameters + ')';\r\n Result := Format(NativeLineBreak + NativeLineBreak +\r\n 'function %s.CreateEmptyContainer: TJclAbstractContainerBase;' + NativeLineBreak +\r\n 'begin' + NativeLineBreak +\r\n ' Result := %s.Create%s;' + NativeLineBreak +\r\n ' AssignPropertiesTo(Result);' + NativeLineBreak +\r\n 'end;' + NativeLineBreak,\r\n [SelfClassName, SelfClassName, ConstructorParameters]);\r\n end;\r\nend;\r\n\r\nprocedure TJclClassImplementationParams.ResetDefault(Value: Boolean);\r\nbegin\r\n inherited ResetDefault(Value);\r\n FMacroFooter := '';\r\n if not Value then\r\n FMacroFooter := GetMacroFooter;\r\nend;\r\n\r\ninitialization\r\n RegisterJclContainers;\r\n {$IFDEF UNITVERSIONING}\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n {$ENDIF UNITVERSIONING}\r\n\r\nfinalization\r\n {$IFDEF UNITVERSIONING}\r\n UnregisterUnitVersion(HInstance);\r\n {$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jcl/source/common/JclPreProcessorContainer2DTemplates.pas", "content": "{**************************************************************************************************}\r\n{ }\r\n{ Project JEDI Code Library (JCL) }\r\n{ }\r\n{ The contents of this file are subject to the Mozilla Public License Version 1.1 (the \"License\"); }\r\n{ you may not use this file except in compliance with the License. You may obtain a copy of the }\r\n{ License at http://www.mozilla.org/MPL/ }\r\n{ }\r\n{ Software distributed under the License is distributed on an \"AS IS\" basis, WITHOUT WARRANTY OF }\r\n{ ANY KIND, either express or implied. See the License for the specific language governing rights }\r\n{ and limitations under the License. }\r\n{ }\r\n{ The Original Code is JclContainer2DTemplates.pas. }\r\n{ }\r\n{ The Initial Developer of the Original Code is Florent Ouchet }\r\n{ }\r\n{ Portions created by Florent Ouchet are Copyright (C) of Florent Ouchet. All rights reserved. }\r\n{ }\r\n{ Contributors: }\r\n{ }\r\n{**************************************************************************************************}\r\n{ }\r\n{ Last modified: $Date:: 2012-02-20 19:48:39 +0100 (lun. 20 févr. 2012) $ }\r\n{ Revision: $Rev:: 3737 $ }\r\n{ Author: $Author:: outchy $ }\r\n{ }\r\n{**************************************************************************************************}\r\n\r\nunit JclPreProcessorContainer2DTemplates;\r\n\r\ninterface\r\n\r\n{$I jcl.inc}\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n JclBase,\r\n JclPreProcessorContainerTypes,\r\n JclPreProcessorContainer1DTemplates;\r\n\r\n{$TYPEINFO ON}\r\n\r\ntype\r\n TJclContainerMapInfo = class\r\n private\r\n FCustomMapAttributes: TMapAttributes;\r\n FKnownMapAttributes: PKnownMapAttributes;\r\n FValueTypeInfo: TJclContainerTypeInfo;\r\n FKeyTypeInfo: TJclContainerTypeInfo;\r\n function GetCustomMapAttribute(Index: TMapAttributeID): string;\r\n function GetKeyAttribute(Index: TKeyAttributeID): string;\r\n function GetValueAttribute(Index: TValueAttributeID): string;\r\n procedure SetKeyAttribute(Index: TKeyAttributeID; const Value: string);\r\n procedure SetValueAttribute(Index: TValueAttributeID;\r\n const Value: string);\r\n function GetKeyOwnershipDeclaration: string;\r\n function GetValueOwnershipDeclaration: string;\r\n protected\r\n function GetKnownMap: Boolean;\r\n function GetMapAttribute(Index: TMapAttributeID): string;\r\n function IsMapAttributeStored(Index: TMapAttributeID): Boolean;\r\n procedure SetKnownMap(Value: Boolean);\r\n procedure SetMapAttribute(Index: TMapAttributeID; const Value: string);\r\n procedure TypeKnownTypeChange(Sender: TObject);\r\n public\r\n constructor Create;\r\n destructor Destroy; override;\r\n property KnownMap: Boolean read GetKnownMap write SetKnownMap;\r\n property KnownMapAttributes: PKnownMapAttributes read FKnownMapAttributes;\r\n property CustomMapAttributes[Index: TMapAttributeID]: string read GetCustomMapAttribute;\r\n property MapAttributes[Index: TMapAttributeID]: string read GetMapAttribute write SetMapAttribute;\r\n property KeyAttributes[Index: TKeyAttributeID]: string read GetKeyAttribute write SetKeyAttribute;\r\n property KeyTypeInfo: TJclContainerTypeInfo read FKeyTypeInfo;\r\n property KeyOwnershipDeclaration: string read GetKeyOwnershipDeclaration;\r\n property ValueAttributes[Index: TValueAttributeID]: string read GetValueAttribute write SetValueAttribute;\r\n property ValueTypeInfo: TJclContainerTypeInfo read FValueTypeInfo;\r\n property ValueOwnershipDeclaration: string read GetValueOwnershipDeclaration;\r\n end;\r\n\r\n TJclMapInterfaceParams = class(TJclInterfaceParams)\r\n private\r\n FMapInfo: TJclContainerMapInfo;\r\n function GetKeyOwnershipDeclaration: string;\r\n function GetValueOwnershipDeclaration: string;\r\n protected\r\n function GetKeyAttribute(Index: TKeyAttributeID): string;\r\n function GetMapAttribute(Index: TMapAttributeID): string;\r\n function GetValueAttribute(Index: TValueAttributeID): string;\r\n function IsMapAttributeStored(Index: TMapAttributeID): Boolean;\r\n procedure SetKeyAttribute(Index: TKeyAttributeID; const Value: string);\r\n procedure SetMapAttribute(Index: TMapAttributeID; const Value: string);\r\n procedure SetValueAttribute(Index: TValueAttributeID; const Value: string);\r\n public\r\n property KeyOwnershipDeclaration: string read GetKeyOwnershipDeclaration;\r\n property MapInfo: TJclContainerMapInfo read FMapInfo write FMapInfo;\r\n property ValueOwnershipDeclaration: string read GetValueOwnershipDeclaration;\r\n end;\r\n\r\n TJclMapClassInterfaceParams = class(TJclMapInterfaceParams)\r\n protected\r\n FInterfaceAdditional: string;\r\n FSectionAdditional: string;\r\n function GetInterfaceAdditional: string; virtual;\r\n function GetSectionAdditional: string; virtual;\r\n function GetComparisonSectionAdditional: string; virtual; abstract;\r\n public\r\n property InterfaceAdditional: string read GetInterfaceAdditional write FInterfaceAdditional;\r\n property SectionAdditional: string read GetSectionAdditional write FSectionAdditional;\r\n property KeyTypeName: string index kaKeyTypeName read GetKeyAttribute write SetKeyAttribute stored False;\r\n property ValueTypeName: string index vaValueTypeName read GetValueAttribute write SetValueAttribute stored False;\r\n end;\r\n\r\n TJclMapImplementationParams = class(TJclImplementationParams)\r\n private\r\n function GetKeyOwnershipDeclaration: string;\r\n function GetValueOwnershipDeclaration: string;\r\n function GetMapInfo: TJclContainerMapInfo;\r\n protected\r\n function GetKeyAttribute(Index: TKeyAttributeID): string;\r\n function GetMapAttribute(Index: TMapAttributeID): string;\r\n function GetValueAttribute(Index: TValueAttributeID): string;\r\n procedure SetKeyAttribute(Index: TKeyAttributeID; const Value: string);\r\n procedure SetMapAttribute(Index: TMapAttributeID; const Value: string);\r\n procedure SetValueAttribute(Index: TValueAttributeID; const Value: string);\r\n public\r\n property KeyOwnershipDeclaration: string read GetKeyOwnershipDeclaration;\r\n property ValueOwnershipDeclaration: string read GetValueOwnershipDeclaration;\r\n property MapInfo: TJclContainerMapInfo read GetMapInfo;\r\n end;\r\n\r\n TJclMapClassImplementationParams = class(TJclMapImplementationParams)\r\n protected\r\n FCreateKeySet: string;\r\n FCreateValueCollection: string;\r\n FMacroFooter: string;\r\n FOwnershipAssignments: string;\r\n function GetCreateKeySet: string;\r\n function GetCreateValueCollection: string;\r\n function GetOwnershipAssignment: string;\r\n function GetSelfClassName: string; virtual; abstract;\r\n public\r\n function GetConstructorParameters: string; virtual; abstract;\r\n function GetMacroFooter: string; override;\r\n procedure ResetDefault(Value: Boolean); override;\r\n property MacroFooter: string read GetMacroFooter write FMacroFooter;\r\n property KeyTypeName: string index kaKeyTypeName read GetKeyAttribute write SetKeyAttribute stored False;\r\n property KeyDefault: string index kaKeyDefaultValue read GetKeyAttribute write SetKeyAttribute stored False;\r\n property KeyArraySetClassName: string index kaKeyArraySetClassName read GetKeyAttribute write SetKeyAttribute stored False;\r\n property ValueTypeName: string index vaValueTypeName read GetValueAttribute write SetValueAttribute stored False;\r\n property ValueDefault: string index vaValueDefaultValue read GetValueAttribute write SetValueAttribute stored False;\r\n property ValueArrayListClassName: string index vaValueArrayListClassName read GetValueAttribute write SetValueAttribute stored False;\r\n property OwnershipAssignments: string read GetOwnershipAssignment write FOwnershipAssignments;\r\n property CreateKeySet: string read GetCreateKeySet write FCreateKeySet;\r\n property CreateValueCollection: string read GetCreateValueCollection write FCreateValueCollection;\r\n end;\r\n\r\n{$IFNDEF TYPEINFO_ON}\r\n {$TYPEINFO OFF}\r\n{$ENDIF ~TYPEINFO_ON}\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jcl.svn.sourceforge.net/svnroot/jcl/tags/JCL-2.4-Build4571/jcl/source/common/JclPreProcessorContainer2DTemplates.pas $';\r\n Revision: '$Revision: 3737 $';\r\n Date: '$Date: 2012-02-20 19:48:39 +0100 (lun. 20 févr. 2012) $';\r\n LogPath: 'JCL\\source\\common';\r\n Extra: '';\r\n Data: nil\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n {$IFDEF HAS_UNITSCOPE}\r\n System.TypInfo,\r\n System.SysUtils,\r\n Winapi.ActiveX,\r\n System.Win.ComObj,\r\n {$ELSE ~HAS_UNITSCOPE}\r\n TypInfo,\r\n SysUtils,\r\n ActiveX,\r\n ComObj,\r\n {$ENDIF ~HAS_UNITSCOPE}\r\n JclRTTI,\r\n JclSysUtils,\r\n JclContainerIntf,\r\n JclPreProcessorContainerKnownMaps;\r\n\r\n//=== { TJclContainerMapInfo } ===============================================\r\n\r\nconstructor TJclContainerMapInfo.Create;\r\nbegin\r\n inherited Create;\r\n FKeyTypeInfo := TJclContainerTypeInfo.Create;\r\n FKeyTypeInfo.OnKnownTypeChange := TypeKnownTypeChange;\r\n FValueTypeInfo := TJclContainerTypeInfo.Create;\r\n FValueTypeInfo.OnKnownTypeChange := TypeKnownTypeChange;\r\nend;\r\n\r\ndestructor TJclContainerMapInfo.Destroy;\r\nbegin\r\n FKeyTypeInfo.Free;\r\n FValueTypeInfo.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJclContainerMapInfo.GetCustomMapAttribute(Index: TMapAttributeID): string;\r\nbegin\r\n if (Index >= Low(TMapAttributeID)) and (Index <= High(TMapAttributeID)) then\r\n Result := FCustomMapAttributes[Index]\r\n else\r\n begin\r\n Error(reRangeError);\r\n Result := '';\r\n end;\r\nend;\r\n\r\nfunction TJclContainerMapInfo.GetKeyAttribute(Index: TKeyAttributeID): string;\r\nbegin\r\n if Index = kaKeyTypeName then\r\n Result := KeyTypeInfo.TypeName\r\n else\r\n if (Index >= Low(TKeyAttributeID)) and (Index <= High(TKeyAttributeID)) then\r\n Result := KeyTypeInfo.TypeAttributes[KeyAttributeInfos[Index]]\r\n else\r\n begin\r\n Error(reRangeError);\r\n Result := '';\r\n end;\r\nend;\r\n\r\nfunction TJclContainerMapInfo.GetKeyOwnershipDeclaration: string;\r\nbegin\r\n Result := GetKeyAttribute(kaKeyOwnershipParameterName);\r\n if Result <> '' then\r\n Result := 'AOwnsKeys: Boolean';\r\nend;\r\n\r\nfunction TJclContainerMapInfo.GetKnownMap: Boolean;\r\nvar\r\n Index: TMapAttributeID;\r\nbegin\r\n Result := Assigned(FKnownMapAttributes) and KeyTypeInfo.KnownType and ValueTypeInfo.KnownType;\r\n for Index := Low(TMapAttributeID) to High(TMapAttributeID) do\r\n begin\r\n Result := Result and (FCustomMapAttributes[Index] = '');\r\n if not Result then\r\n Break;\r\n end;\r\nend;\r\n\r\nfunction TJclContainerMapInfo.GetMapAttribute(\r\n Index: TMapAttributeID): string;\r\nbegin\r\n if (Index >= Low(TMapAttributeID)) and (Index <= High(TMapAttributeID)) then\r\n begin\r\n if FCustomMapAttributes[Index] = '' then\r\n begin\r\n if Assigned(FKnownMapAttributes) then\r\n Result := FKnownMapAttributes^.MapAttributes[Index]\r\n else\r\n Result := Format(MapAttributeInfos[Index].DefaultValue, [KeyTypeInfo.TypeName, ValueTypeInfo.TypeName]);\r\n end\r\n else\r\n Result := FCustomMapAttributes[Index];\r\n end\r\n else\r\n begin\r\n Error(reRangeError);\r\n Result := '';\r\n end;\r\nend;\r\n\r\nfunction TJclContainerMapInfo.GetValueAttribute(Index: TValueAttributeID): string;\r\nbegin\r\n if Index = vaValueTypeName then\r\n Result := ValueTypeInfo.TypeName\r\n else\r\n if (Index >= Low(TValueAttributeID)) and (Index <= High(TValueAttributeID)) then\r\n Result := ValueTypeInfo.TypeAttributes[ValueAttributeInfos[Index]]\r\n else\r\n begin\r\n Error(reRangeError);\r\n Result := '';\r\n end;\r\nend;\r\n\r\nfunction TJclContainerMapInfo.GetValueOwnershipDeclaration: string;\r\nbegin\r\n Result := GetValueAttribute(vaValueOwnershipParameterName);\r\n if Result <> '' then\r\n Result := 'AOwnsValues: Boolean';\r\nend;\r\n\r\nfunction TJclContainerMapInfo.IsMapAttributeStored(Index: TMapAttributeID): Boolean;\r\nbegin\r\n if (Index >= Low(TMapAttributeID)) and (Index <= High(TMapAttributeID)) then\r\n Result := FCustomMapAttributes[Index] <> ''\r\n else\r\n begin\r\n Error(reRangeError);\r\n Result := False;\r\n end;\r\nend;\r\n\r\nprocedure TJclContainerMapInfo.SetKeyAttribute(Index: TKeyAttributeID;\r\n const Value: string);\r\nbegin\r\n if Index = kaKeyTypeName then\r\n KeyTypeInfo.TypeName := Value\r\n else\r\n if (Index >= Low(TKeyAttributeID)) and (Index <= High(TKeyAttributeID)) then\r\n KeyTypeInfo.TypeAttributes[KeyAttributeInfos[Index]] := Value\r\n else\r\n Error(reRangeError);\r\nend;\r\n\r\nprocedure TJclContainerMapInfo.SetKnownMap(Value: Boolean);\r\nvar\r\n Index: TMapAttributeID;\r\n NewGUID: TGUID;\r\nbegin\r\n if Value then\r\n begin\r\n // reset to default values\r\n for Index := Low(TMapAttributeID) to High(TMapAttributeID) do\r\n FCustomMapAttributes[Index] := '';\r\n end\r\n else\r\n if {not Value and} Assigned(FKnownMapAttributes) then\r\n begin\r\n // copy with new GUIDs\r\n for Index := Low(TMapAttributeID) to High(TMapAttributeID) do\r\n begin\r\n if MapAttributeInfos[Index].IsGUID then\r\n begin\r\n OleCheck(CoCreateGuid(NewGUID));\r\n FCustomMapAttributes[Index] := GUIDToString(NewGUID);\r\n end\r\n else\r\n FCustomMapAttributes[Index] := FKnownMapAttributes^.MapAttributes[Index];\r\n end;\r\n end\r\n else\r\n begin\r\n {not Value and not Assigned(FKnownTypeAttributes)}\r\n // default names with new GUIDs\r\n for Index := Low(TMapAttributeID) to High(TMapAttributeID) do\r\n begin\r\n if MapAttributeInfos[Index].IsGUID then\r\n begin\r\n OleCheck(CoCreateGuid(NewGUID));\r\n FCustomMapAttributes[Index] := GUIDToString(NewGUID);\r\n end\r\n else\r\n FCustomMapAttributes[Index] := Format(MapAttributeInfos[Index].DefaultValue,\r\n [KeyTypeInfo.TypeName, ValueTypeInfo.TypeName]);\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJclContainerMapInfo.SetMapAttribute(Index: TMapAttributeID;\r\n const Value: string);\r\nbegin\r\n if (Index >= Low(TMapAttributeID)) and (Index <= High(TMapAttributeID)) then\r\n FCustomMapAttributes[Index] := Value\r\n else\r\n Error(reRangeError);\r\nend;\r\n\r\nprocedure TJclContainerMapInfo.SetValueAttribute(Index: TValueAttributeID;\r\n const Value: string);\r\nbegin\r\n if Index = vaValueTypeName then\r\n ValueTypeInfo.TypeName := Value\r\n else\r\n if (Index >= Low(TValueAttributeID)) and (Index <= High(TValueAttributeID)) then\r\n ValueTypeInfo.TypeAttributes[ValueAttributeInfos[Index]] := Value\r\n else\r\n Error(reRangeError);\r\nend;\r\n\r\nprocedure TJclContainerMapInfo.TypeKnownTypeChange(Sender: TObject);\r\nbegin\r\n if KeyTypeInfo.KnownType and ValueTypeInfo.KnownType then\r\n begin\r\n FKnownMapAttributes := IsKnownMap(KeyTypeInfo.TypeName, ValueTypeInfo.TypeName);\r\n SetKnownMap(True);\r\n end;\r\nend;\r\n\r\n//=== { TJclMapInterfaceParams } =============================================\r\n\r\nfunction TJclMapInterfaceParams.GetKeyAttribute(Index: TKeyAttributeID): string;\r\nbegin\r\n Result := MapInfo.KeyAttributes[Index];\r\nend;\r\n\r\nfunction TJclMapInterfaceParams.GetKeyOwnershipDeclaration: string;\r\nbegin\r\n Result := MapInfo.KeyOwnershipDeclaration;\r\n if Result <> '' then\r\n Result := '; ' + Result;\r\nend;\r\n\r\nfunction TJclMapInterfaceParams.GetMapAttribute(\r\n Index: TMapAttributeID): string;\r\nbegin\r\n Result := MapInfo.MapAttributes[Index];\r\nend;\r\n\r\nfunction TJclMapInterfaceParams.GetValueAttribute(\r\n Index: TValueAttributeID): string;\r\nbegin\r\n Result := MapInfo.ValueAttributes[Index];\r\nend;\r\n\r\nfunction TJclMapInterfaceParams.GetValueOwnershipDeclaration: string;\r\nbegin\r\n Result := MapInfo.ValueOwnershipDeclaration;\r\n if Result <> '' then\r\n Result := '; ' + Result;\r\nend;\r\n\r\nfunction TJclMapInterfaceParams.IsMapAttributeStored(\r\n Index: TMapAttributeID): Boolean;\r\nbegin\r\n Result := MapInfo.CustomMapAttributes[Index] <> '';\r\nend;\r\n\r\nprocedure TJclMapInterfaceParams.SetKeyAttribute(Index: TKeyAttributeID;\r\n const Value: string);\r\nbegin\r\n MapInfo.KeyAttributes[Index] := Value;\r\nend;\r\n\r\nprocedure TJclMapInterfaceParams.SetMapAttribute(Index: TMapAttributeID;\r\n const Value: string);\r\nbegin\r\n MapInfo.MapAttributes[Index] := Value;\r\nend;\r\n\r\nprocedure TJclMapInterfaceParams.SetValueAttribute(Index: TValueAttributeID;\r\n const Value: string);\r\nbegin\r\n MapInfo.ValueAttributes[Index] := Value;\r\nend;\r\n\r\n//=== { TJclMapClassInterfaceParams } ========================================\r\n\r\nfunction TJclMapClassInterfaceParams.GetInterfaceAdditional: string;\r\nbegin\r\n Result := FInterfaceAdditional;\r\n if Result = '' then\r\n begin\r\n if MapInfo.KeyTypeInfo.StringType or MapInfo.ValueTypeInfo.StringType then\r\n Result := ' IJclStrBaseContainer,';\r\n if MapInfo.KeyTypeInfo.TypeAttributes[taContainerInterfaceName] <> '' then\r\n Result := Format('%s %s,', [Result, MapInfo.KeyTypeInfo.TypeAttributes[taContainerInterfaceName]]);\r\n if (MapInfo.KeyTypeInfo.TypeName <> MapInfo.ValueTypeInfo.TypeName) and (MapInfo.ValueTypeInfo.TypeAttributes[taContainerInterfaceName] <> '') then\r\n Result := Format('%s %s,', [Result, MapInfo.ValueTypeInfo.TypeAttributes[taContainerInterfaceName]]);\r\n if MapInfo.KeyTypeInfo.TObjectType then\r\n Result := Result + ' IJclKeyOwner,';\r\n if MapInfo.ValueTypeInfo.TObjectType then\r\n Result := Result + ' IJclValueOwner,';\r\n end;\r\nend;\r\n\r\nfunction TJclMapClassInterfaceParams.GetSectionAdditional: string;\r\nbegin\r\n Result := FSectionAdditional;\r\n if (Result = '') and MapInfo.KnownMap then\r\n begin\r\n Result := NativeLineBreak +\r\n 'protected' + NativeLineBreak +\r\n ' function CreateEmptyContainer: TJclAbstractContainerBase; override;' + NativeLineBreak;\r\n\r\n if not MapInfo.KeyTypeInfo.TObjectType then\r\n Result := Format('%s function FreeKey(var Key: %s): %s;' + NativeLineBreak,\r\n [Result, KeyTypeName, KeyTypeName]);\r\n if not MapInfo.ValueTypeInfo.TObjectType then\r\n Result := Format('%s function FreeValue(var Value: %s): %s;' + NativeLineBreak,\r\n [Result, ValueTypeName, ValueTypeName]);\r\n\r\n Result := Result + GetComparisonSectionAdditional;\r\n\r\n if MapInfo.KeyTypeInfo.TObjectType or MapInfo.ValueTypeInfo.TObjectType then\r\n begin\r\n if MapInfo.ValueTypeInfo.TObjectType then\r\n Result := ' FOwnsValues: Boolean;' + Result;\r\n if MapInfo.KeyTypeInfo.TObjectType then\r\n Result := ' FOwnsKeys: Boolean;' + NativeLineBreak + Result;\r\n Result := NativeLineBreak + 'private' + NativeLineBreak + Result + NativeLineBreak + 'public' + NativeLineBreak;\r\n if MapInfo.KeyTypeInfo.TObjectType then\r\n Result := Result + ' { IJclKeyOwner }' + NativeLineBreak +\r\n ' function FreeKey(var Key: TObject): TObject;' + NativeLineBreak +\r\n ' function GetOwnsKeys: Boolean;' + NativeLineBreak +\r\n ' property OwnsKeys: Boolean read FOwnsKeys;';\r\n if MapInfo.KeyTypeInfo.TObjectType and MapInfo.ValueTypeInfo.TObjectType then\r\n Result := Result + NativeLineBreak;\r\n if MapInfo.ValueTypeInfo.TObjectType then\r\n Result := Result + ' { IJclValueOwner }' + NativeLineBreak +\r\n ' function FreeValue(var Value: TObject): TObject;' + NativeLineBreak +\r\n ' function GetOwnsValues: Boolean;' + NativeLineBreak +\r\n ' property OwnsValues: Boolean read FOwnsValues;';\r\n end;\r\n end\r\nend;\r\n\r\n//=== { TJclMapImplementationParams } ========================================\r\n\r\nfunction TJclMapImplementationParams.GetKeyAttribute(\r\n Index: TKeyAttributeID): string;\r\nbegin\r\n Result := (InterfaceParams as TJclMapInterfaceParams).GetKeyAttribute(Index);\r\nend;\r\n\r\nfunction TJclMapImplementationParams.GetKeyOwnershipDeclaration: string;\r\nbegin\r\n Result := (InterfaceParams as TJclMapInterfaceParams).GetKeyOwnershipDeclaration;\r\nend;\r\n\r\nfunction TJclMapImplementationParams.GetMapAttribute(\r\n Index: TMapAttributeID): string;\r\nbegin\r\n Result := (InterfaceParams as TJclMapInterfaceParams).GetMapAttribute(Index);\r\nend;\r\n\r\nfunction TJclMapImplementationParams.GetMapInfo: TJclContainerMapInfo;\r\nbegin\r\n Result := (InterfaceParams as TJclMapInterfaceParams).MapInfo;\r\nend;\r\n\r\nfunction TJclMapImplementationParams.GetValueAttribute(\r\n Index: TValueAttributeID): string;\r\nbegin\r\n Result := (InterfaceParams as TJclMapInterfaceParams).GetValueAttribute(Index);\r\nend;\r\n\r\nfunction TJclMapImplementationParams.GetValueOwnershipDeclaration: string;\r\nbegin\r\n Result := (InterfaceParams as TJclMapInterfaceParams).GetValueOwnershipDeclaration;\r\nend;\r\n\r\nprocedure TJclMapImplementationParams.SetKeyAttribute(Index: TKeyAttributeID;\r\n const Value: string);\r\nbegin\r\n (InterfaceParams as TJclMapInterfaceParams).SetKeyAttribute(Index, Value);\r\nend;\r\n\r\nprocedure TJclMapImplementationParams.SetMapAttribute(Index: TMapAttributeID;\r\n const Value: string);\r\nbegin\r\n (InterfaceParams as TJclMapInterfaceParams).SetMapAttribute(Index, Value);\r\nend;\r\n\r\nprocedure TJclMapImplementationParams.SetValueAttribute(\r\n Index: TValueAttributeID; const Value: string);\r\nbegin\r\n (InterfaceParams as TJclMapInterfaceParams).SetValueAttribute(Index, Value);\r\nend;\r\n\r\n//=== { TJclMapClassImplementationParams } ===================================\r\n\r\nfunction TJclMapClassImplementationParams.GetCreateKeySet: string;\r\nvar\r\n Ownership: string;\r\nbegin\r\n Result := FCreateKeySet;\r\n if Result = '' then\r\n begin\r\n if MapInfo.KeyTypeInfo.TypeAttributes[taOwnershipParameterName] <> '' then\r\n Ownership := ', False'\r\n else\r\n Ownership := '';\r\n Result := Format('%s.Create(FSize%s)', [KeyArraySetClassName, Ownership]);\r\n end;\r\nend;\r\n\r\nfunction TJclMapClassImplementationParams.GetCreateValueCollection: string;\r\nvar\r\n Ownership: string;\r\nbegin\r\n Result := FCreateValueCollection;\r\n if Result = '' then\r\n begin\r\n if MapInfo.ValueTypeInfo.TypeAttributes[taOwnershipParameterName] <> '' then\r\n Ownership := ', False'\r\n else\r\n Ownership := '';\r\n Result := Format('%s.Create(FSize%s)', [ValueArrayListClassName, Ownership]);\r\n end;\r\nend;\r\n\r\nfunction TJclMapClassImplementationParams.GetMacroFooter: string;\r\nvar\r\n Ownership, SelfClassName, ConstructorParameters,\r\n FuncBody: string;\r\nbegin\r\n Result := FMacroFooter;\r\n\r\n if (Result = '') and MapInfo.KnownMap then\r\n begin\r\n if GetKeyAttribute(kaKeyOwnershipParameterName) <> '' then\r\n begin\r\n if GetValueAttribute(vaValueOwnershipParameterName) <> '' then\r\n Ownership := 'False, False'\r\n else\r\n Ownership := 'False';\r\n end\r\n else\r\n begin\r\n if GetValueAttribute(vaValueOwnershipParameterName) <> '' then\r\n Ownership := 'False'\r\n else\r\n Ownership := '';\r\n end;\r\n\r\n SelfClassName := GetSelfClassName;\r\n ConstructorParameters := GetConstructorParameters;\r\n\r\n if (ConstructorParameters <> '') and (Ownership <> '') then\r\n ConstructorParameters := ConstructorParameters + ', ' + Ownership\r\n else\r\n if ConstructorParameters = '' then\r\n ConstructorParameters := Ownership;\r\n if ConstructorParameters <> '' then\r\n ConstructorParameters := '(' + ConstructorParameters + ')';\r\n Result := Format(NativeLineBreak + NativeLineBreak +\r\n 'function %s.CreateEmptyContainer: TJclAbstractContainerBase;' + NativeLineBreak +\r\n 'begin' + NativeLineBreak +\r\n ' Result := %s.Create%s;' + NativeLineBreak +\r\n ' AssignPropertiesTo(Result);' + NativeLineBreak +\r\n 'end;' + NativeLineBreak,\r\n [SelfClassName, SelfClassName, ConstructorParameters]);\r\n\r\n if MapInfo.KeyTypeInfo.TObjectType then\r\n FuncBody := Format(' if FOwnsKeys then' + NativeLineBreak +\r\n ' begin' + NativeLineBreak +\r\n ' Result := %s;' + NativeLineBreak +\r\n ' FreeAndNil(Key);' + NativeLineBreak +\r\n ' end' + NativeLineBreak +\r\n ' else' + NativeLineBreak +\r\n ' begin' + NativeLineBreak +\r\n ' Result := Key;' + NativeLineBreak +\r\n ' Key := %s;' + NativeLineBreak +\r\n ' end;' + NativeLineBreak,\r\n [KeyDefault, KeyDefault])\r\n else\r\n FuncBody := Format(' Result := Key;' + NativeLineBreak +\r\n ' Key := %s;' + NativeLineBreak, [KeyDefault]);\r\n\r\n Result := Format('%s' + NativeLineBreak +\r\n 'function %s.FreeKey(var Key: %s): %s;' + NativeLineBreak +\r\n 'begin' + NativeLineBreak +\r\n '%s' +\r\n 'end;' + NativeLineBreak,\r\n [Result, SelfClassName, KeyTypeName, KeyTypeName, FuncBody]);\r\n\r\n if MapInfo.ValueTypeInfo.TObjectType then\r\n FuncBody := Format(' if FOwnsValues then' + NativeLineBreak +\r\n ' begin' + NativeLineBreak +\r\n ' Result := %s;' + NativeLineBreak +\r\n ' FreeAndNil(Value);' + NativeLineBreak +\r\n ' end' + NativeLineBreak +\r\n ' else' + NativeLineBreak +\r\n ' begin' + NativeLineBreak +\r\n ' Result := Value;' + NativeLineBreak +\r\n ' Value := %s;' + NativeLineBreak +\r\n ' end;' + NativeLineBreak,\r\n [ValueDefault, ValueDefault])\r\n else\r\n FuncBody := Format(' Result := Value;' + NativeLineBreak +\r\n ' Value := %s;' + NativeLineBreak, [ValueDefault]);\r\n\r\n Result := Format('%s' + NativeLineBreak +\r\n 'function %s.FreeValue(var Value: %s): %s;' + NativeLineBreak +\r\n 'begin' + NativeLineBreak +\r\n '%s' +\r\n 'end;' + NativeLineBreak,\r\n [Result, SelfClassName, ValueTypeName, ValueTypeName, FuncBody]);\r\n\r\n if MapInfo.KeyTypeInfo.TObjectType then\r\n begin\r\n Result := Format('%s' + NativeLineBreak +\r\n 'function %s.GetOwnsKeys: Boolean;' + NativeLineBreak +\r\n 'begin' + NativeLineBreak +\r\n ' Result := FOwnsKeys;' + NativeLineBreak +\r\n 'end;' + NativeLineBreak,\r\n [Result, SelfClassName]);\r\n end;\r\n\r\n if MapInfo.ValueTypeInfo.TObjectType then\r\n begin\r\n Result := Format('%s' + NativeLineBreak +\r\n 'function %s.GetOwnsValues: Boolean;' + NativeLineBreak +\r\n 'begin' + NativeLineBreak +\r\n ' Result := FOwnsValues;' + NativeLineBreak +\r\n 'end;' + NativeLineBreak,\r\n [Result, SelfClassName]);\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJclMapClassImplementationParams.GetOwnershipAssignment: string;\r\nbegin\r\n Result := FOwnershipAssignments;\r\n if Result = '' then\r\n begin\r\n if MapInfo.KeyTypeInfo.TObjectType then\r\n Result := NativeLineBreak + ' FOwnsKeys := AOwnsKeys;';\r\n if MapInfo.ValueTypeInfo.TObjectType then\r\n Result := Result + NativeLineBreak + ' FOwnsValues := AOwnsValues;';\r\n end;\r\nend;\r\n\r\nprocedure TJclMapClassImplementationParams.ResetDefault(Value: Boolean);\r\nbegin\r\n inherited ResetDefault(Value);\r\n FCreateKeySet := '';\r\n FCreateValueCollection := '';\r\n FMacroFooter := '';\r\n FOwnershipAssignments := '';\r\n if not Value then\r\n begin\r\n FCreateKeySet := GetCreateKeySet;\r\n FCreateValueCollection := GetCreateValueCollection;\r\n FMacroFooter := GetMacroFooter;\r\n FOwnershipAssignments := GetOwnershipAssignment;\r\n end;\r\nend;\r\n\r\ninitialization\r\n {$IFDEF UNITVERSIONING}\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n {$ENDIF UNITVERSIONING}\r\n\r\nfinalization\r\n {$IFDEF UNITVERSIONING}\r\n UnregisterUnitVersion(HInstance);\r\n {$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jcl/source/common/JclPreProcessorContainerIntfTemplates.pas", "content": "{**************************************************************************************************}\r\n{ }\r\n{ Project JEDI Code Library (JCL) }\r\n{ }\r\n{ The contents of this file are subject to the Mozilla Public License Version 1.1 (the \"License\"); }\r\n{ you may not use this file except in compliance with the License. You may obtain a copy of the }\r\n{ License at http://www.mozilla.org/MPL/ }\r\n{ }\r\n{ Software distributed under the License is distributed on an \"AS IS\" basis, WITHOUT WARRANTY OF }\r\n{ ANY KIND, either express or implied. See the License for the specific language governing rights }\r\n{ and limitations under the License. }\r\n{ }\r\n{ The Original Code is JclContainerIntfTemplates.pas. }\r\n{ }\r\n{ The Initial Developer of the Original Code is Florent Ouchet }\r\n{ }\r\n{ Portions created by Florent Ouchet are Copyright (C) of Florent Ouchet. All rights reserved. }\r\n{ }\r\n{ Contributors: }\r\n{ }\r\n{**************************************************************************************************}\r\n{ }\r\n{ Last modified: $Date:: 2012-02-20 19:48:39 +0100 (lun. 20 févr. 2012) $ }\r\n{ Revision: $Rev:: 3737 $ }\r\n{ Author: $Author:: outchy $ }\r\n{ }\r\n{**************************************************************************************************}\r\n\r\nunit JclPreProcessorContainerIntfTemplates;\r\n\r\ninterface\r\n\r\n{$I jcl.inc}\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n JclPreProcessorContainerTypes,\r\n JclPreProcessorContainerTemplates,\r\n JclPreProcessorContainer1DTemplates,\r\n JclPreProcessorContainer2DTemplates;\r\n\r\ntype\r\n TJclContainerIntf1DParams = class(TJclContainerInterfaceParams)\r\n protected\r\n // function CodeUnit: string; override;\r\n end;\r\n\r\n TJclContainerIntf2DParams = class(TJclMapInterfaceParams)\r\n protected\r\n // function CodeUnit: string; override;\r\n end;\r\n\r\n TJclContainerIntfAncestorParams = class(TJclContainerIntf1DParams)\r\n protected\r\n FAncestorName: string;\r\n function GetAncestorName: string; virtual;\r\n function IsAncestorNameStored: Boolean;\r\n public\r\n property AncestorName: string read GetAncestorName write FAncestorName stored IsAncestorNameStored;\r\n end;\r\n\r\n TJclContainerIntfFlatAncestorParams = class(TJclContainerIntfAncestorParams)\r\n protected\r\n function GetAncestorName: string; override;\r\n end;\r\n\r\n (* ITERPROCEDURE(ITERATEPROCEDURETYPENAME, CONSTKEYWORD, PARAMETERNAME, TYPENAME) *)\r\n TJclIterProcedureParams = class(TJclContainerIntf1DParams)\r\n public\r\n function AliasAttributeIDs: TAllTypeAttributeIDs; override;\r\n published\r\n property IterateProcedureTypeName: string index taIterateProcedureTypeName read GetTypeAttribute write SetTypeAttribute stored IsTypeAttributeStored;\r\n property ConstKeyword: string index taConstKeyword read GetTypeAttribute write SetTypeAttribute stored False;\r\n property ParameterName: string index taParameterName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property TypeName: string index taTypeName read GetTypeAttribute write SetTypeAttribute stored False;\r\n end;\r\n\r\n (* APPLYFUNCTION(APPLYFUNCTIONTYPENAME, CONSTKEYWORD, PARAMETERNAME, TYPENAME) *)\r\n TJclApplyFunctionParams = class(TJclContainerIntf1DParams)\r\n public\r\n function AliasAttributeIDs: TAllTypeAttributeIDs; override;\r\n published\r\n property ApplyFunctionTypeName: string index taApplyFunctionTypeName read GetTypeAttribute write SetTypeAttribute stored IsTypeAttributeStored;\r\n property ConstKeyword: string index taConstKeyword read GetTypeAttribute write SetTypeAttribute stored False;\r\n property ParameterName: string index taParameterName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property TypeName: string index taTypeName read GetTypeAttribute write SetTypeAttribute stored False;\r\n end;\r\n\r\n (* COMPAREFUNCTION(COMPAREFUNCTIONTYPENAME, CONSTKEYWORD, TYPENAME) *)\r\n TJclCompareFunctionParams = class(TJclContainerIntf1DParams)\r\n public\r\n function AliasAttributeIDs: TAllTypeAttributeIDs; override;\r\n published\r\n property CompareFunctionTypeName: string index taCompareFunctionTypeName read GetTypeAttribute write SetTypeAttribute stored IsTypeAttributeStored;\r\n property ConstKeyword: string index taConstKeyword read GetTypeAttribute write SetTypeAttribute stored False;\r\n property TypeName: string index taTypeName read GetTypeAttribute write SetTypeAttribute stored False;\r\n end;\r\n\r\n (* EQUALITYCOMPAREFUNCTION(EQUALITYCOMPAREFUNCTIONTYPENAME, CONSTKEYWORD, TYPENAME) *)\r\n TJclEqualityCompareFunctionParams = class(TJclContainerIntf1DParams)\r\n public\r\n function AliasAttributeIDs: TAllTypeAttributeIDs; override;\r\n published\r\n property EqualityCompareFunctionTypeName: string index taEqualityCompareFunctionTypeName read GetTypeAttribute write SetTypeAttribute stored IsTypeAttributeStored;\r\n property ConstKeyword: string index taConstKeyword read GetTypeAttribute write SetTypeAttribute stored False;\r\n property TypeName: string index taTypeName read GetTypeAttribute write SetTypeAttribute stored False;\r\n end;\r\n\r\n (* HASHFUNCTION(HASHCONVERTFUNCTIONTYPENAME, CONSTKEYWORD, PARAMETERNAME, TYPENAME) *)\r\n TJclHashFunctionParams = class(TJclContainerIntf1DParams)\r\n public\r\n function AliasAttributeIDs: TAllTypeAttributeIDs; override;\r\n published\r\n property HashConvertFunctionTypeName: string index taHashConvertFunctionTypeName read GetTypeAttribute write SetTypeAttribute stored IsTypeAttributeStored;\r\n property ConstKeyword: string index taConstKeyword read GetTypeAttribute write SetTypeAttribute stored False;\r\n property ParameterName: string index taParameterName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property TypeName: string index taTypeName read GetTypeAttribute write SetTypeAttribute stored False;\r\n end;\r\n\r\n (* SORTPROC(SORTPROCEDURETYPENAME, LISTINTERFACENAME, COMPAREFUNCTIONTYPENAME) *)\r\n TJclSortFunctionParams = class(TJclContainerIntf1DParams)\r\n public\r\n function AliasAttributeIDs: TAllTypeAttributeIDs; override;\r\n published\r\n property SortProcedureTypeName: string index taSortProcedureTypeName read GetTypeAttribute write SetTypeAttribute stored IsTypeAttributeStored;\r\n property ListInterfaceName: string index taListInterfaceName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property CompareFunctionTypeName: string index taCompareFunctionTypeName read GetTypeAttribute write SetTypeAttribute stored False;\r\n end;\r\n\r\n (* EQUALITYCOMPARER(INTERFACENAME, GUID, EQUALITYCOMPAREFUNCTIONTYPENAME, CONSTKEYWORD, TYPENAME) *)\r\n TJclEqualityComparerParams = class(TJclContainerIntf1DParams)\r\n public\r\n function AliasAttributeIDs: TAllTypeAttributeIDs; override;\r\n published\r\n property InterfaceName: string index taEqualityComparerInterfaceName read GetTypeAttribute write SetTypeAttribute stored IsTypeAttributeStored;\r\n property GUID: string index taEqualityComparerInterfaceGUID read GetTypeAttribute write SetTypeAttribute stored IsTypeAttributeStored;\r\n property EqualityCompareFunctionTypeName: string index taEqualityCompareFunctionTypeName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property ConstKeyword: string index taConstKeyword read GetTypeAttribute write SetTypeAttribute stored False;\r\n property TypeName: string index taTypeName read GetTypeAttribute write SetTypeAttribute stored False;\r\n end;\r\n\r\n (* COMPARER(INTERFACENAME, GUID, COMPAREFUNCTIONTYPENAME, CONSTKEYWORD, TYPENAME) *)\r\n TJclComparerParams = class(TJclContainerIntf1DParams)\r\n public\r\n function AliasAttributeIDs: TAllTypeAttributeIDs; override;\r\n published\r\n property InterfaceName: string index taComparerInterfaceName read GetTypeAttribute write SetTypeAttribute stored IsTypeAttributeStored;\r\n property GUID: string index taComparerInterfaceGUID read GetTypeAttribute write SetTypeAttribute stored IsTypeAttributeStored;\r\n property CompareFunctionTypeName: string index taCompareFunctionTypeName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property ConstKeyword: string index taConstKeyword read GetTypeAttribute write SetTypeAttribute stored False;\r\n property TypeName: string index taTypeName read GetTypeAttribute write SetTypeAttribute stored False;\r\n end;\r\n\r\n (* HASHCONVERTER(INTERFACENAME, GUID, HASHCONVERTFUNCTIONTYPENAME, CONSTKEYWORD, PARAMETERNAME, TYPENAME) *)\r\n TJclHashConverterParams = class(TJclContainerIntf1DParams)\r\n public\r\n function AliasAttributeIDs: TAllTypeAttributeIDs; override;\r\n published\r\n property InterfaceName: string index taHashConverterInterfaceName read GetTypeAttribute write SetTypeAttribute stored IsTypeAttributeStored;\r\n property GUID: string index taHashConverterInterfaceGUID read GetTypeAttribute write SetTypeAttribute stored IsTypeAttributeStored;\r\n property HashConvertFunctionTypeName: string index taHashConvertFunctionTypeName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property ConstKeyword: string index taConstKeyword read GetTypeAttribute write SetTypeAttribute stored False;\r\n property ParameterName: string index taParameterName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property TypeName: string index taTypeName read GetTypeAttribute write SetTypeAttribute stored False;\r\n end;\r\n\r\n (* RELEASEEVENT(EVENTTYPENAME, PARAMETERNAME, TYPENAME) *)\r\n TJclReleaseEventParams = class(TJclContainerIntf1DParams)\r\n public\r\n function AliasAttributeIDs: TAllTypeAttributeIDs; override;\r\n published\r\n property EventTypeName: string index taReleaseEventTypeName read GetTypeAttribute write SetTypeAttribute stored IsTypeAttributeStored;\r\n property ParameterName: string index taParameterName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property TypeName: string index taTypeName read GetTypeAttribute write SetTypeAttribute stored False;\r\n end;\r\n\r\n (* OWNER(INTERFACENAME, ANCESTORNAME, GUID, RELEASERFUNCTIONNAME, RELEASEEVENTNAME, RELEASEEVENTTYPENAME, PARAMETERNAME, TYPENAME, OWNERADDITIONAL) *)\r\n TJclOwnerParams = class(TJclContainerIntfAncestorParams)\r\n protected\r\n FOwnerAdditional: string;\r\n function GetAncestorName: string; override;\r\n function GetOwnerAdditional: string;\r\n public\r\n function AliasAttributeIDs: TAllTypeAttributeIDs; override;\r\n published\r\n property InterfaceName: string index taOwnershipInterfaceName read GetTypeAttribute write SetTypeAttribute stored IsTypeAttributeStored;\r\n property AncestorName;\r\n property GUID: string index taOwnershipInterfaceGUID read GetTypeAttribute write SetTypeAttribute stored IsTypeAttributeStored;\r\n property ReleaserFunctionName: string index taReleaserFunctionName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property ReleaseEventName: string index taReleaseEventName read GetTypeAttribute write SetTypeAttribute stored IsTypeAttributeStored;\r\n property ReleaseEventTypeName: string index taReleaseEventTypeName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property ParameterName: string index taParameterName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property TypeName: string index taTypeName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property OwnerAdditional: string read GetOwnerAdditional write FOwnerAdditional;\r\n end;\r\n\r\n (* ITERATOR(INTERFACENAME, ANCESTORNAME, GUID, CONSTKEYWORD, PARAMETERNAME, TYPENAME, GETTERFUNCTIONNAME, SETTERPROCEDURENAME) *)\r\n TJclIteratorParams = class(TJclContainerIntfAncestorParams)\r\n protected\r\n function GetAncestorName: string; override;\r\n public\r\n function AliasAttributeIDs: TAllTypeAttributeIDs; override;\r\n published\r\n property InterfaceName: string index taIteratorInterfaceName read GetTypeAttribute write SetTypeAttribute stored IsTypeAttributeStored;\r\n property AncestorName;\r\n property GUID: string index taIteratorInterfaceGUID read GetTypeAttribute write SetTypeAttribute stored IsTypeAttributeStored;\r\n property ConstKeyword: string index taConstKeyword read GetTypeAttribute write SetTypeAttribute stored False;\r\n property ParameterName: string index taParameterName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property TypeName: string index taTypeName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property GetterFunctionName: string index taGetterFunctionName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property SetterProcedureName: string index taSetterProcedureName read GetTypeAttribute write SetTypeAttribute stored False;\r\n end;\r\n\r\n (* TREEITERATOR(INTERFACENAME, ANCESTORNAME, GUID, CONSTKEYWORD, PARAMETERNAME, TYPENAME) *)\r\n TJclTreeIteratorParams = class(TJclContainerIntf1DParams)\r\n public\r\n function AliasAttributeIDs: TAllTypeAttributeIDs; override;\r\n published\r\n property InterfaceName: string index taTreeIteratorInterfaceName read GetTypeAttribute write SetTypeAttribute stored IsTypeAttributeStored;\r\n property AncestorName: string index taIteratorInterfaceName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property GUID: string index taTreeIteratorInterfaceGUID read GetTypeAttribute write SetTypeAttribute stored IsTypeAttributeStored;\r\n property ConstKeyword: string index taConstKeyword read GetTypeAttribute write SetTypeAttribute stored False;\r\n property ParameterName: string index taParameterName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property TypeName: string index taTypeName read GetTypeAttribute write SetTypeAttribute stored False;\r\n end;\r\n\r\n (* BINTREEITERATOR(INTERFACENAME, ANCESTORNAME, GUID, TYPENAME) *)\r\n TJclBinaryTreeIteratorParams = class(TJclContainerIntf1DParams)\r\n public\r\n function AliasAttributeIDs: TAllTypeAttributeIDs; override;\r\n published\r\n property InterfaceName: string index taBinaryTreeIteratorInterfaceName read GetTypeAttribute write SetTypeAttribute stored IsTypeAttributeStored;\r\n property AncestorName: string index taTreeIteratorInterfaceName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property GUID: string index taBinaryTreeIteratorInterfaceGUID read GetTypeAttribute write SetTypeAttribute stored IsTypeAttributeStored;\r\n property TypeName: string index taTypeName read GetTypeAttribute write SetTypeAttribute stored False;\r\n end;\r\n\r\n (* COLLECTION(INTERFACENAME, ANCESTORNAME, GUID, CONSTKEYWORD, PARAMETERNAME, TYPENAME, ITRNAME) *)\r\n TJclCollectionParams = class(TJclContainerIntfFlatAncestorParams)\r\n public\r\n function AliasAttributeIDs: TAllTypeAttributeIDs; override;\r\n published\r\n property InterfaceName: string index taCollectionInterfaceName read GetTypeAttribute write SetTypeAttribute stored IsTypeAttributeStored;\r\n property AncestorName;\r\n property GUID: string index taCollectionInterfaceGUID read GetTypeAttribute write SetTypeAttribute stored IsTypeAttributeStored;\r\n property ConstKeyword: string index taConstKeyword read GetTypeAttribute write SetTypeAttribute stored False;\r\n property ParameterName: string index taParameterName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property TypeName: string index taTypeName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property ItrName: string index taIteratorInterfaceName read GetTypeAttribute write SetTypeAttribute stored False;\r\n end;\r\n\r\n (* LIST(INTERFACENAME, ANCESTORNAME, GUID, CONSTKEYWORD, PARAMETERNAME, TYPENAME, GETTERFUNCTIONNAME, SETTERPROCEDURENAME, ARRAYPROPERTYNAME) *)\r\n TJclListParams = class(TJclContainerIntf1DParams)\r\n public\r\n function AliasAttributeIDs: TAllTypeAttributeIDs; override;\r\n published\r\n property InterfaceName: string index taListInterfaceName read GetTypeAttribute write SetTypeAttribute stored IsTypeAttributeStored;\r\n property ListInterfaceName: string index taListInterfaceName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property AncestorName: string index taCollectionInterfaceName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property CollectionInterfaceName: string index taCollectionInterfaceName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property GUID: string index taListInterfaceGUID read GetTypeAttribute write SetTypeAttribute stored IsTypeAttributeStored;\r\n property ConstKeyword: string index taConstKeyword read GetTypeAttribute write SetTypeAttribute stored False;\r\n property ParameterName: string index taParameterName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property TypeName: string index taTypeName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property GetterFunctionName: string index taGetterFunctionName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property SetterProcedureName: string index taSetterProcedureName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property ArrayPropertyName: string index taArrayPropertyName read GetTypeAttribute write SetTypeAttribute stored False;\r\n end;\r\n\r\n (* ARRAY(INTERFACENAME, ANCESTORNAME, GUID, CONSTKEYWORD, PARAMETERNAME, TYPENAME, GETTERFUNCTIONNAME, SETTERPROCEDURENAME, ARRAYPROPERTYNAME) *)\r\n TJclArrayParams = class(TJclContainerIntf1DParams)\r\n public\r\n function AliasAttributeIDs: TAllTypeAttributeIDs; override;\r\n published\r\n property InterfaceName: string index taArrayInterfaceName read GetTypeAttribute write SetTypeAttribute stored IsTypeAttributeStored;\r\n property AncestorName: string index taListInterfaceName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property GUID: string index taArrayInterfaceGUID read GetTypeAttribute write SetTypeAttribute stored IsTypeAttributeStored;\r\n property ConstKeyword: string index taConstKeyword read GetTypeAttribute write SetTypeAttribute stored False;\r\n property ParameterName: string index taParameterName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property TypeName: string index taTypeName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property GetterFunctionName: string index taGetterFunctionName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property SetterProcedureName: string index taSetterProcedureName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property ArrayPropertyName: string index taArrayPropertyName read GetTypeAttribute write SetTypeAttribute stored False;\r\n end;\r\n\r\n (* SET(INTERFACENAME, ANCESTORNAME, GUID) *)\r\n TJclSetParams = class(TJclContainerIntf1DParams)\r\n public\r\n function AliasAttributeIDs: TAllTypeAttributeIDs; override;\r\n published\r\n property InterfaceName: string index taSetInterfaceName read GetTypeAttribute write SetTypeAttribute stored IsTypeAttributeStored;\r\n property SetInterfaceName: string index taSetInterfaceName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property AncestorName: string index taCollectionInterfaceName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property CollectionInterfaceName: string index taCollectionInterfaceName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property GUID: string index taSetInterfaceGUID read GetTypeAttribute write SetTypeAttribute stored IsTypeAttributeStored;\r\n end;\r\n\r\n (* TREE(INTERFACENAME, ANCESTORNAME, GUID, ITRNAME) *)\r\n TJclTreeParams = class(TJclContainerIntf1DParams)\r\n public\r\n function AliasAttributeIDs: TAllTypeAttributeIDs; override;\r\n published\r\n property InterfaceName: string index taTreeInterfaceName read GetTypeAttribute write SetTypeAttribute stored IsTypeAttributeStored;\r\n property AncestorName: string index taCollectionInterfaceName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property GUID: string index taTreeInterfaceGUID read GetTypeAttribute write SetTypeAttribute stored IsTypeAttributeStored;\r\n property ItrName: string index taTreeIteratorInterfaceName read GetTypeAttribute write SetTypeAttribute stored False;\r\n end;\r\n\r\n (* MAP(INTERFACENAME, ANCESTORNAME, GUID, KEYCONSTKEYWORD, KEYTYPENAME, KEYSETNAME,\r\n VALUECONSTKEYWORD, VALUETYPENAME, VALUECOLLECTIONNAME) *)\r\n TJclMapParams = class(TJclContainerIntf2DParams)\r\n public\r\n function AliasAttributeIDs: TAllTypeAttributeIDs; override;\r\n published\r\n property InterfaceName: string index maMapInterfaceName read GetMapAttribute write SetMapAttribute stored IsMapAttributeStored;\r\n property AncestorName: string index maMapInterfaceAncestorName read GetMapAttribute write SetMapAttribute stored IsMapAttributeStored;\r\n property GUID: string index maMapInterfaceGUID read GetMapAttribute write SetMapAttribute stored IsMapAttributeStored;\r\n property ConstKeyword: string index kaKeyConstKeyword read GetKeyAttribute write SetKeyAttribute stored False;\r\n property TypeName: string index kaKeyTypeName read GetKeyAttribute write SetKeyAttribute stored False;\r\n property SetName: string index kaKeySetInterfaceName read GetKeyAttribute write SetKeyAttribute stored False;\r\n property CollectionName: string index vaValueCollectionInterfaceName read GetValueAttribute write SetValueAttribute stored False;\r\n property KeyConstKeyword: string index kaKeyConstKeyword read GetKeyAttribute write SetKeyAttribute stored False;\r\n property KeyTypeName: string index kaKeyTypeName read GetKeyAttribute write SetKeyAttribute stored False;\r\n property KeySetName: string index kaKeySetInterfaceName read GetKeyAttribute write SetKeyAttribute stored False;\r\n property ValueConstKeyword: string index vaValueConstKeyword read GetValueAttribute write SetValueAttribute stored False;\r\n property ValueTypeName: string index vaValueTypeName read GetValueAttribute write SetValueAttribute stored False;\r\n property ValueCollectionName: string index vaValueCollectionInterfaceName read GetValueAttribute write SetValueAttribute stored False;\r\n end;\r\n\r\n (* QUEUE(INTERFACENAME, ANCESTORNAME, GUID, CONSTKEYWORD, PARAMETERNAME, TYPENAME) *)\r\n TJclQueueParams = class(TJclContainerIntfAncestorParams)\r\n public\r\n function AliasAttributeIDs: TAllTypeAttributeIDs; override;\r\n published\r\n property InterfaceName: string index taQueueInterfaceName read GetTypeAttribute write SetTypeAttribute stored IsTypeAttributeStored;\r\n property AncestorName;\r\n property GUID: string index taQueueInterfaceGUID read GetTypeAttribute write SetTypeAttribute stored IsTypeAttributeStored;\r\n property ConstKeyword: string index taConstKeyword read GetTypeAttribute write SetTypeAttribute stored False;\r\n property ParameterName: string index taParameterName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property TypeName: string index taTypeName read GetTypeAttribute write SetTypeAttribute stored False;\r\n end;\r\n\r\n (* SORTEDMAP(INTERFACENAME, ANCESTORNAME, GUID, KEYCONSTKEYWORD, KEYTYPENAME) *)\r\n TJclSortedMapParams = class(TJclContainerIntf2DParams)\r\n public\r\n function AliasAttributeIDs: TAllTypeAttributeIDs; override;\r\n published\r\n property InterfaceName: string index maSortedMapInterfaceName read GetMapAttribute write SetMapAttribute stored IsMapAttributeStored;\r\n property AncestorName: string index maMapInterfaceName read GetMapAttribute write SetMapAttribute stored False;\r\n property GUID: string index maSortedMapInterfaceGUID read GetMapAttribute write SetMapAttribute stored IsMapAttributeStored;\r\n property KeyConstKeyword: string index kaKeyConstKeyword read GetKeyAttribute write SetKeyAttribute stored False;\r\n property KeyTypeName: string index kaKeyTypeName read GetKeyAttribute write SetKeyAttribute stored False;\r\n end;\r\n\r\n (* SORTEDSET(INTERFACENAME, ANCESTORNAME, GUID, CONSTKEYWORD, TYPENAME) *)\r\n TJclSortedSetParams = class(TJclContainerIntf1DParams)\r\n public\r\n function AliasAttributeIDs: TAllTypeAttributeIDs; override;\r\n published\r\n property InterfaceName: string index taSortedSetInterfaceName read GetTypeAttribute write SetTypeAttribute stored IsTypeAttributeStored;\r\n property AncestorName: string index taSetInterfaceName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property GUID: string index taSortedSetInterfaceGUID read GetTypeAttribute write SetTypeAttribute stored IsTypeAttributeStored;\r\n property ConstKeyword: string index taConstKeyword read GetTypeAttribute write SetTypeAttribute stored False;\r\n property TypeName: string index taTypeName read GetTypeAttribute write SetTypeAttribute stored False;\r\n end;\r\n\r\n (* STACK(INTERFACENAME, ANCESTORNAME, GUID, CONSTKEYWORD, PARAMETERNAME, TYPENAME) *)\r\n TJclStackParams = class(TJclContainerIntfAncestorParams)\r\n public\r\n function AliasAttributeIDs: TAllTypeAttributeIDs; override;\r\n published\r\n property InterfaceName: string index taStackInterfaceName read GetTypeAttribute write SetTypeAttribute stored IsTypeAttributeStored;\r\n property AncestorName;\r\n property GUID: string index taStackInterfaceGUID read GetTypeAttribute write SetTypeAttribute stored IsTypeAttributeStored;\r\n property ConstKeyword: string index taConstKeyword read GetTypeAttribute write SetTypeAttribute stored False;\r\n property ParameterName: string index taParameterName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property TypeName: string index taTypeName read GetTypeAttribute write SetTypeAttribute stored False;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jcl.svn.sourceforge.net/svnroot/jcl/tags/JCL-2.4-Build4571/jcl/source/common/JclPreProcessorContainerIntfTemplates.pas $';\r\n Revision: '$Revision: 3737 $';\r\n Date: '$Date: 2012-02-20 19:48:39 +0100 (lun. 20 févr. 2012) $';\r\n LogPath: 'JCL\\source\\common';\r\n Extra: '';\r\n Data: nil\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n JclStrings;\r\n\r\nprocedure RegisterJclContainers;\r\nbegin\r\n RegisterContainerParams('ITERPROCEDURE', TJclIterProcedureParams);\r\n RegisterContainerParams('APPLYFUNCTION', TJclApplyFunctionParams);\r\n RegisterContainerParams('COMPAREFUNCTION', TJclCompareFunctionParams);\r\n RegisterContainerParams('EQUALITYCOMPAREFUNCTION', TJclEqualityCompareFunctionParams);\r\n RegisterContainerParams('HASHFUNCTION', TJclHashFunctionParams);\r\n RegisterContainerParams('SORTPROC', TJclSortFunctionParams);\r\n RegisterContainerParams('EQUALITYCOMPARER', TJclEqualityComparerParams);\r\n RegisterContainerParams('COMPARER', TJclComparerParams);\r\n RegisterContainerParams('HASHCONVERTER', TJclHashConverterParams);\r\n RegisterContainerParams('RELEASEEVENT', TJclReleaseEventParams);\r\n RegisterContainerParams('OWNER', TJclOwnerParams);\r\n RegisterContainerParams('ITERATOR', TJclIteratorParams);\r\n RegisterContainerParams('TREEITERATOR', TJclTreeIteratorParams);\r\n RegisterContainerParams('BINTREEITERATOR', TJclBinaryTreeIteratorParams);\r\n RegisterContainerParams('COLLECTION', TJclCollectionParams);\r\n RegisterContainerParams('LIST', TJclListParams);\r\n RegisterContainerParams('ARRAY', TJclArrayParams);\r\n RegisterContainerParams('SET', TJclSetParams);\r\n RegisterContainerParams('TREE', TJclTreeParams);\r\n RegisterContainerParams('MAP', TJclMapParams);\r\n RegisterContainerParams('QUEUE', TJclQueueParams);\r\n RegisterContainerParams('SORTEDMAP', TJclSortedMapParams);\r\n RegisterContainerParams('SORTEDSET', TJclSortedSetParams);\r\n RegisterContainerParams('STACK', TJclStackParams);\r\nend;\r\n\r\n//=== { TJclContainerIntfAncestorParams } ====================================\r\n\r\nfunction TJclContainerIntfAncestorParams.GetAncestorName: string;\r\nbegin\r\n Result := FAncestorName;\r\n if Result = '' then\r\n Result := TypeInfo.TypeAttributes[taContainerInterfaceName];\r\n if Result = '' then\r\n Result := 'IJclBaseContainer';\r\nend;\r\n\r\nfunction TJclContainerIntfAncestorParams.IsAncestorNameStored: Boolean;\r\nbegin\r\n Result := FAncestorName <> '';\r\nend;\r\n\r\n//=== { TJclIteratorParams } =================================================\r\n\r\nfunction TJclIteratorParams.AliasAttributeIDs: TAllTypeAttributeIDs;\r\nbegin\r\n Result := [taIteratorInterfaceName];\r\nend;\r\n\r\nfunction TJclIteratorParams.GetAncestorName: string;\r\nbegin\r\n Result := FAncestorName;\r\n if Result = '' then\r\n Result := 'IJclAbstractIterator';\r\nend;\r\n\r\n//=== { TJclContainerIntfFlatAncestorParams } ================================\r\n\r\nfunction TJclContainerIntfFlatAncestorParams.GetAncestorName: string;\r\nbegin\r\n Result := FAncestorName;\r\n if Result = '' then\r\n Result := TypeInfo.TypeAttributes[taFlatContainerInterfaceName];\r\n if Result = '' then\r\n Result := TypeInfo.TypeAttributes[taContainerInterfaceName];\r\n if Result = '' then\r\n Result := 'IJclBaseContainer';\r\nend;\r\n\r\n//=== { TJclIterProcedureParams } ============================================\r\n\r\nfunction TJclIterProcedureParams.AliasAttributeIDs: TAllTypeAttributeIDs;\r\nbegin\r\n Result := [taIterateProcedureTypeName];\r\nend;\r\n\r\n//=== { TJclApplyFunctionParams } ============================================\r\n\r\nfunction TJclApplyFunctionParams.AliasAttributeIDs: TAllTypeAttributeIDs;\r\nbegin\r\n Result := [taApplyFunctionTypeName];\r\nend;\r\n\r\n//=== { TJclCompareFunctionParams } ==========================================\r\n\r\nfunction TJclCompareFunctionParams.AliasAttributeIDs: TAllTypeAttributeIDs;\r\nbegin\r\n Result := [taCompareFunctionTypeName];\r\nend;\r\n\r\n//=== { TJclEqualityCompareFunctionParams } ==================================\r\n\r\nfunction TJclEqualityCompareFunctionParams.AliasAttributeIDs: TAllTypeAttributeIDs;\r\nbegin\r\n Result := [taEqualityCompareFunctionTypeName];\r\nend;\r\n\r\n//=== { TJclHashFunctionParams } =============================================\r\n\r\nfunction TJclHashFunctionParams.AliasAttributeIDs: TAllTypeAttributeIDs;\r\nbegin\r\n Result := [taHashConvertFunctionTypeName];\r\nend;\r\n\r\n//=== { TJclSortFunctionParams } =============================================\r\n\r\nfunction TJclSortFunctionParams.AliasAttributeIDs: TAllTypeAttributeIDs;\r\nbegin\r\n Result := [taSortProcedureTypeName];\r\nend;\r\n\r\n//=== { TJclEqualityComparerParams } =========================================\r\n\r\nfunction TJclEqualityComparerParams.AliasAttributeIDs: TAllTypeAttributeIDs;\r\nbegin\r\n Result := [taEqualityComparerInterfaceName];\r\nend;\r\n\r\n//=== { TJclComparerParams } =================================================\r\n\r\nfunction TJclComparerParams.AliasAttributeIDs: TAllTypeAttributeIDs;\r\nbegin\r\n Result := [taComparerInterfaceName];\r\nend;\r\n\r\n//=== { TJclHashConverterParams } ============================================\r\n\r\nfunction TJclHashConverterParams.AliasAttributeIDs: TAllTypeAttributeIDs;\r\nbegin\r\n Result := [taHashConverterInterfaceName];\r\nend;\r\n\r\n//=== { TJclReleaseEventParams } =============================================\r\n\r\nfunction TJclReleaseEventParams.AliasAttributeIDs: TAllTypeAttributeIDs;\r\nbegin\r\n Result := [taReleaseEventTypeName];\r\nend;\r\n\r\n//=== { TJclOwnerParams } ====================================================\r\n\r\nfunction TJclOwnerParams.AliasAttributeIDs: TAllTypeAttributeIDs;\r\nbegin\r\n Result := [taOwnershipInterfaceName];\r\nend;\r\n\r\nfunction TJclOwnerParams.GetAncestorName: string;\r\nbegin\r\n Result := FAncestorName;\r\n if Result = '' then\r\n Result := 'IInterface';\r\nend;\r\n\r\nfunction TJclOwnerParams.GetOwnerAdditional: string;\r\nbegin\r\n Result := FOwnerAdditional;\r\n if (Result = '') and TypeInfo.TObjectType then\r\n Result := NativeLineBreak +\r\n ' function GetOwnsObjects: Boolean;' + NativeLineBreak +\r\n ' property OwnsObjects: Boolean read GetOwnsObjects;';\r\nend;\r\n\r\n//=== { TJclTreeIteratorParams } =============================================\r\n\r\nfunction TJclTreeIteratorParams.AliasAttributeIDs: TAllTypeAttributeIDs;\r\nbegin\r\n Result := [taTreeIteratorInterfaceName];\r\nend;\r\n\r\n//=== { TJclBinaryTreeIteratorParams } =======================================\r\n\r\nfunction TJclBinaryTreeIteratorParams.AliasAttributeIDs: TAllTypeAttributeIDs;\r\nbegin\r\n Result := [taBinaryTreeIteratorInterfaceName];\r\nend;\r\n\r\n//=== { TJclCollectionParams } ===============================================\r\n\r\nfunction TJclCollectionParams.AliasAttributeIDs: TAllTypeAttributeIDs;\r\nbegin\r\n Result := [taCollectionInterfaceName];\r\nend;\r\n\r\n//=== { TJclListParams } =====================================================\r\n\r\nfunction TJclListParams.AliasAttributeIDs: TAllTypeAttributeIDs;\r\nbegin\r\n Result := [taListInterfaceName];\r\nend;\r\n\r\n//=== { TJclArrayParams } ====================================================\r\n\r\nfunction TJclArrayParams.AliasAttributeIDs: TAllTypeAttributeIDs;\r\nbegin\r\n Result := [taArrayInterfaceName];\r\nend;\r\n\r\n//=== { TJclSetParams } ======================================================\r\n\r\nfunction TJclSetParams.AliasAttributeIDs: TAllTypeAttributeIDs;\r\nbegin\r\n Result := [taSetInterfaceName];\r\nend;\r\n\r\n//=== { TJclTreeParams } =====================================================\r\n\r\nfunction TJclTreeParams.AliasAttributeIDs: TAllTypeAttributeIDs;\r\nbegin\r\n Result := [taTreeInterfaceName];\r\nend;\r\n\r\n//=== { TJclMapParams } =====================================================\r\n\r\nfunction TJclMapParams.AliasAttributeIDs: TAllTypeAttributeIDs;\r\nbegin\r\n Result := [maMapInterfaceName];\r\nend;\r\n\r\n//=== { TJclQueueParams } ====================================================\r\n\r\nfunction TJclQueueParams.AliasAttributeIDs: TAllTypeAttributeIDs;\r\nbegin\r\n Result := [taQueueInterfaceName];\r\nend;\r\n\r\n//=== { TJclSortedMapParams } ================================================\r\n\r\nfunction TJclSortedMapParams.AliasAttributeIDs: TAllTypeAttributeIDs;\r\nbegin\r\n Result := [maSortedMapInterfaceName];\r\nend;\r\n\r\n//=== { TJclSortedSetParams } ================================================\r\n\r\nfunction TJclSortedSetParams.AliasAttributeIDs: TAllTypeAttributeIDs;\r\nbegin\r\n Result := [taSortedSetInterfaceName];\r\nend;\r\n\r\n//=== { TJclStackParams } ====================================================\r\n\r\nfunction TJclStackParams.AliasAttributeIDs: TAllTypeAttributeIDs;\r\nbegin\r\n Result := [taStackInterfaceName];\r\nend;\r\n\r\ninitialization\r\n RegisterJclContainers;\r\n {$IFDEF UNITVERSIONING}\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n {$ENDIF UNITVERSIONING}\r\n\r\nfinalization\r\n {$IFDEF UNITVERSIONING}\r\n UnregisterUnitVersion(HInstance);\r\n {$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n\r\n" }, { "path": "External/Jedi/Jcl/source/common/JclPreProcessorContainerKnownMaps.pas", "content": "{**************************************************************************************************}\r\n{ }\r\n{ Project JEDI Code Library (JCL) }\r\n{ }\r\n{ The contents of this file are subject to the Mozilla Public License Version 1.1 (the \"License\"); }\r\n{ you may not use this file except in compliance with the License. You may obtain a copy of the }\r\n{ License at http://www.mozilla.org/MPL/ }\r\n{ }\r\n{ Software distributed under the License is distributed on an \"AS IS\" basis, WITHOUT WARRANTY OF }\r\n{ ANY KIND, either express or implied. See the License for the specific language governing rights }\r\n{ and limitations under the License. }\r\n{ }\r\n{ The Original Code is JclContainerKnownMaps.pas. }\r\n{ }\r\n{ The Initial Developer of the Original Code is Florent Ouchet }\r\n{ }\r\n{ Portions created by Florent Ouchet are Copyright (C) of Florent Ouchet. All rights reserved. }\r\n{ }\r\n{ Contributors: }\r\n{ }\r\n{**************************************************************************************************}\r\n{ }\r\n{ Last modified: $Date:: 2012-02-24 12:27:42 +0100 (ven. 24 févr. 2012) $ }\r\n{ Revision: $Rev:: 3747 $ }\r\n{ Author: $Author:: outchy $ }\r\n{ }\r\n{**************************************************************************************************}\r\n\r\nunit JclPreProcessorContainerKnownMaps;\r\n\r\ninterface\r\n\r\n{$I jcl.inc}\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n JclPreProcessorContainerTypes,\r\n JclPreProcessorContainerKnownTypes;\r\n\r\nconst\r\n IInterfaceIInterfaceKnownMap: TKnownMapAttributes =\r\n (MapAttributes:\r\n ( {maMapInterfaceName} 'IJclIntfIntfMap',\r\n {maMapInterfaceGUID} '{01D05399-4A05-4F3E-92F4-0C236BE77019}',\r\n {maMapInterfaceAncestorName} 'IJclBaseContainer',\r\n {maSortedMapInterfaceName} 'IJclIntfIntfSortedMap',\r\n {maSortedMapInterfaceGUID} '{265A6EB2-4BB3-459F-8813-360FD32A4971}',\r\n {maMapAncestorClassName} 'TJclIntfAbstractContainer',\r\n {maHashMapEntryTypeName} 'TJclIntfIntfHashMapEntry',\r\n {maHashMapEntryArrayTypeName} 'TJclIntfIntfHashMapEntryArray',\r\n {maHashMapBucketTypeName} 'TJclIntfIntfHashMapBucket',\r\n {maHashMapClassName} 'TJclIntfIntfHashMap',\r\n {maSortedMapEntryTypeName} 'TJclIntfIntfSortedMapEntry',\r\n {maSortedMapEntryArrayTypeName} 'TJclIntfIntfSortedMapEntryArray',\r\n {maSortedMapClassName} 'TJclIntfIntfSortedMap' );\r\n KeyAttributes: @IInterfaceKnownType;\r\n ValueAttributes: @IInterfaceKnownType);\r\n\r\n AnsiStringIInterfaceKnownMap: TKnownMapAttributes =\r\n (MapAttributes:\r\n ( {maMapInterfaceName} 'IJclAnsiStrIntfMap',\r\n {maMapInterfaceGUID} '{A4788A96-281A-4924-AA24-03776DDAAD8A}',\r\n {maMapInterfaceAncestorName} 'IJclAnsiStrContainer',\r\n {maSortedMapInterfaceName} 'IJclAnsiStrIntfSortedMap',\r\n {maSortedMapInterfaceGUID} '{706D1C91-5416-4FDC-B6B1-F4C1E8CFCD38}',\r\n {maMapAncestorClassName} 'TJclAnsiStrAbstractContainer',\r\n {maHashMapEntryTypeName} 'TJclAnsiStrIntfHashMapEntry',\r\n {maHashMapEntryArrayTypeName} 'TJclAnsiStrIntfHashMapEntryArray',\r\n {maHashMapBucketTypeName} 'TJclAnsiStrIntfHashMapBucket',\r\n {maHashMapClassName} 'TJclAnsiStrIntfHashMap',\r\n {maSortedMapEntryTypeName} 'TJclAnsiStrIntfSortedMapEntry',\r\n {maSortedMapEntryArrayTypeName} 'TJclAnsiStrIntfSortedMapEntryArray',\r\n {maSortedMapClassName} 'TJclAnsiStrIntfSortedMap' );\r\n KeyAttributes: @AnsiStringKnownType;\r\n ValueAttributes: @IInterfaceKnownType);\r\n\r\n WideStringIInterfaceKnownMap: TKnownMapAttributes =\r\n (MapAttributes:\r\n ( {maMapInterfaceName} 'IJclWideStrIntfMap',\r\n {maMapInterfaceGUID} '{C959AB76-9CF0-4C2C-A2C6-8A1846563FAF}',\r\n {maMapInterfaceAncestorName} 'IJclWideStrContainer',\r\n {maSortedMapInterfaceName} 'IJclWideStrIntfSortedMap',\r\n {maSortedMapInterfaceGUID} '{299FDCFD-2DB7-4D64-BF18-EE3668316430}',\r\n {maMapAncestorClassName} 'TJclWideStrAbstractContainer',\r\n {maHashMapEntryTypeName} 'TJclWideStrIntfHashMapEntry',\r\n {maHashMapEntryArrayTypeName} 'TJclWideStrIntfHashMapEntryArray',\r\n {maHashMapBucketTypeName} 'TJclWideStrIntfHashMapBucket',\r\n {maHashMapClassName} 'TJclWideStrIntfHashMap',\r\n {maSortedMapEntryTypeName} 'TJclWideStrIntfSortedMapEntry',\r\n {maSortedMapEntryArrayTypeName} 'TJclWideStrIntfSortedMapEntryArray',\r\n {maSortedMapClassName} 'TJclWideStrIntfSortedMap' );\r\n KeyAttributes: @WideStringKnownType;\r\n ValueAttributes: @IInterfaceKnownType);\r\n\r\n UnicodeStringIInterfaceKnownMap: TKnownMapAttributes =\r\n (MapAttributes:\r\n ( {maMapInterfaceName} 'IJclUnicodeStrIntfMap',\r\n {maMapInterfaceGUID} '{C83D4F5E-8E66-41E9-83F6-338B44F24BE6}',\r\n {maMapInterfaceAncestorName} 'IJclUnicodeStrContainer',\r\n {maSortedMapInterfaceName} 'IJclUnicodeStrIntfSortedMap',\r\n {maSortedMapInterfaceGUID} '{25FDE916-730D-449A-BA29-852D8A0470B6}',\r\n {maMapAncestorClassName} 'TJclUnicodeStrAbstractContainer',\r\n {maHashMapEntryTypeName} 'TJclUnicodeStrIntfHashMapEntry',\r\n {maHashMapEntryArrayTypeName} 'TJclUnicodeStrIntfHashMapEntryArray',\r\n {maHashMapBucketTypeName} 'TJclUnicodeStrIntfHashMapBucket',\r\n {maHashMapClassName} 'TJclUnicodeStrIntfHashMap',\r\n {maSortedMapEntryTypeName} 'TJclUnicodeStrIntfSortedMapEntry',\r\n {maSortedMapEntryArrayTypeName} 'TJclUnicodeStrIntfSortedMapEntryArray',\r\n {maSortedMapClassName} 'TJclUnicodeStrIntfSortedMap' );\r\n KeyAttributes: @UnicodeStringKnownType;\r\n ValueAttributes: @IInterfaceKnownType);\r\n\r\n StringIInterfaceKnownMap: TKnownMapAttributes =\r\n (MapAttributes:\r\n ( {maMapInterfaceName} 'IJclStrIntfMap',\r\n {maMapInterfaceGUID} '',\r\n {maMapInterfaceAncestorName} 'IJclStrBaseContainer',\r\n {maSortedMapInterfaceName} 'IJclStrIntfSortedMap',\r\n {maSortedMapInterfaceGUID} '',\r\n {maMapAncestorClassName} 'TJclStrAbstractContainer',\r\n {maHashMapEntryTypeName} 'TJclStrIntfHashMapEntry',\r\n {maHashMapEntryArrayTypeName} 'TJclStrIntfHashMapEntryArray',\r\n {maHashMapBucketTypeName} 'TJclStrIntfHashMapBucket',\r\n {maHashMapClassName} 'TJclStrIntfHashMap',\r\n {maSortedMapEntryTypeName} 'TJclStrIntfSortedMapEntry',\r\n {maSortedMapEntryArrayTypeName} 'TJclStrIntfSortedMapEntryArray',\r\n {maSortedMapClassName} 'TJclStrIntfSortedMap' );\r\n KeyAttributes: @StringKnownType;\r\n ValueAttributes: @IInterfaceKnownType);\r\n\r\n IInterfaceAnsiStringKnownMap: TKnownMapAttributes =\r\n (MapAttributes:\r\n ( {maMapInterfaceName} 'IJclIntfAnsiStrMap',\r\n {maMapInterfaceGUID} '{B10E324A-1D98-42FF-B9B4-7F99044591B2}',\r\n {maMapInterfaceAncestorName} 'IJclAnsiStrContainer',\r\n {maSortedMapInterfaceName} 'IJclIntfAnsiStrSortedMap',\r\n {maSortedMapInterfaceGUID} '{96E6AC5E-8C40-4795-9C8A-CFD098B58680}',\r\n {maMapAncestorClassName} 'TJclAnsiStrAbstractContainer',\r\n {maHashMapEntryTypeName} 'TJclIntfAnsiStrHashMapEntry',\r\n {maHashMapEntryArrayTypeName} 'TJclIntfAnsiStrHashMapEntryArray',\r\n {maHashMapBucketTypeName} 'TJclIntfAnsiStrHashMapBucket',\r\n {maHashMapClassName} 'TJclIntfAnsiStrHashMap',\r\n {maSortedMapEntryTypeName} 'TJclIntfAnsiStrSortedMapEntry',\r\n {maSortedMapEntryArrayTypeName} 'TJclIntfAnsiStrSortedMapEntryArray',\r\n {maSortedMapClassName} 'TJclIntfAnsiStrSortedMap' );\r\n KeyAttributes: @IInterfaceKnownType;\r\n ValueAttributes: @AnsiStringKnownType);\r\n\r\n IInterfaceWideStringKnownMap: TKnownMapAttributes =\r\n (MapAttributes:\r\n ( {maMapInterfaceName} 'IJclIntfWideStrMap',\r\n {maMapInterfaceGUID} '{D9FD7887-B840-4636-8A8F-E586663E332C}',\r\n {maMapInterfaceAncestorName} 'IJclWideStrContainer',\r\n {maSortedMapInterfaceName} 'IJclIntfWideStrSortedMap',\r\n {maSortedMapInterfaceGUID} '{FBE3AD2E-2781-4DC0-9E80-027027380E21}',\r\n {maMapAncestorClassName} 'TJclWideStrAbstractContainer',\r\n {maHashMapEntryTypeName} 'TJclIntfWideStrHashMapEntry',\r\n {maHashMapEntryArrayTypeName} 'TJclIntfWideStrHashMapEntryArray',\r\n {maHashMapBucketTypeName} 'TJclIntfWideStrHashMapBucket',\r\n {maHashMapClassName} 'TJclIntfWideStrHashMap',\r\n {maSortedMapEntryTypeName} 'TJclIntfWideStrSortedMapEntry',\r\n {maSortedMapEntryArrayTypeName} 'TJclIntfWideStrSortedMapEntryArray',\r\n {maSortedMapClassName} 'TJclIntfWideStrSortedMap' );\r\n KeyAttributes: @IInterfaceKnownType;\r\n ValueAttributes: @WideStringKnownType);\r\n\r\n IInterfaceUnicodeStringKnownMap: TKnownMapAttributes =\r\n (MapAttributes:\r\n ( {maMapInterfaceName} 'IJclIntfUnicodeStrMap',\r\n {maMapInterfaceGUID} '{40F8B873-B763-4A3C-8EC4-31DB3404BF73}',\r\n {maMapInterfaceAncestorName} 'IJclUnicodeStrContainer',\r\n {maSortedMapInterfaceName} 'IJclIntfUnicodeStrSortedMap',\r\n {maSortedMapInterfaceGUID} '{B0B0CB9B-268B-40D2-94A8-0B8B5BE2E1AC}',\r\n {maMapAncestorClassName} 'TJclUnicodeStrAbstractContainer',\r\n {maHashMapEntryTypeName} 'TJclIntfUnicodeStrHashMapEntry',\r\n {maHashMapEntryArrayTypeName} 'TJclIntfUnicodeStrHashMapEntryArray',\r\n {maHashMapBucketTypeName} 'TJclIntfUnicodeStrHashMapBucket',\r\n {maHashMapClassName} 'TJclIntfUnicodeStrHashMap',\r\n {maSortedMapEntryTypeName} 'TJclIntfUnicodeStrSortedMapEntry',\r\n {maSortedMapEntryArrayTypeName} 'TJclIntfUnicodeStrSortedMapEntryArray',\r\n {maSortedMapClassName} 'TJclIntfUnicodeStrSortedMap' );\r\n KeyAttributes: @IInterfaceKnownType;\r\n ValueAttributes: @UnicodeStringKnownType);\r\n\r\n IInterfaceStringKnownMap: TKnownMapAttributes =\r\n (MapAttributes:\r\n ( {maMapInterfaceName} 'IJclIntfStrMap',\r\n {maMapInterfaceGUID} '',\r\n {maMapInterfaceAncestorName} 'IJclStrBaseContainer',\r\n {maSortedMapInterfaceName} 'IJclIntfStrSortedMap',\r\n {maSortedMapInterfaceGUID} '',\r\n {maMapAncestorClassName} 'TJclStrAbstractContainer',\r\n {maHashMapEntryTypeName} 'TJclIntfStrHashMapEntry',\r\n {maHashMapEntryArrayTypeName} 'TJclIntfStrHashMapEntryArray',\r\n {maHashMapBucketTypeName} 'TJclIntfStrHashMapBucket',\r\n {maHashMapClassName} 'TJclIntfStrHashMap',\r\n {maSortedMapEntryTypeName} 'TJclIntfStrSortedMapEntry',\r\n {maSortedMapEntryArrayTypeName} 'TJclIntfStrSortedMapEntryArray',\r\n {maSortedMapClassName} 'TJclIntfStrSortedMap' );\r\n KeyAttributes: @IInterfaceKnownType;\r\n ValueAttributes: @StringKnownType);\r\n\r\n AnsiStringAnsiStringKnownMap: TKnownMapAttributes =\r\n (MapAttributes:\r\n ( {maMapInterfaceName} 'IJclAnsiStrAnsiStrMap',\r\n {maMapInterfaceGUID} '{A4788A96-281A-4924-AA24-03776DDAAD8A}',\r\n {maMapInterfaceAncestorName} 'IJclAnsiStrContainer',\r\n {maSortedMapInterfaceName} 'IJclAnsiStrAnsiStrSortedMap',\r\n {maSortedMapInterfaceGUID} '{4F457799-5D03-413D-A46C-067DC4200CC3}',\r\n {maMapAncestorClassName} 'TJclAnsiStrAbstractContainer',\r\n {maHashMapEntryTypeName} 'TJclAnsiStrAnsiStrHashMapEntry',\r\n {maHashMapEntryArrayTypeName} 'TJclAnsiStrAnsiStrHashMapEntryArray',\r\n {maHashMapBucketTypeName} 'TJclAnsiStrAnsiStrHashMapBucket',\r\n {maHashMapClassName} 'TJclAnsiStrAnsiStrHashMap',\r\n {maSortedMapEntryTypeName} 'TJclAnsiStrAnsiStrSortedMapEntry',\r\n {maSortedMapEntryArrayTypeName} 'TJclAnsiStrAnsiStrSortedMapEntryArray',\r\n {maSortedMapClassName} 'TJclAnsiStrAnsiStrSortedMap' );\r\n KeyAttributes: @AnsiStringKnownType;\r\n ValueAttributes: @AnsiStringKnownType);\r\n\r\n WideStringWideStringKnownMap: TKnownMapAttributes =\r\n (MapAttributes:\r\n ( {maMapInterfaceName} 'IJclWideStrWideStrMap',\r\n {maMapInterfaceGUID} '{8E8D2735-C4FB-4F00-8802-B2102BCE3644}',\r\n {maMapInterfaceAncestorName} 'IJclWideStrContainer',\r\n {maSortedMapInterfaceName} 'IJclWideStrWideStrSortedMap',\r\n {maSortedMapInterfaceGUID} '{3B0757B2-2290-4AFA-880D-F9BA600E501E}',\r\n {maMapAncestorClassName} 'TJclWideStrAbstractContainer',\r\n {maHashMapEntryTypeName} 'TJclWideStrWideStrHashMapEntry',\r\n {maHashMapEntryArrayTypeName} 'TJclWideStrWideStrHashMapEntryArray',\r\n {maHashMapBucketTypeName} 'TJclWideStrWideStrHashMapBucket',\r\n {maHashMapClassName} 'TJclWideStrWideStrHashMap',\r\n {maSortedMapEntryTypeName} 'TJclWideStrWideStrSortedMapEntry',\r\n {maSortedMapEntryArrayTypeName} 'TJclWideStrWideStrSortedMapEntryArray',\r\n {maSortedMapClassName} 'TJclWideStrWideStrSortedMap' );\r\n KeyAttributes: @WideStringKnownType;\r\n ValueAttributes: @WideStringKnownType);\r\n\r\n UnicodeStringUnicodeStringKnownMap: TKnownMapAttributes =\r\n (MapAttributes:\r\n ( {maMapInterfaceName} 'IJclUnicodeStrUnicodeStrMap',\r\n {maMapInterfaceGUID} '{557E1CBD-06AC-41C2-BAED-253709CBD0AE}',\r\n {maMapInterfaceAncestorName} 'IJclUnicodeStrContainer',\r\n {maSortedMapInterfaceName} 'IJclUnicodeStrUnicodeStrSortedMap',\r\n {maSortedMapInterfaceGUID} '{D8EACC5D-B31E-47A8-9CC9-32B15A79CACA}',\r\n {maMapAncestorClassName} 'TJclUnicodeStrAbstractContainer',\r\n {maHashMapEntryTypeName} 'TJclUnicodeStrUnicodeStrHashMapEntry',\r\n {maHashMapEntryArrayTypeName} 'TJclUnicodeStrUnicodeStrHashMapEntryArray',\r\n {maHashMapBucketTypeName} 'TJclUnicodeStrUnicodeStrHashMapBucket',\r\n {maHashMapClassName} 'TJclUnicodeStrUnicodeStrHashMap',\r\n {maSortedMapEntryTypeName} 'TJclUnicodeStrUnicodeStrSortedMapEntry',\r\n {maSortedMapEntryArrayTypeName} 'TJclUnicodeStrUnicodeStrSortedMapEntryArray',\r\n {maSortedMapClassName} 'TJclUnicodeStrUnicodeStrSortedMap' );\r\n KeyAttributes: @UnicodeStringKnownType;\r\n ValueAttributes: @UnicodeStringKnownType);\r\n\r\n StringStringKnownMap: TKnownMapAttributes =\r\n (MapAttributes:\r\n ( {maMapInterfaceName} 'IJclStrStrMap',\r\n {maMapInterfaceGUID} '',\r\n {maMapInterfaceAncestorName} 'IJclStrBaseContainer',\r\n {maSortedMapInterfaceName} 'IJclStrStrSortedMap',\r\n {maSortedMapInterfaceGUID} '',\r\n {maMapAncestorClassName} 'TJclStrAbstractContainer',\r\n {maHashMapEntryTypeName} 'TJclStrStrHashMapEntry',\r\n {maHashMapEntryArrayTypeName} 'TJclStrStrHashMapEntryArray',\r\n {maHashMapBucketTypeName} 'TJclStrStrHashMapBucket',\r\n {maHashMapClassName} 'TJclStrStrHashMap',\r\n {maSortedMapEntryTypeName} 'TJclStrStrSortedMapEntry',\r\n {maSortedMapEntryArrayTypeName} 'TJclStrStrSortedMapEntryArray',\r\n {maSortedMapClassName} 'TJclStrStrSortedMap' );\r\n KeyAttributes: @StringKnownType;\r\n ValueAttributes: @StringKnownType);\r\n\r\n SingleIInterfaceKnownMap: TKnownMapAttributes =\r\n (MapAttributes:\r\n ( {maMapInterfaceName} 'IJclSingleIntfMap',\r\n {maMapInterfaceGUID} '{5F5E9E8B-E648-450B-B6C0-0EC65CC2D0BA}',\r\n {maMapInterfaceAncestorName} 'IJclSingleContainer',\r\n {maSortedMapInterfaceName} 'IJclSingleIntfSortedMap',\r\n {maSortedMapInterfaceGUID} '{83D57068-7B8E-453E-B35B-2AB4B594A7A9}',\r\n {maMapAncestorClassName} 'TJclSingleAbstractContainer',\r\n {maHashMapEntryTypeName} 'TJclSingleIntfHashMapEntry',\r\n {maHashMapEntryArrayTypeName} 'TJclSingleIntfHashMapEntryArray',\r\n {maHashMapBucketTypeName} 'TJclSingleIntfHashMapBucket',\r\n {maHashMapClassName} 'TJclSingleIntfHashMap',\r\n {maSortedMapEntryTypeName} 'TJclSingleIntfSortedMapEntry',\r\n {maSortedMapEntryArrayTypeName} 'TJclSingleIntfSortedMapEntryArray',\r\n {maSortedMapClassName} 'TJclSingleIntfSortedMap' );\r\n KeyAttributes: @SingleKnownType;\r\n ValueAttributes: @IInterfaceKnownType);\r\n\r\n IInterfaceSingleKnownMap: TKnownMapAttributes =\r\n (MapAttributes:\r\n ( {maMapInterfaceName} 'IJclIntfSingleMap',\r\n {maMapInterfaceGUID} '{234D1618-FB0E-46F5-A70D-5106163A90F7}',\r\n {maMapInterfaceAncestorName} 'IJclSingleContainer',\r\n {maSortedMapInterfaceName} 'IJclIntfSingleSortedMap',\r\n {maSortedMapInterfaceGUID} '{B07FA192-3466-4F2A-BBF0-2DC0100B08A8}',\r\n {maMapAncestorClassName} 'TJclSingleAbstractContainer',\r\n {maHashMapEntryTypeName} 'TJclIntfSingleHashMapEntry',\r\n {maHashMapEntryArrayTypeName} 'TJclIntfSingleHashMapEntryArray',\r\n {maHashMapBucketTypeName} 'TJclIntfSingleHashMapBucket',\r\n {maHashMapClassName} 'TJclIntfSingleHashMap',\r\n {maSortedMapEntryTypeName} 'TJclIntfSingleSortedMapEntry',\r\n {maSortedMapEntryArrayTypeName} 'TJclIntfSingleSortedMapEntryArray',\r\n {maSortedMapClassName} 'TJclIntfSingleSortedMap' );\r\n KeyAttributes: @IInterfaceKnownType;\r\n ValueAttributes: @SingleKnownType);\r\n\r\n SingleSingleKnownMap: TKnownMapAttributes =\r\n (MapAttributes:\r\n ( {maMapInterfaceName} 'IJclSingleSingleMap',\r\n {maMapInterfaceGUID} '{AEB0008F-F3CF-4055-A7F3-A330D312F03F}',\r\n {maMapInterfaceAncestorName} 'IJclSingleContainer',\r\n {maSortedMapInterfaceName} 'IJclSingleSingleSortedMap',\r\n {maSortedMapInterfaceGUID} '{7C6EA0B4-959D-44D5-915F-99DFC1753B00}',\r\n {maMapAncestorClassName} 'TJclSingleAbstractContainer',\r\n {maHashMapEntryTypeName} 'TJclSingleSingleHashMapEntry',\r\n {maHashMapEntryArrayTypeName} 'TJclSingleSingleHashMapEntryArray',\r\n {maHashMapBucketTypeName} 'TJclSingleSingleHashMapBucket',\r\n {maHashMapClassName} 'TJclSingleSingleHashMap',\r\n {maSortedMapEntryTypeName} 'TJclSingleSingleSortedMapEntry',\r\n {maSortedMapEntryArrayTypeName} 'TJclSingleSingleSortedMapEntryArray',\r\n {maSortedMapClassName} 'TJclSingleSingleSortedMap' );\r\n KeyAttributes: @SingleKnownType;\r\n ValueAttributes: @SingleKnownType);\r\n\r\n DoubleIInterfaceKnownMap: TKnownMapAttributes =\r\n (MapAttributes:\r\n ( {maMapInterfaceName} 'IJclDoubleIntfMap',\r\n {maMapInterfaceGUID} '{08968FFB-36C6-4FBA-BC09-3DCA2B5D7A50}',\r\n {maMapInterfaceAncestorName} 'IJclDoubleContainer',\r\n {maSortedMapInterfaceName} 'IJclDoubleIntfSortedMap',\r\n {maSortedMapInterfaceGUID} '{F36C5F4F-4F8C-4943-AA35-41623D3C21E9}',\r\n {maMapAncestorClassName} 'TJclDoubleAbstractContainer',\r\n {maHashMapEntryTypeName} 'TJclDoubleIntfHashMapEntry',\r\n {maHashMapEntryArrayTypeName} 'TJclDoubleIntfHashMapEntryArray',\r\n {maHashMapBucketTypeName} 'TJclDoubleIntfHashMapBucket',\r\n {maHashMapClassName} 'TJclDoubleIntfHashMap',\r\n {maSortedMapEntryTypeName} 'TJclDoubleIntfSortedMapEntry',\r\n {maSortedMapEntryArrayTypeName} 'TJclDoubleIntfSortedMapEntryArray',\r\n {maSortedMapClassName} 'TJclDoubleIntfSortedMap' );\r\n KeyAttributes: @DoubleKnownType;\r\n ValueAttributes: @IInterfaceKnownType);\r\n\r\n IInterfaceDoubleKnownMap: TKnownMapAttributes =\r\n (MapAttributes:\r\n ( {maMapInterfaceName} 'IJclIntfDoubleMap',\r\n {maMapInterfaceGUID} '{B23DAF6A-6DC5-4DDD-835C-CD4633DDA010}',\r\n {maMapInterfaceAncestorName} 'IJclDoubleContainer',\r\n {maSortedMapInterfaceName} 'IJclIntfDoubleSortedMap',\r\n {maSortedMapInterfaceGUID} '{0F16ADAE-F499-4857-B5EA-6F3CC9009DBA}',\r\n {maMapAncestorClassName} 'TJclDoubleAbstractContainer',\r\n {maHashMapEntryTypeName} 'TJclIntfDoubleHashMapEntry',\r\n {maHashMapEntryArrayTypeName} 'TJclIntfDoubleHashMapEntryArray',\r\n {maHashMapBucketTypeName} 'TJclIntfDoubleHashMapBucket',\r\n {maHashMapClassName} 'TJclIntfDoubleHashMap',\r\n {maSortedMapEntryTypeName} 'TJclIntfDoubleSortedMapEntry',\r\n {maSortedMapEntryArrayTypeName} 'TJclIntfDoubleSortedMapEntryArray',\r\n {maSortedMapClassName} 'TJclIntfDoubleSortedMap' );\r\n KeyAttributes: @IInterfaceKnownType;\r\n ValueAttributes: @DoubleKnownType);\r\n\r\n DoubleDoubleKnownMap: TKnownMapAttributes =\r\n (MapAttributes:\r\n ( {maMapInterfaceName} 'IJclDoubleDoubleMap',\r\n {maMapInterfaceGUID} '{329A03B8-0B6B-4FE3-87C5-4B63447A5FFD}',\r\n {maMapInterfaceAncestorName} 'IJclDoubleContainer',\r\n {maSortedMapInterfaceName} 'IJclDoubleDoubleSortedMap',\r\n {maSortedMapInterfaceGUID} '{855C858B-74CF-4338-872B-AF88A02DB537}',\r\n {maMapAncestorClassName} 'TJclDoubleAbstractContainer',\r\n {maHashMapEntryTypeName} 'TJclDoubleDoubleHashMapEntry',\r\n {maHashMapEntryArrayTypeName} 'TJclDoubleDoubleHashMapEntryArray',\r\n {maHashMapBucketTypeName} 'TJclDoubleDoubleHashMapBucket',\r\n {maHashMapClassName} 'TJclDoubleDoubleHashMap',\r\n {maSortedMapEntryTypeName} 'TJclDoubleDoubleSortedMapEntry',\r\n {maSortedMapEntryArrayTypeName} 'TJclDoubleDoubleSortedMapEntryArray',\r\n {maSortedMapClassName} 'TJclDoubleDoubleSortedMap' );\r\n KeyAttributes: @DoubleKnownType;\r\n ValueAttributes: @DoubleKnownType);\r\n\r\n ExtendedIInterfaceKnownMap: TKnownMapAttributes =\r\n (MapAttributes:\r\n ( {maMapInterfaceName} 'IJclExtendedIntfMap',\r\n {maMapInterfaceGUID} '{7C0731E0-C9AB-4378-B1B0-8CE3DD60AD41}',\r\n {maMapInterfaceAncestorName} 'IJclExtendedContainer',\r\n {maSortedMapInterfaceName} 'IJclExtendedIntfSortedMap',\r\n {maSortedMapInterfaceGUID} '{A30B8835-A319-4776-9A11-D1EEF60B9C26}',\r\n {maMapAncestorClassName} 'TJclExtendedAbstractContainer',\r\n {maHashMapEntryTypeName} 'TJclExtendedIntfHashMapEntry',\r\n {maHashMapEntryArrayTypeName} 'TJclExtendedIntfHashMapEntryArray',\r\n {maHashMapBucketTypeName} 'TJclExtendedIntfHashMapBucket',\r\n {maHashMapClassName} 'TJclExtendedIntfHashMap',\r\n {maSortedMapEntryTypeName} 'TJclExtendedIntfSortedMapEntry',\r\n {maSortedMapEntryArrayTypeName} 'TJclExtendedIntfSortedMapEntryArray',\r\n {maSortedMapClassName} 'TJclExtendedIntfSortedMap' );\r\n KeyAttributes: @ExtendedKnownType;\r\n ValueAttributes: @IInterfaceKnownType);\r\n\r\n IInterfaceExtendedKnownMap: TKnownMapAttributes =\r\n (MapAttributes:\r\n ( {maMapInterfaceName} 'IJclIntfExtendedMap',\r\n {maMapInterfaceGUID} '{479FCE5A-2D8A-44EE-96BC-E8DA3187DBD8}',\r\n {maMapInterfaceAncestorName} 'IJclExtendedContainer',\r\n {maSortedMapInterfaceName} 'IJclIntfExtendedSortedMap',\r\n {maSortedMapInterfaceGUID} '{3493D6C4-3075-48B6-8E99-CB0000D3978C}',\r\n {maMapAncestorClassName} 'TJclExtendedAbstractContainer',\r\n {maHashMapEntryTypeName} 'TJclIntfExtendedHashMapEntry',\r\n {maHashMapEntryArrayTypeName} 'TJclIntfExtendedHashMapEntryArray',\r\n {maHashMapBucketTypeName} 'TJclIntfExtendedHashMapBucket',\r\n {maHashMapClassName} 'TJclIntfExtendedHashMap',\r\n {maSortedMapEntryTypeName} 'TJclIntfExtendedSortedMapEntry',\r\n {maSortedMapEntryArrayTypeName} 'TJclIntfExtendedSortedMapEntryArray',\r\n {maSortedMapClassName} 'TJclIntfExtendedSortedMap' );\r\n KeyAttributes: @IInterfaceKnownType;\r\n ValueAttributes: @ExtendedKnownType);\r\n\r\n ExtendedExtendedKnownMap: TKnownMapAttributes =\r\n (MapAttributes:\r\n ( {maMapInterfaceName} 'IJclExtendedExtendedMap',\r\n {maMapInterfaceGUID} '{962C2B09-8CF5-44E8-A21A-4A7DAFB72A11}',\r\n {maMapInterfaceAncestorName} 'IJclExtendedContainer',\r\n {maSortedMapInterfaceName} 'IJclExtendedExtendedSortedMap',\r\n {maSortedMapInterfaceGUID} '{8CAA505C-D9BB-47E7-92EC-6043DC4AF42C}',\r\n {maMapAncestorClassName} 'TJclExtendedAbstractContainer',\r\n {maHashMapEntryTypeName} 'TJclExtendedExtendedHashMapEntry',\r\n {maHashMapEntryArrayTypeName} 'TJclExtendedExtendedHashMapEntryArray',\r\n {maHashMapBucketTypeName} 'TJclExtendedExtendedHashMapBucket',\r\n {maHashMapClassName} 'TJclExtendedExtendedHashMap',\r\n {maSortedMapEntryTypeName} 'TJclExtendedExtendedSortedMapEntry',\r\n {maSortedMapEntryArrayTypeName} 'TJclExtendedExtendedSortedMapEntryArray',\r\n {maSortedMapClassName} 'TJclExtendedExtendedSortedMap' );\r\n KeyAttributes: @ExtendedKnownType;\r\n ValueAttributes: @ExtendedKnownType);\r\n\r\n FloatIInterfaceKnownMap: TKnownMapAttributes =\r\n (MapAttributes:\r\n ( {maMapInterfaceName} 'IJclFloatIntfMap',\r\n {maMapInterfaceGUID} '',\r\n {maMapInterfaceAncestorName} 'IJclFloatContainer',\r\n {maSortedMapInterfaceName} 'IJclFloatIntfSortedMap',\r\n {maSortedMapInterfaceGUID} '',\r\n {maMapAncestorClassName} 'TJclFloatAbstractContainer',\r\n {maHashMapEntryTypeName} 'TJclFloatIntfHashMapEntry',\r\n {maHashMapEntryArrayTypeName} 'TJclFloatIntfHashMapEntryArray',\r\n {maHashMapBucketTypeName} 'TJclFloatIntfHashMapBucket',\r\n {maHashMapClassName} 'TJclFloatIntfHashMap',\r\n {maSortedMapEntryTypeName} 'TJclFloatIntfSortedMapEntry',\r\n {maSortedMapEntryArrayTypeName} 'TJclFloatIntfSortedMapEntryArray',\r\n {maSortedMapClassName} 'TJclFloatIntfSortedMap' );\r\n KeyAttributes: @FloatKnownType;\r\n ValueAttributes: @IInterfaceKnownType);\r\n\r\n IInterfaceFloatKnownMap: TKnownMapAttributes =\r\n (MapAttributes:\r\n ( {maMapInterfaceName} 'IJclIntfFloatMap',\r\n {maMapInterfaceGUID} '',\r\n {maMapInterfaceAncestorName} 'IJclFloatContainer',\r\n {maSortedMapInterfaceName} 'IJclIntfFloatSortedMap',\r\n {maSortedMapInterfaceGUID} '',\r\n {maMapAncestorClassName} 'TJclFloatAbstractContainer',\r\n {maHashMapEntryTypeName} 'TJclIntfFloatHashMapEntry',\r\n {maHashMapEntryArrayTypeName} 'TJclIntfFloatHashMapEntryArray',\r\n {maHashMapBucketTypeName} 'TJclIntfFloatHashMapBucket',\r\n {maHashMapClassName} 'TJclIntfFloatHashMap',\r\n {maSortedMapEntryTypeName} 'TJclIntfFloatSortedMapEntry',\r\n {maSortedMapEntryArrayTypeName} 'TJclIntfFloatSortedMapEntryArray',\r\n {maSortedMapClassName} 'TJclIntfFloatSortedMap' );\r\n KeyAttributes: @IInterfaceKnownType;\r\n ValueAttributes: @FloatKnownType);\r\n\r\n FloatFloatKnownMap: TKnownMapAttributes =\r\n (MapAttributes:\r\n ( {maMapInterfaceName} 'IJclFloatFloatMap',\r\n {maMapInterfaceGUID} '',\r\n {maMapInterfaceAncestorName} 'IJclFloatContainer',\r\n {maSortedMapInterfaceName} 'IJclFloatFloatSortedMap',\r\n {maSortedMapInterfaceGUID} '{8CAA505C-D9BB-47E7-92EC-6043DC4AF42C}',\r\n {maMapAncestorClassName} 'TJclFloatAbstractContainer',\r\n {maHashMapEntryTypeName} 'TJclFloatFloatHashMapEntry',\r\n {maHashMapEntryArrayTypeName} 'TJclFloatFloatHashMapEntryArray',\r\n {maHashMapBucketTypeName} 'TJclFloatFloatHashMapBucket',\r\n {maHashMapClassName} 'TJclFloatFloatHashMap',\r\n {maSortedMapEntryTypeName} 'TJclFloatFloatSortedMapEntry',\r\n {maSortedMapEntryArrayTypeName} 'TJclFloatFloatSortedMapEntryArray',\r\n {maSortedMapClassName} 'TJclFloatFloatSortedMap' );\r\n KeyAttributes: @FloatKnownType;\r\n ValueAttributes: @FloatKnownType);\r\n\r\n IntegerIInterfaceKnownMap: TKnownMapAttributes =\r\n (MapAttributes:\r\n ( {maMapInterfaceName} 'IJclIntegerIntfMap',\r\n {maMapInterfaceGUID} '{E535FE65-AC88-49D3-BEF2-FB30D92C2FA6}',\r\n {maMapInterfaceAncestorName} 'IJclBaseContainer',\r\n {maSortedMapInterfaceName} 'IJclIntegerIntfSortedMap',\r\n {maSortedMapInterfaceGUID} '{8B22802C-61F2-4DA5-B1E9-DBB7840E7996}',\r\n {maMapAncestorClassName} 'TJclIntegerAbstractContainer',\r\n {maHashMapEntryTypeName} 'TJclIntegerIntfHashMapEntry',\r\n {maHashMapEntryArrayTypeName} 'TJclIntegerIntfHashMapEntryArray',\r\n {maHashMapBucketTypeName} 'TJclIntegerIntfHashMapBucket',\r\n {maHashMapClassName} 'TJclIntegerIntfHashMap',\r\n {maSortedMapEntryTypeName} 'TJclIntegerIntfSortedMapEntry',\r\n {maSortedMapEntryArrayTypeName} 'TJclIntegerIntfSortedMapEntryArray',\r\n {maSortedMapClassName} 'TJclIntegerIntfSortedMap' );\r\n KeyAttributes: @IntegerKnownType;\r\n ValueAttributes: @IInterfaceKnownType);\r\n\r\n IInterfaceIntegerKnownMap: TKnownMapAttributes =\r\n (MapAttributes:\r\n ( {maMapInterfaceName} 'IJclIntfIntegerMap',\r\n {maMapInterfaceGUID} '{E01DA012-BEE0-4259-8E30-0A7A1A87BED0}',\r\n {maMapInterfaceAncestorName} 'IJclBaseContainer',\r\n {maSortedMapInterfaceName} 'IJclIntfIntegerSortedMap',\r\n {maSortedMapInterfaceGUID} '{8D3C9B7E-772D-409B-A58C-0CABFAFDEFF0}',\r\n {maMapAncestorClassName} 'TJclIntegerAbstractContainer',\r\n {maHashMapEntryTypeName} 'TJclIntfIntegerHashMapEntry',\r\n {maHashMapEntryArrayTypeName} 'TJclIntfIntegerHashMapEntryArray',\r\n {maHashMapBucketTypeName} 'TJclIntfIntegerHashMapBucket',\r\n {maHashMapClassName} 'TJclIntfIntegerHashMap',\r\n {maSortedMapEntryTypeName} 'TJclIntfIntegerSortedMapEntry',\r\n {maSortedMapEntryArrayTypeName} 'TJclIntfIntegerSortedMapEntryArray',\r\n {maSortedMapClassName} 'TJclIntfIntegerSortedMap' );\r\n KeyAttributes: @IInterfaceKnownType;\r\n ValueAttributes: @IntegerKnownType);\r\n\r\n IntegerIntegerKnownMap: TKnownMapAttributes =\r\n (MapAttributes:\r\n ( {maMapInterfaceName} 'IJclIntegerIntegerMap',\r\n {maMapInterfaceGUID} '{23A46BC0-DF8D-4BD2-89D2-4DACF1EC73A1}',\r\n {maMapInterfaceAncestorName} 'IJclBaseContainer',\r\n {maSortedMapInterfaceName} 'IJclIntegerIntegerSortedMap',\r\n {maSortedMapInterfaceGUID} '{8A8BA17A-F468-469C-AF99-77D64C802F7A}',\r\n {maMapAncestorClassName} 'TJclIntegerAbstractContainer',\r\n {maHashMapEntryTypeName} 'TJclIntegerIntegerHashMapEntry',\r\n {maHashMapEntryArrayTypeName} 'TJclIntegerIntegerHashMapEntryArray',\r\n {maHashMapBucketTypeName} 'TJclIntegerIntegerHashMapBucket',\r\n {maHashMapClassName} 'TJclIntegerIntegerHashMap',\r\n {maSortedMapEntryTypeName} 'TJclIntegerIntegerSortedMapEntry',\r\n {maSortedMapEntryArrayTypeName} 'TJclIntegerIntegerSortedMapEntryArray',\r\n {maSortedMapClassName} 'TJclIntegerIntegerSortedMap' );\r\n KeyAttributes: @IntegerKnownType;\r\n ValueAttributes: @IntegerKnownType);\r\n\r\n CardinalIInterfaceKnownMap: TKnownMapAttributes =\r\n (MapAttributes:\r\n ( {maMapInterfaceName} 'IJclCardinalIntfMap',\r\n {maMapInterfaceGUID} '{80D39FB1-0D10-49CE-8AF3-1CD98A1D4F6C}',\r\n {maMapInterfaceAncestorName} 'IJclBaseContainer',\r\n {maSortedMapInterfaceName} 'IJclCardinalIntfSortedMap',\r\n {maSortedMapInterfaceGUID} '{BAE97425-4F2E-461B-88DD-F83D27657AFA}',\r\n {maMapAncestorClassName} 'TJclCardinalAbstractContainer',\r\n {maHashMapEntryTypeName} 'TJclCardinalIntfHashMapEntry',\r\n {maHashMapEntryArrayTypeName} 'TJclCardinalIntfHashMapEntryArray',\r\n {maHashMapBucketTypeName} 'TJclCardinalIntfHashMapBucket',\r\n {maHashMapClassName} 'TJclCardinalIntfHashMap',\r\n {maSortedMapEntryTypeName} 'TJclCardinalIntfSortedMapEntry',\r\n {maSortedMapEntryArrayTypeName} 'TJclCardinalIntfSortedMapEntryArray',\r\n {maSortedMapClassName} 'TJclCardinalIntfSortedMap' );\r\n KeyAttributes: @CardinalKnownType;\r\n ValueAttributes: @IInterfaceKnownType);\r\n\r\n IInterfaceCardinalKnownMap: TKnownMapAttributes =\r\n (MapAttributes:\r\n ( {maMapInterfaceName} 'IJclIntfCardinalMap',\r\n {maMapInterfaceGUID} '{E1A724AB-6BDA-45F0-AE21-5E7E789A751B}',\r\n {maMapInterfaceAncestorName} 'IJclBaseContainer',\r\n {maSortedMapInterfaceName} 'IJclIntfCardinalSortedMap',\r\n {maSortedMapInterfaceGUID} '{BC66BACF-23AE-48C4-9573-EDC3B5110BE7}',\r\n {maMapAncestorClassName} 'TJclCardinalAbstractContainer',\r\n {maHashMapEntryTypeName} 'TJclIntfCardinalHashMapEntry',\r\n {maHashMapEntryArrayTypeName} 'TJclIntfCardinalHashMapEntryArray',\r\n {maHashMapBucketTypeName} 'TJclIntfCardinalHashMapBucket',\r\n {maHashMapClassName} 'TJclIntfCardinalHashMap',\r\n {maSortedMapEntryTypeName} 'TJclIntfCardinalSortedMapEntry',\r\n {maSortedMapEntryArrayTypeName} 'TJclIntfCardinalSortedMapEntryArray',\r\n {maSortedMapClassName} 'TJclIntfCardinalSortedMap' );\r\n KeyAttributes: @IInterfaceKnownType;\r\n ValueAttributes: @CardinalKnownType);\r\n\r\n CardinalCardinalKnownMap: TKnownMapAttributes =\r\n (MapAttributes:\r\n ( {maMapInterfaceName} 'IJclCardinalCardinalMap',\r\n {maMapInterfaceGUID} '{1CD3F54C-F92F-4AF4-82B2-0829C08AA83B}',\r\n {maMapInterfaceAncestorName} 'IJclBaseContainer',\r\n {maSortedMapInterfaceName} 'IJclCardinalCardinalSortedMap',\r\n {maSortedMapInterfaceGUID} '{182ACDA4-7D74-4D29-BB5C-4C8189DA774E}',\r\n {maMapAncestorClassName} 'TJclCardinalAbstractContainer',\r\n {maHashMapEntryTypeName} 'TJclCardinalCardinalHashMapEntry',\r\n {maHashMapEntryArrayTypeName} 'TJclCardinalCardinalHashMapEntryArray',\r\n {maHashMapBucketTypeName} 'TJclCardinalCardinalHashMapBucket',\r\n {maHashMapClassName} 'TJclCardinalCardinalHashMap',\r\n {maSortedMapEntryTypeName} 'TJclCardinalCardinalSortedMapEntry',\r\n {maSortedMapEntryArrayTypeName} 'TJclCardinalCardinalSortedMapEntryArray',\r\n {maSortedMapClassName} 'TJclCardinalCardinalSortedMap' );\r\n KeyAttributes: @CardinalKnownType;\r\n ValueAttributes: @CardinalKnownType);\r\n\r\n Int64IInterfaceKnownMap: TKnownMapAttributes =\r\n (MapAttributes:\r\n ( {maMapInterfaceName} 'IJclInt64IntfMap',\r\n {maMapInterfaceGUID} '{B64FB2D1-8D45-4367-B950-98D3D05AC6A0}',\r\n {maMapInterfaceAncestorName} 'IJclBaseContainer',\r\n {maSortedMapInterfaceName} 'IJclInt64IntfSortedMap',\r\n {maSortedMapInterfaceGUID} '{24391756-FB02-4901-81E3-A37738B73DAD}',\r\n {maMapAncestorClassName} 'TJclInt64AbstractContainer',\r\n {maHashMapEntryTypeName} 'TJclInt64IntfHashMapEntry',\r\n {maHashMapEntryArrayTypeName} 'TJclInt64IntfHashMapEntryArray',\r\n {maHashMapBucketTypeName} 'TJclInt64IntfHashMapBucket',\r\n {maHashMapClassName} 'TJclInt64IntfHashMap',\r\n {maSortedMapEntryTypeName} 'TJclInt64IntfSortedMapEntry',\r\n {maSortedMapEntryArrayTypeName} 'TJclInt64IntfSortedMapEntryArray',\r\n {maSortedMapClassName} 'TJclInt64IntfSortedMap' );\r\n KeyAttributes: @Int64KnownType;\r\n ValueAttributes: @IInterfaceKnownType);\r\n\r\n IInterfaceInt64KnownMap: TKnownMapAttributes =\r\n (MapAttributes:\r\n ( {maMapInterfaceName} 'IJclIntfInt64Map',\r\n {maMapInterfaceGUID} '{9886BEE3-D15B-45D2-A3FB-4D3A0ADEC8AC}',\r\n {maMapInterfaceAncestorName} 'IJclBaseContainer',\r\n {maSortedMapInterfaceName} 'IJclIntfInt64SortedMap',\r\n {maSortedMapInterfaceGUID} '{6E2AB647-59CC-4609-82E8-6AE75AED80CA}',\r\n {maMapAncestorClassName} 'TJclInt64AbstractContainer',\r\n {maHashMapEntryTypeName} 'TJclIntfInt64HashMapEntry',\r\n {maHashMapEntryArrayTypeName} 'TJclIntfInt64HashMapEntryArray',\r\n {maHashMapBucketTypeName} 'TJclIntfInt64HashMapBucket',\r\n {maHashMapClassName} 'TJclIntfInt64HashMap',\r\n {maSortedMapEntryTypeName} 'TJclIntfInt64SortedMapEntry',\r\n {maSortedMapEntryArrayTypeName} 'TJclIntfInt64SortedMapEntryArray',\r\n {maSortedMapClassName} 'TJclIntfInt64SortedMap' );\r\n KeyAttributes: @IInterfaceKnownType;\r\n ValueAttributes: @Int64KnownType);\r\n\r\n Int64Int64KnownMap: TKnownMapAttributes =\r\n (MapAttributes:\r\n ( {maMapInterfaceName} 'IJclInt64Int64Map',\r\n {maMapInterfaceGUID} '{EF2A2726-408A-4984-9971-DDC1B6EFC9F5}',\r\n {maMapInterfaceAncestorName} 'IJclBaseContainer',\r\n {maSortedMapInterfaceName} 'IJclInt64Int64SortedMap',\r\n {maSortedMapInterfaceGUID} '{168581D2-9DD3-46D0-934E-EA0CCE5E3C0C}',\r\n {maMapAncestorClassName} 'TJclInt64AbstractContainer',\r\n {maHashMapEntryTypeName} 'TJclInt64Int64HashMapEntry',\r\n {maHashMapEntryArrayTypeName} 'TJclInt64Int64HashMapEntryArray',\r\n {maHashMapBucketTypeName} 'TJclInt64Int64HashMapBucket',\r\n {maHashMapClassName} 'TJclInt64Int64HashMap',\r\n {maSortedMapEntryTypeName} 'TJclInt64Int64SortedMapEntry',\r\n {maSortedMapEntryArrayTypeName} 'TJclInt64Int64SortedMapEntryArray',\r\n {maSortedMapClassName} 'TJclInt64Int64SortedMap' );\r\n KeyAttributes: @Int64KnownType;\r\n ValueAttributes: @Int64KnownType);\r\n\r\n PointerIInterfaceKnownMap: TKnownMapAttributes =\r\n (MapAttributes:\r\n ( {maMapInterfaceName} 'IJclPtrIntfMap',\r\n {maMapInterfaceGUID} '{B7C48542-39A0-453F-8F03-8C8CFAB0DCCF}',\r\n {maMapInterfaceAncestorName} 'IJclBaseContainer',\r\n {maSortedMapInterfaceName} 'IJclPtrIntfSortedMap',\r\n {maSortedMapInterfaceGUID} '{6D7B8042-3CBC-4C8F-98B5-69AFAA104532}',\r\n {maMapAncestorClassName} 'TJclPtrAbstractContainer',\r\n {maHashMapEntryTypeName} 'TJclPtrIntfHashMapEntry',\r\n {maHashMapEntryArrayTypeName} 'TJclPtrIntfHashMapEntryArray',\r\n {maHashMapBucketTypeName} 'TJclPtrIntfHashMapBucket',\r\n {maHashMapClassName} 'TJclPtrIntfHashMap',\r\n {maSortedMapEntryTypeName} 'TJclPtrIntfSortedMapEntry',\r\n {maSortedMapEntryArrayTypeName} 'TJclPtrIntfSortedMapEntryArray',\r\n {maSortedMapClassName} 'TJclPtrIntfSortedMap' );\r\n KeyAttributes: @PointerKnownType;\r\n ValueAttributes: @IInterfaceKnownType);\r\n\r\n IInterfacePointerKnownMap: TKnownMapAttributes =\r\n (MapAttributes:\r\n ( {maMapInterfaceName} 'IJclIntfPtrMap',\r\n {maMapInterfaceGUID} '{DA51D823-58DB-4D7C-9B8E-07E0FD560B57}',\r\n {maMapInterfaceAncestorName} 'IJclBaseContainer',\r\n {maSortedMapInterfaceName} 'IJclIntfPtrSortedMap',\r\n {maSortedMapInterfaceGUID} '{B054BDA2-536F-4C16-B6BB-BB64FA0818B3}',\r\n {maMapAncestorClassName} 'TJclPtrAbstractContainer',\r\n {maHashMapEntryTypeName} 'TJclIntfPtrHashMapEntry',\r\n {maHashMapEntryArrayTypeName} 'TJclIntfPtrHashMapEntryArray',\r\n {maHashMapBucketTypeName} 'TJclIntfPtrHashMapBucket',\r\n {maHashMapClassName} 'TJclIntfPtrHashMap',\r\n {maSortedMapEntryTypeName} 'TJclIntfPtrSortedMapEntry',\r\n {maSortedMapEntryArrayTypeName} 'TJclIntfPtrSortedMapEntryArray',\r\n {maSortedMapClassName} 'TJclIntfPtrSortedMap' );\r\n KeyAttributes: @IInterfaceKnownType;\r\n ValueAttributes: @PointerKnownType);\r\n\r\n PointerPointerKnownMap: TKnownMapAttributes =\r\n (MapAttributes:\r\n ( {maMapInterfaceName} 'IJclPtrPtrMap',\r\n {maMapInterfaceGUID} '{1200CB0F-A766-443F-9030-5A804C11B798}',\r\n {maMapInterfaceAncestorName} 'IJclBaseContainer',\r\n {maSortedMapInterfaceName} 'IJclPtrPtrSortedMap',\r\n {maSortedMapInterfaceGUID} '{F1FAE922-0212-41D0-BB4E-76A8AB2CAB86}',\r\n {maMapAncestorClassName} 'TJclPtrAbstractContainer',\r\n {maHashMapEntryTypeName} 'TJclPtrPtrHashMapEntry',\r\n {maHashMapEntryArrayTypeName} 'TJclPtrPtrHashMapEntryArray',\r\n {maHashMapBucketTypeName} 'TJclPtrPtrHashMapBucket',\r\n {maHashMapClassName} 'TJclPtrPtrHashMap',\r\n {maSortedMapEntryTypeName} 'TJclPtrPtrSortedMapEntry',\r\n {maSortedMapEntryArrayTypeName} 'TJclPtrPtrSortedMapEntryArray',\r\n {maSortedMapClassName} 'TJclPtrPtrSortedMap' );\r\n KeyAttributes: @PointerKnownType;\r\n ValueAttributes: @PointerKnownType);\r\n\r\n IInterfaceTObjectKnownMap: TKnownMapAttributes =\r\n (MapAttributes:\r\n ( {maMapInterfaceName} 'IJclIntfMap',\r\n {maMapInterfaceGUID} '{C70570C6-EDDB-47B4-9003-C637B486731D}',\r\n {maMapInterfaceAncestorName} 'IJclBaseContainer',\r\n {maSortedMapInterfaceName} 'IJclIntfSortedMap',\r\n {maSortedMapInterfaceGUID} '{3CED1477-B958-4109-9BDA-7C84B9E063B2}',\r\n {maMapAncestorClassName} 'TJclIntfAbstractContainer',\r\n {maHashMapEntryTypeName} 'TJclIntfHashMapEntry',\r\n {maHashMapEntryArrayTypeName} 'TJclIntfHashMapEntryArray',\r\n {maHashMapBucketTypeName} 'TJclIntfHashMapBucket',\r\n {maHashMapClassName} 'TJclIntfHashMap',\r\n {maSortedMapEntryTypeName} 'TJclIntfSortedMapEntry',\r\n {maSortedMapEntryArrayTypeName} 'TJclIntfSortedMapEntryArray',\r\n {maSortedMapClassName} 'TJclIntfSortedMap' );\r\n KeyAttributes: @IInterfaceKnownType;\r\n ValueAttributes: @TObjectKnownType);\r\n\r\n AnsiStringTObjectKnownMap: TKnownMapAttributes =\r\n (MapAttributes:\r\n ( {maMapInterfaceName} 'IJclAnsiStrMap',\r\n {maMapInterfaceGUID} '{A7D0A882-6952-496D-A258-23D47DDCCBC4}',\r\n {maMapInterfaceAncestorName} 'IJclAnsiStrContainer',\r\n {maSortedMapInterfaceName} 'IJclAnsiStrSortedMap',\r\n {maSortedMapInterfaceGUID} '{573F98E3-EBCD-4F28-8F35-96A7366CBF47}',\r\n {maMapAncestorClassName} 'TJclAnsiStrAbstractContainer',\r\n {maHashMapEntryTypeName} 'TJclAnsiStrHashMapEntry',\r\n {maHashMapEntryArrayTypeName} 'TJclAnsiStrHashMapEntryArray',\r\n {maHashMapBucketTypeName} 'TJclAnsiStrHashMapBucket',\r\n {maHashMapClassName} 'TJclAnsiStrHashMap',\r\n {maSortedMapEntryTypeName} 'TJclAnsiStrSortedMapEntry',\r\n {maSortedMapEntryArrayTypeName} 'TJclAnsiStrSortedMapEntryArray',\r\n {maSortedMapClassName} 'TJclAnsiStrSortedMap' );\r\n KeyAttributes: @AnsiStringKnownType;\r\n ValueAttributes: @TObjectKnownType);\r\n\r\n WideStringTObjectKnownMap: TKnownMapAttributes =\r\n (MapAttributes:\r\n ( {maMapInterfaceName} 'IJclWideStrMap',\r\n {maMapInterfaceGUID} '{ACE8E6B4-5A56-4753-A2C6-BAE195A56B63}',\r\n {maMapInterfaceAncestorName} 'IJclWideStrContainer',\r\n {maSortedMapInterfaceName} 'IJclWideStrSortedMap',\r\n {maSortedMapInterfaceGUID} '{B3021EFC-DE25-4B4B-A896-ACE823CD5C01}',\r\n {maMapAncestorClassName} 'TJclWideStrAbstractContainer',\r\n {maHashMapEntryTypeName} 'TJclWideStrHashMapEntry',\r\n {maHashMapEntryArrayTypeName} 'TJclWideStrHashMapEntryArray',\r\n {maHashMapBucketTypeName} 'TJclWideStrHashMapBucket',\r\n {maHashMapClassName} 'TJclWideStrHashMap',\r\n {maSortedMapEntryTypeName} 'TJclWideStrSortedMapEntry',\r\n {maSortedMapEntryArrayTypeName} 'TJclWideStrSortedMapEntryArray',\r\n {maSortedMapClassName} 'TJclWideStrSortedMap' );\r\n KeyAttributes: @WideStringKnownType;\r\n ValueAttributes: @TObjectKnownType);\r\n\r\n UnicodeStringTObjectKnownMap: TKnownMapAttributes =\r\n (MapAttributes:\r\n ( {maMapInterfaceName} 'IJclUnicodeStrMap',\r\n {maMapInterfaceGUID} '{4328E033-9B92-40C6-873D-A6982CFC2B95}',\r\n {maMapInterfaceAncestorName} 'IJclUnicodeStrContainer',\r\n {maSortedMapInterfaceName} 'IJclUnicodeStrSortedMap',\r\n {maSortedMapInterfaceGUID} '{5510B8FC-3439-4211-8D1F-5EDD9A56D3E3}',\r\n {maMapAncestorClassName} 'TJclUnicodeStrAbstractContainer',\r\n {maHashMapEntryTypeName} 'TJclUnicodeStrHashMapEntry',\r\n {maHashMapEntryArrayTypeName} 'TJclUnicodeStrHashMapEntryArray',\r\n {maHashMapBucketTypeName} 'TJclUnicodeStrHashMapBucket',\r\n {maHashMapClassName} 'TJclUnicodeStrHashMap',\r\n {maSortedMapEntryTypeName} 'TJclUnicodeStrSortedMapEntry',\r\n {maSortedMapEntryArrayTypeName} 'TJclUnicodeStrSortedMapEntryArray',\r\n {maSortedMapClassName} 'TJclUnicodeStrSortedMap' );\r\n KeyAttributes: @UnicodeStringKnownType;\r\n ValueAttributes: @TObjectKnownType);\r\n\r\n StringTObjectKnownMap: TKnownMapAttributes =\r\n (MapAttributes:\r\n ( {maMapInterfaceName} 'IJclStrMap',\r\n {maMapInterfaceGUID} '',\r\n {maMapInterfaceAncestorName} 'IJclStrBaseContainer',\r\n {maSortedMapInterfaceName} 'IJclStrSortedMap',\r\n {maSortedMapInterfaceGUID} '',\r\n {maMapAncestorClassName} 'TJclStrAbstractContainer',\r\n {maHashMapEntryTypeName} 'TJclStrHashMapEntry',\r\n {maHashMapEntryArrayTypeName} 'TJclStrHashMapEntryArray',\r\n {maHashMapBucketTypeName} 'TJclStrHashMapBucket',\r\n {maHashMapClassName} 'TJclStrHashMap',\r\n {maSortedMapEntryTypeName} 'TJclStrSortedMapEntry',\r\n {maSortedMapEntryArrayTypeName} 'TJclStrSortedMapEntryArray',\r\n {maSortedMapClassName} 'TJclStrSortedMap' );\r\n KeyAttributes: @StringKnownType;\r\n ValueAttributes: @TObjectKnownType);\r\n\r\n SingleTObjectKnownMap: TKnownMapAttributes =\r\n (MapAttributes:\r\n ( {maMapInterfaceName} 'IJclSingleMap',\r\n {maMapInterfaceGUID} '{C501920A-F252-4F94-B142-1F05AE06C3D2}',\r\n {maMapInterfaceAncestorName} 'IJclSingleContainer',\r\n {maSortedMapInterfaceName} 'IJclSingleSortedMap',\r\n {maSortedMapInterfaceGUID} '{8C1A12BE-A7F2-4351-90B7-25DB0AAF5F94}',\r\n {maMapAncestorClassName} 'TJclSingleAbstractContainer',\r\n {maHashMapEntryTypeName} 'TJclSingleHashMapEntry',\r\n {maHashMapEntryArrayTypeName} 'TJclSingleHashMapEntryArray',\r\n {maHashMapBucketTypeName} 'TJclSingleHashMapBucket',\r\n {maHashMapClassName} 'TJclSingleHashMap',\r\n {maSortedMapEntryTypeName} 'TJclSingleSortedMapEntry',\r\n {maSortedMapEntryArrayTypeName} 'TJclSingleSortedMapEntryArray',\r\n {maSortedMapClassName} 'TJclSingleSortedMap' );\r\n KeyAttributes: @SingleKnownType;\r\n ValueAttributes: @TObjectKnownType);\r\n\r\n DoubleTObjectKnownMap: TKnownMapAttributes =\r\n (MapAttributes:\r\n ( {maMapInterfaceName} 'IJclDoubleMap',\r\n {maMapInterfaceGUID} '{B1B994AC-49C9-418B-814B-43BAD706F355}',\r\n {maMapInterfaceAncestorName} 'IJclDoubleContainer',\r\n {maSortedMapInterfaceName} 'IJclDoubleSortedMap',\r\n {maSortedMapInterfaceGUID} '{8018D66B-AA54-4016-84FC-3E780FFCC38B}',\r\n {maMapAncestorClassName} 'TJclDoubleAbstractContainer',\r\n {maHashMapEntryTypeName} 'TJclDoubleHashMapEntry',\r\n {maHashMapEntryArrayTypeName} 'TJclDoubleHashMapEntryArray',\r\n {maHashMapBucketTypeName} 'TJclDoubleHashMapBucket',\r\n {maHashMapClassName} 'TJclDoubleHashMap',\r\n {maSortedMapEntryTypeName} 'TJclDoubleSortedMapEntry',\r\n {maSortedMapEntryArrayTypeName} 'TJclDoubleSortedMapEntryArray',\r\n {maSortedMapClassName} 'TJclDoubleSortedMap' );\r\n KeyAttributes: @DoubleKnownType;\r\n ValueAttributes: @TObjectKnownType);\r\n\r\n ExtendedTObjectKnownMap: TKnownMapAttributes =\r\n (MapAttributes:\r\n ( {maMapInterfaceName} 'IJclExtendedMap',\r\n {maMapInterfaceGUID} '{3BCC8C87-A186-45E8-9B37-0B8E85120434}',\r\n {maMapInterfaceAncestorName} 'IJclExtendedContainer',\r\n {maSortedMapInterfaceName} 'IJclExtendedSortedMap',\r\n {maSortedMapInterfaceGUID} '{2B82C65A-B3EF-477D-BEC0-3D8620A226B1}',\r\n {maMapAncestorClassName} 'TJclExtendedAbstractContainer',\r\n {maHashMapEntryTypeName} 'TJclExtendedHashMapEntry',\r\n {maHashMapEntryArrayTypeName} 'TJclExtendedHashMapEntryArray',\r\n {maHashMapBucketTypeName} 'TJclExtendedHashMapBucket',\r\n {maHashMapClassName} 'TJclExtendedHashMap',\r\n {maSortedMapEntryTypeName} 'TJclExtendedSortedMapEntry',\r\n {maSortedMapEntryArrayTypeName} 'TJclExtendedSortedMapEntryArray',\r\n {maSortedMapClassName} 'TJclExtendedSortedMap' );\r\n KeyAttributes: @ExtendedKnownType;\r\n ValueAttributes: @TObjectKnownType);\r\n\r\n FloatTObjectKnownMap: TKnownMapAttributes =\r\n (MapAttributes:\r\n ( {maMapInterfaceName} 'IJclFloatMap',\r\n {maMapInterfaceGUID} '',\r\n {maMapInterfaceAncestorName} 'IJclFloatContainer',\r\n {maSortedMapInterfaceName} 'IJclFloatSortedMap',\r\n {maSortedMapInterfaceGUID} '',\r\n {maMapAncestorClassName} 'TJclFloatAbstractContainer',\r\n {maHashMapEntryTypeName} 'TJclFloatHashMapEntry',\r\n {maHashMapEntryArrayTypeName} 'TJclFloatHashMapEntryArray',\r\n {maHashMapBucketTypeName} 'TJclFloatHashMapBucket',\r\n {maHashMapClassName} 'TJclFloatHashMap',\r\n {maSortedMapEntryTypeName} 'TJclFloatSortedMapEntry',\r\n {maSortedMapEntryArrayTypeName} 'TJclFloatSortedMapEntryArray',\r\n {maSortedMapClassName} 'TJclFloatSortedMap' );\r\n KeyAttributes: @FloatKnownType;\r\n ValueAttributes: @TObjectKnownType);\r\n\r\n IntegerTObjectKnownMap: TKnownMapAttributes =\r\n (MapAttributes:\r\n ( {maMapInterfaceName} 'IJclIntegerMap',\r\n {maMapInterfaceGUID} '{D6FA5D64-A4AF-4419-9981-56BA79BF8770}',\r\n {maMapInterfaceAncestorName} 'IJclBaseContainer',\r\n {maSortedMapInterfaceName} 'IJclIntegerSortedMap',\r\n {maSortedMapInterfaceGUID} '{DD7B4C5E-6D51-44CC-9328-B38396A7E1C9}',\r\n {maMapAncestorClassName} 'TJclIntegerAbstractContainer',\r\n {maHashMapEntryTypeName} 'TJclIntegerHashMapEntry',\r\n {maHashMapEntryArrayTypeName} 'TJclIntegerHashMapEntryArray',\r\n {maHashMapBucketTypeName} 'TJclIntegerHashMapBucket',\r\n {maHashMapClassName} 'TJclIntegerHashMap',\r\n {maSortedMapEntryTypeName} 'TJclIntegerSortedMapEntry',\r\n {maSortedMapEntryArrayTypeName} 'TJclIntegerSortedMapEntryArray',\r\n {maSortedMapClassName} 'TJclIntegerSortedMap' );\r\n KeyAttributes: @IntegerKnownType;\r\n ValueAttributes: @TObjectKnownType);\r\n\r\n CardinalTObjectKnownMap: TKnownMapAttributes =\r\n (MapAttributes:\r\n ( {maMapInterfaceName} 'IJclCardinalMap',\r\n {maMapInterfaceGUID} '{A2F92F4F-11CB-4DB2-932F-F10A14237126}',\r\n {maMapInterfaceAncestorName} 'IJclBaseContainer',\r\n {maSortedMapInterfaceName} 'IJclCardinalSortedMap',\r\n {maSortedMapInterfaceGUID} '{4AEAF81F-D72E-4499-B10E-3D017F39915E}',\r\n {maMapAncestorClassName} 'TJclCardinalAbstractContainer',\r\n {maHashMapEntryTypeName} 'TJclCardinalHashMapEntry',\r\n {maHashMapEntryArrayTypeName} 'TJclCardinalHashMapEntryArray',\r\n {maHashMapBucketTypeName} 'TJclCardinalHashMapBucket',\r\n {maHashMapClassName} 'TJclCardinalHashMap',\r\n {maSortedMapEntryTypeName} 'TJclCardinalSortedMapEntry',\r\n {maSortedMapEntryArrayTypeName} 'TJclCardinalSortedMapEntryArray',\r\n {maSortedMapClassName} 'TJclCardinalSortedMap' );\r\n KeyAttributes: @CardinalKnownType;\r\n ValueAttributes: @TObjectKnownType);\r\n\r\n Int64TObjectKnownMap: TKnownMapAttributes =\r\n (MapAttributes:\r\n ( {maMapInterfaceName} 'IJclInt64Map',\r\n {maMapInterfaceGUID} '{4C720CE0-7A7C-41D5-BFC1-8D58A47E648F}',\r\n {maMapInterfaceAncestorName} 'IJclBaseContainer',\r\n {maSortedMapInterfaceName} 'IJclInt64SortedMap',\r\n {maSortedMapInterfaceGUID} '{06C03F90-7DE9-4043-AA56-AAE071D8BD50}',\r\n {maMapAncestorClassName} 'TJclInt64AbstractContainer',\r\n {maHashMapEntryTypeName} 'TJclInt64HashMapEntry',\r\n {maHashMapEntryArrayTypeName} 'TJclInt64HashMapEntryArray',\r\n {maHashMapBucketTypeName} 'TJclInt64HashMapBucket',\r\n {maHashMapClassName} 'TJclInt64HashMap',\r\n {maSortedMapEntryTypeName} 'TJclInt64SortedMapEntry',\r\n {maSortedMapEntryArrayTypeName} 'TJclInt64SortedMapEntryArray',\r\n {maSortedMapClassName} 'TJclInt64SortedMap' );\r\n KeyAttributes: @Int64KnownType;\r\n ValueAttributes: @TObjectKnownType);\r\n\r\n PointerTObjectKnownMap: TKnownMapAttributes =\r\n (MapAttributes:\r\n ( {maMapInterfaceName} 'IJclPtrMap',\r\n {maMapInterfaceGUID} '{2FE029A9-026C-487D-8204-AD3A28BD2FA2}',\r\n {maMapInterfaceAncestorName} 'IJclBaseContainer',\r\n {maSortedMapInterfaceName} 'IJclPtrSortedMap',\r\n {maSortedMapInterfaceGUID} '{578918DB-6A4A-4A9D-B44E-AE3E8FF70818}',\r\n {maMapAncestorClassName} 'TJclPtrAbstractContainer',\r\n {maHashMapEntryTypeName} 'TJclPtrHashMapEntry',\r\n {maHashMapEntryArrayTypeName} 'TJclPtrHashMapEntryArray',\r\n {maHashMapBucketTypeName} 'TJclPtrHashMapBucket',\r\n {maHashMapClassName} 'TJclPtrHashMap',\r\n {maSortedMapEntryTypeName} 'TJclPtrSortedMapEntry',\r\n {maSortedMapEntryArrayTypeName} 'TJclPtrSortedMapEntryArray',\r\n {maSortedMapClassName} 'TJclPtrSortedMap' );\r\n KeyAttributes: @PointerKnownType;\r\n ValueAttributes: @TObjectKnownType);\r\n\r\n TObjectTObjectKnownMap: TKnownMapAttributes =\r\n (MapAttributes:\r\n ( {maMapInterfaceName} 'IJclMap',\r\n {maMapInterfaceGUID} '{A7D0A882-6952-496D-A258-23D47DDCCBC4}',\r\n {maMapInterfaceAncestorName} 'IJclBaseContainer',\r\n {maSortedMapInterfaceName} 'IJclSortedMap',\r\n {maSortedMapInterfaceGUID} '{F317A70F-7851-49C2-9DCF-092D8F4D4F98}',\r\n {maMapAncestorClassName} 'TJclAbstractContainerBase',\r\n {maHashMapEntryTypeName} 'TJclHashMapEntry',\r\n {maHashMapEntryArrayTypeName} 'TJclHashMapEntryArray',\r\n {maHashMapBucketTypeName} 'TJclHashMapBucket',\r\n {maHashMapClassName} 'TJclHashMap',\r\n {maSortedMapEntryTypeName} 'TJclSortedMapEntry',\r\n {maSortedMapEntryArrayTypeName} 'TJclSortedMapEntryArray',\r\n {maSortedMapClassName} 'TJclSortedMap' );\r\n KeyAttributes: @TObjectKnownType;\r\n ValueAttributes: @TObjectKnownType);\r\n\r\n KnownAllMaps: array[0..50] of PKnownMapAttributes =\r\n ( @IInterfaceIInterfaceKnownMap,\r\n @AnsiStringIInterfaceKnownMap,\r\n @IInterfaceAnsiStringKnownMap,\r\n @AnsiStringAnsiStringKnownMap,\r\n @WideStringIInterfaceKnownMap,\r\n @IInterfaceWideStringKnownMap,\r\n @WideStringWideStringKnownMap,\r\n @UnicodeStringIInterfaceKnownMap,\r\n @IInterfaceUnicodeStringKnownMap,\r\n @UnicodeStringUnicodeStringKnownMap,\r\n @StringIInterfaceKnownMap,\r\n @IInterfaceStringKnownMap,\r\n @StringStringKnownMap,\r\n @SingleIInterfaceKnownMap,\r\n @IInterfaceSingleKnownMap,\r\n @SingleSingleKnownMap,\r\n @DoubleIInterfaceKnownMap,\r\n @IInterfaceDoubleKnownMap,\r\n @DoubleDoubleKnownMap,\r\n @ExtendedIInterfaceKnownMap,\r\n @IInterfaceExtendedKnownMap,\r\n @ExtendedExtendedKnownMap,\r\n @FloatIInterfaceKnownMap,\r\n @IInterfaceFloatKnownMap,\r\n @FloatFloatKnownMap,\r\n @IntegerIInterfaceKnownMap,\r\n @IInterfaceIntegerKnownMap,\r\n @IntegerIntegerKnownMap,\r\n @CardinalIInterfaceKnownMap,\r\n @IInterfaceCardinalKnownMap,\r\n @CardinalCardinalKnownMap,\r\n @Int64IInterfaceKnownMap,\r\n @IInterfaceInt64KnownMap,\r\n @Int64Int64KnownMap,\r\n @PointerIInterfaceKnownMap,\r\n @IInterfacePointerKnownMap,\r\n @PointerPointerKnownMap,\r\n @IInterfaceTObjectKnownMap,\r\n @AnsiStringTObjectKnownMap,\r\n @WideStringTObjectKnownMap,\r\n @UnicodeStringTObjectKnownMap,\r\n @StringTObjectKnownMap,\r\n @SingleTObjectKnownMap,\r\n @DoubleTObjectKnownMap,\r\n @ExtendedTObjectKnownMap,\r\n @FloatTObjectKnownMap,\r\n @IntegerTObjectKnownMap,\r\n @CardinalTObjectKnownMap,\r\n @Int64TObjectKnownMap,\r\n @PointerTObjectKnownMap,\r\n @TObjectTObjectKnownMap );\r\n\r\n // same as previous, except without compiler magic types (string) and type aliases (float)\r\n KnownTrueMaps: array[0..42] of PKnownMapAttributes =\r\n ( @IInterfaceIInterfaceKnownMap,\r\n @AnsiStringIInterfaceKnownMap,\r\n @IInterfaceAnsiStringKnownMap,\r\n @AnsiStringAnsiStringKnownMap,\r\n @WideStringIInterfaceKnownMap,\r\n @IInterfaceWideStringKnownMap,\r\n @WideStringWideStringKnownMap,\r\n @UnicodeStringIInterfaceKnownMap,\r\n @IInterfaceUnicodeStringKnownMap,\r\n @UnicodeStringUnicodeStringKnownMap,\r\n @SingleIInterfaceKnownMap,\r\n @IInterfaceSingleKnownMap,\r\n @SingleSingleKnownMap,\r\n @DoubleIInterfaceKnownMap,\r\n @IInterfaceDoubleKnownMap,\r\n @DoubleDoubleKnownMap,\r\n @ExtendedIInterfaceKnownMap,\r\n @IInterfaceExtendedKnownMap,\r\n @ExtendedExtendedKnownMap,\r\n @IntegerIInterfaceKnownMap,\r\n @IInterfaceIntegerKnownMap,\r\n @IntegerIntegerKnownMap,\r\n @CardinalIInterfaceKnownMap,\r\n @IInterfaceCardinalKnownMap,\r\n @CardinalCardinalKnownMap,\r\n @Int64IInterfaceKnownMap,\r\n @IInterfaceInt64KnownMap,\r\n @Int64Int64KnownMap,\r\n @PointerIInterfaceKnownMap,\r\n @IInterfacePointerKnownMap,\r\n @PointerPointerKnownMap,\r\n @IInterfaceTObjectKnownMap,\r\n @AnsiStringTObjectKnownMap,\r\n @WideStringTObjectKnownMap,\r\n @UnicodeStringTObjectKnownMap,\r\n @SingleTObjectKnownMap,\r\n @DoubleTObjectKnownMap,\r\n @ExtendedTObjectKnownMap,\r\n @IntegerTObjectKnownMap,\r\n @CardinalTObjectKnownMap,\r\n @Int64TObjectKnownMap,\r\n @PointerTObjectKnownMap,\r\n @TObjectTObjectKnownMap );\r\n\r\nfunction IsKnownMap(const KeyName, ValueName: string): PKnownMapAttributes;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jcl.svn.sourceforge.net/svnroot/jcl/tags/JCL-2.4-Build4571/jcl/source/common/JclPreProcessorContainerKnownMaps.pas $';\r\n Revision: '$Revision: 3747 $';\r\n Date: '$Date: 2012-02-24 12:27:42 +0100 (ven. 24 févr. 2012) $';\r\n LogPath: 'JCL\\source\\common';\r\n Extra: '';\r\n Data: nil\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n {$IFDEF HAS_UNITSCOPE}\r\n System.SysUtils;\r\n {$ELSE ~HAS_UNITSCOPE}\r\n SysUtils;\r\n {$ENDIF ~HAS_UNITSCOPE}\r\n\r\nfunction IsKnownMap(const KeyName, ValueName: string): PKnownMapAttributes;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := nil;\r\n for I := Low(KnownAllMaps) to High(KnownAllMaps) do\r\n if SameText(KeyName, KnownAllMaps[I]^.KeyAttributes[taTypeName]) and\r\n SameText(ValueName, KnownAllMaps[I]^.ValueAttributes[taTypeName]) then\r\n begin\r\n Result := KnownAllMaps[I];\r\n Break;\r\n end;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jcl/source/common/JclPreProcessorContainerKnownTypes.pas", "content": "{**************************************************************************************************}\r\n{ }\r\n{ Project JEDI Code Library (JCL) }\r\n{ }\r\n{ The contents of this file are subject to the Mozilla Public License Version 1.1 (the \"License\"); }\r\n{ you may not use this file except in compliance with the License. You may obtain a copy of the }\r\n{ License at http://www.mozilla.org/MPL/ }\r\n{ }\r\n{ Software distributed under the License is distributed on an \"AS IS\" basis, WITHOUT WARRANTY OF }\r\n{ ANY KIND, either express or implied. See the License for the specific language governing rights }\r\n{ and limitations under the License. }\r\n{ }\r\n{ The Original Code is JclContainerKnownTypes.pas. }\r\n{ }\r\n{ The Initial Developer of the Original Code is Florent Ouchet }\r\n{ }\r\n{ Portions created by Florent Ouchet are Copyright (C) of Florent Ouchet. All rights reserved. }\r\n{ }\r\n{ Contributors: }\r\n{ }\r\n{**************************************************************************************************}\r\n{ }\r\n{ Last modified: $Date:: 2012-02-24 12:23:03 +0100 (ven. 24 févr. 2012) $ }\r\n{ Revision: $Rev:: 3746 $ }\r\n{ Author: $Author:: outchy $ }\r\n{ }\r\n{**************************************************************************************************}\r\n\r\nunit JclPreProcessorContainerKnownTypes;\r\n\r\ninterface\r\n\r\n{$I jcl.inc}\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n JclPreProcessorContainerTypes;\r\n\r\nconst\r\n IInterfaceKnownType: TKnownTypeAttributes =\r\n ({taTypeName} 'IInterface',\r\n {taCondition} '',\r\n {taDefines} 'REFCOUNTED',\r\n {taUndefs} 'ZEROINIT;GENERIC',\r\n {taAlias} '',\r\n {taAliasCondition} '',\r\n {taDefaultValue} 'nil',\r\n {taConstKeyword} 'const ',\r\n {taOwnershipParameterName} '',\r\n {taOwnershipInterfaceName} 'IJclIntfOwner',\r\n {taOwnershipInterfaceGUID} '{17C1D3FB-BB32-48F2-BD1C-D43EA05A86A8}',\r\n {taReleaserFunctionName} 'FreeObject',\r\n {taReleaseEventName} 'OnFreeObject',\r\n {taReleaseEventTypeName} 'TFreeIntfEvent',\r\n {taGetterFunctionName} 'GetObject',\r\n {taSetterProcedureName} 'SetObject',\r\n {taParameterName} 'AInterface',\r\n {taDynArrayTypeName} 'TDynIInterfaceArray',\r\n {taMoveArrayProcedureName} 'MoveArray',\r\n {taArrayPropertyName} 'Objects',\r\n {taBaseContainerClassName} 'TJclIntfAbstractContainer',\r\n {taBaseCollectionClassName} '',\r\n {taIterateProcedureTypeName} 'TIntfIterateProcedure',\r\n {taIterateProcedureName} 'Iterate',\r\n {taApplyFunctionTypeName} 'TIntfApplyFunction',\r\n {taApplyProcedureName} 'Apply',\r\n {taCompareFunctionTypeName} 'TIntfCompare',\r\n {taSimpleCompareFunctionName} 'IntfSimpleCompare',\r\n {taEqualityCompareFunctionTypeName} 'TIntfEqualityCompare',\r\n {taSimpleEqualityCompareFunctionName} 'IntfSimpleEqualityCompare',\r\n {taHashConvertFunctionTypeName} 'TIntfHashConvert',\r\n {taSimpleHashConvertFunctionName} 'IntfSimpleHashConvert',\r\n {taContainerInterfaceName} 'IJclIntfContainer',\r\n {taContainerInterfaceGUID} '{44F10075-9702-4DCA-9731-D8990F234A74}',\r\n {taFlatContainerInterfaceName} 'IJclIntfFlatContainer',\r\n {taFlatContainerInterfaceGUID} '{15116007-6BB8-4D9D-8249-C2F49D4AB3EA}',\r\n {taEqualityComparerInterfaceName} 'IJclIntfEqualityComparer',\r\n {taEqualityComparerInterfaceGUID} '{5CC2DF51-BE56-4D02-A171-31BAAC097632}',\r\n {taComparerInterfaceName} 'IJclIntfComparer',\r\n {taComparerInterfaceGUID} '{EB41B843-184B-420D-B5DA-27D055B4CD55}',\r\n {taHashConverterInterfaceName} 'IJclIntfHashConverter',\r\n {taHashConverterInterfaceGUID} '{7BAA0791-3B45-4D0F-9CD8-D13B81694786}',\r\n {taIteratorInterfaceName} 'IJclIntfIterator',\r\n {taIteratorInterfaceGUID} '{E121A98A-7C43-4587-806B-9189E8B2F106}',\r\n {taBinaryTreeIteratorInterfaceName} 'IJclIntfBinaryTreeIterator',\r\n {taBinaryTreeIteratorInterfaceGUID} '{8BE874B2-0075-4EE0-8F49-665FC894D923}',\r\n {taBinaryTreeNodeTypeName} 'TJclIntfBinaryNode',\r\n {taBinaryTreeClassName} 'TJclIntfBinaryTree',\r\n {taBinaryTreeBaseIteratorClassName} 'TJclIntfBinaryTreeIterator',\r\n {taBinaryTreePreOrderIteratorClassName} 'TJclPreOrderIntfBinaryTreeIterator',\r\n {taBinaryTreeInOrderIteratorClassName} 'TJclInOrderIntfBinaryTreeIterator',\r\n {taBinaryTreePostOrderIteratorClassName} 'TJclPostOrderIntfBinaryTreeIterator',\r\n {taCollectionInterfaceName} 'IJclIntfCollection',\r\n {taCollectionInterfaceGUID} '{8E178463-4575-487A-B4D5-DC2AED3C7ACA}',\r\n {taListInterfaceName} 'IJclIntfList',\r\n {taListInterfaceGUID} '{E14EDA4B-1DAA-4013-9E6C-CDCB365C7CF9}',\r\n {taSortProcedureTypeName} 'TIntfSortProc',\r\n {taSortProcedureName} 'Sort',\r\n {taQuickSortProcedureName} 'QuickSort',\r\n {taFindFunctionName} 'Find',\r\n {taCountObjectFunctionName} 'CountObject',\r\n {taCopyProcedureName} 'Copy',\r\n {taGenerateProcedureName} 'Generate',\r\n {taFillProcedureName} 'Fill',\r\n {taReverseProcedureName} 'Reverse',\r\n {taArrayInterfaceName} 'IJclIntfArray',\r\n {taArrayInterfaceGUID} '{B055B427-7817-43FC-97D4-AD1845643D63}',\r\n {taArrayListClassName} 'TJclIntfArrayList',\r\n {taArrayIteratorClassName} 'TJclIntfArrayIterator',\r\n {taLinkedListItemClassName} 'TJclIntfLinkedListItem',\r\n {taLinkedListClassName} 'TJclIntfLinkedList',\r\n {taLinkedListIteratorClassName} 'TJclIntfLinkedListIterator',\r\n {taVectorClassName} 'TJclIntfVector',\r\n {taVectorIteratorClassName} 'TJclIntfVectorIterator',\r\n {taSetInterfaceName} 'IJclIntfSet',\r\n {taSetInterfaceGUID} '{E2D28852-9774-49B7-A739-5DBA2B705924}',\r\n {taArraySetClassName} 'TJclIntfArraySet',\r\n {taHashSetBucketTypeName} 'TJclIntfHashSetBucket',\r\n {taHashSetClassName} 'TJclIntfHashSet',\r\n {taHashSetIteratorClassName} 'TJclIntfHashSetIterator',\r\n {taTreeIteratorInterfaceName} 'IJclIntfTreeIterator',\r\n {taTreeIteratorInterfaceGUID} '{C97379BF-C6A9-4A90-9D7A-152E9BAD314F}',\r\n {taTreeInterfaceName} 'IJclIntfTree',\r\n {taTreeInterfaceGUID} '{5A21688F-113D-41B4-A17C-54BDB0BD6559}',\r\n {taTreeNodeClassName} 'TJclIntfTreeNode',\r\n {taTreeClassName} 'TJclIntfTree',\r\n {taTreeBaseIteratorClassName} 'TJclIntfTreeIterator',\r\n {taTreePreOrderIteratorClassName} 'TJclPreOrderIntfTreeIterator',\r\n {taTreePostOrderIteratorClassName} 'TJclPostOrderIntfTreeIterator',\r\n {taQueueInterfaceName} 'IJclIntfQueue',\r\n {taQueueInterfaceGUID} '{B88756FE-5553-4106-957E-3E33120BFA99}',\r\n {taQueueClassName} 'TJclIntfQueue',\r\n {taSortedSetInterfaceName} 'IJclIntfSortedSet',\r\n {taSortedSetInterfaceGUID} '{159BE5A7-7349-42FF-BE55-9CA1B9DBA991}',\r\n {taStackInterfaceName} 'IJclIntfStack',\r\n {taStackInterfaceGUID} '{CA1DC7A1-8D8F-4A5D-81D1-0FE32E9A4E84}',\r\n {taStackClassName} 'TJclIntfStack'\r\n );\r\n\r\n AnsiStringKnownType: TKnownTypeAttributes =\r\n ({taTypeName} 'AnsiString',\r\n {taCondition} '',\r\n {taDefines} 'REFCOUNTED',\r\n {taUndefs} 'ZEROINIT;GENERIC',\r\n {taAlias} 'string',\r\n {taAliasCondition} 'CONTAINER_ANSISTR',\r\n {taDefaultValue} '''''',\r\n {taConstKeyword} 'const ',\r\n {taOwnershipParameterName} '',\r\n {taOwnershipInterfaceName} 'IJclAnsiStrOwner',\r\n {taOwnershipInterfaceGUID} '{4F64F1F6-766A-4CFA-B51B-654116E308A8}',\r\n {taReleaserFunctionName} 'FreeString',\r\n {taReleaseEventName} 'OnFreeString',\r\n {taReleaseEventTypeName} 'TFreeAnsiStrEvent',\r\n {taGetterFunctionName} 'GetString',\r\n {taSetterProcedureName} 'SetString',\r\n {taParameterName} 'AString',\r\n {taDynArrayTypeName} 'TDynAnsiStringArray',\r\n {taMoveArrayProcedureName} 'MoveArray',\r\n {taArrayPropertyName} 'Strings',\r\n {taBaseContainerClassName} 'TJclAnsiStrAbstractContainer',\r\n {taBaseCollectionClassName} 'TJclAnsiStrAbstractCollection',\r\n {taIterateProcedureTypeName} 'TAnsiStrIterateProcedure',\r\n {taIterateProcedureName} 'Iterate',\r\n {taApplyFunctionTypeName} 'TAnsiStrApplyFunction',\r\n {taApplyProcedureName} 'Apply',\r\n {taCompareFunctionTypeName} 'TAnsiStrCompare',\r\n {taSimpleCompareFunctionName} 'AnsiStrSimpleCompare',\r\n {taEqualityCompareFunctionTypeName} 'TAnsiStrEqualityCompare',\r\n {taSimpleEqualityCompareFunctionName} 'AnsiStrSimpleEqualityCompare',\r\n {taHashConvertFunctionTypeName} 'TAnsiStrHashConvert',\r\n {taSimpleHashConvertFunctionName} 'AnsiStrSimpleHashConvert',\r\n {taContainerInterfaceName} 'IJclAnsiStrContainer',\r\n {taContainerInterfaceGUID} '{F8239357-B96F-46F1-A48E-B5DF25B5F1FA}',\r\n {taFlatContainerInterfaceName} 'IJclAnsiStrFlatContainer',\r\n {taFlatContainerInterfaceGUID} '{8A45A4D4-6317-4CDF-8314-C3E5CC6899F4}',\r\n {taEqualityComparerInterfaceName} 'IJclAnsiStrEqualityComparer',\r\n {taEqualityComparerInterfaceGUID} '{E3DB9016-F0D0-4CE0-B156-4C5DCA47FD3B}',\r\n {taComparerInterfaceName} 'IJclAnsiStrComparer',\r\n {taComparerInterfaceGUID} '{09063CBB-9226-4734-B2A0-A178C2343176}',\r\n {taHashConverterInterfaceName} 'IJclAnsiStrHashConverter',\r\n {taHashConverterInterfaceGUID} '{9841014E-8A31-4C79-8AD5-EB03C4E85533}',\r\n {taIteratorInterfaceName} 'IJclAnsiStrIterator',\r\n {taIteratorInterfaceGUID} '{D5D4B681-F902-49C7-B9E1-73007C9D64F0}',\r\n {taBinaryTreeIteratorInterfaceName} 'IJclAnsiStrBinaryTreeIterator',\r\n {taBinaryTreeIteratorInterfaceGUID} '{34A4A300-042C-43A9-AC23-8FC1B76BFB25}',\r\n {taBinaryTreeNodeTypeName} 'TJclAnsiStrBinaryNode',\r\n {taBinaryTreeClassName} 'TJclAnsiStrBinaryTree',\r\n {taBinaryTreeBaseIteratorClassName} 'TJclAnsiStrBinaryTreeIterator',\r\n {taBinaryTreePreOrderIteratorClassName} 'TJclPreOrderAnsiStrBinaryTreeIterator',\r\n {taBinaryTreeInOrderIteratorClassName} 'TJclInOrderAnsiStrBinaryTreeIterator',\r\n {taBinaryTreePostOrderIteratorClassName} 'TJclPostOrderAnsiStrBinaryTreeIterator',\r\n {taCollectionInterfaceName} 'IJclAnsiStrCollection',\r\n {taCollectionInterfaceGUID} '{3E3CFC19-E8AF-4DD7-91FA-2DF2895FC7B9}',\r\n {taListInterfaceName} 'IJclAnsiStrList',\r\n {taListInterfaceGUID} '{07DD7644-EAC6-4059-99FC-BEB7FBB73186}',\r\n {taSortProcedureTypeName} 'TAnsiStrSortProc',\r\n {taSortProcedureName} 'Sort',\r\n {taQuickSortProcedureName} 'QuickSort',\r\n {taFindFunctionName} 'Find',\r\n {taCountObjectFunctionName} 'CountObject',\r\n {taCopyProcedureName} 'Copy',\r\n {taGenerateProcedureName} 'Generate',\r\n {taFillProcedureName} 'Fill',\r\n {taReverseProcedureName} 'Reverse',\r\n {taArrayInterfaceName} 'IJclAnsiStrArray',\r\n {taArrayInterfaceGUID} '{4953EA83-9288-4537-9D10-544D1C992B62}',\r\n {taArrayListClassName} 'TJclAnsiStrArrayList',\r\n {taArrayIteratorClassName} 'TJclAnsiStrArrayIterator',\r\n {taLinkedListItemClassName} 'TJclAnsiStrLinkedListItem',\r\n {taLinkedListClassName} 'TJclAnsiStrLinkedList',\r\n {taLinkedListIteratorClassName} 'TJclAnsiStrLinkedListIterator',\r\n {taVectorClassName} 'TJclAnsiStrVector',\r\n {taVectorIteratorClassName} 'TJclAnsiStrVectorIterator',\r\n {taSetInterfaceName} 'IJclAnsiStrSet',\r\n {taSetInterfaceGUID} '{72204D85-2B68-4914-B9F2-09E5180C12E9}',\r\n {taArraySetClassName} 'TJclAnsiStrArraySet',\r\n {taHashSetBucketTypeName} 'TJclAnsiStrHashSetBucket',\r\n {taHashSetClassName} 'TJclAnsiStrHashSet',\r\n {taHashSetIteratorClassName} 'TJclAnsiStrHashSetIterator',\r\n {taTreeIteratorInterfaceName} 'IJclAnsiStrTreeIterator',\r\n {taTreeIteratorInterfaceGUID} '{66BC5C76-758C-4E72-ABF1-EB02CF851C6D}',\r\n {taTreeInterfaceName} 'IJclAnsiStrTree',\r\n {taTreeInterfaceGUID} '{1E1896C0-0497-47DF-83AF-A9422084636C}',\r\n {taTreeNodeClassName} 'TJclAnsiStrTreeNode',\r\n {taTreeClassName} 'TJclAnsiStrTree',\r\n {taTreeBaseIteratorClassName} 'TJclAnsiStrTreeIterator',\r\n {taTreePreOrderIteratorClassName} 'TJclPreOrderAnsiStrTreeIterator',\r\n {taTreePostOrderIteratorClassName} 'TJclPostOrderAnsiStrTreeIterator',\r\n {taQueueInterfaceName} 'IJclAnsiStrQueue',\r\n {taQueueInterfaceGUID} '{5BA0ED9A-5AF3-4F79-9D80-34FA7FF15D1F}',\r\n {taQueueClassName} 'TJclAnsiStrQueue',\r\n {taSortedSetInterfaceName} 'IJclAnsiStrSortedSet',\r\n {taSortedSetInterfaceGUID} '{03198146-F967-4310-868B-7AD3D52D5CBE}',\r\n {taStackInterfaceName} 'IJclAnsiStrStack',\r\n {taStackInterfaceGUID} '{649BB74C-D7BE-40D9-9F4E-32DDC3F13F3B}',\r\n {taStackClassName} 'TJclAnsiStrStack'\r\n );\r\n\r\n WideStringKnownType: TKnownTypeAttributes =\r\n ({taTypeName} 'WideString',\r\n {taCondition} '',\r\n {taDefines} 'REFCOUNTED',\r\n {taUndefs} 'ZEROINIT;GENERIC',\r\n {taAlias} 'string',\r\n {taAliasCondition} 'CONTAINER_WIDESTR',\r\n {taDefaultValue} '''''',\r\n {taConstKeyword} 'const ',\r\n {taOwnershipParameterName} '',\r\n {taOwnershipInterfaceName} 'IJclWideStrOwner',\r\n {taOwnershipInterfaceGUID} '{282B7A64-BCD0-4EAE-8776-4EF92D7E3D8B}',\r\n {taReleaserFunctionName} 'FreeString',\r\n {taReleaseEventName} 'OnFreeString',\r\n {taReleaseEventTypeName} 'TFreeWideStrEvent',\r\n {taGetterFunctionName} 'GetString',\r\n {taSetterProcedureName} 'SetString',\r\n {taParameterName} 'AString',\r\n {taDynArrayTypeName} 'TDynWideStringArray',\r\n {taMoveArrayProcedureName} 'MoveArray',\r\n {taArrayPropertyName} 'Strings',\r\n {taBaseContainerClassName} 'TJclWideStrAbstractContainer',\r\n {taBaseCollectionClassName} 'TJclWideStrAbstractCollection',\r\n {taIterateProcedureTypeName} 'TWideStrIterateProcedure',\r\n {taIterateProcedureName} 'Iterate',\r\n {taApplyFunctionTypeName} 'TWideStrApplyFunction',\r\n {taApplyProcedureName} 'Apply',\r\n {taCompareFunctionTypeName} 'TWideStrCompare',\r\n {taSimpleCompareFunctionName} 'WideStrSimpleCompare',\r\n {taEqualityCompareFunctionTypeName} 'TWideStrEqualityCompare',\r\n {taSimpleEqualityCompareFunctionName} 'WideStrSimpleEqualityCompare',\r\n {taHashConvertFunctionTypeName} 'TWideStrHashConvert',\r\n {taSimpleHashConvertFunctionName} 'WideStrSimpleHashConvert',\r\n {taContainerInterfaceName} 'IJclWideStrContainer',\r\n {taContainerInterfaceGUID} '{875E1AC4-CA22-46BC-8999-048E5B9BF11D}',\r\n {taFlatContainerInterfaceName} 'IJclWideStrFlatContainer',\r\n {taFlatContainerInterfaceGUID} '{5B001B93-CA1C-47A8-98B8-451CCB444930}',\r\n {taEqualityComparerInterfaceName} 'IJclWideStrEqualityComparer',\r\n {taEqualityComparerInterfaceGUID} '{2E5696C9-8374-4347-9DC9-B3722F47F5FB}',\r\n {taComparerInterfaceName} 'IJclWideStrComparer',\r\n {taComparerInterfaceGUID} '{7A24AEDA-25B1-4E73-B2E9-5D74011E4C9C}',\r\n {taHashConverterInterfaceName} 'IJclWideStrHashConverter',\r\n {taHashConverterInterfaceGUID} '{2584118F-19AE-443E-939B-0DB18BCD0117}',\r\n {taIteratorInterfaceName} 'IJclWideStrIterator',\r\n {taIteratorInterfaceGUID} '{F03BC7D4-CCDA-4C4A-AF3A-E51FDCDE8ADE}',\r\n {taBinaryTreeIteratorInterfaceName} 'IJclWideStrBinaryTreeIterator',\r\n {taBinaryTreeIteratorInterfaceGUID} '{17C08EB9-6880-469E-878A-8F5EBFE905B1}',\r\n {taBinaryTreeNodeTypeName} 'TJclWideStrBinaryNode',\r\n {taBinaryTreeClassName} 'TJclWideStrBinaryTree',\r\n {taBinaryTreeBaseIteratorClassName} 'TJclWideStrBinaryTreeIterator',\r\n {taBinaryTreePreOrderIteratorClassName} 'TJclPreOrderWideStrBinaryTreeIterator',\r\n {taBinaryTreeInOrderIteratorClassName} 'TJclInOrderWideStrBinaryTreeIterator',\r\n {taBinaryTreePostOrderIteratorClassName} 'TJclPostOrderWideStrBinaryTreeIterator',\r\n {taCollectionInterfaceName} 'IJclWideStrCollection',\r\n {taCollectionInterfaceGUID} '{CDCC0F94-4DD0-4F25-B441-6AE55D5C7466}',\r\n {taListInterfaceName} 'IJclWideStrList',\r\n {taListInterfaceGUID} '{C9955874-6AC0-4CE0-8CC0-606A3F1702C6}',\r\n {taSortProcedureTypeName} 'TWideStrSortProc',\r\n {taSortProcedureName} 'Sort',\r\n {taQuickSortProcedureName} 'QuickSort',\r\n {taFindFunctionName} 'Find',\r\n {taCountObjectFunctionName} 'CountObject',\r\n {taCopyProcedureName} 'Copy',\r\n {taGenerateProcedureName} 'Generate',\r\n {taFillProcedureName} 'Fill',\r\n {taReverseProcedureName} 'Reverse',\r\n {taArrayInterfaceName} 'IJclWideStrArray',\r\n {taArrayInterfaceGUID} '{3CE09F9A-5CB4-4867-80D5-C2313D278D69}',\r\n {taArrayListClassName} 'TJclWideStrArrayList',\r\n {taArrayIteratorClassName} 'TJclWideStrArrayIterator',\r\n {taLinkedListItemClassName} 'TJclWideStrLinkedListItem',\r\n {taLinkedListClassName} 'TJclWideStrLinkedList',\r\n {taLinkedListIteratorClassName} 'TJclWideStrLinkedListIterator',\r\n {taVectorClassName} 'TJclWideStrVector',\r\n {taVectorIteratorClassName} 'TJclWideStrVectorIterator',\r\n {taSetInterfaceName} 'IJclWideStrSet',\r\n {taSetInterfaceGUID} '{08009E0A-ABDD-46AB-8CEE-407D4723E17C}',\r\n {taArraySetClassName} 'TJclWideStrArraySet',\r\n {taHashSetBucketTypeName} 'TJclWideStrHashSetBucket',\r\n {taHashSetClassName} 'TJclWideStrHashSet',\r\n {taHashSetIteratorClassName} 'TJclWideStrHashSetIterator',\r\n {taTreeIteratorInterfaceName} 'IJclWideStrTreeIterator',\r\n {taTreeIteratorInterfaceGUID} '{B3168A3B-5A90-4ABF-855F-3D2B3AB6EE7F}',\r\n {taTreeInterfaceName} 'IJclWideStrTree',\r\n {taTreeInterfaceGUID} '{E325615A-7A20-4788-87FA-9051002CCD91}',\r\n {taTreeNodeClassName} 'TJclWideStrTreeNode',\r\n {taTreeClassName} 'TJclWideStrTree',\r\n {taTreeBaseIteratorClassName} 'TJclWideStrTreeIterator',\r\n {taTreePreOrderIteratorClassName} 'TJclPreOrderWideStrTreeIterator',\r\n {taTreePostOrderIteratorClassName} 'TJclPostOrderWideStrTreeIterator',\r\n {taQueueInterfaceName} 'IJclWideStrQueue',\r\n {taQueueInterfaceGUID} '{058BBFB7-E9B9-44B5-B676-D5B5B9A79BEF}',\r\n {taQueueClassName} 'TJclWideStrQueue',\r\n {taSortedSetInterfaceName} 'IJclWideStrSortedSet',\r\n {taSortedSetInterfaceGUID} '{ED9567E2-C1D3-4C00-A1D4-90D5C7E27C2D}',\r\n {taStackInterfaceName} 'IJclWideStrStack',\r\n {taStackInterfaceGUID} '{B2C3B165-33F1-4B7D-A2EC-0B19D12CE33C}',\r\n {taStackClassName} 'TJclWideStrStack'\r\n );\r\n\r\n UnicodeStringKnownType: TKnownTypeAttributes =\r\n ({taTypeName} 'UnicodeString',\r\n {taCondition} 'SUPPORTS_UNICODE_STRING',\r\n {taDefines} 'REFCOUNTED',\r\n {taUndefs} 'ZEROINIT;GENERIC',\r\n {taAlias} 'string',\r\n {taAliasCondition} 'CONTAINER_UNICODESTR',\r\n {taDefaultValue} '''''',\r\n {taConstKeyword} 'const ',\r\n {taOwnershipParameterName} '',\r\n {taOwnershipInterfaceName} 'IJclUnicodeStrOwner',\r\n {taOwnershipInterfaceGUID} '{07F402E6-DD97-4AA4-83D8-4CCD419FCCFC}',\r\n {taReleaserFunctionName} 'FreeString',\r\n {taReleaseEventName} 'OnFreeString',\r\n {taReleaseEventTypeName} 'TFreeUnicodeStrEvent',\r\n {taGetterFunctionName} 'GetString',\r\n {taSetterProcedureName} 'SetString',\r\n {taParameterName} 'AString',\r\n {taDynArrayTypeName} 'TDynUnicodeStringArray',\r\n {taMoveArrayProcedureName} 'MoveArray',\r\n {taArrayPropertyName} 'Strings',\r\n {taBaseContainerClassName} 'TJclUnicodeStrAbstractContainer',\r\n {taBaseCollectionClassName} 'TJclUnicodeStrAbstractCollection',\r\n {taIterateProcedureTypeName} 'TUnicodeStrIterateProcedure',\r\n {taIterateProcedureName} 'Iterate',\r\n {taApplyFunctionTypeName} 'TUnicodeStrApplyFunction',\r\n {taApplyProcedureName} 'Apply',\r\n {taCompareFunctionTypeName} 'TUnicodeStrCompare',\r\n {taSimpleCompareFunctionName} 'UnicodeStrSimpleCompare',\r\n {taEqualityCompareFunctionTypeName} 'TUnicodeStrEqualityCompare',\r\n {taSimpleEqualityCompareFunctionName} 'UnicodeStrSimpleEqualityCompare',\r\n {taHashConvertFunctionTypeName} 'TUnicodeStrHashConvert',\r\n {taSimpleHashConvertFunctionName} 'UnicodeStrSimpleHashConvert',\r\n {taContainerInterfaceName} 'IJclUnicodeStrContainer',\r\n {taContainerInterfaceGUID} '{619BA29F-5E05-464D-B472-1C8453DBC707}',\r\n {taFlatContainerInterfaceName} 'IJclUnicodeStrFlatContainer',\r\n {taFlatContainerInterfaceGUID} '{3343D73E-4ADC-458E-8289-A4B83D1479D1}',\r\n {taEqualityComparerInterfaceName} 'IJclUnicodeStrEqualityComparer',\r\n {taEqualityComparerInterfaceGUID} '{EDFCC1C7-79DB-4F58-BD64-5016B44EEAC0}',\r\n {taComparerInterfaceName} 'IJclUnicodeStrComparer',\r\n {taComparerInterfaceGUID} '{E81E2705-0CA0-4DBD-BECC-5F9AA623A6E4}',\r\n {taHashConverterInterfaceName} 'IJclUnicodeStrHashConverter',\r\n {taHashConverterInterfaceGUID} '{08CD8171-DBAF-405F-9802-46D955C8BBE6}',\r\n {taIteratorInterfaceName} 'IJclUnicodeStrIterator',\r\n {taIteratorInterfaceGUID} '{B913FFDC-792A-48FB-B58E-763EFDEBA15C}',\r\n {taBinaryTreeIteratorInterfaceName} 'IJclUnicodeStrBinaryTreeIterator',\r\n {taBinaryTreeIteratorInterfaceGUID} '{CA32B126-AD4B-4C33-BC47-52B09FE093BE}',\r\n {taBinaryTreeNodeTypeName} 'TJclUnicodeStrBinaryNode',\r\n {taBinaryTreeClassName} 'TJclUnicodeStrBinaryTree',\r\n {taBinaryTreeBaseIteratorClassName} 'TJclUnicodeStrBinaryTreeIterator',\r\n {taBinaryTreePreOrderIteratorClassName} 'TJclPreOrderUnicodeStrBinaryTreeIterator',\r\n {taBinaryTreeInOrderIteratorClassName} 'TJclInOrderUnicodeStrBinaryTreeIterator',\r\n {taBinaryTreePostOrderIteratorClassName} 'TJclPostOrderUnicodeStrBinaryTreeIterator',\r\n {taCollectionInterfaceName} 'IJclUnicodeStrCollection',\r\n {taCollectionInterfaceGUID} '{82EA7DDE-4EBF-4E0D-A380-CAF8A24C1A0D}',\r\n {taListInterfaceName} 'IJclUnicodeStrList',\r\n {taListInterfaceGUID} '{F4307EB4-D66E-4656-AC56-50883D0F2C83}',\r\n {taSortProcedureTypeName} 'TUnicodeStrSortProc',\r\n {taSortProcedureName} 'Sort',\r\n {taQuickSortProcedureName} 'QuickSort',\r\n {taFindFunctionName} 'Find',\r\n {taCountObjectFunctionName} 'CountObject',\r\n {taCopyProcedureName} 'Copy',\r\n {taGenerateProcedureName} 'Generate',\r\n {taFillProcedureName} 'Fill',\r\n {taReverseProcedureName} 'Reverse',\r\n {taArrayInterfaceName} 'IJclUnicodeStrArray',\r\n {taArrayInterfaceGUID} '{24312E5B-B61D-485C-9E57-AC36C93D8159}',\r\n {taArrayListClassName} 'TJclUnicodeStrArrayList',\r\n {taArrayIteratorClassName} 'TJclUnicodeStrArrayIterator',\r\n {taLinkedListItemClassName} 'TJclUnicodeStrLinkedListItem',\r\n {taLinkedListClassName} 'TJclUnicodeStrLinkedList',\r\n {taLinkedListIteratorClassName} 'TJclUnicodeStrLinkedListIterator',\r\n {taVectorClassName} 'TJclUnicodeStrVector',\r\n {taVectorIteratorClassName} 'TJclUnicodeStrVectorIterator',\r\n {taSetInterfaceName} 'IJclUnicodeStrSet',\r\n {taSetInterfaceGUID} '{440E9BCB-341F-40B6-8AED-479B2E98C92A}',\r\n {taArraySetClassName} 'TJclUnicodeStrArraySet',\r\n {taHashSetBucketTypeName} 'TJclUnicodeStrHashSetBucket',\r\n {taHashSetClassName} 'TJclUnicodeStrHashSet',\r\n {taHashSetIteratorClassName} 'TJclUnicodeStrHashSetIterator',\r\n {taTreeIteratorInterfaceName} 'IJclUnicodeStrTreeIterator',\r\n {taTreeIteratorInterfaceGUID} '{0B0A60DE-0403-4EE1-B1F0-10D849924CF8}',\r\n {taTreeInterfaceName} 'IJclUnicodeStrTree',\r\n {taTreeInterfaceGUID} '{A378BC36-1FB1-4330-A335-037DD370E81B}',\r\n {taTreeNodeClassName} 'TJclUnicodeStrTreeNode',\r\n {taTreeClassName} 'TJclUnicodeStrTree',\r\n {taTreeBaseIteratorClassName} 'TJclUnicodeStrTreeIterator',\r\n {taTreePreOrderIteratorClassName} 'TJclPreOrderUnicodeStrTreeIterator',\r\n {taTreePostOrderIteratorClassName} 'TJclPostOrderUnicodeStrTreeIterator',\r\n {taQueueInterfaceName} 'IJclUnicodeStrQueue',\r\n {taQueueInterfaceGUID} '{94A09E52-424A-486E-846B-9C2C52DC3A8F}',\r\n {taQueueClassName} 'TJclUnicodeStrQueue',\r\n {taSortedSetInterfaceName} 'IJclUnicodeStrSortedSet',\r\n {taSortedSetInterfaceGUID} '{172BCD6F-D23C-4014-9C8C-A77A27D6E881}',\r\n {taStackInterfaceName} 'IJclUnicodeStrStack',\r\n {taStackInterfaceGUID} '{BC046C3D-E3D2-42BA-A96D-054834A70404}',\r\n {taStackClassName} 'TJclUnicodeStrStack'\r\n );\r\n\r\n StringKnownType: TKnownTypeAttributes =\r\n ({taTypeName} 'string',\r\n {taCondition} '',\r\n {taDefines} 'REFCOUNTED',\r\n {taUndefs} 'ZEROINIT;GENERIC',\r\n {taAlias} '',\r\n {taAliasCondition} '',\r\n {taDefaultValue} '''''',\r\n {taConstKeyword} 'const ',\r\n {taOwnershipParameterName} '',\r\n {taOwnershipInterfaceName} 'IJclStrOwner',\r\n {taOwnershipInterfaceGUID} '',\r\n {taReleaserFunctionName} '',\r\n {taReleaseEventName} '',\r\n {taReleaseEventTypeName} 'TFreeStrEvent',\r\n {taGetterFunctionName} 'GetString',\r\n {taSetterProcedureName} 'SetString',\r\n {taParameterName} 'AString',\r\n {taDynArrayTypeName} 'TDynStringArray',\r\n {taMoveArrayProcedureName} 'MoveArray',\r\n {taArrayPropertyName} 'Strings',\r\n {taBaseContainerClassName} '',\r\n {taBaseCollectionClassName} '',\r\n {taIterateProcedureTypeName} 'TStrIterateProcedure',\r\n {taIterateProcedureName} 'Iterate',\r\n {taApplyFunctionTypeName} 'TStrApplyFunction',\r\n {taApplyProcedureName} 'Apply',\r\n {taCompareFunctionTypeName} 'TStrCompare',\r\n {taSimpleCompareFunctionName} 'StrSimpleCompare',\r\n {taEqualityCompareFunctionTypeName} 'TStrEqualityCompare',\r\n {taSimpleEqualityCompareFunctionName} 'StrSimpleEqualityCompare',\r\n {taHashConvertFunctionTypeName} 'TStrHashConvert',\r\n {taSimpleHashConvertFunctionName} 'StrSimpleHashConvert',\r\n {taContainerInterfaceName} '',\r\n {taContainerInterfaceGUID} '',\r\n {taFlatContainerInterfaceName} '',\r\n {taFlatContainerInterfaceGUID} '',\r\n {taEqualityComparerInterfaceName} 'IJclStrEqualityComparer',\r\n {taEqualityComparerInterfaceGUID} '',\r\n {taComparerInterfaceName} 'IJclStrComparer',\r\n {taComparerInterfaceGUID} '',\r\n {taHashConverterInterfaceName} 'IJclStrHashConverter',\r\n {taHashConverterInterfaceGUID} '',\r\n {taIteratorInterfaceName} 'IJclStrIterator',\r\n {taIteratorInterfaceGUID} '',\r\n {taBinaryTreeIteratorInterfaceName} 'IJclStrBinaryTreeIterator',\r\n {taBinaryTreeIteratorInterfaceGUID} '',\r\n {taBinaryTreeNodeTypeName} 'TJclStrBinaryNode',\r\n {taBinaryTreeClassName} 'TJclStrBinaryTree',\r\n {taBinaryTreeBaseIteratorClassName} 'TJclStrBinaryTreeIterator',\r\n {taBinaryTreePreOrderIteratorClassName} 'TJclPreOrderStrBinaryTreeIterator',\r\n {taBinaryTreeInOrderIteratorClassName} 'TJclInOrderStrBinaryTreeIterator',\r\n {taBinaryTreePostOrderIteratorClassName} 'TJclPostOrderStrBinaryTreeIterator',\r\n {taCollectionInterfaceName} 'IJclStrCollection',\r\n {taCollectionInterfaceGUID} '',\r\n {taListInterfaceName} 'IJclStrList',\r\n {taListInterfaceGUID} '',\r\n {taSortProcedureTypeName} 'TStrSortProc',\r\n {taSortProcedureName} 'Sort',\r\n {taQuickSortProcedureName} 'QuickSort',\r\n {taFindFunctionName} 'Find',\r\n {taCountObjectFunctionName} 'CountObject',\r\n {taCopyProcedureName} 'Copy',\r\n {taGenerateProcedureName} 'Generate',\r\n {taFillProcedureName} 'Fill',\r\n {taReverseProcedureName} 'Reverse',\r\n {taArrayInterfaceName} 'IJclStrArray',\r\n {taArrayInterfaceGUID} '',\r\n {taArrayListClassName} 'TJclStrArrayList',\r\n {taArrayIteratorClassName} 'TJclStrArrayIterator',\r\n {taLinkedListItemClassName} 'TJclStrLinkedListItem',\r\n {taLinkedListClassName} 'TJclStrLinkedList',\r\n {taLinkedListIteratorClassName} 'TJclStrLinkedListIterator',\r\n {taVectorClassName} 'TJclStrVector',\r\n {taVectorIteratorClassName} 'TJclStrVectorIterator',\r\n {taSetInterfaceName} 'IJclStrSet',\r\n {taSetInterfaceGUID} '',\r\n {taArraySetClassName} 'TJclStrArraySet',\r\n {taHashSetBucketTypeName} 'TJclStrHashSetBucket',\r\n {taHashSetClassName} 'TJclStrHashSet',\r\n {taHashSetIteratorClassName} 'TJclStrHashSetIterator',\r\n {taTreeIteratorInterfaceName} 'IJclStrTreeIterator',\r\n {taTreeIteratorInterfaceGUID} '',\r\n {taTreeInterfaceName} 'IJclStrTree',\r\n {taTreeInterfaceGUID} '',\r\n {taTreeNodeClassName} 'TJclStrTreeNode',\r\n {taTreeClassName} 'TJclStrTree',\r\n {taTreeBaseIteratorClassName} 'TJclStrTreeIterator',\r\n {taTreePreOrderIteratorClassName} 'TJclPreOrderStrTreeIterator',\r\n {taTreePostOrderIteratorClassName} 'TJclPostOrderStrTreeIterator',\r\n {taQueueInterfaceName} 'IJclStrQueue',\r\n {taQueueInterfaceGUID} '',\r\n {taQueueClassName} 'TJclStrQueue',\r\n {taSortedSetInterfaceName} 'IJclStrSortedSet',\r\n {taSortedSetInterfaceGUID} '',\r\n {taStackInterfaceName} 'IJclStrStack',\r\n {taStackInterfaceGUID} '',\r\n {taStackClassName} 'TJclStrStack'\r\n );\r\n\r\n SingleKnownType: TKnownTypeAttributes =\r\n ({taTypeName} 'Single',\r\n {taCondition} '',\r\n {taDefines} 'ZEROINIT',\r\n {taUndefs} 'GENERIC;REFCOUNTED',\r\n {taAlias} 'Float',\r\n {taAliasCondition} 'MATH_SINGLE_PRECISION',\r\n {taDefaultValue} '0.0',\r\n {taConstKeyword} 'const ',\r\n {taOwnershipParameterName} '',\r\n {taOwnershipInterfaceName} 'IJclSingleOwner',\r\n {taOwnershipInterfaceGUID} '{B002C201-70D7-4FA8-B44A-6D18E82580E5}',\r\n {taReleaserFunctionName} 'FreeSingle',\r\n {taReleaseEventName} 'OnFreeSingle',\r\n {taReleaseEventTypeName} 'TFreeSingleEvent',\r\n {taGetterFunctionName} 'GetValue',\r\n {taSetterProcedureName} 'SetValue',\r\n {taParameterName} 'AValue',\r\n {taDynArrayTypeName} 'TDynSingleArray',\r\n {taMoveArrayProcedureName} 'MoveArray',\r\n {taArrayPropertyName} 'Values',\r\n {taBaseContainerClassName} 'TJclSingleAbstractContainer',\r\n {taBaseCollectionClassName} '',\r\n {taIterateProcedureTypeName} 'TSingleIterateProcedure',\r\n {taIterateProcedureName} 'Iterate',\r\n {taApplyFunctionTypeName} 'TSingleApplyFunction',\r\n {taApplyProcedureName} 'Apply',\r\n {taCompareFunctionTypeName} 'TSingleCompare',\r\n {taSimpleCompareFunctionName} 'SingleSimpleCompare',\r\n {taEqualityCompareFunctionTypeName} 'TSingleEqualityCompare',\r\n {taSimpleEqualityCompareFunctionName} 'SingleSimpleEqualityCompare',\r\n {taHashConvertFunctionTypeName} 'TSingleHashConvert',\r\n {taSimpleHashConvertFunctionName} 'SingleSimpleHashConvert',\r\n {taContainerInterfaceName} 'IJclSingleContainer',\r\n {taContainerInterfaceGUID} '{22BE88BD-87D1-4B4D-9FAB-F1B6D555C6A9}',\r\n {taFlatContainerInterfaceName} 'IJclSingleFlatContainer',\r\n {taFlatContainerInterfaceGUID} '{F16955E8-94D2-4201-809B-CC2EA39B5FDD}',\r\n {taEqualityComparerInterfaceName} 'IJclSingleEqualityComparer',\r\n {taEqualityComparerInterfaceGUID} '{4835BC5B-1A87-4864-BFE1-778F3BAF26B1}',\r\n {taComparerInterfaceName} 'IJclSingleComparer',\r\n {taComparerInterfaceGUID} '{008225CE-075E-4450-B9DE-9863CB6D347C}',\r\n {taHashConverterInterfaceName} 'IJclSingleHashConverter',\r\n {taHashConverterInterfaceGUID} '{20F0E481-F1D2-48B6-A95D-FBB56AF119F5}',\r\n {taIteratorInterfaceName} 'IJclSingleIterator',\r\n {taIteratorInterfaceGUID} '{FD1124F8-CB2B-4AD7-B12D-C05702F4204B}',\r\n {taBinaryTreeIteratorInterfaceName} 'IJclSingleBinaryTreeIterator',\r\n {taBinaryTreeIteratorInterfaceGUID} '{BC6FFB13-FA1C-4077-8273-F25A3119168B}',\r\n {taBinaryTreeNodeTypeName} 'TJclSingleBinaryNode',\r\n {taBinaryTreeClassName} 'TJclSingleBinaryTree',\r\n {taBinaryTreeBaseIteratorClassName} 'TJclSingleBinaryTreeIterator',\r\n {taBinaryTreePreOrderIteratorClassName} 'TJclPreOrderSingleBinaryTreeIterator',\r\n {taBinaryTreeInOrderIteratorClassName} 'TJclInOrderSingleBinaryTreeIterator',\r\n {taBinaryTreePostOrderIteratorClassName} 'TJclPostOrderSingleBinaryTreeIterator',\r\n {taCollectionInterfaceName} 'IJclSingleCollection',\r\n {taCollectionInterfaceGUID} '{1D34D474-6588-441E-B2B3-8C021A37ED89}',\r\n {taListInterfaceName} 'IJclSingleList',\r\n {taListInterfaceGUID} '{D081324C-70A4-4AAC-BA42-7557F0262826}',\r\n {taSortProcedureTypeName} 'TSingleSortProc',\r\n {taSortProcedureName} 'Sort',\r\n {taQuickSortProcedureName} 'QuickSort',\r\n {taFindFunctionName} 'Find',\r\n {taCountObjectFunctionName} 'CountObject',\r\n {taCopyProcedureName} 'Copy',\r\n {taGenerateProcedureName} 'Generate',\r\n {taFillProcedureName} 'Fill',\r\n {taReverseProcedureName} 'Reverse',\r\n {taArrayInterfaceName} 'IJclSingleArray',\r\n {taArrayInterfaceGUID} '{B96E2A4D-D750-4B65-B975-C619A05A29F6}',\r\n {taArrayListClassName} 'TJclSingleArrayList',\r\n {taArrayIteratorClassName} 'TJclSingleArrayIterator',\r\n {taLinkedListItemClassName} 'TJclSingleLinkedListItem',\r\n {taLinkedListClassName} 'TJclSingleLinkedList',\r\n {taLinkedListIteratorClassName} 'TJclSingleLinkedListIterator',\r\n {taVectorClassName} 'TJclSingleVector',\r\n {taVectorIteratorClassName} 'TJclSingleVectorIterator',\r\n {taSetInterfaceName} 'IJclSingleSet',\r\n {taSetInterfaceGUID} '{36E34A78-6A29-4503-97D5-4BF53538CEC0}',\r\n {taArraySetClassName} 'TJclSingleArraySet',\r\n {taHashSetBucketTypeName} 'TJclSingleHashSetBucket',\r\n {taHashSetClassName} 'TJclSingleHashSet',\r\n {taHashSetIteratorClassName} 'TJclSingleHashSetIterator',\r\n {taTreeIteratorInterfaceName} 'IJclSingleTreeIterator',\r\n {taTreeIteratorInterfaceGUID} '{17BFDE9D-DBF7-4DC8-AC74-919C717B4726}',\r\n {taTreeInterfaceName} 'IJclSingleTree',\r\n {taTreeInterfaceGUID} '{A90A51BC-EBD7-40D3-B0A0-C9987E7A83D0}',\r\n {taTreeNodeClassName} 'TJclSingleTreeNode',\r\n {taTreeClassName} 'TJclSingleTree',\r\n {taTreeBaseIteratorClassName} 'TJclSingleTreeIterator',\r\n {taTreePreOrderIteratorClassName} 'TJclPreOrderSingleTreeIterator',\r\n {taTreePostOrderIteratorClassName} 'TJclPostOrderSingleTreeIterator',\r\n {taQueueInterfaceName} 'IJclSingleQueue',\r\n {taQueueInterfaceGUID} '{67D74314-9967-4C99-8A48-6E0ADD73EC29}',\r\n {taQueueClassName} 'TJclSingleQueue',\r\n {taSortedSetInterfaceName} 'IJclSingleSortedSet',\r\n {taSortedSetInterfaceGUID} '{65EDA801-9E04-4119-BF9E-D7DD4AF82144}',\r\n {taStackInterfaceName} 'IJclSingleStack',\r\n {taStackInterfaceGUID} '{8DCE45C8-B5B3-43AB-BA08-DAD531CEB9CF}',\r\n {taStackClassName} 'TJclSingleStack'\r\n );\r\n\r\n DoubleKnownType: TKnownTypeAttributes =\r\n ({taTypeName} 'Double',\r\n {taCondition} '',\r\n {taDefines} 'ZEROINIT',\r\n {taUndefs} 'GENERIC;REFCOUNTED',\r\n {taAlias} 'Float',\r\n {taAliasCondition} 'MATH_DOUBLE_PRECISION',\r\n {taDefaultValue} '0.0',\r\n {taConstKeyword} 'const ',\r\n {taOwnershipParameterName} '',\r\n {taOwnershipInterfaceName} 'IJclDoubleOwner',\r\n {taOwnershipInterfaceGUID} '{3BEFEDB0-C904-4400-ABEF-40FC928BB258}',\r\n {taReleaserFunctionName} 'FreeDouble',\r\n {taReleaseEventName} 'OnFreeDouble',\r\n {taReleaseEventTypeName} 'TFreeDoubleEvent',\r\n {taGetterFunctionName} 'GetValue',\r\n {taSetterProcedureName} 'SetValue',\r\n {taParameterName} 'AValue',\r\n {taDynArrayTypeName} 'TDynDoubleArray',\r\n {taMoveArrayProcedureName} 'MoveArray',\r\n {taArrayPropertyName} 'Values',\r\n {taBaseContainerClassName} 'TJclDoubleAbstractContainer',\r\n {taBaseCollectionClassName} '',\r\n {taIterateProcedureTypeName} 'TDoubleIterateProcedure',\r\n {taIterateProcedureName} 'Iterate',\r\n {taApplyFunctionTypeName} 'TDoubleApplyFunction',\r\n {taApplyProcedureName} 'Apply',\r\n {taCompareFunctionTypeName} 'TDoubleCompare',\r\n {taSimpleCompareFunctionName} 'DoubleSimpleCompare',\r\n {taEqualityCompareFunctionTypeName} 'TDoubleEqualityCompare',\r\n {taSimpleEqualityCompareFunctionName} 'DoubleSimpleEqualityCompare',\r\n {taHashConvertFunctionTypeName} 'TDoubleHashConvert',\r\n {taSimpleHashConvertFunctionName} 'DoubleSimpleHashConvert',\r\n {taContainerInterfaceName} 'IJclDoubleContainer',\r\n {taContainerInterfaceGUID} '{372B9354-DF6D-4CAA-A5A9-C50E1FEE5525}',\r\n {taFlatContainerInterfaceName} 'IJclDoubleFlatContainer',\r\n {taFlatContainerInterfaceGUID} '{2F0252CE-7471-45CA-8C8D-FD3925507C00}',\r\n {taEqualityComparerInterfaceName} 'IJclDoubleEqualityComparer',\r\n {taEqualityComparerInterfaceGUID} '{15F0A9F0-D5DC-4978-8CDB-53B6E510262C}',\r\n {taComparerInterfaceName} 'IJclDoubleComparer',\r\n {taComparerInterfaceGUID} '{BC245D7F-7EB9-43D0-81B4-EE215486A5AA}',\r\n {taHashConverterInterfaceName} 'IJclDoubleHashConverter',\r\n {taHashConverterInterfaceGUID} '{193A2881-535B-4AF4-B0C3-6845A2800F80}',\r\n {taIteratorInterfaceName} 'IJclDoubleIterator',\r\n {taIteratorInterfaceGUID} '{004C154A-281C-4DA7-BF64-F3EE80ACF640}',\r\n {taBinaryTreeIteratorInterfaceName} 'IJclDoubleBinaryTreeIterator',\r\n {taBinaryTreeIteratorInterfaceGUID} '{CE48083C-D60C-4315-BC14-8CE77AC3269E}',\r\n {taBinaryTreeNodeTypeName} 'TJclDoubleBinaryNode',\r\n {taBinaryTreeClassName} 'TJclDoubleBinaryTree',\r\n {taBinaryTreeBaseIteratorClassName} 'TJclDoubleBinaryTreeIterator',\r\n {taBinaryTreePreOrderIteratorClassName} 'TJclPreOrderDoubleBinaryTreeIterator',\r\n {taBinaryTreeInOrderIteratorClassName} 'TJclInOrderDoubleBinaryTreeIterator',\r\n {taBinaryTreePostOrderIteratorClassName} 'TJclPostOrderDoubleBinaryTreeIterator',\r\n {taCollectionInterfaceName} 'IJclDoubleCollection',\r\n {taCollectionInterfaceGUID} '{E54C7717-C33A-4F1B-860C-4F60F303EAD3}',\r\n {taListInterfaceName} 'IJclDoubleList',\r\n {taListInterfaceGUID} '{ECA58515-3903-4312-9486-3214E03F35AB}',\r\n {taSortProcedureTypeName} 'TDoubleSortProc',\r\n {taSortProcedureName} 'Sort',\r\n {taQuickSortProcedureName} 'QuickSort',\r\n {taFindFunctionName} 'Find',\r\n {taCountObjectFunctionName} 'CountObject',\r\n {taCopyProcedureName} 'Copy',\r\n {taGenerateProcedureName} 'Generate',\r\n {taFillProcedureName} 'Fill',\r\n {taReverseProcedureName} 'Reverse',\r\n {taArrayInterfaceName} 'IJclDoubleArray',\r\n {taArrayInterfaceGUID} '{67E66324-9757-4E85-8ECD-53396910FB39}',\r\n {taArrayListClassName} 'TJclDoubleArrayList',\r\n {taArrayIteratorClassName} 'TJclDoubleArrayIterator',\r\n {taLinkedListItemClassName} 'TJclDoubleLinkedListItem',\r\n {taLinkedListClassName} 'TJclDoubleLinkedList',\r\n {taLinkedListIteratorClassName} 'TJclDoubleLinkedListIterator',\r\n {taVectorClassName} 'TJclDoubleVector',\r\n {taVectorIteratorClassName} 'TJclDoubleVectorIterator',\r\n {taSetInterfaceName} 'IJclDoubleSet',\r\n {taSetInterfaceGUID} '{4E1E4847-E934-4811-A26C-5FC8E772A623}',\r\n {taArraySetClassName} 'TJclDoubleArraySet',\r\n {taHashSetBucketTypeName} 'TJclDoubleHashSetBucket',\r\n {taHashSetClassName} 'TJclDoubleHashSet',\r\n {taHashSetIteratorClassName} 'TJclDoubleHashSetIterator',\r\n {taTreeIteratorInterfaceName} 'IJclDoubleTreeIterator',\r\n {taTreeIteratorInterfaceGUID} '{EB39B84E-D3C5-496E-A521-B8BF24579252}',\r\n {taTreeInterfaceName} 'IJclDoubleTree',\r\n {taTreeInterfaceGUID} '{69DA85B1-A0DD-407B-B5CF-5EB7C6D4B82D}',\r\n {taTreeNodeClassName} 'TJclDoubleTreeNode',\r\n {taTreeClassName} 'TJclDoubleTree',\r\n {taTreeBaseIteratorClassName} 'TJclDoubleTreeIterator',\r\n {taTreePreOrderIteratorClassName} 'TJclPreOrderDoubleTreeIterator',\r\n {taTreePostOrderIteratorClassName} 'TJclPostOrderDoubleTreeIterator',\r\n {taQueueInterfaceName} 'IJclDoubleQueue',\r\n {taQueueInterfaceGUID} '{FA1B6D25-3456-4963-87DC-5A2E53B2963F}',\r\n {taQueueClassName} 'TJclDoubleQueue',\r\n {taSortedSetInterfaceName} 'IJclDoubleSortedSet',\r\n {taSortedSetInterfaceGUID} '{DA0E689F-BAFE-4BCE-85E4-C38E780BC84C}',\r\n {taStackInterfaceName} 'IJclDoubleStack',\r\n {taStackInterfaceGUID} '{46DF2701-16F0-453C-B938-F04E9C1CEBF8}',\r\n {taStackClassName} 'TJclDoubleStack'\r\n );\r\n\r\n ExtendedKnownType: TKnownTypeAttributes =\r\n ({taTypeName} 'Extended',\r\n {taCondition} '',\r\n {taDefines} 'ZEROINIT',\r\n {taUndefs} 'GENERIC;REFCOUNTED',\r\n {taAlias} 'Float',\r\n {taAliasCondition} 'MATH_EXTENDED_PRECISION',\r\n {taDefaultValue} '0.0',\r\n {taConstKeyword} 'const ',\r\n {taOwnershipParameterName} '',\r\n {taOwnershipInterfaceName} 'IJclExtendedOwner',\r\n {taOwnershipInterfaceGUID} '{4501B203-6784-479D-8A8E-FBE3E1249CCF}',\r\n {taReleaserFunctionName} 'FreeExtended',\r\n {taReleaseEventName} 'OnFreeExtended',\r\n {taReleaseEventTypeName} 'TFreeExtendedEvent',\r\n {taGetterFunctionName} 'GetValue',\r\n {taSetterProcedureName} 'SetValue',\r\n {taParameterName} 'AValue',\r\n {taDynArrayTypeName} 'TDynExtendedArray',\r\n {taMoveArrayProcedureName} 'MoveArray',\r\n {taArrayPropertyName} 'Values',\r\n {taBaseContainerClassName} 'TJclExtendedAbstractContainer',\r\n {taBaseCollectionClassName} '',\r\n {taIterateProcedureTypeName} 'TExtendedIterateProcedure',\r\n {taIterateProcedureName} 'Iterate',\r\n {taApplyFunctionTypeName} 'TExtendedApplyFunction',\r\n {taApplyProcedureName} 'Apply',\r\n {taCompareFunctionTypeName} 'TExtendedCompare',\r\n {taSimpleCompareFunctionName} 'ExtendedSimpleCompare',\r\n {taEqualityCompareFunctionTypeName} 'TExtendedEqualityCompare',\r\n {taSimpleEqualityCompareFunctionName} 'ExtendedSimpleEqualityCompare',\r\n {taHashConvertFunctionTypeName} 'TExtendedHashConvert',\r\n {taSimpleHashConvertFunctionName} 'ExtendedSimpleHashConvert',\r\n {taContainerInterfaceName} 'IJclExtendedContainer',\r\n {taContainerInterfaceGUID} '{431A6482-FD5C-45A7-BE53-339A3CF75AC9}',\r\n {taFlatContainerInterfaceName} 'IJclExtendedFlatContainer',\r\n {taFlatContainerInterfaceGUID} '{1D3F48A2-001E-48F7-8A54-B9F4CE837523}',\r\n {taEqualityComparerInterfaceName} 'IJclExtendedEqualityComparer',\r\n {taEqualityComparerInterfaceGUID} '{149883D5-4138-4570-8C5C-99F186B7E646}',\r\n {taComparerInterfaceName} 'IJclExtendedComparer',\r\n {taComparerInterfaceGUID} '{92657C66-C18D-4BF8-A538-A3B0140320BB}',\r\n {taHashConverterInterfaceName} 'IJclExtendedHashConverter',\r\n {taHashConverterInterfaceGUID} '{77CECDB9-2774-4FDC-8E5A-A80325626434}',\r\n {taIteratorInterfaceName} 'IJclExtendedIterator',\r\n {taIteratorInterfaceGUID} '{B89877A5-DED4-4CD9-AB90-C7D062111DE0}',\r\n {taBinaryTreeIteratorInterfaceName} 'IJclExtendedBinaryTreeIterator',\r\n {taBinaryTreeIteratorInterfaceGUID} '{8A9FAE2A-5EF5-4165-8E8D-51F2102A4580}',\r\n {taBinaryTreeNodeTypeName} 'TJclExtendedBinaryNode',\r\n {taBinaryTreeClassName} 'TJclExtendedBinaryTree',\r\n {taBinaryTreeBaseIteratorClassName} 'TJclExtendedBinaryTreeIterator',\r\n {taBinaryTreePreOrderIteratorClassName} 'TJclPreOrderExtendedBinaryTreeIterator',\r\n {taBinaryTreeInOrderIteratorClassName} 'TJclInOrderExtendedBinaryTreeIterator',\r\n {taBinaryTreePostOrderIteratorClassName} 'TJclPostOrderExtendedBinaryTreeIterator',\r\n {taCollectionInterfaceName} 'IJclExtendedCollection',\r\n {taCollectionInterfaceGUID} '{2A1341CB-B997-4E3B-B1CA-6D60AE853C55}',\r\n {taListInterfaceName} 'IJclExtendedList',\r\n {taListInterfaceGUID} '{7463F954-F8DF-4B02-A284-FCB98746248E}',\r\n {taSortProcedureTypeName} 'TExtendedSortProc',\r\n {taSortProcedureName} 'Sort',\r\n {taQuickSortProcedureName} 'QuickSort',\r\n {taFindFunctionName} 'Find',\r\n {taCountObjectFunctionName} 'CountObject',\r\n {taCopyProcedureName} 'Copy',\r\n {taGenerateProcedureName} 'Generate',\r\n {taFillProcedureName} 'Fill',\r\n {taReverseProcedureName} 'Reverse',\r\n {taArrayInterfaceName} 'IJclExtendedArray',\r\n {taArrayInterfaceGUID} '{D43E8D18-26B3-41A2-8D52-ED7EA2FE1AB7}',\r\n {taArrayListClassName} 'TJclExtendedArrayList',\r\n {taArrayIteratorClassName} 'TJclExtendedArrayIterator',\r\n {taLinkedListItemClassName} 'TJclExtendedLinkedListItem',\r\n {taLinkedListClassName} 'TJclExtendedLinkedList',\r\n {taLinkedListIteratorClassName} 'TJclExtendedLinkedListIterator',\r\n {taVectorClassName} 'TJclExtendedVector',\r\n {taVectorIteratorClassName} 'TJclExtendedVectorIterator',\r\n {taSetInterfaceName} 'IJclExtendedSet',\r\n {taSetInterfaceGUID} '{3B9CF52D-1C49-4388-A7B3-9BEE1821FFD4}',\r\n {taArraySetClassName} 'TJclExtendedArraySet',\r\n {taHashSetBucketTypeName} 'TJclExtendedHashSetBucket',\r\n {taHashSetClassName} 'TJclExtendedHashSet',\r\n {taHashSetIteratorClassName} 'TJclExtendedHashSetIterator',\r\n {taTreeIteratorInterfaceName} 'IJclExtendedTreeIterator',\r\n {taTreeIteratorInterfaceGUID} '{1B40A544-FC5D-454C-8E42-CE17B015E65C}',\r\n {taTreeInterfaceName} 'IJclExtendedTree',\r\n {taTreeInterfaceGUID} '{9ACCCAFD-B617-43DC-AAF9-916BE324A17E}',\r\n {taTreeNodeClassName} 'TJclExtendedTreeNode',\r\n {taTreeClassName} 'TJclExtendedTree',\r\n {taTreeBaseIteratorClassName} 'TJclExtendedTreeIterator',\r\n {taTreePreOrderIteratorClassName} 'TJclPreOrderExtendedTreeIterator',\r\n {taTreePostOrderIteratorClassName} 'TJclPostOrderExtendedTreeIterator',\r\n {taQueueInterfaceName} 'IJclExtendedQueue',\r\n {taQueueInterfaceGUID} '{76F349C0-7681-4BE8-9E94-280C962780D8}',\r\n {taQueueClassName} 'TJclExtendedQueue',\r\n {taSortedSetInterfaceName} 'IJclExtendedSortedSet',\r\n {taSortedSetInterfaceGUID} '{A9875ED3-81A4-43A3-86BB-3429F51B278B}',\r\n {taStackInterfaceName} 'IJclExtendedStack',\r\n {taStackInterfaceGUID} '{A2A30585-F561-4757-ABE1-CA511AE72CC5}',\r\n {taStackClassName} 'TJclExtendedStack'\r\n );\r\n\r\n FloatKnownType: TKnownTypeAttributes =\r\n ({taTypeName} 'Float',\r\n {taCondition} '',\r\n {taDefines} 'ZEROINIT',\r\n {taUndefs} 'GENERIC;REFCOUNTED',\r\n {taAlias} '',\r\n {taAliasCondition} '',\r\n {taDefaultValue} '0.0',\r\n {taConstKeyword} 'const ',\r\n {taOwnershipParameterName} '',\r\n {taOwnershipInterfaceName} 'IJclFloatOwner',\r\n {taOwnershipInterfaceGUID} '',\r\n {taReleaserFunctionName} '',\r\n {taReleaseEventName} '',\r\n {taReleaseEventTypeName} 'TFreeFloatEvent',\r\n {taGetterFunctionName} 'GetValue',\r\n {taSetterProcedureName} 'SetValue',\r\n {taParameterName} 'AValue',\r\n {taDynArrayTypeName} 'TDynFloatArray',\r\n {taMoveArrayProcedureName} 'MoveArray',\r\n {taArrayPropertyName} 'Values',\r\n {taBaseContainerClassName} '',\r\n {taBaseCollectionClassName} '',\r\n {taIterateProcedureTypeName} 'TFloatIterateProcedure',\r\n {taIterateProcedureName} 'Iterate',\r\n {taApplyFunctionTypeName} 'TFloatApplyFunction',\r\n {taApplyProcedureName} 'Apply',\r\n {taCompareFunctionTypeName} 'TFloatCompare',\r\n {taSimpleCompareFunctionName} 'FloatSimpleCompare',\r\n {taEqualityCompareFunctionTypeName} 'TFloatEqualityCompare',\r\n {taSimpleEqualityCompareFunctionName} 'FloatSimpleEqualityCompare',\r\n {taHashConvertFunctionTypeName} 'TFloatHashConvert',\r\n {taSimpleHashConvertFunctionName} 'FloatSimpleHashConvert',\r\n {taContainerInterfaceName} 'IJclFloatContainer',\r\n {taContainerInterfaceGUID} '',\r\n {taFlatContainerInterfaceName} 'IJclFloatFlatContainer',\r\n {taFlatContainerInterfaceGUID} '',\r\n {taEqualityComparerInterfaceName} 'IJclFloatEqualityComparer',\r\n {taEqualityComparerInterfaceGUID} '',\r\n {taComparerInterfaceName} 'IJclFloatComparer',\r\n {taComparerInterfaceGUID} '',\r\n {taHashConverterInterfaceName} 'IJclFloatHashConverter',\r\n {taHashConverterInterfaceGUID} '',\r\n {taIteratorInterfaceName} 'IJclFloatIterator',\r\n {taIteratorInterfaceGUID} '',\r\n {taBinaryTreeIteratorInterfaceName} 'IJclFloatBinaryTreeIterator',\r\n {taBinaryTreeIteratorInterfaceGUID} '',\r\n {taBinaryTreeNodeTypeName} 'TJclFloatBinaryNode',\r\n {taBinaryTreeClassName} 'TJclFloatBinaryTree',\r\n {taBinaryTreeBaseIteratorClassName} 'TJclFloatBinaryTreeIterator',\r\n {taBinaryTreePreOrderIteratorClassName} 'TJclPreOrderFloatBinaryTreeIterator',\r\n {taBinaryTreeInOrderIteratorClassName} 'TJclInOrderFloatBinaryTreeIterator',\r\n {taBinaryTreePostOrderIteratorClassName} 'TJclPostOrderFloatBinaryTreeIterator',\r\n {taCollectionInterfaceName} 'IJclFloatCollection',\r\n {taCollectionInterfaceGUID} '',\r\n {taListInterfaceName} 'IJclFloatList',\r\n {taListInterfaceGUID} '',\r\n {taSortProcedureTypeName} 'TFloatSortProc',\r\n {taSortProcedureName} 'Sort',\r\n {taQuickSortProcedureName} 'QuickSort',\r\n {taFindFunctionName} 'Find',\r\n {taCountObjectFunctionName} 'CountObject',\r\n {taCopyProcedureName} 'Copy',\r\n {taGenerateProcedureName} 'Generate',\r\n {taFillProcedureName} 'Fill',\r\n {taReverseProcedureName} 'Reverse',\r\n {taArrayInterfaceName} 'IJclFloatArray',\r\n {taArrayInterfaceGUID} '',\r\n {taArrayListClassName} 'TJclFloatArrayList',\r\n {taArrayIteratorClassName} 'TJclFloatArrayIterator',\r\n {taLinkedListItemClassName} 'TJclFloatLinkedListItem',\r\n {taLinkedListClassName} 'TJclFloatLinkedList',\r\n {taLinkedListIteratorClassName} 'TJclFloatLinkedListIterator',\r\n {taVectorClassName} 'TJclFloatVector',\r\n {taVectorIteratorClassName} 'TJclFloatVectorIterator',\r\n {taSetInterfaceName} 'IJclFloatSet',\r\n {taSetInterfaceGUID} '',\r\n {taArraySetClassName} 'TJclFloatArraySet',\r\n {taHashSetBucketTypeName} 'TJclFloatHashSetBucket',\r\n {taHashSetClassName} 'TJclFloatHashSet',\r\n {taHashSetIteratorClassName} 'TJclFloatHashSetIterator',\r\n {taTreeIteratorInterfaceName} 'IJclFloatTreeIterator',\r\n {taTreeIteratorInterfaceGUID} '',\r\n {taTreeInterfaceName} 'IJclFloatTree',\r\n {taTreeInterfaceGUID} '',\r\n {taTreeNodeClassName} 'TJclFloatTreeNode',\r\n {taTreeClassName} 'TJclFloatTree',\r\n {taTreeBaseIteratorClassName} 'TJclFloatTreeIterator',\r\n {taTreePreOrderIteratorClassName} 'TJclPreOrderFloatTreeIterator',\r\n {taTreePostOrderIteratorClassName} 'TJclPostOrderFloatTreeIterator',\r\n {taQueueInterfaceName} 'IJclFloatQueue',\r\n {taQueueInterfaceGUID} '',\r\n {taQueueClassName} 'TJclFloatQueue',\r\n {taSortedSetInterfaceName} 'IJclFloatSortedSet',\r\n {taSortedSetInterfaceGUID} '',\r\n {taStackInterfaceName} 'IJclFloatStack',\r\n {taStackInterfaceGUID} '',\r\n {taStackClassName} 'TJclFloatStack'\r\n );\r\n\r\n IntegerKnownType: TKnownTypeAttributes =\r\n ({taTypeName} 'Integer',\r\n {taCondition} '',\r\n {taDefines} 'ZEROINIT',\r\n {taUndefs} 'GENERIC;REFCOUNTED',\r\n {taAlias} '',\r\n {taAliasCondition} '',\r\n {taDefaultValue} '0',\r\n {taConstKeyword} '',\r\n {taOwnershipParameterName} '',\r\n {taOwnershipInterfaceName} 'IJclIntegerOwner',\r\n {taOwnershipInterfaceGUID} '{00E37ECB-0FF0-4833-8143-EB7FBEF9E208}',\r\n {taReleaserFunctionName} 'FreeInteger',\r\n {taReleaseEventName} 'OnFreeInteger',\r\n {taReleaseEventTypeName} 'TFreeIntegerEvent',\r\n {taGetterFunctionName} 'GetValue',\r\n {taSetterProcedureName} 'SetValue',\r\n {taParameterName} 'AValue',\r\n {taDynArrayTypeName} 'TDynIntegerArray',\r\n {taMoveArrayProcedureName} 'MoveArray',\r\n {taArrayPropertyName} 'Values',\r\n {taBaseContainerClassName} 'TJclIntegerAbstractContainer',\r\n {taBaseCollectionClassName} '',\r\n {taIterateProcedureTypeName} 'TIntegerIterateProcedure',\r\n {taIterateProcedureName} 'Iterate',\r\n {taApplyFunctionTypeName} 'TIntegerApplyFunction',\r\n {taApplyProcedureName} 'Apply',\r\n {taCompareFunctionTypeName} 'TIntegerCompare',\r\n {taSimpleCompareFunctionName} 'IntegerSimpleCompare',\r\n {taEqualityCompareFunctionTypeName} 'TIntegerEqualityCompare',\r\n {taSimpleEqualityCompareFunctionName} 'IntegerSimpleEqualityCompare',\r\n {taHashConvertFunctionTypeName} 'TIntegerHashConvert',\r\n {taSimpleHashConvertFunctionName} 'IntegerSimpleHashConvert',\r\n {taContainerInterfaceName} 'IJclIntegerContainer',\r\n {taContainerInterfaceGUID} '{3BAF5447-9835-43A4-9FF3-E5EA7D43A7D1}',\r\n {taFlatContainerInterfaceName} 'IJclIntegerFlatContainer',\r\n {taFlatContainerInterfaceGUID} '{EF4EFCD9-60CB-4525-9D20-18E55291F7CF}',\r\n {taEqualityComparerInterfaceName} 'IJclIntegerEqualityComparer',\r\n {taEqualityComparerInterfaceGUID} '{AABC35E6-A779-4A44-B748-27BFCB34FDFB}',\r\n {taComparerInterfaceName} 'IJclIntegerComparer',\r\n {taComparerInterfaceGUID} '{362C3A6A-CBC1-4D5F-8652-158913DC9865}',\r\n {taHashConverterInterfaceName} 'IJclIntegerHashConverter',\r\n {taHashConverterInterfaceGUID} '{92C540B2-C16C-47E4-995A-644BE71878B1}',\r\n {taIteratorInterfaceName} 'IJclIntegerIterator',\r\n {taIteratorInterfaceGUID} '{1406A991-4574-48A1-83FE-2EDCA03908BE}',\r\n {taBinaryTreeIteratorInterfaceName} 'IJclIntegerBinaryTreeIterator',\r\n {taBinaryTreeIteratorInterfaceGUID} '{FE2BF57D-D10D-4B0C-903D-BB61700FBA0A}',\r\n {taBinaryTreeNodeTypeName} 'TJclIntegerBinaryNode',\r\n {taBinaryTreeClassName} 'TJclIntegerBinaryTree',\r\n {taBinaryTreeBaseIteratorClassName} 'TJclIntegerBinaryTreeIterator',\r\n {taBinaryTreePreOrderIteratorClassName} 'TJclPreOrderIntegerBinaryTreeIterator',\r\n {taBinaryTreeInOrderIteratorClassName} 'TJclInOrderIntegerBinaryTreeIterator',\r\n {taBinaryTreePostOrderIteratorClassName} 'TJclPostOrderIntegerBinaryTreeIterator',\r\n {taCollectionInterfaceName} 'IJclIntegerCollection',\r\n {taCollectionInterfaceGUID} '{AF69890D-22D1-4D89-8FFD-5FAD7E0638BA}',\r\n {taListInterfaceName} 'IJclIntegerList',\r\n {taListInterfaceGUID} '{339BE91B-557D-4CE0-A854-1CBD4FE31725}',\r\n {taSortProcedureTypeName} 'TIntegerSortProc',\r\n {taSortProcedureName} 'Sort',\r\n {taQuickSortProcedureName} 'QuickSort',\r\n {taFindFunctionName} 'Find',\r\n {taCountObjectFunctionName} 'CountObject',\r\n {taCopyProcedureName} 'Copy',\r\n {taGenerateProcedureName} 'Generate',\r\n {taFillProcedureName} 'Fill',\r\n {taReverseProcedureName} 'Reverse',\r\n {taArrayInterfaceName} 'IJclIntegerArray',\r\n {taArrayInterfaceGUID} '{2B7C8B33-C0BD-4EC3-9764-63866E174781}',\r\n {taArrayListClassName} 'TJclIntegerArrayList',\r\n {taArrayIteratorClassName} 'TJclIntegerArrayIterator',\r\n {taLinkedListItemClassName} 'TJclIntegerLinkedListItem',\r\n {taLinkedListClassName} 'TJclIntegerLinkedList',\r\n {taLinkedListIteratorClassName} 'TJclIntegerLinkedListIterator',\r\n {taVectorClassName} 'TJclIntegerVector',\r\n {taVectorIteratorClassName} 'TJclIntegerVectorIterator',\r\n {taSetInterfaceName} 'IJclIntegerSet',\r\n {taSetInterfaceGUID} '{5E4D29AF-F508-465B-9008-D11FF82F25FE}',\r\n {taArraySetClassName} 'TJclIntegerArraySet',\r\n {taHashSetBucketTypeName} 'TJclIntegerHashSetBucket',\r\n {taHashSetClassName} 'TJclIntegerHashSet',\r\n {taHashSetIteratorClassName} 'TJclIntegerHashSetIterator',\r\n {taTreeIteratorInterfaceName} 'IJclIntegerTreeIterator',\r\n {taTreeIteratorInterfaceGUID} '{88EDC5C5-CA41-41AF-9838-AA19D07E69F5}',\r\n {taTreeInterfaceName} 'IJclIntegerTree',\r\n {taTreeInterfaceGUID} '{40A6F934-E5F3-4C74-AC02-227035C8C3C6}',\r\n {taTreeNodeClassName} 'TJclIntegerTreeNode',\r\n {taTreeClassName} 'TJclIntegerTree',\r\n {taTreeBaseIteratorClassName} 'TJclIntegerTreeIterator',\r\n {taTreePreOrderIteratorClassName} 'TJclPreOrderIntegerTreeIterator',\r\n {taTreePostOrderIteratorClassName} 'TJclPostOrderIntegerTreeIterator',\r\n {taQueueInterfaceName} 'IJclIntegerQueue',\r\n {taQueueInterfaceGUID} '{4C4E174E-5D19-44CE-A248-B5589A9B68DF}',\r\n {taQueueClassName} 'TJclIntegerQueue',\r\n {taSortedSetInterfaceName} 'IJclIntegerSortedSet',\r\n {taSortedSetInterfaceGUID} '{E086C54B-4FA3-426D-AC4E-FF8E8CA3D663}',\r\n {taStackInterfaceName} 'IJclIntegerStack',\r\n {taStackInterfaceGUID} '{9190BF0E-5B0C-4D6C-A107-20A933C9B56A}',\r\n {taStackClassName} 'TJclIntegerStack'\r\n );\r\n\r\n CardinalKnownType: TKnownTypeAttributes =\r\n ({taTypeName} 'Cardinal',\r\n {taCondition} '',\r\n {taDefines} 'ZEROINIT',\r\n {taUndefs} 'GENERIC;REFCOUNTED',\r\n {taAlias} '',\r\n {taAliasCondition} '',\r\n {taDefaultValue} '0',\r\n {taConstKeyword} '',\r\n {taOwnershipParameterName} '',\r\n {taOwnershipInterfaceName} 'IJclCardinalOwner',\r\n {taOwnershipInterfaceGUID} '{27B3EDEF-0ACD-4592-95F2-52A1DF5E7A39}',\r\n {taReleaserFunctionName} 'FreeCardinal',\r\n {taReleaseEventName} 'OnFreeCardinal',\r\n {taReleaseEventTypeName} 'TFreeCardinalEvent',\r\n {taGetterFunctionName} 'GetValue',\r\n {taSetterProcedureName} 'SetValue',\r\n {taParameterName} 'AValue',\r\n {taDynArrayTypeName} 'TDynCardinalArray',\r\n {taMoveArrayProcedureName} 'MoveArray',\r\n {taArrayPropertyName} 'Values',\r\n {taBaseContainerClassName} 'TJclCardinalAbstractContainer',\r\n {taBaseCollectionClassName} '',\r\n {taIterateProcedureTypeName} 'TCardinalIterateProcedure',\r\n {taIterateProcedureName} 'Iterate',\r\n {taApplyFunctionTypeName} 'TCardinalApplyFunction',\r\n {taApplyProcedureName} 'Apply',\r\n {taCompareFunctionTypeName} 'TCardinalCompare',\r\n {taSimpleCompareFunctionName} 'CardinalSimpleCompare',\r\n {taEqualityCompareFunctionTypeName} 'TCardinalEqualityCompare',\r\n {taSimpleEqualityCompareFunctionName} 'CardinalSimpleEqualityCompare',\r\n {taHashConvertFunctionTypeName} 'TCardinalHashConvert',\r\n {taSimpleHashConvertFunctionName} 'CardinalSimpleHashConvert',\r\n {taContainerInterfaceName} 'IJclCardinalContainer',\r\n {taContainerInterfaceGUID} '{01DF05CF-62E9-46B3-8BC1-2830EEF43644}',\r\n {taFlatContainerInterfaceName} 'IJclCardinalFlatContainer',\r\n {taFlatContainerInterfaceGUID} '{79E48B80-3215-47D0-A1B5-D74C495AC9D1}',\r\n {taEqualityComparerInterfaceName} 'IJclCardinalEqualityComparer',\r\n {taEqualityComparerInterfaceGUID} '{B2DECF81-6ECE-4D9F-80E1-C8C884DB407C}',\r\n {taComparerInterfaceName} 'IJclCardinalComparer',\r\n {taComparerInterfaceGUID} '{56E44725-00B9-4530-8CC2-72DCA9171EE0}',\r\n {taHashConverterInterfaceName} 'IJclCardinalHashConverter',\r\n {taHashConverterInterfaceGUID} '{2DF04C8A-16B8-4712-BC5D-AD35014EC9F7}',\r\n {taIteratorInterfaceName} 'IJclCardinalIterator',\r\n {taIteratorInterfaceGUID} '{72847A34-C8C4-4592-9447-CEB8161E33AD}',\r\n {taBinaryTreeIteratorInterfaceName} 'IJclCardinalBinaryTreeIterator',\r\n {taBinaryTreeIteratorInterfaceGUID} '{AAA358F5-95A1-480F-8E2A-09028BA6C397}',\r\n {taBinaryTreeNodeTypeName} 'TJclCardinalBinaryNode',\r\n {taBinaryTreeClassName} 'TJclCardinalBinaryTree',\r\n {taBinaryTreeBaseIteratorClassName} 'TJclCardinalBinaryTreeIterator',\r\n {taBinaryTreePreOrderIteratorClassName} 'TJclPreOrderCardinalBinaryTreeIterator',\r\n {taBinaryTreeInOrderIteratorClassName} 'TJclInOrderCardinalBinaryTreeIterator',\r\n {taBinaryTreePostOrderIteratorClassName} 'TJclPostOrderCardinalBinaryTreeIterator',\r\n {taCollectionInterfaceName} 'IJclCardinalCollection',\r\n {taCollectionInterfaceGUID} '{CFBD0344-58C8-4FA2-B4D7-D21D77DFBF80}',\r\n {taListInterfaceName} 'IJclCardinalList',\r\n {taListInterfaceGUID} '{02B09EA8-DE6F-4A18-AA57-C3533E6AC4E3}',\r\n {taSortProcedureTypeName} 'TCardinalSortProc',\r\n {taSortProcedureName} 'Sort',\r\n {taQuickSortProcedureName} 'QuickSort',\r\n {taFindFunctionName} 'Find',\r\n {taCountObjectFunctionName} 'CountObject',\r\n {taCopyProcedureName} 'Copy',\r\n {taGenerateProcedureName} 'Generate',\r\n {taFillProcedureName} 'Fill',\r\n {taReverseProcedureName} 'Reverse',\r\n {taArrayInterfaceName} 'IJclCardinalArray',\r\n {taArrayInterfaceGUID} '{C451F2F8-65C6-4C29-99A0-CC9C15356418}',\r\n {taArrayListClassName} 'TJclCardinalArrayList',\r\n {taArrayIteratorClassName} 'TJclCardinalArrayIterator',\r\n {taLinkedListItemClassName} 'TJclCardinalLinkedListItem',\r\n {taLinkedListClassName} 'TJclCardinalLinkedList',\r\n {taLinkedListIteratorClassName} 'TJclCardinalLinkedListIterator',\r\n {taVectorClassName} 'TJclCardinalVector',\r\n {taVectorIteratorClassName} 'TJclCardinalVectorIterator',\r\n {taSetInterfaceName} 'IJclCardinalSet',\r\n {taSetInterfaceGUID} '{09858637-CE8F-42E6-97E0-2786CD68387B}',\r\n {taArraySetClassName} 'TJclCardinalArraySet',\r\n {taHashSetBucketTypeName} 'TJclCardinalHashSetBucket',\r\n {taHashSetClassName} 'TJclCardinalHashSet',\r\n {taHashSetIteratorClassName} 'TJclCardinalHashSetIterator',\r\n {taTreeIteratorInterfaceName} 'IJclCardinalTreeIterator',\r\n {taTreeIteratorInterfaceGUID} '{FDBF493F-F79D-46EB-A59D-7193B6E6A860}',\r\n {taTreeInterfaceName} 'IJclCardinalTree',\r\n {taTreeInterfaceGUID} '{6C76C668-50C8-42A2-B72B-79BF102E270D}',\r\n {taTreeNodeClassName} 'TJclCardinalTreeNode',\r\n {taTreeClassName} 'TJclCardinalTree',\r\n {taTreeBaseIteratorClassName} 'TJclCardinalTreeIterator',\r\n {taTreePreOrderIteratorClassName} 'TJclPreOrderCardinalTreeIterator',\r\n {taTreePostOrderIteratorClassName} 'TJclPostOrderCardinalTreeIterator',\r\n {taQueueInterfaceName} 'IJclCardinalQueue',\r\n {taQueueInterfaceGUID} '{CC1D4358-E259-4FB0-BA83-5180A0F8A6C0}',\r\n {taQueueClassName} 'TJclCardinalQueue',\r\n {taSortedSetInterfaceName} 'IJclCardinalSortedSet',\r\n {taSortedSetInterfaceGUID} '{2D7995C6-A784-48B6-87E9-55D394A72362}',\r\n {taStackInterfaceName} 'IJclCardinalStack',\r\n {taStackInterfaceGUID} '{94F9EDB3-602B-49CE-9990-0AFDAC556F83}',\r\n {taStackClassName} 'TJclCardinalStack'\r\n );\r\n\r\n Int64KnownType: TKnownTypeAttributes =\r\n ({taTypeName} 'Int64',\r\n {taCondition} '',\r\n {taDefines} 'ZEROINIT',\r\n {taUndefs} 'GENERIC;REFCOUNTED',\r\n {taAlias} '',\r\n {taAliasCondition} '',\r\n {taDefaultValue} '0',\r\n {taConstKeyword} 'const ',\r\n {taOwnershipParameterName} '',\r\n {taOwnershipInterfaceName} 'IJclInt64Owner',\r\n {taOwnershipInterfaceGUID} '{7D4A1375-057A-42B8-8DAA-52DE30058864}',\r\n {taReleaserFunctionName} 'FreeInt64',\r\n {taReleaseEventName} 'OnFreeInt64',\r\n {taReleaseEventTypeName} 'TFreeInt64Event',\r\n {taGetterFunctionName} 'GetValue',\r\n {taSetterProcedureName} 'SetValue',\r\n {taParameterName} 'AValue',\r\n {taDynArrayTypeName} 'TDynInt64Array',\r\n {taMoveArrayProcedureName} 'MoveArray',\r\n {taArrayPropertyName} 'Values',\r\n {taBaseContainerClassName} 'TJclInt64AbstractContainer',\r\n {taBaseCollectionClassName} '',\r\n {taIterateProcedureTypeName} 'TInt64IterateProcedure',\r\n {taIterateProcedureName} 'Iterate',\r\n {taApplyFunctionTypeName} 'TInt64ApplyFunction',\r\n {taApplyProcedureName} 'Apply',\r\n {taCompareFunctionTypeName} 'TInt64Compare',\r\n {taSimpleCompareFunctionName} 'Int64SimpleCompare',\r\n {taEqualityCompareFunctionTypeName} 'TInt64EqualityCompare',\r\n {taSimpleEqualityCompareFunctionName} 'Int64SimpleEqualityCompare',\r\n {taHashConvertFunctionTypeName} 'TInt64HashConvert',\r\n {taSimpleHashConvertFunctionName} 'Int64SimpleHashConvert',\r\n {taContainerInterfaceName} 'IJclInt64Container',\r\n {taContainerInterfaceGUID} '{B560B2B6-F8C7-45F0-A5E5-920AA61C1540}',\r\n {taFlatContainerInterfaceName} 'IJclInt64FlatContainer',\r\n {taFlatContainerInterfaceGUID} '{E740B9EF-7342-4CEF-B7FB-96C5267F5738}',\r\n {taEqualityComparerInterfaceName} 'IJclInt64EqualityComparer',\r\n {taEqualityComparerInterfaceGUID} '{8B2825E2-0C81-42BA-AC0D-104344CE7E56}',\r\n {taComparerInterfaceName} 'IJclInt64Comparer',\r\n {taComparerInterfaceGUID} '{87C935BF-3A42-4F1F-A474-9C823939EE1C}',\r\n {taHashConverterInterfaceName} 'IJclInt64HashConverter',\r\n {taHashConverterInterfaceGUID} '{96CF2A71-9185-4E26-B283-457ABC3584E7}',\r\n {taIteratorInterfaceName} 'IJclInt64Iterator',\r\n {taIteratorInterfaceGUID} '{573E5A51-BF76-43D7-9F93-46305BED20A8}',\r\n {taBinaryTreeIteratorInterfaceName} 'IJclInt64BinaryTreeIterator',\r\n {taBinaryTreeIteratorInterfaceGUID} '{5605E164-5CDD-40B1-9323-DE1CB584E289}',\r\n {taBinaryTreeNodeTypeName} 'TJclInt64BinaryNode',\r\n {taBinaryTreeClassName} 'TJclInt64BinaryTree',\r\n {taBinaryTreeBaseIteratorClassName} 'TJclInt64BinaryTreeIterator',\r\n {taBinaryTreePreOrderIteratorClassName} 'TJclPreOrderInt64BinaryTreeIterator',\r\n {taBinaryTreeInOrderIteratorClassName} 'TJclInOrderInt64BinaryTreeIterator',\r\n {taBinaryTreePostOrderIteratorClassName} 'TJclPostOrderInt64BinaryTreeIterator',\r\n {taCollectionInterfaceName} 'IJclInt64Collection',\r\n {taCollectionInterfaceGUID} '{93A45BDE-3C4C-48D6-9874-5322914DFDDA}',\r\n {taListInterfaceName} 'IJclInt64List',\r\n {taListInterfaceGUID} '{E8D49200-91D3-4BD0-A59B-B93EC7E2074B}',\r\n {taSortProcedureTypeName} 'TInt64SortProc',\r\n {taSortProcedureName} 'Sort',\r\n {taQuickSortProcedureName} 'QuickSort',\r\n {taFindFunctionName} 'Find',\r\n {taCountObjectFunctionName} 'CountObject',\r\n {taCopyProcedureName} 'Copy',\r\n {taGenerateProcedureName} 'Generate',\r\n {taFillProcedureName} 'Fill',\r\n {taReverseProcedureName} 'Reverse',\r\n {taArrayInterfaceName} 'IJclInt64Array',\r\n {taArrayInterfaceGUID} '{D947C43D-2D04-442A-A707-39EDE7D96FC9}',\r\n {taArrayListClassName} 'TJclInt64ArrayList',\r\n {taArrayIteratorClassName} 'TJclInt64ArrayIterator',\r\n {taLinkedListItemClassName} 'TJclInt64LinkedListItem',\r\n {taLinkedListClassName} 'TJclInt64LinkedList',\r\n {taLinkedListIteratorClassName} 'TJclInt64LinkedListIterator',\r\n {taVectorClassName} 'TJclInt64Vector',\r\n {taVectorIteratorClassName} 'TJclInt64VectorIterator',\r\n {taSetInterfaceName} 'IJclInt64Set',\r\n {taSetInterfaceGUID} '{ACB3127A-48EE-4F9F-B988-6AE9057780E9}',\r\n {taArraySetClassName} 'TJclInt64ArraySet',\r\n {taHashSetBucketTypeName} 'TJclInt64HashSetBucket',\r\n {taHashSetClassName} 'TJclInt64HashSet',\r\n {taHashSetIteratorClassName} 'TJclInt64HashSetIterator',\r\n {taTreeIteratorInterfaceName} 'IJclInt64TreeIterator',\r\n {taTreeIteratorInterfaceGUID} '{C5A5E504-E19B-43AC-90B9-E4B8984BFA23}',\r\n {taTreeInterfaceName} 'IJclInt64Tree',\r\n {taTreeInterfaceGUID} '{1925B973-8B75-4A79-A993-DF2598FF19BE}',\r\n {taTreeNodeClassName} 'TJclInt64TreeNode',\r\n {taTreeClassName} 'TJclInt64Tree',\r\n {taTreeBaseIteratorClassName} 'TJclInt64TreeIterator',\r\n {taTreePreOrderIteratorClassName} 'TJclPreOrderInt64TreeIterator',\r\n {taTreePostOrderIteratorClassName} 'TJclPostOrderInt64TreeIterator',\r\n {taQueueInterfaceName} 'IJclInt64Queue',\r\n {taQueueInterfaceGUID} '{96B620BB-9A90-43D5-82A7-2D818A11C8E1}',\r\n {taQueueClassName} 'TJclInt64Queue',\r\n {taSortedSetInterfaceName} 'IJclInt64SortedSet',\r\n {taSortedSetInterfaceGUID} '{4C1C3FCA-6169-4A2F-B044-91AC2AA2E954}',\r\n {taStackInterfaceName} 'IJclInt64Stack',\r\n {taStackInterfaceGUID} '{D689EB8F-2746-40E9-AD1B-7E656475FC64}',\r\n {taStackClassName} 'TJclInt64Stack'\r\n );\r\n\r\n PointerKnownType: TKnownTypeAttributes =\r\n ({taTypeName} 'Pointer',\r\n {taCondition} '',\r\n {taDefines} 'ZEROINIT',\r\n {taUndefs} 'GENERIC;REFCOUNTED',\r\n {taAlias} '',\r\n {taAliasCondition} '',\r\n {taDefaultValue} 'nil',\r\n {taConstKeyword} '',\r\n {taOwnershipParameterName} '',\r\n {taOwnershipInterfaceName} 'IJclPtrOwner',\r\n {taOwnershipInterfaceGUID} '{28340328-34AD-4632-9BAC-A7387A822200}',\r\n {taReleaserFunctionName} 'FreePointer',\r\n {taReleaseEventName} 'OnFreePointer',\r\n {taReleaseEventTypeName} 'TFreePtrEvent',\r\n {taGetterFunctionName} 'GetPointer',\r\n {taSetterProcedureName} 'SetPointer',\r\n {taParameterName} 'APtr',\r\n {taDynArrayTypeName} 'TDynPointerArray',\r\n {taMoveArrayProcedureName} 'MoveArray',\r\n {taArrayPropertyName} 'Pointers',\r\n {taBaseContainerClassName} 'TJclPtrAbstractContainer',\r\n {taBaseCollectionClassName} '',\r\n {taIterateProcedureTypeName} 'TPtrIterateProcedure',\r\n {taIterateProcedureName} 'Iterate',\r\n {taApplyFunctionTypeName} 'TPtrApplyFunction',\r\n {taApplyProcedureName} 'Apply',\r\n {taCompareFunctionTypeName} 'TPtrCompare',\r\n {taSimpleCompareFunctionName} 'PtrSimpleCompare',\r\n {taEqualityCompareFunctionTypeName} 'TPtrEqualityCompare',\r\n {taSimpleEqualityCompareFunctionName} 'PtrSimpleEqualityCompare',\r\n {taHashConvertFunctionTypeName} 'TPtrHashConvert',\r\n {taSimpleHashConvertFunctionName} 'PtrSimpleHashConvert',\r\n {taContainerInterfaceName} 'IJclPtrContainer',\r\n {taContainerInterfaceGUID} '{E8DD2A85-1E12-4605-B517-7E3121C5624F}',\r\n {taFlatContainerInterfaceName} 'IJclPtrFlatContainer',\r\n {taFlatContainerInterfaceGUID} '{43C41789-DE71-4DA5-B4AC-3F53EB9459CD}',\r\n {taEqualityComparerInterfaceName} 'IJclPtrEqualityComparer',\r\n {taEqualityComparerInterfaceGUID} '{C6B7CBF9-ECD9-4D70-85CC-4E2367A1D806}',\r\n {taComparerInterfaceName} 'IJclPtrComparer',\r\n {taComparerInterfaceGUID} '{85557D4C-A036-477E-BA73-B5EEF43A8696}',\r\n {taHashConverterInterfaceName} 'IJclPtrHashConverter',\r\n {taHashConverterInterfaceGUID} '{D704CC67-CFED-44E6-9504-65D5E468FCAF}',\r\n {taIteratorInterfaceName} 'IJclPtrIterator',\r\n {taIteratorInterfaceGUID} '{62B5501C-07AA-4D00-A85B-713B39912CDF}',\r\n {taBinaryTreeIteratorInterfaceName} 'IJclPtrBinaryTreeIterator',\r\n {taBinaryTreeIteratorInterfaceGUID} '{75D3DF0D-C491-43F7-B078-E658197E8051}',\r\n {taBinaryTreeNodeTypeName} 'TJclPtrBinaryNode',\r\n {taBinaryTreeClassName} 'TJclPtrBinaryTree',\r\n {taBinaryTreeBaseIteratorClassName} 'TJclPtrBinaryTreeIterator',\r\n {taBinaryTreePreOrderIteratorClassName} 'TJclPreOrderPtrBinaryTreeIterator',\r\n {taBinaryTreeInOrderIteratorClassName} 'TJclInOrderPtrBinaryTreeIterator',\r\n {taBinaryTreePostOrderIteratorClassName} 'TJclPostOrderPtrBinaryTreeIterator',\r\n {taCollectionInterfaceName} 'IJclPtrCollection',\r\n {taCollectionInterfaceGUID} '{02E909A7-5B1D-40D4-82EA-A0CD97D5C811}',\r\n {taListInterfaceName} 'IJclPtrList',\r\n {taListInterfaceGUID} '{2CF5CF1F-C012-480C-A4CE-38BDAFB15D05}',\r\n {taSortProcedureTypeName} 'TPtrSortProc',\r\n {taSortProcedureName} 'Sort',\r\n {taQuickSortProcedureName} 'QuickSort',\r\n {taFindFunctionName} 'Find',\r\n {taCountObjectFunctionName} 'CountObject',\r\n {taCopyProcedureName} 'Copy',\r\n {taGenerateProcedureName} 'Generate',\r\n {taFillProcedureName} 'Fill',\r\n {taReverseProcedureName} 'Reverse',\r\n {taArrayInterfaceName} 'IJclPtrArray',\r\n {taArrayInterfaceGUID} '{D43E8D18-26B3-41A2-8D52-ED7EA2FE1AB7}',\r\n {taArrayListClassName} 'TJclPtrArrayList',\r\n {taArrayIteratorClassName} 'TJclPtrArrayIterator',\r\n {taLinkedListItemClassName} 'TJclPtrLinkedListItem',\r\n {taLinkedListClassName} 'TJclPtrLinkedList',\r\n {taLinkedListIteratorClassName} 'TJclPtrLinkedListIterator',\r\n {taVectorClassName} 'TJclPtrVector',\r\n {taVectorIteratorClassName} 'TJclPtrVectorIterator',\r\n {taSetInterfaceName} 'IJclPtrSet',\r\n {taSetInterfaceGUID} '{26717C68-4F83-4CCB-973A-7324FBD09632}',\r\n {taArraySetClassName} 'TJclPtrArraySet',\r\n {taHashSetBucketTypeName} 'TJclPtrHashSetBucket',\r\n {taHashSetClassName} 'TJclPtrHashSet',\r\n {taHashSetIteratorClassName} 'TJclPtrHashSetIterator',\r\n {taTreeIteratorInterfaceName} 'IJclPtrTreeIterator',\r\n {taTreeIteratorInterfaceGUID} '{ED4C08E6-60FC-4ED3-BD19-E6605B9BD943}',\r\n {taTreeInterfaceName} 'IJclPtrTree',\r\n {taTreeInterfaceGUID} '{2C1ACA3E-3F23-4E3C-984D-151CF9776E14}',\r\n {taTreeNodeClassName} 'TJclPtrTreeNode',\r\n {taTreeClassName} 'TJclPtrTree',\r\n {taTreeBaseIteratorClassName} 'TJclPtrTreeIterator',\r\n {taTreePreOrderIteratorClassName} 'TJclPreOrderPtrTreeIterator',\r\n {taTreePostOrderIteratorClassName} 'TJclPostOrderPtrTreeIterator',\r\n {taQueueInterfaceName} 'IJclPtrQueue',\r\n {taQueueInterfaceGUID} '{1052DD37-3035-4C44-A793-54AC4B9C0B29}',\r\n {taQueueClassName} 'TJclPtrQueue',\r\n {taSortedSetInterfaceName} 'IJclPtrSortedSet',\r\n {taSortedSetInterfaceGUID} '{F3A3183C-0820-425C-9446-E0838F0ADAD8}',\r\n {taStackInterfaceName} 'IJclPtrStack',\r\n {taStackInterfaceGUID} '{AD11D06C-E0E1-4EDE-AA2F-BC8BDD972B73}',\r\n {taStackClassName} 'TJclPtrStack'\r\n );\r\n\r\n TObjectKnownType: TKnownTypeAttributes =\r\n ({taTypeName} 'TObject',\r\n {taCondition} '',\r\n {taDefines} 'OWNABLE;ZEROINIT',\r\n {taUndefs} 'GENERIC;REFCOUNTED',\r\n {taAlias} '',\r\n {taAliasCondition} '',\r\n {taDefaultValue} 'nil',\r\n {taConstKeyword} '',\r\n {taOwnershipParameterName} 'AOwnsObjects',\r\n {taOwnershipInterfaceName} 'IJclObjectOwner',\r\n {taOwnershipInterfaceGUID} '{5157EA13-924E-4A56-995D-36956441025C}',\r\n {taReleaserFunctionName} 'FreeObject',\r\n {taReleaseEventName} 'OnFreeObject',\r\n {taReleaseEventTypeName} 'TFreeObjectEvent',\r\n {taGetterFunctionName} 'GetObject',\r\n {taSetterProcedureName} 'SetObject',\r\n {taParameterName} 'AObject',\r\n {taDynArrayTypeName} 'TDynObjectArray',\r\n {taMoveArrayProcedureName} 'MoveArray',\r\n {taArrayPropertyName} 'Objects',\r\n {taBaseContainerClassName} 'TJclAbstractContainer',\r\n {taBaseCollectionClassName} '',\r\n {taIterateProcedureTypeName} 'TIterateProcedure',\r\n {taIterateProcedureName} 'Iterate',\r\n {taApplyFunctionTypeName} 'TApplyFunction',\r\n {taApplyProcedureName} 'Apply',\r\n {taCompareFunctionTypeName} 'TCompare',\r\n {taSimpleCompareFunctionName} 'SimpleCompare',\r\n {taEqualityCompareFunctionTypeName} 'TEqualityCompare',\r\n {taSimpleEqualityCompareFunctionName} 'SimpleEqualityCompare',\r\n {taHashConvertFunctionTypeName} 'THashConvert',\r\n {taSimpleHashConvertFunctionName} 'SimpleHashConvert',\r\n {taContainerInterfaceName} 'IJclContainer',\r\n {taContainerInterfaceGUID} '{A9EBED03-4993-426A-8449-30D98DC2AC90}',\r\n {taFlatContainerInterfaceName} 'IJclFlatContainer',\r\n {taFlatContainerInterfaceGUID} '{0A070B6F-54A1-4B3D-A4E4-CFFAE2C7C57B}',\r\n {taEqualityComparerInterfaceName} 'IJclEqualityComparer',\r\n {taEqualityComparerInterfaceGUID} '{82C67986-8365-44AB-8D56-7B0CF4F6B918}',\r\n {taComparerInterfaceName} 'IJclComparer',\r\n {taComparerInterfaceGUID} '{7B376028-56DC-4C4A-86A9-1AC19E3EDF75}',\r\n {taHashConverterInterfaceName} 'IJclHashConverter',\r\n {taHashConverterInterfaceGUID} '{2D0DD6F4-162E-41D6-8A34-489E7EACABCD}',\r\n {taIteratorInterfaceName} 'IJclIterator',\r\n {taIteratorInterfaceGUID} '{997DF9B7-9AA2-4239-8B94-14DFFD26D790}',\r\n {taBinaryTreeIteratorInterfaceName} 'IJclBinaryTreeIterator',\r\n {taBinaryTreeIteratorInterfaceGUID} '{821DE28D-631C-4F23-A0B2-CC0F35B4C64D}',\r\n {taBinaryTreeNodeTypeName} 'TJclBinaryNode',\r\n {taBinaryTreeClassName} 'TJclBinaryTree',\r\n {taBinaryTreeBaseIteratorClassName} 'TJclBinaryTreeIterator',\r\n {taBinaryTreePreOrderIteratorClassName} 'TJclPreOrderBinaryTreeIterator',\r\n {taBinaryTreeInOrderIteratorClassName} 'TJclInOrderBinaryTreeIterator',\r\n {taBinaryTreePostOrderIteratorClassName} 'TJclPostOrderBinaryTreeIterator',\r\n {taCollectionInterfaceName} 'IJclCollection',\r\n {taCollectionInterfaceGUID} '{58947EF1-CD21-4DD1-AE3D-225C3AAD7EE5}',\r\n {taListInterfaceName} 'IJclList',\r\n {taListInterfaceGUID} '{8ABC70AC-5C06-43EA-AFE0-D066379BCC28}',\r\n {taSortProcedureTypeName} 'TSortProc',\r\n {taSortProcedureName} 'Sort',\r\n {taQuickSortProcedureName} 'QuickSort',\r\n {taFindFunctionName} 'Find',\r\n {taCountObjectFunctionName} 'CountObject',\r\n {taCopyProcedureName} 'Copy',\r\n {taGenerateProcedureName} 'Generate',\r\n {taFillProcedureName} 'Fill',\r\n {taReverseProcedureName} 'Reverse',\r\n {taArrayInterfaceName} 'IJclArray',\r\n {taArrayInterfaceGUID} '{A69F6D35-54B2-4361-852E-097ED75E648A}',\r\n {taArrayListClassName} 'TJclArrayList',\r\n {taArrayIteratorClassName} 'TJclArrayIterator',\r\n {taLinkedListItemClassName} 'TJclLinkedListItem',\r\n {taLinkedListClassName} 'TJclLinkedList',\r\n {taLinkedListIteratorClassName} 'TJclLinkedListIterator',\r\n {taVectorClassName} 'TJclVector',\r\n {taVectorIteratorClassName} 'TJclVectorIterator',\r\n {taSetInterfaceName} 'IJclSet',\r\n {taSetInterfaceGUID} '{0B7CDB90-8588-4260-A54C-D87101C669EA}',\r\n {taArraySetClassName} 'TJclArraySet',\r\n {taHashSetBucketTypeName} 'TJclHashSetBucket',\r\n {taHashSetClassName} 'TJclHashSet',\r\n {taHashSetIteratorClassName} 'TJclHashSetIterator',\r\n {taTreeIteratorInterfaceName} 'IJclTreeIterator',\r\n {taTreeIteratorInterfaceGUID} '{8B4863B0-B6B9-426E-B5B8-7AF71D264237}',\r\n {taTreeInterfaceName} 'IJclTree',\r\n {taTreeInterfaceGUID} '{B0C658CC-FEF5-4178-A4C5-442C0DEDE207}',\r\n {taTreeNodeClassName} 'TJclTreeNode',\r\n {taTreeClassName} 'TJclTree',\r\n {taTreeBaseIteratorClassName} 'TJclTreeIterator',\r\n {taTreePreOrderIteratorClassName} 'TJclPreOrderTreeIterator',\r\n {taTreePostOrderIteratorClassName} 'TJclPostOrderTreeIterator',\r\n {taQueueInterfaceName} 'IJclQueue',\r\n {taQueueInterfaceGUID} '{7D0F9DE4-71EA-46EF-B879-88BCFD5D9610}',\r\n {taQueueClassName} 'TJclQueue',\r\n {taSortedSetInterfaceName} 'IJclSortedSet',\r\n {taSortedSetInterfaceGUID} '{A3D23E76-ADE9-446C-9B97-F49FCE895D9F}',\r\n {taStackInterfaceName} 'IJclStack',\r\n {taStackInterfaceGUID} '{E07E0BD8-A831-41B9-B9A0-7199BD4873B9}',\r\n {taStackClassName} 'TJclStack'\r\n );\r\n\r\n KnownAllTypes: array[0..13] of PKnownTypeAttributes =\r\n ( @IInterfaceKnownType,\r\n @AnsiStringKnownType,\r\n @WideStringKnownType,\r\n @UnicodeStringKnownType,\r\n @StringKnownType,\r\n @SingleKnownType,\r\n @DoubleKnownType,\r\n @ExtendedKnownType,\r\n @FloatKnownType,\r\n @IntegerKnownType,\r\n @CardinalKnownType,\r\n @Int64KnownType,\r\n @PointerKnownType,\r\n @TObjectKnownType );\r\n\r\n // same as previous, except without compiler magic types (string) and type aliases (float)\r\n KnownTrueTypes: array[0..11] of PKnownTypeAttributes =\r\n ( @IInterfaceKnownType,\r\n @AnsiStringKnownType,\r\n @WideStringKnownType,\r\n @UnicodeStringKnownType,\r\n @SingleKnownType,\r\n @DoubleKnownType,\r\n @ExtendedKnownType,\r\n @IntegerKnownType,\r\n @CardinalKnownType,\r\n @Int64KnownType,\r\n @PointerKnownType,\r\n @TObjectKnownType );\r\n\r\nfunction IsKnownType(const TypeName: string): PKnownTypeAttributes;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jcl.svn.sourceforge.net/svnroot/jcl/tags/JCL-2.4-Build4571/jcl/source/common/JclPreProcessorContainerKnownTypes.pas $';\r\n Revision: '$Revision: 3746 $';\r\n Date: '$Date: 2012-02-24 12:23:03 +0100 (ven. 24 févr. 2012) $';\r\n LogPath: 'JCL\\source\\common';\r\n Extra: '';\r\n Data: nil\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n {$IFDEF HAS_UNITSCOPE}\r\n System.SysUtils;\r\n {$ELSE ~HAS_UNITSCOPE}\r\n SysUtils;\r\n {$ENDIF ~HAS_UNITSCOPE}\r\n\r\nfunction IsKnownType(const TypeName: string): PKnownTypeAttributes;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := nil;\r\n for I := Low(KnownAllTypes) to High(KnownAllTypes) do\r\n if SameText(TypeName, KnownAllTypes[I]^[taTypeName]) then\r\n begin\r\n Result := KnownAllTypes[I];\r\n Break;\r\n end;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jcl/source/common/JclPreProcessorContainerTemplates.pas", "content": "{**************************************************************************************************}\r\n{ }\r\n{ Project JEDI Code Library (JCL) }\r\n{ }\r\n{ The contents of this file are subject to the Mozilla Public License Version 1.1 (the \"License\"); }\r\n{ you may not use this file except in compliance with the License. You may obtain a copy of the }\r\n{ License at http://www.mozilla.org/MPL/ }\r\n{ }\r\n{ Software distributed under the License is distributed on an \"AS IS\" basis, WITHOUT WARRANTY OF }\r\n{ ANY KIND, either express or implied. See the License for the specific language governing rights }\r\n{ and limitations under the License. }\r\n{ }\r\n{ The Original Code is JclContainerTemplates.pas. }\r\n{ }\r\n{ The Initial Developer of the Original Code is Florent Ouchet }\r\n{ }\r\n{ Portions created by Florent Ouchet are Copyright (C) of Florent Ouchet. All rights reserved. }\r\n{ }\r\n{ Contributors: }\r\n{ }\r\n{**************************************************************************************************}\r\n{ }\r\n{ Last modified: $Date:: 2012-02-03 19:25:51 +0100 (ven. 03 févr. 2012) $ }\r\n{ Revision: $Rev:: 3712 $ }\r\n{ Author: $Author:: outchy $ }\r\n{ }\r\n{**************************************************************************************************}\r\n\r\nunit JclPreProcessorContainerTemplates;\r\n\r\ninterface\r\n\r\n{$I jcl.inc}\r\n\r\nuses\r\n {$IFDEF HAS_UNITSCOPE}\r\n System.Classes,\r\n {$ELSE ~HAS_UNITSCOPE}\r\n Classes,\r\n {$ENDIF ~HAS_UNITSCOPE}\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n JclBase,\r\n JclIDEUtils,\r\n JclPreProcessorTemplates,\r\n JclPreProcessorContainerTypes,\r\n JclPreProcessorContainer1DTemplates,\r\n JclPreProcessorContainer2DTemplates;\r\n\r\n{$TYPEINFO ON}\r\n\r\ntype\r\n TJclContainerParams = class(TJclTemplateParams)\r\n private\r\n FTypeInfo: TJclContainerTypeInfo;\r\n FAllTypeIndex: Integer;\r\n FTrueTypeIndex: Integer;\r\n FMapInfo: TJclContainerMapInfo;\r\n FAllMapIndex: Integer;\r\n FTrueMapIndex: Integer;\r\n function GetAllTypeCount: Integer;\r\n function GetHelpAllTypeCount: Integer;\r\n function GetTrueTypeCount: Integer;\r\n function GetHelpTrueTypeCount: Integer;\r\n procedure SetAllTypeIndex(const Value: Integer);\r\n procedure SetTrueTypeIndex(const Value: Integer);\r\n function GetAllMapCount: Integer;\r\n function GetHelpAllMapCount: Integer;\r\n function GetTrueMapCount: Integer;\r\n function GetHelpTrueMapCount: Integer;\r\n procedure SetAllMapIndex(const Value: Integer);\r\n procedure SetMapTypeIndex(const Value: Integer);\r\n protected\r\n function ProcessConditional(const MacroText: string; ContainerTypeInfo: TJclContainerTypeInfo): string;\r\n procedure ProcessDefines(const Prefix, Defines, Undefs: string);\r\n public\r\n constructor Create;\r\n destructor Destroy; override;\r\n function ExpandMacro(const AName: string; const ParamValues: TDynStringArray): string; override;\r\n published\r\n property AllTypeIndex: Integer read FAllTypeIndex write SetAllTypeIndex;\r\n property AllTypeCount: Integer read GetAllTypeCount;\r\n property HelpAllTypeCount: Integer read GetHelpAllTypeCount;\r\n property TrueTypeIndex: Integer read FTrueTypeIndex write SetTrueTypeIndex;\r\n property TrueTypeCount: Integer read GetTrueTypeCount;\r\n property HelpTrueTypeCount: Integer read GetHelpTrueTypeCount;\r\n property AllMapIndex: Integer read FAllMapIndex write SetAllMapIndex;\r\n property AllMapCount: Integer read GetAllMapCount;\r\n property HelpAllMapCount: Integer read GetHelpAllMapCount;\r\n property TrueMapIndex: Integer read FTrueMapIndex write SetMapTypeIndex;\r\n property TrueMapCount: Integer read GetTrueMapCount;\r\n property HelpTrueMapCount: Integer read GetHelpTrueMapCount;\r\n end;\r\n\r\n{$IFNDEF TYPEINFO_ON}\r\n {$TYPEINFO OFF}\r\n{$ENDIF ~TYPEINFO_ON}\r\n\r\nprocedure RegisterContainerParams(const PrototypeName: string;\r\n InterfaceParamsClass: TJclInterfaceParamsClass); overload;\r\nprocedure RegisterContainerParams(const PrototypeName: string;\r\n ImplementationParamsClass: TJclImplementationParamsClass;\r\n InterfaceParamsClass: TJclInterfaceParamsClass); overload;\r\nprocedure FindContainerParams(const PrototypeName: string;\r\n out InterfaceParamsClass: TJclInterfaceParamsClass;\r\n out ImplementationParamsClass: TJclImplementationParamsClass);\r\n\r\nprocedure CheckJclContainers;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jcl.svn.sourceforge.net/svnroot/jcl/tags/JCL-2.4-Build4571/jcl/source/common/JclPreProcessorContainerTemplates.pas $';\r\n Revision: '$Revision: 3712 $';\r\n Date: '$Date: 2012-02-03 19:25:51 +0100 (ven. 03 févr. 2012) $';\r\n LogPath: 'JCL\\source\\common';\r\n Extra: '';\r\n Data: nil\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n {$IFDEF HAS_UNITSCOPE}\r\n {$IFDEF MSWINDOWS}\r\n Winapi.Windows,\r\n {$ENDIF MSWINDOWS}\r\n System.TypInfo,\r\n System.SysUtils,\r\n {$ELSE ~HAS_UNITSCOPE}\r\n {$IFDEF MSWINDOWS}\r\n Windows,\r\n {$ENDIF MSWINDOWS}\r\n TypInfo,\r\n SysUtils,\r\n {$ENDIF ~HAS_UNITSCOPE}\r\n JclRTTI,\r\n JclSysUtils,\r\n JclStrings,\r\n JclContainerIntf,\r\n JclPreProcessorContainerKnownTypes,\r\n JclPreProcessorContainerKnownMaps;\r\n\r\ntype\r\n TInterfaceParamsRec = record\r\n ParamsName: string;\r\n ParamsCount: Integer;\r\n ParamsClass: TJclInterfaceParamsClass;\r\n end;\r\n\r\n TImplementationParamsRec = record\r\n ParamsName: string;\r\n ParamsCount: Integer;\r\n ParamsClass: TJclImplementationParamsClass;\r\n InterfaceParamsClass: TJclInterfaceParamsClass;\r\n end;\r\n\r\nvar\r\n GlobalInterfaceParams: array of TInterfaceParamsRec;\r\n GlobalImplementationParams: array of TImplementationParamsRec;\r\n GlobalTypeAttributeHandlers: array [TAllTypeAttributeID] of TJclInterfaceParamsClass;\r\n GlobalTypeAttributeDependencies: array [TAllTypeAttributeID] of TAllTypeAttributeIDs;\r\n\r\nprocedure ClearRegisteredContainers;\r\nvar\r\n AttributeID: TAllTypeAttributeID;\r\nbegin\r\n SetLength(GlobalInterfaceParams, 0);\r\n SetLength(GlobalImplementationParams, 0);\r\n // avoid spurious errors while recompiling installed package in the IDE\r\n // for some reasons the GlobalTypeAttributeHandlers and GlobalAttirbuteDependencies\r\n // are not clean when the package is reloaded\r\n for AttributeID := Low(AttributeID) to High(AttributeID) do\r\n begin\r\n GlobalTypeAttributeHandlers[AttributeID] := nil;\r\n GlobalTypeAttributeDependencies[AttributeID] := [];\r\n end;\r\nend;\r\n\r\nprocedure RegisterContainerParams(const PrototypeName: string;\r\n InterfaceParamsClass: TJclInterfaceParamsClass);\r\nvar\r\n PropList: PPropList;\r\n PropInfo: PPropInfo;\r\n PropCount, Index: Integer;\r\n Dependencies: TAllTypeAttributeIDs;\r\nbegin\r\n // avoid duplicate registrations\r\n for Index := Low(GlobalInterfaceParams) to High(GlobalInterfaceParams) do\r\n if (GlobalInterfaceParams[Index].ParamsName = PrototypeName) then\r\n Exit;\r\n\r\n PropCount := GetStringPropList(InterfaceParamsClass.ClassInfo, PropList);\r\n if PropCount > 0 then\r\n begin\r\n try\r\n Dependencies := [];\r\n for Index := 0 to PropCount - 1 do\r\n begin\r\n PropInfo := PropList^[Index];\r\n if (PropInfo^.Index > 0) and (PropInfo^.StoredProc = nil) then\r\n Include(Dependencies, TAllTypeAttributeID(PropInfo^.Index));\r\n end;\r\n for Index := 0 to PropCount - 1 do\r\n begin\r\n PropInfo := PropList^[Index];\r\n if (PropInfo^.Index > 0) and (PropInfo^.StoredProc <> nil) then\r\n begin\r\n if Assigned(GlobalTypeAttributeHandlers[TAllTypeAttributeID(PropInfo^.Index)]) then\r\n raise EJclContainerException.CreateFmt('Duplicate handler for attribute %s: %s and %s',\r\n [GetEnumName(TypeInfo(TAllTypeAttributeID), PropInfo^.Index),\r\n GlobalTypeAttributeHandlers[TAllTypeAttributeID(PropInfo^.Index)].ClassName,\r\n InterfaceParamsClass.ClassName]);\r\n GlobalTypeAttributeHandlers[TAllTypeAttributeID(PropInfo^.Index)] := InterfaceParamsClass;\r\n GlobalTypeAttributeDependencies[TAllTypeAttributeID(PropInfo^.Index)] := Dependencies;\r\n end;\r\n end;\r\n if PrototypeName <> '' then\r\n begin\r\n Index := Length(GlobalInterfaceParams);\r\n SetLength(GlobalInterfaceParams, Index + 1);\r\n GlobalInterfaceParams[Index].ParamsName := PrototypeName;\r\n GlobalInterfaceParams[Index].ParamsCount := PropCount;\r\n GlobalInterfaceParams[Index].ParamsClass := InterfaceParamsClass;\r\n end;\r\n finally\r\n FreeMem(PropList);\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure RegisterContainerParams(const PrototypeName: string;\r\n ImplementationParamsClass: TJclImplementationParamsClass;\r\n InterfaceParamsClass: TJclInterfaceParamsClass);\r\nvar\r\n PropList: PPropList;\r\n PropCount, Index: Integer;\r\n PropInfo: PPropInfo;\r\nbegin\r\n // avoid duplicate registrations\r\n for Index := Low(GlobalImplementationParams) to High(GlobalImplementationParams) do\r\n if (GlobalImplementationParams[Index].ParamsName = PrototypeName) then\r\n Exit;\r\n\r\n PropCount := GetStringPropList(ImplementationParamsClass.ClassInfo, PropList);\r\n if PropCount > 0 then\r\n begin\r\n try\r\n for Index := 0 to PropCount - 1 do\r\n begin\r\n PropInfo := PropList^[Index];\r\n if (PropInfo^.Index > 0) and (PropInfo^.StoredProc <> nil) then\r\n raise EJclContainerException.CreateFmt('Invalid interface handler for attribute %s in %s',\r\n [GetEnumName(TypeInfo(TAllTypeAttributeID), PropInfo^.Index),\r\n ImplementationParamsClass.ClassName]);\r\n end;\r\n if PrototypeName <> '' then\r\n begin\r\n Index := Length(GlobalImplementationParams);\r\n SetLength(GlobalImplementationParams, Index + 1);\r\n GlobalImplementationParams[Index].ParamsName := PrototypeName;\r\n GlobalImplementationParams[Index].ParamsCount := PropCount;\r\n GlobalImplementationParams[Index].ParamsClass := ImplementationParamsClass;\r\n GlobalImplementationParams[Index].InterfaceParamsClass := InterfaceParamsClass;\r\n end;\r\n finally\r\n FreeMem(PropList);\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure FindContainerParams(const PrototypeName: string;\r\n out InterfaceParamsClass: TJclInterfaceParamsClass;\r\n out ImplementationParamsClass: TJclImplementationParamsClass);\r\nvar\r\n ParamsCount, Index: Integer;\r\n MacroName: string;\r\nbegin\r\n InterfaceParamsClass := nil;\r\n ImplementationParamsClass := nil;\r\n Index := Pos('`', PrototypeName);\r\n if Index > 0 then\r\n begin\r\n MacroName := Copy(PrototypeName, 1, Index - 1);\r\n ParamsCount := StrToInt(Copy(PrototypeName, Index + 1, Length(PrototypeName) - Index));\r\n end\r\n else\r\n begin\r\n MacroName := PrototypeName;\r\n ParamsCount := -1;\r\n end;\r\n InterfaceParamsClass := nil;\r\n ImplementationParamsClass := nil;\r\n for Index := Low(GlobalInterfaceParams) to High(GlobalInterfaceParams) do\r\n if AnsiSameText(MacroName, GlobalInterfaceParams[Index].ParamsName) and\r\n ((ParamsCount = -1) or (ParamsCount = GlobalInterfaceParams[Index].ParamsCount)) then\r\n begin\r\n InterfaceParamsClass := GlobalInterfaceParams[Index].ParamsClass;\r\n ImplementationParamsClass := nil;\r\n Exit;\r\n end;\r\n for Index := Low(GlobalImplementationParams) to High(GlobalImplementationParams) do\r\n if AnsiSameText(MacroName, GlobalImplementationParams[Index].ParamsName) and\r\n ((ParamsCount = -1) or (ParamsCount = GlobalImplementationParams[Index].ParamsCount)) then\r\n begin\r\n InterfaceParamsClass := GlobalImplementationParams[Index].InterfaceParamsClass;\r\n ImplementationParamsClass := GlobalImplementationParams[Index].ParamsClass;\r\n Exit;\r\n end;\r\nend;\r\n\r\nprocedure CheckJclContainers;\r\nvar\r\n Index: TAllTypeAttributeID;\r\nbegin\r\n for Index := Low(TAllTypeAttributeID) to High(TAllTypeAttributeID) do\r\n if (Index <> taTypeName) and (Index <> maMapAncestorClassName) and\r\n // exclude key and value attribute ID that are aliases to standard type ID\r\n ((Index < Low(TKeyAttributeID)) or (Index > High(TKeyAttributeID))) and\r\n ((Index < Low(TValueAttributeID)) or (Index > High(TValueAttributeID))) and\r\n (GlobalTypeAttributeHandlers[Index] = nil) then\r\n raise EJclContainerException.CreateFmt('No handler found for attribute %s',\r\n [GetEnumName(TypeInfo(TAllTypeAttributeID), Integer(Index))]);\r\nend;\r\n\r\n//function FindContainerParams(TypeInformationID: TTypeAttributeID): TJclContainerParamsClass; overload;\r\n//begin\r\n\r\n//end;\r\n\r\n//function FindContainerParams(const PrototypeName: string): TJclContainerParamsClass; overload;\r\n//begin\r\n\r\n//end;\r\n\r\n//=== { TJclContainerParams } ================================================\r\n\r\nconstructor TJclContainerParams.Create;\r\nbegin\r\n inherited Create;\r\n FTypeInfo := TJclContainerTypeInfo.Create;\r\n FMapInfo := TJclContainerMapInfo.Create;\r\nend;\r\n\r\ndestructor TJclContainerParams.Destroy;\r\nbegin\r\n FMapInfo.Free;\r\n FTypeInfo.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJclContainerParams.ExpandMacro(const AName: string;\r\n const ParamValues: TDynStringArray): string;\r\nvar\r\n InterfaceParamsClass: TJclInterfaceParamsClass;\r\n ImplementationParamsClass: TJclImplementationParamsClass;\r\n InterfaceParams: TJclInterfaceParams;\r\n ImplementationParams: TJclImplementationParams;\r\n AMacroName, AMacroText: string;\r\n AMacro: IJclStrList;\r\n AMacroParams: TDynWideStringArray;\r\n Params: array of TVarRec;\r\n Index: Integer;\r\n PropInfo: PPropInfo;\r\n AliasAttributeID: TAllTypeAttributeID;\r\n AliasAttributeIDs: TAllTypeAttributeIDs;\r\n AliasTypeIndex, AliasMapIndex: Integer;\r\n AliasTypeAttributes: PKnownTypeAttributes;\r\n AliasMapAttributes: PKnownMapAttributes;\r\nbegin\r\n SetLength(AMacroParams, 0);\r\n FindContainerParams(AName, InterfaceParamsClass, ImplementationParamsClass);\r\n if InterfaceParamsClass <> nil then\r\n begin\r\n InterfaceParams := InterfaceParamsClass.Create;\r\n if InterfaceParams is TJclContainerInterfaceParams then\r\n TJclContainerInterfaceParams(InterfaceParams).TypeInfo := FTypeInfo;\r\n if InterfaceParams is TJclMapInterfaceParams then\r\n TJclMapInterfaceParams(InterfaceParams).MapInfo := FMapInfo;\r\n if ImplementationParamsClass <> nil then\r\n ImplementationParams := ImplementationParamsClass.Create(InterfaceParams)\r\n else\r\n ImplementationParams := nil;\r\n try\r\n AMacroName := Format('%s`%d', [AName, Length(ParamValues)]);\r\n AMacro := FindMacro(AMacroName);\r\n // the macro text is the last item, previous items are the macro parameter names\r\n AMacroText := AMacro.Strings[AMacro.Size - 1];\r\n AMacroParams := AssociateParameters(AMacro.SubList(0, AMacro.Size - 1), ParamValues);\r\n\r\n if ImplementationParams <> nil then\r\n AliasAttributeIDs := []\r\n else\r\n AliasAttributeIDs := InterfaceParams.AliasAttributeIDs;\r\n\r\n Result := '';\r\n\r\n if AliasAttributeIDs <> [] then\r\n begin\r\n // this is an alias declaration\r\n // replace the macro with some predefined text\r\n if (InterfaceParams is TJclContainerInterfaceParams) and FTypeInfo.KnownType then\r\n begin\r\n for AliasTypeIndex := Low(KnownAllTypes) to High(KnownAllTypes) do\r\n begin\r\n AliasTypeAttributes := KnownAllTypes[AliasTypeIndex];\r\n if AliasTypeAttributes^[taAlias] = FTypeInfo.TypeName then\r\n begin\r\n Result := Format('%s{$IFDEF %s}%s', [Result, AliasTypeAttributes^[taAliasCondition], NativeLineBreak]);\r\n for AliasAttributeID := Low(AliasAttributeID) to High(AliasAttributeID) do\r\n if AliasAttributeID in AliasAttributeIDs then\r\n begin\r\n Result := Format('%s%s = %s;%s',\r\n [Result, FTypeInfo.TypeAttributes[AliasAttributeID], AliasTypeAttributes^[AliasAttributeID], NativeLineBreak]);\r\n end;\r\n Result := Format('%s{$ENDIF %s}%s', [Result, AliasTypeAttributes^[taAliasCondition], NativeLineBreak]);\r\n end;\r\n end;\r\n end\r\n else\r\n if (InterfaceParams is TJclMapInterfaceParams) and FMapInfo.KnownMap then\r\n begin\r\n for AliasMapIndex := Low(KnownAllMaps) to High(KnownAllMaps) do\r\n begin\r\n AliasMapAttributes := KnownAllMaps[AliasMapIndex];\r\n // key alias\r\n if (AliasMapAttributes^.KeyAttributes[taAlias] = FMapInfo.KeyTypeInfo.TypeName) and\r\n (AliasMapAttributes^.ValueAttributes[taTypeName] = FMapInfo.ValueTypeInfo.TypeName) then\r\n begin\r\n Result := Format('%s{$IFDEF %s}%s', [Result, AliasMapAttributes^.KeyAttributes[taAliasCondition], NativeLineBreak]);\r\n for AliasAttributeID := Low(AliasAttributeID) to High(AliasAttributeID) do\r\n if AliasAttributeID in AliasAttributeIDs then\r\n begin\r\n Result := Format('%s%s = %s;%s',\r\n [Result, FMapInfo.MapAttributes[AliasAttributeID], AliasMapAttributes^.MapAttributes[AliasAttributeID], NativeLineBreak]);\r\n end;\r\n Result := Format('%s{$ENDIF %s}%s', [Result, AliasMapAttributes^.KeyAttributes[taAliasCondition], NativeLineBreak]);\r\n end\r\n else\r\n // value alias\r\n if (AliasMapAttributes^.ValueAttributes[taAlias] = FMapInfo.ValueTypeInfo.TypeName) and\r\n (AliasMapAttributes^.KeyAttributes[taTypeName] = FMapInfo.KeyTypeInfo.TypeName) then\r\n begin\r\n Result := Format('%s{$IFDEF %s}%s', [Result, AliasMapAttributes^.ValueAttributes[taAliasCondition], NativeLineBreak]);\r\n for AliasAttributeID := Low(AliasAttributeID) to High(AliasAttributeID) do\r\n if AliasAttributeID in AliasAttributeIDs then\r\n begin\r\n Result := Format('%s%s = %s;%s',\r\n [Result, FMapInfo.MapAttributes[AliasAttributeID], AliasMapAttributes^.MapAttributes[AliasAttributeID], NativeLineBreak]);\r\n end;\r\n Result := Format('%s{$ENDIF %s}%s', [Result, AliasMapAttributes^.ValueAttributes[taAliasCondition], NativeLineBreak]);\r\n end\r\n else\r\n // both aliases\r\n if (AliasMapAttributes^.KeyAttributes[taAlias] = FMapInfo.KeyTypeInfo.TypeName) and\r\n (AliasMapAttributes^.ValueAttributes[taAlias] = FMapInfo.ValueTypeInfo.TypeName) then\r\n begin\r\n if AliasMapAttributes^.KeyAttributes[taAliasCondition] <> AliasMapAttributes^.ValueAttributes[taAliasCondition] then\r\n Result := Format('%s{$IFDEF %s}%s{$IFDEF %s}%s',\r\n [Result,\r\n AliasMapAttributes^.KeyAttributes[taAliasCondition], NativeLineBreak,\r\n AliasMapAttributes^.ValueAttributes[taAliasCondition], NativeLineBreak])\r\n else\r\n Result := Format('%s{$IFDEF %s}%s', [Result, AliasMapAttributes^.KeyAttributes[taAliasCondition], NativeLineBreak]);\r\n for AliasAttributeID := Low(AliasAttributeID) to High(AliasAttributeID) do\r\n if AliasAttributeID in AliasAttributeIDs then\r\n begin\r\n Result := Format('%s%s = %s;%s',\r\n [Result, FMapInfo.MapAttributes[AliasAttributeID], AliasMapAttributes^.MapAttributes[AliasAttributeID], NativeLineBreak]);\r\n end;\r\n if AliasMapAttributes^.KeyAttributes[taAliasCondition] <> AliasMapAttributes^.ValueAttributes[taAliasCondition] then\r\n Result := Format('%s{$ENDIF %s}%s{$ENDIF %s}%s',\r\n [Result,\r\n AliasMapAttributes^.KeyAttributes[taAliasCondition], NativeLineBreak,\r\n AliasMapAttributes^.ValueAttributes[taAliasCondition], NativeLineBreak])\r\n else\r\n Result := Format('%s{$ENDIF %s}%s', [Result, AliasMapAttributes^.KeyAttributes[taAliasCondition], NativeLineBreak]);\r\n end;\r\n end;\r\n end;\r\n end;\r\n\r\n if Result = '' then\r\n begin\r\n // expand the macro\r\n SetLength(Params, Length(ParamValues));\r\n for Index := Low(ParamValues) to High(ParamValues) do\r\n begin\r\n if AMacroParams[Index] = '' then\r\n begin\r\n // default to params\r\n if Assigned(ImplementationParams) then\r\n begin\r\n PropInfo := GetPropInfo(ImplementationParams, AMacro.Strings[Index]);\r\n if Assigned(PropInfo) then\r\n {$IFDEF COMPILER8_UP}\r\n AMacroParams[Index] := GetPropValue(ImplementationParams, PropInfo);\r\n {$ELSE ~COMPILER8_UP}\r\n AMacroParams[Index] := GetPropValue(ImplementationParams, AMacro.Strings[Index]);\r\n {$ENDIF ~COMPILER8_UP}\r\n end\r\n else\r\n begin\r\n PropInfo := GetPropInfo(InterfaceParams, AMacro.Strings[Index]);\r\n if Assigned(PropInfo) then\r\n {$IFDEF COMPILER8_UP}\r\n AMacroParams[Index] := GetPropValue(InterfaceParams, PropInfo);\r\n {$ELSE ~COMPILER8_UP}\r\n AMacroParams[Index] := GetPropValue(InterfaceParams, AMacro.Strings[Index]);\r\n {$ENDIF ~COMPILER8_UP}\r\n end;\r\n end;\r\n Params[Index].VType := vtPWideChar;\r\n Params[Index].VPWideChar := PWideChar(AMacroParams[Index]);\r\n end;\r\n Result := Format(AMacroText, Params);\r\n end;\r\n if Assigned(ImplementationParams) then\r\n Result := ImplementationParams.GetMacroHeader + Result + ImplementationParams.GetMacroFooter\r\n else\r\n Result := InterfaceParams.GetMacroHeader + Result + InterfaceParams.GetMacroFooter;\r\n\r\n // process conditional defines\r\n if (InterfaceParams is TJclMapInterfaceParams) and FMapInfo.KnownMap then\r\n begin\r\n ProcessDefines('KEY',\r\n FMapInfo.KeyTypeInfo.TypeAttributes[taDefines],\r\n FMapInfo.KeyTypeInfo.TypeAttributes[taUndefs]);\r\n ProcessDefines('VALUE',\r\n FMapInfo.ValueTypeInfo.TypeAttributes[taDefines],\r\n FMapInfo.ValueTypeInfo.TypeAttributes[taUndefs]);\r\n Result := ProcessConditional(Result, FMapInfo.KeyTypeInfo);\r\n if FMapInfo.KeyTypeInfo.TypeAttributes[taCondition] <> FMapInfo.ValueTypeInfo.TypeAttributes[taCondition] then\r\n Result := ProcessConditional(Result, FMapInfo.ValueTypeInfo);\r\n end\r\n else\r\n if (InterfaceParams is TJclContainerInterfaceParams) and FTypeInfo.KnownType then\r\n begin\r\n ProcessDefines('',\r\n FTypeInfo.TypeAttributes[taDefines],\r\n FTypeInfo.TypeAttributes[taUndefs]);\r\n Result := ProcessConditional(Result, FTypeInfo);\r\n end;\r\n finally\r\n ImplementationParams.Free;\r\n InterfaceParams.Free;\r\n end;\r\n end\r\n else\r\n Result := inherited ExpandMacro(AName, ParamValues);\r\nend;\r\n\r\nfunction TJclContainerParams.GetAllMapCount: Integer;\r\nbegin\r\n Result := Length(KnownAllMaps);\r\nend;\r\n\r\nfunction TJclContainerParams.GetHelpAllMapCount: Integer;\r\nbegin\r\n Result := Length(KnownAllMaps) - 1;\r\nend;\r\n\r\nfunction TJclContainerParams.GetAllTypeCount: Integer;\r\nbegin\r\n Result := Length(KnownAllTypes);\r\nend;\r\n\r\nfunction TJclContainerParams.GetHelpAllTypeCount: Integer;\r\nbegin\r\n Result := Length(KnownAllTypes) - 1;\r\nend;\r\n\r\nfunction TJclContainerParams.GetTrueMapCount: Integer;\r\nbegin\r\n Result := Length(KnownTrueMaps);\r\nend;\r\n\r\nfunction TJclContainerParams.GetHelpTrueMapCount: Integer;\r\nbegin\r\n Result := Length(KnownTrueMaps) - 1;\r\nend;\r\n\r\nfunction TJclContainerParams.GetTrueTypeCount: Integer;\r\nbegin\r\n Result := Length(KnownTrueTypes);\r\nend;\r\n\r\nfunction TJclContainerParams.GetHelpTrueTypeCount: Integer;\r\nbegin\r\n Result := Length(KnownTrueTypes) - 1;\r\nend;\r\n\r\nfunction TJclContainerParams.ProcessConditional(const MacroText: string; ContainerTypeInfo: TJclContainerTypeInfo): string;\r\nvar\r\n Condition: string;\r\nbegin\r\n Result := MacroText;\r\n Condition := ContainerTypeInfo.TypeAttributes[taCondition];\r\n if Condition <> '' then\r\n Result := Format('{$IFDEF %s}%s%s%s{$ENDIF %s}%s',\r\n [Condition, NativeLineBreak,\r\n Result, NativeLineBreak,\r\n Condition, NativeLineBreak]);\r\nend;\r\n\r\nprocedure TJclContainerParams.ProcessDefines(const Prefix, Defines, Undefs: string);\r\nvar\r\n DefineList: TStrings;\r\n I: Integer;\r\nbegin\r\n DefineList := TStringList.Create;\r\n try\r\n StrToStrings(Defines, ';', DefineList, False);\r\n for I := 0 to DefineList.Count - 1 do\r\n Define(Prefix + DefineList.Strings[I]);\r\n StrToStrings(Undefs, ';', DefineList, False);\r\n for I := 0 to DefineList.Count - 1 do\r\n Undef(Prefix + DefineList.Strings[I]);\r\n finally\r\n DefineList.Free;\r\n end;\r\nend;\r\n\r\nprocedure TJclContainerParams.SetAllMapIndex(const Value: Integer);\r\nbegin\r\n FAllMapIndex := Value;\r\n if (Value >= Low(KnownAllMaps)) and (Value <= High(KnownAllMaps)) then\r\n begin\r\n FMapInfo.KeyTypeInfo.TypeName := KnownAllMaps[Value]^.KeyAttributes[taTypeName];\r\n FMapInfo.ValueTypeInfo.TypeName := KnownAllMaps[Value]^.ValueAttributes[taTypeName];\r\n FMapInfo.KnownMap := True;\r\n end\r\n else\r\n begin\r\n FMapInfo.KeyTypeInfo.TypeName := '';\r\n FMapInfo.ValueTypeInfo.TypeName := '';\r\n FMapInfo.KnownMap := False;\r\n end;\r\nend;\r\n\r\nprocedure TJclContainerParams.SetAllTypeIndex(const Value: Integer);\r\nbegin\r\n FAllTypeIndex := Value;\r\n if (Value >= Low(KnownAllTypes)) and (Value <= High(KnownAllTypes)) then\r\n begin\r\n FTypeInfo.TypeName := KnownAllTypes[Value]^[taTypeName];\r\n FTypeInfo.KnownType := True;\r\n end\r\n else\r\n begin\r\n FTypeInfo.TypeName := '';\r\n FTypeInfo.KnownType := False;\r\n end;\r\nend;\r\n\r\nprocedure TJclContainerParams.SetMapTypeIndex(const Value: Integer);\r\nbegin\r\n FTrueMapIndex := Value;\r\n if (Value >= Low(KnownTrueMaps)) and (Value <= High(KnownTrueMaps)) then\r\n begin\r\n FMapInfo.KeyTypeInfo.TypeName := KnownTrueMaps[Value]^.KeyAttributes[taTypeName];\r\n FMapInfo.ValueTypeInfo.TypeName := KnownTrueMaps[Value]^.ValueAttributes[taTypeName];\r\n FMapInfo.KnownMap := True;\r\n end\r\n else\r\n begin\r\n FMapInfo.KeyTypeInfo.TypeName := '';\r\n FMapInfo.ValueTypeInfo.TypeName := '';\r\n FMapInfo.KnownMap := False;\r\n end;\r\nend;\r\n\r\nprocedure TJclContainerParams.SetTrueTypeIndex(const Value: Integer);\r\nbegin\r\n FTrueTypeIndex := Value;\r\n if (Value >= Low(KnownTrueTypes)) and (Value <= High(KnownTrueTypes)) then\r\n begin\r\n FTypeInfo.TypeName := KnownTrueTypes[Value]^[taTypeName];\r\n FTypeInfo.KnownType := True;\r\n end\r\n else\r\n begin\r\n FTypeInfo.TypeName := '';\r\n FTypeInfo.KnownType := False;\r\n end;\r\nend;\r\n\r\ninitialization\r\n {$IFDEF UNITVERSIONING}\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n {$ENDIF UNITVERSIONING}\r\n\r\nfinalization\r\n {$IFDEF UNITVERSIONING}\r\n UnregisterUnitVersion(HInstance);\r\n {$ENDIF UNITVERSIONING}\r\n ClearRegisteredContainers;\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jcl/source/common/JclPreProcessorContainerTypes.pas", "content": "{**************************************************************************************************}\r\n{ }\r\n{ Project JEDI Code Library (JCL) }\r\n{ }\r\n{ The contents of this file are subject to the Mozilla Public License Version 1.1 (the \"License\"); }\r\n{ you may not use this file except in compliance with the License. You may obtain a copy of the }\r\n{ License at http://www.mozilla.org/MPL/ }\r\n{ }\r\n{ Software distributed under the License is distributed on an \"AS IS\" basis, WITHOUT WARRANTY OF }\r\n{ ANY KIND, either express or implied. See the License for the specific language governing rights }\r\n{ and limitations under the License. }\r\n{ }\r\n{ The Original Code is JclContainerTypes.pas. }\r\n{ }\r\n{ The Initial Developer of the Original Code is Florent Ouchet }\r\n{ }\r\n{ Portions created by Florent Ouchet are Copyright (C) of Florent Ouchet. All rights reserved. }\r\n{ }\r\n{ Contributors: }\r\n{ }\r\n{**************************************************************************************************}\r\n{ }\r\n{ Last modified: $Date:: 2012-02-24 12:27:42 +0100 (ven. 24 févr. 2012) $ }\r\n{ Revision: $Rev:: 3747 $ }\r\n{ Author: $Author:: outchy $ }\r\n{ }\r\n{**************************************************************************************************}\r\n\r\nunit JclPreProcessorContainerTypes;\r\n\r\ninterface\r\n\r\n{$I jcl.inc}\r\n\r\nuses\r\n JclBase,\r\n JclPreProcessorTemplates,\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n JclNotify;\r\n\r\n\r\ntype\r\n TAllTypeAttributeID = (\r\n // attributes for 1-D containers\r\n taTypeName,\r\n taCondition, // condition while expanding macros, will be emitted\r\n taDefines, // list of defines while expanding macros, won't be emitted\r\n taUndefs, // list of undefs while expanding macros, won't be emitted\r\n taAlias,\r\n taAliasCondition,\r\n taDefaultValue,\r\n taConstKeyword,\r\n taOwnershipParameterName,\r\n taOwnershipInterfaceName,\r\n taOwnershipInterfaceGUID,\r\n taReleaserFunctionName,\r\n taReleaseEventName,\r\n taReleaseEventTypeName,\r\n taGetterFunctionName,\r\n taSetterProcedureName,\r\n taParameterName,\r\n taDynArrayTypeName,\r\n taMoveArrayProcedureName,\r\n taArrayPropertyName,\r\n taBaseContainerClassName,\r\n taBaseCollectionClassName,\r\n taIterateProcedureTypeName,\r\n taIterateProcedureName,\r\n taApplyFunctionTypeName,\r\n taApplyProcedureName,\r\n taCompareFunctionTypeName,\r\n taSimpleCompareFunctionName,\r\n taEqualityCompareFunctionTypeName,\r\n taSimpleEqualityCompareFunctionName,\r\n taHashConvertFunctionTypeName,\r\n taSimpleHashConvertFunctionName,\r\n taContainerInterfaceName,\r\n taContainerInterfaceGUID,\r\n taFlatContainerInterfaceName,\r\n taFlatContainerInterfaceGUID,\r\n taEqualityComparerInterfaceName,\r\n taEqualityComparerInterfaceGUID,\r\n taComparerInterfaceName,\r\n taComparerInterfaceGUID,\r\n taHashConverterInterfaceName,\r\n taHashConverterInterfaceGUID,\r\n taIteratorInterfaceName,\r\n taIteratorInterfaceGUID,\r\n taBinaryTreeIteratorInterfaceName,\r\n taBinaryTreeIteratorInterfaceGUID,\r\n taBinaryTreeNodeTypeName,\r\n taBinaryTreeClassName,\r\n taBinaryTreeBaseIteratorClassName,\r\n taBinaryTreePreOrderIteratorClassName,\r\n taBinaryTreeInOrderIteratorClassName,\r\n taBinaryTreePostOrderIteratorClassName,\r\n taCollectionInterfaceName,\r\n taCollectionInterfaceGUID,\r\n taListInterfaceName,\r\n taListInterfaceGUID,\r\n taSortProcedureTypeName,\r\n taSortProcedureName,\r\n taQuickSortProcedureName,\r\n taFindFunctionName,\r\n taCountObjectFunctionName,\r\n taCopyProcedureName,\r\n taGenerateProcedureName,\r\n taFillProcedureName,\r\n taReverseProcedureName,\r\n taArrayInterfaceName,\r\n taArrayInterfaceGUID,\r\n taArrayListClassName,\r\n taArrayIteratorClassName,\r\n taLinkedListItemClassName,\r\n taLinkedListClassName,\r\n taLinkedListIteratorClassName,\r\n taVectorClassName,\r\n taVectorIteratorClassName,\r\n taSetInterfaceName,\r\n taSetInterfaceGUID,\r\n taArraySetClassName,\r\n taHashSetBucketTypeName,\r\n taHashSetClassName,\r\n taHashSetIteratorClassName,\r\n taTreeIteratorInterfaceName,\r\n taTreeIteratorInterfaceGUID,\r\n taTreeInterfaceName,\r\n taTreeInterfaceGUID,\r\n taTreeNodeClassName,\r\n taTreeClassName,\r\n taTreeBaseIteratorClassName,\r\n taTreePreOrderIteratorClassName,\r\n taTreePostOrderIteratorClassName,\r\n taQueueInterfaceName,\r\n taQueueInterfaceGUID,\r\n taQueueClassName,\r\n taSortedSetInterfaceName,\r\n taSortedSetInterfaceGUID,\r\n taStackInterfaceName,\r\n taStackInterfaceGUID,\r\n taStackClassName,\r\n // attributes for 2-D containers (maps)\r\n kaKeyTypeName,\r\n kaKeyOwnershipParameterName,\r\n kaKeyConstKeyword,\r\n kaKeyParameterName,\r\n kaKeyDefaultValue,\r\n kaKeySimpleCompareFunctionName,\r\n kaKeySimpleEqualityCompareFunctionName,\r\n kaKeySimpleHashConvertFunctionName,\r\n kaKeyBaseContainerClassName,\r\n kaKeyIteratorInterfaceName,\r\n kaKeySetInterfaceName,\r\n kaKeyArraySetClassName,\r\n vaValueTypeName,\r\n vaValueOwnershipParameterName,\r\n vaValueConstKeyword,\r\n vaValueDefaultValue,\r\n vaValueSimpleCompareFunctionName,\r\n vaValueSimpleEqualityCompareFunctionName,\r\n vaValueBaseContainerClassName,\r\n vaValueCollectionInterfaceName,\r\n vaValueArrayListClassName,\r\n maMapInterfaceName,\r\n maMapInterfaceGUID,\r\n maMapInterfaceAncestorName,\r\n maSortedMapInterfaceName,\r\n maSortedMapInterfaceGUID,\r\n maMapAncestorClassName,\r\n maHashMapEntryTypeName,\r\n maHashMapEntryArrayTypeName,\r\n maHashMapBucketTypeName,\r\n maHashMapClassName,\r\n maSortedMapEntryTypeName,\r\n maSortedMapEntryArrayTypeName,\r\n maSortedMapClassName);\r\n TAllTypeAttributeIDs = set of TAllTypeAttributeID;\r\n\r\n TTypeAttributeID = taTypeName..taStackClassName;\r\n {$EXTERNALSYM TTypeAttributeID}\r\n {$HPPEMIT '#define TTypeAttributeID int'}\r\n\r\n TTypeAttributes = array [TTypeAttributeID] of string;\r\n\r\n TKnownTypeAttributes = TTypeAttributes;\r\n PKnownTypeAttributes = ^TKnownTypeAttributes;\r\n\r\n TKeyAttributeID = kaKeyTypeName..kaKeyArraySetClassName;\r\n {$EXTERNALSYM TKeyAttributeID}\r\n {$HPPEMIT '#define TKeyAttributeID int'}\r\n\r\n TValueAttributeID = vaValueTypeName..vaValueArrayListClassName;\r\n {$EXTERNALSYM TValueAttributeID}\r\n {$HPPEMIT '#define TValueAttributeID int'}\r\n\r\n TMapAttributeID = maMapInterfaceName..maSortedMapClassName;\r\n {$EXTERNALSYM TMapAttributeID}\r\n {$HPPEMIT '#define TMapAttributeID int'}\r\n\r\n TMapAttributes = array [TMapAttributeID] of string;\r\n\r\n TKnownMapAttributes = record\r\n MapAttributes: TMapAttributes;\r\n KeyAttributes: PKnownTypeAttributes;\r\n ValueAttributes: PKnownTypeAttributes;\r\n end;\r\n PKnownMapAttributes = ^TKnownMapAttributes;\r\n\r\n TTypeAttributeInfo = record\r\n IsGUID: Boolean;\r\n DefaultValue: string;\r\n end;\r\n\r\nconst\r\n TypeAttributeInfos: array [TTypeAttributeID] of TTypeAttributeInfo =\r\n ( {TypeName} (IsGUID: False; DefaultValue: ''),\r\n {Condition} (IsGUID: False; DefaultValue: ''),\r\n {Defines} (IsGUID: False; DefaultValue: ''),\r\n {Undefs} (IsGUID: False; DefaultValue: ''),\r\n {Alias} (IsGUID: False; DefaultValue: ''),\r\n {AliasCondition} (IsGUID: False; DefaultValue: ''),\r\n {DefaultValue} (IsGUID: False; DefaultValue: ''),\r\n {ConstKeyword} (IsGUID: False; DefaultValue: ''),\r\n {OwnershipParameterName} (IsGUID: False; DefaultValue: ''),\r\n {OwnershipInterfaceName} (IsGUID: False; DefaultValue: 'IJcl%sOwner'),\r\n {OwnershipInterfaceGUID} (IsGUID: True; DefaultValue: ''),\r\n {ReleaserFunctionName} (IsGUID: False; DefaultValue: 'Free%s'),\r\n {ReleaseEventName} (IsGUID: False; DefaultValue: 'OnFree%s'),\r\n {ReleaseEventTypeName} (IsGUID: False; DefaultValue: 'TFree%sEvent'),\r\n {GetterFunctionName} (IsGUID: False; DefaultValue: 'Get%s'),\r\n {SetterProcedureName} (IsGUID: False; DefaultValue: 'Set%s'),\r\n {ParameterName} (IsGUID: False; DefaultValue: 'A%s'),\r\n {DynArrayTypeName} (IsGUID: False; DefaultValue: 'TDyn%sArray'),\r\n {MoveArrayProcedureName} (IsGUID: False; DefaultValue: 'MoveArray'),\r\n {ArrayParameterName} (IsGUID: False; DefaultValue: '%ss'),\r\n {BaseContainerClassName} (IsGUID: False; DefaultValue: ''),\r\n {BaseCollectionClassName} (IsGUID: False; DefaultValue: ''),\r\n {IterateProcedureTypeName} (IsGUID: False; DefaultValue: 'T%sIterateFunction'),\r\n {IterateProcedureName} (IsGUID: False; DefaultValue: 'Iterate'),\r\n {ApplyFunctionTypeName} (IsGUID: False; DefaultValue: 'T%sApplyFunction'),\r\n {ApplyProcedureName} (IsGUID: False; DefaultValue: 'Apply'),\r\n {CompareFunctionTypeName} (IsGUID: False; DefaultValue: 'T%sCompareFunction'),\r\n {SimpleCompareFunctionName} (IsGUID: False; DefaultValue: '%sSimpleCompare'),\r\n {EqualityCompareFunctionTypeName} (IsGUID: False; DefaultValue: 'T%sEqualityCompare'),\r\n {SimpleEqualityCompareFunctionName} (IsGUID: False; DefaultValue: '%sSimpleCompare'),\r\n {HashConvertFunctionTypeName} (IsGUID: False; DefaultValue: 'T%sHashConvert'),\r\n {SimpleHashConvertFunctionName} (IsGUID: False; DefaultValue: '%sSimpleHashConvert'),\r\n {ContainerInterfaceName} (IsGUID: False; DefaultValue: ''),\r\n {ContainerInterfaceGUID} (IsGUID: True; DefaultValue: ''),\r\n {FlatContainerInterfaceName} (IsGUID: False; DefaultValue: ''),\r\n {FlatContainerInterfaceGUID} (IsGUID: True; DefaultValue: ''),\r\n {EqualityComparerInterfaceName} (IsGUID: False; DefaultValue: 'IJcl%sEqualityComparer'),\r\n {EqualityComparerInterfaceGUID} (IsGUID: True; DefaultValue: ''),\r\n {ComparerInterfaceName} (IsGUID: False; DefaultValue: 'IJcl%sComparer'),\r\n {ComparerInterfaceGUID} (IsGUID: True; DefaultValue: ''),\r\n {HashConverterInterfaceName} (IsGUID: False; DefaultValue: 'IJcl%sHashConverter'),\r\n {HashConverterInterfaceGUID} (IsGUID: True; DefaultValue: ''),\r\n {IteratorInterfaceName} (IsGUID: False; DefaultValue: 'IJcl%sIterator'),\r\n {IteratorInterfaceGUID} (IsGUID: True; DefaultValue: ''),\r\n {BinaryTreeIteratorInterfaceName} (IsGUID: False; DefaultValue: 'IJcl%sBinaryTreeIterator'),\r\n {BinaryTreeIteratorInterfaceGUID} (IsGUID: True; DefaultValue: ''),\r\n {BinaryTreeNodeTypeName} (IsGUID: False; DefaultValue: 'TJcl%sBinaryNode'),\r\n {BinaryTreeClassName} (IsGUID: False; DefaultValue: 'TJcl%sBinaryTree'),\r\n {BinaryTreeBaseIteratorClassName} (IsGUID: False; DefaultValue: 'TJcl%sBinaryTreeIterator'),\r\n {BinaryTreePreOrderIteratorClassName} (IsGUID: False; DefaultValue: 'TJclPreOrder%sBinaryTreeIterator'),\r\n {BinaryTreeInOrderIteratorClassName} (IsGUID: False; DefaultValue: 'TJclInOrder%sBinaryTreeIterator'),\r\n {BinaryTreePostOrderIteratorClassName} (IsGUID: False; DefaultValue: 'TJclPostOrder%sBinaryTreeIterator'),\r\n {CollectionInterfaceName} (IsGUID: False; DefaultValue: 'IJcl%sCollection'),\r\n {CollectionInterfaceGUID} (IsGUID: True; DefaultValue: ''),\r\n {ListInterfaceName} (IsGUID: False; DefaultValue: 'IJcl%sList'),\r\n {ListInterfaceGUID} (IsGUID: True; DefaultValue: ''),\r\n {SortProcedureTypeName} (IsGUID: False; DefaultValue: 'T%sSortProc'),\r\n {SortProcedureName} (IsGUID: False; DefaultValue: 'Sort'),\r\n {QuickSortProcedureName} (IsGUID: False; DefaultValue: 'QuickSort'),\r\n {FindFunctionName} (IsGUID: False; DefaultValue: 'Find'),\r\n {CountObjectFunctionName} (IsGUID: False; DefaultValue: 'CountObject'),\r\n {CopyProcedureName} (IsGUID: False; DefaultValue: 'Copy'),\r\n {GenerateProcedureName} (IsGUID: False; DefaultValue: 'Generate'),\r\n {FillProcedureName} (IsGUID: False; DefaultValue: 'Fill'),\r\n {ReverseProcedureName} (IsGUID: False; DefaultValue: 'Reverse'),\r\n {ArrayInterfaceName} (IsGUID: False; DefaultValue: 'IJcl%sArray'),\r\n {ArrayInterfaceGUID} (IsGUID: True; DefaultValue: ''),\r\n {ArrayListClassName} (IsGUID: False; DefaultValue: 'TJcl%sArrayList'),\r\n {ArrayIteratorClassName} (IsGUID: False; DefaultValue: 'TJcl%sArrayIterator'),\r\n {LinkedListItemTypeName} (IsGUID: False; DefaultValue: 'TJcl%sLinkedListItem'),\r\n {LinkedListClassName} (IsGUID: False; DefaultValue: 'TJcl%sLinkedList'),\r\n {LinkedListIteratorClassName} (IsGUID: False; DefaultValue: 'TJcl%sLinkedListIterator'),\r\n {VectorClassName} (IsGUID: False; DefaultValue: 'TJcl%sVector'),\r\n {VectorIteratorClassName} (IsGUID: False; DefaultValue: 'TJcl%sVectorIterator'),\r\n {SetInterfaceName} (IsGUID: False; DefaultValue: 'IJcl%sSet'),\r\n {SetInterfaceGUID} (IsGUID: True; DefaultValue: ''),\r\n {ArraySetClassName} (IsGUID: False; DefaultValue: 'TJcl%sArraySet'),\r\n {HashSetBucketTypeName} (IsGUID: False; DefaultValue: 'TJcl%sHashSetBucket'),\r\n {HashSetClassName} (IsGUID: False; DefaultValue: 'TJcl%sHashSet'),\r\n {HashSetIteratorClassName} (IsGUID: False; DefaultValue: 'TJcl%sHashSetIterator'),\r\n {TreeIteratorInterfaceName} (IsGUID: False; DefaultValue: 'IJcl%sTreeIterator'),\r\n {TreeIteratorInterfaceGUID} (IsGUID: True; DefaultValue: ''),\r\n {TreeInterfaceName} (IsGUID: False; DefaultValue: 'IJcl%sTree'),\r\n {TreeInterfaceGUID} (IsGUID: True; DefaultValue: ''),\r\n {TreeNodeClassName} (IsGUID: False; DefaultValue: 'TJcl%sTreeNode'),\r\n {TreeClassName} (IsGUID: False; DefaultValue: 'TJcl%sTree'),\r\n {TreeBaseIteratorClassName} (IsGUID: False; DefaultValue: 'TJcl%sTreeIterator'),\r\n {TreePreOrderIteratorClassName} (IsGUID: False; DefaultValue: 'TJclPreOrder%sTreeIterator'),\r\n {TreePostOrderIteratorClassName} (IsGUID: False; DefaultValue: 'TJclPostOrder%sTreeIterator'),\r\n {QueueInterfaceName} (IsGUID: False; DefaultValue: 'IJcl%sQueue'),\r\n {QueueInterfaceGUID} (IsGUID: True; DefaultValue: ''),\r\n {QueueClassName} (IsGUID: False; DefaultValue: 'TJcl%sQueue'),\r\n {SortedSetInterfaceName} (IsGUID: False; DefaultValue: 'IJcl%sSortedSet'),\r\n {SortedSetInterfaceGUID} (IsGUID: True; DefaultValue: ''),\r\n {StackInterfaceName} (IsGUID: False; DefaultValue: 'IJcl%sStack'),\r\n {StackInterfaceGUID} (IsGUID: True; DefaultValue: ''),\r\n {StackClassName} (IsGUID: False; DefaultValue: 'TJcl%sStack') );\r\n\r\n KeyAttributeInfos: array [TKeyAttributeID] of TTypeAttributeID =\r\n ( {KeyTypeName} taTypeName,\r\n {KeyOwnershipParameterName} taOwnershipParameterName,\r\n {KeyConstKeyword} taConstKeyword,\r\n {KeyParameterName} taParameterName,\r\n {KeyDefaultValue} taDefaultValue,\r\n {KeySimpleCompareFunctionName} taSimpleCompareFunctionName,\r\n {KeySimpleEqualityCompareFunctionName} taSimpleEqualityCompareFunctionName,\r\n {KeySimpleHashConvertFunctionName} taSimpleHashConvertFunctionName,\r\n {KeyBaseContainerClassName} taBaseContainerClassName,\r\n {KeyIteratorInterfaceName} taIteratorInterfaceName,\r\n {KeySetInterfaceName} taSetInterfaceName,\r\n {KeyArraySetClassName} taArraySetClassName);\r\n\r\n ValueAttributeInfos: array [TValueAttributeID] of TTypeAttributeID =\r\n ( {ValueTypeName} taTypeName,\r\n {ValueOwnershipParameterName} taOwnershipParameterName,\r\n {ValueConstKeyword} taConstKeyword,\r\n {ValueDefaultValue} taDefaultValue,\r\n {ValueSimpleCompareFunctionName} taSimpleCompareFunctionName,\r\n {ValueSimpleEqualityCompareFunctionName} taSimpleEqualityCompareFunctionName,\r\n {ValueBaseContainerClassName} taBaseContainerClassName,\r\n {ValueCollectionInterfaceName} taCollectionInterfaceName,\r\n {ValueArrayListClassName} taArrayListClassName);\r\n\r\n MapAttributeInfos: array [TMapAttributeID] of TTypeAttributeInfo =\r\n ( {MapInterfaceName} (IsGUID: False; DefaultValue: 'TJcl%s%sMap'),\r\n {MapInterfaceGUID} (IsGUID: True; DefaultValue: ''),\r\n {MapInterfaceAncestorName} (IsGUID: False; DefaultValue: 'IJclBaseContainer'),\r\n {SortedMapInterfaceName} (IsGUID: False; DefaultValue: 'TJcl%s%sSortedMap'),\r\n {SortedMapInterfaceGUID} (IsGUID: True; DefaultValue: ''),\r\n {MapAncestorClassName} (IsGUID: False; DefaultValue: 'TJclContainer'),\r\n {HashMapEntryTypeName} (IsGUID: False; DefaultValue: 'TJcl%s%sHashEntry'),\r\n {HashMapEntryArrayTypeName} (IsGUID: False; DefaultValue: 'TJcl%s%sHashEntryArray'),\r\n {HashMapBucketTypeName} (IsGUID: False; DefaultValue: 'TJcl%s%sHashBucket'),\r\n {HashMapClassName} (IsGUID: False; DefaultValue: 'TJcl%s%sHashMap'),\r\n {SortedMapEntryTypeName} (IsGUID: False; DefaultValue: 'TJcl%s%sSortedEntry'),\r\n {SortedMapEntryArrayTypeName} (IsGUID: False; DefaultValue: 'TJcl%s%sSortedEntryArray'),\r\n {SortedMapClassName} (IsGUID: False; DefaultValue: 'TJcl%s%sSortedMap') );\r\n\r\ntype\r\n EJclContainerException = class(EJclError);\r\n\r\n TCodeLocation = (clDefault, clAtCursor, clInterface, clImplementation);\r\n\r\n TJclMacroParams = class\r\n private\r\n // FCodeLocation: TCodeLocation;\r\n // FCodeUnit: string;\r\n protected\r\n // function CodeLocation: string; virtual;\r\n // function CodeUnit: string; virtual;\r\n public\r\n function IsDefault: Boolean; virtual;\r\n procedure ResetDefault(Value: Boolean); virtual;\r\n\r\n // this function returns some text to be emitted at the beginning of the macro\r\n function GetMacroHeader: string; virtual;\r\n // this function returns some text to be emitted at the end of the macro\r\n function GetMacroFooter: string; virtual;\r\n\r\n // procedure InterfaceUnitDependencies(Units: TStrings); virtual;\r\n // procedure ImplementationUnitDependencies(Units: TStrings); virtual;\r\n\r\n // property CodeLocation: TCodeLocation read GetCodeLocation write FCodeLocation;\r\n // property CodeUnit: string read GetCodeUnit write FCodeUnit;\r\n end;\r\n\r\n TJclInterfaceParams = class(TJclMacroParams)\r\n public\r\n // this function returns the attribute ID when alias declarations should be emitted\r\n // taTypeName is ignored\r\n function AliasAttributeIDs: TAllTypeAttributeIDs; virtual;\r\n end;\r\n\r\n TJclInterfaceParamsClass = class of TJclInterfaceParams;\r\n\r\n TJclImplementationParams = class(TJclMacroParams)\r\n private\r\n FInterfaceParams: TJclInterfaceParams;\r\n public\r\n constructor Create(AInterfaceParams: TJclInterfaceParams);\r\n property InterfaceParams: TJclInterfaceParams read FInterfaceParams;\r\n end;\r\n\r\n TJclImplementationParamsClass = class of TJclImplementationParams;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jcl.svn.sourceforge.net/svnroot/jcl/tags/JCL-2.4-Build4571/jcl/source/common/JclPreProcessorContainerTypes.pas $';\r\n Revision: '$Revision: 3747 $';\r\n Date: '$Date: 2012-02-24 12:27:42 +0100 (ven. 24 févr. 2012) $';\r\n LogPath: 'JCL\\source\\common';\r\n Extra: '';\r\n Data: nil\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\n//=== { TJclMacroParams } ====================================================\r\n\r\nfunction TJclMacroParams.GetMacroFooter: string;\r\nbegin\r\n // override to customize\r\n Result := '';\r\nend;\r\n\r\nfunction TJclMacroParams.GetMacroHeader: string;\r\nbegin\r\n // override to customize\r\n Result := '';\r\nend;\r\n\r\nfunction TJclMacroParams.IsDefault: Boolean;\r\nbegin\r\n // default if no properties are marked as \"stored\"\r\n Result := True;\r\nend;\r\n\r\nprocedure TJclMacroParams.ResetDefault(Value: Boolean);\r\nbegin\r\n // override to customize\r\nend;\r\n\r\n//=== { TJclInterfaceParams } ================================================\r\n\r\nfunction TJclInterfaceParams.AliasAttributeIDs: TAllTypeAttributeIDs;\r\nbegin\r\n Result := [];\r\nend;\r\n\r\n//=== { TJclImplementationParams } ===========================================\r\n\r\nconstructor TJclImplementationParams.Create(AInterfaceParams: TJclInterfaceParams);\r\nbegin\r\n inherited Create;\r\n FInterfaceParams := AInterfaceParams;\r\nend;\r\n\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n\r\n" }, { "path": "External/Jedi/Jcl/source/common/JclPreProcessorExcDlgTemplates.pas", "content": "{**************************************************************************************************}\r\n{ }\r\n{ Project JEDI Code Library (JCL) }\r\n{ }\r\n{ The contents of this file are subject to the Mozilla Public License Version 1.1 (the \"License\"); }\r\n{ you may not use this file except in compliance with the License. You may obtain a copy of the }\r\n{ License at http://www.mozilla.org/MPL/ }\r\n{ }\r\n{ Software distributed under the License is distributed on an \"AS IS\" basis, WITHOUT WARRANTY OF }\r\n{ ANY KIND, either express or implied. See the License for the specific language governing rights }\r\n{ and limitations under the License. }\r\n{ }\r\n{ The Original Code is JclOtaExcDlgRepository.pas. }\r\n{ }\r\n{ The Initial Developer of the Original Code is Florent Ouchet }\r\n{ }\r\n{ Portions created by Florent Ouchet are Copyright (C) of Florent Ouchet. All rights reserved. }\r\n{ }\r\n{ Contributors: }\r\n{ }\r\n{**************************************************************************************************}\r\n{ }\r\n{ Last modified: $Date:: 2012-02-23 22:12:12 +0100 (jeu. 23 févr. 2012) $ }\r\n{ Revision: $Rev:: 3741 $ }\r\n{ Author: $Author:: outchy $ }\r\n{ }\r\n{**************************************************************************************************}\r\n\r\nunit JclPreProcessorExcDlgTemplates;\r\n\r\ninterface\r\n\r\n{$I jcl.inc}\r\n\r\nuses\r\n {$IFDEF HAS_UNITSCOPE}\r\n System.Classes,\r\n {$ELSE ~HAS_UNITSCOPE}\r\n Classes,\r\n {$ENDIF ~HAS_UNITSCOPE}\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n JclIDEUtils,\r\n JclPreProcessorTemplates;\r\n\r\ntype\r\n TJclExcDlgParams = class(TJclTemplateParams)\r\n private\r\n FHookDll: Boolean;\r\n FFileName: string;\r\n FCodeDetails: Boolean;\r\n FModuleName: Boolean;\r\n FModuleOffset: Boolean;\r\n FDelayedTrace: Boolean;\r\n FFormName: string;\r\n FLogFile: Boolean;\r\n FLogFileName: string;\r\n FAutoSaveWorkingDirectory: Boolean;\r\n FAutoSaveApplicationDirectory: Boolean;\r\n FAutoSaveDesktopDirectory: Boolean;\r\n FLogSaveDialog: Boolean;\r\n FAddressOffset: Boolean;\r\n FVirtualAddress: Boolean;\r\n FActivePersonality: TJclBorPersonality;\r\n FLanguage: TJclBorPersonality;\r\n FLanguages: TJclBorPersonalities;\r\n FRawData: Boolean;\r\n FSendEMail: Boolean;\r\n FEMailAddress: string;\r\n FFormAncestor: string;\r\n FModalDialog: Boolean;\r\n FSizeableDialog: Boolean;\r\n FEMailSubject: string;\r\n FDesigner: TJclBorDesigner;\r\n FModuleList: Boolean;\r\n FUnitVersioning: Boolean;\r\n FOSInfo: Boolean;\r\n FActiveControls: Boolean;\r\n FDisableIfDebuggerAttached: Boolean;\r\n FStackList: Boolean;\r\n FAutoScrollBars: Boolean;\r\n FCatchMainThread: Boolean;\r\n FAllThreads: Boolean;\r\n FAllRegisteredThreads: Boolean;\r\n FMainExceptionThreads: Boolean;\r\n FExceptionThread: Boolean;\r\n FMainThread: Boolean;\r\n FTraceEAbort: Boolean;\r\n FIgnoredExceptions: TStrings;\r\n FIgnoredExceptionsIndex: Integer;\r\n FTraceAllExceptions: Boolean;\r\n function GetIgnoredExceptionsCount: Integer;\r\n function GetReportAllThreads: Boolean;\r\n function GetReportExceptionThread: Boolean;\r\n function GetReportMainThread: Boolean;\r\n function GetIgnoredException: string;\r\n public\r\n constructor Create; reintroduce;\r\n destructor Destroy; override; \r\n published\r\n // file options\r\n property Language: TJclBorPersonality read FLanguage write FLanguage;\r\n property Languages: TJclBorPersonalities read FLanguages write FLanguages;\r\n property ActivePersonality: TJclBorPersonality read FActivePersonality\r\n write FActivePersonality;\r\n property FileName: string read FFileName write FFileName;\r\n property FormName: string read FFormName write FFormName;\r\n property FormAncestor: string read FFormAncestor write FFormAncestor;\r\n property Designer: TJclBorDesigner read FDesigner write FDesigner;\r\n // form options\r\n property ModalDialog: Boolean read FModalDialog write FModalDialog;\r\n property SendEMail: Boolean read FSendEMail write FSendEMail;\r\n property EMailAddress: string read FEMailAddress write FEMailAddress;\r\n property EMailSubject: string read FEMailSubject write FEMailSubject;\r\n property SizeableDialog: Boolean read FSizeableDialog write FSizeableDialog;\r\n property AutoScrollBars: Boolean read FAutoScrollBars write FAutoScrollBars;\r\n // system options\r\n property DelayedTrace: Boolean read FDelayedTrace write FDelayedTrace;\r\n property HookDll: Boolean read FHookDll write FHookDll;\r\n property OSInfo: Boolean read FOSInfo write FOSInfo;\r\n property ModuleList: Boolean read FModuleList write FModuleList;\r\n property UnitVersioning: Boolean read FUnitVersioning write FUnitVersioning;\r\n property ActiveControls: Boolean read FActiveControls write FActiveControls;\r\n property CatchMainThread: Boolean read FCatchMainThread write FCatchMainThread;\r\n property DisableIfDebuggerAttached: Boolean read FDisableIfDebuggerAttached write FDisableIfDebuggerAttached;\r\n // log options\r\n property LogFile: Boolean read FLogFile write FLogFile;\r\n property LogFileName: string read FLogFileName write FLogFileName;\r\n property AutoSaveWorkingDirectory: Boolean read FAutoSaveWorkingDirectory write FAutoSaveWorkingDirectory;\r\n property AutoSaveApplicationDirectory: Boolean read FAutoSaveApplicationDirectory write FAutoSaveApplicationDirectory;\r\n property AutoSaveDesktopDirectory: Boolean read FAutoSaveDesktopDirectory write FAutoSaveDesktopDirectory;\r\n property LogSaveDialog: Boolean read FLogSaveDialog write FLogSaveDialog;\r\n // ignored exceptions\r\n property TraceAllExceptions: Boolean read FTraceAllExceptions\r\n write FTraceAllExceptions;\r\n property TraceEAbort: Boolean read FTraceEAbort write FTraceEAbort;\r\n property IgnoredException: string read GetIgnoredException;\r\n property IgnoredExceptions: TStrings read FIgnoredExceptions write FIgnoredExceptions;\r\n property IgnoredExceptionsIndex: Integer read FIgnoredExceptionsIndex write FIgnoredExceptionsIndex;\r\n property IgnoredExceptionsCount: Integer read GetIgnoredExceptionsCount;\r\n // trace options\r\n property StackList: Boolean read FStackList write FStackList;\r\n property RawData: Boolean read FRawData write FRawData;\r\n property ModuleName: Boolean read FModuleName write FModuleName;\r\n property ModuleOffset: Boolean read FModuleOffset write FModuleOffset;\r\n // thread options (mutually exclusives)\r\n property AllThreads: Boolean read FAllThreads write FAllThreads;\r\n property AllRegisterThreads: Boolean read FAllRegisteredThreads write FAllRegisteredThreads;\r\n property MainExceptionThreads: Boolean read FMainExceptionThreads write FMainExceptionThreads;\r\n property ExceptionThread: Boolean read FExceptionThread write FExceptionThread;\r\n property MainThread: Boolean read FMainThread write FMainThread;\r\n // composite properties\r\n property ReportMainThread: Boolean read GetReportMainThread;\r\n property ReportAllThreads: Boolean read GetReportAllThreads;\r\n property ReportExceptionThread: Boolean read GetReportExceptionThread; \r\n //property AddressOffset: Boolean read FAddressOffset write FAddressOffset;\r\n property CodeDetails: Boolean read FCodeDetails write FCodeDetails;\r\n property VirtualAddress: Boolean read FVirtualAddress write FVirtualAddress;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jcl.svn.sourceforge.net/svnroot/jcl/tags/JCL-2.4-Build4571/jcl/source/common/JclPreProcessorExcDlgTemplates.pas $';\r\n Revision: '$Revision: 3741 $';\r\n Date: '$Date: 2012-02-23 22:12:12 +0100 (jeu. 23 févr. 2012) $';\r\n LogPath: 'JCL\\source\\common';\r\n Extra: '';\r\n Data: nil\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\n//=== { TJclExcDlgParams } ===================================================\r\n\r\nconstructor TJclExcDlgParams.Create;\r\nbegin\r\n inherited Create;\r\n\r\n FHookDll := True;\r\n FLanguage := bpUnknown;\r\n FLanguages := [bpUnknown];\r\n FFileName := '';\r\n FCodeDetails := True;\r\n FModuleName := True;\r\n FModuleOffset := False;\r\n FDelayedTrace := True;\r\n FFormName := 'ExceptionDialog';\r\n FFormAncestor := 'TForm';\r\n FLogFile := False;\r\n FLogFileName := 'ExtractFileName(Application.ExeName) + ''-exception-'' + FormatDateTime(''yyyy-mm-dd'', Date) + ''.log''';\r\n FAutoSaveWorkingDirectory := False;\r\n FAutoSaveApplicationDirectory := False;\r\n FAutoSaveDesktopDirectory := False;\r\n FLogSaveDialog := False;\r\n FAddressOffset := True;\r\n FVirtualAddress := False;\r\n FActivePersonality := bpUnknown;\r\n FRawData := False;\r\n FSendEMail := False;\r\n FEMailAddress := '';\r\n FEMailSubject := '';\r\n FModalDialog := True;\r\n FSizeableDialog := False;\r\n FDesigner := bdVCL;\r\n FModuleList := True;\r\n FUnitVersioning := True;\r\n FOSInfo := True;\r\n FActiveControls := True;\r\n FDisableIfDebuggerAttached := False;\r\n FStackList := True;\r\n FAutoScrollBars := True;\r\n FCatchMainThread := False;\r\n FTraceEAbort := False;\r\n FTraceAllExceptions := False;\r\n FIgnoredExceptions := TStringList.Create;\r\n FAllThreads := True;\r\n FAllRegisteredThreads := False;\r\n FMainExceptionThreads := False;\r\n FExceptionThread := False;\r\n FMainThread := False;\r\nend;\r\n\r\ndestructor TJclExcDlgParams.Destroy;\r\nbegin\r\n FIgnoredExceptions.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJclExcDlgParams.GetIgnoredException: string;\r\nbegin\r\n Result := FIgnoredExceptions.Strings[FIgnoredExceptionsIndex];\r\nend;\r\n\r\nfunction TJclExcDlgParams.GetIgnoredExceptionsCount: Integer;\r\nbegin\r\n Result := FIgnoredExceptions.Count;\r\nend;\r\n\r\nfunction TJclExcDlgParams.GetReportAllThreads: Boolean;\r\nbegin\r\n Result := FAllThreads or FAllRegisteredThreads;\r\nend;\r\n\r\nfunction TJclExcDlgParams.GetReportExceptionThread: Boolean;\r\nbegin\r\n Result := FExceptionThread or FMainExceptionThreads;\r\nend;\r\n\r\nfunction TJclExcDlgParams.GetReportMainThread: Boolean;\r\nbegin\r\n Result := FMainThread or FMainExceptionThreads or FAllThreads or FAllRegisteredThreads;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jcl/source/common/JclPreProcessorHashMapsTemplates.pas", "content": "{**************************************************************************************************}\r\n{ }\r\n{ Project JEDI Code Library (JCL) }\r\n{ }\r\n{ The contents of this file are subject to the Mozilla Public License Version 1.1 (the \"License\"); }\r\n{ you may not use this file except in compliance with the License. You may obtain a copy of the }\r\n{ License at http://www.mozilla.org/MPL/ }\r\n{ }\r\n{ Software distributed under the License is distributed on an \"AS IS\" basis, WITHOUT WARRANTY OF }\r\n{ ANY KIND, either express or implied. See the License for the specific language governing rights }\r\n{ and limitations under the License. }\r\n{ }\r\n{ The Original Code is JclHashMapsTemplates.pas. }\r\n{ }\r\n{ The Initial Developer of the Original Code is Florent Ouchet }\r\n{ }\r\n{ Portions created by Florent Ouchet are Copyright (C) of Florent Ouchet. All rights reserved. }\r\n{ }\r\n{ Contributors: }\r\n{ }\r\n{**************************************************************************************************}\r\n{ }\r\n{ Last modified: $Date:: 2012-02-24 12:27:42 +0100 (ven. 24 févr. 2012) $ }\r\n{ Revision: $Rev:: 3747 $ }\r\n{ Author: $Author:: outchy $ }\r\n{ }\r\n{**************************************************************************************************}\r\n\r\nunit JclPreProcessorHashMapsTemplates;\r\n\r\ninterface\r\n\r\n{$I jcl.inc}\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n JclPreProcessorContainerTypes,\r\n JclPreProcessorContainerTemplates,\r\n JclPreProcessorContainer2DTemplates;\r\n\r\ntype\r\n (* JCLHASHMAPTYPESINT(ENTRYTYPENAME, ENTRYARRAYTYPENAME, BUCKETTYPENAME, KEYTYPENAME, VALUETYPENAME) *)\r\n TJclHashMapTypeIntParams = class(TJclMapInterfaceParams)\r\n public\r\n function AliasAttributeIDs: TAllTypeAttributeIDs; override;\r\n published\r\n property EntryTypeName: string index maHashMapEntryTypeName read GetMapAttribute write SetMapAttribute stored IsMapAttributeStored;\r\n property EntryArrayTypeName: string index maHashMapEntryArrayTypeName read GetMapAttribute write SetMapAttribute stored IsMapAttributeStored;\r\n property BucketTypeName: string index maHashMapBucketTypeName read GetMapAttribute write SetMapAttribute stored IsMapAttributeStored;\r\n property KeyTypeName: string index kaKeyTypeName read GetKeyAttribute write SetKeyAttribute stored False;\r\n property ValueTypeName: string index vaValueTypeName read GetValueAttribute write SetValueAttribute stored False;\r\n end;\r\n\r\n (* JCLHASHMAPINT(BUCKETTYPENAME, SELFCLASSNAME, ANCESTORNAME, MAPINTERFACENAME, KEYSETINTERFACENAME,\r\n VALUECOLLECTIONINTERFACENAME, INTERFACEADDITIONAL, SECTIONADDITIONAL,\r\n KEYOWNERSHIPDECLARATION, VALUEOWNERSHIPDECLARATION, KEYCONSTKEYWORD,\r\n KEYTYPENAME, VALUECONSTKEYWORD, VALUETYPENAME) *)\r\n TJclHashMapIntParams = class(TJclMapClassInterfaceParams)\r\n protected\r\n // function CodeUnit: string; override;\r\n function GetComparisonSectionAdditional: string; override;\r\n public\r\n function AliasAttributeIDs: TAllTypeAttributeIDs; override;\r\n published\r\n property BucketTypeName: string index maHashMapBucketTypeName read GetMapAttribute write SetMapAttribute stored False;\r\n property SelfClassName: string index maHashMapClassName read GetMapAttribute write SetMapAttribute stored IsMapAttributeStored;\r\n property AncestorName: string index maMapAncestorClassName read GetMapAttribute write SetMapAttribute stored False;\r\n property MapInterfaceName: string index maMapInterfaceName read GetMapAttribute write SetMapAttribute stored False;\r\n property KeySetInterfaceName: string index kaKeySetInterfaceName read GetKeyAttribute write SetKeyAttribute stored False;\r\n property ValueCollectionInterfaceName: string index vaValueCollectionInterfaceName read GetValueAttribute write SetValueAttribute stored False;\r\n property InterfaceAdditional;\r\n property SectionAdditional;\r\n property KeyOwnershipDeclaration;\r\n property ValueOwnershipDeclaration;\r\n property KeyConstKeyword: string index kaKeyConstKeyword read GetKeyAttribute write SetKeyAttribute stored False;\r\n property KeyTypeName;\r\n property ValueConstKeyword: string index vaValueConstKeyword read GetValueAttribute write SetValueAttribute stored False;\r\n property ValueTypeName;\r\n end;\r\n\r\n (* JCLHASHMAPTYPESIMP(ENTRYARRAYTYPENAME, BUCKETTYPENAME, KEYDEFAULT, VALUEDEFAULT) *)\r\n TJclHashMapTypeImpParams = class(TJclMapImplementationParams)\r\n published\r\n property EntryArrayTypeName: string index maHashMapEntryArrayTypeName read GetMapAttribute write SetMapAttribute stored False;\r\n property BucketTypeName: string index maHashMapBucketTypeName read GetMapAttribute write SetMapAttribute stored False;\r\n property KeyDefault: string index kaKeyDefaultValue read GetKeyAttribute write SetKeyAttribute stored False;\r\n property ValueDefault: string index vaValueDefaultValue read GetValueAttribute write SetValueAttribute stored False;\r\n end;\r\n\r\n (* JCLHASHMAPIMP(SELFCLASSNAME, BUCKETTYPENAME,\r\n MAPINTERFACENAME, KEYSETINTERFACENAME, KEYITRINTERFACENAME, VALUECOLLECTIONINTERFACENAME,\r\n KEYOWNERSHIPDECLARATION, VALUEOWNERSHIPDECLARATION, OWNERSHIPASSIGNMENTS,\r\n KEYCONSTKEYWORD, KEYTYPENAME, KEYDEFAULT, VALUECONSTKEYWORD, VALUETYPENAME, VALUEDEFAULT,\r\n CREATEKEYSET, CREATEVALUECOLLECTION) *)\r\n TJclHashMapImpParams = class(TJclMapClassImplementationParams)\r\n protected\r\n // function CodeUnit: string; override;\r\n public\r\n function GetConstructorParameters: string; override;\r\n function GetMacroFooter: string; override;\r\n function GetSelfClassName: string; override;\r\n published\r\n property SelfClassName: string index maHashMapClassName read GetMapAttribute write SetMapAttribute stored False;\r\n property AncestorClassName: string index maMapAncestorClassName read GetMapAttribute write SetMapAttribute stored False;\r\n property BucketTypeName: string index maHashMapBucketTypeName read GetMapAttribute write SetMapAttribute stored False;\r\n property MapInterfaceName: string index maMapInterfaceName read GetMapAttribute write SetMapAttribute stored False;\r\n property KeySetInterfaceName: string index kaKeySetInterfaceName read GetKeyAttribute write SetKeyAttribute stored False;\r\n property KeyArraySetClassName;\r\n property KeyItrInterfaceName: string index kaKeyIteratorInterfaceName read GetKeyAttribute write SetKeyAttribute stored False;\r\n property ValueCollectionInterfaceName: string index vaValueCollectionInterfaceName read GetValueAttribute write SetValueAttribute stored False;\r\n property ValueArrayListClassName;\r\n property KeyOwnershipDeclaration;\r\n property ValueOwnershipDeclaration;\r\n property OwnershipAssignments;\r\n property KeyConstKeyword: string index kaKeyConstKeyword read GetKeyAttribute write SetKeyAttribute stored False;\r\n property KeyParameterName: string index kaKeyParameterName read GetKeyAttribute write SetKeyAttribute stored False;\r\n property KeyTypeName;\r\n property KeyDefault;\r\n property KeySimpleEqualityCompareFunctionName: string index kaKeySimpleEqualityCompareFunctionName read GetKeyAttribute write SetKeyAttribute stored False;\r\n property KeySimpleHashConvertFunctionName: string index kaKeySimpleHashConvertFunctionName read GetKeyAttribute write SetKeyAttribute stored False;\r\n property KeyBaseContainer: string index kaKeyBaseContainerClassName read GetKeyAttribute write SetKeyAttribute stored False;\r\n property ValueConstKeyword: string index vaValueConstKeyword read GetValueAttribute write SetValueAttribute stored False;\r\n property ValueTypeName;\r\n property ValueDefault;\r\n property ValueSimpleEqualityCompareFunctionName: string index vaValueSimpleEqualityCompareFunctionName read GetValueAttribute write SetValueAttribute stored False;\r\n property ValueBaseContainerClassName: string index vaValueBaseContainerClassName read GetValueAttribute write SetValueAttribute stored False;\r\n property CreateKeySet;\r\n property CreateValueCollection;\r\n property MacroFooter;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jcl.svn.sourceforge.net/svnroot/jcl/tags/JCL-2.4-Build4571/jcl/source/common/JclPreProcessorHashMapsTemplates.pas $';\r\n Revision: '$Revision: 3747 $';\r\n Date: '$Date: 2012-02-24 12:27:42 +0100 (ven. 24 févr. 2012) $';\r\n LogPath: 'JCL\\source\\common';\r\n Extra: '';\r\n Data: nil\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n {$IFDEF HAS_UNITSCOPE}\r\n System.SysUtils,\r\n {$ELSE ~HAS_UNITSCOPE}\r\n SysUtils,\r\n {$ENDIF ~HAS_UNITSCOPE}\r\n JclStrings;\r\n\r\nprocedure RegisterJclContainers;\r\nbegin\r\n RegisterContainerParams('JCLHASHMAPTYPESINT', TJclHashMapTypeIntParams);\r\n RegisterContainerParams('JCLHASHMAPTYPESIMP', TJclHashMapTypeImpParams, TJclHashMapTypeIntParams);\r\n RegisterContainerParams('JCLHASHMAPINT', TJclHashMapIntParams);\r\n RegisterContainerParams('JCLHASHMAPIMP', TJclHashMapImpParams, TJclHashMapIntParams);\r\nend;\r\n\r\n//=== { TJclHashMapTypeIntParams } ===========================================\r\n\r\nfunction TJclHashMapTypeIntParams.AliasAttributeIDs: TAllTypeAttributeIDs;\r\nbegin\r\n Result := [maHashMapEntryTypeName, maHashMapBucketTypeName];\r\nend;\r\n\r\n//=== { TJclHashMapIntParams } ===============================================\r\n\r\nfunction TJclHashMapIntParams.AliasAttributeIDs: TAllTypeAttributeIDs;\r\nbegin\r\n Result := [maHashMapClassName];\r\nend;\r\n\r\nfunction TJclHashMapIntParams.GetComparisonSectionAdditional: string;\r\nbegin\r\n Result := '';\r\n if AncestorName <> MapInfo.KeyTypeInfo.TypeAttributes[taBaseContainerClassName] then\r\n begin\r\n Result := Format('%s function Hash(%s%s: %s): Integer;',\r\n [Result, MapInfo.KeyTypeInfo.TypeAttributes[taConstKeyword],\r\n MapInfo.KeyTypeInfo.TypeAttributes[taParameterName], KeyTypeName]);\r\n if AncestorName <> 'TJclAbstractContainerBase' then\r\n Result := Result + ' reintroduce;' + NativeLineBreak\r\n else\r\n Result := Result + NativeLineBreak;\r\n end;\r\n Result := Format('%s function KeysEqual(%sA, B: %s): Boolean;' + NativeLineBreak +\r\n ' function ValuesEqual(%sA, B: %s): Boolean;',\r\n [Result, KeyConstKeyword, KeyTypeName, ValueConstKeyword, ValueTypeName]);\r\nend;\r\n\r\n//=== { TJclHashMapImpParams } ===============================================\r\n\r\nfunction TJclHashMapImpParams.GetConstructorParameters: string;\r\nbegin\r\n Result := 'FCapacity';\r\nend;\r\n\r\nfunction TJclHashMapImpParams.GetMacroFooter: string;\r\nvar\r\n FuncName: string;\r\nbegin\r\n Result := inherited GetMacroFooter;\r\n if (FMacroFooter = '') and MapInfo.KnownMap then\r\n begin\r\n if AncestorClassName <> KeyBaseContainer then\r\n begin\r\n Result := Format('%s' + NativeLineBreak +\r\n 'function %s.Hash(%s%s: %s): Integer;' + NativeLineBreak +\r\n 'begin' + NativeLineBreak +\r\n ' Result := %s(%s);' + NativeLineBreak +\r\n 'end;' + NativeLineBreak,\r\n [Result, SelfClassName, KeyConstKeyword, KeyParameterName, KeyTypeName,\r\n KeySimpleHashConvertFunctionName, KeyParameterName]);\r\n end;\r\n\r\n if AncestorClassName = KeyBaseContainer then\r\n FuncName := 'ItemsEqual'\r\n else\r\n FuncName := KeySimpleEqualityCompareFunctionName;\r\n\r\n Result := Format('%s' + NativeLineBreak +\r\n 'function %s.KeysEqual(%sA, B: %s): Boolean;' + NativeLineBreak +\r\n 'begin' + NativeLineBreak +\r\n ' Result := %s(A, B);' + NativeLineBreak +\r\n 'end;' + NativeLineBreak,\r\n [Result, SelfClassName, KeyConstKeyword, KeyTypeName, FuncName]);\r\n\r\n if AncestorClassName = ValueBaseContainerClassName then\r\n FuncName := 'ItemsEqual'\r\n else\r\n FuncName := ValueSimpleEqualityCompareFunctionName;\r\n\r\n Result := Format('%s' + NativeLineBreak +\r\n 'function %s.ValuesEqual(%sA, B: %s): Boolean;' + NativeLineBreak +\r\n 'begin' + NativeLineBreak +\r\n ' Result := %s(A, B);' + NativeLineBreak +\r\n 'end;' + NativeLineBreak,\r\n [Result, SelfClassName, ValueConstKeyword, ValueTypeName, FuncName]);\r\n end;\r\nend;\r\n\r\nfunction TJclHashMapImpParams.GetSelfClassName: string;\r\nbegin\r\n Result := SelfClassName;\r\nend;\r\n\r\ninitialization\r\n RegisterJclContainers;\r\n {$IFDEF UNITVERSIONING}\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n {$ENDIF UNITVERSIONING}\r\n\r\nfinalization\r\n {$IFDEF UNITVERSIONING}\r\n UnregisterUnitVersion(HInstance);\r\n {$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n\r\n" }, { "path": "External/Jedi/Jcl/source/common/JclPreProcessorHashSetsTemplates.pas", "content": "{**************************************************************************************************}\r\n{ }\r\n{ Project JEDI Code Library (JCL) }\r\n{ }\r\n{ The contents of this file are subject to the Mozilla Public License Version 1.1 (the \"License\"); }\r\n{ you may not use this file except in compliance with the License. You may obtain a copy of the }\r\n{ License at http://www.mozilla.org/MPL/ }\r\n{ }\r\n{ Software distributed under the License is distributed on an \"AS IS\" basis, WITHOUT WARRANTY OF }\r\n{ ANY KIND, either express or implied. See the License for the specific language governing rights }\r\n{ and limitations under the License. }\r\n{ }\r\n{ The Original Code is JclArraySetsTemplates.pas. }\r\n{ }\r\n{ The Initial Developer of the Original Code is Florent Ouchet }\r\n{ }\r\n{ Portions created by Florent Ouchet are Copyright (C) of Florent Ouchet. All rights reserved. }\r\n{ }\r\n{ Contributors: }\r\n{ }\r\n{**************************************************************************************************}\r\n{ }\r\n{ Last modified: $Date:: 2012-02-23 21:46:07 +0100 (jeu. 23 févr. 2012) $ }\r\n{ Revision: $Rev:: 3740 $ }\r\n{ Author: $Author:: outchy $ }\r\n{ }\r\n{**************************************************************************************************}\r\n\r\nunit JclPreProcessorHashSetsTemplates;\r\n\r\ninterface\r\n\r\n{$I jcl.inc}\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n JclPreProcessorContainerTypes,\r\n JclPreProcessorContainerTemplates,\r\n JclPreProcessorContainer1DTemplates;\r\n\r\ntype\r\n (* JCLHASHSETTYPESINT(BUCKETTYPENAME, TYPENAME) *)\r\n TJclHashSetTypeIntParams = class(TJclContainerInterfaceParams)\r\n public\r\n function AliasAttributeIDs: TAllTypeAttributeIDs; override;\r\n published\r\n property BucketTypeName: string index taHashSetBucketTypeName read GetTypeAttribute write SetTypeAttribute stored IsTypeAttributeStored;\r\n property DynArrayTypeName: string index taDynArrayTypeName read GetTypeAttribute write SetTypeAttribute stored False;\r\n end;\r\n\r\n (* JCLHASHSETINT(SELFCLASSNAME, ANCESTORCLASSNAME, BASECONTAINERINTERFACENAME,\r\n FLATCONTAINERINTERFACENAME, BUCKETTYPENAME,\r\n COLLECTIONINTERFACENAME, SETINTERFACENAME, ITRINTERFACENAME,\r\n EQUALITYCOMPARERINTERFACENAME, HASHCONVERTERINTERFACENAME, INTERFACEADDITIONAL,\r\n SECTIONADDITIONAL, COLLECTIONFLAGS, CONSTKEYWORD, PARAMETERNAME, TYPENAME) *)\r\n TJclHashSetIntParams = class(TJclCollectionInterfaceParams)\r\n protected\r\n // function CodeUnit: string; override;\r\n public\r\n function AliasAttributeIDs: TAllTypeAttributeIDs; override;\r\n published\r\n property SelfClassName: string index taHashSetClassName read GetTypeAttribute write SetTypeAttribute stored IsTypeAttributeStored;\r\n property AncestorClassName;\r\n property BaseContainerInterfaceName: string index taContainerInterfaceName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property FlatContainerInterfaceName: string index taFlatContainerInterfaceName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property BucketTypeName: string index taHashSetBucketTypeName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property CollectionInterfaceName: string index taCollectionInterfaceName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property EqualityComparerInterfaceName: string index taEqualityComparerInterfaceName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property HashConverterInterfaceName: string index taHashConverterInterfaceName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property ListInterfaceName: string index taListInterfaceName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property ArrayInterfaceName: string index taArrayInterfaceName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property SetInterfaceName: string index taSetInterfaceName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property ItrInterfaceName: string index taIteratorInterfaceName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property InterfaceAdditional;\r\n property SectionAdditional;\r\n property CollectionFlags;\r\n property ConstKeyword: string index taConstKeyword read GetTypeAttribute write SetTypeAttribute stored False;\r\n property ParameterName: string index taParameterName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property TypeName: string index taTypeName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property OwnershipDeclaration;\r\n end;\r\n\r\n (* JCLHASHSETITRINT(SELFCLASSNAME, ITRINTERFACENAME, HASHSETCLASSNAME,\r\n CONSTKEYWORD, PARAMETERNAME, TYPENAME, GETTERFUNCTIONNAME, SETTERPROCEDURENAME) *)\r\n TJclHashSetItrIntParams = class(TJclClassInterfaceParams)\r\n protected\r\n // function CodeUnit: string; override;\r\n public\r\n function AliasAttributeIDs: TAllTypeAttributeIDs; override;\r\n published\r\n property SelfClassName: string index taHashSetIteratorClassName read GetTypeAttribute write SetTypeAttribute stored IsTypeAttributeStored;\r\n property ItrInterfaceName: string index taIteratorInterfaceName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property HashSetClassName: string index taHashSetClassName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property ConstKeyword: string index taConstKeyword read GetTypeAttribute write SetTypeAttribute stored False;\r\n property ParameterName: string index taParameterName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property TypeName: string index taTypeName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property GetterFunctionName: string index taGetterFunctionName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property SetterProcedureName: string index taSetterProcedureName read GetTypeAttribute write SetTypeAttribute stored False;\r\n end;\r\n\r\n (* JCLHASHSETIMP(SELFCLASSNAME, BUCKETTYPENAME, OWNERSHIPDECLARATION, OWNERSHIPPARAMETERNAME,\r\n COLLECTIONINTERFACENAME, ITRCLASSNAME, ITRINTERFACENAME, MOVEARRAYPROCEDURENAME,\r\n CONSTKEYWORD, PARAMETERNAME, TYPENAME, DEFAULTVALUE, RELEASERFUNCTIONNAME) *)\r\n TJclHashSetImpParams = class(TJclCollectionImplementationParams)\r\n protected\r\n // function CodeUnit: string; override;\r\n public\r\n function GetConstructorParameters: string; override;\r\n function GetSelfClassName: string; override;\r\n published\r\n property SelfClassName: string index taHashSetClassName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property BucketTypeName: string index taHashSetBucketTypeName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property OwnershipDeclaration;\r\n property OwnershipParameterName: string index taOwnershipParameterName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property CollectionInterfaceName: string index taCollectionInterfaceName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property ItrClassName: string index taHashSetIteratorClassName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property ItrInterfaceName: string index taIteratorInterfaceName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property MoveArrayProcedureName: string index taMoveArrayProcedureName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property ConstKeyword: string index taConstKeyword read GetTypeAttribute write SetTypeAttribute stored False;\r\n property ParameterName: string index taParameterName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property TypeName: string index taTypeName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property DefaultValue: string index taDefaultValue read GetTypeAttribute write SetTypeAttribute stored False;\r\n property ReleaserFunctionName: string index taReleaserFunctionName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property MacroFooter;\r\n end;\r\n\r\n (* JCLHASHSETITRIMP(SELFCLASSNAME, HASHSETCLASSNAME, BUCKETTYPENAME, ITRINTERFACENAME,\r\n CONSTKEYWORD, PARAMETERNAME, TYPENAME, GETTERFUNCTIONNAME, SETTERPROCEDURENAME) *)\r\n TJclHashSetItrImpParams = class(TJclContainerImplementationParams)\r\n protected\r\n // function CodeUnit: string; override;\r\n published\r\n property SelfClassName: string index taHashSetIteratorClassName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property HashSetClassName: string index taHashSetClassName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property BucketTypeName: string index taHashSetBucketTypeName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property ItrInterfaceName: string index taIteratorInterfaceName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property ConstKeyword: string index taConstKeyword read GetTypeAttribute write SetTypeAttribute stored False;\r\n property ParameterName: string index taParameterName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property TypeName: string index taTypeName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property DefaultValue: string index taDefaultValue read GetTypeAttribute write SetTypeAttribute stored False;\r\n property GetterFunctionName: string index taGetterFunctionName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property SetterProcedureName: string index taSetterProcedureName read GetTypeAttribute write SetTypeAttribute stored False;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jcl.svn.sourceforge.net/svnroot/jcl/tags/JCL-2.4-Build4571/jcl/source/common/JclPreProcessorHashSetsTemplates.pas $';\r\n Revision: '$Revision: 3740 $';\r\n Date: '$Date: 2012-02-23 21:46:07 +0100 (jeu. 23 févr. 2012) $';\r\n LogPath: 'JCL\\source\\common';\r\n Extra: '';\r\n Data: nil\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n {$IFDEF HAS_UNITSCOPE}\r\n System.SysUtils,\r\n {$ELSE ~HAS_UNITSCOPE}\r\n SysUtils,\r\n {$ENDIF ~HAS_UNITSCOPE}\r\n JclStrings;\r\n\r\nprocedure RegisterJclContainers;\r\nbegin\r\n RegisterContainerParams('JCLHASHSETTYPEINT', TJclHashSetTypeIntParams);\r\n RegisterContainerParams('JCLHASHSETINT', TJclHashSetIntParams);\r\n RegisterContainerParams('JCLHASHSETITRINT', TJclHashSetItrIntParams);\r\n RegisterContainerParams('JCLHASHSETIMP', TJclHashSetImpParams, TJclHashSetIntParams);\r\n RegisterContainerParams('JCLHASHSETITRIMP', TJclHashSetItrImpParams, TJclHashSetItrIntParams);\r\nend;\r\n\r\n//=== { TJclHashSetTypeIntParams } ===========================================\r\n\r\nfunction TJclHashSetTypeIntParams.AliasAttributeIDs: TAllTypeAttributeIDs;\r\nbegin\r\n Result := [taHashSetBucketTypeName];\r\nend;\r\n\r\n//=== { TJclHashSetIntParams } ===============================================\r\n\r\nfunction TJclHashSetIntParams.AliasAttributeIDs: TAllTypeAttributeIDs;\r\nbegin\r\n Result := [taHashSetClassName];\r\nend;\r\n\r\n//=== { TJclHashSetItrIntParams } ============================================\r\n\r\nfunction TJclHashSetItrIntParams.AliasAttributeIDs: TAllTypeAttributeIDs;\r\nbegin\r\n Result := [taHashSetIteratorClassName];\r\nend;\r\n\r\n//=== { TJclHashSetImpParams } ===============================================\r\n\r\nfunction TJclHashSetImpParams.GetConstructorParameters: string;\r\nbegin\r\n Result := 'Size';\r\nend;\r\n\r\nfunction TJclHashSetImpParams.GetSelfClassName: string;\r\nbegin\r\n Result := SelfClassName;\r\nend;\r\n\r\ninitialization\r\n RegisterJclContainers;\r\n {$IFDEF UNITVERSIONING}\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n {$ENDIF UNITVERSIONING}\r\n\r\nfinalization\r\n {$IFDEF UNITVERSIONING}\r\n UnregisterUnitVersion(HInstance);\r\n {$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n\r\n" }, { "path": "External/Jedi/Jcl/source/common/JclPreProcessorLexer.pas", "content": "{ **************************************************************************** }\r\n{ }\r\n{ Pascal PreProcessor Lexer }\r\n{ Copyright (c) 2001 Barry Kelly. }\r\n{ barry_j_kelly@hotmail.com }\r\n{ }\r\n{ The contents of this file are subject to the Mozilla Public License }\r\n{ Version 1.1 (the \"License\"); you may not use this file except in }\r\n{ compliance with the License. You may obtain a copy of the License at }\r\n{ http://www.mozilla.org/MPL/ }\r\n{ }\r\n{ Software distributed under the License is distributed on an \"AS IS\" }\r\n{ basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the }\r\n{ License for the specific language governing rights and limitations }\r\n{ under the License. }\r\n{ }\r\n{ The Original Code is PppLexer.pas }\r\n{ }\r\n{ The Initial Developer of the Original Code is Barry Kelly. }\r\n{ Portions created by Barry Kelly are Copyright (C) 2001 }\r\n{ Barry Kelly. All Rights Reserved. }\r\n{ }\r\n{ Contributors: }\r\n{ Robert Rossmair (rrossmair) }\r\n{ Florent Ouchet }\r\n{ }\r\n{ Alternatively, the contents of this file may be used under the terms }\r\n{ of the Lesser GNU Public License (the \"LGPL License\"), in which case }\r\n{ the provisions of LGPL License are applicable instead of those }\r\n{ above. If you wish to allow use of your version of this file only }\r\n{ under the terms of the LPGL License and not to allow others to use }\r\n{ your version of this file under the MPL, indicate your decision by }\r\n{ deleting the provisions above and replace them with the notice and }\r\n{ other provisions required by the LGPL License. If you do not delete }\r\n{ the provisions above, a recipient may use your version of this file }\r\n{ under either the MPL or the LPGL License. }\r\n{ }\r\n{ **************************************************************************** }\r\n{ }\r\n{ Last modified: $Date:: 2011-09-03 00:07:50 +0200 (sam. 03 sept. 2011) $ }\r\n{ Revision: $Rev:: 3599 $ }\r\n{ Author: $Author:: outchy $ }\r\n{ }\r\n{ **************************************************************************** }\r\n{ }\r\n{ JppLexer differs from the original unit in that it provides a separate }\r\n{ token for line breaks, ptEol. That makes it much easier to remove }\r\n{ orphaned line breaks after conditional compilation symbol resolution, }\r\n{ see unit JppParser. }\r\n{ }\r\n{ **************************************************************************** }\r\n\r\nunit JclPreProcessorLexer;\r\n\r\n{$I jcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n {$IFDEF HAS_UNITSCOPE}\r\n System.SysUtils, System.Classes,\r\n {$ELSE ~HAS_UNITSCOPE}\r\n SysUtils, Classes,\r\n {$ENDIF ~HAS_UNITSCOPE}\r\n JclBase, JclStrHashMap, JclStrings;\r\n\r\ntype\r\n TJppToken = (ptEof, ptComment, ptText, ptEol,\r\n ptDefine, ptUndef, ptIfdef, ptIfndef, ptIfopt, ptElse, ptEndif,\r\n ptInclude, ptJppDefineMacro, ptJppExpandMacro, ptJppUndefMacro,\r\n ptJppGetStrValue, ptJppGetIntValue, ptJppGetBoolValue,\r\n ptJppSetStrValue, ptJppSetIntValue, ptJppSetBoolValue, ptJppLoop,\r\n // same as $DEFINE and $UNDEF but they will not be written to the final file\r\n ptJppDefine, ptJppUndef);\r\n\r\n EJppLexerError = class(EJclError);\r\n\r\n TJppLexer = class\r\n private\r\n FBuf: string;\r\n FTokenHash: TStringHashMap;\r\n FCurrPos: PChar;\r\n FCurrLine: Integer;\r\n FCurrTok: TJppToken;\r\n FTokenAsString: string;\r\n FRawComment: string;\r\n FIgnoreUnterminatedStrings: Boolean;\r\n public\r\n constructor Create(const ABuffer: string; AIgnoreUnterminatedStrings: Boolean = False);\r\n destructor Destroy; override;\r\n\r\n procedure Error(const AMsg: string);\r\n procedure NextTok;\r\n procedure Reset;\r\n property CurrTok: TJppToken read FCurrTok;\r\n { TokenAsString is the preprocessor symbol for $IFDEF & $IFNDEF,\r\n and the file name for $I and $INCLUDE, and is the actual text\r\n for ptComment and ptText. }\r\n property TokenAsString: string read FTokenAsString;\r\n { The raw comment for $IFDEF, etc. when TokenAsString becomes the\r\n file name / preprocessor symbol. }\r\n property RawComment: string read FRawComment;\r\n { Do not raise exceptions when strings are not terminated }\r\n property IgnoreUnterminatedStrings: Boolean read FIgnoreUnterminatedStrings write FIgnoreUnterminatedStrings;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jcl.svn.sourceforge.net/svnroot/jcl/tags/JCL-2.4-Build4571/jcl/source/common/JclPreProcessorLexer.pas $';\r\n Revision: '$Revision: 3599 $';\r\n Date: '$Date: 2011-09-03 00:07:50 +0200 (sam. 03 sept. 2011) $';\r\n LogPath: 'JCL\\source\\common';\r\n Extra: '';\r\n Data: nil\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\n{ TJppLexer }\r\n\r\nconstructor TJppLexer.Create(const ABuffer: string; AIgnoreUnterminatedStrings: Boolean);\r\n\r\n procedure AddToken(const AIdent: string; AValue: TJppToken);\r\n var\r\n x: Integer;\r\n begin\r\n x := Ord(AValue);\r\n FTokenHash.Add(AIdent, x);\r\n end;\r\n\r\nbegin\r\n inherited Create;\r\n FIgnoreUnterminatedStrings := AIgnoreUnterminatedStrings;\r\n\r\n FTokenHash := TStringHashMap.Create(CaseInsensitiveTraits, 19);\r\n\r\n AddToken('i', ptInclude);\r\n AddToken('include', ptInclude);\r\n AddToken('ifdef', ptIfdef);\r\n AddToken('ifndef', ptIfndef);\r\n AddToken('ifopt', ptIfopt);\r\n AddToken('else', ptElse);\r\n AddToken('endif', ptEndif);\r\n AddToken('define', ptDefine);\r\n AddToken('undef', ptUndef);\r\n AddToken('jppdefinemacro', ptjppDefineMacro);\r\n AddToken('jppexpandmacro', ptJppExpandMacro);\r\n AddToken('jppundefmacro', ptJppUndefMacro);\r\n AddToken('jppstrvalue', ptJppGetStrValue); // backward compatibility\r\n AddToken('jppintvalue', ptJppGetIntValue); // backward compatibility\r\n AddToken('jppboolvalue', ptJppGetBoolValue); // backward compatibility\r\n AddToken('jppgetstrvalue', ptJppGetStrValue);\r\n AddToken('jppgetintvalue', ptJppGetIntValue);\r\n AddToken('jppgetboolvalue', ptJppGetBoolValue);\r\n AddToken('jppsetstrvalue', ptJppSetStrValue);\r\n AddToken('jppsetintvalue', ptJppSetIntValue);\r\n AddToken('jppsetboolvalue', ptJppSetBoolValue);\r\n AddToken('jpploop', ptJppLoop);\r\n AddToken('jppdefine', ptJppDefine);\r\n AddToken('jppundef', ptJppUndef);\r\n\r\n FBuf := ABuffer;\r\n Reset;\r\nend;\r\n\r\ndestructor TJppLexer.Destroy;\r\nbegin\r\n FTokenHash.Free;\r\n inherited;\r\nend;\r\n\r\nprocedure TJppLexer.Error(const AMsg: string);\r\nbegin\r\n if not IgnoreUnterminatedStrings then\r\n raise EJppLexerError.CreateFmt('(%d): %s', [FCurrLine, AMsg]);\r\nend;\r\n\r\nprocedure TJppLexer.NextTok;\r\n\r\n procedure HandleDirective(APos: PChar);\r\n\r\n { needs to be special, because it checks for not * or }\r\n function ReadString(cp: PChar; var ident: string): PChar;\r\n var\r\n start: PChar;\r\n begin\r\n if cp^ = '\"' then\r\n begin\r\n Inc(cp);\r\n start := cp;\r\n while (cp^ <> #0) and (cp^ <> #10) and (cp^ <> #13) and (cp^ <> '\"') do\r\n Inc(cp);\r\n if (cp^ = #0) or (cp^ = #10) or (cp^ = #13) then\r\n Error('Unterminated string');\r\n SetString(ident, start, cp - start);\r\n Result := cp + 1;\r\n end\r\n else\r\n begin\r\n start := cp;\r\n while (not CharIsSpace(cp^)) and (cp^ <> '*') and (cp^ <> '}') do\r\n Inc(cp);\r\n if cp^ = #0 then\r\n Error('Unterminated string');\r\n SetString(ident, start, cp - start);\r\n Result := cp;\r\n end;\r\n end;\r\n\r\n var\r\n BPos, start: PChar;\r\n ident: string;\r\n tokInt: Integer;\r\n begin\r\n Assert(APos^ = '$');\r\n Inc(APos);\r\n start := APos;\r\n\r\n { read identifier }\r\n while CharIsValidIdentifierLetter(APos^) do\r\n Inc(APos);\r\n SetString(ident, start, APos - start);\r\n\r\n { find identifier in hash map }\r\n if FTokenHash.Find(ident, tokInt) then\r\n begin\r\n FCurrTok := TJppToken(tokInt);\r\n\r\n case FCurrTok of\r\n ptDefine,\r\n ptUndef,\r\n ptIfdef,\r\n ptIfndef,\r\n ptJppDefine,\r\n ptJppUndef,\r\n ptJppGetStrValue,\r\n ptJppGetIntValue,\r\n ptJppGetBoolValue,\r\n ptJppSetStrValue,\r\n ptJppSetIntValue,\r\n ptJppSetBoolValue:\r\n begin\r\n BPos := APos;\r\n StrSkipChars(BPos, CharIsWhiteSpace);\r\n StrIdent(BPos, FTokenAsString);\r\n end;\r\n ptInclude:\r\n begin\r\n BPos := APos;\r\n StrSkipChars(BPos, CharIsWhiteSpace);\r\n ReadString(BPos, FTokenAsString);\r\n end;\r\n end;\r\n end\r\n else\r\n { other directives must pass through; therefore call them text }\r\n FCurrTok := ptText;\r\n end;\r\n\r\nvar\r\n cp, start: PChar;\r\n cl: Integer;\r\n Eol: Boolean;\r\nlabel\r\n Label_NormalText;\r\nbegin\r\n { register variables optimization }\r\n cp := FCurrPos;\r\n cl := FCurrLine;\r\n\r\n { determine token type }\r\n case cp^ of\r\n\r\n { the buck stops here }\r\n #0:\r\n begin\r\n FCurrTok := ptEof;\r\n Exit;\r\n end;\r\n\r\n { possible Standard Pascal comment }\r\n '(':\r\n begin\r\n if (cp + 1)^ <> '*' then\r\n goto Label_NormalText;\r\n start := cp;\r\n Inc(cp, 2);\r\n while True do\r\n begin\r\n case cp^ of\r\n #0:\r\n Break;\r\n #10:\r\n Inc(cl);\r\n '*':\r\n if (cp + 1)^ = ')' then\r\n Break;\r\n end;\r\n Inc(cp);\r\n end;\r\n if cp^ = '*' then\r\n Inc(cp, 2); // get whole of comment, including trailing '*)'\r\n SetString(FTokenAsString, start, cp - start);\r\n FCurrTok := ptComment;\r\n end;\r\n\r\n { possible line comment }\r\n '/':\r\n begin\r\n if (cp + 1)^ <> '/' then\r\n goto Label_NormalText;\r\n start := cp;\r\n Inc(cp, 2);\r\n while True do\r\n case cp^ of\r\n #0, #13, #10:\r\n Break;\r\n else\r\n Inc(cp);\r\n end;\r\n { if cp^ is #10, we leave it in, to avoid formatting cock-ups }\r\n SetString(FTokenAsString, start, cp - start);\r\n FCurrTok := ptComment;\r\n end;\r\n\r\n { pascal comment }\r\n '{':\r\n begin\r\n start := cp;\r\n while True do\r\n begin\r\n case cp^ of\r\n #0, '}':\r\n Break;\r\n #10:\r\n Inc(cl);\r\n end;\r\n Inc(cp);\r\n end;\r\n if cp^ = '}' then\r\n Inc(cp);\r\n SetString(FTokenAsString, start, cp - start);\r\n FCurrTok := ptComment;\r\n end;\r\n else\r\nLabel_NormalText:\r\n { process normal text; passes straight through until next comment or eof }\r\n start := cp;\r\n\r\n Eol := False;\r\n if cp^ = #13 then\r\n begin\r\n Eol := True;\r\n Inc(cp);\r\n end;\r\n if cp^ = #10 then\r\n begin\r\n Eol := True;\r\n Inc(cp);\r\n end;\r\n \r\n if Eol then\r\n Inc(cl)\r\n else\r\n while True do\r\n begin\r\n case cp^ of\r\n #0, #10, #13:\r\n Break;\r\n '{':\r\n Break;\r\n '/':\r\n if (cp + 1)^ = '/' then\r\n Break;\r\n '(':\r\n if (cp + 1)^ = '*' then\r\n Break;\r\n\r\n { must handle strings seperately; there can be no comments in strings }\r\n '''':\r\n begin\r\n Inc(cp);\r\n while True do\r\n case cp^ of\r\n #0, #10:\r\n begin\r\n FCurrLine := cl;\r\n Error('String not terminated');\r\n Break;\r\n end;\r\n '''':\r\n Break;\r\n else\r\n Inc(cp);\r\n end; { of '''' case }\r\n end;\r\n end;\r\n Inc(cp);\r\n end;\r\n SetString(FTokenAsString, start, cp - start);\r\n if Eol then\r\n FCurrTok := ptEol\r\n else\r\n FCurrTok := ptText;\r\n end;\r\n\r\n { find out if we have a special directive }\r\n if FCurrTok = ptComment then\r\n begin\r\n FRawComment := FTokenAsString;\r\n case (start + 1)^ of\r\n '$': // {$\r\n HandleDirective(start + 1);\r\n\r\n '*': // (*$\r\n if (start + 2)^ = '$' then\r\n HandleDirective(start + 2);\r\n '/': // do nothing\r\n ;\r\n end;\r\n end;\r\n\r\n { restore register variables }\r\n FCurrPos := cp;\r\n FCurrLine := cl;\r\nend;\r\n\r\nprocedure TJppLexer.Reset;\r\nbegin\r\n FCurrPos := PChar(FBuf);\r\n FCurrLine := 1;\r\n NextTok;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n\r\n" }, { "path": "External/Jedi/Jcl/source/common/JclPreProcessorLinkedListsTemplates.pas", "content": "{**************************************************************************************************}\r\n{ }\r\n{ Project JEDI Code Library (JCL) }\r\n{ }\r\n{ The contents of this file are subject to the Mozilla Public License Version 1.1 (the \"License\"); }\r\n{ you may not use this file except in compliance with the License. You may obtain a copy of the }\r\n{ License at http://www.mozilla.org/MPL/ }\r\n{ }\r\n{ Software distributed under the License is distributed on an \"AS IS\" basis, WITHOUT WARRANTY OF }\r\n{ ANY KIND, either express or implied. See the License for the specific language governing rights }\r\n{ and limitations under the License. }\r\n{ }\r\n{ The Original Code is JclLinkedListsTemplates.pas. }\r\n{ }\r\n{ The Initial Developer of the Original Code is Florent Ouchet }\r\n{ }\r\n{ Portions created by Florent Ouchet are Copyright (C) of Florent Ouchet. All rights reserved. }\r\n{ }\r\n{ Contributors: }\r\n{ }\r\n{**************************************************************************************************}\r\n{ }\r\n{ Last modified: $Date:: 2012-02-20 19:48:39 +0100 (lun. 20 févr. 2012) $ }\r\n{ Revision: $Rev:: 3737 $ }\r\n{ Author: $Author:: outchy $ }\r\n{ }\r\n{**************************************************************************************************}\r\n\r\nunit JclPreProcessorLinkedListsTemplates;\r\n\r\ninterface\r\n\r\n{$I jcl.inc}\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n JclPreProcessorContainerTypes,\r\n JclPreProcessorContainerTemplates,\r\n JclPreProcessorContainer1DTemplates;\r\n\r\ntype\r\n (* JCLLINKEDLISTTYPESINT(ITEMCLASSNAME, TYPENAME) *)\r\n TJclLinkedListTypeIntParams = class(TJclContainerInterfaceParams)\r\n public\r\n function AliasAttributeIDs: TAllTypeAttributeIDs; override;\r\n published\r\n property ItemClassName: string index taLinkedListItemClassName read GetTypeAttribute write SetTypeAttribute stored IsTypeAttributeStored;\r\n property TypeName: string index taTypeName read GetTypeAttribute write SetTypeAttribute stored False;\r\n end;\r\n\r\n (* JCLLINKEDLISTINT(ITEMCLASSNAME, SELFCLASSNAME, ANCESTORCLASSNAME,\r\n BASECONTAINTERINTERFACENAME, FLATCONTAINERINTERFACENAME, COLLECTIONINTERFACENAME,\r\n LISTINTERFACENAME, ITRINTERFACENAME, EQUALITYCOMPARERINTERFACENAME,\r\n INTERFACEADDITIONAL, SECTIONADDITIONAL,\r\n COLLECTIONFLAGS, OWNERSHIPDECLARATION, CONSTKEYWORD, PARAMETERNAME,\r\n TYPENAME, GETTERFUNCTIONNAME, SETTERPROCEDURENAME) *)\r\n TJclLinkedListIntParams = class(TJclCollectionInterfaceParams)\r\n protected\r\n // function CodeUnit: string; override;\r\n public\r\n function AliasAttributeIDs: TAllTypeAttributeIDs; override;\r\n published\r\n property ItemClassName: string index taLinkedListItemClassName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property SelfClassName: string index taLinkedListClassName read GetTypeAttribute write SetTypeAttribute stored IsTypeAttributeStored;\r\n property AncestorClassName;\r\n property BaseContainerInterfaceName: string index taContainerInterfaceName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property FlatContainerInterfaceName: string index taFlatContainerInterfaceName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property CollectionInterfaceName: string index taCollectionInterfaceName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property ListInterfaceName: string index taListInterfaceName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property ItrInterfaceName: string index taIteratorInterfaceName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property EqualityComparerInterfaceName: string index taEqualityComparerInterfaceName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property InterfaceAdditional;\r\n property SectionAdditional;\r\n property CollectionFlags;\r\n property OwnershipDeclaration;\r\n property ConstKeyword: string index taConstKeyword read GetTypeAttribute write SetTypeAttribute stored False;\r\n property ParameterName: string index taParameterName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property TypeName: string index taTypeName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property GetterFunctionName: string index taGetterFunctionName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property SetterProcedureName: string index taSetterProcedureName read GetTypeAttribute write SetTypeAttribute stored False;\r\n end;\r\n\r\n (* JCLLINKEDLISTITRINT(SELFCLASSNAME, ITRINTERFACENAME, LISTCLASSNAME, EQUALITYCOMPARERINTERFACENAME,\r\n ITEMCLASSNAME, CONSTKEYWORD, PARAMETERNAME, TYPENAME, DEFAULTVALUE,\r\n GETTERFUNCTIONNAME, SETTERPROCEDURENAME) *)\r\n TJclLinkedListItrIntParams = class(TJclContainerInterfaceParams)\r\n protected\r\n // function CodeUnit: string; override;\r\n public\r\n function AliasAttributeIDs: TAllTypeAttributeIDs; override;\r\n published\r\n property SelfClassName: string index taLinkedListIteratorClassName read GetTypeAttribute write SetTypeAttribute stored IsTypeAttributeStored;\r\n property ItrInterfaceName: string index taIteratorInterfaceName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property ListClassName: string index taLinkedListClassName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property EqualityComparerInterfaceName: string index taEqualityComparerInterfaceName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property ItemClassName: string index taLinkedListItemClassName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property ConstKeyword: string index taConstKeyword read GetTypeAttribute write SetTypeAttribute stored False;\r\n property ParameterName: string index taParameterName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property TypeName: string index taTypeName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property DefaultValue: string index taDefaultValue read GetTypeAttribute write SetTypeAttribute stored False;\r\n property GetterFunctionName: string index taGetterFunctionName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property SetterProcedureName: string index taSetterProcedureName read GetTypeAttribute write SetTypeAttribute stored False;\r\n end;\r\n\r\n (* JCLLINKEDLISTIMP(SELFCLASSNAME, ITEMCLASSNAME, COLLECTIONINTERFACENAME, LISTINTERFACENAME,\r\n ITRINTERFACENAME, ITRCLASSNAME, OWNERSHIPDECLARATION, OWNERSHIPPARAMETERNAME,\r\n CONSTKEYWORD, PARAMETERNAME, TYPENAME, DEFAULTVALUE,\r\n GETTERFUNCTIONNAME, SETTERPROCEDURENAME, RELEASERFUNCTIONNAME) *)\r\n TJclLinkedListImpParams = class(TJclCollectionImplementationParams)\r\n protected\r\n // function CodeUnit: string; override;\r\n public\r\n function GetConstructorParameters: string; override;\r\n function GetSelfClassName: string; override;\r\n published\r\n property SelfClassName: string index taLinkedListClassName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property ItemClassName: string index taLinkedListItemClassName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property CollectionInterfaceName: string index taCollectionInterfaceName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property ListInterfaceName: string index taListInterfaceName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property ItrInterfaceName: string index taIteratorInterfaceName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property ItrClassName: string index taLinkedListIteratorClassName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property OwnershipDeclaration;\r\n property OwnershipParameterName: string index taOwnershipParameterName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property ConstKeyword: string index taConstKeyword read GetTypeAttribute write SetTypeAttribute stored False;\r\n property ParameterName: string index taParameterName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property TypeName: string index taTypeName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property DefaultValue: string index taDefaultValue read GetTypeAttribute write SetTypeAttribute stored False;\r\n property GetterFunctionName: string index taGetterFunctionName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property SetterProcedureName: string index taSetterProcedureName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property ReleaserFunctionName: string index taReleaserFunctionName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property MacroFooter;\r\n end;\r\n\r\n (* JCLLINKEDLISTITRIMP(SELFCLASSNAME, ITRINTERFACENAME, LISTCLASSNAME, EQUALITYCOMPARERINTERFACENAME,\r\n ITEMCLASSNAME, CONSTKEYWORD, PARAMETERNAME, TYPENAME, DEFAULTVALUE,\r\n GETTERFUNCTIONNAME, SETTERPROCEDURENAME, RELEASERCALL) *)\r\n TJclLinkedListItrImpParams = class(TJclContainerImplementationParams)\r\n private\r\n FReleaserCall: string;\r\n function GetReleaserCall: string;\r\n protected\r\n // function CodeUnit: string; override;\r\n public\r\n procedure ResetDefault(Value: Boolean); override;\r\n published\r\n property SelfClassName: string index taLinkedListIteratorClassName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property ItrInterfaceName: string index taIteratorInterfaceName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property ListClassName: string index taLinkedListClassName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property EqualityComparerInterfaceName: string index taEqualityComparerInterfaceName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property ItemClassName: string index taLinkedListItemClassName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property ConstKeyword: string index taConstKeyword read GetTypeAttribute write SetTypeAttribute stored False;\r\n property ParameterName: string index taParameterName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property TypeName: string index taTypeName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property DefaultValue: string index taDefaultValue read GetTypeAttribute write SetTypeAttribute stored False;\r\n property GetterFunctionName: string index taGetterFunctionName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property SetterProcedureName: string index taSetterProcedureName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property ReleaserCall: string read GetReleaserCall write FReleaserCall;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jcl.svn.sourceforge.net/svnroot/jcl/tags/JCL-2.4-Build4571/jcl/source/common/JclPreProcessorLinkedListsTemplates.pas $';\r\n Revision: '$Revision: 3737 $';\r\n Date: '$Date: 2012-02-20 19:48:39 +0100 (lun. 20 févr. 2012) $';\r\n LogPath: 'JCL\\source\\common';\r\n Extra: '';\r\n Data: nil\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n {$IFDEF HAS_UNITSCOPE}\r\n System.SysUtils,\r\n {$ELSE ~HAS_UNITSCOPE}\r\n SysUtils,\r\n {$ENDIF ~HAS_UNITSCOPE}\r\n JclStrings;\r\n\r\nprocedure RegisterJclContainers;\r\nbegin\r\n RegisterContainerParams('JCLLINKEDLISTTYPESINT', TJclLinkedListTypeIntParams);\r\n RegisterContainerParams('JCLLINKEDLISTINT', TJclLinkedListIntParams);\r\n RegisterContainerParams('JCLLINKEDLISTITRINT', TJclLinkedListItrIntParams);\r\n RegisterContainerParams('JCLLINKEDLISTIMP', TJclLinkedListImpParams, TJclLinkedListIntParams);\r\n RegisterContainerParams('JCLLINKEDLISTITRIMP', TJclLinkedListItrImpParams, TJclLinkedListItrIntParams);\r\nend;\r\n\r\n//=== { TJclLinkedListTypeIntParams } ========================================\r\n\r\nfunction TJclLinkedListTypeIntParams.AliasAttributeIDs: TAllTypeAttributeIDs;\r\nbegin\r\n Result := [taLinkedListItemClassName];\r\nend;\r\n\r\n//=== { TJclLinkedListIntParams } ============================================\r\n\r\nfunction TJclLinkedListIntParams.AliasAttributeIDs: TAllTypeAttributeIDs;\r\nbegin\r\n Result := [taLinkedListClassName];\r\nend;\r\n\r\n//=== { TJclLinkedListItrIntParams } =========================================\r\n\r\nfunction TJclLinkedListItrIntParams.AliasAttributeIDs: TAllTypeAttributeIDs;\r\nbegin\r\n Result := [taLinkedListIteratorClassName];\r\nend;\r\n\r\n//=== { TJclLinkedListImpParams } ============================================\r\n\r\nfunction TJclLinkedListImpParams.GetConstructorParameters: string;\r\nbegin\r\n Result := 'nil';\r\nend;\r\n\r\nfunction TJclLinkedListImpParams.GetSelfClassName: string;\r\nbegin\r\n Result := SelfClassName;\r\nend;\r\n\r\n//=== { TJclLinkedListItrImpParams } =========================================\r\n\r\nfunction TJclLinkedListItrImpParams.GetReleaserCall: string;\r\nbegin\r\n Result := FReleaserCall;\r\n if (Result = '') and TypeInfo.KnownType then\r\n begin\r\n if TypeInfo.TObjectType then\r\n Result := '(FownList as IJclObjectOwner).FreeObject(FCursor.Value);'\r\n else\r\n Result := Format('FCursor.Value := %s;', [TypeInfo.TypeAttributes[taDefaultValue]]);\r\n end;\r\nend;\r\n\r\nprocedure TJclLinkedListItrImpParams.ResetDefault(Value: Boolean);\r\nbegin\r\n inherited ResetDefault(Value);\r\n FReleaserCall := '';\r\n if not Value then\r\n FReleaserCall := GetReleaserCall;\r\nend;\r\n\r\ninitialization\r\n RegisterJclContainers;\r\n {$IFDEF UNITVERSIONING}\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n {$ENDIF UNITVERSIONING}\r\n\r\nfinalization\r\n {$IFDEF UNITVERSIONING}\r\n UnregisterUnitVersion(HInstance);\r\n {$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n\r\n" }, { "path": "External/Jedi/Jcl/source/common/JclPreProcessorParser.pas", "content": "{ **************************************************************************** }\r\n{ }\r\n{ Pascal PreProcessor Parser }\r\n{ Copyright (c) 2001 Barry Kelly. }\r\n{ barry_j_kelly@hotmail.com }\r\n{ }\r\n{ The contents of this file are subject to the Mozilla Public License }\r\n{ Version 1.1 (the \"License\"); you may not use this file except in }\r\n{ compliance with the License. You may obtain a copy of the License at }\r\n{ http://www.mozilla.org/MPL/ }\r\n{ }\r\n{ Software distributed under the License is distributed on an \"AS IS\" }\r\n{ basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the }\r\n{ License for the specific language governing rights and limitations }\r\n{ under the License. }\r\n{ }\r\n{ The Original Code is PppParser.pas }\r\n{ }\r\n{ The Initial Developer of the Original Code is Barry Kelly. }\r\n{ Portions created by Barry Kelly are Copyright (C) 2001 }\r\n{ Barry Kelly. All Rights Reserved. }\r\n{ }\r\n{ Contributors: }\r\n{ Robert Rossmair, }\r\n{ Peter Thrnqvist, }\r\n{ Florent Ouchet }\r\n{ }\r\n{ Alternatively, the contents of this file may be used under the terms }\r\n{ of the Lesser GNU Public License (the \"LGPL License\"), in which case }\r\n{ the provisions of LGPL License are applicable instead of those }\r\n{ above. If you wish to allow use of your version of this file only }\r\n{ under the terms of the LPGL License and not to allow others to use }\r\n{ your version of this file under the MPL, indicate your decision by }\r\n{ deleting the provisions above and replace them with the notice and }\r\n{ other provisions required by the LGPL License. If you do not delete }\r\n{ the provisions above, a recipient may use your version of this file }\r\n{ under either the MPL or the LPGL License. }\r\n{ }\r\n{ **************************************************************************** }\r\n{ }\r\n{ Last modified: $Date:: 2012-02-24 12:09:51 +0100 (ven. 24 févr. 2012) $ }\r\n{ Revision: $Rev:: 3744 $ }\r\n{ Author: $Author:: outchy $ }\r\n{ }\r\n{ **************************************************************************** }\r\n\r\nunit JclPreProcessorParser;\r\n\r\n{$I jcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF HAS_UNITSCOPE}\r\n System.SysUtils, System.Classes,\r\n {$ELSE ~HAS_UNITSCOPE}\r\n SysUtils, Classes,\r\n {$ENDIF ~HAS_UNITSCOPE}\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n JclBase, JclContainerIntf, JclPreProcessorLexer;\r\n\r\ntype\r\n TPppState = class;\r\n \r\n EPppParserError = class(EJclError);\r\n\r\n TJppParser = class\r\n private\r\n FLexer: TJppLexer;\r\n FState: TPppState;\r\n FResult: string;\r\n FResultLen: Integer;\r\n FLineBreakPos: Integer;\r\n FAllWhiteSpaceIn: Boolean;\r\n FAllWhiteSpaceOut: Boolean;\r\n protected\r\n procedure AddResult(const S: string; FixIndent: Boolean = False; ForceRecurseTest: Boolean = False);\r\n function IsExcludedInclude(const FileName: string): Boolean;\r\n\r\n procedure NextToken;\r\n\r\n procedure ParseText;\r\n procedure ParseCondition(Token: TJppToken);\r\n function ParseInclude: string;\r\n\r\n procedure ParseDefine(Skip: Boolean);\r\n procedure ParseUndef(Skip: Boolean);\r\n\r\n procedure ParseDefineMacro;\r\n procedure ParseExpandMacro;\r\n procedure ParseUndefMacro;\r\n\r\n procedure ParseGetBoolValue;\r\n procedure ParseGetIntValue;\r\n procedure ParseGetStrValue;\r\n procedure ParseLoop;\r\n procedure ParseSetBoolValue;\r\n procedure ParseSetIntValue;\r\n procedure ParseSetStrValue;\r\n public\r\n constructor Create(const ABuffer: string; APppState: TPppState);\r\n destructor Destroy; override;\r\n function Parse: string;\r\n\r\n property Lexer: TJppLexer read FLexer;\r\n property State: TPppState read FState;\r\n end;\r\n\r\n EPppState = class(EJclError);\r\n\r\n TPppOption = (poProcessIncludes, poProcessDefines, poStripComments,\r\n poProcessMacros, poProcessValues, poNoWarningHeader, poKeepTabAndSpaces,\r\n poIgnoreUnterminatedStrings);\r\n TPppOptions = set of TPppOption;\r\n\r\n TTriState = (ttUnknown, ttUndef, ttDefined);\r\n\r\n TPppStateItem = class\r\n public\r\n DefinedKeywords: IJclStrMap;\r\n ExcludedFiles: IJclStrList;\r\n Macros: IJclStrIntfMap;\r\n SearchPath: IJclStrList;\r\n TriState: TTriState;\r\n end;\r\n\r\n TPppStateItemClass = class of TPppStateItem;\r\n\r\n TPppProvider = class(TPersistent)\r\n protected\r\n function GetBoolValue(const Name: string): Boolean; virtual; abstract;\r\n function GetDefine(const ASymbol: string): TTriState; virtual; abstract;\r\n function GetIntegerValue(const Name: string): Integer; virtual; abstract;\r\n function GetStringValue(const Name: string): string; virtual; abstract;\r\n procedure SetBoolValue(const Name: string; Value: Boolean); virtual; abstract;\r\n procedure SetDefine(const ASymbol: string; const Value: TTriState); virtual; abstract;\r\n procedure SetIntegerValue(const Name: string; Value: Integer); virtual; abstract;\r\n procedure SetStringValue(const Name, Value: string); virtual; abstract;\r\n public\r\n property Defines[const ASymbol: string]: TTriState read GetDefine write SetDefine;\r\n property BoolValues[const Name: string]: Boolean read GetBoolValue write SetBoolValue;\r\n property StringValues[const Name: string]: string read GetStringValue write SetStringValue;\r\n property IntegerValues[const Name: string]: Integer read GetIntegerValue write SetIntegerValue;\r\n end;\r\n\r\n TPppState = class(TPppProvider)\r\n private\r\n FStateStack: IJclStack;\r\n FOptions: TPppOptions;\r\n function InternalPeekDefines: IJclStrMap;\r\n function InternalPeekExcludedFiles: IJclStrList;\r\n function InternalPeekMacros: IJclStrIntfMap;\r\n function InternalPeekSearchPath: IJclStrList;\r\n function InternalPeekTriState: TTriState;\r\n procedure InternalSetTriState(Value: TTriState);\r\n protected\r\n class function StateItemClass: TPppStateItemClass; virtual;\r\n procedure InternalPushState(FromStateItem, ToStateItem: TPppStateItem); virtual;\r\n function PeekStateItem: TPppStateItem;\r\n\r\n function GetOptions: TPppOptions;\r\n procedure SetOptions(AOptions: TPppOptions);\r\n\r\n function FindMacro(const AMacroName: string): IJclStrList;\r\n function AssociateParameters(const ParamNames: IJclStrList;\r\n const ParamValues: TDynStringArray): TDynWideStringArray;\r\n\r\n function GetBoolValue(const Name: string): Boolean; override;\r\n function GetDefine(const ASymbol: string): TTriState; override;\r\n function GetIntegerValue(const Name: string): Integer; override;\r\n function GetStringValue(const Name: string): string; override;\r\n procedure SetBoolValue(const Name: string; Value: Boolean); override;\r\n procedure SetDefine(const ASymbol: string; const Value: TTriState); override;\r\n procedure SetIntegerValue(const Name: string; Value: Integer); override;\r\n procedure SetStringValue(const Name, Value: string); override;\r\n public\r\n constructor Create;\r\n destructor Destroy; override;\r\n\r\n procedure AfterConstruction; override;\r\n \r\n { PushState is called at the start of every unit, and PopState at the\r\n end. This means that any declarations like $DEFINE will be file-local\r\n in scope. }\r\n procedure PushState;\r\n procedure PopState;\r\n\r\n property TriState: TTriState read InternalPeekTriState write InternalSetTriState;\r\n\r\n procedure Define(const ASymbol: string);\r\n procedure Undef(const ASymbol: string);\r\n\r\n function FindFile(const AName: string): TStream;\r\n procedure AddToSearchPath(const AName: string);\r\n\r\n procedure AddFileToExclusionList(const AName: string);\r\n function IsFileExcluded(const AName: string): Boolean;\r\n\r\n function ExpandMacro(const AName: string; const ParamValues: TDynStringArray): string; virtual;\r\n procedure DefineMacro(const AName: string; const ParamNames: TDynStringArray;\r\n const Value: string);\r\n procedure UndefMacro(const AName: string; const ParamNames: TDynStringArray);\r\n\r\n property Options: TPppOptions read GetOptions write SetOptions;\r\n end;\r\n\r\n TPppStateClass = class of TPppState;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jcl.svn.sourceforge.net/svnroot/jcl/tags/JCL-2.4-Build4571/jcl/source/common/JclPreProcessorParser.pas $';\r\n Revision: '$Revision: 3744 $';\r\n Date: '$Date: 2012-02-24 12:09:51 +0100 (ven. 24 févr. 2012) $';\r\n LogPath: 'JCL\\source\\common';\r\n Extra: '';\r\n Data: nil\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n {$IFDEF HAS_UNITSCOPE}\r\n System.TypInfo,\r\n {$ELSE ~HAS_UNITSCOPE}\r\n TypInfo,\r\n {$ENDIF ~HAS_UNITSCOPE}\r\n JclStrings, JclStreams, JclSysUtils, JclArrayLists, JclHashMaps, JclStacks;\r\n \r\nfunction AllWhiteSpace(P: PChar; KeepTabAndSpaces: Boolean): Boolean;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := True;\r\n for I := 1 to StrLen(P) do\r\n case P^ of\r\n NativeTab, NativeSpace:\r\n if KeepTabAndSpaces then\r\n begin\r\n Result := False;\r\n Break;\r\n end\r\n else\r\n Inc(P);\r\n NativeLineFeed, NativeCarriageReturn:\r\n Inc(P);\r\n else\r\n Result := False;\r\n Break;\r\n end;\r\nend;\r\n\r\nfunction ParseMacro(const MacroText: string; var MacroName: string; var ParamNames: TDynStringArray;\r\n ParamDeclaration: Boolean): Integer;\r\nvar\r\n I, J: Integer;\r\n Comment: Boolean;\r\n ParenthesisCount: Integer;\r\n MacroTextLen: Integer;\r\n MacroParenthesis, MacroBracket: Boolean;\r\nbegin\r\n MacroTextLen := Length(MacroText);\r\n I := 1;\r\n while (I <= MacroTextLen) and not CharIsSpace(MacroText[I]) do\r\n Inc(I);\r\n while (I <= MacroTextLen) and CharIsSpace(MacroText[I]) do\r\n Inc(I);\r\n J := I;\r\n while (J <= MacroTextLen) and CharIsValidIdentifierLetter(MacroText[J]) do\r\n Inc(J);\r\n MacroName := Copy(MacroText, I, J - I);\r\n\r\n if J <= MacroTextLen then\r\n begin\r\n SetLength(ParamNames, 0);\r\n MacroParenthesis := MacroText[J] = '(';\r\n MacroBracket := MacroText[J] = '[';\r\n if MacroParenthesis or MacroBracket then\r\n begin\r\n Inc(J);\r\n if ParamDeclaration then\r\n begin\r\n repeat\r\n while (J <= MacroTextLen) and CharIsSpace(MacroText[J]) do\r\n Inc(J);\r\n I := J;\r\n while (I <= MacroTextLen) and CharIsValidIdentifierLetter(MacroText[I]) do\r\n Inc(I);\r\n SetLength(ParamNames, Length(ParamNames) + 1);\r\n ParamNames[High(ParamNames)] := Copy(MacroText, J, I - J);\r\n while (I <= MacroTextLen) and CharIsSpace(MacroText[I]) do\r\n Inc(I);\r\n if (I <= MacroTextLen) then\r\n begin\r\n if MacroParenthesis then\r\n case MacroText[I] of\r\n ',':\r\n Inc(I);\r\n ')': ;\r\n else\r\n raise EPppParserError.CreateFmt('invalid parameter declaration in macro \"%s\"', [MacroText]);\r\n end;\r\n if MacroBracket then\r\n case MacroText[I] of\r\n '|':\r\n Inc(I);\r\n ']': ;\r\n else\r\n raise EPppParserError.CreateFmt('invalid parameter declaration in macro \"%s\"', [MacroText]);\r\n end;\r\n end;\r\n J := I;\r\n until (J > MacroTextLen) or (MacroParenthesis and (MacroText[J] = ')')) or (MacroBracket and (MacroText[J] = ']'));\r\n end\r\n else\r\n begin\r\n repeat\r\n I := J;\r\n Comment := False;\r\n ParenthesisCount := 0;\r\n\r\n while I <= MacroTextLen do\r\n begin\r\n case MacroText[I] of\r\n NativeSingleQuote:\r\n Comment := not Comment;\r\n '(':\r\n if not Comment then\r\n Inc(ParenthesisCount);\r\n ')':\r\n begin\r\n if MacroParenthesis and (not Comment) and (ParenthesisCount = 0) then\r\n Break;\r\n if not Comment then\r\n Dec(ParenthesisCount);\r\n end;\r\n ']':\r\n if MacroBracket and (not Comment) and (ParenthesisCount = 0) then\r\n Break;\r\n NativeBackslash:\r\n if (not Comment) and (ParenthesisCount = 0) and (I < MacroTextLen) and (MacroText[i + 1] = NativeComma) then\r\n Inc(I);\r\n NativeComma:\r\n if MacroParenthesis and (not Comment) and (ParenthesisCount = 0) then\r\n Break;\r\n '|':\r\n if MacroBracket and (not Comment) and (ParenthesisCount = 0) then\r\n Break;\r\n end;\r\n Inc(I);\r\n end;\r\n SetLength(ParamNames, Length(ParamNames) + 1);\r\n ParamNames[High(ParamNames)] := Copy(MacroText, J, I - J);\r\n StrReplace(ParamNames[High(ParamNames)], '\\,', ',', [rfReplaceAll]);\r\n if MacroParenthesis then\r\n begin\r\n if (I < MacroTextLen) and (MacroText[I] = ')') then\r\n begin\r\n J := I;\r\n Break;\r\n end;\r\n if (I < MacroTextLen) and (MacroText[I] = ',') then\r\n Inc(I);\r\n end;\r\n if MacroBracket then\r\n begin\r\n if (I < MacroTextLen) and (MacroText[I] = ']') then\r\n begin\r\n J := I;\r\n Break;\r\n end;\r\n if (I < MacroTextLen) and (MacroText[I] = '|') then\r\n Inc(I);\r\n end;\r\n J := I;\r\n until J > MacroTextLen;\r\n end;\r\n if J <= MacroTextLen then\r\n begin\r\n if MacroParenthesis and (MacroText[J] = ')') then\r\n Inc(J) // skip )\r\n else\r\n if MacroBracket and (MacroText[J] = ']') then\r\n Inc(J) // skip ]\r\n else\r\n raise EPppParserError.CreateFmt('Unterminated list of arguments for macro \"%s\"', [MacroText]);\r\n end;\r\n end\r\n else\r\n begin\r\n while (J <= MacroTextLen) and CharIsSpace(MacroText[J]) do\r\n Inc(J);\r\n end;\r\n end;\r\n Result := J;\r\nend;\r\n\r\n{ TJppParser }\r\n\r\nconstructor TJppParser.Create(const ABuffer: string; APppState: TPppState);\r\nbegin\r\n inherited Create;\r\n Assert(APppState <> nil);\r\n\r\n FLexer := TJppLexer.Create(ABuffer, poIgnoreUnterminatedStrings in APppState.Options);\r\n FState := APppState;\r\n FState.Undef('PROTOTYPE');\r\nend;\r\n\r\ndestructor TJppParser.Destroy;\r\nbegin\r\n FLexer.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJppParser.AddResult(const S: string; FixIndent, ForceRecurseTest: Boolean);\r\nvar\r\n I, J: Integer;\r\n LinePrefix, AResult, Line: string;\r\n TempMemoryStream: TMemoryStream;\r\n TempStringStream: TJclAutoStream;\r\n TempLexer: TJppLexer;\r\n TempParser: TJppParser;\r\n Lines: TStrings;\r\n Recurse: Boolean;\r\nbegin\r\n if State.TriState = ttUndef then\r\n Exit;\r\n\r\n AResult := S;\r\n // recurse macro expanding\r\n if (AResult <> '') and (ForceRecurseTest or (StrIPos('$JPP', AResult) > 0)) then\r\n begin\r\n try\r\n Recurse := False;\r\n TempLexer := TJppLexer.Create(AResult, poIgnoreUnterminatedStrings in State.Options);\r\n try\r\n State.PushState;\r\n while True do\r\n begin\r\n case TempLexer.CurrTok of\r\n ptEof:\r\n Break;\r\n ptDefine,\r\n ptJppDefine,\r\n ptUndef,\r\n ptJppUndef:\r\n if poProcessDefines in State.Options then\r\n begin\r\n Recurse := True;\r\n Break;\r\n end;\r\n ptIfdef, ptIfndef:\r\n if (poProcessDefines in State.Options) and (State.Defines[TempLexer.TokenAsString] in [ttDefined, ttUndef]) then\r\n begin\r\n Recurse := True;\r\n Break;\r\n end;\r\n ptJppDefineMacro,\r\n ptJppExpandMacro,\r\n ptJppUndefMacro:\r\n if poProcessMacros in State.Options then\r\n begin\r\n Recurse := True;\r\n Break;\r\n end;\r\n ptJppGetStrValue,\r\n ptJppGetIntValue,\r\n ptJppGetBoolValue,\r\n ptJppSetStrValue,\r\n ptJppSetIntValue,\r\n ptJppSetBoolValue,\r\n ptJppLoop:\r\n if poProcessValues in State.Options then\r\n begin\r\n Recurse := True;\r\n Break;\r\n end;\r\n end;\r\n TempLexer.NextTok;\r\n end;\r\n finally\r\n State.PopState;\r\n TempLexer.Free;\r\n end;\r\n if Recurse then\r\n begin\r\n TempMemoryStream := TMemoryStream.Create;\r\n try\r\n TempStringStream := TJclAutoStream.Create(TempMemoryStream);\r\n try\r\n TempStringStream.WriteString(AResult, 1, Length(AResult));\r\n TempStringStream.Seek(0, soBeginning);\r\n TempParser := TJppParser.Create(TempStringStream.ReadString, State);\r\n try\r\n AResult := TempParser.Parse;\r\n finally\r\n TempParser.Free;\r\n end;\r\n finally\r\n TempStringStream.Free;\r\n end;\r\n finally\r\n TempMemoryStream.Free;\r\n end;\r\n end;\r\n except\r\n // The text might not be well-formed Pascal source and\r\n // thus exceptions might be raised, in such case, just add the text without recursion\r\n AResult := S;\r\n end;\r\n end;\r\n if FixIndent and (AResult <> '') then\r\n begin\r\n // find the number of white space at the beginning of the current line (indentation level)\r\n I := FResultLen + 1;\r\n while (I > 1) and not CharIsReturn(FResult[I - 1]) do\r\n Dec(I);\r\n J := I;\r\n while (J <= FResultLen) and CharIsWhiteSpace(FResult[J]) do\r\n Inc(J);\r\n LinePrefix := StrRepeat(NativeSpace, J - I);\r\n\r\n Lines := TStringList.Create;\r\n try\r\n StrToStrings(AResult, NativeLineBreak, Lines);\r\n if not (poKeepTabAndSpaces in State.Options) then\r\n begin\r\n // remove first empty lines\r\n while Lines.Count > 0 do\r\n begin\r\n if Lines.Strings[0] = '' then\r\n Lines.Delete(0)\r\n else\r\n Break;\r\n end;\r\n // remove last empty lines\r\n for I := Lines.Count - 1 downto 0 do\r\n begin\r\n if Lines.Strings[I] = '' then\r\n Lines.Delete(I)\r\n else\r\n Break;\r\n end;\r\n end;\r\n // fix line offsets\r\n if LinePrefix <> '' then\r\n for I := 1 to Lines.Count - 1 do\r\n begin\r\n Line := Lines.Strings[I];\r\n if Line <> '' then\r\n Lines.Strings[I] := LinePrefix + Line;\r\n end;\r\n AResult := StringsToStr(Lines, NativeLineBreak);\r\n finally\r\n Lines.Free;\r\n end;\r\n end;\r\n if AResult <> '' then\r\n begin\r\n while FResultLen + Length(AResult) > Length(FResult) do\r\n SetLength(FResult, Length(FResult) * 2);\r\n Move(AResult[1], FResult[FResultLen + 1], Length(AResult) * SizeOf(Char));\r\n FAllWhiteSpaceOut := FAllWhiteSpaceOut and AllWhiteSpace(PChar(AResult), poKeepTabAndSpaces in State.Options);\r\n Inc(FResultLen, Length(AResult));\r\n end;\r\nend;\r\n\r\nfunction TJppParser.IsExcludedInclude(const FileName: string): Boolean;\r\nbegin\r\n Result := State.IsFileExcluded(FileName);\r\nend;\r\n\r\nprocedure TJppParser.NextToken;\r\nbegin\r\n Lexer.NextTok;\r\n\r\n if State.TriState = ttUndef then\r\n Exit;\r\n \r\n case Lexer.CurrTok of\r\n ptEof, ptEol:\r\n // do not change FAllWhiteSpaceIn\r\n ;\r\n ptComment:\r\n FAllWhiteSpaceIn := False;\r\n ptText:\r\n FAllWhiteSpaceIn := FAllWhiteSpaceIn and AllWhiteSpace(PChar(Lexer.TokenAsString), poKeepTabAndSpaces in State.Options);\r\n ptDefine,\r\n ptUndef,\r\n ptIfdef,\r\n ptIfndef,\r\n ptIfopt,\r\n ptElse,\r\n ptEndif,\r\n ptJppDefine,\r\n ptJppUndef,\r\n ptJppDefineMacro,\r\n ptJppExpandMacro,\r\n ptJppUndefMacro,\r\n ptJppGetStrValue,\r\n ptJppGetIntValue,\r\n ptJppGetBoolValue,\r\n ptJppSetStrValue,\r\n ptJppSetIntValue,\r\n ptJppSetBoolValue,\r\n ptJppLoop:\r\n FAllWhiteSpaceIn := False;\r\n ptInclude:\r\n FAllWhiteSpaceIn := IsExcludedInclude(Lexer.TokenAsString);\r\n else\r\n // Error\r\n end;\r\nend;\r\n\r\nfunction TJppParser.Parse: string;\r\nbegin\r\n FLexer.Reset;\r\n SetLength(FResult, 64 * 1024);\r\n FillChar(FResult[1], Length(FResult) * SizeOf(Char), 0);\r\n FResultLen := 0;\r\n FLineBreakPos := 1;\r\n FAllWhiteSpaceOut := True;\r\n\r\n ParseText;\r\n SetLength(FResult, FResultLen);\r\n Result := FResult;\r\nend;\r\n\r\nprocedure TJppParser.ParseCondition(Token: TJppToken);\r\n procedure PushAndExecute(NewTriState: TTriState);\r\n var\r\n NeedPush: Boolean;\r\n begin\r\n NeedPush := State.TriState <> NewTriState;\r\n if NeedPush then\r\n State.PushState;\r\n try\r\n State.TriState := NewTriState;\r\n NextToken;\r\n ParseText;\r\n finally\r\n if NeedPush then\r\n State.PopState;\r\n end;\r\n end;\r\nvar\r\n Condition: string;\r\n ConditionTriState: TTriState;\r\nbegin\r\n Condition := Lexer.TokenAsString;\r\n ConditionTriState := State.Defines[Condition];\r\n // parse the first part of the $IFDEF or $IFNDEF\r\n case ConditionTriState of\r\n ttUnknown:\r\n begin\r\n State.PushState;\r\n try\r\n // preserve the $IFDEF or $IFNDEF\r\n AddResult(Lexer.RawComment);\r\n // assume that the symbol is defined in the $IFDEF\r\n if Token = ptIfdef then\r\n State.Define(Condition)\r\n else\r\n // assume that the symbol is not defined in the $IFNDEF\r\n if Token = ptIfndef then\r\n State.Undef(Condition);\r\n NextToken;\r\n ParseText;\r\n finally\r\n State.PopState;\r\n end;\r\n end;\r\n ttUndef:\r\n if Token = ptIfdef then\r\n PushAndExecute(ttUndef)\r\n else\r\n if Token = ptIfndef then\r\n PushAndExecute(ttDefined);\r\n ttDefined:\r\n if Token = ptIfdef then\r\n PushAndExecute(ttDefined)\r\n else\r\n if Token = ptIfndef then\r\n PushAndExecute(ttUndef);\r\n end;\r\n // part the second part of the $IFDEF or $IFNDEF if any\r\n if Lexer.CurrTok = ptElse then\r\n begin\r\n case ConditionTriState of\r\n ttUnknown:\r\n begin\r\n State.PushState;\r\n try\r\n // preserve the $ELSE\r\n AddResult(Lexer.RawComment);\r\n // assume that the symbol is not defined after the $IFDEF\r\n if Token = ptIfdef then\r\n State.Undef(Condition)\r\n else\r\n // assume that the symbol is defined after the $IFNDEF\r\n if Token = ptIfndef then\r\n State.Define(Condition);\r\n NextToken;\r\n ParseText;\r\n finally\r\n State.PopState;\r\n end;\r\n end;\r\n ttUndef:\r\n begin\r\n if Token = ptIfdef then\r\n PushAndExecute(ttDefined)\r\n else\r\n if Token = ptIfndef then\r\n PushAndExecute(ttUndef);\r\n //State.Defines[Condition] := ttDefined;\r\n end;\r\n ttDefined:\r\n begin\r\n if Token = ptIfdef then\r\n PushAndExecute(ttUndef)\r\n else\r\n if Token = ptIfndef then\r\n PushAndExecute(ttDefined);\r\n //State.Defines[Condition] := ttUndef;\r\n end;\r\n end;\r\n end;\r\n if Lexer.CurrTok <> ptEndif then\r\n Lexer.Error('$ENDIF expected');\r\n case ConditionTriState of\r\n ttUnknown:\r\n // preserve the $ENDIF\r\n AddResult(Lexer.RawComment);\r\n ttUndef: ;\r\n ttDefined: ;\r\n end;\r\n NextToken;\r\nend;\r\n\r\nprocedure TJppParser.ParseDefine(Skip: Boolean);\r\nvar\r\n Condition: string;\r\nbegin\r\n Condition := Lexer.TokenAsString;\r\n case State.Defines[Condition] of\r\n // the symbol is not defined\r\n ttUnknown,\r\n ttUndef:\r\n begin\r\n State.Defines[Lexer.TokenAsString] := ttDefined;\r\n if not Skip then\r\n AddResult(Lexer.RawComment);\r\n end;\r\n // the symbol is already defined, always skip it\r\n ttDefined: ;\r\n end;\r\n NextToken;\r\nend;\r\n\r\nprocedure TJppParser.ParseDefineMacro;\r\nvar\r\n I, J: Integer;\r\n MacroText, MacroName, MacroValue: string;\r\n ParamNames: TDynStringArray;\r\nbegin\r\n MacroText := Lexer.TokenAsString;\r\n I := ParseMacro(MacroText, MacroName, ParamNames, True);\r\n if I <= Length(MacroText) then\r\n begin\r\n if Copy(MacroText, I, Length(NativeLineBreak)) = NativeLineBreak then\r\n Inc(I, Length(NativeLineBreak));\r\n J := Length(MacroText);\r\n if MacroText[J] = ')' then\r\n Dec(J);\r\n MacroValue := Copy(MacroText, I, J - I);\r\n State.DefineMacro(MacroName, ParamNames, MacroValue);\r\n end;\r\n NextToken;\r\nend;\r\n\r\nprocedure TJppParser.ParseExpandMacro;\r\nvar\r\n MacroText, MacroName, AResult: string;\r\n ParamNames: TDynStringArray;\r\nbegin\r\n MacroText := Lexer.TokenAsString;\r\n ParseMacro(MacroText, MacroName, ParamNames, False);\r\n // macros are expanded in a sub-state\r\n State.PushState;\r\n try\r\n AResult := State.ExpandMacro(MacroName, ParamNames);\r\n // add result to buffer\r\n AddResult(AResult, True, True);\r\n finally\r\n State.PopState;\r\n end;\r\n NextToken;\r\nend;\r\n\r\nprocedure TJppParser.ParseUndef(Skip: Boolean);\r\nvar\r\n Condition: string;\r\nbegin\r\n Condition := Lexer.TokenAsString;\r\n case State.Defines[Condition] of\r\n // the symbol is not defined\r\n ttUnknown,\r\n ttDefined:\r\n begin\r\n State.Defines[Lexer.TokenAsString] := ttUndef;\r\n if not Skip then\r\n AddResult(Lexer.RawComment);\r\n end;\r\n // the symbol is already defined, skip it\r\n ttUndef: ;\r\n end;\r\n NextToken;\r\nend;\r\n\r\nprocedure TJppParser.ParseUndefMacro;\r\nvar\r\n MacroText, MacroName: string;\r\n ParamNames: TDynStringArray;\r\nbegin\r\n MacroText := Lexer.TokenAsString;\r\n ParseMacro(MacroText, MacroName, ParamNames, True);\r\n State.UndefMacro(MacroName, ParamNames);\r\n NextToken;\r\nend;\r\n\r\nfunction TJppParser.ParseInclude: string;\r\nvar\r\n oldLexer, newLexer: TJppLexer;\r\n fsIn: TStream;\r\n ssIn: TJclAutoStream;\r\nbegin\r\n Result := '';\r\n Assert(Lexer.TokenAsString <> '');\r\n { we must prevent case of $I- & $I+ becoming file names }\r\n if (Lexer.TokenAsString[1] = '-')\r\n or (Lexer.TokenAsString[1] = '+')\r\n or IsExcludedInclude(Lexer.TokenAsString) then\r\n Result := Lexer.RawComment\r\n else\r\n begin\r\n fsIn := nil;\r\n ssIn := nil;\r\n newLexer := nil;\r\n\r\n oldLexer := Lexer;\r\n try\r\n try\r\n fsIn := FState.FindFile(Lexer.TokenAsString);\r\n except\r\n on e: Exception do\r\n Lexer.Error(e.Message);\r\n end;\r\n ssIn := TJclAutoStream.Create(fsIn);\r\n newLexer := TJppLexer.Create(ssIn.ReadString, poIgnoreUnterminatedStrings in State.Options);\r\n FLexer := newLexer;\r\n ParseText;\r\n finally\r\n FLexer := oldLexer;\r\n ssIn.Free;\r\n fsIn.Free;\r\n newLexer.Free;\r\n end;\r\n end;\r\n NextToken;\r\nend;\r\n\r\nprocedure TJppParser.ParseGetStrValue;\r\nvar\r\n Name: string;\r\nbegin\r\n Name := Lexer.TokenAsString;\r\n AddResult(State.StringValues[Name]);\r\n NextToken;\r\nend;\r\n\r\nprocedure TJppParser.ParseGetIntValue;\r\nvar\r\n Name: string;\r\nbegin\r\n Name := Lexer.TokenAsString;\r\n AddResult(IntToStr(State.IntegerValues[Name]));\r\n NextToken;\r\nend;\r\n\r\nprocedure TJppParser.ParseGetBoolValue;\r\nvar\r\n Name: string;\r\nbegin\r\n Name := Lexer.TokenAsString;\r\n AddResult(BoolToStr(State.BoolValues[Name], True));\r\n NextToken;\r\nend;\r\n\r\nprocedure TJppParser.ParseLoop;\r\nvar\r\n I, J, RepeatIndex, RepeatCount: Integer;\r\n RepeatText, IndexName, CountName: string;\r\nbegin\r\n I := 1;\r\n RepeatText := Lexer.RawComment;\r\n while (I <= Length(RepeatText)) and not CharIsWhiteSpace(RepeatText[I]) do\r\n Inc(I);\r\n while (I <= Length(RepeatText)) and CharIsWhiteSpace(RepeatText[I]) do\r\n Inc(I);\r\n J := I;\r\n while (J <= Length(RepeatText)) and CharIsValidIdentifierLetter(RepeatText[J]) do\r\n Inc(J);\r\n IndexName := Copy(RepeatText, I, J - I);\r\n while (J <= Length(RepeatText)) and CharIsWhiteSpace(RepeatText[J]) do\r\n Inc(J);\r\n I := J;\r\n while (J <= Length(RepeatText)) and CharIsValidIdentifierLetter(RepeatText[I]) do\r\n Inc(I);\r\n CountName := Copy(RepeatText, J, I - J);\r\n\r\n J := Length(RepeatText);\r\n if RepeatText[J] = ')' then\r\n Dec(J);\r\n RepeatText := Copy(RepeatText, I, J - I);\r\n RepeatCount := State.IntegerValues[CountName];\r\n for RepeatIndex := 0 to RepeatCount - 1 do\r\n begin\r\n State.IntegerValues[IndexName] := RepeatIndex;\r\n AddResult(RepeatText);\r\n end;\r\n State.IntegerValues[IndexName] := -1;\r\n NextToken;\r\nend;\r\n\r\nprocedure TJppParser.ParseSetStrValue;\r\nvar\r\n I, J: Integer;\r\n Text, Name, Value: string;\r\nbegin\r\n I := 1;\r\n Text := Lexer.RawComment;\r\n while (I <= Length(Text)) and not CharIsWhiteSpace(Text[I]) do\r\n Inc(I);\r\n while (I <= Length(Text)) and CharIsWhiteSpace(Text[I]) do\r\n Inc(I);\r\n J := I;\r\n while (J <= Length(Text)) and CharIsValidIdentifierLetter(Text[J]) do\r\n Inc(J);\r\n Name := Copy(Text, I, J - I);\r\n while (J <= Length(Text)) and CharIsWhiteSpace(Text[J]) do\r\n Inc(J);\r\n I := Length(Text);\r\n if Text[I] = ')' then\r\n Dec(I);\r\n Value := Copy(Text, J, I - J);\r\n State.StringValues[Name] := Value;\r\n NextToken;\r\nend;\r\n\r\nprocedure TJppParser.ParseSetIntValue;\r\nvar\r\n I, J: Integer;\r\n Text, Name, Value: string;\r\nbegin\r\n I := 1;\r\n Text := Lexer.RawComment;\r\n while (I <= Length(Text)) and not CharIsWhiteSpace(Text[I]) do\r\n Inc(I);\r\n while (I <= Length(Text)) and CharIsWhiteSpace(Text[I]) do\r\n Inc(I);\r\n J := I;\r\n while (J <= Length(Text)) and CharIsValidIdentifierLetter(Text[J]) do\r\n Inc(J);\r\n Name := Copy(Text, I, J - I);\r\n while (J <= Length(Text)) and CharIsWhiteSpace(Text[J]) do\r\n Inc(J);\r\n I := Length(Text);\r\n if Text[I] = ')' then\r\n Dec(I);\r\n Value := Copy(Text, J, I - J);\r\n State.IntegerValues[Name] := StrToInt(Value);\r\n NextToken;\r\nend;\r\n\r\nprocedure TJppParser.ParseSetBoolValue;\r\nvar\r\n I, J: Integer;\r\n Text, Name, Value: string;\r\nbegin\r\n I := 1;\r\n Text := Lexer.RawComment;\r\n while (I <= Length(Text)) and not CharIsWhiteSpace(Text[I]) do\r\n Inc(I);\r\n while (I <= Length(Text)) and CharIsWhiteSpace(Text[I]) do\r\n Inc(I);\r\n J := I;\r\n while (J <= Length(Text)) and CharIsValidIdentifierLetter(Text[J]) do\r\n Inc(J);\r\n Name := Copy(Text, I, J - I);\r\n while (J <= Length(Text)) and CharIsWhiteSpace(Text[J]) do\r\n Inc(J);\r\n I := Length(Text);\r\n if Text[I] = ')' then\r\n Dec(I);\r\n Value := Copy(Text, J, I - J);\r\n State.BoolValues[Name] := StrToBoolean(Value);\r\n NextToken;\r\nend;\r\n\r\nprocedure TJppParser.ParseText;\r\n\r\n procedure AddRawComment;\r\n begin\r\n AddResult(Lexer.RawComment);\r\n NextToken;\r\n end;\r\n\r\n procedure DeleteCurrentLineIfOrphaned;\r\n begin\r\n if not FAllWhiteSpaceIn and FAllWhiteSpaceOut then\r\n if FLineBreakPos <= FResultLen then\r\n begin\r\n FResultLen := FLineBreakPos - 1;\r\n FResult[FResultLen + 1] := #0;\r\n end;\r\n end;\r\n\r\nbegin\r\n while True do\r\n case Lexer.CurrTok of\r\n ptComment:\r\n begin\r\n if not (poStripComments in State.Options) then\r\n AddResult(Lexer.TokenAsString);\r\n NextToken;\r\n end;\r\n\r\n ptEof:\r\n begin\r\n DeleteCurrentLineIfOrphaned;\r\n Break;\r\n end;\r\n\r\n ptEol:\r\n begin\r\n AddResult(Lexer.TokenAsString);\r\n DeleteCurrentLineIfOrphaned;\r\n FLineBreakPos := FResultLen + 1;\r\n FAllWhiteSpaceIn := True;\r\n FAllWhiteSpaceOut := True;\r\n NextToken;\r\n end;\r\n\r\n ptText:\r\n begin\r\n AddResult(Lexer.TokenAsString);\r\n NextToken;\r\n end;\r\n\r\n ptDefine, ptJppDefine, ptUndef, ptJppUndef, ptIfdef, ptIfndef, ptIfopt:\r\n if poProcessDefines in State.Options then\r\n case Lexer.CurrTok of\r\n ptDefine:\r\n ParseDefine(False);\r\n ptJppDefine:\r\n ParseDefine(True);\r\n ptUndef:\r\n ParseUndef(False);\r\n ptJppUndef:\r\n ParseUndef(True);\r\n ptIfdef:\r\n ParseCondition(ptIfdef);\r\n ptIfndef:\r\n ParseCondition(ptIfndef);\r\n ptIfopt:\r\n ParseCondition(ptIfopt);\r\n end\r\n else\r\n AddRawComment;\r\n\r\n ptElse, ptEndif:\r\n if poProcessDefines in State.Options then\r\n Break\r\n else\r\n AddRawComment;\r\n\r\n ptInclude:\r\n if poProcessIncludes in State.Options then\r\n AddResult(ParseInclude)\r\n else\r\n AddRawComment;\r\n\r\n ptJppDefineMacro, ptJppExpandMacro, ptJppUndefMacro:\r\n if State.TriState = ttUndef then\r\n NextToken\r\n else\r\n if poProcessMacros in State.Options then\r\n case Lexer.CurrTok of\r\n ptJppDefineMacro:\r\n ParseDefineMacro;\r\n ptJppExpandMacro:\r\n ParseExpandMacro;\r\n ptJppUndefMacro:\r\n ParseUndefMacro;\r\n end\r\n else\r\n AddRawComment;\r\n\r\n ptJppGetStrValue,\r\n ptJppGetIntValue,\r\n ptJppGetBoolValue,\r\n ptJppSetStrValue,\r\n ptJppSetIntValue,\r\n ptJppSetBoolValue,\r\n ptJppLoop:\r\n if State.TriState = ttUndef then\r\n NextToken\r\n else\r\n if poProcessValues in State.Options then\r\n case Lexer.CurrTok of\r\n ptJppGetStrValue:\r\n ParseGetStrValue;\r\n ptJppGetIntValue:\r\n ParseGetIntValue;\r\n ptJppGetBoolValue:\r\n ParseGetBoolValue;\r\n ptJppSetStrValue:\r\n ParseSetStrValue;\r\n ptJppSetIntValue:\r\n ParseSetIntValue;\r\n ptJppSetBoolValue:\r\n ParseSetBoolValue;\r\n ptJppLoop:\r\n ParseLoop;\r\n end\r\n else\r\n AddRawComment;\r\n else\r\n Break;\r\n end;\r\nend;\r\n\r\n//=== { TPppState } ==========================================================\r\n\r\nconstructor TPppState.Create;\r\nbegin\r\n inherited Create;\r\n FStateStack := TJclStack.Create(16, True);\r\nend;\r\n\r\ndestructor TPppState.Destroy;\r\nbegin\r\n FStateStack := nil;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TPppState.AddFileToExclusionList(const AName: string);\r\nbegin\r\n InternalPeekExcludedFiles.Add(AName);\r\nend;\r\n\r\nprocedure TPppState.AddToSearchPath(const AName: string);\r\nbegin\r\n InternalPeekSearchPath.Add(AName);\r\nend;\r\n\r\nprocedure TPppState.AfterConstruction;\r\nvar\r\n StateItem: TPppStateItem;\r\nbegin\r\n StateItem := StateItemClass.Create;\r\n InternalPushState(nil, StateItem);\r\n FStateStack.Push(StateItem);\r\nend;\r\n\r\nfunction TPppState.AssociateParameters(const ParamNames: IJclStrList;\r\n const ParamValues: TDynStringArray): TDynWideStringArray;\r\nvar\r\n StrParams: TStrings;\r\n AssociationByName: Boolean;\r\n Index, ParamIndex: Integer;\r\n AParamName, AParamText: string;\r\nbegin\r\n SetLength(Result, Length(ParamValues));\r\n AssociationByName := True;\r\n StrParams := TStringList.Create;\r\n try\r\n for Index := Low(ParamValues) to High(ParamValues) do\r\n begin\r\n StrParams.Add(ParamValues[Index]);\r\n AParamName := StrParams.Names[Index];\r\n if Assigned(ParamNames) and (AParamName <> '') then\r\n begin\r\n // verify parameter names\r\n ParamIndex := ParamNames.IndexOf(AParamName);\r\n if ParamIndex < 0 then\r\n AssociationByName := False;\r\n end\r\n else\r\n AssociationByName := False;\r\n end;\r\n for Index := Low(ParamValues) to High(ParamValues) do\r\n begin\r\n if AssociationByName then\r\n AParamText := StrParams.Values[ParamNames.Strings[Index]]\r\n else\r\n AParamText := StrParams.Strings[Index];\r\n Result[Index] := WideString(AParamText);\r\n end;\r\n finally\r\n StrParams.Free;\r\n end;\r\nend;\r\n\r\nfunction TPppState.ExpandMacro(const AName: string;\r\n const ParamValues: TDynStringArray): string;\r\nvar\r\n AMacro: IJclStrList;\r\n AMacroName, AMacroText: string;\r\n Index: Integer;\r\n Params: array of TVarRec;\r\n AMacroParams: TDynWideStringArray;\r\nbegin\r\n AMacroName := Format('%s`%d', [AName, Length(ParamValues)]);\r\n AMacro := FindMacro(AMacroName);\r\n // the macro text is the last item, previous items are the macro parameter names\r\n AMacroText := AMacro.Strings[AMacro.Size - 1];\r\n AMacroParams := AssociateParameters(AMacro.SubList(0, AMacro.Size - 1), ParamValues);\r\n\r\n SetLength(Params, Length(ParamValues));\r\n for Index := Low(ParamValues) to High(ParamValues) do\r\n begin\r\n Params[Index].VType := vtPWideChar;\r\n Params[Index].VPWideChar := PWideChar(AMacroParams[Index]);\r\n end;\r\n Result := Format(AMacroText, Params);\r\nend;\r\n\r\nprocedure TPppState.Define(const ASymbol: string);\r\nbegin\r\n Defines[ASymbol] := ttDefined;\r\nend;\r\n\r\nprocedure TPppState.DefineMacro(const AName: string;\r\n const ParamNames: TDynStringArray; const Value: string);\r\nvar\r\n AMacro: IJclStrList;\r\n AMacros: IJclStrIntfMap;\r\n AMacroNames: IJclStrIterator;\r\n AMacroName, AMacroFormat: string;\r\n Index: Integer;\r\nbegin\r\n AMacros := InternalPeekMacros;\r\n AMacroName := Format('%s`%d', [AName, Length(ParamNames)]);\r\n AMacroNames := AMacros.KeySet.First;\r\n while AMacroNames.HasNext do\r\n if JclStrings.StrSame(AMacroNames.Next, AMacroName) then\r\n raise EPppState.CreateFmt('macro \"%s\" is already defined', [AName]);\r\n AMacroFormat := Value;\r\n AMacro := TJclStrArrayList.Create(16);\r\n for Index := Low(ParamNames) to High(ParamNames) do\r\n begin\r\n StrReplace(AMacroFormat, ParamNames[Index], '%' + IntToStr(Index) + ':s', [rfReplaceAll, rfIgnoreCase]);\r\n // the first elements in the list are the macro parameter names\r\n AMacro.Add(ParamNames[Index]);\r\n end;\r\n // the macro text is the last element in the list\r\n AMacro.Add(AMacroFormat);\r\n AMacros.Items[AMacroName] := AMacro;\r\nend;\r\n\r\nfunction TPppState.FindFile(const AName: string): TStream;\r\nvar\r\n i: Integer;\r\n fn: string;\r\n Found: Boolean;\r\n ASearchPath: IJclStrList;\r\nbegin\r\n ASearchPath := InternalPeekSearchPath;\r\n fn := AName;\r\n Found := FileExists(fn);\r\n if not Found then\r\n for i := 0 to ASearchPath.Size - 1 do\r\n begin\r\n fn := ASearchPath.Strings[i] + PathDelim + AName;\r\n if FileExists(fn) then\r\n begin\r\n Found := True;\r\n Break;\r\n end;\r\n end;\r\n if not Found then\r\n raise EPppState.CreateFmt('File not found: %s', [AName]);\r\n Result := TFileStream.Create(fn, fmOpenRead or fmShareDenyWrite);\r\nend;\r\n\r\nfunction TPppState.FindMacro(const AMacroName: string): IJclStrList;\r\nvar\r\n AMacros: IJclStrIntfMap;\r\n AMacroNames: IJclStrIterator;\r\nbegin\r\n AMacros := InternalPeekMacros;\r\n AMacroNames := AMacros.KeySet.First;\r\n while AMacroNames.HasNext do\r\n begin\r\n if JclStrings.StrSame(AMacroNames.Next, AMacroName) then\r\n begin\r\n Result := AMacros.Items[AMacroNames.GetString] as IJclStrList;\r\n Exit;\r\n end;\r\n end;\r\n raise EPppState.CreateFmt('unknown macro \"%s\"', [AMacroName]);\r\nend;\r\n\r\nfunction TPppState.GetBoolValue(const Name: string): Boolean;\r\nvar\r\n VariantValue: Variant;\r\nbegin\r\n VariantValue := GetPropValue(Self, Name);\r\n Result := Boolean(VariantValue);\r\nend;\r\n\r\nfunction TPppState.GetIntegerValue(const Name: string): Integer;\r\nvar\r\n VariantValue: Variant;\r\nbegin\r\n VariantValue := GetPropValue(Self, Name);\r\n Result := Integer(VariantValue);\r\nend;\r\n\r\nfunction TPppState.GetStringValue(const Name: string): string;\r\nvar\r\n VariantValue: Variant;\r\nbegin\r\n VariantValue := GetPropValue(Self, Name, True);\r\n Result := string(VariantValue);\r\nend;\r\n\r\nfunction TPppState.GetOptions: TPppOptions;\r\nbegin\r\n Result := FOptions;\r\nend;\r\n\r\nfunction TPppState.GetDefine(const ASymbol: string): TTriState;\r\nvar\r\n ADefines: IJclStrMap;\r\n ASymbolNames: IJclStrIterator;\r\n PI: PPropInfo;\r\n PV: Variant;\r\nbegin\r\n Result := ttUnknown;\r\n ADefines := InternalPeekDefines;\r\n ASymbolNames := ADefines.KeySet.First;\r\n while ASymbolNames.HasNext do\r\n begin\r\n if JclStrings.StrSame(ASymbolNames.Next, ASymbol) then\r\n begin\r\n Result := TTriState(ADefines.Items[ASymbolNames.GetString]);\r\n Break;\r\n end;\r\n end;\r\n if Result = ttUnknown then\r\n begin\r\n PI := GetPropInfo(Self, ASymbol);\r\n if Assigned(PI) then\r\n begin\r\n {$IFDEF COMPILER8_UP}\r\n PV := GetPropValue(Self, PI);\r\n {$ELSE ~COMPILER8_UP}\r\n PV := GetPropValue(Self, PI^.Name);\r\n {$ENDIF ~COMPILER8_UP}\r\n if Boolean(PV) then\r\n Result := ttDefined\r\n else\r\n Result := ttUndef;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TPppState.InternalPeekDefines: IJclStrMap;\r\nbegin\r\n Result := PeekStateItem.DefinedKeywords;\r\nend;\r\n\r\nfunction TPppState.InternalPeekExcludedFiles: IJclStrList;\r\nbegin\r\n Result := PeekStateItem.ExcludedFiles;\r\nend;\r\n\r\nfunction TPppState.InternalPeekMacros: IJclStrIntfMap;\r\nbegin\r\n Result := PeekStateItem.Macros;\r\nend;\r\n\r\nfunction TPppState.InternalPeekSearchPath: IJclStrList;\r\nbegin\r\n Result := PeekStateItem.SearchPath;\r\nend;\r\n\r\nfunction TPppState.InternalPeekTriState: TTriState;\r\nbegin\r\n Result := PeekStateItem.TriState;\r\nend;\r\n\r\nprocedure TPppState.InternalPushState(FromStateItem, ToStateItem: TPppStateItem);\r\nbegin\r\n if Assigned(FromStateItem) then\r\n begin\r\n // clone\r\n ToStateItem.DefinedKeywords := (FromStateItem.DefinedKeywords as IJclIntfCloneable).IntfClone as IJclStrMap;\r\n ToStateItem.ExcludedFiles := (FromStateItem.ExcludedFiles as IJclIntfCloneable).IntfClone as IJclStrList;\r\n ToStateItem.Macros := (FromStateItem.Macros as IJclIntfCloneable).IntfClone as IJclStrIntfMap;\r\n ToStateItem.SearchPath := (FromStateItem.SearchPath as IJclIntfCloneable).IntfClone as IJclStrList;\r\n ToStateItem.TriState := FromStateItem.TriState;\r\n end\r\n else\r\n begin\r\n // create the first item\r\n ToStateItem.DefinedKeywords := TJclStrHashMap.Create(16, False);\r\n ToStateItem.ExcludedFiles := TJclStrArrayList.Create(16);\r\n ToStateItem.Macros := TJclStrIntfHashMap.Create(16);\r\n ToStateItem.SearchPath := TJclStrArrayList.Create(16);\r\n ToStateItem.TriState := ttDefined;\r\n end;\r\nend;\r\n\r\nprocedure TPppState.InternalSetTriState(Value: TTriState);\r\nvar\r\n APppStateItem: TPppStateItem;\r\nbegin\r\n APppStateItem := PeekStateItem;\r\n if APppStateItem.TriState <> ttUndef then\r\n APppStateItem.TriState := Value;\r\nend;\r\n\r\nfunction TPppState.IsFileExcluded(const AName: string): Boolean;\r\nvar\r\n AExcludedFiles: IJclStrList;\r\n AFileNames: IJclStrIterator;\r\nbegin\r\n AExcludedFiles := InternalPeekExcludedFiles;\r\n AFileNames := AExcludedFiles.First;\r\n Result := False;\r\n while AFileNames.HasNext do\r\n begin\r\n if JclStrings.StrSame(AFileNames.Next, AName) then\r\n begin\r\n Result := True;\r\n Break;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TPppState.PeekStateItem: TPppStateItem;\r\nbegin\r\n if FStateStack.Empty then\r\n raise EPppState.Create('Internal error: PPP State stack is empty');\r\n Result := FStateStack.Peek as TPppStateItem; \r\nend;\r\n\r\nprocedure TPppState.PopState;\r\nbegin\r\n if FStateStack.Size <= 1 then\r\n raise EPppState.Create('Internal error: PPP State stack underflow');\r\n FStateStack.Pop.Free;\r\nend;\r\n\r\nprocedure TPppState.PushState;\r\nvar\r\n FromStateItem, ToStateItem: TPppStateItem;\r\nbegin\r\n FromStateItem := PeekStateItem;\r\n ToStateItem := StateItemClass.Create;\r\n InternalPushState(FromStateItem, ToStateItem);\r\n FStateStack.Push(ToStateItem);\r\nend;\r\n\r\nprocedure TPppState.SetOptions(AOptions: TPppOptions);\r\nbegin\r\n FOptions := AOptions;\r\nend;\r\n\r\nprocedure TPppState.SetBoolValue(const Name: string; Value: Boolean);\r\nvar\r\n VariantValue: Variant;\r\nbegin\r\n VariantValue := Value;\r\n SetPropValue(Self, Name, VariantValue);\r\nend;\r\n\r\nprocedure TPppState.SetDefine(const ASymbol: string;\r\n const Value: TTriState);\r\nvar\r\n ADefines: IJclStrMap;\r\n ASymbolNames: IJclStrIterator;\r\n PI: PPropInfo;\r\nbegin\r\n ADefines := InternalPeekDefines;\r\n ASymbolNames := ADefines.KeySet.First;\r\n while ASymbolNames.HasNext do\r\n begin\r\n if JclStrings.StrSame(ASymbolNames.Next, ASymbol) then\r\n begin\r\n ADefines.Items[ASymbolNames.GetString] := TObject(Value);\r\n Exit;\r\n end;\r\n end;\r\n if Value <> ttUnknown then\r\n begin\r\n PI := GetPropInfo(Self, ASymbol);\r\n if Assigned(PI) then\r\n begin\r\n if Value = ttDefined then\r\n {$IFDEF COMPILER8_UP}\r\n SetPropValue(Self, PI, True)\r\n {$ELSE ~COMPILER8_UP}\r\n SetPropValue(Self, PI^.Name, True)\r\n {$ENDIF ~COMPILER8_UP}\r\n else\r\n {$IFDEF COMPILER8_UP}\r\n SetPropValue(Self, PI, False);\r\n {$ELSE ~COMPILER8_UP}\r\n SetPropValue(Self, PI^.Name, False);\r\n {$ENDIF ~COMPILER8_UP}\r\n Exit;\r\n end;\r\n end;\r\n ADefines.Items[ASymbol] := TObject(Value);\r\nend;\r\n\r\nprocedure TPppState.SetIntegerValue(const Name: string; Value: Integer);\r\nvar\r\n VariantValue: Variant;\r\nbegin\r\n VariantValue := Value;\r\n SetPropValue(Self, Name, VariantValue);\r\nend;\r\n\r\nprocedure TPppState.SetStringValue(const Name, Value: string);\r\nvar\r\n VariantValue: Variant;\r\nbegin\r\n VariantValue := Value;\r\n SetPropValue(Self, Name, VariantValue);\r\nend;\r\n\r\nclass function TPppState.StateItemClass: TPppStateItemClass;\r\nbegin\r\n Result := TPppStateItem;\r\nend;\r\n\r\nprocedure TPppState.Undef(const ASymbol: string);\r\nbegin\r\n Defines[ASymbol] := ttUndef;\r\nend;\r\n\r\nprocedure TPppState.UndefMacro(const AName: string; const ParamNames: TDynStringArray);\r\nvar\r\n AMacros: IJclStrIntfMap;\r\n AMacroNames: IJclStrIterator;\r\n AMacroName: string;\r\nbegin\r\n AMacros := InternalPeekMacros;\r\n AMacroName := Format('%s`%d', [AName, Length(ParamNames)]);\r\n AMacroNames := AMacros.KeySet.First;\r\n while AMacroNames.HasNext do\r\n if JclStrings.StrSame(AMacroNames.Next, AMacroName) then\r\n AMacros.Remove(AMacroNames.GetString);\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jcl/source/common/JclPreProcessorQueuesTemplates.pas", "content": "{**************************************************************************************************}\r\n{ }\r\n{ Project JEDI Code Library (JCL) }\r\n{ }\r\n{ The contents of this file are subject to the Mozilla Public License Version 1.1 (the \"License\"); }\r\n{ you may not use this file except in compliance with the License. You may obtain a copy of the }\r\n{ License at http://www.mozilla.org/MPL/ }\r\n{ }\r\n{ Software distributed under the License is distributed on an \"AS IS\" basis, WITHOUT WARRANTY OF }\r\n{ ANY KIND, either express or implied. See the License for the specific language governing rights }\r\n{ and limitations under the License. }\r\n{ }\r\n{ The Original Code is JclQueuesTemplates.pas. }\r\n{ }\r\n{ The Initial Developer of the Original Code is Florent Ouchet }\r\n{ }\r\n{ Portions created by Florent Ouchet are Copyright (C) of Florent Ouchet. All rights reserved. }\r\n{ }\r\n{ Contributors: }\r\n{ }\r\n{**************************************************************************************************}\r\n{ }\r\n{ Last modified: $Date:: 2012-02-23 21:46:07 +0100 (jeu. 23 févr. 2012) $ }\r\n{ Revision: $Rev:: 3740 $ }\r\n{ Author: $Author:: outchy $ }\r\n{ }\r\n{**************************************************************************************************}\r\n\r\nunit JclPreProcessorQueuesTemplates;\r\n\r\ninterface\r\n\r\n{$I jcl.inc}\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n JclPreProcessorContainerTypes,\r\n JclPreProcessorContainerTemplates,\r\n JclPreProcessorContainer1DTemplates;\r\n\r\ntype\r\n (* JCLQUEUEINT(SELFCLASSNAME, QUEUEINTERFACENAME, ANCESTORCLASSNAME, DYNARRAYTYPENAME,\r\n EQUALITYCOMPARERINTERFACENAME, INTERFACEADDITIONAL, SECTIONADDITIONAL,\r\n OWNERSHIPDECLARATION, CONSTKEYWORD, PARAMETERNAME, TYPENAME) *)\r\n TJclQueueIntParams = class(TJclClassInterfaceParams)\r\n protected\r\n // function CodeUnit: string; override;\r\n public\r\n function AliasAttributeIDs: TAllTypeAttributeIDs; override;\r\n published\r\n property SelfClassName: string index taQueueClassName read GetTypeAttribute write SetTypeAttribute stored IsTypeAttributeStored;\r\n property BaseContainerInterfaceName: string index taContainerInterfaceName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property QueueInterfaceName: string index taQueueInterfaceName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property AncestorClassName;\r\n property DynArrayTypeName: string index taDynArrayTypeName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property EqualityComparerInterfaceName: string index taEqualityComparerInterfaceName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property InterfaceAdditional;\r\n property SectionAdditional;\r\n property OwnershipDeclaration;\r\n property ConstKeyword: string index taConstKeyword read GetTypeAttribute write SetTypeAttribute stored False;\r\n property ParameterName: string index taParameterName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property TypeName: string index taTypeName read GetTypeAttribute write SetTypeAttribute stored False;\r\n end;\r\n\r\n (* JCLQUEUEIMP(SELFCLASSNAME, OWNERSHIPDECLARATION, OWNERSHIPPARAMETERNAME, MOVEARRAYPROCEDURENAME,\r\n CONSTKEYWORD, PARAMETERNAME, TYPENAME, DEFAULTVALUE, RELEASERFUNCTIONNAME) *)\r\n TJclQueueImpParams = class(TJclClassImplementationParams)\r\n protected\r\n // function CodeUnit: string; override;\r\n public\r\n function GetConstructorParameters: string; override;\r\n function GetSelfClassName: string; override;\r\n published\r\n property SelfClassName: string index taQueueClassName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property OwnershipDeclaration;\r\n property OwnershipParameterName: string index taOwnershipParameterName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property MoveArrayProcedureName: string index taMoveArrayProcedureName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property ConstKeyword: string index taConstKeyword read GetTypeAttribute write SetTypeAttribute stored False;\r\n property ParameterName: string index taParameterName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property TypeName: string index taTypeName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property DefaultValue: string index taDefaultValue read GetTypeAttribute write SetTypeAttribute stored False;\r\n property ReleaserFunctionName: string index taReleaserFunctionName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property MacroFooter;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jcl.svn.sourceforge.net/svnroot/jcl/tags/JCL-2.4-Build4571/jcl/source/common/JclPreProcessorQueuesTemplates.pas $';\r\n Revision: '$Revision: 3740 $';\r\n Date: '$Date: 2012-02-23 21:46:07 +0100 (jeu. 23 févr. 2012) $';\r\n LogPath: 'JCL\\source\\common';\r\n Extra: '';\r\n Data: nil\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n {$IFDEF HAS_UNITSCOPE}\r\n System.SysUtils,\r\n {$ELSE ~HAS_UNITSCOPE}\r\n SysUtils,\r\n {$ENDIF ~HAS_UNITSCOPE}\r\n JclStrings;\r\n\r\nprocedure RegisterJclContainers;\r\nbegin\r\n RegisterContainerParams('JCLQUEUEINT', TJclQueueIntParams);\r\n RegisterContainerParams('JCLQUEUEIMP', TJclQueueImpParams, TJclQueueIntParams);\r\nend;\r\n\r\n//=== { TJclQueueIntParams } =================================================\r\n\r\nfunction TJclQueueIntParams.AliasAttributeIDs: TAllTypeAttributeIDs;\r\nbegin\r\n Result := [taQueueClassName];\r\nend;\r\n\r\n//=== { TJclQueueImpParams } =================================================\r\n\r\nfunction TJclQueueImpParams.GetConstructorParameters: string;\r\nbegin\r\n Result := 'Size + 1';\r\nend;\r\n\r\nfunction TJclQueueImpParams.GetSelfClassName: string;\r\nbegin\r\n Result := SelfClassName;\r\nend;\r\n\r\ninitialization\r\n RegisterJclContainers;\r\n {$IFDEF UNITVERSIONING}\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n {$ENDIF UNITVERSIONING}\r\n\r\nfinalization\r\n {$IFDEF UNITVERSIONING}\r\n UnregisterUnitVersion(HInstance);\r\n {$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n\r\n" }, { "path": "External/Jedi/Jcl/source/common/JclPreProcessorSortedMapsTemplates.pas", "content": "{**************************************************************************************************}\r\n{ }\r\n{ Project JEDI Code Library (JCL) }\r\n{ }\r\n{ The contents of this file are subject to the Mozilla Public License Version 1.1 (the \"License\"); }\r\n{ you may not use this file except in compliance with the License. You may obtain a copy of the }\r\n{ License at http://www.mozilla.org/MPL/ }\r\n{ }\r\n{ Software distributed under the License is distributed on an \"AS IS\" basis, WITHOUT WARRANTY OF }\r\n{ ANY KIND, either express or implied. See the License for the specific language governing rights }\r\n{ and limitations under the License. }\r\n{ }\r\n{ The Original Code is JclSortedMapsTemplates.pas. }\r\n{ }\r\n{ The Initial Developer of the Original Code is Florent Ouchet }\r\n{ }\r\n{ Portions created by Florent Ouchet are Copyright (C) of Florent Ouchet. All rights reserved. }\r\n{ }\r\n{ Contributors: }\r\n{ }\r\n{**************************************************************************************************}\r\n{ }\r\n{ Last modified: $Date:: 2012-02-24 12:27:42 +0100 (ven. 24 févr. 2012) $ }\r\n{ Revision: $Rev:: 3747 $ }\r\n{ Author: $Author:: outchy $ }\r\n{ }\r\n{**************************************************************************************************}\r\n\r\nunit JclPreProcessorSortedMapsTemplates;\r\n\r\ninterface\r\n\r\n{$I jcl.inc}\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n JclPreProcessorContainerTypes,\r\n JclPreProcessorContainerTemplates,\r\n JclPreProcessorContainer2DTemplates;\r\n\r\ntype\r\n (* JCLSORTEDMAPTYPESINT(ENTRYTYPENAME, ENTRYARRAYTYPENAME, KEYTYPENAME, VALUETYPENAME) *)\r\n TJclSortedMapTypeIntParams = class(TJclMapInterfaceParams)\r\n public\r\n function AliasAttributeIDs: TAllTypeAttributeIDs; override;\r\n published\r\n property EntryTypeName: string index maSortedMapEntryTypeName read GetMapAttribute write SetMapAttribute stored IsMapAttributeStored;\r\n property EntryArrayTypeName: string index maSortedMapEntryArrayTypeName read GetMapAttribute write SetMapAttribute stored IsMapAttributeStored;\r\n property KeyTypeName: string index kaKeyTypeName read GetKeyAttribute write SetKeyAttribute stored False;\r\n property ValueTypeName: string index vaValueTypeName read GetValueAttribute write SetValueAttribute stored False;\r\n end;\r\n\r\n (* JCLSORTEDMAPINT(ENTRYTYPENAME, ENTRYARRAYTYPENAME, SELFCLASSNAME, ANCESTORNAME,\r\n STDMAPINTERFACENAME, SORTEDMAPINTERFACENAME,\r\n KEYSETINTERFACENAME, VALUECOLLECTIONINTERFACENAME,\r\n INTERFACEADDITIONAL, SECTIONADDITIONAL, KEYOWNERSHIPDECLARATION,\r\n VALUEOWNERSHIPDECLARATION, KEYCONSTKEYWORD, KEYTYPENAME,\r\n VALUECONSTKEYWORD, VALUETYPENAME) *)\r\n TJclSortedMapIntParams = class(TJclMapClassInterfaceParams)\r\n protected\r\n // function CodeUnit: string; override;\r\n //function GetInterfaceAdditional: string; override;\r\n public\r\n function AliasAttributeIDs: TAllTypeAttributeIDs; override;\r\n function GetComparisonSectionAdditional: string; override;\r\n published\r\n property EntryTypeName: string index maSortedMapEntryTypeName read GetMapAttribute write SetMapAttribute stored False;\r\n property EntryArrayTypeName: string index maSortedMapEntryArrayTypeName read GetMapAttribute write SetMapAttribute stored False;\r\n property SelfClassName: string index maSortedMapClassName read GetMapAttribute write SetMapAttribute stored IsMapAttributeStored;\r\n property AncestorName: string index maMapAncestorClassName read GetMapAttribute write SetMapAttribute stored False;\r\n property StdMapInterfaceName: string index maMapInterfaceName read GetMapAttribute write SetMapAttribute stored False;\r\n property SortedMapInterfaceName: string index maSortedMapInterfaceName read GetMapAttribute write SetMapAttribute stored False;\r\n property KeySetInterfaceName: string index kaKeySetInterfaceName read GetKeyAttribute write SetKeyAttribute stored False;\r\n property ValueCollectionInterfaceName: string index vaValueCollectionInterfaceName read GetValueAttribute write SetValueAttribute stored False;\r\n property InterfaceAdditional;\r\n property SectionAdditional;\r\n property KeyOwnershipDeclaration;\r\n property ValueOwnershipDeclaration;\r\n property KeyConstKeyword: string index kaKeyConstKeyword read GetKeyAttribute write SetKeyAttribute stored False;\r\n property KeyTypeName;\r\n property ValueConstKeyword: string index vaValueConstKeyword read GetValueAttribute write SetValueAttribute stored False;\r\n property ValueTypeName;\r\n end;\r\n\r\n (* JCLSORTEDMAPIMP(ENTRYTYPENAME, ENTRYARRAYTYPENAME, SELFCLASSNAME,\r\n STDMAPINTERFACENAME, SORTEDMAPINTERFACENAME,\r\n KEYSETINTERFACENAME, KEYITRINTERFACENAME,\r\n VALUECOLLECTIONINTERFACENAME,\r\n KEYOWNERSHIPDECLARATION, VALUEOWNERSHIPDECLARATION,\r\n OWNERSHIPASSIGNMENTS, KEYCONSTKEYWORD, KEYTYPENAME, KEYDEFAULT,\r\n VALUECONSTKEYWORD, VALUETYPENAME, VALUEDEFAULT,\r\n CREATEKEYSET, CREATEVALUECOLLECTION) *)\r\n TJclSortedMapImpParams = class(TJclMapClassImplementationParams)\r\n protected\r\n // function CodeUnit: string; override;\r\n public\r\n function GetConstructorParameters: string; override;\r\n function GetMacroFooter: string; override;\r\n function GetSelfClassName: string; override;\r\n published\r\n property EntryTypeName: string index maSortedMapEntryTypeName read GetMapAttribute write SetMapAttribute stored False;\r\n property EntryArrayTypeName: string index maSortedMapEntryArrayTypeName read GetMapAttribute write SetMapAttribute stored False;\r\n property SelfClassName: string index maSortedMapClassName read GetMapAttribute write SetMapAttribute stored False;\r\n property AncestorClassName: string index maMapAncestorClassName read GetMapAttribute write SetMapAttribute stored False;\r\n property StdMapInterfaceName: string index maMapInterfaceName read GetMapAttribute write SetMapAttribute stored False;\r\n property SortedMapInterfaceName: string index maSortedMapInterfaceName read GetMapAttribute write SetMapAttribute stored False;\r\n property KeySetInterfaceName: string index kaKeySetInterfaceName read GetKeyAttribute write SetKeyAttribute stored False;\r\n property KeyItrInterfaceName: string index kaKeyIteratorInterfaceName read GetKeyAttribute write SetKeyAttribute stored False;\r\n property ValueCollectionInterfaceName: string index vaValueCollectionInterfaceName read GetValueAttribute write SetValueAttribute stored False;\r\n property KeyOwnershipDeclaration;\r\n property ValueOwnershipDeclaration;\r\n property OwnershipAssignments;\r\n property KeyConstKeyword: string index kaKeyConstKeyword read GetKeyAttribute write SetKeyAttribute stored False;\r\n property KeyTypeName;\r\n property KeyDefault;\r\n property KeySimpleCompareFunctionName: string index kaKeySimpleCompareFunctionName read GetKeyAttribute write SetKeyAttribute stored False;\r\n property KeyBaseContainer: string index kaKeyBaseContainerClassName read GetKeyAttribute write SetKeyAttribute stored False;\r\n property ValueConstKeyword: string index vaValueConstKeyword read GetValueAttribute write SetValueAttribute stored False;\r\n property ValueTypeName;\r\n property ValueDefault;\r\n property ValueSimpleCompareFunctionName: string index vaValueSimpleCompareFunctionName read GetValueAttribute write SetValueAttribute stored False;\r\n property ValueBaseContainerClassName: string index vaValueBaseContainerClassName read GetValueAttribute write SetValueAttribute stored False;\r\n property CreateKeySet;\r\n property CreateValueCollection;\r\n property MacroFooter;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jcl.svn.sourceforge.net/svnroot/jcl/tags/JCL-2.4-Build4571/jcl/source/common/JclPreProcessorSortedMapsTemplates.pas $';\r\n Revision: '$Revision: 3747 $';\r\n Date: '$Date: 2012-02-24 12:27:42 +0100 (ven. 24 févr. 2012) $';\r\n LogPath: 'JCL\\source\\common';\r\n Extra: '';\r\n Data: nil\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n {$IFDEF HAS_UNITSCOPE}\r\n System.SysUtils,\r\n {$ELSE ~HAS_UNITSCOPE}\r\n SysUtils,\r\n {$ENDIF ~HAS_UNITSCOPE}\r\n JclStrings;\r\n\r\nprocedure RegisterJclContainers;\r\nbegin\r\n RegisterContainerParams('JCLSORTEDMAPTYPESINT', TJclSortedMapTypeIntParams);\r\n RegisterContainerParams('JCLSORTEDMAPINT', TJclSortedMapIntParams);\r\n RegisterContainerParams('JCLSORTEDMAPIMP', TJclSortedMapImpParams, TJclSortedMapIntParams);\r\nend;\r\n\r\n//=== { TJclSortedMapTypeIntParams } =========================================\r\n\r\nfunction TJclSortedMapTypeIntParams.AliasAttributeIDs: TAllTypeAttributeIDs;\r\nbegin\r\n Result := [maSortedMapEntryTypeName];\r\nend;\r\n\r\n//=== { TJclSortedMapIntParams } =============================================\r\n\r\nfunction TJclSortedMapIntParams.AliasAttributeIDs: TAllTypeAttributeIDs;\r\nbegin\r\n Result := [maSortedMapClassName];\r\nend;\r\n\r\nfunction TJclSortedMapIntParams.GetComparisonSectionAdditional: string;\r\nbegin\r\n Result := Format(' function KeysCompare(%sA, B: %s): Integer;' + NativeLineBreak +\r\n ' function ValuesCompare(%sA, B: %s): Integer;',\r\n [KeyConstKeyword, KeyTypeName, ValueConstKeyword, ValueTypeName]);\r\nend;\r\n\r\n//=== { TJclSortedMapImpParams } =============================================\r\n\r\nfunction TJclSortedMapImpParams.GetConstructorParameters: string;\r\nbegin\r\n Result := 'FSize';\r\nend;\r\n\r\nfunction TJclSortedMapImpParams.GetMacroFooter: string;\r\nvar\r\n FuncName: string;\r\nbegin\r\n Result := inherited GetMacroFooter;\r\n if (FMacroFooter = '') and MapInfo.KnownMap then\r\n begin\r\n if AncestorClassName = KeyBaseContainer then\r\n FuncName := 'ItemsCompare'\r\n else\r\n FuncName := KeySimpleCompareFunctionName;\r\n\r\n Result := Format('%s' + NativeLineBreak +\r\n 'function %s.KeysCompare(%sA, B: %s): Integer;' + NativeLineBreak +\r\n 'begin' + NativeLineBreak +\r\n ' Result := %s(A, B);' + NativeLineBreak +\r\n 'end;' + NativeLineBreak,\r\n [Result, SelfClassName, KeyConstKeyword, KeyTypeName, FuncName]);\r\n\r\n if AncestorClassName = ValueBaseContainerClassName then\r\n FuncName := 'ItemsCompare'\r\n else\r\n FuncName := ValueSimpleCompareFunctionName;\r\n\r\n Result := Format('%s' + NativeLineBreak +\r\n 'function %s.ValuesCompare(%sA, B: %s): Integer;' + NativeLineBreak +\r\n 'begin' + NativeLineBreak +\r\n ' Result := %s(A, B);' + NativeLineBreak +\r\n 'end;' + NativeLineBreak,\r\n [Result, SelfClassName, ValueConstKeyword, ValueTypeName, FuncName]);\r\n end;\r\nend;\r\n\r\nfunction TJclSortedMapImpParams.GetSelfClassName: string;\r\nbegin\r\n Result := SelfClassName;\r\nend;\r\n\r\ninitialization\r\n RegisterJclContainers;\r\n {$IFDEF UNITVERSIONING}\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n {$ENDIF UNITVERSIONING}\r\n\r\nfinalization\r\n {$IFDEF UNITVERSIONING}\r\n UnregisterUnitVersion(HInstance);\r\n {$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n\r\n" }, { "path": "External/Jedi/Jcl/source/common/JclPreProcessorStacksTemplates.pas", "content": "{**************************************************************************************************}\r\n{ }\r\n{ Project JEDI Code Library (JCL) }\r\n{ }\r\n{ The contents of this file are subject to the Mozilla Public License Version 1.1 (the \"License\"); }\r\n{ you may not use this file except in compliance with the License. You may obtain a copy of the }\r\n{ License at http://www.mozilla.org/MPL/ }\r\n{ }\r\n{ Software distributed under the License is distributed on an \"AS IS\" basis, WITHOUT WARRANTY OF }\r\n{ ANY KIND, either express or implied. See the License for the specific language governing rights }\r\n{ and limitations under the License. }\r\n{ }\r\n{ The Original Code is JclStacksTemplates.pas. }\r\n{ }\r\n{ The Initial Developer of the Original Code is Florent Ouchet }\r\n{ }\r\n{ Portions created by Florent Ouchet are Copyright (C) of Florent Ouchet. All rights reserved. }\r\n{ }\r\n{ Contributors: }\r\n{ }\r\n{**************************************************************************************************}\r\n{ }\r\n{ Last modified: $Date:: 2012-02-20 19:48:39 +0100 (lun. 20 févr. 2012) $ }\r\n{ Revision: $Rev:: 3737 $ }\r\n{ Author: $Author:: outchy $ }\r\n{ }\r\n{**************************************************************************************************}\r\n\r\nunit JclPreProcessorStacksTemplates;\r\n\r\ninterface\r\n\r\n{$I jcl.inc}\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n JclPreProcessorContainerTypes,\r\n JclPreProcessorContainerTemplates,\r\n JclPreProcessorContainer1DTemplates;\r\n\r\ntype\r\n (* JCLSTACKINT(SELFCLASSNAME, BASECONTAINERINTERFACENAME, STACKINTERFACENAME, ANCESTORCLASSNAME, DYNARRAYTYPENAME,\r\n EQUALITYCOMPARERINTERFACENAME, INTERFACEADDITIONAL, SECTIONADDITIONAL,\r\n OWNERSHIPDECLARATION, CONSTKEYWORD, PARAMETERNAME, TYPENAME) *)\r\n TJclStackIntParams = class(TJclClassInterfaceParams)\r\n protected\r\n // function CodeUnit: string; override;\r\n public\r\n function AliasAttributeIDs: TAllTypeAttributeIDs; override;\r\n published\r\n property SelfClassName: string index taStackClassName read GetTypeAttribute write SetTypeAttribute stored IsTypeAttributeStored;\r\n property BaseContainerInterfaceName: string index taContainerInterfaceName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property StackInterfaceName: string index taStackInterfaceName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property EqualityComparerInterfaceName: string index taEqualityComparerInterfaceName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property AncestorClassName;\r\n property DynArrayTypeName: string index taDynArrayTypeName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property InterfaceAdditional;\r\n property SectionAdditional;\r\n property OwnershipDeclaration;\r\n property ConstKeyword: string index taConstKeyword read GetTypeAttribute write SetTypeAttribute stored False;\r\n property ParameterName: string index taParameterName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property TypeName: string index taTypeName read GetTypeAttribute write SetTypeAttribute stored False;\r\n end;\r\n\r\n (* JCLSTACKIMP(SELFCLASSNAME, OWNERSHIPDECLARATION, OWNERSHIPPARAMETERNAME, CONSTKEYWORD,\r\n PARAMETERNAME, TYPENAME, DEFAULTVALUE, RELEASERFUNCTIONNAME) *)\r\n TJclStackImpParams = class(TJclClassImplementationParams)\r\n protected\r\n // function CodeUnit: string; override;\r\n public\r\n function GetConstructorParameters: string; override;\r\n function GetSelfClassName: string; override;\r\n published\r\n property SelfClassName: string index taStackClassName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property OwnershipDeclaration;\r\n property OwnershipParameterName: string index taOwnershipParameterName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property ConstKeyword: string index taConstKeyword read GetTypeAttribute write SetTypeAttribute stored False;\r\n property ParameterName: string index taParameterName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property TypeName: string index taTypeName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property DefaultValue: string index taDefaultValue read GetTypeAttribute write SetTypeAttribute stored False;\r\n property ReleaserFunctionName: string index taReleaserFunctionName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property MacroFooter;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jcl.svn.sourceforge.net/svnroot/jcl/tags/JCL-2.4-Build4571/jcl/source/common/JclPreProcessorStacksTemplates.pas $';\r\n Revision: '$Revision: 3737 $';\r\n Date: '$Date: 2012-02-20 19:48:39 +0100 (lun. 20 févr. 2012) $';\r\n LogPath: 'JCL\\source\\common';\r\n Extra: '';\r\n Data: nil\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n {$IFDEF HAS_UNITSCOPE}\r\n System.SysUtils,\r\n {$ELSE ~HAS_UNITSCOPE}\r\n SysUtils,\r\n {$ENDIF ~HAS_UNITSCOPE}\r\n JclStrings;\r\n\r\nprocedure RegisterJclContainers;\r\nbegin\r\n RegisterContainerParams('JCLSTACKINT', TJclStackIntParams);\r\n RegisterContainerParams('JCLSTACKIMP', TJclStackImpParams, TJclStackIntParams);\r\nend;\r\n\r\n//=== { TJclStackIntParams } =================================================\r\n\r\nfunction TJclStackIntParams.AliasAttributeIDs: TAllTypeAttributeIDs;\r\nbegin\r\n Result := [taStackClassName];\r\nend;\r\n\r\n//=== { TJclStackImpParams } =================================================\r\n\r\nfunction TJclStackImpParams.GetConstructorParameters: string;\r\nbegin\r\n Result := 'FSize';\r\nend;\r\n\r\nfunction TJclStackImpParams.GetSelfClassName: string;\r\nbegin\r\n Result := SelfClassName;\r\nend;\r\n\r\ninitialization\r\n RegisterJclContainers;\r\n {$IFDEF UNITVERSIONING}\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n {$ENDIF UNITVERSIONING}\r\n\r\nfinalization\r\n {$IFDEF UNITVERSIONING}\r\n UnregisterUnitVersion(HInstance);\r\n {$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n\r\n" }, { "path": "External/Jedi/Jcl/source/common/JclPreProcessorTemplates.pas", "content": "{**************************************************************************************************}\r\n{ }\r\n{ Project JEDI Code Library (JCL) }\r\n{ }\r\n{ The contents of this file are subject to the Mozilla Public License Version 1.1 (the \"License\"); }\r\n{ you may not use this file except in compliance with the License. You may obtain a copy of the }\r\n{ License at http://www.mozilla.org/MPL/ }\r\n{ }\r\n{ Software distributed under the License is distributed on an \"AS IS\" basis, WITHOUT WARRANTY OF }\r\n{ ANY KIND, either express or implied. See the License for the specific language governing rights }\r\n{ and limitations under the License. }\r\n{ }\r\n{ The Original Code is JclOtaTemplates.pas. }\r\n{ }\r\n{ The Initial Developer of the Original Code is Florent Ouchet }\r\n{ }\r\n{ Portions created by Florent Ouchet are Copyright (C) of Florent Ouchet. All rights reserved. }\r\n{ }\r\n{ Contributors: }\r\n{ }\r\n{**************************************************************************************************}\r\n{ }\r\n{ Last modified: $Date:: 2011-09-03 00:07:50 +0200 (sam. 03 sept. 2011) $ }\r\n{ Revision: $Rev:: 3599 $ }\r\n{ Author: $Author:: outchy $ }\r\n{ }\r\n{**************************************************************************************************}\r\n\r\nunit JclPreProcessorTemplates;\r\n\r\ninterface\r\n\r\n{$I jcl.inc}\r\n\r\nuses\r\n {$IFDEF HAS_UNITSCOPE}\r\n System.Classes,\r\n {$ELSE ~HAS_UNITSCOPE}\r\n Classes,\r\n {$ENDIF ~HAS_UNITSCOPE}\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n JclPreProcessorParser;\r\n\r\ntype\r\n TJclTemplateParams = class(TPppState)\r\n public\r\n constructor Create;\r\n end;\r\n\r\nconst\r\n ModulePattern = '%MODULENAME%';\r\n FormPattern = '%FORMNAME%';\r\n AncestorPattern = '%ANCESTORNAME%';\r\n\r\nfunction GetFinalFormContent(const Content, FormIdent,\r\n AncestorIdent: string): string;\r\nfunction GetFinalHeaderContent(const Content, ModuleIdent, FormIdent,\r\n AncestorIdent: string): string;\r\nfunction GetFinalSourceContent(const Content, ModuleIdent, FormIdent,\r\n AncestorIdent: string): string;\r\n\r\nfunction ApplyTemplate(const Template: string; const Params: TJclTemplateParams): string;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jcl.svn.sourceforge.net/svnroot/jcl/tags/JCL-2.4-Build4571/jcl/source/common/JclPreProcessorTemplates.pas $';\r\n Revision: '$Revision: 3599 $';\r\n Date: '$Date: 2011-09-03 00:07:50 +0200 (sam. 03 sept. 2011) $';\r\n LogPath: 'JCL\\source\\common';\r\n Extra: '';\r\n Data: nil\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n {$IFDEF HAS_UNITSCOPE}\r\n System.SysUtils,\r\n System.TypInfo,\r\n {$ELSE ~HAS_UNITSCOPE}\r\n SysUtils,\r\n TypInfo,\r\n {$ENDIF ~HAS_UNITSCOPE}\r\n JclStrings, JclSysUtils;\r\n\r\n//=== { TJclTemplateParams } =================================================\r\n\r\nconstructor TJclTemplateParams.Create;\r\nbegin\r\n inherited Create;\r\n Options := Options + [poProcessDefines, poProcessMacros, poProcessValues];\r\nend;\r\n\r\nfunction GetFinalFormContent(const Content, FormIdent,\r\n AncestorIdent: string): string;\r\nbegin\r\n Result := StringReplace(Content, FormPattern, FormIdent, [rfReplaceAll, rfIgnoreCase]);\r\n Result := StringReplace(Result, AncestorPattern, AncestorIdent, [rfReplaceAll, rfIgnoreCase]);\r\nend;\r\n\r\nfunction GetFinalHeaderContent(const Content, ModuleIdent, FormIdent,\r\n AncestorIdent: string): string;\r\nbegin\r\n Result := StringReplace(Content, FormPattern, FormIdent, [rfReplaceAll, rfIgnoreCase]);\r\n Result := StringReplace(Result, AncestorPattern, AncestorIdent, [rfReplaceAll, rfIgnoreCase]);\r\n Result := StringReplace(Result, ModulePattern, ModuleIdent, [rfReplaceAll, rfIgnoreCase]);\r\nend;\r\n\r\nfunction GetFinalSourceContent(const Content, ModuleIdent, FormIdent, AncestorIdent: string): string;\r\nbegin\r\n Result := StringReplace(Content, FormPattern, FormIdent, [rfReplaceAll, rfIgnoreCase]);\r\n Result := StringReplace(Result, AncestorPattern, AncestorIdent, [rfReplaceAll, rfIgnoreCase]);\r\n Result := StringReplace(Result, ModulePattern, ModuleIdent, [rfReplaceAll, rfIgnoreCase]);\r\nend;\r\n\r\nfunction ApplyTemplate(const Template: string; const Params: TJclTemplateParams): string;\r\nvar\r\n JppParser: TJppParser;\r\nbegin\r\n Params.PushState;\r\n try\r\n JppParser := TJppParser.Create(Template, Params);\r\n try\r\n Result := JppParser.Parse;\r\n finally\r\n JppParser.Free;\r\n end;\r\n finally\r\n Params.PopState;\r\n end;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jcl/source/common/JclPreProcessorTreesTemplates.pas", "content": "{**************************************************************************************************}\r\n{ }\r\n{ Project JEDI Code Library (JCL) }\r\n{ }\r\n{ The contents of this file are subject to the Mozilla Public License Version 1.1 (the \"License\"); }\r\n{ you may not use this file except in compliance with the License. You may obtain a copy of the }\r\n{ License at http://www.mozilla.org/MPL/ }\r\n{ }\r\n{ Software distributed under the License is distributed on an \"AS IS\" basis, WITHOUT WARRANTY OF }\r\n{ ANY KIND, either express or implied. See the License for the specific language governing rights }\r\n{ and limitations under the License. }\r\n{ }\r\n{ The Original Code is JclTreesTemplates.pas. }\r\n{ }\r\n{ The Initial Developer of the Original Code is Florent Ouchet }\r\n{ }\r\n{ Portions created by Florent Ouchet are Copyright (C) of Florent Ouchet. All rights reserved. }\r\n{ }\r\n{ Contributors: }\r\n{ }\r\n{**************************************************************************************************}\r\n{ }\r\n{ Last modified: $Date:: 2012-02-20 19:48:39 +0100 (lun. 20 févr. 2012) $ }\r\n{ Revision: $Rev:: 3737 $ }\r\n{ Author: $Author:: outchy $ }\r\n{ }\r\n{**************************************************************************************************}\r\n\r\nunit JclPreProcessorTreesTemplates;\r\n\r\ninterface\r\n\r\n{$I jcl.inc}\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n JclPreProcessorContainerTypes,\r\n JclPreProcessorContainerTemplates,\r\n JclPreProcessorContainer1DTemplates;\r\n\r\ntype\r\n (* JCLTREETYPESINT(NODETYPENAME, EQUALITYCOMPARERINTERFACENAME, CONSTKEYWORD, PARAMETERNAME, TYPENAME) *)\r\n TJclTreeTypeIntParams = class(TJclContainerInterfaceParams)\r\n public\r\n function AliasAttributeIDs: TAllTypeAttributeIDs; override;\r\n published\r\n property NodeTypeName: string index taTreeNodeClassName read GetTypeAttribute write SetTypeAttribute stored IsTypeAttributeStored;\r\n property EqualityComparerInterfaceName: string index taEqualityComparerInterfaceName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property ConstKeyword: string index taConstKeyword read GetTypeAttribute write SetTypeAttribute stored False;\r\n property ParameterName: string index taParameterName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property TypeName: string index taTypeName read GetTypeAttribute write SetTypeAttribute stored False;\r\n end;\r\n\r\n (* JCLTREEINT(NODETYPENAME, SELFCLASSNAME, ANCESTORCLASSNAME,\r\n BASECONTAINERINTERFACENAME, FLATCONTAINERINTERFACENAME, EQUALITYCOMPARERINTERFACENAME,\r\n COLLECTIONINTERFACENAME, TREEINTERFACENAME, STDITRINTERFACENAME, TREEITRINTERFACENAME,\r\n INTERFACEADDITIONAL, SECTIONADDITIONAL, COLLECTIONFLAGS, OWNERSHIPDECLARATION,\r\n CONSTKEYWORD, PARAMETERNAME, TYPENAME, DEFAULTVALUE) *)\r\n TJclTreeIntParams = class(TJclCollectionInterfaceParams)\r\n protected\r\n // function CodeUnit: string; override;\r\n function GetOwnershipDeclaration: string; override;\r\n public\r\n function AliasAttributeIDs: TAllTypeAttributeIDs; override;\r\n published\r\n property NodeTypeName: string index taTreeNodeClassName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property SelfClassName: string index taTreeClassName read GetTypeAttribute write SetTypeAttribute stored IsTypeAttributeStored;\r\n property AncestorClassName;\r\n property BaseContainerInterfaceName: string index taContainerInterfaceName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property FlatContainerInterfaceName: string index taFlatContainerInterfaceName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property EqualityComparerInterfaceName: string index taEqualityComparerInterfaceName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property CollectionInterfaceName: string index taCollectionInterfaceName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property TreeInterfaceName: string index taTreeInterfaceName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property StdItrInterfaceName: string index taIteratorInterfaceName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property TreeItrInterfaceName: string index taTreeIteratorInterfaceName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property InterfaceAdditional;\r\n property SectionAdditional;\r\n property OwnershipDeclaration;\r\n property CollectionFlags;\r\n property ConstKeyword: string index taConstKeyword read GetTypeAttribute write SetTypeAttribute stored False;\r\n property ParameterName: string index taParameterName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property TypeName: string index taTypeName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property DefaultValue: string index taDefaultValue read GetTypeAttribute write SetTypeAttribute stored False;\r\n end;\r\n\r\n (* JCLTREEITRINT(BASEITRCLASSNAME, PREORDERITRCLASSNAME, POSTORDERITRCLASSNAME, NODETYPENAME,\r\n TREECLASSNAME, STDITRINTERFACENAME, TREEITRINTERFACENAME, EQUALITYCOMPARERINTERFACENAME,\r\n CONSTKEYWORD, PARAMETERNAME, TYPENAME, DEFAULTVALUE, GETTERFUNCTIONNAME, SETTERPROCEDURENAME) *)\r\n TJclTreeItrIntParams = class(TJclContainerInterfaceParams)\r\n protected\r\n // function CodeUnit: string; override;\r\n public\r\n function AliasAttributeIDs: TAllTypeAttributeIDs; override;\r\n published\r\n property BaseItrClassName: string index taTreeBaseIteratorClassName read GetTypeAttribute write SetTypeAttribute stored IsTypeAttributeStored;\r\n property PreOrderItrClassName: string index taTreePreOrderIteratorClassName read GetTypeAttribute write SetTypeAttribute stored IsTypeAttributeStored;\r\n property PostOrderItrClassName: string index taTreePostOrderIteratorClassName read GetTypeAttribute write SetTypeAttribute stored IsTypeAttributeStored;\r\n property NodeTypeName: string index taTreeNodeClassName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property TreeClassName: string index taTreeClassName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property StdItrInterfaceName: string index taIteratorInterfaceName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property TreeItrInterfaceName: string index taTreeIteratorInterfaceName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property EqualityComparerInterfaceName: string index taEqualityComparerInterfaceName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property ConstKeyword: string index taConstKeyword read GetTypeAttribute write SetTypeAttribute stored False;\r\n property ParameterName: string index taParameterName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property TypeName: string index taTypeName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property DefaultValue: string index taDefaultValue read GetTypeAttribute write SetTypeAttribute stored False;\r\n property GetterFunctionName: string index taGetterFunctionName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property SetterProcedureName: string index taSetterProcedureName read GetTypeAttribute write SetTypeAttribute stored False;\r\n end;\r\n\r\n (* JCLTREETYPESIMP(NODETYPENAME, EQUALITYCOMPARERINTERFACENAME, CONSTKEYWORD, PARAMETERNAME, TYPENAME) *)\r\n TJclTreeTypeImpParams = class(TJclContainerImplementationParams)\r\n published\r\n property NodeTypeName: string index taTreeNodeClassName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property EqualityComparerInterfaceName: string index taEqualityComparerInterfaceName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property ConstKeyword: string index taConstKeyword read GetTypeAttribute write SetTypeAttribute stored False;\r\n property ParameterName: string index taParameterName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property TypeName: string index taTypeName read GetTypeAttribute write SetTypeAttribute stored False;\r\n end;\r\n\r\n (* JCLTREEIMP(NODETYPENAME, SELFCLASSNAME, PREORDERITRCLASSNAME, POSTORDERITRCLASSNAME,\r\n COLLECTIONINTERFACENAME, STDITRINTERFACENAME, TREEITRINTERFACENAME,\r\n EQUALITYCOMPARERINTERFACENAME, OWNERSHIPDECLARATION, OWNERSHIPPARAMETERNAME,\r\n CONSTKEYWORD, PARAMETERNAME, TYPENAME, DEFAULTVALUE, RELEASERFUNCTIONNAME) *)\r\n TJclTreeImpParams = class(TJclCollectionImplementationParams)\r\n protected\r\n // function CodeUnit: string; override;\r\n function GetConstructorParameters: string; override;\r\n function GetSelfClassName: string; override;\r\n function GetOwnershipDeclaration: string; override;\r\n published\r\n property SelfClassName: string index taTreeClassName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property NodeTypeName: string index taTreeNodeClassName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property PreOrderItrClassName: string index taTreePreOrderIteratorClassName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property PostOrderItrClassName: string index taTreePostOrderIteratorClassName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property CollectionInterfaceName: string index taCollectionInterfaceName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property StdItrInterfaceName: string index taIteratorInterfaceName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property TreeItrInterfaceName: string index taTreeIteratorInterfaceName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property EqualityComparerInterfaceName: string index taEqualityComparerInterfaceName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property OwnershipDeclaration;\r\n property OwnershipParameterName: string index taOwnershipParameterName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property ConstKeyword: string index taConstKeyword read GetTypeAttribute write SetTypeAttribute stored False;\r\n property ParameterName: string index taParameterName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property TypeName: string index taTypeName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property DefaultValue: string index taDefaultValue read GetTypeAttribute write SetTypeAttribute stored False;\r\n property ReleaserFunctionName: string index taReleaserFunctionName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property MacroFooter;\r\n end;\r\n\r\n (* JCLTREEITRIMP(BASEITRCLASSNAME, PREORDERITRCLASSNAME, POSTORDERITRCLASSNAME, NODETYPENAME, TREECLASSNAME,\r\n STDITRINTERFACENAME, TREEITRINTERFACENAME, EQUALITYCOMPARERINTERFACENAME,\r\n CONSTKEYWORD, PARAMETERNAME, TYPENAME, DEFAULTVALUE, GETTERFUNCTIONNAME, SETTERPROCEDURENAME, RELEASERFUNCTIONNAME) *)\r\n TJclTreeItrImpParams = class(TJclContainerImplementationParams)\r\n protected\r\n // function CodeUnit: string; override;\r\n published\r\n property BaseItrClassName: string index taTreeBaseIteratorClassName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property PreOrderItrClassName: string index taTreePreOrderIteratorClassName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property PostOrderItrClassName: string index taTreePostOrderIteratorClassName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property NodeTypeName: string index taTreeNodeClassName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property TreeClassName: string index taTreeClassName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property StdItrInterfaceName: string index taIteratorInterfaceName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property TreeItrInterfaceName: string index taTreeIteratorInterfaceName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property EqualityComparerInterfaceName: string index taEqualityComparerInterfaceName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property ConstKeyword: string index taConstKeyword read GetTypeAttribute write SetTypeAttribute stored False;\r\n property ParameterName: string index taParameterName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property TypeName: string index taTypeName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property DefaultValue: string index taDefaultValue read GetTypeAttribute write SetTypeAttribute stored False;\r\n property GetterFunctionName: string index taGetterFunctionName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property SetterProcedureName: string index taSetterProcedureName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property ReleaserFunctionName: string index taReleaserFunctionName read GetTypeAttribute write SetTypeAttribute stored False;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jcl.svn.sourceforge.net/svnroot/jcl/tags/JCL-2.4-Build4571/jcl/source/common/JclPreProcessorTreesTemplates.pas $';\r\n Revision: '$Revision: 3737 $';\r\n Date: '$Date: 2012-02-20 19:48:39 +0100 (lun. 20 févr. 2012) $';\r\n LogPath: 'JCL\\source\\common';\r\n Extra: '';\r\n Data: nil\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n {$IFDEF HAS_UNITSCOPE}\r\n System.SysUtils,\r\n {$ELSE ~HAS_UNITSCOPE}\r\n SysUtils,\r\n {$ENDIF ~HAS_UNITSCOPE}\r\n JclStrings;\r\n\r\nprocedure RegisterJclContainers;\r\nbegin\r\n RegisterContainerParams('JCLTREETYPESINT', TJclTreeTypeIntParams);\r\n RegisterContainerParams('JCLTREETYPESIMP', TJclTreeTypeImpParams, TJclTreeTypeIntParams);\r\n RegisterContainerParams('JCLTREEINT', TJclTreeIntParams);\r\n RegisterContainerParams('JCLTREEITRINT', TJclTreeItrIntParams);\r\n RegisterContainerParams('JCLTREEIMP', TJclTreeImpParams, TJclTreeIntParams);\r\n RegisterContainerParams('JCLTREEITRIMP', TJclTreeItrImpParams, TJclTreeItrIntParams);\r\nend;\r\n\r\n//=== { TJclTreeTypeIntParams } ==============================================\r\n\r\nfunction TJclTreeTypeIntParams.AliasAttributeIDs: TAllTypeAttributeIDs;\r\nbegin\r\n Result := [taTreeNodeClassName];\r\nend;\r\n\r\n//=== { TJclTreeIntParams } ==================================================\r\n\r\nfunction TJclTreeIntParams.AliasAttributeIDs: TAllTypeAttributeIDs;\r\nbegin\r\n Result := [taTreeClassName];\r\nend;\r\n\r\nfunction TJclTreeIntParams.GetOwnershipDeclaration: string;\r\nbegin\r\n Result := TypeInfo.OwnershipDeclaration;\r\nend;\r\n\r\n//=== { TJclTreeItrIntParams } ===============================================\r\n\r\nfunction TJclTreeItrIntParams.AliasAttributeIDs: TAllTypeAttributeIDs;\r\nbegin\r\n Result := [taTreeBaseIteratorClassName, taTreePreOrderIteratorClassName,\r\n taTreePostOrderIteratorClassName];\r\nend;\r\n\r\n//=== { TJclTreeImpParams } ==================================================\r\n\r\nfunction TJclTreeImpParams.GetConstructorParameters: string;\r\nbegin\r\n Result := '';\r\nend;\r\n\r\nfunction TJclTreeImpParams.GetOwnershipDeclaration: string;\r\nbegin\r\n Result := TypeInfo.OwnershipDeclaration;\r\nend;\r\n\r\nfunction TJclTreeImpParams.GetSelfClassName: string;\r\nbegin\r\n Result := SelfClassName;\r\nend;\r\n\r\ninitialization\r\n RegisterJclContainers;\r\n {$IFDEF UNITVERSIONING}\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n {$ENDIF UNITVERSIONING}\r\n\r\nfinalization\r\n {$IFDEF UNITVERSIONING}\r\n UnregisterUnitVersion(HInstance);\r\n {$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n\r\n" }, { "path": "External/Jedi/Jcl/source/common/JclPreProcessorVectorsTemplates.pas", "content": "{**************************************************************************************************}\r\n{ }\r\n{ Project JEDI Code Library (JCL) }\r\n{ }\r\n{ The contents of this file are subject to the Mozilla Public License Version 1.1 (the \"License\"); }\r\n{ you may not use this file except in compliance with the License. You may obtain a copy of the }\r\n{ License at http://www.mozilla.org/MPL/ }\r\n{ }\r\n{ Software distributed under the License is distributed on an \"AS IS\" basis, WITHOUT WARRANTY OF }\r\n{ ANY KIND, either express or implied. See the License for the specific language governing rights }\r\n{ and limitations under the License. }\r\n{ }\r\n{ The Original Code is JclVectorsTemplates.pas. }\r\n{ }\r\n{ The Initial Developer of the Original Code is Florent Ouchet }\r\n{ }\r\n{ Portions created by Florent Ouchet are Copyright (C) of Florent Ouchet. All rights reserved. }\r\n{ }\r\n{ Contributors: }\r\n{ }\r\n{**************************************************************************************************}\r\n{ }\r\n{ Last modified: $Date:: 2012-02-23 21:46:07 +0100 (jeu. 23 févr. 2012) $ }\r\n{ Revision: $Rev:: 3740 $ }\r\n{ Author: $Author:: outchy $ }\r\n{ }\r\n{**************************************************************************************************}\r\n\r\nunit JclPreProcessorVectorsTemplates;\r\n\r\ninterface\r\n\r\n{$I jcl.inc}\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n JclPreProcessorContainerTypes,\r\n JclPreProcessorContainerTemplates,\r\n JclPreProcessorContainer1DTemplates;\r\n\r\ntype\r\n (* JCLVECTORINT(SELFCLASSNAME, ANCESTORCLASSNAME, BASECONTAINERINTERFACENAME,\r\n FLATCONTAINERINTERFACENAME, COLLECTIONINTERFACENAME, LISTINTERFACENAME,\r\n ARRAYINTERFACENAME, ITRINTERFACENAME, EQUALITYCOMPARERINTERFACENAME,\r\n INTERFACEADDITIONAL, SECTIONADDITIONAL, COLLECTIONFLAGS, OWNERSHIPDECLARATION,\r\n CONSTKEYWORD, PARAMETERNAME, TYPENAME, DYNARRAYTYPE, GETTERFUNCTIONNAME, SETTERPROCEDURENAME) *)\r\n TJclVectorIntParams = class(TJclCollectionInterfaceParams)\r\n protected\r\n // function CodeUnit: string; override;\r\n public\r\n function AliasAttributeIDs: TAllTypeAttributeIDs; override;\r\n published\r\n property SelfClassName: string index taVectorClassName read GetTypeAttribute write SetTypeAttribute stored IsTypeAttributeStored;\r\n property AncestorClassName;\r\n property BaseContainerInterfaceName: string index taContainerInterfaceName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property FlatContainerInterfaceName: string index taFlatContainerInterfaceName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property CollectionInterfaceName: string index taCollectionInterfaceName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property EqualityComparerInterfaceName: string index taEqualityComparerInterfaceName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property ListInterfaceName: string index taListInterfaceName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property ArrayInterfaceName: string index taArrayInterfaceName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property ItrInterfaceName: string index taIteratorInterfaceName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property InterfaceAdditional;\r\n property SectionAdditional;\r\n property CollectionFlags;\r\n property OwnershipDeclaration;\r\n property ConstKeyword: string index taConstKeyword read GetTypeAttribute write SetTypeAttribute stored False;\r\n property ParameterName: string index taParameterName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property TypeName: string index taTypeName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property DynArrayType: string index taDynArrayTypeName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property GetterFunctionName: string index taGetterFunctionName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property SetterProcedureName: string index taSetterProcedureName read GetTypeAttribute write SetTypeAttribute stored False;\r\n end;\r\n\r\n (* JCLVECTORITRINT(SELFCLASSNAME, ITRINTERFACENAME, LISTCLASSNAME,\r\n CONSTKEYWORD, PARAMETERNAME, TYPENAME, GETTERFUNCTIONNAME, SETTERPROCEDURENAME) *)\r\n TJclVectorItrIntParams = class(TJclContainerInterfaceParams)\r\n protected\r\n // function CodeUnit: string; override;\r\n public\r\n function AliasAttributeIDs: TAllTypeAttributeIDs; override;\r\n published\r\n property SelfClassName: string index taVectorIteratorClassName read GetTypeAttribute write SetTypeAttribute stored IsTypeAttributeStored;\r\n property ItrInterfaceName: string index taIteratorInterfaceName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property ListClassName: string index taVectorClassName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property ConstKeyword: string index taConstKeyword read GetTypeAttribute write SetTypeAttribute stored False;\r\n property ParameterName: string index taParameterName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property TypeName: string index taTypeName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property GetterFunctionName: string index taGetterFunctionName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property SetterProcedureName: string index taSetterProcedureName read GetTypeAttribute write SetTypeAttribute stored False;\r\n end;\r\n\r\n (* JCLVECTORIMP(SELFCLASSNAME, COLLECTIONINTERFACENAME, LISTINTERFACENAME, ITRINTERFACENAME,\r\n ITRCLASSNAME, OWNERSHIPDECLARATION, OWNERSHIPPARAMETERNAME, MOVEARRAYPROCEDURENAME,\r\n CONSTKEYWORD, PARAMETERNAME, TYPENAME, DEFAULTVALUE,\r\n GETTERFUNCTIONNAME, SETTERPROCEDURENAME, RELEASERFUNCTIONNAME) *)\r\n TJclVectorImpParams = class(TJclCollectionImplementationParams)\r\n protected\r\n // function CodeUnit: string; override;\r\n public\r\n function GetConstructorParameters: string; override;\r\n function GetSelfClassName: string; override;\r\n published\r\n property SelfClassName: string index taVectorClassName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property CollectionInterfaceName: string index taCollectionInterfaceName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property ListInterfaceName: string index taListInterfaceName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property ItrInterfaceName: string index taIteratorInterfaceName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property ItrClassName: string index taVectorIteratorClassName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property OwnershipDeclaration;\r\n property OwnershipParameterName: string index taOwnershipParameterName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property MoveArrayProcedureName: string index taMoveArrayProcedureName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property ConstKeyword: string index taConstKeyword read GetTypeAttribute write SetTypeAttribute stored False;\r\n property ParameterName: string index taParameterName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property TypeName: string index taTypeName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property DefaultValue: string index taDefaultValue read GetTypeAttribute write SetTypeAttribute stored False;\r\n property GetterFunctionName: string index taGetterFunctionName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property SetterProcedureName: string index taSetterProcedureName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property ReleaserFunctionName: string index taReleaserFunctionName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property MacroFooter;\r\n end;\r\n\r\n (* JCLVECTORITRIMP(SELFCLASSNAME, ITRINTERFACENAME, LISTCLASSNAME,\r\n CONSTKEYWORD, PARAMETERNAME, TYPENAME, GETTERFUNCTIONNAME, SETTERPROCEDURENAME) *)\r\n TJclVectorItrImpParams = class(TJclContainerImplementationParams)\r\n protected\r\n // function CodeUnit: string; override;\r\n published\r\n property SelfClassName: string index taVectorIteratorClassName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property ItrInterfaceName: string index taIteratorInterfaceName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property ListClassName: string index taVectorClassName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property ConstKeyword: string index taConstKeyword read GetTypeAttribute write SetTypeAttribute stored False;\r\n property ParameterName: string index taParameterName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property TypeName: string index taTypeName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property GetterFunctionName: string index taGetterFunctionName read GetTypeAttribute write SetTypeAttribute stored False;\r\n property SetterProcedureName: string index taSetterProcedureName read GetTypeAttribute write SetTypeAttribute stored False;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jcl.svn.sourceforge.net/svnroot/jcl/tags/JCL-2.4-Build4571/jcl/source/common/JclPreProcessorVectorsTemplates.pas $';\r\n Revision: '$Revision: 3740 $';\r\n Date: '$Date: 2012-02-23 21:46:07 +0100 (jeu. 23 févr. 2012) $';\r\n LogPath: 'JCL\\source\\common';\r\n Extra: '';\r\n Data: nil\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n {$IFDEF HAS_UNITSCOPE}\r\n System.SysUtils,\r\n {$ELSE ~HAS_UNITSCOPE}\r\n SysUtils,\r\n {$ENDIF ~HAS_UNITSCOPE}\r\n JclStrings;\r\n\r\nprocedure RegisterJclContainers;\r\nbegin\r\n RegisterContainerParams('JCLVECTORINT', TJclVectorIntParams);\r\n RegisterContainerParams('JCLVECTORITRINT', TJclVectorItrIntParams);\r\n RegisterContainerParams('JCLVECTORIMP', TJclVectorImpParams, TJclVectorIntParams);\r\n RegisterContainerParams('JCLVECTORITRIMP', TJclVectorItrImpParams, TJclVectorItrIntParams);\r\nend;\r\n\r\n//=== { TJclVectorIntParams } ================================================\r\n\r\nfunction TJclVectorIntParams.AliasAttributeIDs: TAllTypeAttributeIDs;\r\nbegin\r\n Result := [taVectorClassName];\r\nend;\r\n\r\n//=== { TJclVectorItrIntParams } =============================================\r\n\r\nfunction TJclVectorItrIntParams.AliasAttributeIDs: TAllTypeAttributeIDs;\r\nbegin\r\n Result := [taVectorIteratorClassName];\r\nend;\r\n\r\n//=== { TJclVectorImpParams } ================================================\r\n\r\nfunction TJclVectorImpParams.GetConstructorParameters: string;\r\nbegin\r\n Result := 'FSize';\r\nend;\r\n\r\nfunction TJclVectorImpParams.GetSelfClassName: string;\r\nbegin\r\n Result := SelfClassName;\r\nend;\r\n\r\ninitialization\r\n RegisterJclContainers;\r\n {$IFDEF UNITVERSIONING}\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n {$ENDIF UNITVERSIONING}\r\n\r\nfinalization\r\n {$IFDEF UNITVERSIONING}\r\n UnregisterUnitVersion(HInstance);\r\n {$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n\r\n" }, { "path": "External/Jedi/Jcl/source/common/JclQueues.pas", "content": "{**************************************************************************************************}\r\n{ WARNING: JEDI preprocessor generated unit. Do not edit. }\r\n{**************************************************************************************************}\r\n\r\n{**************************************************************************************************}\r\n{ }\r\n{ Project JEDI Code Library (JCL) }\r\n{ }\r\n{ The contents of this file are subject to the Mozilla Public License Version 1.1 (the \"License\"); }\r\n{ you may not use this file except in compliance with the License. You may obtain a copy of the }\r\n{ License at http://www.mozilla.org/MPL/ }\r\n{ }\r\n{ Software distributed under the License is distributed on an \"AS IS\" basis, WITHOUT WARRANTY OF }\r\n{ ANY KIND, either express or implied. See the License for the specific language governing rights }\r\n{ and limitations under the License. }\r\n{ }\r\n{ The Original Code is Queue.pas. }\r\n{ }\r\n{ The Initial Developer of the Original Code is Jean-Philippe BEMPEL aka RDM. Portions created by }\r\n{ Jean-Philippe BEMPEL are Copyright (C) Jean-Philippe BEMPEL (rdm_30 att yahoo dott com) }\r\n{ All rights reserved. }\r\n{ }\r\n{ Contributors: }\r\n{ Florent Ouchet (outchy) }\r\n{ }\r\n{**************************************************************************************************}\r\n{ }\r\n{ The Delphi Container Library }\r\n{ }\r\n{**************************************************************************************************}\r\n{ }\r\n{ Last modified: $Date:: 2012-02-23 21:46:07 +0100 (jeu. 23 févr. 2012) $ }\r\n{ Revision: $Rev:: 3740 $ }\r\n{ Author: $Author:: outchy $ }\r\n{ }\r\n{**************************************************************************************************}\r\n\r\nunit JclQueues;\r\n\r\n{$I jcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n JclAlgorithms,\r\n JclBase, JclAbstractContainers, JclContainerIntf, JclSynch;\r\n\r\n\r\ntype\r\n TJclIntfQueue = class(TJclIntfAbstractContainer, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclIntfCloneable, IJclCloneable, IJclPackable, IJclGrowable, IJclBaseContainer,\r\n IJclIntfContainer, IJclIntfEqualityComparer,\r\n IJclIntfQueue)\r\n protected\r\n function CreateEmptyContainer: TJclAbstractContainerBase; override;\r\n private\r\n FElements: TDynIInterfaceArray;\r\n FHead: Integer;\r\n FTail: Integer;\r\n protected\r\n procedure AssignDataTo(Dest: TJclAbstractContainerBase); override;\r\n public\r\n constructor Create(ACapacity: Integer);\r\n destructor Destroy; override;\r\n { IJclPackable }\r\n procedure Pack; override;\r\n procedure SetCapacity(Value: Integer); override;\r\n { IJclIntfQueue }\r\n procedure Clear;\r\n function Contains(const AInterface: IInterface): Boolean;\r\n function Dequeue: IInterface;\r\n function Empty: Boolean;\r\n function Enqueue(const AInterface: IInterface): Boolean;\r\n function Peek: IInterface;\r\n function Size: Integer;\r\n end;\r\n\r\n TJclAnsiStrQueue = class(TJclAnsiStrAbstractContainer, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclIntfCloneable, IJclCloneable, IJclPackable, IJclGrowable, IJclBaseContainer,\r\n IJclAnsiStrContainer, IJclAnsiStrEqualityComparer, IJclStrBaseContainer,\r\n IJclAnsiStrQueue)\r\n protected\r\n function CreateEmptyContainer: TJclAbstractContainerBase; override;\r\n private\r\n FElements: TDynAnsiStringArray;\r\n FHead: Integer;\r\n FTail: Integer;\r\n protected\r\n procedure AssignDataTo(Dest: TJclAbstractContainerBase); override;\r\n public\r\n constructor Create(ACapacity: Integer);\r\n destructor Destroy; override;\r\n { IJclPackable }\r\n procedure Pack; override;\r\n procedure SetCapacity(Value: Integer); override;\r\n { IJclAnsiStrQueue }\r\n procedure Clear;\r\n function Contains(const AString: AnsiString): Boolean;\r\n function Dequeue: AnsiString;\r\n function Empty: Boolean;\r\n function Enqueue(const AString: AnsiString): Boolean;\r\n function Peek: AnsiString;\r\n function Size: Integer;\r\n end;\r\n\r\n TJclWideStrQueue = class(TJclWideStrAbstractContainer, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclIntfCloneable, IJclCloneable, IJclPackable, IJclGrowable, IJclBaseContainer,\r\n IJclWideStrContainer, IJclWideStrEqualityComparer, IJclStrBaseContainer,\r\n IJclWideStrQueue)\r\n protected\r\n function CreateEmptyContainer: TJclAbstractContainerBase; override;\r\n private\r\n FElements: TDynWideStringArray;\r\n FHead: Integer;\r\n FTail: Integer;\r\n protected\r\n procedure AssignDataTo(Dest: TJclAbstractContainerBase); override;\r\n public\r\n constructor Create(ACapacity: Integer);\r\n destructor Destroy; override;\r\n { IJclPackable }\r\n procedure Pack; override;\r\n procedure SetCapacity(Value: Integer); override;\r\n { IJclWideStrQueue }\r\n procedure Clear;\r\n function Contains(const AString: WideString): Boolean;\r\n function Dequeue: WideString;\r\n function Empty: Boolean;\r\n function Enqueue(const AString: WideString): Boolean;\r\n function Peek: WideString;\r\n function Size: Integer;\r\n end;\r\n\r\n {$IFDEF SUPPORTS_UNICODE_STRING}\r\n TJclUnicodeStrQueue = class(TJclUnicodeStrAbstractContainer, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclIntfCloneable, IJclCloneable, IJclPackable, IJclGrowable, IJclBaseContainer,\r\n IJclUnicodeStrContainer, IJclUnicodeStrEqualityComparer, IJclStrBaseContainer,\r\n IJclUnicodeStrQueue)\r\n protected\r\n function CreateEmptyContainer: TJclAbstractContainerBase; override;\r\n private\r\n FElements: TDynUnicodeStringArray;\r\n FHead: Integer;\r\n FTail: Integer;\r\n protected\r\n procedure AssignDataTo(Dest: TJclAbstractContainerBase); override;\r\n public\r\n constructor Create(ACapacity: Integer);\r\n destructor Destroy; override;\r\n { IJclPackable }\r\n procedure Pack; override;\r\n procedure SetCapacity(Value: Integer); override;\r\n { IJclUnicodeStrQueue }\r\n procedure Clear;\r\n function Contains(const AString: UnicodeString): Boolean;\r\n function Dequeue: UnicodeString;\r\n function Empty: Boolean;\r\n function Enqueue(const AString: UnicodeString): Boolean;\r\n function Peek: UnicodeString;\r\n function Size: Integer;\r\n end;\r\n {$ENDIF SUPPORTS_UNICODE_STRING}\r\n\r\n {$IFDEF CONTAINER_ANSISTR}\r\n TJclStrQueue = TJclAnsiStrQueue;\r\n {$ENDIF CONTAINER_ANSISTR}\r\n {$IFDEF CONTAINER_WIDESTR}\r\n TJclStrQueue = TJclWideStrQueue;\r\n {$ENDIF CONTAINER_WIDESTR}\r\n {$IFDEF CONTAINER_UNICODESTR}\r\n TJclStrQueue = TJclUnicodeStrQueue;\r\n {$ENDIF CONTAINER_UNICODESTR}\r\n\r\n TJclSingleQueue = class(TJclSingleAbstractContainer, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclIntfCloneable, IJclCloneable, IJclPackable, IJclGrowable, IJclBaseContainer,\r\n IJclSingleContainer, IJclSingleEqualityComparer,\r\n IJclSingleQueue)\r\n protected\r\n function CreateEmptyContainer: TJclAbstractContainerBase; override;\r\n private\r\n FElements: TDynSingleArray;\r\n FHead: Integer;\r\n FTail: Integer;\r\n protected\r\n procedure AssignDataTo(Dest: TJclAbstractContainerBase); override;\r\n public\r\n constructor Create(ACapacity: Integer);\r\n destructor Destroy; override;\r\n { IJclPackable }\r\n procedure Pack; override;\r\n procedure SetCapacity(Value: Integer); override;\r\n { IJclSingleQueue }\r\n procedure Clear;\r\n function Contains(const AValue: Single): Boolean;\r\n function Dequeue: Single;\r\n function Empty: Boolean;\r\n function Enqueue(const AValue: Single): Boolean;\r\n function Peek: Single;\r\n function Size: Integer;\r\n end;\r\n\r\n TJclDoubleQueue = class(TJclDoubleAbstractContainer, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclIntfCloneable, IJclCloneable, IJclPackable, IJclGrowable, IJclBaseContainer,\r\n IJclDoubleContainer, IJclDoubleEqualityComparer,\r\n IJclDoubleQueue)\r\n protected\r\n function CreateEmptyContainer: TJclAbstractContainerBase; override;\r\n private\r\n FElements: TDynDoubleArray;\r\n FHead: Integer;\r\n FTail: Integer;\r\n protected\r\n procedure AssignDataTo(Dest: TJclAbstractContainerBase); override;\r\n public\r\n constructor Create(ACapacity: Integer);\r\n destructor Destroy; override;\r\n { IJclPackable }\r\n procedure Pack; override;\r\n procedure SetCapacity(Value: Integer); override;\r\n { IJclDoubleQueue }\r\n procedure Clear;\r\n function Contains(const AValue: Double): Boolean;\r\n function Dequeue: Double;\r\n function Empty: Boolean;\r\n function Enqueue(const AValue: Double): Boolean;\r\n function Peek: Double;\r\n function Size: Integer;\r\n end;\r\n\r\n TJclExtendedQueue = class(TJclExtendedAbstractContainer, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclIntfCloneable, IJclCloneable, IJclPackable, IJclGrowable, IJclBaseContainer,\r\n IJclExtendedContainer, IJclExtendedEqualityComparer,\r\n IJclExtendedQueue)\r\n protected\r\n function CreateEmptyContainer: TJclAbstractContainerBase; override;\r\n private\r\n FElements: TDynExtendedArray;\r\n FHead: Integer;\r\n FTail: Integer;\r\n protected\r\n procedure AssignDataTo(Dest: TJclAbstractContainerBase); override;\r\n public\r\n constructor Create(ACapacity: Integer);\r\n destructor Destroy; override;\r\n { IJclPackable }\r\n procedure Pack; override;\r\n procedure SetCapacity(Value: Integer); override;\r\n { IJclExtendedQueue }\r\n procedure Clear;\r\n function Contains(const AValue: Extended): Boolean;\r\n function Dequeue: Extended;\r\n function Empty: Boolean;\r\n function Enqueue(const AValue: Extended): Boolean;\r\n function Peek: Extended;\r\n function Size: Integer;\r\n end;\r\n\r\n {$IFDEF MATH_SINGLE_PRECISION}\r\n TJclFloatQueue = TJclSingleQueue;\r\n {$ENDIF MATH_SINGLE_PRECISION}\r\n {$IFDEF MATH_DOUBLE_PRECISION}\r\n TJclFloatQueue = TJclDoubleQueue;\r\n {$ENDIF MATH_DOUBLE_PRECISION}\r\n {$IFDEF MATH_EXTENDED_PRECISION}\r\n TJclFloatQueue = TJclExtendedQueue;\r\n {$ENDIF MATH_EXTENDED_PRECISION}\r\n\r\n TJclIntegerQueue = class(TJclIntegerAbstractContainer, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclIntfCloneable, IJclCloneable, IJclPackable, IJclGrowable, IJclBaseContainer,\r\n IJclIntegerContainer, IJclIntegerEqualityComparer,\r\n IJclIntegerQueue)\r\n protected\r\n function CreateEmptyContainer: TJclAbstractContainerBase; override;\r\n private\r\n FElements: TDynIntegerArray;\r\n FHead: Integer;\r\n FTail: Integer;\r\n protected\r\n procedure AssignDataTo(Dest: TJclAbstractContainerBase); override;\r\n public\r\n constructor Create(ACapacity: Integer);\r\n destructor Destroy; override;\r\n { IJclPackable }\r\n procedure Pack; override;\r\n procedure SetCapacity(Value: Integer); override;\r\n { IJclIntegerQueue }\r\n procedure Clear;\r\n function Contains(AValue: Integer): Boolean;\r\n function Dequeue: Integer;\r\n function Empty: Boolean;\r\n function Enqueue(AValue: Integer): Boolean;\r\n function Peek: Integer;\r\n function Size: Integer;\r\n end;\r\n\r\n TJclCardinalQueue = class(TJclCardinalAbstractContainer, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclIntfCloneable, IJclCloneable, IJclPackable, IJclGrowable, IJclBaseContainer,\r\n IJclCardinalContainer, IJclCardinalEqualityComparer,\r\n IJclCardinalQueue)\r\n protected\r\n function CreateEmptyContainer: TJclAbstractContainerBase; override;\r\n private\r\n FElements: TDynCardinalArray;\r\n FHead: Integer;\r\n FTail: Integer;\r\n protected\r\n procedure AssignDataTo(Dest: TJclAbstractContainerBase); override;\r\n public\r\n constructor Create(ACapacity: Integer);\r\n destructor Destroy; override;\r\n { IJclPackable }\r\n procedure Pack; override;\r\n procedure SetCapacity(Value: Integer); override;\r\n { IJclCardinalQueue }\r\n procedure Clear;\r\n function Contains(AValue: Cardinal): Boolean;\r\n function Dequeue: Cardinal;\r\n function Empty: Boolean;\r\n function Enqueue(AValue: Cardinal): Boolean;\r\n function Peek: Cardinal;\r\n function Size: Integer;\r\n end;\r\n\r\n TJclInt64Queue = class(TJclInt64AbstractContainer, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclIntfCloneable, IJclCloneable, IJclPackable, IJclGrowable, IJclBaseContainer,\r\n IJclInt64Container, IJclInt64EqualityComparer,\r\n IJclInt64Queue)\r\n protected\r\n function CreateEmptyContainer: TJclAbstractContainerBase; override;\r\n private\r\n FElements: TDynInt64Array;\r\n FHead: Integer;\r\n FTail: Integer;\r\n protected\r\n procedure AssignDataTo(Dest: TJclAbstractContainerBase); override;\r\n public\r\n constructor Create(ACapacity: Integer);\r\n destructor Destroy; override;\r\n { IJclPackable }\r\n procedure Pack; override;\r\n procedure SetCapacity(Value: Integer); override;\r\n { IJclInt64Queue }\r\n procedure Clear;\r\n function Contains(const AValue: Int64): Boolean;\r\n function Dequeue: Int64;\r\n function Empty: Boolean;\r\n function Enqueue(const AValue: Int64): Boolean;\r\n function Peek: Int64;\r\n function Size: Integer;\r\n end;\r\n\r\n TJclPtrQueue = class(TJclPtrAbstractContainer, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclIntfCloneable, IJclCloneable, IJclPackable, IJclGrowable, IJclBaseContainer,\r\n IJclPtrContainer, IJclPtrEqualityComparer,\r\n IJclPtrQueue)\r\n protected\r\n function CreateEmptyContainer: TJclAbstractContainerBase; override;\r\n private\r\n FElements: TDynPointerArray;\r\n FHead: Integer;\r\n FTail: Integer;\r\n protected\r\n procedure AssignDataTo(Dest: TJclAbstractContainerBase); override;\r\n public\r\n constructor Create(ACapacity: Integer);\r\n destructor Destroy; override;\r\n { IJclPackable }\r\n procedure Pack; override;\r\n procedure SetCapacity(Value: Integer); override;\r\n { IJclPtrQueue }\r\n procedure Clear;\r\n function Contains(APtr: Pointer): Boolean;\r\n function Dequeue: Pointer;\r\n function Empty: Boolean;\r\n function Enqueue(APtr: Pointer): Boolean;\r\n function Peek: Pointer;\r\n function Size: Integer;\r\n end;\r\n\r\n TJclQueue = class(TJclAbstractContainer, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclIntfCloneable, IJclCloneable, IJclPackable, IJclGrowable, IJclBaseContainer,\r\n IJclContainer, IJclEqualityComparer, IJclObjectOwner,\r\n IJclQueue)\r\n protected\r\n function CreateEmptyContainer: TJclAbstractContainerBase; override;\r\n private\r\n FElements: TDynObjectArray;\r\n FHead: Integer;\r\n FTail: Integer;\r\n protected\r\n procedure AssignDataTo(Dest: TJclAbstractContainerBase); override;\r\n public\r\n constructor Create(ACapacity: Integer; AOwnsObjects: Boolean);\r\n destructor Destroy; override;\r\n { IJclPackable }\r\n procedure Pack; override;\r\n procedure SetCapacity(Value: Integer); override;\r\n { IJclQueue }\r\n procedure Clear;\r\n function Contains(AObject: TObject): Boolean;\r\n function Dequeue: TObject;\r\n function Empty: Boolean;\r\n function Enqueue(AObject: TObject): Boolean;\r\n function Peek: TObject;\r\n function Size: Integer;\r\n end;\r\n\r\n\r\n {$IFDEF SUPPORTS_GENERICS}\r\n //DOM-IGNORE-BEGIN\r\n\r\n TJclQueue = class(TJclAbstractContainer, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclIntfCloneable, IJclCloneable, IJclPackable, IJclGrowable, IJclBaseContainer,\r\n IJclContainer, IJclEqualityComparer, IJclItemOwner,\r\n IJclQueue)\r\n protected\r\n type\r\n TDynArray = array of T;\r\n procedure MoveArray(var List: TDynArray; FromIndex, ToIndex, Count: SizeInt);\r\n private\r\n FElements: TDynArray;\r\n FHead: Integer;\r\n FTail: Integer;\r\n protected\r\n procedure AssignDataTo(Dest: TJclAbstractContainerBase); override;\r\n public\r\n constructor Create(ACapacity: Integer; AOwnsItems: Boolean);\r\n destructor Destroy; override;\r\n { IJclPackable }\r\n procedure Pack; override;\r\n procedure SetCapacity(Value: Integer); override;\r\n { IJclQueue }\r\n procedure Clear;\r\n function Contains(const AItem: T): Boolean;\r\n function Dequeue: T;\r\n function Empty: Boolean;\r\n function Enqueue(const AItem: T): Boolean;\r\n function Peek: T;\r\n function Size: Integer;\r\n end;\r\n\r\n // E = external helper to compare items for equality (GetHashCode is not used)\r\n TJclQueueE = class(TJclQueue, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclIntfCloneable, IJclCloneable, IJclPackable, IJclGrowable, IJclBaseContainer, IJclContainer, IJclQueue, IJclItemOwner)\r\n private\r\n FEqualityComparer: IEqualityComparer;\r\n protected\r\n procedure AssignPropertiesTo(Dest: TJclAbstractContainerBase); override;\r\n function CreateEmptyContainer: TJclAbstractContainerBase; override;\r\n public\r\n constructor Create(const AEqualityComparer: IEqualityComparer; ACapacity: Integer; AOwnsItems: Boolean);\r\n { IJclEqualityComparer }\r\n function ItemsEqual(const A, B: T): Boolean; override;\r\n property EqualityComparer: IEqualityComparer read FEqualityComparer write FEqualityComparer;\r\n end;\r\n\r\n // F = function to compare items for equality\r\n TJclQueueF = class(TJclQueue, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclIntfCloneable, IJclCloneable, IJclPackable, IJclGrowable, IJclBaseContainer, IJclContainer, IJclQueue, IJclItemOwner)\r\n protected\r\n function CreateEmptyContainer: TJclAbstractContainerBase; override;\r\n public\r\n constructor Create(AEqualityCompare: TEqualityCompare; ACapacity: Integer; AOwnsItems: Boolean);\r\n end;\r\n\r\n // I = items can compare themselves to an other\r\n TJclQueueI> = class(TJclQueue, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclIntfCloneable, IJclCloneable, IJclPackable, IJclGrowable, IJclBaseContainer, IJclContainer, IJclQueue, IJclItemOwner)\r\n protected\r\n function CreateEmptyContainer: TJclAbstractContainerBase; override;\r\n public\r\n { IJclEqualityComparer }\r\n function ItemsEqual(const A, B: T): Boolean; override;\r\n end;\r\n\r\n //DOM-IGNORE-END\r\n {$ENDIF SUPPORTS_GENERICS}\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jcl.svn.sourceforge.net/svnroot/jcl/tags/JCL-2.4-Build4571/jcl/source/common/JclQueues.pas $';\r\n Revision: '$Revision: 3740 $';\r\n Date: '$Date: 2012-02-23 21:46:07 +0100 (jeu. 23 févr. 2012) $';\r\n LogPath: 'JCL\\source\\common';\r\n Extra: '';\r\n Data: nil\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n {$IFDEF HAS_UNITSCOPE}\r\n System.SysUtils;\r\n {$ELSE ~HAS_UNITSCOPE}\r\n SysUtils;\r\n {$ENDIF ~HAS_UNITSCOPE}\r\n\r\n//=== { TJclIntfQueue } =======================================================\r\n\r\nconstructor TJclIntfQueue.Create(ACapacity: Integer);\r\nbegin\r\n inherited Create();\r\n FHead := 0;\r\n FTail := 0;\r\n SetCapacity(ACapacity);\r\nend;\r\n\r\ndestructor TJclIntfQueue.Destroy;\r\nbegin\r\n FReadOnly := False;\r\n Clear;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJclIntfQueue.AssignDataTo(Dest: TJclAbstractContainerBase);\r\nvar\r\n ADest: TJclIntfQueue;\r\n I: Integer;\r\nbegin\r\n inherited AssignDataTo(Dest);\r\n if Dest is TJclIntfQueue then\r\n begin\r\n ADest := TJclIntfQueue(Dest);\r\n ADest.Clear;\r\n ADest.SetCapacity(Size + 1);\r\n I := FHead;\r\n while I <> FTail do\r\n begin\r\n ADest.Enqueue(FElements[I]);\r\n Inc(I);\r\n if I = FCapacity then\r\n I := 0;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJclIntfQueue.Clear;\r\nvar\r\n I: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n I := FHead;\r\n while I <> FTail do\r\n begin\r\n FreeObject(FElements[I]);\r\n Inc(I);\r\n if I = FCapacity then\r\n I := 0;\r\n end;\r\n FHead := 0;\r\n FTail := 0;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfQueue.Contains(const AInterface: IInterface): Boolean;\r\nvar\r\n I: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n I := FHead;\r\n while I <> FTail do\r\n begin\r\n if ItemsEqual(FElements[I], AInterface) then\r\n begin\r\n Result := True;\r\n Break;\r\n end;\r\n Inc(I);\r\n if I = FCapacity then\r\n I := 0;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfQueue.Dequeue: IInterface;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := nil;\r\n if FTail <> FHead then\r\n begin\r\n Result := FElements[FHead];\r\n FElements[FHead] := nil;\r\n Inc(FHead);\r\n if FHead = FCapacity then\r\n FHead := 0;\r\n AutoPack;\r\n end\r\n else\r\n if not FReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfQueue.Empty: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := FTail = FHead;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfQueue.Enqueue(const AInterface: IInterface): Boolean;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if (FTail = (FHead - 1)) or (FTail = (FHead + FCapacity - 1)) then\r\n AutoGrow;\r\n Result := (FTail <> (FHead - 1)) and (FTail <> (FHead + FCapacity - 1));\r\n if Result then\r\n begin\r\n FElements[FTail] := AInterface;\r\n Inc(FTail);\r\n if FTail = FCapacity then\r\n FTail := 0;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclIntfQueue.Pack;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n SetCapacity(Size + 1);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfQueue.Peek: IInterface;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := nil;\r\n if FTail <> FHead then\r\n Result := FElements[FHead]\r\n else\r\n if not FReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclIntfQueue.SetCapacity(Value: Integer);\r\nvar\r\n NewHead: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Value < 1 then\r\n raise EJclIllegalQueueCapacityError.Create;\r\n if Value <= Size then\r\n raise EJclOutOfBoundsError.Create;\r\n\r\n if FHead > FTail then // looped\r\n begin\r\n NewHead := FHead + Value - FCapacity;\r\n if Value > FCapacity then\r\n // growing\r\n SetLength(FElements, Value);\r\n MoveArray(FElements, FHead, NewHead, FCapacity - FHead);\r\n if FCapacity > Value then\r\n // packing\r\n SetLength(FElements, Value);\r\n FHead := NewHead;\r\n end\r\n else\r\n begin\r\n // unlooped\r\n if Value < FCapacity then\r\n begin\r\n MoveArray(FElements, FHead, 0, FTail - FHead);\r\n Dec(FTail, FHead);\r\n FHead := 0;\r\n end;\r\n SetLength(FElements, Value);\r\n end;\r\n inherited SetCapacity(Value);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfQueue.Size: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FHead > FTail then\r\n Result := FCapacity - FHead + FTail // looped\r\n else\r\n Result := FTail - FHead;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfQueue.CreateEmptyContainer: TJclAbstractContainerBase;\r\nbegin\r\n Result := TJclIntfQueue.Create(Size + 1);\r\n AssignPropertiesTo(Result);\r\nend;\r\n\r\n//=== { TJclAnsiStrQueue } =======================================================\r\n\r\nconstructor TJclAnsiStrQueue.Create(ACapacity: Integer);\r\nbegin\r\n inherited Create();\r\n FHead := 0;\r\n FTail := 0;\r\n SetCapacity(ACapacity);\r\nend;\r\n\r\ndestructor TJclAnsiStrQueue.Destroy;\r\nbegin\r\n FReadOnly := False;\r\n Clear;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJclAnsiStrQueue.AssignDataTo(Dest: TJclAbstractContainerBase);\r\nvar\r\n ADest: TJclAnsiStrQueue;\r\n I: Integer;\r\nbegin\r\n inherited AssignDataTo(Dest);\r\n if Dest is TJclAnsiStrQueue then\r\n begin\r\n ADest := TJclAnsiStrQueue(Dest);\r\n ADest.Clear;\r\n ADest.SetCapacity(Size + 1);\r\n I := FHead;\r\n while I <> FTail do\r\n begin\r\n ADest.Enqueue(FElements[I]);\r\n Inc(I);\r\n if I = FCapacity then\r\n I := 0;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJclAnsiStrQueue.Clear;\r\nvar\r\n I: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n I := FHead;\r\n while I <> FTail do\r\n begin\r\n FreeString(FElements[I]);\r\n Inc(I);\r\n if I = FCapacity then\r\n I := 0;\r\n end;\r\n FHead := 0;\r\n FTail := 0;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclAnsiStrQueue.Contains(const AString: AnsiString): Boolean;\r\nvar\r\n I: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n I := FHead;\r\n while I <> FTail do\r\n begin\r\n if ItemsEqual(FElements[I], AString) then\r\n begin\r\n Result := True;\r\n Break;\r\n end;\r\n Inc(I);\r\n if I = FCapacity then\r\n I := 0;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclAnsiStrQueue.Dequeue: AnsiString;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := '';\r\n if FTail <> FHead then\r\n begin\r\n Result := FElements[FHead];\r\n FElements[FHead] := '';\r\n Inc(FHead);\r\n if FHead = FCapacity then\r\n FHead := 0;\r\n AutoPack;\r\n end\r\n else\r\n if not FReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclAnsiStrQueue.Empty: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := FTail = FHead;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclAnsiStrQueue.Enqueue(const AString: AnsiString): Boolean;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if (FTail = (FHead - 1)) or (FTail = (FHead + FCapacity - 1)) then\r\n AutoGrow;\r\n Result := (FTail <> (FHead - 1)) and (FTail <> (FHead + FCapacity - 1));\r\n if Result then\r\n begin\r\n FElements[FTail] := AString;\r\n Inc(FTail);\r\n if FTail = FCapacity then\r\n FTail := 0;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclAnsiStrQueue.Pack;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n SetCapacity(Size + 1);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclAnsiStrQueue.Peek: AnsiString;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := '';\r\n if FTail <> FHead then\r\n Result := FElements[FHead]\r\n else\r\n if not FReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclAnsiStrQueue.SetCapacity(Value: Integer);\r\nvar\r\n NewHead: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Value < 1 then\r\n raise EJclIllegalQueueCapacityError.Create;\r\n if Value <= Size then\r\n raise EJclOutOfBoundsError.Create;\r\n\r\n if FHead > FTail then // looped\r\n begin\r\n NewHead := FHead + Value - FCapacity;\r\n if Value > FCapacity then\r\n // growing\r\n SetLength(FElements, Value);\r\n MoveArray(FElements, FHead, NewHead, FCapacity - FHead);\r\n if FCapacity > Value then\r\n // packing\r\n SetLength(FElements, Value);\r\n FHead := NewHead;\r\n end\r\n else\r\n begin\r\n // unlooped\r\n if Value < FCapacity then\r\n begin\r\n MoveArray(FElements, FHead, 0, FTail - FHead);\r\n Dec(FTail, FHead);\r\n FHead := 0;\r\n end;\r\n SetLength(FElements, Value);\r\n end;\r\n inherited SetCapacity(Value);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclAnsiStrQueue.Size: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FHead > FTail then\r\n Result := FCapacity - FHead + FTail // looped\r\n else\r\n Result := FTail - FHead;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclAnsiStrQueue.CreateEmptyContainer: TJclAbstractContainerBase;\r\nbegin\r\n Result := TJclAnsiStrQueue.Create(Size + 1);\r\n AssignPropertiesTo(Result);\r\nend;\r\n\r\n//=== { TJclWideStrQueue } =======================================================\r\n\r\nconstructor TJclWideStrQueue.Create(ACapacity: Integer);\r\nbegin\r\n inherited Create();\r\n FHead := 0;\r\n FTail := 0;\r\n SetCapacity(ACapacity);\r\nend;\r\n\r\ndestructor TJclWideStrQueue.Destroy;\r\nbegin\r\n FReadOnly := False;\r\n Clear;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJclWideStrQueue.AssignDataTo(Dest: TJclAbstractContainerBase);\r\nvar\r\n ADest: TJclWideStrQueue;\r\n I: Integer;\r\nbegin\r\n inherited AssignDataTo(Dest);\r\n if Dest is TJclWideStrQueue then\r\n begin\r\n ADest := TJclWideStrQueue(Dest);\r\n ADest.Clear;\r\n ADest.SetCapacity(Size + 1);\r\n I := FHead;\r\n while I <> FTail do\r\n begin\r\n ADest.Enqueue(FElements[I]);\r\n Inc(I);\r\n if I = FCapacity then\r\n I := 0;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJclWideStrQueue.Clear;\r\nvar\r\n I: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n I := FHead;\r\n while I <> FTail do\r\n begin\r\n FreeString(FElements[I]);\r\n Inc(I);\r\n if I = FCapacity then\r\n I := 0;\r\n end;\r\n FHead := 0;\r\n FTail := 0;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclWideStrQueue.Contains(const AString: WideString): Boolean;\r\nvar\r\n I: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n I := FHead;\r\n while I <> FTail do\r\n begin\r\n if ItemsEqual(FElements[I], AString) then\r\n begin\r\n Result := True;\r\n Break;\r\n end;\r\n Inc(I);\r\n if I = FCapacity then\r\n I := 0;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclWideStrQueue.Dequeue: WideString;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := '';\r\n if FTail <> FHead then\r\n begin\r\n Result := FElements[FHead];\r\n FElements[FHead] := '';\r\n Inc(FHead);\r\n if FHead = FCapacity then\r\n FHead := 0;\r\n AutoPack;\r\n end\r\n else\r\n if not FReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclWideStrQueue.Empty: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := FTail = FHead;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclWideStrQueue.Enqueue(const AString: WideString): Boolean;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if (FTail = (FHead - 1)) or (FTail = (FHead + FCapacity - 1)) then\r\n AutoGrow;\r\n Result := (FTail <> (FHead - 1)) and (FTail <> (FHead + FCapacity - 1));\r\n if Result then\r\n begin\r\n FElements[FTail] := AString;\r\n Inc(FTail);\r\n if FTail = FCapacity then\r\n FTail := 0;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclWideStrQueue.Pack;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n SetCapacity(Size + 1);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclWideStrQueue.Peek: WideString;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := '';\r\n if FTail <> FHead then\r\n Result := FElements[FHead]\r\n else\r\n if not FReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclWideStrQueue.SetCapacity(Value: Integer);\r\nvar\r\n NewHead: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Value < 1 then\r\n raise EJclIllegalQueueCapacityError.Create;\r\n if Value <= Size then\r\n raise EJclOutOfBoundsError.Create;\r\n\r\n if FHead > FTail then // looped\r\n begin\r\n NewHead := FHead + Value - FCapacity;\r\n if Value > FCapacity then\r\n // growing\r\n SetLength(FElements, Value);\r\n MoveArray(FElements, FHead, NewHead, FCapacity - FHead);\r\n if FCapacity > Value then\r\n // packing\r\n SetLength(FElements, Value);\r\n FHead := NewHead;\r\n end\r\n else\r\n begin\r\n // unlooped\r\n if Value < FCapacity then\r\n begin\r\n MoveArray(FElements, FHead, 0, FTail - FHead);\r\n Dec(FTail, FHead);\r\n FHead := 0;\r\n end;\r\n SetLength(FElements, Value);\r\n end;\r\n inherited SetCapacity(Value);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclWideStrQueue.Size: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FHead > FTail then\r\n Result := FCapacity - FHead + FTail // looped\r\n else\r\n Result := FTail - FHead;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclWideStrQueue.CreateEmptyContainer: TJclAbstractContainerBase;\r\nbegin\r\n Result := TJclWideStrQueue.Create(Size + 1);\r\n AssignPropertiesTo(Result);\r\nend;\r\n\r\n{$IFDEF SUPPORTS_UNICODE_STRING}\r\n//=== { TJclUnicodeStrQueue } =======================================================\r\n\r\nconstructor TJclUnicodeStrQueue.Create(ACapacity: Integer);\r\nbegin\r\n inherited Create();\r\n FHead := 0;\r\n FTail := 0;\r\n SetCapacity(ACapacity);\r\nend;\r\n\r\ndestructor TJclUnicodeStrQueue.Destroy;\r\nbegin\r\n FReadOnly := False;\r\n Clear;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJclUnicodeStrQueue.AssignDataTo(Dest: TJclAbstractContainerBase);\r\nvar\r\n ADest: TJclUnicodeStrQueue;\r\n I: Integer;\r\nbegin\r\n inherited AssignDataTo(Dest);\r\n if Dest is TJclUnicodeStrQueue then\r\n begin\r\n ADest := TJclUnicodeStrQueue(Dest);\r\n ADest.Clear;\r\n ADest.SetCapacity(Size + 1);\r\n I := FHead;\r\n while I <> FTail do\r\n begin\r\n ADest.Enqueue(FElements[I]);\r\n Inc(I);\r\n if I = FCapacity then\r\n I := 0;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJclUnicodeStrQueue.Clear;\r\nvar\r\n I: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n I := FHead;\r\n while I <> FTail do\r\n begin\r\n FreeString(FElements[I]);\r\n Inc(I);\r\n if I = FCapacity then\r\n I := 0;\r\n end;\r\n FHead := 0;\r\n FTail := 0;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclUnicodeStrQueue.Contains(const AString: UnicodeString): Boolean;\r\nvar\r\n I: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n I := FHead;\r\n while I <> FTail do\r\n begin\r\n if ItemsEqual(FElements[I], AString) then\r\n begin\r\n Result := True;\r\n Break;\r\n end;\r\n Inc(I);\r\n if I = FCapacity then\r\n I := 0;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclUnicodeStrQueue.Dequeue: UnicodeString;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := '';\r\n if FTail <> FHead then\r\n begin\r\n Result := FElements[FHead];\r\n FElements[FHead] := '';\r\n Inc(FHead);\r\n if FHead = FCapacity then\r\n FHead := 0;\r\n AutoPack;\r\n end\r\n else\r\n if not FReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclUnicodeStrQueue.Empty: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := FTail = FHead;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclUnicodeStrQueue.Enqueue(const AString: UnicodeString): Boolean;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if (FTail = (FHead - 1)) or (FTail = (FHead + FCapacity - 1)) then\r\n AutoGrow;\r\n Result := (FTail <> (FHead - 1)) and (FTail <> (FHead + FCapacity - 1));\r\n if Result then\r\n begin\r\n FElements[FTail] := AString;\r\n Inc(FTail);\r\n if FTail = FCapacity then\r\n FTail := 0;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclUnicodeStrQueue.Pack;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n SetCapacity(Size + 1);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclUnicodeStrQueue.Peek: UnicodeString;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := '';\r\n if FTail <> FHead then\r\n Result := FElements[FHead]\r\n else\r\n if not FReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclUnicodeStrQueue.SetCapacity(Value: Integer);\r\nvar\r\n NewHead: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Value < 1 then\r\n raise EJclIllegalQueueCapacityError.Create;\r\n if Value <= Size then\r\n raise EJclOutOfBoundsError.Create;\r\n\r\n if FHead > FTail then // looped\r\n begin\r\n NewHead := FHead + Value - FCapacity;\r\n if Value > FCapacity then\r\n // growing\r\n SetLength(FElements, Value);\r\n MoveArray(FElements, FHead, NewHead, FCapacity - FHead);\r\n if FCapacity > Value then\r\n // packing\r\n SetLength(FElements, Value);\r\n FHead := NewHead;\r\n end\r\n else\r\n begin\r\n // unlooped\r\n if Value < FCapacity then\r\n begin\r\n MoveArray(FElements, FHead, 0, FTail - FHead);\r\n Dec(FTail, FHead);\r\n FHead := 0;\r\n end;\r\n SetLength(FElements, Value);\r\n end;\r\n inherited SetCapacity(Value);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclUnicodeStrQueue.Size: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FHead > FTail then\r\n Result := FCapacity - FHead + FTail // looped\r\n else\r\n Result := FTail - FHead;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclUnicodeStrQueue.CreateEmptyContainer: TJclAbstractContainerBase;\r\nbegin\r\n Result := TJclUnicodeStrQueue.Create(Size + 1);\r\n AssignPropertiesTo(Result);\r\nend;\r\n\r\n{$ENDIF SUPPORTS_UNICODE_STRING}\r\n\r\n//=== { TJclSingleQueue } =======================================================\r\n\r\nconstructor TJclSingleQueue.Create(ACapacity: Integer);\r\nbegin\r\n inherited Create();\r\n FHead := 0;\r\n FTail := 0;\r\n SetCapacity(ACapacity);\r\nend;\r\n\r\ndestructor TJclSingleQueue.Destroy;\r\nbegin\r\n FReadOnly := False;\r\n Clear;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJclSingleQueue.AssignDataTo(Dest: TJclAbstractContainerBase);\r\nvar\r\n ADest: TJclSingleQueue;\r\n I: Integer;\r\nbegin\r\n inherited AssignDataTo(Dest);\r\n if Dest is TJclSingleQueue then\r\n begin\r\n ADest := TJclSingleQueue(Dest);\r\n ADest.Clear;\r\n ADest.SetCapacity(Size + 1);\r\n I := FHead;\r\n while I <> FTail do\r\n begin\r\n ADest.Enqueue(FElements[I]);\r\n Inc(I);\r\n if I = FCapacity then\r\n I := 0;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJclSingleQueue.Clear;\r\nvar\r\n I: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n I := FHead;\r\n while I <> FTail do\r\n begin\r\n FreeSingle(FElements[I]);\r\n Inc(I);\r\n if I = FCapacity then\r\n I := 0;\r\n end;\r\n FHead := 0;\r\n FTail := 0;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSingleQueue.Contains(const AValue: Single): Boolean;\r\nvar\r\n I: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n I := FHead;\r\n while I <> FTail do\r\n begin\r\n if ItemsEqual(FElements[I], AValue) then\r\n begin\r\n Result := True;\r\n Break;\r\n end;\r\n Inc(I);\r\n if I = FCapacity then\r\n I := 0;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSingleQueue.Dequeue: Single;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := 0.0;\r\n if FTail <> FHead then\r\n begin\r\n Result := FElements[FHead];\r\n FElements[FHead] := 0.0;\r\n Inc(FHead);\r\n if FHead = FCapacity then\r\n FHead := 0;\r\n AutoPack;\r\n end\r\n else\r\n if not FReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSingleQueue.Empty: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := FTail = FHead;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSingleQueue.Enqueue(const AValue: Single): Boolean;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if (FTail = (FHead - 1)) or (FTail = (FHead + FCapacity - 1)) then\r\n AutoGrow;\r\n Result := (FTail <> (FHead - 1)) and (FTail <> (FHead + FCapacity - 1));\r\n if Result then\r\n begin\r\n FElements[FTail] := AValue;\r\n Inc(FTail);\r\n if FTail = FCapacity then\r\n FTail := 0;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclSingleQueue.Pack;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n SetCapacity(Size + 1);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSingleQueue.Peek: Single;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := 0.0;\r\n if FTail <> FHead then\r\n Result := FElements[FHead]\r\n else\r\n if not FReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclSingleQueue.SetCapacity(Value: Integer);\r\nvar\r\n NewHead: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Value < 1 then\r\n raise EJclIllegalQueueCapacityError.Create;\r\n if Value <= Size then\r\n raise EJclOutOfBoundsError.Create;\r\n\r\n if FHead > FTail then // looped\r\n begin\r\n NewHead := FHead + Value - FCapacity;\r\n if Value > FCapacity then\r\n // growing\r\n SetLength(FElements, Value);\r\n MoveArray(FElements, FHead, NewHead, FCapacity - FHead);\r\n if FCapacity > Value then\r\n // packing\r\n SetLength(FElements, Value);\r\n FHead := NewHead;\r\n end\r\n else\r\n begin\r\n // unlooped\r\n if Value < FCapacity then\r\n begin\r\n MoveArray(FElements, FHead, 0, FTail - FHead);\r\n Dec(FTail, FHead);\r\n FHead := 0;\r\n end;\r\n SetLength(FElements, Value);\r\n end;\r\n inherited SetCapacity(Value);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSingleQueue.Size: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FHead > FTail then\r\n Result := FCapacity - FHead + FTail // looped\r\n else\r\n Result := FTail - FHead;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSingleQueue.CreateEmptyContainer: TJclAbstractContainerBase;\r\nbegin\r\n Result := TJclSingleQueue.Create(Size + 1);\r\n AssignPropertiesTo(Result);\r\nend;\r\n\r\n//=== { TJclDoubleQueue } =======================================================\r\n\r\nconstructor TJclDoubleQueue.Create(ACapacity: Integer);\r\nbegin\r\n inherited Create();\r\n FHead := 0;\r\n FTail := 0;\r\n SetCapacity(ACapacity);\r\nend;\r\n\r\ndestructor TJclDoubleQueue.Destroy;\r\nbegin\r\n FReadOnly := False;\r\n Clear;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJclDoubleQueue.AssignDataTo(Dest: TJclAbstractContainerBase);\r\nvar\r\n ADest: TJclDoubleQueue;\r\n I: Integer;\r\nbegin\r\n inherited AssignDataTo(Dest);\r\n if Dest is TJclDoubleQueue then\r\n begin\r\n ADest := TJclDoubleQueue(Dest);\r\n ADest.Clear;\r\n ADest.SetCapacity(Size + 1);\r\n I := FHead;\r\n while I <> FTail do\r\n begin\r\n ADest.Enqueue(FElements[I]);\r\n Inc(I);\r\n if I = FCapacity then\r\n I := 0;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJclDoubleQueue.Clear;\r\nvar\r\n I: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n I := FHead;\r\n while I <> FTail do\r\n begin\r\n FreeDouble(FElements[I]);\r\n Inc(I);\r\n if I = FCapacity then\r\n I := 0;\r\n end;\r\n FHead := 0;\r\n FTail := 0;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclDoubleQueue.Contains(const AValue: Double): Boolean;\r\nvar\r\n I: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n I := FHead;\r\n while I <> FTail do\r\n begin\r\n if ItemsEqual(FElements[I], AValue) then\r\n begin\r\n Result := True;\r\n Break;\r\n end;\r\n Inc(I);\r\n if I = FCapacity then\r\n I := 0;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclDoubleQueue.Dequeue: Double;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := 0.0;\r\n if FTail <> FHead then\r\n begin\r\n Result := FElements[FHead];\r\n FElements[FHead] := 0.0;\r\n Inc(FHead);\r\n if FHead = FCapacity then\r\n FHead := 0;\r\n AutoPack;\r\n end\r\n else\r\n if not FReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclDoubleQueue.Empty: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := FTail = FHead;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclDoubleQueue.Enqueue(const AValue: Double): Boolean;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if (FTail = (FHead - 1)) or (FTail = (FHead + FCapacity - 1)) then\r\n AutoGrow;\r\n Result := (FTail <> (FHead - 1)) and (FTail <> (FHead + FCapacity - 1));\r\n if Result then\r\n begin\r\n FElements[FTail] := AValue;\r\n Inc(FTail);\r\n if FTail = FCapacity then\r\n FTail := 0;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclDoubleQueue.Pack;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n SetCapacity(Size + 1);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclDoubleQueue.Peek: Double;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := 0.0;\r\n if FTail <> FHead then\r\n Result := FElements[FHead]\r\n else\r\n if not FReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclDoubleQueue.SetCapacity(Value: Integer);\r\nvar\r\n NewHead: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Value < 1 then\r\n raise EJclIllegalQueueCapacityError.Create;\r\n if Value <= Size then\r\n raise EJclOutOfBoundsError.Create;\r\n\r\n if FHead > FTail then // looped\r\n begin\r\n NewHead := FHead + Value - FCapacity;\r\n if Value > FCapacity then\r\n // growing\r\n SetLength(FElements, Value);\r\n MoveArray(FElements, FHead, NewHead, FCapacity - FHead);\r\n if FCapacity > Value then\r\n // packing\r\n SetLength(FElements, Value);\r\n FHead := NewHead;\r\n end\r\n else\r\n begin\r\n // unlooped\r\n if Value < FCapacity then\r\n begin\r\n MoveArray(FElements, FHead, 0, FTail - FHead);\r\n Dec(FTail, FHead);\r\n FHead := 0;\r\n end;\r\n SetLength(FElements, Value);\r\n end;\r\n inherited SetCapacity(Value);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclDoubleQueue.Size: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FHead > FTail then\r\n Result := FCapacity - FHead + FTail // looped\r\n else\r\n Result := FTail - FHead;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclDoubleQueue.CreateEmptyContainer: TJclAbstractContainerBase;\r\nbegin\r\n Result := TJclDoubleQueue.Create(Size + 1);\r\n AssignPropertiesTo(Result);\r\nend;\r\n\r\n//=== { TJclExtendedQueue } =======================================================\r\n\r\nconstructor TJclExtendedQueue.Create(ACapacity: Integer);\r\nbegin\r\n inherited Create();\r\n FHead := 0;\r\n FTail := 0;\r\n SetCapacity(ACapacity);\r\nend;\r\n\r\ndestructor TJclExtendedQueue.Destroy;\r\nbegin\r\n FReadOnly := False;\r\n Clear;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJclExtendedQueue.AssignDataTo(Dest: TJclAbstractContainerBase);\r\nvar\r\n ADest: TJclExtendedQueue;\r\n I: Integer;\r\nbegin\r\n inherited AssignDataTo(Dest);\r\n if Dest is TJclExtendedQueue then\r\n begin\r\n ADest := TJclExtendedQueue(Dest);\r\n ADest.Clear;\r\n ADest.SetCapacity(Size + 1);\r\n I := FHead;\r\n while I <> FTail do\r\n begin\r\n ADest.Enqueue(FElements[I]);\r\n Inc(I);\r\n if I = FCapacity then\r\n I := 0;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJclExtendedQueue.Clear;\r\nvar\r\n I: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n I := FHead;\r\n while I <> FTail do\r\n begin\r\n FreeExtended(FElements[I]);\r\n Inc(I);\r\n if I = FCapacity then\r\n I := 0;\r\n end;\r\n FHead := 0;\r\n FTail := 0;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclExtendedQueue.Contains(const AValue: Extended): Boolean;\r\nvar\r\n I: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n I := FHead;\r\n while I <> FTail do\r\n begin\r\n if ItemsEqual(FElements[I], AValue) then\r\n begin\r\n Result := True;\r\n Break;\r\n end;\r\n Inc(I);\r\n if I = FCapacity then\r\n I := 0;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclExtendedQueue.Dequeue: Extended;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := 0.0;\r\n if FTail <> FHead then\r\n begin\r\n Result := FElements[FHead];\r\n FElements[FHead] := 0.0;\r\n Inc(FHead);\r\n if FHead = FCapacity then\r\n FHead := 0;\r\n AutoPack;\r\n end\r\n else\r\n if not FReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclExtendedQueue.Empty: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := FTail = FHead;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclExtendedQueue.Enqueue(const AValue: Extended): Boolean;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if (FTail = (FHead - 1)) or (FTail = (FHead + FCapacity - 1)) then\r\n AutoGrow;\r\n Result := (FTail <> (FHead - 1)) and (FTail <> (FHead + FCapacity - 1));\r\n if Result then\r\n begin\r\n FElements[FTail] := AValue;\r\n Inc(FTail);\r\n if FTail = FCapacity then\r\n FTail := 0;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclExtendedQueue.Pack;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n SetCapacity(Size + 1);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclExtendedQueue.Peek: Extended;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := 0.0;\r\n if FTail <> FHead then\r\n Result := FElements[FHead]\r\n else\r\n if not FReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclExtendedQueue.SetCapacity(Value: Integer);\r\nvar\r\n NewHead: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Value < 1 then\r\n raise EJclIllegalQueueCapacityError.Create;\r\n if Value <= Size then\r\n raise EJclOutOfBoundsError.Create;\r\n\r\n if FHead > FTail then // looped\r\n begin\r\n NewHead := FHead + Value - FCapacity;\r\n if Value > FCapacity then\r\n // growing\r\n SetLength(FElements, Value);\r\n MoveArray(FElements, FHead, NewHead, FCapacity - FHead);\r\n if FCapacity > Value then\r\n // packing\r\n SetLength(FElements, Value);\r\n FHead := NewHead;\r\n end\r\n else\r\n begin\r\n // unlooped\r\n if Value < FCapacity then\r\n begin\r\n MoveArray(FElements, FHead, 0, FTail - FHead);\r\n Dec(FTail, FHead);\r\n FHead := 0;\r\n end;\r\n SetLength(FElements, Value);\r\n end;\r\n inherited SetCapacity(Value);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclExtendedQueue.Size: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FHead > FTail then\r\n Result := FCapacity - FHead + FTail // looped\r\n else\r\n Result := FTail - FHead;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclExtendedQueue.CreateEmptyContainer: TJclAbstractContainerBase;\r\nbegin\r\n Result := TJclExtendedQueue.Create(Size + 1);\r\n AssignPropertiesTo(Result);\r\nend;\r\n\r\n//=== { TJclIntegerQueue } =======================================================\r\n\r\nconstructor TJclIntegerQueue.Create(ACapacity: Integer);\r\nbegin\r\n inherited Create();\r\n FHead := 0;\r\n FTail := 0;\r\n SetCapacity(ACapacity);\r\nend;\r\n\r\ndestructor TJclIntegerQueue.Destroy;\r\nbegin\r\n FReadOnly := False;\r\n Clear;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJclIntegerQueue.AssignDataTo(Dest: TJclAbstractContainerBase);\r\nvar\r\n ADest: TJclIntegerQueue;\r\n I: Integer;\r\nbegin\r\n inherited AssignDataTo(Dest);\r\n if Dest is TJclIntegerQueue then\r\n begin\r\n ADest := TJclIntegerQueue(Dest);\r\n ADest.Clear;\r\n ADest.SetCapacity(Size + 1);\r\n I := FHead;\r\n while I <> FTail do\r\n begin\r\n ADest.Enqueue(FElements[I]);\r\n Inc(I);\r\n if I = FCapacity then\r\n I := 0;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJclIntegerQueue.Clear;\r\nvar\r\n I: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n I := FHead;\r\n while I <> FTail do\r\n begin\r\n FreeInteger(FElements[I]);\r\n Inc(I);\r\n if I = FCapacity then\r\n I := 0;\r\n end;\r\n FHead := 0;\r\n FTail := 0;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntegerQueue.Contains(AValue: Integer): Boolean;\r\nvar\r\n I: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n I := FHead;\r\n while I <> FTail do\r\n begin\r\n if ItemsEqual(FElements[I], AValue) then\r\n begin\r\n Result := True;\r\n Break;\r\n end;\r\n Inc(I);\r\n if I = FCapacity then\r\n I := 0;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntegerQueue.Dequeue: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := 0;\r\n if FTail <> FHead then\r\n begin\r\n Result := FElements[FHead];\r\n FElements[FHead] := 0;\r\n Inc(FHead);\r\n if FHead = FCapacity then\r\n FHead := 0;\r\n AutoPack;\r\n end\r\n else\r\n if not FReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntegerQueue.Empty: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := FTail = FHead;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntegerQueue.Enqueue(AValue: Integer): Boolean;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if (FTail = (FHead - 1)) or (FTail = (FHead + FCapacity - 1)) then\r\n AutoGrow;\r\n Result := (FTail <> (FHead - 1)) and (FTail <> (FHead + FCapacity - 1));\r\n if Result then\r\n begin\r\n FElements[FTail] := AValue;\r\n Inc(FTail);\r\n if FTail = FCapacity then\r\n FTail := 0;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclIntegerQueue.Pack;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n SetCapacity(Size + 1);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntegerQueue.Peek: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := 0;\r\n if FTail <> FHead then\r\n Result := FElements[FHead]\r\n else\r\n if not FReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclIntegerQueue.SetCapacity(Value: Integer);\r\nvar\r\n NewHead: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Value < 1 then\r\n raise EJclIllegalQueueCapacityError.Create;\r\n if Value <= Size then\r\n raise EJclOutOfBoundsError.Create;\r\n\r\n if FHead > FTail then // looped\r\n begin\r\n NewHead := FHead + Value - FCapacity;\r\n if Value > FCapacity then\r\n // growing\r\n SetLength(FElements, Value);\r\n MoveArray(FElements, FHead, NewHead, FCapacity - FHead);\r\n if FCapacity > Value then\r\n // packing\r\n SetLength(FElements, Value);\r\n FHead := NewHead;\r\n end\r\n else\r\n begin\r\n // unlooped\r\n if Value < FCapacity then\r\n begin\r\n MoveArray(FElements, FHead, 0, FTail - FHead);\r\n Dec(FTail, FHead);\r\n FHead := 0;\r\n end;\r\n SetLength(FElements, Value);\r\n end;\r\n inherited SetCapacity(Value);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntegerQueue.Size: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FHead > FTail then\r\n Result := FCapacity - FHead + FTail // looped\r\n else\r\n Result := FTail - FHead;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntegerQueue.CreateEmptyContainer: TJclAbstractContainerBase;\r\nbegin\r\n Result := TJclIntegerQueue.Create(Size + 1);\r\n AssignPropertiesTo(Result);\r\nend;\r\n\r\n//=== { TJclCardinalQueue } =======================================================\r\n\r\nconstructor TJclCardinalQueue.Create(ACapacity: Integer);\r\nbegin\r\n inherited Create();\r\n FHead := 0;\r\n FTail := 0;\r\n SetCapacity(ACapacity);\r\nend;\r\n\r\ndestructor TJclCardinalQueue.Destroy;\r\nbegin\r\n FReadOnly := False;\r\n Clear;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJclCardinalQueue.AssignDataTo(Dest: TJclAbstractContainerBase);\r\nvar\r\n ADest: TJclCardinalQueue;\r\n I: Integer;\r\nbegin\r\n inherited AssignDataTo(Dest);\r\n if Dest is TJclCardinalQueue then\r\n begin\r\n ADest := TJclCardinalQueue(Dest);\r\n ADest.Clear;\r\n ADest.SetCapacity(Size + 1);\r\n I := FHead;\r\n while I <> FTail do\r\n begin\r\n ADest.Enqueue(FElements[I]);\r\n Inc(I);\r\n if I = FCapacity then\r\n I := 0;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJclCardinalQueue.Clear;\r\nvar\r\n I: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n I := FHead;\r\n while I <> FTail do\r\n begin\r\n FreeCardinal(FElements[I]);\r\n Inc(I);\r\n if I = FCapacity then\r\n I := 0;\r\n end;\r\n FHead := 0;\r\n FTail := 0;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclCardinalQueue.Contains(AValue: Cardinal): Boolean;\r\nvar\r\n I: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n I := FHead;\r\n while I <> FTail do\r\n begin\r\n if ItemsEqual(FElements[I], AValue) then\r\n begin\r\n Result := True;\r\n Break;\r\n end;\r\n Inc(I);\r\n if I = FCapacity then\r\n I := 0;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclCardinalQueue.Dequeue: Cardinal;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := 0;\r\n if FTail <> FHead then\r\n begin\r\n Result := FElements[FHead];\r\n FElements[FHead] := 0;\r\n Inc(FHead);\r\n if FHead = FCapacity then\r\n FHead := 0;\r\n AutoPack;\r\n end\r\n else\r\n if not FReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclCardinalQueue.Empty: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := FTail = FHead;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclCardinalQueue.Enqueue(AValue: Cardinal): Boolean;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if (FTail = (FHead - 1)) or (FTail = (FHead + FCapacity - 1)) then\r\n AutoGrow;\r\n Result := (FTail <> (FHead - 1)) and (FTail <> (FHead + FCapacity - 1));\r\n if Result then\r\n begin\r\n FElements[FTail] := AValue;\r\n Inc(FTail);\r\n if FTail = FCapacity then\r\n FTail := 0;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclCardinalQueue.Pack;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n SetCapacity(Size + 1);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclCardinalQueue.Peek: Cardinal;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := 0;\r\n if FTail <> FHead then\r\n Result := FElements[FHead]\r\n else\r\n if not FReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclCardinalQueue.SetCapacity(Value: Integer);\r\nvar\r\n NewHead: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Value < 1 then\r\n raise EJclIllegalQueueCapacityError.Create;\r\n if Value <= Size then\r\n raise EJclOutOfBoundsError.Create;\r\n\r\n if FHead > FTail then // looped\r\n begin\r\n NewHead := FHead + Value - FCapacity;\r\n if Value > FCapacity then\r\n // growing\r\n SetLength(FElements, Value);\r\n MoveArray(FElements, FHead, NewHead, FCapacity - FHead);\r\n if FCapacity > Value then\r\n // packing\r\n SetLength(FElements, Value);\r\n FHead := NewHead;\r\n end\r\n else\r\n begin\r\n // unlooped\r\n if Value < FCapacity then\r\n begin\r\n MoveArray(FElements, FHead, 0, FTail - FHead);\r\n Dec(FTail, FHead);\r\n FHead := 0;\r\n end;\r\n SetLength(FElements, Value);\r\n end;\r\n inherited SetCapacity(Value);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclCardinalQueue.Size: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FHead > FTail then\r\n Result := FCapacity - FHead + FTail // looped\r\n else\r\n Result := FTail - FHead;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclCardinalQueue.CreateEmptyContainer: TJclAbstractContainerBase;\r\nbegin\r\n Result := TJclCardinalQueue.Create(Size + 1);\r\n AssignPropertiesTo(Result);\r\nend;\r\n\r\n//=== { TJclInt64Queue } =======================================================\r\n\r\nconstructor TJclInt64Queue.Create(ACapacity: Integer);\r\nbegin\r\n inherited Create();\r\n FHead := 0;\r\n FTail := 0;\r\n SetCapacity(ACapacity);\r\nend;\r\n\r\ndestructor TJclInt64Queue.Destroy;\r\nbegin\r\n FReadOnly := False;\r\n Clear;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJclInt64Queue.AssignDataTo(Dest: TJclAbstractContainerBase);\r\nvar\r\n ADest: TJclInt64Queue;\r\n I: Integer;\r\nbegin\r\n inherited AssignDataTo(Dest);\r\n if Dest is TJclInt64Queue then\r\n begin\r\n ADest := TJclInt64Queue(Dest);\r\n ADest.Clear;\r\n ADest.SetCapacity(Size + 1);\r\n I := FHead;\r\n while I <> FTail do\r\n begin\r\n ADest.Enqueue(FElements[I]);\r\n Inc(I);\r\n if I = FCapacity then\r\n I := 0;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJclInt64Queue.Clear;\r\nvar\r\n I: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n I := FHead;\r\n while I <> FTail do\r\n begin\r\n FreeInt64(FElements[I]);\r\n Inc(I);\r\n if I = FCapacity then\r\n I := 0;\r\n end;\r\n FHead := 0;\r\n FTail := 0;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclInt64Queue.Contains(const AValue: Int64): Boolean;\r\nvar\r\n I: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n I := FHead;\r\n while I <> FTail do\r\n begin\r\n if ItemsEqual(FElements[I], AValue) then\r\n begin\r\n Result := True;\r\n Break;\r\n end;\r\n Inc(I);\r\n if I = FCapacity then\r\n I := 0;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclInt64Queue.Dequeue: Int64;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := 0;\r\n if FTail <> FHead then\r\n begin\r\n Result := FElements[FHead];\r\n FElements[FHead] := 0;\r\n Inc(FHead);\r\n if FHead = FCapacity then\r\n FHead := 0;\r\n AutoPack;\r\n end\r\n else\r\n if not FReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclInt64Queue.Empty: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := FTail = FHead;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclInt64Queue.Enqueue(const AValue: Int64): Boolean;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if (FTail = (FHead - 1)) or (FTail = (FHead + FCapacity - 1)) then\r\n AutoGrow;\r\n Result := (FTail <> (FHead - 1)) and (FTail <> (FHead + FCapacity - 1));\r\n if Result then\r\n begin\r\n FElements[FTail] := AValue;\r\n Inc(FTail);\r\n if FTail = FCapacity then\r\n FTail := 0;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclInt64Queue.Pack;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n SetCapacity(Size + 1);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclInt64Queue.Peek: Int64;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := 0;\r\n if FTail <> FHead then\r\n Result := FElements[FHead]\r\n else\r\n if not FReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclInt64Queue.SetCapacity(Value: Integer);\r\nvar\r\n NewHead: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Value < 1 then\r\n raise EJclIllegalQueueCapacityError.Create;\r\n if Value <= Size then\r\n raise EJclOutOfBoundsError.Create;\r\n\r\n if FHead > FTail then // looped\r\n begin\r\n NewHead := FHead + Value - FCapacity;\r\n if Value > FCapacity then\r\n // growing\r\n SetLength(FElements, Value);\r\n MoveArray(FElements, FHead, NewHead, FCapacity - FHead);\r\n if FCapacity > Value then\r\n // packing\r\n SetLength(FElements, Value);\r\n FHead := NewHead;\r\n end\r\n else\r\n begin\r\n // unlooped\r\n if Value < FCapacity then\r\n begin\r\n MoveArray(FElements, FHead, 0, FTail - FHead);\r\n Dec(FTail, FHead);\r\n FHead := 0;\r\n end;\r\n SetLength(FElements, Value);\r\n end;\r\n inherited SetCapacity(Value);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclInt64Queue.Size: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FHead > FTail then\r\n Result := FCapacity - FHead + FTail // looped\r\n else\r\n Result := FTail - FHead;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclInt64Queue.CreateEmptyContainer: TJclAbstractContainerBase;\r\nbegin\r\n Result := TJclInt64Queue.Create(Size + 1);\r\n AssignPropertiesTo(Result);\r\nend;\r\n\r\n//=== { TJclPtrQueue } =======================================================\r\n\r\nconstructor TJclPtrQueue.Create(ACapacity: Integer);\r\nbegin\r\n inherited Create();\r\n FHead := 0;\r\n FTail := 0;\r\n SetCapacity(ACapacity);\r\nend;\r\n\r\ndestructor TJclPtrQueue.Destroy;\r\nbegin\r\n FReadOnly := False;\r\n Clear;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJclPtrQueue.AssignDataTo(Dest: TJclAbstractContainerBase);\r\nvar\r\n ADest: TJclPtrQueue;\r\n I: Integer;\r\nbegin\r\n inherited AssignDataTo(Dest);\r\n if Dest is TJclPtrQueue then\r\n begin\r\n ADest := TJclPtrQueue(Dest);\r\n ADest.Clear;\r\n ADest.SetCapacity(Size + 1);\r\n I := FHead;\r\n while I <> FTail do\r\n begin\r\n ADest.Enqueue(FElements[I]);\r\n Inc(I);\r\n if I = FCapacity then\r\n I := 0;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJclPtrQueue.Clear;\r\nvar\r\n I: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n I := FHead;\r\n while I <> FTail do\r\n begin\r\n FreePointer(FElements[I]);\r\n Inc(I);\r\n if I = FCapacity then\r\n I := 0;\r\n end;\r\n FHead := 0;\r\n FTail := 0;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclPtrQueue.Contains(APtr: Pointer): Boolean;\r\nvar\r\n I: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n I := FHead;\r\n while I <> FTail do\r\n begin\r\n if ItemsEqual(FElements[I], APtr) then\r\n begin\r\n Result := True;\r\n Break;\r\n end;\r\n Inc(I);\r\n if I = FCapacity then\r\n I := 0;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclPtrQueue.Dequeue: Pointer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := nil;\r\n if FTail <> FHead then\r\n begin\r\n Result := FElements[FHead];\r\n FElements[FHead] := nil;\r\n Inc(FHead);\r\n if FHead = FCapacity then\r\n FHead := 0;\r\n AutoPack;\r\n end\r\n else\r\n if not FReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclPtrQueue.Empty: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := FTail = FHead;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclPtrQueue.Enqueue(APtr: Pointer): Boolean;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if (FTail = (FHead - 1)) or (FTail = (FHead + FCapacity - 1)) then\r\n AutoGrow;\r\n Result := (FTail <> (FHead - 1)) and (FTail <> (FHead + FCapacity - 1));\r\n if Result then\r\n begin\r\n FElements[FTail] := APtr;\r\n Inc(FTail);\r\n if FTail = FCapacity then\r\n FTail := 0;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclPtrQueue.Pack;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n SetCapacity(Size + 1);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclPtrQueue.Peek: Pointer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := nil;\r\n if FTail <> FHead then\r\n Result := FElements[FHead]\r\n else\r\n if not FReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclPtrQueue.SetCapacity(Value: Integer);\r\nvar\r\n NewHead: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Value < 1 then\r\n raise EJclIllegalQueueCapacityError.Create;\r\n if Value <= Size then\r\n raise EJclOutOfBoundsError.Create;\r\n\r\n if FHead > FTail then // looped\r\n begin\r\n NewHead := FHead + Value - FCapacity;\r\n if Value > FCapacity then\r\n // growing\r\n SetLength(FElements, Value);\r\n MoveArray(FElements, FHead, NewHead, FCapacity - FHead);\r\n if FCapacity > Value then\r\n // packing\r\n SetLength(FElements, Value);\r\n FHead := NewHead;\r\n end\r\n else\r\n begin\r\n // unlooped\r\n if Value < FCapacity then\r\n begin\r\n MoveArray(FElements, FHead, 0, FTail - FHead);\r\n Dec(FTail, FHead);\r\n FHead := 0;\r\n end;\r\n SetLength(FElements, Value);\r\n end;\r\n inherited SetCapacity(Value);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclPtrQueue.Size: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FHead > FTail then\r\n Result := FCapacity - FHead + FTail // looped\r\n else\r\n Result := FTail - FHead;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclPtrQueue.CreateEmptyContainer: TJclAbstractContainerBase;\r\nbegin\r\n Result := TJclPtrQueue.Create(Size + 1);\r\n AssignPropertiesTo(Result);\r\nend;\r\n\r\n//=== { TJclQueue } =======================================================\r\n\r\nconstructor TJclQueue.Create(ACapacity: Integer; AOwnsObjects: Boolean);\r\nbegin\r\n inherited Create(AOwnsObjects);\r\n FHead := 0;\r\n FTail := 0;\r\n SetCapacity(ACapacity);\r\nend;\r\n\r\ndestructor TJclQueue.Destroy;\r\nbegin\r\n FReadOnly := False;\r\n Clear;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJclQueue.AssignDataTo(Dest: TJclAbstractContainerBase);\r\nvar\r\n ADest: TJclQueue;\r\n I: Integer;\r\nbegin\r\n inherited AssignDataTo(Dest);\r\n if Dest is TJclQueue then\r\n begin\r\n ADest := TJclQueue(Dest);\r\n ADest.Clear;\r\n ADest.SetCapacity(Size + 1);\r\n I := FHead;\r\n while I <> FTail do\r\n begin\r\n ADest.Enqueue(FElements[I]);\r\n Inc(I);\r\n if I = FCapacity then\r\n I := 0;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJclQueue.Clear;\r\nvar\r\n I: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n I := FHead;\r\n while I <> FTail do\r\n begin\r\n FreeObject(FElements[I]);\r\n Inc(I);\r\n if I = FCapacity then\r\n I := 0;\r\n end;\r\n FHead := 0;\r\n FTail := 0;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclQueue.Contains(AObject: TObject): Boolean;\r\nvar\r\n I: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n I := FHead;\r\n while I <> FTail do\r\n begin\r\n if ItemsEqual(FElements[I], AObject) then\r\n begin\r\n Result := True;\r\n Break;\r\n end;\r\n Inc(I);\r\n if I = FCapacity then\r\n I := 0;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclQueue.Dequeue: TObject;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := nil;\r\n if FTail <> FHead then\r\n begin\r\n Result := FElements[FHead];\r\n FElements[FHead] := nil;\r\n Inc(FHead);\r\n if FHead = FCapacity then\r\n FHead := 0;\r\n AutoPack;\r\n end\r\n else\r\n if not FReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclQueue.Empty: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := FTail = FHead;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclQueue.Enqueue(AObject: TObject): Boolean;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if (FTail = (FHead - 1)) or (FTail = (FHead + FCapacity - 1)) then\r\n AutoGrow;\r\n Result := (FTail <> (FHead - 1)) and (FTail <> (FHead + FCapacity - 1));\r\n if Result then\r\n begin\r\n FElements[FTail] := AObject;\r\n Inc(FTail);\r\n if FTail = FCapacity then\r\n FTail := 0;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclQueue.Pack;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n SetCapacity(Size + 1);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclQueue.Peek: TObject;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := nil;\r\n if FTail <> FHead then\r\n Result := FElements[FHead]\r\n else\r\n if not FReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclQueue.SetCapacity(Value: Integer);\r\nvar\r\n NewHead: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Value < 1 then\r\n raise EJclIllegalQueueCapacityError.Create;\r\n if Value <= Size then\r\n raise EJclOutOfBoundsError.Create;\r\n\r\n if FHead > FTail then // looped\r\n begin\r\n NewHead := FHead + Value - FCapacity;\r\n if Value > FCapacity then\r\n // growing\r\n SetLength(FElements, Value);\r\n MoveArray(FElements, FHead, NewHead, FCapacity - FHead);\r\n if FCapacity > Value then\r\n // packing\r\n SetLength(FElements, Value);\r\n FHead := NewHead;\r\n end\r\n else\r\n begin\r\n // unlooped\r\n if Value < FCapacity then\r\n begin\r\n MoveArray(FElements, FHead, 0, FTail - FHead);\r\n Dec(FTail, FHead);\r\n FHead := 0;\r\n end;\r\n SetLength(FElements, Value);\r\n end;\r\n inherited SetCapacity(Value);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclQueue.Size: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FHead > FTail then\r\n Result := FCapacity - FHead + FTail // looped\r\n else\r\n Result := FTail - FHead;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclQueue.CreateEmptyContainer: TJclAbstractContainerBase;\r\nbegin\r\n Result := TJclQueue.Create(Size + 1, False);\r\n AssignPropertiesTo(Result);\r\nend;\r\n\r\n\r\n{$IFDEF SUPPORTS_GENERICS}\r\n//DOM-IGNORE-BEGIN\r\n\r\n//=== { TJclQueue } =======================================================\r\n\r\nconstructor TJclQueue.Create(ACapacity: Integer; AOwnsItems: Boolean);\r\nbegin\r\n inherited Create(AOwnsItems);\r\n FHead := 0;\r\n FTail := 0;\r\n SetCapacity(ACapacity);\r\nend;\r\n\r\ndestructor TJclQueue.Destroy;\r\nbegin\r\n FReadOnly := False;\r\n Clear;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJclQueue.AssignDataTo(Dest: TJclAbstractContainerBase);\r\nvar\r\n ADest: TJclQueue;\r\n I: Integer;\r\nbegin\r\n inherited AssignDataTo(Dest);\r\n if Dest is TJclQueue then\r\n begin\r\n ADest := TJclQueue(Dest);\r\n ADest.Clear;\r\n ADest.SetCapacity(Size + 1);\r\n I := FHead;\r\n while I <> FTail do\r\n begin\r\n ADest.Enqueue(FElements[I]);\r\n Inc(I);\r\n if I = FCapacity then\r\n I := 0;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJclQueue.Clear;\r\nvar\r\n I: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n I := FHead;\r\n while I <> FTail do\r\n begin\r\n FreeItem(FElements[I]);\r\n Inc(I);\r\n if I = FCapacity then\r\n I := 0;\r\n end;\r\n FHead := 0;\r\n FTail := 0;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclQueue.Contains(const AItem: T): Boolean;\r\nvar\r\n I: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n I := FHead;\r\n while I <> FTail do\r\n begin\r\n if ItemsEqual(FElements[I], AItem) then\r\n begin\r\n Result := True;\r\n Break;\r\n end;\r\n Inc(I);\r\n if I = FCapacity then\r\n I := 0;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclQueue.Dequeue: T;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := Default(T);\r\n if FTail <> FHead then\r\n begin\r\n Result := FElements[FHead];\r\n FElements[FHead] := Default(T);\r\n Inc(FHead);\r\n if FHead = FCapacity then\r\n FHead := 0;\r\n AutoPack;\r\n end\r\n else\r\n if not FReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclQueue.Empty: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := FTail = FHead;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclQueue.Enqueue(const AItem: T): Boolean;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if (FTail = (FHead - 1)) or (FTail = (FHead + FCapacity - 1)) then\r\n AutoGrow;\r\n Result := (FTail <> (FHead - 1)) and (FTail <> (FHead + FCapacity - 1));\r\n if Result then\r\n begin\r\n FElements[FTail] := AItem;\r\n Inc(FTail);\r\n if FTail = FCapacity then\r\n FTail := 0;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclQueue.Pack;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n SetCapacity(Size + 1);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclQueue.Peek: T;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := Default(T);\r\n if FTail <> FHead then\r\n Result := FElements[FHead]\r\n else\r\n if not FReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclQueue.SetCapacity(Value: Integer);\r\nvar\r\n NewHead: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Value < 1 then\r\n raise EJclIllegalQueueCapacityError.Create;\r\n if Value <= Size then\r\n raise EJclOutOfBoundsError.Create;\r\n\r\n if FHead > FTail then // looped\r\n begin\r\n NewHead := FHead + Value - FCapacity;\r\n if Value > FCapacity then\r\n // growing\r\n SetLength(FElements, Value);\r\n MoveArray(FElements, FHead, NewHead, FCapacity - FHead);\r\n if FCapacity > Value then\r\n // packing\r\n SetLength(FElements, Value);\r\n FHead := NewHead;\r\n end\r\n else\r\n begin\r\n // unlooped\r\n if Value < FCapacity then\r\n begin\r\n MoveArray(FElements, FHead, 0, FTail - FHead);\r\n Dec(FTail, FHead);\r\n FHead := 0;\r\n end;\r\n SetLength(FElements, Value);\r\n end;\r\n inherited SetCapacity(Value);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclQueue.Size: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FHead > FTail then\r\n Result := FCapacity - FHead + FTail // looped\r\n else\r\n Result := FTail - FHead;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclQueue.MoveArray(var List: TDynArray; FromIndex, ToIndex, Count: SizeInt);\r\nvar\r\n I: SizeInt;\r\nbegin\r\n if FromIndex < ToIndex then\r\n begin\r\n for I := Count - 1 downto 0 do\r\n List[ToIndex + I] := List[FromIndex + I];\r\n\r\n if (ToIndex - FromIndex) < Count then\r\n // overlapped source and target\r\n for I := 0 to ToIndex - FromIndex - 1 do\r\n List[FromIndex + I] := Default(T)\r\n else\r\n // independant\r\n for I := 0 to Count - 1 do\r\n List[FromIndex + I] := Default(T);\r\n end\r\n else\r\n begin\r\n for I := 0 to Count - 1 do\r\n List[ToIndex + I] := List[FromIndex + I];\r\n\r\n if (FromIndex - ToIndex) < Count then\r\n // overlapped source and target\r\n for I := Count - FromIndex + ToIndex to Count - 1 do\r\n List[FromIndex + I] := Default(T)\r\n else\r\n // independant\r\n for I := 0 to Count - 1 do\r\n List[FromIndex + I] := Default(T);\r\n end; \r\nend;\r\n\r\n//=== { TJclQueueE } ======================================================\r\n\r\nconstructor TJclQueueE.Create(const AEqualityComparer: IEqualityComparer;\r\n ACapacity: Integer; AOwnsItems: Boolean);\r\nbegin\r\n inherited Create(ACapacity, AOwnsItems);\r\n FEqualityComparer := AEqualityComparer;\r\nend;\r\n\r\nprocedure TJclQueueE.AssignPropertiesTo(Dest: TJclAbstractContainerBase);\r\nbegin\r\n inherited AssignPropertiesTo(Dest);\r\n if Dest is TJclQueueE then\r\n TJclQueueE(Dest).FEqualityComparer := FEqualityComparer;\r\nend;\r\n\r\nfunction TJclQueueE.CreateEmptyContainer: TJclAbstractContainerBase;\r\nbegin\r\n Result := TJclQueueE.Create(EqualityComparer, Size + 1, False);\r\n AssignPropertiesTo(Result);\r\nend;\r\n\r\nfunction TJclQueueE.ItemsEqual(const A, B: T): Boolean;\r\nbegin\r\n if EqualityComparer <> nil then\r\n Result := EqualityComparer.Equals(A, B)\r\n else\r\n Result := inherited ItemsEqual(A, B);\r\nend;\r\n\r\n//=== { TJclQueueF } ======================================================\r\n\r\nconstructor TJclQueueF.Create(AEqualityCompare: TEqualityCompare;\r\n ACapacity: Integer; AOwnsItems: Boolean);\r\nbegin\r\n inherited Create(ACapacity, AOwnsItems);\r\n SetEqualityCompare(AEqualityCompare);\r\nend;\r\n\r\nfunction TJclQueueF.CreateEmptyContainer: TJclAbstractContainerBase;\r\nbegin\r\n Result := TJclQueueF.Create(EqualityCompare, Size + 1, False);\r\n AssignPropertiesTo(Result);\r\nend;\r\n\r\n//=== { TJclQueueI } ======================================================\r\n\r\nfunction TJclQueueI.CreateEmptyContainer: TJclAbstractContainerBase;\r\nbegin\r\n Result := TJclQueueI.Create(Size + 1, False);\r\n AssignPropertiesTo(Result);\r\nend;\r\n\r\nfunction TJclQueueI.ItemsEqual(const A, B: T): Boolean;\r\nbegin\r\n if Assigned(FEqualityCompare) then\r\n Result := FEqualityCompare(A, B)\r\n else\r\n if Assigned(FCompare) then\r\n Result := FCompare(A, B) = 0\r\n else\r\n Result := A.Equals(B);\r\nend;\r\n\r\n//DOM-IGNORE-END\r\n{$ENDIF SUPPORTS_GENERICS}\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jcl/source/common/JclRTTI.pas", "content": "{**************************************************************************************************}\r\n{ }\r\n{ Project JEDI Code Library (JCL) }\r\n{ }\r\n{ The contents of this file are subject to the Mozilla Public License Version 1.1 (the \"License\"); }\r\n{ you may not use this file except in compliance with the License. You may obtain a copy of the }\r\n{ License at http://www.mozilla.org/MPL/ }\r\n{ }\r\n{ Software distributed under the License is distributed on an \"AS IS\" basis, WITHOUT WARRANTY OF }\r\n{ ANY KIND, either express or implied. See the License for the specific language governing rights }\r\n{ and limitations under the License. }\r\n{ }\r\n{ The Original Code is JclRTTI.pas. }\r\n{ }\r\n{ The Initial Developer of the Original Code is Marcel Bestebroer. }\r\n{ Portions created Marcel Bestebroer are Copyright (C) Marcel Bestebroer. All rights reserved. }\r\n{ }\r\n{ Contributor(s): }\r\n{ Theo Bebekis }\r\n{ Marcel Bestebroer (marcelb) }\r\n{ Robert Marquardt (marquardt) }\r\n{ Robert Rossmair (rrossmair) }\r\n{ Matthias Thoma (mthoma) }\r\n{ Petr Vones (pvones) }\r\n{ }\r\n{**************************************************************************************************}\r\n{ }\r\n{ Various RunTime Type Information routines. Includes retrieving RTTI information for different }\r\n{ types, declaring/generating new types, data conversion to user displayable values and 'is'/'as' }\r\n{ operator hooking. }\r\n{ }\r\n{**************************************************************************************************}\r\n{ }\r\n{ Last modified: $Date:: 2012-03-04 19:39:47 +0100 (dim. 04 mars 2012) $ }\r\n{ Revision: $Rev:: 3759 $ }\r\n{ Author: $Author:: outchy $ }\r\n{ }\r\n{**************************************************************************************************}\r\n\r\nunit JclRTTI;\r\n\r\n{$I jcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n {$IFDEF HAS_UNITSCOPE}\r\n System.Types,\r\n {$IFDEF MSWINDOWS}\r\n Winapi.Windows,\r\n {$ENDIF MSWINDOWS}\r\n System.Classes, System.SysUtils, System.TypInfo,\r\n {$ELSE ~HAS_UNITSCOPE}\r\n Types,\r\n {$IFDEF MSWINDOWS}\r\n Windows,\r\n {$ENDIF MSWINDOWS}\r\n Classes, SysUtils, TypInfo,\r\n {$ENDIF ~HAS_UNITSCOPE}\r\n JclBase;\r\n\r\ntype\r\n // TypeInfo writing\r\n IJclInfoWriter = interface\r\n ['{7DAD522D-46EA-11D5-B0C0-4854E825F345}']\r\n function GetWrap: Integer;\r\n procedure SetWrap(const Value: Integer);\r\n procedure Write(const S: string);\r\n procedure Writeln(const S: string = '');\r\n procedure Indent;\r\n procedure Outdent;\r\n property Wrap: Integer read GetWrap write SetWrap;\r\n end;\r\n\r\n TJclInfoWriter = class(TInterfacedObject, IJclInfoWriter)\r\n private\r\n FCurLine: string;\r\n FIndentLevel: Integer;\r\n FWrap: Integer;\r\n protected\r\n procedure DoWrap;\r\n procedure DoWriteCompleteLines;\r\n procedure PrimWrite(const S: string); virtual; abstract;\r\n\r\n property CurLine: string read FCurLine write FCurLine;\r\n property IndentLevel: Integer read FIndentLevel write FIndentLevel;\r\n public\r\n constructor Create(const AWrap: Integer = 80);\r\n destructor Destroy; override;\r\n { IJclInfoWriter }\r\n function GetWrap: Integer;\r\n procedure SetWrap(const Value: Integer);\r\n procedure Write(const S: string);\r\n procedure Writeln(const S: string = '');\r\n procedure Indent;\r\n procedure Outdent;\r\n property Wrap: Integer read GetWrap write SetWrap;\r\n end;\r\n\r\n TJclInfoStringsWriter = class(TJclInfoWriter)\r\n private\r\n FStrings: TStrings;\r\n protected\r\n procedure PrimWrite(const S: string); override;\r\n public\r\n constructor Create(const AStrings: TStrings; const AWrap: Integer = 80);\r\n\r\n property Strings: TStrings read FStrings;\r\n end;\r\n\r\n // TypeInfo retrieval\r\n IJclBaseInfo = interface\r\n ['{84E57A52-7219-4248-BDC7-4AACBFE2002D}']\r\n procedure WriteTo(const Dest: IJclInfoWriter);\r\n procedure DeclarationTo(const Dest: IJclInfoWriter);\r\n end;\r\n\r\n IJclTypeInfo = interface(IJclBaseInfo)\r\n ['{7DAD5220-46EA-11D5-B0C0-4854E825F345}']\r\n function GetName: string;\r\n function GetTypeData: PTypeData;\r\n function GetTypeInfo: PTypeInfo;\r\n function GetTypeKind: TTypeKind;\r\n\r\n property Name: string read GetName;\r\n property TypeData: PTypeData read GetTypeData;\r\n property TypeInfo: PTypeInfo read GetTypeInfo;\r\n property TypeKind: TTypeKind read GetTypeKind;\r\n end;\r\n\r\n TJclTypeInfo = class(TInterfacedObject, IJclBaseInfo, IJclTypeInfo)\r\n private\r\n FTypeData: PTypeData;\r\n FTypeInfo: PTypeInfo;\r\n public\r\n constructor Create(ATypeInfo: PTypeInfo);\r\n { IJclBaseInfo }\r\n procedure WriteTo(const Dest: IJclInfoWriter); virtual;\r\n procedure DeclarationTo(const Dest: IJclInfoWriter); virtual;\r\n { IJclTypeInfo }\r\n function GetName: string;\r\n function GetTypeData: PTypeData;\r\n function GetTypeInfo: PTypeInfo;\r\n function GetTypeKind: TTypeKind;\r\n property Name: string read GetName;\r\n property TypeData: PTypeData read GetTypeData;\r\n property TypeInfo: PTypeInfo read GetTypeInfo;\r\n property TypeKind: TTypeKind read GetTypeKind;\r\n end;\r\n\r\n // for all values that can be serialized to/deserialized from strings\r\n IJclValueTypeInfo = interface(IJclTypeInfo)\r\n ['{522C6E39-F917-4C92-B085-223BD68C377F}']\r\n function SaveValueToString(AnObj: TObject; const PropName: string): string;\r\n procedure LoadValueFromString(AnObj: TObject; const PropName, Value: string);\r\n end;\r\n\r\n // Ordinal types\r\n IJclOrdinalTypeInfo = interface(IJclValueTypeInfo)\r\n ['{7DAD5221-46EA-11D5-B0C0-4854E825F345}']\r\n function GetOrdinalType: TOrdType;\r\n\r\n property OrdinalType: TOrdType read GetOrdinalType;\r\n end;\r\n\r\n TJclOrdinalTypeInfo = class(TJclTypeInfo, IJclBaseInfo, IJclTypeInfo,\r\n IJclValueTypeInfo, IJclOrdinalTypeInfo)\r\n public\r\n { IJclBaseInfo }\r\n procedure WriteTo(const Dest: IJclInfoWriter); override;\r\n { IJclValueTypeInfo }\r\n function SaveValueToString(AnObj: TObject; const PropName: string): string;\r\n procedure LoadValueFromString(AnObj: TObject; const PropName, Value: string);\r\n { IJclOrdinalTypeInfo }\r\n function GetOrdinalType: TOrdType;\r\n property OrdinalType: TOrdType read GetOrdinalType;\r\n end;\r\n\r\n IJclOrdinalRangeTypeInfo = interface(IJclOrdinalTypeInfo)\r\n ['{7DAD5222-46EA-11D5-B0C0-4854E825F345}']\r\n function GetMinValue: Int64;\r\n function GetMaxValue: Int64;\r\n\r\n property MinValue: Int64 read GetMinValue;\r\n property MaxValue: Int64 read GetMaxValue;\r\n end;\r\n\r\n TJclOrdinalRangeTypeInfo = class(TJclOrdinalTypeInfo, IJclBaseInfo, IJclTypeInfo,\r\n IJclValueTypeInfo, IJclOrdinalTypeInfo, IJclOrdinalRangeTypeInfo)\r\n public\r\n { IJclBaseInfo }\r\n procedure WriteTo(const Dest: IJclInfoWriter); override;\r\n procedure DeclarationTo(const Dest: IJclInfoWriter); override;\r\n { IJclOrdinalRangeTypeInfo }\r\n function GetMinValue: Int64;\r\n function GetMaxValue: Int64;\r\n property MinValue: Int64 read GetMinValue;\r\n property MaxValue: Int64 read GetMaxValue;\r\n end;\r\n\r\n IJclEnumerationTypeInfo = interface(IJclOrdinalRangeTypeInfo)\r\n ['{7DAD5223-46EA-11D5-B0C0-4854E825F345}']\r\n function GetBaseType: IJclEnumerationTypeInfo;\r\n function GetNames(const I: Integer): string;\r\n function GetUnitName: string;\r\n\r\n function IndexOfName(const Name: string): Integer;\r\n\r\n property BaseType: IJclEnumerationTypeInfo read GetBaseType;\r\n property Names[const I: Integer]: string read GetNames; default;\r\n property UnitName: string read GetUnitName;\r\n end;\r\n\r\n TJclEnumerationTypeInfo = class(TJclOrdinalRangeTypeInfo, IJclBaseInfo, IJclTypeInfo, \r\n IJclValueTypeInfo, IJclOrdinalTypeInfo, IJclOrdinalRangeTypeInfo, IJclEnumerationTypeInfo)\r\n public\r\n { IJclBaseInfo }\r\n procedure WriteTo(const Dest: IJclInfoWriter); override;\r\n procedure DeclarationTo(const Dest: IJclInfoWriter); override;\r\n { IJclValueTypeInfo }\r\n function SaveValueToString(AnObj: TObject; const PropName: string): string;\r\n procedure LoadValueFromString(AnObj: TObject; const PropName, Value: string);\r\n { IJclEnumerationTypeInfo }\r\n function GetBaseType: IJclEnumerationTypeInfo;\r\n function GetNames(const I: Integer): string;\r\n function GetUnitName: string;\r\n function IndexOfName(const Name: string): Integer;\r\n property BaseType: IJclEnumerationTypeInfo read GetBaseType;\r\n property Names[const I: Integer]: string read GetNames; default;\r\n end;\r\n\r\n IJclSetTypeInfo = interface(IJclOrdinalTypeInfo)\r\n ['{7DAD5224-46EA-11D5-B0C0-4854E825F345}']\r\n function GetBaseType: IJclOrdinalTypeInfo;\r\n\r\n procedure GetAsList(const Value; const WantRanges: Boolean;\r\n const Strings: TStrings);\r\n procedure SetAsList(out Value; const Strings: TStrings);\r\n\r\n property BaseType: IJclOrdinalTypeInfo read GetBaseType;\r\n end;\r\n\r\n TJclSetTypeInfo = class(TJclOrdinalTypeInfo, IJclBaseInfo, IJclTypeInfo,\r\n IJclValueTypeInfo, IJclOrdinalTypeInfo, IJclSetTypeInfo)\r\n public\r\n { IJclBaseInfo }\r\n procedure WriteTo(const Dest: IJclInfoWriter); override;\r\n procedure DeclarationTo(const Dest: IJclInfoWriter); override;\r\n { IJclValueInfo }\r\n function SaveValueToString(AnObj: TObject; const PropName: string): string;\r\n procedure LoadValueFromString(AnObj: TObject; const PropName, Value: string);\r\n { IJclSetTypeInfo }\r\n function GetBaseType: IJclOrdinalTypeInfo;\r\n procedure GetAsList(const Value; const WantRanges: Boolean;\r\n const Strings: TStrings);\r\n procedure SetAsList(out Value; const Strings: TStrings);\r\n property BaseType: IJclOrdinalTypeInfo read GetBaseType;\r\n end;\r\n\r\n // Float types\r\n IJclFloatTypeInfo = interface(IJclValueTypeInfo)\r\n ['{7DAD5225-46EA-11D5-B0C0-4854E825F345}']\r\n function GetFloatType: TFloatType;\r\n\r\n property FloatType: TFloatType read GetFloatType;\r\n end;\r\n\r\n TJclFloatTypeInfo = class(TJclTypeInfo, IJclBaseInfo, IJclTypeInfo,\r\n IJclValueTypeInfo, IJclFloatTypeInfo)\r\n public\r\n { IJclBaseInfo }\r\n procedure WriteTo(const Dest: IJclInfoWriter); override;\r\n procedure DeclarationTo(const Dest: IJclInfoWriter); override;\r\n { IJclValueInfo }\r\n function SaveValueToString(AnObj: TObject; const PropName: string): string;\r\n procedure LoadValueFromString(AnObj: TObject; const PropName, Value: string);\r\n { IJclFloatTypeInfo }\r\n function GetFloatType: TFloatType;\r\n property FloatType: TFloatType read GetFloatType;\r\n end;\r\n\r\n // Short string types\r\n IJclStringTypeInfo = interface(IJclValueTypeInfo)\r\n ['{7DAD5226-46EA-11D5-B0C0-4854E825F345}']\r\n function GetMaxLength: Integer;\r\n\r\n property MaxLength: Integer read GetMaxLength;\r\n end;\r\n\r\n TJclStringTypeInfo = class(TJclTypeInfo, IJclBaseInfo, IJclTypeInfo,\r\n IJclValueTypeInfo, IJclStringTypeInfo)\r\n public\r\n { IJclBaseInfo }\r\n procedure WriteTo(const Dest: IJclInfoWriter); override;\r\n procedure DeclarationTo(const Dest: IJclInfoWriter); override;\r\n { IJclValueInfo }\r\n function SaveValueToString(AnObj: TObject; const PropName: string): string;\r\n procedure LoadValueFromString(AnObj: TObject; const PropName, Value: string);\r\n { IJclStringTypeInfo }\r\n function GetMaxLength: Integer;\r\n property MaxLength: Integer read GetMaxLength;\r\n end;\r\n\r\n // Class types\r\n TJclPropSpecKind = (pskNone, pskStaticMethod, pskVirtualMethod, pskField,\r\n pskConstant);\r\n\r\n IJclPropInfo = interface\r\n ['{7DAD5227-46EA-11D5-B0C0-4854E825F345}']\r\n function GetPropInfo: PPropInfo;\r\n function GetPropType: IJclTypeInfo;\r\n function GetReader: Pointer;\r\n function GetWriter: Pointer;\r\n function GetStoredProc: Pointer;\r\n function GetIndex: Integer;\r\n function GetDefault: Longint;\r\n function GetNameIndex: Smallint;\r\n function GetName: string;\r\n function GetReaderType: TJclPropSpecKind;\r\n function GetWriterType: TJclPropSpecKind;\r\n function GetStoredType: TJclPropSpecKind;\r\n function GetReaderValue: TJclAddr;\r\n function GetWriterValue: TJclAddr;\r\n function GetStoredValue: TJclAddr;\r\n\r\n function IsStored(const AInstance: TObject): Boolean;\r\n function HasDefault: Boolean;\r\n function HasIndex: Boolean;\r\n\r\n function SaveValueToString(AnObj: TObject): string;\r\n procedure LoadValueFromString(AnObj: TObject; const Value: string);\r\n\r\n property PropInfo: PPropInfo read GetPropInfo;\r\n property PropType: IJclTypeInfo read GetPropType;\r\n property Reader: Pointer read GetReader;\r\n property Writer: Pointer read GetWriter;\r\n property StoredProc: Pointer read GetStoredProc;\r\n property ReaderType: TJclPropSpecKind read GetReaderType;\r\n property WriterType: TJclPropSpecKind read GetWriterType;\r\n property StoredType: TJclPropSpecKind read GetStoredType;\r\n property ReaderValue: TJclAddr read GetReaderValue;\r\n property WriterValue: TJclAddr read GetWriterValue;\r\n property StoredValue: TJclAddr read GetStoredValue;\r\n property Index: Integer read GetIndex;\r\n property Default: Longint read GetDefault;\r\n property NameIndex: Smallint read GetNameIndex;\r\n property Name: string read GetName;\r\n end;\r\n\r\n TJclPropInfo = class(TInterfacedObject, IJclPropInfo)\r\n private\r\n FPropInfo: PPropInfo;\r\n public\r\n constructor Create(const APropInfo: PPropInfo);\r\n { IJclPropInfo }\r\n function GetPropInfo: PPropInfo;\r\n function GetPropType: IJclTypeInfo;\r\n function GetReader: Pointer;\r\n function GetWriter: Pointer;\r\n function GetStoredProc: Pointer;\r\n function GetIndex: Integer;\r\n function GetDefault: Longint;\r\n function GetNameIndex: Smallint;\r\n function GetName: string;\r\n function GetSpecKind(const Value: TJclAddr): TJclPropSpecKind;\r\n function GetSpecValue(const Value: TJclAddr): TJclAddr;\r\n function GetReaderType: TJclPropSpecKind;\r\n function GetWriterType: TJclPropSpecKind;\r\n function GetStoredType: TJclPropSpecKind;\r\n function GetReaderValue: TJclAddr;\r\n function GetWriterValue: TJclAddr;\r\n function GetStoredValue: TJclAddr;\r\n\r\n function IsStored(const AInstance: TObject): Boolean;\r\n function HasDefault: Boolean;\r\n function HasIndex: Boolean;\r\n\r\n function SaveValueToString(AnObj: TObject): string;\r\n procedure LoadValueFromString(AnObj: TObject; const Value: string);\r\n\r\n property PropInfo: PPropInfo read GetPropInfo;\r\n property PropType: IJclTypeInfo read GetPropType;\r\n property Reader: Pointer read GetReader;\r\n property Writer: Pointer read GetWriter;\r\n property StoredProc: Pointer read GetStoredProc;\r\n property ReaderType: TJclPropSpecKind read GetReaderType;\r\n property WriterType: TJclPropSpecKind read GetWriterType;\r\n property StoredType: TJclPropSpecKind read GetStoredType;\r\n property ReaderValue: TJclAddr read GetReaderValue;\r\n property WriterValue: TJclAddr read GetWriterValue;\r\n property StoredValue: TJclAddr read GetStoredValue;\r\n property Index: Integer read GetIndex;\r\n property Default: Longint read GetDefault;\r\n property NameIndex: Smallint read GetNameIndex;\r\n property Name: string read GetName;\r\n end;\r\n\r\n IJclObjPropInfo = interface(IJclPropInfo)\r\n function GetAbsoluteName: string;\r\n function GetInstance: TObject;\r\n function IsStored: Boolean; overload;\r\n\r\n function SaveValueToString: string;\r\n procedure LoadValueFromString(const Value: string);\r\n\r\n property AbsoluteName: string read GetAbsoluteName;\r\n property Instance: TObject read GetInstance;\r\n end;\r\n\r\n IJclObjPropInfoArray = array of IJclObjPropInfo;\r\n\r\n TJclObjPropInfo = class(TJclPropInfo, IJclPropInfo, IJclObjPropInfo)\r\n private\r\n FPrefix: string;\r\n FInstance: TObject;\r\n public\r\n constructor Create(const APropInfo: PPropInfo; const APrefix: string; AInstance: TObject);\r\n { IJclObjPropInfo }\r\n function GetAbsoluteName: string;\r\n function GetInstance: TObject;\r\n function IsStored: Boolean; overload;\r\n function SaveValueToString: string; overload;\r\n procedure LoadValueFromString(const Value: string); overload;\r\n end;\r\n\r\n IJclClassTypeInfo = interface(IJclValueTypeInfo)\r\n ['{7DAD5228-46EA-11D5-B0C0-4854E825F345}']\r\n function GetClassRef: TClass;\r\n function GetParent: IJclClassTypeInfo;\r\n function GetTotalPropertyCount: Integer;\r\n function GetPropertyCount: Integer;\r\n function GetProperties(const PropIdx: Integer): IJclPropInfo;\r\n function GetPropNames(const Name: string): IJclPropInfo;\r\n function GetUnitName: string;\r\n\r\n property ClassRef: TClass read GetClassRef;\r\n property Parent: IJclClassTypeInfo read GetParent;\r\n property TotalPropertyCount: Integer read GetTotalPropertyCount;\r\n property PropertyCount: Integer read GetPropertyCount;\r\n property Properties[const PropIdx: Integer]: IJclPropInfo read GetProperties;\r\n property PropNames[const Name: string]: IJclPropInfo read GetPropNames;\r\n property UnitName: string read GetUnitName;\r\n end;\r\n\r\n TJclClassTypeInfo = class(TJclTypeInfo, IJclBaseInfo, IJclTypeInfo,\r\n IJclValueTypeInfo, IJclClassTypeInfo)\r\n public\r\n { IJclBaseInfo }\r\n procedure WriteTo(const Dest: IJclInfoWriter); override;\r\n procedure DeclarationTo(const Dest: IJclInfoWriter); override;\r\n { IJclValueInfo }\r\n function SaveValueToString(AnObj: TObject; const PropName: string): string;\r\n procedure LoadValueFromString(AnObj: TObject; const PropName, Value: string);\r\n { IJclClassTypeInfo }\r\n function GetClassRef: TClass;\r\n function GetParent: IJclClassTypeInfo;\r\n function GetTotalPropertyCount: Integer;\r\n function GetPropertyCount: Integer;\r\n function GetProperties(const PropIdx: Integer): IJclPropInfo;\r\n function GetPropNames(const Name: string): IJclPropInfo;\r\n function GetUnitName: string;\r\n property ClassRef: TClass read GetClassRef;\r\n property Parent: IJclClassTypeInfo read GetParent;\r\n property TotalPropertyCount: Integer read GetTotalPropertyCount;\r\n property PropertyCount: Integer read GetPropertyCount;\r\n property Properties[const PropIdx: Integer]: IJclPropInfo read GetProperties;\r\n property PropNames[const Name: string]: IJclPropInfo read GetPropNames;\r\n end;\r\n\r\n IJclObjClassTypeInfo = interface(IJclClassTypeInfo)\r\n ['{5BF4383D-7FDD-4494-88CC-849D72B5E142}']\r\n function GetInstance: TObject;\r\n function GetObjProperties(const PropIdx: Integer): IJclObjPropInfo;\r\n function GetObjPropNames(const Name: string): IJclObjPropInfo;\r\n\r\n function SaveValueToString(const PropName: string): string; overload;\r\n procedure LoadValueFromString(const PropName, Value: string); overload;\r\n\r\n property Instance: TObject read GetInstance;\r\n property ObjProperties[const PropIdx: Integer]: IJclObjPropInfo read GetObjProperties;\r\n property ObjPropNames[const Name: string]: IJclObjPropInfo read GetObjPropNames;\r\n end;\r\n\r\n TJclObjClassTypeInfo = class(TJclClassTypeInfo, IJclBaseInfo, IJclTypeInfo,\r\n IJclValueTypeInfo, IJclClassTypeInfo, IJclObjClassTypeInfo)\r\n private\r\n FPrefix: string;\r\n FInstance: TObject;\r\n public\r\n constructor Create(const ATypeInfo: PTypeInfo; const APrefix: string; AInstance: TObject);\r\n { IJclObjClassTypeInfo }\r\n function GetInstance: TObject;\r\n function GetObjProperties(const PropIdx: Integer): IJclObjPropInfo;\r\n function GetObjPropNames(const Name: string): IJclObjPropInfo;\r\n function SaveValueToString(const PropName: string): string; overload;\r\n procedure LoadValueFromString(const PropName, Value: string); overload;\r\n end;\r\n\r\n // Event types\r\n IJclEventParamInfo = interface\r\n ['{7DAD5229-46EA-11D5-B0C0-4854E825F345}']\r\n function GetFlags: TParamFlags;\r\n function GetName: string;\r\n function GetRecSize: Integer;\r\n function GetTypeName: string;\r\n function GetParam: Pointer;\r\n\r\n property Flags: TParamFlags read GetFlags;\r\n property Name: string read GetName;\r\n property RecSize: Integer read GetRecSize;\r\n property TypeName: string read GetTypeName;\r\n property Param: Pointer read GetParam;\r\n end;\r\n\r\n TJclEventParamInfo = class(TInterfacedObject, IJclEventParamInfo)\r\n private\r\n FParam: Pointer;\r\n public\r\n constructor Create(const AParam: Pointer);\r\n { IJclEventParamInfo }\r\n function GetFlags: TParamFlags;\r\n function GetName: string;\r\n function GetRecSize: Integer;\r\n function GetTypeName: string;\r\n function GetParam: Pointer;\r\n property Flags: TParamFlags read GetFlags;\r\n property Name: string read GetName;\r\n property RecSize: Integer read GetRecSize;\r\n property TypeName: string read GetTypeName;\r\n property Param: Pointer read GetParam;\r\n end;\r\n\r\n IJclEventTypeInfo = interface(IJclTypeInfo)\r\n ['{7DAD522A-46EA-11D5-B0C0-4854E825F345}']\r\n function GetMethodKind: TMethodKind;\r\n function GetParameterCount: Integer;\r\n function GetParameters(const ParamIdx: Integer): IJclEventParamInfo;\r\n function GetResultTypeName: string;\r\n\r\n property MethodKind: TMethodKind read GetMethodKind;\r\n property ParameterCount: Integer read GetParameterCount;\r\n property Parameters[const ParamIdx: Integer]: IJclEventParamInfo\r\n read GetParameters;\r\n property ResultTypeName: string read GetResultTypeName;\r\n end;\r\n\r\n TJclEventTypeInfo = class(TJclTypeInfo, IJclBaseInfo, IJclTypeInfo, IJclEventTypeInfo)\r\n public\r\n { IJclBaseInfo }\r\n procedure WriteTo(const Dest: IJclInfoWriter); override;\r\n procedure DeclarationTo(const Dest: IJclInfoWriter); override;\r\n { IJclEventTypeInfo }\r\n function GetMethodKind: TMethodKind;\r\n function GetParameterCount: Integer;\r\n function GetParameters(const ParamIdx: Integer): IJclEventParamInfo;\r\n function GetResultTypeName: string;\r\n property MethodKind: TMethodKind read GetMethodKind;\r\n property ParameterCount: Integer read GetParameterCount;\r\n property Parameters[const ParamIdx: Integer]: IJclEventParamInfo\r\n read GetParameters;\r\n property ResultTypeName: string read GetResultTypeName;\r\n end;\r\n\r\n // Interface types\r\n IJclInterfaceTypeInfo = interface(IJclTypeInfo)\r\n ['{7DAD522B-46EA-11D5-B0C0-4854E825F345}']\r\n function GetParent: IJclInterfaceTypeInfo;\r\n function GetFlags: TIntfFlagsBase;\r\n function GetGUID: TGUID;\r\n function GetPropertyCount: Integer;\r\n function GetUnitName: string;\r\n\r\n property Parent: IJclInterfaceTypeInfo read GetParent;\r\n property Flags: TIntfFlagsBase read GetFlags;\r\n property GUID: TGUID read GetGUID;\r\n property PropertyCount: Integer read GetPropertyCount;\r\n property UnitName: string read GetUnitName;\r\n end;\r\n\r\n TJclInterfaceTypeInfo = class(TJclTypeInfo, IJclBaseInfo, IJclTypeInfo,\r\n IJclInterfaceTypeInfo)\r\n public\r\n { IJclBaseInfo }\r\n procedure WriteTo(const Dest: IJclInfoWriter); override;\r\n procedure DeclarationTo(const Dest: IJclInfoWriter); override;\r\n { IJclInterfaceTypeInfo }\r\n function GetParent: IJclInterfaceTypeInfo;\r\n function GetFlags: TIntfFlagsBase;\r\n function GetGUID: TGUID;\r\n function GetPropertyCount: Integer;\r\n function GetUnitName: string;\r\n property Parent: IJclInterfaceTypeInfo read GetParent;\r\n property Flags: TIntfFlagsBase read GetFlags;\r\n property GUID: TGUID read GetGUID;\r\n property PropertyCount: Integer read GetPropertyCount;\r\n end;\r\n\r\n // Int64 types\r\n IJclInt64TypeInfo = interface(IJclValueTypeInfo)\r\n ['{7DAD522C-46EA-11D5-B0C0-4854E825F345}']\r\n function GetMinValue: Int64;\r\n function GetMaxValue: Int64;\r\n\r\n property MinValue: Int64 read GetMinValue;\r\n property MaxValue: Int64 read GetMaxValue;\r\n end;\r\n\r\n TJclInt64TypeInfo = class(TJclTypeInfo, IJclBaseInfo, IJclTypeInfo,\r\n IJclValueTypeInfo, IJclInt64TypeInfo)\r\n public\r\n { IJclBaseInfo }\r\n procedure WriteTo(const Dest: IJclInfoWriter); override;\r\n procedure DeclarationTo(const Dest: IJclInfoWriter); override;\r\n { IJclValueInfo }\r\n function SaveValueToString(AnObj: TObject; const PropName: string): string;\r\n procedure LoadValueFromString(AnObj: TObject; const PropName, Value: string);\r\n { IJclInt64TypeInfo }\r\n function GetMinValue: Int64;\r\n function GetMaxValue: Int64;\r\n property MinValue: Int64 read GetMinValue;\r\n property MaxValue: Int64 read GetMaxValue;\r\n end;\r\n\r\n // Dynamic array types\r\n IJclDynArrayTypeInfo = interface(IJclTypeInfo)\r\n ['{7DAD522E-46EA-11D5-B0C0-4854E825F345}']\r\n function GetElementSize: Longint;\r\n function GetElementType: IJclTypeInfo;\r\n function GetElementsNeedCleanup: Boolean;\r\n function GetVarType: Integer;\r\n function GetUnitName: string;\r\n\r\n property ElementSize: Longint read GetElementSize;\r\n property ElementType: IJclTypeInfo read GetElementType;\r\n property ElementsNeedCleanup: Boolean read GetElementsNeedCleanup;\r\n property VarType: Integer read GetVarType;\r\n property UnitName: string read GetUnitName;\r\n end;\r\n\r\n TJclDynArrayTypeInfo = class(TJclTypeInfo, IJclBaseInfo, IJclTypeInfo,\r\n IJclDynArrayTypeInfo)\r\n public\r\n { IJclBaseInfo }\r\n procedure WriteTo(const Dest: IJclInfoWriter); override;\r\n procedure DeclarationTo(const Dest: IJclInfoWriter); override;\r\n { IJclDynArrayTypeInfo }\r\n function GetElementSize: Longint;\r\n function GetElementType: IJclTypeInfo;\r\n function GetElementsNeedCleanup: Boolean;\r\n function GetVarType: Integer;\r\n function GetUnitName: string;\r\n property ElementSize: Longint read GetElementSize;\r\n property ElementType: IJclTypeInfo read GetElementType;\r\n property ElementsNeedCleanup: Boolean read GetElementsNeedCleanup;\r\n property VarType: Integer read GetVarType;\r\n end;\r\n\r\n EJclRTTIError = class(EJclError);\r\n\r\nfunction JclTypeInfo(ATypeInfo: PTypeInfo): IJclTypeInfo;\r\n\r\n// Enumeration types\r\nconst\r\n PREFIX_CUT_LOWERCASE = 255;\r\n PREFIX_CUT_EQUAL = 254;\r\n\r\n MaxPrefixCut = 250;\r\n\r\nfunction JclEnumValueToIdent(TypeInfo: PTypeInfo; const Value): string;\r\n\r\nfunction JclGenerateEnumType(const TypeName: ShortString;\r\n const Literals: array of string): PTypeInfo;\r\nfunction JclGenerateEnumTypeBasedOn(const TypeName: ShortString;\r\n BaseType: PTypeInfo; const PrefixCut: Byte): PTypeInfo;\r\nfunction JclGenerateSubRange(BaseType: PTypeInfo; const TypeName: string;\r\n const MinValue, MaxValue: Integer): PTypeInfo;\r\n\r\n\r\n// Integer types\r\nfunction JclStrToTypedInt(Value: string; TypeInfo: PTypeInfo): Integer;\r\nfunction JclTypedIntToStr(Value: Integer; TypeInfo: PTypeInfo): string;\r\n\r\n// Sets\r\nfunction JclSetToList(TypeInfo: PTypeInfo; const Value; const WantBrackets: Boolean; const WantRanges: Boolean;\r\n const Strings: TStrings): string;\r\nfunction JclSetToStr(TypeInfo: PTypeInfo; const Value; const WantBrackets: Boolean = False;\r\n const WantRanges: Boolean = False): string;\r\nprocedure JclStrToSet(TypeInfo: PTypeInfo; var SetVar; const Value: string);\r\nprocedure JclIntToSet(TypeInfo: PTypeInfo; var SetVar; const Value: Integer);\r\nfunction JclSetToInt(TypeInfo: PTypeInfo; const SetVar): Integer;\r\nfunction JclGenerateSetType(BaseType: PTypeInfo; const TypeName: ShortString): PTypeInfo;\r\n\r\n// User generated type info managment\r\nprocedure RemoveTypeInfo(TypeInfo: PTypeInfo);\r\n\r\n// Is/As hooking\r\nfunction JclIsClass(const AnObj: TObject; const AClass: TClass): Boolean;\r\nfunction JclIsClassByName(const AnObj: TObject; const AClass: TClass): Boolean;\r\n\r\n// returns all properties of type string (kind = tkLString or kind = tkUString when Unicode is enabled)\r\nfunction GetStringPropList(TypeInfo: PTypeInfo; out PropList: PPropList): Integer;\r\n\r\n// returns all object properties\r\nfunction GetObjectProperties(AnObj: TObject; Recurse: Boolean = False): IJclObjPropInfoArray;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jcl.svn.sourceforge.net/svnroot/jcl/tags/JCL-2.4-Build4571/jcl/source/common/JclRTTI.pas $';\r\n Revision: '$Revision: 3759 $';\r\n Date: '$Date: 2012-03-04 19:39:47 +0100 (dim. 04 mars 2012) $';\r\n LogPath: 'JCL\\source\\common';\r\n Extra: '';\r\n Data: nil\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n {$IFDEF HAS_UNITSCOPE}\r\n System.SysConst,\r\n {$ELSE ~HAS_UNITSCOPE}\r\n SysConst,\r\n {$ENDIF ~HAS_UNITSCOPE}\r\n JclLogic, JclResources, JclStrings, JclSysUtils;\r\n\r\n//=== { TJclInfoWriter } =====================================================\r\n\r\nconstructor TJclInfoWriter.Create(const AWrap: Integer);\r\nbegin\r\n inherited Create;\r\n Wrap := AWrap;\r\nend;\r\n\r\ndestructor TJclInfoWriter.Destroy;\r\nbegin\r\n if CurLine <> '' then\r\n Writeln('');\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJclInfoWriter.GetWrap: Integer;\r\nbegin\r\n Result := FWrap;\r\nend;\r\n\r\nprocedure TJclInfoWriter.SetWrap(const Value: Integer);\r\nbegin\r\n FWrap := Value;\r\nend;\r\n\r\nprocedure TJclInfoWriter.DoWrap;\r\nconst\r\n WrapChars : TSetOfAnsiChar = [#0..' ', '-'];\r\nvar\r\n TmpLines: TStringList;\r\n I: Integer;\r\n TmpLines2: TStringList;\r\n EndedInCRLF: Boolean;\r\n LineBreakLength: Integer;\r\nbegin\r\n LineBreakLength := Length(NativeLineBreak);\r\n EndedInCRLF := Copy(CurLine, Length(CurLine) - LineBreakLength + 1, LineBreakLength) = NativeLineBreak;\r\n TmpLines := TStringList.Create;\r\n try\r\n TmpLines.Text := CurLine;\r\n TmpLines2 := TStringList.Create;\r\n try\r\n I := TmpLines.Count-1;\r\n if not EndedInCRLF then\r\n Dec(I);\r\n while I >= 0 do\r\n begin\r\n TmpLines[I] := StringOfChar(' ', 2 * IndentLevel) + TmpLines[I];\r\n if (Wrap > 0) and (Length(TmpLines[I]) > Wrap) then\r\n begin\r\n TmpLines2.Text := WrapText(\r\n TmpLines[I],\r\n NativeLineBreak + StringOfChar(' ', 2 * (IndentLevel+1)),\r\n WrapChars,\r\n Wrap);\r\n TmpLines.Delete(I);\r\n TmpLines.Insert(I, Copy(TmpLines2.Text, 1,\r\n Length(TmpLines2.Text) - 2));\r\n end;\r\n Dec(I);\r\n end;\r\n CurLine := TmpLines.Text;\r\n if not EndedInCRLF then\r\n Delete(FCurLine, Length(FCurLine) - LineBreakLength + 1, LineBreakLength);\r\n finally\r\n TmpLines2.Free;\r\n end;\r\n finally\r\n TmpLines.Free;\r\n end;\r\nend;\r\n\r\nprocedure TJclInfoWriter.DoWriteCompleteLines;\r\nvar\r\n CRLFPos: Integer;\r\nbegin\r\n CRLFPos := StrLastPos(NativeLineBreak, CurLine);\r\n if CRLFPos > 0 then\r\n begin\r\n PrimWrite(Copy(CurLine, 1, CRLFPos-1));\r\n Delete(FCurLine, 1, CRLFPos+1);\r\n end;\r\nend;\r\n\r\nprocedure TJclInfoWriter.Indent;\r\nbegin\r\n IndentLevel := IndentLevel + 1;\r\nend;\r\n\r\nprocedure TJclInfoWriter.Outdent;\r\nbegin\r\n IndentLevel := IndentLevel - 1;\r\nend;\r\n\r\nprocedure TJclInfoWriter.Write(const S: string);\r\nbegin\r\n CurLine := CurLine + S;\r\n DoWrap;\r\n DoWriteCompleteLines;\r\nend;\r\n\r\nprocedure TJclInfoWriter.Writeln(const S: string);\r\nbegin\r\n Write(S + NativeLineBreak);\r\nend;\r\n\r\n//=== { TJclInfoStringsWriter } ==============================================\r\n\r\nconstructor TJclInfoStringsWriter.Create(const AStrings: TStrings;\r\n const AWrap: Integer);\r\nbegin\r\n inherited Create(AWrap);\r\n FStrings := AStrings;\r\nend;\r\n\r\nprocedure TJclInfoStringsWriter.PrimWrite(const S: string);\r\nbegin\r\n Strings.Add(S);\r\nend;\r\n\r\n//=== { TJclTypeInfo } =======================================================\r\n\r\nconstructor TJclTypeInfo.Create(ATypeInfo: PTypeInfo);\r\nbegin\r\n inherited Create;\r\n FTypeInfo := ATypeInfo;\r\n FTypeData := {$IFDEF HAS_UNITSCOPE}System.{$ENDIF}TypInfo.GetTypeData(ATypeInfo);\r\nend;\r\n\r\nfunction TJclTypeInfo.GetName: string;\r\nbegin\r\n Result := string(TypeInfo.Name);\r\nend;\r\n\r\nfunction TJclTypeInfo.GetTypeData: PTypeData;\r\nbegin\r\n Result := FTypeData;\r\nend;\r\n\r\nfunction TJclTypeInfo.GetTypeInfo: PTypeInfo;\r\nbegin\r\n Result := FTypeInfo;\r\nend;\r\n\r\nfunction TJclTypeInfo.GetTypeKind: TTypeKind;\r\nbegin\r\n Result := TypeInfo.Kind;\r\nend;\r\n\r\nprocedure TJclTypeInfo.WriteTo(const Dest: IJclInfoWriter);\r\nbegin\r\n Dest.Writeln(LoadResString(@RsRTTIName) + Name);\r\n Dest.Writeln(LoadResString(@RsRTTITypeKind) + JclEnumValueToIdent(System.TypeInfo(TTypeKind),\r\n TypeInfo.Kind));\r\n Dest.Writeln(Format(LoadResString(@RsRTTITypeInfoAt), [TypeInfo]));\r\nend;\r\n\r\nprocedure TJclTypeInfo.DeclarationTo(const Dest: IJclInfoWriter);\r\nbegin\r\n Dest.Write(Format(LoadResString(@RsDeclarationFormat), [Name]));\r\nend;\r\n\r\n//=== { TJclOrdinalTypeInfo } ================================================\r\n\r\nfunction TJclOrdinalTypeInfo.GetOrdinalType: TOrdType;\r\nbegin\r\n Result := TypeData.OrdType;\r\nend;\r\n\r\nprocedure TJclOrdinalTypeInfo.LoadValueFromString(AnObj: TObject;\r\n const PropName, Value: string);\r\nbegin\r\n SetOrdProp(AnObj, PropName, StrToInt(Value));\r\nend;\r\n\r\nprocedure TJclOrdinalTypeInfo.WriteTo(const Dest: IJclInfoWriter);\r\nbegin\r\n inherited WriteTo(Dest);\r\n Dest.Writeln(LoadResString(@RsRTTIOrdinalType) +\r\n JclEnumValueToIdent(System.TypeInfo(TOrdType), TypeData.OrdType));\r\nend;\r\n\r\nfunction TJclOrdinalTypeInfo.SaveValueToString(AnObj: TObject;\r\n const PropName: string): string;\r\nbegin\r\n Result := IntToStr(GetOrdProp(AnObj, PropName));\r\nend;\r\n\r\n//=== { TJclOrdinalRangeTypeInfo } ===========================================\r\n\r\nfunction TJclOrdinalRangeTypeInfo.GetMinValue: Int64;\r\nbegin\r\n if OrdinalType = otULong then\r\n Result := Longword(TypeData.MinValue)\r\n else\r\n Result := TypeData.MinValue;\r\nend;\r\n\r\nfunction TJclOrdinalRangeTypeInfo.GetMaxValue: Int64;\r\nbegin\r\n if OrdinalType = otULong then\r\n Result := Longword(TypeData.MaxValue)\r\n else\r\n Result := TypeData.MaxValue;\r\nend;\r\n\r\nprocedure TJclOrdinalRangeTypeInfo.WriteTo(const Dest: IJclInfoWriter);\r\nbegin\r\n inherited WriteTo(Dest);\r\n Dest.Writeln(LoadResString(@RsRTTIMinValue) + IntToStr(MinValue));\r\n Dest.Writeln(LoadResString(@RsRTTIMaxValue) + IntToStr(MaxValue));\r\nend;\r\n\r\nprocedure TJclOrdinalRangeTypeInfo.DeclarationTo(const Dest: IJclInfoWriter);\r\nconst\r\n cRange = '..';\r\nbegin\r\n Dest.Write(Name + ' = ');\r\n if TypeInfo.Kind in [tkChar, tkWChar] then\r\n begin\r\n if (MinValue < Ord(' ')) or (MinValue > Ord('~')) then\r\n Dest.Write('#' + IntToStr(MinValue) + cRange)\r\n else\r\n Dest.Write('''' + Chr(Byte(MinValue)) + '''' + cRange);\r\n if (MaxValue < Ord(' ')) or (MaxValue > Ord('~')) then\r\n Dest.Write('#' + IntToStr(MaxValue))\r\n else\r\n Dest.Write('''' + Chr(Byte(MaxValue)) + '''');\r\n end\r\n else\r\n Dest.Write(IntToStr(MinValue) + '..' + IntToStr(MaxValue));\r\n Dest.Writeln('; // ' + JclEnumValueToIdent(System.TypeInfo(TOrdType), TypeData.OrdType));\r\nend;\r\n\r\n//=== { TJclEnumerationTypeInfo } ============================================\r\n\r\nfunction TJclEnumerationTypeInfo.GetBaseType: IJclEnumerationTypeInfo;\r\nbegin\r\n if TypeData.BaseType{$IFDEF BORLAND}^{$ENDIF} = TypeInfo then\r\n Result := Self\r\n else\r\n Result := TJclEnumerationTypeInfo.Create(TypeData.BaseType{$IFDEF BORLAND}^{$ENDIF});\r\nend;\r\n\r\nfunction TJclEnumerationTypeInfo.GetNames(const I: Integer): string;\r\nvar\r\n Base: IJclEnumerationTypeInfo;\r\n Idx: Integer;\r\n P: ^ShortString;\r\nbegin\r\n Base := BaseType;\r\n Idx := I;\r\n P := @Base.TypeData.NameList;\r\n while Idx <> 0 do\r\n begin\r\n Inc(TJclAddr(P), Length(P^) + 1);\r\n Dec(Idx);\r\n end;\r\n Result := string(P^);\r\nend;\r\n\r\nfunction TJclEnumerationTypeInfo.GetUnitName: string;\r\nvar\r\n I: Integer;\r\n P: ^ShortString;\r\nbegin\r\n if BaseType.TypeInfo = TypeInfo then\r\n begin\r\n I := MaxValue - MinValue;\r\n P := @TypeData.NameList;\r\n while I >= 0 do\r\n begin\r\n Inc(TJclAddr(P), Length(P^) + 1);\r\n Dec(I);\r\n end;\r\n Result := string(P^);\r\n end\r\n else\r\n Result := string(TypeData.NameList);\r\nend;\r\n\r\nfunction TJclEnumerationTypeInfo.IndexOfName(const Name: string): Integer;\r\nbegin\r\n Result := MaxValue;\r\n while (Result >= MinValue) and\r\n not AnsiSameText(Name, Names[Result]) do\r\n Dec(Result);\r\n if Result < MinValue then\r\n Result := -1;\r\nend;\r\n\r\nprocedure TJclEnumerationTypeInfo.LoadValueFromString(AnObj: TObject;\r\n const PropName, Value: string);\r\nbegin\r\n SetEnumProp(AnObj, PropName, Value);\r\nend;\r\n\r\nprocedure TJclEnumerationTypeInfo.WriteTo(const Dest: IJclInfoWriter);\r\nvar\r\n Idx: Integer;\r\n Prefix: string;\r\nbegin\r\n inherited WriteTo(Dest);\r\n Dest.Writeln(LoadResString(@RsRTTIUnitName) + GetUnitName);\r\n Dest.Write(LoadResString(@RsRTTINameList));\r\n Prefix := '(';\r\n for Idx := MinValue to MaxValue do\r\n begin\r\n Dest.Write(Prefix + Names[Idx]);\r\n Prefix := ', ';\r\n end;\r\n Dest.Writeln(')');\r\nend;\r\n\r\nfunction TJclEnumerationTypeInfo.SaveValueToString(AnObj: TObject;\r\n const PropName: string): string;\r\nbegin\r\n Result := GetEnumProp(AnObj, PropName);\r\nend;\r\n\r\nprocedure TJclEnumerationTypeInfo.DeclarationTo(const Dest: IJclInfoWriter);\r\nvar\r\n Prefix: string;\r\n I: Integer;\r\nbegin\r\n if Name[1] <> '.' then\r\n Dest.Write(Name + ' = ');\r\n if BaseType.TypeInfo = TypeInfo then\r\n begin\r\n Dest.Write('(');\r\n Prefix := '';\r\n for I := MinValue to MaxValue do\r\n begin\r\n Dest.Write(Prefix + Names[I]);\r\n Prefix := ', ';\r\n end;\r\n Dest.Write(')');\r\n end\r\n else\r\n Dest.Write(Names[MinValue] + ' .. ' + Names[MaxValue]);\r\n if Name[1] <> '.' then\r\n begin\r\n Dest.Write('; // ' + JclEnumValueToIdent(System.TypeInfo(TOrdType), TypeData.OrdType));\r\n Dest.Writeln('');\r\n end;\r\nend;\r\n\r\n//=== { TJclSetTypeInfo } ====================================================\r\n\r\nfunction TJclSetTypeInfo.GetBaseType: IJclOrdinalTypeInfo;\r\nbegin\r\n Result := JclTypeInfo(TypeData.CompType{$IFDEF BORLAND}^{$ENDIF}) as IJclOrdinalTypeInfo;\r\nend;\r\n\r\nprocedure TJclSetTypeInfo.LoadValueFromString(AnObj: TObject; const PropName,\r\n Value: string);\r\nbegin\r\n SetSetProp(AnObj, PropName, Value);\r\nend;\r\n\r\nprocedure TJclSetTypeInfo.GetAsList(const Value; const WantRanges: Boolean;\r\n const Strings: TStrings);\r\nvar\r\n BaseInfo: IJclOrdinalRangeTypeInfo;\r\n FirstBit: Byte;\r\n LastBit: Byte;\r\n Bit: Byte;\r\n StartBit: Integer;\r\n\r\n procedure AddRange;\r\n var\r\n FirstOrdNum: Int64;\r\n LastOrdNum: Int64;\r\n OrdNum: Int64;\r\n begin\r\n FirstOrdNum := (StartBit - FirstBit) + BaseInfo.MinValue;\r\n LastOrdNum := (Bit - 1 - FirstBit) + BaseInfo.MinValue;\r\n if WantRanges and (LastOrdNum <> FirstOrdNum) then\r\n begin\r\n if BaseInfo.TypeKind = tkEnumeration then\r\n Strings.Add((BaseInfo as IJclEnumerationTypeInfo).Names[FirstOrdNum] +\r\n ' .. ' + (BaseInfo as IJclEnumerationTypeInfo).Names[LastOrdNum])\r\n else\r\n Strings.Add(IntToStr(FirstOrdNum) + ' .. ' + IntToStr(LastOrdNum));\r\n end\r\n else\r\n begin\r\n OrdNum := FirstOrdNum;\r\n while OrdNum <= LastOrdNum do\r\n begin\r\n if BaseInfo.TypeKind = tkEnumeration then\r\n Strings.Add((BaseInfo as IJclEnumerationTypeInfo).Names[OrdNum])\r\n else\r\n Strings.Add(IntToStr(OrdNum));\r\n Inc(OrdNum);\r\n end;\r\n end;\r\n end;\r\n\r\nbegin\r\n BaseInfo := BaseType as IJclOrdinalRangeTypeInfo;\r\n FirstBit := BaseInfo.MinValue mod 8;\r\n LastBit := BaseInfo.MaxValue - (BaseInfo.MinValue - FirstBit);\r\n Bit := FirstBit;\r\n StartBit := -1;\r\n Strings.BeginUpdate;\r\n try\r\n while Bit <= LastBit do\r\n begin\r\n if TestBitBuffer(Value, Bit) then\r\n begin\r\n if StartBit = -1 then\r\n StartBit := Bit;\r\n end\r\n else\r\n begin\r\n if StartBit <> -1 then\r\n begin\r\n AddRange;\r\n StartBit := -1;\r\n end;\r\n end;\r\n Inc(Bit);\r\n end;\r\n if StartBit <> -1 then\r\n AddRange;\r\n finally\r\n Strings.EndUpdate;\r\n end;\r\nend;\r\n\r\nprocedure TJclSetTypeInfo.SetAsList(out Value; const Strings: TStrings);\r\nvar\r\n BaseInfo: IJclOrdinalRangeTypeInfo;\r\n FirstBit: Integer;\r\n I: Integer;\r\n FirstIdent: string;\r\n LastIdent: string;\r\n RangePos: Integer;\r\n FirstOrd: Int64;\r\n LastOrd: Int64;\r\n CurOrd: Integer;\r\n\r\n procedure ClearValue;\r\n var\r\n LastBit: Integer;\r\n ByteCount: Integer;\r\n begin\r\n LastBit := BaseInfo.MaxValue - BaseInfo.MinValue + 1 + FirstBit;\r\n ByteCount := (LastBit - FirstBit) div 8;\r\n if LastBit mod 8 <> 0 then\r\n Inc(ByteCount);\r\n ResetMemory(Value, ByteCount);\r\n end;\r\n\r\nbegin\r\n BaseInfo := BaseType as IJclOrdinalRangeTypeInfo;\r\n FirstBit := BaseInfo.MinValue mod 8;\r\n ClearValue;\r\n Strings.BeginUpdate;\r\n try\r\n for I := 0 to Strings.Count - 1 do\r\n begin\r\n if Trim(Strings[I]) <> '' then\r\n begin\r\n FirstIdent := Trim(Strings[I]);\r\n RangePos := Pos('..', FirstIdent);\r\n if RangePos > 0 then\r\n begin\r\n LastIdent := Trim(StrRestOf(FirstIdent, RangePos + 2));\r\n FirstIdent := Trim(Copy(FirstIdent, 1, RangePos - 1));\r\n end\r\n else\r\n LastIdent := FirstIdent;\r\n if BaseInfo.TypeKind = tkEnumeration then\r\n begin\r\n FirstOrd := (BaseInfo as IJclEnumerationTypeInfo).IndexOfName(FirstIdent);\r\n LastOrd := (BaseInfo as IJclEnumerationTypeInfo).IndexOfName(LastIdent);\r\n if FirstOrd = -1 then\r\n raise EJclRTTIError.CreateResFmt(@RsRTTIUnknownIdentifier, [FirstIdent]);\r\n if LastOrd = -1 then\r\n raise EJclRTTIError.CreateResFmt(@RsRTTIUnknownIdentifier, [LastIdent]);\r\n end\r\n else\r\n begin\r\n FirstOrd := StrToInt(FirstIdent);\r\n LastOrd := StrToInt(LastIdent);\r\n end;\r\n Dec(FirstOrd, BaseInfo.MinValue);\r\n Dec(LastOrd, BaseInfo.MinValue);\r\n for CurOrd := FirstOrd to LastOrd do\r\n SetBitBuffer(Value, CurOrd + FirstBit);\r\n end;\r\n end;\r\n finally\r\n Strings.EndUpdate;\r\n end;\r\nend;\r\n\r\nprocedure TJclSetTypeInfo.WriteTo(const Dest: IJclInfoWriter);\r\nbegin\r\n inherited WriteTo(Dest);\r\n Dest.Writeln(LoadResString(@RsRTTIBasedOn));\r\n Dest.Indent;\r\n try\r\n BaseType.WriteTo(Dest);\r\n finally\r\n Dest.Outdent;\r\n end;\r\nend;\r\n\r\nfunction TJclSetTypeInfo.SaveValueToString(AnObj: TObject;\r\n const PropName: string): string;\r\nbegin\r\n Result := GetSetProp(AnObj, PropName);\r\nend;\r\n\r\nprocedure TJclSetTypeInfo.DeclarationTo(const Dest: IJclInfoWriter);\r\nvar\r\n Base: IJclOrdinalTypeInfo;\r\n BaseEnum: IJclEnumerationTypeInfo;\r\nbegin\r\n if Name[1] <> '.' then\r\n Dest.Write(Name + ' = set of ');\r\n Base := BaseType;\r\n\r\n if Base.Name[1] = '.' then\r\n begin\r\n if Base.QueryInterface(IJclEnumerationTypeInfo, BaseEnum) = S_OK then\r\n BaseEnum.DeclarationTo(Dest)\r\n else\r\n Dest.Write(LoadResString(@RsRTTITypeError));\r\n end\r\n else\r\n Dest.Write(Base.Name);\r\n if Name[1] <> '.' then\r\n begin\r\n Dest.Write('; // ' + JclEnumValueToIdent(System.TypeInfo(TOrdType), TypeData.OrdType));\r\n Dest.Writeln('');\r\n end;\r\nend;\r\n\r\n//=== { TJclFloatTypeInfo } ==================================================\r\n\r\nfunction TJclFloatTypeInfo.GetFloatType: TFloatType;\r\nbegin\r\n Result := TypeData.FloatType;\r\nend;\r\n\r\nprocedure TJclFloatTypeInfo.LoadValueFromString(AnObj: TObject; const PropName,\r\n Value: string);\r\nbegin\r\n SetFloatProp(AnObj, PropName, StrToFloat(Value));\r\nend;\r\n\r\nprocedure TJclFloatTypeInfo.WriteTo(const Dest: IJclInfoWriter);\r\nbegin\r\n inherited WriteTo(Dest);\r\n Dest.Writeln(LoadResString(@RsRTTIFloatType) +\r\n JclEnumValueToIdent(System.TypeInfo(TFloatType), TypeData.FloatType));\r\nend;\r\n\r\nfunction TJclFloatTypeInfo.SaveValueToString(AnObj: TObject;\r\n const PropName: string): string;\r\nbegin\r\n Result := FloatToStr(GetFloatProp(AnObj, PropName));\r\nend;\r\n\r\nprocedure TJclFloatTypeInfo.DeclarationTo(const Dest: IJclInfoWriter);\r\nvar\r\n S: string;\r\n FT: TFloatType;\r\nbegin\r\n FT := FloatType;\r\n S := StrRestOf(JclEnumValueToIdent(System.TypeInfo(TFloatType), FT), 3);\r\n Dest.Writeln(Name + ' = type ' + S + ';');\r\nend;\r\n\r\n//=== { TJclStringTypeInfo } =================================================\r\n\r\nfunction TJclStringTypeInfo.GetMaxLength: Integer;\r\nbegin\r\n if FTypeInfo^.Kind = tkString then\r\n Result := TypeData.MaxLength\r\n else\r\n Result := 0;\r\nend;\r\n\r\nprocedure TJclStringTypeInfo.LoadValueFromString(AnObj: TObject; const PropName,\r\n Value: string);\r\nbegin\r\n SetStrProp(AnObj, PropName, Value);\r\nend;\r\n\r\nprocedure TJclStringTypeInfo.WriteTo(const Dest: IJclInfoWriter);\r\nbegin\r\n inherited WriteTo(Dest);\r\n if FTypeInfo^.Kind = tkString then\r\n Dest.Writeln(LoadResString(@RsRTTIMaxLen) + IntToStr(MaxLength));\r\nend;\r\n\r\nfunction TJclStringTypeInfo.SaveValueToString(AnObj: TObject;\r\n const PropName: string): string;\r\nbegin\r\n Result := GetStrProp(AnObj, PropName);\r\nend;\r\n\r\nprocedure TJclStringTypeInfo.DeclarationTo(const Dest: IJclInfoWriter);\r\nbegin\r\n if Name[1] <> '.' then\r\n Dest.Write(Name + ' = ');\r\n\r\n {$IFDEF SUPPORTS_UNICODE_STRING}\r\n if FTypeInfo^.Kind = tkUString then\r\n Dest.Write('UnicodeString')\r\n else\r\n {$ENDIF SUPPORTS_UNICODE_STRING}\r\n if FTypeInfo^.Kind = tkLString then\r\n Dest.Write('AnsiString')\r\n else\r\n if FTypeInfo^.Kind = tkWString then\r\n Dest.Write('WideString')\r\n else\r\n Dest.Write('string[' + IntToStr(MaxLength) + ']');\r\n\r\n if Name[1] <> '.' then\r\n Dest.Writeln(';');\r\nend;\r\n\r\n//=== { TJclPropInfo } =======================================================\r\n\r\nconstructor TJclPropInfo.Create(const APropInfo: PPropInfo);\r\nbegin\r\n inherited Create;\r\n FPropInfo := APropInfo;\r\nend;\r\n\r\nfunction TJclPropInfo.GetPropInfo: PPropInfo;\r\nbegin\r\n Result := FPropInfo;\r\nend;\r\n\r\nfunction TJclPropInfo.GetPropType: IJclTypeInfo;\r\nbegin\r\n Result := JclTypeInfo(PropInfo.PropType{$IFDEF BORLAND}^{$ENDIF});\r\nend;\r\n\r\nfunction TJclPropInfo.GetReader: Pointer;\r\nbegin\r\n Result := PropInfo.GetProc;\r\nend;\r\n\r\nfunction TJclPropInfo.GetWriter: Pointer;\r\nbegin\r\n Result := PropInfo.SetProc;\r\nend;\r\n\r\nfunction TJclPropInfo.GetStoredProc: Pointer;\r\nbegin\r\n Result := PropInfo.StoredProc;\r\nend;\r\n\r\nfunction TJclPropInfo.GetIndex: Integer;\r\nbegin\r\n Result := PropInfo.Index;\r\nend;\r\n\r\nfunction TJclPropInfo.GetDefault: Longint;\r\nbegin\r\n Result := PropInfo.Default;\r\nend;\r\n\r\nfunction TJclPropInfo.GetNameIndex: Smallint;\r\nbegin\r\n Result := PropInfo.NameIndex;\r\nend;\r\n\r\nfunction TJclPropInfo.GetName: string;\r\nbegin\r\n Result := string(PropInfo.Name);\r\nend;\r\n\r\nfunction TJclPropInfo.GetSpecKind(const Value: TJclAddr): TJclPropSpecKind;\r\nvar\r\n P: Integer;\r\nbegin\r\n {$IFDEF CPU32}\r\n P := Value shr 24;\r\n {$ENDIF CPU32}\r\n {$IFDEF CPU64}\r\n P := Value shr 56;\r\n {$ENDIF CPU64}\r\n case P of\r\n $00:\r\n if Value < 2 then\r\n Result := pskConstant\r\n else\r\n Result := pskStaticMethod;\r\n $FE:\r\n Result := pskVirtualMethod;\r\n $FF:\r\n Result := pskField;\r\n else\r\n Result := pskStaticMethod;\r\n end;\r\nend;\r\n\r\nfunction TJclPropInfo.GetSpecValue(const Value: TJclAddr): TJclAddr;\r\nbegin\r\n case GetSpecKind(Value) of\r\n pskStaticMethod, pskConstant:\r\n Result := Value;\r\n pskVirtualMethod:\r\n {$IFDEF CPU32}\r\n Result := Value and $0000FFFF;\r\n {$ENDIF CPU32}\r\n {$IFDEF CPU64}\r\n Result := Value and $0000FFFFFFFFFFFF;\r\n {$ENDIF CPU64}\r\n pskField:\r\n {$IFDEF CPU32}\r\n Result := Value and $00FFFFFF;\r\n {$ENDIF CPU32}\r\n {$IFDEF CPU64}\r\n Result := Value and $00FFFFFFFFFFFFFF;\r\n {$ENDIF CPU64}\r\n else\r\n Result := 0;\r\n end;\r\nend;\r\n\r\nfunction TJclPropInfo.GetReaderType: TJclPropSpecKind;\r\nbegin\r\n Result := GetSpecKind(TJclAddr(Reader));\r\nend;\r\n\r\nfunction TJclPropInfo.GetWriterType: TJclPropSpecKind;\r\nbegin\r\n Result := GetSpecKind(TJclAddr(Writer));\r\nend;\r\n\r\nfunction TJclPropInfo.GetStoredType: TJclPropSpecKind;\r\nbegin\r\n Result := GetSpecKind(TJclAddr(StoredProc));\r\nend;\r\n\r\nfunction TJclPropInfo.GetReaderValue: TJclAddr;\r\nbegin\r\n Result := GetSpecValue(TJclAddr(Reader));\r\nend;\r\n\r\nfunction TJclPropInfo.GetWriterValue: TJclAddr;\r\nbegin\r\n Result := GetSpecValue(TJclAddr(Writer));\r\nend;\r\n\r\nfunction TJclPropInfo.GetStoredValue: TJclAddr;\r\nbegin\r\n Result := GetSpecValue(TJclAddr(StoredProc));\r\nend;\r\n\r\nfunction TJclPropInfo.IsStored(const AInstance: TObject): Boolean;\r\nbegin\r\n Result := IsStoredProp(AInstance, FPropInfo);\r\nend;\r\n\r\nprocedure TJclPropInfo.LoadValueFromString(AnObj: TObject; const Value: string);\r\nvar\r\n APropType: IJclTypeInfo;\r\n AValueInfo: IJclValueTypeInfo;\r\nbegin\r\n APropType := PropType;\r\n if Supports(APropType, IJclValueTypeInfo, AValueInfo) then\r\n AValueInfo.LoadValueFromString(AnObj, Name, Value)\r\n else\r\n raise EJclRTTIError.CreateResFmt(@RsRTTINoStringValue, [Name, APropType.Name]);\r\nend;\r\n\r\nfunction TJclPropInfo.SaveValueToString(AnObj: TObject): string;\r\nvar\r\n APropType: IJclTypeInfo;\r\n AValueInfo: IJclValueTypeInfo;\r\nbegin\r\n APropType := PropType;\r\n if Supports(APropType, IJclValueTypeInfo, AValueInfo) then\r\n Result := AValueInfo.SaveValueToString(AnObj, Name)\r\n else\r\n raise EJclRTTIError.CreateResFmt(@RsRTTINoStringValue, [Name, APropType.Name]);\r\nend;\r\n\r\nfunction TJclPropInfo.HasDefault: Boolean;\r\nbegin\r\n Result := Longword(Default) <> $80000000;\r\nend;\r\n\r\nfunction TJclPropInfo.HasIndex: Boolean;\r\nbegin\r\n Result := Longword(Index) <> $80000000;\r\nend;\r\n\r\n//=== { TJclObjPropInfo } ====================================================\r\n\r\nconstructor TJclObjPropInfo.Create(const APropInfo: PPropInfo;\r\n const APrefix: string; AInstance: TObject);\r\nbegin\r\n inherited Create(APropInfo);\r\n FPrefix := APrefix;\r\n FInstance := AInstance;\r\nend;\r\n\r\nfunction TJclObjPropInfo.GetAbsoluteName: string;\r\nbegin\r\n if FPrefix <> '' then\r\n Result := FPrefix + '.' + Name\r\n else\r\n Result := Name;\r\nend;\r\n\r\nfunction TJclObjPropInfo.GetInstance: TObject;\r\nbegin\r\n Result := FInstance;\r\nend;\r\n\r\nfunction TJclObjPropInfo.IsStored: Boolean;\r\nbegin\r\n Result := IsStoredProp(FInstance, Name);\r\nend;\r\n\r\nprocedure TJclObjPropInfo.LoadValueFromString(const Value: string);\r\nbegin\r\n LoadValueFromString(FInstance, Value);\r\nend;\r\n\r\nfunction TJclObjPropInfo.SaveValueToString: string;\r\nbegin\r\n Result := SaveValueToString(FInstance);\r\nend;\r\n\r\n//=== { TJclClassTypeInfo } ==================================================\r\n\r\nfunction TJclClassTypeInfo.GetClassRef: TClass;\r\nbegin\r\n Result := TypeData.ClassType;\r\nend;\r\n\r\nfunction TJclClassTypeInfo.GetParent: IJclClassTypeInfo;\r\nbegin\r\n if (TypeData.ParentInfo <> nil) {$IFDEF BORLAND}and (TypeData.ParentInfo^ <> nil){$ENDIF BORLAND} then\r\n Result := JclTypeInfo(TypeData.ParentInfo{$IFDEF BORLAND}^{$ENDIF}) as IJclClassTypeInfo\r\n else\r\n Result := nil;\r\nend;\r\n\r\nfunction TJclClassTypeInfo.GetTotalPropertyCount: Integer;\r\nbegin\r\n Result := TypeData.PropCount;\r\nend;\r\n\r\nfunction TJclClassTypeInfo.GetPropertyCount: Integer;\r\nvar\r\n PropData: ^TPropData;\r\nbegin\r\n PropData := @TypeData.UnitName;\r\n Inc(TJclAddr(PropData), 1 + Length(GetUnitName));\r\n Result := PropData.PropCount;\r\nend;\r\n\r\nfunction TJclClassTypeInfo.GetProperties(const PropIdx: Integer): IJclPropInfo;\r\nvar\r\n PropData: ^TPropData;\r\n Prop: PPropInfo;\r\n Idx: Integer;\r\n RecSize: Integer;\r\nbegin\r\n PropData := @TypeData.UnitName;\r\n Inc(TJclAddr(PropData), 1 + Length(GetUnitName));\r\n if PropIdx + 1 > PropData.PropCount then\r\n Result := Parent.Properties[PropIdx - PropData.PropCount]\r\n else\r\n begin\r\n Prop := PPropInfo(PropData);\r\n Inc(TJclAddr(Prop), 2);\r\n if PropIdx > 0 then\r\n begin\r\n RecSize := SizeOf(TPropInfo) - SizeOf(ShortString);\r\n Idx := PropIdx;\r\n while Idx > 0 do\r\n begin\r\n Inc(TJclAddr(Prop), RecSize);\r\n Inc(TJclAddr(Prop), 1 + PByte(Prop)^);\r\n Dec(Idx);\r\n end;\r\n end;\r\n Result := TJclPropInfo.Create(Prop);\r\n end;\r\nend;\r\n\r\nfunction TJclClassTypeInfo.GetPropNames(const Name: string): IJclPropInfo;\r\nvar\r\n PropInfo: PPropInfo;\r\nbegin\r\n PropInfo := GetPropInfo(TypeInfo, Name);\r\n if PropInfo <> nil then\r\n Result := TJclPropInfo.Create(PropInfo)\r\n else\r\n Result := nil;\r\nend;\r\n\r\nfunction TJclClassTypeInfo.GetUnitName: string;\r\nbegin\r\n Result := string(TypeData.UnitName);\r\nend;\r\n\r\nprocedure TJclClassTypeInfo.LoadValueFromString(AnObj: TObject; const PropName,\r\n Value: string);\r\nvar\r\n DotPos: Integer;\r\n BaseObj: TObject;\r\n Prefix: string;\r\n ValueInfo: IJclValueTypeInfo;\r\nbegin\r\n DotPos := CharPos(PropName, '.');\r\n if DotPos = 0 then\r\n raise EJclRTTIError.CreateResFmt(@RsRTTINoStringValue, [PropName, Name]);\r\n Prefix := StrLeft(PropName, DotPos - 1);\r\n BaseObj := GetObjectProp(AnObj, Prefix);\r\n if Assigned(BaseObj) and Supports(PropNames[Prefix], IJclValueTypeInfo, ValueInfo) then\r\n ValueInfo.LoadValueFromString(BaseObj, StrRestOf(PropName, DotPos + 1), Value)\r\n else\r\n raise EJclRTTIError.CreateResFmt(@RsRTTINoStringValue, [PropName, Name]);\r\nend;\r\n\r\nfunction TJclClassTypeInfo.SaveValueToString(AnObj: TObject;\r\n const PropName: string): string;\r\nvar\r\n DotPos: Integer;\r\n BaseObj: TObject;\r\n Prefix: string;\r\n ValueInfo: IJclValueTypeInfo;\r\nbegin\r\n DotPos := CharPos(PropName, '.');\r\n if DotPos = 0 then\r\n raise EJclRTTIError.CreateResFmt(@RsRTTINoStringValue, [PropName, Name]);\r\n Prefix := StrLeft(PropName, DotPos - 1);\r\n BaseObj := GetObjectProp(AnObj, Prefix);\r\n if Assigned(BaseObj) and Supports(PropNames[Prefix], IJclValueTypeInfo, ValueInfo) then\r\n Result := ValueInfo.SaveValueToString(BaseObj, StrRestOf(PropName, DotPos + 1))\r\n else\r\n raise EJclRTTIError.CreateResFmt(@RsRTTINoStringValue, [PropName, Name]);\r\nend;\r\n\r\nprocedure TJclClassTypeInfo.WriteTo(const Dest: IJclInfoWriter);\r\nconst\r\n cFmt1 = '[%s %d]';\r\n cFmt2 = '[%s %s $%p]';\r\n cFmt3 = '[%s=%s]';\r\n cFmt4 = '[%s=%s $%p]';\r\nvar\r\n I: Integer;\r\n Prop: IJclPropInfo;\r\nbegin\r\n inherited WriteTo(Dest);\r\n Dest.Writeln(LoadResString(@RsRTTIClassName) + ClassRef.ClassName);\r\n Dest.Writeln(LoadResString(@RsRTTIParent) + Parent.ClassRef.ClassName);\r\n Dest.Writeln(LoadResString(@RsRTTIUnitName) + GetUnitName);\r\n Dest.Writeln(LoadResString(@RsRTTIPropCount) + IntToStr(PropertyCount) + ' (' +\r\n IntToStr(TotalPropertyCount) + ')');\r\n Dest.Indent;\r\n try\r\n for I := 0 to PropertyCount-1 do\r\n begin\r\n Prop := Properties[I];\r\n Dest.Writeln(Prop.Name + ': ' + Prop.PropType.Name);\r\n Dest.Indent;\r\n try\r\n if Prop.HasIndex then\r\n Dest.Writeln(Format(cFmt1, [LoadResString(@RsRTTIIndex), Prop.Index]));\r\n if Prop.HasDefault then\r\n Dest.Writeln(Format(cFmt1, [LoadResString(@RsRTTIDefault), Prop.Default]));\r\n case Prop.ReaderType of\r\n pskStaticMethod:\r\n Dest.Writeln(Format(cFmt2, [LoadResString(@RsRTTIPropRead), LoadResString(@RsRTTIStaticMethod),\r\n Pointer(Prop.ReaderValue)]));\r\n pskField:\r\n Dest.Writeln(Format(cFmt2, [LoadResString(@RsRTTIPropRead), LoadResString(@RsRTTIField),\r\n Pointer(Prop.ReaderValue)]));\r\n pskVirtualMethod:\r\n Dest.Writeln(Format(cFmt2, [LoadResString(@RsRTTIPropRead), LoadResString(@RsRTTIVirtualMethod),\r\n Pointer(Prop.ReaderValue)]));\r\n end;\r\n case Prop.WriterType of\r\n pskStaticMethod:\r\n Dest.Writeln(Format(cFmt2, [LoadResString(@RsRTTIPropWrite), LoadResString(@RsRTTIStaticMethod),\r\n Pointer(Prop.WriterValue)]));\r\n pskField:\r\n Dest.Writeln(Format(cFmt2, [LoadResString(@RsRTTIPropWrite), LoadResString(@RsRTTIField),\r\n Pointer(Prop.WriterValue)]));\r\n pskVirtualMethod:\r\n Dest.Writeln(Format(cFmt2, [LoadResString(@RsRTTIPropWrite), LoadResString(@RsRTTIVirtualMethod),\r\n Pointer(Prop.WriterValue)]));\r\n end;\r\n case Prop.StoredType of\r\n pskConstant:\r\n if Boolean(Prop.StoredValue) then\r\n Dest.Writeln(Format(cFmt3, [LoadResString(@RsRTTIPropStored), LoadResString(@RsRTTITrue)]))\r\n else\r\n Dest.Writeln(Format(cFmt3, [LoadResString(@RsRTTIPropStored), LoadResString(@RsRTTIFalse)]));\r\n pskStaticMethod:\r\n Dest.Writeln(Format(cFmt4, [LoadResString(@RsRTTIPropStored), LoadResString(@RsRTTIStaticMethod),\r\n Pointer(Prop.StoredValue)]));\r\n pskField:\r\n Dest.Writeln(Format(cFmt4, [LoadResString(@RsRTTIPropStored), LoadResString(@RsRTTIField),\r\n Pointer(Prop.StoredValue)]));\r\n pskVirtualMethod:\r\n Dest.Writeln(Format(cFmt4, [LoadResString(@RsRTTIPropStored), LoadResString(@RsRTTIVirtualMethod),\r\n Pointer(Prop.StoredValue)]));\r\n end;\r\n finally\r\n Dest.Outdent;\r\n end;\r\n end;\r\n finally\r\n Dest.Outdent;\r\n end;\r\nend;\r\n\r\nprocedure TJclClassTypeInfo.DeclarationTo(const Dest: IJclInfoWriter);\r\nvar\r\n IntfTbl: PInterfaceTable;\r\n I: Integer;\r\n Prop: IJclPropInfo;\r\nbegin\r\n if (Parent <> nil) and\r\n not AnsiSameText(Parent.Name, 'TObject') then\r\n begin\r\n Dest.Write(Name + ' = class(' + Parent.Name);\r\n IntfTbl := ClassRef.GetInterfaceTable;\r\n if IntfTbl <> nil then\r\n for I := 0 to IntfTbl.EntryCount-1 do\r\n {$IFDEF FPC}if IntfTbl.Entries[I].IID <> nil then{$ENDIF FPC}\r\n Dest.Write(', [''' + JclGUIDToString(IntfTbl.Entries[I].IID{$IFDEF FPC}^{$ENDIF}) + ''']');\r\n Dest.Writeln(') // unit ' + GetUnitName);\r\n end\r\n else\r\n Dest.Writeln(Name + ' = class // unit ' + GetUnitName);\r\n if PropertyCount > 0 then\r\n begin\r\n Dest.Writeln('published');\r\n Dest.Indent;\r\n try\r\n for I := 0 to PropertyCount-1 do\r\n begin\r\n Prop := Properties[I];\r\n Dest.Write('property ' + Prop.Name + ': ' + Prop.PropType.Name);\r\n if Prop.HasIndex then\r\n Dest.Write(Format(' index %d', [Prop.Index]));\r\n\r\n case Prop.ReaderType of\r\n pskStaticMethod:\r\n Dest.Write(Format(' read [static method $%p]', [Pointer(Prop.ReaderValue)]));\r\n pskField:\r\n Dest.Write(Format(' read [field $%p]', [Pointer(Prop.ReaderValue)]));\r\n pskVirtualMethod:\r\n Dest.Write(Format(' read [virtual method $%p]', [Pointer(Prop.ReaderValue)]));\r\n end;\r\n\r\n case Prop.WriterType of\r\n pskStaticMethod:\r\n Dest.Write(Format(' write [static method $%p]', [Pointer(Prop.WriterValue)]));\r\n pskField:\r\n Dest.Write(Format(' write [field $%p]', [Pointer(Prop.WriterValue)]));\r\n pskVirtualMethod:\r\n Dest.Write(Format(' write [virtual method $%p]', [Pointer(Prop.WriterValue)]));\r\n end;\r\n\r\n case Prop.StoredType of\r\n pskConstant:\r\n if Boolean(Prop.StoredValue) then\r\n Dest.Write(' stored = True')\r\n else\r\n Dest.Write(' stored = False');\r\n pskStaticMethod:\r\n Dest.Write(Format(' stored = [static method $%p]', [Pointer(Prop.StoredValue)]));\r\n pskField:\r\n Dest.Write(Format(' stored = [field $%p]', [Pointer(Prop.StoredValue)]));\r\n pskVirtualMethod:\r\n Dest.Write(Format(' stored = [virtual method $%p]', [Pointer(Prop.StoredValue)]));\r\n end;\r\n if Prop.HasDefault then\r\n Dest.Write(' default ' + IntToStr(Prop.Default));\r\n Dest.Writeln(';');\r\n end;\r\n finally\r\n Dest.Outdent;\r\n end;\r\n end;\r\n Dest.Writeln('end;');\r\nend;\r\n\r\n//=== { TJclObjClassTypeInfo } ===============================================\r\n\r\nconstructor TJclObjClassTypeInfo.Create(const ATypeInfo: PTypeInfo;\r\n const APrefix: string; AInstance: TObject);\r\nbegin\r\n inherited Create(ATypeInfo);\r\n FPrefix := APrefix;\r\n FInstance := AInstance;\r\nend;\r\n\r\nfunction TJclObjClassTypeInfo.GetInstance: TObject;\r\nbegin\r\n Result := FInstance;\r\nend;\r\n\r\nfunction TJclObjClassTypeInfo.GetObjProperties(\r\n const PropIdx: Integer): IJclObjPropInfo;\r\nvar\r\n PropData: ^TPropData;\r\n Prop: PPropInfo;\r\n Idx: Integer;\r\n RecSize: Integer;\r\nbegin\r\n PropData := @TypeData.UnitName;\r\n Inc(TJclAddr(PropData), 1 + Length(GetUnitName));\r\n Prop := PPropInfo(PropData);\r\n Inc(TJclAddr(Prop), 2);\r\n if PropIdx > 0 then\r\n begin\r\n RecSize := SizeOf(TPropInfo) - SizeOf(ShortString);\r\n Idx := PropIdx;\r\n while Idx > 0 do\r\n begin\r\n Inc(TJclAddr(Prop), RecSize);\r\n Inc(TJclAddr(Prop), 1 + PByte(Prop)^);\r\n Dec(Idx);\r\n end;\r\n end;\r\n Result := TJclObjPropInfo.Create(Prop, FPrefix, FInstance);\r\nend;\r\n\r\nfunction TJclObjClassTypeInfo.GetObjPropNames(\r\n const Name: string): IJclObjPropInfo;\r\nvar\r\n PropInfo: PPropInfo;\r\n DotPos: Integer;\r\n Prefix, Suffix: string;\r\n SubClassTypeInfo: IJclObjClassTypeInfo;\r\n AInstance: TObject;\r\nbegin\r\n DotPos := CharPos(Name, '.');\r\n if DotPos > 0 then\r\n begin\r\n Prefix := StrLeft(Name, DotPos - 1);\r\n Suffix := StrRestOf(Name, DotPos + 1);\r\n PropInfo := GetPropInfo(TypeInfo, Prefix);\r\n if (PropInfo <> nil) and (PropInfo.PropType^.Kind = tkClass) then\r\n begin\r\n if FPrefix <> '' then\r\n Prefix := FPrefix + '.' + Prefix;\r\n AInstance := GetObjectProp(FInstance, PropInfo);\r\n if AInstance <> nil then\r\n begin\r\n SubClassTypeInfo := TJclObjClassTypeInfo.Create(PropInfo.PropType{$IFDEF BORLAND}^{$ENDIF}, Prefix, AInstance);\r\n Result := SubClassTypeInfo.ObjPropNames[Suffix];\r\n end\r\n else\r\n Result := nil;\r\n end\r\n else\r\n Result := nil;\r\n end\r\n else\r\n begin\r\n PropInfo := GetPropInfo(TypeInfo, Name);\r\n if PropInfo <> nil then\r\n Result := TJclObjPropInfo.Create(PropInfo, FPrefix, FInstance)\r\n else\r\n Result := nil;\r\n end;\r\nend;\r\n\r\nprocedure TJclObjClassTypeInfo.LoadValueFromString(const PropName,\r\n Value: string);\r\nvar\r\n ObjPropInfo: IJclObjPropInfo;\r\nbegin\r\n ObjPropInfo := GetObjPropNames(PropName);\r\n if Assigned(ObjPropInfo) then\r\n ObjPropInfo.LoadValueFromString(Value)\r\n else\r\n raise EJclRTTIError.CreateResFmt(@RsRTTINoStringValue, [Name, PropName]);\r\nend;\r\n\r\nfunction TJclObjClassTypeInfo.SaveValueToString(const PropName: string): string;\r\nvar\r\n ObjPropInfo: IJclObjPropInfo;\r\nbegin\r\n ObjPropInfo := GetObjPropNames(PropName);\r\n if Assigned(ObjPropInfo) then\r\n Result := ObjPropInfo.SaveValueToString\r\n else\r\n raise EJclRTTIError.CreateResFmt(@RsRTTINoStringValue, [Name, PropName]);\r\nend;\r\n\r\n//=== { TJclEventParamInfo } =================================================\r\n\r\nconstructor TJclEventParamInfo.Create(const AParam: Pointer);\r\nbegin\r\n inherited Create;\r\n FParam := AParam;\r\nend;\r\n\r\nfunction TJclEventParamInfo.GetFlags: TParamFlags;\r\ntype\r\n PParamFlags = ^TParamFlags;\r\nbegin\r\n Result := PParamFlags(Param)^;\r\nend;\r\n\r\nfunction TJclEventParamInfo.GetName: string;\r\nvar\r\n PName: PShortString;\r\nbegin\r\n PName := Param;\r\n Inc(TJclAddr(PName));\r\n Result := string(PName^);\r\nend;\r\n\r\nfunction TJclEventParamInfo.GetRecSize: Integer;\r\nbegin\r\n Result := 3 + Length(Name) + Length(TypeName);\r\nend;\r\n\r\nfunction TJclEventParamInfo.GetTypeName: string;\r\nvar\r\n PName: PShortString;\r\nbegin\r\n PName := Param;\r\n Inc(TJclAddr(PName));\r\n Inc(TJclAddr(PName), PByte(PName)^ + 1);\r\n Result := string(PName^);\r\nend;\r\n\r\nfunction TJclEventParamInfo.GetParam: Pointer;\r\nbegin\r\n Result := FParam;\r\nend;\r\n\r\n//=== { TJclEventTypeInfo } ==================================================\r\n\r\nfunction TJclEventTypeInfo.GetMethodKind: TMethodKind;\r\nbegin\r\n Result := TypeData.MethodKind;\r\nend;\r\n\r\nfunction TJclEventTypeInfo.GetParameterCount: Integer;\r\nbegin\r\n Result := TypeData.ParamCount;\r\nend;\r\n\r\nfunction TJclEventTypeInfo.GetParameters(const ParamIdx: Integer): IJclEventParamInfo;\r\nvar\r\n I: Integer;\r\n Param: Pointer;\r\nbegin\r\n Result := nil;\r\n Param := @TypeData.ParamList[0];\r\n I := ParamIdx;\r\n while I >= 0 do\r\n begin\r\n Result := TJclEventParamInfo.Create(Param);\r\n Inc(TJclAddr(Param), Result.RecSize);\r\n Dec(I);\r\n end;\r\nend;\r\n\r\nfunction TJclEventTypeInfo.GetResultTypeName: string;\r\nvar\r\n LastParam: IJclEventParamInfo;\r\n ResPtr: PShortString;\r\nbegin\r\n if MethodKind = mkFunction then\r\n begin\r\n if ParameterCount > 0 then\r\n begin\r\n LastParam := Parameters[ParameterCount-1];\r\n ResPtr := Pointer(TJclAddr(LastParam.Param) + TJclAddr(LastParam.RecSize));\r\n end\r\n else\r\n ResPtr := @TypeData.ParamList[0];\r\n Result := string(ResPtr^);\r\n end\r\n else\r\n Result := '';\r\nend;\r\n\r\nprocedure TJclEventTypeInfo.WriteTo(const Dest: IJclInfoWriter);\r\nvar\r\n I: Integer;\r\n Param: IJclEventParamInfo;\r\n ParamFlags: TParamFlags;\r\nbegin\r\n inherited WriteTo(Dest);\r\n Dest.Writeln(LoadResString(@RsRTTIMethodKind) +\r\n JclEnumValueToIdent(System.TypeInfo(TMethodKind), TypeData.MethodKind));\r\n Dest.Writeln(LoadResString(@RsRTTIParamCount) + IntToStr(ParameterCount));\r\n Dest.Indent;\r\n try\r\n for I := 0 to ParameterCount-1 do\r\n begin\r\n if I > 0 then\r\n Dest.Writeln('');\r\n Param := Parameters[I];\r\n ParamFlags := Param.Flags;\r\n Dest.Writeln(LoadResString(@RsRTTIName) + Param.Name);\r\n Dest.Writeln(LoadResString(@RsRTTIType) + Param.TypeName);\r\n Dest.Writeln(LoadResString(@RsRTTIFlags) +\r\n JclSetToStr(System.TypeInfo(TParamFlags), ParamFlags, True, False));\r\n end;\r\n finally\r\n Dest.Outdent;\r\n end;\r\n if MethodKind = mkFunction then\r\n Dest.Writeln(LoadResString(@RsRTTIReturnType) + ResultTypeName);\r\nend;\r\n\r\nprocedure TJclEventTypeInfo.DeclarationTo(const Dest: IJclInfoWriter);\r\nvar\r\n Prefix: string;\r\n I: Integer;\r\n Param: IJclEventParamInfo;\r\nbegin\r\n Dest.Write(Name + ' = ');\r\n if MethodKind = mkFunction then\r\n Dest.Write('function')\r\n else\r\n Dest.Write('procedure');\r\n Prefix := '(';\r\n for I := 0 to ParameterCount-1 do\r\n begin\r\n Dest.Write(Prefix);\r\n Prefix := '; ';\r\n Param := Parameters[I];\r\n if pfVar in Param.Flags then\r\n Dest.Write(LoadResString(@RsRTTIVar))\r\n else\r\n if pfConst in Param.Flags then\r\n Dest.Write(LoadResString(@RsRTTIConst))\r\n else\r\n if pfOut in Param.Flags then\r\n Dest.Write(LoadResString(@RsRTTIOut));\r\n Dest.Write(Param.Name);\r\n if Param.TypeName <> '' then\r\n begin\r\n Dest.Write(': ');\r\n if pfArray in Param.Flags then\r\n Dest.Write(LoadResString(@RsRTTIArrayOf));\r\n if AnsiSameText(Param.TypeName, 'TVarRec') and (pfArray in Param.Flags) then\r\n Dest.Write(TrimRight(LoadResString(@RsRTTIConst)))\r\n else\r\n Dest.Write(Param.TypeName);\r\n end;\r\n end;\r\n if ParameterCount <> 0 then\r\n Dest.Write(')');\r\n if MethodKind = mkFunction then\r\n Dest.Write(': ' + ResultTypeName);\r\n Dest.Writeln(' of object;');\r\nend;\r\n\r\n//=== { TJclInterfaceTypeInfo } ==============================================\r\n\r\nfunction TJclInterfaceTypeInfo.GetParent: IJclInterfaceTypeInfo;\r\nbegin\r\n if (TypeData.IntfParent <> nil) {$IFDEF BORLAND}and (TypeData.IntfParent^ <> nil){$ENDIF BORLAND} then\r\n Result := JclTypeInfo(TypeData.IntfParent{$IFDEF BORLAND}^{$ENDIF}) as IJclInterfaceTypeInfo\r\n else\r\n Result := nil;\r\nend;\r\n\r\nfunction TJclInterfaceTypeInfo.GetFlags: TIntfFlagsBase;\r\nbegin\r\n Result := TypeData.IntfFlags;\r\nend;\r\n\r\nconst\r\n NullGUID: TGUID = '{00000000-0000-0000-0000-000000000000}';\r\n\r\nfunction TJclInterfaceTypeInfo.GetGUID: TGUID;\r\nbegin\r\n if ifHasGuid in Flags then\r\n Result := TypeData.Guid\r\n else\r\n Result := NullGUID;\r\nend;\r\n\r\nfunction TJclInterfaceTypeInfo.GetPropertyCount: Integer;\r\nvar\r\n PropData: ^TPropData;\r\nbegin\r\n PropData := @TypeData.IntfUnit;\r\n Inc(TJclAddr(PropData), 1 + Length(GetUnitName));\r\n Result := PropData.PropCount;\r\nend;\r\n\r\nfunction TJclInterfaceTypeInfo.GetUnitName: string;\r\nbegin\r\n Result := string(TypeData.IntfUnit);\r\nend;\r\n\r\nprocedure TJclInterfaceTypeInfo.WriteTo(const Dest: IJclInfoWriter);\r\nvar\r\n IntfFlags: TIntfFlagsBase;\r\nbegin\r\n inherited WriteTo(Dest);\r\n if ifHasGuid in Flags then\r\n Dest.Writeln(LoadResString(@RsRTTIGUID) + JclGuidToString(GUID));\r\n IntfFlags := Flags;\r\n Dest.Writeln(LoadResString(@RsRTTIFlags) + JclSetToStr(System.TypeInfo(TIntfFlagsBase),\r\n IntfFlags, True, False));\r\n Dest.Writeln(LoadResString(@RsRTTIUnitName) + GetUnitName);\r\n if Parent <> nil then\r\n Dest.Writeln(LoadResString(@RsRTTIParent) + Parent.Name);\r\n Dest.Writeln(LoadResString(@RsRTTIPropCount) + IntToStr(PropertyCount));\r\nend;\r\n\r\nprocedure TJclInterfaceTypeInfo.DeclarationTo(const Dest: IJclInfoWriter);\r\nbegin\r\n Dest.Write(Name + ' = ');\r\n if ifDispInterface in Flags then\r\n Dest.Write('dispinterface')\r\n else\r\n Dest.Write('interface');\r\n if (Parent <> nil) and not (ifDispInterface in Flags) and not\r\n AnsiSameText(Parent.Name, 'IUnknown') then\r\n Dest.Write('(' + Parent.Name + ')');\r\n Dest.Writeln(' // unit ' + GetUnitName);\r\n Dest.Indent;\r\n try\r\n if ifHasGuid in Flags then\r\n Dest.Writeln('[''' + JclGuidToString(GUID) + ''']');\r\n finally\r\n Dest.Outdent;\r\n Dest.Writeln('end;');\r\n end;\r\nend;\r\n\r\n//=== { TJclInt64TypeInfo } ==================================================\r\n\r\nfunction TJclInt64TypeInfo.GetMinValue: Int64;\r\nbegin\r\n Result := TypeData.MinInt64Value;\r\nend;\r\n\r\nprocedure TJclInt64TypeInfo.LoadValueFromString(AnObj: TObject; const PropName,\r\n Value: string);\r\nbegin\r\n SetInt64Prop(AnObj, PropName, StrToInt(Value));\r\nend;\r\n\r\nfunction TJclInt64TypeInfo.GetMaxValue: Int64;\r\nbegin\r\n Result := TypeData.MaxInt64Value;\r\nend;\r\n\r\nprocedure TJclInt64TypeInfo.WriteTo(const Dest: IJclInfoWriter);\r\nbegin\r\n inherited WriteTo(Dest);\r\n Dest.Writeln(LoadResString(@RsRTTIMinValue) + IntToStr(MinValue));\r\n Dest.Writeln(LoadResString(@RsRTTIMaxValue) + IntToStr(MaxValue));\r\nend;\r\n\r\nfunction TJclInt64TypeInfo.SaveValueToString(AnObj: TObject;\r\n const PropName: string): string;\r\nbegin\r\n Result := IntToStr(GetInt64Prop(AnObj, PropName));\r\nend;\r\n\r\nprocedure TJclInt64TypeInfo.DeclarationTo(const Dest: IJclInfoWriter);\r\nbegin\r\n Dest.Writeln(Name + ' = ' + IntToStr(MinValue) + ' .. ' + IntToStr(MaxValue) + ';');\r\nend;\r\n\r\n//=== { TJclDynArrayTypeInfo } ===============================================\r\n\r\nfunction TJclDynArrayTypeInfo.GetElementSize: Longint;\r\nbegin\r\n Result := TypeData.elSize;\r\nend;\r\n\r\nfunction TJclDynArrayTypeInfo.GetElementType: IJclTypeInfo;\r\nbegin\r\n if TypeData.elType = nil then\r\n begin\r\n if TypeData.elType2 <> nil then\r\n Result := JclTypeInfo(TypeData.elType2^)\r\n else\r\n Result := nil;\r\n end\r\n else\r\n Result := JclTypeInfo(TypeData.elType^);\r\nend;\r\n\r\nfunction TJclDynArrayTypeInfo.GetElementsNeedCleanup: Boolean;\r\nbegin\r\n Result := TypeData.elType <> nil;\r\nend;\r\n\r\nfunction TJclDynArrayTypeInfo.GetVarType: Integer;\r\nbegin\r\n Result := TypeData.varType;\r\nend;\r\n\r\nfunction TJclDynArrayTypeInfo.GetUnitName: string;\r\nbegin\r\n Result := string(TypeData.DynUnitName);\r\nend;\r\n\r\nprocedure TJclDynArrayTypeInfo.WriteTo(const Dest: IJclInfoWriter);\r\nbegin\r\n inherited WriteTo(Dest);\r\n Dest.Writeln(LoadResString(@RsRTTIElSize) + IntToStr(ElementSize));\r\n if ElementType = nil then\r\n Dest.Writeln(LoadResString(@RsRTTIElType) + RsRTTITypeError)\r\n else\r\n if ElementType.Name[1] <> '.' then\r\n Dest.Writeln(LoadResString(@RsRTTIElType) + ElementType.Name)\r\n else\r\n begin\r\n Dest.Writeln(LoadResString(@RsRTTIElType));\r\n Dest.Indent;\r\n try\r\n ElementType.WriteTo(Dest);\r\n finally\r\n Dest.Outdent;\r\n end;\r\n end;\r\n Dest.Write(LoadResString(@RsRTTIElNeedCleanup));\r\n if ElementsNeedCleanup then\r\n Dest.Writeln(LoadResString(@RsRTTITrue))\r\n else\r\n Dest.Writeln(LoadResString(@RsRTTIFalse));\r\n Dest.Writeln(LoadResString(@RsRTTIVarType) + IntToStr(VarType));\r\n Dest.Writeln(LoadResString(@RsRTTIUnitName) + GetUnitName);\r\nend;\r\n\r\nprocedure TJclDynArrayTypeInfo.DeclarationTo(const Dest: IJclInfoWriter);\r\nbegin\r\n if Name[1] <> '.' then\r\n Dest.Write(Name + ' = ' + LoadResString(@RsRTTIArrayOf))\r\n else\r\n Dest.Write(LoadResString(@RsRTTIArrayOf));\r\n if ElementType = nil then\r\n Dest.Write(LoadResString(@RsRTTITypeError))\r\n else\r\n if ElementType.Name[1] = '.' then\r\n ElementType.DeclarationTo(Dest)\r\n else\r\n Dest.Write(ElementType.Name);\r\n if Name[1] <> '.' then\r\n Dest.Writeln('; // Unit ' + GetUnitName);\r\nend;\r\n\r\n//=== Typeinfo retrieval =====================================================\r\n\r\nfunction JclTypeInfo(ATypeInfo: PTypeInfo): IJclTypeInfo;\r\nbegin\r\n case ATypeInfo.Kind of\r\n tkInteger, tkChar, tkWChar:\r\n Result := TJclOrdinalRangeTypeInfo.Create(ATypeInfo);\r\n tkEnumeration:\r\n Result := TJclEnumerationTypeInfo.Create(ATypeInfo);\r\n tkSet:\r\n Result := TJclSetTypeInfo.Create(ATypeInfo);\r\n tkFloat:\r\n Result := TJclFloatTypeInfo.Create(ATypeInfo);\r\n tkString,\r\n tkLString,\r\n {$IFDEF SUPPORTS_UNICODE_STRING}\r\n tkUString,\r\n {$ENDIF SUPPORTS_UNICODE_STRING}\r\n tkWString:\r\n Result := TJclStringTypeInfo.Create(ATypeInfo);\r\n tkClass:\r\n Result := TJclClassTypeInfo.Create(ATypeInfo);\r\n tkMethod:\r\n Result := TJclEventTypeInfo.Create(ATypeInfo);\r\n tkInterface:\r\n Result := TJclInterfaceTypeInfo.Create(ATypeInfo);\r\n tkInt64:\r\n Result := TJclInt64TypeInfo.Create(ATypeInfo);\r\n tkDynArray:\r\n Result := TJclDynArrayTypeInfo.Create(ATypeInfo);\r\n else\r\n Result := TJclTypeInfo.Create(ATypeInfo);\r\n end;\r\nend;\r\n\r\n//=== User generated type info managment =====================================\r\n\r\nvar\r\n TypeList: TThreadList;\r\n\r\ntype\r\n PTypeItem = ^TTypeItem;\r\n TTypeItem = record\r\n TypeInfo: PTypeInfo;\r\n RefCount: Integer;\r\n end;\r\n\r\nprocedure FreeTypeData(const TypeInfo: PTypeInfo);\r\nvar\r\n TD: PTypeData;\r\nbegin\r\n TD := GetTypeData(TypeInfo);\r\n if TypeInfo.Kind = tkSet then\r\n RemoveTypeInfo(TD^.CompType{$IFDEF BORLAND}^{$ENDIF})\r\n else\r\n if (TypeInfo.Kind = tkEnumeration) and (TD^.BaseType{$IFDEF BORLAND}^{$ENDIF} <> TypeInfo) then\r\n RemoveTypeInfo(GetTypeData(TypeInfo)^.BaseType{$IFDEF BORLAND}^{$ENDIF});\r\n FreeMem(GetTypeData(TypeInfo)^.BaseType);\r\n FreeMem(TypeInfo);\r\nend;\r\n\r\nprocedure AddType(const TypeInfo: PTypeInfo);\r\nvar\r\n Item: PTypeItem;\r\nbegin\r\n New(Item);\r\n try\r\n Item.TypeInfo := TypeInfo;\r\n Item.RefCount := 1;\r\n TypeList.Add(Item);\r\n except\r\n Dispose(Item);\r\n raise;\r\n end;\r\nend;\r\n\r\nprocedure DeleteType(const TypeItem: PTypeItem);\r\nbegin\r\n FreeTypeData(TypeItem.TypeInfo);\r\n TypeList.Remove(TypeItem);\r\n Dispose(TypeItem);\r\nend;\r\n\r\nprocedure DoRefType(const TypeInfo: PTypeInfo; Add: Integer);\r\nvar\r\n I: Integer;\r\n List: TList;\r\nbegin\r\n List := TypeList.LockList;\r\n try\r\n I := List.Count-1;\r\n while (I >= 0) and (PTypeItem(List[I]).TypeInfo <> TypeInfo) do\r\n Dec(I);\r\n if I > -1 then\r\n Inc(PTypeItem(List[I]).RefCount, Add);\r\n finally\r\n TypeList.UnlockList;\r\n end;\r\nend;\r\n\r\nprocedure ReferenceType(const TypeInfo: PTypeInfo);\r\nbegin\r\n DoRefType(TypeInfo, 1);\r\nend;\r\n\r\nprocedure DeReferenceType(const TypeInfo: PTypeInfo);\r\nbegin\r\n DoRefType(TypeInfo, -1);\r\nend;\r\n\r\nprocedure ClearInfoList;\r\nvar\r\n L: TList;\r\nbegin\r\n L := TypeList.LockList;\r\n try\r\n while L.Count > 0 do\r\n RemoveTypeInfo(PTypeItem(L[L.Count-1])^.TypeInfo);\r\n finally\r\n TypeList.UnlockList;\r\n end;\r\nend;\r\n\r\nprocedure NewInfoItem(const TypeInfo: PTypeInfo);\r\nbegin\r\n TypeList.Add(TypeInfo);\r\nend;\r\n\r\nprocedure RemoveTypeInfo(TypeInfo: PTypeInfo);\r\nvar\r\n I: Integer;\r\n List: TList;\r\n Item: PTypeItem;\r\nbegin\r\n Item := nil;\r\n List := TypeList.LockList;\r\n try\r\n I := List.Count-1;\r\n while (I >= 0) and (PTypeItem(List[I]).TypeInfo <> TypeInfo) do\r\n Dec(I);\r\n if I > -1 then\r\n Item := PTypeItem(List[I]);\r\n finally\r\n TypeList.UnlockList;\r\n end;\r\n if Item <> nil then\r\n begin\r\n Dec(Item.RefCount);\r\n if Item.RefCount <= 0 then\r\n DeleteType(Item);\r\n end;\r\nend;\r\n\r\n//=== Enumerations ===========================================================\r\n\r\nfunction JclEnumValueToIdent(TypeInfo: PTypeInfo;\r\n const Value): string;\r\nvar\r\n MinEnum: Integer;\r\n MaxEnum: Integer;\r\n EnumVal: Int64;\r\n OrdType: TOrdType;\r\nbegin\r\n OrdType := GetTypeData(TypeInfo).OrdType;\r\n MinEnum := GetTypeData(TypeInfo).MinValue;\r\n MaxEnum := GetTypeData(TypeInfo).MaxValue;\r\n case OrdType of\r\n otSByte:\r\n EnumVal := Smallint(Value);\r\n otUByte:\r\n EnumVal := Byte(Value);\r\n otSWord:\r\n EnumVal := Shortint(Value);\r\n otUWord:\r\n EnumVal := Word(Value);\r\n otSLong:\r\n EnumVal := Integer(Value);\r\n otULong:\r\n EnumVal := Longword(Value);\r\n else\r\n EnumVal := 0;\r\n end;\r\n // Check range...\r\n if (EnumVal < MinEnum) or (EnumVal > MaxEnum) then\r\n Result := Format(LoadResString(@RsRTTIValueOutOfRange),\r\n [LoadResString(@RsRTTIOrdinal) + IntToStr(EnumVal)])\r\n else\r\n Result := GetEnumName(TypeInfo, EnumVal);\r\nend;\r\n\r\nfunction JclGenerateEnumType(const TypeName: ShortString;\r\n const Literals: array of string): PTypeInfo;\r\nvar\r\n StringSize: Integer;\r\n I: Integer;\r\n TypeData: PTypeData;\r\n CurName: PShortString;\r\nbegin\r\n StringSize := 0;\r\n for I := Low(Literals) to High(Literals) do\r\n StringSize := StringSize + 1 + Length(Literals[I]);\r\n Result := AllocMem(SizeOf(TTypeInfo) + SizeOf(TOrdType) +\r\n (2*SizeOf(Integer)) + SizeOf(PPTypeInfo) +\r\n StringSize + 1);\r\n try\r\n with Result^ do\r\n begin\r\n Kind := tkEnumeration;\r\n Name := TypeName;\r\n end;\r\n TypeData := GetTypeData(Result);\r\n TypeData^.BaseType := AllocMem(SizeOf(Pointer));\r\n if Length(Literals) < 256 then\r\n TypeData^.OrdType := otUByte\r\n else\r\n if Length(Literals) < 65536 then\r\n TypeData^.OrdType := otUWord\r\n else\r\n TypeData^.OrdType := otULong;\r\n TypeData^.MinValue := 0;\r\n TypeData^.MaxValue := Length(Literals)-1;\r\n TypeData^.BaseType{$IFDEF BORLAND}^{$ENDIF} := Result; // No sub-range: basetype points to itself\r\n CurName := @TypeData^.NameList;\r\n for I := Low(Literals) to High(Literals) do\r\n begin\r\n CurName^ := ShortString(Literals[I]);\r\n Inc(TJclAddr(CurName), Length(Literals[I])+1);\r\n end;\r\n CurName^ := ''; // Unit name unknown\r\n AddType(Result);\r\n except\r\n try\r\n ReallocMem(Result, 0);\r\n except\r\n Result := nil;\r\n end;\r\n raise;\r\n end;\r\nend;\r\n\r\nfunction JclGenerateEnumTypeBasedOn(const TypeName: ShortString;\r\n BaseType: PTypeInfo; const PrefixCut: Byte): PTypeInfo;\r\nvar\r\n BaseInfo: IJclTypeInfo;\r\n BaseKind: TTypeKind;\r\n Literals: array of string;\r\n I: Integer;\r\n S: string;\r\nbegin\r\n BaseInfo := JclTypeInfo(BaseType);\r\n BaseKind := BaseInfo.TypeKind;\r\n if BaseInfo.TypeKind <> tkEnumeration then\r\n raise EJclRTTIError.CreateResFmt(@RsRTTIInvalidBaseType, [BaseInfo.Name,\r\n JclEnumValueToIdent(System.TypeInfo(TTypeKind), BaseKind)]);\r\n with BaseInfo as IJclEnumerationTypeInfo do\r\n begin\r\n SetLength(Literals, MaxValue - MinValue + 1);\r\n for I := MinValue to MaxValue do\r\n begin\r\n S := Names[I];\r\n if PrefixCut = PREFIX_CUT_LOWERCASE then\r\n while (Length(S) > 0) and CharIsLower(S[1]) do\r\n Delete(S, 1, 1);\r\n if (PrefixCut > 0) and (PrefixCut < MaxPrefixCut) then\r\n Delete(S, 1, PrefixCut);\r\n if S = '' then\r\n S := Names[I];\r\n Literals[I- MinValue] := S;\r\n end;\r\n if PrefixCut = PREFIX_CUT_EQUAL then\r\n begin\r\n S := Literals[High(Literals)];\r\n I := High(Literals)-1;\r\n while (I >= 0) and (S > '') do\r\n begin\r\n while Copy(Literals[I], 1, Length(S)) <> S do\r\n Delete(S, Length(S), 1);\r\n Dec(I);\r\n end;\r\n if S > '' then\r\n for I := Low(Literals) to High(Literals) do\r\n begin\r\n Literals[I] := StrRestOf(Literals[I], Length(S));\r\n if Literals[I] = '' then\r\n Literals[I] := Names[I + MinValue];\r\n end;\r\n end;\r\n end;\r\n Result := JclGenerateEnumType(TypeName, Literals);\r\nend;\r\n\r\nfunction JclGenerateSubRange(BaseType: PTypeInfo; const TypeName: string;\r\n const MinValue, MaxValue: Integer): PTypeInfo;\r\nvar\r\n TypeData: PTypeData;\r\nbegin\r\n Result := AllocMem(SizeOf(TTypeInfo) + SizeOf(TOrdType) +\r\n (2*SizeOf(Integer)) + SizeOf(PPTypeInfo));\r\n try\r\n with Result^ do\r\n begin\r\n Kind := BaseType^.Kind;\r\n Name := ShortString(TypeName);\r\n end;\r\n TypeData := GetTypeData(Result);\r\n TypeData^.OrdType := GetTypeData(BaseType)^.OrdType;\r\n TypeData^.MinValue := MinValue;\r\n TypeData^.MaxValue := MaxValue;\r\n TypeData^.BaseType := AllocMem(SizeOf(Pointer));\r\n TypeData^.BaseType{$IFDEF BORLAND}^{$ENDIF} := BaseType;\r\n AddType(Result);\r\n except\r\n try\r\n ReallocMem(Result, 0);\r\n except\r\n Result := nil;\r\n end;\r\n raise;\r\n end;\r\n ReferenceType(BaseType);\r\nend;\r\n\r\n//=== Integers ===============================================================\r\n\r\nfunction JclStrToTypedInt(Value: string; TypeInfo: PTypeInfo): Integer;\r\nvar\r\n Conv: TIdentToInt;\r\n HaveConversion: Boolean;\r\n Info: IJclTypeInfo;\r\n RangeInfo: IJclOrdinalRangeTypeInfo;\r\n TmpVal: Int64;\r\nbegin\r\n if TypeInfo <> nil then\r\n Conv := FindIdentToInt(TypeInfo)\r\n else\r\n Conv := nil;\r\n Result := 0;\r\n HaveConversion := (@Conv <> nil) and Conv(Value, Result);\r\n if not HaveConversion then\r\n begin\r\n if TypeInfo <> nil then\r\n begin\r\n Info := JclTypeInfo(TypeInfo);\r\n if Info.QueryInterface(IJclOrdinalRangeTypeInfo, RangeInfo) <> S_OK then\r\n RangeInfo := nil;\r\n TmpVal := StrToInt64(Value);\r\n if (RangeInfo <> nil) and ((TmpVal < RangeInfo.MinValue) or\r\n (TmpVal > RangeInfo.MaxValue)) then\r\n raise EConvertError.CreateResFmt(@SInvalidInteger, [Value]);\r\n Result := Integer(TmpVal);\r\n end\r\n else\r\n Result := StrToInt(Value)\r\n end;\r\nend;\r\n\r\nfunction JclTypedIntToStr(Value: Integer; TypeInfo: PTypeInfo): string;\r\nvar\r\n Conv: TIntToIdent;\r\n HaveConversion: Boolean;\r\nbegin\r\n if TypeInfo <> nil then\r\n Conv := FindIntToIdent(TypeInfo)\r\n else\r\n Conv := nil;\r\n Result := '';\r\n HaveConversion := (@Conv <> nil) and Conv(Value, Result);\r\n if not HaveConversion then\r\n begin\r\n if (TypeInfo <> nil) and (GetTypeData(TypeInfo).OrdType = otULong) then\r\n Result := IntToStr(Int64(Cardinal(Value)))\r\n else\r\n Result := IntToStr(Value)\r\n end;\r\nend;\r\n\r\n//=== Sets ===================================================================\r\n\r\nfunction JclSetToList(TypeInfo: PTypeInfo; const Value; const WantBrackets: Boolean; const WantRanges: Boolean;\r\n const Strings: TStrings): string;\r\nvar\r\n SetType: IJclSetTypeInfo;\r\n I: Integer;\r\nbegin\r\n I := Strings.Count;\r\n Result := '';\r\n SetType := JclTypeInfo(TypeInfo) as IJclSetTypeInfo;\r\n SetType.GetAsList(Value, WantRanges, Strings);\r\n for I := I to Strings.Count - 1 do\r\n begin\r\n if Result <> '' then\r\n Result := Result + ', ' + Strings[I]\r\n else\r\n Result := Result + Strings[I];\r\n end;\r\n if WantBrackets then\r\n Result := '[' + Result + ']';\r\nend;\r\n\r\nfunction JclSetToStr(TypeInfo: PTypeInfo; const Value; const WantBrackets: Boolean; const WantRanges: Boolean): string;\r\nvar\r\n Dummy: TStringList;\r\nbegin\r\n Dummy := TStringList.Create;\r\n try\r\n Result := JclSetToList(TypeInfo, Value, WantBrackets, WantRanges, Dummy);\r\n finally\r\n Dummy.Free;\r\n end;\r\nend;\r\n\r\nprocedure JclStrToSet(TypeInfo: PTypeInfo; var SetVar; const Value: string);\r\nvar\r\n SetInfo: IJclSetTypeInfo;\r\n S: TStringList;\r\nbegin\r\n SetInfo := JclTypeInfo(TypeInfo) as IJclSetTypeInfo;\r\n S := TStringList.Create;\r\n try\r\n StrToStrings(Value, ',', S);\r\n if S.Count > 0 then\r\n begin\r\n if S[0][1] = '[' then\r\n begin\r\n S[0] := Copy(S[0], 2, Length(S[0]));\r\n S[S.Count-1] := Copy(S[S.Count-1], 1,\r\n Length(S[S.Count-1]) - 1);\r\n end;\r\n end;\r\n SetInfo.SetAsList(SetVar, S);\r\n finally\r\n S.Free;\r\n end;\r\nend;\r\n\r\nprocedure JclIntToSet(TypeInfo: PTypeInfo; var SetVar; const Value: Integer);\r\nvar\r\n BitShift: Integer;\r\n TmpInt64: Int64;\r\n EnumMin: Integer;\r\n EnumMax: Integer;\r\n ResBytes: Integer;\r\n CompType: PTypeInfo;\r\nbegin\r\n CompType := GetTypeData(TypeInfo).CompType{$IFDEF BORLAND}^{$ENDIF};\r\n EnumMin := GetTypeData(CompType).MinValue;\r\n BitShift := EnumMin mod 8;\r\n TmpInt64 := Longword(Value) shl BitShift;\r\n EnumMax := GetTypeData(CompType).MaxValue;\r\n ResBytes := (EnumMax div 8) - (EnumMin div 8) + 1;\r\n Move(TmpInt64, SetVar, ResBytes);\r\nend;\r\n\r\nfunction JclSetToInt(TypeInfo: PTypeInfo; const SetVar): Integer;\r\nvar\r\n BitShift: Integer;\r\n TmpInt64: Int64;\r\n EnumMin: Integer;\r\n EnumMax: Integer;\r\n ResBytes: Integer;\r\n CompType: PTypeInfo;\r\nbegin\r\n CompType := GetTypeData(TypeInfo).CompType{$IFDEF BORLAND}^{$ENDIF};\r\n EnumMin := GetTypeData(CompType).MinValue;\r\n EnumMax := GetTypeData(CompType).MaxValue;\r\n ResBytes := (EnumMax div 8) - (EnumMin div 8) + 1;\r\n BitShift := EnumMin mod 8;\r\n if (EnumMax - EnumMin) > 32 then\r\n raise EJclRTTIError.CreateResFmt(@RsRTTIValueOutOfRange,\r\n [IntToStr(EnumMax - EnumMin) + ' ' + LoadResString(@RsRTTIBits)]);\r\n Result := 0;\r\n TmpInt64 := 0;\r\n Move(SetVar, TmpInt64, ResBytes + 1);\r\n TmpInt64 := TmpInt64 shr BitShift;\r\n Move(TmpInt64, Result, ResBytes);\r\nend;\r\n\r\nfunction JclGenerateSetType(BaseType: PTypeInfo;\r\n const TypeName: ShortString): PTypeInfo;\r\nvar\r\n TypeData: PTypeData;\r\n ValCount: Integer;\r\nbegin\r\n Result := AllocMem(SizeOf(TTypeInfo) + SizeOf(TOrdType) + SizeOf(PPTypeInfo));\r\n try\r\n with Result^ do\r\n begin\r\n Kind := tkSet;\r\n Name := TypeName;\r\n end;\r\n with GetTypeData(BaseType)^ do\r\n ValCount := MaxValue - MinValue + (MinValue mod 8);\r\n TypeData := GetTypeData(Result);\r\n case ValCount of\r\n 0..8:\r\n TypeData^.OrdType := otUByte;\r\n 9..16:\r\n TypeData^.OrdType := otUWord;\r\n 17..32:\r\n TypeData^.OrdType := otULong;\r\n 33..64:\r\n Byte(TypeData^.OrdType) := 8;\r\n 65..128:\r\n Byte(TypeData^.OrdType) := 16;\r\n 129..256:\r\n Byte(TypeData^.OrdType) := 32;\r\n else\r\n Byte(TypeData^.OrdType) := 255;\r\n end;\r\n {$IFDEF BORLAND}\r\n TypeData^.CompType := AllocMem(SizeOf(Pointer));\r\n TypeData^.CompType^ := BaseType;\r\n {$ENDIF BORLAND}\r\n {$IFDEF FPC}\r\n TypeData^.CompType := BaseType;\r\n {$ENDIF FPC}\r\n AddType(Result);\r\n except\r\n try\r\n ReallocMem(Result, 0);\r\n except\r\n Result := nil;\r\n end;\r\n raise;\r\n end;\r\n ReferenceType(BaseType);\r\nend;\r\n\r\n//=== Is/As hooking ==========================================================\r\n\r\n// Copied from System.pas (_IsClass function)\r\n\r\nfunction JclIsClass(const AnObj: TObject; const AClass: TClass): Boolean;\r\nasm\r\n {$IFDEF CPU32}\r\n // 32 --> EAX AnObj\r\n // EDX AClass\r\n // <-- AL Result\r\n TEST EAX,EAX\r\n JE @@exit\r\n@@loop:\r\n MOV EAX,[EAX]\r\n CMP EAX,EDX\r\n JE @@success\r\n MOV EAX,[EAX].vmtParent\r\n TEST EAX,EAX\r\n {$ENDIF CPU32}\r\n {$IFDEF CPU64}\r\n // 64 --> RCX AnObj\r\n // RDX AClass\r\n // <-- AL Result\r\n MOV RAX,RCX\r\n TEST RAX,RAX\r\n JE @@exit\r\n@@loop:\r\n MOV RAX,[RAX]\r\n CMP RAX,RDX\r\n JE @@success\r\n MOV RAX,[RAX].vmtParent\r\n TEST RAX,RAX\r\n {$ENDIF CPU64}\r\n JNE @@loop\r\n JMP @@exit\r\n@@success:\r\n MOV AL,1\r\n@@exit:\r\nend;\r\n\r\nfunction JclIsClassByName(const AnObj: TObject; const AClass: TClass): Boolean;\r\nvar\r\n CurClass: TClass;\r\n CurClass2: TClass;\r\nbegin\r\n Result := AnObj <> nil;\r\n if Result then\r\n begin\r\n CurClass := AnObj.ClassType;\r\n Result := False;\r\n while not Result and (CurClass <> nil) do\r\n begin\r\n Result := CurClass.ClassNameIs(AClass.ClassName);\r\n if not Result then\r\n CurClass := CurClass.ClassParent;\r\n end;\r\n if CurClass <> nil then\r\n CurClass := CurClass.ClassParent;\r\n CurClass2 := AClass.ClassParent;\r\n while Result and (CurClass <> nil) and (CurClass2 <> nil) do\r\n begin\r\n Result := CurClass.ClassNameIs(CurClass2.ClassName);\r\n if Result then\r\n begin\r\n CurClass := CurClass.ClassParent;\r\n CurClass2 := CurClass2.ClassParent;\r\n end;\r\n end;\r\n Result := Result and (CurClass = CurClass2);\r\n end;\r\nend;\r\n\r\nfunction JclAsClass(const AnObj: TObject; const AClass: TClass): TObject;\r\nbegin\r\n if (AnObj = nil) or (AnObj is AClass) then\r\n Result := AnObj\r\n else\r\n raise EInvalidCast.CreateRes(@SInvalidCast);\r\nend;\r\n\r\nfunction GetStringPropList(TypeInfo: PTypeInfo; out PropList: PPropList): Integer;\r\nbegin\r\n PropList := nil;\r\n {$IFDEF SUPPORTS_UNICODE_STRING}\r\n Result := GetPropList(TypeInfo, [tkUString], PropList);\r\n if Result > 0 then\r\n begin\r\n GetMem(PropList, Result * SizeOf(PropList[0]));\r\n Result := GetPropList(TypeInfo, [tkUString], PropList);\r\n end;\r\n {$ELSE ~SUPPORTS_UNICODE_STRING}\r\n Result := GetPropList(TypeInfo, [tkLString], PropList);\r\n if Result > 0 then\r\n begin\r\n GetMem(PropList, Result * SizeOf(PropList[0]));\r\n Result := GetPropList(TypeInfo, [tkLString], PropList);\r\n end;\r\n {$ENDIF ~SUPPORTS_UNICODE_STRING}\r\nend;\r\n\r\nfunction GetObjectProperties(AnObj: TObject; Recurse: Boolean): IJclObjPropInfoArray;\r\n\r\n procedure InternalGetObjectProperties(var PropCount: SizeInt; Current: TObject; const Prefix: string);\r\n var\r\n I, C: Integer;\r\n PropList: PPropList;\r\n SubObject: TObject;\r\n AbsoluteName: string;\r\n begin\r\n if Assigned(Current) then\r\n begin\r\n C := GetPropList(Current, PropList);\r\n try\r\n for I := 0 to C - 1 do\r\n begin\r\n if PropCount = Length(Result) then\r\n SetLength(Result, Length(Result) * 2);\r\n Result[PropCount] := TJclObjPropInfo.Create(PropList[I], Prefix, Current);\r\n Inc(PropCount);\r\n\r\n if Recurse and (PropList[I]^.PropType^.Kind = tkClass) then\r\n begin\r\n SubObject := GetObjectProp(Current, PropList[I]);\r\n if Prefix <> '' then\r\n AbsoluteName := string(Prefix + '.' + string(PropList[I]^.Name))\r\n else\r\n AbsoluteName := string(PropList[I]^.Name);\r\n InternalGetObjectProperties(PropCount, SubObject, AbsoluteName);\r\n end;\r\n end;\r\n finally\r\n if C > 0 then\r\n FreeMem(PropList);\r\n end;\r\n end;\r\n end;\r\n\r\nvar\r\n PropCount: SizeInt;\r\nbegin\r\n PropCount := 0;\r\n SetLength(Result, 16);\r\n InternalGetObjectProperties(PropCount, AnObj, '');\r\n SetLength(Result, PropCount);\r\nend;\r\n\r\ninitialization\r\n TypeList := TThreadList.Create;\r\n {$IFDEF UNITVERSIONING}\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n {$ENDIF UNITVERSIONING}\r\n\r\nfinalization\r\n {$IFDEF UNITVERSIONING}\r\n UnregisterUnitVersion(HInstance);\r\n {$ENDIF UNITVERSIONING}\r\n ClearInfoList;\r\n FreeAndNil(TypeList);\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jcl/source/common/JclResources.pas", "content": "{**************************************************************************************************}\r\n{ }\r\n{ Project JEDI Code Library (JCL) }\r\n{ }\r\n{ The contents of this file are subject to the Mozilla Public License Version 1.1 (the \"License\"); }\r\n{ you may not use this file except in compliance with the License. You may obtain a copy of the }\r\n{ License at http://www.mozilla.org/MPL/ }\r\n{ }\r\n{ Software distributed under the License is distributed on an \"AS IS\" basis, WITHOUT WARRANTY OF }\r\n{ ANY KIND, either express or implied. See the License for the specific language governing rights }\r\n{ and limitations under the License. }\r\n{ }\r\n{ The Original Code is JclResources.pas. }\r\n{ }\r\n{ The Initial Developer of the Original Code is Marcel van Brakel. }\r\n{ Portions created by Marcel van Brakel are Copyright (C) Marcel van Brakel. All rights reserved. }\r\n{ }\r\n{ Contributors: }\r\n{ Alexei Koudinov }\r\n{ Barry Kelly }\r\n{ Flier Lu (flier) }\r\n{ Florent Ouchet (outchy) }\r\n{ Jean-Fabien Connault (cycocrew) }\r\n{ Marcel Bestebroer }\r\n{ Marcel van Brakel }\r\n{ Matthias Thoma (mthoma) }\r\n{ Peter Friese }\r\n{ Petr Vones (pvones) }\r\n{ Raymond Alexander (rayspostbox3) }\r\n{ Robert Marquardt (marquardt) }\r\n{ Robert Rossmair (rrossmair) }\r\n{ Scott Price (scottprice) }\r\n{ Uwe Schuster (uschuster) }\r\n{ }\r\n{**************************************************************************************************}\r\n{ }\r\n{ Unit which provides a central place for all resource strings used in the JCL }\r\n{ }\r\n{**************************************************************************************************}\r\n{ }\r\n{ Last modified: $Date:: 2012-08-28 16:44:17 +0200 (mar. 28 août 2012) $ }\r\n{ Revision: $Rev:: 3850 $ }\r\n{ Author: $Author:: outchy $ }\r\n{ }\r\n{**************************************************************************************************}\r\n\r\nunit JclResources;\r\n\r\n{$I jcl.inc}\r\n\r\ninterface\r\n\r\n{$IFDEF UNITVERSIONING}\r\nuses\r\n JclUnitVersioning;\r\n{$ENDIF UNITVERSIONING}\r\n\r\n//=== JclBase ================================================================\r\nresourcestring\r\n RsCantConvertAddr64 = 'The address %s%.16x cannot be converted to 32 bit';\r\n RsEReplacementChar = 'Failed to get ANSI replacement character';\r\n\r\n//=== JclCharsets ============================================================\r\nresourcestring\r\n RsENoCharset = 'No matching charset';\r\n\r\n//=== JclCIL =================================================================\r\nresourcestring\r\n RsInstructionStreamInvalid = 'Invalid IL instruction stream';\r\n RsCILNamenop = 'nop';\r\n RsCILNamebreak = 'break';\r\n RsCILNameldarg0 = 'ldarg.0';\r\n RsCILNameldarg1 = 'ldarg.1';\r\n RsCILNameldarg2 = 'ldarg.2';\r\n RsCILNameldarg3 = 'ldarg.3';\r\n RsCILNameldloc0 = 'ldloc.0';\r\n RsCILNameldloc1 = 'ldloc.1';\r\n RsCILNameldloc2 = 'ldloc.2';\r\n RsCILNameldloc3 = 'ldloc.3';\r\n RsCILNamestloc0 = 'stloc.0';\r\n RsCILNamestloc1 = 'stloc.1';\r\n RsCILNamestloc2 = 'stloc.2';\r\n RsCILNamestloc3 = 'stloc.3';\r\n RsCILNameldargs = 'ldarg.s';\r\n RsCILNameldargas = 'ldarga.s';\r\n RsCILNamestargs = 'starg.s';\r\n RsCILNameldlocs = 'ldloc.s';\r\n RsCILNameldlocas = 'ldloca.s';\r\n RsCILNamestlocs = 'stloc.s';\r\n RsCILNameldnull = 'ldnull';\r\n RsCILNameldci4m1 = 'ldc.i4.m1';\r\n RsCILNameldci40 = 'ldc.i4.0';\r\n RsCILNameldci41 = 'ldc.i4.1';\r\n RsCILNameldci42 = 'ldc.i4.2';\r\n RsCILNameldci43 = 'ldc.i4.3';\r\n RsCILNameldci44 = 'ldc.i4.4';\r\n RsCILNameldci45 = 'ldc.i4.5';\r\n RsCILNameldci46 = 'ldc.i4.6';\r\n RsCILNameldci47 = 'ldc.i4.7';\r\n RsCILNameldci48 = 'ldc.i4.8';\r\n RsCILNameldci4s = 'ldc.i4.s';\r\n RsCILNameldci4 = 'ldc.i4';\r\n RsCILNameldci8 = 'ldc.i8';\r\n RsCILNameldcr4 = 'ldc.r4';\r\n RsCILNameldcr8 = 'ldc.r8';\r\n RsCILNameunused1 = 'unused';\r\n RsCILNamedup = 'dup';\r\n RsCILNamepop = 'pop';\r\n RsCILNamejmp = 'jmp';\r\n RsCILNamecall = 'call';\r\n RsCILNamecalli = 'calli';\r\n RsCILNameret = 'ret';\r\n RsCILNamebrs = 'br.s';\r\n RsCILNamebrfalses = 'brfalse.s';\r\n RsCILNamebrtrues = 'brtrue.s';\r\n RsCILNamebeqs = 'beq.s';\r\n RsCILNamebges = 'bge.s';\r\n RsCILNamebgts = 'bgt.s';\r\n RsCILNamebles = 'ble.s';\r\n RsCILNameblts = 'blt.s';\r\n RsCILNamebneuns = 'bne.un.s';\r\n RsCILNamebgeuns = 'bge.un.s';\r\n RsCILNamebgtuns = 'bgt.un.s';\r\n RsCILNamebleuns = 'ble.un.s';\r\n RsCILNamebltuns = 'blt.un.s';\r\n RsCILNamebr = 'br';\r\n RsCILNamebrfalse = 'brfalse';\r\n RsCILNamebrtrue = 'brtrue';\r\n RsCILNamebeq = 'beq';\r\n RsCILNamebge = 'bge';\r\n RsCILNamebgt = 'bgt';\r\n RsCILNameble = 'ble';\r\n RsCILNameblt = 'blt';\r\n RsCILNamebneun = 'bne.un';\r\n RsCILNamebgeun = 'bge.un';\r\n RsCILNamebgtun = 'bgt.un';\r\n RsCILNamebleun = 'ble.un';\r\n RsCILNamebltun = 'blt.un';\r\n RsCILNameswitch = 'switch';\r\n RsCILNameldindi1 = 'ldind.i1';\r\n RsCILNameldindu1 = 'ldind.u1';\r\n RsCILNameldindi2 = 'ldind.i2';\r\n RsCILNameldindu2 = 'ldind.u2';\r\n RsCILNameldindi4 = 'ldind.i4';\r\n RsCILNameldindu4 = 'ldind.u4';\r\n RsCILNameldindi8 = 'ldind.i8';\r\n RsCILNameldindi = 'ldind.i';\r\n RsCILNameldindr4 = 'ldind.r4';\r\n RsCILNameldindr8 = 'ldind.r8';\r\n RsCILNameldindref = 'ldind.ref';\r\n RsCILNamestindref = 'stind.ref';\r\n RsCILNamestindi1 = 'stind.i1';\r\n RsCILNamestindi2 = 'stind.i2';\r\n RsCILNamestindi4 = 'stind.i4';\r\n RsCILNamestindi8 = 'stind.i8';\r\n RsCILNamestindr4 = 'stind.r4';\r\n RsCILNamestindr8 = 'stind.r8';\r\n RsCILNameadd = 'add';\r\n RsCILNamesub = 'sub';\r\n RsCILNamemul = 'mul';\r\n RsCILNamediv = 'div';\r\n RsCILNamedivun = 'div.un';\r\n RsCILNamerem = 'rem';\r\n RsCILNameremun = 'rem.un';\r\n RsCILNameand = 'and';\r\n RsCILNameor = 'or';\r\n RsCILNamexor = 'xor';\r\n RsCILNameshl = 'shl';\r\n RsCILNameshr = 'shr';\r\n RsCILNameshrun = 'shr.un';\r\n RsCILNameneg = 'neg';\r\n RsCILNamenot = 'not';\r\n RsCILNameconvi1 = 'conv.i1';\r\n RsCILNameconvi2 = 'conv.i2';\r\n RsCILNameconvi4 = 'conv.i4';\r\n RsCILNameconvi8 = 'conv.i8';\r\n RsCILNameconvr4 = 'conv.r4';\r\n RsCILNameconvr8 = 'conv.r8';\r\n RsCILNameconvu4 = 'conv.u4';\r\n RsCILNameconvu8 = 'conv.u8';\r\n RsCILNamecallvirt = 'callvirt';\r\n RsCILNamecpobj = 'cpobj';\r\n RsCILNameldobj = 'ldobj';\r\n RsCILNameldstr = 'ldstr';\r\n RsCILNamenewobj = 'newobj';\r\n RsCILNamecastclass = 'castclass';\r\n RsCILNameisinst = 'isinst';\r\n RsCILNameconvrun = 'conv.r.un';\r\n RsCILNameunused2 = 'unused';\r\n RsCILNameunused3 = 'unused';\r\n RsCILNameunbox = 'unbox';\r\n RsCILNamethrow = 'throw';\r\n RsCILNameldfld = 'ldfld';\r\n RsCILNameldflda = 'ldflda';\r\n RsCILNamestfld = 'stfld';\r\n RsCILNameldsfld = 'ldsfld';\r\n RsCILNameldsflda = 'ldsflda';\r\n RsCILNamestsfld = 'stsfld';\r\n RsCILNamestobj = 'stobj';\r\n RsCILNameconvovfi1un = 'conv.ovf.i1.un';\r\n RsCILNameconvovfi2un = 'conv.ovf.i2.un';\r\n RsCILNameconvovfi4un = 'conv.ovf.i4.un';\r\n RsCILNameconvovfi8un = 'conv.ovf.i8.un';\r\n RsCILNameconvovfu1un = 'conv.ovf.u1.un';\r\n RsCILNameconvovfu2un = 'conv.ovf.u2.un';\r\n RsCILNameconvovfu4un = 'conv.ovf.u4.un';\r\n RsCILNameconvovfu8un = 'conv.ovf.u8.un';\r\n RsCILNameconvovfiun = 'conv.ovf.i.un';\r\n RsCILNameconvovfuun = 'conv.ovf.u.un';\r\n RsCILNamebox = 'box';\r\n RsCILNamenewarr = 'newarr';\r\n RsCILNameldlen = 'ldlen';\r\n RsCILNameldelema = 'ldelema';\r\n RsCILNameldelemi1 = 'ldelem.i1';\r\n RsCILNameldelemu1 = 'ldelem.u1';\r\n RsCILNameldelemi2 = 'ldelem.i2';\r\n RsCILNameldelemu2 = 'ldelem.u2';\r\n RsCILNameldelemi4 = 'ldelem.i4';\r\n RsCILNameldelemu4 = 'ldelem.u4';\r\n RsCILNameldelemi8 = 'ldelem.i8';\r\n RsCILNameldelemi = 'ldelem.i';\r\n RsCILNameldelemr4 = 'ldelem.r4';\r\n RsCILNameldelemr8 = 'ldelem.r8';\r\n RsCILNameldelemref = 'ldelem.ref';\r\n RsCILNamestelemi = 'stelem.i';\r\n RsCILNamestelemi1 = 'stelem.i1';\r\n RsCILNamestelemi2 = 'stelem.i2';\r\n RsCILNamestelemi4 = 'stelem.i4';\r\n RsCILNamestelemi8 = 'stelem.i8';\r\n RsCILNamestelemr4 = 'stelem.r4';\r\n RsCILNamestelemr8 = 'stelem.r8';\r\n RsCILNamestelemref = 'stelem.ref';\r\n RsCILNameunused4 = 'unused';\r\n RsCILNameunused5 = 'unused';\r\n RsCILNameunused6 = 'unused';\r\n RsCILNameunused7 = 'unused';\r\n RsCILNameunused8 = 'unused';\r\n RsCILNameunused9 = 'unused';\r\n RsCILNameunused10 = 'unused';\r\n RsCILNameunused11 = 'unused';\r\n RsCILNameunused12 = 'unused';\r\n RsCILNameunused13 = 'unused';\r\n RsCILNameunused14 = 'unused';\r\n RsCILNameunused15 = 'unused';\r\n RsCILNameunused16 = 'unused';\r\n RsCILNameunused17 = 'unused';\r\n RsCILNameunused18 = 'unused';\r\n RsCILNameunused19 = 'unused';\r\n RsCILNameconvovfi1 = 'conv.ovf.i1';\r\n RsCILNameconvovfu1 = 'conv.ovf.u1';\r\n RsCILNameconvovfi2 = 'conv.ovf.i2';\r\n RsCILNameconvovfu2 = 'conv.ovf.u2';\r\n RsCILNameconvovfi4 = 'conv.ovf.i4';\r\n RsCILNameconvovfu4 = 'conv.ovf.u4';\r\n RsCILNameconvovfi8 = 'conv.ovf.i8';\r\n RsCILNameconvovfu8 = 'conv.ovf.u8';\r\n RsCILNameunused20 = 'unused';\r\n RsCILNameunused21 = 'unused';\r\n RsCILNameunused22 = 'unused';\r\n RsCILNameunused23 = 'unused';\r\n RsCILNameunused24 = 'unused';\r\n RsCILNameunused25 = 'unused';\r\n RsCILNameunused26 = 'unused';\r\n RsCILNamerefanyval = 'refanyval';\r\n RsCILNameckfinite = 'ckfinite';\r\n RsCILNameunused27 = 'unused';\r\n RsCILNameunused28 = 'unused';\r\n RsCILNamemkrefany = 'mkrefany';\r\n RsCILNameunused29 = 'unused';\r\n RsCILNameunused30 = 'unused';\r\n RsCILNameunused31 = 'unused';\r\n RsCILNameunused32 = 'unused';\r\n RsCILNameunused33 = 'unused';\r\n RsCILNameunused34 = 'unused';\r\n RsCILNameunused35 = 'unused';\r\n RsCILNameunused36 = 'unused';\r\n RsCILNameunused37 = 'unused';\r\n RsCILNameldtoken = 'ldtoken';\r\n RsCILNameconvu2 = 'conv.u2';\r\n RsCILNameconvu1 = 'conv.u1';\r\n RsCILNameconvi = 'conv.i';\r\n RsCILNameconvovfi = 'conv.ovf.i';\r\n RsCILNameconvovfu = 'conv.ovf.u';\r\n RsCILNameaddovf = 'add.ovf';\r\n RsCILNameaddovfun = 'add.ovf.un';\r\n RsCILNamemulovf = 'mul.ovf';\r\n RsCILNamemulovfun = 'mul.ovf.un';\r\n RsCILNamesubovf = 'sub.ovf';\r\n RsCILNamesubovfun = 'sub.ovf.un';\r\n RsCILNameendfinally = 'endfinally';\r\n RsCILNameleave = 'leave';\r\n RsCILNameleaves = 'leave.s';\r\n RsCILNamestindi = 'stind.i';\r\n RsCILNameconvu = 'conv.u';\r\n RsCILNameunused38 = 'unused';\r\n RsCILNameunused39 = 'unused';\r\n RsCILNameunused40 = 'unused';\r\n RsCILNameunused41 = 'unused';\r\n RsCILNameunused42 = 'unused';\r\n RsCILNameunused43 = 'unused';\r\n RsCILNameunused44 = 'unused';\r\n RsCILNameunused45 = 'unused';\r\n RsCILNameunused46 = 'unused';\r\n RsCILNameunused47 = 'unused';\r\n RsCILNameunused48 = 'unused';\r\n RsCILNameunused49 = 'unused';\r\n RsCILNameunused50 = 'unused';\r\n RsCILNameunused51 = 'unused';\r\n RsCILNameunused52 = 'unused';\r\n RsCILNameunused53 = 'unused';\r\n RsCILNameunused54 = 'unused';\r\n RsCILNameunused55 = 'unused';\r\n RsCILNameunused56 = 'unused';\r\n RsCILNameunused57 = 'unused';\r\n RsCILNameunused58 = 'unused';\r\n RsCILNameunused59 = 'unused';\r\n RsCILNameunused60 = 'unused';\r\n RsCILNameprefix7 = 'prefix7';\r\n RsCILNameprefix6 = 'prefix6';\r\n RsCILNameprefix5 = 'prefix5';\r\n RsCILNameprefix4 = 'prefix4';\r\n RsCILNameprefix3 = 'prefix3';\r\n RsCILNameprefix2 = 'prefix2';\r\n RsCILNameprefix1 = 'prefix1';\r\n RsCILNameprefixref = 'prefixref';\r\n RsCILNamearglist = 'arglist';\r\n RsCILNameceq = 'ceq';\r\n RsCILNamecgt = 'cgt';\r\n RsCILNamecgtun = 'cgt.un';\r\n RsCILNameclt = 'clt';\r\n RsCILNamecltun = 'clt.un';\r\n RsCILNameldftn = 'ldftn';\r\n RsCILNameldvirtftn = 'ldvirtftn';\r\n RsCILNameunused61 = 'unused';\r\n RsCILNameldarg = 'ldarg';\r\n RsCILNameldarga = 'ldarga';\r\n RsCILNamestarg = 'starg';\r\n RsCILNameldloc = 'ldloc';\r\n RsCILNameldloca = 'ldloca';\r\n RsCILNamestloc = 'stloc';\r\n RsCILNamelocalloc = 'localloc';\r\n RsCILNameunused62 = 'unused';\r\n RsCILNameendfilter = 'endfilter';\r\n RsCILNameunaligned = 'unaligned.';\r\n RsCILNamevolatile = 'volatile.';\r\n RsCILNametail = 'tail.';\r\n RsCILNameinitobj = 'initobj';\r\n RsCILNameunused63 = 'unused';\r\n RsCILNamecpblk = 'cpblk';\r\n RsCILNameinitblk = 'initblk';\r\n RsCILNameunused64 = 'unused';\r\n RsCILNamerethrow = 'rethrow';\r\n RsCILNameunused65 = 'unused';\r\n RsCILNamesizeof = 'sizeof';\r\n RsCILNamerefanytype = 'refanytype';\r\n RsCILNameunused66 = 'unused';\r\n RsCILNameunused67 = 'unused';\r\n RsCILNameunused68 = 'unused';\r\n RsCILNameunused69 = 'unused';\r\n RsCILNameunused70 = 'unused';\r\n\r\n RsCILCmdnop = 'no operation';\r\n RsCILCmdbreak = 'breakpoint instruction';\r\n RsCILCmdldarg0 = 'load argument onto the stack';\r\n RsCILCmdldarg1 = 'load argument onto the stack';\r\n RsCILCmdldarg2 = 'load argument onto the stack';\r\n RsCILCmdldarg3 = 'load argument onto the stack';\r\n RsCILCmdldloc0 = 'load local variable onto the stack';\r\n RsCILCmdldloc1 = 'load local variable onto the stack';\r\n RsCILCmdldloc2 = 'load local variable onto the stack';\r\n RsCILCmdldloc3 = 'load local variable onto the stack';\r\n RsCILCmdstloc0 = 'pop value from stack to local variable';\r\n RsCILCmdstloc1 = 'pop value from stack to local variable';\r\n RsCILCmdstloc2 = 'pop value from stack to local variable';\r\n RsCILCmdstloc3 = 'pop value from stack to local variable';\r\n RsCILCmdldargs = 'load argument onto the stack';\r\n RsCILCmdldargas = 'load an argument address';\r\n RsCILCmdstargs = 'store a value in an argument slot';\r\n RsCILCmdldlocs = 'load local variable onto the stack';\r\n RsCILCmdldlocas = 'load local variable address';\r\n RsCILCmdstlocs = 'pop value from stack to local variable';\r\n RsCILCmdldnull = 'load a null pointer';\r\n RsCILCmdldci4m1 = 'load numeric constant';\r\n RsCILCmdldci40 = 'load numeric constant';\r\n RsCILCmdldci41 = 'load numeric constant';\r\n RsCILCmdldci42 = 'load numeric constant';\r\n RsCILCmdldci43 = 'load numeric constant';\r\n RsCILCmdldci44 = 'load numeric constant';\r\n RsCILCmdldci45 = 'load numeric constant';\r\n RsCILCmdldci46 = 'load numeric constant';\r\n RsCILCmdldci47 = 'load numeric constant';\r\n RsCILCmdldci48 = 'load numeric constant';\r\n RsCILCmdldci4s = 'load numeric constant';\r\n RsCILCmdldci4 = 'load numeric constant';\r\n RsCILCmdldci8 = 'load numeric constant';\r\n RsCILCmdldcr4 = 'load numeric constant';\r\n RsCILCmdldcr8 = 'load numeric constant';\r\n RsCILCmdunused1 = '';\r\n RsCILCmddup = 'duplicate the top value of the stack';\r\n RsCILCmdpop = 'remove the top element of the stack';\r\n RsCILCmdjmp = 'jump to method';\r\n RsCILCmdcall = 'call a method';\r\n RsCILCmdcalli = 'indirect method call';\r\n RsCILCmdret = 'return from method';\r\n RsCILCmdbrs = 'unconditional branch';\r\n RsCILCmdbrfalses = 'branch on false, null, or zero';\r\n RsCILCmdbrtrues = 'branch on non-false or non-null';\r\n RsCILCmdbeqs = 'branch on equal';\r\n RsCILCmdbges = 'branch on greater than or equal to';\r\n RsCILCmdbgts = 'branch on greater than';\r\n RsCILCmdbles = 'branch on less than or equal to';\r\n RsCILCmdblts = 'branch on less than';\r\n RsCILCmdbneuns = 'branch on not equal or unordered';\r\n RsCILCmdbgeuns = 'branch on greater than or equal to, unsigned or unordered';\r\n RsCILCmdbgtuns = 'branch on greater than, unsigned or unordered';\r\n RsCILCmdbleuns = 'branch on less than or equal to, unsigned or unordered';\r\n RsCILCmdbltuns = 'branch on less than, unsigned or unordered';\r\n RsCILCmdbr = 'unconditional branch';\r\n RsCILCmdbrfalse = 'branch on false, null, or zero';\r\n RsCILCmdbrtrue = 'branch on non-false or non-null';\r\n RsCILCmdbeq = 'branch on equal';\r\n RsCILCmdbge = 'branch on greater than or equal to';\r\n RsCILCmdbgt = 'branch on greater than';\r\n RsCILCmdble = 'branch on less than or equal to';\r\n RsCILCmdblt = 'branch on less than';\r\n RsCILCmdbneun = 'branch on not equal or unordered';\r\n RsCILCmdbgeun = 'branch on greater than or equal to, unsigned or unordered';\r\n RsCILCmdbgtun = 'branch on greater than, unsigned or unordered';\r\n RsCILCmdbleun = 'branch on less than or equal to, unsigned or unordered';\r\n RsCILCmdbltun = 'branch on less than, unsigned or unordered';\r\n RsCILCmdswitch = 'table switch on value';\r\n RsCILCmdldindi1 = 'load value indirect onto the stack';\r\n RsCILCmdldindu1 = 'load value indirect onto the stack';\r\n RsCILCmdldindi2 = 'load value indirect onto the stack';\r\n RsCILCmdldindu2 = 'load value indirect onto the stack';\r\n RsCILCmdldindi4 = 'load value indirect onto the stack';\r\n RsCILCmdldindu4 = 'load value indirect onto the stack';\r\n RsCILCmdldindi8 = 'load value indirect onto the stack';\r\n RsCILCmdldindi = 'load value indirect onto the stack';\r\n RsCILCmdldindr4 = 'load value indirect onto the stack';\r\n RsCILCmdldindr8 = 'load value indirect onto the stack';\r\n RsCILCmdldindref = 'load value indirect onto the stack';\r\n RsCILCmdstindref = 'store value indirect from stack';\r\n RsCILCmdstindi1 = 'store value indirect from stack';\r\n RsCILCmdstindi2 = 'store value indirect from stack';\r\n RsCILCmdstindi4 = 'store value indirect from stack';\r\n RsCILCmdstindi8 = 'store value indirect from stack';\r\n RsCILCmdstindr4 = 'store value indirect from stack';\r\n RsCILCmdstindr8 = 'store value indirect from stack';\r\n RsCILCmdadd = 'add numeric values';\r\n RsCILCmdsub = 'subtract numeric values';\r\n RsCILCmdmul = 'multiply values';\r\n RsCILCmddiv = 'divide values';\r\n RsCILCmddivun = 'divide integer values, unsigned';\r\n RsCILCmdrem = 'compute remainder';\r\n RsCILCmdremun = 'compute integer remainder, unsigned';\r\n RsCILCmdand = 'bitwise AND';\r\n RsCILCmdor = 'bitwise OR';\r\n RsCILCmdxor = 'bitwise XOR';\r\n RsCILCmdshl = 'shift integer left';\r\n RsCILCmdshr = 'shift integer right';\r\n RsCILCmdshrun = 'shift integer right, unsigned';\r\n RsCILCmdneg = 'negate';\r\n RsCILCmdnot = 'bitwise complement';\r\n RsCILCmdconvi1 = 'data conversion';\r\n RsCILCmdconvi2 = 'data conversion';\r\n RsCILCmdconvi4 = 'data conversion';\r\n RsCILCmdconvi8 = 'data conversion';\r\n RsCILCmdconvr4 = 'data conversion';\r\n RsCILCmdconvr8 = 'data conversion';\r\n RsCILCmdconvu4 = 'data conversion';\r\n RsCILCmdconvu8 = 'data conversion';\r\n RsCILCmdcallvirt = 'call a method associated, at runtime, with an object';\r\n RsCILCmdcpobj = 'copy a value type';\r\n RsCILCmdldobj = 'copy value type to the stack';\r\n RsCILCmdldstr = 'load a literal string';\r\n RsCILCmdnewobj = 'create a new object';\r\n RsCILCmdcastclass = 'cast an object to a class';\r\n RsCILCmdisinst = 'test if an object is an instance of a class or interface';\r\n RsCILCmdconvrun = 'data conversion';\r\n RsCILCmdunused2 = '';\r\n RsCILCmdunused3 = '';\r\n RsCILCmdunbox = 'Convert boxed value type to its raw form';\r\n RsCILCmdthrow = 'throw an exception';\r\n RsCILCmdldfld = 'load field of an object';\r\n RsCILCmdldflda = 'load field address';\r\n RsCILCmdstfld = 'store into a field of an object';\r\n RsCILCmdldsfld = 'load static field of a class';\r\n RsCILCmdldsflda = 'load static field address';\r\n RsCILCmdstsfld = 'store a static field of a class';\r\n RsCILCmdstobj = 'store a value type from the stack into memory';\r\n RsCILCmdconvovfi1un = 'unsigned data conversion with overflow detection';\r\n RsCILCmdconvovfi2un = 'unsigned data conversion with overflow detection';\r\n RsCILCmdconvovfi4un = 'unsigned data conversion with overflow detection';\r\n RsCILCmdconvovfi8un = 'unsigned data conversion with overflow detection';\r\n RsCILCmdconvovfu1un = 'unsigned data conversion with overflow detection';\r\n RsCILCmdconvovfu2un = 'unsigned data conversion with overflow detection';\r\n RsCILCmdconvovfu4un = 'unsigned data conversion with overflow detection';\r\n RsCILCmdconvovfu8un = 'unsigned data conversion with overflow detection';\r\n RsCILCmdconvovfiun = 'unsigned data conversion with overflow detection';\r\n RsCILCmdconvovfuun = 'unsigned data conversion with overflow detection';\r\n RsCILCmdbox = 'convert value type to object reference';\r\n RsCILCmdnewarr = 'create a zero-based, one-dimensional array';\r\n RsCILCmdldlen = 'load the length of an array';\r\n RsCILCmdldelema = 'load address of an element of an array';\r\n RsCILCmdldelemi1 = 'load an element of an array';\r\n RsCILCmdldelemu1 = 'load an element of an array';\r\n RsCILCmdldelemi2 = 'load an element of an array';\r\n RsCILCmdldelemu2 = 'load an element of an array';\r\n RsCILCmdldelemi4 = 'load an element of an array';\r\n RsCILCmdldelemu4 = 'load an element of an array';\r\n RsCILCmdldelemi8 = 'load an element of an array';\r\n RsCILCmdldelemi = 'load an element of an array';\r\n RsCILCmdldelemr4 = 'load an element of an array';\r\n RsCILCmdldelemr8 = 'load an element of an array';\r\n RsCILCmdldelemref = 'load an element of an array';\r\n RsCILCmdstelemi = 'store an element of an array';\r\n RsCILCmdstelemi1 = 'store an element of an array';\r\n RsCILCmdstelemi2 = 'store an element of an array';\r\n RsCILCmdstelemi4 = 'store an element of an array';\r\n RsCILCmdstelemi8 = 'store an element of an array';\r\n RsCILCmdstelemr4 = 'store an element of an array';\r\n RsCILCmdstelemr8 = 'store an element of an array';\r\n RsCILCmdstelemref = 'store an element of an array';\r\n RsCILCmdunused4 = '';\r\n RsCILCmdunused5 = '';\r\n RsCILCmdunused6 = '';\r\n RsCILCmdunused7 = '';\r\n RsCILCmdunused8 = '';\r\n RsCILCmdunused9 = '';\r\n RsCILCmdunused10 = '';\r\n RsCILCmdunused11 = '';\r\n RsCILCmdunused12 = '';\r\n RsCILCmdunused13 = '';\r\n RsCILCmdunused14 = '';\r\n RsCILCmdunused15 = '';\r\n RsCILCmdunused16 = '';\r\n RsCILCmdunused17 = '';\r\n RsCILCmdunused18 = '';\r\n RsCILCmdunused19 = '';\r\n RsCILCmdconvovfi1 = 'data conversion with overflow detection';\r\n RsCILCmdconvovfu1 = 'data conversion with overflow detection';\r\n RsCILCmdconvovfi2 = 'data conversion with overflow detection';\r\n RsCILCmdconvovfu2 = 'data conversion with overflow detection';\r\n RsCILCmdconvovfi4 = 'data conversion with overflow detection';\r\n RsCILCmdconvovfu4 = 'data conversion with overflow detection';\r\n RsCILCmdconvovfi8 = 'data conversion with overflow detection';\r\n RsCILCmdconvovfu8 = 'data conversion with overflow detection';\r\n RsCILCmdunused20 = '';\r\n RsCILCmdunused21 = '';\r\n RsCILCmdunused22 = '';\r\n RsCILCmdunused23 = '';\r\n RsCILCmdunused24 = '';\r\n RsCILCmdunused25 = '';\r\n RsCILCmdunused26 = '';\r\n RsCILCmdrefanyval = 'load the address out of a typed reference';\r\n RsCILCmdckfinite = 'check for a finite real number';\r\n RsCILCmdunused27 = '';\r\n RsCILCmdunused28 = '';\r\n RsCILCmdmkrefany = 'push a typed reference on the stack';\r\n RsCILCmdunused29 = '';\r\n RsCILCmdunused30 = '';\r\n RsCILCmdunused31 = '';\r\n RsCILCmdunused32 = '';\r\n RsCILCmdunused33 = '';\r\n RsCILCmdunused34 = '';\r\n RsCILCmdunused35 = '';\r\n RsCILCmdunused36 = '';\r\n RsCILCmdunused37 = '';\r\n RsCILCmdldtoken = 'load the runtime representation of a metadata token';\r\n RsCILCmdconvu2 = 'data conversion';\r\n RsCILCmdconvu1 = 'data conversion';\r\n RsCILCmdconvi = 'data conversion';\r\n RsCILCmdconvovfi = 'data conversion with overflow detection';\r\n RsCILCmdconvovfu = 'data conversion with overflow detection';\r\n RsCILCmdaddovf = 'add integer values with overflow check';\r\n RsCILCmdaddovfun = 'add integer values with overflow check';\r\n RsCILCmdmulovf = 'multiply integer values with overflow check';\r\n RsCILCmdmulovfun = 'multiply integer values with overflow check';\r\n RsCILCmdsubovf = 'subtract integer values, checking for overflow';\r\n RsCILCmdsubovfun = 'subtract integer values, checking for overflow';\r\n RsCILCmdendfinally = 'end the finally or fault clause of an exception block';\r\n RsCILCmdleave = 'exit a protected region of code';\r\n RsCILCmdleaves = 'exit a protected region of code';\r\n RsCILCmdstindi = 'store value indirect from stack';\r\n RsCILCmdconvu = 'data conversion';\r\n RsCILCmdunused38 = '';\r\n RsCILCmdunused39 = '';\r\n RsCILCmdunused40 = '';\r\n RsCILCmdunused41 = '';\r\n RsCILCmdunused42 = '';\r\n RsCILCmdunused43 = '';\r\n RsCILCmdunused44 = '';\r\n RsCILCmdunused45 = '';\r\n RsCILCmdunused46 = '';\r\n RsCILCmdunused47 = '';\r\n RsCILCmdunused48 = '';\r\n RsCILCmdunused49 = '';\r\n RsCILCmdunused50 = '';\r\n RsCILCmdunused51 = '';\r\n RsCILCmdunused52 = '';\r\n RsCILCmdunused53 = '';\r\n RsCILCmdunused54 = '';\r\n RsCILCmdunused55 = '';\r\n RsCILCmdunused56 = '';\r\n RsCILCmdunused57 = '';\r\n RsCILCmdunused58 = '';\r\n RsCILCmdunused59 = '';\r\n RsCILCmdunused60 = '';\r\n RsCILCmdprefix7 = '';\r\n RsCILCmdprefix6 = '';\r\n RsCILCmdprefix5 = '';\r\n RsCILCmdprefix4 = '';\r\n RsCILCmdprefix3 = '';\r\n RsCILCmdprefix2 = '';\r\n RsCILCmdprefix1 = '';\r\n RsCILCmdprefixref = '';\r\n RsCILCmdarglist = 'get argument list';\r\n RsCILCmdceq = 'compare equal';\r\n RsCILCmdcgt = 'compare greater than';\r\n RsCILCmdcgtun = 'compare greater than, unsigned or unordered';\r\n RsCILCmdclt = 'compare less than';\r\n RsCILCmdcltun = 'compare less than, unsigned or unordered';\r\n RsCILCmdldftn = 'load method pointer';\r\n RsCILCmdldvirtftn = 'load a virtual method pointer';\r\n RsCILCmdunused61 = '';\r\n RsCILCmdldarg = 'load argument onto the stack';\r\n RsCILCmdldarga = 'load an argument address';\r\n RsCILCmdstarg = 'store a value in an argument slot';\r\n RsCILCmdldloc = 'load local variable onto the stack';\r\n RsCILCmdldloca = 'load local variable address';\r\n RsCILCmdstloc = 'pop value from stack to local variable';\r\n RsCILCmdlocalloc = 'allocate space in the local dynamic memory pool';\r\n RsCILCmdunused62 = '';\r\n RsCILCmdendfilter = 'end filter clause of SEH';\r\n RsCILCmdunaligned = 'pointer instruction may be unaligned';\r\n RsCILCmdvolatile = 'pointer reference is volatile';\r\n RsCILCmdtail = 'call terminates current method';\r\n RsCILCmdinitobj = 'initialize a value type';\r\n RsCILCmdunused63 = '';\r\n RsCILCmdcpblk = 'copy data from memory to memory';\r\n RsCILCmdinitblk = 'initialize a block of memory to a value';\r\n RsCILCmdunused64 = '';\r\n RsCILCmdrethrow = 'rethrow the current exception';\r\n RsCILCmdunused65 = '';\r\n RsCILCmdsizeof = 'load the size in bytes of a value type';\r\n RsCILCmdrefanytype = 'load the type out of a typed reference';\r\n RsCILCmdunused66 = '';\r\n RsCILCmdunused67 = '';\r\n RsCILCmdunused68 = '';\r\n RsCILCmdunused69 = '';\r\n RsCILCmdunused70 = '';\r\n\r\n RsCILDescrnop = 'Do nothing';\r\n RsCILDescrbreak = 'inform a debugger that a breakpoint has been reached.';\r\n RsCILDescrldarg0 = 'Load argument 0 onto stack';\r\n RsCILDescrldarg1 = 'Load argument 1 onto stack';\r\n RsCILDescrldarg2 = 'Load argument 2 onto stack';\r\n RsCILDescrldarg3 = 'Load argument 3 onto stack';\r\n RsCILDescrldloc0 = 'Load local variable 0 onto stack.';\r\n RsCILDescrldloc1 = 'Load local variable 1 onto stack.';\r\n RsCILDescrldloc2 = 'Load local variable 2 onto stack.';\r\n RsCILDescrldloc3 = 'Load local variable 3 onto stack.';\r\n RsCILDescrstloc0 = 'Pop value from stack into local variable 0.';\r\n RsCILDescrstloc1 = 'Pop value from stack into local variable 1.';\r\n RsCILDescrstloc2 = 'Pop value from stack into local variable 2.';\r\n RsCILDescrstloc3 = 'Pop value from stack into local variable 3.';\r\n RsCILDescrldargs = 'Load argument numbered num onto stack, short form.';\r\n RsCILDescrldargas = 'fetch the address of argument argNum, short form';\r\n RsCILDescrstargs = 'Store a value to the argument numbered num, short form';\r\n RsCILDescrldlocs = 'Load local variable of index indx onto stack, short form.';\r\n RsCILDescrldlocas = 'Load address of local variable with index indx, short form';\r\n RsCILDescrstlocs = 'Pop value from stack into local variable indx, short form.';\r\n RsCILDescrldnull = 'Push null reference on the stack';\r\n RsCILDescrldci4m1 = 'Push -1 onto the stack as int32.';\r\n RsCILDescrldci40 = 'Push 0 onto the stack as int32.';\r\n RsCILDescrldci41 = 'Push 1 onto the stack as int32.';\r\n RsCILDescrldci42 = 'Push 2 onto the stack as int32.';\r\n RsCILDescrldci43 = 'Push 3 onto the stack as int32.';\r\n RsCILDescrldci44 = 'Push 4 onto the stack as int32.';\r\n RsCILDescrldci45 = 'Push 5 onto the stack as int32.';\r\n RsCILDescrldci46 = 'Push 6 onto the stack as int32.';\r\n RsCILDescrldci47 = 'Push 7 onto the stack as int32.';\r\n RsCILDescrldci48 = 'Push 8 onto the stack as int32.';\r\n RsCILDescrldci4s = 'Push num onto the stack as int32, short form.';\r\n RsCILDescrldci4 = 'Push num of type int32 onto the stack as int32.';\r\n RsCILDescrldci8 = 'Push num of type int64 onto the stack as int64.';\r\n RsCILDescrldcr4 = 'Push num of type float32 onto the stack as F.';\r\n RsCILDescrldcr8 = 'Push num of type float64 onto the stack as F.';\r\n RsCILDescrunused1 = '';\r\n RsCILDescrdup = 'duplicate value on the top of the stack';\r\n RsCILDescrpop = 'pop a value from the stack';\r\n RsCILDescrjmp = 'Exit current method and jump to specified method';\r\n RsCILDescrcall = 'Call method described by method';\r\n RsCILDescrcalli = 'Call method indicated on the stack with arguments described by callsitedescr.';\r\n RsCILDescrret = 'Return from method, possibly returning a value';\r\n RsCILDescrbrs = 'branch to target, short form';\r\n RsCILDescrbrfalses = 'branch to target if value is zero (false), short form';\r\n RsCILDescrbrtrues = 'branch to target if value is non-zero (true), short form';\r\n RsCILDescrbeqs = 'branch to target if equal, short form';\r\n RsCILDescrbges = 'branch to target if greater than or equal to, short form';\r\n RsCILDescrbgts = 'branch to target if greater than, short form';\r\n RsCILDescrbles = 'branch to target if less than or equal to, short form';\r\n RsCILDescrblts = 'branch to target if less than';\r\n RsCILDescrbneuns = 'branch to target if unequal or unordered, short form';\r\n RsCILDescrbgeuns = 'branch to target if greater than or equal to (unsigned or unordered), short form';\r\n RsCILDescrbgtuns = 'branch to target if greater than (unsigned or unordered), short form';\r\n RsCILDescrbleuns = 'branch to target if less than or equal to (unsigned or unordered), short form';\r\n RsCILDescrbltuns = 'Branch to target if less than (unsigned or unordered), short form';\r\n RsCILDescrbr = 'branch to target ';\r\n RsCILDescrbrfalse = 'branch to target if value is zero (false)';\r\n RsCILDescrbrtrue = 'branch to target if value is non-zero (true)';\r\n RsCILDescrbeq = 'branch to target if equal';\r\n RsCILDescrbge = 'branch to target if greater than or equal to';\r\n RsCILDescrbgt = 'branch to target if greater than';\r\n RsCILDescrble = 'branch to target if less than or equal to';\r\n RsCILDescrblt = 'branch to target if less than';\r\n RsCILDescrbneun = 'branch to target if unequal or unordered';\r\n RsCILDescrbgeun = 'branch to target if greater than or equal to (unsigned or unordered)';\r\n RsCILDescrbgtun = 'branch to target if greater than (unsigned or unordered)';\r\n RsCILDescrbleun = 'branch to target if less than or equal to (unsigned or unordered)';\r\n RsCILDescrbltun = 'Branch to target if less than (unsigned or unordered) ';\r\n RsCILDescrswitch = 'jump to one of n values';\r\n RsCILDescrldindi1 = 'Indirect load value of type int8 as int32 on the stack.';\r\n RsCILDescrldindu1 = 'Indirect load value of type unsigned int8 as int32 on the stack.';\r\n RsCILDescrldindi2 = 'Indirect load value of type int16 as int32 on the stack.';\r\n RsCILDescrldindu2 = 'Indirect load value of type unsigned int16 as int32 on the stack.';\r\n RsCILDescrldindi4 = 'Indirect load value of type int32 as int32 on the stack.';\r\n RsCILDescrldindu4 = 'Indirect load value of type unsigned int32 as int32 on the stack.';\r\n RsCILDescrldindi8 = 'Indirect load value of type int64 as int64 on the stack.';\r\n RsCILDescrldindi = 'Indirect load value of type native int as native int on the stack';\r\n RsCILDescrldindr4 = 'Indirect load value of type float32 as F on the stack.';\r\n RsCILDescrldindr8 = 'Indirect load value of type float64 as F on the stack.';\r\n RsCILDescrldindref = 'Indirect load value of type object ref as O on the stack.';\r\n RsCILDescrstindref = 'Store value of type object ref (type O) into memory at address';\r\n RsCILDescrstindi1 = 'Store value of type int8 into memory at address';\r\n RsCILDescrstindi2 = 'Store value of type int16 into memory at address';\r\n RsCILDescrstindi4 = 'Store value of type int32 into memory at address';\r\n RsCILDescrstindi8 = 'Store value of type int64 into memory at address';\r\n RsCILDescrstindr4 = 'Store value of type float32 into memory at address';\r\n RsCILDescrstindr8 = 'Store value of type float64 into memory at address';\r\n RsCILDescradd = 'Add two values, returning a new value';\r\n RsCILDescrsub = 'Subtract value2 from value1, returning a new value';\r\n RsCILDescrmul = 'Multiply values';\r\n RsCILDescrdiv = 'Divide two values to return a quotient or floating-point result';\r\n RsCILDescrdivun = 'Divide two values, unsigned, returning a quotient';\r\n RsCILDescrrem = 'Remainder of dividing value1 by value2';\r\n RsCILDescrremun = 'Remainder of unsigned dividing value1 by value2';\r\n RsCILDescrand = 'Bitwise AND of two integral values, returns an integral value';\r\n RsCILDescror = 'Bitwise OR of two integer values, returns an integer.';\r\n RsCILDescrxor = 'Bitwise XOR of integer values, returns an integer';\r\n RsCILDescrshl = 'Shift an integer to the left (shifting in zeros)';\r\n RsCILDescrshr = 'Shift an integer right, (shift in sign), return an integer';\r\n RsCILDescrshrun = 'Shift an integer right, (shift in zero), return an integer';\r\n RsCILDescrneg = 'Negate value';\r\n RsCILDescrnot = 'Bitwise complement';\r\n RsCILDescrconvi1 = 'Convert to int8, pushing int32 on stack';\r\n RsCILDescrconvi2 = 'Convert to int16, pushing int32 on stack';\r\n RsCILDescrconvi4 = 'Convert to int32, pushing int32 on stack';\r\n RsCILDescrconvi8 = 'Convert to int64, pushing int64 on stack';\r\n RsCILDescrconvr4 = 'Convert to float32, pushing F on stack';\r\n RsCILDescrconvr8 = 'Convert to float64, pushing F on stack';\r\n RsCILDescrconvu4 = 'Convert to unsigned int32, pushing int32 on stack';\r\n RsCILDescrconvu8 = 'Convert to unsigned int64, pushing int64 on stack';\r\n RsCILDescrcallvirt = 'Call a method associated with obj';\r\n RsCILDescrcpobj = 'Copy a value type from srcValObj to destValObj';\r\n RsCILDescrldobj = 'Copy instance of value type classTok to the stack.';\r\n RsCILDescrldstr = 'push a string object for the literal string ';\r\n RsCILDescrnewobj = 'allocate an uninitialized object or value type and call ctor ';\r\n RsCILDescrcastclass = 'Cast obj to class';\r\n RsCILDescrisinst = 'test if object is an instance of class, returning NULL or an instance of that class or interface';\r\n RsCILDescrconvrun = 'Convert unsigned integer to floating-point, pushing F on stack';\r\n RsCILDescrunused2 = '';\r\n RsCILDescrunused3 = '';\r\n RsCILDescrunbox = 'Extract the value type data from obj, its boxed representation';\r\n RsCILDescrthrow = 'Throw an exception';\r\n RsCILDescrldfld = 'Push the value of field of object, or value type, obj, onto the stack';\r\n RsCILDescrldflda = 'Push the address of field of object obj on the stack';\r\n RsCILDescrstfld = 'Replace the value of field of the object obj with val';\r\n RsCILDescrldsfld = 'Push the value of field on the stack';\r\n RsCILDescrldsflda = 'Push the address of the static field, field, on the stack';\r\n RsCILDescrstsfld = 'Replace the value of field with val';\r\n RsCILDescrstobj = 'Store a value of type classTok from the stack into memory';\r\n RsCILDescrconvovfi1un = 'Convert unsigned to an int8 (on the stack as int32) and throw an exception on overflow';\r\n RsCILDescrconvovfi2un = 'Convert unsigned to an int16 (on the stack as int32) and throw an exception on overflow';\r\n RsCILDescrconvovfi4un = 'Convert unsigned to an int32 (on the stack as int32) and throw an exception on overflow';\r\n RsCILDescrconvovfi8un = 'Convert unsigned to an int64 (on the stack as int64) and throw an exception on overflow';\r\n RsCILDescrconvovfu1un = 'Convert unsigned to an unsigned int8 (on the stack as int32) and throw an exception on overflow';\r\n RsCILDescrconvovfu2un = 'Convert unsigned to an unsigned int16 (on the stack as int32) and throw an exception on overflow';\r\n RsCILDescrconvovfu4un = 'Convert unsigned to an unsigned int32 (on the stack as int32) and throw an exception on overflow';\r\n RsCILDescrconvovfu8un = 'Convert unsigned to an unsigned int64 (on the stack as int64) and throw an exception on overflow';\r\n RsCILDescrconvovfiun = 'Convert unsigned to a native int (on the stack as native int) and throw an exception on overflow';\r\n RsCILDescrconvovfuun = 'Convert unsigned to a native unsigned int (on the stack as native int) and throw an exception on overflow';\r\n RsCILDescrbox = 'Convert valueType to a true object reference';\r\n RsCILDescrnewarr = 'create a new array with elements of type etype';\r\n RsCILDescrldlen = 'push the length (of type native unsigned int) of array on the stack';\r\n RsCILDescrldelema = 'Load the address of element at index onto the top of the stack';\r\n RsCILDescrldelemi1 = 'Load the element with type int8 at index onto the top of the stack as an int32';\r\n RsCILDescrldelemu1 = 'Load the element with type unsigned int8 at index onto the top of the stack as an int32';\r\n RsCILDescrldelemi2 = 'Load the element with type int16 at index onto the top of the stack as an int32';\r\n RsCILDescrldelemu2 = 'Load the element with type unsigned int16 at index onto the top of the stack as an int32';\r\n RsCILDescrldelemi4 = 'Load the element with type int32 at index onto the top of the stack as an int32';\r\n RsCILDescrldelemu4 = 'Load the element with type unsigned int32 at index onto the top of the stack as an int32 (alias for ldelem.i4)';\r\n RsCILDescrldelemi8 = 'Load the element with type int64 at index onto the top of the stack as an int64';\r\n RsCILDescrldelemi = 'Load the element with type native int at index onto the top of the stack as an native int';\r\n RsCILDescrldelemr4 = 'Load the element with type float32 at index onto the top of the stack as an F';\r\n RsCILDescrldelemr8 = 'Load the element with type float64 at index onto the top of the stack as an F';\r\n RsCILDescrldelemref = 'Load the element of type object, at index onto the top of the stack as an O';\r\n RsCILDescrstelemi = 'Replace array element at index with the i value on the stack';\r\n RsCILDescrstelemi1 = 'Replace array element at index with the int8 value on the stack';\r\n RsCILDescrstelemi2 = 'Replace array element at index with the int16 value on the stack';\r\n RsCILDescrstelemi4 = 'Replace array element at index with the int32 value on the stack';\r\n RsCILDescrstelemi8 = 'Replace array element at index with the int64 value on the stack';\r\n RsCILDescrstelemr4 = 'Replace array element at index with the float32 value on the stack';\r\n RsCILDescrstelemr8 = 'Replace array element at index with the float64 value on the stack';\r\n RsCILDescrstelemref = 'Replace array element at index with the ref value on the stack';\r\n RsCILDescrunused4 = '';\r\n RsCILDescrunused5 = '';\r\n RsCILDescrunused6 = '';\r\n RsCILDescrunused7 = '';\r\n RsCILDescrunused8 = '';\r\n RsCILDescrunused9 = '';\r\n RsCILDescrunused10 = '';\r\n RsCILDescrunused11 = '';\r\n RsCILDescrunused12 = '';\r\n RsCILDescrunused13 = '';\r\n RsCILDescrunused14 = '';\r\n RsCILDescrunused15 = '';\r\n RsCILDescrunused16 = '';\r\n RsCILDescrunused17 = '';\r\n RsCILDescrunused18 = '';\r\n RsCILDescrunused19 = '';\r\n RsCILDescrconvovfi1 = 'Convert to an int8 (on the stack as int32) and throw an exception on overflow ';\r\n RsCILDescrconvovfu1 = 'Convert to a unsigned int8 (on the stack as int32) and throw an exception on overflow ';\r\n RsCILDescrconvovfi2 = 'Convert to an int16 (on the stack as int32) and throw an exception on overflow ';\r\n RsCILDescrconvovfu2 = 'Convert to a unsigned int16 (on the stack as int32) and throw an exception on overflow ';\r\n RsCILDescrconvovfi4 = 'Convert to an int32 (on the stack as int32) and throw an exception on overflow ';\r\n RsCILDescrconvovfu4 = 'Convert to a unsigned int32 (on the stack as int32) and throw an exception on overflow ';\r\n RsCILDescrconvovfi8 = 'Convert to an int64 (on the stack as int64) and throw an exception on overflow ';\r\n RsCILDescrconvovfu8 = 'Convert to a unsigned int64 (on the stack as int64) and throw an exception on overflow ';\r\n RsCILDescrunused20 = '';\r\n RsCILDescrunused21 = '';\r\n RsCILDescrunused22 = '';\r\n RsCILDescrunused23 = '';\r\n RsCILDescrunused24 = '';\r\n RsCILDescrunused25 = '';\r\n RsCILDescrunused26 = '';\r\n RsCILDescrrefanyval = 'Push the address stored in a typed reference';\r\n RsCILDescrckfinite = 'throw ArithmeticException if value is not a finite number';\r\n RsCILDescrunused27 = '';\r\n RsCILDescrunused28 = '';\r\n RsCILDescrmkrefany = 'push a typed reference to ptr of type class onto the stack';\r\n RsCILDescrunused29 = '';\r\n RsCILDescrunused30 = '';\r\n RsCILDescrunused31 = '';\r\n RsCILDescrunused32 = '';\r\n RsCILDescrunused33 = '';\r\n RsCILDescrunused34 = '';\r\n RsCILDescrunused35 = '';\r\n RsCILDescrunused36 = '';\r\n RsCILDescrunused37 = '';\r\n RsCILDescrldtoken = 'Convert metadata token to its runtime representation';\r\n RsCILDescrconvu2 = 'Convert to unsigned int16, pushing int32 on stack';\r\n RsCILDescrconvu1 = 'Convert to unsigned int8, pushing int32 on stack';\r\n RsCILDescrconvi = 'Convert to native int, pushing native int on stack';\r\n RsCILDescrconvovfi = 'Convert to an native int (on the stack as native int) and throw an exception on overflow';\r\n RsCILDescrconvovfu = 'Convert to a native unsigned int (on the stack as native int) and throw an exception on overflow';\r\n RsCILDescraddovf = 'Add signed integer values with overflow check. ';\r\n RsCILDescraddovfun = 'Add unsigned integer values with overflow check.';\r\n RsCILDescrmulovf = 'Multiply signed integer values. Signed result must fit in same size';\r\n RsCILDescrmulovfun = 'Multiply unsigned integer values. Unsigned result must fit in same size';\r\n RsCILDescrsubovf = 'Subtract native int from an native int. Signed result must fit in same size';\r\n RsCILDescrsubovfun = 'Subtract native unsigned int from a native unsigned int. Unsigned result must fit in same size';\r\n RsCILDescrendfinally = 'End finally clause of an exception block';\r\n RsCILDescrleave = 'Exit a protected region of code.';\r\n RsCILDescrleaves = 'Exit a protected region of code, short form';\r\n RsCILDescrstindi = 'Store value of type native int into memory at address';\r\n RsCILDescrconvu = 'Convert to native unsigned int, pushing native int on stack';\r\n RsCILDescrunused38 = '';\r\n RsCILDescrunused39 = '';\r\n RsCILDescrunused40 = '';\r\n RsCILDescrunused41 = '';\r\n RsCILDescrunused42 = '';\r\n RsCILDescrunused43 = '';\r\n RsCILDescrunused44 = '';\r\n RsCILDescrunused45 = '';\r\n RsCILDescrunused46 = '';\r\n RsCILDescrunused47 = '';\r\n RsCILDescrunused48 = '';\r\n RsCILDescrunused49 = '';\r\n RsCILDescrunused50 = '';\r\n RsCILDescrunused51 = '';\r\n RsCILDescrunused52 = '';\r\n RsCILDescrunused53 = '';\r\n RsCILDescrunused54 = '';\r\n RsCILDescrunused55 = '';\r\n RsCILDescrunused56 = '';\r\n RsCILDescrunused57 = '';\r\n RsCILDescrunused58 = '';\r\n RsCILDescrunused59 = '';\r\n RsCILDescrunused60 = '';\r\n RsCILDescrprefix7 = '';\r\n RsCILDescrprefix6 = '';\r\n RsCILDescrprefix5 = '';\r\n RsCILDescrprefix4 = '';\r\n RsCILDescrprefix3 = '';\r\n RsCILDescrprefix2 = '';\r\n RsCILDescrprefix1 = '';\r\n RsCILDescrprefixref = '';\r\n RsCILDescrarglist = 'return argument list handle for the current method ';\r\n RsCILDescrceq = 'push 1 (of type int32) if value1 equals value2, else 0';\r\n RsCILDescrcgt = 'push 1 (of type int32) if value1 > value2, else 0';\r\n RsCILDescrcgtun = 'push 1 (of type int32) if value1 > value2, unsigned or unordered, else 0';\r\n RsCILDescrclt = 'push 1 (of type int32) if value1 < value2, else 0';\r\n RsCILDescrcltun = 'push 1 (of type int32) if value1 < value2, unsigned or unordered, else 0';\r\n RsCILDescrldftn = 'Push a pointer to a method referenced by method on the stack';\r\n RsCILDescrldvirtftn = 'Push address of virtual method mthd on the stack';\r\n RsCILDescrunused61 = '';\r\n RsCILDescrldarg = 'Load argument numbered num onto stack.';\r\n RsCILDescrldarga = 'fetch the address of argument argNum.';\r\n RsCILDescrstarg = 'Store a value to the argument numbered num';\r\n RsCILDescrldloc = 'Load local variable of index indx onto stack.';\r\n RsCILDescrldloca = 'Load address of local variable with index indx';\r\n RsCILDescrstloc = 'Pop value from stack into local variable indx.';\r\n RsCILDescrlocalloc = 'Allocate space from the local memory pool.';\r\n RsCILDescrunused62 = '';\r\n RsCILDescrendfilter = 'End filter clause of SEH exception handling';\r\n RsCILDescrunaligned = 'Subsequent pointer instruction may be unaligned';\r\n RsCILDescrvolatile = 'Subsequent pointer reference is volatile';\r\n RsCILDescrtail = 'Subsequent call terminates current method';\r\n RsCILDescrinitobj = 'Initialize a value type';\r\n RsCILDescrunused63 = '';\r\n RsCILDescrcpblk = 'Copy data from memory to memory';\r\n RsCILDescrinitblk = 'Set a block of memory to a given byte';\r\n RsCILDescrunused64 = '';\r\n RsCILDescrrethrow = 'Rethrow the current exception';\r\n RsCILDescrunused65 = '';\r\n RsCILDescrsizeof = 'Push the size, in bytes, of a value type as a unsigned int32';\r\n RsCILDescrrefanytype = 'Push the type token stored in a typed reference';\r\n RsCILDescrunused66 = '';\r\n RsCILDescrunused67 = '';\r\n RsCILDescrunused68 = '';\r\n RsCILDescrunused69 = '';\r\n RsCILDescrunused70 = '';\r\n\r\n//=== JclCLR =================================================================\r\nresourcestring\r\n RsClrCopyright = '// Delphi-JEDI .NET Framework IL Disassembler. Version 0.1' + sLineBreak +\r\n '// Project JEDI Code Library (JCL) Team. All rights reserved.' + sLineBreak;\r\n RsUnknownTableFmt = '%s%s';\r\n RsUnknownTable = 'Unknown table - ';\r\n\r\n//=== JclCOM =================================================================\r\nresourcestring\r\n RsComInvalidParam = 'An invalid parameter was passed to the routine. If a parameter was ' +\r\n 'expected, it might be an unassigned item or nil pointer';\r\n RsComFailedStreamRead = 'Failed to read all of the data from the specified stream';\r\n RsComFailedStreamWrite = 'Failed to write all of the data into the specified stream';\r\n\r\n//=== JclComplex =============================================================\r\nresourcestring\r\n RsComplexInvalidString = 'Failed to create a complex number from the string provided';\r\n\r\n//=== JclCompression =========================================================\r\nresourcestring\r\n RsCompressionReadNotSupported = 'read is not an supported operation.';\r\n RsCompressionWriteNotSupported = 'write is not an supported operation.';\r\n RsCompressionResetNotSupported = 'reset is not an supported operation.';\r\n RsCompressionSeekNotSupported = 'seek is not an supported operation.';\r\n RsCompressionZLibZErrNo = 'zlib returned: ERRNO';\r\n RsCompressionZLibZStreamError = 'zlib returned: Stream error';\r\n RsCompressionZLibZDataError = 'zlib returned: data error';\r\n RsCompressionZLibZMemError = 'zlib returned: memory error';\r\n RsCompressionZLibZBufError = 'zlib returned: buffer error';\r\n RsCompressionZLibZVersionError = 'zlib returned: version error';\r\n RsCompressionZLibError = 'zLib returned: unknown error (%d)';\r\n RsCompressionGZIPInvalidID = 'gzip: Invalid ID (ID1=%.2x; ID2=%.2x)';\r\n RsCompressionGZIPUnsupportedCM = 'gzip: unsupported compression method (%d)';\r\n RsCompressionGZIPHeaderCRC = 'gzip: CRC failed, header is damaged';\r\n RsCompressionGZIPDecompressing = 'gzip: this property is not readable when the data are being decompressed';\r\n RsCompressionGZIPNotDecompressed = 'gzip: this property is not readable until the data are fully decompressed';\r\n RsCompressionGZIPDataTruncated = 'gzip: data are truncated';\r\n RsCompressionGZIPInternalError = 'gzip: internal error';\r\n RsCompressionGZIPDataCRCFailed = 'gzip: CRC failed, data are damaged';\r\n RsCompressionGZIPExtraFieldTooLong = 'gzip: extra field is too long';\r\n RsCompressionGZIPBadString = 'gzip: the string contains null chars';\r\n RsCompressionBZIP2SequenceError = 'bzip2 returned: sequence error';\r\n RsCompressionBZIP2ParameterError = 'bzip2 returned: parameter error';\r\n RsCompressionBZIP2MemoryError = 'bzip2 returned: memory error';\r\n RsCompressionBZIP2DataError = 'bzip2 returned: data error';\r\n RsCompressionBZIP2HeaderError = 'bzip2 returned: header error';\r\n RsCompressionBZIP2IOError = 'bzip2 returned: IO error';\r\n RsCompressionBZIP2EOFError = 'bzip2 returned: unexpected end of file';\r\n RsCompressionBZIP2OutBuffError = 'bzip2 returned: out buffer is too small';\r\n RsCompressionBZIP2ConfigError = 'bzip2 returned: configuration error';\r\n RsCompressionBZIP2Error = 'bzip2 returned: unknown error (%d)';\r\n RsCompressionUnavailableProperty = 'Property is not available';\r\n RsCompressionCompressingError = 'Operation is not supported while compressing';\r\n RsCompressionDecompressingError = 'Operation is not supported while decompressing';\r\n RsCompressionNoFileName = 'File name not supplied';\r\n RsCompressionUnsupportedMethod = 'Unsupported method';\r\n RsCompressionDataError = 'Data error';\r\n RsCompressionCRCError = 'CRC error';\r\n RsCompressionNoNestedArchive = 'Nested archive is not supported';\r\n RsCompressionUnknownError = 'Unknown error';\r\n RsCompression7zLoadError = 'Sevenzip: Failed to load 7z.dll';\r\n RsCompression7zReturnError = 'Sevenzip: Error result (%.8x) \"%s\"';\r\n RsCompression7zOutArchiveError = 'Sevenzip: Failed to get out archive interface for class %s';\r\n RsCompression7zInArchiveError = 'Sevenzip: Failed to get in archive interface for class %s';\r\n RsCompression7zUnknownValueType = 'Sevenzip: Unknown value type (%d) for property ID %d';\r\n RsCompression7zOnlyCurrentFile = 'Sevenzip: Only properties for current file can be retreived';\r\n RsCompression7zWindows = 'Windows';\r\n RsCompression7zUnix = 'Unix';\r\n RsCompressionZipName = 'Zip archive';\r\n RsCompressionZipExtensions = '*.zip;' + // Basic ZIP file\r\n '*.jar;*.ear;*.war;' + // JAVA files\r\n '*.cbz;' + //Comic reader files - ZIP version\r\n '*.apk;' + // Android application package\r\n '*.wsz;*.wal;' + // Winamp Skins\r\n '*.xpi;*.crx;' + // Firefox, Chrome extensions\r\n '*.dfsz;' + // ???\r\n '*.pcv;' + // MozBackup file\r\n '*.bsz;' + // BSplayer skin\r\n '*.mskin;' + // Maxthon skin\r\n '*.wmz;' + // Windows Media Player skin\r\n '*.ipa;' + // iPhone/iPad application\r\n '*.docx;*.xlsx;*.pptx;' + // MsOffice\r\n '*.sxw;*.sxi;*.sxt;*.sxd;*.sxc;*.sxm;*.sxg;*.stw;*.sti;*.std;*.stc;' + // OpenOffice.org 1.x documents and templates\r\n '*.odh;*.odd;*.odt;*.odm;*.ods;*.ots;*.odg;*.otg;*.odp;*.otp;*.odf;*.odb'; // OpenOffice.org 2.x/3.x docs and templates\r\n RsCompressionBZip2Name = 'BZip2 archive';\r\n RsCompressionBZip2Extensions = '*.bz2;*.bzip2;*.tbz2;*.tbz';\r\n RsCompressionBZip2SubExtensions = '.tbz2=.tar;.tbz=.tar';\r\n RsCompressionRarName = 'Rar archive';\r\n RsCompressionRarExtensions = '*.rar;*.r00;'+\r\n '*.cbr'; // Comic reader file - RAR version\r\n RsCompressionArjName = 'Arj archive';\r\n RsCompressionArjExtensions = '*.arj';\r\n RsCompressionZName = 'Z archive';\r\n RsCompressionZExtensions = '*.z;*.taz';\r\n RsCompressionZSubExtensions = '.taz=.tar';\r\n RsCompressionLzhName = 'Lzh archive';\r\n RsCompressionLzhExtensions = '*.lzh;*.lha';\r\n RsCompression7zName = '7z archive';\r\n RsCompression7zExtensions = '*.7z';\r\n RsCompressionCabName = 'Cab archive';\r\n RsCompressionCabExtensions = '*.cab;'+\r\n '*.fwp'; // FrontPage Web Package\r\n RsCompressionNsisName = 'Nsis archive';\r\n RsCompressionNsisExtensions = '*.nsis';\r\n RsCompressionLzmaName = 'Lzma archive';\r\n RsCompressionLzmaExtensions = '*.lzma';\r\n RsCompressionLzma86Name = 'Lzma86 archive';\r\n RsCompressionLzma86Extensions = '*.lzma86';\r\n RsCompressionPeName = 'Pe archive';\r\n RsCompressionPeExtensions = '*.exe;*.dll;*.sys;*.bpl';\r\n RsCompressionElfName = 'Elf archive';\r\n // TODO: extension might be *.*, but then TJclCompressionStreamFormats.FindDecompressFormat can fail\r\n RsCompressionElfExtensions = '*.';\r\n RsCompressionMachoName = 'Mach-O archive';\r\n // TODO: extension might be *.*, but then TJclCompressionStreamFormats.FindDecompressFormat can fail\r\n RsCompressionMachoExtensions = '*.';\r\n RsCompressionUdfName = 'Udf archive';\r\n RsCompressionUdfExtensions = '*.iso;*.img';\r\n RsCompressionXarName = 'Xar archive';\r\n RsCompressionXarExtensions = '*.xar;'+\r\n '*.safariextz'; // Safari extensions\r\n RsCompressionMubName = 'Mub archive';\r\n // TODO: extension might be *.*, but then TJclCompressionStreamFormats.FindDecompressFormat can fail\r\n RsCompressionMubExtensions = '*.';\r\n RsCompressionHfsName = 'Hfs archive';\r\n RsCompressionHfsExtensions = '*.hfs';\r\n RsCompressionDmgName = 'Dmg archive';\r\n RsCompressionDmgExtensions = '*.dmg';\r\n RsCompressionCompoundName = 'Compound archive';\r\n RsCompressionCompoundExtensions = '*.msi;*.msp;*.doc;*.xls;*.ppt';\r\n RsCompressionWimName = 'Wim archive';\r\n RsCompressionWimExtensions = '*.wim;*.swm';\r\n RsCompressionIsoName = 'Iso archive';\r\n RsCompressionIsoExtensions = '*.iso;*.img';\r\n RsCompressionChmName = 'Chm archive';\r\n RsCompressionChmExtensions = '*.chm;*.chi;*.chq;*.chw;*.hxs;*.hxi;*.hxr;*.hxq;*.hxw;*.lit';\r\n RsCompressionSplitName = 'Split archive';\r\n RsCompressionSplitExtensions = '*.001';\r\n RsCompressionRpmName = 'Rpm archive';\r\n RsCompressionRpmExtensions = '*.rpm';\r\n RsCompressionDebName = 'Deb archive';\r\n RsCompressionDebExtensions = '*.deb';\r\n RsCompressionCpioName = 'Cpio archive';\r\n RsCompressionCpioExtensions = '*.cpio';\r\n RsCompressionTarName = 'Tar archive';\r\n RsCompressionTarExtensions = '*.tar';\r\n RsCompressionGZipName = 'GZip archive';\r\n RsCompressionGZipExtensions = '*.gz;*.gzip;*.tgz;*.tpz';\r\n RsCompressionGZipSubExtensions = '.tgz=.tar;.tpz=.tar';\r\n RsCompressionXzName = 'Xz archive';\r\n RsCompressionXzExtensions = '*.xz;*.txz';\r\n RsCompressionXzSubExtensions = '.txz=.tar';\r\n RsCompressionNtfsName = 'Ntfs archive';\r\n RsCompressionNtfsExtensions = '*.ntfs;*.img';\r\n RsCompressionFatName = 'Fat archive';\r\n RsCompressionFatExtensions = '*.fat;*.img';\r\n RsCompressionMbrName = 'Mbr archive';\r\n RsCompressionMbrExtensions = '*.mbr';\r\n RsCompressionVhdName = 'Vhd archive';\r\n RsCompressionVhdExtensions = '*.vhd';\r\n RsCompressionVhdSubExtensions = '.vhd=.mbr';\r\n RsCompressionFlvName = 'Flv archive';\r\n RsCompressionFlvExtensions = '*.flv';\r\n RsCompressionMsLZName = 'MsLZ archive';\r\n // TODO: extension might be *.*, but then TJclCompressionStreamFormats.FindDecompressFormat can fail\r\n RsCompressionMsLZExtensions = '*.';\r\n RsCompressionSwfName = 'Swf archive';\r\n RsCompressionSwfExtensions = '*.swf';\r\n RsCompressionSwfcName = 'Swf archive';\r\n RsCompressionSwfcExtensions = '*.swf';\r\n RsCompressionApmName = 'APM archive';\r\n RsCompressionApmExtensions = '*.';\r\n RsCompressionPpmdName = 'PPMD archive';\r\n RsCompressionPpmdExtensions = '*.pmd';\r\n RsCompressionTEName = 'Terse Executable';\r\n RsCompressionTEExtensions = '*.te';\r\n RsCompressionUEFIcName = 'UEFIc archive';\r\n RsCompressionUEFIcExtensions = '*.scap';\r\n RsCompressionUEFIsName = 'UEFIs archive';\r\n RsCompressionUEFIsExtensions = '*.';\r\n RsCompressionSquashFSName = 'SquashFS archive';\r\n RsCompressionSquashFSExtensions = '*.squashfs';\r\n RsCompressionCramFSName = 'CramFS archive';\r\n RsCompressionCramFSExtensions = '*.cramfs';\r\n RsCompressionDuplicate = 'The file %s already exists in the archive';\r\n RsCompressionReplaceError = 'At least one compression volume could not be replaced after an archive out-of-place update';\r\n\r\n//=== JclConsole =============================================================\r\nresourcestring\r\n RsCannotRaiseSignal = 'Cannot raise %s signal.';\r\n\r\n//=== JclContainerIntf =======================================================\r\nresourcestring\r\n RsEOutOfBounds = 'Out of bounds';\r\n RsEOperationNotSupported = 'Operation not supported';\r\n RsEValueNotFound = 'Value %s not found';\r\n RsEDuplicateElement = 'Duplicate element';\r\n RsENoCollection = 'Collection not assigned';\r\n RsEIllegalQueueCapacity = 'Illegal queue capacity';\r\n RsEIllegalStateOperation = 'Illegal state operation';\r\n RsENoEqualityComparer = 'Item equality comparer is not assigned';\r\n RsENoComparer = 'Item comparer is not assigned';\r\n RsENoHashConverter = 'Hash converter is not assigned';\r\n RsEAssignError = 'Assignation error';\r\n RsEReadOnlyError = 'Container is read-only';\r\n\r\n//=== JclCounter =============================================================\r\nresourcestring\r\n RsNoCounter = 'No high performance counters supported';\r\n\r\n//=== JclDateTime ============================================================\r\nresourcestring\r\n RsMakeUTCTime = 'Error converting to UTC time. Time zone could not be determined';\r\n RsDateConversion = 'Error illegal date or time format';\r\n\r\n//=== JclDebug ===============================================================\r\nresourcestring\r\n RsUnknownFunctionAt = 'Unknown function at %s';\r\n\r\n//=== JclCppException ========================================================\r\nresourcestring\r\n RsCppUnhandledExceptionMsg = 'Unhandled C++ exception of type ''%s'' occurred';\r\n\r\n//=== JclDotNet ==============================================================\r\nresourcestring\r\n RsEUnknownCLRVersion = '\"%s\" is not a known CLR version';\r\n\r\n//=== JclExprEval ============================================================\r\nresourcestring\r\n RsExprEvalRParenExpected = 'Parse error: '')'' expected';\r\n RsExprEvalFactorExpected = 'Parse error: Factor expected';\r\n RsExprEvalUnknownSymbol = 'Parse error: Unknown symbol: ''%s''';\r\n\r\n RsExprEvalFirstArg = 'Parse error: ''('' and function''s first parameter expected';\r\n RsExprEvalNextArg = 'Parse error: '','' and another parameter expected';\r\n RsExprEvalEndArgs = 'Parse error: '')'' to close function''s parameters expected';\r\n\r\n RsExprEvalExprNotFound = 'Expression compiler error: Expression ''%s'' not found';\r\n RsExprEvalExprPtrNotFound = 'Expression compiler error: Expression pointer not found';\r\n RsExprEvalExprRefCountAssertion = 'Expression compiler error: expression refcount < 0';\r\n\r\n//=== JclFileUtils ===========================================================\r\nresourcestring\r\n // Path manipulation\r\n RsPathInvalidDrive = '%s is not a valid drive';\r\n\r\n // Files and directories\r\n RsFileUtilsAttrUnavailable = 'Unable to retrieve attributes of %s';\r\n\r\n RsCannotCreateDir = 'Unable to create directory';\r\n RsDelTreePathIsEmpty = 'DelTree: Path is empty';\r\n RsFileSearchAttrInconsistency = 'Some file search attributes are required AND rejected!';\r\n RsEWindowsVersionNotSupported = 'This windows version is not supported';\r\n RsEWindowNotValid = 'The window with handle %d is not valid';\r\n RsEProcessNotValid = 'The process with ID %d is not valid';\r\n RsEModuleNotValid = 'The Module with handle %d is not valid';\r\n\r\n // TJclFileVersionInfo\r\n RsFileUtilsNoVersionInfo = 'File contains no version information';\r\n RsFileUtilsFileDoesNotExist = 'The file %s does not exist';\r\n RsFileUtilsLanguageIndex = 'Illegal language index';\r\n RsFileUtilsEmptyValue = 'No value was supplied';\r\n RsFileUtilsValueNotFound = 'The value %s was not found.';\r\n // Strings returned from OSIdentTOString()\r\n RsVosUnknown = 'Unknown';\r\n RsVosDos = 'MS-DOS';\r\n RsVosOS216 = '16-bit OS/2';\r\n RsVosOS232 = '32-bit OS/2';\r\n RsVosNT = 'Windows NT';\r\n RsVosWindows16 = '16-bit Windows';\r\n RsVosPM16 = '16-bit PM';\r\n RsVosPM32 = '32-bit PM';\r\n RsVosWindows32 = '32-bit Windows';\r\n RsVosDosWindows16 = '16-bit Windows, running on MS-DOS';\r\n RsVosDosWindows32 = 'Win32 API, running on MS-DOS';\r\n RsVosOS216PM16 = '16-bit PM, running on 16-bit OS/2';\r\n RsVosOS232PM32 = '32-bit PM, running on 32-bit OS/2';\r\n RsVosNTWindows32 = 'Win32 API, running on Windows/NT';\r\n RsVosDesignedFor = 'Designed for %s';\r\n\r\n // Strings returned from OSFileTypeToString()\r\n RsVftUnknown = 'Unknown';\r\n RsVftApp = 'Application';\r\n RsVftDll = 'Library';\r\n RsVftDrv = 'Driver';\r\n RsVftFont = 'Font';\r\n RsVftVxd = 'Virtual device';\r\n RsVftStaticLib = 'Static-link library';\r\n RsVft2DrvPRINTER = 'Printer';\r\n RsVft2DrvKEYBOARD = 'Keyboard';\r\n RsVft2DrvLANGUAGE = 'Language';\r\n RsVft2DrvDISPLAY = 'Display';\r\n RsVft2DrvMOUSE = 'Mouse';\r\n RsVft2DrvNETWORK = 'Network';\r\n RsVft2DrvSYSTEM = 'System';\r\n RsVft2DrvINSTALLABLE = 'Installable';\r\n RsVft2DrvSOUND = 'Sound';\r\n RsVft2DrvCOMM = 'Communications';\r\n RsVft2FontRASTER = 'Raster';\r\n RsVft2FontVECTOR = 'Vector';\r\n RsVft2FontTRUETYPE = 'TrueType';\r\n\r\n // TJclFileStream\r\n RsFileStreamCreate = 'Unable to create temporary file stream';\r\n\r\n // TJclFileMapping\r\n RsCreateFileMapping = 'Failed to create FileMapping';\r\n RsCreateFileMappingView = 'Failed to create FileMappingView';\r\n RsLoadFromStreamSize = 'Not enough space in View in procedure LoadFromStream';\r\n RsFileMappingInvalidHandle = 'Invalid file handle';\r\n RsViewNeedsMapping = 'FileMap argument of TJclFileMappingView constructor cannot be nil';\r\n RsFailedToObtainSize = 'Failed to obtain size of file';\r\n\r\n // GetDriveTypeStr()\r\n RsUnknownDrive = 'Unknown drive type';\r\n RsRemovableDrive = 'Removable Drive';\r\n RsHardDisk = 'Hard Disk';\r\n RsRemoteDrive = 'Remote Drive';\r\n RsCDRomDrive = 'CD-ROM';\r\n RsRamDisk = 'RAM-Disk';\r\n\r\n // GetFileAttributeList()\r\n RsAttrDirectory = 'Directory';\r\n RsAttrReadOnly = 'ReadOnly';\r\n RsAttrSystemFile = 'SystemFile';\r\n RsAttrVolumeID = 'Volume ID';\r\n RsAttrArchive = 'Archive';\r\n RsAttrAnyFile = 'AnyFile';\r\n RsAttrHidden = 'Hidden';\r\n\r\n // GetFileAttributeListEx()\r\n RsAttrNormal = 'Normal';\r\n RsAttrTemporary = 'Temporary';\r\n RsAttrCompressed = 'Compressed';\r\n RsAttrOffline = 'Offline';\r\n RsAttrEncrypted = 'Encrypted';\r\n RsAttrReparsePoint = 'Reparse Point';\r\n RsAttrSparseFile = 'Sparse';\r\n\r\n // TJclFileMapping.Create\r\n RsFileMappingOpenFile = 'Unable to open the file';\r\n\r\n // TJclMappedTextReader\r\n RsFileIndexOutOfRange = 'Index of out range';\r\n\r\n // FileGetTypeName()\r\n RsDefaultFileTypeName = ' File';\r\n\r\n//=== JclMapi ================================================================\r\nresourcestring\r\n RsMapiError = 'MAPI Error: (%d) \"%s\"';\r\n RsMapiMissingExport = 'Function \"%s\" is not exported by client';\r\n RsMapiInvalidIndex = 'Index is out ot range';\r\n RsMapiMailNoClient = 'No Simple MAPI client installed, cannot send the message';\r\n\r\n RsMapiErrUSER_ABORT = 'User abort';\r\n RsMapiErrFAILURE = 'General MAPI failure';\r\n RsMapiErrLOGIN_FAILURE = 'MAPI login failure';\r\n RsMapiErrDISK_FULL = 'Disk full';\r\n RsMapiErrINSUFFICIENT_MEMORY = 'Insufficient memory';\r\n RsMapiErrACCESS_DENIED = 'Access denied';\r\n RsMapiErrTOO_MANY_SESSIONS = 'Too many sessions';\r\n RsMapiErrTOO_MANY_FILES = 'Too many files were specified';\r\n RsMapiErrTOO_MANY_RECIPIENTS = 'Too many recipients were specified';\r\n RsMapiErrATTACHMENT_NOT_FOUND = 'A specified attachment was not found';\r\n RsMapiErrATTACHMENT_OPEN_FAILURE = 'Attachment open failure';\r\n RsMapiErrATTACHMENT_WRITE_FAILURE = 'Attachment write failure';\r\n RsMapiErrUNKNOWN_RECIPIENT = 'Unknown recipient';\r\n RsMapiErrBAD_RECIPTYPE = 'Bad recipient type';\r\n RsMapiErrNO_MESSAGES = 'No messages';\r\n RsMapiErrINVALID_MESSAGE = 'Invalid message';\r\n RsMapiErrTEXT_TOO_LARGE = 'Text too large';\r\n RsMapiErrINVALID_SESSION = 'Invalid session';\r\n RsMapiErrTYPE_NOT_SUPPORTED = 'Type not supported';\r\n RsMapiErrAMBIGUOUS_RECIPIENT = 'A recipient was specified ambiguously';\r\n RsMapiErrMESSAGE_IN_USE = 'Message in use';\r\n RsMapiErrNETWORK_FAILURE = 'Network failure';\r\n RsMapiErrINVALID_EDITFIELDS = 'Invalid edit fields';\r\n RsMapiErrINVALID_RECIPS = 'Invalid recipients';\r\n RsMapiErrNOT_SUPPORTED = 'Not supported';\r\n\r\n RsMapiMailORIG = 'From';\r\n RsMapiMailTO = 'To';\r\n RsMapiMailCC = 'Cc';\r\n RsMapiMailBCC = 'Bcc';\r\n RsMapiMailSubject = 'Subject';\r\n\r\n//=== JclMath ================================================================\r\nresourcestring\r\n RsMathDomainError = 'Domain check failure in JclMath';\r\n RsEmptyArray = 'Empty array is not allowed as input parameter';\r\n RsNonPositiveArray = 'Input array contains non-positive or zero values';\r\n RsUnexpectedValue = 'Unexpected data value';\r\n RsInvalidRational = 'Invalid rational number';\r\n RsDivByZero = 'Division by zero';\r\n RsRationalDivByZero = 'Rational division by zero';\r\n RsNoNaN = 'NaN expected';\r\n RsNaNTagError = 'NaN Tag value %d out of range';\r\n RsNaNSignal = 'NaN signaling %d';\r\n RsPowerInfinite = 'Power function: Result is infinite';\r\n RsPowerComplex = 'Power function: Result is complex';\r\n\r\n//=== JclMetadata ============================================================\r\nresourcestring\r\n RsUnknownClassLayout = 'Unknown class layout - $%.8x';\r\n RsUnknownStringFormatting = 'Unknown string formatting - $%.8x';\r\n RsInvalidSignatureData = 'Invalid compressed signature data - %.2x %.2x %.2x %.2x';\r\n RsUnknownManifestResource = 'Unknown manifest resource visibility - %d';\r\n RsNoLocalVarSig = 'Signature %s is not LocalVarSig';\r\n RsLocalVarSigOutOfRange = 'LocalVarSig count %d is out of range [1..$$FFFE]';\r\n\r\n//=== JclMIDI ================================================================\r\nresourcestring\r\n RsOctaveC = 'C';\r\n RsOctaveCSharp = 'C#';\r\n RsOctaveD = 'D';\r\n RsOctaveDSharp = 'D#';\r\n RsOctaveE = 'E';\r\n RsOctaveF = 'F';\r\n RsOctaveFSharp = 'F#';\r\n RsOctaveG = 'G';\r\n RsOctaveGSharp = 'G#';\r\n RsOctaveA = 'A';\r\n RsOctaveASharp = 'A#';\r\n RsOctaveB = 'B';\r\n\r\n RsMidiInvalidChannelNum = 'Invalid MIDI channel number (%d)';\r\n {$IFDEF UNIX}\r\n RsMidiNotImplemented = 'JclMidi: MIDI I/O for Unix not (yet) implemented';\r\n {$ENDIF UNIX}\r\n\r\n//=== JclMiscel ==============================================================\r\nresourcestring\r\n // CreateProcAsUser\r\n RsCreateProcNTRequiredError = 'Windows NT required';\r\n RsCreateProcBuild1057Error = 'NT version 3.51 build 1057 or later required';\r\n\r\n RsCreateProcPrivilegeMissing = 'This account does not have the privilege \"%s\" (%s)';\r\n RsCreateProcLogonUserError = 'LogonUser failed';\r\n RsCreateProcAccessDenied = 'Access denied';\r\n RsCreateProcLogonFailed = 'Unable to logon';\r\n RsCreateProcSetStationSecurityError = 'Cannot set WindowStation \"%s\" security.';\r\n RsCreateProcSetDesktopSecurityError = 'Cannot set Desktop \"%s\" security.';\r\n RsCreateProcPrivilegesMissing = 'This account does not have one (or more) of ' +\r\n 'the following privileges: ' + '\"%s\"(%s)' + sLineBreak + '\"%s\"(%s)' + sLineBreak;\r\n RsCreateProcCommandNotFound = 'Command or filename not found: \"%s\"';\r\n RsCreateProcFailed = 'CreateProcessAsUser failed';\r\n\r\n//=== JclMultimedia ==========================================================\r\nresourcestring\r\n // Multimedia timer\r\n RsMmTimerGetCaps = 'Error retrieving multimedia timer device capabilities';\r\n RsMmSetEvent = 'Error setting multimedia event timer';\r\n RsMmInconsistentId = 'Multimedia timer callback was called with inconsistent Id';\r\n RsMmTimerActive = 'This operation cannot be performed while the timer is active';\r\n\r\n // Audio Mixer\r\n RsMmMixerSource = 'Source';\r\n RsMmMixerDestination = 'Destination';\r\n RsMmMixerUndefined = 'Undefined';\r\n RsMmMixerDigital = 'Digital';\r\n RsMmMixerLine = 'Line';\r\n RsMmMixerMonitor = 'Monitor';\r\n RsMmMixerSpeakers = 'Speakers';\r\n RsMmMixerHeadphones = 'Headphones';\r\n RsMmMixerTelephone = 'Telephone';\r\n RsMmMixerWaveIn = 'Waveform-audio input';\r\n RsMmMixerVoiceIn = 'Voice input';\r\n RsMmMixerMicrophone = 'Microphone';\r\n RsMmMixerSynthesizer = 'Synthesizer';\r\n RsMmMixerCompactDisc = 'Compact disc';\r\n RsMmMixerPcSpeaker = 'PC speaker';\r\n RsMmMixerWaveOut = 'Waveform-audio output';\r\n RsMmMixerAuxiliary = 'Auxiliary audio line';\r\n RsMmMixerAnalog = 'Analog';\r\n RsMmMixerNoDevices = 'No mixer device found';\r\n RsMmMixerCtlNotFound = 'Line control (%s, %.8x) not found';\r\n\r\n // EJclMciError\r\n RsMmUnknownError = 'Unknown MCI error No. %d';\r\n RsMmMciErrorPrefix = 'MCI-Error: ';\r\n\r\n // CD audio routines\r\n RsMmNoCdAudio = 'Cannot open CDAUDIO-Device';\r\n RsMmCdTrackNo = 'Track: %.2u';\r\n RsMMCdTimeFormat = '%2u:%.2u';\r\n RsMMTrackAudio = 'Audio';\r\n RsMMTrackOther = 'Other';\r\n\r\n//=== JclNTFS ================================================================\r\nresourcestring\r\n RsInvalidArgument = '%s: Invalid argument <%s>';\r\n RsNtfsUnableToDeleteSymbolicLink = 'Unable to delete temporary symbolic link';\r\n RsEUnableToCreatePropertyStorage = 'Unable to create property storage';\r\n RsEIncomatibleDataFormat = 'Incompatible data format';\r\n\r\n//=== JclPCRE ================================================================\r\nresourcestring\r\n RsErrNoMatch = 'No match';\r\n RsErrNull = 'Required value is null';\r\n RsErrBadOption = 'Bad option';\r\n RsErrBadMagic = 'Bad magic';\r\n RsErrUnknownNode = 'Unknown node';\r\n RsErrNoMemory = 'Out of memory';\r\n RsErrNoSubString = 'No substring';\r\n RsErrMatchLimit = 'Match limit';\r\n RsErrCallout = 'Callout';\r\n RsErrBadUTF8 = 'Bad UTF-8';\r\n RsErrBadUTF16 = 'Bad UTF-16';\r\n RsErrBadUTF8Offset = 'Bad UTF-8 offset';\r\n RsErrBadUTF16Offset = 'Bad UTF-16 offset';\r\n RsErrPartial = 'Partial';\r\n RsErrBadPartial = 'Bad partial';\r\n RsErrInternal = 'Internal';\r\n RsErrBadCount = 'Bad count';\r\n RsErrDfaUItem = 'DFA UItem';\r\n RsErrDfaUCond = 'DFA UCond';\r\n RsErrDfaUMLimit = 'DFA UMLimit';\r\n RsErrDfaWSSize = 'DFA WSSize';\r\n RsErrDfaRecurse = 'DFA Recurse';\r\n RsErrRecursionLimit = 'Recursion limit';\r\n RsErrNullWsLimit = 'Null WS limit';\r\n RsErrBadNewLine = 'Bad new line';\r\n RsErrBadOffset = 'Bad offset';\r\n RsErrShortUTF8 = 'Short UTF-8';\r\n RsErrShortUTF16 = 'Short UTF-16';\r\n RsErrRecurseLoop = 'Recurse loop';\r\n RsErrJITStackLimit = 'JIT stack limit';\r\n RsErrLibNotLoaded = 'PCRE library not loaded';\r\n RsErrMemFuncNotSet = 'PCRE memory management functions not set';\r\n RsErrStudyFailed = 'Study failed';\r\n RsErrCalloutError = 'Unhandled exception in callout';\r\n RsErrUnknownError = 'Unknown error';\r\n RsErrNoUTF8Support = 'No UTF-8 support in this version of PCRE';\r\n RsErrNoUTF16Support = 'No UTF-16 support in this version of PCRE';\r\n RsErrNoJITSupport = 'No JIT support in this version of PCRE';\r\n RsErrBadMode = 'Bad Mode';\r\n RsErrBadEndianness = 'Bad endianness';\r\n RsErrBadRestart = 'Bad Restart';\r\n\r\n//=== JclPeImage =============================================================\r\nresourcestring\r\n RsPeReadOnlyStream = 'Stream is read-only';\r\n\r\n // TJclPeImage\r\n RsPeCantOpen = 'Cannot open file \"%s\"';\r\n RsPeNotPE = 'This is not a PE format';\r\n RsPeUnknownTarget = 'Unknown PE target'; \r\n RsPeNotResDir = 'Not a resource directory';\r\n RsPeNotAvailableForAttached = 'Feature is not available for attached images';\r\n RsPeSectionNotFound = 'Section \"%s\" not found';\r\n\r\n // PE directory names\r\n RsPeImg_00 = 'Exports';\r\n RsPeImg_01 = 'Imports';\r\n RsPeImg_02 = 'Resources';\r\n RsPeImg_03 = 'Exceptions';\r\n RsPeImg_04 = 'Security';\r\n RsPeImg_05 = 'Base Relocations';\r\n RsPeImg_06 = 'Debug';\r\n RsPeImg_07 = 'Description';\r\n RsPeImg_08 = 'Machine Value';\r\n RsPeImg_09 = 'TLS';\r\n RsPeImg_10 = 'Load configuration';\r\n RsPeImg_11 = 'Bound Import';\r\n RsPeImg_12 = 'IAT';\r\n RsPeImg_13 = 'Delay load import';\r\n RsPeImg_14 = 'COM run-time';\r\n RsPeImg_Reserved = 'reserved [%.2d]';\r\n\r\n // NT Header names\r\n RsPeSignature = 'Signature';\r\n RsPeMachine = 'Machine';\r\n RsPeNumberOfSections = 'Number of Sections';\r\n RsPeTimeDateStamp = 'Time Date Stamp';\r\n RsPePointerToSymbolTable = 'Symbols Pointer';\r\n RsPeNumberOfSymbols = 'Number of Symbols';\r\n RsPeSizeOfOptionalHeader = 'Size of Optional Header';\r\n RsPeCharacteristics = 'Characteristics';\r\n RsPeMagic = 'Magic';\r\n RsPeLinkerVersion = 'Linker Version';\r\n RsPeSizeOfCode = 'Size of Code';\r\n RsPeSizeOfInitializedData = 'Size of Initialized Data';\r\n RsPeSizeOfUninitializedData = 'Size of Uninitialized Data';\r\n RsPeAddressOfEntryPoint = 'Address of Entry Point';\r\n RsPeBaseOfCode = 'Base of Code';\r\n RsPeBaseOfData = 'Base of Data';\r\n RsPeImageBase = 'Image Base';\r\n RsPeSectionAlignment = 'Section Alignment';\r\n RsPeFileAlignment = 'File Alignment';\r\n RsPeOperatingSystemVersion = 'Operating System Version';\r\n RsPeImageVersion = 'Image Version';\r\n RsPeSubsystemVersion = 'Subsystem Version';\r\n RsPeWin32VersionValue = 'Win32 Version';\r\n RsPeSizeOfImage = 'Size of Image';\r\n RsPeSizeOfHeaders = 'Size of Headers';\r\n RsPeCheckSum = 'CheckSum';\r\n RsPeSubsystem = 'Subsystem';\r\n RsPeDllCharacteristics = 'Dll Characteristics';\r\n RsPeSizeOfStackReserve = 'Size of Stack Reserve';\r\n RsPeSizeOfStackCommit = 'Size of Stack Commit';\r\n RsPeSizeOfHeapReserve = 'Size of Heap Reserve';\r\n RsPeSizeOfHeapCommit = 'Size of Heap Commit';\r\n RsPeLoaderFlags = 'Loader Flags';\r\n RsPeNumberOfRvaAndSizes = 'Number of RVA';\r\n\r\n // Load config names\r\n RsPeVersion = 'Version';\r\n RsPeGlobalFlagsClear = 'GlobalFlagsClear';\r\n RsPeGlobalFlagsSet = 'GlobalFlagsSet';\r\n RsPeCriticalSectionDefaultTimeout = 'CriticalSectionDefaultTimeout';\r\n RsPeDeCommitFreeBlockThreshold = 'DeCommitFreeBlockThreshold';\r\n RsPeDeCommitTotalFreeThreshold = 'DeCommitTotalFreeThreshold';\r\n RsPeLockPrefixTable = 'LockPrefixTable';\r\n RsPeMaximumAllocationSize = 'MaximumAllocationSize';\r\n RsPeVirtualMemoryThreshold = 'VirtualMemoryThreshold';\r\n RsPeProcessHeapFlags = 'ProcessHeapFlags';\r\n RsPeProcessAffinityMask = 'ProcessAffinityMask';\r\n RsPeCSDVersion = 'CSDVersion';\r\n RsPeReserved = 'Reserved';\r\n RsPeEditList = 'EditList';\r\n\r\n // Machine names\r\n RsPeMACHINE_UNKNOWN = 'Unknown';\r\n RsPeMACHINE_I386 = 'Intel 386';\r\n RsPeMACHINE_R3000 = 'MIPS little-endian R3000';\r\n RsPeMACHINE_R4000 = 'MIPS little-endian R4000';\r\n RsPeMACHINE_R10000 = 'MIPS little-endian R10000';\r\n RsPeMACHINE_WCEMIPSV2 = 'MIPS little-endian WCE v2';\r\n RsPeMACHINE_ALPHA = 'Alpha_AXP';\r\n RsPeMACHINE_SH3 = 'SH3 little-endian';\r\n RsPeMACHINE_SH3DSP = 'SH3 DSP';\r\n RsPeMACHINE_SH3E = 'SH3E little-endian';\r\n RsPeMACHINE_SH4 = 'SH4 little-endian';\r\n RsPeMACHINE_SH5 = 'SH5';\r\n RsPeMACHINE_ARM = 'ARM Little-Endian';\r\n RsPeMACHINE_THUMB = 'THUMB';\r\n RsPeMACHINE_AM33 = 'AM33';\r\n RsPeMACHINE_POWERPC = 'IBM PowerPC Little-Endian';\r\n RsPeMACHINE_POWERPCFP = 'IBM PowerPC FP';\r\n RsPeMACHINE_IA64 = 'Intel 64';\r\n RsPeMACHINE_MIPS16 = 'MIPS16';\r\n RsPeMACHINE_AMPHA64 = 'ALPHA64';\r\n RsPeMACHINE_MIPSFPU = 'MIPSFPU';\r\n RsPeMACHINE_MIPSFPU16 = 'MIPSFPU16';\r\n RsPeMACHINE_TRICORE = 'Infineon';\r\n RsPeMACHINE_CEF = 'CEF';\r\n RsPeMACHINE_EBC = 'EFI Byte Code';\r\n RsPeMACHINE_AMD64 = 'AMD64 (K8)';\r\n RsPeMACHINE_M32R = 'M32R little-endian';\r\n RsPeMACHINE_CEE = 'CEE';\r\n\r\n // Subsystem names\r\n RsPeSUBSYSTEM_UNKNOWN = 'Unknown';\r\n RsPeSUBSYSTEM_NATIVE = 'Native';\r\n RsPeSUBSYSTEM_WINDOWS_GUI = 'GUI';\r\n RsPeSUBSYSTEM_WINDOWS_CUI = 'Console';\r\n RsPeSUBSYSTEM_OS2_CUI = 'OS/2';\r\n RsPeSUBSYSTEM_POSIX_CUI = 'Posix';\r\n RsPeSUBSYSTEM_RESERVED8 = 'Reserved 8';\r\n\r\n // Debug symbol type names\r\n RsPeDEBUG_UNKNOWN = 'UNKNOWN';\r\n RsPeDEBUG_COFF = 'COFF';\r\n RsPeDEBUG_CODEVIEW = 'CODEVIEW';\r\n RsPeDEBUG_FPO = 'FPO';\r\n RsPeDEBUG_MISC = 'MISC';\r\n RsPeDEBUG_EXCEPTION = 'EXCEPTION';\r\n RsPeDEBUG_FIXUP = 'FIXUP';\r\n RsPeDEBUG_OMAP_TO_SRC = 'OMAP_TO_SRC';\r\n RsPeDEBUG_OMAP_FROM_SRC = 'OMAP_FROM_SRC';\r\n RsPeDEBUG_BORLAND = 'BORLAND';\r\n\r\n // TJclPePackageInfo.PackageModuleTypeToString\r\n RsPePkgExecutable = 'Executable';\r\n RsPePkgPackage = 'Package';\r\n PsPePkgLibrary = 'Library';\r\n\r\n // TJclPePackageInfo.PackageOptionsToString\r\n RsPePkgNeverBuild = 'NeverBuild';\r\n RsPePkgDesignOnly = 'DesignOnly';\r\n RsPePkgRunOnly = 'RunOnly';\r\n RsPePkgIgnoreDupUnits = 'IgnoreDupUnits';\r\n\r\n // TJclPePackageInfo.ProducerToString\r\n RsPePkgV3Produced = 'Delphi 3 or C++ Builder 3';\r\n RsPePkgProducerUndefined = 'Undefined';\r\n RsPePkgBCB4Produced = 'C++ Builder 4 or later';\r\n RsPePkgDelphi4Produced = 'Delphi 4 or later';\r\n\r\n // TJclPePackageInfo.UnitInfoFlagsToString\r\n RsPePkgMain = 'Main';\r\n RsPePkgWeak = 'Weak';\r\n RsPePkgOrgWeak = 'OrgWeak';\r\n RsPePkgImplicit = 'Implicit';\r\n\r\n//=== JclRegistry ============================================================\r\nresourcestring\r\n RsUnableToOpenKeyRead = 'Unable to open key \"%s\\%s\" for read';\r\n RsUnableToOpenKeyWrite = 'Unable to open key \"%s\\%s\" for write';\r\n RsUnableToAccessValue = 'Unable to open key \"%s\\%s\" and access value \"%s\"';\r\n RsWrongDataType = '\"%s\\%s\\%s\" is of wrong kind or size';\r\n RsInconsistentPath = '\"%s\" does not match RootKey';\r\n\r\n//=== JclRTTI ================================================================\r\nresourcestring\r\n RsRTTIValueOutOfRange = 'Value out of range (%s).';\r\n RsRTTIUnknownIdentifier = 'Unknown identifier ''%s''.';\r\n RsRTTIInvalidBaseType = 'Invalid base type (%s is of type %s).';\r\n RsRTTINoStringValue = 'The property %s of type %s has no string value'; \r\n\r\n RsRTTIVar = 'var ';\r\n RsRTTIConst = 'const ';\r\n RsRTTIArrayOf = 'array of ';\r\n RsRTTIOut = 'out ';\r\n RsRTTIBits = 'bits';\r\n RsRTTIOrdinal = 'ordinal=';\r\n RsRTTITrue = 'True';\r\n RsRTTIFalse = 'False';\r\n RsRTTITypeError = '???';\r\n RsRTTITypeInfoAt = 'Type info: %p';\r\n\r\n RsRTTIPropRead = 'read';\r\n RsRTTIPropWrite = 'write';\r\n RsRTTIPropStored = 'stored';\r\n\r\n RsRTTIField = 'field';\r\n RsRTTIStaticMethod = 'static method';\r\n RsRTTIVirtualMethod = 'virtual method';\r\n\r\n RsRTTIIndex = 'index';\r\n RsRTTIDefault = 'default';\r\n\r\n RsRTTIName = 'Name: ';\r\n RsRTTIType = 'Type: ';\r\n RsRTTIFlags = 'Flags: ';\r\n RsRTTIGUID = 'GUID: ';\r\n RsRTTITypeKind = 'Type kind: ';\r\n RsRTTIOrdinalType = 'Ordinal type: ';\r\n RsRTTIMinValue = 'Min value: ';\r\n RsRTTIMaxValue = 'Max value: ';\r\n RsRTTINameList = 'Names: ';\r\n RsRTTIClassName = 'Class name: ';\r\n RsRTTIParent = 'Parent: ';\r\n RsRTTIPropCount = 'Property count: ';\r\n RsRTTIUnitName = 'Unit name: ';\r\n RsRTTIBasedOn = 'Based on: ';\r\n RsRTTIFloatType = 'Float type: ';\r\n RsRTTIMethodKind = 'Method kind: ';\r\n RsRTTIParamCount = 'Parameter count: ';\r\n RsRTTIReturnType = 'Return type: ';\r\n RsRTTIMaxLen = 'Max length: ';\r\n RsRTTIElSize = 'Element size: ';\r\n RsRTTIElType = 'Element type: ';\r\n RsRTTIElNeedCleanup = 'Elements need clean up: ';\r\n RsRTTIVarType = 'Variant type: ';\r\n\r\n RsDeclarationFormat = '// Declaration for ''%s'' not supported.';\r\n\r\n//=== JclSchedule ============================================================\r\nresourcestring\r\n RsScheduleInvalidTime = 'Invalid time specification';\r\n RsScheduleEndBeforeStart = 'End time can not be before start time';\r\n RsScheduleIntervalZero = 'Interval should be larger than 0';\r\n RsScheduleNoDaySpecified = 'At least one day of the week should be specified';\r\n RsScheduleIndexValueSup = 'Property IndexValue not supported for current IndexKind';\r\n RsScheduleIndexValueZero = 'IndexValue can not be 0';\r\n RsScheduleDayNotSupported = 'Property Day not supported for current IndexKind';\r\n RsScheduleDayInRange = 'Day values should fall in the range 1 .. 31';\r\n RsScheduleMonthInRange = 'Month values should fall in the range 1 .. 12';\r\n\r\n//=== JclSecurity ============================================================\r\nresourcestring\r\n RsInvalidSID = 'Invalid SID';\r\n RsSIDBufferTooSmall = 'SID buffer too small.';\r\n RsLsaError = 'LSA Error: NT Status = %.8x, message: %s'; \r\n\r\n//=== JclSimpleXml ===========================================================\r\nresourcestring\r\n RsEInvalidXMLElementUnexpectedCharacte =\r\n 'Invalid XML Element: Unexpected character in property declaration (\"%s\" found at position %d)';\r\n RsEInvalidXMLElementUnexpectedCharacte_ =\r\n 'Invalid XML Element: Unexpected character in property declaration. Expecting \" or '' but \"%s\" found at position %d';\r\n RsEUnexpectedValueForLPos = 'Unexpected value for lPos at position %d';\r\n RsEInvalidXMLElementExpectedBeginningO = 'Invalid XML Element: Expected beginning of tag but \"%s\" found at position %d';\r\n RsEInvalidXMLElementExpectedEndOfTagBu = 'Invalid XML Element: Expected end of tag but \"%s\" found at position %d';\r\n RsEInvalidXMLElementMalformedTagFoundn = 'Invalid XML Element: malformed tag found (no valid name) at position %d';\r\n RsEInvalidXMLElementErroneousEndOfTagE =\r\n 'Invalid XML Element: Erroneous end of tag, expecting but found at position %d';\r\n RsEInvalidCommentExpectedsButFounds = 'Invalid Comment: expected \"%0:s\" but found \"%1:s\" at position %d';\r\n RsEInvalidCommentNotAllowedInsideComme = 'Invalid Comment: \"--\" not allowed inside comments at position %d';\r\n RsEInvalidCommentUnexpectedEndOfData = 'Invalid Comment: Unexpected end of data at position %d';\r\n RsEInvalidCDATAExpectedsButFounds = 'Invalid CDATA: expected \"%0:s\" but found \"%1:s\" at position %d';\r\n RsEInvalidCDATAUnexpectedEndOfData = 'Invalid CDATA: Unexpected end of data at position %d';\r\n RsEInvalidHeaderExpectedsButFounds = 'Invalid Header: expected \"%0:s\" but found \"%1:s\" at position %d';\r\n RsEInvalidStylesheetExpectedsButFounds = 'Invalid Stylesheet: expected \"%0:s\" but found \"%1:s\" at position %d';\r\n RsEInvalidStylesheetUnexpectedEndOfDat = 'Invalid Stylesheet: Unexpected end of data at position %d';\r\n RsEInvalidMSOExpectedsButFounds = 'Invalid MSO: expected \"%0:s\" but found \"%1:s\" at position %d';\r\n RsEInvalidMSOUnexpectedEndOfDat = 'Invalid MSO: Unexpected end of data at position %d';\r\n RsEInvalidDocumentUnexpectedTextInFile = 'Invalid Document: Unexpected text in file prolog at position %d';\r\n\r\n//=== JclStatistics ==========================================================\r\nresourcestring\r\n RsInvalidSampleSize = 'Invalid sample size (%d)';\r\n\r\n//=== JclStreams =============================================================\r\nresourcestring\r\n RsStreamsCreateError = 'Cannot create file %s';\r\n RsStreamsOpenError = 'Cannot open file %s';\r\n RsStreamsSetSizeError = 'Error setting stream size';\r\n RsStreamsSeekError = 'Error seeking stream';\r\n RsStreamsCRCError = 'Cyclic Redundency Check (CRC) error: data are damaged';\r\n\r\n//=== JclStrHashMap ==========================================================\r\nresourcestring\r\n RsStringHashMapMustBeEmpty = 'HashList: must be empty to set size to zero';\r\n RsStringHashMapDuplicate = 'Duplicate hash list entry: %s';\r\n RsStringHashMapInvalidNode = 'Tried to remove invalid node: %s';\r\n RsStringHashMapNoTraits = 'HashList must have traits';\r\n\r\n//=== JclStrings =============================================================\r\nresourcestring\r\n RsBlankSearchString = 'Search string cannot be blank';\r\n RsInvalidEmptyStringItem = 'String list passed to StringsToMultiSz cannot contain empty strings.';\r\n RsNumericConstantTooLarge = 'Numeric constant too large (%d) at position %d.';\r\n RsFormatException = 'Format exception';\r\n RsDotNetFormatNullFormat = 'Format string is null';\r\n RsArgumentIsNull = 'Argument %d is null';\r\n RsDotNetFormatArgumentNotSupported = 'Argument type of %d is not supported';\r\n RsArgumentOutOfRange = 'Argument out of range';\r\n RsTabs_DuplicatesNotAllowed = 'Duplicate tab stops are not allowed.';\r\n RsTabs_StopExpected = 'A tab stop was expected but not found.';\r\n RsTabs_CloseBracketExpected = 'Closing bracket expected.';\r\n RsTabs_TabWidthExpected = 'Tab width expected.';\r\n // Default text for the NullReferenceException in .NET\r\n RsArg_NullReferenceException = 'Object reference not set to an instance of an object.';\r\n\r\n//=== JclStructStorage =======================================================\r\nresourcestring\r\n RsIStreamNil = 'IStream is nil';\r\n\r\n//=== JclSynch ===============================================================\r\nresourcestring\r\n RsSynchAttachWin32Handle = 'Invalid handle to TJclWin32HandleObject.Attach';\r\n RsSynchDuplicateWin32Handle = 'Invalid handle to TJclWin32HandleObject.Duplicate';\r\n RsSynchInitCriticalSection = 'Failed to initalize critical section';\r\n RsSynchAttachDispatcher = 'Invalid handle to TJclDispatcherObject.Attach';\r\n RsSynchCreateEvent = 'Failed to create event';\r\n RsSynchOpenEvent = 'Failed to open event';\r\n RsSynchCreateWaitableTimer = 'Failed to create waitable timer';\r\n RsSynchOpenWaitableTimer = 'Failed to open waitable timer';\r\n RsSynchCreateSemaphore = 'Failed to create semaphore';\r\n RsSynchOpenSemaphore = 'Failed to open semaphore';\r\n RsSynchCreateMutex = 'Failed to create mutex';\r\n RsSynchOpenMutex = 'Failed to open mutex';\r\n RsMetSectInvalidParameter = 'An invalid parameter was passed to the constructor.';\r\n RsMetSectInitialize = 'Failed to initialize the metered section.';\r\n RsMetSectNameEmpty = 'Name cannot be empty when using the Open constructor.';\r\n\r\n//=== JclSysInfo =============================================================\r\nresourcestring\r\n RsSystemProcess = 'System Process';\r\n RsSystemIdleProcess = 'System Idle Process';\r\n\r\n RsIntelUnknownCache = 'Unknown cache ID (%.2x)';\r\n RsIntelCacheDescr00 = 'Null descriptor';\r\n RsIntelCacheDescr01 = 'Instruction TLB: 4 KByte pages, 4-way set associative, 32 entries';\r\n RsIntelCacheDescr02 = 'Instruction TLB: 4 MByte pages, 4-way set associative, 2 entries';\r\n RsIntelCacheDescr03 = 'Data TLB: 4 KByte pages, 4-way set associative, 64 entries';\r\n RsIntelCacheDescr04 = 'Data TLB: 4 MByte pages, 4-way set associative, 8 entries';\r\n RsIntelCacheDescr05 = 'Data TLB1: 4 MByte pages, 4-way set associative, 32 entries';\r\n RsIntelCacheDescr06 = '1st level instruction cache: 8 KBytes, 4-way set associative, 32 byte line size';\r\n RsIntelCacheDescr08 = '1st level instruction cache: 16 KBytes, 4-way set associative, 32 byte line size';\r\n RsIntelCacheDescr09 = '1st level instruction cache: 32 KBytes, 4-way set associative, 64 byte line size';\r\n RsIntelCacheDescr0A = '1st level data cache: 8 KBytes, 2-way set associative, 32 byte line size';\r\n RsIntelCacheDescr0B = 'Instruction TLB: 4 MByte pages, 4-way set associative, 4 entries';\r\n RsIntelCacheDescr0C = '1st level data cache: 16 KBytes, 4-way set associative, 32 byte line size';\r\n RsIntelCacheDescr0D = '1st level data cache: 16 KBytes, 4-way set associative, 64 byte line size';\r\n RsIntelCacheDescr0E = '1st level data cache: 24 KBytes, 6-way set associative, 64 byte line size';\r\n RsIntelCacheDescr21 = '2nd level cache: 256 KBytes, 8-way set associative, 64 byte line size';\r\n RsIntelCacheDescr22 = '3rd level cache: 512 KBytes, 4-way set associative, 64 byte line size, 2 lines per sector';\r\n RsIntelCacheDescr23 = '3rd level cache: 1 MBytes, 8-way set associative, 64 byte line size, 2 lines per sector';\r\n RsIntelCacheDescr25 = '3rd level cache: 2 MBytes, 8-way set associative, 64 byte line size, 2 lines per sector';\r\n RsIntelCacheDescr29 = '3rd level cache: 4 MBytes, 8-way set associative, 64 byte line size, 2 lines per sector';\r\n RsIntelCacheDescr2C = '1st level data cache: 32 KBytes, 8-way set associative, 64 byte line size';\r\n RsIntelCacheDescr30 = '1st level instruction cache: 32 KBytes, 8-way set associative, 64 byte line size';\r\n RsIntelCacheDescr39 = '2nd-level cache: 128 KBytes, 4-way set associative, sectored cache, 64-byte line size';\r\n RsIntelCacheDescr3A = '2nd-level cache: 192 KBytes, 6-way set associative, sectored cache, 64-byte line size';\r\n RsIntelCacheDescr3B = '2nd-level cache: 128 KBytes, 2-way set associative, sectored cache, 64-byte line size';\r\n RsIntelCacheDescr3C = '2nd-level cache: 256 KBytes, 4-way set associative, sectored cache, 64-byte line size';\r\n RsIntelCacheDescr3D = '2nd-level cache: 384 KBytes, 6-way set associative, sectored cache, 64-byte line size';\r\n RsIntelCacheDescr3E = '2nd-level cache: 512 KBytes, 4-way set associative, sectored cache, 64-byte line size';\r\n RsIntelCacheDescr40 = 'No 2nd-level cache or, if processor contains a valid 2nd-level cache, no 3rd-level cache';\r\n RsIntelCacheDescr41 = '2nd-level cache: 128 KBytes, 4-way set associative, 32 byte line size';\r\n RsIntelCacheDescr42 = '2nd-level cache: 256 KBytes, 4-way set associative, 32 byte line size';\r\n RsIntelCacheDescr43 = '2nd-level cache: 512 KBytes, 4-way set associative, 32 byte line size';\r\n RsIntelCacheDescr44 = '2nd-level cache: 1 MBytes, 4-way set associative, 32 byte line size';\r\n RsIntelCacheDescr45 = '2nd-level cache: 2 MBytes, 4-way set associative, 32 byte line size';\r\n RsIntelCacheDescr46 = '3rd-level cache: 4 MBytes, 4-way set associative, 64 byte line size';\r\n RsIntelCacheDescr47 = '3rd-level cache: 8 MBytes, 4-way set associative, 64 byte line size';\r\n RsIntelCacheDescr48 = '3rd-level cache: 8 MByte, 8-way set associative, 64 byte line size';\r\n RsIntelCacheDescr49 = '2nd-level cache: 4 MBytes, 16-way set associative, 64 byte line size';\r\n RsIntelCacheDescr4A = '3rd-level cache: 6MByte, 12-way set associative, 64 byte line size';\r\n RsIntelCacheDescr4B = '3rd-level cache: 8MByte, 16-way set associative, 64 byte line size';\r\n RsIntelCacheDescr4C = '3rd-level cache: 12MByte, 12-way set associative, 64 byte line size';\r\n RsIntelCacheDescr4D = '3rd-level cache: 16MByte, 16-way set associative, 64 byte line size';\r\n RsIntelCacheDescr4E = '2nd-level cache: 6MByte, 24-way set associative, 64 byte line size';\r\n RsIntelCacheDescr4F = 'Instruction TLB: 4 KByte pages, 32 Entries';\r\n RsIntelCacheDescr50 = 'Instruction TLB: 4 KByte and 2 MByte or 4 MByte pages, 64 Entries';\r\n RsIntelCacheDescr51 = 'Instruction TLB: 4 KByte and 2 MByte or 4 MByte pages, 128 Entries';\r\n RsIntelCacheDescr52 = 'Instruction TLB: 4 KByte and 2 MByte or 4 MByte pages, 256 Entries';\r\n RsIntelCacheDescr55 = 'Instruction TLB: 2-MByte or 4-MByte pages, fully associative, 7 entries';\r\n RsIntelCacheDescr56 = 'Data TLB0: 4 MByte pages, 4-way set associative, 16 entries';\r\n RsIntelCacheDescr57 = 'Data TLB0: 4 KByte pages, 4-way associative, 16 entries';\r\n RsIntelCacheDescr59 = 'Data TLB0: 4 KByte pages, fully associative, 16 entries';\r\n RsIntelCacheDescr5A = 'Data TLB0: 2 MByte or 4 MByte pages, 4-way set associative, 32 entries';\r\n RsIntelCacheDescr5B = 'Data TLB: 4 KByte and 4 MByte pages, 64 Entries';\r\n RsIntelCacheDescr5C = 'Data TLB: 4 KByte and 4 MByte pages, 128 Entries';\r\n RsIntelCacheDescr5D = 'Data TLB: 4 KByte and 4 MByte pages, 256 Entries';\r\n RsIntelCacheDescr60 = '1st-level data cache: 16 KByte, 8-way set associative, 64 byte line size';\r\n RsIntelCacheDescr66 = '1st-level data cache: 8 KBytes, 4-way set associative, 64 byte line size';\r\n RsIntelCacheDescr67 = '1st-level data cache: 16 KBytes, 4-way set associative, 64 byte line size';\r\n RsIntelCacheDescr68 = '1st-level data cache: 32 KBytes, 4-way set associative, 64 byte line size';\r\n RsIntelCacheDescr70 = 'Trace cache: 12 K-Ops, 8-way set associative';\r\n RsIntelCacheDescr71 = 'Trace cache: 16 K-Ops, 8-way set associative';\r\n RsIntelCacheDescr72 = 'Trace cache: 32 K-Ops, 8-way set associative';\r\n RsIntelCacheDescr73 = 'Trace cache: 64 K-Ops, 8-way set associative';\r\n RsIntelCacheDescr76 = 'Instruction TLB: 2M/4M pages, fully associative, 8 entries';\r\n RsIntelCacheDescr78 = '2nd-level cache: 1 MBytes, 4-way set associative, 64 bytes line size';\r\n RsIntelCacheDescr79 = '2nd-level cache: 128 KBytes, 8-way set associative, 64 bytes line size, 2 lines per sector';\r\n RsIntelCacheDescr7A = '2nd-level cache: 256 KBytes, 8-way set associative, 64 bytes line size, 2 lines per sector';\r\n RsIntelCacheDescr7B = '2nd-level cache: 512 KBytes, 8-way set associative, 64 bytes line size, 2 lines per sector';\r\n RsIntelCacheDescr7C = '2nd-level cache: 1 MBytes, 8-way set associative, 64 bytes line size, 2 lines per sector';\r\n RsIntelCacheDescr7D = '2nd-level cache: 2 MBytes, 8-way set associative, 64 byte line size';\r\n RsIntelCacheDescr7F = '2nd-level cache: 512 KBytes, 2-way set associative, 64 byte line size';\r\n RsIntelCacheDescr80 = '2nd-level cache: 512 KBytes, 8-way set associative, 64 byte line size';\r\n RsIntelCacheDescr82 = '2nd-level cache: 256 KBytes, 8-way associative, 32 byte line size';\r\n RsIntelCacheDescr83 = '2nd-level cache: 512 KBytes, 8-way associative, 32 byte line size';\r\n RsIntelCacheDescr84 = '2nd-level cache: 1 MBytes, 8-way associative, 32 byte line size';\r\n RsIntelCacheDescr85 = '2nd-level cache: 2 MBytes, 8-way associative, 32 byte line size';\r\n RsIntelCacheDescr86 = '2nd-level cache: 512 KByte, 4-way set associative, 64 byte line size';\r\n RsIntelCacheDescr87 = '2nd-level cache: 1 MByte, 8-way set associative, 64 byte line size';\r\n RsIntelCacheDescrB0 = 'Instruction TLB: 4 KByte pages, 4-way set associative, 128 entries';\r\n RsIntelCacheDescrB1 = 'Instruction TLB: 2 MByte pages, 4-way, 8 entries or 4 MByte pages, 4-way, 4 entries';\r\n RsIntelCacheDescrB2 = 'Instruction TLB: 4 KByte pages, 4-way set associative, 64 entries';\r\n RsIntelCacheDescrB3 = 'Data TLB: 4 KByte pages, 4-way set associative, 128 entries';\r\n RsIntelCacheDescrB4 = 'Data TLB1: 4 KByte pages, 4-way set associative, 256 entries';\r\n RsIntelCacheDescrBA = 'Data TLB1: 4 KByte pages, 4-way set associative, 64 entries';\r\n RsIntelCacheDescrC0 = 'Data TLB: 4 KByte and 4 MByte pages, 4-way set associative, 8 entries';\r\n RsIntelCacheDescrCA = 'Shared 2nd-Level TLB: 4 KByte pages, 4-way associative, 512 entries';\r\n RsIntelCacheDescrD0 = '3rd-level cache: 512 KByte, 4-way set associative, 64 byte line size';\r\n RsIntelCacheDescrD1 = '3rd-level cache: 1 MByte, 4-way set associative, 64 byte line size';\r\n RsIntelCacheDescrD2 = '3rd-level cache: 2 MByte, 4-way set associative, 64 byte line size';\r\n RsIntelCacheDescrD6 = '3rd-level cache: 1 MByte, 8-way set associative, 64 byte line size';\r\n RsIntelCacheDescrD7 = '3rd-level cache: 2 MByte, 8-way set associative, 64 byte line size';\r\n RsIntelCacheDescrD8 = '3rd-level cache: 4 MByte, 8-way set associative, 64 byte line size';\r\n RsIntelCacheDescrDC = '3rd-level cache: 1.5 MByte, 12-way set associative, 64 byte line size';\r\n RsIntelCacheDescrDD = '3rd-level cache: 3 MByte, 12-way set associative, 64 byte line size';\r\n RsIntelCacheDescrDE = '3rd-level cache: 6 MByte, 12-way set associative, 64 byte line size';\r\n RsIntelCacheDescrE2 = '3rd-level cache: 2 MByte, 16-way set associative, 64 byte line size';\r\n RsIntelCacheDescrE3 = '3rd-level cache: 4 MByte, 16-way set associative, 64 byte line size';\r\n RsIntelCacheDescrE4 = '3rd-level cache: 8 MByte, 16-way set associative, 64 byte line size';\r\n RsIntelCacheDescrEA = '3rd-level cache: 12 MByte, 24-way set associative, 64 byte line size';\r\n RsIntelCacheDescrEB = '3rd-level cache: 18 MByte, 24-way set associative, 64 byte line size';\r\n RsIntelCacheDescrEC = '3rd-level cache: 24 MByte, 24-way set associative, 64 byte line size';\r\n RsIntelCacheDescrF0 = '64-Byte Prefetching';\r\n RsIntelCacheDescrF1 = '128-Byte Prefetching';\r\n RsIntelCacheDescrFF = 'CPUID leaf 2 does not report cache descriptor information, use CPUID leaf 4 to query cache parameters';\r\n\r\n RsUnknownAMDModel = 'Unknown AMD (Model %d)';\r\n\r\n RsOSVersionWin95 = 'Windows 95';\r\n RsOSVersionWin95OSR2 = 'Windows 95 OSR2';\r\n RsOSVersionWin98 = 'Windows 98';\r\n RsOSVersionWin98SE = 'Windows 98 SE';\r\n RsOSVersionWinME = 'Windows ME';\r\n RsOSVersionWinNT3 = 'Windows NT 3.%u';\r\n RsOSVersionWinNT4 = 'Windows NT 4.%u';\r\n RsOSVersionWin2000 = 'Windows 2000';\r\n RsOSVersionWinXP = 'Windows XP';\r\n RsOSVersionWin2003 = 'Windows Server 2003';\r\n RsOSVersionWin2003R2 = 'Windows Server 2003 R2';\r\n RsOSVersionWinXP64 = 'Windows XP x64';\r\n RsOSVersionWinVista = 'Windows Vista';\r\n RsOSVersionWinServer2008 = 'Windows Server 2008';\r\n RsOSVersionWin7 = 'Windows 7';\r\n RsOSVersionWinServer2008R2 = 'Windows Server 2008 R2';\r\n RsOSVersionWin8 = 'Windows 8';\r\n RsOSVersionWinServer2012 = 'Windows Server 2012';\r\n\r\n RsEditionWinXPHome = 'Home Edition';\r\n RsEditionWinXPPro = 'Professional';\r\n RsEditionWinXPHomeN = 'Home Edition N';\r\n RsEditionWinXPProN = 'Professional N';\r\n RsEditionWinXPHomeK = 'Home Edition K';\r\n RsEditionWinXPProK = 'Professional K';\r\n RsEditionWinXPHomeKN = 'Home Edition KN';\r\n RsEditionWinXPProKN = 'Professional KN';\r\n RsEditionWinXPStarter = 'Starter Edition';\r\n RsEditionWinXPMediaCenter = 'Media Center Edition';\r\n RsEditionWinXPTablet = 'Tablet PC Edition';\r\n RsEditionWinVistaStarter = 'Starter';\r\n RsEditionWinVistaHomeBasic = 'Home Basic';\r\n RsEditionWinVistaHomeBasicN = 'Home Basic N';\r\n RsEditionWinVistaHomePremium = 'Home Premium';\r\n RsEditionWinVistaBusiness = 'Business';\r\n RsEditionWinVistaBusinessN = 'Business N';\r\n RsEditionWinVistaEnterprise = 'Enterprise';\r\n RsEditionWinVistaUltimate = 'Ultimate';\r\n RsEditionWin7Starter = 'Starter';\r\n RsEditionWin7HomeBasic = 'Home Basic';\r\n RsEditionWin7HomePremium = 'Home Premium';\r\n RsEditionWin7Professional = 'Professional';\r\n RsEditionWin7Enterprise = 'Enterprise';\r\n RsEditionWin7Ultimate = 'Ultimate';\r\n\r\n RsProductTypeWorkStation = 'Workstation';\r\n RsProductTypeServer = 'Server';\r\n RsProductTypeAdvancedServer = 'Advanced Server';\r\n RsProductTypePersonal = 'Home Edition';\r\n RsProductTypeProfessional = 'Professional';\r\n RsProductTypeDatacenterServer = 'Datacenter Server';\r\n RsProductTypeEnterprise = 'Enterprise';\r\n RsProductTypeWebEdition = 'Web Edition';\r\n\r\n RsEOpenGLInfo = 'GetOpenGLVersion: %s failed';\r\n RsENetWkstaGetInfo = 'NetWkstaGetInfo failed';\r\n\r\n {$IFDEF MSWINDOWS}\r\n RsSPInfo = 'SP%u';\r\n {$ENDIF MSWINDOWS}\r\n\r\n {$IFDEF UNIX}\r\n RsInvalidProcessID = 'Invalid process ID %d';\r\n {$ENDIF UNIX}\r\n\r\n RsOpenGLInfoError = 'Err';\r\n\r\n//=== JclSysUtils ============================================================\r\nresourcestring\r\n RsVMTMemoryWriteError = 'Error writing VMT memory (%s)';\r\n RsCannotWriteRefStream = 'Can not write to a read-only memory stream';\r\n RsStringToBoolean = 'Unable to convert the string \"%s\" to a boolean';\r\n RsInvalidDigit = 'Invalid base %d digit ''%s'' encountered.';\r\n RsInvalidDigitValue = 'There is no valid base %d digit for decimal value %d';\r\n\r\n {$IFDEF UNIX}\r\n RsReadKeyError = 'ReadKey: Problem waiting on stdin';\r\n {$ENDIF UNIX}\r\n\r\n RsInvalidGUIDString = 'Invalid conversion from string to GUID (%s).';\r\n\r\n RsInvalidMMFName = 'Invalid MMF name \"%s\"';\r\n RsInvalidMMFEmpty = 'The MMF named \"%s\" cannot be created empty';\r\n\r\n//=== JclTD32 ================================================================\r\nresourcestring\r\n RsHasNotTD32Info = 'File [%s] has not TD32 debug information!';\r\n\r\n//=== JclTimeZones ===========================================================\r\nresourcestring\r\n RsEDaylightSavingsNotSupported = 'Daylight Savings not supported by this timezone';\r\n RsEAutoAdjustNotEnabled = 'Auto adjust for Daylight Savings is not enabled. Date is not available';\r\n RsENoCallbackFunc = 'No callback function assigned';\r\n\r\n//=== JclUnicode =============================================================\r\nresourcestring\r\n RsUREErrorFmt = '%s%s%s';\r\n RsUREBaseString = 'Error in regular expression: %s' + sLineBreak;\r\n RsUREUnexpectedEOS = 'Unexpected end of pattern.';\r\n RsURECharacterClassOpen = 'Character class not closed, '']'' is missing.';\r\n RsUREUnbalancedGroup = 'Unbalanced group expression, '')'' is missing.';\r\n RsUREInvalidCharProperty = 'A character property is invalid';\r\n RsUREInvalidRepeatRange = 'Invalid repetition range.';\r\n RsURERepeatRangeOpen = 'Repetition range not closed, ''}'' is missing.';\r\n RsUREExpressionEmpty = 'Expression is empty.';\r\n RsCategoryUnicodeChar = 'category Unicode character > $FFFFFF found';\r\n RsCasedUnicodeChar = 'cased Unicode character > $FFFFFF found';\r\n RsDecomposedUnicodeChar = 'decomposed Unicode character > $FFFFFF found';\r\n RsCombiningClassUnicodeChar = 'combining class for Unicode character > $FFFFFF found';\r\n RsEUnexpectedEOSeq = 'Unexpected end of sequence';\r\n\r\n//=== JclUnitConv ============================================================\r\nresourcestring\r\n RsTempConvTypeError = 'An invalid type has been provided for the %s parameter';\r\n RsConvTempBelowAbsoluteZero = 'Temperature can not be below Absolute Zero!';\r\n\r\n//=== JclWin32 ===============================================================\r\nresourcestring\r\n RsWin32Error = 'Win32 error: %s (%u)%s%s';\r\n RsELibraryNotFound = 'Library not found: %s';\r\n RsEFunctionNotFound = 'Function not found: %s.%s';\r\n\r\n//=== JclWinMidi =============================================================\r\nresourcestring\r\n RsMidiInUnknownError = 'Unknown MIDI-In error No. %d';\r\n RsMidiOutUnknownError = 'Unknown MIDI-Out error No. %d';\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jcl.svn.sourceforge.net/svnroot/jcl/tags/JCL-2.4-Build4571/jcl/source/common/JclResources.pas $';\r\n Revision: '$Revision: 3850 $';\r\n Date: '$Date: 2012-08-28 16:44:17 +0200 (mar. 28 août 2012) $';\r\n LogPath: 'JCL\\source\\common';\r\n Extra: '';\r\n Data: nil\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jcl/source/common/JclSchedule.pas", "content": "{**************************************************************************************************}\r\n{ }\r\n{ Project JEDI Code Library (JCL) }\r\n{ }\r\n{ The contents of this file are subject to the Mozilla Public License Version 1.1 (the \"License\"); }\r\n{ you may not use this file except in compliance with the License. You may obtain a copy of the }\r\n{ License at http://www.mozilla.org/MPL/ }\r\n{ }\r\n{ Software distributed under the License is distributed on an \"AS IS\" basis, WITHOUT WARRANTY OF }\r\n{ ANY KIND, either express or implied. See the License for the specific language governing rights }\r\n{ and limitations under the License. }\r\n{ }\r\n{ The Original Code is JclSchedule.pas. }\r\n{ }\r\n{ The Initial Developer of the Original Code is Marcel Bestebroer. }\r\n{ Portions created Marcel Bestebroer are Copyright (C) Marcel Bestebroer. All rights reserved. }\r\n{ }\r\n{ Contributor(s): }\r\n{ Marcel Bestebroer (marcelb) }\r\n{ Robert Rossmair (rrossmair) }\r\n{ Petr Vones (pvones) }\r\n{ }\r\n{**************************************************************************************************}\r\n{ }\r\n{ This unit contains scheduler classes. }\r\n{ }\r\n{**************************************************************************************************}\r\n{ }\r\n{ Last modified: $Date:: 2011-09-03 00:07:50 +0200 (sam. 03 sept. 2011) $ }\r\n{ Revision: $Rev:: 3599 $ }\r\n{ Author: $Author:: outchy $ }\r\n{ }\r\n{**************************************************************************************************}\r\n\r\nunit JclSchedule;\r\n\r\n{$I jcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n {$IFDEF HAS_UNITSCOPE}\r\n System.SysUtils,\r\n {$ELSE ~HAS_UNITSCOPE}\r\n SysUtils,\r\n {$ENDIF ~HAS_UNITSCOPE}\r\n JclBase;\r\n\r\ntype\r\n TScheduleRecurringKind = (srkOneShot, srkDaily, srkWeekly, srkMonthly, srkYearly);\r\n TScheduleEndKind = (sekNone, sekDate, sekTriggerCount, sekDayCount);\r\n TScheduleWeekDay = (swdMonday, swdTuesday, swdWednesday, swdThursday, swdFriday, swdSaturday,\r\n swdSunday);\r\n TScheduleWeekDays = set of TScheduleWeekDay;\r\n TScheduleIndexKind = (sikNone, sikDay, sikWeekDay, sikWeekendDay, sikMonday, sikTuesday,\r\n sikWednesday, sikThursday, sikFriday, sikSaturday, sikSunday);\r\n\r\nconst\r\n sivFirst = 1;\r\n sivSecond = 2;\r\n sivThird = 3;\r\n sivFourth = 4;\r\n sivLast = -1;\r\n\r\ntype\r\n // Forwards\r\n IJclSchedule = interface;\r\n IJclDailySchedule = interface;\r\n IJclWeeklySchedule = interface;\r\n IJclMonthlySchedule = interface;\r\n IJclYearlySchedule = interface;\r\n\r\n EJclScheduleError = class(EJclError);\r\n ESchedule = EJclScheduleError;\r\n\r\n IJclSchedule = interface(IUnknown)\r\n ['{1CC54450-7F84-4F27-B1C1-418C451DAD80}']\r\n function GetStartDate: TTimeStamp;\r\n function GetRecurringType: TScheduleRecurringKind;\r\n function GetEndType: TScheduleEndKind;\r\n function GetEndDate: TTimeStamp;\r\n function GetEndCount: Cardinal;\r\n procedure SetStartDate(const Value: TTimeStamp);\r\n procedure SetRecurringType(Value: TScheduleRecurringKind);\r\n procedure SetEndType(Value: TScheduleEndKind);\r\n procedure SetEndDate(const Value: TTimeStamp);\r\n procedure SetEndCount(Value: Cardinal);\r\n\r\n function TriggerCount: Cardinal;\r\n function DayCount: Cardinal;\r\n function LastTriggered: TTimeStamp;\r\n\r\n procedure InitToSavedState(const LastTriggerStamp: TTimeStamp; const LastTriggerCount,\r\n LastDayCount: Cardinal);\r\n procedure Reset;\r\n function NextEvent(CountMissedEvents: Boolean = False): TTimeStamp;\r\n function NextEventFrom(const FromEvent: TTimeStamp; CountMissedEvent: Boolean = False): TTimeStamp;\r\n function NextEventFromNow(CountMissedEvents: Boolean = False): TTimeStamp;\r\n\r\n property StartDate: TTimeStamp read GetStartDate write SetStartDate;\r\n property RecurringType: TScheduleRecurringKind read GetRecurringType write SetRecurringType;\r\n property EndType: TScheduleEndKind read GetEndType write SetEndType;\r\n property EndDate: TTimeStamp read GetEndDate write SetEndDate;\r\n property EndCount: Cardinal read GetEndCount write SetEndCount;\r\n end;\r\n\r\n IJclScheduleDayFrequency = interface(IUnknown)\r\n ['{6CF37F0D-56F4-4AE6-BBCA-7B9DFE60F50D}']\r\n function GetStartTime: Cardinal;\r\n function GetEndTime: Cardinal;\r\n function GetInterval: Cardinal;\r\n procedure SetStartTime(Value: Cardinal);\r\n procedure SetEndTime(Value: Cardinal);\r\n procedure SetInterval(Value: Cardinal);\r\n\r\n property StartTime: Cardinal read GetStartTime write SetStartTime;\r\n property EndTime: Cardinal read GetEndTime write SetEndTime;\r\n property Interval: Cardinal read GetInterval write SetInterval;\r\n end;\r\n\r\n IJclDailySchedule = interface(IUnknown)\r\n ['{540E22C5-BE14-4539-AFB3-E24A67C58D8A}']\r\n function GetEveryWeekDay: Boolean;\r\n function GetInterval: Cardinal;\r\n procedure SetEveryWeekDay(Value: Boolean);\r\n procedure SetInterval(Value: Cardinal);\r\n\r\n property EveryWeekDay: Boolean read GetEveryWeekDay write SetEveryWeekDay;\r\n property Interval: Cardinal read GetInterval write SetInterval;\r\n end;\r\n\r\n IJclWeeklySchedule = interface(IUnknown)\r\n ['{73F15D99-C6A1-4526-8DE3-A2110E099BBC}']\r\n function GetDaysOfWeek: TScheduleWeekDays;\r\n function GetInterval: Cardinal;\r\n procedure SetDaysOfWeek(Value: TScheduleWeekDays);\r\n procedure SetInterval(Value: Cardinal);\r\n\r\n property DaysOfWeek: TScheduleWeekDays read GetDaysOfWeek write SetDaysOfWeek;\r\n property Interval: Cardinal read GetInterval write SetInterval;\r\n end;\r\n\r\n IJclMonthlySchedule = interface(IUnknown)\r\n ['{705E17FC-83E6-4385-8D2D-17013052E9B3}']\r\n function GetIndexKind: TScheduleIndexKind;\r\n function GetIndexValue: Integer;\r\n function GetDay: Cardinal;\r\n function GetInterval: Cardinal;\r\n procedure SetIndexKind(Value: TScheduleIndexKind);\r\n procedure SetIndexValue(Value: Integer);\r\n procedure SetDay(Value: Cardinal);\r\n procedure SetInterval(Value: Cardinal);\r\n\r\n property IndexKind: TScheduleIndexKind read GetIndexKind write SetIndexKind;\r\n property IndexValue: Integer read GetIndexValue write SetIndexValue;\r\n property Day: Cardinal read GetDay write SetDay;\r\n property Interval: Cardinal read GetInterval write SetInterval;\r\n end;\r\n\r\n IJclYearlySchedule = interface(IUnknown)\r\n ['{3E5303B0-FFA0-495A-96BB-14A718A01C1B}']\r\n function GetIndexKind: TScheduleIndexKind;\r\n function GetIndexValue: Integer;\r\n function GetDay: Cardinal;\r\n function GetMonth: Cardinal;\r\n function GetInterval: Cardinal;\r\n procedure SetIndexKind(Value: TScheduleIndexKind);\r\n procedure SetIndexValue(Value: Integer);\r\n procedure SetDay(Value: Cardinal);\r\n procedure SetMonth(Value: Cardinal);\r\n procedure SetInterval(Value: Cardinal);\r\n\r\n property IndexKind: TScheduleIndexKind read GetIndexKind write SetIndexKind;\r\n property IndexValue: Integer read GetIndexValue write SetIndexValue;\r\n property Day: Cardinal read GetDay write SetDay;\r\n property Month: Cardinal read GetMonth write SetMonth;\r\n property Interval: Cardinal read GetInterval write SetInterval;\r\n end;\r\n\r\nfunction CreateSchedule: IJclSchedule;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jcl.svn.sourceforge.net/svnroot/jcl/tags/JCL-2.4-Build4571/jcl/source/common/JclSchedule.pas $';\r\n Revision: '$Revision: 3599 $';\r\n Date: '$Date: 2011-09-03 00:07:50 +0200 (sam. 03 sept. 2011) $';\r\n LogPath: 'JCL\\source\\common';\r\n Extra: '';\r\n Data: nil\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n JclDateTime, JclResources;\r\n\r\n//=== { TJclScheduleAggregate } ==============================================\r\n\r\ntype\r\n TJclScheduleAggregate = class(TAggregatedObject)\r\n protected\r\n procedure CheckInterfaceAllowed;\r\n function InterfaceAllowed: Boolean;\r\n function Schedule: IJclSchedule;\r\n class function RecurringType: TScheduleRecurringKind; virtual;\r\n\r\n function ValidStamp(const Stamp: TTimeStamp): Boolean; virtual; abstract;\r\n procedure MakeValidStamp(var Stamp: TTimeStamp); virtual; abstract;\r\n function NextValidStamp(const Stamp: TTimeStamp): TTimeStamp; virtual; abstract;\r\n end;\r\n\r\nprocedure TJclScheduleAggregate.CheckInterfaceAllowed;\r\nbegin\r\n if not InterfaceAllowed then\r\n RunError(23); // reIntfCastError\r\nend;\r\n\r\nfunction TJclScheduleAggregate.InterfaceAllowed: Boolean;\r\nbegin\r\n Result := Schedule.RecurringType = RecurringType;\r\nend;\r\n\r\nfunction TJclScheduleAggregate.Schedule: IJclSchedule;\r\nbegin\r\n Result := Controller as IJclSchedule;\r\nend;\r\n\r\nclass function TJclScheduleAggregate.RecurringType: TScheduleRecurringKind;\r\nbegin\r\n Result := srkOneShot;\r\nend;\r\n\r\n//=== { TJclDayFrequency } ===================================================\r\n\r\ntype\r\n TJclDayFrequency = class(TAggregatedObject, IJclScheduleDayFrequency, IInterface)\r\n private\r\n FStartTime: Cardinal;\r\n FEndTime: Cardinal;\r\n FInterval: Cardinal;\r\n protected\r\n function ValidStamp(const Stamp: TTimeStamp): Boolean;\r\n function NextValidStamp(const Stamp: TTimeStamp): TTimeStamp;\r\n public\r\n constructor Create(const Controller: IUnknown);\r\n { IJclScheduleDayFrequency }\r\n function GetStartTime: Cardinal;\r\n function GetEndTime: Cardinal;\r\n function GetInterval: Cardinal;\r\n procedure SetStartTime(Value: Cardinal);\r\n procedure SetEndTime(Value: Cardinal);\r\n procedure SetInterval(Value: Cardinal);\r\n\r\n property StartTime: Cardinal read GetStartTime write SetStartTime;\r\n property EndTime: Cardinal read GetEndTime write SetEndTime;\r\n property Interval: Cardinal read GetInterval write SetInterval;\r\n end;\r\n\r\nconstructor TJclDayFrequency.Create(const Controller: IUnknown);\r\nbegin\r\n inherited Create(Controller);\r\n FStartTime := 0;\r\n FEndTime := HoursToMSecs(24) - 1;\r\n FInterval := 500;\r\nend;\r\n\r\nfunction TJclDayFrequency.ValidStamp(const Stamp: TTimeStamp): Boolean;\r\nbegin\r\n Result := (Cardinal(Stamp.Time) >= FStartTime) and (Cardinal(Stamp.Time) <= FEndTime) and\r\n ((Cardinal(Stamp.Time) - FStartTime) mod FInterval = 0);\r\nend;\r\n\r\nfunction TJclDayFrequency.NextValidStamp(const Stamp: TTimeStamp): TTimeStamp;\r\nbegin\r\n Result := Stamp;\r\n if Stamp.Time < Integer(FStartTime) then\r\n Result.Time := FStartTime\r\n else\r\n if ((Cardinal(Stamp.Time) - FStartTime) mod FInterval) <> 0 then\r\n Result.Time := Stamp.Time + Integer(FInterval-(Cardinal(Stamp.Time) - FStartTime) mod FInterval)\r\n else\r\n Result.Time := Stamp.Time + Integer(FInterval);\r\n if (Result.Time < 0) or (Cardinal(Result.Time) > FEndTime) then\r\n Result := NullStamp;\r\nend;\r\n\r\nfunction TJclDayFrequency.GetStartTime: Cardinal;\r\nbegin\r\n Result := FStartTime;\r\nend;\r\n\r\nfunction TJclDayFrequency.GetEndTime: Cardinal;\r\nbegin\r\n Result := FEndTime;\r\nend;\r\n\r\nfunction TJclDayFrequency.GetInterval: Cardinal;\r\nbegin\r\n Result := FInterval;\r\nend;\r\n\r\nprocedure TJclDayFrequency.SetStartTime(Value: Cardinal);\r\nbegin\r\n if Value <> FStartTime then\r\n begin\r\n if Value >= Cardinal(HoursToMSecs(24)) then\r\n raise EJclScheduleError.CreateRes(@RsScheduleInvalidTime);\r\n FStartTime := Value;\r\n if EndTime < StartTime then\r\n FEndTime := Value;\r\n end;\r\nend;\r\n\r\nprocedure TJclDayFrequency.SetEndTime(Value: Cardinal);\r\nbegin\r\n if Value <> FEndTime then\r\n begin\r\n if Value < FStartTime then\r\n raise EJclScheduleError.CreateRes(@RsScheduleEndBeforeStart);\r\n if Value >= Cardinal(HoursToMSecs(24)) then\r\n raise EJclScheduleError.CreateRes(@RsScheduleInvalidTime);\r\n FEndTime := Value;\r\n end;\r\nend;\r\n\r\nprocedure TJclDayFrequency.SetInterval(Value: Cardinal);\r\nbegin\r\n if Value <> FInterval then\r\n begin\r\n if Value >= Cardinal(HoursToMSecs(24)) then\r\n raise EJclScheduleError.CreateRes(@RsScheduleInvalidTime);\r\n if Value = 0 then\r\n begin\r\n FEndTime := FStartTime;\r\n FInterval := 1;\r\n end\r\n else\r\n FInterval := Value;\r\n end;\r\nend;\r\n\r\n//=== { TJclDailySchedule } ==================================================\r\n\r\ntype\r\n TJclDailySchedule = class(TJclScheduleAggregate, IJclDailySchedule, IInterface)\r\n private\r\n FEveryWeekDay: Boolean;\r\n FInterval: Cardinal;\r\n protected\r\n class function RecurringType: TScheduleRecurringKind; override;\r\n\r\n function ValidStamp(const Stamp: TTimeStamp): Boolean; override;\r\n procedure MakeValidStamp(var Stamp: TTimeStamp); override;\r\n function NextValidStamp(const Stamp: TTimeStamp): TTimeStamp; override;\r\n public\r\n constructor Create(const Controller: IUnknown);\r\n { IJclDailySchedule }\r\n function GetEveryWeekDay: Boolean;\r\n function GetInterval: Cardinal;\r\n procedure SetEveryWeekDay(Value: Boolean);\r\n procedure SetInterval(Value: Cardinal);\r\n\r\n property EveryWeekDay: Boolean read GetEveryWeekDay write SetEveryWeekDay;\r\n property Interval: Cardinal read GetInterval write SetInterval;\r\n end;\r\n\r\nconstructor TJclDailySchedule.Create(const Controller: IUnknown);\r\nbegin\r\n inherited Create(Controller);\r\n FEveryWeekDay := True;\r\n FInterval := 1;\r\nend;\r\n\r\nclass function TJclDailySchedule.RecurringType: TScheduleRecurringKind;\r\nbegin\r\n Result := srkDaily;\r\nend;\r\n\r\nfunction TJclDailySchedule.ValidStamp(const Stamp: TTimeStamp): Boolean;\r\nbegin\r\n Result := (FEveryWeekDay and (TimeStampDOW(Stamp) < 6)) or\r\n (not FEveryWeekDay and (Cardinal(Stamp.Date - Schedule.StartDate.Date) mod Interval = 0));\r\nend;\r\n\r\nprocedure TJclDailySchedule.MakeValidStamp(var Stamp: TTimeStamp);\r\nbegin\r\n if FEveryWeekDay and (TimeStampDOW(Stamp) >= 6) then\r\n Inc(Stamp.Date, 2 - (TimeStampDOW(Stamp) - 6))\r\n else\r\n if not FEveryWeekDay and (Cardinal(Stamp.Date - Schedule.StartDate.Date) mod Interval <> 0) then\r\n Inc(Stamp.Date, Interval - Cardinal(Stamp.Date - Schedule.StartDate.Date) mod Interval);\r\nend;\r\n\r\nfunction TJclDailySchedule.NextValidStamp(const Stamp: TTimeStamp): TTimeStamp;\r\nbegin\r\n Result := Stamp;\r\n MakeValidStamp(Result);\r\n if EqualTimeStamps(Stamp, Result) then\r\n begin\r\n // Time stamp has not been adjusted (it was valid). Determine the next time stamp\r\n if FEveryWeekDay then\r\n begin\r\n Inc(Result.Date);\r\n MakeValidStamp(Result); // Skip over the weekend.\r\n end\r\n else\r\n Inc(Result.Date, Interval); // always valid as we started with a valid stamp\r\n end;\r\nend;\r\n\r\nfunction TJclDailySchedule.GetEveryWeekDay: Boolean;\r\nbegin\r\n CheckInterfaceAllowed;\r\n Result := FEveryWeekDay;\r\nend;\r\n\r\nfunction TJclDailySchedule.GetInterval: Cardinal;\r\nbegin\r\n CheckInterfaceAllowed;\r\n if EveryWeekDay then\r\n Result := 0\r\n else\r\n Result := FInterval;\r\nend;\r\n\r\nprocedure TJclDailySchedule.SetEveryWeekDay(Value: Boolean);\r\nbegin\r\n CheckInterfaceAllowed;\r\n FEveryWeekDay := Value;\r\nend;\r\n\r\nprocedure TJclDailySchedule.SetInterval(Value: Cardinal);\r\nbegin\r\n CheckInterfaceAllowed;\r\n if Value = 0 then\r\n raise EJclScheduleError.CreateRes(@RsScheduleIntervalZero);\r\n if FEveryWeekDay then\r\n FEveryWeekDay := False;\r\n if Value <> FInterval then\r\n FInterval := Value;\r\nend;\r\n\r\n//=== { TJclWeeklySchedule } =================================================\r\n\r\ntype\r\n TJclWeeklySchedule = class(TJclScheduleAggregate, IJclWeeklySchedule, IInterface)\r\n private\r\n FDaysOfWeek: TScheduleWeekDays;\r\n FInterval: Cardinal;\r\n protected\r\n class function RecurringType: TScheduleRecurringKind; override;\r\n\r\n function ValidStamp(const Stamp: TTimeStamp): Boolean; override;\r\n procedure MakeValidStamp(var Stamp: TTimeStamp); override;\r\n function NextValidStamp(const Stamp: TTimeStamp): TTimeStamp; override;\r\n public\r\n constructor Create(const Controller: IUnknown);\r\n { IJclWeeklySchedule }\r\n function GetDaysOfWeek: TScheduleWeekDays;\r\n function GetInterval: Cardinal;\r\n procedure SetDaysOfWeek(Value: TScheduleWeekDays);\r\n procedure SetInterval(Value: Cardinal);\r\n\r\n property DaysOfWeek: TScheduleWeekDays read GetDaysOfWeek write SetDaysOfWeek;\r\n property Interval: Cardinal read GetInterval write SetInterval;\r\n end;\r\n\r\nconstructor TJclWeeklySchedule.Create(const Controller: IUnknown);\r\nbegin\r\n inherited Create(Controller);\r\n FDaysOfWeek := [swdMonday];\r\n FInterval := 1;\r\nend;\r\n\r\nclass function TJclWeeklySchedule.RecurringType: TScheduleRecurringKind;\r\nbegin\r\n Result := srkWeekly;\r\nend;\r\n\r\nfunction TJclWeeklySchedule.ValidStamp(const Stamp: TTimeStamp): Boolean;\r\nbegin\r\n Result := (TScheduleWeekDay(TimeStampDOW(Stamp)) in DaysOfWeek) and\r\n (Cardinal((Stamp.Date - Schedule.StartDate.Date) div 7) mod Interval = 0);\r\nend;\r\n\r\nprocedure TJclWeeklySchedule.MakeValidStamp(var Stamp: TTimeStamp);\r\nbegin\r\n while not (TScheduleWeekDay(TimeStampDOW(Stamp) - 1) in DaysOfWeek) do\r\n Inc(Stamp.Date);\r\n if (Stamp.Date - Schedule.StartDate.Date) <> 0 then\r\n begin\r\n if Cardinal((Stamp.Date - Schedule.StartDate.Date) div 7) mod Interval <> 0 then\r\n Inc(Stamp.Date, 7 * (Interval -\r\n (Cardinal((Stamp.Date - Schedule.StartDate.Date) div 7) mod Interval)));\r\n end;\r\nend;\r\n\r\nfunction TJclWeeklySchedule.NextValidStamp(const Stamp: TTimeStamp): TTimeStamp;\r\nbegin\r\n Result := Stamp;\r\n MakeValidStamp(Result);\r\n if EqualTimeStamps(Stamp, Result) then\r\n begin\r\n // Time stamp has not been adjusted (it was valid). Determine the next time stamp\r\n Inc(Result.Date);\r\n MakeValidStamp(Result); // Skip over unwanted days and weeks\r\n end;\r\nend;\r\n\r\nfunction TJclWeeklySchedule.GetDaysOfWeek: TScheduleWeekDays;\r\nbegin\r\n CheckInterfaceAllowed;\r\n Result := FDaysOfWeek;\r\nend;\r\n\r\nfunction TJclWeeklySchedule.GetInterval: Cardinal;\r\nbegin\r\n CheckInterfaceAllowed;\r\n Result := FInterval;\r\nend;\r\n\r\nprocedure TJclWeeklySchedule.SetDaysOfWeek(Value: TScheduleWeekDays);\r\nbegin\r\n CheckInterfaceAllowed;\r\n if Value = [] then\r\n raise EJclScheduleError.CreateRes(@RsScheduleNoDaySpecified);\r\n FDaysOfWeek := Value;\r\nend;\r\n\r\nprocedure TJclWeeklySchedule.SetInterval(Value: Cardinal);\r\nbegin\r\n CheckInterfaceAllowed;\r\n if Value = 0 then\r\n raise EJclScheduleError.CreateRes(@RsScheduleIntervalZero);\r\n FInterval := Value;\r\nend;\r\n\r\n//=== { TJclMonthlySchedule } ================================================\r\n\r\ntype\r\n TJclMonthlySchedule = class(TJclScheduleAggregate, IJclMonthlySchedule, IInterface)\r\n private\r\n FIndexKind: TScheduleIndexKind;\r\n FIndexValue: Integer;\r\n FDay: Cardinal;\r\n FInterval: Cardinal;\r\n protected\r\n class function RecurringType: TScheduleRecurringKind; override;\r\n\r\n function ValidStamp(const Stamp: TTimeStamp): Boolean; override;\r\n procedure MakeValidStamp(var Stamp: TTimeStamp); override;\r\n function NextValidStamp(const Stamp: TTimeStamp): TTimeStamp; override;\r\n\r\n function ValidStampMonthIndex(const TYear, TMonth, TDay: Word): Boolean;\r\n procedure MakeValidStampMonthIndex(var TYear, TMonth, TDay: Word);\r\n public\r\n constructor Create(const Controller: IUnknown);\r\n { IJclMonthlySchedule }\r\n function GetIndexKind: TScheduleIndexKind;\r\n function GetIndexValue: Integer;\r\n function GetDay: Cardinal;\r\n function GetInterval: Cardinal;\r\n procedure SetIndexKind(Value: TScheduleIndexKind);\r\n procedure SetIndexValue(Value: Integer);\r\n procedure SetDay(Value: Cardinal); \r\n procedure SetInterval(Value: Cardinal);\r\n\r\n property IndexKind: TScheduleIndexKind read GetIndexKind write SetIndexKind;\r\n property IndexValue: Integer read GetIndexValue write SetIndexValue;\r\n property Day: Cardinal read GetDay write SetDay;\r\n property Interval: Cardinal read GetInterval write SetInterval;\r\n end;\r\n\r\nconstructor TJclMonthlySchedule.Create(const Controller: IUnknown);\r\nbegin\r\n inherited Create(Controller);\r\n FIndexKind := sikNone;\r\n FIndexValue := sivFirst;\r\n FDay := 1;\r\n FInterval := 1;\r\nend;\r\n\r\nclass function TJclMonthlySchedule.RecurringType: TScheduleRecurringKind;\r\nbegin\r\n Result := srkMonthly;\r\nend;\r\n\r\nfunction TJclMonthlySchedule.ValidStamp(const Stamp: TTimeStamp): Boolean;\r\nvar\r\n SYear, SMonth, SDay: Word;\r\n TYear, TMonth, TDay: Word;\r\nbegin\r\n DecodeDate(TimeStampToDateTime(Schedule.StartDate), SYear, SMonth, SDay);\r\n DecodeDate(TimeStampToDateTime(Stamp), TYear, TMonth, TDay);\r\n Result := (((TYear * 12 + TMonth) - (SYear * 12 + SMonth)) mod Integer(Interval) = 0) and\r\n ValidStampMonthIndex(TYear, TMonth, TDay);\r\nend;\r\n\r\nprocedure TJclMonthlySchedule.MakeValidStamp(var Stamp: TTimeStamp);\r\nvar\r\n SYear, SMonth, SDay: Word;\r\n TYear, TMonth, TDay: Word;\r\n MonthDiff: Integer;\r\nbegin\r\n DecodeDate(TimeStampToDateTime(Schedule.StartDate), SYear, SMonth, SDay);\r\n DecodeDate(TimeStampToDateTime(Stamp), TYear, TMonth, TDay);\r\n MonthDiff := (TYear * 12 + TMonth) - (SYear * 12 + SMonth);\r\n if MonthDiff mod Integer(Interval) <> 0 then\r\n begin\r\n Inc(TMonth, Integer(Interval) - (MonthDiff mod Integer(Interval)));\r\n if TMonth > 12 then\r\n begin\r\n Inc(TYear, TMonth div 12);\r\n TMonth := TMonth mod 12;\r\n end;\r\n TDay := 1;\r\n end;\r\n MakeValidStampMonthIndex(TYear, TMonth, TDay);\r\n while DateTimeToTimeStamp(JclDateTime.EncodeDate(TYear, TMonth, TDay)).Date < Stamp.Date do\r\n begin\r\n Inc(TMonth, Integer(Interval));\r\n if TMonth > 12 then\r\n begin\r\n Inc(TYear, TMonth div 12);\r\n TMonth := TMonth mod 12;\r\n end;\r\n MakeValidStampMonthIndex(TYear, TMonth, TDay);\r\n end;\r\n Stamp.Date := DateTimeToTimeStamp(JclDateTime.EncodeDate(TYear, TMonth, TDay)).Date;\r\nend;\r\n\r\nfunction TJclMonthlySchedule.NextValidStamp(const Stamp: TTimeStamp): TTimeStamp;\r\nbegin\r\n Result := Stamp;\r\n MakeValidStamp(Result);\r\n if EqualTimeStamps(Stamp, Result) then\r\n begin\r\n // Time stamp has not been adjusted (it was valid). Determine the next time stamp\r\n Inc(Result.Date);\r\n MakeValidStamp(Result); // Skip over unwanted days and months\r\n end;\r\nend;\r\n\r\nfunction TJclMonthlySchedule.ValidStampMonthIndex(const TYear, TMonth, TDay: Word): Boolean;\r\nvar\r\n DIM: Integer;\r\n TempDay: Integer;\r\nbegin\r\n DIM := DaysInMonth(JclDateTime.EncodeDate(TYear, TMonth, 1));\r\n case IndexKind of\r\n sikNone:\r\n Result := (TDay = Day) or ((Integer(Day) > DIM) and (TDay = DIM));\r\n sikDay:\r\n Result :=\r\n ((IndexValue = sivLast) and (TDay = DIM)) or\r\n ((IndexValue <> sivLast) and (\r\n (TDay = IndexValue) or (\r\n (IndexValue > DIM) and\r\n (TDay = DIM)\r\n ) or (\r\n (IndexValue < 0) and (\r\n (TDay = DIM + 1 + IndexValue) or (\r\n (-IndexValue > DIM) and\r\n (TDay = 1)\r\n )\r\n )\r\n )\r\n ));\r\n sikWeekDay:\r\n begin\r\n case IndexValue of\r\n sivFirst:\r\n TempDay := FirstWeekDay(TYear, TMonth);\r\n sivLast:\r\n TempDay := LastWeekDay(TYear, TMonth);\r\n else\r\n TempDay := IndexedWeekDay(TYear, TMonth, IndexValue);\r\n if TempDay = 0 then\r\n begin\r\n if IndexValue > 0 then\r\n TempDay := LastWeekDay(TYear, TMonth)\r\n else\r\n if IndexValue < 0 then\r\n TempDay := FirstWeekDay(TYear, TMonth);\r\n end;\r\n end;\r\n Result := TDay = TempDay;\r\n end;\r\n sikWeekendDay:\r\n begin\r\n case IndexValue of\r\n sivFirst:\r\n TempDay := FirstWeekendDay(TYear, TMonth);\r\n sivLast:\r\n TempDay := LastWeekendDay(TYear, TMonth);\r\n else\r\n TempDay := IndexedWeekendDay(TYear, TMonth, IndexValue);\r\n if TempDay = 0 then\r\n begin\r\n if IndexValue > 0 then\r\n TempDay := LastWeekendDay(TYear, TMonth)\r\n else\r\n if IndexValue < 0 then\r\n TempDay := FirstWeekendDay(TYear, TMonth);\r\n end;\r\n end;\r\n Result := TDay = TempDay;\r\n end;\r\n sikMonday..sikSunday:\r\n begin\r\n case IndexValue of\r\n sivFirst:\r\n TempDay := FirstDayOfWeek(TYear, TMonth, Ord(IndexKind) - Ord(sikWeekendDay));\r\n sivLast:\r\n TempDay := LastDayOfWeek(TYear, TMonth, Ord(IndexKind) - Ord(sikWeekendDay));\r\n else\r\n TempDay := IndexedDayOfWeek(TYear, TMonth, Ord(IndexKind) - Ord(sikWeekendDay),\r\n IndexValue);\r\n if TempDay = 0 then\r\n begin\r\n if IndexValue > 0 then\r\n TempDay := LastDayOfWeek(TYear, TMonth, Ord(IndexKind) - Ord(sikWeekendDay))\r\n else\r\n if IndexValue < 0 then\r\n TempDay := FirstDayOfWeek(TYear, TMonth, Ord(IndexKind) - Ord(sikWeekendDay));\r\n end;\r\n end;\r\n Result := TDay = TempDay;\r\n end;\r\n else\r\n Result := False;\r\n end;\r\nend;\r\n\r\nprocedure TJclMonthlySchedule.MakeValidStampMonthIndex(var TYear, TMonth, TDay: Word);\r\nvar\r\n DIM: Integer;\r\nbegin\r\n DIM := DaysInMonth(JclDateTime.EncodeDate(TYear, TMonth, 1));\r\n case IndexKind of\r\n sikNone:\r\n begin\r\n TDay := Day;\r\n if Integer(Day) > DIM then\r\n TDay := DIM;\r\n end;\r\n sikDay:\r\n begin\r\n if (IndexValue = sivLast) or (Integer(IndexValue) > DIM) then\r\n TDay := DIM\r\n else\r\n if IndexValue > 0 then\r\n TDay := IndexValue\r\n else\r\n begin\r\n if -IndexValue > DIM then\r\n TDay := 1\r\n else\r\n TDay := DIM + 1 + IndexValue;\r\n end;\r\n end;\r\n sikWeekDay:\r\n begin\r\n case IndexValue of\r\n sivFirst:\r\n TDay := FirstWeekDay(TYear, TMonth);\r\n sivLast:\r\n TDay := LastWeekDay(TYear, TMonth);\r\n else\r\n begin\r\n TDay := IndexedWeekDay(TYear, TMonth, IndexValue);\r\n if TDay = 0 then\r\n begin\r\n if IndexValue > 0 then\r\n TDay := LastWeekDay(TYear, TMonth)\r\n else\r\n if IndexValue < 0 then\r\n TDay := FirstWeekDay(TYear, TMonth);\r\n end;\r\n end;\r\n end;\r\n end;\r\n sikWeekendDay:\r\n begin\r\n case IndexValue of\r\n sivFirst:\r\n TDay := FirstWeekendDay(TYear, TMonth);\r\n sivLast:\r\n TDay := LastWeekendDay(TYear, TMonth);\r\n else\r\n begin\r\n TDay := IndexedWeekendDay(TYear, TMonth, IndexValue);\r\n if TDay = 0 then\r\n begin\r\n if IndexValue > 0 then\r\n TDay := LastWeekendDay(TYear, TMonth)\r\n else\r\n if IndexValue < 0 then\r\n TDay := FirstWeekendDay(TYear, TMonth);\r\n end;\r\n end;\r\n end;\r\n end;\r\n sikMonday..sikSunday:\r\n begin\r\n case IndexValue of\r\n sivFirst:\r\n TDay := FirstDayOfWeek(TYear, TMonth, Ord(IndexKind) - Ord(sikWeekendDay));\r\n sivLast:\r\n TDay := LastDayOfWeek(TYear, TMonth, Ord(IndexKind) - Ord(sikWeekendDay));\r\n else\r\n TDay := IndexedDayOfWeek(TYear, TMonth, Ord(IndexKind) - Ord(sikWeekendDay),\r\n IndexValue);\r\n if TDay = 0 then\r\n begin\r\n if IndexValue > 0 then\r\n TDay := LastDayOfWeek(TYear, TMonth, Ord(IndexKind) - Ord(sikWeekendDay))\r\n else\r\n if IndexValue < 0 then\r\n TDay := FirstDayOfWeek(TYear, TMonth, Ord(IndexKind) - Ord(sikWeekendDay));\r\n end;\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJclMonthlySchedule.GetIndexKind: TScheduleIndexKind;\r\nbegin\r\n CheckInterfaceAllowed;\r\n Result := FIndexKind;\r\nend;\r\n\r\nfunction TJclMonthlySchedule.GetIndexValue: Integer;\r\nbegin\r\n CheckInterfaceAllowed;\r\n if not (FIndexKind in [sikDay .. sikSunday]) then\r\n raise EJclScheduleError.CreateRes(@RsScheduleIndexValueSup);\r\n Result := FIndexValue;\r\nend;\r\n\r\nfunction TJclMonthlySchedule.GetDay: Cardinal;\r\nbegin\r\n CheckInterfaceAllowed;\r\n Result := FDay;\r\nend;\r\n\r\nfunction TJclMonthlySchedule.GetInterval: Cardinal;\r\nbegin\r\n CheckInterfaceAllowed;\r\n Result := FInterval;\r\nend;\r\n\r\nprocedure TJclMonthlySchedule.SetIndexKind(Value: TScheduleIndexKind);\r\nbegin\r\n CheckInterfaceAllowed;\r\n FIndexKind := Value;\r\nend;\r\n\r\nprocedure TJclMonthlySchedule.SetIndexValue(Value: Integer);\r\nbegin\r\n CheckInterfaceAllowed;\r\n if not (FIndexKind in [sikDay .. sikSunday]) then\r\n raise EJclScheduleError.CreateRes(@RsScheduleIndexValueSup);\r\n if Value = 0 then\r\n raise EJclScheduleError.CreateRes(@RsScheduleIndexValueZero);\r\n FIndexValue := Value;\r\nend;\r\n\r\nprocedure TJclMonthlySchedule.SetDay(Value: Cardinal);\r\nbegin\r\n CheckInterfaceAllowed;\r\n if not (FIndexKind in [sikNone]) then\r\n raise EJclScheduleError.CreateRes(@RsScheduleDayNotSupported);\r\n if (Value = 0) or (Value > 31) then\r\n raise EJclScheduleError.CreateRes(@RsScheduleDayInRange);\r\n FDay := Value;\r\nend;\r\n\r\nprocedure TJclMonthlySchedule.SetInterval(Value: Cardinal);\r\nbegin\r\n CheckInterfaceAllowed;\r\n if Value = 0 then\r\n raise EJclScheduleError.CreateRes(@RsScheduleIntervalZero);\r\n FInterval := Value;\r\nend;\r\n\r\n//=== { TJclYearlySchedule } =================================================\r\n\r\ntype\r\n TJclYearlySchedule = class(TJclMonthlySchedule, IJclYearlySchedule, IInterface)\r\n private\r\n FMonth: Cardinal;\r\n protected\r\n class function RecurringType: TScheduleRecurringKind; override;\r\n\r\n function ValidStamp(const Stamp: TTimeStamp): Boolean; override;\r\n procedure MakeValidStamp(var Stamp: TTimeStamp); override;\r\n function NextValidStamp(const Stamp: TTimeStamp): TTimeStamp; override;\r\n public\r\n constructor Create(const Controller: IUnknown);\r\n { IJclYearlySchedule }\r\n function GetMonth: Cardinal;\r\n procedure SetMonth(Value: Cardinal);\r\n \r\n property Month: Cardinal read GetMonth write SetMonth;\r\n end;\r\n\r\nconstructor TJclYearlySchedule.Create(const Controller: IUnknown);\r\nbegin\r\n inherited Create(Controller);\r\n FMonth := 1;\r\nend;\r\n\r\nclass function TJclYearlySchedule.RecurringType: TScheduleRecurringKind;\r\nbegin\r\n Result := srkYearly;\r\nend;\r\n\r\nfunction TJclYearlySchedule.ValidStamp(const Stamp: TTimeStamp): Boolean;\r\nvar\r\n SYear, SMonth, SDay: Word;\r\n TYear, TMonth, TDay: Word;\r\nbegin\r\n JclDateTime.DecodeDate(TimeStampToDateTime(Schedule.StartDate), SYear, SMonth, SDay);\r\n JclDateTime.DecodeDate(TimeStampToDateTime(Stamp), TYear, TMonth, TDay);\r\n Result := ((TYear - SYear) mod Integer(Interval) = 0) and (TMonth = Month) and\r\n ValidStampMonthIndex(TYear, TMonth, TDay);\r\nend;\r\n\r\nprocedure TJclYearlySchedule.MakeValidStamp(var Stamp: TTimeStamp);\r\nvar\r\n SYear, SMonth, SDay: Word;\r\n TYear, TMonth, TDay: Word;\r\n YearDiff: Integer;\r\nbegin\r\n JclDateTime.DecodeDate(TimeStampToDateTime(Schedule.StartDate), SYear, SMonth, SDay);\r\n JclDateTime.DecodeDate(TimeStampToDateTime(Stamp), TYear, TMonth, TDay);\r\n YearDiff := TYear - SYear;\r\n if YearDiff mod Integer(Interval) <> 0 then\r\n begin\r\n Inc(TYear, Integer(Interval) - (YearDiff mod Integer(Interval)));\r\n TMonth := Month;\r\n TDay := 1;\r\n end;\r\n MakeValidStampMonthIndex(TYear, TMonth, TDay);\r\n while DateTimeToTimeStamp(JclDateTime.EncodeDate(TYear, TMonth, TDay)).Date < Stamp.Date do\r\n begin\r\n Inc(TYear, Integer(Interval));\r\n TMonth := Month;\r\n TDay := 1;\r\n MakeValidStampMonthIndex(TYear, TMonth, TDay);\r\n end;\r\n Stamp.Date := DateTimeToTimeStamp(JclDateTime.EncodeDate(TYear, TMonth, TDay)).Date;\r\nend;\r\n\r\nfunction TJclYearlySchedule.NextValidStamp(const Stamp: TTimeStamp): TTimeStamp;\r\nbegin\r\n Result := Stamp;\r\n MakeValidStamp(Result);\r\n if EqualTimeStamps(Stamp, Result) then\r\n begin\r\n // Time stamp has not been adjusted (it was valid). Determine the next time stamp\r\n Inc(Result.Date);\r\n MakeValidStamp(Result); // Skip over unwanted days and months\r\n end;\r\nend;\r\n\r\nfunction TJclYearlySchedule.GetMonth: Cardinal;\r\nbegin\r\n CheckInterfaceAllowed;\r\n Result := FMonth;\r\nend;\r\n\r\nprocedure TJclYearlySchedule.SetMonth(Value: Cardinal);\r\nbegin\r\n CheckInterfaceAllowed;\r\n if (Value < 1) or (Value > 12) then\r\n raise EJclScheduleError.CreateRes(@RsScheduleMonthInRange);\r\n FMonth := Value;\r\nend;\r\n\r\n//=== { TJclSchedule } =======================================================\r\n\r\ntype\r\n TJclSchedule = class(TInterfacedObject, IJclSchedule, IJclScheduleDayFrequency, IJclDailySchedule,\r\n IJclWeeklySchedule, IJclMonthlySchedule, IJclYearlySchedule)\r\n private\r\n FStartDate: TTimeStamp;\r\n FRecurringType: TScheduleRecurringKind;\r\n FEndType: TScheduleEndKind;\r\n FEndDate: TTimeStamp;\r\n FEndCount: Cardinal;\r\n FDayFrequency: TJclDayFrequency;\r\n FDailySchedule: TJclDailySchedule;\r\n FWeeklySchedule: TJclWeeklySchedule;\r\n FMonthlySchedule: TJclMonthlySchedule;\r\n FYearlySchedule: TJclYearlySchedule;\r\n protected\r\n FTriggerCount: Cardinal;\r\n FDayCount: Cardinal;\r\n FLastEvent: TTimeStamp;\r\n function GetNextEventStamp(const From: TTimeStamp): TTimeStamp;\r\n public\r\n constructor Create;\r\n destructor Destroy; override;\r\n\r\n { IJclSchedule }\r\n function GetStartDate: TTimeStamp;\r\n function GetRecurringType: TScheduleRecurringKind;\r\n function GetEndType: TScheduleEndKind;\r\n function GetEndDate: TTimeStamp;\r\n function GetEndCount: Cardinal;\r\n procedure SetStartDate(const Value: TTimeStamp);\r\n procedure SetRecurringType(Value: TScheduleRecurringKind);\r\n procedure SetEndType(Value: TScheduleEndKind);\r\n procedure SetEndDate(const Value: TTimeStamp);\r\n procedure SetEndCount(Value: Cardinal);\r\n\r\n function TriggerCount: Cardinal;\r\n function DayCount: Cardinal;\r\n function LastTriggered: TTimeStamp;\r\n\r\n procedure InitToSavedState(const LastTriggerStamp: TTimeStamp; const LastTriggerCount,\r\n LastDayCount: Cardinal);\r\n procedure Reset;\r\n function NextEvent(CountMissedEvents: Boolean = False): TTimeStamp;\r\n function NextEventFrom(const FromEvent: TTimeStamp;\r\n CountMissedEvent: Boolean = False): TTimeStamp;\r\n function NextEventFromNow(CountMissedEvents: Boolean = False): TTimeStamp;\r\n\r\n property StartDate: TTimeStamp read GetStartDate write SetStartDate;\r\n property RecurringType: TScheduleRecurringKind read GetRecurringType write SetRecurringType;\r\n property EndType: TScheduleEndKind read GetEndType write SetEndType;\r\n property EndDate: TTimeStamp read GetEndDate write SetEndDate;\r\n property EndCount: Cardinal read GetEndCount write SetEndCount;\r\n\r\n { IJclScheduleDayFrequency }\r\n function GetDayFrequency: IJclScheduleDayFrequency;\r\n property DayFrequency: IJclScheduleDayFrequency read GetDayFrequency implements IJclScheduleDayFrequency;\r\n { IJclDailySchedule }\r\n function GetDailySchedule: IJclDailySchedule;\r\n property DailySchedule: IJclDailySchedule read GetDailySchedule implements IJclDailySchedule;\r\n { IJclWeeklySchedule }\r\n function GetWeeklySchedule: IJclWeeklySchedule;\r\n property WeeklySchedule: IJclWeeklySchedule read GetWeeklySchedule implements IJclWeeklySchedule;\r\n { IJclMonthlySchedule }\r\n function GetMonthlySchedule: IJclMonthlySchedule;\r\n property MonthlySchedule: IJclMonthlySchedule read GetMonthlySchedule implements IJclMonthlySchedule;\r\n { IJclYearlySchedule }\r\n function GetYearlySchedule: IJclYearlySchedule;\r\n property YearlySchedule: IJclYearlySchedule read GetYearlySchedule implements IJclYearlySchedule;\r\n end;\r\n\r\nconstructor TJclSchedule.Create;\r\nvar\r\n InitialStamp: TTimeStamp;\r\nbegin\r\n inherited Create;\r\n FDayFrequency := TJclDayFrequency.Create(Self);\r\n FDailySchedule := TJclDailySchedule.Create(Self);\r\n FWeeklySchedule := TJclWeeklySchedule.Create(Self);\r\n FMonthlySchedule := TJclMonthlySchedule.Create(Self);\r\n FYearlySchedule := TJclYearlySchedule.Create(Self);\r\n InitialStamp := DateTimeToTimeStamp(Now);\r\n InitialStamp.Time := 1000 * (InitialStamp.Time div 1000); // strip of milliseconds\r\n StartDate := InitialStamp;\r\n EndType := sekNone;\r\n RecurringType := srkOneShot;\r\nend;\r\n\r\ndestructor TJclSchedule.Destroy;\r\nbegin\r\n FreeAndNil(FYearlySchedule);\r\n FreeAndNil(FMonthlySchedule);\r\n FreeAndNil(FWeeklySchedule);\r\n FreeAndNil(FDailySchedule);\r\n FreeAndNil(FDayFrequency);\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJclSchedule.GetDayFrequency: IJclScheduleDayFrequency;\r\nbegin\r\n Result := FDayFrequency;\r\nend;\r\n\r\nfunction TJclSchedule.GetDailySchedule: IJclDailySchedule;\r\nbegin\r\n Result := FDailySchedule;\r\nend;\r\n\r\nfunction TJclSchedule.GetWeeklySchedule: IJclWeeklySchedule;\r\nbegin\r\n Result := FWeeklySchedule;\r\nend;\r\n\r\nfunction TJclSchedule.GetMonthlySchedule: IJclMonthlySchedule;\r\nbegin\r\n Result := FMonthlySchedule;\r\nend;\r\n\r\nfunction TJclSchedule.GetYearlySchedule: IJclYearlySchedule;\r\nbegin\r\n Result := FYearlySchedule;\r\nend;\r\n\r\nfunction TJclSchedule.GetNextEventStamp(const From: TTimeStamp): TTimeStamp;\r\nvar\r\n UseFrom: TTimeStamp;\r\nbegin\r\n Result := NullStamp;\r\n UseFrom := From;\r\n if (From.Date = 0) or (From.Date < StartDate.Date) then\r\n begin\r\n UseFrom := StartDate;\r\n Dec(UseFrom.Time);\r\n end;\r\n case RecurringType of\r\n srkOneShot:\r\n if TriggerCount = 0 then\r\n Result := StartDate;\r\n srkDaily:\r\n begin\r\n Result := FDayFrequency.NextValidStamp(UseFrom);\r\n if IsNullTimeStamp(Result) then\r\n begin\r\n Result.Date := UseFrom.Date;\r\n Result.Time := FDayFrequency.StartTime;\r\n Result := FDailySchedule.NextValidStamp(Result);\r\n end\r\n else\r\n FDailySchedule.MakeValidStamp(Result);\r\n end;\r\n srkWeekly:\r\n begin\r\n Result := FDayFrequency.NextValidStamp(UseFrom);\r\n if IsNullTimeStamp(Result) then\r\n begin\r\n Result.Date := UseFrom.Date;\r\n Result.Time := FDayFrequency.StartTime;\r\n Result := FWeeklySchedule.NextValidStamp(Result);\r\n end\r\n else\r\n FWeeklySchedule.MakeValidStamp(Result);\r\n end;\r\n srkMonthly:\r\n begin\r\n Result := FDayFrequency.NextValidStamp(UseFrom);\r\n if IsNullTimeStamp(Result) then\r\n begin\r\n Result.Date := UseFrom.Date;\r\n Result.Time := FDayFrequency.StartTime;\r\n Result := FMonthlySchedule.NextValidStamp(Result);\r\n end\r\n else\r\n FMonthlySchedule.MakeValidStamp(Result);\r\n end;\r\n srkYearly:\r\n begin\r\n Result := FDayFrequency.NextValidStamp(UseFrom);\r\n if IsNullTimeStamp(Result) then\r\n begin\r\n Result.Date := UseFrom.Date;\r\n Result.Time := FDayFrequency.StartTime;\r\n Result := FYearlySchedule.NextValidStamp(Result);\r\n end\r\n else\r\n FYearlySchedule.MakeValidStamp(Result);\r\n end;\r\n end;\r\n if CompareTimeStamps(Result, UseFrom) < 0 then\r\n Result := NullStamp;\r\n if not IsNullTimeStamp(Result) then\r\n begin\r\n if ((EndType = sekDate) and (CompareTimeStamps(Result, EndDate) > 0)) or\r\n ((EndType = sekDayCount) and (DayCount = EndCount) and (UseFrom.Date <> Result.Date)) or\r\n ((EndType = sekTriggerCount) and (TriggerCount = EndCount)) then\r\n Result := NullStamp\r\n else\r\n begin\r\n Inc(FTriggerCount);\r\n if (UseFrom.Date <> Result.Date) or (DayCount = 0) then\r\n Inc(FDayCount);\r\n FLastEvent := Result;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJclSchedule.GetStartDate: TTimeStamp;\r\nbegin\r\n Result := FStartDate;\r\nend;\r\n\r\nfunction TJclSchedule.GetRecurringType: TScheduleRecurringKind;\r\nbegin\r\n Result := FRecurringType;\r\nend;\r\n\r\nfunction TJclSchedule.GetEndType: TScheduleEndKind;\r\nbegin\r\n Result := FEndType;\r\nend;\r\n\r\nfunction TJclSchedule.GetEndDate: TTimeStamp;\r\nbegin\r\n Result := FEndDate;\r\nend;\r\n\r\nfunction TJclSchedule.GetEndCount: Cardinal;\r\nbegin\r\n Result := FEndCount;\r\nend;\r\n\r\nprocedure TJclSchedule.SetStartDate(const Value: TTimeStamp);\r\nbegin\r\n FStartDate := Value;\r\nend;\r\n\r\nprocedure TJclSchedule.SetRecurringType(Value: TScheduleRecurringKind);\r\nbegin\r\n FRecurringType := Value;\r\nend;\r\n\r\nprocedure TJclSchedule.SetEndType(Value: TScheduleEndKind);\r\nbegin\r\n FEndType := Value;\r\nend;\r\n\r\nprocedure TJclSchedule.SetEndDate(const Value: TTimeStamp);\r\nbegin\r\n FEndDate := Value;\r\nend;\r\n\r\nprocedure TJclSchedule.SetEndCount(Value: Cardinal);\r\nbegin\r\n FEndCount := Value;\r\nend;\r\n\r\nfunction TJclSchedule.TriggerCount: Cardinal;\r\nbegin\r\n Result := FTriggerCount;\r\nend;\r\n\r\nfunction TJclSchedule.DayCount: Cardinal;\r\nbegin\r\n Result := FDayCount;\r\nend;\r\n\r\nfunction TJclSchedule.LastTriggered: TTimeStamp;\r\nbegin\r\n Result := FLastEvent;\r\nend;\r\n\r\nprocedure TJclSchedule.InitToSavedState(const LastTriggerStamp: TTimeStamp; const LastTriggerCount,\r\n LastDayCount: Cardinal);\r\nbegin\r\n FLastEvent := LastTriggerStamp;\r\n FTriggerCount := LastTriggerCount;\r\n FDayCount := LastDayCount;\r\nend;\r\n\r\nprocedure TJclSchedule.Reset;\r\nbegin\r\n FLastEvent := NullStamp;\r\n FTriggerCount := 0;\r\n FDayCount := 0;\r\nend;\r\n\r\nfunction TJclSchedule.NextEvent(CountMissedEvents: Boolean = False): TTimeStamp;\r\nbegin\r\n Result := NextEventFrom(FLastEvent, CountMissedEvents);\r\nend;\r\n\r\nfunction TJclSchedule.NextEventFrom(const FromEvent: TTimeStamp;\r\n CountMissedEvent: Boolean = False): TTimeStamp;\r\nbegin\r\n if CountMissedEvent then\r\n begin\r\n Result := FLastEvent;\r\n repeat\r\n Result := GetNextEventStamp(Result);\r\n until IsNullTimeStamp(Result) or (CompareTimeStamps(FromEvent, Result) <= 0);\r\n end\r\n else\r\n Result := GetNextEventStamp(FromEvent);\r\nend;\r\n\r\nfunction TJclSchedule.NextEventFromNow(CountMissedEvents: Boolean = False): TTimeStamp;\r\nbegin\r\n Result := NextEventFrom(DateTimeToTimeStamp(Now), CountMissedEvents);\r\nend;\r\n\r\nfunction CreateSchedule: IJclSchedule;\r\nbegin\r\n Result := TJclSchedule.Create;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jcl/source/common/JclSimpleXml.pas", "content": "{**************************************************************************************************}\r\n{ }\r\n{ Project JEDI Code Library (JCL) }\r\n{ }\r\n{ The contents of this file are subject to the Mozilla Public License Version 1.1 (the \"License\"); }\r\n{ you may not use this file except in compliance with the License. You may obtain a copy of the }\r\n{ License at http://www.mozilla.org/MPL/ }\r\n{ }\r\n{ Software distributed under the License is distributed on an \"AS IS\" basis, WITHOUT WARRANTY OF }\r\n{ ANY KIND, either express or implied. See the License for the specific language governing rights }\r\n{ and limitations under the License. }\r\n{ }\r\n{ The Original Code is JvSimpleXML.PAS, released on 2002-06-03. }\r\n{ }\r\n{ The Initial Developer of the Original Code is Sbastien Buysse [sbuysse att buypin dott com]. }\r\n{ Portions created by Sbastien Buysse are Copyright (C) 2001 Sbastien Buysse. }\r\n{ All Rights Reserved. }\r\n{ }\r\n{ Contributor(s): }\r\n{ Christophe Paris, }\r\n{ Florent Ouchet (move from the JVCL to the JCL) }\r\n{ Tetrm }\r\n{ }\r\n{**************************************************************************************************}\r\n{ }\r\n{ This unit contains Xml parser and writter classes }\r\n{ }\r\n{**************************************************************************************************}\r\n{ }\r\n{ Last modified: $Date:: 2012-09-04 16:08:04 +0200 (mar. 04 sept. 2012) $ }\r\n{ Revision: $Rev:: 3861 $ }\r\n{ Author: $Author:: outchy $ }\r\n{ }\r\n{**************************************************************************************************}\r\n\r\n// Known Issues: This component does not parse the !DOCTYPE tags but preserves them\r\n\r\nunit JclSimpleXml;\r\n\r\ninterface\r\n\r\n{$I jcl.inc}\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n {$IFDEF HAS_UNITSCOPE}\r\n {$IFDEF HAS_UNIT_RTLCONSTS}\r\n System.RTLConsts,\r\n {$ENDIF HAS_UNIT_RTLCONSTS}\r\n {$IFDEF MSWINDOWS}\r\n Winapi.Windows, // Delphi 2005 inline\r\n {$ENDIF MSWINDOWS}\r\n System.SysUtils, System.Classes,\r\n System.Variants,\r\n System.IniFiles,\r\n System.Contnrs,\r\n {$ELSE ~HAS_UNITSCOPE}\r\n {$IFDEF HAS_UNIT_RTLCONSTS}\r\n RTLConsts,\r\n {$ENDIF HAS_UNIT_RTLCONSTS}\r\n {$IFDEF MSWINDOWS}\r\n Windows, // Delphi 2005 inline\r\n {$ENDIF MSWINDOWS}\r\n SysUtils, Classes,\r\n Variants,\r\n IniFiles,\r\n Contnrs,\r\n {$ENDIF ~HAS_UNITSCOPE}\r\n JclBase, JclStreams;\r\n\r\ntype\r\n TJclSimpleItem = class(TObject)\r\n private\r\n FName: string;\r\n protected\r\n procedure SetName(const Value: string); virtual;\r\n public\r\n property Name: string read FName write SetName;\r\n end;\r\n\r\ntype\r\n TJclSimpleItemHashedList = class(TObjectList)\r\n private\r\n FNameHash: TStringHash;\r\n FCaseSensitive: Boolean;\r\n function GetSimpleItemByName(const Name: string): TJclSimpleItem;\r\n function GetSimpleItem(Index: Integer): TJclSimpleItem;\r\n procedure SetCaseSensitive(const Value: Boolean);\r\n protected\r\n procedure Notify(Ptr: Pointer; Action: TListNotification); override;\r\n public\r\n constructor Create(ACaseSensitive: Boolean);\r\n destructor Destroy; override;\r\n function Add(Item: TJclSimpleItem): Integer;\r\n procedure Clear; override;\r\n function IndexOfSimpleItem(Item: TJclSimpleItem): Integer;\r\n function IndexOfName(const Name: string): Integer;\r\n procedure Insert(Index: Integer; Item: TJclSimpleItem);\r\n procedure InvalidateHash;\r\n procedure Move(CurIndex, NewIndex: Integer);\r\n property CaseSensitive: Boolean read FCaseSensitive write SetCaseSensitive;\r\n property SimpleItemByNames[const Name: string]: TJclSimpleItem read GetSimpleItemByName;\r\n property SimpleItems[Index: Integer]: TJclSimpleItem read GetSimpleItem;\r\n end;\r\n\r\ntype\r\n TJclSimpleData = class(TJclSimpleItem)\r\n private\r\n FValue: string;\r\n FData: Pointer;\r\n protected\r\n function GetBoolValue: Boolean;\r\n procedure SetBoolValue(const Value: Boolean);\r\n function GetFloatValue: Extended;\r\n procedure SetFloatValue(const Value: Extended);\r\n function GetAnsiValue: AnsiString;\r\n procedure SetAnsiValue(const Value: AnsiString);\r\n function GetIntValue: Int64;\r\n procedure SetIntValue(const Value: Int64);\r\n public\r\n constructor Create; overload; virtual;\r\n constructor Create(const AName: string); overload;\r\n constructor Create(const AName, AValue: string); overload;\r\n property Value: string read FValue write FValue;\r\n property AnsiValue: AnsiString read GetAnsiValue write SetAnsiValue;\r\n property IntValue: Int64 read GetIntValue write SetIntValue;\r\n property BoolValue: Boolean read GetBoolValue write SetBoolValue;\r\n property FloatValue: Extended read GetFloatValue write SetFloatValue;\r\n\r\n property Data: Pointer read FData write FData;\r\n end;\r\n\r\ntype\r\n TJclSimpleXMLData = class(TJclSimpleData)\r\n private\r\n FNameSpace: string;\r\n public\r\n function FullName:string;\r\n property NameSpace: string read FNameSpace write FNameSpace;\r\n end;\r\n\r\ntype\r\n TJclSimpleXML = class;\r\n EJclSimpleXMLError = class(EJclError);\r\n {$TYPEINFO ON} // generate RTTI for published properties\r\n TJclSimpleXMLElem = class;\r\n {$IFNDEF TYPEINFO_ON}\r\n {$TYPEINFO OFF}\r\n {$ENDIF ~TYPEINFO_ON}\r\n TJclSimpleXMLElems = class;\r\n TJclSimpleXMLProps = class;\r\n TJclSimpleXMLElemsProlog = class;\r\n TJclSimpleXMLNamedElems = class;\r\n TJclSimpleXMLElemComment = class;\r\n TJclSimpleXMLElemClassic = class;\r\n TJclSimpleXMLElemCData = class;\r\n TJclSimpleXMLElemDocType = class;\r\n TJclSimpleXMLElemText = class;\r\n TJclSimpleXMLElemHeader = class;\r\n TJclSimpleXMLElemSheet = class;\r\n TJclSimpleXMLElemMSOApplication = class;\r\n TJclOnSimpleXMLParsed = procedure(Sender: TObject; const Name: string) of object;\r\n TJclOnValueParsed = procedure(Sender: TObject; const Name, Value: string) of object;\r\n TJclOnSimpleProgress = procedure(Sender: TObject; const Position, Total: Integer) of object;\r\n\r\n //Those hash stuffs are for future use only\r\n //Plans are to replace current hash by this mechanism\r\n TJclHashKind = (hkList, hkDirect);\r\n PJclHashElem = ^TJclHashElem;\r\n TJclHashElem = packed record\r\n Next: PJclHashElem;\r\n Obj: TObject;\r\n end;\r\n PJclHashRecord = ^TJclHashRecord;\r\n TJclHashList = array [0..25] of PJclHashRecord;\r\n PJclHashList = ^TJclHashList;\r\n TJclHashRecord = packed record\r\n Count: Byte;\r\n case Kind: TJclHashKind of\r\n hkList: (List: PJclHashList);\r\n hkDirect: (FirstElem: PJclHashElem);\r\n end;\r\n\r\n TJclSimpleXMLProp = class(TJclSimpleXMLData)\r\n private\r\n FParent: TJclSimpleXMLElem;\r\n protected\r\n function GetSimpleXML: TJclSimpleXML;\r\n procedure SetName(const Value: string); override;\r\n public\r\n constructor Create(AParent: TJclSimpleXMLElem; const AName, AValue: string);\r\n procedure SaveToStringStream(StringStream: TJclStringStream);\r\n property Parent: TJclSimpleXMLElem read FParent;\r\n property SimpleXML: TJclSimpleXML read GetSimpleXML;\r\n end;\r\n\r\n {$IFDEF SUPPORTS_FOR_IN}\r\n TJclSimpleXMLPropsEnumerator = class\r\n private\r\n FIndex: Integer;\r\n FList: TJclSimpleXMLProps;\r\n public\r\n constructor Create(AList: TJclSimpleXMLProps);\r\n function GetCurrent: TJclSimpleXMLProp; {$IFDEF SUPPORTS_INLINE}inline;{$ENDIF}\r\n function MoveNext: Boolean;\r\n property Current: TJclSimpleXMLProp read GetCurrent;\r\n end;\r\n {$ENDIF SUPPORTS_FOR_IN}\r\n\r\n TJclSimpleXMLProps = class(TObject)\r\n private\r\n FProperties: TStringList;\r\n FParent: TJclSimpleXMLElem;\r\n function GetCount: Integer;\r\n function GetItemNamedDefault(const Name, Default: string): TJclSimpleXMLProp;\r\n function GetItemNamed(const Name: string): TJclSimpleXMLProp;\r\n protected\r\n function GetSimpleXML: TJclSimpleXML;\r\n function GetItem(const Index: Integer): TJclSimpleXMLProp;\r\n procedure DoItemRename(Value: TJclSimpleXMLProp; const Name: string);\r\n procedure Error(const S: string);\r\n procedure FmtError(const S: string; const Args: array of const);\r\n public\r\n constructor Create(AParent: TJclSimpleXMLElem);\r\n destructor Destroy; override;\r\n function Add(const Name, Value: string): TJclSimpleXMLProp; overload;\r\n {$IFDEF SUPPORTS_UNICODE}\r\n function Add(const Name: string; const Value: AnsiString): TJclSimpleXMLProp; overload;\r\n {$ENDIF SUPPORTS_UNICODE}\r\n function Add(const Name: string; const Value: Int64): TJclSimpleXMLProp; overload;\r\n function Add(const Name: string; const Value: Boolean): TJclSimpleXMLProp; overload;\r\n function Insert(const Index: Integer; const Name, Value: string): TJclSimpleXMLProp; overload;\r\n function Insert(const Index: Integer; const Name: string; const Value: Int64): TJclSimpleXMLProp; overload;\r\n function Insert(const Index: Integer; const Name: string; const Value: Boolean): TJclSimpleXMLProp; overload;\r\n procedure Clear; virtual;\r\n procedure Delete(const Index: Integer); overload;\r\n procedure Delete(const Name: string); overload;\r\n {$IFDEF SUPPORTS_FOR_IN}\r\n function GetEnumerator: TJclSimpleXMLPropsEnumerator;\r\n {$ENDIF SUPPORTS_FOR_IN}\r\n function Value(const Name: string; const Default: string = ''): string;\r\n function IntValue(const Name: string; const Default: Int64 = -1): Int64;\r\n function BoolValue(const Name: string; Default: Boolean = True): Boolean;\r\n function FloatValue(const Name: string; const Default: Extended = 0): Extended;\r\n procedure LoadFromStringStream(StringStream: TJclStringStream);\r\n procedure SaveToStringStream(StringStream: TJclStringStream);\r\n property Item[const Index: Integer]: TJclSimpleXMLProp read GetItem; default;\r\n property ItemNamed[const Name: string]: TJclSimpleXMLProp read GetItemNamed;\r\n property Count: Integer read GetCount;\r\n property Parent: TJclSimpleXMLElem read FParent;\r\n end;\r\n\r\n {$IFDEF SUPPORTS_FOR_IN}\r\n TJclSimpleXMLElemsPrologEnumerator = class\r\n private\r\n FIndex: Integer;\r\n FList: TJclSimpleXMLElemsProlog;\r\n public\r\n constructor Create(AList: TJclSimpleXMLElemsProlog);\r\n function GetCurrent: TJclSimpleXMLElem; {$IFDEF SUPPORTS_INLINE}inline;{$ENDIF}\r\n function MoveNext: Boolean;\r\n property Current: TJclSimpleXMLElem read GetCurrent;\r\n end;\r\n {$ENDIF SUPPORTS_FOR_IN}\r\n\r\n TJclSimpleXMLElemsProlog = class(TObject)\r\n private\r\n FElems: TJclSimpleItemHashedList;\r\n function GetCount: Integer;\r\n function GetItem(const Index: Integer): TJclSimpleXMLElem;\r\n function GetEncoding: string;\r\n function GetStandAlone: Boolean;\r\n function GetVersion: string;\r\n procedure SetEncoding(const Value: string);\r\n procedure SetStandAlone(const Value: Boolean);\r\n procedure SetVersion(const Value: string);\r\n protected\r\n FSimpleXML: TJclSimpleXML;\r\n function FindHeader: TJclSimpleXMLElem;\r\n procedure Error(const S: string);\r\n procedure FmtError(const S: string; const Args: array of const);\r\n public\r\n constructor Create(ASimpleXML: TJclSimpleXML);\r\n destructor Destroy; override;\r\n function AddComment(const AValue: string): TJclSimpleXMLElemComment;\r\n function AddDocType(const AValue: string): TJclSimpleXMLElemDocType;\r\n procedure Clear;\r\n function AddStyleSheet(const AType, AHRef: string): TJclSimpleXMLElemSheet;\r\n function AddMSOApplication(const AProgId : string): TJclSimpleXMLElemMSOApplication;\r\n procedure LoadFromStringStream(StringStream: TJclStringStream);\r\n procedure SaveToStringStream(StringStream: TJclStringStream);\r\n {$IFDEF SUPPORTS_FOR_IN}\r\n function GetEnumerator: TJclSimpleXMLElemsPrologEnumerator;\r\n {$ENDIF SUPPORTS_FOR_IN}\r\n property Item[const Index: Integer]: TJclSimpleXMLElem read GetItem; default;\r\n property Count: Integer read GetCount;\r\n property Encoding: string read GetEncoding write SetEncoding;\r\n property SimpleXML: TJclSimpleXML read FSimpleXML;\r\n property StandAlone: Boolean read GetStandAlone write SetStandAlone;\r\n property Version: string read GetVersion write SetVersion;\r\n end;\r\n\r\n {$IFDEF SUPPORTS_FOR_IN}\r\n TJclSimpleXMLNamedElemsEnumerator = class\r\n private\r\n FIndex: Integer;\r\n FList: TJclSimpleXMLNamedElems;\r\n public\r\n constructor Create(AList: TJclSimpleXMLNamedElems);\r\n function GetCurrent: TJclSimpleXMLElem; {$IFDEF SUPPORTS_INLINE}inline;{$ENDIF}\r\n function MoveNext: Boolean;\r\n property Current: TJclSimpleXMLElem read GetCurrent;\r\n end;\r\n {$ENDIF SUPPORTS_FOR_IN}\r\n\r\n TJclSimpleXMLNamedElems = class(TJclSimpleItem)\r\n private\r\n FElems: TJclSimpleXMLElems;\r\n function GetCount: Integer;\r\n protected\r\n FItems: TList;\r\n function GetItem(const Index: Integer): TJclSimpleXMLElem;\r\n procedure SetName(const Value: string); override;\r\n public\r\n constructor Create(AElems: TJclSimpleXMLElems; const AName: string);\r\n destructor Destroy; override;\r\n\r\n function Add: TJclSimpleXMLElemClassic; overload;\r\n function Add(const Value: string): TJclSimpleXMLElemClassic; overload;\r\n function Add(const Value: Int64): TJclSimpleXMLElemClassic; overload;\r\n function Add(const Value: Boolean): TJclSimpleXMLElemClassic; overload;\r\n function Add(Value: TStream): TJclSimpleXMLElemClassic; overload;\r\n function AddFirst: TJclSimpleXMLElemClassic;\r\n function AddComment(const Value: string): TJclSimpleXMLElemComment;\r\n function AddCData(const Value: string): TJclSimpleXMLElemCData;\r\n function AddText(const Value: string): TJclSimpleXMLElemText;\r\n procedure Clear; virtual;\r\n procedure Delete(const Index: Integer);\r\n procedure Move(const CurIndex, NewIndex: Integer);\r\n function IndexOf(const Value: TJclSimpleXMLElem): Integer; overload;\r\n function IndexOf(const Value: string): Integer; overload;\r\n {$IFDEF SUPPORTS_FOR_IN}\r\n function GetEnumerator: TJclSimpleXMLNamedElemsEnumerator;\r\n {$ENDIF SUPPORTS_FOR_IN}\r\n\r\n property Elems: TJclSimpleXMLElems read FElems;\r\n property Item[const Index: Integer]: TJclSimpleXMLElem read GetItem; default;\r\n property Count: Integer read GetCount;\r\n end;\r\n\r\n {$IFDEF SUPPORTS_FOR_IN}\r\n TJclSimpleXMLElemsEnumerator = class\r\n private\r\n FIndex: Integer;\r\n FList: TJclSimpleXMLElems;\r\n public\r\n constructor Create(AList: TJclSimpleXMLElems);\r\n function GetCurrent: TJclSimpleXMLElem; {$IFDEF SUPPORTS_INLINE}inline;{$ENDIF}\r\n function MoveNext: Boolean;\r\n property Current: TJclSimpleXMLElem read GetCurrent;\r\n end;\r\n {$ENDIF SUPPORTS_FOR_IN}\r\n\r\n TJclSimpleXMLElemCompare = function(Elems: TJclSimpleXMLElems; Index1, Index2: Integer): Integer of object;\r\n TJclSimpleXMLElems = class(TObject)\r\n private\r\n FParent: TJclSimpleXMLElem;\r\n function GetCount: Integer;\r\n function GetItemNamedDefault(const Name, Default: string): TJclSimpleXMLElem;\r\n function GetItemNamed(const Name: string): TJclSimpleXMLElem;\r\n function GetNamedElems(const Name: string): TJclSimpleXMLNamedElems;\r\n protected\r\n FElems: TJclSimpleItemHashedList;\r\n FCompare: TJclSimpleXMLElemCompare;\r\n FNamedElems: TJclSimpleItemHashedList;\r\n function GetItem(const Index: Integer): TJclSimpleXMLElem;\r\n procedure AddChild(const Value: TJclSimpleXMLElem);\r\n procedure AddChildFirst(const Value: TJclSimpleXMLElem);\r\n procedure InsertChild(const Value: TJclSimpleXMLElem; Index: Integer);\r\n procedure DoItemRename(Value: TJclSimpleXMLElem; const Name: string);\r\n procedure CreateElems;\r\n function SimpleCompare(Elems: TJclSimpleXMLElems; Index1, Index2: Integer): Integer;\r\n public\r\n constructor Create(AParent: TJclSimpleXMLElem);\r\n destructor Destroy; override;\r\n\r\n // Use notify to indicate to a list that the given element is removed\r\n // from the list so that it doesn't delete it as well as the one\r\n // that insert it in itself. This method is automatically called\r\n // by AddChild and AddChildFirst if the Container property of the\r\n // given element is set.\r\n procedure Notify(Value: TJclSimpleXMLElem; Operation: TOperation);\r\n\r\n function Add(const Name: string): TJclSimpleXMLElemClassic; overload;\r\n function Add(const Name, Value: string): TJclSimpleXMLElemClassic; overload;\r\n function Add(const Name: string; const Value: Int64): TJclSimpleXMLElemClassic; overload;\r\n function Add(const Name: string; const Value: Boolean): TJclSimpleXMLElemClassic; overload;\r\n function Add(const Name: string; Value: TStream): TJclSimpleXMLElemClassic; overload;\r\n function Add(Value: TJclSimpleXMLElem): TJclSimpleXMLElem; overload;\r\n function AddFirst(Value: TJclSimpleXMLElem): TJclSimpleXMLElem; overload;\r\n function AddFirst(const Name: string): TJclSimpleXMLElemClassic; overload;\r\n function AddComment(const Name: string; const Value: string): TJclSimpleXMLElemComment;\r\n function AddCData(const Name: string; const Value: string): TJclSimpleXMLElemCData;\r\n function AddText(const Name: string; const Value: string): TJclSimpleXMLElemText;\r\n function Insert(Value: TJclSimpleXMLElem; Index: Integer): TJclSimpleXMLElem; overload;\r\n function Insert(const Name: string; Index: Integer): TJclSimpleXMLElemClassic; overload;\r\n procedure Clear; virtual;\r\n procedure Delete(const Index: Integer); overload;\r\n procedure Delete(const Name: string); overload;\r\n function Remove(Value: TJclSimpleXMLElem): Integer;\r\n procedure Move(const CurIndex, NewIndex: Integer);\r\n {$IFDEF SUPPORTS_FOR_IN}\r\n function GetEnumerator: TJclSimpleXMLElemsEnumerator;\r\n {$ENDIF SUPPORTS_FOR_IN}\r\n function IndexOf(const Value: TJclSimpleXMLElem): Integer; overload;\r\n function IndexOf(const Name: string): Integer; overload;\r\n function Value(const Name: string; const Default: string = ''): string;\r\n function IntValue(const Name: string; const Default: Int64 = -1): Int64;\r\n function FloatValue(const Name: string; const Default: Extended = 0): Extended;\r\n function BoolValue(const Name: string; Default: Boolean = True): Boolean;\r\n procedure BinaryValue(const Name: string; Stream: TStream);\r\n procedure LoadFromStringStream(StringStream: TJclStringStream);\r\n procedure SaveToStringStream(StringStream: TJclStringStream; const Level: string = '');\r\n procedure Sort;\r\n procedure CustomSort(AFunction: TJclSimpleXMLElemCompare);\r\n property Parent: TJclSimpleXMLElem read FParent;\r\n property Item[const Index: Integer]: TJclSimpleXMLElem read GetItem; default;\r\n property ItemNamed[const Name: string]: TJclSimpleXMLElem read GetItemNamed;\r\n property Count: Integer read GetCount;\r\n property NamedElems[const Name: string]: TJclSimpleXMLNamedElems read GetNamedElems;\r\n end;\r\n\r\n {$TYPEINFO ON}\r\n TJclSimpleXMLElem = class(TJclSimpleXMLData)\r\n private\r\n FParent: TJclSimpleXMLElem;\r\n FSimpleXML: TJclSimpleXML;\r\n function GetHasItems: Boolean;\r\n function GetHasProperties: Boolean;\r\n function GetItemCount: Integer;\r\n function GetPropertyCount: Integer;\r\n protected\r\n FItems: TJclSimpleXMLElems;\r\n FProps: TJclSimpleXMLProps;\r\n function GetChildsCount: Integer;\r\n function GetProps: TJclSimpleXMLProps;\r\n procedure SetName(const Value: string); override;\r\n function GetItems: TJclSimpleXMLElems;\r\n procedure Error(const S: string);\r\n procedure FmtError(const S: string; const Args: array of const);\r\n public\r\n //constructor Create; overload;\r\n //constructor Create(const AName: string); overload;\r\n //constructor Create(const AName, AValue: string); overload;\r\n constructor Create(ASimpleXML: TJclSimpleXML); overload;\r\n destructor Destroy; override;\r\n procedure Assign(Value: TJclSimpleXMLElem); virtual;\r\n procedure Clear; virtual;\r\n procedure LoadFromStringStream(StringStream: TJclStringStream); virtual; abstract;\r\n procedure SaveToStringStream(StringStream: TJclStringStream; const Level: string = ''); virtual;\r\n abstract;\r\n procedure LoadFromString(const Value: string);\r\n function SaveToString: string;\r\n procedure GetBinaryValue(Stream: TStream);\r\n function GetChildIndex(const AChild: TJclSimpleXMLElem): Integer;\r\n function GetNamedIndex(const AChild: TJclSimpleXMLElem): Integer;\r\n\r\n property SimpleXML: TJclSimpleXML read FSimpleXML;\r\n published\r\n property Parent: TJclSimpleXMLElem read FParent;\r\n property ChildsCount: Integer read GetChildsCount;\r\n property HasItems: Boolean read GetHasItems;\r\n property HasProperties: Boolean read GetHasProperties;\r\n property ItemCount: Integer read GetItemCount;\r\n property PropertyCount: Integer read GetPropertyCount;\r\n property Items: TJclSimpleXMLElems read GetItems;\r\n property Properties: TJclSimpleXMLProps read GetProps;\r\n end;\r\n {$IFNDEF TYPEINFO_ON}\r\n {$TYPEINFO OFF}\r\n {$ENDIF ~TYPEINFO_ON}\r\n TJclSimpleXMLElemClass = class of TJclSimpleXMLElem;\r\n\r\n TJclSimpleXMLElemComment = class(TJclSimpleXMLElem)\r\n public\r\n procedure LoadFromStringStream(StringStream: TJclStringStream); override;\r\n procedure SaveToStringStream(StringStream: TJclStringStream; const Level: string = ''); override;\r\n end;\r\n\r\n TJclSimpleXMLElemClassic = class(TJclSimpleXMLElem)\r\n public\r\n procedure LoadFromStringStream(StringStream: TJclStringStream); override;\r\n procedure SaveToStringStream(StringStream: TJclStringStream; const Level: string = ''); override;\r\n end;\r\n\r\n TJclSimpleXMLElemCData = class(TJclSimpleXMLElem)\r\n public\r\n procedure LoadFromStringStream(StringStream: TJclStringStream); override;\r\n procedure SaveToStringStream(StringStream: TJclStringStream; const Level: string = ''); override;\r\n end;\r\n\r\n TJclSimpleXMLElemText = class(TJclSimpleXMLElem)\r\n public\r\n procedure LoadFromStringStream(StringStream: TJclStringStream); override;\r\n procedure SaveToStringStream(StringStream: TJclStringStream; const Level: string = ''); override;\r\n end;\r\n\r\n TJclSimpleXMLElemProcessingInstruction = class(TJclSimpleXMLElem)\r\n public\r\n procedure LoadFromStringStream(StringStream: TJclStringStream); override;\r\n procedure SaveToStringStream(StringStream: TJclStringStream; const Level: string = ''); override;\r\n end;\r\n\r\n TJclSimpleXMLElemHeader = class(TJclSimpleXMLElemProcessingInstruction)\r\n private\r\n function GetEncoding: string;\r\n function GetStandalone: Boolean;\r\n function GetVersion: string;\r\n procedure SetEncoding(const Value: string);\r\n procedure SetStandalone(const Value: Boolean);\r\n procedure SetVersion(const Value: string);\r\n public\r\n constructor Create; override;\r\n\r\n procedure LoadFromStringStream(StringStream: TJclStringStream); override;\r\n procedure SaveToStringStream(StringStream: TJclStringStream; const Level: string = ''); override;\r\n property Version: string read GetVersion write SetVersion;\r\n property StandAlone: Boolean read GetStandalone write SetStandalone;\r\n property Encoding: string read GetEncoding write SetEncoding;\r\n end;\r\n\r\n // for backward compatibility\r\n TJclSimpleXMLElemSheet = class(TJclSimpleXMLElemProcessingInstruction)\r\n end;\r\n\r\n // for backward compatibility\r\n TJclSimpleXMLElemMSOApplication = class(TJclSimpleXMLElemProcessingInstruction)\r\n end;\r\n\r\n TJclSimpleXMLElemDocType = class(TJclSimpleXMLElem)\r\n public\r\n procedure LoadFromStringStream(StringStream: TJclStringStream); override;\r\n procedure SaveToStringStream(StringStream: TJclStringStream; const Level: string = ''); override;\r\n end;\r\n\r\n TJclSimpleXMLOptions = set of (sxoAutoCreate, sxoAutoIndent, sxoAutoEncodeValue,\r\n sxoAutoEncodeEntity, sxoDoNotSaveProlog, sxoTrimPrecedingTextWhitespace,\r\n sxoTrimFollowingTextWhitespace, sxoKeepWhitespace, sxoDoNotSaveBOM, sxoCaseSensitive);\r\n TJclSimpleXMLEncodeEvent = procedure(Sender: TObject; var Value: string) of object;\r\n TJclSimpleXMLEncodeStreamEvent = procedure(Sender: TObject; InStream, OutStream: TStream) of object;\r\n\r\n TJclSimpleXML = class(TObject)\r\n protected\r\n FEncoding: TJclStringEncoding;\r\n FCodePage: Word;\r\n FFileName: TFileName;\r\n FOptions: TJclSimpleXMLOptions;\r\n FRoot: TJclSimpleXMLElemClassic;\r\n FOnTagParsed: TJclOnSimpleXMLParsed;\r\n FOnValue: TJclOnValueParsed;\r\n FOnLoadProg: TJclOnSimpleProgress;\r\n FOnSaveProg: TJclOnSimpleProgress;\r\n FProlog: TJclSimpleXMLElemsProlog;\r\n FSaveCount: Integer;\r\n FSaveCurrent: Integer;\r\n FIndentString: string;\r\n FBaseIndentString: string;\r\n FOnEncodeValue: TJclSimpleXMLEncodeEvent;\r\n FOnDecodeValue: TJclSimpleXMLEncodeEvent;\r\n FOnDecodeStream: TJclSimpleXMLEncodeStreamEvent;\r\n FOnEncodeStream: TJclSimpleXMLEncodeStreamEvent;\r\n procedure SetIndentString(const Value: string);\r\n procedure SetBaseIndentString(const Value: string);\r\n procedure SetRoot(const Value: TJclSimpleXMLElemClassic);\r\n procedure SetFileName(const Value: TFileName);\r\n protected\r\n procedure DoLoadProgress(const APosition, ATotal: Integer);\r\n procedure DoSaveProgress;\r\n procedure DoTagParsed(const AName: string);\r\n procedure DoValueParsed(const AName, AValue: string);\r\n procedure DoEncodeValue(var Value: string); virtual;\r\n procedure DoDecodeValue(var Value: string); virtual;\r\n procedure GetEncodingFromXMLHeader(var Encoding: TJclStringEncoding; var CodePage: Word);\r\n public\r\n constructor Create;\r\n destructor Destroy; override;\r\n procedure LoadFromString(const Value: string);\r\n procedure LoadFromFile(const FileName: TFileName; Encoding: TJclStringEncoding = seAuto; CodePage: Word = CP_ACP);\r\n procedure LoadFromStream(Stream: TStream; Encoding: TJclStringEncoding = seAuto; CodePage: Word = CP_ACP);\r\n procedure LoadFromStringStream(StringStream: TJclStringStream);\r\n procedure LoadFromResourceName(Instance: THandle; const ResName: string; Encoding: TJclStringEncoding = seAuto; CodePage: Word = CP_ACP);\r\n procedure SaveToFile(const FileName: TFileName; Encoding: TJclStringEncoding = seAuto; CodePage: Word = CP_ACP);\r\n procedure SaveToStream(Stream: TStream; Encoding: TJclStringEncoding = seAuto; CodePage: Word = CP_ACP);\r\n procedure SaveToStringStream(StringStream: TJclStringStream);\r\n function SaveToString: string;\r\n function SaveToStringEncoding(Encoding: TJclStringEncoding; CodePage: Word = CP_ACP): string;\r\n property CodePage: Word read FCodePage;\r\n property Prolog: TJclSimpleXMLElemsProlog read FProlog write FProlog;\r\n property Root: TJclSimpleXMLElemClassic read FRoot write SetRoot;\r\n property XMLData: string read SaveToString write LoadFromString;\r\n property FileName: TFileName read FFileName write SetFileName;\r\n property IndentString: string read FIndentString write SetIndentString;\r\n property BaseIndentString: string read FBaseIndentString write SetBaseIndentString;\r\n property Options: TJclSimpleXMLOptions read FOptions write FOptions;\r\n property OnSaveProgress: TJclOnSimpleProgress read FOnSaveProg write FOnSaveProg;\r\n property OnLoadProgress: TJclOnSimpleProgress read FOnLoadProg write FOnLoadProg;\r\n property OnTagParsed: TJclOnSimpleXMLParsed read FOnTagParsed write FOnTagParsed;\r\n property OnValueParsed: TJclOnValueParsed read FOnValue write FOnValue;\r\n property OnEncodeValue: TJclSimpleXMLEncodeEvent read FOnEncodeValue write FOnEncodeValue;\r\n property OnDecodeValue: TJclSimpleXMLEncodeEvent read FOnDecodeValue write FOnDecodeValue;\r\n property OnEncodeStream: TJclSimpleXMLEncodeStreamEvent read FOnEncodeStream write FOnEncodeStream;\r\n property OnDecodeStream: TJclSimpleXMLEncodeStreamEvent read FOnDecodeStream write FOnDecodeStream;\r\n end;\r\n\r\n TXMLVariant = class(TInvokeableVariantType)\r\n public\r\n procedure Clear(var V: TVarData); override;\r\n function IsClear(const V: TVarData): Boolean; override;\r\n procedure Copy(var Dest: TVarData; const Source: TVarData;\r\n const Indirect: Boolean); override;\r\n procedure CastTo(var Dest: TVarData; const Source: TVarData;\r\n const AVarType: TVarType); override;\r\n\r\n function DoFunction(var Dest: TVarData; const V: TVarData;\r\n const Name: string; const Arguments: TVarDataArray): Boolean; override;\r\n function GetProperty(var Dest: TVarData; const V: TVarData;\r\n const Name: string): Boolean; override;\r\n function SetProperty(const V: TVarData; const Name: string;\r\n const Value: TVarData): Boolean; override;\r\n end;\r\n\r\nprocedure XMLCreateInto(var ADest: Variant; const AXML: TJclSimpleXMLElem);\r\nfunction XMLCreate(const AXML: TJclSimpleXMLElem): Variant; overload;\r\nfunction XMLCreate: Variant; overload;\r\nfunction VarXML: TVarType;\r\n\r\n// Encodes a string into an internal format:\r\n// any character TAB,LF,CR,#32..#127 is preserved\r\n// all other characters are converted to hex notation except\r\n// for some special characters that are converted to XML entities\r\nfunction SimpleXMLEncode(const S: string): string;\r\n// Decodes a string encoded with SimpleXMLEncode:\r\n// any character TAB,LF,CR,#32..#127 is preserved\r\n// all other characters and substrings are converted from\r\n// the special XML entities to characters or from hex to characters\r\n// NB! Setting TrimBlanks to true will slow down the process considerably\r\nprocedure SimpleXMLDecode(var S: string; TrimBlanks: Boolean);\r\n\r\nfunction XMLEncode(const S: string): string;\r\nfunction XMLDecode(const S: string): string;\r\n\r\n// Encodes special characters (', \", <, > and &) into XML entities (@apos;, ", <, > and &)\r\nfunction EntityEncode(const S: string): string;\r\n// Decodes XML entities (@apos;, ", <, > and &) into special characters (', \", <, > and &)\r\nfunction EntityDecode(const S: string): string;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jcl.svn.sourceforge.net/svnroot/jcl/tags/JCL-2.4-Build4571/jcl/source/common/JclSimpleXml.pas $';\r\n Revision: '$Revision: 3861 $';\r\n Date: '$Date: 2012-09-04 16:08:04 +0200 (mar. 04 sept. 2012) $';\r\n LogPath: 'JCL\\source\\common';\r\n Extra: '';\r\n Data: nil\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n {$IFDEF HAS_UNITSCOPE}\r\n System.Types,\r\n {$ENDIF HAS_UNITSCOPE}\r\n JclCharsets,\r\n JclStrings,\r\n JclUnicode,\r\n JclStringConversions,\r\n JclResources;\r\n\r\nconst\r\n cBufferSize = 8192;\r\n\r\nvar\r\n GlobalXMLVariant: TXMLVariant = nil;\r\n\r\n PreparedNibbleCharMapping: Boolean = False;\r\n NibbleCharMapping: array [Low(Char)..High(Char)] of Byte;\r\n\r\nfunction XMLVariant: TXMLVariant;\r\nbegin\r\n if not Assigned(GlobalXMLVariant) then\r\n GlobalXMLVariant := TXMLVariant.Create;\r\n Result := GlobalXMLVariant;\r\nend;\r\n\r\nprocedure AddEntity(var Res: string; var ResIndex, ResLen: Integer; const Entity: string);\r\nvar\r\n EntityIndex, EntityLen: Integer;\r\nbegin\r\n EntityLen := Length(Entity);\r\n if (ResIndex + EntityLen) > ResLen then\r\n begin\r\n if ResLen <= EntityLen then\r\n ResLen := ResLen * EntityLen\r\n else\r\n ResLen := ResLen * 2;\r\n SetLength(Res, ResLen);\r\n end;\r\n for EntityIndex := 1 to EntityLen do\r\n begin\r\n Res[ResIndex] := Entity[EntityIndex];\r\n Inc(ResIndex);\r\n end;\r\nend;\r\n\r\nfunction EntityEncode(const S: string): string;\r\nvar\r\n C: Char;\r\n SIndex, SLen, RIndex, RLen: Integer;\r\n Tmp: string;\r\nbegin\r\n SLen := Length(S);\r\n RLen := SLen;\r\n RIndex := 1;\r\n SetLength(Tmp, RLen);\r\n for SIndex := 1 to SLen do\r\n begin\r\n C := S[SIndex];\r\n case C of\r\n '\"':\r\n AddEntity(Tmp, RIndex, RLen, '"');\r\n '&':\r\n AddEntity(Tmp, RIndex, RLen, '&');\r\n #39:\r\n AddEntity(Tmp, RIndex, RLen, ''');\r\n '<':\r\n AddEntity(Tmp, RIndex, RLen, '<');\r\n '>':\r\n AddEntity(Tmp, RIndex, RLen, '>');\r\n else\r\n if RIndex > RLen then\r\n begin\r\n RLen := RLen * 2;\r\n SetLength(Tmp, RLen);\r\n end;\r\n Tmp[RIndex] := C;\r\n Inc(RIndex);\r\n end;\r\n end;\r\n if RIndex > 1 then\r\n SetLength(Tmp, RIndex - 1);\r\n\r\n Result := Tmp;\r\nend;\r\n\r\nfunction EntityDecode(const S: string): string;\r\nvar\r\n I, J, L: Integer;\r\nbegin\r\n Result := S;\r\n I := 1;\r\n J := 1;\r\n L := Length(Result);\r\n\r\n while I <= L do\r\n begin\r\n if Result[I] = '&' then\r\n begin\r\n if StrSame(Copy(Result, I, 5), '&') then\r\n begin\r\n Result[J] := '&';\r\n Inc(J);\r\n Inc(I, 4);\r\n end\r\n else\r\n if StrSame(Copy(Result, I, 4), '<') then\r\n begin\r\n Result[J] := '<';\r\n Inc(J);\r\n Inc(I, 3);\r\n end\r\n else\r\n if StrSame(Copy(Result, I, 4), '>') then\r\n begin\r\n Result[J] := '>';\r\n Inc(J);\r\n Inc(I, 3);\r\n end\r\n else\r\n if StrSame(Copy(Result, I, 6), ''') then\r\n begin\r\n Result[J] := #39;\r\n Inc(J);\r\n Inc(I, 5);\r\n end\r\n else\r\n if StrSame(Copy(Result, I, 6), '"') then\r\n begin\r\n Result[J] := '\"';\r\n Inc(J);\r\n Inc(I, 5);\r\n end\r\n else\r\n begin\r\n Result[J] := Result[I];\r\n Inc(J);\r\n end;\r\n end\r\n else\r\n begin\r\n Result[J] := Result[I];\r\n Inc(J);\r\n end;\r\n Inc(I);\r\n end;\r\n if J > 1 then\r\n SetLength(Result, J - 1)\r\n else\r\n SetLength(Result, 0);\r\nend;\r\n\r\nfunction SimpleXMLEncode(const S: string): string;\r\nvar\r\n C: Char;\r\n SIndex, SLen, RIndex, RLen: Integer;\r\n Tmp: string;\r\nbegin\r\n SLen := Length(S);\r\n RLen := SLen;\r\n RIndex := 1;\r\n SetLength(Tmp, RLen);\r\n for SIndex := 1 to SLen do\r\n begin\r\n C := S[SIndex];\r\n case C of\r\n '\"':\r\n AddEntity(Tmp, RIndex, RLen, '"');\r\n '&':\r\n AddEntity(Tmp, RIndex, RLen, '&');\r\n #39:\r\n AddEntity(Tmp, RIndex, RLen, ''');\r\n '<':\r\n AddEntity(Tmp, RIndex, RLen, '<');\r\n '>':\r\n AddEntity(Tmp, RIndex, RLen, '>');\r\n NativeNull..NativeBackspace, // NativeTab, NativeLineFeed\r\n NativeVerticalTab..NativeFormFeed, // NativeCarriageReturn\r\n NativeSo..NativeUs,\r\n Char(128)..Char(255):\r\n AddEntity(Tmp, RIndex, RLen, Format('&#x%.2x;', [Ord(C)]));\r\n {$IFDEF SUPPORTS_UNICODE}\r\n Char(256)..High(Char):\r\n AddEntity(Tmp, RIndex, RLen, Format('&#x%.4x;', [Ord(C)]));\r\n {$ENDIF SUPPORTS_UNICODE}\r\n else\r\n if RIndex > RLen then\r\n begin\r\n RLen := RLen * 2;\r\n SetLength(Tmp, RLen);\r\n end;\r\n Tmp[RIndex] := C;\r\n Inc(RIndex);\r\n end;\r\n end;\r\n if RIndex > 1 then\r\n SetLength(Tmp, RIndex - 1);\r\n\r\n Result := Tmp;\r\nend;\r\n\r\nprocedure SimpleXMLDecode(var S: string; TrimBlanks: Boolean);\r\n procedure DecodeEntity(var S: string; StringLength: Cardinal;\r\n var ReadIndex, WriteIndex: Cardinal);\r\n const\r\n cHexPrefix: array [Boolean] of string = ('', '$');\r\n var\r\n I: Cardinal;\r\n Value: Integer;\r\n IsHex: Boolean;\r\n begin\r\n Inc(ReadIndex, 2);\r\n IsHex := (ReadIndex <= StringLength) and ((S[ReadIndex] = 'x') or (S[ReadIndex] = 'X'));\r\n Inc(ReadIndex, Ord(IsHex));\r\n I := ReadIndex;\r\n while ReadIndex <= StringLength do\r\n begin\r\n if S[ReadIndex] = ';' then\r\n begin\r\n Value := StrToIntDef(cHexPrefix[IsHex] + Copy(S, I, ReadIndex - I), -1); // no characters are less than 0\r\n if Value >= 0 then\r\n S[WriteIndex] := Chr(Value)\r\n else\r\n ReadIndex := I - (2 + Cardinal(IsHex)); // reset to start\r\n Exit;\r\n end;\r\n Inc(ReadIndex);\r\n end;\r\n ReadIndex := I - (2 + Cardinal(IsHex)); // reset to start\r\n end;\r\n\r\n procedure SkipBlanks(var S: string; StringLength: Cardinal; var ReadIndex: Cardinal);\r\n begin\r\n while ReadIndex < StringLength do\r\n begin\r\n if S[ReadIndex] = NativeCarriageReturn then\r\n S[ReadIndex] := NativeLineFeed\r\n else\r\n if S[ReadIndex + 1] = NativeCarriageReturn then\r\n S[ReadIndex + 1] := NativeLineFeed;\r\n if (S[ReadIndex] < #33) and (S[ReadIndex] = S[ReadIndex + 1]) then\r\n Inc(ReadIndex)\r\n else\r\n Exit;\r\n end;\r\n end;\r\n\r\nvar\r\n StringLength, ReadIndex, WriteIndex: Cardinal;\r\nbegin\r\n // NB! This procedure replaces the text inplace to speed up the conversion. This\r\n // works because when decoding, the string can only become shorter. This is\r\n // accomplished by keeping track of the current read and write points.\r\n // In addition, the original string length is read only once and passed to the\r\n // inner procedures to speed up conversion as much as possible\r\n ReadIndex := 1;\r\n WriteIndex := 1;\r\n StringLength := Length(S);\r\n while ReadIndex <= StringLength do\r\n begin\r\n // this call lowers conversion speed by ~30%, ie 21MB/sec -> 15MB/sec (repeated tests, various inputs)\r\n if TrimBlanks then\r\n SkipBlanks(S, StringLength, ReadIndex);\r\n if S[ReadIndex] = '&' then\r\n begin\r\n if (ReadIndex < StringLength) and (S[ReadIndex + 1] = '#') then\r\n begin\r\n DecodeEntity(S, StringLength, ReadIndex, WriteIndex);\r\n Inc(WriteIndex);\r\n end\r\n else\r\n if StrSame(Copy(S, ReadIndex, 5), '&') then\r\n begin\r\n S[WriteIndex] := '&';\r\n Inc(WriteIndex);\r\n Inc(ReadIndex, 4);\r\n end\r\n else\r\n if StrSame(Copy(S, ReadIndex, 4), '<') then\r\n begin\r\n S[WriteIndex] := '<';\r\n Inc(WriteIndex);\r\n Inc(ReadIndex, 3);\r\n end\r\n else\r\n if StrSame(Copy(S, ReadIndex, 4), '>') then\r\n begin\r\n S[WriteIndex] := '>';\r\n Inc(WriteIndex);\r\n Inc(ReadIndex, 3);\r\n end\r\n else\r\n if StrSame(Copy(S, ReadIndex, 6), ''') then\r\n begin\r\n S[WriteIndex] := #39;\r\n Inc(WriteIndex);\r\n Inc(ReadIndex, 5);\r\n end\r\n else\r\n if StrSame(Copy(S, ReadIndex, 6), '"') then\r\n begin\r\n S[WriteIndex] := '\"';\r\n Inc(WriteIndex);\r\n Inc(ReadIndex, 5);\r\n end\r\n else\r\n begin\r\n S[WriteIndex] := S[ReadIndex];\r\n Inc(WriteIndex);\r\n end;\r\n end\r\n else\r\n begin\r\n S[WriteIndex] := S[ReadIndex];\r\n Inc(WriteIndex);\r\n end;\r\n Inc(ReadIndex);\r\n end;\r\n if WriteIndex > 0 then\r\n SetLength(S, WriteIndex - 1)\r\n else\r\n SetLength(S, 0);\r\n // this call lowers conversion speed by ~65%, ie 21MB/sec -> 7MB/sec (repeated tests, various inputs)\r\n// if TrimBlanks then\r\n// S := AdjustLineBreaks(S);\r\nend;\r\n\r\nfunction XMLEncode(const S: string): string;\r\nbegin\r\n Result := SimpleXMLEncode(S);\r\nend;\r\n\r\nfunction XMLDecode(const S: string): string;\r\nbegin\r\n Result := S;\r\n SimpleXMLDecode(Result, False);\r\nend;\r\n\r\n//=== { TJclSimpleItem } =====================================================\r\n\r\nprocedure TJclSimpleItem.SetName(const Value: string);\r\nbegin\r\n FName := Value;\r\nend;\r\n\r\n//=== { TJclSimpleItemHashedList } ===========================================\r\n\r\nprocedure TJclSimpleItemHashedList.Clear;\r\nbegin\r\n InvalidateHash;\r\n inherited Clear;\r\nend;\r\n\r\nconstructor TJclSimpleItemHashedList.Create(ACaseSensitive: Boolean);\r\nbegin\r\n inherited Create(True);\r\n FCaseSensitive := ACaseSensitive;\r\nend;\r\n\r\ndestructor TJclSimpleItemHashedList.Destroy;\r\nbegin\r\n FreeAndNil(FNameHash);\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJclSimpleItemHashedList.Add(Item: TJclSimpleItem): Integer;\r\nbegin\r\n Result := inherited Add(Item);\r\n if FNameHash <> nil then\r\n begin\r\n if FCaseSensitive then\r\n FNameHash.Add(Item.Name, Result)\r\n else\r\n FNameHash.Add(UpperCase(Item.Name), Result);\r\n end;\r\nend;\r\n\r\nfunction TJclSimpleItemHashedList.GetSimpleItem(Index: Integer): TJclSimpleItem;\r\nbegin\r\n Result := TJclSimpleItem(GetItem(Index));\r\nend;\r\n\r\nfunction TJclSimpleItemHashedList.GetSimpleItemByName(const Name: string): TJclSimpleItem;\r\nvar\r\n I: Integer;\r\nbegin\r\n I := IndexOfName(Name);\r\n if I >= 0 then\r\n Result := TJclSimpleItem(Items[I])\r\n else\r\n Result := nil;\r\nend;\r\n\r\nfunction TJclSimpleItemHashedList.IndexOfSimpleItem(Item: TJclSimpleItem): Integer;\r\nbegin\r\n Result := IndexOf(Item);\r\nend;\r\n\r\nfunction TJclSimpleItemHashedList.IndexOfName(const Name: string): Integer;\r\nvar\r\n I: Integer;\r\nbegin\r\n if FCaseSensitive then\r\n begin\r\n if FNameHash = nil then\r\n begin\r\n FNameHash := TStringHash.Create(8);\r\n for I := 0 to Count - 1 do\r\n FNameHash.Add(TJclSimpleData(Items[I]).Name, I);\r\n end;\r\n Result := FNameHash.ValueOf(Name);\r\n end\r\n else\r\n begin\r\n if FNameHash = nil then\r\n begin\r\n FNameHash := TStringHash.Create(8);\r\n for I := 0 to Count - 1 do\r\n FNameHash.Add(UpperCase(TJclSimpleData(Items[I]).Name), I);\r\n end;\r\n Result := FNameHash.ValueOf(UpperCase(Name));\r\n end;\r\nend;\r\n\r\nprocedure TJclSimpleItemHashedList.Insert(Index: Integer; Item: TJclSimpleItem);\r\nbegin\r\n InvalidateHash;\r\n inherited Insert(Index, Item);\r\nend;\r\n\r\nprocedure TJclSimpleItemHashedList.InvalidateHash;\r\nbegin\r\n FreeAndNil(FNameHash);\r\nend;\r\n\r\nprocedure TJclSimpleItemHashedList.Move(CurIndex, NewIndex: Integer);\r\nbegin\r\n InvalidateHash;\r\n inherited Move(CurIndex, NewIndex);\r\nend;\r\n\r\nprocedure TJclSimpleItemHashedList.Notify(Ptr: Pointer; Action: TListNotification);\r\nbegin\r\n if (Action = lnDeleted) and (FNameHash <> nil) then\r\n begin\r\n if FCaseSensitive then\r\n FNameHash.Remove(TJclSimpleItem(Ptr).Name)\r\n else\r\n FNameHash.Remove(UpperCase(TJclSimpleItem(Ptr).Name));\r\n end;\r\n inherited Notify(Ptr, Action);\r\nend;\r\n\r\nprocedure TJclSimpleItemHashedList.SetCaseSensitive(const Value: Boolean);\r\nbegin\r\n if FCaseSensitive <> Value then\r\n begin\r\n InvalidateHash;\r\n FCaseSensitive := Value;\r\n end;\r\nend;\r\n\r\n//=== { TJclSimpleData } =====================================================\r\n\r\nconstructor TJclSimpleData.Create;\r\nbegin\r\n inherited Create;\r\nend;\r\n\r\nconstructor TJclSimpleData.Create(const AName: string);\r\nbegin\r\n inherited Create;\r\n FName := AName;\r\nend;\r\n\r\nconstructor TJclSimpleData.Create(const AName, AValue: string);\r\nbegin\r\n inherited Create;\r\n FName := AName;\r\n FValue := AValue;\r\nend;\r\n\r\nfunction TJclSimpleData.GetAnsiValue: AnsiString;\r\nbegin\r\n Result := AnsiString(Value);\r\nend;\r\n\r\nfunction TJclSimpleData.GetBoolValue: Boolean;\r\nbegin\r\n Result := StrToBoolDef(Value, False);\r\nend;\r\n\r\nfunction TJclSimpleData.GetFloatValue: Extended;\r\nbegin\r\n Result := 0.0;\r\n if not TryStrToFloat(Value, Result) then\r\n Result := 0.0;\r\nend;\r\n\r\nfunction TJclSimpleData.GetIntValue: Int64;\r\nbegin\r\n Result := StrToInt64Def(Value, -1);\r\nend;\r\n\r\nprocedure TJclSimpleData.SetAnsiValue(const Value: AnsiString);\r\nbegin\r\n Self.Value := string(Value);\r\nend;\r\n\r\nprocedure TJclSimpleData.SetBoolValue(const Value: Boolean);\r\nbegin\r\n FValue := BoolToStr(Value);\r\nend;\r\n\r\nprocedure TJclSimpleData.SetFloatValue(const Value: Extended);\r\nbegin\r\n FValue := FloatToStr(Value);\r\nend;\r\n\r\nprocedure TJclSimpleData.SetIntValue(const Value: Int64);\r\nbegin\r\n FValue := IntToStr(Value);\r\nend;\r\n\r\n//=== { TJclSimpleXMLData } ==================================================\r\n\r\nfunction TJclSimpleXMLData.FullName: string;\r\nbegin\r\n if NameSpace <> '' then\r\n Result := NameSpace + ':' + Name\r\n else\r\n Result := Name;\r\nend;\r\n\r\n//=== { TJclSimpleXML } ======================================================\r\n\r\nconstructor TJclSimpleXML.Create;\r\nbegin\r\n inherited Create;\r\n FRoot := TJclSimpleXMLElemClassic.Create(Self);\r\n FProlog := TJclSimpleXMLElemsProlog.Create(Self);\r\n FOptions := [sxoAutoIndent, sxoAutoEncodeValue, sxoAutoEncodeEntity];\r\n FIndentString := ' ';\r\nend;\r\n\r\ndestructor TJclSimpleXML.Destroy;\r\nbegin\r\n FreeAndNil(FRoot);\r\n FreeAndNil(FProlog);\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJclSimpleXML.DoDecodeValue(var Value: string);\r\nbegin\r\n if sxoAutoEncodeValue in Options then\r\n SimpleXMLDecode(Value, False)\r\n else\r\n if sxoAutoEncodeEntity in Options then\r\n Value := EntityDecode(Value);\r\n if Assigned(FOnDecodeValue) then\r\n FOnDecodeValue(Self, Value);\r\nend;\r\n\r\nprocedure TJclSimpleXML.DoEncodeValue(var Value: string);\r\nbegin\r\n if Assigned(FOnEncodeValue) then\r\n FOnEncodeValue(Self, Value);\r\n if sxoAutoEncodeValue in Options then\r\n Value := SimpleXMLEncode(Value)\r\n else\r\n if sxoAutoEncodeEntity in Options then\r\n Value := EntityEncode(Value);\r\nend;\r\n\r\nprocedure TJclSimpleXML.DoLoadProgress(const APosition, ATotal: Integer);\r\nbegin\r\n if Assigned(FOnLoadProg) then\r\n FOnLoadProg(Self, APosition, ATotal);\r\nend;\r\n\r\nprocedure TJclSimpleXML.DoSaveProgress;\r\nbegin\r\n if Assigned(FOnSaveProg) then\r\n begin\r\n Inc(FSaveCount);\r\n FOnSaveProg(Self, FSaveCurrent, FSaveCount);\r\n end;\r\nend;\r\n\r\nprocedure TJclSimpleXML.DoTagParsed(const AName: string);\r\nbegin\r\n if Assigned(FOnTagParsed) then\r\n FOnTagParsed(Self, AName);\r\nend;\r\n\r\nprocedure TJclSimpleXML.DoValueParsed(const AName, AValue: string);\r\nbegin\r\n if Assigned(FOnValue) then\r\n FOnValue(Self, AName, AValue);\r\nend;\r\n\r\nprocedure TJclSimpleXML.LoadFromFile(const FileName: TFileName; Encoding: TJclStringEncoding; CodePage: Word);\r\nvar\r\n Stream: TMemoryStream;\r\nbegin\r\n Stream := TMemoryStream.Create;\r\n try\r\n Stream.LoadFromFile(FileName);\r\n LoadFromStream(Stream, Encoding, CodePage);\r\n finally\r\n Stream.Free;\r\n end;\r\nend;\r\n\r\nprocedure TJclSimpleXML.LoadFromResourceName(Instance: THandle; const ResName: string;\r\n Encoding: TJclStringEncoding; CodePage: Word);\r\n{$IFNDEF MSWINDOWS}\r\nconst\r\n RT_RCDATA = PChar(10);\r\n{$ENDIF !MSWINDOWS}\r\nvar\r\n Stream: TResourceStream;\r\nbegin\r\n Stream := TResourceStream.Create(Instance, ResName, RT_RCDATA);\r\n try\r\n LoadFromStream(Stream, Encoding, CodePage);\r\n finally\r\n Stream.Free;\r\n end;\r\nend;\r\n\r\nprocedure TJclSimpleXML.LoadFromStream(Stream: TStream; Encoding: TJclStringEncoding; CodePage: Word);\r\nvar\r\n AOutStream: TStream;\r\n AStringStream: TJclStringStream;\r\n DoFree: Boolean;\r\nbegin\r\n FRoot.Clear;\r\n FProlog.Clear;\r\n AOutStream := nil;\r\n DoFree := False;\r\n try\r\n if Assigned(FOnDecodeStream) then\r\n begin\r\n AOutStream := TMemoryStream.Create;\r\n DoFree := True;\r\n FOnDecodeStream(Self, Stream, AOutStream);\r\n AOutStream.Seek(0, soBeginning);\r\n end\r\n else\r\n AOutStream := Stream;\r\n\r\n case Encoding of\r\n seAnsi:\r\n begin\r\n AStringStream := TJclAnsiStream.Create(AOutStream, False);\r\n TJclAnsiStream(AStringStream).CodePage := CodePage;\r\n end;\r\n seUTF8:\r\n AStringStream := TJclUTF8Stream.Create(AOutStream, False);\r\n seUTF16:\r\n AStringStream := TJclUTF16Stream.Create(AOutStream, False);\r\n else\r\n AStringStream := TJclAutoStream.Create(AOutStream, False);\r\n if CodePage <> CP_ACP then\r\n TJclAutoStream(AStringStream).CodePage := CodePage;\r\n end;\r\n try\r\n AStringStream.SkipBOM;\r\n\r\n LoadFromStringStream(AStringStream);\r\n\r\n // save codepage and encoding for future saves\r\n if AStringStream is TJclAutoStream then\r\n begin\r\n FCodePage := TJclAutoStream(AStringStream).CodePage;\r\n FEncoding := TJclAutoStream(AStringStream).Encoding;\r\n end\r\n else\r\n if AStringStream is TJclAnsiStream then\r\n begin\r\n FCodePage := TJclAnsiStream(AStringStream).CodePage;\r\n FEncoding := Encoding;\r\n end\r\n else\r\n begin\r\n FCodePage := CodePage;\r\n FEncoding := Encoding;\r\n end;\r\n finally\r\n AStringStream.Free;\r\n end;\r\n finally\r\n if DoFree then\r\n AOutStream.Free;\r\n end;\r\nend;\r\n\r\nprocedure TJclSimpleXML.LoadFromStringStream(StringStream: TJclStringStream);\r\nvar\r\n BufferSize: Integer;\r\nbegin\r\n if Assigned(FOnLoadProg) then\r\n FOnLoadProg(Self, StringStream.Stream.Position, StringStream.Stream.Size);\r\n\r\n BufferSize := StringStream.BufferSize;\r\n StringStream.BufferSize := 1;\r\n\r\n // Read doctype and so on\r\n FProlog.LoadFromStringStream(StringStream);\r\n\r\n StringStream.BufferSize := BufferSize;\r\n\r\n // Read elements\r\n FRoot.LoadFromStringStream(StringStream);\r\n\r\n if Assigned(FOnLoadProg) then\r\n FOnLoadProg(Self, StringStream.Stream.Position, StringStream.Stream.Size);\r\nend;\r\n\r\nprocedure TJclSimpleXML.LoadFromString(const Value: string);\r\nvar\r\n Stream: TStringStream;\r\nbegin\r\n Stream := TStringStream.Create(Value {$IFDEF SUPPORTS_UNICODE}, TEncoding.Unicode{$ENDIF});\r\n try\r\n LoadFromStream(Stream {$IFDEF SUPPORTS_UNICODE}, seUTF16, CP_UTF16LE{$ENDIF});\r\n finally\r\n Stream.Free;\r\n end;\r\nend;\r\n\r\nprocedure TJclSimpleXML.GetEncodingFromXMLHeader(var Encoding: TJclStringEncoding; var CodePage: Word);\r\nvar\r\n XMLHeader: TJclSimpleXMLElemHeader;\r\n I: Integer;\r\nbegin\r\n XMLHeader := nil;\r\n for I := 0 to Prolog.Count - 1 do\r\n if Prolog.Item[I] is TJclSimpleXMLElemHeader then\r\n begin\r\n XMLHeader := TJclSimpleXMLElemHeader(Prolog.Item[I]);\r\n Break;\r\n end;\r\n if Assigned(XMLHeader) then\r\n begin\r\n CodePage := CodePageFromCharsetName(XMLHeader.Encoding);\r\n case CodePage of\r\n CP_UTF8:\r\n Encoding := seUTF8;\r\n CP_UTF16LE:\r\n Encoding := seUTF16;\r\n else\r\n Encoding := seAnsi;\r\n end;\r\n end\r\n else\r\n begin\r\n // restore from previous load\r\n Encoding := FEncoding;\r\n CodePage := FCodePage;\r\n end;\r\nend;\r\n\r\nprocedure TJclSimpleXML.SaveToFile(const FileName: TFileName; Encoding: TJclStringEncoding; CodePage: Word);\r\nvar\r\n Stream: TMemoryStream;\r\nbegin\r\n Stream := TMemoryStream.Create;\r\n try\r\n SaveToStream(Stream, Encoding, CodePage);\r\n Stream.SaveToFile(FileName);\r\n finally\r\n Stream.Free;\r\n end;\r\nend;\r\n\r\nprocedure TJclSimpleXML.SaveToStream(Stream: TStream; Encoding: TJclStringEncoding; CodePage: Word);\r\nvar\r\n AOutStream: TStream;\r\n AStringStream: TJclStringStream;\r\n DoFree: Boolean;\r\nbegin\r\n if Assigned(FOnEncodeStream) then\r\n begin\r\n AOutStream := TMemoryStream.Create;\r\n DoFree := True;\r\n end\r\n else\r\n begin\r\n AOutStream := Stream;\r\n DoFree := False;\r\n end;\r\n try\r\n if Encoding = seAuto then\r\n GetEncodingFromXMLHeader(Encoding, CodePage);\r\n\r\n case Encoding of\r\n seUTF8:\r\n begin\r\n AStringStream := TJclUTF8Stream.Create(AOutStream, False);\r\n FCodePage := CP_UTF8;\r\n end;\r\n seUTF16:\r\n begin\r\n AStringStream := TJclUTF16Stream.Create(AOutStream, False);\r\n FCodePage := CP_UTF16LE;\r\n end\r\n else\r\n AStringStream := TJclAnsiStream.Create(AOutStream);\r\n TJclAnsiStream(AStringStream).CodePage := CodePage;\r\n end;\r\n try\r\n if not (sxoDoNotSaveBOM in Options) then\r\n AStringStream.WriteBOM;\r\n SaveToStringStream(AStringStream);\r\n AStringStream.Flush;\r\n finally\r\n AStringStream.Free;\r\n end;\r\n if Assigned(FOnEncodeStream) then\r\n begin\r\n AOutStream.Seek(0, soBeginning);\r\n FOnEncodeStream(Self, AOutStream, Stream);\r\n end;\r\n finally\r\n if DoFree then\r\n AOutStream.Free;\r\n end;\r\nend;\r\n\r\nprocedure TJclSimpleXML.SaveToStringStream(StringStream: TJclStringStream);\r\nvar\r\n lCount: Integer;\r\nbegin\r\n lCount := Root.ChildsCount + Prolog.Count;\r\n FSaveCount := lCount;\r\n FSaveCurrent := 0;\r\n\r\n if Assigned(FOnSaveProg) then\r\n FOnSaveProg(Self, 0, lCount);\r\n\r\n if not (sxoDoNotSaveProlog in FOptions) then\r\n Prolog.SaveToStringStream(StringStream);\r\n\r\n Root.SaveToStringStream(StringStream, BaseIndentString);\r\n\r\n if Assigned(FOnSaveProg) then\r\n FOnSaveProg(Self, lCount, lCount);\r\nend;\r\n\r\nfunction TJclSimpleXML.SaveToString: string;\r\nbegin\r\n Result := SaveToStringEncoding(seAuto, CP_ACP);\r\nend;\r\n\r\nfunction TJclSimpleXML.SaveToStringEncoding(Encoding: TJclStringEncoding; CodePage: Word): string;\r\nvar\r\n Stream: TStringStream;\r\nbegin\r\n {$IFDEF SUPPORTS_UNICODE}\r\n // Use the same logic for seAuto as in SaveToStream for creating the TStringStream.\r\n // Otherwise a Unicode-TStringStream is written to from a TJclAnsiStream proxy.\r\n if Encoding = seAuto then\r\n GetEncodingFromXMLHeader(Encoding, CodePage);\r\n\r\n case Encoding of\r\n seAnsi:\r\n Stream := TStringStream.Create('', TEncoding.{$IFDEF COMPILER16_UP}ANSI{$ELSE}Default{$ENDIF});\r\n seUTF8:\r\n Stream := TStringStream.Create('', TEncoding.UTF8);\r\n else\r\n //seUTF16:\r\n Stream := TStringStream.Create('', TEncoding.Unicode);\r\n end;\r\n {$ELSE ~SUPPORTS_UNICODE}\r\n Stream := TStringStream.Create('');\r\n {$ENDIF ~SUPPORTS_UNICODE}\r\n try\r\n SaveToStream(Stream, Encoding, CodePage);\r\n Result := Stream.DataString;\r\n finally\r\n Stream.Free;\r\n end;\r\nend;\r\n\r\nprocedure TJclSimpleXML.SetBaseIndentString(const Value: string);\r\nbegin\r\n // test if the new value is only made of spaces or tabs\r\n if not StrContainsChars(Value, CharIsWhiteSpace, True) then\r\n Exit;\r\n\r\n FBaseIndentString := Value;\r\nend;\r\n\r\nprocedure TJclSimpleXML.SetFileName(const Value: TFileName);\r\nbegin\r\n FFileName := Value;\r\n LoadFromFile(Value);\r\nend;\r\n\r\n//=== { TJclSimpleXMLElem } ==================================================\r\n\r\nprocedure TJclSimpleXMLElem.Assign(Value: TJclSimpleXMLElem);\r\nvar\r\n Elems: TJclSimpleXMLElem;\r\n SrcElem, DestElem: TJclSimpleXMLElem;\r\n I: Integer;\r\n SrcProps, DestProps: TJclSimpleXMLProps;\r\n SrcProp: TJclSimpleXMLProp;\r\n SrcElems, DestElems: TJclSimpleXMLElems;\r\nbegin\r\n Clear;\r\n if Value = nil then\r\n Exit;\r\n Elems := TJclSimpleXMLElem(Value);\r\n Name := Elems.Name;\r\n Self.Value := Elems.Value;\r\n SrcProps := Elems.FProps;\r\n if Assigned(SrcProps) then\r\n begin\r\n DestProps := Properties;\r\n for I := 0 to SrcProps.Count - 1 do\r\n begin\r\n SrcProp := SrcProps.Item[I];\r\n DestProps.Add(SrcProp.Name, SrcProp.Value);\r\n end;\r\n end;\r\n\r\n SrcElems := Elems.FItems;\r\n if Assigned(SrcElems) then\r\n begin\r\n DestElems := Items;\r\n for I := 0 to SrcElems.Count - 1 do\r\n begin\r\n // Create from the class type, so that the virtual constructor is called\r\n // creating an element of the correct class type.\r\n SrcElem := SrcElems.Item[I];\r\n DestElem := TJclSimpleXMLElemClass(SrcElem.ClassType).Create(SrcElem.Name, SrcElem.Value);\r\n DestElem.Assign(SrcElem);\r\n DestElems.Add(DestElem);\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJclSimpleXMLElem.Clear;\r\nbegin\r\n if FItems <> nil then\r\n FItems.Clear;\r\n if FProps <> nil then\r\n FProps.Clear;\r\nend;\r\n\r\nconstructor TJclSimpleXMLElem.Create(ASimpleXML: TJclSimpleXML);\r\nbegin\r\n Create;\r\n FSimpleXML := ASimpleXML;\r\nend;\r\n\r\ndestructor TJclSimpleXMLElem.Destroy;\r\nbegin\r\n FSimpleXML := nil;\r\n FParent := nil;\r\n Clear;\r\n FreeAndNil(FItems);\r\n FreeAndNil(FProps);\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJclSimpleXMLElem.Error(const S: string);\r\nbegin\r\n raise EJclSimpleXMLError.Create(S);\r\nend;\r\n\r\nprocedure TJclSimpleXMLElem.FmtError(const S: string;\r\n const Args: array of const);\r\nbegin\r\n Error(Format(S, Args));\r\nend;\r\n\r\nprocedure TJclSimpleXMLElem.GetBinaryValue(Stream: TStream);\r\nvar\r\n I, J, ValueLength, RequiredStreamSize: Integer;\r\n Buf: array [0..cBufferSize - 1] of Byte;\r\n N1, N2: Byte;\r\n\r\n function NibbleCharToNibble(const AChar: Char): Byte;\r\n begin\r\n case AChar of\r\n '0': Result := 0;\r\n '1': Result := 1;\r\n '2': Result := 2;\r\n '3': Result := 3;\r\n '4': Result := 4;\r\n '5': Result := 5;\r\n '6': Result := 6;\r\n '7': Result := 7;\r\n '8': Result := 8;\r\n '9': Result := 9;\r\n 'a', 'A': Result := 10;\r\n 'b', 'B': Result := 11;\r\n 'c', 'C': Result := 12;\r\n 'd', 'D': Result := 13;\r\n 'e', 'E': Result := 14;\r\n 'f', 'F': Result := 15;\r\n else\r\n Result := 16;\r\n end;\r\n end;\r\n\r\n procedure PrepareNibbleCharMapping;\r\n var\r\n C: Char;\r\n begin\r\n if not PreparedNibbleCharMapping then\r\n begin\r\n for C := Low(Char) to High(Char) do\r\n NibbleCharMapping[C] := NibbleCharToNibble(C);\r\n PreparedNibbleCharMapping := True;\r\n end;\r\n end;\r\n\r\nvar\r\n CurrentStreamPosition: Integer;\r\nbegin\r\n PrepareNibbleCharMapping;\r\n I := 1;\r\n J := 0;\r\n ValueLength := Length(Value);\r\n RequiredStreamSize := Stream.Position + ValueLength div 2;\r\n if Stream.Size < RequiredStreamSize then\r\n begin\r\n CurrentStreamPosition := Stream.Position;\r\n Stream.Size := RequiredStreamSize;\r\n Stream.Seek(CurrentStreamPosition, soBeginning);\r\n end;\r\n while I < ValueLength do\r\n begin\r\n //faster replacement for St := '$' + Value[I] + Value[I + 1]; Buf[J] := StrToIntDef(St, 0);\r\n N1 := NibbleCharMapping[Value[I]];\r\n N2 := NibbleCharMapping[Value[I + 1]];\r\n Inc(I, 2);\r\n if (N1 > 15) or (N2 > 15) then\r\n Buf[J] := 0\r\n else\r\n Buf[J] := (N1 shl 4) or N2;\r\n Inc(J);\r\n if J = cBufferSize - 1 then //Buffered write to speed up the process a little\r\n begin\r\n Stream.Write(Buf, J);\r\n J := 0;\r\n end;\r\n end;\r\n Stream.Write(Buf, J);\r\nend;\r\n\r\nfunction TJclSimpleXMLElem.GetChildIndex(const AChild: TJclSimpleXMLElem): Integer;\r\nbegin\r\n if FItems = nil then\r\n Result := -1\r\n else\r\n Result := FItems.FElems.IndexOfSimpleItem(AChild);\r\nend;\r\n\r\nfunction TJclSimpleXMLElem.GetChildsCount: Integer;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := 1;\r\n if FItems <> nil then\r\n for I := 0 to FItems.Count - 1 do\r\n Result := Result + FItems[I].ChildsCount;\r\nend;\r\n\r\nfunction TJclSimpleXMLElem.GetHasItems: Boolean;\r\nbegin\r\n Result := Assigned(FItems) and (FItems.Count > 0);\r\nend;\r\n\r\nfunction TJclSimpleXMLElem.GetHasProperties: Boolean;\r\nbegin\r\n Result := Assigned(FProps) and (FProps.Count > 0);\r\nend;\r\n\r\nfunction TJclSimpleXMLElem.GetItemCount: Integer;\r\nbegin\r\n Result := 0;\r\n if Assigned(FItems) then\r\n Result := FItems.Count;\r\nend;\r\n\r\nfunction TJclSimpleXMLElem.GetItems: TJclSimpleXMLElems;\r\nbegin\r\n if FItems = nil then\r\n FItems := TJclSimpleXMLElems.Create(Self);\r\n Result := FItems;\r\nend;\r\n\r\nfunction TJclSimpleXMLElem.GetNamedIndex(const AChild: TJclSimpleXMLElem): Integer;\r\nbegin\r\n Result := Items.NamedElems[AChild.Name].IndexOf(AChild);\r\nend;\r\n\r\nfunction TJclSimpleXMLElem.GetPropertyCount: Integer;\r\nbegin\r\n Result := 0;\r\n if Assigned(FProps) then\r\n Result := FProps.Count;\r\nend;\r\n\r\nfunction TJclSimpleXMLElem.GetProps: TJclSimpleXMLProps;\r\nbegin\r\n if FProps = nil then\r\n FProps := TJclSimpleXMLProps.Create(Self);\r\n Result := FProps;\r\nend;\r\n\r\nprocedure TJclSimpleXMLElem.LoadFromString(const Value: string);\r\nvar\r\n Stream: TJclStringStream;\r\n StrStream: TStringStream;\r\nbegin\r\n StrStream := TStringStream.Create(Value);\r\n try\r\n Stream := TJclAutoStream.Create(StrStream);\r\n try\r\n LoadFromStringStream(Stream);\r\n finally\r\n Stream.Free;\r\n end;\r\n finally\r\n StrStream.Free;\r\n end;\r\nend;\r\n\r\nfunction TJclSimpleXMLElem.SaveToString: string;\r\nvar\r\n Stream: TJclStringStream;\r\n StrStream: TStringStream;\r\nbegin\r\n StrStream := TStringStream.Create('');\r\n try\r\n Stream := TJclAutoStream.Create(StrStream);\r\n try\r\n SaveToStringStream(Stream);\r\n Stream.Flush;\r\n finally\r\n Stream.Free;\r\n end;\r\n Result := StrStream.DataString;\r\n finally\r\n StrStream.Free;\r\n end;\r\nend;\r\n\r\nprocedure TJclSimpleXMLElem.SetName(const Value: string);\r\nbegin\r\n if (Value <> Name) and (Value <> '') then\r\n begin\r\n if (Parent <> nil) and (Name <> '') then\r\n Parent.Items.DoItemRename(Self, Value);\r\n inherited SetName(Value);\r\n end;\r\nend;\r\n\r\n//=== { TJclSimpleXMLNamedElemsEnumerator } ==================================\r\n\r\n{$IFDEF SUPPORTS_FOR_IN}\r\nconstructor TJclSimpleXMLNamedElemsEnumerator.Create(AList: TJclSimpleXMLNamedElems);\r\nbegin\r\n inherited Create;\r\n FIndex := -1;\r\n FList := AList;\r\nend;\r\n\r\nfunction TJclSimpleXMLNamedElemsEnumerator.GetCurrent: TJclSimpleXMLElem;\r\nbegin\r\n Result := FList[FIndex];\r\nend;\r\n\r\nfunction TJclSimpleXMLNamedElemsEnumerator.MoveNext: Boolean;\r\nbegin\r\n Result := FIndex < FList.Count - 1;\r\n if Result then\r\n Inc(FIndex);\r\nend;\r\n{$ENDIF SUPPORTS_FOR_IN}\r\n\r\n//=== { TJclSimpleXMLNamedElems } ============================================\r\n\r\nconstructor TJclSimpleXMLNamedElems.Create(AElems: TJclSimpleXMLElems; const AName: string);\r\nbegin\r\n inherited Create;\r\n FElems := AElems;\r\n FName := AName;\r\n FItems := TList.Create;\r\nend;\r\n\r\ndestructor TJclSimpleXMLNamedElems.Destroy;\r\nbegin\r\n FItems.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJclSimpleXMLNamedElems.Add(const Value: Int64): TJclSimpleXMLElemClassic;\r\nbegin\r\n Result := Elems.Add(Name, Value);\r\nend;\r\n\r\nfunction TJclSimpleXMLNamedElems.Add(Value: TStream): TJclSimpleXMLElemClassic;\r\nbegin\r\n Result := Elems.Add(Name, Value);\r\nend;\r\n\r\nfunction TJclSimpleXMLNamedElems.Add(const Value: Boolean): TJclSimpleXMLElemClassic;\r\nbegin\r\n Result := Elems.Add(Name, Value);\r\nend;\r\n\r\nfunction TJclSimpleXMLNamedElems.Add: TJclSimpleXMLElemClassic;\r\nbegin\r\n Result := Elems.Add(Name);\r\nend;\r\n\r\nfunction TJclSimpleXMLNamedElems.Add(const Value: string): TJclSimpleXMLElemClassic;\r\nbegin\r\n Result := Elems.Add(Name, Value);\r\nend;\r\n\r\nfunction TJclSimpleXMLNamedElems.AddCData(const Value: string): TJclSimpleXMLElemCData;\r\nbegin\r\n Result := Elems.AddCData(Name, Value);\r\nend;\r\n\r\nfunction TJclSimpleXMLNamedElems.AddComment(const Value: string): TJclSimpleXMLElemComment;\r\nbegin\r\n Result := Elems.AddComment(Name, Value);\r\nend;\r\n\r\nfunction TJclSimpleXMLNamedElems.AddFirst: TJclSimpleXMLElemClassic;\r\nbegin\r\n Result := Elems.AddFirst(Name);\r\nend;\r\n\r\nfunction TJclSimpleXMLNamedElems.AddText(const Value: string): TJclSimpleXMLElemText;\r\nbegin\r\n Result := Elems.AddText(Name, Value);\r\nend;\r\n\r\nprocedure TJclSimpleXMLNamedElems.Clear;\r\nvar\r\n Index: Integer;\r\nbegin\r\n for Index := FItems.Count - 1 downto 0 do\r\n Elems.Remove(TJclSimpleXMLElem(FItems.Items[Index]));\r\nend;\r\n\r\nprocedure TJclSimpleXMLNamedElems.Delete(const Index: Integer);\r\nbegin\r\n if (Index >= 0) and (Index < FItems.Count) then\r\n Elems.Remove(TJclSimpleXMLElem(FItems.Items[Index]));\r\nend;\r\n\r\nfunction TJclSimpleXMLNamedElems.GetCount: Integer;\r\nbegin\r\n Result := FItems.Count;\r\nend;\r\n\r\n{$IFDEF SUPPORTS_FOR_IN}\r\nfunction TJclSimpleXMLNamedElems.GetEnumerator: TJclSimpleXMLNamedElemsEnumerator;\r\nbegin\r\n Result := TJclSimpleXMLNamedElemsEnumerator.Create(Self);\r\nend;\r\n{$ENDIF SUPPORTS_FOR_IN}\r\n\r\nfunction TJclSimpleXMLNamedElems.GetItem(const Index: Integer): TJclSimpleXMLElem;\r\nbegin\r\n if (Index >= 0) then\r\n begin\r\n While (Index >= Count) do\r\n if Assigned(Elems.Parent) and Assigned(Elems.Parent.SimpleXML) and\r\n (sxoAutoCreate in Elems.Parent.SimpleXML.Options) then\r\n Add\r\n else\r\n break;\r\n if Index < Count then\r\n Result := TJclSimpleXMLElem(FItems.Items[Index])\r\n else\r\n Result := nil;\r\n end\r\n else\r\n Result := nil;\r\nend;\r\n\r\nfunction TJclSimpleXMLNamedElems.IndexOf(const Value: TJclSimpleXMLElem): Integer;\r\nbegin\r\n Result := FItems.IndexOf(Value);\r\nend;\r\n\r\nfunction TJclSimpleXMLNamedElems.IndexOf(const Value: string): Integer;\r\nvar\r\n Index: Integer;\r\n NewItem: TJclSimpleXMLElem;\r\nbegin\r\n Result := -1;\r\n for Index := 0 to FItems.Count - 1 do\r\n if TJclSimpleXMLElem(FItems.Items[Index]).Value = Value then\r\n begin\r\n Result := Index;\r\n Break;\r\n end;\r\n if (Result = -1) and (sxoAutoCreate in Elems.Parent.SimpleXML.Options) then\r\n begin\r\n NewItem := Elems.Add(Name, Value);\r\n Result := FItems.IndexOf(NewItem);\r\n end;\r\nend;\r\n\r\nprocedure TJclSimpleXMLNamedElems.Move(const CurIndex, NewIndex: Integer);\r\nvar\r\n ElemsCurIndex, ElemsNewIndex: Integer;\r\nbegin\r\n ElemsCurIndex := Elems.IndexOf(TJclSimpleXMLElem(FItems.Items[CurIndex]));\r\n ElemsNewIndex := Elems.IndexOf(TJclSimpleXMLElem(FItems.Items[NewIndex]));\r\n Elems.Move(ElemsCurIndex, ElemsNewIndex);\r\n FItems.Move(CurIndex, NewIndex);\r\nend;\r\n\r\nprocedure TJclSimpleXMLNamedElems.SetName(const Value: string);\r\nbegin\r\n raise EJclSimpleXMLError.CreateRes(@SReadOnlyProperty);\r\nend;\r\n\r\n//=== { TJclSimpleXMLElemsEnumerator } =======================================\r\n\r\n{$IFDEF SUPPORTS_FOR_IN}\r\nconstructor TJclSimpleXMLElemsEnumerator.Create(AList: TJclSimpleXMLElems);\r\nbegin\r\n inherited Create;\r\n FIndex := -1;\r\n FList := AList;\r\nend;\r\n\r\nfunction TJclSimpleXMLElemsEnumerator.GetCurrent: TJclSimpleXMLElem;\r\nbegin\r\n Result := FList[FIndex];\r\nend;\r\n\r\nfunction TJclSimpleXMLElemsEnumerator.MoveNext: Boolean;\r\nbegin\r\n Result := FIndex < FList.Count - 1;\r\n if Result then\r\n Inc(FIndex);\r\nend;\r\n{$ENDIF SUPPORTS_FOR_IN}\r\n\r\n//=== { TJclSimpleXMLElems } =================================================\r\n\r\nfunction TJclSimpleXMLElems.Add(const Name: string): TJclSimpleXMLElemClassic;\r\nbegin\r\n Result := TJclSimpleXMLElemClassic.Create(Name);\r\n AddChild(Result);\r\nend;\r\n\r\nfunction TJclSimpleXMLElems.Add(const Name, Value: string): TJclSimpleXMLElemClassic;\r\nbegin\r\n Result := TJclSimpleXMLElemClassic.Create(Name, Value);\r\n AddChild(Result);\r\nend;\r\n\r\nfunction TJclSimpleXMLElems.Add(const Name: string; const Value: Int64): TJclSimpleXMLElemClassic;\r\nbegin\r\n Result := TJclSimpleXMLElemClassic.Create(Name, IntToStr(Value));\r\n AddChild(Result);\r\nend;\r\n\r\nfunction TJclSimpleXMLElems.Add(Value: TJclSimpleXMLElem): TJclSimpleXMLElem;\r\nbegin\r\n if Value <> nil then\r\n AddChild(Value);\r\n Result := Value;\r\nend;\r\n\r\nfunction TJclSimpleXMLElems.Add(const Name: string; const Value: Boolean): TJclSimpleXMLElemClassic;\r\nbegin\r\n Result := TJclSimpleXMLElemClassic.Create(Name, BoolToStr(Value));\r\n AddChild(Result);\r\nend;\r\n\r\nfunction TJclSimpleXMLElems.Add(const Name: string; Value: TStream): TJclSimpleXMLElemClassic;\r\nvar\r\n Stream: TStringStream;\r\n Buf: array [0..cBufferSize - 1] of Byte;\r\n St: string;\r\n I, Count: Integer;\r\nbegin\r\n Stream := TStringStream.Create('');\r\n try\r\n Buf[0] := 0;\r\n repeat\r\n Count := Value.Read(Buf, Length(Buf));\r\n St := '';\r\n for I := 0 to Count - 1 do\r\n St := St + IntToHex(Buf[I], 2);\r\n Stream.WriteString(St);\r\n until Count = 0;\r\n Result := TJclSimpleXMLElemClassic.Create(Name, Stream.DataString);\r\n AddChild(Result);\r\n finally\r\n Stream.Free;\r\n end;\r\nend;\r\n\r\nprocedure TJclSimpleXMLElems.AddChild(const Value: TJclSimpleXMLElem);\r\nvar\r\n NamedIndex: Integer;\r\nbegin\r\n CreateElems;\r\n\r\n // If there already is a container, notify it to remove the element\r\n if Assigned(Value.Parent) then\r\n Value.Parent.Items.Notify(Value, opRemove);\r\n\r\n FElems.Add(Value);\r\n\r\n if FNamedElems <> nil then\r\n begin\r\n NamedIndex := FNamedElems.IndexOfName(Value.Name);\r\n if NamedIndex >= 0 then\r\n TJclSimpleXMLNamedElems(FNamedElems.SimpleItems[NamedIndex]).FItems.Add(Value);\r\n end;\r\n\r\n Notify(Value, opInsert);\r\nend;\r\n\r\nprocedure TJclSimpleXMLElems.AddChildFirst(const Value: TJclSimpleXMLElem);\r\nvar\r\n NamedIndex: Integer;\r\nbegin\r\n CreateElems;\r\n\r\n // If there already is a container, notify it to remove the element\r\n if Assigned(Value.Parent) then\r\n Value.Parent.Items.Notify(Value, opRemove);\r\n\r\n FElems.Insert(0, Value);\r\n\r\n if FNamedElems <> nil then\r\n begin\r\n NamedIndex := FNamedElems.IndexOfName(Value.Name);\r\n if NamedIndex >= 0 then\r\n TJclSimpleXMLNamedElems(FNamedElems.SimpleItems[NamedIndex]).FItems.Insert(0, Value);\r\n end;\r\n\r\n Notify(Value, opInsert);\r\nend;\r\n\r\nfunction TJclSimpleXMLElems.AddFirst(const Name: string): TJclSimpleXMLElemClassic;\r\nbegin\r\n Result := TJclSimpleXMLElemClassic.Create(Name);\r\n AddChildFirst(Result);\r\nend;\r\n\r\nfunction TJclSimpleXMLElems.AddFirst(Value: TJclSimpleXMLElem): TJclSimpleXMLElem;\r\nbegin\r\n if Value <> nil then\r\n AddChildFirst(Value);\r\n Result := Value;\r\nend;\r\n\r\nfunction TJclSimpleXMLElems.AddComment(const Name,\r\n Value: string): TJclSimpleXMLElemComment;\r\nbegin\r\n Result := TJclSimpleXMLElemComment.Create(Name, Value);\r\n AddChild(Result);\r\nend;\r\n\r\nfunction TJclSimpleXMLElems.AddCData(const Name, Value: string): TJclSimpleXMLElemCData;\r\nbegin\r\n Result := TJclSimpleXMLElemCData.Create(Name, Value);\r\n AddChild(Result);\r\nend;\r\n\r\nfunction TJclSimpleXMLElems.AddText(const Name, Value: string): TJclSimpleXMLElemText;\r\nbegin\r\n Result := TJclSimpleXMLElemText.Create(Name, Value);\r\n AddChild(Result);\r\nend;\r\n\r\nprocedure TJclSimpleXMLElems.BinaryValue(const Name: string; Stream: TStream);\r\nvar\r\n Elem: TJclSimpleXMLElem;\r\nbegin\r\n Elem := GetItemNamed(Name);\r\n if Elem <> nil then\r\n Elem.GetBinaryValue(Stream);\r\nend;\r\n\r\nfunction TJclSimpleXMLElems.BoolValue(const Name: string; Default: Boolean): Boolean;\r\nvar\r\n Elem: TJclSimpleXMLElem;\r\nbegin\r\n try\r\n Elem := GetItemNamedDefault(Name, BoolToStr(Default));\r\n if (Elem = nil) or (Elem.Value = '') then\r\n Result := Default\r\n else\r\n Result := Elem.BoolValue;\r\n except\r\n Result := Default;\r\n end;\r\nend;\r\n\r\nprocedure TJclSimpleXMLElems.Clear;\r\nbegin\r\n if FElems <> nil then\r\n FElems.Clear;\r\n if FNamedElems <> nil then\r\n FNamedElems.Clear;\r\nend;\r\n\r\nconstructor TJclSimpleXMLElems.Create(AParent: TJclSimpleXMLElem);\r\nbegin\r\n inherited Create;\r\n FParent := AParent;\r\nend;\r\n\r\nprocedure TJclSimpleXMLElems.CreateElems;\r\nvar\r\n CaseSensitive: Boolean;\r\nbegin\r\n if FElems = nil then\r\n begin\r\n CaseSensitive := Assigned(Parent) and Assigned(Parent.SimpleXML)\r\n and (sxoCaseSensitive in Parent.SimpleXML.Options);\r\n FElems := TJclSimpleItemHashedList.Create(CaseSensitive);\r\n end;\r\nend;\r\n\r\nprocedure TJclSimpleXMLElems.Delete(const Index: Integer);\r\nvar\r\n Elem: TJclSimpleXMLElem;\r\n NamedIndex: Integer;\r\nbegin\r\n if (FElems <> nil) and (Index >= 0) and (Index < FElems.Count) then\r\n begin\r\n Elem := TJclSimpleXMLElem(FElems.SimpleItems[Index]);\r\n if FNamedElems <> nil then\r\n begin\r\n NamedIndex := FNamedElems.IndexOfName(Elem.Name);\r\n if NamedIndex >= 0 then\r\n TJclSimpleXMLNamedElems(FNamedElems.SimpleItems[NamedIndex]).FItems.Remove(Elem);\r\n end;\r\n FElems.Delete(Index);\r\n FreeAndNil(Elem);\r\n end;\r\nend;\r\n\r\nprocedure TJclSimpleXMLElems.Delete(const Name: string);\r\nbegin\r\n if FElems <> nil then\r\n Delete(FElems.IndexOfName(Name));\r\nend;\r\n\r\ndestructor TJclSimpleXMLElems.Destroy;\r\nbegin\r\n FParent := nil;\r\n Clear;\r\n FreeAndNil(FElems);\r\n FreeAndNil(FNamedElems);\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJclSimpleXMLElems.DoItemRename(Value: TJclSimpleXMLElem; const Name: string);\r\nvar\r\n NamedIndex: Integer;\r\nbegin\r\n if FNamedElems <> nil then\r\n begin\r\n NamedIndex := FNamedElems.IndexOfName(Value.Name);\r\n if NamedIndex >= 0 then\r\n TJclSimpleXMLNamedElems(FNamedElems.SimpleItems[NamedIndex]).FItems.Remove(Value);\r\n\r\n NamedIndex := FNamedElems.IndexOfName(Name);\r\n if NamedIndex >= 0 then\r\n TJclSimpleXMLNamedElems(FNamedElems.SimpleItems[NamedIndex]).FItems.Add(Value);\r\n end;\r\nend;\r\n\r\nfunction TJclSimpleXMLElems.FloatValue(const Name: string;\r\n const Default: Extended): Extended;\r\nvar\r\n Elem: TJclSimpleXMLElem;\r\nbegin\r\n Elem := GetItemNamedDefault(Name, FloatToStr(Default));\r\n if Elem = nil then\r\n Result := Default\r\n else\r\n Result := Elem.FloatValue;\r\nend;\r\n\r\nfunction TJclSimpleXMLElems.GetCount: Integer;\r\nbegin\r\n if FElems = nil then\r\n Result := 0\r\n else\r\n Result := FElems.Count;\r\nend;\r\n\r\n{$IFDEF SUPPORTS_FOR_IN}\r\nfunction TJclSimpleXMLElems.GetEnumerator: TJclSimpleXMLElemsEnumerator;\r\nbegin\r\n Result := TJclSimpleXMLElemsEnumerator.Create(Self);\r\nend;\r\n{$ENDIF SUPPORTS_FOR_IN}\r\n\r\nfunction TJclSimpleXMLElems.GetItem(const Index: Integer): TJclSimpleXMLElem;\r\nbegin\r\n if (FElems = nil) or (Index > FElems.Count) then\r\n Result := nil\r\n else\r\n Result := TJclSimpleXMLElem(FElems.SimpleItems[Index]);\r\nend;\r\n\r\nfunction TJclSimpleXMLElems.GetItemNamedDefault(const Name, Default: string): TJclSimpleXMLElem;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := nil;\r\n if FElems <> nil then\r\n begin\r\n I := FElems.IndexOfName(Name);\r\n if I <> -1 then\r\n Result := TJclSimpleXMLElem(FElems.SimpleItems[I])\r\n else\r\n if Assigned(Parent) and Assigned(Parent.SimpleXML) and (sxoAutoCreate in Parent.SimpleXML.Options) then\r\n Result := Add(Name, Default);\r\n end\r\n else\r\n if Assigned(Parent) and Assigned(Parent.SimpleXML) and (sxoAutoCreate in Parent.SimpleXML.Options) then\r\n Result := Add(Name, Default);\r\nend;\r\n\r\nfunction TJclSimpleXMLElems.GetNamedElems(const Name: string): TJclSimpleXMLNamedElems;\r\nvar\r\n NamedIndex: Integer;\r\n CaseSensitive: Boolean;\r\nbegin\r\n if FNamedElems = nil then\r\n begin\r\n CaseSensitive := Assigned(Parent) and Assigned(Parent.SimpleXML)\r\n and (sxoCaseSensitive in Parent.SimpleXML.Options);\r\n FNamedElems := TJclSimpleItemHashedList.Create(CaseSensitive);\r\n end;\r\n NamedIndex := FNamedElems.IndexOfName(Name);\r\n if NamedIndex = -1 then\r\n begin\r\n Result := TJclSimpleXMLNamedElems.Create(Self, Name);\r\n FNamedElems.Add(Result);\r\n if FElems <> nil then\r\n for NamedIndex := 0 to FElems.Count - 1 do\r\n if FElems.SimpleItems[NamedIndex].Name = Name then\r\n Result.FItems.Add(FElems.SimpleItems[NamedIndex]);\r\n end\r\n else\r\n Result := TJclSimpleXMLNamedElems(FNamedElems.SimpleItems[NamedIndex]);\r\nend;\r\n\r\nfunction TJclSimpleXMLElems.GetItemNamed(const Name: string): TJclSimpleXMLElem;\r\nbegin\r\n Result := GetItemNamedDefault(Name, '');\r\nend;\r\n\r\nfunction TJclSimpleXMLElems.IntValue(const Name: string; const Default: Int64): Int64;\r\nvar\r\n Elem: TJclSimpleXMLElem;\r\nbegin\r\n Elem := GetItemNamedDefault(Name, IntToStr(Default));\r\n if Elem = nil then\r\n Result := Default\r\n else\r\n Result := Elem.IntValue;\r\nend;\r\n\r\nprocedure TJclSimpleXMLElems.LoadFromStringStream(StringStream: TJclStringStream);\r\ntype\r\n TReadStatus = (rsWaitingTag, rsReadingTagKind);\r\nvar\r\n lPos: TReadStatus;\r\n St: TUCS4Array;\r\n lElem: TJclSimpleXMLElem;\r\n Ch: UCS4;\r\n ContainsText, ContainsWhiteSpace, KeepWhiteSpace: Boolean;\r\n SimpleXML: TJclSimpleXML;\r\nbegin\r\n SetLength(St, 0);\r\n lPos := rsWaitingTag;\r\n SimpleXML := Parent.SimpleXML;\r\n KeepWhiteSpace := (SimpleXML <> nil) and (sxoKeepWhitespace in SimpleXML.Options);\r\n ContainsText := False;\r\n ContainsWhiteSpace := False;\r\n\r\n // We read from a stream, thus replacing the existing items\r\n Clear;\r\n\r\n if SimpleXML <> nil then\r\n SimpleXML.DoLoadProgress(StringStream.Stream.Position, StringStream.Stream.Size);\r\n\r\n while StringStream.PeekUCS4(Ch) do\r\n begin\r\n case lPos of\r\n rsWaitingTag: //We are waiting for a tag and thus avoiding spaces\r\n begin\r\n if Ch = Ord('<') then\r\n begin\r\n lPos := rsReadingTagKind;\r\n St := UCS4Array(Ch);\r\n end\r\n else\r\n if UnicodeIsWhiteSpace(Ch) then\r\n ContainsWhiteSpace := True\r\n else\r\n ContainsText := True;\r\n end;\r\n\r\n rsReadingTagKind: //We are trying to determine the kind of the tag\r\n begin\r\n lElem := nil;\r\n case Ch of\r\n Ord('/'):\r\n if UCS4ArrayEquals(St, '<') then\r\n begin // \"'), Ord(':'): //This should be a classic tag\r\n begin // \"\r\n lElem := TJclSimpleXMLElemClassic.Create;\r\n SetLength(St, 0);\r\n lPos := rsWaitingTag;\r\n end;\r\n else\r\n if ContainsText or (ContainsWhiteSpace and KeepWhiteSpace) then\r\n begin\r\n // inner text\r\n lElem := TJclSimpleXMLElemText.Create;\r\n lPos := rsReadingTagKind;\r\n ContainsText := False;\r\n ContainsWhiteSpace := False;\r\n end\r\n else\r\n begin\r\n if not UCS4ArrayEquals(St, ' nil then\r\n begin\r\n CreateElems;\r\n Notify(lElem, opInsert);\r\n lElem.LoadFromStringStream(StringStream);\r\n FElems.Add(lElem);\r\n end;\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJclSimpleXMLElems.Notify(Value: TJclSimpleXMLElem; Operation: TOperation);\r\nvar\r\n NamedIndex: Integer;\r\nbegin\r\n case Operation of\r\n opRemove:\r\n if Value.Parent = Parent then // Only remove if we have it\r\n begin\r\n if FNamedElems <> nil then\r\n begin\r\n NamedIndex := FNamedElems.IndexOfName(Value.Name);\r\n if NamedIndex >= 0 then\r\n TJclSimpleXMLNamedElems(FNamedElems.SimpleItems[NamedIndex]).FItems.Remove(Value);\r\n end;\r\n FElems.Remove(Value);\r\n Value.FParent := nil;\r\n Value.FSimpleXML := nil;\r\n end;\r\n opInsert:\r\n begin\r\n Value.FParent := Parent;\r\n Value.FSimpleXML := Parent.SimpleXML;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJclSimpleXMLElems.Remove(Value: TJclSimpleXMLElem): Integer;\r\nbegin\r\n Result := FElems.IndexOfSimpleItem(Value);\r\n Notify(Value, opRemove);\r\nend;\r\n\r\nprocedure TJclSimpleXMLElems.SaveToStringStream(StringStream: TJclStringStream;\r\n const Level: string);\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := 0 to Count - 1 do\r\n Item[I].SaveToStringStream(StringStream, Level);\r\nend;\r\n\r\nfunction TJclSimpleXMLElems.SimpleCompare(Elems: TJclSimpleXMLElems; Index1,\r\n Index2: Integer): Integer;\r\nbegin\r\n Result := CompareText(Elems.Item[Index1].Name, Elems.Item[Index2].Name);\r\nend;\r\n\r\nfunction TJclSimpleXMLElems.Value(const Name, Default: string): string;\r\nvar\r\n Elem: TJclSimpleXMLElem;\r\nbegin\r\n Result := '';\r\n Elem := GetItemNamedDefault(Name, Default);\r\n if Elem = nil then\r\n Result := Default\r\n else\r\n Result := Elem.Value;\r\nend;\r\n\r\nprocedure TJclSimpleXMLElems.Move(const CurIndex, NewIndex: Integer);\r\nbegin\r\n if FElems <> nil then\r\n FElems.Move(CurIndex, NewIndex);\r\nend;\r\n\r\nfunction TJclSimpleXMLElems.IndexOf(const Value: TJclSimpleXMLElem): Integer;\r\nbegin\r\n if FElems = nil then\r\n Result := -1\r\n else\r\n Result := FElems.IndexOfSimpleItem(Value);\r\nend;\r\n\r\nfunction TJclSimpleXMLElems.IndexOf(const Name: string): Integer;\r\nbegin\r\n if FElems = nil then\r\n Result := -1\r\n else\r\n Result := FElems.IndexOfName(Name);\r\nend;\r\n\r\nprocedure TJclSimpleXMLElems.InsertChild(const Value: TJclSimpleXMLElem; Index: Integer);\r\nvar\r\n NamedIndex: Integer;\r\nbegin\r\n CreateElems;\r\n\r\n // If there already is a container, notify it to remove the element\r\n if Assigned(Value.Parent) then\r\n Value.Parent.Items.Notify(Value, opRemove);\r\n\r\n FElems.Insert(Index, Value);\r\n\r\n if FNamedElems <> nil then\r\n begin\r\n NamedIndex := FNamedElems.IndexOfName(Value.Name);\r\n if NamedIndex >= 0 then\r\n TJclSimpleXMLNamedElems(FNamedElems.SimpleItems[NamedIndex]).FItems.Add(Value);\r\n end;\r\n\r\n Notify(Value, opInsert);\r\nend;\r\n\r\nfunction TJclSimpleXMLElems.Insert(Value: TJclSimpleXMLElem;\r\n Index: Integer): TJclSimpleXMLElem;\r\nbegin\r\n if Value <> nil then\r\n InsertChild(Value, Index);\r\n Result := Value;\r\nend;\r\n\r\nfunction TJclSimpleXMLElems.Insert(const Name: string;\r\n Index: Integer): TJclSimpleXMLElemClassic;\r\nbegin\r\n Result := TJclSimpleXMLElemClassic.Create(Name);\r\n InsertChild(Result, Index);\r\nend;\r\n\r\nprocedure QuickSort(Elems: TJclSimpleXMLElems; List: TList; L, R: Integer;\r\n AFunction: TJclSimpleXMLElemCompare);\r\nvar\r\n I, J, M: Integer;\r\n T: Pointer;\r\nbegin\r\n repeat\r\n I := L;\r\n J := R;\r\n M := (L + R) shr 1;\r\n repeat\r\n while AFunction(Elems, I, M) < 0 do\r\n Inc(I);\r\n while AFunction(Elems, J, M) > 0 do\r\n Dec(J);\r\n if I <= J then\r\n begin\r\n T := List[I];\r\n List[I] := List[J];\r\n List[J] := T;\r\n Inc(I);\r\n Dec(J);\r\n end;\r\n until I > J;\r\n if L < J then\r\n QuickSort(Elems, List, L, J, AFunction);\r\n L := I;\r\n until I >= R;\r\nend;\r\n\r\nprocedure TJclSimpleXMLElems.CustomSort(AFunction: TJclSimpleXMLElemCompare);\r\nbegin\r\n if FElems <> nil then\r\n QuickSort(Self, FElems, 0, FElems.Count - 1, AFunction);\r\nend;\r\n\r\nprocedure TJclSimpleXMLElems.Sort;\r\nbegin\r\n CustomSort(SimpleCompare);\r\nend;\r\n\r\n//=== { TJclSimpleXMLPropsEnumerator } =======================================\r\n\r\n{$IFDEF SUPPORTS_FOR_IN}\r\nconstructor TJclSimpleXMLPropsEnumerator.Create(AList: TJclSimpleXMLProps);\r\nbegin\r\n inherited Create;\r\n FIndex := -1;\r\n FList := AList;\r\nend;\r\n\r\nfunction TJclSimpleXMLPropsEnumerator.GetCurrent: TJclSimpleXMLProp;\r\nbegin\r\n Result := FList[FIndex];\r\nend;\r\n\r\nfunction TJclSimpleXMLPropsEnumerator.MoveNext: Boolean;\r\nbegin\r\n Result := FIndex < FList.Count - 1;\r\n if Result then\r\n Inc(FIndex);\r\nend;\r\n{$ENDIF SUPPORTS_FOR_IN}\r\n\r\n//=== { TJclSimpleXMLProps } =================================================\r\n\r\nfunction TJclSimpleXMLProps.Add(const Name, Value: string): TJclSimpleXMLProp;\r\nbegin\r\n if FProperties = nil then\r\n FProperties := TStringList.Create;\r\n Result := TJclSimpleXMLProp.Create(Parent, Name, Value);\r\n FProperties.AddObject(Name, Result);\r\nend;\r\n\r\nfunction TJclSimpleXMLProps.Add(const Name: string; const Value: Int64): TJclSimpleXMLProp;\r\nbegin\r\n Result := Add(Name, IntToStr(Value));\r\nend;\r\n\r\nfunction TJclSimpleXMLProps.Add(const Name: string; const Value: Boolean): TJclSimpleXMLProp;\r\nbegin\r\n Result := Add(Name, BoolToStr(Value));\r\nend;\r\n\r\n{$IFDEF SUPPORTS_UNICODE}\r\nfunction TJclSimpleXMLProps.Add(const Name: string;\r\n const Value: AnsiString): TJclSimpleXMLProp;\r\nbegin\r\n Result := Add(Name, string(Value));\r\nend;\r\n{$ENDIF SUPPORTS_UNICODE}\r\n\r\nfunction TJclSimpleXMLProps.Insert(const Index: Integer; const Name, Value: string): TJclSimpleXMLProp;\r\nbegin\r\n if FProperties = nil then\r\n FProperties := TStringList.Create;\r\n Result := TJclSimpleXMLProp.Create(Parent, Name, Value);\r\n FProperties.InsertObject(Index, Name, Result);\r\nend;\r\n\r\nfunction TJclSimpleXMLProps.Insert(const Index: Integer; const Name: string; const Value: Int64): TJclSimpleXMLProp;\r\nbegin\r\n Result := Insert(Index, Name, IntToStr(Value));\r\nend;\r\n\r\nfunction TJclSimpleXMLProps.Insert(const Index: Integer; const Name: string; const Value: Boolean): TJclSimpleXMLProp;\r\nbegin\r\n Result := Insert(Index, Name, BoolToStr(Value));\r\nend;\r\n\r\nfunction TJclSimpleXMLProps.BoolValue(const Name: string; Default: Boolean): Boolean;\r\nvar\r\n Prop: TJclSimpleXMLProp;\r\nbegin\r\n try\r\n Prop := GetItemNamedDefault(Name, BoolToStr(Default));\r\n if (Prop = nil) or (Prop.Value = '') then\r\n Result := Default\r\n else\r\n Result := Prop.BoolValue;\r\n except\r\n Result := Default;\r\n end;\r\nend;\r\n\r\nprocedure TJclSimpleXMLProps.Clear;\r\nvar\r\n I: Integer;\r\nbegin\r\n if FProperties <> nil then\r\n begin\r\n for I := 0 to FProperties.Count - 1 do\r\n begin\r\n TJclSimpleXMLProp(FProperties.Objects[I]).Free;\r\n FProperties.Objects[I] := nil;\r\n end;\r\n FProperties.Clear;\r\n end;\r\nend;\r\n\r\nprocedure TJclSimpleXMLProps.Delete(const Index: Integer);\r\nbegin\r\n if (FProperties <> nil) and (Index >= 0) and (Index < FProperties.Count) then\r\n begin\r\n TObject(FProperties.Objects[Index]).Free;\r\n FProperties.Delete(Index);\r\n end;\r\nend;\r\n\r\nconstructor TJclSimpleXMLProps.Create(AParent: TJclSimpleXMLElem);\r\nbegin\r\n inherited Create;\r\n FParent := AParent;\r\nend;\r\n\r\nprocedure TJclSimpleXMLProps.Delete(const Name: string);\r\nbegin\r\n if FProperties <> nil then\r\n Delete(FProperties.IndexOf(Name));\r\nend;\r\n\r\ndestructor TJclSimpleXMLProps.Destroy;\r\nbegin\r\n FParent := nil;\r\n Clear;\r\n FreeAndNil(FProperties);\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJclSimpleXMLProps.DoItemRename(Value: TJclSimpleXMLProp; const Name: string);\r\nvar\r\n I: Integer;\r\nbegin\r\n if FProperties = nil then\r\n Exit;\r\n I := FProperties.IndexOfObject(Value);\r\n if I <> -1 then\r\n FProperties[I] := Name;\r\nend;\r\n\r\nprocedure TJclSimpleXMLProps.Error(const S: string);\r\nbegin\r\n raise EJclSimpleXMLError.Create(S);\r\nend;\r\n\r\nfunction TJclSimpleXMLProps.FloatValue(const Name: string;\r\n const Default: Extended): Extended;\r\nvar\r\n Prop: TJclSimpleXMLProp;\r\nbegin\r\n Prop := GetItemNamedDefault(Name, FloatToStr(Default));\r\n if Prop = nil then\r\n Result := Default\r\n else\r\n Result := Prop.FloatValue;\r\nend;\r\n\r\nprocedure TJclSimpleXMLProps.FmtError(const S: string;\r\n const Args: array of const);\r\nbegin\r\n Error(Format(S, Args));\r\nend;\r\n\r\nfunction TJclSimpleXMLProps.GetCount: Integer;\r\nbegin\r\n if FProperties = nil then\r\n Result := 0\r\n else\r\n Result := FProperties.Count;\r\nend;\r\n\r\n{$IFDEF SUPPORTS_FOR_IN}\r\nfunction TJclSimpleXMLProps.GetEnumerator: TJclSimpleXMLPropsEnumerator;\r\nbegin\r\n Result := TJclSimpleXMLPropsEnumerator.Create(Self);\r\nend;\r\n{$ENDIF SUPPORTS_FOR_IN}\r\n\r\nfunction TJclSimpleXMLProps.GetItem(const Index: Integer): TJclSimpleXMLProp;\r\nbegin\r\n if FProperties <> nil then\r\n Result := TJclSimpleXMLProp(FProperties.Objects[Index])\r\n else\r\n Result := nil;\r\nend;\r\n\r\nfunction TJclSimpleXMLProps.GetItemNamedDefault(const Name, Default: string): TJclSimpleXMLProp;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := nil;\r\n if FProperties <> nil then\r\n begin\r\n I := FProperties.IndexOf(Name);\r\n if I <> -1 then\r\n Result := TJclSimpleXMLProp(FProperties.Objects[I])\r\n else\r\n if Assigned(FParent) and Assigned(FParent.SimpleXML) and (sxoAutoCreate in FParent.SimpleXML.Options) then\r\n Result := Add(Name, Default);\r\n end\r\n else\r\n if Assigned(FParent) and Assigned(FParent.SimpleXML) and (sxoAutoCreate in FParent.SimpleXML.Options) then\r\n begin\r\n Result := Add(Name, Default);\r\n end;\r\nend;\r\n\r\nfunction TJclSimpleXMLProps.GetItemNamed(const Name: string): TJclSimpleXMLProp;\r\nbegin\r\n Result := GetItemNamedDefault(Name, '');\r\nend;\r\n\r\nfunction TJclSimpleXMLProps.GetSimpleXML: TJclSimpleXML;\r\nbegin\r\n if FParent <> nil then\r\n Result := FParent.SimpleXML\r\n else\r\n Result := nil;\r\nend;\r\n\r\nfunction TJclSimpleXMLProps.IntValue(const Name: string; const Default: Int64): Int64;\r\nvar\r\n Prop: TJclSimpleXMLProp;\r\nbegin\r\n Prop := GetItemNamedDefault(Name, IntToStr(Default));\r\n if Prop = nil then\r\n Result := Default\r\n else\r\n Result := Prop.IntValue;\r\nend;\r\n\r\nprocedure TJclSimpleXMLProps.LoadFromStringStream(StringStream: TJclStringStream);\r\n//\r\n//Stop on / or ? or >\r\ntype\r\n TPosType = (\r\n ptWaiting,\r\n ptReadingName,\r\n ptStartingContent,\r\n ptReadingValue,\r\n ptSpaceBeforeEqual\r\n );\r\nvar\r\n lPos: TPosType;\r\n lName, lValue, lNameSpace: TUCS4Array;\r\n sValue: string;\r\n lPropStart: UCS4;\r\n Ch: UCS4;\r\nbegin\r\n SetLength(lValue, 0);\r\n SetLength(lNameSpace, 0);\r\n SetLength(lName, 0);\r\n lPropStart := Ord(NativeSpace);\r\n lPos := ptWaiting;\r\n\r\n // We read from a stream, thus replacing the existing properties\r\n Clear;\r\n\r\n while StringStream.PeekUCS4(Ch) do\r\n begin\r\n case lPos of\r\n ptWaiting: //We are waiting for a property\r\n begin\r\n if UnicodeIsWhiteSpace(Ch) then\r\n StringStream.ReadUCS4(Ch)\r\n else\r\n if UnicodeIsIdentifierStart(Ch) or (Ch = Ord('-')) or (Ch = Ord('.')) or (Ch = Ord('_')) then\r\n begin\r\n StringStream.ReadUCS4(Ch);\r\n lName := UCS4Array(Ch);\r\n SetLength(lNameSpace, 0);\r\n lPos := ptReadingName;\r\n end\r\n else\r\n if (Ch = Ord('/')) or (Ch = Ord('>')) or (Ch = Ord('?')) then\r\n // end of properties\r\n Break\r\n else\r\n FmtError(LoadResString(@RsEInvalidXMLElementUnexpectedCharacte), [UCS4ToChar(Ch), StringStream.PeekPosition]);\r\n end;\r\n\r\n ptReadingName: //We are reading a property name\r\n begin\r\n StringStream.ReadUCS4(Ch);\r\n if UnicodeIsIdentifierPart(Ch) or (Ch = Ord('-')) or (Ch = Ord('.')) then\r\n begin\r\n UCS4ArrayConcat(lName, Ch);\r\n end\r\n else\r\n if Ch = Ord(':') then\r\n begin\r\n lNameSpace := lName;\r\n SetLength(lName, 0);\r\n end\r\n else\r\n if Ch = Ord('=') then\r\n lPos := ptStartingContent\r\n else\r\n if UnicodeIsWhiteSpace(Ch) then\r\n lPos := ptSpaceBeforeEqual\r\n else\r\n FmtError(LoadResString(@RsEInvalidXMLElementUnexpectedCharacte), [UCS4ToChar(Ch), StringStream.PeekPosition]);\r\n end;\r\n\r\n ptStartingContent: //We are going to start a property content\r\n begin\r\n StringStream.ReadUCS4(Ch);\r\n if UnicodeIsWhiteSpace(Ch) then\r\n // ignore white space\r\n else\r\n if (Ch = Ord('''')) or (Ch = Ord('\"')) then\r\n begin\r\n lPropStart := Ch;\r\n SetLength(lValue, 0);\r\n lPos := ptReadingValue;\r\n end\r\n else\r\n FmtError(LoadResString(@RsEInvalidXMLElementUnexpectedCharacte_), [UCS4ToChar(Ch), StringStream.PeekPosition]);\r\n end;\r\n\r\n ptReadingValue: //We are reading a property\r\n begin\r\n StringStream.ReadUCS4(Ch);\r\n if Ch = lPropStart then\r\n begin\r\n sValue := UCS4ToString(lValue);\r\n if GetSimpleXML <> nil then\r\n GetSimpleXML.DoDecodeValue(sValue);\r\n with Add(UCS4ToString(lName), sValue) do\r\n NameSpace := UCS4ToString(lNameSpace);\r\n lPos := ptWaiting;\r\n end\r\n else\r\n UCS4ArrayConcat(lValue, Ch);\r\n end;\r\n\r\n ptSpaceBeforeEqual: // We are reading the white space between a property name and the = sign\r\n begin\r\n StringStream.ReadUCS4(Ch);\r\n if UnicodeIsWhiteSpace(Ch) then\r\n // more white space, stay in this state and ignore\r\n else\r\n if Ch = Ord('=') then\r\n lPos := ptStartingContent\r\n else\r\n FmtError(LoadResString(@RsEInvalidXMLElementUnexpectedCharacte), [UCS4ToChar(Ch), StringStream.PeekPosition]);\r\n end;\r\n else\r\n Assert(False, RsEUnexpectedValueForLPos);\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJclSimpleXMLProps.SaveToStringStream(StringStream: TJclStringStream);\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := 0 to Count - 1 do\r\n Item[I].SaveToStringStream(StringStream);\r\nend;\r\n\r\nfunction TJclSimpleXMLProps.Value(const Name, Default: string): string;\r\nvar\r\n Prop: TJclSimpleXMLProp;\r\nbegin\r\n Result := '';\r\n Prop := GetItemNamedDefault(Name, Default);\r\n if Prop = nil then\r\n Result := Default\r\n else\r\n Result := Prop.Value;\r\nend;\r\n\r\n//=== { TJclSimpleXMLProp } ==================================================\r\n\r\nconstructor TJclSimpleXMLProp.Create(AParent: TJclSimpleXMLElem; const AName, AValue: string);\r\nbegin\r\n inherited Create(AName, AValue);\r\n FParent := AParent;\r\nend;\r\n\r\nfunction TJclSimpleXMLProp.GetSimpleXML: TJclSimpleXML;\r\nbegin\r\n if FParent <> nil then\r\n Result := FParent.SimpleXML\r\n else\r\n Result := nil;\r\nend;\r\n\r\nprocedure TJclSimpleXMLProp.SaveToStringStream(StringStream: TJclStringStream);\r\nvar\r\n AEncoder: TJclSimpleXML;\r\n Tmp: string;\r\nbegin\r\n AEncoder := GetSimpleXML;\r\n Tmp := Value;\r\n if AEncoder <> nil then\r\n AEncoder.DoEncodeValue(Tmp);\r\n if NameSpace <> '' then\r\n Tmp := Format(' %s:%s=\"%s\"', [NameSpace, Name, Tmp])\r\n else\r\n Tmp := Format(' %s=\"%s\"', [Name, tmp]);\r\n StringStream.WriteString(Tmp, 1, Length(Tmp));\r\nend;\r\n\r\nprocedure TJclSimpleXMLProp.SetName(const Value: string);\r\nbegin\r\n if (Value <> Name) and (Value <> '') then\r\n begin\r\n if (Parent <> nil) and (Name <> '') then\r\n FParent.Properties.DoItemRename(Self, Value);\r\n inherited SetName(Value);\r\n end;\r\nend;\r\n\r\n//=== { TJclSimpleXMLElemClassic } ===========================================\r\n\r\nprocedure TJclSimpleXMLElemClassic.LoadFromStringStream(StringStream: TJclStringStream);\r\n//\r\n//foorbeuhbar\r\n//foorbeuhbar\r\ntype\r\n TReadStatus = (rsWaitingOpeningTag, rsOpeningName, rsTypeOpeningTag, rsEndSingleTag,\r\n rsWaitingClosingTag1, rsWaitingClosingTag2, rsClosingName);\r\nvar\r\n lPos: TReadStatus;\r\n St, lName, lNameSpace: TUCS4Array;\r\n sValue: string;\r\n Ch: UCS4;\r\nbegin\r\n SetLength(St, 0);\r\n SetLength(lName, 0);\r\n SetLength(lNameSpace, 0);\r\n sValue := '';\r\n lPos := rsWaitingOpeningTag;\r\n\r\n if SimpleXML <> nil then\r\n SimpleXML.DoLoadProgress(StringStream.Stream.Position, StringStream.Stream.Size);\r\n\r\n while StringStream.ReadUCS4(Ch) do\r\n begin\r\n case lPos of\r\n rsWaitingOpeningTag: // wait beginning of tag\r\n if Ch = Ord('<') then\r\n lPos := rsOpeningName // read name\r\n else\r\n if not UnicodeIsWhiteSpace(Ch) then\r\n FmtError(LoadResString(@RsEInvalidXMLElementExpectedBeginningO), [UCS4ToChar(Ch), StringStream.PeekPosition]);\r\n\r\n rsOpeningName:\r\n if UnicodeIsIdentifierPart(Ch) or (Ch = Ord('-')) or (Ch = Ord('.')) then\r\n UCS4ArrayConcat(St, Ch)\r\n else\r\n if (Ch = Ord(':')) and (Length(lNameSpace) = 0) then\r\n begin\r\n lNameSpace := St;\r\n SetLength(st, 0);\r\n end\r\n else\r\n if UnicodeIsWhiteSpace(Ch) and (Length(St) = 0) then\r\n // whitespace after \"<\" (no name)\r\n FmtError(LoadResString(@RsEInvalidXMLElementMalformedTagFoundn), [StringStream.PeekPosition])\r\n else\r\n if UnicodeIsWhiteSpace(Ch) then\r\n begin\r\n lName := St;\r\n SetLength(St, 0);\r\n Properties.LoadFromStringStream(StringStream);\r\n lPos := rsTypeOpeningTag;\r\n end\r\n else\r\n if Ch = Ord('/') then // single tag\r\n begin\r\n lName := St;\r\n lPos := rsEndSingleTag\r\n end\r\n else\r\n if Ch = Ord('>') then // 2 tags\r\n begin\r\n lName := St;\r\n SetLength(St, 0);\r\n //Load elements\r\n Items.LoadFromStringStream(StringStream);\r\n lPos := rsWaitingClosingTag1;\r\n end\r\n else\r\n // other invalid characters\r\n FmtError(LoadResString(@RsEInvalidXMLElementMalformedTagFoundn), [StringStream.PeekPosition]);\r\n\r\n rsTypeOpeningTag:\r\n if UnicodeIsWhiteSpace(Ch) then\r\n // nothing, spaces after name or properties\r\n else\r\n if Ch = Ord('/') then\r\n lPos := rsEndSingleTag // single tag\r\n else\r\n if Ch = Ord('>') then // 2 tags\r\n begin\r\n //Load elements\r\n Items.LoadFromStringStream(StringStream);\r\n lPos := rsWaitingClosingTag1;\r\n end\r\n else\r\n FmtError(LoadResString(@RsEInvalidXMLElementExpectedEndOfTagBu), [UCS4ToChar(Ch), StringStream.PeekPosition]);\r\n\r\n rsEndSingleTag:\r\n if Ch = Ord('>') then\r\n Break\r\n else\r\n FmtError(LoadResString(@RsEInvalidXMLElementExpectedEndOfTagBu), [UCS4ToChar(Ch), StringStream.PeekPosition]);\r\n\r\n rsWaitingClosingTag1:\r\n if UnicodeIsWhiteSpace(Ch) then\r\n // nothing, spaces before closing tag\r\n else\r\n if Ch = Ord('<') then\r\n lPos := rsWaitingClosingTag2\r\n else\r\n FmtError(LoadResString(@RsEInvalidXMLElementExpectedEndOfTagBu), [UCS4ToChar(Ch), StringStream.PeekPosition]);\r\n\r\n rsWaitingClosingTag2:\r\n if Ch = Ord('/') then\r\n lPos := rsClosingName\r\n else\r\n FmtError(LoadResString(@RsEInvalidXMLElementExpectedEndOfTagBu), [UCS4ToChar(Ch), StringStream.PeekPosition]);\r\n\r\n rsClosingName:\r\n if UnicodeIsWhiteSpace(Ch) or (Ch = Ord('>')) then\r\n begin\r\n if Length(lNameSpace) > 0 then\r\n begin\r\n if not StrSame(UCS4ToString(lNameSpace) + ':' + UCS4ToString(lName), UCS4ToString(St)) then\r\n FmtError(LoadResString(@RsEInvalidXMLElementErroneousEndOfTagE), [UCS4ToString(lName), UCS4ToString(St), StringStream.PeekPosition]);\r\n end\r\n else\r\n if not UCS4ArrayEquals(lName, St) then\r\n FmtError(LoadResString(@RsEInvalidXMLElementErroneousEndOfTagE), [UCS4ToString(lName), UCS4ToString(St), StringStream.PeekPosition]);\r\n //Set value if only one sub element\r\n //This might reduce speed, but this is for compatibility issues\r\n if (Items.Count = 1) and (Items[0] is TJclSimpleXMLElemText) then\r\n begin\r\n sValue := Items[0].Value;\r\n Items.Clear;\r\n // free some memory\r\n FreeAndNil(FItems);\r\n end;\r\n Break;\r\n end\r\n else\r\n if UnicodeIsIdentifierPart(Ch) or (Ch = Ord('-')) or (Ch = Ord('.')) or (Ch = Ord(':')) then\r\n UCS4ArrayConcat(St, Ch)\r\n else\r\n // other invalid characters\r\n FmtError(LoadResString(@RsEInvalidXMLElementMalformedTagFoundn), [StringStream.PeekPosition]);\r\n end;\r\n end;\r\n\r\n Name := UCS4ToString(lName);\r\n if SimpleXML <> nil then\r\n SimpleXML.DoDecodeValue(sValue);\r\n Value := sValue;\r\n NameSpace := UCS4ToString(lNameSpace);\r\n\r\n if SimpleXML <> nil then\r\n begin\r\n SimpleXML.DoTagParsed(Name);\r\n SimpleXML.DoValueParsed(Name, sValue);\r\n end;\r\nend;\r\n\r\nprocedure TJclSimpleXMLElemClassic.SaveToStringStream(StringStream: TJclStringStream; const Level: string);\r\nvar\r\n St, AName, tmp: string;\r\n LevelAdd: string;\r\n AutoIndent: Boolean;\r\nbegin\r\n if(NameSpace <> '') then\r\n AName := NameSpace + ':' + Name\r\n else\r\n AName := Name;\r\n\r\n if Name <> '' then\r\n begin\r\n if SimpleXML <> nil then\r\n SimpleXML.DoEncodeValue(AName);\r\n St := Level + '<' + AName;\r\n\r\n StringStream.WriteString(St, 1, Length(St));\r\n if Assigned(FProps) then\r\n FProps.SaveToStringStream(StringStream);\r\n end;\r\n\r\n AutoIndent := (SimpleXML <> nil) and (sxoAutoIndent in SimpleXML.Options);\r\n\r\n if (ItemCount = 0) then\r\n begin\r\n tmp := Value;\r\n if (Name <> '') then\r\n begin\r\n if Value = '' then\r\n begin\r\n if AutoIndent then\r\n St := '/>' + sLineBreak\r\n else\r\n St := '/>';\r\n end\r\n else\r\n begin\r\n if SimpleXML <> nil then\r\n SimpleXML.DoEncodeValue(tmp);\r\n if AutoIndent then\r\n St := '>' + tmp + '' + sLineBreak\r\n else\r\n St := '>' + tmp + '';\r\n end;\r\n StringStream.WriteString(St, 1, Length(St));\r\n end;\r\n end\r\n else\r\n begin\r\n if (Name <> '') then\r\n begin\r\n if AutoIndent then\r\n St := '>' + sLineBreak\r\n else\r\n St := '>';\r\n StringStream.WriteString(St, 1, Length(St));\r\n end;\r\n if AutoIndent then\r\n begin\r\n LevelAdd := SimpleXML.IndentString;\r\n end;\r\n FItems.SaveToStringStream(StringStream, Level + LevelAdd);\r\n if Name <> '' then\r\n begin\r\n if AutoIndent then\r\n St := Level + '' + sLineBreak\r\n else\r\n St := Level + '';\r\n StringStream.WriteString(St, 1, Length(St));\r\n end;\r\n end;\r\n if SimpleXML <> nil then\r\n SimpleXML.DoSaveProgress;\r\nend;\r\n\r\n//=== { TJclSimpleXMLElemComment } ===========================================\r\n\r\nprocedure TJclSimpleXMLElemComment.LoadFromStringStream(StringStream: TJclStringStream);\r\n//\r\nconst\r\n CS_START_COMMENT = '';\r\nvar\r\n lPos: Integer;\r\n St: TUCS4Array;\r\n Ch: UCS4;\r\n lOk: Boolean;\r\nbegin\r\n SetLength(St, 0);\r\n lPos := 1;\r\n lOk := False;\r\n\r\n if SimpleXML <> nil then\r\n SimpleXML.DoLoadProgress(StringStream.Stream.Position, StringStream.Stream.Size);\r\n\r\n while StringStream.ReadUCS4(Ch) do\r\n begin\r\n case lPos of\r\n 1..4: //' + sLineBreak\r\n else\r\n St := '-->';\r\n StringStream.WriteString(St, 1, Length(St));\r\n if SimpleXML <> nil then\r\n SimpleXML.DoSaveProgress;\r\nend;\r\n\r\n//=== { TJclSimpleXMLElemCData } =============================================\r\n\r\nprocedure TJclSimpleXMLElemCData.LoadFromStringStream(StringStream: TJclStringStream);\r\n//Hello, world!]]>\r\nconst\r\n CS_START_CDATA = '';\r\nvar\r\n lPos: Integer;\r\n St: TUCS4Array;\r\n Ch: UCS4;\r\n lOk: Boolean;\r\nbegin\r\n SetLength(St, 0);\r\n lPos := 1;\r\n lOk := False;\r\n\r\n if SimpleXML <> nil then\r\n SimpleXML.DoLoadProgress(StringStream.Stream.Position, StringStream.Stream.Size);\r\n\r\n while StringStream.ReadUCS4(Ch) do\r\n begin\r\n case lPos of\r\n 1..9: //\r\n if Ch = Ord(CS_STOP_CDATA[lPos]) then\r\n begin\r\n lOk := True;\r\n Break; //End if\r\n end\r\n else\r\n // ]]]\r\n if Ch = Ord(CS_STOP_CDATA[lPos-1]) then\r\n UCS4ArrayConcat(St, Ord(']'))\r\n else\r\n begin\r\n UCS4ArrayConcat(St, Ord(']'));\r\n UCS4ArrayConcat(St, Ord(']'));\r\n UCS4ArrayConcat(St, Ch);\r\n Dec(lPos, 2);\r\n end;\r\n end;\r\n end;\r\n\r\n if not lOk then\r\n FmtError(LoadResString(@RsEInvalidCDATAUnexpectedEndOfData), [StringStream.PeekPosition]);\r\n\r\n Value := UCS4ToString(St);\r\n Name := '';\r\n\r\n if SimpleXML <> nil then\r\n SimpleXML.DoValueParsed('', Value);\r\nend;\r\n\r\nprocedure TJclSimpleXMLElemCData.SaveToStringStream(StringStream: TJclStringStream; const Level: string);\r\nvar\r\n St: string;\r\nbegin\r\n St := Level + ' '' then\r\n StringStream.WriteString(Value, 1, Length(Value));\r\n if (SimpleXML <> nil) and (sxoAutoIndent in SimpleXML.Options) then\r\n St := ']]>' + sLineBreak\r\n else\r\n St := ']]>';\r\n StringStream.WriteString(St, 1, Length(St));\r\n if SimpleXML <> nil then\r\n SimpleXML.DoSaveProgress;\r\nend;\r\n\r\n//=== { TJclSimpleXMLElemText } ==============================================\r\n\r\nprocedure TJclSimpleXMLElemText.LoadFromStringStream(StringStream: TJclStringStream);\r\nvar\r\n Ch: UCS4;\r\n USt: TUCS4Array;\r\n St, TrimValue: string;\r\nbegin\r\n SetLength(USt, 0);\r\n St := '';\r\n\r\n if SimpleXML <> nil then\r\n SimpleXML.DoLoadProgress(StringStream.Stream.Position, StringStream.Stream.Size);\r\n\r\n while StringStream.PeekUCS4(Ch) do\r\n begin\r\n case Ch of\r\n Ord('<'):\r\n //Quit text\r\n Break;\r\n else\r\n begin\r\n StringStream.ReadUCS4(Ch);\r\n UCS4ArrayConcat(USt, Ch);\r\n end;\r\n end;\r\n end;\r\n\r\n St := UCS4ToString(USt);\r\n\r\n if Assigned(SimpleXML) then\r\n begin\r\n SimpleXML.DoDecodeValue(St);\r\n\r\n TrimValue := St;\r\n if sxoTrimPrecedingTextWhitespace in SimpleXML.Options then\r\n TrimValue := TrimLeft(TrimValue);\r\n if sxoTrimFollowingTextWhitespace in SimpleXML.Options then\r\n TrimValue := TrimRight(TrimValue);\r\n if (TrimValue <> '') or not (sxoKeepWhitespace in SimpleXML.Options) then\r\n St := TrimValue;\r\n end;\r\n\r\n Value := St;\r\n Name := '';\r\n\r\n if SimpleXML <> nil then\r\n SimpleXML.DoValueParsed('', St);\r\nend;\r\n\r\nprocedure TJclSimpleXMLElemText.SaveToStringStream(StringStream: TJclStringStream; const Level: string);\r\nvar\r\n St, tmp: string;\r\nbegin\r\n // should never be used\r\n if Value <> '' then\r\n begin\r\n tmp := Value;\r\n if SimpleXML <> nil then\r\n SimpleXML.DoEncodeValue(tmp);\r\n if (SimpleXML <> nil) and (sxoAutoIndent in SimpleXML.Options) then\r\n St := Level + tmp + sLineBreak\r\n else\r\n St := Level + tmp;\r\n StringStream.WriteString(St, 1, Length(St));\r\n end;\r\n if SimpleXML <> nil then\r\n SimpleXML.DoSaveProgress;\r\nend;\r\n\r\n//=== { TJclSimpleXMLElemProcessingInstruction } =============================\r\n\r\nprocedure TJclSimpleXMLElemProcessingInstruction.LoadFromStringStream(\r\n StringStream: TJclStringStream);\r\ntype\r\n TReadStatus = (rsWaitingOpeningTag, rsOpeningTag, rsOpeningName, rsEndTag1, rsEndTag2);\r\nvar\r\n lPos: TReadStatus;\r\n lOk: Boolean;\r\n St, lName, lNameSpace: TUCS4Array;\r\n Ch: UCS4;\r\nbegin\r\n SetLength(St, 0);\r\n SetLength(lName, 0);\r\n SetLength(lNameSpace, 0);\r\n lPos := rsWaitingOpeningTag;\r\n lOk := False;\r\n\r\n if SimpleXML <> nil then\r\n SimpleXML.DoLoadProgress(StringStream.Stream.Position, StringStream.Stream.Size);\r\n\r\n while StringStream.ReadUCS4(Ch) do\r\n begin\r\n case lPos of\r\n rsWaitingOpeningTag: // wait beginning of tag\r\n if Ch = Ord('<') then\r\n lPos := rsOpeningTag\r\n else\r\n if not UnicodeIsWhiteSpace(Ch) then\r\n FmtError(LoadResString(@RsEInvalidXMLElementExpectedBeginningO), [UCS4ToChar(Ch), StringStream.PeekPosition]);\r\n\r\n rsOpeningTag:\r\n if Ch = Ord('?') then\r\n lPos := rsOpeningName // read name\r\n else\r\n FmtError(LoadResString(@RsEInvalidXMLElementMalformedTagFoundn), [StringStream.PeekPosition]);\r\n\r\n rsOpeningName:\r\n if UnicodeIsIdentifierPart(Ch) or (Ch = Ord('-')) or (Ch = Ord('.')) then\r\n UCS4ArrayConcat(St, Ch)\r\n else\r\n if (Ch = Ord(':')) and (Length(lNameSpace) = 0) then\r\n begin\r\n lNameSpace := St;\r\n SetLength(St, 0);\r\n end\r\n else\r\n if UnicodeIsWhiteSpace(Ch) and (Length(St) = 0) then\r\n // whitespace after \"<\" (no name)\r\n FmtError(LoadResString(@RsEInvalidXMLElementMalformedTagFoundn), [StringStream.PeekPosition])\r\n else\r\n if UnicodeIsWhiteSpace(Ch) then\r\n begin\r\n lName := St;\r\n SetLength(St, 0);\r\n Properties.LoadFromStringStream(StringStream);\r\n lPos := rsEndTag1;\r\n end\r\n else\r\n if Ch = Ord('?') then\r\n begin\r\n lName := St;\r\n lPos := rsEndTag2;\r\n end\r\n else\r\n // other invalid characters\r\n FmtError(LoadResString(@RsEInvalidXMLElementMalformedTagFoundn), [StringStream.PeekPosition]);\r\n\r\n rsEndTag1:\r\n if Ch = Ord('?') then\r\n lPos := rsEndTag2\r\n else\r\n if not UnicodeIsWhiteSpace(Ch) then\r\n FmtError(LoadResString(@RsEInvalidXMLElementExpectedEndOfTagBu), [UCS4ToChar(Ch), StringStream.PeekPosition]);\r\n\r\n rsEndTag2:\r\n if Ch = Ord('>') then\r\n begin\r\n lOk := True;\r\n Break;\r\n end\r\n else\r\n FmtError(LoadResString(@RsEInvalidXMLElementExpectedEndOfTagBu), [UCS4ToChar(Ch), StringStream.PeekPosition]);\r\n end;\r\n end;\r\n\r\n if not lOk then\r\n FmtError(LoadResString(@RsEInvalidCommentUnexpectedEndOfData), [StringStream.PeekPosition]);\r\n\r\n Name := UCS4ToString(lName);\r\n NameSpace := UCS4ToString(lNameSpace);\r\nend;\r\n\r\nprocedure TJclSimpleXMLElemProcessingInstruction.SaveToStringStream(\r\n StringStream: TJclStringStream; const Level: string);\r\nvar\r\n St: string;\r\nbegin\r\n St := Level + ' '' then\r\n St := St + NameSpace + ':' + Name\r\n else\r\n St := St + Name;\r\n StringStream.WriteString(St, 1, Length(St));\r\n if Assigned(FProps) then\r\n FProps.SaveToStringStream(StringStream);\r\n if (SimpleXML <> nil) and (sxoAutoIndent in SimpleXML.Options) then\r\n St := '?>' + sLineBreak\r\n else\r\n St := '?>';\r\n StringStream.WriteString(St, 1, Length(St));\r\n if SimpleXML <> nil then\r\n SimpleXML.DoSaveProgress;\r\nend;\r\n\r\n//=== { TJclSimpleXMLElemHeader } ============================================\r\n\r\nconstructor TJclSimpleXMLElemHeader.Create;\r\nbegin\r\n inherited Create;\r\n\r\n Name := 'xml';\r\nend;\r\n\r\nfunction TJclSimpleXMLElemHeader.GetEncoding: string;\r\nvar\r\n ASimpleXML: TJclSimpleXML;\r\n DefaultCodePage: Word;\r\nbegin\r\n ASimpleXML := SimpleXML;\r\n if Assigned(ASimpleXML) then\r\n begin\r\n DefaultCodePage := ASimpleXML.CodePage;\r\n {$IFDEF MSWINDOWS}\r\n if DefaultCodePage = CP_ACP then\r\n DefaultCodePage := GetAcp;\r\n {$ENDIF MSWINDOWS}\r\n end\r\n else\r\n {$IFDEF UNICODE}\r\n DefaultCodePage := CP_UTF16LE;\r\n {$ELSE ~UNICODE}\r\n {$IFDEF MSWINDOWS}\r\n DefaultCodePage := GetACP;\r\n {$ELSE ~MSWINDOWS}\r\n DefaultCodePage := 1252;\r\n {$ENDIF ~MSWINDOWS}\r\n {$ENDIF ~UNICODE}\r\n Result := Properties.Value('encoding', CharsetNameFromCodePage(DefaultCodePage));\r\nend;\r\n\r\nfunction TJclSimpleXMLElemHeader.GetStandalone: Boolean;\r\nbegin\r\n Result := Properties.Value('standalone') = 'yes';\r\nend;\r\n\r\nfunction TJclSimpleXMLElemHeader.GetVersion: string;\r\nbegin\r\n Result := Properties.Value('version', '1.0');\r\nend;\r\n\r\nprocedure TJclSimpleXMLElemHeader.LoadFromStringStream(StringStream: TJclStringStream);\r\n//\r\nvar\r\n CodePage: Word;\r\n EncodingProp: TJclSimpleXMLProp;\r\nbegin\r\n inherited LoadFromStringStream(StringStream);\r\n\r\n if Assigned(FProps) then\r\n EncodingProp := FProps.ItemNamed['encoding']\r\n else\r\n EncodingProp := nil;\r\n if Assigned(EncodingProp) and (EncodingProp.Value <> '') then\r\n CodePage := CodePageFromCharsetName(EncodingProp.Value)\r\n else\r\n CodePage := CP_ACP;\r\n\r\n // set current stringstream codepage\r\n if StringStream is TJclAutoStream then\r\n TJclAutoStream(StringStream).CodePage := CodePage\r\n else\r\n if StringStream is TJclAnsiStream then\r\n TJclAnsiStream(StringStream).CodePage := CodePage\r\n else\r\n if not (StringStream is TJclUTF8Stream) and not (StringStream is TJclUTF16Stream) then\r\n Error(LoadResString(@RsENoCharset));\r\nend;\r\n\r\nprocedure TJclSimpleXMLElemHeader.SaveToStringStream(\r\n StringStream: TJclStringStream; const Level: string);\r\nbegin\r\n SetVersion(GetVersion);\r\n SetEncoding(GetEncoding);\r\n SetStandalone(GetStandalone);\r\n\r\n inherited SaveToStringStream(StringStream, Level);\r\nend;\r\n\r\nprocedure TJclSimpleXMLElemHeader.SetEncoding(const Value: string);\r\nvar\r\n Prop: TJclSimpleXMLProp;\r\nbegin\r\n Prop := Properties.ItemNamed['encoding'];\r\n if Assigned(Prop) then\r\n Prop.Value := Value\r\n else\r\n Properties.Add('encoding', Value);\r\nend;\r\n\r\nprocedure TJclSimpleXMLElemHeader.SetStandalone(const Value: Boolean);\r\nvar\r\n Prop: TJclSimpleXMLProp;\r\nconst\r\n BooleanValues: array [Boolean] of string = ('no', 'yes');\r\nbegin\r\n Prop := Properties.ItemNamed['standalone'];\r\n if Assigned(Prop) then\r\n Prop.Value := BooleanValues[Value]\r\n else\r\n Properties.Add('standalone', BooleanValues[Value]);\r\nend;\r\n\r\nprocedure TJclSimpleXMLElemHeader.SetVersion(const Value: string);\r\nvar\r\n Prop: TJclSimpleXMLProp;\r\nbegin\r\n Prop := Properties.ItemNamed['version'];\r\n if Assigned(Prop) then\r\n Prop.Value := Value\r\n else\r\n // Various XML parsers (including MSIE, Firefox) require the \"version\" to be the first\r\n Properties.Insert(0, 'version', Value);\r\nend;\r\n\r\n//=== { TJclSimpleXMLElemDocType } ===========================================\r\n\r\nprocedure TJclSimpleXMLElemDocType.LoadFromStringStream(StringStream: TJclStringStream);\r\n{\r\n\r\n\r\n' >\r\n%xx;\r\n]>\r\n\r\n\r\n}\r\nconst\r\n CS_START_DOCTYPE = '');\r\n SetLength(St, 0);\r\n\r\n if SimpleXML <> nil then\r\n SimpleXML.DoLoadProgress(StringStream.Stream.Position, StringStream.Stream.Size);\r\n\r\n while StringStream.ReadUCS4(Ch) do\r\n begin\r\n case lPos of\r\n 1..9: // or >\r\n if lChar = Ch then\r\n begin\r\n if lChar = Ord('>') then\r\n begin\r\n lOk := True;\r\n Break; //This is the end\r\n end\r\n else\r\n begin\r\n UCS4ArrayConcat(St, Ch);\r\n lChar := Ord('>');\r\n end;\r\n end\r\n else\r\n begin\r\n UCS4ArrayConcat(St, Ch);\r\n if Ch = Ord('[') then\r\n lChar := Ord(']');\r\n end;\r\n end;\r\n end;\r\n\r\n if not lOk then\r\n FmtError(LoadResString(@RsEInvalidCommentUnexpectedEndOfData), [StringStream.PeekPosition]);\r\n\r\n Name := '';\r\n Value := StrTrimCharsLeft(UCS4ToString(St), CharIsWhiteSpace);\r\n\r\n if SimpleXML <> nil then\r\n SimpleXML.DoValueParsed('', Value);\r\nend;\r\n\r\nprocedure TJclSimpleXMLElemDocType.SaveToStringStream(StringStream: TJclStringStream;\r\n const Level: string);\r\nvar\r\n St: string;\r\nbegin\r\n if (SimpleXML <> nil) and (sxoAutoIndent in SimpleXML.Options) then\r\n St := Level + '' + sLineBreak\r\n else\r\n St := Level + '';\r\n StringStream.WriteString(St, 1, Length(St));\r\n if SimpleXML <> nil then\r\n SimpleXML.DoSaveProgress;\r\nend;\r\n\r\n//=== { TJclSimpleXMLElemsPrologEnumerator } =================================\r\n\r\n{$IFDEF SUPPORTS_FOR_IN}\r\nconstructor TJclSimpleXMLElemsPrologEnumerator.Create(AList: TJclSimpleXMLElemsProlog);\r\nbegin\r\n inherited Create;\r\n FIndex := -1;\r\n FList := AList;\r\nend;\r\n\r\nfunction TJclSimpleXMLElemsPrologEnumerator.GetCurrent: TJclSimpleXMLElem;\r\nbegin\r\n Result := FList[FIndex];\r\nend;\r\n\r\nfunction TJclSimpleXMLElemsPrologEnumerator.MoveNext: Boolean;\r\nbegin\r\n Result := FIndex < FList.Count - 1;\r\n if Result then\r\n Inc(FIndex);\r\nend;\r\n{$ENDIF SUPPORTS_FOR_IN}\r\n\r\n//=== { TJclSimpleXMLElemsProlog } ===========================================\r\n\r\nconstructor TJclSimpleXMLElemsProlog.Create(ASimpleXML: TJclSimpleXML);\r\nvar\r\n CaseSensitive: Boolean;\r\nbegin\r\n inherited Create;\r\n FSimpleXML := ASimpleXML;\r\n CaseSensitive := Assigned(ASimpleXML) and (sxoCaseSensitive in ASimpleXML.Options);\r\n FElems := TJclSimpleItemHashedList.Create(CaseSensitive);\r\nend;\r\n\r\ndestructor TJclSimpleXMLElemsProlog.Destroy;\r\nbegin\r\n Clear;\r\n FreeAndNil(FElems);\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJclSimpleXMLElemsProlog.Clear;\r\nbegin\r\n FElems.Clear;\r\nend;\r\n\r\nfunction TJclSimpleXMLElemsProlog.GetCount: Integer;\r\nbegin\r\n Result := FElems.Count;\r\nend;\r\n\r\nfunction TJclSimpleXMLElemsProlog.GetItem(const Index: Integer): TJclSimpleXMLElem;\r\nbegin\r\n Result := TJclSimpleXMLElem(FElems.SimpleItems[Index]);\r\nend;\r\n\r\nprocedure TJclSimpleXMLElemsProlog.LoadFromStringStream(StringStream: TJclStringStream);\r\n{\r\n\r\n\r\n]>\r\nHello, world!\r\n\r\n Hello, world!\r\n}\r\nvar\r\n lPos: Integer;\r\n St: TUCS4Array;\r\n lEnd: Boolean;\r\n lElem: TJclSimpleXMLElem;\r\n Ch: UCS4;\r\nbegin\r\n SetLength(St, 0);\r\n lPos := 0;\r\n\r\n if SimpleXML <> nil then\r\n SimpleXML.DoLoadProgress(StringStream.Stream.Position, StringStream.Stream.Size);\r\n\r\n while StringStream.PeekUCS4(Ch) do\r\n begin\r\n case lPos of\r\n 0: //We are waiting for a tag and thus avoiding spaces and any BOM\r\n begin\r\n if UnicodeIsWhiteSpace(Ch) then\r\n // still waiting\r\n else\r\n if Ch = Ord('<') then\r\n begin\r\n lPos := 1;\r\n St := UCS4Array(Ch);\r\n end\r\n else\r\n FmtError(LoadResString(@RsEInvalidDocumentUnexpectedTextInFile), [StringStream.PeekPosition]);\r\n end;\r\n 1: //We are trying to determine the kind of the tag\r\n begin\r\n lElem := nil;\r\n lEnd := False;\r\n\r\n if not UCS4ArrayEquals(St, ' 3) and (St[1] = Ord('?')) and UnicodeIsWhiteSpace(St[High(St)]) then\r\n lElem := TJclSimpleXMLElemProcessingInstruction.Create(SimpleXML)\r\n else\r\n if (Length(St) > 1) and (St[1] <> Ord('!')) and (St[1] <> Ord('?')) then\r\n lEnd := True;\r\n\r\n if lEnd then\r\n Break\r\n else\r\n if lElem <> nil then\r\n begin\r\n FElems.Add(lElem);\r\n lElem.LoadFromStringStream(StringStream);\r\n SetLength(St, 0);\r\n lPos := 0;\r\n end;\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJclSimpleXMLElemsProlog.SaveToStringStream(StringStream: TJclStringStream);\r\nvar\r\n I: Integer;\r\nbegin\r\n FindHeader;\r\n for I := 0 to Count - 1 do\r\n Item[I].SaveToStringStream(StringStream, '');\r\nend;\r\n\r\nfunction VarXML: TVarType;\r\nbegin\r\n Result := XMLVariant.VarType;\r\nend;\r\n\r\nprocedure XMLCreateInto(var ADest: Variant; const AXML: TJclSimpleXMLElem);\r\nbegin\r\n TVarData(ADest).vType := VarXML;\r\n TVarData(ADest).vAny := AXML;\r\nend;\r\n\r\nfunction XMLCreate(const AXML: TJclSimpleXMLElem): Variant;\r\nbegin\r\n XMLCreateInto(Result, AXML);\r\nend;\r\n\r\nfunction XMLCreate: Variant;\r\nbegin\r\n XMLCreateInto(Result, TJclSimpleXMLElemClassic.Create(nil));\r\nend;\r\n\r\n//=== { TXMLVariant } ========================================================\r\n\r\nprocedure TXMLVariant.CastTo(var Dest: TVarData; const Source: TVarData;\r\n const AVarType: TVarType);\r\nvar\r\n StorageStream: TStringStream;\r\n ConversionString: TJclStringStream;\r\nbegin\r\n if Source.vType = VarType then\r\n begin\r\n case AVarType of\r\n varOleStr:\r\n begin\r\n StorageStream := TStringStream.Create('');\r\n try\r\n ConversionString := TJclUTF16Stream.Create(StorageStream, False);\r\n try\r\n ConversionString.WriteBOM;\r\n TJclSimpleXMLElem(Source.vAny).SaveToStringStream(ConversionString, '');\r\n ConversionString.Flush;\r\n finally\r\n ConversionString.Free;\r\n end;\r\n VarDataFromOleStr(Dest, StorageStream.DataString);\r\n finally\r\n StorageStream.Free;\r\n end;\r\n end;\r\n varString:\r\n begin\r\n StorageStream := TStringStream.Create('');\r\n try\r\n {$IFDEF SUPPORTS_UNICODE}\r\n ConversionString := TJclUTF16Stream.Create(StorageStream, False);\r\n {$ELSE ~SUPPORTS_UNICODE}\r\n ConversionString := TJclAnsiStream.Create(StorageStream, False);\r\n {$ENDIF ~SUPPORTS_UNICODE}\r\n try\r\n ConversionString.WriteBOM;\r\n TJclSimpleXMLElem(Source.vAny).SaveToStringStream(ConversionString, '');\r\n ConversionString.Flush;\r\n finally\r\n ConversionString.Free;\r\n end;\r\n VarDataFromStr(Dest, StorageStream.DataString);\r\n finally\r\n StorageStream.Free;\r\n end;\r\n end;\r\n {$IFDEF SUPPORTS_UNICODE_STRING}\r\n varUString:\r\n begin\r\n StorageStream := TStringStream.Create('');\r\n try\r\n ConversionString := TJclUTF16Stream.Create(StorageStream, False);\r\n try\r\n ConversionString.WriteBOM;\r\n TJclSimpleXMLElem(Source.vAny).SaveToStringStream(ConversionString, '');\r\n ConversionString.Flush;\r\n finally\r\n ConversionString.Free;\r\n end;\r\n VarDataClear(Dest);\r\n Dest.VUString := nil;\r\n Dest.VType := varUString;\r\n UnicodeString(Dest.VUString) := UnicodeString(StorageStream.DataString);\r\n finally\r\n StorageStream.Free;\r\n end;\r\n end;\r\n {$ENDIF SUPPORTS_UNICODE_STRING}\r\n else\r\n RaiseCastError;\r\n end;\r\n end\r\n else\r\n inherited CastTo(Dest, Source, AVarType);\r\nend;\r\n\r\nprocedure TXMLVariant.Clear(var V: TVarData);\r\nbegin\r\n V.vType := varEmpty;\r\n V.vAny := nil;\r\nend;\r\n\r\nprocedure TXMLVariant.Copy(var Dest: TVarData; const Source: TVarData;\r\n const Indirect: Boolean);\r\nbegin\r\n if Indirect and VarDataIsByRef(Source) then\r\n VarDataCopyNoInd(Dest, Source)\r\n else\r\n begin\r\n Dest.vType := Source.vType;\r\n Dest.vAny := Source.vAny;\r\n end;\r\nend;\r\n\r\nfunction TXMLVariant.DoFunction(var Dest: TVarData; const V: TVarData;\r\n const Name: string; const Arguments: TVarDataArray): Boolean;\r\nvar\r\n VXML, LXML: TJclSimpleXMLElem;\r\n VElems: TJclSimpleXMLElems;\r\n I, J, K: Integer;\r\nbegin\r\n Result := False;\r\n if (Length(Arguments) = 1) and (Arguments[0].vType in [vtInteger, vtExtended]) then\r\n begin\r\n VXML := TJclSimpleXMLElem(V.VAny);\r\n K := Arguments[0].vInteger;\r\n J := 0;\r\n\r\n if (K > 0) and VXML.HasItems then\r\n begin\r\n VElems := VXML.Items;\r\n for I := 0 to VElems.Count - 1 do\r\n if UpperCase(VElems.Item[I].Name) = Name then\r\n begin\r\n Inc(J);\r\n if J = K then\r\n Break;\r\n end;\r\n end;\r\n\r\n if (J = K) and (J < VXML.ItemCount) then\r\n begin\r\n LXML := VXML.Items[J];\r\n if LXML <> nil then\r\n begin\r\n Dest.vType := VarXML;\r\n Dest.vAny := Pointer(LXML);\r\n Result := True;\r\n end\r\n end;\r\n end\r\nend;\r\n\r\nfunction TXMLVariant.GetProperty(var Dest: TVarData; const V: TVarData;\r\n const Name: string): Boolean;\r\nvar\r\n VXML, LXML: TJclSimpleXMLElem;\r\n lProp: TJclSimpleXMLProp;\r\nbegin\r\n Result := False;\r\n VXML := TJclSimpleXMLElem(V.VAny);\r\n if VXML.HasItems then\r\n begin\r\n LXML := VXML.Items.ItemNamed[Name];\r\n if LXML <> nil then\r\n begin\r\n Dest.vType := VarXML;\r\n Dest.vAny := Pointer(LXML);\r\n Result := True;\r\n end;\r\n end;\r\n if (not Result) and VXML.HasProperties then\r\n begin\r\n lProp := VXML.Properties.ItemNamed[Name];\r\n if lProp <> nil then\r\n begin\r\n VarDataFromOleStr(Dest, lProp.Value);\r\n Result := True;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TXMLVariant.IsClear(const V: TVarData): Boolean;\r\nvar\r\n VXML: TJclSimpleXMLElem;\r\nbegin\r\n VXML := TJclSimpleXMLElem(V.VAny);\r\n Result := (VXML = nil) or (not VXML.HasItems);\r\nend;\r\n\r\nfunction TXMLVariant.SetProperty(const V: TVarData; const Name: string;\r\n const Value: TVarData): Boolean;\r\n\r\n function GetStrValue: string;\r\n begin\r\n try\r\n Result := Value.VOleStr;\r\n except\r\n Result := '';\r\n end;\r\n end;\r\n\r\nvar\r\n VXML, LXML: TJclSimpleXMLElem;\r\n lProp: TJclSimpleXMLProp;\r\nbegin\r\n Result := False;\r\n VXML := TJclSimpleXMLElem(V.VAny);\r\n if VXML.HasItems then\r\n begin\r\n LXML := VXML.Items.ItemNamed[Name];\r\n if LXML <> nil then\r\n begin\r\n LXML.Value := GetStrValue;\r\n Result := True;\r\n end;\r\n end;\r\n if (not Result) and VXML.HasProperties then\r\n begin\r\n lProp := VXML.Properties.ItemNamed[Name];\r\n if lProp <> nil then\r\n begin\r\n lProp.Value := GetStrValue;\r\n Result := True;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJclSimpleXMLElemsProlog.Error(const S: string);\r\nbegin\r\n raise EJclSimpleXMLError.Create(S);\r\nend;\r\n\r\nprocedure TJclSimpleXMLElemsProlog.FmtError(const S: string;\r\n const Args: array of const);\r\nbegin\r\n Error(Format(S, Args));\r\nend;\r\n\r\nprocedure TJclSimpleXML.SetIndentString(const Value: string);\r\nbegin\r\n // test if the new value is only made of spaces or tabs\r\n if not StrContainsChars(Value, CharIsWhiteSpace, True) then\r\n Exit;\r\n FIndentString := Value;\r\nend;\r\n\r\nprocedure TJclSimpleXML.SetRoot(const Value: TJclSimpleXMLElemClassic);\r\nbegin\r\n if Value <> FRoot then\r\n begin\r\n// FRoot.FSimpleXML := nil;\r\n FRoot := Value;\r\n// FRoot.FSimpleXML := Self;\r\n end;\r\nend;\r\n\r\nfunction TJclSimpleXMLElemsProlog.GetEncoding: string;\r\nvar\r\n Elem: TJclSimpleXMLElemHeader;\r\nbegin\r\n Elem := TJclSimpleXMLElemHeader(FindHeader);\r\n if Elem <> nil then\r\n Result := Elem.Encoding\r\n else\r\n Result := 'UTF-8';\r\nend;\r\n\r\n{$IFDEF SUPPORTS_FOR_IN}\r\nfunction TJclSimpleXMLElemsProlog.GetEnumerator: TJclSimpleXMLElemsPrologEnumerator;\r\nbegin\r\n Result := TJclSimpleXMLElemsPrologEnumerator.Create(Self);\r\nend;\r\n{$ENDIF SUPPORTS_FOR_IN}\r\n\r\nfunction TJclSimpleXMLElemsProlog.GetStandAlone: Boolean;\r\nvar\r\n Elem: TJclSimpleXMLElemHeader;\r\nbegin\r\n Elem := TJclSimpleXMLElemHeader(FindHeader);\r\n if Elem <> nil then\r\n Result := Elem.StandAlone\r\n else\r\n Result := False;\r\nend;\r\n\r\nfunction TJclSimpleXMLElemsProlog.GetVersion: string;\r\nvar\r\n Elem: TJclSimpleXMLElemHeader;\r\nbegin\r\n Elem := TJclSimpleXMLElemHeader(FindHeader);\r\n if Elem <> nil then\r\n Result := Elem.Version\r\n else\r\n Result := '1.0';\r\nend;\r\n\r\nprocedure TJclSimpleXMLElemsProlog.SetEncoding(const Value: string);\r\nvar\r\n Elem: TJclSimpleXMLElemHeader;\r\nbegin\r\n Elem := TJclSimpleXMLElemHeader(FindHeader);\r\n if Elem <> nil then\r\n Elem.Encoding := Value;\r\nend;\r\n\r\nprocedure TJclSimpleXMLElemsProlog.SetStandAlone(const Value: Boolean);\r\nvar\r\n Elem: TJclSimpleXMLElemHeader;\r\nbegin\r\n Elem := TJclSimpleXMLElemHeader(FindHeader);\r\n if Elem <> nil then\r\n Elem.StandAlone := Value;\r\nend;\r\n\r\nprocedure TJclSimpleXMLElemsProlog.SetVersion(const Value: string);\r\nvar\r\n Elem: TJclSimpleXMLElemHeader;\r\nbegin\r\n Elem := TJclSimpleXMLElemHeader(FindHeader);\r\n if Elem <> nil then\r\n Elem.Version := Value;\r\nend;\r\n\r\nfunction TJclSimpleXMLElemsProlog.FindHeader: TJclSimpleXMLElem;\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := 0 to Count - 1 do\r\n if Item[I] is TJclSimpleXMLElemHeader then\r\n begin\r\n Result := Item[I];\r\n Exit;\r\n end;\r\n // (p3) if we get here, an xml header was not found\r\n Result := TJclSimpleXMLElemHeader.Create(SimpleXML);\r\n FElems.Add(Result);\r\nend;\r\n\r\nfunction TJclSimpleXMLElemsProlog.AddStyleSheet(const AType, AHRef: string): TJclSimpleXMLElemSheet;\r\nbegin\r\n // make sure there is an xml header\r\n FindHeader;\r\n Result := TJclSimpleXMLElemSheet.Create('xml-stylesheet');\r\n Result.Properties.Add('type',AType);\r\n Result.Properties.Add('href',AHRef);\r\n FElems.Add(Result);\r\nend;\r\n\r\nfunction TJclSimpleXMLElemsProlog.AddMSOApplication(const AProgId : string): TJclSimpleXMLElemMSOApplication;\r\nbegin\r\n // make sure there is an xml header\r\n FindHeader;\r\n Result := TJclSimpleXMLElemMSOApplication.Create('mso-application');\r\n Result.Properties.Add('progid',AProgId);\r\n FElems.Add(Result);\r\nend;\r\n\r\nfunction TJclSimpleXMLElemsProlog.AddComment(const AValue: string): TJclSimpleXMLElemComment;\r\nbegin\r\n // make sure there is an xml header\r\n FindHeader;\r\n Result := TJclSimpleXMLElemComment.Create('', AValue);\r\n FElems.Add(Result);\r\nend;\r\n\r\nfunction TJclSimpleXMLElemsProlog.AddDocType(const AValue: string): TJclSimpleXMLElemDocType;\r\nbegin\r\n // make sure there is an xml header\r\n FindHeader;\r\n Result := TJclSimpleXMLElemDocType.Create('', AValue);\r\n FElems.Add(Result);\r\nend;\r\n\r\ninitialization\r\n {$IFDEF UNITVERSIONING}\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n {$ENDIF UNITVERSIONING}\r\n\r\nfinalization\r\n FreeAndNil(GlobalXMLVariant);\r\n {$IFDEF UNITVERSIONING}\r\n UnregisterUnitVersion(HInstance);\r\n {$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jcl/source/common/JclSortedMaps.pas", "content": "{**************************************************************************************************}\r\n{ WARNING: JEDI preprocessor generated unit. Do not edit. }\r\n{**************************************************************************************************}\r\n\r\n{**************************************************************************************************}\r\n{ }\r\n{ Project JEDI Code Library (JCL) }\r\n{ }\r\n{ The contents of this file are subject to the Mozilla Public License Version 1.1 (the \"License\"); }\r\n{ you may not use this file except in compliance with the License. You may obtain a copy of the }\r\n{ License at http://www.mozilla.org/MPL/ }\r\n{ }\r\n{ Software distributed under the License is distributed on an \"AS IS\" basis, WITHOUT WARRANTY OF }\r\n{ ANY KIND, either express or implied. See the License for the specific language governing rights }\r\n{ and limitations under the License. }\r\n{ }\r\n{ The Original Code is JclSortedMaps.pas. }\r\n{ }\r\n{ The Initial Developer of the Original Code is Florent Ouchet. Portions created by }\r\n{ Florent Ouchet are Copyright (C) Florent Ouchet = record\r\n Key: TKey;\r\n Value: TValue;\r\n end;\r\n\r\n TJclSortedMap = class(TJclAbstractContainerBase, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclIntfCloneable, IJclCloneable, IJclGrowable, IJclPackable, IJclBaseContainer, IJclPairOwner,\r\n IJclMap, IJclSortedMap)\r\n\r\n protected\r\n type\r\n TSortedEntry = TJclSortedEntry;\r\n TSortedEntryArray = array of TSortedEntry;\r\n private\r\n FOwnsKeys: Boolean;\r\n FOwnsValues: Boolean;\r\n protected\r\n function KeysCompare(const A, B: TKey): Integer; virtual; abstract;\r\n function ValuesCompare(const A, B: TValue): Integer; virtual; abstract;\r\n function CreateEmptyArrayList(ACapacity: Integer; AOwnsObjects: Boolean): IJclCollection; virtual; abstract;\r\n function CreateEmptyArraySet(ACapacity: Integer; AOwnsObjects: Boolean): IJclSet; virtual; abstract;\r\n public\r\n { IJclPairOwner }\r\n function FreeKey(var Key: TKey): TKey;\r\n function FreeValue(var Value: TValue): TValue;\r\n function GetOwnsKeys: Boolean;\r\n function GetOwnsValues: Boolean;\r\n property OwnsKeys: Boolean read FOwnsKeys;\r\n property OwnsValues: Boolean read FOwnsValues;\r\n private\r\n FEntries: TSortedEntryArray;\r\n function BinarySearch(const Key: TKey): Integer;\r\n protected\r\n procedure AssignDataTo(Dest: TJclAbstractContainerBase); override;\r\n procedure MoveArray(var List: TSortedEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\n public\r\n constructor Create(ACapacity: Integer; AOwnsValues: Boolean; AOwnsKeys: Boolean);\r\n destructor Destroy; override;\r\n { IJclPackable }\r\n procedure SetCapacity(Value: Integer); override;\r\n { IJclMap }\r\n procedure Clear;\r\n function ContainsKey(const Key: TKey): Boolean;\r\n function ContainsValue(const Value: TValue): Boolean;\r\n function Extract(const Key: TKey): TValue;\r\n function GetValue(const Key: TKey): TValue;\r\n function IsEmpty: Boolean;\r\n function KeyOfValue(const Value: TValue): TKey;\r\n function KeySet: IJclSet;\r\n function MapEquals(const AMap: IJclMap): Boolean;\r\n procedure PutAll(const AMap: IJclMap);\r\n procedure PutValue(const Key: TKey; const Value: TValue);\r\n function Remove(const Key: TKey): TValue;\r\n function Size: Integer;\r\n function Values: IJclCollection;\r\n { IJclSortedMap }\r\n function FirstKey: TKey;\r\n function HeadMap(const ToKey: TKey): IJclSortedMap;\r\n function LastKey: TKey;\r\n function SubMap(const FromKey, ToKey: TKey): IJclSortedMap;\r\n function TailMap(const FromKey: TKey): IJclSortedMap;\r\n end;\r\n\r\n // E = external helper to compare items\r\n TJclSortedMapE = class(TJclSortedMap, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclIntfCloneable, IJclCloneable, IJclPackable, IJclBaseContainer, IJclMap, IJclSortedMap, IJclPairOwner)\r\n protected\r\n type\r\n TArrayList = TJclArrayListE;\r\n TArraySet = TJclArraySetE;\r\n private\r\n FKeyComparer: IJclComparer;\r\n FValueComparer: IJclComparer;\r\n FValueEqualityComparer: IJclEqualityComparer;\r\n protected\r\n procedure AssignPropertiesTo(Dest: TJclAbstractContainerBase); override;\r\n function KeysCompare(const A, B: TKey): Integer; override;\r\n function ValuesCompare(const A, B: TValue): Integer; override;\r\n function CreateEmptyArrayList(ACapacity: Integer; AOwnsObjects: Boolean): IJclCollection; override;\r\n function CreateEmptyContainer: TJclAbstractContainerBase; override;\r\n function CreateEmptyArraySet(ACapacity: Integer; AOwnsObjects: Boolean): IJclSet; override;\r\n public\r\n constructor Create(const AKeyComparer: IJclComparer; const AValueComparer: IJclComparer;\r\n const AValueEqualityComparer: IJclEqualityComparer; ACapacity: Integer; AOwnsValues: Boolean;\r\n AOwnsKeys: Boolean);\r\n\r\n property KeyComparer: IJclComparer read FKeyComparer write FKeyComparer;\r\n property ValueComparer: IJclComparer read FValueComparer write FValueComparer;\r\n property ValueEqualityComparer: IJclEqualityComparer read FValueEqualityComparer write FValueEqualityComparer;\r\n end;\r\n\r\n // F = Functions to compare items\r\n TJclSortedMapF = class(TJclSortedMap, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclIntfCloneable, IJclCloneable, IJclPackable, IJclBaseContainer, IJclMap, IJclSortedMap, IJclPairOwner)\r\n protected\r\n type\r\n TArrayList = TJclArrayListF;\r\n TArraySet = TJclArraySetF;\r\n private\r\n FKeyCompare: TCompare;\r\n FValueCompare: TCompare;\r\n FValueEqualityCompare: TEqualityCompare;\r\n protected\r\n procedure AssignPropertiesTo(Dest: TJclAbstractContainerBase); override;\r\n function KeysCompare(const A, B: TKey): Integer; override;\r\n function ValuesCompare(const A, B: TValue): Integer; override;\r\n function CreateEmptyArrayList(ACapacity: Integer; AOwnsObjects: Boolean): IJclCollection; override;\r\n function CreateEmptyContainer: TJclAbstractContainerBase; override;\r\n function CreateEmptyArraySet(ACapacity: Integer; AOwnsObjects: Boolean): IJclSet; override;\r\n public\r\n constructor Create(AKeyCompare: TCompare; AValueCompare: TCompare;\r\n AValueEqualityCompare: TEqualityCompare; ACapacity: Integer; AOwnsValues: Boolean; AOwnsKeys: Boolean);\r\n\r\n property KeyCompare: TCompare read FKeyCompare write FKeyCompare;\r\n property ValueCompare: TCompare read FValueCompare write FValueCompare;\r\n property ValueEqualityCompare: TEqualityCompare read FValueEqualityCompare write FValueEqualityCompare;\r\n end;\r\n\r\n // I = items can compare themselves to an other\r\n TJclSortedMapI; TValue: IComparable, IEquatable> = class(TJclSortedMap,\r\n {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE} IJclIntfCloneable, IJclCloneable, IJclPackable, IJclBaseContainer,\r\n IJclMap, IJclSortedMap, IJclPairOwner)\r\n protected\r\n type\r\n TArrayList = TJclArrayListI;\r\n TArraySet = TJclArraySetI;\r\n protected\r\n function KeysCompare(const A, B: TKey): Integer; override;\r\n function ValuesCompare(const A, B: TValue): Integer; override;\r\n function CreateEmptyArrayList(ACapacity: Integer; AOwnsObjects: Boolean): IJclCollection; override;\r\n function CreateEmptyContainer: TJclAbstractContainerBase; override;\r\n function CreateEmptyArraySet(ACapacity: Integer; AOwnsObjects: Boolean): IJclSet; override;\r\n end;\r\n\r\n //DOM-IGNORE-END\r\n {$ENDIF SUPPORTS_GENERICS}\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jcl.svn.sourceforge.net/svnroot/jcl/tags/JCL-2.4-Build4571/jcl/source/common/JclSortedMaps.pas $';\r\n Revision: '$Revision: 3755 $';\r\n Date: '$Date: 2012-03-03 11:17:49 +0100 (sam. 03 mars 2012) $';\r\n LogPath: 'JCL\\source\\common';\r\n Extra: '';\r\n Data: nil\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n {$IFDEF HAS_UNITSCOPE}\r\n System.SysUtils;\r\n {$ELSE ~HAS_UNITSCOPE}\r\n SysUtils;\r\n {$ENDIF ~HAS_UNITSCOPE}\r\n\r\n//=== { TJclIntfIntfSortedMap } ==============================================\r\n\r\nconstructor TJclIntfIntfSortedMap.Create(ACapacity: Integer);\r\nbegin\r\n inherited Create();\r\n SetCapacity(ACapacity);\r\nend;\r\n\r\ndestructor TJclIntfIntfSortedMap.Destroy;\r\nbegin\r\n FReadOnly := False;\r\n Clear;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJclIntfIntfSortedMap.AssignDataTo(Dest: TJclAbstractContainerBase);\r\nvar\r\n MyDest: TJclIntfIntfSortedMap;\r\nbegin\r\n inherited AssignDataTo(Dest);\r\n if Dest is TJclIntfIntfSortedMap then\r\n begin\r\n MyDest := TJclIntfIntfSortedMap(Dest);\r\n MyDest.SetCapacity(FSize);\r\n MyDest.FEntries := FEntries;\r\n MyDest.FSize := FSize;\r\n end;\r\nend;\r\n\r\nfunction TJclIntfIntfSortedMap.BinarySearch(const Key: IInterface): Integer;\r\nvar\r\n HiPos, LoPos, CompPos: Integer;\r\n Comp: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n LoPos := 0;\r\n HiPos := FSize - 1;\r\n CompPos := (HiPos + LoPos) div 2;\r\n while HiPos >= LoPos do\r\n begin\r\n Comp := KeysCompare(FEntries[CompPos].Key, Key);\r\n if Comp < 0 then\r\n LoPos := CompPos + 1\r\n else\r\n if Comp > 0 then\r\n HiPos := CompPos - 1\r\n else\r\n begin\r\n HiPos := CompPos;\r\n LoPos := CompPos + 1;\r\n end;\r\n CompPos := (HiPos + LoPos) div 2;\r\n end;\r\n Result := HiPos;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclIntfIntfSortedMap.Clear;\r\nvar\r\n Index: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n for Index := 0 to FSize - 1 do\r\n begin\r\n FreeKey(FEntries[Index].Key);\r\n FreeValue(FEntries[Index].Value);\r\n end;\r\n FSize := 0;\r\n AutoPack;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfIntfSortedMap.ContainsKey(const Key: IInterface): Boolean;\r\nvar\r\n Index: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Index := BinarySearch(Key);\r\n Result := (Index >= 0) and (KeysCompare(FEntries[Index].Key, Key) = 0);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfIntfSortedMap.ContainsValue(const Value: IInterface): Boolean;\r\nvar\r\n Index: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n for Index := 0 to FSize - 1 do\r\n if ValuesCompare(FEntries[Index].Value, Value) = 0 then\r\n begin\r\n Result := True;\r\n Break;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfIntfSortedMap.FirstKey: IInterface;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := nil;\r\n if FSize > 0 then\r\n Result := FEntries[0].Key\r\n else\r\n if not FReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfIntfSortedMap.Extract(const Key: IInterface): IInterface;\r\nvar\r\n Index: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Index := BinarySearch(Key);\r\n if (Index >= 0) and (KeysCompare(FEntries[Index].Key, Key) = 0) then\r\n begin\r\n Result := FEntries[Index].Value;\r\n FEntries[Index].Value := nil;\r\n FreeKey(FEntries[Index].Key);\r\n if Index < (FSize - 1) then\r\n MoveArray(FEntries, Index + 1, Index, FSize - Index - 1);\r\n Dec(FSize);\r\n AutoPack;\r\n end\r\n else\r\n Result := nil;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfIntfSortedMap.GetValue(const Key: IInterface): IInterface;\r\nvar\r\n Index: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Index := BinarySearch(Key);\r\n Result := nil;\r\n if (Index >= 0) and (KeysCompare(FEntries[Index].Key, Key) = 0) then\r\n Result := FEntries[Index].Value\r\n else if not FReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfIntfSortedMap.HeadMap(const ToKey: IInterface): IJclIntfIntfSortedMap;\r\nvar\r\n ToIndex: Integer;\r\n NewMap: TJclIntfIntfSortedMap;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n NewMap := CreateEmptyContainer as TJclIntfIntfSortedMap;\r\n ToIndex := BinarySearch(ToKey);\r\n if ToIndex >= 0 then\r\n begin\r\n NewMap.SetCapacity(ToIndex + 1);\r\n NewMap.FSize := ToIndex + 1;\r\n while ToIndex >= 0 do\r\n begin\r\n NewMap.FEntries[ToIndex] := FEntries[ToIndex];\r\n Dec(ToIndex);\r\n end;\r\n end;\r\n Result := NewMap;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfIntfSortedMap.IsEmpty: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := FSize = 0;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfIntfSortedMap.KeyOfValue(const Value: IInterface): IInterface;\r\nvar\r\n Index: Integer;\r\n Found: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Found := False;\r\n Result := nil;\r\n for Index := 0 to FSize - 1 do\r\n if ValuesCompare(FEntries[Index].Value, Value) = 0 then\r\n begin\r\n Result := FEntries[Index].Key;\r\n Found := True;\r\n Break;\r\n end;\r\n\r\n if (not Found) and (not FReturnDefaultElements) then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfIntfSortedMap.KeySet: IJclIntfSet;\r\nvar\r\n Index: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := TJclIntfArraySet.Create(FSize);\r\n for Index := 0 to FSize - 1 do\r\n Result.Add(FEntries[Index].Key);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfIntfSortedMap.LastKey: IInterface;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := nil;\r\n if FSize > 0 then\r\n Result := FEntries[FSize - 1].Key\r\n else\r\n if not FReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfIntfSortedMap.MapEquals(const AMap: IJclIntfIntfMap): Boolean;\r\nvar\r\n It: IJclIntfIterator;\r\n Index: Integer;\r\n AKey: IInterface;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if AMap = nil then\r\n Exit;\r\n if FSize <> AMap.Size then\r\n Exit;\r\n It := AMap.KeySet.First;\r\n Index := 0;\r\n while It.HasNext do\r\n begin\r\n if Index >= FSize then\r\n Exit;\r\n AKey := It.Next;\r\n if ValuesCompare(AMap.GetValue(AKey), FEntries[Index].Value) <> 0 then\r\n Exit;\r\n Inc(Index);\r\n end;\r\n Result := True;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclIntfIntfSortedMap.FinalizeArrayBeforeMove(var List: TJclIntfIntfSortedMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\nbegin\r\n Assert(Count > 0);\r\n if FromIndex < ToIndex then\r\n begin\r\n if Count > (ToIndex - FromIndex) then\r\n Finalize(List[FromIndex + Count], ToIndex - FromIndex)\r\n else\r\n Finalize(List[ToIndex], Count);\r\n end\r\n else\r\n if FromIndex > ToIndex then\r\n begin\r\n if Count > (FromIndex - ToIndex) then\r\n Count := FromIndex - ToIndex;\r\n Finalize(List[ToIndex], Count)\r\n end;\r\nend;\r\n\r\nprocedure TJclIntfIntfSortedMap.InitializeArray(var List: TJclIntfIntfSortedMapEntryArray; FromIndex, Count: SizeInt);\r\nbegin\r\n {$IFDEF FPC}\r\n while Count > 0 do\r\n begin\r\n Initialize(List[FromIndex]);\r\n Inc(FromIndex);\r\n Dec(Count);\r\n end;\r\n {$ELSE ~FPC}\r\n Initialize(List[FromIndex], Count);\r\n {$ENDIF ~FPC}\r\nend;\r\n\r\nprocedure TJclIntfIntfSortedMap.InitializeArrayAfterMove(var List: TJclIntfIntfSortedMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\nbegin\r\n { Keep reference counting working }\r\n if FromIndex < ToIndex then\r\n begin\r\n if (ToIndex - FromIndex) < Count then\r\n Count := ToIndex - FromIndex;\r\n InitializeArray(List, FromIndex, Count);\r\n end\r\n else\r\n if FromIndex > ToIndex then\r\n begin\r\n if (FromIndex - ToIndex) < Count then\r\n InitializeArray(List, ToIndex + Count, FromIndex - ToIndex)\r\n else\r\n InitializeArray(List, FromIndex, Count);\r\n end;\r\nend;\r\n\r\nprocedure TJclIntfIntfSortedMap.MoveArray(var List: TJclIntfIntfSortedMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\nbegin\r\n if Count > 0 then\r\n begin\r\n FinalizeArrayBeforeMove(List, FromIndex, ToIndex, Count);\r\n Move(List[FromIndex], List[ToIndex], Count * SizeOf(List[0]));\r\n InitializeArrayAfterMove(List, FromIndex, ToIndex, Count);\r\n end;\r\nend;\r\n\r\nprocedure TJclIntfIntfSortedMap.PutAll(const AMap: IJclIntfIntfMap);\r\nvar\r\n It: IJclIntfIterator;\r\n Key: IInterface;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if AMap = nil then\r\n Exit;\r\n It := AMap.KeySet.First;\r\n while It.HasNext do\r\n begin\r\n Key := It.Next;\r\n PutValue(Key, AMap.GetValue(Key));\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclIntfIntfSortedMap.PutValue(const Key: IInterface; const Value: IInterface);\r\nvar\r\n Index: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FAllowDefaultElements or ((KeysCompare(Key, nil) <> 0) and (ValuesCompare(Value, nil) <> 0)) then\r\n begin\r\n Index := BinarySearch(Key);\r\n\r\n if (Index >= 0) and (KeysCompare(FEntries[Index].Key, Key) = 0) then\r\n begin\r\n FreeValue(FEntries[Index].Value);\r\n FEntries[Index].Value := Value;\r\n end\r\n else\r\n begin\r\n if FSize = FCapacity then\r\n AutoGrow;\r\n if FSize < FCapacity then\r\n begin\r\n Inc(Index);\r\n if (Index < FSize) and (KeysCompare(FEntries[Index].Key, Key) <> 0) then\r\n MoveArray(FEntries, Index, Index + 1, FSize - Index);\r\n FEntries[Index].Key := Key;\r\n FEntries[Index].Value := Value;\r\n Inc(FSize);\r\n end;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfIntfSortedMap.Remove(const Key: IInterface): IInterface;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := Extract(Key);\r\n Result := FreeValue(Result);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclIntfIntfSortedMap.SetCapacity(Value: Integer);\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FSize <= Value then\r\n begin\r\n SetLength(FEntries, Value);\r\n inherited SetCapacity(Value);\r\n end\r\n else\r\n raise EJclOperationNotSupportedError.Create;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfIntfSortedMap.Size: Integer;\r\nbegin\r\n Result := FSize;\r\nend;\r\n\r\nfunction TJclIntfIntfSortedMap.SubMap(const FromKey, ToKey: IInterface): IJclIntfIntfSortedMap;\r\nvar\r\n FromIndex, ToIndex: Integer;\r\n NewMap: TJclIntfIntfSortedMap;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n NewMap := CreateEmptyContainer as TJclIntfIntfSortedMap;\r\n FromIndex := BinarySearch(FromKey);\r\n if (FromIndex = -1) or (KeysCompare(FEntries[FromIndex].Key, FromKey) < 0) then\r\n Inc(FromIndex);\r\n ToIndex := BinarySearch(ToKey);\r\n if (FromIndex >= 0) and (FromIndex <= ToIndex) then\r\n begin\r\n NewMap.SetCapacity(ToIndex - FromIndex + 1);\r\n NewMap.FSize := ToIndex - FromIndex + 1;\r\n while ToIndex >= FromIndex do\r\n begin\r\n NewMap.FEntries[ToIndex - FromIndex] := FEntries[ToIndex];\r\n Dec(ToIndex);\r\n end;\r\n end;\r\n Result := NewMap;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfIntfSortedMap.TailMap(const FromKey: IInterface): IJclIntfIntfSortedMap;\r\nvar\r\n FromIndex, Index: Integer;\r\n NewMap: TJclIntfIntfSortedMap;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n NewMap := CreateEmptyContainer as TJclIntfIntfSortedMap;\r\n FromIndex := BinarySearch(FromKey);\r\n if (FromIndex = -1) or (KeysCompare(FEntries[FromIndex].Key, FromKey) < 0) then\r\n Inc(FromIndex);\r\n if (FromIndex >= 0) and (FromIndex < FSize) then\r\n begin\r\n NewMap.SetCapacity(FSize - FromIndex);\r\n NewMap.FSize := FSize - FromIndex;\r\n Index := FromIndex;\r\n while Index < FSize do\r\n begin\r\n NewMap.FEntries[Index - FromIndex] := FEntries[Index];\r\n Inc(Index);\r\n end;\r\n end;\r\n Result := NewMap;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfIntfSortedMap.Values: IJclIntfCollection;\r\nvar\r\n Index: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := TJclIntfArrayList.Create(FSize);\r\n for Index := 0 to FSize - 1 do\r\n Result.Add(FEntries[Index].Value);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfIntfSortedMap.CreateEmptyContainer: TJclAbstractContainerBase;\r\nbegin\r\n Result := TJclIntfIntfSortedMap.Create(FSize);\r\n AssignPropertiesTo(Result);\r\nend;\r\n\r\nfunction TJclIntfIntfSortedMap.FreeKey(var Key: IInterface): IInterface;\r\nbegin\r\n Result := Key;\r\n Key := nil;\r\nend;\r\n\r\nfunction TJclIntfIntfSortedMap.FreeValue(var Value: IInterface): IInterface;\r\nbegin\r\n Result := Value;\r\n Value := nil;\r\nend;\r\n\r\nfunction TJclIntfIntfSortedMap.KeysCompare(const A, B: IInterface): Integer;\r\nbegin\r\n Result := ItemsCompare(A, B);\r\nend;\r\n\r\nfunction TJclIntfIntfSortedMap.ValuesCompare(const A, B: IInterface): Integer;\r\nbegin\r\n Result := ItemsCompare(A, B);\r\nend;\r\n\r\n//=== { TJclAnsiStrIntfSortedMap } ==============================================\r\n\r\nconstructor TJclAnsiStrIntfSortedMap.Create(ACapacity: Integer);\r\nbegin\r\n inherited Create();\r\n SetCapacity(ACapacity);\r\nend;\r\n\r\ndestructor TJclAnsiStrIntfSortedMap.Destroy;\r\nbegin\r\n FReadOnly := False;\r\n Clear;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJclAnsiStrIntfSortedMap.AssignDataTo(Dest: TJclAbstractContainerBase);\r\nvar\r\n MyDest: TJclAnsiStrIntfSortedMap;\r\nbegin\r\n inherited AssignDataTo(Dest);\r\n if Dest is TJclAnsiStrIntfSortedMap then\r\n begin\r\n MyDest := TJclAnsiStrIntfSortedMap(Dest);\r\n MyDest.SetCapacity(FSize);\r\n MyDest.FEntries := FEntries;\r\n MyDest.FSize := FSize;\r\n end;\r\nend;\r\n\r\nfunction TJclAnsiStrIntfSortedMap.BinarySearch(const Key: AnsiString): Integer;\r\nvar\r\n HiPos, LoPos, CompPos: Integer;\r\n Comp: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n LoPos := 0;\r\n HiPos := FSize - 1;\r\n CompPos := (HiPos + LoPos) div 2;\r\n while HiPos >= LoPos do\r\n begin\r\n Comp := KeysCompare(FEntries[CompPos].Key, Key);\r\n if Comp < 0 then\r\n LoPos := CompPos + 1\r\n else\r\n if Comp > 0 then\r\n HiPos := CompPos - 1\r\n else\r\n begin\r\n HiPos := CompPos;\r\n LoPos := CompPos + 1;\r\n end;\r\n CompPos := (HiPos + LoPos) div 2;\r\n end;\r\n Result := HiPos;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclAnsiStrIntfSortedMap.Clear;\r\nvar\r\n Index: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n for Index := 0 to FSize - 1 do\r\n begin\r\n FreeKey(FEntries[Index].Key);\r\n FreeValue(FEntries[Index].Value);\r\n end;\r\n FSize := 0;\r\n AutoPack;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclAnsiStrIntfSortedMap.ContainsKey(const Key: AnsiString): Boolean;\r\nvar\r\n Index: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Index := BinarySearch(Key);\r\n Result := (Index >= 0) and (KeysCompare(FEntries[Index].Key, Key) = 0);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclAnsiStrIntfSortedMap.ContainsValue(const Value: IInterface): Boolean;\r\nvar\r\n Index: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n for Index := 0 to FSize - 1 do\r\n if ValuesCompare(FEntries[Index].Value, Value) = 0 then\r\n begin\r\n Result := True;\r\n Break;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclAnsiStrIntfSortedMap.FirstKey: AnsiString;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := '';\r\n if FSize > 0 then\r\n Result := FEntries[0].Key\r\n else\r\n if not FReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclAnsiStrIntfSortedMap.Extract(const Key: AnsiString): IInterface;\r\nvar\r\n Index: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Index := BinarySearch(Key);\r\n if (Index >= 0) and (KeysCompare(FEntries[Index].Key, Key) = 0) then\r\n begin\r\n Result := FEntries[Index].Value;\r\n FEntries[Index].Value := nil;\r\n FreeKey(FEntries[Index].Key);\r\n if Index < (FSize - 1) then\r\n MoveArray(FEntries, Index + 1, Index, FSize - Index - 1);\r\n Dec(FSize);\r\n AutoPack;\r\n end\r\n else\r\n Result := nil;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclAnsiStrIntfSortedMap.GetValue(const Key: AnsiString): IInterface;\r\nvar\r\n Index: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Index := BinarySearch(Key);\r\n Result := nil;\r\n if (Index >= 0) and (KeysCompare(FEntries[Index].Key, Key) = 0) then\r\n Result := FEntries[Index].Value\r\n else if not FReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclAnsiStrIntfSortedMap.HeadMap(const ToKey: AnsiString): IJclAnsiStrIntfSortedMap;\r\nvar\r\n ToIndex: Integer;\r\n NewMap: TJclAnsiStrIntfSortedMap;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n NewMap := CreateEmptyContainer as TJclAnsiStrIntfSortedMap;\r\n ToIndex := BinarySearch(ToKey);\r\n if ToIndex >= 0 then\r\n begin\r\n NewMap.SetCapacity(ToIndex + 1);\r\n NewMap.FSize := ToIndex + 1;\r\n while ToIndex >= 0 do\r\n begin\r\n NewMap.FEntries[ToIndex] := FEntries[ToIndex];\r\n Dec(ToIndex);\r\n end;\r\n end;\r\n Result := NewMap;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclAnsiStrIntfSortedMap.IsEmpty: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := FSize = 0;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclAnsiStrIntfSortedMap.KeyOfValue(const Value: IInterface): AnsiString;\r\nvar\r\n Index: Integer;\r\n Found: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Found := False;\r\n Result := '';\r\n for Index := 0 to FSize - 1 do\r\n if ValuesCompare(FEntries[Index].Value, Value) = 0 then\r\n begin\r\n Result := FEntries[Index].Key;\r\n Found := True;\r\n Break;\r\n end;\r\n\r\n if (not Found) and (not FReturnDefaultElements) then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclAnsiStrIntfSortedMap.KeySet: IJclAnsiStrSet;\r\nvar\r\n Index: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := TJclAnsiStrArraySet.Create(FSize);\r\n for Index := 0 to FSize - 1 do\r\n Result.Add(FEntries[Index].Key);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclAnsiStrIntfSortedMap.LastKey: AnsiString;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := '';\r\n if FSize > 0 then\r\n Result := FEntries[FSize - 1].Key\r\n else\r\n if not FReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclAnsiStrIntfSortedMap.MapEquals(const AMap: IJclAnsiStrIntfMap): Boolean;\r\nvar\r\n It: IJclAnsiStrIterator;\r\n Index: Integer;\r\n AKey: AnsiString;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if AMap = nil then\r\n Exit;\r\n if FSize <> AMap.Size then\r\n Exit;\r\n It := AMap.KeySet.First;\r\n Index := 0;\r\n while It.HasNext do\r\n begin\r\n if Index >= FSize then\r\n Exit;\r\n AKey := It.Next;\r\n if ValuesCompare(AMap.GetValue(AKey), FEntries[Index].Value) <> 0 then\r\n Exit;\r\n Inc(Index);\r\n end;\r\n Result := True;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclAnsiStrIntfSortedMap.FinalizeArrayBeforeMove(var List: TJclAnsiStrIntfSortedMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\nbegin\r\n Assert(Count > 0);\r\n if FromIndex < ToIndex then\r\n begin\r\n if Count > (ToIndex - FromIndex) then\r\n Finalize(List[FromIndex + Count], ToIndex - FromIndex)\r\n else\r\n Finalize(List[ToIndex], Count);\r\n end\r\n else\r\n if FromIndex > ToIndex then\r\n begin\r\n if Count > (FromIndex - ToIndex) then\r\n Count := FromIndex - ToIndex;\r\n Finalize(List[ToIndex], Count)\r\n end;\r\nend;\r\n\r\nprocedure TJclAnsiStrIntfSortedMap.InitializeArray(var List: TJclAnsiStrIntfSortedMapEntryArray; FromIndex, Count: SizeInt);\r\nbegin\r\n {$IFDEF FPC}\r\n while Count > 0 do\r\n begin\r\n Initialize(List[FromIndex]);\r\n Inc(FromIndex);\r\n Dec(Count);\r\n end;\r\n {$ELSE ~FPC}\r\n Initialize(List[FromIndex], Count);\r\n {$ENDIF ~FPC}\r\nend;\r\n\r\nprocedure TJclAnsiStrIntfSortedMap.InitializeArrayAfterMove(var List: TJclAnsiStrIntfSortedMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\nbegin\r\n { Keep reference counting working }\r\n if FromIndex < ToIndex then\r\n begin\r\n if (ToIndex - FromIndex) < Count then\r\n Count := ToIndex - FromIndex;\r\n InitializeArray(List, FromIndex, Count);\r\n end\r\n else\r\n if FromIndex > ToIndex then\r\n begin\r\n if (FromIndex - ToIndex) < Count then\r\n InitializeArray(List, ToIndex + Count, FromIndex - ToIndex)\r\n else\r\n InitializeArray(List, FromIndex, Count);\r\n end;\r\nend;\r\n\r\nprocedure TJclAnsiStrIntfSortedMap.MoveArray(var List: TJclAnsiStrIntfSortedMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\nbegin\r\n if Count > 0 then\r\n begin\r\n FinalizeArrayBeforeMove(List, FromIndex, ToIndex, Count);\r\n Move(List[FromIndex], List[ToIndex], Count * SizeOf(List[0]));\r\n InitializeArrayAfterMove(List, FromIndex, ToIndex, Count);\r\n end;\r\nend;\r\n\r\nprocedure TJclAnsiStrIntfSortedMap.PutAll(const AMap: IJclAnsiStrIntfMap);\r\nvar\r\n It: IJclAnsiStrIterator;\r\n Key: AnsiString;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if AMap = nil then\r\n Exit;\r\n It := AMap.KeySet.First;\r\n while It.HasNext do\r\n begin\r\n Key := It.Next;\r\n PutValue(Key, AMap.GetValue(Key));\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclAnsiStrIntfSortedMap.PutValue(const Key: AnsiString; const Value: IInterface);\r\nvar\r\n Index: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FAllowDefaultElements or ((KeysCompare(Key, '') <> 0) and (ValuesCompare(Value, nil) <> 0)) then\r\n begin\r\n Index := BinarySearch(Key);\r\n\r\n if (Index >= 0) and (KeysCompare(FEntries[Index].Key, Key) = 0) then\r\n begin\r\n FreeValue(FEntries[Index].Value);\r\n FEntries[Index].Value := Value;\r\n end\r\n else\r\n begin\r\n if FSize = FCapacity then\r\n AutoGrow;\r\n if FSize < FCapacity then\r\n begin\r\n Inc(Index);\r\n if (Index < FSize) and (KeysCompare(FEntries[Index].Key, Key) <> 0) then\r\n MoveArray(FEntries, Index, Index + 1, FSize - Index);\r\n FEntries[Index].Key := Key;\r\n FEntries[Index].Value := Value;\r\n Inc(FSize);\r\n end;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclAnsiStrIntfSortedMap.Remove(const Key: AnsiString): IInterface;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := Extract(Key);\r\n Result := FreeValue(Result);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclAnsiStrIntfSortedMap.SetCapacity(Value: Integer);\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FSize <= Value then\r\n begin\r\n SetLength(FEntries, Value);\r\n inherited SetCapacity(Value);\r\n end\r\n else\r\n raise EJclOperationNotSupportedError.Create;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclAnsiStrIntfSortedMap.Size: Integer;\r\nbegin\r\n Result := FSize;\r\nend;\r\n\r\nfunction TJclAnsiStrIntfSortedMap.SubMap(const FromKey, ToKey: AnsiString): IJclAnsiStrIntfSortedMap;\r\nvar\r\n FromIndex, ToIndex: Integer;\r\n NewMap: TJclAnsiStrIntfSortedMap;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n NewMap := CreateEmptyContainer as TJclAnsiStrIntfSortedMap;\r\n FromIndex := BinarySearch(FromKey);\r\n if (FromIndex = -1) or (KeysCompare(FEntries[FromIndex].Key, FromKey) < 0) then\r\n Inc(FromIndex);\r\n ToIndex := BinarySearch(ToKey);\r\n if (FromIndex >= 0) and (FromIndex <= ToIndex) then\r\n begin\r\n NewMap.SetCapacity(ToIndex - FromIndex + 1);\r\n NewMap.FSize := ToIndex - FromIndex + 1;\r\n while ToIndex >= FromIndex do\r\n begin\r\n NewMap.FEntries[ToIndex - FromIndex] := FEntries[ToIndex];\r\n Dec(ToIndex);\r\n end;\r\n end;\r\n Result := NewMap;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclAnsiStrIntfSortedMap.TailMap(const FromKey: AnsiString): IJclAnsiStrIntfSortedMap;\r\nvar\r\n FromIndex, Index: Integer;\r\n NewMap: TJclAnsiStrIntfSortedMap;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n NewMap := CreateEmptyContainer as TJclAnsiStrIntfSortedMap;\r\n FromIndex := BinarySearch(FromKey);\r\n if (FromIndex = -1) or (KeysCompare(FEntries[FromIndex].Key, FromKey) < 0) then\r\n Inc(FromIndex);\r\n if (FromIndex >= 0) and (FromIndex < FSize) then\r\n begin\r\n NewMap.SetCapacity(FSize - FromIndex);\r\n NewMap.FSize := FSize - FromIndex;\r\n Index := FromIndex;\r\n while Index < FSize do\r\n begin\r\n NewMap.FEntries[Index - FromIndex] := FEntries[Index];\r\n Inc(Index);\r\n end;\r\n end;\r\n Result := NewMap;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclAnsiStrIntfSortedMap.Values: IJclIntfCollection;\r\nvar\r\n Index: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := TJclIntfArrayList.Create(FSize);\r\n for Index := 0 to FSize - 1 do\r\n Result.Add(FEntries[Index].Value);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclAnsiStrIntfSortedMap.CreateEmptyContainer: TJclAbstractContainerBase;\r\nbegin\r\n Result := TJclAnsiStrIntfSortedMap.Create(FSize);\r\n AssignPropertiesTo(Result);\r\nend;\r\n\r\nfunction TJclAnsiStrIntfSortedMap.FreeKey(var Key: AnsiString): AnsiString;\r\nbegin\r\n Result := Key;\r\n Key := '';\r\nend;\r\n\r\nfunction TJclAnsiStrIntfSortedMap.FreeValue(var Value: IInterface): IInterface;\r\nbegin\r\n Result := Value;\r\n Value := nil;\r\nend;\r\n\r\nfunction TJclAnsiStrIntfSortedMap.KeysCompare(const A, B: AnsiString): Integer;\r\nbegin\r\n Result := ItemsCompare(A, B);\r\nend;\r\n\r\nfunction TJclAnsiStrIntfSortedMap.ValuesCompare(const A, B: IInterface): Integer;\r\nbegin\r\n Result := IntfSimpleCompare(A, B);\r\nend;\r\n\r\n//=== { TJclIntfAnsiStrSortedMap } ==============================================\r\n\r\nconstructor TJclIntfAnsiStrSortedMap.Create(ACapacity: Integer);\r\nbegin\r\n inherited Create();\r\n SetCapacity(ACapacity);\r\nend;\r\n\r\ndestructor TJclIntfAnsiStrSortedMap.Destroy;\r\nbegin\r\n FReadOnly := False;\r\n Clear;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJclIntfAnsiStrSortedMap.AssignDataTo(Dest: TJclAbstractContainerBase);\r\nvar\r\n MyDest: TJclIntfAnsiStrSortedMap;\r\nbegin\r\n inherited AssignDataTo(Dest);\r\n if Dest is TJclIntfAnsiStrSortedMap then\r\n begin\r\n MyDest := TJclIntfAnsiStrSortedMap(Dest);\r\n MyDest.SetCapacity(FSize);\r\n MyDest.FEntries := FEntries;\r\n MyDest.FSize := FSize;\r\n end;\r\nend;\r\n\r\nfunction TJclIntfAnsiStrSortedMap.BinarySearch(const Key: IInterface): Integer;\r\nvar\r\n HiPos, LoPos, CompPos: Integer;\r\n Comp: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n LoPos := 0;\r\n HiPos := FSize - 1;\r\n CompPos := (HiPos + LoPos) div 2;\r\n while HiPos >= LoPos do\r\n begin\r\n Comp := KeysCompare(FEntries[CompPos].Key, Key);\r\n if Comp < 0 then\r\n LoPos := CompPos + 1\r\n else\r\n if Comp > 0 then\r\n HiPos := CompPos - 1\r\n else\r\n begin\r\n HiPos := CompPos;\r\n LoPos := CompPos + 1;\r\n end;\r\n CompPos := (HiPos + LoPos) div 2;\r\n end;\r\n Result := HiPos;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclIntfAnsiStrSortedMap.Clear;\r\nvar\r\n Index: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n for Index := 0 to FSize - 1 do\r\n begin\r\n FreeKey(FEntries[Index].Key);\r\n FreeValue(FEntries[Index].Value);\r\n end;\r\n FSize := 0;\r\n AutoPack;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfAnsiStrSortedMap.ContainsKey(const Key: IInterface): Boolean;\r\nvar\r\n Index: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Index := BinarySearch(Key);\r\n Result := (Index >= 0) and (KeysCompare(FEntries[Index].Key, Key) = 0);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfAnsiStrSortedMap.ContainsValue(const Value: AnsiString): Boolean;\r\nvar\r\n Index: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n for Index := 0 to FSize - 1 do\r\n if ValuesCompare(FEntries[Index].Value, Value) = 0 then\r\n begin\r\n Result := True;\r\n Break;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfAnsiStrSortedMap.FirstKey: IInterface;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := nil;\r\n if FSize > 0 then\r\n Result := FEntries[0].Key\r\n else\r\n if not FReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfAnsiStrSortedMap.Extract(const Key: IInterface): AnsiString;\r\nvar\r\n Index: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Index := BinarySearch(Key);\r\n if (Index >= 0) and (KeysCompare(FEntries[Index].Key, Key) = 0) then\r\n begin\r\n Result := FEntries[Index].Value;\r\n FEntries[Index].Value := '';\r\n FreeKey(FEntries[Index].Key);\r\n if Index < (FSize - 1) then\r\n MoveArray(FEntries, Index + 1, Index, FSize - Index - 1);\r\n Dec(FSize);\r\n AutoPack;\r\n end\r\n else\r\n Result := '';\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfAnsiStrSortedMap.GetValue(const Key: IInterface): AnsiString;\r\nvar\r\n Index: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Index := BinarySearch(Key);\r\n Result := '';\r\n if (Index >= 0) and (KeysCompare(FEntries[Index].Key, Key) = 0) then\r\n Result := FEntries[Index].Value\r\n else if not FReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfAnsiStrSortedMap.HeadMap(const ToKey: IInterface): IJclIntfAnsiStrSortedMap;\r\nvar\r\n ToIndex: Integer;\r\n NewMap: TJclIntfAnsiStrSortedMap;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n NewMap := CreateEmptyContainer as TJclIntfAnsiStrSortedMap;\r\n ToIndex := BinarySearch(ToKey);\r\n if ToIndex >= 0 then\r\n begin\r\n NewMap.SetCapacity(ToIndex + 1);\r\n NewMap.FSize := ToIndex + 1;\r\n while ToIndex >= 0 do\r\n begin\r\n NewMap.FEntries[ToIndex] := FEntries[ToIndex];\r\n Dec(ToIndex);\r\n end;\r\n end;\r\n Result := NewMap;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfAnsiStrSortedMap.IsEmpty: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := FSize = 0;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfAnsiStrSortedMap.KeyOfValue(const Value: AnsiString): IInterface;\r\nvar\r\n Index: Integer;\r\n Found: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Found := False;\r\n Result := nil;\r\n for Index := 0 to FSize - 1 do\r\n if ValuesCompare(FEntries[Index].Value, Value) = 0 then\r\n begin\r\n Result := FEntries[Index].Key;\r\n Found := True;\r\n Break;\r\n end;\r\n\r\n if (not Found) and (not FReturnDefaultElements) then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfAnsiStrSortedMap.KeySet: IJclIntfSet;\r\nvar\r\n Index: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := TJclIntfArraySet.Create(FSize);\r\n for Index := 0 to FSize - 1 do\r\n Result.Add(FEntries[Index].Key);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfAnsiStrSortedMap.LastKey: IInterface;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := nil;\r\n if FSize > 0 then\r\n Result := FEntries[FSize - 1].Key\r\n else\r\n if not FReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfAnsiStrSortedMap.MapEquals(const AMap: IJclIntfAnsiStrMap): Boolean;\r\nvar\r\n It: IJclIntfIterator;\r\n Index: Integer;\r\n AKey: IInterface;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if AMap = nil then\r\n Exit;\r\n if FSize <> AMap.Size then\r\n Exit;\r\n It := AMap.KeySet.First;\r\n Index := 0;\r\n while It.HasNext do\r\n begin\r\n if Index >= FSize then\r\n Exit;\r\n AKey := It.Next;\r\n if ValuesCompare(AMap.GetValue(AKey), FEntries[Index].Value) <> 0 then\r\n Exit;\r\n Inc(Index);\r\n end;\r\n Result := True;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclIntfAnsiStrSortedMap.FinalizeArrayBeforeMove(var List: TJclIntfAnsiStrSortedMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\nbegin\r\n Assert(Count > 0);\r\n if FromIndex < ToIndex then\r\n begin\r\n if Count > (ToIndex - FromIndex) then\r\n Finalize(List[FromIndex + Count], ToIndex - FromIndex)\r\n else\r\n Finalize(List[ToIndex], Count);\r\n end\r\n else\r\n if FromIndex > ToIndex then\r\n begin\r\n if Count > (FromIndex - ToIndex) then\r\n Count := FromIndex - ToIndex;\r\n Finalize(List[ToIndex], Count)\r\n end;\r\nend;\r\n\r\nprocedure TJclIntfAnsiStrSortedMap.InitializeArray(var List: TJclIntfAnsiStrSortedMapEntryArray; FromIndex, Count: SizeInt);\r\nbegin\r\n {$IFDEF FPC}\r\n while Count > 0 do\r\n begin\r\n Initialize(List[FromIndex]);\r\n Inc(FromIndex);\r\n Dec(Count);\r\n end;\r\n {$ELSE ~FPC}\r\n Initialize(List[FromIndex], Count);\r\n {$ENDIF ~FPC}\r\nend;\r\n\r\nprocedure TJclIntfAnsiStrSortedMap.InitializeArrayAfterMove(var List: TJclIntfAnsiStrSortedMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\nbegin\r\n { Keep reference counting working }\r\n if FromIndex < ToIndex then\r\n begin\r\n if (ToIndex - FromIndex) < Count then\r\n Count := ToIndex - FromIndex;\r\n InitializeArray(List, FromIndex, Count);\r\n end\r\n else\r\n if FromIndex > ToIndex then\r\n begin\r\n if (FromIndex - ToIndex) < Count then\r\n InitializeArray(List, ToIndex + Count, FromIndex - ToIndex)\r\n else\r\n InitializeArray(List, FromIndex, Count);\r\n end;\r\nend;\r\n\r\nprocedure TJclIntfAnsiStrSortedMap.MoveArray(var List: TJclIntfAnsiStrSortedMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\nbegin\r\n if Count > 0 then\r\n begin\r\n FinalizeArrayBeforeMove(List, FromIndex, ToIndex, Count);\r\n Move(List[FromIndex], List[ToIndex], Count * SizeOf(List[0]));\r\n InitializeArrayAfterMove(List, FromIndex, ToIndex, Count);\r\n end;\r\nend;\r\n\r\nprocedure TJclIntfAnsiStrSortedMap.PutAll(const AMap: IJclIntfAnsiStrMap);\r\nvar\r\n It: IJclIntfIterator;\r\n Key: IInterface;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if AMap = nil then\r\n Exit;\r\n It := AMap.KeySet.First;\r\n while It.HasNext do\r\n begin\r\n Key := It.Next;\r\n PutValue(Key, AMap.GetValue(Key));\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclIntfAnsiStrSortedMap.PutValue(const Key: IInterface; const Value: AnsiString);\r\nvar\r\n Index: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FAllowDefaultElements or ((KeysCompare(Key, nil) <> 0) and (ValuesCompare(Value, '') <> 0)) then\r\n begin\r\n Index := BinarySearch(Key);\r\n\r\n if (Index >= 0) and (KeysCompare(FEntries[Index].Key, Key) = 0) then\r\n begin\r\n FreeValue(FEntries[Index].Value);\r\n FEntries[Index].Value := Value;\r\n end\r\n else\r\n begin\r\n if FSize = FCapacity then\r\n AutoGrow;\r\n if FSize < FCapacity then\r\n begin\r\n Inc(Index);\r\n if (Index < FSize) and (KeysCompare(FEntries[Index].Key, Key) <> 0) then\r\n MoveArray(FEntries, Index, Index + 1, FSize - Index);\r\n FEntries[Index].Key := Key;\r\n FEntries[Index].Value := Value;\r\n Inc(FSize);\r\n end;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfAnsiStrSortedMap.Remove(const Key: IInterface): AnsiString;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := Extract(Key);\r\n Result := FreeValue(Result);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclIntfAnsiStrSortedMap.SetCapacity(Value: Integer);\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FSize <= Value then\r\n begin\r\n SetLength(FEntries, Value);\r\n inherited SetCapacity(Value);\r\n end\r\n else\r\n raise EJclOperationNotSupportedError.Create;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfAnsiStrSortedMap.Size: Integer;\r\nbegin\r\n Result := FSize;\r\nend;\r\n\r\nfunction TJclIntfAnsiStrSortedMap.SubMap(const FromKey, ToKey: IInterface): IJclIntfAnsiStrSortedMap;\r\nvar\r\n FromIndex, ToIndex: Integer;\r\n NewMap: TJclIntfAnsiStrSortedMap;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n NewMap := CreateEmptyContainer as TJclIntfAnsiStrSortedMap;\r\n FromIndex := BinarySearch(FromKey);\r\n if (FromIndex = -1) or (KeysCompare(FEntries[FromIndex].Key, FromKey) < 0) then\r\n Inc(FromIndex);\r\n ToIndex := BinarySearch(ToKey);\r\n if (FromIndex >= 0) and (FromIndex <= ToIndex) then\r\n begin\r\n NewMap.SetCapacity(ToIndex - FromIndex + 1);\r\n NewMap.FSize := ToIndex - FromIndex + 1;\r\n while ToIndex >= FromIndex do\r\n begin\r\n NewMap.FEntries[ToIndex - FromIndex] := FEntries[ToIndex];\r\n Dec(ToIndex);\r\n end;\r\n end;\r\n Result := NewMap;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfAnsiStrSortedMap.TailMap(const FromKey: IInterface): IJclIntfAnsiStrSortedMap;\r\nvar\r\n FromIndex, Index: Integer;\r\n NewMap: TJclIntfAnsiStrSortedMap;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n NewMap := CreateEmptyContainer as TJclIntfAnsiStrSortedMap;\r\n FromIndex := BinarySearch(FromKey);\r\n if (FromIndex = -1) or (KeysCompare(FEntries[FromIndex].Key, FromKey) < 0) then\r\n Inc(FromIndex);\r\n if (FromIndex >= 0) and (FromIndex < FSize) then\r\n begin\r\n NewMap.SetCapacity(FSize - FromIndex);\r\n NewMap.FSize := FSize - FromIndex;\r\n Index := FromIndex;\r\n while Index < FSize do\r\n begin\r\n NewMap.FEntries[Index - FromIndex] := FEntries[Index];\r\n Inc(Index);\r\n end;\r\n end;\r\n Result := NewMap;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfAnsiStrSortedMap.Values: IJclAnsiStrCollection;\r\nvar\r\n Index: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := TJclAnsiStrArrayList.Create(FSize);\r\n for Index := 0 to FSize - 1 do\r\n Result.Add(FEntries[Index].Value);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfAnsiStrSortedMap.CreateEmptyContainer: TJclAbstractContainerBase;\r\nbegin\r\n Result := TJclIntfAnsiStrSortedMap.Create(FSize);\r\n AssignPropertiesTo(Result);\r\nend;\r\n\r\nfunction TJclIntfAnsiStrSortedMap.FreeKey(var Key: IInterface): IInterface;\r\nbegin\r\n Result := Key;\r\n Key := nil;\r\nend;\r\n\r\nfunction TJclIntfAnsiStrSortedMap.FreeValue(var Value: AnsiString): AnsiString;\r\nbegin\r\n Result := Value;\r\n Value := '';\r\nend;\r\n\r\nfunction TJclIntfAnsiStrSortedMap.KeysCompare(const A, B: IInterface): Integer;\r\nbegin\r\n Result := IntfSimpleCompare(A, B);\r\nend;\r\n\r\nfunction TJclIntfAnsiStrSortedMap.ValuesCompare(const A, B: AnsiString): Integer;\r\nbegin\r\n Result := ItemsCompare(A, B);\r\nend;\r\n\r\n//=== { TJclAnsiStrAnsiStrSortedMap } ==============================================\r\n\r\nconstructor TJclAnsiStrAnsiStrSortedMap.Create(ACapacity: Integer);\r\nbegin\r\n inherited Create();\r\n SetCapacity(ACapacity);\r\nend;\r\n\r\ndestructor TJclAnsiStrAnsiStrSortedMap.Destroy;\r\nbegin\r\n FReadOnly := False;\r\n Clear;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJclAnsiStrAnsiStrSortedMap.AssignDataTo(Dest: TJclAbstractContainerBase);\r\nvar\r\n MyDest: TJclAnsiStrAnsiStrSortedMap;\r\nbegin\r\n inherited AssignDataTo(Dest);\r\n if Dest is TJclAnsiStrAnsiStrSortedMap then\r\n begin\r\n MyDest := TJclAnsiStrAnsiStrSortedMap(Dest);\r\n MyDest.SetCapacity(FSize);\r\n MyDest.FEntries := FEntries;\r\n MyDest.FSize := FSize;\r\n end;\r\nend;\r\n\r\nfunction TJclAnsiStrAnsiStrSortedMap.BinarySearch(const Key: AnsiString): Integer;\r\nvar\r\n HiPos, LoPos, CompPos: Integer;\r\n Comp: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n LoPos := 0;\r\n HiPos := FSize - 1;\r\n CompPos := (HiPos + LoPos) div 2;\r\n while HiPos >= LoPos do\r\n begin\r\n Comp := KeysCompare(FEntries[CompPos].Key, Key);\r\n if Comp < 0 then\r\n LoPos := CompPos + 1\r\n else\r\n if Comp > 0 then\r\n HiPos := CompPos - 1\r\n else\r\n begin\r\n HiPos := CompPos;\r\n LoPos := CompPos + 1;\r\n end;\r\n CompPos := (HiPos + LoPos) div 2;\r\n end;\r\n Result := HiPos;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclAnsiStrAnsiStrSortedMap.Clear;\r\nvar\r\n Index: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n for Index := 0 to FSize - 1 do\r\n begin\r\n FreeKey(FEntries[Index].Key);\r\n FreeValue(FEntries[Index].Value);\r\n end;\r\n FSize := 0;\r\n AutoPack;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclAnsiStrAnsiStrSortedMap.ContainsKey(const Key: AnsiString): Boolean;\r\nvar\r\n Index: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Index := BinarySearch(Key);\r\n Result := (Index >= 0) and (KeysCompare(FEntries[Index].Key, Key) = 0);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclAnsiStrAnsiStrSortedMap.ContainsValue(const Value: AnsiString): Boolean;\r\nvar\r\n Index: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n for Index := 0 to FSize - 1 do\r\n if ValuesCompare(FEntries[Index].Value, Value) = 0 then\r\n begin\r\n Result := True;\r\n Break;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclAnsiStrAnsiStrSortedMap.FirstKey: AnsiString;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := '';\r\n if FSize > 0 then\r\n Result := FEntries[0].Key\r\n else\r\n if not FReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclAnsiStrAnsiStrSortedMap.Extract(const Key: AnsiString): AnsiString;\r\nvar\r\n Index: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Index := BinarySearch(Key);\r\n if (Index >= 0) and (KeysCompare(FEntries[Index].Key, Key) = 0) then\r\n begin\r\n Result := FEntries[Index].Value;\r\n FEntries[Index].Value := '';\r\n FreeKey(FEntries[Index].Key);\r\n if Index < (FSize - 1) then\r\n MoveArray(FEntries, Index + 1, Index, FSize - Index - 1);\r\n Dec(FSize);\r\n AutoPack;\r\n end\r\n else\r\n Result := '';\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclAnsiStrAnsiStrSortedMap.GetValue(const Key: AnsiString): AnsiString;\r\nvar\r\n Index: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Index := BinarySearch(Key);\r\n Result := '';\r\n if (Index >= 0) and (KeysCompare(FEntries[Index].Key, Key) = 0) then\r\n Result := FEntries[Index].Value\r\n else if not FReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclAnsiStrAnsiStrSortedMap.HeadMap(const ToKey: AnsiString): IJclAnsiStrAnsiStrSortedMap;\r\nvar\r\n ToIndex: Integer;\r\n NewMap: TJclAnsiStrAnsiStrSortedMap;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n NewMap := CreateEmptyContainer as TJclAnsiStrAnsiStrSortedMap;\r\n ToIndex := BinarySearch(ToKey);\r\n if ToIndex >= 0 then\r\n begin\r\n NewMap.SetCapacity(ToIndex + 1);\r\n NewMap.FSize := ToIndex + 1;\r\n while ToIndex >= 0 do\r\n begin\r\n NewMap.FEntries[ToIndex] := FEntries[ToIndex];\r\n Dec(ToIndex);\r\n end;\r\n end;\r\n Result := NewMap;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclAnsiStrAnsiStrSortedMap.IsEmpty: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := FSize = 0;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclAnsiStrAnsiStrSortedMap.KeyOfValue(const Value: AnsiString): AnsiString;\r\nvar\r\n Index: Integer;\r\n Found: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Found := False;\r\n Result := '';\r\n for Index := 0 to FSize - 1 do\r\n if ValuesCompare(FEntries[Index].Value, Value) = 0 then\r\n begin\r\n Result := FEntries[Index].Key;\r\n Found := True;\r\n Break;\r\n end;\r\n\r\n if (not Found) and (not FReturnDefaultElements) then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclAnsiStrAnsiStrSortedMap.KeySet: IJclAnsiStrSet;\r\nvar\r\n Index: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := TJclAnsiStrArraySet.Create(FSize);\r\n for Index := 0 to FSize - 1 do\r\n Result.Add(FEntries[Index].Key);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclAnsiStrAnsiStrSortedMap.LastKey: AnsiString;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := '';\r\n if FSize > 0 then\r\n Result := FEntries[FSize - 1].Key\r\n else\r\n if not FReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclAnsiStrAnsiStrSortedMap.MapEquals(const AMap: IJclAnsiStrAnsiStrMap): Boolean;\r\nvar\r\n It: IJclAnsiStrIterator;\r\n Index: Integer;\r\n AKey: AnsiString;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if AMap = nil then\r\n Exit;\r\n if FSize <> AMap.Size then\r\n Exit;\r\n It := AMap.KeySet.First;\r\n Index := 0;\r\n while It.HasNext do\r\n begin\r\n if Index >= FSize then\r\n Exit;\r\n AKey := It.Next;\r\n if ValuesCompare(AMap.GetValue(AKey), FEntries[Index].Value) <> 0 then\r\n Exit;\r\n Inc(Index);\r\n end;\r\n Result := True;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclAnsiStrAnsiStrSortedMap.FinalizeArrayBeforeMove(var List: TJclAnsiStrAnsiStrSortedMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\nbegin\r\n Assert(Count > 0);\r\n if FromIndex < ToIndex then\r\n begin\r\n if Count > (ToIndex - FromIndex) then\r\n Finalize(List[FromIndex + Count], ToIndex - FromIndex)\r\n else\r\n Finalize(List[ToIndex], Count);\r\n end\r\n else\r\n if FromIndex > ToIndex then\r\n begin\r\n if Count > (FromIndex - ToIndex) then\r\n Count := FromIndex - ToIndex;\r\n Finalize(List[ToIndex], Count)\r\n end;\r\nend;\r\n\r\nprocedure TJclAnsiStrAnsiStrSortedMap.InitializeArray(var List: TJclAnsiStrAnsiStrSortedMapEntryArray; FromIndex, Count: SizeInt);\r\nbegin\r\n {$IFDEF FPC}\r\n while Count > 0 do\r\n begin\r\n Initialize(List[FromIndex]);\r\n Inc(FromIndex);\r\n Dec(Count);\r\n end;\r\n {$ELSE ~FPC}\r\n Initialize(List[FromIndex], Count);\r\n {$ENDIF ~FPC}\r\nend;\r\n\r\nprocedure TJclAnsiStrAnsiStrSortedMap.InitializeArrayAfterMove(var List: TJclAnsiStrAnsiStrSortedMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\nbegin\r\n { Keep reference counting working }\r\n if FromIndex < ToIndex then\r\n begin\r\n if (ToIndex - FromIndex) < Count then\r\n Count := ToIndex - FromIndex;\r\n InitializeArray(List, FromIndex, Count);\r\n end\r\n else\r\n if FromIndex > ToIndex then\r\n begin\r\n if (FromIndex - ToIndex) < Count then\r\n InitializeArray(List, ToIndex + Count, FromIndex - ToIndex)\r\n else\r\n InitializeArray(List, FromIndex, Count);\r\n end;\r\nend;\r\n\r\nprocedure TJclAnsiStrAnsiStrSortedMap.MoveArray(var List: TJclAnsiStrAnsiStrSortedMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\nbegin\r\n if Count > 0 then\r\n begin\r\n FinalizeArrayBeforeMove(List, FromIndex, ToIndex, Count);\r\n Move(List[FromIndex], List[ToIndex], Count * SizeOf(List[0]));\r\n InitializeArrayAfterMove(List, FromIndex, ToIndex, Count);\r\n end;\r\nend;\r\n\r\nprocedure TJclAnsiStrAnsiStrSortedMap.PutAll(const AMap: IJclAnsiStrAnsiStrMap);\r\nvar\r\n It: IJclAnsiStrIterator;\r\n Key: AnsiString;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if AMap = nil then\r\n Exit;\r\n It := AMap.KeySet.First;\r\n while It.HasNext do\r\n begin\r\n Key := It.Next;\r\n PutValue(Key, AMap.GetValue(Key));\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclAnsiStrAnsiStrSortedMap.PutValue(const Key: AnsiString; const Value: AnsiString);\r\nvar\r\n Index: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FAllowDefaultElements or ((KeysCompare(Key, '') <> 0) and (ValuesCompare(Value, '') <> 0)) then\r\n begin\r\n Index := BinarySearch(Key);\r\n\r\n if (Index >= 0) and (KeysCompare(FEntries[Index].Key, Key) = 0) then\r\n begin\r\n FreeValue(FEntries[Index].Value);\r\n FEntries[Index].Value := Value;\r\n end\r\n else\r\n begin\r\n if FSize = FCapacity then\r\n AutoGrow;\r\n if FSize < FCapacity then\r\n begin\r\n Inc(Index);\r\n if (Index < FSize) and (KeysCompare(FEntries[Index].Key, Key) <> 0) then\r\n MoveArray(FEntries, Index, Index + 1, FSize - Index);\r\n FEntries[Index].Key := Key;\r\n FEntries[Index].Value := Value;\r\n Inc(FSize);\r\n end;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclAnsiStrAnsiStrSortedMap.Remove(const Key: AnsiString): AnsiString;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := Extract(Key);\r\n Result := FreeValue(Result);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclAnsiStrAnsiStrSortedMap.SetCapacity(Value: Integer);\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FSize <= Value then\r\n begin\r\n SetLength(FEntries, Value);\r\n inherited SetCapacity(Value);\r\n end\r\n else\r\n raise EJclOperationNotSupportedError.Create;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclAnsiStrAnsiStrSortedMap.Size: Integer;\r\nbegin\r\n Result := FSize;\r\nend;\r\n\r\nfunction TJclAnsiStrAnsiStrSortedMap.SubMap(const FromKey, ToKey: AnsiString): IJclAnsiStrAnsiStrSortedMap;\r\nvar\r\n FromIndex, ToIndex: Integer;\r\n NewMap: TJclAnsiStrAnsiStrSortedMap;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n NewMap := CreateEmptyContainer as TJclAnsiStrAnsiStrSortedMap;\r\n FromIndex := BinarySearch(FromKey);\r\n if (FromIndex = -1) or (KeysCompare(FEntries[FromIndex].Key, FromKey) < 0) then\r\n Inc(FromIndex);\r\n ToIndex := BinarySearch(ToKey);\r\n if (FromIndex >= 0) and (FromIndex <= ToIndex) then\r\n begin\r\n NewMap.SetCapacity(ToIndex - FromIndex + 1);\r\n NewMap.FSize := ToIndex - FromIndex + 1;\r\n while ToIndex >= FromIndex do\r\n begin\r\n NewMap.FEntries[ToIndex - FromIndex] := FEntries[ToIndex];\r\n Dec(ToIndex);\r\n end;\r\n end;\r\n Result := NewMap;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclAnsiStrAnsiStrSortedMap.TailMap(const FromKey: AnsiString): IJclAnsiStrAnsiStrSortedMap;\r\nvar\r\n FromIndex, Index: Integer;\r\n NewMap: TJclAnsiStrAnsiStrSortedMap;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n NewMap := CreateEmptyContainer as TJclAnsiStrAnsiStrSortedMap;\r\n FromIndex := BinarySearch(FromKey);\r\n if (FromIndex = -1) or (KeysCompare(FEntries[FromIndex].Key, FromKey) < 0) then\r\n Inc(FromIndex);\r\n if (FromIndex >= 0) and (FromIndex < FSize) then\r\n begin\r\n NewMap.SetCapacity(FSize - FromIndex);\r\n NewMap.FSize := FSize - FromIndex;\r\n Index := FromIndex;\r\n while Index < FSize do\r\n begin\r\n NewMap.FEntries[Index - FromIndex] := FEntries[Index];\r\n Inc(Index);\r\n end;\r\n end;\r\n Result := NewMap;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclAnsiStrAnsiStrSortedMap.Values: IJclAnsiStrCollection;\r\nvar\r\n Index: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := TJclAnsiStrArrayList.Create(FSize);\r\n for Index := 0 to FSize - 1 do\r\n Result.Add(FEntries[Index].Value);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclAnsiStrAnsiStrSortedMap.CreateEmptyContainer: TJclAbstractContainerBase;\r\nbegin\r\n Result := TJclAnsiStrAnsiStrSortedMap.Create(FSize);\r\n AssignPropertiesTo(Result);\r\nend;\r\n\r\nfunction TJclAnsiStrAnsiStrSortedMap.FreeKey(var Key: AnsiString): AnsiString;\r\nbegin\r\n Result := Key;\r\n Key := '';\r\nend;\r\n\r\nfunction TJclAnsiStrAnsiStrSortedMap.FreeValue(var Value: AnsiString): AnsiString;\r\nbegin\r\n Result := Value;\r\n Value := '';\r\nend;\r\n\r\nfunction TJclAnsiStrAnsiStrSortedMap.KeysCompare(const A, B: AnsiString): Integer;\r\nbegin\r\n Result := ItemsCompare(A, B);\r\nend;\r\n\r\nfunction TJclAnsiStrAnsiStrSortedMap.ValuesCompare(const A, B: AnsiString): Integer;\r\nbegin\r\n Result := ItemsCompare(A, B);\r\nend;\r\n\r\n//=== { TJclWideStrIntfSortedMap } ==============================================\r\n\r\nconstructor TJclWideStrIntfSortedMap.Create(ACapacity: Integer);\r\nbegin\r\n inherited Create();\r\n SetCapacity(ACapacity);\r\nend;\r\n\r\ndestructor TJclWideStrIntfSortedMap.Destroy;\r\nbegin\r\n FReadOnly := False;\r\n Clear;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJclWideStrIntfSortedMap.AssignDataTo(Dest: TJclAbstractContainerBase);\r\nvar\r\n MyDest: TJclWideStrIntfSortedMap;\r\nbegin\r\n inherited AssignDataTo(Dest);\r\n if Dest is TJclWideStrIntfSortedMap then\r\n begin\r\n MyDest := TJclWideStrIntfSortedMap(Dest);\r\n MyDest.SetCapacity(FSize);\r\n MyDest.FEntries := FEntries;\r\n MyDest.FSize := FSize;\r\n end;\r\nend;\r\n\r\nfunction TJclWideStrIntfSortedMap.BinarySearch(const Key: WideString): Integer;\r\nvar\r\n HiPos, LoPos, CompPos: Integer;\r\n Comp: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n LoPos := 0;\r\n HiPos := FSize - 1;\r\n CompPos := (HiPos + LoPos) div 2;\r\n while HiPos >= LoPos do\r\n begin\r\n Comp := KeysCompare(FEntries[CompPos].Key, Key);\r\n if Comp < 0 then\r\n LoPos := CompPos + 1\r\n else\r\n if Comp > 0 then\r\n HiPos := CompPos - 1\r\n else\r\n begin\r\n HiPos := CompPos;\r\n LoPos := CompPos + 1;\r\n end;\r\n CompPos := (HiPos + LoPos) div 2;\r\n end;\r\n Result := HiPos;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclWideStrIntfSortedMap.Clear;\r\nvar\r\n Index: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n for Index := 0 to FSize - 1 do\r\n begin\r\n FreeKey(FEntries[Index].Key);\r\n FreeValue(FEntries[Index].Value);\r\n end;\r\n FSize := 0;\r\n AutoPack;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclWideStrIntfSortedMap.ContainsKey(const Key: WideString): Boolean;\r\nvar\r\n Index: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Index := BinarySearch(Key);\r\n Result := (Index >= 0) and (KeysCompare(FEntries[Index].Key, Key) = 0);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclWideStrIntfSortedMap.ContainsValue(const Value: IInterface): Boolean;\r\nvar\r\n Index: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n for Index := 0 to FSize - 1 do\r\n if ValuesCompare(FEntries[Index].Value, Value) = 0 then\r\n begin\r\n Result := True;\r\n Break;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclWideStrIntfSortedMap.FirstKey: WideString;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := '';\r\n if FSize > 0 then\r\n Result := FEntries[0].Key\r\n else\r\n if not FReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclWideStrIntfSortedMap.Extract(const Key: WideString): IInterface;\r\nvar\r\n Index: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Index := BinarySearch(Key);\r\n if (Index >= 0) and (KeysCompare(FEntries[Index].Key, Key) = 0) then\r\n begin\r\n Result := FEntries[Index].Value;\r\n FEntries[Index].Value := nil;\r\n FreeKey(FEntries[Index].Key);\r\n if Index < (FSize - 1) then\r\n MoveArray(FEntries, Index + 1, Index, FSize - Index - 1);\r\n Dec(FSize);\r\n AutoPack;\r\n end\r\n else\r\n Result := nil;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclWideStrIntfSortedMap.GetValue(const Key: WideString): IInterface;\r\nvar\r\n Index: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Index := BinarySearch(Key);\r\n Result := nil;\r\n if (Index >= 0) and (KeysCompare(FEntries[Index].Key, Key) = 0) then\r\n Result := FEntries[Index].Value\r\n else if not FReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclWideStrIntfSortedMap.HeadMap(const ToKey: WideString): IJclWideStrIntfSortedMap;\r\nvar\r\n ToIndex: Integer;\r\n NewMap: TJclWideStrIntfSortedMap;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n NewMap := CreateEmptyContainer as TJclWideStrIntfSortedMap;\r\n ToIndex := BinarySearch(ToKey);\r\n if ToIndex >= 0 then\r\n begin\r\n NewMap.SetCapacity(ToIndex + 1);\r\n NewMap.FSize := ToIndex + 1;\r\n while ToIndex >= 0 do\r\n begin\r\n NewMap.FEntries[ToIndex] := FEntries[ToIndex];\r\n Dec(ToIndex);\r\n end;\r\n end;\r\n Result := NewMap;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclWideStrIntfSortedMap.IsEmpty: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := FSize = 0;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclWideStrIntfSortedMap.KeyOfValue(const Value: IInterface): WideString;\r\nvar\r\n Index: Integer;\r\n Found: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Found := False;\r\n Result := '';\r\n for Index := 0 to FSize - 1 do\r\n if ValuesCompare(FEntries[Index].Value, Value) = 0 then\r\n begin\r\n Result := FEntries[Index].Key;\r\n Found := True;\r\n Break;\r\n end;\r\n\r\n if (not Found) and (not FReturnDefaultElements) then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclWideStrIntfSortedMap.KeySet: IJclWideStrSet;\r\nvar\r\n Index: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := TJclWideStrArraySet.Create(FSize);\r\n for Index := 0 to FSize - 1 do\r\n Result.Add(FEntries[Index].Key);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclWideStrIntfSortedMap.LastKey: WideString;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := '';\r\n if FSize > 0 then\r\n Result := FEntries[FSize - 1].Key\r\n else\r\n if not FReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclWideStrIntfSortedMap.MapEquals(const AMap: IJclWideStrIntfMap): Boolean;\r\nvar\r\n It: IJclWideStrIterator;\r\n Index: Integer;\r\n AKey: WideString;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if AMap = nil then\r\n Exit;\r\n if FSize <> AMap.Size then\r\n Exit;\r\n It := AMap.KeySet.First;\r\n Index := 0;\r\n while It.HasNext do\r\n begin\r\n if Index >= FSize then\r\n Exit;\r\n AKey := It.Next;\r\n if ValuesCompare(AMap.GetValue(AKey), FEntries[Index].Value) <> 0 then\r\n Exit;\r\n Inc(Index);\r\n end;\r\n Result := True;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclWideStrIntfSortedMap.FinalizeArrayBeforeMove(var List: TJclWideStrIntfSortedMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\nbegin\r\n Assert(Count > 0);\r\n if FromIndex < ToIndex then\r\n begin\r\n if Count > (ToIndex - FromIndex) then\r\n Finalize(List[FromIndex + Count], ToIndex - FromIndex)\r\n else\r\n Finalize(List[ToIndex], Count);\r\n end\r\n else\r\n if FromIndex > ToIndex then\r\n begin\r\n if Count > (FromIndex - ToIndex) then\r\n Count := FromIndex - ToIndex;\r\n Finalize(List[ToIndex], Count)\r\n end;\r\nend;\r\n\r\nprocedure TJclWideStrIntfSortedMap.InitializeArray(var List: TJclWideStrIntfSortedMapEntryArray; FromIndex, Count: SizeInt);\r\nbegin\r\n {$IFDEF FPC}\r\n while Count > 0 do\r\n begin\r\n Initialize(List[FromIndex]);\r\n Inc(FromIndex);\r\n Dec(Count);\r\n end;\r\n {$ELSE ~FPC}\r\n Initialize(List[FromIndex], Count);\r\n {$ENDIF ~FPC}\r\nend;\r\n\r\nprocedure TJclWideStrIntfSortedMap.InitializeArrayAfterMove(var List: TJclWideStrIntfSortedMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\nbegin\r\n { Keep reference counting working }\r\n if FromIndex < ToIndex then\r\n begin\r\n if (ToIndex - FromIndex) < Count then\r\n Count := ToIndex - FromIndex;\r\n InitializeArray(List, FromIndex, Count);\r\n end\r\n else\r\n if FromIndex > ToIndex then\r\n begin\r\n if (FromIndex - ToIndex) < Count then\r\n InitializeArray(List, ToIndex + Count, FromIndex - ToIndex)\r\n else\r\n InitializeArray(List, FromIndex, Count);\r\n end;\r\nend;\r\n\r\nprocedure TJclWideStrIntfSortedMap.MoveArray(var List: TJclWideStrIntfSortedMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\nbegin\r\n if Count > 0 then\r\n begin\r\n FinalizeArrayBeforeMove(List, FromIndex, ToIndex, Count);\r\n Move(List[FromIndex], List[ToIndex], Count * SizeOf(List[0]));\r\n InitializeArrayAfterMove(List, FromIndex, ToIndex, Count);\r\n end;\r\nend;\r\n\r\nprocedure TJclWideStrIntfSortedMap.PutAll(const AMap: IJclWideStrIntfMap);\r\nvar\r\n It: IJclWideStrIterator;\r\n Key: WideString;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if AMap = nil then\r\n Exit;\r\n It := AMap.KeySet.First;\r\n while It.HasNext do\r\n begin\r\n Key := It.Next;\r\n PutValue(Key, AMap.GetValue(Key));\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclWideStrIntfSortedMap.PutValue(const Key: WideString; const Value: IInterface);\r\nvar\r\n Index: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FAllowDefaultElements or ((KeysCompare(Key, '') <> 0) and (ValuesCompare(Value, nil) <> 0)) then\r\n begin\r\n Index := BinarySearch(Key);\r\n\r\n if (Index >= 0) and (KeysCompare(FEntries[Index].Key, Key) = 0) then\r\n begin\r\n FreeValue(FEntries[Index].Value);\r\n FEntries[Index].Value := Value;\r\n end\r\n else\r\n begin\r\n if FSize = FCapacity then\r\n AutoGrow;\r\n if FSize < FCapacity then\r\n begin\r\n Inc(Index);\r\n if (Index < FSize) and (KeysCompare(FEntries[Index].Key, Key) <> 0) then\r\n MoveArray(FEntries, Index, Index + 1, FSize - Index);\r\n FEntries[Index].Key := Key;\r\n FEntries[Index].Value := Value;\r\n Inc(FSize);\r\n end;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclWideStrIntfSortedMap.Remove(const Key: WideString): IInterface;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := Extract(Key);\r\n Result := FreeValue(Result);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclWideStrIntfSortedMap.SetCapacity(Value: Integer);\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FSize <= Value then\r\n begin\r\n SetLength(FEntries, Value);\r\n inherited SetCapacity(Value);\r\n end\r\n else\r\n raise EJclOperationNotSupportedError.Create;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclWideStrIntfSortedMap.Size: Integer;\r\nbegin\r\n Result := FSize;\r\nend;\r\n\r\nfunction TJclWideStrIntfSortedMap.SubMap(const FromKey, ToKey: WideString): IJclWideStrIntfSortedMap;\r\nvar\r\n FromIndex, ToIndex: Integer;\r\n NewMap: TJclWideStrIntfSortedMap;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n NewMap := CreateEmptyContainer as TJclWideStrIntfSortedMap;\r\n FromIndex := BinarySearch(FromKey);\r\n if (FromIndex = -1) or (KeysCompare(FEntries[FromIndex].Key, FromKey) < 0) then\r\n Inc(FromIndex);\r\n ToIndex := BinarySearch(ToKey);\r\n if (FromIndex >= 0) and (FromIndex <= ToIndex) then\r\n begin\r\n NewMap.SetCapacity(ToIndex - FromIndex + 1);\r\n NewMap.FSize := ToIndex - FromIndex + 1;\r\n while ToIndex >= FromIndex do\r\n begin\r\n NewMap.FEntries[ToIndex - FromIndex] := FEntries[ToIndex];\r\n Dec(ToIndex);\r\n end;\r\n end;\r\n Result := NewMap;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclWideStrIntfSortedMap.TailMap(const FromKey: WideString): IJclWideStrIntfSortedMap;\r\nvar\r\n FromIndex, Index: Integer;\r\n NewMap: TJclWideStrIntfSortedMap;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n NewMap := CreateEmptyContainer as TJclWideStrIntfSortedMap;\r\n FromIndex := BinarySearch(FromKey);\r\n if (FromIndex = -1) or (KeysCompare(FEntries[FromIndex].Key, FromKey) < 0) then\r\n Inc(FromIndex);\r\n if (FromIndex >= 0) and (FromIndex < FSize) then\r\n begin\r\n NewMap.SetCapacity(FSize - FromIndex);\r\n NewMap.FSize := FSize - FromIndex;\r\n Index := FromIndex;\r\n while Index < FSize do\r\n begin\r\n NewMap.FEntries[Index - FromIndex] := FEntries[Index];\r\n Inc(Index);\r\n end;\r\n end;\r\n Result := NewMap;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclWideStrIntfSortedMap.Values: IJclIntfCollection;\r\nvar\r\n Index: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := TJclIntfArrayList.Create(FSize);\r\n for Index := 0 to FSize - 1 do\r\n Result.Add(FEntries[Index].Value);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclWideStrIntfSortedMap.CreateEmptyContainer: TJclAbstractContainerBase;\r\nbegin\r\n Result := TJclWideStrIntfSortedMap.Create(FSize);\r\n AssignPropertiesTo(Result);\r\nend;\r\n\r\nfunction TJclWideStrIntfSortedMap.FreeKey(var Key: WideString): WideString;\r\nbegin\r\n Result := Key;\r\n Key := '';\r\nend;\r\n\r\nfunction TJclWideStrIntfSortedMap.FreeValue(var Value: IInterface): IInterface;\r\nbegin\r\n Result := Value;\r\n Value := nil;\r\nend;\r\n\r\nfunction TJclWideStrIntfSortedMap.KeysCompare(const A, B: WideString): Integer;\r\nbegin\r\n Result := ItemsCompare(A, B);\r\nend;\r\n\r\nfunction TJclWideStrIntfSortedMap.ValuesCompare(const A, B: IInterface): Integer;\r\nbegin\r\n Result := IntfSimpleCompare(A, B);\r\nend;\r\n\r\n//=== { TJclIntfWideStrSortedMap } ==============================================\r\n\r\nconstructor TJclIntfWideStrSortedMap.Create(ACapacity: Integer);\r\nbegin\r\n inherited Create();\r\n SetCapacity(ACapacity);\r\nend;\r\n\r\ndestructor TJclIntfWideStrSortedMap.Destroy;\r\nbegin\r\n FReadOnly := False;\r\n Clear;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJclIntfWideStrSortedMap.AssignDataTo(Dest: TJclAbstractContainerBase);\r\nvar\r\n MyDest: TJclIntfWideStrSortedMap;\r\nbegin\r\n inherited AssignDataTo(Dest);\r\n if Dest is TJclIntfWideStrSortedMap then\r\n begin\r\n MyDest := TJclIntfWideStrSortedMap(Dest);\r\n MyDest.SetCapacity(FSize);\r\n MyDest.FEntries := FEntries;\r\n MyDest.FSize := FSize;\r\n end;\r\nend;\r\n\r\nfunction TJclIntfWideStrSortedMap.BinarySearch(const Key: IInterface): Integer;\r\nvar\r\n HiPos, LoPos, CompPos: Integer;\r\n Comp: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n LoPos := 0;\r\n HiPos := FSize - 1;\r\n CompPos := (HiPos + LoPos) div 2;\r\n while HiPos >= LoPos do\r\n begin\r\n Comp := KeysCompare(FEntries[CompPos].Key, Key);\r\n if Comp < 0 then\r\n LoPos := CompPos + 1\r\n else\r\n if Comp > 0 then\r\n HiPos := CompPos - 1\r\n else\r\n begin\r\n HiPos := CompPos;\r\n LoPos := CompPos + 1;\r\n end;\r\n CompPos := (HiPos + LoPos) div 2;\r\n end;\r\n Result := HiPos;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclIntfWideStrSortedMap.Clear;\r\nvar\r\n Index: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n for Index := 0 to FSize - 1 do\r\n begin\r\n FreeKey(FEntries[Index].Key);\r\n FreeValue(FEntries[Index].Value);\r\n end;\r\n FSize := 0;\r\n AutoPack;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfWideStrSortedMap.ContainsKey(const Key: IInterface): Boolean;\r\nvar\r\n Index: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Index := BinarySearch(Key);\r\n Result := (Index >= 0) and (KeysCompare(FEntries[Index].Key, Key) = 0);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfWideStrSortedMap.ContainsValue(const Value: WideString): Boolean;\r\nvar\r\n Index: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n for Index := 0 to FSize - 1 do\r\n if ValuesCompare(FEntries[Index].Value, Value) = 0 then\r\n begin\r\n Result := True;\r\n Break;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfWideStrSortedMap.FirstKey: IInterface;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := nil;\r\n if FSize > 0 then\r\n Result := FEntries[0].Key\r\n else\r\n if not FReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfWideStrSortedMap.Extract(const Key: IInterface): WideString;\r\nvar\r\n Index: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Index := BinarySearch(Key);\r\n if (Index >= 0) and (KeysCompare(FEntries[Index].Key, Key) = 0) then\r\n begin\r\n Result := FEntries[Index].Value;\r\n FEntries[Index].Value := '';\r\n FreeKey(FEntries[Index].Key);\r\n if Index < (FSize - 1) then\r\n MoveArray(FEntries, Index + 1, Index, FSize - Index - 1);\r\n Dec(FSize);\r\n AutoPack;\r\n end\r\n else\r\n Result := '';\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfWideStrSortedMap.GetValue(const Key: IInterface): WideString;\r\nvar\r\n Index: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Index := BinarySearch(Key);\r\n Result := '';\r\n if (Index >= 0) and (KeysCompare(FEntries[Index].Key, Key) = 0) then\r\n Result := FEntries[Index].Value\r\n else if not FReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfWideStrSortedMap.HeadMap(const ToKey: IInterface): IJclIntfWideStrSortedMap;\r\nvar\r\n ToIndex: Integer;\r\n NewMap: TJclIntfWideStrSortedMap;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n NewMap := CreateEmptyContainer as TJclIntfWideStrSortedMap;\r\n ToIndex := BinarySearch(ToKey);\r\n if ToIndex >= 0 then\r\n begin\r\n NewMap.SetCapacity(ToIndex + 1);\r\n NewMap.FSize := ToIndex + 1;\r\n while ToIndex >= 0 do\r\n begin\r\n NewMap.FEntries[ToIndex] := FEntries[ToIndex];\r\n Dec(ToIndex);\r\n end;\r\n end;\r\n Result := NewMap;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfWideStrSortedMap.IsEmpty: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := FSize = 0;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfWideStrSortedMap.KeyOfValue(const Value: WideString): IInterface;\r\nvar\r\n Index: Integer;\r\n Found: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Found := False;\r\n Result := nil;\r\n for Index := 0 to FSize - 1 do\r\n if ValuesCompare(FEntries[Index].Value, Value) = 0 then\r\n begin\r\n Result := FEntries[Index].Key;\r\n Found := True;\r\n Break;\r\n end;\r\n\r\n if (not Found) and (not FReturnDefaultElements) then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfWideStrSortedMap.KeySet: IJclIntfSet;\r\nvar\r\n Index: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := TJclIntfArraySet.Create(FSize);\r\n for Index := 0 to FSize - 1 do\r\n Result.Add(FEntries[Index].Key);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfWideStrSortedMap.LastKey: IInterface;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := nil;\r\n if FSize > 0 then\r\n Result := FEntries[FSize - 1].Key\r\n else\r\n if not FReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfWideStrSortedMap.MapEquals(const AMap: IJclIntfWideStrMap): Boolean;\r\nvar\r\n It: IJclIntfIterator;\r\n Index: Integer;\r\n AKey: IInterface;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if AMap = nil then\r\n Exit;\r\n if FSize <> AMap.Size then\r\n Exit;\r\n It := AMap.KeySet.First;\r\n Index := 0;\r\n while It.HasNext do\r\n begin\r\n if Index >= FSize then\r\n Exit;\r\n AKey := It.Next;\r\n if ValuesCompare(AMap.GetValue(AKey), FEntries[Index].Value) <> 0 then\r\n Exit;\r\n Inc(Index);\r\n end;\r\n Result := True;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclIntfWideStrSortedMap.FinalizeArrayBeforeMove(var List: TJclIntfWideStrSortedMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\nbegin\r\n Assert(Count > 0);\r\n if FromIndex < ToIndex then\r\n begin\r\n if Count > (ToIndex - FromIndex) then\r\n Finalize(List[FromIndex + Count], ToIndex - FromIndex)\r\n else\r\n Finalize(List[ToIndex], Count);\r\n end\r\n else\r\n if FromIndex > ToIndex then\r\n begin\r\n if Count > (FromIndex - ToIndex) then\r\n Count := FromIndex - ToIndex;\r\n Finalize(List[ToIndex], Count)\r\n end;\r\nend;\r\n\r\nprocedure TJclIntfWideStrSortedMap.InitializeArray(var List: TJclIntfWideStrSortedMapEntryArray; FromIndex, Count: SizeInt);\r\nbegin\r\n {$IFDEF FPC}\r\n while Count > 0 do\r\n begin\r\n Initialize(List[FromIndex]);\r\n Inc(FromIndex);\r\n Dec(Count);\r\n end;\r\n {$ELSE ~FPC}\r\n Initialize(List[FromIndex], Count);\r\n {$ENDIF ~FPC}\r\nend;\r\n\r\nprocedure TJclIntfWideStrSortedMap.InitializeArrayAfterMove(var List: TJclIntfWideStrSortedMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\nbegin\r\n { Keep reference counting working }\r\n if FromIndex < ToIndex then\r\n begin\r\n if (ToIndex - FromIndex) < Count then\r\n Count := ToIndex - FromIndex;\r\n InitializeArray(List, FromIndex, Count);\r\n end\r\n else\r\n if FromIndex > ToIndex then\r\n begin\r\n if (FromIndex - ToIndex) < Count then\r\n InitializeArray(List, ToIndex + Count, FromIndex - ToIndex)\r\n else\r\n InitializeArray(List, FromIndex, Count);\r\n end;\r\nend;\r\n\r\nprocedure TJclIntfWideStrSortedMap.MoveArray(var List: TJclIntfWideStrSortedMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\nbegin\r\n if Count > 0 then\r\n begin\r\n FinalizeArrayBeforeMove(List, FromIndex, ToIndex, Count);\r\n Move(List[FromIndex], List[ToIndex], Count * SizeOf(List[0]));\r\n InitializeArrayAfterMove(List, FromIndex, ToIndex, Count);\r\n end;\r\nend;\r\n\r\nprocedure TJclIntfWideStrSortedMap.PutAll(const AMap: IJclIntfWideStrMap);\r\nvar\r\n It: IJclIntfIterator;\r\n Key: IInterface;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if AMap = nil then\r\n Exit;\r\n It := AMap.KeySet.First;\r\n while It.HasNext do\r\n begin\r\n Key := It.Next;\r\n PutValue(Key, AMap.GetValue(Key));\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclIntfWideStrSortedMap.PutValue(const Key: IInterface; const Value: WideString);\r\nvar\r\n Index: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FAllowDefaultElements or ((KeysCompare(Key, nil) <> 0) and (ValuesCompare(Value, '') <> 0)) then\r\n begin\r\n Index := BinarySearch(Key);\r\n\r\n if (Index >= 0) and (KeysCompare(FEntries[Index].Key, Key) = 0) then\r\n begin\r\n FreeValue(FEntries[Index].Value);\r\n FEntries[Index].Value := Value;\r\n end\r\n else\r\n begin\r\n if FSize = FCapacity then\r\n AutoGrow;\r\n if FSize < FCapacity then\r\n begin\r\n Inc(Index);\r\n if (Index < FSize) and (KeysCompare(FEntries[Index].Key, Key) <> 0) then\r\n MoveArray(FEntries, Index, Index + 1, FSize - Index);\r\n FEntries[Index].Key := Key;\r\n FEntries[Index].Value := Value;\r\n Inc(FSize);\r\n end;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfWideStrSortedMap.Remove(const Key: IInterface): WideString;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := Extract(Key);\r\n Result := FreeValue(Result);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclIntfWideStrSortedMap.SetCapacity(Value: Integer);\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FSize <= Value then\r\n begin\r\n SetLength(FEntries, Value);\r\n inherited SetCapacity(Value);\r\n end\r\n else\r\n raise EJclOperationNotSupportedError.Create;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfWideStrSortedMap.Size: Integer;\r\nbegin\r\n Result := FSize;\r\nend;\r\n\r\nfunction TJclIntfWideStrSortedMap.SubMap(const FromKey, ToKey: IInterface): IJclIntfWideStrSortedMap;\r\nvar\r\n FromIndex, ToIndex: Integer;\r\n NewMap: TJclIntfWideStrSortedMap;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n NewMap := CreateEmptyContainer as TJclIntfWideStrSortedMap;\r\n FromIndex := BinarySearch(FromKey);\r\n if (FromIndex = -1) or (KeysCompare(FEntries[FromIndex].Key, FromKey) < 0) then\r\n Inc(FromIndex);\r\n ToIndex := BinarySearch(ToKey);\r\n if (FromIndex >= 0) and (FromIndex <= ToIndex) then\r\n begin\r\n NewMap.SetCapacity(ToIndex - FromIndex + 1);\r\n NewMap.FSize := ToIndex - FromIndex + 1;\r\n while ToIndex >= FromIndex do\r\n begin\r\n NewMap.FEntries[ToIndex - FromIndex] := FEntries[ToIndex];\r\n Dec(ToIndex);\r\n end;\r\n end;\r\n Result := NewMap;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfWideStrSortedMap.TailMap(const FromKey: IInterface): IJclIntfWideStrSortedMap;\r\nvar\r\n FromIndex, Index: Integer;\r\n NewMap: TJclIntfWideStrSortedMap;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n NewMap := CreateEmptyContainer as TJclIntfWideStrSortedMap;\r\n FromIndex := BinarySearch(FromKey);\r\n if (FromIndex = -1) or (KeysCompare(FEntries[FromIndex].Key, FromKey) < 0) then\r\n Inc(FromIndex);\r\n if (FromIndex >= 0) and (FromIndex < FSize) then\r\n begin\r\n NewMap.SetCapacity(FSize - FromIndex);\r\n NewMap.FSize := FSize - FromIndex;\r\n Index := FromIndex;\r\n while Index < FSize do\r\n begin\r\n NewMap.FEntries[Index - FromIndex] := FEntries[Index];\r\n Inc(Index);\r\n end;\r\n end;\r\n Result := NewMap;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfWideStrSortedMap.Values: IJclWideStrCollection;\r\nvar\r\n Index: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := TJclWideStrArrayList.Create(FSize);\r\n for Index := 0 to FSize - 1 do\r\n Result.Add(FEntries[Index].Value);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfWideStrSortedMap.CreateEmptyContainer: TJclAbstractContainerBase;\r\nbegin\r\n Result := TJclIntfWideStrSortedMap.Create(FSize);\r\n AssignPropertiesTo(Result);\r\nend;\r\n\r\nfunction TJclIntfWideStrSortedMap.FreeKey(var Key: IInterface): IInterface;\r\nbegin\r\n Result := Key;\r\n Key := nil;\r\nend;\r\n\r\nfunction TJclIntfWideStrSortedMap.FreeValue(var Value: WideString): WideString;\r\nbegin\r\n Result := Value;\r\n Value := '';\r\nend;\r\n\r\nfunction TJclIntfWideStrSortedMap.KeysCompare(const A, B: IInterface): Integer;\r\nbegin\r\n Result := IntfSimpleCompare(A, B);\r\nend;\r\n\r\nfunction TJclIntfWideStrSortedMap.ValuesCompare(const A, B: WideString): Integer;\r\nbegin\r\n Result := ItemsCompare(A, B);\r\nend;\r\n\r\n//=== { TJclWideStrWideStrSortedMap } ==============================================\r\n\r\nconstructor TJclWideStrWideStrSortedMap.Create(ACapacity: Integer);\r\nbegin\r\n inherited Create();\r\n SetCapacity(ACapacity);\r\nend;\r\n\r\ndestructor TJclWideStrWideStrSortedMap.Destroy;\r\nbegin\r\n FReadOnly := False;\r\n Clear;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJclWideStrWideStrSortedMap.AssignDataTo(Dest: TJclAbstractContainerBase);\r\nvar\r\n MyDest: TJclWideStrWideStrSortedMap;\r\nbegin\r\n inherited AssignDataTo(Dest);\r\n if Dest is TJclWideStrWideStrSortedMap then\r\n begin\r\n MyDest := TJclWideStrWideStrSortedMap(Dest);\r\n MyDest.SetCapacity(FSize);\r\n MyDest.FEntries := FEntries;\r\n MyDest.FSize := FSize;\r\n end;\r\nend;\r\n\r\nfunction TJclWideStrWideStrSortedMap.BinarySearch(const Key: WideString): Integer;\r\nvar\r\n HiPos, LoPos, CompPos: Integer;\r\n Comp: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n LoPos := 0;\r\n HiPos := FSize - 1;\r\n CompPos := (HiPos + LoPos) div 2;\r\n while HiPos >= LoPos do\r\n begin\r\n Comp := KeysCompare(FEntries[CompPos].Key, Key);\r\n if Comp < 0 then\r\n LoPos := CompPos + 1\r\n else\r\n if Comp > 0 then\r\n HiPos := CompPos - 1\r\n else\r\n begin\r\n HiPos := CompPos;\r\n LoPos := CompPos + 1;\r\n end;\r\n CompPos := (HiPos + LoPos) div 2;\r\n end;\r\n Result := HiPos;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclWideStrWideStrSortedMap.Clear;\r\nvar\r\n Index: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n for Index := 0 to FSize - 1 do\r\n begin\r\n FreeKey(FEntries[Index].Key);\r\n FreeValue(FEntries[Index].Value);\r\n end;\r\n FSize := 0;\r\n AutoPack;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclWideStrWideStrSortedMap.ContainsKey(const Key: WideString): Boolean;\r\nvar\r\n Index: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Index := BinarySearch(Key);\r\n Result := (Index >= 0) and (KeysCompare(FEntries[Index].Key, Key) = 0);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclWideStrWideStrSortedMap.ContainsValue(const Value: WideString): Boolean;\r\nvar\r\n Index: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n for Index := 0 to FSize - 1 do\r\n if ValuesCompare(FEntries[Index].Value, Value) = 0 then\r\n begin\r\n Result := True;\r\n Break;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclWideStrWideStrSortedMap.FirstKey: WideString;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := '';\r\n if FSize > 0 then\r\n Result := FEntries[0].Key\r\n else\r\n if not FReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclWideStrWideStrSortedMap.Extract(const Key: WideString): WideString;\r\nvar\r\n Index: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Index := BinarySearch(Key);\r\n if (Index >= 0) and (KeysCompare(FEntries[Index].Key, Key) = 0) then\r\n begin\r\n Result := FEntries[Index].Value;\r\n FEntries[Index].Value := '';\r\n FreeKey(FEntries[Index].Key);\r\n if Index < (FSize - 1) then\r\n MoveArray(FEntries, Index + 1, Index, FSize - Index - 1);\r\n Dec(FSize);\r\n AutoPack;\r\n end\r\n else\r\n Result := '';\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclWideStrWideStrSortedMap.GetValue(const Key: WideString): WideString;\r\nvar\r\n Index: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Index := BinarySearch(Key);\r\n Result := '';\r\n if (Index >= 0) and (KeysCompare(FEntries[Index].Key, Key) = 0) then\r\n Result := FEntries[Index].Value\r\n else if not FReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclWideStrWideStrSortedMap.HeadMap(const ToKey: WideString): IJclWideStrWideStrSortedMap;\r\nvar\r\n ToIndex: Integer;\r\n NewMap: TJclWideStrWideStrSortedMap;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n NewMap := CreateEmptyContainer as TJclWideStrWideStrSortedMap;\r\n ToIndex := BinarySearch(ToKey);\r\n if ToIndex >= 0 then\r\n begin\r\n NewMap.SetCapacity(ToIndex + 1);\r\n NewMap.FSize := ToIndex + 1;\r\n while ToIndex >= 0 do\r\n begin\r\n NewMap.FEntries[ToIndex] := FEntries[ToIndex];\r\n Dec(ToIndex);\r\n end;\r\n end;\r\n Result := NewMap;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclWideStrWideStrSortedMap.IsEmpty: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := FSize = 0;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclWideStrWideStrSortedMap.KeyOfValue(const Value: WideString): WideString;\r\nvar\r\n Index: Integer;\r\n Found: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Found := False;\r\n Result := '';\r\n for Index := 0 to FSize - 1 do\r\n if ValuesCompare(FEntries[Index].Value, Value) = 0 then\r\n begin\r\n Result := FEntries[Index].Key;\r\n Found := True;\r\n Break;\r\n end;\r\n\r\n if (not Found) and (not FReturnDefaultElements) then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclWideStrWideStrSortedMap.KeySet: IJclWideStrSet;\r\nvar\r\n Index: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := TJclWideStrArraySet.Create(FSize);\r\n for Index := 0 to FSize - 1 do\r\n Result.Add(FEntries[Index].Key);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclWideStrWideStrSortedMap.LastKey: WideString;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := '';\r\n if FSize > 0 then\r\n Result := FEntries[FSize - 1].Key\r\n else\r\n if not FReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclWideStrWideStrSortedMap.MapEquals(const AMap: IJclWideStrWideStrMap): Boolean;\r\nvar\r\n It: IJclWideStrIterator;\r\n Index: Integer;\r\n AKey: WideString;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if AMap = nil then\r\n Exit;\r\n if FSize <> AMap.Size then\r\n Exit;\r\n It := AMap.KeySet.First;\r\n Index := 0;\r\n while It.HasNext do\r\n begin\r\n if Index >= FSize then\r\n Exit;\r\n AKey := It.Next;\r\n if ValuesCompare(AMap.GetValue(AKey), FEntries[Index].Value) <> 0 then\r\n Exit;\r\n Inc(Index);\r\n end;\r\n Result := True;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclWideStrWideStrSortedMap.FinalizeArrayBeforeMove(var List: TJclWideStrWideStrSortedMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\nbegin\r\n Assert(Count > 0);\r\n if FromIndex < ToIndex then\r\n begin\r\n if Count > (ToIndex - FromIndex) then\r\n Finalize(List[FromIndex + Count], ToIndex - FromIndex)\r\n else\r\n Finalize(List[ToIndex], Count);\r\n end\r\n else\r\n if FromIndex > ToIndex then\r\n begin\r\n if Count > (FromIndex - ToIndex) then\r\n Count := FromIndex - ToIndex;\r\n Finalize(List[ToIndex], Count)\r\n end;\r\nend;\r\n\r\nprocedure TJclWideStrWideStrSortedMap.InitializeArray(var List: TJclWideStrWideStrSortedMapEntryArray; FromIndex, Count: SizeInt);\r\nbegin\r\n {$IFDEF FPC}\r\n while Count > 0 do\r\n begin\r\n Initialize(List[FromIndex]);\r\n Inc(FromIndex);\r\n Dec(Count);\r\n end;\r\n {$ELSE ~FPC}\r\n Initialize(List[FromIndex], Count);\r\n {$ENDIF ~FPC}\r\nend;\r\n\r\nprocedure TJclWideStrWideStrSortedMap.InitializeArrayAfterMove(var List: TJclWideStrWideStrSortedMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\nbegin\r\n { Keep reference counting working }\r\n if FromIndex < ToIndex then\r\n begin\r\n if (ToIndex - FromIndex) < Count then\r\n Count := ToIndex - FromIndex;\r\n InitializeArray(List, FromIndex, Count);\r\n end\r\n else\r\n if FromIndex > ToIndex then\r\n begin\r\n if (FromIndex - ToIndex) < Count then\r\n InitializeArray(List, ToIndex + Count, FromIndex - ToIndex)\r\n else\r\n InitializeArray(List, FromIndex, Count);\r\n end;\r\nend;\r\n\r\nprocedure TJclWideStrWideStrSortedMap.MoveArray(var List: TJclWideStrWideStrSortedMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\nbegin\r\n if Count > 0 then\r\n begin\r\n FinalizeArrayBeforeMove(List, FromIndex, ToIndex, Count);\r\n Move(List[FromIndex], List[ToIndex], Count * SizeOf(List[0]));\r\n InitializeArrayAfterMove(List, FromIndex, ToIndex, Count);\r\n end;\r\nend;\r\n\r\nprocedure TJclWideStrWideStrSortedMap.PutAll(const AMap: IJclWideStrWideStrMap);\r\nvar\r\n It: IJclWideStrIterator;\r\n Key: WideString;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if AMap = nil then\r\n Exit;\r\n It := AMap.KeySet.First;\r\n while It.HasNext do\r\n begin\r\n Key := It.Next;\r\n PutValue(Key, AMap.GetValue(Key));\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclWideStrWideStrSortedMap.PutValue(const Key: WideString; const Value: WideString);\r\nvar\r\n Index: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FAllowDefaultElements or ((KeysCompare(Key, '') <> 0) and (ValuesCompare(Value, '') <> 0)) then\r\n begin\r\n Index := BinarySearch(Key);\r\n\r\n if (Index >= 0) and (KeysCompare(FEntries[Index].Key, Key) = 0) then\r\n begin\r\n FreeValue(FEntries[Index].Value);\r\n FEntries[Index].Value := Value;\r\n end\r\n else\r\n begin\r\n if FSize = FCapacity then\r\n AutoGrow;\r\n if FSize < FCapacity then\r\n begin\r\n Inc(Index);\r\n if (Index < FSize) and (KeysCompare(FEntries[Index].Key, Key) <> 0) then\r\n MoveArray(FEntries, Index, Index + 1, FSize - Index);\r\n FEntries[Index].Key := Key;\r\n FEntries[Index].Value := Value;\r\n Inc(FSize);\r\n end;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclWideStrWideStrSortedMap.Remove(const Key: WideString): WideString;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := Extract(Key);\r\n Result := FreeValue(Result);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclWideStrWideStrSortedMap.SetCapacity(Value: Integer);\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FSize <= Value then\r\n begin\r\n SetLength(FEntries, Value);\r\n inherited SetCapacity(Value);\r\n end\r\n else\r\n raise EJclOperationNotSupportedError.Create;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclWideStrWideStrSortedMap.Size: Integer;\r\nbegin\r\n Result := FSize;\r\nend;\r\n\r\nfunction TJclWideStrWideStrSortedMap.SubMap(const FromKey, ToKey: WideString): IJclWideStrWideStrSortedMap;\r\nvar\r\n FromIndex, ToIndex: Integer;\r\n NewMap: TJclWideStrWideStrSortedMap;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n NewMap := CreateEmptyContainer as TJclWideStrWideStrSortedMap;\r\n FromIndex := BinarySearch(FromKey);\r\n if (FromIndex = -1) or (KeysCompare(FEntries[FromIndex].Key, FromKey) < 0) then\r\n Inc(FromIndex);\r\n ToIndex := BinarySearch(ToKey);\r\n if (FromIndex >= 0) and (FromIndex <= ToIndex) then\r\n begin\r\n NewMap.SetCapacity(ToIndex - FromIndex + 1);\r\n NewMap.FSize := ToIndex - FromIndex + 1;\r\n while ToIndex >= FromIndex do\r\n begin\r\n NewMap.FEntries[ToIndex - FromIndex] := FEntries[ToIndex];\r\n Dec(ToIndex);\r\n end;\r\n end;\r\n Result := NewMap;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclWideStrWideStrSortedMap.TailMap(const FromKey: WideString): IJclWideStrWideStrSortedMap;\r\nvar\r\n FromIndex, Index: Integer;\r\n NewMap: TJclWideStrWideStrSortedMap;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n NewMap := CreateEmptyContainer as TJclWideStrWideStrSortedMap;\r\n FromIndex := BinarySearch(FromKey);\r\n if (FromIndex = -1) or (KeysCompare(FEntries[FromIndex].Key, FromKey) < 0) then\r\n Inc(FromIndex);\r\n if (FromIndex >= 0) and (FromIndex < FSize) then\r\n begin\r\n NewMap.SetCapacity(FSize - FromIndex);\r\n NewMap.FSize := FSize - FromIndex;\r\n Index := FromIndex;\r\n while Index < FSize do\r\n begin\r\n NewMap.FEntries[Index - FromIndex] := FEntries[Index];\r\n Inc(Index);\r\n end;\r\n end;\r\n Result := NewMap;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclWideStrWideStrSortedMap.Values: IJclWideStrCollection;\r\nvar\r\n Index: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := TJclWideStrArrayList.Create(FSize);\r\n for Index := 0 to FSize - 1 do\r\n Result.Add(FEntries[Index].Value);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclWideStrWideStrSortedMap.CreateEmptyContainer: TJclAbstractContainerBase;\r\nbegin\r\n Result := TJclWideStrWideStrSortedMap.Create(FSize);\r\n AssignPropertiesTo(Result);\r\nend;\r\n\r\nfunction TJclWideStrWideStrSortedMap.FreeKey(var Key: WideString): WideString;\r\nbegin\r\n Result := Key;\r\n Key := '';\r\nend;\r\n\r\nfunction TJclWideStrWideStrSortedMap.FreeValue(var Value: WideString): WideString;\r\nbegin\r\n Result := Value;\r\n Value := '';\r\nend;\r\n\r\nfunction TJclWideStrWideStrSortedMap.KeysCompare(const A, B: WideString): Integer;\r\nbegin\r\n Result := ItemsCompare(A, B);\r\nend;\r\n\r\nfunction TJclWideStrWideStrSortedMap.ValuesCompare(const A, B: WideString): Integer;\r\nbegin\r\n Result := ItemsCompare(A, B);\r\nend;\r\n\r\n{$IFDEF SUPPORTS_UNICODE_STRING}\r\n//=== { TJclUnicodeStrIntfSortedMap } ==============================================\r\n\r\nconstructor TJclUnicodeStrIntfSortedMap.Create(ACapacity: Integer);\r\nbegin\r\n inherited Create();\r\n SetCapacity(ACapacity);\r\nend;\r\n\r\ndestructor TJclUnicodeStrIntfSortedMap.Destroy;\r\nbegin\r\n FReadOnly := False;\r\n Clear;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJclUnicodeStrIntfSortedMap.AssignDataTo(Dest: TJclAbstractContainerBase);\r\nvar\r\n MyDest: TJclUnicodeStrIntfSortedMap;\r\nbegin\r\n inherited AssignDataTo(Dest);\r\n if Dest is TJclUnicodeStrIntfSortedMap then\r\n begin\r\n MyDest := TJclUnicodeStrIntfSortedMap(Dest);\r\n MyDest.SetCapacity(FSize);\r\n MyDest.FEntries := FEntries;\r\n MyDest.FSize := FSize;\r\n end;\r\nend;\r\n\r\nfunction TJclUnicodeStrIntfSortedMap.BinarySearch(const Key: UnicodeString): Integer;\r\nvar\r\n HiPos, LoPos, CompPos: Integer;\r\n Comp: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n LoPos := 0;\r\n HiPos := FSize - 1;\r\n CompPos := (HiPos + LoPos) div 2;\r\n while HiPos >= LoPos do\r\n begin\r\n Comp := KeysCompare(FEntries[CompPos].Key, Key);\r\n if Comp < 0 then\r\n LoPos := CompPos + 1\r\n else\r\n if Comp > 0 then\r\n HiPos := CompPos - 1\r\n else\r\n begin\r\n HiPos := CompPos;\r\n LoPos := CompPos + 1;\r\n end;\r\n CompPos := (HiPos + LoPos) div 2;\r\n end;\r\n Result := HiPos;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclUnicodeStrIntfSortedMap.Clear;\r\nvar\r\n Index: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n for Index := 0 to FSize - 1 do\r\n begin\r\n FreeKey(FEntries[Index].Key);\r\n FreeValue(FEntries[Index].Value);\r\n end;\r\n FSize := 0;\r\n AutoPack;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclUnicodeStrIntfSortedMap.ContainsKey(const Key: UnicodeString): Boolean;\r\nvar\r\n Index: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Index := BinarySearch(Key);\r\n Result := (Index >= 0) and (KeysCompare(FEntries[Index].Key, Key) = 0);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclUnicodeStrIntfSortedMap.ContainsValue(const Value: IInterface): Boolean;\r\nvar\r\n Index: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n for Index := 0 to FSize - 1 do\r\n if ValuesCompare(FEntries[Index].Value, Value) = 0 then\r\n begin\r\n Result := True;\r\n Break;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclUnicodeStrIntfSortedMap.FirstKey: UnicodeString;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := '';\r\n if FSize > 0 then\r\n Result := FEntries[0].Key\r\n else\r\n if not FReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclUnicodeStrIntfSortedMap.Extract(const Key: UnicodeString): IInterface;\r\nvar\r\n Index: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Index := BinarySearch(Key);\r\n if (Index >= 0) and (KeysCompare(FEntries[Index].Key, Key) = 0) then\r\n begin\r\n Result := FEntries[Index].Value;\r\n FEntries[Index].Value := nil;\r\n FreeKey(FEntries[Index].Key);\r\n if Index < (FSize - 1) then\r\n MoveArray(FEntries, Index + 1, Index, FSize - Index - 1);\r\n Dec(FSize);\r\n AutoPack;\r\n end\r\n else\r\n Result := nil;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclUnicodeStrIntfSortedMap.GetValue(const Key: UnicodeString): IInterface;\r\nvar\r\n Index: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Index := BinarySearch(Key);\r\n Result := nil;\r\n if (Index >= 0) and (KeysCompare(FEntries[Index].Key, Key) = 0) then\r\n Result := FEntries[Index].Value\r\n else if not FReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclUnicodeStrIntfSortedMap.HeadMap(const ToKey: UnicodeString): IJclUnicodeStrIntfSortedMap;\r\nvar\r\n ToIndex: Integer;\r\n NewMap: TJclUnicodeStrIntfSortedMap;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n NewMap := CreateEmptyContainer as TJclUnicodeStrIntfSortedMap;\r\n ToIndex := BinarySearch(ToKey);\r\n if ToIndex >= 0 then\r\n begin\r\n NewMap.SetCapacity(ToIndex + 1);\r\n NewMap.FSize := ToIndex + 1;\r\n while ToIndex >= 0 do\r\n begin\r\n NewMap.FEntries[ToIndex] := FEntries[ToIndex];\r\n Dec(ToIndex);\r\n end;\r\n end;\r\n Result := NewMap;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclUnicodeStrIntfSortedMap.IsEmpty: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := FSize = 0;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclUnicodeStrIntfSortedMap.KeyOfValue(const Value: IInterface): UnicodeString;\r\nvar\r\n Index: Integer;\r\n Found: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Found := False;\r\n Result := '';\r\n for Index := 0 to FSize - 1 do\r\n if ValuesCompare(FEntries[Index].Value, Value) = 0 then\r\n begin\r\n Result := FEntries[Index].Key;\r\n Found := True;\r\n Break;\r\n end;\r\n\r\n if (not Found) and (not FReturnDefaultElements) then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclUnicodeStrIntfSortedMap.KeySet: IJclUnicodeStrSet;\r\nvar\r\n Index: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := TJclUnicodeStrArraySet.Create(FSize);\r\n for Index := 0 to FSize - 1 do\r\n Result.Add(FEntries[Index].Key);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclUnicodeStrIntfSortedMap.LastKey: UnicodeString;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := '';\r\n if FSize > 0 then\r\n Result := FEntries[FSize - 1].Key\r\n else\r\n if not FReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclUnicodeStrIntfSortedMap.MapEquals(const AMap: IJclUnicodeStrIntfMap): Boolean;\r\nvar\r\n It: IJclUnicodeStrIterator;\r\n Index: Integer;\r\n AKey: UnicodeString;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if AMap = nil then\r\n Exit;\r\n if FSize <> AMap.Size then\r\n Exit;\r\n It := AMap.KeySet.First;\r\n Index := 0;\r\n while It.HasNext do\r\n begin\r\n if Index >= FSize then\r\n Exit;\r\n AKey := It.Next;\r\n if ValuesCompare(AMap.GetValue(AKey), FEntries[Index].Value) <> 0 then\r\n Exit;\r\n Inc(Index);\r\n end;\r\n Result := True;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclUnicodeStrIntfSortedMap.FinalizeArrayBeforeMove(var List: TJclUnicodeStrIntfSortedMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\nbegin\r\n Assert(Count > 0);\r\n if FromIndex < ToIndex then\r\n begin\r\n if Count > (ToIndex - FromIndex) then\r\n Finalize(List[FromIndex + Count], ToIndex - FromIndex)\r\n else\r\n Finalize(List[ToIndex], Count);\r\n end\r\n else\r\n if FromIndex > ToIndex then\r\n begin\r\n if Count > (FromIndex - ToIndex) then\r\n Count := FromIndex - ToIndex;\r\n Finalize(List[ToIndex], Count)\r\n end;\r\nend;\r\n\r\nprocedure TJclUnicodeStrIntfSortedMap.InitializeArray(var List: TJclUnicodeStrIntfSortedMapEntryArray; FromIndex, Count: SizeInt);\r\nbegin\r\n {$IFDEF FPC}\r\n while Count > 0 do\r\n begin\r\n Initialize(List[FromIndex]);\r\n Inc(FromIndex);\r\n Dec(Count);\r\n end;\r\n {$ELSE ~FPC}\r\n Initialize(List[FromIndex], Count);\r\n {$ENDIF ~FPC}\r\nend;\r\n\r\nprocedure TJclUnicodeStrIntfSortedMap.InitializeArrayAfterMove(var List: TJclUnicodeStrIntfSortedMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\nbegin\r\n { Keep reference counting working }\r\n if FromIndex < ToIndex then\r\n begin\r\n if (ToIndex - FromIndex) < Count then\r\n Count := ToIndex - FromIndex;\r\n InitializeArray(List, FromIndex, Count);\r\n end\r\n else\r\n if FromIndex > ToIndex then\r\n begin\r\n if (FromIndex - ToIndex) < Count then\r\n InitializeArray(List, ToIndex + Count, FromIndex - ToIndex)\r\n else\r\n InitializeArray(List, FromIndex, Count);\r\n end;\r\nend;\r\n\r\nprocedure TJclUnicodeStrIntfSortedMap.MoveArray(var List: TJclUnicodeStrIntfSortedMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\nbegin\r\n if Count > 0 then\r\n begin\r\n FinalizeArrayBeforeMove(List, FromIndex, ToIndex, Count);\r\n Move(List[FromIndex], List[ToIndex], Count * SizeOf(List[0]));\r\n InitializeArrayAfterMove(List, FromIndex, ToIndex, Count);\r\n end;\r\nend;\r\n\r\nprocedure TJclUnicodeStrIntfSortedMap.PutAll(const AMap: IJclUnicodeStrIntfMap);\r\nvar\r\n It: IJclUnicodeStrIterator;\r\n Key: UnicodeString;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if AMap = nil then\r\n Exit;\r\n It := AMap.KeySet.First;\r\n while It.HasNext do\r\n begin\r\n Key := It.Next;\r\n PutValue(Key, AMap.GetValue(Key));\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclUnicodeStrIntfSortedMap.PutValue(const Key: UnicodeString; const Value: IInterface);\r\nvar\r\n Index: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FAllowDefaultElements or ((KeysCompare(Key, '') <> 0) and (ValuesCompare(Value, nil) <> 0)) then\r\n begin\r\n Index := BinarySearch(Key);\r\n\r\n if (Index >= 0) and (KeysCompare(FEntries[Index].Key, Key) = 0) then\r\n begin\r\n FreeValue(FEntries[Index].Value);\r\n FEntries[Index].Value := Value;\r\n end\r\n else\r\n begin\r\n if FSize = FCapacity then\r\n AutoGrow;\r\n if FSize < FCapacity then\r\n begin\r\n Inc(Index);\r\n if (Index < FSize) and (KeysCompare(FEntries[Index].Key, Key) <> 0) then\r\n MoveArray(FEntries, Index, Index + 1, FSize - Index);\r\n FEntries[Index].Key := Key;\r\n FEntries[Index].Value := Value;\r\n Inc(FSize);\r\n end;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclUnicodeStrIntfSortedMap.Remove(const Key: UnicodeString): IInterface;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := Extract(Key);\r\n Result := FreeValue(Result);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclUnicodeStrIntfSortedMap.SetCapacity(Value: Integer);\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FSize <= Value then\r\n begin\r\n SetLength(FEntries, Value);\r\n inherited SetCapacity(Value);\r\n end\r\n else\r\n raise EJclOperationNotSupportedError.Create;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclUnicodeStrIntfSortedMap.Size: Integer;\r\nbegin\r\n Result := FSize;\r\nend;\r\n\r\nfunction TJclUnicodeStrIntfSortedMap.SubMap(const FromKey, ToKey: UnicodeString): IJclUnicodeStrIntfSortedMap;\r\nvar\r\n FromIndex, ToIndex: Integer;\r\n NewMap: TJclUnicodeStrIntfSortedMap;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n NewMap := CreateEmptyContainer as TJclUnicodeStrIntfSortedMap;\r\n FromIndex := BinarySearch(FromKey);\r\n if (FromIndex = -1) or (KeysCompare(FEntries[FromIndex].Key, FromKey) < 0) then\r\n Inc(FromIndex);\r\n ToIndex := BinarySearch(ToKey);\r\n if (FromIndex >= 0) and (FromIndex <= ToIndex) then\r\n begin\r\n NewMap.SetCapacity(ToIndex - FromIndex + 1);\r\n NewMap.FSize := ToIndex - FromIndex + 1;\r\n while ToIndex >= FromIndex do\r\n begin\r\n NewMap.FEntries[ToIndex - FromIndex] := FEntries[ToIndex];\r\n Dec(ToIndex);\r\n end;\r\n end;\r\n Result := NewMap;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclUnicodeStrIntfSortedMap.TailMap(const FromKey: UnicodeString): IJclUnicodeStrIntfSortedMap;\r\nvar\r\n FromIndex, Index: Integer;\r\n NewMap: TJclUnicodeStrIntfSortedMap;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n NewMap := CreateEmptyContainer as TJclUnicodeStrIntfSortedMap;\r\n FromIndex := BinarySearch(FromKey);\r\n if (FromIndex = -1) or (KeysCompare(FEntries[FromIndex].Key, FromKey) < 0) then\r\n Inc(FromIndex);\r\n if (FromIndex >= 0) and (FromIndex < FSize) then\r\n begin\r\n NewMap.SetCapacity(FSize - FromIndex);\r\n NewMap.FSize := FSize - FromIndex;\r\n Index := FromIndex;\r\n while Index < FSize do\r\n begin\r\n NewMap.FEntries[Index - FromIndex] := FEntries[Index];\r\n Inc(Index);\r\n end;\r\n end;\r\n Result := NewMap;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclUnicodeStrIntfSortedMap.Values: IJclIntfCollection;\r\nvar\r\n Index: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := TJclIntfArrayList.Create(FSize);\r\n for Index := 0 to FSize - 1 do\r\n Result.Add(FEntries[Index].Value);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclUnicodeStrIntfSortedMap.CreateEmptyContainer: TJclAbstractContainerBase;\r\nbegin\r\n Result := TJclUnicodeStrIntfSortedMap.Create(FSize);\r\n AssignPropertiesTo(Result);\r\nend;\r\n\r\nfunction TJclUnicodeStrIntfSortedMap.FreeKey(var Key: UnicodeString): UnicodeString;\r\nbegin\r\n Result := Key;\r\n Key := '';\r\nend;\r\n\r\nfunction TJclUnicodeStrIntfSortedMap.FreeValue(var Value: IInterface): IInterface;\r\nbegin\r\n Result := Value;\r\n Value := nil;\r\nend;\r\n\r\nfunction TJclUnicodeStrIntfSortedMap.KeysCompare(const A, B: UnicodeString): Integer;\r\nbegin\r\n Result := ItemsCompare(A, B);\r\nend;\r\n\r\nfunction TJclUnicodeStrIntfSortedMap.ValuesCompare(const A, B: IInterface): Integer;\r\nbegin\r\n Result := IntfSimpleCompare(A, B);\r\nend;\r\n\r\n{$ENDIF SUPPORTS_UNICODE_STRING}\r\n\r\n{$IFDEF SUPPORTS_UNICODE_STRING}\r\n//=== { TJclIntfUnicodeStrSortedMap } ==============================================\r\n\r\nconstructor TJclIntfUnicodeStrSortedMap.Create(ACapacity: Integer);\r\nbegin\r\n inherited Create();\r\n SetCapacity(ACapacity);\r\nend;\r\n\r\ndestructor TJclIntfUnicodeStrSortedMap.Destroy;\r\nbegin\r\n FReadOnly := False;\r\n Clear;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJclIntfUnicodeStrSortedMap.AssignDataTo(Dest: TJclAbstractContainerBase);\r\nvar\r\n MyDest: TJclIntfUnicodeStrSortedMap;\r\nbegin\r\n inherited AssignDataTo(Dest);\r\n if Dest is TJclIntfUnicodeStrSortedMap then\r\n begin\r\n MyDest := TJclIntfUnicodeStrSortedMap(Dest);\r\n MyDest.SetCapacity(FSize);\r\n MyDest.FEntries := FEntries;\r\n MyDest.FSize := FSize;\r\n end;\r\nend;\r\n\r\nfunction TJclIntfUnicodeStrSortedMap.BinarySearch(const Key: IInterface): Integer;\r\nvar\r\n HiPos, LoPos, CompPos: Integer;\r\n Comp: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n LoPos := 0;\r\n HiPos := FSize - 1;\r\n CompPos := (HiPos + LoPos) div 2;\r\n while HiPos >= LoPos do\r\n begin\r\n Comp := KeysCompare(FEntries[CompPos].Key, Key);\r\n if Comp < 0 then\r\n LoPos := CompPos + 1\r\n else\r\n if Comp > 0 then\r\n HiPos := CompPos - 1\r\n else\r\n begin\r\n HiPos := CompPos;\r\n LoPos := CompPos + 1;\r\n end;\r\n CompPos := (HiPos + LoPos) div 2;\r\n end;\r\n Result := HiPos;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclIntfUnicodeStrSortedMap.Clear;\r\nvar\r\n Index: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n for Index := 0 to FSize - 1 do\r\n begin\r\n FreeKey(FEntries[Index].Key);\r\n FreeValue(FEntries[Index].Value);\r\n end;\r\n FSize := 0;\r\n AutoPack;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfUnicodeStrSortedMap.ContainsKey(const Key: IInterface): Boolean;\r\nvar\r\n Index: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Index := BinarySearch(Key);\r\n Result := (Index >= 0) and (KeysCompare(FEntries[Index].Key, Key) = 0);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfUnicodeStrSortedMap.ContainsValue(const Value: UnicodeString): Boolean;\r\nvar\r\n Index: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n for Index := 0 to FSize - 1 do\r\n if ValuesCompare(FEntries[Index].Value, Value) = 0 then\r\n begin\r\n Result := True;\r\n Break;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfUnicodeStrSortedMap.FirstKey: IInterface;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := nil;\r\n if FSize > 0 then\r\n Result := FEntries[0].Key\r\n else\r\n if not FReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfUnicodeStrSortedMap.Extract(const Key: IInterface): UnicodeString;\r\nvar\r\n Index: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Index := BinarySearch(Key);\r\n if (Index >= 0) and (KeysCompare(FEntries[Index].Key, Key) = 0) then\r\n begin\r\n Result := FEntries[Index].Value;\r\n FEntries[Index].Value := '';\r\n FreeKey(FEntries[Index].Key);\r\n if Index < (FSize - 1) then\r\n MoveArray(FEntries, Index + 1, Index, FSize - Index - 1);\r\n Dec(FSize);\r\n AutoPack;\r\n end\r\n else\r\n Result := '';\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfUnicodeStrSortedMap.GetValue(const Key: IInterface): UnicodeString;\r\nvar\r\n Index: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Index := BinarySearch(Key);\r\n Result := '';\r\n if (Index >= 0) and (KeysCompare(FEntries[Index].Key, Key) = 0) then\r\n Result := FEntries[Index].Value\r\n else if not FReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfUnicodeStrSortedMap.HeadMap(const ToKey: IInterface): IJclIntfUnicodeStrSortedMap;\r\nvar\r\n ToIndex: Integer;\r\n NewMap: TJclIntfUnicodeStrSortedMap;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n NewMap := CreateEmptyContainer as TJclIntfUnicodeStrSortedMap;\r\n ToIndex := BinarySearch(ToKey);\r\n if ToIndex >= 0 then\r\n begin\r\n NewMap.SetCapacity(ToIndex + 1);\r\n NewMap.FSize := ToIndex + 1;\r\n while ToIndex >= 0 do\r\n begin\r\n NewMap.FEntries[ToIndex] := FEntries[ToIndex];\r\n Dec(ToIndex);\r\n end;\r\n end;\r\n Result := NewMap;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfUnicodeStrSortedMap.IsEmpty: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := FSize = 0;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfUnicodeStrSortedMap.KeyOfValue(const Value: UnicodeString): IInterface;\r\nvar\r\n Index: Integer;\r\n Found: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Found := False;\r\n Result := nil;\r\n for Index := 0 to FSize - 1 do\r\n if ValuesCompare(FEntries[Index].Value, Value) = 0 then\r\n begin\r\n Result := FEntries[Index].Key;\r\n Found := True;\r\n Break;\r\n end;\r\n\r\n if (not Found) and (not FReturnDefaultElements) then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfUnicodeStrSortedMap.KeySet: IJclIntfSet;\r\nvar\r\n Index: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := TJclIntfArraySet.Create(FSize);\r\n for Index := 0 to FSize - 1 do\r\n Result.Add(FEntries[Index].Key);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfUnicodeStrSortedMap.LastKey: IInterface;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := nil;\r\n if FSize > 0 then\r\n Result := FEntries[FSize - 1].Key\r\n else\r\n if not FReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfUnicodeStrSortedMap.MapEquals(const AMap: IJclIntfUnicodeStrMap): Boolean;\r\nvar\r\n It: IJclIntfIterator;\r\n Index: Integer;\r\n AKey: IInterface;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if AMap = nil then\r\n Exit;\r\n if FSize <> AMap.Size then\r\n Exit;\r\n It := AMap.KeySet.First;\r\n Index := 0;\r\n while It.HasNext do\r\n begin\r\n if Index >= FSize then\r\n Exit;\r\n AKey := It.Next;\r\n if ValuesCompare(AMap.GetValue(AKey), FEntries[Index].Value) <> 0 then\r\n Exit;\r\n Inc(Index);\r\n end;\r\n Result := True;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclIntfUnicodeStrSortedMap.FinalizeArrayBeforeMove(var List: TJclIntfUnicodeStrSortedMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\nbegin\r\n Assert(Count > 0);\r\n if FromIndex < ToIndex then\r\n begin\r\n if Count > (ToIndex - FromIndex) then\r\n Finalize(List[FromIndex + Count], ToIndex - FromIndex)\r\n else\r\n Finalize(List[ToIndex], Count);\r\n end\r\n else\r\n if FromIndex > ToIndex then\r\n begin\r\n if Count > (FromIndex - ToIndex) then\r\n Count := FromIndex - ToIndex;\r\n Finalize(List[ToIndex], Count)\r\n end;\r\nend;\r\n\r\nprocedure TJclIntfUnicodeStrSortedMap.InitializeArray(var List: TJclIntfUnicodeStrSortedMapEntryArray; FromIndex, Count: SizeInt);\r\nbegin\r\n {$IFDEF FPC}\r\n while Count > 0 do\r\n begin\r\n Initialize(List[FromIndex]);\r\n Inc(FromIndex);\r\n Dec(Count);\r\n end;\r\n {$ELSE ~FPC}\r\n Initialize(List[FromIndex], Count);\r\n {$ENDIF ~FPC}\r\nend;\r\n\r\nprocedure TJclIntfUnicodeStrSortedMap.InitializeArrayAfterMove(var List: TJclIntfUnicodeStrSortedMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\nbegin\r\n { Keep reference counting working }\r\n if FromIndex < ToIndex then\r\n begin\r\n if (ToIndex - FromIndex) < Count then\r\n Count := ToIndex - FromIndex;\r\n InitializeArray(List, FromIndex, Count);\r\n end\r\n else\r\n if FromIndex > ToIndex then\r\n begin\r\n if (FromIndex - ToIndex) < Count then\r\n InitializeArray(List, ToIndex + Count, FromIndex - ToIndex)\r\n else\r\n InitializeArray(List, FromIndex, Count);\r\n end;\r\nend;\r\n\r\nprocedure TJclIntfUnicodeStrSortedMap.MoveArray(var List: TJclIntfUnicodeStrSortedMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\nbegin\r\n if Count > 0 then\r\n begin\r\n FinalizeArrayBeforeMove(List, FromIndex, ToIndex, Count);\r\n Move(List[FromIndex], List[ToIndex], Count * SizeOf(List[0]));\r\n InitializeArrayAfterMove(List, FromIndex, ToIndex, Count);\r\n end;\r\nend;\r\n\r\nprocedure TJclIntfUnicodeStrSortedMap.PutAll(const AMap: IJclIntfUnicodeStrMap);\r\nvar\r\n It: IJclIntfIterator;\r\n Key: IInterface;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if AMap = nil then\r\n Exit;\r\n It := AMap.KeySet.First;\r\n while It.HasNext do\r\n begin\r\n Key := It.Next;\r\n PutValue(Key, AMap.GetValue(Key));\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclIntfUnicodeStrSortedMap.PutValue(const Key: IInterface; const Value: UnicodeString);\r\nvar\r\n Index: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FAllowDefaultElements or ((KeysCompare(Key, nil) <> 0) and (ValuesCompare(Value, '') <> 0)) then\r\n begin\r\n Index := BinarySearch(Key);\r\n\r\n if (Index >= 0) and (KeysCompare(FEntries[Index].Key, Key) = 0) then\r\n begin\r\n FreeValue(FEntries[Index].Value);\r\n FEntries[Index].Value := Value;\r\n end\r\n else\r\n begin\r\n if FSize = FCapacity then\r\n AutoGrow;\r\n if FSize < FCapacity then\r\n begin\r\n Inc(Index);\r\n if (Index < FSize) and (KeysCompare(FEntries[Index].Key, Key) <> 0) then\r\n MoveArray(FEntries, Index, Index + 1, FSize - Index);\r\n FEntries[Index].Key := Key;\r\n FEntries[Index].Value := Value;\r\n Inc(FSize);\r\n end;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfUnicodeStrSortedMap.Remove(const Key: IInterface): UnicodeString;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := Extract(Key);\r\n Result := FreeValue(Result);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclIntfUnicodeStrSortedMap.SetCapacity(Value: Integer);\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FSize <= Value then\r\n begin\r\n SetLength(FEntries, Value);\r\n inherited SetCapacity(Value);\r\n end\r\n else\r\n raise EJclOperationNotSupportedError.Create;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfUnicodeStrSortedMap.Size: Integer;\r\nbegin\r\n Result := FSize;\r\nend;\r\n\r\nfunction TJclIntfUnicodeStrSortedMap.SubMap(const FromKey, ToKey: IInterface): IJclIntfUnicodeStrSortedMap;\r\nvar\r\n FromIndex, ToIndex: Integer;\r\n NewMap: TJclIntfUnicodeStrSortedMap;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n NewMap := CreateEmptyContainer as TJclIntfUnicodeStrSortedMap;\r\n FromIndex := BinarySearch(FromKey);\r\n if (FromIndex = -1) or (KeysCompare(FEntries[FromIndex].Key, FromKey) < 0) then\r\n Inc(FromIndex);\r\n ToIndex := BinarySearch(ToKey);\r\n if (FromIndex >= 0) and (FromIndex <= ToIndex) then\r\n begin\r\n NewMap.SetCapacity(ToIndex - FromIndex + 1);\r\n NewMap.FSize := ToIndex - FromIndex + 1;\r\n while ToIndex >= FromIndex do\r\n begin\r\n NewMap.FEntries[ToIndex - FromIndex] := FEntries[ToIndex];\r\n Dec(ToIndex);\r\n end;\r\n end;\r\n Result := NewMap;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfUnicodeStrSortedMap.TailMap(const FromKey: IInterface): IJclIntfUnicodeStrSortedMap;\r\nvar\r\n FromIndex, Index: Integer;\r\n NewMap: TJclIntfUnicodeStrSortedMap;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n NewMap := CreateEmptyContainer as TJclIntfUnicodeStrSortedMap;\r\n FromIndex := BinarySearch(FromKey);\r\n if (FromIndex = -1) or (KeysCompare(FEntries[FromIndex].Key, FromKey) < 0) then\r\n Inc(FromIndex);\r\n if (FromIndex >= 0) and (FromIndex < FSize) then\r\n begin\r\n NewMap.SetCapacity(FSize - FromIndex);\r\n NewMap.FSize := FSize - FromIndex;\r\n Index := FromIndex;\r\n while Index < FSize do\r\n begin\r\n NewMap.FEntries[Index - FromIndex] := FEntries[Index];\r\n Inc(Index);\r\n end;\r\n end;\r\n Result := NewMap;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfUnicodeStrSortedMap.Values: IJclUnicodeStrCollection;\r\nvar\r\n Index: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := TJclUnicodeStrArrayList.Create(FSize);\r\n for Index := 0 to FSize - 1 do\r\n Result.Add(FEntries[Index].Value);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfUnicodeStrSortedMap.CreateEmptyContainer: TJclAbstractContainerBase;\r\nbegin\r\n Result := TJclIntfUnicodeStrSortedMap.Create(FSize);\r\n AssignPropertiesTo(Result);\r\nend;\r\n\r\nfunction TJclIntfUnicodeStrSortedMap.FreeKey(var Key: IInterface): IInterface;\r\nbegin\r\n Result := Key;\r\n Key := nil;\r\nend;\r\n\r\nfunction TJclIntfUnicodeStrSortedMap.FreeValue(var Value: UnicodeString): UnicodeString;\r\nbegin\r\n Result := Value;\r\n Value := '';\r\nend;\r\n\r\nfunction TJclIntfUnicodeStrSortedMap.KeysCompare(const A, B: IInterface): Integer;\r\nbegin\r\n Result := IntfSimpleCompare(A, B);\r\nend;\r\n\r\nfunction TJclIntfUnicodeStrSortedMap.ValuesCompare(const A, B: UnicodeString): Integer;\r\nbegin\r\n Result := ItemsCompare(A, B);\r\nend;\r\n\r\n{$ENDIF SUPPORTS_UNICODE_STRING}\r\n\r\n{$IFDEF SUPPORTS_UNICODE_STRING}\r\n//=== { TJclUnicodeStrUnicodeStrSortedMap } ==============================================\r\n\r\nconstructor TJclUnicodeStrUnicodeStrSortedMap.Create(ACapacity: Integer);\r\nbegin\r\n inherited Create();\r\n SetCapacity(ACapacity);\r\nend;\r\n\r\ndestructor TJclUnicodeStrUnicodeStrSortedMap.Destroy;\r\nbegin\r\n FReadOnly := False;\r\n Clear;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJclUnicodeStrUnicodeStrSortedMap.AssignDataTo(Dest: TJclAbstractContainerBase);\r\nvar\r\n MyDest: TJclUnicodeStrUnicodeStrSortedMap;\r\nbegin\r\n inherited AssignDataTo(Dest);\r\n if Dest is TJclUnicodeStrUnicodeStrSortedMap then\r\n begin\r\n MyDest := TJclUnicodeStrUnicodeStrSortedMap(Dest);\r\n MyDest.SetCapacity(FSize);\r\n MyDest.FEntries := FEntries;\r\n MyDest.FSize := FSize;\r\n end;\r\nend;\r\n\r\nfunction TJclUnicodeStrUnicodeStrSortedMap.BinarySearch(const Key: UnicodeString): Integer;\r\nvar\r\n HiPos, LoPos, CompPos: Integer;\r\n Comp: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n LoPos := 0;\r\n HiPos := FSize - 1;\r\n CompPos := (HiPos + LoPos) div 2;\r\n while HiPos >= LoPos do\r\n begin\r\n Comp := KeysCompare(FEntries[CompPos].Key, Key);\r\n if Comp < 0 then\r\n LoPos := CompPos + 1\r\n else\r\n if Comp > 0 then\r\n HiPos := CompPos - 1\r\n else\r\n begin\r\n HiPos := CompPos;\r\n LoPos := CompPos + 1;\r\n end;\r\n CompPos := (HiPos + LoPos) div 2;\r\n end;\r\n Result := HiPos;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclUnicodeStrUnicodeStrSortedMap.Clear;\r\nvar\r\n Index: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n for Index := 0 to FSize - 1 do\r\n begin\r\n FreeKey(FEntries[Index].Key);\r\n FreeValue(FEntries[Index].Value);\r\n end;\r\n FSize := 0;\r\n AutoPack;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclUnicodeStrUnicodeStrSortedMap.ContainsKey(const Key: UnicodeString): Boolean;\r\nvar\r\n Index: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Index := BinarySearch(Key);\r\n Result := (Index >= 0) and (KeysCompare(FEntries[Index].Key, Key) = 0);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclUnicodeStrUnicodeStrSortedMap.ContainsValue(const Value: UnicodeString): Boolean;\r\nvar\r\n Index: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n for Index := 0 to FSize - 1 do\r\n if ValuesCompare(FEntries[Index].Value, Value) = 0 then\r\n begin\r\n Result := True;\r\n Break;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclUnicodeStrUnicodeStrSortedMap.FirstKey: UnicodeString;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := '';\r\n if FSize > 0 then\r\n Result := FEntries[0].Key\r\n else\r\n if not FReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclUnicodeStrUnicodeStrSortedMap.Extract(const Key: UnicodeString): UnicodeString;\r\nvar\r\n Index: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Index := BinarySearch(Key);\r\n if (Index >= 0) and (KeysCompare(FEntries[Index].Key, Key) = 0) then\r\n begin\r\n Result := FEntries[Index].Value;\r\n FEntries[Index].Value := '';\r\n FreeKey(FEntries[Index].Key);\r\n if Index < (FSize - 1) then\r\n MoveArray(FEntries, Index + 1, Index, FSize - Index - 1);\r\n Dec(FSize);\r\n AutoPack;\r\n end\r\n else\r\n Result := '';\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclUnicodeStrUnicodeStrSortedMap.GetValue(const Key: UnicodeString): UnicodeString;\r\nvar\r\n Index: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Index := BinarySearch(Key);\r\n Result := '';\r\n if (Index >= 0) and (KeysCompare(FEntries[Index].Key, Key) = 0) then\r\n Result := FEntries[Index].Value\r\n else if not FReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclUnicodeStrUnicodeStrSortedMap.HeadMap(const ToKey: UnicodeString): IJclUnicodeStrUnicodeStrSortedMap;\r\nvar\r\n ToIndex: Integer;\r\n NewMap: TJclUnicodeStrUnicodeStrSortedMap;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n NewMap := CreateEmptyContainer as TJclUnicodeStrUnicodeStrSortedMap;\r\n ToIndex := BinarySearch(ToKey);\r\n if ToIndex >= 0 then\r\n begin\r\n NewMap.SetCapacity(ToIndex + 1);\r\n NewMap.FSize := ToIndex + 1;\r\n while ToIndex >= 0 do\r\n begin\r\n NewMap.FEntries[ToIndex] := FEntries[ToIndex];\r\n Dec(ToIndex);\r\n end;\r\n end;\r\n Result := NewMap;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclUnicodeStrUnicodeStrSortedMap.IsEmpty: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := FSize = 0;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclUnicodeStrUnicodeStrSortedMap.KeyOfValue(const Value: UnicodeString): UnicodeString;\r\nvar\r\n Index: Integer;\r\n Found: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Found := False;\r\n Result := '';\r\n for Index := 0 to FSize - 1 do\r\n if ValuesCompare(FEntries[Index].Value, Value) = 0 then\r\n begin\r\n Result := FEntries[Index].Key;\r\n Found := True;\r\n Break;\r\n end;\r\n\r\n if (not Found) and (not FReturnDefaultElements) then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclUnicodeStrUnicodeStrSortedMap.KeySet: IJclUnicodeStrSet;\r\nvar\r\n Index: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := TJclUnicodeStrArraySet.Create(FSize);\r\n for Index := 0 to FSize - 1 do\r\n Result.Add(FEntries[Index].Key);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclUnicodeStrUnicodeStrSortedMap.LastKey: UnicodeString;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := '';\r\n if FSize > 0 then\r\n Result := FEntries[FSize - 1].Key\r\n else\r\n if not FReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclUnicodeStrUnicodeStrSortedMap.MapEquals(const AMap: IJclUnicodeStrUnicodeStrMap): Boolean;\r\nvar\r\n It: IJclUnicodeStrIterator;\r\n Index: Integer;\r\n AKey: UnicodeString;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if AMap = nil then\r\n Exit;\r\n if FSize <> AMap.Size then\r\n Exit;\r\n It := AMap.KeySet.First;\r\n Index := 0;\r\n while It.HasNext do\r\n begin\r\n if Index >= FSize then\r\n Exit;\r\n AKey := It.Next;\r\n if ValuesCompare(AMap.GetValue(AKey), FEntries[Index].Value) <> 0 then\r\n Exit;\r\n Inc(Index);\r\n end;\r\n Result := True;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclUnicodeStrUnicodeStrSortedMap.FinalizeArrayBeforeMove(var List: TJclUnicodeStrUnicodeStrSortedMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\nbegin\r\n Assert(Count > 0);\r\n if FromIndex < ToIndex then\r\n begin\r\n if Count > (ToIndex - FromIndex) then\r\n Finalize(List[FromIndex + Count], ToIndex - FromIndex)\r\n else\r\n Finalize(List[ToIndex], Count);\r\n end\r\n else\r\n if FromIndex > ToIndex then\r\n begin\r\n if Count > (FromIndex - ToIndex) then\r\n Count := FromIndex - ToIndex;\r\n Finalize(List[ToIndex], Count)\r\n end;\r\nend;\r\n\r\nprocedure TJclUnicodeStrUnicodeStrSortedMap.InitializeArray(var List: TJclUnicodeStrUnicodeStrSortedMapEntryArray; FromIndex, Count: SizeInt);\r\nbegin\r\n {$IFDEF FPC}\r\n while Count > 0 do\r\n begin\r\n Initialize(List[FromIndex]);\r\n Inc(FromIndex);\r\n Dec(Count);\r\n end;\r\n {$ELSE ~FPC}\r\n Initialize(List[FromIndex], Count);\r\n {$ENDIF ~FPC}\r\nend;\r\n\r\nprocedure TJclUnicodeStrUnicodeStrSortedMap.InitializeArrayAfterMove(var List: TJclUnicodeStrUnicodeStrSortedMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\nbegin\r\n { Keep reference counting working }\r\n if FromIndex < ToIndex then\r\n begin\r\n if (ToIndex - FromIndex) < Count then\r\n Count := ToIndex - FromIndex;\r\n InitializeArray(List, FromIndex, Count);\r\n end\r\n else\r\n if FromIndex > ToIndex then\r\n begin\r\n if (FromIndex - ToIndex) < Count then\r\n InitializeArray(List, ToIndex + Count, FromIndex - ToIndex)\r\n else\r\n InitializeArray(List, FromIndex, Count);\r\n end;\r\nend;\r\n\r\nprocedure TJclUnicodeStrUnicodeStrSortedMap.MoveArray(var List: TJclUnicodeStrUnicodeStrSortedMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\nbegin\r\n if Count > 0 then\r\n begin\r\n FinalizeArrayBeforeMove(List, FromIndex, ToIndex, Count);\r\n Move(List[FromIndex], List[ToIndex], Count * SizeOf(List[0]));\r\n InitializeArrayAfterMove(List, FromIndex, ToIndex, Count);\r\n end;\r\nend;\r\n\r\nprocedure TJclUnicodeStrUnicodeStrSortedMap.PutAll(const AMap: IJclUnicodeStrUnicodeStrMap);\r\nvar\r\n It: IJclUnicodeStrIterator;\r\n Key: UnicodeString;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if AMap = nil then\r\n Exit;\r\n It := AMap.KeySet.First;\r\n while It.HasNext do\r\n begin\r\n Key := It.Next;\r\n PutValue(Key, AMap.GetValue(Key));\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclUnicodeStrUnicodeStrSortedMap.PutValue(const Key: UnicodeString; const Value: UnicodeString);\r\nvar\r\n Index: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FAllowDefaultElements or ((KeysCompare(Key, '') <> 0) and (ValuesCompare(Value, '') <> 0)) then\r\n begin\r\n Index := BinarySearch(Key);\r\n\r\n if (Index >= 0) and (KeysCompare(FEntries[Index].Key, Key) = 0) then\r\n begin\r\n FreeValue(FEntries[Index].Value);\r\n FEntries[Index].Value := Value;\r\n end\r\n else\r\n begin\r\n if FSize = FCapacity then\r\n AutoGrow;\r\n if FSize < FCapacity then\r\n begin\r\n Inc(Index);\r\n if (Index < FSize) and (KeysCompare(FEntries[Index].Key, Key) <> 0) then\r\n MoveArray(FEntries, Index, Index + 1, FSize - Index);\r\n FEntries[Index].Key := Key;\r\n FEntries[Index].Value := Value;\r\n Inc(FSize);\r\n end;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclUnicodeStrUnicodeStrSortedMap.Remove(const Key: UnicodeString): UnicodeString;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := Extract(Key);\r\n Result := FreeValue(Result);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclUnicodeStrUnicodeStrSortedMap.SetCapacity(Value: Integer);\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FSize <= Value then\r\n begin\r\n SetLength(FEntries, Value);\r\n inherited SetCapacity(Value);\r\n end\r\n else\r\n raise EJclOperationNotSupportedError.Create;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclUnicodeStrUnicodeStrSortedMap.Size: Integer;\r\nbegin\r\n Result := FSize;\r\nend;\r\n\r\nfunction TJclUnicodeStrUnicodeStrSortedMap.SubMap(const FromKey, ToKey: UnicodeString): IJclUnicodeStrUnicodeStrSortedMap;\r\nvar\r\n FromIndex, ToIndex: Integer;\r\n NewMap: TJclUnicodeStrUnicodeStrSortedMap;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n NewMap := CreateEmptyContainer as TJclUnicodeStrUnicodeStrSortedMap;\r\n FromIndex := BinarySearch(FromKey);\r\n if (FromIndex = -1) or (KeysCompare(FEntries[FromIndex].Key, FromKey) < 0) then\r\n Inc(FromIndex);\r\n ToIndex := BinarySearch(ToKey);\r\n if (FromIndex >= 0) and (FromIndex <= ToIndex) then\r\n begin\r\n NewMap.SetCapacity(ToIndex - FromIndex + 1);\r\n NewMap.FSize := ToIndex - FromIndex + 1;\r\n while ToIndex >= FromIndex do\r\n begin\r\n NewMap.FEntries[ToIndex - FromIndex] := FEntries[ToIndex];\r\n Dec(ToIndex);\r\n end;\r\n end;\r\n Result := NewMap;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclUnicodeStrUnicodeStrSortedMap.TailMap(const FromKey: UnicodeString): IJclUnicodeStrUnicodeStrSortedMap;\r\nvar\r\n FromIndex, Index: Integer;\r\n NewMap: TJclUnicodeStrUnicodeStrSortedMap;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n NewMap := CreateEmptyContainer as TJclUnicodeStrUnicodeStrSortedMap;\r\n FromIndex := BinarySearch(FromKey);\r\n if (FromIndex = -1) or (KeysCompare(FEntries[FromIndex].Key, FromKey) < 0) then\r\n Inc(FromIndex);\r\n if (FromIndex >= 0) and (FromIndex < FSize) then\r\n begin\r\n NewMap.SetCapacity(FSize - FromIndex);\r\n NewMap.FSize := FSize - FromIndex;\r\n Index := FromIndex;\r\n while Index < FSize do\r\n begin\r\n NewMap.FEntries[Index - FromIndex] := FEntries[Index];\r\n Inc(Index);\r\n end;\r\n end;\r\n Result := NewMap;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclUnicodeStrUnicodeStrSortedMap.Values: IJclUnicodeStrCollection;\r\nvar\r\n Index: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := TJclUnicodeStrArrayList.Create(FSize);\r\n for Index := 0 to FSize - 1 do\r\n Result.Add(FEntries[Index].Value);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclUnicodeStrUnicodeStrSortedMap.CreateEmptyContainer: TJclAbstractContainerBase;\r\nbegin\r\n Result := TJclUnicodeStrUnicodeStrSortedMap.Create(FSize);\r\n AssignPropertiesTo(Result);\r\nend;\r\n\r\nfunction TJclUnicodeStrUnicodeStrSortedMap.FreeKey(var Key: UnicodeString): UnicodeString;\r\nbegin\r\n Result := Key;\r\n Key := '';\r\nend;\r\n\r\nfunction TJclUnicodeStrUnicodeStrSortedMap.FreeValue(var Value: UnicodeString): UnicodeString;\r\nbegin\r\n Result := Value;\r\n Value := '';\r\nend;\r\n\r\nfunction TJclUnicodeStrUnicodeStrSortedMap.KeysCompare(const A, B: UnicodeString): Integer;\r\nbegin\r\n Result := ItemsCompare(A, B);\r\nend;\r\n\r\nfunction TJclUnicodeStrUnicodeStrSortedMap.ValuesCompare(const A, B: UnicodeString): Integer;\r\nbegin\r\n Result := ItemsCompare(A, B);\r\nend;\r\n\r\n{$ENDIF SUPPORTS_UNICODE_STRING}\r\n\r\n//=== { TJclSingleIntfSortedMap } ==============================================\r\n\r\nconstructor TJclSingleIntfSortedMap.Create(ACapacity: Integer);\r\nbegin\r\n inherited Create();\r\n SetCapacity(ACapacity);\r\nend;\r\n\r\ndestructor TJclSingleIntfSortedMap.Destroy;\r\nbegin\r\n FReadOnly := False;\r\n Clear;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJclSingleIntfSortedMap.AssignDataTo(Dest: TJclAbstractContainerBase);\r\nvar\r\n MyDest: TJclSingleIntfSortedMap;\r\nbegin\r\n inherited AssignDataTo(Dest);\r\n if Dest is TJclSingleIntfSortedMap then\r\n begin\r\n MyDest := TJclSingleIntfSortedMap(Dest);\r\n MyDest.SetCapacity(FSize);\r\n MyDest.FEntries := FEntries;\r\n MyDest.FSize := FSize;\r\n end;\r\nend;\r\n\r\nfunction TJclSingleIntfSortedMap.BinarySearch(const Key: Single): Integer;\r\nvar\r\n HiPos, LoPos, CompPos: Integer;\r\n Comp: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n LoPos := 0;\r\n HiPos := FSize - 1;\r\n CompPos := (HiPos + LoPos) div 2;\r\n while HiPos >= LoPos do\r\n begin\r\n Comp := KeysCompare(FEntries[CompPos].Key, Key);\r\n if Comp < 0 then\r\n LoPos := CompPos + 1\r\n else\r\n if Comp > 0 then\r\n HiPos := CompPos - 1\r\n else\r\n begin\r\n HiPos := CompPos;\r\n LoPos := CompPos + 1;\r\n end;\r\n CompPos := (HiPos + LoPos) div 2;\r\n end;\r\n Result := HiPos;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclSingleIntfSortedMap.Clear;\r\nvar\r\n Index: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n for Index := 0 to FSize - 1 do\r\n begin\r\n FreeKey(FEntries[Index].Key);\r\n FreeValue(FEntries[Index].Value);\r\n end;\r\n FSize := 0;\r\n AutoPack;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSingleIntfSortedMap.ContainsKey(const Key: Single): Boolean;\r\nvar\r\n Index: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Index := BinarySearch(Key);\r\n Result := (Index >= 0) and (KeysCompare(FEntries[Index].Key, Key) = 0);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSingleIntfSortedMap.ContainsValue(const Value: IInterface): Boolean;\r\nvar\r\n Index: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n for Index := 0 to FSize - 1 do\r\n if ValuesCompare(FEntries[Index].Value, Value) = 0 then\r\n begin\r\n Result := True;\r\n Break;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSingleIntfSortedMap.FirstKey: Single;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := 0.0;\r\n if FSize > 0 then\r\n Result := FEntries[0].Key\r\n else\r\n if not FReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSingleIntfSortedMap.Extract(const Key: Single): IInterface;\r\nvar\r\n Index: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Index := BinarySearch(Key);\r\n if (Index >= 0) and (KeysCompare(FEntries[Index].Key, Key) = 0) then\r\n begin\r\n Result := FEntries[Index].Value;\r\n FEntries[Index].Value := nil;\r\n FreeKey(FEntries[Index].Key);\r\n if Index < (FSize - 1) then\r\n MoveArray(FEntries, Index + 1, Index, FSize - Index - 1);\r\n Dec(FSize);\r\n AutoPack;\r\n end\r\n else\r\n Result := nil;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSingleIntfSortedMap.GetValue(const Key: Single): IInterface;\r\nvar\r\n Index: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Index := BinarySearch(Key);\r\n Result := nil;\r\n if (Index >= 0) and (KeysCompare(FEntries[Index].Key, Key) = 0) then\r\n Result := FEntries[Index].Value\r\n else if not FReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSingleIntfSortedMap.HeadMap(const ToKey: Single): IJclSingleIntfSortedMap;\r\nvar\r\n ToIndex: Integer;\r\n NewMap: TJclSingleIntfSortedMap;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n NewMap := CreateEmptyContainer as TJclSingleIntfSortedMap;\r\n ToIndex := BinarySearch(ToKey);\r\n if ToIndex >= 0 then\r\n begin\r\n NewMap.SetCapacity(ToIndex + 1);\r\n NewMap.FSize := ToIndex + 1;\r\n while ToIndex >= 0 do\r\n begin\r\n NewMap.FEntries[ToIndex] := FEntries[ToIndex];\r\n Dec(ToIndex);\r\n end;\r\n end;\r\n Result := NewMap;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSingleIntfSortedMap.IsEmpty: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := FSize = 0;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSingleIntfSortedMap.KeyOfValue(const Value: IInterface): Single;\r\nvar\r\n Index: Integer;\r\n Found: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Found := False;\r\n Result := 0.0;\r\n for Index := 0 to FSize - 1 do\r\n if ValuesCompare(FEntries[Index].Value, Value) = 0 then\r\n begin\r\n Result := FEntries[Index].Key;\r\n Found := True;\r\n Break;\r\n end;\r\n\r\n if (not Found) and (not FReturnDefaultElements) then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSingleIntfSortedMap.KeySet: IJclSingleSet;\r\nvar\r\n Index: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := TJclSingleArraySet.Create(FSize);\r\n for Index := 0 to FSize - 1 do\r\n Result.Add(FEntries[Index].Key);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSingleIntfSortedMap.LastKey: Single;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := 0.0;\r\n if FSize > 0 then\r\n Result := FEntries[FSize - 1].Key\r\n else\r\n if not FReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSingleIntfSortedMap.MapEquals(const AMap: IJclSingleIntfMap): Boolean;\r\nvar\r\n It: IJclSingleIterator;\r\n Index: Integer;\r\n AKey: Single;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if AMap = nil then\r\n Exit;\r\n if FSize <> AMap.Size then\r\n Exit;\r\n It := AMap.KeySet.First;\r\n Index := 0;\r\n while It.HasNext do\r\n begin\r\n if Index >= FSize then\r\n Exit;\r\n AKey := It.Next;\r\n if ValuesCompare(AMap.GetValue(AKey), FEntries[Index].Value) <> 0 then\r\n Exit;\r\n Inc(Index);\r\n end;\r\n Result := True;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclSingleIntfSortedMap.FinalizeArrayBeforeMove(var List: TJclSingleIntfSortedMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\nbegin\r\n Assert(Count > 0);\r\n if FromIndex < ToIndex then\r\n begin\r\n if Count > (ToIndex - FromIndex) then\r\n Finalize(List[FromIndex + Count], ToIndex - FromIndex)\r\n else\r\n Finalize(List[ToIndex], Count);\r\n end\r\n else\r\n if FromIndex > ToIndex then\r\n begin\r\n if Count > (FromIndex - ToIndex) then\r\n Count := FromIndex - ToIndex;\r\n Finalize(List[ToIndex], Count)\r\n end;\r\nend;\r\n\r\nprocedure TJclSingleIntfSortedMap.InitializeArray(var List: TJclSingleIntfSortedMapEntryArray; FromIndex, Count: SizeInt);\r\nbegin\r\n {$IFDEF FPC}\r\n while Count > 0 do\r\n begin\r\n Initialize(List[FromIndex]);\r\n Inc(FromIndex);\r\n Dec(Count);\r\n end;\r\n {$ELSE ~FPC}\r\n Initialize(List[FromIndex], Count);\r\n {$ENDIF ~FPC}\r\nend;\r\n\r\nprocedure TJclSingleIntfSortedMap.InitializeArrayAfterMove(var List: TJclSingleIntfSortedMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\nbegin\r\n { Keep reference counting working }\r\n if FromIndex < ToIndex then\r\n begin\r\n if (ToIndex - FromIndex) < Count then\r\n Count := ToIndex - FromIndex;\r\n InitializeArray(List, FromIndex, Count);\r\n end\r\n else\r\n if FromIndex > ToIndex then\r\n begin\r\n if (FromIndex - ToIndex) < Count then\r\n InitializeArray(List, ToIndex + Count, FromIndex - ToIndex)\r\n else\r\n InitializeArray(List, FromIndex, Count);\r\n end;\r\nend;\r\n\r\nprocedure TJclSingleIntfSortedMap.MoveArray(var List: TJclSingleIntfSortedMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\nbegin\r\n if Count > 0 then\r\n begin\r\n FinalizeArrayBeforeMove(List, FromIndex, ToIndex, Count);\r\n Move(List[FromIndex], List[ToIndex], Count * SizeOf(List[0]));\r\n InitializeArrayAfterMove(List, FromIndex, ToIndex, Count);\r\n end;\r\nend;\r\n\r\nprocedure TJclSingleIntfSortedMap.PutAll(const AMap: IJclSingleIntfMap);\r\nvar\r\n It: IJclSingleIterator;\r\n Key: Single;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if AMap = nil then\r\n Exit;\r\n It := AMap.KeySet.First;\r\n while It.HasNext do\r\n begin\r\n Key := It.Next;\r\n PutValue(Key, AMap.GetValue(Key));\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclSingleIntfSortedMap.PutValue(const Key: Single; const Value: IInterface);\r\nvar\r\n Index: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FAllowDefaultElements or ((KeysCompare(Key, 0.0) <> 0) and (ValuesCompare(Value, nil) <> 0)) then\r\n begin\r\n Index := BinarySearch(Key);\r\n\r\n if (Index >= 0) and (KeysCompare(FEntries[Index].Key, Key) = 0) then\r\n begin\r\n FreeValue(FEntries[Index].Value);\r\n FEntries[Index].Value := Value;\r\n end\r\n else\r\n begin\r\n if FSize = FCapacity then\r\n AutoGrow;\r\n if FSize < FCapacity then\r\n begin\r\n Inc(Index);\r\n if (Index < FSize) and (KeysCompare(FEntries[Index].Key, Key) <> 0) then\r\n MoveArray(FEntries, Index, Index + 1, FSize - Index);\r\n FEntries[Index].Key := Key;\r\n FEntries[Index].Value := Value;\r\n Inc(FSize);\r\n end;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSingleIntfSortedMap.Remove(const Key: Single): IInterface;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := Extract(Key);\r\n Result := FreeValue(Result);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclSingleIntfSortedMap.SetCapacity(Value: Integer);\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FSize <= Value then\r\n begin\r\n SetLength(FEntries, Value);\r\n inherited SetCapacity(Value);\r\n end\r\n else\r\n raise EJclOperationNotSupportedError.Create;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSingleIntfSortedMap.Size: Integer;\r\nbegin\r\n Result := FSize;\r\nend;\r\n\r\nfunction TJclSingleIntfSortedMap.SubMap(const FromKey, ToKey: Single): IJclSingleIntfSortedMap;\r\nvar\r\n FromIndex, ToIndex: Integer;\r\n NewMap: TJclSingleIntfSortedMap;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n NewMap := CreateEmptyContainer as TJclSingleIntfSortedMap;\r\n FromIndex := BinarySearch(FromKey);\r\n if (FromIndex = -1) or (KeysCompare(FEntries[FromIndex].Key, FromKey) < 0) then\r\n Inc(FromIndex);\r\n ToIndex := BinarySearch(ToKey);\r\n if (FromIndex >= 0) and (FromIndex <= ToIndex) then\r\n begin\r\n NewMap.SetCapacity(ToIndex - FromIndex + 1);\r\n NewMap.FSize := ToIndex - FromIndex + 1;\r\n while ToIndex >= FromIndex do\r\n begin\r\n NewMap.FEntries[ToIndex - FromIndex] := FEntries[ToIndex];\r\n Dec(ToIndex);\r\n end;\r\n end;\r\n Result := NewMap;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSingleIntfSortedMap.TailMap(const FromKey: Single): IJclSingleIntfSortedMap;\r\nvar\r\n FromIndex, Index: Integer;\r\n NewMap: TJclSingleIntfSortedMap;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n NewMap := CreateEmptyContainer as TJclSingleIntfSortedMap;\r\n FromIndex := BinarySearch(FromKey);\r\n if (FromIndex = -1) or (KeysCompare(FEntries[FromIndex].Key, FromKey) < 0) then\r\n Inc(FromIndex);\r\n if (FromIndex >= 0) and (FromIndex < FSize) then\r\n begin\r\n NewMap.SetCapacity(FSize - FromIndex);\r\n NewMap.FSize := FSize - FromIndex;\r\n Index := FromIndex;\r\n while Index < FSize do\r\n begin\r\n NewMap.FEntries[Index - FromIndex] := FEntries[Index];\r\n Inc(Index);\r\n end;\r\n end;\r\n Result := NewMap;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSingleIntfSortedMap.Values: IJclIntfCollection;\r\nvar\r\n Index: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := TJclIntfArrayList.Create(FSize);\r\n for Index := 0 to FSize - 1 do\r\n Result.Add(FEntries[Index].Value);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSingleIntfSortedMap.CreateEmptyContainer: TJclAbstractContainerBase;\r\nbegin\r\n Result := TJclSingleIntfSortedMap.Create(FSize);\r\n AssignPropertiesTo(Result);\r\nend;\r\n\r\nfunction TJclSingleIntfSortedMap.FreeKey(var Key: Single): Single;\r\nbegin\r\n Result := Key;\r\n Key := 0.0;\r\nend;\r\n\r\nfunction TJclSingleIntfSortedMap.FreeValue(var Value: IInterface): IInterface;\r\nbegin\r\n Result := Value;\r\n Value := nil;\r\nend;\r\n\r\nfunction TJclSingleIntfSortedMap.KeysCompare(const A, B: Single): Integer;\r\nbegin\r\n Result := ItemsCompare(A, B);\r\nend;\r\n\r\nfunction TJclSingleIntfSortedMap.ValuesCompare(const A, B: IInterface): Integer;\r\nbegin\r\n Result := IntfSimpleCompare(A, B);\r\nend;\r\n\r\n//=== { TJclIntfSingleSortedMap } ==============================================\r\n\r\nconstructor TJclIntfSingleSortedMap.Create(ACapacity: Integer);\r\nbegin\r\n inherited Create();\r\n SetCapacity(ACapacity);\r\nend;\r\n\r\ndestructor TJclIntfSingleSortedMap.Destroy;\r\nbegin\r\n FReadOnly := False;\r\n Clear;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJclIntfSingleSortedMap.AssignDataTo(Dest: TJclAbstractContainerBase);\r\nvar\r\n MyDest: TJclIntfSingleSortedMap;\r\nbegin\r\n inherited AssignDataTo(Dest);\r\n if Dest is TJclIntfSingleSortedMap then\r\n begin\r\n MyDest := TJclIntfSingleSortedMap(Dest);\r\n MyDest.SetCapacity(FSize);\r\n MyDest.FEntries := FEntries;\r\n MyDest.FSize := FSize;\r\n end;\r\nend;\r\n\r\nfunction TJclIntfSingleSortedMap.BinarySearch(const Key: IInterface): Integer;\r\nvar\r\n HiPos, LoPos, CompPos: Integer;\r\n Comp: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n LoPos := 0;\r\n HiPos := FSize - 1;\r\n CompPos := (HiPos + LoPos) div 2;\r\n while HiPos >= LoPos do\r\n begin\r\n Comp := KeysCompare(FEntries[CompPos].Key, Key);\r\n if Comp < 0 then\r\n LoPos := CompPos + 1\r\n else\r\n if Comp > 0 then\r\n HiPos := CompPos - 1\r\n else\r\n begin\r\n HiPos := CompPos;\r\n LoPos := CompPos + 1;\r\n end;\r\n CompPos := (HiPos + LoPos) div 2;\r\n end;\r\n Result := HiPos;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclIntfSingleSortedMap.Clear;\r\nvar\r\n Index: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n for Index := 0 to FSize - 1 do\r\n begin\r\n FreeKey(FEntries[Index].Key);\r\n FreeValue(FEntries[Index].Value);\r\n end;\r\n FSize := 0;\r\n AutoPack;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfSingleSortedMap.ContainsKey(const Key: IInterface): Boolean;\r\nvar\r\n Index: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Index := BinarySearch(Key);\r\n Result := (Index >= 0) and (KeysCompare(FEntries[Index].Key, Key) = 0);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfSingleSortedMap.ContainsValue(const Value: Single): Boolean;\r\nvar\r\n Index: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n for Index := 0 to FSize - 1 do\r\n if ValuesCompare(FEntries[Index].Value, Value) = 0 then\r\n begin\r\n Result := True;\r\n Break;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfSingleSortedMap.FirstKey: IInterface;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := nil;\r\n if FSize > 0 then\r\n Result := FEntries[0].Key\r\n else\r\n if not FReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfSingleSortedMap.Extract(const Key: IInterface): Single;\r\nvar\r\n Index: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Index := BinarySearch(Key);\r\n if (Index >= 0) and (KeysCompare(FEntries[Index].Key, Key) = 0) then\r\n begin\r\n Result := FEntries[Index].Value;\r\n FEntries[Index].Value := 0.0;\r\n FreeKey(FEntries[Index].Key);\r\n if Index < (FSize - 1) then\r\n MoveArray(FEntries, Index + 1, Index, FSize - Index - 1);\r\n Dec(FSize);\r\n AutoPack;\r\n end\r\n else\r\n Result := 0.0;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfSingleSortedMap.GetValue(const Key: IInterface): Single;\r\nvar\r\n Index: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Index := BinarySearch(Key);\r\n Result := 0.0;\r\n if (Index >= 0) and (KeysCompare(FEntries[Index].Key, Key) = 0) then\r\n Result := FEntries[Index].Value\r\n else if not FReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfSingleSortedMap.HeadMap(const ToKey: IInterface): IJclIntfSingleSortedMap;\r\nvar\r\n ToIndex: Integer;\r\n NewMap: TJclIntfSingleSortedMap;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n NewMap := CreateEmptyContainer as TJclIntfSingleSortedMap;\r\n ToIndex := BinarySearch(ToKey);\r\n if ToIndex >= 0 then\r\n begin\r\n NewMap.SetCapacity(ToIndex + 1);\r\n NewMap.FSize := ToIndex + 1;\r\n while ToIndex >= 0 do\r\n begin\r\n NewMap.FEntries[ToIndex] := FEntries[ToIndex];\r\n Dec(ToIndex);\r\n end;\r\n end;\r\n Result := NewMap;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfSingleSortedMap.IsEmpty: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := FSize = 0;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfSingleSortedMap.KeyOfValue(const Value: Single): IInterface;\r\nvar\r\n Index: Integer;\r\n Found: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Found := False;\r\n Result := nil;\r\n for Index := 0 to FSize - 1 do\r\n if ValuesCompare(FEntries[Index].Value, Value) = 0 then\r\n begin\r\n Result := FEntries[Index].Key;\r\n Found := True;\r\n Break;\r\n end;\r\n\r\n if (not Found) and (not FReturnDefaultElements) then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfSingleSortedMap.KeySet: IJclIntfSet;\r\nvar\r\n Index: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := TJclIntfArraySet.Create(FSize);\r\n for Index := 0 to FSize - 1 do\r\n Result.Add(FEntries[Index].Key);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfSingleSortedMap.LastKey: IInterface;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := nil;\r\n if FSize > 0 then\r\n Result := FEntries[FSize - 1].Key\r\n else\r\n if not FReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfSingleSortedMap.MapEquals(const AMap: IJclIntfSingleMap): Boolean;\r\nvar\r\n It: IJclIntfIterator;\r\n Index: Integer;\r\n AKey: IInterface;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if AMap = nil then\r\n Exit;\r\n if FSize <> AMap.Size then\r\n Exit;\r\n It := AMap.KeySet.First;\r\n Index := 0;\r\n while It.HasNext do\r\n begin\r\n if Index >= FSize then\r\n Exit;\r\n AKey := It.Next;\r\n if ValuesCompare(AMap.GetValue(AKey), FEntries[Index].Value) <> 0 then\r\n Exit;\r\n Inc(Index);\r\n end;\r\n Result := True;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclIntfSingleSortedMap.FinalizeArrayBeforeMove(var List: TJclIntfSingleSortedMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\nbegin\r\n Assert(Count > 0);\r\n if FromIndex < ToIndex then\r\n begin\r\n if Count > (ToIndex - FromIndex) then\r\n Finalize(List[FromIndex + Count], ToIndex - FromIndex)\r\n else\r\n Finalize(List[ToIndex], Count);\r\n end\r\n else\r\n if FromIndex > ToIndex then\r\n begin\r\n if Count > (FromIndex - ToIndex) then\r\n Count := FromIndex - ToIndex;\r\n Finalize(List[ToIndex], Count)\r\n end;\r\nend;\r\n\r\nprocedure TJclIntfSingleSortedMap.InitializeArray(var List: TJclIntfSingleSortedMapEntryArray; FromIndex, Count: SizeInt);\r\nbegin\r\n {$IFDEF FPC}\r\n while Count > 0 do\r\n begin\r\n Initialize(List[FromIndex]);\r\n Inc(FromIndex);\r\n Dec(Count);\r\n end;\r\n {$ELSE ~FPC}\r\n Initialize(List[FromIndex], Count);\r\n {$ENDIF ~FPC}\r\nend;\r\n\r\nprocedure TJclIntfSingleSortedMap.InitializeArrayAfterMove(var List: TJclIntfSingleSortedMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\nbegin\r\n { Keep reference counting working }\r\n if FromIndex < ToIndex then\r\n begin\r\n if (ToIndex - FromIndex) < Count then\r\n Count := ToIndex - FromIndex;\r\n InitializeArray(List, FromIndex, Count);\r\n end\r\n else\r\n if FromIndex > ToIndex then\r\n begin\r\n if (FromIndex - ToIndex) < Count then\r\n InitializeArray(List, ToIndex + Count, FromIndex - ToIndex)\r\n else\r\n InitializeArray(List, FromIndex, Count);\r\n end;\r\nend;\r\n\r\nprocedure TJclIntfSingleSortedMap.MoveArray(var List: TJclIntfSingleSortedMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\nbegin\r\n if Count > 0 then\r\n begin\r\n FinalizeArrayBeforeMove(List, FromIndex, ToIndex, Count);\r\n Move(List[FromIndex], List[ToIndex], Count * SizeOf(List[0]));\r\n InitializeArrayAfterMove(List, FromIndex, ToIndex, Count);\r\n end;\r\nend;\r\n\r\nprocedure TJclIntfSingleSortedMap.PutAll(const AMap: IJclIntfSingleMap);\r\nvar\r\n It: IJclIntfIterator;\r\n Key: IInterface;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if AMap = nil then\r\n Exit;\r\n It := AMap.KeySet.First;\r\n while It.HasNext do\r\n begin\r\n Key := It.Next;\r\n PutValue(Key, AMap.GetValue(Key));\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclIntfSingleSortedMap.PutValue(const Key: IInterface; const Value: Single);\r\nvar\r\n Index: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FAllowDefaultElements or ((KeysCompare(Key, nil) <> 0) and (ValuesCompare(Value, 0.0) <> 0)) then\r\n begin\r\n Index := BinarySearch(Key);\r\n\r\n if (Index >= 0) and (KeysCompare(FEntries[Index].Key, Key) = 0) then\r\n begin\r\n FreeValue(FEntries[Index].Value);\r\n FEntries[Index].Value := Value;\r\n end\r\n else\r\n begin\r\n if FSize = FCapacity then\r\n AutoGrow;\r\n if FSize < FCapacity then\r\n begin\r\n Inc(Index);\r\n if (Index < FSize) and (KeysCompare(FEntries[Index].Key, Key) <> 0) then\r\n MoveArray(FEntries, Index, Index + 1, FSize - Index);\r\n FEntries[Index].Key := Key;\r\n FEntries[Index].Value := Value;\r\n Inc(FSize);\r\n end;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfSingleSortedMap.Remove(const Key: IInterface): Single;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := Extract(Key);\r\n Result := FreeValue(Result);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclIntfSingleSortedMap.SetCapacity(Value: Integer);\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FSize <= Value then\r\n begin\r\n SetLength(FEntries, Value);\r\n inherited SetCapacity(Value);\r\n end\r\n else\r\n raise EJclOperationNotSupportedError.Create;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfSingleSortedMap.Size: Integer;\r\nbegin\r\n Result := FSize;\r\nend;\r\n\r\nfunction TJclIntfSingleSortedMap.SubMap(const FromKey, ToKey: IInterface): IJclIntfSingleSortedMap;\r\nvar\r\n FromIndex, ToIndex: Integer;\r\n NewMap: TJclIntfSingleSortedMap;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n NewMap := CreateEmptyContainer as TJclIntfSingleSortedMap;\r\n FromIndex := BinarySearch(FromKey);\r\n if (FromIndex = -1) or (KeysCompare(FEntries[FromIndex].Key, FromKey) < 0) then\r\n Inc(FromIndex);\r\n ToIndex := BinarySearch(ToKey);\r\n if (FromIndex >= 0) and (FromIndex <= ToIndex) then\r\n begin\r\n NewMap.SetCapacity(ToIndex - FromIndex + 1);\r\n NewMap.FSize := ToIndex - FromIndex + 1;\r\n while ToIndex >= FromIndex do\r\n begin\r\n NewMap.FEntries[ToIndex - FromIndex] := FEntries[ToIndex];\r\n Dec(ToIndex);\r\n end;\r\n end;\r\n Result := NewMap;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfSingleSortedMap.TailMap(const FromKey: IInterface): IJclIntfSingleSortedMap;\r\nvar\r\n FromIndex, Index: Integer;\r\n NewMap: TJclIntfSingleSortedMap;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n NewMap := CreateEmptyContainer as TJclIntfSingleSortedMap;\r\n FromIndex := BinarySearch(FromKey);\r\n if (FromIndex = -1) or (KeysCompare(FEntries[FromIndex].Key, FromKey) < 0) then\r\n Inc(FromIndex);\r\n if (FromIndex >= 0) and (FromIndex < FSize) then\r\n begin\r\n NewMap.SetCapacity(FSize - FromIndex);\r\n NewMap.FSize := FSize - FromIndex;\r\n Index := FromIndex;\r\n while Index < FSize do\r\n begin\r\n NewMap.FEntries[Index - FromIndex] := FEntries[Index];\r\n Inc(Index);\r\n end;\r\n end;\r\n Result := NewMap;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfSingleSortedMap.Values: IJclSingleCollection;\r\nvar\r\n Index: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := TJclSingleArrayList.Create(FSize);\r\n for Index := 0 to FSize - 1 do\r\n Result.Add(FEntries[Index].Value);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfSingleSortedMap.CreateEmptyContainer: TJclAbstractContainerBase;\r\nbegin\r\n Result := TJclIntfSingleSortedMap.Create(FSize);\r\n AssignPropertiesTo(Result);\r\nend;\r\n\r\nfunction TJclIntfSingleSortedMap.FreeKey(var Key: IInterface): IInterface;\r\nbegin\r\n Result := Key;\r\n Key := nil;\r\nend;\r\n\r\nfunction TJclIntfSingleSortedMap.FreeValue(var Value: Single): Single;\r\nbegin\r\n Result := Value;\r\n Value := 0.0;\r\nend;\r\n\r\nfunction TJclIntfSingleSortedMap.KeysCompare(const A, B: IInterface): Integer;\r\nbegin\r\n Result := IntfSimpleCompare(A, B);\r\nend;\r\n\r\nfunction TJclIntfSingleSortedMap.ValuesCompare(const A, B: Single): Integer;\r\nbegin\r\n Result := ItemsCompare(A, B);\r\nend;\r\n\r\n//=== { TJclSingleSingleSortedMap } ==============================================\r\n\r\nconstructor TJclSingleSingleSortedMap.Create(ACapacity: Integer);\r\nbegin\r\n inherited Create();\r\n SetCapacity(ACapacity);\r\nend;\r\n\r\ndestructor TJclSingleSingleSortedMap.Destroy;\r\nbegin\r\n FReadOnly := False;\r\n Clear;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJclSingleSingleSortedMap.AssignDataTo(Dest: TJclAbstractContainerBase);\r\nvar\r\n MyDest: TJclSingleSingleSortedMap;\r\nbegin\r\n inherited AssignDataTo(Dest);\r\n if Dest is TJclSingleSingleSortedMap then\r\n begin\r\n MyDest := TJclSingleSingleSortedMap(Dest);\r\n MyDest.SetCapacity(FSize);\r\n MyDest.FEntries := FEntries;\r\n MyDest.FSize := FSize;\r\n end;\r\nend;\r\n\r\nfunction TJclSingleSingleSortedMap.BinarySearch(const Key: Single): Integer;\r\nvar\r\n HiPos, LoPos, CompPos: Integer;\r\n Comp: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n LoPos := 0;\r\n HiPos := FSize - 1;\r\n CompPos := (HiPos + LoPos) div 2;\r\n while HiPos >= LoPos do\r\n begin\r\n Comp := KeysCompare(FEntries[CompPos].Key, Key);\r\n if Comp < 0 then\r\n LoPos := CompPos + 1\r\n else\r\n if Comp > 0 then\r\n HiPos := CompPos - 1\r\n else\r\n begin\r\n HiPos := CompPos;\r\n LoPos := CompPos + 1;\r\n end;\r\n CompPos := (HiPos + LoPos) div 2;\r\n end;\r\n Result := HiPos;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclSingleSingleSortedMap.Clear;\r\nvar\r\n Index: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n for Index := 0 to FSize - 1 do\r\n begin\r\n FreeKey(FEntries[Index].Key);\r\n FreeValue(FEntries[Index].Value);\r\n end;\r\n FSize := 0;\r\n AutoPack;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSingleSingleSortedMap.ContainsKey(const Key: Single): Boolean;\r\nvar\r\n Index: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Index := BinarySearch(Key);\r\n Result := (Index >= 0) and (KeysCompare(FEntries[Index].Key, Key) = 0);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSingleSingleSortedMap.ContainsValue(const Value: Single): Boolean;\r\nvar\r\n Index: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n for Index := 0 to FSize - 1 do\r\n if ValuesCompare(FEntries[Index].Value, Value) = 0 then\r\n begin\r\n Result := True;\r\n Break;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSingleSingleSortedMap.FirstKey: Single;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := 0.0;\r\n if FSize > 0 then\r\n Result := FEntries[0].Key\r\n else\r\n if not FReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSingleSingleSortedMap.Extract(const Key: Single): Single;\r\nvar\r\n Index: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Index := BinarySearch(Key);\r\n if (Index >= 0) and (KeysCompare(FEntries[Index].Key, Key) = 0) then\r\n begin\r\n Result := FEntries[Index].Value;\r\n FEntries[Index].Value := 0.0;\r\n FreeKey(FEntries[Index].Key);\r\n if Index < (FSize - 1) then\r\n MoveArray(FEntries, Index + 1, Index, FSize - Index - 1);\r\n Dec(FSize);\r\n AutoPack;\r\n end\r\n else\r\n Result := 0.0;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSingleSingleSortedMap.GetValue(const Key: Single): Single;\r\nvar\r\n Index: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Index := BinarySearch(Key);\r\n Result := 0.0;\r\n if (Index >= 0) and (KeysCompare(FEntries[Index].Key, Key) = 0) then\r\n Result := FEntries[Index].Value\r\n else if not FReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSingleSingleSortedMap.HeadMap(const ToKey: Single): IJclSingleSingleSortedMap;\r\nvar\r\n ToIndex: Integer;\r\n NewMap: TJclSingleSingleSortedMap;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n NewMap := CreateEmptyContainer as TJclSingleSingleSortedMap;\r\n ToIndex := BinarySearch(ToKey);\r\n if ToIndex >= 0 then\r\n begin\r\n NewMap.SetCapacity(ToIndex + 1);\r\n NewMap.FSize := ToIndex + 1;\r\n while ToIndex >= 0 do\r\n begin\r\n NewMap.FEntries[ToIndex] := FEntries[ToIndex];\r\n Dec(ToIndex);\r\n end;\r\n end;\r\n Result := NewMap;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSingleSingleSortedMap.IsEmpty: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := FSize = 0;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSingleSingleSortedMap.KeyOfValue(const Value: Single): Single;\r\nvar\r\n Index: Integer;\r\n Found: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Found := False;\r\n Result := 0.0;\r\n for Index := 0 to FSize - 1 do\r\n if ValuesCompare(FEntries[Index].Value, Value) = 0 then\r\n begin\r\n Result := FEntries[Index].Key;\r\n Found := True;\r\n Break;\r\n end;\r\n\r\n if (not Found) and (not FReturnDefaultElements) then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSingleSingleSortedMap.KeySet: IJclSingleSet;\r\nvar\r\n Index: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := TJclSingleArraySet.Create(FSize);\r\n for Index := 0 to FSize - 1 do\r\n Result.Add(FEntries[Index].Key);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSingleSingleSortedMap.LastKey: Single;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := 0.0;\r\n if FSize > 0 then\r\n Result := FEntries[FSize - 1].Key\r\n else\r\n if not FReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSingleSingleSortedMap.MapEquals(const AMap: IJclSingleSingleMap): Boolean;\r\nvar\r\n It: IJclSingleIterator;\r\n Index: Integer;\r\n AKey: Single;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if AMap = nil then\r\n Exit;\r\n if FSize <> AMap.Size then\r\n Exit;\r\n It := AMap.KeySet.First;\r\n Index := 0;\r\n while It.HasNext do\r\n begin\r\n if Index >= FSize then\r\n Exit;\r\n AKey := It.Next;\r\n if ValuesCompare(AMap.GetValue(AKey), FEntries[Index].Value) <> 0 then\r\n Exit;\r\n Inc(Index);\r\n end;\r\n Result := True;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclSingleSingleSortedMap.InitializeArrayAfterMove(var List: TJclSingleSingleSortedMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\nbegin\r\n { Clean array }\r\n if FromIndex < ToIndex then\r\n begin\r\n if (ToIndex - FromIndex) < Count then\r\n Count := ToIndex - FromIndex;\r\n FillChar(List[FromIndex], Count * SizeOf(List[0]), 0);\r\n end\r\n else\r\n if FromIndex > ToIndex then\r\n begin\r\n if (FromIndex - ToIndex) < Count then\r\n FillChar(List[ToIndex + Count], (FromIndex - ToIndex) * SizeOf(List[0]), 0)\r\n else\r\n FillChar(List[FromIndex], Count * SizeOf(List[0]), 0);\r\n end;\r\nend;\r\n\r\nprocedure TJclSingleSingleSortedMap.MoveArray(var List: TJclSingleSingleSortedMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\nbegin\r\n if Count > 0 then\r\n begin\r\n Move(List[FromIndex], List[ToIndex], Count * SizeOf(List[0]));\r\n InitializeArrayAfterMove(List, FromIndex, ToIndex, Count);\r\n end;\r\nend;\r\n\r\nprocedure TJclSingleSingleSortedMap.PutAll(const AMap: IJclSingleSingleMap);\r\nvar\r\n It: IJclSingleIterator;\r\n Key: Single;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if AMap = nil then\r\n Exit;\r\n It := AMap.KeySet.First;\r\n while It.HasNext do\r\n begin\r\n Key := It.Next;\r\n PutValue(Key, AMap.GetValue(Key));\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclSingleSingleSortedMap.PutValue(const Key: Single; const Value: Single);\r\nvar\r\n Index: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FAllowDefaultElements or ((KeysCompare(Key, 0.0) <> 0) and (ValuesCompare(Value, 0.0) <> 0)) then\r\n begin\r\n Index := BinarySearch(Key);\r\n\r\n if (Index >= 0) and (KeysCompare(FEntries[Index].Key, Key) = 0) then\r\n begin\r\n FreeValue(FEntries[Index].Value);\r\n FEntries[Index].Value := Value;\r\n end\r\n else\r\n begin\r\n if FSize = FCapacity then\r\n AutoGrow;\r\n if FSize < FCapacity then\r\n begin\r\n Inc(Index);\r\n if (Index < FSize) and (KeysCompare(FEntries[Index].Key, Key) <> 0) then\r\n MoveArray(FEntries, Index, Index + 1, FSize - Index);\r\n FEntries[Index].Key := Key;\r\n FEntries[Index].Value := Value;\r\n Inc(FSize);\r\n end;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSingleSingleSortedMap.Remove(const Key: Single): Single;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := Extract(Key);\r\n Result := FreeValue(Result);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclSingleSingleSortedMap.SetCapacity(Value: Integer);\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FSize <= Value then\r\n begin\r\n SetLength(FEntries, Value);\r\n inherited SetCapacity(Value);\r\n end\r\n else\r\n raise EJclOperationNotSupportedError.Create;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSingleSingleSortedMap.Size: Integer;\r\nbegin\r\n Result := FSize;\r\nend;\r\n\r\nfunction TJclSingleSingleSortedMap.SubMap(const FromKey, ToKey: Single): IJclSingleSingleSortedMap;\r\nvar\r\n FromIndex, ToIndex: Integer;\r\n NewMap: TJclSingleSingleSortedMap;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n NewMap := CreateEmptyContainer as TJclSingleSingleSortedMap;\r\n FromIndex := BinarySearch(FromKey);\r\n if (FromIndex = -1) or (KeysCompare(FEntries[FromIndex].Key, FromKey) < 0) then\r\n Inc(FromIndex);\r\n ToIndex := BinarySearch(ToKey);\r\n if (FromIndex >= 0) and (FromIndex <= ToIndex) then\r\n begin\r\n NewMap.SetCapacity(ToIndex - FromIndex + 1);\r\n NewMap.FSize := ToIndex - FromIndex + 1;\r\n while ToIndex >= FromIndex do\r\n begin\r\n NewMap.FEntries[ToIndex - FromIndex] := FEntries[ToIndex];\r\n Dec(ToIndex);\r\n end;\r\n end;\r\n Result := NewMap;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSingleSingleSortedMap.TailMap(const FromKey: Single): IJclSingleSingleSortedMap;\r\nvar\r\n FromIndex, Index: Integer;\r\n NewMap: TJclSingleSingleSortedMap;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n NewMap := CreateEmptyContainer as TJclSingleSingleSortedMap;\r\n FromIndex := BinarySearch(FromKey);\r\n if (FromIndex = -1) or (KeysCompare(FEntries[FromIndex].Key, FromKey) < 0) then\r\n Inc(FromIndex);\r\n if (FromIndex >= 0) and (FromIndex < FSize) then\r\n begin\r\n NewMap.SetCapacity(FSize - FromIndex);\r\n NewMap.FSize := FSize - FromIndex;\r\n Index := FromIndex;\r\n while Index < FSize do\r\n begin\r\n NewMap.FEntries[Index - FromIndex] := FEntries[Index];\r\n Inc(Index);\r\n end;\r\n end;\r\n Result := NewMap;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSingleSingleSortedMap.Values: IJclSingleCollection;\r\nvar\r\n Index: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := TJclSingleArrayList.Create(FSize);\r\n for Index := 0 to FSize - 1 do\r\n Result.Add(FEntries[Index].Value);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSingleSingleSortedMap.CreateEmptyContainer: TJclAbstractContainerBase;\r\nbegin\r\n Result := TJclSingleSingleSortedMap.Create(FSize);\r\n AssignPropertiesTo(Result);\r\nend;\r\n\r\nfunction TJclSingleSingleSortedMap.FreeKey(var Key: Single): Single;\r\nbegin\r\n Result := Key;\r\n Key := 0.0;\r\nend;\r\n\r\nfunction TJclSingleSingleSortedMap.FreeValue(var Value: Single): Single;\r\nbegin\r\n Result := Value;\r\n Value := 0.0;\r\nend;\r\n\r\nfunction TJclSingleSingleSortedMap.KeysCompare(const A, B: Single): Integer;\r\nbegin\r\n Result := ItemsCompare(A, B);\r\nend;\r\n\r\nfunction TJclSingleSingleSortedMap.ValuesCompare(const A, B: Single): Integer;\r\nbegin\r\n Result := ItemsCompare(A, B);\r\nend;\r\n\r\n//=== { TJclDoubleIntfSortedMap } ==============================================\r\n\r\nconstructor TJclDoubleIntfSortedMap.Create(ACapacity: Integer);\r\nbegin\r\n inherited Create();\r\n SetCapacity(ACapacity);\r\nend;\r\n\r\ndestructor TJclDoubleIntfSortedMap.Destroy;\r\nbegin\r\n FReadOnly := False;\r\n Clear;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJclDoubleIntfSortedMap.AssignDataTo(Dest: TJclAbstractContainerBase);\r\nvar\r\n MyDest: TJclDoubleIntfSortedMap;\r\nbegin\r\n inherited AssignDataTo(Dest);\r\n if Dest is TJclDoubleIntfSortedMap then\r\n begin\r\n MyDest := TJclDoubleIntfSortedMap(Dest);\r\n MyDest.SetCapacity(FSize);\r\n MyDest.FEntries := FEntries;\r\n MyDest.FSize := FSize;\r\n end;\r\nend;\r\n\r\nfunction TJclDoubleIntfSortedMap.BinarySearch(const Key: Double): Integer;\r\nvar\r\n HiPos, LoPos, CompPos: Integer;\r\n Comp: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n LoPos := 0;\r\n HiPos := FSize - 1;\r\n CompPos := (HiPos + LoPos) div 2;\r\n while HiPos >= LoPos do\r\n begin\r\n Comp := KeysCompare(FEntries[CompPos].Key, Key);\r\n if Comp < 0 then\r\n LoPos := CompPos + 1\r\n else\r\n if Comp > 0 then\r\n HiPos := CompPos - 1\r\n else\r\n begin\r\n HiPos := CompPos;\r\n LoPos := CompPos + 1;\r\n end;\r\n CompPos := (HiPos + LoPos) div 2;\r\n end;\r\n Result := HiPos;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclDoubleIntfSortedMap.Clear;\r\nvar\r\n Index: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n for Index := 0 to FSize - 1 do\r\n begin\r\n FreeKey(FEntries[Index].Key);\r\n FreeValue(FEntries[Index].Value);\r\n end;\r\n FSize := 0;\r\n AutoPack;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclDoubleIntfSortedMap.ContainsKey(const Key: Double): Boolean;\r\nvar\r\n Index: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Index := BinarySearch(Key);\r\n Result := (Index >= 0) and (KeysCompare(FEntries[Index].Key, Key) = 0);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclDoubleIntfSortedMap.ContainsValue(const Value: IInterface): Boolean;\r\nvar\r\n Index: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n for Index := 0 to FSize - 1 do\r\n if ValuesCompare(FEntries[Index].Value, Value) = 0 then\r\n begin\r\n Result := True;\r\n Break;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclDoubleIntfSortedMap.FirstKey: Double;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := 0.0;\r\n if FSize > 0 then\r\n Result := FEntries[0].Key\r\n else\r\n if not FReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclDoubleIntfSortedMap.Extract(const Key: Double): IInterface;\r\nvar\r\n Index: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Index := BinarySearch(Key);\r\n if (Index >= 0) and (KeysCompare(FEntries[Index].Key, Key) = 0) then\r\n begin\r\n Result := FEntries[Index].Value;\r\n FEntries[Index].Value := nil;\r\n FreeKey(FEntries[Index].Key);\r\n if Index < (FSize - 1) then\r\n MoveArray(FEntries, Index + 1, Index, FSize - Index - 1);\r\n Dec(FSize);\r\n AutoPack;\r\n end\r\n else\r\n Result := nil;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclDoubleIntfSortedMap.GetValue(const Key: Double): IInterface;\r\nvar\r\n Index: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Index := BinarySearch(Key);\r\n Result := nil;\r\n if (Index >= 0) and (KeysCompare(FEntries[Index].Key, Key) = 0) then\r\n Result := FEntries[Index].Value\r\n else if not FReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclDoubleIntfSortedMap.HeadMap(const ToKey: Double): IJclDoubleIntfSortedMap;\r\nvar\r\n ToIndex: Integer;\r\n NewMap: TJclDoubleIntfSortedMap;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n NewMap := CreateEmptyContainer as TJclDoubleIntfSortedMap;\r\n ToIndex := BinarySearch(ToKey);\r\n if ToIndex >= 0 then\r\n begin\r\n NewMap.SetCapacity(ToIndex + 1);\r\n NewMap.FSize := ToIndex + 1;\r\n while ToIndex >= 0 do\r\n begin\r\n NewMap.FEntries[ToIndex] := FEntries[ToIndex];\r\n Dec(ToIndex);\r\n end;\r\n end;\r\n Result := NewMap;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclDoubleIntfSortedMap.IsEmpty: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := FSize = 0;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclDoubleIntfSortedMap.KeyOfValue(const Value: IInterface): Double;\r\nvar\r\n Index: Integer;\r\n Found: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Found := False;\r\n Result := 0.0;\r\n for Index := 0 to FSize - 1 do\r\n if ValuesCompare(FEntries[Index].Value, Value) = 0 then\r\n begin\r\n Result := FEntries[Index].Key;\r\n Found := True;\r\n Break;\r\n end;\r\n\r\n if (not Found) and (not FReturnDefaultElements) then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclDoubleIntfSortedMap.KeySet: IJclDoubleSet;\r\nvar\r\n Index: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := TJclDoubleArraySet.Create(FSize);\r\n for Index := 0 to FSize - 1 do\r\n Result.Add(FEntries[Index].Key);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclDoubleIntfSortedMap.LastKey: Double;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := 0.0;\r\n if FSize > 0 then\r\n Result := FEntries[FSize - 1].Key\r\n else\r\n if not FReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclDoubleIntfSortedMap.MapEquals(const AMap: IJclDoubleIntfMap): Boolean;\r\nvar\r\n It: IJclDoubleIterator;\r\n Index: Integer;\r\n AKey: Double;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if AMap = nil then\r\n Exit;\r\n if FSize <> AMap.Size then\r\n Exit;\r\n It := AMap.KeySet.First;\r\n Index := 0;\r\n while It.HasNext do\r\n begin\r\n if Index >= FSize then\r\n Exit;\r\n AKey := It.Next;\r\n if ValuesCompare(AMap.GetValue(AKey), FEntries[Index].Value) <> 0 then\r\n Exit;\r\n Inc(Index);\r\n end;\r\n Result := True;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclDoubleIntfSortedMap.FinalizeArrayBeforeMove(var List: TJclDoubleIntfSortedMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\nbegin\r\n Assert(Count > 0);\r\n if FromIndex < ToIndex then\r\n begin\r\n if Count > (ToIndex - FromIndex) then\r\n Finalize(List[FromIndex + Count], ToIndex - FromIndex)\r\n else\r\n Finalize(List[ToIndex], Count);\r\n end\r\n else\r\n if FromIndex > ToIndex then\r\n begin\r\n if Count > (FromIndex - ToIndex) then\r\n Count := FromIndex - ToIndex;\r\n Finalize(List[ToIndex], Count)\r\n end;\r\nend;\r\n\r\nprocedure TJclDoubleIntfSortedMap.InitializeArray(var List: TJclDoubleIntfSortedMapEntryArray; FromIndex, Count: SizeInt);\r\nbegin\r\n {$IFDEF FPC}\r\n while Count > 0 do\r\n begin\r\n Initialize(List[FromIndex]);\r\n Inc(FromIndex);\r\n Dec(Count);\r\n end;\r\n {$ELSE ~FPC}\r\n Initialize(List[FromIndex], Count);\r\n {$ENDIF ~FPC}\r\nend;\r\n\r\nprocedure TJclDoubleIntfSortedMap.InitializeArrayAfterMove(var List: TJclDoubleIntfSortedMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\nbegin\r\n { Keep reference counting working }\r\n if FromIndex < ToIndex then\r\n begin\r\n if (ToIndex - FromIndex) < Count then\r\n Count := ToIndex - FromIndex;\r\n InitializeArray(List, FromIndex, Count);\r\n end\r\n else\r\n if FromIndex > ToIndex then\r\n begin\r\n if (FromIndex - ToIndex) < Count then\r\n InitializeArray(List, ToIndex + Count, FromIndex - ToIndex)\r\n else\r\n InitializeArray(List, FromIndex, Count);\r\n end;\r\nend;\r\n\r\nprocedure TJclDoubleIntfSortedMap.MoveArray(var List: TJclDoubleIntfSortedMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\nbegin\r\n if Count > 0 then\r\n begin\r\n FinalizeArrayBeforeMove(List, FromIndex, ToIndex, Count);\r\n Move(List[FromIndex], List[ToIndex], Count * SizeOf(List[0]));\r\n InitializeArrayAfterMove(List, FromIndex, ToIndex, Count);\r\n end;\r\nend;\r\n\r\nprocedure TJclDoubleIntfSortedMap.PutAll(const AMap: IJclDoubleIntfMap);\r\nvar\r\n It: IJclDoubleIterator;\r\n Key: Double;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if AMap = nil then\r\n Exit;\r\n It := AMap.KeySet.First;\r\n while It.HasNext do\r\n begin\r\n Key := It.Next;\r\n PutValue(Key, AMap.GetValue(Key));\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclDoubleIntfSortedMap.PutValue(const Key: Double; const Value: IInterface);\r\nvar\r\n Index: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FAllowDefaultElements or ((KeysCompare(Key, 0.0) <> 0) and (ValuesCompare(Value, nil) <> 0)) then\r\n begin\r\n Index := BinarySearch(Key);\r\n\r\n if (Index >= 0) and (KeysCompare(FEntries[Index].Key, Key) = 0) then\r\n begin\r\n FreeValue(FEntries[Index].Value);\r\n FEntries[Index].Value := Value;\r\n end\r\n else\r\n begin\r\n if FSize = FCapacity then\r\n AutoGrow;\r\n if FSize < FCapacity then\r\n begin\r\n Inc(Index);\r\n if (Index < FSize) and (KeysCompare(FEntries[Index].Key, Key) <> 0) then\r\n MoveArray(FEntries, Index, Index + 1, FSize - Index);\r\n FEntries[Index].Key := Key;\r\n FEntries[Index].Value := Value;\r\n Inc(FSize);\r\n end;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclDoubleIntfSortedMap.Remove(const Key: Double): IInterface;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := Extract(Key);\r\n Result := FreeValue(Result);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclDoubleIntfSortedMap.SetCapacity(Value: Integer);\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FSize <= Value then\r\n begin\r\n SetLength(FEntries, Value);\r\n inherited SetCapacity(Value);\r\n end\r\n else\r\n raise EJclOperationNotSupportedError.Create;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclDoubleIntfSortedMap.Size: Integer;\r\nbegin\r\n Result := FSize;\r\nend;\r\n\r\nfunction TJclDoubleIntfSortedMap.SubMap(const FromKey, ToKey: Double): IJclDoubleIntfSortedMap;\r\nvar\r\n FromIndex, ToIndex: Integer;\r\n NewMap: TJclDoubleIntfSortedMap;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n NewMap := CreateEmptyContainer as TJclDoubleIntfSortedMap;\r\n FromIndex := BinarySearch(FromKey);\r\n if (FromIndex = -1) or (KeysCompare(FEntries[FromIndex].Key, FromKey) < 0) then\r\n Inc(FromIndex);\r\n ToIndex := BinarySearch(ToKey);\r\n if (FromIndex >= 0) and (FromIndex <= ToIndex) then\r\n begin\r\n NewMap.SetCapacity(ToIndex - FromIndex + 1);\r\n NewMap.FSize := ToIndex - FromIndex + 1;\r\n while ToIndex >= FromIndex do\r\n begin\r\n NewMap.FEntries[ToIndex - FromIndex] := FEntries[ToIndex];\r\n Dec(ToIndex);\r\n end;\r\n end;\r\n Result := NewMap;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclDoubleIntfSortedMap.TailMap(const FromKey: Double): IJclDoubleIntfSortedMap;\r\nvar\r\n FromIndex, Index: Integer;\r\n NewMap: TJclDoubleIntfSortedMap;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n NewMap := CreateEmptyContainer as TJclDoubleIntfSortedMap;\r\n FromIndex := BinarySearch(FromKey);\r\n if (FromIndex = -1) or (KeysCompare(FEntries[FromIndex].Key, FromKey) < 0) then\r\n Inc(FromIndex);\r\n if (FromIndex >= 0) and (FromIndex < FSize) then\r\n begin\r\n NewMap.SetCapacity(FSize - FromIndex);\r\n NewMap.FSize := FSize - FromIndex;\r\n Index := FromIndex;\r\n while Index < FSize do\r\n begin\r\n NewMap.FEntries[Index - FromIndex] := FEntries[Index];\r\n Inc(Index);\r\n end;\r\n end;\r\n Result := NewMap;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclDoubleIntfSortedMap.Values: IJclIntfCollection;\r\nvar\r\n Index: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := TJclIntfArrayList.Create(FSize);\r\n for Index := 0 to FSize - 1 do\r\n Result.Add(FEntries[Index].Value);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclDoubleIntfSortedMap.CreateEmptyContainer: TJclAbstractContainerBase;\r\nbegin\r\n Result := TJclDoubleIntfSortedMap.Create(FSize);\r\n AssignPropertiesTo(Result);\r\nend;\r\n\r\nfunction TJclDoubleIntfSortedMap.FreeKey(var Key: Double): Double;\r\nbegin\r\n Result := Key;\r\n Key := 0.0;\r\nend;\r\n\r\nfunction TJclDoubleIntfSortedMap.FreeValue(var Value: IInterface): IInterface;\r\nbegin\r\n Result := Value;\r\n Value := nil;\r\nend;\r\n\r\nfunction TJclDoubleIntfSortedMap.KeysCompare(const A, B: Double): Integer;\r\nbegin\r\n Result := ItemsCompare(A, B);\r\nend;\r\n\r\nfunction TJclDoubleIntfSortedMap.ValuesCompare(const A, B: IInterface): Integer;\r\nbegin\r\n Result := IntfSimpleCompare(A, B);\r\nend;\r\n\r\n//=== { TJclIntfDoubleSortedMap } ==============================================\r\n\r\nconstructor TJclIntfDoubleSortedMap.Create(ACapacity: Integer);\r\nbegin\r\n inherited Create();\r\n SetCapacity(ACapacity);\r\nend;\r\n\r\ndestructor TJclIntfDoubleSortedMap.Destroy;\r\nbegin\r\n FReadOnly := False;\r\n Clear;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJclIntfDoubleSortedMap.AssignDataTo(Dest: TJclAbstractContainerBase);\r\nvar\r\n MyDest: TJclIntfDoubleSortedMap;\r\nbegin\r\n inherited AssignDataTo(Dest);\r\n if Dest is TJclIntfDoubleSortedMap then\r\n begin\r\n MyDest := TJclIntfDoubleSortedMap(Dest);\r\n MyDest.SetCapacity(FSize);\r\n MyDest.FEntries := FEntries;\r\n MyDest.FSize := FSize;\r\n end;\r\nend;\r\n\r\nfunction TJclIntfDoubleSortedMap.BinarySearch(const Key: IInterface): Integer;\r\nvar\r\n HiPos, LoPos, CompPos: Integer;\r\n Comp: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n LoPos := 0;\r\n HiPos := FSize - 1;\r\n CompPos := (HiPos + LoPos) div 2;\r\n while HiPos >= LoPos do\r\n begin\r\n Comp := KeysCompare(FEntries[CompPos].Key, Key);\r\n if Comp < 0 then\r\n LoPos := CompPos + 1\r\n else\r\n if Comp > 0 then\r\n HiPos := CompPos - 1\r\n else\r\n begin\r\n HiPos := CompPos;\r\n LoPos := CompPos + 1;\r\n end;\r\n CompPos := (HiPos + LoPos) div 2;\r\n end;\r\n Result := HiPos;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclIntfDoubleSortedMap.Clear;\r\nvar\r\n Index: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n for Index := 0 to FSize - 1 do\r\n begin\r\n FreeKey(FEntries[Index].Key);\r\n FreeValue(FEntries[Index].Value);\r\n end;\r\n FSize := 0;\r\n AutoPack;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfDoubleSortedMap.ContainsKey(const Key: IInterface): Boolean;\r\nvar\r\n Index: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Index := BinarySearch(Key);\r\n Result := (Index >= 0) and (KeysCompare(FEntries[Index].Key, Key) = 0);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfDoubleSortedMap.ContainsValue(const Value: Double): Boolean;\r\nvar\r\n Index: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n for Index := 0 to FSize - 1 do\r\n if ValuesCompare(FEntries[Index].Value, Value) = 0 then\r\n begin\r\n Result := True;\r\n Break;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfDoubleSortedMap.FirstKey: IInterface;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := nil;\r\n if FSize > 0 then\r\n Result := FEntries[0].Key\r\n else\r\n if not FReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfDoubleSortedMap.Extract(const Key: IInterface): Double;\r\nvar\r\n Index: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Index := BinarySearch(Key);\r\n if (Index >= 0) and (KeysCompare(FEntries[Index].Key, Key) = 0) then\r\n begin\r\n Result := FEntries[Index].Value;\r\n FEntries[Index].Value := 0.0;\r\n FreeKey(FEntries[Index].Key);\r\n if Index < (FSize - 1) then\r\n MoveArray(FEntries, Index + 1, Index, FSize - Index - 1);\r\n Dec(FSize);\r\n AutoPack;\r\n end\r\n else\r\n Result := 0.0;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfDoubleSortedMap.GetValue(const Key: IInterface): Double;\r\nvar\r\n Index: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Index := BinarySearch(Key);\r\n Result := 0.0;\r\n if (Index >= 0) and (KeysCompare(FEntries[Index].Key, Key) = 0) then\r\n Result := FEntries[Index].Value\r\n else if not FReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfDoubleSortedMap.HeadMap(const ToKey: IInterface): IJclIntfDoubleSortedMap;\r\nvar\r\n ToIndex: Integer;\r\n NewMap: TJclIntfDoubleSortedMap;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n NewMap := CreateEmptyContainer as TJclIntfDoubleSortedMap;\r\n ToIndex := BinarySearch(ToKey);\r\n if ToIndex >= 0 then\r\n begin\r\n NewMap.SetCapacity(ToIndex + 1);\r\n NewMap.FSize := ToIndex + 1;\r\n while ToIndex >= 0 do\r\n begin\r\n NewMap.FEntries[ToIndex] := FEntries[ToIndex];\r\n Dec(ToIndex);\r\n end;\r\n end;\r\n Result := NewMap;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfDoubleSortedMap.IsEmpty: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := FSize = 0;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfDoubleSortedMap.KeyOfValue(const Value: Double): IInterface;\r\nvar\r\n Index: Integer;\r\n Found: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Found := False;\r\n Result := nil;\r\n for Index := 0 to FSize - 1 do\r\n if ValuesCompare(FEntries[Index].Value, Value) = 0 then\r\n begin\r\n Result := FEntries[Index].Key;\r\n Found := True;\r\n Break;\r\n end;\r\n\r\n if (not Found) and (not FReturnDefaultElements) then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfDoubleSortedMap.KeySet: IJclIntfSet;\r\nvar\r\n Index: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := TJclIntfArraySet.Create(FSize);\r\n for Index := 0 to FSize - 1 do\r\n Result.Add(FEntries[Index].Key);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfDoubleSortedMap.LastKey: IInterface;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := nil;\r\n if FSize > 0 then\r\n Result := FEntries[FSize - 1].Key\r\n else\r\n if not FReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfDoubleSortedMap.MapEquals(const AMap: IJclIntfDoubleMap): Boolean;\r\nvar\r\n It: IJclIntfIterator;\r\n Index: Integer;\r\n AKey: IInterface;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if AMap = nil then\r\n Exit;\r\n if FSize <> AMap.Size then\r\n Exit;\r\n It := AMap.KeySet.First;\r\n Index := 0;\r\n while It.HasNext do\r\n begin\r\n if Index >= FSize then\r\n Exit;\r\n AKey := It.Next;\r\n if ValuesCompare(AMap.GetValue(AKey), FEntries[Index].Value) <> 0 then\r\n Exit;\r\n Inc(Index);\r\n end;\r\n Result := True;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclIntfDoubleSortedMap.FinalizeArrayBeforeMove(var List: TJclIntfDoubleSortedMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\nbegin\r\n Assert(Count > 0);\r\n if FromIndex < ToIndex then\r\n begin\r\n if Count > (ToIndex - FromIndex) then\r\n Finalize(List[FromIndex + Count], ToIndex - FromIndex)\r\n else\r\n Finalize(List[ToIndex], Count);\r\n end\r\n else\r\n if FromIndex > ToIndex then\r\n begin\r\n if Count > (FromIndex - ToIndex) then\r\n Count := FromIndex - ToIndex;\r\n Finalize(List[ToIndex], Count)\r\n end;\r\nend;\r\n\r\nprocedure TJclIntfDoubleSortedMap.InitializeArray(var List: TJclIntfDoubleSortedMapEntryArray; FromIndex, Count: SizeInt);\r\nbegin\r\n {$IFDEF FPC}\r\n while Count > 0 do\r\n begin\r\n Initialize(List[FromIndex]);\r\n Inc(FromIndex);\r\n Dec(Count);\r\n end;\r\n {$ELSE ~FPC}\r\n Initialize(List[FromIndex], Count);\r\n {$ENDIF ~FPC}\r\nend;\r\n\r\nprocedure TJclIntfDoubleSortedMap.InitializeArrayAfterMove(var List: TJclIntfDoubleSortedMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\nbegin\r\n { Keep reference counting working }\r\n if FromIndex < ToIndex then\r\n begin\r\n if (ToIndex - FromIndex) < Count then\r\n Count := ToIndex - FromIndex;\r\n InitializeArray(List, FromIndex, Count);\r\n end\r\n else\r\n if FromIndex > ToIndex then\r\n begin\r\n if (FromIndex - ToIndex) < Count then\r\n InitializeArray(List, ToIndex + Count, FromIndex - ToIndex)\r\n else\r\n InitializeArray(List, FromIndex, Count);\r\n end;\r\nend;\r\n\r\nprocedure TJclIntfDoubleSortedMap.MoveArray(var List: TJclIntfDoubleSortedMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\nbegin\r\n if Count > 0 then\r\n begin\r\n FinalizeArrayBeforeMove(List, FromIndex, ToIndex, Count);\r\n Move(List[FromIndex], List[ToIndex], Count * SizeOf(List[0]));\r\n InitializeArrayAfterMove(List, FromIndex, ToIndex, Count);\r\n end;\r\nend;\r\n\r\nprocedure TJclIntfDoubleSortedMap.PutAll(const AMap: IJclIntfDoubleMap);\r\nvar\r\n It: IJclIntfIterator;\r\n Key: IInterface;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if AMap = nil then\r\n Exit;\r\n It := AMap.KeySet.First;\r\n while It.HasNext do\r\n begin\r\n Key := It.Next;\r\n PutValue(Key, AMap.GetValue(Key));\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclIntfDoubleSortedMap.PutValue(const Key: IInterface; const Value: Double);\r\nvar\r\n Index: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FAllowDefaultElements or ((KeysCompare(Key, nil) <> 0) and (ValuesCompare(Value, 0.0) <> 0)) then\r\n begin\r\n Index := BinarySearch(Key);\r\n\r\n if (Index >= 0) and (KeysCompare(FEntries[Index].Key, Key) = 0) then\r\n begin\r\n FreeValue(FEntries[Index].Value);\r\n FEntries[Index].Value := Value;\r\n end\r\n else\r\n begin\r\n if FSize = FCapacity then\r\n AutoGrow;\r\n if FSize < FCapacity then\r\n begin\r\n Inc(Index);\r\n if (Index < FSize) and (KeysCompare(FEntries[Index].Key, Key) <> 0) then\r\n MoveArray(FEntries, Index, Index + 1, FSize - Index);\r\n FEntries[Index].Key := Key;\r\n FEntries[Index].Value := Value;\r\n Inc(FSize);\r\n end;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfDoubleSortedMap.Remove(const Key: IInterface): Double;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := Extract(Key);\r\n Result := FreeValue(Result);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclIntfDoubleSortedMap.SetCapacity(Value: Integer);\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FSize <= Value then\r\n begin\r\n SetLength(FEntries, Value);\r\n inherited SetCapacity(Value);\r\n end\r\n else\r\n raise EJclOperationNotSupportedError.Create;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfDoubleSortedMap.Size: Integer;\r\nbegin\r\n Result := FSize;\r\nend;\r\n\r\nfunction TJclIntfDoubleSortedMap.SubMap(const FromKey, ToKey: IInterface): IJclIntfDoubleSortedMap;\r\nvar\r\n FromIndex, ToIndex: Integer;\r\n NewMap: TJclIntfDoubleSortedMap;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n NewMap := CreateEmptyContainer as TJclIntfDoubleSortedMap;\r\n FromIndex := BinarySearch(FromKey);\r\n if (FromIndex = -1) or (KeysCompare(FEntries[FromIndex].Key, FromKey) < 0) then\r\n Inc(FromIndex);\r\n ToIndex := BinarySearch(ToKey);\r\n if (FromIndex >= 0) and (FromIndex <= ToIndex) then\r\n begin\r\n NewMap.SetCapacity(ToIndex - FromIndex + 1);\r\n NewMap.FSize := ToIndex - FromIndex + 1;\r\n while ToIndex >= FromIndex do\r\n begin\r\n NewMap.FEntries[ToIndex - FromIndex] := FEntries[ToIndex];\r\n Dec(ToIndex);\r\n end;\r\n end;\r\n Result := NewMap;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfDoubleSortedMap.TailMap(const FromKey: IInterface): IJclIntfDoubleSortedMap;\r\nvar\r\n FromIndex, Index: Integer;\r\n NewMap: TJclIntfDoubleSortedMap;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n NewMap := CreateEmptyContainer as TJclIntfDoubleSortedMap;\r\n FromIndex := BinarySearch(FromKey);\r\n if (FromIndex = -1) or (KeysCompare(FEntries[FromIndex].Key, FromKey) < 0) then\r\n Inc(FromIndex);\r\n if (FromIndex >= 0) and (FromIndex < FSize) then\r\n begin\r\n NewMap.SetCapacity(FSize - FromIndex);\r\n NewMap.FSize := FSize - FromIndex;\r\n Index := FromIndex;\r\n while Index < FSize do\r\n begin\r\n NewMap.FEntries[Index - FromIndex] := FEntries[Index];\r\n Inc(Index);\r\n end;\r\n end;\r\n Result := NewMap;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfDoubleSortedMap.Values: IJclDoubleCollection;\r\nvar\r\n Index: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := TJclDoubleArrayList.Create(FSize);\r\n for Index := 0 to FSize - 1 do\r\n Result.Add(FEntries[Index].Value);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfDoubleSortedMap.CreateEmptyContainer: TJclAbstractContainerBase;\r\nbegin\r\n Result := TJclIntfDoubleSortedMap.Create(FSize);\r\n AssignPropertiesTo(Result);\r\nend;\r\n\r\nfunction TJclIntfDoubleSortedMap.FreeKey(var Key: IInterface): IInterface;\r\nbegin\r\n Result := Key;\r\n Key := nil;\r\nend;\r\n\r\nfunction TJclIntfDoubleSortedMap.FreeValue(var Value: Double): Double;\r\nbegin\r\n Result := Value;\r\n Value := 0.0;\r\nend;\r\n\r\nfunction TJclIntfDoubleSortedMap.KeysCompare(const A, B: IInterface): Integer;\r\nbegin\r\n Result := IntfSimpleCompare(A, B);\r\nend;\r\n\r\nfunction TJclIntfDoubleSortedMap.ValuesCompare(const A, B: Double): Integer;\r\nbegin\r\n Result := ItemsCompare(A, B);\r\nend;\r\n\r\n//=== { TJclDoubleDoubleSortedMap } ==============================================\r\n\r\nconstructor TJclDoubleDoubleSortedMap.Create(ACapacity: Integer);\r\nbegin\r\n inherited Create();\r\n SetCapacity(ACapacity);\r\nend;\r\n\r\ndestructor TJclDoubleDoubleSortedMap.Destroy;\r\nbegin\r\n FReadOnly := False;\r\n Clear;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJclDoubleDoubleSortedMap.AssignDataTo(Dest: TJclAbstractContainerBase);\r\nvar\r\n MyDest: TJclDoubleDoubleSortedMap;\r\nbegin\r\n inherited AssignDataTo(Dest);\r\n if Dest is TJclDoubleDoubleSortedMap then\r\n begin\r\n MyDest := TJclDoubleDoubleSortedMap(Dest);\r\n MyDest.SetCapacity(FSize);\r\n MyDest.FEntries := FEntries;\r\n MyDest.FSize := FSize;\r\n end;\r\nend;\r\n\r\nfunction TJclDoubleDoubleSortedMap.BinarySearch(const Key: Double): Integer;\r\nvar\r\n HiPos, LoPos, CompPos: Integer;\r\n Comp: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n LoPos := 0;\r\n HiPos := FSize - 1;\r\n CompPos := (HiPos + LoPos) div 2;\r\n while HiPos >= LoPos do\r\n begin\r\n Comp := KeysCompare(FEntries[CompPos].Key, Key);\r\n if Comp < 0 then\r\n LoPos := CompPos + 1\r\n else\r\n if Comp > 0 then\r\n HiPos := CompPos - 1\r\n else\r\n begin\r\n HiPos := CompPos;\r\n LoPos := CompPos + 1;\r\n end;\r\n CompPos := (HiPos + LoPos) div 2;\r\n end;\r\n Result := HiPos;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclDoubleDoubleSortedMap.Clear;\r\nvar\r\n Index: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n for Index := 0 to FSize - 1 do\r\n begin\r\n FreeKey(FEntries[Index].Key);\r\n FreeValue(FEntries[Index].Value);\r\n end;\r\n FSize := 0;\r\n AutoPack;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclDoubleDoubleSortedMap.ContainsKey(const Key: Double): Boolean;\r\nvar\r\n Index: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Index := BinarySearch(Key);\r\n Result := (Index >= 0) and (KeysCompare(FEntries[Index].Key, Key) = 0);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclDoubleDoubleSortedMap.ContainsValue(const Value: Double): Boolean;\r\nvar\r\n Index: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n for Index := 0 to FSize - 1 do\r\n if ValuesCompare(FEntries[Index].Value, Value) = 0 then\r\n begin\r\n Result := True;\r\n Break;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclDoubleDoubleSortedMap.FirstKey: Double;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := 0.0;\r\n if FSize > 0 then\r\n Result := FEntries[0].Key\r\n else\r\n if not FReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclDoubleDoubleSortedMap.Extract(const Key: Double): Double;\r\nvar\r\n Index: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Index := BinarySearch(Key);\r\n if (Index >= 0) and (KeysCompare(FEntries[Index].Key, Key) = 0) then\r\n begin\r\n Result := FEntries[Index].Value;\r\n FEntries[Index].Value := 0.0;\r\n FreeKey(FEntries[Index].Key);\r\n if Index < (FSize - 1) then\r\n MoveArray(FEntries, Index + 1, Index, FSize - Index - 1);\r\n Dec(FSize);\r\n AutoPack;\r\n end\r\n else\r\n Result := 0.0;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclDoubleDoubleSortedMap.GetValue(const Key: Double): Double;\r\nvar\r\n Index: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Index := BinarySearch(Key);\r\n Result := 0.0;\r\n if (Index >= 0) and (KeysCompare(FEntries[Index].Key, Key) = 0) then\r\n Result := FEntries[Index].Value\r\n else if not FReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclDoubleDoubleSortedMap.HeadMap(const ToKey: Double): IJclDoubleDoubleSortedMap;\r\nvar\r\n ToIndex: Integer;\r\n NewMap: TJclDoubleDoubleSortedMap;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n NewMap := CreateEmptyContainer as TJclDoubleDoubleSortedMap;\r\n ToIndex := BinarySearch(ToKey);\r\n if ToIndex >= 0 then\r\n begin\r\n NewMap.SetCapacity(ToIndex + 1);\r\n NewMap.FSize := ToIndex + 1;\r\n while ToIndex >= 0 do\r\n begin\r\n NewMap.FEntries[ToIndex] := FEntries[ToIndex];\r\n Dec(ToIndex);\r\n end;\r\n end;\r\n Result := NewMap;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclDoubleDoubleSortedMap.IsEmpty: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := FSize = 0;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclDoubleDoubleSortedMap.KeyOfValue(const Value: Double): Double;\r\nvar\r\n Index: Integer;\r\n Found: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Found := False;\r\n Result := 0.0;\r\n for Index := 0 to FSize - 1 do\r\n if ValuesCompare(FEntries[Index].Value, Value) = 0 then\r\n begin\r\n Result := FEntries[Index].Key;\r\n Found := True;\r\n Break;\r\n end;\r\n\r\n if (not Found) and (not FReturnDefaultElements) then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclDoubleDoubleSortedMap.KeySet: IJclDoubleSet;\r\nvar\r\n Index: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := TJclDoubleArraySet.Create(FSize);\r\n for Index := 0 to FSize - 1 do\r\n Result.Add(FEntries[Index].Key);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclDoubleDoubleSortedMap.LastKey: Double;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := 0.0;\r\n if FSize > 0 then\r\n Result := FEntries[FSize - 1].Key\r\n else\r\n if not FReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclDoubleDoubleSortedMap.MapEquals(const AMap: IJclDoubleDoubleMap): Boolean;\r\nvar\r\n It: IJclDoubleIterator;\r\n Index: Integer;\r\n AKey: Double;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if AMap = nil then\r\n Exit;\r\n if FSize <> AMap.Size then\r\n Exit;\r\n It := AMap.KeySet.First;\r\n Index := 0;\r\n while It.HasNext do\r\n begin\r\n if Index >= FSize then\r\n Exit;\r\n AKey := It.Next;\r\n if ValuesCompare(AMap.GetValue(AKey), FEntries[Index].Value) <> 0 then\r\n Exit;\r\n Inc(Index);\r\n end;\r\n Result := True;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclDoubleDoubleSortedMap.InitializeArrayAfterMove(var List: TJclDoubleDoubleSortedMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\nbegin\r\n { Clean array }\r\n if FromIndex < ToIndex then\r\n begin\r\n if (ToIndex - FromIndex) < Count then\r\n Count := ToIndex - FromIndex;\r\n FillChar(List[FromIndex], Count * SizeOf(List[0]), 0);\r\n end\r\n else\r\n if FromIndex > ToIndex then\r\n begin\r\n if (FromIndex - ToIndex) < Count then\r\n FillChar(List[ToIndex + Count], (FromIndex - ToIndex) * SizeOf(List[0]), 0)\r\n else\r\n FillChar(List[FromIndex], Count * SizeOf(List[0]), 0);\r\n end;\r\nend;\r\n\r\nprocedure TJclDoubleDoubleSortedMap.MoveArray(var List: TJclDoubleDoubleSortedMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\nbegin\r\n if Count > 0 then\r\n begin\r\n Move(List[FromIndex], List[ToIndex], Count * SizeOf(List[0]));\r\n InitializeArrayAfterMove(List, FromIndex, ToIndex, Count);\r\n end;\r\nend;\r\n\r\nprocedure TJclDoubleDoubleSortedMap.PutAll(const AMap: IJclDoubleDoubleMap);\r\nvar\r\n It: IJclDoubleIterator;\r\n Key: Double;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if AMap = nil then\r\n Exit;\r\n It := AMap.KeySet.First;\r\n while It.HasNext do\r\n begin\r\n Key := It.Next;\r\n PutValue(Key, AMap.GetValue(Key));\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclDoubleDoubleSortedMap.PutValue(const Key: Double; const Value: Double);\r\nvar\r\n Index: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FAllowDefaultElements or ((KeysCompare(Key, 0.0) <> 0) and (ValuesCompare(Value, 0.0) <> 0)) then\r\n begin\r\n Index := BinarySearch(Key);\r\n\r\n if (Index >= 0) and (KeysCompare(FEntries[Index].Key, Key) = 0) then\r\n begin\r\n FreeValue(FEntries[Index].Value);\r\n FEntries[Index].Value := Value;\r\n end\r\n else\r\n begin\r\n if FSize = FCapacity then\r\n AutoGrow;\r\n if FSize < FCapacity then\r\n begin\r\n Inc(Index);\r\n if (Index < FSize) and (KeysCompare(FEntries[Index].Key, Key) <> 0) then\r\n MoveArray(FEntries, Index, Index + 1, FSize - Index);\r\n FEntries[Index].Key := Key;\r\n FEntries[Index].Value := Value;\r\n Inc(FSize);\r\n end;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclDoubleDoubleSortedMap.Remove(const Key: Double): Double;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := Extract(Key);\r\n Result := FreeValue(Result);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclDoubleDoubleSortedMap.SetCapacity(Value: Integer);\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FSize <= Value then\r\n begin\r\n SetLength(FEntries, Value);\r\n inherited SetCapacity(Value);\r\n end\r\n else\r\n raise EJclOperationNotSupportedError.Create;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclDoubleDoubleSortedMap.Size: Integer;\r\nbegin\r\n Result := FSize;\r\nend;\r\n\r\nfunction TJclDoubleDoubleSortedMap.SubMap(const FromKey, ToKey: Double): IJclDoubleDoubleSortedMap;\r\nvar\r\n FromIndex, ToIndex: Integer;\r\n NewMap: TJclDoubleDoubleSortedMap;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n NewMap := CreateEmptyContainer as TJclDoubleDoubleSortedMap;\r\n FromIndex := BinarySearch(FromKey);\r\n if (FromIndex = -1) or (KeysCompare(FEntries[FromIndex].Key, FromKey) < 0) then\r\n Inc(FromIndex);\r\n ToIndex := BinarySearch(ToKey);\r\n if (FromIndex >= 0) and (FromIndex <= ToIndex) then\r\n begin\r\n NewMap.SetCapacity(ToIndex - FromIndex + 1);\r\n NewMap.FSize := ToIndex - FromIndex + 1;\r\n while ToIndex >= FromIndex do\r\n begin\r\n NewMap.FEntries[ToIndex - FromIndex] := FEntries[ToIndex];\r\n Dec(ToIndex);\r\n end;\r\n end;\r\n Result := NewMap;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclDoubleDoubleSortedMap.TailMap(const FromKey: Double): IJclDoubleDoubleSortedMap;\r\nvar\r\n FromIndex, Index: Integer;\r\n NewMap: TJclDoubleDoubleSortedMap;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n NewMap := CreateEmptyContainer as TJclDoubleDoubleSortedMap;\r\n FromIndex := BinarySearch(FromKey);\r\n if (FromIndex = -1) or (KeysCompare(FEntries[FromIndex].Key, FromKey) < 0) then\r\n Inc(FromIndex);\r\n if (FromIndex >= 0) and (FromIndex < FSize) then\r\n begin\r\n NewMap.SetCapacity(FSize - FromIndex);\r\n NewMap.FSize := FSize - FromIndex;\r\n Index := FromIndex;\r\n while Index < FSize do\r\n begin\r\n NewMap.FEntries[Index - FromIndex] := FEntries[Index];\r\n Inc(Index);\r\n end;\r\n end;\r\n Result := NewMap;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclDoubleDoubleSortedMap.Values: IJclDoubleCollection;\r\nvar\r\n Index: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := TJclDoubleArrayList.Create(FSize);\r\n for Index := 0 to FSize - 1 do\r\n Result.Add(FEntries[Index].Value);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclDoubleDoubleSortedMap.CreateEmptyContainer: TJclAbstractContainerBase;\r\nbegin\r\n Result := TJclDoubleDoubleSortedMap.Create(FSize);\r\n AssignPropertiesTo(Result);\r\nend;\r\n\r\nfunction TJclDoubleDoubleSortedMap.FreeKey(var Key: Double): Double;\r\nbegin\r\n Result := Key;\r\n Key := 0.0;\r\nend;\r\n\r\nfunction TJclDoubleDoubleSortedMap.FreeValue(var Value: Double): Double;\r\nbegin\r\n Result := Value;\r\n Value := 0.0;\r\nend;\r\n\r\nfunction TJclDoubleDoubleSortedMap.KeysCompare(const A, B: Double): Integer;\r\nbegin\r\n Result := ItemsCompare(A, B);\r\nend;\r\n\r\nfunction TJclDoubleDoubleSortedMap.ValuesCompare(const A, B: Double): Integer;\r\nbegin\r\n Result := ItemsCompare(A, B);\r\nend;\r\n\r\n//=== { TJclExtendedIntfSortedMap } ==============================================\r\n\r\nconstructor TJclExtendedIntfSortedMap.Create(ACapacity: Integer);\r\nbegin\r\n inherited Create();\r\n SetCapacity(ACapacity);\r\nend;\r\n\r\ndestructor TJclExtendedIntfSortedMap.Destroy;\r\nbegin\r\n FReadOnly := False;\r\n Clear;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJclExtendedIntfSortedMap.AssignDataTo(Dest: TJclAbstractContainerBase);\r\nvar\r\n MyDest: TJclExtendedIntfSortedMap;\r\nbegin\r\n inherited AssignDataTo(Dest);\r\n if Dest is TJclExtendedIntfSortedMap then\r\n begin\r\n MyDest := TJclExtendedIntfSortedMap(Dest);\r\n MyDest.SetCapacity(FSize);\r\n MyDest.FEntries := FEntries;\r\n MyDest.FSize := FSize;\r\n end;\r\nend;\r\n\r\nfunction TJclExtendedIntfSortedMap.BinarySearch(const Key: Extended): Integer;\r\nvar\r\n HiPos, LoPos, CompPos: Integer;\r\n Comp: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n LoPos := 0;\r\n HiPos := FSize - 1;\r\n CompPos := (HiPos + LoPos) div 2;\r\n while HiPos >= LoPos do\r\n begin\r\n Comp := KeysCompare(FEntries[CompPos].Key, Key);\r\n if Comp < 0 then\r\n LoPos := CompPos + 1\r\n else\r\n if Comp > 0 then\r\n HiPos := CompPos - 1\r\n else\r\n begin\r\n HiPos := CompPos;\r\n LoPos := CompPos + 1;\r\n end;\r\n CompPos := (HiPos + LoPos) div 2;\r\n end;\r\n Result := HiPos;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclExtendedIntfSortedMap.Clear;\r\nvar\r\n Index: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n for Index := 0 to FSize - 1 do\r\n begin\r\n FreeKey(FEntries[Index].Key);\r\n FreeValue(FEntries[Index].Value);\r\n end;\r\n FSize := 0;\r\n AutoPack;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclExtendedIntfSortedMap.ContainsKey(const Key: Extended): Boolean;\r\nvar\r\n Index: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Index := BinarySearch(Key);\r\n Result := (Index >= 0) and (KeysCompare(FEntries[Index].Key, Key) = 0);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclExtendedIntfSortedMap.ContainsValue(const Value: IInterface): Boolean;\r\nvar\r\n Index: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n for Index := 0 to FSize - 1 do\r\n if ValuesCompare(FEntries[Index].Value, Value) = 0 then\r\n begin\r\n Result := True;\r\n Break;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclExtendedIntfSortedMap.FirstKey: Extended;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := 0.0;\r\n if FSize > 0 then\r\n Result := FEntries[0].Key\r\n else\r\n if not FReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclExtendedIntfSortedMap.Extract(const Key: Extended): IInterface;\r\nvar\r\n Index: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Index := BinarySearch(Key);\r\n if (Index >= 0) and (KeysCompare(FEntries[Index].Key, Key) = 0) then\r\n begin\r\n Result := FEntries[Index].Value;\r\n FEntries[Index].Value := nil;\r\n FreeKey(FEntries[Index].Key);\r\n if Index < (FSize - 1) then\r\n MoveArray(FEntries, Index + 1, Index, FSize - Index - 1);\r\n Dec(FSize);\r\n AutoPack;\r\n end\r\n else\r\n Result := nil;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclExtendedIntfSortedMap.GetValue(const Key: Extended): IInterface;\r\nvar\r\n Index: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Index := BinarySearch(Key);\r\n Result := nil;\r\n if (Index >= 0) and (KeysCompare(FEntries[Index].Key, Key) = 0) then\r\n Result := FEntries[Index].Value\r\n else if not FReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclExtendedIntfSortedMap.HeadMap(const ToKey: Extended): IJclExtendedIntfSortedMap;\r\nvar\r\n ToIndex: Integer;\r\n NewMap: TJclExtendedIntfSortedMap;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n NewMap := CreateEmptyContainer as TJclExtendedIntfSortedMap;\r\n ToIndex := BinarySearch(ToKey);\r\n if ToIndex >= 0 then\r\n begin\r\n NewMap.SetCapacity(ToIndex + 1);\r\n NewMap.FSize := ToIndex + 1;\r\n while ToIndex >= 0 do\r\n begin\r\n NewMap.FEntries[ToIndex] := FEntries[ToIndex];\r\n Dec(ToIndex);\r\n end;\r\n end;\r\n Result := NewMap;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclExtendedIntfSortedMap.IsEmpty: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := FSize = 0;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclExtendedIntfSortedMap.KeyOfValue(const Value: IInterface): Extended;\r\nvar\r\n Index: Integer;\r\n Found: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Found := False;\r\n Result := 0.0;\r\n for Index := 0 to FSize - 1 do\r\n if ValuesCompare(FEntries[Index].Value, Value) = 0 then\r\n begin\r\n Result := FEntries[Index].Key;\r\n Found := True;\r\n Break;\r\n end;\r\n\r\n if (not Found) and (not FReturnDefaultElements) then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclExtendedIntfSortedMap.KeySet: IJclExtendedSet;\r\nvar\r\n Index: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := TJclExtendedArraySet.Create(FSize);\r\n for Index := 0 to FSize - 1 do\r\n Result.Add(FEntries[Index].Key);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclExtendedIntfSortedMap.LastKey: Extended;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := 0.0;\r\n if FSize > 0 then\r\n Result := FEntries[FSize - 1].Key\r\n else\r\n if not FReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclExtendedIntfSortedMap.MapEquals(const AMap: IJclExtendedIntfMap): Boolean;\r\nvar\r\n It: IJclExtendedIterator;\r\n Index: Integer;\r\n AKey: Extended;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if AMap = nil then\r\n Exit;\r\n if FSize <> AMap.Size then\r\n Exit;\r\n It := AMap.KeySet.First;\r\n Index := 0;\r\n while It.HasNext do\r\n begin\r\n if Index >= FSize then\r\n Exit;\r\n AKey := It.Next;\r\n if ValuesCompare(AMap.GetValue(AKey), FEntries[Index].Value) <> 0 then\r\n Exit;\r\n Inc(Index);\r\n end;\r\n Result := True;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclExtendedIntfSortedMap.FinalizeArrayBeforeMove(var List: TJclExtendedIntfSortedMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\nbegin\r\n Assert(Count > 0);\r\n if FromIndex < ToIndex then\r\n begin\r\n if Count > (ToIndex - FromIndex) then\r\n Finalize(List[FromIndex + Count], ToIndex - FromIndex)\r\n else\r\n Finalize(List[ToIndex], Count);\r\n end\r\n else\r\n if FromIndex > ToIndex then\r\n begin\r\n if Count > (FromIndex - ToIndex) then\r\n Count := FromIndex - ToIndex;\r\n Finalize(List[ToIndex], Count)\r\n end;\r\nend;\r\n\r\nprocedure TJclExtendedIntfSortedMap.InitializeArray(var List: TJclExtendedIntfSortedMapEntryArray; FromIndex, Count: SizeInt);\r\nbegin\r\n {$IFDEF FPC}\r\n while Count > 0 do\r\n begin\r\n Initialize(List[FromIndex]);\r\n Inc(FromIndex);\r\n Dec(Count);\r\n end;\r\n {$ELSE ~FPC}\r\n Initialize(List[FromIndex], Count);\r\n {$ENDIF ~FPC}\r\nend;\r\n\r\nprocedure TJclExtendedIntfSortedMap.InitializeArrayAfterMove(var List: TJclExtendedIntfSortedMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\nbegin\r\n { Keep reference counting working }\r\n if FromIndex < ToIndex then\r\n begin\r\n if (ToIndex - FromIndex) < Count then\r\n Count := ToIndex - FromIndex;\r\n InitializeArray(List, FromIndex, Count);\r\n end\r\n else\r\n if FromIndex > ToIndex then\r\n begin\r\n if (FromIndex - ToIndex) < Count then\r\n InitializeArray(List, ToIndex + Count, FromIndex - ToIndex)\r\n else\r\n InitializeArray(List, FromIndex, Count);\r\n end;\r\nend;\r\n\r\nprocedure TJclExtendedIntfSortedMap.MoveArray(var List: TJclExtendedIntfSortedMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\nbegin\r\n if Count > 0 then\r\n begin\r\n FinalizeArrayBeforeMove(List, FromIndex, ToIndex, Count);\r\n Move(List[FromIndex], List[ToIndex], Count * SizeOf(List[0]));\r\n InitializeArrayAfterMove(List, FromIndex, ToIndex, Count);\r\n end;\r\nend;\r\n\r\nprocedure TJclExtendedIntfSortedMap.PutAll(const AMap: IJclExtendedIntfMap);\r\nvar\r\n It: IJclExtendedIterator;\r\n Key: Extended;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if AMap = nil then\r\n Exit;\r\n It := AMap.KeySet.First;\r\n while It.HasNext do\r\n begin\r\n Key := It.Next;\r\n PutValue(Key, AMap.GetValue(Key));\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclExtendedIntfSortedMap.PutValue(const Key: Extended; const Value: IInterface);\r\nvar\r\n Index: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FAllowDefaultElements or ((KeysCompare(Key, 0.0) <> 0) and (ValuesCompare(Value, nil) <> 0)) then\r\n begin\r\n Index := BinarySearch(Key);\r\n\r\n if (Index >= 0) and (KeysCompare(FEntries[Index].Key, Key) = 0) then\r\n begin\r\n FreeValue(FEntries[Index].Value);\r\n FEntries[Index].Value := Value;\r\n end\r\n else\r\n begin\r\n if FSize = FCapacity then\r\n AutoGrow;\r\n if FSize < FCapacity then\r\n begin\r\n Inc(Index);\r\n if (Index < FSize) and (KeysCompare(FEntries[Index].Key, Key) <> 0) then\r\n MoveArray(FEntries, Index, Index + 1, FSize - Index);\r\n FEntries[Index].Key := Key;\r\n FEntries[Index].Value := Value;\r\n Inc(FSize);\r\n end;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclExtendedIntfSortedMap.Remove(const Key: Extended): IInterface;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := Extract(Key);\r\n Result := FreeValue(Result);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclExtendedIntfSortedMap.SetCapacity(Value: Integer);\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FSize <= Value then\r\n begin\r\n SetLength(FEntries, Value);\r\n inherited SetCapacity(Value);\r\n end\r\n else\r\n raise EJclOperationNotSupportedError.Create;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclExtendedIntfSortedMap.Size: Integer;\r\nbegin\r\n Result := FSize;\r\nend;\r\n\r\nfunction TJclExtendedIntfSortedMap.SubMap(const FromKey, ToKey: Extended): IJclExtendedIntfSortedMap;\r\nvar\r\n FromIndex, ToIndex: Integer;\r\n NewMap: TJclExtendedIntfSortedMap;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n NewMap := CreateEmptyContainer as TJclExtendedIntfSortedMap;\r\n FromIndex := BinarySearch(FromKey);\r\n if (FromIndex = -1) or (KeysCompare(FEntries[FromIndex].Key, FromKey) < 0) then\r\n Inc(FromIndex);\r\n ToIndex := BinarySearch(ToKey);\r\n if (FromIndex >= 0) and (FromIndex <= ToIndex) then\r\n begin\r\n NewMap.SetCapacity(ToIndex - FromIndex + 1);\r\n NewMap.FSize := ToIndex - FromIndex + 1;\r\n while ToIndex >= FromIndex do\r\n begin\r\n NewMap.FEntries[ToIndex - FromIndex] := FEntries[ToIndex];\r\n Dec(ToIndex);\r\n end;\r\n end;\r\n Result := NewMap;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclExtendedIntfSortedMap.TailMap(const FromKey: Extended): IJclExtendedIntfSortedMap;\r\nvar\r\n FromIndex, Index: Integer;\r\n NewMap: TJclExtendedIntfSortedMap;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n NewMap := CreateEmptyContainer as TJclExtendedIntfSortedMap;\r\n FromIndex := BinarySearch(FromKey);\r\n if (FromIndex = -1) or (KeysCompare(FEntries[FromIndex].Key, FromKey) < 0) then\r\n Inc(FromIndex);\r\n if (FromIndex >= 0) and (FromIndex < FSize) then\r\n begin\r\n NewMap.SetCapacity(FSize - FromIndex);\r\n NewMap.FSize := FSize - FromIndex;\r\n Index := FromIndex;\r\n while Index < FSize do\r\n begin\r\n NewMap.FEntries[Index - FromIndex] := FEntries[Index];\r\n Inc(Index);\r\n end;\r\n end;\r\n Result := NewMap;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclExtendedIntfSortedMap.Values: IJclIntfCollection;\r\nvar\r\n Index: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := TJclIntfArrayList.Create(FSize);\r\n for Index := 0 to FSize - 1 do\r\n Result.Add(FEntries[Index].Value);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclExtendedIntfSortedMap.CreateEmptyContainer: TJclAbstractContainerBase;\r\nbegin\r\n Result := TJclExtendedIntfSortedMap.Create(FSize);\r\n AssignPropertiesTo(Result);\r\nend;\r\n\r\nfunction TJclExtendedIntfSortedMap.FreeKey(var Key: Extended): Extended;\r\nbegin\r\n Result := Key;\r\n Key := 0.0;\r\nend;\r\n\r\nfunction TJclExtendedIntfSortedMap.FreeValue(var Value: IInterface): IInterface;\r\nbegin\r\n Result := Value;\r\n Value := nil;\r\nend;\r\n\r\nfunction TJclExtendedIntfSortedMap.KeysCompare(const A, B: Extended): Integer;\r\nbegin\r\n Result := ItemsCompare(A, B);\r\nend;\r\n\r\nfunction TJclExtendedIntfSortedMap.ValuesCompare(const A, B: IInterface): Integer;\r\nbegin\r\n Result := IntfSimpleCompare(A, B);\r\nend;\r\n\r\n//=== { TJclIntfExtendedSortedMap } ==============================================\r\n\r\nconstructor TJclIntfExtendedSortedMap.Create(ACapacity: Integer);\r\nbegin\r\n inherited Create();\r\n SetCapacity(ACapacity);\r\nend;\r\n\r\ndestructor TJclIntfExtendedSortedMap.Destroy;\r\nbegin\r\n FReadOnly := False;\r\n Clear;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJclIntfExtendedSortedMap.AssignDataTo(Dest: TJclAbstractContainerBase);\r\nvar\r\n MyDest: TJclIntfExtendedSortedMap;\r\nbegin\r\n inherited AssignDataTo(Dest);\r\n if Dest is TJclIntfExtendedSortedMap then\r\n begin\r\n MyDest := TJclIntfExtendedSortedMap(Dest);\r\n MyDest.SetCapacity(FSize);\r\n MyDest.FEntries := FEntries;\r\n MyDest.FSize := FSize;\r\n end;\r\nend;\r\n\r\nfunction TJclIntfExtendedSortedMap.BinarySearch(const Key: IInterface): Integer;\r\nvar\r\n HiPos, LoPos, CompPos: Integer;\r\n Comp: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n LoPos := 0;\r\n HiPos := FSize - 1;\r\n CompPos := (HiPos + LoPos) div 2;\r\n while HiPos >= LoPos do\r\n begin\r\n Comp := KeysCompare(FEntries[CompPos].Key, Key);\r\n if Comp < 0 then\r\n LoPos := CompPos + 1\r\n else\r\n if Comp > 0 then\r\n HiPos := CompPos - 1\r\n else\r\n begin\r\n HiPos := CompPos;\r\n LoPos := CompPos + 1;\r\n end;\r\n CompPos := (HiPos + LoPos) div 2;\r\n end;\r\n Result := HiPos;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclIntfExtendedSortedMap.Clear;\r\nvar\r\n Index: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n for Index := 0 to FSize - 1 do\r\n begin\r\n FreeKey(FEntries[Index].Key);\r\n FreeValue(FEntries[Index].Value);\r\n end;\r\n FSize := 0;\r\n AutoPack;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfExtendedSortedMap.ContainsKey(const Key: IInterface): Boolean;\r\nvar\r\n Index: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Index := BinarySearch(Key);\r\n Result := (Index >= 0) and (KeysCompare(FEntries[Index].Key, Key) = 0);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfExtendedSortedMap.ContainsValue(const Value: Extended): Boolean;\r\nvar\r\n Index: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n for Index := 0 to FSize - 1 do\r\n if ValuesCompare(FEntries[Index].Value, Value) = 0 then\r\n begin\r\n Result := True;\r\n Break;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfExtendedSortedMap.FirstKey: IInterface;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := nil;\r\n if FSize > 0 then\r\n Result := FEntries[0].Key\r\n else\r\n if not FReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfExtendedSortedMap.Extract(const Key: IInterface): Extended;\r\nvar\r\n Index: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Index := BinarySearch(Key);\r\n if (Index >= 0) and (KeysCompare(FEntries[Index].Key, Key) = 0) then\r\n begin\r\n Result := FEntries[Index].Value;\r\n FEntries[Index].Value := 0.0;\r\n FreeKey(FEntries[Index].Key);\r\n if Index < (FSize - 1) then\r\n MoveArray(FEntries, Index + 1, Index, FSize - Index - 1);\r\n Dec(FSize);\r\n AutoPack;\r\n end\r\n else\r\n Result := 0.0;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfExtendedSortedMap.GetValue(const Key: IInterface): Extended;\r\nvar\r\n Index: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Index := BinarySearch(Key);\r\n Result := 0.0;\r\n if (Index >= 0) and (KeysCompare(FEntries[Index].Key, Key) = 0) then\r\n Result := FEntries[Index].Value\r\n else if not FReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfExtendedSortedMap.HeadMap(const ToKey: IInterface): IJclIntfExtendedSortedMap;\r\nvar\r\n ToIndex: Integer;\r\n NewMap: TJclIntfExtendedSortedMap;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n NewMap := CreateEmptyContainer as TJclIntfExtendedSortedMap;\r\n ToIndex := BinarySearch(ToKey);\r\n if ToIndex >= 0 then\r\n begin\r\n NewMap.SetCapacity(ToIndex + 1);\r\n NewMap.FSize := ToIndex + 1;\r\n while ToIndex >= 0 do\r\n begin\r\n NewMap.FEntries[ToIndex] := FEntries[ToIndex];\r\n Dec(ToIndex);\r\n end;\r\n end;\r\n Result := NewMap;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfExtendedSortedMap.IsEmpty: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := FSize = 0;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfExtendedSortedMap.KeyOfValue(const Value: Extended): IInterface;\r\nvar\r\n Index: Integer;\r\n Found: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Found := False;\r\n Result := nil;\r\n for Index := 0 to FSize - 1 do\r\n if ValuesCompare(FEntries[Index].Value, Value) = 0 then\r\n begin\r\n Result := FEntries[Index].Key;\r\n Found := True;\r\n Break;\r\n end;\r\n\r\n if (not Found) and (not FReturnDefaultElements) then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfExtendedSortedMap.KeySet: IJclIntfSet;\r\nvar\r\n Index: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := TJclIntfArraySet.Create(FSize);\r\n for Index := 0 to FSize - 1 do\r\n Result.Add(FEntries[Index].Key);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfExtendedSortedMap.LastKey: IInterface;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := nil;\r\n if FSize > 0 then\r\n Result := FEntries[FSize - 1].Key\r\n else\r\n if not FReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfExtendedSortedMap.MapEquals(const AMap: IJclIntfExtendedMap): Boolean;\r\nvar\r\n It: IJclIntfIterator;\r\n Index: Integer;\r\n AKey: IInterface;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if AMap = nil then\r\n Exit;\r\n if FSize <> AMap.Size then\r\n Exit;\r\n It := AMap.KeySet.First;\r\n Index := 0;\r\n while It.HasNext do\r\n begin\r\n if Index >= FSize then\r\n Exit;\r\n AKey := It.Next;\r\n if ValuesCompare(AMap.GetValue(AKey), FEntries[Index].Value) <> 0 then\r\n Exit;\r\n Inc(Index);\r\n end;\r\n Result := True;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclIntfExtendedSortedMap.FinalizeArrayBeforeMove(var List: TJclIntfExtendedSortedMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\nbegin\r\n Assert(Count > 0);\r\n if FromIndex < ToIndex then\r\n begin\r\n if Count > (ToIndex - FromIndex) then\r\n Finalize(List[FromIndex + Count], ToIndex - FromIndex)\r\n else\r\n Finalize(List[ToIndex], Count);\r\n end\r\n else\r\n if FromIndex > ToIndex then\r\n begin\r\n if Count > (FromIndex - ToIndex) then\r\n Count := FromIndex - ToIndex;\r\n Finalize(List[ToIndex], Count)\r\n end;\r\nend;\r\n\r\nprocedure TJclIntfExtendedSortedMap.InitializeArray(var List: TJclIntfExtendedSortedMapEntryArray; FromIndex, Count: SizeInt);\r\nbegin\r\n {$IFDEF FPC}\r\n while Count > 0 do\r\n begin\r\n Initialize(List[FromIndex]);\r\n Inc(FromIndex);\r\n Dec(Count);\r\n end;\r\n {$ELSE ~FPC}\r\n Initialize(List[FromIndex], Count);\r\n {$ENDIF ~FPC}\r\nend;\r\n\r\nprocedure TJclIntfExtendedSortedMap.InitializeArrayAfterMove(var List: TJclIntfExtendedSortedMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\nbegin\r\n { Keep reference counting working }\r\n if FromIndex < ToIndex then\r\n begin\r\n if (ToIndex - FromIndex) < Count then\r\n Count := ToIndex - FromIndex;\r\n InitializeArray(List, FromIndex, Count);\r\n end\r\n else\r\n if FromIndex > ToIndex then\r\n begin\r\n if (FromIndex - ToIndex) < Count then\r\n InitializeArray(List, ToIndex + Count, FromIndex - ToIndex)\r\n else\r\n InitializeArray(List, FromIndex, Count);\r\n end;\r\nend;\r\n\r\nprocedure TJclIntfExtendedSortedMap.MoveArray(var List: TJclIntfExtendedSortedMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\nbegin\r\n if Count > 0 then\r\n begin\r\n FinalizeArrayBeforeMove(List, FromIndex, ToIndex, Count);\r\n Move(List[FromIndex], List[ToIndex], Count * SizeOf(List[0]));\r\n InitializeArrayAfterMove(List, FromIndex, ToIndex, Count);\r\n end;\r\nend;\r\n\r\nprocedure TJclIntfExtendedSortedMap.PutAll(const AMap: IJclIntfExtendedMap);\r\nvar\r\n It: IJclIntfIterator;\r\n Key: IInterface;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if AMap = nil then\r\n Exit;\r\n It := AMap.KeySet.First;\r\n while It.HasNext do\r\n begin\r\n Key := It.Next;\r\n PutValue(Key, AMap.GetValue(Key));\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclIntfExtendedSortedMap.PutValue(const Key: IInterface; const Value: Extended);\r\nvar\r\n Index: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FAllowDefaultElements or ((KeysCompare(Key, nil) <> 0) and (ValuesCompare(Value, 0.0) <> 0)) then\r\n begin\r\n Index := BinarySearch(Key);\r\n\r\n if (Index >= 0) and (KeysCompare(FEntries[Index].Key, Key) = 0) then\r\n begin\r\n FreeValue(FEntries[Index].Value);\r\n FEntries[Index].Value := Value;\r\n end\r\n else\r\n begin\r\n if FSize = FCapacity then\r\n AutoGrow;\r\n if FSize < FCapacity then\r\n begin\r\n Inc(Index);\r\n if (Index < FSize) and (KeysCompare(FEntries[Index].Key, Key) <> 0) then\r\n MoveArray(FEntries, Index, Index + 1, FSize - Index);\r\n FEntries[Index].Key := Key;\r\n FEntries[Index].Value := Value;\r\n Inc(FSize);\r\n end;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfExtendedSortedMap.Remove(const Key: IInterface): Extended;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := Extract(Key);\r\n Result := FreeValue(Result);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclIntfExtendedSortedMap.SetCapacity(Value: Integer);\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FSize <= Value then\r\n begin\r\n SetLength(FEntries, Value);\r\n inherited SetCapacity(Value);\r\n end\r\n else\r\n raise EJclOperationNotSupportedError.Create;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfExtendedSortedMap.Size: Integer;\r\nbegin\r\n Result := FSize;\r\nend;\r\n\r\nfunction TJclIntfExtendedSortedMap.SubMap(const FromKey, ToKey: IInterface): IJclIntfExtendedSortedMap;\r\nvar\r\n FromIndex, ToIndex: Integer;\r\n NewMap: TJclIntfExtendedSortedMap;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n NewMap := CreateEmptyContainer as TJclIntfExtendedSortedMap;\r\n FromIndex := BinarySearch(FromKey);\r\n if (FromIndex = -1) or (KeysCompare(FEntries[FromIndex].Key, FromKey) < 0) then\r\n Inc(FromIndex);\r\n ToIndex := BinarySearch(ToKey);\r\n if (FromIndex >= 0) and (FromIndex <= ToIndex) then\r\n begin\r\n NewMap.SetCapacity(ToIndex - FromIndex + 1);\r\n NewMap.FSize := ToIndex - FromIndex + 1;\r\n while ToIndex >= FromIndex do\r\n begin\r\n NewMap.FEntries[ToIndex - FromIndex] := FEntries[ToIndex];\r\n Dec(ToIndex);\r\n end;\r\n end;\r\n Result := NewMap;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfExtendedSortedMap.TailMap(const FromKey: IInterface): IJclIntfExtendedSortedMap;\r\nvar\r\n FromIndex, Index: Integer;\r\n NewMap: TJclIntfExtendedSortedMap;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n NewMap := CreateEmptyContainer as TJclIntfExtendedSortedMap;\r\n FromIndex := BinarySearch(FromKey);\r\n if (FromIndex = -1) or (KeysCompare(FEntries[FromIndex].Key, FromKey) < 0) then\r\n Inc(FromIndex);\r\n if (FromIndex >= 0) and (FromIndex < FSize) then\r\n begin\r\n NewMap.SetCapacity(FSize - FromIndex);\r\n NewMap.FSize := FSize - FromIndex;\r\n Index := FromIndex;\r\n while Index < FSize do\r\n begin\r\n NewMap.FEntries[Index - FromIndex] := FEntries[Index];\r\n Inc(Index);\r\n end;\r\n end;\r\n Result := NewMap;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfExtendedSortedMap.Values: IJclExtendedCollection;\r\nvar\r\n Index: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := TJclExtendedArrayList.Create(FSize);\r\n for Index := 0 to FSize - 1 do\r\n Result.Add(FEntries[Index].Value);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfExtendedSortedMap.CreateEmptyContainer: TJclAbstractContainerBase;\r\nbegin\r\n Result := TJclIntfExtendedSortedMap.Create(FSize);\r\n AssignPropertiesTo(Result);\r\nend;\r\n\r\nfunction TJclIntfExtendedSortedMap.FreeKey(var Key: IInterface): IInterface;\r\nbegin\r\n Result := Key;\r\n Key := nil;\r\nend;\r\n\r\nfunction TJclIntfExtendedSortedMap.FreeValue(var Value: Extended): Extended;\r\nbegin\r\n Result := Value;\r\n Value := 0.0;\r\nend;\r\n\r\nfunction TJclIntfExtendedSortedMap.KeysCompare(const A, B: IInterface): Integer;\r\nbegin\r\n Result := IntfSimpleCompare(A, B);\r\nend;\r\n\r\nfunction TJclIntfExtendedSortedMap.ValuesCompare(const A, B: Extended): Integer;\r\nbegin\r\n Result := ItemsCompare(A, B);\r\nend;\r\n\r\n//=== { TJclExtendedExtendedSortedMap } ==============================================\r\n\r\nconstructor TJclExtendedExtendedSortedMap.Create(ACapacity: Integer);\r\nbegin\r\n inherited Create();\r\n SetCapacity(ACapacity);\r\nend;\r\n\r\ndestructor TJclExtendedExtendedSortedMap.Destroy;\r\nbegin\r\n FReadOnly := False;\r\n Clear;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJclExtendedExtendedSortedMap.AssignDataTo(Dest: TJclAbstractContainerBase);\r\nvar\r\n MyDest: TJclExtendedExtendedSortedMap;\r\nbegin\r\n inherited AssignDataTo(Dest);\r\n if Dest is TJclExtendedExtendedSortedMap then\r\n begin\r\n MyDest := TJclExtendedExtendedSortedMap(Dest);\r\n MyDest.SetCapacity(FSize);\r\n MyDest.FEntries := FEntries;\r\n MyDest.FSize := FSize;\r\n end;\r\nend;\r\n\r\nfunction TJclExtendedExtendedSortedMap.BinarySearch(const Key: Extended): Integer;\r\nvar\r\n HiPos, LoPos, CompPos: Integer;\r\n Comp: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n LoPos := 0;\r\n HiPos := FSize - 1;\r\n CompPos := (HiPos + LoPos) div 2;\r\n while HiPos >= LoPos do\r\n begin\r\n Comp := KeysCompare(FEntries[CompPos].Key, Key);\r\n if Comp < 0 then\r\n LoPos := CompPos + 1\r\n else\r\n if Comp > 0 then\r\n HiPos := CompPos - 1\r\n else\r\n begin\r\n HiPos := CompPos;\r\n LoPos := CompPos + 1;\r\n end;\r\n CompPos := (HiPos + LoPos) div 2;\r\n end;\r\n Result := HiPos;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclExtendedExtendedSortedMap.Clear;\r\nvar\r\n Index: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n for Index := 0 to FSize - 1 do\r\n begin\r\n FreeKey(FEntries[Index].Key);\r\n FreeValue(FEntries[Index].Value);\r\n end;\r\n FSize := 0;\r\n AutoPack;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclExtendedExtendedSortedMap.ContainsKey(const Key: Extended): Boolean;\r\nvar\r\n Index: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Index := BinarySearch(Key);\r\n Result := (Index >= 0) and (KeysCompare(FEntries[Index].Key, Key) = 0);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclExtendedExtendedSortedMap.ContainsValue(const Value: Extended): Boolean;\r\nvar\r\n Index: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n for Index := 0 to FSize - 1 do\r\n if ValuesCompare(FEntries[Index].Value, Value) = 0 then\r\n begin\r\n Result := True;\r\n Break;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclExtendedExtendedSortedMap.FirstKey: Extended;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := 0.0;\r\n if FSize > 0 then\r\n Result := FEntries[0].Key\r\n else\r\n if not FReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclExtendedExtendedSortedMap.Extract(const Key: Extended): Extended;\r\nvar\r\n Index: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Index := BinarySearch(Key);\r\n if (Index >= 0) and (KeysCompare(FEntries[Index].Key, Key) = 0) then\r\n begin\r\n Result := FEntries[Index].Value;\r\n FEntries[Index].Value := 0.0;\r\n FreeKey(FEntries[Index].Key);\r\n if Index < (FSize - 1) then\r\n MoveArray(FEntries, Index + 1, Index, FSize - Index - 1);\r\n Dec(FSize);\r\n AutoPack;\r\n end\r\n else\r\n Result := 0.0;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclExtendedExtendedSortedMap.GetValue(const Key: Extended): Extended;\r\nvar\r\n Index: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Index := BinarySearch(Key);\r\n Result := 0.0;\r\n if (Index >= 0) and (KeysCompare(FEntries[Index].Key, Key) = 0) then\r\n Result := FEntries[Index].Value\r\n else if not FReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclExtendedExtendedSortedMap.HeadMap(const ToKey: Extended): IJclExtendedExtendedSortedMap;\r\nvar\r\n ToIndex: Integer;\r\n NewMap: TJclExtendedExtendedSortedMap;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n NewMap := CreateEmptyContainer as TJclExtendedExtendedSortedMap;\r\n ToIndex := BinarySearch(ToKey);\r\n if ToIndex >= 0 then\r\n begin\r\n NewMap.SetCapacity(ToIndex + 1);\r\n NewMap.FSize := ToIndex + 1;\r\n while ToIndex >= 0 do\r\n begin\r\n NewMap.FEntries[ToIndex] := FEntries[ToIndex];\r\n Dec(ToIndex);\r\n end;\r\n end;\r\n Result := NewMap;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclExtendedExtendedSortedMap.IsEmpty: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := FSize = 0;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclExtendedExtendedSortedMap.KeyOfValue(const Value: Extended): Extended;\r\nvar\r\n Index: Integer;\r\n Found: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Found := False;\r\n Result := 0.0;\r\n for Index := 0 to FSize - 1 do\r\n if ValuesCompare(FEntries[Index].Value, Value) = 0 then\r\n begin\r\n Result := FEntries[Index].Key;\r\n Found := True;\r\n Break;\r\n end;\r\n\r\n if (not Found) and (not FReturnDefaultElements) then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclExtendedExtendedSortedMap.KeySet: IJclExtendedSet;\r\nvar\r\n Index: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := TJclExtendedArraySet.Create(FSize);\r\n for Index := 0 to FSize - 1 do\r\n Result.Add(FEntries[Index].Key);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclExtendedExtendedSortedMap.LastKey: Extended;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := 0.0;\r\n if FSize > 0 then\r\n Result := FEntries[FSize - 1].Key\r\n else\r\n if not FReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclExtendedExtendedSortedMap.MapEquals(const AMap: IJclExtendedExtendedMap): Boolean;\r\nvar\r\n It: IJclExtendedIterator;\r\n Index: Integer;\r\n AKey: Extended;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if AMap = nil then\r\n Exit;\r\n if FSize <> AMap.Size then\r\n Exit;\r\n It := AMap.KeySet.First;\r\n Index := 0;\r\n while It.HasNext do\r\n begin\r\n if Index >= FSize then\r\n Exit;\r\n AKey := It.Next;\r\n if ValuesCompare(AMap.GetValue(AKey), FEntries[Index].Value) <> 0 then\r\n Exit;\r\n Inc(Index);\r\n end;\r\n Result := True;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclExtendedExtendedSortedMap.InitializeArrayAfterMove(var List: TJclExtendedExtendedSortedMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\nbegin\r\n { Clean array }\r\n if FromIndex < ToIndex then\r\n begin\r\n if (ToIndex - FromIndex) < Count then\r\n Count := ToIndex - FromIndex;\r\n FillChar(List[FromIndex], Count * SizeOf(List[0]), 0);\r\n end\r\n else\r\n if FromIndex > ToIndex then\r\n begin\r\n if (FromIndex - ToIndex) < Count then\r\n FillChar(List[ToIndex + Count], (FromIndex - ToIndex) * SizeOf(List[0]), 0)\r\n else\r\n FillChar(List[FromIndex], Count * SizeOf(List[0]), 0);\r\n end;\r\nend;\r\n\r\nprocedure TJclExtendedExtendedSortedMap.MoveArray(var List: TJclExtendedExtendedSortedMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\nbegin\r\n if Count > 0 then\r\n begin\r\n Move(List[FromIndex], List[ToIndex], Count * SizeOf(List[0]));\r\n InitializeArrayAfterMove(List, FromIndex, ToIndex, Count);\r\n end;\r\nend;\r\n\r\nprocedure TJclExtendedExtendedSortedMap.PutAll(const AMap: IJclExtendedExtendedMap);\r\nvar\r\n It: IJclExtendedIterator;\r\n Key: Extended;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if AMap = nil then\r\n Exit;\r\n It := AMap.KeySet.First;\r\n while It.HasNext do\r\n begin\r\n Key := It.Next;\r\n PutValue(Key, AMap.GetValue(Key));\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclExtendedExtendedSortedMap.PutValue(const Key: Extended; const Value: Extended);\r\nvar\r\n Index: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FAllowDefaultElements or ((KeysCompare(Key, 0.0) <> 0) and (ValuesCompare(Value, 0.0) <> 0)) then\r\n begin\r\n Index := BinarySearch(Key);\r\n\r\n if (Index >= 0) and (KeysCompare(FEntries[Index].Key, Key) = 0) then\r\n begin\r\n FreeValue(FEntries[Index].Value);\r\n FEntries[Index].Value := Value;\r\n end\r\n else\r\n begin\r\n if FSize = FCapacity then\r\n AutoGrow;\r\n if FSize < FCapacity then\r\n begin\r\n Inc(Index);\r\n if (Index < FSize) and (KeysCompare(FEntries[Index].Key, Key) <> 0) then\r\n MoveArray(FEntries, Index, Index + 1, FSize - Index);\r\n FEntries[Index].Key := Key;\r\n FEntries[Index].Value := Value;\r\n Inc(FSize);\r\n end;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclExtendedExtendedSortedMap.Remove(const Key: Extended): Extended;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := Extract(Key);\r\n Result := FreeValue(Result);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclExtendedExtendedSortedMap.SetCapacity(Value: Integer);\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FSize <= Value then\r\n begin\r\n SetLength(FEntries, Value);\r\n inherited SetCapacity(Value);\r\n end\r\n else\r\n raise EJclOperationNotSupportedError.Create;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclExtendedExtendedSortedMap.Size: Integer;\r\nbegin\r\n Result := FSize;\r\nend;\r\n\r\nfunction TJclExtendedExtendedSortedMap.SubMap(const FromKey, ToKey: Extended): IJclExtendedExtendedSortedMap;\r\nvar\r\n FromIndex, ToIndex: Integer;\r\n NewMap: TJclExtendedExtendedSortedMap;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n NewMap := CreateEmptyContainer as TJclExtendedExtendedSortedMap;\r\n FromIndex := BinarySearch(FromKey);\r\n if (FromIndex = -1) or (KeysCompare(FEntries[FromIndex].Key, FromKey) < 0) then\r\n Inc(FromIndex);\r\n ToIndex := BinarySearch(ToKey);\r\n if (FromIndex >= 0) and (FromIndex <= ToIndex) then\r\n begin\r\n NewMap.SetCapacity(ToIndex - FromIndex + 1);\r\n NewMap.FSize := ToIndex - FromIndex + 1;\r\n while ToIndex >= FromIndex do\r\n begin\r\n NewMap.FEntries[ToIndex - FromIndex] := FEntries[ToIndex];\r\n Dec(ToIndex);\r\n end;\r\n end;\r\n Result := NewMap;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclExtendedExtendedSortedMap.TailMap(const FromKey: Extended): IJclExtendedExtendedSortedMap;\r\nvar\r\n FromIndex, Index: Integer;\r\n NewMap: TJclExtendedExtendedSortedMap;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n NewMap := CreateEmptyContainer as TJclExtendedExtendedSortedMap;\r\n FromIndex := BinarySearch(FromKey);\r\n if (FromIndex = -1) or (KeysCompare(FEntries[FromIndex].Key, FromKey) < 0) then\r\n Inc(FromIndex);\r\n if (FromIndex >= 0) and (FromIndex < FSize) then\r\n begin\r\n NewMap.SetCapacity(FSize - FromIndex);\r\n NewMap.FSize := FSize - FromIndex;\r\n Index := FromIndex;\r\n while Index < FSize do\r\n begin\r\n NewMap.FEntries[Index - FromIndex] := FEntries[Index];\r\n Inc(Index);\r\n end;\r\n end;\r\n Result := NewMap;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclExtendedExtendedSortedMap.Values: IJclExtendedCollection;\r\nvar\r\n Index: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := TJclExtendedArrayList.Create(FSize);\r\n for Index := 0 to FSize - 1 do\r\n Result.Add(FEntries[Index].Value);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclExtendedExtendedSortedMap.CreateEmptyContainer: TJclAbstractContainerBase;\r\nbegin\r\n Result := TJclExtendedExtendedSortedMap.Create(FSize);\r\n AssignPropertiesTo(Result);\r\nend;\r\n\r\nfunction TJclExtendedExtendedSortedMap.FreeKey(var Key: Extended): Extended;\r\nbegin\r\n Result := Key;\r\n Key := 0.0;\r\nend;\r\n\r\nfunction TJclExtendedExtendedSortedMap.FreeValue(var Value: Extended): Extended;\r\nbegin\r\n Result := Value;\r\n Value := 0.0;\r\nend;\r\n\r\nfunction TJclExtendedExtendedSortedMap.KeysCompare(const A, B: Extended): Integer;\r\nbegin\r\n Result := ItemsCompare(A, B);\r\nend;\r\n\r\nfunction TJclExtendedExtendedSortedMap.ValuesCompare(const A, B: Extended): Integer;\r\nbegin\r\n Result := ItemsCompare(A, B);\r\nend;\r\n\r\n//=== { TJclIntegerIntfSortedMap } ==============================================\r\n\r\nconstructor TJclIntegerIntfSortedMap.Create(ACapacity: Integer);\r\nbegin\r\n inherited Create();\r\n SetCapacity(ACapacity);\r\nend;\r\n\r\ndestructor TJclIntegerIntfSortedMap.Destroy;\r\nbegin\r\n FReadOnly := False;\r\n Clear;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJclIntegerIntfSortedMap.AssignDataTo(Dest: TJclAbstractContainerBase);\r\nvar\r\n MyDest: TJclIntegerIntfSortedMap;\r\nbegin\r\n inherited AssignDataTo(Dest);\r\n if Dest is TJclIntegerIntfSortedMap then\r\n begin\r\n MyDest := TJclIntegerIntfSortedMap(Dest);\r\n MyDest.SetCapacity(FSize);\r\n MyDest.FEntries := FEntries;\r\n MyDest.FSize := FSize;\r\n end;\r\nend;\r\n\r\nfunction TJclIntegerIntfSortedMap.BinarySearch(Key: Integer): Integer;\r\nvar\r\n HiPos, LoPos, CompPos: Integer;\r\n Comp: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n LoPos := 0;\r\n HiPos := FSize - 1;\r\n CompPos := (HiPos + LoPos) div 2;\r\n while HiPos >= LoPos do\r\n begin\r\n Comp := KeysCompare(FEntries[CompPos].Key, Key);\r\n if Comp < 0 then\r\n LoPos := CompPos + 1\r\n else\r\n if Comp > 0 then\r\n HiPos := CompPos - 1\r\n else\r\n begin\r\n HiPos := CompPos;\r\n LoPos := CompPos + 1;\r\n end;\r\n CompPos := (HiPos + LoPos) div 2;\r\n end;\r\n Result := HiPos;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclIntegerIntfSortedMap.Clear;\r\nvar\r\n Index: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n for Index := 0 to FSize - 1 do\r\n begin\r\n FreeKey(FEntries[Index].Key);\r\n FreeValue(FEntries[Index].Value);\r\n end;\r\n FSize := 0;\r\n AutoPack;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntegerIntfSortedMap.ContainsKey(Key: Integer): Boolean;\r\nvar\r\n Index: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Index := BinarySearch(Key);\r\n Result := (Index >= 0) and (KeysCompare(FEntries[Index].Key, Key) = 0);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntegerIntfSortedMap.ContainsValue(const Value: IInterface): Boolean;\r\nvar\r\n Index: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n for Index := 0 to FSize - 1 do\r\n if ValuesCompare(FEntries[Index].Value, Value) = 0 then\r\n begin\r\n Result := True;\r\n Break;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntegerIntfSortedMap.FirstKey: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := 0;\r\n if FSize > 0 then\r\n Result := FEntries[0].Key\r\n else\r\n if not FReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntegerIntfSortedMap.Extract(Key: Integer): IInterface;\r\nvar\r\n Index: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Index := BinarySearch(Key);\r\n if (Index >= 0) and (KeysCompare(FEntries[Index].Key, Key) = 0) then\r\n begin\r\n Result := FEntries[Index].Value;\r\n FEntries[Index].Value := nil;\r\n FreeKey(FEntries[Index].Key);\r\n if Index < (FSize - 1) then\r\n MoveArray(FEntries, Index + 1, Index, FSize - Index - 1);\r\n Dec(FSize);\r\n AutoPack;\r\n end\r\n else\r\n Result := nil;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntegerIntfSortedMap.GetValue(Key: Integer): IInterface;\r\nvar\r\n Index: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Index := BinarySearch(Key);\r\n Result := nil;\r\n if (Index >= 0) and (KeysCompare(FEntries[Index].Key, Key) = 0) then\r\n Result := FEntries[Index].Value\r\n else if not FReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntegerIntfSortedMap.HeadMap(ToKey: Integer): IJclIntegerIntfSortedMap;\r\nvar\r\n ToIndex: Integer;\r\n NewMap: TJclIntegerIntfSortedMap;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n NewMap := CreateEmptyContainer as TJclIntegerIntfSortedMap;\r\n ToIndex := BinarySearch(ToKey);\r\n if ToIndex >= 0 then\r\n begin\r\n NewMap.SetCapacity(ToIndex + 1);\r\n NewMap.FSize := ToIndex + 1;\r\n while ToIndex >= 0 do\r\n begin\r\n NewMap.FEntries[ToIndex] := FEntries[ToIndex];\r\n Dec(ToIndex);\r\n end;\r\n end;\r\n Result := NewMap;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntegerIntfSortedMap.IsEmpty: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := FSize = 0;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntegerIntfSortedMap.KeyOfValue(const Value: IInterface): Integer;\r\nvar\r\n Index: Integer;\r\n Found: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Found := False;\r\n Result := 0;\r\n for Index := 0 to FSize - 1 do\r\n if ValuesCompare(FEntries[Index].Value, Value) = 0 then\r\n begin\r\n Result := FEntries[Index].Key;\r\n Found := True;\r\n Break;\r\n end;\r\n\r\n if (not Found) and (not FReturnDefaultElements) then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntegerIntfSortedMap.KeySet: IJclIntegerSet;\r\nvar\r\n Index: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := TJclIntegerArraySet.Create(FSize);\r\n for Index := 0 to FSize - 1 do\r\n Result.Add(FEntries[Index].Key);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntegerIntfSortedMap.LastKey: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := 0;\r\n if FSize > 0 then\r\n Result := FEntries[FSize - 1].Key\r\n else\r\n if not FReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntegerIntfSortedMap.MapEquals(const AMap: IJclIntegerIntfMap): Boolean;\r\nvar\r\n It: IJclIntegerIterator;\r\n Index: Integer;\r\n AKey: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if AMap = nil then\r\n Exit;\r\n if FSize <> AMap.Size then\r\n Exit;\r\n It := AMap.KeySet.First;\r\n Index := 0;\r\n while It.HasNext do\r\n begin\r\n if Index >= FSize then\r\n Exit;\r\n AKey := It.Next;\r\n if ValuesCompare(AMap.GetValue(AKey), FEntries[Index].Value) <> 0 then\r\n Exit;\r\n Inc(Index);\r\n end;\r\n Result := True;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclIntegerIntfSortedMap.FinalizeArrayBeforeMove(var List: TJclIntegerIntfSortedMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\nbegin\r\n Assert(Count > 0);\r\n if FromIndex < ToIndex then\r\n begin\r\n if Count > (ToIndex - FromIndex) then\r\n Finalize(List[FromIndex + Count], ToIndex - FromIndex)\r\n else\r\n Finalize(List[ToIndex], Count);\r\n end\r\n else\r\n if FromIndex > ToIndex then\r\n begin\r\n if Count > (FromIndex - ToIndex) then\r\n Count := FromIndex - ToIndex;\r\n Finalize(List[ToIndex], Count)\r\n end;\r\nend;\r\n\r\nprocedure TJclIntegerIntfSortedMap.InitializeArray(var List: TJclIntegerIntfSortedMapEntryArray; FromIndex, Count: SizeInt);\r\nbegin\r\n {$IFDEF FPC}\r\n while Count > 0 do\r\n begin\r\n Initialize(List[FromIndex]);\r\n Inc(FromIndex);\r\n Dec(Count);\r\n end;\r\n {$ELSE ~FPC}\r\n Initialize(List[FromIndex], Count);\r\n {$ENDIF ~FPC}\r\nend;\r\n\r\nprocedure TJclIntegerIntfSortedMap.InitializeArrayAfterMove(var List: TJclIntegerIntfSortedMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\nbegin\r\n { Keep reference counting working }\r\n if FromIndex < ToIndex then\r\n begin\r\n if (ToIndex - FromIndex) < Count then\r\n Count := ToIndex - FromIndex;\r\n InitializeArray(List, FromIndex, Count);\r\n end\r\n else\r\n if FromIndex > ToIndex then\r\n begin\r\n if (FromIndex - ToIndex) < Count then\r\n InitializeArray(List, ToIndex + Count, FromIndex - ToIndex)\r\n else\r\n InitializeArray(List, FromIndex, Count);\r\n end;\r\nend;\r\n\r\nprocedure TJclIntegerIntfSortedMap.MoveArray(var List: TJclIntegerIntfSortedMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\nbegin\r\n if Count > 0 then\r\n begin\r\n FinalizeArrayBeforeMove(List, FromIndex, ToIndex, Count);\r\n Move(List[FromIndex], List[ToIndex], Count * SizeOf(List[0]));\r\n InitializeArrayAfterMove(List, FromIndex, ToIndex, Count);\r\n end;\r\nend;\r\n\r\nprocedure TJclIntegerIntfSortedMap.PutAll(const AMap: IJclIntegerIntfMap);\r\nvar\r\n It: IJclIntegerIterator;\r\n Key: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if AMap = nil then\r\n Exit;\r\n It := AMap.KeySet.First;\r\n while It.HasNext do\r\n begin\r\n Key := It.Next;\r\n PutValue(Key, AMap.GetValue(Key));\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclIntegerIntfSortedMap.PutValue(Key: Integer; const Value: IInterface);\r\nvar\r\n Index: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FAllowDefaultElements or ((KeysCompare(Key, 0) <> 0) and (ValuesCompare(Value, nil) <> 0)) then\r\n begin\r\n Index := BinarySearch(Key);\r\n\r\n if (Index >= 0) and (KeysCompare(FEntries[Index].Key, Key) = 0) then\r\n begin\r\n FreeValue(FEntries[Index].Value);\r\n FEntries[Index].Value := Value;\r\n end\r\n else\r\n begin\r\n if FSize = FCapacity then\r\n AutoGrow;\r\n if FSize < FCapacity then\r\n begin\r\n Inc(Index);\r\n if (Index < FSize) and (KeysCompare(FEntries[Index].Key, Key) <> 0) then\r\n MoveArray(FEntries, Index, Index + 1, FSize - Index);\r\n FEntries[Index].Key := Key;\r\n FEntries[Index].Value := Value;\r\n Inc(FSize);\r\n end;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntegerIntfSortedMap.Remove(Key: Integer): IInterface;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := Extract(Key);\r\n Result := FreeValue(Result);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclIntegerIntfSortedMap.SetCapacity(Value: Integer);\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FSize <= Value then\r\n begin\r\n SetLength(FEntries, Value);\r\n inherited SetCapacity(Value);\r\n end\r\n else\r\n raise EJclOperationNotSupportedError.Create;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntegerIntfSortedMap.Size: Integer;\r\nbegin\r\n Result := FSize;\r\nend;\r\n\r\nfunction TJclIntegerIntfSortedMap.SubMap(FromKey, ToKey: Integer): IJclIntegerIntfSortedMap;\r\nvar\r\n FromIndex, ToIndex: Integer;\r\n NewMap: TJclIntegerIntfSortedMap;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n NewMap := CreateEmptyContainer as TJclIntegerIntfSortedMap;\r\n FromIndex := BinarySearch(FromKey);\r\n if (FromIndex = -1) or (KeysCompare(FEntries[FromIndex].Key, FromKey) < 0) then\r\n Inc(FromIndex);\r\n ToIndex := BinarySearch(ToKey);\r\n if (FromIndex >= 0) and (FromIndex <= ToIndex) then\r\n begin\r\n NewMap.SetCapacity(ToIndex - FromIndex + 1);\r\n NewMap.FSize := ToIndex - FromIndex + 1;\r\n while ToIndex >= FromIndex do\r\n begin\r\n NewMap.FEntries[ToIndex - FromIndex] := FEntries[ToIndex];\r\n Dec(ToIndex);\r\n end;\r\n end;\r\n Result := NewMap;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntegerIntfSortedMap.TailMap(FromKey: Integer): IJclIntegerIntfSortedMap;\r\nvar\r\n FromIndex, Index: Integer;\r\n NewMap: TJclIntegerIntfSortedMap;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n NewMap := CreateEmptyContainer as TJclIntegerIntfSortedMap;\r\n FromIndex := BinarySearch(FromKey);\r\n if (FromIndex = -1) or (KeysCompare(FEntries[FromIndex].Key, FromKey) < 0) then\r\n Inc(FromIndex);\r\n if (FromIndex >= 0) and (FromIndex < FSize) then\r\n begin\r\n NewMap.SetCapacity(FSize - FromIndex);\r\n NewMap.FSize := FSize - FromIndex;\r\n Index := FromIndex;\r\n while Index < FSize do\r\n begin\r\n NewMap.FEntries[Index - FromIndex] := FEntries[Index];\r\n Inc(Index);\r\n end;\r\n end;\r\n Result := NewMap;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntegerIntfSortedMap.Values: IJclIntfCollection;\r\nvar\r\n Index: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := TJclIntfArrayList.Create(FSize);\r\n for Index := 0 to FSize - 1 do\r\n Result.Add(FEntries[Index].Value);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntegerIntfSortedMap.CreateEmptyContainer: TJclAbstractContainerBase;\r\nbegin\r\n Result := TJclIntegerIntfSortedMap.Create(FSize);\r\n AssignPropertiesTo(Result);\r\nend;\r\n\r\nfunction TJclIntegerIntfSortedMap.FreeKey(var Key: Integer): Integer;\r\nbegin\r\n Result := Key;\r\n Key := 0;\r\nend;\r\n\r\nfunction TJclIntegerIntfSortedMap.FreeValue(var Value: IInterface): IInterface;\r\nbegin\r\n Result := Value;\r\n Value := nil;\r\nend;\r\n\r\nfunction TJclIntegerIntfSortedMap.KeysCompare(A, B: Integer): Integer;\r\nbegin\r\n Result := ItemsCompare(A, B);\r\nend;\r\n\r\nfunction TJclIntegerIntfSortedMap.ValuesCompare(const A, B: IInterface): Integer;\r\nbegin\r\n Result := IntfSimpleCompare(A, B);\r\nend;\r\n\r\n//=== { TJclIntfIntegerSortedMap } ==============================================\r\n\r\nconstructor TJclIntfIntegerSortedMap.Create(ACapacity: Integer);\r\nbegin\r\n inherited Create();\r\n SetCapacity(ACapacity);\r\nend;\r\n\r\ndestructor TJclIntfIntegerSortedMap.Destroy;\r\nbegin\r\n FReadOnly := False;\r\n Clear;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJclIntfIntegerSortedMap.AssignDataTo(Dest: TJclAbstractContainerBase);\r\nvar\r\n MyDest: TJclIntfIntegerSortedMap;\r\nbegin\r\n inherited AssignDataTo(Dest);\r\n if Dest is TJclIntfIntegerSortedMap then\r\n begin\r\n MyDest := TJclIntfIntegerSortedMap(Dest);\r\n MyDest.SetCapacity(FSize);\r\n MyDest.FEntries := FEntries;\r\n MyDest.FSize := FSize;\r\n end;\r\nend;\r\n\r\nfunction TJclIntfIntegerSortedMap.BinarySearch(const Key: IInterface): Integer;\r\nvar\r\n HiPos, LoPos, CompPos: Integer;\r\n Comp: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n LoPos := 0;\r\n HiPos := FSize - 1;\r\n CompPos := (HiPos + LoPos) div 2;\r\n while HiPos >= LoPos do\r\n begin\r\n Comp := KeysCompare(FEntries[CompPos].Key, Key);\r\n if Comp < 0 then\r\n LoPos := CompPos + 1\r\n else\r\n if Comp > 0 then\r\n HiPos := CompPos - 1\r\n else\r\n begin\r\n HiPos := CompPos;\r\n LoPos := CompPos + 1;\r\n end;\r\n CompPos := (HiPos + LoPos) div 2;\r\n end;\r\n Result := HiPos;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclIntfIntegerSortedMap.Clear;\r\nvar\r\n Index: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n for Index := 0 to FSize - 1 do\r\n begin\r\n FreeKey(FEntries[Index].Key);\r\n FreeValue(FEntries[Index].Value);\r\n end;\r\n FSize := 0;\r\n AutoPack;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfIntegerSortedMap.ContainsKey(const Key: IInterface): Boolean;\r\nvar\r\n Index: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Index := BinarySearch(Key);\r\n Result := (Index >= 0) and (KeysCompare(FEntries[Index].Key, Key) = 0);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfIntegerSortedMap.ContainsValue(Value: Integer): Boolean;\r\nvar\r\n Index: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n for Index := 0 to FSize - 1 do\r\n if ValuesCompare(FEntries[Index].Value, Value) = 0 then\r\n begin\r\n Result := True;\r\n Break;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfIntegerSortedMap.FirstKey: IInterface;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := nil;\r\n if FSize > 0 then\r\n Result := FEntries[0].Key\r\n else\r\n if not FReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfIntegerSortedMap.Extract(const Key: IInterface): Integer;\r\nvar\r\n Index: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Index := BinarySearch(Key);\r\n if (Index >= 0) and (KeysCompare(FEntries[Index].Key, Key) = 0) then\r\n begin\r\n Result := FEntries[Index].Value;\r\n FEntries[Index].Value := 0;\r\n FreeKey(FEntries[Index].Key);\r\n if Index < (FSize - 1) then\r\n MoveArray(FEntries, Index + 1, Index, FSize - Index - 1);\r\n Dec(FSize);\r\n AutoPack;\r\n end\r\n else\r\n Result := 0;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfIntegerSortedMap.GetValue(const Key: IInterface): Integer;\r\nvar\r\n Index: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Index := BinarySearch(Key);\r\n Result := 0;\r\n if (Index >= 0) and (KeysCompare(FEntries[Index].Key, Key) = 0) then\r\n Result := FEntries[Index].Value\r\n else if not FReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfIntegerSortedMap.HeadMap(const ToKey: IInterface): IJclIntfIntegerSortedMap;\r\nvar\r\n ToIndex: Integer;\r\n NewMap: TJclIntfIntegerSortedMap;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n NewMap := CreateEmptyContainer as TJclIntfIntegerSortedMap;\r\n ToIndex := BinarySearch(ToKey);\r\n if ToIndex >= 0 then\r\n begin\r\n NewMap.SetCapacity(ToIndex + 1);\r\n NewMap.FSize := ToIndex + 1;\r\n while ToIndex >= 0 do\r\n begin\r\n NewMap.FEntries[ToIndex] := FEntries[ToIndex];\r\n Dec(ToIndex);\r\n end;\r\n end;\r\n Result := NewMap;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfIntegerSortedMap.IsEmpty: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := FSize = 0;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfIntegerSortedMap.KeyOfValue(Value: Integer): IInterface;\r\nvar\r\n Index: Integer;\r\n Found: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Found := False;\r\n Result := nil;\r\n for Index := 0 to FSize - 1 do\r\n if ValuesCompare(FEntries[Index].Value, Value) = 0 then\r\n begin\r\n Result := FEntries[Index].Key;\r\n Found := True;\r\n Break;\r\n end;\r\n\r\n if (not Found) and (not FReturnDefaultElements) then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfIntegerSortedMap.KeySet: IJclIntfSet;\r\nvar\r\n Index: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := TJclIntfArraySet.Create(FSize);\r\n for Index := 0 to FSize - 1 do\r\n Result.Add(FEntries[Index].Key);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfIntegerSortedMap.LastKey: IInterface;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := nil;\r\n if FSize > 0 then\r\n Result := FEntries[FSize - 1].Key\r\n else\r\n if not FReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfIntegerSortedMap.MapEquals(const AMap: IJclIntfIntegerMap): Boolean;\r\nvar\r\n It: IJclIntfIterator;\r\n Index: Integer;\r\n AKey: IInterface;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if AMap = nil then\r\n Exit;\r\n if FSize <> AMap.Size then\r\n Exit;\r\n It := AMap.KeySet.First;\r\n Index := 0;\r\n while It.HasNext do\r\n begin\r\n if Index >= FSize then\r\n Exit;\r\n AKey := It.Next;\r\n if ValuesCompare(AMap.GetValue(AKey), FEntries[Index].Value) <> 0 then\r\n Exit;\r\n Inc(Index);\r\n end;\r\n Result := True;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclIntfIntegerSortedMap.FinalizeArrayBeforeMove(var List: TJclIntfIntegerSortedMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\nbegin\r\n Assert(Count > 0);\r\n if FromIndex < ToIndex then\r\n begin\r\n if Count > (ToIndex - FromIndex) then\r\n Finalize(List[FromIndex + Count], ToIndex - FromIndex)\r\n else\r\n Finalize(List[ToIndex], Count);\r\n end\r\n else\r\n if FromIndex > ToIndex then\r\n begin\r\n if Count > (FromIndex - ToIndex) then\r\n Count := FromIndex - ToIndex;\r\n Finalize(List[ToIndex], Count)\r\n end;\r\nend;\r\n\r\nprocedure TJclIntfIntegerSortedMap.InitializeArray(var List: TJclIntfIntegerSortedMapEntryArray; FromIndex, Count: SizeInt);\r\nbegin\r\n {$IFDEF FPC}\r\n while Count > 0 do\r\n begin\r\n Initialize(List[FromIndex]);\r\n Inc(FromIndex);\r\n Dec(Count);\r\n end;\r\n {$ELSE ~FPC}\r\n Initialize(List[FromIndex], Count);\r\n {$ENDIF ~FPC}\r\nend;\r\n\r\nprocedure TJclIntfIntegerSortedMap.InitializeArrayAfterMove(var List: TJclIntfIntegerSortedMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\nbegin\r\n { Keep reference counting working }\r\n if FromIndex < ToIndex then\r\n begin\r\n if (ToIndex - FromIndex) < Count then\r\n Count := ToIndex - FromIndex;\r\n InitializeArray(List, FromIndex, Count);\r\n end\r\n else\r\n if FromIndex > ToIndex then\r\n begin\r\n if (FromIndex - ToIndex) < Count then\r\n InitializeArray(List, ToIndex + Count, FromIndex - ToIndex)\r\n else\r\n InitializeArray(List, FromIndex, Count);\r\n end;\r\nend;\r\n\r\nprocedure TJclIntfIntegerSortedMap.MoveArray(var List: TJclIntfIntegerSortedMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\nbegin\r\n if Count > 0 then\r\n begin\r\n FinalizeArrayBeforeMove(List, FromIndex, ToIndex, Count);\r\n Move(List[FromIndex], List[ToIndex], Count * SizeOf(List[0]));\r\n InitializeArrayAfterMove(List, FromIndex, ToIndex, Count);\r\n end;\r\nend;\r\n\r\nprocedure TJclIntfIntegerSortedMap.PutAll(const AMap: IJclIntfIntegerMap);\r\nvar\r\n It: IJclIntfIterator;\r\n Key: IInterface;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if AMap = nil then\r\n Exit;\r\n It := AMap.KeySet.First;\r\n while It.HasNext do\r\n begin\r\n Key := It.Next;\r\n PutValue(Key, AMap.GetValue(Key));\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclIntfIntegerSortedMap.PutValue(const Key: IInterface; Value: Integer);\r\nvar\r\n Index: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FAllowDefaultElements or ((KeysCompare(Key, nil) <> 0) and (ValuesCompare(Value, 0) <> 0)) then\r\n begin\r\n Index := BinarySearch(Key);\r\n\r\n if (Index >= 0) and (KeysCompare(FEntries[Index].Key, Key) = 0) then\r\n begin\r\n FreeValue(FEntries[Index].Value);\r\n FEntries[Index].Value := Value;\r\n end\r\n else\r\n begin\r\n if FSize = FCapacity then\r\n AutoGrow;\r\n if FSize < FCapacity then\r\n begin\r\n Inc(Index);\r\n if (Index < FSize) and (KeysCompare(FEntries[Index].Key, Key) <> 0) then\r\n MoveArray(FEntries, Index, Index + 1, FSize - Index);\r\n FEntries[Index].Key := Key;\r\n FEntries[Index].Value := Value;\r\n Inc(FSize);\r\n end;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfIntegerSortedMap.Remove(const Key: IInterface): Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := Extract(Key);\r\n Result := FreeValue(Result);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclIntfIntegerSortedMap.SetCapacity(Value: Integer);\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FSize <= Value then\r\n begin\r\n SetLength(FEntries, Value);\r\n inherited SetCapacity(Value);\r\n end\r\n else\r\n raise EJclOperationNotSupportedError.Create;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfIntegerSortedMap.Size: Integer;\r\nbegin\r\n Result := FSize;\r\nend;\r\n\r\nfunction TJclIntfIntegerSortedMap.SubMap(const FromKey, ToKey: IInterface): IJclIntfIntegerSortedMap;\r\nvar\r\n FromIndex, ToIndex: Integer;\r\n NewMap: TJclIntfIntegerSortedMap;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n NewMap := CreateEmptyContainer as TJclIntfIntegerSortedMap;\r\n FromIndex := BinarySearch(FromKey);\r\n if (FromIndex = -1) or (KeysCompare(FEntries[FromIndex].Key, FromKey) < 0) then\r\n Inc(FromIndex);\r\n ToIndex := BinarySearch(ToKey);\r\n if (FromIndex >= 0) and (FromIndex <= ToIndex) then\r\n begin\r\n NewMap.SetCapacity(ToIndex - FromIndex + 1);\r\n NewMap.FSize := ToIndex - FromIndex + 1;\r\n while ToIndex >= FromIndex do\r\n begin\r\n NewMap.FEntries[ToIndex - FromIndex] := FEntries[ToIndex];\r\n Dec(ToIndex);\r\n end;\r\n end;\r\n Result := NewMap;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfIntegerSortedMap.TailMap(const FromKey: IInterface): IJclIntfIntegerSortedMap;\r\nvar\r\n FromIndex, Index: Integer;\r\n NewMap: TJclIntfIntegerSortedMap;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n NewMap := CreateEmptyContainer as TJclIntfIntegerSortedMap;\r\n FromIndex := BinarySearch(FromKey);\r\n if (FromIndex = -1) or (KeysCompare(FEntries[FromIndex].Key, FromKey) < 0) then\r\n Inc(FromIndex);\r\n if (FromIndex >= 0) and (FromIndex < FSize) then\r\n begin\r\n NewMap.SetCapacity(FSize - FromIndex);\r\n NewMap.FSize := FSize - FromIndex;\r\n Index := FromIndex;\r\n while Index < FSize do\r\n begin\r\n NewMap.FEntries[Index - FromIndex] := FEntries[Index];\r\n Inc(Index);\r\n end;\r\n end;\r\n Result := NewMap;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfIntegerSortedMap.Values: IJclIntegerCollection;\r\nvar\r\n Index: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := TJclIntegerArrayList.Create(FSize);\r\n for Index := 0 to FSize - 1 do\r\n Result.Add(FEntries[Index].Value);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfIntegerSortedMap.CreateEmptyContainer: TJclAbstractContainerBase;\r\nbegin\r\n Result := TJclIntfIntegerSortedMap.Create(FSize);\r\n AssignPropertiesTo(Result);\r\nend;\r\n\r\nfunction TJclIntfIntegerSortedMap.FreeKey(var Key: IInterface): IInterface;\r\nbegin\r\n Result := Key;\r\n Key := nil;\r\nend;\r\n\r\nfunction TJclIntfIntegerSortedMap.FreeValue(var Value: Integer): Integer;\r\nbegin\r\n Result := Value;\r\n Value := 0;\r\nend;\r\n\r\nfunction TJclIntfIntegerSortedMap.KeysCompare(const A, B: IInterface): Integer;\r\nbegin\r\n Result := IntfSimpleCompare(A, B);\r\nend;\r\n\r\nfunction TJclIntfIntegerSortedMap.ValuesCompare(A, B: Integer): Integer;\r\nbegin\r\n Result := ItemsCompare(A, B);\r\nend;\r\n\r\n//=== { TJclIntegerIntegerSortedMap } ==============================================\r\n\r\nconstructor TJclIntegerIntegerSortedMap.Create(ACapacity: Integer);\r\nbegin\r\n inherited Create();\r\n SetCapacity(ACapacity);\r\nend;\r\n\r\ndestructor TJclIntegerIntegerSortedMap.Destroy;\r\nbegin\r\n FReadOnly := False;\r\n Clear;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJclIntegerIntegerSortedMap.AssignDataTo(Dest: TJclAbstractContainerBase);\r\nvar\r\n MyDest: TJclIntegerIntegerSortedMap;\r\nbegin\r\n inherited AssignDataTo(Dest);\r\n if Dest is TJclIntegerIntegerSortedMap then\r\n begin\r\n MyDest := TJclIntegerIntegerSortedMap(Dest);\r\n MyDest.SetCapacity(FSize);\r\n MyDest.FEntries := FEntries;\r\n MyDest.FSize := FSize;\r\n end;\r\nend;\r\n\r\nfunction TJclIntegerIntegerSortedMap.BinarySearch(Key: Integer): Integer;\r\nvar\r\n HiPos, LoPos, CompPos: Integer;\r\n Comp: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n LoPos := 0;\r\n HiPos := FSize - 1;\r\n CompPos := (HiPos + LoPos) div 2;\r\n while HiPos >= LoPos do\r\n begin\r\n Comp := KeysCompare(FEntries[CompPos].Key, Key);\r\n if Comp < 0 then\r\n LoPos := CompPos + 1\r\n else\r\n if Comp > 0 then\r\n HiPos := CompPos - 1\r\n else\r\n begin\r\n HiPos := CompPos;\r\n LoPos := CompPos + 1;\r\n end;\r\n CompPos := (HiPos + LoPos) div 2;\r\n end;\r\n Result := HiPos;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclIntegerIntegerSortedMap.Clear;\r\nvar\r\n Index: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n for Index := 0 to FSize - 1 do\r\n begin\r\n FreeKey(FEntries[Index].Key);\r\n FreeValue(FEntries[Index].Value);\r\n end;\r\n FSize := 0;\r\n AutoPack;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntegerIntegerSortedMap.ContainsKey(Key: Integer): Boolean;\r\nvar\r\n Index: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Index := BinarySearch(Key);\r\n Result := (Index >= 0) and (KeysCompare(FEntries[Index].Key, Key) = 0);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntegerIntegerSortedMap.ContainsValue(Value: Integer): Boolean;\r\nvar\r\n Index: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n for Index := 0 to FSize - 1 do\r\n if ValuesCompare(FEntries[Index].Value, Value) = 0 then\r\n begin\r\n Result := True;\r\n Break;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntegerIntegerSortedMap.FirstKey: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := 0;\r\n if FSize > 0 then\r\n Result := FEntries[0].Key\r\n else\r\n if not FReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntegerIntegerSortedMap.Extract(Key: Integer): Integer;\r\nvar\r\n Index: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Index := BinarySearch(Key);\r\n if (Index >= 0) and (KeysCompare(FEntries[Index].Key, Key) = 0) then\r\n begin\r\n Result := FEntries[Index].Value;\r\n FEntries[Index].Value := 0;\r\n FreeKey(FEntries[Index].Key);\r\n if Index < (FSize - 1) then\r\n MoveArray(FEntries, Index + 1, Index, FSize - Index - 1);\r\n Dec(FSize);\r\n AutoPack;\r\n end\r\n else\r\n Result := 0;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntegerIntegerSortedMap.GetValue(Key: Integer): Integer;\r\nvar\r\n Index: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Index := BinarySearch(Key);\r\n Result := 0;\r\n if (Index >= 0) and (KeysCompare(FEntries[Index].Key, Key) = 0) then\r\n Result := FEntries[Index].Value\r\n else if not FReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntegerIntegerSortedMap.HeadMap(ToKey: Integer): IJclIntegerIntegerSortedMap;\r\nvar\r\n ToIndex: Integer;\r\n NewMap: TJclIntegerIntegerSortedMap;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n NewMap := CreateEmptyContainer as TJclIntegerIntegerSortedMap;\r\n ToIndex := BinarySearch(ToKey);\r\n if ToIndex >= 0 then\r\n begin\r\n NewMap.SetCapacity(ToIndex + 1);\r\n NewMap.FSize := ToIndex + 1;\r\n while ToIndex >= 0 do\r\n begin\r\n NewMap.FEntries[ToIndex] := FEntries[ToIndex];\r\n Dec(ToIndex);\r\n end;\r\n end;\r\n Result := NewMap;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntegerIntegerSortedMap.IsEmpty: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := FSize = 0;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntegerIntegerSortedMap.KeyOfValue(Value: Integer): Integer;\r\nvar\r\n Index: Integer;\r\n Found: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Found := False;\r\n Result := 0;\r\n for Index := 0 to FSize - 1 do\r\n if ValuesCompare(FEntries[Index].Value, Value) = 0 then\r\n begin\r\n Result := FEntries[Index].Key;\r\n Found := True;\r\n Break;\r\n end;\r\n\r\n if (not Found) and (not FReturnDefaultElements) then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntegerIntegerSortedMap.KeySet: IJclIntegerSet;\r\nvar\r\n Index: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := TJclIntegerArraySet.Create(FSize);\r\n for Index := 0 to FSize - 1 do\r\n Result.Add(FEntries[Index].Key);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntegerIntegerSortedMap.LastKey: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := 0;\r\n if FSize > 0 then\r\n Result := FEntries[FSize - 1].Key\r\n else\r\n if not FReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntegerIntegerSortedMap.MapEquals(const AMap: IJclIntegerIntegerMap): Boolean;\r\nvar\r\n It: IJclIntegerIterator;\r\n Index: Integer;\r\n AKey: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if AMap = nil then\r\n Exit;\r\n if FSize <> AMap.Size then\r\n Exit;\r\n It := AMap.KeySet.First;\r\n Index := 0;\r\n while It.HasNext do\r\n begin\r\n if Index >= FSize then\r\n Exit;\r\n AKey := It.Next;\r\n if ValuesCompare(AMap.GetValue(AKey), FEntries[Index].Value) <> 0 then\r\n Exit;\r\n Inc(Index);\r\n end;\r\n Result := True;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclIntegerIntegerSortedMap.InitializeArrayAfterMove(var List: TJclIntegerIntegerSortedMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\nbegin\r\n { Clean array }\r\n if FromIndex < ToIndex then\r\n begin\r\n if (ToIndex - FromIndex) < Count then\r\n Count := ToIndex - FromIndex;\r\n FillChar(List[FromIndex], Count * SizeOf(List[0]), 0);\r\n end\r\n else\r\n if FromIndex > ToIndex then\r\n begin\r\n if (FromIndex - ToIndex) < Count then\r\n FillChar(List[ToIndex + Count], (FromIndex - ToIndex) * SizeOf(List[0]), 0)\r\n else\r\n FillChar(List[FromIndex], Count * SizeOf(List[0]), 0);\r\n end;\r\nend;\r\n\r\nprocedure TJclIntegerIntegerSortedMap.MoveArray(var List: TJclIntegerIntegerSortedMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\nbegin\r\n if Count > 0 then\r\n begin\r\n Move(List[FromIndex], List[ToIndex], Count * SizeOf(List[0]));\r\n InitializeArrayAfterMove(List, FromIndex, ToIndex, Count);\r\n end;\r\nend;\r\n\r\nprocedure TJclIntegerIntegerSortedMap.PutAll(const AMap: IJclIntegerIntegerMap);\r\nvar\r\n It: IJclIntegerIterator;\r\n Key: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if AMap = nil then\r\n Exit;\r\n It := AMap.KeySet.First;\r\n while It.HasNext do\r\n begin\r\n Key := It.Next;\r\n PutValue(Key, AMap.GetValue(Key));\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclIntegerIntegerSortedMap.PutValue(Key: Integer; Value: Integer);\r\nvar\r\n Index: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FAllowDefaultElements or ((KeysCompare(Key, 0) <> 0) and (ValuesCompare(Value, 0) <> 0)) then\r\n begin\r\n Index := BinarySearch(Key);\r\n\r\n if (Index >= 0) and (KeysCompare(FEntries[Index].Key, Key) = 0) then\r\n begin\r\n FreeValue(FEntries[Index].Value);\r\n FEntries[Index].Value := Value;\r\n end\r\n else\r\n begin\r\n if FSize = FCapacity then\r\n AutoGrow;\r\n if FSize < FCapacity then\r\n begin\r\n Inc(Index);\r\n if (Index < FSize) and (KeysCompare(FEntries[Index].Key, Key) <> 0) then\r\n MoveArray(FEntries, Index, Index + 1, FSize - Index);\r\n FEntries[Index].Key := Key;\r\n FEntries[Index].Value := Value;\r\n Inc(FSize);\r\n end;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntegerIntegerSortedMap.Remove(Key: Integer): Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := Extract(Key);\r\n Result := FreeValue(Result);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclIntegerIntegerSortedMap.SetCapacity(Value: Integer);\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FSize <= Value then\r\n begin\r\n SetLength(FEntries, Value);\r\n inherited SetCapacity(Value);\r\n end\r\n else\r\n raise EJclOperationNotSupportedError.Create;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntegerIntegerSortedMap.Size: Integer;\r\nbegin\r\n Result := FSize;\r\nend;\r\n\r\nfunction TJclIntegerIntegerSortedMap.SubMap(FromKey, ToKey: Integer): IJclIntegerIntegerSortedMap;\r\nvar\r\n FromIndex, ToIndex: Integer;\r\n NewMap: TJclIntegerIntegerSortedMap;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n NewMap := CreateEmptyContainer as TJclIntegerIntegerSortedMap;\r\n FromIndex := BinarySearch(FromKey);\r\n if (FromIndex = -1) or (KeysCompare(FEntries[FromIndex].Key, FromKey) < 0) then\r\n Inc(FromIndex);\r\n ToIndex := BinarySearch(ToKey);\r\n if (FromIndex >= 0) and (FromIndex <= ToIndex) then\r\n begin\r\n NewMap.SetCapacity(ToIndex - FromIndex + 1);\r\n NewMap.FSize := ToIndex - FromIndex + 1;\r\n while ToIndex >= FromIndex do\r\n begin\r\n NewMap.FEntries[ToIndex - FromIndex] := FEntries[ToIndex];\r\n Dec(ToIndex);\r\n end;\r\n end;\r\n Result := NewMap;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntegerIntegerSortedMap.TailMap(FromKey: Integer): IJclIntegerIntegerSortedMap;\r\nvar\r\n FromIndex, Index: Integer;\r\n NewMap: TJclIntegerIntegerSortedMap;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n NewMap := CreateEmptyContainer as TJclIntegerIntegerSortedMap;\r\n FromIndex := BinarySearch(FromKey);\r\n if (FromIndex = -1) or (KeysCompare(FEntries[FromIndex].Key, FromKey) < 0) then\r\n Inc(FromIndex);\r\n if (FromIndex >= 0) and (FromIndex < FSize) then\r\n begin\r\n NewMap.SetCapacity(FSize - FromIndex);\r\n NewMap.FSize := FSize - FromIndex;\r\n Index := FromIndex;\r\n while Index < FSize do\r\n begin\r\n NewMap.FEntries[Index - FromIndex] := FEntries[Index];\r\n Inc(Index);\r\n end;\r\n end;\r\n Result := NewMap;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntegerIntegerSortedMap.Values: IJclIntegerCollection;\r\nvar\r\n Index: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := TJclIntegerArrayList.Create(FSize);\r\n for Index := 0 to FSize - 1 do\r\n Result.Add(FEntries[Index].Value);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntegerIntegerSortedMap.CreateEmptyContainer: TJclAbstractContainerBase;\r\nbegin\r\n Result := TJclIntegerIntegerSortedMap.Create(FSize);\r\n AssignPropertiesTo(Result);\r\nend;\r\n\r\nfunction TJclIntegerIntegerSortedMap.FreeKey(var Key: Integer): Integer;\r\nbegin\r\n Result := Key;\r\n Key := 0;\r\nend;\r\n\r\nfunction TJclIntegerIntegerSortedMap.FreeValue(var Value: Integer): Integer;\r\nbegin\r\n Result := Value;\r\n Value := 0;\r\nend;\r\n\r\nfunction TJclIntegerIntegerSortedMap.KeysCompare(A, B: Integer): Integer;\r\nbegin\r\n Result := ItemsCompare(A, B);\r\nend;\r\n\r\nfunction TJclIntegerIntegerSortedMap.ValuesCompare(A, B: Integer): Integer;\r\nbegin\r\n Result := ItemsCompare(A, B);\r\nend;\r\n\r\n//=== { TJclCardinalIntfSortedMap } ==============================================\r\n\r\nconstructor TJclCardinalIntfSortedMap.Create(ACapacity: Integer);\r\nbegin\r\n inherited Create();\r\n SetCapacity(ACapacity);\r\nend;\r\n\r\ndestructor TJclCardinalIntfSortedMap.Destroy;\r\nbegin\r\n FReadOnly := False;\r\n Clear;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJclCardinalIntfSortedMap.AssignDataTo(Dest: TJclAbstractContainerBase);\r\nvar\r\n MyDest: TJclCardinalIntfSortedMap;\r\nbegin\r\n inherited AssignDataTo(Dest);\r\n if Dest is TJclCardinalIntfSortedMap then\r\n begin\r\n MyDest := TJclCardinalIntfSortedMap(Dest);\r\n MyDest.SetCapacity(FSize);\r\n MyDest.FEntries := FEntries;\r\n MyDest.FSize := FSize;\r\n end;\r\nend;\r\n\r\nfunction TJclCardinalIntfSortedMap.BinarySearch(Key: Cardinal): Integer;\r\nvar\r\n HiPos, LoPos, CompPos: Integer;\r\n Comp: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n LoPos := 0;\r\n HiPos := FSize - 1;\r\n CompPos := (HiPos + LoPos) div 2;\r\n while HiPos >= LoPos do\r\n begin\r\n Comp := KeysCompare(FEntries[CompPos].Key, Key);\r\n if Comp < 0 then\r\n LoPos := CompPos + 1\r\n else\r\n if Comp > 0 then\r\n HiPos := CompPos - 1\r\n else\r\n begin\r\n HiPos := CompPos;\r\n LoPos := CompPos + 1;\r\n end;\r\n CompPos := (HiPos + LoPos) div 2;\r\n end;\r\n Result := HiPos;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclCardinalIntfSortedMap.Clear;\r\nvar\r\n Index: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n for Index := 0 to FSize - 1 do\r\n begin\r\n FreeKey(FEntries[Index].Key);\r\n FreeValue(FEntries[Index].Value);\r\n end;\r\n FSize := 0;\r\n AutoPack;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclCardinalIntfSortedMap.ContainsKey(Key: Cardinal): Boolean;\r\nvar\r\n Index: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Index := BinarySearch(Key);\r\n Result := (Index >= 0) and (KeysCompare(FEntries[Index].Key, Key) = 0);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclCardinalIntfSortedMap.ContainsValue(const Value: IInterface): Boolean;\r\nvar\r\n Index: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n for Index := 0 to FSize - 1 do\r\n if ValuesCompare(FEntries[Index].Value, Value) = 0 then\r\n begin\r\n Result := True;\r\n Break;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclCardinalIntfSortedMap.FirstKey: Cardinal;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := 0;\r\n if FSize > 0 then\r\n Result := FEntries[0].Key\r\n else\r\n if not FReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclCardinalIntfSortedMap.Extract(Key: Cardinal): IInterface;\r\nvar\r\n Index: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Index := BinarySearch(Key);\r\n if (Index >= 0) and (KeysCompare(FEntries[Index].Key, Key) = 0) then\r\n begin\r\n Result := FEntries[Index].Value;\r\n FEntries[Index].Value := nil;\r\n FreeKey(FEntries[Index].Key);\r\n if Index < (FSize - 1) then\r\n MoveArray(FEntries, Index + 1, Index, FSize - Index - 1);\r\n Dec(FSize);\r\n AutoPack;\r\n end\r\n else\r\n Result := nil;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclCardinalIntfSortedMap.GetValue(Key: Cardinal): IInterface;\r\nvar\r\n Index: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Index := BinarySearch(Key);\r\n Result := nil;\r\n if (Index >= 0) and (KeysCompare(FEntries[Index].Key, Key) = 0) then\r\n Result := FEntries[Index].Value\r\n else if not FReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclCardinalIntfSortedMap.HeadMap(ToKey: Cardinal): IJclCardinalIntfSortedMap;\r\nvar\r\n ToIndex: Integer;\r\n NewMap: TJclCardinalIntfSortedMap;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n NewMap := CreateEmptyContainer as TJclCardinalIntfSortedMap;\r\n ToIndex := BinarySearch(ToKey);\r\n if ToIndex >= 0 then\r\n begin\r\n NewMap.SetCapacity(ToIndex + 1);\r\n NewMap.FSize := ToIndex + 1;\r\n while ToIndex >= 0 do\r\n begin\r\n NewMap.FEntries[ToIndex] := FEntries[ToIndex];\r\n Dec(ToIndex);\r\n end;\r\n end;\r\n Result := NewMap;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclCardinalIntfSortedMap.IsEmpty: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := FSize = 0;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclCardinalIntfSortedMap.KeyOfValue(const Value: IInterface): Cardinal;\r\nvar\r\n Index: Integer;\r\n Found: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Found := False;\r\n Result := 0;\r\n for Index := 0 to FSize - 1 do\r\n if ValuesCompare(FEntries[Index].Value, Value) = 0 then\r\n begin\r\n Result := FEntries[Index].Key;\r\n Found := True;\r\n Break;\r\n end;\r\n\r\n if (not Found) and (not FReturnDefaultElements) then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclCardinalIntfSortedMap.KeySet: IJclCardinalSet;\r\nvar\r\n Index: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := TJclCardinalArraySet.Create(FSize);\r\n for Index := 0 to FSize - 1 do\r\n Result.Add(FEntries[Index].Key);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclCardinalIntfSortedMap.LastKey: Cardinal;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := 0;\r\n if FSize > 0 then\r\n Result := FEntries[FSize - 1].Key\r\n else\r\n if not FReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclCardinalIntfSortedMap.MapEquals(const AMap: IJclCardinalIntfMap): Boolean;\r\nvar\r\n It: IJclCardinalIterator;\r\n Index: Integer;\r\n AKey: Cardinal;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if AMap = nil then\r\n Exit;\r\n if FSize <> AMap.Size then\r\n Exit;\r\n It := AMap.KeySet.First;\r\n Index := 0;\r\n while It.HasNext do\r\n begin\r\n if Index >= FSize then\r\n Exit;\r\n AKey := It.Next;\r\n if ValuesCompare(AMap.GetValue(AKey), FEntries[Index].Value) <> 0 then\r\n Exit;\r\n Inc(Index);\r\n end;\r\n Result := True;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclCardinalIntfSortedMap.FinalizeArrayBeforeMove(var List: TJclCardinalIntfSortedMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\nbegin\r\n Assert(Count > 0);\r\n if FromIndex < ToIndex then\r\n begin\r\n if Count > (ToIndex - FromIndex) then\r\n Finalize(List[FromIndex + Count], ToIndex - FromIndex)\r\n else\r\n Finalize(List[ToIndex], Count);\r\n end\r\n else\r\n if FromIndex > ToIndex then\r\n begin\r\n if Count > (FromIndex - ToIndex) then\r\n Count := FromIndex - ToIndex;\r\n Finalize(List[ToIndex], Count)\r\n end;\r\nend;\r\n\r\nprocedure TJclCardinalIntfSortedMap.InitializeArray(var List: TJclCardinalIntfSortedMapEntryArray; FromIndex, Count: SizeInt);\r\nbegin\r\n {$IFDEF FPC}\r\n while Count > 0 do\r\n begin\r\n Initialize(List[FromIndex]);\r\n Inc(FromIndex);\r\n Dec(Count);\r\n end;\r\n {$ELSE ~FPC}\r\n Initialize(List[FromIndex], Count);\r\n {$ENDIF ~FPC}\r\nend;\r\n\r\nprocedure TJclCardinalIntfSortedMap.InitializeArrayAfterMove(var List: TJclCardinalIntfSortedMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\nbegin\r\n { Keep reference counting working }\r\n if FromIndex < ToIndex then\r\n begin\r\n if (ToIndex - FromIndex) < Count then\r\n Count := ToIndex - FromIndex;\r\n InitializeArray(List, FromIndex, Count);\r\n end\r\n else\r\n if FromIndex > ToIndex then\r\n begin\r\n if (FromIndex - ToIndex) < Count then\r\n InitializeArray(List, ToIndex + Count, FromIndex - ToIndex)\r\n else\r\n InitializeArray(List, FromIndex, Count);\r\n end;\r\nend;\r\n\r\nprocedure TJclCardinalIntfSortedMap.MoveArray(var List: TJclCardinalIntfSortedMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\nbegin\r\n if Count > 0 then\r\n begin\r\n FinalizeArrayBeforeMove(List, FromIndex, ToIndex, Count);\r\n Move(List[FromIndex], List[ToIndex], Count * SizeOf(List[0]));\r\n InitializeArrayAfterMove(List, FromIndex, ToIndex, Count);\r\n end;\r\nend;\r\n\r\nprocedure TJclCardinalIntfSortedMap.PutAll(const AMap: IJclCardinalIntfMap);\r\nvar\r\n It: IJclCardinalIterator;\r\n Key: Cardinal;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if AMap = nil then\r\n Exit;\r\n It := AMap.KeySet.First;\r\n while It.HasNext do\r\n begin\r\n Key := It.Next;\r\n PutValue(Key, AMap.GetValue(Key));\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclCardinalIntfSortedMap.PutValue(Key: Cardinal; const Value: IInterface);\r\nvar\r\n Index: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FAllowDefaultElements or ((KeysCompare(Key, 0) <> 0) and (ValuesCompare(Value, nil) <> 0)) then\r\n begin\r\n Index := BinarySearch(Key);\r\n\r\n if (Index >= 0) and (KeysCompare(FEntries[Index].Key, Key) = 0) then\r\n begin\r\n FreeValue(FEntries[Index].Value);\r\n FEntries[Index].Value := Value;\r\n end\r\n else\r\n begin\r\n if FSize = FCapacity then\r\n AutoGrow;\r\n if FSize < FCapacity then\r\n begin\r\n Inc(Index);\r\n if (Index < FSize) and (KeysCompare(FEntries[Index].Key, Key) <> 0) then\r\n MoveArray(FEntries, Index, Index + 1, FSize - Index);\r\n FEntries[Index].Key := Key;\r\n FEntries[Index].Value := Value;\r\n Inc(FSize);\r\n end;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclCardinalIntfSortedMap.Remove(Key: Cardinal): IInterface;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := Extract(Key);\r\n Result := FreeValue(Result);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclCardinalIntfSortedMap.SetCapacity(Value: Integer);\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FSize <= Value then\r\n begin\r\n SetLength(FEntries, Value);\r\n inherited SetCapacity(Value);\r\n end\r\n else\r\n raise EJclOperationNotSupportedError.Create;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclCardinalIntfSortedMap.Size: Integer;\r\nbegin\r\n Result := FSize;\r\nend;\r\n\r\nfunction TJclCardinalIntfSortedMap.SubMap(FromKey, ToKey: Cardinal): IJclCardinalIntfSortedMap;\r\nvar\r\n FromIndex, ToIndex: Integer;\r\n NewMap: TJclCardinalIntfSortedMap;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n NewMap := CreateEmptyContainer as TJclCardinalIntfSortedMap;\r\n FromIndex := BinarySearch(FromKey);\r\n if (FromIndex = -1) or (KeysCompare(FEntries[FromIndex].Key, FromKey) < 0) then\r\n Inc(FromIndex);\r\n ToIndex := BinarySearch(ToKey);\r\n if (FromIndex >= 0) and (FromIndex <= ToIndex) then\r\n begin\r\n NewMap.SetCapacity(ToIndex - FromIndex + 1);\r\n NewMap.FSize := ToIndex - FromIndex + 1;\r\n while ToIndex >= FromIndex do\r\n begin\r\n NewMap.FEntries[ToIndex - FromIndex] := FEntries[ToIndex];\r\n Dec(ToIndex);\r\n end;\r\n end;\r\n Result := NewMap;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclCardinalIntfSortedMap.TailMap(FromKey: Cardinal): IJclCardinalIntfSortedMap;\r\nvar\r\n FromIndex, Index: Integer;\r\n NewMap: TJclCardinalIntfSortedMap;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n NewMap := CreateEmptyContainer as TJclCardinalIntfSortedMap;\r\n FromIndex := BinarySearch(FromKey);\r\n if (FromIndex = -1) or (KeysCompare(FEntries[FromIndex].Key, FromKey) < 0) then\r\n Inc(FromIndex);\r\n if (FromIndex >= 0) and (FromIndex < FSize) then\r\n begin\r\n NewMap.SetCapacity(FSize - FromIndex);\r\n NewMap.FSize := FSize - FromIndex;\r\n Index := FromIndex;\r\n while Index < FSize do\r\n begin\r\n NewMap.FEntries[Index - FromIndex] := FEntries[Index];\r\n Inc(Index);\r\n end;\r\n end;\r\n Result := NewMap;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclCardinalIntfSortedMap.Values: IJclIntfCollection;\r\nvar\r\n Index: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := TJclIntfArrayList.Create(FSize);\r\n for Index := 0 to FSize - 1 do\r\n Result.Add(FEntries[Index].Value);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclCardinalIntfSortedMap.CreateEmptyContainer: TJclAbstractContainerBase;\r\nbegin\r\n Result := TJclCardinalIntfSortedMap.Create(FSize);\r\n AssignPropertiesTo(Result);\r\nend;\r\n\r\nfunction TJclCardinalIntfSortedMap.FreeKey(var Key: Cardinal): Cardinal;\r\nbegin\r\n Result := Key;\r\n Key := 0;\r\nend;\r\n\r\nfunction TJclCardinalIntfSortedMap.FreeValue(var Value: IInterface): IInterface;\r\nbegin\r\n Result := Value;\r\n Value := nil;\r\nend;\r\n\r\nfunction TJclCardinalIntfSortedMap.KeysCompare(A, B: Cardinal): Integer;\r\nbegin\r\n Result := ItemsCompare(A, B);\r\nend;\r\n\r\nfunction TJclCardinalIntfSortedMap.ValuesCompare(const A, B: IInterface): Integer;\r\nbegin\r\n Result := IntfSimpleCompare(A, B);\r\nend;\r\n\r\n//=== { TJclIntfCardinalSortedMap } ==============================================\r\n\r\nconstructor TJclIntfCardinalSortedMap.Create(ACapacity: Integer);\r\nbegin\r\n inherited Create();\r\n SetCapacity(ACapacity);\r\nend;\r\n\r\ndestructor TJclIntfCardinalSortedMap.Destroy;\r\nbegin\r\n FReadOnly := False;\r\n Clear;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJclIntfCardinalSortedMap.AssignDataTo(Dest: TJclAbstractContainerBase);\r\nvar\r\n MyDest: TJclIntfCardinalSortedMap;\r\nbegin\r\n inherited AssignDataTo(Dest);\r\n if Dest is TJclIntfCardinalSortedMap then\r\n begin\r\n MyDest := TJclIntfCardinalSortedMap(Dest);\r\n MyDest.SetCapacity(FSize);\r\n MyDest.FEntries := FEntries;\r\n MyDest.FSize := FSize;\r\n end;\r\nend;\r\n\r\nfunction TJclIntfCardinalSortedMap.BinarySearch(const Key: IInterface): Integer;\r\nvar\r\n HiPos, LoPos, CompPos: Integer;\r\n Comp: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n LoPos := 0;\r\n HiPos := FSize - 1;\r\n CompPos := (HiPos + LoPos) div 2;\r\n while HiPos >= LoPos do\r\n begin\r\n Comp := KeysCompare(FEntries[CompPos].Key, Key);\r\n if Comp < 0 then\r\n LoPos := CompPos + 1\r\n else\r\n if Comp > 0 then\r\n HiPos := CompPos - 1\r\n else\r\n begin\r\n HiPos := CompPos;\r\n LoPos := CompPos + 1;\r\n end;\r\n CompPos := (HiPos + LoPos) div 2;\r\n end;\r\n Result := HiPos;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclIntfCardinalSortedMap.Clear;\r\nvar\r\n Index: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n for Index := 0 to FSize - 1 do\r\n begin\r\n FreeKey(FEntries[Index].Key);\r\n FreeValue(FEntries[Index].Value);\r\n end;\r\n FSize := 0;\r\n AutoPack;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfCardinalSortedMap.ContainsKey(const Key: IInterface): Boolean;\r\nvar\r\n Index: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Index := BinarySearch(Key);\r\n Result := (Index >= 0) and (KeysCompare(FEntries[Index].Key, Key) = 0);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfCardinalSortedMap.ContainsValue(Value: Cardinal): Boolean;\r\nvar\r\n Index: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n for Index := 0 to FSize - 1 do\r\n if ValuesCompare(FEntries[Index].Value, Value) = 0 then\r\n begin\r\n Result := True;\r\n Break;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfCardinalSortedMap.FirstKey: IInterface;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := nil;\r\n if FSize > 0 then\r\n Result := FEntries[0].Key\r\n else\r\n if not FReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfCardinalSortedMap.Extract(const Key: IInterface): Cardinal;\r\nvar\r\n Index: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Index := BinarySearch(Key);\r\n if (Index >= 0) and (KeysCompare(FEntries[Index].Key, Key) = 0) then\r\n begin\r\n Result := FEntries[Index].Value;\r\n FEntries[Index].Value := 0;\r\n FreeKey(FEntries[Index].Key);\r\n if Index < (FSize - 1) then\r\n MoveArray(FEntries, Index + 1, Index, FSize - Index - 1);\r\n Dec(FSize);\r\n AutoPack;\r\n end\r\n else\r\n Result := 0;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfCardinalSortedMap.GetValue(const Key: IInterface): Cardinal;\r\nvar\r\n Index: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Index := BinarySearch(Key);\r\n Result := 0;\r\n if (Index >= 0) and (KeysCompare(FEntries[Index].Key, Key) = 0) then\r\n Result := FEntries[Index].Value\r\n else if not FReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfCardinalSortedMap.HeadMap(const ToKey: IInterface): IJclIntfCardinalSortedMap;\r\nvar\r\n ToIndex: Integer;\r\n NewMap: TJclIntfCardinalSortedMap;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n NewMap := CreateEmptyContainer as TJclIntfCardinalSortedMap;\r\n ToIndex := BinarySearch(ToKey);\r\n if ToIndex >= 0 then\r\n begin\r\n NewMap.SetCapacity(ToIndex + 1);\r\n NewMap.FSize := ToIndex + 1;\r\n while ToIndex >= 0 do\r\n begin\r\n NewMap.FEntries[ToIndex] := FEntries[ToIndex];\r\n Dec(ToIndex);\r\n end;\r\n end;\r\n Result := NewMap;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfCardinalSortedMap.IsEmpty: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := FSize = 0;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfCardinalSortedMap.KeyOfValue(Value: Cardinal): IInterface;\r\nvar\r\n Index: Integer;\r\n Found: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Found := False;\r\n Result := nil;\r\n for Index := 0 to FSize - 1 do\r\n if ValuesCompare(FEntries[Index].Value, Value) = 0 then\r\n begin\r\n Result := FEntries[Index].Key;\r\n Found := True;\r\n Break;\r\n end;\r\n\r\n if (not Found) and (not FReturnDefaultElements) then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfCardinalSortedMap.KeySet: IJclIntfSet;\r\nvar\r\n Index: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := TJclIntfArraySet.Create(FSize);\r\n for Index := 0 to FSize - 1 do\r\n Result.Add(FEntries[Index].Key);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfCardinalSortedMap.LastKey: IInterface;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := nil;\r\n if FSize > 0 then\r\n Result := FEntries[FSize - 1].Key\r\n else\r\n if not FReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfCardinalSortedMap.MapEquals(const AMap: IJclIntfCardinalMap): Boolean;\r\nvar\r\n It: IJclIntfIterator;\r\n Index: Integer;\r\n AKey: IInterface;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if AMap = nil then\r\n Exit;\r\n if FSize <> AMap.Size then\r\n Exit;\r\n It := AMap.KeySet.First;\r\n Index := 0;\r\n while It.HasNext do\r\n begin\r\n if Index >= FSize then\r\n Exit;\r\n AKey := It.Next;\r\n if ValuesCompare(AMap.GetValue(AKey), FEntries[Index].Value) <> 0 then\r\n Exit;\r\n Inc(Index);\r\n end;\r\n Result := True;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclIntfCardinalSortedMap.FinalizeArrayBeforeMove(var List: TJclIntfCardinalSortedMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\nbegin\r\n Assert(Count > 0);\r\n if FromIndex < ToIndex then\r\n begin\r\n if Count > (ToIndex - FromIndex) then\r\n Finalize(List[FromIndex + Count], ToIndex - FromIndex)\r\n else\r\n Finalize(List[ToIndex], Count);\r\n end\r\n else\r\n if FromIndex > ToIndex then\r\n begin\r\n if Count > (FromIndex - ToIndex) then\r\n Count := FromIndex - ToIndex;\r\n Finalize(List[ToIndex], Count)\r\n end;\r\nend;\r\n\r\nprocedure TJclIntfCardinalSortedMap.InitializeArray(var List: TJclIntfCardinalSortedMapEntryArray; FromIndex, Count: SizeInt);\r\nbegin\r\n {$IFDEF FPC}\r\n while Count > 0 do\r\n begin\r\n Initialize(List[FromIndex]);\r\n Inc(FromIndex);\r\n Dec(Count);\r\n end;\r\n {$ELSE ~FPC}\r\n Initialize(List[FromIndex], Count);\r\n {$ENDIF ~FPC}\r\nend;\r\n\r\nprocedure TJclIntfCardinalSortedMap.InitializeArrayAfterMove(var List: TJclIntfCardinalSortedMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\nbegin\r\n { Keep reference counting working }\r\n if FromIndex < ToIndex then\r\n begin\r\n if (ToIndex - FromIndex) < Count then\r\n Count := ToIndex - FromIndex;\r\n InitializeArray(List, FromIndex, Count);\r\n end\r\n else\r\n if FromIndex > ToIndex then\r\n begin\r\n if (FromIndex - ToIndex) < Count then\r\n InitializeArray(List, ToIndex + Count, FromIndex - ToIndex)\r\n else\r\n InitializeArray(List, FromIndex, Count);\r\n end;\r\nend;\r\n\r\nprocedure TJclIntfCardinalSortedMap.MoveArray(var List: TJclIntfCardinalSortedMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\nbegin\r\n if Count > 0 then\r\n begin\r\n FinalizeArrayBeforeMove(List, FromIndex, ToIndex, Count);\r\n Move(List[FromIndex], List[ToIndex], Count * SizeOf(List[0]));\r\n InitializeArrayAfterMove(List, FromIndex, ToIndex, Count);\r\n end;\r\nend;\r\n\r\nprocedure TJclIntfCardinalSortedMap.PutAll(const AMap: IJclIntfCardinalMap);\r\nvar\r\n It: IJclIntfIterator;\r\n Key: IInterface;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if AMap = nil then\r\n Exit;\r\n It := AMap.KeySet.First;\r\n while It.HasNext do\r\n begin\r\n Key := It.Next;\r\n PutValue(Key, AMap.GetValue(Key));\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclIntfCardinalSortedMap.PutValue(const Key: IInterface; Value: Cardinal);\r\nvar\r\n Index: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FAllowDefaultElements or ((KeysCompare(Key, nil) <> 0) and (ValuesCompare(Value, 0) <> 0)) then\r\n begin\r\n Index := BinarySearch(Key);\r\n\r\n if (Index >= 0) and (KeysCompare(FEntries[Index].Key, Key) = 0) then\r\n begin\r\n FreeValue(FEntries[Index].Value);\r\n FEntries[Index].Value := Value;\r\n end\r\n else\r\n begin\r\n if FSize = FCapacity then\r\n AutoGrow;\r\n if FSize < FCapacity then\r\n begin\r\n Inc(Index);\r\n if (Index < FSize) and (KeysCompare(FEntries[Index].Key, Key) <> 0) then\r\n MoveArray(FEntries, Index, Index + 1, FSize - Index);\r\n FEntries[Index].Key := Key;\r\n FEntries[Index].Value := Value;\r\n Inc(FSize);\r\n end;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfCardinalSortedMap.Remove(const Key: IInterface): Cardinal;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := Extract(Key);\r\n Result := FreeValue(Result);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclIntfCardinalSortedMap.SetCapacity(Value: Integer);\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FSize <= Value then\r\n begin\r\n SetLength(FEntries, Value);\r\n inherited SetCapacity(Value);\r\n end\r\n else\r\n raise EJclOperationNotSupportedError.Create;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfCardinalSortedMap.Size: Integer;\r\nbegin\r\n Result := FSize;\r\nend;\r\n\r\nfunction TJclIntfCardinalSortedMap.SubMap(const FromKey, ToKey: IInterface): IJclIntfCardinalSortedMap;\r\nvar\r\n FromIndex, ToIndex: Integer;\r\n NewMap: TJclIntfCardinalSortedMap;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n NewMap := CreateEmptyContainer as TJclIntfCardinalSortedMap;\r\n FromIndex := BinarySearch(FromKey);\r\n if (FromIndex = -1) or (KeysCompare(FEntries[FromIndex].Key, FromKey) < 0) then\r\n Inc(FromIndex);\r\n ToIndex := BinarySearch(ToKey);\r\n if (FromIndex >= 0) and (FromIndex <= ToIndex) then\r\n begin\r\n NewMap.SetCapacity(ToIndex - FromIndex + 1);\r\n NewMap.FSize := ToIndex - FromIndex + 1;\r\n while ToIndex >= FromIndex do\r\n begin\r\n NewMap.FEntries[ToIndex - FromIndex] := FEntries[ToIndex];\r\n Dec(ToIndex);\r\n end;\r\n end;\r\n Result := NewMap;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfCardinalSortedMap.TailMap(const FromKey: IInterface): IJclIntfCardinalSortedMap;\r\nvar\r\n FromIndex, Index: Integer;\r\n NewMap: TJclIntfCardinalSortedMap;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n NewMap := CreateEmptyContainer as TJclIntfCardinalSortedMap;\r\n FromIndex := BinarySearch(FromKey);\r\n if (FromIndex = -1) or (KeysCompare(FEntries[FromIndex].Key, FromKey) < 0) then\r\n Inc(FromIndex);\r\n if (FromIndex >= 0) and (FromIndex < FSize) then\r\n begin\r\n NewMap.SetCapacity(FSize - FromIndex);\r\n NewMap.FSize := FSize - FromIndex;\r\n Index := FromIndex;\r\n while Index < FSize do\r\n begin\r\n NewMap.FEntries[Index - FromIndex] := FEntries[Index];\r\n Inc(Index);\r\n end;\r\n end;\r\n Result := NewMap;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfCardinalSortedMap.Values: IJclCardinalCollection;\r\nvar\r\n Index: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := TJclCardinalArrayList.Create(FSize);\r\n for Index := 0 to FSize - 1 do\r\n Result.Add(FEntries[Index].Value);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfCardinalSortedMap.CreateEmptyContainer: TJclAbstractContainerBase;\r\nbegin\r\n Result := TJclIntfCardinalSortedMap.Create(FSize);\r\n AssignPropertiesTo(Result);\r\nend;\r\n\r\nfunction TJclIntfCardinalSortedMap.FreeKey(var Key: IInterface): IInterface;\r\nbegin\r\n Result := Key;\r\n Key := nil;\r\nend;\r\n\r\nfunction TJclIntfCardinalSortedMap.FreeValue(var Value: Cardinal): Cardinal;\r\nbegin\r\n Result := Value;\r\n Value := 0;\r\nend;\r\n\r\nfunction TJclIntfCardinalSortedMap.KeysCompare(const A, B: IInterface): Integer;\r\nbegin\r\n Result := IntfSimpleCompare(A, B);\r\nend;\r\n\r\nfunction TJclIntfCardinalSortedMap.ValuesCompare(A, B: Cardinal): Integer;\r\nbegin\r\n Result := ItemsCompare(A, B);\r\nend;\r\n\r\n//=== { TJclCardinalCardinalSortedMap } ==============================================\r\n\r\nconstructor TJclCardinalCardinalSortedMap.Create(ACapacity: Integer);\r\nbegin\r\n inherited Create();\r\n SetCapacity(ACapacity);\r\nend;\r\n\r\ndestructor TJclCardinalCardinalSortedMap.Destroy;\r\nbegin\r\n FReadOnly := False;\r\n Clear;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJclCardinalCardinalSortedMap.AssignDataTo(Dest: TJclAbstractContainerBase);\r\nvar\r\n MyDest: TJclCardinalCardinalSortedMap;\r\nbegin\r\n inherited AssignDataTo(Dest);\r\n if Dest is TJclCardinalCardinalSortedMap then\r\n begin\r\n MyDest := TJclCardinalCardinalSortedMap(Dest);\r\n MyDest.SetCapacity(FSize);\r\n MyDest.FEntries := FEntries;\r\n MyDest.FSize := FSize;\r\n end;\r\nend;\r\n\r\nfunction TJclCardinalCardinalSortedMap.BinarySearch(Key: Cardinal): Integer;\r\nvar\r\n HiPos, LoPos, CompPos: Integer;\r\n Comp: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n LoPos := 0;\r\n HiPos := FSize - 1;\r\n CompPos := (HiPos + LoPos) div 2;\r\n while HiPos >= LoPos do\r\n begin\r\n Comp := KeysCompare(FEntries[CompPos].Key, Key);\r\n if Comp < 0 then\r\n LoPos := CompPos + 1\r\n else\r\n if Comp > 0 then\r\n HiPos := CompPos - 1\r\n else\r\n begin\r\n HiPos := CompPos;\r\n LoPos := CompPos + 1;\r\n end;\r\n CompPos := (HiPos + LoPos) div 2;\r\n end;\r\n Result := HiPos;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclCardinalCardinalSortedMap.Clear;\r\nvar\r\n Index: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n for Index := 0 to FSize - 1 do\r\n begin\r\n FreeKey(FEntries[Index].Key);\r\n FreeValue(FEntries[Index].Value);\r\n end;\r\n FSize := 0;\r\n AutoPack;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclCardinalCardinalSortedMap.ContainsKey(Key: Cardinal): Boolean;\r\nvar\r\n Index: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Index := BinarySearch(Key);\r\n Result := (Index >= 0) and (KeysCompare(FEntries[Index].Key, Key) = 0);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclCardinalCardinalSortedMap.ContainsValue(Value: Cardinal): Boolean;\r\nvar\r\n Index: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n for Index := 0 to FSize - 1 do\r\n if ValuesCompare(FEntries[Index].Value, Value) = 0 then\r\n begin\r\n Result := True;\r\n Break;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclCardinalCardinalSortedMap.FirstKey: Cardinal;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := 0;\r\n if FSize > 0 then\r\n Result := FEntries[0].Key\r\n else\r\n if not FReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclCardinalCardinalSortedMap.Extract(Key: Cardinal): Cardinal;\r\nvar\r\n Index: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Index := BinarySearch(Key);\r\n if (Index >= 0) and (KeysCompare(FEntries[Index].Key, Key) = 0) then\r\n begin\r\n Result := FEntries[Index].Value;\r\n FEntries[Index].Value := 0;\r\n FreeKey(FEntries[Index].Key);\r\n if Index < (FSize - 1) then\r\n MoveArray(FEntries, Index + 1, Index, FSize - Index - 1);\r\n Dec(FSize);\r\n AutoPack;\r\n end\r\n else\r\n Result := 0;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclCardinalCardinalSortedMap.GetValue(Key: Cardinal): Cardinal;\r\nvar\r\n Index: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Index := BinarySearch(Key);\r\n Result := 0;\r\n if (Index >= 0) and (KeysCompare(FEntries[Index].Key, Key) = 0) then\r\n Result := FEntries[Index].Value\r\n else if not FReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclCardinalCardinalSortedMap.HeadMap(ToKey: Cardinal): IJclCardinalCardinalSortedMap;\r\nvar\r\n ToIndex: Integer;\r\n NewMap: TJclCardinalCardinalSortedMap;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n NewMap := CreateEmptyContainer as TJclCardinalCardinalSortedMap;\r\n ToIndex := BinarySearch(ToKey);\r\n if ToIndex >= 0 then\r\n begin\r\n NewMap.SetCapacity(ToIndex + 1);\r\n NewMap.FSize := ToIndex + 1;\r\n while ToIndex >= 0 do\r\n begin\r\n NewMap.FEntries[ToIndex] := FEntries[ToIndex];\r\n Dec(ToIndex);\r\n end;\r\n end;\r\n Result := NewMap;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclCardinalCardinalSortedMap.IsEmpty: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := FSize = 0;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclCardinalCardinalSortedMap.KeyOfValue(Value: Cardinal): Cardinal;\r\nvar\r\n Index: Integer;\r\n Found: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Found := False;\r\n Result := 0;\r\n for Index := 0 to FSize - 1 do\r\n if ValuesCompare(FEntries[Index].Value, Value) = 0 then\r\n begin\r\n Result := FEntries[Index].Key;\r\n Found := True;\r\n Break;\r\n end;\r\n\r\n if (not Found) and (not FReturnDefaultElements) then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclCardinalCardinalSortedMap.KeySet: IJclCardinalSet;\r\nvar\r\n Index: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := TJclCardinalArraySet.Create(FSize);\r\n for Index := 0 to FSize - 1 do\r\n Result.Add(FEntries[Index].Key);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclCardinalCardinalSortedMap.LastKey: Cardinal;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := 0;\r\n if FSize > 0 then\r\n Result := FEntries[FSize - 1].Key\r\n else\r\n if not FReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclCardinalCardinalSortedMap.MapEquals(const AMap: IJclCardinalCardinalMap): Boolean;\r\nvar\r\n It: IJclCardinalIterator;\r\n Index: Integer;\r\n AKey: Cardinal;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if AMap = nil then\r\n Exit;\r\n if FSize <> AMap.Size then\r\n Exit;\r\n It := AMap.KeySet.First;\r\n Index := 0;\r\n while It.HasNext do\r\n begin\r\n if Index >= FSize then\r\n Exit;\r\n AKey := It.Next;\r\n if ValuesCompare(AMap.GetValue(AKey), FEntries[Index].Value) <> 0 then\r\n Exit;\r\n Inc(Index);\r\n end;\r\n Result := True;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclCardinalCardinalSortedMap.InitializeArrayAfterMove(var List: TJclCardinalCardinalSortedMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\nbegin\r\n { Clean array }\r\n if FromIndex < ToIndex then\r\n begin\r\n if (ToIndex - FromIndex) < Count then\r\n Count := ToIndex - FromIndex;\r\n FillChar(List[FromIndex], Count * SizeOf(List[0]), 0);\r\n end\r\n else\r\n if FromIndex > ToIndex then\r\n begin\r\n if (FromIndex - ToIndex) < Count then\r\n FillChar(List[ToIndex + Count], (FromIndex - ToIndex) * SizeOf(List[0]), 0)\r\n else\r\n FillChar(List[FromIndex], Count * SizeOf(List[0]), 0);\r\n end;\r\nend;\r\n\r\nprocedure TJclCardinalCardinalSortedMap.MoveArray(var List: TJclCardinalCardinalSortedMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\nbegin\r\n if Count > 0 then\r\n begin\r\n Move(List[FromIndex], List[ToIndex], Count * SizeOf(List[0]));\r\n InitializeArrayAfterMove(List, FromIndex, ToIndex, Count);\r\n end;\r\nend;\r\n\r\nprocedure TJclCardinalCardinalSortedMap.PutAll(const AMap: IJclCardinalCardinalMap);\r\nvar\r\n It: IJclCardinalIterator;\r\n Key: Cardinal;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if AMap = nil then\r\n Exit;\r\n It := AMap.KeySet.First;\r\n while It.HasNext do\r\n begin\r\n Key := It.Next;\r\n PutValue(Key, AMap.GetValue(Key));\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclCardinalCardinalSortedMap.PutValue(Key: Cardinal; Value: Cardinal);\r\nvar\r\n Index: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FAllowDefaultElements or ((KeysCompare(Key, 0) <> 0) and (ValuesCompare(Value, 0) <> 0)) then\r\n begin\r\n Index := BinarySearch(Key);\r\n\r\n if (Index >= 0) and (KeysCompare(FEntries[Index].Key, Key) = 0) then\r\n begin\r\n FreeValue(FEntries[Index].Value);\r\n FEntries[Index].Value := Value;\r\n end\r\n else\r\n begin\r\n if FSize = FCapacity then\r\n AutoGrow;\r\n if FSize < FCapacity then\r\n begin\r\n Inc(Index);\r\n if (Index < FSize) and (KeysCompare(FEntries[Index].Key, Key) <> 0) then\r\n MoveArray(FEntries, Index, Index + 1, FSize - Index);\r\n FEntries[Index].Key := Key;\r\n FEntries[Index].Value := Value;\r\n Inc(FSize);\r\n end;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclCardinalCardinalSortedMap.Remove(Key: Cardinal): Cardinal;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := Extract(Key);\r\n Result := FreeValue(Result);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclCardinalCardinalSortedMap.SetCapacity(Value: Integer);\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FSize <= Value then\r\n begin\r\n SetLength(FEntries, Value);\r\n inherited SetCapacity(Value);\r\n end\r\n else\r\n raise EJclOperationNotSupportedError.Create;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclCardinalCardinalSortedMap.Size: Integer;\r\nbegin\r\n Result := FSize;\r\nend;\r\n\r\nfunction TJclCardinalCardinalSortedMap.SubMap(FromKey, ToKey: Cardinal): IJclCardinalCardinalSortedMap;\r\nvar\r\n FromIndex, ToIndex: Integer;\r\n NewMap: TJclCardinalCardinalSortedMap;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n NewMap := CreateEmptyContainer as TJclCardinalCardinalSortedMap;\r\n FromIndex := BinarySearch(FromKey);\r\n if (FromIndex = -1) or (KeysCompare(FEntries[FromIndex].Key, FromKey) < 0) then\r\n Inc(FromIndex);\r\n ToIndex := BinarySearch(ToKey);\r\n if (FromIndex >= 0) and (FromIndex <= ToIndex) then\r\n begin\r\n NewMap.SetCapacity(ToIndex - FromIndex + 1);\r\n NewMap.FSize := ToIndex - FromIndex + 1;\r\n while ToIndex >= FromIndex do\r\n begin\r\n NewMap.FEntries[ToIndex - FromIndex] := FEntries[ToIndex];\r\n Dec(ToIndex);\r\n end;\r\n end;\r\n Result := NewMap;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclCardinalCardinalSortedMap.TailMap(FromKey: Cardinal): IJclCardinalCardinalSortedMap;\r\nvar\r\n FromIndex, Index: Integer;\r\n NewMap: TJclCardinalCardinalSortedMap;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n NewMap := CreateEmptyContainer as TJclCardinalCardinalSortedMap;\r\n FromIndex := BinarySearch(FromKey);\r\n if (FromIndex = -1) or (KeysCompare(FEntries[FromIndex].Key, FromKey) < 0) then\r\n Inc(FromIndex);\r\n if (FromIndex >= 0) and (FromIndex < FSize) then\r\n begin\r\n NewMap.SetCapacity(FSize - FromIndex);\r\n NewMap.FSize := FSize - FromIndex;\r\n Index := FromIndex;\r\n while Index < FSize do\r\n begin\r\n NewMap.FEntries[Index - FromIndex] := FEntries[Index];\r\n Inc(Index);\r\n end;\r\n end;\r\n Result := NewMap;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclCardinalCardinalSortedMap.Values: IJclCardinalCollection;\r\nvar\r\n Index: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := TJclCardinalArrayList.Create(FSize);\r\n for Index := 0 to FSize - 1 do\r\n Result.Add(FEntries[Index].Value);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclCardinalCardinalSortedMap.CreateEmptyContainer: TJclAbstractContainerBase;\r\nbegin\r\n Result := TJclCardinalCardinalSortedMap.Create(FSize);\r\n AssignPropertiesTo(Result);\r\nend;\r\n\r\nfunction TJclCardinalCardinalSortedMap.FreeKey(var Key: Cardinal): Cardinal;\r\nbegin\r\n Result := Key;\r\n Key := 0;\r\nend;\r\n\r\nfunction TJclCardinalCardinalSortedMap.FreeValue(var Value: Cardinal): Cardinal;\r\nbegin\r\n Result := Value;\r\n Value := 0;\r\nend;\r\n\r\nfunction TJclCardinalCardinalSortedMap.KeysCompare(A, B: Cardinal): Integer;\r\nbegin\r\n Result := ItemsCompare(A, B);\r\nend;\r\n\r\nfunction TJclCardinalCardinalSortedMap.ValuesCompare(A, B: Cardinal): Integer;\r\nbegin\r\n Result := ItemsCompare(A, B);\r\nend;\r\n\r\n//=== { TJclInt64IntfSortedMap } ==============================================\r\n\r\nconstructor TJclInt64IntfSortedMap.Create(ACapacity: Integer);\r\nbegin\r\n inherited Create();\r\n SetCapacity(ACapacity);\r\nend;\r\n\r\ndestructor TJclInt64IntfSortedMap.Destroy;\r\nbegin\r\n FReadOnly := False;\r\n Clear;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJclInt64IntfSortedMap.AssignDataTo(Dest: TJclAbstractContainerBase);\r\nvar\r\n MyDest: TJclInt64IntfSortedMap;\r\nbegin\r\n inherited AssignDataTo(Dest);\r\n if Dest is TJclInt64IntfSortedMap then\r\n begin\r\n MyDest := TJclInt64IntfSortedMap(Dest);\r\n MyDest.SetCapacity(FSize);\r\n MyDest.FEntries := FEntries;\r\n MyDest.FSize := FSize;\r\n end;\r\nend;\r\n\r\nfunction TJclInt64IntfSortedMap.BinarySearch(const Key: Int64): Integer;\r\nvar\r\n HiPos, LoPos, CompPos: Integer;\r\n Comp: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n LoPos := 0;\r\n HiPos := FSize - 1;\r\n CompPos := (HiPos + LoPos) div 2;\r\n while HiPos >= LoPos do\r\n begin\r\n Comp := KeysCompare(FEntries[CompPos].Key, Key);\r\n if Comp < 0 then\r\n LoPos := CompPos + 1\r\n else\r\n if Comp > 0 then\r\n HiPos := CompPos - 1\r\n else\r\n begin\r\n HiPos := CompPos;\r\n LoPos := CompPos + 1;\r\n end;\r\n CompPos := (HiPos + LoPos) div 2;\r\n end;\r\n Result := HiPos;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclInt64IntfSortedMap.Clear;\r\nvar\r\n Index: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n for Index := 0 to FSize - 1 do\r\n begin\r\n FreeKey(FEntries[Index].Key);\r\n FreeValue(FEntries[Index].Value);\r\n end;\r\n FSize := 0;\r\n AutoPack;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclInt64IntfSortedMap.ContainsKey(const Key: Int64): Boolean;\r\nvar\r\n Index: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Index := BinarySearch(Key);\r\n Result := (Index >= 0) and (KeysCompare(FEntries[Index].Key, Key) = 0);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclInt64IntfSortedMap.ContainsValue(const Value: IInterface): Boolean;\r\nvar\r\n Index: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n for Index := 0 to FSize - 1 do\r\n if ValuesCompare(FEntries[Index].Value, Value) = 0 then\r\n begin\r\n Result := True;\r\n Break;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclInt64IntfSortedMap.FirstKey: Int64;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := 0;\r\n if FSize > 0 then\r\n Result := FEntries[0].Key\r\n else\r\n if not FReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclInt64IntfSortedMap.Extract(const Key: Int64): IInterface;\r\nvar\r\n Index: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Index := BinarySearch(Key);\r\n if (Index >= 0) and (KeysCompare(FEntries[Index].Key, Key) = 0) then\r\n begin\r\n Result := FEntries[Index].Value;\r\n FEntries[Index].Value := nil;\r\n FreeKey(FEntries[Index].Key);\r\n if Index < (FSize - 1) then\r\n MoveArray(FEntries, Index + 1, Index, FSize - Index - 1);\r\n Dec(FSize);\r\n AutoPack;\r\n end\r\n else\r\n Result := nil;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclInt64IntfSortedMap.GetValue(const Key: Int64): IInterface;\r\nvar\r\n Index: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Index := BinarySearch(Key);\r\n Result := nil;\r\n if (Index >= 0) and (KeysCompare(FEntries[Index].Key, Key) = 0) then\r\n Result := FEntries[Index].Value\r\n else if not FReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclInt64IntfSortedMap.HeadMap(const ToKey: Int64): IJclInt64IntfSortedMap;\r\nvar\r\n ToIndex: Integer;\r\n NewMap: TJclInt64IntfSortedMap;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n NewMap := CreateEmptyContainer as TJclInt64IntfSortedMap;\r\n ToIndex := BinarySearch(ToKey);\r\n if ToIndex >= 0 then\r\n begin\r\n NewMap.SetCapacity(ToIndex + 1);\r\n NewMap.FSize := ToIndex + 1;\r\n while ToIndex >= 0 do\r\n begin\r\n NewMap.FEntries[ToIndex] := FEntries[ToIndex];\r\n Dec(ToIndex);\r\n end;\r\n end;\r\n Result := NewMap;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclInt64IntfSortedMap.IsEmpty: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := FSize = 0;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclInt64IntfSortedMap.KeyOfValue(const Value: IInterface): Int64;\r\nvar\r\n Index: Integer;\r\n Found: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Found := False;\r\n Result := 0;\r\n for Index := 0 to FSize - 1 do\r\n if ValuesCompare(FEntries[Index].Value, Value) = 0 then\r\n begin\r\n Result := FEntries[Index].Key;\r\n Found := True;\r\n Break;\r\n end;\r\n\r\n if (not Found) and (not FReturnDefaultElements) then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclInt64IntfSortedMap.KeySet: IJclInt64Set;\r\nvar\r\n Index: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := TJclInt64ArraySet.Create(FSize);\r\n for Index := 0 to FSize - 1 do\r\n Result.Add(FEntries[Index].Key);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclInt64IntfSortedMap.LastKey: Int64;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := 0;\r\n if FSize > 0 then\r\n Result := FEntries[FSize - 1].Key\r\n else\r\n if not FReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclInt64IntfSortedMap.MapEquals(const AMap: IJclInt64IntfMap): Boolean;\r\nvar\r\n It: IJclInt64Iterator;\r\n Index: Integer;\r\n AKey: Int64;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if AMap = nil then\r\n Exit;\r\n if FSize <> AMap.Size then\r\n Exit;\r\n It := AMap.KeySet.First;\r\n Index := 0;\r\n while It.HasNext do\r\n begin\r\n if Index >= FSize then\r\n Exit;\r\n AKey := It.Next;\r\n if ValuesCompare(AMap.GetValue(AKey), FEntries[Index].Value) <> 0 then\r\n Exit;\r\n Inc(Index);\r\n end;\r\n Result := True;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclInt64IntfSortedMap.FinalizeArrayBeforeMove(var List: TJclInt64IntfSortedMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\nbegin\r\n Assert(Count > 0);\r\n if FromIndex < ToIndex then\r\n begin\r\n if Count > (ToIndex - FromIndex) then\r\n Finalize(List[FromIndex + Count], ToIndex - FromIndex)\r\n else\r\n Finalize(List[ToIndex], Count);\r\n end\r\n else\r\n if FromIndex > ToIndex then\r\n begin\r\n if Count > (FromIndex - ToIndex) then\r\n Count := FromIndex - ToIndex;\r\n Finalize(List[ToIndex], Count)\r\n end;\r\nend;\r\n\r\nprocedure TJclInt64IntfSortedMap.InitializeArray(var List: TJclInt64IntfSortedMapEntryArray; FromIndex, Count: SizeInt);\r\nbegin\r\n {$IFDEF FPC}\r\n while Count > 0 do\r\n begin\r\n Initialize(List[FromIndex]);\r\n Inc(FromIndex);\r\n Dec(Count);\r\n end;\r\n {$ELSE ~FPC}\r\n Initialize(List[FromIndex], Count);\r\n {$ENDIF ~FPC}\r\nend;\r\n\r\nprocedure TJclInt64IntfSortedMap.InitializeArrayAfterMove(var List: TJclInt64IntfSortedMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\nbegin\r\n { Keep reference counting working }\r\n if FromIndex < ToIndex then\r\n begin\r\n if (ToIndex - FromIndex) < Count then\r\n Count := ToIndex - FromIndex;\r\n InitializeArray(List, FromIndex, Count);\r\n end\r\n else\r\n if FromIndex > ToIndex then\r\n begin\r\n if (FromIndex - ToIndex) < Count then\r\n InitializeArray(List, ToIndex + Count, FromIndex - ToIndex)\r\n else\r\n InitializeArray(List, FromIndex, Count);\r\n end;\r\nend;\r\n\r\nprocedure TJclInt64IntfSortedMap.MoveArray(var List: TJclInt64IntfSortedMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\nbegin\r\n if Count > 0 then\r\n begin\r\n FinalizeArrayBeforeMove(List, FromIndex, ToIndex, Count);\r\n Move(List[FromIndex], List[ToIndex], Count * SizeOf(List[0]));\r\n InitializeArrayAfterMove(List, FromIndex, ToIndex, Count);\r\n end;\r\nend;\r\n\r\nprocedure TJclInt64IntfSortedMap.PutAll(const AMap: IJclInt64IntfMap);\r\nvar\r\n It: IJclInt64Iterator;\r\n Key: Int64;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if AMap = nil then\r\n Exit;\r\n It := AMap.KeySet.First;\r\n while It.HasNext do\r\n begin\r\n Key := It.Next;\r\n PutValue(Key, AMap.GetValue(Key));\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclInt64IntfSortedMap.PutValue(const Key: Int64; const Value: IInterface);\r\nvar\r\n Index: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FAllowDefaultElements or ((KeysCompare(Key, 0) <> 0) and (ValuesCompare(Value, nil) <> 0)) then\r\n begin\r\n Index := BinarySearch(Key);\r\n\r\n if (Index >= 0) and (KeysCompare(FEntries[Index].Key, Key) = 0) then\r\n begin\r\n FreeValue(FEntries[Index].Value);\r\n FEntries[Index].Value := Value;\r\n end\r\n else\r\n begin\r\n if FSize = FCapacity then\r\n AutoGrow;\r\n if FSize < FCapacity then\r\n begin\r\n Inc(Index);\r\n if (Index < FSize) and (KeysCompare(FEntries[Index].Key, Key) <> 0) then\r\n MoveArray(FEntries, Index, Index + 1, FSize - Index);\r\n FEntries[Index].Key := Key;\r\n FEntries[Index].Value := Value;\r\n Inc(FSize);\r\n end;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclInt64IntfSortedMap.Remove(const Key: Int64): IInterface;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := Extract(Key);\r\n Result := FreeValue(Result);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclInt64IntfSortedMap.SetCapacity(Value: Integer);\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FSize <= Value then\r\n begin\r\n SetLength(FEntries, Value);\r\n inherited SetCapacity(Value);\r\n end\r\n else\r\n raise EJclOperationNotSupportedError.Create;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclInt64IntfSortedMap.Size: Integer;\r\nbegin\r\n Result := FSize;\r\nend;\r\n\r\nfunction TJclInt64IntfSortedMap.SubMap(const FromKey, ToKey: Int64): IJclInt64IntfSortedMap;\r\nvar\r\n FromIndex, ToIndex: Integer;\r\n NewMap: TJclInt64IntfSortedMap;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n NewMap := CreateEmptyContainer as TJclInt64IntfSortedMap;\r\n FromIndex := BinarySearch(FromKey);\r\n if (FromIndex = -1) or (KeysCompare(FEntries[FromIndex].Key, FromKey) < 0) then\r\n Inc(FromIndex);\r\n ToIndex := BinarySearch(ToKey);\r\n if (FromIndex >= 0) and (FromIndex <= ToIndex) then\r\n begin\r\n NewMap.SetCapacity(ToIndex - FromIndex + 1);\r\n NewMap.FSize := ToIndex - FromIndex + 1;\r\n while ToIndex >= FromIndex do\r\n begin\r\n NewMap.FEntries[ToIndex - FromIndex] := FEntries[ToIndex];\r\n Dec(ToIndex);\r\n end;\r\n end;\r\n Result := NewMap;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclInt64IntfSortedMap.TailMap(const FromKey: Int64): IJclInt64IntfSortedMap;\r\nvar\r\n FromIndex, Index: Integer;\r\n NewMap: TJclInt64IntfSortedMap;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n NewMap := CreateEmptyContainer as TJclInt64IntfSortedMap;\r\n FromIndex := BinarySearch(FromKey);\r\n if (FromIndex = -1) or (KeysCompare(FEntries[FromIndex].Key, FromKey) < 0) then\r\n Inc(FromIndex);\r\n if (FromIndex >= 0) and (FromIndex < FSize) then\r\n begin\r\n NewMap.SetCapacity(FSize - FromIndex);\r\n NewMap.FSize := FSize - FromIndex;\r\n Index := FromIndex;\r\n while Index < FSize do\r\n begin\r\n NewMap.FEntries[Index - FromIndex] := FEntries[Index];\r\n Inc(Index);\r\n end;\r\n end;\r\n Result := NewMap;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclInt64IntfSortedMap.Values: IJclIntfCollection;\r\nvar\r\n Index: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := TJclIntfArrayList.Create(FSize);\r\n for Index := 0 to FSize - 1 do\r\n Result.Add(FEntries[Index].Value);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclInt64IntfSortedMap.CreateEmptyContainer: TJclAbstractContainerBase;\r\nbegin\r\n Result := TJclInt64IntfSortedMap.Create(FSize);\r\n AssignPropertiesTo(Result);\r\nend;\r\n\r\nfunction TJclInt64IntfSortedMap.FreeKey(var Key: Int64): Int64;\r\nbegin\r\n Result := Key;\r\n Key := 0;\r\nend;\r\n\r\nfunction TJclInt64IntfSortedMap.FreeValue(var Value: IInterface): IInterface;\r\nbegin\r\n Result := Value;\r\n Value := nil;\r\nend;\r\n\r\nfunction TJclInt64IntfSortedMap.KeysCompare(const A, B: Int64): Integer;\r\nbegin\r\n Result := ItemsCompare(A, B);\r\nend;\r\n\r\nfunction TJclInt64IntfSortedMap.ValuesCompare(const A, B: IInterface): Integer;\r\nbegin\r\n Result := IntfSimpleCompare(A, B);\r\nend;\r\n\r\n//=== { TJclIntfInt64SortedMap } ==============================================\r\n\r\nconstructor TJclIntfInt64SortedMap.Create(ACapacity: Integer);\r\nbegin\r\n inherited Create();\r\n SetCapacity(ACapacity);\r\nend;\r\n\r\ndestructor TJclIntfInt64SortedMap.Destroy;\r\nbegin\r\n FReadOnly := False;\r\n Clear;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJclIntfInt64SortedMap.AssignDataTo(Dest: TJclAbstractContainerBase);\r\nvar\r\n MyDest: TJclIntfInt64SortedMap;\r\nbegin\r\n inherited AssignDataTo(Dest);\r\n if Dest is TJclIntfInt64SortedMap then\r\n begin\r\n MyDest := TJclIntfInt64SortedMap(Dest);\r\n MyDest.SetCapacity(FSize);\r\n MyDest.FEntries := FEntries;\r\n MyDest.FSize := FSize;\r\n end;\r\nend;\r\n\r\nfunction TJclIntfInt64SortedMap.BinarySearch(const Key: IInterface): Integer;\r\nvar\r\n HiPos, LoPos, CompPos: Integer;\r\n Comp: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n LoPos := 0;\r\n HiPos := FSize - 1;\r\n CompPos := (HiPos + LoPos) div 2;\r\n while HiPos >= LoPos do\r\n begin\r\n Comp := KeysCompare(FEntries[CompPos].Key, Key);\r\n if Comp < 0 then\r\n LoPos := CompPos + 1\r\n else\r\n if Comp > 0 then\r\n HiPos := CompPos - 1\r\n else\r\n begin\r\n HiPos := CompPos;\r\n LoPos := CompPos + 1;\r\n end;\r\n CompPos := (HiPos + LoPos) div 2;\r\n end;\r\n Result := HiPos;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclIntfInt64SortedMap.Clear;\r\nvar\r\n Index: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n for Index := 0 to FSize - 1 do\r\n begin\r\n FreeKey(FEntries[Index].Key);\r\n FreeValue(FEntries[Index].Value);\r\n end;\r\n FSize := 0;\r\n AutoPack;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfInt64SortedMap.ContainsKey(const Key: IInterface): Boolean;\r\nvar\r\n Index: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Index := BinarySearch(Key);\r\n Result := (Index >= 0) and (KeysCompare(FEntries[Index].Key, Key) = 0);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfInt64SortedMap.ContainsValue(const Value: Int64): Boolean;\r\nvar\r\n Index: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n for Index := 0 to FSize - 1 do\r\n if ValuesCompare(FEntries[Index].Value, Value) = 0 then\r\n begin\r\n Result := True;\r\n Break;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfInt64SortedMap.FirstKey: IInterface;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := nil;\r\n if FSize > 0 then\r\n Result := FEntries[0].Key\r\n else\r\n if not FReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfInt64SortedMap.Extract(const Key: IInterface): Int64;\r\nvar\r\n Index: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Index := BinarySearch(Key);\r\n if (Index >= 0) and (KeysCompare(FEntries[Index].Key, Key) = 0) then\r\n begin\r\n Result := FEntries[Index].Value;\r\n FEntries[Index].Value := 0;\r\n FreeKey(FEntries[Index].Key);\r\n if Index < (FSize - 1) then\r\n MoveArray(FEntries, Index + 1, Index, FSize - Index - 1);\r\n Dec(FSize);\r\n AutoPack;\r\n end\r\n else\r\n Result := 0;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfInt64SortedMap.GetValue(const Key: IInterface): Int64;\r\nvar\r\n Index: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Index := BinarySearch(Key);\r\n Result := 0;\r\n if (Index >= 0) and (KeysCompare(FEntries[Index].Key, Key) = 0) then\r\n Result := FEntries[Index].Value\r\n else if not FReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfInt64SortedMap.HeadMap(const ToKey: IInterface): IJclIntfInt64SortedMap;\r\nvar\r\n ToIndex: Integer;\r\n NewMap: TJclIntfInt64SortedMap;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n NewMap := CreateEmptyContainer as TJclIntfInt64SortedMap;\r\n ToIndex := BinarySearch(ToKey);\r\n if ToIndex >= 0 then\r\n begin\r\n NewMap.SetCapacity(ToIndex + 1);\r\n NewMap.FSize := ToIndex + 1;\r\n while ToIndex >= 0 do\r\n begin\r\n NewMap.FEntries[ToIndex] := FEntries[ToIndex];\r\n Dec(ToIndex);\r\n end;\r\n end;\r\n Result := NewMap;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfInt64SortedMap.IsEmpty: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := FSize = 0;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfInt64SortedMap.KeyOfValue(const Value: Int64): IInterface;\r\nvar\r\n Index: Integer;\r\n Found: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Found := False;\r\n Result := nil;\r\n for Index := 0 to FSize - 1 do\r\n if ValuesCompare(FEntries[Index].Value, Value) = 0 then\r\n begin\r\n Result := FEntries[Index].Key;\r\n Found := True;\r\n Break;\r\n end;\r\n\r\n if (not Found) and (not FReturnDefaultElements) then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfInt64SortedMap.KeySet: IJclIntfSet;\r\nvar\r\n Index: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := TJclIntfArraySet.Create(FSize);\r\n for Index := 0 to FSize - 1 do\r\n Result.Add(FEntries[Index].Key);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfInt64SortedMap.LastKey: IInterface;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := nil;\r\n if FSize > 0 then\r\n Result := FEntries[FSize - 1].Key\r\n else\r\n if not FReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfInt64SortedMap.MapEquals(const AMap: IJclIntfInt64Map): Boolean;\r\nvar\r\n It: IJclIntfIterator;\r\n Index: Integer;\r\n AKey: IInterface;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if AMap = nil then\r\n Exit;\r\n if FSize <> AMap.Size then\r\n Exit;\r\n It := AMap.KeySet.First;\r\n Index := 0;\r\n while It.HasNext do\r\n begin\r\n if Index >= FSize then\r\n Exit;\r\n AKey := It.Next;\r\n if ValuesCompare(AMap.GetValue(AKey), FEntries[Index].Value) <> 0 then\r\n Exit;\r\n Inc(Index);\r\n end;\r\n Result := True;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclIntfInt64SortedMap.FinalizeArrayBeforeMove(var List: TJclIntfInt64SortedMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\nbegin\r\n Assert(Count > 0);\r\n if FromIndex < ToIndex then\r\n begin\r\n if Count > (ToIndex - FromIndex) then\r\n Finalize(List[FromIndex + Count], ToIndex - FromIndex)\r\n else\r\n Finalize(List[ToIndex], Count);\r\n end\r\n else\r\n if FromIndex > ToIndex then\r\n begin\r\n if Count > (FromIndex - ToIndex) then\r\n Count := FromIndex - ToIndex;\r\n Finalize(List[ToIndex], Count)\r\n end;\r\nend;\r\n\r\nprocedure TJclIntfInt64SortedMap.InitializeArray(var List: TJclIntfInt64SortedMapEntryArray; FromIndex, Count: SizeInt);\r\nbegin\r\n {$IFDEF FPC}\r\n while Count > 0 do\r\n begin\r\n Initialize(List[FromIndex]);\r\n Inc(FromIndex);\r\n Dec(Count);\r\n end;\r\n {$ELSE ~FPC}\r\n Initialize(List[FromIndex], Count);\r\n {$ENDIF ~FPC}\r\nend;\r\n\r\nprocedure TJclIntfInt64SortedMap.InitializeArrayAfterMove(var List: TJclIntfInt64SortedMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\nbegin\r\n { Keep reference counting working }\r\n if FromIndex < ToIndex then\r\n begin\r\n if (ToIndex - FromIndex) < Count then\r\n Count := ToIndex - FromIndex;\r\n InitializeArray(List, FromIndex, Count);\r\n end\r\n else\r\n if FromIndex > ToIndex then\r\n begin\r\n if (FromIndex - ToIndex) < Count then\r\n InitializeArray(List, ToIndex + Count, FromIndex - ToIndex)\r\n else\r\n InitializeArray(List, FromIndex, Count);\r\n end;\r\nend;\r\n\r\nprocedure TJclIntfInt64SortedMap.MoveArray(var List: TJclIntfInt64SortedMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\nbegin\r\n if Count > 0 then\r\n begin\r\n FinalizeArrayBeforeMove(List, FromIndex, ToIndex, Count);\r\n Move(List[FromIndex], List[ToIndex], Count * SizeOf(List[0]));\r\n InitializeArrayAfterMove(List, FromIndex, ToIndex, Count);\r\n end;\r\nend;\r\n\r\nprocedure TJclIntfInt64SortedMap.PutAll(const AMap: IJclIntfInt64Map);\r\nvar\r\n It: IJclIntfIterator;\r\n Key: IInterface;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if AMap = nil then\r\n Exit;\r\n It := AMap.KeySet.First;\r\n while It.HasNext do\r\n begin\r\n Key := It.Next;\r\n PutValue(Key, AMap.GetValue(Key));\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclIntfInt64SortedMap.PutValue(const Key: IInterface; const Value: Int64);\r\nvar\r\n Index: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FAllowDefaultElements or ((KeysCompare(Key, nil) <> 0) and (ValuesCompare(Value, 0) <> 0)) then\r\n begin\r\n Index := BinarySearch(Key);\r\n\r\n if (Index >= 0) and (KeysCompare(FEntries[Index].Key, Key) = 0) then\r\n begin\r\n FreeValue(FEntries[Index].Value);\r\n FEntries[Index].Value := Value;\r\n end\r\n else\r\n begin\r\n if FSize = FCapacity then\r\n AutoGrow;\r\n if FSize < FCapacity then\r\n begin\r\n Inc(Index);\r\n if (Index < FSize) and (KeysCompare(FEntries[Index].Key, Key) <> 0) then\r\n MoveArray(FEntries, Index, Index + 1, FSize - Index);\r\n FEntries[Index].Key := Key;\r\n FEntries[Index].Value := Value;\r\n Inc(FSize);\r\n end;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfInt64SortedMap.Remove(const Key: IInterface): Int64;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := Extract(Key);\r\n Result := FreeValue(Result);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclIntfInt64SortedMap.SetCapacity(Value: Integer);\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FSize <= Value then\r\n begin\r\n SetLength(FEntries, Value);\r\n inherited SetCapacity(Value);\r\n end\r\n else\r\n raise EJclOperationNotSupportedError.Create;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfInt64SortedMap.Size: Integer;\r\nbegin\r\n Result := FSize;\r\nend;\r\n\r\nfunction TJclIntfInt64SortedMap.SubMap(const FromKey, ToKey: IInterface): IJclIntfInt64SortedMap;\r\nvar\r\n FromIndex, ToIndex: Integer;\r\n NewMap: TJclIntfInt64SortedMap;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n NewMap := CreateEmptyContainer as TJclIntfInt64SortedMap;\r\n FromIndex := BinarySearch(FromKey);\r\n if (FromIndex = -1) or (KeysCompare(FEntries[FromIndex].Key, FromKey) < 0) then\r\n Inc(FromIndex);\r\n ToIndex := BinarySearch(ToKey);\r\n if (FromIndex >= 0) and (FromIndex <= ToIndex) then\r\n begin\r\n NewMap.SetCapacity(ToIndex - FromIndex + 1);\r\n NewMap.FSize := ToIndex - FromIndex + 1;\r\n while ToIndex >= FromIndex do\r\n begin\r\n NewMap.FEntries[ToIndex - FromIndex] := FEntries[ToIndex];\r\n Dec(ToIndex);\r\n end;\r\n end;\r\n Result := NewMap;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfInt64SortedMap.TailMap(const FromKey: IInterface): IJclIntfInt64SortedMap;\r\nvar\r\n FromIndex, Index: Integer;\r\n NewMap: TJclIntfInt64SortedMap;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n NewMap := CreateEmptyContainer as TJclIntfInt64SortedMap;\r\n FromIndex := BinarySearch(FromKey);\r\n if (FromIndex = -1) or (KeysCompare(FEntries[FromIndex].Key, FromKey) < 0) then\r\n Inc(FromIndex);\r\n if (FromIndex >= 0) and (FromIndex < FSize) then\r\n begin\r\n NewMap.SetCapacity(FSize - FromIndex);\r\n NewMap.FSize := FSize - FromIndex;\r\n Index := FromIndex;\r\n while Index < FSize do\r\n begin\r\n NewMap.FEntries[Index - FromIndex] := FEntries[Index];\r\n Inc(Index);\r\n end;\r\n end;\r\n Result := NewMap;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfInt64SortedMap.Values: IJclInt64Collection;\r\nvar\r\n Index: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := TJclInt64ArrayList.Create(FSize);\r\n for Index := 0 to FSize - 1 do\r\n Result.Add(FEntries[Index].Value);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfInt64SortedMap.CreateEmptyContainer: TJclAbstractContainerBase;\r\nbegin\r\n Result := TJclIntfInt64SortedMap.Create(FSize);\r\n AssignPropertiesTo(Result);\r\nend;\r\n\r\nfunction TJclIntfInt64SortedMap.FreeKey(var Key: IInterface): IInterface;\r\nbegin\r\n Result := Key;\r\n Key := nil;\r\nend;\r\n\r\nfunction TJclIntfInt64SortedMap.FreeValue(var Value: Int64): Int64;\r\nbegin\r\n Result := Value;\r\n Value := 0;\r\nend;\r\n\r\nfunction TJclIntfInt64SortedMap.KeysCompare(const A, B: IInterface): Integer;\r\nbegin\r\n Result := IntfSimpleCompare(A, B);\r\nend;\r\n\r\nfunction TJclIntfInt64SortedMap.ValuesCompare(const A, B: Int64): Integer;\r\nbegin\r\n Result := ItemsCompare(A, B);\r\nend;\r\n\r\n//=== { TJclInt64Int64SortedMap } ==============================================\r\n\r\nconstructor TJclInt64Int64SortedMap.Create(ACapacity: Integer);\r\nbegin\r\n inherited Create();\r\n SetCapacity(ACapacity);\r\nend;\r\n\r\ndestructor TJclInt64Int64SortedMap.Destroy;\r\nbegin\r\n FReadOnly := False;\r\n Clear;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJclInt64Int64SortedMap.AssignDataTo(Dest: TJclAbstractContainerBase);\r\nvar\r\n MyDest: TJclInt64Int64SortedMap;\r\nbegin\r\n inherited AssignDataTo(Dest);\r\n if Dest is TJclInt64Int64SortedMap then\r\n begin\r\n MyDest := TJclInt64Int64SortedMap(Dest);\r\n MyDest.SetCapacity(FSize);\r\n MyDest.FEntries := FEntries;\r\n MyDest.FSize := FSize;\r\n end;\r\nend;\r\n\r\nfunction TJclInt64Int64SortedMap.BinarySearch(const Key: Int64): Integer;\r\nvar\r\n HiPos, LoPos, CompPos: Integer;\r\n Comp: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n LoPos := 0;\r\n HiPos := FSize - 1;\r\n CompPos := (HiPos + LoPos) div 2;\r\n while HiPos >= LoPos do\r\n begin\r\n Comp := KeysCompare(FEntries[CompPos].Key, Key);\r\n if Comp < 0 then\r\n LoPos := CompPos + 1\r\n else\r\n if Comp > 0 then\r\n HiPos := CompPos - 1\r\n else\r\n begin\r\n HiPos := CompPos;\r\n LoPos := CompPos + 1;\r\n end;\r\n CompPos := (HiPos + LoPos) div 2;\r\n end;\r\n Result := HiPos;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclInt64Int64SortedMap.Clear;\r\nvar\r\n Index: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n for Index := 0 to FSize - 1 do\r\n begin\r\n FreeKey(FEntries[Index].Key);\r\n FreeValue(FEntries[Index].Value);\r\n end;\r\n FSize := 0;\r\n AutoPack;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclInt64Int64SortedMap.ContainsKey(const Key: Int64): Boolean;\r\nvar\r\n Index: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Index := BinarySearch(Key);\r\n Result := (Index >= 0) and (KeysCompare(FEntries[Index].Key, Key) = 0);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclInt64Int64SortedMap.ContainsValue(const Value: Int64): Boolean;\r\nvar\r\n Index: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n for Index := 0 to FSize - 1 do\r\n if ValuesCompare(FEntries[Index].Value, Value) = 0 then\r\n begin\r\n Result := True;\r\n Break;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclInt64Int64SortedMap.FirstKey: Int64;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := 0;\r\n if FSize > 0 then\r\n Result := FEntries[0].Key\r\n else\r\n if not FReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclInt64Int64SortedMap.Extract(const Key: Int64): Int64;\r\nvar\r\n Index: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Index := BinarySearch(Key);\r\n if (Index >= 0) and (KeysCompare(FEntries[Index].Key, Key) = 0) then\r\n begin\r\n Result := FEntries[Index].Value;\r\n FEntries[Index].Value := 0;\r\n FreeKey(FEntries[Index].Key);\r\n if Index < (FSize - 1) then\r\n MoveArray(FEntries, Index + 1, Index, FSize - Index - 1);\r\n Dec(FSize);\r\n AutoPack;\r\n end\r\n else\r\n Result := 0;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclInt64Int64SortedMap.GetValue(const Key: Int64): Int64;\r\nvar\r\n Index: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Index := BinarySearch(Key);\r\n Result := 0;\r\n if (Index >= 0) and (KeysCompare(FEntries[Index].Key, Key) = 0) then\r\n Result := FEntries[Index].Value\r\n else if not FReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclInt64Int64SortedMap.HeadMap(const ToKey: Int64): IJclInt64Int64SortedMap;\r\nvar\r\n ToIndex: Integer;\r\n NewMap: TJclInt64Int64SortedMap;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n NewMap := CreateEmptyContainer as TJclInt64Int64SortedMap;\r\n ToIndex := BinarySearch(ToKey);\r\n if ToIndex >= 0 then\r\n begin\r\n NewMap.SetCapacity(ToIndex + 1);\r\n NewMap.FSize := ToIndex + 1;\r\n while ToIndex >= 0 do\r\n begin\r\n NewMap.FEntries[ToIndex] := FEntries[ToIndex];\r\n Dec(ToIndex);\r\n end;\r\n end;\r\n Result := NewMap;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclInt64Int64SortedMap.IsEmpty: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := FSize = 0;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclInt64Int64SortedMap.KeyOfValue(const Value: Int64): Int64;\r\nvar\r\n Index: Integer;\r\n Found: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Found := False;\r\n Result := 0;\r\n for Index := 0 to FSize - 1 do\r\n if ValuesCompare(FEntries[Index].Value, Value) = 0 then\r\n begin\r\n Result := FEntries[Index].Key;\r\n Found := True;\r\n Break;\r\n end;\r\n\r\n if (not Found) and (not FReturnDefaultElements) then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclInt64Int64SortedMap.KeySet: IJclInt64Set;\r\nvar\r\n Index: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := TJclInt64ArraySet.Create(FSize);\r\n for Index := 0 to FSize - 1 do\r\n Result.Add(FEntries[Index].Key);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclInt64Int64SortedMap.LastKey: Int64;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := 0;\r\n if FSize > 0 then\r\n Result := FEntries[FSize - 1].Key\r\n else\r\n if not FReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclInt64Int64SortedMap.MapEquals(const AMap: IJclInt64Int64Map): Boolean;\r\nvar\r\n It: IJclInt64Iterator;\r\n Index: Integer;\r\n AKey: Int64;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if AMap = nil then\r\n Exit;\r\n if FSize <> AMap.Size then\r\n Exit;\r\n It := AMap.KeySet.First;\r\n Index := 0;\r\n while It.HasNext do\r\n begin\r\n if Index >= FSize then\r\n Exit;\r\n AKey := It.Next;\r\n if ValuesCompare(AMap.GetValue(AKey), FEntries[Index].Value) <> 0 then\r\n Exit;\r\n Inc(Index);\r\n end;\r\n Result := True;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclInt64Int64SortedMap.InitializeArrayAfterMove(var List: TJclInt64Int64SortedMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\nbegin\r\n { Clean array }\r\n if FromIndex < ToIndex then\r\n begin\r\n if (ToIndex - FromIndex) < Count then\r\n Count := ToIndex - FromIndex;\r\n FillChar(List[FromIndex], Count * SizeOf(List[0]), 0);\r\n end\r\n else\r\n if FromIndex > ToIndex then\r\n begin\r\n if (FromIndex - ToIndex) < Count then\r\n FillChar(List[ToIndex + Count], (FromIndex - ToIndex) * SizeOf(List[0]), 0)\r\n else\r\n FillChar(List[FromIndex], Count * SizeOf(List[0]), 0);\r\n end;\r\nend;\r\n\r\nprocedure TJclInt64Int64SortedMap.MoveArray(var List: TJclInt64Int64SortedMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\nbegin\r\n if Count > 0 then\r\n begin\r\n Move(List[FromIndex], List[ToIndex], Count * SizeOf(List[0]));\r\n InitializeArrayAfterMove(List, FromIndex, ToIndex, Count);\r\n end;\r\nend;\r\n\r\nprocedure TJclInt64Int64SortedMap.PutAll(const AMap: IJclInt64Int64Map);\r\nvar\r\n It: IJclInt64Iterator;\r\n Key: Int64;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if AMap = nil then\r\n Exit;\r\n It := AMap.KeySet.First;\r\n while It.HasNext do\r\n begin\r\n Key := It.Next;\r\n PutValue(Key, AMap.GetValue(Key));\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclInt64Int64SortedMap.PutValue(const Key: Int64; const Value: Int64);\r\nvar\r\n Index: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FAllowDefaultElements or ((KeysCompare(Key, 0) <> 0) and (ValuesCompare(Value, 0) <> 0)) then\r\n begin\r\n Index := BinarySearch(Key);\r\n\r\n if (Index >= 0) and (KeysCompare(FEntries[Index].Key, Key) = 0) then\r\n begin\r\n FreeValue(FEntries[Index].Value);\r\n FEntries[Index].Value := Value;\r\n end\r\n else\r\n begin\r\n if FSize = FCapacity then\r\n AutoGrow;\r\n if FSize < FCapacity then\r\n begin\r\n Inc(Index);\r\n if (Index < FSize) and (KeysCompare(FEntries[Index].Key, Key) <> 0) then\r\n MoveArray(FEntries, Index, Index + 1, FSize - Index);\r\n FEntries[Index].Key := Key;\r\n FEntries[Index].Value := Value;\r\n Inc(FSize);\r\n end;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclInt64Int64SortedMap.Remove(const Key: Int64): Int64;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := Extract(Key);\r\n Result := FreeValue(Result);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclInt64Int64SortedMap.SetCapacity(Value: Integer);\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FSize <= Value then\r\n begin\r\n SetLength(FEntries, Value);\r\n inherited SetCapacity(Value);\r\n end\r\n else\r\n raise EJclOperationNotSupportedError.Create;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclInt64Int64SortedMap.Size: Integer;\r\nbegin\r\n Result := FSize;\r\nend;\r\n\r\nfunction TJclInt64Int64SortedMap.SubMap(const FromKey, ToKey: Int64): IJclInt64Int64SortedMap;\r\nvar\r\n FromIndex, ToIndex: Integer;\r\n NewMap: TJclInt64Int64SortedMap;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n NewMap := CreateEmptyContainer as TJclInt64Int64SortedMap;\r\n FromIndex := BinarySearch(FromKey);\r\n if (FromIndex = -1) or (KeysCompare(FEntries[FromIndex].Key, FromKey) < 0) then\r\n Inc(FromIndex);\r\n ToIndex := BinarySearch(ToKey);\r\n if (FromIndex >= 0) and (FromIndex <= ToIndex) then\r\n begin\r\n NewMap.SetCapacity(ToIndex - FromIndex + 1);\r\n NewMap.FSize := ToIndex - FromIndex + 1;\r\n while ToIndex >= FromIndex do\r\n begin\r\n NewMap.FEntries[ToIndex - FromIndex] := FEntries[ToIndex];\r\n Dec(ToIndex);\r\n end;\r\n end;\r\n Result := NewMap;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclInt64Int64SortedMap.TailMap(const FromKey: Int64): IJclInt64Int64SortedMap;\r\nvar\r\n FromIndex, Index: Integer;\r\n NewMap: TJclInt64Int64SortedMap;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n NewMap := CreateEmptyContainer as TJclInt64Int64SortedMap;\r\n FromIndex := BinarySearch(FromKey);\r\n if (FromIndex = -1) or (KeysCompare(FEntries[FromIndex].Key, FromKey) < 0) then\r\n Inc(FromIndex);\r\n if (FromIndex >= 0) and (FromIndex < FSize) then\r\n begin\r\n NewMap.SetCapacity(FSize - FromIndex);\r\n NewMap.FSize := FSize - FromIndex;\r\n Index := FromIndex;\r\n while Index < FSize do\r\n begin\r\n NewMap.FEntries[Index - FromIndex] := FEntries[Index];\r\n Inc(Index);\r\n end;\r\n end;\r\n Result := NewMap;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclInt64Int64SortedMap.Values: IJclInt64Collection;\r\nvar\r\n Index: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := TJclInt64ArrayList.Create(FSize);\r\n for Index := 0 to FSize - 1 do\r\n Result.Add(FEntries[Index].Value);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclInt64Int64SortedMap.CreateEmptyContainer: TJclAbstractContainerBase;\r\nbegin\r\n Result := TJclInt64Int64SortedMap.Create(FSize);\r\n AssignPropertiesTo(Result);\r\nend;\r\n\r\nfunction TJclInt64Int64SortedMap.FreeKey(var Key: Int64): Int64;\r\nbegin\r\n Result := Key;\r\n Key := 0;\r\nend;\r\n\r\nfunction TJclInt64Int64SortedMap.FreeValue(var Value: Int64): Int64;\r\nbegin\r\n Result := Value;\r\n Value := 0;\r\nend;\r\n\r\nfunction TJclInt64Int64SortedMap.KeysCompare(const A, B: Int64): Integer;\r\nbegin\r\n Result := ItemsCompare(A, B);\r\nend;\r\n\r\nfunction TJclInt64Int64SortedMap.ValuesCompare(const A, B: Int64): Integer;\r\nbegin\r\n Result := ItemsCompare(A, B);\r\nend;\r\n\r\n//=== { TJclPtrIntfSortedMap } ==============================================\r\n\r\nconstructor TJclPtrIntfSortedMap.Create(ACapacity: Integer);\r\nbegin\r\n inherited Create();\r\n SetCapacity(ACapacity);\r\nend;\r\n\r\ndestructor TJclPtrIntfSortedMap.Destroy;\r\nbegin\r\n FReadOnly := False;\r\n Clear;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJclPtrIntfSortedMap.AssignDataTo(Dest: TJclAbstractContainerBase);\r\nvar\r\n MyDest: TJclPtrIntfSortedMap;\r\nbegin\r\n inherited AssignDataTo(Dest);\r\n if Dest is TJclPtrIntfSortedMap then\r\n begin\r\n MyDest := TJclPtrIntfSortedMap(Dest);\r\n MyDest.SetCapacity(FSize);\r\n MyDest.FEntries := FEntries;\r\n MyDest.FSize := FSize;\r\n end;\r\nend;\r\n\r\nfunction TJclPtrIntfSortedMap.BinarySearch(Key: Pointer): Integer;\r\nvar\r\n HiPos, LoPos, CompPos: Integer;\r\n Comp: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n LoPos := 0;\r\n HiPos := FSize - 1;\r\n CompPos := (HiPos + LoPos) div 2;\r\n while HiPos >= LoPos do\r\n begin\r\n Comp := KeysCompare(FEntries[CompPos].Key, Key);\r\n if Comp < 0 then\r\n LoPos := CompPos + 1\r\n else\r\n if Comp > 0 then\r\n HiPos := CompPos - 1\r\n else\r\n begin\r\n HiPos := CompPos;\r\n LoPos := CompPos + 1;\r\n end;\r\n CompPos := (HiPos + LoPos) div 2;\r\n end;\r\n Result := HiPos;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclPtrIntfSortedMap.Clear;\r\nvar\r\n Index: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n for Index := 0 to FSize - 1 do\r\n begin\r\n FreeKey(FEntries[Index].Key);\r\n FreeValue(FEntries[Index].Value);\r\n end;\r\n FSize := 0;\r\n AutoPack;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclPtrIntfSortedMap.ContainsKey(Key: Pointer): Boolean;\r\nvar\r\n Index: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Index := BinarySearch(Key);\r\n Result := (Index >= 0) and (KeysCompare(FEntries[Index].Key, Key) = 0);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclPtrIntfSortedMap.ContainsValue(const Value: IInterface): Boolean;\r\nvar\r\n Index: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n for Index := 0 to FSize - 1 do\r\n if ValuesCompare(FEntries[Index].Value, Value) = 0 then\r\n begin\r\n Result := True;\r\n Break;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclPtrIntfSortedMap.FirstKey: Pointer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := nil;\r\n if FSize > 0 then\r\n Result := FEntries[0].Key\r\n else\r\n if not FReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclPtrIntfSortedMap.Extract(Key: Pointer): IInterface;\r\nvar\r\n Index: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Index := BinarySearch(Key);\r\n if (Index >= 0) and (KeysCompare(FEntries[Index].Key, Key) = 0) then\r\n begin\r\n Result := FEntries[Index].Value;\r\n FEntries[Index].Value := nil;\r\n FreeKey(FEntries[Index].Key);\r\n if Index < (FSize - 1) then\r\n MoveArray(FEntries, Index + 1, Index, FSize - Index - 1);\r\n Dec(FSize);\r\n AutoPack;\r\n end\r\n else\r\n Result := nil;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclPtrIntfSortedMap.GetValue(Key: Pointer): IInterface;\r\nvar\r\n Index: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Index := BinarySearch(Key);\r\n Result := nil;\r\n if (Index >= 0) and (KeysCompare(FEntries[Index].Key, Key) = 0) then\r\n Result := FEntries[Index].Value\r\n else if not FReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclPtrIntfSortedMap.HeadMap(ToKey: Pointer): IJclPtrIntfSortedMap;\r\nvar\r\n ToIndex: Integer;\r\n NewMap: TJclPtrIntfSortedMap;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n NewMap := CreateEmptyContainer as TJclPtrIntfSortedMap;\r\n ToIndex := BinarySearch(ToKey);\r\n if ToIndex >= 0 then\r\n begin\r\n NewMap.SetCapacity(ToIndex + 1);\r\n NewMap.FSize := ToIndex + 1;\r\n while ToIndex >= 0 do\r\n begin\r\n NewMap.FEntries[ToIndex] := FEntries[ToIndex];\r\n Dec(ToIndex);\r\n end;\r\n end;\r\n Result := NewMap;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclPtrIntfSortedMap.IsEmpty: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := FSize = 0;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclPtrIntfSortedMap.KeyOfValue(const Value: IInterface): Pointer;\r\nvar\r\n Index: Integer;\r\n Found: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Found := False;\r\n Result := nil;\r\n for Index := 0 to FSize - 1 do\r\n if ValuesCompare(FEntries[Index].Value, Value) = 0 then\r\n begin\r\n Result := FEntries[Index].Key;\r\n Found := True;\r\n Break;\r\n end;\r\n\r\n if (not Found) and (not FReturnDefaultElements) then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclPtrIntfSortedMap.KeySet: IJclPtrSet;\r\nvar\r\n Index: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := TJclPtrArraySet.Create(FSize);\r\n for Index := 0 to FSize - 1 do\r\n Result.Add(FEntries[Index].Key);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclPtrIntfSortedMap.LastKey: Pointer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := nil;\r\n if FSize > 0 then\r\n Result := FEntries[FSize - 1].Key\r\n else\r\n if not FReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclPtrIntfSortedMap.MapEquals(const AMap: IJclPtrIntfMap): Boolean;\r\nvar\r\n It: IJclPtrIterator;\r\n Index: Integer;\r\n AKey: Pointer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if AMap = nil then\r\n Exit;\r\n if FSize <> AMap.Size then\r\n Exit;\r\n It := AMap.KeySet.First;\r\n Index := 0;\r\n while It.HasNext do\r\n begin\r\n if Index >= FSize then\r\n Exit;\r\n AKey := It.Next;\r\n if ValuesCompare(AMap.GetValue(AKey), FEntries[Index].Value) <> 0 then\r\n Exit;\r\n Inc(Index);\r\n end;\r\n Result := True;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclPtrIntfSortedMap.FinalizeArrayBeforeMove(var List: TJclPtrIntfSortedMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\nbegin\r\n Assert(Count > 0);\r\n if FromIndex < ToIndex then\r\n begin\r\n if Count > (ToIndex - FromIndex) then\r\n Finalize(List[FromIndex + Count], ToIndex - FromIndex)\r\n else\r\n Finalize(List[ToIndex], Count);\r\n end\r\n else\r\n if FromIndex > ToIndex then\r\n begin\r\n if Count > (FromIndex - ToIndex) then\r\n Count := FromIndex - ToIndex;\r\n Finalize(List[ToIndex], Count)\r\n end;\r\nend;\r\n\r\nprocedure TJclPtrIntfSortedMap.InitializeArray(var List: TJclPtrIntfSortedMapEntryArray; FromIndex, Count: SizeInt);\r\nbegin\r\n {$IFDEF FPC}\r\n while Count > 0 do\r\n begin\r\n Initialize(List[FromIndex]);\r\n Inc(FromIndex);\r\n Dec(Count);\r\n end;\r\n {$ELSE ~FPC}\r\n Initialize(List[FromIndex], Count);\r\n {$ENDIF ~FPC}\r\nend;\r\n\r\nprocedure TJclPtrIntfSortedMap.InitializeArrayAfterMove(var List: TJclPtrIntfSortedMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\nbegin\r\n { Keep reference counting working }\r\n if FromIndex < ToIndex then\r\n begin\r\n if (ToIndex - FromIndex) < Count then\r\n Count := ToIndex - FromIndex;\r\n InitializeArray(List, FromIndex, Count);\r\n end\r\n else\r\n if FromIndex > ToIndex then\r\n begin\r\n if (FromIndex - ToIndex) < Count then\r\n InitializeArray(List, ToIndex + Count, FromIndex - ToIndex)\r\n else\r\n InitializeArray(List, FromIndex, Count);\r\n end;\r\nend;\r\n\r\nprocedure TJclPtrIntfSortedMap.MoveArray(var List: TJclPtrIntfSortedMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\nbegin\r\n if Count > 0 then\r\n begin\r\n FinalizeArrayBeforeMove(List, FromIndex, ToIndex, Count);\r\n Move(List[FromIndex], List[ToIndex], Count * SizeOf(List[0]));\r\n InitializeArrayAfterMove(List, FromIndex, ToIndex, Count);\r\n end;\r\nend;\r\n\r\nprocedure TJclPtrIntfSortedMap.PutAll(const AMap: IJclPtrIntfMap);\r\nvar\r\n It: IJclPtrIterator;\r\n Key: Pointer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if AMap = nil then\r\n Exit;\r\n It := AMap.KeySet.First;\r\n while It.HasNext do\r\n begin\r\n Key := It.Next;\r\n PutValue(Key, AMap.GetValue(Key));\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclPtrIntfSortedMap.PutValue(Key: Pointer; const Value: IInterface);\r\nvar\r\n Index: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FAllowDefaultElements or ((KeysCompare(Key, nil) <> 0) and (ValuesCompare(Value, nil) <> 0)) then\r\n begin\r\n Index := BinarySearch(Key);\r\n\r\n if (Index >= 0) and (KeysCompare(FEntries[Index].Key, Key) = 0) then\r\n begin\r\n FreeValue(FEntries[Index].Value);\r\n FEntries[Index].Value := Value;\r\n end\r\n else\r\n begin\r\n if FSize = FCapacity then\r\n AutoGrow;\r\n if FSize < FCapacity then\r\n begin\r\n Inc(Index);\r\n if (Index < FSize) and (KeysCompare(FEntries[Index].Key, Key) <> 0) then\r\n MoveArray(FEntries, Index, Index + 1, FSize - Index);\r\n FEntries[Index].Key := Key;\r\n FEntries[Index].Value := Value;\r\n Inc(FSize);\r\n end;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclPtrIntfSortedMap.Remove(Key: Pointer): IInterface;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := Extract(Key);\r\n Result := FreeValue(Result);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclPtrIntfSortedMap.SetCapacity(Value: Integer);\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FSize <= Value then\r\n begin\r\n SetLength(FEntries, Value);\r\n inherited SetCapacity(Value);\r\n end\r\n else\r\n raise EJclOperationNotSupportedError.Create;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclPtrIntfSortedMap.Size: Integer;\r\nbegin\r\n Result := FSize;\r\nend;\r\n\r\nfunction TJclPtrIntfSortedMap.SubMap(FromKey, ToKey: Pointer): IJclPtrIntfSortedMap;\r\nvar\r\n FromIndex, ToIndex: Integer;\r\n NewMap: TJclPtrIntfSortedMap;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n NewMap := CreateEmptyContainer as TJclPtrIntfSortedMap;\r\n FromIndex := BinarySearch(FromKey);\r\n if (FromIndex = -1) or (KeysCompare(FEntries[FromIndex].Key, FromKey) < 0) then\r\n Inc(FromIndex);\r\n ToIndex := BinarySearch(ToKey);\r\n if (FromIndex >= 0) and (FromIndex <= ToIndex) then\r\n begin\r\n NewMap.SetCapacity(ToIndex - FromIndex + 1);\r\n NewMap.FSize := ToIndex - FromIndex + 1;\r\n while ToIndex >= FromIndex do\r\n begin\r\n NewMap.FEntries[ToIndex - FromIndex] := FEntries[ToIndex];\r\n Dec(ToIndex);\r\n end;\r\n end;\r\n Result := NewMap;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclPtrIntfSortedMap.TailMap(FromKey: Pointer): IJclPtrIntfSortedMap;\r\nvar\r\n FromIndex, Index: Integer;\r\n NewMap: TJclPtrIntfSortedMap;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n NewMap := CreateEmptyContainer as TJclPtrIntfSortedMap;\r\n FromIndex := BinarySearch(FromKey);\r\n if (FromIndex = -1) or (KeysCompare(FEntries[FromIndex].Key, FromKey) < 0) then\r\n Inc(FromIndex);\r\n if (FromIndex >= 0) and (FromIndex < FSize) then\r\n begin\r\n NewMap.SetCapacity(FSize - FromIndex);\r\n NewMap.FSize := FSize - FromIndex;\r\n Index := FromIndex;\r\n while Index < FSize do\r\n begin\r\n NewMap.FEntries[Index - FromIndex] := FEntries[Index];\r\n Inc(Index);\r\n end;\r\n end;\r\n Result := NewMap;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclPtrIntfSortedMap.Values: IJclIntfCollection;\r\nvar\r\n Index: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := TJclIntfArrayList.Create(FSize);\r\n for Index := 0 to FSize - 1 do\r\n Result.Add(FEntries[Index].Value);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclPtrIntfSortedMap.CreateEmptyContainer: TJclAbstractContainerBase;\r\nbegin\r\n Result := TJclPtrIntfSortedMap.Create(FSize);\r\n AssignPropertiesTo(Result);\r\nend;\r\n\r\nfunction TJclPtrIntfSortedMap.FreeKey(var Key: Pointer): Pointer;\r\nbegin\r\n Result := Key;\r\n Key := nil;\r\nend;\r\n\r\nfunction TJclPtrIntfSortedMap.FreeValue(var Value: IInterface): IInterface;\r\nbegin\r\n Result := Value;\r\n Value := nil;\r\nend;\r\n\r\nfunction TJclPtrIntfSortedMap.KeysCompare(A, B: Pointer): Integer;\r\nbegin\r\n Result := ItemsCompare(A, B);\r\nend;\r\n\r\nfunction TJclPtrIntfSortedMap.ValuesCompare(const A, B: IInterface): Integer;\r\nbegin\r\n Result := IntfSimpleCompare(A, B);\r\nend;\r\n\r\n//=== { TJclIntfPtrSortedMap } ==============================================\r\n\r\nconstructor TJclIntfPtrSortedMap.Create(ACapacity: Integer);\r\nbegin\r\n inherited Create();\r\n SetCapacity(ACapacity);\r\nend;\r\n\r\ndestructor TJclIntfPtrSortedMap.Destroy;\r\nbegin\r\n FReadOnly := False;\r\n Clear;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJclIntfPtrSortedMap.AssignDataTo(Dest: TJclAbstractContainerBase);\r\nvar\r\n MyDest: TJclIntfPtrSortedMap;\r\nbegin\r\n inherited AssignDataTo(Dest);\r\n if Dest is TJclIntfPtrSortedMap then\r\n begin\r\n MyDest := TJclIntfPtrSortedMap(Dest);\r\n MyDest.SetCapacity(FSize);\r\n MyDest.FEntries := FEntries;\r\n MyDest.FSize := FSize;\r\n end;\r\nend;\r\n\r\nfunction TJclIntfPtrSortedMap.BinarySearch(const Key: IInterface): Integer;\r\nvar\r\n HiPos, LoPos, CompPos: Integer;\r\n Comp: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n LoPos := 0;\r\n HiPos := FSize - 1;\r\n CompPos := (HiPos + LoPos) div 2;\r\n while HiPos >= LoPos do\r\n begin\r\n Comp := KeysCompare(FEntries[CompPos].Key, Key);\r\n if Comp < 0 then\r\n LoPos := CompPos + 1\r\n else\r\n if Comp > 0 then\r\n HiPos := CompPos - 1\r\n else\r\n begin\r\n HiPos := CompPos;\r\n LoPos := CompPos + 1;\r\n end;\r\n CompPos := (HiPos + LoPos) div 2;\r\n end;\r\n Result := HiPos;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclIntfPtrSortedMap.Clear;\r\nvar\r\n Index: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n for Index := 0 to FSize - 1 do\r\n begin\r\n FreeKey(FEntries[Index].Key);\r\n FreeValue(FEntries[Index].Value);\r\n end;\r\n FSize := 0;\r\n AutoPack;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfPtrSortedMap.ContainsKey(const Key: IInterface): Boolean;\r\nvar\r\n Index: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Index := BinarySearch(Key);\r\n Result := (Index >= 0) and (KeysCompare(FEntries[Index].Key, Key) = 0);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfPtrSortedMap.ContainsValue(Value: Pointer): Boolean;\r\nvar\r\n Index: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n for Index := 0 to FSize - 1 do\r\n if ValuesCompare(FEntries[Index].Value, Value) = 0 then\r\n begin\r\n Result := True;\r\n Break;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfPtrSortedMap.FirstKey: IInterface;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := nil;\r\n if FSize > 0 then\r\n Result := FEntries[0].Key\r\n else\r\n if not FReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfPtrSortedMap.Extract(const Key: IInterface): Pointer;\r\nvar\r\n Index: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Index := BinarySearch(Key);\r\n if (Index >= 0) and (KeysCompare(FEntries[Index].Key, Key) = 0) then\r\n begin\r\n Result := FEntries[Index].Value;\r\n FEntries[Index].Value := nil;\r\n FreeKey(FEntries[Index].Key);\r\n if Index < (FSize - 1) then\r\n MoveArray(FEntries, Index + 1, Index, FSize - Index - 1);\r\n Dec(FSize);\r\n AutoPack;\r\n end\r\n else\r\n Result := nil;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfPtrSortedMap.GetValue(const Key: IInterface): Pointer;\r\nvar\r\n Index: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Index := BinarySearch(Key);\r\n Result := nil;\r\n if (Index >= 0) and (KeysCompare(FEntries[Index].Key, Key) = 0) then\r\n Result := FEntries[Index].Value\r\n else if not FReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfPtrSortedMap.HeadMap(const ToKey: IInterface): IJclIntfPtrSortedMap;\r\nvar\r\n ToIndex: Integer;\r\n NewMap: TJclIntfPtrSortedMap;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n NewMap := CreateEmptyContainer as TJclIntfPtrSortedMap;\r\n ToIndex := BinarySearch(ToKey);\r\n if ToIndex >= 0 then\r\n begin\r\n NewMap.SetCapacity(ToIndex + 1);\r\n NewMap.FSize := ToIndex + 1;\r\n while ToIndex >= 0 do\r\n begin\r\n NewMap.FEntries[ToIndex] := FEntries[ToIndex];\r\n Dec(ToIndex);\r\n end;\r\n end;\r\n Result := NewMap;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfPtrSortedMap.IsEmpty: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := FSize = 0;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfPtrSortedMap.KeyOfValue(Value: Pointer): IInterface;\r\nvar\r\n Index: Integer;\r\n Found: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Found := False;\r\n Result := nil;\r\n for Index := 0 to FSize - 1 do\r\n if ValuesCompare(FEntries[Index].Value, Value) = 0 then\r\n begin\r\n Result := FEntries[Index].Key;\r\n Found := True;\r\n Break;\r\n end;\r\n\r\n if (not Found) and (not FReturnDefaultElements) then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfPtrSortedMap.KeySet: IJclIntfSet;\r\nvar\r\n Index: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := TJclIntfArraySet.Create(FSize);\r\n for Index := 0 to FSize - 1 do\r\n Result.Add(FEntries[Index].Key);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfPtrSortedMap.LastKey: IInterface;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := nil;\r\n if FSize > 0 then\r\n Result := FEntries[FSize - 1].Key\r\n else\r\n if not FReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfPtrSortedMap.MapEquals(const AMap: IJclIntfPtrMap): Boolean;\r\nvar\r\n It: IJclIntfIterator;\r\n Index: Integer;\r\n AKey: IInterface;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if AMap = nil then\r\n Exit;\r\n if FSize <> AMap.Size then\r\n Exit;\r\n It := AMap.KeySet.First;\r\n Index := 0;\r\n while It.HasNext do\r\n begin\r\n if Index >= FSize then\r\n Exit;\r\n AKey := It.Next;\r\n if ValuesCompare(AMap.GetValue(AKey), FEntries[Index].Value) <> 0 then\r\n Exit;\r\n Inc(Index);\r\n end;\r\n Result := True;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclIntfPtrSortedMap.FinalizeArrayBeforeMove(var List: TJclIntfPtrSortedMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\nbegin\r\n Assert(Count > 0);\r\n if FromIndex < ToIndex then\r\n begin\r\n if Count > (ToIndex - FromIndex) then\r\n Finalize(List[FromIndex + Count], ToIndex - FromIndex)\r\n else\r\n Finalize(List[ToIndex], Count);\r\n end\r\n else\r\n if FromIndex > ToIndex then\r\n begin\r\n if Count > (FromIndex - ToIndex) then\r\n Count := FromIndex - ToIndex;\r\n Finalize(List[ToIndex], Count)\r\n end;\r\nend;\r\n\r\nprocedure TJclIntfPtrSortedMap.InitializeArray(var List: TJclIntfPtrSortedMapEntryArray; FromIndex, Count: SizeInt);\r\nbegin\r\n {$IFDEF FPC}\r\n while Count > 0 do\r\n begin\r\n Initialize(List[FromIndex]);\r\n Inc(FromIndex);\r\n Dec(Count);\r\n end;\r\n {$ELSE ~FPC}\r\n Initialize(List[FromIndex], Count);\r\n {$ENDIF ~FPC}\r\nend;\r\n\r\nprocedure TJclIntfPtrSortedMap.InitializeArrayAfterMove(var List: TJclIntfPtrSortedMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\nbegin\r\n { Keep reference counting working }\r\n if FromIndex < ToIndex then\r\n begin\r\n if (ToIndex - FromIndex) < Count then\r\n Count := ToIndex - FromIndex;\r\n InitializeArray(List, FromIndex, Count);\r\n end\r\n else\r\n if FromIndex > ToIndex then\r\n begin\r\n if (FromIndex - ToIndex) < Count then\r\n InitializeArray(List, ToIndex + Count, FromIndex - ToIndex)\r\n else\r\n InitializeArray(List, FromIndex, Count);\r\n end;\r\nend;\r\n\r\nprocedure TJclIntfPtrSortedMap.MoveArray(var List: TJclIntfPtrSortedMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\nbegin\r\n if Count > 0 then\r\n begin\r\n FinalizeArrayBeforeMove(List, FromIndex, ToIndex, Count);\r\n Move(List[FromIndex], List[ToIndex], Count * SizeOf(List[0]));\r\n InitializeArrayAfterMove(List, FromIndex, ToIndex, Count);\r\n end;\r\nend;\r\n\r\nprocedure TJclIntfPtrSortedMap.PutAll(const AMap: IJclIntfPtrMap);\r\nvar\r\n It: IJclIntfIterator;\r\n Key: IInterface;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if AMap = nil then\r\n Exit;\r\n It := AMap.KeySet.First;\r\n while It.HasNext do\r\n begin\r\n Key := It.Next;\r\n PutValue(Key, AMap.GetValue(Key));\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclIntfPtrSortedMap.PutValue(const Key: IInterface; Value: Pointer);\r\nvar\r\n Index: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FAllowDefaultElements or ((KeysCompare(Key, nil) <> 0) and (ValuesCompare(Value, nil) <> 0)) then\r\n begin\r\n Index := BinarySearch(Key);\r\n\r\n if (Index >= 0) and (KeysCompare(FEntries[Index].Key, Key) = 0) then\r\n begin\r\n FreeValue(FEntries[Index].Value);\r\n FEntries[Index].Value := Value;\r\n end\r\n else\r\n begin\r\n if FSize = FCapacity then\r\n AutoGrow;\r\n if FSize < FCapacity then\r\n begin\r\n Inc(Index);\r\n if (Index < FSize) and (KeysCompare(FEntries[Index].Key, Key) <> 0) then\r\n MoveArray(FEntries, Index, Index + 1, FSize - Index);\r\n FEntries[Index].Key := Key;\r\n FEntries[Index].Value := Value;\r\n Inc(FSize);\r\n end;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfPtrSortedMap.Remove(const Key: IInterface): Pointer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := Extract(Key);\r\n Result := FreeValue(Result);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclIntfPtrSortedMap.SetCapacity(Value: Integer);\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FSize <= Value then\r\n begin\r\n SetLength(FEntries, Value);\r\n inherited SetCapacity(Value);\r\n end\r\n else\r\n raise EJclOperationNotSupportedError.Create;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfPtrSortedMap.Size: Integer;\r\nbegin\r\n Result := FSize;\r\nend;\r\n\r\nfunction TJclIntfPtrSortedMap.SubMap(const FromKey, ToKey: IInterface): IJclIntfPtrSortedMap;\r\nvar\r\n FromIndex, ToIndex: Integer;\r\n NewMap: TJclIntfPtrSortedMap;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n NewMap := CreateEmptyContainer as TJclIntfPtrSortedMap;\r\n FromIndex := BinarySearch(FromKey);\r\n if (FromIndex = -1) or (KeysCompare(FEntries[FromIndex].Key, FromKey) < 0) then\r\n Inc(FromIndex);\r\n ToIndex := BinarySearch(ToKey);\r\n if (FromIndex >= 0) and (FromIndex <= ToIndex) then\r\n begin\r\n NewMap.SetCapacity(ToIndex - FromIndex + 1);\r\n NewMap.FSize := ToIndex - FromIndex + 1;\r\n while ToIndex >= FromIndex do\r\n begin\r\n NewMap.FEntries[ToIndex - FromIndex] := FEntries[ToIndex];\r\n Dec(ToIndex);\r\n end;\r\n end;\r\n Result := NewMap;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfPtrSortedMap.TailMap(const FromKey: IInterface): IJclIntfPtrSortedMap;\r\nvar\r\n FromIndex, Index: Integer;\r\n NewMap: TJclIntfPtrSortedMap;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n NewMap := CreateEmptyContainer as TJclIntfPtrSortedMap;\r\n FromIndex := BinarySearch(FromKey);\r\n if (FromIndex = -1) or (KeysCompare(FEntries[FromIndex].Key, FromKey) < 0) then\r\n Inc(FromIndex);\r\n if (FromIndex >= 0) and (FromIndex < FSize) then\r\n begin\r\n NewMap.SetCapacity(FSize - FromIndex);\r\n NewMap.FSize := FSize - FromIndex;\r\n Index := FromIndex;\r\n while Index < FSize do\r\n begin\r\n NewMap.FEntries[Index - FromIndex] := FEntries[Index];\r\n Inc(Index);\r\n end;\r\n end;\r\n Result := NewMap;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfPtrSortedMap.Values: IJclPtrCollection;\r\nvar\r\n Index: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := TJclPtrArrayList.Create(FSize);\r\n for Index := 0 to FSize - 1 do\r\n Result.Add(FEntries[Index].Value);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfPtrSortedMap.CreateEmptyContainer: TJclAbstractContainerBase;\r\nbegin\r\n Result := TJclIntfPtrSortedMap.Create(FSize);\r\n AssignPropertiesTo(Result);\r\nend;\r\n\r\nfunction TJclIntfPtrSortedMap.FreeKey(var Key: IInterface): IInterface;\r\nbegin\r\n Result := Key;\r\n Key := nil;\r\nend;\r\n\r\nfunction TJclIntfPtrSortedMap.FreeValue(var Value: Pointer): Pointer;\r\nbegin\r\n Result := Value;\r\n Value := nil;\r\nend;\r\n\r\nfunction TJclIntfPtrSortedMap.KeysCompare(const A, B: IInterface): Integer;\r\nbegin\r\n Result := IntfSimpleCompare(A, B);\r\nend;\r\n\r\nfunction TJclIntfPtrSortedMap.ValuesCompare(A, B: Pointer): Integer;\r\nbegin\r\n Result := ItemsCompare(A, B);\r\nend;\r\n\r\n//=== { TJclPtrPtrSortedMap } ==============================================\r\n\r\nconstructor TJclPtrPtrSortedMap.Create(ACapacity: Integer);\r\nbegin\r\n inherited Create();\r\n SetCapacity(ACapacity);\r\nend;\r\n\r\ndestructor TJclPtrPtrSortedMap.Destroy;\r\nbegin\r\n FReadOnly := False;\r\n Clear;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJclPtrPtrSortedMap.AssignDataTo(Dest: TJclAbstractContainerBase);\r\nvar\r\n MyDest: TJclPtrPtrSortedMap;\r\nbegin\r\n inherited AssignDataTo(Dest);\r\n if Dest is TJclPtrPtrSortedMap then\r\n begin\r\n MyDest := TJclPtrPtrSortedMap(Dest);\r\n MyDest.SetCapacity(FSize);\r\n MyDest.FEntries := FEntries;\r\n MyDest.FSize := FSize;\r\n end;\r\nend;\r\n\r\nfunction TJclPtrPtrSortedMap.BinarySearch(Key: Pointer): Integer;\r\nvar\r\n HiPos, LoPos, CompPos: Integer;\r\n Comp: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n LoPos := 0;\r\n HiPos := FSize - 1;\r\n CompPos := (HiPos + LoPos) div 2;\r\n while HiPos >= LoPos do\r\n begin\r\n Comp := KeysCompare(FEntries[CompPos].Key, Key);\r\n if Comp < 0 then\r\n LoPos := CompPos + 1\r\n else\r\n if Comp > 0 then\r\n HiPos := CompPos - 1\r\n else\r\n begin\r\n HiPos := CompPos;\r\n LoPos := CompPos + 1;\r\n end;\r\n CompPos := (HiPos + LoPos) div 2;\r\n end;\r\n Result := HiPos;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclPtrPtrSortedMap.Clear;\r\nvar\r\n Index: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n for Index := 0 to FSize - 1 do\r\n begin\r\n FreeKey(FEntries[Index].Key);\r\n FreeValue(FEntries[Index].Value);\r\n end;\r\n FSize := 0;\r\n AutoPack;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclPtrPtrSortedMap.ContainsKey(Key: Pointer): Boolean;\r\nvar\r\n Index: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Index := BinarySearch(Key);\r\n Result := (Index >= 0) and (KeysCompare(FEntries[Index].Key, Key) = 0);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclPtrPtrSortedMap.ContainsValue(Value: Pointer): Boolean;\r\nvar\r\n Index: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n for Index := 0 to FSize - 1 do\r\n if ValuesCompare(FEntries[Index].Value, Value) = 0 then\r\n begin\r\n Result := True;\r\n Break;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclPtrPtrSortedMap.FirstKey: Pointer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := nil;\r\n if FSize > 0 then\r\n Result := FEntries[0].Key\r\n else\r\n if not FReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclPtrPtrSortedMap.Extract(Key: Pointer): Pointer;\r\nvar\r\n Index: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Index := BinarySearch(Key);\r\n if (Index >= 0) and (KeysCompare(FEntries[Index].Key, Key) = 0) then\r\n begin\r\n Result := FEntries[Index].Value;\r\n FEntries[Index].Value := nil;\r\n FreeKey(FEntries[Index].Key);\r\n if Index < (FSize - 1) then\r\n MoveArray(FEntries, Index + 1, Index, FSize - Index - 1);\r\n Dec(FSize);\r\n AutoPack;\r\n end\r\n else\r\n Result := nil;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclPtrPtrSortedMap.GetValue(Key: Pointer): Pointer;\r\nvar\r\n Index: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Index := BinarySearch(Key);\r\n Result := nil;\r\n if (Index >= 0) and (KeysCompare(FEntries[Index].Key, Key) = 0) then\r\n Result := FEntries[Index].Value\r\n else if not FReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclPtrPtrSortedMap.HeadMap(ToKey: Pointer): IJclPtrPtrSortedMap;\r\nvar\r\n ToIndex: Integer;\r\n NewMap: TJclPtrPtrSortedMap;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n NewMap := CreateEmptyContainer as TJclPtrPtrSortedMap;\r\n ToIndex := BinarySearch(ToKey);\r\n if ToIndex >= 0 then\r\n begin\r\n NewMap.SetCapacity(ToIndex + 1);\r\n NewMap.FSize := ToIndex + 1;\r\n while ToIndex >= 0 do\r\n begin\r\n NewMap.FEntries[ToIndex] := FEntries[ToIndex];\r\n Dec(ToIndex);\r\n end;\r\n end;\r\n Result := NewMap;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclPtrPtrSortedMap.IsEmpty: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := FSize = 0;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclPtrPtrSortedMap.KeyOfValue(Value: Pointer): Pointer;\r\nvar\r\n Index: Integer;\r\n Found: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Found := False;\r\n Result := nil;\r\n for Index := 0 to FSize - 1 do\r\n if ValuesCompare(FEntries[Index].Value, Value) = 0 then\r\n begin\r\n Result := FEntries[Index].Key;\r\n Found := True;\r\n Break;\r\n end;\r\n\r\n if (not Found) and (not FReturnDefaultElements) then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclPtrPtrSortedMap.KeySet: IJclPtrSet;\r\nvar\r\n Index: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := TJclPtrArraySet.Create(FSize);\r\n for Index := 0 to FSize - 1 do\r\n Result.Add(FEntries[Index].Key);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclPtrPtrSortedMap.LastKey: Pointer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := nil;\r\n if FSize > 0 then\r\n Result := FEntries[FSize - 1].Key\r\n else\r\n if not FReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclPtrPtrSortedMap.MapEquals(const AMap: IJclPtrPtrMap): Boolean;\r\nvar\r\n It: IJclPtrIterator;\r\n Index: Integer;\r\n AKey: Pointer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if AMap = nil then\r\n Exit;\r\n if FSize <> AMap.Size then\r\n Exit;\r\n It := AMap.KeySet.First;\r\n Index := 0;\r\n while It.HasNext do\r\n begin\r\n if Index >= FSize then\r\n Exit;\r\n AKey := It.Next;\r\n if ValuesCompare(AMap.GetValue(AKey), FEntries[Index].Value) <> 0 then\r\n Exit;\r\n Inc(Index);\r\n end;\r\n Result := True;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclPtrPtrSortedMap.InitializeArrayAfterMove(var List: TJclPtrPtrSortedMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\nbegin\r\n { Clean array }\r\n if FromIndex < ToIndex then\r\n begin\r\n if (ToIndex - FromIndex) < Count then\r\n Count := ToIndex - FromIndex;\r\n FillChar(List[FromIndex], Count * SizeOf(List[0]), 0);\r\n end\r\n else\r\n if FromIndex > ToIndex then\r\n begin\r\n if (FromIndex - ToIndex) < Count then\r\n FillChar(List[ToIndex + Count], (FromIndex - ToIndex) * SizeOf(List[0]), 0)\r\n else\r\n FillChar(List[FromIndex], Count * SizeOf(List[0]), 0);\r\n end;\r\nend;\r\n\r\nprocedure TJclPtrPtrSortedMap.MoveArray(var List: TJclPtrPtrSortedMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\nbegin\r\n if Count > 0 then\r\n begin\r\n Move(List[FromIndex], List[ToIndex], Count * SizeOf(List[0]));\r\n InitializeArrayAfterMove(List, FromIndex, ToIndex, Count);\r\n end;\r\nend;\r\n\r\nprocedure TJclPtrPtrSortedMap.PutAll(const AMap: IJclPtrPtrMap);\r\nvar\r\n It: IJclPtrIterator;\r\n Key: Pointer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if AMap = nil then\r\n Exit;\r\n It := AMap.KeySet.First;\r\n while It.HasNext do\r\n begin\r\n Key := It.Next;\r\n PutValue(Key, AMap.GetValue(Key));\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclPtrPtrSortedMap.PutValue(Key: Pointer; Value: Pointer);\r\nvar\r\n Index: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FAllowDefaultElements or ((KeysCompare(Key, nil) <> 0) and (ValuesCompare(Value, nil) <> 0)) then\r\n begin\r\n Index := BinarySearch(Key);\r\n\r\n if (Index >= 0) and (KeysCompare(FEntries[Index].Key, Key) = 0) then\r\n begin\r\n FreeValue(FEntries[Index].Value);\r\n FEntries[Index].Value := Value;\r\n end\r\n else\r\n begin\r\n if FSize = FCapacity then\r\n AutoGrow;\r\n if FSize < FCapacity then\r\n begin\r\n Inc(Index);\r\n if (Index < FSize) and (KeysCompare(FEntries[Index].Key, Key) <> 0) then\r\n MoveArray(FEntries, Index, Index + 1, FSize - Index);\r\n FEntries[Index].Key := Key;\r\n FEntries[Index].Value := Value;\r\n Inc(FSize);\r\n end;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclPtrPtrSortedMap.Remove(Key: Pointer): Pointer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := Extract(Key);\r\n Result := FreeValue(Result);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclPtrPtrSortedMap.SetCapacity(Value: Integer);\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FSize <= Value then\r\n begin\r\n SetLength(FEntries, Value);\r\n inherited SetCapacity(Value);\r\n end\r\n else\r\n raise EJclOperationNotSupportedError.Create;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclPtrPtrSortedMap.Size: Integer;\r\nbegin\r\n Result := FSize;\r\nend;\r\n\r\nfunction TJclPtrPtrSortedMap.SubMap(FromKey, ToKey: Pointer): IJclPtrPtrSortedMap;\r\nvar\r\n FromIndex, ToIndex: Integer;\r\n NewMap: TJclPtrPtrSortedMap;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n NewMap := CreateEmptyContainer as TJclPtrPtrSortedMap;\r\n FromIndex := BinarySearch(FromKey);\r\n if (FromIndex = -1) or (KeysCompare(FEntries[FromIndex].Key, FromKey) < 0) then\r\n Inc(FromIndex);\r\n ToIndex := BinarySearch(ToKey);\r\n if (FromIndex >= 0) and (FromIndex <= ToIndex) then\r\n begin\r\n NewMap.SetCapacity(ToIndex - FromIndex + 1);\r\n NewMap.FSize := ToIndex - FromIndex + 1;\r\n while ToIndex >= FromIndex do\r\n begin\r\n NewMap.FEntries[ToIndex - FromIndex] := FEntries[ToIndex];\r\n Dec(ToIndex);\r\n end;\r\n end;\r\n Result := NewMap;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclPtrPtrSortedMap.TailMap(FromKey: Pointer): IJclPtrPtrSortedMap;\r\nvar\r\n FromIndex, Index: Integer;\r\n NewMap: TJclPtrPtrSortedMap;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n NewMap := CreateEmptyContainer as TJclPtrPtrSortedMap;\r\n FromIndex := BinarySearch(FromKey);\r\n if (FromIndex = -1) or (KeysCompare(FEntries[FromIndex].Key, FromKey) < 0) then\r\n Inc(FromIndex);\r\n if (FromIndex >= 0) and (FromIndex < FSize) then\r\n begin\r\n NewMap.SetCapacity(FSize - FromIndex);\r\n NewMap.FSize := FSize - FromIndex;\r\n Index := FromIndex;\r\n while Index < FSize do\r\n begin\r\n NewMap.FEntries[Index - FromIndex] := FEntries[Index];\r\n Inc(Index);\r\n end;\r\n end;\r\n Result := NewMap;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclPtrPtrSortedMap.Values: IJclPtrCollection;\r\nvar\r\n Index: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := TJclPtrArrayList.Create(FSize);\r\n for Index := 0 to FSize - 1 do\r\n Result.Add(FEntries[Index].Value);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclPtrPtrSortedMap.CreateEmptyContainer: TJclAbstractContainerBase;\r\nbegin\r\n Result := TJclPtrPtrSortedMap.Create(FSize);\r\n AssignPropertiesTo(Result);\r\nend;\r\n\r\nfunction TJclPtrPtrSortedMap.FreeKey(var Key: Pointer): Pointer;\r\nbegin\r\n Result := Key;\r\n Key := nil;\r\nend;\r\n\r\nfunction TJclPtrPtrSortedMap.FreeValue(var Value: Pointer): Pointer;\r\nbegin\r\n Result := Value;\r\n Value := nil;\r\nend;\r\n\r\nfunction TJclPtrPtrSortedMap.KeysCompare(A, B: Pointer): Integer;\r\nbegin\r\n Result := ItemsCompare(A, B);\r\nend;\r\n\r\nfunction TJclPtrPtrSortedMap.ValuesCompare(A, B: Pointer): Integer;\r\nbegin\r\n Result := ItemsCompare(A, B);\r\nend;\r\n\r\n//=== { TJclIntfSortedMap } ==============================================\r\n\r\nconstructor TJclIntfSortedMap.Create(ACapacity: Integer; AOwnsValues: Boolean);\r\nbegin\r\n inherited Create();\r\n FOwnsValues := AOwnsValues;\r\n SetCapacity(ACapacity);\r\nend;\r\n\r\ndestructor TJclIntfSortedMap.Destroy;\r\nbegin\r\n FReadOnly := False;\r\n Clear;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJclIntfSortedMap.AssignDataTo(Dest: TJclAbstractContainerBase);\r\nvar\r\n MyDest: TJclIntfSortedMap;\r\nbegin\r\n inherited AssignDataTo(Dest);\r\n if Dest is TJclIntfSortedMap then\r\n begin\r\n MyDest := TJclIntfSortedMap(Dest);\r\n MyDest.SetCapacity(FSize);\r\n MyDest.FEntries := FEntries;\r\n MyDest.FSize := FSize;\r\n end;\r\nend;\r\n\r\nfunction TJclIntfSortedMap.BinarySearch(const Key: IInterface): Integer;\r\nvar\r\n HiPos, LoPos, CompPos: Integer;\r\n Comp: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n LoPos := 0;\r\n HiPos := FSize - 1;\r\n CompPos := (HiPos + LoPos) div 2;\r\n while HiPos >= LoPos do\r\n begin\r\n Comp := KeysCompare(FEntries[CompPos].Key, Key);\r\n if Comp < 0 then\r\n LoPos := CompPos + 1\r\n else\r\n if Comp > 0 then\r\n HiPos := CompPos - 1\r\n else\r\n begin\r\n HiPos := CompPos;\r\n LoPos := CompPos + 1;\r\n end;\r\n CompPos := (HiPos + LoPos) div 2;\r\n end;\r\n Result := HiPos;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclIntfSortedMap.Clear;\r\nvar\r\n Index: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n for Index := 0 to FSize - 1 do\r\n begin\r\n FreeKey(FEntries[Index].Key);\r\n FreeValue(FEntries[Index].Value);\r\n end;\r\n FSize := 0;\r\n AutoPack;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfSortedMap.ContainsKey(const Key: IInterface): Boolean;\r\nvar\r\n Index: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Index := BinarySearch(Key);\r\n Result := (Index >= 0) and (KeysCompare(FEntries[Index].Key, Key) = 0);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfSortedMap.ContainsValue(Value: TObject): Boolean;\r\nvar\r\n Index: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n for Index := 0 to FSize - 1 do\r\n if ValuesCompare(FEntries[Index].Value, Value) = 0 then\r\n begin\r\n Result := True;\r\n Break;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfSortedMap.FirstKey: IInterface;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := nil;\r\n if FSize > 0 then\r\n Result := FEntries[0].Key\r\n else\r\n if not FReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfSortedMap.Extract(const Key: IInterface): TObject;\r\nvar\r\n Index: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Index := BinarySearch(Key);\r\n if (Index >= 0) and (KeysCompare(FEntries[Index].Key, Key) = 0) then\r\n begin\r\n Result := FEntries[Index].Value;\r\n FEntries[Index].Value := nil;\r\n FreeKey(FEntries[Index].Key);\r\n if Index < (FSize - 1) then\r\n MoveArray(FEntries, Index + 1, Index, FSize - Index - 1);\r\n Dec(FSize);\r\n AutoPack;\r\n end\r\n else\r\n Result := nil;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfSortedMap.GetValue(const Key: IInterface): TObject;\r\nvar\r\n Index: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Index := BinarySearch(Key);\r\n Result := nil;\r\n if (Index >= 0) and (KeysCompare(FEntries[Index].Key, Key) = 0) then\r\n Result := FEntries[Index].Value\r\n else if not FReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfSortedMap.HeadMap(const ToKey: IInterface): IJclIntfSortedMap;\r\nvar\r\n ToIndex: Integer;\r\n NewMap: TJclIntfSortedMap;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n NewMap := CreateEmptyContainer as TJclIntfSortedMap;\r\n ToIndex := BinarySearch(ToKey);\r\n if ToIndex >= 0 then\r\n begin\r\n NewMap.SetCapacity(ToIndex + 1);\r\n NewMap.FSize := ToIndex + 1;\r\n while ToIndex >= 0 do\r\n begin\r\n NewMap.FEntries[ToIndex] := FEntries[ToIndex];\r\n Dec(ToIndex);\r\n end;\r\n end;\r\n Result := NewMap;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfSortedMap.IsEmpty: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := FSize = 0;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfSortedMap.KeyOfValue(Value: TObject): IInterface;\r\nvar\r\n Index: Integer;\r\n Found: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Found := False;\r\n Result := nil;\r\n for Index := 0 to FSize - 1 do\r\n if ValuesCompare(FEntries[Index].Value, Value) = 0 then\r\n begin\r\n Result := FEntries[Index].Key;\r\n Found := True;\r\n Break;\r\n end;\r\n\r\n if (not Found) and (not FReturnDefaultElements) then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfSortedMap.KeySet: IJclIntfSet;\r\nvar\r\n Index: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := TJclIntfArraySet.Create(FSize);\r\n for Index := 0 to FSize - 1 do\r\n Result.Add(FEntries[Index].Key);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfSortedMap.LastKey: IInterface;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := nil;\r\n if FSize > 0 then\r\n Result := FEntries[FSize - 1].Key\r\n else\r\n if not FReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfSortedMap.MapEquals(const AMap: IJclIntfMap): Boolean;\r\nvar\r\n It: IJclIntfIterator;\r\n Index: Integer;\r\n AKey: IInterface;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if AMap = nil then\r\n Exit;\r\n if FSize <> AMap.Size then\r\n Exit;\r\n It := AMap.KeySet.First;\r\n Index := 0;\r\n while It.HasNext do\r\n begin\r\n if Index >= FSize then\r\n Exit;\r\n AKey := It.Next;\r\n if ValuesCompare(AMap.GetValue(AKey), FEntries[Index].Value) <> 0 then\r\n Exit;\r\n Inc(Index);\r\n end;\r\n Result := True;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclIntfSortedMap.FinalizeArrayBeforeMove(var List: TJclIntfSortedMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\nbegin\r\n Assert(Count > 0);\r\n if FromIndex < ToIndex then\r\n begin\r\n if Count > (ToIndex - FromIndex) then\r\n Finalize(List[FromIndex + Count], ToIndex - FromIndex)\r\n else\r\n Finalize(List[ToIndex], Count);\r\n end\r\n else\r\n if FromIndex > ToIndex then\r\n begin\r\n if Count > (FromIndex - ToIndex) then\r\n Count := FromIndex - ToIndex;\r\n Finalize(List[ToIndex], Count)\r\n end;\r\nend;\r\n\r\nprocedure TJclIntfSortedMap.InitializeArray(var List: TJclIntfSortedMapEntryArray; FromIndex, Count: SizeInt);\r\nbegin\r\n {$IFDEF FPC}\r\n while Count > 0 do\r\n begin\r\n Initialize(List[FromIndex]);\r\n Inc(FromIndex);\r\n Dec(Count);\r\n end;\r\n {$ELSE ~FPC}\r\n Initialize(List[FromIndex], Count);\r\n {$ENDIF ~FPC}\r\nend;\r\n\r\nprocedure TJclIntfSortedMap.InitializeArrayAfterMove(var List: TJclIntfSortedMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\nbegin\r\n { Keep reference counting working }\r\n if FromIndex < ToIndex then\r\n begin\r\n if (ToIndex - FromIndex) < Count then\r\n Count := ToIndex - FromIndex;\r\n InitializeArray(List, FromIndex, Count);\r\n end\r\n else\r\n if FromIndex > ToIndex then\r\n begin\r\n if (FromIndex - ToIndex) < Count then\r\n InitializeArray(List, ToIndex + Count, FromIndex - ToIndex)\r\n else\r\n InitializeArray(List, FromIndex, Count);\r\n end;\r\nend;\r\n\r\nprocedure TJclIntfSortedMap.MoveArray(var List: TJclIntfSortedMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\nbegin\r\n if Count > 0 then\r\n begin\r\n FinalizeArrayBeforeMove(List, FromIndex, ToIndex, Count);\r\n Move(List[FromIndex], List[ToIndex], Count * SizeOf(List[0]));\r\n InitializeArrayAfterMove(List, FromIndex, ToIndex, Count);\r\n end;\r\nend;\r\n\r\nprocedure TJclIntfSortedMap.PutAll(const AMap: IJclIntfMap);\r\nvar\r\n It: IJclIntfIterator;\r\n Key: IInterface;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if AMap = nil then\r\n Exit;\r\n It := AMap.KeySet.First;\r\n while It.HasNext do\r\n begin\r\n Key := It.Next;\r\n PutValue(Key, AMap.GetValue(Key));\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclIntfSortedMap.PutValue(const Key: IInterface; Value: TObject);\r\nvar\r\n Index: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FAllowDefaultElements or ((KeysCompare(Key, nil) <> 0) and (ValuesCompare(Value, nil) <> 0)) then\r\n begin\r\n Index := BinarySearch(Key);\r\n\r\n if (Index >= 0) and (KeysCompare(FEntries[Index].Key, Key) = 0) then\r\n begin\r\n FreeValue(FEntries[Index].Value);\r\n FEntries[Index].Value := Value;\r\n end\r\n else\r\n begin\r\n if FSize = FCapacity then\r\n AutoGrow;\r\n if FSize < FCapacity then\r\n begin\r\n Inc(Index);\r\n if (Index < FSize) and (KeysCompare(FEntries[Index].Key, Key) <> 0) then\r\n MoveArray(FEntries, Index, Index + 1, FSize - Index);\r\n FEntries[Index].Key := Key;\r\n FEntries[Index].Value := Value;\r\n Inc(FSize);\r\n end;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfSortedMap.Remove(const Key: IInterface): TObject;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := Extract(Key);\r\n Result := FreeValue(Result);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclIntfSortedMap.SetCapacity(Value: Integer);\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FSize <= Value then\r\n begin\r\n SetLength(FEntries, Value);\r\n inherited SetCapacity(Value);\r\n end\r\n else\r\n raise EJclOperationNotSupportedError.Create;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfSortedMap.Size: Integer;\r\nbegin\r\n Result := FSize;\r\nend;\r\n\r\nfunction TJclIntfSortedMap.SubMap(const FromKey, ToKey: IInterface): IJclIntfSortedMap;\r\nvar\r\n FromIndex, ToIndex: Integer;\r\n NewMap: TJclIntfSortedMap;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n NewMap := CreateEmptyContainer as TJclIntfSortedMap;\r\n FromIndex := BinarySearch(FromKey);\r\n if (FromIndex = -1) or (KeysCompare(FEntries[FromIndex].Key, FromKey) < 0) then\r\n Inc(FromIndex);\r\n ToIndex := BinarySearch(ToKey);\r\n if (FromIndex >= 0) and (FromIndex <= ToIndex) then\r\n begin\r\n NewMap.SetCapacity(ToIndex - FromIndex + 1);\r\n NewMap.FSize := ToIndex - FromIndex + 1;\r\n while ToIndex >= FromIndex do\r\n begin\r\n NewMap.FEntries[ToIndex - FromIndex] := FEntries[ToIndex];\r\n Dec(ToIndex);\r\n end;\r\n end;\r\n Result := NewMap;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfSortedMap.TailMap(const FromKey: IInterface): IJclIntfSortedMap;\r\nvar\r\n FromIndex, Index: Integer;\r\n NewMap: TJclIntfSortedMap;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n NewMap := CreateEmptyContainer as TJclIntfSortedMap;\r\n FromIndex := BinarySearch(FromKey);\r\n if (FromIndex = -1) or (KeysCompare(FEntries[FromIndex].Key, FromKey) < 0) then\r\n Inc(FromIndex);\r\n if (FromIndex >= 0) and (FromIndex < FSize) then\r\n begin\r\n NewMap.SetCapacity(FSize - FromIndex);\r\n NewMap.FSize := FSize - FromIndex;\r\n Index := FromIndex;\r\n while Index < FSize do\r\n begin\r\n NewMap.FEntries[Index - FromIndex] := FEntries[Index];\r\n Inc(Index);\r\n end;\r\n end;\r\n Result := NewMap;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfSortedMap.Values: IJclCollection;\r\nvar\r\n Index: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := TJclArrayList.Create(FSize, False);\r\n for Index := 0 to FSize - 1 do\r\n Result.Add(FEntries[Index].Value);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfSortedMap.CreateEmptyContainer: TJclAbstractContainerBase;\r\nbegin\r\n Result := TJclIntfSortedMap.Create(FSize, False);\r\n AssignPropertiesTo(Result);\r\nend;\r\n\r\nfunction TJclIntfSortedMap.FreeKey(var Key: IInterface): IInterface;\r\nbegin\r\n Result := Key;\r\n Key := nil;\r\nend;\r\n\r\nfunction TJclIntfSortedMap.FreeValue(var Value: TObject): TObject;\r\nbegin\r\n if FOwnsValues then\r\n begin\r\n Result := nil;\r\n FreeAndNil(Value);\r\n end\r\n else\r\n begin\r\n Result := Value;\r\n Value := nil;\r\n end;\r\nend;\r\n\r\nfunction TJclIntfSortedMap.GetOwnsValues: Boolean;\r\nbegin\r\n Result := FOwnsValues;\r\nend;\r\n\r\nfunction TJclIntfSortedMap.KeysCompare(const A, B: IInterface): Integer;\r\nbegin\r\n Result := ItemsCompare(A, B);\r\nend;\r\n\r\nfunction TJclIntfSortedMap.ValuesCompare(A, B: TObject): Integer;\r\nbegin\r\n Result := SimpleCompare(A, B);\r\nend;\r\n\r\n//=== { TJclAnsiStrSortedMap } ==============================================\r\n\r\nconstructor TJclAnsiStrSortedMap.Create(ACapacity: Integer; AOwnsValues: Boolean);\r\nbegin\r\n inherited Create();\r\n FOwnsValues := AOwnsValues;\r\n SetCapacity(ACapacity);\r\nend;\r\n\r\ndestructor TJclAnsiStrSortedMap.Destroy;\r\nbegin\r\n FReadOnly := False;\r\n Clear;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJclAnsiStrSortedMap.AssignDataTo(Dest: TJclAbstractContainerBase);\r\nvar\r\n MyDest: TJclAnsiStrSortedMap;\r\nbegin\r\n inherited AssignDataTo(Dest);\r\n if Dest is TJclAnsiStrSortedMap then\r\n begin\r\n MyDest := TJclAnsiStrSortedMap(Dest);\r\n MyDest.SetCapacity(FSize);\r\n MyDest.FEntries := FEntries;\r\n MyDest.FSize := FSize;\r\n end;\r\nend;\r\n\r\nfunction TJclAnsiStrSortedMap.BinarySearch(const Key: AnsiString): Integer;\r\nvar\r\n HiPos, LoPos, CompPos: Integer;\r\n Comp: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n LoPos := 0;\r\n HiPos := FSize - 1;\r\n CompPos := (HiPos + LoPos) div 2;\r\n while HiPos >= LoPos do\r\n begin\r\n Comp := KeysCompare(FEntries[CompPos].Key, Key);\r\n if Comp < 0 then\r\n LoPos := CompPos + 1\r\n else\r\n if Comp > 0 then\r\n HiPos := CompPos - 1\r\n else\r\n begin\r\n HiPos := CompPos;\r\n LoPos := CompPos + 1;\r\n end;\r\n CompPos := (HiPos + LoPos) div 2;\r\n end;\r\n Result := HiPos;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclAnsiStrSortedMap.Clear;\r\nvar\r\n Index: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n for Index := 0 to FSize - 1 do\r\n begin\r\n FreeKey(FEntries[Index].Key);\r\n FreeValue(FEntries[Index].Value);\r\n end;\r\n FSize := 0;\r\n AutoPack;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclAnsiStrSortedMap.ContainsKey(const Key: AnsiString): Boolean;\r\nvar\r\n Index: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Index := BinarySearch(Key);\r\n Result := (Index >= 0) and (KeysCompare(FEntries[Index].Key, Key) = 0);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclAnsiStrSortedMap.ContainsValue(Value: TObject): Boolean;\r\nvar\r\n Index: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n for Index := 0 to FSize - 1 do\r\n if ValuesCompare(FEntries[Index].Value, Value) = 0 then\r\n begin\r\n Result := True;\r\n Break;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclAnsiStrSortedMap.FirstKey: AnsiString;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := '';\r\n if FSize > 0 then\r\n Result := FEntries[0].Key\r\n else\r\n if not FReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclAnsiStrSortedMap.Extract(const Key: AnsiString): TObject;\r\nvar\r\n Index: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Index := BinarySearch(Key);\r\n if (Index >= 0) and (KeysCompare(FEntries[Index].Key, Key) = 0) then\r\n begin\r\n Result := FEntries[Index].Value;\r\n FEntries[Index].Value := nil;\r\n FreeKey(FEntries[Index].Key);\r\n if Index < (FSize - 1) then\r\n MoveArray(FEntries, Index + 1, Index, FSize - Index - 1);\r\n Dec(FSize);\r\n AutoPack;\r\n end\r\n else\r\n Result := nil;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclAnsiStrSortedMap.GetValue(const Key: AnsiString): TObject;\r\nvar\r\n Index: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Index := BinarySearch(Key);\r\n Result := nil;\r\n if (Index >= 0) and (KeysCompare(FEntries[Index].Key, Key) = 0) then\r\n Result := FEntries[Index].Value\r\n else if not FReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclAnsiStrSortedMap.HeadMap(const ToKey: AnsiString): IJclAnsiStrSortedMap;\r\nvar\r\n ToIndex: Integer;\r\n NewMap: TJclAnsiStrSortedMap;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n NewMap := CreateEmptyContainer as TJclAnsiStrSortedMap;\r\n ToIndex := BinarySearch(ToKey);\r\n if ToIndex >= 0 then\r\n begin\r\n NewMap.SetCapacity(ToIndex + 1);\r\n NewMap.FSize := ToIndex + 1;\r\n while ToIndex >= 0 do\r\n begin\r\n NewMap.FEntries[ToIndex] := FEntries[ToIndex];\r\n Dec(ToIndex);\r\n end;\r\n end;\r\n Result := NewMap;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclAnsiStrSortedMap.IsEmpty: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := FSize = 0;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclAnsiStrSortedMap.KeyOfValue(Value: TObject): AnsiString;\r\nvar\r\n Index: Integer;\r\n Found: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Found := False;\r\n Result := '';\r\n for Index := 0 to FSize - 1 do\r\n if ValuesCompare(FEntries[Index].Value, Value) = 0 then\r\n begin\r\n Result := FEntries[Index].Key;\r\n Found := True;\r\n Break;\r\n end;\r\n\r\n if (not Found) and (not FReturnDefaultElements) then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclAnsiStrSortedMap.KeySet: IJclAnsiStrSet;\r\nvar\r\n Index: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := TJclAnsiStrArraySet.Create(FSize);\r\n for Index := 0 to FSize - 1 do\r\n Result.Add(FEntries[Index].Key);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclAnsiStrSortedMap.LastKey: AnsiString;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := '';\r\n if FSize > 0 then\r\n Result := FEntries[FSize - 1].Key\r\n else\r\n if not FReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclAnsiStrSortedMap.MapEquals(const AMap: IJclAnsiStrMap): Boolean;\r\nvar\r\n It: IJclAnsiStrIterator;\r\n Index: Integer;\r\n AKey: AnsiString;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if AMap = nil then\r\n Exit;\r\n if FSize <> AMap.Size then\r\n Exit;\r\n It := AMap.KeySet.First;\r\n Index := 0;\r\n while It.HasNext do\r\n begin\r\n if Index >= FSize then\r\n Exit;\r\n AKey := It.Next;\r\n if ValuesCompare(AMap.GetValue(AKey), FEntries[Index].Value) <> 0 then\r\n Exit;\r\n Inc(Index);\r\n end;\r\n Result := True;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclAnsiStrSortedMap.FinalizeArrayBeforeMove(var List: TJclAnsiStrSortedMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\nbegin\r\n Assert(Count > 0);\r\n if FromIndex < ToIndex then\r\n begin\r\n if Count > (ToIndex - FromIndex) then\r\n Finalize(List[FromIndex + Count], ToIndex - FromIndex)\r\n else\r\n Finalize(List[ToIndex], Count);\r\n end\r\n else\r\n if FromIndex > ToIndex then\r\n begin\r\n if Count > (FromIndex - ToIndex) then\r\n Count := FromIndex - ToIndex;\r\n Finalize(List[ToIndex], Count)\r\n end;\r\nend;\r\n\r\nprocedure TJclAnsiStrSortedMap.InitializeArray(var List: TJclAnsiStrSortedMapEntryArray; FromIndex, Count: SizeInt);\r\nbegin\r\n {$IFDEF FPC}\r\n while Count > 0 do\r\n begin\r\n Initialize(List[FromIndex]);\r\n Inc(FromIndex);\r\n Dec(Count);\r\n end;\r\n {$ELSE ~FPC}\r\n Initialize(List[FromIndex], Count);\r\n {$ENDIF ~FPC}\r\nend;\r\n\r\nprocedure TJclAnsiStrSortedMap.InitializeArrayAfterMove(var List: TJclAnsiStrSortedMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\nbegin\r\n { Keep reference counting working }\r\n if FromIndex < ToIndex then\r\n begin\r\n if (ToIndex - FromIndex) < Count then\r\n Count := ToIndex - FromIndex;\r\n InitializeArray(List, FromIndex, Count);\r\n end\r\n else\r\n if FromIndex > ToIndex then\r\n begin\r\n if (FromIndex - ToIndex) < Count then\r\n InitializeArray(List, ToIndex + Count, FromIndex - ToIndex)\r\n else\r\n InitializeArray(List, FromIndex, Count);\r\n end;\r\nend;\r\n\r\nprocedure TJclAnsiStrSortedMap.MoveArray(var List: TJclAnsiStrSortedMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\nbegin\r\n if Count > 0 then\r\n begin\r\n FinalizeArrayBeforeMove(List, FromIndex, ToIndex, Count);\r\n Move(List[FromIndex], List[ToIndex], Count * SizeOf(List[0]));\r\n InitializeArrayAfterMove(List, FromIndex, ToIndex, Count);\r\n end;\r\nend;\r\n\r\nprocedure TJclAnsiStrSortedMap.PutAll(const AMap: IJclAnsiStrMap);\r\nvar\r\n It: IJclAnsiStrIterator;\r\n Key: AnsiString;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if AMap = nil then\r\n Exit;\r\n It := AMap.KeySet.First;\r\n while It.HasNext do\r\n begin\r\n Key := It.Next;\r\n PutValue(Key, AMap.GetValue(Key));\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclAnsiStrSortedMap.PutValue(const Key: AnsiString; Value: TObject);\r\nvar\r\n Index: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FAllowDefaultElements or ((KeysCompare(Key, '') <> 0) and (ValuesCompare(Value, nil) <> 0)) then\r\n begin\r\n Index := BinarySearch(Key);\r\n\r\n if (Index >= 0) and (KeysCompare(FEntries[Index].Key, Key) = 0) then\r\n begin\r\n FreeValue(FEntries[Index].Value);\r\n FEntries[Index].Value := Value;\r\n end\r\n else\r\n begin\r\n if FSize = FCapacity then\r\n AutoGrow;\r\n if FSize < FCapacity then\r\n begin\r\n Inc(Index);\r\n if (Index < FSize) and (KeysCompare(FEntries[Index].Key, Key) <> 0) then\r\n MoveArray(FEntries, Index, Index + 1, FSize - Index);\r\n FEntries[Index].Key := Key;\r\n FEntries[Index].Value := Value;\r\n Inc(FSize);\r\n end;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclAnsiStrSortedMap.Remove(const Key: AnsiString): TObject;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := Extract(Key);\r\n Result := FreeValue(Result);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclAnsiStrSortedMap.SetCapacity(Value: Integer);\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FSize <= Value then\r\n begin\r\n SetLength(FEntries, Value);\r\n inherited SetCapacity(Value);\r\n end\r\n else\r\n raise EJclOperationNotSupportedError.Create;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclAnsiStrSortedMap.Size: Integer;\r\nbegin\r\n Result := FSize;\r\nend;\r\n\r\nfunction TJclAnsiStrSortedMap.SubMap(const FromKey, ToKey: AnsiString): IJclAnsiStrSortedMap;\r\nvar\r\n FromIndex, ToIndex: Integer;\r\n NewMap: TJclAnsiStrSortedMap;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n NewMap := CreateEmptyContainer as TJclAnsiStrSortedMap;\r\n FromIndex := BinarySearch(FromKey);\r\n if (FromIndex = -1) or (KeysCompare(FEntries[FromIndex].Key, FromKey) < 0) then\r\n Inc(FromIndex);\r\n ToIndex := BinarySearch(ToKey);\r\n if (FromIndex >= 0) and (FromIndex <= ToIndex) then\r\n begin\r\n NewMap.SetCapacity(ToIndex - FromIndex + 1);\r\n NewMap.FSize := ToIndex - FromIndex + 1;\r\n while ToIndex >= FromIndex do\r\n begin\r\n NewMap.FEntries[ToIndex - FromIndex] := FEntries[ToIndex];\r\n Dec(ToIndex);\r\n end;\r\n end;\r\n Result := NewMap;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclAnsiStrSortedMap.TailMap(const FromKey: AnsiString): IJclAnsiStrSortedMap;\r\nvar\r\n FromIndex, Index: Integer;\r\n NewMap: TJclAnsiStrSortedMap;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n NewMap := CreateEmptyContainer as TJclAnsiStrSortedMap;\r\n FromIndex := BinarySearch(FromKey);\r\n if (FromIndex = -1) or (KeysCompare(FEntries[FromIndex].Key, FromKey) < 0) then\r\n Inc(FromIndex);\r\n if (FromIndex >= 0) and (FromIndex < FSize) then\r\n begin\r\n NewMap.SetCapacity(FSize - FromIndex);\r\n NewMap.FSize := FSize - FromIndex;\r\n Index := FromIndex;\r\n while Index < FSize do\r\n begin\r\n NewMap.FEntries[Index - FromIndex] := FEntries[Index];\r\n Inc(Index);\r\n end;\r\n end;\r\n Result := NewMap;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclAnsiStrSortedMap.Values: IJclCollection;\r\nvar\r\n Index: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := TJclArrayList.Create(FSize, False);\r\n for Index := 0 to FSize - 1 do\r\n Result.Add(FEntries[Index].Value);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclAnsiStrSortedMap.CreateEmptyContainer: TJclAbstractContainerBase;\r\nbegin\r\n Result := TJclAnsiStrSortedMap.Create(FSize, False);\r\n AssignPropertiesTo(Result);\r\nend;\r\n\r\nfunction TJclAnsiStrSortedMap.FreeKey(var Key: AnsiString): AnsiString;\r\nbegin\r\n Result := Key;\r\n Key := '';\r\nend;\r\n\r\nfunction TJclAnsiStrSortedMap.FreeValue(var Value: TObject): TObject;\r\nbegin\r\n if FOwnsValues then\r\n begin\r\n Result := nil;\r\n FreeAndNil(Value);\r\n end\r\n else\r\n begin\r\n Result := Value;\r\n Value := nil;\r\n end;\r\nend;\r\n\r\nfunction TJclAnsiStrSortedMap.GetOwnsValues: Boolean;\r\nbegin\r\n Result := FOwnsValues;\r\nend;\r\n\r\nfunction TJclAnsiStrSortedMap.KeysCompare(const A, B: AnsiString): Integer;\r\nbegin\r\n Result := ItemsCompare(A, B);\r\nend;\r\n\r\nfunction TJclAnsiStrSortedMap.ValuesCompare(A, B: TObject): Integer;\r\nbegin\r\n Result := SimpleCompare(A, B);\r\nend;\r\n\r\n//=== { TJclWideStrSortedMap } ==============================================\r\n\r\nconstructor TJclWideStrSortedMap.Create(ACapacity: Integer; AOwnsValues: Boolean);\r\nbegin\r\n inherited Create();\r\n FOwnsValues := AOwnsValues;\r\n SetCapacity(ACapacity);\r\nend;\r\n\r\ndestructor TJclWideStrSortedMap.Destroy;\r\nbegin\r\n FReadOnly := False;\r\n Clear;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJclWideStrSortedMap.AssignDataTo(Dest: TJclAbstractContainerBase);\r\nvar\r\n MyDest: TJclWideStrSortedMap;\r\nbegin\r\n inherited AssignDataTo(Dest);\r\n if Dest is TJclWideStrSortedMap then\r\n begin\r\n MyDest := TJclWideStrSortedMap(Dest);\r\n MyDest.SetCapacity(FSize);\r\n MyDest.FEntries := FEntries;\r\n MyDest.FSize := FSize;\r\n end;\r\nend;\r\n\r\nfunction TJclWideStrSortedMap.BinarySearch(const Key: WideString): Integer;\r\nvar\r\n HiPos, LoPos, CompPos: Integer;\r\n Comp: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n LoPos := 0;\r\n HiPos := FSize - 1;\r\n CompPos := (HiPos + LoPos) div 2;\r\n while HiPos >= LoPos do\r\n begin\r\n Comp := KeysCompare(FEntries[CompPos].Key, Key);\r\n if Comp < 0 then\r\n LoPos := CompPos + 1\r\n else\r\n if Comp > 0 then\r\n HiPos := CompPos - 1\r\n else\r\n begin\r\n HiPos := CompPos;\r\n LoPos := CompPos + 1;\r\n end;\r\n CompPos := (HiPos + LoPos) div 2;\r\n end;\r\n Result := HiPos;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclWideStrSortedMap.Clear;\r\nvar\r\n Index: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n for Index := 0 to FSize - 1 do\r\n begin\r\n FreeKey(FEntries[Index].Key);\r\n FreeValue(FEntries[Index].Value);\r\n end;\r\n FSize := 0;\r\n AutoPack;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclWideStrSortedMap.ContainsKey(const Key: WideString): Boolean;\r\nvar\r\n Index: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Index := BinarySearch(Key);\r\n Result := (Index >= 0) and (KeysCompare(FEntries[Index].Key, Key) = 0);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclWideStrSortedMap.ContainsValue(Value: TObject): Boolean;\r\nvar\r\n Index: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n for Index := 0 to FSize - 1 do\r\n if ValuesCompare(FEntries[Index].Value, Value) = 0 then\r\n begin\r\n Result := True;\r\n Break;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclWideStrSortedMap.FirstKey: WideString;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := '';\r\n if FSize > 0 then\r\n Result := FEntries[0].Key\r\n else\r\n if not FReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclWideStrSortedMap.Extract(const Key: WideString): TObject;\r\nvar\r\n Index: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Index := BinarySearch(Key);\r\n if (Index >= 0) and (KeysCompare(FEntries[Index].Key, Key) = 0) then\r\n begin\r\n Result := FEntries[Index].Value;\r\n FEntries[Index].Value := nil;\r\n FreeKey(FEntries[Index].Key);\r\n if Index < (FSize - 1) then\r\n MoveArray(FEntries, Index + 1, Index, FSize - Index - 1);\r\n Dec(FSize);\r\n AutoPack;\r\n end\r\n else\r\n Result := nil;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclWideStrSortedMap.GetValue(const Key: WideString): TObject;\r\nvar\r\n Index: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Index := BinarySearch(Key);\r\n Result := nil;\r\n if (Index >= 0) and (KeysCompare(FEntries[Index].Key, Key) = 0) then\r\n Result := FEntries[Index].Value\r\n else if not FReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclWideStrSortedMap.HeadMap(const ToKey: WideString): IJclWideStrSortedMap;\r\nvar\r\n ToIndex: Integer;\r\n NewMap: TJclWideStrSortedMap;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n NewMap := CreateEmptyContainer as TJclWideStrSortedMap;\r\n ToIndex := BinarySearch(ToKey);\r\n if ToIndex >= 0 then\r\n begin\r\n NewMap.SetCapacity(ToIndex + 1);\r\n NewMap.FSize := ToIndex + 1;\r\n while ToIndex >= 0 do\r\n begin\r\n NewMap.FEntries[ToIndex] := FEntries[ToIndex];\r\n Dec(ToIndex);\r\n end;\r\n end;\r\n Result := NewMap;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclWideStrSortedMap.IsEmpty: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := FSize = 0;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclWideStrSortedMap.KeyOfValue(Value: TObject): WideString;\r\nvar\r\n Index: Integer;\r\n Found: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Found := False;\r\n Result := '';\r\n for Index := 0 to FSize - 1 do\r\n if ValuesCompare(FEntries[Index].Value, Value) = 0 then\r\n begin\r\n Result := FEntries[Index].Key;\r\n Found := True;\r\n Break;\r\n end;\r\n\r\n if (not Found) and (not FReturnDefaultElements) then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclWideStrSortedMap.KeySet: IJclWideStrSet;\r\nvar\r\n Index: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := TJclWideStrArraySet.Create(FSize);\r\n for Index := 0 to FSize - 1 do\r\n Result.Add(FEntries[Index].Key);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclWideStrSortedMap.LastKey: WideString;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := '';\r\n if FSize > 0 then\r\n Result := FEntries[FSize - 1].Key\r\n else\r\n if not FReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclWideStrSortedMap.MapEquals(const AMap: IJclWideStrMap): Boolean;\r\nvar\r\n It: IJclWideStrIterator;\r\n Index: Integer;\r\n AKey: WideString;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if AMap = nil then\r\n Exit;\r\n if FSize <> AMap.Size then\r\n Exit;\r\n It := AMap.KeySet.First;\r\n Index := 0;\r\n while It.HasNext do\r\n begin\r\n if Index >= FSize then\r\n Exit;\r\n AKey := It.Next;\r\n if ValuesCompare(AMap.GetValue(AKey), FEntries[Index].Value) <> 0 then\r\n Exit;\r\n Inc(Index);\r\n end;\r\n Result := True;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclWideStrSortedMap.FinalizeArrayBeforeMove(var List: TJclWideStrSortedMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\nbegin\r\n Assert(Count > 0);\r\n if FromIndex < ToIndex then\r\n begin\r\n if Count > (ToIndex - FromIndex) then\r\n Finalize(List[FromIndex + Count], ToIndex - FromIndex)\r\n else\r\n Finalize(List[ToIndex], Count);\r\n end\r\n else\r\n if FromIndex > ToIndex then\r\n begin\r\n if Count > (FromIndex - ToIndex) then\r\n Count := FromIndex - ToIndex;\r\n Finalize(List[ToIndex], Count)\r\n end;\r\nend;\r\n\r\nprocedure TJclWideStrSortedMap.InitializeArray(var List: TJclWideStrSortedMapEntryArray; FromIndex, Count: SizeInt);\r\nbegin\r\n {$IFDEF FPC}\r\n while Count > 0 do\r\n begin\r\n Initialize(List[FromIndex]);\r\n Inc(FromIndex);\r\n Dec(Count);\r\n end;\r\n {$ELSE ~FPC}\r\n Initialize(List[FromIndex], Count);\r\n {$ENDIF ~FPC}\r\nend;\r\n\r\nprocedure TJclWideStrSortedMap.InitializeArrayAfterMove(var List: TJclWideStrSortedMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\nbegin\r\n { Keep reference counting working }\r\n if FromIndex < ToIndex then\r\n begin\r\n if (ToIndex - FromIndex) < Count then\r\n Count := ToIndex - FromIndex;\r\n InitializeArray(List, FromIndex, Count);\r\n end\r\n else\r\n if FromIndex > ToIndex then\r\n begin\r\n if (FromIndex - ToIndex) < Count then\r\n InitializeArray(List, ToIndex + Count, FromIndex - ToIndex)\r\n else\r\n InitializeArray(List, FromIndex, Count);\r\n end;\r\nend;\r\n\r\nprocedure TJclWideStrSortedMap.MoveArray(var List: TJclWideStrSortedMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\nbegin\r\n if Count > 0 then\r\n begin\r\n FinalizeArrayBeforeMove(List, FromIndex, ToIndex, Count);\r\n Move(List[FromIndex], List[ToIndex], Count * SizeOf(List[0]));\r\n InitializeArrayAfterMove(List, FromIndex, ToIndex, Count);\r\n end;\r\nend;\r\n\r\nprocedure TJclWideStrSortedMap.PutAll(const AMap: IJclWideStrMap);\r\nvar\r\n It: IJclWideStrIterator;\r\n Key: WideString;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if AMap = nil then\r\n Exit;\r\n It := AMap.KeySet.First;\r\n while It.HasNext do\r\n begin\r\n Key := It.Next;\r\n PutValue(Key, AMap.GetValue(Key));\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclWideStrSortedMap.PutValue(const Key: WideString; Value: TObject);\r\nvar\r\n Index: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FAllowDefaultElements or ((KeysCompare(Key, '') <> 0) and (ValuesCompare(Value, nil) <> 0)) then\r\n begin\r\n Index := BinarySearch(Key);\r\n\r\n if (Index >= 0) and (KeysCompare(FEntries[Index].Key, Key) = 0) then\r\n begin\r\n FreeValue(FEntries[Index].Value);\r\n FEntries[Index].Value := Value;\r\n end\r\n else\r\n begin\r\n if FSize = FCapacity then\r\n AutoGrow;\r\n if FSize < FCapacity then\r\n begin\r\n Inc(Index);\r\n if (Index < FSize) and (KeysCompare(FEntries[Index].Key, Key) <> 0) then\r\n MoveArray(FEntries, Index, Index + 1, FSize - Index);\r\n FEntries[Index].Key := Key;\r\n FEntries[Index].Value := Value;\r\n Inc(FSize);\r\n end;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclWideStrSortedMap.Remove(const Key: WideString): TObject;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := Extract(Key);\r\n Result := FreeValue(Result);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclWideStrSortedMap.SetCapacity(Value: Integer);\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FSize <= Value then\r\n begin\r\n SetLength(FEntries, Value);\r\n inherited SetCapacity(Value);\r\n end\r\n else\r\n raise EJclOperationNotSupportedError.Create;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclWideStrSortedMap.Size: Integer;\r\nbegin\r\n Result := FSize;\r\nend;\r\n\r\nfunction TJclWideStrSortedMap.SubMap(const FromKey, ToKey: WideString): IJclWideStrSortedMap;\r\nvar\r\n FromIndex, ToIndex: Integer;\r\n NewMap: TJclWideStrSortedMap;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n NewMap := CreateEmptyContainer as TJclWideStrSortedMap;\r\n FromIndex := BinarySearch(FromKey);\r\n if (FromIndex = -1) or (KeysCompare(FEntries[FromIndex].Key, FromKey) < 0) then\r\n Inc(FromIndex);\r\n ToIndex := BinarySearch(ToKey);\r\n if (FromIndex >= 0) and (FromIndex <= ToIndex) then\r\n begin\r\n NewMap.SetCapacity(ToIndex - FromIndex + 1);\r\n NewMap.FSize := ToIndex - FromIndex + 1;\r\n while ToIndex >= FromIndex do\r\n begin\r\n NewMap.FEntries[ToIndex - FromIndex] := FEntries[ToIndex];\r\n Dec(ToIndex);\r\n end;\r\n end;\r\n Result := NewMap;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclWideStrSortedMap.TailMap(const FromKey: WideString): IJclWideStrSortedMap;\r\nvar\r\n FromIndex, Index: Integer;\r\n NewMap: TJclWideStrSortedMap;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n NewMap := CreateEmptyContainer as TJclWideStrSortedMap;\r\n FromIndex := BinarySearch(FromKey);\r\n if (FromIndex = -1) or (KeysCompare(FEntries[FromIndex].Key, FromKey) < 0) then\r\n Inc(FromIndex);\r\n if (FromIndex >= 0) and (FromIndex < FSize) then\r\n begin\r\n NewMap.SetCapacity(FSize - FromIndex);\r\n NewMap.FSize := FSize - FromIndex;\r\n Index := FromIndex;\r\n while Index < FSize do\r\n begin\r\n NewMap.FEntries[Index - FromIndex] := FEntries[Index];\r\n Inc(Index);\r\n end;\r\n end;\r\n Result := NewMap;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclWideStrSortedMap.Values: IJclCollection;\r\nvar\r\n Index: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := TJclArrayList.Create(FSize, False);\r\n for Index := 0 to FSize - 1 do\r\n Result.Add(FEntries[Index].Value);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclWideStrSortedMap.CreateEmptyContainer: TJclAbstractContainerBase;\r\nbegin\r\n Result := TJclWideStrSortedMap.Create(FSize, False);\r\n AssignPropertiesTo(Result);\r\nend;\r\n\r\nfunction TJclWideStrSortedMap.FreeKey(var Key: WideString): WideString;\r\nbegin\r\n Result := Key;\r\n Key := '';\r\nend;\r\n\r\nfunction TJclWideStrSortedMap.FreeValue(var Value: TObject): TObject;\r\nbegin\r\n if FOwnsValues then\r\n begin\r\n Result := nil;\r\n FreeAndNil(Value);\r\n end\r\n else\r\n begin\r\n Result := Value;\r\n Value := nil;\r\n end;\r\nend;\r\n\r\nfunction TJclWideStrSortedMap.GetOwnsValues: Boolean;\r\nbegin\r\n Result := FOwnsValues;\r\nend;\r\n\r\nfunction TJclWideStrSortedMap.KeysCompare(const A, B: WideString): Integer;\r\nbegin\r\n Result := ItemsCompare(A, B);\r\nend;\r\n\r\nfunction TJclWideStrSortedMap.ValuesCompare(A, B: TObject): Integer;\r\nbegin\r\n Result := SimpleCompare(A, B);\r\nend;\r\n\r\n{$IFDEF SUPPORTS_UNICODE_STRING}\r\n//=== { TJclUnicodeStrSortedMap } ==============================================\r\n\r\nconstructor TJclUnicodeStrSortedMap.Create(ACapacity: Integer; AOwnsValues: Boolean);\r\nbegin\r\n inherited Create();\r\n FOwnsValues := AOwnsValues;\r\n SetCapacity(ACapacity);\r\nend;\r\n\r\ndestructor TJclUnicodeStrSortedMap.Destroy;\r\nbegin\r\n FReadOnly := False;\r\n Clear;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJclUnicodeStrSortedMap.AssignDataTo(Dest: TJclAbstractContainerBase);\r\nvar\r\n MyDest: TJclUnicodeStrSortedMap;\r\nbegin\r\n inherited AssignDataTo(Dest);\r\n if Dest is TJclUnicodeStrSortedMap then\r\n begin\r\n MyDest := TJclUnicodeStrSortedMap(Dest);\r\n MyDest.SetCapacity(FSize);\r\n MyDest.FEntries := FEntries;\r\n MyDest.FSize := FSize;\r\n end;\r\nend;\r\n\r\nfunction TJclUnicodeStrSortedMap.BinarySearch(const Key: UnicodeString): Integer;\r\nvar\r\n HiPos, LoPos, CompPos: Integer;\r\n Comp: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n LoPos := 0;\r\n HiPos := FSize - 1;\r\n CompPos := (HiPos + LoPos) div 2;\r\n while HiPos >= LoPos do\r\n begin\r\n Comp := KeysCompare(FEntries[CompPos].Key, Key);\r\n if Comp < 0 then\r\n LoPos := CompPos + 1\r\n else\r\n if Comp > 0 then\r\n HiPos := CompPos - 1\r\n else\r\n begin\r\n HiPos := CompPos;\r\n LoPos := CompPos + 1;\r\n end;\r\n CompPos := (HiPos + LoPos) div 2;\r\n end;\r\n Result := HiPos;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclUnicodeStrSortedMap.Clear;\r\nvar\r\n Index: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n for Index := 0 to FSize - 1 do\r\n begin\r\n FreeKey(FEntries[Index].Key);\r\n FreeValue(FEntries[Index].Value);\r\n end;\r\n FSize := 0;\r\n AutoPack;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclUnicodeStrSortedMap.ContainsKey(const Key: UnicodeString): Boolean;\r\nvar\r\n Index: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Index := BinarySearch(Key);\r\n Result := (Index >= 0) and (KeysCompare(FEntries[Index].Key, Key) = 0);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclUnicodeStrSortedMap.ContainsValue(Value: TObject): Boolean;\r\nvar\r\n Index: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n for Index := 0 to FSize - 1 do\r\n if ValuesCompare(FEntries[Index].Value, Value) = 0 then\r\n begin\r\n Result := True;\r\n Break;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclUnicodeStrSortedMap.FirstKey: UnicodeString;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := '';\r\n if FSize > 0 then\r\n Result := FEntries[0].Key\r\n else\r\n if not FReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclUnicodeStrSortedMap.Extract(const Key: UnicodeString): TObject;\r\nvar\r\n Index: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Index := BinarySearch(Key);\r\n if (Index >= 0) and (KeysCompare(FEntries[Index].Key, Key) = 0) then\r\n begin\r\n Result := FEntries[Index].Value;\r\n FEntries[Index].Value := nil;\r\n FreeKey(FEntries[Index].Key);\r\n if Index < (FSize - 1) then\r\n MoveArray(FEntries, Index + 1, Index, FSize - Index - 1);\r\n Dec(FSize);\r\n AutoPack;\r\n end\r\n else\r\n Result := nil;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclUnicodeStrSortedMap.GetValue(const Key: UnicodeString): TObject;\r\nvar\r\n Index: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Index := BinarySearch(Key);\r\n Result := nil;\r\n if (Index >= 0) and (KeysCompare(FEntries[Index].Key, Key) = 0) then\r\n Result := FEntries[Index].Value\r\n else if not FReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclUnicodeStrSortedMap.HeadMap(const ToKey: UnicodeString): IJclUnicodeStrSortedMap;\r\nvar\r\n ToIndex: Integer;\r\n NewMap: TJclUnicodeStrSortedMap;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n NewMap := CreateEmptyContainer as TJclUnicodeStrSortedMap;\r\n ToIndex := BinarySearch(ToKey);\r\n if ToIndex >= 0 then\r\n begin\r\n NewMap.SetCapacity(ToIndex + 1);\r\n NewMap.FSize := ToIndex + 1;\r\n while ToIndex >= 0 do\r\n begin\r\n NewMap.FEntries[ToIndex] := FEntries[ToIndex];\r\n Dec(ToIndex);\r\n end;\r\n end;\r\n Result := NewMap;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclUnicodeStrSortedMap.IsEmpty: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := FSize = 0;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclUnicodeStrSortedMap.KeyOfValue(Value: TObject): UnicodeString;\r\nvar\r\n Index: Integer;\r\n Found: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Found := False;\r\n Result := '';\r\n for Index := 0 to FSize - 1 do\r\n if ValuesCompare(FEntries[Index].Value, Value) = 0 then\r\n begin\r\n Result := FEntries[Index].Key;\r\n Found := True;\r\n Break;\r\n end;\r\n\r\n if (not Found) and (not FReturnDefaultElements) then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclUnicodeStrSortedMap.KeySet: IJclUnicodeStrSet;\r\nvar\r\n Index: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := TJclUnicodeStrArraySet.Create(FSize);\r\n for Index := 0 to FSize - 1 do\r\n Result.Add(FEntries[Index].Key);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclUnicodeStrSortedMap.LastKey: UnicodeString;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := '';\r\n if FSize > 0 then\r\n Result := FEntries[FSize - 1].Key\r\n else\r\n if not FReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclUnicodeStrSortedMap.MapEquals(const AMap: IJclUnicodeStrMap): Boolean;\r\nvar\r\n It: IJclUnicodeStrIterator;\r\n Index: Integer;\r\n AKey: UnicodeString;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if AMap = nil then\r\n Exit;\r\n if FSize <> AMap.Size then\r\n Exit;\r\n It := AMap.KeySet.First;\r\n Index := 0;\r\n while It.HasNext do\r\n begin\r\n if Index >= FSize then\r\n Exit;\r\n AKey := It.Next;\r\n if ValuesCompare(AMap.GetValue(AKey), FEntries[Index].Value) <> 0 then\r\n Exit;\r\n Inc(Index);\r\n end;\r\n Result := True;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclUnicodeStrSortedMap.FinalizeArrayBeforeMove(var List: TJclUnicodeStrSortedMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\nbegin\r\n Assert(Count > 0);\r\n if FromIndex < ToIndex then\r\n begin\r\n if Count > (ToIndex - FromIndex) then\r\n Finalize(List[FromIndex + Count], ToIndex - FromIndex)\r\n else\r\n Finalize(List[ToIndex], Count);\r\n end\r\n else\r\n if FromIndex > ToIndex then\r\n begin\r\n if Count > (FromIndex - ToIndex) then\r\n Count := FromIndex - ToIndex;\r\n Finalize(List[ToIndex], Count)\r\n end;\r\nend;\r\n\r\nprocedure TJclUnicodeStrSortedMap.InitializeArray(var List: TJclUnicodeStrSortedMapEntryArray; FromIndex, Count: SizeInt);\r\nbegin\r\n {$IFDEF FPC}\r\n while Count > 0 do\r\n begin\r\n Initialize(List[FromIndex]);\r\n Inc(FromIndex);\r\n Dec(Count);\r\n end;\r\n {$ELSE ~FPC}\r\n Initialize(List[FromIndex], Count);\r\n {$ENDIF ~FPC}\r\nend;\r\n\r\nprocedure TJclUnicodeStrSortedMap.InitializeArrayAfterMove(var List: TJclUnicodeStrSortedMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\nbegin\r\n { Keep reference counting working }\r\n if FromIndex < ToIndex then\r\n begin\r\n if (ToIndex - FromIndex) < Count then\r\n Count := ToIndex - FromIndex;\r\n InitializeArray(List, FromIndex, Count);\r\n end\r\n else\r\n if FromIndex > ToIndex then\r\n begin\r\n if (FromIndex - ToIndex) < Count then\r\n InitializeArray(List, ToIndex + Count, FromIndex - ToIndex)\r\n else\r\n InitializeArray(List, FromIndex, Count);\r\n end;\r\nend;\r\n\r\nprocedure TJclUnicodeStrSortedMap.MoveArray(var List: TJclUnicodeStrSortedMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\nbegin\r\n if Count > 0 then\r\n begin\r\n FinalizeArrayBeforeMove(List, FromIndex, ToIndex, Count);\r\n Move(List[FromIndex], List[ToIndex], Count * SizeOf(List[0]));\r\n InitializeArrayAfterMove(List, FromIndex, ToIndex, Count);\r\n end;\r\nend;\r\n\r\nprocedure TJclUnicodeStrSortedMap.PutAll(const AMap: IJclUnicodeStrMap);\r\nvar\r\n It: IJclUnicodeStrIterator;\r\n Key: UnicodeString;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if AMap = nil then\r\n Exit;\r\n It := AMap.KeySet.First;\r\n while It.HasNext do\r\n begin\r\n Key := It.Next;\r\n PutValue(Key, AMap.GetValue(Key));\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclUnicodeStrSortedMap.PutValue(const Key: UnicodeString; Value: TObject);\r\nvar\r\n Index: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FAllowDefaultElements or ((KeysCompare(Key, '') <> 0) and (ValuesCompare(Value, nil) <> 0)) then\r\n begin\r\n Index := BinarySearch(Key);\r\n\r\n if (Index >= 0) and (KeysCompare(FEntries[Index].Key, Key) = 0) then\r\n begin\r\n FreeValue(FEntries[Index].Value);\r\n FEntries[Index].Value := Value;\r\n end\r\n else\r\n begin\r\n if FSize = FCapacity then\r\n AutoGrow;\r\n if FSize < FCapacity then\r\n begin\r\n Inc(Index);\r\n if (Index < FSize) and (KeysCompare(FEntries[Index].Key, Key) <> 0) then\r\n MoveArray(FEntries, Index, Index + 1, FSize - Index);\r\n FEntries[Index].Key := Key;\r\n FEntries[Index].Value := Value;\r\n Inc(FSize);\r\n end;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclUnicodeStrSortedMap.Remove(const Key: UnicodeString): TObject;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := Extract(Key);\r\n Result := FreeValue(Result);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclUnicodeStrSortedMap.SetCapacity(Value: Integer);\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FSize <= Value then\r\n begin\r\n SetLength(FEntries, Value);\r\n inherited SetCapacity(Value);\r\n end\r\n else\r\n raise EJclOperationNotSupportedError.Create;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclUnicodeStrSortedMap.Size: Integer;\r\nbegin\r\n Result := FSize;\r\nend;\r\n\r\nfunction TJclUnicodeStrSortedMap.SubMap(const FromKey, ToKey: UnicodeString): IJclUnicodeStrSortedMap;\r\nvar\r\n FromIndex, ToIndex: Integer;\r\n NewMap: TJclUnicodeStrSortedMap;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n NewMap := CreateEmptyContainer as TJclUnicodeStrSortedMap;\r\n FromIndex := BinarySearch(FromKey);\r\n if (FromIndex = -1) or (KeysCompare(FEntries[FromIndex].Key, FromKey) < 0) then\r\n Inc(FromIndex);\r\n ToIndex := BinarySearch(ToKey);\r\n if (FromIndex >= 0) and (FromIndex <= ToIndex) then\r\n begin\r\n NewMap.SetCapacity(ToIndex - FromIndex + 1);\r\n NewMap.FSize := ToIndex - FromIndex + 1;\r\n while ToIndex >= FromIndex do\r\n begin\r\n NewMap.FEntries[ToIndex - FromIndex] := FEntries[ToIndex];\r\n Dec(ToIndex);\r\n end;\r\n end;\r\n Result := NewMap;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclUnicodeStrSortedMap.TailMap(const FromKey: UnicodeString): IJclUnicodeStrSortedMap;\r\nvar\r\n FromIndex, Index: Integer;\r\n NewMap: TJclUnicodeStrSortedMap;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n NewMap := CreateEmptyContainer as TJclUnicodeStrSortedMap;\r\n FromIndex := BinarySearch(FromKey);\r\n if (FromIndex = -1) or (KeysCompare(FEntries[FromIndex].Key, FromKey) < 0) then\r\n Inc(FromIndex);\r\n if (FromIndex >= 0) and (FromIndex < FSize) then\r\n begin\r\n NewMap.SetCapacity(FSize - FromIndex);\r\n NewMap.FSize := FSize - FromIndex;\r\n Index := FromIndex;\r\n while Index < FSize do\r\n begin\r\n NewMap.FEntries[Index - FromIndex] := FEntries[Index];\r\n Inc(Index);\r\n end;\r\n end;\r\n Result := NewMap;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclUnicodeStrSortedMap.Values: IJclCollection;\r\nvar\r\n Index: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := TJclArrayList.Create(FSize, False);\r\n for Index := 0 to FSize - 1 do\r\n Result.Add(FEntries[Index].Value);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclUnicodeStrSortedMap.CreateEmptyContainer: TJclAbstractContainerBase;\r\nbegin\r\n Result := TJclUnicodeStrSortedMap.Create(FSize, False);\r\n AssignPropertiesTo(Result);\r\nend;\r\n\r\nfunction TJclUnicodeStrSortedMap.FreeKey(var Key: UnicodeString): UnicodeString;\r\nbegin\r\n Result := Key;\r\n Key := '';\r\nend;\r\n\r\nfunction TJclUnicodeStrSortedMap.FreeValue(var Value: TObject): TObject;\r\nbegin\r\n if FOwnsValues then\r\n begin\r\n Result := nil;\r\n FreeAndNil(Value);\r\n end\r\n else\r\n begin\r\n Result := Value;\r\n Value := nil;\r\n end;\r\nend;\r\n\r\nfunction TJclUnicodeStrSortedMap.GetOwnsValues: Boolean;\r\nbegin\r\n Result := FOwnsValues;\r\nend;\r\n\r\nfunction TJclUnicodeStrSortedMap.KeysCompare(const A, B: UnicodeString): Integer;\r\nbegin\r\n Result := ItemsCompare(A, B);\r\nend;\r\n\r\nfunction TJclUnicodeStrSortedMap.ValuesCompare(A, B: TObject): Integer;\r\nbegin\r\n Result := SimpleCompare(A, B);\r\nend;\r\n\r\n{$ENDIF SUPPORTS_UNICODE_STRING}\r\n\r\n//=== { TJclSingleSortedMap } ==============================================\r\n\r\nconstructor TJclSingleSortedMap.Create(ACapacity: Integer; AOwnsValues: Boolean);\r\nbegin\r\n inherited Create();\r\n FOwnsValues := AOwnsValues;\r\n SetCapacity(ACapacity);\r\nend;\r\n\r\ndestructor TJclSingleSortedMap.Destroy;\r\nbegin\r\n FReadOnly := False;\r\n Clear;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJclSingleSortedMap.AssignDataTo(Dest: TJclAbstractContainerBase);\r\nvar\r\n MyDest: TJclSingleSortedMap;\r\nbegin\r\n inherited AssignDataTo(Dest);\r\n if Dest is TJclSingleSortedMap then\r\n begin\r\n MyDest := TJclSingleSortedMap(Dest);\r\n MyDest.SetCapacity(FSize);\r\n MyDest.FEntries := FEntries;\r\n MyDest.FSize := FSize;\r\n end;\r\nend;\r\n\r\nfunction TJclSingleSortedMap.BinarySearch(const Key: Single): Integer;\r\nvar\r\n HiPos, LoPos, CompPos: Integer;\r\n Comp: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n LoPos := 0;\r\n HiPos := FSize - 1;\r\n CompPos := (HiPos + LoPos) div 2;\r\n while HiPos >= LoPos do\r\n begin\r\n Comp := KeysCompare(FEntries[CompPos].Key, Key);\r\n if Comp < 0 then\r\n LoPos := CompPos + 1\r\n else\r\n if Comp > 0 then\r\n HiPos := CompPos - 1\r\n else\r\n begin\r\n HiPos := CompPos;\r\n LoPos := CompPos + 1;\r\n end;\r\n CompPos := (HiPos + LoPos) div 2;\r\n end;\r\n Result := HiPos;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclSingleSortedMap.Clear;\r\nvar\r\n Index: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n for Index := 0 to FSize - 1 do\r\n begin\r\n FreeKey(FEntries[Index].Key);\r\n FreeValue(FEntries[Index].Value);\r\n end;\r\n FSize := 0;\r\n AutoPack;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSingleSortedMap.ContainsKey(const Key: Single): Boolean;\r\nvar\r\n Index: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Index := BinarySearch(Key);\r\n Result := (Index >= 0) and (KeysCompare(FEntries[Index].Key, Key) = 0);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSingleSortedMap.ContainsValue(Value: TObject): Boolean;\r\nvar\r\n Index: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n for Index := 0 to FSize - 1 do\r\n if ValuesCompare(FEntries[Index].Value, Value) = 0 then\r\n begin\r\n Result := True;\r\n Break;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSingleSortedMap.FirstKey: Single;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := 0.0;\r\n if FSize > 0 then\r\n Result := FEntries[0].Key\r\n else\r\n if not FReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSingleSortedMap.Extract(const Key: Single): TObject;\r\nvar\r\n Index: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Index := BinarySearch(Key);\r\n if (Index >= 0) and (KeysCompare(FEntries[Index].Key, Key) = 0) then\r\n begin\r\n Result := FEntries[Index].Value;\r\n FEntries[Index].Value := nil;\r\n FreeKey(FEntries[Index].Key);\r\n if Index < (FSize - 1) then\r\n MoveArray(FEntries, Index + 1, Index, FSize - Index - 1);\r\n Dec(FSize);\r\n AutoPack;\r\n end\r\n else\r\n Result := nil;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSingleSortedMap.GetValue(const Key: Single): TObject;\r\nvar\r\n Index: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Index := BinarySearch(Key);\r\n Result := nil;\r\n if (Index >= 0) and (KeysCompare(FEntries[Index].Key, Key) = 0) then\r\n Result := FEntries[Index].Value\r\n else if not FReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSingleSortedMap.HeadMap(const ToKey: Single): IJclSingleSortedMap;\r\nvar\r\n ToIndex: Integer;\r\n NewMap: TJclSingleSortedMap;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n NewMap := CreateEmptyContainer as TJclSingleSortedMap;\r\n ToIndex := BinarySearch(ToKey);\r\n if ToIndex >= 0 then\r\n begin\r\n NewMap.SetCapacity(ToIndex + 1);\r\n NewMap.FSize := ToIndex + 1;\r\n while ToIndex >= 0 do\r\n begin\r\n NewMap.FEntries[ToIndex] := FEntries[ToIndex];\r\n Dec(ToIndex);\r\n end;\r\n end;\r\n Result := NewMap;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSingleSortedMap.IsEmpty: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := FSize = 0;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSingleSortedMap.KeyOfValue(Value: TObject): Single;\r\nvar\r\n Index: Integer;\r\n Found: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Found := False;\r\n Result := 0.0;\r\n for Index := 0 to FSize - 1 do\r\n if ValuesCompare(FEntries[Index].Value, Value) = 0 then\r\n begin\r\n Result := FEntries[Index].Key;\r\n Found := True;\r\n Break;\r\n end;\r\n\r\n if (not Found) and (not FReturnDefaultElements) then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSingleSortedMap.KeySet: IJclSingleSet;\r\nvar\r\n Index: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := TJclSingleArraySet.Create(FSize);\r\n for Index := 0 to FSize - 1 do\r\n Result.Add(FEntries[Index].Key);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSingleSortedMap.LastKey: Single;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := 0.0;\r\n if FSize > 0 then\r\n Result := FEntries[FSize - 1].Key\r\n else\r\n if not FReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSingleSortedMap.MapEquals(const AMap: IJclSingleMap): Boolean;\r\nvar\r\n It: IJclSingleIterator;\r\n Index: Integer;\r\n AKey: Single;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if AMap = nil then\r\n Exit;\r\n if FSize <> AMap.Size then\r\n Exit;\r\n It := AMap.KeySet.First;\r\n Index := 0;\r\n while It.HasNext do\r\n begin\r\n if Index >= FSize then\r\n Exit;\r\n AKey := It.Next;\r\n if ValuesCompare(AMap.GetValue(AKey), FEntries[Index].Value) <> 0 then\r\n Exit;\r\n Inc(Index);\r\n end;\r\n Result := True;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclSingleSortedMap.InitializeArrayAfterMove(var List: TJclSingleSortedMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\nbegin\r\n { Clean array }\r\n if FromIndex < ToIndex then\r\n begin\r\n if (ToIndex - FromIndex) < Count then\r\n Count := ToIndex - FromIndex;\r\n FillChar(List[FromIndex], Count * SizeOf(List[0]), 0);\r\n end\r\n else\r\n if FromIndex > ToIndex then\r\n begin\r\n if (FromIndex - ToIndex) < Count then\r\n FillChar(List[ToIndex + Count], (FromIndex - ToIndex) * SizeOf(List[0]), 0)\r\n else\r\n FillChar(List[FromIndex], Count * SizeOf(List[0]), 0);\r\n end;\r\nend;\r\n\r\nprocedure TJclSingleSortedMap.MoveArray(var List: TJclSingleSortedMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\nbegin\r\n if Count > 0 then\r\n begin\r\n Move(List[FromIndex], List[ToIndex], Count * SizeOf(List[0]));\r\n InitializeArrayAfterMove(List, FromIndex, ToIndex, Count);\r\n end;\r\nend;\r\n\r\nprocedure TJclSingleSortedMap.PutAll(const AMap: IJclSingleMap);\r\nvar\r\n It: IJclSingleIterator;\r\n Key: Single;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if AMap = nil then\r\n Exit;\r\n It := AMap.KeySet.First;\r\n while It.HasNext do\r\n begin\r\n Key := It.Next;\r\n PutValue(Key, AMap.GetValue(Key));\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclSingleSortedMap.PutValue(const Key: Single; Value: TObject);\r\nvar\r\n Index: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FAllowDefaultElements or ((KeysCompare(Key, 0.0) <> 0) and (ValuesCompare(Value, nil) <> 0)) then\r\n begin\r\n Index := BinarySearch(Key);\r\n\r\n if (Index >= 0) and (KeysCompare(FEntries[Index].Key, Key) = 0) then\r\n begin\r\n FreeValue(FEntries[Index].Value);\r\n FEntries[Index].Value := Value;\r\n end\r\n else\r\n begin\r\n if FSize = FCapacity then\r\n AutoGrow;\r\n if FSize < FCapacity then\r\n begin\r\n Inc(Index);\r\n if (Index < FSize) and (KeysCompare(FEntries[Index].Key, Key) <> 0) then\r\n MoveArray(FEntries, Index, Index + 1, FSize - Index);\r\n FEntries[Index].Key := Key;\r\n FEntries[Index].Value := Value;\r\n Inc(FSize);\r\n end;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSingleSortedMap.Remove(const Key: Single): TObject;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := Extract(Key);\r\n Result := FreeValue(Result);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclSingleSortedMap.SetCapacity(Value: Integer);\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FSize <= Value then\r\n begin\r\n SetLength(FEntries, Value);\r\n inherited SetCapacity(Value);\r\n end\r\n else\r\n raise EJclOperationNotSupportedError.Create;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSingleSortedMap.Size: Integer;\r\nbegin\r\n Result := FSize;\r\nend;\r\n\r\nfunction TJclSingleSortedMap.SubMap(const FromKey, ToKey: Single): IJclSingleSortedMap;\r\nvar\r\n FromIndex, ToIndex: Integer;\r\n NewMap: TJclSingleSortedMap;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n NewMap := CreateEmptyContainer as TJclSingleSortedMap;\r\n FromIndex := BinarySearch(FromKey);\r\n if (FromIndex = -1) or (KeysCompare(FEntries[FromIndex].Key, FromKey) < 0) then\r\n Inc(FromIndex);\r\n ToIndex := BinarySearch(ToKey);\r\n if (FromIndex >= 0) and (FromIndex <= ToIndex) then\r\n begin\r\n NewMap.SetCapacity(ToIndex - FromIndex + 1);\r\n NewMap.FSize := ToIndex - FromIndex + 1;\r\n while ToIndex >= FromIndex do\r\n begin\r\n NewMap.FEntries[ToIndex - FromIndex] := FEntries[ToIndex];\r\n Dec(ToIndex);\r\n end;\r\n end;\r\n Result := NewMap;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSingleSortedMap.TailMap(const FromKey: Single): IJclSingleSortedMap;\r\nvar\r\n FromIndex, Index: Integer;\r\n NewMap: TJclSingleSortedMap;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n NewMap := CreateEmptyContainer as TJclSingleSortedMap;\r\n FromIndex := BinarySearch(FromKey);\r\n if (FromIndex = -1) or (KeysCompare(FEntries[FromIndex].Key, FromKey) < 0) then\r\n Inc(FromIndex);\r\n if (FromIndex >= 0) and (FromIndex < FSize) then\r\n begin\r\n NewMap.SetCapacity(FSize - FromIndex);\r\n NewMap.FSize := FSize - FromIndex;\r\n Index := FromIndex;\r\n while Index < FSize do\r\n begin\r\n NewMap.FEntries[Index - FromIndex] := FEntries[Index];\r\n Inc(Index);\r\n end;\r\n end;\r\n Result := NewMap;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSingleSortedMap.Values: IJclCollection;\r\nvar\r\n Index: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := TJclArrayList.Create(FSize, False);\r\n for Index := 0 to FSize - 1 do\r\n Result.Add(FEntries[Index].Value);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSingleSortedMap.CreateEmptyContainer: TJclAbstractContainerBase;\r\nbegin\r\n Result := TJclSingleSortedMap.Create(FSize, False);\r\n AssignPropertiesTo(Result);\r\nend;\r\n\r\nfunction TJclSingleSortedMap.FreeKey(var Key: Single): Single;\r\nbegin\r\n Result := Key;\r\n Key := 0.0;\r\nend;\r\n\r\nfunction TJclSingleSortedMap.FreeValue(var Value: TObject): TObject;\r\nbegin\r\n if FOwnsValues then\r\n begin\r\n Result := nil;\r\n FreeAndNil(Value);\r\n end\r\n else\r\n begin\r\n Result := Value;\r\n Value := nil;\r\n end;\r\nend;\r\n\r\nfunction TJclSingleSortedMap.GetOwnsValues: Boolean;\r\nbegin\r\n Result := FOwnsValues;\r\nend;\r\n\r\nfunction TJclSingleSortedMap.KeysCompare(const A, B: Single): Integer;\r\nbegin\r\n Result := ItemsCompare(A, B);\r\nend;\r\n\r\nfunction TJclSingleSortedMap.ValuesCompare(A, B: TObject): Integer;\r\nbegin\r\n Result := SimpleCompare(A, B);\r\nend;\r\n\r\n//=== { TJclDoubleSortedMap } ==============================================\r\n\r\nconstructor TJclDoubleSortedMap.Create(ACapacity: Integer; AOwnsValues: Boolean);\r\nbegin\r\n inherited Create();\r\n FOwnsValues := AOwnsValues;\r\n SetCapacity(ACapacity);\r\nend;\r\n\r\ndestructor TJclDoubleSortedMap.Destroy;\r\nbegin\r\n FReadOnly := False;\r\n Clear;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJclDoubleSortedMap.AssignDataTo(Dest: TJclAbstractContainerBase);\r\nvar\r\n MyDest: TJclDoubleSortedMap;\r\nbegin\r\n inherited AssignDataTo(Dest);\r\n if Dest is TJclDoubleSortedMap then\r\n begin\r\n MyDest := TJclDoubleSortedMap(Dest);\r\n MyDest.SetCapacity(FSize);\r\n MyDest.FEntries := FEntries;\r\n MyDest.FSize := FSize;\r\n end;\r\nend;\r\n\r\nfunction TJclDoubleSortedMap.BinarySearch(const Key: Double): Integer;\r\nvar\r\n HiPos, LoPos, CompPos: Integer;\r\n Comp: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n LoPos := 0;\r\n HiPos := FSize - 1;\r\n CompPos := (HiPos + LoPos) div 2;\r\n while HiPos >= LoPos do\r\n begin\r\n Comp := KeysCompare(FEntries[CompPos].Key, Key);\r\n if Comp < 0 then\r\n LoPos := CompPos + 1\r\n else\r\n if Comp > 0 then\r\n HiPos := CompPos - 1\r\n else\r\n begin\r\n HiPos := CompPos;\r\n LoPos := CompPos + 1;\r\n end;\r\n CompPos := (HiPos + LoPos) div 2;\r\n end;\r\n Result := HiPos;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclDoubleSortedMap.Clear;\r\nvar\r\n Index: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n for Index := 0 to FSize - 1 do\r\n begin\r\n FreeKey(FEntries[Index].Key);\r\n FreeValue(FEntries[Index].Value);\r\n end;\r\n FSize := 0;\r\n AutoPack;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclDoubleSortedMap.ContainsKey(const Key: Double): Boolean;\r\nvar\r\n Index: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Index := BinarySearch(Key);\r\n Result := (Index >= 0) and (KeysCompare(FEntries[Index].Key, Key) = 0);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclDoubleSortedMap.ContainsValue(Value: TObject): Boolean;\r\nvar\r\n Index: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n for Index := 0 to FSize - 1 do\r\n if ValuesCompare(FEntries[Index].Value, Value) = 0 then\r\n begin\r\n Result := True;\r\n Break;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclDoubleSortedMap.FirstKey: Double;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := 0.0;\r\n if FSize > 0 then\r\n Result := FEntries[0].Key\r\n else\r\n if not FReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclDoubleSortedMap.Extract(const Key: Double): TObject;\r\nvar\r\n Index: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Index := BinarySearch(Key);\r\n if (Index >= 0) and (KeysCompare(FEntries[Index].Key, Key) = 0) then\r\n begin\r\n Result := FEntries[Index].Value;\r\n FEntries[Index].Value := nil;\r\n FreeKey(FEntries[Index].Key);\r\n if Index < (FSize - 1) then\r\n MoveArray(FEntries, Index + 1, Index, FSize - Index - 1);\r\n Dec(FSize);\r\n AutoPack;\r\n end\r\n else\r\n Result := nil;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclDoubleSortedMap.GetValue(const Key: Double): TObject;\r\nvar\r\n Index: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Index := BinarySearch(Key);\r\n Result := nil;\r\n if (Index >= 0) and (KeysCompare(FEntries[Index].Key, Key) = 0) then\r\n Result := FEntries[Index].Value\r\n else if not FReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclDoubleSortedMap.HeadMap(const ToKey: Double): IJclDoubleSortedMap;\r\nvar\r\n ToIndex: Integer;\r\n NewMap: TJclDoubleSortedMap;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n NewMap := CreateEmptyContainer as TJclDoubleSortedMap;\r\n ToIndex := BinarySearch(ToKey);\r\n if ToIndex >= 0 then\r\n begin\r\n NewMap.SetCapacity(ToIndex + 1);\r\n NewMap.FSize := ToIndex + 1;\r\n while ToIndex >= 0 do\r\n begin\r\n NewMap.FEntries[ToIndex] := FEntries[ToIndex];\r\n Dec(ToIndex);\r\n end;\r\n end;\r\n Result := NewMap;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclDoubleSortedMap.IsEmpty: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := FSize = 0;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclDoubleSortedMap.KeyOfValue(Value: TObject): Double;\r\nvar\r\n Index: Integer;\r\n Found: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Found := False;\r\n Result := 0.0;\r\n for Index := 0 to FSize - 1 do\r\n if ValuesCompare(FEntries[Index].Value, Value) = 0 then\r\n begin\r\n Result := FEntries[Index].Key;\r\n Found := True;\r\n Break;\r\n end;\r\n\r\n if (not Found) and (not FReturnDefaultElements) then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclDoubleSortedMap.KeySet: IJclDoubleSet;\r\nvar\r\n Index: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := TJclDoubleArraySet.Create(FSize);\r\n for Index := 0 to FSize - 1 do\r\n Result.Add(FEntries[Index].Key);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclDoubleSortedMap.LastKey: Double;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := 0.0;\r\n if FSize > 0 then\r\n Result := FEntries[FSize - 1].Key\r\n else\r\n if not FReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclDoubleSortedMap.MapEquals(const AMap: IJclDoubleMap): Boolean;\r\nvar\r\n It: IJclDoubleIterator;\r\n Index: Integer;\r\n AKey: Double;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if AMap = nil then\r\n Exit;\r\n if FSize <> AMap.Size then\r\n Exit;\r\n It := AMap.KeySet.First;\r\n Index := 0;\r\n while It.HasNext do\r\n begin\r\n if Index >= FSize then\r\n Exit;\r\n AKey := It.Next;\r\n if ValuesCompare(AMap.GetValue(AKey), FEntries[Index].Value) <> 0 then\r\n Exit;\r\n Inc(Index);\r\n end;\r\n Result := True;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclDoubleSortedMap.InitializeArrayAfterMove(var List: TJclDoubleSortedMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\nbegin\r\n { Clean array }\r\n if FromIndex < ToIndex then\r\n begin\r\n if (ToIndex - FromIndex) < Count then\r\n Count := ToIndex - FromIndex;\r\n FillChar(List[FromIndex], Count * SizeOf(List[0]), 0);\r\n end\r\n else\r\n if FromIndex > ToIndex then\r\n begin\r\n if (FromIndex - ToIndex) < Count then\r\n FillChar(List[ToIndex + Count], (FromIndex - ToIndex) * SizeOf(List[0]), 0)\r\n else\r\n FillChar(List[FromIndex], Count * SizeOf(List[0]), 0);\r\n end;\r\nend;\r\n\r\nprocedure TJclDoubleSortedMap.MoveArray(var List: TJclDoubleSortedMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\nbegin\r\n if Count > 0 then\r\n begin\r\n Move(List[FromIndex], List[ToIndex], Count * SizeOf(List[0]));\r\n InitializeArrayAfterMove(List, FromIndex, ToIndex, Count);\r\n end;\r\nend;\r\n\r\nprocedure TJclDoubleSortedMap.PutAll(const AMap: IJclDoubleMap);\r\nvar\r\n It: IJclDoubleIterator;\r\n Key: Double;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if AMap = nil then\r\n Exit;\r\n It := AMap.KeySet.First;\r\n while It.HasNext do\r\n begin\r\n Key := It.Next;\r\n PutValue(Key, AMap.GetValue(Key));\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclDoubleSortedMap.PutValue(const Key: Double; Value: TObject);\r\nvar\r\n Index: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FAllowDefaultElements or ((KeysCompare(Key, 0.0) <> 0) and (ValuesCompare(Value, nil) <> 0)) then\r\n begin\r\n Index := BinarySearch(Key);\r\n\r\n if (Index >= 0) and (KeysCompare(FEntries[Index].Key, Key) = 0) then\r\n begin\r\n FreeValue(FEntries[Index].Value);\r\n FEntries[Index].Value := Value;\r\n end\r\n else\r\n begin\r\n if FSize = FCapacity then\r\n AutoGrow;\r\n if FSize < FCapacity then\r\n begin\r\n Inc(Index);\r\n if (Index < FSize) and (KeysCompare(FEntries[Index].Key, Key) <> 0) then\r\n MoveArray(FEntries, Index, Index + 1, FSize - Index);\r\n FEntries[Index].Key := Key;\r\n FEntries[Index].Value := Value;\r\n Inc(FSize);\r\n end;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclDoubleSortedMap.Remove(const Key: Double): TObject;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := Extract(Key);\r\n Result := FreeValue(Result);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclDoubleSortedMap.SetCapacity(Value: Integer);\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FSize <= Value then\r\n begin\r\n SetLength(FEntries, Value);\r\n inherited SetCapacity(Value);\r\n end\r\n else\r\n raise EJclOperationNotSupportedError.Create;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclDoubleSortedMap.Size: Integer;\r\nbegin\r\n Result := FSize;\r\nend;\r\n\r\nfunction TJclDoubleSortedMap.SubMap(const FromKey, ToKey: Double): IJclDoubleSortedMap;\r\nvar\r\n FromIndex, ToIndex: Integer;\r\n NewMap: TJclDoubleSortedMap;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n NewMap := CreateEmptyContainer as TJclDoubleSortedMap;\r\n FromIndex := BinarySearch(FromKey);\r\n if (FromIndex = -1) or (KeysCompare(FEntries[FromIndex].Key, FromKey) < 0) then\r\n Inc(FromIndex);\r\n ToIndex := BinarySearch(ToKey);\r\n if (FromIndex >= 0) and (FromIndex <= ToIndex) then\r\n begin\r\n NewMap.SetCapacity(ToIndex - FromIndex + 1);\r\n NewMap.FSize := ToIndex - FromIndex + 1;\r\n while ToIndex >= FromIndex do\r\n begin\r\n NewMap.FEntries[ToIndex - FromIndex] := FEntries[ToIndex];\r\n Dec(ToIndex);\r\n end;\r\n end;\r\n Result := NewMap;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclDoubleSortedMap.TailMap(const FromKey: Double): IJclDoubleSortedMap;\r\nvar\r\n FromIndex, Index: Integer;\r\n NewMap: TJclDoubleSortedMap;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n NewMap := CreateEmptyContainer as TJclDoubleSortedMap;\r\n FromIndex := BinarySearch(FromKey);\r\n if (FromIndex = -1) or (KeysCompare(FEntries[FromIndex].Key, FromKey) < 0) then\r\n Inc(FromIndex);\r\n if (FromIndex >= 0) and (FromIndex < FSize) then\r\n begin\r\n NewMap.SetCapacity(FSize - FromIndex);\r\n NewMap.FSize := FSize - FromIndex;\r\n Index := FromIndex;\r\n while Index < FSize do\r\n begin\r\n NewMap.FEntries[Index - FromIndex] := FEntries[Index];\r\n Inc(Index);\r\n end;\r\n end;\r\n Result := NewMap;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclDoubleSortedMap.Values: IJclCollection;\r\nvar\r\n Index: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := TJclArrayList.Create(FSize, False);\r\n for Index := 0 to FSize - 1 do\r\n Result.Add(FEntries[Index].Value);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclDoubleSortedMap.CreateEmptyContainer: TJclAbstractContainerBase;\r\nbegin\r\n Result := TJclDoubleSortedMap.Create(FSize, False);\r\n AssignPropertiesTo(Result);\r\nend;\r\n\r\nfunction TJclDoubleSortedMap.FreeKey(var Key: Double): Double;\r\nbegin\r\n Result := Key;\r\n Key := 0.0;\r\nend;\r\n\r\nfunction TJclDoubleSortedMap.FreeValue(var Value: TObject): TObject;\r\nbegin\r\n if FOwnsValues then\r\n begin\r\n Result := nil;\r\n FreeAndNil(Value);\r\n end\r\n else\r\n begin\r\n Result := Value;\r\n Value := nil;\r\n end;\r\nend;\r\n\r\nfunction TJclDoubleSortedMap.GetOwnsValues: Boolean;\r\nbegin\r\n Result := FOwnsValues;\r\nend;\r\n\r\nfunction TJclDoubleSortedMap.KeysCompare(const A, B: Double): Integer;\r\nbegin\r\n Result := ItemsCompare(A, B);\r\nend;\r\n\r\nfunction TJclDoubleSortedMap.ValuesCompare(A, B: TObject): Integer;\r\nbegin\r\n Result := SimpleCompare(A, B);\r\nend;\r\n\r\n//=== { TJclExtendedSortedMap } ==============================================\r\n\r\nconstructor TJclExtendedSortedMap.Create(ACapacity: Integer; AOwnsValues: Boolean);\r\nbegin\r\n inherited Create();\r\n FOwnsValues := AOwnsValues;\r\n SetCapacity(ACapacity);\r\nend;\r\n\r\ndestructor TJclExtendedSortedMap.Destroy;\r\nbegin\r\n FReadOnly := False;\r\n Clear;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJclExtendedSortedMap.AssignDataTo(Dest: TJclAbstractContainerBase);\r\nvar\r\n MyDest: TJclExtendedSortedMap;\r\nbegin\r\n inherited AssignDataTo(Dest);\r\n if Dest is TJclExtendedSortedMap then\r\n begin\r\n MyDest := TJclExtendedSortedMap(Dest);\r\n MyDest.SetCapacity(FSize);\r\n MyDest.FEntries := FEntries;\r\n MyDest.FSize := FSize;\r\n end;\r\nend;\r\n\r\nfunction TJclExtendedSortedMap.BinarySearch(const Key: Extended): Integer;\r\nvar\r\n HiPos, LoPos, CompPos: Integer;\r\n Comp: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n LoPos := 0;\r\n HiPos := FSize - 1;\r\n CompPos := (HiPos + LoPos) div 2;\r\n while HiPos >= LoPos do\r\n begin\r\n Comp := KeysCompare(FEntries[CompPos].Key, Key);\r\n if Comp < 0 then\r\n LoPos := CompPos + 1\r\n else\r\n if Comp > 0 then\r\n HiPos := CompPos - 1\r\n else\r\n begin\r\n HiPos := CompPos;\r\n LoPos := CompPos + 1;\r\n end;\r\n CompPos := (HiPos + LoPos) div 2;\r\n end;\r\n Result := HiPos;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclExtendedSortedMap.Clear;\r\nvar\r\n Index: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n for Index := 0 to FSize - 1 do\r\n begin\r\n FreeKey(FEntries[Index].Key);\r\n FreeValue(FEntries[Index].Value);\r\n end;\r\n FSize := 0;\r\n AutoPack;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclExtendedSortedMap.ContainsKey(const Key: Extended): Boolean;\r\nvar\r\n Index: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Index := BinarySearch(Key);\r\n Result := (Index >= 0) and (KeysCompare(FEntries[Index].Key, Key) = 0);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclExtendedSortedMap.ContainsValue(Value: TObject): Boolean;\r\nvar\r\n Index: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n for Index := 0 to FSize - 1 do\r\n if ValuesCompare(FEntries[Index].Value, Value) = 0 then\r\n begin\r\n Result := True;\r\n Break;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclExtendedSortedMap.FirstKey: Extended;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := 0.0;\r\n if FSize > 0 then\r\n Result := FEntries[0].Key\r\n else\r\n if not FReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclExtendedSortedMap.Extract(const Key: Extended): TObject;\r\nvar\r\n Index: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Index := BinarySearch(Key);\r\n if (Index >= 0) and (KeysCompare(FEntries[Index].Key, Key) = 0) then\r\n begin\r\n Result := FEntries[Index].Value;\r\n FEntries[Index].Value := nil;\r\n FreeKey(FEntries[Index].Key);\r\n if Index < (FSize - 1) then\r\n MoveArray(FEntries, Index + 1, Index, FSize - Index - 1);\r\n Dec(FSize);\r\n AutoPack;\r\n end\r\n else\r\n Result := nil;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclExtendedSortedMap.GetValue(const Key: Extended): TObject;\r\nvar\r\n Index: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Index := BinarySearch(Key);\r\n Result := nil;\r\n if (Index >= 0) and (KeysCompare(FEntries[Index].Key, Key) = 0) then\r\n Result := FEntries[Index].Value\r\n else if not FReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclExtendedSortedMap.HeadMap(const ToKey: Extended): IJclExtendedSortedMap;\r\nvar\r\n ToIndex: Integer;\r\n NewMap: TJclExtendedSortedMap;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n NewMap := CreateEmptyContainer as TJclExtendedSortedMap;\r\n ToIndex := BinarySearch(ToKey);\r\n if ToIndex >= 0 then\r\n begin\r\n NewMap.SetCapacity(ToIndex + 1);\r\n NewMap.FSize := ToIndex + 1;\r\n while ToIndex >= 0 do\r\n begin\r\n NewMap.FEntries[ToIndex] := FEntries[ToIndex];\r\n Dec(ToIndex);\r\n end;\r\n end;\r\n Result := NewMap;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclExtendedSortedMap.IsEmpty: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := FSize = 0;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclExtendedSortedMap.KeyOfValue(Value: TObject): Extended;\r\nvar\r\n Index: Integer;\r\n Found: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Found := False;\r\n Result := 0.0;\r\n for Index := 0 to FSize - 1 do\r\n if ValuesCompare(FEntries[Index].Value, Value) = 0 then\r\n begin\r\n Result := FEntries[Index].Key;\r\n Found := True;\r\n Break;\r\n end;\r\n\r\n if (not Found) and (not FReturnDefaultElements) then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclExtendedSortedMap.KeySet: IJclExtendedSet;\r\nvar\r\n Index: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := TJclExtendedArraySet.Create(FSize);\r\n for Index := 0 to FSize - 1 do\r\n Result.Add(FEntries[Index].Key);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclExtendedSortedMap.LastKey: Extended;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := 0.0;\r\n if FSize > 0 then\r\n Result := FEntries[FSize - 1].Key\r\n else\r\n if not FReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclExtendedSortedMap.MapEquals(const AMap: IJclExtendedMap): Boolean;\r\nvar\r\n It: IJclExtendedIterator;\r\n Index: Integer;\r\n AKey: Extended;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if AMap = nil then\r\n Exit;\r\n if FSize <> AMap.Size then\r\n Exit;\r\n It := AMap.KeySet.First;\r\n Index := 0;\r\n while It.HasNext do\r\n begin\r\n if Index >= FSize then\r\n Exit;\r\n AKey := It.Next;\r\n if ValuesCompare(AMap.GetValue(AKey), FEntries[Index].Value) <> 0 then\r\n Exit;\r\n Inc(Index);\r\n end;\r\n Result := True;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclExtendedSortedMap.InitializeArrayAfterMove(var List: TJclExtendedSortedMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\nbegin\r\n { Clean array }\r\n if FromIndex < ToIndex then\r\n begin\r\n if (ToIndex - FromIndex) < Count then\r\n Count := ToIndex - FromIndex;\r\n FillChar(List[FromIndex], Count * SizeOf(List[0]), 0);\r\n end\r\n else\r\n if FromIndex > ToIndex then\r\n begin\r\n if (FromIndex - ToIndex) < Count then\r\n FillChar(List[ToIndex + Count], (FromIndex - ToIndex) * SizeOf(List[0]), 0)\r\n else\r\n FillChar(List[FromIndex], Count * SizeOf(List[0]), 0);\r\n end;\r\nend;\r\n\r\nprocedure TJclExtendedSortedMap.MoveArray(var List: TJclExtendedSortedMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\nbegin\r\n if Count > 0 then\r\n begin\r\n Move(List[FromIndex], List[ToIndex], Count * SizeOf(List[0]));\r\n InitializeArrayAfterMove(List, FromIndex, ToIndex, Count);\r\n end;\r\nend;\r\n\r\nprocedure TJclExtendedSortedMap.PutAll(const AMap: IJclExtendedMap);\r\nvar\r\n It: IJclExtendedIterator;\r\n Key: Extended;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if AMap = nil then\r\n Exit;\r\n It := AMap.KeySet.First;\r\n while It.HasNext do\r\n begin\r\n Key := It.Next;\r\n PutValue(Key, AMap.GetValue(Key));\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclExtendedSortedMap.PutValue(const Key: Extended; Value: TObject);\r\nvar\r\n Index: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FAllowDefaultElements or ((KeysCompare(Key, 0.0) <> 0) and (ValuesCompare(Value, nil) <> 0)) then\r\n begin\r\n Index := BinarySearch(Key);\r\n\r\n if (Index >= 0) and (KeysCompare(FEntries[Index].Key, Key) = 0) then\r\n begin\r\n FreeValue(FEntries[Index].Value);\r\n FEntries[Index].Value := Value;\r\n end\r\n else\r\n begin\r\n if FSize = FCapacity then\r\n AutoGrow;\r\n if FSize < FCapacity then\r\n begin\r\n Inc(Index);\r\n if (Index < FSize) and (KeysCompare(FEntries[Index].Key, Key) <> 0) then\r\n MoveArray(FEntries, Index, Index + 1, FSize - Index);\r\n FEntries[Index].Key := Key;\r\n FEntries[Index].Value := Value;\r\n Inc(FSize);\r\n end;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclExtendedSortedMap.Remove(const Key: Extended): TObject;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := Extract(Key);\r\n Result := FreeValue(Result);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclExtendedSortedMap.SetCapacity(Value: Integer);\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FSize <= Value then\r\n begin\r\n SetLength(FEntries, Value);\r\n inherited SetCapacity(Value);\r\n end\r\n else\r\n raise EJclOperationNotSupportedError.Create;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclExtendedSortedMap.Size: Integer;\r\nbegin\r\n Result := FSize;\r\nend;\r\n\r\nfunction TJclExtendedSortedMap.SubMap(const FromKey, ToKey: Extended): IJclExtendedSortedMap;\r\nvar\r\n FromIndex, ToIndex: Integer;\r\n NewMap: TJclExtendedSortedMap;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n NewMap := CreateEmptyContainer as TJclExtendedSortedMap;\r\n FromIndex := BinarySearch(FromKey);\r\n if (FromIndex = -1) or (KeysCompare(FEntries[FromIndex].Key, FromKey) < 0) then\r\n Inc(FromIndex);\r\n ToIndex := BinarySearch(ToKey);\r\n if (FromIndex >= 0) and (FromIndex <= ToIndex) then\r\n begin\r\n NewMap.SetCapacity(ToIndex - FromIndex + 1);\r\n NewMap.FSize := ToIndex - FromIndex + 1;\r\n while ToIndex >= FromIndex do\r\n begin\r\n NewMap.FEntries[ToIndex - FromIndex] := FEntries[ToIndex];\r\n Dec(ToIndex);\r\n end;\r\n end;\r\n Result := NewMap;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclExtendedSortedMap.TailMap(const FromKey: Extended): IJclExtendedSortedMap;\r\nvar\r\n FromIndex, Index: Integer;\r\n NewMap: TJclExtendedSortedMap;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n NewMap := CreateEmptyContainer as TJclExtendedSortedMap;\r\n FromIndex := BinarySearch(FromKey);\r\n if (FromIndex = -1) or (KeysCompare(FEntries[FromIndex].Key, FromKey) < 0) then\r\n Inc(FromIndex);\r\n if (FromIndex >= 0) and (FromIndex < FSize) then\r\n begin\r\n NewMap.SetCapacity(FSize - FromIndex);\r\n NewMap.FSize := FSize - FromIndex;\r\n Index := FromIndex;\r\n while Index < FSize do\r\n begin\r\n NewMap.FEntries[Index - FromIndex] := FEntries[Index];\r\n Inc(Index);\r\n end;\r\n end;\r\n Result := NewMap;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclExtendedSortedMap.Values: IJclCollection;\r\nvar\r\n Index: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := TJclArrayList.Create(FSize, False);\r\n for Index := 0 to FSize - 1 do\r\n Result.Add(FEntries[Index].Value);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclExtendedSortedMap.CreateEmptyContainer: TJclAbstractContainerBase;\r\nbegin\r\n Result := TJclExtendedSortedMap.Create(FSize, False);\r\n AssignPropertiesTo(Result);\r\nend;\r\n\r\nfunction TJclExtendedSortedMap.FreeKey(var Key: Extended): Extended;\r\nbegin\r\n Result := Key;\r\n Key := 0.0;\r\nend;\r\n\r\nfunction TJclExtendedSortedMap.FreeValue(var Value: TObject): TObject;\r\nbegin\r\n if FOwnsValues then\r\n begin\r\n Result := nil;\r\n FreeAndNil(Value);\r\n end\r\n else\r\n begin\r\n Result := Value;\r\n Value := nil;\r\n end;\r\nend;\r\n\r\nfunction TJclExtendedSortedMap.GetOwnsValues: Boolean;\r\nbegin\r\n Result := FOwnsValues;\r\nend;\r\n\r\nfunction TJclExtendedSortedMap.KeysCompare(const A, B: Extended): Integer;\r\nbegin\r\n Result := ItemsCompare(A, B);\r\nend;\r\n\r\nfunction TJclExtendedSortedMap.ValuesCompare(A, B: TObject): Integer;\r\nbegin\r\n Result := SimpleCompare(A, B);\r\nend;\r\n\r\n//=== { TJclIntegerSortedMap } ==============================================\r\n\r\nconstructor TJclIntegerSortedMap.Create(ACapacity: Integer; AOwnsValues: Boolean);\r\nbegin\r\n inherited Create();\r\n FOwnsValues := AOwnsValues;\r\n SetCapacity(ACapacity);\r\nend;\r\n\r\ndestructor TJclIntegerSortedMap.Destroy;\r\nbegin\r\n FReadOnly := False;\r\n Clear;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJclIntegerSortedMap.AssignDataTo(Dest: TJclAbstractContainerBase);\r\nvar\r\n MyDest: TJclIntegerSortedMap;\r\nbegin\r\n inherited AssignDataTo(Dest);\r\n if Dest is TJclIntegerSortedMap then\r\n begin\r\n MyDest := TJclIntegerSortedMap(Dest);\r\n MyDest.SetCapacity(FSize);\r\n MyDest.FEntries := FEntries;\r\n MyDest.FSize := FSize;\r\n end;\r\nend;\r\n\r\nfunction TJclIntegerSortedMap.BinarySearch(Key: Integer): Integer;\r\nvar\r\n HiPos, LoPos, CompPos: Integer;\r\n Comp: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n LoPos := 0;\r\n HiPos := FSize - 1;\r\n CompPos := (HiPos + LoPos) div 2;\r\n while HiPos >= LoPos do\r\n begin\r\n Comp := KeysCompare(FEntries[CompPos].Key, Key);\r\n if Comp < 0 then\r\n LoPos := CompPos + 1\r\n else\r\n if Comp > 0 then\r\n HiPos := CompPos - 1\r\n else\r\n begin\r\n HiPos := CompPos;\r\n LoPos := CompPos + 1;\r\n end;\r\n CompPos := (HiPos + LoPos) div 2;\r\n end;\r\n Result := HiPos;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclIntegerSortedMap.Clear;\r\nvar\r\n Index: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n for Index := 0 to FSize - 1 do\r\n begin\r\n FreeKey(FEntries[Index].Key);\r\n FreeValue(FEntries[Index].Value);\r\n end;\r\n FSize := 0;\r\n AutoPack;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntegerSortedMap.ContainsKey(Key: Integer): Boolean;\r\nvar\r\n Index: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Index := BinarySearch(Key);\r\n Result := (Index >= 0) and (KeysCompare(FEntries[Index].Key, Key) = 0);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntegerSortedMap.ContainsValue(Value: TObject): Boolean;\r\nvar\r\n Index: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n for Index := 0 to FSize - 1 do\r\n if ValuesCompare(FEntries[Index].Value, Value) = 0 then\r\n begin\r\n Result := True;\r\n Break;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntegerSortedMap.FirstKey: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := 0;\r\n if FSize > 0 then\r\n Result := FEntries[0].Key\r\n else\r\n if not FReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntegerSortedMap.Extract(Key: Integer): TObject;\r\nvar\r\n Index: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Index := BinarySearch(Key);\r\n if (Index >= 0) and (KeysCompare(FEntries[Index].Key, Key) = 0) then\r\n begin\r\n Result := FEntries[Index].Value;\r\n FEntries[Index].Value := nil;\r\n FreeKey(FEntries[Index].Key);\r\n if Index < (FSize - 1) then\r\n MoveArray(FEntries, Index + 1, Index, FSize - Index - 1);\r\n Dec(FSize);\r\n AutoPack;\r\n end\r\n else\r\n Result := nil;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntegerSortedMap.GetValue(Key: Integer): TObject;\r\nvar\r\n Index: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Index := BinarySearch(Key);\r\n Result := nil;\r\n if (Index >= 0) and (KeysCompare(FEntries[Index].Key, Key) = 0) then\r\n Result := FEntries[Index].Value\r\n else if not FReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntegerSortedMap.HeadMap(ToKey: Integer): IJclIntegerSortedMap;\r\nvar\r\n ToIndex: Integer;\r\n NewMap: TJclIntegerSortedMap;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n NewMap := CreateEmptyContainer as TJclIntegerSortedMap;\r\n ToIndex := BinarySearch(ToKey);\r\n if ToIndex >= 0 then\r\n begin\r\n NewMap.SetCapacity(ToIndex + 1);\r\n NewMap.FSize := ToIndex + 1;\r\n while ToIndex >= 0 do\r\n begin\r\n NewMap.FEntries[ToIndex] := FEntries[ToIndex];\r\n Dec(ToIndex);\r\n end;\r\n end;\r\n Result := NewMap;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntegerSortedMap.IsEmpty: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := FSize = 0;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntegerSortedMap.KeyOfValue(Value: TObject): Integer;\r\nvar\r\n Index: Integer;\r\n Found: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Found := False;\r\n Result := 0;\r\n for Index := 0 to FSize - 1 do\r\n if ValuesCompare(FEntries[Index].Value, Value) = 0 then\r\n begin\r\n Result := FEntries[Index].Key;\r\n Found := True;\r\n Break;\r\n end;\r\n\r\n if (not Found) and (not FReturnDefaultElements) then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntegerSortedMap.KeySet: IJclIntegerSet;\r\nvar\r\n Index: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := TJclIntegerArraySet.Create(FSize);\r\n for Index := 0 to FSize - 1 do\r\n Result.Add(FEntries[Index].Key);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntegerSortedMap.LastKey: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := 0;\r\n if FSize > 0 then\r\n Result := FEntries[FSize - 1].Key\r\n else\r\n if not FReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntegerSortedMap.MapEquals(const AMap: IJclIntegerMap): Boolean;\r\nvar\r\n It: IJclIntegerIterator;\r\n Index: Integer;\r\n AKey: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if AMap = nil then\r\n Exit;\r\n if FSize <> AMap.Size then\r\n Exit;\r\n It := AMap.KeySet.First;\r\n Index := 0;\r\n while It.HasNext do\r\n begin\r\n if Index >= FSize then\r\n Exit;\r\n AKey := It.Next;\r\n if ValuesCompare(AMap.GetValue(AKey), FEntries[Index].Value) <> 0 then\r\n Exit;\r\n Inc(Index);\r\n end;\r\n Result := True;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclIntegerSortedMap.InitializeArrayAfterMove(var List: TJclIntegerSortedMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\nbegin\r\n { Clean array }\r\n if FromIndex < ToIndex then\r\n begin\r\n if (ToIndex - FromIndex) < Count then\r\n Count := ToIndex - FromIndex;\r\n FillChar(List[FromIndex], Count * SizeOf(List[0]), 0);\r\n end\r\n else\r\n if FromIndex > ToIndex then\r\n begin\r\n if (FromIndex - ToIndex) < Count then\r\n FillChar(List[ToIndex + Count], (FromIndex - ToIndex) * SizeOf(List[0]), 0)\r\n else\r\n FillChar(List[FromIndex], Count * SizeOf(List[0]), 0);\r\n end;\r\nend;\r\n\r\nprocedure TJclIntegerSortedMap.MoveArray(var List: TJclIntegerSortedMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\nbegin\r\n if Count > 0 then\r\n begin\r\n Move(List[FromIndex], List[ToIndex], Count * SizeOf(List[0]));\r\n InitializeArrayAfterMove(List, FromIndex, ToIndex, Count);\r\n end;\r\nend;\r\n\r\nprocedure TJclIntegerSortedMap.PutAll(const AMap: IJclIntegerMap);\r\nvar\r\n It: IJclIntegerIterator;\r\n Key: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if AMap = nil then\r\n Exit;\r\n It := AMap.KeySet.First;\r\n while It.HasNext do\r\n begin\r\n Key := It.Next;\r\n PutValue(Key, AMap.GetValue(Key));\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclIntegerSortedMap.PutValue(Key: Integer; Value: TObject);\r\nvar\r\n Index: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FAllowDefaultElements or ((KeysCompare(Key, 0) <> 0) and (ValuesCompare(Value, nil) <> 0)) then\r\n begin\r\n Index := BinarySearch(Key);\r\n\r\n if (Index >= 0) and (KeysCompare(FEntries[Index].Key, Key) = 0) then\r\n begin\r\n FreeValue(FEntries[Index].Value);\r\n FEntries[Index].Value := Value;\r\n end\r\n else\r\n begin\r\n if FSize = FCapacity then\r\n AutoGrow;\r\n if FSize < FCapacity then\r\n begin\r\n Inc(Index);\r\n if (Index < FSize) and (KeysCompare(FEntries[Index].Key, Key) <> 0) then\r\n MoveArray(FEntries, Index, Index + 1, FSize - Index);\r\n FEntries[Index].Key := Key;\r\n FEntries[Index].Value := Value;\r\n Inc(FSize);\r\n end;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntegerSortedMap.Remove(Key: Integer): TObject;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := Extract(Key);\r\n Result := FreeValue(Result);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclIntegerSortedMap.SetCapacity(Value: Integer);\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FSize <= Value then\r\n begin\r\n SetLength(FEntries, Value);\r\n inherited SetCapacity(Value);\r\n end\r\n else\r\n raise EJclOperationNotSupportedError.Create;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntegerSortedMap.Size: Integer;\r\nbegin\r\n Result := FSize;\r\nend;\r\n\r\nfunction TJclIntegerSortedMap.SubMap(FromKey, ToKey: Integer): IJclIntegerSortedMap;\r\nvar\r\n FromIndex, ToIndex: Integer;\r\n NewMap: TJclIntegerSortedMap;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n NewMap := CreateEmptyContainer as TJclIntegerSortedMap;\r\n FromIndex := BinarySearch(FromKey);\r\n if (FromIndex = -1) or (KeysCompare(FEntries[FromIndex].Key, FromKey) < 0) then\r\n Inc(FromIndex);\r\n ToIndex := BinarySearch(ToKey);\r\n if (FromIndex >= 0) and (FromIndex <= ToIndex) then\r\n begin\r\n NewMap.SetCapacity(ToIndex - FromIndex + 1);\r\n NewMap.FSize := ToIndex - FromIndex + 1;\r\n while ToIndex >= FromIndex do\r\n begin\r\n NewMap.FEntries[ToIndex - FromIndex] := FEntries[ToIndex];\r\n Dec(ToIndex);\r\n end;\r\n end;\r\n Result := NewMap;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntegerSortedMap.TailMap(FromKey: Integer): IJclIntegerSortedMap;\r\nvar\r\n FromIndex, Index: Integer;\r\n NewMap: TJclIntegerSortedMap;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n NewMap := CreateEmptyContainer as TJclIntegerSortedMap;\r\n FromIndex := BinarySearch(FromKey);\r\n if (FromIndex = -1) or (KeysCompare(FEntries[FromIndex].Key, FromKey) < 0) then\r\n Inc(FromIndex);\r\n if (FromIndex >= 0) and (FromIndex < FSize) then\r\n begin\r\n NewMap.SetCapacity(FSize - FromIndex);\r\n NewMap.FSize := FSize - FromIndex;\r\n Index := FromIndex;\r\n while Index < FSize do\r\n begin\r\n NewMap.FEntries[Index - FromIndex] := FEntries[Index];\r\n Inc(Index);\r\n end;\r\n end;\r\n Result := NewMap;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntegerSortedMap.Values: IJclCollection;\r\nvar\r\n Index: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := TJclArrayList.Create(FSize, False);\r\n for Index := 0 to FSize - 1 do\r\n Result.Add(FEntries[Index].Value);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntegerSortedMap.CreateEmptyContainer: TJclAbstractContainerBase;\r\nbegin\r\n Result := TJclIntegerSortedMap.Create(FSize, False);\r\n AssignPropertiesTo(Result);\r\nend;\r\n\r\nfunction TJclIntegerSortedMap.FreeKey(var Key: Integer): Integer;\r\nbegin\r\n Result := Key;\r\n Key := 0;\r\nend;\r\n\r\nfunction TJclIntegerSortedMap.FreeValue(var Value: TObject): TObject;\r\nbegin\r\n if FOwnsValues then\r\n begin\r\n Result := nil;\r\n FreeAndNil(Value);\r\n end\r\n else\r\n begin\r\n Result := Value;\r\n Value := nil;\r\n end;\r\nend;\r\n\r\nfunction TJclIntegerSortedMap.GetOwnsValues: Boolean;\r\nbegin\r\n Result := FOwnsValues;\r\nend;\r\n\r\nfunction TJclIntegerSortedMap.KeysCompare(A, B: Integer): Integer;\r\nbegin\r\n Result := ItemsCompare(A, B);\r\nend;\r\n\r\nfunction TJclIntegerSortedMap.ValuesCompare(A, B: TObject): Integer;\r\nbegin\r\n Result := SimpleCompare(A, B);\r\nend;\r\n\r\n//=== { TJclCardinalSortedMap } ==============================================\r\n\r\nconstructor TJclCardinalSortedMap.Create(ACapacity: Integer; AOwnsValues: Boolean);\r\nbegin\r\n inherited Create();\r\n FOwnsValues := AOwnsValues;\r\n SetCapacity(ACapacity);\r\nend;\r\n\r\ndestructor TJclCardinalSortedMap.Destroy;\r\nbegin\r\n FReadOnly := False;\r\n Clear;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJclCardinalSortedMap.AssignDataTo(Dest: TJclAbstractContainerBase);\r\nvar\r\n MyDest: TJclCardinalSortedMap;\r\nbegin\r\n inherited AssignDataTo(Dest);\r\n if Dest is TJclCardinalSortedMap then\r\n begin\r\n MyDest := TJclCardinalSortedMap(Dest);\r\n MyDest.SetCapacity(FSize);\r\n MyDest.FEntries := FEntries;\r\n MyDest.FSize := FSize;\r\n end;\r\nend;\r\n\r\nfunction TJclCardinalSortedMap.BinarySearch(Key: Cardinal): Integer;\r\nvar\r\n HiPos, LoPos, CompPos: Integer;\r\n Comp: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n LoPos := 0;\r\n HiPos := FSize - 1;\r\n CompPos := (HiPos + LoPos) div 2;\r\n while HiPos >= LoPos do\r\n begin\r\n Comp := KeysCompare(FEntries[CompPos].Key, Key);\r\n if Comp < 0 then\r\n LoPos := CompPos + 1\r\n else\r\n if Comp > 0 then\r\n HiPos := CompPos - 1\r\n else\r\n begin\r\n HiPos := CompPos;\r\n LoPos := CompPos + 1;\r\n end;\r\n CompPos := (HiPos + LoPos) div 2;\r\n end;\r\n Result := HiPos;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclCardinalSortedMap.Clear;\r\nvar\r\n Index: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n for Index := 0 to FSize - 1 do\r\n begin\r\n FreeKey(FEntries[Index].Key);\r\n FreeValue(FEntries[Index].Value);\r\n end;\r\n FSize := 0;\r\n AutoPack;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclCardinalSortedMap.ContainsKey(Key: Cardinal): Boolean;\r\nvar\r\n Index: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Index := BinarySearch(Key);\r\n Result := (Index >= 0) and (KeysCompare(FEntries[Index].Key, Key) = 0);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclCardinalSortedMap.ContainsValue(Value: TObject): Boolean;\r\nvar\r\n Index: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n for Index := 0 to FSize - 1 do\r\n if ValuesCompare(FEntries[Index].Value, Value) = 0 then\r\n begin\r\n Result := True;\r\n Break;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclCardinalSortedMap.FirstKey: Cardinal;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := 0;\r\n if FSize > 0 then\r\n Result := FEntries[0].Key\r\n else\r\n if not FReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclCardinalSortedMap.Extract(Key: Cardinal): TObject;\r\nvar\r\n Index: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Index := BinarySearch(Key);\r\n if (Index >= 0) and (KeysCompare(FEntries[Index].Key, Key) = 0) then\r\n begin\r\n Result := FEntries[Index].Value;\r\n FEntries[Index].Value := nil;\r\n FreeKey(FEntries[Index].Key);\r\n if Index < (FSize - 1) then\r\n MoveArray(FEntries, Index + 1, Index, FSize - Index - 1);\r\n Dec(FSize);\r\n AutoPack;\r\n end\r\n else\r\n Result := nil;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclCardinalSortedMap.GetValue(Key: Cardinal): TObject;\r\nvar\r\n Index: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Index := BinarySearch(Key);\r\n Result := nil;\r\n if (Index >= 0) and (KeysCompare(FEntries[Index].Key, Key) = 0) then\r\n Result := FEntries[Index].Value\r\n else if not FReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclCardinalSortedMap.HeadMap(ToKey: Cardinal): IJclCardinalSortedMap;\r\nvar\r\n ToIndex: Integer;\r\n NewMap: TJclCardinalSortedMap;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n NewMap := CreateEmptyContainer as TJclCardinalSortedMap;\r\n ToIndex := BinarySearch(ToKey);\r\n if ToIndex >= 0 then\r\n begin\r\n NewMap.SetCapacity(ToIndex + 1);\r\n NewMap.FSize := ToIndex + 1;\r\n while ToIndex >= 0 do\r\n begin\r\n NewMap.FEntries[ToIndex] := FEntries[ToIndex];\r\n Dec(ToIndex);\r\n end;\r\n end;\r\n Result := NewMap;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclCardinalSortedMap.IsEmpty: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := FSize = 0;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclCardinalSortedMap.KeyOfValue(Value: TObject): Cardinal;\r\nvar\r\n Index: Integer;\r\n Found: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Found := False;\r\n Result := 0;\r\n for Index := 0 to FSize - 1 do\r\n if ValuesCompare(FEntries[Index].Value, Value) = 0 then\r\n begin\r\n Result := FEntries[Index].Key;\r\n Found := True;\r\n Break;\r\n end;\r\n\r\n if (not Found) and (not FReturnDefaultElements) then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclCardinalSortedMap.KeySet: IJclCardinalSet;\r\nvar\r\n Index: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := TJclCardinalArraySet.Create(FSize);\r\n for Index := 0 to FSize - 1 do\r\n Result.Add(FEntries[Index].Key);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclCardinalSortedMap.LastKey: Cardinal;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := 0;\r\n if FSize > 0 then\r\n Result := FEntries[FSize - 1].Key\r\n else\r\n if not FReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclCardinalSortedMap.MapEquals(const AMap: IJclCardinalMap): Boolean;\r\nvar\r\n It: IJclCardinalIterator;\r\n Index: Integer;\r\n AKey: Cardinal;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if AMap = nil then\r\n Exit;\r\n if FSize <> AMap.Size then\r\n Exit;\r\n It := AMap.KeySet.First;\r\n Index := 0;\r\n while It.HasNext do\r\n begin\r\n if Index >= FSize then\r\n Exit;\r\n AKey := It.Next;\r\n if ValuesCompare(AMap.GetValue(AKey), FEntries[Index].Value) <> 0 then\r\n Exit;\r\n Inc(Index);\r\n end;\r\n Result := True;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclCardinalSortedMap.InitializeArrayAfterMove(var List: TJclCardinalSortedMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\nbegin\r\n { Clean array }\r\n if FromIndex < ToIndex then\r\n begin\r\n if (ToIndex - FromIndex) < Count then\r\n Count := ToIndex - FromIndex;\r\n FillChar(List[FromIndex], Count * SizeOf(List[0]), 0);\r\n end\r\n else\r\n if FromIndex > ToIndex then\r\n begin\r\n if (FromIndex - ToIndex) < Count then\r\n FillChar(List[ToIndex + Count], (FromIndex - ToIndex) * SizeOf(List[0]), 0)\r\n else\r\n FillChar(List[FromIndex], Count * SizeOf(List[0]), 0);\r\n end;\r\nend;\r\n\r\nprocedure TJclCardinalSortedMap.MoveArray(var List: TJclCardinalSortedMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\nbegin\r\n if Count > 0 then\r\n begin\r\n Move(List[FromIndex], List[ToIndex], Count * SizeOf(List[0]));\r\n InitializeArrayAfterMove(List, FromIndex, ToIndex, Count);\r\n end;\r\nend;\r\n\r\nprocedure TJclCardinalSortedMap.PutAll(const AMap: IJclCardinalMap);\r\nvar\r\n It: IJclCardinalIterator;\r\n Key: Cardinal;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if AMap = nil then\r\n Exit;\r\n It := AMap.KeySet.First;\r\n while It.HasNext do\r\n begin\r\n Key := It.Next;\r\n PutValue(Key, AMap.GetValue(Key));\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclCardinalSortedMap.PutValue(Key: Cardinal; Value: TObject);\r\nvar\r\n Index: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FAllowDefaultElements or ((KeysCompare(Key, 0) <> 0) and (ValuesCompare(Value, nil) <> 0)) then\r\n begin\r\n Index := BinarySearch(Key);\r\n\r\n if (Index >= 0) and (KeysCompare(FEntries[Index].Key, Key) = 0) then\r\n begin\r\n FreeValue(FEntries[Index].Value);\r\n FEntries[Index].Value := Value;\r\n end\r\n else\r\n begin\r\n if FSize = FCapacity then\r\n AutoGrow;\r\n if FSize < FCapacity then\r\n begin\r\n Inc(Index);\r\n if (Index < FSize) and (KeysCompare(FEntries[Index].Key, Key) <> 0) then\r\n MoveArray(FEntries, Index, Index + 1, FSize - Index);\r\n FEntries[Index].Key := Key;\r\n FEntries[Index].Value := Value;\r\n Inc(FSize);\r\n end;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclCardinalSortedMap.Remove(Key: Cardinal): TObject;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := Extract(Key);\r\n Result := FreeValue(Result);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclCardinalSortedMap.SetCapacity(Value: Integer);\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FSize <= Value then\r\n begin\r\n SetLength(FEntries, Value);\r\n inherited SetCapacity(Value);\r\n end\r\n else\r\n raise EJclOperationNotSupportedError.Create;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclCardinalSortedMap.Size: Integer;\r\nbegin\r\n Result := FSize;\r\nend;\r\n\r\nfunction TJclCardinalSortedMap.SubMap(FromKey, ToKey: Cardinal): IJclCardinalSortedMap;\r\nvar\r\n FromIndex, ToIndex: Integer;\r\n NewMap: TJclCardinalSortedMap;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n NewMap := CreateEmptyContainer as TJclCardinalSortedMap;\r\n FromIndex := BinarySearch(FromKey);\r\n if (FromIndex = -1) or (KeysCompare(FEntries[FromIndex].Key, FromKey) < 0) then\r\n Inc(FromIndex);\r\n ToIndex := BinarySearch(ToKey);\r\n if (FromIndex >= 0) and (FromIndex <= ToIndex) then\r\n begin\r\n NewMap.SetCapacity(ToIndex - FromIndex + 1);\r\n NewMap.FSize := ToIndex - FromIndex + 1;\r\n while ToIndex >= FromIndex do\r\n begin\r\n NewMap.FEntries[ToIndex - FromIndex] := FEntries[ToIndex];\r\n Dec(ToIndex);\r\n end;\r\n end;\r\n Result := NewMap;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclCardinalSortedMap.TailMap(FromKey: Cardinal): IJclCardinalSortedMap;\r\nvar\r\n FromIndex, Index: Integer;\r\n NewMap: TJclCardinalSortedMap;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n NewMap := CreateEmptyContainer as TJclCardinalSortedMap;\r\n FromIndex := BinarySearch(FromKey);\r\n if (FromIndex = -1) or (KeysCompare(FEntries[FromIndex].Key, FromKey) < 0) then\r\n Inc(FromIndex);\r\n if (FromIndex >= 0) and (FromIndex < FSize) then\r\n begin\r\n NewMap.SetCapacity(FSize - FromIndex);\r\n NewMap.FSize := FSize - FromIndex;\r\n Index := FromIndex;\r\n while Index < FSize do\r\n begin\r\n NewMap.FEntries[Index - FromIndex] := FEntries[Index];\r\n Inc(Index);\r\n end;\r\n end;\r\n Result := NewMap;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclCardinalSortedMap.Values: IJclCollection;\r\nvar\r\n Index: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := TJclArrayList.Create(FSize, False);\r\n for Index := 0 to FSize - 1 do\r\n Result.Add(FEntries[Index].Value);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclCardinalSortedMap.CreateEmptyContainer: TJclAbstractContainerBase;\r\nbegin\r\n Result := TJclCardinalSortedMap.Create(FSize, False);\r\n AssignPropertiesTo(Result);\r\nend;\r\n\r\nfunction TJclCardinalSortedMap.FreeKey(var Key: Cardinal): Cardinal;\r\nbegin\r\n Result := Key;\r\n Key := 0;\r\nend;\r\n\r\nfunction TJclCardinalSortedMap.FreeValue(var Value: TObject): TObject;\r\nbegin\r\n if FOwnsValues then\r\n begin\r\n Result := nil;\r\n FreeAndNil(Value);\r\n end\r\n else\r\n begin\r\n Result := Value;\r\n Value := nil;\r\n end;\r\nend;\r\n\r\nfunction TJclCardinalSortedMap.GetOwnsValues: Boolean;\r\nbegin\r\n Result := FOwnsValues;\r\nend;\r\n\r\nfunction TJclCardinalSortedMap.KeysCompare(A, B: Cardinal): Integer;\r\nbegin\r\n Result := ItemsCompare(A, B);\r\nend;\r\n\r\nfunction TJclCardinalSortedMap.ValuesCompare(A, B: TObject): Integer;\r\nbegin\r\n Result := SimpleCompare(A, B);\r\nend;\r\n\r\n//=== { TJclInt64SortedMap } ==============================================\r\n\r\nconstructor TJclInt64SortedMap.Create(ACapacity: Integer; AOwnsValues: Boolean);\r\nbegin\r\n inherited Create();\r\n FOwnsValues := AOwnsValues;\r\n SetCapacity(ACapacity);\r\nend;\r\n\r\ndestructor TJclInt64SortedMap.Destroy;\r\nbegin\r\n FReadOnly := False;\r\n Clear;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJclInt64SortedMap.AssignDataTo(Dest: TJclAbstractContainerBase);\r\nvar\r\n MyDest: TJclInt64SortedMap;\r\nbegin\r\n inherited AssignDataTo(Dest);\r\n if Dest is TJclInt64SortedMap then\r\n begin\r\n MyDest := TJclInt64SortedMap(Dest);\r\n MyDest.SetCapacity(FSize);\r\n MyDest.FEntries := FEntries;\r\n MyDest.FSize := FSize;\r\n end;\r\nend;\r\n\r\nfunction TJclInt64SortedMap.BinarySearch(const Key: Int64): Integer;\r\nvar\r\n HiPos, LoPos, CompPos: Integer;\r\n Comp: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n LoPos := 0;\r\n HiPos := FSize - 1;\r\n CompPos := (HiPos + LoPos) div 2;\r\n while HiPos >= LoPos do\r\n begin\r\n Comp := KeysCompare(FEntries[CompPos].Key, Key);\r\n if Comp < 0 then\r\n LoPos := CompPos + 1\r\n else\r\n if Comp > 0 then\r\n HiPos := CompPos - 1\r\n else\r\n begin\r\n HiPos := CompPos;\r\n LoPos := CompPos + 1;\r\n end;\r\n CompPos := (HiPos + LoPos) div 2;\r\n end;\r\n Result := HiPos;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclInt64SortedMap.Clear;\r\nvar\r\n Index: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n for Index := 0 to FSize - 1 do\r\n begin\r\n FreeKey(FEntries[Index].Key);\r\n FreeValue(FEntries[Index].Value);\r\n end;\r\n FSize := 0;\r\n AutoPack;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclInt64SortedMap.ContainsKey(const Key: Int64): Boolean;\r\nvar\r\n Index: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Index := BinarySearch(Key);\r\n Result := (Index >= 0) and (KeysCompare(FEntries[Index].Key, Key) = 0);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclInt64SortedMap.ContainsValue(Value: TObject): Boolean;\r\nvar\r\n Index: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n for Index := 0 to FSize - 1 do\r\n if ValuesCompare(FEntries[Index].Value, Value) = 0 then\r\n begin\r\n Result := True;\r\n Break;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclInt64SortedMap.FirstKey: Int64;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := 0;\r\n if FSize > 0 then\r\n Result := FEntries[0].Key\r\n else\r\n if not FReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclInt64SortedMap.Extract(const Key: Int64): TObject;\r\nvar\r\n Index: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Index := BinarySearch(Key);\r\n if (Index >= 0) and (KeysCompare(FEntries[Index].Key, Key) = 0) then\r\n begin\r\n Result := FEntries[Index].Value;\r\n FEntries[Index].Value := nil;\r\n FreeKey(FEntries[Index].Key);\r\n if Index < (FSize - 1) then\r\n MoveArray(FEntries, Index + 1, Index, FSize - Index - 1);\r\n Dec(FSize);\r\n AutoPack;\r\n end\r\n else\r\n Result := nil;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclInt64SortedMap.GetValue(const Key: Int64): TObject;\r\nvar\r\n Index: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Index := BinarySearch(Key);\r\n Result := nil;\r\n if (Index >= 0) and (KeysCompare(FEntries[Index].Key, Key) = 0) then\r\n Result := FEntries[Index].Value\r\n else if not FReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclInt64SortedMap.HeadMap(const ToKey: Int64): IJclInt64SortedMap;\r\nvar\r\n ToIndex: Integer;\r\n NewMap: TJclInt64SortedMap;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n NewMap := CreateEmptyContainer as TJclInt64SortedMap;\r\n ToIndex := BinarySearch(ToKey);\r\n if ToIndex >= 0 then\r\n begin\r\n NewMap.SetCapacity(ToIndex + 1);\r\n NewMap.FSize := ToIndex + 1;\r\n while ToIndex >= 0 do\r\n begin\r\n NewMap.FEntries[ToIndex] := FEntries[ToIndex];\r\n Dec(ToIndex);\r\n end;\r\n end;\r\n Result := NewMap;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclInt64SortedMap.IsEmpty: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := FSize = 0;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclInt64SortedMap.KeyOfValue(Value: TObject): Int64;\r\nvar\r\n Index: Integer;\r\n Found: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Found := False;\r\n Result := 0;\r\n for Index := 0 to FSize - 1 do\r\n if ValuesCompare(FEntries[Index].Value, Value) = 0 then\r\n begin\r\n Result := FEntries[Index].Key;\r\n Found := True;\r\n Break;\r\n end;\r\n\r\n if (not Found) and (not FReturnDefaultElements) then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclInt64SortedMap.KeySet: IJclInt64Set;\r\nvar\r\n Index: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := TJclInt64ArraySet.Create(FSize);\r\n for Index := 0 to FSize - 1 do\r\n Result.Add(FEntries[Index].Key);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclInt64SortedMap.LastKey: Int64;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := 0;\r\n if FSize > 0 then\r\n Result := FEntries[FSize - 1].Key\r\n else\r\n if not FReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclInt64SortedMap.MapEquals(const AMap: IJclInt64Map): Boolean;\r\nvar\r\n It: IJclInt64Iterator;\r\n Index: Integer;\r\n AKey: Int64;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if AMap = nil then\r\n Exit;\r\n if FSize <> AMap.Size then\r\n Exit;\r\n It := AMap.KeySet.First;\r\n Index := 0;\r\n while It.HasNext do\r\n begin\r\n if Index >= FSize then\r\n Exit;\r\n AKey := It.Next;\r\n if ValuesCompare(AMap.GetValue(AKey), FEntries[Index].Value) <> 0 then\r\n Exit;\r\n Inc(Index);\r\n end;\r\n Result := True;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclInt64SortedMap.InitializeArrayAfterMove(var List: TJclInt64SortedMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\nbegin\r\n { Clean array }\r\n if FromIndex < ToIndex then\r\n begin\r\n if (ToIndex - FromIndex) < Count then\r\n Count := ToIndex - FromIndex;\r\n FillChar(List[FromIndex], Count * SizeOf(List[0]), 0);\r\n end\r\n else\r\n if FromIndex > ToIndex then\r\n begin\r\n if (FromIndex - ToIndex) < Count then\r\n FillChar(List[ToIndex + Count], (FromIndex - ToIndex) * SizeOf(List[0]), 0)\r\n else\r\n FillChar(List[FromIndex], Count * SizeOf(List[0]), 0);\r\n end;\r\nend;\r\n\r\nprocedure TJclInt64SortedMap.MoveArray(var List: TJclInt64SortedMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\nbegin\r\n if Count > 0 then\r\n begin\r\n Move(List[FromIndex], List[ToIndex], Count * SizeOf(List[0]));\r\n InitializeArrayAfterMove(List, FromIndex, ToIndex, Count);\r\n end;\r\nend;\r\n\r\nprocedure TJclInt64SortedMap.PutAll(const AMap: IJclInt64Map);\r\nvar\r\n It: IJclInt64Iterator;\r\n Key: Int64;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if AMap = nil then\r\n Exit;\r\n It := AMap.KeySet.First;\r\n while It.HasNext do\r\n begin\r\n Key := It.Next;\r\n PutValue(Key, AMap.GetValue(Key));\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclInt64SortedMap.PutValue(const Key: Int64; Value: TObject);\r\nvar\r\n Index: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FAllowDefaultElements or ((KeysCompare(Key, 0) <> 0) and (ValuesCompare(Value, nil) <> 0)) then\r\n begin\r\n Index := BinarySearch(Key);\r\n\r\n if (Index >= 0) and (KeysCompare(FEntries[Index].Key, Key) = 0) then\r\n begin\r\n FreeValue(FEntries[Index].Value);\r\n FEntries[Index].Value := Value;\r\n end\r\n else\r\n begin\r\n if FSize = FCapacity then\r\n AutoGrow;\r\n if FSize < FCapacity then\r\n begin\r\n Inc(Index);\r\n if (Index < FSize) and (KeysCompare(FEntries[Index].Key, Key) <> 0) then\r\n MoveArray(FEntries, Index, Index + 1, FSize - Index);\r\n FEntries[Index].Key := Key;\r\n FEntries[Index].Value := Value;\r\n Inc(FSize);\r\n end;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclInt64SortedMap.Remove(const Key: Int64): TObject;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := Extract(Key);\r\n Result := FreeValue(Result);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclInt64SortedMap.SetCapacity(Value: Integer);\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FSize <= Value then\r\n begin\r\n SetLength(FEntries, Value);\r\n inherited SetCapacity(Value);\r\n end\r\n else\r\n raise EJclOperationNotSupportedError.Create;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclInt64SortedMap.Size: Integer;\r\nbegin\r\n Result := FSize;\r\nend;\r\n\r\nfunction TJclInt64SortedMap.SubMap(const FromKey, ToKey: Int64): IJclInt64SortedMap;\r\nvar\r\n FromIndex, ToIndex: Integer;\r\n NewMap: TJclInt64SortedMap;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n NewMap := CreateEmptyContainer as TJclInt64SortedMap;\r\n FromIndex := BinarySearch(FromKey);\r\n if (FromIndex = -1) or (KeysCompare(FEntries[FromIndex].Key, FromKey) < 0) then\r\n Inc(FromIndex);\r\n ToIndex := BinarySearch(ToKey);\r\n if (FromIndex >= 0) and (FromIndex <= ToIndex) then\r\n begin\r\n NewMap.SetCapacity(ToIndex - FromIndex + 1);\r\n NewMap.FSize := ToIndex - FromIndex + 1;\r\n while ToIndex >= FromIndex do\r\n begin\r\n NewMap.FEntries[ToIndex - FromIndex] := FEntries[ToIndex];\r\n Dec(ToIndex);\r\n end;\r\n end;\r\n Result := NewMap;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclInt64SortedMap.TailMap(const FromKey: Int64): IJclInt64SortedMap;\r\nvar\r\n FromIndex, Index: Integer;\r\n NewMap: TJclInt64SortedMap;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n NewMap := CreateEmptyContainer as TJclInt64SortedMap;\r\n FromIndex := BinarySearch(FromKey);\r\n if (FromIndex = -1) or (KeysCompare(FEntries[FromIndex].Key, FromKey) < 0) then\r\n Inc(FromIndex);\r\n if (FromIndex >= 0) and (FromIndex < FSize) then\r\n begin\r\n NewMap.SetCapacity(FSize - FromIndex);\r\n NewMap.FSize := FSize - FromIndex;\r\n Index := FromIndex;\r\n while Index < FSize do\r\n begin\r\n NewMap.FEntries[Index - FromIndex] := FEntries[Index];\r\n Inc(Index);\r\n end;\r\n end;\r\n Result := NewMap;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclInt64SortedMap.Values: IJclCollection;\r\nvar\r\n Index: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := TJclArrayList.Create(FSize, False);\r\n for Index := 0 to FSize - 1 do\r\n Result.Add(FEntries[Index].Value);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclInt64SortedMap.CreateEmptyContainer: TJclAbstractContainerBase;\r\nbegin\r\n Result := TJclInt64SortedMap.Create(FSize, False);\r\n AssignPropertiesTo(Result);\r\nend;\r\n\r\nfunction TJclInt64SortedMap.FreeKey(var Key: Int64): Int64;\r\nbegin\r\n Result := Key;\r\n Key := 0;\r\nend;\r\n\r\nfunction TJclInt64SortedMap.FreeValue(var Value: TObject): TObject;\r\nbegin\r\n if FOwnsValues then\r\n begin\r\n Result := nil;\r\n FreeAndNil(Value);\r\n end\r\n else\r\n begin\r\n Result := Value;\r\n Value := nil;\r\n end;\r\nend;\r\n\r\nfunction TJclInt64SortedMap.GetOwnsValues: Boolean;\r\nbegin\r\n Result := FOwnsValues;\r\nend;\r\n\r\nfunction TJclInt64SortedMap.KeysCompare(const A, B: Int64): Integer;\r\nbegin\r\n Result := ItemsCompare(A, B);\r\nend;\r\n\r\nfunction TJclInt64SortedMap.ValuesCompare(A, B: TObject): Integer;\r\nbegin\r\n Result := SimpleCompare(A, B);\r\nend;\r\n\r\n//=== { TJclPtrSortedMap } ==============================================\r\n\r\nconstructor TJclPtrSortedMap.Create(ACapacity: Integer; AOwnsValues: Boolean);\r\nbegin\r\n inherited Create();\r\n FOwnsValues := AOwnsValues;\r\n SetCapacity(ACapacity);\r\nend;\r\n\r\ndestructor TJclPtrSortedMap.Destroy;\r\nbegin\r\n FReadOnly := False;\r\n Clear;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJclPtrSortedMap.AssignDataTo(Dest: TJclAbstractContainerBase);\r\nvar\r\n MyDest: TJclPtrSortedMap;\r\nbegin\r\n inherited AssignDataTo(Dest);\r\n if Dest is TJclPtrSortedMap then\r\n begin\r\n MyDest := TJclPtrSortedMap(Dest);\r\n MyDest.SetCapacity(FSize);\r\n MyDest.FEntries := FEntries;\r\n MyDest.FSize := FSize;\r\n end;\r\nend;\r\n\r\nfunction TJclPtrSortedMap.BinarySearch(Key: Pointer): Integer;\r\nvar\r\n HiPos, LoPos, CompPos: Integer;\r\n Comp: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n LoPos := 0;\r\n HiPos := FSize - 1;\r\n CompPos := (HiPos + LoPos) div 2;\r\n while HiPos >= LoPos do\r\n begin\r\n Comp := KeysCompare(FEntries[CompPos].Key, Key);\r\n if Comp < 0 then\r\n LoPos := CompPos + 1\r\n else\r\n if Comp > 0 then\r\n HiPos := CompPos - 1\r\n else\r\n begin\r\n HiPos := CompPos;\r\n LoPos := CompPos + 1;\r\n end;\r\n CompPos := (HiPos + LoPos) div 2;\r\n end;\r\n Result := HiPos;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclPtrSortedMap.Clear;\r\nvar\r\n Index: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n for Index := 0 to FSize - 1 do\r\n begin\r\n FreeKey(FEntries[Index].Key);\r\n FreeValue(FEntries[Index].Value);\r\n end;\r\n FSize := 0;\r\n AutoPack;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclPtrSortedMap.ContainsKey(Key: Pointer): Boolean;\r\nvar\r\n Index: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Index := BinarySearch(Key);\r\n Result := (Index >= 0) and (KeysCompare(FEntries[Index].Key, Key) = 0);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclPtrSortedMap.ContainsValue(Value: TObject): Boolean;\r\nvar\r\n Index: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n for Index := 0 to FSize - 1 do\r\n if ValuesCompare(FEntries[Index].Value, Value) = 0 then\r\n begin\r\n Result := True;\r\n Break;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclPtrSortedMap.FirstKey: Pointer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := nil;\r\n if FSize > 0 then\r\n Result := FEntries[0].Key\r\n else\r\n if not FReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclPtrSortedMap.Extract(Key: Pointer): TObject;\r\nvar\r\n Index: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Index := BinarySearch(Key);\r\n if (Index >= 0) and (KeysCompare(FEntries[Index].Key, Key) = 0) then\r\n begin\r\n Result := FEntries[Index].Value;\r\n FEntries[Index].Value := nil;\r\n FreeKey(FEntries[Index].Key);\r\n if Index < (FSize - 1) then\r\n MoveArray(FEntries, Index + 1, Index, FSize - Index - 1);\r\n Dec(FSize);\r\n AutoPack;\r\n end\r\n else\r\n Result := nil;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclPtrSortedMap.GetValue(Key: Pointer): TObject;\r\nvar\r\n Index: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Index := BinarySearch(Key);\r\n Result := nil;\r\n if (Index >= 0) and (KeysCompare(FEntries[Index].Key, Key) = 0) then\r\n Result := FEntries[Index].Value\r\n else if not FReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclPtrSortedMap.HeadMap(ToKey: Pointer): IJclPtrSortedMap;\r\nvar\r\n ToIndex: Integer;\r\n NewMap: TJclPtrSortedMap;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n NewMap := CreateEmptyContainer as TJclPtrSortedMap;\r\n ToIndex := BinarySearch(ToKey);\r\n if ToIndex >= 0 then\r\n begin\r\n NewMap.SetCapacity(ToIndex + 1);\r\n NewMap.FSize := ToIndex + 1;\r\n while ToIndex >= 0 do\r\n begin\r\n NewMap.FEntries[ToIndex] := FEntries[ToIndex];\r\n Dec(ToIndex);\r\n end;\r\n end;\r\n Result := NewMap;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclPtrSortedMap.IsEmpty: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := FSize = 0;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclPtrSortedMap.KeyOfValue(Value: TObject): Pointer;\r\nvar\r\n Index: Integer;\r\n Found: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Found := False;\r\n Result := nil;\r\n for Index := 0 to FSize - 1 do\r\n if ValuesCompare(FEntries[Index].Value, Value) = 0 then\r\n begin\r\n Result := FEntries[Index].Key;\r\n Found := True;\r\n Break;\r\n end;\r\n\r\n if (not Found) and (not FReturnDefaultElements) then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclPtrSortedMap.KeySet: IJclPtrSet;\r\nvar\r\n Index: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := TJclPtrArraySet.Create(FSize);\r\n for Index := 0 to FSize - 1 do\r\n Result.Add(FEntries[Index].Key);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclPtrSortedMap.LastKey: Pointer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := nil;\r\n if FSize > 0 then\r\n Result := FEntries[FSize - 1].Key\r\n else\r\n if not FReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclPtrSortedMap.MapEquals(const AMap: IJclPtrMap): Boolean;\r\nvar\r\n It: IJclPtrIterator;\r\n Index: Integer;\r\n AKey: Pointer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if AMap = nil then\r\n Exit;\r\n if FSize <> AMap.Size then\r\n Exit;\r\n It := AMap.KeySet.First;\r\n Index := 0;\r\n while It.HasNext do\r\n begin\r\n if Index >= FSize then\r\n Exit;\r\n AKey := It.Next;\r\n if ValuesCompare(AMap.GetValue(AKey), FEntries[Index].Value) <> 0 then\r\n Exit;\r\n Inc(Index);\r\n end;\r\n Result := True;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclPtrSortedMap.InitializeArrayAfterMove(var List: TJclPtrSortedMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\nbegin\r\n { Clean array }\r\n if FromIndex < ToIndex then\r\n begin\r\n if (ToIndex - FromIndex) < Count then\r\n Count := ToIndex - FromIndex;\r\n FillChar(List[FromIndex], Count * SizeOf(List[0]), 0);\r\n end\r\n else\r\n if FromIndex > ToIndex then\r\n begin\r\n if (FromIndex - ToIndex) < Count then\r\n FillChar(List[ToIndex + Count], (FromIndex - ToIndex) * SizeOf(List[0]), 0)\r\n else\r\n FillChar(List[FromIndex], Count * SizeOf(List[0]), 0);\r\n end;\r\nend;\r\n\r\nprocedure TJclPtrSortedMap.MoveArray(var List: TJclPtrSortedMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\nbegin\r\n if Count > 0 then\r\n begin\r\n Move(List[FromIndex], List[ToIndex], Count * SizeOf(List[0]));\r\n InitializeArrayAfterMove(List, FromIndex, ToIndex, Count);\r\n end;\r\nend;\r\n\r\nprocedure TJclPtrSortedMap.PutAll(const AMap: IJclPtrMap);\r\nvar\r\n It: IJclPtrIterator;\r\n Key: Pointer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if AMap = nil then\r\n Exit;\r\n It := AMap.KeySet.First;\r\n while It.HasNext do\r\n begin\r\n Key := It.Next;\r\n PutValue(Key, AMap.GetValue(Key));\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclPtrSortedMap.PutValue(Key: Pointer; Value: TObject);\r\nvar\r\n Index: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FAllowDefaultElements or ((KeysCompare(Key, nil) <> 0) and (ValuesCompare(Value, nil) <> 0)) then\r\n begin\r\n Index := BinarySearch(Key);\r\n\r\n if (Index >= 0) and (KeysCompare(FEntries[Index].Key, Key) = 0) then\r\n begin\r\n FreeValue(FEntries[Index].Value);\r\n FEntries[Index].Value := Value;\r\n end\r\n else\r\n begin\r\n if FSize = FCapacity then\r\n AutoGrow;\r\n if FSize < FCapacity then\r\n begin\r\n Inc(Index);\r\n if (Index < FSize) and (KeysCompare(FEntries[Index].Key, Key) <> 0) then\r\n MoveArray(FEntries, Index, Index + 1, FSize - Index);\r\n FEntries[Index].Key := Key;\r\n FEntries[Index].Value := Value;\r\n Inc(FSize);\r\n end;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclPtrSortedMap.Remove(Key: Pointer): TObject;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := Extract(Key);\r\n Result := FreeValue(Result);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclPtrSortedMap.SetCapacity(Value: Integer);\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FSize <= Value then\r\n begin\r\n SetLength(FEntries, Value);\r\n inherited SetCapacity(Value);\r\n end\r\n else\r\n raise EJclOperationNotSupportedError.Create;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclPtrSortedMap.Size: Integer;\r\nbegin\r\n Result := FSize;\r\nend;\r\n\r\nfunction TJclPtrSortedMap.SubMap(FromKey, ToKey: Pointer): IJclPtrSortedMap;\r\nvar\r\n FromIndex, ToIndex: Integer;\r\n NewMap: TJclPtrSortedMap;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n NewMap := CreateEmptyContainer as TJclPtrSortedMap;\r\n FromIndex := BinarySearch(FromKey);\r\n if (FromIndex = -1) or (KeysCompare(FEntries[FromIndex].Key, FromKey) < 0) then\r\n Inc(FromIndex);\r\n ToIndex := BinarySearch(ToKey);\r\n if (FromIndex >= 0) and (FromIndex <= ToIndex) then\r\n begin\r\n NewMap.SetCapacity(ToIndex - FromIndex + 1);\r\n NewMap.FSize := ToIndex - FromIndex + 1;\r\n while ToIndex >= FromIndex do\r\n begin\r\n NewMap.FEntries[ToIndex - FromIndex] := FEntries[ToIndex];\r\n Dec(ToIndex);\r\n end;\r\n end;\r\n Result := NewMap;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclPtrSortedMap.TailMap(FromKey: Pointer): IJclPtrSortedMap;\r\nvar\r\n FromIndex, Index: Integer;\r\n NewMap: TJclPtrSortedMap;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n NewMap := CreateEmptyContainer as TJclPtrSortedMap;\r\n FromIndex := BinarySearch(FromKey);\r\n if (FromIndex = -1) or (KeysCompare(FEntries[FromIndex].Key, FromKey) < 0) then\r\n Inc(FromIndex);\r\n if (FromIndex >= 0) and (FromIndex < FSize) then\r\n begin\r\n NewMap.SetCapacity(FSize - FromIndex);\r\n NewMap.FSize := FSize - FromIndex;\r\n Index := FromIndex;\r\n while Index < FSize do\r\n begin\r\n NewMap.FEntries[Index - FromIndex] := FEntries[Index];\r\n Inc(Index);\r\n end;\r\n end;\r\n Result := NewMap;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclPtrSortedMap.Values: IJclCollection;\r\nvar\r\n Index: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := TJclArrayList.Create(FSize, False);\r\n for Index := 0 to FSize - 1 do\r\n Result.Add(FEntries[Index].Value);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclPtrSortedMap.CreateEmptyContainer: TJclAbstractContainerBase;\r\nbegin\r\n Result := TJclPtrSortedMap.Create(FSize, False);\r\n AssignPropertiesTo(Result);\r\nend;\r\n\r\nfunction TJclPtrSortedMap.FreeKey(var Key: Pointer): Pointer;\r\nbegin\r\n Result := Key;\r\n Key := nil;\r\nend;\r\n\r\nfunction TJclPtrSortedMap.FreeValue(var Value: TObject): TObject;\r\nbegin\r\n if FOwnsValues then\r\n begin\r\n Result := nil;\r\n FreeAndNil(Value);\r\n end\r\n else\r\n begin\r\n Result := Value;\r\n Value := nil;\r\n end;\r\nend;\r\n\r\nfunction TJclPtrSortedMap.GetOwnsValues: Boolean;\r\nbegin\r\n Result := FOwnsValues;\r\nend;\r\n\r\nfunction TJclPtrSortedMap.KeysCompare(A, B: Pointer): Integer;\r\nbegin\r\n Result := ItemsCompare(A, B);\r\nend;\r\n\r\nfunction TJclPtrSortedMap.ValuesCompare(A, B: TObject): Integer;\r\nbegin\r\n Result := SimpleCompare(A, B);\r\nend;\r\n\r\n//=== { TJclSortedMap } ==============================================\r\n\r\nconstructor TJclSortedMap.Create(ACapacity: Integer; AOwnsValues: Boolean; AOwnsKeys: Boolean);\r\nbegin\r\n inherited Create();\r\n FOwnsKeys := AOwnsKeys;\r\n FOwnsValues := AOwnsValues;\r\n SetCapacity(ACapacity);\r\nend;\r\n\r\ndestructor TJclSortedMap.Destroy;\r\nbegin\r\n FReadOnly := False;\r\n Clear;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJclSortedMap.AssignDataTo(Dest: TJclAbstractContainerBase);\r\nvar\r\n MyDest: TJclSortedMap;\r\nbegin\r\n inherited AssignDataTo(Dest);\r\n if Dest is TJclSortedMap then\r\n begin\r\n MyDest := TJclSortedMap(Dest);\r\n MyDest.SetCapacity(FSize);\r\n MyDest.FEntries := FEntries;\r\n MyDest.FSize := FSize;\r\n end;\r\nend;\r\n\r\nfunction TJclSortedMap.BinarySearch(Key: TObject): Integer;\r\nvar\r\n HiPos, LoPos, CompPos: Integer;\r\n Comp: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n LoPos := 0;\r\n HiPos := FSize - 1;\r\n CompPos := (HiPos + LoPos) div 2;\r\n while HiPos >= LoPos do\r\n begin\r\n Comp := KeysCompare(FEntries[CompPos].Key, Key);\r\n if Comp < 0 then\r\n LoPos := CompPos + 1\r\n else\r\n if Comp > 0 then\r\n HiPos := CompPos - 1\r\n else\r\n begin\r\n HiPos := CompPos;\r\n LoPos := CompPos + 1;\r\n end;\r\n CompPos := (HiPos + LoPos) div 2;\r\n end;\r\n Result := HiPos;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclSortedMap.Clear;\r\nvar\r\n Index: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n for Index := 0 to FSize - 1 do\r\n begin\r\n FreeKey(FEntries[Index].Key);\r\n FreeValue(FEntries[Index].Value);\r\n end;\r\n FSize := 0;\r\n AutoPack;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSortedMap.ContainsKey(Key: TObject): Boolean;\r\nvar\r\n Index: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Index := BinarySearch(Key);\r\n Result := (Index >= 0) and (KeysCompare(FEntries[Index].Key, Key) = 0);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSortedMap.ContainsValue(Value: TObject): Boolean;\r\nvar\r\n Index: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n for Index := 0 to FSize - 1 do\r\n if ValuesCompare(FEntries[Index].Value, Value) = 0 then\r\n begin\r\n Result := True;\r\n Break;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSortedMap.FirstKey: TObject;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := nil;\r\n if FSize > 0 then\r\n Result := FEntries[0].Key\r\n else\r\n if not FReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSortedMap.Extract(Key: TObject): TObject;\r\nvar\r\n Index: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Index := BinarySearch(Key);\r\n if (Index >= 0) and (KeysCompare(FEntries[Index].Key, Key) = 0) then\r\n begin\r\n Result := FEntries[Index].Value;\r\n FEntries[Index].Value := nil;\r\n FreeKey(FEntries[Index].Key);\r\n if Index < (FSize - 1) then\r\n MoveArray(FEntries, Index + 1, Index, FSize - Index - 1);\r\n Dec(FSize);\r\n AutoPack;\r\n end\r\n else\r\n Result := nil;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSortedMap.GetValue(Key: TObject): TObject;\r\nvar\r\n Index: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Index := BinarySearch(Key);\r\n Result := nil;\r\n if (Index >= 0) and (KeysCompare(FEntries[Index].Key, Key) = 0) then\r\n Result := FEntries[Index].Value\r\n else if not FReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSortedMap.HeadMap(ToKey: TObject): IJclSortedMap;\r\nvar\r\n ToIndex: Integer;\r\n NewMap: TJclSortedMap;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n NewMap := CreateEmptyContainer as TJclSortedMap;\r\n ToIndex := BinarySearch(ToKey);\r\n if ToIndex >= 0 then\r\n begin\r\n NewMap.SetCapacity(ToIndex + 1);\r\n NewMap.FSize := ToIndex + 1;\r\n while ToIndex >= 0 do\r\n begin\r\n NewMap.FEntries[ToIndex] := FEntries[ToIndex];\r\n Dec(ToIndex);\r\n end;\r\n end;\r\n Result := NewMap;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSortedMap.IsEmpty: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := FSize = 0;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSortedMap.KeyOfValue(Value: TObject): TObject;\r\nvar\r\n Index: Integer;\r\n Found: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Found := False;\r\n Result := nil;\r\n for Index := 0 to FSize - 1 do\r\n if ValuesCompare(FEntries[Index].Value, Value) = 0 then\r\n begin\r\n Result := FEntries[Index].Key;\r\n Found := True;\r\n Break;\r\n end;\r\n\r\n if (not Found) and (not FReturnDefaultElements) then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSortedMap.KeySet: IJclSet;\r\nvar\r\n Index: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := TJclArraySet.Create(FSize, False);\r\n for Index := 0 to FSize - 1 do\r\n Result.Add(FEntries[Index].Key);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSortedMap.LastKey: TObject;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := nil;\r\n if FSize > 0 then\r\n Result := FEntries[FSize - 1].Key\r\n else\r\n if not FReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSortedMap.MapEquals(const AMap: IJclMap): Boolean;\r\nvar\r\n It: IJclIterator;\r\n Index: Integer;\r\n AKey: TObject;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if AMap = nil then\r\n Exit;\r\n if FSize <> AMap.Size then\r\n Exit;\r\n It := AMap.KeySet.First;\r\n Index := 0;\r\n while It.HasNext do\r\n begin\r\n if Index >= FSize then\r\n Exit;\r\n AKey := It.Next;\r\n if ValuesCompare(AMap.GetValue(AKey), FEntries[Index].Value) <> 0 then\r\n Exit;\r\n Inc(Index);\r\n end;\r\n Result := True;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclSortedMap.InitializeArrayAfterMove(var List: TJclSortedMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\nbegin\r\n { Clean array }\r\n if FromIndex < ToIndex then\r\n begin\r\n if (ToIndex - FromIndex) < Count then\r\n Count := ToIndex - FromIndex;\r\n FillChar(List[FromIndex], Count * SizeOf(List[0]), 0);\r\n end\r\n else\r\n if FromIndex > ToIndex then\r\n begin\r\n if (FromIndex - ToIndex) < Count then\r\n FillChar(List[ToIndex + Count], (FromIndex - ToIndex) * SizeOf(List[0]), 0)\r\n else\r\n FillChar(List[FromIndex], Count * SizeOf(List[0]), 0);\r\n end;\r\nend;\r\n\r\nprocedure TJclSortedMap.MoveArray(var List: TJclSortedMapEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\nbegin\r\n if Count > 0 then\r\n begin\r\n Move(List[FromIndex], List[ToIndex], Count * SizeOf(List[0]));\r\n InitializeArrayAfterMove(List, FromIndex, ToIndex, Count);\r\n end;\r\nend;\r\n\r\nprocedure TJclSortedMap.PutAll(const AMap: IJclMap);\r\nvar\r\n It: IJclIterator;\r\n Key: TObject;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if AMap = nil then\r\n Exit;\r\n It := AMap.KeySet.First;\r\n while It.HasNext do\r\n begin\r\n Key := It.Next;\r\n PutValue(Key, AMap.GetValue(Key));\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclSortedMap.PutValue(Key: TObject; Value: TObject);\r\nvar\r\n Index: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FAllowDefaultElements or ((KeysCompare(Key, nil) <> 0) and (ValuesCompare(Value, nil) <> 0)) then\r\n begin\r\n Index := BinarySearch(Key);\r\n\r\n if (Index >= 0) and (KeysCompare(FEntries[Index].Key, Key) = 0) then\r\n begin\r\n FreeValue(FEntries[Index].Value);\r\n FEntries[Index].Value := Value;\r\n end\r\n else\r\n begin\r\n if FSize = FCapacity then\r\n AutoGrow;\r\n if FSize < FCapacity then\r\n begin\r\n Inc(Index);\r\n if (Index < FSize) and (KeysCompare(FEntries[Index].Key, Key) <> 0) then\r\n MoveArray(FEntries, Index, Index + 1, FSize - Index);\r\n FEntries[Index].Key := Key;\r\n FEntries[Index].Value := Value;\r\n Inc(FSize);\r\n end;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSortedMap.Remove(Key: TObject): TObject;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := Extract(Key);\r\n Result := FreeValue(Result);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclSortedMap.SetCapacity(Value: Integer);\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FSize <= Value then\r\n begin\r\n SetLength(FEntries, Value);\r\n inherited SetCapacity(Value);\r\n end\r\n else\r\n raise EJclOperationNotSupportedError.Create;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSortedMap.Size: Integer;\r\nbegin\r\n Result := FSize;\r\nend;\r\n\r\nfunction TJclSortedMap.SubMap(FromKey, ToKey: TObject): IJclSortedMap;\r\nvar\r\n FromIndex, ToIndex: Integer;\r\n NewMap: TJclSortedMap;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n NewMap := CreateEmptyContainer as TJclSortedMap;\r\n FromIndex := BinarySearch(FromKey);\r\n if (FromIndex = -1) or (KeysCompare(FEntries[FromIndex].Key, FromKey) < 0) then\r\n Inc(FromIndex);\r\n ToIndex := BinarySearch(ToKey);\r\n if (FromIndex >= 0) and (FromIndex <= ToIndex) then\r\n begin\r\n NewMap.SetCapacity(ToIndex - FromIndex + 1);\r\n NewMap.FSize := ToIndex - FromIndex + 1;\r\n while ToIndex >= FromIndex do\r\n begin\r\n NewMap.FEntries[ToIndex - FromIndex] := FEntries[ToIndex];\r\n Dec(ToIndex);\r\n end;\r\n end;\r\n Result := NewMap;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSortedMap.TailMap(FromKey: TObject): IJclSortedMap;\r\nvar\r\n FromIndex, Index: Integer;\r\n NewMap: TJclSortedMap;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n NewMap := CreateEmptyContainer as TJclSortedMap;\r\n FromIndex := BinarySearch(FromKey);\r\n if (FromIndex = -1) or (KeysCompare(FEntries[FromIndex].Key, FromKey) < 0) then\r\n Inc(FromIndex);\r\n if (FromIndex >= 0) and (FromIndex < FSize) then\r\n begin\r\n NewMap.SetCapacity(FSize - FromIndex);\r\n NewMap.FSize := FSize - FromIndex;\r\n Index := FromIndex;\r\n while Index < FSize do\r\n begin\r\n NewMap.FEntries[Index - FromIndex] := FEntries[Index];\r\n Inc(Index);\r\n end;\r\n end;\r\n Result := NewMap;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSortedMap.Values: IJclCollection;\r\nvar\r\n Index: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := TJclArrayList.Create(FSize, False);\r\n for Index := 0 to FSize - 1 do\r\n Result.Add(FEntries[Index].Value);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSortedMap.CreateEmptyContainer: TJclAbstractContainerBase;\r\nbegin\r\n Result := TJclSortedMap.Create(FSize, False, False);\r\n AssignPropertiesTo(Result);\r\nend;\r\n\r\nfunction TJclSortedMap.FreeKey(var Key: TObject): TObject;\r\nbegin\r\n if FOwnsKeys then\r\n begin\r\n Result := nil;\r\n FreeAndNil(Key);\r\n end\r\n else\r\n begin\r\n Result := Key;\r\n Key := nil;\r\n end;\r\nend;\r\n\r\nfunction TJclSortedMap.FreeValue(var Value: TObject): TObject;\r\nbegin\r\n if FOwnsValues then\r\n begin\r\n Result := nil;\r\n FreeAndNil(Value);\r\n end\r\n else\r\n begin\r\n Result := Value;\r\n Value := nil;\r\n end;\r\nend;\r\n\r\nfunction TJclSortedMap.GetOwnsKeys: Boolean;\r\nbegin\r\n Result := FOwnsKeys;\r\nend;\r\n\r\nfunction TJclSortedMap.GetOwnsValues: Boolean;\r\nbegin\r\n Result := FOwnsValues;\r\nend;\r\n\r\nfunction TJclSortedMap.KeysCompare(A, B: TObject): Integer;\r\nbegin\r\n Result := SimpleCompare(A, B);\r\nend;\r\n\r\nfunction TJclSortedMap.ValuesCompare(A, B: TObject): Integer;\r\nbegin\r\n Result := SimpleCompare(A, B);\r\nend;\r\n\r\n\r\n\r\n{$IFDEF SUPPORTS_GENERICS}\r\n//DOM-IGNORE-BEGIN\r\n\r\n//=== { TJclSortedMap } ==============================================\r\n\r\nconstructor TJclSortedMap.Create(ACapacity: Integer; AOwnsValues: Boolean; AOwnsKeys: Boolean);\r\nbegin\r\n inherited Create();\r\n\r\n FOwnsKeys := AOwnsKeys;\r\n FOwnsValues := AOwnsValues;\r\n SetCapacity(ACapacity);\r\nend;\r\n\r\ndestructor TJclSortedMap.Destroy;\r\nbegin\r\n FReadOnly := False;\r\n Clear;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJclSortedMap.AssignDataTo(Dest: TJclAbstractContainerBase);\r\nvar\r\n MyDest: TJclSortedMap;\r\nbegin\r\n inherited AssignDataTo(Dest);\r\n if Dest is TJclSortedMap then\r\n begin\r\n MyDest := TJclSortedMap(Dest);\r\n MyDest.SetCapacity(FSize);\r\n MyDest.FEntries := FEntries;\r\n MyDest.FSize := FSize;\r\n end;\r\nend;\r\n\r\nfunction TJclSortedMap.BinarySearch(const Key: TKey): Integer;\r\nvar\r\n HiPos, LoPos, CompPos: Integer;\r\n Comp: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n LoPos := 0;\r\n HiPos := FSize - 1;\r\n CompPos := (HiPos + LoPos) div 2;\r\n while HiPos >= LoPos do\r\n begin\r\n Comp := KeysCompare(FEntries[CompPos].Key, Key);\r\n if Comp < 0 then\r\n LoPos := CompPos + 1\r\n else\r\n if Comp > 0 then\r\n HiPos := CompPos - 1\r\n else\r\n begin\r\n HiPos := CompPos;\r\n LoPos := CompPos + 1;\r\n end;\r\n CompPos := (HiPos + LoPos) div 2;\r\n end;\r\n Result := HiPos;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclSortedMap.Clear;\r\nvar\r\n Index: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n for Index := 0 to FSize - 1 do\r\n begin\r\n FreeKey(FEntries[Index].Key);\r\n FreeValue(FEntries[Index].Value);\r\n end;\r\n FSize := 0;\r\n AutoPack;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSortedMap.ContainsKey(const Key: TKey): Boolean;\r\nvar\r\n Index: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Index := BinarySearch(Key);\r\n Result := (Index >= 0) and (KeysCompare(FEntries[Index].Key, Key) = 0);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSortedMap.ContainsValue(const Value: TValue): Boolean;\r\nvar\r\n Index: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n for Index := 0 to FSize - 1 do\r\n if ValuesCompare(FEntries[Index].Value, Value) = 0 then\r\n begin\r\n Result := True;\r\n Break;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSortedMap.FirstKey: TKey;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := Default(TKey);\r\n if FSize > 0 then\r\n Result := FEntries[0].Key\r\n else\r\n if not FReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSortedMap.Extract(const Key: TKey): TValue;\r\nvar\r\n Index: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Index := BinarySearch(Key);\r\n if (Index >= 0) and (KeysCompare(FEntries[Index].Key, Key) = 0) then\r\n begin\r\n Result := FEntries[Index].Value;\r\n FEntries[Index].Value := Default(TValue);\r\n FreeKey(FEntries[Index].Key);\r\n if Index < (FSize - 1) then\r\n MoveArray(FEntries, Index + 1, Index, FSize - Index - 1);\r\n Dec(FSize);\r\n AutoPack;\r\n end\r\n else\r\n Result := Default(TValue);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSortedMap.GetValue(const Key: TKey): TValue;\r\nvar\r\n Index: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Index := BinarySearch(Key);\r\n Result := Default(TValue);\r\n if (Index >= 0) and (KeysCompare(FEntries[Index].Key, Key) = 0) then\r\n Result := FEntries[Index].Value\r\n else if not FReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSortedMap.HeadMap(const ToKey: TKey): IJclSortedMap;\r\nvar\r\n ToIndex: Integer;\r\n NewMap: TJclSortedMap;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n NewMap := CreateEmptyContainer as TJclSortedMap;\r\n ToIndex := BinarySearch(ToKey);\r\n if ToIndex >= 0 then\r\n begin\r\n NewMap.SetCapacity(ToIndex + 1);\r\n NewMap.FSize := ToIndex + 1;\r\n while ToIndex >= 0 do\r\n begin\r\n NewMap.FEntries[ToIndex] := FEntries[ToIndex];\r\n Dec(ToIndex);\r\n end;\r\n end;\r\n Result := NewMap;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSortedMap.IsEmpty: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := FSize = 0;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSortedMap.KeyOfValue(const Value: TValue): TKey;\r\nvar\r\n Index: Integer;\r\n Found: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Found := False;\r\n Result := Default(TKey);\r\n for Index := 0 to FSize - 1 do\r\n if ValuesCompare(FEntries[Index].Value, Value) = 0 then\r\n begin\r\n Result := FEntries[Index].Key;\r\n Found := True;\r\n Break;\r\n end;\r\n\r\n if (not Found) and (not FReturnDefaultElements) then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSortedMap.KeySet: IJclSet;\r\nvar\r\n Index: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := CreateEmptyArraySet(FSize, False);\r\n for Index := 0 to FSize - 1 do\r\n Result.Add(FEntries[Index].Key);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSortedMap.LastKey: TKey;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := Default(TKey);\r\n if FSize > 0 then\r\n Result := FEntries[FSize - 1].Key\r\n else\r\n if not FReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSortedMap.MapEquals(const AMap: IJclMap): Boolean;\r\nvar\r\n It: IJclIterator;\r\n Index: Integer;\r\n AKey: TKey;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if AMap = nil then\r\n Exit;\r\n if FSize <> AMap.Size then\r\n Exit;\r\n It := AMap.KeySet.First;\r\n Index := 0;\r\n while It.HasNext do\r\n begin\r\n if Index >= FSize then\r\n Exit;\r\n AKey := It.Next;\r\n if ValuesCompare(AMap.GetValue(AKey), FEntries[Index].Value) <> 0 then\r\n Exit;\r\n Inc(Index);\r\n end;\r\n Result := True;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclSortedMap.MoveArray(var List: TSortedEntryArray; FromIndex, ToIndex, Count: SizeInt);\r\nvar\r\n I: SizeInt;\r\nbegin\r\n if FromIndex < ToIndex then\r\n begin\r\n for I := Count - 1 downto 0 do\r\n List[ToIndex + I] := List[FromIndex + I];\r\n\r\n if (ToIndex - FromIndex) < Count then\r\n // overlapped source and target\r\n for I := 0 to ToIndex - FromIndex - 1 do\r\n List[FromIndex + I] := Default(TSortedEntry)\r\n else\r\n // independant\r\n for I := 0 to Count - 1 do\r\n List[FromIndex + I] := Default(TSortedEntry);\r\n end\r\n else\r\n begin\r\n for I := 0 to Count - 1 do\r\n List[ToIndex + I] := List[FromIndex + I];\r\n\r\n if (FromIndex - ToIndex) < Count then\r\n // overlapped source and target\r\n for I := Count - FromIndex + ToIndex to Count - 1 do\r\n List[FromIndex + I] := Default(TSortedEntry)\r\n else\r\n // independant\r\n for I := 0 to Count - 1 do\r\n List[FromIndex + I] := Default(TSortedEntry);\r\n end; \r\nend;\r\n\r\nprocedure TJclSortedMap.PutAll(const AMap: IJclMap);\r\nvar\r\n It: IJclIterator;\r\n Key: TKey;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if AMap = nil then\r\n Exit;\r\n It := AMap.KeySet.First;\r\n while It.HasNext do\r\n begin\r\n Key := It.Next;\r\n PutValue(Key, AMap.GetValue(Key));\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclSortedMap.PutValue(const Key: TKey; const Value: TValue);\r\nvar\r\n Index: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FAllowDefaultElements or ((KeysCompare(Key, Default(TKey)) <> 0) and (ValuesCompare(Value, Default(TValue)) <> 0)) then\r\n begin\r\n Index := BinarySearch(Key);\r\n\r\n if (Index >= 0) and (KeysCompare(FEntries[Index].Key, Key) = 0) then\r\n begin\r\n FreeValue(FEntries[Index].Value);\r\n FEntries[Index].Value := Value;\r\n end\r\n else\r\n begin\r\n if FSize = FCapacity then\r\n AutoGrow;\r\n if FSize < FCapacity then\r\n begin\r\n Inc(Index);\r\n if (Index < FSize) and (KeysCompare(FEntries[Index].Key, Key) <> 0) then\r\n MoveArray(FEntries, Index, Index + 1, FSize - Index);\r\n FEntries[Index].Key := Key;\r\n FEntries[Index].Value := Value;\r\n Inc(FSize);\r\n end;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSortedMap.Remove(const Key: TKey): TValue;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := Extract(Key);\r\n Result := FreeValue(Result);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclSortedMap.SetCapacity(Value: Integer);\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FSize <= Value then\r\n begin\r\n SetLength(FEntries, Value);\r\n inherited SetCapacity(Value);\r\n end\r\n else\r\n raise EJclOperationNotSupportedError.Create;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSortedMap.Size: Integer;\r\nbegin\r\n Result := FSize;\r\nend;\r\n\r\nfunction TJclSortedMap.SubMap(const FromKey, ToKey: TKey): IJclSortedMap;\r\nvar\r\n FromIndex, ToIndex: Integer;\r\n NewMap: TJclSortedMap;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n NewMap := CreateEmptyContainer as TJclSortedMap;\r\n FromIndex := BinarySearch(FromKey);\r\n if (FromIndex = -1) or (KeysCompare(FEntries[FromIndex].Key, FromKey) < 0) then\r\n Inc(FromIndex);\r\n ToIndex := BinarySearch(ToKey);\r\n if (FromIndex >= 0) and (FromIndex <= ToIndex) then\r\n begin\r\n NewMap.SetCapacity(ToIndex - FromIndex + 1);\r\n NewMap.FSize := ToIndex - FromIndex + 1;\r\n while ToIndex >= FromIndex do\r\n begin\r\n NewMap.FEntries[ToIndex - FromIndex] := FEntries[ToIndex];\r\n Dec(ToIndex);\r\n end;\r\n end;\r\n Result := NewMap;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSortedMap.TailMap(const FromKey: TKey): IJclSortedMap;\r\nvar\r\n FromIndex, Index: Integer;\r\n NewMap: TJclSortedMap;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n NewMap := CreateEmptyContainer as TJclSortedMap;\r\n FromIndex := BinarySearch(FromKey);\r\n if (FromIndex = -1) or (KeysCompare(FEntries[FromIndex].Key, FromKey) < 0) then\r\n Inc(FromIndex);\r\n if (FromIndex >= 0) and (FromIndex < FSize) then\r\n begin\r\n NewMap.SetCapacity(FSize - FromIndex);\r\n NewMap.FSize := FSize - FromIndex;\r\n Index := FromIndex;\r\n while Index < FSize do\r\n begin\r\n NewMap.FEntries[Index - FromIndex] := FEntries[Index];\r\n Inc(Index);\r\n end;\r\n end;\r\n Result := NewMap;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSortedMap.Values: IJclCollection;\r\nvar\r\n Index: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := CreateEmptyArrayList(FSize, False);\r\n for Index := 0 to FSize - 1 do\r\n Result.Add(FEntries[Index].Value);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSortedMap.FreeKey(var Key: TKey): TKey;\r\nbegin\r\n if FOwnsKeys then\r\n begin\r\n Result := Default(TKey);\r\n FreeAndNil(Key);\r\n end\r\n else\r\n begin\r\n Result := Key;\r\n Key := Default(TKey);\r\n end;\r\nend;\r\n\r\nfunction TJclSortedMap.FreeValue(var Value: TValue): TValue;\r\nbegin\r\n if FOwnsValues then\r\n begin\r\n Result := Default(TValue);\r\n FreeAndNil(Value);\r\n end\r\n else\r\n begin\r\n Result := Value;\r\n Value := Default(TValue);\r\n end;\r\nend;\r\n\r\nfunction TJclSortedMap.GetOWnsKeys: Boolean;\r\nbegin\r\n Result := FOwnsKeys;\r\nend;\r\n\r\nfunction TJclSortedMap.GetOwnsValues: Boolean;\r\nbegin\r\n Result := FOwnsValues;\r\nend;\r\n\r\n//=== { TJclSortedMapE } =======================================\r\n\r\nconstructor TJclSortedMapE.Create(const AKeyComparer: IJclComparer;\r\n const AValueComparer: IJclComparer; const AValueEqualityComparer: IJclEqualityComparer; ACapacity: Integer;\r\n AOwnsValues: Boolean; AOwnsKeys: Boolean);\r\nbegin\r\n inherited Create(ACapacity, AOwnsValues, AOwnsKeys);\r\n FKeyComparer := AKeyComparer;\r\n FValueComparer := AValueComparer;\r\n FValueEqualityComparer := AValueEqualityComparer;\r\nend;\r\n\r\nprocedure TJclSortedMapE.AssignPropertiesTo(Dest: TJclAbstractContainerBase);\r\nvar\r\n ADest: TJclSortedMapE;\r\nbegin\r\n inherited AssignPropertiesTo(Dest);\r\n if Dest is TJclSortedMapE then\r\n begin\r\n ADest := TJclSortedMapE(Dest);\r\n ADest.FKeyComparer := FKeyComparer;\r\n ADest.FValueComparer := FValueComparer;\r\n end;\r\nend;\r\n\r\nfunction TJclSortedMapE.CreateEmptyArrayList(ACapacity: Integer;\r\n AOwnsObjects: Boolean): IJclCollection;\r\nbegin\r\n if FValueEqualityComparer = nil then\r\n raise EJclNoEqualityComparerError.Create;\r\n Result := TArrayList.Create(FValueEqualityComparer, ACapacity, AOwnsObjects);\r\nend;\r\n\r\nfunction TJclSortedMapE.CreateEmptyContainer: TJclAbstractContainerBase;\r\nbegin\r\n Result := TJclSortedMapE.Create(FKeyComparer, FValueComparer, FValueEqualityComparer, FCapacity,\r\n FOwnsValues, FOwnsKeys);\r\n AssignPropertiesTo(Result);\r\nend;\r\n\r\nfunction TJclSortedMapE.CreateEmptyArraySet(ACapacity: Integer; AOwnsObjects: Boolean): IJclSet;\r\nbegin\r\n Result := TArraySet.Create(FKeyComparer, FCapacity, AOwnsObjects);\r\nend;\r\n\r\nfunction TJclSortedMapE.KeysCompare(const A, B: TKey): Integer;\r\nbegin\r\n if KeyComparer = nil then\r\n raise EJclNoComparerError.Create;\r\n Result := KeyComparer.Compare(A, B);\r\nend;\r\n\r\nfunction TJclSortedMapE.ValuesCompare(const A, B: TValue): Integer;\r\nbegin\r\n if ValueComparer = nil then\r\n raise EJclNoComparerError.Create;\r\n Result := ValueComparer.Compare(A, B);\r\nend;\r\n\r\n//=== { TJclSortedMapF } =======================================\r\n\r\nconstructor TJclSortedMapF.Create(AKeyCompare: TCompare; AValueCompare: TCompare;\r\n AValueEqualityCompare: TEqualityCompare; ACapacity: Integer; AOwnsValues: Boolean; AOwnsKeys: Boolean);\r\nbegin\r\n inherited Create(ACapacity, AOwnsValues, AOwnsKeys);\r\n FKeyCompare := AKeyCompare;\r\n FValueCompare := AValueCompare;\r\n FValueEqualityCompare := AValueEqualityCompare;\r\nend;\r\n\r\nprocedure TJclSortedMapF.AssignPropertiesTo(Dest: TJclAbstractContainerBase);\r\nvar\r\n ADest: TJclSortedMapF;\r\nbegin\r\n inherited AssignPropertiesTo(Dest);\r\n if Dest is TJclSortedMapF then\r\n begin\r\n ADest := TJclSortedMapF(Dest);\r\n ADest.FKeyCompare := FKeyCompare;\r\n ADest.FValueCompare := FValueCompare;\r\n end;\r\nend;\r\n\r\nfunction TJclSortedMapF.CreateEmptyArrayList(ACapacity: Integer;\r\n AOwnsObjects: Boolean): IJclCollection;\r\nbegin\r\n if not Assigned(FValueEqualityCompare) then\r\n raise EJclNoEqualityComparerError.Create;\r\n Result := TArrayList.Create(FValueEqualityCompare, ACapacity, AOwnsObjects);\r\nend;\r\n\r\nfunction TJclSortedMapF.CreateEmptyContainer: TJclAbstractContainerBase;\r\nbegin\r\n Result := TJclSortedMapF.Create(FKeyCompare, FValueCompare, FValueEqualityCompare, FCapacity,\r\n FOwnsValues, FOwnsKeys);\r\n AssignPropertiesTo(Result);\r\nend;\r\n\r\nfunction TJclSortedMapF.CreateEmptyArraySet(ACapacity: Integer; AOwnsObjects: Boolean): IJclSet;\r\nbegin\r\n Result := TArraySet.Create(FKeyCompare, FCapacity, AOwnsObjects);\r\nend;\r\n\r\nfunction TJclSortedMapF.KeysCompare(const A, B: TKey): Integer;\r\nbegin\r\n if not Assigned(KeyCompare) then\r\n raise EJclNoComparerError.Create;\r\n Result := KeyCompare(A, B);\r\nend;\r\n\r\nfunction TJclSortedMapF.ValuesCompare(const A, B: TValue): Integer;\r\nbegin\r\n if not Assigned(ValueCompare) then\r\n raise EJclNoComparerError.Create;\r\n Result := ValueCompare(A, B);\r\nend;\r\n\r\n//=== { TJclSortedMapI } =======================================\r\n\r\nfunction TJclSortedMapI.CreateEmptyArrayList(ACapacity: Integer;\r\n AOwnsObjects: Boolean): IJclCollection;\r\nbegin\r\n Result := TArrayList.Create(ACapacity, AOwnsObjects);\r\nend;\r\n\r\nfunction TJclSortedMapI.CreateEmptyContainer: TJclAbstractContainerBase;\r\nbegin\r\n Result := TJclSortedMapI.Create(FCapacity, FOwnsValues, FOwnsKeys);\r\n AssignPropertiesTo(Result);\r\nend;\r\n\r\nfunction TJclSortedMapI.CreateEmptyArraySet(ACapacity: Integer; AOwnsObjects: Boolean): IJclSet;\r\nbegin\r\n Result := TArraySet.Create(FCapacity, AOwnsObjects);\r\nend;\r\n\r\nfunction TJclSortedMapI.KeysCompare(const A, B: TKey): Integer;\r\nbegin\r\n Result := A.CompareTo(B);\r\nend;\r\n\r\nfunction TJclSortedMapI.ValuesCompare(const A, B: TValue): Integer;\r\nbegin\r\n Result := A.CompareTo(B);\r\nend;\r\n\r\n//DOM-IGNORE-END\r\n{$ENDIF SUPPORTS_GENERICS}\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jcl/source/common/JclStacks.pas", "content": "{**************************************************************************************************}\r\n{ WARNING: JEDI preprocessor generated unit. Do not edit. }\r\n{**************************************************************************************************}\r\n\r\n{**************************************************************************************************}\r\n{ }\r\n{ Project JEDI Code Library (JCL) }\r\n{ }\r\n{ The contents of this file are subject to the Mozilla Public License Version 1.1 (the \"License\"); }\r\n{ you may not use this file except in compliance with the License. You may obtain a copy of the }\r\n{ License at http://www.mozilla.org/MPL/ }\r\n{ }\r\n{ Software distributed under the License is distributed on an \"AS IS\" basis, WITHOUT WARRANTY OF }\r\n{ ANY KIND, either express or implied. See the License for the specific language governing rights }\r\n{ and limitations under the License. }\r\n{ }\r\n{ The Original Code is Stack.pas. }\r\n{ }\r\n{ The Initial Developer of the Original Code is Jean-Philippe BEMPEL aka RDM. Portions created by }\r\n{ Jean-Philippe BEMPEL are Copyright (C) Jean-Philippe BEMPEL (rdm_30 att yahoo dott com) }\r\n{ All rights reserved. }\r\n{ }\r\n{ Contributors: }\r\n{ Florent Ouchet (outchy) }\r\n{ }\r\n{**************************************************************************************************}\r\n{ }\r\n{ The Delphi Container Library }\r\n{ }\r\n{**************************************************************************************************}\r\n{ }\r\n{ Last modified: $Date:: 2012-02-21 18:37:18 +0100 (mar. 21 févr. 2012) $ }\r\n{ Revision: $Rev:: 3739 $ }\r\n{ Author: $Author:: outchy $ }\r\n{ }\r\n{**************************************************************************************************}\r\n\r\nunit JclStacks;\r\n\r\n{$I jcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n {$IFDEF HAS_UNITSCOPE}\r\n {$IFDEF SUPPORTS_GENERICS}\r\n System.Generics.Collections,\r\n JclAlgorithms,\r\n {$ENDIF SUPPORTS_GENERICS}\r\n {$ELSE ~HAS_UNITSCOPE}\r\n {$IFDEF SUPPORTS_GENERICS}\r\n Generics.Collections,\r\n JclAlgorithms,\r\n {$ENDIF SUPPORTS_GENERICS}\r\n {$ENDIF ~HAS_UNITSCOPE}\r\n JclBase, JclAbstractContainers, JclContainerIntf, JclSynch;\r\n\r\ntype\r\n TJclIntfStack = class(TJclIntfAbstractContainer, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclIntfCloneable, IJclCloneable, IJclPackable, IJclGrowable, IJclBaseContainer,\r\n IJclIntfContainer, IJclIntfEqualityComparer,\r\n IJclIntfStack)\r\n protected\r\n function CreateEmptyContainer: TJclAbstractContainerBase; override;\r\n private\r\n FElements: TDynIInterfaceArray;\r\n protected\r\n procedure AssignDataTo(Dest: TJclAbstractContainerBase); override;\r\n public\r\n constructor Create(ACapacity: Integer);\r\n destructor Destroy; override;\r\n { IJclPackable }\r\n procedure SetCapacity(Value: Integer); override;\r\n { IJclIntfStack }\r\n procedure Clear;\r\n function Contains(const AInterface: IInterface): Boolean;\r\n function Empty: Boolean;\r\n function Peek: IInterface;\r\n function Pop: IInterface;\r\n function Push(const AInterface: IInterface): Boolean;\r\n function Size: Integer;\r\n end;\r\n\r\n TJclAnsiStrStack = class(TJclAnsiStrAbstractContainer, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclIntfCloneable, IJclCloneable, IJclPackable, IJclGrowable, IJclBaseContainer,\r\n IJclAnsiStrContainer, IJclAnsiStrEqualityComparer, IJclStrBaseContainer,\r\n IJclAnsiStrStack)\r\n protected\r\n function CreateEmptyContainer: TJclAbstractContainerBase; override;\r\n private\r\n FElements: TDynAnsiStringArray;\r\n protected\r\n procedure AssignDataTo(Dest: TJclAbstractContainerBase); override;\r\n public\r\n constructor Create(ACapacity: Integer);\r\n destructor Destroy; override;\r\n { IJclPackable }\r\n procedure SetCapacity(Value: Integer); override;\r\n { IJclAnsiStrStack }\r\n procedure Clear;\r\n function Contains(const AString: AnsiString): Boolean;\r\n function Empty: Boolean;\r\n function Peek: AnsiString;\r\n function Pop: AnsiString;\r\n function Push(const AString: AnsiString): Boolean;\r\n function Size: Integer;\r\n end;\r\n\r\n TJclWideStrStack = class(TJclWideStrAbstractContainer, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclIntfCloneable, IJclCloneable, IJclPackable, IJclGrowable, IJclBaseContainer,\r\n IJclWideStrContainer, IJclWideStrEqualityComparer, IJclStrBaseContainer,\r\n IJclWideStrStack)\r\n protected\r\n function CreateEmptyContainer: TJclAbstractContainerBase; override;\r\n private\r\n FElements: TDynWideStringArray;\r\n protected\r\n procedure AssignDataTo(Dest: TJclAbstractContainerBase); override;\r\n public\r\n constructor Create(ACapacity: Integer);\r\n destructor Destroy; override;\r\n { IJclPackable }\r\n procedure SetCapacity(Value: Integer); override;\r\n { IJclWideStrStack }\r\n procedure Clear;\r\n function Contains(const AString: WideString): Boolean;\r\n function Empty: Boolean;\r\n function Peek: WideString;\r\n function Pop: WideString;\r\n function Push(const AString: WideString): Boolean;\r\n function Size: Integer;\r\n end;\r\n\r\n {$IFDEF SUPPORTS_UNICODE_STRING}\r\n TJclUnicodeStrStack = class(TJclUnicodeStrAbstractContainer, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclIntfCloneable, IJclCloneable, IJclPackable, IJclGrowable, IJclBaseContainer,\r\n IJclUnicodeStrContainer, IJclUnicodeStrEqualityComparer, IJclStrBaseContainer,\r\n IJclUnicodeStrStack)\r\n protected\r\n function CreateEmptyContainer: TJclAbstractContainerBase; override;\r\n private\r\n FElements: TDynUnicodeStringArray;\r\n protected\r\n procedure AssignDataTo(Dest: TJclAbstractContainerBase); override;\r\n public\r\n constructor Create(ACapacity: Integer);\r\n destructor Destroy; override;\r\n { IJclPackable }\r\n procedure SetCapacity(Value: Integer); override;\r\n { IJclUnicodeStrStack }\r\n procedure Clear;\r\n function Contains(const AString: UnicodeString): Boolean;\r\n function Empty: Boolean;\r\n function Peek: UnicodeString;\r\n function Pop: UnicodeString;\r\n function Push(const AString: UnicodeString): Boolean;\r\n function Size: Integer;\r\n end;\r\n {$ENDIF SUPPORTS_UNICODE_STRING}\r\n\r\n {$IFDEF CONTAINER_ANSISTR}\r\n TJclStrStack = TJclAnsiStrStack;\r\n {$ENDIF CONTAINER_ANSISTR}\r\n {$IFDEF CONTAINER_WIDESTR}\r\n TJclStrStack = TJclWideStrStack;\r\n {$ENDIF CONTAINER_WIDESTR}\r\n {$IFDEF CONTAINER_UNICODESTR}\r\n TJclStrStack = TJclUnicodeStrStack;\r\n {$ENDIF CONTAINER_UNICODESTR}\r\n\r\n TJclSingleStack = class(TJclSingleAbstractContainer, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclIntfCloneable, IJclCloneable, IJclPackable, IJclGrowable, IJclBaseContainer,\r\n IJclSingleContainer, IJclSingleEqualityComparer,\r\n IJclSingleStack)\r\n protected\r\n function CreateEmptyContainer: TJclAbstractContainerBase; override;\r\n private\r\n FElements: TDynSingleArray;\r\n protected\r\n procedure AssignDataTo(Dest: TJclAbstractContainerBase); override;\r\n public\r\n constructor Create(ACapacity: Integer);\r\n destructor Destroy; override;\r\n { IJclPackable }\r\n procedure SetCapacity(Value: Integer); override;\r\n { IJclSingleStack }\r\n procedure Clear;\r\n function Contains(const AValue: Single): Boolean;\r\n function Empty: Boolean;\r\n function Peek: Single;\r\n function Pop: Single;\r\n function Push(const AValue: Single): Boolean;\r\n function Size: Integer;\r\n end;\r\n\r\n TJclDoubleStack = class(TJclDoubleAbstractContainer, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclIntfCloneable, IJclCloneable, IJclPackable, IJclGrowable, IJclBaseContainer,\r\n IJclDoubleContainer, IJclDoubleEqualityComparer,\r\n IJclDoubleStack)\r\n protected\r\n function CreateEmptyContainer: TJclAbstractContainerBase; override;\r\n private\r\n FElements: TDynDoubleArray;\r\n protected\r\n procedure AssignDataTo(Dest: TJclAbstractContainerBase); override;\r\n public\r\n constructor Create(ACapacity: Integer);\r\n destructor Destroy; override;\r\n { IJclPackable }\r\n procedure SetCapacity(Value: Integer); override;\r\n { IJclDoubleStack }\r\n procedure Clear;\r\n function Contains(const AValue: Double): Boolean;\r\n function Empty: Boolean;\r\n function Peek: Double;\r\n function Pop: Double;\r\n function Push(const AValue: Double): Boolean;\r\n function Size: Integer;\r\n end;\r\n\r\n TJclExtendedStack = class(TJclExtendedAbstractContainer, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclIntfCloneable, IJclCloneable, IJclPackable, IJclGrowable, IJclBaseContainer,\r\n IJclExtendedContainer, IJclExtendedEqualityComparer,\r\n IJclExtendedStack)\r\n protected\r\n function CreateEmptyContainer: TJclAbstractContainerBase; override;\r\n private\r\n FElements: TDynExtendedArray;\r\n protected\r\n procedure AssignDataTo(Dest: TJclAbstractContainerBase); override;\r\n public\r\n constructor Create(ACapacity: Integer);\r\n destructor Destroy; override;\r\n { IJclPackable }\r\n procedure SetCapacity(Value: Integer); override;\r\n { IJclExtendedStack }\r\n procedure Clear;\r\n function Contains(const AValue: Extended): Boolean;\r\n function Empty: Boolean;\r\n function Peek: Extended;\r\n function Pop: Extended;\r\n function Push(const AValue: Extended): Boolean;\r\n function Size: Integer;\r\n end;\r\n\r\n {$IFDEF MATH_SINGLE_PRECISION}\r\n TJclFloatStack = TJclSingleStack;\r\n {$ENDIF MATH_SINGLE_PRECISION}\r\n {$IFDEF MATH_DOUBLE_PRECISION}\r\n TJclFloatStack = TJclDoubleStack;\r\n {$ENDIF MATH_DOUBLE_PRECISION}\r\n {$IFDEF MATH_EXTENDED_PRECISION}\r\n TJclFloatStack = TJclExtendedStack;\r\n {$ENDIF MATH_EXTENDED_PRECISION}\r\n\r\n TJclIntegerStack = class(TJclIntegerAbstractContainer, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclIntfCloneable, IJclCloneable, IJclPackable, IJclGrowable, IJclBaseContainer,\r\n IJclIntegerContainer, IJclIntegerEqualityComparer,\r\n IJclIntegerStack)\r\n protected\r\n function CreateEmptyContainer: TJclAbstractContainerBase; override;\r\n private\r\n FElements: TDynIntegerArray;\r\n protected\r\n procedure AssignDataTo(Dest: TJclAbstractContainerBase); override;\r\n public\r\n constructor Create(ACapacity: Integer);\r\n destructor Destroy; override;\r\n { IJclPackable }\r\n procedure SetCapacity(Value: Integer); override;\r\n { IJclIntegerStack }\r\n procedure Clear;\r\n function Contains(AValue: Integer): Boolean;\r\n function Empty: Boolean;\r\n function Peek: Integer;\r\n function Pop: Integer;\r\n function Push(AValue: Integer): Boolean;\r\n function Size: Integer;\r\n end;\r\n\r\n TJclCardinalStack = class(TJclCardinalAbstractContainer, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclIntfCloneable, IJclCloneable, IJclPackable, IJclGrowable, IJclBaseContainer,\r\n IJclCardinalContainer, IJclCardinalEqualityComparer,\r\n IJclCardinalStack)\r\n protected\r\n function CreateEmptyContainer: TJclAbstractContainerBase; override;\r\n private\r\n FElements: TDynCardinalArray;\r\n protected\r\n procedure AssignDataTo(Dest: TJclAbstractContainerBase); override;\r\n public\r\n constructor Create(ACapacity: Integer);\r\n destructor Destroy; override;\r\n { IJclPackable }\r\n procedure SetCapacity(Value: Integer); override;\r\n { IJclCardinalStack }\r\n procedure Clear;\r\n function Contains(AValue: Cardinal): Boolean;\r\n function Empty: Boolean;\r\n function Peek: Cardinal;\r\n function Pop: Cardinal;\r\n function Push(AValue: Cardinal): Boolean;\r\n function Size: Integer;\r\n end;\r\n\r\n TJclInt64Stack = class(TJclInt64AbstractContainer, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclIntfCloneable, IJclCloneable, IJclPackable, IJclGrowable, IJclBaseContainer,\r\n IJclInt64Container, IJclInt64EqualityComparer,\r\n IJclInt64Stack)\r\n protected\r\n function CreateEmptyContainer: TJclAbstractContainerBase; override;\r\n private\r\n FElements: TDynInt64Array;\r\n protected\r\n procedure AssignDataTo(Dest: TJclAbstractContainerBase); override;\r\n public\r\n constructor Create(ACapacity: Integer);\r\n destructor Destroy; override;\r\n { IJclPackable }\r\n procedure SetCapacity(Value: Integer); override;\r\n { IJclInt64Stack }\r\n procedure Clear;\r\n function Contains(const AValue: Int64): Boolean;\r\n function Empty: Boolean;\r\n function Peek: Int64;\r\n function Pop: Int64;\r\n function Push(const AValue: Int64): Boolean;\r\n function Size: Integer;\r\n end;\r\n\r\n TJclPtrStack = class(TJclPtrAbstractContainer, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclIntfCloneable, IJclCloneable, IJclPackable, IJclGrowable, IJclBaseContainer,\r\n IJclPtrContainer, IJclPtrEqualityComparer,\r\n IJclPtrStack)\r\n protected\r\n function CreateEmptyContainer: TJclAbstractContainerBase; override;\r\n private\r\n FElements: TDynPointerArray;\r\n protected\r\n procedure AssignDataTo(Dest: TJclAbstractContainerBase); override;\r\n public\r\n constructor Create(ACapacity: Integer);\r\n destructor Destroy; override;\r\n { IJclPackable }\r\n procedure SetCapacity(Value: Integer); override;\r\n { IJclPtrStack }\r\n procedure Clear;\r\n function Contains(APtr: Pointer): Boolean;\r\n function Empty: Boolean;\r\n function Peek: Pointer;\r\n function Pop: Pointer;\r\n function Push(APtr: Pointer): Boolean;\r\n function Size: Integer;\r\n end;\r\n\r\n TJclStack = class(TJclAbstractContainer, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclIntfCloneable, IJclCloneable, IJclPackable, IJclGrowable, IJclBaseContainer,\r\n IJclContainer, IJclEqualityComparer, IJclObjectOwner,\r\n IJclStack)\r\n protected\r\n function CreateEmptyContainer: TJclAbstractContainerBase; override;\r\n private\r\n FElements: TDynObjectArray;\r\n protected\r\n procedure AssignDataTo(Dest: TJclAbstractContainerBase); override;\r\n public\r\n constructor Create(ACapacity: Integer; AOwnsObjects: Boolean);\r\n destructor Destroy; override;\r\n { IJclPackable }\r\n procedure SetCapacity(Value: Integer); override;\r\n { IJclStack }\r\n procedure Clear;\r\n function Contains(AObject: TObject): Boolean;\r\n function Empty: Boolean;\r\n function Peek: TObject;\r\n function Pop: TObject;\r\n function Push(AObject: TObject): Boolean;\r\n function Size: Integer;\r\n end;\r\n\r\n\r\n {$IFDEF SUPPORTS_GENERICS}\r\n //DOM-IGNORE-BEGIN\r\n\r\n TJclStack = class(TJclAbstractContainer, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclIntfCloneable, IJclCloneable, IJclPackable, IJclGrowable, IJclBaseContainer,\r\n IJclContainer, IJclEqualityComparer, IJclItemOwner,\r\n IJclStack)\r\n protected\r\n type\r\n TDynArray = array of T;\r\n private\r\n FElements: TDynArray;\r\n protected\r\n procedure AssignDataTo(Dest: TJclAbstractContainerBase); override;\r\n public\r\n constructor Create(ACapacity: Integer; AOwnsItems: Boolean);\r\n destructor Destroy; override;\r\n { IJclPackable }\r\n procedure SetCapacity(Value: Integer); override;\r\n { IJclStack }\r\n procedure Clear;\r\n function Contains(const AItem: T): Boolean;\r\n function Empty: Boolean;\r\n function Peek: T;\r\n function Pop: T;\r\n function Push(const AItem: T): Boolean;\r\n function Size: Integer;\r\n end;\r\n\r\n // E = external helper to compare items for equality\r\n TJclStackE = class(TJclStack, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclIntfCloneable, IJclCloneable, IJclPackable, IJclGrowable, IJclBaseContainer, IJclContainer,\r\n IJclStack, IJclItemOwner)\r\n private\r\n FEqualityComparer: IEqualityComparer;\r\n protected\r\n procedure AssignPropertiesTo(Dest: TJclAbstractContainerBase); override;\r\n function CreateEmptyContainer: TJclAbstractContainerBase; override;\r\n public\r\n constructor Create(const AEqualityComparer: IEqualityComparer; ACapacity: Integer; AOwnsItems: Boolean);\r\n { IJclEqualityComparer }\r\n function ItemsEqual(const A, B: T): Boolean; override;\r\n property EqualityComparer: IEqualityComparer read FEqualityComparer write FEqualityComparer;\r\n end;\r\n\r\n // F = Function to compare items for equality\r\n TJclStackF = class(TJclStack, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclIntfCloneable, IJclCloneable, IJclPackable, IJclGrowable, IJclBaseContainer, IJclContainer,\r\n IJclStack, IJclItemOwner)\r\n protected\r\n function CreateEmptyContainer: TJclAbstractContainerBase; override;\r\n public\r\n constructor Create(AEqualityCompare: TEqualityCompare; ACapacity: Integer; AOwnsItems: Boolean);\r\n end;\r\n\r\n // I = items can compare themselves to an other for equality\r\n TJclStackI> = class(TJclStack, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclIntfCloneable, IJclCloneable, IJclPackable, IJclGrowable, IJclBaseContainer, IJclContainer,\r\n IJclStack, IJclItemOwner)\r\n protected\r\n function CreateEmptyContainer: TJclAbstractContainerBase; override;\r\n public\r\n { IJclEqualityComparer }\r\n function ItemsEqual(const A, B: T): Boolean; override;\r\n end;\r\n\r\n //DOM-IGNORE-END\r\n {$ENDIF SUPPORTS_GENERICS}\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jcl.svn.sourceforge.net/svnroot/jcl/tags/JCL-2.4-Build4571/jcl/source/common/JclStacks.pas $';\r\n Revision: '$Revision: 3739 $';\r\n Date: '$Date: 2012-02-21 18:37:18 +0100 (mar. 21 févr. 2012) $';\r\n LogPath: 'JCL\\source\\common';\r\n Extra: '';\r\n Data: nil\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n SysUtils;\r\n\r\n//=== { TJclIntfStack } =======================================================\r\n\r\nconstructor TJclIntfStack.Create(ACapacity: Integer);\r\nbegin\r\n inherited Create();\r\n SetCapacity(ACapacity);\r\nend;\r\n\r\ndestructor TJclIntfStack.Destroy;\r\nbegin\r\n FReadOnly := False;\r\n Clear;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJclIntfStack.AssignDataTo(Dest: TJclAbstractContainerBase);\r\nvar\r\n ADest: TJclIntfStack;\r\n I: Integer;\r\nbegin\r\n inherited AssignDataTo(Dest);\r\n if Dest is TJclIntfStack then\r\n begin\r\n ADest := TJclIntfStack(Dest);\r\n ADest.Clear;\r\n ADest.SetCapacity(FSize + 1);\r\n for I := 0 to FSize - 1 do\r\n ADest.FElements[I] := FElements[I];\r\n ADest.FSize := FSize;\r\n end;\r\nend;\r\n\r\nprocedure TJclIntfStack.Clear;\r\nvar\r\n I: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n for I := 0 to FSize - 1 do\r\n FreeObject(FElements[I]);\r\n FSize := 0;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfStack.Contains(const AInterface: IInterface): Boolean;\r\nvar\r\n I: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n for I := 0 to FSize - 1 do\r\n if ItemsEqual(FElements[I], AInterface) then\r\n begin\r\n Result := True;\r\n Break;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfStack.Empty: Boolean;\r\nbegin\r\n Result := FSize = 0;\r\nend;\r\n\r\nfunction TJclIntfStack.Peek: IInterface;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := nil;\r\n if FSize > 0 then\r\n Result := FElements[FSize - 1]\r\n else\r\n if not FReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfStack.Pop: IInterface;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := nil;\r\n if FSize > 0 then\r\n begin\r\n Dec(FSize);\r\n Result := FElements[FSize];\r\n FElements[FSize] := nil;\r\n end\r\n else\r\n if not FReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n AutoPack;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfStack.Push(const AInterface: IInterface): Boolean;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FSize = FCapacity then\r\n AutoGrow;\r\n Result := FSize < FCapacity;\r\n if Result then\r\n begin\r\n FElements[FSize] := AInterface;\r\n Inc(FSize);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclIntfStack.SetCapacity(Value: Integer);\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Value < FSize then\r\n raise EJclOutOfBoundsError.Create;\r\n SetLength(FElements, Value);\r\n inherited SetCapacity(Value);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfStack.Size: Integer;\r\nbegin\r\n Result := FSize;\r\nend;\r\n\r\nfunction TJclIntfStack.CreateEmptyContainer: TJclAbstractContainerBase;\r\nbegin\r\n Result := TJclIntfStack.Create(FSize);\r\n AssignPropertiesTo(Result);\r\nend;\r\n\r\n//=== { TJclAnsiStrStack } =======================================================\r\n\r\nconstructor TJclAnsiStrStack.Create(ACapacity: Integer);\r\nbegin\r\n inherited Create();\r\n SetCapacity(ACapacity);\r\nend;\r\n\r\ndestructor TJclAnsiStrStack.Destroy;\r\nbegin\r\n FReadOnly := False;\r\n Clear;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJclAnsiStrStack.AssignDataTo(Dest: TJclAbstractContainerBase);\r\nvar\r\n ADest: TJclAnsiStrStack;\r\n I: Integer;\r\nbegin\r\n inherited AssignDataTo(Dest);\r\n if Dest is TJclAnsiStrStack then\r\n begin\r\n ADest := TJclAnsiStrStack(Dest);\r\n ADest.Clear;\r\n ADest.SetCapacity(FSize + 1);\r\n for I := 0 to FSize - 1 do\r\n ADest.FElements[I] := FElements[I];\r\n ADest.FSize := FSize;\r\n end;\r\nend;\r\n\r\nprocedure TJclAnsiStrStack.Clear;\r\nvar\r\n I: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n for I := 0 to FSize - 1 do\r\n FreeString(FElements[I]);\r\n FSize := 0;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclAnsiStrStack.Contains(const AString: AnsiString): Boolean;\r\nvar\r\n I: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n for I := 0 to FSize - 1 do\r\n if ItemsEqual(FElements[I], AString) then\r\n begin\r\n Result := True;\r\n Break;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclAnsiStrStack.Empty: Boolean;\r\nbegin\r\n Result := FSize = 0;\r\nend;\r\n\r\nfunction TJclAnsiStrStack.Peek: AnsiString;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := '';\r\n if FSize > 0 then\r\n Result := FElements[FSize - 1]\r\n else\r\n if not FReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclAnsiStrStack.Pop: AnsiString;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := '';\r\n if FSize > 0 then\r\n begin\r\n Dec(FSize);\r\n Result := FElements[FSize];\r\n FElements[FSize] := '';\r\n end\r\n else\r\n if not FReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n AutoPack;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclAnsiStrStack.Push(const AString: AnsiString): Boolean;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FSize = FCapacity then\r\n AutoGrow;\r\n Result := FSize < FCapacity;\r\n if Result then\r\n begin\r\n FElements[FSize] := AString;\r\n Inc(FSize);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclAnsiStrStack.SetCapacity(Value: Integer);\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Value < FSize then\r\n raise EJclOutOfBoundsError.Create;\r\n SetLength(FElements, Value);\r\n inherited SetCapacity(Value);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclAnsiStrStack.Size: Integer;\r\nbegin\r\n Result := FSize;\r\nend;\r\n\r\nfunction TJclAnsiStrStack.CreateEmptyContainer: TJclAbstractContainerBase;\r\nbegin\r\n Result := TJclAnsiStrStack.Create(FSize);\r\n AssignPropertiesTo(Result);\r\nend;\r\n\r\n//=== { TJclWideStrStack } =======================================================\r\n\r\nconstructor TJclWideStrStack.Create(ACapacity: Integer);\r\nbegin\r\n inherited Create();\r\n SetCapacity(ACapacity);\r\nend;\r\n\r\ndestructor TJclWideStrStack.Destroy;\r\nbegin\r\n FReadOnly := False;\r\n Clear;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJclWideStrStack.AssignDataTo(Dest: TJclAbstractContainerBase);\r\nvar\r\n ADest: TJclWideStrStack;\r\n I: Integer;\r\nbegin\r\n inherited AssignDataTo(Dest);\r\n if Dest is TJclWideStrStack then\r\n begin\r\n ADest := TJclWideStrStack(Dest);\r\n ADest.Clear;\r\n ADest.SetCapacity(FSize + 1);\r\n for I := 0 to FSize - 1 do\r\n ADest.FElements[I] := FElements[I];\r\n ADest.FSize := FSize;\r\n end;\r\nend;\r\n\r\nprocedure TJclWideStrStack.Clear;\r\nvar\r\n I: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n for I := 0 to FSize - 1 do\r\n FreeString(FElements[I]);\r\n FSize := 0;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclWideStrStack.Contains(const AString: WideString): Boolean;\r\nvar\r\n I: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n for I := 0 to FSize - 1 do\r\n if ItemsEqual(FElements[I], AString) then\r\n begin\r\n Result := True;\r\n Break;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclWideStrStack.Empty: Boolean;\r\nbegin\r\n Result := FSize = 0;\r\nend;\r\n\r\nfunction TJclWideStrStack.Peek: WideString;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := '';\r\n if FSize > 0 then\r\n Result := FElements[FSize - 1]\r\n else\r\n if not FReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclWideStrStack.Pop: WideString;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := '';\r\n if FSize > 0 then\r\n begin\r\n Dec(FSize);\r\n Result := FElements[FSize];\r\n FElements[FSize] := '';\r\n end\r\n else\r\n if not FReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n AutoPack;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclWideStrStack.Push(const AString: WideString): Boolean;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FSize = FCapacity then\r\n AutoGrow;\r\n Result := FSize < FCapacity;\r\n if Result then\r\n begin\r\n FElements[FSize] := AString;\r\n Inc(FSize);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclWideStrStack.SetCapacity(Value: Integer);\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Value < FSize then\r\n raise EJclOutOfBoundsError.Create;\r\n SetLength(FElements, Value);\r\n inherited SetCapacity(Value);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclWideStrStack.Size: Integer;\r\nbegin\r\n Result := FSize;\r\nend;\r\n\r\nfunction TJclWideStrStack.CreateEmptyContainer: TJclAbstractContainerBase;\r\nbegin\r\n Result := TJclWideStrStack.Create(FSize);\r\n AssignPropertiesTo(Result);\r\nend;\r\n\r\n{$IFDEF SUPPORTS_UNICODE_STRING}\r\n//=== { TJclUnicodeStrStack } =======================================================\r\n\r\nconstructor TJclUnicodeStrStack.Create(ACapacity: Integer);\r\nbegin\r\n inherited Create();\r\n SetCapacity(ACapacity);\r\nend;\r\n\r\ndestructor TJclUnicodeStrStack.Destroy;\r\nbegin\r\n FReadOnly := False;\r\n Clear;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJclUnicodeStrStack.AssignDataTo(Dest: TJclAbstractContainerBase);\r\nvar\r\n ADest: TJclUnicodeStrStack;\r\n I: Integer;\r\nbegin\r\n inherited AssignDataTo(Dest);\r\n if Dest is TJclUnicodeStrStack then\r\n begin\r\n ADest := TJclUnicodeStrStack(Dest);\r\n ADest.Clear;\r\n ADest.SetCapacity(FSize + 1);\r\n for I := 0 to FSize - 1 do\r\n ADest.FElements[I] := FElements[I];\r\n ADest.FSize := FSize;\r\n end;\r\nend;\r\n\r\nprocedure TJclUnicodeStrStack.Clear;\r\nvar\r\n I: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n for I := 0 to FSize - 1 do\r\n FreeString(FElements[I]);\r\n FSize := 0;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclUnicodeStrStack.Contains(const AString: UnicodeString): Boolean;\r\nvar\r\n I: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n for I := 0 to FSize - 1 do\r\n if ItemsEqual(FElements[I], AString) then\r\n begin\r\n Result := True;\r\n Break;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclUnicodeStrStack.Empty: Boolean;\r\nbegin\r\n Result := FSize = 0;\r\nend;\r\n\r\nfunction TJclUnicodeStrStack.Peek: UnicodeString;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := '';\r\n if FSize > 0 then\r\n Result := FElements[FSize - 1]\r\n else\r\n if not FReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclUnicodeStrStack.Pop: UnicodeString;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := '';\r\n if FSize > 0 then\r\n begin\r\n Dec(FSize);\r\n Result := FElements[FSize];\r\n FElements[FSize] := '';\r\n end\r\n else\r\n if not FReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n AutoPack;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclUnicodeStrStack.Push(const AString: UnicodeString): Boolean;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FSize = FCapacity then\r\n AutoGrow;\r\n Result := FSize < FCapacity;\r\n if Result then\r\n begin\r\n FElements[FSize] := AString;\r\n Inc(FSize);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclUnicodeStrStack.SetCapacity(Value: Integer);\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Value < FSize then\r\n raise EJclOutOfBoundsError.Create;\r\n SetLength(FElements, Value);\r\n inherited SetCapacity(Value);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclUnicodeStrStack.Size: Integer;\r\nbegin\r\n Result := FSize;\r\nend;\r\n\r\nfunction TJclUnicodeStrStack.CreateEmptyContainer: TJclAbstractContainerBase;\r\nbegin\r\n Result := TJclUnicodeStrStack.Create(FSize);\r\n AssignPropertiesTo(Result);\r\nend;\r\n\r\n{$ENDIF SUPPORTS_UNICODE_STRING}\r\n\r\n//=== { TJclSingleStack } =======================================================\r\n\r\nconstructor TJclSingleStack.Create(ACapacity: Integer);\r\nbegin\r\n inherited Create();\r\n SetCapacity(ACapacity);\r\nend;\r\n\r\ndestructor TJclSingleStack.Destroy;\r\nbegin\r\n FReadOnly := False;\r\n Clear;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJclSingleStack.AssignDataTo(Dest: TJclAbstractContainerBase);\r\nvar\r\n ADest: TJclSingleStack;\r\n I: Integer;\r\nbegin\r\n inherited AssignDataTo(Dest);\r\n if Dest is TJclSingleStack then\r\n begin\r\n ADest := TJclSingleStack(Dest);\r\n ADest.Clear;\r\n ADest.SetCapacity(FSize + 1);\r\n for I := 0 to FSize - 1 do\r\n ADest.FElements[I] := FElements[I];\r\n ADest.FSize := FSize;\r\n end;\r\nend;\r\n\r\nprocedure TJclSingleStack.Clear;\r\nvar\r\n I: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n for I := 0 to FSize - 1 do\r\n FreeSingle(FElements[I]);\r\n FSize := 0;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSingleStack.Contains(const AValue: Single): Boolean;\r\nvar\r\n I: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n for I := 0 to FSize - 1 do\r\n if ItemsEqual(FElements[I], AValue) then\r\n begin\r\n Result := True;\r\n Break;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSingleStack.Empty: Boolean;\r\nbegin\r\n Result := FSize = 0;\r\nend;\r\n\r\nfunction TJclSingleStack.Peek: Single;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := 0.0;\r\n if FSize > 0 then\r\n Result := FElements[FSize - 1]\r\n else\r\n if not FReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSingleStack.Pop: Single;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := 0.0;\r\n if FSize > 0 then\r\n begin\r\n Dec(FSize);\r\n Result := FElements[FSize];\r\n FElements[FSize] := 0.0;\r\n end\r\n else\r\n if not FReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n AutoPack;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSingleStack.Push(const AValue: Single): Boolean;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FSize = FCapacity then\r\n AutoGrow;\r\n Result := FSize < FCapacity;\r\n if Result then\r\n begin\r\n FElements[FSize] := AValue;\r\n Inc(FSize);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclSingleStack.SetCapacity(Value: Integer);\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Value < FSize then\r\n raise EJclOutOfBoundsError.Create;\r\n SetLength(FElements, Value);\r\n inherited SetCapacity(Value);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSingleStack.Size: Integer;\r\nbegin\r\n Result := FSize;\r\nend;\r\n\r\nfunction TJclSingleStack.CreateEmptyContainer: TJclAbstractContainerBase;\r\nbegin\r\n Result := TJclSingleStack.Create(FSize);\r\n AssignPropertiesTo(Result);\r\nend;\r\n\r\n//=== { TJclDoubleStack } =======================================================\r\n\r\nconstructor TJclDoubleStack.Create(ACapacity: Integer);\r\nbegin\r\n inherited Create();\r\n SetCapacity(ACapacity);\r\nend;\r\n\r\ndestructor TJclDoubleStack.Destroy;\r\nbegin\r\n FReadOnly := False;\r\n Clear;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJclDoubleStack.AssignDataTo(Dest: TJclAbstractContainerBase);\r\nvar\r\n ADest: TJclDoubleStack;\r\n I: Integer;\r\nbegin\r\n inherited AssignDataTo(Dest);\r\n if Dest is TJclDoubleStack then\r\n begin\r\n ADest := TJclDoubleStack(Dest);\r\n ADest.Clear;\r\n ADest.SetCapacity(FSize + 1);\r\n for I := 0 to FSize - 1 do\r\n ADest.FElements[I] := FElements[I];\r\n ADest.FSize := FSize;\r\n end;\r\nend;\r\n\r\nprocedure TJclDoubleStack.Clear;\r\nvar\r\n I: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n for I := 0 to FSize - 1 do\r\n FreeDouble(FElements[I]);\r\n FSize := 0;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclDoubleStack.Contains(const AValue: Double): Boolean;\r\nvar\r\n I: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n for I := 0 to FSize - 1 do\r\n if ItemsEqual(FElements[I], AValue) then\r\n begin\r\n Result := True;\r\n Break;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclDoubleStack.Empty: Boolean;\r\nbegin\r\n Result := FSize = 0;\r\nend;\r\n\r\nfunction TJclDoubleStack.Peek: Double;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := 0.0;\r\n if FSize > 0 then\r\n Result := FElements[FSize - 1]\r\n else\r\n if not FReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclDoubleStack.Pop: Double;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := 0.0;\r\n if FSize > 0 then\r\n begin\r\n Dec(FSize);\r\n Result := FElements[FSize];\r\n FElements[FSize] := 0.0;\r\n end\r\n else\r\n if not FReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n AutoPack;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclDoubleStack.Push(const AValue: Double): Boolean;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FSize = FCapacity then\r\n AutoGrow;\r\n Result := FSize < FCapacity;\r\n if Result then\r\n begin\r\n FElements[FSize] := AValue;\r\n Inc(FSize);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclDoubleStack.SetCapacity(Value: Integer);\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Value < FSize then\r\n raise EJclOutOfBoundsError.Create;\r\n SetLength(FElements, Value);\r\n inherited SetCapacity(Value);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclDoubleStack.Size: Integer;\r\nbegin\r\n Result := FSize;\r\nend;\r\n\r\nfunction TJclDoubleStack.CreateEmptyContainer: TJclAbstractContainerBase;\r\nbegin\r\n Result := TJclDoubleStack.Create(FSize);\r\n AssignPropertiesTo(Result);\r\nend;\r\n\r\n//=== { TJclExtendedStack } =======================================================\r\n\r\nconstructor TJclExtendedStack.Create(ACapacity: Integer);\r\nbegin\r\n inherited Create();\r\n SetCapacity(ACapacity);\r\nend;\r\n\r\ndestructor TJclExtendedStack.Destroy;\r\nbegin\r\n FReadOnly := False;\r\n Clear;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJclExtendedStack.AssignDataTo(Dest: TJclAbstractContainerBase);\r\nvar\r\n ADest: TJclExtendedStack;\r\n I: Integer;\r\nbegin\r\n inherited AssignDataTo(Dest);\r\n if Dest is TJclExtendedStack then\r\n begin\r\n ADest := TJclExtendedStack(Dest);\r\n ADest.Clear;\r\n ADest.SetCapacity(FSize + 1);\r\n for I := 0 to FSize - 1 do\r\n ADest.FElements[I] := FElements[I];\r\n ADest.FSize := FSize;\r\n end;\r\nend;\r\n\r\nprocedure TJclExtendedStack.Clear;\r\nvar\r\n I: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n for I := 0 to FSize - 1 do\r\n FreeExtended(FElements[I]);\r\n FSize := 0;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclExtendedStack.Contains(const AValue: Extended): Boolean;\r\nvar\r\n I: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n for I := 0 to FSize - 1 do\r\n if ItemsEqual(FElements[I], AValue) then\r\n begin\r\n Result := True;\r\n Break;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclExtendedStack.Empty: Boolean;\r\nbegin\r\n Result := FSize = 0;\r\nend;\r\n\r\nfunction TJclExtendedStack.Peek: Extended;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := 0.0;\r\n if FSize > 0 then\r\n Result := FElements[FSize - 1]\r\n else\r\n if not FReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclExtendedStack.Pop: Extended;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := 0.0;\r\n if FSize > 0 then\r\n begin\r\n Dec(FSize);\r\n Result := FElements[FSize];\r\n FElements[FSize] := 0.0;\r\n end\r\n else\r\n if not FReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n AutoPack;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclExtendedStack.Push(const AValue: Extended): Boolean;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FSize = FCapacity then\r\n AutoGrow;\r\n Result := FSize < FCapacity;\r\n if Result then\r\n begin\r\n FElements[FSize] := AValue;\r\n Inc(FSize);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclExtendedStack.SetCapacity(Value: Integer);\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Value < FSize then\r\n raise EJclOutOfBoundsError.Create;\r\n SetLength(FElements, Value);\r\n inherited SetCapacity(Value);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclExtendedStack.Size: Integer;\r\nbegin\r\n Result := FSize;\r\nend;\r\n\r\nfunction TJclExtendedStack.CreateEmptyContainer: TJclAbstractContainerBase;\r\nbegin\r\n Result := TJclExtendedStack.Create(FSize);\r\n AssignPropertiesTo(Result);\r\nend;\r\n\r\n//=== { TJclIntegerStack } =======================================================\r\n\r\nconstructor TJclIntegerStack.Create(ACapacity: Integer);\r\nbegin\r\n inherited Create();\r\n SetCapacity(ACapacity);\r\nend;\r\n\r\ndestructor TJclIntegerStack.Destroy;\r\nbegin\r\n FReadOnly := False;\r\n Clear;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJclIntegerStack.AssignDataTo(Dest: TJclAbstractContainerBase);\r\nvar\r\n ADest: TJclIntegerStack;\r\n I: Integer;\r\nbegin\r\n inherited AssignDataTo(Dest);\r\n if Dest is TJclIntegerStack then\r\n begin\r\n ADest := TJclIntegerStack(Dest);\r\n ADest.Clear;\r\n ADest.SetCapacity(FSize + 1);\r\n for I := 0 to FSize - 1 do\r\n ADest.FElements[I] := FElements[I];\r\n ADest.FSize := FSize;\r\n end;\r\nend;\r\n\r\nprocedure TJclIntegerStack.Clear;\r\nvar\r\n I: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n for I := 0 to FSize - 1 do\r\n FreeInteger(FElements[I]);\r\n FSize := 0;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntegerStack.Contains(AValue: Integer): Boolean;\r\nvar\r\n I: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n for I := 0 to FSize - 1 do\r\n if ItemsEqual(FElements[I], AValue) then\r\n begin\r\n Result := True;\r\n Break;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntegerStack.Empty: Boolean;\r\nbegin\r\n Result := FSize = 0;\r\nend;\r\n\r\nfunction TJclIntegerStack.Peek: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := 0;\r\n if FSize > 0 then\r\n Result := FElements[FSize - 1]\r\n else\r\n if not FReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntegerStack.Pop: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := 0;\r\n if FSize > 0 then\r\n begin\r\n Dec(FSize);\r\n Result := FElements[FSize];\r\n FElements[FSize] := 0;\r\n end\r\n else\r\n if not FReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n AutoPack;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntegerStack.Push(AValue: Integer): Boolean;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FSize = FCapacity then\r\n AutoGrow;\r\n Result := FSize < FCapacity;\r\n if Result then\r\n begin\r\n FElements[FSize] := AValue;\r\n Inc(FSize);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclIntegerStack.SetCapacity(Value: Integer);\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Value < FSize then\r\n raise EJclOutOfBoundsError.Create;\r\n SetLength(FElements, Value);\r\n inherited SetCapacity(Value);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntegerStack.Size: Integer;\r\nbegin\r\n Result := FSize;\r\nend;\r\n\r\nfunction TJclIntegerStack.CreateEmptyContainer: TJclAbstractContainerBase;\r\nbegin\r\n Result := TJclIntegerStack.Create(FSize);\r\n AssignPropertiesTo(Result);\r\nend;\r\n\r\n//=== { TJclCardinalStack } =======================================================\r\n\r\nconstructor TJclCardinalStack.Create(ACapacity: Integer);\r\nbegin\r\n inherited Create();\r\n SetCapacity(ACapacity);\r\nend;\r\n\r\ndestructor TJclCardinalStack.Destroy;\r\nbegin\r\n FReadOnly := False;\r\n Clear;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJclCardinalStack.AssignDataTo(Dest: TJclAbstractContainerBase);\r\nvar\r\n ADest: TJclCardinalStack;\r\n I: Integer;\r\nbegin\r\n inherited AssignDataTo(Dest);\r\n if Dest is TJclCardinalStack then\r\n begin\r\n ADest := TJclCardinalStack(Dest);\r\n ADest.Clear;\r\n ADest.SetCapacity(FSize + 1);\r\n for I := 0 to FSize - 1 do\r\n ADest.FElements[I] := FElements[I];\r\n ADest.FSize := FSize;\r\n end;\r\nend;\r\n\r\nprocedure TJclCardinalStack.Clear;\r\nvar\r\n I: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n for I := 0 to FSize - 1 do\r\n FreeCardinal(FElements[I]);\r\n FSize := 0;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclCardinalStack.Contains(AValue: Cardinal): Boolean;\r\nvar\r\n I: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n for I := 0 to FSize - 1 do\r\n if ItemsEqual(FElements[I], AValue) then\r\n begin\r\n Result := True;\r\n Break;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclCardinalStack.Empty: Boolean;\r\nbegin\r\n Result := FSize = 0;\r\nend;\r\n\r\nfunction TJclCardinalStack.Peek: Cardinal;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := 0;\r\n if FSize > 0 then\r\n Result := FElements[FSize - 1]\r\n else\r\n if not FReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclCardinalStack.Pop: Cardinal;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := 0;\r\n if FSize > 0 then\r\n begin\r\n Dec(FSize);\r\n Result := FElements[FSize];\r\n FElements[FSize] := 0;\r\n end\r\n else\r\n if not FReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n AutoPack;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclCardinalStack.Push(AValue: Cardinal): Boolean;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FSize = FCapacity then\r\n AutoGrow;\r\n Result := FSize < FCapacity;\r\n if Result then\r\n begin\r\n FElements[FSize] := AValue;\r\n Inc(FSize);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclCardinalStack.SetCapacity(Value: Integer);\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Value < FSize then\r\n raise EJclOutOfBoundsError.Create;\r\n SetLength(FElements, Value);\r\n inherited SetCapacity(Value);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclCardinalStack.Size: Integer;\r\nbegin\r\n Result := FSize;\r\nend;\r\n\r\nfunction TJclCardinalStack.CreateEmptyContainer: TJclAbstractContainerBase;\r\nbegin\r\n Result := TJclCardinalStack.Create(FSize);\r\n AssignPropertiesTo(Result);\r\nend;\r\n\r\n//=== { TJclInt64Stack } =======================================================\r\n\r\nconstructor TJclInt64Stack.Create(ACapacity: Integer);\r\nbegin\r\n inherited Create();\r\n SetCapacity(ACapacity);\r\nend;\r\n\r\ndestructor TJclInt64Stack.Destroy;\r\nbegin\r\n FReadOnly := False;\r\n Clear;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJclInt64Stack.AssignDataTo(Dest: TJclAbstractContainerBase);\r\nvar\r\n ADest: TJclInt64Stack;\r\n I: Integer;\r\nbegin\r\n inherited AssignDataTo(Dest);\r\n if Dest is TJclInt64Stack then\r\n begin\r\n ADest := TJclInt64Stack(Dest);\r\n ADest.Clear;\r\n ADest.SetCapacity(FSize + 1);\r\n for I := 0 to FSize - 1 do\r\n ADest.FElements[I] := FElements[I];\r\n ADest.FSize := FSize;\r\n end;\r\nend;\r\n\r\nprocedure TJclInt64Stack.Clear;\r\nvar\r\n I: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n for I := 0 to FSize - 1 do\r\n FreeInt64(FElements[I]);\r\n FSize := 0;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclInt64Stack.Contains(const AValue: Int64): Boolean;\r\nvar\r\n I: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n for I := 0 to FSize - 1 do\r\n if ItemsEqual(FElements[I], AValue) then\r\n begin\r\n Result := True;\r\n Break;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclInt64Stack.Empty: Boolean;\r\nbegin\r\n Result := FSize = 0;\r\nend;\r\n\r\nfunction TJclInt64Stack.Peek: Int64;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := 0;\r\n if FSize > 0 then\r\n Result := FElements[FSize - 1]\r\n else\r\n if not FReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclInt64Stack.Pop: Int64;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := 0;\r\n if FSize > 0 then\r\n begin\r\n Dec(FSize);\r\n Result := FElements[FSize];\r\n FElements[FSize] := 0;\r\n end\r\n else\r\n if not FReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n AutoPack;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclInt64Stack.Push(const AValue: Int64): Boolean;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FSize = FCapacity then\r\n AutoGrow;\r\n Result := FSize < FCapacity;\r\n if Result then\r\n begin\r\n FElements[FSize] := AValue;\r\n Inc(FSize);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclInt64Stack.SetCapacity(Value: Integer);\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Value < FSize then\r\n raise EJclOutOfBoundsError.Create;\r\n SetLength(FElements, Value);\r\n inherited SetCapacity(Value);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclInt64Stack.Size: Integer;\r\nbegin\r\n Result := FSize;\r\nend;\r\n\r\nfunction TJclInt64Stack.CreateEmptyContainer: TJclAbstractContainerBase;\r\nbegin\r\n Result := TJclInt64Stack.Create(FSize);\r\n AssignPropertiesTo(Result);\r\nend;\r\n\r\n//=== { TJclPtrStack } =======================================================\r\n\r\nconstructor TJclPtrStack.Create(ACapacity: Integer);\r\nbegin\r\n inherited Create();\r\n SetCapacity(ACapacity);\r\nend;\r\n\r\ndestructor TJclPtrStack.Destroy;\r\nbegin\r\n FReadOnly := False;\r\n Clear;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJclPtrStack.AssignDataTo(Dest: TJclAbstractContainerBase);\r\nvar\r\n ADest: TJclPtrStack;\r\n I: Integer;\r\nbegin\r\n inherited AssignDataTo(Dest);\r\n if Dest is TJclPtrStack then\r\n begin\r\n ADest := TJclPtrStack(Dest);\r\n ADest.Clear;\r\n ADest.SetCapacity(FSize + 1);\r\n for I := 0 to FSize - 1 do\r\n ADest.FElements[I] := FElements[I];\r\n ADest.FSize := FSize;\r\n end;\r\nend;\r\n\r\nprocedure TJclPtrStack.Clear;\r\nvar\r\n I: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n for I := 0 to FSize - 1 do\r\n FreePointer(FElements[I]);\r\n FSize := 0;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclPtrStack.Contains(APtr: Pointer): Boolean;\r\nvar\r\n I: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n for I := 0 to FSize - 1 do\r\n if ItemsEqual(FElements[I], APtr) then\r\n begin\r\n Result := True;\r\n Break;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclPtrStack.Empty: Boolean;\r\nbegin\r\n Result := FSize = 0;\r\nend;\r\n\r\nfunction TJclPtrStack.Peek: Pointer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := nil;\r\n if FSize > 0 then\r\n Result := FElements[FSize - 1]\r\n else\r\n if not FReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclPtrStack.Pop: Pointer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := nil;\r\n if FSize > 0 then\r\n begin\r\n Dec(FSize);\r\n Result := FElements[FSize];\r\n FElements[FSize] := nil;\r\n end\r\n else\r\n if not FReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n AutoPack;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclPtrStack.Push(APtr: Pointer): Boolean;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FSize = FCapacity then\r\n AutoGrow;\r\n Result := FSize < FCapacity;\r\n if Result then\r\n begin\r\n FElements[FSize] := APtr;\r\n Inc(FSize);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclPtrStack.SetCapacity(Value: Integer);\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Value < FSize then\r\n raise EJclOutOfBoundsError.Create;\r\n SetLength(FElements, Value);\r\n inherited SetCapacity(Value);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclPtrStack.Size: Integer;\r\nbegin\r\n Result := FSize;\r\nend;\r\n\r\nfunction TJclPtrStack.CreateEmptyContainer: TJclAbstractContainerBase;\r\nbegin\r\n Result := TJclPtrStack.Create(FSize);\r\n AssignPropertiesTo(Result);\r\nend;\r\n\r\n//=== { TJclStack } =======================================================\r\n\r\nconstructor TJclStack.Create(ACapacity: Integer; AOwnsObjects: Boolean);\r\nbegin\r\n inherited Create(AOwnsObjects);\r\n SetCapacity(ACapacity);\r\nend;\r\n\r\ndestructor TJclStack.Destroy;\r\nbegin\r\n FReadOnly := False;\r\n Clear;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJclStack.AssignDataTo(Dest: TJclAbstractContainerBase);\r\nvar\r\n ADest: TJclStack;\r\n I: Integer;\r\nbegin\r\n inherited AssignDataTo(Dest);\r\n if Dest is TJclStack then\r\n begin\r\n ADest := TJclStack(Dest);\r\n ADest.Clear;\r\n ADest.SetCapacity(FSize + 1);\r\n for I := 0 to FSize - 1 do\r\n ADest.FElements[I] := FElements[I];\r\n ADest.FSize := FSize;\r\n end;\r\nend;\r\n\r\nprocedure TJclStack.Clear;\r\nvar\r\n I: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n for I := 0 to FSize - 1 do\r\n FreeObject(FElements[I]);\r\n FSize := 0;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclStack.Contains(AObject: TObject): Boolean;\r\nvar\r\n I: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n for I := 0 to FSize - 1 do\r\n if ItemsEqual(FElements[I], AObject) then\r\n begin\r\n Result := True;\r\n Break;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclStack.Empty: Boolean;\r\nbegin\r\n Result := FSize = 0;\r\nend;\r\n\r\nfunction TJclStack.Peek: TObject;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := nil;\r\n if FSize > 0 then\r\n Result := FElements[FSize - 1]\r\n else\r\n if not FReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclStack.Pop: TObject;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := nil;\r\n if FSize > 0 then\r\n begin\r\n Dec(FSize);\r\n Result := FElements[FSize];\r\n FElements[FSize] := nil;\r\n end\r\n else\r\n if not FReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n AutoPack;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclStack.Push(AObject: TObject): Boolean;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FSize = FCapacity then\r\n AutoGrow;\r\n Result := FSize < FCapacity;\r\n if Result then\r\n begin\r\n FElements[FSize] := AObject;\r\n Inc(FSize);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclStack.SetCapacity(Value: Integer);\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Value < FSize then\r\n raise EJclOutOfBoundsError.Create;\r\n SetLength(FElements, Value);\r\n inherited SetCapacity(Value);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclStack.Size: Integer;\r\nbegin\r\n Result := FSize;\r\nend;\r\n\r\nfunction TJclStack.CreateEmptyContainer: TJclAbstractContainerBase;\r\nbegin\r\n Result := TJclStack.Create(FSize, False);\r\n AssignPropertiesTo(Result);\r\nend;\r\n\r\n\r\n{$IFDEF SUPPORTS_GENERICS}\r\n//DOM-IGNORE-BEGIN\r\n\r\n//=== { TJclStack } =======================================================\r\n\r\nconstructor TJclStack.Create(ACapacity: Integer; AOwnsItems: Boolean);\r\nbegin\r\n inherited Create(AOwnsItems);\r\n SetCapacity(ACapacity);\r\nend;\r\n\r\ndestructor TJclStack.Destroy;\r\nbegin\r\n FReadOnly := False;\r\n Clear;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJclStack.AssignDataTo(Dest: TJclAbstractContainerBase);\r\nvar\r\n ADest: TJclStack;\r\n I: Integer;\r\nbegin\r\n inherited AssignDataTo(Dest);\r\n if Dest is TJclStack then\r\n begin\r\n ADest := TJclStack(Dest);\r\n ADest.Clear;\r\n ADest.SetCapacity(FSize + 1);\r\n for I := 0 to FSize - 1 do\r\n ADest.FElements[I] := FElements[I];\r\n ADest.FSize := FSize;\r\n end;\r\nend;\r\n\r\nprocedure TJclStack.Clear;\r\nvar\r\n I: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n for I := 0 to FSize - 1 do\r\n FreeItem(FElements[I]);\r\n FSize := 0;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclStack.Contains(const AItem: T): Boolean;\r\nvar\r\n I: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n for I := 0 to FSize - 1 do\r\n if ItemsEqual(FElements[I], AItem) then\r\n begin\r\n Result := True;\r\n Break;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclStack.Empty: Boolean;\r\nbegin\r\n Result := FSize = 0;\r\nend;\r\n\r\nfunction TJclStack.Peek: T;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := Default(T);\r\n if FSize > 0 then\r\n Result := FElements[FSize - 1]\r\n else\r\n if not FReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclStack.Pop: T;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := Default(T);\r\n if FSize > 0 then\r\n begin\r\n Dec(FSize);\r\n Result := FElements[FSize];\r\n FElements[FSize] := Default(T);\r\n end\r\n else\r\n if not FReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n AutoPack;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclStack.Push(const AItem: T): Boolean;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FSize = FCapacity then\r\n AutoGrow;\r\n Result := FSize < FCapacity;\r\n if Result then\r\n begin\r\n FElements[FSize] := AItem;\r\n Inc(FSize);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclStack.SetCapacity(Value: Integer);\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Value < FSize then\r\n raise EJclOutOfBoundsError.Create;\r\n SetLength(FElements, Value);\r\n inherited SetCapacity(Value);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclStack.Size: Integer;\r\nbegin\r\n Result := FSize;\r\nend;\r\n\r\n//=== { TJclStackE } ======================================================\r\n\r\nconstructor TJclStackE.Create(const AEqualityComparer: IEqualityComparer; ACapacity: Integer;\r\n AOwnsItems: Boolean);\r\nbegin\r\n inherited Create(ACapacity, AOwnsItems);\r\n FEqualityComparer := AEqualityComparer;\r\nend;\r\n\r\nprocedure TJclStackE.AssignPropertiesTo(Dest: TJclAbstractContainerBase);\r\nbegin\r\n inherited AssignPropertiesTo(Dest);\r\n if Dest is TJclStackE then\r\n TJclStackE(Dest).FEqualityComparer := FEqualityComparer;\r\nend;\r\n\r\nfunction TJclStackE.CreateEmptyContainer: TJclAbstractContainerBase;\r\nbegin\r\n Result := TJclStackE.Create(FEqualityComparer, FSize, False);\r\n AssignPropertiesTo(Result);\r\nend;\r\n\r\nfunction TJclStackE.ItemsEqual(const A, B: T): Boolean;\r\nbegin\r\n if EqualityComparer <> nil then\r\n Result := EqualityComparer.Equals(A, B)\r\n else\r\n Result := inherited ItemsEqual(A, B);\r\nend;\r\n\r\n//=== { TJclStackF } ======================================================\r\n\r\nconstructor TJclStackF.Create(AEqualityCompare: TEqualityCompare; ACapacity: Integer; AOwnsItems: Boolean);\r\nbegin\r\n inherited Create(ACapacity, AOwnsItems);\r\n SetEqualityCompare(AEqualityCompare);\r\nend;\r\n\r\nfunction TJclStackF.CreateEmptyContainer: TJclAbstractContainerBase;\r\nbegin\r\n Result := TJclStackF.Create(FEqualityCompare, FSize + 1, False);\r\n AssignPropertiesTo(Result);\r\nend;\r\n\r\n//=== { TJclStackI } ======================================================\r\n\r\nfunction TJclStackI.CreateEmptyContainer: TJclAbstractContainerBase;\r\nbegin\r\n Result := TJclStackI.Create(FSize + 1, False);\r\n AssignPropertiesTo(Result);\r\nend;\r\n\r\nfunction TJclStackI.ItemsEqual(const A, B: T): Boolean;\r\nbegin\r\n if Assigned(FEqualityCompare) then\r\n Result := FEqualityCompare(A, B)\r\n else\r\n if Assigned(FCompare) then\r\n Result := FCompare(A, B) = 0\r\n else\r\n Result := A.Equals(B);\r\nend;\r\n\r\n//DOM-IGNORE-END\r\n{$ENDIF SUPPORTS_GENERICS}\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jcl/source/common/JclStatistics.pas", "content": "{**************************************************************************************************}\r\n{ }\r\n{ Project JEDI Code Library (JCL) }\r\n{ }\r\n{ The contents of this file are subject to the Mozilla Public License Version 1.1 (the \"License\"); }\r\n{ you may not use this file except in compliance with the License. You may obtain a copy of the }\r\n{ License at http://www.mozilla.org/MPL/ }\r\n{ }\r\n{ Software distributed under the License is distributed on an \"AS IS\" basis, WITHOUT WARRANTY OF }\r\n{ ANY KIND, either express or implied. See the License for the specific language governing rights }\r\n{ and limitations under the License. }\r\n{ }\r\n{ The Original Code is JclStatistics.pas. }\r\n{ }\r\n{ The Initial Developer of the Original Code is ESB Consultancy. }\r\n{ Portions created by ESB Consultancy are Copyright ESB Consultancy. All rights reserved. }\r\n{ }\r\n{ Contributors (in alphabetical order): }\r\n{ ESB Consultancy }\r\n{ Fred Hovey }\r\n{ Marcel van Brakel }\r\n{ Matthias Thoma }\r\n{ Robert Marquardt }\r\n{ Robert Rossmair }\r\n{ Petr Vones }\r\n{ }\r\n{**************************************************************************************************}\r\n{ }\r\n{ Various common statistics routines to calculate, for example, the arithmetic mean, geometric }\r\n{ meanor median of a set of numbers. }\r\n{ }\r\n{**************************************************************************************************}\r\n{ }\r\n{ Last modified: $Date:: 2009-07-30 12:08:05 +0200 (jeu. 30 juil. 2009) $ }\r\n{ Revision: $Rev:: 2892 $ }\r\n{ Author: $Author:: outchy $ }\r\n{ }\r\n{**************************************************************************************************}\r\n\r\n{ TODO : Test cases! }\r\n\r\nunit JclStatistics;\r\n\r\n{$I jcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n JclBase, JclMath;\r\n\r\ntype\r\n EJclStatisticsError = class(EJclMathError);\r\n\r\n{ Mean functions }\r\n\r\nfunction ArithmeticMean(const X: TDynFloatArray): Float;\r\nfunction GeometricMean(const X: TDynFloatArray): Float;\r\nfunction HarmonicMean(const X: TDynFloatArray): Float;\r\nfunction HeronianMean(const A, B: Float): Float;\r\n\r\n{ Miscellanous }\r\n\r\nfunction BinomialCoeff(N, R: Cardinal): Float;\r\nfunction IsPositiveFloatArray(const X: TDynFloatArray): Boolean;\r\nfunction MaxFloatArray(const B: TDynFloatArray): Float;\r\nfunction MaxFloatArrayIndex(const B: TDynFloatArray): Integer;\r\nfunction Median(const X: TDynFloatArray): Float;\r\nfunction MedianUnsorted(const X: TDynFloatArray): Float;\r\nfunction MinFloatArray(const B: TDynFloatArray): Float;\r\nfunction MinFloatArrayIndex(const B: TDynFloatArray): Integer;\r\nfunction Permutation(N, R: Cardinal): Float;\r\nfunction Combinations(N, R: Cardinal): Float;\r\nfunction SumOfSquares(const X: TDynFloatArray): Float;\r\nfunction PopulationVariance(const X: TDynFloatArray): Float;\r\nprocedure PopulationVarianceAndMean(const X: TDynFloatArray; var Variance, Mean: Float);\r\nfunction SampleVariance(const X: TDynFloatArray): Float;\r\nprocedure SampleVarianceAndMean(const X: TDynFloatArray; var Variance, Mean: Float);\r\nfunction StdError(const X: TDynFloatArray): Float; overload;\r\nfunction StdError(const Variance: Float; const SampleSize: Integer): Float; overload;\r\nfunction SumFloatArray(const B: TDynFloatArray): Float;\r\nfunction SumSquareDiffFloatArray(const B: TDynFloatArray; Diff: Float): Float;\r\nfunction SumSquareFloatArray(const B: TDynFloatArray): Float;\r\nfunction SumPairProductFloatArray(const X, Y: TDynFloatArray): Float;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jcl.svn.sourceforge.net/svnroot/jcl/tags/JCL-2.4-Build4571/jcl/source/common/JclStatistics.pas $';\r\n Revision: '$Revision: 2892 $';\r\n Date: '$Date: 2009-07-30 12:08:05 +0200 (jeu. 30 juil. 2009) $';\r\n LogPath: 'JCL\\source\\common';\r\n Extra: '';\r\n Data: nil\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n JclLogic,\r\n JclSysUtils,\r\n JclResources;\r\n\r\n//=== Local helpers ==========================================================\r\n\r\nfunction GetDynLength(const X: TDynFloatArray): Integer;\r\nbegin\r\n Result := Length(X);\r\nend;\r\n\r\nfunction GetDynLengthNotNull(const X: TDynFloatArray): Integer;\r\nbegin\r\n Result := Length(X);\r\n if Result = 0 then\r\n raise EJclMathError.CreateRes(@RsEmptyArray);\r\nend;\r\n\r\nprocedure InvalidSampleSize(SampleSize: Integer);\r\nbegin\r\n raise EJclStatisticsError.CreateResFmt(@RsInvalidSampleSize, [SampleSize]);\r\nend;\r\n\r\nfunction GetSampleSize(const Sample: TDynFloatArray; MinValidSize: Integer = 1): Integer;\r\nbegin\r\n Result := Length(Sample);\r\n if Result < MinValidSize then\r\n InvalidSampleSize(Result);\r\nend;\r\n\r\n//=== Mean Functions =========================================================\r\n\r\nfunction ArithmeticMean(const X: TDynFloatArray): Float;\r\nbegin\r\n Result := SumFloatArray(X) / Length(X);\r\nend;\r\n\r\nfunction GeometricMean(const X: TDynFloatArray): Float;\r\nvar\r\n I, N: Integer;\r\nbegin\r\n N := GetSampleSize(X);\r\n Result := 1.0;\r\n for I := 0 to N - 1 do\r\n begin\r\n if X[I] <= PrecisionTolerance then\r\n raise EJclMathError.CreateRes(@RsNonPositiveArray);\r\n Result := Result * X[I];\r\n end;\r\n Result := Power(Result, 1 / N);\r\nend;\r\n\r\nfunction HarmonicMean(const X: TDynFloatArray): Float;\r\nvar\r\n I, N: Integer;\r\nbegin\r\n Result := 0.0;\r\n N := GetSampleSize(X);\r\n for I := 0 to N - 1 do\r\n begin\r\n if X[I] <= PrecisionTolerance then\r\n raise EJclMathError.CreateRes(@RsNonPositiveArray);\r\n Result := Result + 1 / X[I];\r\n end;\r\n Result := N / Result;\r\nend;\r\n\r\nfunction HeronianMean(const A, B: Float): Float;\r\nbegin\r\n Assert(A >= 0);\r\n Assert(B >= 0);\r\n Result := (A + Sqrt(A * B) + B) / 3;\r\nend;\r\n\r\n//=== Miscellanous ===========================================================\r\n\r\nfunction BinomialCoeff(N, R: Cardinal): Float;\r\nvar\r\n I: Integer;\r\n K: LongWord;\r\nbegin\r\n if (N = 0) or (R > N) or (N > MaxFactorial) then\r\n begin\r\n Result := 0.0;\r\n Exit;\r\n end;\r\n Result := 1.0;\r\n if not ((R = 0) or (R = N)) then\r\n begin\r\n if R > N div 2 then\r\n R := N - R;\r\n K := 2;\r\n try\r\n for I := N - R + 1 to N do\r\n begin\r\n Result := Result * I;\r\n if K <= R then\r\n begin\r\n Result := Result / K;\r\n Inc(K);\r\n end;\r\n end;\r\n Result := Int(Result + 0.5);\r\n except\r\n Result := -1.0;\r\n end;\r\n end;\r\nend;\r\n\r\n\r\nfunction IsPositiveFloatArray(const X: TDynFloatArray): Boolean;\r\nvar\r\n I, N: Integer;\r\nbegin\r\n Result := False;\r\n N := GetDynLengthNotNull(X);\r\n for I := 0 to N - 1 do\r\n if X[I] <= PrecisionTolerance then\r\n Exit;\r\n Result := True;\r\nend;\r\n\r\nfunction MaxFloatArray(const B: TDynFloatArray): Float;\r\nvar\r\n I, N: Integer;\r\nbegin\r\n N := GetDynLengthNotNull(B);\r\n Result := B[0];\r\n for I := 1 to N - 1 do\r\n if B[I] > Result then\r\n Result := B[I];\r\nend;\r\n\r\nfunction MaxFloatArrayIndex(const B: TDynFloatArray): Integer;\r\nvar\r\n I, N: Integer;\r\n Max: Float;\r\nbegin\r\n Result := 0;\r\n N := GetDynLengthNotNull(B);\r\n Max := B[0];\r\n for I := 1 to N - 1 do\r\n if B[I] > Max then\r\n begin\r\n Max := B[I];\r\n Result := I;\r\n end;\r\nend;\r\n\r\n// The FloatArray X must be presorted so Median can calculate the correct value.\r\n// Y_{(n+1)/2} if N is odd\r\n// Median = { 1/2 * (Y_{n/2} + Y_{1+(n/2) } if N is even\r\n\r\nfunction Median(const X: TDynFloatArray): Float;\r\nvar\r\n N: Integer;\r\nbegin\r\n N := GetSampleSize(X);\r\n if N = 1 then\r\n Result := X[0]\r\n else\r\n if Odd(N) then\r\n Result := X[N div 2]\r\n else\r\n Result := (X[N div 2 - 1] + X[N div 2]) / 2;\r\nend;\r\n\r\nfunction MedianUnsorted(const X: TDynFloatArray): Float;\r\nvar\r\n SortedList: TDynFloatArray;\r\n\r\nbegin\r\n // We need to sort the values first\r\n SortedList := Copy(X);\r\n // type cast to Pointer for the sake of FPC\r\n SortDynArray(Pointer(SortedList), SizeOf(Float),DynArrayCompareFloat);\r\n\r\n // and call the median function afterwards\r\n Result := Median(SortedList);\r\nend;\r\n\r\nfunction MinFloatArray(const B: TDynFloatArray): Float;\r\nvar\r\n I, N: Integer;\r\nbegin\r\n N := GetDynLengthNotNull(B);\r\n Result := B[0];\r\n for I := 1 to N - 1 do\r\n if B[I] < Result then\r\n Result := B[I];\r\nend;\r\n\r\nfunction MinFloatArrayIndex(const B: TDynFloatArray): Integer;\r\nvar\r\n I, N: Integer;\r\n Min: Float;\r\nbegin\r\n Result := 0;\r\n N := GetDynLengthNotNull(B);\r\n Min := B[0];\r\n for I := 1 to N - 1 do\r\n if B[I] < Min then\r\n begin\r\n Min := B[I];\r\n Result := I;\r\n end;\r\nend;\r\n\r\nfunction Permutation(N, R: Cardinal): Float;\r\nvar\r\n I : Integer;\r\nbegin\r\n if (N = 0) or (R > N) or (N > MaxFactorial) then\r\n begin\r\n Result := 0.0;\r\n Exit;\r\n end;\r\n Result := 1.0;\r\n if R <> 0 then\r\n try\r\n for I := N downto N - R + 1 do\r\n Result := Result * I;\r\n Result := Int(Result + 0.5);\r\n except\r\n Result := -1.0;\r\n end;\r\nend;\r\n\r\n{ TODO -cDoc : Donator: Fred Hovey }\r\nfunction Combinations(N, R: Cardinal): Float;\r\nbegin\r\n Result := Factorial(R);\r\n if IsFloatZero(Result) then\r\n Result := -1.0\r\n else\r\n Result := Permutation(N, R) / Result;\r\nend;\r\n\r\n{ TODO -cDoc : donator: Fred Hovey, contributor: Robert Rossmair }\r\nfunction SumOfSquares(const X: TDynFloatArray): Float;\r\nvar\r\n I, N: Integer;\r\n Sum: Float;\r\nbegin\r\n N := GetSampleSize(X);\r\n Result := Sqr(X[0]);\r\n Sum := X[0];\r\n for I := 1 to N - 1 do\r\n begin\r\n Result := Result + Sqr(X[I]);\r\n Sum := Sum + X[I];\r\n end;\r\n Result := Result - Sum * Sum / N;\r\nend;\r\n\r\n{ TODO -cDoc : Contributors: Fred Hovey, Robert Rossmair }\r\nfunction PopulationVariance(const X: TDynFloatArray): Float;\r\nbegin\r\n // Length(X) = 0 would cause SumOfSquares() to raise an exception before the division is executed.\r\n Result := SumOfSquares(X) / Length(X);\r\nend;\r\n\r\nprocedure PopulationVarianceAndMean(const X: TDynFloatArray; var Variance, Mean: Float);\r\nvar\r\n I, N: Integer;\r\n Sum, SumSq: Float;\r\nbegin\r\n N := GetSampleSize(X);\r\n SumSq := Sqr(X[0]);\r\n Sum := X[0];\r\n for I := 1 to N - 1 do\r\n begin\r\n SumSq := SumSq + Sqr(X[I]);\r\n Sum := Sum + X[I];\r\n end;\r\n Mean := Sum / N;\r\n Variance := (SumSq / N) - Sqr(Mean);\r\nend;\r\n\r\n{ TODO -cDoc : Contributors: Fred Hovey, Robert Rossmair }\r\nfunction SampleVariance(const X: TDynFloatArray): Float;\r\nvar\r\n N: Integer;\r\nbegin\r\n N := GetSampleSize(X, 2);\r\n Result := SumOfSquares(X) / (N - 1)\r\nend;\r\n\r\n{ TODO -cDoc : Contributors: Fred Hovey, Robert Rossmair }\r\nprocedure SampleVarianceAndMean(const X: TDynFloatArray; var Variance, Mean: Float);\r\nvar\r\n I, N: Integer;\r\n Sum, SumSq: Float;\r\nbegin\r\n N := GetSampleSize(X);\r\n SumSq := Sqr(X[0]);\r\n Sum := X[0];\r\n for I := 1 to N - 1 do\r\n begin\r\n SumSq := SumSq + Sqr(X[I]);\r\n Sum := Sum + X[I];\r\n end;\r\n Mean := Sum / N;\r\n if N < 2 then\r\n InvalidSampleSize(N);\r\n //Variance := (SumSq / (N - 1)) - Sqr(Sum / (N - 1)) => WRONG!!!!\r\n Variance := (SumSq - Sum * Sum / N) / (N - 1)\r\nend;\r\n\r\n{ TODO -cDoc : Donator: Fred Hovey, contributor: Robert Rossmair }\r\nfunction StdError(const X: TDynFloatArray): Float;\r\nbegin\r\n // Length(X) = 0 would cause SampleVariance() to raise an exception before the division is\r\n // executed.\r\n Result := Sqrt(SampleVariance(X) / Length(X));\r\nend;\r\n\r\n{ TODO -cDoc : Donator: Fred Hovey, contributor: Robert Rossmair }\r\nfunction StdError(const Variance: Float; const SampleSize: Integer): Float;\r\nbegin\r\n if SampleSize = 0 then\r\n InvalidSampleSize(SampleSize);\r\n Result := Sqrt(Variance / SampleSize);\r\nend;\r\n\r\nfunction SumFloatArray(const B: TDynFloatArray): Float;\r\nvar\r\n I, N: Integer;\r\nbegin\r\n Result := 0.0;\r\n N := GetDynLength(B);\r\n if N <> 0 then\r\n begin\r\n Result := B[0];\r\n for I := 1 to N - 1 do\r\n Result := Result + B[I];\r\n end;\r\nend;\r\n\r\nfunction SumSquareDiffFloatArray(const B: TDynFloatArray; Diff: Float): Float;\r\nvar\r\n I, N: Integer;\r\nbegin\r\n Result := 0.0;\r\n N := GetDynLength(B);\r\n if N <> 0 then\r\n begin\r\n Result := Sqr(B[0] - Diff);\r\n for I := 1 to N - 1 do\r\n Result := Result + Sqr(B[I] - Diff);\r\n end;\r\nend;\r\n\r\nfunction SumSquareFloatArray(const B: TDynFloatArray): Float;\r\nvar\r\n I, N: Integer;\r\nbegin\r\n Result := 0.0;\r\n N := GetDynLength(B);\r\n if N <> 0 then\r\n begin\r\n Result := Sqr(B[0]);\r\n for I := 1 to N - 1 do\r\n Result := Result + Sqr(B[I]);\r\n end;\r\nend;\r\n\r\nfunction SumPairProductFloatArray(const X, Y: TDynFloatArray): Float;\r\nvar\r\n I, N: Integer;\r\nbegin\r\n Result := 0.0;\r\n N := Min(Length(X), Length(Y));\r\n if N <> 0 then\r\n begin\r\n Result := X[0] * Y[0];\r\n for I := 1 to N - 1 do\r\n Result := Result + X[I] * Y[I];\r\n end;\r\nend;\r\n\r\nfunction ChiSquare(const X: TDynFloatArray): Float; { TODO -cDoc : ChiSquare }\r\nvar\r\n I, N: Integer;\r\n Sum: Float;\r\nbegin\r\n N := GetDynLengthNotNull(X);\r\n Result := Sqr(X[0]);\r\n Sum := X[0];\r\n for I := 1 to N - 1 do\r\n begin\r\n Result := Result + Sqr(X[I]);\r\n Sum := Sum + X[I];\r\n end;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jcl/source/common/JclStrHashMap.pas", "content": "{**************************************************************************************************}\r\n{ }\r\n{ Project JEDI Code Library (JCL) }\r\n{ }\r\n{ The contents of this file are subject to the Mozilla Public License Version 1.1 (the \"License\"); }\r\n{ you may not use this file except in compliance with the License. You may obtain a copy of the }\r\n{ License at http://www.mozilla.org/MPL/ }\r\n{ }\r\n{ Software distributed under the License is distributed on an \"AS IS\" basis, WITHOUT WARRANTY OF }\r\n{ ANY KIND, either express or implied. See the License for the specific language governing rights }\r\n{ and limitations under the License. }\r\n{ }\r\n{ The Original Code is JclStrHashMap.pas. }\r\n{ }\r\n{ The Initial Developer of the Original Code is Barry Kelly. }\r\n{ Portions created by Barry Kelly are Copyright (C) Barry Kelly. All rights reserved. }\r\n{ }\r\n{ Contributors: }\r\n{ Barry Kelly, Robert Rossmair, Matthias Thoma, Petr Vones }\r\n{ }\r\n{**************************************************************************************************}\r\n{ }\r\n{ This unit contains a string-pointer associative map. It works by hashing the added strings using }\r\n{ a passed-in traits object. }\r\n{ }\r\n{**************************************************************************************************}\r\n{ }\r\n{ Last modified: $Date:: 2012-08-14 12:55:54 +0200 (mar. 14 août 2012) $ }\r\n{ Revision: $Rev:: 3823 $ }\r\n{ Author: $Author:: outchy $ }\r\n{ }\r\n{**************************************************************************************************}\r\n\r\nunit JclStrHashMap;\r\n\r\n{$I jcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n {$IFDEF HAS_UNITSCOPE}\r\n System.SysUtils,\r\n {$ELSE ~HAS_UNITSCOPE}\r\n SysUtils,\r\n {$ENDIF ~HAS_UNITSCOPE}\r\n JclBase, JclResources;\r\n\r\ntype\r\n EJclStringHashMapError = class(EJclError);\r\n THashValue = Cardinal;\r\n\r\ntype\r\n TStringHashMapTraits = class(TObject)\r\n public\r\n function Hash(const S: string): Cardinal; virtual; abstract;\r\n function Compare(const L, R: string): Integer; virtual; abstract;\r\n end;\r\n\r\nfunction CaseSensitiveTraits: TStringHashMapTraits;\r\nfunction CaseInsensitiveTraits: TStringHashMapTraits;\r\n\r\ntype\r\n PUserData = Pointer;\r\n PData = Pointer;\r\n\r\n TIterateFunc = function(AUserData: PUserData; const AStr: string; var APtr: PData): Boolean;\r\n TIterateMethod = function(AUserData: PUserData; const AStr: string; var APtr: PData): Boolean of object;\r\n\r\n PPHashNode = ^PHashNode;\r\n PHashNode = ^THashNode;\r\n THashNode = record\r\n Str: string;\r\n Ptr: Pointer;\r\n Left: PHashNode;\r\n Right: PHashNode;\r\n end;\r\n\r\n { Internal iterate function pointer type used by the protected\r\n TStringHashMap.NodeIterate method. }\r\n TNodeIterateFunc = procedure(AUserData: Pointer; ANode: PPHashNode);\r\n\r\n PHashArray = ^THashArray;\r\n THashArray = array [0..MaxInt div SizeOf(PHashNode) - 1] of PHashNode;\r\n\r\n TStringHashMap = class(TObject)\r\n private\r\n FHashSize: Cardinal;\r\n FCount: Cardinal;\r\n FList: PHashArray;\r\n FLeftDelete: Boolean;\r\n FTraits: TStringHashMapTraits;\r\n function IterateNode(ANode: PHashNode; AUserData: PUserData; AIterateFunc: TIterateFunc): Boolean;\r\n function IterateMethodNode(ANode: PHashNode; AUserData: PUserData; AIterateMethod: TIterateMethod): Boolean;\r\n procedure NodeIterate(ANode: PPHashNode; AUserData: PUserData; AIterateFunc: TNodeIterateFunc);\r\n procedure SetHashSize(AHashSize: Cardinal);\r\n procedure DeleteNodes(var Q: PHashNode);\r\n procedure DeleteNode(var Q: PHashNode);\r\n protected\r\n function FindNode(const S: string): PPHashNode;\r\n function AllocNode: PHashNode; virtual;\r\n procedure FreeNode(ANode: PHashNode); virtual;\r\n function GetData(const S: string): PData;\r\n procedure SetData(const S: string; P: PData);\r\n public\r\n constructor Create(ATraits: TStringHashMapTraits; AHashSize: Cardinal);\r\n destructor Destroy; override;\r\n procedure Add(const S: string; const P);\r\n function Remove(const S: string): PData;\r\n procedure RemoveData(const P);\r\n procedure Iterate(AUserData: PUserData; AIterateFunc: TIterateFunc);\r\n procedure IterateMethod(AUserData: PUserData; AIterateMethod: TIterateMethod);\r\n function Has(const S: string): Boolean;\r\n function Find(const S: string; var P): Boolean;\r\n function FindData(const P; var S: string): Boolean;\r\n procedure Clear;\r\n property Count: Cardinal read FCount;\r\n property Data[const S: string]: PData read GetData write SetData; default;\r\n property Traits: TStringHashMapTraits read FTraits;\r\n property HashSize: Cardinal read FHashSize write SetHashSize;\r\n end;\r\n\r\n{ Str=case sensitive, text=case insensitive }\r\n\r\nfunction Iterate_FreeObjects(AUserData: PUserData; const AStr: string; var AData: PData): Boolean;\r\nfunction Iterate_Dispose(AUserData: PUserData; const AStr: string; var AData: PData): Boolean;\r\nfunction Iterate_FreeMem(AUserData: PUserData; const AStr: string; var AData: PData): Boolean;\r\n\r\ntype\r\n TCaseSensitiveTraits = class(TStringHashMapTraits)\r\n public\r\n function Hash(const S: string): Cardinal; override;\r\n function Compare(const L, R: string): Integer; override;\r\n end;\r\n\r\n TCaseInsensitiveTraits = class(TStringHashMapTraits)\r\n public\r\n function Hash(const S: string): Cardinal; override;\r\n function Compare(const L, R: string): Integer; override;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jcl.svn.sourceforge.net/svnroot/jcl/tags/JCL-2.4-Build4571/jcl/source/common/JclStrHashMap.pas $';\r\n Revision: '$Revision: 3823 $';\r\n Date: '$Date: 2012-08-14 12:55:54 +0200 (mar. 14 août 2012) $';\r\n LogPath: 'JCL\\source\\common';\r\n Extra: '';\r\n Data: nil\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n JclAlgorithms;\r\n\r\n// Case Sensitive & Insensitive Traits\r\nfunction TCaseSensitiveTraits.Compare(const L, R: string): Integer;\r\nbegin\r\n Result := CompareStr(L, R);\r\nend;\r\n\r\nfunction TCaseSensitiveTraits.Hash(const S: string): Cardinal;\r\nbegin\r\n Result := StrSimpleHashConvert(S);\r\nend;\r\n\r\nfunction TCaseInsensitiveTraits.Compare(const L, R: string): Integer;\r\nbegin\r\n Result := CompareText(L, R);\r\nend;\r\n\r\nfunction TCaseInsensitiveTraits.Hash(const S: string): Cardinal;\r\nbegin\r\n Result := StrSimpleHashConvertI(S);\r\nend;\r\n\r\nvar\r\n GlobalCaseSensitiveTraits: TCaseSensitiveTraits;\r\n\r\nfunction CaseSensitiveTraits: TStringHashMapTraits;\r\nbegin\r\n if GlobalCaseSensitiveTraits = nil then\r\n GlobalCaseSensitiveTraits := TCaseSensitiveTraits.Create;\r\n Result := GlobalCaseSensitiveTraits;\r\nend;\r\n\r\nvar\r\n GlobalCaseInsensitiveTraits: TCaseInsensitiveTraits;\r\n\r\nfunction CaseInsensitiveTraits: TStringHashMapTraits;\r\nbegin\r\n if GlobalCaseInsensitiveTraits = nil then\r\n GlobalCaseInsensitiveTraits := TCaseInsensitiveTraits.Create;\r\n Result := GlobalCaseInsensitiveTraits;\r\nend;\r\n\r\nfunction Iterate_FreeObjects(AUserData: PUserData; const AStr: string; var AData: PData): Boolean;\r\nbegin\r\n TObject(AData).Free;\r\n AData := nil;\r\n Result := True;\r\nend;\r\n\r\nfunction Iterate_Dispose(AUserData: PUserData; const AStr: string; var AData: PData): Boolean;\r\nbegin\r\n Dispose(AData);\r\n AData := nil;\r\n Result := True;\r\nend;\r\n\r\nfunction Iterate_FreeMem(AUserData: PUserData; const AStr: string; var AData: PData): Boolean;\r\nbegin\r\n FreeMem(AData);\r\n AData := nil;\r\n Result := True;\r\nend;\r\n\r\n//=== { TStringHashMap } =====================================================\r\n\r\nconstructor TStringHashMap.Create(ATraits: TStringHashMapTraits; AHashSize: Cardinal);\r\nbegin\r\n inherited Create;\r\n Assert(ATraits <> nil, LoadResString(@RsStringHashMapNoTraits));\r\n SetHashSize(AHashSize);\r\n FTraits := ATraits;\r\nend;\r\n\r\ndestructor TStringHashMap.Destroy;\r\nbegin\r\n Clear;\r\n SetHashSize(0);\r\n inherited Destroy;\r\nend;\r\n\r\ntype\r\n PPCollectNodeNode = ^PCollectNodeNode;\r\n PCollectNodeNode = ^TCollectNodeNode;\r\n TCollectNodeNode = record\r\n Next: PCollectNodeNode;\r\n Str: string;\r\n Ptr: Pointer;\r\n end;\r\n\r\n\r\nprocedure NodeIterate_CollectNodes(AUserData: PUserData; ANode: PPHashNode);\r\nvar\r\n PPCnn: PPCollectNodeNode;\r\n PCnn: PCollectNodeNode;\r\nbegin\r\n PPCnn := PPCollectNodeNode(AUserData);\r\n New(PCnn);\r\n PCnn^.Next := PPCnn^;\r\n PPCnn^ := PCnn;\r\n\r\n PCnn^.Str := ANode^^.Str;\r\n PCnn^.Ptr := ANode^^.Ptr;\r\nend;\r\n\r\nprocedure TStringHashMap.SetHashSize(AHashSize: Cardinal);\r\nvar\r\n CollectList: PCollectNodeNode;\r\n\r\n procedure CollectNodes;\r\n var\r\n I: Integer;\r\n begin\r\n CollectList := nil;\r\n for I := 0 to FHashSize - 1 do\r\n NodeIterate(@FList^[I], @CollectList, NodeIterate_CollectNodes);\r\n end;\r\n\r\n procedure InsertNodes;\r\n var\r\n PCnn, Tmp: PCollectNodeNode;\r\n begin\r\n PCnn := CollectList;\r\n while PCnn <> nil do\r\n begin\r\n Tmp := PCnn^.Next;\r\n Add(PCnn^.Str, PCnn^.Ptr);\r\n Dispose(PCnn);\r\n PCnn := Tmp;\r\n end;\r\n end;\r\n\r\nbegin\r\n { 4 cases:\r\n we are empty, and AHashSize = 0 --> nothing to do\r\n we are full, and AHashSize = 0 --> straight empty\r\n we are empty, and AHashSize > 0 --> straight allocation\r\n we are full, and AHashSize > 0 --> rehash }\r\n\r\n if FHashSize = 0 then\r\n begin\r\n if AHashSize > 0 then\r\n begin\r\n GetMem(FList, AHashSize * SizeOf(FList^[0]));\r\n FillChar(FList^, AHashSize * SizeOf(FList^[0]), 0);\r\n FHashSize := AHashSize;\r\n end;\r\n end\r\n else\r\n begin\r\n if AHashSize > 0 then\r\n begin\r\n { must rehash table }\r\n CollectNodes;\r\n Clear;\r\n ReallocMem(FList, AHashSize * SizeOf(FList^[0]));\r\n FillChar(FList^, AHashSize * SizeOf(FList^[0]), 0);\r\n FHashSize := AHashSize;\r\n InsertNodes;\r\n end\r\n else\r\n begin\r\n { we are clearing the table - need hash to be empty }\r\n if FCount > 0 then\r\n raise EJclStringHashMapError.CreateRes(@RsStringHashMapMustBeEmpty);\r\n FreeMem(FList);\r\n FList := nil;\r\n FHashSize := 0;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TStringHashMap.FindNode(const S: string): PPHashNode;\r\nvar\r\n I: Cardinal;\r\n R: Integer;\r\n PPN: PPHashNode;\r\nbegin\r\n { we start at the node offset by S in the hash list }\r\n I := FTraits.Hash(S) mod FHashSize;\r\n\r\n PPN := @FList^[I];\r\n\r\n if PPN^ <> nil then\r\n while True do\r\n begin\r\n R := FTraits.Compare(S, PPN^^.Str);\r\n\r\n { left, then right, then match }\r\n if R < 0 then\r\n PPN := @PPN^^.Left\r\n else\r\n if R > 0 then\r\n PPN := @PPN^^.Right\r\n else\r\n Break;\r\n\r\n { check for empty position after drilling left or right }\r\n if PPN^ = nil then\r\n Break;\r\n end;\r\n\r\n Result := PPN;\r\nend;\r\n\r\nfunction TStringHashMap.IterateNode(ANode: PHashNode; AUserData: Pointer;\r\n AIterateFunc: TIterateFunc): Boolean;\r\nbegin\r\n if ANode <> nil then\r\n begin\r\n Result := AIterateFunc(AUserData, ANode^.Str, ANode^.Ptr);\r\n if not Result then\r\n Exit;\r\n\r\n Result := IterateNode(ANode^.Left, AUserData, AIterateFunc);\r\n if not Result then\r\n Exit;\r\n\r\n Result := IterateNode(ANode^.Right, AUserData, AIterateFunc);\r\n if not Result then\r\n Exit;\r\n end\r\n else\r\n Result := True;\r\nend;\r\n\r\nfunction TStringHashMap.IterateMethodNode(ANode: PHashNode; AUserData: Pointer;\r\n AIterateMethod: TIterateMethod): Boolean;\r\nbegin\r\n if ANode <> nil then\r\n begin\r\n Result := AIterateMethod(AUserData, ANode^.Str, ANode^.Ptr);\r\n if not Result then\r\n Exit;\r\n\r\n Result := IterateMethodNode(ANode^.Left, AUserData, AIterateMethod);\r\n if not Result then\r\n Exit;\r\n\r\n Result := IterateMethodNode(ANode^.Right, AUserData, AIterateMethod);\r\n if not Result then\r\n Exit;\r\n end\r\n else\r\n Result := True;\r\nend;\r\n\r\nprocedure TStringHashMap.NodeIterate(ANode: PPHashNode; AUserData: Pointer;\r\n AIterateFunc: TNodeIterateFunc);\r\nbegin\r\n if ANode^ <> nil then\r\n begin\r\n AIterateFunc(AUserData, ANode);\r\n NodeIterate(@ANode^.Left, AUserData, AIterateFunc);\r\n NodeIterate(@ANode^.Right, AUserData, AIterateFunc);\r\n end;\r\nend;\r\n\r\nprocedure TStringHashMap.DeleteNode(var Q: PHashNode);\r\nvar\r\n T, R, S: PHashNode;\r\nbegin\r\n { we must delete node Q without destroying binary tree }\r\n { Knuth 6.2.2 D (pg 432 Vol 3 2nd ed) }\r\n\r\n { alternating between left / right delete to preserve decent\r\n performance over multiple insertion / deletion }\r\n FLeftDelete := not FLeftDelete;\r\n\r\n { T will be the node we delete }\r\n T := Q;\r\n\r\n if FLeftDelete then\r\n begin\r\n if T^.Right = nil then\r\n Q := T^.Left\r\n else\r\n begin\r\n R := T^.Right;\r\n if R^.Left = nil then\r\n begin\r\n R^.Left := T^.Left;\r\n Q := R;\r\n end\r\n else\r\n begin\r\n S := R^.Left;\r\n if S^.Left <> nil then\r\n repeat\r\n R := S;\r\n S := R^.Left;\r\n until S^.Left = nil;\r\n { now, S = symmetric successor of Q }\r\n S^.Left := T^.Left;\r\n R^.Left := S^.Right;\r\n S^.Right := T^.Right;\r\n Q := S;\r\n end;\r\n end;\r\n end\r\n else\r\n begin\r\n if T^.Left = nil then\r\n Q := T^.Right\r\n else\r\n begin\r\n R := T^.Left;\r\n if R^.Right = nil then\r\n begin\r\n R^.Right := T^.Right;\r\n Q := R;\r\n end\r\n else\r\n begin\r\n S := R^.Right;\r\n if S^.Right <> nil then\r\n repeat\r\n R := S;\r\n S := R^.Right;\r\n until S^.Right = nil;\r\n { now, S = symmetric predecessor of Q }\r\n S^.Right := T^.Right;\r\n R^.Right := S^.Left;\r\n S^.Left := T^.Left;\r\n Q := S;\r\n end;\r\n end;\r\n end;\r\n\r\n { we decrement before because the tree is already adjusted\r\n => any exception in FreeNode MUST be ignored.\r\n\r\n It's unlikely that FreeNode would raise an exception anyway. }\r\n Dec(FCount);\r\n FreeNode(T);\r\nend;\r\n\r\nprocedure TStringHashMap.DeleteNodes(var Q: PHashNode);\r\nbegin\r\n if Q^.Left <> nil then\r\n DeleteNodes(Q^.Left);\r\n if Q^.Right <> nil then\r\n DeleteNodes(Q^.Right);\r\n FreeNode(Q);\r\n Q := nil;\r\nend;\r\n\r\nfunction TStringHashMap.AllocNode: PHashNode;\r\nbegin\r\n New(Result);\r\n Result^.Left := nil;\r\n Result^.Right := nil;\r\nend;\r\n\r\nprocedure TStringHashMap.FreeNode(ANode: PHashNode);\r\nbegin\r\n Dispose(ANode);\r\nend;\r\n\r\nfunction TStringHashMap.GetData(const S: string): Pointer;\r\nvar\r\n PPN: PPHashNode;\r\nbegin\r\n PPN := FindNode(S);\r\n\r\n if PPN^ <> nil then\r\n Result := PPN^^.Ptr\r\n else\r\n Result := nil;\r\nend;\r\n\r\nprocedure TStringHashMap.SetData(const S: string; P: Pointer);\r\nvar\r\n PPN: PPHashNode;\r\nbegin\r\n PPN := FindNode(S);\r\n\r\n if PPN^ <> nil then\r\n PPN^^.Ptr := P\r\n else\r\n begin\r\n { add }\r\n PPN^ := AllocNode;\r\n { we increment after in case of exception }\r\n Inc(FCount);\r\n PPN^^.Str := S;\r\n PPN^^.Ptr := P;\r\n end;\r\nend;\r\n\r\nprocedure TStringHashMap.Add(const S: string; const P{: Pointer});\r\nvar\r\n PPN: PPHashNode;\r\nbegin\r\n PPN := FindNode(S);\r\n\r\n { if reordered from SetData because PPN^ = nil is more common for Add }\r\n if PPN^ = nil then\r\n begin\r\n { add }\r\n PPN^ := AllocNode;\r\n { we increment after in case of exception }\r\n Inc(FCount);\r\n PPN^^.Str := S;\r\n PPN^^.Ptr := Pointer(P);\r\n end\r\n else\r\n raise EJclStringHashMapError.CreateResFmt(@RsStringHashMapDuplicate, [S]);\r\nend;\r\n\r\ntype\r\n PListNode = ^TListNode;\r\n TListNode = record\r\n Next: PListNode;\r\n NodeLoc: PPHashNode;\r\n end;\r\n\r\n PDataParam = ^TDataParam;\r\n TDataParam = record\r\n Head: PListNode;\r\n Data: Pointer;\r\n end;\r\n\r\nprocedure NodeIterate_BuildDataList(AUserData: Pointer; ANode: PPHashNode);\r\nvar\r\n DP: PDataParam;\r\n T: PListNode;\r\nbegin\r\n DP := PDataParam(AUserData);\r\n if DP.Data = ANode^^.Ptr then\r\n begin\r\n New(T);\r\n T^.Next := DP.Head;\r\n T^.NodeLoc := ANode;\r\n DP.Head := T;\r\n end;\r\nend;\r\n\r\nprocedure TStringHashMap.RemoveData(const P{: Pointer});\r\nvar\r\n DP: TDataParam;\r\n I: Integer;\r\n N, T: PListNode;\r\nbegin\r\n DP.Data := Pointer(P);\r\n DP.Head := nil;\r\n\r\n for I := 0 to FHashSize - 1 do\r\n NodeIterate(@FList^[I], @DP, NodeIterate_BuildDataList);\r\n\r\n N := DP.Head;\r\n while N <> nil do\r\n begin\r\n DeleteNode(N^.NodeLoc^);\r\n T := N;\r\n N := N^.Next;\r\n Dispose(T);\r\n end;\r\nend;\r\n\r\nfunction TStringHashMap.Remove(const S: string): Pointer;\r\nvar\r\n PPN: PPHashNode;\r\nbegin\r\n PPN := FindNode(S);\r\n\r\n if PPN^ <> nil then\r\n begin\r\n Result := PPN^^.Ptr;\r\n DeleteNode(PPN^);\r\n end\r\n else\r\n raise EJclStringHashMapError.CreateResFmt(@RsStringHashMapInvalidNode, [S]);\r\nend;\r\n\r\nprocedure TStringHashMap.IterateMethod(AUserData: Pointer;\r\n AIterateMethod: TIterateMethod);\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := 0 to FHashSize - 1 do\r\n if not IterateMethodNode(FList^[I], AUserData, AIterateMethod) then\r\n Break;\r\nend;\r\n\r\nprocedure TStringHashMap.Iterate(AUserData: Pointer; AIterateFunc: TIterateFunc);\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := 0 to FHashSize - 1 do\r\n if not IterateNode(FList^[I], AUserData, AIterateFunc) then\r\n Break;\r\nend;\r\n\r\nfunction TStringHashMap.Has(const S: string): Boolean;\r\nvar\r\n PPN: PPHashNode;\r\nbegin\r\n PPN := FindNode(S);\r\n Result := PPN^ <> nil;\r\nend;\r\n\r\nfunction TStringHashMap.Find(const S: string; var P{: Pointer}): Boolean;\r\nvar\r\n PPN: PPHashNode;\r\nbegin\r\n PPN := FindNode(S);\r\n Result := PPN^ <> nil;\r\n if Result then\r\n Pointer(P) := PPN^^.Ptr;\r\nend;\r\n\r\ntype\r\n PFindDataResult = ^TFindDataResult;\r\n TFindDataResult = record\r\n Found: Boolean;\r\n ValueToFind: Pointer;\r\n Key: string;\r\n end;\r\n\r\nfunction Iterate_FindData(AUserData: Pointer; const AStr: string;\r\n var APtr: Pointer): Boolean;\r\nvar\r\n PFdr: PFindDataResult;\r\nbegin\r\n PFdr := PFindDataResult(AUserData);\r\n PFdr^.Found := (APtr = PFdr^.ValueToFind);\r\n Result := not PFdr^.Found;\r\n if PFdr^.Found then\r\n PFdr^.Key := AStr;\r\nend;\r\n\r\nfunction TStringHashMap.FindData(const P{: Pointer}; var S: string): Boolean;\r\nvar\r\n PFdr: PFindDataResult;\r\nbegin\r\n New(PFdr);\r\n try\r\n PFdr^.Found := False;\r\n PFdr^.ValueToFind := Pointer(P);\r\n Iterate(PFdr, Iterate_FindData);\r\n Result := PFdr^.Found;\r\n if Result then\r\n S := PFdr^.Key;\r\n finally\r\n Dispose(PFdr);\r\n end;\r\nend;\r\n\r\nprocedure TStringHashMap.Clear;\r\nvar\r\n I: Integer;\r\n PPN: PPHashNode;\r\nbegin\r\n for I := 0 to FHashSize - 1 do\r\n begin\r\n PPN := @FList^[I];\r\n if PPN^ <> nil then\r\n DeleteNodes(PPN^);\r\n end;\r\n FCount := 0;\r\nend;\r\n\r\ninitialization\r\n {$IFDEF UNITVERSIONING}\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n {$ENDIF UNITVERSIONING}\r\n\r\nfinalization\r\n {$IFDEF UNITVERSIONING}\r\n UnregisterUnitVersion(HInstance);\r\n {$ENDIF UNITVERSIONING}\r\n FreeAndNil(GlobalCaseInsensitiveTraits);\r\n FreeAndNil(GlobalCaseSensitiveTraits);\r\n\r\nend.\r\n\r\n" }, { "path": "External/Jedi/Jcl/source/common/JclStreams.pas", "content": "{**************************************************************************************************}\r\n{ }\r\n{ Project JEDI Code Library (JCL) }\r\n{ }\r\n{ The contents of this file are subject to the Mozilla Public License Version 1.1 (the \"License\"); }\r\n{ you may not use this file except in compliance with the License. You may obtain a copy of the }\r\n{ License at http://www.mozilla.org/MPL/ }\r\n{ }\r\n{ Software distributed under the License is distributed on an \"AS IS\" basis, WITHOUT WARRANTY OF }\r\n{ ANY KIND, either express or implied. See the License for the specific language governing rights }\r\n{ and limitations under the License. }\r\n{ }\r\n{ The Original Code is JclStreams.pas. }\r\n{ }\r\n{ The Initial Developer of the Original Code is Robert Marquardt. Portions created by }\r\n{ Robert Marquardt are Copyright (C) Robert Marquardt (robert_marquardt att gmx dott de) }\r\n{ All rights reserved. }\r\n{ }\r\n{ Contributors: }\r\n{ Florent Ouchet (outchy) }\r\n{ Heinz Zastrau }\r\n{ Andreas Schmidt }\r\n{ }\r\n{**************************************************************************************************}\r\n{ }\r\n{ Stream-related functions and classes }\r\n{ }\r\n{**************************************************************************************************}\r\n{ }\r\n{ Last modified: $Date:: 2012-09-04 16:08:04 +0200 (mar. 04 sept. 2012) $ }\r\n{ Revision: $Rev:: 3861 $ }\r\n{ Author: $Author:: outchy $ }\r\n{ }\r\n{**************************************************************************************************}\r\n\r\nunit JclStreams;\r\n\r\n{$I jcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n {$IFDEF HAS_UNITSCOPE}\r\n {$IFDEF MSWINDOWS}\r\n Winapi.Windows,\r\n {$ENDIF MSWINDOWS}\r\n System.SysUtils, System.Classes,\r\n System.Contnrs,\r\n {$ELSE ~HAS_UNITSCOPE}\r\n {$IFDEF MSWINDOWS}\r\n Windows,\r\n {$ENDIF MSWINDOWS}\r\n SysUtils, Classes,\r\n Contnrs,\r\n {$ENDIF ~HAS_UNITSCOPE}\r\n {$IFDEF HAS_UNIT_LIBC}\r\n Libc,\r\n {$ENDIF HAS_UNIT_LIBC}\r\n JclBase, JclStringConversions;\r\n\r\nconst\r\n StreamDefaultBufferSize = 4096;\r\n\r\ntype\r\n EJclStreamError = class(EJclError);\r\n\r\n // abstraction layer to support Delphi 5 and C++Builder 5 streams\r\n // 64 bit version of overloaded functions are introduced\r\n TJclStream = class(TStream)\r\n protected\r\n procedure SetSize(NewSize: Longint); overload; override;\r\n procedure SetSize(const NewSize: Int64); overload; override;\r\n public\r\n function Seek(Offset: Longint; Origin: Word): Longint; overload; override;\r\n function Seek(const Offset: Int64; Origin: TSeekOrigin): Int64; overload; override;\r\n procedure LoadFromStream(Source: TStream; BufferSize: Longint = StreamDefaultBufferSize); virtual;\r\n procedure LoadFromFile(const FileName: TFileName; BufferSize: Longint = StreamDefaultBufferSize); virtual;\r\n procedure SaveToStream(Dest: TStream; BufferSize: Longint = StreamDefaultBufferSize); virtual;\r\n procedure SaveToFile(const FileName: TFileName; BufferSize: Longint = StreamDefaultBufferSize); virtual;\r\n end;\r\n\r\n //=== VCL stream replacements ===\r\n\r\n TJclHandleStream = class(TJclStream)\r\n private\r\n FHandle: THandle;\r\n protected\r\n procedure SetSize(const NewSize: Int64); override;\r\n public\r\n constructor Create(AHandle: THandle);\r\n function Read(var Buffer; Count: Longint): Longint; override;\r\n function Write(const Buffer; Count: Longint): Longint; override;\r\n function Seek(const Offset: Int64; Origin: TSeekOrigin): Int64; override;\r\n property Handle: THandle read FHandle;\r\n end;\r\n\r\n TJclFileStream = class(TJclHandleStream)\r\n public\r\n constructor Create(const FileName: TFileName; Mode: Word; Rights: Cardinal = $666);\r\n destructor Destroy; override;\r\n end;\r\n\r\n {\r\n TJclCustomMemoryStream = class(TJclStream)\r\n end;\r\n\r\n TJclMemoryStream = class(TJclCustomMemoryStream)\r\n end;\r\n\r\n TJclStringStream = class(TJclStream)\r\n end;\r\n\r\n TJclResourceStream = class(TJclCustomMemoryStream)\r\n end;\r\n }\r\n\r\n //=== new stream ideas ===\r\n\r\n TJclEmptyStream = class(TJclStream)\r\n protected\r\n procedure SetSize(const NewSize: Int64); override;\r\n public\r\n function Read(var Buffer; Count: Longint): Longint; override;\r\n function Write(const Buffer; Count: Longint): Longint; override;\r\n function Seek(const Offset: Int64; Origin: TSeekOrigin): Int64; override;\r\n end;\r\n\r\n TJclNullStream = class(TJclStream)\r\n private\r\n FPosition: Int64;\r\n FSize: Int64;\r\n protected\r\n procedure SetSize(const NewSize: Int64); override;\r\n public\r\n function Read(var Buffer; Count: Longint): Longint; override;\r\n function Write(const Buffer; Count: Longint): Longint; override;\r\n function Seek(const Offset: Int64; Origin: TSeekOrigin): Int64; override;\r\n end;\r\n\r\n TJclRandomStream = class(TJclNullStream)\r\n protected\r\n function GetRandSeed: Longint; virtual;\r\n procedure SetRandSeed(Seed: Longint); virtual;\r\n public\r\n function RandomData: Byte; virtual;\r\n procedure Randomize; dynamic;\r\n function Read(var Buffer; Count: Longint): Longint; override;\r\n property RandSeed: Longint read GetRandSeed write SetRandSeed;\r\n end;\r\n\r\n TJclMultiplexStream = class(TJclStream)\r\n private\r\n FStreams: TList;\r\n FReadStreamIndex: Integer;\r\n function GetStream(Index: Integer): TStream;\r\n function GetCount: Integer;\r\n procedure SetStream(Index: Integer; const Value: TStream);\r\n function GetReadStream: TStream;\r\n procedure SetReadStream(const Value: TStream);\r\n procedure SetReadStreamIndex(const Value: Integer);\r\n protected\r\n procedure SetSize(const NewSize: Int64); override;\r\n public\r\n constructor Create;\r\n destructor Destroy; override;\r\n function Read(var Buffer; Count: Longint): Longint; override;\r\n function Write(const Buffer; Count: Longint): Longint; override;\r\n function Seek(const Offset: Int64; Origin: TSeekOrigin): Int64; override;\r\n\r\n function Add(NewStream: TStream): Integer;\r\n procedure Clear;\r\n function Remove(AStream: TStream): Integer;\r\n procedure Delete(const Index: Integer);\r\n\r\n property Streams[Index: Integer]: TStream read GetStream write SetStream;\r\n property ReadStreamIndex: Integer read FReadStreamIndex write SetReadStreamIndex;\r\n property ReadStream: TStream read GetReadStream write SetReadStream;\r\n property Count: Integer read GetCount;\r\n end;\r\n\r\n TJclStreamDecorator = class(TJclStream)\r\n private\r\n FAfterStreamChange: TNotifyEvent;\r\n FBeforeStreamChange: TNotifyEvent;\r\n FOwnsStream: Boolean;\r\n FStream: TStream;\r\n procedure SetStream(Value: TStream);\r\n protected\r\n procedure DoAfterStreamChange; virtual;\r\n procedure DoBeforeStreamChange; virtual;\r\n procedure SetSize(const NewSize: Int64); override;\r\n public\r\n constructor Create(AStream: TStream; AOwnsStream: Boolean = False);\r\n destructor Destroy; override;\r\n function Read(var Buffer; Count: Longint): Longint; override;\r\n function Write(const Buffer; Count: Longint): Longint; override;\r\n function Seek(const Offset: Int64; Origin: TSeekOrigin): Int64; override;\r\n property AfterStreamChange: TNotifyEvent read FAfterStreamChange write FAfterStreamChange;\r\n property BeforeStreamChange: TNotifyEvent read FBeforeStreamChange write FBeforeStreamChange;\r\n property OwnsStream: Boolean read FOwnsStream write FOwnsStream;\r\n property Stream: TStream read FStream write SetStream;\r\n end;\r\n\r\n TJclBufferedStream = class(TJclStreamDecorator)\r\n protected\r\n FBuffer: array of Byte;\r\n FBufferCurrentSize: Longint;\r\n FBufferMaxModifiedPos: Longint;\r\n FBufferSize: Longint;\r\n FBufferStart: Int64; // position of the first byte of the buffer in stream\r\n FPosition: Int64; // current position in stream\r\n function BufferHit: Boolean;\r\n function GetCalcedSize: Int64; virtual;\r\n function LoadBuffer: Boolean; virtual;\r\n function ReadFromBuffer(var Buffer; Count, Start: Longint): Longint;\r\n function WriteToBuffer(const Buffer; Count, Start: Longint): Longint;\r\n protected\r\n procedure DoAfterStreamChange; override;\r\n procedure DoBeforeStreamChange; override;\r\n procedure SetSize(const NewSize: Int64); override;\r\n public\r\n constructor Create(AStream: TStream; AOwnsStream: Boolean = False);\r\n destructor Destroy; override;\r\n procedure Flush; virtual;\r\n function Read(var Buffer; Count: Longint): Longint; override;\r\n function Write(const Buffer; Count: Longint): Longint; override;\r\n function Seek(const Offset: Int64; Origin: TSeekOrigin): Int64; override;\r\n property BufferSize: Longint read FBufferSize write FBufferSize;\r\n end;\r\n\r\n TStreamNotifyEvent = procedure(Sender: TObject; Position: Int64; Size: Int64) of object;\r\n\r\n TJclEventStream = class(TJclStreamDecorator)\r\n private\r\n FNotification: TStreamNotifyEvent;\r\n procedure DoNotification;\r\n protected\r\n procedure DoBeforeStreamChange; override;\r\n procedure DoAfterStreamChange; override;\r\n procedure SetSize(const NewSize: Int64); override;\r\n public\r\n constructor Create(AStream: TStream; ANotification: TStreamNotifyEvent = nil;\r\n AOwnsStream: Boolean = False);\r\n function Read(var Buffer; Count: Longint): Longint; override;\r\n function Write(const Buffer; Count: Longint): Longint; override;\r\n function Seek(const Offset: Int64; Origin: TSeekOrigin): Int64; override;\r\n property OnNotification: TStreamNotifyEvent read FNotification write FNotification;\r\n end;\r\n\r\n TJclEasyStream = class(TJclStreamDecorator)\r\n public\r\n function IsEqual(Stream: TStream): Boolean;\r\n function ReadBoolean: Boolean;\r\n function ReadChar: Char;\r\n function ReadAnsiChar: AnsiChar;\r\n function ReadWideChar: WideChar;\r\n function ReadByte: Byte;\r\n function ReadCurrency: Currency;\r\n function ReadDateTime: TDateTime;\r\n function ReadExtended: Extended;\r\n function ReadDouble: Double;\r\n function ReadInt64: Int64;\r\n function ReadInteger: Integer;\r\n function ReadCString: string; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\n function ReadCAnsiString: AnsiString;\r\n function ReadCWideString: WideString;\r\n function ReadShortString: string;\r\n function ReadSingle: Single;\r\n function ReadSizedString: string; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\n function ReadSizedAnsiString: AnsiString;\r\n function ReadSizedWideString: WideString;\r\n procedure WriteBoolean(Value: Boolean);\r\n procedure WriteChar(Value: Char);\r\n procedure WriteAnsiChar(Value: AnsiChar);\r\n procedure WriteWideChar(Value: WideChar);\r\n procedure WriteByte(Value: Byte);\r\n procedure WriteCurrency(const Value: Currency);\r\n procedure WriteDateTime(const Value: TDateTime);\r\n procedure WriteExtended(const Value: Extended);\r\n procedure WriteDouble(const Value: Double);\r\n procedure WriteInt64(Value: Int64); overload;\r\n procedure WriteInteger(Value: Integer); overload;\r\n procedure WriteCString(const Value: string); {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\n procedure WriteCAnsiString(const Value: AnsiString);\r\n procedure WriteCWideString(const Value: WideString);\r\n // use WriteCString\r\n procedure WriteShortString(const Value: ShortString);\r\n procedure WriteSingle(const Value: Single);\r\n procedure WriteSizedString(const Value: string); {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\n procedure WriteSizedAnsiString(const Value: AnsiString);\r\n procedure WriteSizedWideString(const Value: WideString);\r\n end;\r\n\r\n TJclScopedStream = class(TJclStream)\r\n private\r\n FParentStream: TStream;\r\n FStartPos: Int64;\r\n FCurrentPos: Int64;\r\n FMaxSize: Int64;\r\n protected\r\n procedure SetSize(const NewSize: Int64); override;\r\n public\r\n // scopedstream starting at the current position of the ParentStream\r\n // if MaxSize is positive or null, read and write operations cannot overrun this size or the ParentStream limitation\r\n // if MaxSize is negative, read and write operations are unlimited (up to the ParentStream limitation)\r\n constructor Create(AParentStream: TStream; const AMaxSize: Int64 = -1); overload;\r\n constructor Create(AParentStream: TStream; const AStartPos, AMaxSize: Int64); overload;\r\n function Read(var Buffer; Count: Longint): Longint; override;\r\n function Write(const Buffer; Count: Longint): Longint; override;\r\n function Seek(const Offset: Int64; Origin: TSeekOrigin): Int64; override;\r\n\r\n property ParentStream: TStream read FParentStream;\r\n property StartPos: Int64 read FStartPos;\r\n property MaxSize: Int64 read FMaxSize write FMaxSize;\r\n end;\r\n\r\n TJclStreamSeekEvent = function(Sender: TObject; const Offset: Int64;\r\n Origin: TSeekOrigin): Int64 of object;\r\n TJclStreamReadEvent = function(Sender: TObject; var Buffer; Count: Longint): Longint of object;\r\n TJclStreamWriteEvent = function(Sender: TObject; const Buffer;Count: Longint): Longint of object;\r\n TJclStreamSizeEvent = procedure(Sender: TObject; const NewSize: Int64) of object;\r\n\r\n TJclDelegatedStream = class(TJclStream)\r\n private\r\n FOnSeek: TJclStreamSeekEvent;\r\n FOnRead: TJclStreamReadEvent;\r\n FOnWrite: TJclStreamWriteEvent;\r\n FOnSize: TJclStreamSizeEvent;\r\n protected\r\n procedure SetSize(const NewSize: Int64); override;\r\n public\r\n function Seek(const Offset: Int64; Origin: TSeekOrigin): Int64; override;\r\n function Read(var Buffer; Count: Longint): Longint; override;\r\n function Write(const Buffer; Count: Longint): Longint; override;\r\n property OnSeek: TJclStreamSeekEvent read FOnSeek write FOnSeek;\r\n property OnRead: TJclStreamReadEvent read FOnRead write FOnRead;\r\n property OnWrite: TJclStreamWriteEvent read FOnWrite write FOnWrite;\r\n property OnSize: TJclStreamSizeEvent read FOnSize write FOnSize;\r\n end;\r\n\r\n // ancestor classes for streams with checksums and encrypted streams\r\n // data are stored in sectors: each BufferSize-d buffer is followed by FBlockOverHeader bytes\r\n // containing the checksum. In case of an encrypted stream, there is no byte\r\n // but sector is encrypted\r\n\r\n // reusing some code from TJclBufferedStream\r\n TJclSectoredStream = class(TJclBufferedStream)\r\n protected\r\n FSectorOverHead: Longint;\r\n function FlatToSectored(const Position: Int64): Int64;\r\n function SectoredToFlat(const Position: Int64): Int64;\r\n function GetCalcedSize: Int64; override;\r\n function LoadBuffer: Boolean; override;\r\n procedure DoAfterStreamChange; override;\r\n procedure AfterBlockRead; virtual; // override to check protection\r\n procedure BeforeBlockWrite; virtual; // override to compute protection\r\n procedure SetSize(const NewSize: Int64); override;\r\n public\r\n constructor Create(AStorageStream: TStream; AOwnsStream: Boolean = False;\r\n ASectorOverHead: Longint = 0);\r\n\r\n procedure Flush; override;\r\n end;\r\n\r\n TJclCRC16Stream = class(TJclSectoredStream)\r\n protected\r\n procedure AfterBlockRead; override;\r\n procedure BeforeBlockWrite; override;\r\n public\r\n constructor Create(AStorageStream: TStream; AOwnsStream: Boolean = False);\r\n end;\r\n\r\n TJclCRC32Stream = class(TJclSectoredStream)\r\n protected\r\n procedure AfterBlockRead; override;\r\n procedure BeforeBlockWrite; override;\r\n public\r\n constructor Create(AStorageStream: TStream; AOwnsStream: Boolean = False);\r\n end;\r\n\r\n {$IFDEF COMPILER7_UP}\r\n {$DEFINE SIZE64}\r\n {$ENDIF ~COMPILER7_UP}\r\n {$IFDEF FPC}\r\n {$DEFINE SIZE64}\r\n {$ENDIF FPC}\r\n TJclSplitStream = class(TJclStream)\r\n private\r\n FVolume: TStream;\r\n FVolumeIndex: Integer;\r\n FVolumeMaxSize: Int64;\r\n FPosition: Int64;\r\n FVolumePosition: Int64;\r\n FForcePosition: Boolean;\r\n protected\r\n function GetVolume(Index: Integer): TStream; virtual; abstract;\r\n function GetVolumeMaxSize(Index: Integer): Int64; virtual; abstract;\r\n function GetSize: Int64; {$IFDEF SIZE64}override;{$ENDIF SIZE64}\r\n procedure SetSize(const NewSize: Int64); override;\r\n function InternalLoadVolume(Index: Integer): Boolean;\r\n public\r\n constructor Create(AForcePosition: Boolean = False);\r\n\r\n function Seek(const Offset: Int64; Origin: TSeekOrigin): Int64; override;\r\n function Read(var Buffer; Count: Longint): Longint; override;\r\n function Write(const Buffer; Count: Longint): Longint; override;\r\n\r\n property ForcePosition: Boolean read FForcePosition write FForcePosition;\r\n end;\r\n\r\n TJclVolumeEvent = function(Index: Integer): TStream of object;\r\n TJclVolumeMaxSizeEvent = function(Index: Integer): Int64 of object;\r\n\r\n TJclDynamicSplitStream = class(TJclSplitStream)\r\n private\r\n FOnVolume: TJclVolumeEvent;\r\n FOnVolumeMaxSize: TJclVolumeMaxSizeEvent;\r\n protected\r\n function GetVolume(Index: Integer): TStream; override;\r\n function GetVolumeMaxSize(Index: Integer): Int64; override;\r\n public\r\n property OnVolume: TJclVolumeEvent read FOnVolume write FOnVolume;\r\n property OnVolumeMaxSize: TJclVolumeMaxSizeEvent read FOnVolumeMaxSize\r\n write FOnVolumeMaxSize;\r\n end;\r\n\r\n TJclSplitVolume = class\r\n public\r\n MaxSize: Int64;\r\n Stream: TStream;\r\n OwnStream: Boolean;\r\n end;\r\n\r\n TJclStaticSplitStream = class(TJclSplitStream)\r\n private\r\n FVolumes: TObjectList;\r\n function GetVolumeCount: Integer;\r\n protected\r\n function GetVolume(Index: Integer): TStream; override;\r\n function GetVolumeMaxSize(Index: Integer): Int64; override;\r\n public\r\n constructor Create(AForcePosition: Boolean = False);\r\n destructor Destroy; override;\r\n\r\n function AddVolume(AStream: TStream; AMaxSize: Int64 = 0;\r\n AOwnStream: Boolean = False): Integer;\r\n\r\n property VolumeCount: Integer read GetVolumeCount;\r\n property Volumes[Index: Integer]: TStream read GetVolume;\r\n property VolumeMaxSizes[Index: Integer]: Int64 read GetVolumeMaxSize;\r\n end;\r\n\r\n TJclStringStream = class\r\n protected\r\n FStream: TStream;\r\n FOwnStream: Boolean;\r\n FBOM: array of Byte;\r\n FBufferSize: SizeInt;\r\n FStrPosition: Int64; // current position in characters\r\n FStrBuffer: TUCS4Array; // buffer for read/write operations\r\n FStrBufferPosition: Int64; // position of the first character of the read/write buffer\r\n FStrBufferCurrentSize: Int64; // numbers of characters available in str buffer\r\n FStrBufferModifiedSize: Int64; // numbers of characters modified in str buffer\r\n FStrBufferStart: Int64; // position of the first byte of the read/write buffer in stream\r\n FStrBufferNext: Int64; // position of the next character following the read/write buffer in stream\r\n FStrPeekPosition: Int64; // current peek position in characters\r\n FStrPeekBuffer: TUCS4Array; // buffer for peek operations\r\n FStrPeekBufferPosition: Int64; // index of the first character of the peek buffer\r\n FStrPeekBufferCurrentSize: SizeInt; // numbers of characters available in peek buffer\r\n FStrPeekBufferStart: Int64; // position of the first byte of the peek buffer in stream\r\n FStrPeekBufferNext: Int64; // position of the next character following the peek buffer in stream\r\n function LoadBuffer: Boolean;\r\n function LoadPeekBuffer: Boolean;\r\n function InternalGetNextChar(S: TStream; out Ch: UCS4): Boolean; virtual; abstract;\r\n function InternalGetNextBuffer(S: TStream; var Buffer: TUCS4Array; Start, Count: SizeInt): Longint; virtual;\r\n function InternalSetNextChar(S: TStream; Ch: UCS4): Boolean; virtual; abstract;\r\n function InternalSetNextBuffer(S: TStream; const Buffer: TUCS4Array; Start, Count: SizeInt): Longint; virtual;\r\n procedure InvalidateBuffers;\r\n public\r\n constructor Create(AStream: TStream; AOwnsStream: Boolean = False); virtual;\r\n destructor Destroy; override;\r\n procedure Flush; virtual;\r\n function ReadString(var Buffer: string; Start, Count: Longint): Longint; overload;\r\n function ReadString(BufferSize: Longint = StreamDefaultBufferSize): string; overload;\r\n function ReadAnsiString(var Buffer: AnsiString; Start, Count: Longint): Longint; overload;\r\n function ReadAnsiString(BufferSize: Longint = StreamDefaultBufferSize): AnsiString; overload;\r\n function ReadWideString(var Buffer: WideString; Start, Count: Longint): Longint; overload;\r\n function ReadWideString(BufferSize: Longint = StreamDefaultBufferSize): WideString; overload;\r\n function Seek(const Offset: Int64; Origin: TSeekOrigin): Int64; virtual;\r\n function WriteString(const Buffer: string; Start, Count: Longint): Longint;\r\n function WriteAnsiString(const Buffer: AnsiString; Start, Count: Longint): Longint;\r\n function WriteWideString(const Buffer: WideString; Start, Count: Longint): Longint;\r\n function PeekChar(out Buffer: Char): Boolean;\r\n function PeekAnsiChar(out Buffer: AnsiChar): Boolean;\r\n function PeekUCS4(out Buffer: UCS4): Boolean;\r\n function PeekWideChar(out Buffer: WideChar): Boolean;\r\n function ReadChar(out Buffer: Char): Boolean;\r\n function ReadAnsiChar(out Buffer: AnsiChar): Boolean;\r\n function ReadUCS4(out Buffer: UCS4): Boolean;\r\n function ReadWideChar(out Buffer: WideChar): Boolean;\r\n function WriteChar(Value: Char): Boolean;\r\n function WriteAnsiChar(Value: AnsiChar): Boolean;\r\n function WriteUCS4(Value: UCS4): Boolean;\r\n function WriteWideChar(Value: WideChar): Boolean;\r\n function SkipBOM: LongInt; virtual;\r\n function WriteBOM: Longint; virtual;\r\n property BufferSize: SizeInt read FBufferSize write FBufferSize;\r\n property PeekPosition: Int64 read FStrPeekPosition;\r\n property Position: Int64 read FStrPosition;\r\n property Stream: TStream read FStream;\r\n property OwnStream: Boolean read FOwnStream;\r\n end;\r\n\r\n TJclStringStreamClass = class of TJclStringStream;\r\n\r\n TJclAnsiStream = class(TJclStringStream)\r\n private\r\n FCodePage: Word;\r\n protected\r\n function InternalGetNextChar(S: TStream; out Ch: UCS4): Boolean; override;\r\n function InternalGetNextBuffer(S: TStream; var Buffer: TUCS4Array; Start, Count: SizeInt): Longint; override;\r\n function InternalSetNextChar(S: TStream; Ch: UCS4): Boolean; override;\r\n function InternalSetNextBuffer(S: TStream; const Buffer: TUCS4Array; Start, Count: SizeInt): Longint; override;\r\n public\r\n constructor Create(AStream: TStream; AOwnsStream: Boolean = False); override;\r\n property CodePage: Word read FCodePage write FCodePage;\r\n end;\r\n\r\n TJclUTF8Stream = class(TJclStringStream)\r\n protected\r\n function InternalGetNextChar(S: TStream; out Ch: UCS4): Boolean; override;\r\n function InternalGetNextBuffer(S: TStream; var Buffer: TUCS4Array; Start, Count: SizeInt): Longint; override;\r\n function InternalSetNextChar(S: TStream; Ch: UCS4): Boolean; override;\r\n function InternalSetNextBuffer(S: TStream; const Buffer: TUCS4Array; Start, Count: SizeInt): Longint; override;\r\n public\r\n constructor Create(AStream: TStream; AOwnsStream: Boolean = False); override;\r\n end;\r\n\r\n TJclUTF16Stream = class(TJclStringStream)\r\n protected\r\n function InternalGetNextChar(S: TStream; out Ch: UCS4): Boolean; override;\r\n function InternalGetNextBuffer(S: TStream; var Buffer: TUCS4Array; Start, Count: SizeInt): Longint; override;\r\n function InternalSetNextChar(S: TStream; Ch: UCS4): Boolean; override;\r\n function InternalSetNextBuffer(S: TStream; const Buffer: TUCS4Array; Start, Count: SizeInt): Longint; override;\r\n public\r\n constructor Create(AStream: TStream; AOwnsStream: Boolean = False); override;\r\n end;\r\n\r\n TJclStringEncoding = (seAnsi, seUTF8, seUTF16, seAuto);\r\n\r\n TJclAutoStream = class(TJclStringStream)\r\n private\r\n FCodePage: Word;\r\n FEncoding: TJclStringEncoding;\r\n procedure SetCodePage(Value: Word);\r\n protected\r\n function InternalGetNextChar(S: TStream; out Ch: UCS4): Boolean; override;\r\n function InternalGetNextBuffer(S: TStream; var Buffer: TUCS4Array; Start, Count: SizeInt): Longint; override;\r\n function InternalSetNextChar(S: TStream; Ch: UCS4): Boolean; override;\r\n function InternalSetNextBuffer(S: TStream; const Buffer: TUCS4Array; Start, Count: SizeInt): Longint; override;\r\n public\r\n constructor Create(AStream: TStream; AOwnsStream: Boolean = False); override;\r\n function SkipBOM: LongInt; override;\r\n property CodePage: Word read FCodePage write SetCodePage;\r\n property Encoding: TJclStringEncoding read FEncoding;\r\n end;\r\n\r\n// buffered copy of all available bytes from Source to Dest\r\n// returns the number of bytes that were copied\r\nfunction StreamCopy(Source: TStream; Dest: TStream; BufferSize: Longint = StreamDefaultBufferSize): Int64;\r\n\r\n// buffered copy of all available characters from Source to Dest\r\n// retuns the number of characters (in specified encoding) that were copied\r\nfunction StringStreamCopy(Source, Dest: TJclStringStream; BufferLength: Longint = StreamDefaultBufferSize): Int64;\r\nfunction AnsiStringStreamCopy(Source, Dest: TJclStringStream; BufferLength: Longint = StreamDefaultBufferSize): Int64;\r\nfunction WideStringStreamCopy(Source, Dest: TJclStringStream; BufferLength: Longint = StreamDefaultBufferSize): Int64;\r\n\r\n// compares 2 streams for differencies\r\nfunction CompareStreams(A, B : TStream; BufferSize: Longint = StreamDefaultBufferSize): Boolean;\r\n// compares 2 files for differencies (calling CompareStreams)\r\nfunction CompareFiles(const FileA, FileB: TFileName; BufferSize: Longint = StreamDefaultBufferSize): Boolean;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jcl.svn.sourceforge.net/svnroot/jcl/tags/JCL-2.4-Build4571/jcl/source/common/JclStreams.pas $';\r\n Revision: '$Revision: 3861 $';\r\n Date: '$Date: 2012-09-04 16:08:04 +0200 (mar. 04 sept. 2012) $';\r\n LogPath: 'JCL\\source\\common';\r\n Extra: '';\r\n Data: nil\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n {$IFDEF HAS_UNITSCOPE}\r\n System.Types,\r\n {$ENDIF HAS_UNITSCOPE}\r\n JclResources,\r\n JclCharsets,\r\n JclMath,\r\n JclSysUtils;\r\n\r\nfunction StreamCopy(Source: TStream; Dest: TStream; BufferSize: Longint): Int64;\r\nvar\r\n Buffer: array of Byte;\r\n ByteCount: Longint;\r\nbegin\r\n Result := 0;\r\n SetLength(Buffer, BufferSize);\r\n repeat\r\n ByteCount := Source.Read(Buffer[0], BufferSize);\r\n Result := Result + ByteCount;\r\n Dest.WriteBuffer(Buffer[0], ByteCount);\r\n until ByteCount < BufferSize;\r\nend;\r\n\r\nfunction StringStreamCopy(Source, Dest: TJclStringStream; BufferLength: Longint): Int64;\r\nvar\r\n Buffer: string;\r\n CharCount: Longint;\r\nbegin\r\n Result := 0;\r\n SetLength(Buffer, BufferLength);\r\n repeat\r\n CharCount := Source.ReadString(Buffer, 1, BufferLength);\r\n Result := Result + CharCount;\r\n CharCount := Dest.WriteString(Buffer, 1, CharCount);\r\n until CharCount = 0;\r\nend;\r\n\r\nfunction AnsiStringStreamCopy(Source, Dest: TJclStringStream; BufferLength: Longint): Int64;\r\nvar\r\n Buffer: AnsiString;\r\n CharCount: Longint;\r\nbegin\r\n Result := 0;\r\n SetLength(Buffer, BufferLength);\r\n repeat\r\n CharCount := Source.ReadAnsiString(Buffer, 1, BufferLength);\r\n Result := Result + CharCount;\r\n CharCount := Dest.WriteAnsiString(Buffer, 1, CharCount);\r\n until CharCount = 0;\r\nend;\r\n\r\nfunction WideStringStreamCopy(Source, Dest: TJclStringStream; BufferLength: Longint): Int64;\r\nvar\r\n Buffer: WideString;\r\n CharCount: Longint;\r\nbegin\r\n Result := 0;\r\n SetLength(Buffer, BufferLength);\r\n repeat\r\n CharCount := Source.ReadWideString(Buffer, 1, BufferLength);\r\n Result := Result + CharCount;\r\n CharCount := Dest.WriteWideString(Buffer, 1, CharCount);\r\n until CharCount = 0;\r\nend;\r\n\r\nfunction CompareStreams(A, B : TStream; BufferSize: Longint): Boolean;\r\nvar\r\n BufferA, BufferB: array of Byte;\r\n ByteCountA, ByteCountB: Longint;\r\nbegin\r\n SetLength(BufferA, BufferSize);\r\n try\r\n SetLength(BufferB, BufferSize);\r\n try\r\n repeat\r\n ByteCountA := A.Read(BufferA[0], BufferSize);\r\n ByteCountB := B.Read(BufferB[0], BufferSize);\r\n\r\n Result := (ByteCountA = ByteCountB);\r\n Result := Result and CompareMem(BufferA, BufferB, ByteCountA);\r\n until (ByteCountA <> BufferSize) or (ByteCountB <> BufferSize) or not Result;\r\n finally\r\n SetLength(BufferB, 0);\r\n end;\r\n finally\r\n SetLength(BufferA, 0);\r\n end;\r\nend;\r\n\r\nfunction CompareFiles(const FileA, FileB: TFileName; BufferSize: Longint): Boolean;\r\nvar\r\n A, B: TStream;\r\nbegin\r\n A := TFileStream.Create(FileA, fmOpenRead or fmShareDenyWrite);\r\n try\r\n B := TFileStream.Create(FileB, fmOpenRead or fmShareDenyWrite);\r\n try\r\n Result := CompareStreams(A, B, BufferSize);\r\n finally\r\n B.Free;\r\n end;\r\n finally\r\n A.Free;\r\n end;\r\nend;\r\n\r\n//=== { TJclStream } =========================================================\r\n\r\nfunction TJclStream.Seek(Offset: Longint; Origin: Word): Longint;\r\nvar\r\n Result64: Int64;\r\nbegin\r\n case Origin of\r\n soFromBeginning:\r\n Result64 := Seek(Int64(Offset), soBeginning);\r\n soFromCurrent:\r\n Result64 := Seek(Int64(Offset), soCurrent);\r\n soFromEnd:\r\n Result64 := Seek(Int64(Offset), soEnd);\r\n else\r\n Result64 := -1;\r\n end;\r\n if (Result64 < 0) or (Result64 > High(Longint)) then\r\n Result64 := -1;\r\n Result := Result64;\r\nend;\r\n\r\nprocedure TJclStream.LoadFromFile(const FileName: TFileName;\r\n BufferSize: Integer);\r\nvar\r\n FS: TStream;\r\nbegin\r\n FS := TFileStream.Create(FileName, fmOpenRead or fmShareDenyWrite);\r\n try\r\n LoadFromStream(FS, BufferSize);\r\n finally\r\n FS.Free;\r\n end;\r\nend;\r\n\r\nprocedure TJclStream.LoadFromStream(Source: TStream; BufferSize: Integer);\r\nbegin\r\n StreamCopy(Source, Self, BufferSize);\r\nend;\r\n\r\nprocedure TJclStream.SaveToFile(const FileName: TFileName; BufferSize: Integer);\r\nvar\r\n FS: TStream;\r\nbegin\r\n FS := TFileStream.Create(FileName, fmCreate);\r\n try\r\n SaveToStream(FS, BufferSize);\r\n finally\r\n FS.Free;\r\n end;\r\nend;\r\n\r\nprocedure TJclStream.SaveToStream(Dest: TStream; BufferSize: Integer);\r\nbegin\r\n StreamCopy(Self, Dest, BufferSize);\r\nend;\r\n\r\nfunction TJclStream.Seek(const Offset: Int64; Origin: TSeekOrigin): Int64;\r\nbegin\r\n // override to customize\r\n Result := -1;\r\nend;\r\n\r\nprocedure TJclStream.SetSize(NewSize: Longint);\r\nbegin\r\n SetSize(Int64(NewSize));\r\nend;\r\n\r\nprocedure TJclStream.SetSize(const NewSize: Int64);\r\nbegin\r\n // override to customize\r\nend;\r\n\r\n//=== { TJclHandleStream } ===================================================\r\n\r\nconstructor TJclHandleStream.Create(AHandle: THandle);\r\nbegin\r\n inherited Create;\r\n FHandle := AHandle;\r\nend;\r\n\r\nfunction TJclHandleStream.Read(var Buffer; Count: Longint): Longint;\r\nbegin\r\n Result := 0;\r\n {$IFDEF MSWINDOWS}\r\n if (Count <= 0) or not ReadFile(Handle, Buffer, DWORD(Count), DWORD(Result), nil) then\r\n Result := 0;\r\n {$ENDIF MSWINDOWS}\r\n {$IFDEF LINUX}\r\n Result := __read(Handle, Buffer, Count);\r\n {$ENDIF LINUX}\r\nend;\r\n\r\nfunction TJclHandleStream.Write(const Buffer; Count: Longint): Longint;\r\nbegin\r\n Result := 0;\r\n {$IFDEF MSWINDOWS}\r\n if (Count <= 0) or not WriteFile(Handle, Buffer, DWORD(Count), DWORD(Result), nil) then\r\n Result := 0;\r\n {$ENDIF MSWINDOWS}\r\n {$IFDEF LINUX}\r\n Result := __write(Handle, Buffer, Count);\r\n {$ENDIF LINUX}\r\nend;\r\n\r\n{$IFDEF MSWINDOWS}\r\nfunction TJclHandleStream.Seek(const Offset: Int64; Origin: TSeekOrigin): Int64;\r\nconst\r\n INVALID_SET_FILE_POINTER = -1;\r\ntype\r\n TLarge = record\r\n case Boolean of\r\n False:\r\n (OffsetLo: Longint;\r\n OffsetHi: Longint);\r\n True:\r\n (Offset64: Int64);\r\n end;\r\nvar\r\n Offs: TLarge;\r\nbegin\r\n Offs.Offset64 := Offset;\r\n Offs.OffsetLo := SetFilePointer(Handle, Offs.OffsetLo, @Offs.OffsetHi, Ord(Origin));\r\n if (Offs.OffsetLo = INVALID_SET_FILE_POINTER) and (GetLastError <> NO_ERROR) then\r\n Result := -1\r\n else\r\n Result := Offs.Offset64;\r\nend;\r\n{$ENDIF MSWINDOWS}\r\n{$IFDEF LINUX}\r\nfunction TJclHandleStream.Seek(const Offset: Int64; Origin: TSeekOrigin): Int64;\r\nconst\r\n SeekOrigins: array [TSeekOrigin] of Cardinal = ( SEEK_SET {soBeginning}, SEEK_CUR {soCurrent}, SEEK_END {soEnd} );\r\nbegin\r\n Result := lseek(Handle, Offset, SeekOrigins[Origin]);\r\nend;\r\n{$ENDIF LINUX}\r\n\r\nprocedure TJclHandleStream.SetSize(const NewSize: Int64);\r\nbegin\r\n Seek(NewSize, soBeginning);\r\n {$IFDEF MSWINDOWS}\r\n if not SetEndOfFile(Handle) then\r\n RaiseLastOSError;\r\n {$ENDIF MSWINDOWS}\r\n {$IFDEF LINUX}\r\n if ftruncate(Handle, Position) = -1 then\r\n raise EJclStreamError.CreateRes(@RsStreamsSetSizeError);\r\n {$ENDIF LINUX}\r\nend;\r\n\r\n//=== { TJclFileStream } =====================================================\r\n\r\nconstructor TJclFileStream.Create(const FileName: TFileName; Mode: Word; Rights: Cardinal);\r\nvar\r\n H: THandle;\r\n{$IFDEF LINUX}\r\nconst\r\n INVALID_HANDLE_VALUE = -1;\r\n{$ENDIF LINUX}\r\nbegin\r\n if Mode = fmCreate then\r\n begin\r\n {$IFDEF LINUX}\r\n H := open(PChar(FileName), O_CREAT or O_RDWR, Rights);\r\n {$ENDIF LINUX}\r\n {$IFDEF MSWINDOWS}\r\n H := CreateFile(PChar(FileName), GENERIC_READ or GENERIC_WRITE,\r\n 0, nil, CREATE_ALWAYS, FILE_ATTRIBUTE_NORMAL, 0);\r\n {$ENDIF MSWINDOWS}\r\n inherited Create(H);\r\n if Handle = INVALID_HANDLE_VALUE then\r\n raise EJclStreamError.CreateResFmt(@RsStreamsCreateError, [FileName]);\r\n end\r\n else\r\n begin\r\n H := THandle(FileOpen(FileName, Mode));\r\n inherited Create(H);\r\n if Handle = INVALID_HANDLE_VALUE then\r\n raise EJclStreamError.CreateResFmt(@RsStreamsOpenError, [FileName]);\r\n end;\r\nend;\r\n\r\ndestructor TJclFileStream.Destroy;\r\nbegin\r\n {$IFDEF MSWINDOWS}\r\n if Handle <> INVALID_HANDLE_VALUE then\r\n CloseHandle(Handle);\r\n {$ENDIF MSWINDOWS}\r\n {$IFDEF LINUX}\r\n __close(Handle);\r\n {$ENDIF LINUX}\r\n inherited Destroy;\r\nend;\r\n\r\n//=== { TJclEmptyStream } ====================================================\r\n\r\n// a stream which stays empty no matter what you do\r\n// so it is a Unix /dev/null equivalent\r\n\r\nprocedure TJclEmptyStream.SetSize(const NewSize: Int64);\r\nbegin\r\n // nothing\r\nend;\r\n\r\nfunction TJclEmptyStream.Read(var Buffer; Count: Longint): Longint;\r\nbegin\r\n // you cannot read anything\r\n Result := 0;\r\nend;\r\n\r\nfunction TJclEmptyStream.Write(const Buffer; Count: Longint): Longint;\r\nbegin\r\n // you cannot write anything\r\n Result := 0;\r\nend;\r\n\r\nfunction TJclEmptyStream.Seek(const Offset: Int64; Origin: TSeekOrigin): Int64;\r\nbegin\r\n if Offset <> 0 then\r\n // seeking to anywhere except the position 0 is an error\r\n Result := -1\r\n else\r\n Result := 0;\r\nend;\r\n\r\n//=== { TJclNullStream } =====================================================\r\n\r\n// a stream which only keeps position and size, but no data\r\n// so it is a Unix /dev/zero equivalent (?)\r\n\r\nprocedure TJclNullStream.SetSize(const NewSize: Int64);\r\nbegin\r\n if NewSize > 0 then\r\n FSize := NewSize\r\n else\r\n FSize := 0;\r\n if FPosition > FSize then\r\n FPosition := FSize;\r\nend;\r\n\r\nfunction TJclNullStream.Read(var Buffer; Count: Longint): Longint;\r\nbegin\r\n if Count < 0 then\r\n Count := 0;\r\n // FPosition > FSize is possible!\r\n if FSize - FPosition < Count then\r\n Count := FSize - FPosition;\r\n // does not read if beyond EOF\r\n if Count > 0 then\r\n begin\r\n ResetMemory(Buffer, Count);\r\n FPosition := FPosition + Count;\r\n end;\r\n Result := Count;\r\nend;\r\n\r\nfunction TJclNullStream.Write(const Buffer; Count: Longint): Longint;\r\nbegin\r\n if Count < 0 then\r\n Count := 0;\r\n FPosition := FPosition + Count;\r\n // writing when FPosition > FSize is possible!\r\n if FPosition > FSize then\r\n FSize := FPosition;\r\n Result := Count;\r\nend;\r\n\r\nfunction TJclNullStream.Seek(const Offset: Int64; Origin: TSeekOrigin): Int64;\r\nvar\r\n Rel: Int64;\r\nbegin\r\n case Origin of\r\n soBeginning:\r\n Rel := 0;\r\n soCurrent:\r\n Rel := FPosition;\r\n soEnd:\r\n Rel := FSize;\r\n else\r\n // force Rel + Offset = -1 (code is never reached)\r\n Rel := Offset - 1;\r\n end;\r\n if Rel + Offset >= 0 then\r\n begin\r\n // all non-negative destination positions including beyond EOF are valid\r\n FPosition := Rel + Offset;\r\n Result := FPosition;\r\n end\r\n else\r\n Result := -1;\r\nend;\r\n\r\n//=== { TJclRandomStream } ===================================================\r\n\r\n// A TJclNullStream decendant which returns random data when read\r\n// so it is a Unix /dev/random equivalent\r\n\r\nfunction TJclRandomStream.GetRandSeed: Longint;\r\nbegin\r\n Result := System.RandSeed;\r\nend;\r\n\r\nprocedure TJclRandomStream.SetRandSeed(Seed: Longint);\r\nbegin\r\n System.RandSeed := Seed;\r\nend;\r\n\r\nfunction TJclRandomStream.RandomData: Byte;\r\nbegin\r\n Result := System.Random(256);\r\nend;\r\n\r\nprocedure TJclRandomStream.Randomize;\r\nbegin\r\n System.Randomize;\r\nend;\r\n\r\nfunction TJclRandomStream.Read(var Buffer; Count: Longint): Longint;\r\nvar\r\n I: Longint;\r\n BufferPtr: PByte;\r\nbegin\r\n // this handles all necessary checks\r\n Count := inherited Read(Buffer, Count);\r\n BufferPtr := @Buffer;\r\n for I := 0 to Count - 1 do\r\n begin\r\n BufferPtr^ := RandomData;\r\n Inc(BufferPtr);\r\n end;\r\n Result := Count;\r\nend;\r\n\r\n//=== { TJclMultiplexStream } ================================================\r\n\r\nconstructor TJclMultiplexStream.Create;\r\nbegin\r\n inherited Create;\r\n FStreams := TList.Create;\r\n FReadStreamIndex := -1;\r\nend;\r\n\r\ndestructor TJclMultiplexStream.Destroy;\r\nbegin\r\n FStreams.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJclMultiplexStream.Add(NewStream: TStream): Integer;\r\nbegin\r\n Result := FStreams.Add(Pointer(NewStream));\r\nend;\r\n\r\nprocedure TJclMultiplexStream.Clear;\r\nbegin\r\n FStreams.Clear;\r\n FReadStreamIndex := -1;\r\nend;\r\n\r\nprocedure TJclMultiplexStream.Delete(const Index: Integer);\r\nbegin\r\n FStreams.Delete(Index);\r\n if ReadStreamIndex = Index then\r\n FReadStreamIndex := -1\r\n else\r\n if ReadStreamIndex > Index then\r\n Dec(FReadStreamIndex);\r\nend;\r\n\r\nfunction TJclMultiplexStream.GetReadStream: TStream;\r\nbegin\r\n if FReadStreamIndex >= 0 then\r\n Result := TStream(FStreams.Items[FReadStreamIndex])\r\n else\r\n Result := nil;\r\nend;\r\n\r\nfunction TJclMultiplexStream.GetStream(Index: Integer): TStream;\r\nbegin\r\n Result := TStream(FStreams.Items[Index]);\r\nend;\r\n\r\nfunction TJclMultiplexStream.GetCount: Integer;\r\nbegin\r\n Result := FStreams.Count;\r\nend;\r\n\r\nfunction TJclMultiplexStream.Read(var Buffer; Count: Longint): Longint;\r\nvar\r\n Stream: TStream;\r\nbegin\r\n Stream := ReadStream;\r\n if Assigned(Stream) then\r\n Result := Stream.Read(Buffer, Count)\r\n else\r\n Result := 0;\r\nend;\r\n\r\nfunction TJclMultiplexStream.Remove(AStream: TStream): Integer;\r\nbegin\r\n Result := FStreams.Remove(Pointer(AStream));\r\n if FReadStreamIndex = Result then\r\n FReadStreamIndex := -1\r\n else\r\n if FReadStreamIndex > Result then\r\n Dec(FReadStreamIndex);\r\nend;\r\n\r\nfunction TJclMultiplexStream.Seek(const Offset: Int64; Origin: TSeekOrigin): Int64;\r\nbegin\r\n // what should this function do?\r\n Result := -1;\r\nend;\r\n\r\nprocedure TJclMultiplexStream.SetReadStream(const Value: TStream);\r\nbegin\r\n FReadStreamIndex := FStreams.IndexOf(Pointer(Value));\r\nend;\r\n\r\nprocedure TJclMultiplexStream.SetReadStreamIndex(const Value: Integer);\r\nbegin\r\n FReadStreamIndex := Value;\r\nend;\r\n\r\nprocedure TJclMultiplexStream.SetSize(const NewSize: Int64);\r\nbegin\r\n // what should this function do?\r\nend;\r\n\r\nprocedure TJclMultiplexStream.SetStream(Index: Integer; const Value: TStream);\r\nbegin\r\n FStreams.Items[Index] := Pointer(Value);\r\nend;\r\n\r\nfunction TJclMultiplexStream.Write(const Buffer; Count: Longint): Longint;\r\nvar\r\n Index: Integer;\r\n ByteWritten, MinByteWritten: Longint;\r\nbegin\r\n MinByteWritten := Count;\r\n for Index := 0 to Self.Count - 1 do\r\n begin\r\n ByteWritten := TStream(FStreams.Items[Index]).Write(Buffer, Count);\r\n if ByteWritten < MinByteWritten then\r\n MinByteWritten := ByteWritten;\r\n end;\r\n Result := MinByteWritten;\r\nend;\r\n\r\n//=== { TJclStreamDecorator } ================================================\r\n\r\nconstructor TJclStreamDecorator.Create(AStream: TStream; AOwnsStream: Boolean = False);\r\nbegin\r\n inherited Create;\r\n FStream := AStream;\r\n FOwnsStream := AOwnsStream;\r\nend;\r\n\r\ndestructor TJclStreamDecorator.Destroy;\r\nbegin\r\n if OwnsStream then\r\n FStream.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJclStreamDecorator.DoAfterStreamChange;\r\nbegin\r\n if Assigned(FAfterStreamChange) then\r\n FAfterStreamChange(Self);\r\nend;\r\n\r\nprocedure TJclStreamDecorator.DoBeforeStreamChange;\r\nbegin\r\n if Assigned(FBeforeStreamChange) then\r\n FBeforeStreamChange(Self);\r\nend;\r\n\r\nfunction TJclStreamDecorator.Read(var Buffer; Count: Longint): Longint;\r\nbegin\r\n if Assigned(FStream) then\r\n Result := Stream.Read(Buffer, Count)\r\n else\r\n Result := 0;\r\nend;\r\n\r\nfunction TJclStreamDecorator.Seek(const Offset: Int64; Origin: TSeekOrigin): Int64;\r\nbegin\r\n Result := Stream.Seek(Offset, Origin);\r\nend;\r\n\r\nprocedure TJclStreamDecorator.SetSize(const NewSize: Int64);\r\nbegin\r\n if Assigned(FStream) then\r\n Stream.Size := NewSize;\r\nend;\r\n\r\nprocedure TJclStreamDecorator.SetStream(Value: TStream);\r\nbegin\r\n if Value <> FStream then\r\n try\r\n DoBeforeStreamChange;\r\n finally\r\n if OwnsStream then\r\n FStream.Free;\r\n FStream := Value;\r\n DoAfterStreamChange;\r\n end;\r\nend;\r\n\r\nfunction TJclStreamDecorator.Write(const Buffer; Count: Longint): Longint;\r\nbegin\r\n if Assigned(FStream) then\r\n Result := Stream.Write(Buffer, Count)\r\n else\r\n Result := 0;\r\nend;\r\n\r\n//=== { TJclBufferedStream } =================================================\r\n\r\nconstructor TJclBufferedStream.Create(AStream: TStream; AOwnsStream: Boolean = False);\r\nbegin\r\n inherited Create(AStream, AOwnsStream);\r\n if Stream <> nil then\r\n FPosition := Stream.Position;\r\n BufferSize := StreamDefaultBufferSize;\r\n LoadBuffer;\r\nend;\r\n\r\ndestructor TJclBufferedStream.Destroy;\r\nbegin\r\n Flush;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJclBufferedStream.BufferHit: Boolean;\r\nbegin\r\n Result := (FBufferStart <= FPosition) and (FPosition < (FBufferStart + FBufferCurrentSize));\r\nend;\r\n\r\nprocedure TJclBufferedStream.DoAfterStreamChange;\r\nbegin\r\n inherited DoAfterStreamChange;\r\n FBufferCurrentSize := 0; // invalidate buffer after stream is changed\r\n FBufferStart := 0;\r\n if Stream <> nil then\r\n FPosition := Stream.Position;\r\nend;\r\n\r\nprocedure TJclBufferedStream.DoBeforeStreamChange;\r\nbegin\r\n inherited DoBeforeStreamChange;\r\n Flush;\r\nend;\r\n\r\nprocedure TJclBufferedStream.Flush;\r\nbegin\r\n if (Stream <> nil) and (FBufferMaxModifiedPos > 0) then\r\n begin\r\n Stream.Position := FBufferStart;\r\n Stream.WriteBuffer(FBuffer[0], FBufferMaxModifiedPos);\r\n FBufferMaxModifiedPos := 0;\r\n end;\r\nend;\r\n\r\nfunction TJclBufferedStream.GetCalcedSize: Int64;\r\nbegin\r\n if Assigned(Stream) then\r\n Result := Stream.Size\r\n else\r\n Result := 0;\r\n if Result < FBufferMaxModifiedPos + FBufferStart then\r\n Result := FBufferMaxModifiedPos + FBufferStart;\r\nend;\r\n\r\nfunction TJclBufferedStream.LoadBuffer: Boolean;\r\nbegin\r\n Flush;\r\n if Length(FBuffer) <> FBufferSize then\r\n SetLength(FBuffer, FBufferSize);\r\n if Stream <> nil then\r\n begin\r\n Stream.Position := FPosition;\r\n FBufferCurrentSize := Stream.Read(FBuffer[0], FBufferSize);\r\n end\r\n else\r\n FBufferCurrentSize := 0;\r\n FBufferStart := FPosition;\r\n Result := (FBufferCurrentSize > 0);\r\nend;\r\n\r\nfunction TJclBufferedStream.Read(var Buffer; Count: Longint): Longint;\r\nconst\r\n Offset = 0;\r\nbegin\r\n Result := Count + Offset;\r\n while Count > 0 do\r\n begin\r\n if not BufferHit then\r\n if not LoadBuffer then\r\n Break;\r\n Dec(Count, ReadFromBuffer(Buffer, Count, Result - Count));\r\n end;\r\n Result := Result - Count - Offset;\r\nend;\r\n\r\nfunction TJclBufferedStream.ReadFromBuffer(var Buffer; Count, Start: Longint): Longint;\r\nvar\r\n BufPos: Longint;\r\n P: PAnsiChar;\r\nbegin\r\n Result := Count;\r\n BufPos := FPosition - FBufferStart;\r\n if Result > FBufferCurrentSize - BufPos then\r\n Result := FBufferCurrentSize - BufPos;\r\n P := @Buffer;\r\n Move(FBuffer[BufPos], P[Start], Result);\r\n Inc(FPosition, Result);\r\nend;\r\n\r\nfunction TJclBufferedStream.Seek(const Offset: Int64;\r\n Origin: TSeekOrigin): Int64;\r\nvar\r\n NewPos: Int64;\r\nbegin\r\n NewPos := FPosition;\r\n case Origin of\r\n soBeginning:\r\n NewPos := Offset;\r\n soCurrent:\r\n Inc(NewPos, Offset);\r\n soEnd:\r\n NewPos := GetCalcedSize + Offset;\r\n else\r\n NewPos := -1;\r\n end;\r\n if NewPos < 0 then\r\n NewPos := -1\r\n else\r\n FPosition := NewPos;\r\n Result := NewPos;\r\nend;\r\n\r\nprocedure TJclBufferedStream.SetSize(const NewSize: Int64);\r\nbegin\r\n inherited SetSize(NewSize);\r\n if NewSize < (FBufferStart + FBufferMaxModifiedPos) then\r\n begin\r\n FBufferMaxModifiedPos := NewSize - FBufferStart;\r\n if FBufferMaxModifiedPos < 0 then\r\n FBufferMaxModifiedPos := 0;\r\n end;\r\n if NewSize < (FBufferStart + FBufferCurrentSize) then\r\n begin\r\n FBufferCurrentSize := NewSize - FBufferStart;\r\n if FBufferCurrentSize < 0 then\r\n FBufferCurrentSize := 0;\r\n end;\r\n // fix from Marcelo Rocha\r\n if Stream <> nil then\r\n FPosition := Stream.Position;\r\nend;\r\n\r\nfunction TJclBufferedStream.Write(const Buffer; Count: Longint): Longint;\r\nconst\r\n Offset = 0;\r\nbegin\r\n Result := Count + Offset;\r\n while Count > 0 do\r\n begin\r\n if (FBufferStart > FPosition) or (FPosition >= (FBufferStart + FBufferSize)) then\r\n LoadBuffer;\r\n Dec(Count, WriteToBuffer(Buffer, Count, Result - Count));\r\n end;\r\n Result := Result - Count - Offset;\r\nend;\r\n\r\nfunction TJclBufferedStream.WriteToBuffer(const Buffer; Count, Start: Longint): Longint;\r\nvar\r\n BufPos: Longint;\r\n P: PAnsiChar;\r\nbegin\r\n Result := Count;\r\n BufPos := FPosition - FBufferStart;\r\n if Result > Length(FBuffer) - BufPos then\r\n Result := Length(FBuffer) - BufPos;\r\n if FBufferCurrentSize < BufPos + Result then\r\n FBufferCurrentSize := BufPos + Result;\r\n P := @Buffer;\r\n Move(P[Start], FBuffer[BufPos], Result);\r\n if FBufferMaxModifiedPos < BufPos + Result then\r\n FBufferMaxModifiedPos := BufPos + Result;\r\n Inc(FPosition, Result);\r\nend;\r\n\r\n//=== { TJclEventStream } ====================================================\r\n\r\nconstructor TJclEventStream.Create(AStream: TStream; ANotification:\r\n TStreamNotifyEvent = nil; AOwnsStream: Boolean = False);\r\nbegin\r\n inherited Create(AStream, AOwnsStream);\r\n FNotification := ANotification;\r\nend;\r\n\r\nprocedure TJclEventStream.DoAfterStreamChange;\r\nbegin\r\n inherited DoAfterStreamChange;\r\n if Stream <> nil then\r\n DoNotification;\r\nend;\r\n\r\nprocedure TJclEventStream.DoBeforeStreamChange;\r\nbegin\r\n inherited DoBeforeStreamChange;\r\n if Stream <> nil then\r\n DoNotification;\r\nend;\r\n\r\nprocedure TJclEventStream.DoNotification;\r\nbegin\r\n if Assigned(FNotification) then\r\n FNotification(Self, Stream.Position, Stream.Size);\r\nend;\r\n\r\nfunction TJclEventStream.Read(var Buffer; Count: Longint): Longint;\r\nbegin\r\n Result := inherited Read(Buffer, Count);\r\n DoNotification;\r\nend;\r\n\r\nfunction TJclEventStream.Seek(const Offset: Int64; Origin: TSeekOrigin): Int64;\r\nbegin\r\n Result := inherited Seek(Offset, Origin);\r\n DoNotification;\r\nend;\r\n\r\nprocedure TJclEventStream.SetSize(const NewSize: Int64);\r\nbegin\r\n inherited SetSize(NewSize);\r\n DoNotification;\r\nend;\r\n\r\nfunction TJclEventStream.Write(const Buffer; Count: Longint): Longint;\r\nbegin\r\n Result := inherited Write(Buffer, Count);\r\n DoNotification;\r\nend;\r\n\r\n//=== { TJclEasyStream } =====================================================\r\n\r\nfunction TJclEasyStream.IsEqual(Stream: TStream): Boolean;\r\nvar\r\n SavePos, StreamSavePos: Int64;\r\nbegin\r\n SavePos := Position;\r\n StreamSavePos := Stream.Position;\r\n try\r\n Position := 0;\r\n Stream.Position := 0;\r\n Result := CompareStreams(Self, Stream);\r\n finally\r\n Position := SavePos;\r\n Stream.Position := StreamSavePos;\r\n end;\r\nend;\r\n\r\nfunction TJclEasyStream.ReadBoolean: Boolean;\r\nbegin\r\n Result := False;\r\n ReadBuffer(Result, SizeOf(Result));\r\nend;\r\n\r\nfunction TJclEasyStream.ReadChar: Char;\r\nbegin\r\n Result := #0;\r\n ReadBuffer(Result, SizeOf(Result));\r\nend;\r\n\r\nfunction TJclEasyStream.ReadAnsiChar: AnsiChar;\r\nbegin\r\n Result := #0;\r\n ReadBuffer(Result, SizeOf(Result));\r\nend;\r\n\r\nfunction TJclEasyStream.ReadWideChar: WideChar;\r\nbegin\r\n Result := #0;\r\n ReadBuffer(Result, SizeOf(Result));\r\nend;\r\n\r\nfunction TJclEasyStream.ReadByte: Byte;\r\nbegin\r\n Result := 0;\r\n ReadBuffer(Result, SizeOf(Result));\r\nend;\r\n\r\nfunction TJclEasyStream.ReadCurrency: Currency;\r\nbegin\r\n Result := 0;\r\n ReadBuffer(Result, SizeOf(Result));\r\nend;\r\n\r\nfunction TJclEasyStream.ReadDateTime: TDateTime;\r\nbegin\r\n Result := 0;\r\n ReadBuffer(Result, SizeOf(Result));\r\nend;\r\n\r\nfunction TJclEasyStream.ReadDouble: Double;\r\nbegin\r\n Result := 0;\r\n ReadBuffer(Result, SizeOf(Result));\r\nend;\r\n\r\nfunction TJclEasyStream.ReadExtended: Extended;\r\nbegin\r\n Result := 0;\r\n ReadBuffer(Result, SizeOf(Result));\r\nend;\r\n\r\nfunction TJclEasyStream.ReadInt64: Int64;\r\nbegin\r\n Result := 0;\r\n ReadBuffer(Result, SizeOf(Result));\r\nend;\r\n\r\nfunction TJclEasyStream.ReadInteger: Integer;\r\nbegin\r\n Result := 0;\r\n ReadBuffer(Result, SizeOf(Result));\r\nend;\r\n\r\nfunction TJclEasyStream.ReadCString: string;\r\nbegin\r\n {$IFDEF SUPPORTS_UNICODE}\r\n Result := ReadCWideString;\r\n {$ELSE ~SUPPORTS_UNICODE}\r\n Result := ReadCAnsiString;\r\n {$ENDIF ~SUPPORTS_UNICODE}\r\nend;\r\n\r\nfunction TJclEasyStream.ReadCAnsiString: AnsiString;\r\nvar\r\n CurrPos: Longint;\r\n StrSize: Integer;\r\nbegin\r\n CurrPos := Position;\r\n repeat\r\n until ReadAnsiChar = #0;\r\n StrSize := Position - CurrPos; // Get number of bytes\r\n SetLength(Result, StrSize div SizeOf(AnsiChar) - 1); // Set number of chars without #0\r\n Position := CurrPos; // Seek to start read\r\n ReadBuffer(Result[1], StrSize); // Read ansi data and #0\r\nend;\r\n\r\nfunction TJclEasyStream.ReadCWideString: WideString;\r\nvar\r\n CurrPos: Integer;\r\n StrSize: Integer;\r\nbegin\r\n CurrPos := Position;\r\n repeat\r\n until ReadWideChar = #0;\r\n StrSize := Position - CurrPos; // Get number of bytes\r\n SetLength(Result, StrSize div SizeOf(WideChar) - 1); // Set number of chars without #0\r\n Position := CurrPos; // Seek to start read\r\n ReadBuffer(Result[1], StrSize); // Read wide data and #0\r\nend;\r\n\r\nfunction TJclEasyStream.ReadShortString: string;\r\nvar\r\n StrSize: Integer;\r\nbegin\r\n StrSize := Ord(ReadChar);\r\n SetString(Result, PChar(nil), StrSize);\r\n ReadBuffer(Pointer(Result)^, StrSize);\r\nend;\r\n\r\nfunction TJclEasyStream.ReadSingle: Single;\r\nbegin\r\n Result := 0;\r\n ReadBuffer(Result, SizeOf(Result));\r\nend;\r\n\r\nfunction TJclEasyStream.ReadSizedString: string;\r\nbegin\r\n {$IFDEF SUPPORTS_UNICODE}\r\n Result := ReadSizedWideString;\r\n {$ELSE ~SUPPORTS_UNICODE}\r\n Result := ReadSizedAnsiString;\r\n {$ENDIF ~SUPPORTS_UNICODE}\r\nend;\r\n\r\nfunction TJclEasyStream.ReadSizedAnsiString: AnsiString;\r\nvar\r\n StrSize: Integer;\r\nbegin\r\n StrSize := ReadInteger;\r\n SetLength(Result, StrSize);\r\n ReadBuffer(Result[1], StrSize * SizeOf(Result[1]));\r\nend;\r\n\r\nfunction TJclEasyStream.ReadSizedWideString: WideString;\r\nvar\r\n StrSize: Integer;\r\nbegin\r\n StrSize := ReadInteger;\r\n SetLength(Result, StrSize);\r\n ReadBuffer(Result[1], StrSize * SizeOf(Result[1]));\r\nend;\r\n\r\nprocedure TJclEasyStream.WriteBoolean(Value: Boolean);\r\nbegin\r\n WriteBuffer(Value, SizeOf(Value));\r\nend;\r\n\r\nprocedure TJclEasyStream.WriteChar(Value: Char);\r\nbegin\r\n WriteBuffer(Value, SizeOf(Value));\r\nend;\r\n\r\nprocedure TJclEasyStream.WriteAnsiChar(Value: AnsiChar);\r\nbegin\r\n WriteBuffer(Value, SizeOf(Value));\r\nend;\r\n\r\nprocedure TJclEasyStream.WriteWideChar(Value: WideChar);\r\nbegin\r\n WriteBuffer(Value, SizeOf(Value));\r\nend;\r\n\r\nprocedure TJclEasyStream.WriteByte(Value: Byte);\r\nbegin\r\n WriteBuffer(Value, SizeOf(Value));\r\nend;\r\n\r\nprocedure TJclEasyStream.WriteCurrency(const Value: Currency);\r\nbegin\r\n WriteBuffer(Value, SizeOf(Value));\r\nend;\r\n\r\nprocedure TJclEasyStream.WriteDateTime(const Value: TDateTime);\r\nbegin\r\n WriteBuffer(Value, SizeOf(Value));\r\nend;\r\n\r\nprocedure TJclEasyStream.WriteDouble(const Value: Double);\r\nbegin\r\n WriteBuffer(Value, SizeOf(Value));\r\nend;\r\n\r\nprocedure TJclEasyStream.WriteExtended(const Value: Extended);\r\nbegin\r\n WriteBuffer(Value, SizeOf(Value));\r\nend;\r\n\r\nprocedure TJclEasyStream.WriteInt64(Value: Int64);\r\nbegin\r\n WriteBuffer(Value, SizeOf(Value));\r\nend;\r\n\r\nprocedure TJclEasyStream.WriteInteger(Value: Integer);\r\nbegin\r\n WriteBuffer(Value, SizeOf(Value));\r\nend;\r\n\r\nprocedure TJclEasyStream.WriteCString(const Value: string);\r\nbegin\r\n {$IFDEF SUPPORTS_UNICODE}\r\n WriteCWideString(Value);\r\n {$ELSE ~SUPPORTS_UNICODE}\r\n WriteCAnsiString(Value);\r\n {$ENDIF ~SUPPORTS_UNICODE}\r\nend;\r\n\r\nprocedure TJclEasyStream.WriteCAnsiString(const Value: AnsiString);\r\nvar\r\n StrSize: Integer;\r\nbegin\r\n StrSize := Length(Value);\r\n WriteBuffer(Value[1], (StrSize + 1) * SizeOf(Value[1]));\r\nend;\r\n\r\nprocedure TJclEasyStream.WriteCWideString(const Value: WideString);\r\nvar\r\n StrSize: Integer;\r\nbegin\r\n StrSize := Length(Value);\r\n WriteBuffer(Value[1], (StrSize + 1) * SizeOf(Value[1]));\r\nend;\r\n\r\nprocedure TJclEasyStream.WriteShortString(const Value: ShortString);\r\nbegin\r\n WriteBuffer(Value[0], Length(Value) + 1);\r\nend;\r\n\r\nprocedure TJclEasyStream.WriteSingle(const Value: Single);\r\nbegin\r\n WriteBuffer(Value, SizeOf(Value));\r\nend;\r\n\r\nprocedure TJclEasyStream.WriteSizedString(const Value: string);\r\nbegin\r\n {$IFDEF SUPPORTS_UNICODE}\r\n WriteSizedWideString(Value);\r\n {$ELSE ~SUPPORTS_UNICODE}\r\n WriteSizedAnsiString(Value);\r\n {$ENDIF ~SUPPORTS_UNICODE}\r\nend;\r\n\r\nprocedure TJclEasyStream.WriteSizedAnsiString(const Value: AnsiString);\r\nvar\r\n StrSize: Integer;\r\nbegin\r\n StrSize := Length(Value);\r\n WriteInteger(StrSize);\r\n WriteBuffer(Value[1], StrSize * SizeOf(Value[1]));\r\nend;\r\n\r\nprocedure TJclEasyStream.WriteSizedWideString(const Value: WideString);\r\nvar\r\n StrSize: Integer;\r\nbegin\r\n StrSize := Length(Value);\r\n WriteInteger(StrSize);\r\n WriteBuffer(Value[1], StrSize * SizeOf(Value[1]));\r\nend;\r\n\r\n//=== { TJclScopedStream } ===================================================\r\n\r\nconstructor TJclScopedStream.Create(AParentStream: TStream; const AMaxSize: Int64);\r\nbegin\r\n inherited Create;\r\n\r\n FParentStream := AParentStream;\r\n FStartPos := ParentStream.Position;\r\n FCurrentPos := 0;\r\n FMaxSize := AMaxSize;\r\nend;\r\n\r\nconstructor TJclScopedStream.Create(AParentStream: TStream; const AStartPos, AMaxSize: Int64);\r\nbegin\r\n inherited Create;\r\n\r\n FParentStream := AParentStream;\r\n FStartPos := AStartPos;\r\n FCurrentPos := 0;\r\n FMaxSize := AMaxSize;\r\nend;\r\n\r\nfunction TJclScopedStream.Read(var Buffer; Count: Longint): Longint;\r\nbegin\r\n if (MaxSize >= 0) and ((FCurrentPos + Count) > MaxSize) then\r\n Count := MaxSize - FCurrentPos;\r\n\r\n if (Count > 0) and Assigned(ParentStream) then\r\n begin\r\n Result := ParentStream.Read(Buffer, Count);\r\n Inc(FCurrentPos, Result);\r\n end\r\n else\r\n Result := 0;\r\nend;\r\n\r\nfunction TJclScopedStream.Seek(const Offset: Int64; Origin: TSeekOrigin): Int64;\r\nbegin\r\n case Origin of\r\n soBeginning:\r\n begin\r\n if (Offset < 0) or ((MaxSize >= 0) and (Offset > MaxSize)) then\r\n Result := -1 // low and high bound check\r\n else\r\n Result := ParentStream.Seek(StartPos + Offset, soBeginning) - StartPos;\r\n end;\r\n soCurrent:\r\n begin\r\n if Offset = 0 then\r\n Result := FCurrentPos // speeding the Position property up\r\n else if ((FCurrentPos + Offset) < 0) or ((MaxSize >= 0)\r\n and ((FCurrentPos + Offset) > MaxSize)) then\r\n Result := -1 // low and high bound check\r\n else\r\n Result := ParentStream.Seek(Offset, soCurrent) - StartPos;\r\n end;\r\n soEnd:\r\n begin\r\n if (MaxSize >= 0) then\r\n begin\r\n if (Offset > 0) or (MaxSize < -Offset) then // low and high bound check\r\n Result := -1\r\n else\r\n Result := ParentStream.Seek(StartPos + MaxSize + Offset, soBeginning) - StartPos;\r\n end\r\n else\r\n begin\r\n Result := ParentStream.Seek(Offset, soEnd);\r\n if (Result <> -1) and (Result < StartPos) then // low bound check\r\n begin\r\n Result := -1;\r\n ParentStream.Seek(StartPos + FCurrentPos, soBeginning);\r\n end;\r\n end;\r\n end;\r\n else\r\n Result := -1;\r\n end;\r\n if Result <> -1 then\r\n FCurrentPos := Result;\r\nend;\r\n\r\nprocedure TJclScopedStream.SetSize(const NewSize: Int64);\r\nvar\r\n ScopedNewSize: Int64;\r\nbegin\r\n if (FMaxSize >= 0) and (NewSize >= (FStartPos + FMaxSize)) then\r\n ScopedNewSize := FMaxSize + FStartPos\r\n else\r\n ScopedNewSize := NewSize;\r\n inherited SetSize(ScopedNewSize);\r\nend;\r\n\r\nfunction TJclScopedStream.Write(const Buffer; Count: Longint): Longint;\r\nbegin\r\n if (MaxSize >= 0) and ((FCurrentPos + Count) > MaxSize) then\r\n Count := MaxSize - FCurrentPos;\r\n\r\n if (Count > 0) and Assigned(ParentStream) then\r\n begin\r\n Result := ParentStream.Write(Buffer, Count);\r\n Inc(FCurrentPos, Result);\r\n end\r\n else\r\n Result := 0;\r\nend;\r\n\r\n//=== { TJclDelegateStream } =================================================\r\n\r\nprocedure TJclDelegatedStream.SetSize(const NewSize: Int64);\r\nbegin\r\n if Assigned(FOnSize) then\r\n FOnSize(Self, NewSize);\r\nend;\r\n\r\nfunction TJclDelegatedStream.Seek(const Offset: Int64; Origin: TSeekOrigin): Int64;\r\nbegin\r\n if Assigned(FOnSeek) then\r\n Result := FOnSeek(Self, Offset, Origin)\r\n else\r\n Result := -1;\r\nend;\r\n\r\nfunction TJclDelegatedStream.Read(var Buffer; Count: Longint): Longint;\r\nbegin\r\n if Assigned(FOnRead) then\r\n Result := FOnRead(Self, Buffer, Count)\r\n else\r\n Result := -1;\r\nend;\r\n\r\nfunction TJclDelegatedStream.Write(const Buffer; Count: Longint): Longint;\r\nbegin\r\n if Assigned(FOnWrite) then\r\n Result := FOnWrite(Self, Buffer, Count)\r\n else\r\n Result := -1;\r\nend;\r\n\r\n//=== { TJclSectoredStream } =================================================\r\n\r\nprocedure TJclSectoredStream.AfterBlockRead;\r\nbegin\r\n // override to customize (checks of protection)\r\nend;\r\n\r\nprocedure TJclSectoredStream.BeforeBlockWrite;\r\nbegin\r\n // override to customize (computation of protection)\r\nend;\r\n\r\nconstructor TJclSectoredStream.Create(AStorageStream: TStream;\r\n AOwnsStream: Boolean; ASectorOverHead: Integer);\r\nbegin\r\n inherited Create(AStorageStream, AOwnsStream);\r\n FSectorOverHead := ASectorOverHead;\r\n if Stream <> nil then\r\n FPosition := SectoredToFlat(Stream.Position);\r\nend;\r\n\r\nprocedure TJclSectoredStream.DoAfterStreamChange;\r\nbegin\r\n inherited DoAfterStreamChange;\r\n if Stream <> nil then\r\n FPosition := SectoredToFlat(Stream.Position);\r\nend;\r\n\r\nfunction TJclSectoredStream.FlatToSectored(const Position: Int64): Int64;\r\nbegin\r\n Result := (Position div BufferSize) * (Int64(BufferSize) + FSectorOverHead) // add overheads of previous buffers\r\n + (Position mod BufferSize); // offset in sector\r\nend;\r\n\r\nprocedure TJclSectoredStream.Flush;\r\nbegin\r\n if (Stream <> nil) and (FBufferMaxModifiedPos > 0) then\r\n begin\r\n BeforeBlockWrite;\r\n\r\n Stream.Position := FlatToSectored(FBufferStart);\r\n Stream.WriteBuffer(FBuffer[0], FBufferCurrentSize + FSectorOverHead);\r\n FBufferMaxModifiedPos := 0;\r\n end;\r\nend;\r\n\r\nfunction TJclSectoredStream.GetCalcedSize: Int64;\r\nvar\r\n VirtualSize: Int64;\r\nbegin\r\n if Assigned(Stream) then\r\n Result := SectoredToFlat(Stream.Size)\r\n else\r\n Result := 0;\r\n VirtualSize := FBufferMaxModifiedPos + FBufferStart;\r\n if Result < VirtualSize then\r\n Result := VirtualSize;\r\nend;\r\n\r\nfunction TJclSectoredStream.LoadBuffer: Boolean;\r\nvar\r\n TotalSectorSize: Longint;\r\nbegin\r\n Flush;\r\n TotalSectorSize := FBufferSize + FSectorOverHead;\r\n if Length(FBuffer) <> TotalSectorSize then\r\n SetLength(FBuffer, TotalSectorSize);\r\n FBufferStart := (FPosition div BufferSize) * BufferSize;\r\n if Stream <> nil then\r\n begin\r\n Stream.Position := FlatToSectored(FBufferStart);\r\n FBufferCurrentSize := Stream.Read(FBuffer[0], TotalSectorSize);\r\n if FBufferCurrentSize > 0 then\r\n begin\r\n Dec(FBufferCurrentSize, FSectorOverHead);\r\n AfterBlockRead;\r\n end;\r\n end\r\n else\r\n FBufferCurrentSize := 0;\r\n Result := (FBufferCurrentSize > 0);\r\nend;\r\n\r\nfunction TJclSectoredStream.SectoredToFlat(const Position: Int64): Int64;\r\nvar\r\n TotalSectorSize: Int64;\r\nbegin\r\n TotalSectorSize := Int64(BufferSize) + FSectorOverHead;\r\n Result := (Position div TotalSectorSize) * BufferSize // remove previous overheads\r\n + Position mod TotalSectorSize; // offset in sector\r\nend;\r\n\r\nprocedure TJclSectoredStream.SetSize(const NewSize: Int64);\r\nbegin\r\n inherited SetSize(FlatToSectored(NewSize));\r\nend;\r\n\r\n//=== { TJclCRC16Stream } ====================================================\r\n\r\nprocedure TJclCRC16Stream.AfterBlockRead;\r\nvar\r\n CRC: Word;\r\nbegin\r\n CRC := Word(FBuffer[FBufferCurrentSize]) or (Word(FBuffer[FBufferCurrentSize + 1]) shl 8);\r\n if CheckCrc16(FBuffer, FBufferCurrentSize, CRC) < 0 then\r\n raise EJclStreamError.CreateRes(@RsStreamsCRCError);\r\nend;\r\n\r\nprocedure TJclCRC16Stream.BeforeBlockWrite;\r\nvar\r\n CRC: Word;\r\nbegin\r\n CRC := Crc16(FBuffer, FBufferCurrentSize);\r\n FBuffer[FBufferCurrentSize] := CRC and $FF;\r\n FBuffer[FBufferCurrentSize + 1] := CRC shr 8;\r\nend;\r\n\r\nconstructor TJclCRC16Stream.Create(AStorageStream: TStream; AOwnsStream: Boolean);\r\nbegin\r\n inherited Create(AStorageStream, AOwnsStream, 2);\r\nend;\r\n\r\n//=== { TJclCRC32Stream } ====================================================\r\n\r\nprocedure TJclCRC32Stream.AfterBlockRead;\r\nvar\r\n CRC: Cardinal;\r\nbegin\r\n CRC := Cardinal(FBuffer[FBufferCurrentSize]) or (Cardinal(FBuffer[FBufferCurrentSize + 1]) shl 8)\r\n or (Cardinal(FBuffer[FBufferCurrentSize + 2]) shl 16) or (Cardinal(FBuffer[FBufferCurrentSize + 3]) shl 24);\r\n if CheckCrc32(FBuffer, FBufferCurrentSize, CRC) < 0 then\r\n raise EJclStreamError.CreateRes(@RsStreamsCRCError);\r\nend;\r\n\r\nprocedure TJclCRC32Stream.BeforeBlockWrite;\r\nvar\r\n CRC: Cardinal;\r\nbegin\r\n CRC := Crc32(FBuffer, FBufferCurrentSize);\r\n FBuffer[FBufferCurrentSize] := CRC and $FF;\r\n FBuffer[FBufferCurrentSize + 1] := (CRC shr 8) and $FF;\r\n FBuffer[FBufferCurrentSize + 2] := (CRC shr 16) and $FF;\r\n FBuffer[FBufferCurrentSize + 3] := (CRC shr 24) and $FF;\r\nend;\r\n\r\nconstructor TJclCRC32Stream.Create(AStorageStream: TStream;\r\n AOwnsStream: Boolean);\r\nbegin\r\n inherited Create(AStorageStream, AOwnsStream, 4);\r\nend;\r\n\r\n//=== { TJclSplitStream } ====================================================\r\n\r\nconstructor TJclSplitStream.Create(AForcePosition: Boolean);\r\nbegin\r\n inherited Create;\r\n FVolume := nil;\r\n FVolumeIndex := -1;\r\n FVolumeMaxSize := 0;\r\n FPosition := 0;\r\n FVolumePosition := 0;\r\n FForcePosition := AForcePosition;\r\nend;\r\n\r\nfunction TJclSplitStream.GetSize: Int64;\r\nvar\r\n OldVolumeIndex: Integer;\r\n OldVolumePosition, OldPosition: Int64;\r\nbegin\r\n OldVolumeIndex := FVolumeIndex;\r\n OldVolumePosition := FVolumePosition;\r\n OldPosition := FPosition;\r\n\r\n Result := 0;\r\n try\r\n FVolumeIndex := -1;\r\n repeat\r\n if not InternalLoadVolume(FVolumeIndex + 1) then\r\n Break;\r\n Result := Result + FVolume.Size;\r\n until FVolume.Size = 0;\r\n finally\r\n InternalLoadVolume(OldVolumeIndex);\r\n FPosition := OldPosition;\r\n if Assigned(FVolume) then\r\n FVolumePosition := FVolume.Seek(OldVolumePosition, soBeginning);\r\n end;\r\nend;\r\n\r\nfunction TJclSplitStream.InternalLoadVolume(Index: Integer): Boolean;\r\nvar\r\n OldVolumeIndex: Integer;\r\n OldVolumeMaxSize: Int64;\r\n OldVolumePosition: Int64;\r\n OldVolume: TStream;\r\nbegin\r\n if Index = -1 then\r\n Index := 0;\r\n if Index <> FVolumeIndex then\r\n begin\r\n // save current pointers\r\n OldVolumeIndex := FVolumeIndex;\r\n OldVolumeMaxSize := FVolumeMaxSize;\r\n OldVolumePosition := FVolumePosition;\r\n OldVolume := FVolume;\r\n\r\n FVolumeIndex := Index;\r\n FVolumePosition := 0;\r\n FVolume := GetVolume(Index);\r\n FVolumeMaxSize := GetVolumeMaxSize(Index);\r\n Result := Assigned(FVolume);\r\n if Result then\r\n FVolume.Seek(0, soBeginning)\r\n else\r\n begin\r\n // restore old pointers if volume load failed\r\n FVolumeIndex := OldVolumeIndex;\r\n FVolumeMaxSize := OldVolumeMaxSize;\r\n FVolumePosition := OldVolumePosition;\r\n FVolume := OldVolume;\r\n end;\r\n end\r\n else\r\n Result := Assigned(FVolume);\r\nend;\r\n\r\nfunction TJclSplitStream.Read(var Buffer; Count: Longint): Longint;\r\nvar\r\n Data: PByte;\r\n Total, LoopRead: Longint;\r\nbegin\r\n Result := 0;\r\n\r\n if not InternalLoadVolume(FVolumeIndex) then\r\n Exit;\r\n\r\n Data := PByte(@Buffer);\r\n Total := Count;\r\n\r\n repeat\r\n // force position\r\n if ForcePosition then\r\n FVolume.Seek(FVolumePosition, soBeginning);\r\n\r\n // try to read (Count) bytes from current stream\r\n LoopRead := FVolume.Read(Data^, Count);\r\n FVolumePosition := FVolumePosition + LoopRead;\r\n FPosition := FPosition + LoopRead;\r\n Inc(Result, LoopRead);\r\n if Result = Total then\r\n Break;\r\n\r\n // with next volume\r\n Dec(Count, Result);\r\n Inc(Data, Result);\r\n if not InternalLoadVolume(FVolumeIndex + 1) then\r\n Break;\r\n until False;\r\nend;\r\n\r\nfunction TJclSplitStream.Seek(const Offset: Int64;\r\n Origin: TSeekOrigin): Int64;\r\nvar\r\n ExpectedPosition, RemainingOffset: Int64;\r\nbegin\r\n case TSeekOrigin(Origin) of\r\n soBeginning:\r\n ExpectedPosition := Offset;\r\n soCurrent:\r\n ExpectedPosition := FPosition + Offset;\r\n soEnd:\r\n ExpectedPosition := Size + Offset;\r\n else\r\n raise EJclStreamError.CreateRes(@RsStreamsSeekError);\r\n end;\r\n RemainingOffset := ExpectedPosition - FPosition;\r\n Result := FPosition;\r\n repeat\r\n if not InternalLoadVolume(FVolumeIndex) then\r\n Break;\r\n\r\n if RemainingOffset < 0 then\r\n begin\r\n // FPosition > ExpectedPosition, seek backward\r\n if FVolumePosition >= -RemainingOffset then\r\n begin\r\n // seek in current volume\r\n FVolumePosition := FVolume.Seek(FVolumePosition + RemainingOffset, soBeginning);\r\n Result := Result + RemainingOffset;\r\n FPosition := Result;\r\n RemainingOffset := 0;\r\n end\r\n else\r\n begin\r\n // seek to previous volume\r\n if FVolumeIndex = 0 then\r\n Exit;\r\n // seek to the beginning of current volume\r\n RemainingOffset := RemainingOffset + FVolumePosition;\r\n Result := Result - FVolumePosition;\r\n FPosition := Result;\r\n FVolumePosition := FVolume.Seek(0, soBeginning);\r\n // load previous volume\r\n if not InternalLoadVolume(FVolumeIndex - 1) then\r\n Break;\r\n Result := Result - FVolume.Size;\r\n FPosition := Result;\r\n RemainingOffset := RemainingOffset + FVolume.Size;\r\n end;\r\n end\r\n else if RemainingOffset > 0 then\r\n begin\r\n // FPosition < ExpectedPosition, seek forward\r\n if (FVolumeMaxSize = 0) or ((FVolumePosition + RemainingOffset) < FVolumeMaxSize) then\r\n begin\r\n // can seek in current volume\r\n FVolumePosition := FVolume.Seek(FVolumePosition + RemainingOffset, soBeginning);\r\n Result := Result + RemainingOffset;\r\n FPosition := Result;\r\n RemainingOffset := 0;\r\n end\r\n else\r\n begin\r\n // seek to next volume\r\n RemainingOffset := RemainingOffset - FVolumeMaxSize + FVolumePosition;\r\n Result := Result + FVolumeMaxSize - FVolumePosition;\r\n FPosition := Result;\r\n if not InternalLoadVolume(FVolumeIndex + 1) then\r\n Break;\r\n end;\r\n end;\r\n until RemainingOffset = 0;\r\nend;\r\n\r\nprocedure TJclSplitStream.SetSize(const NewSize: Int64);\r\nvar\r\n OldVolumeIndex: Integer;\r\n OldVolumePosition, OldPosition, RemainingSize, VolumeSize: Int64;\r\nbegin\r\n OldVolumeIndex := FVolumeIndex;\r\n OldVolumePosition := FVolumePosition;\r\n OldPosition := FPosition;\r\n\r\n RemainingSize := NewSize;\r\n try\r\n FVolumeIndex := 0;\r\n repeat\r\n if not InternalLoadVolume(FVolumeIndex) then\r\n Break;\r\n if (FVolumeMaxSize > 0) and (RemainingSize > FVolumeMaxSize) then\r\n VolumeSize := FVolumeMaxSize\r\n else\r\n VolumeSize := RemainingSize;\r\n FVolume.Size := VolumeSize;\r\n RemainingSize := RemainingSize - VolumeSize;\r\n\r\n Inc(FVolumeIndex);\r\n until RemainingSize = 0;\r\n finally\r\n InternalLoadVolume(OldVolumeIndex);\r\n FPosition := OldPosition;\r\n if Assigned(FVolume) then\r\n FVolumePosition := FVolume.Seek(OldVolumePosition, soBeginning);\r\n end;\r\nend;\r\n\r\nfunction TJclSplitStream.Write(const Buffer; Count: Longint): Longint;\r\nvar\r\n Data: PByte;\r\n Total, LoopWritten: Longint;\r\nbegin\r\n Result := 0;\r\n\r\n if not InternalLoadVolume(FVolumeIndex) then\r\n Exit;\r\n\r\n Data := PByte(@Buffer);\r\n Total := Count;\r\n\r\n repeat\r\n // force position\r\n if ForcePosition then\r\n FVolume.Seek(FVolumePosition, soBeginning);\r\n\r\n // do not write more than (VolumeMaxSize) bytes in current stream\r\n if (FVolumeMaxSize > 0) and ((Count + FVolumePosition) > FVolumeMaxSize) then\r\n LoopWritten := FVolumeMaxSize - FVolumePosition\r\n else\r\n LoopWritten := Count;\r\n // try to write (Count) bytes from current stream\r\n LoopWritten := FVolume.Write(Data^, LoopWritten);\r\n FVolumePosition := FVolumePosition + LoopWritten;\r\n FPosition := FPosition + LoopWritten;\r\n Inc(Result, LoopWritten);\r\n if Result = Total then\r\n Break;\r\n\r\n // with next volume\r\n Dec(Count, LoopWritten);\r\n Inc(Data, LoopWritten);\r\n if not InternalLoadVolume(FVolumeIndex + 1) then\r\n Break;\r\n until False;\r\nend;\r\n\r\n//=== { TJclDynamicSplitStream } =============================================\r\n\r\nfunction TJclDynamicSplitStream.GetVolume(Index: Integer): TStream;\r\nbegin\r\n if Assigned(FOnVolume) then\r\n Result := FOnVolume(Index)\r\n else\r\n Result := nil;\r\nend;\r\n\r\nfunction TJclDynamicSplitStream.GetVolumeMaxSize(Index: Integer): Int64;\r\nbegin\r\n if Assigned(FOnVolumeMaxSize) then\r\n Result := FOnVolumeMaxSize(Index)\r\n else\r\n Result := 0;\r\nend;\r\n\r\n//=== { TJclStaticSplitStream } ===========================================\r\n\r\nconstructor TJclStaticSplitStream.Create(AForcePosition: Boolean);\r\nbegin\r\n inherited Create(AForcePosition);\r\n FVolumes := TObjectList.Create(True);\r\nend;\r\n\r\ndestructor TJclStaticSplitStream.Destroy;\r\nvar\r\n Index: Integer;\r\n AVolumeRec: TJclSplitVolume;\r\nbegin\r\n if Assigned(FVolumes) then\r\n begin\r\n for Index := 0 to FVolumes.Count - 1 do\r\n begin\r\n AVolumeRec := TJclSplitVolume(FVolumes.Items[Index]);\r\n if AVolumeRec.OwnStream then\r\n AVolumeRec.Stream.Free;\r\n end;\r\n FVolumes.Free;\r\n end;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJclStaticSplitStream.AddVolume(AStream: TStream; AMaxSize: Int64;\r\n AOwnStream: Boolean): Integer;\r\nvar\r\n AVolumeRec: TJclSplitVolume;\r\nbegin\r\n AVolumeRec := TJclSplitVolume.Create;\r\n AVolumeRec.MaxSize := AMaxSize;\r\n AVolumeRec.Stream := AStream;\r\n AVolumeRec.OwnStream := AOwnStream;\r\n Result := FVolumes.Add(AVolumeRec);\r\nend;\r\n\r\nfunction TJclStaticSplitStream.GetVolume(Index: Integer): TStream;\r\nbegin\r\n Result := TJclSplitVolume(FVolumes.Items[Index]).Stream;\r\nend;\r\n\r\nfunction TJclStaticSplitStream.GetVolumeCount: Integer;\r\nbegin\r\n Result := FVolumes.Count;\r\nend;\r\n\r\nfunction TJclStaticSplitStream.GetVolumeMaxSize(Index: Integer): Int64;\r\nbegin\r\n Result := TJclSplitVolume(FVolumes.Items[Index]).MaxSize;\r\nend;\r\n\r\n//=== { TJclStringStream } ====================================================\r\n\r\nconstructor TJclStringStream.Create(AStream: TStream; AOwnsStream: Boolean);\r\nbegin\r\n inherited Create;\r\n FStream := AStream;\r\n FOwnStream := AOwnsStream;\r\n FBufferSize := StreamDefaultBufferSize;\r\nend;\r\n\r\ndestructor TJclStringStream.Destroy;\r\nbegin\r\n Flush;\r\n if FOwnStream then\r\n FStream.Free;\r\n inherited;\r\nend;\r\n\r\nprocedure TJclStringStream.Flush;\r\nbegin\r\n if FStrBufferModifiedSize > 0 then\r\n begin\r\n FStream.Position := FStrBufferStart;\r\n InternalSetNextBuffer(FStream, FStrBuffer, 0, FStrBufferModifiedSize);\r\n FStrBufferNext := FStream.Seek(0, soCurrent);\r\n FStrBufferModifiedSize := 0;\r\n end;\r\nend;\r\n\r\nfunction TJclStringStream.InternalGetNextBuffer(S: TStream;\r\n var Buffer: TUCS4Array; Start, Count: SizeInt): Longint;\r\nvar\r\n Ch: UCS4;\r\nbegin\r\n // override to optimize\r\n Result := 0;\r\n while Count > 0 do\r\n begin\r\n if InternalGetNextChar(S, Ch) then\r\n begin\r\n Buffer[Start] := Ch;\r\n Inc(Start);\r\n Inc(Result);\r\n end\r\n else\r\n Break;\r\n Dec(Count);\r\n end;\r\nend;\r\n\r\nfunction TJclStringStream.InternalSetNextBuffer(S: TStream;\r\n const Buffer: TUCS4Array; Start, Count: SizeInt): Longint;\r\nbegin\r\n // override to optimize\r\n Result := 0;\r\n while Count > 0 do\r\n begin\r\n if InternalSetNextChar(S, Buffer[Start]) then\r\n begin\r\n Inc(Start);\r\n Inc(Result);\r\n end\r\n else\r\n Break;\r\n Dec(Count);\r\n end;\r\nend;\r\n\r\nprocedure TJclStringStream.InvalidateBuffers;\r\nbegin\r\n FStrBufferStart := FStream.Seek(0, soCurrent);\r\n FStrBufferNext := FStrBufferStart;\r\n FStrBufferPosition := 0;\r\n FStrBufferCurrentSize := 0;\r\n FStrBufferModifiedSize := 0;\r\n FStrPeekBufferStart := FStrBufferStart;\r\n FStrPeekBufferNext := FStrBufferNext;\r\n FStrPeekPosition := 0;\r\n FStrPeekBufferCurrentSize := 0;\r\nend;\r\n\r\nfunction TJclStringStream.LoadBuffer: Boolean;\r\nbegin\r\n Flush;\r\n // first test if the peek buffer contains the value\r\n if (FStrBufferNext >= FStrPeekBufferStart) and (FStrBufferNext < FStrPeekBufferNext) then\r\n begin\r\n // the requested buffer is already loaded in the peek buffer\r\n FStrBufferStart := FStrPeekBufferStart;\r\n FStrBufferNext := FStrPeekBufferNext;\r\n if Length(FStrBuffer) <> Length(FStrPeekBuffer) then\r\n SetLength(FStrBuffer, Length(FStrPeekBuffer));\r\n FStrBufferPosition := FStrPeekBufferPosition;\r\n FStrBufferCurrentSize := FStrPeekBufferCurrentSize;\r\n Move(FStrPeekBuffer[0], FStrBuffer[0], FStrBufferCurrentSize * SizeOf(FStrBuffer[0]));\r\n end\r\n else\r\n begin\r\n // load a new buffer\r\n if Length(FStrBuffer) <> FBufferSize then\r\n SetLength(FStrBuffer, FBufferSize);\r\n Inc(FStrBufferPosition, FStrBufferCurrentSize);\r\n FStrBufferStart := FStrBufferNext;\r\n FStream.Seek(FStrBufferStart, soBeginning);\r\n FStrBufferCurrentSize := InternalGetNextBuffer(FStream, FStrBuffer, 0, FBufferSize);\r\n FStrBufferNext := FStream.Seek(0, soCurrent);\r\n // reset the peek buffer\r\n FStrPeekBufferPosition := FStrBufferPosition + FStrBufferCurrentSize;\r\n FStrPeekBufferCurrentSize := 0;\r\n FStrPeekBufferNext := FStrBufferNext;\r\n FStrPeekBufferStart := FStrBufferNext;\r\n end;\r\n Result := (FStrPosition >= FStrBufferPosition) and (FStrPosition < (FStrBufferPosition + FStrBufferCurrentSize));\r\nend;\r\n\r\nfunction TJclStringStream.LoadPeekBuffer: Boolean;\r\nbegin\r\n if Length(FStrPeekBuffer) <> FBufferSize then\r\n SetLength(FStrPeekBuffer, FBufferSize);\r\n if FStrPeekBufferPosition > FStrPeekPosition then\r\n begin\r\n // the peek position is rolling back, load the buffer after the read buffer\r\n FStrPeekBufferPosition := FStrBufferPosition;\r\n FStrPeekBufferCurrentSize := FStrBufferCurrentSize;\r\n FStrPeekBufferStart := FStrBufferStart;\r\n FStrPeekBufferNext := FStrBufferNext;\r\n end;\r\n FStrPeekBufferStart := FStrPeekBufferNext;\r\n Inc(FStrPeekBufferPosition, FStrPeekBufferCurrentSize);\r\n FStream.Seek(FStrPeekBufferStart, soBeginning);\r\n FStrPeekBufferCurrentSize := InternalGetNextBuffer(FStream, FStrPeekBuffer, 0, FBufferSize);\r\n FStrPeekBufferNext := FStream.Seek(0, soCurrent);\r\n Result := (FStrPeekPosition >= FStrPeekBufferPosition) and (FStrPeekPosition < (FStrPeekBufferPosition + FStrPeekBufferCurrentSize));\r\nend;\r\n\r\nfunction TJclStringStream.PeekAnsiChar(out Buffer: AnsiChar): Boolean;\r\nvar\r\n Ch: UCS4;\r\nbegin\r\n Result := PeekUCS4(Ch);\r\n if Result then\r\n Buffer := UCS4ToAnsiChar(Ch);\r\nend;\r\n\r\nfunction TJclStringStream.PeekChar(out Buffer: Char): Boolean;\r\nvar\r\n Ch: UCS4;\r\nbegin\r\n Result := PeekUCS4(Ch);\r\n if Result then\r\n Buffer := UCS4ToChar(Ch);\r\nend;\r\n\r\nfunction TJclStringStream.PeekUCS4(out Buffer: UCS4): Boolean;\r\nbegin\r\n if (FStrPeekPosition >= FStrPeekBufferPosition) and (FStrPeekPosition < (FStrPeekBufferPosition + FStrPeekBufferCurrentSize)) then\r\n begin\r\n // read from the peek buffer\r\n Result := True;\r\n Buffer := FStrPeekBuffer[FStrPeekPosition - FStrPeekBufferPosition];\r\n Inc(FStrPeekPosition);\r\n end\r\n else\r\n if (FStrPeekPosition >= FStrBufferPosition) and (FStrPeekPosition < (FStrBufferPosition + FStrBufferCurrentSize)) then\r\n begin\r\n // read from the read/write buffer\r\n Result := True;\r\n Buffer := FStrBuffer[FStrPeekPosition - FStrBufferPosition];\r\n Inc(FStrPeekPosition);\r\n end\r\n else\r\n begin\r\n // load a new peek buffer\r\n Result := LoadPeekBuffer;\r\n if Result then\r\n begin\r\n Buffer := FStrPeekBuffer[FStrPeekPosition - FStrPeekBufferPosition];\r\n Inc(FStrPeekPosition);\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJclStringStream.PeekWideChar(out Buffer: WideChar): Boolean;\r\nvar\r\n Ch: UCS4;\r\nbegin\r\n Result := PeekUCS4(Ch);\r\n if Result then\r\n Buffer := UCS4ToWideChar(Ch);\r\nend;\r\n\r\nfunction TJclStringStream.ReadString(var Buffer: string; Start, Count: Longint): Longint;\r\nvar\r\n Index: Integer;\r\n StrPos: SizeInt;\r\n Ch: UCS4;\r\nbegin\r\n Index := Start;\r\n while Index < Start + Count - 1 do // avoid overflow on surrogate pairs for WideString\r\n begin\r\n if ReadUCS4(Ch) then\r\n begin\r\n StrPos := Index;\r\n if StringSetNextChar(Buffer, StrPos, Ch) and (StrPos > 0) then\r\n Index := StrPos\r\n else\r\n Break; // end of string (write)\r\n end\r\n else\r\n Break; // end of stream (read)\r\n end;\r\n Result := Index - Start;\r\nend;\r\n\r\nfunction TJclStringStream.ReadString(BufferSize: Longint): string;\r\nvar\r\n Buffer: string;\r\n ProcessedLength: Longint;\r\nbegin\r\n Result := '';\r\n SetLength(Buffer, BufferSize);\r\n repeat\r\n ProcessedLength := ReadString(Buffer, 1, BufferSize);\r\n if ProcessedLength > 0 then\r\n Result := Result + Copy(Buffer, 1, ProcessedLength);\r\n until ProcessedLength = 0;\r\nend;\r\n\r\nfunction TJclStringStream.ReadAnsiChar(out Buffer: AnsiChar): Boolean;\r\nvar\r\n Ch: UCS4;\r\nbegin\r\n Result := ReadUCS4(Ch);\r\n if Result then\r\n Buffer := UCS4ToAnsiChar(Ch);\r\nend;\r\n\r\nfunction TJclStringStream.ReadAnsiString(var Buffer: AnsiString; Start, Count: Longint): Longint;\r\nvar\r\n Index: Integer;\r\n StrPos: SizeInt;\r\n Ch: UCS4;\r\nbegin\r\n Index := Start;\r\n while Index < Start + Count do\r\n begin\r\n if ReadUCS4(Ch) then\r\n begin\r\n StrPos := Index;\r\n if AnsiSetNextChar(Buffer, StrPos, Ch) and (StrPos > 0) then\r\n Index := StrPos\r\n else\r\n Break; // end of string (write)\r\n end\r\n else\r\n Break; // end of stream (read)\r\n end;\r\n Result := Index - Start;\r\nend;\r\n\r\nfunction TJclStringStream.ReadAnsiString(BufferSize: Longint): AnsiString;\r\nvar\r\n Buffer: AnsiString;\r\n ProcessedLength: Longint;\r\nbegin\r\n Result := '';\r\n SetLength(Buffer, BufferSize);\r\n repeat\r\n ProcessedLength := ReadAnsiString(Buffer, 1, BufferSize);\r\n if ProcessedLength > 0 then\r\n Result := Result + Copy(Buffer, 1, ProcessedLength);\r\n until ProcessedLength = 0;\r\nend;\r\n\r\nfunction TJclStringStream.ReadChar(out Buffer: Char): Boolean;\r\nvar\r\n Ch: UCS4;\r\nbegin\r\n Result := ReadUCS4(Ch);\r\n if Result then\r\n Buffer := UCS4ToChar(Ch);\r\nend;\r\n\r\nfunction TJclStringStream.ReadUCS4(out Buffer: UCS4): Boolean;\r\nbegin\r\n if (FStrPosition >= FStrBufferPosition) and (FStrPosition < (FStrBufferPosition + FStrBufferCurrentSize)) then\r\n begin\r\n // load from buffer\r\n Result := True;\r\n Buffer := FStrBuffer[FStrPosition - FStrBufferPosition];\r\n Inc(FStrPosition);\r\n end\r\n else\r\n begin\r\n // load a new buffer\r\n Result := LoadBuffer;\r\n if Result then\r\n begin\r\n Buffer := FStrBuffer[FStrPosition - FStrBufferPosition];\r\n Inc(FStrPosition);\r\n end;\r\n end;\r\n FStrPeekPosition := FStrPosition;\r\nend;\r\n\r\nfunction TJclStringStream.ReadWideChar(out Buffer: WideChar): Boolean;\r\nvar\r\n Ch: UCS4;\r\nbegin\r\n Result := ReadUCS4(Ch);\r\n if Result then\r\n Buffer := UCS4ToWideChar(Ch);\r\nend;\r\n\r\nfunction TJclStringStream.ReadWideString(var Buffer: WideString; Start, Count: Longint): Longint;\r\nvar\r\n Index: Integer;\r\n StrPos: SizeInt;\r\n Ch: UCS4;\r\nbegin\r\n Index := Start;\r\n while Index < Start + Count - 1 do // avoid overflow on surrogate pairs\r\n begin\r\n if ReadUCS4(Ch) then\r\n begin\r\n StrPos := Index;\r\n if UTF16SetNextChar(Buffer, StrPos, Ch) and (StrPos > 0) then\r\n Index := StrPos\r\n else\r\n Break; // end of string (write)\r\n end\r\n else\r\n Break; // end of stream (read)\r\n end;\r\n Result := Index - Start;\r\nend;\r\n\r\nfunction TJclStringStream.ReadWideString(BufferSize: Longint): WideString;\r\nvar\r\n Buffer: WideString;\r\n ProcessedLength: Longint;\r\nbegin\r\n Result := '';\r\n SetLength(Buffer, BufferSize);\r\n repeat\r\n ProcessedLength := ReadWideString(Buffer, 1, BufferSize);\r\n if ProcessedLength > 0 then\r\n Result := Result + Copy(Buffer, 1, ProcessedLength);\r\n until ProcessedLength = 0;\r\nend;\r\n\r\nfunction TJclStringStream.Seek(const Offset: Int64; Origin: TSeekOrigin): Int64;\r\nbegin\r\n case Origin of\r\n soBeginning:\r\n if Offset = 0 then\r\n begin\r\n Flush;\r\n FStrPosition := 0;\r\n FStrBufferPosition := 0;\r\n FStrBufferCurrentSize := 0;\r\n FStrBufferStart := 0;\r\n FStrBufferNext := 0;\r\n FStrPeekBufferPosition := 0;\r\n FStrPeekBufferCurrentSize := 0;\r\n FStrPeekBufferStart := 0;\r\n FStrPeekBufferNext := 0;\r\n end\r\n else\r\n raise EJclStreamError.CreateRes(@RsStreamsSeekError);\r\n soCurrent:\r\n if Offset <> 0 then\r\n raise EJclStreamError.CreateRes(@RsStreamsSeekError);\r\n soEnd:\r\n raise EJclStreamError.CreateRes(@RsStreamsSeekError);\r\n end;\r\n Result := FStrPosition;\r\n FStrPeekPosition := FStrPosition;\r\nend;\r\n\r\nfunction TJclStringStream.SkipBOM: Longint;\r\nvar\r\n Pos: Int64;\r\n I: Integer;\r\n BOM: array of Byte;\r\nbegin\r\n if Length(FBOM) > 0 then\r\n begin\r\n Pos := FStream.Seek(0, soCurrent);\r\n SetLength(BOM, Length(FBOM));\r\n Result := FStream.Read(BOM[0], Length(BOM) * SizeOf(BOM[0]));\r\n if Result = Length(FBOM) * SizeOf(FBOM[0]) then\r\n for I := Low(FBOM) to High(FBOM) do\r\n if BOM[I - Low(FBOM)] <> FBOM[I] then\r\n Result := 0;\r\n if Result <> Length(FBOM) * SizeOf(FBOM[0]) then\r\n FStream.Seek(Pos, soBeginning);\r\n end\r\n else\r\n Result := 0;\r\n InvalidateBuffers;\r\nend;\r\n\r\nfunction TJclStringStream.WriteBOM: Longint;\r\nbegin\r\n if Length(FBOM) > 0 then\r\n Result := FStream.Write(FBOM[0], Length(FBOM) * SizeOf(FBOM[0]))\r\n else\r\n Result := 0;\r\n InvalidateBuffers;\r\nend;\r\n\r\nfunction TJclStringStream.WriteChar(Value: Char): Boolean;\r\nbegin\r\n Result := WriteUCS4(CharToUCS4(Value));\r\nend;\r\n\r\nfunction TJclStringStream.WriteString(const Buffer: string; Start, Count: Longint): Longint;\r\nvar\r\n Index: Integer;\r\n StrPos: SizeInt;\r\n Ch: UCS4;\r\nbegin\r\n Index := Start;\r\n while Index < Start + Count do\r\n begin\r\n StrPos := Index;\r\n Ch := StringGetNextChar(Buffer, StrPos);\r\n if (StrPos > 0) and WriteUCS4(Ch) then\r\n Index := StrPos\r\n else\r\n Break; // end of string (read) or end of stream (write)\r\n end;\r\n Result := Index - Start;\r\nend;\r\n\r\nfunction TJclStringStream.WriteAnsiChar(Value: AnsiChar): Boolean;\r\nbegin\r\n Result := WriteUCS4(AnsiCharToUCS4(Value));\r\nend;\r\n\r\nfunction TJclStringStream.WriteAnsiString(const Buffer: AnsiString; Start, Count: Longint): Longint;\r\nvar\r\n Index: Integer;\r\n StrPos: SizeInt;\r\n Ch: UCS4;\r\nbegin\r\n Index := Start;\r\n while Index < Start + Count do\r\n begin\r\n StrPos := Index;\r\n Ch := AnsiGetNextChar(Buffer, StrPos);\r\n if (StrPos > 0) and WriteUCS4(Ch) then\r\n Index := StrPos\r\n else\r\n Break; // end of string (read) or end of stream (write)\r\n end;\r\n Result := Index - Start;\r\nend;\r\n\r\nfunction TJclStringStream.WriteUCS4(Value: UCS4): Boolean;\r\nvar\r\n BufferPos: Int64;\r\nbegin\r\n if FStrPosition >= (FStrBufferPosition + FBufferSize) then\r\n // load the next buffer first\r\n LoadBuffer;\r\n // write to current buffer\r\n BufferPos := FStrPosition - FStrBufferPosition;\r\n Result := True;\r\n if Length(FStrBuffer) <> FBufferSize then\r\n SetLength(FStrBuffer, FBufferSize);\r\n FStrBuffer[BufferPos] := Value;\r\n Inc(FStrPosition);\r\n Inc(BufferPos);\r\n if FStrBufferModifiedSize < BufferPos then\r\n FStrBufferModifiedSize := BufferPos;\r\n if FStrBufferCurrentSize < BufferPos then\r\n FStrBufferCurrentSize := BufferPos;\r\n FStrPeekPosition := FStrPosition;\r\nend;\r\n\r\nfunction TJclStringStream.WriteWideChar(Value: WideChar): Boolean;\r\nbegin\r\n Result := WriteUCS4(WideCharToUCS4(Value));\r\nend;\r\n\r\nfunction TJclStringStream.WriteWideString(const Buffer: WideString; Start, Count: Longint): Longint;\r\nvar\r\n Index: Integer;\r\n StrPos: SizeInt;\r\n Ch: UCS4;\r\nbegin\r\n Index := Start;\r\n while Index < Start + Count do\r\n begin\r\n StrPos := Index;\r\n Ch := UTF16GetNextChar(Buffer, StrPos);\r\n if (StrPos > 0) and WriteUCS4(Ch) then\r\n Index := StrPos\r\n else\r\n Break; // end of string (read) or end of stream (write)\r\n end;\r\n Result := Index - Start;\r\nend;\r\n\r\n//=== { TJclAnsiStream } ======================================================\r\n\r\nconstructor TJclAnsiStream.Create(AStream: TStream; AOwnsStream: Boolean);\r\nbegin\r\n inherited Create(AStream, AOwnsStream);\r\n SetLength(FBOM, 0);\r\n FCodePage := CP_ACP;\r\nend;\r\n\r\nfunction TJclAnsiStream.InternalGetNextBuffer(S: TStream;\r\n var Buffer: TUCS4Array; Start, Count: SizeInt): Longint;\r\nbegin\r\n if FCodePage = CP_ACP then\r\n Result := AnsiGetNextBufferFromStream(S, Buffer, Start, Count)\r\n else\r\n Result := AnsiGetNextBufferFromStream(S, FCodePage, Buffer, Start, Count);\r\nend;\r\n\r\nfunction TJclAnsiStream.InternalGetNextChar(S: TStream; out Ch: UCS4): Boolean;\r\nbegin\r\n if FCodePage = CP_ACP then\r\n Result := AnsiGetNextCharFromStream(S, Ch)\r\n else\r\n Result := AnsiGetNextCharFromStream(S, FCodePage, Ch);\r\nend;\r\n\r\nfunction TJclAnsiStream.InternalSetNextBuffer(S: TStream;\r\n const Buffer: TUCS4Array; Start, Count: SizeInt): Longint;\r\nbegin\r\n if FCodePage = CP_ACP then\r\n Result := AnsiSetNextBufferToStream(S, Buffer, Start, Count)\r\n else\r\n Result := AnsiSetNextBufferToStream(S, FCodePage, Buffer, Start, Count);\r\nend;\r\n\r\nfunction TJclAnsiStream.InternalSetNextChar(S: TStream; Ch: UCS4): Boolean;\r\nbegin\r\n if FCodePage = CP_ACP then\r\n Result := AnsiSetNextCharToStream(S, Ch)\r\n else\r\n Result := AnsiSetNextCharToStream(S, FCodePage, Ch);\r\nend;\r\n\r\n//=== { TJclUTF8Stream } ======================================================\r\n\r\nconstructor TJclUTF8Stream.Create(AStream: TStream; AOwnsStream: Boolean);\r\nvar\r\n I: Integer;\r\nbegin\r\n inherited Create(AStream, AOwnsStream);\r\n SetLength(FBOM, Length(BOM_UTF8));\r\n for I := Low(BOM_UTF8) to High(BOM_UTF8) do\r\n FBOM[I - Low(BOM_UTF8)] := BOM_UTF8[I];\r\nend;\r\n\r\nfunction TJclUTF8Stream.InternalGetNextBuffer(S: TStream;\r\n var Buffer: TUCS4Array; Start, Count: SizeInt): Longint;\r\nbegin\r\n Result := UTF8GetNextBufferFromStream(S, Buffer, Start, Count);\r\nend;\r\n\r\nfunction TJclUTF8Stream.InternalGetNextChar(S: TStream; out Ch: UCS4): Boolean;\r\nbegin\r\n Result := UTF8GetNextCharFromStream(S, Ch);\r\nend;\r\n\r\nfunction TJclUTF8Stream.InternalSetNextBuffer(S: TStream;\r\n const Buffer: TUCS4Array; Start, Count: SizeInt): Longint;\r\nbegin\r\n Result := UTF8SetNextBufferToStream(S, Buffer, Start, Count);\r\nend;\r\n\r\nfunction TJclUTF8Stream.InternalSetNextChar(S: TStream; Ch: UCS4): Boolean;\r\nbegin\r\n Result := UTF8SetNextCharToStream(S, Ch);\r\nend;\r\n\r\n//=== { TJclUTF16Stream } =====================================================\r\n\r\nconstructor TJclUTF16Stream.Create(AStream: TStream; AOwnsStream: Boolean);\r\nvar\r\n I: Integer;\r\nbegin\r\n inherited Create(AStream, AOwnsStream);\r\n SetLength(FBOM, Length(BOM_UTF16_LSB));\r\n for I := Low(BOM_UTF16_LSB) to High(BOM_UTF16_LSB) do\r\n FBOM[I - Low(BOM_UTF16_LSB)] := BOM_UTF16_LSB[I];\r\nend;\r\n\r\nfunction TJclUTF16Stream.InternalGetNextBuffer(S: TStream;\r\n var Buffer: TUCS4Array; Start, Count: SizeInt): Longint;\r\nbegin\r\n Result := UTF16GetNextBufferFromStream(S, Buffer, Start, Count);\r\nend;\r\n\r\nfunction TJclUTF16Stream.InternalGetNextChar(S: TStream; out Ch: UCS4): Boolean;\r\nbegin\r\n Result := UTF16GetNextCharFromStream(S, Ch);\r\nend;\r\n\r\nfunction TJclUTF16Stream.InternalSetNextBuffer(S: TStream;\r\n const Buffer: TUCS4Array; Start, Count: SizeInt): Longint;\r\nbegin\r\n Result := UTF16SetNextBufferToStream(S, Buffer, Start, Count);\r\nend;\r\n\r\nfunction TJclUTF16Stream.InternalSetNextChar(S: TStream; Ch: UCS4): Boolean;\r\nbegin\r\n Result := UTF16SetNextCharToStream(S, Ch);\r\nend;\r\n\r\n//=== { TJclAutoStream } ======================================================\r\n\r\nconstructor TJclAutoStream.Create(AStream: TStream; AOwnsStream: Boolean);\r\nvar\r\n I, MaxLength, ReadLength: Integer;\r\n BOM: array of Byte;\r\nbegin\r\n inherited Create(AStream, AOwnsStream);\r\n MaxLength := Length(BOM_UTF8);\r\n if MaxLength < Length(BOM_UTF16_LSB) then\r\n MaxLength := Length(BOM_UTF16_LSB);\r\n\r\n SetLength(BOM, MaxLength);\r\n ReadLength := FStream.Read(BOM[0], Length(BOM) * SizeOf(BOM[0])) div SizeOf(BOM[0]);\r\n\r\n FEncoding := seAuto;\r\n\r\n // try UTF8 BOM\r\n if (FEncoding = seAuto) and (ReadLength >= Length(BOM_UTF8) * SizeOf(BOM_UTF8[0])) then\r\n begin\r\n FCodePage := CP_UTF8;\r\n FEncoding := seUTF8;\r\n for I := Low(BOM_UTF8) to High(BOM_UTF8) do\r\n if BOM[I - Low(BOM_UTF8)] <> BOM_UTF8[I] then\r\n begin\r\n FEncoding := seAuto;\r\n Break;\r\n end;\r\n end;\r\n\r\n // try UTF16 BOM\r\n if (FEncoding = seAuto) and (ReadLength >= Length(BOM_UTF16_LSB) * SizeOf(BOM_UTF16_LSB[0])) then\r\n begin\r\n FCodePage := CP_UTF16LE;\r\n FEncoding := seUTF16;\r\n for I := Low(BOM_UTF16_LSB) to High(BOM_UTF16_LSB) do\r\n if BOM[I - Low(BOM_UTF8)] <> BOM_UTF16_LSB[I] then\r\n begin\r\n FEncoding := seAuto;\r\n Break;\r\n end;\r\n end;\r\n\r\n case FEncoding of\r\n seUTF8:\r\n begin\r\n FCodePage := CP_UTF8;\r\n SetLength(FBOM, Length(BOM_UTF8));\r\n for I := Low(BOM_UTF8) to High(BOM_UTF8) do\r\n FBOM[I - Low(BOM_UTF8)] := BOM_UTF8[I];\r\n end;\r\n seUTF16:\r\n begin\r\n FCodePage := CP_UTF16LE;\r\n SetLength(FBOM, Length(BOM_UTF16_LSB));\r\n for I := Low(BOM_UTF16_LSB) to High(BOM_UTF16_LSB) do\r\n FBOM[I - Low(BOM_UTF16_LSB)] := BOM_UTF16_LSB[I];\r\n end;\r\n seAuto,\r\n seAnsi:\r\n begin\r\n // defaults to Ansi\r\n FCodePage := CP_ACP;\r\n FEncoding := seAnsi;\r\n SetLength(FBOM, 0);\r\n end;\r\n end;\r\n FStream.Seek(Length(FBOM) - ReadLength, soCurrent);\r\n InvalidateBuffers;\r\nend;\r\n\r\nfunction TJclAutoStream.InternalGetNextBuffer(S: TStream;\r\n var Buffer: TUCS4Array; Start, Count: SizeInt): Longint;\r\nbegin\r\n case FCodePage of\r\n CP_UTF8:\r\n Result := UTF8GetNextBufferFromStream(S, Buffer, Start, Count);\r\n CP_UTF16LE:\r\n Result := UTF16GetNextBufferFromStream(S, Buffer, Start, Count);\r\n CP_ACP:\r\n Result := AnsiGetNextBufferFromStream(S, Buffer, Start, Count);\r\n else\r\n Result := AnsiGetNextBufferFromStream(S, CodePage, Buffer, Start, Count);\r\n end;\r\nend;\r\n\r\nfunction TJclAutoStream.InternalGetNextChar(S: TStream; out Ch: UCS4): Boolean;\r\nbegin\r\n case FCodePage of\r\n CP_UTF8:\r\n Result := UTF8GetNextCharFromStream(S, Ch);\r\n CP_UTF16LE:\r\n Result := UTF16GetNextCharFromStream(S, Ch);\r\n CP_ACP:\r\n Result := AnsiGetNextCharFromStream(S, Ch);\r\n else\r\n Result := AnsiGetNextCharFromStream(S, CodePage, Ch);\r\n end;\r\nend;\r\n\r\nfunction TJclAutoStream.InternalSetNextBuffer(S: TStream;\r\n const Buffer: TUCS4Array; Start, Count: SizeInt): Longint;\r\nbegin\r\n case FCodePage of\r\n CP_UTF8:\r\n Result := UTF8SetNextBufferToStream(S, Buffer, Start, Count);\r\n CP_UTF16LE:\r\n Result := UTF16SetNextBufferToStream(S, Buffer, Start, Count);\r\n CP_ACP:\r\n Result := AnsiSetNextBufferToStream(S, Buffer, Start, Count);\r\n else\r\n Result := AnsiSetNextBufferToStream(S, CodePage, Buffer, Start, Count);\r\n end;\r\nend;\r\n\r\nfunction TJclAutoStream.InternalSetNextChar(S: TStream; Ch: UCS4): Boolean;\r\nbegin\r\n case FCodePage of\r\n CP_UTF8:\r\n Result := UTF8SetNextCharToStream(S, Ch);\r\n CP_UTF16LE:\r\n Result := UTF16SetNextCharToStream(S, Ch);\r\n CP_ACP:\r\n Result := AnsiSetNextCharToStream(S, Ch);\r\n else\r\n Result := AnsiSetNextCharToStream(S, CodePage, Ch);\r\n end;\r\nend;\r\n\r\nprocedure TJclAutoStream.SetCodePage(Value: Word);\r\nbegin\r\n if Value = CP_UTF8 then\r\n FEncoding := seUTF8\r\n else\r\n if Value = CP_UTF16LE then\r\n FEncoding := seUTF16\r\n else\r\n if Value = CP_ACP then\r\n FEncoding := seAnsi\r\n else\r\n FEncoding := seAuto;\r\n FCodePage := Value;\r\nend;\r\n\r\nfunction TJclAutoStream.SkipBOM: LongInt;\r\nbegin\r\n // already skipped to determine encoding\r\n Result := 0;\r\n InvalidateBuffers;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jcl/source/common/JclStringConversions.pas", "content": "{**************************************************************************************************}\r\n{ }\r\n{ Project JEDI Code Library (JCL) }\r\n{ }\r\n{ The contents of this file are subject to the Mozilla Public License Version 1.1 (the \"License\"); }\r\n{ you may not use this file except in compliance with the License. You may obtain a copy of the }\r\n{ License at http://www.mozilla.org/MPL/ }\r\n{ }\r\n{ Software distributed under the License is distributed on an \"AS IS\" basis, WITHOUT WARRANTY OF }\r\n{ ANY KIND, either express or implied. See the License for the specific language governing rights }\r\n{ and limitations under the License. }\r\n{ }\r\n{ The Original Code is JclUnicode.pas. }\r\n{ }\r\n{ The Initial Developer of the Original Code is Mike Lischke (public att lischke-online dott de). }\r\n{ Portions created by Mike Lischke are Copyright (C) 1999-2000 Mike Lischke. All Rights Reserved. }\r\n{ }\r\n{ Contributor(s): }\r\n{ Marcel van Brakel }\r\n{ Andreas Hausladen (ahuser) }\r\n{ Mike Lischke }\r\n{ Flier Lu (flier) }\r\n{ Robert Marquardt (marquardt) }\r\n{ Robert Rossmair (rrossmair) }\r\n{ Olivier Sannier (obones) }\r\n{ Matthias Thoma (mthoma) }\r\n{ Petr Vones (pvones) }\r\n{ Peter Schraut (http://www.console-dev.de) }\r\n{ Florent Ouchet (outchy) }\r\n{ }\r\n{**************************************************************************************************}\r\n{ }\r\n{ String conversion routines }\r\n{ }\r\n{**************************************************************************************************}\r\n{ }\r\n{ Last modified: $Date:: 2012-05-16 21:09:59 +0200 (mer. 16 mai 2012) $ }\r\n{ Revision: $Rev:: 3795 $ }\r\n{ Author: $Author:: ahuser $ }\r\n{ }\r\n{**************************************************************************************************}\r\n\r\nunit JclStringConversions;\r\n\r\n{$I jcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF HAS_UNITSCOPE}\r\n System.Classes,\r\n {$ELSE ~HAS_UNITSCOPE}\r\n Classes,\r\n {$ENDIF ~HAS_UNITSCOPE}\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n JclBase;\r\n\r\ntype\r\n EJclStringConversionError = class(EJclError);\r\n EJclUnexpectedEOSequenceError = class (EJclStringConversionError)\r\n public\r\n constructor Create;\r\n end;\r\n\r\n// conversion routines between Ansi, UTF-16, UCS-4 and UTF8 strings\r\n\r\n// one shot conversion between PAnsiChar and PWideChar\r\nprocedure ExpandASCIIString(const Source: PAnsiChar; Target: PWideChar; Count: SizeInt);\r\n\r\n// tpye of stream related functions\r\ntype\r\n TJclStreamGetNextCharFunc = function(S: TStream; out Ch: UCS4): Boolean;\r\n TJclStreamSkipCharsFunc = function(S: TStream; var NbSeq: SizeInt): Boolean;\r\n TJclStreamSetNextCharFunc = function(S: TStream; Ch: UCS4): Boolean;\r\n\r\n// iterative conversions\r\n\r\n// UTF8GetNextChar = read next UTF8 sequence at StrPos\r\n// if UNICODE_SILENT_FAILURE is defined, invalid sequences will be replaced by ReplacementCharacter\r\n// otherwise StrPos is set to -1 on return to flag an error (invalid UTF8 sequence)\r\n// StrPos will be incremented by the number of chars that were read\r\nfunction UTF8GetNextChar(const S: TUTF8String; var StrPos: SizeInt): UCS4;\r\nfunction UTF8GetNextBuffer(const S: TUTF8String; var StrPos: SizeInt; var Buffer: TUCS4Array; var Start: SizeInt; Count: SizeInt): SizeInt;\r\nfunction UTF8GetNextCharFromStream(S: TStream; out Ch: UCS4): Boolean;\r\nfunction UTF8GetNextBufferFromStream(S: TStream; var Buffer: TUCS4Array; var Start: SizeInt; Count: SizeInt): SizeInt;\r\n\r\n// UTF8SkipChars = skip NbSeq UTF8 sequences starting from StrPos\r\n// returns False if String is too small\r\n// if UNICODE_SILENT_FAILURE is not defined StrPos is set to -1 on error (invalid UTF8 sequence)\r\n// StrPos will be incremented by the number of chars that were skipped\r\n// On return, NbSeq contains the number of UTF8 sequences that were skipped\r\nfunction UTF8SkipChars(const S: TUTF8String; var StrPos: SizeInt; var NbSeq: SizeInt): Boolean;\r\nfunction UTF8SkipCharsFromStream(S: TStream; var NbSeq: SizeInt): Boolean;\r\n\r\n// UTF8SetNextChar = append an UTF8 sequence at StrPos\r\n// returns False on error:\r\n// - if an UCS4 character cannot be stored to an UTF-8 string:\r\n// - if UNICODE_SILENT_FAILURE is defined, ReplacementCharacter is added\r\n// - if UNICODE_SILENT_FAILURE is not defined, StrPos is set to -1\r\n// - StrPos > -1 flags string being too small, callee did nothing, caller is responsible for allocating space\r\n// StrPos will be incremented by the number of chars that were written\r\nfunction UTF8SetNextChar(var S: TUTF8String; var StrPos: SizeInt; Ch: UCS4): Boolean;\r\nfunction UTF8SetNextBuffer(var S: TUTF8String; var StrPos: SizeInt; const Buffer: TUCS4Array; var Start: SizeInt; Count: SizeInt): SizeInt;\r\nfunction UTF8SetNextCharToStream(S: TStream; Ch: UCS4): Boolean;\r\nfunction UTF8SetNextBufferToStream(S: TStream; const Buffer: TUCS4Array; var Start: SizeInt; Count: SizeInt): SizeInt;\r\n\r\n// UTF16GetNextChar = read next UTF16 sequence at StrPos\r\n// if UNICODE_SILENT_FAILURE is defined, invalid sequences will be replaced by ReplacementCharacter\r\n// otherwise StrPos is set to -1 on return to flag an error (invalid UTF16 sequence)\r\n// StrPos will be incremented by the number of chars that were read\r\nfunction UTF16GetNextChar(const S: TUTF16String; var StrPos: SizeInt): UCS4; overload;\r\nfunction UTF16GetNextBuffer(const S: TUTF16String; var StrPos: SizeInt; var Buffer: TUCS4Array; var Start: SizeInt; Count: SizeInt): SizeInt; overload;\r\n{$IFDEF SUPPORTS_UNICODE_STRING}\r\nfunction UTF16GetNextChar(const S: WideString; var StrPos: SizeInt): UCS4; overload;\r\nfunction UTF16GetNextBuffer(const S: WideString; var StrPos: SizeInt; var Buffer: TUCS4Array; var Start: SizeInt; Count: SizeInt): SizeInt; overload;\r\n{$ENDIF SUPPORTS_UNICODE_STRING}\r\nfunction UTF16GetNextCharFromStream(S: TStream; out Ch: UCS4): Boolean;\r\nfunction UTF16GetNextBufferFromStream(S: TStream; var Buffer: TUCS4Array; var Start: SizeInt; Count: SizeInt): SizeInt;\r\n\r\n// UTF16GetPreviousChar = read previous UTF16 sequence starting at StrPos-1\r\n// if UNICODE_SILENT_FAILURE is defined, invalid sequences will be replaced by ReplacementCharacter\r\n// otherwise StrPos is set to -1 on return to flag an error (invalid UTF16 sequence)\r\n// StrPos will be decremented by the number of chars that were read\r\nfunction UTF16GetPreviousChar(const S: TUTF16String; var StrPos: SizeInt): UCS4; overload;\r\n{$IFDEF SUPPORTS_UNICODE_STRING}\r\nfunction UTF16GetPreviousChar(const S: WideString; var StrPos: SizeInt): UCS4; overload;\r\n{$ENDIF SUPPORTS_UNICODE_STRING}\r\n\r\n// UTF16SkipChars = skip NbSeq UTF16 sequences starting from StrPos\r\n// returns False if String is too small\r\n// if UNICODE_SILENT_FAILURE is not defined StrPos is set to -1 on error (invalid UTF16 sequence)\r\n// StrPos will be incremented by the number of chars that were skipped\r\n// On return, NbChar contains the number of UTF16 sequences that were skipped\r\nfunction UTF16SkipChars(const S: TUTF16String; var StrPos: SizeInt; var NbSeq: SizeInt): Boolean; overload;\r\n{$IFDEF SUPPORTS_UNICODE_STRING}\r\nfunction UTF16SkipChars(const S: WideString; var StrPos: SizeInt; var NbSeq: SizeInt): Boolean; overload;\r\n{$ENDIF SUPPORTS_UNICODE_STRING}\r\nfunction UTF16SkipCharsFromStream(S: TStream; var NbSeq: SizeInt): Boolean;\r\n\r\n// UTF16SetNextChar = append an UTF16 sequence at StrPos\r\n// returns False on error:\r\n// - if an UCS4 character cannot be stored to an UTF-16 string:\r\n// - if UNICODE_SILENT_FAILURE is defined, ReplacementCharacter is added\r\n// - if UNICODE_SILENT_FAILURE is not defined, StrPos is set to -1\r\n// - StrPos > -1 flags string being too small, callee did nothing and caller is responsible for allocating space\r\n// StrPos will be incremented by the number of chars that were written\r\nfunction UTF16SetNextChar(var S: TUTF16String; var StrPos: SizeInt; Ch: UCS4): Boolean; overload;\r\nfunction UTF16SetNextBuffer(var S: TUTF16String; var StrPos: SizeInt; const Buffer: TUCS4Array; var Start: SizeInt; Count: SizeInt): SizeInt; overload;\r\n{$IFDEF SUPPORTS_UNICODE_STRING}\r\nfunction UTF16SetNextChar(var S: WideString; var StrPos: SizeInt; Ch: UCS4): Boolean; overload;\r\nfunction UTF16SetNextBuffer(var S: WideString; var StrPos: SizeInt; const Buffer: TUCS4Array; var Start: SizeInt; Count: SizeInt): SizeInt; overload;\r\n{$ENDIF SUPPORTS_UNICODE_STRING}\r\nfunction UTF16SetNextCharToStream(S: TStream; Ch: UCS4): Boolean;\r\nfunction UTF16SetNextBufferToStream(S: TStream; const Buffer: TUCS4Array; var Start: SizeInt; Count: SizeInt): SizeInt;\r\n\r\n// AnsiGetNextChar = read next character at StrPos\r\n// StrPos will be incremented by the number of chars that were read (1)\r\nfunction AnsiGetNextChar(const S: AnsiString; var StrPos: SizeInt): UCS4; overload;\r\nfunction AnsiGetNextBuffer(const S: AnsiString; var StrPos: SizeInt; var Buffer: TUCS4Array; var Start: SizeInt; Count: SizeInt): SizeInt; overload;\r\nfunction AnsiGetNextCharFromStream(S: TStream; out Ch: UCS4): Boolean; overload;\r\nfunction AnsiGetNextBufferFromStream(S: TStream; var Buffer: TUCS4Array; var Start: SizeInt; Count: SizeInt): SizeInt; overload;\r\n\r\n// same as AnsiGetNextChar* with custom codepage\r\nfunction AnsiGetNextChar(const S: AnsiString; CodePage: Word; var StrPos: SizeInt): UCS4; overload;\r\nfunction AnsiGetNextBuffer(const S: AnsiString; CodePage: Word; var StrPos: SizeInt; var Buffer: TUCS4Array; var Start: SizeInt; Count: SizeInt): SizeInt; overload;\r\nfunction AnsiGetNextCharFromStream(S: TStream; CodePage: Word; out Ch: UCS4): Boolean; overload;\r\nfunction AnsiGetNextBufferFromStream(S: TStream; CodePage: Word; var Buffer: TUCS4Array; var Start: SizeInt; Count: SizeInt): SizeInt; overload;\r\n\r\n// AnsiSkipChars = skip NbSeq characters starting from StrPos\r\n// returns False if String is too small\r\n// StrPos will be incremented by the number of chars that were skipped\r\n// On return, NbChar contains the number of UTF16 sequences that were skipped\r\nfunction AnsiSkipChars(const S: AnsiString; var StrPos: SizeInt; var NbSeq: SizeInt): Boolean;\r\nfunction AnsiSkipCharsFromStream(S: TStream; var NbSeq: SizeInt): Boolean;\r\n\r\n// AnsiSetNextChar = append a character at StrPos\r\n// returns False on error:\r\n// - if an UCS4 character cannot be stored to an ansi string:\r\n// - if UNICODE_SILENT_FAILURE is defined, ReplacementCharacter is added\r\n// - if UNICODE_SILENT_FAILURE is not defined, StrPos is set to -1\r\n// - StrPos > -1 flags string being too small, callee did nothing and caller is responsible for allocating space\r\n// StrPos will be incremented by the number of chars that were written (1)\r\nfunction AnsiSetNextChar(var S: AnsiString; var StrPos: SizeInt; Ch: UCS4): Boolean; overload;\r\nfunction AnsiSetNextBuffer(var S: AnsiString; var StrPos: SizeInt; const Buffer: TUCS4Array; var Start: SizeInt; Count: SizeInt): SizeInt; overload;\r\nfunction AnsiSetNextCharToStream(S: TStream; Ch: UCS4): Boolean; overload;\r\nfunction AnsiSetNextBufferToStream(S: TStream; const Buffer: TUCS4Array; var Start: SizeInt; Count: SizeInt): SizeInt; overload;\r\n\r\n// same as AnsiSetNextChar* with custom codepage\r\nfunction AnsiSetNextChar(var S: AnsiString; CodePage: Word; var StrPos: SizeInt; Ch: UCS4): Boolean; overload;\r\nfunction AnsiSetNextBuffer(var S: AnsiString; CodePage: Word; var StrPos: SizeInt; const Buffer: TUCS4Array; var Start: SizeInt; Count: SizeInt): SizeInt; overload;\r\nfunction AnsiSetNextCharToStream(S: TStream; CodePage: Word; Ch: UCS4): Boolean; overload;\r\nfunction AnsiSetNextBufferToStream(S: TStream; CodePage: Word; const Buffer: TUCS4Array; var Start: SizeInt; Count: SizeInt): SizeInt; overload;\r\n\r\n// StringGetNextChar = read next character/sequence at StrPos\r\n// if UNICODE_SILENT_FAILURE is defined, invalid sequences will be replaced by ReplacementCharacter\r\n// otherwise StrPos is set to -1 on return to flag an error (invalid UTF16 sequence for WideString)\r\n// StrPos will be incremented by the number of chars that were read\r\nfunction StringGetNextChar(const S: string; var StrPos: SizeInt): UCS4; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\nfunction StringGetNextBuffer(const S: string; var StrPos: SizeInt; var Buffer: TUCS4Array; var Start: SizeInt; Count: SizeInt): SizeInt; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\n\r\n// StringSkipChars = skip NbSeq characters/sequences starting from StrPos\r\n// returns False if String is too small\r\n// if UNICODE_SILENT_FAILURE is not defined StrPos is set to -1 on error (invalid UTF16 sequence for WideString)\r\n// StrPos will be incremented by the number of chars that were skipped\r\n// On return, NbChar contains the number of UTF16 sequences that were skipped\r\nfunction StringSkipChars(const S: string; var StrPos: SizeInt; var NbSeq: SizeInt): Boolean; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\n\r\n// StringSetNextChar = append a character/sequence at StrPos\r\n// returns False on error:\r\n// - if an UCS4 character cannot be stored to a string:\r\n// - if UNICODE_SILENT_FAILURE is defined, ReplacementCharacter is added\r\n// - if UNICODE_SILENT_FAILURE is not defined, StrPos is set to -1\r\n// - StrPos > -1 flags string being too small, callee did nothing and caller is responsible for allocating space\r\n// StrPos will be incremented by the number of chars that were written\r\nfunction StringSetNextChar(var S: string; var StrPos: SizeInt; Ch: UCS4): Boolean; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\nfunction StringSetNextBuffer(var S: string; var StrPos: SizeInt; const Buffer: TUCS4Array; var Start: SizeInt; Count: SizeInt): SizeInt; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\n\r\n// one shot conversions between WideString and others\r\nfunction WideStringToUTF8(const S: WideString): TUTF8String; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF SUPPORTS_INLINE}\r\nfunction UTF8ToWideString(const S: TUTF8String): WideString; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF SUPPORTS_INLINE}\r\nfunction WideStringToUCS4(const S: WideString): TUCS4Array; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF SUPPORTS_INLINE}\r\nfunction UCS4ToWideString(const S: TUCS4Array): WideString; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF SUPPORTS_INLINE}\r\n\r\n// one shot conversions between AnsiString and others\r\nfunction AnsiStringToUTF8(const S: AnsiString): TUTF8String; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF SUPPORTS_INLINE}\r\nfunction UTF8ToAnsiString(const S: TUTF8String): AnsiString; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF SUPPORTS_INLINE}\r\nfunction AnsiStringToUTF16(const S: AnsiString): TUTF16String; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF SUPPORTS_INLINE}\r\nfunction UTF16ToAnsiString(const S: TUTF16String): AnsiString; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF SUPPORTS_INLINE}\r\nfunction AnsiStringToUCS4(const S: AnsiString): TUCS4Array; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF SUPPORTS_INLINE}\r\nfunction UCS4ToAnsiString(const S: TUCS4Array): AnsiString; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF SUPPORTS_INLINE}\r\n\r\n// one shot conversions between string and others\r\nfunction StringToUTF8(const S: string): TUTF8String; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF SUPPORTS_INLINE}\r\nfunction UTF8ToString(const S: TUTF8String): string; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF SUPPORTS_INLINE}\r\nfunction StringToUTF16(const S: string): TUTF16String; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF SUPPORTS_INLINE}\r\nfunction UTF16ToString(const S: TUTF16String): string; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF SUPPORTS_INLINE}\r\nfunction StringToUCS4(const S: string): TUCS4Array; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF SUPPORTS_INLINE}\r\nfunction UCS4ToString(const S: TUCS4Array): string; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF SUPPORTS_INLINE}\r\n\r\nfunction TryStringToUTF8(const S: string; out D: TUTF8String): Boolean; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF SUPPORTS_INLINE}\r\nfunction TryUTF8ToString(const S: TUTF8String; out D: string): Boolean; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF SUPPORTS_INLINE}\r\nfunction TryStringToUTF16(const S: string; out D: TUTF16String): Boolean; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF SUPPORTS_INLINE}\r\nfunction TryUTF16ToString(const S: TUTF16String; out D: string): Boolean; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF SUPPORTS_INLINE}\r\nfunction TryStringToUCS4(const S: string; out D: TUCS4Array): Boolean; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF SUPPORTS_INLINE}\r\nfunction TryUCS4ToString(const S: TUCS4Array; out D: string): Boolean; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF SUPPORTS_INLINE}\r\n\r\nfunction UTF8ToUTF16(const S: TUTF8String): TUTF16String;\r\nfunction UTF16ToUTF8(const S: TUTF16String): TUTF8String;\r\nfunction UTF8ToUCS4(const S: TUTF8String): TUCS4Array;\r\nfunction UCS4ToUTF8(const S: TUCS4Array): TUTF8String;\r\nfunction UTF16ToUCS4(const S: TUTF16String): TUCS4Array;\r\nfunction UCS4ToUTF16(const S: TUCS4Array): TUTF16String;\r\n\r\nfunction TryUTF8ToUTF16(const S: TUTF8String; out D: TUTF16String): Boolean;\r\nfunction TryUTF16ToUTF8(const S: TUTF16String; out D: TUTF8String): Boolean;\r\nfunction TryUTF8ToUCS4(const S: TUTF8String; out D: TUCS4Array): Boolean;\r\nfunction TryUCS4ToUTF8(const S: TUCS4Array; out D: TUTF8String): Boolean;\r\nfunction TryUTF16ToUCS4(const S: TUTF16String; out D: TUCS4Array): Boolean;\r\nfunction TryUCS4ToUTF16(const S: TUCS4Array; out D: TUTF16String): Boolean;\r\n\r\n// indexed conversions\r\nfunction UTF8CharCount(const S: TUTF8String): SizeInt;\r\nfunction UTF16CharCount(const S: TUTF16String): SizeInt;\r\nfunction UCS2CharCount(const S: TUCS2String): SizeInt;\r\nfunction UCS4CharCount(const S: TUCS4Array): SizeInt;\r\n// returns False if string is too small\r\n// if UNICODE_SILENT_FAILURE is not defined and an invalid UTFX sequence is detected, an exception is raised\r\n// returns True on success and Value contains UCS4 character that was read\r\nfunction GetUCS4CharAt(const UTF8Str: TUTF8String; Index: SizeInt; out Value: UCS4): Boolean; overload;\r\nfunction GetUCS4CharAt(const WideStr: TUTF16String; Index: SizeInt; out Value: UCS4; IsUTF16: Boolean = True): Boolean; overload;\r\nfunction GetUCS4CharAt(const UCS4Str: TUCS4Array; Index: SizeInt; out Value: UCS4): Boolean; overload;\r\n\r\nfunction UCS4ToAnsiChar(Value: UCS4): AnsiChar;\r\nfunction UCS4ToWideChar(Value: UCS4): WideChar;\r\nfunction UCS4ToChar(Value: UCS4): Char; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF SUPPORTS_INLINE}\r\n\r\nfunction AnsiCharToUCS4(Value: AnsiChar): UCS4;\r\nfunction WideCharToUCS4(Value: WideChar): UCS4;\r\nfunction CharToUCS4(Value: Char): UCS4; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF SUPPORTS_INLINE}\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jcl.svn.sourceforge.net/svnroot/jcl/tags/JCL-2.4-Build4571/jcl/source/common/JclStringConversions.pas $';\r\n Revision: '$Revision: 3795 $';\r\n Date: '$Date: 2012-05-16 21:09:59 +0200 (mer. 16 mai 2012) $';\r\n LogPath: 'JCL\\source\\common';\r\n Extra: '';\r\n Data: nil\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n {$IFDEF HAS_UNITSCOPE}\r\n {$IFDEF MSWINDOWS}\r\n Winapi.Windows,\r\n {$ENDIF MSWINDOWS}\r\n {$ELSE ~HAS_UNITSCOPE}\r\n {$IFDEF MSWINDOWS}\r\n Windows,\r\n {$ENDIF MSWINDOWS}\r\n {$ENDIF ~HAS_UNITSCOPE}\r\n JclResources;\r\n\r\nconst MB_ERR_INVALID_CHARS = 8;\r\n\r\nconstructor EJclUnexpectedEOSequenceError.Create;\r\nbegin\r\n inherited CreateRes(@RsEUnexpectedEOSeq);\r\nend;\r\n\r\nfunction StreamReadByte(S: TStream; out B: Byte): Boolean; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\nbegin\r\n B := 0;\r\n Result := S.Read(B, SizeOf(B)) = SizeOf(B);\r\nend;\r\n\r\nfunction StreamWriteByte(S: TStream; B: Byte): Boolean; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\nbegin\r\n Result := S.Write(B, SizeOf(B)) = SizeOf(B);\r\nend;\r\n\r\nfunction StreamReadWord(S: TStream; out W: Word): Boolean; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\nbegin\r\n W := 0;\r\n Result := S.Read(W, SizeOf(W)) = SizeOf(W);\r\nend;\r\n\r\nfunction StreamWriteWord(S: TStream; W: Word): Boolean; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\nbegin\r\n Result := S.Write(W, SizeOf(W)) = SizeOf(W);\r\nend;\r\n\r\n//----------------- conversion routines ------------------------------------------------------------\r\n\r\n// Converts the given source ANSI string into a Unicode string by expanding each character\r\n// from one byte to two bytes.\r\n// EAX contains Source, EDX contains Target, ECX contains Count\r\n\r\nprocedure ExpandASCIIString(const Source: PAnsiChar; Target: PWideChar; Count: SizeInt);\r\nasm\r\n {$IFDEF CPU32}\r\n // --> EAX Source\r\n // EDX Target\r\n // ECX Count\r\n JECXZ @@Finish // go out if there is nothing to do (ECX = 0)\r\n PUSH ESI\r\n MOV ESI, EAX\r\n XOR EAX, EAX\r\n@@1:\r\n MOV AL, [ESI]\r\n INC ESI\r\n MOV [EDX], AX\r\n ADD EDX, 2\r\n DEC ECX\r\n JNZ @@1\r\n POP ESI\r\n {$ENDIF CPU32}\r\n {$IFDEF CPU64}\r\n // --> RCX Source\r\n // RDX Target\r\n // R8 Count\r\n\r\n DEC R8 // go out if there is nothing to do (R8 = 0)\r\n JS @@Finish\r\n@@1:\r\n MOVZX AX, BYTE PTR [RCX]\r\n INC RCX\r\n MOV WORD PTR [RDX], AX\r\n ADD RDX, 2\r\n@@2:\r\n DEC R8\r\n JNS @@1\r\n {$ENDIF CPU64}\r\n@@Finish:\r\nend;\r\n\r\nconst\r\n HalfShift: Integer = 10;\r\n\r\n HalfBase: UCS4 = $0010000;\r\n HalfMask: UCS4 = $3FF;\r\n\r\nprocedure FlagInvalidSequence(var StrPos: SizeInt; Increment: SizeInt; out Ch: UCS4); overload;\r\nbegin\r\n {$IFDEF UNICODE_SILENT_FAILURE}\r\n Ch := UCS4ReplacementCharacter;\r\n Inc(StrPos, Increment);\r\n {$ELSE ~UNICODE_SILENT_FAILURE}\r\n StrPos := -1;\r\n {$ENDIF ~UNICODE_SILENT_FAILURE}\r\nend;\r\n\r\nprocedure FlagInvalidSequence(var StrPos: SizeInt; Increment: SizeInt); overload;\r\nbegin\r\n {$IFDEF UNICODE_SILENT_FAILURE}\r\n Inc(StrPos, Increment);\r\n {$ELSE ~UNICODE_SILENT_FAILURE}\r\n StrPos := -1;\r\n {$ENDIF ~UNICODE_SILENT_FAILURE}\r\nend;\r\n\r\nprocedure FlagInvalidSequence(out Ch: UCS4); overload;\r\nbegin\r\n {$IFDEF UNICODE_SILENT_FAILURE}\r\n Ch := UCS4ReplacementCharacter;\r\n {$ELSE ~UNICODE_SILENT_FAILURE}\r\n raise EJclUnexpectedEOSequenceError.Create;\r\n {$ENDIF ~UNICODE_SILENT_FAILURE}\r\nend;\r\n\r\nprocedure FlagInvalidSequence; overload;\r\nbegin\r\n {$IFNDEF UNICODE_SILENT_FAILURE}\r\n raise EJclUnexpectedEOSequenceError.Create;\r\n {$ENDIF ~UNICODE_SILENT_FAILURE}\r\nend;\r\n\r\n// if UNICODE_SILENT_FAILURE is defined, invalid sequences will be replaced by ReplacementCharacter\r\n// otherwise StrPos is set to -1 on return to flag an error (invalid UTF8 sequence)\r\n// StrPos will be incremented by the number of chars that were read\r\nfunction UTF8GetNextChar(const S: TUTF8String; var StrPos: SizeInt): UCS4;\r\nvar\r\n StrLength: SizeInt;\r\n Ch: UCS4;\r\n ReadSuccess: Boolean;\r\nbegin\r\n StrLength := Length(S);\r\n ReadSuccess := True;\r\n\r\n if (StrPos <= StrLength) and (StrPos > 0) then\r\n begin\r\n Result := UCS4(S[StrPos]);\r\n\r\n case Result of\r\n $00..$7F:\r\n // 1 byte to read\r\n Inc(StrPos);\r\n $C0..$DF:\r\n begin\r\n // 2 bytes to read\r\n if StrPos < StrLength then\r\n begin\r\n Ch := UCS4(S[StrPos + 1]);\r\n if (Ch and $C0) = $80 then\r\n begin\r\n Result := ((Result and $1F) shl 6) or (Ch and $3F);\r\n Inc(StrPos, 2);\r\n end\r\n else\r\n FlagInvalidSequence(StrPos, 1, Result);\r\n end\r\n else\r\n ReadSuccess := False;\r\n end;\r\n $E0..$EF:\r\n begin\r\n // 3 bytes to read\r\n if (StrPos + 1) < StrLength then\r\n begin\r\n Ch := UCS4(S[StrPos + 1]);\r\n if (Ch and $C0) = $80 then\r\n begin\r\n Result := ((Result and $0F) shl 12) or ((Ch and $3F) shl 6);\r\n Ch := UCS4(S[StrPos + 2]);\r\n if (Ch and $C0) = $80 then\r\n begin\r\n Result := Result or (Ch and $3F);\r\n Inc(StrPos, 3);\r\n end\r\n else\r\n FlagInvalidSequence(StrPos, 2, Result);\r\n end\r\n else\r\n FlagInvalidSequence(StrPos, 1, Result);\r\n end\r\n else\r\n ReadSuccess := False;\r\n end;\r\n $F0..$F7:\r\n begin\r\n // 4 bytes to read\r\n if (StrPos + 2) < StrLength then\r\n begin\r\n Ch := UCS4(S[StrPos + 1]);\r\n if (Ch and $C0) = $80 then\r\n begin\r\n Result := ((Result and $07) shl 18) or ((Ch and $3F) shl 12);\r\n Ch := UCS4(S[StrPos + 2]);\r\n if (Ch and $C0) = $80 then\r\n begin\r\n Result := Result or ((Ch and $3F) shl 6);\r\n Ch := UCS4(S[StrPos + 3]);\r\n if (Ch and $C0) = $80 then\r\n begin\r\n Result := Result or (Ch and $3F);\r\n Inc(StrPos, 4);\r\n end\r\n else\r\n FlagInvalidSequence(StrPos, 3, Result);\r\n end\r\n else\r\n FlagInvalidSequence(StrPos, 2, Result);\r\n end\r\n else\r\n FlagInvalidSequence(StrPos, 1, Result);\r\n end\r\n else\r\n ReadSuccess := False;\r\n end;\r\n $F8..$FB:\r\n begin\r\n // 5 bytes to read\r\n if (StrPos + 3) < StrLength then\r\n begin\r\n Ch := UCS4(S[StrPos + 1]);\r\n if (Ch and $C0) = $80 then\r\n begin\r\n Result := ((Result and $03) shl 24) or ((Ch and $3F) shl 18);\r\n Ch := UCS4(S[StrPos + 2]);\r\n if (Ch and $C0) = $80 then\r\n begin\r\n Result := Result or ((Ch and $3F) shl 12);\r\n Ch := UCS4(S[StrPos + 3]);\r\n if (Ch and $C0) = $80 then\r\n begin\r\n Result := Result or ((Ch and $3F) shl 6);\r\n Ch := UCS4(S[StrPos + 4]);\r\n if (Ch and $C0) = $80 then\r\n begin\r\n Result := Result or (Ch and $3F);\r\n Inc(StrPos, 5);\r\n end\r\n else\r\n FlagInvalidSequence(StrPos, 4, Result);\r\n end\r\n else\r\n FlagInvalidSequence(StrPos, 3, Result);\r\n end\r\n else\r\n FlagInvalidSequence(StrPos, 2, Result);\r\n end\r\n else\r\n FlagInvalidSequence(StrPos, 1, Result);\r\n end\r\n else\r\n ReadSuccess := False;\r\n end;\r\n $FC..$FD:\r\n begin\r\n // 6 bytes to read\r\n if (StrPos + 4) < StrLength then\r\n begin\r\n Ch := UCS4(S[StrPos + 1]);\r\n if (Ch and $C0) = $80 then\r\n begin\r\n Result := ((Result and $01) shl 30) or ((Ch and $3F) shl 24);\r\n Ch := UCS4(S[StrPos + 2]);\r\n if (Ch and $C0) = $80 then\r\n begin\r\n Result := Result or ((Ch and $3F) shl 18);\r\n Ch := UCS4(S[StrPos + 3]);\r\n if (Ch and $C0) = $80 then\r\n begin\r\n Result := Result or ((Ch and $3F) shl 12);\r\n Ch := UCS4(S[StrPos + 4]);\r\n if (Ch and $C0) = $80 then\r\n begin\r\n Result := Result or ((Ch and $3F) shl 6);\r\n Ch := UCS4(S[StrPos + 5]);\r\n if (Ch and $C0) = $80 then\r\n begin\r\n Result := Result or (Ch and $3F);\r\n Inc(StrPos, 6);\r\n end\r\n else\r\n FlagInvalidSequence(StrPos, 5, Result);\r\n end\r\n else\r\n FlagInvalidSequence(StrPos, 4, Result);\r\n end\r\n else\r\n FlagInvalidSequence(StrPos, 3, Result);\r\n end\r\n else\r\n FlagInvalidSequence(StrPos, 2, Result);\r\n end\r\n else\r\n FlagInvalidSequence(StrPos, 1, Result);\r\n end\r\n else\r\n ReadSuccess := False;\r\n end;\r\n else\r\n FlagInvalidSequence(StrPos, 1, Result);\r\n end;\r\n if not ReadSuccess then\r\n FlagInvalidSequence(StrPos, 1, Result);\r\n end\r\n else\r\n begin\r\n // StrPos > StrLength\r\n Result := 0;\r\n FlagInvalidSequence(StrPos, 0, Result);\r\n end;\r\nend;\r\n\r\nfunction UTF8GetNextBuffer(const S: TUTF8String; var StrPos: SizeInt; var Buffer: TUCS4Array; var Start: SizeInt; Count: SizeInt): SizeInt;\r\nvar\r\n B: Byte;\r\n Ch: UCS4;\r\n ReadSuccess: Boolean;\r\n StrLength: SizeInt;\r\nbegin\r\n StrLength := Length(S);\r\n Result := 0;\r\n ReadSuccess := True;\r\n while (StrPos <= StrLength) and (StrPos > 0) and (Count > 0) do\r\n begin\r\n Ch := UCS4(S[StrPos]);\r\n\r\n case Ch of\r\n $00..$7F:\r\n // 1 byte to read\r\n Inc(StrPos);\r\n $C0..$DF:\r\n begin\r\n // 2 bytes to read\r\n if StrPos < StrLength then\r\n begin\r\n B := Ord(S[StrPos + 1]);\r\n if (B and $C0) = $80 then\r\n Ch := ((Ch and $1F) shl 6) or (B and $3F)\r\n else\r\n FlagInvalidSequence(StrPos, 1, Ch);\r\n end\r\n else\r\n ReadSuccess := False;\r\n end;\r\n $E0..$EF:\r\n begin\r\n // 3 bytes to read\r\n if (StrPos + 1) < StrLength then\r\n begin\r\n B := Ord(S[StrPos + 1]);\r\n if (B and $C0) = $80 then\r\n begin\r\n Ch := ((Ch and $0F) shl 12) or ((B and $3F) shl 6);\r\n B := Ord(S[StrPos + 2]);\r\n if (B and $C0) = $80 then\r\n Ch := Ch or (B and $3F)\r\n else\r\n FlagInvalidSequence(StrPos, 2, Ch);\r\n end\r\n else\r\n FlagInvalidSequence(StrPos, 1, Ch);\r\n end\r\n else\r\n ReadSuccess := False;\r\n end;\r\n $F0..$F7:\r\n begin\r\n // 4 bytes to read\r\n if (StrPos + 2) < StrLength then\r\n begin\r\n B := Ord(S[StrPos + 1]);\r\n if (B and $C0) = $80 then\r\n begin\r\n Ch := ((Ch and $07) shl 18) or ((B and $3F) shl 12);\r\n B := Ord(S[StrPos + 2]);\r\n if (B and $C0) = $80 then\r\n begin\r\n Ch := Ch or ((B and $3F) shl 6);\r\n B := Ord(S[StrPos + 3]);\r\n if (B and $C0) = $80 then\r\n Ch := Ch or (B and $3F)\r\n else\r\n FlagInvalidSequence(StrPos, 3, Ch);\r\n end\r\n else\r\n FlagInvalidSequence(StrPos, 2, Ch);\r\n end\r\n else\r\n FlagInvalidSequence(StrPos, 1, Ch);\r\n end\r\n else\r\n ReadSuccess := False;\r\n end;\r\n $F8..$FB:\r\n begin\r\n // 5 bytes to read\r\n if (StrPos + 3) < StrLength then\r\n begin\r\n B := Ord(S[StrPos + 1]);\r\n if (B and $C0) = $80 then\r\n begin\r\n Ch := ((Ch and $03) shl 24) or ((B and $3F) shl 18);\r\n B := Ord(S[StrPos + 2]);\r\n if (B and $C0) = $80 then\r\n begin\r\n Ch := Ch or ((B and $3F) shl 12);\r\n B := Ord(S[StrPos + 3]);\r\n if (B and $C0) = $80 then\r\n begin\r\n Ch := Ch or ((B and $3F) shl 6);\r\n B := Ord(S[StrPos + 4]);\r\n if (B and $C0) = $80 then\r\n Ch := Ch or (B and $3F)\r\n else\r\n FlagInvalidSequence(StrPos, 4, Ch);\r\n end\r\n else\r\n FlagInvalidSequence(StrPos, 3, Ch);\r\n end\r\n else\r\n FlagInvalidSequence(StrPos, 2, Ch);\r\n end\r\n else\r\n FlagInvalidSequence(StrPos, 1, Ch);\r\n end\r\n else\r\n ReadSuccess := False;\r\n end;\r\n $FC..$FD:\r\n begin\r\n // 6 bytes to read\r\n if (StrPos + 4) < StrLength then\r\n begin\r\n B := Ord(S[StrPos + 1]);\r\n if (B and $C0) = $80 then\r\n begin\r\n Ch := ((Ch and $01) shl 30) or ((B and $3F) shl 24);\r\n B := Ord(S[StrPos + 2]);\r\n if (B and $C0) = $80 then\r\n begin\r\n Ch := Ch or ((B and $3F) shl 18);\r\n B := Ord(S[StrPos + 3]);\r\n if (B and $C0) = $80 then\r\n begin\r\n Ch := Ch or ((B and $3F) shl 12);\r\n B := Ord(S[StrPos + 4]);\r\n if (B and $C0) = $80 then\r\n begin\r\n Ch := Ch or ((B and $3F) shl 6);\r\n B := Ord(S[StrPos + 5]);\r\n if (B and $C0) = $80 then\r\n Ch := Ch or (B and $3F)\r\n else\r\n FlagInvalidSequence(StrPos, 5, Ch);\r\n end\r\n else\r\n FlagInvalidSequence(StrPos, 4, Ch);\r\n end\r\n else\r\n FlagInvalidSequence(StrPos, 3, Ch);\r\n end\r\n else\r\n FlagInvalidSequence(StrPos, 2, Ch);\r\n end\r\n else\r\n FlagInvalidSequence(StrPos, 1, Ch);\r\n end\r\n else\r\n ReadSuccess := False;\r\n end\r\n else\r\n FlagInvalidSequence(StrPos, 1, Ch);\r\n end;\r\n if not ReadSuccess then\r\n FlagInvalidSequence(StrPos, 1, Ch);\r\n\r\n Buffer[Start] := Ch;\r\n Inc(Start);\r\n Inc(Result);\r\n Dec(Count);\r\n end;\r\nend;\r\n\r\nfunction UTF8GetNextCharFromStream(S: TStream; out Ch: UCS4): Boolean;\r\nvar\r\n B: Byte;\r\nbegin\r\n Result := StreamReadByte(S,B);\r\n if Result then\r\n begin\r\n Ch := UCS4(B);\r\n\r\n case Ch of\r\n $00..$7F: ;\r\n // 1 byte to read\r\n // nothing to do\r\n $C0..$DF:\r\n begin\r\n // 2 bytes to read\r\n Result := StreamReadByte(S,B);\r\n if Result then\r\n begin\r\n if (B and $C0) = $80 then\r\n Ch := ((Ch and $1F) shl 6) or (B and $3F)\r\n else\r\n FlagInvalidSequence(Ch);\r\n end;\r\n end;\r\n $E0..$EF:\r\n begin\r\n // 3 bytes to read\r\n Result := StreamReadByte(S,B);\r\n if Result then\r\n begin\r\n if (B and $C0) = $80 then\r\n begin\r\n Ch := ((Ch and $0F) shl 12) or ((B and $3F) shl 6);\r\n Result := StreamReadByte(S,B);\r\n if Result then\r\n begin\r\n if (B and $C0) = $80 then\r\n Ch := Ch or (B and $3F)\r\n else\r\n FlagInvalidSequence(Ch);\r\n end;\r\n end\r\n else\r\n FlagInvalidSequence(Ch);\r\n end;\r\n end;\r\n $F0..$F7:\r\n begin\r\n // 4 bytes to read\r\n Result := StreamReadByte(S,B);\r\n if Result then\r\n begin\r\n if (B and $C0) = $80 then\r\n begin\r\n Ch := ((Ch and $07) shl 18) or ((B and $3F) shl 12);\r\n Result := StreamReadByte(S,B);\r\n if Result then\r\n begin\r\n if (B and $C0) = $80 then\r\n begin\r\n Ch := Ch or ((B and $3F) shl 6);\r\n Result := StreamReadByte(S,B);\r\n if Result then\r\n begin\r\n if (B and $C0) = $80 then\r\n Ch := Ch or (B and $3F)\r\n else\r\n FlagInvalidSequence(Ch);\r\n end;\r\n end\r\n else\r\n FlagInvalidSequence(Ch);\r\n end;\r\n end\r\n else\r\n FlagInvalidSequence(Ch);\r\n end;\r\n end;\r\n $F8..$FB:\r\n begin\r\n // 5 bytes to read\r\n Result := StreamReadByte(S,B);\r\n if Result then\r\n begin\r\n if (B and $C0) = $80 then\r\n begin\r\n Ch := ((Ch and $03) shl 24) or ((B and $3F) shl 18);\r\n Result := StreamReadByte(S,B);\r\n if Result then\r\n begin\r\n if (B and $C0) = $80 then\r\n begin\r\n Ch := Ch or ((B and $3F) shl 12);\r\n Result := StreamReadByte(S,B);\r\n if Result then\r\n begin\r\n if (B and $C0) = $80 then\r\n begin\r\n Ch := Ch or ((B and $3F) shl 6);\r\n Result := StreamReadByte(S,B);\r\n if Result then\r\n begin\r\n if (B and $C0) = $80 then\r\n Ch := Ch or (B and $3F)\r\n else\r\n FlagInvalidSequence(Ch);\r\n end;\r\n end\r\n else\r\n FlagInvalidSequence(Ch);\r\n end;\r\n end\r\n else\r\n FlagInvalidSequence(Ch);\r\n end;\r\n end\r\n else\r\n FlagInvalidSequence(Ch);\r\n end;\r\n end;\r\n $FC..$FD:\r\n begin\r\n // 6 bytes to read\r\n Result := StreamReadByte(S,B);\r\n if Result then\r\n begin\r\n if (B and $C0) = $80 then\r\n begin\r\n Ch := ((Ch and $01) shl 30) or ((B and $3F) shl 24);\r\n Result := StreamReadByte(S,B);\r\n if Result then\r\n begin\r\n if (B and $C0) = $80 then\r\n begin\r\n Ch := Ch or ((B and $3F) shl 18);\r\n Result := StreamReadByte(S,B);\r\n if Result then\r\n begin\r\n if (B and $C0) = $80 then\r\n begin\r\n Ch := Ch or ((B and $3F) shl 12);\r\n Result := StreamReadByte(S,B);\r\n if Result then\r\n begin\r\n if (B and $C0) = $80 then\r\n begin\r\n Ch := Ch or ((B and $3F) shl 6);\r\n Result := StreamReadByte(S,B);\r\n if Result then\r\n begin\r\n if (B and $C0) = $80 then\r\n Ch := Ch or (B and $3F)\r\n else\r\n FlagInvalidSequence(Ch);\r\n end;\r\n end\r\n else\r\n FlagInvalidSequence(Ch);\r\n end;\r\n end\r\n else\r\n FlagInvalidSequence(Ch);\r\n end;\r\n end\r\n else\r\n FlagInvalidSequence(Ch);\r\n end;\r\n end\r\n else\r\n FlagInvalidSequence(Ch);\r\n end;\r\n end;\r\n else\r\n FlagInvalidSequence(Ch);\r\n end;\r\n end;\r\nend;\r\n\r\nfunction UTF8GetNextBufferFromStream(S: TStream; var Buffer: TUCS4Array; var Start: SizeInt; Count: SizeInt): SizeInt;\r\nvar\r\n B: Byte;\r\n Ch: UCS4;\r\n ReadSuccess: Boolean;\r\nbegin\r\n Result := 0;\r\n ReadSuccess := True;\r\n while ReadSuccess and (Count > 0) do\r\n begin\r\n if StreamReadByte(S,B) then\r\n begin\r\n Ch := UCS4(B);\r\n\r\n case Ch of\r\n $00..$7F: ;\r\n // 1 byte to read\r\n // nothing to do\r\n $C0..$DF:\r\n begin\r\n // 2 bytes to read\r\n if StreamReadByte(S,B) then\r\n begin\r\n if (B and $C0) = $80 then\r\n Ch := ((Ch and $1F) shl 6) or (B and $3F)\r\n else\r\n FlagInvalidSequence(Ch);\r\n end\r\n else\r\n ReadSuccess := False;\r\n end;\r\n $E0..$EF:\r\n begin\r\n // 3 bytes to read\r\n if StreamReadByte(S,B) then\r\n begin\r\n if (B and $C0) = $80 then\r\n begin\r\n Ch := ((Ch and $0F) shl 12) or ((B and $3F) shl 6);\r\n if StreamReadByte(S,B) then\r\n begin\r\n if (B and $C0) = $80 then\r\n Ch := Ch or (B and $3F)\r\n else\r\n FlagInvalidSequence(Ch);\r\n end\r\n else\r\n ReadSuccess := False;\r\n end\r\n else\r\n FlagInvalidSequence(Ch);\r\n end\r\n else\r\n ReadSuccess := False;\r\n end;\r\n $F0..$F7:\r\n begin\r\n // 4 bytes to read\r\n if StreamReadByte(S,B) then\r\n begin\r\n if (B and $C0) = $80 then\r\n begin\r\n Ch := ((Ch and $07) shl 18) or ((B and $3F) shl 12);\r\n if StreamReadByte(S,B) then\r\n begin\r\n if (B and $C0) = $80 then\r\n begin\r\n Ch := Ch or ((B and $3F) shl 6);\r\n if StreamReadByte(S,B) then\r\n begin\r\n if (B and $C0) = $80 then\r\n Ch := Ch or (B and $3F)\r\n else\r\n FlagInvalidSequence(Ch);\r\n end\r\n else\r\n ReadSuccess := False;\r\n end\r\n else\r\n FlagInvalidSequence(Ch);\r\n end\r\n else\r\n ReadSuccess := False;\r\n end\r\n else\r\n FlagInvalidSequence(Ch);\r\n end\r\n else\r\n ReadSuccess := False;\r\n end;\r\n $F8..$FB:\r\n begin\r\n // 5 bytes to read\r\n if StreamReadByte(S,B) then\r\n begin\r\n if (B and $C0) = $80 then\r\n begin\r\n Ch := ((Ch and $03) shl 24) or ((B and $3F) shl 18);\r\n if StreamReadByte(S,B) then\r\n begin\r\n if (B and $C0) = $80 then\r\n begin\r\n Ch := Ch or ((B and $3F) shl 12);\r\n if StreamReadByte(S,B) then\r\n begin\r\n if (B and $C0) = $80 then\r\n begin\r\n Ch := Ch or ((B and $3F) shl 6);\r\n if StreamReadByte(S,B) then\r\n begin\r\n if (B and $C0) = $80 then\r\n Ch := Ch or (B and $3F)\r\n else\r\n FlagInvalidSequence(Ch);\r\n end\r\n else\r\n ReadSuccess := False;\r\n end\r\n else\r\n FlagInvalidSequence(Ch);\r\n end\r\n else\r\n ReadSuccess := False;\r\n end\r\n else\r\n FlagInvalidSequence(Ch);\r\n end\r\n else\r\n ReadSuccess := False;\r\n end\r\n else\r\n FlagInvalidSequence(Ch);\r\n end\r\n else\r\n ReadSuccess := False;\r\n end;\r\n $FC..$FD:\r\n begin\r\n // 6 bytes to read\r\n if StreamReadByte(S,B) then\r\n begin\r\n if (B and $C0) = $80 then\r\n begin\r\n Ch := ((Ch and $01) shl 30) or ((B and $3F) shl 24);\r\n if StreamReadByte(S,B) then\r\n begin\r\n if (B and $C0) = $80 then\r\n begin\r\n Ch := Ch or ((B and $3F) shl 18);\r\n if StreamReadByte(S,B) then\r\n begin\r\n if (B and $C0) = $80 then\r\n begin\r\n Ch := Ch or ((B and $3F) shl 12);\r\n if StreamReadByte(S,B) then\r\n begin\r\n if (B and $C0) = $80 then\r\n begin\r\n Ch := Ch or ((B and $3F) shl 6);\r\n if StreamReadByte(S,B) then\r\n begin\r\n if (B and $C0) = $80 then\r\n Ch := Ch or (B and $3F)\r\n else\r\n FlagInvalidSequence(Ch);\r\n end\r\n else\r\n ReadSuccess := False;\r\n end\r\n else\r\n FlagInvalidSequence(Ch);\r\n end\r\n else\r\n ReadSuccess := False;\r\n end\r\n else\r\n FlagInvalidSequence(Ch);\r\n end\r\n else\r\n ReadSuccess := False;\r\n end\r\n else\r\n FlagInvalidSequence(Ch);\r\n end\r\n else\r\n ReadSuccess := False;\r\n end\r\n else\r\n FlagInvalidSequence(Ch);\r\n end\r\n else\r\n ReadSuccess := False;\r\n end\r\n else\r\n FlagInvalidSequence(Ch);\r\n end;\r\n if ReadSuccess then\r\n begin\r\n Buffer[Start] := Ch;\r\n Inc(Start);\r\n Inc(Result);\r\n end;\r\n end\r\n else\r\n ReadSuccess := False;\r\n Dec(Count);\r\n end;\r\nend;\r\n\r\n// returns False if String is too small\r\n// if UNICODE_SILENT_FAILURE is not defined StrPos is set to -1 on error (invalid UTF8 sequence)\r\n// StrPos will be incremented by the number of ansi chars that were skipped\r\n// On return, NbSeq contains the number of UTF8 sequences that were skipped\r\nfunction UTF8SkipChars(const S: TUTF8String; var StrPos: SizeInt; var NbSeq: SizeInt): Boolean;\r\nvar\r\n StrLength: SizeInt;\r\n Ch: UCS4;\r\n Index: SizeInt;\r\nbegin\r\n Result := True;\r\n StrLength := Length(S);\r\n\r\n Index := 0;\r\n while (Index < NbSeq) and (StrPos > 0) do\r\n begin\r\n Ch := UCS4(S[StrPos]);\r\n\r\n case Ch of\r\n $00..$7F:\r\n // 1 byte to skip\r\n Inc(StrPos);\r\n $C0..$DF:\r\n // 2 bytes to skip\r\n if (StrPos >= StrLength) or ((UCS4(S[StrPos + 1]) and $C0) <> $80) then\r\n FlagInvalidSequence(StrPos, 1)\r\n else\r\n Inc(StrPos, 2);\r\n $E0..$EF:\r\n // 3 bytes to skip\r\n if ((StrPos + 1) >= StrLength) or ((UCS4(S[StrPos + 1]) and $C0) <> $80) then\r\n FlagInvalidSequence(StrPos, 1)\r\n else\r\n if (UCS4(S[StrPos + 2]) and $C0) <> $80 then\r\n FlagInvalidSequence(StrPos, 2)\r\n else\r\n Inc(StrPos, 3);\r\n $F0..$F7:\r\n // 4 bytes to skip\r\n if ((StrPos + 2) >= StrLength) or ((UCS4(S[StrPos + 1]) and $C0) <> $80) then\r\n FlagInvalidSequence(StrPos, 1)\r\n else\r\n if (UCS4(S[StrPos + 2]) and $C0) <> $80 then\r\n FlagInvalidSequence(StrPos, 2)\r\n else\r\n if (UCS4(S[StrPos + 3]) and $C0) <> $80 then\r\n FlagInvalidSequence(StrPos, 3)\r\n else\r\n Inc(StrPos, 4);\r\n $F8..$FB:\r\n // 5 bytes to skip\r\n if ((StrPos + 3) >= StrLength) or ((UCS4(S[StrPos + 1]) and $C0) <> $80) then\r\n FlagInvalidSequence(StrPos, 1)\r\n else\r\n if (UCS4(S[StrPos + 2]) and $C0) <> $80 then\r\n FlagInvalidSequence(StrPos, 2)\r\n else\r\n if (UCS4(S[StrPos + 3]) and $C0) <> $80 then\r\n FlagInvalidSequence(StrPos, 3)\r\n else\r\n if (UCS4(S[StrPos + 4]) and $C0) <> $80 then\r\n FlagInvalidSequence(StrPos, 4)\r\n else\r\n Inc(StrPos, 5);\r\n $FC..$FD:\r\n // 6 bytes to skip\r\n if ((StrPos + 4) >= StrLength) or ((UCS4(S[StrPos + 1]) and $C0) <> $80) then\r\n FlagInvalidSequence(StrPos, 1)\r\n else\r\n if (UCS4(S[StrPos + 2]) and $C0) <> $80 then\r\n FlagInvalidSequence(StrPos, 2)\r\n else\r\n if (UCS4(S[StrPos + 3]) and $C0) <> $80 then\r\n FlagInvalidSequence(StrPos, 3)\r\n else\r\n if (UCS4(S[StrPos + 4]) and $C0) <> $80 then\r\n FlagInvalidSequence(StrPos, 4)\r\n else\r\n if (UCS4(S[StrPos + 5]) and $C0) <> $80 then\r\n FlagInvalidSequence(StrPos, 5)\r\n else\r\n Inc(StrPos, 6);\r\n else\r\n FlagInvalidSequence(StrPos, 1);\r\n end;\r\n\r\n if StrPos <> -1 then\r\n Inc(Index);\r\n if (StrPos > StrLength) and (Index < NbSeq) then\r\n begin\r\n Result := False;\r\n Break;\r\n end;\r\n end;\r\n NbSeq := Index;\r\nend;\r\n\r\nfunction UTF8SkipCharsFromStream(S: TStream; var NbSeq: SizeInt): Boolean;\r\nvar\r\n B: Byte;\r\n Index: SizeInt;\r\nbegin\r\n Index := 0;\r\n while (Index < NbSeq) do\r\n begin\r\n Result := StreamReadByte(S, B);\r\n if not Result then\r\n Break;\r\n case B of\r\n $00..$7F: ;\r\n // 1 byte to skip\r\n // nothing to do\r\n $C0..$DF:\r\n // 2 bytes to skip\r\n begin\r\n Result := StreamReadByte(S, B);\r\n if not Result then\r\n Break;\r\n if (B and $C0) <> $80 then\r\n FlagInvalidSequence;\r\n end;\r\n $E0..$EF:\r\n // 3 bytes to skip\r\n begin\r\n Result := StreamReadByte(S, B);\r\n if not Result then\r\n Break;\r\n if (B and $C0) <> $80 then\r\n FlagInvalidSequence;\r\n Result := StreamReadByte(S, B);\r\n if not Result then\r\n Break;\r\n if (B and $C0) <> $80 then\r\n FlagInvalidSequence;\r\n end;\r\n $F0..$F7:\r\n // 4 bytes to skip\r\n begin\r\n Result := StreamReadByte(S, B);\r\n if not Result then\r\n Break;\r\n if (B and $C0) <> $80 then\r\n FlagInvalidSequence;\r\n Result := StreamReadByte(S, B);\r\n if not Result then\r\n Break;\r\n if (B and $C0) <> $80 then\r\n FlagInvalidSequence;\r\n Result := StreamReadByte(S, B);\r\n if not Result then\r\n Break;\r\n if (B and $C0) <> $80 then\r\n FlagInvalidSequence;\r\n end;\r\n $F8..$FB:\r\n // 5 bytes to skip\r\n begin\r\n Result := StreamReadByte(S, B);\r\n if not Result then\r\n Break;\r\n if (B and $C0) <> $80 then\r\n FlagInvalidSequence;\r\n Result := StreamReadByte(S, B);\r\n if not Result then\r\n Break;\r\n if (B and $C0) <> $80 then\r\n FlagInvalidSequence;\r\n Result := StreamReadByte(S, B);\r\n if not Result then\r\n Break;\r\n if (B and $C0) <> $80 then\r\n FlagInvalidSequence;\r\n Result := StreamReadByte(S, B);\r\n if not Result then\r\n Break;\r\n if (B and $C0) <> $80 then\r\n FlagInvalidSequence;\r\n end;\r\n $FC..$FD:\r\n // 6 bytes to skip\r\n begin\r\n Result := StreamReadByte(S, B);\r\n if not Result then\r\n Break;\r\n if (B and $C0) <> $80 then\r\n FlagInvalidSequence;\r\n Result := StreamReadByte(S, B);\r\n if not Result then\r\n Break;\r\n if (B and $C0) <> $80 then\r\n FlagInvalidSequence;\r\n Result := StreamReadByte(S, B);\r\n if not Result then\r\n Break;\r\n if (B and $C0) <> $80 then\r\n FlagInvalidSequence;\r\n Result := StreamReadByte(S, B);\r\n if not Result then\r\n Break;\r\n if (B and $C0) <> $80 then\r\n FlagInvalidSequence;\r\n Result := StreamReadByte(S, B);\r\n if not Result then\r\n Break;\r\n if (B and $C0) <> $80 then\r\n FlagInvalidSequence;\r\n end;\r\n else\r\n FlagInvalidSequence;\r\n end;\r\n Inc(Index);\r\n end;\r\n Result := Index = NbSeq;\r\n NbSeq := Index;\r\nend;\r\n\r\n// returns False on error:\r\n// - if an UCS4 character cannot be stored to an UTF-8 string:\r\n// - if UNICODE_SILENT_FAILURE is defined, ReplacementCharacter is added\r\n// - if UNICODE_SILENT_FAILURE is not defined, StrPos is set to -1\r\n// - StrPos > -1 flags string being too small, caller is responsible for allocating space\r\n// StrPos will be incremented by the number of chars that were written\r\nfunction UTF8SetNextChar(var S: TUTF8String; var StrPos: SizeInt; Ch: UCS4): Boolean;\r\nvar\r\n StrLength: SizeInt;\r\nbegin\r\n StrLength := Length(S);\r\n\r\n if Ch <= $7F then\r\n begin\r\n // 7 bits to store\r\n Result := (StrPos > 0) and (StrPos <= StrLength);\r\n if Result then\r\n begin\r\n S[StrPos] := AnsiChar(Ch);\r\n Inc(StrPos);\r\n end;\r\n end\r\n else\r\n if Ch <= $7FF then\r\n begin\r\n // 11 bits to store\r\n Result := (StrPos > 0) and (StrPos < StrLength);\r\n if Result then\r\n begin\r\n S[StrPos] := AnsiChar($C0 or (Ch shr 6)); // 5 bits\r\n S[StrPos + 1] := AnsiChar((Ch and $3F) or $80); // 6 bits\r\n Inc(StrPos, 2);\r\n end;\r\n end\r\n else\r\n if Ch <= $FFFF then\r\n begin\r\n // 16 bits to store\r\n Result := (StrPos > 0) and (StrPos < (StrLength - 1));\r\n if Result then\r\n begin\r\n S[StrPos] := AnsiChar($E0 or (Ch shr 12)); // 4 bits\r\n S[StrPos + 1] := AnsiChar(((Ch shr 6) and $3F) or $80); // 6 bits\r\n S[StrPos + 2] := AnsiChar((Ch and $3F) or $80); // 6 bits\r\n Inc(StrPos, 3);\r\n end;\r\n end\r\n else\r\n if Ch <= $1FFFFF then\r\n begin\r\n // 21 bits to store\r\n Result := (StrPos > 0) and (StrPos < (StrLength - 2));\r\n if Result then\r\n begin\r\n S[StrPos] := AnsiChar($F0 or (Ch shr 18)); // 3 bits\r\n S[StrPos + 1] := AnsiChar(((Ch shr 12) and $3F) or $80); // 6 bits\r\n S[StrPos + 2] := AnsiChar(((Ch shr 6) and $3F) or $80); // 6 bits\r\n S[StrPos + 3] := AnsiChar((Ch and $3F) or $80); // 6 bits\r\n Inc(StrPos, 4);\r\n end;\r\n end\r\n else\r\n if Ch <= $3FFFFFF then\r\n begin\r\n // 26 bits to store\r\n Result := (StrPos > 0) and (StrPos < (StrLength - 2));\r\n if Result then\r\n begin\r\n S[StrPos] := AnsiChar($F8 or (Ch shr 24)); // 2 bits\r\n S[StrPos + 1] := AnsiChar(((Ch shr 18) and $3F) or $80); // 6 bits\r\n S[StrPos + 2] := AnsiChar(((Ch shr 12) and $3F) or $80); // 6 bits\r\n S[StrPos + 3] := AnsiChar(((Ch shr 6) and $3F) or $80); // 6 bits\r\n S[StrPos + 4] := AnsiChar((Ch and $3F) or $80); // 6 bits\r\n Inc(StrPos, 5);\r\n end;\r\n end\r\n else\r\n if Ch <= MaximumUCS4 then\r\n begin\r\n // 31 bits to store\r\n Result := (StrPos > 0) and (StrPos < (StrLength - 3));\r\n if Result then\r\n begin\r\n S[StrPos] := AnsiChar($FC or (Ch shr 30)); // 1 bits\r\n S[StrPos + 1] := AnsiChar(((Ch shr 24) and $3F) or $80); // 6 bits\r\n S[StrPos + 2] := AnsiChar(((Ch shr 18) and $3F) or $80); // 6 bits\r\n S[StrPos + 3] := AnsiChar(((Ch shr 12) and $3F) or $80); // 6 bits\r\n S[StrPos + 4] := AnsiChar(((Ch shr 6) and $3F) or $80); // 6 bits\r\n S[StrPos + 5] := AnsiChar((Ch and $3F) or $80); // 6 bits\r\n Inc(StrPos, 6);\r\n end;\r\n end\r\n else\r\n begin\r\n {$IFDEF UNICODE_SILENT_FAILURE}\r\n // add ReplacementCharacter\r\n Result := (StrPos > 0) and (StrPos < (StrLength - 1));\r\n if Result then\r\n begin\r\n S[StrPos] := AnsiChar($E0 or (UCS4ReplacementCharacter shr 12)); // 4 bits\r\n S[StrPos + 1] := AnsiChar(((UCS4ReplacementCharacter shr 6) and $3F) or $80); // 6 bits\r\n S[StrPos + 2] := AnsiChar((UCS4ReplacementCharacter and $3F) or $80); // 6 bits\r\n Inc(StrPos, 3);\r\n end;\r\n {$ELSE ~UNICODE_SILENT_FAILURE}\r\n StrPos := -1;\r\n Result := False;\r\n {$ENDIF ~UNICODE_SILENT_FAILURE}\r\n end;\r\nend;\r\n\r\nfunction UTF8SetNextBuffer(var S: TUTF8String; var StrPos: SizeInt; const Buffer: TUCS4Array; var Start: SizeInt; Count: SizeInt): SizeInt;\r\nvar\r\n StrLength: SizeInt;\r\n Ch: UCS4;\r\n Success: Boolean;\r\nbegin\r\n StrLength := Length(S);\r\n Success := True;\r\n Result := 0;\r\n while Success and (Count > 0) do\r\n begin\r\n Ch := Buffer[Start];\r\n if Ch <= $7F then\r\n begin\r\n // 7 bits to store\r\n if (StrPos > 0) and (StrPos <= StrLength) then\r\n begin\r\n S[StrPos] := AnsiChar(Ch);\r\n Inc(StrPos);\r\n end\r\n else\r\n Success := False;\r\n end\r\n else\r\n if Ch <= $7FF then\r\n begin\r\n // 11 bits to store\r\n if (StrPos > 0) and (StrPos < StrLength) then\r\n begin\r\n S[StrPos] := AnsiChar($C0 or (Ch shr 6)); // 5 bits\r\n S[StrPos + 1] := AnsiChar((Ch and $3F) or $80); // 6 bits\r\n Inc(StrPos, 2);\r\n end\r\n else\r\n Success := False;\r\n end\r\n else\r\n if Ch <= $FFFF then\r\n begin\r\n // 16 bits to store\r\n if (StrPos > 0) and (StrPos < (StrLength - 1)) then\r\n begin\r\n S[StrPos] := AnsiChar($E0 or (Ch shr 12)); // 4 bits\r\n S[StrPos + 1] := AnsiChar(((Ch shr 6) and $3F) or $80); // 6 bits\r\n S[StrPos + 2] := AnsiChar((Ch and $3F) or $80); // 6 bits\r\n Inc(StrPos, 3);\r\n end\r\n else\r\n Success := False;\r\n end\r\n else\r\n if Ch <= $1FFFFF then\r\n begin\r\n // 21 bits to store\r\n if (StrPos > 0) and (StrPos < (StrLength - 2)) then\r\n begin\r\n S[StrPos] := AnsiChar($F0 or (Ch shr 18)); // 3 bits\r\n S[StrPos + 1] := AnsiChar(((Ch shr 12) and $3F) or $80); // 6 bits\r\n S[StrPos + 2] := AnsiChar(((Ch shr 6) and $3F) or $80); // 6 bits\r\n S[StrPos + 3] := AnsiChar((Ch and $3F) or $80); // 6 bits\r\n Inc(StrPos, 4);\r\n end\r\n else\r\n Success := False;\r\n end\r\n else\r\n if Ch <= $3FFFFFF then\r\n begin\r\n // 26 bits to store\r\n if (StrPos > 0) and (StrPos < (StrLength - 2)) then\r\n begin\r\n S[StrPos] := AnsiChar($F8 or (Ch shr 24)); // 2 bits\r\n S[StrPos + 1] := AnsiChar(((Ch shr 18) and $3F) or $80); // 6 bits\r\n S[StrPos + 2] := AnsiChar(((Ch shr 12) and $3F) or $80); // 6 bits\r\n S[StrPos + 3] := AnsiChar(((Ch shr 6) and $3F) or $80); // 6 bits\r\n S[StrPos + 4] := AnsiChar((Ch and $3F) or $80); // 6 bits\r\n Inc(StrPos, 5);\r\n end\r\n else\r\n Success := False;\r\n end\r\n else\r\n if Ch <= MaximumUCS4 then\r\n begin\r\n // 31 bits to store\r\n if (StrPos > 0) and (StrPos < (StrLength - 3)) then\r\n begin\r\n S[StrPos] := AnsiChar($FC or (Ch shr 30)); // 1 bits\r\n S[StrPos + 1] := AnsiChar(((Ch shr 24) and $3F) or $80); // 6 bits\r\n S[StrPos + 2] := AnsiChar(((Ch shr 18) and $3F) or $80); // 6 bits\r\n S[StrPos + 3] := AnsiChar(((Ch shr 12) and $3F) or $80); // 6 bits\r\n S[StrPos + 4] := AnsiChar(((Ch shr 6) and $3F) or $80); // 6 bits\r\n S[StrPos + 5] := AnsiChar((Ch and $3F) or $80); // 6 bits\r\n Inc(StrPos, 6);\r\n end\r\n else\r\n Success := False;\r\n end\r\n else\r\n begin\r\n {$IFDEF UNICODE_SILENT_FAILURE}\r\n // add ReplacementCharacter\r\n if (StrPos > 0) and (StrPos < (StrLength - 1)) then\r\n begin\r\n S[StrPos] := AnsiChar($E0 or (UCS4ReplacementCharacter shr 12)); // 4 bits\r\n S[StrPos + 1] := AnsiChar(((UCS4ReplacementCharacter shr 6) and $3F) or $80); // 6 bits\r\n S[StrPos + 2] := AnsiChar((UCS4ReplacementCharacter and $3F) or $80); // 6 bits\r\n Inc(StrPos, 3);\r\n end\r\n else\r\n Success := False;\r\n {$ELSE ~UNICODE_SILENT_FAILURE}\r\n StrPos := -1;\r\n Success := False;\r\n {$ENDIF ~UNICODE_SILENT_FAILURE}\r\n end;\r\n if Success then\r\n begin\r\n Inc(Start);\r\n Inc(Result);\r\n end;\r\n Dec(Count);\r\n end;\r\nend;\r\n\r\nfunction UTF8SetNextCharToStream(S: TStream; Ch: UCS4): Boolean;\r\nbegin\r\n if Ch <= $7F then\r\n // 7 bits to store\r\n Result := StreamWriteByte(S,Ch)\r\n else\r\n if Ch <= $7FF then\r\n // 11 bits to store\r\n Result := StreamWriteByte(S, $C0 or (Ch shr 6)) and // 5 bits\r\n StreamWriteByte(S, (Ch and $3F) or $80) // 6 bits\r\n else\r\n if Ch <= $FFFF then\r\n // 16 bits to store\r\n Result := StreamWriteByte(S, $E0 or (Ch shr 12)) and // 4 bits\r\n StreamWriteByte(S, ((Ch shr 6) and $3F) or $80) and // 6 bits\r\n StreamWriteByte(S, (Ch and $3F) or $80) // 6 bits\r\n else\r\n if Ch <= $1FFFFF then\r\n // 21 bits to store\r\n Result := StreamWriteByte(S, $F0 or (Ch shr 18)) and // 3 bits\r\n StreamWriteByte(S, ((Ch shr 12) and $3F) or $80) and // 6 bits\r\n StreamWriteByte(S, ((Ch shr 6) and $3F) or $80) and // 6 bits\r\n StreamWriteByte(S, (Ch and $3F) or $80) // 6 bits\r\n else\r\n if Ch <= $3FFFFFF then\r\n // 26 bits to store\r\n Result := StreamWriteByte(S, $F8 or (Ch shr 24)) and // 2 bits\r\n StreamWriteByte(S, ((Ch shr 18) and $3F) or $80) and // 6 bits\r\n StreamWriteByte(S, ((Ch shr 12) and $3F) or $80) and // 6 bits\r\n StreamWriteByte(S, ((Ch shr 6) and $3F) or $80) and // 6 bits\r\n StreamWriteByte(S, (Ch and $3F) or $80) // 6 bits\r\n else\r\n if Ch <= MaximumUCS4 then\r\n // 31 bits to store\r\n Result := StreamWriteByte(S, $FC or (Ch shr 30)) and // 1 bits\r\n StreamWriteByte(S, ((Ch shr 24) and $3F) or $80) and // 6 bits\r\n StreamWriteByte(S, ((Ch shr 18) and $3F) or $80) and // 6 bits\r\n StreamWriteByte(S, ((Ch shr 12) and $3F) or $80) and // 6 bits\r\n StreamWriteByte(S, ((Ch shr 6) and $3F) or $80) and // 6 bits\r\n StreamWriteByte(S, (Ch and $3F) or $80) // 6 bits\r\n else\r\n {$IFDEF UNICODE_SILENT_FAILURE}\r\n // add ReplacementCharacter\r\n Result := StreamWriteByte(S, $E0 or (UCS4ReplacementCharacter shr 12)) and // 4 bits\r\n StreamWriteByte(S, ((UCS4ReplacementCharacter shr 6) and $3F) or $80) and // 6 bits\r\n StreamWriteByte(S, (UCS4ReplacementCharacter and $3F) or $80); // 6 bits\r\n {$ELSE ~UNICODE_SILENT_FAILURE}\r\n Result := False;\r\n {$ENDIF ~UNICODE_SILENT_FAILURE}\r\nend;\r\n\r\nfunction UTF8SetNextBufferToStream(S: TStream; const Buffer: TUCS4Array; var Start: SizeInt; Count: SizeInt): SizeInt;\r\nvar\r\n Ch: UCS4;\r\n Success: Boolean;\r\nbegin\r\n Result := 0;\r\n Success := True;\r\n while Success and (Count > 0) do\r\n begin\r\n Ch := Buffer[Start];\r\n if Ch <= $7F then\r\n // 7 bits to store\r\n Success := StreamWriteByte(S,Ch)\r\n else\r\n if Ch <= $7FF then\r\n // 11 bits to store\r\n Success := StreamWriteByte(S, $C0 or (Ch shr 6)) and // 5 bits\r\n StreamWriteByte(S, (Ch and $3F) or $80) // 6 bits\r\n else\r\n if Ch <= $FFFF then\r\n // 16 bits to store\r\n Success := StreamWriteByte(S, $E0 or (Ch shr 12)) and // 4 bits\r\n StreamWriteByte(S, ((Ch shr 6) and $3F) or $80) and // 6 bits\r\n StreamWriteByte(S, (Ch and $3F) or $80) // 6 bits\r\n else\r\n if Ch <= $1FFFFF then\r\n // 21 bits to store\r\n Success := StreamWriteByte(S, $F0 or (Ch shr 18)) and // 3 bits\r\n StreamWriteByte(S, ((Ch shr 12) and $3F) or $80) and // 6 bits\r\n StreamWriteByte(S, ((Ch shr 6) and $3F) or $80) and // 6 bits\r\n StreamWriteByte(S, (Ch and $3F) or $80) // 6 bits\r\n else\r\n if Ch <= $3FFFFFF then\r\n // 26 bits to store\r\n Success := StreamWriteByte(S, $F8 or (Ch shr 24)) and // 2 bits\r\n StreamWriteByte(S, ((Ch shr 18) and $3F) or $80) and // 6 bits\r\n StreamWriteByte(S, ((Ch shr 12) and $3F) or $80) and // 6 bits\r\n StreamWriteByte(S, ((Ch shr 6) and $3F) or $80) and // 6 bits\r\n StreamWriteByte(S, (Ch and $3F) or $80) // 6 bits\r\n else\r\n if Ch <= MaximumUCS4 then\r\n // 31 bits to store\r\n Success := StreamWriteByte(S, $FC or (Ch shr 30)) and // 1 bits\r\n StreamWriteByte(S, ((Ch shr 24) and $3F) or $80) and // 6 bits\r\n StreamWriteByte(S, ((Ch shr 18) and $3F) or $80) and // 6 bits\r\n StreamWriteByte(S, ((Ch shr 12) and $3F) or $80) and // 6 bits\r\n StreamWriteByte(S, ((Ch shr 6) and $3F) or $80) and // 6 bits\r\n StreamWriteByte(S, (Ch and $3F) or $80) // 6 bits\r\n else\r\n {$IFDEF UNICODE_SILENT_FAILURE}\r\n // add ReplacementCharacter\r\n Success := StreamWriteByte(S, $E0 or (UCS4ReplacementCharacter shr 12)) and // 4 bits\r\n StreamWriteByte(S, ((UCS4ReplacementCharacter shr 6) and $3F) or $80) and // 6 bits\r\n StreamWriteByte(S, (UCS4ReplacementCharacter and $3F) or $80); // 6 bits\r\n {$ELSE ~UNICODE_SILENT_FAILURE}\r\n Success := False;\r\n {$ENDIF ~UNICODE_SILENT_FAILURE}\r\n if Success then\r\n begin\r\n Inc(Start);\r\n Inc(Result);\r\n end;\r\n Dec(Count);\r\n end;\r\nend;\r\n\r\n// if UNICODE_SILENT_FAILURE is defined, invalid sequences will be replaced by ReplacementCharacter\r\n// otherwise StrPos is set to -1 on return to flag an error (invalid UTF16 sequence)\r\n// StrPos will be incremented by the number of chars that were read\r\nfunction UTF16GetNextChar(const S: TUTF16String; var StrPos: SizeInt): UCS4;\r\nvar\r\n StrLength: SizeInt;\r\n Ch: UCS4;\r\nbegin\r\n StrLength := Length(S);\r\n\r\n if (StrPos <= StrLength) and (StrPos > 0) then\r\n begin\r\n Result := UCS4(S[StrPos]);\r\n\r\n case Result of\r\n SurrogateHighStart..SurrogateHighEnd:\r\n begin\r\n // 2 bytes to read\r\n if StrPos < StrLength then\r\n begin\r\n Ch := UCS4(S[StrPos + 1]);\r\n if (Ch >= SurrogateLowStart) and (Ch <= SurrogateLowEnd) then\r\n begin\r\n Result := ((Result - SurrogateHighStart) shl HalfShift) + (Ch - SurrogateLowStart) + HalfBase;\r\n Inc(StrPos, 2);\r\n end\r\n else\r\n FlagInvalidSequence(StrPos, 1, Result);\r\n end\r\n else\r\n FlagInvalidSequence(StrPos, 1, Result);\r\n end;\r\n SurrogateLowStart..SurrogateLowEnd:\r\n FlagInvalidSequence(StrPos, 1, Result);\r\n else\r\n // 1 byte to read\r\n Inc(StrPos);\r\n end;\r\n end\r\n else\r\n begin\r\n // StrPos > StrLength\r\n Result := 0;\r\n FlagInvalidSequence(StrPos, 0, Result);\r\n end;\r\nend;\r\n\r\nfunction UTF16GetNextBuffer(const S: TUTF16String; var StrPos: SizeInt; var Buffer: TUCS4Array; var Start: SizeInt; Count: SizeInt): SizeInt; overload;\r\nvar\r\n StrLength: SizeInt;\r\n Ch, ChNext: UCS4;\r\n ReadSuccess: Boolean;\r\nbegin\r\n StrLength := Length(S);\r\n Result := 0;\r\n ReadSuccess := True;\r\n while (StrPos <= StrLength) and (StrPos > 0) and (Count > 0) do\r\n begin\r\n Ch := UCS4(S[StrPos]);\r\n\r\n case Ch of\r\n SurrogateHighStart..SurrogateHighEnd:\r\n begin\r\n // 2 bytes to read\r\n if StrPos < StrLength then\r\n begin\r\n ChNext := UCS4(S[StrPos + 1]);\r\n if (ChNext >= SurrogateLowStart) and (ChNext <= SurrogateLowEnd) then\r\n begin\r\n Ch := ((Ch - SurrogateHighStart) shl HalfShift) + (ChNext - SurrogateLowStart) + HalfBase;\r\n Inc(StrPos, 2);\r\n end\r\n else\r\n FlagInvalidSequence(StrPos, 1, Ch);\r\n end\r\n else\r\n ReadSuccess := False;\r\n end;\r\n SurrogateLowStart..SurrogateLowEnd:\r\n FlagInvalidSequence(StrPos, 1, Ch);\r\n else\r\n // 1 byte to read\r\n Inc(StrPos);\r\n end;\r\n if not ReadSuccess then\r\n FlagInvalidSequence(StrPos, 1, Ch);\r\n\r\n Buffer[Start] := Ch;\r\n Inc(Start);\r\n Inc(Result);\r\n Dec(Count);\r\n end;\r\nend;\r\n\r\n// if UNICODE_SILENT_FAILURE is defined, invalid sequences will be replaced by ReplacementCharacter\r\n// otherwise StrPos is set to -1 on return to flag an error (invalid UTF16 sequence)\r\n// StrPos will be incremented by the number of chars that were read\r\n{$IFDEF SUPPORTS_UNICODE_STRING}\r\nfunction UTF16GetNextChar(const S: WideString; var StrPos: SizeInt): UCS4;\r\nvar\r\n StrLength: SizeInt;\r\n Ch: UCS4;\r\nbegin\r\n StrLength := Length(S);\r\n\r\n if (StrPos <= StrLength) and (StrPos > 0) then\r\n begin\r\n Result := UCS4(S[StrPos]);\r\n\r\n case Result of\r\n SurrogateHighStart..SurrogateHighEnd:\r\n begin\r\n // 2 bytes to read\r\n if StrPos < StrLength then\r\n begin\r\n Ch := UCS4(S[StrPos + 1]);\r\n if (Ch >= SurrogateLowStart) and (Ch <= SurrogateLowEnd) then\r\n begin\r\n Result := ((Result - SurrogateHighStart) shl HalfShift) + (Ch - SurrogateLowStart) + HalfBase;\r\n Inc(StrPos, 2);\r\n end\r\n else\r\n FlagInvalidSequence(StrPos, 1, Result);\r\n end\r\n else\r\n FlagInvalidSequence(StrPos, 1, Result);\r\n end;\r\n SurrogateLowStart..SurrogateLowEnd:\r\n FlagInvalidSequence(StrPos, 1, Result);\r\n else\r\n // 1 byte to read\r\n Inc(StrPos);\r\n end;\r\n end\r\n else\r\n begin\r\n // StrPos > StrLength\r\n Result := 0;\r\n FlagInvalidSequence(StrPos, 0, Result);\r\n end;\r\nend;\r\n\r\nfunction UTF16GetNextBuffer(const S: WideString; var StrPos: SizeInt; var Buffer: TUCS4Array; var Start: SizeInt; Count: SizeInt): SizeInt; overload;\r\nvar\r\n StrLength: SizeInt;\r\n Ch, ChNext: UCS4;\r\n ReadSuccess: Boolean;\r\nbegin\r\n StrLength := Length(S);\r\n Result := 0;\r\n ReadSuccess := True;\r\n while (StrPos <= StrLength) and (StrPos > 0) and (Count > 0) do\r\n begin\r\n Ch := UCS4(S[StrPos]);\r\n\r\n case Ch of\r\n SurrogateHighStart..SurrogateHighEnd:\r\n begin\r\n // 2 bytes to read\r\n if StrPos < StrLength then\r\n begin\r\n ChNext := UCS4(S[StrPos + 1]);\r\n if (ChNext >= SurrogateLowStart) and (ChNext <= SurrogateLowEnd) then\r\n begin\r\n Ch := ((Ch - SurrogateHighStart) shl HalfShift) + (ChNext - SurrogateLowStart) + HalfBase;\r\n Inc(StrPos, 2);\r\n end\r\n else\r\n FlagInvalidSequence(StrPos, 1, Ch);\r\n end\r\n else\r\n ReadSuccess := False;\r\n end;\r\n SurrogateLowStart..SurrogateLowEnd:\r\n FlagInvalidSequence(StrPos, 1, Ch);\r\n else\r\n // 1 byte to read\r\n Inc(StrPos);\r\n end;\r\n if not ReadSuccess then\r\n FlagInvalidSequence(StrPos, 1, Ch);\r\n\r\n Buffer[Start] := Ch;\r\n Inc(Start);\r\n Inc(Result);\r\n Dec(Count);\r\n end;\r\nend;\r\n{$ENDIF SUPPORTS_UNICODE_STRING}\r\n\r\nfunction UTF16GetNextCharFromStream(S: TStream; out Ch: UCS4): Boolean;\r\nvar\r\n W: Word;\r\nbegin\r\n Result := StreamReadWord(S, W);\r\n if Result then\r\n begin\r\n Ch := UCS4(W);\r\n\r\n case W of\r\n SurrogateHighStart..SurrogateHighEnd:\r\n begin\r\n // 2 bytes to read\r\n Result := StreamReadWord(S, W);\r\n if Result then\r\n begin\r\n if (W >= SurrogateLowStart) and (W <= SurrogateLowEnd) then\r\n Ch := ((Ch - SurrogateHighStart) shl HalfShift) + (W - SurrogateLowStart) + HalfBase\r\n else\r\n FlagInvalidSequence(Ch);\r\n end;\r\n end;\r\n SurrogateLowStart..SurrogateLowEnd:\r\n FlagInvalidSequence(Ch);\r\n else\r\n // 1 byte to read\r\n // nothing to do\r\n end;\r\n end;\r\nend;\r\n\r\nfunction UTF16GetNextBufferFromStream(S: TStream; var Buffer: TUCS4Array; var Start: SizeInt; Count: SizeInt): SizeInt;\r\nvar\r\n W: Word;\r\n Ch: UCS4;\r\n ReadSuccess: Boolean;\r\nbegin\r\n Result := 0;\r\n ReadSuccess := True;\r\n while ReadSuccess and (Count > 0) do\r\n begin\r\n if StreamReadWord(S, W) then\r\n begin\r\n Ch := UCS4(W);\r\n\r\n case W of\r\n SurrogateHighStart..SurrogateHighEnd:\r\n begin\r\n // 2 bytes to read\r\n if StreamReadWord(S, W) then\r\n begin\r\n if (W >= SurrogateLowStart) and (W <= SurrogateLowEnd) then\r\n Ch := ((Ch - SurrogateHighStart) shl HalfShift) + (W - SurrogateLowStart) + HalfBase\r\n else\r\n FlagInvalidSequence(Ch);\r\n end\r\n else\r\n ReadSuccess := False;\r\n end;\r\n SurrogateLowStart..SurrogateLowEnd:\r\n FlagInvalidSequence(Ch);\r\n else\r\n // 1 byte to read\r\n // nothing to do\r\n end;\r\n if ReadSuccess then\r\n begin\r\n Buffer[Start] := Ch;\r\n Inc(Result);\r\n Inc(Start);\r\n end;\r\n end;\r\n Dec(Count);\r\n end;\r\nend;\r\n\r\n// if UNICODE_SILENT_FAILURE is defined, invalid sequences will be replaced by ReplacementCharacter\r\n// otherwise StrPos is set to -1 on return to flag an error (invalid UTF16 sequence)\r\n// StrPos will be decremented by the number of chars that were read\r\nfunction UTF16GetPreviousChar(const S: TUTF16String; var StrPos: SizeInt): UCS4;\r\nvar\r\n StrLength: SizeInt;\r\n ChPrev: UCS4;\r\nbegin\r\n StrLength := Length(S);\r\n\r\n if (StrPos <= (StrLength + 1)) and (StrPos > 1) then\r\n begin\r\n Result := UCS4(S[StrPos - 1]);\r\n\r\n case Result of\r\n SurrogateHighStart..SurrogateHighEnd:\r\n FlagInvalidSequence(StrPos, -1, Result);\r\n SurrogateLowStart..SurrogateLowEnd:\r\n begin\r\n // 2 bytes to read\r\n if StrPos > 2 then\r\n begin\r\n ChPrev := UCS4(S[StrPos - 2]);\r\n if (ChPrev >= SurrogateHighStart) and (ChPrev <= SurrogateHighEnd) then\r\n begin\r\n Result := ((ChPrev - SurrogateHighStart) shl HalfShift) + (Result - SurrogateLowStart) + HalfBase;\r\n Dec(StrPos, 2);\r\n end\r\n else\r\n FlagInvalidSequence(StrPos, -1, Result);\r\n end\r\n else\r\n FlagInvalidSequence(StrPos, -1, Result);\r\n end;\r\n else\r\n // 1 byte to read\r\n Dec(StrPos);\r\n end;\r\n end\r\n else\r\n begin\r\n // StrPos > StrLength\r\n Result := 0;\r\n FlagInvalidSequence(StrPos, 0, Result);\r\n end;\r\nend;\r\n\r\n// if UNICODE_SILENT_FAILURE is defined, invalid sequences will be replaced by ReplacementCharacter\r\n// otherwise StrPos is set to -1 on return to flag an error (invalid UTF16 sequence)\r\n// StrPos will be decremented by the number of chars that were read\r\n{$IFDEF SUPPORTS_UNICODE_STRING}\r\nfunction UTF16GetPreviousChar(const S: WideString; var StrPos: SizeInt): UCS4;\r\nvar\r\n StrLength: SizeInt;\r\n ChPrev: UCS4;\r\nbegin\r\n StrLength := Length(S);\r\n\r\n if (StrPos <= (StrLength + 1)) and (StrPos > 1) then\r\n begin\r\n Result := UCS4(S[StrPos - 1]);\r\n\r\n case Result of\r\n SurrogateHighStart..SurrogateHighEnd:\r\n FlagInvalidSequence(StrPos, -1, Result);\r\n SurrogateLowStart..SurrogateLowEnd:\r\n begin\r\n // 2 bytes to read\r\n if StrPos > 2 then\r\n begin\r\n ChPrev := UCS4(S[StrPos - 2]);\r\n if (ChPrev >= SurrogateHighStart) and (ChPrev <= SurrogateHighEnd) then\r\n begin\r\n Result := ((ChPrev - SurrogateHighStart) shl HalfShift) + (Result - SurrogateLowStart) + HalfBase;\r\n Dec(StrPos, 2);\r\n end\r\n else\r\n FlagInvalidSequence(StrPos, -1, Result);\r\n end\r\n else\r\n FlagInvalidSequence(StrPos, -1, Result);\r\n end;\r\n else\r\n // 1 byte to read\r\n Dec(StrPos);\r\n end;\r\n end\r\n else\r\n begin\r\n // StrPos > StrLength\r\n Result := 0;\r\n FlagInvalidSequence(StrPos, 0, Result);\r\n end;\r\nend;\r\n{$ENDIF SUPPORTS_UNICODE_STRING}\r\n\r\n// returns False if String is too small\r\n// if UNICODE_SILENT_FAILURE is not defined StrPos is set to -1 on error (invalid UTF16 sequence)\r\n// StrPos will be incremented by the number of chars that were skipped\r\n// On return, NbSeq contains the number of UTF16 sequences that were skipped\r\nfunction UTF16SkipChars(const S: TUTF16String; var StrPos: SizeInt; var NbSeq: SizeInt): Boolean;\r\nvar\r\n StrLength, Index: SizeInt;\r\n Ch: UCS4;\r\nbegin\r\n Result := True;\r\n StrLength := Length(S);\r\n\r\n Index := 0;\r\n if NbSeq >= 0 then\r\n while (Index < NbSeq) and (StrPos > 0) do\r\n begin\r\n Ch := UCS4(S[StrPos]);\r\n\r\n case Ch of\r\n SurrogateHighStart..SurrogateHighEnd:\r\n // 2 bytes to skip\r\n if StrPos >= StrLength then\r\n FlagInvalidSequence(StrPos, 1)\r\n else\r\n begin\r\n Ch := UCS4(S[StrPos + 1]);\r\n if (Ch < SurrogateLowStart) or (Ch > SurrogateLowEnd) then\r\n FlagInvalidSequence(StrPos, 1)\r\n else\r\n Inc(StrPos, 2);\r\n end;\r\n SurrogateLowStart..SurrogateLowEnd:\r\n // error\r\n FlagInvalidSequence(StrPos, 1);\r\n else\r\n // 1 byte to skip\r\n Inc(StrPos);\r\n end;\r\n\r\n if StrPos <> -1 then\r\n Inc(Index);\r\n\r\n if (StrPos > StrLength) and (Index < NbSeq) then\r\n begin\r\n Result := False;\r\n Break;\r\n end;\r\n end\r\n else\r\n while (Index > NbSeq) and (StrPos > 1) do\r\n begin\r\n Ch := UCS4(S[StrPos - 1]);\r\n\r\n case Ch of\r\n SurrogateHighStart..SurrogateHighEnd:\r\n // error\r\n FlagInvalidSequence(StrPos, -1);\r\n SurrogateLowStart..SurrogateLowEnd:\r\n // 2 bytes to skip\r\n if StrPos <= 2 then\r\n FlagInvalidSequence(StrPos, -1)\r\n else\r\n begin\r\n Ch := UCS4(S[StrPos - 2]);\r\n if (Ch < SurrogateHighStart) or (Ch > SurrogateHighEnd) then\r\n FlagInvalidSequence(StrPos, -1)\r\n else\r\n Dec(StrPos, 2);\r\n end;\r\n else\r\n // 1 byte to skip\r\n Dec(StrPos);\r\n end;\r\n\r\n if StrPos <> -1 then\r\n Dec(Index);\r\n\r\n if (StrPos = 1) and (Index > NbSeq) then\r\n begin\r\n Result := False;\r\n Break;\r\n end;\r\n end;\r\n NbSeq := Index;\r\nend;\r\n\r\n// returns False if String is too small\r\n// if UNICODE_SILENT_FAILURE is not defined StrPos is set to -1 on error (invalid UTF16 sequence)\r\n// StrPos will be incremented by the number of chars that were skipped\r\n// On return, NbSeq contains the number of UTF16 sequences that were skipped\r\n{$IFDEF SUPPORTS_UNICODE_STRING}\r\nfunction UTF16SkipChars(const S: WideString; var StrPos: SizeInt; var NbSeq: SizeInt): Boolean;\r\nvar\r\n StrLength, Index: SizeInt;\r\n Ch: UCS4;\r\nbegin\r\n Result := True;\r\n StrLength := Length(S);\r\n\r\n Index := 0;\r\n if NbSeq >= 0 then\r\n while (Index < NbSeq) and (StrPos > 0) do\r\n begin\r\n Ch := UCS4(S[StrPos]);\r\n\r\n case Ch of\r\n SurrogateHighStart..SurrogateHighEnd:\r\n // 2 bytes to skip\r\n if StrPos >= StrLength then\r\n FlagInvalidSequence(StrPos, 1)\r\n else\r\n begin\r\n Ch := UCS4(S[StrPos + 1]);\r\n if (Ch < SurrogateLowStart) or (Ch > SurrogateLowEnd) then\r\n FlagInvalidSequence(StrPos, 1)\r\n else\r\n Inc(StrPos, 2);\r\n end;\r\n SurrogateLowStart..SurrogateLowEnd:\r\n // error\r\n FlagInvalidSequence(StrPos, 1);\r\n else\r\n // 1 byte to skip\r\n Inc(StrPos);\r\n end;\r\n\r\n if StrPos <> -1 then\r\n Inc(Index);\r\n\r\n if (StrPos > StrLength) and (Index < NbSeq) then\r\n begin\r\n Result := False;\r\n Break;\r\n end;\r\n end\r\n else\r\n while (Index > NbSeq) and (StrPos > 1) do\r\n begin\r\n Ch := UCS4(S[StrPos - 1]);\r\n\r\n case Ch of\r\n SurrogateHighStart..SurrogateHighEnd:\r\n // error\r\n FlagInvalidSequence(StrPos, -1);\r\n SurrogateLowStart..SurrogateLowEnd:\r\n // 2 bytes to skip\r\n if StrPos <= 2 then\r\n FlagInvalidSequence(StrPos, -1)\r\n else\r\n begin\r\n Ch := UCS4(S[StrPos - 2]);\r\n if (Ch < SurrogateHighStart) or (Ch > SurrogateHighEnd) then\r\n FlagInvalidSequence(StrPos, -1)\r\n else\r\n Dec(StrPos, 2);\r\n end;\r\n else\r\n // 1 byte to skip\r\n Dec(StrPos);\r\n end;\r\n\r\n if StrPos <> -1 then\r\n Dec(Index);\r\n\r\n if (StrPos = 1) and (Index > NbSeq) then\r\n begin\r\n Result := False;\r\n Break;\r\n end;\r\n end;\r\n NbSeq := Index;\r\nend;\r\n{$ENDIF SUPPORTS_UNICODE_STRING}\r\n\r\nfunction UTF16SkipCharsFromStream(S: TStream; var NbSeq: SizeInt): Boolean;\r\nvar\r\n Index: SizeInt;\r\n W: Word;\r\nbegin\r\n Index := 0;\r\n while Index < NbSeq do\r\n begin\r\n Result := StreamReadWord(S, W);\r\n if not Result then\r\n Break;\r\n case W of\r\n SurrogateHighStart..SurrogateHighEnd:\r\n // 2 bytes to skip\r\n begin\r\n Result := StreamReadWord(S, W);\r\n if not Result then\r\n Break;\r\n if (W < SurrogateLowStart) or (W > SurrogateLowEnd) then\r\n FlagInvalidSequence;\r\n end;\r\n SurrogateLowStart..SurrogateLowEnd:\r\n // error\r\n FlagInvalidSequence;\r\n else\r\n // 1 byte to skip\r\n // nothing to do\r\n end;\r\n Inc(Index);\r\n end;\r\n Result := Index = NbSeq;\r\n NbSeq := Index;\r\nend;\r\n\r\n// returns False on error:\r\n// - if an UCS4 character cannot be stored to an UTF-8 string:\r\n// - if UNICODE_SILENT_FAILURE is defined, ReplacementCharacter is added\r\n// - if UNICODE_SILENT_FAILURE is not defined, StrPos is set to -1\r\n// - StrPos > -1 flags string being too small, caller is responsible for allocating space\r\n// StrPos will be incremented by the number of chars that were written\r\nfunction UTF16SetNextChar(var S: TUTF16String; var StrPos: SizeInt; Ch: UCS4): Boolean;\r\nvar\r\n StrLength: SizeInt;\r\nbegin\r\n StrLength := Length(S);\r\n\r\n if Ch <= MaximumUCS2 then\r\n begin\r\n // 16 bits to store in place\r\n Result := (StrPos > 0) and (StrPos <= StrLength);\r\n if Result then\r\n begin\r\n S[StrPos] := WideChar(Ch);\r\n Inc(StrPos);\r\n end;\r\n end\r\n else\r\n if Ch <= MaximumUTF16 then\r\n begin\r\n // stores a surrogate pair\r\n Result := (StrPos > 0) and (StrPos < StrLength);\r\n if Result then\r\n begin\r\n Ch := Ch - HalfBase;\r\n S[StrPos] := WideChar((Ch shr HalfShift) or SurrogateHighStart);\r\n S[StrPos + 1] := WideChar((Ch and HalfMask) or SurrogateLowStart);\r\n Inc(StrPos, 2);\r\n end;\r\n end\r\n else\r\n begin\r\n {$IFDEF UNICODE_SILENT_FAILURE}\r\n // add ReplacementCharacter\r\n Result := (StrPos > 0) and (StrPos <= StrLength);\r\n if Result then\r\n begin\r\n S[StrPos] := WideChar(UCS4ReplacementCharacter);\r\n Inc(StrPos, 1);\r\n end;\r\n {$ELSE ~UNICODE_SILENT_FAILURE}\r\n StrPos := -1;\r\n Result := False;\r\n {$ENDIF ~UNICODE_SILENT_FAILURE}\r\n end;\r\nend;\r\n\r\nfunction UTF16SetNextBuffer(var S: TUTF16String; var StrPos: SizeInt; const Buffer: TUCS4Array; var Start: SizeInt; Count: SizeInt): SizeInt; overload;\r\nvar\r\n StrLength: SizeInt;\r\n Ch: UCS4;\r\n Success: Boolean;\r\nbegin\r\n StrLength := Length(S);\r\n Result := 0;\r\n Success := True;\r\n while Success and (Count > 0) do\r\n begin\r\n Ch := Buffer[Start];\r\n\r\n if Ch <= MaximumUCS2 then\r\n begin\r\n // 16 bits to store in place\r\n if (StrPos > 0) and (StrPos <= StrLength) then\r\n begin\r\n S[StrPos] := WideChar(Ch);\r\n Inc(StrPos);\r\n end\r\n else\r\n Success := False;\r\n end\r\n else\r\n if Ch <= MaximumUTF16 then\r\n begin\r\n // stores a surrogate pair\r\n if (StrPos > 0) and (StrPos < StrLength) then\r\n begin\r\n Ch := Ch - HalfBase;\r\n S[StrPos] := WideChar((Ch shr HalfShift) or SurrogateHighStart);\r\n S[StrPos + 1] := WideChar((Ch and HalfMask) or SurrogateLowStart);\r\n Inc(StrPos, 2);\r\n end\r\n else\r\n Success := False;\r\n end\r\n else\r\n begin\r\n {$IFDEF UNICODE_SILENT_FAILURE}\r\n // add ReplacementCharacter\r\n if (StrPos > 0) and (StrPos <= StrLength) then\r\n begin\r\n S[StrPos] := WideChar(UCS4ReplacementCharacter);\r\n Inc(StrPos, 1);\r\n end\r\n else\r\n Success := False;\r\n {$ELSE ~UNICODE_SILENT_FAILURE}\r\n StrPos := -1;\r\n Success := False;\r\n {$ENDIF ~UNICODE_SILENT_FAILURE}\r\n end;\r\n if Success then\r\n begin\r\n Inc(Start);\r\n Inc(Result);\r\n end;\r\n Dec(Count);\r\n end;\r\nend;\r\n\r\n{$IFDEF SUPPORTS_UNICODE_STRING}\r\nfunction UTF16SetNextChar(var S: WideString; var StrPos: SizeInt; Ch: UCS4): Boolean;\r\nvar\r\n StrLength: SizeInt;\r\nbegin\r\n StrLength := Length(S);\r\n\r\n if Ch <= MaximumUCS2 then\r\n begin\r\n // 16 bits to store in place\r\n Result := (StrPos > 0) and (StrPos <= StrLength);\r\n if Result then\r\n begin\r\n S[StrPos] := WideChar(Ch);\r\n Inc(StrPos);\r\n end;\r\n end\r\n else\r\n if Ch <= MaximumUTF16 then\r\n begin\r\n // stores a surrogate pair\r\n Result := (StrPos > 0) and (StrPos < StrLength);\r\n if Result then\r\n begin\r\n Ch := Ch - HalfBase;\r\n S[StrPos] := WideChar((Ch shr HalfShift) + SurrogateHighStart);\r\n S[StrPos + 1] := WideChar((Ch and HalfMask) + SurrogateLowStart);\r\n Inc(StrPos, 2);\r\n end;\r\n end\r\n else\r\n begin\r\n {$IFDEF UNICODE_SILENT_FAILURE}\r\n // add ReplacementCharacter\r\n Result := (StrPos > 0) and (StrPos <= StrLength);\r\n if Result then\r\n begin\r\n S[StrPos] := WideChar(UCS4ReplacementCharacter);\r\n Inc(StrPos, 1);\r\n end;\r\n {$ELSE ~UNICODE_SILENT_FAILURE}\r\n StrPos := -1;\r\n Result := False;\r\n {$ENDIF ~UNICODE_SILENT_FAILURE}\r\n end;\r\nend;\r\n\r\nfunction UTF16SetNextBuffer(var S: WideString; var StrPos: SizeInt; const Buffer: TUCS4Array; var Start: SizeInt; Count: SizeInt): SizeInt; overload;\r\nvar\r\n StrLength: SizeInt;\r\n Ch: UCS4;\r\n Success: Boolean;\r\nbegin\r\n StrLength := Length(S);\r\n Result := 0;\r\n Success := True;\r\n while Success and (Count > 0) do\r\n begin\r\n Ch := Buffer[Start];\r\n\r\n if Ch <= MaximumUCS2 then\r\n begin\r\n // 16 bits to store in place\r\n if (StrPos > 0) and (StrPos <= StrLength) then\r\n begin\r\n S[StrPos] := WideChar(Ch);\r\n Inc(StrPos);\r\n end\r\n else\r\n Success := False;\r\n end\r\n else\r\n if Ch <= MaximumUTF16 then\r\n begin\r\n // stores a surrogate pair\r\n if (StrPos > 0) and (StrPos < StrLength) then\r\n begin\r\n Ch := Ch - HalfBase;\r\n S[StrPos] := WideChar((Ch shr HalfShift) or SurrogateHighStart);\r\n S[StrPos + 1] := WideChar((Ch and HalfMask) or SurrogateLowStart);\r\n Inc(StrPos, 2);\r\n end\r\n else\r\n Success := False;\r\n end\r\n else\r\n begin\r\n {$IFDEF UNICODE_SILENT_FAILURE}\r\n // add ReplacementCharacter\r\n if (StrPos > 0) and (StrPos <= StrLength) then\r\n begin\r\n S[StrPos] := WideChar(UCS4ReplacementCharacter);\r\n Inc(StrPos, 1);\r\n end\r\n else\r\n Success := False;\r\n {$ELSE ~UNICODE_SILENT_FAILURE}\r\n StrPos := -1;\r\n Success := False;\r\n {$ENDIF ~UNICODE_SILENT_FAILURE}\r\n end;\r\n if Success then\r\n begin\r\n Inc(Start);\r\n Inc(Result);\r\n end;\r\n Dec(Count);\r\n end;\r\nend;\r\n{$ENDIF SUPPORTS_UNICODE_STRING}\r\n\r\nfunction UTF16SetNextCharToStream(S: TStream; Ch: UCS4): Boolean;\r\nbegin\r\n if Ch <= MaximumUCS2 then\r\n // 16 bits to store in place\r\n Result := StreamWriteWord(S, Ch)\r\n else\r\n if Ch <= MaximumUTF16 then\r\n // stores a surrogate pair\r\n Result := StreamWriteWord(S, (Ch shr HalfShift) or SurrogateHighStart) and\r\n StreamWriteWord(S, (Ch and HalfMask) or SurrogateLowStart)\r\n else\r\n begin\r\n {$IFDEF UNICODE_SILENT_FAILURE}\r\n // add ReplacementCharacter\r\n Result := StreamWriteWord(S, UCS4ReplacementCharacter);\r\n {$ELSE ~UNICODE_SILENT_FAILURE}\r\n Result := False;\r\n {$ENDIF ~UNICODE_SILENT_FAILURE}\r\n end;\r\nend;\r\n\r\nfunction UTF16SetNextBufferToStream(S: TStream; const Buffer: TUCS4Array; var Start: SizeInt; Count: SizeInt): SizeInt;\r\nvar\r\n Ch: UCS4;\r\n Success: Boolean;\r\nbegin\r\n Result := 0;\r\n Success := True;\r\n while Success and (Count > 0) do\r\n begin\r\n Ch := Buffer[Start];\r\n if Ch <= MaximumUCS2 then\r\n // 16 bits to store in place\r\n Success := StreamWriteWord(S, Ch)\r\n else\r\n if Ch <= MaximumUTF16 then\r\n // stores a surrogate pair\r\n Success := StreamWriteWord(S, (Ch shr HalfShift) or SurrogateHighStart) and\r\n StreamWriteWord(S, (Ch and HalfMask) or SurrogateLowStart)\r\n else\r\n begin\r\n {$IFDEF UNICODE_SILENT_FAILURE}\r\n // add ReplacementCharacter\r\n Success := StreamWriteWord(S, UCS4ReplacementCharacter);\r\n {$ELSE ~UNICODE_SILENT_FAILURE}\r\n Success := False;\r\n {$ENDIF ~UNICODE_SILENT_FAILURE}\r\n end;\r\n if Success then\r\n begin\r\n Inc(Start);\r\n Inc(Result);\r\n end;\r\n Dec(Count);\r\n end;\r\nend;\r\n\r\n// AnsiGetNextChar = read next character at StrPos\r\n// StrPos will be incremented by the number of chars that were read (1)\r\nfunction AnsiGetNextChar(const S: AnsiString; var StrPos: SizeInt): UCS4;\r\nvar\r\n StrLen, TmpPos: SizeInt;\r\n UTF16Buffer: TUTF16String;\r\nbegin\r\n StrLen := Length(S);\r\n\r\n if (StrPos <= StrLen) and (StrPos > 0) then\r\n begin\r\n UTF16Buffer := WideString(S[StrPos]);\r\n TmpPos := 1;\r\n Result := UTF16GetNextChar(UTF16Buffer, TmpPos);\r\n if TmpPos = -1 then\r\n StrPos := -1\r\n else\r\n Inc(StrPos);\r\n end\r\n else\r\n begin\r\n // StrPos > StrLength\r\n Result := 0;\r\n FlagInvalidSequence(StrPos, 0, Result);\r\n end;\r\nend;\r\n\r\nfunction AnsiGetNextBuffer(const S: AnsiString; var StrPos: SizeInt; var Buffer: TUCS4Array; var Start: SizeInt; Count: SizeInt): SizeInt; overload;\r\nvar\r\n StrLength, TmpPos: SizeInt;\r\n UTF16Buffer: TUTF16String;\r\nbegin\r\n StrLength := Length(S);\r\n if (StrPos > 0) and (StrPos <= StrLength) then\r\n begin\r\n UTF16Buffer := WideString(Copy(S, StrPos, Count));\r\n TmpPos := 1;\r\n Result := UTF16GetNextBuffer(UTF16Buffer, TmpPos, Buffer, Start, Count);\r\n if TmpPos > 0 then\r\n Inc(StrPos, Result)\r\n else\r\n StrPos := -1;\r\n end\r\n else\r\n Result := 0;\r\nend;\r\n\r\nfunction AnsiGetNextCharFromStream(S: TStream; out Ch: UCS4): Boolean;\r\nvar\r\n B: Byte;\r\n TmpPos: SizeInt;\r\n UTF16Buffer: TUTF16String;\r\nbegin\r\n Result := StreamReadByte(S, B);\r\n if Result then\r\n begin\r\n UTF16Buffer := WideString(AnsiString(Chr(B)));\r\n TmpPos := 1;\r\n Ch := UTF16GetNextChar(UTF16Buffer, TmpPos);\r\n Result := TmpPos <> -1;\r\n end;\r\nend;\r\n\r\nfunction AnsiGetNextBufferFromStream(S: TStream; var Buffer: TUCS4Array; var Start: SizeInt; Count: SizeInt): SizeInt; overload;\r\nvar\r\n B: TDynByteArray;\r\n ReadSuccess: Boolean;\r\n ReadCount, TmpPos: SizeInt;\r\n UTF16Buffer: TUTF16String;\r\nbegin\r\n Result := 0;\r\n ReadSuccess := True;\r\n SetLength(B, Count);\r\n SetLength(UTF16Buffer, 2 * Count);\r\n while ReadSuccess and (Count > 0) do\r\n begin\r\n ReadCount := S.Read(B[0], Count);\r\n if ReadCount > 0 then\r\n begin\r\n ReadCount := MultiByteToWideChar(CP_ACP, MB_PRECOMPOSED or MB_ERR_INVALID_CHARS, @B[0], ReadCount, PWideChar(UTF16Buffer), 2 * Count);\r\n if ReadCount > 0 then\r\n begin\r\n TmpPos := 1;\r\n ReadCount := UTF16GetNextBuffer(UTF16Buffer, TmpPos, Buffer, Start, ReadCount);\r\n if TmpPos <> -1 then\r\n Inc(Result, ReadCount)\r\n else\r\n ReadSuccess := False;\r\n end\r\n else\r\n begin\r\n Result := 0;\r\n FlagInvalidSequence;\r\n end;\r\n end\r\n else\r\n ReadSuccess := False;\r\n Dec(Count, ReadCount);\r\n end;\r\nend;\r\n\r\n// AnsiGetNextChar = read next character at StrPos\r\n// StrPos will be incremented by the number of chars that were read (1)\r\nfunction AnsiGetNextChar(const S: AnsiString; CodePage: Word; var StrPos: SizeInt): UCS4;\r\nvar\r\n StrLen, TmpPos: SizeInt;\r\n UTF16Buffer: TUTF16String;\r\nbegin\r\n StrLen := Length(S);\r\n\r\n if (StrPos <= StrLen) and (StrPos > 0) then\r\n begin\r\n SetLength(UTF16Buffer, 2);\r\n if MultiByteToWideChar(CodePage, MB_PRECOMPOSED or MB_ERR_INVALID_CHARS, @S[StrPos], 1, PWideChar(UTF16Buffer), 2) > 0 then\r\n begin\r\n TmpPos := 1;\r\n Result := UTF16GetNextChar(UTF16Buffer, TmpPos);\r\n if TmpPos > 0 then\r\n Inc(StrPos)\r\n else\r\n StrPos := -1;\r\n end\r\n else\r\n begin\r\n Result := UCS4ReplacementCharacter;\r\n FlagInvalidSequence(StrPos, 1, Result);\r\n end;\r\n end\r\n else\r\n begin\r\n // StrPos > StrLength\r\n Result := 0;\r\n FlagInvalidSequence(StrPos, 0, Result);\r\n end;\r\nend;\r\n\r\nfunction AnsiGetNextBuffer(const S: AnsiString; CodePage: Word; var StrPos: SizeInt; var Buffer: TUCS4Array; var Start: SizeInt; Count: SizeInt): SizeInt; overload;\r\nvar\r\n ReadCount, StrLength, TmpPos: SizeInt;\r\n UTF16Buffer: TUTF16String;\r\nbegin\r\n StrLength := Length(S);\r\n if (StrPos > 0) and (StrPos <= StrLength) then\r\n begin\r\n SetLength(Buffer, 2 * Count);\r\n ReadCount :=MultiByteToWideChar(CodePage, MB_PRECOMPOSED or MB_ERR_INVALID_CHARS, @S[StrPos], Count, PWideChar(UTF16Buffer), 2 * Count);\r\n if ReadCount > 0 then\r\n begin\r\n TmpPos := 1;\r\n Result := UTF16GetNextBuffer(UTF16Buffer, TmpPos, Buffer, Start, ReadCount);\r\n if TmpPos > 0 then\r\n Inc(StrPos, Result)\r\n else\r\n StrPos := -1;\r\n end\r\n else\r\n begin\r\n Result := 0;\r\n FlagInvalidSequence(StrPos, 1);\r\n end;\r\n end\r\n else\r\n Result := 0;\r\nend;\r\n\r\nfunction AnsiGetNextCharFromStream(S: TStream; CodePage: Word; out Ch: UCS4): Boolean;\r\nvar\r\n B: Byte;\r\n TmpPos: SizeInt;\r\n UTF16Buffer: TUTF16String;\r\nbegin\r\n Result := StreamReadByte(S, B);\r\n if Result then\r\n begin\r\n SetLength(UTF16Buffer, 2);\r\n if MultiByteToWideChar(CodePage, MB_PRECOMPOSED or MB_ERR_INVALID_CHARS, @B, 1, PWideChar(UTF16Buffer), 2) <> 0 then\r\n begin\r\n TmpPos := 1;\r\n Ch := UTF16GetNextChar(UTF16Buffer, TmpPos);\r\n Result := TmpPos <> -1;\r\n end\r\n else\r\n begin\r\n Result := False;\r\n Ch := UCS4ReplacementCharacter;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction AnsiGetNextBufferFromStream(S: TStream; CodePage: Word; var Buffer: TUCS4Array; var Start: SizeInt; Count: SizeInt): SizeInt; overload;\r\nvar\r\n B: TDynByteArray;\r\n ReadSuccess: Boolean;\r\n ReadCount, TmpPos: SizeInt;\r\n UTF16Buffer: TUTF16String;\r\nbegin\r\n Result := 0;\r\n ReadSuccess := True;\r\n SetLength(B, Count);\r\n SetLength(UTF16Buffer, 2 * Count);\r\n while ReadSuccess and (Count > 0) do\r\n begin\r\n ReadCount := S.Read(B[0], Count);\r\n if ReadCount > 0 then\r\n begin\r\n ReadCount := MultiByteToWideChar(CodePage, MB_PRECOMPOSED or MB_ERR_INVALID_CHARS, @B[0], ReadCount, PWideChar(UTF16Buffer), 2 * Count);\r\n if ReadCount > 0 then\r\n begin\r\n TmpPos := 1;\r\n ReadCount := UTF16GetNextBuffer(UTF16Buffer, TmpPos, Buffer, Start, ReadCount);\r\n if TmpPos <> -1 then\r\n Inc(Result, ReadCount)\r\n else\r\n ReadSuccess := False;\r\n end\r\n else\r\n begin\r\n Result := 0;\r\n FlagInvalidSequence;\r\n end;\r\n end\r\n else\r\n ReadSuccess := False;\r\n Dec(Count, ReadCount);\r\n end;\r\nend;\r\n\r\n// AnsiSkipChars = skip NbSeq characters starting from StrPos\r\n// returns False if String is too small\r\n// StrPos will be incremented by the number of chars that were skipped\r\n// On return, NbChar contains the number of chars that were skipped\r\nfunction AnsiSkipChars(const S: AnsiString; var StrPos: SizeInt; var NbSeq: SizeInt): Boolean;\r\nvar\r\n StrLen: SizeInt;\r\nbegin\r\n StrLen := Length(S);\r\n\r\n if StrPos > 0 then\r\n begin\r\n if StrPos + NbSeq > StrLen then\r\n begin\r\n NbSeq := StrLen + 1 - StrPos;\r\n StrPos := StrLen + 1;\r\n Result := False;\r\n end\r\n else\r\n begin\r\n // NbSeq := NbSeq;\r\n StrPos := StrLen + NbSeq;\r\n Result := True;\r\n end;\r\n end\r\n else\r\n begin\r\n // previous error\r\n NbSeq := 0;\r\n // StrPos := -1;\r\n Result := False;\r\n end;\r\nend;\r\n\r\nfunction AnsiSkipCharsFromStream(S: TStream; var NbSeq: SizeInt): Boolean;\r\nvar\r\n Index: SizeInt;\r\n B: Byte;\r\nbegin\r\n Index := 0;\r\n while Index < NbSeq do\r\n begin\r\n Result := StreamReadByte(S, B);\r\n if not Result then\r\n Break;\r\n Inc(Index);\r\n end;\r\n Result := Index = NbSeq;\r\n NbSeq := Index;\r\nend;\r\n\r\n// AnsiSetNextChar = append a character at StrPos\r\n// returns False on error:\r\n// - if an UCS4 character cannot be stored to an ansi string:\r\n// - if UNICODE_SILENT_FAILURE is defined, ReplacementCharacter is added\r\n// - if UNICODE_SILENT_FAILURE is not defined, StrPos is set to -1\r\n// - StrPos > -1 flags string being too small, callee did nothing and caller is responsible for allocating space\r\n// StrPos will be incremented by the number of chars that were written (1)\r\nfunction AnsiSetNextChar(var S: AnsiString; var StrPos: SizeInt; Ch: UCS4): Boolean;\r\nvar\r\n StrLen, TmpPos, AnsiStrLen: SizeInt;\r\n UTF16Buffer: TUTF16String;\r\n AnsiBuffer: AnsiString;\r\nbegin\r\n StrLen := Length(S);\r\n Result := (StrPos > 0) and (StrPos <= StrLen);\r\n if Result then\r\n begin\r\n SetLength(UTF16Buffer, 2);\r\n TmpPos := 1;\r\n Result := UTF16SetNextChar(UTF16Buffer, TmpPos, Ch);\r\n if Result and (TmpPos = 2) then\r\n // one wide character\r\n AnsiBuffer := AnsiString(WideString(UTF16Buffer[1]))\r\n else\r\n if Result and (TmpPos = 3) then\r\n // one surrogate pair\r\n AnsiBuffer := AnsiString(UTF16Buffer)\r\n else\r\n begin\r\n // add ReplacementCharacter\r\n AnsiBuffer := AnsiReplacementCharacter;\r\n {$IFDEF UNICODE_SILENT_FAILURE}\r\n Result := True;\r\n {$ELSE}\r\n StrPos := -1;\r\n {$ENDIF UNICODE_SILENT_FAILURE}\r\n end;\r\n AnsiStrLen := Length(AnsiBuffer);\r\n Result := Result and ((StrPos + AnsiStrLen) <= (StrLen + 1));\r\n if Result then\r\n begin\r\n for TmpPos := 1 to AnsiStrLen do\r\n begin\r\n S[StrPos] := AnsiBuffer[TmpPos];\r\n Inc(StrPos);\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction AnsiSetNextBuffer(var S: AnsiString; var StrPos: SizeInt; const Buffer: TUCS4Array; var Start: SizeInt; Count: SizeInt): SizeInt; overload;\r\nvar\r\n AnsiBuffer: AnsiString;\r\n UTF16Buffer: WideString;\r\n StrLen, TmpPos, AnsiStrLen: SizeInt;\r\n Ch: UCS4;\r\n Success: Boolean;\r\nbegin\r\n StrLen:= Length(S);\r\n SetLength(UTF16Buffer, 2);\r\n Result := 0;\r\n Success := True;\r\n while Success and (Count > 0) do\r\n begin\r\n Ch := Buffer[Start];\r\n\r\n TmpPos := 1;\r\n Success := UTF16SetNextChar(UTF16Buffer, TmpPos, Ch);\r\n if Success and (TmpPos = 2) then\r\n // one wide character\r\n AnsiBuffer := AnsiString(WideString(UTF16Buffer[1]))\r\n else\r\n if Success and (TmpPos = 3) then\r\n // one surrogate pair\r\n AnsiBuffer := AnsiString(UTF16Buffer)\r\n else\r\n begin\r\n // add ReplacementCharacter\r\n AnsiBuffer := AnsiReplacementCharacter;\r\n {$IFDEF UNICODE_SILENT_FAILURE}\r\n Success := True;\r\n {$ELSE}\r\n StrPos := -1;\r\n {$ENDIF ~UNICODE_SILENT_FAILURE}\r\n end;\r\n AnsiStrLen := Length(AnsiBuffer);\r\n Success := Success and ((StrPos + AnsiStrLen) <= (StrLen + 1));\r\n if Success then\r\n begin\r\n for TmpPos := 1 to AnsiStrLen do\r\n begin\r\n S[StrPos] := AnsiBuffer[TmpPos];\r\n Inc(StrPos);\r\n end;\r\n end;\r\n if Success then\r\n begin\r\n Inc(Start);\r\n Inc(Result);\r\n end;\r\n Dec(Count);\r\n end;\r\nend;\r\n\r\nfunction AnsiSetNextCharToStream(S: TStream; Ch: UCS4): Boolean;\r\nvar\r\n TmpPos, I: SizeInt;\r\n UTF16Buffer: TUTF16String;\r\n AnsiBuffer: AnsiString;\r\nbegin\r\n SetLength(UTF16Buffer, 2);\r\n TmpPos := 1;\r\n Result := UTF16SetNextChar(UTF16Buffer, TmpPos, Ch);\r\n\r\n if Result and (TmpPos = 2) then\r\n // one wide character\r\n AnsiBuffer := AnsiString(WideString(UTF16Buffer[1]))\r\n else\r\n if Result and (TmpPos = 3) then\r\n // one surrogate pair\r\n AnsiBuffer := AnsiString(UTF16Buffer)\r\n else\r\n begin\r\n // add ReplacementCharacter\r\n AnsiBuffer := AnsiReplacementCharacter;\r\n {$IFDEF UNICODE_SILENT_FAILURE}\r\n Result := True;\r\n {$ENDIF UNICODE_SILENT_FAILURE}\r\n end;\r\n if Result then\r\n for I := 1 to Length(AnsiBuffer) do\r\n Result := Result and StreamWriteByte(S, Ord(AnsiBuffer[I]));\r\nend;\r\n\r\nfunction AnsiSetNextBufferToStream(S: TStream; const Buffer: TUCS4Array; var Start: SizeInt; Count: SizeInt): SizeInt; overload;\r\nvar\r\n TmpPos, I: SizeInt;\r\n UTF16Buffer: TUTF16String;\r\n AnsiBuffer: AnsiString;\r\n Success: Boolean;\r\n Ch: UCS4;\r\nbegin\r\n SetLength(UTF16Buffer, 2);\r\n Result := 0;\r\n Success := True;\r\n while Success and (Count > 0) do\r\n begin\r\n Ch := Buffer[Start];\r\n TmpPos := 1;\r\n Success := UTF16SetNextChar(UTF16Buffer, TmpPos, Ch);\r\n\r\n if Success and (TmpPos = 2) then\r\n // one wide character\r\n AnsiBuffer := AnsiString(WideString(UTF16Buffer[1]))\r\n else\r\n if Success and (TmpPos = 3) then\r\n // one surrogate pair\r\n AnsiBuffer := AnsiString(UTF16Buffer)\r\n else\r\n begin\r\n // add ReplacementCharacter\r\n AnsiBuffer := AnsiReplacementCharacter;\r\n {$IFDEF UNICODE_SILENT_FAILURE}\r\n Success := True;\r\n {$ENDIF UNICODE_SILENT_FAILURE}\r\n end;\r\n if Success then\r\n for I := 1 to Length(AnsiBuffer) do\r\n Success := Success and StreamWriteByte(S, Ord(AnsiBuffer[I]));\r\n if Success then\r\n begin\r\n Inc(Start);\r\n Inc(Result);\r\n end;\r\n Dec(Count);\r\n end;\r\nend;\r\n\r\nfunction AnsiSetNextChar(var S: AnsiString; CodePage: Word; var StrPos: SizeInt; Ch: UCS4): Boolean;\r\nvar\r\n StrLen, TmpPos, AnsiStrLen: SizeInt;\r\n UTF16Buffer: TUTF16String;\r\n AnsiBuffer: AnsiString;\r\nbegin\r\n StrLen := Length(S);\r\n Result := (StrPos > 0) and (StrPos <= StrLen);\r\n if Result then\r\n begin\r\n SetLength(UTF16Buffer, 2);\r\n TmpPos := 1;\r\n Result := UTF16SetNextChar(UTF16Buffer, TmpPos, Ch);\r\n AnsiStrLen := WideCharToMultiByte(CodePage, 0, PWideChar(UTF16Buffer), TmpPos-1, nil, 0, nil, nil);\r\n SetLength(AnsiBuffer, AnsiStrLen);\r\n Result := Result and (WideCharToMultiByte(CodePage, 0, PWideChar(UTF16Buffer), TmpPos-1, @AnsiBuffer[1], AnsiStrLen, nil, nil) > 0);\r\n if not Result then\r\n begin\r\n // add ReplacementCharacter\r\n AnsiBuffer := AnsiReplacementCharacter;\r\n AnsiStrLen := 1;\r\n {$IFDEF UNICODE_SILENT_FAILURE}\r\n Result := True;\r\n {$ELSE}\r\n StrPos := -1;\r\n {$ENDIF ~UNICODE_SILENT_FAILURE}\r\n end;\r\n Result := Result and ((StrPos + AnsiStrLen) <= (StrLen + 1));\r\n if Result then\r\n for TmpPos := 1 to AnsiStrLen do\r\n begin\r\n S[StrPos] := AnsiBuffer[TmpPos];\r\n Inc(StrPos);\r\n end;\r\n end;\r\nend;\r\n\r\nfunction AnsiSetNextBuffer(var S: AnsiString; CodePage: Word; var StrPos: SizeInt; const Buffer: TUCS4Array; var Start: SizeInt; Count: SizeInt): SizeInt; overload;\r\nvar\r\n StrLen, TmpPos, AnsiStrLen: SizeInt;\r\n UTF16Buffer: TUTF16String;\r\n AnsiBuffer: AnsiString;\r\n Ch: UCS4;\r\n Success: Boolean;\r\nbegin\r\n StrLen:= Length(S);\r\n SetLength(UTF16Buffer, 2);\r\n Result := 0;\r\n Success := True;\r\n while Success and (Count > 0) do\r\n begin\r\n Ch := Buffer[Start];\r\n\r\n TmpPos := 1;\r\n Success := UTF16SetNextChar(UTF16Buffer, TmpPos, Ch);\r\n AnsiStrLen := WideCharToMultiByte(CodePage, 0, PWideChar(UTF16Buffer), TmpPos-1, nil, 0, nil, nil);\r\n SetLength(AnsiBuffer, AnsiStrLen);\r\n Success := Success and (WideCharToMultiByte(CodePage, 0, PWideChar(UTF16Buffer), TmpPos-1, @AnsiBuffer[1], AnsiStrLen, nil, nil) > 0);\r\n if not Success then\r\n begin\r\n // add ReplacementCharacter\r\n AnsiBuffer := AnsiReplacementCharacter;\r\n AnsiStrLen := 1;\r\n {$IFDEF UNICODE_SILENT_FAILURE}\r\n Success := True;\r\n {$ELSE}\r\n StrPos := -1;\r\n {$ENDIF UNICODE_SILENT_FAILURE}\r\n end;\r\n Success := Success and ((StrPos + AnsiStrLen) <= (StrLen + 1));\r\n if Success then\r\n for TmpPos := 1 to AnsiStrLen do\r\n begin\r\n S[StrPos] := AnsiBuffer[TmpPos];\r\n Inc(StrPos);\r\n end;\r\n if Success then\r\n begin\r\n Inc(Start);\r\n Inc(Result);\r\n end;\r\n Dec(Count);\r\n end;\r\nend;\r\n\r\nfunction AnsiSetNextCharToStream(S: TStream; CodePage: Word; Ch: UCS4): Boolean;\r\nvar\r\n TmpPos, AnsiStrLen: SizeInt;\r\n UTF16Buffer: TUTF16String;\r\n AnsiBuffer: AnsiString;\r\nbegin\r\n SetLength(UTF16Buffer, 2);\r\n TmpPos := 1;\r\n Result := UTF16SetNextChar(UTF16Buffer, TmpPos, Ch);\r\n AnsiStrLen := WideCharToMultiByte(CodePage, 0, PWideChar(UTF16Buffer), TmpPos-1, nil, 0, nil, nil);\r\n SetLength(AnsiBuffer, AnsiStrLen);\r\n Result := Result and (WideCharToMultiByte(CodePage, 0, PWideChar(UTF16Buffer), TmpPos-1, @AnsiBuffer[1], AnsiStrLen, nil, nil) > 0);\r\n if not Result then\r\n begin\r\n // add ReplacementCharacter\r\n AnsiBuffer := AnsiReplacementCharacter;\r\n AnsiStrLen := 1;\r\n {$IFDEF UNICODE_SILENT_FAILURE}\r\n Result := True;\r\n {$ENDIF UNICODE_SILENT_FAILURE}\r\n end;\r\n if Result then\r\n for TmpPos := 1 to AnsiStrLen do\r\n Result := Result and StreamWriteByte(S, Ord(AnsiBuffer[TmpPos]));\r\nend;\r\n\r\nfunction AnsiSetNextBufferToStream(S: TStream; CodePage: Word; const Buffer: TUCS4Array; var Start: SizeInt; Count: SizeInt): SizeInt; overload;\r\nvar\r\n TmpPos, AnsiStrLen: SizeInt;\r\n UTF16Buffer: TUTF16String;\r\n AnsiBuffer: AnsiString;\r\n Success: Boolean;\r\n Ch: UCS4;\r\nbegin\r\n SetLength(UTF16Buffer, 2);\r\n Result := 0;\r\n Success := True;\r\n while Success and (Count > 0) do\r\n begin\r\n Ch := Buffer[Start];\r\n TmpPos := 1;\r\n Success := UTF16SetNextChar(UTF16Buffer, TmpPos, Ch);\r\n AnsiStrLen := WideCharToMultiByte(CodePage, 0, PWideChar(UTF16Buffer), TmpPos-1, nil, 0, nil, nil);\r\n SetLength(AnsiBuffer, AnsiStrLen);\r\n Success := Success and (WideCharToMultiByte(CodePage, 0, PWideChar(UTF16Buffer), TmpPos-1, @AnsiBuffer[1], AnsiStrLen, nil, nil) > 0);\r\n if not Success then\r\n begin\r\n // add ReplacementCharacter\r\n AnsiBuffer := AnsiReplacementCharacter;\r\n AnsiStrLen := 1;\r\n {$IFDEF UNICODE_SILENT_FAILURE}\r\n Success := True;\r\n {$ENDIF UNICODE_SILENT_FAILURE}\r\n end;\r\n if Success then\r\n for TmpPos := 1 to AnsiStrLen do\r\n Success := Success and StreamWriteByte(S, Ord(AnsiBuffer[TmpPos]));\r\n if Success then\r\n begin\r\n Inc(Start);\r\n Inc(Result);\r\n end;\r\n Dec(Count);\r\n end;\r\nend;\r\n\r\n// StringGetNextChar = read next character/sequence at StrPos\r\n// if UNICODE_SILENT_FAILURE is defined, invalid sequences will be replaced by ReplacementCharacter\r\n// otherwise StrPos is set to -1 on return to flag an error (invalid UTF16 sequence for WideString)\r\n// StrPos will be incremented by the number of chars that were read\r\nfunction StringGetNextChar(const S: string; var StrPos: SizeInt): UCS4;\r\nbegin\r\n {$IFDEF SUPPORTS_UNICODE}\r\n Result := UTF16GetNextChar(S, StrPos);\r\n {$ELSE ~SUPPORTS_UNICODE}\r\n Result := AnsiGetNextChar(S, StrPos);\r\n {$ENDIF ~SUPPORTS_UNICODE}\r\nend;\r\n\r\nfunction StringGetNextBuffer(const S: string; var StrPos: SizeInt; var Buffer: TUCS4Array; var Start: SizeInt; Count: SizeInt): SizeInt;\r\nbegin\r\n {$IFDEF SUPPORTS_UNICODE}\r\n Result := UTF16GetNextBuffer(S, StrPos, Buffer, Start, Count);\r\n {$ELSE ~SUPPORTS_UNICODE}\r\n Result := AnsiGetNextBuffer(S, StrPos, Buffer, Start, Count);\r\n {$ENDIF ~SUPPORTS_UNICODE}\r\nend;\r\n\r\n// StringSkipChars = skip NbSeq characters/sequences starting from StrPos\r\n// returns False if String is too small\r\n// if UNICODE_SILENT_FAILURE is not defined StrPos is set to -1 on error (invalid UTF16 sequence for WideString)\r\n// StrPos will be incremented by the number of chars that were skipped\r\n// On return, NbChar contains the number of UTF16 sequences that were skipped\r\nfunction StringSkipChars(const S: string; var StrPos: SizeInt; var NbSeq: SizeInt): Boolean;\r\nbegin\r\n {$IFDEF SUPPORTS_UNICODE}\r\n Result := UTF16SkipChars(S, StrPos, NbSeq);\r\n {$ELSE ~SUPPORTS_UNICODE}\r\n Result := AnsiSkipChars(S, StrPos, NbSeq);\r\n {$ENDIF ~SUPPORTS_UNICODE}\r\nend;\r\n\r\n// StringSetNextChar = append a character/sequence at StrPos\r\n// returns False on error:\r\n// - if an UCS4 character cannot be stored to a string:\r\n// - if UNICODE_SILENT_FAILURE is defined, ReplacementCharacter is added\r\n// - if UNICODE_SILENT_FAILURE is not defined, StrPos is set to -1\r\n// - StrPos > -1 flags string being too small, callee did nothing and caller is responsible for allocating space\r\n// StrPos will be incremented by the number of chars that were written\r\nfunction StringSetNextChar(var S: string; var StrPos: SizeInt; Ch: UCS4): Boolean;\r\nbegin\r\n {$IFDEF SUPPORTS_UNICODE}\r\n Result := UTF16SetNextChar(S, StrPos, Ch);\r\n {$ELSE ~SUPPORTS_UNICODE}\r\n Result := AnsiSetNextChar(S, StrPos, Ch);\r\n {$ENDIF ~SUPPORTS_UNICODE}\r\nend;\r\n\r\nfunction StringSetNextBuffer(var S: string; var StrPos: SizeInt; const Buffer: TUCS4Array; var Start: SizeInt; Count: SizeInt): SizeInt;\r\nbegin\r\n {$IFDEF SUPPORTS_UNICODE}\r\n Result := UTF16SetNextBuffer(S, StrPos, Buffer, Start, Count);\r\n {$ELSE ~SUPPORTS_UNICODE}\r\n Result := AnsiSetNextBuffer(S, StrPos, Buffer, Start, Count);\r\n {$ENDIF ~SUPPORTS_UNICODE}\r\nend;\r\n\r\nfunction WideStringToUTF8(const S: WideString): TUTF8String;\r\nbegin\r\n Result := UTF16ToUTF8(S);\r\nend;\r\n\r\nfunction UTF8ToWideString(const S: TUTF8String): WideString;\r\nbegin\r\n Result := UTF8ToUTF16(S);\r\nend;\r\n\r\nfunction WideStringToUCS4(const S: WideString): TUCS4Array;\r\nbegin\r\n Result := UTF16ToUCS4(S);\r\nend;\r\n\r\nfunction UCS4ToWideString(const S: TUCS4Array): WideString;\r\nbegin\r\n Result := UCS4ToUTF16(S);\r\nend;\r\n\r\nfunction AnsiStringToUTF8(const S: AnsiString): TUTF8String;\r\nvar\r\n WS: TUTF16String;\r\nbegin\r\n WS := TUTF16String(S);\r\n Result := UTF16ToUTF8(WS);\r\nend;\r\n\r\nfunction UTF8ToAnsiString(const S: TUTF8String): AnsiString;\r\nvar\r\n WS: TUTF16String;\r\nbegin\r\n WS := UTF8ToUTF16(S);\r\n Result := AnsiString(WS);\r\nend;\r\n\r\nfunction AnsiStringToUTF16(const S: AnsiString): TUTF16String;\r\nbegin\r\n Result := TUTF16String(S);\r\nend;\r\n\r\nfunction UTF16ToAnsiString(const S: TUTF16String): AnsiString;\r\nbegin\r\n Result := AnsiString(S);\r\nend;\r\n\r\nfunction AnsiStringToUCS4(const S: AnsiString): TUCS4Array;\r\nvar\r\n WS: TUTF16String;\r\nbegin\r\n WS := TUTF16String(S);\r\n Result := UTF16ToUCS4(WS);\r\nend;\r\n\r\nfunction UCS4ToAnsiString(const S: TUCS4Array): AnsiString;\r\nvar\r\n WS: TUTF16String;\r\nbegin\r\n WS := UCS4ToUTF16(S);\r\n Result := AnsiString(WS);\r\nend;\r\n\r\nfunction StringToUTF8(const S: string): TUTF8String;\r\nvar\r\n WS: TUTF16String;\r\nbegin\r\n WS := TUTF16String(S);\r\n Result := UTF16ToUTF8(WS);\r\nend;\r\n\r\nfunction TryStringToUTF8(const S: string; out D: TUTF8String): Boolean;\r\nvar\r\n WS: TUTF16String;\r\nbegin\r\n WS := TUTF16String(S);\r\n Result := TryUTF16ToUTF8(WS, D);\r\nend;\r\n\r\nfunction UTF8ToString(const S: TUTF8String): string;\r\nvar\r\n WS: TUTF16String;\r\nbegin\r\n WS := UTF8ToUTF16(S);\r\n Result := string(WS);\r\nend;\r\n\r\nfunction TryUTF8ToString(const S: TUTF8String; out D: string): Boolean;\r\nvar\r\n WS: TUTF16String;\r\nbegin\r\n Result := TryUTF8ToUTF16(S, WS);\r\n D := string(WS);\r\nend;\r\n\r\nfunction StringToUTF16(const S: string): TUTF16String;\r\nbegin\r\n Result := TUTF16String(S);\r\nend;\r\n\r\nfunction TryStringToUTF16(const S: string; out D: TUTF16String): Boolean;\r\nbegin\r\n D := TUTF16String(S);\r\n Result := True;\r\nend;\r\n\r\nfunction UTF16ToString(const S: TUTF16String): string;\r\nbegin\r\n Result := string(S);\r\nend;\r\n\r\nfunction TryUTF16ToString(const S: TUTF16String; out D: string): Boolean;\r\nbegin\r\n D := string(S);\r\n Result := True;\r\nend;\r\n\r\nfunction StringToUCS4(const S: string): TUCS4Array;\r\nvar\r\n WS: TUTF16String;\r\nbegin\r\n WS := TUTF16String(S);\r\n Result := UTF16ToUCS4(WS);\r\nend;\r\n\r\nfunction TryStringToUCS4(const S: string; out D: TUCS4Array): Boolean;\r\nvar\r\n WS: TUTF16String;\r\nbegin\r\n WS := TUTF16String(S);\r\n Result := TryUTF16ToUCS4(WS, D);\r\nend;\r\n\r\nfunction UCS4ToString(const S: TUCS4Array): string;\r\nvar\r\n WS: WideString;\r\nbegin\r\n WS := UCS4ToUTF16(S);\r\n Result := string(WS);\r\nend;\r\n\r\nfunction TryUCS4ToString(const S: TUCS4Array; out D: string): Boolean;\r\nvar\r\n WS: TUTF16String;\r\nbegin\r\n Result := TryUCS4ToUTF16(S, WS);\r\n D := string(WS);\r\nend;\r\n\r\nfunction UTF8ToUTF16(const S: TUTF8String): TUTF16String;\r\nvar\r\n SrcIndex, SrcLength, DestIndex: SizeInt;\r\n Ch: UCS4;\r\nbegin\r\n if S = '' then\r\n Result := ''\r\n else\r\n begin\r\n SrcLength := Length(S);\r\n SetLength(Result, SrcLength); // create enough room\r\n\r\n SrcIndex := 1;\r\n DestIndex := 1;\r\n while SrcIndex <= SrcLength do\r\n begin\r\n Ch := UTF8GetNextChar(S, SrcIndex);\r\n if SrcIndex = -1 then\r\n raise EJclUnexpectedEOSequenceError.Create;\r\n\r\n UTF16SetNextChar(Result, DestIndex, Ch);\r\n end;\r\n SetLength(Result, DestIndex - 1); // now fix up length\r\n end;\r\nend;\r\n\r\nfunction TryUTF8ToUTF16(const S: TUTF8String; out D: TUTF16String): Boolean;\r\nvar\r\n SrcIndex, SrcLength, DestIndex: SizeInt;\r\n Ch: UCS4;\r\nbegin\r\n Result := True;\r\n if S = '' then\r\n D := ''\r\n else\r\n begin\r\n SrcLength := Length(S);\r\n SetLength(D, SrcLength); // create enough room\r\n\r\n SrcIndex := 1;\r\n DestIndex := 1;\r\n while (SrcIndex > 0) and (SrcIndex <= SrcLength) do\r\n begin\r\n Ch := UTF8GetNextChar(S, SrcIndex);\r\n if SrcIndex > 0 then\r\n UTF16SetNextChar(D, DestIndex, Ch)\r\n else\r\n Result := False;\r\n end;\r\n if Result then\r\n SetLength(D, DestIndex - 1) // now fix up length\r\n else\r\n D := '';\r\n end;\r\nend;\r\n\r\nfunction UTF16ToUTF8(const S: TUTF16String): TUTF8String;\r\nvar\r\n SrcIndex, SrcLength, DestIndex: SizeInt;\r\n Ch: UCS4;\r\nbegin\r\n if S = '' then\r\n Result := ''\r\n else\r\n begin\r\n SrcLength := Length(S);\r\n SetLength(Result, SrcLength * 3); // worste case\r\n\r\n SrcIndex := 1;\r\n DestIndex := 1;\r\n while SrcIndex <= SrcLength do\r\n begin\r\n Ch := UTF16GetNextChar(S, SrcIndex);\r\n if SrcIndex = -1 then\r\n raise EJclUnexpectedEOSequenceError.Create;\r\n\r\n UTF8SetNextChar(Result, DestIndex, Ch);\r\n end;\r\n SetLength(Result, DestIndex - 1); // now fix up length\r\n end;\r\nend;\r\n\r\nfunction TryUTF16ToUTF8(const S: TUTF16String; out D: TUTF8String): Boolean;\r\nvar\r\n SrcIndex, SrcLength, DestIndex: SizeInt;\r\n Ch: UCS4;\r\nbegin\r\n Result := True;\r\n if S = '' then\r\n D := ''\r\n else\r\n begin\r\n SrcLength := Length(S);\r\n SetLength(D, SrcLength * 3); // worste case\r\n\r\n SrcIndex := 1;\r\n DestIndex := 1;\r\n while (SrcIndex > 0) and (SrcIndex <= SrcLength) do\r\n begin\r\n Ch := UTF16GetNextChar(S, SrcIndex);\r\n if SrcIndex > 0 then\r\n UTF8SetNextChar(D, DestIndex, Ch)\r\n else\r\n Result := False;\r\n end;\r\n if Result then\r\n SetLength(D, DestIndex - 1) // now fix up length\r\n else\r\n D := '';\r\n end;\r\nend;\r\n\r\nfunction UTF8ToUCS4(const S: TUTF8String): TUCS4Array;\r\nvar\r\n SrcIndex, SrcLength, DestIndex: SizeInt;\r\n Ch: UCS4;\r\nbegin\r\n if S <> '' then\r\n begin\r\n SrcLength := Length(S);\r\n SetLength(Result, SrcLength); // create enough room\r\n\r\n SrcIndex := 1;\r\n DestIndex := 0;\r\n while SrcIndex <= SrcLength do\r\n begin\r\n Ch := UTF8GetNextChar(S, SrcIndex);\r\n if SrcIndex = -1 then\r\n raise EJclUnexpectedEOSequenceError.Create;\r\n\r\n Result[DestIndex] := Ch;\r\n Inc(DestIndex);\r\n end;\r\n SetLength(Result, DestIndex); // now fix up length\r\n end;\r\nend;\r\n\r\nfunction TryUTF8ToUCS4(const S: TUTF8String; out D: TUCS4Array): Boolean;\r\nvar\r\n SrcIndex, SrcLength, DestIndex: SizeInt;\r\n Ch: UCS4;\r\nbegin\r\n Result := True;\r\n if S <> '' then\r\n begin\r\n SrcLength := Length(S);\r\n SetLength(D, SrcLength); // create enough room\r\n\r\n SrcIndex := 1;\r\n DestIndex := 0;\r\n while (SrcIndex > 0) and (SrcIndex <= SrcLength) do\r\n begin\r\n Ch := UTF8GetNextChar(S, SrcIndex);\r\n if SrcIndex > 0 then\r\n begin\r\n D[DestIndex] := Ch;\r\n Inc(DestIndex);\r\n end\r\n else\r\n Result := False;\r\n end;\r\n if Result then\r\n SetLength(D, DestIndex) // now fix up length\r\n else\r\n SetLength(D, 0);\r\n end;\r\nend;\r\n\r\nfunction UCS4ToUTF8(const S: TUCS4Array): TUTF8String;\r\nvar\r\n SrcIndex, SrcLength, DestIndex: SizeInt;\r\nbegin\r\n SrcLength := Length(S);\r\n if Length(S) = 0 then\r\n Result := ''\r\n else\r\n begin\r\n SetLength(Result, SrcLength * 3); // assume worst case\r\n DestIndex := 1;\r\n\r\n for SrcIndex := 0 to SrcLength - 1 do\r\n begin\r\n UTF8SetNextChar(Result, DestIndex, S[SrcIndex]);\r\n if DestIndex = -1 then\r\n raise EJclUnexpectedEOSequenceError.Create;\r\n end;\r\n\r\n SetLength(Result, DestIndex - 1); // set to actual length\r\n end;\r\nend;\r\n\r\nfunction TryUCS4ToUTF8(const S: TUCS4Array; out D: TUTF8String): Boolean;\r\nvar\r\n SrcIndex, SrcLength, DestIndex: SizeInt;\r\nbegin\r\n SrcLength := Length(S);\r\n Result := True;\r\n if Length(S) = 0 then\r\n D := ''\r\n else\r\n begin\r\n SetLength(D, SrcLength * 3); // assume worst case\r\n DestIndex := 1;\r\n\r\n for SrcIndex := 0 to SrcLength - 1 do\r\n begin\r\n UTF8SetNextChar(D, DestIndex, S[SrcIndex]);\r\n if DestIndex = -1 then\r\n begin\r\n Result := False;\r\n Break;\r\n end;\r\n end;\r\n if Result then\r\n SetLength(D, DestIndex - 1) // set to actual length\r\n else\r\n D := '';\r\n end;\r\nend;\r\n\r\nfunction UTF16ToUCS4(const S: TUTF16String): TUCS4Array;\r\nvar\r\n SrcIndex, SrcLength, DestIndex: SizeInt;\r\n Ch: UCS4;\r\nbegin\r\n if S <> '' then\r\n begin\r\n SrcLength := Length(S);\r\n SetLength(Result, SrcLength); // create enough room\r\n\r\n SrcIndex := 1;\r\n DestIndex := 0;\r\n while SrcIndex <= SrcLength do\r\n begin\r\n Ch := UTF16GetNextChar(S, SrcIndex);\r\n if SrcIndex = -1 then\r\n raise EJclUnexpectedEOSequenceError.Create;\r\n\r\n Result[DestIndex] := Ch;\r\n Inc(DestIndex);\r\n end;\r\n SetLength(Result, DestIndex); // now fix up length\r\n end;\r\nend;\r\n\r\nfunction TryUTF16ToUCS4(const S: TUTF16String; out D: TUCS4Array): Boolean;\r\nvar\r\n SrcIndex, SrcLength, DestIndex: SizeInt;\r\n Ch: UCS4;\r\nbegin\r\n Result := True;\r\n if S <> '' then\r\n begin\r\n SrcLength := Length(S);\r\n SetLength(D, SrcLength); // create enough room\r\n\r\n SrcIndex := 1;\r\n DestIndex := 0;\r\n while (SrcIndex > 0) and (SrcIndex <= SrcLength) do\r\n begin\r\n Ch := UTF16GetNextChar(S, SrcIndex);\r\n if SrcIndex > 0 then\r\n begin\r\n D[DestIndex] := Ch;\r\n Inc(DestIndex);\r\n end\r\n else\r\n Result := False;\r\n end;\r\n if Result then\r\n SetLength(D, DestIndex) // now fix up length\r\n else\r\n SetLength(D, 0);\r\n end;\r\nend;\r\n\r\nfunction UCS4ToUTF16(const S: TUCS4Array): TUTF16String;\r\nvar\r\n SrcIndex, SrcLength, DestIndex: SizeInt;\r\nbegin\r\n SrcLength := Length(S);\r\n if SrcLength = 0 then\r\n Result := ''\r\n else\r\n begin\r\n SetLength(Result, SrcLength * 3); // assume worst case\r\n DestIndex := 1;\r\n\r\n for SrcIndex := 0 to SrcLength - 1 do\r\n begin\r\n UTF16SetNextChar(Result, DestIndex, S[SrcIndex]);\r\n if DestIndex = -1 then\r\n raise EJclUnexpectedEOSequenceError.Create;\r\n end;\r\n\r\n SetLength(Result, DestIndex - 1); // set to actual length\r\n end;\r\nend;\r\n\r\nfunction TryUCS4ToUTF16(const S: TUCS4Array; out D:TUTF16String): Boolean;\r\nvar\r\n SrcIndex, SrcLength, DestIndex: SizeInt;\r\nbegin\r\n SrcLength := Length(S);\r\n Result := True;\r\n if SrcLength = 0 then\r\n D := ''\r\n else\r\n begin\r\n SetLength(D, SrcLength * 3); // assume worst case\r\n DestIndex := 1;\r\n\r\n for SrcIndex := 0 to SrcLength - 1 do\r\n begin\r\n UTF16SetNextChar(D, DestIndex, S[SrcIndex]);\r\n if DestIndex = -1 then\r\n begin\r\n Result := False;\r\n Break;\r\n end;\r\n end;\r\n\r\n if Result then\r\n SetLength(D, DestIndex - 1) // set to actual length\r\n else\r\n D := '';\r\n end;\r\nend;\r\n\r\nfunction UTF8CharCount(const S: TUTF8String): SizeInt;\r\nvar\r\n StrPos: SizeInt;\r\nbegin\r\n StrPos := 1;\r\n Result := Length(S);\r\n UTF8SkipChars(S, StrPos, Result);\r\n if StrPos = -1 then\r\n raise EJclUnexpectedEOSequenceError.Create;\r\nend;\r\n\r\nfunction UTF16CharCount(const S: TUTF16String): SizeInt;\r\nvar\r\n StrPos: SizeInt;\r\nbegin\r\n StrPos := 1;\r\n Result := Length(S);\r\n UTF16SkipChars(S, StrPos, Result);\r\n if StrPos = -1 then\r\n raise EJclUnexpectedEOSequenceError.Create;\r\nend;\r\n\r\nfunction UCS2CharCount(const S: TUCS2String): SizeInt;\r\nbegin\r\n Result := Length(S);\r\nend;\r\n\r\nfunction UCS4CharCount(const S: TUCS4Array): SizeInt;\r\nbegin\r\n Result := Length(S);\r\nend;\r\n\r\nfunction GetUCS4CharAt(const UTF8Str: TUTF8String; Index: SizeInt; out Value: UCS4): Boolean; overload;\r\nvar\r\n StrPos: SizeInt;\r\nbegin\r\n StrPos := 1;\r\n Result := Index >= 0;\r\n if Result then\r\n Result := UTF8SkipChars(UTF8Str, StrPos, Index);\r\n if StrPos = -1 then\r\n raise EJclUnexpectedEOSequenceError.Create;\r\n Result := Result and (StrPos <= Length(UTF8Str));\r\n if Result then\r\n begin\r\n Value := UTF8GetNextChar(UTF8Str, StrPos);\r\n if StrPos = -1 then\r\n raise EJclUnexpectedEOSequenceError.Create;\r\n end;\r\nend;\r\n\r\nfunction GetUCS4CharAt(const WideStr: TUTF16String; Index: SizeInt; out Value: UCS4; IsUTF16: Boolean): Boolean; overload;\r\nvar\r\n StrPos: SizeInt;\r\nbegin\r\n if IsUTF16 then\r\n begin\r\n StrPos := 1;\r\n Result := Index >= 0;\r\n if Result then\r\n Result := UTF16SkipChars(WideStr, StrPos, Index);\r\n if StrPos = -1 then\r\n raise EJclUnexpectedEOSequenceError.Create;\r\n Result := Result and (StrPos <= Length(WideStr));\r\n if Result then\r\n begin\r\n Value := UTF16GetNextChar(WideStr, StrPos);\r\n if StrPos = -1 then\r\n raise EJclUnexpectedEOSequenceError.Create;\r\n end;\r\n end\r\n else\r\n begin\r\n Result := (Index >= 1) and (Index <= Length(WideStr));\r\n Value := UCS4(WideStr[Index]);\r\n end;\r\nend;\r\n\r\nfunction GetUCS4CharAt(const UCS4Str: TUCS4Array; Index: SizeInt; out Value: UCS4): Boolean; overload;\r\nbegin\r\n Result := (Index >= 0) and (Index < Length(UCS4Str));\r\n if Result then\r\n Value := UCS4Str[Index];\r\nend;\r\n\r\nfunction UCS4ToAnsiChar(Value: UCS4): AnsiChar;\r\nvar\r\n Buf: WideString;\r\n StrPos: SizeInt;\r\nbegin\r\n StrPos := 1;\r\n Buf := #0#0;\r\n if UTF16SetNextChar(Buf, StrPos, Value) then\r\n Result := AnsiString(Buf)[1]\r\n else\r\n Result := AnsiReplacementCharacter;\r\nend;\r\n\r\nfunction UCS4ToWideChar(Value: UCS4): WideChar;\r\nbegin\r\n if Value <= MaximumUCS2 then\r\n Result := WideChar(Value)\r\n else\r\n Result := WideChar(UCS4ReplacementCharacter);\r\nend;\r\n\r\nfunction UCS4ToChar(Value: UCS4): Char;\r\nbegin\r\n {$IFDEF SUPPORTS_UNICODE}\r\n Result := UCS4ToWideChar(Value);\r\n {$ELSE ~SUPPORTS_UNICODE}\r\n Result := UCS4ToAnsiChar(Value);\r\n {$ENDIF ~SUPPORTS_UNICODE}\r\nend;\r\n\r\nfunction AnsiCharToUCS4(Value: AnsiChar): UCS4;\r\nvar\r\n Buf: WideString;\r\n StrPos: SizeInt;\r\nbegin\r\n StrPos := 1;\r\n Buf := WideString(AnsiString(Value));\r\n Result := UTF16GetNextChar(Buf, StrPos);\r\nend;\r\n\r\nfunction WideCharToUCS4(Value: WideChar): UCS4;\r\nbegin\r\n Result := UCS4(Value);\r\nend;\r\n\r\nfunction CharToUCS4(Value: Char): UCS4;\r\nbegin\r\n {$IFDEF SUPPORTS_UNICODE}\r\n Result := WideCharToUCS4(Value);\r\n {$ELSE ~SUPPORTS_UNICODE}\r\n Result := AnsiCharToUCS4(Value);\r\n {$ENDIF ~SUPPORTS_UNICODE}\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jcl/source/common/JclStringLists.pas", "content": "{**************************************************************************************************}\r\n{ }\r\n{ Project JEDI Code Library (JCL) }\r\n{ }\r\n{ The contents of this file are subject to the Mozilla Public License Version 1.1 (the \"License\"); }\r\n{ you may not use this file except in compliance with the License. You may obtain a copy of the }\r\n{ License at http://www.mozilla.org/MPL/ }\r\n{ }\r\n{ Software distributed under the License is distributed on an \"AS IS\" basis, WITHOUT WARRANTY OF }\r\n{ ANY KIND, either express or implied. See the License for the specific language governing rights }\r\n{ and limitations under the License. }\r\n{ }\r\n{ The Original Code is NewStringListUnit.pas. }\r\n{ }\r\n{ The Initial Developer of the Original Code is Romullo Sousa. }\r\n{ Portions created by Romullo Sousa are Copyright (C) Romullo Sousa. All rights reserved. }\r\n{ }\r\n{ Contributor(s): }\r\n{ Romullo Sousa (romullobr) }\r\n{ Leo Simas (Leh_U) }\r\n{ }\r\n{**************************************************************************************************}\r\n{ }\r\n{ This unit contains several improvements of the standard TStringList. }\r\n{ }\r\n{**************************************************************************************************}\r\n{ }\r\n{ Last modified: $Date:: 2012-09-03 00:25:26 +0200 (lun. 03 sept. 2012) $ }\r\n{ Revision: $Rev:: 3855 $ }\r\n{ Author: $Author:: outchy $ }\r\n{ }\r\n{**************************************************************************************************}\r\n\r\nunit JclStringLists;\r\n\r\n{$I jcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n {$IFDEF HAS_UNITSCOPE}\r\n {$IFDEF MSWINDOWS}\r\n Winapi.Windows,\r\n {$ENDIF MSWINDOWS}\r\n System.Variants,\r\n System.Classes, System.SysUtils,\r\n {$ELSE ~HAS_UNITSCOPE}\r\n {$IFDEF MSWINDOWS}\r\n Windows,\r\n {$ENDIF MSWINDOWS}\r\n Variants,\r\n Classes, SysUtils,\r\n {$ENDIF ~HAS_UNITSCOPE}\r\n JclBase,\r\n JclPCRE;\r\n\r\n{$DEFINE HAS_TSTRINGS_COMPARESTRINGS}\r\n{$IFDEF FPC}\r\n {$UNDEF HAS_TSTRINGS_COMPARESTRINGS}\r\n{$ENDIF FPC}\r\n\r\ntype\r\n EJclStringListError = class(EJclError);\r\n\r\n IJclStringList = interface;\r\n\r\n TJclStringListObjectsMode = (omNone, omObjects, omVariants, omInterfaces);\r\n\r\n TJclStringListSortCompare = function(List: IJclStringList; Index1, Index2: Integer): Integer;\r\n\r\n IJclStringList = interface(IInterface)\r\n ['{8DC5B71C-4756-404D-8636-7872CD299796}']\r\n { From TStrings/TStringList }\r\n function Add(const S: string): Integer; overload;\r\n function AddObject(const S: string; AObject: TObject): Integer;\r\n function Get(Index: Integer): string;\r\n function GetCapacity: Integer;\r\n function GetCount: Integer;\r\n function GetObjects(Index: Integer): TObject;\r\n function GetTextStr: string;\r\n function GetValue(const Name: string): string;\r\n {$IFDEF FPC}\r\n function Find(const S: string; out Index: Integer): Boolean;\r\n {$ELSE ~FPC}\r\n function Find(const S: string; var Index: Integer): Boolean;\r\n {$ENDIF ~FPC}\r\n function IndexOf(const S: string): Integer;\r\n function GetCaseSensitive: Boolean;\r\n function GetDuplicates: TDuplicates;\r\n function GetOnChange: TNotifyEvent;\r\n function GetOnChanging: TNotifyEvent;\r\n function GetSorted: Boolean;\r\n function Equals(Strings: TStrings): Boolean;\r\n function IndexOfName(const Name: string): Integer;\r\n function IndexOfObject(AObject: TObject): Integer; \r\n function LoadFromFile(const FileName: string): IJclStringList;\r\n function LoadFromStream(Stream: TStream): IJclStringList;\r\n function SaveToFile(const FileName: string): IJclStringList;\r\n function SaveToStream(Stream: TStream): IJclStringList;\r\n function GetCommaText: string;\r\n function GetDelimitedText: string;\r\n function GetDelimiter: Char;\r\n function GetName(Index: Integer): string;\r\n {$IFDEF COMPILER7_UP}\r\n function GetNameValueSeparator: Char;\r\n function GetValueFromIndex(Index: Integer): string;\r\n {$ENDIF COMPILER7_UP}\r\n function GetQuoteChar: Char;\r\n procedure SetCommaText(const Value: string);\r\n procedure SetDelimitedText(const Value: string);\r\n procedure SetDelimiter(const Value: Char);\r\n {$IFDEF COMPILER7_UP}\r\n procedure SetNameValueSeparator(const Value: Char);\r\n procedure SetValueFromIndex(Index: Integer; const Value: string);\r\n {$ENDIF COMPILER7_UP}\r\n procedure SetQuoteChar(const Value: Char);\r\n procedure AddStrings(Strings: TStrings); overload;\r\n procedure SetObjects(Index: Integer; const Value: TObject);\r\n procedure Put(Index: Integer; const S: string);\r\n procedure SetCapacity(NewCapacity: Integer);\r\n procedure SetTextStr(const Value: string);\r\n procedure SetValue(const Name, Value: string);\r\n procedure SetCaseSensitive(const Value: Boolean);\r\n procedure SetDuplicates(const Value: TDuplicates);\r\n procedure SetOnChange(const Value: TNotifyEvent);\r\n procedure SetOnChanging(const Value: TNotifyEvent);\r\n procedure SetSorted(const Value: Boolean);\r\n property Count: Integer read GetCount;\r\n property Strings[Index: Integer]: string read Get write Put; default;\r\n property Text: string read GetTextStr write SetTextStr;\r\n property Objects[Index: Integer]: TObject read GetObjects write SetObjects;\r\n property Capacity: Integer read GetCapacity write SetCapacity;\r\n property Values[const Name: string]: string read GetValue write SetValue;\r\n property Duplicates: TDuplicates read GetDuplicates write SetDuplicates;\r\n property Sorted: Boolean read GetSorted write SetSorted;\r\n property CaseSensitive: Boolean read GetCaseSensitive write SetCaseSensitive;\r\n property OnChange: TNotifyEvent read GetOnChange write SetOnChange;\r\n property OnChanging: TNotifyEvent read GetOnChanging write SetOnChanging;\r\n property DelimitedText: string read GetDelimitedText write SetDelimitedText;\r\n property Delimiter: Char read GetDelimiter write SetDelimiter;\r\n property Names[Index: Integer]: string read GetName;\r\n property QuoteChar: Char read GetQuoteChar write SetQuoteChar;\r\n property CommaText: string read GetCommaText write SetCommaText;\r\n {$IFDEF COMPILER7_UP}\r\n property ValueFromIndex[Index: Integer]: string read GetValueFromIndex write SetValueFromIndex;\r\n property NameValueSeparator: Char read GetNameValueSeparator write SetNameValueSeparator;\r\n {$ENDIF COMPILER7_UP}\r\n { New }\r\n function Assign(Source: TPersistent): IJclStringList;\r\n function LoadExeParams: IJclStringList;\r\n function Exists(const S: string): Boolean;\r\n function ExistsName(const S: string): Boolean;\r\n function DeleteBlanks: IJclStringList;\r\n function KeepIntegers: IJclStringList;\r\n function DeleteIntegers: IJclStringList;\r\n function ReleaseInterfaces: IJclStringList;\r\n function FreeObjects(AFreeAndNil: Boolean = False): IJclStringList;\r\n function Clone: IJclStringList;\r\n function Insert(Index: Integer; const S: string): IJclStringList;\r\n function InsertObject(Index: Integer; const S: string; AObject: TObject): IJclStringList;\r\n function Sort(ACompareFunction: TJclStringListSortCompare = nil): IJclStringList;\r\n function SortAsInteger: IJclStringList;\r\n function SortByName: IJclStringList;\r\n function Delete(AIndex: Integer): IJclStringList; overload;\r\n function Delete(const AString: string): IJclStringList; overload;\r\n function Exchange(Index1, Index2: Integer): IJclStringList;\r\n function Add(const A: array of const): IJclStringList; overload;\r\n function AddStrings(const A: array of string): IJclStringList; overload;\r\n function BeginUpdate: IJclStringList;\r\n function EndUpdate: IJclStringList;\r\n function Trim: IJclStringList;\r\n function Join(const ASeparator: string = ''): string;\r\n function Split(const AText, ASeparator: string; AClearBeforeAdd: Boolean = True): IJclStringList;\r\n function ExtractWords(const AText: string; const ADelims: TSetOfAnsiChar = [#0..' ']; AClearBeforeAdd: Boolean = True): IJclStringList;\r\n function Last: string;\r\n function First: string;\r\n function LastIndex: Integer;\r\n function Clear: IJclStringList;\r\n {$IFDEF JCL_PCRE}\r\n function DeleteRegEx(const APattern: string): IJclStringList;\r\n function KeepRegEx(const APattern: string): IJclStringList;\r\n function Files(const APattern: string = '*'; ARecursive: Boolean = False; const ARegExPattern: string = ''): IJclStringList;\r\n function Directories(const APattern: string = '*'; ARecursive: Boolean = False; const ARegExPattern: string = ''): IJclStringList;\r\n {$ENDIF JCL_PCRE}\r\n function GetStringsRef: TStrings;\r\n function ConfigAsSet: IJclStringList;\r\n function Delimit(const ADelimiter: string): IJclStringList;\r\n function GetInterfaceByIndex(Index: Integer): IInterface;\r\n function GetLists(Index: Integer): IJclStringList;\r\n function GetVariants(AIndex: Integer): Variant;\r\n function GetKeyInterface(const AKey: string): IInterface;\r\n function GetKeyObject(const AKey: string): TObject;\r\n function GetKeyVariant(const AKey: string): Variant;\r\n function GetKeyList(const AKey: string): IJclStringList;\r\n function GetObjectsMode: TJclStringListObjectsMode;\r\n procedure SetInterfaceByIndex(Index: Integer; const Value: IInterface);\r\n procedure SetLists(Index: Integer; const Value: IJclStringList);\r\n procedure SetVariants(Index: Integer; const Value: Variant);\r\n procedure SetKeyInterface(const AKey: string; const Value: IInterface);\r\n procedure SetKeyObject(const AKey: string; const Value: TObject);\r\n procedure SetKeyVariant(const AKey: string; const Value: Variant);\r\n procedure SetKeyList(const AKey: string; const Value: IJclStringList);\r\n property Interfaces[Index: Integer]: IInterface read GetInterfaceByIndex write SetInterfaceByIndex;\r\n property Lists[Index: Integer]: IJclStringList read GetLists write SetLists;\r\n property Variants[Index: Integer]: Variant read GetVariants write SetVariants;\r\n property KeyList[const AKey: string]: IJclStringList read GetKeyList write SetKeyList;\r\n property KeyObject[const AKey: string]: TObject read GetKeyObject write SetKeyObject;\r\n property KeyInterface[const AKey: string]: IInterface read GetKeyInterface write SetKeyInterface;\r\n property KeyVariant[const AKey: string]: Variant read GetKeyVariant write SetKeyVariant;\r\n property ObjectsMode: TJclStringListObjectsMode read GetObjectsMode;\r\n end;\r\n\r\ntype\r\n TJclInterfacedStringList = class(TStringList, IInterface)\r\n private\r\n FOwnerInterface: IInterface;\r\n public\r\n { IInterface }\r\n function _AddRef: Integer; stdcall;\r\n function _Release: Integer; stdcall;\r\n function QueryInterface({$IFDEF FPC_HAS_CONSTREF}constref{$ELSE}const{$ENDIF} IID: TGUID; out Obj): HResult; stdcall;\r\n procedure AfterConstruction; override;\r\n end;\r\n\r\n\r\n TJclStringList = class(TJclInterfacedStringList, IInterface, IJclStringList)\r\n private\r\n FObjectsMode: TJclStringListObjectsMode;\r\n FSelfAsInterface: IJclStringList;\r\n {$IFDEF JCL_PCRE}\r\n FLastRegExPattern: string;\r\n FRegEx: TJclRegEx;\r\n {$ENDIF JCL_PCRE}\r\n FCompareFunction: TJclStringListSortCompare;\r\n function CanFreeObjects: Boolean;\r\n {$IFDEF JCL_PCRE}\r\n function MatchRegEx(const S, APattern: string): Boolean;\r\n {$ENDIF JCL_PCRE}\r\n procedure EnsureObjectsMode(AMode: TJclStringListObjectsMode);\r\n protected\r\n FRefCount: Integer;\r\n {$IFNDEF HAS_TSTRINGS_COMPARESTRINGS}\r\n function CompareStrings(const S1, S2: string): Integer; virtual;\r\n {$ENDIF ~HAS_TSTRINGS_COMPARESTRINGS}\r\n public\r\n constructor Create;\r\n destructor Destroy; override;\r\n { IInterface }\r\n // function QueryInterface(const IID: TGUID; out Obj): HRESULT; stdcall;\r\n function _AddRef: Integer; stdcall;\r\n function _Release: Integer; stdcall;\r\n { IJclStringList }\r\n // function Add(const S: string): Integer; overload;\r\n // function AddObject(const S: string; AObject: TObject): Integer;\r\n // function Get(Index: Integer): string;\r\n // function GetCapacity: Integer;\r\n // function GetCount: Integer;\r\n function GetObjects(Index: Integer): TObject;\r\n // function GetTextStr: string;\r\n function GetValue(const Name: string): string;\r\n // function Find(const S: string; var Index: Integer): Boolean;\r\n // function IndexOf(const S: string): Integer;\r\n function GetCaseSensitive: Boolean;\r\n function GetDuplicates: TDuplicates;\r\n function GetOnChange: TNotifyEvent;\r\n function GetOnChanging: TNotifyEvent;\r\n function GetSorted: Boolean;\r\n // function Equals(Strings: TStrings): Boolean;\r\n // function IndexOfName(const Name: string): Integer;\r\n // function IndexOfObject(AObject: TObject): Integer;\r\n function LoadFromFile(const FileName: string): IJclStringList; reintroduce;\r\n function LoadFromStream(Stream: TStream): IJclStringList; reintroduce;\r\n function SaveToFile(const FileName: string): IJclStringList; reintroduce;\r\n function SaveToStream(Stream: TStream): IJclStringList; reintroduce;\r\n function GetCommaText: string;\r\n function GetDelimitedText: string;\r\n function GetDelimiter: Char;\r\n function GetName(Index: Integer): string;\r\n {$IFDEF COMPILER7_UP}\r\n function GetNameValueSeparator: Char;\r\n function GetValueFromIndex(Index: Integer): string;\r\n {$ENDIF COMPILER7_UP}\r\n function GetQuoteChar: Char;\r\n procedure SetCommaText(const Value: string);\r\n procedure SetDelimitedText(const Value: string);\r\n procedure SetDelimiter(const Value: Char);\r\n {$IFDEF COMPILER7_UP}\r\n procedure SetNameValueSeparator(const Value: Char);\r\n procedure SetValueFromIndex(Index: Integer; const Value: string);\r\n {$ENDIF COMPILER7_UP}\r\n procedure SetQuoteChar(const Value: Char);\r\n // procedure AddStrings(Strings: TStrings); overload;\r\n procedure SetObjects(Index: Integer; const Value: TObject);\r\n // procedure Put(Index: Integer; const S: string);\r\n // procedure SetCapacity(NewCapacity: Integer);\r\n // procedure SetTextStr(const Value: string);\r\n procedure SetValue(const Name, Value: string);\r\n procedure SetCaseSensitive(const Value: Boolean);\r\n procedure SetDuplicates(const Value: TDuplicates);\r\n procedure SetOnChange(const Value: TNotifyEvent);\r\n procedure SetOnChanging(const Value: TNotifyEvent);\r\n procedure SetSorted(const Value: Boolean);\r\n property Count: Integer read GetCount;\r\n property Strings[Index: Integer]: string read Get write Put; default;\r\n property Text: string read GetTextStr write SetTextStr;\r\n property Objects[Index: Integer]: TObject read GetObjects write SetObjects;\r\n property Capacity: Integer read GetCapacity write SetCapacity;\r\n property Values[const Name: string]: string read GetValue write SetValue;\r\n property Duplicates: TDuplicates read GetDuplicates write SetDuplicates;\r\n property Sorted: Boolean read GetSorted write SetSorted;\r\n property CaseSensitive: Boolean read GetCaseSensitive write SetCaseSensitive;\r\n property OnChange: TNotifyEvent read GetOnChange write SetOnChange;\r\n property OnChanging: TNotifyEvent read GetOnChanging write SetOnChanging;\r\n property DelimitedText: string read GetDelimitedText write SetDelimitedText;\r\n property Delimiter: Char read GetDelimiter write SetDelimiter;\r\n property Names[Index: Integer]: string read GetName;\r\n property QuoteChar: Char read GetQuoteChar write SetQuoteChar;\r\n property CommaText: string read GetCommaText write SetCommaText;\r\n {$IFDEF COMPILER7_UP}\r\n property ValueFromIndex[Index: Integer]: string read GetValueFromIndex write SetValueFromIndex;\r\n property NameValueSeparator: Char read GetNameValueSeparator write SetNameValueSeparator;\r\n {$ENDIF COMPILER7_UP}\r\n { New }\r\n function Assign(Source: TPersistent): IJclStringList; reintroduce;\r\n function LoadExeParams: IJclStringList;\r\n function Exists(const S: string): Boolean;\r\n function ExistsName(const S: string): Boolean;\r\n function DeleteBlanks: IJclStringList;\r\n function KeepIntegers: IJclStringList;\r\n function DeleteIntegers: IJclStringList;\r\n function ReleaseInterfaces: IJclStringList;\r\n function FreeObjects(AFreeAndNil: Boolean = False): IJclStringList;\r\n function Clone: IJclStringList;\r\n function Insert(Index: Integer; const S: string): IJclStringList; reintroduce;\r\n function InsertObject(Index: Integer; const S: string; AObject: TObject): IJclStringList; reintroduce;\r\n function Sort(ACompareFunction: TJclStringListSortCompare = nil): IJclStringList; reintroduce;\r\n function SortAsInteger: IJclStringList;\r\n function SortByName: IJclStringList;\r\n function Delete(AIndex: Integer): IJclStringList; reintroduce; overload;\r\n function Delete(const AString: string): IJclStringList; reintroduce; overload;\r\n function Exchange(Index1, Index2: Integer): IJclStringList; reintroduce;\r\n function Add(const A: array of const): IJclStringList; reintroduce; overload;\r\n function AddStrings(const A: array of string): IJclStringList; reintroduce; overload;\r\n function BeginUpdate: IJclStringList;\r\n function EndUpdate: IJclStringList;\r\n function Trim: IJclStringList;\r\n function Join(const ASeparator: string = ''): string;\r\n function Split(const AText, ASeparator: string; AClearBeforeAdd: Boolean = True): IJclStringList;\r\n function ExtractWords(const AText: string; const ADelims: TSetOfAnsiChar = [#0..' ']; AClearBeforeAdd: Boolean = True): IJclStringList;\r\n function Last: string;\r\n function First: string;\r\n function LastIndex: Integer;\r\n function Clear: IJclStringList; reintroduce;\r\n {$IFDEF JCL_PCRE}\r\n function DeleteRegEx(const APattern: string): IJclStringList;\r\n function KeepRegEx(const APattern: string): IJclStringList;\r\n function Files(const APattern: string = '*'; ARecursive: Boolean = False; const ARegExPattern: string = ''): IJclStringList;\r\n function Directories(const APattern: string = '*'; ARecursive: Boolean = False; const ARegExPattern: string = ''): IJclStringList;\r\n {$ENDIF JCL_PCRE}\r\n function GetStringsRef: TStrings;\r\n function ConfigAsSet: IJclStringList;\r\n function Delimit(const ADelimiter: string): IJclStringList;\r\n function GetInterfaceByIndex(Index: Integer): IInterface;\r\n function GetLists(Index: Integer): IJclStringList;\r\n function GetVariants(AIndex: Integer): Variant;\r\n function GetKeyInterface(const AKey: string): IInterface;\r\n function GetKeyObject(const AKey: string): TObject;\r\n function GetKeyVariant(const AKey: string): Variant;\r\n function GetKeyList(const AKey: string): IJclStringList;\r\n function GetObjectsMode: TJclStringListObjectsMode;\r\n procedure SetInterfaceByIndex(Index: Integer; const Value: IInterface);\r\n procedure SetLists(Index: Integer; const Value: IJclStringList);\r\n procedure SetVariants(Index: Integer; const Value: Variant);\r\n procedure SetKeyInterface(const AKey: string; const Value: IInterface);\r\n procedure SetKeyObject(const AKey: string; const Value: TObject);\r\n procedure SetKeyVariant(const AKey: string; const Value: Variant);\r\n procedure SetKeyList(const AKey: string; const Value: IJclStringList);\r\n property Interfaces[Index: Integer]: IInterface read GetInterfaceByIndex write SetInterfaceByIndex;\r\n property Lists[Index: Integer]: IJclStringList read GetLists write SetLists;\r\n property Variants[Index: Integer]: Variant read GetVariants write SetVariants;\r\n property KeyList[const AKey: string]: IJclStringList read GetKeyList write SetKeyList;\r\n property KeyObject[const AKey: string]: TObject read GetKeyObject write SetKeyObject;\r\n property KeyInterface[const AKey: string]: IInterface read GetKeyInterface write SetKeyInterface;\r\n property KeyVariant[const AKey: string]: Variant read GetKeyVariant write SetKeyVariant;\r\n property ObjectsMode: TJclStringListObjectsMode read GetObjectsMode;\r\n end;\r\n\r\nfunction JclStringList: IJclStringList; overload;\r\nfunction JclStringListStrings(AStrings: TStrings): IJclStringList; overload;\r\nfunction JclStringListStrings(const A: array of string): IJclStringList; overload;\r\nfunction JclStringList(const A: array of const): IJclStringList; overload;\r\nfunction JclStringList(const AText: string): IJclStringList; overload;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jcl.svn.sourceforge.net/svnroot/jcl/tags/JCL-2.4-Build4571/jcl/source/common/JclStringLists.pas $';\r\n Revision: '$Revision: 3855 $';\r\n Date: '$Date: 2012-09-03 00:25:26 +0200 (lun. 03 sept. 2012) $';\r\n LogPath: 'JCL\\source\\common';\r\n Extra: '';\r\n Data: nil\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n {$IFDEF HAS_UNITSCOPE}\r\n System.TypInfo,\r\n {$ELSE ~HAS_UNITSCOPE}\r\n TypInfo,\r\n {$ENDIF ~HAS_UNITSCOPE}\r\n JclFileUtils,\r\n JclStrings;\r\n\r\ntype\r\n TVariantWrapper = class(TObject)\r\n private\r\n FValue: Variant;\r\n end;\r\n\r\n TInterfaceWrapper = class(TObject)\r\n private\r\n FValue: IInterface;\r\n end;\r\n\r\nfunction JclStringList: IJclStringList;\r\nbegin\r\n Result := TJclStringList.Create;\r\nend;\r\n\r\nfunction JclStringList(const AText: string): IJclStringList; overload;\r\nbegin\r\n Result := JclStringList;\r\n Result.Text := AText;\r\nend;\r\n\r\nfunction JclStringListStrings(AStrings: TStrings): IJclStringList; overload;\r\nbegin\r\n Result := JclStringList;\r\n Result.AddStrings(AStrings);\r\nend;\r\n\r\nfunction JclStringListStrings(const A: array of string): IJclStringList;\r\nbegin\r\n Result := JclStringList.AddStrings(A);\r\nend;\r\n\r\nfunction JclStringList(const A: array of const): IJclStringList;\r\nbegin\r\n Result := JclStringList.Add(A);\r\nend;\r\n\r\n//=== { TJclInterfacedStringList } ==============================================\r\n\r\nprocedure TJclInterfacedStringList.AfterConstruction;\r\nVar\r\n MyOwner : TPersistent;\r\nbegin\r\n inherited;\r\n MyOwner := GetOwner;\r\n if Assigned(MyOwner) then\r\n MyOwner.GetInterface(IUnknown,FOwnerInterface);\r\nend;\r\n\r\n\r\nfunction TJclInterfacedStringList._AddRef: Integer;stdcall;\r\nbegin\r\n if assigned(FOwnerInterface) then\r\n Result := FOwnerInterface._AddRef\r\n else\r\n Result := -1;\r\nend;\r\n\r\n\r\nfunction TJclInterfacedStringList._Release: Integer;stdcall;\r\nbegin\r\n if assigned(FOwnerInterface) then\r\n Result := FOwnerInterface._Release\r\n else\r\n Result := -1;\r\nend;\r\n\r\n\r\nfunction TJclInterfacedStringList.QueryInterface({$IFDEF FPC_HAS_CONSTREF}constref{$ELSE}const{$ENDIF} IID: TGUID; out Obj): HResult;stdcall;\r\nbegin\r\n if GetInterface(IID, Obj) then\r\n Result := 0\r\n else\r\n Result := E_NOINTERFACE;\r\nend;\r\n\r\n//=== { TJclStringList } =====================================================\r\n\r\nfunction TJclStringList.Add(const A: array of const): IJclStringList;\r\nconst\r\n BoolToStr: array [Boolean] of string[5] = ('false', 'true');\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := BeginUpdate;\r\n try\r\n for I := Low(A) to High(A) do\r\n case A[I].VType of\r\n vtInteger:\r\n Add(IntToStr(A[I].VInteger));\r\n vtBoolean:\r\n Add(string(BoolToStr[A[I].VBoolean]));\r\n vtChar:\r\n Add(string(AnsiString(A[I].VChar)));\r\n vtExtended:\r\n Add(FloatToStr(A[I].VExtended^));\r\n vtString:\r\n Add(string(A[I].VString^));\r\n vtPChar:\r\n Add(string(AnsiString(A[I].VPChar)));\r\n vtPWideChar:\r\n Add(string(WideString(A[I].VPWideChar)));\r\n vtObject:\r\n Add(A[I].VObject.ClassName);\r\n vtClass:\r\n Add(A[I].VClass.ClassName);\r\n vtAnsiString:\r\n Add(string(A[I].VAnsiString));\r\n vtWideString:\r\n Add(string(A[I].VWideString));\r\n vtCurrency:\r\n Add(CurrToStr(A[I].VCurrency^));\r\n vtVariant:\r\n Add(string(A[I].VVariant^));\r\n vtInt64:\r\n Add(IntToStr(A[I].VInt64^));\r\n {$IFDEF SUPPORTS_UNICODE_STRING}\r\n vtUnicodeString:\r\n Add(string(A[I].VUnicodeString));\r\n {$ENDIF SUPPORTS_UNICODE_STRING}\r\n end;\r\n finally\r\n Result := EndUpdate;\r\n end;\r\nend;\r\n\r\nfunction TJclStringList.AddStrings(const A: array of string): IJclStringList;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := BeginUpdate;\r\n try\r\n for I := Low(A) to High(A) do\r\n Add(A[I]);\r\n finally\r\n Result := EndUpdate;\r\n end;\r\nend;\r\n\r\nfunction TJclStringList.BeginUpdate: IJclStringList;\r\nbegin\r\n inherited BeginUpdate;\r\n Result := FSelfAsInterface;\r\nend;\r\n\r\nfunction TJclStringList.Clear: IJclStringList;\r\nbegin\r\n if CanFreeObjects then\r\n FreeObjects(False);\r\n inherited Clear;\r\n Result := FSelfAsInterface;\r\nend;\r\n\r\nfunction TJclStringList.EndUpdate: IJclStringList;\r\nbegin\r\n inherited EndUpdate;\r\n Result := FSelfAsInterface;\r\nend;\r\n\r\nfunction TJclStringList.ExtractWords(const AText: string; const ADelims: TSetOfAnsiChar;\r\n AClearBeforeAdd: Boolean): IJclStringList;\r\nvar\r\n L, I, X: Integer;\r\nbegin\r\n Result := BeginUpdate;\r\n try\r\n if AClearBeforeAdd then\r\n Clear;\r\n I := 1;\r\n L := Length(AText);\r\n while I <= L do\r\n begin\r\n while (I <= L) and (AnsiChar(AText[I]) in ADelims) do\r\n Inc(I);\r\n X := I;\r\n while (I <= L) and not (AnsiChar(AText[I]) in ADelims) do\r\n Inc(I);\r\n if X <> I then\r\n Add(Copy(AText, X, I - X));\r\n end;\r\n finally\r\n Result := EndUpdate;\r\n end;\r\nend;\r\n\r\nfunction TJclStringList.First: string;\r\nbegin\r\n Result := Strings[0];\r\nend;\r\n\r\nfunction TJclStringList.Join(const ASeparator: string): string;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := '';\r\n for I := 0 to LastIndex - 1 do\r\n Result := Result + Strings[I] + ASeparator;\r\n if Count > 0 then\r\n Result := Result + Last;\r\nend;\r\n\r\nfunction TJclStringList.Last: string;\r\nbegin\r\n Result := Strings[LastIndex];\r\nend;\r\n\r\nfunction TJclStringList.Split(const AText, ASeparator: string;\r\n AClearBeforeAdd: Boolean = True): IJclStringList;\r\nvar\r\n LStartIndex, LEndIndex: Integer;\r\n LLengthSeparator: Integer;\r\nbegin\r\n Result := FSelfAsInterface;\r\n if AText <> '' then\r\n begin\r\n Result := BeginUpdate;\r\n try\r\n if AClearBeforeAdd then\r\n Clear;\r\n LLengthSeparator := Length(ASeparator);\r\n LStartIndex := 1;\r\n LEndIndex := StrSearch(ASeparator, AText, LStartIndex);\r\n while LEndIndex > 0 do\r\n begin\r\n Add(Copy(AText, LStartIndex, LEndIndex - LStartIndex));\r\n LStartIndex := LEndIndex + LLengthSeparator;\r\n LEndIndex := StrSearch(ASeparator, AText, LStartIndex);\r\n end;\r\n Add(Copy(AText, LStartIndex, MaxInt));\r\n finally\r\n Result := EndUpdate;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJclStringList.Trim: IJclStringList;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := BeginUpdate;\r\n try\r\n for I := 0 to LastIndex do\r\n Strings[I] := {$IFDEF HAS_UNITSCOPE}System.{$ENDIF}SysUtils.Trim(Strings[I]);\r\n finally\r\n Result := EndUpdate;\r\n end;\r\nend;\r\n\r\nfunction TJclStringList._AddRef: Integer;\r\nbegin\r\n Result := InterlockedIncrement(FRefCount);\r\nend;\r\n\r\nfunction TJclStringList._Release: Integer;\r\nbegin\r\n Result := InterlockedDecrement(FRefCount);\r\n if Result = 1 then\r\n begin\r\n // When there is only one reference, it is the internal reference,\r\n // so we release it. The compiler will call _Release again and\r\n // the object will be destroyed.\r\n FSelfAsInterface := nil;\r\n end\r\n else\r\n if Result = 0 then\r\n Destroy;\r\nend;\r\n\r\n{$IFDEF JCL_PCRE}\r\nfunction TJclStringList.DeleteRegEx(const APattern: string): IJclStringList;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := BeginUpdate;\r\n try\r\n for I := LastIndex downto 0 do\r\n if MatchRegEx(Strings[I], APattern) then\r\n Delete(I);\r\n finally\r\n Result := EndUpdate;\r\n end;\r\nend;\r\n\r\nfunction TJclStringList.KeepRegEx(const APattern: string): IJclStringList;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := BeginUpdate;\r\n try\r\n for I := LastIndex downto 0 do\r\n if not MatchRegEx(Strings[I], APattern) then\r\n Delete(I);\r\n finally\r\n Result := EndUpdate;\r\n end;\r\nend;\r\n\r\nfunction TJclStringList.MatchRegEx(const S, APattern: string): Boolean;\r\nbegin\r\n if FRegEx = nil then\r\n FRegEx := TJclRegEx.Create;\r\n if FLastRegExPattern <> APattern then\r\n begin\r\n if CaseSensitive then\r\n FRegEx.Options := FRegEx.Options - [roIgnoreCase]\r\n else\r\n FRegEx.Options := FRegEx.Options + [roIgnoreCase];\r\n FRegEx.Compile(APattern, False, True);\r\n FLastRegExPattern := APattern;\r\n end;\r\n Result := FRegEx.Match(S);\r\nend;\r\n{$ENDIF JCL_PCRE}\r\n\r\ndestructor TJclStringList.Destroy;\r\nbegin\r\n if CanFreeObjects then\r\n FreeObjects(False);\r\n {$IFDEF JCL_PCRE}\r\n FreeAndNil(FRegEx);\r\n {$ENDIF JCL_PCRE}\r\n inherited Destroy;\r\nend;\r\n\r\n{$IFDEF JCL_PCRE}\r\nfunction TJclStringList.Directories(const APattern: string = '*';\r\n ARecursive: Boolean = False; const ARegExPattern: string = ''): IJclStringList;\r\n\r\n procedure DoDirectories(const APattern: string);\r\n var\r\n LSearchRec: TSearchRec;\r\n LFullName: string;\r\n LPath: string;\r\n begin\r\n LPath := ExtractFilePath(APattern);\r\n if FindFirst(APattern, faAnyFile, LSearchRec) = 0 then\r\n try\r\n repeat\r\n if (LSearchRec.Attr and faDirectory = 0) or\r\n (LSearchRec.Name = '.') or (LSearchRec.Name = '..') then\r\n Continue;\r\n LFullName := LPath + LSearchRec.Name;\r\n if (ARegExPattern = '') or MatchRegEx(LFullName, ARegExPattern) then\r\n Add(LFullName);\r\n if ARecursive then\r\n DoDirectories(PathAddSeparator(LFullName) + ExtractFileName(APattern));\r\n until FindNext(LSearchRec) <> 0;\r\n finally\r\n FindClose(LSearchRec);\r\n end;\r\n end;\r\n\r\nbegin\r\n Result := BeginUpdate;\r\n try\r\n if DirectoryExists(APattern) then\r\n DoDirectories(PathAddSeparator(APattern) + '*')\r\n else\r\n DoDirectories(APattern);\r\n finally\r\n Result := EndUpdate;\r\n end;\r\nend;\r\n\r\nfunction TJclStringList.Files(const APattern: string = '*';\r\n ARecursive: Boolean = False; const ARegExPattern: string = ''): IJclStringList;\r\n\r\n procedure DoFiles(const APattern: string);\r\n var\r\n LSearchRec: TSearchRec;\r\n LFullName: string;\r\n LDirectories: IJclStringList;\r\n LPath: string;\r\n I: Integer;\r\n begin\r\n LPath := ExtractFilePath(APattern);\r\n if FindFirst(APattern, faAnyFile and not faDirectory, LSearchRec) = 0 then\r\n begin\r\n try\r\n repeat\r\n if (LSearchRec.Attr and faDirectory <> 0) or\r\n (LSearchRec.Name = '.') or (LSearchRec.Name = '..') then\r\n Continue;\r\n LFullName := LPath + LSearchRec.Name;\r\n if (ARegExPattern = '') or MatchRegEx(LFullName, ARegExPattern) then\r\n Add(LFullName);\r\n until FindNext(LSearchRec) <> 0;\r\n finally\r\n FindClose(LSearchRec);\r\n end;\r\n end;\r\n if ARecursive then\r\n begin\r\n LDirectories := JclStringList.Directories(LPath + '*', False);\r\n for I := 0 to LDirectories.LastIndex do\r\n DoFiles(PathAddSeparator(LDirectories[I]) + ExtractFileName(APattern));\r\n end;\r\n end;\r\n\r\nbegin\r\n Result := BeginUpdate;\r\n try\r\n if DirectoryExists(APattern) then\r\n DoFiles(PathAddSeparator(APattern) + '*')\r\n else\r\n DoFiles(APattern);\r\n finally\r\n Result := EndUpdate;\r\n end;\r\nend;\r\n{$ENDIF JCL_PCRE}\r\n\r\nfunction TJclStringList.LastIndex: Integer;\r\nbegin\r\n { The code bellow is more optimized than \"Result := Count - 1\". }\r\n Result := Count;\r\n Dec(Result);\r\nend;\r\n\r\nconstructor TJclStringList.Create;\r\nbegin\r\n inherited Create;\r\n if QueryInterface(IJclStringList, FSelfAsInterface) <> 0 then\r\n System.Error(reIntfCastError);\r\nend;\r\n\r\nfunction TJclStringList.GetLists(Index: Integer): IJclStringList;\r\nbegin\r\n Result := Interfaces[Index] as IJclStringList;\r\n if Result = nil then\r\n begin\r\n Result := JclStringList;\r\n Interfaces[Index] := Result;\r\n end;\r\nend;\r\n\r\nprocedure TJclStringList.SetLists(Index: Integer; const Value: IJclStringList);\r\nbegin\r\n Interfaces[Index] := Value;\r\nend;\r\n\r\nfunction TJclStringList.GetStringsRef: TStrings;\r\nbegin\r\n Result := Self;\r\nend;\r\n\r\nfunction TJclStringList.GetKeyInterface(const AKey: string): IInterface;\r\nvar\r\n I: Integer;\r\nbegin\r\n I := IndexOf(AKey);\r\n if I >= 0 then\r\n Result := Interfaces[I]\r\n else\r\n Result := nil;\r\nend;\r\n\r\nfunction TJclStringList.GetKeyObject(const AKey: string): TObject;\r\nvar\r\n I: Integer;\r\nbegin\r\n I := IndexOf(AKey);\r\n if I >= 0 then\r\n Result := Objects[I]\r\n else\r\n Result := nil;\r\nend;\r\n\r\nprocedure TJclStringList.SetKeyInterface(const AKey: string; const Value: IInterface);\r\nvar\r\n I: Integer;\r\nbegin\r\n I := IndexOf(AKey);\r\n if I < 0 then\r\n I := Add(AKey);\r\n Interfaces[I] := Value\r\nend;\r\n\r\nprocedure TJclStringList.SetKeyObject(const AKey: string; const Value: TObject);\r\nvar\r\n I: Integer;\r\nbegin\r\n I := IndexOf(AKey);\r\n if I < 0 then\r\n AddObject(AKey, Value)\r\n else\r\n Objects[I] := Value;\r\nend;\r\n\r\nfunction TJclStringList.ConfigAsSet: IJclStringList;\r\nbegin\r\n Sorted := True;\r\n Duplicates := dupIgnore;\r\n Result := FSelfAsInterface;\r\nend;\r\n\r\nfunction TJclStringList.GetKeyVariant(const AKey: string): Variant;\r\nvar\r\n I: Integer;\r\nbegin\r\n I := IndexOf(AKey);\r\n if I >= 0 then\r\n Result := Variants[I]\r\n else\r\n Result := Unassigned;\r\nend;\r\n\r\nprocedure TJclStringList.SetKeyVariant(const AKey: string; const Value: Variant);\r\nvar\r\n I: Integer;\r\nbegin\r\n I := IndexOf(AKey);\r\n if I < 0 then\r\n I := Add(AKey);\r\n Variants[I] := Value\r\nend;\r\n\r\nfunction TJclStringList.GetValue(const Name: string): string;\r\nbegin\r\n Result := inherited Values[Name];\r\nend;\r\n\r\nprocedure TJclStringList.SetValue(const Name, Value: string);\r\nbegin\r\n inherited Values[Name] := Value;\r\nend;\r\n\r\nfunction TJclStringList.GetInterfaceByIndex(Index: Integer): IInterface;\r\nvar\r\n V: TInterfaceWrapper;\r\nbegin\r\n if FObjectsMode <> omInterfaces then\r\n EnsureObjectsMode(omInterfaces);\r\n V := TInterfaceWrapper(inherited Objects[Index]);\r\n if V = nil then\r\n Result := nil\r\n else\r\n Result := V.FValue;\r\nend;\r\n\r\nprocedure TJclStringList.SetInterfaceByIndex(Index: Integer; const Value: IInterface);\r\nvar\r\n V: TInterfaceWrapper;\r\nbegin\r\n if FObjectsMode <> omInterfaces then\r\n EnsureObjectsMode(omInterfaces);\r\n V := TInterfaceWrapper(inherited Objects[Index]);\r\n if V = nil then\r\n begin\r\n V := TInterfaceWrapper.Create;\r\n inherited Objects[Index] := V;\r\n end;\r\n V.FValue := Value;\r\nend;\r\n\r\nfunction TJclStringList.GetObjects(Index: Integer): TObject;\r\nbegin\r\n if FObjectsMode <> omObjects then\r\n EnsureObjectsMode(omObjects);\r\n Result := inherited Objects[Index];\r\nend;\r\n\r\nprocedure TJclStringList.SetObjects(Index: Integer; const Value: TObject);\r\nbegin\r\n if FObjectsMode <> omObjects then\r\n EnsureObjectsMode(omObjects);\r\n inherited Objects[Index] := Value;\r\nend;\r\n\r\nfunction TJclStringList.GetVariants(AIndex: Integer): Variant;\r\nvar\r\n V: TVariantWrapper;\r\nbegin\r\n if FObjectsMode <> omVariants then\r\n EnsureObjectsMode(omVariants);\r\n V := TVariantWrapper(inherited Objects[AIndex]);\r\n if V = nil then\r\n Result := Unassigned\r\n else\r\n Result := V.FValue;\r\nend;\r\n\r\nprocedure TJclStringList.SetVariants(Index: Integer; const Value: Variant);\r\nvar\r\n V: TVariantWrapper;\r\nbegin\r\n if FObjectsMode <> omVariants then\r\n EnsureObjectsMode(omVariants);\r\n V := TVariantWrapper(inherited Objects[Index]);\r\n if V = nil then\r\n begin\r\n V := TVariantWrapper.Create;\r\n inherited Objects[Index] := V;\r\n end;\r\n V.FValue := Value;\r\nend;\r\n\r\nprocedure TJclStringList.EnsureObjectsMode(AMode: TJclStringListObjectsMode);\r\nbegin\r\n if FObjectsMode <> AMode then\r\n begin\r\n if FObjectsMode <> omNone then\r\n begin\r\n raise EJclStringListError.CreateFmt('Objects cannot be used as \"%s\" because it has been used as \"%s\".',\r\n [GetEnumName(TypeInfo(TJclStringListObjectsMode), Ord(AMode)),\r\n GetEnumName(TypeInfo(TJclStringListObjectsMode), Ord(FObjectsMode))]);\r\n end;\r\n FObjectsMode := AMode;\r\n end;\r\nend;\r\n\r\nfunction TJclStringList.GetKeyList(const AKey: string): IJclStringList;\r\nbegin\r\n Result := KeyInterface[AKey] as IJclStringList;\r\n if Result = nil then\r\n begin\r\n Result := JclStringList;\r\n KeyInterface[AKey] := Result;\r\n end;\r\nend;\r\n\r\nprocedure TJclStringList.SetKeyList(const AKey: string; const Value: IJclStringList);\r\nbegin\r\n KeyInterface[AKey] := Value;\r\nend;\r\n\r\nfunction TJclStringList.Delete(AIndex: Integer): IJclStringList;\r\nbegin\r\n if CanFreeObjects then\r\n inherited Objects[AIndex].Free;\r\n inherited Delete(AIndex);\r\n Result := FSelfAsInterface;\r\nend;\r\n\r\nfunction TJclStringList.Delete(const AString: string): IJclStringList;\r\nbegin\r\n Result := Delete(IndexOf(AString));\r\nend;\r\n\r\nfunction TJclStringList.Exchange(Index1, Index2: Integer): IJclStringList;\r\nbegin\r\n inherited Exchange(Index1, Index2);\r\n Result := FSelfAsInterface;\r\nend;\r\n\r\nfunction LocalSort(List: TStringList; Index1, Index2: Integer): Integer;\r\nbegin\r\n Result := TJclStringList(List).FCompareFunction(TJclStringList(List).FSelfAsInterface, Index1, Index2);\r\nend;\r\n\r\nfunction TJclStringList.Sort(ACompareFunction: TJclStringListSortCompare = nil): IJclStringList;\r\nbegin\r\n FCompareFunction := ACompareFunction;\r\n if not Assigned(ACompareFunction) then\r\n inherited Sort\r\n else\r\n inherited CustomSort(@LocalSort);\r\n Result := FSelfAsInterface;\r\nend;\r\n\r\nfunction LocalSortAsInteger(List: TStringList; Index1, Index2: Integer): Integer;\r\nbegin\r\n Result := StrToInt(List[Index1]) - StrToInt(List[Index2]);\r\nend;\r\n\r\nfunction TJclStringList.SortAsInteger: IJclStringList;\r\nbegin\r\n inherited CustomSort(@LocalSortAsInteger);\r\n Result := FSelfAsInterface;\r\nend;\r\n\r\n{$IFNDEF HAS_TSTRINGS_COMPARESTRINGS}\r\nfunction TJclStringList.CompareStrings(const S1, S2: string): Integer;\r\nbegin\r\n Result := AnsiCompareText(S1, S2);\r\nend;\r\n{$ENDIF ~HAS_TSTRINGS_COMPARESTRINGS}\r\n\r\nfunction LocalSortByName(List: TStringList; Index1, Index2: Integer): Integer;\r\nbegin\r\n Result := TJclStringList(List).CompareStrings(List.Names[Index1], List.Names[Index2]);\r\nend;\r\n\r\nfunction TJclStringList.SortByName: IJclStringList;\r\nbegin\r\n inherited CustomSort(@LocalSortByName);\r\n Result := FSelfAsInterface;\r\nend;\r\n\r\nfunction TJclStringList.Insert(Index: Integer; const S: string): IJclStringList;\r\nbegin\r\n inherited Insert(Index, S);\r\n Result := FSelfAsInterface;\r\nend;\r\n\r\nfunction TJclStringList.InsertObject(Index: Integer; const S: string; AObject: TObject): IJclStringList;\r\nbegin\r\n inherited InsertObject(Index, S, AObject);\r\n Result := FSelfAsInterface;\r\nend;\r\n\r\nfunction TJclStringList.GetCaseSensitive: Boolean;\r\nbegin\r\n Result := inherited CaseSensitive;\r\nend;\r\n\r\nfunction TJclStringList.GetDuplicates: TDuplicates;\r\nbegin\r\n Result := inherited Duplicates;\r\nend;\r\n\r\nfunction TJclStringList.GetOnChange: TNotifyEvent;\r\nbegin\r\n Result := inherited OnChange;\r\nend;\r\n\r\nfunction TJclStringList.GetOnChanging: TNotifyEvent;\r\nbegin\r\n Result := inherited OnChanging;\r\nend;\r\n\r\nfunction TJclStringList.GetSorted: Boolean;\r\nbegin\r\n Result := inherited Sorted;\r\nend;\r\n\r\nprocedure TJclStringList.SetCaseSensitive(const Value: Boolean);\r\nbegin\r\n inherited CaseSensitive := Value;\r\nend;\r\n\r\nprocedure TJclStringList.SetDuplicates(const Value: TDuplicates);\r\nbegin\r\n inherited Duplicates := Value;\r\nend;\r\n\r\nprocedure TJclStringList.SetOnChange(const Value: TNotifyEvent);\r\nbegin\r\n inherited OnChange := Value;\r\nend;\r\n\r\nprocedure TJclStringList.SetOnChanging(const Value: TNotifyEvent);\r\nbegin\r\n inherited OnChanging := Value;\r\nend;\r\n\r\nprocedure TJclStringList.SetSorted(const Value: Boolean);\r\nbegin\r\n inherited Sorted := Value;\r\nend;\r\n\r\nfunction TJclStringList.LoadFromFile(const FileName: string): IJclStringList;\r\nbegin\r\n inherited LoadFromFile(FileName);\r\n Result := FSelfAsInterface;\r\nend;\r\n\r\nfunction TJclStringList.LoadFromStream(Stream: TStream): IJclStringList;\r\nbegin\r\n inherited LoadFromStream(Stream);\r\n Result := FSelfAsInterface;\r\nend;\r\n\r\nfunction TJclStringList.SaveToFile(const FileName: string): IJclStringList;\r\nbegin\r\n inherited SaveToFile(FileName);\r\n Result := FSelfAsInterface;\r\nend;\r\n\r\nfunction TJclStringList.SaveToStream(Stream: TStream): IJclStringList;\r\nbegin\r\n inherited SaveToStream(Stream);\r\n Result := FSelfAsInterface;\r\nend;\r\n\r\nfunction TJclStringList.GetCommaText: string;\r\nbegin\r\n Result := inherited CommaText;\r\nend;\r\n\r\nfunction TJclStringList.GetDelimitedText: string;\r\nbegin\r\n Result := inherited DelimitedText;\r\nend;\r\n\r\nfunction TJclStringList.GetDelimiter: Char;\r\nbegin\r\n Result := inherited Delimiter;\r\nend;\r\n\r\nfunction TJclStringList.GetName(Index: Integer): string;\r\nbegin\r\n Result := inherited Names[Index];\r\nend;\r\n\r\n{$IFDEF COMPILER7_UP}\r\n\r\nfunction TJclStringList.GetNameValueSeparator: Char;\r\nbegin\r\n Result := inherited NameValueSeparator;\r\nend;\r\n\r\nfunction TJclStringList.GetValueFromIndex(Index: Integer): string;\r\nbegin\r\n Result := inherited ValueFromIndex[Index];\r\nend;\r\n\r\n{$ENDIF COMPILER7_UP}\r\n\r\nfunction TJclStringList.GetQuoteChar: Char;\r\nbegin\r\n Result := inherited QuoteChar;\r\nend;\r\n\r\nprocedure TJclStringList.SetCommaText(const Value: string);\r\nbegin\r\n inherited CommaText := Value;\r\nend;\r\n\r\nprocedure TJclStringList.SetDelimitedText(const Value: string);\r\nbegin\r\n inherited DelimitedText := Value;\r\nend;\r\n\r\nprocedure TJclStringList.SetDelimiter(const Value: Char);\r\nbegin\r\n inherited Delimiter := Value;\r\nend;\r\n\r\n{$IFDEF COMPILER7_UP}\r\n\r\nprocedure TJclStringList.SetNameValueSeparator(const Value: Char);\r\nbegin\r\n inherited NameValueSeparator := Value;\r\nend;\r\n\r\nprocedure TJclStringList.SetValueFromIndex(Index: Integer; const Value: string);\r\nbegin\r\n inherited ValueFromIndex[Index] := Value;\r\nend;\r\n\r\n{$ENDIF COMPILER7_UP}\r\n\r\nprocedure TJclStringList.SetQuoteChar(const Value: Char);\r\nbegin\r\n inherited QuoteChar := Value;\r\nend;\r\n\r\nfunction TJclStringList.Delimit(const ADelimiter: string): IJclStringList;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := BeginUpdate;\r\n try\r\n for I := 0 to LastIndex do\r\n Strings[I] := ADelimiter + Strings[I] + ADelimiter;\r\n finally\r\n Result := EndUpdate;\r\n end;\r\nend;\r\n\r\nfunction TJclStringList.LoadExeParams: IJclStringList;\r\nvar\r\n I: Integer;\r\n S: string;\r\nbegin\r\n Result := BeginUpdate;\r\n try\r\n Clear;\r\n for I := 1 to ParamCount do\r\n begin\r\n S := ParamStr(I);\r\n if (S[1] = '-') or (S[1] = '/') then\r\n System.Delete(S, 1, 1);\r\n Add(S);\r\n end;\r\n finally\r\n Result := EndUpdate;\r\n end;\r\nend;\r\n\r\nfunction TJclStringList.Exists(const S: string): Boolean;\r\nbegin\r\n Result := IndexOf(S) >= 0;\r\nend;\r\n\r\nfunction TJclStringList.ExistsName(const S: string): Boolean;\r\nbegin\r\n Result := IndexOfName(S) >= 0;\r\nend;\r\n\r\nfunction TJclStringList.DeleteBlanks: IJclStringList;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := BeginUpdate;\r\n try\r\n for I := LastIndex downto 0 do\r\n if {$IFDEF HAS_UNITSCOPE}System.{$ENDIF}SysUtils.Trim(Strings[I]) = '' then\r\n Delete(I);\r\n finally\r\n Result := EndUpdate;\r\n end;\r\nend;\r\n\r\nfunction TJclStringList.KeepIntegers: IJclStringList;\r\nvar\r\n I, X: Integer;\r\nbegin\r\n Result := BeginUpdate;\r\n try\r\n X := 0;\r\n for I := LastIndex downto 0 do\r\n if not TryStrToInt(Strings[I], X) then\r\n Delete(I);\r\n finally\r\n Result := EndUpdate;\r\n end;\r\nend;\r\n\r\nfunction TJclStringList.DeleteIntegers: IJclStringList;\r\nvar\r\n I, X: Integer;\r\nbegin\r\n Result := BeginUpdate;\r\n try\r\n X := 0;\r\n for I := LastIndex downto 0 do\r\n if TryStrToInt(Strings[I], X) then\r\n Delete(I);\r\n finally\r\n Result := EndUpdate;\r\n end;\r\nend;\r\n\r\nfunction TJclStringList.FreeObjects(AFreeAndNil: Boolean = False): IJclStringList;\r\nvar\r\n I: Integer;\r\nbegin\r\n if AFreeAndNil then\r\n Result := BeginUpdate;\r\n for I := 0 to LastIndex do\r\n begin\r\n inherited Objects[I].Free;\r\n if AFreeAndNil then\r\n inherited Objects[I] := nil;\r\n end;\r\n if AFreeAndNil then\r\n Result := EndUpdate\r\n else\r\n Result := FSelfAsInterface;\r\nend;\r\n\r\nfunction TJclStringList.ReleaseInterfaces: IJclStringList;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := BeginUpdate;\r\n try\r\n for I := 0 to LastIndex do\r\n Interfaces[I] := nil;\r\n finally\r\n Result := EndUpdate;\r\n end;\r\nend;\r\n\r\nfunction TJclStringList.Clone: IJclStringList;\r\nbegin\r\n Result := JclStringList.Assign(Self);\r\nend;\r\n\r\nfunction TJclStringList.Assign(Source: TPersistent): IJclStringList;\r\nvar\r\n L: TJclStringList;\r\n I: Integer;\r\nbegin\r\n inherited Assign(Source);\r\n Result := FSelfAsInterface;\r\n if Source is TJclStringList then\r\n begin\r\n L := TJclStringList(Source);\r\n FObjectsMode := L.FObjectsMode;\r\n if not (FObjectsMode in [omNone, omObjects]) then\r\n begin\r\n Result := BeginUpdate;\r\n try\r\n for I := 0 to LastIndex do\r\n begin\r\n inherited Objects[I] := nil;\r\n case FObjectsMode of\r\n omVariants:\r\n Variants[I] := L.Variants[I];\r\n omInterfaces:\r\n Interfaces[I] := L.Interfaces[I];\r\n end;\r\n end;\r\n finally\r\n Result := EndUpdate;\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJclStringList.CanFreeObjects: Boolean;\r\nbegin\r\n Result := not (FObjectsMode in [omNone, omObjects]);\r\nend;\r\n\r\nfunction TJclStringList.GetObjectsMode: TJclStringListObjectsMode;\r\nbegin\r\n Result := FObjectsMode;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jcl/source/common/JclStrings.pas", "content": "{**************************************************************************************************}\r\n{ }\r\n{ Project JEDI Code Library (JCL) }\r\n{ }\r\n{ The contents of this file are subject to the Mozilla Public License Version 1.1 (the \"License\"); }\r\n{ you may not use this file except in compliance with the License. You may obtain a copy of the }\r\n{ License at http://www.mozilla.org/MPL/ }\r\n{ }\r\n{ Software distributed under the License is distributed on an \"AS IS\" basis, WITHOUT WARRANTY OF }\r\n{ ANY KIND, either express or implied. See the License for the specific language governing rights }\r\n{ and limitations under the License. }\r\n{ }\r\n{ The Original Code is JclStrings.pas. }\r\n{ }\r\n{ The Initial Developer of the Original Code is Marcel van Brakel. }\r\n{ Portions created by Marcel van Brakel are Copyright (C) Marcel van Brakel. All rights reserved. }\r\n{ }\r\n{ Contributor(s): }\r\n{ Alexander Radchenko }\r\n{ Andreas Hausladen (ahuser) }\r\n{ Anthony Steele }\r\n{ Azret Botash }\r\n{ Barry Kelly }\r\n{ Huanlin Tsai }\r\n{ Jack N.A. Bakker }\r\n{ Jean-Fabien Connault (cycocrew) }\r\n{ John C Molyneux }\r\n{ Kiriakos Vlahos }\r\n{ Leonard Wennekers }\r\n{ Marcel Bestebroer }\r\n{ Martin Kimmings }\r\n{ Martin Kubecka }\r\n{ Massimo Maria Ghisalberti }\r\n{ Matthias Thoma (mthoma) }\r\n{ Michael Winter }\r\n{ Nick Hodges }\r\n{ Olivier Sannier (obones) }\r\n{ Pelle F. S. Liljendal }\r\n{ Petr Vones (pvones) }\r\n{ Rik Barker (rikbarker) }\r\n{ Robert Lee }\r\n{ Robert Marquardt (marquardt) }\r\n{ Robert Rossmair (rrossmair) }\r\n{ Andreas Schmidt }\r\n{ Sean Farrow (sfarrow) }\r\n{ }\r\n{**************************************************************************************************}\r\n{ }\r\n{ Various character and string routines (searching, testing and transforming) }\r\n{ }\r\n{**************************************************************************************************}\r\n{ }\r\n{ Last modified: $Date:: 2012-03-11 18:27:44 +0100 (dim. 11 mars 2012) $ }\r\n{ Revision: $Rev:: 3770 $ }\r\n{ Author: $Author:: obones $ }\r\n{ }\r\n{**************************************************************************************************}\r\n\r\nunit JclStrings;\r\n\r\n{$I jcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n {$IFDEF HAS_UNITSCOPE}\r\n {$IFDEF MSWINDOWS}\r\n Winapi.Windows,\r\n {$ENDIF MSWINDOWS}\r\n {$IFDEF UNICODE_RTL_DATABASE}\r\n System.Character,\r\n {$ENDIF UNICODE_RTL_DATABASE}\r\n System.Classes, System.SysUtils,\r\n {$ELSE ~HAS_UNITSCOPE}\r\n {$IFDEF MSWINDOWS}\r\n Windows,\r\n {$ENDIF MSWINDOWS}\r\n {$IFDEF UNICODE_RTL_DATABASE}\r\n Character,\r\n {$ENDIF UNICODE_RTL_DATABASE}\r\n Classes, SysUtils,\r\n {$ENDIF ~HAS_UNITSCOPE}\r\n JclAnsiStrings,\r\n JclWideStrings,\r\n JclBase;\r\n\r\n// Exceptions\r\ntype\r\n EJclStringError = class(EJclError);\r\n\r\n// Character constants and sets\r\n\r\nconst\r\n // Misc. often used character definitions\r\n NativeNull = Char(#0);\r\n NativeSoh = Char(#1);\r\n NativeStx = Char(#2);\r\n NativeEtx = Char(#3);\r\n NativeEot = Char(#4);\r\n NativeEnq = Char(#5);\r\n NativeAck = Char(#6);\r\n NativeBell = Char(#7);\r\n NativeBackspace = Char(#8);\r\n NativeTab = Char(#9);\r\n NativeLineFeed = JclBase.NativeLineFeed;\r\n NativeVerticalTab = Char(#11);\r\n NativeFormFeed = Char(#12);\r\n NativeCarriageReturn = JclBase.NativeCarriageReturn;\r\n NativeCrLf = JclBase.NativeCrLf;\r\n NativeSo = Char(#14);\r\n NativeSi = Char(#15);\r\n NativeDle = Char(#16);\r\n NativeDc1 = Char(#17);\r\n NativeDc2 = Char(#18);\r\n NativeDc3 = Char(#19);\r\n NativeDc4 = Char(#20);\r\n NativeNak = Char(#21);\r\n NativeSyn = Char(#22);\r\n NativeEtb = Char(#23);\r\n NativeCan = Char(#24);\r\n NativeEm = Char(#25);\r\n NativeEndOfFile = Char(#26);\r\n NativeEscape = Char(#27);\r\n NativeFs = Char(#28);\r\n NativeGs = Char(#29);\r\n NativeRs = Char(#30);\r\n NativeUs = Char(#31);\r\n NativeSpace = Char(' ');\r\n NativeComma = Char(',');\r\n NativeBackslash = Char('\\');\r\n NativeForwardSlash = Char('/');\r\n\r\n NativeDoubleQuote = Char('\"');\r\n NativeSingleQuote = Char('''');\r\n\r\n NativeLineBreak = JclBase.NativeLineBreak;\r\n\r\nconst\r\n // CharType return values\r\n C1_UPPER = $0001; // Uppercase\r\n C1_LOWER = $0002; // Lowercase\r\n C1_DIGIT = $0004; // Decimal digits\r\n C1_SPACE = $0008; // Space characters\r\n C1_PUNCT = $0010; // Punctuation\r\n C1_CNTRL = $0020; // Control characters\r\n C1_BLANK = $0040; // Blank characters\r\n C1_XDIGIT = $0080; // Hexadecimal digits\r\n C1_ALPHA = $0100; // Any linguistic character: alphabetic, syllabary, or ideographic\r\n\r\n {$IFDEF MSWINDOWS}\r\n {$IFDEF SUPPORTS_EXTSYM}\r\n {$EXTERNALSYM C1_UPPER}\r\n {$EXTERNALSYM C1_LOWER}\r\n {$EXTERNALSYM C1_DIGIT}\r\n {$EXTERNALSYM C1_SPACE}\r\n {$EXTERNALSYM C1_PUNCT}\r\n {$EXTERNALSYM C1_CNTRL}\r\n {$EXTERNALSYM C1_BLANK}\r\n {$EXTERNALSYM C1_XDIGIT}\r\n {$EXTERNALSYM C1_ALPHA}\r\n {$ENDIF SUPPORTS_EXTSYM}\r\n {$ENDIF MSWINDOWS}\r\n\r\ntype\r\n TCharValidator = function(const C: Char): Boolean;\r\n\r\nfunction ArrayContainsChar(const Chars: array of Char; const C: Char): Boolean; overload;\r\nfunction ArrayContainsChar(const Chars: array of Char; const C: Char; out Index: SizeInt): Boolean; overload;\r\n\r\n// String Test Routines\r\nfunction StrIsAlpha(const S: string): Boolean;\r\nfunction StrIsAlphaNum(const S: string): Boolean;\r\nfunction StrIsAlphaNumUnderscore(const S: string): Boolean;\r\nfunction StrContainsChars(const S: string; const Chars: TCharValidator; CheckAll: Boolean): Boolean; overload;\r\nfunction StrContainsChars(const S: string; const Chars: array of Char; CheckAll: Boolean): Boolean; overload;\r\nfunction StrConsistsOfNumberChars(const S: string): Boolean;\r\nfunction StrIsDigit(const S: string): Boolean;\r\nfunction StrIsSubset(const S: string; const ValidChars: TCharValidator): Boolean; overload;\r\nfunction StrIsSubset(const S: string; const ValidChars: array of Char): Boolean; overload;\r\nfunction StrSame(const S1, S2: string; CaseSensitive: Boolean = False): Boolean;\r\n\r\n// String Transformation Routines\r\nfunction StrCenter(const S: string; L: SizeInt; C: Char = ' '): string;\r\nfunction StrCharPosLower(const S: string; CharPos: SizeInt): string;\r\nfunction StrCharPosUpper(const S: string; CharPos: SizeInt): string;\r\nfunction StrDoubleQuote(const S: string): string;\r\nfunction StrEnsureNoPrefix(const Prefix, Text: string): string;\r\nfunction StrEnsureNoSuffix(const Suffix, Text: string): string;\r\nfunction StrEnsurePrefix(const Prefix, Text: string): string;\r\nfunction StrEnsureSuffix(const Suffix, Text: string): string;\r\nfunction StrEscapedToString(const S: string): string;\r\nfunction StrLower(const S: string): string;\r\nprocedure StrLowerInPlace(var S: string);\r\nprocedure StrLowerBuff(S: PChar);\r\nprocedure StrMove(var Dest: string; const Source: string; const ToIndex,\r\n FromIndex, Count: SizeInt);\r\nfunction StrPadLeft(const S: string; Len: SizeInt; C: Char = NativeSpace): string;\r\nfunction StrPadRight(const S: string; Len: SizeInt; C: Char = NativeSpace): string;\r\nfunction StrProper(const S: string): string;\r\nprocedure StrProperBuff(S: PChar);\r\nfunction StrQuote(const S: string; C: Char): string;\r\nfunction StrRemoveChars(const S: string; const Chars: TCharValidator): string; overload;\r\nfunction StrRemoveChars(const S: string; const Chars: array of Char): string; overload;\r\nfunction StrRemoveLeadingChars(const S: string; const Chars: TCharValidator): string; overload;\r\nfunction StrRemoveLeadingChars(const S: string; const Chars: array of Char): string; overload;\r\nfunction StrRemoveEndChars(const S: string; const Chars: TCharValidator): string; overload;\r\nfunction StrRemoveEndChars(const S: string; const Chars: array of Char): string; overload;\r\nfunction StrKeepChars(const S: string; const Chars: TCharValidator): string; overload;\r\nfunction StrKeepChars(const S: string; const Chars: array of Char): string; overload;\r\nprocedure StrReplace(var S: string; const Search, Replace: string; Flags: TReplaceFlags = []);\r\nfunction StrReplaceChar(const S: string; const Source, Replace: Char): string;\r\nfunction StrReplaceChars(const S: string; const Chars: TCharValidator; Replace: Char): string; overload;\r\nfunction StrReplaceChars(const S: string; const Chars: array of Char; Replace: Char): string; overload;\r\nfunction StrReplaceButChars(const S: string; const Chars: TCharValidator; Replace: Char): string; overload;\r\nfunction StrReplaceButChars(const S: string; const Chars: array of Char; Replace: Char): string; overload;\r\nfunction StrRepeat(const S: string; Count: SizeInt): string;\r\nfunction StrRepeatLength(const S: string; L: SizeInt): string;\r\nfunction StrReverse(const S: string): string;\r\nprocedure StrReverseInPlace(var S: string);\r\nfunction StrSingleQuote(const S: string): string;\r\nprocedure StrSkipChars(var S: PChar; const Chars: TCharValidator); overload;\r\nprocedure StrSkipChars(var S: PChar; const Chars: array of Char); overload;\r\nprocedure StrSkipChars(const S: string; var Index: SizeInt; const Chars: TCharValidator); overload;\r\nprocedure StrSkipChars(const S: string; var Index: SizeInt; const Chars: array of Char); overload;\r\nfunction StrSmartCase(const S: string; const Delimiters: TCharValidator): string; overload;\r\nfunction StrSmartCase(const S: string; const Delimiters: array of Char): string; overload;\r\nfunction StrStringToEscaped(const S: string): string;\r\nfunction StrStripNonNumberChars(const S: string): string;\r\nfunction StrToHex(const Source: string): string;\r\nfunction StrTrimCharLeft(const S: string; C: Char): string;\r\nfunction StrTrimCharsLeft(const S: string; const Chars: TCharValidator): string; overload;\r\nfunction StrTrimCharsLeft(const S: string; const Chars: array of Char): string; overload;\r\nfunction StrTrimCharRight(const S: string; C: Char): string;\r\nfunction StrTrimCharsRight(const S: string; const Chars: TCharValidator): string; overload;\r\nfunction StrTrimCharsRight(const S: string; const Chars: array of Char): string; overload;\r\nfunction StrTrimQuotes(const S: string): string;\r\nfunction StrUpper(const S: string): string;\r\nprocedure StrUpperInPlace(var S: string);\r\nprocedure StrUpperBuff(S: PChar);\r\n\r\n// String Management\r\nprocedure StrAddRef(var S: string);\r\nprocedure StrDecRef(var S: string);\r\nfunction StrLength(const S: string): SizeInt;\r\nfunction StrRefCount(const S: string): SizeInt;\r\n\r\n// String Search and Replace Routines\r\nfunction StrCharCount(const S: string; C: Char): SizeInt; overload;\r\nfunction StrCharsCount(const S: string; const Chars: TCharValidator): SizeInt; overload;\r\nfunction StrCharsCount(const S: string; const Chars: array of Char): SizeInt; overload;\r\nfunction StrStrCount(const S, SubS: string): SizeInt;\r\nfunction StrCompare(const S1, S2: string; CaseSensitive: Boolean = False): SizeInt;\r\nfunction StrCompareRange(const S1, S2: string; Index, Count: SizeInt; CaseSensitive: Boolean = True): SizeInt;\r\nfunction StrCompareRangeEx(const S1, S2: string; Index, Count: SizeInt; CaseSensitive: Boolean): SizeInt;\r\nprocedure StrFillChar(var S; Count: SizeInt; C: Char);\r\nfunction StrRepeatChar(C: Char; Count: SizeInt): string;\r\nfunction StrFind(const Substr, S: string; const Index: SizeInt = 1): SizeInt;\r\nfunction StrHasPrefix(const S: string; const Prefixes: array of string): Boolean;\r\nfunction StrHasSuffix(const S: string; const Suffixes: array of string): Boolean;\r\nfunction StrIndex(const S: string; const List: array of string; CaseSensitive: Boolean = False): SizeInt;\r\nfunction StrIHasPrefix(const S: string; const Prefixes: array of string): Boolean;\r\nfunction StrIHasSuffix(const S: string; const Suffixes: array of string): Boolean;\r\nfunction StrILastPos(const SubStr, S: string): SizeInt;\r\nfunction StrIPos(const SubStr, S: string): SizeInt;\r\nfunction StrIPrefixIndex(const S: string; const Prefixes: array of string): SizeInt;\r\nfunction StrIsOneOf(const S: string; const List: array of string): Boolean;\r\nfunction StrISuffixIndex(const S: string; const Suffixes: array of string): SizeInt;\r\nfunction StrLastPos(const SubStr, S: string): SizeInt;\r\nfunction StrMatch(const Substr, S: string; Index: SizeInt = 1): SizeInt;\r\nfunction StrMatches(const Substr, S: string; const Index: SizeInt = 1): Boolean;\r\nfunction StrNIPos(const S, SubStr: string; N: SizeInt): SizeInt;\r\nfunction StrNPos(const S, SubStr: string; N: SizeInt): SizeInt;\r\nfunction StrPrefixIndex(const S: string; const Prefixes: array of string): SizeInt;\r\nfunction StrSearch(const Substr, S: string; const Index: SizeInt = 1): SizeInt;\r\nfunction StrSuffixIndex(const S: string; const Suffixes: array of string): SizeInt;\r\n\r\n// String Extraction\r\n// Returns the String before SubStr\r\nfunction StrAfter(const SubStr, S: string): string;\r\n/// Returns the string after SubStr\r\nfunction StrBefore(const SubStr, S: string): string;\r\n/// Splits a string at SubStr, returns true when SubStr is found, Left contains the\r\n/// string before the SubStr and Rigth the string behind SubStr\r\nfunction StrSplit(const SubStr, S: string;var Left, Right : string): boolean;\r\n/// Returns the string between Start and Stop\r\nfunction StrBetween(const S: string; const Start, Stop: Char): string;\r\n/// Returns the left N characters of the string\r\nfunction StrChopRight(const S: string; N: SizeInt): string;\r\n/// Returns the left Count characters of the string\r\nfunction StrLeft(const S: string; Count: SizeInt): string;\r\n/// Returns the string starting from position Start for the Count Characters\r\nfunction StrMid(const S: string; Start, Count: SizeInt): string;\r\n/// Returns the string starting from position N to the end\r\nfunction StrRestOf(const S: string; N: SizeInt): string;\r\n/// Returns the right Count characters of the string\r\nfunction StrRight(const S: string; Count: SizeInt): string;\r\n\r\n// Character Test Routines\r\nfunction CharEqualNoCase(const C1, C2: Char): Boolean; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\nfunction CharIsAlpha(const C: Char): Boolean; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\nfunction CharIsAlphaNum(const C: Char): Boolean; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\nfunction CharIsBlank(const C: Char): Boolean; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\nfunction CharIsControl(const C: Char): Boolean; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\nfunction CharIsDelete(const C: Char): Boolean; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\nfunction CharIsDigit(const C: Char): Boolean; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\nfunction CharIsFracDigit(const C: Char): Boolean; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\nfunction CharIsHexDigit(const C: Char): Boolean; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\nfunction CharIsLower(const C: Char): Boolean; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\nfunction CharIsNumberChar(const C: Char): Boolean; {$IFDEF SUPPORTS_INLINE} {$IFDEF COMPILER16_UP} inline; {$ENDIF} {$ENDIF}\r\nfunction CharIsNumber(const C: Char): Boolean; {$IFDEF SUPPORTS_INLINE} {$IFDEF COMPILER16_UP} inline; {$ENDIF} {$ENDIF}\r\nfunction CharIsPrintable(const C: Char): Boolean; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\nfunction CharIsPunctuation(const C: Char): Boolean; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\nfunction CharIsReturn(const C: Char): Boolean; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\nfunction CharIsSpace(const C: Char): Boolean; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\nfunction CharIsUpper(const C: Char): Boolean; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\nfunction CharIsValidIdentifierLetter(const C: Char): Boolean; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\nfunction CharIsWhiteSpace(const C: Char): Boolean; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\nfunction CharIsWildcard(const C: Char): Boolean; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\nfunction CharType(const C: Char): Word;\r\n\r\n// Character Transformation Routines\r\nfunction CharHex(const C: Char): Byte;\r\nfunction CharLower(const C: Char): Char; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\nfunction CharUpper(const C: Char): Char; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\nfunction CharToggleCase(const C: Char): Char;\r\n\r\n// Character Search and Replace\r\nfunction CharPos(const S: string; const C: Char; const Index: SizeInt = 1): SizeInt;\r\nfunction CharLastPos(const S: string; const C: Char; const Index: SizeInt = 1): SizeInt;\r\nfunction CharIPos(const S: string; C: Char; const Index: SizeInt = 1): SizeInt;\r\nfunction CharReplace(var S: string; const Search, Replace: Char): SizeInt;\r\n\r\n// PCharVector\r\ntype\r\n PCharVector = ^PChar;\r\n\r\nfunction StringsToPCharVector(var Dest: PCharVector; const Source: TStrings): PCharVector;\r\nfunction PCharVectorCount(Source: PCharVector): SizeInt;\r\nprocedure PCharVectorToStrings(const Dest: TStrings; Source: PCharVector);\r\nprocedure FreePCharVector(var Dest: PCharVector);\r\n\r\n// MultiSz Routines\r\ntype\r\n PMultiSz = PChar;\r\n PAnsiMultiSz = JclAnsiStrings.PAnsiMultiSz;\r\n PWideMultiSz = JclWideStrings.PWideMultiSz;\r\n\r\n TAnsiStrings = JclAnsiStrings.TJclAnsiStrings;\r\n TWideStrings = JclWideStrings.TJclWideStrings;\r\n TAnsiStringList = JclAnsiStrings.TJclAnsiStringList;\r\n TWideStringList = JclWideStrings.TJclWideStringList;\r\n\r\nfunction StringsToMultiSz(var Dest: PMultiSz; const Source: TStrings): PMultiSz;\r\nprocedure MultiSzToStrings(const Dest: TStrings; const Source: PMultiSz);\r\nfunction MultiSzLength(const Source: PMultiSz): SizeInt;\r\nprocedure AllocateMultiSz(var Dest: PMultiSz; Len: SizeInt);\r\nprocedure FreeMultiSz(var Dest: PMultiSz);\r\nfunction MultiSzDup(const Source: PMultiSz): PMultiSz;\r\n\r\nfunction AnsiStringsToAnsiMultiSz(var Dest: PAnsiMultiSz; const Source: TAnsiStrings): PAnsiMultiSz;\r\n {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\nprocedure AnsiMultiSzToAnsiStrings(const Dest: TAnsiStrings; const Source: PAnsiMultiSz); {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\nfunction AnsiMultiSzLength(const Source: PAnsiMultiSz): SizeInt; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\nprocedure AllocateAnsiMultiSz(var Dest: PAnsiMultiSz; Len: SizeInt); {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\nprocedure FreeAnsiMultiSz(var Dest: PAnsiMultiSz); {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\nfunction AnsiMultiSzDup(const Source: PAnsiMultiSz): PAnsiMultiSz; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\n\r\nfunction WideStringsToWideMultiSz(var Dest: PWideMultiSz; const Source: TWideStrings): PWideMultiSz;\r\n {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\nprocedure WideMultiSzToWideStrings(const Dest: TWideStrings; const Source: PWideMultiSz); {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\nfunction WideMultiSzLength(const Source: PWideMultiSz): SizeInt; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\nprocedure AllocateWideMultiSz(var Dest: PWideMultiSz; Len: SizeInt); {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\nprocedure FreeWideMultiSz(var Dest: PWideMultiSz); {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\nfunction WideMultiSzDup(const Source: PWideMultiSz): PWideMultiSz; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\n\r\n// TStrings Manipulation\r\nprocedure StrIToStrings(S, Sep: string; const List: TStrings; const AllowEmptyString: Boolean = True);\r\nprocedure StrToStrings(S, Sep: string; const List: TStrings; const AllowEmptyString: Boolean = True);\r\nfunction StringsToStr(const List: TStrings; const Sep: string; const AllowEmptyString: Boolean = True): string; overload;\r\nfunction StringsToStr(const List: TStrings; const Sep: string; const NumberOfItems: SizeInt; const AllowEmptyString:\r\n Boolean = True): string; overload;\r\nprocedure TrimStrings(const List: TStrings; DeleteIfEmpty: Boolean = True);\r\nprocedure TrimStringsRight(const List: TStrings; DeleteIfEmpty: Boolean = True);\r\nprocedure TrimStringsLeft(const List: TStrings; DeleteIfEmpty: Boolean = True);\r\nfunction AddStringToStrings(const S: string; Strings: TStrings; const Unique: Boolean): Boolean;\r\n\r\n// Miscellaneous\r\n// (OF) moved to JclSysUtils\r\n// function BooleanToStr(B: Boolean): string;\r\n // AnsiString here because it is binary data\r\nfunction FileToString(const FileName: string): {$IFDEF COMPILER12_UP}RawByteString{$ELSE}AnsiString{$ENDIF};\r\nprocedure StringToFile(const FileName: string; const Contents: {$IFDEF COMPILER12_UP}RawByteString{$ELSE}AnsiString{$ENDIF};\r\n Append: Boolean = False);\r\n\r\nfunction StrToken(var S: string; Separator: Char): string;\r\nprocedure StrTokens(const S: string; const List: TStrings);\r\nprocedure StrTokenToStrings(S: string; Separator: Char; const List: TStrings);\r\nfunction StrWord(const S: string; var Index: SizeInt; out Word: string): Boolean; overload;\r\nfunction StrWord(var S: PChar; out Word: string): Boolean; overload;\r\nfunction StrIdent(const S: string; var Index: SizeInt; out Ident: string): Boolean; overload;\r\nfunction StrIdent(var S: PChar; out Ident: string): Boolean; overload;\r\nfunction StrToFloatSafe(const S: string): Float;\r\nfunction StrToIntSafe(const S: string): Integer;\r\nprocedure StrNormIndex(const StrLen: SizeInt; var Index: SizeInt; var Count: SizeInt); overload;\r\n\r\nfunction ArrayOf(List: TStrings): TDynStringArray; overload;\r\n\r\ntype\r\n FormatException = class(EJclError);\r\n ArgumentException = class(EJclError);\r\n ArgumentNullException = class(EJclError);\r\n ArgumentOutOfRangeException = class(EJclError);\r\n\r\n IToString = interface\r\n ['{C4ABABB4-1029-46E7-B5FA-99800F130C05}']\r\n function ToString: string;\r\n end;\r\n\r\n TCharDynArray = array of Char;\r\n\r\n // The TStringBuilder class is a Delphi implementation of the .NET\r\n // System.Text.StringBuilder.\r\n // It is zero based and the method that allow an TObject (Append, Insert,\r\n // AppendFormat) are limited to IToString implementors.\r\n // This class is not threadsafe. Any instance of TStringBuilder should not\r\n // be used in different threads at the same time.\r\n TJclStringBuilder = class(TInterfacedObject, IToString)\r\n private\r\n FChars: TCharDynArray;\r\n FLength: SizeInt;\r\n FMaxCapacity: SizeInt;\r\n\r\n function GetCapacity: SizeInt;\r\n procedure SetCapacity(const Value: SizeInt);\r\n function GetChars(Index: SizeInt): Char;\r\n procedure SetChars(Index: SizeInt; const Value: Char);\r\n procedure Set_Length(const Value: SizeInt);\r\n protected\r\n function AppendPChar(Value: PChar; Count: SizeInt; RepeatCount: SizeInt = 1): TJclStringBuilder;\r\n function InsertPChar(Index: SizeInt; Value: PChar; Count: SizeInt; RepeatCount: SizeInt = 1): TJclStringBuilder;\r\n public\r\n constructor Create(const Value: string; Capacity: SizeInt = 16); overload;\r\n constructor Create(Capacity: SizeInt = 16; MaxCapacity: SizeInt = MaxInt); overload;\r\n constructor Create(const Value: string; StartIndex, Length, Capacity: SizeInt); overload;\r\n\r\n function Append(const Value: string): TJclStringBuilder; overload;\r\n function Append(const Value: string; StartIndex, Length: SizeInt): TJclStringBuilder; overload;\r\n function Append(Value: Boolean): TJclStringBuilder; overload;\r\n function Append(Value: Char; RepeatCount: SizeInt = 1): TJclStringBuilder; overload;\r\n function Append(const Value: array of Char): TJclStringBuilder; overload;\r\n function Append(const Value: array of Char; StartIndex, Length: SizeInt): TJclStringBuilder; overload;\r\n function Append(Value: Cardinal): TJclStringBuilder; overload;\r\n function Append(Value: Integer): TJclStringBuilder; overload;\r\n function Append(Value: Double): TJclStringBuilder; overload;\r\n function Append(Value: Int64): TJclStringBuilder; overload;\r\n function Append(Obj: TObject): TJclStringBuilder; overload;\r\n function AppendFormat(const Fmt: string; const Args: array of const): TJclStringBuilder; overload;\r\n function AppendFormat(const Fmt: string; Arg0: Variant): TJclStringBuilder; overload;\r\n function AppendFormat(const Fmt: string; Arg0, Arg1: Variant): TJclStringBuilder; overload;\r\n function AppendFormat(const Fmt: string; Arg0, Arg1, Arg2: Variant): TJclStringBuilder; overload;\r\n\r\n function Insert(Index: SizeInt; const Value: string; Count: SizeInt = 1): TJclStringBuilder; overload;\r\n function Insert(Index: SizeInt; Value: Boolean): TJclStringBuilder; overload;\r\n function Insert(Index: SizeInt; const Value: array of Char): TJclStringBuilder; overload;\r\n function Insert(Index: SizeInt; const Value: array of Char; StartIndex, Length: SizeInt): TJclStringBuilder;\r\n overload;\r\n function Insert(Index: SizeInt; Value: Cardinal): TJclStringBuilder; overload;\r\n function Insert(Index: SizeInt; Value: Integer): TJclStringBuilder; overload;\r\n function Insert(Index: SizeInt; Value: Double): TJclStringBuilder; overload;\r\n function Insert(Index: SizeInt; Value: Int64): TJclStringBuilder; overload;\r\n function Insert(Index: SizeInt; Obj: TObject): TJclStringBuilder; overload;\r\n\r\n function Replace(OldChar, NewChar: Char; StartIndex: SizeInt = 0; Count: SizeInt = -1): TJclStringBuilder;\r\n overload;\r\n function Replace(OldValue, NewValue: string; StartIndex: SizeInt = 0; Count: SizeInt = -1): TJclStringBuilder;\r\n overload;\r\n\r\n function Remove(StartIndex, Length: SizeInt): TJclStringBuilder;\r\n function EnsureCapacity(Capacity: SizeInt): SizeInt;\r\n\r\n { IToString }\r\n function ToString: string; {$IFDEF RTL200_UP} override; {$ENDIF RTL200_UP}\r\n\r\n property __Chars__[Index: SizeInt]: Char read GetChars write SetChars; default;\r\n property Chars: TCharDynArray read FChars;\r\n property Length: SizeInt read FLength write Set_Length;\r\n property Capacity: SizeInt read GetCapacity write SetCapacity;\r\n property MaxCapacity: SizeInt read FMaxCapacity;\r\n end;\r\n\r\n {$IFDEF RTL200_UP}\r\n TStringBuilder = {$IFDEF HAS_UNITSCOPE}System.{$ENDIF}SysUtils.TStringBuilder;\r\n {$ELSE ~RTL200_UP}\r\n TStringBuilder = TJclStringBuilder;\r\n {$ENDIF ~RTL200_UP}\r\n\r\n// DotNetFormat() uses the .NET format style: \"{argX}\"\r\nfunction DotNetFormat(const Fmt: string; const Args: array of const): string; overload;\r\nfunction DotNetFormat(const Fmt: string; const Arg0: Variant): string; overload;\r\nfunction DotNetFormat(const Fmt: string; const Arg0, Arg1: Variant): string; overload;\r\nfunction DotNetFormat(const Fmt: string; const Arg0, Arg1, Arg2: Variant): string; overload;\r\n\r\n// TJclTabSet\r\ntype\r\n TJclTabSet = class (TInterfacedObject, IToString)\r\n private\r\n FData: TObject;\r\n function GetCount: SizeInt;\r\n function GetStops(Index: SizeInt): SizeInt;\r\n function GetTabWidth: SizeInt;\r\n function GetZeroBased: Boolean;\r\n procedure SetStops(Index, Value: SizeInt);\r\n procedure SetTabWidth(Value: SizeInt);\r\n procedure SetZeroBased(Value: Boolean);\r\n protected\r\n function FindStop(Column: SizeInt): SizeInt;\r\n function InternalTabStops: TDynSizeIntArray;\r\n function InternalTabWidth: SizeInt;\r\n procedure RemoveAt(Index: SizeInt);\r\n public\r\n constructor Create; overload;\r\n constructor Create(Data: TObject); overload;\r\n constructor Create(TabWidth: SizeInt); overload;\r\n constructor Create(const Tabstops: array of SizeInt; ZeroBased: Boolean); overload;\r\n constructor Create(const Tabstops: array of SizeInt; ZeroBased: Boolean; TabWidth: SizeInt); overload;\r\n destructor Destroy; override;\r\n\r\n // cloning and referencing\r\n function Clone: TJclTabSet;\r\n function NewReference: TJclTabSet;\r\n\r\n // Tab stops manipulation\r\n function Add(Column: SizeInt): SizeInt;\r\n function Delete(Column: SizeInt): SizeInt;\r\n\r\n // Usage\r\n function Expand(const S: string): string; overload;\r\n function Expand(const S: string; Column: SizeInt): string; overload;\r\n procedure OptimalFillInfo(StartColumn, TargetColumn: SizeInt; out TabsNeeded, SpacesNeeded: SizeInt);\r\n function Optimize(const S: string): string; overload;\r\n function Optimize(const S: string; Column: SizeInt): string; overload;\r\n function StartColumn: SizeInt;\r\n function TabFrom(Column: SizeInt): SizeInt;\r\n function UpdatePosition(const S: string): SizeInt; overload;\r\n function UpdatePosition(const S: string; Column: SizeInt): SizeInt; overload;\r\n function UpdatePosition(const S: string; var Column, Line: SizeInt): SizeInt; overload;\r\n\r\n { IToString }\r\n function ToString: string; overload; {$IFDEF RTL200_UP} override; {$ENDIF RTL200_UP}\r\n // Conversions\r\n function ToString(FormattingOptions: SizeInt): string; {$IFDEF RTL200_UP} reintroduce; {$ENDIF RTL200_UP} overload;\r\n class function FromString(const S: string): TJclTabSet; {$IFDEF SUPPORTS_STATIC} static; {$ENDIF SUPPORTS_STATIC}\r\n\r\n // Properties\r\n property ActualTabWidth: SizeInt read InternalTabWidth;\r\n property Count: SizeInt read GetCount;\r\n property TabStops[Index: SizeInt]: SizeInt read GetStops write SetStops; default;\r\n property TabWidth: SizeInt read GetTabWidth write SetTabWidth;\r\n property ZeroBased: Boolean read GetZeroBased write SetZeroBased;\r\n end;\r\n\r\n// Formatting constants\r\nconst\r\n TabSetFormatting_SurroundStopsWithBrackets = 1;\r\n TabSetFormatting_EmptyBracketsIfNoStops = 2;\r\n TabSetFormatting_NoTabStops = 4;\r\n TabSetFormatting_NoTabWidth = 8;\r\n TabSetFormatting_AutoTabWidth = 16;\r\n // common combinations\r\n TabSetFormatting_Default = 0;\r\n TabSetFormatting_AlwaysUseBrackets = TabSetFormatting_SurroundStopsWithBrackets or\r\n TabSetFormatting_EmptyBracketsIfNoStops;\r\n TabSetFormatting_Full = TabSetFormatting_AlwaysUseBrackets or TabSetFormatting_AutoTabWidth;\r\n // aliases\r\n TabSetFormatting_StopsOnly = TabSetFormatting_NoTabWidth;\r\n TabSetFormatting_TabWidthOnly = TabSetFormatting_NoTabStops;\r\n TabSetFormatting_StopsWithoutBracketsAndTabWidth = TabSetFormatting_Default;\r\n\r\n// Tab expansion routines\r\nfunction StrExpandTabs(S: string): string; {$IFDEF SUPPORTS_INLINE}inline; {$ENDIF} overload;\r\nfunction StrExpandTabs(S: string; TabWidth: SizeInt): string; {$IFDEF SUPPORTS_INLINE}inline; {$ENDIF} overload;\r\nfunction StrExpandTabs(S: string; TabSet: TJclTabSet): string; {$IFDEF SUPPORTS_INLINE}inline; {$ENDIF} overload;\r\n// Tab optimization routines\r\nfunction StrOptimizeTabs(S: string): string; {$IFDEF SUPPORTS_INLINE}inline; {$ENDIF} overload;\r\nfunction StrOptimizeTabs(S: string; TabWidth: SizeInt): string; {$IFDEF SUPPORTS_INLINE}inline; {$ENDIF} overload;\r\nfunction StrOptimizeTabs(S: string; TabSet: TJclTabSet): string; {$IFDEF SUPPORTS_INLINE}inline; {$ENDIF} overload;\r\n\r\n// move to JclBase?\r\ntype\r\n NullReferenceException = class(EJclError)\r\n public\r\n constructor Create; overload;\r\n end;\r\n\r\nprocedure StrResetLength(var S: WideString); overload;\r\nprocedure StrResetLength(var S: AnsiString); overload;\r\nprocedure StrResetLength(S: TJclStringBuilder); overload;\r\n{$IFDEF SUPPORTS_UNICODE_STRING}\r\nprocedure StrResetLength(var S: UnicodeString); overload;\r\n{$ENDIF SUPPORTS_UNICODE_STRING}\r\n\r\n// natural comparison functions\r\nfunction CompareNaturalStr(const S1, S2: string): SizeInt;\r\nfunction CompareNaturalText(const S1, S2: string): SizeInt;\r\n\r\n{$IFNDEF UNICODE_RTL_DATABASE}\r\n// internal structures published to make function inlining working\r\nconst\r\n MaxStrCharCount = Ord(High(Char)) + 1; // # of chars in one set\r\n StrLoOffset = MaxStrCharCount * 0; // offset to lower case chars\r\n StrUpOffset = MaxStrCharCount * 1; // offset to upper case chars\r\n StrReOffset = MaxStrCharCount * 2; // offset to reverse case chars\r\n StrCaseMapSize = MaxStrCharCount * 3; // # of chars is a table\r\n\r\nvar\r\n StrCaseMap: array [0..StrCaseMapSize - 1] of Char; // case mappings\r\n StrCaseMapReady: Boolean = False; // true if case map exists\r\n StrCharTypes: array [Char] of Word;\r\n{$ENDIF ~UNICODE_RTL_DATABASE}\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jcl.svn.sourceforge.net/svnroot/jcl/tags/JCL-2.4-Build4571/jcl/source/common/JclStrings.pas $';\r\n Revision: '$Revision: 3770 $';\r\n Date: '$Date: 2012-03-11 18:27:44 +0100 (dim. 11 mars 2012) $';\r\n LogPath: 'JCL\\source\\common';\r\n Extra: '';\r\n Data: nil\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n {$IFDEF HAS_UNIT_LIBC}\r\n Libc,\r\n {$ENDIF HAS_UNIT_LIBC}\r\n {$IFDEF SUPPORTS_UNICODE}\r\n {$IFDEF HAS_UNITSCOPE}\r\n System.StrUtils,\r\n {$ELSE ~HAS_UNITSCOPE}\r\n StrUtils,\r\n {$ENDIF ~HAS_UNITSCOPE}\r\n {$ENDIF SUPPORTS_UNICODE}\r\n JclLogic, JclResources, JclStreams, JclSynch, JclSysUtils;\r\n\r\n//=== Internal ===============================================================\r\n\r\ntype\r\n TStrRec = packed record\r\n RefCount: Longint;\r\n Length: Longint;\r\n end;\r\n PStrRec = ^TStrRec;\r\n\r\n{$IFNDEF UNICODE_RTL_DATABASE}\r\nprocedure LoadCharTypes;\r\nvar\r\n CurrChar: Char;\r\n CurrType: Word;\r\nbegin\r\n for CurrChar := Low(CurrChar) to High(CurrChar) do\r\n begin\r\n {$IFDEF MSWINDOWS}\r\n CurrType := 0;\r\n GetStringTypeEx(LOCALE_USER_DEFAULT, CT_CTYPE1, @CurrChar, 1, CurrType);\r\n {$DEFINE CHAR_TYPES_INITIALIZED}\r\n {$ENDIF MSWINDOWS}\r\n {$IFDEF LINUX}\r\n CurrType := 0;\r\n if isupper(Byte(CurrChar)) <> 0 then\r\n CurrType := CurrType or C1_UPPER;\r\n if islower(Byte(CurrChar)) <> 0 then\r\n CurrType := CurrType or C1_LOWER;\r\n if isdigit(Byte(CurrChar)) <> 0 then\r\n CurrType := CurrType or C1_DIGIT;\r\n if isspace(Byte(CurrChar)) <> 0 then\r\n CurrType := CurrType or C1_SPACE;\r\n if ispunct(Byte(CurrChar)) <> 0 then\r\n CurrType := CurrType or C1_PUNCT;\r\n if iscntrl(Byte(CurrChar)) <> 0 then\r\n CurrType := CurrType or C1_CNTRL;\r\n if isblank(Byte(CurrChar)) <> 0 then\r\n CurrType := CurrType or C1_BLANK;\r\n if isxdigit(Byte(CurrChar)) <> 0 then\r\n CurrType := CurrType or C1_XDIGIT;\r\n if isalpha(Byte(CurrChar)) <> 0 then\r\n CurrType := CurrType or C1_ALPHA;\r\n {$DEFINE CHAR_TYPES_INITIALIZED}\r\n {$ENDIF LINUX}\r\n StrCharTypes[CurrChar] := CurrType;\r\n {$IFNDEF CHAR_TYPES_INITIALIZED}\r\n Implement case map initialization here\r\n {$ENDIF ~CHAR_TYPES_INITIALIZED}\r\n end;\r\nend;\r\n\r\nprocedure LoadCaseMap;\r\nvar\r\n CurrChar, UpCaseChar, LoCaseChar, ReCaseChar: Char;\r\nbegin\r\n if not StrCaseMapReady then\r\n begin\r\n for CurrChar := Low(Char) to High(Char) do\r\n begin\r\n {$IFDEF MSWINDOWS}\r\n LoCaseChar := CurrChar;\r\n UpCaseChar := CurrChar;\r\n {$IFDEF HAS_UNITSCOPE}Winapi.{$ENDIF}Windows.CharLowerBuff(@LoCaseChar, 1);\r\n {$IFDEF HAS_UNITSCOPE}Winapi.{$ENDIF}Windows.CharUpperBuff(@UpCaseChar, 1);\r\n {$DEFINE CASE_MAP_INITIALIZED}\r\n {$ENDIF MSWINDOWS}\r\n {$IFDEF LINUX}\r\n LoCaseChar := Char(tolower(Byte(CurrChar)));\r\n UpCaseChar := Char(toupper(Byte(CurrChar)));\r\n {$DEFINE CASE_MAP_INITIALIZED}\r\n {$ENDIF LINUX}\r\n {$IFNDEF CASE_MAP_INITIALIZED}\r\n Implement case map initialization here\r\n {$ENDIF ~CASE_MAP_INITIALIZED}\r\n if CharIsUpper(CurrChar) then\r\n ReCaseChar := LoCaseChar\r\n else\r\n if CharIsLower(CurrChar) then\r\n ReCaseChar := UpCaseChar\r\n else\r\n ReCaseChar := CurrChar;\r\n StrCaseMap[Ord(CurrChar) + StrLoOffset] := LoCaseChar;\r\n StrCaseMap[Ord(CurrChar) + StrUpOffset] := UpCaseChar;\r\n StrCaseMap[Ord(CurrChar) + StrReOffset] := ReCaseChar;\r\n end;\r\n StrCaseMapReady := True;\r\n end;\r\nend;\r\n\r\n// Uppercases or Lowercases a give string depending on the\r\n// passed offset. (UpOffset or LoOffset)\r\n\r\nprocedure StrCase(var Str: string; const Offset: SizeInt);\r\nvar\r\n P: PChar;\r\n I, L: SizeInt;\r\nbegin\r\n L := Length(Str);\r\n if L > 0 then\r\n begin\r\n UniqueString(Str);\r\n P := PChar(Str);\r\n for I := 1 to L do\r\n begin\r\n P^ := StrCaseMap[Offset + Ord(P^)];\r\n Inc(P);\r\n end;\r\n end;\r\nend;\r\n\r\n// Internal utility function\r\n// Uppercases or Lowercases a give null terminated string depending on the\r\n// passed offset. (UpOffset or LoOffset)\r\n\r\nprocedure StrCaseBuff(S: PChar; const Offset: SizeInt);\r\nvar\r\n C: Char;\r\nbegin\r\n if S <> nil then\r\n begin\r\n repeat\r\n C := S^;\r\n S^ := StrCaseMap[Offset + Ord(C)];\r\n Inc(S);\r\n until C = #0;\r\n end;\r\nend;\r\n{$ENDIF ~UNICODE_RTL_DATABASE}\r\n\r\nfunction StrEndW(Str: PWideChar): PWideChar;\r\nbegin\r\n Result := Str;\r\n while Result^ <> #0 do\r\n Inc(Result);\r\nend;\r\n\r\nfunction ArrayContainsChar(const Chars: array of Char; const C: Char): Boolean;\r\nvar\r\n idx: SizeInt;\r\nbegin\r\n Result := ArrayContainsChar(Chars, C, idx);\r\nend;\r\n\r\nfunction ArrayContainsChar(const Chars: array of Char; const C: Char; out Index: SizeInt): Boolean;\r\n{ optimized version for sorted arrays\r\nvar\r\n I, L, H: SizeInt;\r\nbegin\r\n L := Low(Chars);\r\n H := High(Chars);\r\n while L <= H do\r\n begin\r\n I := (L + H) div 2;\r\n if C = Chars[I] then\r\n begin\r\n Result := True;\r\n Exit;\r\n end\r\n else\r\n if C < Chars[I] then\r\n H := I - 1\r\n else\r\n // C > Chars[I]\r\n L := I + 1;\r\n end;\r\n Result := False;\r\nend;}\r\nbegin\r\n Index := High(Chars);\r\n while (Index >= Low(Chars)) and (Chars[Index] <> C) do\r\n Dec(Index);\r\n Result := Index >= Low(Chars);\r\nend;\r\n\r\n// String Test Routines\r\nfunction StrIsAlpha(const S: string): Boolean;\r\nvar\r\n I: SizeInt;\r\nbegin\r\n Result := S <> '';\r\n for I := 1 to Length(S) do\r\n begin\r\n if not CharIsAlpha(S[I]) then\r\n begin\r\n Result := False;\r\n Exit;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction StrIsAlphaNum(const S: string): Boolean;\r\nvar\r\n I: SizeInt;\r\nbegin\r\n Result := S <> '';\r\n for I := 1 to Length(S) do\r\n begin\r\n if not CharIsAlphaNum(S[I]) then\r\n begin\r\n Result := False;\r\n Exit;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction StrConsistsofNumberChars(const S: string): Boolean;\r\nvar\r\n I: SizeInt;\r\nbegin\r\n Result := S <> '';\r\n for I := 1 to Length(S) do\r\n begin\r\n if not CharIsNumberChar(S[I]) then\r\n begin\r\n Result := False;\r\n Exit;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction StrContainsChars(const S: string; const Chars: TCharValidator; CheckAll: Boolean): Boolean;\r\nvar\r\n I: SizeInt;\r\nbegin\r\n Result := False;\r\n if CheckAll then\r\n begin\r\n // this will not work with the current definition of the validator. The validator would need to check each character\r\n // it requires against the string (which is currently not provided to the Validator). The current implementation of\r\n // CheckAll will check if all characters in S will be accepted by the provided Validator, which is wrong and incon-\r\n // sistent with the documentation and the array-based overload.\r\n for I := 1 to Length(S) do\r\n begin\r\n Result := Chars(S[I]);\r\n if not Result then\r\n Break;\r\n end;\r\n end\r\n else\r\n begin\r\n for I := 1 to Length(S) do\r\n begin\r\n Result := Chars(S[I]);\r\n if Result then\r\n Break;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction StrContainsChars(const S: string; const Chars: array of Char; CheckAll: Boolean): Boolean;\r\nvar\r\n I: SizeInt;\r\nbegin\r\n if CheckAll then\r\n begin\r\n Result := True;\r\n I := High(Chars);\r\n while (I >= 0) and Result do\r\n begin\r\n Result := CharPos(S, Chars[I]) > 0;\r\n Dec(I);\r\n end;\r\n end\r\n else\r\n begin\r\n Result := False;\r\n for I := 1 to Length(S) do\r\n begin\r\n Result := ArrayContainsChar(Chars, S[I]);\r\n if Result then\r\n Break;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction StrIsAlphaNumUnderscore(const S: string): Boolean;\r\nvar\r\n I: SizeInt;\r\n C: Char;\r\nbegin\r\n for I := 1 to Length(S) do\r\n begin\r\n C := S[I];\r\n\r\n if not (CharIsAlphaNum(C) or (C = '_')) then\r\n begin\r\n Result := False;\r\n Exit;\r\n end;\r\n end;\r\n\r\n Result := Length(S) > 0;\r\nend;\r\n\r\nfunction StrIsDigit(const S: string): Boolean;\r\nvar\r\n I: SizeInt;\r\nbegin\r\n Result := S <> '';\r\n for I := 1 to Length(S) do\r\n begin\r\n if not CharIsDigit(S[I]) then\r\n begin\r\n Result := False;\r\n Exit;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction StrIsSubset(const S: string; const ValidChars: TCharValidator): Boolean;\r\nvar\r\n I: SizeInt;\r\nbegin\r\n for I := 1 to Length(S) do\r\n begin\r\n Result := ValidChars(S[I]);\r\n if not Result then\r\n Exit;\r\n end;\r\n\r\n Result := Length(S) > 0;\r\nend;\r\n\r\nfunction StrIsSubset(const S: string; const ValidChars: array of Char): Boolean;\r\nvar\r\n I: SizeInt;\r\nbegin\r\n for I := 1 to Length(S) do\r\n begin\r\n Result := ArrayContainsChar(ValidChars, S[I]);\r\n if not Result then\r\n Exit;\r\n end;\r\n\r\n Result := Length(S) > 0;\r\nend;\r\n\r\nfunction StrSame(const S1, S2: string; CaseSensitive: Boolean): Boolean;\r\nbegin\r\n Result := StrCompare(S1, S2, CaseSensitive) = 0;\r\nend;\r\n\r\n//=== String Transformation Routines =========================================\r\n\r\nfunction StrCenter(const S: string; L: SizeInt; C: Char = ' '): string;\r\nbegin\r\n if Length(S) < L then\r\n begin\r\n Result := StringOfChar(C, (L - Length(S)) div 2) + S;\r\n Result := Result + StringOfChar(C, L - Length(Result));\r\n end\r\n else\r\n Result := S;\r\nend;\r\n\r\nfunction StrCharPosLower(const S: string; CharPos: SizeInt): string;\r\nbegin\r\n Result := S;\r\n if (CharPos > 0) and (CharPos <= Length(S)) then\r\n Result[CharPos] := CharLower(Result[CharPos]);\r\nend;\r\n\r\nfunction StrCharPosUpper(const S: string; CharPos: SizeInt): string;\r\nbegin\r\n Result := S;\r\n if (CharPos > 0) and (CharPos <= Length(S)) then\r\n Result[CharPos] := CharUpper(Result[CharPos]);\r\nend;\r\n\r\nfunction StrDoubleQuote(const S: string): string;\r\nbegin\r\n Result := NativeDoubleQuote + S + NativeDoubleQuote;\r\nend;\r\n\r\nfunction StrEnsureNoPrefix(const Prefix, Text: string): string;\r\nvar\r\n PrefixLen: SizeInt;\r\nbegin\r\n PrefixLen := Length(Prefix);\r\n if Copy(Text, 1, PrefixLen) = Prefix then\r\n Result := Copy(Text, PrefixLen + 1, Length(Text))\r\n else\r\n Result := Text;\r\nend;\r\n\r\nfunction StrEnsureNoSuffix(const Suffix, Text: string): string;\r\nvar\r\n SuffixLen: SizeInt;\r\n StrLength: SizeInt;\r\nbegin\r\n SuffixLen := Length(Suffix);\r\n StrLength := Length(Text);\r\n if Copy(Text, StrLength - SuffixLen + 1, SuffixLen) = Suffix then\r\n Result := Copy(Text, 1, StrLength - SuffixLen)\r\n else\r\n Result := Text;\r\nend;\r\n\r\nfunction StrEnsurePrefix(const Prefix, Text: string): string;\r\nvar\r\n PrefixLen: SizeInt;\r\nbegin\r\n PrefixLen := Length(Prefix);\r\n if Copy(Text, 1, PrefixLen) = Prefix then\r\n Result := Text\r\n else\r\n Result := Prefix + Text;\r\nend;\r\n\r\nfunction StrEnsureSuffix(const Suffix, Text: string): string;\r\nvar\r\n SuffixLen: SizeInt;\r\nbegin\r\n SuffixLen := Length(Suffix);\r\n if Copy(Text, Length(Text) - SuffixLen + 1, SuffixLen) = Suffix then\r\n Result := Text\r\n else\r\n Result := Text + Suffix;\r\nend;\r\n\r\nfunction StrEscapedToString(const S: string): string;\r\n procedure HandleHexEscapeSeq(const S: string; var I: SizeInt; Len: SizeInt; var Dest: string);\r\n const\r\n HexDigits = string('0123456789abcdefABCDEF');\r\n var\r\n StartI, Val, N: SizeInt;\r\n begin\r\n StartI := I;\r\n N := Pos(S[I + 1], HexDigits) - 1;\r\n if N < 0 then\r\n // '\\x' without hex digit following is not escape sequence\r\n Dest := Dest + '\\x'\r\n else\r\n begin\r\n Inc(I); // Jump over x\r\n if N >= 16 then\r\n N := N - 6;\r\n Val := N;\r\n // Same for second digit\r\n if I < Len then\r\n begin\r\n N := Pos(S[I + 1], HexDigits) - 1;\r\n if N >= 0 then\r\n begin\r\n Inc(I); // Jump over first digit\r\n if N >= 16 then\r\n N := N - 6;\r\n Val := Val * 16 + N;\r\n end;\r\n end;\r\n\r\n if Val > Ord(High(Char)) then\r\n raise EJclStringError.CreateResFmt(@RsNumericConstantTooLarge, [Val, StartI]);\r\n\r\n Dest := Dest + Char(Val);\r\n end;\r\n end;\r\n\r\n procedure HandleOctEscapeSeq(const S: string; var I: SizeInt; Len: SizeInt; var Dest: string);\r\n const\r\n OctDigits = string('01234567');\r\n var\r\n StartI, Val, N: SizeInt;\r\n begin\r\n StartI := I;\r\n // first digit\r\n Val := Pos(S[I], OctDigits) - 1;\r\n if I < Len then\r\n begin\r\n N := Pos(S[I + 1], OctDigits) - 1;\r\n if N >= 0 then\r\n begin\r\n Inc(I);\r\n Val := Val * 8 + N;\r\n end;\r\n if I < Len then\r\n begin\r\n N := Pos(S[I + 1], OctDigits) - 1;\r\n if N >= 0 then\r\n begin\r\n Inc(I);\r\n Val := Val * 8 + N;\r\n end;\r\n end;\r\n end;\r\n\r\n if Val > Ord(High(Char)) then\r\n raise EJclStringError.CreateResFmt(@RsNumericConstantTooLarge, [Val, StartI]);\r\n\r\n Dest := Dest + Char(Val);\r\n end;\r\n\r\nvar\r\n I, Len: SizeInt;\r\nbegin\r\n Result := '';\r\n I := 1;\r\n Len := Length(S);\r\n while I <= Len do\r\n begin\r\n if not ((S[I] = '\\') and (I < Len)) then\r\n Result := Result + S[I]\r\n else\r\n begin\r\n Inc(I); // Jump over escape character\r\n case S[I] of\r\n 'a':\r\n Result := Result + NativeBell;\r\n 'b':\r\n Result := Result + NativeBackspace;\r\n 'f':\r\n Result := Result + NativeFormFeed;\r\n 'n':\r\n Result := Result + NativeLineFeed;\r\n 'r':\r\n Result := Result + NativeCarriageReturn;\r\n 't':\r\n Result := Result + NativeTab;\r\n 'v':\r\n Result := Result + NativeVerticalTab;\r\n '\\':\r\n Result := Result + '\\';\r\n '\"':\r\n Result := Result + '\"';\r\n '''':\r\n Result := Result + ''''; // Optionally escaped\r\n '?':\r\n Result := Result + '?'; // Optionally escaped\r\n 'x':\r\n if I < Len then\r\n // Start of hex escape sequence\r\n HandleHexEscapeSeq(S, I, Len, Result)\r\n else\r\n // '\\x' at end of string is not escape sequence\r\n Result := Result + '\\x';\r\n '0'..'7':\r\n // start of octal escape sequence\r\n HandleOctEscapeSeq(S, I, Len, Result);\r\n else\r\n // no escape sequence\r\n Result := Result + '\\' + S[I];\r\n end;\r\n end;\r\n Inc(I);\r\n end;\r\nend;\r\n\r\nfunction StrLower(const S: string): string;\r\nbegin\r\n Result := S;\r\n StrLowerInPlace(Result);\r\nend;\r\n\r\nprocedure StrLowerInPlace(var S: string);\r\n{$IFDEF UNICODE_RTL_DATABASE}\r\nvar\r\n P: PChar;\r\n I, L: SizeInt;\r\nbegin\r\n L := Length(S);\r\n if L > 0 then\r\n begin\r\n UniqueString(S);\r\n P := PChar(S);\r\n for I := 1 to L do\r\n begin\r\n P^ := TCharacter.ToLower(P^);\r\n Inc(P);\r\n end;\r\n end;\r\nend;\r\n{$ELSE ~UNICODE_RTL_DATABASE}\r\nbegin\r\n StrCase(S, StrLoOffset);\r\nend;\r\n{$ENDIF ~UNICODE_RTL_DATABASE}\r\n\r\nprocedure StrLowerBuff(S: PChar);\r\nbegin\r\n {$IFDEF UNICODE_RTL_DATABASE}\r\n if S <> nil then\r\n begin\r\n repeat\r\n S^ := TCharacter.ToLower(S^);\r\n Inc(S);\r\n until S^ = #0;\r\n end;\r\n {$ELSE ~UNICODE_RTL_DATABASE}\r\n StrCaseBuff(S, StrLoOffset);\r\n {$ENDIF ~UNICODE_RTL_DATABASE}\r\nend;\r\n\r\nprocedure StrMove(var Dest: string; const Source: string;\r\n const ToIndex, FromIndex, Count: SizeInt);\r\nbegin\r\n // Check strings\r\n if (Source = '') or (Length(Dest) = 0) then\r\n Exit;\r\n\r\n // Check FromIndex\r\n if (FromIndex <= 0) or (FromIndex > Length(Source)) or\r\n (ToIndex <= 0) or (ToIndex > Length(Dest)) or\r\n ((FromIndex + Count - 1) > Length(Source)) or ((ToIndex + Count - 1) > Length(Dest)) then\r\n { TODO : Is failure without notice the proper thing to do here? }\r\n Exit;\r\n\r\n // Move\r\n Move(Source[FromIndex], Dest[ToIndex], Count * SizeOf(Char));\r\nend;\r\n\r\nfunction StrPadLeft(const S: string; Len: SizeInt; C: Char): string;\r\nvar\r\n L: SizeInt;\r\nbegin\r\n L := Length(S);\r\n if L < Len then\r\n Result := StringOfChar(C, Len - L) + S\r\n else\r\n Result := S;\r\nend;\r\n\r\nfunction StrPadRight(const S: string; Len: SizeInt; C: Char): string;\r\nvar\r\n L: SizeInt;\r\nbegin\r\n L := Length(S);\r\n if L < Len then\r\n Result := S + StringOfChar(C, Len - L)\r\n else\r\n Result := S;\r\nend;\r\n\r\nfunction StrProper(const S: string): string;\r\nbegin\r\n Result := StrLower(S);\r\n if Result <> '' then\r\n Result[1] := UpCase(Result[1]);\r\nend;\r\n\r\nprocedure StrProperBuff(S: PChar);\r\nbegin\r\n if (S <> nil) and (S^ <> #0) then\r\n begin\r\n StrLowerBuff(S);\r\n S^ := CharUpper(S^);\r\n end;\r\nend;\r\n\r\nfunction StrQuote(const S: string; C: Char): string;\r\nvar\r\n L: SizeInt;\r\nbegin\r\n L := Length(S);\r\n Result := S;\r\n if L > 0 then\r\n begin\r\n if Result[1] <> C then\r\n begin\r\n Result := C + Result;\r\n Inc(L);\r\n end;\r\n if Result[L] <> C then\r\n Result := Result + C;\r\n end;\r\nend;\r\n\r\nfunction StrRemoveChars(const S: string; const Chars: TCharValidator): string;\r\nvar\r\n Source, Dest: PChar;\r\n Len, Index: SizeInt;\r\nbegin\r\n Len := Length(S);\r\n SetLength(Result, Len);\r\n UniqueString(Result);\r\n Source := PChar(S);\r\n Dest := PChar(Result);\r\n for Index := 0 to Len - 1 do\r\n begin\r\n if not Chars(Source^) then\r\n begin\r\n Dest^ := Source^;\r\n Inc(Dest);\r\n end;\r\n Inc(Source);\r\n end;\r\n SetLength(Result, Dest - PChar(Result));\r\nend;\r\n\r\nfunction StrRemoveChars(const S: string; const Chars: array of Char): string;\r\nvar\r\n Source, Dest: PChar;\r\n Len, Index: SizeInt;\r\nbegin\r\n Len := Length(S);\r\n SetLength(Result, Len);\r\n UniqueString(Result);\r\n Source := PChar(S);\r\n Dest := PChar(Result);\r\n for Index := 0 to Len - 1 do\r\n begin\r\n if not ArrayContainsChar(Chars, Source^) then\r\n begin\r\n Dest^ := Source^;\r\n Inc(Dest);\r\n end;\r\n Inc(Source);\r\n end;\r\n SetLength(Result, Dest - PChar(Result));\r\nend;\r\n\r\nfunction StrRemoveLeadingChars(const S: string; const Chars: TCharValidator): string;\r\nvar\r\n Len : SizeInt;\r\n I: SizeInt;\r\nbegin\r\n Len := Length(S);\r\n I := 1;\r\n while (I <= Len) and Chars(s[I]) do\r\n Inc(I);\r\n Result := Copy (s, I, Len-I+1);\r\nend;\r\n\r\nfunction StrRemoveLeadingChars(const S: string; const Chars: array of Char): string;\r\nvar\r\n Len : SizeInt;\r\n I: SizeInt;\r\nbegin\r\n Len := Length(S);\r\n I := 1;\r\n while (I <= Len) and ArrayContainsChar(Chars, s[I]) do\r\n Inc(I);\r\n Result := Copy (s, I, Len-I+1);\r\nend;\r\n\r\nfunction StrRemoveEndChars(const S: string; const Chars: TCharValidator): string;\r\nvar\r\n Len : SizeInt;\r\nbegin\r\n Len := Length(S);\r\n while (Len > 0) and Chars(s[Len]) do\r\n Dec(Len);\r\n Result := Copy (s, 1, Len);\r\nend;\r\n\r\nfunction StrRemoveEndChars(const S: string; const Chars: array of Char): string;\r\nvar\r\n Len : SizeInt;\r\nbegin\r\n Len := Length(S);\r\n while (Len > 0) and ArrayContainsChar(Chars, s[Len]) do\r\n Dec(Len);\r\n Result := Copy (s, 1, Len);\r\nend;\r\n\r\nfunction StrKeepChars(const S: string; const Chars: TCharValidator): string;\r\nvar\r\n Source, Dest: PChar;\r\n Len, Index: SizeInt;\r\nbegin\r\n Len := Length(S);\r\n SetLength(Result, Len);\r\n UniqueString(Result);\r\n Source := PChar(S);\r\n Dest := PChar(Result);\r\n for Index := 0 to Len - 1 do\r\n begin\r\n if Chars(Source^) then\r\n begin\r\n Dest^ := Source^;\r\n Inc(Dest);\r\n end;\r\n Inc(Source);\r\n end;\r\n SetLength(Result, Dest - PChar(Result));\r\nend;\r\n\r\nfunction StrKeepChars(const S: string; const Chars: array of Char): string;\r\nvar\r\n Source, Dest: PChar;\r\n Len, Index: SizeInt;\r\nbegin\r\n Len := Length(S);\r\n SetLength(Result, Len);\r\n UniqueString(Result);\r\n Source := PChar(S);\r\n Dest := PChar(Result);\r\n for Index := 0 to Len - 1 do\r\n begin\r\n if ArrayContainsChar(Chars, Source^) then\r\n begin\r\n Dest^ := Source^;\r\n Inc(Dest);\r\n end;\r\n Inc(Source);\r\n end;\r\n SetLength(Result, Dest - PChar(Result));\r\nend;\r\n\r\nfunction StrRepeat(const S: string; Count: SizeInt): string;\r\nvar\r\n Len, Index: SizeInt;\r\n Dest, Source: PChar;\r\nbegin\r\n Len := Length(S);\r\n SetLength(Result, Count * Len);\r\n Dest := PChar(Result);\r\n Source := PChar(S);\r\n if Dest <> nil then\r\n for Index := 0 to Count - 1 do\r\n begin\r\n Move(Source^, Dest^, Len * SizeOf(Char));\r\n Inc(Dest, Len);\r\n end;\r\nend;\r\n\r\nfunction StrRepeatLength(const S: string; L: SizeInt): string;\r\nvar\r\n Len: SizeInt;\r\n Dest: PChar;\r\nbegin\r\n Result := '';\r\n Len := Length(S);\r\n\r\n if (Len > 0) and (S <> '') then\r\n begin\r\n SetLength(Result, L);\r\n Dest := PChar(Result);\r\n while (L > 0) do\r\n begin\r\n Move(S[1], Dest^, Min(L, Len) * SizeOf(Char));\r\n Inc(Dest, Len);\r\n Dec(L, Len);\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure StrReplace(var S: string; const Search, Replace: string; Flags: TReplaceFlags);\r\nvar\r\n SearchStr: string;\r\n ResultStr: string; { result string }\r\n SourcePtr: PChar; { pointer into S of character under examination }\r\n SourceMatchPtr: PChar; { pointers into S and Search when first character has }\r\n SearchMatchPtr: PChar; { been matched and we're probing for a complete match }\r\n ResultPtr: PChar; { pointer into Result of character being written }\r\n ResultIndex,\r\n SearchLength, { length of search string }\r\n ReplaceLength, { length of replace string }\r\n BufferLength, { length of temporary result buffer }\r\n ResultLength: SizeInt; { length of result string }\r\n C: Char; { first character of search string }\r\n IgnoreCase: Boolean;\r\nbegin\r\n if Search = '' then\r\n begin\r\n if S = '' then\r\n begin\r\n S := Replace;\r\n Exit;\r\n end\r\n else\r\n raise EJclStringError.CreateRes(@RsBlankSearchString);\r\n end;\r\n\r\n if S <> '' then\r\n begin\r\n IgnoreCase := rfIgnoreCase in Flags;\r\n if IgnoreCase then\r\n SearchStr := StrUpper(Search)\r\n else\r\n SearchStr := Search;\r\n { avoid having to call Length() within the loop }\r\n SearchLength := Length(Search);\r\n ReplaceLength := Length(Replace);\r\n ResultLength := Length(S);\r\n BufferLength := ResultLength;\r\n SetLength(ResultStr, BufferLength);\r\n { get pointers to begin of source and result }\r\n ResultPtr := PChar(ResultStr);\r\n SourcePtr := PChar(S);\r\n C := SearchStr[1];\r\n { while we haven't reached the end of the string }\r\n while True do\r\n begin\r\n { copy characters until we find the first character of the search string }\r\n if IgnoreCase then\r\n while (CharUpper(SourcePtr^) <> C) and (SourcePtr^ <> #0) do\r\n begin\r\n ResultPtr^ := SourcePtr^;\r\n Inc(ResultPtr);\r\n Inc(SourcePtr);\r\n end\r\n else\r\n while (SourcePtr^ <> C) and (SourcePtr^ <> #0) do\r\n begin\r\n ResultPtr^ := SourcePtr^;\r\n Inc(ResultPtr);\r\n Inc(SourcePtr);\r\n end;\r\n { did we find that first character or did we hit the end of the string? }\r\n if SourcePtr^ = #0 then\r\n Break\r\n else\r\n begin\r\n { continue comparing, +1 because first character was matched already }\r\n SourceMatchPtr := SourcePtr + 1;\r\n SearchMatchPtr := PChar(SearchStr) + 1;\r\n if IgnoreCase then\r\n while (CharUpper(SourceMatchPtr^) = SearchMatchPtr^) and (SearchMatchPtr^ <> #0) do\r\n begin\r\n Inc(SourceMatchPtr);\r\n Inc(SearchMatchPtr);\r\n end\r\n else\r\n while (SourceMatchPtr^ = SearchMatchPtr^) and (SearchMatchPtr^ <> #0) do\r\n begin\r\n Inc(SourceMatchPtr);\r\n Inc(SearchMatchPtr);\r\n end;\r\n { did we find a complete match? }\r\n if SearchMatchPtr^ = #0 then\r\n begin\r\n // keep track of result length\r\n Inc(ResultLength, ReplaceLength - SearchLength);\r\n if ReplaceLength > 0 then\r\n begin\r\n // increase buffer size if required\r\n if ResultLength > BufferLength then\r\n begin\r\n BufferLength := ResultLength * 2;\r\n ResultIndex := ResultPtr - PChar(ResultStr) + 1;\r\n SetLength(ResultStr, BufferLength);\r\n ResultPtr := @ResultStr[ResultIndex];\r\n end;\r\n { append replace to result and move past the search string in source }\r\n Move((@Replace[1])^, ResultPtr^, ReplaceLength * SizeOf(Char));\r\n end;\r\n Inc(SourcePtr, SearchLength);\r\n Inc(ResultPtr, ReplaceLength);\r\n { replace all instances or just one? }\r\n if not (rfReplaceAll in Flags) then\r\n begin\r\n { just one, copy until end of source and break out of loop }\r\n while SourcePtr^ <> #0 do\r\n begin\r\n ResultPtr^ := SourcePtr^;\r\n Inc(ResultPtr);\r\n Inc(SourcePtr);\r\n end;\r\n Break;\r\n end;\r\n end\r\n else\r\n begin\r\n { copy current character and start over with the next }\r\n ResultPtr^ := SourcePtr^;\r\n Inc(ResultPtr);\r\n Inc(SourcePtr);\r\n end;\r\n end;\r\n end;\r\n { set result length and copy result into S }\r\n SetLength(ResultStr, ResultLength);\r\n S := ResultStr;\r\n end;\r\nend;\r\n\r\nfunction StrReplaceChar(const S: string; const Source, Replace: Char): string;\r\nvar\r\n I: SizeInt;\r\nbegin\r\n Result := S;\r\n for I := 1 to Length(S) do\r\n if Result[I] = Source then\r\n Result[I] := Replace;\r\nend;\r\n\r\nfunction StrReplaceChars(const S: string; const Chars: TCharValidator; Replace: Char): string;\r\nvar\r\n I: SizeInt;\r\nbegin\r\n Result := S;\r\n for I := 1 to Length(S) do\r\n if Chars(Result[I]) then\r\n Result[I] := Replace;\r\nend;\r\n\r\nfunction StrReplaceChars(const S: string; const Chars: array of Char; Replace: Char): string;\r\nvar\r\n I: SizeInt;\r\nbegin\r\n Result := S;\r\n for I := 1 to Length(S) do\r\n if ArrayContainsChar(Chars, Result[I]) then\r\n Result[I] := Replace;\r\nend;\r\n\r\nfunction StrReplaceButChars(const S: string; const Chars: TCharValidator;\r\n Replace: Char): string;\r\nvar\r\n I: SizeInt;\r\nbegin\r\n Result := S;\r\n for I := 1 to Length(S) do\r\n if not Chars(Result[I]) then\r\n Result[I] := Replace;\r\nend;\r\n\r\nfunction StrReplaceButChars(const S: string; const Chars: array of Char; Replace: Char): string;\r\nvar\r\n I: SizeInt;\r\nbegin\r\n Result := S;\r\n for I := 1 to Length(S) do\r\n if not ArrayContainsChar(Chars, Result[I]) then\r\n Result[I] := Replace;\r\nend;\r\n\r\nfunction StrReverse(const S: string): string;\r\nbegin\r\n Result := S;\r\n StrReverseInplace(Result);\r\nend;\r\n\r\nprocedure StrReverseInPlace(var S: string);\r\n{ TODO -oahuser : Warning: This is dangerous for unicode surrogates }\r\nvar\r\n P1, P2: PChar;\r\n C: Char;\r\nbegin\r\n UniqueString(S);\r\n P1 := PChar(S);\r\n P2 := P1 + (Length(S) - 1);\r\n while P1 < P2 do\r\n begin\r\n C := P1^;\r\n P1^ := P2^;\r\n P2^ := C;\r\n Inc(P1);\r\n Dec(P2);\r\n end;\r\nend;\r\n\r\nfunction StrSingleQuote(const S: string): string;\r\nbegin\r\n Result := NativeSingleQuote + S + NativeSingleQuote;\r\nend;\r\n\r\nprocedure StrSkipChars(var S: PChar; const Chars: TCharValidator);\r\nbegin\r\n while Chars(S^) do\r\n Inc(S);\r\nend;\r\n\r\nprocedure StrSkipChars(var S: PChar; const Chars: array of Char);\r\nbegin\r\n while ArrayContainsChar(Chars, S^) do\r\n Inc(S);\r\nend;\r\n\r\nprocedure StrSkipChars(const S: string; var Index: SizeInt; const Chars: TCharValidator);\r\nbegin\r\n while Chars(S[Index]) do\r\n Inc(Index);\r\nend;\r\n\r\nprocedure StrSkipChars(const S: string; var Index: SizeInt; const Chars: array of Char);\r\nbegin\r\n while ArrayContainsChar(Chars, S[Index]) do\r\n Inc(Index);\r\nend;\r\n\r\nfunction StrSmartCase(const S: string; const Delimiters: TCharValidator): string;\r\nvar\r\n Source, Dest: PChar;\r\n Index, Len: SizeInt;\r\n InternalDelimiters: TCharValidator;\r\nbegin\r\n Result := '';\r\n if Assigned(Delimiters) then\r\n InternalDelimiters := Delimiters\r\n else\r\n InternalDelimiters := CharIsSpace;\r\n\r\n if S <> '' then\r\n begin\r\n Result := S;\r\n UniqueString(Result);\r\n\r\n Len := Length(S);\r\n Source := PChar(S);\r\n Dest := PChar(Result);\r\n Inc(Dest);\r\n\r\n for Index := 2 to Len do\r\n begin\r\n if InternalDelimiters(Source^) and not InternalDelimiters(Dest^) then\r\n Dest^ := CharUpper(Dest^);\r\n Inc(Dest);\r\n Inc(Source);\r\n end;\r\n Result[1] := CharUpper(Result[1]);\r\n end;\r\nend;\r\n\r\nfunction StrSmartCase(const S: string; const Delimiters: array of Char): string;\r\nvar\r\n Source, Dest: PChar;\r\n Index, Len: SizeInt;\r\nbegin\r\n Result := '';\r\n\r\n if S <> '' then\r\n begin\r\n Result := S;\r\n UniqueString(Result);\r\n\r\n Len := Length(S);\r\n Source := PChar(S);\r\n Dest := PChar(Result);\r\n Inc(Dest);\r\n\r\n for Index := 2 to Len do\r\n begin\r\n if ArrayContainsChar(Delimiters, Source^) and not ArrayContainsChar(Delimiters, Dest^) then\r\n Dest^ := CharUpper(Dest^);\r\n Inc(Dest);\r\n Inc(Source);\r\n end;\r\n Result[1] := CharUpper(Result[1]);\r\n end;\r\nend;\r\n\r\nfunction StrStringToEscaped(const S: string): string;\r\nvar\r\n I: SizeInt;\r\nbegin\r\n Result := '';\r\n for I := 1 to Length(S) do\r\n begin\r\n case S[I] of\r\n NativeBackspace:\r\n Result := Result + '\\b';\r\n NativeBell:\r\n Result := Result + '\\a';\r\n NativeCarriageReturn:\r\n Result := Result + '\\r';\r\n NAtiveFormFeed:\r\n Result := Result + '\\f';\r\n NativeLineFeed:\r\n Result := Result + '\\n';\r\n NativeTab:\r\n Result := Result + '\\t';\r\n NativeVerticalTab:\r\n Result := Result + '\\v';\r\n NativeBackSlash:\r\n Result := Result + '\\\\';\r\n NativeDoubleQuote:\r\n Result := Result + '\\\"';\r\n else\r\n // Characters < ' ' are escaped with hex sequence\r\n if S[I] < #32 then\r\n Result := Result + Format('\\x%.2x', [SizeInt(S[I])])\r\n else\r\n Result := Result + S[I];\r\n end;\r\n end;\r\nend;\r\n\r\nfunction StrStripNonNumberChars(const S: string): string;\r\nvar\r\n I: SizeInt;\r\n C: Char;\r\nbegin\r\n Result := '';\r\n for I := 1 to Length(S) do\r\n begin\r\n C := S[I];\r\n if CharIsNumberChar(C) then\r\n Result := Result + C;\r\n end;\r\nend;\r\n\r\nfunction StrToHex(const Source: string): string;\r\nvar\r\n Index: SizeInt;\r\n C, L, N: SizeInt;\r\n BL, BH: Byte;\r\n S: string;\r\nbegin\r\n Result := '';\r\n if Source <> '' then\r\n begin\r\n S := Source;\r\n L := Length(S);\r\n if Odd(L) then\r\n begin\r\n S := '0' + S;\r\n Inc(L);\r\n end;\r\n Index := 1;\r\n SetLength(Result, L div 2);\r\n C := 1;\r\n N := 1;\r\n while C <= L do\r\n begin\r\n BH := CharHex(S[Index]);\r\n Inc(Index);\r\n BL := CharHex(S[Index]);\r\n Inc(Index);\r\n Inc(C, 2);\r\n if (BH = $FF) or (BL = $FF) then\r\n begin\r\n Result := '';\r\n Exit;\r\n end;\r\n Result[N] := Char((BH shl 4) or BL);\r\n Inc(N);\r\n end;\r\n end;\r\nend;\r\n\r\nfunction StrTrimCharLeft(const S: string; C: Char): string;\r\nvar\r\n I, L: SizeInt;\r\nbegin\r\n I := 1;\r\n L := Length(S);\r\n while (I <= L) and (S[I] = C) do\r\n Inc(I);\r\n Result := Copy(S, I, L - I + 1);\r\nend;\r\n\r\nfunction StrTrimCharsLeft(const S: string; const Chars: TCharValidator): string;\r\nvar\r\n I, L: SizeInt;\r\nbegin\r\n I := 1;\r\n L := Length(S);\r\n while (I <= L) and Chars(S[I]) do\r\n Inc(I);\r\n Result := Copy(S, I, L - I + 1);\r\nend;\r\n\r\nfunction StrTrimCharsLeft(const S: string; const Chars: array of Char): string;\r\nvar\r\n I, L: SizeInt;\r\nbegin\r\n I := 1;\r\n L := Length(S);\r\n while (I <= L) and ArrayContainsChar(Chars, S[I]) do\r\n Inc(I);\r\n Result := Copy(S, I, L - I + 1);\r\nend;\r\n\r\nfunction StrTrimCharRight(const S: string; C: Char): string;\r\nvar\r\n I: SizeInt;\r\nbegin\r\n I := Length(S);\r\n while (I >= 1) and (S[I] = C) do\r\n Dec(I);\r\n Result := Copy(S, 1, I);\r\nend;\r\n\r\nfunction StrTrimCharsRight(const S: string; const Chars: TCharValidator): string;\r\nvar\r\n I: SizeInt;\r\nbegin\r\n I := Length(S);\r\n while (I >= 1) and Chars(S[I]) do\r\n Dec(I);\r\n Result := Copy(S, 1, I);\r\nend;\r\n\r\nfunction StrTrimCharsRight(const S: string; const Chars: array of Char): string;\r\nvar\r\n I: SizeInt;\r\nbegin\r\n I := Length(S);\r\n while (I >= 1) and ArrayContainsChar(Chars, S[I]) do\r\n Dec(I);\r\n Result := Copy(S, 1, I);\r\nend;\r\n\r\nfunction StrTrimQuotes(const S: string): string;\r\nvar\r\n First, Last: Char;\r\n L: SizeInt;\r\nbegin\r\n L := Length(S);\r\n if L > 1 then\r\n begin\r\n First := S[1];\r\n Last := S[L];\r\n if (First = Last) and ((First = NativeSingleQuote) or (First = NativeDoubleQuote)) then\r\n Result := Copy(S, 2, L - 2)\r\n else\r\n Result := S;\r\n end\r\n else\r\n Result := S;\r\nend;\r\n\r\nfunction StrUpper(const S: string): string;\r\nbegin\r\n Result := S;\r\n StrUpperInPlace(Result);\r\nend;\r\n\r\nprocedure StrUpperInPlace(var S: string);\r\n{$IFDEF UNICODE_RTL_DATABASE}\r\nvar\r\n P: PChar;\r\n I, L: SizeInt;\r\nbegin\r\n L := Length(S);\r\n if L > 0 then\r\n begin\r\n UniqueString(S);\r\n P := PChar(S);\r\n for I := 1 to L do\r\n begin\r\n P^ := TCharacter.ToUpper(P^);\r\n Inc(P);\r\n end;\r\n end;\r\nend;\r\n{$ELSE ~UNICODE_RTL_DATABASE}\r\nbegin\r\n StrCase(S, StrUpOffset);\r\nend;\r\n{$ENDIF ~UNICODE_RTL_DATABASE}\r\n\r\nprocedure StrUpperBuff(S: PChar);\r\nbegin\r\n {$IFDEF UNICODE_RTL_DATABASE}\r\n if S <> nil then\r\n begin\r\n repeat\r\n S^ := TCharacter.ToUpper(S^);\r\n Inc(S);\r\n until S^ = #0;\r\n end;\r\n {$ELSE ~UNICODE_RTL_DATABASE}\r\n StrCaseBuff(S, StrUpOffset);\r\n {$ENDIF ~UNICODE_RTL_DATABASE}\r\nend;\r\n\r\n//=== String Management ======================================================\r\n\r\nprocedure StrAddRef(var S: string);\r\nvar\r\n P: PStrRec;\r\nbegin\r\n P := Pointer(S);\r\n if P <> nil then\r\n begin\r\n Dec(P);\r\n if P^.RefCount = -1 then\r\n UniqueString(S)\r\n else\r\n LockedInc(P^.RefCount);\r\n end;\r\nend;\r\n\r\nprocedure StrDecRef(var S: string);\r\nvar\r\n P: PStrRec;\r\nbegin\r\n P := Pointer(S);\r\n if P <> nil then\r\n begin\r\n Dec(P);\r\n case P^.RefCount of\r\n -1, 0: { nothing } ;\r\n 1:\r\n begin\r\n Finalize(S);\r\n Pointer(S) := nil;\r\n end;\r\n else\r\n LockedDec(P^.RefCount);\r\n end;\r\n end;\r\nend;\r\n\r\nfunction StrLength(const S: string): SizeInt;\r\nvar\r\n P: PStrRec;\r\nbegin\r\n Result := 0;\r\n P := Pointer(S);\r\n if P <> nil then\r\n begin\r\n Dec(P);\r\n Result := P^.Length and (not $80000000 shr 1);\r\n end;\r\nend;\r\n\r\nfunction StrRefCount(const S: string): SizeInt;\r\nvar\r\n P: PStrRec;\r\nbegin\r\n Result := 0;\r\n P := Pointer(S);\r\n if P <> nil then\r\n begin\r\n Dec(P);\r\n Result := P^.RefCount;\r\n end;\r\nend;\r\n\r\nprocedure StrResetLength(var S: WideString);\r\nvar\r\n I: SizeInt;\r\nbegin\r\n for I := 0 to Length(S) - 1 do\r\n if S[I + 1] = #0 then\r\n begin\r\n SetLength(S, I);\r\n Exit;\r\n end;\r\nend;\r\n\r\nprocedure StrResetLength(var S: AnsiString);\r\nvar\r\n I: SizeInt;\r\nbegin\r\n for I := 0 to Length(S) - 1 do\r\n if S[I + 1] = #0 then\r\n begin\r\n SetLength(S, I);\r\n Exit;\r\n end;\r\nend;\r\n\r\nprocedure StrResetLength(S: TJclStringBuilder);\r\nvar\r\n I: SizeInt;\r\nbegin\r\n if S <> nil then\r\n for I := 0 to S.Length - 1 do\r\n if S[I] = #0 then\r\n begin\r\n S.Length := I;\r\n Exit;\r\n end;\r\nend;\r\n\r\n{$IFDEF SUPPORTS_UNICODE_STRING}\r\nprocedure StrResetLength(var S: UnicodeString);\r\nvar\r\n I: SizeInt;\r\nbegin\r\n for I := 0 to Length(S) - 1 do\r\n if S[I + 1] = #0 then\r\n begin\r\n SetLength(S, I);\r\n Exit;\r\n end;\r\nend;\r\n{$ENDIF SUPPORTS_UNICODE_STRING}\r\n\r\n//=== String Search and Replace Routines =====================================\r\n\r\nfunction StrCharCount(const S: string; C: Char): SizeInt;\r\nvar\r\n I: SizeInt;\r\nbegin\r\n Result := 0;\r\n for I := 1 to Length(S) do\r\n if S[I] = C then\r\n Inc(Result);\r\nend;\r\n\r\nfunction StrCharsCount(const S: string; const Chars: TCharValidator): SizeInt;\r\nvar\r\n I: SizeInt;\r\nbegin\r\n Result := 0;\r\n for I := 1 to Length(S) do\r\n if Chars(S[I]) then\r\n Inc(Result);\r\nend;\r\n\r\nfunction StrCharsCount(const S: string; const Chars: array of Char): SizeInt;\r\nvar\r\n I: SizeInt;\r\nbegin\r\n Result := 0;\r\n for I := 1 to Length(S) do\r\n if ArrayContainsChar(Chars, S[I]) then\r\n Inc(Result);\r\nend;\r\n\r\nfunction StrStrCount(const S, SubS: string): SizeInt;\r\nvar\r\n I: SizeInt;\r\nbegin\r\n Result := 0;\r\n if (Length(SubS) > Length(S)) or (Length(SubS) = 0) or (Length(S) = 0) then\r\n Exit;\r\n if Length(SubS) = 1 then\r\n begin\r\n Result := StrCharCount(S, SubS[1]);\r\n Exit;\r\n end;\r\n I := StrSearch(SubS, S, 1);\r\n\r\n if I > 0 then\r\n Inc(Result);\r\n\r\n while (I > 0) and (Length(S) > I + Length(SubS)) do\r\n begin\r\n I := StrSearch(SubS, S, I + 1);\r\n\r\n if I > 0 then\r\n Inc(Result);\r\n end;\r\nend;\r\n\r\n(*\r\n{ 1} Test(StrCompareRange('', '', 1, 5), 0);\r\n{ 2} Test(StrCompareRange('A', '', 1, 5), -1);\r\n{ 3} Test(StrCompareRange('AB', '', 1, 5), -1);\r\n{ 4} Test(StrCompareRange('ABC', '', 1, 5), -1);\r\n{ 5} Test(StrCompareRange('', 'A', 1, 5), -1);\r\n{ 6} Test(StrCompareRange('', 'AB', 1, 5), -1);\r\n{ 7} Test(StrCompareRange('', 'ABC', 1, 5), -1);\r\n{ 8} Test(StrCompareRange('A', 'a', 1, 5), -2);\r\n{ 9} Test(StrCompareRange('A', 'a', 1, 1), -32);\r\n{10} Test(StrCompareRange('aA', 'aB', 1, 1), 0);\r\n{11} Test(StrCompareRange('aA', 'aB', 1, 2), -1);\r\n{12} Test(StrCompareRange('aB', 'aA', 1, 2), 1);\r\n{13} Test(StrCompareRange('aA', 'aa', 1, 2), -32);\r\n{14} Test(StrCompareRange('aa', 'aA', 1, 2), 32);\r\n{15} Test(StrCompareRange('', '', 1, 0), 0);\r\n{16} Test(StrCompareRange('A', 'A', 1, 0), -2);\r\n{17} Test(StrCompareRange('Aa', 'A', 1, 0), -2);\r\n{18} Test(StrCompareRange('Aa', 'Aa', 1, 2), 0);\r\n{19} Test(StrCompareRange('Aa', 'A', 1, 2), 0);\r\n{20} Test(StrCompareRange('Ba', 'A', 1, 2), 1);\r\n*)\r\nfunction StrCompareRangeEx(const S1, S2: string; Index, Count: SizeInt; CaseSensitive: Boolean): SizeInt;\r\nvar\r\n Len1, Len2: SizeInt;\r\n I: SizeInt;\r\n C1, C2: Char;\r\nbegin\r\n if Pointer(S1) = Pointer(S2) then\r\n begin\r\n if (Count <= 0) and (S1 <> '') then\r\n Result := -2 // no work\r\n else\r\n Result := 0;\r\n end\r\n else\r\n if (S1 = '') or (S2 = '') then\r\n Result := -1 // null string\r\n else\r\n if Count <= 0 then\r\n Result := -2 // no work\r\n else\r\n begin\r\n Len1 := Length(S1);\r\n Len2 := Length(S2);\r\n\r\n if (Index - 1) + Count > Len1 then\r\n Result := -2\r\n else\r\n begin\r\n if (Index - 1) + Count > Len2 then // strange behaviour, but the assembler code does it\r\n Count := Len2 - (Index - 1);\r\n\r\n if CaseSensitive then\r\n begin\r\n for I := 0 to Count - 1 do\r\n begin\r\n C1 := S1[Index + I];\r\n C2 := S2[Index + I];\r\n if C1 <> C2 then\r\n begin\r\n Result := Ord(C1) - Ord(C2);\r\n Exit;\r\n end;\r\n end;\r\n end\r\n else\r\n begin\r\n for I := 0 to Count - 1 do\r\n begin\r\n C1 := S1[Index + I];\r\n C2 := S2[Index + I];\r\n if C1 <> C2 then\r\n begin\r\n C1 := CharLower(C1);\r\n C2 := CharLower(C2);\r\n if C1 <> C2 then\r\n begin\r\n Result := Ord(C1) - Ord(C2);\r\n Exit;\r\n end;\r\n end;\r\n end;\r\n end;\r\n Result := 0;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction StrCompare(const S1, S2: string; CaseSensitive: Boolean): SizeInt;\r\nvar\r\n Len1, Len2: SizeInt;\r\nbegin\r\n if Pointer(S1) = Pointer(S2) then\r\n Result := 0\r\n else\r\n begin\r\n Len1 := Length(S1);\r\n Len2 := Length(S2);\r\n Result := Len1 - Len2;\r\n if Result = 0 then\r\n Result := StrCompareRangeEx(S1, S2, 1, Len1, CaseSensitive);\r\n end;\r\nend;\r\n\r\nfunction StrCompareRange(const S1, S2: string; Index, Count: SizeInt; CaseSensitive: Boolean): SizeInt;\r\nbegin\r\n Result := StrCompareRangeEx(S1, S2, Index, Count, CaseSensitive);\r\nend;\r\n\r\nprocedure StrFillChar(var S; Count: SizeInt; C: Char);\r\n{$IFDEF SUPPORTS_UNICODE}\r\nasm\r\n // 32 --> EAX S\r\n // EDX Count\r\n // ECX C\r\n // 64 --> RCX S\r\n // RDX Count\r\n // R8W C\r\n {$IFDEF CPU32}\r\n DEC EDX\r\n JS @@Leave\r\n@@Loop:\r\n MOV [EAX], CX\r\n ADD EAX, 2\r\n DEC EDX\r\n JNS @@Loop\r\n {$ENDIF CPU32}\r\n {$IFDEF CPU64}\r\n DEC RDX\r\n JS @@Leave\r\n@@Loop:\r\n MOV WORD PTR [RCX], R8W\r\n ADD RCX, 2\r\n DEC RDX\r\n JNS @@Loop\r\n {$ENDIF CPU64}\r\n@@Leave:\r\nend;\r\n{$ELSE ~SUPPORTS_UNICODE}\r\nbegin\r\n if Count > 0 then\r\n FillChar(S, Count, C);\r\nend;\r\n{$ENDIF ~SUPPORTS_UNICODE}\r\n\r\nfunction StrRepeatChar(C: Char; Count: SizeInt): string;\r\nbegin\r\n SetLength(Result, Count);\r\n if Count > 0 then\r\n StrFillChar(Result[1], Count, C);\r\nend;\r\n\r\nfunction StrFind(const Substr, S: string; const Index: SizeInt): SizeInt;\r\nvar\r\n pos: SizeInt;\r\nbegin\r\n if (SubStr <> '') and (S <> '') then\r\n begin\r\n pos := StrIPos(Substr, Copy(S, Index, Length(S) - Index + 1));\r\n if pos = 0 then\r\n Result := 0\r\n else\r\n Result := Index + Pos - 1;\r\n end\r\n else\r\n Result := 0;\r\nend;\r\n\r\nfunction StrHasPrefix(const S: string; const Prefixes: array of string): Boolean;\r\nbegin\r\n Result := StrPrefixIndex(S, Prefixes) > -1;\r\nend;\r\n\r\nfunction StrHasSuffix(const S: string; const Suffixes: array of string): Boolean;\r\nbegin\r\n Result := StrSuffixIndex(S, Suffixes) > -1;\r\nend;\r\n\r\nfunction StrIndex(const S: string; const List: array of string; CaseSensitive: Boolean): SizeInt;\r\nvar\r\n I: SizeInt;\r\nbegin\r\n Result := -1;\r\n for I := Low(List) to High(List) do\r\n begin\r\n if StrCompare(S, List[I], CaseSensitive) = 0 then\r\n begin\r\n Result := I;\r\n Break;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction StrIHasPrefix(const S: string; const Prefixes: array of string): Boolean;\r\nbegin\r\n Result := StrIPrefixIndex(S, Prefixes) > -1;\r\nend;\r\n\r\nfunction StrIHasSuffix(const S: string; const Suffixes: array of string): Boolean;\r\nbegin\r\n Result := StrISuffixIndex(S, Suffixes) > -1;\r\nend;\r\n\r\nfunction StrILastPos(const SubStr, S: string): SizeInt;\r\nbegin\r\n Result := StrLastPos(StrUpper(SubStr), StrUpper(S));\r\nend;\r\n\r\nfunction StrIPos(const SubStr, S: string): SizeInt;\r\nbegin\r\n Result := Pos(StrUpper(SubStr), StrUpper(S));\r\nend;\r\n\r\nfunction StrIPrefixIndex(const S: string; const Prefixes: array of string): SizeInt;\r\nvar\r\n I: SizeInt;\r\n Test: string;\r\nbegin\r\n Result := -1;\r\n for I := Low(Prefixes) to High(Prefixes) do\r\n begin\r\n Test := StrLeft(S, Length(Prefixes[I]));\r\n if CompareText(Test, Prefixes[I]) = 0 then\r\n begin\r\n Result := I;\r\n Break;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction StrIsOneOf(const S: string; const List: array of string): Boolean;\r\nbegin\r\n Result := StrIndex(S, List) > -1;\r\nend;\r\n\r\nfunction StrISuffixIndex(const S: string; const Suffixes: array of string): SizeInt;\r\nvar\r\n I: SizeInt;\r\n Test: string;\r\nbegin\r\n Result := -1;\r\n for I := Low(Suffixes) to High(Suffixes) do\r\n begin\r\n Test := StrRight(S, Length(Suffixes[I]));\r\n if CompareText(Test, Suffixes[I]) = 0 then\r\n begin\r\n Result := I;\r\n Break;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction StrLastPos(const SubStr, S: string): SizeInt;\r\nvar\r\n Last, Current: PChar;\r\nbegin\r\n Result := 0;\r\n Last := nil;\r\n Current := PChar(S);\r\n\r\n while (Current <> nil) and (Current^ <> #0) do\r\n begin\r\n Current := StrPos(PChar(Current), PChar(SubStr));\r\n if Current <> nil then\r\n begin\r\n Last := Current;\r\n Inc(Current);\r\n end;\r\n end;\r\n if Last <> nil then\r\n Result := Abs(PChar(S) - Last) + 1;\r\nend;\r\n\r\n// IMPORTANT NOTE: The StrMatch function does currently not work with the Asterix (*)\r\n// (*) acts like (?)\r\n\r\nfunction StrMatch(const Substr, S: string; Index: SizeInt): SizeInt;\r\nvar\r\n SI, SubI, SLen, SubLen: SizeInt;\r\n SubC: Char;\r\nbegin\r\n SLen := Length(S);\r\n SubLen := Length(Substr);\r\n Result := 0;\r\n if (Index > SLen) or (SubLen = 0) then\r\n Exit;\r\n while Index <= SLen do\r\n begin\r\n SubI := 1;\r\n SI := Index;\r\n while (SI <= SLen) and (SubI <= SubLen) do\r\n begin\r\n SubC := Substr[SubI];\r\n if (SubC = '*') or (SubC = '?') or (SubC = S[SI]) then\r\n begin\r\n Inc(SI);\r\n Inc(SubI);\r\n end\r\n else\r\n Break;\r\n end;\r\n if SubI > SubLen then\r\n begin\r\n Result := Index;\r\n Break;\r\n end;\r\n Inc(Index);\r\n end;\r\nend;\r\n\r\n// Derived from \"Like\" by Michael Winter\r\nfunction StrMatches(const Substr, S: string; const Index: SizeInt): Boolean;\r\nvar\r\n StringPtr: PChar;\r\n PatternPtr: PChar;\r\n StringRes: PChar;\r\n PatternRes: PChar;\r\nbegin\r\n if SubStr = '' then\r\n raise EJclStringError.CreateRes(@RsBlankSearchString);\r\n\r\n Result := SubStr = '*';\r\n\r\n if Result or (S = '') then\r\n Exit;\r\n\r\n if (Index <= 0) or (Index > Length(S)) then\r\n raise EJclStringError.CreateRes(@RsArgumentOutOfRange);\r\n\r\n StringPtr := PChar(@S[Index]);\r\n PatternPtr := PChar(SubStr);\r\n StringRes := nil;\r\n PatternRes := nil;\r\n\r\n repeat\r\n repeat\r\n case PatternPtr^ of\r\n #0:\r\n begin\r\n Result := StringPtr^ = #0;\r\n if Result or (StringRes = nil) or (PatternRes = nil) then\r\n Exit;\r\n\r\n StringPtr := StringRes;\r\n PatternPtr := PatternRes;\r\n Break;\r\n end;\r\n '*':\r\n begin\r\n Inc(PatternPtr);\r\n PatternRes := PatternPtr;\r\n Break;\r\n end;\r\n '?':\r\n begin\r\n if StringPtr^ = #0 then\r\n Exit;\r\n Inc(StringPtr);\r\n Inc(PatternPtr);\r\n end;\r\n else\r\n begin\r\n if StringPtr^ = #0 then\r\n Exit;\r\n if StringPtr^ <> PatternPtr^ then\r\n begin\r\n if (StringRes = nil) or (PatternRes = nil) then\r\n Exit;\r\n StringPtr := StringRes;\r\n PatternPtr := PatternRes;\r\n Break;\r\n end\r\n else\r\n begin\r\n Inc(StringPtr);\r\n Inc(PatternPtr);\r\n end;\r\n end;\r\n end;\r\n until False;\r\n\r\n repeat\r\n case PatternPtr^ of\r\n #0:\r\n begin\r\n Result := True;\r\n Exit;\r\n end;\r\n '*':\r\n begin\r\n Inc(PatternPtr);\r\n PatternRes := PatternPtr;\r\n end;\r\n '?':\r\n begin\r\n if StringPtr^ = #0 then\r\n Exit;\r\n Inc(StringPtr);\r\n Inc(PatternPtr);\r\n end;\r\n else\r\n begin\r\n repeat\r\n if StringPtr^ = #0 then\r\n Exit;\r\n if StringPtr^ = PatternPtr^ then\r\n Break;\r\n Inc(StringPtr);\r\n until False;\r\n Inc(StringPtr);\r\n StringRes := StringPtr;\r\n Inc(PatternPtr);\r\n Break;\r\n end;\r\n end;\r\n until False;\r\n until False;\r\nend;\r\n\r\nfunction StrNPos(const S, SubStr: string; N: SizeInt): SizeInt;\r\nvar\r\n I, P: SizeInt;\r\nbegin\r\n if N < 1 then\r\n begin\r\n Result := 0;\r\n Exit;\r\n end;\r\n\r\n Result := StrSearch(SubStr, S, 1);\r\n I := 1;\r\n while I < N do\r\n begin\r\n P := StrSearch(SubStr, S, Result + 1);\r\n if P = 0 then\r\n begin\r\n Result := 0;\r\n Break;\r\n end\r\n else\r\n begin\r\n Result := P;\r\n Inc(I);\r\n end;\r\n end;\r\nend;\r\n\r\nfunction StrNIPos(const S, SubStr: string; N: SizeInt): SizeInt;\r\nvar\r\n I, P: SizeInt;\r\nbegin\r\n if N < 1 then\r\n begin\r\n Result := 0;\r\n Exit;\r\n end;\r\n\r\n Result := StrFind(SubStr, S, 1);\r\n I := 1;\r\n while I < N do\r\n begin\r\n P := StrFind(SubStr, S, Result + 1);\r\n if P = 0 then\r\n begin\r\n Result := 0;\r\n Break;\r\n end\r\n else\r\n begin\r\n Result := P;\r\n Inc(I);\r\n end;\r\n end;\r\nend;\r\n\r\nfunction StrPrefixIndex(const S: string; const Prefixes: array of string): SizeInt;\r\nvar\r\n I: SizeInt;\r\n Test: string;\r\nbegin\r\n Result := -1;\r\n for I := Low(Prefixes) to High(Prefixes) do\r\n begin\r\n Test := StrLeft(S, Length(Prefixes[I]));\r\n if CompareStr(Test, Prefixes[I]) = 0 then\r\n begin\r\n Result := I;\r\n Break;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction StrSearch(const Substr, S: string; const Index: SizeInt): SizeInt;\r\nvar\r\n SP, SPI, SubP: PChar;\r\n SLen: SizeInt;\r\nbegin\r\n SLen := Length(S);\r\n if Index <= SLen then\r\n begin\r\n SP := PChar(S);\r\n SubP := PChar(Substr);\r\n SPI := SP;\r\n Inc(SPI, Index);\r\n Dec(SPI);\r\n SPI := StrPos(SPI, SubP);\r\n if SPI <> nil then\r\n Result := SPI - SP + 1\r\n else\r\n Result := 0;\r\n end\r\n else\r\n Result := 0;\r\nend;\r\n\r\nfunction StrSuffixIndex(const S: string; const Suffixes: array of string): SizeInt;\r\nvar\r\n I: SizeInt;\r\n Test: string;\r\nbegin\r\n Result := -1;\r\n for I := Low(Suffixes) to High(Suffixes) do\r\n begin\r\n Test := StrRight(S, Length(Suffixes[I]));\r\n if CompareStr(Test, Suffixes[I]) = 0 then\r\n begin\r\n Result := I;\r\n Break;\r\n end;\r\n end;\r\nend;\r\n\r\n//=== String Extraction ======================================================\r\n\r\nfunction StrAfter(const SubStr, S: string): string;\r\nvar\r\n P: SizeInt;\r\nbegin\r\n P := StrFind(SubStr, S, 1); // StrFind is case-insensitive pos\r\n if P <= 0 then\r\n Result := '' // substr not found -> nothing after it\r\n else\r\n Result := StrRestOf(S, P + Length(SubStr));\r\nend;\r\n\r\nfunction StrBefore(const SubStr, S: string): string;\r\nvar\r\n P: SizeInt;\r\nbegin\r\n P := StrFind(SubStr, S, 1);\r\n if P <= 0 then\r\n Result := S\r\n else\r\n Result := StrLeft(S, P - 1);\r\nend;\r\n\r\nfunction StrSplit(const SubStr, S: string;var Left, Right : string): boolean;\r\nvar\r\n P: SizeInt;\r\nbegin\r\n P := StrFind(SubStr, S, 1);\r\n Result:= p > 0;\r\n if Result then\r\n begin\r\n Left := StrLeft(S, P - 1);\r\n Right := StrRestOf(S, P + Length(SubStr));\r\n end\r\n else\r\n begin\r\n Left := '';\r\n Right := '';\r\n end;\r\nend;\r\n\r\nfunction StrBetween(const S: string; const Start, Stop: Char): string;\r\nvar\r\n PosStart, PosEnd: SizeInt;\r\n L: SizeInt;\r\nbegin\r\n PosStart := Pos(Start, S);\r\n PosEnd := StrSearch(Stop, S, PosStart + 1); // PosEnd has to be after PosStart.\r\n\r\n if (PosStart > 0) and (PosEnd > PosStart) then\r\n begin\r\n L := PosEnd - PosStart;\r\n Result := Copy(S, PosStart + 1, L - 1);\r\n end\r\n else\r\n Result := '';\r\nend;\r\n\r\nfunction StrChopRight(const S: string; N: SizeInt): string;\r\nbegin\r\n Result := Copy(S, 1, Length(S) - N);\r\nend;\r\n\r\nfunction StrLeft(const S: string; Count: SizeInt): string;\r\nbegin\r\n Result := Copy(S, 1, Count);\r\nend;\r\n\r\nfunction StrMid(const S: string; Start, Count: SizeInt): string;\r\nbegin\r\n Result := Copy(S, Start, Count);\r\nend;\r\n\r\nfunction StrRestOf(const S: string; N: SizeInt): string;\r\nbegin\r\n Result := Copy(S, N, (Length(S) - N + 1));\r\nend;\r\n\r\nfunction StrRight(const S: string; Count: SizeInt): string;\r\nbegin\r\n Result := Copy(S, Length(S) - Count + 1, Count);\r\nend;\r\n\r\n//=== Character (do we have it ;) ============================================\r\n\r\nfunction CharEqualNoCase(const C1, C2: Char): Boolean;\r\nbegin\r\n //if they are not equal chars, may be same letter different case\r\n Result := (C1 = C2) or\r\n (CharIsAlpha(C1) and CharIsAlpha(C2) and (CharLower(C1) = CharLower(C2)));\r\nend;\r\n\r\n\r\nfunction CharIsAlpha(const C: Char): Boolean;\r\nbegin\r\n {$IFDEF UNICODE_RTL_DATABASE}\r\n Result := TCharacter.IsLetter(C);\r\n {$ELSE ~UNICODE_RTL_DATABASE}\r\n Result := (StrCharTypes[C] and C1_ALPHA) <> 0;\r\n {$ENDIF ~UNICODE_RTL_DATABASE}\r\nend;\r\n\r\nfunction CharIsAlphaNum(const C: Char): Boolean;\r\nbegin\r\n {$IFDEF UNICODE_RTL_DATABASE}\r\n Result := TCharacter.IsLetterOrDigit(C);\r\n {$ELSE ~UNICODE_RTL_DATABASE}\r\n Result := ((StrCharTypes[C] and C1_ALPHA) <> 0) or ((StrCharTypes[C] and C1_DIGIT) <> 0);\r\n {$ENDIF ~UNICODE_RTL_DATABASE}\r\nend;\r\n\r\nfunction CharIsBlank(const C: Char): Boolean;\r\nbegin\r\n {$IFDEF UNICODE_RTL_DATABASE}\r\n //http://blogs.msdn.com/b/michkap/archive/2007/06/11/3230072.aspx\r\n Result := (C = ' ') or (C = #$0009) or (C = #$00A0) or (C = #$3000);\r\n {$ELSE ~UNICODE_RTL_DATABASE}\r\n Result := ((StrCharTypes[C] and C1_BLANK) <> 0);\r\n {$ENDIF ~UNICODE_RTL_DATABASE}\r\nend;\r\n\r\nfunction CharIsControl(const C: Char): Boolean;\r\nbegin\r\n {$IFDEF UNICODE_RTL_DATABASE}\r\n Result := TCharacter.IsControl(C);\r\n {$ELSE ~UNICODE_RTL_DATABASE}\r\n Result := (StrCharTypes[C] and C1_CNTRL) <> 0;\r\n {$ENDIF ~UNICODE_RTL_DATABASE}\r\nend;\r\n\r\nfunction CharIsDelete(const C: Char): Boolean;\r\nbegin\r\n Result := (C = #8);\r\nend;\r\n\r\nfunction CharIsDigit(const C: Char): Boolean;\r\nbegin\r\n {$IFDEF UNICODE_RTL_DATABASE}\r\n Result := TCharacter.IsDigit(C);\r\n {$ELSE ~UNICODE_RTL_DATABASE}\r\n Result := (StrCharTypes[C] and C1_DIGIT) <> 0;\r\n {$ENDIF ~UNICODE_RTL_DATABASE}\r\nend;\r\n\r\nfunction CharIsFracDigit(const C: Char): Boolean;\r\nbegin\r\n Result := (C = '.') or CharIsDigit(C);\r\nend;\r\n\r\nfunction CharIsHexDigit(const C: Char): Boolean;\r\nbegin\r\n case C of\r\n 'A'..'F',\r\n 'a'..'f':\r\n Result := True;\r\n else\r\n Result := CharIsDigit(C);\r\n end;\r\nend;\r\n\r\nfunction CharIsLower(const C: Char): Boolean;\r\nbegin\r\n {$IFDEF UNICODE_RTL_DATABASE}\r\n Result := TCharacter.IsLower(C);\r\n {$ELSE ~UNICODE_RTL_DATABASE}\r\n Result := (StrCharTypes[C] and C1_LOWER) <> 0;\r\n {$ENDIF ~UNICODE_RTL_DATABASE}\r\nend;\r\n\r\nfunction CharIsNumberChar(const C: Char): Boolean;\r\nbegin\r\n Result := CharIsDigit(C) or (C = '+') or (C = '-') or (C = JclFormatSettings.DecimalSeparator);\r\nend;\r\n\r\nfunction CharIsNumber(const C: Char): Boolean;\r\nbegin\r\n Result := CharIsDigit(C) or (C = JclFormatSettings.DecimalSeparator);\r\nend;\r\n\r\nfunction CharIsPrintable(const C: Char): Boolean;\r\nbegin\r\n Result := not CharIsControl(C);\r\nend;\r\n\r\nfunction CharIsPunctuation(const C: Char): Boolean;\r\nbegin\r\n {$IFDEF UNICODE_RTL_DATABASE}\r\n Result := TCharacter.IsPunctuation(C);\r\n {$ELSE ~UNICODE_RTL_DATABASE}\r\n Result := ((StrCharTypes[C] and C1_PUNCT) <> 0);\r\n {$ENDIF ~UNICODE_RTL_DATABASE}\r\nend;\r\n\r\nfunction CharIsReturn(const C: Char): Boolean;\r\nbegin\r\n Result := (C = NativeLineFeed) or (C = NativeCarriageReturn);\r\nend;\r\n\r\nfunction CharIsSpace(const C: Char): Boolean;\r\nbegin\r\n {$IFDEF UNICODE_RTL_DATABASE}\r\n Result := TCharacter.IsWhiteSpace(C);\r\n {$ELSE ~UNICODE_RTL_DATABASE}\r\n Result := (StrCharTypes[C] and C1_SPACE) <> 0;\r\n {$ENDIF ~UNICODE_RTL_DATABASE}\r\nend;\r\n\r\nfunction CharIsUpper(const C: Char): Boolean;\r\nbegin\r\n {$IFDEF UNICODE_RTL_DATABASE}\r\n Result := TCharacter.IsUpper(C);\r\n {$ELSE ~UNICODE_RTL_DATABASE}\r\n Result := (StrCharTypes[C] and C1_UPPER) <> 0;\r\n {$ENDIF ~UNICODE_RTL_DATABASE}\r\nend;\r\n\r\nfunction CharIsValidIdentifierLetter(const C: Char): Boolean;\r\nbegin\r\n case C of\r\n {$IFDEF SUPPORTS_UNICODE}\r\n // from XML specifications\r\n #$00C0..#$00D6, #$00D8..#$00F6, #$00F8..#$02FF, #$0370..#$037D,\r\n #$037F..#$1FFF, #$200C..#$200D, #$2070..#$218F, #$2C00..#$2FEF,\r\n #$3001..#$D7FF, #$F900..#$FDCF, #$FDF0..#$FFFD, // #$10000..#$EFFFF, howto match surrogate pairs?\r\n #$00B7, #$0300..#$036F, #$203F..#$2040,\r\n {$ENDIF SUPPORTS_UNICODE}\r\n '0'..'9', 'A'..'Z', 'a'..'z', '_':\r\n Result := True;\r\n else\r\n Result := False;\r\n end;\r\nend;\r\n\r\nfunction CharIsWhiteSpace(const C: Char): Boolean;\r\nbegin\r\n case C of\r\n NativeTab,\r\n NativeLineFeed,\r\n NativeVerticalTab,\r\n NativeFormFeed,\r\n NativeCarriageReturn,\r\n NativeSpace:\r\n Result := True;\r\n else\r\n Result := False;\r\n end;\r\nend;\r\n\r\nfunction CharIsWildcard(const C: Char): Boolean;\r\nbegin\r\n case C of\r\n '*', '?':\r\n Result := True;\r\n else\r\n Result := False;\r\n end;\r\nend;\r\n\r\nfunction CharType(const C: Char): Word;\r\nbegin\r\n {$IFDEF UNICODE_RTL_DATABASE}\r\n GetStringTypeEx(LOCALE_USER_DEFAULT, CT_CTYPE1, @C, 1, Result);\r\n {$ELSE ~UNICODE_RTL_DATABASE}\r\n Result := StrCharTypes[C];\r\n {$ENDIF ~UNICODE_RTL_DATABASE}\r\nend;\r\n\r\n//=== PCharVector ============================================================\r\n\r\nfunction StringsToPCharVector(var Dest: PCharVector; const Source: TStrings): PCharVector;\r\nvar\r\n I: SizeInt;\r\n S: string;\r\n List: array of PChar;\r\nbegin\r\n Assert(Source <> nil);\r\n Dest := AllocMem((Source.Count + SizeOf(Char)) * SizeOf(PChar));\r\n SetLength(List, Source.Count + SizeOf(Char));\r\n for I := 0 to Source.Count - 1 do\r\n begin\r\n S := Source[I];\r\n List[I] := StrAlloc(Length(S) + SizeOf(Char));\r\n StrPCopy(List[I], S);\r\n end;\r\n List[Source.Count] := nil;\r\n Move(List[0], Dest^, (Source.Count + 1) * SizeOf(PChar));\r\n Result := Dest;\r\nend;\r\n\r\nfunction PCharVectorCount(Source: PCharVector): SizeInt;\r\nbegin\r\n Result := 0;\r\n if Source <> nil then\r\n begin\r\n while Source^ <> nil do\r\n begin\r\n Inc(Source);\r\n Inc(Result);\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure PCharVectorToStrings(const Dest: TStrings; Source: PCharVector);\r\nvar\r\n I, Count: SizeInt;\r\n List: array of PChar;\r\nbegin\r\n Assert(Dest <> nil);\r\n if Source <> nil then\r\n begin\r\n Count := PCharVectorCount(Source);\r\n SetLength(List, Count);\r\n Move(Source^, List[0], Count * SizeOf(PChar));\r\n Dest.BeginUpdate;\r\n try\r\n Dest.Clear;\r\n for I := 0 to Count - 1 do\r\n Dest.Add(List[I]);\r\n finally\r\n Dest.EndUpdate;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure FreePCharVector(var Dest: PCharVector);\r\nvar\r\n I, Count: SizeInt;\r\n List: array of PChar;\r\nbegin\r\n if Dest <> nil then\r\n begin\r\n Count := PCharVectorCount(Dest);\r\n SetLength(List, Count);\r\n Move(Dest^, List[0], Count * SizeOf(PChar));\r\n for I := 0 to Count - 1 do\r\n StrDispose(List[I]);\r\n FreeMem(Dest, (Count + 1) * SizeOf(PChar));\r\n Dest := nil;\r\n end;\r\nend;\r\n\r\n//=== Character Transformation Routines ======================================\r\n\r\nfunction CharHex(const C: Char): Byte;\r\nbegin\r\n case C of\r\n '0'..'9':\r\n Result := Ord(C) - Ord('0');\r\n 'a'..'f':\r\n Result := Ord(C) - Ord('a') + 10;\r\n 'A'..'F':\r\n Result := Ord(C) - Ord('A') + 10;\r\n else\r\n Result := $FF;\r\n end;\r\nend;\r\n\r\nfunction CharLower(const C: Char): Char;\r\nbegin\r\n {$IFDEF UNICODE_RTL_DATABASE}\r\n Result := TCharacter.ToLower(C);\r\n {$ELSE ~UNICODE_RTL_DATABASE}\r\n Result := StrCaseMap[Ord(C) + StrLoOffset];\r\n {$ENDIF ~UNICODE_RTL_DATABASE}\r\nend;\r\n\r\nfunction CharToggleCase(const C: Char): Char;\r\nbegin\r\n {$IFDEF UNICODE_RTL_DATABASE}\r\n if CharIsLower(C) then\r\n Result := CharUpper(C)\r\n else if CharIsUpper(C) then\r\n Result := CharLower(C)\r\n else\r\n Result := C;\r\n {$ELSE ~UNICODE_RTL_DATABASE}\r\n Result := StrCaseMap[Ord(C) + StrReOffset];\r\n {$ENDIF ~UNICODE_RTL_DATABASE}\r\nend;\r\n\r\nfunction CharUpper(const C: Char): Char;\r\nbegin\r\n {$IFDEF UNICODE_RTL_DATABASE}\r\n Result := TCharacter.ToUpper(C);\r\n {$ELSE ~UNICODE_RTL_DATABASE}\r\n Result := StrCaseMap[Ord(C) + StrUpOffset];\r\n {$ENDIF ~UNICODE_RTL_DATABASE}\r\nend;\r\n\r\n//=== Character Search and Replace ===========================================\r\n\r\nfunction CharLastPos(const S: string; const C: Char; const Index: SizeInt): SizeInt;\r\nbegin\r\n if (Index > 0) and (Index <= Length(S)) then\r\n begin\r\n for Result := Length(S) downto Index do\r\n if S[Result] = C then\r\n Exit;\r\n end;\r\n Result := 0;\r\nend;\r\n\r\nfunction CharPos(const S: string; const C: Char; const Index: SizeInt): SizeInt;\r\nbegin\r\n if (Index > 0) and (Index <= Length(S)) then\r\n begin\r\n for Result := Index to Length(S) do\r\n if S[Result] = C then\r\n Exit;\r\n end;\r\n Result := 0;\r\nend;\r\n\r\nfunction CharIPos(const S: string; C: Char; const Index: SizeInt): SizeInt;\r\nbegin\r\n if (Index > 0) and (Index <= Length(S)) then\r\n begin\r\n C := CharUpper(C);\r\n for Result := Index to Length(S) do\r\n if CharUpper(S[Result]) = C then\r\n Exit;\r\n end;\r\n Result := 0;\r\nend;\r\n\r\nfunction CharReplace(var S: string; const Search, Replace: Char): SizeInt;\r\nvar\r\n P: PChar;\r\n Index, Len: SizeInt;\r\nbegin\r\n Result := 0;\r\n if Search <> Replace then\r\n begin\r\n UniqueString(S);\r\n P := PChar(S);\r\n Len := Length(S);\r\n for Index := 0 to Len - 1 do\r\n begin\r\n if P^ = Search then\r\n begin\r\n P^ := Replace;\r\n Inc(Result);\r\n end;\r\n Inc(P);\r\n end;\r\n end;\r\nend;\r\n\r\n//=== MultiSz ================================================================\r\n\r\nfunction StringsToMultiSz(var Dest: PMultiSz; const Source: TStrings): PMultiSz;\r\nvar\r\n I, TotalLength: SizeInt;\r\n P: PMultiSz;\r\nbegin\r\n Assert(Source <> nil);\r\n TotalLength := 1;\r\n for I := 0 to Source.Count - 1 do\r\n if Source[I] = '' then\r\n raise EJclStringError.CreateRes(@RsInvalidEmptyStringItem)\r\n else\r\n Inc(TotalLength, StrLen(PChar(Source[I])) + 1);\r\n AllocateMultiSz(Dest, TotalLength);\r\n P := Dest;\r\n for I := 0 to Source.Count - 1 do\r\n begin\r\n P := StrECopy(P, PChar(Source[I]));\r\n Inc(P);\r\n end;\r\n P^ := #0;\r\n Result := Dest;\r\nend;\r\n\r\nprocedure MultiSzToStrings(const Dest: TStrings; const Source: PMultiSz);\r\nvar\r\n P: PMultiSz;\r\nbegin\r\n Assert(Dest <> nil);\r\n Dest.BeginUpdate;\r\n try\r\n Dest.Clear;\r\n if Source <> nil then\r\n begin\r\n P := Source;\r\n while P^ <> #0 do\r\n begin\r\n Dest.Add(P);\r\n P := StrEnd(P);\r\n Inc(P);\r\n end;\r\n end;\r\n finally\r\n Dest.EndUpdate;\r\n end;\r\nend;\r\n\r\nfunction MultiSzLength(const Source: PMultiSz): SizeInt;\r\nvar\r\n P: PMultiSz;\r\nbegin\r\n Result := 0;\r\n if Source <> nil then\r\n begin\r\n P := Source;\r\n repeat\r\n Inc(Result, StrLen(P) + 1);\r\n P := StrEnd(P);\r\n Inc(P);\r\n until P^ = #0;\r\n Inc(Result);\r\n end;\r\nend;\r\n\r\nprocedure AllocateMultiSz(var Dest: PMultiSz; Len: SizeInt);\r\nbegin\r\n if Len > 0 then\r\n GetMem(Dest, Len * SizeOf(Char))\r\n else\r\n Dest := nil;\r\nend;\r\n\r\nprocedure FreeMultiSz(var Dest: PMultiSz);\r\nbegin\r\n if Dest <> nil then\r\n FreeMem(Dest);\r\n Dest := nil;\r\nend;\r\n\r\nfunction MultiSzDup(const Source: PMultiSz): PMultiSz;\r\nvar\r\n Len: SizeInt;\r\nbegin\r\n if Source <> nil then\r\n begin\r\n Len := MultiSzLength(Source);\r\n Result := nil;\r\n AllocateMultiSz(Result, Len);\r\n Move(Source^, Result^, Len * SizeOf(Char));\r\n end\r\n else\r\n Result := nil;\r\nend;\r\n\r\nfunction AnsiStringsToAnsiMultiSz(var Dest: PAnsiMultiSz; const Source: TAnsiStrings): PAnsiMultiSz;\r\nbegin\r\n Result := JclAnsiStrings.StringsToMultiSz(Dest, Source);\r\nend;\r\n\r\nprocedure AnsiMultiSzToAnsiStrings(const Dest: TAnsiStrings; const Source: PAnsiMultiSz);\r\nbegin\r\n JclAnsiStrings.MultiSzToStrings(Dest, Source);\r\nend;\r\n\r\nfunction AnsiMultiSzLength(const Source: PAnsiMultiSz): SizeInt;\r\nbegin\r\n Result := JclAnsiStrings.MultiSzLength(Source);\r\nend;\r\n\r\nprocedure AllocateAnsiMultiSz(var Dest: PAnsiMultiSz; Len: SizeInt);\r\nbegin\r\n JclAnsiStrings.AllocateMultiSz(Dest, Len);\r\nend;\r\n\r\nprocedure FreeAnsiMultiSz(var Dest: PAnsiMultiSz);\r\nbegin\r\n JclAnsiStrings.FreeMultiSz(Dest);\r\nend;\r\n\r\nfunction AnsiMultiSzDup(const Source: PAnsiMultiSz): PAnsiMultiSz;\r\nbegin\r\n Result := JclAnsiStrings.MultiSzDup(Source);\r\nend;\r\n\r\nfunction WideStringsToWideMultiSz(var Dest: PWideMultiSz; const Source: TWideStrings): PWideMultiSz;\r\nbegin\r\n Result := JclWideStrings.StringsToMultiSz(Dest, Source);\r\nend;\r\n\r\nprocedure WideMultiSzToWideStrings(const Dest: TWideStrings; const Source: PWideMultiSz);\r\nbegin\r\n JclWideStrings.MultiSzToStrings(Dest, Source);\r\nend;\r\n\r\nfunction WideMultiSzLength(const Source: PWideMultiSz): SizeInt;\r\nbegin\r\n Result := JclWideStrings.MultiSzLength(Source);\r\nend;\r\n\r\nprocedure AllocateWideMultiSz(var Dest: PWideMultiSz; Len: SizeInt);\r\nbegin\r\n JclWideStrings.AllocateMultiSz(Dest, Len);\r\nend;\r\n\r\nprocedure FreeWideMultiSz(var Dest: PWideMultiSz);\r\nbegin\r\n JclWideStrings.FreeMultiSz(Dest);\r\nend;\r\n\r\nfunction WideMultiSzDup(const Source: PWideMultiSz): PWideMultiSz;\r\nbegin\r\n Result := JclWideStrings.MultiSzDup(Source);\r\nend;\r\n\r\n//=== TStrings Manipulation ==================================================\r\n\r\nprocedure StrToStrings(S, Sep: string; const List: TStrings; const AllowEmptyString: Boolean = True);\r\nvar\r\n I, L: SizeInt;\r\n Left: string;\r\nbegin\r\n Assert(List <> nil);\r\n List.BeginUpdate;\r\n try\r\n List.Clear;\r\n L := Length(Sep);\r\n I := Pos(Sep, S);\r\n while I > 0 do\r\n begin\r\n Left := StrLeft(S, I - 1);\r\n if (Left <> '') or AllowEmptyString then\r\n List.Add(Left);\r\n Delete(S, 1, I + L - 1);\r\n I := Pos(Sep, S);\r\n end;\r\n if S <> '' then\r\n List.Add(S); // Ignore empty strings at the end.\r\n finally\r\n List.EndUpdate;\r\n end;\r\nend;\r\n\r\nprocedure StrIToStrings(S, Sep: string; const List: TStrings; const AllowEmptyString: Boolean = True);\r\nvar\r\n I, L: SizeInt;\r\n LowerCaseStr: string;\r\n Left: string;\r\nbegin\r\n Assert(List <> nil);\r\n LowerCaseStr := StrLower(S);\r\n Sep := StrLower(Sep);\r\n L := Length(Sep);\r\n I := Pos(Sep, LowerCaseStr);\r\n List.BeginUpdate;\r\n try\r\n List.Clear;\r\n while I > 0 do\r\n begin\r\n Left := StrLeft(S, I - 1);\r\n if (Left <> '') or AllowEmptyString then\r\n List.Add(Left);\r\n Delete(S, 1, I + L - 1);\r\n Delete(LowerCaseStr, 1, I + L - 1);\r\n I := Pos(Sep, LowerCaseStr);\r\n end;\r\n if S <> '' then\r\n List.Add(S); // Ignore empty strings at the end.\r\n finally\r\n List.EndUpdate;\r\n end;\r\nend;\r\n\r\nfunction StringsToStr(const List: TStrings; const Sep: string; const AllowEmptyString: Boolean = True): string;\r\nvar\r\n I, L: SizeInt;\r\nbegin\r\n Result := '';\r\n for I := 0 to List.Count - 1 do\r\n begin\r\n if (List[I] <> '') or AllowEmptyString then\r\n begin\r\n // don't combine these into one addition, somehow it hurts performance\r\n Result := Result + List[I];\r\n Result := Result + Sep;\r\n end;\r\n end;\r\n // remove terminating separator\r\n if List.Count > 0 then\r\n begin\r\n L := Length(Sep);\r\n Delete(Result, Length(Result) - L + 1, L);\r\n end;\r\nend;\r\n\r\nfunction StringsToStr(const List: TStrings; const Sep: string; const NumberOfItems: SizeInt; const AllowEmptyString:\r\n Boolean = True): string;\r\nvar\r\n I, L, N: SizeInt;\r\nbegin\r\n Result := '';\r\n if List.Count > NumberOfItems then\r\n N := NumberOfItems\r\n else\r\n N := List.Count;\r\n for I := 0 to N - 1 do\r\n begin\r\n if (List[I] <> '') or AllowEmptyString then\r\n begin\r\n // don't combine these into one addition, somehow it hurts performance\r\n Result := Result + List[I];\r\n Result := Result + Sep;\r\n end;\r\n end;\r\n // remove terminating separator\r\n if N > 0 then\r\n begin\r\n L := Length(Sep);\r\n Delete(Result, Length(Result) - L + 1, L);\r\n end;\r\nend;\r\n\r\nprocedure TrimStrings(const List: TStrings; DeleteIfEmpty: Boolean);\r\nvar\r\n I: SizeInt;\r\nbegin\r\n Assert(List <> nil);\r\n List.BeginUpdate;\r\n try\r\n for I := List.Count - 1 downto 0 do\r\n begin\r\n List[I] := Trim(List[I]);\r\n if (List[I] = '') and DeleteIfEmpty then\r\n List.Delete(I);\r\n end;\r\n finally\r\n List.EndUpdate;\r\n end;\r\nend;\r\n\r\nprocedure TrimStringsRight(const List: TStrings; DeleteIfEmpty: Boolean);\r\nvar\r\n I: SizeInt;\r\nbegin\r\n Assert(List <> nil);\r\n List.BeginUpdate;\r\n try\r\n for I := List.Count - 1 downto 0 do\r\n begin\r\n List[I] := TrimRight(List[I]);\r\n if (List[I] = '') and DeleteIfEmpty then\r\n List.Delete(I);\r\n end;\r\n finally\r\n List.EndUpdate;\r\n end;\r\nend;\r\n\r\nprocedure TrimStringsLeft(const List: TStrings; DeleteIfEmpty: Boolean);\r\nvar\r\n I: SizeInt;\r\nbegin\r\n Assert(List <> nil);\r\n List.BeginUpdate;\r\n try\r\n for I := List.Count - 1 downto 0 do\r\n begin\r\n List[I] := TrimLeft(List[I]);\r\n if (List[I] = '') and DeleteIfEmpty then\r\n List.Delete(I);\r\n end;\r\n finally\r\n List.EndUpdate;\r\n end;\r\nend;\r\n\r\nfunction AddStringToStrings(const S: string; Strings: TStrings; const Unique: Boolean): Boolean;\r\nbegin\r\n Assert(Strings <> nil);\r\n Result := Unique and (Strings.IndexOf(S) <> -1);\r\n if not Result then\r\n Result := Strings.Add(S) > -1;\r\nend;\r\n\r\n//=== Miscellaneous ==========================================================\r\n\r\nfunction FileToString(const FileName: string): {$IFDEF COMPILER12_UP}RawByteString{$ELSE}AnsiString{$ENDIF};\r\nvar\r\n fs: TFileStream;\r\n Len: SizeInt;\r\nbegin\r\n fs := TFileStream.Create(FileName, fmOpenRead or fmShareDenyWrite);\r\n try\r\n Len := fs.Size;\r\n SetLength(Result, Len);\r\n if Len > 0 then\r\n fs.ReadBuffer(Result[1], Len);\r\n finally\r\n fs.Free;\r\n end;\r\nend;\r\n\r\nprocedure StringToFile(const FileName: string; const Contents: {$IFDEF COMPILER12_UP}RawByteString{$ELSE}AnsiString{$ENDIF};\r\n Append: Boolean);\r\nvar\r\n FS: TFileStream;\r\n Len: SizeInt;\r\nbegin\r\n if Append and FileExists(filename) then\r\n FS := TFileStream.Create(FileName, fmOpenReadWrite or fmShareDenyWrite)\r\n else\r\n FS := TFileStream.Create(FileName, fmCreate);\r\n try\r\n if Append then\r\n FS.Seek(0, soEnd); // faster than .Position := .Size\r\n Len := Length(Contents);\r\n if Len > 0 then\r\n FS.WriteBuffer(Contents[1], Len);\r\n finally\r\n FS.Free;\r\n end;\r\nend;\r\n\r\nfunction StrToken(var S: string; Separator: Char): string;\r\nvar\r\n I: SizeInt;\r\nbegin\r\n I := Pos(Separator, S);\r\n if I <> 0 then\r\n begin\r\n Result := Copy(S, 1, I - 1);\r\n Delete(S, 1, I);\r\n end\r\n else\r\n begin\r\n Result := S;\r\n S := '';\r\n end;\r\nend;\r\n\r\nprocedure StrTokens(const S: string; const List: TStrings);\r\nvar\r\n Start: PChar;\r\n Token: string;\r\n Done: Boolean;\r\nbegin\r\n Assert(List <> nil);\r\n if List = nil then\r\n Exit;\r\n\r\n List.BeginUpdate;\r\n try\r\n List.Clear;\r\n Start := Pointer(S);\r\n repeat\r\n Done := JclStrings.StrWord(Start, Token);\r\n if Token <> '' then\r\n List.Add(Token);\r\n until Done;\r\n finally\r\n List.EndUpdate;\r\n end;\r\nend;\r\n\r\nfunction StrWord(const S: string; var Index: SizeInt; out Word: string): Boolean;\r\nvar\r\n Start: SizeInt;\r\n C: Char;\r\nbegin\r\n Word := '';\r\n if (S = '') then\r\n begin\r\n Result := True;\r\n Exit;\r\n end;\r\n Start := Index;\r\n Result := False;\r\n while True do\r\n begin\r\n C := S[Index];\r\n case C of\r\n #0:\r\n begin\r\n if Start <> 0 then\r\n Word := Copy(S, Start, Index - Start);\r\n Result := True;\r\n Exit;\r\n end;\r\n NativeSpace, NativeLineFeed, NativeCarriageReturn:\r\n begin\r\n if Start <> 0 then\r\n begin\r\n Word := Copy(S, Start, Index - Start);\r\n Exit;\r\n end\r\n else\r\n begin\r\n while CharIsWhiteSpace(C) do\r\n begin\r\n Inc(Index);\r\n C := S[Index];\r\n end;\r\n end;\r\n end;\r\n else\r\n if Start = 0 then\r\n Start := Index;\r\n Inc(Index);\r\n end;\r\n end;\r\nend;\r\n\r\nfunction StrWord(var S: PChar; out Word: string): Boolean;\r\nvar\r\n Start: PChar;\r\nbegin\r\n Word := '';\r\n if S = nil then\r\n begin\r\n Result := True;\r\n Exit;\r\n end;\r\n Start := nil;\r\n Result := False;\r\n while True do\r\n begin\r\n case S^ of\r\n #0:\r\n begin\r\n if Start <> nil then\r\n SetString(Word, Start, S - Start);\r\n Result := True;\r\n Exit;\r\n end;\r\n NativeSpace, NativeLineFeed, NativeCarriageReturn:\r\n begin\r\n if Start <> nil then\r\n begin\r\n SetString(Word, Start, S - Start);\r\n Exit;\r\n end\r\n else\r\n while CharIsWhiteSpace(S^) do\r\n Inc(S);\r\n end;\r\n else\r\n if Start = nil then\r\n Start := S;\r\n Inc(S);\r\n end;\r\n end;\r\nend;\r\n\r\nfunction StrIdent(const S: string; var Index: SizeInt; out Ident: string): Boolean;\r\nvar\r\n Start: SizeInt;\r\n C: Char;\r\nbegin\r\n Ident := '';\r\n if (S = '') then\r\n begin\r\n Result := True;\r\n Exit;\r\n end;\r\n Start := Index;\r\n Result := False;\r\n while True do\r\n begin\r\n C := S[Index];\r\n if CharIsValidIdentifierLetter(C) then\r\n begin\r\n if Start = 0 then\r\n Start := Index;\r\n end\r\n else\r\n if C = #0 then\r\n begin\r\n if Start <> 0 then\r\n Ident := Copy(S, Start, Index - Start);\r\n Result := True;\r\n Exit;\r\n end\r\n else\r\n begin\r\n if Start <> 0 then\r\n begin\r\n Ident := Copy(S, Start, Index - Start);\r\n Exit;\r\n end;\r\n end;\r\n Inc(Index);\r\n end;\r\nend;\r\n\r\nfunction StrIdent(var S: PChar; out Ident: string): Boolean;\r\nvar\r\n Start: PChar;\r\n C: Char;\r\nbegin\r\n Ident := '';\r\n if S = nil then\r\n begin\r\n Result := True;\r\n Exit;\r\n end;\r\n Start := nil;\r\n Result := False;\r\n while True do\r\n begin\r\n C := S^;\r\n if CharIsValidIdentifierLetter(C) then\r\n begin\r\n if Start = nil then\r\n Start := S;\r\n end\r\n else\r\n if C = #0 then\r\n begin\r\n if Start <> nil then\r\n SetString(Ident, Start, S - Start);\r\n Result := True;\r\n Exit;\r\n end\r\n else\r\n begin\r\n if Start <> nil then\r\n begin\r\n SetString(Ident, Start, S - Start);\r\n Exit;\r\n end\r\n end;\r\n Inc(S);\r\n end;\r\nend;\r\n\r\nprocedure StrTokenToStrings(S: string; Separator: Char; const List: TStrings);\r\nvar\r\n Token: string;\r\nbegin\r\n Assert(List <> nil);\r\n\r\n if List = nil then\r\n Exit;\r\n\r\n List.BeginUpdate;\r\n try\r\n List.Clear;\r\n while S <> '' do\r\n begin\r\n Token := StrToken(S, Separator);\r\n List.Add(Token);\r\n end;\r\n finally\r\n List.EndUpdate;\r\n end;\r\nend;\r\n\r\nfunction StrToFloatSafe(const S: string): Float;\r\nvar\r\n Temp: string;\r\n I, J, K: SizeInt;\r\n SwapSeparators, IsNegative: Boolean;\r\n DecSep, ThouSep, C: Char;\r\nbegin\r\n DecSep := {$IFDEF RTL220_UP}FormatSettings.{$ENDIF}DecimalSeparator;\r\n ThouSep := {$IFDEF RTL220_UP}FormatSettings.{$ENDIF}ThousandSeparator;\r\n Temp := S;\r\n SwapSeparators := False;\r\n\r\n IsNegative := False;\r\n J := 0;\r\n for I := 1 to Length(Temp) do\r\n begin\r\n C := Temp[I];\r\n if C = '-' then\r\n IsNegative := not IsNegative\r\n else\r\n if (C <> ' ') and (C <> '(') and (C <> '+') then\r\n begin\r\n // if it appears prior to any digit, it has to be a decimal separator\r\n SwapSeparators := Temp[I] = ThouSep;\r\n J := I;\r\n Break;\r\n end;\r\n end;\r\n\r\n if not SwapSeparators then\r\n begin\r\n K := CharPos(Temp, DecSep);\r\n SwapSeparators :=\r\n // if it appears prior to any digit, it has to be a decimal separator\r\n (K > J) and\r\n // if it appears multiple times, it has to be a thousand separator\r\n ((StrCharCount(Temp, DecSep) > 1) or\r\n // we assume (consistent with Windows Platform SDK documentation),\r\n // that thousand separators appear only to the left of the decimal\r\n (K < CharPos(Temp, ThouSep)));\r\n end;\r\n\r\n if SwapSeparators then\r\n begin\r\n // assume a numerical string from a different locale,\r\n // where DecimalSeparator and ThousandSeparator are exchanged\r\n for I := 1 to Length(Temp) do\r\n if Temp[I] = DecSep then\r\n Temp[I] := ThouSep\r\n else\r\n if Temp[I] = ThouSep then\r\n Temp[I] := DecSep;\r\n end;\r\n\r\n Temp := StrKeepChars(Temp, CharIsNumber);\r\n\r\n if Length(Temp) > 0 then\r\n begin\r\n if Temp[1] = DecSep then\r\n Temp := '0' + Temp;\r\n if Temp[Length(Temp)] = DecSep then\r\n Temp := Temp + '0';\r\n Result := StrToFloat(Temp);\r\n if IsNegative then\r\n Result := -Result;\r\n end\r\n else\r\n Result := 0.0;\r\nend;\r\n\r\nfunction StrToIntSafe(const S: string): Integer;\r\nbegin\r\n Result := Trunc(StrToFloatSafe(S));\r\nend;\r\n\r\nprocedure StrNormIndex(const StrLen: SizeInt; var Index: SizeInt; var Count: SizeInt); overload;\r\nbegin\r\n Index := Max(1, Min(Index, StrLen + 1));\r\n Count := Max(0, Min(Count, StrLen + 1 - Index));\r\nend;\r\n\r\nfunction ArrayOf(List: TStrings): TDynStringArray;\r\nvar\r\n I: SizeInt;\r\nbegin\r\n if List <> nil then\r\n begin\r\n SetLength(Result, List.Count);\r\n for I := 0 to List.Count - 1 do\r\n Result[I] := List[I];\r\n end\r\n else\r\n Result := nil;\r\nend;\r\n\r\nconst\r\n BoolToStr: array [Boolean] of string = ('false', 'true');\r\n\r\ntype\r\n TInterfacedObjectAccess = class(TInterfacedObject);\r\n\r\nprocedure MoveChar(const Source; var Dest; Count: SizeInt);\r\nbegin\r\n if Count > 0 then\r\n Move(Source, Dest, Count * SizeOf(Char));\r\nend;\r\n\r\nfunction DotNetFormat(const Fmt: string; const Arg0: Variant): string;\r\nbegin\r\n Result := DotNetFormat(Fmt, [Arg0]);\r\nend;\r\n\r\nfunction DotNetFormat(const Fmt: string; const Arg0, Arg1: Variant): string;\r\nbegin\r\n Result := DotNetFormat(Fmt, [Arg0, Arg1]);\r\nend;\r\n\r\nfunction DotNetFormat(const Fmt: string; const Arg0, Arg1, Arg2: Variant): string;\r\nbegin\r\n Result := DotNetFormat(Fmt, [Arg0, Arg1, Arg2]);\r\nend;\r\n\r\nfunction DotNetFormat(const Fmt: string; const Args: array of const): string;\r\nvar\r\n F, P: PChar;\r\n Len, Capacity, Count: SizeInt;\r\n Index: SizeInt;\r\n ErrorCode: Integer;\r\n S: string;\r\n\r\n procedure Grow(Count: SizeInt);\r\n begin\r\n if Len + Count > Capacity then\r\n begin\r\n Capacity := Capacity * 5 div 3 + Count;\r\n SetLength(Result, Capacity);\r\n end;\r\n end;\r\n\r\n function InheritsFrom(AClass: TClass; const ClassName: string): Boolean;\r\n begin\r\n Result := True;\r\n while AClass <> nil do\r\n begin\r\n if CompareText(AClass.ClassName, ClassName) = 0 then\r\n Exit;\r\n AClass := AClass.ClassParent;\r\n end;\r\n Result := False;\r\n end;\r\n\r\n function GetStringOf(const V: TVarData; Index: SizeInt): string; overload;\r\n begin\r\n case V.VType of\r\n varEmpty, varNull:\r\n raise ArgumentNullException.CreateRes(@RsArgumentIsNull);\r\n varSmallInt:\r\n Result := IntToStr(V.VSmallInt);\r\n varInteger:\r\n Result := IntToStr(V.VInteger);\r\n varSingle:\r\n Result := FloatToStr(V.VSingle);\r\n varDouble:\r\n Result := FloatToStr(V.VDouble);\r\n varCurrency:\r\n Result := CurrToStr(V.VCurrency);\r\n varDate:\r\n Result := DateTimeToStr(V.VDate);\r\n varOleStr:\r\n Result := V.VOleStr;\r\n varBoolean:\r\n Result := BoolToStr[V.VBoolean <> False];\r\n varByte:\r\n Result := IntToStr(V.VByte);\r\n varWord:\r\n Result := IntToStr(V.VWord);\r\n varShortInt:\r\n Result := IntToStr(V.VShortInt);\r\n varLongWord:\r\n Result := IntToStr(V.VLongWord);\r\n varInt64:\r\n Result := IntToStr(V.VInt64);\r\n varString:\r\n Result := string(V.VString);\r\n {$IFDEF SUPPORTS_UNICODE_STRING}\r\n varUString:\r\n Result := string(V.VUString);\r\n {$ENDIF SUPPORTS_UNICODE_STRING}\r\n {varArray,\r\n varDispatch,\r\n varError,\r\n varUnknown,\r\n varAny,\r\n varByRef:}\r\n else\r\n raise ArgumentNullException.CreateResFmt(@RsDotNetFormatArgumentNotSupported, [Index]);\r\n end;\r\n end;\r\n\r\n function GetStringOf(Index: SizeInt): string; overload;\r\n var\r\n V: TVarRec;\r\n Intf: IToString;\r\n begin\r\n V := Args[Index];\r\n if (V.VInteger = 0) and\r\n (V.VType in [vtExtended, vtString, vtObject, vtClass, vtCurrency,\r\n vtInterface, vtInt64]) then\r\n raise ArgumentNullException.CreateResFmt(@RsArgumentIsNull, [Index]);\r\n\r\n case V.VType of\r\n vtInteger:\r\n Result := IntToStr(V.VInteger);\r\n vtBoolean:\r\n Result := BoolToStr[V.VBoolean];\r\n vtChar:\r\n Result := string(AnsiString(V.VChar));\r\n vtExtended:\r\n Result := FloatToStr(V.VExtended^);\r\n vtString:\r\n Result := string(V.VString^);\r\n vtPointer:\r\n Result := IntToHex(TJclAddr(V.VPointer), 8);\r\n vtPChar:\r\n Result := string(AnsiString(V.VPChar));\r\n vtObject:\r\n if (V.VObject is TInterfacedObject) and V.VObject.GetInterface(IToString, Intf) then\r\n begin\r\n Result := Intf.ToString;\r\n Pointer(Intf) := nil; // do not release the object\r\n // undo the RefCount change\r\n Dec(TInterfacedObjectAccess(V.VObject).FRefCount);\r\n end\r\n else\r\n if InheritsFrom(V.VObject.ClassType, 'TComponent') and V.VObject.GetInterface(IToString, Intf) then\r\n Result := Intf.ToString\r\n else\r\n raise ArgumentNullException.CreateResFmt(@RsDotNetFormatArgumentNotSupported, [Index]);\r\n vtClass:\r\n Result := V.VClass.ClassName;\r\n vtWideChar:\r\n Result := V.VWideChar;\r\n vtPWideChar:\r\n Result := V.VPWideChar;\r\n vtAnsiString:\r\n Result := string(V.VAnsiString);\r\n vtCurrency:\r\n Result := CurrToStr(V.VCurrency^);\r\n vtVariant:\r\n Result := GetStringOf(TVarData(V.VVariant^), Index);\r\n vtInterface:\r\n if IInterface(V.VInterface).QueryInterface(IToString, Intf) = 0 then\r\n Result := IToString(Intf).ToString\r\n else\r\n raise ArgumentNullException.CreateResFmt(@RsDotNetFormatArgumentNotSupported, [Index]);\r\n vtWideString:\r\n Result := WideString(V.VWideString);\r\n vtInt64:\r\n Result := IntToStr(V.VInt64^);\r\n {$IFDEF SUPPORTS_UNICODE_STRING}\r\n vtUnicodeString:\r\n Result := UnicodeString(V.VUnicodeString);\r\n {$ENDIF SUPPORTS_UNICODE_STRING}\r\n else\r\n raise ArgumentNullException.CreateResFmt(@RsDotNetFormatArgumentNotSupported, [Index]);\r\n end;\r\n end;\r\n\r\nbegin\r\n if Length(Args) = 0 then\r\n begin\r\n Result := Fmt;\r\n Exit;\r\n end;\r\n Len := 0;\r\n Capacity := Length(Fmt);\r\n SetLength(Result, Capacity);\r\n if Capacity = 0 then\r\n raise ArgumentNullException.CreateRes(@RsDotNetFormatNullFormat);\r\n\r\n P := Pointer(Fmt);\r\n F := P;\r\n while True do\r\n begin\r\n if (P[0] = #0) or (P[0] = '{') then\r\n begin\r\n Count := P - F;\r\n Inc(P);\r\n if (P[-1] <> #0) and (P[0] = '{') then\r\n Inc(Count); // include '{'\r\n\r\n if Count > 0 then\r\n begin\r\n Grow(Count);\r\n MoveChar(F[0], Result[Len + 1], Count);\r\n Inc(Len, Count);\r\n end;\r\n\r\n if P[-1] = #0 then\r\n Break;\r\n\r\n if P[0] <> '{' then\r\n begin\r\n F := P;\r\n Inc(P);\r\n while (P[0] <> #0) and (P[0] <> '}') do\r\n Inc(P);\r\n SetString(S, F, P - F);\r\n Val(S, Index, ErrorCode);\r\n if ErrorCode <> 0 then\r\n raise FormatException.CreateRes(@RsFormatException);\r\n if (Index < 0) or (Index > High(Args)) then\r\n raise FormatException.CreateRes(@RsFormatException);\r\n S := GetStringOf(Index);\r\n if S <> '' then\r\n begin\r\n Grow(Length(S));\r\n MoveChar(S[1], Result[Len + 1], Length(S));\r\n Inc(Len, Length(S));\r\n end;\r\n\r\n if P[0] = #0 then\r\n Break;\r\n end;\r\n F := P + 1;\r\n end\r\n else\r\n if (P[0] = '}') and (P[1] = '}') then\r\n begin\r\n Count := P - F + 1;\r\n Inc(P); // skip next '}'\r\n\r\n Grow(Count);\r\n MoveChar(F[0], Result[Len + 1], Count);\r\n Inc(Len, Count);\r\n F := P + 1;\r\n end;\r\n\r\n Inc(P);\r\n end;\r\n\r\n SetLength(Result, Len);\r\nend;\r\n\r\n//=== { TJclStringBuilder } =====================================================\r\n\r\nconstructor TJclStringBuilder.Create(Capacity: SizeInt; MaxCapacity: SizeInt);\r\nbegin\r\n inherited Create;\r\n SetLength(FChars, Capacity);\r\n FMaxCapacity := MaxCapacity;\r\nend;\r\n\r\nconstructor TJclStringBuilder.Create(const Value: string; Capacity: SizeInt);\r\nbegin\r\n Create(Capacity);\r\n Append(Value);\r\nend;\r\n\r\nconstructor TJclStringBuilder.Create(const Value: string; StartIndex,\r\n Length, Capacity: SizeInt);\r\nbegin\r\n Create(Capacity);\r\n Append(Value, StartIndex + 1, Length);\r\nend;\r\n\r\nfunction TJclStringBuilder.ToString: string;\r\nbegin\r\n if FLength > 0 then\r\n SetString(Result, PChar(@FChars[0]), FLength)\r\n else\r\n Result := '';\r\nend;\r\n\r\nfunction TJclStringBuilder.EnsureCapacity(Capacity: SizeInt): SizeInt;\r\nbegin\r\n if System.Length(FChars) < Capacity then\r\n SetCapacity(Capacity);\r\n Result := System.Length(FChars);\r\nend;\r\n\r\nprocedure TJclStringBuilder.SetCapacity(const Value: SizeInt);\r\nbegin\r\n if Value <> System.Length(FChars) then\r\n begin\r\n SetLength(FChars, Value);\r\n if Value < FLength then\r\n FLength := Value;\r\n end;\r\nend;\r\n\r\nfunction TJclStringBuilder.GetChars(Index: SizeInt): Char;\r\nbegin\r\n Result := FChars[Index];\r\nend;\r\n\r\nprocedure TJclStringBuilder.SetChars(Index: SizeInt; const Value: Char);\r\nbegin\r\n FChars[Index] := Value;\r\nend;\r\n\r\nprocedure TJclStringBuilder.Set_Length(const Value: SizeInt);\r\nbegin\r\n FLength := Value;\r\nend;\r\n\r\nfunction TJclStringBuilder.GetCapacity: SizeInt;\r\nbegin\r\n Result := System.Length(FChars);\r\nend;\r\n\r\nfunction TJclStringBuilder.AppendPChar(Value: PChar; Count: SizeInt; RepeatCount: SizeInt): TJclStringBuilder;\r\nvar\r\n Capacity: SizeInt;\r\nbegin\r\n if (Count > 0) and (RepeatCount > 0) then\r\n begin\r\n repeat\r\n Capacity := System.Length(FChars);\r\n if Capacity + Count > MaxCapacity then\r\n raise ArgumentOutOfRangeException.CreateRes(@RsArgumentOutOfRange);\r\n if Capacity < FLength + Count then\r\n SetLength(FChars, Capacity * 5 div 3 + Count);\r\n if Count = 1 then\r\n FChars[FLength] := Value[0]\r\n else\r\n MoveChar(Value[0], FChars[FLength], Count);\r\n Inc(FLength, Count);\r\n Dec(RepeatCount);\r\n until RepeatCount <= 0;\r\n end;\r\n Result := Self;\r\nend;\r\n\r\nfunction TJclStringBuilder.InsertPChar(Index: SizeInt; Value: PChar; Count,\r\n RepeatCount: SizeInt): TJclStringBuilder;\r\nvar\r\n Capacity: SizeInt;\r\nbegin\r\n if (Index < 0) or (Index > FLength) then\r\n raise ArgumentOutOfRangeException.CreateRes(@RsArgumentOutOfRange);\r\n\r\n if Index = FLength then\r\n AppendPChar(Value, Count, RepeatCount)\r\n else\r\n if (Count > 0) and (RepeatCount > 0) then\r\n begin\r\n repeat\r\n Capacity := System.Length(FChars);\r\n if Capacity + Count > MaxCapacity then\r\n raise ArgumentOutOfRangeException.CreateRes(@RsArgumentOutOfRange);\r\n if Capacity < FLength + Count then\r\n SetLength(FChars, Capacity * 5 div 3 + Count);\r\n MoveChar(FChars[Index], FChars[Index + Count], FLength - Index);\r\n if Count = 1 then\r\n FChars[Index] := Value[0]\r\n else\r\n MoveChar(Value[0], FChars[Index], Count);\r\n Inc(FLength, Count);\r\n\r\n Dec(RepeatCount);\r\n\r\n Inc(Index, Count); // little optimization\r\n until RepeatCount <= 0;\r\n end;\r\n Result := Self;\r\nend;\r\n\r\nfunction TJclStringBuilder.Append(const Value: array of Char): TJclStringBuilder;\r\nvar\r\n Len: SizeInt;\r\nbegin\r\n Len := System.Length(Value);\r\n if Len > 0 then\r\n AppendPChar(@Value[0], Len);\r\n Result := Self;\r\nend;\r\n\r\nfunction TJclStringBuilder.Append(const Value: array of Char; StartIndex, Length: SizeInt): TJclStringBuilder;\r\nvar\r\n Len: SizeInt;\r\nbegin\r\n Len := System.Length(Value);\r\n if (Length > 0) and (StartIndex < Len) then\r\n begin\r\n if StartIndex + Length > Len then\r\n Length := Len - StartIndex;\r\n AppendPChar(PChar(@Value[0]) + StartIndex, Length);\r\n end;\r\n Result := Self;\r\nend;\r\n\r\nfunction TJclStringBuilder.Append(Value: Char; RepeatCount: SizeInt = 1): TJclStringBuilder;\r\nbegin\r\n Result := AppendPChar(@Value, 1, RepeatCount);\r\nend;\r\n\r\nfunction TJclStringBuilder.Append(const Value: string): TJclStringBuilder;\r\nvar\r\n Len: SizeInt;\r\nbegin\r\n Len := System.Length(Value);\r\n if Len > 0 then\r\n AppendPChar(Pointer(Value), Len);\r\n Result := Self;\r\nend;\r\n\r\nfunction TJclStringBuilder.Append(const Value: string; StartIndex, Length: SizeInt): TJclStringBuilder;\r\nvar\r\n Len: SizeInt;\r\nbegin\r\n Len := System.Length(Value);\r\n if (Length > 0) and (StartIndex < Len) then\r\n begin\r\n if StartIndex + Length > Len then\r\n Length := Len - StartIndex;\r\n AppendPChar(PChar(Pointer(Value)) + StartIndex, Length);\r\n end;\r\n Result := Self;\r\nend;\r\n\r\nfunction TJclStringBuilder.Append(Value: Boolean): TJclStringBuilder;\r\nbegin\r\n Result := Append(BoolToStr[Value]);\r\nend;\r\n\r\nfunction TJclStringBuilder.Append(Value: Cardinal): TJclStringBuilder;\r\nbegin\r\n Result := Append(IntToStr(Value));\r\nend;\r\n\r\nfunction TJclStringBuilder.Append(Value: Integer): TJclStringBuilder;\r\nbegin\r\n Result := Append(IntToStr(Value));\r\nend;\r\n\r\nfunction TJclStringBuilder.Append(Value: Double): TJclStringBuilder;\r\nbegin\r\n Result := Append(FloatToStr(Value));\r\nend;\r\n\r\nfunction TJclStringBuilder.Append(Value: Int64): TJclStringBuilder;\r\nbegin\r\n Result := Append(IntToStr(Value));\r\nend;\r\n\r\nfunction TJclStringBuilder.Append(Obj: TObject): TJclStringBuilder;\r\nbegin\r\n Result := Append(DotNetFormat('{0}', [Obj]));\r\nend;\r\n\r\nfunction TJclStringBuilder.AppendFormat(const Fmt: string; Arg0: Variant): TJclStringBuilder;\r\nbegin\r\n Result := Append(DotNetFormat(Fmt, [Arg0]));\r\nend;\r\n\r\nfunction TJclStringBuilder.AppendFormat(const Fmt: string; Arg0, Arg1: Variant): TJclStringBuilder;\r\nbegin\r\n Result := Append(DotNetFormat(Fmt, [Arg0, Arg1]));\r\nend;\r\n\r\nfunction TJclStringBuilder.AppendFormat(const Fmt: string; Arg0, Arg1, Arg2: Variant): TJclStringBuilder;\r\nbegin\r\n Result := Append(DotNetFormat(Fmt, [Arg0, Arg1, Arg2]));\r\nend;\r\n\r\nfunction TJclStringBuilder.AppendFormat(const Fmt: string; const Args: array of const): TJclStringBuilder;\r\nbegin\r\n Result := Append(DotNetFormat(Fmt, Args));\r\nend;\r\n\r\nfunction TJclStringBuilder.Insert(Index: SizeInt; const Value: array of Char): TJclStringBuilder;\r\nvar\r\n Len: SizeInt;\r\nbegin\r\n Len := System.Length(Value);\r\n if Len > 0 then\r\n InsertPChar(Index, @Value[0], Len);\r\n Result := Self;\r\nend;\r\n\r\nfunction TJclStringBuilder.Insert(Index: SizeInt; const Value: string; Count: SizeInt): TJclStringBuilder;\r\nvar\r\n Len: SizeInt;\r\nbegin\r\n Len := System.Length(Value);\r\n if Len > 0 then\r\n InsertPChar(Index, Pointer(Value), Len, Count);\r\n Result := Self;\r\nend;\r\n\r\nfunction TJclStringBuilder.Insert(Index: SizeInt; Value: Boolean): TJclStringBuilder;\r\nbegin\r\n Result := Insert(Index, BoolToStr[Value]);\r\nend;\r\n\r\nfunction TJclStringBuilder.Insert(Index: SizeInt; const Value: array of Char;\r\n StartIndex, Length: SizeInt): TJclStringBuilder;\r\nvar\r\n Len: SizeInt;\r\nbegin\r\n Len := System.Length(Value);\r\n if (Length > 0) and (StartIndex < Len) then\r\n begin\r\n if StartIndex + Length > Len then\r\n Length := Len - StartIndex;\r\n InsertPChar(Index, PChar(@Value[0]) + StartIndex, Length);\r\n end;\r\n Result := Self;\r\nend;\r\n\r\nfunction TJclStringBuilder.Insert(Index: SizeInt; Value: Double): TJclStringBuilder;\r\nbegin\r\n Result := Insert(Index, FloatToStr(Value));\r\nend;\r\n\r\nfunction TJclStringBuilder.Insert(Index: SizeInt; Value: Int64): TJclStringBuilder;\r\nbegin\r\n Result := Insert(Index, IntToStr(Value));\r\nend;\r\n\r\nfunction TJclStringBuilder.Insert(Index: SizeInt; Value: Cardinal): TJclStringBuilder;\r\nbegin\r\n Result := Insert(Index, IntToStr(Value));\r\nend;\r\n\r\nfunction TJclStringBuilder.Insert(Index: SizeInt; Value: Integer): TJclStringBuilder;\r\nbegin\r\n Result := Insert(Index, IntToStr(Value));\r\nend;\r\n\r\nfunction TJclStringBuilder.Insert(Index: SizeInt; Obj: TObject): TJclStringBuilder;\r\nbegin\r\n Result := Insert(Index, Format('{0}', [Obj]));\r\nend;\r\n\r\nfunction TJclStringBuilder.Remove(StartIndex, Length: SizeInt): TJclStringBuilder;\r\nbegin\r\n if (StartIndex < 0) or (Length < 0) or (StartIndex + Length >= FLength) then\r\n raise ArgumentOutOfRangeException.CreateRes(@RsArgumentOutOfRange);\r\n if Length > 0 then\r\n begin\r\n MoveChar(FChars[StartIndex + Length], FChars[StartIndex], FLength - (StartIndex + Length));\r\n Dec(FLength, Length);\r\n end;\r\n Result := Self;\r\nend;\r\n\r\nfunction TJclStringBuilder.Replace(OldChar, NewChar: Char; StartIndex,\r\n Count: SizeInt): TJclStringBuilder;\r\nvar\r\n I: SizeInt;\r\nbegin\r\n if Count = -1 then\r\n Count := FLength;\r\n if (StartIndex < 0) or (Count < 0) or (StartIndex + Count > FLength) then\r\n raise ArgumentOutOfRangeException.CreateRes(@RsArgumentOutOfRange);\r\n if (Count > 0) and (OldChar <> NewChar) then\r\n begin\r\n for I := StartIndex to StartIndex + Length - 1 do\r\n if FChars[I] = OldChar then\r\n FChars[I] := NewChar;\r\n end;\r\n Result := Self;\r\nend;\r\n\r\nfunction TJclStringBuilder.Replace(OldValue, NewValue: string; StartIndex, Count: SizeInt): TJclStringBuilder;\r\nvar\r\n I: SizeInt;\r\n Offset: SizeInt;\r\n NewLen, OldLen, Capacity: SizeInt;\r\nbegin\r\n if Count = -1 then\r\n Count := FLength;\r\n if (StartIndex < 0) or (Count < 0) or (StartIndex + Count > FLength) then\r\n raise ArgumentOutOfRangeException.CreateRes(@RsArgumentOutOfRange);\r\n if OldValue = '' then\r\n raise ArgumentException.CreateResFmt(@RsArgumentIsNull, [0]);\r\n\r\n if (Count > 0) and (OldValue <> NewValue) then\r\n begin\r\n OldLen := System.Length(OldValue);\r\n NewLen := System.Length(NewValue);\r\n Offset := NewLen - OldLen;\r\n Capacity := System.Length(FChars);\r\n for I := StartIndex to StartIndex + Length - 1 do\r\n if FChars[I] = OldValue[1] then\r\n begin\r\n if OldLen > 1 then\r\n if StrLComp(@FChars[I + 1], PChar(OldValue) + 1, OldLen - 1) <> 0 then\r\n Continue;\r\n if Offset <> 0 then\r\n begin\r\n if FLength - OldLen + NewLen > MaxCurrency then\r\n raise ArgumentOutOfRangeException.CreateRes(@RsArgumentOutOfRange);\r\n if Capacity < FLength + Offset then\r\n begin\r\n Capacity := Capacity * 5 div 3 + Offset;\r\n SetLength(FChars, Capacity);\r\n end;\r\n if Offset < 0 then\r\n MoveChar(FChars[I - Offset], FChars[I], FLength - I)\r\n else\r\n MoveChar(FChars[I + OldLen], FChars[I + OldLen + Offset], FLength - OldLen - I);\r\n Inc(FLength, Offset);\r\n end;\r\n if NewLen > 0 then\r\n begin\r\n if (OldLen = 1) and (NewLen = 1) then\r\n FChars[I] := NewValue[1]\r\n else\r\n MoveChar(NewValue[1], FChars[I], NewLen);\r\n end;\r\n end;\r\n end;\r\n Result := Self;\r\nend;\r\n\r\nfunction StrExpandTabs(S: string): string;\r\nbegin\r\n // use an empty tab set, which will default to a tab width of 2\r\n Result := TJclTabSet(nil).Expand(s);\r\nend;\r\n\r\nfunction StrExpandTabs(S: string; TabWidth: SizeInt): string;\r\nvar\r\n TabSet: TJclTabSet;\r\nbegin\r\n // create a tab set with no tab stops and the given tab width\r\n TabSet := TJclTabSet.Create(TabWidth);\r\n try\r\n Result := TabSet.Expand(S);\r\n finally\r\n TabSet.Free;\r\n end;\r\nend;\r\n\r\nfunction StrExpandTabs(S: string; TabSet: TJclTabSet): string;\r\nbegin\r\n // use the provided tab set to perform the expansion\r\n Result := TabSet.Expand(S);\r\nend;\r\n\r\nfunction StrOptimizeTabs(S: string): string;\r\nbegin\r\n // use an empty tab set, which will default to a tab width of 2\r\n Result := TJclTabSet(nil).Optimize(s);\r\nend;\r\n\r\nfunction StrOptimizeTabs(S: string; TabWidth: SizeInt): string;\r\nvar\r\n TabSet: TJclTabSet;\r\nbegin\r\n // create a tab set with no tab stops and the given tab width\r\n TabSet := TJclTabSet.Create(TabWidth);\r\n try\r\n Result := TabSet.Optimize(S);\r\n finally\r\n TabSet.Free;\r\n end;\r\nend;\r\n\r\nfunction StrOptimizeTabs(S: string; TabSet: TJclTabSet): string;\r\nbegin\r\n // use the provided tab set to perform the optimization\r\n Result := TabSet.Optimize(S);\r\nend;\r\n\r\n// === { TTabSetData } ===================================================\r\n\r\ntype\r\n TTabSetData = class\r\n public\r\n FStops: TDynSizeIntArray;\r\n FRealWidth: SizeInt;\r\n FRefCount: SizeInt;\r\n FWidth: SizeInt;\r\n FZeroBased: Boolean;\r\n constructor Create(TabStops: array of SizeInt; ZeroBased: Boolean; TabWidth: SizeInt);\r\n\r\n function Add(Column: SizeInt): SizeInt;\r\n function AddRef: SizeInt;\r\n procedure CalcRealWidth;\r\n function FindStop(Column: SizeInt): SizeInt;\r\n function ReleaseRef: SizeInt;\r\n procedure RemoveAt(Index: SizeInt);\r\n procedure SetStops(Index, Value: SizeInt);\r\n end;\r\n\r\nconstructor TTabSetData.Create(TabStops: array of SizeInt; ZeroBased: Boolean; TabWidth: SizeInt);\r\nvar\r\n idx: SizeInt;\r\nbegin\r\n inherited Create;\r\n FRefCount := 1;\r\n for idx := 0 to High(Tabstops) do\r\n Add(Tabstops[idx]);\r\n FWidth := TabWidth;\r\n FZeroBased := ZeroBased;\r\n CalcRealWidth;\r\nend;\r\n\r\nfunction TTabSetData.Add(Column: SizeInt): SizeInt;\r\nvar\r\n I: SizeInt;\r\nbegin\r\n if Column < Ord(FZeroBased) then\r\n raise ArgumentOutOfRangeException.Create('Column');\r\n Result := FindStop(Column);\r\n if Result < 0 then\r\n begin\r\n // the column doesn't exist; invert the result of FindStop to get the correct index position\r\n Result := not Result;\r\n // increase the tab stop array\r\n SetLength(FStops, Length(FStops) + 1);\r\n // shift rooms after the insert position\r\n for I := High(FStops) - 1 downto Result do\r\n FStops[I + 1] := FStops[I];\r\n // add the tab stop at the correct location\r\n FStops[Result] := Column;\r\n CalcRealWidth;\r\n end\r\n else\r\n begin\r\n raise EJclStringError.CreateRes(@RsTabs_DuplicatesNotAllowed);\r\n end;\r\nend;\r\n\r\nfunction TTabSetData.AddRef: SizeInt;\r\nbegin\r\n Result := LockedInc(FRefCount);\r\nend;\r\n\r\nprocedure TTabSetData.CalcRealWidth;\r\nbegin\r\n if FWidth < 1 then\r\n begin\r\n if Length(FStops) > 1 then\r\n FRealWidth := FStops[High(FStops)] - FStops[Pred(High(FStops))]\r\n else\r\n if Length(FStops) = 1 then\r\n FRealWidth := FStops[0]\r\n else\r\n FRealWidth := 2;\r\n end\r\n else\r\n FRealWidth := FWidth;\r\nend;\r\n\r\nfunction TTabSetData.FindStop(Column: SizeInt): SizeInt;\r\nbegin\r\n Result := High(FStops);\r\n while (Result >= 0) and (FStops[Result] > Column) do\r\n Dec(Result);\r\n if (Result >= 0) and (FStops[Result] <> Column) then\r\n Result := not Succ(Result);\r\nend;\r\n\r\nfunction TTabSetData.ReleaseRef: SizeInt;\r\nbegin\r\n Result := LockedDec(FRefCount);\r\n if Result <= 0 then\r\n Destroy;\r\nend;\r\n\r\nprocedure TTabSetData.RemoveAt(Index: SizeInt);\r\nvar\r\n I: SizeInt;\r\nbegin\r\n for I := Index to High(FStops) - 1 do\r\n FStops[I] := FStops[I + 1];\r\n SetLength(FStops, High(FStops));\r\n CalcRealWidth;\r\nend;\r\n\r\nprocedure TTabSetData.SetStops(Index, Value: SizeInt);\r\nvar\r\n temp: SizeInt;\r\nbegin\r\n if (Index < 0) or (Index >= Length(FStops)) then\r\n begin\r\n raise ArgumentOutOfRangeException.CreateRes(@RsArgumentOutOfRange);\r\n end\r\n else\r\n begin\r\n temp := FindStop(Value);\r\n if temp < 0 then\r\n begin\r\n // remove existing tab stop...\r\n RemoveAt(Index);\r\n // now add the new tab stop\r\n Add(Value);\r\n end\r\n else\r\n if temp <> Index then\r\n begin\r\n // new tab stop already present at another index\r\n raise EJclStringError.CreateRes(@RsTabs_DuplicatesNotAllowed);\r\n end;\r\n end;\r\nend;\r\n\r\n//=== { TJclTabSet } =====================================================\r\n\r\nconstructor TJclTabSet.Create;\r\nbegin\r\n // no tab stops, tab width set to auto\r\n Create([], True, 0);\r\nend;\r\n\r\nconstructor TJclTabSet.Create(TabWidth: SizeInt);\r\nbegin\r\n // no tab stops, specified tab width\r\n Create([], True, TabWidth);\r\nend;\r\n\r\nconstructor TJclTabSet.Create(const Tabstops: array of SizeInt; ZeroBased: Boolean);\r\nbegin\r\n // specified tab stops, tab width equal to distance between last two tab stops\r\n Create(Tabstops, ZeroBased, 0);\r\nend;\r\n\r\nconstructor TJclTabSet.Create(const Tabstops: array of SizeInt; ZeroBased: Boolean; TabWidth: SizeInt);\r\nbegin\r\n inherited Create;\r\n FData := TTabSetData.Create(Tabstops, ZeroBased, TabWidth);\r\nend;\r\n\r\nconstructor TJclTabSet.Create(Data: TObject);\r\nbegin\r\n inherited Create;\r\n // add a reference to the data\r\n TTabSetData(Data).AddRef;\r\n // assign the data to this instance\r\n FData := TTabSetData(Data);\r\nend;\r\n\r\ndestructor TJclTabSet.Destroy;\r\nbegin\r\n // release the reference to the tab set data\r\n TTabSetData(FData).ReleaseRef;\r\n // make sure we won't accidentally refer to it later, just in case something goes wrong during destruction\r\n FData := nil;\r\n // really destroy the instance\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJclTabSet.Add(Column: SizeInt): SizeInt;\r\nbegin\r\n if Self = nil then\r\n raise NullReferenceException.Create;\r\n Result := TTabSetData(FData).Add(Column);\r\nend;\r\n\r\nfunction TJclTabSet.Clone: TJclTabSet;\r\nbegin\r\n if Self <> nil then\r\n Result := TJclTabSet.Create(TTabSetData(FData).FStops, TTabSetData(FData).FZeroBased, TTabSetData(FData).FWidth)\r\n else\r\n Result := nil;\r\nend;\r\n\r\nfunction TJclTabSet.Delete(Column: SizeInt): SizeInt;\r\nbegin\r\n Result := TTabSetData(FData).FindStop(Column);\r\n if Result >= 0 then\r\n TTabSetData(FData).RemoveAt(Result);\r\nend;\r\n\r\nfunction TJclTabSet.Expand(const S: string): string;\r\nbegin\r\n Result := Expand(s, StartColumn);\r\nend;\r\n\r\nfunction TJclTabSet.Expand(const S: string; Column: SizeInt): string;\r\nvar\r\n sb: TJclStringBuilder;\r\n head: PChar;\r\n cur: PChar;\r\nbegin\r\n if Column < StartColumn then\r\n raise ArgumentOutOfRangeException.Create('Column');\r\n sb := TJclStringBuilder.Create(Length(S));\r\n try\r\n cur := PChar(S);\r\n while cur^ <> #0 do\r\n begin\r\n head := cur;\r\n while (cur^ <> #0) and (cur^ <> #9) do\r\n begin\r\n if CharIsReturn(cur^) then\r\n Column := StartColumn\r\n else\r\n Inc(Column);\r\n Inc(cur);\r\n end;\r\n if cur > head then\r\n sb.Append(head, 0, cur - head);\r\n if cur^ = #9 then\r\n begin\r\n sb.Append(' ', TabFrom(Column) - Column);\r\n Column := TabFrom(Column);\r\n Inc(cur);\r\n end;\r\n end;\r\n Result := sb.ToString;\r\n finally\r\n sb.Free;\r\n end;\r\nend;\r\n\r\nfunction TJclTabSet.FindStop(Column: SizeInt): SizeInt;\r\nbegin\r\n if Self <> nil then\r\n Result := TTabSetData(FData).FindStop(Column)\r\n else\r\n Result := -1;\r\nend;\r\n\r\nclass function TJclTabSet.FromString(const S: string): TJclTabSet;\r\nvar\r\n cur: PChar;\r\n\r\n function ParseNumber: Integer;\r\n var\r\n head: PChar;\r\n begin\r\n StrSkipChars(cur, CharIsWhiteSpace);\r\n head := cur;\r\n while CharIsDigit(cur^) do\r\n Inc(cur);\r\n Result := -1;\r\n if (cur <= head) or not TryStrToInt(Copy(head, 1, cur - head), Result) then\r\n Result := -1;\r\n end;\r\n\r\n procedure ParseStops;\r\n var\r\n openBracket, hadComma: Boolean;\r\n num: SizeInt;\r\n begin\r\n StrSkipChars(cur, CharIsWhiteSpace);\r\n openBracket := cur^ = '[';\r\n hadComma := False;\r\n if openBracket then\r\n Inc(cur);\r\n repeat\r\n num := ParseNumber;\r\n if (num < 0) and hadComma then\r\n raise EJclStringError.CreateRes(@RsTabs_StopExpected)\r\n else\r\n if num >= 0 then\r\n Result.Add(num);\r\n StrSkipChars(cur, CharIsWhiteSpace);\r\n hadComma := cur^ = ',';\r\n if hadComma then\r\n Inc(cur);\r\n until (cur^ = #0) or (cur^ = '+') or (cur^ = ']');\r\n if hadComma then\r\n raise EJclStringError.CreateRes(@RsTabs_StopExpected)\r\n else\r\n if openBracket and (cur^ <> ']') then\r\n raise EJclStringError.CreateRes(@RsTabs_CloseBracketExpected);\r\n end;\r\n\r\n procedure ParseTabWidth;\r\n var\r\n num: SizeInt;\r\n begin\r\n StrSkipChars(cur, CharIsWhiteSpace);\r\n if cur^ = '+' then\r\n begin\r\n Inc(cur);\r\n StrSkipChars(cur, CharIsWhiteSpace);\r\n num := ParseNumber;\r\n if (num < 0) then\r\n raise EJclStringError.CreateRes(@RsTabs_TabWidthExpected)\r\n else\r\n Result.TabWidth := num;\r\n end;\r\n end;\r\n\r\n procedure ParseZeroBasedFlag;\r\n begin\r\n StrSkipChars(cur, CharIsWhiteSpace);\r\n if cur^ = '0' then\r\n begin\r\n Inc(cur);\r\n if CharIsWhiteSpace(cur^) or (cur^ = #0) or (cur^ = '[') then\r\n begin\r\n Result.ZeroBased := True;\r\n StrSkipChars(cur, CharIsWhiteSpace);\r\n end\r\n else\r\n Dec(cur);\r\n end;\r\n end;\r\n\r\nbegin\r\n Result := TJclTabSet.Create;\r\n try\r\n Result.ZeroBased := False;\r\n cur := PChar(S);\r\n ParseZeroBasedFlag;\r\n ParseStops;\r\n ParseTabWidth;\r\n except\r\n // clean up the partially complete instance (to avoid memory leaks)...\r\n Result.Free;\r\n // ... and re-raise the exception\r\n raise;\r\n end;\r\nend;\r\n\r\nfunction TJclTabSet.GetCount: SizeInt;\r\nbegin\r\n if Self <> nil then\r\n Result := Length(TTabSetData(FData).FStops)\r\n else\r\n Result := 0;\r\nend;\r\n\r\nfunction TJclTabSet.GetStops(Index: SizeInt): SizeInt;\r\nbegin\r\n if Self <> nil then\r\n begin\r\n if (Index < 0) or (Index >= Length(TTabSetData(FData).FStops)) then\r\n begin\r\n raise EJclStringError.CreateRes(@RsArgumentOutOfRange);\r\n end\r\n else\r\n Result := TTabSetData(FData).FStops[Index];\r\n end\r\n else\r\n begin\r\n raise EJclStringError.CreateRes(@RsArgumentOutOfRange);\r\n end;\r\nend;\r\n\r\nfunction TJclTabSet.GetTabWidth: SizeInt;\r\nbegin\r\n if Self <> nil then\r\n Result := TTabSetData(FData).FWidth\r\n else\r\n Result := 0;\r\nend;\r\n\r\nfunction TJclTabSet.GetZeroBased: Boolean;\r\nbegin\r\n Result := (Self = nil) or TTabSetData(FData).FZeroBased;\r\nend;\r\n\r\nprocedure TJclTabSet.OptimalFillInfo(StartColumn, TargetColumn: SizeInt; out TabsNeeded, SpacesNeeded: SizeInt);\r\nvar\r\n nextTab: SizeInt;\r\nbegin\r\n if StartColumn < Self.StartColumn then // starting column less than 1 or 0 (depending on ZeroBased state)\r\n raise ArgumentOutOfRangeException.Create('StartColumn');\r\n if (TargetColumn < StartColumn) then // target lies before the starting column\r\n raise ArgumentOutOfRangeException.Create('TargetColumn');\r\n TabsNeeded := 0;\r\n repeat\r\n nextTab := TabFrom(StartColumn);\r\n if nextTab <= TargetColumn then\r\n begin\r\n Inc(TabsNeeded);\r\n StartColumn := nextTab;\r\n end;\r\n until nextTab > TargetColumn;\r\n SpacesNeeded := TargetColumn - StartColumn;\r\nend;\r\n\r\nfunction TJclTabSet.Optimize(const S: string): string;\r\nbegin\r\n Result := Optimize(S, StartColumn);\r\nend;\r\n\r\nfunction TJclTabSet.Optimize(const S: string; Column: SizeInt): string;\r\nvar\r\n sb: TJclStringBuilder;\r\n head: PChar;\r\n cur: PChar;\r\n tgt: SizeInt;\r\n\r\n procedure AppendOptimalWhiteSpace(Target: SizeInt);\r\n var\r\n tabCount: SizeInt;\r\n spaceCount: SizeInt;\r\n begin\r\n if cur > head then\r\n begin\r\n OptimalFillInfo(Column, Target, tabCount, spaceCount);\r\n if tabCount > 0 then\r\n sb.Append(#9, tabCount);\r\n if spaceCount > 0 then\r\n sb.Append(' ', spaceCount);\r\n end;\r\n end;\r\n\r\nbegin\r\n if Column < StartColumn then\r\n raise ArgumentOutOfRangeException.Create('Column');\r\n sb := TJclStringBuilder.Create(Length(S));\r\n try\r\n cur := PChar(s);\r\n while cur^ <> #0 do\r\n begin\r\n // locate first whitespace character\r\n head := cur;\r\n while (cur^ <> #0) and not CharIsWhiteSpace(cur^) do\r\n Inc(cur);\r\n // output non whitespace characters\r\n if cur > head then\r\n sb.Append(head, 0, cur - head);\r\n // advance column\r\n Inc(Column, cur - head);\r\n // initialize target column indexer\r\n tgt := Column;\r\n // locate end of whitespace sequence\r\n while CharIsWhiteSpace(cur^) do\r\n begin\r\n if CharIsReturn(cur^) then\r\n begin\r\n // append optimized whitespace sequence...\r\n AppendOptimalWhiteSpace(tgt);\r\n // ...set the column back to the start of the line...\r\n Column := StartColumn;\r\n // ...reset target column indexer...\r\n tgt := Column;\r\n // ...add the line break character...\r\n sb.Append(cur^);\r\n end\r\n else\r\n if cur^ = #9 then\r\n tgt := TabFrom(tgt) // expand the tab\r\n else\r\n Inc(tgt); // a normal whitespace; taking up 1 column\r\n Inc(cur);\r\n end;\r\n AppendOptimalWhiteSpace(tgt); // append optimized whitespace sequence...\r\n Column := tgt; // ...and memorize the column for the next iteration\r\n end;\r\n Result := sb.ToString; // convert result to a string\r\n finally\r\n sb.Free;\r\n end;\r\nend;\r\n\r\nprocedure TJclTabSet.RemoveAt(Index: SizeInt);\r\nbegin\r\n if Self <> nil then\r\n TTabSetData(FData).RemoveAt(Index)\r\n else\r\n raise NullReferenceException.Create;\r\nend;\r\n\r\nprocedure TJclTabSet.SetStops(Index, Value: SizeInt);\r\nbegin\r\n if Self <> nil then\r\n TTabSetData(FData).SetStops(Index, Value)\r\n else\r\n raise NullReferenceException.Create;\r\nend;\r\n\r\nprocedure TJclTabSet.SetTabWidth(Value: SizeInt);\r\nbegin\r\n if Self <> nil then\r\n begin\r\n TTabSetData(FData).FWidth := Value;\r\n TTabSetData(FData).CalcRealWidth;\r\n end\r\n else\r\n raise NullReferenceException.Create;\r\nend;\r\n\r\nprocedure TJclTabSet.SetZeroBased(Value: Boolean);\r\nvar\r\n shift: SizeInt;\r\n idx: SizeInt;\r\nbegin\r\n if Self <> nil then\r\n begin\r\n if Value <> TTabSetData(FData).FZeroBased then\r\n begin\r\n TTabSetData(FData).FZeroBased := Value;\r\n if Value then\r\n shift := -1\r\n else\r\n shift := 1;\r\n for idx := 0 to High(TTabSetData(FData).FStops) do\r\n TTabSetData(FData).FStops[idx] := TTabSetData(FData).FStops[idx] + shift;\r\n end;\r\n end\r\n else\r\n raise NullReferenceException.Create;\r\nend;\r\n\r\nfunction TJclTabSet.InternalTabStops: TDynSizeIntArray;\r\nbegin\r\n if Self <> nil then\r\n Result := TTabSetData(FData).FStops\r\n else\r\n Result := nil;\r\nend;\r\n\r\nfunction TJclTabSet.InternalTabWidth: SizeInt;\r\nbegin\r\n if Self <> nil then\r\n Result := TTabSetData(FData).FRealWidth\r\n else\r\n Result := 2;\r\nend;\r\n\r\nfunction TJclTabSet.NewReference: TJclTabSet;\r\nbegin\r\n if Self <> nil then\r\n Result := TJclTabSet.Create(FData)\r\n else\r\n Result := nil;\r\nend;\r\n\r\nfunction TJclTabSet.StartColumn: SizeInt;\r\nbegin\r\n if GetZeroBased then\r\n Result := 0\r\n else\r\n Result := 1;\r\nend;\r\n\r\nfunction TJclTabSet.TabFrom(Column: SizeInt): SizeInt;\r\nbegin\r\n if Column < StartColumn then\r\n raise ArgumentOutOfRangeException.Create('Column');\r\n Result := FindStop(Column);\r\n if Result < 0 then\r\n Result := not Result\r\n else\r\n Inc(Result);\r\n if Result >= GetCount then\r\n begin\r\n if GetCount > 0 then\r\n Result := TTabSetData(FData).FStops[High(TTabSetData(FData).FStops)]\r\n else\r\n Result := StartColumn;\r\n while Result <= Column do\r\n Inc(Result, ActualTabWidth);\r\n end\r\n else\r\n Result := TTabSetData(FData).FStops[Result];\r\nend;\r\n\r\nfunction TJclTabSet.ToString: string;\r\nbegin\r\n Result := ToString(TabSetFormatting_Full);\r\nend;\r\n\r\nfunction TJclTabSet.ToString(FormattingOptions: SizeInt): string;\r\nvar\r\n sb: TJclStringBuilder;\r\n idx: SizeInt;\r\n\r\n function WantBrackets: Boolean;\r\n begin\r\n Result := (TabSetFormatting_SurroundStopsWithBrackets and FormattingOptions) <> 0;\r\n end;\r\n\r\n function EmptyBrackets: Boolean;\r\n begin\r\n Result := (TabSetFormatting_EmptyBracketsIfNoStops and FormattingOptions) <> 0;\r\n end;\r\n\r\n function IncludeAutoWidth: Boolean;\r\n begin\r\n Result := (TabSetFormatting_AutoTabWidth and FormattingOptions) <> 0;\r\n end;\r\n\r\n function IncludeTabWidth: Boolean;\r\n begin\r\n Result := (TabSetFormatting_NoTabWidth and FormattingOptions) = 0;\r\n end;\r\n\r\n function IncludeStops: Boolean;\r\n begin\r\n Result := (TabSetFormatting_NoTabStops and FormattingOptions) = 0;\r\n end;\r\n\r\nbegin\r\n sb := TJclStringBuilder.Create;\r\n try\r\n // output the fixed tabulation positions if requested...\r\n if IncludeStops then\r\n begin\r\n // output each individual tabulation position\r\n for idx := 0 to GetCount - 1 do\r\n begin\r\n sb.Append(TabStops[idx]);\r\n sb.Append(',');\r\n end;\r\n // remove the final comma if any tabulation positions where outputted\r\n if sb.Length <> 0 then\r\n sb.Remove(sb.Length - 1, 1);\r\n // bracket the tabulation positions if requested\r\n if WantBrackets and (EmptyBrackets or (sb.Length > 0)) then\r\n begin\r\n sb.Insert(0, '[');\r\n sb.Append(']');\r\n end;\r\n end;\r\n // output the tab width if requested....\r\n if IncludeTabWidth and (IncludeAutoWidth or (TabWidth > 0)) then\r\n begin\r\n // separate the tab width from any outputted tabulation positions with a whitespace\r\n if sb.Length > 0 then\r\n sb.Append(' ');\r\n // flag tab width\r\n sb.Append('+');\r\n // finally, output the tab width\r\n sb.Append(ActualTabWidth);\r\n end;\r\n // flag zero-based tabset by outputting a 0 (zero) as the first character.\r\n if ZeroBased then\r\n sb.Insert(0, string('0 '));\r\n Result := StrTrimCharRight(sb.ToString, ' ');\r\n finally\r\n sb.Free;\r\n end;\r\nend;\r\n\r\nfunction TJclTabSet.UpdatePosition(const S: string): SizeInt;\r\nvar\r\n Line: SizeInt;\r\nbegin\r\n Result := StartColumn;\r\n Line := -1;\r\n UpdatePosition(S, Result, Line);\r\nend;\r\n\r\nfunction TJclTabSet.UpdatePosition(const S: string; Column: SizeInt): SizeInt;\r\nvar\r\n Line: SizeInt;\r\nbegin\r\n if Column < StartColumn then\r\n raise ArgumentOutOfRangeException.Create('Column');\r\n Result := Column;\r\n Line := -1;\r\n UpdatePosition(S, Result, Line);\r\nend;\r\n\r\nfunction TJclTabSet.UpdatePosition(const S: string; var Column, Line: SizeInt): SizeInt;\r\nvar\r\n prevChar: Char;\r\n cur: PChar;\r\nbegin\r\n if Column < StartColumn then\r\n raise ArgumentOutOfRangeException.Create('Column');\r\n // initialize loop\r\n cur := PChar(S);\r\n // iterate until end of string (the Null-character)\r\n while cur^ <> #0 do\r\n begin\r\n // check for line-breaking characters\r\n if CharIsReturn(cur^) then\r\n begin\r\n // Column moves back all the way to the left\r\n Column := StartColumn;\r\n // If this is the first line-break character or the same line-break character, increment the Line parameter\r\n Inc(Line);\r\n // check if it's the first of a two-character line-break\r\n prevChar := cur^;\r\n Inc(cur);\r\n // if it isn't a two-character line-break, undo the previous advancement\r\n if (cur^ = prevChar) or not CharIsReturn(cur^) then\r\n Dec(cur);\r\n end\r\n else // check for tab character and expand it\r\n if cur^ = #9 then\r\n Column := TabFrom(Column)\r\n else // a normal character; increment column\r\n Inc(Column);\r\n // advance pointer\r\n Inc(cur);\r\n end;\r\n // set the result to the newly calculated column\r\n Result := Column;\r\nend;\r\n\r\n//=== { NullReferenceException } =============================================\r\n\r\nconstructor NullReferenceException.Create;\r\nbegin\r\n CreateRes(@RsArg_NullReferenceException);\r\nend;\r\n\r\nfunction CompareNatural(const S1, S2: string; CaseInsensitive: Boolean): SizeInt;\r\nvar\r\n Cur1, Len1,\r\n Cur2, Len2: SizeInt;\r\n\r\n function IsRealNumberChar(ch: Char): Boolean;\r\n begin\r\n Result := ((ch >= '0') and (ch <= '9')) or (ch = '-') or (ch = '+');\r\n end;\r\n\r\n procedure NumberCompare;\r\n var\r\n IsReallyNumber: Boolean;\r\n FirstDiffBreaks: Boolean;\r\n Val1, Val2: SizeInt;\r\n begin\r\n Result := 0;\r\n IsReallyNumber := False;\r\n // count leading spaces in S1\r\n while (Cur1 <= Len1) and CharIsWhiteSpace(S1[Cur1]) do\r\n begin\r\n Dec(Result);\r\n Inc(Cur1);\r\n end;\r\n // count leading spaces in S2 (canceling them out against the ones in S1)\r\n while (Cur2 <= Len2) and CharIsWhiteSpace(S2[Cur2]) do\r\n begin\r\n Inc(Result);\r\n Inc(Cur2);\r\n end;\r\n\r\n // if spaces match, or both strings are actually followed by a numeric character, continue the checks\r\n if (Result = 0) or ((Cur1 <= Len1) and CharIsNumberChar(S1[Cur1]) and (Cur2 <= Len2) and CharIsNumberChar(S2[Cur2])) then\r\n begin\r\n // Check signed number\r\n if (Cur1 <= Len1) and (S1[Cur1] = '-') and ((Cur2 > Len2) or (S2[Cur2] <> '-')) then\r\n Result := 1\r\n else\r\n if (Cur2 <= Len2) and (S2[Cur2] = '-') and ((Cur1 > Len1) or (S1[Cur1] <> '-')) then\r\n Result := -1\r\n else\r\n Result := 0;\r\n\r\n if (Cur1 <= Len1) and ((S1[Cur1] = '-') or (S1[Cur1] = '+')) then\r\n Inc(Cur1);\r\n if (Cur2 <= Len2) and ((S2[Cur2] = '-') or (S2[Cur2] = '+')) then\r\n Inc(Cur2);\r\n\r\n FirstDiffBreaks := (Cur1 <= Len1) and (S1[Cur1] = '0') or (Cur2 <= Len2) and (S2[Cur2] = '0');\r\n while (Cur1 <= Len1) and CharIsDigit(S1[Cur1]) and (Cur2 <= Len2) and CharIsDigit(S2[Cur2]) do\r\n begin\r\n IsReallyNumber := True;\r\n Val1 := StrToInt(S1[Cur1]);\r\n Val2 := StrToInt(S2[Cur2]);\r\n\r\n if (Result = 0) and (Val1 < Val2) then\r\n Result := -1\r\n else\r\n if (Result = 0) and (Val1 > Val2) then\r\n Result := 1;\r\n if FirstDiffBreaks and (Result <> 0) then\r\n Break;\r\n Inc(Cur1);\r\n Inc(Cur2);\r\n end;\r\n\r\n if IsReallyNumber then\r\n begin\r\n if not FirstDiffBreaks then\r\n begin\r\n if (Cur1 <= Len1) and CharIsDigit(S1[Cur1]) then\r\n Result := 1\r\n else\r\n if (Cur2 <= Len2) and CharIsDigit(S2[Cur2]) then\r\n Result := -1;\r\n end;\r\n end;\r\n end;\r\n end;\r\n\r\n procedure SetByCompareLength;\r\n var\r\n Remain1: SizeInt;\r\n Remain2: SizeInt;\r\n begin\r\n // base result on relative compare length (spaces could be ignored, so even if S1 is longer than S2, they could be\r\n // completely equal, or S2 could be longer)\r\n Remain1 := Len1 - Cur1 + 1;\r\n Remain2 := Len2 - Cur2 + 1;\r\n if Remain1 < 0 then\r\n Remain1 := 0;\r\n if Remain2 < 0 then\r\n Remain2 := 0;\r\n\r\n if Remain1 < Remain2 then\r\n Result := -1\r\n else\r\n if Remain1 > Remain2 then\r\n Result := 1;\r\n end;\r\n\r\nbegin\r\n Cur1 := 1;\r\n Len1 := Length(S1);\r\n Cur2 := 1;\r\n Len2 := Length(S2);\r\n Result := 0;\r\n\r\n while (Result = 0) do\r\n begin\r\n if (Cur1 > Len1) or (Cur2 > Len2) then\r\n begin\r\n SetByCompareLength;\r\n Break;\r\n end\r\n else\r\n if (Cur1 <= Len1) and (Cur2 > Len2) then\r\n Result := 1\r\n else\r\n if (S1[Cur1] = '-') and IsRealNumberChar(S2[Cur2]) and (S2[Cur2] <> '-') then\r\n Result := -1\r\n else\r\n if (S2[Cur2] = '-') and IsRealNumberChar(S1[Cur1]) and (S1[Cur1] <> '-') then\r\n Result := 1\r\n else\r\n if (IsRealNumberChar(S1[Cur1]) or CharIsWhiteSpace(S1[Cur1])) and (IsRealNumberChar(S2[Cur2]) or CharIsWhiteSpace(S2[Cur2])) then\r\n NumberCompare\r\n else\r\n begin\r\n if CaseInsensitive then\r\n Result := StrLIComp(PChar(@S1[Cur1]), PChar(@S2[Cur2]), 1)\r\n else\r\n Result := StrLComp(PChar(@S1[Cur1]), PChar(@S2[Cur2]), 1);\r\n Inc(Cur1);\r\n Inc(Cur2);\r\n end;\r\n end;\r\nend;\r\n\r\nfunction CompareNaturalStr(const S1, S2: string): SizeInt; overload;\r\nbegin\r\n Result := CompareNatural(S1, S2, False);\r\nend;\r\n\r\nfunction CompareNaturalText(const S1, S2: string): SizeInt; overload;\r\nbegin\r\n Result := CompareNatural(S1, S2, True);\r\nend;\r\n\r\ninitialization\r\n {$IFNDEF UNICODE_RTL_DATABASE}\r\n LoadCharTypes; // this table first\r\n LoadCaseMap; // or this function does not work\r\n {$ENDIF ~UNICODE_RTL_DATABASE}\r\n {$IFDEF UNITVERSIONING}\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n {$ENDIF UNITVERSIONING}\r\n\r\n{$IFDEF UNITVERSIONING}\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n\r\n" }, { "path": "External/Jedi/Jcl/source/common/JclSynch.pas", "content": "{**************************************************************************************************}\r\n{ }\r\n{ Project JEDI Code Library (JCL) }\r\n{ }\r\n{ The contents of this file are subject to the Mozilla Public License Version 1.1 (the \"License\"); }\r\n{ you may not use this file except in compliance with the License. You may obtain a copy of the }\r\n{ License at http://www.mozilla.org/MPL/ }\r\n{ }\r\n{ Software distributed under the License is distributed on an \"AS IS\" basis, WITHOUT WARRANTY OF }\r\n{ ANY KIND, either express or implied. See the License for the specific language governing rights }\r\n{ and limitations under the License. }\r\n{ }\r\n{ The Original Code is JclSynch.pas. }\r\n{ }\r\n{ The Initial Developers of the Original Code are Marcel van Brakel and Azret Botash. }\r\n{ Portions created by these individuals are Copyright (C) of these individuals. }\r\n{ All Rights Reserved. }\r\n{ }\r\n{ Contributor(s): }\r\n{ Marcel van Brakel }\r\n{ Olivier Sannier (obones) }\r\n{ Matthias Thoma (mthoma) }\r\n{ }\r\n{**************************************************************************************************}\r\n{ }\r\n{ This unit contains various classes and support routines for implementing synchronisation in }\r\n{ multithreaded applications. This ranges from interlocked access to simple typed variables to }\r\n{ wrapper classes for synchronisation primitives provided by the operating system }\r\n{ (critical section, semaphore, mutex etc). It also includes three user defined classes to }\r\n{ complement these. }\r\n{ }\r\n{**************************************************************************************************}\r\n{ }\r\n{ Last modified: $Date:: 2012-03-04 19:39:47 +0100 (dim. 04 mars 2012) $ }\r\n{ Revision: $Rev:: 3759 $ }\r\n{ Author: $Author:: outchy $ }\r\n{ }\r\n{**************************************************************************************************}\r\n\r\nunit JclSynch;\r\n\r\n{$I jcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n {$IFDEF HAS_UNITSCOPE}\r\n {$IFDEF MSWINDOWS}\r\n Winapi.Windows, JclWin32,\r\n {$ENDIF MSWINDOWS}\r\n {$ELSE ~HAS_UNITSCOPE}\r\n {$IFDEF MSWINDOWS}\r\n Windows, JclWin32,\r\n {$ENDIF MSWINDOWS}\r\n {$ENDIF ~HAS_UNITSCOPE}\r\n JclBase;\r\n\r\n// Locked Integer manipulation\r\n//\r\n// Routines to manipulate simple typed variables in a thread safe manner\r\nfunction LockedAdd(var Target: Integer; Value: Integer): Integer; overload;\r\nfunction LockedCompareExchange(var Target: Integer; Exch, Comp: Integer): Integer; overload;\r\nfunction LockedCompareExchange(var Target: TObject; Exch, Comp: TObject): TObject; overload;\r\nfunction LockedCompareExchange(var Target: Pointer; Exch, Comp: Pointer): Pointer; overload;\r\nfunction LockedDec(var Target: Integer): Integer; overload;\r\nfunction LockedExchange(var Target: Integer; Value: Integer): Integer; overload;\r\nfunction LockedExchangeAdd(var Target: Integer; Value: Integer): Integer; overload;\r\nfunction LockedExchangeDec(var Target: Integer): Integer; overload;\r\nfunction LockedExchangeInc(var Target: Integer): Integer; overload;\r\nfunction LockedExchangeSub(var Target: Integer; Value: Integer): Integer; overload;\r\nfunction LockedInc(var Target: Integer): Integer; overload;\r\nfunction LockedSub(var Target: Integer; Value: Integer): Integer; overload;\r\n\r\n{$IFDEF CPU64}\r\nfunction LockedAdd(var Target: Int64; Value: Int64): Int64; overload;\r\nfunction LockedCompareExchange(var Target: Int64; Exch, Comp: Int64): Int64; overload;\r\nfunction LockedDec(var Target: Int64): Int64; overload;\r\nfunction LockedExchange(var Target: Int64; Value: Int64): Int64; overload;\r\nfunction LockedExchangeAdd(var Target: Int64; Value: Int64): Int64; overload;\r\nfunction LockedExchangeDec(var Target: Int64): Int64; overload;\r\nfunction LockedExchangeInc(var Target: Int64): Int64; overload;\r\nfunction LockedExchangeSub(var Target: Int64; Value: Int64): Int64; overload;\r\nfunction LockedInc(var Target: Int64): Int64; overload;\r\nfunction LockedSub(var Target: Int64; Value: Int64): Int64; overload;\r\n\r\n{$IFDEF BORLAND}\r\nfunction LockedDec(var Target: NativeInt): NativeInt; overload;\r\nfunction LockedInc(var Target: NativeInt): NativeInt; overload;\r\n{$ENDIF BORLAND}\r\n{$ENDIF CPU64}\r\n\r\n// TJclDispatcherObject\r\n//\r\n// Base class for operating system provided synchronisation primitives\r\ntype\r\n TJclWaitResult = (wrAbandoned, wrError, wrIoCompletion, wrSignaled, wrTimeout);\r\n\r\n TJclWaitHandle = THandle;\r\n\r\n TJclDispatcherObject = class(TObject)\r\n private\r\n FExisted: Boolean;\r\n FHandle: TJclWaitHandle;\r\n FName: string;\r\n public\r\n constructor Attach(AHandle: TJclWaitHandle);\r\n destructor Destroy; override;\r\n //function MsgWaitFor(const TimeOut: Cardinal): TJclWaitResult; Mask: DWORD): TJclWaitResult;\r\n //function MsgWaitForEx(const TimeOut: Cardinal): TJclWaitResult; Mask: DWORD): TJclWaitResult;\r\n function SignalAndWait(const Obj: TJclDispatcherObject; TimeOut: Cardinal;\r\n Alertable: Boolean): TJclWaitResult;\r\n function WaitAlertable(const TimeOut: Cardinal): TJclWaitResult;\r\n function WaitFor(const TimeOut: Cardinal): TJclWaitResult;\r\n function WaitForever: TJclWaitResult;\r\n property Existed: Boolean read FExisted;\r\n property Handle: TJclWaitHandle read FHandle;\r\n property Name: string read FName;\r\n end;\r\n\r\n// Wait functions\r\n//\r\n// Object enabled Wait functions (takes TJclDispatcher objects as parameter as\r\n// opposed to handles) mostly for convenience\r\nfunction WaitForMultipleObjects(const Objects: array of TJclDispatcherObject;\r\n WaitAll: Boolean; TimeOut: Cardinal): Cardinal;\r\nfunction WaitAlertableForMultipleObjects(const Objects: array of TJclDispatcherObject;\r\n WaitAll: Boolean; TimeOut: Cardinal): Cardinal;\r\n\r\ntype\r\n TJclCriticalSection = class(TObject)\r\n private\r\n FCriticalSection: TRTLCriticalSection;\r\n public\r\n constructor Create; virtual;\r\n destructor Destroy; override;\r\n class procedure CreateAndEnter(var CS: TJclCriticalSection);\r\n procedure Enter;\r\n procedure Leave;\r\n end;\r\n\r\n TJclCriticalSectionEx = class(TJclCriticalSection)\r\n private\r\n FSpinCount: Cardinal;\r\n function GetSpinCount: Cardinal;\r\n procedure SetSpinCount(const Value: Cardinal);\r\n public\r\n constructor Create; override;\r\n constructor CreateEx(SpinCount: Cardinal; NoFailEnter: Boolean); virtual;\r\n class function GetSpinTimeOut: Cardinal;\r\n class procedure SetSpinTimeOut(const Value: Cardinal);\r\n function TryEnter: Boolean;\r\n property SpinCount: Cardinal read GetSpinCount write SetSpinCount;\r\n end;\r\n\r\n TJclEvent = class(TJclDispatcherObject)\r\n public\r\n constructor Create(SecAttr: PSecurityAttributes; Manual, Signaled: Boolean; const Name: string);\r\n constructor Open(Access: Cardinal; Inheritable: Boolean; const Name: string);\r\n function Pulse: Boolean;\r\n function ResetEvent: Boolean;\r\n function SetEvent: Boolean;\r\n end;\r\n\r\n TJclWaitableTimer = class(TJclDispatcherObject)\r\n private\r\n FResume: Boolean;\r\n public\r\n constructor Create(SecAttr: PSecurityAttributes; Manual: Boolean; const Name: string);\r\n constructor Open(Access: Cardinal; Inheritable: Boolean; const Name: string);\r\n function Cancel: Boolean;\r\n function SetTimer(const DueTime: Int64; Period: Longint; Resume: Boolean): Boolean;\r\n function SetTimerApc(const DueTime: Int64; Period: Longint; Resume: Boolean; Apc: TFNTimerAPCRoutine; Arg: Pointer): Boolean;\r\n end;\r\n\r\n TJclSemaphore = class(TJclDispatcherObject)\r\n public\r\n constructor Create(SecAttr: PSecurityAttributes; Initial, Maximum: Longint; const Name: string);\r\n constructor Open(Access: Cardinal; Inheritable: Boolean; const Name: string);\r\n function Release(ReleaseCount: Longint): Boolean;\r\n function ReleasePrev(ReleaseCount: Longint; var PrevCount: Longint): Boolean;\r\n end;\r\n\r\n TJclMutex = class(TJclDispatcherObject)\r\n public\r\n constructor Create(SecAttr: PSecurityAttributes; InitialOwner: Boolean;\r\n const Name: string);\r\n constructor Open(Access: Cardinal; Inheritable: Boolean; const Name: string);\r\n function Acquire(const TimeOut: Cardinal = INFINITE): Boolean;\r\n function Release: Boolean;\r\n end;\r\n\r\n POptexSharedInfo = ^TOptexSharedInfo;\r\n TOptexSharedInfo = record\r\n SpinCount: Integer; // number of times to try and enter the optex before\r\n // waiting on kernel event, 0 on single processor\r\n LockCount: Integer; // count of enter attempts\r\n ThreadId: Longword; // id of thread that owns the optex, 0 if free\r\n RecursionCount: Integer; // number of times the optex is owned, 0 if free\r\n end;\r\n\r\n TJclOptex = class(TObject)\r\n private\r\n FEvent: TJclEvent;\r\n FExisted: Boolean;\r\n FFileMapping: THandle;\r\n FName: string;\r\n FSharedInfo: POptexSharedInfo;\r\n function GetUniProcess: Boolean;\r\n function GetSpinCount: Integer;\r\n procedure SetSpinCount(Value: Integer);\r\n public\r\n constructor Create(const Name: string = ''; SpinCount: Integer = 4000);\r\n destructor Destroy; override;\r\n procedure Enter;\r\n procedure Leave;\r\n function TryEnter: Boolean;\r\n property Existed: Boolean read FExisted;\r\n property Name: string read FName;\r\n property SpinCount: Integer read GetSpinCount write SetSpinCount;\r\n property UniProcess: Boolean read GetUniProcess;\r\n end;\r\n\r\n TMrewPreferred = (mpReaders, mpWriters, mpEqual);\r\n\r\n TMrewThreadInfo = record\r\n ThreadId: Longword; // client-id of thread\r\n RecursionCount: Integer; // number of times a thread accessed the mrew\r\n Reader: Boolean; // true if reader, false if writer\r\n end;\r\n TMrewThreadInfoArray = array of TMrewThreadInfo;\r\n\r\n TJclMultiReadExclusiveWrite = class(TObject)\r\n private\r\n FLock: TJclCriticalSection;\r\n FPreferred: TMrewPreferred;\r\n FSemReaders: TJclSemaphore;\r\n FSemWriters: TJclSemaphore;\r\n FState: Integer;\r\n FThreads: TMrewThreadInfoArray;\r\n FWaitingReaders: Integer;\r\n FWaitingWriters: Integer;\r\n procedure AddToThreadList(ThreadId: Longword; Reader: Boolean);\r\n procedure RemoveFromThreadList(Index: Integer);\r\n function FindThread(ThreadId: Longword): Integer;\r\n procedure ReleaseWaiters(WasReading: Boolean);\r\n protected\r\n procedure Release;\r\n public\r\n constructor Create(Preferred: TMrewPreferred);\r\n\r\n destructor Destroy; override;\r\n procedure BeginRead;\r\n procedure BeginWrite;\r\n procedure EndRead;\r\n procedure EndWrite;\r\n end;\r\n\r\n PMetSectSharedInfo = ^TMetSectSharedInfo;\r\n TMetSectSharedInfo = record\r\n Initialized: LongBool; // Is the metered section initialized?\r\n SpinLock: Longint; // Used to gain access to this structure\r\n ThreadsWaiting: Longint; // Count of threads waiting\r\n AvailableCount: Longint; // Available resource count\r\n MaximumCount: Longint; // Maximum resource count\r\n end;\r\n\r\n PMeteredSection = ^TMeteredSection;\r\n TMeteredSection = record\r\n Event: THandle; // Handle to a kernel event object\r\n FileMap: THandle; // Handle to memory mapped file\r\n SharedInfo: PMetSectSharedInfo;\r\n end;\r\n\r\n TJclMeteredSection = class(TObject)\r\n private\r\n FMetSect: PMeteredSection;\r\n procedure CloseMeteredSection;\r\n function InitMeteredSection(InitialCount, MaxCount: Longint; const Name: string; OpenOnly: Boolean): Boolean;\r\n function CreateMetSectEvent(const Name: string; OpenOnly: Boolean): Boolean;\r\n function CreateMetSectFileView(InitialCount, MaxCount: Longint; const Name: string; OpenOnly: Boolean): Boolean;\r\n protected\r\n procedure AcquireLock;\r\n procedure ReleaseLock;\r\n public\r\n constructor Create(InitialCount, MaxCount: Longint; const Name: string);\r\n constructor Open(const Name: string);\r\n destructor Destroy; override;\r\n function Enter(TimeOut: Longword): TJclWaitResult;\r\n function Leave(ReleaseCount: Longint): Boolean; overload;\r\n function Leave(ReleaseCount: Longint; out PrevCount: Longint): Boolean; overload;\r\n end;\r\n\r\n// Debugging\r\n//\r\n// Note that the following function and structure declarations are all offically\r\n// undocumented and, except for QueryCriticalSection, require Windows NT since\r\n// it is all part of the Windows NT Native API.\r\n{ TODO -cTest : Test this structures }\r\ntype\r\n TEventInfo = record\r\n EventType: Longint; // 0 = manual, otherwise auto\r\n Signaled: LongBool; // true is signaled\r\n end;\r\n\r\n TMutexInfo = record\r\n SignalState: Longint; // >0 = signaled, <0 = |SignalState| recurs. acquired\r\n Owned: ByteBool; // owned by thread\r\n Abandoned: ByteBool; // is abandoned?\r\n end;\r\n\r\n TSemaphoreCounts = record\r\n CurrentCount: Longint; // current semaphore count\r\n MaximumCount: Longint; // maximum semaphore count\r\n end;\r\n\r\n TTimerInfo = record\r\n Remaining: TLargeInteger; // 100ns intervals until signaled\r\n Signaled: ByteBool; // is signaled?\r\n end;\r\n\r\nfunction QueryCriticalSection(CS: TJclCriticalSection; var Info: TRTLCriticalSection): Boolean;\r\n{ TODO -cTest : Test these 4 functions }\r\nfunction QueryEvent(Handle: THandle; var Info: TEventInfo): Boolean;\r\nfunction QueryMutex(Handle: THandle; var Info: TMutexInfo): Boolean;\r\nfunction QuerySemaphore(Handle: THandle; var Info: TSemaphoreCounts): Boolean;\r\nfunction QueryTimer(Handle: THandle; var Info: TTimerInfo): Boolean;\r\n\r\ntype\r\n // Exceptions\r\n EJclWin32HandleObjectError = class(EJclWin32Error);\r\n EJclDispatcherObjectError = class(EJclWin32Error);\r\n EJclCriticalSectionError = class(EJclWin32Error);\r\n EJclEventError = class(EJclWin32Error);\r\n EJclWaitableTimerError = class(EJclWin32Error);\r\n EJclSemaphoreError = class(EJclWin32Error);\r\n EJclMutexError = class(EJclWin32Error);\r\n EJclMeteredSectionError = class(EJclError);\r\n\r\nfunction ValidateMutexName(const aName: string): string;\r\n\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jcl.svn.sourceforge.net/svnroot/jcl/tags/JCL-2.4-Build4571/jcl/source/common/JclSynch.pas $';\r\n Revision: '$Revision: 3759 $';\r\n Date: '$Date: 2012-03-04 19:39:47 +0100 (dim. 04 mars 2012) $';\r\n LogPath: 'JCL\\source\\common';\r\n Extra: '';\r\n Data: nil\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n {$IFDEF HAS_UNITSCOPE}\r\n System.SysUtils,\r\n {$ELSE ~HAS_UNITSCOPE}\r\n SysUtils,\r\n {$ENDIF ~HAS_UNITSCOPE}\r\n JclLogic, JclRegistry, JclResources,\r\n JclSysInfo, JclStrings;\r\n\r\nconst\r\n RegSessionManager = {HKLM\\} 'SYSTEM\\CurrentControlSet\\Control\\Session Manager';\r\n RegCritSecTimeout = {RegSessionManager\\} 'CriticalSectionTimeout';\r\n\r\n// Locked Integer manipulation\r\nfunction LockedAdd(var Target: Integer; Value: Integer): Integer;\r\nasm\r\n {$IFDEF CPU32}\r\n // --> EAX Target\r\n // EDX Value\r\n // <-- EAX Result\r\n MOV ECX, EAX\r\n MOV EAX, EDX\r\n LOCK XADD [ECX], EAX\r\n ADD EAX, EDX\r\n {$ENDIF CPU32}\r\n {$IFDEF CPU64}\r\n // --> RCX Target\r\n // EDX Value\r\n // <-- EAX Result\r\n MOV EAX, EDX\r\n LOCK XADD [RCX], EAX\r\n ADD EAX, EDX\r\n {$ENDIF CPU64}\r\nend;\r\n\r\nfunction LockedCompareExchange(var Target: Integer; Exch, Comp: Integer): Integer;\r\nasm\r\n {$IFDEF CPU32}\r\n // --> EAX Target\r\n // EDX Exch\r\n // ECX Comp\r\n // <-- EAX Result\r\n XCHG EAX, ECX\r\n // EAX Comp\r\n // EDX Exch\r\n // ECX Target\r\n LOCK CMPXCHG [ECX], EDX\r\n {$ENDIF CPU32}\r\n {$IFDEF CPU64}\r\n // --> RCX Target\r\n // EDX Exch\r\n // R8 Comp\r\n // <-- EAX Result\r\n MOV RAX, R8\r\n // RCX Target\r\n // EDX Exch\r\n // RAX Comp\r\n LOCK CMPXCHG [RCX], EDX\r\n {$ENDIF CPU64}\r\nend;\r\n\r\nfunction LockedCompareExchange(var Target: Pointer; Exch, Comp: Pointer): Pointer;\r\nasm\r\n {$IFDEF CPU32}\r\n // --> EAX Target\r\n // EDX Exch\r\n // ECX Comp\r\n // <-- EAX Result\r\n XCHG EAX, ECX\r\n // EAX Comp\r\n // EDX Exch\r\n // ECX Target\r\n LOCK CMPXCHG [ECX], EDX\r\n {$ENDIF CPU32}\r\n {$IFDEF CPU64}\r\n // --> RCX Target\r\n // RDX Exch\r\n // R8 Comp\r\n // <-- RAX Result\r\n MOV RAX, R8\r\n // RCX Target\r\n // RDX Exch\r\n // RAX Comp\r\n LOCK CMPXCHG [RCX], RDX\r\n {$ENDIF CPU64}\r\nend;\r\n\r\nfunction LockedCompareExchange(var Target: TObject; Exch, Comp: TObject): TObject;\r\nasm\r\n {$IFDEF CPU32}\r\n // --> EAX Target\r\n // EDX Exch\r\n // ECX Comp\r\n // <-- EAX Result\r\n XCHG EAX, ECX\r\n // EAX Comp\r\n // EDX Exch\r\n // ECX Target\r\n LOCK CMPXCHG [ECX], EDX\r\n {$ENDIF CPU32}\r\n {$IFDEF CPU64}\r\n // --> RCX Target\r\n // RDX Exch\r\n // R8 Comp\r\n // <-- RAX Result\r\n MOV RAX, R8\r\n // --> RCX Target\r\n // RDX Exch\r\n // RAX Comp\r\n LOCK CMPXCHG [RCX], RDX\r\n {$ENDIF CPU64}\r\nend;\r\n\r\nfunction LockedDec(var Target: Integer): Integer;\r\nasm\r\n {$IFDEF CPU32}\r\n // --> EAX Target\r\n // <-- EAX Result\r\n MOV ECX, EAX\r\n MOV EAX, -1\r\n LOCK XADD [ECX], EAX\r\n DEC EAX\r\n {$ENDIF CPU32}\r\n {$IFDEF CPU64}\r\n // --> RCX Target\r\n // <-- EAX Result\r\n MOV EAX, -1\r\n LOCK XADD [RCX], EAX\r\n DEC EAX\r\n {$ENDIF CPU64}\r\nend;\r\n\r\nfunction LockedExchange(var Target: Integer; Value: Integer): Integer;\r\nasm\r\n {$IFDEF CPU32}\r\n // --> EAX Target\r\n // EDX Value\r\n // <-- EAX Result\r\n MOV ECX, EAX\r\n MOV EAX, EDX\r\n // ECX Target\r\n // EAX Value\r\n LOCK XCHG [ECX], EAX\r\n {$ENDIF CPU32}\r\n {$IFDEF CPU64}\r\n // --> RCX Target\r\n // EDX Value\r\n // <-- EAX Result\r\n MOV EAX, EDX\r\n // RCX Target\r\n // EAX Value\r\n LOCK XCHG [RCX], EAX\r\n {$ENDIF CPU64}\r\nend;\r\n\r\nfunction LockedExchangeAdd(var Target: Integer; Value: Integer): Integer;\r\nasm\r\n {$IFDEF CPU32}\r\n // --> EAX Target\r\n // EDX Value\r\n // <-- EAX Result\r\n MOV ECX, EAX\r\n MOV EAX, EDX\r\n // ECX Target\r\n // EAX Value\r\n LOCK XADD [ECX], EAX\r\n {$ENDIF CPU32}\r\n {$IFDEF CPU64}\r\n // --> RCX Target\r\n // EDX Value\r\n // <-- EAX Result\r\n MOV EAX, EDX\r\n // RCX Target\r\n // EAX Value\r\n LOCK XADD [RCX], EAX\r\n {$ENDIF CPU64}\r\nend;\r\n\r\nfunction LockedExchangeDec(var Target: Integer): Integer;\r\nasm\r\n {$IFDEF CPU32}\r\n // --> EAX Target\r\n // <-- EAX Result\r\n MOV ECX, EAX\r\n MOV EAX, -1\r\n LOCK XADD [ECX], EAX\r\n {$ENDIF CPU32}\r\n {$IFDEF CPU64}\r\n // --> RCX Target\r\n // <-- EAX Result\r\n MOV EAX, -1\r\n LOCK XADD [RCX], EAX\r\n {$ENDIF CPU64}\r\nend;\r\n\r\nfunction LockedExchangeInc(var Target: Integer): Integer;\r\nasm\r\n {$IFDEF CPU32}\r\n // --> EAX Target\r\n // <-- EAX Result\r\n MOV ECX, EAX\r\n MOV EAX, 1\r\n LOCK XADD [ECX], EAX\r\n {$ENDIF CPU32}\r\n {$IFDEF CPU64}\r\n // --> RCX Target\r\n // <-- EAX Result\r\n MOV EAX, 1\r\n LOCK XADD [RCX], EAX\r\n {$ENDIF CPU64}\r\nend;\r\n\r\nfunction LockedExchangeSub(var Target: Integer; Value: Integer): Integer;\r\nasm\r\n {$IFDEF CPU32}\r\n // --> EAX Target\r\n // EDX Value\r\n // <-- EAX Result\r\n MOV ECX, EAX\r\n NEG EDX\r\n MOV EAX, EDX\r\n // ECX Target\r\n // EAX -Value\r\n LOCK XADD [ECX], EAX\r\n {$ENDIF CPU32}\r\n {$IFDEF CPU64}\r\n // --> RCX Target\r\n // EDX Value\r\n // <-- EAX Result\r\n NEG EDX\r\n MOV EAX, EDX\r\n // RCX Target\r\n // EAX -Value\r\n LOCK XADD [RCX], EAX\r\n {$ENDIF CPU64}\r\nend;\r\n\r\nfunction LockedInc(var Target: Integer): Integer;\r\nasm\r\n {$IFDEF CPU32}\r\n // --> EAX Target\r\n // <-- EAX Result\r\n MOV ECX, EAX\r\n MOV EAX, 1\r\n LOCK XADD [ECX], EAX\r\n INC EAX\r\n {$ENDIF CPU32}\r\n {$IFDEF CPU64}\r\n // --> RCX Target\r\n // <-- EAX Result\r\n MOV EAX, 1\r\n LOCK XADD [RCX], EAX\r\n INC EAX\r\n {$ENDIF CPU64}\r\nend;\r\n\r\nfunction LockedSub(var Target: Integer; Value: Integer): Integer;\r\nasm\r\n {$IFDEF CPU32}\r\n // --> EAX Target\r\n // EDX Value\r\n // <-- EAX Result\r\n MOV ECX, EAX\r\n NEG EDX\r\n MOV EAX, EDX\r\n LOCK XADD [ECX], EAX\r\n ADD EAX, EDX\r\n {$ENDIF CPU32}\r\n {$IFDEF CPU64}\r\n // --> RCX Target\r\n // EDX Value\r\n // <-- EAX Result\r\n NEG EDX\r\n MOV EAX, EDX\r\n LOCK XADD [RCX], EAX\r\n ADD EAX, EDX\r\n {$ENDIF CPU64}\r\nend;\r\n\r\n{$IFDEF CPU64}\r\n\r\n// Locked Int64 manipulation\r\nfunction LockedAdd(var Target: Int64; Value: Int64): Int64;\r\nasm\r\n // --> RCX Target\r\n // RDX Value\r\n // <-- RAX Result\r\n MOV RAX, RDX\r\n LOCK XADD [RCX], RAX\r\n ADD RAX, RDX\r\nend;\r\n\r\nfunction LockedCompareExchange(var Target: Int64; Exch, Comp: Int64): Int64;\r\nasm\r\n // --> RCX Target\r\n // RDX Exch\r\n // R8 Comp\r\n // <-- RAX Result\r\n MOV RAX, R8\r\n LOCK CMPXCHG [RCX], RDX\r\nend;\r\n\r\nfunction LockedDec(var Target: Int64): Int64;\r\nasm\r\n // --> RCX Target\r\n // <-- RAX Result\r\n MOV RAX, -1\r\n LOCK XADD [RCX], RAX\r\n DEC RAX\r\nend;\r\n\r\nfunction LockedExchange(var Target: Int64; Value: Int64): Int64;\r\nasm\r\n // --> RCX Target\r\n // RDX Value\r\n // <-- RAX Result\r\n MOV RAX, RDX\r\n LOCK XCHG [RCX], RAX\r\nend;\r\n\r\nfunction LockedExchangeAdd(var Target: Int64; Value: Int64): Int64;\r\nasm\r\n // --> RCX Target\r\n // RDX Value\r\n // <-- RAX Result\r\n MOV RAX, RDX\r\n LOCK XADD [RCX], RAX\r\nend;\r\n\r\nfunction LockedExchangeDec(var Target: Int64): Int64;\r\nasm\r\n // --> RCX Target\r\n // <-- RAX Result\r\n MOV RAX, -1\r\n LOCK XADD [RCX], RAX\r\nend;\r\n\r\nfunction LockedExchangeInc(var Target: Int64): Int64;\r\nasm\r\n // --> RCX Target\r\n // <-- RAX Result\r\n MOV RAX, 1\r\n LOCK XADD [RCX], RAX\r\nend;\r\n\r\nfunction LockedExchangeSub(var Target: Int64; Value: Int64): Int64;\r\nasm\r\n // --> RCX Target\r\n // RDX Value\r\n // <-- RAX Result\r\n NEG RDX\r\n MOV RAX, RDX\r\n LOCK XADD [RCX], RAX\r\nend;\r\n\r\nfunction LockedInc(var Target: Int64): Int64;\r\nasm\r\n // --> RCX Target\r\n // <-- RAX Result\r\n MOV RAX, 1\r\n LOCK XADD [RCX], RAX\r\n INC RAX\r\nend;\r\n\r\nfunction LockedSub(var Target: Int64; Value: Int64): Int64;\r\nasm\r\n // --> RCX Target\r\n // RDX Value\r\n // <-- RAX Result\r\n NEG RDX\r\n MOV RAX, RDX\r\n LOCK XADD [RCX], RAX\r\n ADD RAX, RDX\r\nend;\r\n\r\n{$IFDEF BORLAND}\r\n\r\nfunction LockedDec(var Target: NativeInt): NativeInt;\r\nasm\r\n // --> RCX Target\r\n // <-- RAX Result\r\n MOV RAX, -1\r\n LOCK XADD [RCX], RAX\r\n DEC RAX\r\nend;\r\n\r\nfunction LockedInc(var Target: NativeInt): NativeInt;\r\nasm\r\n // --> RCX Target\r\n // <-- RAX Result\r\n MOV RAX, 1\r\n LOCK XADD [RCX], RAX\r\n INC RAX\r\nend;\r\n\r\n{$ENDIF BORLAND}\r\n\r\n{$ENDIF CPU64}\r\n\r\n//=== { TJclDispatcherObject } ===============================================\r\n\r\nfunction MapSignalResult(const Ret: DWORD): TJclWaitResult;\r\nbegin\r\n case Ret of\r\n WAIT_ABANDONED:\r\n Result := wrAbandoned;\r\n WAIT_OBJECT_0:\r\n Result := wrSignaled;\r\n WAIT_TIMEOUT:\r\n Result := wrTimeout;\r\n WAIT_IO_COMPLETION:\r\n Result := wrIoCompletion;\r\n WAIT_FAILED:\r\n Result := wrError;\r\n else\r\n Result := wrError;\r\n end;\r\nend;\r\n\r\nconstructor TJclDispatcherObject.Attach(AHandle: TJclWaitHandle);\r\nbegin\r\n inherited Create;\r\n FExisted := True;\r\n FHandle := AHandle;\r\n FName := '';\r\nend;\r\n\r\ndestructor TJclDispatcherObject.Destroy;\r\nbegin\r\n CloseHandle(FHandle);\r\n inherited Destroy;\r\nend;\r\n\r\n{ TODO: Use RTDL Version of SignalObjectAndWait }\r\n\r\nfunction TJclDispatcherObject.SignalAndWait(const Obj: TJclDispatcherObject;\r\n TimeOut: Cardinal; Alertable: Boolean): TJclWaitResult;\r\nbegin\r\n // Note: Do not make this method virtual! It's only available on NT 4 up...\r\n Result := MapSignalResult(Cardinal({$IFDEF HAS_UNITSCOPE}Winapi.{$ENDIF}Windows.SignalObjectAndWait(Obj.Handle, Handle, TimeOut, Alertable)));\r\nend;\r\n\r\nfunction TJclDispatcherObject.WaitAlertable(const TimeOut: Cardinal): TJclWaitResult;\r\nbegin\r\n Result := MapSignalResult({$IFDEF HAS_UNITSCOPE}Winapi.{$ENDIF}Windows.WaitForSingleObjectEx(FHandle, TimeOut, True));\r\nend;\r\n\r\nfunction TJclDispatcherObject.WaitFor(const TimeOut: Cardinal): TJclWaitResult;\r\nbegin\r\n Result := MapSignalResult({$IFDEF HAS_UNITSCOPE}Winapi.{$ENDIF}Windows.WaitForSingleObject(FHandle, TimeOut));\r\nend;\r\n\r\nfunction TJclDispatcherObject.WaitForever: TJclWaitResult;\r\nbegin\r\n Result := WaitFor(INFINITE);\r\nend;\r\n\r\n// Wait functions\r\nfunction WaitForMultipleObjects(const Objects: array of TJclDispatcherObject;\r\n WaitAll: Boolean; TimeOut: Cardinal): Cardinal;\r\nvar\r\n Handles: array of TJclWaitHandle;\r\n I, Count: Integer;\r\nbegin\r\n Count := High(Objects) + 1;\r\n SetLength(Handles, Count);\r\n for I := 0 to Count - 1 do\r\n Handles[I] := Objects[I].Handle;\r\n Result := {$IFDEF HAS_UNITSCOPE}Winapi.{$ENDIF}Windows.WaitForMultipleObjects(Count, @Handles[0], WaitAll, TimeOut);\r\nend;\r\n\r\nfunction WaitAlertableForMultipleObjects(const Objects: array of TJclDispatcherObject;\r\n WaitAll: Boolean; TimeOut: Cardinal): Cardinal;\r\nvar\r\n Handles: array of TJclWaitHandle;\r\n I, Count: Integer;\r\nbegin\r\n Count := High(Objects) + 1;\r\n SetLength(Handles, Count);\r\n for I := 0 to Count - 1 do\r\n Handles[I] := Objects[I].Handle;\r\n Result := {$IFDEF HAS_UNITSCOPE}Winapi.{$ENDIF}Windows.WaitForMultipleObjectsEx(Count, @Handles[0], WaitAll, TimeOut, True);\r\nend;\r\n\r\n//=== { TJclCriticalSection } ================================================\r\n\r\nconstructor TJclCriticalSection.Create;\r\nbegin\r\n inherited Create;\r\n {$IFDEF HAS_UNITSCOPE}Winapi.{$ENDIF}Windows.InitializeCriticalSection(FCriticalSection);\r\nend;\r\n\r\ndestructor TJclCriticalSection.Destroy;\r\nbegin\r\n {$IFDEF HAS_UNITSCOPE}Winapi.{$ENDIF}Windows.DeleteCriticalSection(FCriticalSection);\r\n inherited Destroy;\r\nend;\r\n\r\nclass procedure TJclCriticalSection.CreateAndEnter(var CS: TJclCriticalSection);\r\nvar\r\n NewCritSect: TJclCriticalSection;\r\nbegin\r\n NewCritSect := TJclCriticalSection.Create;\r\n if LockedCompareExchange(Pointer(CS), Pointer(NewCritSect), nil) <> nil then\r\n begin\r\n // LoadInProgress was <> nil -> no exchange took place, free the CS\r\n NewCritSect.Free;\r\n end;\r\n CS.Enter;\r\nend;\r\n\r\nprocedure TJclCriticalSection.Enter;\r\nbegin\r\n {$IFDEF HAS_UNITSCOPE}Winapi.{$ENDIF}Windows.EnterCriticalSection(FCriticalSection);\r\nend;\r\n\r\nprocedure TJclCriticalSection.Leave;\r\nbegin\r\n {$IFDEF HAS_UNITSCOPE}Winapi.{$ENDIF}Windows.LeaveCriticalSection(FCriticalSection);\r\nend;\r\n\r\n//== { TJclCriticalSectionEx } ===============================================\r\n\r\nconst\r\n DefaultCritSectSpinCount = 4000;\r\n\r\nconstructor TJclCriticalSectionEx.Create;\r\nbegin\r\n CreateEx(DefaultCritSectSpinCount, False);\r\nend;\r\n\r\n{ TODO: Use RTDL Version of InitializeCriticalSectionAndSpinCount }\r\n\r\nconstructor TJclCriticalSectionEx.CreateEx(SpinCount: Cardinal;\r\n NoFailEnter: Boolean);\r\nbegin\r\n FSpinCount := SpinCount;\r\n if NoFailEnter then\r\n SpinCount := SpinCount or Cardinal($80000000);\r\n\r\n if not InitializeCriticalSectionAndSpinCount(FCriticalSection, SpinCount) then\r\n raise EJclCriticalSectionError.CreateRes(@RsSynchInitCriticalSection);\r\nend;\r\n\r\nfunction TJclCriticalSectionEx.GetSpinCount: Cardinal;\r\nbegin\r\n // Spinning only makes sense on multiprocessor systems. On a single processor\r\n // system the thread would simply waste cycles while the owning thread is\r\n // suspended and thus cannot release the critical section.\r\n if ProcessorCount = 1 then\r\n Result := 0\r\n else\r\n Result := FSpinCount;\r\nend;\r\n\r\nclass function TJclCriticalSectionEx.GetSpinTimeOut: Cardinal;\r\nbegin\r\n Result := Cardinal(RegReadInteger(HKEY_LOCAL_MACHINE, RegSessionManager,\r\n RegCritSecTimeout));\r\nend;\r\n\r\n{ TODO: Use RTLD version of SetCriticalSectionSpinCount }\r\nprocedure TJclCriticalSectionEx.SetSpinCount(const Value: Cardinal);\r\nbegin\r\n FSpinCount := SetCriticalSectionSpinCount(FCriticalSection, Value);\r\nend;\r\n\r\nclass procedure TJclCriticalSectionEx.SetSpinTimeOut(const Value: Cardinal);\r\nbegin\r\n RegWriteInteger(HKEY_LOCAL_MACHINE, RegSessionManager, RegCritSecTimeout,\r\n Integer(Value));\r\nend;\r\n\r\n{ TODO: Use RTLD version of TryEnterCriticalSection }\r\nfunction TJclCriticalSectionEx.TryEnter: Boolean;\r\nbegin\r\n Result := TryEnterCriticalSection(FCriticalSection);\r\nend;\r\n\r\n//== { TJclEvent } ===========================================================\r\n\r\nconstructor TJclEvent.Create(SecAttr: PSecurityAttributes; Manual, Signaled: Boolean; const Name: string);\r\nbegin\r\n inherited Create;\r\n FName := Name;\r\n FHandle := {$IFDEF HAS_UNITSCOPE}Winapi.{$ENDIF}Windows.CreateEvent(SecAttr, Manual, Signaled, PChar(FName));\r\n if FHandle = 0 then\r\n raise EJclEventError.CreateRes(@RsSynchCreateEvent);\r\n FExisted := GetLastError = ERROR_ALREADY_EXISTS;\r\nend;\r\n\r\nconstructor TJclEvent.Open(Access: Cardinal; Inheritable: Boolean;\r\n const Name: string);\r\nbegin\r\n FName := Name;\r\n FExisted := True;\r\n FHandle := {$IFDEF HAS_UNITSCOPE}Winapi.{$ENDIF}Windows.OpenEvent(Access, Inheritable, PChar(Name));\r\n if FHandle = 0 then\r\n raise EJclEventError.CreateRes(@RsSynchOpenEvent);\r\nend;\r\n\r\nfunction TJclEvent.Pulse: Boolean;\r\nbegin\r\n Result := {$IFDEF HAS_UNITSCOPE}Winapi.{$ENDIF}Windows.PulseEvent(FHandle);\r\nend;\r\n\r\nfunction TJclEvent.ResetEvent: Boolean;\r\nbegin\r\n Result := {$IFDEF HAS_UNITSCOPE}Winapi.{$ENDIF}Windows.ResetEvent(FHandle);\r\nend;\r\n\r\nfunction TJclEvent.SetEvent: Boolean;\r\nbegin\r\n Result := {$IFDEF HAS_UNITSCOPE}Winapi.{$ENDIF}Windows.SetEvent(FHandle);\r\nend;\r\n\r\n//=== { TJclWaitableTimer } ==================================================\r\n\r\n{ TODO: Use RTLD version of CreateWaitableTimer }\r\nconstructor TJclWaitableTimer.Create(SecAttr: PSecurityAttributes;\r\n Manual: Boolean; const Name: string);\r\nbegin\r\n FName := Name;\r\n FResume := False;\r\n FHandle := CreateWaitableTimer(SecAttr, Manual, PChar(Name));\r\n if FHandle = 0 then\r\n raise EJclWaitableTimerError.CreateRes(@RsSynchCreateWaitableTimer);\r\n FExisted := GetLastError = ERROR_ALREADY_EXISTS;\r\nend;\r\n\r\n{ TODO: Use RTLD version of CancelWaitableTimer }\r\nfunction TJclWaitableTimer.Cancel: Boolean;\r\nbegin\r\n Result := CancelWaitableTimer(FHandle);\r\nend;\r\n\r\n{ TODO: Use RTLD version of OpenWaitableTimer }\r\n\r\nconstructor TJclWaitableTimer.Open(Access: Cardinal; Inheritable: Boolean;\r\n const Name: string);\r\nbegin\r\n FExisted := True;\r\n FName := Name;\r\n FResume := False;\r\n FHandle := OpenWaitableTimer(Access, Inheritable, PChar(Name));\r\n if FHandle = 0 then\r\n raise EJclWaitableTimerError.CreateRes(@RsSynchOpenWaitableTimer);\r\nend;\r\n\r\n{ TODO: Use RTLD version of SetWaitableTimer }\r\nfunction TJclWaitableTimer.SetTimer(const DueTime: Int64; Period: Longint;\r\n Resume: Boolean): Boolean;\r\nvar\r\n DT: Int64;\r\nbegin\r\n DT := DueTime;\r\n FResume := Resume;\r\n Result := SetWaitableTimer(FHandle, DT, Period, nil, nil, FResume);\r\nend;\r\n\r\n{ TODO -cHelp : OS restrictions }\r\nfunction TJclWaitableTimer.SetTimerApc(const DueTime: Int64; Period: Longint;\r\n Resume: Boolean; Apc: TFNTimerAPCRoutine; Arg: Pointer): Boolean;\r\nvar\r\n DT: Int64;\r\nbegin\r\n DT := DueTime;\r\n FResume := Resume;\r\n Result := RtdlSetWaitableTimer(FHandle, DT, Period, Apc, Arg, FResume);\r\n { TODO : Exception for Win9x, older WinNT? }\r\n // if not Result and (GetLastError = ERROR_CALL_NOT_IMPLEMENTED) then\r\n // RaiseLastOSError;\r\nend;\r\n\r\n//== { TJclSemaphore } =======================================================\r\n\r\nconstructor TJclSemaphore.Create(SecAttr: PSecurityAttributes;\r\n Initial, Maximum: Integer; const Name: string);\r\nbegin\r\n Assert((Initial >= 0) and (Maximum > 0));\r\n FName := Name;\r\n FHandle := {$IFDEF HAS_UNITSCOPE}Winapi.{$ENDIF}Windows.CreateSemaphore(SecAttr, Initial, Maximum, PChar(Name));\r\n if FHandle = 0 then\r\n raise EJclSemaphoreError.CreateRes(@RsSynchCreateSemaphore);\r\n FExisted := GetLastError = ERROR_ALREADY_EXISTS;\r\nend;\r\n\r\nconstructor TJclSemaphore.Open(Access: Cardinal; Inheritable: Boolean;\r\n const Name: string);\r\nbegin\r\n FName := Name;\r\n FExisted := True;\r\n FHandle := {$IFDEF HAS_UNITSCOPE}Winapi.{$ENDIF}Windows.OpenSemaphore(Access, Inheritable, PChar(Name));\r\n if FHandle = 0 then\r\n raise EJclSemaphoreError.CreateRes(@RsSynchOpenSemaphore);\r\nend;\r\n\r\nfunction TJclSemaphore.ReleasePrev(ReleaseCount: Longint;\r\n var PrevCount: Longint): Boolean;\r\nbegin\r\n Result := {$IFDEF HAS_UNITSCOPE}Winapi.{$ENDIF}Windows.ReleaseSemaphore(FHandle, ReleaseCount, @PrevCount);\r\nend;\r\n\r\nfunction TJclSemaphore.Release(ReleaseCount: Integer): Boolean;\r\nbegin\r\n Result := {$IFDEF HAS_UNITSCOPE}Winapi.{$ENDIF}Windows.ReleaseSemaphore(FHandle, ReleaseCount, nil);\r\nend;\r\n\r\n//=== { TJclMutex } ==========================================================\r\n\r\nfunction TJclMutex.Acquire(const TimeOut: Cardinal): Boolean;\r\nbegin\r\n Result := WaitFor(TimeOut) = wrSignaled;\r\nend;\r\n\r\nconstructor TJclMutex.Create(SecAttr: PSecurityAttributes; InitialOwner: Boolean; const Name: string);\r\nbegin\r\n inherited Create;\r\n FName := Name;\r\n FHandle := JclWin32.CreateMutex(SecAttr, Ord(InitialOwner), PChar(Name));\r\n if FHandle = 0 then\r\n raise EJclMutexError.CreateRes(@RsSynchCreateMutex);\r\n FExisted := GetLastError = ERROR_ALREADY_EXISTS;\r\nend;\r\n\r\nconstructor TJclMutex.Open(Access: Cardinal; Inheritable: Boolean; const Name: string);\r\nbegin\r\n inherited Create;\r\n FName := Name;\r\n FExisted := True;\r\n FHandle := {$IFDEF HAS_UNITSCOPE}Winapi.{$ENDIF}Windows.OpenMutex(Access, Inheritable, PChar(Name));\r\n if FHandle = 0 then\r\n raise EJclMutexError.CreateRes(@RsSynchOpenMutex);\r\nend;\r\n\r\nfunction TJclMutex.Release: Boolean;\r\nbegin\r\n Result := {$IFDEF HAS_UNITSCOPE}Winapi.{$ENDIF}Windows.ReleaseMutex(FHandle);\r\nend;\r\n\r\n//=== { TJclOptex } ==========================================================\r\n\r\nconstructor TJclOptex.Create(const Name: string; SpinCount: Integer);\r\nbegin\r\n FExisted := False;\r\n FName := Name;\r\n if Name = '' then\r\n begin\r\n // None shared optex, don't need filemapping, sharedinfo is local\r\n FFileMapping := 0;\r\n FEvent := TJclEvent.Create(nil, False, False, '');\r\n FSharedInfo := AllocMem(SizeOf(TOptexSharedInfo));\r\n end\r\n else\r\n begin\r\n // Shared optex, event protects access to sharedinfo. Creation of filemapping\r\n // doesn't need protection as it will automatically \"open\" instead of \"create\"\r\n // if another process already created it.\r\n FEvent := TJclEvent.Create(nil, False, False, 'Optex_Event_' + Name);\r\n FExisted := FEvent.Existed;\r\n FFileMapping := {$IFDEF HAS_UNITSCOPE}Winapi.{$ENDIF}Windows.CreateFileMapping(INVALID_HANDLE_VALUE, nil, PAGE_READWRITE,\r\n 0, SizeOf(TOptexSharedInfo), PChar('Optex_MMF_' + Name));\r\n Assert(FFileMapping <> 0);\r\n FSharedInfo := {$IFDEF HAS_UNITSCOPE}Winapi.{$ENDIF}Windows.MapViewOfFile(FFileMapping, FILE_MAP_WRITE, 0, 0, 0);\r\n Assert(FSharedInfo <> nil);\r\n end;\r\n SetSpinCount(SpinCount);\r\nend;\r\n\r\ndestructor TJclOptex.Destroy;\r\nbegin\r\n FreeAndNil(FEvent);\r\n if UniProcess then\r\n FreeMem(FSharedInfo)\r\n else\r\n begin\r\n {$IFDEF HAS_UNITSCOPE}Winapi.{$ENDIF}Windows.UnmapViewOfFile(FSharedInfo);\r\n {$IFDEF HAS_UNITSCOPE}Winapi.{$ENDIF}Windows.CloseHandle(FFileMapping);\r\n end;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJclOptex.Enter;\r\nvar\r\n ThreadId: Longword;\r\nbegin\r\n if TryEnter then\r\n Exit;\r\n ThreadId := {$IFDEF HAS_UNITSCOPE}Winapi.{$ENDIF}Windows.GetCurrentThreadId;\r\n if {$IFDEF HAS_UNITSCOPE}Winapi.{$ENDIF}Windows.InterlockedIncrement(FSharedInfo^.LockCount) = 1 then\r\n begin\r\n // Optex was unowned\r\n FSharedInfo^.ThreadId := ThreadId;\r\n FSharedInfo^.RecursionCount := 1;\r\n end\r\n else\r\n begin\r\n if FSharedInfo^.ThreadId = ThreadId then\r\n begin\r\n // We already owned it, increase ownership count\r\n Inc(FSharedInfo^.RecursionCount)\r\n end\r\n else\r\n begin\r\n // Optex is owner by someone else, wait for it to be released and then\r\n // immediately take ownership\r\n FEvent.WaitForever;\r\n FSharedInfo^.ThreadId := ThreadId;\r\n FSharedInfo^.RecursionCount := 1;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJclOptex.GetSpinCount: Integer;\r\nbegin\r\n Result := FSharedInfo^.SpinCount;\r\nend;\r\n\r\nfunction TJclOptex.GetUniProcess: Boolean;\r\nbegin\r\n Result := FFileMapping = 0;\r\nend;\r\n\r\nprocedure TJclOptex.Leave;\r\nbegin\r\n Dec(FSharedInfo^.RecursionCount);\r\n if FSharedInfo^.RecursionCount > 0 then\r\n {$IFDEF HAS_UNITSCOPE}Winapi.{$ENDIF}Windows.InterlockedDecrement(FSharedInfo^.LockCount)\r\n else\r\n begin\r\n FSharedInfo^.ThreadId := 0;\r\n if {$IFDEF HAS_UNITSCOPE}Winapi.{$ENDIF}Windows.InterlockedDecrement(FSharedInfo^.LockCount) > 0 then\r\n FEvent.SetEvent;\r\n end;\r\nend;\r\n\r\nprocedure TJclOptex.SetSpinCount(Value: Integer);\r\nbegin\r\n if Value < 0 then\r\n Value := DefaultCritSectSpinCount;\r\n // Spinning only makes sense on multiprocessor systems\r\n if ProcessorCount > 1 then\r\n {$IFDEF HAS_UNITSCOPE}Winapi.{$ENDIF}Windows.InterlockedExchange(Integer(FSharedInfo^.SpinCount), Value);\r\nend;\r\n\r\nfunction TJclOptex.TryEnter: Boolean;\r\nvar\r\n ThreadId: Longword;\r\n ThreadOwnsOptex: Boolean;\r\n SpinCount: Integer;\r\nbegin\r\n ThreadId := {$IFDEF HAS_UNITSCOPE}Winapi.{$ENDIF}Windows.GetCurrentThreadId;\r\n SpinCount := FSharedInfo^.SpinCount;\r\n repeat\r\n //ThreadOwnsOptex := InterlockedCompareExchange(Pointer(FSharedInfo^.LockCount),\r\n // Pointer(1), Pointer(0)) = Pointer(0); // not available on win95\r\n ThreadOwnsOptex := LockedCompareExchange(FSharedInfo^.LockCount, 1, 0) = 0;\r\n if ThreadOwnsOptex then\r\n begin\r\n // Optex was unowned\r\n FSharedInfo^.ThreadId := ThreadId;\r\n FSharedInfo^.RecursionCount := 1;\r\n end\r\n else\r\n begin\r\n if FSharedInfo^.ThreadId = ThreadId then\r\n begin\r\n // We already owned the Optex\r\n {$IFDEF HAS_UNITSCOPE}Winapi.{$ENDIF}Windows.InterlockedIncrement(FSharedInfo^.LockCount);\r\n Inc(FSharedInfo^.RecursionCount);\r\n ThreadOwnsOptex := True;\r\n end;\r\n end;\r\n Dec(SpinCount);\r\n until ThreadOwnsOptex or (SpinCount <= 0);\r\n Result := ThreadOwnsOptex;\r\nend;\r\n\r\n//=== { TJclMultiReadExclusiveWrite } ========================================\r\n\r\nconstructor TJclMultiReadExclusiveWrite.Create(Preferred: TMrewPreferred);\r\nbegin\r\n inherited Create;\r\n FLock := TJclCriticalSection.Create;\r\n FPreferred := Preferred;\r\n FSemReaders := TJclSemaphore.Create(nil, 0, MaxInt, '');\r\n FSemWriters := TJclSemaphore.Create(nil, 0, MaxInt, '');\r\n SetLength(FThreads, 0);\r\n FState := 0;\r\n FWaitingReaders := 0;\r\n FWaitingWriters := 0;\r\nend;\r\n\r\ndestructor TJclMultiReadExclusiveWrite.Destroy;\r\nbegin\r\n FreeAndNil(FSemReaders);\r\n FreeAndNil(FSemWriters);\r\n FreeAndNil(FLock);\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJclMultiReadExclusiveWrite.AddToThreadList(ThreadId: Longword;\r\n Reader: Boolean);\r\nvar\r\n L: Integer;\r\nbegin\r\n // Caller must own lock\r\n L := Length(FThreads);\r\n SetLength(FThreads, L + 1);\r\n FThreads[L].ThreadId := ThreadId;\r\n FThreads[L].RecursionCount := 1;\r\n FThreads[L].Reader := Reader;\r\nend;\r\n\r\nprocedure TJclMultiReadExclusiveWrite.BeginRead;\r\nvar\r\n ThreadId: Longword;\r\n Index: Integer;\r\n MustWait: Boolean;\r\nbegin\r\n MustWait := False;\r\n ThreadId := {$IFDEF HAS_UNITSCOPE}Winapi.{$ENDIF}Windows.GetCurrentThreadId;\r\n FLock.Enter;\r\n try\r\n Index := FindThread(ThreadId);\r\n if Index >= 0 then\r\n begin\r\n // Thread is on threadslist so it is already reading\r\n Inc(FThreads[Index].RecursionCount);\r\n end\r\n else\r\n begin\r\n // Request to read (first time)\r\n AddToThreadList(ThreadId, True);\r\n if FState >= 0 then\r\n begin\r\n // MREW is unowned or only readers. If there are no waiting writers or\r\n // readers are preferred then allow thread to continue, otherwise it must\r\n // wait it's turn\r\n if (FPreferred = mpReaders) or (FWaitingWriters = 0) then\r\n Inc(FState)\r\n else\r\n begin\r\n Inc(FWaitingReaders);\r\n MustWait := True;\r\n end;\r\n end\r\n else\r\n begin\r\n // MREW is owner by a writer, must wait\r\n Inc(FWaitingReaders);\r\n MustWait := True;\r\n end;\r\n end;\r\n finally\r\n FLock.Leave;\r\n end;\r\n if MustWait then\r\n FSemReaders.WaitForever;\r\nend;\r\n\r\nprocedure TJclMultiReadExclusiveWrite.BeginWrite;\r\nvar\r\n ThreadId: Longword;\r\n Index: Integer;\r\n MustWait: Boolean;\r\nbegin\r\n MustWait := False;\r\n FLock.Enter;\r\n try\r\n ThreadId := {$IFDEF HAS_UNITSCOPE}Winapi.{$ENDIF}Windows.GetCurrentThreadId;\r\n Index := FindThread(ThreadId);\r\n if Index < 0 then\r\n begin\r\n // Request to write (first time)\r\n AddToThreadList(ThreadId, False);\r\n if FState = 0 then\r\n begin\r\n // MREW is unowned so start writing\r\n FState := -1;\r\n end\r\n else\r\n begin\r\n // MREW is owner, must wait\r\n Inc(FWaitingWriters);\r\n MustWait := True;\r\n end;\r\n end\r\n else\r\n begin\r\n if FThreads[Index].Reader then\r\n begin\r\n // Request to write while reading\r\n Inc(FThreads[Index].RecursionCount);\r\n FThreads[Index].Reader := False;\r\n Dec(FState);\r\n if FState = 0 then\r\n begin\r\n // MREW is unowned so start writing\r\n FState := -1;\r\n end\r\n else\r\n begin\r\n // MREW is owned, must wait\r\n MustWait := True;\r\n Inc(FWaitingWriters);\r\n end;\r\n end\r\n else\r\n // Requesting to write while already writing\r\n Inc(FThreads[Index].RecursionCount);\r\n end;\r\n finally\r\n FLock.Leave;\r\n end;\r\n if MustWait then\r\n FSemWriters.WaitFor(INFINITE);\r\nend;\r\n\r\nprocedure TJclMultiReadExclusiveWrite.EndRead;\r\nbegin\r\n Release;\r\nend;\r\n\r\nprocedure TJclMultiReadExclusiveWrite.EndWrite;\r\nbegin\r\n Release;\r\nend;\r\n\r\nfunction TJclMultiReadExclusiveWrite.FindThread(ThreadId: Longword): Integer;\r\nvar\r\n I: Integer;\r\nbegin\r\n // Caller must lock\r\n Result := -1;\r\n for I := 0 to Length(FThreads) - 1 do\r\n if FThreads[I].ThreadId = ThreadId then\r\n begin\r\n Result := I;\r\n Exit;\r\n end;\r\nend;\r\n\r\nprocedure TJclMultiReadExclusiveWrite.Release;\r\nvar\r\n ThreadId: Longword;\r\n Index: Integer;\r\n WasReading: Boolean;\r\nbegin\r\n ThreadId := GetCurrentThreadId;\r\n FLock.Enter;\r\n try\r\n Index := FindThread(ThreadId);\r\n if Index >= 0 then\r\n begin\r\n Dec(FThreads[Index].RecursionCount);\r\n if FThreads[Index].RecursionCount = 0 then\r\n begin\r\n WasReading := FThreads[Index].Reader;\r\n if WasReading then\r\n Dec(FState)\r\n else\r\n FState := 0;\r\n RemoveFromThreadList(Index);\r\n if FState = 0 then\r\n ReleaseWaiters(WasReading);\r\n end;\r\n end;\r\n finally\r\n FLock.Leave;\r\n end;\r\nend;\r\n\r\nprocedure TJclMultiReadExclusiveWrite.ReleaseWaiters(WasReading: Boolean);\r\nvar\r\n ToRelease: TMrewPreferred;\r\nbegin\r\n // Caller must Lock\r\n ToRelease := mpEqual;\r\n case FPreferred of\r\n mpReaders:\r\n if FWaitingReaders > 0 then\r\n ToRelease := mpReaders\r\n else\r\n if FWaitingWriters > 0 then\r\n ToRelease := mpWriters;\r\n mpWriters:\r\n if FWaitingWriters > 0 then\r\n ToRelease := mpWriters\r\n else\r\n if FWaitingReaders > 0 then\r\n ToRelease := mpReaders;\r\n mpEqual:\r\n if WasReading then\r\n begin\r\n if FWaitingWriters > 0 then\r\n ToRelease := mpWriters\r\n else\r\n if FWaitingReaders > 0 then\r\n ToRelease := mpReaders;\r\n end\r\n else\r\n begin\r\n if FWaitingReaders > 0 then\r\n ToRelease := mpReaders\r\n else\r\n if FWaitingWriters > 0 then\r\n ToRelease := mpWriters;\r\n end;\r\n end;\r\n case ToRelease of\r\n mpReaders:\r\n begin\r\n FState := FWaitingReaders;\r\n FWaitingReaders := 0;\r\n FSemReaders.Release(FState);\r\n end;\r\n mpWriters:\r\n begin\r\n FState := -1;\r\n Dec(FWaitingWriters);\r\n FSemWriters.Release(1);\r\n end;\r\n mpEqual:\r\n // no waiters\r\n end;\r\nend;\r\n\r\nprocedure TJclMultiReadExclusiveWrite.RemoveFromThreadList(Index: Integer);\r\nvar\r\n L: Integer;\r\nbegin\r\n // Caller must Lock\r\n L := Length(FThreads);\r\n if Index < (L - 1) then\r\n Move(FThreads[Index + 1], FThreads[Index], SizeOf(TMrewThreadInfo) * (L - Index - 1));\r\n SetLength(FThreads, L - 1);\r\nend;\r\n\r\n//=== { TJclMeteredSection } =================================================\r\n\r\nconst\r\n MAX_METSECT_NAMELEN = 128;\r\n\r\nconstructor TJclMeteredSection.Create(InitialCount, MaxCount: Integer; const Name: string);\r\nbegin\r\n if (MaxCount < 1) or (InitialCount > MaxCount) or (InitialCount < 0) or\r\n (Length(Name) > MAX_METSECT_NAMELEN) then\r\n raise EJclMeteredSectionError.CreateRes(@RsMetSectInvalidParameter);\r\n FMetSect := PMeteredSection(AllocMem(SizeOf(TMeteredSection)));\r\n if FMetSect <> nil then\r\n begin\r\n if not InitMeteredSection(InitialCount, MaxCount, Name, False) then\r\n begin\r\n CloseMeteredSection;\r\n FMetSect := nil;\r\n raise EJclMeteredSectionError.CreateRes(@RsMetSectInitialize);\r\n end;\r\n end;\r\nend;\r\n\r\nconstructor TJclMeteredSection.Open(const Name: string);\r\nbegin\r\n FMetSect := nil;\r\n if Name = '' then\r\n raise EJclMeteredSectionError.CreateRes(@RsMetSectNameEmpty);\r\n FMetSect := PMeteredSection(AllocMem(SizeOf(TMeteredSection)));\r\n Assert(FMetSect <> nil);\r\n if not InitMeteredSection(0, 0, Name, True) then\r\n begin\r\n CloseMeteredSection;\r\n FMetSect := nil;\r\n raise EJclMeteredSectionError.CreateRes(@RsMetSectInitialize);\r\n end;\r\nend;\r\n\r\ndestructor TJclMeteredSection.Destroy;\r\nbegin\r\n CloseMeteredSection;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJclMeteredSection.AcquireLock;\r\nbegin\r\n while {$IFDEF HAS_UNITSCOPE}Winapi.{$ENDIF}Windows.InterlockedExchange(FMetSect^.SharedInfo^.SpinLock, 1) <> 0 do\r\n {$IFDEF HAS_UNITSCOPE}Winapi.{$ENDIF}Windows.Sleep(0);\r\nend;\r\n\r\nprocedure TJclMeteredSection.CloseMeteredSection;\r\nbegin\r\n if FMetSect <> nil then\r\n begin\r\n if FMetSect^.SharedInfo <> nil then\r\n {$IFDEF HAS_UNITSCOPE}Winapi.{$ENDIF}Windows.UnmapViewOfFile(FMetSect^.SharedInfo);\r\n if FMetSect^.FileMap <> 0 then\r\n {$IFDEF HAS_UNITSCOPE}Winapi.{$ENDIF}Windows.CloseHandle(FMetSect^.FileMap);\r\n if FMetSect^.Event <> 0 then\r\n {$IFDEF HAS_UNITSCOPE}Winapi.{$ENDIF}Windows.CloseHandle(FMetSect^.Event);\r\n FreeMem(FMetSect);\r\n end;\r\nend;\r\n\r\nfunction TJclMeteredSection.CreateMetSectEvent(const Name: string; OpenOnly: Boolean): Boolean;\r\nvar\r\n FullName: string;\r\nbegin\r\n if Name = '' then\r\n FMetSect^.Event := {$IFDEF HAS_UNITSCOPE}Winapi.{$ENDIF}Windows.CreateEvent(nil, False, False, nil)\r\n else\r\n begin\r\n FullName := 'JCL_MSECT_EVT_' + Name;\r\n if OpenOnly then\r\n FMetSect^.Event := {$IFDEF HAS_UNITSCOPE}Winapi.{$ENDIF}Windows.OpenEvent(0, False, PChar(FullName))\r\n else\r\n FMetSect^.Event := {$IFDEF HAS_UNITSCOPE}Winapi.{$ENDIF}Windows.CreateEvent(nil, False, False, PChar(FullName));\r\n end;\r\n Result := FMetSect^.Event <> 0;\r\nend;\r\n\r\nfunction TJclMeteredSection.CreateMetSectFileView(InitialCount, MaxCount: Longint;\r\n const Name: string; OpenOnly: Boolean): Boolean;\r\nvar\r\n FullName: string;\r\n LastError: DWORD;\r\nbegin\r\n Result := False;\r\n if Name = '' then\r\n FMetSect^.FileMap := {$IFDEF HAS_UNITSCOPE}Winapi.{$ENDIF}Windows.CreateFileMapping(INVALID_HANDLE_VALUE, nil, PAGE_READWRITE, 0, SizeOf(TMetSectSharedInfo), nil)\r\n else\r\n begin\r\n FullName := 'JCL_MSECT_MMF_' + Name;\r\n if OpenOnly then\r\n FMetSect^.FileMap := {$IFDEF HAS_UNITSCOPE}Winapi.{$ENDIF}Windows.OpenFileMapping(0, False, PChar(FullName))\r\n else\r\n FMetSect^.FileMap := {$IFDEF HAS_UNITSCOPE}Winapi.{$ENDIF}Windows.CreateFileMapping(INVALID_HANDLE_VALUE, nil, PAGE_READWRITE, 0, SizeOf(TMetSectSharedInfo), PChar(FullName));\r\n end;\r\n if FMetSect^.FileMap <> 0 then\r\n begin\r\n LastError := GetLastError;\r\n FMetSect^.SharedInfo := {$IFDEF HAS_UNITSCOPE}Winapi.{$ENDIF}Windows.MapViewOfFile(FMetSect^.FileMap, FILE_MAP_WRITE, 0, 0, 0);\r\n if FMetSect^.SharedInfo <> nil then\r\n begin\r\n if LastError = ERROR_ALREADY_EXISTS then\r\n while not FMetSect^.SharedInfo^.Initialized do Sleep(0)\r\n else\r\n begin\r\n FMetSect^.SharedInfo^.SpinLock := 0;\r\n FMetSect^.SharedInfo^.ThreadsWaiting := 0;\r\n FMetSect^.SharedInfo^.AvailableCount := InitialCount;\r\n FMetSect^.SharedInfo^.MaximumCount := MaxCount;\r\n {$IFDEF HAS_UNITSCOPE}Winapi.{$ENDIF}Windows.InterlockedExchange(Integer(FMetSect^.SharedInfo^.Initialized), 1);\r\n end;\r\n Result := True;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJclMeteredSection.Enter(TimeOut: Longword): TJclWaitResult;\r\nbegin\r\n Result := wrSignaled;\r\n while Result = wrSignaled do\r\n begin\r\n AcquireLock;\r\n try\r\n if FMetSect^.SharedInfo^.AvailableCount >= 1 then\r\n begin\r\n Dec(FMetSect^.SharedInfo^.AvailableCount);\r\n Result := MapSignalResult(WAIT_OBJECT_0);\r\n Exit;\r\n end;\r\n Inc(FMetSect^.SharedInfo^.ThreadsWaiting);\r\n {$IFDEF HAS_UNITSCOPE}Winapi.{$ENDIF}Windows.ResetEvent(FMetSect^.Event);\r\n finally\r\n ReleaseLock;\r\n end;\r\n Result := MapSignalResult({$IFDEF HAS_UNITSCOPE}Winapi.{$ENDIF}Windows.WaitForSingleObject(FMetSect^.Event, TimeOut));\r\n end;\r\nend;\r\n\r\nfunction TJclMeteredSection.InitMeteredSection(InitialCount, MaxCount: Longint;\r\n const Name: string; OpenOnly: Boolean): Boolean;\r\nbegin\r\n Result := False;\r\n if CreateMetSectEvent(Name, OpenOnly) then\r\n Result := CreateMetSectFileView(InitialCount, MaxCount, Name, OpenOnly);\r\nend;\r\n\r\nfunction TJclMeteredSection.Leave(ReleaseCount: Integer; out PrevCount: Integer): Boolean;\r\nvar\r\n Count: Integer;\r\nbegin\r\n Result := False;\r\n AcquireLock;\r\n try\r\n PrevCount := FMetSect^.SharedInfo^.AvailableCount;\r\n if (ReleaseCount < 0) or\r\n (FMetSect^.SharedInfo^.AvailableCount + ReleaseCount > FMetSect^.SharedInfo^.MaximumCount) then\r\n begin\r\n {$IFDEF HAS_UNITSCOPE}Winapi.{$ENDIF}Windows.SetLastError(ERROR_INVALID_PARAMETER);\r\n Exit;\r\n end;\r\n Inc(FMetSect^.SharedInfo^.AvailableCount, ReleaseCount);\r\n ReleaseCount := Min(ReleaseCount, FMetSect^.SharedInfo^.ThreadsWaiting);\r\n if FMetSect^.SharedInfo^.ThreadsWaiting > 0 then\r\n begin\r\n for Count := 0 to ReleaseCount - 1 do\r\n begin\r\n Dec(FMetSect^.SharedInfo^.ThreadsWaiting);\r\n {$IFDEF HAS_UNITSCOPE}Winapi.{$ENDIF}Windows.SetEvent(FMetSect^.Event);\r\n end;\r\n end;\r\n finally\r\n ReleaseLock;\r\n end;\r\n Result := True;\r\nend;\r\n\r\nfunction TJclMeteredSection.Leave(ReleaseCount: Integer): Boolean;\r\nvar\r\n Previous: Longint;\r\nbegin\r\n Result := Leave(ReleaseCount, Previous);\r\nend;\r\n\r\nprocedure TJclMeteredSection.ReleaseLock;\r\nbegin\r\n {$IFDEF HAS_UNITSCOPE}Winapi.{$ENDIF}Windows.InterlockedExchange(FMetSect^.SharedInfo^.SpinLock, 0);\r\nend;\r\n\r\n//=== Debugging ==============================================================\r\n\r\nfunction QueryCriticalSection(CS: TJclCriticalSection; var Info: TRTLCriticalSection): Boolean;\r\nbegin\r\n Result := CS <> nil;\r\n if Result then\r\n Info := CS.FCriticalSection;\r\nend;\r\n\r\n// Native API functions\r\n// http://undocumented.ntinternals.net/\r\n\r\n{ TODO: RTLD version }\r\n\r\ntype\r\n TNtQueryProc = function (Handle: THandle; InfoClass: Byte; Info: Pointer;\r\n Len: Longint; ResLen: PLongint): Longint; stdcall;\r\n\r\nvar\r\n _QueryEvent: TNtQueryProc = nil;\r\n _QueryMutex: TNtQueryProc = nil;\r\n _QuerySemaphore: TNtQueryProc = nil;\r\n _QueryTimer: TNtQueryProc = nil;\r\n\r\nfunction CallQueryProc(var P: TNtQueryProc; const Name: string; Handle: THandle;\r\n Info: Pointer; InfoSize: Longint): Boolean;\r\nvar\r\n NtDll: THandle;\r\n Status: Longint;\r\nbegin\r\n Result := False;\r\n if @P = nil then\r\n begin\r\n NtDll := GetModuleHandle(PChar('ntdll.dll'));\r\n if NtDll <> 0 then\r\n @P := GetProcAddress(NtDll, PChar(Name));\r\n end;\r\n if @P <> nil then\r\n begin\r\n Status := P(Handle, 0, Info, InfoSize, nil);\r\n Result := (Status and $80000000) = 0;\r\n end;\r\nend;\r\n\r\nfunction QueryEvent(Handle: THandle; var Info: TEventInfo): Boolean;\r\nbegin\r\n Result := CallQueryProc(_QueryEvent, 'NtQueryEvent', Handle, @Info, SizeOf(Info));\r\nend;\r\n\r\nfunction QueryMutex(Handle: THandle; var Info: TMutexInfo): Boolean;\r\nbegin\r\n Result := CallQueryProc(_QueryMutex, 'NtQueryMutex', Handle, @Info, SizeOf(Info));\r\nend;\r\n\r\nfunction QuerySemaphore(Handle: THandle; var Info: TSemaphoreCounts): Boolean;\r\nbegin\r\n Result := CallQueryProc(_QuerySemaphore, 'NtQuerySemaphore', Handle, @Info, SizeOf(Info));\r\nend;\r\n\r\nfunction QueryTimer(Handle: THandle; var Info: TTimerInfo): Boolean;\r\nbegin\r\n Result := CallQueryProc(_QueryTimer, 'NtQueryTimer', Handle, @Info, SizeOf(Info));\r\nend;\r\n\r\nfunction ValidateMutexName(const aName: string): string;\r\nconst cMutexMaxName = 200;\r\nbegin\r\n if Length(aName) > cMutexMaxName then\r\n Result := Copy (aName, Length(aName)-cMutexMaxName, cMutexMaxName)\r\n else\r\n Result := aName;\r\n Result := StrReplaceChar(Result, '\\', '_');\r\nend;\r\n\r\n\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jcl/source/common/JclSysInfo.pas", "content": "{**************************************************************************************************}\r\n{ }\r\n{ Project JEDI Code Library (JCL) }\r\n{ }\r\n{ The contents of this file are subject to the Mozilla Public License Version 1.1 (the \"License\"); }\r\n{ you may not use this file except in compliance with the License. You may obtain a copy of the }\r\n{ License at http://www.mozilla.org/MPL/ }\r\n{ }\r\n{ Software distributed under the License is distributed on an \"AS IS\" basis, WITHOUT WARRANTY OF }\r\n{ ANY KIND, either express or implied. See the License for the specific language governing rights }\r\n{ and limitations under the License. }\r\n{ }\r\n{ The Original Code is JclSysInfo.pas. }\r\n{ }\r\n{ The Initial Developer of the Original Code is Marcel van Brakel. }\r\n{ Portions created by Marcel van Brakel are Copyright (C) Marcel van Brakel. All rights reserved. }\r\n{ }\r\n{ Contributors: }\r\n{ Alexander Radchenko }\r\n{ Andre Snepvangers (asnepvangers) }\r\n{ Azret Botash }\r\n{ Bryan Coutch }\r\n{ Carl Clark }\r\n{ Eric S. Fisher }\r\n{ Florent Ouchet (outchy) }\r\n{ Heiko Adams }\r\n{ James Azarja }\r\n{ Jean-Fabien Connault (cycocrew) }\r\n{ John C Molyneux }\r\n{ Marcel van Brakel }\r\n{ Matthias Thoma (mthoma) }\r\n{ Mike Lischke }\r\n{ Nick Hodges }\r\n{ Olivier Sannier (obones) }\r\n{ Peter Friese }\r\n{ Peter Thornquist (peter3) }\r\n{ Petr Vones (pvones) }\r\n{ Rik Barker }\r\n{ Robert Marquardt (marquardt) }\r\n{ Robert Rossmair (rrossmair) }\r\n{ Scott Price }\r\n{ Tom Hahn (tomhahn) }\r\n{ Wim de Cleen }\r\n{ }\r\n{**************************************************************************************************}\r\n{ }\r\n{ This unit contains routines and classes to retrieve various pieces of system information. }\r\n{ Examples are the location of standard folders, settings of environment variables, processor }\r\n{ details and the Windows version. }\r\n{ }\r\n{**************************************************************************************************}\r\n{ }\r\n{ Last modified: $Date:: 2012-08-22 17:40:33 +0200 (mer. 22 août 2012) $ }\r\n{ Revision: $Rev:: 3843 $ }\r\n{ Author: $Author:: outchy $ }\r\n{ }\r\n{**************************************************************************************************}\r\n\r\n// Windows NT 4 and earlier do not support GetSystemPowerStatus (while introduced\r\n// in NT4 - it is a stub there - implemented in Windows 2000 and later.\r\n\r\n\r\nunit JclSysInfo;\r\n\r\n{$I jcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n {$IFDEF HAS_UNIT_LIBC}\r\n Libc,\r\n {$ENDIF HAS_UNIT_LIBC}\r\n {$IFDEF HAS_UNITSCOPE}\r\n {$IFDEF MSWINDOWS}\r\n Winapi.Windows, WinApi.ActiveX, Winapi.ShlObj,\r\n {$ENDIF MSWINDOWS}\r\n System.Classes,\r\n {$ELSE ~HAS_UNITSCOPE}\r\n {$IFDEF MSWINDOWS}\r\n Windows, ActiveX, ShlObj,\r\n {$ENDIF MSWINDOWS}\r\n Classes,\r\n {$ENDIF ~HAS_UNITSCOPE}\r\n JclBase, JclResources;\r\n\r\n// Environment Variables\r\n{$IFDEF MSWINDOWS}\r\ntype\r\n TEnvironmentOption = (eoLocalMachine, eoCurrentUser, eoAdditional);\r\n TEnvironmentOptions = set of TEnvironmentOption;\r\n{$ENDIF MSWINDOWS}\r\n\r\nfunction DelEnvironmentVar(const Name: string): Boolean;\r\nfunction ExpandEnvironmentVar(var Value: string): Boolean;\r\nfunction ExpandEnvironmentVarCustom(var Value: string; Vars: TStrings): Boolean;\r\nfunction GetEnvironmentVar(const Name: string; out Value: string): Boolean; overload;\r\nfunction GetEnvironmentVar(const Name: string; out Value: string; Expand: Boolean): Boolean; overload;\r\nfunction GetEnvironmentVars(const Vars: TStrings): Boolean; overload;\r\nfunction GetEnvironmentVars(const Vars: TStrings; Expand: Boolean): Boolean; overload;\r\nfunction SetEnvironmentVar(const Name, Value: string): Boolean;\r\n{$IFDEF MSWINDOWS}\r\nfunction CreateEnvironmentBlock(const Options: TEnvironmentOptions; const AdditionalVars: TStrings): PChar;\r\nprocedure DestroyEnvironmentBlock(var Env: PChar);\r\nprocedure SetGlobalEnvironmentVariable(VariableName, VariableContent: string);\r\n{$ENDIF MSWINDOWS}\r\n\r\n// Common Folder Locations\r\n{$IFDEF MSWINDOWS}\r\nfunction GetCommonFilesFolder: string;\r\n{$ENDIF MSWINDOWS}\r\nfunction GetCurrentFolder: string;\r\n{$IFDEF MSWINDOWS}\r\nfunction GetProgramFilesFolder: string;\r\nfunction GetWindowsFolder: string;\r\nfunction GetWindowsSystemFolder: string;\r\nfunction GetWindowsTempFolder: string;\r\n\r\nfunction GetDesktopFolder: string;\r\nfunction GetProgramsFolder: string;\r\n{$ENDIF MSWINDOWS}\r\nfunction GetPersonalFolder: string;\r\n{$IFDEF MSWINDOWS}\r\nfunction GetFavoritesFolder: string;\r\nfunction GetStartupFolder: string;\r\nfunction GetRecentFolder: string;\r\nfunction GetSendToFolder: string;\r\nfunction GetStartmenuFolder: string;\r\nfunction GetDesktopDirectoryFolder: string;\r\nfunction GetCommonDocumentsFolder: string;\r\nfunction GetNethoodFolder: string;\r\nfunction GetFontsFolder: string;\r\nfunction GetCommonStartmenuFolder: string;\r\nfunction GetCommonStartupFolder: string;\r\nfunction GetPrinthoodFolder: string;\r\nfunction GetProfileFolder: string;\r\nfunction GetCommonProgramsFolder: string;\r\nfunction GetCommonDesktopdirectoryFolder: string;\r\nfunction GetCommonAppdataFolder: string;\r\nfunction GetAppdataFolder: string;\r\nfunction GetLocalAppData: string;\r\nfunction GetCommonFavoritesFolder: string;\r\nfunction GetTemplatesFolder: string;\r\nfunction GetInternetCacheFolder: string;\r\nfunction GetCookiesFolder: string;\r\nfunction GetHistoryFolder: string;\r\n\r\n// Advanced Power Management (APM)\r\ntype\r\n TAPMLineStatus = (alsOffline, alsOnline, alsUnknown);\r\n TAPMBatteryFlag = (abfHigh, abfLow, abfCritical, abfCharging, abfNoBattery, abfUnknown);\r\n TAPMBatteryFlags = set of TAPMBatteryFlag;\r\n\r\nfunction GetAPMLineStatus: TAPMLineStatus;\r\nfunction GetAPMBatteryFlag: TAPMBatteryFlag;\r\nfunction GetAPMBatteryFlags: TAPMBatteryFlags;\r\nfunction GetAPMBatteryLifePercent: Integer;\r\nfunction GetAPMBatteryLifeTime: DWORD;\r\nfunction GetAPMBatteryFullLifeTime: DWORD;\r\n\r\n// Identification\r\ntype\r\n TFileSystemFlag =\r\n (\r\n fsCaseSensitive, // The file system supports case-sensitive file names.\r\n fsCasePreservedNames, // The file system preserves the case of file names when it places a name on disk.\r\n fsSupportsUnicodeOnDisk, // The file system supports Unicode in file names as they appear on disk.\r\n fsPersistentACLs, // The file system preserves and enforces ACLs. For example, NTFS preserves and enforces ACLs, and FAT does not.\r\n fsSupportsFileCompression, // The file system supports file-based compression.\r\n fsSupportsVolumeQuotas, // The file system supports disk quotas.\r\n fsSupportsSparseFiles, // The file system supports sparse files.\r\n fsSupportsReparsePoints, // The file system supports reparse points.\r\n fsSupportsRemoteStorage, // ?\r\n fsVolumeIsCompressed, // The specified volume is a compressed volume; for example, a DoubleSpace volume.\r\n fsSupportsObjectIds, // The file system supports object identifiers.\r\n fsSupportsEncryption, // The file system supports the Encrypted File System (EFS).\r\n fsSupportsNamedStreams, // The file system supports named streams.\r\n fsVolumeIsReadOnly // The specified volume is read-only.\r\n // Windows 2000/NT and Windows Me/98/95: This value is not supported.\r\n );\r\n\r\n TFileSystemFlags = set of TFileSystemFlag;\r\n\r\nfunction GetVolumeName(const Drive: string): string;\r\nfunction GetVolumeSerialNumber(const Drive: string): string;\r\nfunction GetVolumeFileSystem(const Drive: string): string;\r\nfunction GetVolumeFileSystemFlags(const Volume: string): TFileSystemFlags;\r\n{$ENDIF MSWINDOWS}\r\nfunction GetIPAddress(const HostName: string): string;\r\n{$IFDEF MSWINDOWS}\r\nprocedure GetIpAddresses(Results: TStrings; const HostName: AnsiString); overload;\r\n{$ENDIF MSWINDOWS}\r\nprocedure GetIpAddresses(Results: TStrings); overload;\r\nfunction GetLocalComputerName: string;\r\nfunction GetLocalUserName: string;\r\n{$IFDEF MSWINDOWS}\r\nfunction GetUserDomainName(const CurUser: string): string;\r\nfunction GetWorkGroupName: WideString;\r\n{$ENDIF MSWINDOWS}\r\nfunction GetDomainName: string;\r\n{$IFDEF MSWINDOWS}\r\nfunction GetRegisteredCompany: string;\r\nfunction GetRegisteredOwner: string;\r\nfunction GetBIOSName: string;\r\nfunction GetBIOSCopyright: string;\r\nfunction GetBIOSExtendedInfo: string;\r\nfunction GetBIOSDate: TDateTime;\r\n{$ENDIF MSWINDOWS}\r\n\r\n// Processes, Tasks and Modules\r\ntype\r\n TJclTerminateAppResult = (taError, taClean, taKill);\r\n\r\nfunction RunningProcessesList(const List: TStrings; FullPath: Boolean = True): Boolean;\r\n\r\n{$IFDEF MSWINDOWS}\r\nfunction LoadedModulesList(const List: TStrings; ProcessID: DWORD; HandlesOnly: Boolean = False): Boolean;\r\nfunction GetTasksList(const List: TStrings): Boolean;\r\n\r\nfunction ModuleFromAddr(const Addr: Pointer): HMODULE;\r\nfunction IsSystemModule(const Module: HMODULE): Boolean;\r\n\r\nfunction IsMainAppWindow(Wnd: THandle): Boolean;\r\nfunction IsWindowResponding(Wnd: THandle; Timeout: Integer): Boolean;\r\n\r\nfunction GetWindowIcon(Wnd: THandle; LargeIcon: Boolean): HICON;\r\nfunction GetWindowCaption(Wnd: THandle): string;\r\nfunction TerminateTask(Wnd: THandle; Timeout: Integer): TJclTerminateAppResult;\r\nfunction TerminateApp(ProcessID: DWORD; Timeout: Integer): TJclTerminateAppResult;\r\n{$ENDIF MSWINDOWS}\r\n\r\n{$IFDEF MSWINDOWS}\r\n{.$IFNDEF FPC}\r\nfunction GetPidFromProcessName(const ProcessName: string): THandle;\r\nfunction GetProcessNameFromWnd(Wnd: THandle): string;\r\nfunction GetProcessNameFromPid(PID: DWORD): string;\r\nfunction GetMainAppWndFromPid(PID: DWORD): THandle;\r\nfunction GetWndFromPid(PID: DWORD; const WindowClassName: string): HWND;\r\n{.$ENDIF ~FPC}\r\n\r\nfunction GetShellProcessName: string;\r\n{.$IFNDEF FPC}\r\nfunction GetShellProcessHandle: THandle;\r\n{.$ENDIF ~FPC}\r\n\r\n// Version Information\r\ntype\r\n TWindowsVersion =\r\n (wvUnknown, wvWin95, wvWin95OSR2, wvWin98, wvWin98SE, wvWinME,\r\n wvWinNT31, wvWinNT35, wvWinNT351, wvWinNT4, wvWin2000, wvWinXP,\r\n wvWin2003, wvWinXP64, wvWin2003R2, wvWinVista, wvWinServer2008,\r\n wvWin7, wvWinServer2008R2, wvWin8, wvWinServer2012);\r\n TWindowsEdition =\r\n (weUnknown, weWinXPHome, weWinXPPro, weWinXPHomeN, weWinXPProN, weWinXPHomeK,\r\n weWinXPProK, weWinXPHomeKN, weWinXPProKN, weWinXPStarter, weWinXPMediaCenter,\r\n weWinXPTablet, weWinVistaStarter, weWinVistaHomeBasic, weWinVistaHomeBasicN,\r\n weWinVistaHomePremium, weWinVistaBusiness, weWinVistaBusinessN,\r\n weWinVistaEnterprise, weWinVistaUltimate, weWin7Starter, weWin7HomeBasic,\r\n weWin7HomePremium, weWin7Professional, weWin7Enterprise, weWin7Ultimate,\r\n weWin8, weWin8Pro, weWin8Enterprise, weWin8Ultimate, weWin8RT);\r\n TNtProductType =\r\n (ptUnknown, ptWorkStation, ptServer, ptAdvancedServer,\r\n ptPersonal, ptProfessional, ptDatacenterServer, ptEnterprise, ptWebEdition);\r\n TProcessorArchitecture =\r\n (paUnknown, // unknown processor\r\n pax8632, // x86 32 bit processors (some P4, Celeron, Athlon and older)\r\n pax8664, // x86 64 bit processors (latest P4, Celeron and Athlon64)\r\n paIA64); // Itanium processors\r\n\r\nvar\r\n { in case of additions, don't forget to update initialization section! }\r\n IsWin95: Boolean = False;\r\n IsWin95OSR2: Boolean = False;\r\n IsWin98: Boolean = False;\r\n IsWin98SE: Boolean = False;\r\n IsWinME: Boolean = False;\r\n IsWinNT: Boolean = False;\r\n IsWinNT3: Boolean = False;\r\n IsWinNT31: Boolean = False;\r\n IsWinNT35: Boolean = False;\r\n IsWinNT351: Boolean = False;\r\n IsWinNT4: Boolean = False;\r\n IsWin2K: Boolean = False;\r\n IsWinXP: Boolean = False;\r\n IsWin2003: Boolean = False;\r\n IsWinXP64: Boolean = False;\r\n IsWin2003R2: Boolean = False;\r\n IsWinVista: Boolean = False;\r\n IsWinServer2008: Boolean = False;\r\n IsWin7: Boolean = False;\r\n IsWinServer2008R2: Boolean = False;\r\n IsWin8: Boolean = False;\r\n IsWinServer2012: Boolean = False;\r\n\r\nconst\r\n PROCESSOR_ARCHITECTURE_INTEL = 0;\r\n {$EXTERNALSYM PROCESSOR_ARCHITECTURE_INTEL}\r\n PROCESSOR_ARCHITECTURE_AMD64 = 9;\r\n {$EXTERNALSYM PROCESSOR_ARCHITECTURE_AMD64}\r\n PROCESSOR_ARCHITECTURE_IA32_ON_WIN64 = 10;\r\n {$EXTERNALSYM PROCESSOR_ARCHITECTURE_IA32_ON_WIN64}\r\n PROCESSOR_ARCHITECTURE_IA64 = 6;\r\n {$EXTERNALSYM PROCESSOR_ARCHITECTURE_IA64}\r\n\r\nfunction GetWindowsVersion: TWindowsVersion;\r\nfunction GetWindowsEdition: TWindowsEdition;\r\nfunction NtProductType: TNtProductType;\r\nfunction GetWindowsVersionString: string;\r\nfunction GetWindowsEditionString: string;\r\nfunction GetWindowsProductString: string;\r\nfunction NtProductTypeString: string;\r\nfunction GetWindowsServicePackVersion: Integer;\r\nfunction GetWindowsServicePackVersionString: string;\r\nfunction GetOpenGLVersion(const Win: THandle; out Version, Vendor: AnsiString): Boolean;\r\nfunction GetNativeSystemInfo(var SystemInfo: TSystemInfo): Boolean;\r\nfunction GetProcessorArchitecture: TProcessorArchitecture;\r\nfunction IsWindows64: Boolean;\r\n{$ENDIF MSWINDOWS}\r\n\r\nfunction GetOSVersionString: string;\r\n\r\n// Hardware\r\n{$IFDEF MSWINDOWS}\r\nfunction GetMacAddresses(const Machine: string; const Addresses: TStrings): Integer;\r\n{$ENDIF MSWINDOWS}\r\nfunction ReadTimeStampCounter: Int64;\r\n\r\ntype\r\n TTLBInformation = (tiEntries, tiAssociativity);\r\n TCacheInformation = (ciLineSize {in Bytes}, ciLinesPerTag, ciAssociativity, ciSize);\r\n\r\n TIntelSpecific = record\r\n L2Cache: Cardinal;\r\n CacheDescriptors: array [0..15] of Byte;\r\n BrandID: Byte;\r\n FlushLineSize: Byte;\r\n APICID: Byte;\r\n ExFeatures: Cardinal;\r\n Ex64Features: Cardinal;\r\n Ex64Features2: Cardinal;\r\n PowerManagementFeatures: Cardinal;\r\n PhysicalAddressBits: Byte;\r\n VirtualAddressBits: Byte;\r\n end;\r\n\r\n TCyrixSpecific = record\r\n L1CacheInfo: array [0..3] of Byte;\r\n TLBInfo: array [0..3] of Byte;\r\n end;\r\n\r\n TAMDSpecific = packed record\r\n ExFeatures: Cardinal;\r\n ExFeatures2: Cardinal;\r\n Features2: Cardinal;\r\n BrandID: Byte;\r\n FlushLineSize: Byte;\r\n APICID: Byte;\r\n ExBrandID: Word;\r\n // do not split L1 MByte TLB\r\n L1MByteInstructionTLB: array [TTLBInformation] of Byte;\r\n L1MByteDataTLB: array [TTLBInformation] of Byte;\r\n // do not split L1 KByte TLB\r\n L1KByteInstructionTLB: array [TTLBInformation] of Byte;\r\n L1KByteDataTLB: array [TTLBInformation] of Byte;\r\n L1DataCache: array [TCacheInformation] of Byte;\r\n L1InstructionCache: array [TCacheInformation] of Byte;\r\n // do not split L2 MByte TLB\r\n L2MByteInstructionTLB: array [TTLBInformation] of Byte; // L2 TLB for 2-MByte and 4-MByte pages\r\n L2MByteDataTLB: array [TTLBInformation] of Byte; // L2 TLB for 2-MByte and 4-MByte pages\r\n // do not split L2 KByte TLB\r\n L2KByteDataTLB: array [TTLBInformation] of Byte; // L2 TLB for 4-KByte pages\r\n L2KByteInstructionTLB: array [TTLBInformation] of Byte; // L2 TLB for 4-KByte pages\r\n L2Cache: Cardinal;\r\n L3Cache: Cardinal;\r\n AdvancedPowerManagement: Cardinal;\r\n PhysicalAddressSize: Byte;\r\n VirtualAddressSize: Byte;\r\n end;\r\n\r\n TVIASpecific = record\r\n ExFeatures: Cardinal;\r\n DataTLB: array [TTLBInformation] of Byte;\r\n InstructionTLB: array [TTLBInformation] of Byte;\r\n L1DataCache: array [TCacheInformation] of Byte;\r\n L1InstructionCache: array [TCacheInformation] of Byte;\r\n L2DataCache: Cardinal;\r\n end;\r\n\r\n TTransmetaSpecific = record\r\n ExFeatures: Cardinal;\r\n DataTLB: array [TTLBInformation] of Byte;\r\n CodeTLB: array [TTLBInformation] of Byte;\r\n L1DataCache: array [TCacheInformation] of Byte;\r\n L1CodeCache: array [TCacheInformation] of Byte;\r\n L2Cache: Cardinal;\r\n RevisionABCD: Cardinal;\r\n RevisionXXXX: Cardinal;\r\n Frequency: Cardinal;\r\n CodeMorphingABCD: Cardinal;\r\n CodeMorphingXXXX: Cardinal;\r\n TransmetaFeatures: Cardinal;\r\n TransmetaInformations: array [0..64] of Char;\r\n CurrentVoltage: Cardinal;\r\n CurrentFrequency: Cardinal;\r\n CurrentPerformance: Cardinal;\r\n end;\r\n\r\n TCacheFamily = (\r\n cfInstructionTLB, cfDataTLB,\r\n cfL1InstructionCache, cfL1DataCache,\r\n cfL2Cache, cfL2TLB, cfL3Cache, cfTrace, cfOther);\r\n\r\n TCacheInfo = record\r\n D: Byte;\r\n Family: TCacheFamily;\r\n Size: Cardinal;\r\n WaysOfAssoc: Byte;\r\n LineSize: Byte; // for Normal Cache\r\n LinePerSector: Byte; // for L3 Normal Cache\r\n Entries: Cardinal; // for TLB\r\n I: PResStringRec;\r\n end;\r\n\r\n TFreqInfo = record\r\n RawFreq: Int64;\r\n NormFreq: Int64;\r\n InCycles: Int64;\r\n ExTicks: Int64;\r\n end;\r\n\r\nconst\r\n CPU_TYPE_INTEL = 1;\r\n CPU_TYPE_CYRIX = 2;\r\n CPU_TYPE_AMD = 3;\r\n CPU_TYPE_TRANSMETA = 4;\r\n CPU_TYPE_VIA = 5;\r\n\r\ntype\r\n TSSESupport = (sse, sse2, sse3, ssse3, sse41, sse42, sse4A, sse5, avx);\r\n TSSESupports = set of TSSESupport;\r\n\r\n TCpuInfo = record\r\n HasInstruction: Boolean;\r\n AES: Boolean;\r\n MMX: Boolean;\r\n ExMMX: Boolean;\r\n _3DNow: Boolean;\r\n Ex3DNow: Boolean;\r\n SSE: TSSESupports;\r\n IsFDIVOK: Boolean;\r\n Is64Bits: Boolean;\r\n DEPCapable: Boolean;\r\n HasCacheInfo: Boolean;\r\n HasExtendedInfo: Boolean;\r\n PType: Byte;\r\n Family: Byte;\r\n ExtendedFamily: Byte;\r\n Model: Byte;\r\n ExtendedModel: Byte;\r\n Stepping: Byte;\r\n Features: Cardinal;\r\n FrequencyInfo: TFreqInfo;\r\n VendorIDString: array [0..11] of AnsiChar;\r\n Manufacturer: array [0..9] of AnsiChar;\r\n CpuName: array [0..47] of AnsiChar;\r\n L1DataCacheSize: Cardinal; // in kByte\r\n L1DataCacheLineSize: Byte; // in Byte\r\n L1DataCacheAssociativity: Byte;\r\n L1InstructionCacheSize: Cardinal; // in kByte\r\n L1InstructionCacheLineSize: Byte; // in Byte\r\n L1InstructionCacheAssociativity: Byte;\r\n L2CacheSize: Cardinal; // in kByte\r\n L2CacheLineSize: Byte; // in Byte\r\n L2CacheAssociativity: Byte;\r\n L3CacheSize: Cardinal; // in kByte\r\n L3CacheLineSize: Byte; // in Byte\r\n L3CacheAssociativity: Byte;\r\n L3LinesPerSector: Byte;\r\n LogicalCore: Byte;\r\n PhysicalCore: Byte;\r\n HyperThreadingTechnology: Boolean;\r\n HardwareHyperThreadingTechnology: Boolean;\r\n // todo: TLB\r\n case CpuType: Byte of\r\n CPU_TYPE_INTEL: (IntelSpecific: TIntelSpecific;);\r\n CPU_TYPE_CYRIX: (CyrixSpecific: TCyrixSpecific;);\r\n CPU_TYPE_AMD: (AMDSpecific: TAMDSpecific;);\r\n CPU_TYPE_TRANSMETA: (TransmetaSpecific: TTransmetaSpecific;);\r\n CPU_TYPE_VIA: (ViaSpecific: TViaSpecific;);\r\n end;\r\n\r\nconst\r\n VendorIDIntel: array [0..11] of AnsiChar = 'GenuineIntel';\r\n VendorIDCyrix: array [0..11] of AnsiChar = 'CyrixInstead';\r\n VendorIDAMD: array [0..11] of AnsiChar = 'AuthenticAMD';\r\n VendorIDTransmeta: array [0..11] of AnsiChar = 'GenuineTMx86';\r\n VendorIDVIA: array [0..11] of AnsiChar = 'CentaurHauls';\r\n\r\n// Constants to be used with Feature Flag set of a CPU\r\n// eg. IF (Features and FPU_FLAG = FPU_FLAG) THEN CPU has Floating-Point unit on\r\n// chip. However, Intel claims that in future models, a zero in the feature\r\n// flags will mean that the chip has that feature, however, the following flags\r\n// will work for any production 80x86 chip or clone.\r\n// eg. IF (Features and FPU_FLAG = 0) then CPU has Floating-Point unit on chip.\r\n\r\nconst\r\n { 32 bits in a DWord Value }\r\n BIT_0 = $00000001;\r\n BIT_1 = $00000002;\r\n BIT_2 = $00000004;\r\n BIT_3 = $00000008;\r\n BIT_4 = $00000010;\r\n BIT_5 = $00000020;\r\n BIT_6 = $00000040;\r\n BIT_7 = $00000080;\r\n BIT_8 = $00000100;\r\n BIT_9 = $00000200;\r\n BIT_10 = $00000400;\r\n BIT_11 = $00000800;\r\n BIT_12 = $00001000;\r\n BIT_13 = $00002000;\r\n BIT_14 = $00004000;\r\n BIT_15 = $00008000;\r\n BIT_16 = $00010000;\r\n BIT_17 = $00020000;\r\n BIT_18 = $00040000;\r\n BIT_19 = $00080000;\r\n BIT_20 = $00100000;\r\n BIT_21 = $00200000;\r\n BIT_22 = $00400000;\r\n BIT_23 = $00800000;\r\n BIT_24 = $01000000;\r\n BIT_25 = $02000000;\r\n BIT_26 = $04000000;\r\n BIT_27 = $08000000;\r\n BIT_28 = $10000000;\r\n BIT_29 = $20000000;\r\n BIT_30 = $40000000;\r\n BIT_31 = DWORD($80000000);\r\n\r\n { Standard Feature Flags }\r\n FPU_FLAG = BIT_0; // Floating-Point unit on chip\r\n VME_FLAG = BIT_1; // Virtual Mode Extention\r\n DE_FLAG = BIT_2; // Debugging Extention\r\n PSE_FLAG = BIT_3; // Page Size Extention\r\n TSC_FLAG = BIT_4; // Time Stamp Counter\r\n MSR_FLAG = BIT_5; // Model Specific Registers\r\n PAE_FLAG = BIT_6; // Physical Address Extention\r\n MCE_FLAG = BIT_7; // Machine Check Exception\r\n CX8_FLAG = BIT_8; // CMPXCHG8 Instruction\r\n APIC_FLAG = BIT_9; // Software-accessible local APIC on Chip\r\n BIT_10_FLAG = BIT_10; // Reserved, do not count on value\r\n SEP_FLAG = BIT_11; // Fast System Call\r\n MTRR_FLAG = BIT_12; // Memory Type Range Registers\r\n PGE_FLAG = BIT_13; // Page Global Enable\r\n MCA_FLAG = BIT_14; // Machine Check Architecture\r\n CMOV_FLAG = BIT_15; // Conditional Move Instruction\r\n PAT_FLAG = BIT_16; // Page Attribute Table\r\n PSE36_FLAG = BIT_17; // 36-bit Page Size Extention\r\n PSN_FLAG = BIT_18; // Processor serial number is present and enabled\r\n CLFLSH_FLAG = BIT_19; // CLFLUSH intruction\r\n BIT_20_FLAG = BIT_20; // Reserved, do not count on value\r\n DS_FLAG = BIT_21; // Debug store\r\n ACPI_FLAG = BIT_22; // Thermal monitor and clock control\r\n MMX_FLAG = BIT_23; // MMX technology\r\n FXSR_FLAG = BIT_24; // Fast Floating Point Save and Restore\r\n SSE_FLAG = BIT_25; // Streaming SIMD Extensions\r\n SSE2_FLAG = BIT_26; // Streaming SIMD Extensions 2\r\n SS_FLAG = BIT_27; // Self snoop\r\n HTT_FLAG = BIT_28; // Hyper-threading technology\r\n TM_FLAG = BIT_29; // Thermal monitor\r\n BIT_30_FLAG = BIT_30; // Reserved, do not count on value\r\n PBE_FLAG = BIT_31; // Pending Break Enable\r\n\r\n { Standard Intel Feature Flags }\r\n INTEL_FPU = BIT_0; // Floating-Point unit on chip\r\n INTEL_VME = BIT_1; // Virtual Mode Extention\r\n INTEL_DE = BIT_2; // Debugging Extention\r\n INTEL_PSE = BIT_3; // Page Size Extention\r\n INTEL_TSC = BIT_4; // Time Stamp Counter\r\n INTEL_MSR = BIT_5; // Model Specific Registers\r\n INTEL_PAE = BIT_6; // Physical Address Extention\r\n INTEL_MCE = BIT_7; // Machine Check Exception\r\n INTEL_CX8 = BIT_8; // CMPXCHG8 Instruction\r\n INTEL_APIC = BIT_9; // Software-accessible local APIC on Chip\r\n INTEL_BIT_10 = BIT_10; // Reserved, do not count on value\r\n INTEL_SEP = BIT_11; // Fast System Call\r\n INTEL_MTRR = BIT_12; // Memory Type Range Registers\r\n INTEL_PGE = BIT_13; // Page Global Enable\r\n INTEL_MCA = BIT_14; // Machine Check Architecture\r\n INTEL_CMOV = BIT_15; // Conditional Move Instruction\r\n INTEL_PAT = BIT_16; // Page Attribute Table\r\n INTEL_PSE36 = BIT_17; // 36-bit Page Size Extention\r\n INTEL_PSN = BIT_18; // Processor serial number is present and enabled\r\n INTEL_CLFLSH = BIT_19; // CLFLUSH intruction\r\n INTEL_BIT_20 = BIT_20; // Reserved, do not count on value\r\n INTEL_DS = BIT_21; // Debug store\r\n INTEL_ACPI = BIT_22; // Thermal monitor and clock control\r\n INTEL_MMX = BIT_23; // MMX technology\r\n INTEL_FXSR = BIT_24; // Fast Floating Point Save and Restore\r\n INTEL_SSE = BIT_25; // Streaming SIMD Extensions\r\n INTEL_SSE2 = BIT_26; // Streaming SIMD Extensions 2\r\n INTEL_SS = BIT_27; // Self snoop\r\n INTEL_HTT = BIT_28; // Hyper-threading technology\r\n INTEL_TM = BIT_29; // Thermal monitor\r\n INTEL_IA64 = BIT_30; // IA32 emulation mode on Itanium processors (IA64)\r\n INTEL_PBE = BIT_31; // Pending Break Enable\r\n\r\n { Extended Intel Feature Flags }\r\n EINTEL_SSE3 = BIT_0; // Streaming SIMD Extensions 3\r\n EINTEL_PCLMULQDQ = BIT_1; // the processor supports the PCLMULQDQ instruction\r\n EINTEL_DTES64 = BIT_2; // the processor supports DS area using 64-bit layout\r\n EINTEL_MONITOR = BIT_3; // Monitor/MWAIT\r\n EINTEL_DSCPL = BIT_4; // CPL Qualified debug Store\r\n EINTEL_VMX = BIT_5; // Virtual Machine Technology\r\n EINTEL_SMX = BIT_6; // Safer Mode Extensions\r\n EINTEL_EST = BIT_7; // Enhanced Intel Speedstep technology\r\n EINTEL_TM2 = BIT_8; // Thermal monitor 2\r\n EINTEL_SSSE3 = BIT_9; // SSSE 3 extensions\r\n EINTEL_CNXTID = BIT_10; // L1 Context ID\r\n EINTEL_BIT_11 = BIT_11; // Reserved, do not count on value\r\n EINTEL_FMA = BIT_12; // Fused Multiply Add\r\n EINTEL_CX16 = BIT_13; // CMPXCHG16B instruction\r\n EINTEL_XTPR = BIT_14; // Send Task Priority messages\r\n EINTEL_PDCM = BIT_15; // Perf/Debug Capability MSR\r\n EINTEL_BIT_16 = BIT_16; // Reserved, do not count on value\r\n EINTEL_PCID = BIT_17; // Process-context Identifiers\r\n EINTEL_DCA = BIT_18; // Direct Cache Access\r\n EINTEL_SSE4_1 = BIT_19; // Streaming SIMD Extensions 4.1\r\n EINTEL_SSE4_2 = BIT_20; // Streaming SIMD Extensions 4.2\r\n EINTEL_X2APIC = BIT_21; // x2APIC feature\r\n EINTEL_MOVBE = BIT_22; // MOVBE instruction\r\n EINTEL_POPCNT = BIT_23; // A value of 1 indicates the processor supports the POPCNT instruction.\r\n EINTEL_TSC_DL = BIT_24; // TSC-Deadline\r\n EINTEL_AES = BIT_25; // the processor supports the AES instruction extensions\r\n EINTEL_XSAVE = BIT_26; // XSAVE/XRSTOR processor extended states feature, XSETBV/XGETBV instructions and XFEATURE_ENABLED_MASK (XCR0) register\r\n EINTEL_OSXSAVE = BIT_27; // OS has enabled features present in EINTEL_XSAVE\r\n EINTEL_AVX = BIT_28; // Advanced Vector Extensions\r\n EINTEL_BIT_29 = BIT_29; // Reserved, do not count on value\r\n EINTEL_RDRAND = BIT_30; // the processor supports the RDRAND instruction.\r\n EINTEL_BIT_31 = BIT_31; // Always return 0\r\n\r\n { Extended Intel 64 Bits Feature Flags }\r\n EINTEL64_BIT_0 = BIT_0; // Reserved, do not count on value\r\n EINTEL64_BIT_1 = BIT_1; // Reserved, do not count on value\r\n EINTEL64_BIT_2 = BIT_2; // Reserved, do not count on value\r\n EINTEL64_BIT_3 = BIT_3; // Reserved, do not count on value\r\n EINTEL64_BIT_4 = BIT_4; // Reserved, do not count on value\r\n EINTEL64_BIT_5 = BIT_5; // Reserved, do not count on value\r\n EINTEL64_BIT_6 = BIT_6; // Reserved, do not count on value\r\n EINTEL64_BIT_7 = BIT_7; // Reserved, do not count on value\r\n EINTEL64_BIT_8 = BIT_8; // Reserved, do not count on value\r\n EINTEL64_BIT_9 = BIT_9; // Reserved, do not count on value\r\n EINTEL64_BIT_10 = BIT_10; // Reserved, do not count on value\r\n EINTEL64_SYS = BIT_11; // 64 Bit - SYSCALL SYSRET\r\n EINTEL64_BIT_12 = BIT_12; // Reserved, do not count on value\r\n EINTEL64_BIT_13 = BIT_13; // Reserved, do not count on value\r\n EINTEL64_BIT_14 = BIT_14; // Reserved, do not count on value\r\n EINTEL64_BIT_15 = BIT_15; // Reserved, do not count on value\r\n EINTEL64_BIT_16 = BIT_16; // Reserved, do not count on value\r\n EINTEL64_BIT_17 = BIT_17; // Reserved, do not count on value\r\n EINTEL64_BIT_18 = BIT_18; // Reserved, do not count on value\r\n EINTEL64_BIT_19 = BIT_19; // Reserved, do not count on value\r\n EINTEL64_XD = BIT_20; // Execution Disable Bit\r\n EINTEL64_BIT_21 = BIT_21; // Reserved, do not count on value\r\n EINTEL64_BIT_22 = BIT_22; // Reserved, do not count on value\r\n EINTEL64_BIT_23 = BIT_23; // Reserved, do not count on value\r\n EINTEL64_BIT_24 = BIT_24; // Reserved, do not count on value\r\n EINTEL64_BIT_25 = BIT_25; // Reserved, do not count on value\r\n EINTEL64_1GBYTE = BIT_26; // 1G-Byte pages are available\r\n EINTEL64_RDTSCP = BIT_27; // RDTSCP and IA32_TSC_AUX are available\r\n EINTEL64_BIT_28 = BIT_28; // Reserved, do not count on value\r\n EINTEL64_EM64T = BIT_29; // Intel Extended Memory 64 Technology\r\n EINTEL64_BIT_30 = BIT_30; // Reserved, do not count on value\r\n EINTEL64_BIT_31 = BIT_31; // Reserved, do not count on value\r\n\r\n { Extended Intel 64 Bits Feature Flags continued }\r\n EINTEL64_2_LAHF = BIT_0; // LAHF/SAHF available in 64 bit mode\r\n EINTEL64_2_BIT_1 = BIT_1; // Reserved, do not count on value\r\n EINTEL64_2_BIT_2 = BIT_2; // Reserved, do not count on value\r\n EINTEL64_2_BIT_3 = BIT_3; // Reserved, do not count on value\r\n EINTEL64_2_BIT_4 = BIT_4; // Reserved, do not count on value\r\n EINTEL64_2_BIT_5 = BIT_5; // Reserved, do not count on value\r\n EINTEL64_2_BIT_6 = BIT_6; // Reserved, do not count on value\r\n EINTEL64_2_BIT_7 = BIT_7; // Reserved, do not count on value\r\n EINTEL64_2_BIT_8 = BIT_8; // Reserved, do not count on value\r\n EINTEL64_2_BIT_9 = BIT_9; // Reserved, do not count on value\r\n EINTEL64_2_BIT_10 = BIT_10; // Reserved, do not count on value\r\n EINTEL64_2_BIT_11 = BIT_11; // Reserved, do not count on value\r\n EINTEL64_2_BIT_12 = BIT_12; // Reserved, do not count on value\r\n EINTEL64_2_BIT_13 = BIT_13; // Reserved, do not count on value\r\n EINTEL64_2_BIT_14 = BIT_14; // Reserved, do not count on value\r\n EINTEL64_2_BIT_15 = BIT_15; // Reserved, do not count on value\r\n EINTEL64_2_BIT_16 = BIT_16; // Reserved, do not count on value\r\n EINTEL64_2_BIT_17 = BIT_17; // Reserved, do not count on value\r\n EINTEL64_2_BIT_18 = BIT_18; // Reserved, do not count on value\r\n EINTEL64_2_BIT_19 = BIT_19; // Reserved, do not count on value\r\n EINTEL64_2_BIT_20 = BIT_20; // Reserved, do not count on value\r\n EINTEL64_2_BIT_21 = BIT_21; // Reserved, do not count on value\r\n EINTEL64_2_BIT_22 = BIT_22; // Reserved, do not count on value\r\n EINTEL64_2_BIT_23 = BIT_23; // Reserved, do not count on value\r\n EINTEL64_2_BIT_24 = BIT_24; // Reserved, do not count on value\r\n EINTEL64_2_BIT_25 = BIT_25; // Reserved, do not count on value\r\n EINTEL64_2_BIT_26 = BIT_26; // Reserved, do not count on value\r\n EINTEL64_2_BIT_27 = BIT_27; // Reserved, do not count on value\r\n EINTEL64_2_BIT_28 = BIT_28; // Reserved, do not count on value\r\n EINTEL64_2_BIT_29 = BIT_29; // Reserved, do not count on value\r\n EINTEL64_2_BIT_30 = BIT_30; // Reserved, do not count on value\r\n EINTEL64_2_BIT_31 = BIT_31; // Reserved, do not count on value\r\n\r\n { INTEL Power Management Flags }\r\n PINTEL_TEMPSENSOR = BIT_0; // Digital temperature sensor\r\n PINTEL_TURBOBOOST = BIT_1; // Intel Turbo Boost Technology Available\r\n PINTEL_ARAT = BIT_2; // APIC-Timer-always-running feature\r\n PINTEL_BIT_3 = BIT_3; // Reverved, do not count on value\r\n PINTEL_PLN = BIT_4; // Power Limit Notification constrols\r\n PINTEL_ECMD = BIT_5; // Clock Modulation duty cycle extension\r\n PINTEL_PTM = BIT_6; // Package Thermal Management\r\n PINTEL_BIT_7 = BIT_7; // Reserved, do not count on value\r\n PINTEL_BIT_8 = BIT_8; // Reserved, do not count on value\r\n PINTEL_BIT_9 = BIT_9; // Reserved, do not count on value\r\n PINTEL_BIT_10 = BIT_10; // Reserved, do not count on value\r\n PINTEL_BIT_11 = BIT_11; // Reserved, do not count on value\r\n PINTEL_BIT_12 = BIT_12; // Reserved, do not count on value\r\n PINTEL_BIT_13 = BIT_13; // Reserved, do not count on value\r\n PINTEL_BIT_14 = BIT_14; // Reserved, do not count on value\r\n PINTEL_BIT_15 = BIT_15; // Reserved, do not count on value\r\n PINTEL_BIT_16 = BIT_16; // Reserved, do not count on value\r\n PINTEL_BIT_17 = BIT_17; // Reserved, do not count on value\r\n PINTEL_BIT_18 = BIT_18; // Reserved, do not count on value\r\n PINTEL_BIT_19 = BIT_19; // Reserved, do not count on value\r\n PINTEL_BIT_20 = BIT_20; // Reserved, do not count on value\r\n PINTEL_BIT_21 = BIT_21; // Reserved, do not count on value\r\n PINTEL_BIT_22 = BIT_22; // Reserved, do not count on value\r\n PINTEL_BIT_23 = BIT_23; // Reserved, do not count on value\r\n PINTEL_BIT_24 = BIT_24; // Reserved, do not count on value\r\n PINTEL_BIT_25 = BIT_25; // Reserved, do not count on value\r\n PINTEL_BIT_26 = BIT_26; // Reserved, do not count on value\r\n PINTEL_BIT_27 = BIT_27; // Reserved, do not count on value\r\n PINTEL_BIT_28 = BIT_28; // Reserved, do not count on value\r\n PINTEL_BIT_29 = BIT_29; // Reserved, do not count on value\r\n PINTEL_BIT_30 = BIT_30; // Reserved, do not count on value\r\n PINTEL_BIT_31 = BIT_31; // Reserved, do not count on value\r\n\r\n { AMD Standard Feature Flags }\r\n AMD_FPU = BIT_0; // Floating-Point unit on chip\r\n AMD_VME = BIT_1; // Virtual Mode Extention\r\n AMD_DE = BIT_2; // Debugging Extention\r\n AMD_PSE = BIT_3; // Page Size Extention\r\n AMD_TSC = BIT_4; // Time Stamp Counter\r\n AMD_MSR = BIT_5; // Model Specific Registers\r\n AMD_PAE = BIT_6; // Physical address Extensions\r\n AMD_MCE = BIT_7; // Machine Check Exception\r\n AMD_CX8 = BIT_8; // CMPXCHG8 Instruction\r\n AMD_APIC = BIT_9; // Software-accessible local APIC on Chip\r\n AMD_BIT_10 = BIT_10; // Reserved, do not count on value\r\n AMD_SEP_BIT = BIT_11; // SYSENTER and SYSEXIT instructions\r\n AMD_MTRR = BIT_12; // Memory Type Range Registers\r\n AMD_PGE = BIT_13; // Page Global Enable\r\n AMD_MCA = BIT_14; // Machine Check Architecture\r\n AMD_CMOV = BIT_15; // Conditional Move Instruction\r\n AMD_PAT = BIT_16; // Page Attribute Table\r\n AMD_PSE36 = BIT_17; // Page Size Extensions\r\n AMD_BIT_18 = BIT_18; // Reserved, do not count on value\r\n AMD_CLFLSH = BIT_19; // CLFLUSH instruction\r\n AMD_BIT_20 = BIT_20; // Reserved, do not count on value\r\n AMD_BIT_21 = BIT_21; // Reserved, do not count on value\r\n AMD_BIT_22 = BIT_22; // Reserved, do not count on value\r\n AMD_MMX = BIT_23; // MMX technology\r\n AMD_FXSR = BIT_24; // FXSAVE and FXSTORE instructions\r\n AMD_SSE = BIT_25; // SSE Extensions\r\n AMD_SSE2 = BIT_26; // SSE2 Extensions\r\n AMD_BIT_27 = BIT_27; // Reserved, do not count on value\r\n AMD_HTT = BIT_28; // Hyper-Threading Technology\r\n AMD_BIT_29 = BIT_29; // Reserved, do not count on value\r\n AMD_BIT_30 = BIT_30; // Reserved, do not count on value\r\n AMD_BIT_31 = BIT_31; // Reserved, do not count on value\r\n\r\n { AMD Standard Feature Flags continued }\r\n AMD2_SSE3 = BIT_0; // SSE3 extensions\r\n AMD2_PCLMULQDQ = BIT_1; // PCLMULQDQ instruction support\r\n AMD2_BIT_2 = BIT_2; // Reserved, do not count on value\r\n AMD2_MONITOR = BIT_3; // MONITOR/MWAIT instructions. See \"MONITOR\" and \"MWAIT\" in APM3.\r\n AMD2_BIT_4 = BIT_4; // Reserved, do not count on value\r\n AMD2_BIT_5 = BIT_5; // Reserved, do not count on value\r\n AMD2_BIT_6 = BIT_6; // Reserved, do not count on value\r\n AMD2_BIT_7 = BIT_7; // Reserved, do not count on value\r\n AMD2_BIT_8 = BIT_8; // Reserved, do not count on value\r\n AMD2_SSSE3 = BIT_9; // supplemental SSE3 extensions\r\n AMD2_BIT_10 = BIT_10; // Reserved, do not count on value\r\n AMD2_BIT_11 = BIT_11; // Reserved, do not count on value\r\n AMD2_FMA = BIT_12; // FMA instruction support\r\n AMD2_CMPXCHG16B = BIT_13; // CMPXCHG16B available\r\n AMD2_BIT_14 = BIT_14; // Reserved, do not count on value\r\n AMD2_BIT_15 = BIT_15; // Reserved, do not count on value\r\n AMD2_BIT_16 = BIT_16; // Reserved, do not count on value\r\n AMD2_BIT_17 = BIT_17; // Reserved, do not count on value\r\n AMD2_BIT_18 = BIT_18; // Reserved, do not count on value\r\n AMD2_SSE41 = BIT_19; // SSE4.1 instruction support\r\n AMD2_SSE42 = BIT_20; // SSE4.2 instruction support\r\n AMD2_BIT_21 = BIT_21; // Reserved, do not count on value\r\n AMD2_BIT_22 = BIT_22; // Reserved, do not count on value\r\n AMD2_POPCNT = BIT_23; // POPCNT instruction. See \"POPCNT\" in APM3.\r\n AMD2_BIT_24 = BIT_24; // Reserved, do not count on value\r\n AMD2_AES = BIT_25; // AES instruction support\r\n AMD2_XSAVE = BIT_26; // XSAVE (and related) instructions are supported by hardware\r\n AMD2_OSXSAVE = BIT_27; // XSAVE (and related) instructions are enabled\r\n AMD2_AVX = BIT_28; // AVX instruction support\r\n AMD2_F16C = BIT_29; // half-precision convert instruction support\r\n AMD2_BIT_30 = BIT_30; // Reserved, do not count on value\r\n AMD2_RAZ = BIT_31; // Reserved for use by hypervisor to indicate guest status\r\n\r\n { AMD Enhanced Feature Flags }\r\n EAMD_FPU = BIT_0; // Floating-Point unit on chip\r\n EAMD_VME = BIT_1; // Virtual Mode Extention\r\n EAMD_DE = BIT_2; // Debugging Extention\r\n EAMD_PSE = BIT_3; // Page Size Extention\r\n EAMD_TSC = BIT_4; // Time Stamp Counter\r\n EAMD_MSR = BIT_5; // Model Specific Registers\r\n EAMD_PAE = BIT_6; // Physical-address extensions\r\n EAMD_MCE = BIT_7; // Machine Check Exception\r\n EAMD_CX8 = BIT_8; // CMPXCHG8 Instruction\r\n EAMD_APIC = BIT_9; // Advanced Programmable Interrupt Controler\r\n EAMD_BIT_10 = BIT_10; // Reserved, do not count on value\r\n EAMD_SEP = BIT_11; // Fast System Call\r\n EAMD_MTRR = BIT_12; // Memory-Type Range Registers\r\n EAMD_PGE = BIT_13; // Page Global Enable\r\n EAMD_MCA = BIT_14; // Machine Check Architecture\r\n EAMD_CMOV = BIT_15; // Conditional Move Intructions\r\n EAMD_PAT = BIT_16; // Page Attributes Table\r\n EAMD_PSE2 = BIT_17; // Page Size Extensions\r\n EAMD_BIT_18 = BIT_18; // Reserved, do not count on value\r\n EAMD_BIT_19 = BIT_19; // Reserved, do not count on value\r\n EAMD_NX = BIT_20; // No-Execute Page Protection\r\n EAMD_BIT_21 = BIT_21; // Reserved, do not count on value\r\n EAMD_EXMMX = BIT_22; // AMD Extensions to MMX technology\r\n EAMD_MMX = BIT_23; // MMX technology\r\n EAMD_FX = BIT_24; // FXSAVE and FXSTORE instructions\r\n EAMD_FFX = BIT_25; // Fast FXSAVE and FXSTORE instructions\r\n EAMD_1GBPAGE = BIT_26; // 1-GB large page support.\r\n EAMD_RDTSCP = BIT_27; // RDTSCP instruction.\r\n EAMD_BIT_28 = BIT_28; // Reserved, do not count on value\r\n EAMD_LONG = BIT_29; // Long Mode (64-bit Core)\r\n EAMD_EX3DNOW = BIT_30; // AMD Extensions to 3DNow! intructions\r\n EAMD_3DNOW = BIT_31; // AMD 3DNOW! Technology\r\n\r\n { AMD Extended Feature Flags continued }\r\n EAMD2_LAHF = BIT_0; // LAHF/SAHF available in 64-bit mode\r\n EAMD2_CMPLEGACY = BIT_1; // core multi-processing legacy mode\r\n EAMD2_SVM = BIT_2; // Secure Virtual Machine\r\n EAMD2_EXTAPICSPACE = BIT_3; // This bit indicates the presence of extended APIC register space starting at offset 400h from the APIC Base Address Register, as specified in the BKDG.\r\n EAMD2_ALTMOVCR8 = BIT_4; // LOCK MOV CR0 means MOV CR8\r\n EAMD2_ABM = BIT_5; // ABM: Advanced bit manipulation. LZCNT instruction support.\r\n EAMD2_SSE4A = BIT_6; // EXTRQ, INSERTQ, MOVNTSS, and MOVNTSD instruction support.\r\n EAMD2_MISALIGNSSE = BIT_7; // Misaligned SSE mode.\r\n EAMD2_3DNOWPREFETCH = BIT_8; // PREFETCH and PREFETCHW instruction support.\r\n EAMD2_OSVW = BIT_9; // OS visible workaround.\r\n EAMD2_IBS = BIT_10; // Instruction based sampling\r\n EAMD2_XOP = BIT_11; // extended operation support\r\n EAMD2_SKINIT = BIT_12; // SKINIT, STGI, and DEV support.\r\n EAMD2_WDT = BIT_13; // Watchdog timer support.\r\n EAMD2_BIT_14 = BIT_14; // Reserved, do not count on value\r\n EAMD2_LWP = BIT_15; // lightweight profiling support\r\n EAMD2_FMA4 = BIT_16; // 4-operand FMA instruction support.\r\n EAMD2_BIT_17 = BIT_17; // Reserved, do not count on value\r\n EAMD2_BIT_18 = BIT_18; // Reserved, do not count on value\r\n EAMD2_NODEID = BIT_19; // Support for MSRC001_100C[NodeId, NodesPerProcessor]\r\n EAMD2_BIT_20 = BIT_20; // Reserved, do not count on value\r\n EAMD2_TBM = BIT_21; // trailing bit manipulation instruction support\r\n EAMD2_TOPOLOGYEXT = BIT_22; // topology extensions support\r\n EAMD2_BIT_23 = BIT_23; // Reserved, do not count on value\r\n EAMD2_BIT_24 = BIT_24; // Reserved, do not count on value\r\n EAMD2_BIT_25 = BIT_25; // Reserved, do not count on value\r\n EAMD2_BIT_26 = BIT_26; // Reserved, do not count on value\r\n EAMD2_BIT_27 = BIT_27; // Reserved, do not count on value\r\n EAMD2_BIT_28 = BIT_28; // Reserved, do not count on value\r\n EAMD2_BIT_29 = BIT_29; // Reserved, do not count on value\r\n EAMD2_BIT_30 = BIT_30; // Reserved, do not count on value\r\n EAMD2_BIT_31 = BIT_31; // Reserved, do not count on value\r\n\r\n { AMD Power Management Features Flags }\r\n PAMD_TEMPSENSOR = BIT_0; // Temperature Sensor\r\n PAMD_FREQUENCYID = BIT_1; // Frequency ID Control\r\n PAMD_VOLTAGEID = BIT_2; // Voltage ID Control\r\n PAMD_THERMALTRIP = BIT_3; // Thermal Trip\r\n PAMD_THERMALMONITOR = BIT_4; // Thermal Monitoring\r\n PAMD_BIT_5 = BIT_5; // Reserved, do not count on value\r\n PAMD_100MHZSTEP = BIT_6; // 100 Mhz multiplier control.\r\n PAMD_HWPSTATE = BIT_7; // Hardware P-State control.\r\n PAMD_TSC_INVARIANT = BIT_8; // TSC rate is invariant\r\n PAMD_CPB = BIT_9; // core performance boost\r\n PAMD_EFFFREQRO = BIT_10; // read-only effective frequency interface\r\n PAMD_BIT_11 = BIT_11; // Reserved, do not count on value\r\n PAMD_BIT_12 = BIT_12; // Reserved, do not count on value\r\n PAMD_BIT_13 = BIT_13; // Reserved, do not count on value\r\n PAMD_BIT_14 = BIT_14; // Reserved, do not count on value\r\n PAMD_BIT_15 = BIT_15; // Reserved, do not count on value\r\n PAMD_BIT_16 = BIT_16; // Reserved, do not count on value\r\n PAMD_BIT_17 = BIT_17; // Reserved, do not count on value\r\n PAMD_BIT_18 = BIT_18; // Reserved, do not count on value\r\n PAMD_BIT_19 = BIT_19; // Reserved, do not count on value\r\n PAMD_BIT_20 = BIT_20; // Reserved, do not count on value\r\n PAMD_BIT_21 = BIT_21; // Reserved, do not count on value\r\n PAMD_BIT_22 = BIT_22; // Reserved, do not count on value\r\n PAMD_BIT_23 = BIT_23; // Reserved, do not count on value\r\n PAMD_BIT_24 = BIT_24; // Reserved, do not count on value\r\n PAMD_BIT_25 = BIT_25; // Reserved, do not count on value\r\n PAMD_BIT_26 = BIT_26; // Reserved, do not count on value\r\n PAMD_BIT_27 = BIT_27; // Reserved, do not count on value\r\n PAMD_BIT_28 = BIT_28; // Reserved, do not count on value\r\n PAMD_BIT_29 = BIT_29; // Reserved, do not count on value\r\n PAMD_BIT_30 = BIT_30; // Reserved, do not count on value\r\n PAMD_BIT_31 = BIT_31; // Reserved, do not count on value\r\n\r\n { AMD TLB and L1 Associativity constants }\r\n AMD_ASSOC_RESERVED = 0;\r\n AMD_ASSOC_DIRECT = 1;\r\n // 2 to 254 = direct value to the associativity\r\n AMD_ASSOC_FULLY = 255;\r\n\r\n { AMD L2 Cache Associativity constants }\r\n AMD_L2_ASSOC_DISABLED = 0;\r\n AMD_L2_ASSOC_DIRECT = 1;\r\n AMD_L2_ASSOC_2WAY = 2;\r\n AMD_L2_ASSOC_4WAY = 4;\r\n AMD_L2_ASSOC_8WAY = 6;\r\n AMD_L2_ASSOC_16WAY = 8;\r\n AMD_L2_ASSOC_32WAY = 10;\r\n AMD_L2_ASSOC_48WAY = 11;\r\n AMD_L2_ASSOC_64WAY = 12;\r\n AMD_L2_ASSOC_96WAY = 13;\r\n AMD_L2_ASSOC_128WAY = 14;\r\n AMD_L2_ASSOC_FULLY = 15;\r\n\r\n // TODO AMD SVM and LWP bits\r\n\r\n { VIA Standard Feature Flags }\r\n VIA_FPU = BIT_0; // FPU present\r\n VIA_VME = BIT_1; // Virtual Mode Extension\r\n VIA_DE = BIT_2; // Debugging extensions\r\n VIA_PSE = BIT_3; // Page Size Extensions (4MB)\r\n VIA_TSC = BIT_4; // Time Stamp Counter\r\n VIA_MSR = BIT_5; // Model Specific Registers\r\n VIA_PAE = BIT_6; // Physical Address Extension\r\n VIA_MCE = BIT_7; // Machine Check Exception\r\n VIA_CX8 = BIT_8; // CMPXCHG8B instruction\r\n VIA_APIC = BIT_9; // APIC supported\r\n VIA_BIT_10 = BIT_10; // Reserved, do not count on value\r\n VIA_SEP = BIT_11; // Fast System Call\r\n VIA_MTRR = BIT_12; // Memory Range Registers\r\n VIA_PTE = BIT_13; // PTE Global Bit\r\n VIA_MCA = BIT_14; // Machine Check Architecture\r\n VIA_CMOVE = BIT_15; // Conditional Move\r\n VIA_PAT = BIT_16; // Page Attribute Table\r\n VIA_PSE2 = BIT_17; // 36-bit Page Size Extension\r\n VIA_SNUM = BIT_18; // Processor serial number\r\n VIA_BIT_19 = BIT_19; // Reserved, do not count on value\r\n VIA_BIT_20 = BIT_20; // Reserved, do not count on value\r\n VIA_BIT_21 = BIT_21; // Reserved, do not count on value\r\n VIA_BIT_22 = BIT_22; // Reserved, do not count on value\r\n VIA_MMX = BIT_23; // MMX\r\n VIA_FX = BIT_24; // FXSAVE and FXSTORE instructions\r\n VIA_SSE = BIT_25; // Streaming SIMD Extension\r\n VIA_BIT_26 = BIT_26; // Reserved, do not count on value\r\n VIA_BIT_27 = BIT_27; // Reserved, do not count on value\r\n VIA_BIT_28 = BIT_28; // Reserved, do not count on value\r\n VIA_BIT_29 = BIT_29; // Reserved, do not count on value\r\n VIA_BIT_30 = BIT_30; // Reserved, do not count on value\r\n VIA_3DNOW = BIT_31; // 3DNow! Technology\r\n\r\n { VIA Extended Feature Flags }\r\n EVIA_AIS = BIT_0; // Alternate Instruction Set\r\n EVIA_AISE = BIT_1; // Alternate Instruction Set Enabled\r\n EVIA_NO_RNG = BIT_2; // NO Random Number Generator\r\n EVIA_RNGE = BIT_3; // Random Number Generator Enabled\r\n EVIA_MSR = BIT_4; // Longhaul MSR 0x110A available\r\n EVIA_FEMMS = BIT_5; // FEMMS instruction Present\r\n EVIA_NO_ACE = BIT_6; // Advanced Cryptography Engine NOT Present\r\n EVIA_ACEE = BIT_7; // ACE Enabled\r\n EVIA_BIT_8 = BIT_8; // Reserved, do not count on value\r\n EVIA_BIT_9 = BIT_9; // Reserved, do not count on value\r\n EVIA_BIT_10 = BIT_10; // Reserved, do not count on value\r\n EVIA_BIT_11 = BIT_11; // Reserved, do not count on value\r\n EVIA_BIT_12 = BIT_12; // Reserved, do not count on value\r\n EVIA_BIT_13 = BIT_13; // Reserved, do not count on value\r\n EVIA_BIT_14 = BIT_14; // Reserved, do not count on value\r\n EVIA_BIT_15 = BIT_15; // Reserved, do not count on value\r\n EVIA_BIT_16 = BIT_16; // Reserved, do not count on value\r\n EVIA_BIT_17 = BIT_17; // Reserved, do not count on value\r\n EVIA_BIT_18 = BIT_18; // Reserved, do not count on value\r\n EVIA_BIT_19 = BIT_19; // Reserved, do not count on value\r\n EVIA_BIT_20 = BIT_20; // Reserved, do not count on value\r\n EVIA_BIT_21 = BIT_21; // Reserved, do not count on value\r\n EVIA_BIT_22 = BIT_22; // Reserved, do not count on value\r\n EVIA_BIT_23 = BIT_23; // Reserved, do not count on value\r\n EVIA_BIT_24 = BIT_24; // Reserved, do not count on value\r\n EVIA_BIT_25 = BIT_25; // Reserved, do not count on value\r\n EVIA_BIT_26 = BIT_26; // Reserved, do not count on value\r\n EVIA_BIT_27 = BIT_27; // Reserved, do not count on value\r\n EVIA_BIT_28 = BIT_28; // Reserved, do not count on value\r\n EVIA_BIT_29 = BIT_29; // Reserved, do not count on value\r\n EVIA_BIT_30 = BIT_30; // Reserved, do not count on value\r\n EVIA_BIT_31 = BIT_31; // Reserved, do not count on value\r\n\r\n { Cyrix Standard Feature Flags }\r\n CYRIX_FPU = BIT_0; // Floating-Point unit on chip\r\n CYRIX_VME = BIT_1; // Virtual Mode Extention\r\n CYRIX_DE = BIT_2; // Debugging Extention\r\n CYRIX_PSE = BIT_3; // Page Size Extention\r\n CYRIX_TSC = BIT_4; // Time Stamp Counter\r\n CYRIX_MSR = BIT_5; // Model Specific Registers\r\n CYRIX_PAE = BIT_6; // Physical Address Extention\r\n CYRIX_MCE = BIT_7; // Machine Check Exception\r\n CYRIX_CX8 = BIT_8; // CMPXCHG8 Instruction\r\n CYRIX_APIC = BIT_9; // Software-accessible local APIC on Chip\r\n CYRIX_BIT_10 = BIT_10; // Reserved, do not count on value\r\n CYRIX_BIT_11 = BIT_11; // Reserved, do not count on value\r\n CYRIX_MTRR = BIT_12; // Memory Type Range Registers\r\n CYRIX_PGE = BIT_13; // Page Global Enable\r\n CYRIX_MCA = BIT_14; // Machine Check Architecture\r\n CYRIX_CMOV = BIT_15; // Conditional Move Instruction\r\n CYRIX_BIT_16 = BIT_16; // Reserved, do not count on value\r\n CYRIX_BIT_17 = BIT_17; // Reserved, do not count on value\r\n CYRIX_BIT_18 = BIT_18; // Reserved, do not count on value\r\n CYRIX_BIT_19 = BIT_19; // Reserved, do not count on value\r\n CYRIX_BIT_20 = BIT_20; // Reserved, do not count on value\r\n CYRIX_BIT_21 = BIT_21; // Reserved, do not count on value\r\n CYRIX_BIT_22 = BIT_22; // Reserved, do not count on value\r\n CYRIX_MMX = BIT_23; // MMX technology\r\n CYRIX_BIT_24 = BIT_24; // Reserved, do not count on value\r\n CYRIX_BIT_25 = BIT_25; // Reserved, do not count on value\r\n CYRIX_BIT_26 = BIT_26; // Reserved, do not count on value\r\n CYRIX_BIT_27 = BIT_27; // Reserved, do not count on value\r\n CYRIX_BIT_28 = BIT_28; // Reserved, do not count on value\r\n CYRIX_BIT_29 = BIT_29; // Reserved, do not count on value\r\n CYRIX_BIT_30 = BIT_30; // Reserved, do not count on value\r\n CYRIX_BIT_31 = BIT_31; // Reserved, do not count on value\r\n\r\n { Cyrix Enhanced Feature Flags }\r\n ECYRIX_FPU = BIT_0; // Floating-Point unit on chip\r\n ECYRIX_VME = BIT_1; // Virtual Mode Extention\r\n ECYRIX_DE = BIT_2; // Debugging Extention\r\n ECYRIX_PSE = BIT_3; // Page Size Extention\r\n ECYRIX_TSC = BIT_4; // Time Stamp Counter\r\n ECYRIX_MSR = BIT_5; // Model Specific Registers\r\n ECYRIX_PAE = BIT_6; // Physical Address Extention\r\n ECYRIX_MCE = BIT_7; // Machine Check Exception\r\n ECYRIX_CX8 = BIT_8; // CMPXCHG8 Instruction\r\n ECYRIX_APIC = BIT_9; // Software-accessible local APIC on Chip\r\n ECYRIX_SEP = BIT_10; // Fast System Call\r\n ECYRIX_BIT_11 = BIT_11; // Reserved, do not count on value\r\n ECYRIX_MTRR = BIT_12; // Memory Type Range Registers\r\n ECYRIX_PGE = BIT_13; // Page Global Enable\r\n ECYRIX_MCA = BIT_14; // Machine Check Architecture\r\n ECYRIX_ICMOV = BIT_15; // Integer Conditional Move Instruction\r\n ECYRIX_FCMOV = BIT_16; // Floating Point Conditional Move Instruction\r\n ECYRIX_BIT_17 = BIT_17; // Reserved, do not count on value\r\n ECYRIX_BIT_18 = BIT_18; // Reserved, do not count on value\r\n ECYRIX_BIT_19 = BIT_19; // Reserved, do not count on value\r\n ECYRIX_BIT_20 = BIT_20; // Reserved, do not count on value\r\n ECYRIX_BIT_21 = BIT_21; // Reserved, do not count on value\r\n ECYRIX_BIT_22 = BIT_22; // Reserved, do not count on value\r\n ECYRIX_MMX = BIT_23; // MMX technology\r\n ECYRIX_EMMX = BIT_24; // Extended MMX Technology\r\n ECYRIX_BIT_25 = BIT_25; // Reserved, do not count on value\r\n ECYRIX_BIT_26 = BIT_26; // Reserved, do not count on value\r\n ECYRIX_BIT_27 = BIT_27; // Reserved, do not count on value\r\n ECYRIX_BIT_28 = BIT_28; // Reserved, do not count on value\r\n ECYRIX_BIT_29 = BIT_29; // Reserved, do not count on value\r\n ECYRIX_BIT_30 = BIT_30; // Reserved, do not count on value\r\n ECYRIX_BIT_31 = BIT_31; // Reserved, do not count on value\r\n\r\n { Transmeta Features }\r\n TRANSMETA_FPU = BIT_0; // Floating-Point unit on chip\r\n TRANSMETA_VME = BIT_1; // Virtual Mode Extention\r\n TRANSMETA_DE = BIT_2; // Debugging Extention\r\n TRANSMETA_PSE = BIT_3; // Page Size Extention\r\n TRANSMETA_TSC = BIT_4; // Time Stamp Counter\r\n TRANSMETA_MSR = BIT_5; // Model Specific Registers\r\n TRANSMETA_BIT_6 = BIT_6; // Reserved, do not count on value\r\n TRANSMETA_BIT_7 = BIT_7; // Reserved, do not count on value\r\n TRANSMETA_CX8 = BIT_8; // CMPXCHG8 Instruction\r\n TRANSMETA_BIT_9 = BIT_9; // Reserved, do not count on value\r\n TRANSMETA_BIT_10 = BIT_10; // Reserved, do not count on value\r\n TRANSMETA_SEP = BIT_11; // Fast system Call Extensions\r\n TRANSMETA_BIT_12 = BIT_12; // Reserved, do not count on value\r\n TRANSMETA_BIT_13 = BIT_13; // Reserved, do not count on value\r\n TRANSMETA_BIT_14 = BIT_14; // Reserved, do not count on value\r\n TRANSMETA_CMOV = BIT_15; // Conditional Move Instruction\r\n TRANSMETA_BIT_16 = BIT_16; // Reserved, do not count on value\r\n TRANSMETA_BIT_17 = BIT_17; // Reserved, do not count on value\r\n TRANSMETA_PSN = BIT_18; // Processor Serial Number\r\n TRANSMETA_BIT_19 = BIT_19; // Reserved, do not count on value\r\n TRANSMETA_BIT_20 = BIT_20; // Reserved, do not count on value\r\n TRANSMETA_BIT_21 = BIT_21; // Reserved, do not count on value\r\n TRANSMETA_BIT_22 = BIT_22; // Reserved, do not count on value\r\n TRANSMETA_MMX = BIT_23; // MMX technology\r\n TRANSMETA_BIT_24 = BIT_24; // Reserved, do not count on value\r\n TRANSMETA_BIT_25 = BIT_25; // Reserved, do not count on value\r\n TRANSMETA_BIT_26 = BIT_26; // Reserved, do not count on value\r\n TRANSMETA_BIT_27 = BIT_27; // Reserved, do not count on value\r\n TRANSMETA_BIT_28 = BIT_28; // Reserved, do not count on value\r\n TRANSMETA_BIT_29 = BIT_29; // Reserved, do not count on value\r\n TRANSMETA_BIT_30 = BIT_30; // Reserved, do not count on value\r\n TRANSMETA_BIT_31 = BIT_31; // Reserved, do not count on value\r\n\r\n { Extended Transmeta Features }\r\n ETRANSMETA_FPU = BIT_0; // Floating-Point unit on chip\r\n ETRANSMETA_VME = BIT_1; // Virtual Mode Extention\r\n ETRANSMETA_DE = BIT_2; // Debugging Extention\r\n ETRANSMETA_PSE = BIT_3; // Page Size Extention\r\n ETRANSMETA_TSC = BIT_4; // Time Stamp Counter\r\n ETRANSMETA_MSR = BIT_5; // Model Specific Registers\r\n ETRANSMETA_BIT_6 = BIT_6; // Reserved, do not count on value\r\n ETRANSMETA_BIT_7 = BIT_7; // Reserved, do not count on value\r\n ETRANSMETA_CX8 = BIT_8; // CMPXCHG8 Instruction\r\n ETRANSMETA_BIT_9 = BIT_9; // Reserved, do not count on value\r\n ETRANSMETA_BIT_10 = BIT_10; // Reserved, do not count on value\r\n ETRANSMETA_BIT_11 = BIT_11; // Reserved, do not count on value\r\n ETRANSMETA_BIT_12 = BIT_12; // Reserved, do not count on value\r\n ETRANSMETA_BIT_13 = BIT_13; // Reserved, do not count on value\r\n ETRANSMETA_BIT_14 = BIT_14; // Reserved, do not count on value\r\n ETRANSMETA_CMOV = BIT_15; // Conditional Move Instruction\r\n ETRANSMETA_FCMOV = BIT_16; // Float Conditional Move Instruction\r\n ETRANSMETA_BIT_17 = BIT_17; // Reserved, do not count on value\r\n ETRANSMETA_BIT_18 = BIT_18; // Reserved, do not count on value\r\n ETRANSMETA_BIT_19 = BIT_19; // Reserved, do not count on value\r\n ETRANSMETA_BIT_20 = BIT_20; // Reserved, do not count on value\r\n ETRANSMETA_BIT_21 = BIT_21; // Reserved, do not count on value\r\n ETRANSMETA_BIT_22 = BIT_22; // Reserved, do not count on value\r\n ETRANSMETA_MMX = BIT_23; // MMX technology\r\n ETRANSMETA_BIT_24 = BIT_24; // Reserved, do not count on value\r\n ETRANSMETA_BIT_25 = BIT_25; // Reserved, do not count on value\r\n ETRANSMETA_BIT_26 = BIT_26; // Reserved, do not count on value\r\n ETRANSMETA_BIT_27 = BIT_27; // Reserved, do not count on value\r\n ETRANSMETA_BIT_28 = BIT_28; // Reserved, do not count on value\r\n ETRANSMETA_BIT_29 = BIT_29; // Reserved, do not count on value\r\n ETRANSMETA_BIT_30 = BIT_30; // Reserved, do not count on value\r\n ETRANSMETA_BIT_31 = BIT_31; // Reserved, do not count on value\r\n\r\n { Transmeta Specific Features }\r\n STRANSMETA_RECOVERY = BIT_0; // Recovery Mode\r\n STRANSMETA_LONGRUN = BIT_1; // Long Run\r\n STRANSMETA_BIT_2 = BIT_2; // Debugging Extention\r\n STRANSMETA_LRTI = BIT_3; // Long Run Table Interface\r\n STRANSMETA_BIT_4 = BIT_4; // Reserved, do not count on value\r\n STRANSMETA_BIT_5 = BIT_5; // Reserved, do not count on value\r\n STRANSMETA_BIT_6 = BIT_6; // Reserved, do not count on value\r\n STRANSMETA_PTTI1 = BIT_7; // Persistent Translation Technology 1.x\r\n STRANSMETA_PTTI2 = BIT_8; // Persistent Translation Technology 2.0\r\n STRANSMETA_BIT_9 = BIT_9; // Reserved, do not count on value\r\n STRANSMETA_BIT_10 = BIT_10; // Reserved, do not count on value\r\n STRANSMETA_BIT_11 = BIT_11; // Reserved, do not count on value\r\n STRANSMETA_BIT_12 = BIT_12; // Reserved, do not count on value\r\n STRANSMETA_BIT_13 = BIT_13; // Reserved, do not count on value\r\n STRANSMETA_BIT_14 = BIT_14; // Reserved, do not count on value\r\n STRANSMETA_BIT_15 = BIT_15; // Reserved, do not count on value\r\n STRANSMETA_BIT_16 = BIT_16; // Reserved, do not count on value\r\n STRANSMETA_BIT_17 = BIT_17; // Reserved, do not count on value\r\n STRANSMETA_BIT_18 = BIT_18; // Reserved, do not count on value\r\n STRANSMETA_BIT_19 = BIT_19; // Reserved, do not count on value\r\n STRANSMETA_BIT_20 = BIT_20; // Reserved, do not count on value\r\n STRANSMETA_BIT_21 = BIT_21; // Reserved, do not count on value\r\n STRANSMETA_BIT_22 = BIT_22; // Reserved, do not count on value\r\n STRANSMETA_BIT_23 = BIT_23; // Reserved, do not count on value\r\n STRANSMETA_BIT_24 = BIT_24; // Reserved, do not count on value\r\n STRANSMETA_BIT_25 = BIT_25; // Reserved, do not count on value\r\n STRANSMETA_BIT_26 = BIT_26; // Reserved, do not count on value\r\n STRANSMETA_BIT_27 = BIT_27; // Reserved, do not count on value\r\n STRANSMETA_BIT_28 = BIT_28; // Reserved, do not count on value\r\n STRANSMETA_BIT_29 = BIT_29; // Reserved, do not count on value\r\n STRANSMETA_BIT_30 = BIT_30; // Reserved, do not count on value\r\n STRANSMETA_BIT_31 = BIT_31; // Reserved, do not count on value\r\n\r\n { Constants of bits of the MXCSR register - Intel and AMD processors that support SSE instructions}\r\n MXCSR_IE = BIT_0; // Invalid Operation flag\r\n MXCSR_DE = BIT_1; // Denormal flag\r\n MXCSR_ZE = BIT_2; // Divide by Zero flag\r\n MXCSR_OE = BIT_3; // Overflow flag\r\n MXCSR_UE = BIT_4; // Underflow flag\r\n MXCSR_PE = BIT_5; // Precision flag\r\n MXCSR_DAZ = BIT_6; // Denormal are Zero flag\r\n MXCSR_IM = BIT_7; // Invalid Operation mask\r\n MXCSR_DM = BIT_8; // Denormal mask\r\n MXCSR_ZM = BIT_9; // Divide by Zero mask\r\n MXCSR_OM = BIT_10; // Overflow mask\r\n MXCSR_UM = BIT_11; // Underflow mask\r\n MXCSR_PM = BIT_12; // Precision mask\r\n MXCSR_RC1 = BIT_13; // Rounding control, bit 1\r\n MXCSR_RC2 = BIT_14; // Rounding control, bit 2\r\n MXCSR_RC = MXCSR_RC1 or MXCSR_RC2; // Rounding control\r\n MXCSR_FZ = BIT_15; // Flush to Zero\r\n\r\nconst\r\n IntelCacheDescription: array [0..102] of TCacheInfo = (\r\n (D: $00; Family: cfOther; Size: 0; WaysOfAssoc: 0; LineSize: 0; LinePerSector: 0; Entries: 0; I: @RsIntelCacheDescr00),\r\n (D: $01; Family: cfInstructionTLB; Size: 4; WaysOfAssoc: 4; LineSize: 0; LinePerSector: 0; Entries: 32; I: @RsIntelCacheDescr01),\r\n (D: $02; Family: cfInstructionTLB; Size: 4096; WaysOfAssoc: 4; LineSize: 0; LinePerSector: 0; Entries: 2; I: @RsIntelCacheDescr02),\r\n (D: $03; Family: cfDataTLB; Size: 4; WaysOfAssoc: 4; LineSize: 0; LinePerSector: 0; Entries: 64; I: @RsIntelCacheDescr03),\r\n (D: $04; Family: cfDataTLB; Size: 4096; WaysOfAssoc: 4; LineSize: 0; LinePerSector: 0; Entries: 8; I: @RsIntelCacheDescr04),\r\n (D: $05; Family: cfDataTLB; Size: 4096; WaysOfAssoc: 4; LineSize: 0; LinePerSector: 0; Entries: 32; I: @RsIntelCacheDescr05),\r\n (D: $06; Family: cfL1InstructionCache; Size: 8; WaysOfAssoc: 4; LineSize: 32; LinePerSector: 0; Entries: 0; I: @RsIntelCacheDescr06),\r\n (D: $08; Family: cfL1InstructionCache; Size: 16; WaysOfAssoc: 4; LineSize: 32; LinePerSector: 0; Entries: 0; I: @RsIntelCacheDescr08),\r\n (D: $09; Family: cfL1InstructionCache; Size: 32; WaysOfAssoc: 4; LineSize: 64; LinePerSector: 0; Entries: 0; I: @RsIntelCacheDescr09),\r\n (D: $0A; Family: cfL1DataCache; Size: 8; WaysOfAssoc: 2; LineSize: 32; LinePerSector: 0; Entries: 0; I: @RsIntelCacheDescr0A),\r\n (D: $0B; Family: cfInstructionTLB; Size: 4; WaysOfAssoc: 4; LineSize: 0; LinePerSector: 0; Entries: 4; I: @RsIntelCacheDescr0B),\r\n (D: $0C; Family: cfL1DataCache; Size: 16; WaysOfAssoc: 4; LineSize: 32; LinePerSector: 0; Entries: 0; I: @RsIntelCacheDescr0C),\r\n (D: $0D; Family: cfL1DataCache; Size: 16; WaysOfAssoc: 4; LineSize: 64; LinePerSector: 0; Entries: 0; I: @RsIntelCacheDescr0D),\r\n (D: $0E; Family: cfL1DataCache; Size: 24; WaysOfAssoc: 4; LineSize: 64; LinePerSector: 0; Entries: 0; I: @RsIntelCacheDescr0E),\r\n (D: $21; Family: cfL2Cache; Size: 256; WaysOfAssoc: 4; LineSize: 64; LinePerSector: 0; Entries: 0; I: @RsIntelCacheDescr21),\r\n (D: $22; Family: cfL3Cache; Size: 512; WaysOfAssoc: 4; LineSize: 64; LinePerSector: 2; Entries: 0; I: @RsIntelCacheDescr22),\r\n (D: $23; Family: cfL3Cache; Size: 1024; WaysOfAssoc: 8; LineSize: 64; LinePerSector: 2; Entries: 0; I: @RsIntelCacheDescr23),\r\n (D: $25; Family: cfL3Cache; Size: 2048; WaysOfAssoc: 8; LineSize: 64; LinePerSector: 2; Entries: 0; I: @RsIntelCacheDescr25),\r\n (D: $29; Family: cfL3Cache; Size: 4096; WaysOfAssoc: 8; LineSize: 64; LinePerSector: 2; Entries: 0; I: @RsIntelCacheDescr29),\r\n (D: $2C; Family: cfL1DataCache; Size: 32; WaysOfAssoc: 8; LineSize: 64; LinePerSector: 0; Entries: 0; I: @RsIntelCacheDescr2C),\r\n (D: $30; Family: cfL1InstructionCache; Size: 32; WaysOfAssoc: 8; LineSize: 64; LinePerSector: 0; Entries: 0; I: @RsIntelCacheDescr30),\r\n (D: $39; Family: cfL2Cache; Size: 128; WaysOfAssoc: 4; LineSize: 64; LinePerSector: 0; Entries: 0; I: @RsIntelCacheDescr39),\r\n (D: $3A; Family: cfL2Cache; Size: 192; WaysOfAssoc: 6; LineSize: 64; LinePerSector: 0; Entries: 0; I: @RsIntelCacheDescr3A),\r\n (D: $3B; Family: cfL2Cache; Size: 128; WaysOfAssoc: 2; LineSize: 64; LinePerSector: 0; Entries: 0; I: @RsIntelCacheDescr3B),\r\n (D: $3C; Family: cfL2Cache; Size: 256; WaysOfAssoc: 4; LineSize: 64; LinePerSector: 0; Entries: 0; I: @RsIntelCacheDescr3C),\r\n (D: $3D; Family: cfL2Cache; Size: 384; WaysOfAssoc: 6; LineSize: 64; LinePerSector: 0; Entries: 0; I: @RsIntelCacheDescr3D),\r\n (D: $3E; Family: cfL2Cache; Size: 512; WaysOfAssoc: 4; LineSize: 64; LinePerSector: 0; Entries: 0; I: @RsIntelCacheDescr3E),\r\n (D: $40; Family: cfOther; Size: 0; WaysOfAssoc: 0; LineSize: 0; LinePerSector: 0; Entries: 0; I: @RsIntelCacheDescr40),\r\n (D: $41; Family: cfL2Cache; Size: 128; WaysOfAssoc: 4; LineSize: 32; LinePerSector: 0; Entries: 0; I: @RsIntelCacheDescr41),\r\n (D: $42; Family: cfL2Cache; Size: 256; WaysOfAssoc: 4; LineSize: 32; LinePerSector: 0; Entries: 0; I: @RsIntelCacheDescr42),\r\n (D: $43; Family: cfL2Cache; Size: 512; WaysOfAssoc: 4; LineSize: 32; LinePerSector: 0; Entries: 0; I: @RsIntelCacheDescr43),\r\n (D: $44; Family: cfL2Cache; Size: 1024; WaysOfAssoc: 4; LineSize: 32; LinePerSector: 0; Entries: 0; I: @RsIntelCacheDescr44),\r\n (D: $45; Family: cfL2Cache; Size: 2048; WaysOfAssoc: 4; LineSize: 32; LinePerSector: 0; Entries: 0; I: @RsIntelCacheDescr45),\r\n (D: $46; Family: cfL3Cache; Size: 4096; WaysOfAssoc: 4; LineSize: 64; LinePerSector: 0; Entries: 0; I: @RsIntelCacheDescr46),\r\n (D: $47; Family: cfL3Cache; Size: 8192; WaysOfAssoc: 8; LineSize: 64; LinePerSector: 0; Entries: 0; I: @RsIntelCacheDescr47),\r\n (D: $48; Family: cfL2Cache; Size: 3072; WaysOfAssoc: 12; LineSize: 64; LinePerSector: 0; Entries: 0; I: @RsIntelCacheDescr48),\r\n (D: $49; Family: cfL2Cache; Size: 4096; WaysOfAssoc: 16; LineSize: 64; LinePerSector: 0; Entries: 0; I: @RsIntelCacheDescr49),\r\n (D: $4A; Family: cfL3Cache; Size: 6144; WaysOfAssoc: 12; LineSize: 64; LinePerSector: 0; Entries: 0; I: @RsIntelCacheDescr4A),\r\n (D: $4B; Family: cfL3Cache; Size: 8192; WaysOfAssoc: 16; LineSize: 64; LinePerSector: 0; Entries: 0; I: @RsIntelCacheDescr4B),\r\n (D: $4C; Family: cfL3Cache; Size: 12288; WaysOfAssoc: 12; LineSize: 64; LinePerSector: 0; Entries: 0; I: @RsIntelCacheDescr4C),\r\n (D: $4D; Family: cfL3Cache; Size: 16384; WaysOfAssoc: 16; LineSize: 64; LinePerSector: 0; Entries: 0; I: @RsIntelCacheDescr4D),\r\n (D: $4E; Family: cfL3Cache; Size: 6144; WaysOfAssoc: 24; LineSize: 64; LinePerSector: 0; Entries: 0; I: @RsIntelCacheDescr4E),\r\n (D: $4F; Family: cfInstructionTLB; Size: 4; WaysOfAssoc: 0; LineSize: 0; LinePerSector: 0; Entries: 32; I: @RsIntelCacheDescr4F),\r\n (D: $50; Family: cfInstructionTLB; Size: 4; WaysOfAssoc: 0; LineSize: 0; LinePerSector: 0; Entries: 64; I: @RsIntelCacheDescr50),\r\n (D: $51; Family: cfInstructionTLB; Size: 4; WaysOfAssoc: 0; LineSize: 0; LinePerSector: 0; Entries: 128; I: @RsIntelCacheDescr51),\r\n (D: $52; Family: cfInstructionTLB; Size: 4; WaysOfAssoc: 0; LineSize: 0; LinePerSector: 0; Entries: 256; I: @RsIntelCacheDescr52),\r\n (D: $55; Family: cfInstructionTLB; Size: 2048; WaysOfAssoc: 0; LineSize: 0; LinePerSector: 0; Entries: 7; I: @RsIntelCacheDescr55),\r\n (D: $56; Family: cfDataTLB; Size: 4096; WaysOfAssoc: 4; LineSize: 0; LinePerSector: 0; Entries: 16; I: @RsIntelCacheDescr56),\r\n (D: $57; Family: cfDataTLB; Size: 4; WaysOfAssoc: 4; LineSize: 0; LinePerSector: 0; Entries: 16; I: @RsIntelCacheDescr57),\r\n (D: $59; Family: cfDataTLB; Size: 4; WaysOfAssoc: 0; LineSize: 0; LinePerSector: 0; Entries: 16; I: @RsIntelCacheDescr59),\r\n (D: $5A; Family: cfDataTLB; Size: 4096; WaysOfAssoc: 4; LineSize: 0; LinePerSector: 0; Entries: 32; I: @RsIntelCacheDescr5A),\r\n (D: $5B; Family: cfDataTLB; Size: 4096; WaysOfAssoc: 0; LineSize: 0; LinePerSector: 0; Entries: 64; I: @RsIntelCacheDescr5B),\r\n (D: $5C; Family: cfDataTLB; Size: 4096; WaysOfAssoc: 0; LineSize: 0; LinePerSector: 0; Entries: 128; I: @RsIntelCacheDescr5C),\r\n (D: $5D; Family: cfDataTLB; Size: 4096; WaysOfAssoc: 0; LineSize: 0; LinePerSector: 0; Entries: 256; I: @RsIntelCacheDescr5D),\r\n (D: $60; Family: cfL1DataCache; Size: 16; WaysOfAssoc: 8; LineSize: 64; LinePerSector: 0; Entries: 0; I: @RsIntelCacheDescr60),\r\n (D: $66; Family: cfL1DataCache; Size: 8; WaysOfAssoc: 4; LineSize: 64; LinePerSector: 0; Entries: 0; I: @RsIntelCacheDescr66),\r\n (D: $67; Family: cfL1DataCache; Size: 16; WaysOfAssoc: 4; LineSize: 64; LinePerSector: 0; Entries: 0; I: @RsIntelCacheDescr67),\r\n (D: $68; Family: cfL1DataCache; Size: 32; WaysOfAssoc: 4; LineSize: 64; LinePerSector: 0; Entries: 0; I: @RsIntelCacheDescr68),\r\n (D: $70; Family: cfTrace; Size: 12; WaysOfAssoc: 8; LineSize: 0; LinePerSector: 0; Entries: 0; I: @RsIntelCacheDescr70),\r\n (D: $71; Family: cfTrace; Size: 16; WaysOfAssoc: 8; LineSize: 0; LinePerSector: 0; Entries: 0; I: @RsIntelCacheDescr71),\r\n (D: $72; Family: cfTrace; Size: 32; WaysOfAssoc: 8; LineSize: 0; LinePerSector: 0; Entries: 0; I: @RsIntelCacheDescr72),\r\n (D: $73; Family: cfTrace; Size: 64; WaysOfAssoc: 8; LineSize: 0; LinePerSector: 0; Entries: 0; I: @RsIntelCacheDescr73),\r\n (D: $76; Family: cfInstructionTLB; Size: 2048; WaysOfAssoc: 0; LineSize: 0; LinePerSector: 0; Entries: 8; I: @RsIntelCacheDescr76),\r\n (D: $78; Family: cfL2Cache; Size: 1024; WaysOfAssoc: 4; LineSize: 64; LinePerSector: 0; Entries: 0; I: @RsIntelCacheDescr78),\r\n (D: $79; Family: cfL2Cache; Size: 128; WaysOfAssoc: 8; LineSize: 64; LinePerSector: 2; Entries: 0; I: @RsIntelCacheDescr79),\r\n (D: $7A; Family: cfL2Cache; Size: 256; WaysOfAssoc: 8; LineSize: 64; LinePerSector: 2; Entries: 0; I: @RsIntelCacheDescr7A),\r\n (D: $7B; Family: cfL2Cache; Size: 512; WaysOfAssoc: 8; LineSize: 64; LinePerSector: 2; Entries: 0; I: @RsIntelCacheDescr7B),\r\n (D: $7C; Family: cfL2Cache; Size: 1024; WaysOfAssoc: 8; LineSize: 64; LinePerSector: 2; Entries: 0; I: @RsIntelCacheDescr7C),\r\n (D: $7D; Family: cfL2Cache; Size: 2048; WaysOfAssoc: 8; LineSize: 64; LinePerSector: 0; Entries: 0; I: @RsIntelCacheDescr7D),\r\n (D: $7F; Family: cfL2Cache; Size: 512; WaysOfAssoc: 2; LineSize: 64; LinePerSector: 0; Entries: 0; I: @RsIntelCacheDescr7F),\r\n (D: $80; Family: cfL2Cache; Size: 512; WaysOfAssoc: 8; LineSize: 64; LinePerSector: 0; Entries: 0; I: @RsIntelCacheDescr80),\r\n (D: $82; Family: cfL2Cache; Size: 256; WaysOfAssoc: 8; LineSize: 32; LinePerSector: 0; Entries: 0; I: @RsIntelCacheDescr82),\r\n (D: $83; Family: cfL2Cache; Size: 512; WaysOfAssoc: 8; LineSize: 32; LinePerSector: 0; Entries: 0; I: @RsIntelCacheDescr83),\r\n (D: $84; Family: cfL2Cache; Size: 1024; WaysOfAssoc: 8; LineSize: 32; LinePerSector: 0; Entries: 0; I: @RsIntelCacheDescr84),\r\n (D: $85; Family: cfL2Cache; Size: 2048; WaysOfAssoc: 8; LineSize: 32; LinePerSector: 0; Entries: 0; I: @RsIntelCacheDescr85),\r\n (D: $86; Family: cfL2Cache; Size: 512; WaysOfAssoc: 4; LineSize: 64; LinePerSector: 0; Entries: 0; I: @RsIntelCacheDescr86),\r\n (D: $87; Family: cfL2Cache; Size: 1024; WaysOfAssoc: 8; LineSize: 64; LinePerSector: 0; Entries: 0; I: @RsIntelCacheDescr87),\r\n (D: $B0; Family: cfInstructionTLB; Size: 4; WaysOfAssoc: 4; LineSize: 0; LinePerSector: 0; Entries: 128; I: @RsIntelCacheDescrB0),\r\n (D: $B1; Family: cfInstructionTLB; Size: 2048; WaysOfAssoc: 4; LineSize: 0; LinePerSector: 0; Entries: 8; I: @RsIntelCacheDescrB1),\r\n (D: $B2; Family: cfInstructionTLB; Size: 4; WaysOfAssoc: 4; LineSize: 0; LinePerSector: 0; Entries: 64; I: @RsIntelCacheDescrB2),\r\n (D: $B3; Family: cfDataTLB; Size: 4; WaysOfAssoc: 4; LineSize: 0; LinePerSector: 0; Entries: 128; I: @RsIntelCacheDescrB3),\r\n (D: $B4; Family: cfDataTLB; Size: 4; WaysOfAssoc: 4; LineSize: 0; LinePerSector: 0; Entries: 256; I: @RsIntelCacheDescrB4),\r\n (D: $BA; Family: cfDataTLB; Size: 4; WaysOfAssoc: 4; LineSize: 0; LinePerSector: 0; Entries: 64; I: @RsIntelCacheDescrBA),\r\n (D: $C0; Family: cfDataTLB; Size: 4; WaysOfAssoc: 4; LineSize: 0; LinePerSector: 0; Entries: 8; I: @RsIntelCacheDescrC0),\r\n (D: $CA; Family: cfL2TLB; Size: 4; WaysOfAssoc: 4; LineSize: 0; LinePerSector: 0; Entries: 512; I: @RsIntelCacheDescrCA),\r\n (D: $D0; Family: cfL3Cache; Size: 512; WaysOfAssoc: 4; LineSize: 64; LinePerSector: 0; Entries: 0; I: @RsIntelCacheDescrD0),\r\n (D: $D1; Family: cfL3Cache; Size: 1024; WaysOfAssoc: 4; LineSize: 64; LinePerSector: 0; Entries: 0; I: @RsIntelCacheDescrD1),\r\n (D: $D2; Family: cfL3Cache; Size: 2048; WaysOfAssoc: 4; LineSize: 64; LinePerSector: 0; Entries: 0; I: @RsIntelCacheDescrD2),\r\n (D: $D6; Family: cfL3Cache; Size: 1024; WaysOfAssoc: 8; LineSize: 64; LinePerSector: 0; Entries: 0; I: @RsIntelCacheDescrD6),\r\n (D: $D7; Family: cfL3Cache; Size: 2048; WaysOfAssoc: 8; LineSize: 64; LinePerSector: 0; Entries: 0; I: @RsIntelCacheDescrD7),\r\n (D: $D8; Family: cfL3Cache; Size: 4096; WaysOfAssoc: 8; LineSize: 64; LinePerSector: 0; Entries: 0; I: @RsIntelCacheDescrD8),\r\n (D: $DC; Family: cfL3Cache; Size: 1536; WaysOfAssoc: 12; LineSize: 64; LinePerSector: 0; Entries: 0; I: @RsIntelCacheDescrDC),\r\n (D: $DD; Family: cfL3Cache; Size: 3072; WaysOfAssoc: 12; LineSize: 64; LinePerSector: 0; Entries: 0; I: @RsIntelCacheDescrDD),\r\n (D: $DE; Family: cfL3Cache; Size: 6144; WaysOfAssoc: 12; LineSize: 64; LinePerSector: 0; Entries: 0; I: @RsIntelCacheDescrDE),\r\n (D: $E2; Family: cfL3Cache; Size: 2048; WaysOfAssoc: 16; LineSize: 64; LinePerSector: 0; Entries: 0; I: @RsIntelCacheDescrE2),\r\n (D: $E3; Family: cfL3Cache; Size: 4096; WaysOfAssoc: 16; LineSize: 64; LinePerSector: 0; Entries: 0; I: @RsIntelCacheDescrE3),\r\n (D: $E4; Family: cfL3Cache; Size: 8192; WaysOfAssoc: 16; LineSize: 64; LinePerSector: 0; Entries: 0; I: @RsIntelCacheDescrE4),\r\n (D: $EA; Family: cfL3Cache; Size: 12288; WaysOfAssoc: 24; LineSize: 64; LinePerSector: 0; Entries: 0; I: @RsIntelCacheDescrEA),\r\n (D: $EB; Family: cfL3Cache; Size: 18432; WaysOfAssoc: 24; LineSize: 64; LinePerSector: 0; Entries: 0; I: @RsIntelCacheDescrEB),\r\n (D: $EC; Family: cfL3Cache; Size: 24576; WaysOfAssoc: 24; LineSize: 64; LinePerSector: 0; Entries: 0; I: @RsIntelCacheDescrEC),\r\n (D: $F0; Family: cfOther; Size: 0; WaysOfAssoc: 0; LineSize: 0; LinePerSector: 0; Entries: 0; I: @RsIntelCacheDescrF0),\r\n (D: $F1; Family: cfOther; Size: 0; WaysOfAssoc: 0; LineSize: 0; LinePerSector: 0; Entries: 0; I: @RsIntelCacheDescrF1),\r\n (D: $FF; Family: cfOther; Size: 0; WaysOfAssoc: 0; LineSize: 0; LinePerSector: 0; Entries: 0; I: @RsIntelCacheDescrFF)\r\n );\r\n\r\nprocedure GetCpuInfo(var CpuInfo: TCpuInfo);\r\n\r\nfunction GetIntelCacheDescription(const D: Byte): string;\r\nfunction RoundFrequency(const Frequency: Integer): Integer;\r\n{$IFDEF MSWINDOWS}\r\nfunction GetCPUSpeed(var CpuSpeed: TFreqInfo): Boolean;\r\n\r\ntype\r\n TOSEnabledFeature = (oefFPU, oefSSE, oefAVX);\r\n TOSEnabledFeatures = set of TOSEnabledFeature;\r\n\r\nfunction GetOSEnabledFeatures: TOSEnabledFeatures;\r\n{$ENDIF MSWINDOWS}\r\nfunction CPUID: TCpuInfo;\r\nfunction TestFDIVInstruction: Boolean;\r\n\r\n// Memory Information\r\n{$IFDEF MSWINDOWS}\r\nfunction GetMaxAppAddress: TJclAddr;\r\nfunction GetMinAppAddress: TJclAddr;\r\n{$ENDIF MSWINDOWS}\r\nfunction GetMemoryLoad: Byte;\r\nfunction GetSwapFileSize: Int64;\r\nfunction GetSwapFileUsage: Byte;\r\nfunction GetTotalPhysicalMemory: Int64;\r\nfunction GetFreePhysicalMemory: Int64;\r\n{$IFDEF MSWINDOWS}\r\nfunction GetTotalPageFileMemory: Int64;\r\nfunction GetFreePageFileMemory: Int64;\r\nfunction GetTotalVirtualMemory: Int64;\r\nfunction GetFreeVirtualMemory: Int64;\r\n{$ENDIF MSWINDOWS}\r\n\r\n// Alloc granularity\r\nprocedure RoundToAllocGranularity64(var Value: Int64; Up: Boolean);\r\nprocedure RoundToAllocGranularityPtr(var Value: Pointer; Up: Boolean);\r\n\r\n{$IFDEF MSWINDOWS}\r\n// Keyboard Information\r\nfunction GetKeyState(const VirtualKey: Cardinal): Boolean;\r\nfunction GetNumLockKeyState: Boolean;\r\nfunction GetScrollLockKeyState: Boolean;\r\nfunction GetCapsLockKeyState: Boolean;\r\n\r\n// Windows 95/98/Me system resources information\r\ntype\r\n TFreeSysResKind = (rtSystem, rtGdi, rtUser);\r\n TFreeSystemResources = record\r\n SystemRes: Integer;\r\n GdiRes: Integer;\r\n UserRes: Integer;\r\n end;\r\n\r\nfunction IsSystemResourcesMeterPresent: Boolean;\r\n\r\nfunction GetFreeSystemResources(const ResourceType: TFreeSysResKind): Integer; overload;\r\nfunction GetFreeSystemResources: TFreeSystemResources; overload;\r\nfunction GetBPP: Cardinal;\r\n\r\n// Installed programs information\r\nfunction ProgIDExists(const ProgID: string): Boolean;\r\nfunction IsWordInstalled: Boolean;\r\nfunction IsExcelInstalled: Boolean;\r\nfunction IsAccessInstalled: Boolean;\r\nfunction IsPowerPointInstalled: Boolean;\r\nfunction IsFrontPageInstalled: Boolean;\r\nfunction IsOutlookInstalled: Boolean;\r\nfunction IsInternetExplorerInstalled: Boolean;\r\nfunction IsMSProjectInstalled: Boolean;\r\nfunction IsOpenOfficeInstalled: Boolean;\r\nfunction IsLibreOfficeInstalled: Boolean;\r\n\r\n{$ENDIF MSWINDOWS}\r\n\r\n// Public global variables\r\nvar\r\n ProcessorCount: Cardinal = 0;\r\n AllocGranularity: Cardinal = 0;\r\n PageSize: Cardinal = 0;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jcl.svn.sourceforge.net/svnroot/jcl/tags/JCL-2.4-Build4571/jcl/source/common/JclSysInfo.pas $';\r\n Revision: '$Revision: 3843 $';\r\n Date: '$Date: 2012-08-22 17:40:33 +0200 (mer. 22 août 2012) $';\r\n LogPath: 'JCL\\source\\common';\r\n Extra: '';\r\n Data: nil\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n {$IFDEF HAS_UNITSCOPE}\r\n System.SysUtils, System.Math,\r\n {$IFDEF MSWINDOWS}\r\n Winapi.Messages, Winapi.Winsock, Snmp,\r\n {$IFDEF FPC}\r\n JwaTlHelp32, JwaPsApi,\r\n {$ELSE ~FPC}\r\n Winapi.TLHelp32, Winapi.PsApi,\r\n JclShell,\r\n {$ENDIF ~FPC}\r\n JclRegistry, JclWin32,\r\n {$ENDIF MSWINDOWS}\r\n {$ELSE ~HAS_UNITSCOPE}\r\n SysUtils,\r\n Math,\r\n {$IFDEF MSWINDOWS}\r\n Messages, Winsock, Snmp,\r\n {$IFDEF FPC}\r\n JwaTlHelp32, JwaPsApi,\r\n {$ELSE ~FPC}\r\n TLHelp32, PsApi,\r\n JclShell,\r\n {$ENDIF ~FPC}\r\n JclRegistry, JclWin32,\r\n {$ENDIF MSWINDOWS}\r\n {$ENDIF ~HAS_UNITSCOPE}\r\n Jcl8087, JclIniFiles,\r\n JclSysUtils, JclFileUtils, JclStrings;\r\n\r\n{$IFDEF FPC}\r\n{$IFDEF MSWINDOWS}\r\n\r\nfunction PidlToPath(IdList: PItemIdList): string;\r\nbegin\r\n SetLength(Result, MAX_PATH);\r\n if SHGetPathFromIdList(IdList, PChar(Result)) then\r\n StrResetLength(Result)\r\n else\r\n Result := '';\r\nend;\r\n\r\n//----------------------------------------------------------------------------\r\n\r\nfunction GetSpecialFolderLocation(const Folder: Integer): string;\r\nvar\r\n FolderPidl: PItemIdList;\r\nbegin\r\n FolderPidl := nil;\r\n if Succeeded(SHGetSpecialFolderLocation(0, Folder, FolderPidl)) then\r\n begin\r\n try\r\n Result := PidlToPath(FolderPidl);\r\n finally\r\n CoTaskMemFree(FolderPidl);\r\n end;\r\n end\r\n else\r\n Result := '';\r\nend;\r\n\r\n//----------------------------------------------------------------------------\r\n\r\n{$ENDIF MSWINDOWS}\r\n{$ENDIF FPC}\r\n\r\n//=== Environment ============================================================\r\n\r\nfunction DelEnvironmentVar(const Name: string): Boolean;\r\nbegin\r\n {$IFDEF UNIX}\r\n UnSetEnv(PChar(Name));\r\n Result := True;\r\n {$ENDIF UNIX}\r\n {$IFDEF MSWINDOWS}\r\n Result := SetEnvironmentVariable(PChar(Name), nil);\r\n {$ENDIF MSWINDOWS}\r\nend;\r\n\r\nfunction ExpandEnvironmentVar(var Value: string): Boolean;\r\n{$IFDEF UNIX}\r\nbegin\r\n Result := True;\r\nend;\r\n{$ENDIF UNIX}\r\n{$IFDEF MSWINDOWS}\r\nvar\r\n R: Integer;\r\n Expanded: string;\r\nbegin\r\n SetLength(Expanded, 1);\r\n R := ExpandEnvironmentStrings(PChar(Value), PChar(Expanded), 0);\r\n SetLength(Expanded, R);\r\n Result := ExpandEnvironmentStrings(PChar(Value), PChar(Expanded), R) <> 0;\r\n if Result then\r\n begin\r\n StrResetLength(Expanded);\r\n Value := Expanded;\r\n end;\r\nend;\r\n{$ENDIF MSWINDOWS}\r\n\r\nfunction ExpandEnvironmentVarCustom(var Value: string; Vars: TStrings): Boolean;\r\n\r\n function FindClosingBrace(const R: string; var Position: Integer): Boolean;\r\n var\r\n Index, Len, BraceCount: Integer;\r\n Quotes: string;\r\n begin\r\n Len := Length(R);\r\n BraceCount := 0;\r\n Quotes := '';\r\n while (Position <= Len) do\r\n begin\r\n // handle quotes first\r\n if (R[Position] = NativeSingleQuote) then\r\n begin\r\n Index := JclStrings.CharPos(Quotes, NativeSingleQuote);\r\n if Index >= 0 then\r\n SetLength(Quotes, Index - 1)\r\n else\r\n Quotes := Quotes + NativeSingleQuote;\r\n end;\r\n\r\n if (R[Position] = NativeDoubleQuote) then\r\n begin\r\n Index := JclStrings.CharPos(Quotes, NativeDoubleQuote);\r\n if Index >= 0 then\r\n SetLength(Quotes, Index - 1)\r\n else\r\n Quotes := Quotes + NativeDoubleQuote;\r\n end;\r\n\r\n if (R[Position] = '`') then\r\n begin\r\n Index := JclStrings.CharPos(Quotes, '`');\r\n if Index >= 0 then\r\n SetLength(Quotes, Index - 1)\r\n else\r\n Quotes := Quotes + '`';\r\n end;\r\n\r\n if Quotes = '' then\r\n begin\r\n if R[Position] = ')' then\r\n begin\r\n Dec(BraceCount);\r\n if BraceCount = 0 then\r\n Break;\r\n end\r\n else\r\n if R[Position] = '(' then\r\n Inc(BraceCount);\r\n end;\r\n Inc(Position);\r\n end;\r\n Result := Position <= Len;\r\n\r\n// Delphi XE's CodeGear.Delphi.Targets has a bug where the closing paran is missing\r\n// \"'$(DelphiWin32DebugDCUPath'!=''\". But it is still a valid string and not worth\r\n// an exception.\r\n//\r\n// if Position > Len then\r\n// raise EJclMsBuildError.CreateResFmt(@RsEEndOfString, [S]);\r\n end;\r\n\r\nvar\r\n Start, Position: Integer;\r\n PropertyName, PropertyValue: string;\r\nbegin\r\n Result := True;\r\n repeat\r\n // start with the last match in order to convert $(some$(other))\r\n // evaluate properties\r\n Start := StrLastPos('$(', Value);\r\n if Start > 0 then\r\n begin\r\n Position := Start;\r\n if not FindClosingBrace(Value, Position) then\r\n Break;\r\n PropertyName := Copy(Value, Start + 2, Position - Start - 2);\r\n\r\n PropertyValue := Vars.Values[PropertyName];\r\n\r\n if PropertyValue <> '' then\r\n StrReplace(Value,\r\n Copy(Value, Start, Position - Start + 1), // $(PropertyName)\r\n PropertyValue,\r\n [rfReplaceAll, rfIgnoreCase])\r\n else\r\n begin\r\n Result := False;\r\n Start := 0;\r\n end;\r\n end;\r\n until Start = 0;\r\nend;\r\n\r\n{$IFDEF UNIX}\r\n\r\nfunction GetEnvironmentVar(const Name: string; var Value: string): Boolean;\r\nbegin\r\n Value := getenv(PChar(Name));\r\n Result := Value <> '';\r\nend;\r\n\r\nfunction GetEnvironmentVar(const Name: string; var Value: string; Expand: Boolean): Boolean;\r\nbegin\r\n Result := GetEnvironmentVar(Name, Value); // Expand is there just for x-platform compatibility\r\nend;\r\n\r\n{$ENDIF UNIX}\r\n\r\n{$IFDEF MSWINDOWS}\r\n\r\nfunction GetEnvironmentVar(const Name: string; out Value: string): Boolean;\r\nbegin\r\n Result := GetEnvironmentVar(Name, Value, True);\r\nend;\r\n\r\nfunction GetEnvironmentVar(const Name: string; out Value: string; Expand: Boolean): Boolean;\r\nvar\r\n R: DWORD;\r\nbegin\r\n R := {$IFDEF HAS_UNITSCOPE}Winapi.{$ENDIF}Windows.GetEnvironmentVariable(PChar(Name), nil, 0);\r\n SetLength(Value, R);\r\n R := {$IFDEF HAS_UNITSCOPE}Winapi.{$ENDIF}Windows.GetEnvironmentVariable(PChar(Name), PChar(Value), R);\r\n Result := R <> 0;\r\n if not Result then\r\n Value := ''\r\n else\r\n begin\r\n SetLength(Value, R);\r\n if Expand then\r\n ExpandEnvironmentVar(Value);\r\n end;\r\nend;\r\n\r\n{$ENDIF MSWINDOWS}\r\n\r\n{$IFDEF LINUX}\r\nfunction GetEnvironmentVars(const Vars: TStrings): Boolean;\r\nvar\r\n P: PPChar;\r\nbegin\r\n Vars.BeginUpdate;\r\n try\r\n Vars.Clear;\r\n P := System.envp;\r\n Result := P <> nil;\r\n while (P <> nil) and (P^ <> nil) do\r\n begin\r\n Vars.Add(P^);\r\n Inc(P);\r\n end;\r\n finally\r\n Vars.EndUpdate;\r\n end;\r\nend;\r\n\r\nfunction GetEnvironmentVars(const Vars: TStrings; Expand: Boolean): Boolean;\r\nbegin\r\n Result := GetEnvironmentVars(Vars); // Expand is there just for x-platform compatibility\r\nend;\r\n{$ENDIF LINUX}\r\n\r\n{$IFDEF MSWINDOWS}\r\nfunction GetEnvironmentVars(const Vars: TStrings): Boolean;\r\nbegin\r\n Result := GetEnvironmentVars(Vars, True);\r\nend;\r\n\r\nfunction GetEnvironmentVars(const Vars: TStrings; Expand: Boolean): Boolean;\r\nvar\r\n Raw: PChar;\r\n Expanded: string;\r\n I: Integer;\r\nbegin\r\n Vars.BeginUpdate;\r\n try\r\n Vars.Clear;\r\n Raw := GetEnvironmentStrings;\r\n try\r\n MultiSzToStrings(Vars, Raw);\r\n Result := True;\r\n finally\r\n FreeEnvironmentStrings(Raw);\r\n end;\r\n if Expand then\r\n begin\r\n for I := 0 to Vars.Count - 1 do\r\n begin\r\n Expanded := Vars[I];\r\n if ExpandEnvironmentVar(Expanded) then\r\n Vars[I] := Expanded;\r\n end;\r\n end;\r\n finally\r\n Vars.EndUpdate;\r\n end;\r\nend;\r\n\r\n{$ENDIF MSWINDOWS}\r\n\r\nfunction SetEnvironmentVar(const Name, Value: string): Boolean;\r\nbegin\r\n {$IFDEF UNIX}\r\n SetEnv(PChar(Name), PChar(Value), 1);\r\n Result := True;\r\n {$ENDIF UNIX}\r\n {$IFDEF MSWINDOWS}\r\n Result := SetEnvironmentVariable(PChar(Name), PChar(Value));\r\n {$ENDIF MSWINDOWS}\r\nend;\r\n\r\n{$IFDEF MSWINDOWS}\r\n\r\nfunction CreateEnvironmentBlock(const Options: TEnvironmentOptions; const AdditionalVars: TStrings): PChar;\r\nconst\r\n RegLocalEnvironment = 'SYSTEM\\CurrentControlSet\\Control\\Session Manager\\Environment';\r\n RegUserEnvironment = '\\Environment\\';\r\nvar\r\n KeyNames, TempList: TStrings;\r\n Temp, Name, Value: string;\r\n I: Integer;\r\nbegin\r\n TempList := TStringList.Create;\r\n try\r\n // add additional environment variables\r\n if eoAdditional in Options then\r\n for I := 0 to AdditionalVars.Count - 1 do\r\n begin\r\n Temp := AdditionalVars[I];\r\n ExpandEnvironmentVar(Temp);\r\n TempList.Add(Temp);\r\n end;\r\n // get environment strings from local machine\r\n if eoLocalMachine in Options then\r\n begin\r\n KeyNames := TStringList.Create;\r\n try\r\n if RegGetValueNames(HKEY_LOCAL_MACHINE, RegLocalEnvironment, KeyNames) then\r\n begin\r\n for I := 0 to KeyNames.Count - 1 do\r\n begin\r\n Name := KeyNames[I];\r\n Value := RegReadString(HKEY_LOCAL_MACHINE, RegLocalEnvironment, Name);\r\n ExpandEnvironmentVar(Value);\r\n TempList.Add(Name + '=' + Value);\r\n end;\r\n end;\r\n finally\r\n FreeAndNil(KeyNames);\r\n end;\r\n end;\r\n // get environment strings from current user\r\n if eoCurrentUser in Options then\r\n begin\r\n KeyNames := TStringLIst.Create;\r\n try\r\n if RegGetValueNames(HKEY_CURRENT_USER, RegUserEnvironment, KeyNames) then\r\n begin\r\n for I := 0 to KeyNames.Count - 1 do\r\n begin\r\n Name := KeyNames[I];\r\n Value := RegReadString(HKEY_CURRENT_USER, RegUserEnvironment, Name);\r\n ExpandEnvironmentVar(Value);\r\n TempList.Add(Name + '=' + Value);\r\n end;\r\n end;\r\n finally\r\n KeyNames.Free;\r\n end;\r\n end;\r\n // transform stringlist into multi-PChar\r\n Result := nil;\r\n StringsToMultiSz(Result, TempList);\r\n finally\r\n FreeAndNil(TempList);\r\n end;\r\nend;\r\n\r\n// frees an environment block allocated by CreateEnvironmentBlock and\r\n// sets Env to nil\r\n\r\nprocedure DestroyEnvironmentBlock(var Env: PChar);\r\nbegin\r\n FreeMultiSz(Env);\r\nend;\r\n\r\nprocedure SetGlobalEnvironmentVariable(VariableName, VariableContent: string);\r\nconst\r\n cEnvironment = 'Environment';\r\nbegin\r\n if VariableName = '' then\r\n Exit;\r\n if VariableContent = '' then\r\n begin\r\n RegDeleteEntry(HKEY_CURRENT_USER, cEnvironment, VariableName);\r\n SetEnvironmentVariable(PChar(VariableName), nil);\r\n end\r\n else\r\n begin\r\n RegWriteString(HKEY_CURRENT_USER, cEnvironment, VariableName, VariableContent);\r\n SetEnvironmentVariable(PChar(VariableName), PChar(VariableContent));\r\n end;\r\n SendMessage(HWND_BROADCAST, WM_SETTINGCHANGE, 0, LPARAM(PChar(cEnvironment)));\r\nend;\r\n\r\n//=== Common Folders =========================================================\r\n\r\n// Utility function which returns the Windows independent CurrentVersion key\r\n// inside HKEY_LOCAL_MACHINE\r\n\r\nconst\r\n HKLM_CURRENT_VERSION_WINDOWS = 'SOFTWARE\\Microsoft\\Windows\\CurrentVersion';\r\n HKLM_CURRENT_VERSION_NT = 'SOFTWARE\\Microsoft\\Windows NT\\CurrentVersion';\r\n\r\nfunction REG_CURRENT_VERSION: string;\r\nbegin\r\n if IsWinNT then\r\n Result := HKLM_CURRENT_VERSION_NT\r\n else\r\n Result := HKLM_CURRENT_VERSION_WINDOWS;\r\nend;\r\n\r\n{ TODO : Check for documented solution }\r\nfunction GetCommonFilesFolder: string;\r\nbegin\r\n Result := RegReadStringDef(HKEY_LOCAL_MACHINE, HKLM_CURRENT_VERSION_WINDOWS,\r\n 'CommonFilesDir', '');\r\nend;\r\n\r\n{$ENDIF MSWINDOWS}\r\n\r\nfunction GetCurrentFolder: string;\r\n{$IFDEF UNIX}\r\nconst\r\n InitialSize = 64;\r\nvar\r\n Size: Integer;\r\nbegin\r\n Size := InitialSize;\r\n while True do\r\n begin\r\n SetLength(Result, Size);\r\n if getcwd(PChar(Result), Size) <> nil then\r\n begin\r\n StrResetLength(Result);\r\n Exit;\r\n end;\r\n {$IFDEF FPC}\r\n if GetLastOSError <> ERANGE then\r\n {$ELSE ~FPC}\r\n if GetLastError <> ERANGE then\r\n {$ENDIF ~FPC}\r\n RaiseLastOSError;\r\n Size := Size * 2;\r\n end;\r\nend;\r\n{$ENDIF UNIX}\r\n{$IFDEF MSWINDOWS}\r\nvar\r\n Required: Cardinal;\r\nbegin\r\n Result := '';\r\n Required := GetCurrentDirectory(0, nil);\r\n if Required <> 0 then\r\n begin\r\n SetLength(Result, Required);\r\n GetCurrentDirectory(Required, PChar(Result));\r\n StrResetLength(Result);\r\n end;\r\nend;\r\n{$ENDIF MSWINDOWS}\r\n\r\n{$IFDEF MSWINDOWS}\r\n{ TODO : Check for documented solution }\r\nfunction GetProgramFilesFolder: string;\r\nbegin\r\n Result := RegReadStringDef(HKEY_LOCAL_MACHINE, HKLM_CURRENT_VERSION_WINDOWS, 'ProgramFilesDir', '');\r\nend;\r\n\r\n{ TODO : Check for documented solution }\r\nfunction GetWindowsFolder: string;\r\nvar\r\n Required: Cardinal;\r\nbegin\r\n Result := '';\r\n Required := GetWindowsDirectory(nil, 0);\r\n if Required <> 0 then\r\n begin\r\n SetLength(Result, Required);\r\n GetWindowsDirectory(PChar(Result), Required);\r\n StrResetLength(Result);\r\n end;\r\nend;\r\n\r\n{ TODO : Check for documented solution }\r\nfunction GetWindowsSystemFolder: string;\r\nvar\r\n Required: Cardinal;\r\nbegin\r\n Result := '';\r\n Required := GetSystemDirectory(nil, 0);\r\n if Required <> 0 then\r\n begin\r\n SetLength(Result, Required);\r\n GetSystemDirectory(PChar(Result), Required);\r\n StrResetLength(Result);\r\n end;\r\nend;\r\n\r\nfunction GetWindowsTempFolder: string;\r\nbegin\r\n Result := PathRemoveSeparator(PathGetTempPath);\r\nend;\r\n\r\nfunction GetDesktopFolder: string;\r\nbegin\r\n Result := GetSpecialFolderLocation(CSIDL_DESKTOP);\r\nend;\r\n\r\n{ TODO : Check GetProgramsFolder = GetProgramFilesFolder }\r\nfunction GetProgramsFolder: string;\r\nbegin\r\n Result := GetSpecialFolderLocation(CSIDL_PROGRAMS);\r\nend;\r\n\r\n{$ENDIF MSWINDOWS}\r\nfunction GetPersonalFolder: string;\r\nbegin\r\n {$IFDEF UNIX}\r\n Result := GetEnvironmentVariable('HOME');\r\n {$ENDIF UNIX}\r\n {$IFDEF MSWINDOWS}\r\n Result := GetSpecialFolderLocation(CSIDL_PERSONAL);\r\n {$ENDIF MSWINDOWS}\r\nend;\r\n\r\n{$IFDEF MSWINDOWS}\r\nfunction GetFavoritesFolder: string;\r\nbegin\r\n Result := GetSpecialFolderLocation(CSIDL_FAVORITES);\r\nend;\r\n\r\nfunction GetStartupFolder: string;\r\nbegin\r\n Result := GetSpecialFolderLocation(CSIDL_STARTUP);\r\nend;\r\n\r\nfunction GetRecentFolder: string;\r\nbegin\r\n Result := GetSpecialFolderLocation(CSIDL_RECENT);\r\nend;\r\n\r\nfunction GetSendToFolder: string;\r\nbegin\r\n Result := GetSpecialFolderLocation(CSIDL_SENDTO);\r\nend;\r\n\r\nfunction GetStartmenuFolder: string;\r\nbegin\r\n Result := GetSpecialFolderLocation(CSIDL_STARTMENU);\r\nend;\r\n\r\nfunction GetDesktopDirectoryFolder: string;\r\nbegin\r\n Result := GetSpecialFolderLocation(CSIDL_DESKTOPDIRECTORY);\r\nend;\r\n\r\nfunction GetCommonDocumentsFolder: string;\r\nbegin\r\n Result := GetSpecialFolderLocation(CSIDL_COMMON_DOCUMENTS);\r\nend;\r\n\r\nfunction GetNethoodFolder: string;\r\nbegin\r\n Result := GetSpecialFolderLocation(CSIDL_NETHOOD);\r\nend;\r\n\r\nfunction GetFontsFolder: string;\r\nbegin\r\n Result := GetSpecialFolderLocation(CSIDL_FONTS);\r\nend;\r\n\r\nfunction GetCommonStartmenuFolder: string;\r\nbegin\r\n Result := GetSpecialFolderLocation(CSIDL_COMMON_STARTMENU);\r\nend;\r\n\r\nfunction GetCommonProgramsFolder: string;\r\nbegin\r\n Result := GetSpecialFolderLocation(CSIDL_COMMON_PROGRAMS);\r\nend;\r\n\r\nfunction GetCommonStartupFolder: string;\r\nbegin\r\n Result := GetSpecialFolderLocation(CSIDL_COMMON_STARTUP);\r\nend;\r\n\r\nfunction GetCommonDesktopdirectoryFolder: string;\r\nbegin\r\n Result := GetSpecialFolderLocation(CSIDL_COMMON_DESKTOPDIRECTORY);\r\nend;\r\n\r\nfunction GetCommonAppdataFolder: string;\r\nbegin\r\n Result := GetSpecialFolderLocation(CSIDL_COMMON_APPDATA);\r\nend;\r\n\r\nfunction GetAppdataFolder: string;\r\nbegin\r\n Result := GetSpecialFolderLocation(CSIDL_APPDATA);\r\nend;\r\n\r\nfunction GetLocalAppData: string;\r\nbegin\r\n Result := GetSpecialFolderLocation(CSIDL_LOCAL_APPDATA);\r\nend;\r\n\r\nfunction GetPrinthoodFolder: string;\r\nbegin\r\n Result := GetSpecialFolderLocation(CSIDL_PRINTHOOD);\r\nend;\r\n\r\nfunction GetCommonFavoritesFolder: string;\r\nbegin\r\n Result := GetSpecialFolderLocation(CSIDL_COMMON_FAVORITES);\r\nend;\r\n\r\nfunction GetTemplatesFolder: string;\r\nbegin\r\n Result := GetSpecialFolderLocation(CSIDL_TEMPLATES);\r\nend;\r\n\r\nfunction GetInternetCacheFolder: string;\r\nbegin\r\n Result := GetSpecialFolderLocation(CSIDL_INTERNET_CACHE);\r\nend;\r\n\r\nfunction GetCookiesFolder: string;\r\nbegin\r\n Result := GetSpecialFolderLocation(CSIDL_COOKIES);\r\nend;\r\n\r\nfunction GetHistoryFolder: string;\r\nbegin\r\n Result := GetSpecialFolderLocation(CSIDL_HISTORY);\r\nend;\r\n\r\nfunction GetProfileFolder: string;\r\nbegin\r\n Result := GetSpecialFolderLocation(CSIDL_PROFILE);\r\nend;\r\n\r\n// the following special folders are pure virtual and cannot be\r\n// mapped to a directory path:\r\n// CSIDL_INTERNET\r\n// CSIDL_CONTROLS\r\n// CSIDL_PRINTERS\r\n// CSIDL_BITBUCKET\r\n// CSIDL_DRIVES\r\n// CSIDL_NETWORK\r\n// CSIDL_ALTSTARTUP\r\n// CSIDL_COMMON_ALTSTARTUP\r\n\r\n// Identification\r\ntype\r\n TVolumeInfoKind = (vikName, vikSerial, vikFileSystem);\r\n\r\nfunction GetVolumeInfoHelper(const Drive: string; InfoKind: TVolumeInfoKind): string;\r\nvar\r\n VolumeSerialNumber: DWORD;\r\n MaximumComponentLength: DWORD;\r\n Flags: DWORD;\r\n Name: array [0..MAX_PATH] of Char;\r\n FileSystem: array [0..15] of Char;\r\n ErrorMode: Cardinal;\r\n DriveStr: string;\r\nbegin\r\n { TODO : Change to RootPath }\r\n { TODO : Perform better checking of Drive param or document that no checking\r\n is performed. RM Suggested:\r\n DriveStr := Drive;\r\n if (Length(Drive) < 2) or (Drive[2] <> ':') then\r\n DriveStr := GetCurrentFolder;\r\n DriveStr := DriveStr[1] + ':\\'; }\r\n Result := '';\r\n DriveStr := Drive + ':\\';\r\n ErrorMode := SetErrorMode(SEM_FAILCRITICALERRORS);\r\n try\r\n Flags := 0;\r\n MaximumComponentLength := 0;\r\n if GetVolumeInformation(PChar(DriveStr), Name, SizeOf(Name), @VolumeSerialNumber,\r\n MaximumComponentLength, Flags, FileSystem, SizeOf(FileSystem)) then\r\n case InfoKind of\r\n vikName:\r\n Result := StrPas(Name);\r\n vikSerial:\r\n begin\r\n Result := IntToHex(HiWord(VolumeSerialNumber), 4) + '-' +\r\n IntToHex(LoWord(VolumeSerialNumber), 4);\r\n end;\r\n vikFileSystem:\r\n Result := StrPas(FileSystem);\r\n end;\r\n finally\r\n SetErrorMode(ErrorMode);\r\n end;\r\nend;\r\n\r\nfunction GetVolumeName(const Drive: string): string;\r\nbegin\r\n Result := GetVolumeInfoHelper(Drive, vikName);\r\nend;\r\n\r\nfunction GetVolumeSerialNumber(const Drive: string): string;\r\nbegin\r\n Result := GetVolumeInfoHelper(Drive, vikSerial);\r\nend;\r\n\r\nfunction GetVolumeFileSystem(const Drive: string): string;\r\nbegin\r\n Result := GetVolumeInfoHelper(Drive, vikFileSystem);\r\nend;\r\n\r\n{ TODO -cHelp : Donator (incl. TFileSystemFlag[s]): Robert Rossmair }\r\n\r\nfunction GetVolumeFileSystemFlags(const Volume: string): TFileSystemFlags;\r\nconst\r\n FileSystemFlags: array [TFileSystemFlag] of DWORD =\r\n ( FILE_CASE_SENSITIVE_SEARCH, // fsCaseSensitive\r\n FILE_CASE_PRESERVED_NAMES, // fsCasePreservedNames\r\n FILE_UNICODE_ON_DISK, // fsSupportsUnicodeOnDisk\r\n FILE_PERSISTENT_ACLS, // fsPersistentACLs\r\n FILE_FILE_COMPRESSION, // fsSupportsFileCompression\r\n FILE_VOLUME_QUOTAS, // fsSupportsVolumeQuotas\r\n FILE_SUPPORTS_SPARSE_FILES, // fsSupportsSparseFiles\r\n FILE_SUPPORTS_REPARSE_POINTS, // fsSupportsReparsePoints\r\n FILE_SUPPORTS_REMOTE_STORAGE, // fsSupportsRemoteStorage\r\n FILE_VOLUME_IS_COMPRESSED, // fsVolumeIsCompressed\r\n FILE_SUPPORTS_OBJECT_IDS, // fsSupportsObjectIds\r\n FILE_SUPPORTS_ENCRYPTION, // fsSupportsEncryption\r\n FILE_NAMED_STREAMS, // fsSupportsNamedStreams\r\n FILE_READ_ONLY_VOLUME // fsVolumeIsReadOnly\r\n );\r\nvar\r\n MaximumComponentLength, Flags: Cardinal;\r\n Flag: TFileSystemFlag;\r\nbegin\r\n Flags := 0;\r\n MaximumComponentLength := 0;\r\n if not GetVolumeInformation(PChar(PathAddSeparator(Volume)), nil, 0, nil,\r\n MaximumComponentLength, Flags, nil, 0) then\r\n RaiseLastOSError;\r\n Result := [];\r\n for Flag := Low(TFileSystemFlag) to High(TFileSystemFlag) do\r\n if (Flags and FileSystemFlags[Flag]) <> 0 then\r\n Include(Result, Flag);\r\nend;\r\n\r\n{$ENDIF MSWINDOWS}\r\n\r\n{ TODO -cDoc: Contributor: twm }\r\n\r\nfunction GetIPAddress(const HostName: string): string;\r\nvar\r\n {$IFDEF MSWINDOWS}\r\n R: Integer;\r\n WSAData: TWSAData;\r\n {$ENDIF MSWINDOWS}\r\n HostEnt: PHostEnt;\r\n Host: AnsiString;\r\n SockAddr: TSockAddrIn;\r\nbegin\r\n Result := '';\r\n {$IFDEF MSWINDOWS}\r\n WSAData.wVersion := 0;\r\n R := WSAStartup(MakeWord(1, 1), WSAData);\r\n if R = 0 then\r\n try\r\n {$ENDIF MSWINDOWS}\r\n Host := AnsiString(HostName);\r\n if Host = '' then\r\n begin\r\n SetLength(Host, MAX_PATH);\r\n GetHostName(PAnsiChar(Host), MAX_PATH);\r\n end;\r\n HostEnt := GetHostByName(PAnsiChar(Host));\r\n if HostEnt <> nil then\r\n begin\r\n SockAddr.sin_addr.S_addr := Longint(PLongint(HostEnt^.h_addr_list^)^);\r\n Result := string(AnsiString(inet_ntoa(SockAddr.sin_addr)));\r\n end;\r\n {$IFDEF MSWINDOWS}\r\n finally\r\n WSACleanup;\r\n end;\r\n {$ENDIF MSWINDOWS}\r\nend;\r\n\r\n{ TODO -cDoc: Donator: twm }\r\n\r\n{$IFDEF MSWINDOWS}\r\nprocedure GetIpAddresses(Results: TStrings);\r\nbegin\r\n GetIpAddresses(Results, '');\r\nend;\r\n\r\nprocedure GetIpAddresses(Results: TStrings; const HostName: AnsiString);\r\ntype\r\n TaPInAddr = array[0..10] of PInAddr;\r\n PaPInAddr = ^TaPInAddr;\r\nvar\r\n R: Integer;\r\n HostEnt: PHostEnt;\r\n pptr: PaPInAddr;\r\n Host: AnsiString;\r\n i: Integer;\r\n WSAData: TWSAData;\r\nbegin\r\n //need a socket for ioctl()\r\n WSAData.wVersion := 0;\r\n R := WSAStartup(MakeWord(1, 1), WSAData);\r\n if R = 0 then begin\r\n try\r\n if HostName = '' then\r\n begin\r\n SetLength(Host, MAX_PATH);\r\n GetHostName(PAnsiChar(Host), MAX_PATH);\r\n end\r\n else\r\n Host := HostName;\r\n \r\n HostEnt := GetHostByName(PAnsiChar(Host));\r\n if HostEnt <> nil then\r\n begin\r\n pPtr := PaPInAddr(HostEnt^.h_addr_list);\r\n i := 0;\r\n while pPtr^[I] <> nil do begin\r\n Results.Add(string(AnsiString(inet_ntoa(pptr^[i]^)))); // OF AnsiString to TStrings\r\n Inc(i);\r\n end;\r\n end;\r\n finally\r\n WSACleanup;\r\n end;\r\n end;\r\nend;\r\n{$ENDIF MSWINDOWS}\r\n\r\n{$IFDEF UNIX}\r\n\r\n{ TODO -cDoc: Donator: twm, Contributor rrossmair }\r\n\r\n// Returns all IP addresses of the local machine in the form\r\n// = (which allows for access to the interface names\r\n// by means of Results.Names and the addresses through Results.Values)\r\n//\r\n// Example:\r\n//\r\n// lo=127.0.0.1\r\n// eth0=10.10.10.1\r\n// ppp0=217.82.187.130\r\n//\r\n// note that this will append to Results!\r\n//\r\n\r\nprocedure GetIpAddresses(Results: TStrings);\r\nvar\r\n Sock: Integer;\r\n IfReq: TIfReq;\r\n SockAddrPtr: PSockAddrIn;\r\n ListSave, IfList: PIfNameIndex;\r\nbegin\r\n //need a socket for ioctl()\r\n Sock := socket(AF_INET, SOCK_STREAM, 0);\r\n if Sock < 0 then\r\n RaiseLastOSError;\r\n\r\n try\r\n //returns pointer to dynamically allocated list of structs\r\n ListSave := if_nameindex();\r\n try\r\n IfList := ListSave;\r\n //walk thru the array returned and query for each\r\n //interface's address\r\n while IfList^.if_index <> 0 do\r\n begin\r\n //copy in the interface name to look up address of\r\n {$IFDEF FPC}\r\n strncpy(IfReq.ifr_ifrn.ifrn_name, IfList^.if_name, IFNAMSIZ);\r\n {$ELSE ~FPC}\r\n strncpy(IfReq.ifrn_name, IfList^.if_name, IFNAMSIZ);\r\n {$ENDIF ~FPC}\r\n //get the address for this interface\r\n if ioctl(Sock, SIOCGIFADDR, @IfReq) <> 0 then\r\n RaiseLastOSError;\r\n //print out the address\r\n {$IFDEF FPC}\r\n SockAddrPtr := PSockAddrIn(@IfReq.ifr_ifru.ifru_addr);\r\n Results.Add(Format('%s=%s', [IfReq.ifr_ifrn.ifrn_name, inet_ntoa(SockAddrPtr^.sin_addr)]));\r\n {$ELSE ~FPC}\r\n SockAddrPtr := PSockAddrIn(@IfReq.ifru_addr);\r\n Results.Add(Format('%s=%s', [IfReq.ifrn_name, inet_ntoa(SockAddrPtr^.sin_addr)]));\r\n {$ENDIF ~FPC}\r\n Inc(IfList);\r\n end;\r\n finally\r\n //free the dynamic memory kernel allocated for us\r\n if_freenameindex(ListSave);\r\n end;\r\n finally\r\n Libc.__close(Sock)\r\n end;\r\nend;\r\n\r\n{$ENDIF UNIX}\r\n\r\nfunction GetLocalComputerName: string;\r\n// (rom) UNIX or LINUX?\r\n{$IFDEF LINUX}\r\nvar\r\n MachineInfo: utsname;\r\nbegin\r\n uname(MachineInfo);\r\n Result := MachineInfo.nodename;\r\nend;\r\n{$ENDIF LINUX}\r\n{$IFDEF MSWINDOWS}\r\nvar\r\n Count: DWORD;\r\nbegin\r\n Count := MAX_COMPUTERNAME_LENGTH + 1;\r\n // set buffer size to MAX_COMPUTERNAME_LENGTH + 2 characters for safety\r\n { TODO : Win2k solution }\r\n SetLength(Result, Count);\r\n if GetComputerName(PChar(Result), Count) then\r\n StrResetLength(Result)\r\n else\r\n Result := '';\r\nend;\r\n{$ENDIF MSWINDOWS}\r\n\r\nfunction GetLocalUserName: string;\r\n{$IFDEF UNIX}\r\nbegin\r\n Result := GetEnv('USER');\r\nend;\r\n{$ENDIF UNIX}\r\n{$IFDEF MSWINDOWS}\r\nvar\r\n Count: DWORD;\r\nbegin\r\n Count := 256 + 1; // UNLEN + 1\r\n // set buffer size to 256 + 2 characters\r\n { TODO : Win2k solution }\r\n SetLength(Result, Count);\r\n if GetUserName(PChar(Result), Count) then\r\n StrResetLength(Result)\r\n else\r\n Result := '';\r\nend;\r\n{$ENDIF MSWINDOWS}\r\n\r\n{$IFDEF MSWINDOWS}\r\nfunction GetRegisteredCompany: string;\r\nbegin\r\n { TODO : check for MSDN documentation }\r\n Result := RegReadStringDef(HKEY_LOCAL_MACHINE, REG_CURRENT_VERSION, 'RegisteredOrganization', '');\r\nend;\r\n\r\nfunction GetRegisteredOwner: string;\r\nbegin\r\n { TODO : check for MSDN documentation }\r\n Result := RegReadStringDef(HKEY_LOCAL_MACHINE, REG_CURRENT_VERSION, 'RegisteredOwner', '');\r\nend;\r\n\r\n{ TODO: Check supported platforms, maybe complete rewrite }\r\n\r\nfunction GetUserDomainName(const CurUser: string): string;\r\nvar\r\n Count1, Count2: DWORD;\r\n Sd: PSID; // PSecurityDescriptor; // FPC requires PSID\r\n Snu: SID_Name_Use;\r\nbegin\r\n Count1 := 0;\r\n Count2 := 0;\r\n Sd := nil;\r\n Snu := SIDTypeUser;\r\n Result := '';\r\n LookUpAccountName(nil, PChar(CurUser), Sd, Count1, PChar(Result), Count2, Snu);\r\n // set buffer size to Count2 + 2 characters for safety\r\n SetLength(Result, Count2 + 1);\r\n Sd := AllocMem(Count1);\r\n try\r\n if LookUpAccountName(nil, PChar(CurUser), Sd, Count1, PChar(Result), Count2, Snu) then\r\n StrResetLength(Result)\r\n else\r\n Result := EmptyStr;\r\n finally\r\n FreeMem(Sd);\r\n end;\r\nend;\r\n\r\nfunction GetWorkGroupName: WideString;\r\nvar\r\n WkstaInfo: PByte;\r\n WkstaInfo100: PWKSTA_INFO_100;\r\nbegin\r\n if NetWkstaGetInfo(nil, 100, WkstaInfo) <> NERR_Success then\r\n raise EJclWin32Error.CreateRes(@RsENetWkstaGetInfo);\r\n WkstaInfo100 := PWKSTA_INFO_100(WkstaInfo);\r\n Result := WideString(PWideChar(WkstaInfo100^.wki100_langroup));\r\n NetApiBufferFree(Pointer(WkstaInfo));\r\nend;\r\n\r\n{$ENDIF MSWINDOWS}\r\nfunction GetDomainName: string;\r\n{$IFDEF UNIX}\r\nvar\r\n MachineInfo: utsname;\r\nbegin\r\n uname(MachineInfo);\r\n Result := MachineInfo.domainname;\r\nend;\r\n{$ENDIF UNIX}\r\n{$IFDEF MSWINDOWS}\r\n//091123 HA Use LookupAccountSid to fetch the current users domain ...\r\n//begin\r\n// Result := GetUserDomainName(GetLocalUserName);\r\n//end;\r\nvar\r\n hProcess, hAccessToken: THandle;\r\n InfoBuffer: PChar;\r\n AccountName: array [0..UNLEN] of Char;\r\n DomainName: array [0..UNLEN] of Char;\r\n\r\n InfoBufferSize: Cardinal;\r\n AccountSize: Cardinal;\r\n DomainSize: Cardinal;\r\n snu: SID_NAME_USE;\r\nbegin\r\n InfoBufferSize := 1000;\r\n AccountSize := SizeOf(AccountName);\r\n DomainSize := SizeOf(DomainName);\r\n\r\n hProcess := GetCurrentProcess;\r\n if OpenProcessToken(hProcess, TOKEN_READ, hAccessToken) then\r\n try\r\n GetMem(InfoBuffer, InfoBufferSize);\r\n try\r\n if GetTokenInformation(hAccessToken, TokenUser, InfoBuffer, InfoBufferSize, InfoBufferSize) then\r\n LookupAccountSid(nil, PSIDAndAttributes(InfoBuffer)^.sid, AccountName, AccountSize,\r\n DomainName, DomainSize, snu)\r\n else\r\n RaiseLastOSError;\r\n finally\r\n FreeMem(InfoBuffer)\r\n end;\r\n Result := DomainName;\r\n finally\r\n CloseHandle(hAccessToken);\r\n end\r\nend;\r\n{$ENDIF MSWINDOWS}\r\n\r\n{$IFDEF MSWINDOWS}\r\n// Reference: How to Obtain BIOS Information from the Registry\r\n// http://support.microsoft.com/default.aspx?scid=kb;en-us;q195268\r\n\r\nfunction GetBIOSName: string;\r\nconst\r\n Win9xBIOSInfoKey = 'Enum\\Root\\*PNP0C01\\0000';\r\nbegin\r\n if IsWinNT then\r\n Result := ''\r\n else\r\n Result := RegReadStringDef(HKEY_LOCAL_MACHINE, Win9xBIOSInfoKey, 'BIOSName', '');\r\nend;\r\n\r\nfunction GetBIOSCopyright: string;\r\nconst\r\n ADR_BIOSCOPYRIGHT = $FE091;\r\nbegin\r\n Result := '';\r\n if not IsWinNT and not IsBadReadPtr(Pointer(ADR_BIOSCOPYRIGHT), 2) then\r\n try\r\n Result := string(AnsiString(PAnsiChar(ADR_BIOSCOPYRIGHT)));\r\n except\r\n Result := '';\r\n end;\r\nend;\r\n\r\nfunction GetBIOSExtendedInfo: string;\r\nconst\r\n ADR_BIOSEXTENDEDINFO = $FEC71;\r\nbegin\r\n Result := '';\r\n if not IsWinNT and not IsBadReadPtr(Pointer(ADR_BIOSEXTENDEDINFO), 2) then\r\n try\r\n Result := string(AnsiString(PAnsiChar(ADR_BIOSEXTENDEDINFO)));\r\n except\r\n Result := '';\r\n end;\r\nend;\r\n\r\n// Reference: How to Obtain BIOS Information from the Registry\r\n// http://support.microsoft.com/default.aspx?scid=kb;en-us;q195268\r\n\r\n{ TODO : the date string can be e.g. 00/00/00 }\r\nfunction GetBIOSDate: TDateTime;\r\nconst\r\n WinNT_REG_PATH = 'HARDWARE\\DESCRIPTION\\System';\r\n WinNT_REG_KEY = 'SystemBiosDate';\r\n Win9x_REG_PATH = 'Enum\\Root\\*PNP0C01\\0000';\r\n Win9x_REG_KEY = 'BiosDate';\r\nvar\r\n RegStr: string;\r\n {$IFDEF RTL150_UP}\r\n FormatSettings: TFormatSettings;\r\n {$ELSE ~RTL150_UP}\r\n RegFormat: string;\r\n RegSeparator: Char;\r\n {$ENDIF ~RTL150_UP}\r\nbegin\r\n if IsWinNT then\r\n RegStr := RegReadString(HKEY_LOCAL_MACHINE, WinNT_REG_PATH, WinNT_REG_KEY)\r\n else\r\n RegStr := RegReadString(HKEY_LOCAL_MACHINE, Win9x_REG_PATH, Win9x_REG_KEY);\r\n {$IFDEF RTL150_UP}\r\n FillChar(FormatSettings, SizeOf(FormatSettings), 0);\r\n FormatSettings.DateSeparator := '/';\r\n FormatSettings.ShortDateFormat := 'm/d/y';\r\n if not TryStrToDate(RegStr, Result, FormatSettings) then\r\n begin\r\n FormatSettings.ShortDateFormat := 'y/m/d';\r\n if not TryStrToDate(RegStr, Result, FormatSettings) then\r\n Result := 0;\r\n end;\r\n {$ELSE ~RTL150_UP}\r\n Result := 0;\r\n { TODO : change to a threadsafe solution }\r\n RegFormat := ShortDateFormat;\r\n RegSeparator := DateSeparator;\r\n try\r\n DateSeparator := '/';\r\n try\r\n ShortDateFormat := 'm/d/y';\r\n Result := StrToDate(RegStr);\r\n except\r\n try\r\n ShortDateFormat := 'y/m/d';\r\n Result := StrToDate(RegStr);\r\n except\r\n end;\r\n end;\r\n finally\r\n ShortDateFormat := RegFormat;\r\n DateSeparator := RegSeparator;\r\n end;\r\n {$ENDIF ~RTL150_UP}\r\nend;\r\n\r\n{$ENDIF MSWINDOWS}\r\n\r\n//=== Processes, Tasks and Modules ===========================================\r\n\r\n{$IFDEF UNIX}\r\nconst\r\n CommLen = 16; // synchronize with size of comm in struct task_struct in\r\n // /usr/include/linux/sched.h\r\n SProcDirectory = '/proc';\r\n\r\nfunction RunningProcessesList(const List: TStrings; FullPath: Boolean): Boolean;\r\nvar\r\n ProcDir: PDirectoryStream;\r\n PtrDirEnt: PDirEnt;\r\n Scratch: TDirEnt;\r\n ProcID: __pid_t;\r\n E: Integer;\r\n FileName: string;\r\n F: PIOFile;\r\nbegin\r\n Result := False;\r\n ProcDir := opendir(SProcDirectory);\r\n if ProcDir <> nil then\r\n begin\r\n PtrDirEnt := nil;\r\n {$IFDEF FPC}\r\n if readdir_r(ProcDir, @Scratch, @PtrDirEnt) <> 0 then\r\n Exit;\r\n {$ELSE ~FPC}\r\n if readdir_r(ProcDir, @Scratch, PtrDirEnt) <> 0 then\r\n Exit;\r\n {$ENDIF ~FPC}\r\n List.BeginUpdate;\r\n try\r\n while PtrDirEnt <> nil do\r\n begin\r\n Val(PtrDirEnt^.d_name, ProcID, E);\r\n if E = 0 then // name was process id\r\n begin\r\n FileName := '';\r\n\r\n if FullPath then\r\n FileName := SymbolicLinkTarget(Format('/proc/%s/exe', [PtrDirEnt^.d_name]));\r\n\r\n if FileName = '' then // usually due to insufficient access rights\r\n begin\r\n // read stat\r\n FileName := Format('/proc/%s/stat', [PtrDirEnt^.d_name]);\r\n F := fopen(PChar(FileName), 'r');\r\n if F = nil then\r\n raise EJclError.CreateResFmt(@RsInvalidProcessID, [ProcID]);\r\n try\r\n SetLength(FileName, CommLen);\r\n if fscanf(F, PChar(Format('%%*d (%%%d[^)])', [CommLen])), PChar(FileName)) <> 1 then\r\n RaiseLastOSError;\r\n StrResetLength(FileName);\r\n finally\r\n fclose(F);\r\n end;\r\n end;\r\n\r\n List.AddObject(FileName, Pointer(ProcID));\r\n end;\r\n {$IFDEF FPC}\r\n if readdir_r(ProcDir, @Scratch, @PtrDirEnt) <> 0 then\r\n Break;\r\n {$ELSE ~FPC}\r\n if readdir_r(ProcDir, @Scratch, PtrDirEnt) <> 0 then\r\n Break;\r\n {$ENDIF ~FPC}\r\n end;\r\n finally\r\n List.EndUpdate;\r\n end;\r\n end;\r\nend;\r\n\r\n{$ENDIF UNIX}\r\n\r\n{$IFDEF MSWINDOWS}\r\n\r\nfunction RunningProcessesList(const List: TStrings; FullPath: Boolean): Boolean;\r\n\r\n // This function always returns an empty string on Win9x\r\n function ProcessFileName(PID: DWORD): string;\r\n var\r\n Handle: THandle;\r\n begin\r\n Result := '';\r\n Handle := OpenProcess(PROCESS_QUERY_INFORMATION or PROCESS_VM_READ, False, PID);\r\n if Handle <> 0 then\r\n try\r\n SetLength(Result, MAX_PATH);\r\n if FullPath then\r\n begin\r\n if GetModuleFileNameEx(Handle, 0, PChar(Result), MAX_PATH) > 0 then\r\n StrResetLength(Result)\r\n else\r\n Result := '';\r\n end\r\n else\r\n begin\r\n if GetModuleBaseName(Handle, 0, PChar(Result), MAX_PATH) > 0 then\r\n StrResetLength(Result)\r\n else\r\n Result := '';\r\n end;\r\n finally\r\n CloseHandle(Handle);\r\n end;\r\n end;\r\n\r\n { TODO: Check return value of CreateToolhelp32Snapshot on Windows NT (0?) }\r\n function BuildListTH: Boolean;\r\n var\r\n SnapProcHandle: THandle;\r\n ProcEntry: TProcessEntry32;\r\n NextProc: Boolean;\r\n FileName: string;\r\n begin\r\n SnapProcHandle := CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0);\r\n Result := (SnapProcHandle <> INVALID_HANDLE_VALUE);\r\n if Result then\r\n try\r\n ProcEntry.dwSize := SizeOf(ProcEntry);\r\n NextProc := Process32First(SnapProcHandle, ProcEntry);\r\n while NextProc do\r\n begin\r\n if ProcEntry.th32ProcessID = 0 then\r\n begin\r\n // PID 0 is always the \"System Idle Process\" but this name cannot be\r\n // retrieved from the system and has to be fabricated.\r\n FileName := LoadResString(@RsSystemIdleProcess);\r\n end\r\n else\r\n begin\r\n if IsWin2k or IsWinXP or IsWin2003 or IsWin2003R2 or IsWinXP64 or\r\n IsWinVista or IsWinServer2008 or IsWin7 or IsWinServer2008R2 then\r\n begin\r\n FileName := ProcessFileName(ProcEntry.th32ProcessID);\r\n if FileName = '' then\r\n FileName := ProcEntry.szExeFile;\r\n end\r\n else\r\n begin\r\n FileName := ProcEntry.szExeFile;\r\n if not FullPath then\r\n FileName := ExtractFileName(FileName);\r\n end;\r\n end;\r\n List.AddObject(FileName, Pointer(ProcEntry.th32ProcessID));\r\n NextProc := Process32Next(SnapProcHandle, ProcEntry);\r\n end;\r\n finally\r\n CloseHandle(SnapProcHandle);\r\n end;\r\n end;\r\n\r\n function BuildListPS: Boolean;\r\n var\r\n PIDs: array [0..1024] of DWORD;\r\n Needed: DWORD;\r\n I: Integer;\r\n FileName: string;\r\n begin\r\n Needed := 0;\r\n Result := EnumProcesses(@PIDs, SizeOf(PIDs), Needed);\r\n if Result then\r\n begin\r\n for I := 0 to (Needed div SizeOf(DWORD)) - 1 do\r\n begin\r\n case PIDs[I] of\r\n 0:\r\n // PID 0 is always the \"System Idle Process\" but this name cannot be\r\n // retrieved from the system and has to be fabricated.\r\n FileName := LoadResString(@RsSystemIdleProcess);\r\n 2:\r\n // On NT 4 PID 2 is the \"System Process\" but this name cannot be\r\n // retrieved from the system and has to be fabricated.\r\n if IsWinNT4 then\r\n FileName := LoadResString(@RsSystemProcess)\r\n else\r\n FileName := ProcessFileName(PIDs[I]);\r\n 8:\r\n // On Win2K PID 8 is the \"System Process\" but this name cannot be\r\n // retrieved from the system and has to be fabricated.\r\n if IsWin2k or IsWinXP then\r\n FileName := LoadResString(@RsSystemProcess)\r\n else\r\n FileName := ProcessFileName(PIDs[I]);\r\n else\r\n FileName := ProcessFileName(PIDs[I]);\r\n end;\r\n if FileName <> '' then\r\n List.AddObject(FileName, Pointer(PIDs[I]));\r\n end;\r\n end;\r\n end;\r\n\r\nbegin\r\n { TODO : safer solution? }\r\n List.BeginUpdate;\r\n try\r\n if GetWindowsVersion in [wvWinNT31, wvWinNT35, wvWinNT351, wvWinNT4] then\r\n Result := BuildListPS\r\n else\r\n Result := BuildListTH;\r\n finally\r\n List.EndUpdate;\r\n end;\r\nend;\r\n\r\n{ TODO Windows 9x ? }\r\n\r\nfunction LoadedModulesList(const List: TStrings; ProcessID: DWORD; HandlesOnly: Boolean): Boolean;\r\n\r\n procedure AddToList(ProcessHandle: THandle; Module: HMODULE);\r\n var\r\n FileName: array [0..MAX_PATH] of Char;\r\n ModuleInfo: TModuleInfo;\r\n begin\r\n ModuleInfo.EntryPoint := nil;\r\n {$IFDEF FPC}\r\n if GetModuleInformation(ProcessHandle, Module, ModuleInfo, SizeOf(ModuleInfo)) then\r\n {$ELSE ~FPC}\r\n if GetModuleInformation(ProcessHandle, Module, @ModuleInfo, SizeOf(ModuleInfo)) then\r\n {$ENDIF ~FPC}\r\n begin\r\n if HandlesOnly then\r\n List.AddObject('', Pointer(ModuleInfo.lpBaseOfDll))\r\n else\r\n if GetModuleFileNameEx(ProcessHandle, Module, Filename, SizeOf(Filename)) > 0 then\r\n List.AddObject(FileName, Pointer(ModuleInfo.lpBaseOfDll));\r\n end;\r\n end;\r\n\r\n function EnumModulesVQ(ProcessHandle: THandle): Boolean;\r\n var\r\n MemInfo: TMemoryBasicInformation;\r\n Base: PChar;\r\n LastAllocBase: Pointer;\r\n Res: DWORD;\r\n begin\r\n Base := nil;\r\n LastAllocBase := nil;\r\n ResetMemory(MemInfo, SizeOf(MemInfo));\r\n Res := VirtualQueryEx(ProcessHandle, Base, MemInfo, SizeOf(MemInfo));\r\n Result := (Res = SizeOf(MemInfo));\r\n while Res = SizeOf(MemInfo) do\r\n begin\r\n if MemInfo.AllocationBase <> LastAllocBase then\r\n begin\r\n {$IFDEF FPC}\r\n if MemInfo._Type = MEM_IMAGE then\r\n {$ELSE ~FPC}\r\n if MemInfo.Type_9 = MEM_IMAGE then\r\n {$ENDIF ~FPC}\r\n AddToList(ProcessHandle, HMODULE(MemInfo.AllocationBase));\r\n LastAllocBase := MemInfo.AllocationBase;\r\n end;\r\n Inc(Base, MemInfo.RegionSize);\r\n Res := VirtualQueryEx(ProcessHandle, Base, MemInfo, SizeOf(MemInfo));\r\n end;\r\n end;\r\n\r\n function EnumModulesPS: Boolean;\r\n var\r\n ProcessHandle: THandle;\r\n Needed: DWORD;\r\n Modules: array of THandle;\r\n I, Cnt: Integer;\r\n begin\r\n Result := False;\r\n ProcessHandle := OpenProcess(PROCESS_QUERY_INFORMATION or PROCESS_VM_READ, False, ProcessID);\r\n if ProcessHandle <> 0 then\r\n try\r\n Needed := 0;\r\n Result := EnumProcessModules(ProcessHandle, nil, 0, Needed);\r\n if Result then\r\n begin\r\n Cnt := Needed div SizeOf(HMODULE);\r\n SetLength(Modules, Cnt);\r\n if EnumProcessModules(ProcessHandle, @Modules[0], Needed, Needed) then\r\n for I := 0 to Cnt - 1 do\r\n AddToList(ProcessHandle, Modules[I]);\r\n end\r\n else\r\n Result := EnumModulesVQ(ProcessHandle);\r\n finally\r\n CloseHandle(ProcessHandle);\r\n end;\r\n end;\r\n\r\n { TODO: Check return value of CreateToolhelp32Snapshot on Windows NT (0?) }\r\n\r\n function EnumModulesTH: Boolean;\r\n var\r\n SnapProcHandle: THandle;\r\n Module: TModuleEntry32;\r\n Next: Boolean;\r\n begin\r\n SnapProcHandle := CreateToolhelp32Snapshot(TH32CS_SNAPMODULE, ProcessID);\r\n Result := (SnapProcHandle <> INVALID_HANDLE_VALUE);\r\n if Result then\r\n try\r\n ResetMemory(Module, SizeOf(Module));\r\n Module.dwSize := SizeOf(Module);\r\n Next := Module32First(SnapProcHandle, Module);\r\n while Next do\r\n begin\r\n if HandlesOnly then\r\n List.AddObject('', Pointer(Module.hModule))\r\n else\r\n List.AddObject(Module.szExePath, Pointer(Module.hModule));\r\n Next := Module32Next(SnapProcHandle, Module);\r\n end;\r\n finally\r\n CloseHandle(SnapProcHandle);\r\n end;\r\n end;\r\n\r\nbegin\r\n List.BeginUpdate;\r\n try\r\n if IsWinNT then\r\n Result := EnumModulesPS\r\n else\r\n Result := EnumModulesTH;\r\n finally\r\n List.EndUpdate;\r\n end;\r\nend;\r\n\r\nfunction EnumTaskWindowsProc(Wnd: THandle; List: TStrings): Boolean; stdcall;\r\nvar\r\n Caption: array [0..1024] of Char;\r\nbegin\r\n if IsMainAppWindow(Wnd) and (GetWindowText(Wnd, Caption, SizeOf(Caption)) > 0) then\r\n List.AddObject(Caption, Pointer(Wnd));\r\n Result := True;\r\nend;\r\n\r\nfunction GetTasksList(const List: TStrings): Boolean;\r\nbegin\r\n List.BeginUpdate;\r\n try\r\n Result := EnumWindows(@EnumTaskWindowsProc, LPARAM(List));\r\n finally\r\n List.EndUpdate;\r\n end;\r\nend;\r\n\r\nfunction ModuleFromAddr(const Addr: Pointer): HMODULE;\r\nvar\r\n MI: TMemoryBasicInformation;\r\nbegin\r\n MI.AllocationBase := nil;\r\n VirtualQuery(Addr, MI, SizeOf(MI));\r\n if MI.State <> MEM_COMMIT then\r\n Result := 0\r\n else\r\n Result := HMODULE(MI.AllocationBase);\r\nend;\r\n\r\nfunction IsSystemModule(const Module: HMODULE): Boolean;\r\nvar\r\n CurModule: PLibModule;\r\nbegin\r\n Result := False;\r\n if Module <> 0 then\r\n begin\r\n CurModule := LibModuleList;\r\n while CurModule <> nil do\r\n begin\r\n if CurModule.Instance = Module then\r\n begin\r\n Result := True;\r\n Break;\r\n end;\r\n CurModule := CurModule.Next;\r\n end;\r\n end;\r\nend;\r\n\r\n// Reference: http://msdn.microsoft.com/library/periodic/period97/win321197.htm\r\n{ TODO : wrong link }\r\n\r\nfunction IsMainAppWindow(Wnd: THandle): Boolean;\r\nvar\r\n ParentWnd: THandle;\r\n ExStyle: DWORD;\r\nbegin\r\n if IsWindowVisible(Wnd) then\r\n begin\r\n ParentWnd := THandle(GetWindowLongPtr(Wnd, GWLP_HWNDPARENT));\r\n ExStyle := GetWindowLongPtr(Wnd, GWL_EXSTYLE);\r\n Result := ((ParentWnd = 0) or (ParentWnd = GetDesktopWindow)) and\r\n ((ExStyle and WS_EX_TOOLWINDOW = 0) or (ExStyle and WS_EX_APPWINDOW <> 0));\r\n end\r\n else\r\n Result := False;\r\nend;\r\n\r\nfunction IsWindowResponding(Wnd: THandle; Timeout: Integer): Boolean;\r\nvar\r\n Res: DWORD;\r\nbegin\r\n Res := 0;\r\n Result := SendMessageTimeout(Wnd, WM_NULL, 0, 0, SMTO_ABORTIFHUNG, Timeout, {$IFDEF RTL230_UP}@{$ENDIF}Res) <> 0;\r\nend;\r\n\r\nfunction GetWindowIcon(Wnd: THandle; LargeIcon: Boolean): HICON;\r\nvar\r\n Width, Height: Integer;\r\n TempIcon: HICON;\r\n IconType: DWORD;\r\nbegin\r\n if LargeIcon then\r\n begin\r\n Width := GetSystemMetrics(SM_CXICON);\r\n Height := GetSystemMetrics(SM_CYICON);\r\n IconType := ICON_BIG;\r\n TempIcon := GetClassLong(Wnd, GCL_HICON);\r\n end\r\n else\r\n begin\r\n Width := GetSystemMetrics(SM_CXSMICON);\r\n Height := GetSystemMetrics(SM_CYSMICON);\r\n IconType := ICON_SMALL;\r\n TempIcon := GetClassLong(Wnd, GCL_HICONSM);\r\n end;\r\n if TempIcon = 0 then\r\n TempIcon := SendMessage(Wnd, WM_GETICON, IconType, 0);\r\n if (TempIcon = 0) and not LargeIcon then\r\n TempIcon := SendMessage(Wnd, WM_GETICON, ICON_BIG, 0);\r\n Result := CopyImage(TempIcon, IMAGE_ICON, Width, Height, 0);\r\nend;\r\n\r\nfunction GetWindowCaption(Wnd: THandle): string;\r\nvar\r\n Buffer: string;\r\n Size: Integer;\r\nbegin\r\n Size := GetWindowTextLength(Wnd);\r\n if Size = 0 then\r\n Size := 1; // always allocate at least one byte, otherwise PChar(Buffer) returns nil\r\n SetLength(Buffer, Size);\r\n // strings always have an additional null character\r\n Size := GetWindowText(Wnd, PChar(Buffer), Size + 1);\r\n Result := Copy(Buffer, 1, Size);\r\nend;\r\n\r\n// Q178893\r\n// http://support.microsoft.com/default.aspx?scid=kb;en-us;178893\r\n\r\nfunction EnumTerminateAppWindowsProc(Wnd: THandle; ProcessID: DWORD): Boolean; stdcall;\r\nvar\r\n PID: DWORD;\r\nbegin\r\n GetWindowThreadProcessId(Wnd, @PID);\r\n if ProcessID = PID then\r\n PostMessage(Wnd, WM_CLOSE, 0, 0);\r\n Result := True;\r\nend;\r\n\r\nfunction TerminateApp(ProcessID: DWORD; Timeout: Integer): TJclTerminateAppResult;\r\nvar\r\n ProcessHandle: THandle;\r\nbegin\r\n Result := taError;\r\n if ProcessID <> GetCurrentProcessId then\r\n begin\r\n ProcessHandle := OpenProcess(SYNCHRONIZE or PROCESS_TERMINATE, False, ProcessID);\r\n if ProcessHandle <> 0 then\r\n try\r\n EnumWindows(@EnumTerminateAppWindowsProc, LPARAM(ProcessID));\r\n if WaitForSingleObject(ProcessHandle, Timeout) = WAIT_OBJECT_0 then\r\n Result := taClean\r\n else\r\n if TerminateProcess(ProcessHandle, 0) then\r\n Result := taKill;\r\n finally\r\n CloseHandle(ProcessHandle);\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TerminateTask(Wnd: THandle; Timeout: Integer): TJclTerminateAppResult;\r\nvar\r\n PID: DWORD;\r\nbegin\r\n if GetWindowThreadProcessId(Wnd, @PID) <> 0 then\r\n Result := TerminateApp(PID, Timeout)\r\n else\r\n Result := taError;\r\nend;\r\n\r\nfunction GetProcessNameFromWnd(Wnd: THandle): string;\r\nvar\r\n List: TStringList;\r\n PID: THandle;\r\n I: Integer;\r\nbegin\r\n Result := '';\r\n if IsWindow(Wnd) then\r\n begin\r\n PID := INVALID_HANDLE_VALUE;\r\n GetWindowThreadProcessId(Wnd, @PID);\r\n List := TStringList.Create;\r\n try\r\n if RunningProcessesList(List, True) then\r\n begin\r\n I := List.IndexOfObject(Pointer(PID));\r\n if I > -1 then\r\n Result := List[I];\r\n end;\r\n finally\r\n List.Free;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction GetPidFromProcessName(const ProcessName: string): THandle;\r\nvar\r\n List: TStringList;\r\n I: Integer;\r\n HasFullPath: Boolean;\r\nbegin\r\n Result := INVALID_HANDLE_VALUE;\r\n List := TStringList.Create;\r\n try\r\n HasFullPath := ExtractFilePath(ProcessName) <> '';\r\n if RunningProcessesList(List, HasFullPath) then\r\n begin\r\n I := List.IndexOf(ProcessName);\r\n if I > -1 then\r\n Result := DWORD(List.Objects[I]);\r\n end;\r\n finally\r\n List.Free;\r\n end;\r\nend;\r\n\r\nfunction GetProcessNameFromPid(PID: DWORD): string;\r\nvar\r\n List: TStringList;\r\n I: Integer;\r\nbegin\r\n // Note: there are other ways to retrieve the name of the process given it's\r\n // PID but this implementation seems to work best without making assumptions\r\n // although it may not be the most efficient implementation.\r\n Result := '';\r\n List := TStringList.Create;\r\n try\r\n if RunningProcessesList(List, True) then\r\n begin\r\n I := List.IndexOfObject(Pointer(PID));\r\n if I > -1 then\r\n Result := List[I];\r\n end;\r\n finally\r\n List.Free;\r\n end;\r\nend;\r\n\r\ntype\r\n PSearch = ^TSearch;\r\n TSearch = record\r\n PID: DWORD;\r\n Wnd: THandle;\r\n end;\r\n\r\nfunction EnumMainAppWindowsProc(Wnd: THandle; Res: PSearch): Boolean; stdcall;\r\nvar\r\n WindowPid: DWORD;\r\nbegin\r\n WindowPid := 0;\r\n GetWindowThreadProcessId(Wnd, @WindowPid);\r\n if (WindowPid = Res^.PID) and IsMainAppWindow(Wnd) then\r\n begin\r\n Res^.Wnd := Wnd;\r\n Result := False;\r\n end\r\n else\r\n Result := True;\r\nend;\r\n\r\nfunction GetMainAppWndFromPid(PID: DWORD): THandle;\r\nvar\r\n SearchRec: TSearch;\r\nbegin\r\n SearchRec.PID := PID;\r\n SearchRec.Wnd := 0;\r\n EnumWindows(@EnumMainAppWindowsProc, LPARAM(@SearchRec));\r\n Result := SearchRec.Wnd;\r\nend;\r\n\r\ntype\r\n PEnumWndStruct = ^TEnumWndStruct;\r\n TEnumWndStruct = record\r\n PID: DWORD;\r\n WndClassName: string;\r\n ResultWnd: HWND;\r\n end;\r\n\r\nfunction EnumPidWinProc(Wnd: HWND; Enum: PEnumWndStruct): BOOL; stdcall;\r\nvar\r\n PID: DWORD;\r\n C: PChar;\r\n CLen: Integer;\r\nbegin\r\n Result := True;\r\n GetWindowThreadProcessId(Wnd, @PID);\r\n if (PID = Enum.PID) then\r\n begin\r\n CLen := Length(Enum.WndClassName)+1;\r\n C := StrAlloc(CLen);\r\n if (GetClassName(Wnd, C, CLen) > 0) then\r\n if (C = Enum.WndClassName) then\r\n begin\r\n Result := False;\r\n Enum.ResultWnd := Wnd;\r\n end;\r\n StrDispose(C);\r\n end;\r\nend;\r\n\r\nfunction GetWndFromPid(PID: DWORD; const WindowClassName: string): HWND;\r\nvar\r\n EnumWndStruct: TEnumWndStruct;\r\nbegin\r\n EnumWndStruct.PID := PID;\r\n EnumWndStruct.WndClassName := WindowClassName;\r\n EnumWndStruct.ResultWnd := 0;\r\n EnumWindows(@EnumPidWinProc, LPARAM(@EnumWndStruct));\r\n Result := EnumWndStruct.ResultWnd;\r\nend;\r\n\r\nfunction GetShellProcessName: string;\r\nconst\r\n cShellKey = 'SOFTWARE\\Microsoft\\Windows NT\\CurrentVersion\\WinLogon';\r\n cShellValue = 'Shell';\r\n cShellDefault = 'explorer.exe';\r\n cShellSystemIniFileName = 'system.ini';\r\n cShellBootSection = 'boot';\r\nbegin\r\n if IsWinNT then\r\n Result := RegReadStringDef(HKEY_LOCAL_MACHINE, cShellKey, cShellValue, '')\r\n else\r\n Result := IniReadString(PathAddSeparator(GetWindowsFolder) + cShellSystemIniFileName, cShellBootSection, cShellValue);\r\n if Result = '' then\r\n Result := cShellDefault;\r\nend;\r\n\r\nfunction GetShellProcessHandle: THandle;\r\nvar\r\n Pid: Longword;\r\nbegin\r\n Pid := GetPidFromProcessName(GetShellProcessName);\r\n Result := OpenProcess(PROCESS_ALL_ACCESS, False, Pid);\r\n if Result = 0 then\r\n RaiseLastOSError;\r\nend;\r\n\r\n//=== Version Information ====================================================\r\n\r\n{ Q159/238\r\n\r\n Windows 95 retail, OEM 4.00.950 7/11/95\r\n Windows 95 retail SP1 4.00.950A 7/11/95-12/31/95\r\n OEM Service Release 2 4.00.1111* (4.00.950B) 8/24/96\r\n OEM Service Release 2.1 4.03.1212-1214* (4.00.950B) 8/24/96-8/27/97\r\n OEM Service Release 2.5 4.03.1214* (4.00.950C) 8/24/96-11/18/97\r\n Windows 98 retail, OEM 4.10.1998 5/11/98\r\n Windows 98 Second Edition 4.10.2222A 4/23/99\r\n Windows Millennium 4.90.3000\r\n}\r\n{ TODO : Distinquish between all these different releases? }\r\n\r\nvar\r\n KernelVersionHi: DWORD;\r\n\r\nfunction GetWindowsVersion: TWindowsVersion;\r\nvar\r\n TrimmedWin32CSDVersion: string;\r\n SystemInfo: TSystemInfo;\r\n OSVersionInfoEx: TOSVersionInfoEx;\r\nconst\r\n SM_SERVERR2 = 89;\r\nbegin\r\n Result := wvUnknown;\r\n TrimmedWin32CSDVersion := Trim(Win32CSDVersion);\r\n case Win32Platform of\r\n VER_PLATFORM_WIN32_WINDOWS:\r\n case Win32MinorVersion of\r\n 0..9:\r\n if (TrimmedWin32CSDVersion = 'B') or (TrimmedWin32CSDVersion = 'C') then\r\n Result := wvWin95OSR2\r\n else\r\n Result := wvWin95;\r\n 10..89:\r\n // On Windows ME Win32MinorVersion can be 10 (indicating Windows 98\r\n // under certain circumstances (image name is setup.exe). Checking\r\n // the kernel version is one way of working around that.\r\n if KernelVersionHi = $0004005A then // 4.90.x.x\r\n Result := wvWinME\r\n else\r\n if (TrimmedWin32CSDVersion = 'A') or (TrimmedWin32CSDVersion = 'B') then\r\n Result := wvWin98SE\r\n else\r\n Result := wvWin98;\r\n 90:\r\n Result := wvWinME;\r\n end;\r\n VER_PLATFORM_WIN32_NT:\r\n case Win32MajorVersion of\r\n 3:\r\n case Win32MinorVersion of\r\n 1:\r\n Result := wvWinNT31;\r\n 5:\r\n Result := wvWinNT35;\r\n 51:\r\n Result := wvWinNT351;\r\n end;\r\n 4:\r\n Result := wvWinNT4;\r\n 5:\r\n case Win32MinorVersion of\r\n 0:\r\n Result := wvWin2000;\r\n 1:\r\n Result := wvWinXP;\r\n 2:\r\n begin\r\n OSVersionInfoEx.dwOSVersionInfoSize := SizeOf(OSVersionInfoEx);\r\n SystemInfo.dwOemId := 0;\r\n GetNativeSystemInfo(SystemInfo);\r\n if GetSystemMetrics(SM_SERVERR2) <> 0 then\r\n Result := wvWin2003R2\r\n else\r\n if (SystemInfo.wProcessorArchitecture <> PROCESSOR_ARCHITECTURE_INTEL) and\r\n GetVersionEx(OSVersionInfoEx) and (OSVersionInfoEx.wProductType = VER_NT_WORKSTATION) then\r\n Result := wvWinXP64\r\n else\r\n Result := wvWin2003;\r\n end;\r\n end;\r\n 6:\r\n case Win32MinorVersion of\r\n 0:\r\n begin\r\n OSVersionInfoEx.dwOSVersionInfoSize := SizeOf(OSVersionInfoEx);\r\n if GetVersionEx(OSVersionInfoEx) and (OSVersionInfoEx.wProductType = VER_NT_WORKSTATION) then\r\n Result := wvWinVista\r\n else\r\n Result := wvWinServer2008;\r\n end;\r\n 1:\r\n begin\r\n OSVersionInfoEx.dwOSVersionInfoSize := SizeOf(OSVersionInfoEx);\r\n if GetVersionEx(OSVersionInfoEx) and (OSVersionInfoEx.wProductType = VER_NT_WORKSTATION) then\r\n Result := wvWin7\r\n else\r\n Result := wvWinServer2008R2;\r\n end;\r\n 2:\r\n begin\r\n OSVersionInfoEx.dwOSVersionInfoSize := SizeOf(OSVersionInfoEx);\r\n if GetVersionEx(OSVersionInfoEx) and (OSVersionInfoEx.wProductType = VER_NT_WORKSTATION) then\r\n Result := wvWin8\r\n else\r\n Result := wvWinServer2012;\r\n end;\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction GetWindowsEdition: TWindowsEdition;\r\nconst\r\n ProductName = 'SOFTWARE\\Microsoft\\Windows NT\\CurrentVersion';\r\nvar\r\n Edition: string;\r\nbegin\r\n Result := weUnknown;\r\n Edition := RegReadStringDef(HKEY_LOCAL_MACHINE, ProductName, 'ProductName', '');\r\n if (pos('Windows XP', Edition) = 1) then\r\n begin\r\n // Windows XP Editions\r\n if (pos('Home Edition N', Edition) > 0) then\r\n Result := weWinXPHomeN\r\n else\r\n if (pos('Professional N', Edition) > 0) then\r\n Result := weWinXPProN\r\n else\r\n if (pos('Home Edition K', Edition) > 0) then\r\n Result := weWinXPHomeK\r\n else\r\n if (pos('Professional K', Edition) > 0) then\r\n Result := weWinXPProK\r\n else\r\n if (pos('Home Edition KN', Edition) > 0) then\r\n Result := weWinXPHomeKN\r\n else\r\n if (pos('Professional KN', Edition) > 0) then\r\n Result := weWinXPProKN\r\n else\r\n if (pos('Home', Edition) > 0) then\r\n Result := weWinXPHome\r\n else\r\n if (pos('Professional', Edition) > 0) then\r\n Result := weWinXPPro\r\n else\r\n if (pos('Starter', Edition) > 0) then\r\n Result := weWinXPStarter\r\n else\r\n if (pos('Media Center', Edition) > 0) then\r\n Result := weWinXPMediaCenter\r\n else\r\n if (pos('Tablet', Edition) > 0) then\r\n Result := weWinXPTablet;\r\n end\r\n else\r\n if (pos('Windows Vista', Edition) = 1) then\r\n begin\r\n // Windows Vista Editions\r\n if (pos('Starter', Edition) > 0) then\r\n Result := weWinVistaStarter\r\n else\r\n if (pos('Home Basic N', Edition) > 0) then\r\n Result := weWinVistaHomeBasicN\r\n else\r\n if (pos('Home Basic', Edition) > 0) then\r\n Result := weWinVistaHomeBasic\r\n else\r\n if (pos('Home Premium', Edition) > 0) then\r\n Result := weWinVistaHomePremium\r\n else\r\n if (pos('Business N', Edition) > 0) then\r\n Result := weWinVistaBusinessN\r\n else\r\n if (pos('Business', Edition) > 0) then\r\n Result := weWinVistaBusiness\r\n else\r\n if (pos('Enterprise', Edition) > 0) then\r\n Result := weWinVistaEnterprise\r\n else\r\n if (pos('Ultimate', Edition) > 0) then\r\n Result := weWinVistaUltimate;\r\n end\r\n else\r\n if (pos('Windows 7', Edition) = 1) then\r\n begin\r\n // Windows 7 Editions\r\n if (pos('Starter', Edition) > 0) then\r\n Result := weWin7Starter\r\n else\r\n if (pos('Home Basic', Edition) > 0) then\r\n Result := weWin7HomeBasic\r\n else\r\n if (pos('Home Premium', Edition) > 0) then\r\n Result := weWin7HomePremium\r\n else\r\n if (pos('Professional', Edition) > 0) then\r\n Result := weWin7Professional\r\n else\r\n if (pos('Enterprise', Edition) > 0) then\r\n Result := weWin7Enterprise\r\n else\r\n if (pos('Ultimate', Edition) > 0) then\r\n Result := weWin7Ultimate;\r\n end\r\n else\r\n if (pos('Windows 8', Edition) = 1) then\r\n begin\r\n // Windows 8 Editions\r\n if (pos('Pro', Edition) > 0) then\r\n Result := weWin8Pro\r\n else\r\n if (pos('Enterprise', Edition) > 0) then\r\n Result := weWin8Enterprise\r\n else\r\n if (pos('Ultimate', Edition) > 0) then\r\n Result := weWin8Ultimate\r\n else\r\n Result := weWin8;\r\n end\r\n else\r\n if (pos('Windows RT', Edition) = 1) then\r\n Result := weWin8RT;\r\nend;\r\n\r\nfunction NtProductType: TNtProductType;\r\nconst\r\n ProductType = 'SYSTEM\\CurrentControlSet\\Control\\ProductOptions';\r\nvar\r\n Product: string;\r\n OSVersionInfo: TOSVersionInfoEx;\r\n SystemInfo: TSystemInfo;\r\nbegin\r\n Result := ptUnknown;\r\n ResetMemory(OSVersionInfo, SizeOf(OSVersionInfo));\r\n ResetMemory(SystemInfo, SizeOf(SystemInfo));\r\n OSVersionInfo.dwOSVersionInfoSize := SizeOf(OSVersionInfo);\r\n GetNativeSystemInfo(SystemInfo);\r\n\r\n // Favor documented API over registry\r\n if IsWinNT4 and (GetWindowsServicePackVersion >= 6) then\r\n begin\r\n if GetVersionEx(OSVersionInfo) then\r\n begin\r\n if (OSVersionInfo.wProductType = VER_NT_WORKSTATION) then\r\n Result := ptWorkstation\r\n else\r\n if (OSVersionInfo.wSuiteMask and VER_SUITE_ENTERPRISE) = VER_SUITE_ENTERPRISE then\r\n Result := ptEnterprise\r\n else\r\n Result := ptServer;\r\n end;\r\n end\r\n else\r\n if IsWin2K then\r\n begin\r\n if GetVersionEx(OSVersionInfo) then\r\n begin\r\n if OSVersionInfo.wProductType in [VER_NT_SERVER,VER_NT_DOMAIN_CONTROLLER] then\r\n begin\r\n if (OSVersionInfo.wSuiteMask and VER_SUITE_DATACENTER) <> 0 then\r\n Result := ptDatacenterServer\r\n else\r\n if (OSVersionInfo.wSuiteMask and VER_SUITE_ENTERPRISE) <> 0 then\r\n Result := ptAdvancedServer\r\n else\r\n Result := ptServer;\r\n end\r\n else\r\n Result := ptProfessional;\r\n end;\r\n end\r\n else\r\n if IsWinXP64 or IsWin2003 or IsWin2003R2 then // all (5.2)\r\n begin\r\n if GetVersionEx(OSVersionInfo) then\r\n begin\r\n if OSVersionInfo.wProductType in [VER_NT_SERVER,VER_NT_DOMAIN_CONTROLLER] then\r\n begin\r\n if (OSVersionInfo.wSuiteMask and VER_SUITE_DATACENTER) = VER_SUITE_DATACENTER then\r\n Result := ptDatacenterServer\r\n else\r\n if (OSVersionInfo.wSuiteMask and VER_SUITE_ENTERPRISE) = VER_SUITE_ENTERPRISE then\r\n Result := ptEnterprise\r\n else\r\n if (OSVersionInfo.wSuiteMask = VER_SUITE_BLADE) then\r\n Result := ptWebEdition\r\n else\r\n Result := ptServer;\r\n end\r\n else\r\n if (OSVersionInfo.wProductType = VER_NT_WORKSTATION) then\r\n Result := ptProfessional;\r\n end;\r\n end\r\n else\r\n if IsWinXP or IsWinVista or IsWin7 then // workstation\r\n begin\r\n if GetVersionEx(OSVersionInfo) then\r\n begin\r\n if OSVersionInfo.wProductType = VER_NT_WORKSTATION then\r\n begin\r\n if (OSVersionInfo.wSuiteMask and VER_SUITE_PERSONAL) = VER_SUITE_PERSONAL then\r\n Result := ptPersonal\r\n else\r\n Result := ptProfessional;\r\n end;\r\n end;\r\n end\r\n else\r\n if IsWinServer2008 or IsWinServer2008R2 then // server\r\n begin\r\n if OSVersionInfo.wProductType in [VER_NT_SERVER,VER_NT_DOMAIN_CONTROLLER] then\r\n begin\r\n if (OSVersionInfo.wSuiteMask and VER_SUITE_DATACENTER) = VER_SUITE_DATACENTER then\r\n Result := ptDatacenterServer\r\n else\r\n if (OSVersionInfo.wSuiteMask and VER_SUITE_ENTERPRISE) = VER_SUITE_ENTERPRISE then\r\n Result := ptEnterprise\r\n else\r\n Result := ptServer;\r\n end;\r\n end;\r\n\r\n if Result = ptUnknown then\r\n begin\r\n // Non Windows 2000/XP system or the above method failed, try registry\r\n Product := RegReadStringDef(HKEY_LOCAL_MACHINE, ProductType, 'ProductType', '');\r\n if CompareText(Product, 'WINNT') = 0 then\r\n Result := ptWorkStation\r\n else\r\n if CompareText(Product, 'SERVERNT') = 0 then\r\n Result := {ptServer} ptAdvancedServer\r\n else\r\n if CompareText(Product, 'LANMANNT') = 0 then\r\n Result := {ptAdvancedServer} ptServer\r\n else\r\n Result := ptUnknown;\r\n end;\r\nend;\r\n\r\nfunction GetWindowsVersionString: string;\r\nbegin\r\n case GetWindowsVersion of\r\n wvWin95:\r\n Result := LoadResString(@RsOSVersionWin95);\r\n wvWin95OSR2:\r\n Result := LoadResString(@RsOSVersionWin95OSR2);\r\n wvWin98:\r\n Result := LoadResString(@RsOSVersionWin98);\r\n wvWin98SE:\r\n Result := LoadResString(@RsOSVersionWin98SE);\r\n wvWinME:\r\n Result := LoadResString(@RsOSVersionWinME);\r\n wvWinNT31, wvWinNT35, wvWinNT351:\r\n Result := Format(LoadResString(@RsOSVersionWinNT3), [Win32MinorVersion]);\r\n wvWinNT4:\r\n Result := Format(LoadResString(@RsOSVersionWinNT4), [Win32MinorVersion]);\r\n wvWin2000:\r\n Result := LoadResString(@RsOSVersionWin2000);\r\n wvWinXP:\r\n Result := LoadResString(@RsOSVersionWinXP);\r\n wvWin2003:\r\n Result := LoadResString(@RsOSVersionWin2003);\r\n wvWin2003R2:\r\n Result := LoadResString(@RsOSVersionWin2003R2);\r\n wvWinXP64:\r\n Result := LoadResString(@RsOSVersionWinXP64);\r\n wvWinVista:\r\n Result := LoadResString(@RsOSVersionWinVista);\r\n wvWinServer2008:\r\n Result := LoadResString(@RsOSVersionWinServer2008);\r\n wvWin7:\r\n Result := LoadResString(@RsOSVersionWin7);\r\n wvWinServer2008R2:\r\n Result := LoadResString(@RsOSVersionWinServer2008R2);\r\n wvWin8:\r\n Result := LoadResString(@RsOSVersionWin8);\r\n wvWinServer2012:\r\n Result := LoadResString(@RsOSVersionWinServer2012);\r\n else\r\n Result := '';\r\n end;\r\nend;\r\n\r\nfunction GetWindowsEditionString: string;\r\nbegin\r\n case GetWindowsEdition of\r\n weWinXPHome:\r\n Result := LoadResString(@RsEditionWinXPHome);\r\n weWinXPPro:\r\n Result := LoadResString(@RsEditionWinXPPro);\r\n weWinXPHomeN:\r\n Result := LoadResString(@RsEditionWinXPHomeN);\r\n weWinXPProN:\r\n Result := LoadResString(@RsEditionWinXPProN);\r\n weWinXPHomeK:\r\n Result := LoadResString(@RsEditionWinXPHomeK);\r\n weWinXPProK:\r\n Result := LoadResString(@RsEditionWinXPProK);\r\n weWinXPHomeKN:\r\n Result := LoadResString(@RsEditionWinXPHomeKN);\r\n weWinXPProKN:\r\n Result := LoadResString(@RsEditionWinXPProKN);\r\n weWinXPStarter:\r\n Result := LoadResString(@RsEditionWinXPStarter);\r\n weWinXPMediaCenter:\r\n Result := LoadResString(@RsEditionWinXPMediaCenter);\r\n weWinXPTablet:\r\n Result := LoadResString(@RsEditionWinXPTablet);\r\n weWinVistaStarter:\r\n Result := LoadResString(@RsEditionWinVistaStarter);\r\n weWinVistaHomeBasic:\r\n Result := LoadResString(@RsEditionWinVistaHomeBasic);\r\n weWinVistaHomeBasicN:\r\n Result := LoadResString(@RsEditionWinVistaHomeBasicN);\r\n weWinVistaHomePremium:\r\n Result := LoadResString(@RsEditionWinVistaHomePremium);\r\n weWinVistaBusiness:\r\n Result := LoadResString(@RsEditionWinVistaBusiness);\r\n weWinVistaBusinessN:\r\n Result := LoadResString(@RsEditionWinVistaBusinessN);\r\n weWinVistaEnterprise:\r\n Result := LoadResString(@RsEditionWinVistaEnterprise);\r\n weWinVistaUltimate:\r\n Result := LoadResString(@RsEditionWinVistaUltimate);\r\n weWin7Starter:\r\n Result := LoadResString(@RsEditionWin7Starter);\r\n weWin7HomeBasic:\r\n Result := LoadResString(@RsEditionWin7HomeBasic);\r\n weWin7HomePremium:\r\n Result := LoadResString(@RsEditionWin7HomePremium);\r\n weWin7Professional:\r\n Result := LoadResString(@RsEditionWin7Professional);\r\n weWin7Enterprise:\r\n Result := LoadResString(@RsEditionWin7Enterprise);\r\n weWin7Ultimate:\r\n Result := LoadResString(@RsEditionWin7Ultimate);\r\n else\r\n Result := '';\r\n end;\r\nend;\r\n\r\nfunction GetWindowsProductString: string;\r\nbegin\r\n Result := GetWindowsVersionString;\r\n if (GetWindowsEditionString <> '') then\r\n Result := Result + ' ' + GetWindowsEditionString;\r\nend;\r\n\r\nfunction NtProductTypeString: string;\r\nbegin\r\n case NtProductType of\r\n ptWorkStation:\r\n Result := LoadResString(@RsProductTypeWorkStation);\r\n ptServer:\r\n Result := LoadResString(@RsProductTypeServer);\r\n ptAdvancedServer:\r\n Result := LoadResString(@RsProductTypeAdvancedServer);\r\n ptPersonal:\r\n Result := LoadResString(@RsProductTypePersonal);\r\n ptProfessional:\r\n Result := LoadResString(@RsProductTypeProfessional);\r\n ptDatacenterServer:\r\n Result := LoadResString(@RsProductTypeDatacenterServer);\r\n ptEnterprise:\r\n Result := LoadResString(@RsProductTypeEnterprise);\r\n ptWebEdition:\r\n Result := LoadResString(@RsProductTypeWebEdition);\r\n else\r\n Result := '';\r\n end;\r\nend;\r\n\r\nfunction GetWindowsServicePackVersion: Integer;\r\nconst\r\n RegWindowsControl = 'SYSTEM\\CurrentControlSet\\Control\\Windows';\r\nvar\r\n SP: Integer;\r\n VersionInfo: TOSVersionInfoEx;\r\nbegin\r\n Result := 0;\r\n if (Win32Platform = VER_PLATFORM_WIN32_NT) and (Win32MajorVersion >= 5) then\r\n begin\r\n ResetMemory(VersionInfo, SizeOf(VersionInfo));\r\n VersionInfo.dwOSVersionInfoSize := SizeOf(VersionInfo);\r\n if GetVersionEx(VersionInfo) then\r\n Result := VersionInfo.wServicePackMajor;\r\n end\r\n else\r\n begin\r\n SP := RegReadIntegerDef(HKEY_LOCAL_MACHINE, RegWindowsControl, 'CSDVersion', 0);\r\n Result := StrToInt(IntToHex(SP, 4)) div 100;\r\n end;\r\nend;\r\n\r\nfunction GetWindowsServicePackVersionString: string;\r\nvar\r\n SP: Integer;\r\nbegin\r\n SP := GetWindowsServicePackVersion;\r\n if SP > 0 then\r\n Result := Format(LoadResString(@RsSPInfo), [SP])\r\n else\r\n Result := '';\r\nend;\r\n\r\n// Imports copied from OpenGL unit. Direct using of OpenGL unit might cause unexpected problems due\r\n// setting 8087CW in the intialization section\r\n{\r\nfunction glGetString(name: Cardinal): PChar; stdcall; external opengl32;\r\nfunction glGetError: Cardinal; stdcall; external opengl32;\r\nfunction gluErrorString(errCode: Cardinal): PChar; stdcall; external 'glu32.dll';\r\n}\r\n\r\ntype\r\n TglGetStringFunc = function(name: Cardinal): PAnsiChar; stdcall;\r\n TglGetErrorFunc = function: Cardinal; stdcall;\r\n TgluErrorStringFunc = function(errCode: Cardinal): PAnsiChar; stdcall;\r\n\r\n TwglCreateContextFunc = function(DC: HDC): HGLRC; stdcall;\r\n TwglDeleteContextFunc = function(p1: HGLRC): BOOL; stdcall;\r\n TwglMakeCurrentFunc = function(DC: HDC; p2: HGLRC): BOOL; stdcall;\r\n\r\nconst\r\n glu32 = 'glu32.dll'; // do not localize\r\n glGetStringName = 'glGetString'; // do not localize\r\n glGetErrorName = 'glGetError'; // do not localize\r\n gluErrorStringName = 'gluErrorString'; // do not localize\r\n wglCreateContextName = 'wglCreateContext'; // do not localize\r\n wglDeleteContextName = 'wglDeleteContext'; // do not localize\r\n wglMakeCurrentName = 'wglMakeCurrent'; // do not localize\r\n ChoosePixelFormatName = 'ChoosePixelFormat'; // do not localize\r\n SetPixelFormatName = 'SetPixelFormat'; // do not localize\r\n\r\nfunction GetOpenGLVersion(const Win: THandle; out Version, Vendor: AnsiString): Boolean;\r\nconst\r\n GL_NO_ERROR = 0;\r\n GL_VENDOR = $1F00;\r\n GL_VERSION = $1F02;\r\nvar\r\n OpenGlLib, Glu32Lib: HModule;\r\n\r\n glGetStringFunc: TglGetStringFunc;\r\n glGetErrorFunc: TglGetErrorFunc;\r\n gluErrorStringFunc: TgluErrorStringFunc;\r\n\r\n wglCreateContextFunc: TwglCreateContextFunc;\r\n wglDeleteContextFunc: TwglDeleteContextFunc;\r\n wglMakeCurrentFunc: TwglMakeCurrentFunc;\r\n\r\n pfd: TPixelFormatDescriptor;\r\n iFormatIndex: Integer;\r\n hGLContext: HGLRC;\r\n hGLDC: HDC;\r\n pcTemp: PAnsiChar;\r\n glErr: Cardinal;\r\n bError: Boolean;\r\n sOpenGLVersion, sOpenGLVendor: AnsiString;\r\n Save8087CW: Word;\r\n\r\n procedure FunctionFailedError(Name: string);\r\n begin\r\n raise EJclError.CreateResFmt(@RsEOpenGLInfo, [Name]);\r\n end;\r\n\r\nbegin\r\n @glGetStringFunc := nil;\r\n @glGetErrorFunc := nil;\r\n @gluErrorStringFunc := nil;\r\n\r\n @wglCreateContextFunc := nil;\r\n @wglDeleteContextFunc := nil;\r\n @wglMakeCurrentFunc := nil;\r\n\r\n Glu32Lib := 0;\r\n OpenGlLib := SafeLoadLibrary(opengl32);\r\n try\r\n if OpenGlLib <> 0 then\r\n begin\r\n Glu32Lib := SafeLoadLibrary(glu32); // do not localize\r\n if (OpenGlLib <> 0) and (Glu32Lib <> 0) then\r\n begin\r\n glGetStringFunc := GetProcAddress(OpenGlLib, glGetStringName);\r\n glGetErrorFunc := GetProcAddress(OpenGlLib, glGetErrorName);\r\n gluErrorStringFunc := GetProcAddress(Glu32Lib, gluErrorStringName);\r\n\r\n wglCreateContextFunc := GetProcAddress(OpenGlLib, wglCreateContextName);\r\n wglDeleteContextFunc := GetProcAddress(OpenGlLib, wglDeleteContextName);\r\n wglMakeCurrentFunc := GetProcAddress(OpenGlLib, wglMakeCurrentName);\r\n end;\r\n end;\r\n\r\n if not (Assigned(glGetStringFunc) and Assigned(glGetErrorFunc) and Assigned(gluErrorStringFunc) and\r\n Assigned(wglCreateContextFunc) and Assigned(wglDeleteContextFunc) and Assigned(wglMakeCurrentFunc)) then\r\n begin\r\n @glGetStringFunc := nil;\r\n Result := False;\r\n Vendor := AnsiString(LoadResString(@RsOpenGLInfoError));\r\n Version := AnsiString(LoadResString(@RsOpenGLInfoError));\r\n Exit;\r\n end;\r\n\r\n { To call for the version information string we must first have an active\r\n context established for use. We can, of course, close this after use }\r\n Save8087CW := Get8087ControlWord;\r\n try\r\n Set8087CW($133F);\r\n hGLContext := 0;\r\n Result := False;\r\n bError := False;\r\n\r\n if Win = 0 then\r\n begin\r\n Result := False;\r\n Vendor := AnsiString(LoadResString(@RsOpenGLInfoError));\r\n Version := AnsiString(LoadResString(@RsOpenGLInfoError));\r\n Exit;\r\n end;\r\n\r\n ResetMemory(pfd, SizeOf(pfd));\r\n with pfd do\r\n begin\r\n nSize := SizeOf(pfd);\r\n nVersion := 1; { The Current Version of the descriptor is 1 }\r\n dwFlags := PFD_DRAW_TO_WINDOW or PFD_SUPPORT_OPENGL;\r\n iPixelType := PFD_TYPE_RGBA;\r\n cColorBits := 24; { support 24-bit colour }\r\n cDepthBits := 32; { Depth of the z-buffer }\r\n iLayerType := PFD_MAIN_PLANE;\r\n end;\r\n\r\n hGLDC := GetDC(Win);\r\n try\r\n iFormatIndex := ChoosePixelFormat(hGLDC, @pfd);\r\n if iFormatIndex = 0 then\r\n FunctionFailedError(ChoosePixelFormatName);\r\n\r\n if not SetPixelFormat(hGLDC, iFormatIndex, @pfd) then\r\n FunctionFailedError(SetPixelFormatName);\r\n\r\n hGLContext := wglCreateContextFunc(hGLDC);\r\n if hGLContext = 0 then\r\n FunctionFailedError(wglCreateContextName);\r\n\r\n if not wglMakeCurrentFunc(hGLDC, hGLContext) then\r\n FunctionFailedError(wglMakeCurrentName);\r\n\r\n { TODO : Review the following. Not sure I am 100% happy with this code\r\n in its current structure. }\r\n pcTemp := glGetStringFunc(GL_VERSION);\r\n if pcTemp <> nil then\r\n begin\r\n { TODO : Store this information in a Global Variable, and return that??\r\n This would save this work being performed again with later calls }\r\n sOpenGLVersion := StrPas(pcTemp);\r\n end\r\n else\r\n begin\r\n bError := True;\r\n glErr := glGetErrorFunc;\r\n if glErr <> GL_NO_ERROR then\r\n begin\r\n sOpenGLVersion := gluErrorStringFunc(glErr);\r\n sOpenGLVendor := '';\r\n end;\r\n end;\r\n\r\n pcTemp := glGetStringFunc(GL_VENDOR);\r\n if pcTemp <> nil then\r\n begin\r\n { TODO : Store this information in a Global Variable, and return that??\r\n This would save this work being performed again with later calls }\r\n sOpenGLVendor := StrPas(pcTemp);\r\n end\r\n else\r\n begin\r\n bError := True;\r\n glErr := glGetErrorFunc;\r\n if glErr <> GL_NO_ERROR then\r\n begin\r\n sOpenGLVendor := gluErrorStringFunc(glErr);\r\n Exit;\r\n end;\r\n end;\r\n\r\n Result := (not bError);\r\n Version := sOpenGLVersion;\r\n Vendor := sOpenGLVendor;\r\n finally\r\n { Close all resources }\r\n wglMakeCurrentFunc(hGLDC, 0);\r\n if hGLContext <> 0 then\r\n wglDeleteContextFunc(hGLContext);\r\n end;\r\n finally\r\n Set8087CW(Save8087CW);\r\n end;\r\n finally\r\n if (OpenGlLib <> 0) then\r\n FreeLibrary(OpenGlLib);\r\n if (Glu32Lib <> 0) then\r\n FreeLibrary(Glu32Lib);\r\n end;\r\nend;\r\n\r\nfunction GetNativeSystemInfo(var SystemInfo: TSystemInfo): Boolean;\r\ntype\r\n TGetNativeSystemInfo = procedure (var SystemInfo: TSystemInfo); stdcall;\r\nvar\r\n LibraryHandle: HMODULE;\r\n _GetNativeSystemInfo: TGetNativeSystemInfo;\r\nbegin\r\n Result := False;\r\n LibraryHandle := GetModuleHandle(kernel32);\r\n\r\n if LibraryHandle <> 0 then\r\n begin\r\n _GetNativeSystemInfo := GetProcAddress(LibraryHandle,'GetNativeSystemInfo');\r\n if Assigned(_GetNativeSystemInfo) then\r\n begin\r\n _GetNativeSystemInfo(SystemInfo);\r\n Result := True;\r\n end\r\n else\r\n GetSystemInfo(SystemInfo);\r\n end\r\n else\r\n GetSystemInfo(SystemInfo);\r\nend;\r\n\r\nfunction GetProcessorArchitecture: TProcessorArchitecture;\r\nvar\r\n ASystemInfo: TSystemInfo;\r\nbegin\r\n ASystemInfo.dwOemId := 0;\r\n GetNativeSystemInfo(ASystemInfo);\r\n case ASystemInfo.wProcessorArchitecture of\r\n PROCESSOR_ARCHITECTURE_INTEL:\r\n Result := pax8632;\r\n PROCESSOR_ARCHITECTURE_IA64:\r\n Result := paIA64;\r\n PROCESSOR_ARCHITECTURE_AMD64:\r\n Result := pax8664;\r\n else\r\n Result := paUnknown;\r\n end;\r\nend;\r\n\r\nfunction IsWindows64: Boolean;\r\nvar\r\n ASystemInfo: TSystemInfo;\r\nbegin\r\n ASystemInfo.dwOemId := 0;\r\n GetNativeSystemInfo(ASystemInfo);\r\n Result := ASystemInfo.wProcessorArchitecture in [PROCESSOR_ARCHITECTURE_IA64,PROCESSOR_ARCHITECTURE_AMD64];\r\nend;\r\n\r\n{$ENDIF MSWINDOWS}\r\n\r\nfunction GetOSVersionString: string;\r\n{$IFDEF UNIX}\r\nvar\r\n MachineInfo: utsname;\r\nbegin\r\n uname(MachineInfo);\r\n Result := Format('%s %s', [MachineInfo.sysname, MachineInfo.release]);\r\nend;\r\n{$ENDIF UNIX}\r\n{$IFDEF MSWINDOWS}\r\nbegin\r\n Result := Format('%s %s', [GetWindowsVersionString, GetWindowsServicePackVersionString]);\r\nend;\r\n{$ENDIF MSWINDOWS}\r\n\r\n//=== Hardware ===============================================================\r\n\r\n// Helper function for GetMacAddress()\r\n// Converts the adapter_address array to a string\r\n\r\nfunction AdapterToString(Adapter: PJclByteArray): string;\r\nbegin\r\n Result := Format('%2.2x-%2.2x-%2.2x-%2.2x-%2.2x-%2.2x',\r\n [Integer(Adapter[0]), Integer(Adapter[1]),\r\n Integer(Adapter[2]), Integer(Adapter[3]),\r\n Integer(Adapter[4]), Integer(Adapter[5])]);\r\nend;\r\n\r\n{ TODO: RTLD version of NetBios }\r\n{$IFDEF MSWINDOWS}\r\ntype\r\n TNetBios = function(P: PNCB): Byte; stdcall;\r\n\r\nvar\r\n NetBiosLib: HINST = 0;\r\n _NetBios: TNetBios;\r\n {$IFDEF FPC}\r\n NullAdapterAddress: array [0..5] of Byte = ($00, $00, $00, $00, $00, $00);\r\n OID_ipMACEntAddr: array [0..9] of UINT = (1, 3, 6, 1, 2, 1, 2, 2, 1, 6);\r\n OID_ifEntryType: array [0..9] of UINT = (1, 3, 6, 1, 2, 1, 2, 2, 1, 3);\r\n OID_ifEntryNum: array [0..7] of UINT = (1, 3, 6, 1, 2, 1, 2, 1);\r\n {$ENDIF FPC}\r\n\r\nfunction GetMacAddresses(const Machine: string; const Addresses: TStrings): Integer;\r\n\r\n procedure ExitNetbios;\r\n begin\r\n if NetBiosLib <> 0 then\r\n begin\r\n FreeLibrary(NetBiosLib);\r\n NetBiosLib := 0;\r\n end;\r\n end;\r\n\r\n function InitNetbios: Boolean;\r\n begin\r\n Result := True;\r\n if NetBiosLib = 0 then\r\n begin\r\n NetBiosLib := SafeLoadLibrary('netapi32.dll');\r\n Result := NetBiosLib <> 0;\r\n if Result then\r\n begin\r\n @_NetBios := GetProcAddress(NetBiosLib, PChar('Netbios'));\r\n Result := @_NetBios <> nil;\r\n if not Result then\r\n ExitNetbios;\r\n end;\r\n end;\r\n end;\r\n\r\n function NetBios(P: PNCB): Byte;\r\n begin\r\n if InitNetbios then\r\n Result := _NetBios(P)\r\n else\r\n Result := 1; // anything other than NRC_GOODRET will do\r\n end;\r\n\r\n procedure GetMacAddressesNetBios;\r\n // Platform SDK\r\n // http://msdn.microsoft.com/library/default.asp?url=/library/en-us/netbios/netbios_1l82.asp\r\n\r\n // Microsoft Knowledge Base Article - 118623\r\n // HOWTO: Get the MAC Address for an Ethernet Adapter\r\n // http://support.microsoft.com/default.aspx?scid=kb;en-us;118623\r\n type\r\n AStat = packed record\r\n adapt: TAdapterStatus;\r\n NameBuff: array [0..29] of TNameBuffer;\r\n end;\r\n var\r\n NCB: TNCB;\r\n Enum: TLanaEnum;\r\n I, L, NameLen: Integer;\r\n Adapter: AStat;\r\n MachineName: AnsiString;\r\n begin\r\n MachineName := AnsiString(UpperCase(Machine));\r\n if MachineName = '' then\r\n MachineName := '*';\r\n NameLen := Length(MachineName);\r\n L := NCBNAMSZ - NameLen;\r\n if L > 0 then\r\n begin\r\n SetLength(MachineName, NCBNAMSZ);\r\n FillChar(MachineName[NameLen + 1], L, ' ');\r\n end;\r\n // From Junior/RO in NG: Microsoft's implementation limits NETBIOS names to 15 characters\r\n MachineName[NCBNAMSZ] := #0;\r\n ResetMemory(NCB, SizeOf(NCB));\r\n NCB.ncb_command := NCBENUM;\r\n NCB.ncb_buffer := Pointer(@Enum);\r\n NCB.ncb_length := SizeOf(Enum);\r\n if NetBios(@NCB) = NRC_GOODRET then\r\n begin\r\n Result := Enum.Length;\r\n for I := 0 to Ord(Enum.Length) - 1 do\r\n begin\r\n ResetMemory(NCB, SizeOf(NCB));\r\n NCB.ncb_command := NCBRESET;\r\n NCB.ncb_lana_num := Enum.lana[I];\r\n if NetBios(@NCB) = NRC_GOODRET then\r\n begin\r\n ResetMemory(NCB, SizeOf(NCB));\r\n NCB.ncb_command := NCBASTAT;\r\n NCB.ncb_lana_num := Enum.lana[I];\r\n Move(MachineName[1], NCB.ncb_callname, SizeOf(NCB.ncb_callname));\r\n NCB.ncb_buffer := PUCHAR(@Adapter);\r\n NCB.ncb_length := SizeOf(Adapter);\r\n if NetBios(@NCB) = NRC_GOODRET then\r\n Addresses.Add(AdapterToString(@Adapter.adapt));\r\n end;\r\n end;\r\n end;\r\n end;\r\n\r\n procedure GetMacAddressesSnmp;\r\n const\r\n InetMib1 = 'inetmib1.dll';\r\n {$IFNDEF FPC // can't resolve address of const }\r\n NullAdapterAddress: array [0..5] of Byte = ($00, $00, $00, $00, $00, $00);\r\n OID_ipMACEntAddr: array [0..9] of UINT = (1, 3, 6, 1, 2, 1, 2, 2, 1, 6);\r\n OID_ifEntryType: array [0..9] of UINT = (1, 3, 6, 1, 2, 1, 2, 2, 1, 3);\r\n OID_ifEntryNum: array [0..7] of UINT = (1, 3, 6, 1, 2, 1, 2, 1);\r\n {$ENDIF ~FPC}\r\n var\r\n PollForTrapEvent: THandle;\r\n SupportedView: PAsnObjectIdentifier;\r\n MIB_ifMACEntAddr: TAsnObjectIdentifier;\r\n MIB_ifEntryType: TAsnObjectIdentifier;\r\n MIB_ifEntryNum: TAsnObjectIdentifier;\r\n VarBindList: TSnmpVarBindList;\r\n VarBind: array [0..1] of TSnmpVarBind;\r\n ErrorStatus, ErrorIndex: TAsnInteger32;\r\n DTmp: Integer;\r\n Ret: Boolean;\r\n MAC: PJclByteArray;\r\n begin\r\n if LoadSnmp then\r\n try\r\n if LoadSnmpExtension(InetMib1) then\r\n try\r\n MIB_ifMACEntAddr.idLength := Length(OID_ipMACEntAddr);\r\n MIB_ifMACEntAddr.ids := @OID_ipMACEntAddr;\r\n MIB_ifEntryType.idLength := Length(OID_ifEntryType);\r\n MIB_ifEntryType.ids := @OID_ifEntryType;\r\n MIB_ifEntryNum.idLength := Length(OID_ifEntryNum);\r\n MIB_ifEntryNum.ids := @OID_ifEntryNum;\r\n PollForTrapEvent := 0;\r\n SupportedView := nil;\r\n if SnmpExtensionInit(GetTickCount, PollForTrapEvent, SupportedView) then\r\n begin\r\n VarBindList.list := @VarBind[0];\r\n VarBind[0].name := DEFINE_NULLOID;\r\n VarBind[1].name := DEFINE_NULLOID;\r\n VarBindList.len := 1;\r\n SnmpUtilOidCpy(@VarBind[0].name, @MIB_ifEntryNum);\r\n ErrorIndex := 0;\r\n ErrorStatus := 0;\r\n Ret := SnmpExtensionQuery(SNMP_PDU_GETNEXT, VarBindList, ErrorStatus, ErrorIndex);\r\n if Ret then\r\n begin\r\n Result := VarBind[0].value.number;\r\n VarBindList.len := 2;\r\n SnmpUtilOidCpy(@VarBind[0].name, @MIB_ifEntryType);\r\n SnmpUtilOidCpy(@VarBind[1].name, @MIB_ifMACEntAddr);\r\n while Ret do\r\n begin\r\n Ret := SnmpExtensionQuery(SNMP_PDU_GETNEXT, VarBindList, ErrorStatus, ErrorIndex);\r\n if Ret then\r\n begin\r\n Ret := SnmpUtilOidNCmp(@VarBind[0].name, @MIB_ifEntryType, MIB_ifEntryType.idLength) = SNMP_ERRORSTATUS_NOERROR;\r\n if Ret then\r\n begin\r\n DTmp := VarBind[0].value.number;\r\n if DTmp = 6 then\r\n begin\r\n Ret := SnmpUtilOidNCmp(@VarBind[1].name, @MIB_ifMACEntAddr, MIB_ifMACEntAddr.idLength) = SNMP_ERRORSTATUS_NOERROR;\r\n if Ret and (VarBind[1].value.address.stream <> nil) then\r\n begin\r\n MAC := PJclByteArray(VarBind[1].value.address.stream);\r\n if not CompareMem(MAC, @NullAdapterAddress, SizeOf(NullAdapterAddress)) then\r\n Addresses.Add(AdapterToString(MAC));\r\n end;\r\n end;\r\n end;\r\n end;\r\n end;\r\n end;\r\n SnmpUtilVarBindFree(@VarBind[0]);\r\n SnmpUtilVarBindFree(@VarBind[1]);\r\n end;\r\n finally\r\n UnloadSnmpExtension;\r\n end;\r\n finally\r\n UnloadSnmp;\r\n end;\r\n end;\r\n\r\nbegin\r\n Result := -1;\r\n Addresses.BeginUpdate;\r\n try\r\n Addresses.Clear;\r\n GetMacAddressesNetBios;\r\n if (Result <= 0) and (Machine = '') then\r\n GetMacAddressesSnmp;\r\n finally\r\n Addresses.EndUpdate;\r\n end;\r\nend;\r\n{$ENDIF MSWINDOWS}\r\nfunction ReadTimeStampCounter: Int64; assembler;\r\nasm\r\n DW $310F\r\n // TSC in EDX:EAX\r\n {$IFDEF CPU64}\r\n SHL RDX, 32\r\n OR RAX, RDX\r\n // Result in RAX\r\n {$ENDIF CPU64}\r\nend;\r\n\r\nfunction GetIntelCacheDescription(const D: Byte): string;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := '';\r\n if D <> 0 then\r\n for I := Low(IntelCacheDescription) to High(IntelCacheDescription) do\r\n if IntelCacheDescription[I].D = D then\r\n begin\r\n Result := LoadResString(IntelCacheDescription[I].I);\r\n Break;\r\n end;\r\n // (outchy) added a return value for unknow D value\r\n if Result = '' then\r\n Result := Format(LoadResString(@RsIntelUnknownCache),[D]);\r\nend;\r\n\r\nprocedure GetCpuInfo(var CpuInfo: TCpuInfo);\r\nbegin\r\n CpuInfo := CPUID;\r\n CpuInfo.IsFDIVOK := TestFDIVInstruction;\r\n if CpuInfo.HasInstruction then\r\n begin\r\n {$IFDEF MSWINDOWS}\r\n if (CpuInfo.Features and TSC_FLAG) = TSC_FLAG then\r\n GetCpuSpeed(CpuInfo.FrequencyInfo);\r\n {$ENDIF MSWINDOWS}\r\n end;\r\nend;\r\n\r\nfunction RoundFrequency(const Frequency: Integer): Integer;\r\nconst\r\n NF: array [0..8] of Integer = (0, 20, 33, 50, 60, 66, 80, 90, 100);\r\nvar\r\n Freq, RF: Integer;\r\n I: Byte;\r\n Hi, Lo: Byte;\r\nbegin\r\n RF := 0;\r\n Freq := Frequency mod 100;\r\n for I := 0 to 8 do\r\n begin\r\n if Freq < NF[I] then\r\n begin\r\n Hi := I;\r\n Lo := I - 1;\r\n if (NF[Hi] - Freq) > (Freq - NF[Lo]) then\r\n RF := NF[Lo] - Freq\r\n else\r\n RF := NF[Hi] - Freq;\r\n Break;\r\n end;\r\n end;\r\n Result := Frequency + RF;\r\nend;\r\n\r\nfunction GetCPUSpeed(var CpuSpeed: TFreqInfo): Boolean;\r\n{$IFDEF UNIX}\r\nbegin\r\n { TODO : GetCPUSpeed: Solution for Linux }\r\n Result := False;\r\nend;\r\n{$ENDIF UNIX}\r\n{$IFDEF MSWINDOWS}\r\n\r\nvar\r\n T0, T1: Int64;\r\n CountFreq: Int64;\r\n Freq, Freq2, Freq3, Total: Int64;\r\n TotalCycles, Cycles: Int64;\r\n Stamp0, Stamp1: Int64;\r\n TotalTicks, Ticks: Double;\r\n Tries, Priority: Integer;\r\n Thread: THandle;\r\nbegin\r\n Stamp0 := 0;\r\n Stamp1 := 0;\r\n Freq := 0;\r\n Freq2 := 0;\r\n Freq3 := 0;\r\n Tries := 0;\r\n TotalCycles := 0;\r\n TotalTicks := 0;\r\n Total := 0;\r\n\r\n Thread := GetCurrentThread();\r\n CountFreq := 0;\r\n Result := QueryPerformanceFrequency(CountFreq);\r\n if Result then\r\n begin\r\n while ((Tries < 3) or ((Tries < 20) and ((Abs(3 * Freq - Total) > 3) or\r\n (Abs(3 * Freq2 - Total) > 3) or (Abs(3 * Freq3 - Total) > 3)))) do\r\n begin\r\n Inc(Tries);\r\n Freq3 := Freq2;\r\n Freq2 := Freq;\r\n T0 := 0;\r\n QueryPerformanceCounter(T0);\r\n T1 := T0;\r\n\r\n Priority := GetThreadPriority(Thread);\r\n if Priority <> THREAD_PRIORITY_ERROR_RETURN then\r\n SetThreadPriority(Thread, THREAD_PRIORITY_TIME_CRITICAL);\r\n try\r\n while T1 - T0 < 50 do\r\n begin\r\n QueryPerformanceCounter(T1);\r\n Stamp0 := ReadTimeStampCounter;\r\n end;\r\n T0 := T1;\r\n\r\n while T1 - T0 < 1000 do\r\n begin\r\n QueryPerformanceCounter(T1);\r\n Stamp1 := ReadTimeStampCounter;\r\n end;\r\n finally\r\n if Priority <> THREAD_PRIORITY_ERROR_RETURN then\r\n SetThreadPriority(Thread, Priority);\r\n end;\r\n\r\n Cycles := Stamp1 - Stamp0;\r\n Ticks := T1 - T0;\r\n Ticks := Ticks * 100000;\r\n\r\n // avoid division by zero\r\n if CountFreq = 0 then\r\n Ticks := High(Int64)\r\n else\r\n Ticks := Ticks / (CountFreq / 10);\r\n\r\n TotalTicks := TotalTicks + Ticks;\r\n TotalCycles := TotalCycles + Cycles;\r\n\r\n // avoid division by zero\r\n if IsZero(Ticks) then\r\n Freq := High(Freq)\r\n else\r\n Freq := Round(Cycles / Ticks);\r\n\r\n Total := Freq + Freq2 + Freq3;\r\n end;\r\n\r\n // avoid division by zero\r\n if IsZero(TotalTicks) then\r\n begin\r\n Freq3 := High(Freq3);\r\n Freq2 := High(Freq2);\r\n CpuSpeed.RawFreq := High(CpuSpeed.RawFreq);\r\n end\r\n else\r\n begin\r\n Freq3 := Round((TotalCycles * 10) / TotalTicks); // freq. in multiples of 10^5 Hz\r\n Freq2 := Round((TotalCycles * 100) / TotalTicks); // freq. in multiples of 10^4 Hz\r\n CpuSpeed.RawFreq := Round(TotalCycles / TotalTicks);\r\n end;\r\n\r\n CpuSpeed.NormFreq := CpuSpeed.RawFreq;\r\n\r\n if Freq2 - (Freq3 * 10) >= 6 then\r\n Inc(Freq3);\r\n\r\n\r\n Freq := CpuSpeed.RawFreq * 10;\r\n if (Freq3 - Freq) >= 6 then\r\n Inc(CpuSpeed.NormFreq);\r\n\r\n CpuSpeed.ExTicks := Round(TotalTicks);\r\n CpuSpeed.InCycles := TotalCycles;\r\n\r\n CpuSpeed.NormFreq := RoundFrequency(CpuSpeed.NormFreq);\r\n Result := True;\r\n end;\r\nend;\r\n\r\nfunction GetOSEnabledFeatures: TOSEnabledFeatures;\r\nvar\r\n EnabledFeatures: Int64;\r\nbegin\r\n if IsWin7 or IsWinServer2008 or IsWinServer2008R2 then\r\n begin\r\n EnabledFeatures := $FFFFFFFF;\r\n EnabledFeatures := EnabledFeatures shl 32;\r\n EnabledFeatures := EnabledFeatures or $FFFFFFFF;\r\n EnabledFeatures := GetEnabledExtendedFeatures(EnabledFeatures);\r\n Result := [];\r\n if (EnabledFeatures and XSTATE_MASK_LEGACY_FLOATING_POINT) <> 0 then\r\n Include(Result, oefFPU);\r\n if (EnabledFeatures and XSTATE_MASK_LEGACY_SSE) <> 0 then\r\n Include(Result, oefSSE);\r\n if (EnabledFeatures and XSTATE_MASK_GSSE) <> 0 then\r\n Include(Result, oefAVX);\r\n end\r\n else\r\n Result := [];\r\nend;\r\n{$ENDIF MSWINDOWS}\r\n\r\nfunction CPUID: TCpuInfo;\r\n function HasCPUIDInstruction: Boolean;\r\n const\r\n ID_FLAG = $200000;\r\n {$IFNDEF DELPHI64_TEMPORARY}\r\n begin\r\n {$ENDIF ~DELPHI64_TEMPORARY}\r\n asm\r\n {$IFDEF CPU32}\r\n PUSHFD\r\n POP EAX\r\n MOV ECX, EAX\r\n XOR EAX, ID_FLAG\r\n AND ECX, ID_FLAG\r\n PUSH EAX\r\n POPFD\r\n PUSHFD\r\n POP EAX\r\n AND EAX, ID_FLAG\r\n XOR EAX, ECX\r\n SETNZ Result\r\n {$ENDIF CPU32}\r\n {$IFDEF CPU64}\r\n {$IFDEF FPC}\r\n {$DEFINE DELPHI64_TEMPORARY}\r\n {$ENDIF FPC}\r\n {$IFDEF DELPHI64_TEMPORARY}\r\n PUSHFQ\r\n {$ELSE ~DELPHI64_TEMPORARY}\r\n PUSHFD\r\n {$ENDIF ~DELPHI64_TEMPORARY}\r\n POP RAX\r\n MOV RCX, RAX\r\n XOR RAX, ID_FLAG\r\n AND RCX, ID_FLAG\r\n PUSH RAX\r\n {$IFDEF DELPHI64_TEMPORARY}\r\n POPFQ\r\n {$ELSE ~DELPHI64_TEMPORARY}\r\n POPFD\r\n {$ENDIF ~DELPHI64_TEMPORARY}\r\n {$IFDEF DELPHI64_TEMPORARY}\r\n PUSHFQ\r\n {$ELSE ~DELPHI64_TEMPORARY}\r\n PUSHFD\r\n {$ENDIF ~DELPHI64_TEMPORARY}\r\n POP RAX\r\n AND RAX, ID_FLAG\r\n XOR RAX, RCX\r\n SETNZ Result\r\n {$IFDEF FPC}\r\n {$UNDEF DELPHI64_TEMPORARY}\r\n {$ENDIF FPC}\r\n {$ENDIF CPU64}\r\n end;\r\n {$IFNDEF DELPHI64_TEMPORARY}\r\n end;\r\n {$ENDIF ~DELPHI64_TEMPORARY}\r\n\r\n procedure CallCPUID(ValueEAX, ValueECX: Cardinal; out ReturnedEAX, ReturnedEBX, ReturnedECX, ReturnedEDX);\r\n {$IFNDEF DELPHI64_TEMPORARY}\r\n begin\r\n {$ENDIF ~DELPHI64_TEMPORARY}\r\n asm\r\n {$IFDEF CPU32}\r\n // save context\r\n PUSH EDI\r\n PUSH EBX\r\n // init parameters\r\n MOV EAX, ValueEAX\r\n MOV ECX, ValueECX\r\n // CPUID\r\n DB 0FH\r\n DB 0A2H\r\n // store results\r\n MOV EDI, ReturnedEAX\r\n MOV Cardinal PTR [EDI], EAX\r\n MOV EAX, ReturnedEBX\r\n MOV EDI, ReturnedECX\r\n MOV Cardinal PTR [EAX], EBX\r\n MOV Cardinal PTR [EDI], ECX\r\n MOV EAX, ReturnedEDX\r\n MOV Cardinal PTR [EAX], EDX\r\n // restore context\r\n POP EBX\r\n POP EDI\r\n {$ENDIF CPU32}\r\n {$IFDEF CPU64}\r\n // save context\r\n PUSH RBX\r\n // init parameters\r\n MOV EAX, ValueEAX\r\n MOV ECX, ValueECX\r\n // CPUID\r\n CPUID\r\n // store results\r\n MOV R8, ReturnedEAX\r\n MOV R9, ReturnedEBX\r\n MOV R10, ReturnedECX\r\n MOV R11, ReturnedEDX\r\n MOV Cardinal PTR [R8], EAX\r\n MOV Cardinal PTR [R9], EBX\r\n MOV Cardinal PTR [R10], ECX\r\n MOV Cardinal PTR [R11], EDX\r\n // restore context\r\n POP RBX\r\n {$ENDIF CPU64}\r\n end;\r\n {$IFNDEF DELPHI64_TEMPORARY}\r\n end;\r\n {$ENDIF ~DELPHI64_TEMPORARY}\r\n\r\n procedure ProcessStandard(var CPUInfo: TCpuInfo; HiVal: Cardinal);\r\n var\r\n VersionInfo, AdditionalInfo, ExFeatures: Cardinal;\r\n begin\r\n if HiVal >= 1 then\r\n begin\r\n CallCPUID(1, 0, VersionInfo, AdditionalInfo, ExFeatures, CPUInfo.Features);\r\n\r\n CPUInfo.PType := (VersionInfo and $00003000) shr 12;\r\n CPUInfo.Family := (VersionInfo and $00000F00) shr 8;\r\n CPUInfo.Model := (VersionInfo and $000000F0) shr 4;\r\n CPUInfo.Stepping := (VersionInfo and $0000000F);\r\n CPUInfo.ExtendedModel := (VersionInfo and $000F0000) shr 16;\r\n CPUInfo.ExtendedFamily := (VersionInfo and $0FF00000) shr 20;\r\n\r\n if CPUInfo.CpuType = CPU_TYPE_INTEL then\r\n begin\r\n CPUInfo.IntelSpecific.ExFeatures := ExFeatures;\r\n CPUInfo.IntelSpecific.BrandID := AdditionalInfo and $000000FF;\r\n CPUInfo.IntelSpecific.FlushLineSize := (AdditionalInfo and $0000FF00) shr 8;\r\n CPUInfo.IntelSpecific.APICID := (AdditionalInfo and $FF000000) shr 24;\r\n CPUInfo.HyperThreadingTechnology := (CPUInfo.Features and INTEL_HTT) <> 0;\r\n if CPUInfo.HyperThreadingTechnology then\r\n begin\r\n CPUInfo.LogicalCore := (AdditionalInfo and $00FF0000) shr 16;\r\n if CPUInfo.LogicalCore = 0 then\r\n CPUInfo.LogicalCore := 1;\r\n end;\r\n\r\n if HiVal >= 2 then\r\n begin\r\n CPUInfo.HasCacheInfo := True;\r\n // TODO: multiple loops\r\n CallCPUID(2, 0, CPUInfo.IntelSpecific.CacheDescriptors[0], CPUInfo.IntelSpecific.CacheDescriptors[4],\r\n CPUInfo.IntelSpecific.CacheDescriptors[8], CPUInfo.IntelSpecific.CacheDescriptors[12]);\r\n end;\r\n end;\r\n end;\r\n end;\r\n\r\n procedure ProcessIntel(var CPUInfo: TCpuInfo; HiVal: Cardinal);\r\n var\r\n ExHiVal, Unused, AddressSize, CoreInfo: Cardinal;\r\n I, J: Integer;\r\n begin\r\n CPUInfo.CpuType := CPU_TYPE_INTEL;\r\n CPUInfo.Manufacturer := 'Intel';\r\n\r\n ProcessStandard(CPUInfo, HiVal);\r\n\r\n if HiVal >= 4 then\r\n begin\r\n CallCPUID(4, 0, CoreInfo, Unused, Unused, Unused);\r\n CPUInfo.PhysicalCore := ((CoreInfo and $FC000000) shr 26) + 1;\r\n end;\r\n\r\n if HiVal >= 6 then\r\n CallCPUID(6, 0, CPUInfo.IntelSpecific.PowerManagementFeatures, Unused, Unused, Unused);\r\n\r\n // check Intel extended\r\n CallCPUID($80000000, 0, ExHiVal, Unused, Unused, Unused);\r\n if ExHiVal >= $80000001 then\r\n begin\r\n CPUInfo.HasExtendedInfo := True;\r\n CallCPUID($80000001, 0, Unused, Unused, CPUInfo.IntelSpecific.Ex64Features2,\r\n CPUInfo.IntelSpecific.Ex64Features);\r\n end;\r\n if ExHiVal >= $80000002 then\r\n CallCPUID($80000002, 0, CPUInfo.CpuName[0], CPUInfo.CpuName[4], CPUInfo.CpuName[8], CPUInfo.CpuName[12]);\r\n if ExHiVal >= $80000003 then\r\n CallCPUID($80000003, 0, CPUInfo.CpuName[16], CPUInfo.CpuName[20], CPUInfo.CpuName[24], CPUInfo.CpuName[28]);\r\n if ExHiVal >= $80000004 then\r\n CallCPUID($80000004, 0, CPUInfo.CpuName[32], CPUInfo.CpuName[36], CPUInfo.CpuName[40], CPUInfo.CpuName[44]);\r\n if ExHiVal >= $80000006 then\r\n CallCPUID($80000006, 0, Unused, Unused, CPUInfo.IntelSpecific.L2Cache, Unused);\r\n if ExHiVal >= $80000008 then\r\n begin\r\n CallCPUID($80000008, 0, AddressSize, Unused, Unused, Unused);\r\n CPUInfo.IntelSpecific.PhysicalAddressBits := AddressSize and $000000FF;\r\n CPUInfo.IntelSpecific.VirtualAddressBits := (AddressSize and $0000FF00) shr 8;\r\n end;\r\n\r\n if CPUInfo.HasCacheInfo then\r\n begin\r\n if (CPUInfo.IntelSpecific.L2Cache <> 0) then\r\n begin\r\n CPUInfo.L2CacheSize := CPUInfo.IntelSpecific.L2Cache shr 16;\r\n CPUInfo.L2CacheLineSize := CPUInfo.IntelSpecific.L2Cache and $FF;\r\n CPUInfo.L2CacheAssociativity := (CPUInfo.IntelSpecific.L2Cache shr 12) and $F;\r\n end;\r\n for I := Low(CPUInfo.IntelSpecific.CacheDescriptors) to High(CPUInfo.IntelSpecific.CacheDescriptors) do\r\n if CPUInfo.IntelSpecific.CacheDescriptors[I]<>0 then\r\n for J := Low(IntelCacheDescription) to High(IntelCacheDescription) do\r\n if IntelCacheDescription[J].D = CPUInfo.IntelSpecific.CacheDescriptors[I] then\r\n with IntelCacheDescription[J] do\r\n case Family of\r\n //cfInstructionTLB:\r\n //cfDataTLB:\r\n cfL1InstructionCache:\r\n begin\r\n Inc(CPUInfo.L1InstructionCacheSize,Size);\r\n CPUInfo.L1InstructionCacheLineSize := LineSize;\r\n CPUInfo.L1InstructionCacheAssociativity := WaysOfAssoc;\r\n end;\r\n cfL1DataCache:\r\n begin\r\n Inc(CPUInfo.L1DataCacheSize,Size);\r\n CPUInfo.L1DataCacheLineSize := LineSize;\r\n CPUInfo.L1DataCacheAssociativity := WaysOfAssoc;\r\n end;\r\n cfL2Cache:\r\n if (CPUInfo.IntelSpecific.L2Cache = 0) then\r\n begin\r\n Inc(CPUInfo.L2CacheSize,Size);\r\n CPUInfo.L2CacheLineSize := LineSize;\r\n CPUInfo.L2CacheAssociativity := WaysOfAssoc;\r\n end;\r\n cfL3Cache:\r\n begin\r\n Inc(CPUInfo.L3CacheSize,Size);\r\n CPUInfo.L3CacheLineSize := LineSize;\r\n CPUInfo.L3CacheAssociativity := WaysOfAssoc;\r\n CPUInfo.L3LinesPerSector := LinePerSector;\r\n end;\r\n //cfTrace: // no numeric informations\r\n //cfOther:\r\n end;\r\n end;\r\n if not CPUInfo.HasExtendedInfo then\r\n begin\r\n case CPUInfo.Family of\r\n 4:\r\n case CPUInfo.Model of\r\n 1:\r\n CPUInfo.CpuName := 'Intel 486DX Processor';\r\n 2:\r\n CPUInfo.CpuName := 'Intel 486SX Processor';\r\n 3:\r\n CPUInfo.CpuName := 'Intel DX2 Processor';\r\n 4:\r\n CPUInfo.CpuName := 'Intel 486 Processor';\r\n 5:\r\n CPUInfo.CpuName := 'Intel SX2 Processor';\r\n 7:\r\n CPUInfo.CpuName := 'Write-Back Enhanced Intel DX2 Processor';\r\n 8:\r\n CPUInfo.CpuName := 'Intel DX4 Processor';\r\n else\r\n CPUInfo.CpuName := 'Intel 486 Processor';\r\n end;\r\n 5:\r\n CPUInfo.CpuName := 'Pentium';\r\n 6:\r\n case CPUInfo.Model of\r\n 1:\r\n CPUInfo.CpuName := 'Pentium Pro';\r\n 3:\r\n CPUInfo.CpuName := 'Pentium II';\r\n 5:\r\n case CPUInfo.L2CacheSize of\r\n 0:\r\n CPUInfo.CpuName := 'Celeron';\r\n 1024:\r\n CPUInfo.CpuName := 'Pentium II Xeon';\r\n 2048:\r\n CPUInfo.CpuName := 'Pentium II Xeon';\r\n else\r\n CPUInfo.CpuName := 'Pentium II';\r\n end;\r\n 6:\r\n case CPUInfo.L2CacheSize of\r\n 0:\r\n CPUInfo.CpuName := 'Celeron';\r\n 128:\r\n CPUInfo.CpuName := 'Celeron';\r\n else\r\n CPUInfo.CpuName := 'Pentium II';\r\n end;\r\n 7:\r\n case CPUInfo.L2CacheSize of\r\n 1024:\r\n CPUInfo.CpuName := 'Pentium III Xeon';\r\n 2048:\r\n CPUInfo.CpuName := 'Pentium III Xeon';\r\n else\r\n CPUInfo.CpuName := 'Pentium III';\r\n end;\r\n 8:\r\n case CPUInfo.IntelSpecific.BrandID of\r\n 1:\r\n CPUInfo.CpuName := 'Celeron';\r\n 2:\r\n CPUInfo.CpuName := 'Pentium III';\r\n 3:\r\n CPUInfo.CpuName := 'Pentium III Xeon';\r\n 4:\r\n CPUInfo.CpuName := 'Pentium III';\r\n else\r\n CPUInfo.CpuName := 'Pentium III';\r\n end;\r\n 10:\r\n CPUInfo.CpuName := 'Pentium III Xeon';\r\n 11:\r\n CPUInfo.CpuName := 'Pentium III';\r\n else\r\n StrPCopy(CPUInfo.CpuName, AnsiString(Format('P6 (Model %d)', [CPUInfo.Model])));\r\n end;\r\n 15:\r\n case CPUInfo.IntelSpecific.BrandID of\r\n 1:\r\n CPUInfo.CpuName := 'Celeron';\r\n 8:\r\n CPUInfo.CpuName := 'Pentium 4';\r\n 14:\r\n CPUInfo.CpuName := 'Xeon';\r\n else\r\n CPUInfo.CpuName := 'Pentium 4';\r\n end;\r\n else\r\n StrPCopy(CPUInfo.CpuName, AnsiString(Format('P%d', [CPUInfo.Family])));\r\n end;\r\n end;\r\n\r\n CPUInfo.HardwareHyperThreadingTechnology := CPUInfo.LogicalCore <> CPUInfo.PhysicalCore;\r\n CPUInfo.AES := (CPUInfo.IntelSpecific.ExFeatures and EINTEL_AES) <> 0;\r\n CPUInfo.MMX := (CPUInfo.Features and MMX_FLAG) <> 0;\r\n CPUInfo.SSE := [];\r\n if (CPUInfo.Features and SSE_FLAG) <> 0 then\r\n Include(CPUInfo.SSE, sse);\r\n if (CPUInfo.Features and SSE2_FLAG) <> 0 then\r\n Include(CPUInfo.SSE, sse2);\r\n if (CPUInfo.IntelSpecific.ExFeatures and EINTEL_SSE3) <> 0 then\r\n Include(CPUInfo.SSE, sse3);\r\n if (CPUInfo.IntelSpecific.ExFeatures and EINTEL_SSSE3) <> 0 then\r\n Include(CPUInfo.SSE, ssse3);\r\n if (CPUInfo.IntelSpecific.ExFeatures and EINTEL_SSE4_1) <> 0 then\r\n Include(CPUInfo.SSE, sse41);\r\n if (CPUInfo.IntelSpecific.ExFeatures and EINTEL_SSE4_2) <> 0 then\r\n Include(CPUInfo.SSE, sse42);\r\n if (CPUInfo.IntelSpecific.ExFeatures and EINTEL_AVX) <> 0 then\r\n Include(CPUInfo.SSE, avx);\r\n CPUInfo.Is64Bits := CPUInfo.HasExtendedInfo and ((CPUInfo.IntelSpecific.Ex64Features and EINTEL64_EM64T)<>0);\r\n CPUInfo.DepCapable := CPUInfo.HasExtendedInfo and ((CPUInfo.IntelSpecific.Ex64Features and EINTEL64_XD) <> 0);\r\n end;\r\n\r\n procedure ProcessAMD(var CPUInfo: TCpuInfo; HiVal: Cardinal);\r\n var\r\n ExHiVal, Unused, VersionInfo, AdditionalInfo: Cardinal;\r\n begin\r\n CPUInfo.CpuType := CPU_TYPE_AMD;\r\n CPUInfo.Manufacturer := 'AMD';\r\n\r\n // check AMD extended\r\n if HiVal >= 1 then\r\n begin\r\n CallCPUID(1, 0, VersionInfo, AdditionalInfo, CPUInfo.AMDSpecific.Features2, CPUInfo.Features);\r\n\r\n CPUInfo.AMDSpecific.BrandID := AdditionalInfo and $000000FF;\r\n CPUInfo.AMDSpecific.FlushLineSize := (AdditionalInfo and $0000FF00) shr 8;\r\n CPUInfo.AMDSpecific.APICID := (AdditionalInfo and $FF000000) shr 24;\r\n CPUInfo.HyperThreadingTechnology := (CPUInfo.Features and AMD_HTT) <> 0;\r\n if CPUInfo.HyperThreadingTechnology then\r\n begin\r\n CPUInfo.LogicalCore := (AdditionalInfo and $00FF0000) shr 16;\r\n if CPUInfo.LogicalCore = 0 then\r\n CPUInfo.LogicalCore := 1;\r\n end;\r\n end;\r\n\r\n CallCPUID($80000000, 0, ExHiVal, Unused, Unused, Unused);\r\n if ExHiVal <> 0 then\r\n begin\r\n // AMD only\r\n CPUInfo.HasExtendedInfo := True;\r\n\r\n if ExHiVal >= $80000001 then\r\n begin\r\n CallCPUID($80000001, 0, VersionInfo, AdditionalInfo, CPUInfo.AMDSpecific.ExFeatures2, CPUInfo.AMDSpecific.ExFeatures);\r\n CPUInfo.Family := (VersionInfo and $00000F00) shr 8;\r\n CPUInfo.Model := (VersionInfo and $000000F0) shr 4;\r\n CPUInfo.Stepping := (VersionInfo and $0000000F);\r\n CPUInfo.ExtendedModel := (VersionInfo and $000F0000) shr 16;\r\n CPUInfo.ExtendedFamily := (VersionInfo and $0FF00000) shr 20;\r\n CPUInfo.AMDSpecific.ExBrandID := AdditionalInfo and $0000FFFF;\r\n end;\r\n if ExHiVal >= $80000002 then\r\n CallCPUID($80000002, 0, CPUInfo.CpuName[0], CPUInfo.CpuName[4], CPUInfo.CpuName[8], CPUInfo.CpuName[12]);\r\n if ExHiVal >= $80000003 then\r\n CallCPUID($80000003, 0, CPUInfo.CpuName[16], CPUInfo.CpuName[20], CPUInfo.CpuName[24], CPUInfo.CpuName[28]);\r\n if ExHiVal >= $80000004 then\r\n CallCPUID($80000004, 0, CPUInfo.CpuName[32], CPUInfo.CpuName[36], CPUInfo.CpuName[40], CPUInfo.CpuName[44]);\r\n if ExHiVal >= $80000005 then\r\n begin\r\n CPUInfo.HasCacheInfo := True;\r\n CallCPUID($80000005, 0, CPUInfo.AMDSpecific.L1MByteInstructionTLB, CPUInfo.AMDSpecific.L1KByteInstructionTLB,\r\n CPUInfo.AMDSpecific.L1DataCache, CPUInfo.AMDSpecific.L1InstructionCache);\r\n end;\r\n if ExHiVal >= $80000006 then\r\n CallCPUID($80000006, 0, CPUInfo.AMDSpecific.L2MByteInstructionTLB, CPUInfo.AMDSpecific.L2KByteInstructionTLB,\r\n CPUInfo.AMDSpecific.L2Cache, CPUInfo.AMDSpecific.L3Cache);\r\n if CPUInfo.HasCacheInfo then\r\n begin\r\n CPUInfo.L1DataCacheSize := CPUInfo.AMDSpecific.L1DataCache[ciSize];\r\n CPUInfo.L1DataCacheLineSize := CPUInfo.AMDSpecific.L1DataCache[ciLineSize];\r\n CPUInfo.L1DataCacheAssociativity := CPUInfo.AMDSpecific.L1DataCache[ciAssociativity];\r\n CPUInfo.L1InstructionCacheSize := CPUInfo.AMDSpecific.L1InstructionCache[ciSize];\r\n CPUInfo.L1InstructionCacheLineSize := CPUInfo.AMDSpecific.L1InstructionCache[ciLineSize];\r\n CPUInfo.L1InstructionCacheAssociativity := CPUInfo.AMDSpecific.L1InstructionCache[ciAssociativity];\r\n CPUInfo.L2CacheLineSize := CPUInfo.AMDSpecific.L2Cache and $FF;\r\n CPUInfo.L2CacheAssociativity := (CPUInfo.AMDSpecific.L2Cache shr 12) and $F;\r\n CPUInfo.L2CacheSize := CPUInfo.AMDSpecific.L2Cache shr 16;\r\n CPUInfo.L3CacheLineSize := CPUInfo.AMDSpecific.L3Cache and $FF;\r\n CPUInfo.L3CacheAssociativity := (CPUInfo.AMDSpecific.L3Cache shr 12) and $F;\r\n CPUInfo.L3CacheSize := CPUInfo.AMDSpecific.L3Cache shr 19 {MB}; //(CPUInfo.AMDSpecific.L3Cache shr 18) * 512 {kB};\r\n end;\r\n if ExHiVal >= $80000007 then\r\n CallCPUID($80000007, 0, Unused, Unused, Unused, CPUInfo.AMDSpecific.AdvancedPowerManagement);\r\n if ExHiVal >= $80000008 then\r\n begin\r\n CallCPUID($80000008, 0, Unused, VersionInfo, AdditionalInfo, Unused);\r\n CPUInfo.AMDSpecific.PhysicalAddressSize := VersionInfo and $000000FF;\r\n CPUInfo.AMDSpecific.VirtualAddressSize := (VersionInfo and $0000FF00) shr 8;\r\n CPUInfo.PhysicalCore := (AdditionalInfo and $000000FF) + 1;\r\n end;\r\n end\r\n else\r\n begin\r\n ProcessStandard(CPUInfo, HiVal);\r\n case CPUInfo.Family of\r\n 4:\r\n CPUInfo.CpuName := 'Am486(R) or Am5x86';\r\n 5:\r\n case CPUInfo.Model of\r\n 0:\r\n CPUInfo.CpuName := 'AMD-K5 (Model 0)';\r\n 1:\r\n CPUInfo.CpuName := 'AMD-K5 (Model 1)';\r\n 2:\r\n CPUInfo.CpuName := 'AMD-K5 (Model 2)';\r\n 3:\r\n CPUInfo.CpuName := 'AMD-K5 (Model 3)';\r\n 6:\r\n CPUInfo.CpuName := 'AMD-K6 (Model 6)';\r\n 7:\r\n CPUInfo.CpuName := 'AMD-K6 (Model 7)';\r\n 8:\r\n CPUInfo.CpuName := 'AMD-K6-2 (Model 8)';\r\n 9:\r\n CPUInfo.CpuName := 'AMD-K6-III (Model 9)';\r\n else\r\n StrFmt(CPUInfo.CpuName, PAnsiChar(AnsiString(LoadResString(@RsUnknownAMDModel))),[CPUInfo.Model]);\r\n end;\r\n 6:\r\n case CPUInfo.Model of\r\n 1:\r\n CPUInfo.CpuName := 'AMD Athlon (Model 1)';\r\n 2:\r\n CPUInfo.CpuName := 'AMD Athlon (Model 2)';\r\n 3:\r\n CPUInfo.CpuName := 'AMD Duron (Model 3)';\r\n 4:\r\n CPUInfo.CpuName := 'AMD Athlon (Model 4)';\r\n 6:\r\n CPUInfo.CpuName := 'AMD Athlon XP (Model 6)';\r\n 7:\r\n CPUInfo.CpuName := 'AMD Duron (Model 7)';\r\n 8:\r\n CPUInfo.CpuName := 'AMD Athlon XP (Model 8)';\r\n 10:\r\n CPUInfo.CpuName := 'AMD Athlon XP (Model 10)';\r\n else\r\n StrFmt(CPUInfo.CpuName, PAnsiChar(AnsiString(LoadResString(@RsUnknownAMDModel))), [CPUInfo.Model]);\r\n end;\r\n 8:\r\n\r\n else\r\n CPUInfo.CpuName := 'Unknown AMD Chip';\r\n end;\r\n end;\r\n\r\n CPUInfo.HardwareHyperThreadingTechnology := CPUInfo.LogicalCore <> CPUInfo.PhysicalCore;\r\n CPUInfo.AES := (CPUInfo.AMDSpecific.Features2 and AMD2_AES) <> 0;\r\n CPUInfo.MMX := (CPUInfo.Features and AMD_MMX) <> 0;\r\n CPUInfo.ExMMX := CPUInfo.HasExtendedInfo and ((CPUInfo.AMDSpecific.ExFeatures and EAMD_EXMMX) <> 0);\r\n CPUInfo._3DNow := CPUInfo.HasExtendedInfo and ((CPUInfo.AMDSpecific.ExFeatures and EAMD_3DNOW) <> 0);\r\n CPUInfo.Ex3DNow := CPUInfo.HasExtendedInfo and ((CPUInfo.AMDSpecific.ExFeatures and EAMD_EX3DNOW) <> 0);\r\n CPUInfo.SSE := [];\r\n if (CPUInfo.Features and AMD_SSE) <> 0 then\r\n Include(CPUInfo.SSE, sse);\r\n if (CPUInfo.Features and AMD_SSE2) <> 0 then\r\n Include(CPUInfo.SSE, sse2);\r\n if (CPUInfo.AMDSpecific.Features2 and AMD2_SSE3) <> 0 then\r\n Include(CPUInfo.SSE, sse3);\r\n if CPUInfo.HasExtendedInfo then\r\n begin\r\n if (CPUInfo.AMDSpecific.ExFeatures2 and EAMD2_SSE4A) <> 0 then\r\n Include(CPUInfo.SSE, sse4A);\r\n if (CPUInfo.AMDSpecific.Features2 and AMD2_SSE41) <> 0 then\r\n Include(CPUInfo.SSE, sse41);\r\n if (CPUInfo.AMDSpecific.Features2 and AMD2_SSE42) <> 0 then\r\n Include(CPUInfo.SSE, sse42);\r\n end;\r\n CPUInfo.Is64Bits := CPUInfo.HasExtendedInfo and ((CPUInfo.AMDSpecific.ExFeatures and EAMD_LONG) <> 0);\r\n CPUInfo.DEPCapable := CPUInfo.HasExtendedInfo and ((CPUInfo.AMDSpecific.ExFeatures and EAMD_NX) <> 0);\r\n end;\r\n\r\n procedure ProcessCyrix(var CPUInfo: TCpuInfo; HiVal: Cardinal);\r\n var\r\n ExHiVal, Unused, VersionInfo, AdditionalInfo: Cardinal;\r\n begin\r\n CPUInfo.CpuType := CPU_TYPE_CYRIX;\r\n CPUInfo.Manufacturer := 'Cyrix';\r\n\r\n // check Cyrix extended\r\n CallCPUID($80000000, 0, ExHiVal, Unused, Unused, Unused);\r\n if ExHiVal <> 0 then\r\n begin\r\n // Cyrix only\r\n CPUInfo.HasExtendedInfo := True;\r\n if ExHiVal >= $80000001 then\r\n begin\r\n CallCPUID($80000001, 0, VersionInfo, AdditionalInfo, Unused, CPUInfo.Features);\r\n CPUInfo.PType := (VersionInfo and $0000F000) shr 12;\r\n CPUInfo.Family := (VersionInfo and $00000F00) shr 8;\r\n CPUInfo.Model := (VersionInfo and $000000F0) shr 4;\r\n CPUInfo.Stepping := (VersionInfo and $0000000F);\r\n end;\r\n if ExHiVal >= $80000002 then\r\n CallCPUID($80000002, 0, CPUInfo.CpuName[0], CPUInfo.CpuName[4], CPUInfo.CpuName[8], CPUInfo.CpuName[12]);\r\n if ExHiVal >= $80000003 then\r\n CallCPUID($80000003, 0, CPUInfo.CpuName[16], CPUInfo.CpuName[20], CPUInfo.CpuName[24], CPUInfo.CpuName[28]);\r\n if ExHiVal >= $80000004 then\r\n CallCPUID($80000004, 0, CPUInfo.CpuName[32], CPUInfo.CpuName[36], CPUInfo.CpuName[40], CPUInfo.CpuName[44]);\r\n if ExHiVal >= $80000005 then\r\n begin\r\n CPUInfo.HasCacheInfo := True;\r\n CallCPUID($80000005, 0, Unused, CPUInfo.CyrixSpecific.TLBInfo, CPUInfo.CyrixSpecific.L1CacheInfo, Unused);\r\n end;\r\n end\r\n else\r\n begin\r\n ProcessStandard(CPUInfo, HiVal);\r\n case CPUInfo.Family of\r\n 4:\r\n CPUInfo.CpuName := 'Cyrix MediaGX';\r\n 5:\r\n case CPUInfo.Model of\r\n 2:\r\n CPUInfo.CpuName := 'Cyrix 6x86';\r\n 4:\r\n CPUInfo.CpuName := 'Cyrix GXm';\r\n end;\r\n 6:\r\n CPUInfo.CpuName := '6x86MX';\r\n else\r\n StrPCopy(CPUInfo.CpuName, AnsiString(Format('%dx86', [CPUInfo.Family])));\r\n end;\r\n end;\r\n end;\r\n\r\n procedure ProcessVIA(var CPUInfo: TCpuInfo; HiVal: Cardinal);\r\n var\r\n ExHiVal, Unused, VersionInfo: Cardinal;\r\n begin\r\n CPUInfo.CpuType := CPU_TYPE_VIA;\r\n CPUInfo.Manufacturer := 'Via';\r\n\r\n // check VIA extended\r\n CallCPUID($80000000, 0, ExHiVal, Unused, Unused, Unused);\r\n if ExHiVal <> 0 then\r\n begin\r\n if ExHiVal >= $80000001 then\r\n begin\r\n CPUInfo.HasExtendedInfo := True;\r\n CallCPUID($80000001, 0, VersionInfo, Unused, Unused, CPUInfo.ViaSpecific.ExFeatures);\r\n CPUInfo.PType := (VersionInfo and $00003000) shr 12;\r\n CPUInfo.Family := (VersionInfo and $00000F00) shr 8;\r\n CPUInfo.Model := (VersionInfo and $000000F0) shr 4;\r\n CPUInfo.Stepping := (VersionInfo and $0000000F);\r\n end;\r\n if ExHiVal >= $80000002 then\r\n CallCPUID($80000002, 0, CPUInfo.CpuName[0], CPUInfo.CpuName[4], CPUInfo.CpuName[8], CPUInfo.CpuName[12]);\r\n if ExHiVal >= $80000003 then\r\n CallCPUID($80000003, 0, CPUInfo.CpuName[16], CPUInfo.CpuName[20], CPUInfo.CpuName[24], CPUInfo.CpuName[28]);\r\n if ExHiVal >= $80000004 then\r\n CallCPUID($80000004, 0, CPUInfo.CpuName[32], CPUInfo.CpuName[36], CPUInfo.CpuName[40], CPUInfo.CpuName[44]);\r\n if ExHiVal >= $80000005 then\r\n begin\r\n CPUInfo.HasCacheInfo := True;\r\n CallCPUID($80000005, 0, Unused, CPUInfo.ViaSpecific.InstructionTLB, CPUInfo.ViaSpecific.L1DataCache,\r\n CPUInfo.ViaSpecific.L1InstructionCache);\r\n end;\r\n if ExHiVal >= $80000006 then\r\n CallCPUID($80000006, 0, Unused, Unused, CPUInfo.ViaSpecific.L2DataCache, Unused);\r\n\r\n if CPUInfo.HasCacheInfo then\r\n begin\r\n CPUInfo.L1DataCacheSize := CPUInfo.VIASpecific.L1DataCache[ciSize];\r\n CPUInfo.L1DataCacheLineSize := CPUInfo.VIASpecific.L1DataCache[ciLineSize];\r\n CPUInfo.L1DataCacheAssociativity := CPUInfo.VIASpecific.L1DataCache[ciAssociativity];\r\n CPUInfo.L1InstructionCacheSize := CPUInfo.VIASpecific.L1InstructionCache[ciSize];\r\n CPUInfo.L1InstructionCacheLineSize := CPUInfo.VIASpecific.L1InstructionCache[ciLineSize];\r\n CPUInfo.L1InstructionCacheAssociativity := CPUInfo.VIASpecific.L1InstructionCache[ciAssociativity];\r\n CPUInfo.L2CacheLineSize := CPUInfo.VIASpecific.L2DataCache and $FF;\r\n CPUInfo.L2CacheAssociativity := (CPUInfo.VIASpecific.L2DataCache shr 12) and $F;\r\n CPUInfo.L2CacheSize := CPUInfo.VIASpecific.L2DataCache shr 16;\r\n end;\r\n\r\n CallCPUID($C0000000, 0, ExHiVal, Unused, Unused, Unused);\r\n if ExHiVal >= $C0000001 then\r\n CallCPUID($C0000001, 0, Unused, Unused, Unused, CPUInfo.ViaSpecific.ExFeatures);\r\n end\r\n else\r\n ProcessStandard(CPUInfo, HiVal);\r\n\r\n if not CPUInfo.HasExtendedInfo then\r\n CPUInfo.CpuName := 'C3';\r\n CPUInfo.MMX := (CPUInfo.Features and VIA_MMX) <> 0;\r\n CPUInfo.SSE := [];\r\n if (CPUInfo.Features and VIA_SSE) <> 0 then\r\n Include(CPUInfo.SSE, sse);\r\n CPUInfo._3DNow := (CPUInfo.Features and VIA_3DNOW) <> 0;\r\n end;\r\n\r\n procedure ProcessTransmeta(var CPUInfo: TCpuInfo; HiVal: Cardinal);\r\n var\r\n ExHiVal, Unused, VersionInfo: Cardinal;\r\n begin\r\n CPUInfo.CpuType := CPU_TYPE_TRANSMETA;\r\n CPUInfo.Manufacturer := 'Transmeta';\r\n\r\n if (HiVal >= 1) then\r\n begin\r\n CallCPUID(1, 0, VersionInfo, Unused, Unused, CPUInfo.Features);\r\n CPUInfo.PType := (VersionInfo and $00003000) shr 12;\r\n CPUInfo.Family := (VersionInfo and $00000F00) shr 8;\r\n CPUInfo.Model := (VersionInfo and $000000F0) shr 4;\r\n CPUInfo.Stepping := (VersionInfo and $0000000F);\r\n end;\r\n // no information when eax is 2\r\n // eax is 3 means Serial Number, not detected there\r\n\r\n // small CPU description, overriden if ExHiVal >= 80000002\r\n CallCPUID($80000000, 0, ExHiVal, CPUInfo.CpuName[0], CPUInfo.CpuName[8], CPUInfo.CpuName[4]);\r\n if ExHiVal <> 0 then\r\n begin\r\n CPUInfo.HasExtendedInfo := True;\r\n\r\n if ExHiVal >= $80000001 then\r\n CallCPUID($80000001, 0, Unused, Unused, Unused, CPUInfo.TransmetaSpecific.ExFeatures);\r\n if ExHiVal >= $80000002 then\r\n CallCPUID($80000002, 0, CPUInfo.CpuName[0], CPUInfo.CpuName[4], CPUInfo.CpuName[8], CPUInfo.CpuName[12]);\r\n if ExHiVal >= $80000003 then\r\n CallCPUID($80000003, 0, CPUInfo.CpuName[16], CPUInfo.CpuName[20], CPUInfo.CpuName[24], CPUInfo.CpuName[28]);\r\n if ExHiVal >= $80000004 then\r\n CallCPUID($80000004, 0, CPUInfo.CpuName[32], CPUInfo.CpuName[36], CPUInfo.CpuName[40], CPUInfo.CpuName[44]);\r\n if ExHiVal >= $80000005 then\r\n begin\r\n CPUInfo.HasCacheInfo := True;\r\n CallCPUID($80000005, 0, Unused, CPUInfo.TransmetaSpecific.CodeTLB, CPUInfo.TransmetaSpecific.L1DataCache,\r\n CPUInfo.TransmetaSpecific.L1CodeCache);\r\n end;\r\n if CPUInfo.HasCacheInfo then\r\n begin\r\n CPUInfo.L1DataCacheSize := CPUInfo.TransmetaSpecific.L1DataCache[ciSize];\r\n CPUInfo.L1DataCacheLineSize := CPUInfo.TransmetaSpecific.L1DataCache[ciLineSize];\r\n CPUInfo.L1DataCacheAssociativity := CPUInfo.TransmetaSpecific.L1DataCache[ciAssociativity];\r\n CPUInfo.L1InstructionCacheSize := CPUInfo.TransmetaSpecific.L1CodeCache[ciSize];\r\n CPUInfo.L1InstructionCacheLineSize := CPUInfo.TransmetaSpecific.L1CodeCache[ciLineSize];\r\n CPUInfo.L1InstructionCacheAssociativity := CPUInfo.TransmetaSpecific.L1CodeCache[ciAssociativity];\r\n CPUInfo.L2CacheLineSize := CPUInfo.TransmetaSpecific.L2Cache and $FF;\r\n CPUInfo.L2CacheAssociativity := (CPUInfo.TransmetaSpecific.L2Cache shr 12) and $F;\r\n CPUInfo.L2CacheSize := CPUInfo.TransmetaSpecific.L2Cache shr 16;\r\n end;\r\n if ExHiVal >= $80000006 then\r\n CallCPUID($80000006, 0, Unused, Unused, CPUInfo.TransmetaSpecific.L2Cache, Unused);\r\n end\r\n else\r\n CPUInfo.CpuName := 'Crusoe';\r\n\r\n CallCPUID($80860000, 0, ExHiVal, Unused, Unused, Unused);\r\n if ExHiVal <> 0 then\r\n begin\r\n if ExHiVal >= $80860001 then\r\n CallCPUID($80860001, 0, Unused, CPUInfo.TransmetaSpecific.RevisionABCD, CPUInfo.TransmetaSpecific.RevisionXXXX,\r\n CPUInfo.TransmetaSpecific.TransmetaFeatures);\r\n if ExHiVal >= $80860002 then\r\n CallCPUID($80860002, 0, Unused, CPUInfo.TransmetaSpecific.CodeMorphingABCD, CPUInfo.TransmetaSpecific.CodeMorphingXXXX, Unused);\r\n if ExHiVal >= $80860003 then\r\n CallCPUID($80860003, 0, CPUInfo.TransmetaSpecific.TransmetaInformations[0], CPUInfo.TransmetaSpecific.TransmetaInformations[4],\r\n CPUInfo.TransmetaSpecific.TransmetaInformations[8], CPUInfo.TransmetaSpecific.TransmetaInformations[12]);\r\n if ExHiVal >= $80860004 then\r\n CallCPUID($80860004, 0, CPUInfo.TransmetaSpecific.TransmetaInformations[16], CPUInfo.TransmetaSpecific.TransmetaInformations[20],\r\n CPUInfo.TransmetaSpecific.TransmetaInformations[24], CPUInfo.TransmetaSpecific.TransmetaInformations[28]);\r\n if ExHiVal >= $80860005 then\r\n CallCPUID($80860005, 0, CPUInfo.TransmetaSpecific.TransmetaInformations[32], CPUInfo.TransmetaSpecific.TransmetaInformations[36],\r\n CPUInfo.TransmetaSpecific.TransmetaInformations[40], CPUInfo.TransmetaSpecific.TransmetaInformations[44]);\r\n if ExHiVal >= $80860006 then\r\n CallCPUID($80860006, 0, CPUInfo.TransmetaSpecific.TransmetaInformations[48], CPUInfo.TransmetaSpecific.TransmetaInformations[52],\r\n CPUInfo.TransmetaSpecific.TransmetaInformations[56], CPUInfo.TransmetaSpecific.TransmetaInformations[60]);\r\n if (ExHiVal >= $80860007) and ((CPUInfo.TransmetaSpecific.TransmetaFeatures and STRANSMETA_LONGRUN) <> 0) then\r\n CallCPUID($80860007, 0, CPUInfo.TransmetaSpecific.CurrentFrequency, CPUInfo.TransmetaSpecific.CurrentVoltage,\r\n CPUInfo.TransmetaSpecific.CurrentPerformance, Unused);\r\n end;\r\n CPUInfo.MMX := (CPUInfo.Features and TRANSMETA_MMX) <> 0;\r\n end;\r\n\r\nvar\r\n HiVal: Cardinal;\r\nbegin\r\n ResetMemory(Result, sizeof(Result));\r\n Result.LogicalCore := 1;\r\n Result.PhysicalCore := 1;\r\n\r\n if HasCPUIDInstruction then\r\n begin\r\n Result.HasInstruction := True;\r\n CallCPUID(0, 0, HiVal, Result.VendorIDString[0], Result.VendorIDString[8],\r\n Result.VendorIDString[4]);\r\n if Result.VendorIDString = VendorIDIntel then\r\n ProcessIntel(Result, HiVal)\r\n else if Result.VendorIDString = VendorIDAMD then\r\n ProcessAMD(Result, HiVal)\r\n else if Result.VendorIDString = VendorIDCyrix then\r\n ProcessCyrix(Result, HiVal)\r\n else if Result.VendorIDString = VendorIDVIA then\r\n ProcessVIA(Result, HiVal)\r\n else if Result.VendorIDString = VendorIDTransmeta then\r\n ProcessTransmeta(Result, HiVal)\r\n else\r\n ProcessStandard(Result, HiVal);\r\n end\r\n else\r\n Result.Family := 4;\r\n\r\n if Result.CpuType = 0 then\r\n begin\r\n Result.Manufacturer := 'Unknown';\r\n Result.CpuName := 'Unknown';\r\n end;\r\nend;\r\n\r\nfunction TestFDIVInstruction: Boolean;\r\n{$IFDEF CPU32}\r\nvar\r\n TopNum: Double;\r\n BottomNum: Double;\r\n One: Double;\r\n ISOK: Boolean;\r\nbegin\r\n // The following code was found in Borlands fdiv.asm file in the\r\n // Delphi 3\\Source\\RTL\\SYS directory, (I made some minor modifications)\r\n // therefore I cannot take credit for it.\r\n TopNum := 2658955;\r\n BottomNum := PI;\r\n One := 1;\r\n asm\r\n PUSH EAX\r\n FLD [TopNum]\r\n FDIV [BottomNum]\r\n FMUL [BottomNum]\r\n FSUBR [TopNum]\r\n FCOMP [One]\r\n FSTSW AX\r\n SHR EAX, 8\r\n AND EAX, 01H\r\n MOV ISOK, AL\r\n POP EAX\r\n end;\r\n Result := ISOK;\r\nend;\r\n{$ENDIF CPU32}\r\n{$IFDEF CPU64}\r\nbegin\r\n Result := True;\r\nend;\r\n{$ENDIF CPU64}\r\n\r\n//=== Alloc granularity ======================================================\r\n\r\nprocedure RoundToAllocGranularity64(var Value: Int64; Up: Boolean);\r\nbegin\r\n if (Value mod AllocGranularity) <> 0 then\r\n if Up then\r\n Value := ((Value div AllocGranularity) + 1) * AllocGranularity\r\n else\r\n Value := (Value div AllocGranularity) * AllocGranularity;\r\nend;\r\n\r\nprocedure RoundToAllocGranularityPtr(var Value: Pointer; Up: Boolean);\r\nvar\r\n Addr: TJclAddr;\r\nbegin\r\n Addr := TJclAddr(Value);\r\n if (Addr mod AllocGranularity) <> 0 then\r\n begin\r\n if Up then\r\n Addr := ((Addr div AllocGranularity) + 1) * AllocGranularity\r\n else\r\n Addr := (Addr div AllocGranularity) * AllocGranularity;\r\n Value := Pointer(Addr);\r\n end;\r\nend;\r\n\r\n//=== Advanced Power Management (APM) ========================================\r\n\r\n{$IFDEF MSWINDOWS}\r\nfunction GetAPMLineStatus: TAPMLineStatus;\r\nvar\r\n SystemPowerStatus: TSystemPowerStatus;\r\nbegin\r\n Result := alsUnknown;\r\n\r\n if (Win32Platform = VER_PLATFORM_WIN32_NT) and (Win32MajorVersion < 5) then // Windows NT doesn't support GetSystemPowerStatus\r\n Exit; // so we return alsUnknown\r\n\r\n SystemPowerStatus.ACLineStatus := 0;\r\n if not GetSystemPowerStatus(SystemPowerStatus) then\r\n RaiseLastOSError\r\n else\r\n begin\r\n case SystemPowerStatus.ACLineStatus of\r\n 0:\r\n Result := alsOffline;\r\n 1:\r\n Result := alsOnline;\r\n 255:\r\n Result := alsUnknown;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction GetAPMBatteryFlag: TAPMBatteryFlag;\r\nvar\r\n SystemPowerStatus: TSystemPowerStatus;\r\nbegin\r\n Result := abfUnknown;\r\n\r\n if (Win32Platform = VER_PLATFORM_WIN32_NT) and (Win32MajorVersion < 5) then // Windows NT doesn't support GetSystemPowerStatus\r\n Exit; // so we return abfUnknown\r\n\r\n SystemPowerStatus.ACLineStatus := 0;\r\n if not GetSystemPowerStatus(SystemPowerStatus) then\r\n RaiseLastOSError\r\n else\r\n begin\r\n case SystemPowerStatus.BatteryFlag of\r\n 1:\r\n Result := abfHigh;\r\n 2:\r\n Result := abfLow;\r\n 4:\r\n Result := abfCritical;\r\n 8:\r\n Result := abfCharging;\r\n 128:\r\n Result := abfNoBattery;\r\n 255:\r\n Result := abfUnknown;\r\n end;\r\n end;\r\nend;\r\n\r\n\r\nfunction GetAPMBatteryFlags: TAPMBatteryFlags;\r\nvar\r\n SystemPowerStatus: TSystemPowerStatus;\r\nbegin\r\n Result := [];\r\n\r\n if (Win32Platform = VER_PLATFORM_WIN32_NT) and (Win32MajorVersion < 5) then // Windows NT doesn't support GetSystemPowerStatus\r\n begin\r\n Result := [abfUnknown];\r\n Exit; // so we return [abfUnknown]\r\n end;\r\n\r\n SystemPowerStatus.ACLineStatus := 0;\r\n if not GetSystemPowerStatus(SystemPowerStatus) then\r\n RaiseLastOSError\r\n else\r\n begin\r\n if (SystemPowerStatus.BatteryFlag and 1) <> 0 then\r\n Result := Result + [abfHigh];\r\n if (SystemPowerStatus.BatteryFlag and 2) <> 0 then\r\n Result := Result + [abfLow];\r\n if (SystemPowerStatus.BatteryFlag and 4) <> 0 then\r\n Result := Result + [abfCritical];\r\n if (SystemPowerStatus.BatteryFlag and 8) <> 0 then\r\n Result := Result + [abfCharging];\r\n if (SystemPowerStatus.BatteryFlag and 128) <> 0 then\r\n Result := Result + [abfNoBattery];\r\n if SystemPowerStatus.BatteryFlag = 255 then\r\n Result := Result + [abfUnknown];\r\n end;\r\nend;\r\n\r\nfunction GetAPMBatteryLifePercent: Integer;\r\nvar\r\n SystemPowerStatus: TSystemPowerStatus;\r\nbegin\r\n Result := 0;\r\n\r\n if (Win32Platform = VER_PLATFORM_WIN32_NT) and (Win32MajorVersion < 5) then // Windows NT doesn't support GetSystemPowerStatus\r\n Exit;\r\n\r\n SystemPowerStatus.ACLineStatus := 0;\r\n if not GetSystemPowerStatus(SystemPowerStatus) then\r\n RaiseLastOSError\r\n else\r\n Result := SystemPowerStatus.BatteryLifePercent;\r\nend;\r\n\r\nfunction GetAPMBatteryLifeTime: DWORD;\r\nvar\r\n SystemPowerStatus: TSystemPowerStatus;\r\nbegin\r\n Result := 0;\r\n\r\n if (Win32Platform = VER_PLATFORM_WIN32_NT) and (Win32MajorVersion < 5) then // Windows NT doesn't support GetSystemPowerStatus\r\n Exit;\r\n\r\n SystemPowerStatus.ACLineStatus := 0;\r\n if not GetSystemPowerStatus(SystemPowerStatus) then\r\n RaiseLastOSError\r\n else\r\n Result := SystemPowerStatus.BatteryLifeTime;\r\nend;\r\n\r\nfunction GetAPMBatteryFullLifeTime: DWORD;\r\nvar\r\n SystemPowerStatus: TSystemPowerStatus;\r\nbegin\r\n Result := 0;\r\n\r\n if (Win32Platform = VER_PLATFORM_WIN32_NT) and (Win32MajorVersion < 5) then // Windows NT doesn't support GetSystemPowerStatus\r\n Exit;\r\n\r\n SystemPowerStatus.ACLineStatus := 0;\r\n if not GetSystemPowerStatus(SystemPowerStatus) then\r\n RaiseLastOSError\r\n else\r\n Result := SystemPowerStatus.BatteryFullLifeTime;\r\nend;\r\n\r\n//=== Memory Information =====================================================\r\n\r\nfunction GetMaxAppAddress: TJclAddr;\r\nvar\r\n SystemInfo: TSystemInfo;\r\nbegin\r\n ResetMemory(SystemInfo, SizeOf(SystemInfo));\r\n GetSystemInfo(SystemInfo);\r\n Result := TJclAddr(SystemInfo.lpMaximumApplicationAddress);\r\nend;\r\n\r\nfunction GetMinAppAddress: TJclAddr;\r\nvar\r\n SystemInfo: TSystemInfo;\r\nbegin\r\n ResetMemory(SystemInfo, SizeOf(SystemInfo));\r\n GetSystemInfo(SystemInfo);\r\n Result := TJclAddr(SystemInfo.lpMinimumApplicationAddress);\r\nend;\r\n{$ENDIF MSWINDOWS}\r\n\r\nfunction GetMemoryLoad: Byte;\r\n{$IFDEF UNIX}\r\nvar\r\n SystemInf: TSysInfo;\r\nbegin\r\n {$IFDEF FPC}\r\n SysInfo(@SystemInf);\r\n {$ELSE ~FPC}\r\n SysInfo(SystemInf);\r\n {$ENDIF ~FPC}\r\n with SystemInf do\r\n Result := 100 - Round(100 * freeram / totalram);\r\nend;\r\n{$ENDIF UNIX}\r\n{$IFDEF MSWINDOWS}\r\nvar\r\n MemoryStatusEx: TMemoryStatusEx;\r\nbegin\r\n ResetMemory(MemoryStatusEx, SizeOf(MemoryStatusEx));\r\n MemoryStatusEx.dwLength := SizeOf(MemoryStatusEx);\r\n if not GlobalMemoryStatusEx(MemoryStatusEx) then\r\n RaiseLastOSError;\r\n Result := MemoryStatusEx.dwMemoryLoad;\r\nend;\r\n{$ENDIF MSWINDOWS}\r\n\r\nfunction GetSwapFileSize: Int64;\r\n{$IFDEF UNIX}\r\nvar\r\n SystemInf: TSysInfo;\r\nbegin\r\n {$IFDEF FPC}\r\n SysInfo(@SystemInf);\r\n {$ELSE ~FPC}\r\n SysInfo(SystemInf);\r\n {$ENDIF ~FPC}\r\n Result := SystemInf.totalswap;\r\nend;\r\n{$ENDIF UNIX}\r\n{$IFDEF MSWINDOWS}\r\nvar\r\n MemoryStatusEx: TMemoryStatusEx;\r\nbegin\r\n ResetMemory(MemoryStatusEx, SizeOf(MemoryStatusEx));\r\n MemoryStatusEx.dwLength := SizeOf(MemoryStatusEx);\r\n if not GlobalMemoryStatusEx(MemoryStatusEx) then\r\n RaiseLastOSError;\r\n Result := MemoryStatusEx.ullTotalPageFile - MemoryStatusEx.ullAvailPageFile;\r\nend;\r\n{$ENDIF MSWINDOWS}\r\n\r\nfunction GetSwapFileUsage: Byte;\r\n{$IFDEF UNIX}\r\nvar\r\n SystemInf: TSysInfo;\r\nbegin\r\n {$IFDEF FPC}\r\n SysInfo(@SystemInf);\r\n {$ELSE ~FPC}\r\n SysInfo(SystemInf);\r\n {$ENDIF ~FPC}\r\n with SystemInf do\r\n Result := 100 - Trunc(100 * FreeSwap / TotalSwap);\r\nend;\r\n{$ENDIF UNIX}\r\n{$IFDEF MSWINDOWS}\r\nvar\r\n MemoryStatusEx: TMemoryStatusEx;\r\nbegin\r\n ResetMemory(MemoryStatusEx, SizeOf(MemoryStatusEx));\r\n MemoryStatusEx.dwLength := SizeOf(MemoryStatusEx);\r\n if not GlobalMemoryStatusEx(MemoryStatusEx) then\r\n RaiseLastOSError;\r\n if MemoryStatusEx.ullTotalPageFile > 0 then\r\n Result := 100 - Trunc(MemoryStatusEx.ullAvailPageFile / MemoryStatusEx.ullTotalPageFile * 100)\r\n else\r\n Result := 0;\r\nend;\r\n{$ENDIF MSWINDOWS}\r\n\r\nfunction GetTotalPhysicalMemory: Int64;\r\n{$IFDEF UNIX}\r\nvar\r\n SystemInf: TSysInfo;\r\nbegin\r\n {$IFDEF FPC}\r\n SysInfo(@SystemInf);\r\n {$ELSE ~FPC}\r\n SysInfo(SystemInf);\r\n {$ENDIF ~FPC}\r\n Result := SystemInf.totalram;\r\nend;\r\n{$ENDIF UNIX}\r\n{$IFDEF MSWINDOWS}\r\nvar\r\n MemoryStatusEx: TMemoryStatusEx;\r\nbegin\r\n ResetMemory(MemoryStatusEx, SizeOf(MemoryStatusEx));\r\n MemoryStatusEx.dwLength := SizeOf(MemoryStatusEx);\r\n if not GlobalMemoryStatusEx(MemoryStatusEx) then\r\n RaiseLastOSError;\r\n Result := MemoryStatusEx.ullTotalPhys;\r\nend;\r\n{$ENDIF MSWINDOWS}\r\n\r\nfunction GetFreePhysicalMemory: Int64;\r\n{$IFDEF UNIX}\r\nvar\r\n SystemInf: TSysInfo;\r\nbegin\r\n {$IFDEF FPC}\r\n SysInfo(@SystemInf);\r\n {$ELSE ~FPC}\r\n SysInfo(SystemInf);\r\n {$ENDIF ~FPC}\r\n Result := SystemInf.freeram;\r\nend;\r\n{$ENDIF UNIX}\r\n{$IFDEF MSWINDOWS}\r\nvar\r\n MemoryStatusEx: TMemoryStatusEx;\r\nbegin\r\n ResetMemory(MemoryStatusEx, SizeOf(MemoryStatusEx));\r\n MemoryStatusEx.dwLength := SizeOf(MemoryStatusEx);\r\n if not GlobalMemoryStatusEx(MemoryStatusEx) then\r\n RaiseLastOSError;\r\n Result := MemoryStatusEx.ullAvailPhys;\r\nend;\r\n\r\nfunction GetTotalPageFileMemory: Int64;\r\nvar\r\n MemoryStatusEx: TMemoryStatusEx;\r\nbegin\r\n ResetMemory(MemoryStatusEx, SizeOf(MemoryStatusEx));\r\n MemoryStatusEx.dwLength := SizeOf(MemoryStatusEx);\r\n if not GlobalMemoryStatusEx(MemoryStatusEx) then\r\n RaiseLastOSError;\r\n Result := MemoryStatusEx.ullTotalPageFile;\r\nend;\r\n\r\nfunction GetFreePageFileMemory: Int64;\r\nvar\r\n MemoryStatusEx: TMemoryStatusEx;\r\nbegin\r\n ResetMemory(MemoryStatusEx, SizeOf(MemoryStatusEx));\r\n MemoryStatusEx.dwLength := SizeOf(MemoryStatusEx);\r\n if not GlobalMemoryStatusEx(MemoryStatusEx) then\r\n RaiseLastOSError;\r\n Result := MemoryStatusEx.ullAvailPageFile;\r\nend;\r\n\r\nfunction GetTotalVirtualMemory: Int64;\r\nvar\r\n MemoryStatusEx: TMemoryStatusEx;\r\nbegin\r\n ResetMemory(MemoryStatusEx, SizeOf(MemoryStatusEx));\r\n MemoryStatusEx.dwLength := SizeOf(MemoryStatusEx);\r\n if not GlobalMemoryStatusEx(MemoryStatusEx) then\r\n RaiseLastOSError;\r\n Result := MemoryStatusEx.ullTotalVirtual;\r\nend;\r\n\r\nfunction GetFreeVirtualMemory: Int64;\r\nvar\r\n MemoryStatusEx: TMemoryStatusEx;\r\nbegin\r\n ResetMemory(MemoryStatusEx, SizeOf(MemoryStatusEx));\r\n MemoryStatusEx.dwLength := SizeOf(MemoryStatusEx);\r\n if not GlobalMemoryStatusEx(MemoryStatusEx) then\r\n RaiseLastOSError;\r\n Result := MemoryStatusEx.ullAvailVirtual;\r\nend;\r\n\r\n//=== Keyboard Information ===================================================\r\n\r\nfunction GetKeybStateHelper(VirtualKey: Cardinal; Mask: Byte): Boolean;\r\nvar\r\n Keys: TKeyboardState;\r\nbegin\r\n Keys[0] := 0;\r\n Result := GetKeyBoardState(Keys) and (Keys[VirtualKey] and Mask <> 0);\r\nend;\r\n\r\nfunction GetKeyState(const VirtualKey: Cardinal): Boolean;\r\nbegin\r\n Result := GetKeybStateHelper(VirtualKey, $80);\r\nend;\r\n\r\nfunction GetNumLockKeyState: Boolean;\r\nbegin\r\n Result := GetKeybStateHelper(VK_NUMLOCK, $01);\r\nend;\r\n\r\nfunction GetScrollLockKeyState: Boolean;\r\nbegin\r\n Result := GetKeybStateHelper(VK_SCROLL, $01);\r\nend;\r\n\r\nfunction GetCapsLockKeyState: Boolean;\r\nbegin\r\n Result := GetKeybStateHelper(VK_CAPITAL, $01);\r\nend;\r\n\r\n//=== Windows 95/98/ME system resources information ==========================\r\n\r\n{ TODO -oPJH : compare to Win9xFreeSysResources }\r\nvar\r\n ResmeterLibHandle: THandle;\r\n MyGetFreeSystemResources: function(ResType: UINT): UINT; stdcall;\r\n\r\nprocedure UnloadSystemResourcesMeterLib;\r\nbegin\r\n if ResmeterLibHandle <> 0 then\r\n begin\r\n FreeLibrary(ResmeterLibHandle);\r\n ResmeterLibHandle := 0;\r\n @MyGetFreeSystemResources := nil;\r\n end;\r\nend;\r\n\r\nfunction IsSystemResourcesMeterPresent: Boolean;\r\n\r\n procedure LoadResmeter;\r\n begin\r\n ResmeterLibHandle := SafeLoadLibrary('rsrc32.dll', SEM_FAILCRITICALERRORS);\r\n if ResmeterLibHandle <> 0 then\r\n begin\r\n @MyGetFreeSystemResources := GetProcAddress(ResmeterLibHandle, '_MyGetFreeSystemResources32@4');\r\n if not Assigned(MyGetFreeSystemResources) then\r\n UnloadSystemResourcesMeterLib;\r\n end;\r\n end;\r\n\r\nbegin\r\n if not IsWinNT and (ResmeterLibHandle = 0) then\r\n LoadResmeter;\r\n Result := (ResmeterLibHandle <> 0);\r\nend;\r\n\r\nfunction GetFreeSystemResources(const ResourceType: TFreeSysResKind): Integer;\r\nconst\r\n ParamValues: array [TFreeSysResKind] of UINT = (0, 1, 2);\r\nbegin\r\n if IsSystemResourcesMeterPresent then\r\n Result := MyGetFreeSystemResources(ParamValues[ResourceType])\r\n else\r\n Result := -1;\r\nend;\r\n\r\nfunction GetFreeSystemResources: TFreeSystemResources;\r\nbegin\r\n with Result do\r\n begin\r\n SystemRes := GetFreeSystemResources(rtSystem);\r\n GdiRes := GetFreeSystemResources(rtGdi);\r\n UserRes := GetFreeSystemResources(rtUser);\r\n end;\r\nend;\r\n\r\nfunction GetBPP: Cardinal;\r\nvar\r\n DC: HDC;\r\nbegin\r\n DC := GetDC(HWND_DESKTOP);\r\n if DC <> 0 then\r\n begin\r\n Result := GetDeviceCaps(DC, BITSPIXEL) * GetDeviceCaps(DC, PLANES);\r\n ReleaseDC(HWND_DESKTOP, DC);\r\n end\r\n else\r\n Result := 0;\r\nend;\r\n\r\n//=== Installed programs =====================================================\r\n\r\nfunction ProgIDExists(const ProgID: string): Boolean;\r\nvar\r\n Tmp: TGUID;\r\n WideProgID: WideString;\r\nbegin\r\n WideProgID := ProgID;\r\n Result := Succeeded(CLSIDFromProgID(PWideChar(WideProgID), Tmp));\r\nend;\r\n\r\nfunction IsWordInstalled: Boolean;\r\nbegin\r\n Result := ProgIDExists('Word.Application');\r\nend;\r\n\r\nfunction IsExcelInstalled: Boolean;\r\nbegin\r\n Result := ProgIDExists('Excel.Application');\r\nend;\r\n\r\nfunction IsAccessInstalled: Boolean;\r\nbegin\r\n Result := ProgIDExists('Access.Application');\r\nend;\r\n\r\nfunction IsPowerPointInstalled: Boolean;\r\nbegin\r\n Result := ProgIDExists('PowerPoint.Application');\r\nend;\r\n\r\nfunction IsFrontPageInstalled: Boolean;\r\nbegin\r\n Result := ProgIDExists('FrontPage.Application');\r\nend;\r\n\r\nfunction IsOutlookInstalled: Boolean;\r\nbegin\r\n Result := ProgIDExists('Outlook.Application');\r\nend;\r\n\r\nfunction IsInternetExplorerInstalled: Boolean;\r\nbegin\r\n Result := ProgIDExists('InternetExplorer.Application');\r\nend;\r\n\r\nfunction IsMSProjectInstalled: Boolean;\r\nbegin\r\n Result := ProgIDExists('MSProject.Application');\r\nend;\r\n\r\nfunction IsOpenOfficeInstalled: Boolean;\r\nbegin\r\n Result := ProgIDExists('com.sun.star.ServiceManager');\r\nend;\r\n\r\nfunction IsLibreOfficeInstalled: Boolean;\r\nbegin\r\n Result := ProgIDExists('com.sun.star.ServiceManager.1');\r\nend;\r\n\r\n//=== Initialization/Finalization ============================================\r\n\r\nprocedure InitSysInfo;\r\nvar\r\n SystemInfo: TSystemInfo;\r\n Kernel32FileName: string;\r\n VerFixedFileInfo: TVSFixedFileInfo;\r\nbegin\r\n { processor information related initialization }\r\n\r\n ResetMemory(SystemInfo, SizeOf(SystemInfo));\r\n GetSystemInfo(SystemInfo);\r\n ProcessorCount := SystemInfo.dwNumberOfProcessors;\r\n AllocGranularity := SystemInfo.dwAllocationGranularity;\r\n PageSize := SystemInfo.dwPageSize;\r\n\r\n { Windows version information }\r\n\r\n IsWinNT := Win32Platform = VER_PLATFORM_WIN32_NT;\r\n\r\n Kernel32FileName := GetModulePath(GetModuleHandle(kernel32));\r\n VerFixedFileInfo.dwFileDateLS := 0;\r\n if (not IsWinNT) and VersionFixedFileInfo(Kernel32FileName, VerFixedFileInfo) then\r\n KernelVersionHi := VerFixedFileInfo.dwProductVersionMS\r\n else\r\n KernelVersionHi := 0;\r\n\r\n case GetWindowsVersion of\r\n wvUnknown:\r\n ;\r\n wvWin95:\r\n IsWin95 := True;\r\n wvWin95OSR2:\r\n IsWin95OSR2 := True;\r\n wvWin98:\r\n IsWin98 := True;\r\n wvWin98SE:\r\n IsWin98SE := True;\r\n wvWinME:\r\n IsWinME := True;\r\n wvWinNT31:\r\n begin\r\n IsWinNT3 := True;\r\n IsWinNT31 := True;\r\n end;\r\n wvWinNT35:\r\n begin\r\n IsWinNT3 := True;\r\n IsWinNT35 := True;\r\n end;\r\n wvWinNT351:\r\n begin\r\n IsWinNT3 := True;\r\n IsWinNT35 := True;\r\n IsWinNT351 := True;\r\n end;\r\n wvWinNT4:\r\n IsWinNT4 := True;\r\n wvWin2000:\r\n IsWin2K := True;\r\n wvWinXP:\r\n IsWinXP := True;\r\n wvWin2003:\r\n IsWin2003 := True;\r\n wvWinXP64:\r\n IsWinXP64 := True;\r\n wvWin2003R2:\r\n IsWin2003R2 := True;\r\n wvWinVista:\r\n IsWinVista := True;\r\n wvWinServer2008:\r\n IsWinServer2008 := True;\r\n wvWin7:\r\n IsWin7 := True;\r\n wvWinServer2008R2:\r\n IsWinServer2008R2 := True;\r\n wvWin8:\r\n IsWin8 := True;\r\n wvWinServer2012:\r\n IsWinServer2012 := True;\r\n end;\r\nend;\r\n\r\nprocedure FinalizeSysInfo;\r\nbegin\r\n UnloadSystemResourcesMeterLib;\r\nend;\r\n\r\ninitialization\r\n InitSysInfo;\r\n {$IFDEF UNITVERSIONING}\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n {$ENDIF UNITVERSIONING}\r\n\r\nfinalization\r\n {$IFDEF UNITVERSIONING}\r\n UnregisterUnitVersion(HInstance);\r\n {$ENDIF UNITVERSIONING}\r\n FinalizeSysInfo;\r\n\r\n{$ENDIF MSWINDOWS}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jcl/source/common/JclSysUtils.pas", "content": "{**************************************************************************************************}\r\n{ }\r\n{ Project JEDI Code Library (JCL) }\r\n{ }\r\n{ The contents of this file are subject to the Mozilla Public License Version 1.1 (the \"License\"); }\r\n{ you may not use this file except in compliance with the License. You may obtain a copy of the }\r\n{ License at http://www.mozilla.org/MPL/ }\r\n{ }\r\n{ Software distributed under the License is distributed on an \"AS IS\" basis, WITHOUT WARRANTY OF }\r\n{ ANY KIND, either express or implied. See the License for the specific language governing rights }\r\n{ and limitations under the License. }\r\n{ }\r\n{ The Original Code is JclSysUtils.pas. }\r\n{ }\r\n{ The Initial Developer of the Original Code is Marcel van Brakel. }\r\n{ Portions created by Marcel van Brakel are Copyright (C) Marcel van Brakel. All rights reserved. }\r\n{ }\r\n{ Contributors: }\r\n{ Alexander Radchenko, }\r\n{ Andreas Hausladen (ahuser) }\r\n{ Anthony Steele }\r\n{ Bernhard Berger }\r\n{ Heri Bender }\r\n{ Jean-Fabien Connault (cycocrew) }\r\n{ Jens Fudickar }\r\n{ Jeroen Speldekamp }\r\n{ Marcel van Brakel }\r\n{ Peter Friese }\r\n{ Petr Vones (pvones) }\r\n{ Python }\r\n{ Robert Marquardt (marquardt) }\r\n{ Robert R. Marsh }\r\n{ Robert Rossmair (rrossmair) }\r\n{ Rudy Velthuis }\r\n{ Uwe Schuster (uschuster) }\r\n{ Wayne Sherman }\r\n{ }\r\n{**************************************************************************************************}\r\n{ }\r\n{ Description: Various pointer and class related routines. }\r\n{ }\r\n{**************************************************************************************************}\r\n{ }\r\n{ Last modified: $Date:: 2012-09-03 16:52:06 +0200 (lun. 03 sept. 2012) $ }\r\n{ Revision: $Rev:: 3860 $ }\r\n{ Author: $Author:: obones $ }\r\n{ }\r\n{**************************************************************************************************}\r\n\r\nunit JclSysUtils;\r\n\r\n{$I jcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n {$IFDEF HAS_UNITSCOPE}\r\n {$IFDEF MSWINDOWS}\r\n Winapi.Windows,\r\n {$ENDIF MSWINDOWS}\r\n System.SysUtils, System.Classes, System.TypInfo, System.SyncObjs,\r\n {$ELSE ~HAS_UNITSCOPE}\r\n {$IFDEF MSWINDOWS}\r\n Windows,\r\n {$ENDIF MSWINDOWS}\r\n SysUtils, Classes, TypInfo, SyncObjs,\r\n {$ENDIF ~HAS_UNITSCOPE}\r\n JclBase, JclSynch;\r\n\r\n// memory initialization\r\n// first parameter is \"out\" to make FPC happy with uninitialized values\r\nprocedure ResetMemory(out P; Size: Longint);\r\n\r\n// Pointer manipulation\r\nprocedure GetAndFillMem(var P: Pointer; const Size: Integer; const Value: Byte);\r\nprocedure FreeMemAndNil(var P: Pointer);\r\nfunction PCharOrNil(const S: string): PChar;\r\nfunction PAnsiCharOrNil(const S: AnsiString): PAnsiChar;\r\n{$IFDEF SUPPORTS_WIDESTRING}\r\nfunction PWideCharOrNil(const W: WideString): PWideChar;\r\n{$ENDIF SUPPORTS_WIDESTRING}\r\n\r\nfunction SizeOfMem(const APointer: Pointer): Integer;\r\n\r\nfunction WriteProtectedMemory(BaseAddress, Buffer: Pointer; Size: Cardinal;\r\n out WrittenBytes: Cardinal): Boolean;\r\n\r\n// Guards\r\ntype\r\n ISafeGuard = interface\r\n function ReleaseItem: Pointer;\r\n function GetItem: Pointer;\r\n procedure FreeItem;\r\n property Item: Pointer read GetItem;\r\n end;\r\n\r\n IMultiSafeGuard = interface (IInterface)\r\n function AddItem(Item: Pointer): Pointer;\r\n procedure FreeItem(Index: Integer);\r\n function GetCount: Integer;\r\n function GetItem(Index: Integer): Pointer;\r\n function ReleaseItem(Index: Integer): Pointer;\r\n property Count: Integer read GetCount;\r\n property Items[Index: Integer]: Pointer read GetItem;\r\n end;\r\n\r\n TJclSafeGuard = class(TInterfacedObject, ISafeGuard)\r\n private\r\n FItem: Pointer;\r\n public\r\n constructor Create(Mem: Pointer);\r\n destructor Destroy; override;\r\n { ISafeGuard }\r\n function ReleaseItem: Pointer;\r\n function GetItem: Pointer;\r\n procedure FreeItem; virtual;\r\n property Item: Pointer read GetItem;\r\n end;\r\n\r\n TJclObjSafeGuard = class(TJclSafeGuard, ISafeGuard)\r\n public\r\n constructor Create(Obj: TObject);\r\n { ISafeGuard }\r\n procedure FreeItem; override;\r\n end;\r\n\r\n TJclMultiSafeGuard = class(TInterfacedObject, IMultiSafeGuard)\r\n private\r\n FItems: TList;\r\n public\r\n constructor Create;\r\n destructor Destroy; override;\r\n { IMultiSafeGuard }\r\n function AddItem(Item: Pointer): Pointer;\r\n procedure FreeItem(Index: Integer); virtual;\r\n function GetCount: Integer;\r\n function GetItem(Index: Integer): Pointer;\r\n function ReleaseItem(Index: Integer): Pointer;\r\n property Count: Integer read GetCount;\r\n property Items[Index: Integer]: Pointer read GetItem;\r\n end;\r\n\r\n TJclObjMultiSafeGuard = class(TJclMultiSafeGuard, IMultiSafeGuard)\r\n public\r\n { IMultiSafeGuard }\r\n procedure FreeItem(Index: Integer); override;\r\n end;\r\n\r\nfunction Guard(Mem: Pointer; out SafeGuard: ISafeGuard): Pointer; overload;\r\nfunction Guard(Obj: TObject; out SafeGuard: ISafeGuard): TObject; overload;\r\n\r\nfunction Guard(Mem: Pointer; var SafeGuard: IMultiSafeGuard): Pointer; overload;\r\nfunction Guard(Obj: TObject; var SafeGuard: IMultiSafeGuard): TObject; overload;\r\n\r\nfunction GuardGetMem(Size: Cardinal; out SafeGuard: ISafeGuard): Pointer;\r\nfunction GuardAllocMem(Size: Cardinal; out SafeGuard: ISafeGuard): Pointer;\r\n\r\n(*\r\n{$IFDEF SUPPORTS_GENERICS}\r\ntype\r\n ISafeGuard = interface\r\n function ReleaseItem: T;\r\n function GetItem: T;\r\n procedure FreeItem;\r\n property Item: T read GetItem;\r\n end;\r\n\r\n TSafeGuard = class(TObject, ISafeGuard)\r\n private\r\n FItem: T;\r\n function ReleaseItem: T;\r\n function GetItem: T;\r\n procedure FreeItem;\r\n\r\n constructor Create(Instance: T);\r\n destructor Destroy; override;\r\n public\r\n class function New(Instance: T): ISafeGuard; static;\r\n end;\r\n{$ENDIF SUPPORTS_GENERICS}\r\n*)\r\n\r\n{ Shared memory between processes functions }\r\n\r\n// Functions for the shared memory owner\r\ntype\r\n ESharedMemError = class(EJclError);\r\n\r\n{$IFDEF MSWINDOWS}\r\n\r\n{ SharedGetMem return ERROR_ALREADY_EXISTS if the shared memory is already\r\n allocated, otherwise it returns 0.\r\n Throws ESharedMemError if the Name is invalid. }\r\nfunction SharedGetMem(var P{: Pointer}; const Name: string; Size: Cardinal;\r\n DesiredAccess: Cardinal = FILE_MAP_ALL_ACCESS): Integer;\r\n\r\n{ SharedAllocMem calls SharedGetMem and then fills the memory with zero if\r\n it was not already allocated.\r\n Throws ESharedMemError if the Name is invalid. }\r\nfunction SharedAllocMem(const Name: string; Size: Cardinal;\r\n DesiredAccess: Cardinal = FILE_MAP_ALL_ACCESS): Pointer;\r\n\r\n{ SharedFreeMem releases the shared memory if it was the last reference. }\r\nfunction SharedFreeMem(var P{: Pointer}): Boolean;\r\n\r\n// Functions for the shared memory user\r\n\r\n{ SharedOpenMem returns True if the shared memory was already allocated by\r\n SharedGetMem or SharedAllocMem. Otherwise it returns False.\r\n Throws ESharedMemError if the Name is invalid. }\r\n\r\nfunction SharedOpenMem(var P{: Pointer}; const Name: string;\r\n DesiredAccess: Cardinal = FILE_MAP_ALL_ACCESS): Boolean; overload;\r\n\r\n{ SharedOpenMem return nil if the shared memory was not already allocated\r\n by SharedGetMem or SharedAllocMem.\r\n Throws ESharedMemError if the Name is invalid. }\r\nfunction SharedOpenMem(const Name: string;\r\n DesiredAccess: Cardinal = FILE_MAP_ALL_ACCESS): Pointer; overload;\r\n\r\n{ SharedCloseMem releases the shared memory if it was the last reference. }\r\nfunction SharedCloseMem(var P{: Pointer}): Boolean;\r\n\r\n{$ENDIF MSWINDOWS}\r\n\r\n// Binary search\r\nfunction SearchSortedList(List: TList; SortFunc: TListSortCompare; Item: Pointer;\r\n Nearest: Boolean = False): Integer;\r\n\r\ntype\r\n TUntypedSearchCompare = function(Param: Pointer; ItemIndex: Integer; const Value): Integer;\r\n\r\nfunction SearchSortedUntyped(Param: Pointer; ItemCount: Integer; SearchFunc: TUntypedSearchCompare;\r\n const Value; Nearest: Boolean = False): Integer;\r\n\r\n// Dynamic array sort and search routines\r\ntype\r\n TDynArraySortCompare = function (Item1, Item2: Pointer): Integer;\r\n\r\nprocedure SortDynArray(const ArrayPtr: Pointer; ElementSize: Cardinal; SortFunc: TDynArraySortCompare);\r\n// Usage: SortDynArray(Array, SizeOf(Array[0]), SortFunction);\r\nfunction SearchDynArray(const ArrayPtr: Pointer; ElementSize: Cardinal; SortFunc: TDynArraySortCompare;\r\n ValuePtr: Pointer; Nearest: Boolean = False): SizeInt;\r\n// Usage: SearchDynArray(Array, SizeOf(Array[0]), SortFunction, @SearchedValue);\r\n\r\n{ Various compare functions for basic types }\r\n\r\nfunction DynArrayCompareByte(Item1, Item2: Pointer): Integer;\r\nfunction DynArrayCompareShortInt(Item1, Item2: Pointer): Integer;\r\nfunction DynArrayCompareWord(Item1, Item2: Pointer): Integer;\r\nfunction DynArrayCompareSmallInt(Item1, Item2: Pointer): Integer;\r\nfunction DynArrayCompareInteger(Item1, Item2: Pointer): Integer;\r\nfunction DynArrayCompareCardinal(Item1, Item2: Pointer): Integer;\r\nfunction DynArrayCompareInt64(Item1, Item2: Pointer): Integer;\r\n\r\nfunction DynArrayCompareSingle(Item1, Item2: Pointer): Integer;\r\nfunction DynArrayCompareDouble(Item1, Item2: Pointer): Integer;\r\nfunction DynArrayCompareExtended(Item1, Item2: Pointer): Integer;\r\nfunction DynArrayCompareFloat(Item1, Item2: Pointer): Integer;\r\n\r\nfunction DynArrayCompareAnsiString(Item1, Item2: Pointer): Integer;\r\nfunction DynArrayCompareAnsiText(Item1, Item2: Pointer): Integer;\r\nfunction DynArrayCompareWideString(Item1, Item2: Pointer): Integer;\r\nfunction DynArrayCompareWideText(Item1, Item2: Pointer): Integer;\r\nfunction DynArrayCompareString(Item1, Item2: Pointer): Integer;\r\nfunction DynArrayCompareText(Item1, Item2: Pointer): Integer;\r\n\r\n// Object lists\r\nprocedure ClearObjectList(List: TList);\r\nprocedure FreeObjectList(var List: TList);\r\n\r\n// Reference memory stream\r\ntype\r\n TJclReferenceMemoryStream = class(TCustomMemoryStream)\r\n public\r\n constructor Create(const Ptr: Pointer; Size: Longint);\r\n function Write(const Buffer; Count: Longint): Longint; override;\r\n end;\r\n\r\n// AutoPtr\r\ntype\r\n IAutoPtr = interface\r\n { Returns the object as pointer, so it is easier to assign it to a variable }\r\n function AsPointer: Pointer;\r\n { Returns the AutoPtr handled object }\r\n function AsObject: TObject;\r\n { Releases the object from the AutoPtr. The AutoPtr looses the control over\r\n the object. }\r\n function ReleaseObject: TObject;\r\n end;\r\n\r\n TJclAutoPtr = class(TInterfacedObject, IAutoPtr)\r\n private\r\n FValue: TObject;\r\n public\r\n constructor Create(AValue: TObject);\r\n destructor Destroy; override;\r\n { IAutoPtr }\r\n function AsPointer: Pointer;\r\n function AsObject: TObject;\r\n function ReleaseObject: TObject;\r\n end;\r\n\r\nfunction CreateAutoPtr(Value: TObject): IAutoPtr;\r\n\r\n// Replacement for the C ternary conditional operator ? :\r\nfunction Iff(const Condition: Boolean; const TruePart, FalsePart: string): string; overload;\r\nfunction Iff(const Condition: Boolean; const TruePart, FalsePart: Char): Char; overload;\r\nfunction Iff(const Condition: Boolean; const TruePart, FalsePart: Byte): Byte; overload;\r\nfunction Iff(const Condition: Boolean; const TruePart, FalsePart: Integer): Integer; overload;\r\nfunction Iff(const Condition: Boolean; const TruePart, FalsePart: Cardinal): Cardinal; overload;\r\nfunction Iff(const Condition: Boolean; const TruePart, FalsePart: Float): Float; overload;\r\nfunction Iff(const Condition: Boolean; const TruePart, FalsePart: Boolean): Boolean; overload;\r\nfunction Iff(const Condition: Boolean; const TruePart, FalsePart: Pointer): Pointer; overload;\r\nfunction Iff(const Condition: Boolean; const TruePart, FalsePart: Int64): Int64; overload;\r\n{$IFDEF SUPPORTS_VARIANT}\r\nfunction Iff(const Condition: Boolean; const TruePart, FalsePart: Variant): Variant; overload;\r\n{$ENDIF SUPPORTS_VARIANT}\r\n\r\n// Classes information and manipulation\r\ntype\r\n EJclVMTError = class(EJclError);\r\n\r\n// Virtual Methods\r\n{$IFNDEF FPC}\r\nfunction GetVirtualMethodCount(AClass: TClass): Integer;\r\n{$ENDIF ~FPC}\r\nfunction GetVirtualMethod(AClass: TClass; const Index: Integer): Pointer;\r\nprocedure SetVirtualMethod(AClass: TClass; const Index: Integer; const Method: Pointer);\r\n\r\n// Dynamic Methods\r\ntype\r\n TDynamicIndexList = array [0..MaxInt div 16] of Word;\r\n PDynamicIndexList = ^TDynamicIndexList;\r\n TDynamicAddressList = array [0..MaxInt div 16] of Pointer;\r\n PDynamicAddressList = ^TDynamicAddressList;\r\n\r\nfunction GetDynamicMethodCount(AClass: TClass): Integer;\r\nfunction GetDynamicIndexList(AClass: TClass): PDynamicIndexList;\r\nfunction GetDynamicAddressList(AClass: TClass): PDynamicAddressList;\r\nfunction HasDynamicMethod(AClass: TClass; Index: Integer): Boolean;\r\n{$IFNDEF FPC}\r\nfunction GetDynamicMethod(AClass: TClass; Index: Integer): Pointer;\r\n{$ENDIF ~FPC}\r\n\r\n{ init table methods }\r\n\r\nfunction GetInitTable(AClass: TClass): PTypeInfo;\r\n\r\n{ field table methods }\r\n\r\ntype\r\n PFieldEntry = ^TFieldEntry;\r\n TFieldEntry = packed record\r\n OffSet: Integer;\r\n IDX: Word;\r\n Name: ShortString;\r\n end;\r\n\r\n PFieldClassTable = ^TFieldClassTable;\r\n TFieldClassTable = packed record\r\n Count: Smallint;\r\n Classes: array [0..8191] of ^TPersistentClass;\r\n end;\r\n\r\n PFieldTable = ^TFieldTable;\r\n TFieldTable = packed record\r\n EntryCount: Word;\r\n FieldClassTable: PFieldClassTable;\r\n FirstEntry: TFieldEntry;\r\n {Entries: array [1..65534] of TFieldEntry;}\r\n end;\r\n\r\nfunction GetFieldTable(AClass: TClass): PFieldTable;\r\n\r\n{ method table }\r\n\r\ntype\r\n PMethodEntry = ^TMethodEntry;\r\n TMethodEntry = packed record\r\n EntrySize: Word;\r\n Address: Pointer;\r\n Name: ShortString;\r\n end;\r\n\r\n PMethodTable = ^TMethodTable;\r\n TMethodTable = packed record\r\n Count: Word;\r\n FirstEntry: TMethodEntry;\r\n {Entries: array [1..65534] of TMethodEntry;}\r\n end;\r\n\r\nfunction GetMethodTable(AClass: TClass): PMethodTable;\r\nfunction GetMethodEntry(MethodTable: PMethodTable; Index: Integer): PMethodEntry;\r\n\r\n// Class Parent\r\nprocedure SetClassParent(AClass: TClass; NewClassParent: TClass);\r\nfunction GetClassParent(AClass: TClass): TClass;\r\n\r\n{$IFNDEF FPC}\r\nfunction IsClass(Address: Pointer): Boolean;\r\nfunction IsObject(Address: Pointer): Boolean;\r\n{$ENDIF ~FPC}\r\n\r\nfunction InheritsFromByName(AClass: TClass; const AClassName: string): Boolean;\r\n\r\n// Interface information\r\nfunction GetImplementorOfInterface(const I: IInterface): TObject;\r\n\r\n// interfaced persistent\r\ntype\r\n TJclInterfacedPersistent = class(TInterfacedPersistent, IInterface)\r\n protected\r\n FOwnerInterface: IInterface;\r\n FRefCount: Integer;\r\n public\r\n procedure AfterConstruction; override;\r\n { IInterface }\r\n // function QueryInterface(const IID: TGUID; out Obj): HRESULT; virtual; stdcall;\r\n function _AddRef: Integer; stdcall;\r\n function _Release: Integer; stdcall;\r\n end;\r\n\r\n// Numeric formatting routines\r\ntype\r\n TDigitCount = 0..255;\r\n TDigitValue = -1..35; // invalid, '0'..'9', 'A'..'Z'\r\n TNumericSystemBase = 2..Succ(High(TDigitValue));\r\n\r\n TJclNumericFormat = class(TObject)\r\n private\r\n FWantedPrecision: TDigitCount;\r\n FPrecision: TDigitCount;\r\n FNumberOfFractionalDigits: TDigitCount;\r\n FExpDivision: Integer;\r\n FDigitBlockSize: TDigitCount;\r\n FWidth: TDigitCount;\r\n FSignChars: array [Boolean] of Char;\r\n FBase: TNumericSystemBase;\r\n FFractionalPartSeparator: Char;\r\n FDigitBlockSeparator: Char;\r\n FShowPositiveSign: Boolean;\r\n FPaddingChar: Char;\r\n FMultiplier: string;\r\n function GetDigitValue(Digit: Char): Integer;\r\n function GetNegativeSign: Char;\r\n function GetPositiveSign: Char;\r\n procedure InvalidDigit(Digit: Char);\r\n procedure SetPrecision(const Value: TDigitCount);\r\n procedure SetBase(const Value: TNumericSystemBase);\r\n procedure SetNegativeSign(const Value: Char);\r\n procedure SetPositiveSign(const Value: Char);\r\n procedure SetExpDivision(const Value: Integer);\r\n protected\r\n function IntToStr(const Value: Int64; out FirstDigitPos: Integer): string; overload;\r\n function ShowSign(const Value: Float): Boolean; overload;\r\n function ShowSign(const Value: Int64): Boolean; overload;\r\n function SignChar(const Value: Float): Char; overload;\r\n function SignChar(const Value: Int64): Char; overload;\r\n property WantedPrecision: TDigitCount read FWantedPrecision;\r\n public\r\n constructor Create;\r\n function Digit(DigitValue: TDigitValue): Char;\r\n function DigitValue(Digit: Char): TDigitValue;\r\n function IsDigit(Value: Char): Boolean;\r\n function Sign(Value: Char): Integer;\r\n procedure GetMantissaExp(const Value: Float; out Mantissa: string; out Exponent: Integer);\r\n function FloatToHTML(const Value: Float): string;\r\n function IntToStr(const Value: Int64): string; overload;\r\n function FloatToStr(const Value: Float): string; overload;\r\n function StrToInt(const Value: string): Int64;\r\n property Base: TNumericSystemBase read FBase write SetBase;\r\n property Precision: TDigitCount read FPrecision write SetPrecision;\r\n property NumberOfFractionalDigits: TDigitCount read FNumberOfFractionalDigits write FNumberOfFractionalDigits;\r\n property ExponentDivision: Integer read FExpDivision write SetExpDivision;\r\n property DigitBlockSize: TDigitCount read FDigitBlockSize write FDigitBlockSize;\r\n property DigitBlockSeparator: Char read FDigitBlockSeparator write FDigitBlockSeparator;\r\n property FractionalPartSeparator: Char read FFractionalPartSeparator write FFractionalPartSeparator;\r\n property Multiplier: string read FMultiplier write FMultiplier;\r\n property PaddingChar: Char read FPaddingChar write FPaddingChar;\r\n property ShowPositiveSign: Boolean read FShowPositiveSign write FShowPositiveSign;\r\n property Width: TDigitCount read FWidth write FWidth;\r\n property NegativeSign: Char read GetNegativeSign write SetNegativeSign;\r\n property PositiveSign: Char read GetPositiveSign write SetPositiveSign;\r\n end;\r\n\r\nfunction IntToStrZeroPad(Value, Count: Integer): string;\r\n\r\n// Child processes\r\ntype\r\n // e.g. TStrings.Append\r\n TTextHandler = procedure(const Text: string) of object;\r\n TJclProcessPriority = (ppIdle, ppNormal, ppHigh, ppRealTime, ppBelowNormal, ppAboveNormal);\r\n\r\nconst\r\n ABORT_EXIT_CODE = {$IFDEF MSWINDOWS} ERROR_CANCELLED {$ELSE} 1223 {$ENDIF};\r\n\r\nfunction Execute(const CommandLine: string; OutputLineCallback: TTextHandler; RawOutput: Boolean = False;\r\n AbortPtr: PBoolean = nil; ProcessPriority: TJclProcessPriority = ppNormal): Cardinal; overload;\r\nfunction Execute(const CommandLine: string; AbortEvent: TJclEvent;\r\n OutputLineCallback: TTextHandler; RawOutput: Boolean = False; ProcessPriority: TJclProcessPriority = ppNormal): Cardinal; overload;\r\nfunction Execute(const CommandLine: string; var Output: string; RawOutput: Boolean = False;\r\n AbortPtr: PBoolean = nil; ProcessPriority: TJclProcessPriority = ppNormal): Cardinal; overload;\r\nfunction Execute(const CommandLine: string; AbortEvent: TJclEvent;\r\n var Output: string; RawOutput: Boolean = False; ProcessPriority: TJclProcessPriority = ppNormal): Cardinal; overload;\r\n\r\nfunction Execute(const CommandLine: string; OutputLineCallback, ErrorLineCallback: TTextHandler;\r\n RawOutput: Boolean = False; RawError: Boolean = False; AbortPtr: PBoolean = nil; ProcessPriority: TJclProcessPriority = ppNormal): Cardinal; overload;\r\nfunction Execute(const CommandLine: string; AbortEvent: TJclEvent;\r\n OutputLineCallback, ErrorLineCallback: TTextHandler; RawOutput: Boolean = False; RawError: Boolean = False; ProcessPriority: TJclProcessPriority = ppNormal): Cardinal; overload;\r\nfunction Execute(const CommandLine: string; var Output, Error: string;\r\n RawOutput: Boolean = False; RawError: Boolean = False; AbortPtr: PBoolean = nil; ProcessPriority: TJclProcessPriority = ppNormal): Cardinal; overload;\r\nfunction Execute(const CommandLine: string; AbortEvent: TJclEvent;\r\n var Output, Error: string; RawOutput: Boolean = False; RawError: Boolean = False; ProcessPriority: TJclProcessPriority = ppNormal): Cardinal; overload;\r\n\r\ntype\r\n{$HPPEMIT 'namespace Jclsysutils'}\r\n{$HPPEMIT '{'}\r\n{$HPPEMIT ' // For some reason, the generator puts this interface after its first'}\r\n{$HPPEMIT ' // usage, resulting in an unusable header file. We fix this by forward'}\r\n{$HPPEMIT ' // declaring the interface.'}\r\n{$HPPEMIT ' __interface IJclCommandLineTool;'}\r\n(*$HPPEMIT '}'*)\r\n\r\n IJclCommandLineTool = interface\r\n ['{A0034B09-A074-D811-847D-0030849E4592}']\r\n function GetExeName: string;\r\n function GetOptions: TStrings;\r\n function GetOutput: string;\r\n function GetOutputCallback: TTextHandler;\r\n procedure AddPathOption(const Option, Path: string);\r\n function Execute(const CommandLine: string): Boolean;\r\n procedure SetOutputCallback(const CallbackMethod: TTextHandler);\r\n property ExeName: string read GetExeName;\r\n property Options: TStrings read GetOptions;\r\n property OutputCallback: TTextHandler read GetOutputCallback write SetOutputCallback;\r\n property Output: string read GetOutput;\r\n end;\r\n\r\n EJclCommandLineToolError = class(EJclError);\r\n\r\n TJclCommandLineTool = class(TInterfacedObject, IJclCommandLineTool)\r\n private\r\n FExeName: string;\r\n FOptions: TStringList;\r\n FOutput: string;\r\n FOutputCallback: TTextHandler;\r\n public\r\n constructor Create(const AExeName: string);\r\n destructor Destroy; override;\r\n { IJclCommandLineTool }\r\n function GetExeName: string;\r\n function GetOptions: TStrings;\r\n function GetOutput: string;\r\n function GetOutputCallback: TTextHandler;\r\n procedure AddPathOption(const Option, Path: string);\r\n function Execute(const CommandLine: string): Boolean;\r\n procedure SetOutputCallback(const CallbackMethod: TTextHandler);\r\n property ExeName: string read GetExeName;\r\n property Options: TStrings read GetOptions;\r\n property OutputCallback: TTextHandler read GetOutputCallback write SetOutputCallback;\r\n property Output: string read GetOutput;\r\n end;\r\n\r\n// Console Utilities\r\nfunction ReadKey: Char;\r\n\r\n// Loading of modules (DLLs)\r\ntype\r\n{$IFDEF MSWINDOWS}\r\n TModuleHandle = HINST;\r\n{$ENDIF MSWINDOWS}\r\n{$IFDEF LINUX}\r\n TModuleHandle = Pointer;\r\n{$ENDIF LINUX}\r\n\r\nconst\r\n INVALID_MODULEHANDLE_VALUE = TModuleHandle(0);\r\n\r\nfunction LoadModule(var Module: TModuleHandle; FileName: string): Boolean;\r\nfunction LoadModuleEx(var Module: TModuleHandle; FileName: string; Flags: Cardinal): Boolean;\r\nprocedure UnloadModule(var Module: TModuleHandle);\r\nfunction GetModuleSymbol(Module: TModuleHandle; SymbolName: string): Pointer;\r\nfunction GetModuleSymbolEx(Module: TModuleHandle; SymbolName: string; var Accu: Boolean): Pointer;\r\nfunction ReadModuleData(Module: TModuleHandle; SymbolName: string; var Buffer; Size: Cardinal): Boolean;\r\nfunction WriteModuleData(Module: TModuleHandle; SymbolName: string; var Buffer; Size: Cardinal): Boolean;\r\n\r\n// Conversion Utilities\r\ntype\r\n EJclConversionError = class(EJclError);\r\n\r\nfunction StrToBoolean(const S: string): Boolean;\r\nfunction BooleanToStr(B: Boolean): string;\r\nfunction IntToBool(I: Integer): Boolean;\r\nfunction BoolToInt(B: Boolean): Integer;\r\n\r\nfunction TryStrToUInt(const Value: string; out Res: Cardinal): Boolean;\r\nfunction StrToUIntDef(const Value: string; const Default: Cardinal): Cardinal;\r\nfunction StrToUInt(const Value: string): Cardinal;\r\n\r\nconst\r\n {$IFDEF MSWINDOWS}\r\n ListSeparator = ';';\r\n {$ENDIF MSWINDOWS}\r\n {$IFDEF LINUX}\r\n ListSeparator = ':';\r\n {$ENDIF LINUX}\r\n\r\n// functions to handle items in a separated list of items\r\n// add items at the end\r\nprocedure ListAddItems(var List: string; const Separator, Items: string);\r\n// add items at the end if they are not present\r\nprocedure ListIncludeItems(var List: string; const Separator, Items: string);\r\n// delete multiple items\r\nprocedure ListRemoveItems(var List: string; const Separator, Items: string);\r\n// delete one item\r\nprocedure ListDelItem(var List: string; const Separator: string;\r\n const Index: Integer);\r\n// return the number of item\r\nfunction ListItemCount(const List, Separator: string): Integer;\r\n// return the Nth item\r\nfunction ListGetItem(const List, Separator: string;\r\n const Index: Integer): string;\r\n// set the Nth item\r\nprocedure ListSetItem(var List: string; const Separator: string;\r\n const Index: Integer; const Value: string);\r\n// return the index of an item\r\nfunction ListItemIndex(const List, Separator, Item: string): Integer;\r\n\r\n// RTL package information\r\nfunction SystemTObjectInstance: TJclAddr;\r\nfunction IsCompiledWithPackages: Boolean;\r\n\r\n// GUID\r\nfunction JclGUIDToString(const GUID: TGUID): string;\r\nfunction JclStringToGUID(const S: string): TGUID;\r\nfunction GUIDEquals(const GUID1, GUID2: TGUID): Boolean;\r\n\r\n// thread safe support\r\n\r\ntype\r\n TJclIntfCriticalSection = class(TInterfacedObject, IInterface)\r\n private\r\n FCriticalSection: TCriticalSection;\r\n public\r\n constructor Create;\r\n destructor Destroy; override;\r\n { IInterface }\r\n // function QueryInterface(const IID: TGUID; out Obj): HRESULT; stdcall;\r\n function _AddRef: Integer; stdcall;\r\n function _Release: Integer; stdcall;\r\n end;\r\n\r\ntype\r\n {$IFDEF BORLAND}\r\n {$IFDEF COMPILER16_UP}\r\n TFileHandle = THandle;\r\n {$ELSE ~COMPILER16_UP}\r\n TFileHandle = Integer;\r\n {$ENDIF ~COMPILER16_UP}\r\n {$ELSE ~BORLAND}\r\n TFileHandle = THandle;\r\n {$ENDIF ~BORLAND}\r\n\r\n TJclSimpleLog = class (TObject)\r\n private\r\n FDateTimeFormatStr: String;\r\n FLogFileHandle: TFileHandle;\r\n FLogFileName: string;\r\n FLoggingActive: Boolean;\r\n FLogWasEmpty: Boolean;\r\n function GetLogOpen: Boolean;\r\n protected\r\n function CreateDefaultFileName: string;\r\n public\r\n constructor Create(const ALogFileName: string = '');\r\n destructor Destroy; override;\r\n procedure ClearLog;\r\n procedure CloseLog;\r\n procedure OpenLog;\r\n procedure Write(const Text: string; Indent: Integer = 0; KeepOpen: Boolean = true); overload;\r\n procedure Write(Strings: TStrings; Indent: Integer = 0; KeepOpen: Boolean = true); overload;\r\n //Writes a line to the log file. The current timestamp is written before the line.\r\n procedure TimeWrite(const Text: string; Indent: Integer = 0; KeepOpen: Boolean = true); overload;\r\n procedure TimeWrite(Strings: TStrings; Indent: Integer = 0; KeepOpen: Boolean = true); overload;\r\n procedure WriteStamp(SeparatorLen: Integer = 0; KeepOpen: Boolean = true);\r\n // DateTimeFormatStr property assumes the values described in \"FormatDateTime Function\" in Delphi Help\r\n property DateTimeFormatStr: String read FDateTimeFormatStr write FDateTimeFormatStr;\r\n property LogFileName: string read FLogFileName;\r\n //1 Property to activate / deactivate the logging\r\n property LoggingActive: Boolean read FLoggingActive write FLoggingActive default True;\r\n property LogOpen: Boolean read GetLogOpen;\r\n end;\r\n\r\ntype\r\n TJclFormatSettings = class\r\n private\r\n function GetCurrencyDecimals: Byte; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\n function GetCurrencyFormat: Byte; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\n function GetCurrencyString: string; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\n function GetDateSeparator: Char; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\n function GetDayNamesHighIndex: Integer; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\n function GetDayNamesLowIndex: Integer; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\n function GetDecimalSeparator: Char; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\n function GetListSeparator: Char; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\n function GetLongDateFormat: string; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\n function GetLongDayNames(AIndex: Integer): string; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\n function GetLongMonthNames(AIndex: Integer): string; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\n function GetLongTimeFormat: string; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\n function GetMonthNamesHighIndex: Integer; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\n function GetMonthNamesLowIndex: Integer; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\n function GetNegCurrFormat: Byte; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\n function GetShortDateFormat: string; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\n function GetShortDayNames(AIndex: Integer): string; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\n function GetShortMonthNames(AIndex: Integer): string; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\n function GetShortTimeFormat: string; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\n function GetThousandSeparator: Char; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\n function GetTimeAMString: string; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\n function GetTimePMString: string; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\n function GetTimeSeparator: Char; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\n function GetTwoDigitYearCenturyWindow: Word; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\n procedure SetCurrencyDecimals(AValue: Byte); {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\n procedure SetCurrencyFormat(const AValue: Byte); {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\n procedure SetCurrencyString(AValue: string); {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\n procedure SetDateSeparator(const AValue: Char); {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\n procedure SetDecimalSeparator(AValue: Char); {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\n procedure SetListSeparator(const AValue: Char); {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\n procedure SetLongDateFormat(const AValue: string); {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\n procedure SetLongTimeFormat(const AValue: string); {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\n procedure SetNegCurrFormat(const AValue: Byte); {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\n procedure SetShortDateFormat(AValue: string); {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\n procedure SetShortTimeFormat(const AValue: string); {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\n procedure SetThousandSeparator(AValue: Char); {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\n procedure SetTimeAMString(const AValue: string); {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\n procedure SetTimePMString(const AValue: string); {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\n procedure SetTimeSeparator(const AValue: Char); {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\n procedure SetTwoDigitYearCenturyWindow(const AValue: Word); {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\n public\r\n property CurrencyDecimals: Byte read GetCurrencyDecimals write SetCurrencyDecimals;\r\n property CurrencyFormat: Byte read GetCurrencyFormat write SetCurrencyFormat;\r\n property CurrencyString: string read GetCurrencyString write SetCurrencyString;\r\n property DateSeparator: Char read GetDateSeparator write SetDateSeparator;\r\n property DayNamesHighIndex: Integer read GetDayNamesHighIndex;\r\n property DayNamesLowIndex: Integer read GetDayNamesLowIndex;\r\n property DecimalSeparator: Char read GetDecimalSeparator write SetDecimalSeparator;\r\n property ListSeparator: Char read GetListSeparator write SetListSeparator;\r\n property LongDateFormat: string read GetLongDateFormat write SetLongDateFormat;\r\n property LongDayNames[AIndex: Integer]: string read GetLongDayNames;\r\n property LongMonthNames[AIndex: Integer]: string read GetLongMonthNames;\r\n property LongTimeFormat: string read GetLongTimeFormat write SetLongTimeFormat;\r\n property MonthNamesHighIndex: Integer read GetMonthNamesHighIndex;\r\n property MonthNamesLowIndex: Integer read GetMonthNamesLowIndex;\r\n property NegCurrFormat: Byte read GetNegCurrFormat write SetNegCurrFormat;\r\n property ShortDateFormat: string read GetShortDateFormat write SetShortDateFormat;\r\n property ShortDayNames[AIndex: Integer]: string read GetShortDayNames;\r\n property ShortMonthNames[AIndex: Integer]: string read GetShortMonthNames;\r\n property ShortTimeFormat: string read GetShortTimeFormat write SetShortTimeFormat;\r\n property ThousandSeparator: Char read GetThousandSeparator write SetThousandSeparator;\r\n property TimeAMString: string read GetTimeAMString write SetTimeAMString;\r\n property TimePMString: string read GetTimePMString write SetTimePMString;\r\n property TimeSeparator: Char read GetTimeSeparator write SetTimeSeparator;\r\n property TwoDigitYearCenturyWindow: Word read GetTwoDigitYearCenturyWindow write SetTwoDigitYearCenturyWindow;\r\n end;\r\n\r\nvar\r\n JclFormatSettings: TJclFormatSettings;\r\n\r\n// Procedure to initialize the SimpleLog Variable\r\nprocedure InitSimpleLog(const ALogFileName: string = ''; AOpenLog: Boolean = true);\r\n\r\n// Global Variable to make it easier for an application wide log handling.\r\n// Must be initialized with InitSimpleLog before using\r\nvar\r\n SimpleLog : TJclSimpleLog;\r\n\r\n\r\n// Validates if then variant value is null or is empty\r\nfunction VarIsNullEmpty(const V: Variant): Boolean;\r\n// Validates if then variant value is null or is empty or VarToStr is a blank string\r\nfunction VarIsNullEmptyBlank(const V: Variant): Boolean;\r\n\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jcl.svn.sourceforge.net/svnroot/jcl/tags/JCL-2.4-Build4571/jcl/source/common/JclSysUtils.pas $';\r\n Revision: '$Revision: 3860 $';\r\n Date: '$Date: 2012-09-03 16:52:06 +0200 (lun. 03 sept. 2012) $';\r\n LogPath: 'JCL\\source\\common';\r\n Extra: '';\r\n Data: nil\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n {$IFDEF HAS_UNIT_LIBC}\r\n Libc,\r\n {$ENDIF HAS_UNIT_LIBC}\r\n {$IFDEF MSWINDOWS}\r\n JclConsole,\r\n {$ENDIF MSWINDOWS}\r\n {$IFDEF HAS_UNITSCOPE}\r\n System.Variants, System.Types, System.Contnrs,\r\n {$IFDEF HAS_UNIT_ANSISTRINGS}\r\n System.AnsiStrings,\r\n {$ENDIF HAS_UNIT_ANSISTRINGS}\r\n {$ELSE ~HAS_UNITSCOPE}\r\n Variants, Types, Contnrs,\r\n {$IFDEF HAS_UNIT_ANSISTRINGS}\r\n AnsiStrings,\r\n {$ENDIF HAS_UNIT_ANSISTRINGS}\r\n {$ENDIF ~HAS_UNITSCOPE}\r\n JclFileUtils, JclMath, JclResources, JclStrings,\r\n JclStringConversions, JclSysInfo, JclWin32;\r\n\r\n// memory initialization\r\nprocedure ResetMemory(out P; Size: Longint);\r\nbegin\r\n if Size > 0 then\r\n begin\r\n Byte(P) := 0;\r\n FillChar(P, Size, 0);\r\n end;\r\nend;\r\n\r\n// Pointer manipulation\r\nprocedure GetAndFillMem(var P: Pointer; const Size: Integer; const Value: Byte);\r\nbegin\r\n GetMem(P, Size);\r\n FillChar(P^, Size, Value);\r\nend;\r\n\r\nprocedure FreeMemAndNil(var P: Pointer);\r\nvar\r\n Q: Pointer;\r\nbegin\r\n Q := P;\r\n P := nil;\r\n FreeMem(Q);\r\nend;\r\n\r\nfunction PCharOrNil(const S: string): PChar;\r\nbegin\r\n Result := Pointer(S);\r\nend;\r\n\r\nfunction PAnsiCharOrNil(const S: AnsiString): PAnsiChar;\r\nbegin\r\n Result := Pointer(S);\r\nend;\r\n\r\n{$IFDEF SUPPORTS_WIDESTRING}\r\n\r\nfunction PWideCharOrNil(const W: WideString): PWideChar;\r\nbegin\r\n Result := Pointer(W);\r\nend;\r\n\r\n{$ENDIF SUPPORTS_WIDESTRING}\r\n\r\n{$IFDEF MSWINDOWS}\r\ntype\r\n PUsed = ^TUsed;\r\n TUsed = record\r\n SizeFlags: Integer;\r\n end;\r\n\r\nconst\r\n cThisUsedFlag = 2;\r\n cPrevFreeFlag = 1;\r\n cFillerFlag = Integer($80000000);\r\n cFlags = cThisUsedFlag or cPrevFreeFlag or cFillerFlag;\r\n\r\nfunction SizeOfMem(const APointer: Pointer): Integer;\r\nvar\r\n U: PUsed;\r\nbegin\r\n if IsMemoryManagerSet then\r\n Result:= -1\r\n else\r\n begin\r\n Result := 0;\r\n if APointer <> nil then\r\n begin\r\n U := APointer;\r\n U := PUsed(TJclAddr(U) - SizeOf(TUsed));\r\n if (U.SizeFlags and cThisUsedFlag) <> 0 then\r\n Result := (U.SizeFlags) and (not cFlags - SizeOf(TUsed));\r\n end;\r\n end;\r\nend;\r\n{$ENDIF MSWINDOWS}\r\n\r\n{$IFDEF LINUX}\r\nfunction SizeOfMem(const APointer: Pointer): Integer;\r\nbegin\r\n if IsMemoryManagerSet then\r\n Result:= -1\r\n else\r\n begin\r\n if APointer <> nil then\r\n Result := malloc_usable_size(APointer)\r\n else\r\n Result := 0;\r\n end;\r\nend;\r\n{$ENDIF LINUX}\r\n\r\nfunction WriteProtectedMemory(BaseAddress, Buffer: Pointer;\r\n Size: Cardinal; out WrittenBytes: Cardinal): Boolean;\r\n{$IFDEF MSWINDOWS}\r\nvar\r\n OldProtect, Dummy: Cardinal;\r\nbegin\r\n WrittenBytes := 0;\r\n if Size > 0 then\r\n begin\r\n // (outchy) VirtualProtect for DEP issues\r\n OldProtect := 0;\r\n Result := VirtualProtect(BaseAddress, Size, PAGE_EXECUTE_READWRITE, OldProtect);\r\n if Result then\r\n try\r\n Move(Buffer^, BaseAddress^, Size);\r\n WrittenBytes := Size;\r\n if OldProtect in [PAGE_EXECUTE, PAGE_EXECUTE_READ, PAGE_EXECUTE_READWRITE, PAGE_EXECUTE_WRITECOPY] then\r\n FlushInstructionCache(GetCurrentProcess, BaseAddress, Size);\r\n finally\r\n Dummy := 0;\r\n VirtualProtect(BaseAddress, Size, OldProtect, Dummy);\r\n end;\r\n end;\r\n Result := WrittenBytes = Size;\r\nend;\r\n{$ENDIF MSWINDOWS}\r\n{$IFDEF LINUX}\r\n{ TODO -cHelp : Author: Andreas Hausladen }\r\n{ TODO : Works so far, but causes app to hang on termination }\r\nvar\r\n AlignedAddress: Cardinal;\r\n PageSize, ProtectSize: Cardinal;\r\nbegin\r\n Result := False;\r\n WrittenBytes := 0;\r\n\r\n PageSize := Cardinal(getpagesize);\r\n AlignedAddress := Cardinal(BaseAddress) and not (PageSize - 1); // start memory page\r\n // get the number of needed memory pages\r\n ProtectSize := PageSize;\r\n while Cardinal(BaseAddress) + Size > AlignedAddress + ProtectSize do\r\n Inc(ProtectSize, PageSize);\r\n\r\n if mprotect(Pointer(AlignedAddress), ProtectSize,\r\n PROT_READ or PROT_WRITE or PROT_EXEC) = 0 then // obtain write access\r\n begin\r\n try\r\n Move(Buffer^, BaseAddress^, Size); // replace code\r\n Result := True;\r\n WrittenBytes := Size;\r\n finally\r\n // Is there any function that returns the current page protection?\r\n// mprotect(p, ProtectSize, PROT_READ or PROT_EXEC); // lock memory page\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure FlushInstructionCache;\r\n{ TODO -cHelp : Author: Andreas Hausladen }\r\nbegin\r\n // do nothing\r\nend;\r\n\r\n{$ENDIF LINUX}\r\n\r\n// Guards\r\n\r\n//=== { TJclSafeGuard } ======================================================\r\n\r\nconstructor TJclSafeGuard.Create(Mem: Pointer);\r\nbegin\r\n inherited Create;\r\n FItem := Mem;\r\nend;\r\n\r\ndestructor TJclSafeGuard.Destroy;\r\nbegin\r\n FreeItem;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJclSafeGuard.ReleaseItem: Pointer;\r\nbegin\r\n Result := FItem;\r\n FItem := nil;\r\nend;\r\n\r\nfunction TJclSafeGuard.GetItem: Pointer;\r\nbegin\r\n Result := FItem;\r\nend;\r\n\r\nprocedure TJclSafeGuard.FreeItem;\r\nbegin\r\n if FItem <> nil then\r\n FreeMem(FItem);\r\n FItem := nil;\r\nend;\r\n\r\n//=== { TJclObjSafeGuard } ===================================================\r\n\r\nconstructor TJclObjSafeGuard.Create(Obj: TObject);\r\nbegin\r\n inherited Create(Pointer(Obj));\r\nend;\r\n\r\nprocedure TJclObjSafeGuard.FreeItem;\r\nbegin\r\n if FItem <> nil then\r\n begin\r\n TObject(FItem).Free;\r\n FItem := nil;\r\n end;\r\nend;\r\n\r\n//=== { TJclMultiSafeGuard } =================================================\r\n\r\nconstructor TJclMultiSafeGuard.Create;\r\nbegin\r\n inherited Create;\r\n FItems := TList.Create;\r\nend;\r\n\r\ndestructor TJclMultiSafeGuard.Destroy;\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := FItems.Count - 1 downto 0 do\r\n FreeItem(I);\r\n FItems.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJclMultiSafeGuard.AddItem(Item: Pointer): Pointer;\r\nbegin\r\n Result := Item;\r\n FItems.Add(Item);\r\nend;\r\n\r\nprocedure TJclMultiSafeGuard.FreeItem(Index: Integer);\r\nbegin\r\n FreeMem(FItems[Index]);\r\n FItems.Delete(Index);\r\nend;\r\n\r\nfunction TJclMultiSafeGuard.GetCount: Integer;\r\nbegin\r\n Result := FItems.Count;\r\nend;\r\n\r\nfunction TJclMultiSafeGuard.GetItem(Index: Integer): Pointer;\r\nbegin\r\n Result := FItems[Index];\r\nend;\r\n\r\nfunction TJclMultiSafeGuard.ReleaseItem(Index: Integer): Pointer;\r\nbegin\r\n Result := FItems[Index];\r\n FItems.Delete(Index);\r\nend;\r\n\r\nfunction Guard(Mem: Pointer; var SafeGuard: IMultiSafeGuard): Pointer; overload;\r\nbegin\r\n if SafeGuard = nil then\r\n SafeGuard := TJclMultiSafeGuard.Create;\r\n Result := SafeGuard.AddItem(Mem);\r\nend;\r\n\r\n//=== { TJclObjMultiSafeGuard } ==============================================\r\n\r\nprocedure TJclObjMultiSafeGuard.FreeItem(Index: Integer);\r\nbegin\r\n TObject(FItems[Index]).Free;\r\n FItems.Delete(Index);\r\nend;\r\n\r\nfunction Guard(Obj: TObject; var SafeGuard: IMultiSafeGuard): TObject; overload;\r\nbegin\r\n if SafeGuard = nil then\r\n SafeGuard := TJclObjMultiSafeGuard.Create;\r\n Result := SafeGuard.AddItem(Obj);\r\nend;\r\n\r\nfunction Guard(Mem: Pointer; out SafeGuard: ISafeGuard): Pointer; overload;\r\nbegin\r\n Result := Mem;\r\n SafeGuard := TJclSafeGuard.Create(Mem);\r\nend;\r\n\r\nfunction Guard(Obj: TObject; out SafeGuard: ISafeGuard): TObject; overload;\r\nbegin\r\n Result := Obj;\r\n SafeGuard := TJclObjSafeGuard.Create(Obj);\r\nend;\r\n\r\nfunction GuardGetMem(Size: Cardinal; out SafeGuard: ISafeGuard): Pointer;\r\nbegin\r\n GetMem(Result, Size);\r\n Guard(Result, SafeGuard);\r\nend;\r\n\r\nfunction GuardAllocMem(Size: Cardinal; out SafeGuard: ISafeGuard): Pointer;\r\nbegin\r\n Result := AllocMem(Size);\r\n Guard(Result, SafeGuard);\r\nend;\r\n\r\n{$IFDEF SUPPORTS_GENERICS_}\r\n//=== { TSafeGuard } ======================================================\r\n\r\nconstructor TSafeGuard.Create(Instance: T);\r\nbegin\r\n inherited Create;\r\n FItem := Instance;\r\nend;\r\n\r\ndestructor TSafeGuard.Destroy;\r\nbegin\r\n FreeItem;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TSafeGuard.ReleaseItem: T;\r\nbegin\r\n Result := FItem;\r\n FItem := nil;\r\nend;\r\n\r\nfunction TSafeGuard.GetItem: T;\r\nbegin\r\n Result := FItem;\r\nend;\r\n\r\nprocedure TSafeGuard.FreeItem;\r\nbegin\r\n if FItem <> nil then\r\n FItem.Free;\r\n FItem := nil;\r\nend;\r\n{$ENDIF SUPPORTS_GENERICS_}\r\n\r\n//=== Shared memory functions ================================================\r\n\r\ntype\r\n PMMFHandleListItem = ^TMMFHandleListItem;\r\n TMMFHandleListItem = record\r\n Next: PMMFHandleListItem;\r\n Memory: Pointer;\r\n Handle: THandle;\r\n Name: string;\r\n References: Integer;\r\n end;\r\n\r\n PMMFHandleList = PMMFHandleListItem;\r\n\r\nvar\r\n MMFHandleList: PMMFHandleList = nil;\r\n {$IFDEF THREADSAFE}\r\n MMFFinalized: Boolean = False;\r\n GlobalMMFHandleListCS: TJclIntfCriticalSection = nil;\r\n {$ENDIF THREADSAFE}\r\n\r\n{$IFDEF THREADSAFE}\r\nfunction GetAccessToHandleList: IInterface;\r\nvar\r\n OldValue: Pointer;\r\n CS: TJclIntfCriticalSection;\r\nbegin\r\n if not Assigned(GlobalMMFHandleListCS) and not MMFFinalized then\r\n begin\r\n CS := TJclIntfCriticalSection.Create;\r\n {$IFDEF RTL200_UP} // Delphi 2009+\r\n OldValue := InterlockedCompareExchangePointer(Pointer(GlobalMMFHandleListCS), Pointer(CS), nil);\r\n {$ELSE}\r\n {$IFDEF RTL160_UP} // Delphi 7-2007\r\n OldValue := Pointer(InterlockedCompareExchange(Longint(GlobalMMFHandleListCS), Longint(CS), 0));\r\n {$ELSE} // Delphi 5, 6\r\n OldValue := InterlockedCompareExchange(Pointer(GlobalMMFHandleListCS), Pointer(CS), nil);\r\n {$ENDIF RTL180_UP}\r\n {$ENDIF RTL185_UP}\r\n if OldValue <> nil then\r\n CS.Free;\r\n end;\r\n Result := GlobalMMFHandleListCS;\r\nend;\r\n{$ENDIF THREADSAFE}\r\n\r\n{$IFDEF MSWINDOWS}\r\n\r\nfunction SharedGetMem(var P{: Pointer}; const Name: string; Size: Cardinal;\r\n DesiredAccess: Cardinal = FILE_MAP_ALL_ACCESS): Integer;\r\nvar\r\n FileMappingHandle: THandle;\r\n Iterate, NewListItem: PMMFHandleListItem;\r\n Protect: Cardinal;\r\n {$IFDEF THREADSAFE}\r\n HandleListAccess: IInterface;\r\n {$ENDIF THREADSAFE}\r\nbegin\r\n Result := 0;\r\n Pointer(P) := nil;\r\n\r\n if not CheckWin32Version(5, 0) and ((Name = '') or (Pos('\\', Name) > 0)) then\r\n raise ESharedMemError.CreateResFmt(@RsInvalidMMFName, [Name]);\r\n\r\n {$IFDEF THREADSAFE}\r\n HandleListAccess := GetAccessToHandleList;\r\n {$ENDIF THREADSAFE}\r\n\r\n // search for same name\r\n Iterate := MMFHandleList;\r\n while Iterate <> nil do\r\n begin\r\n if CompareText(Iterate^.Name, Name) = 0 then\r\n begin\r\n Inc(Iterate^.References);\r\n Pointer(P) := Iterate^.Memory;\r\n Result := ERROR_ALREADY_EXISTS;\r\n Exit;\r\n end;\r\n Iterate := Iterate^.Next;\r\n end;\r\n\r\n // open file mapping\r\n FileMappingHandle := OpenFileMapping(DesiredAccess, False, PChar(Name));\r\n if FileMappingHandle = 0 then\r\n begin\r\n if Size = 0 then\r\n raise ESharedMemError.CreateResFmt(@RsInvalidMMFEmpty, [Name]);\r\n\r\n Protect := PAGE_READWRITE;\r\n if (Win32Platform = VER_PLATFORM_WIN32_WINDOWS) and (DesiredAccess = FILE_MAP_COPY) then\r\n Protect := PAGE_WRITECOPY;\r\n\r\n FileMappingHandle := CreateFileMapping(INVALID_HANDLE_VALUE, nil, Protect,\r\n 0, Size, PChar(Name));\r\n end\r\n else\r\n Result := ERROR_ALREADY_EXISTS;\r\n\r\n if GetLastError = ERROR_ALREADY_EXISTS then\r\n Result := ERROR_ALREADY_EXISTS\r\n else\r\n begin\r\n if FileMappingHandle = 0 then\r\n RaiseLastOSError;\r\n end;\r\n\r\n // map view\r\n Pointer(P) := MapViewOfFile(FileMappingHandle, DesiredAccess, 0, 0, Size);\r\n if Pointer(P) = nil then\r\n begin\r\n try\r\n RaiseLastOSError;\r\n except\r\n CloseHandle(FileMappingHandle);\r\n raise;\r\n end;\r\n end;\r\n\r\n // add list item to MMFHandleList\r\n New(NewListItem);\r\n NewListItem^.Name := Name;\r\n NewListItem^.Handle := FileMappingHandle;\r\n NewListItem^.Memory := Pointer(P);\r\n NewListItem^.References := 1;\r\n\r\n NewListItem^.Next := MMFHandleList;\r\n MMFHandleList := NewListItem;\r\nend;\r\n\r\nfunction SharedAllocMem(const Name: string; Size: Cardinal;\r\n DesiredAccess: Cardinal = FILE_MAP_ALL_ACCESS): Pointer;\r\nbegin\r\n Result := nil;\r\n if (SharedGetMem(Result, Name, Size, DesiredAccess) <> ERROR_ALREADY_EXISTS) and\r\n ((DesiredAccess and (FILE_MAP_WRITE or FILE_MAP_COPY)) <> 0) and\r\n (Size > 0) and (Result <> nil) then\r\n ResetMemory(Pointer(Result)^, Size);\r\nend;\r\n\r\nfunction SharedFreeMem(var P{: Pointer}): Boolean;\r\nvar\r\n N, Iterate: PMMFHandleListItem;\r\n {$IFDEF THREADSAFE}\r\n HandleListAccess: IInterface;\r\n {$ENDIF THREADSAFE}\r\nbegin\r\n if Pointer(P) <> nil then\r\n begin\r\n Result := False;\r\n {$IFDEF THREADSAFE}\r\n HandleListAccess := GetAccessToHandleList;\r\n {$ENDIF THREADSAFE}\r\n Iterate := MMFHandleList;\r\n N := nil;\r\n while Iterate <> nil do\r\n begin\r\n if Iterate^.Memory = Pointer(P) then\r\n begin\r\n if Iterate^.References > 1 then\r\n begin\r\n Dec(Iterate^.References);\r\n Pointer(P) := nil;\r\n Result := True;\r\n Exit;\r\n end;\r\n\r\n UnmapViewOfFile(Iterate^.Memory);\r\n CloseHandle(Iterate^.Handle);\r\n\r\n if N = nil then\r\n MMFHandleList := Iterate^.Next\r\n else\r\n N^.Next := Iterate^.Next;\r\n\r\n Dispose(Iterate);\r\n Pointer(P) := nil;\r\n Result := True;\r\n Break;\r\n end;\r\n N := Iterate;\r\n Iterate := Iterate^.Next;\r\n end;\r\n end\r\n else\r\n Result := True;\r\nend;\r\n\r\nfunction SharedOpenMem(var P{: Pointer}; const Name: string;\r\n DesiredAccess: Cardinal = FILE_MAP_ALL_ACCESS): Boolean;\r\nbegin\r\n Result := SharedGetMem(P, Name, 0, DesiredAccess) = ERROR_ALREADY_EXISTS;\r\nend;\r\n\r\nfunction SharedOpenMem(const Name: string;\r\n DesiredAccess: Cardinal = FILE_MAP_ALL_ACCESS): Pointer;\r\nbegin\r\n Result := nil;\r\n SharedGetMem(Result, Name, 0, DesiredAccess);\r\nend;\r\n\r\nfunction SharedCloseMem(var P{: Pointer}): Boolean;\r\nbegin\r\n Result := SharedFreeMem(P);\r\nend;\r\n\r\n{$ENDIF MSWINDOWS}\r\n\r\n//=== Binary search ==========================================================\r\n\r\nfunction SearchSortedList(List: TList; SortFunc: TListSortCompare; Item: Pointer; Nearest: Boolean): Integer;\r\nvar\r\n L, H, I, C: Integer;\r\n B: Boolean;\r\nbegin\r\n Result := -1;\r\n if List <> nil then\r\n begin\r\n L := 0;\r\n H := List.Count - 1;\r\n B := False;\r\n while L <= H do\r\n begin\r\n I := (L + H) shr 1;\r\n C := SortFunc(List.List{$IFNDEF RTL230_UP}^{$ENDIF !RTL230_UP}[I], Item);\r\n if C < 0 then\r\n L := I + 1\r\n else\r\n begin\r\n H := I - 1;\r\n if C = 0 then\r\n begin\r\n B := True;\r\n L := I;\r\n end;\r\n end;\r\n end;\r\n if B then\r\n Result := L\r\n else\r\n if Nearest and (H >= 0) then\r\n Result := H;\r\n end;\r\nend;\r\n\r\nfunction SearchSortedUntyped(Param: Pointer; ItemCount: Integer; SearchFunc: TUntypedSearchCompare;\r\n const Value; Nearest: Boolean): Integer;\r\nvar\r\n L, H, I, C: Integer;\r\n B: Boolean;\r\nbegin\r\n Result := -1;\r\n if ItemCount > 0 then\r\n begin\r\n L := 0;\r\n H := ItemCount - 1;\r\n B := False;\r\n while L <= H do\r\n begin\r\n I := (L + H) shr 1;\r\n C := SearchFunc(Param, I, Value);\r\n if C < 0 then\r\n L := I + 1\r\n else\r\n begin\r\n H := I - 1;\r\n if C = 0 then\r\n begin\r\n B := True;\r\n L := I;\r\n end;\r\n end;\r\n end;\r\n if B then\r\n Result := L\r\n else\r\n if Nearest and (H >= 0) then\r\n Result := H;\r\n end;\r\nend;\r\n\r\n//=== Dynamic array sort and search routines =================================\r\n\r\nprocedure SortDynArray(const ArrayPtr: Pointer; ElementSize: Cardinal; SortFunc: TDynArraySortCompare);\r\nvar\r\n TempBuf: TDynByteArray;\r\n\r\n function ArrayItemPointer(Item: SizeInt): Pointer;\r\n begin\r\n Assert(Item >= 0);\r\n Result := Pointer(TJclAddr(ArrayPtr) + TJclAddr(Item * SizeInt(ElementSize)));\r\n end;\r\n\r\n procedure QuickSort(L, R: SizeInt);\r\n var\r\n I, J, T: SizeInt;\r\n P, IPtr, JPtr: Pointer;\r\n ElSize: Integer;\r\n begin\r\n ElSize := ElementSize;\r\n repeat\r\n I := L;\r\n J := R;\r\n P := ArrayItemPointer((L + R) shr 1);\r\n repeat\r\n IPtr := ArrayItemPointer(I);\r\n JPtr := ArrayItemPointer(J);\r\n while SortFunc(IPtr, P) < 0 do\r\n begin\r\n Inc(I);\r\n Inc(PByte(IPtr), ElSize);\r\n end;\r\n while SortFunc(JPtr, P) > 0 do\r\n begin\r\n Dec(J);\r\n Dec(PByte(JPtr), ElSize);\r\n end;\r\n if I <= J then\r\n begin\r\n if I <> J then\r\n begin\r\n case ElementSize of\r\n SizeOf(Byte):\r\n begin\r\n T := PByte(IPtr)^;\r\n PByte(IPtr)^ := PByte(JPtr)^;\r\n PByte(JPtr)^ := T;\r\n end;\r\n SizeOf(Word):\r\n begin\r\n T := PWord(IPtr)^;\r\n PWord(IPtr)^ := PWord(JPtr)^;\r\n PWord(JPtr)^ := T;\r\n end;\r\n SizeOf(Integer):\r\n begin\r\n T := PInteger(IPtr)^;\r\n PInteger(IPtr)^ := PInteger(JPtr)^;\r\n PInteger(JPtr)^ := T;\r\n end;\r\n else\r\n Move(IPtr^, TempBuf[0], ElementSize);\r\n Move(JPtr^, IPtr^, ElementSize);\r\n Move(TempBuf[0], JPtr^, ElementSize);\r\n end;\r\n end;\r\n if P = IPtr then\r\n P := JPtr\r\n else\r\n if P = JPtr then\r\n P := IPtr;\r\n Inc(I);\r\n Dec(J);\r\n end;\r\n until I > J;\r\n if L < J then\r\n QuickSort(L, J);\r\n L := I;\r\n until I >= R;\r\n end;\r\n\r\nbegin\r\n if ArrayPtr <> nil then\r\n begin\r\n SetLength(TempBuf, ElementSize);\r\n QuickSort(0, PSizeInt(TJclAddr(ArrayPtr) - SizeOf(SizeInt))^ - 1);\r\n end;\r\nend;\r\n\r\nfunction SearchDynArray(const ArrayPtr: Pointer; ElementSize: Cardinal; SortFunc: TDynArraySortCompare;\r\n ValuePtr: Pointer; Nearest: Boolean): SizeInt;\r\nvar\r\n L, H, I, C: SizeInt;\r\n B: Boolean;\r\nbegin\r\n Result := -1;\r\n if ArrayPtr <> nil then\r\n begin\r\n L := 0;\r\n H := PSizeInt(TJclAddr(ArrayPtr) - SizeOf(SizeInt))^ - 1;\r\n B := False;\r\n while L <= H do\r\n begin\r\n I := (L + H) shr 1;\r\n C := SortFunc(Pointer(TJclAddr(ArrayPtr) + TJclAddr(I * SizeInt(ElementSize))), ValuePtr);\r\n if C < 0 then\r\n L := I + 1\r\n else\r\n begin\r\n H := I - 1;\r\n if C = 0 then\r\n begin\r\n B := True;\r\n L := I;\r\n end;\r\n end;\r\n end;\r\n if B then\r\n Result := L\r\n else\r\n if Nearest and (H >= 0) then\r\n Result := H;\r\n end;\r\nend;\r\n\r\n{ Various compare functions for basic types }\r\n\r\nfunction DynArrayCompareByte(Item1, Item2: Pointer): Integer;\r\nbegin\r\n Result := PByte(Item1)^ - PByte(Item2)^;\r\nend;\r\n\r\nfunction DynArrayCompareShortInt(Item1, Item2: Pointer): Integer;\r\nbegin\r\n Result := PShortInt(Item1)^ - PShortInt(Item2)^;\r\nend;\r\n\r\nfunction DynArrayCompareWord(Item1, Item2: Pointer): Integer;\r\nbegin\r\n Result := PWord(Item1)^ - PWord(Item2)^;\r\nend;\r\n\r\nfunction DynArrayCompareSmallInt(Item1, Item2: Pointer): Integer;\r\nbegin\r\n Result := PSmallInt(Item1)^ - PSmallInt(Item2)^;\r\nend;\r\n\r\nfunction DynArrayCompareInteger(Item1, Item2: Pointer): Integer;\r\nbegin\r\n Result := PInteger(Item1)^ - PInteger(Item2)^;\r\nend;\r\n\r\nfunction DynArrayCompareCardinal(Item1, Item2: Pointer): Integer;\r\nbegin\r\n if PCardinal(Item1)^ < PCardinal(Item2)^ then\r\n Result := -1\r\n else\r\n if PCardinal(Item1)^ > PCardinal(Item2)^ then\r\n Result := 1\r\n else\r\n Result := 0;\r\nend;\r\n\r\nfunction DynArrayCompareInt64(Item1, Item2: Pointer): Integer;\r\nbegin\r\n if PInt64(Item1)^ < PInt64(Item2)^ then\r\n Result := -1\r\n else\r\n if PInt64(Item1)^ > PInt64(Item2)^ then\r\n Result := 1\r\n else\r\n Result := 0;\r\nend;\r\n\r\nfunction DynArrayCompareSingle(Item1, Item2: Pointer): Integer;\r\nbegin\r\n if PSingle(Item1)^ < PSingle(Item2)^ then\r\n Result := -1\r\n else\r\n if PSingle(Item1)^ > PSingle(Item2)^ then\r\n Result := 1\r\n else\r\n Result := 0;\r\nend;\r\n\r\nfunction DynArrayCompareDouble(Item1, Item2: Pointer): Integer;\r\nbegin\r\n if PDouble(Item1)^ < PDouble(Item2)^ then\r\n Result := -1\r\n else\r\n if PDouble(Item1)^ > PDouble(Item2)^ then\r\n Result := 1\r\n else\r\n Result := 0;\r\nend;\r\n\r\nfunction DynArrayCompareExtended(Item1, Item2: Pointer): Integer;\r\nbegin\r\n if PExtended(Item1)^ < PExtended(Item2)^ then\r\n Result := -1\r\n else\r\n if PExtended(Item1)^ > PExtended(Item2)^ then\r\n Result := 1\r\n else\r\n Result := 0;\r\nend;\r\n\r\nfunction DynArrayCompareFloat(Item1, Item2: Pointer): Integer;\r\nbegin\r\n if PFloat(Item1)^ < PFloat(Item2)^ then\r\n Result := -1\r\n else\r\n if PFloat(Item1)^ > PFloat(Item2)^ then\r\n Result := 1\r\n else\r\n Result := 0;\r\nend;\r\n\r\nfunction DynArrayCompareAnsiString(Item1, Item2: Pointer): Integer;\r\nbegin\r\n Result := AnsiCompareStr(PAnsiString(Item1)^, PAnsiString(Item2)^);\r\nend;\r\n\r\nfunction DynArrayCompareAnsiText(Item1, Item2: Pointer): Integer;\r\nbegin\r\n Result := AnsiCompareText(PAnsiString(Item1)^, PAnsiString(Item2)^);\r\nend;\r\n\r\nfunction DynArrayCompareWideString(Item1, Item2: Pointer): Integer;\r\nbegin\r\n Result := WideCompareStr(PWideString(Item1)^, PWideString(Item2)^);\r\nend;\r\n\r\nfunction DynArrayCompareWideText(Item1, Item2: Pointer): Integer;\r\nbegin\r\n Result := WideCompareText(PWideString(Item1)^, PWideString(Item2)^);\r\nend;\r\n\r\nfunction DynArrayCompareString(Item1, Item2: Pointer): Integer;\r\nbegin\r\n Result := CompareStr(PString(Item1)^, PString(Item2)^);\r\nend;\r\n\r\nfunction DynArrayCompareText(Item1, Item2: Pointer): Integer;\r\nbegin\r\n Result := CompareText(PString(Item1)^, PString(Item2)^);\r\nend;\r\n\r\n//=== Object lists ===========================================================\r\n\r\nprocedure ClearObjectList(List: TList);\r\nvar\r\n I: Integer;\r\nbegin\r\n if List <> nil then\r\n begin\r\n for I := List.Count - 1 downto 0 do\r\n begin\r\n if List[I] <> nil then\r\n begin\r\n if TObject(List[I]) is TList then\r\n begin\r\n // recursively delete TList sublists\r\n ClearObjectList(TList(List[I]));\r\n end;\r\n TObject(List[I]).Free;\r\n if (not (List is TComponentList))\r\n and ((not(List is TObjectList)) or not TObjectList(List).OwnsObjects) then\r\n List[I] := nil;\r\n end;\r\n end;\r\n List.Clear;\r\n end;\r\nend;\r\n\r\nprocedure FreeObjectList(var List: TList);\r\nbegin\r\n if List <> nil then\r\n begin\r\n ClearObjectList(List);\r\n FreeAndNil(List);\r\n end;\r\nend;\r\n\r\n//=== { TJclReferenceMemoryStream } ==========================================\r\n\r\nconstructor TJclReferenceMemoryStream.Create(const Ptr: Pointer; Size: Longint);\r\nbegin\r\n {$IFDEF MSWINDOWS}\r\n Assert(not IsBadReadPtr(Ptr, Size));\r\n {$ENDIF MSWINDOWS}\r\n inherited Create;\r\n SetPointer(Ptr, Size);\r\nend;\r\n\r\nfunction TJclReferenceMemoryStream.Write(const Buffer; Count: Longint): Longint;\r\nbegin\r\n raise EJclError.CreateRes(@RsCannotWriteRefStream);\r\nend;\r\n\r\n//=== { TJclAutoPtr } ========================================================\r\n\r\nconstructor TJclAutoPtr.Create(AValue: TObject);\r\nbegin\r\n inherited Create;\r\n FValue := AValue;\r\nend;\r\n\r\ndestructor TJclAutoPtr.Destroy;\r\nbegin\r\n FValue.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJclAutoPtr.AsObject: TObject;\r\nbegin\r\n Result := FValue;\r\nend;\r\n\r\nfunction TJclAutoPtr.AsPointer: Pointer;\r\nbegin\r\n Result := FValue;\r\nend;\r\n\r\nfunction TJclAutoPtr.ReleaseObject: TObject;\r\nbegin\r\n Result := FValue;\r\n FValue := nil;\r\nend;\r\n\r\nfunction CreateAutoPtr(Value: TObject): IAutoPtr;\r\nbegin\r\n Result := TJclAutoPtr.Create(Value);\r\nend;\r\n\r\n//=== replacement for the C distfix operator ? : =============================\r\n\r\nfunction Iff(const Condition: Boolean; const TruePart, FalsePart: string): string;\r\nbegin\r\n if Condition then\r\n Result := TruePart\r\n else\r\n Result := FalsePart;\r\nend;\r\n\r\nfunction Iff(const Condition: Boolean; const TruePart, FalsePart: Char): Char;\r\nbegin\r\n if Condition then\r\n Result := TruePart\r\n else\r\n Result := FalsePart;\r\nend;\r\n\r\nfunction Iff(const Condition: Boolean; const TruePart, FalsePart: Byte): Byte;\r\nbegin\r\n if Condition then\r\n Result := TruePart\r\n else\r\n Result := FalsePart;\r\nend;\r\n\r\nfunction Iff(const Condition: Boolean; const TruePart, FalsePart: Integer): Integer;\r\nbegin\r\n if Condition then\r\n Result := TruePart\r\n else\r\n Result := FalsePart;\r\nend;\r\n\r\nfunction Iff(const Condition: Boolean; const TruePart, FalsePart: Cardinal): Cardinal;\r\nbegin\r\n if Condition then\r\n Result := TruePart\r\n else\r\n Result := FalsePart;\r\nend;\r\n\r\nfunction Iff(const Condition: Boolean; const TruePart, FalsePart: Float): Float;\r\nbegin\r\n if Condition then\r\n Result := TruePart\r\n else\r\n Result := FalsePart;\r\nend;\r\n\r\nfunction Iff(const Condition: Boolean; const TruePart, FalsePart: Boolean): Boolean;\r\nbegin\r\n if Condition then\r\n Result := TruePart\r\n else\r\n Result := FalsePart;\r\nend;\r\n\r\nfunction Iff(const Condition: Boolean; const TruePart, FalsePart: Pointer): Pointer;\r\nbegin\r\n if Condition then\r\n Result := TruePart\r\n else\r\n Result := FalsePart;\r\nend;\r\n\r\nfunction Iff(const Condition: Boolean; const TruePart, FalsePart: Int64): Int64;\r\nbegin\r\n if Condition then\r\n Result := TruePart\r\n else\r\n Result := FalsePart;\r\nend;\r\n\r\n{$IFDEF SUPPORTS_VARIANT}\r\nfunction Iff(const Condition: Boolean; const TruePart, FalsePart: Variant): Variant; overload;\r\nbegin\r\n if Condition then\r\n Result := TruePart\r\n else\r\n Result := FalsePart;\r\nend;\r\n{$ENDIF SUPPORTS_VARIANT}\r\n\r\n//=== Classes information and manipulation ===================================\r\n// Virtual Methods\r\n// Helper method\r\n\r\nprocedure SetVMTPointer(AClass: TClass; Offset: Integer; Value: Pointer);\r\nvar\r\n WrittenBytes: DWORD;\r\n PatchAddress: PPointer;\r\nbegin\r\n {$OVERFLOWCHECKS OFF}\r\n PatchAddress := Pointer(TJclAddr(AClass) + TJclAddr(Offset));\r\n {$IFDEF OVERFLOWCHECKS_ON}\r\n {$OVERFLOWCHECKS ON}\r\n {$ENDIF OVERFLOWCHECKS_ON}\r\n if not WriteProtectedMemory(PatchAddress, @Value, SizeOf(Value), WrittenBytes) then\r\n raise EJclVMTError.CreateResFmt(@RsVMTMemoryWriteError,\r\n [SysErrorMessage({$IFDEF FPC}GetLastOSError{$ELSE}GetLastError{$ENDIF})]);\r\n\r\n if WrittenBytes <> SizeOf(Pointer) then\r\n raise EJclVMTError.CreateResFmt(@RsVMTMemoryWriteError, [IntToStr(WrittenBytes)]);\r\n\r\n // make sure that everything keeps working in a dual processor setting\r\n // (outchy) done by WriteProtectedMemory\r\n // FlushInstructionCache{$IFDEF MSWINDOWS}(GetCurrentProcess, PatchAddress, SizeOf(Pointer)){$ENDIF};\r\nend;\r\n\r\n{$IFNDEF FPC}\r\nfunction GetVirtualMethodCount(AClass: TClass): Integer;\r\ntype\r\n PINT_PTR = ^INT_PTR;\r\nvar\r\n BeginVMT: INT_PTR;\r\n EndVMT: INT_PTR;\r\n TablePointer: INT_PTR;\r\n I: Integer;\r\nbegin\r\n BeginVMT := INT_PTR(AClass);\r\n\r\n // Scan the offset entries in the class table for the various fields,\r\n // namely vmtIntfTable, vmtAutoTable, ..., vmtDynamicTable\r\n // The last entry is always the vmtClassName, so stop once we got there\r\n // After the last virtual method there is one of these entries.\r\n\r\n EndVMT := PINT_PTR(INT_PTR(AClass) + vmtClassName)^;\r\n // Set iterator to first item behind VMT table pointer\r\n I := vmtSelfPtr + SizeOf(Pointer);\r\n repeat\r\n TablePointer := PINT_PTR(INT_PTR(AClass) + I)^;\r\n if (TablePointer <> 0) and (TablePointer >= BeginVMT) and\r\n (TablePointer < EndVMT) then\r\n EndVMT := INT_PTR(TablePointer);\r\n Inc(I, SizeOf(Pointer));\r\n until I >= vmtClassName;\r\n\r\n Result := (EndVMT - BeginVMT) div SizeOf(Pointer);\r\nend;\r\n{$ENDIF ~FPC}\r\n\r\nfunction GetVirtualMethod(AClass: TClass; const Index: Integer): Pointer;\r\nbegin\r\n {$OVERFLOWCHECKS OFF}\r\n Result := PPointer(TJclAddr(AClass) + TJclAddr(Index * SizeOf(Pointer)))^;\r\n {$IFDEF OVERFLOWCHECKS_ON}\r\n {$OVERFLOWCHECKS ON}\r\n {$ENDIF OVERFLOWCHECKS_ON}\r\nend;\r\n\r\nprocedure SetVirtualMethod(AClass: TClass; const Index: Integer; const Method: Pointer);\r\nbegin\r\n SetVMTPointer(AClass, Index * SizeOf(Pointer), Method);\r\nend;\r\n\r\nfunction GetDynamicMethodCount(AClass: TClass): Integer; assembler;\r\nasm\r\n {$IFDEF CPU32}\r\n // --> RAX AClass\r\n // <-- EAX Result\r\n MOV EAX, [EAX].vmtDynamicTable\r\n TEST EAX, EAX\r\n JE @@Exit\r\n MOVZX EAX, WORD PTR [EAX]\r\n {$ENDIF CPU32}\r\n {$IFDEF CPU64}\r\n // --> RCX AClass\r\n // <-- EAX Result\r\n MOV RAX, [RCX].vmtDynamicTable\r\n TEST RAX, RAX\r\n JE @@Exit\r\n MOVZX RAX, WORD PTR [RAX]\r\n {$ENDIF CPU64}\r\n@@Exit:\r\nend;\r\n\r\nfunction GetDynamicIndexList(AClass: TClass): PDynamicIndexList; assembler;\r\nasm\r\n {$IFDEF CPU32}\r\n // --> EAX AClass\r\n // <-- EAX Result\r\n MOV EAX, [EAX].vmtDynamicTable\r\n ADD EAX, 2\r\n {$ENDIF CPU32}\r\n {$IFDEF CPU64}\r\n // --> RCX AClass\r\n // <-- RAX Result\r\n MOV RAX, [RCX].vmtDynamicTable\r\n ADD RAX, 2\r\n {$ENDIF CPU64}\r\nend;\r\n\r\nfunction GetDynamicAddressList(AClass: TClass): PDynamicAddressList; assembler;\r\nasm\r\n {$IFDEF CPU32}\r\n // --> EAX AClass\r\n // <-- EAX Result\r\n MOV EAX, [EAX].vmtDynamicTable\r\n MOVZX EDX, Word ptr [EAX]\r\n ADD EAX, EDX\r\n ADD EAX, EDX\r\n ADD EAX, 2\r\n {$ENDIF CPU32}\r\n {$IFDEF CPU64}\r\n // --> RCX AClass\r\n // <-- RAX Result\r\n MOV RAX, [RCX].vmtDynamicTable\r\n MOVZX RDX, Word ptr [RAX]\r\n ADD RAX, RDX\r\n ADD RAX, RDX\r\n ADD RAX, 2\r\n {$ENDIF CPU64}\r\nend;\r\n\r\nfunction HasDynamicMethod(AClass: TClass; Index: Integer): Boolean; assembler;\r\n// Mainly copied from System.GetDynaMethod\r\nasm\r\n {$IFDEF CPU32}\r\n // --> EAX AClass\r\n // EDX Index\r\n // <-- AL Result\r\n PUSH EDI\r\n XCHG EAX, EDX\r\n JMP @@HaveVMT\r\n@@OuterLoop:\r\n MOV EDX, [EDX]\r\n@@HaveVMT:\r\n MOV EDI, [EDX].vmtDynamicTable\r\n TEST EDI, EDI\r\n JE @@Parent\r\n MOVZX ECX, WORD PTR [EDI]\r\n PUSH ECX\r\n ADD EDI,2\r\n REPNE SCASW\r\n JE @@Found\r\n POP ECX\r\n@@Parent:\r\n MOV EDX,[EDX].vmtParent\r\n TEST EDX,EDX\r\n JNE @@OuterLoop\r\n MOV EAX, 0\r\n JMP @@Exit\r\n@@Found:\r\n POP EAX\r\n MOV EAX, 1\r\n@@Exit:\r\n POP EDI\r\n {$ENDIF CPU32}\r\n {$IFDEF CPU64}\r\n // --> RCX AClass\r\n // EDX Index\r\n // <-- AL Result\r\n MOV EAX, EDX\r\n MOV RDX, RCX\r\n JMP @@HaveVMT\r\n@@OuterLoop:\r\n MOV RDX, [RDX]\r\n@@HaveVMT:\r\n MOV RDI, [RDX].vmtDynamicTable\r\n TEST RDI, RDI\r\n JE @@Parent\r\n MOVZX RCX, WORD PTR [RDI]\r\n PUSH RCX\r\n ADD RDI,2\r\n REPNE SCASW\r\n JE @@Found\r\n POP RCX\r\n@@Parent:\r\n MOV RDX,[RDX].vmtParent\r\n TEST RDX,RDX\r\n JNE @@OuterLoop\r\n MOV RAX, 0\r\n JMP @@Exit\r\n@@Found:\r\n POP RAX\r\n MOV RAX, 1\r\n@@Exit:\r\n {$ENDIF CPU64}\r\nend;\r\n\r\n{$IFNDEF FPC}\r\nfunction GetDynamicMethod(AClass: TClass; Index: Integer): Pointer; assembler;\r\nasm\r\n CALL System.@FindDynaClass\r\nend;\r\n{$ENDIF ~FPC}\r\n\r\n//=== Interface Table ========================================================\r\n\r\nfunction GetInitTable(AClass: TClass): PTypeInfo; assembler;\r\nasm\r\n {$IFDEF CPU32}\r\n // --> EAX AClass\r\n // <-- EAX Result\r\n MOV EAX, [EAX].vmtInitTable\r\n {$ENDIF CPU32}\r\n {$IFDEF CPU64}\r\n // --> RCX AClass\r\n // <-- RAX Result\r\n MOV RAX, [RCX].vmtInitTable\r\n {$ENDIF CPU64}\r\nend;\r\n\r\nfunction GetFieldTable(AClass: TClass): PFieldTable; assembler;\r\nasm\r\n {$IFDEF CPU32}\r\n // --> EAX AClass\r\n // <-- EAX Result\r\n MOV EAX, [EAX].vmtFieldTable\r\n {$ENDIF CPU32}\r\n {$IFDEF CPU64}\r\n // --> RCX AClass\r\n // <-- RAX Result\r\n MOV RAX, [RCX].vmtFieldTable\r\n {$ENDIF CPU64}\r\nend;\r\n\r\nfunction GetMethodTable(AClass: TClass): PMethodTable; assembler;\r\nasm\r\n {$IFDEF CPU32}\r\n // --> EAX AClass\r\n // <-- EAX Result\r\n MOV EAX, [EAX].vmtMethodTable\r\n {$ENDIF CPU32}\r\n {$IFDEF CPU64}\r\n // --> RCX AClass\r\n // <-- RAX Result\r\n MOV RAX, [RCX].vmtMethodTable\r\n {$ENDIF CPU64}\r\nend;\r\n\r\nfunction GetMethodEntry(MethodTable: PMethodTable; Index: Integer): PMethodEntry;\r\nbegin\r\n Result := Pointer(TJclAddr(MethodTable) + 2);\r\n for Index := Index downto 1 do\r\n Inc(TJclAddr(Result), Result^.EntrySize);\r\nend;\r\n\r\n//=== Class Parent methods ===================================================\r\n\r\nprocedure SetClassParent(AClass: TClass; NewClassParent: TClass);\r\nvar\r\n WrittenBytes: DWORD;\r\n PatchAddress: Pointer;\r\nbegin\r\n {$OVERFLOWCHECKS OFF}\r\n PatchAddress := PPointer(TJclAddr(AClass) + TJclAddr(vmtParent))^;\r\n {$IFDEF OVERFLOWCHECKS_ON}\r\n {$OVERFLOWCHECKS ON}\r\n {$ENDIF OVERFLOWCHECKS_ON}\r\n if not WriteProtectedMemory(PatchAddress, @NewClassParent, SizeOf(Pointer), WrittenBytes) then\r\n raise EJclVMTError.CreateResFmt(@RsVMTMemoryWriteError,\r\n [SysErrorMessage({$IFDEF FPC}GetLastOSError{$ELSE}GetLastError{$ENDIF})]);\r\n if WrittenBytes <> SizeOf(Pointer) then\r\n raise EJclVMTError.CreateResFmt(@RsVMTMemoryWriteError, [IntToStr(WrittenBytes)]);\r\n // make sure that everything keeps working in a dual processor setting\r\n // (outchy) done by WriteProtectedMemory\r\n // FlushInstructionCache{$IFDEF MSWINDOWS}(GetCurrentProcess, PatchAddress, SizeOf(Pointer)){$ENDIF};\r\nend;\r\n\r\nfunction GetClassParent(AClass: TClass): TClass; assembler;\r\nasm\r\n {$IFDEF CPU32}\r\n // --> EAX AClass\r\n // <-- EAX Result\r\n MOV EAX, [EAX].vmtParent\r\n TEST EAX, EAX\r\n JE @@Exit\r\n MOV EAX, [EAX]\r\n {$ENDIF CPU32}\r\n {$IFDEF CPU64}\r\n // --> RCX AClass\r\n // <-- RAX Result\r\n MOV RAX, [RCX].vmtParent\r\n TEST RAX, RAX\r\n JE @@Exit\r\n MOV RAX, [RAX]\r\n {$ENDIF CPU64}\r\n@@Exit:\r\nend;\r\n\r\n{$IFDEF BORLAND}\r\nfunction IsClass(Address: Pointer): Boolean; assembler;\r\nasm\r\n CMP Address, Address.vmtSelfPtr\r\n JNZ @False\r\n MOV Result, True\r\n JMP @Exit\r\n@False:\r\n MOV Result, False\r\n@Exit:\r\nend;\r\n{$ENDIF BORLAND}\r\n\r\n{$IFDEF BORLAND}\r\nfunction IsObject(Address: Pointer): Boolean; assembler;\r\nasm\r\n// or IsClass(Pointer(Address^));\r\n MOV EAX, [Address]\r\n CMP EAX, EAX.vmtSelfPtr\r\n JNZ @False\r\n MOV Result, True\r\n JMP @Exit\r\n@False:\r\n MOV Result, False\r\n@Exit:\r\nend;\r\n{$ENDIF BORLAND}\r\n\r\nfunction InheritsFromByName(AClass: TClass; const AClassName: string): Boolean;\r\nbegin\r\n while (AClass <> nil) and not AClass.ClassNameIs(AClassName) do\r\n AClass := AClass.ClassParent;\r\n Result := AClass <> nil;\r\nend;\r\n\r\n//=== Interface information ==================================================\r\n\r\nfunction GetImplementorOfInterface(const I: IInterface): TObject;\r\n{ TODO -cDOC : Original code by Hallvard Vassbotn }\r\n{ TODO -cTesting : Check the implemetation for any further version of compiler }\r\nconst\r\n AddByte = $04244483; // opcode for ADD DWORD PTR [ESP+4], Shortint\r\n AddLong = $04244481; // opcode for ADD DWORD PTR [ESP+4], Longint\r\ntype\r\n PAdjustSelfThunk = ^TAdjustSelfThunk;\r\n TAdjustSelfThunk = packed record\r\n case AddInstruction: Longint of\r\n AddByte: (AdjustmentByte: ShortInt);\r\n AddLong: (AdjustmentLong: Longint);\r\n end;\r\n PInterfaceMT = ^TInterfaceMT;\r\n TInterfaceMT = packed record\r\n QueryInterfaceThunk: PAdjustSelfThunk;\r\n end;\r\n TInterfaceRef = ^PInterfaceMT;\r\nvar\r\n QueryInterfaceThunk: PAdjustSelfThunk;\r\nbegin\r\n try\r\n Result := Pointer(I);\r\n if Assigned(Result) then\r\n begin\r\n QueryInterfaceThunk := TInterfaceRef(I)^.QueryInterfaceThunk;\r\n case QueryInterfaceThunk.AddInstruction of\r\n AddByte:\r\n Inc(PByte(Result), QueryInterfaceThunk.AdjustmentByte);\r\n AddLong:\r\n Inc(PByte(Result), QueryInterfaceThunk.AdjustmentLong);\r\n else\r\n Result := nil;\r\n end;\r\n end;\r\n except\r\n Result := nil;\r\n end;\r\nend;\r\n\r\n//=== { TJclInterfacedPersistent } ===========================================\r\n\r\nprocedure TJclInterfacedPersistent.AfterConstruction;\r\nbegin\r\n inherited AfterConstruction;\r\n if GetOwner <> nil then\r\n GetOwner.GetInterface(IInterface, FOwnerInterface);\r\nend;\r\n\r\nfunction TJclInterfacedPersistent._AddRef: Integer;\r\nbegin\r\n if FOwnerInterface <> nil then\r\n Result := FOwnerInterface._AddRef\r\n else\r\n Result := InterlockedIncrement(FRefCount);\r\nend;\r\n\r\nfunction TJclInterfacedPersistent._Release: Integer;\r\nbegin\r\n if FOwnerInterface <> nil then\r\n Result := FOwnerInterface._Release\r\n else\r\n begin\r\n Result := InterlockedDecrement(FRefCount);\r\n if Result = 0 then\r\n Destroy;\r\n end;\r\nend;\r\n\r\n//=== Numeric formatting routines ============================================\r\n\r\nfunction IntToStrZeroPad(Value, Count: Integer): string;\r\nbegin\r\n Result := IntToStr(Value);\r\n if Length(Result) < Count then\r\n Result := StrRepeatChar('0', Count - Length(Result)) + Result;\r\nend;\r\n\r\n//=== { TJclNumericFormat } ==================================================\r\n\r\n{ TODO -cHelp : Author: Robert Rossmair }\r\n{ Digit: converts a digit value (number) to a digit (char)\r\n DigitValue: converts a digit (char) into a number (digit value)\r\n IntToStr,\r\n FloatToStr,\r\n FloatToHTML: converts a numeric value to a base numeric representation with formating options\r\n StrToIn: converts a base numeric representation into an integer, if possible\r\n GetMantisseExponent: similar to AsString, but returns the Exponent separately as an integer\r\n}\r\nconst\r\n {$IFDEF MATH_EXTENDED_PRECISION}\r\n BinaryPrecision = 64;\r\n {$ENDIF MATH_EXTENDED_PRECISION}\r\n {$IFDEF MATH_DOUBLE_PRECISION}\r\n BinaryPrecision = 53;\r\n {$ENDIF MATH_DOUBLE_PRECISION}\r\n {$IFDEF MATH_SINGLE_PRECISION}\r\n BinaryPrecision = 24;\r\n {$ENDIF MATH_SINGLE_PRECISION}\r\n\r\nconstructor TJclNumericFormat.Create;\r\nbegin\r\n inherited Create;\r\n { TODO : Initialize, when possible, from locale info }\r\n FBase := 10;\r\n FExpDivision := 1;\r\n SetPrecision(6);\r\n FNumberOfFractionalDigits := BinaryPrecision;\r\n FSignChars[False] := '-';\r\n FSignChars[True] := '+';\r\n FPaddingChar := ' ';\r\n FMultiplier := '';\r\n FFractionalPartSeparator := JclFormatSettings.DecimalSeparator;\r\n FDigitBlockSeparator := JclFormatSettings.ThousandSeparator;\r\nend;\r\n\r\nprocedure TJclNumericFormat.InvalidDigit(Digit: Char);\r\nbegin\r\n raise EConvertError.CreateResFmt(@RsInvalidDigit, [Base, Digit]);\r\nend;\r\n\r\nfunction TJclNumericFormat.Digit(DigitValue: TDigitValue): Char;\r\nbegin\r\n Assert(DigitValue < Base, Format(LoadResString(@RsInvalidDigitValue), [Base, DigitValue]));\r\n if DigitValue > 9 then\r\n Result := Chr(Ord('A') + DigitValue - 10)\r\n else\r\n Result := Chr(Ord('0') + DigitValue);\r\nend;\r\n\r\nfunction TJclNumericFormat.GetDigitValue(Digit: Char): Integer;\r\nbegin\r\n Result := CharHex(Digit);\r\n if (Result = $FF) or (Result >= Base) then\r\n Result := -1;\r\nend;\r\n\r\nfunction TJclNumericFormat.DigitValue(Digit: Char): TDigitValue;\r\nbegin\r\n Result := GetDigitValue(Digit);\r\n if Result = -1 then\r\n InvalidDigit(Digit);\r\nend;\r\n\r\nfunction TJclNumericFormat.IsDigit(Value: Char): Boolean;\r\nbegin\r\n Result := GetDigitValue(Value) <> -1;\r\nend;\r\n\r\nfunction TJclNumericFormat.FloatToHTML(const Value: Float): string;\r\nvar\r\n Mantissa: string;\r\n Exponent: Integer;\r\nbegin\r\n GetMantissaExp(Value, Mantissa, Exponent);\r\n Result := Format('%s %s %d%d', [Mantissa, Multiplier, Base, Exponent]);\r\nend;\r\n\r\nprocedure TJclNumericFormat.GetMantissaExp(const Value: Float;\r\n out Mantissa: string; out Exponent: Integer);\r\nconst\r\n {$IFDEF FPC}\r\n InfMantissa: array [Boolean] of string[4] = ('inf', '-inf');\r\n {$ElSE ~FPC}\r\n InfMantissa: array [Boolean] of string = ('inf', '-inf');\r\n {$ENDIF ~FPC}\r\nvar\r\n BlockDigits: TDigitCount;\r\n IntDigits, FracDigits: Integer;\r\n FirstDigitPos, Prec: Integer;\r\n I, J, N: Integer;\r\n K: Int64;\r\n X: Extended;\r\n HighDigit: Char;\r\n\r\n function GetDigit(X: Extended): Char;\r\n var\r\n N: Integer;\r\n begin\r\n N := Trunc(X);\r\n if N > 9 then\r\n Result := Chr(Ord('A') + N - 10)\r\n else\r\n Result := Chr(Ord('0') + N);\r\n end;\r\n\r\nbegin\r\n X := Abs(Value);\r\n\r\n if X > MaxFloatingPoint then\r\n begin\r\n Mantissa := InfMantissa[Value < 0];\r\n Exponent := 1;\r\n Exit;\r\n end\r\n else\r\n if X < MinFloatingPoint then\r\n begin\r\n Mantissa := Format('%.*f', [Precision, 0.0]);\r\n Exponent := 1;\r\n Exit;\r\n end;\r\n\r\n IntDigits := 1;\r\n Prec := Precision;\r\n\r\n Exponent := Trunc(LogBaseN(Base, X));\r\n if FExpDivision > 1 then\r\n begin\r\n N := Exponent mod FExpDivision;\r\n Dec(Exponent, N);\r\n Inc(IntDigits, N);\r\n end;\r\n X := X / Power(Base, Exponent);\r\n\r\n if X < 1.0 then\r\n begin\r\n Dec(Exponent, FExpDivision);\r\n X := X * PowerInt(Base, FExpDivision);\r\n Inc(IntDigits, FExpDivision - 1);\r\n end;\r\n\r\n{ TODO : Here's a problem if X > High(Int64).\r\nIt *seems* to surface only if ExponentDivision > 12, but it\r\nhas not been investigated if ExponentDivision <= 12 is safe. }\r\n K := Trunc(X);\r\n if Value < 0 then\r\n K := -K;\r\n\r\n Mantissa := IntToStr(K, FirstDigitPos);\r\n\r\n FracDigits := Prec - IntDigits;\r\n if FracDigits > NumberOfFractionalDigits then\r\n FracDigits := NumberOfFractionalDigits;\r\n\r\n if FracDigits > 0 then\r\n begin\r\n J := Length(Mantissa) + 1;\r\n // allocate sufficient space for point + digits + digit block separators\r\n SetLength(Mantissa, FracDigits * 2 + J);\r\n Mantissa[J] := FractionalPartSeparator;\r\n I := J + 1;\r\n BlockDigits := 0;\r\n while FracDigits > 0 do\r\n begin\r\n if (BlockDigits > 0) and (BlockDigits = DigitBlockSize) then\r\n begin\r\n Mantissa[I] := DigitBlockSeparator;\r\n Inc(I);\r\n BlockDigits := 0;\r\n end;\r\n X := Frac(X) * Base;\r\n Mantissa[I] := GetDigit(X);\r\n Inc(I);\r\n Inc(BlockDigits);\r\n Dec(FracDigits);\r\n end;\r\n Mantissa[I] := #0;\r\n StrResetLength(Mantissa);\r\n end;\r\n\r\n if Frac(X) >= 0.5 then\r\n // round up\r\n begin\r\n HighDigit := Digit(Base - 1);\r\n for I := Length(Mantissa) downto 1 do\r\n begin\r\n if Mantissa[I] = HighDigit then\r\n if (I = FirstDigitPos) then\r\n begin\r\n Mantissa[I] := '1';\r\n Inc(Exponent);\r\n Break;\r\n end\r\n else\r\n Mantissa[I] := '0'\r\n else\r\n if (Mantissa[I] = DigitBlockSeparator) or (Mantissa[I] = FractionalPartSeparator) then\r\n Continue\r\n else\r\n begin\r\n if Mantissa[I] = '9' then\r\n Mantissa[I] := 'A'\r\n else\r\n Mantissa[I] := Succ(Mantissa[I]);\r\n Break;\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJclNumericFormat.FloatToStr(const Value: Float): string;\r\nvar\r\n Mantissa: string;\r\n Exponent: Integer;\r\nbegin\r\n GetMantissaExp(Value, Mantissa, Exponent);\r\n Result := Format('%s %s %d^%d', [Mantissa, Multiplier, Base, Exponent]);\r\nend;\r\n\r\nfunction TJclNumericFormat.IntToStr(const Value: Int64): string;\r\nvar\r\n FirstDigitPos: Integer;\r\nbegin\r\n Result := IntToStr(Value, FirstDigitPos);\r\nend;\r\n\r\nfunction TJclNumericFormat.IntToStr(const Value: Int64; out FirstDigitPos: Integer): string;\r\nconst\r\n MaxResultLen = 64 + 63 + 1; // max. digits + max. group separators + sign\r\nvar\r\n Remainder: Int64;\r\n I, N: Integer;\r\n Chars, Digits: Cardinal;\r\n LoopFinished, HasSign, SpacePadding: Boolean;\r\nbegin\r\n SpacePadding := PaddingChar = ' ';\r\n HasSign := ShowSign(Value);\r\n Chars := MaxResultLen;\r\n if Width > Chars then\r\n Chars := Width;\r\n Result := StrRepeatChar(' ', Chars);\r\n\r\n Remainder := Abs(Value);\r\n Digits := 0;\r\n\r\n Chars := 0;\r\n if HasSign then\r\n Chars := 1;\r\n\r\n I := MaxResultLen;\r\n\r\n while True do\r\n begin\r\n N := Remainder mod Base;\r\n Remainder := Remainder div Base;\r\n if N > 9 then\r\n Result[I] := Chr(Ord('A') + N - 10)\r\n else\r\n Result[I] := Chr(Ord('0') + N);\r\n Dec(I);\r\n Inc(Digits);\r\n Inc(Chars);\r\n if (Remainder = 0) and (SpacePadding or (Chars >= Width)) then\r\n Break;\r\n if (Digits = DigitBlockSize) then\r\n begin\r\n Inc(Chars);\r\n LoopFinished := (Remainder = 0) and (Chars = Width);\r\n if LoopFinished then\r\n Result[I] := ' '\r\n else\r\n Result[I] := DigitBlockSeparator;\r\n Dec(I);\r\n if LoopFinished then\r\n Break;\r\n Digits := 0;\r\n end;\r\n end;\r\n\r\n FirstDigitPos := I + 1;\r\n\r\n if HasSign then\r\n Result[I] := SignChar(Value)\r\n else\r\n Inc(I);\r\n N := MaxResultLen - Width + 1;\r\n if N < I then\r\n I := N;\r\n Result := Copy(Result, I, MaxResultLen);\r\n Dec(FirstDigitPos, I - 1);\r\nend;\r\n\r\nprocedure TJclNumericFormat.SetBase(const Value: TNumericSystemBase);\r\nbegin\r\n FBase := Value;\r\n SetPrecision(FWantedPrecision);\r\nend;\r\n\r\nprocedure TJclNumericFormat.SetExpDivision(const Value: Integer);\r\nbegin\r\n if Value <= 1 then\r\n FExpDivision := 1\r\n else\r\n // see TODO in GetMantissaExp\r\n if Value > 12 then\r\n FExpDivision := 12\r\n else\r\n FExpDivision := Value;\r\nend;\r\n\r\nprocedure TJclNumericFormat.SetPrecision(const Value: TDigitCount);\r\nbegin\r\n FWantedPrecision := Value;\r\n // Do not display more digits than Float precision justifies\r\n if Base = 2 then\r\n FPrecision := BinaryPrecision\r\n else\r\n FPrecision := Trunc(BinaryPrecision / LogBase2(Base));\r\n if Value < FPrecision then\r\n FPrecision := Value;\r\nend;\r\n\r\nfunction TJclNumericFormat.Sign(Value: Char): Integer;\r\nbegin\r\n Result := 0;\r\n if Value = FSignChars[False] then\r\n Result := -1;\r\n if Value = FSignChars[True] then\r\n Result := +1;\r\nend;\r\n\r\nfunction TJclNumericFormat.StrToInt(const Value: string): Int64;\r\nvar\r\n I, N: Integer;\r\n C: Char;\r\nbegin\r\n Result := 0;\r\n I := 1;\r\n if (Length(Value) >= I)\r\n and ((Value[I] = '+') or (Value[I] = '-')) then\r\n Inc(I);\r\n for I := I to Length(Value) do\r\n begin\r\n C := Value[I];\r\n if C = DigitBlockSeparator then\r\n Continue\r\n else\r\n begin\r\n N := CharHex(C);\r\n if (N = $FF) or (N >= Base) then\r\n InvalidDigit(C);\r\n Result := Result * Base + N;\r\n end;\r\n end;\r\n if Value[1] = '-' then\r\n Result := -Result;\r\nend;\r\n\r\nfunction TJclNumericFormat.ShowSign(const Value: Float): Boolean;\r\nbegin\r\n Result := FShowPositiveSign or (Value < 0);\r\nend;\r\n\r\nfunction TJclNumericFormat.ShowSign(const Value: Int64): Boolean;\r\nbegin\r\n Result := FShowPositiveSign or (Value < 0);\r\nend;\r\n\r\nfunction TJclNumericFormat.SignChar(const Value: Float): Char;\r\nbegin\r\n Result := FSignChars[Value >= 0];\r\nend;\r\n\r\nfunction TJclNumericFormat.SignChar(const Value: Int64): Char;\r\nbegin\r\n Result := FSignChars[Value >= 0];\r\nend;\r\n\r\nfunction TJclNumericFormat.GetNegativeSign: Char;\r\nbegin\r\n Result := FSignChars[False];\r\nend;\r\n\r\nfunction TJclNumericFormat.GetPositiveSign: Char;\r\nbegin\r\n Result := FSignChars[True];\r\nend;\r\n\r\nprocedure TJclNumericFormat.SetNegativeSign(const Value: Char);\r\nbegin\r\n FSignChars[False] := Value;\r\nend;\r\n\r\nprocedure TJclNumericFormat.SetPositiveSign(const Value: Char);\r\nbegin\r\n FSignChars[True] := Value;\r\nend;\r\n\r\n//=== Child processes ========================================================\r\n\r\nconst\r\n BufferSize = 255;\r\ntype\r\n TBuffer = array [0..BufferSize] of AnsiChar;\r\n\r\n TPipeInfo = record\r\n PipeRead, PipeWrite: THandle;\r\n Buffer: TBuffer;\r\n Line: string;\r\n TextHandler: TTextHandler;\r\n RawOutput: Boolean;\r\n Event: TJclEvent;\r\n end;\r\n PPipeInfo = ^TPipeInfo;\r\n\r\n// MuteCRTerminatedLines was \"outsourced\" from Win32ExecAndRedirectOutput\r\n\r\nfunction InternalExecuteMuteCRTerminatedLines(const RawOutput: string): string;\r\nconst\r\n Delta = 1024;\r\nvar\r\n BufPos, OutPos, LfPos, EndPos: Integer;\r\n C: Char;\r\nbegin\r\n SetLength(Result, Length(RawOutput));\r\n OutPos := 1;\r\n LfPos := OutPos;\r\n EndPos := OutPos;\r\n for BufPos := 1 to Length(RawOutput) do\r\n begin\r\n if OutPos >= Length(Result)-2 then\r\n SetLength(Result, Length(Result) + Delta);\r\n C := RawOutput[BufPos];\r\n case C of\r\n NativeCarriageReturn:\r\n OutPos := LfPos;\r\n NativeLineFeed:\r\n begin\r\n OutPos := EndPos;\r\n Result[OutPos] := NativeCarriageReturn;\r\n Inc(OutPos);\r\n Result[OutPos] := C;\r\n Inc(OutPos);\r\n EndPos := OutPos;\r\n LfPos := OutPos;\r\n end;\r\n else\r\n Result[OutPos] := C;\r\n Inc(OutPos);\r\n EndPos := OutPos;\r\n end;\r\n end;\r\n SetLength(Result, OutPos - 1);\r\nend;\r\n\r\nprocedure InternalExecuteProcessLine(const PipeInfo: TPipeInfo; LineEnd: Integer);\r\nbegin\r\n if PipeInfo.RawOutput or (PipeInfo.Line[LineEnd] <> NativeCarriageReturn) then\r\n begin\r\n while (LineEnd > 0) and CharIsReturn(PipeInfo.Line[LineEnd]) do\r\n Dec(LineEnd);\r\n PipeInfo.TextHandler(Copy(PipeInfo.Line, 1, LineEnd));\r\n end;\r\nend;\r\n\r\nprocedure InternalExecuteProcessBuffer(var PipeInfo: TPipeInfo; PipeBytesRead: Cardinal);\r\nvar\r\n CR, LF: Integer;\r\nbegin\r\n PipeInfo.Buffer[PipeBytesRead] := #0;\r\n PipeInfo.Line := PipeInfo.Line + string(PipeInfo.Buffer);\r\n if Assigned(PipeInfo.TextHandler) then\r\n repeat\r\n CR := Pos(NativeCarriageReturn, PipeInfo.Line);\r\n if CR = Length(PipeInfo.Line) then\r\n CR := 0; // line feed at CR + 1 might be missing\r\n LF := Pos(NativeLineFeed, PipeInfo.Line);\r\n if (CR > 0) and ((LF > CR + 1) or (LF = 0)) then\r\n LF := CR; // accept CR as line end\r\n if LF > 0 then\r\n begin\r\n InternalExecuteProcessLine(PipeInfo, LF);\r\n Delete(PipeInfo.Line, 1, LF);\r\n end;\r\n until LF = 0;\r\nend;\r\n\r\nprocedure InternalExecuteReadPipe(var PipeInfo: TPipeInfo; var Overlapped: TOverlapped);\r\nvar\r\n NullDWORD: PCardinal;\r\n Res: DWORD;\r\nbegin\r\n NullDWORD := nil;\r\n if not ReadFile(PipeInfo.PipeRead, PipeInfo.Buffer[0], BufferSize, NullDWORD^, @Overlapped) then\r\n begin\r\n Res := GetLastError;\r\n case Res of\r\n ERROR_BROKEN_PIPE:\r\n begin\r\n CloseHandle(PipeInfo.PipeRead);\r\n PipeInfo.PipeRead := 0;\r\n end;\r\n ERROR_IO_PENDING:\r\n ;\r\n else\r\n {$IFDEF DELPHI11_UP}\r\n RaiseLastOSError(Res);\r\n {$ELSE}\r\n RaiseLastOSError;\r\n {$ENDIF DELPHI11_UP}\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure InternalExecuteHandlePipeEvent(var PipeInfo: TPipeInfo; var Overlapped: TOverlapped);\r\nvar\r\n PipeBytesRead: DWORD;\r\nbegin\r\n if GetOverlappedResult(PipeInfo.PipeRead, Overlapped, PipeBytesRead, False) then\r\n begin\r\n InternalExecuteProcessBuffer(PipeInfo, PipeBytesRead);\r\n // automatically launch the next read\r\n InternalExecuteReadPipe(PipeInfo, Overlapped);\r\n end\r\n else\r\n if GetLastError = ERROR_BROKEN_PIPE then\r\n begin\r\n CloseHandle(PipeInfo.PipeRead);\r\n PipeInfo.PipeRead := 0;\r\n end\r\n else\r\n RaiseLastOSError;\r\nend;\r\n\r\nprocedure InternalExecuteFlushPipe(var PipeInfo: TPipeInfo; var Overlapped: TOverlapped);\r\nvar\r\n PipeBytesRead: DWORD;\r\nbegin\r\n CancelIo(PipeInfo.PipeRead);\r\n GetOverlappedResult(PipeInfo.PipeRead, Overlapped, PipeBytesRead, True);\r\n if PipeBytesRead > 0 then\r\n InternalExecuteProcessBuffer(PipeInfo, PipeBytesRead);\r\n while PeekNamedPipe(PipeInfo.PipeRead, nil, 0, nil, @PipeBytesRead, nil) and (PipeBytesRead > 0) do\r\n begin\r\n if PipeBytesRead > BufferSize then\r\n PipeBytesRead := BufferSize;\r\n if not ReadFile(PipeInfo.PipeRead, PipeInfo.Buffer[0], PipeBytesRead, PipeBytesRead, nil) then\r\n RaiseLastOSError;\r\n InternalExecuteProcessBuffer(PipeInfo, PipeBytesRead);\r\n end;\r\nend;\r\n\r\nvar\r\n AsyncPipeCounter: Integer;\r\n\r\n// CreateAsyncPipe creates a pipe that uses overlapped reading.\r\nfunction CreateAsyncPipe(var hReadPipe, hWritePipe: THandle;\r\n lpPipeAttributes: PSecurityAttributes; nSize: DWORD): BOOL;\r\nvar\r\n PipeName: string;\r\n Error: DWORD;\r\n PipeReadHandle, PipeWriteHandle: THandle;\r\nbegin\r\n Result := False;\r\n\r\n if (@hReadPipe = nil) or (@hWritePipe = nil) then\r\n begin\r\n SetLastError(ERROR_INVALID_PARAMETER);\r\n Exit;\r\n end;\r\n\r\n if nSize = 0 then\r\n nSize := 4096;\r\n\r\n InterlockedIncrement(AsyncPipeCounter);\r\n // In some (not so) rare instances there is a race condition\r\n // where the counter is the same for two threads at the same \r\n // time. This makes the CreateNamedPipe call below fail \r\n // because of the limit set to 1 in the call.\r\n // So, to be sure this call succeeds, we put both the process\r\n // and thread id in the name of the pipe.\r\n // This was found to happen while simply starting 7 instances\r\n // of the same exe file in parallel.\r\n PipeName := Format('\\\\.\\Pipe\\AsyncAnonPipe.%.8x.%.8x.%.8x', [GetCurrentProcessId, GetCurrentThreadId, AsyncPipeCounter]);\r\n\r\n PipeReadHandle := CreateNamedPipe(PChar(PipeName), PIPE_ACCESS_INBOUND or FILE_FLAG_OVERLAPPED,\r\n PIPE_TYPE_BYTE or PIPE_WAIT, 1, nSize, nSize, 120 * 1000, lpPipeAttributes);\r\n if PipeReadHandle = INVALID_HANDLE_VALUE then\r\n Exit;\r\n\r\n PipeWriteHandle := CreateFile(PChar(PipeName), GENERIC_WRITE, 0, lpPipeAttributes, OPEN_EXISTING,\r\n FILE_ATTRIBUTE_NORMAL {or FILE_FLAG_OVERLAPPED}, 0);\r\n if PipeWriteHandle = INVALID_HANDLE_VALUE then\r\n begin\r\n Error := GetLastError;\r\n CloseHandle(PipeReadHandle);\r\n SetLastError(Error);\r\n Exit;\r\n end;\r\n\r\n hReadPipe := PipeReadHandle;\r\n hWritePipe := PipeWriteHandle;\r\n\r\n Result := True;\r\nend;\r\n\r\nconst\r\n BELOW_NORMAL_PRIORITY_CLASS = $00004000;\r\n ABOVE_NORMAL_PRIORITY_CLASS = $00008000;\r\n\r\n ProcessPriorities: array [TJclProcessPriority] of DWORD =\r\n (IDLE_PRIORITY_CLASS, NORMAL_PRIORITY_CLASS, HIGH_PRIORITY_CLASS, REALTIME_PRIORITY_CLASS,\r\n BELOW_NORMAL_PRIORITY_CLASS, ABOVE_NORMAL_PRIORITY_CLASS);\r\n\r\nfunction InternalExecute(CommandLine: string; AbortPtr: PBoolean; AbortEvent: TJclEvent;\r\n var Output: string; OutputLineCallback: TTextHandler; RawOutput: Boolean;\r\n MergeError: Boolean; var Error: string; ErrorLineCallback: TTextHandler; RawError: Boolean;\r\n ProcessPriority: TJclProcessPriority): Cardinal;\r\nvar\r\n OutPipeInfo, ErrorPipeInfo: TPipeInfo;\r\n Index: Cardinal;\r\n{$IFDEF MSWINDOWS}\r\nvar\r\n StartupInfo: TStartupInfo;\r\n ProcessInfo: TProcessInformation;\r\n SecurityAttr: TSecurityAttributes;\r\n OutOverlapped, ErrorOverlapped: TOverlapped;\r\n ProcessEvent: TJclDispatcherObject;\r\n WaitEvents: array of TJclDispatcherObject;\r\n InternalAbort: Boolean;\r\n LastError: DWORD;\r\nbegin\r\n // hack to pass a null reference to the parameter lpNumberOfBytesRead of ReadFile\r\n Result := $FFFFFFFF;\r\n SecurityAttr.nLength := SizeOf(SecurityAttr);\r\n SecurityAttr.lpSecurityDescriptor := nil;\r\n SecurityAttr.bInheritHandle := True;\r\n\r\n ResetMemory(OutPipeInfo, SizeOf(OutPipeInfo));\r\n OutPipeInfo.TextHandler := OutputLineCallback;\r\n OutPipeInfo.RawOutput := RawOutput;\r\n if not CreateAsyncPipe(OutPipeInfo.PipeRead, OutPipeInfo.PipeWrite, @SecurityAttr, 0) then\r\n begin\r\n Result := GetLastError;\r\n Exit;\r\n end;\r\n OutPipeInfo.Event := TJclEvent.Create(@SecurityAttr, False {automatic reset}, False {not flagged}, '' {anonymous});\r\n ResetMemory(ErrorPipeInfo, SizeOf(ErrorPipeInfo));\r\n if not MergeError then\r\n begin\r\n ErrorPipeInfo.TextHandler := ErrorLineCallback;\r\n ErrorPipeInfo.RawOutput := RawError;\r\n if not CreateAsyncPipe(ErrorPipeInfo.PipeRead, ErrorPipeInfo.PipeWrite, @SecurityAttr, 0) then\r\n begin\r\n Result := GetLastError;\r\n CloseHandle(OutPipeInfo.PipeWrite);\r\n CloseHandle(OutPipeInfo.PipeRead);\r\n OutPipeInfo.Event.Free;\r\n Exit;\r\n end;\r\n ErrorPipeInfo.Event := TJclEvent.Create(@SecurityAttr, False {automatic reset}, False {not flagged}, '' {anonymous});\r\n end;\r\n\r\n ResetMemory(StartupInfo, SizeOf(TStartupInfo));\r\n StartupInfo.cb := SizeOf(TStartupInfo);\r\n StartupInfo.dwFlags := STARTF_USESHOWWINDOW or STARTF_USESTDHANDLES;\r\n StartupInfo.wShowWindow := SW_HIDE;\r\n StartupInfo.hStdInput := GetStdHandle(STD_INPUT_HANDLE);\r\n StartupInfo.hStdOutput := OutPipeInfo.PipeWrite;\r\n if MergeError then\r\n StartupInfo.hStdError := OutPipeInfo.PipeWrite\r\n else\r\n StartupInfo.hStdError := ErrorPipeInfo.PipeWrite;\r\n UniqueString(CommandLine); // CommandLine must be in a writable memory block\r\n ProcessInfo.dwProcessId := 0;\r\n ProcessEvent := nil;\r\n try\r\n if CreateProcess(nil, PChar(CommandLine), nil, nil, True, ProcessPriorities[ProcessPriority],\r\n nil, nil, StartupInfo, ProcessInfo) then\r\n begin\r\n try\r\n // init out and error events\r\n CloseHandle(OutPipeInfo.PipeWrite);\r\n OutPipeInfo.PipeWrite := 0;\r\n if not MergeError then\r\n begin\r\n CloseHandle(ErrorPipeInfo.PipeWrite);\r\n ErrorPipeInfo.PipeWrite := 0;\r\n end;\r\n InternalAbort := False;\r\n if AbortPtr <> nil then\r\n AbortPtr^ := {$IFDEF FPC}Byte({$ENDIF}False{$IFDEF FPC}){$ENDIF}\r\n else\r\n AbortPtr := @InternalAbort;\r\n // init the array of events to wait for\r\n ProcessEvent := TJclDispatcherObject.Attach(ProcessInfo.hProcess);\r\n SetLength(WaitEvents, 2);\r\n // add the process first\r\n WaitEvents[0] := ProcessEvent;\r\n // add the output event\r\n WaitEvents[1] := OutPipeInfo.Event;\r\n // add the error event\r\n if not MergeError then\r\n begin\r\n SetLength(WaitEvents, 3);\r\n WaitEvents[2] := ErrorPipeInfo.Event;\r\n end;\r\n // add the abort event if any\r\n if AbortEvent <> nil then\r\n begin\r\n AbortEvent.ResetEvent;\r\n Index := Length(WaitEvents);\r\n SetLength(WaitEvents, Index + 1);\r\n WaitEvents[Index] := AbortEvent;\r\n end;\r\n // init the asynchronous reads\r\n ResetMemory(OutOverlapped, SizeOf(OutOverlapped));\r\n OutOverlapped.hEvent := OutPipeInfo.Event.Handle;\r\n InternalExecuteReadPipe(OutPipeInfo, OutOverlapped);\r\n if not MergeError then\r\n begin\r\n ResetMemory(ErrorOverlapped, SizeOf(ErrorOverlapped));\r\n ErrorOverlapped.hEvent := ErrorPipeInfo.Event.Handle;\r\n InternalExecuteReadPipe(ErrorPipeInfo, ErrorOverlapped);\r\n end;\r\n // event based loop\r\n while not {$IFDEF FPC}Boolean({$ENDIF}AbortPtr^{$IFDEF FPC}){$ENDIF} do\r\n begin\r\n Index := WaitAlertableForMultipleObjects(WaitEvents, False, INFINITE);\r\n if Index = WAIT_OBJECT_0 then\r\n // the subprocess has ended\r\n Break\r\n else\r\n if Index = (WAIT_OBJECT_0 + 1) then\r\n begin\r\n // event on output\r\n InternalExecuteHandlePipeEvent(OutPipeInfo, OutOverlapped);\r\n end\r\n else\r\n if (Index = (WAIT_OBJECT_0 + 2)) and not MergeError then\r\n begin\r\n // event on error\r\n InternalExecuteHandlePipeEvent(ErrorPipeInfo, ErrorOverlapped);\r\n end\r\n else\r\n if ((Index = (WAIT_OBJECT_0 + 2)) and MergeError) or\r\n ((Index = (WAIT_OBJECT_0 + 3)) and not MergeError) then\r\n // event on abort\r\n AbortPtr^ := {$IFDEF FPC}Byte({$ENDIF}True{$IFDEF FPC}){$ENDIF}\r\n else\r\n {$IFDEF DELPHI11_UP}\r\n RaiseLastOSError(Index);\r\n {$ELSE}\r\n RaiseLastOSError;\r\n {$ENDIF DELPHI11_UP}\r\n end;\r\n if {$IFDEF FPC}Boolean({$ENDIF}AbortPtr^{$IFDEF FPC}){$ENDIF} then\r\n TerminateProcess(ProcessEvent.Handle, Cardinal(ABORT_EXIT_CODE));\r\n if (ProcessEvent.WaitForever = wrSignaled) and not GetExitCodeProcess(ProcessEvent.Handle, Result) then\r\n Result := $FFFFFFFF;\r\n CloseHandle(ProcessInfo.hThread);\r\n ProcessInfo.hThread := 0;\r\n if OutPipeInfo.PipeRead <> 0 then\r\n // read data remaining in output pipe\r\n InternalExecuteFlushPipe(OutPipeinfo, OutOverlapped);\r\n if not MergeError and (ErrorPipeInfo.PipeRead <> 0) then\r\n // read data remaining in error pipe\r\n InternalExecuteFlushPipe(ErrorPipeInfo, ErrorOverlapped);\r\n except\r\n // always terminate process in case of an exception.\r\n // This is especially useful when an exception occured in one of\r\n // the texthandler but only do it if the process actually started,\r\n // this prevents eating up the last error value by calling those\r\n // three functions with an invalid handle\r\n // Note that we don't do it in the finally block because these\r\n // calls would also then eat up the last error value which we tried\r\n // to avoid in the first place\r\n if ProcessInfo.hProcess <> 0 then\r\n begin\r\n TerminateProcess(ProcessInfo.hProcess, Cardinal(ABORT_EXIT_CODE));\r\n WaitForSingleObject(ProcessInfo.hProcess, INFINITE);\r\n GetExitCodeProcess(ProcessInfo.hProcess, Result);\r\n end;\r\n\r\n raise;\r\n end;\r\n end;\r\n finally\r\n LastError := GetLastError;\r\n try\r\n if OutPipeInfo.PipeRead <> 0 then\r\n CloseHandle(OutPipeInfo.PipeRead);\r\n if OutPipeInfo.PipeWrite <> 0 then\r\n CloseHandle(OutPipeInfo.PipeWrite);\r\n if ErrorPipeInfo.PipeRead <> 0 then\r\n CloseHandle(ErrorPipeInfo.PipeRead);\r\n if ErrorPipeInfo.PipeWrite <> 0 then\r\n CloseHandle(ErrorPipeInfo.PipeWrite);\r\n if ProcessInfo.hThread <> 0 then\r\n CloseHandle(ProcessInfo.hThread);\r\n\r\n if Assigned(ProcessEvent) then\r\n ProcessEvent.Free // this calls CloseHandle(ProcessInfo.hProcess)\r\n else if ProcessInfo.hProcess <> 0 then\r\n CloseHandle(ProcessInfo.hProcess);\r\n OutPipeInfo.Event.Free;\r\n ErrorPipeInfo.Event.Free;\r\n finally\r\n SetLastError(LastError);\r\n end;\r\n end;\r\n{$ENDIF MSWINDOWS}\r\n{$IFDEF UNIX}\r\nvar\r\n PipeBytesRead: Cardinal;\r\n Pipe: PIOFile;\r\n Cmd: string;\r\nbegin\r\n Cmd := Format('%s 2>&1', [CommandLine]);\r\n Pipe := nil;\r\n try\r\n Pipe := Libc.popen(PChar(Cmd), 'r');\r\n { TODO : handle Abort }\r\n repeat\r\n PipeBytesRead := fread_unlocked(@OutBuffer, 1, BufferSize, Pipe);\r\n if PipeBytesRead > 0 then\r\n ProcessBuffer(OutBuffer, OutLine, PipeBytesRead);\r\n until PipeBytesRead = 0;\r\n Result := pclose(Pipe);\r\n Pipe := nil;\r\n wait(nil);\r\n finally\r\n if Pipe <> nil then\r\n pclose(Pipe);\r\n wait(nil);\r\n end;\r\n{$ENDIF UNIX}\r\n if OutPipeInfo.Line <> '' then\r\n if Assigned(OutPipeInfo.TextHandler) then\r\n // output wasn't terminated by a line feed...\r\n // (shouldn't happen, but you never know)\r\n InternalExecuteProcessLine(OutPipeInfo, Length(OutPipeInfo.Line))\r\n else\r\n if RawOutput then\r\n Output := Output + OutPipeInfo.Line\r\n else\r\n Output := Output + InternalExecuteMuteCRTerminatedLines(OutPipeInfo.Line);\r\n if ErrorPipeInfo.Line <> '' then\r\n if Assigned(ErrorPipeInfo.TextHandler) then\r\n // error wasn't terminated by a line feed...\r\n // (shouldn't happen, but you never know)\r\n InternalExecuteProcessLine(ErrorPipeInfo, Length(ErrorPipeInfo.Line))\r\n else\r\n if RawError then\r\n Error := Error + ErrorPipeInfo.Line\r\n else\r\n Error := Error + InternalExecuteMuteCRTerminatedLines(ErrorPipeInfo.Line);\r\nend;\r\n\r\n{ TODO -cHelp :\r\nRawOutput: Do not process isolated carriage returns (#13).\r\nThat is, for RawOutput = False, lines not terminated by a line feed (#10) are deleted from Output. }\r\n\r\nfunction Execute(const CommandLine: string; var Output: string; RawOutput: Boolean;\r\n AbortPtr: PBoolean; ProcessPriority: TJclProcessPriority): Cardinal;\r\nvar\r\n Error: string;\r\nbegin\r\n Error := '';\r\n Result := InternalExecute(CommandLine, AbortPtr, nil, Output, nil, RawOutput, True, Error, nil, False, ProcessPriority);\r\nend;\r\n\r\nfunction Execute(const CommandLine: string; AbortEvent: TJclEvent; var Output: string; RawOutput: Boolean; ProcessPriority: TJclProcessPriority): Cardinal;\r\nvar\r\n Error: string;\r\nbegin\r\n Error := '';\r\n Result := InternalExecute(CommandLine, nil, AbortEvent, Output, nil, RawOutput, True, Error, nil, False, ProcessPriority);\r\nend;\r\n\r\n{ TODO -cHelp :\r\nAuthor: Robert Rossmair\r\nOutputLineCallback called once per line of output. }\r\n\r\nfunction Execute(const CommandLine: string; OutputLineCallback: TTextHandler; RawOutput: Boolean;\r\n AbortPtr: PBoolean; ProcessPriority: TJclProcessPriority): Cardinal;\r\nvar\r\n Output, Error: string;\r\nbegin\r\n Output := '';\r\n Error := '';\r\n Result := InternalExecute(CommandLine, AbortPtr, nil, Output, OutputLineCallback, RawOutput, True, Error, nil, False, ProcessPriority);\r\nend;\r\n\r\nfunction Execute(const CommandLine: string; AbortEvent: TJclEvent; OutputLineCallback: TTextHandler; RawOutput: Boolean; ProcessPriority: TJclProcessPriority): Cardinal;\r\nvar\r\n Output, Error: string;\r\nbegin\r\n Output := '';\r\n Error := '';\r\n Result := InternalExecute(CommandLine, nil, AbortEvent, Output, OutputLineCallback, RawOutput, True, Error, nil, False, ProcessPriority);\r\nend;\r\n\r\n{ TODO -cHelp :\r\nRawOutput: Do not process isolated carriage returns (#13).\r\nThat is, for RawOutput = False, lines not terminated by a line feed (#10) are deleted from Output. }\r\n\r\nfunction Execute(const CommandLine: string; var Output, Error: string; RawOutput, RawError: Boolean;\r\n AbortPtr: PBoolean; ProcessPriority: TJclProcessPriority): Cardinal;\r\nbegin\r\n Result := InternalExecute(CommandLine, AbortPtr, nil, Output, nil, RawOutput, False, Error, nil, RawError, ProcessPriority);\r\nend;\r\n\r\nfunction Execute(const CommandLine: string; AbortEvent: TJclEvent; var Output, Error: string;\r\n RawOutput, RawError: Boolean; ProcessPriority: TJclProcessPriority): Cardinal;\r\nbegin\r\n Result := InternalExecute(CommandLine, nil, AbortEvent, Output, nil, RawOutput, False, Error, nil, RawError, ProcessPriority);\r\nend;\r\n\r\n{ TODO -cHelp :\r\nAuthor: Robert Rossmair\r\nOutputLineCallback called once per line of output. }\r\n\r\nfunction Execute(const CommandLine: string; OutputLineCallback, ErrorLineCallback: TTextHandler;\r\n RawOutput, RawError: Boolean; AbortPtr: PBoolean; ProcessPriority: TJclProcessPriority): Cardinal;\r\nvar\r\n Output, Error: string;\r\nbegin\r\n Output := '';\r\n Error := '';\r\n Result := InternalExecute(CommandLine, AbortPtr, nil, Output, OutputLineCallback, RawOutput, False, Error, ErrorLineCallback, RawError, ProcessPriority);\r\nend;\r\n\r\nfunction Execute(const CommandLine: string; AbortEvent: TJclEvent; OutputLineCallback, ErrorLineCallback: TTextHandler;\r\n RawOutput, RawError: Boolean; ProcessPriority: TJclProcessPriority): Cardinal;\r\nvar\r\n Output, Error: string;\r\nbegin\r\n Output := '';\r\n Error := '';\r\n Result := InternalExecute(CommandLine, nil, AbortEvent, Output, OutputLineCallback, RawOutput, False, Error, ErrorLineCallback, RawError, ProcessPriority);\r\nend;\r\n\r\n//=== { TJclCommandLineTool } ================================================\r\n\r\nconstructor TJclCommandLineTool.Create(const AExeName: string);\r\nbegin\r\n inherited Create;\r\n FOptions := TStringList.Create;\r\n FExeName := AExeName;\r\nend;\r\n\r\ndestructor TJclCommandLineTool.Destroy;\r\nbegin\r\n FreeAndNil(FOptions);\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJclCommandLineTool.AddPathOption(const Option, Path: string);\r\nvar\r\n S: string;\r\nbegin\r\n S := PathRemoveSeparator(Path);\r\n {$IFDEF MSWINDOWS}\r\n S := LowerCase(S); // file names are case insensitive\r\n {$ENDIF MSWINDOWS}\r\n S := Format('-%s%s', [Option, S]);\r\n // avoid duplicate entries (note that search is case sensitive)\r\n if GetOptions.IndexOf(S) = -1 then\r\n GetOptions.Add(S);\r\nend;\r\n\r\nfunction TJclCommandLineTool.Execute(const CommandLine: string): Boolean;\r\nbegin\r\n if Assigned(FOutputCallback) then\r\n Result := JclSysUtils.Execute(Format('\"%s\" %s', [ExeName, CommandLine]), FOutputCallback) = 0\r\n else\r\n Result := JclSysUtils.Execute(Format('\"%s\" %s', [ExeName, CommandLine]), FOutput) = 0;\r\nend;\r\n\r\nfunction TJclCommandLineTool.GetExeName: string;\r\nbegin\r\n Result := FExeName;\r\nend;\r\n\r\nfunction TJclCommandLineTool.GetOptions: TStrings;\r\nbegin\r\n Result := FOptions;\r\nend;\r\n\r\nfunction TJclCommandLineTool.GetOutput: string;\r\nbegin\r\n Result := FOutput;\r\nend;\r\n\r\nfunction TJclCommandLineTool.GetOutputCallback: TTextHandler;\r\nbegin\r\n Result := FOutputCallback;\r\nend;\r\n\r\nprocedure TJclCommandLineTool.SetOutputCallback(const CallbackMethod: TTextHandler);\r\nbegin\r\n FOutputCallback := CallbackMethod;\r\nend;\r\n\r\n//=== Console Utilities ======================================================\r\n\r\nfunction ReadKey: Char;\r\n{$IFDEF MSWINDOWS}\r\n{ TODO -cHelp : Contributor: Robert Rossmair }\r\nvar\r\n Console: TJclConsole;\r\n InputMode: TJclConsoleInputModes;\r\nbegin\r\n Console := TJclConsole.Default;\r\n InputMode := Console.Input.Mode;\r\n Console.Input.Mode := [imProcessed];\r\n Console.Input.Clear;\r\n Result := Char(Console.Input.GetEvent.Event.KeyEvent.AsciiChar);\r\n Console.Input.Mode := InputMode;\r\nend;\r\n{$ENDIF MSWINDOWS}\r\n{$IFDEF UNIX}\r\n{ TODO -cHelp : Donator: Wayne Sherman }\r\nvar\r\n ReadFileDescriptor: TFDSet;\r\n TimeVal: TTimeVal;\r\n SaveTerminalSettings: TTermIos;\r\n RawTerminalSettings: TTermIos;\r\nbegin\r\n Result := #0;\r\n\r\n //Save Original Terminal Settings\r\n tcgetattr(stdin, SaveTerminalSettings);\r\n tcgetattr(stdin, RawTerminalSettings);\r\n\r\n //Put Terminal in RAW mode\r\n cfmakeraw(RawTerminalSettings);\r\n tcsetattr(stdin, TCSANOW, RawTerminalSettings);\r\n try\r\n //Setup file I/O descriptor for STDIN\r\n FD_ZERO(ReadFileDescriptor);\r\n FD_SET(stdin, ReadFileDescriptor);\r\n TimeVal.tv_sec := High(LongInt); //wait forever\r\n TimeVal.tv_usec := 0;\r\n\r\n //clear keyboard buffer first\r\n TCFlush(stdin, TCIFLUSH);\r\n\r\n //wait for a key to be pressed\r\n if select(1, @ReadFileDescriptor, nil, nil, @TimeVal) > 0 then\r\n begin\r\n //Now read the character\r\n Result := Char(getchar);\r\n end\r\n else\r\n raise EJclError.CreateRes(@RsReadKeyError);\r\n finally\r\n //Restore Original Terminal Settings\r\n tcsetattr(stdin, TCSANOW, SaveTerminalSettings);\r\n end;\r\nend;\r\n{$ENDIF UNIX}\r\n\r\n//=== Loading of modules (DLLs) ==============================================\r\n\r\nfunction LoadModule(var Module: TModuleHandle; FileName: string): Boolean;\r\n{$IFDEF MSWINDOWS}\r\nbegin\r\n if Module = INVALID_MODULEHANDLE_VALUE then\r\n Module := SafeLoadLibrary(FileName);\r\n Result := Module <> INVALID_MODULEHANDLE_VALUE;\r\nend;\r\n{$ENDIF MSWINDOWS}\r\n{$IFDEF UNIX}\r\nbegin\r\n if Module = INVALID_MODULEHANDLE_VALUE then\r\n Module := dlopen(PChar(FileName), RTLD_NOW);\r\n Result := Module <> INVALID_MODULEHANDLE_VALUE;\r\nend;\r\n{$ENDIF UNIX}\r\n\r\nfunction LoadModuleEx(var Module: TModuleHandle; FileName: string; Flags: Cardinal): Boolean;\r\n{$IFDEF MSWINDOWS}\r\nbegin\r\n if Module = INVALID_MODULEHANDLE_VALUE then\r\n Module := LoadLibraryEx(PChar(FileName), 0, Flags); // SafeLoadLibrary?\r\n Result := Module <> INVALID_MODULEHANDLE_VALUE;\r\nend;\r\n{$ENDIF MSWINDOWS}\r\n{$IFDEF UNIX}\r\nbegin\r\n if Module = INVALID_MODULEHANDLE_VALUE then\r\n Module := dlopen(PChar(FileName), Flags);\r\n Result := Module <> INVALID_MODULEHANDLE_VALUE;\r\nend;\r\n{$ENDIF UNIX}\r\n\r\nprocedure UnloadModule(var Module: TModuleHandle);\r\n{$IFDEF MSWINDOWS}\r\nbegin\r\n if Module <> INVALID_MODULEHANDLE_VALUE then\r\n FreeLibrary(Module);\r\n Module := INVALID_MODULEHANDLE_VALUE;\r\nend;\r\n{$ENDIF MSWINDOWS}\r\n{$IFDEF UNIX}\r\nbegin\r\n if Module <> INVALID_MODULEHANDLE_VALUE then\r\n dlclose(Pointer(Module));\r\n Module := INVALID_MODULEHANDLE_VALUE;\r\nend;\r\n{$ENDIF UNIX}\r\n\r\nfunction GetModuleSymbol(Module: TModuleHandle; SymbolName: string): Pointer;\r\n{$IFDEF MSWINDOWS}\r\nbegin\r\n Result := nil;\r\n if Module <> INVALID_MODULEHANDLE_VALUE then\r\n Result := GetProcAddress(Module, PChar(SymbolName));\r\nend;\r\n{$ENDIF MSWINDOWS}\r\n{$IFDEF UNIX}\r\nbegin\r\n Result := nil;\r\n if Module <> INVALID_MODULEHANDLE_VALUE then\r\n Result := dlsym(Module, PChar(SymbolName));\r\nend;\r\n{$ENDIF UNIX}\r\n\r\nfunction GetModuleSymbolEx(Module: TModuleHandle; SymbolName: string; var Accu: Boolean): Pointer;\r\n{$IFDEF MSWINDOWS}\r\nbegin\r\n Result := nil;\r\n if Module <> INVALID_MODULEHANDLE_VALUE then\r\n Result := GetProcAddress(Module, PChar(SymbolName));\r\n Accu := Accu and (Result <> nil);\r\nend;\r\n{$ENDIF MSWINDOWS}\r\n{$IFDEF UNIX}\r\nbegin\r\n Result := nil;\r\n if Module <> INVALID_MODULEHANDLE_VALUE then\r\n Result := dlsym(Module, PChar(SymbolName));\r\n Accu := Accu and (Result <> nil);\r\nend;\r\n{$ENDIF UNIX}\r\n\r\nfunction ReadModuleData(Module: TModuleHandle; SymbolName: string; var Buffer; Size: Cardinal): Boolean;\r\nvar\r\n Sym: Pointer;\r\nbegin\r\n Result := True;\r\n Sym := GetModuleSymbolEx(Module, SymbolName, Result);\r\n if Result then\r\n Move(Sym^, Buffer, Size);\r\nend;\r\n\r\nfunction WriteModuleData(Module: TModuleHandle; SymbolName: string; var Buffer; Size: Cardinal): Boolean;\r\nvar\r\n Sym: Pointer;\r\nbegin\r\n Result := True;\r\n Sym := GetModuleSymbolEx(Module, SymbolName, Result);\r\n if Result then\r\n Move(Buffer, Sym^, Size);\r\nend;\r\n\r\n//=== Conversion Utilities ===================================================\r\n\r\nconst\r\n DefaultTrueBoolStr = 'True'; // DO NOT LOCALIZE\r\n DefaultFalseBoolStr = 'False'; // DO NOT LOCALIZE\r\n\r\n DefaultYesBoolStr = 'Yes'; // DO NOT LOCALIZE\r\n DefaultNoBoolStr = 'No'; // DO NOT LOCALIZE\r\n\r\nfunction StrToBoolean(const S: string): Boolean;\r\nvar\r\n LowerCasedText: string;\r\nbegin\r\n { TODO : Possibility to add localized strings, like in Delphi 7 }\r\n { TODO : Lower case constants }\r\n LowerCasedText := LowerCase(S);\r\n Result := ((S = '1') or\r\n (LowerCasedText = LowerCase(DefaultTrueBoolStr)) or (LowerCasedText = LowerCase(DefaultYesBoolStr))) or\r\n (LowerCasedText = LowerCase(DefaultTrueBoolStr[1])) or (LowerCasedText = LowerCase(DefaultYesBoolStr[1]));\r\n if not Result then\r\n begin\r\n Result := not ((S = '0') or\r\n (LowerCasedText = LowerCase(DefaultFalseBoolStr)) or (LowerCasedText = LowerCase(DefaultNoBoolStr)) or\r\n (LowerCasedText = LowerCase(DefaultFalseBoolStr[1])) or (LowerCasedText = LowerCase(DefaultNoBoolStr[1])));\r\n if Result then\r\n raise EJclConversionError.CreateResFmt(@RsStringToBoolean, [S]);\r\n end;\r\nend;\r\n\r\nfunction BooleanToStr(B: Boolean): string;\r\nbegin\r\n if B then\r\n Result := DefaultTrueBoolStr\r\n else\r\n Result := DefaultFalseBoolStr;\r\nend;\r\n\r\nfunction IntToBool(I: Integer): Boolean;\r\nbegin\r\n Result := I <> 0;\r\nend;\r\n\r\nfunction BoolToInt(B: Boolean): Integer;\r\nbegin\r\n Result := Ord(B);\r\nend;\r\n\r\nfunction TryStrToUInt(const Value: string; out Res: Cardinal): Boolean;\r\nvar i6: Int64;\r\nbegin\r\n Result := false;\r\n if not TryStrToInt64(Value, i6) then exit;\r\n if ( i6 < Low(Res)) or ( i6 > High(Res)) then exit;\r\n\r\n Result := true;\r\n Res := i6;\r\nend;\r\n\r\nfunction StrToUIntDef(const Value: string; const Default: Cardinal): Cardinal;\r\nbegin\r\n if not TryStrToUInt(Value, Result)\r\n then Result := Default;\r\nend;\r\n\r\nfunction StrToUInt(const Value: string): Cardinal;\r\nbegin\r\n if not TryStrToUInt(Value, Result)\r\n then raise EConvertError.Create('\"'+Value+'\" is not within range of Cardinal data type');\r\nend;\r\n\r\n//=== RTL package information ================================================\r\n\r\nfunction SystemTObjectInstance: TJclAddr;\r\nbegin\r\n Result := ModuleFromAddr(Pointer(System.TObject));\r\nend;\r\n\r\nfunction IsCompiledWithPackages: Boolean;\r\nbegin\r\n Result := SystemTObjectInstance <> HInstance;\r\nend;\r\n\r\n//=== GUID ===================================================================\r\n\r\nfunction JclGUIDToString(const GUID: TGUID): string;\r\nbegin\r\n Result := Format('{%.8x-%.4x-%.4x-%.2x%.2x-%.2x%.2x%.2x%.2x%.2x%.2x}',\r\n [GUID.D1, GUID.D2, GUID.D3, GUID.D4[0], GUID.D4[1], GUID.D4[2],\r\n GUID.D4[3], GUID.D4[4], GUID.D4[5], GUID.D4[6], GUID.D4[7]]);\r\nend;\r\n\r\nfunction JclStringToGUID(const S: string): TGUID;\r\nbegin\r\n if (Length(S) <> 38) or (S[1] <> '{') or (S[10] <> '-') or (S[15] <> '-') or\r\n (S[20] <> '-') or (S[25] <> '-') or (S[38] <> '}') then\r\n raise EJclConversionError.CreateResFmt(@RsInvalidGUIDString, [S]);\r\n\r\n Result.D1 := StrToInt('$' + Copy(S, 2, 8));\r\n Result.D2 := StrToInt('$' + Copy(S, 11, 4));\r\n Result.D3 := StrToInt('$' + Copy(S, 16, 4));\r\n Result.D4[0] := StrToInt('$' + Copy(S, 21, 2));\r\n Result.D4[1] := StrToInt('$' + Copy(S, 23, 2));\r\n Result.D4[2] := StrToInt('$' + Copy(S, 26, 2));\r\n Result.D4[3] := StrToInt('$' + Copy(S, 28, 2));\r\n Result.D4[4] := StrToInt('$' + Copy(S, 30, 2));\r\n Result.D4[5] := StrToInt('$' + Copy(S, 32, 2));\r\n Result.D4[6] := StrToInt('$' + Copy(S, 34, 2));\r\n Result.D4[7] := StrToInt('$' + Copy(S, 36, 2));\r\nend;\r\n\r\nfunction GUIDEquals(const GUID1, GUID2: TGUID): Boolean;\r\nbegin\r\n Result := (GUID1.D1 = GUID2.D1) and (GUID1.D2 = GUID2.D2) and (GUID1.D3 = GUID2.D3) and\r\n (GUID1.D4[0] = GUID2.D4[0]) and (GUID1.D4[1] = GUID2.D4[1]) and\r\n (GUID1.D4[2] = GUID2.D4[2]) and (GUID1.D4[3] = GUID2.D4[3]) and\r\n (GUID1.D4[4] = GUID2.D4[4]) and (GUID1.D4[5] = GUID2.D4[5]) and\r\n (GUID1.D4[6] = GUID2.D4[6]) and (GUID1.D4[7] = GUID2.D4[7]);\r\nend;\r\n\r\n// add items at the end\r\nprocedure ListAddItems(var List: string; const Separator, Items: string);\r\nvar\r\n StrList, NewItems: TStringList;\r\n Index: Integer;\r\nbegin\r\n StrList := TStringList.Create;\r\n try\r\n StrToStrings(List, Separator, StrList);\r\n\r\n NewItems := TStringList.Create;\r\n try\r\n StrToStrings(Items, Separator, NewItems);\r\n\r\n for Index := 0 to NewItems.Count - 1 do\r\n StrList.Add(NewItems.Strings[Index]);\r\n\r\n List := StringsToStr(StrList, Separator);\r\n finally\r\n NewItems.Free;\r\n end;\r\n finally\r\n StrList.Free;\r\n end;\r\nend;\r\n\r\n// add items at the end if they are not present\r\nprocedure ListIncludeItems(var List: string; const Separator, Items: string);\r\nvar\r\n StrList, NewItems: TStringList;\r\n Index: Integer;\r\n Item: string;\r\nbegin\r\n StrList := TStringList.Create;\r\n try\r\n StrToStrings(List, Separator, StrList);\r\n\r\n NewItems := TStringList.Create;\r\n try\r\n StrToStrings(Items, Separator, NewItems);\r\n\r\n for Index := 0 to NewItems.Count - 1 do\r\n begin\r\n Item := NewItems.Strings[Index];\r\n if StrList.IndexOf(Item) = -1 then\r\n StrList.Add(Item);\r\n end;\r\n\r\n List := StringsToStr(StrList, Separator);\r\n finally\r\n NewItems.Free;\r\n end;\r\n finally\r\n StrList.Free;\r\n end;\r\nend;\r\n\r\n// delete multiple items\r\nprocedure ListRemoveItems(var List: string; const Separator, Items: string);\r\nvar\r\n StrList, RemItems: TStringList;\r\n Index, Position: Integer;\r\n Item: string;\r\nbegin\r\n StrList := TStringList.Create;\r\n try\r\n StrToStrings(List, Separator, StrList);\r\n\r\n RemItems := TStringList.Create;\r\n try\r\n StrToStrings(Items, Separator, RemItems);\r\n\r\n for Index := 0 to RemItems.Count - 1 do\r\n begin\r\n Item := RemItems.Strings[Index];\r\n repeat\r\n Position := StrList.IndexOf(Item);\r\n if Position >= 0 then\r\n StrList.Delete(Position);\r\n until Position < 0;\r\n end;\r\n\r\n List := StringsToStr(StrList, Separator);\r\n finally\r\n RemItems.Free;\r\n end;\r\n finally\r\n StrList.Free;\r\n end;\r\nend;\r\n\r\n// delete one item\r\nprocedure ListDelItem(var List: string; const Separator: string; const Index: Integer);\r\nvar\r\n StrList: TStringList;\r\nbegin\r\n StrList := TStringList.Create;\r\n try\r\n StrToStrings(List, Separator, StrList);\r\n\r\n StrList.Delete(Index);\r\n\r\n List := StringsToStr(StrList, Separator);\r\n finally\r\n StrList.Free;\r\n end;\r\nend;\r\n\r\n// return the number of item\r\nfunction ListItemCount(const List, Separator: string): Integer;\r\nvar\r\n StrList: TStringList;\r\nbegin\r\n StrList := TStringList.Create;\r\n try\r\n StrToStrings(List, Separator, StrList);\r\n\r\n Result := StrList.Count;\r\n finally\r\n StrList.Free;\r\n end;\r\nend;\r\n\r\n// return the Nth item\r\nfunction ListGetItem(const List, Separator: string; const Index: Integer): string;\r\nvar\r\n StrList: TStringList;\r\nbegin\r\n StrList := TStringList.Create;\r\n try\r\n StrToStrings(List, Separator, StrList);\r\n\r\n Result := StrList.Strings[Index];\r\n finally\r\n StrList.Free;\r\n end;\r\nend;\r\n\r\n// set the Nth item\r\nprocedure ListSetItem(var List: string; const Separator: string;\r\n const Index: Integer; const Value: string);\r\nvar\r\n StrList: TStringList;\r\nbegin\r\n StrList := TStringList.Create;\r\n try\r\n StrToStrings(List, Separator, StrList);\r\n\r\n StrList.Strings[Index] := Value;\r\n\r\n List := StringsToStr(StrList, Separator);\r\n finally\r\n StrList.Free;\r\n end;\r\nend;\r\n\r\n// return the index of an item\r\nfunction ListItemIndex(const List, Separator, Item: string): Integer;\r\nvar\r\n StrList: TStringList;\r\nbegin\r\n StrList := TStringList.Create;\r\n try\r\n StrToStrings(List, Separator, StrList);\r\n\r\n Result := StrList.IndexOf(Item);\r\n finally\r\n StrList.Free;\r\n end;\r\nend;\r\n\r\n//=== { TJclIntfCriticalSection } ============================================\r\n\r\nconstructor TJclIntfCriticalSection.Create;\r\nbegin\r\n inherited Create;\r\n FCriticalSection := TCriticalSection.Create;\r\nend;\r\n\r\ndestructor TJclIntfCriticalSection.Destroy;\r\nbegin\r\n FCriticalSection.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJclIntfCriticalSection._AddRef: Integer;\r\nbegin\r\n FCriticalSection.Acquire;\r\n Result := -1;\r\nend;\r\n\r\nfunction TJclIntfCriticalSection._Release: Integer;\r\nbegin\r\n FCriticalSection.Release;\r\n Result := -1;\r\nend;\r\n\r\n//=== { TJclSimpleLog } ======================================================\r\n\r\n{$IFDEF LINUX}\r\nconst\r\n INVALID_HANDLE_VALUE = 0;\r\n{$ENDIF LINUX}\r\n\r\nconstructor TJclSimpleLog.Create(const ALogFileName: string = '');\r\nbegin\r\n if ALogFileName = '' then\r\n FLogFileName := CreateDefaultFileName\r\n else\r\n FLogFileName := ALogFileName;\r\n FLogFileHandle := TFileHandle(INVALID_HANDLE_VALUE);\r\n FLoggingActive := True;\r\nend;\r\n\r\nfunction TJclSimpleLog.CreateDefaultFileName: string;\r\nbegin\r\n Result := PathExtractFileDirFixed(ParamStr(0)) +\r\n PathExtractFileNameNoExt(ParamStr(0)) + '_Err.log';\r\nend;\r\n\r\ndestructor TJclSimpleLog.Destroy;\r\nbegin\r\n CloseLog;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJclSimpleLog.ClearLog;\r\nvar\r\n WasOpen: Boolean;\r\nbegin\r\n WasOpen := LogOpen;\r\n if WasOpen then\r\n CloseLog;\r\n if not FileExists(FlogFileName) then\r\n Exit;\r\n FLogFileHandle := FileCreate(FLogFileName);\r\n FLogWasEmpty := True;\r\n if Not WasOpen then\r\n CloseLog;\r\nend;\r\n\r\nprocedure TJclSimpleLog.CloseLog;\r\nbegin\r\n if LogOpen then\r\n begin\r\n FileClose(FLogFileHandle);\r\n FLogFileHandle := TFileHandle(INVALID_HANDLE_VALUE);\r\n FLogWasEmpty := False;\r\n end;\r\nend;\r\n\r\nfunction TJclSimpleLog.GetLogOpen: Boolean;\r\nbegin\r\n Result := DWORD_PTR(FLogFileHandle) <> INVALID_HANDLE_VALUE;\r\nend;\r\n\r\nprocedure TJclSimpleLog.OpenLog;\r\nbegin\r\n if not LogOpen then\r\n begin\r\n FLogFileHandle := FileOpen(FLogFileName, fmOpenWrite or fmShareDenyWrite);\r\n if LogOpen then\r\n FLogWasEmpty := FileSeek(FLogFileHandle, 0, soFromEnd) = 0\r\n else\r\n begin\r\n FLogFileHandle := FileCreate(FLogFileName);\r\n FLogWasEmpty := True;\r\n if LogOpen then\r\n FileWrite(FLogFileHandle, BOM_UTF8[0], Length(BOM_UTF8));\r\n end;\r\n end\r\n else\r\n FLogWasEmpty := False;\r\nend;\r\n\r\nprocedure TJclSimpleLog.Write(const Text: string; Indent: Integer = 0; KeepOpen: Boolean = true);\r\nvar\r\n S: string;\r\n UTF8S: TUTF8String;\r\n SL: TStringList;\r\n I: Integer;\r\n WasOpen: Boolean;\r\nbegin\r\n if LoggingActive then\r\n begin\r\n WasOpen := LogOpen;\r\n if not WasOpen then\r\n OpenLog;\r\n if LogOpen then\r\n begin\r\n SL := TStringList.Create;\r\n try\r\n SL.Text := Text;\r\n for I := 0 to SL.Count - 1 do\r\n begin\r\n S := StringOfChar(' ', Indent) + StrEnsureSuffix(NativeLineBreak, TrimRight(SL[I]));\r\n UTF8S := StringToUTF8(S);\r\n FileWrite(FLogFileHandle, UTF8S[1], Length(UTF8S));\r\n end;\r\n finally\r\n SL.Free;\r\n end;\r\n // Keep the logfile Open when it was opened before and the KeepOpen is active\r\n if Not (WasOpen and KeepOpen) then\r\n CloseLog;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJclSimpleLog.Write(Strings: TStrings; Indent: Integer = 0; KeepOpen: Boolean = true);\r\nbegin\r\n if Assigned(Strings) then\r\n Write(Strings.Text, Indent, KeepOpen);\r\nend;\r\n\r\nprocedure TJclSimpleLog.TimeWrite(const Text: string; Indent: Integer = 0; KeepOpen: Boolean = true);\r\nvar\r\n S: string;\r\n UTF8S: TUTF8String;\r\n SL: TStringList;\r\n I: Integer;\r\n WasOpen: Boolean;\r\nbegin\r\n if LoggingActive then\r\n begin\r\n WasOpen := LogOpen;\r\n if not LogOpen then\r\n OpenLog;\r\n if LogOpen then\r\n begin\r\n SL := TStringList.Create;\r\n try\r\n SL.Text := Text;\r\n for I := 0 to SL.Count - 1 do\r\n begin\r\n if DateTimeFormatStr = '' then\r\n S := DateTimeToStr(Now)+' : '+StringOfChar(' ', Indent) + StrEnsureSuffix(NativeLineBreak, TrimRight(SL[I]))\r\n else\r\n S := FormatDateTime( DateTimeFormatStr, Now)+' : '+StringOfChar(' ', Indent) + StrEnsureSuffix(NativeLineBreak, TrimRight(SL[I]));\r\n UTF8S := StringToUTF8(S);\r\n FileWrite(FLogFileHandle, UTF8S[1], Length(UTF8S));\r\n end;\r\n finally\r\n SL.Free;\r\n end;\r\n if Not WasOpen and Not KeepOpen then\r\n CloseLog;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJclSimpleLog.TimeWrite(Strings: TStrings; Indent: Integer = 0; KeepOpen: Boolean = true);\r\nbegin\r\n if Assigned(Strings) then\r\n TimeWrite(Strings.Text, Indent, KeepOpen);\r\nend;\r\n\r\nprocedure TJclSimpleLog.WriteStamp(SeparatorLen: Integer = 0; KeepOpen: Boolean = true);\r\nvar\r\n WasOpen: Boolean;\r\nbegin\r\n if SeparatorLen <= 0 then\r\n SeparatorLen := 40;\r\n if LoggingActive then\r\n begin\r\n WasOpen := LogOpen;\r\n if not LogOpen then\r\n begin\r\n OpenLog;\r\n if LogOpen and not FLogWasEmpty then\r\n Write(NativeLineBreak);\r\n end;\r\n if LogOpen then\r\n begin\r\n Write(StrRepeat('=', SeparatorLen), 0, True);\r\n if DateTimeFormatStr = '' then\r\n Write(Format('= %-*s =', [SeparatorLen - 4, DateTimeToStr(Now)]), 0, True)\r\n else\r\n Write(Format('= %-*s =', [SeparatorLen - 4, FormatDateTime( DateTimeFormatStr, Now)]), 0, True);\r\n Write(StrRepeat('=', SeparatorLen), 0, True);\r\n if Not WasOpen and Not KeepOpen then\r\n CloseLog;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure InitSimpleLog(const ALogFileName: string = ''; AOpenLog: Boolean = true);\r\nbegin\r\n if Assigned(SimpleLog) then\r\n FreeAndNil(SimpleLog);\r\n SimpleLog := TJclSimpleLog.Create(ALogFileName);\r\n if AOpenLog then\r\n SimpleLog.OpenLog;\r\nend;\r\n\r\nfunction TJclFormatSettings.GetCurrencyDecimals: Byte;\r\nbegin\r\n{$IFDEF RTL220_UP}\r\n Result := FormatSettings.CurrencyDecimals;\r\n{$ELSE}\r\n Result := SysUtils.CurrencyDecimals;\r\n{$ENDIF}\r\nend;\r\n\r\nfunction TJclFormatSettings.GetCurrencyFormat: Byte;\r\nbegin\r\n{$IFDEF RTL220_UP}\r\n Result := FormatSettings.CurrencyFormat;\r\n{$ELSE}\r\n Result := SysUtils.CurrencyFormat;\r\n{$ENDIF}\r\nend;\r\n\r\nfunction TJclFormatSettings.GetCurrencyString: string;\r\nbegin\r\n{$IFDEF RTL220_UP}\r\n Result := FormatSettings.CurrencyString;\r\n{$ELSE}\r\n Result := SysUtils.CurrencyString;\r\n{$ENDIF}\r\nend;\r\n\r\nfunction TJclFormatSettings.GetDateSeparator: Char;\r\nbegin\r\n{$IFDEF RTL220_UP}\r\n Result := FormatSettings.DateSeparator;\r\n{$ELSE}\r\n Result := SysUtils.DateSeparator;\r\n{$ENDIF}\r\nend;\r\n\r\nfunction TJclFormatSettings.GetDayNamesHighIndex: Integer;\r\nbegin\r\n{$IFDEF RTL220_UP}\r\n Result := High(FormatSettings.LongDayNames);\r\n{$ELSE}\r\n Result := High(SysUtils.LongDayNames);\r\n{$ENDIF}\r\nend;\r\n\r\nfunction TJclFormatSettings.GetDayNamesLowIndex: Integer;\r\nbegin\r\n{$IFDEF RTL220_UP}\r\n Result := Low(FormatSettings.LongDayNames);\r\n{$ELSE}\r\n Result := Low(SysUtils.LongDayNames);\r\n{$ENDIF}\r\nend;\r\n\r\nfunction TJclFormatSettings.GetDecimalSeparator: Char;\r\nbegin\r\n{$IFDEF RTL220_UP}\r\n Result := FormatSettings.DecimalSeparator;\r\n{$ELSE}\r\n Result := SysUtils.DecimalSeparator;\r\n{$ENDIF}\r\nend;\r\n\r\nfunction TJclFormatSettings.GetListSeparator: Char;\r\nbegin\r\n{$IFDEF RTL220_UP}\r\n Result := FormatSettings.ListSeparator;\r\n{$ELSE}\r\n Result := SysUtils.ListSeparator;\r\n{$ENDIF}\r\nend;\r\n\r\nfunction TJclFormatSettings.GetLongDateFormat: string;\r\nbegin\r\n{$IFDEF RTL220_UP}\r\n Result := FormatSettings.LongDateFormat;\r\n{$ELSE}\r\n Result := SysUtils.LongDateFormat;\r\n{$ENDIF}\r\nend;\r\n\r\n{ TJclFormatSettings }\r\n\r\nfunction TJclFormatSettings.GetLongDayNames(AIndex: Integer): string;\r\nbegin\r\n{$IFDEF RTL220_UP}\r\n Result := FormatSettings.LongDayNames[AIndex];\r\n{$ELSE}\r\n Result := SysUtils.LongDayNames[AIndex];\r\n{$ENDIF}\r\nend;\r\n\r\nfunction TJclFormatSettings.GetLongMonthNames(AIndex: Integer): string;\r\nbegin\r\n{$IFDEF RTL220_UP}\r\n Result := FormatSettings.LongMonthNames[AIndex];\r\n{$ELSE}\r\n Result := SysUtils.LongMonthNames[AIndex];\r\n{$ENDIF}\r\nend;\r\n\r\nfunction TJclFormatSettings.GetLongTimeFormat: string;\r\nbegin\r\n{$IFDEF RTL220_UP}\r\n Result := FormatSettings.LongTimeFormat;\r\n{$ELSE}\r\n Result := SysUtils.LongTimeFormat;\r\n{$ENDIF}\r\nend;\r\n\r\nfunction TJclFormatSettings.GetMonthNamesHighIndex: Integer;\r\nbegin\r\n{$IFDEF RTL220_UP}\r\n Result := High(FormatSettings.LongMonthNames);\r\n{$ELSE}\r\n Result := High(SysUtils.LongMonthNames);\r\n{$ENDIF}\r\nend;\r\n\r\nfunction TJclFormatSettings.GetMonthNamesLowIndex: Integer;\r\nbegin\r\n{$IFDEF RTL220_UP}\r\n Result := Low(FormatSettings.LongMonthNames);\r\n{$ELSE}\r\n Result := Low(SysUtils.LongMonthNames);\r\n{$ENDIF}\r\nend;\r\n\r\nfunction TJclFormatSettings.GetNegCurrFormat: Byte;\r\nbegin\r\n{$IFDEF RTL220_UP}\r\n Result := FormatSettings.NegCurrFormat;\r\n{$ELSE}\r\n Result := SysUtils.NegCurrFormat;\r\n{$ENDIF}\r\nend;\r\n\r\nfunction TJclFormatSettings.GetShortDateFormat: string;\r\nbegin\r\n{$IFDEF RTL220_UP}\r\n Result := FormatSettings.ShortDateFormat;\r\n{$ELSE}\r\n Result := SysUtils.ShortDateFormat;\r\n{$ENDIF}\r\nend;\r\n\r\nfunction TJclFormatSettings.GetShortDayNames(AIndex: Integer): string;\r\nbegin\r\n{$IFDEF RTL220_UP}\r\n Result := FormatSettings.ShortDayNames[AIndex];\r\n{$ELSE}\r\n Result := SysUtils.ShortDayNames[AIndex];\r\n{$ENDIF}\r\nend;\r\n\r\nfunction TJclFormatSettings.GetShortMonthNames(AIndex: Integer): string;\r\nbegin\r\n{$IFDEF RTL220_UP}\r\n Result := FormatSettings.ShortMonthNames[AIndex];\r\n{$ELSE}\r\n Result := SysUtils.ShortMonthNames[AIndex];\r\n{$ENDIF}\r\nend;\r\n\r\nfunction TJclFormatSettings.GetShortTimeFormat: string;\r\nbegin\r\n{$IFDEF RTL220_UP}\r\n Result := FormatSettings.ShortTimeFormat;\r\n{$ELSE}\r\n Result := SysUtils.ShortTimeFormat;\r\n{$ENDIF}\r\nend;\r\n\r\nfunction TJclFormatSettings.GetThousandSeparator: Char;\r\nbegin\r\n{$IFDEF RTL220_UP}\r\n Result := FormatSettings.ThousandSeparator;\r\n{$ELSE}\r\n Result := SysUtils.ThousandSeparator;\r\n{$ENDIF}\r\nend;\r\n\r\nfunction TJclFormatSettings.GetTimeAMString: string;\r\nbegin\r\n{$IFDEF RTL220_UP}\r\n Result := FormatSettings.TimeAMString;\r\n{$ELSE}\r\n Result := SysUtils.TimeAMString;\r\n{$ENDIF}\r\nend;\r\n\r\nfunction TJclFormatSettings.GetTimePMString: string;\r\nbegin\r\n{$IFDEF RTL220_UP}\r\n Result := FormatSettings.TimePMString;\r\n{$ELSE}\r\n Result := SysUtils.TimePMString;\r\n{$ENDIF}\r\nend;\r\n\r\nfunction TJclFormatSettings.GetTimeSeparator: Char;\r\nbegin\r\n{$IFDEF RTL220_UP}\r\n Result := FormatSettings.TimeSeparator;\r\n{$ELSE}\r\n Result := SysUtils.TimeSeparator;\r\n{$ENDIF}\r\nend;\r\n\r\nfunction TJclFormatSettings.GetTwoDigitYearCenturyWindow: Word;\r\nbegin\r\n{$IFDEF RTL220_UP}\r\n Result := FormatSettings.TwoDigitYearCenturyWindow;\r\n{$ELSE}\r\n Result := SysUtils.TwoDigitYearCenturyWindow;\r\n{$ENDIF}\r\nend;\r\n\r\nprocedure TJclFormatSettings.SetCurrencyDecimals(AValue: Byte);\r\nbegin\r\n{$IFDEF RTL220_UP}\r\n FormatSettings.CurrencyDecimals := AValue;\r\n{$ELSE}\r\n SysUtils.CurrencyDecimals := AValue;\r\n{$ENDIF}\r\nend;\r\n\r\nprocedure TJclFormatSettings.SetCurrencyFormat(const AValue: Byte);\r\nbegin\r\n{$IFDEF RTL220_UP}\r\n FormatSettings.CurrencyFormat := AValue;\r\n{$ELSE}\r\n SysUtils.CurrencyFormat := AValue;\r\n{$ENDIF}\r\nend;\r\n\r\nprocedure TJclFormatSettings.SetCurrencyString(AValue: string);\r\nbegin\r\n{$IFDEF RTL220_UP}\r\n FormatSettings.CurrencyString := AValue;\r\n{$ELSE}\r\n SysUtils.CurrencyString := AValue;\r\n{$ENDIF}\r\nend;\r\n\r\nprocedure TJclFormatSettings.SetDateSeparator(const AValue: Char);\r\nbegin\r\n{$IFDEF RTL220_UP}\r\n FormatSettings.DateSeparator := AValue;\r\n{$ELSE}\r\n SysUtils.DateSeparator := AValue;\r\n{$ENDIF}\r\nend;\r\n\r\nprocedure TJclFormatSettings.SetDecimalSeparator(AValue: Char);\r\nbegin\r\n{$IFDEF RTL220_UP}\r\n FormatSettings.DecimalSeparator := AValue;\r\n{$ELSE}\r\n SysUtils.DecimalSeparator := AValue;\r\n{$ENDIF}\r\nend;\r\n\r\nprocedure TJclFormatSettings.SetListSeparator(const AValue: Char);\r\nbegin\r\n{$IFDEF RTL220_UP}\r\n FormatSettings.ListSeparator := AValue;\r\n{$ELSE}\r\n SysUtils.ListSeparator := AValue;\r\n{$ENDIF}\r\nend;\r\n\r\nprocedure TJclFormatSettings.SetLongDateFormat(const AValue: string);\r\nbegin\r\n{$IFDEF RTL220_UP}\r\n FormatSettings.LongDateFormat := AValue;\r\n{$ELSE}\r\n SysUtils.LongDateFormat := AValue;\r\n{$ENDIF}\r\nend;\r\n\r\nprocedure TJclFormatSettings.SetLongTimeFormat(const AValue: string);\r\nbegin\r\n{$IFDEF RTL220_UP}\r\n FormatSettings.LongTimeFormat := AValue;\r\n{$ELSE}\r\n SysUtils.LongTimeFormat := AValue;\r\n{$ENDIF}\r\nend;\r\n\r\nprocedure TJclFormatSettings.SetNegCurrFormat(const AValue: Byte);\r\nbegin\r\n{$IFDEF RTL220_UP}\r\n FormatSettings.NegCurrFormat := AValue;\r\n{$ELSE}\r\n SysUtils.NegCurrFormat := AValue;\r\n{$ENDIF}\r\nend;\r\n\r\nprocedure TJclFormatSettings.SetShortDateFormat(AValue: string);\r\nbegin\r\n{$IFDEF RTL220_UP}\r\n FormatSettings.ShortDateFormat := AValue;\r\n{$ELSE}\r\n SysUtils.ShortDateFormat := AValue;\r\n{$ENDIF}\r\nend;\r\n\r\nprocedure TJclFormatSettings.SetShortTimeFormat(const AValue: string);\r\nbegin\r\n{$IFDEF RTL220_UP}\r\n FormatSettings.ShortTimeFormat := AValue;\r\n{$ELSE}\r\n SysUtils.ShortTimeFormat := AValue;\r\n{$ENDIF}\r\nend;\r\n\r\nprocedure TJclFormatSettings.SetThousandSeparator(AValue: Char);\r\nbegin\r\n{$IFDEF RTL220_UP}\r\n FormatSettings.TimeSeparator := AValue;\r\n{$ELSE}\r\n SysUtils.TimeSeparator := AValue;\r\n{$ENDIF}\r\nend;\r\n\r\nprocedure TJclFormatSettings.SetTimeAMString(const AValue: string);\r\nbegin\r\n{$IFDEF RTL220_UP}\r\n FormatSettings.TimeAMString := AValue;\r\n{$ELSE}\r\n SysUtils.TimeAMString := AValue;\r\n{$ENDIF}\r\nend;\r\n\r\nprocedure TJclFormatSettings.SetTimePMString(const AValue: string);\r\nbegin\r\n{$IFDEF RTL220_UP}\r\n FormatSettings.TimePMString := AValue;\r\n{$ELSE}\r\n SysUtils.TimePMString := AValue;\r\n{$ENDIF}\r\nend;\r\n\r\nprocedure TJclFormatSettings.SetTimeSeparator(const AValue: Char);\r\nbegin\r\n{$IFDEF RTL220_UP}\r\n FormatSettings.TimeSeparator := AValue;\r\n{$ELSE}\r\n SysUtils.TimeSeparator := AValue;\r\n{$ENDIF}\r\nend;\r\n\r\nprocedure TJclFormatSettings.SetTwoDigitYearCenturyWindow(const AValue: Word);\r\nbegin\r\n{$IFDEF RTL220_UP}\r\n FormatSettings.TwoDigitYearCenturyWindow:= AValue;\r\n{$ELSE}\r\n SysUtils.TwoDigitYearCenturyWindow:= AValue;\r\n{$ENDIF}\r\nend;\r\n\r\nfunction VarIsNullEmpty(const V: Variant): Boolean;\r\nbegin\r\n Result := VarIsNull(V) or VarIsEmpty(V);\r\nend;\r\n\r\nfunction VarIsNullEmptyBlank(const V: Variant): Boolean;\r\nbegin\r\n Result := VarIsNull(V) or VarIsEmpty(V) or (VarToStr(V) = '');\r\nend;\r\n\r\n\r\n\r\ninitialization\r\n SimpleLog := nil;\r\n {$IFDEF UNITVERSIONING}\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n {$ENDIF UNITVERSIONING}\r\n\r\nfinalization\r\n {$IFDEF UNITVERSIONING}\r\n UnregisterUnitVersion(HInstance);\r\n {$ENDIF UNITVERSIONING}\r\n {$IFDEF MSWINDOWS}\r\n {$IFDEF THREADSAFE}\r\n // The user must release shared memory blocks himself. We don't clean up his\r\n // memory leaks and make it impossible to release the shared memory in other\r\n // unit's finalization blocks.\r\n MMFFinalized := True;\r\n FreeAndNil(GlobalMMFHandleListCS);\r\n {$ENDIF THREADSAFE}\r\n {$ENDIF MSWINDOWS}\r\n if Assigned(SimpleLog) then\r\n FreeAndNil(SimpleLog);\r\nend.\r\n" }, { "path": "External/Jedi/Jcl/source/common/JclTrees.pas", "content": "{**************************************************************************************************}\r\n{ WARNING: JEDI preprocessor generated unit. Do not edit. }\r\n{**************************************************************************************************}\r\n\r\n{**************************************************************************************************}\r\n{ }\r\n{ Project JEDI Code Library (JCL) }\r\n{ }\r\n{ The contents of this file are subject to the Mozilla Public License Version 1.1 (the \"License\"); }\r\n{ you may not use this file except in compliance with the License. You may obtain a copy of the }\r\n{ License at http://www.mozilla.org/MPL/ }\r\n{ }\r\n{ Software distributed under the License is distributed on an \"AS IS\" basis, WITHOUT WARRANTY OF }\r\n{ ANY KIND, either express or implied. See the License for the specific language governing rights }\r\n{ and limitations under the License. }\r\n{ }\r\n{ The Original Code is JclTrees.pas. }\r\n{ }\r\n{ The Initial Developer of the Original Code is Florent Ouchet. Portions created by }\r\n{ Florent Ouchet are Copyright (C) Florent Ouchet = class\r\n public\r\n Value: T;\r\n {$IFDEF BCB}\r\n Children: TDynObjectArray;\r\n {$ELSE ~BCB}\r\n Children: array of TJclTreeNode;\r\n {$ENDIF ~BCB}\r\n ChildrenCount: Integer;\r\n Parent: TJclTreeNode;\r\n function IndexOfChild(AChild: TJclTreeNode): Integer;\r\n function IndexOfValue(const AItem: T; const AEqualityComparer: IJclEqualityComparer): Integer;\r\n end;\r\n\r\n TJclPreOrderTreeIterator = class;\r\n TJclPostOrderTreeIterator = class;\r\n\r\n TJclTree = class(TJclAbstractContainer, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclIntfCloneable, IJclCloneable, IJclPackable, IJclGrowable, IJclBaseContainer,\r\n IJclContainer, IJclFlatContainer, IJclEqualityComparer, IJclItemOwner,\r\n IJclCollection, IJclTree)\r\n protected\r\n type\r\n TTreeNode = TJclTreeNode;\r\n TPreOrderTreeIterator = TJclPreOrderTreeIterator;\r\n TPostOrderTreeIterator = TJclPostOrderTreeIterator;\r\n private\r\n FRoot: TTreeNode;\r\n FTraverseOrder: TJclTraverseOrder;\r\n protected\r\n procedure ExtractNode(var ANode: TTreeNode);\r\n procedure RemoveNode(var ANode: TTreeNode);\r\n function CloneNode(Node, Parent: TTreeNode): TTreeNode;\r\n function NodeContains(ANode: TTreeNode; const AItem: T): Boolean;\r\n procedure PackNode(ANode: TTreeNode);\r\n procedure AssignDataTo(Dest: TJclAbstractContainerBase); override;\r\n procedure AssignPropertiesTo(Dest: TJclAbstractContainerBase); override;\r\n public\r\n constructor Create(AOwnsItems: Boolean);\r\n destructor Destroy; override;\r\n { IJclPackable }\r\n procedure Pack; override;\r\n procedure SetCapacity(Value: Integer); override;\r\n { IJclCollection }\r\n function Add(const AItem: T): Boolean;\r\n function AddAll(const ACollection: IJclCollection): Boolean;\r\n procedure Clear;\r\n function CollectionEquals(const ACollection: IJclCollection): Boolean;\r\n function Contains(const AItem: T): Boolean;\r\n function ContainsAll(const ACollection: IJclCollection): Boolean;\r\n function Extract(const AItem: T): Boolean;\r\n function ExtractAll(const ACollection: IJclCollection): Boolean;\r\n function First: IJclIterator;\r\n function IsEmpty: Boolean;\r\n function Last: IJclIterator;\r\n function Remove(const AItem: T): Boolean;\r\n function RemoveAll(const ACollection: IJclCollection): Boolean;\r\n function RetainAll(const ACollection: IJclCollection): Boolean;\r\n function Size: Integer;\r\n {$IFDEF SUPPORTS_FOR_IN}\r\n function GetEnumerator: IJclIterator;\r\n {$ENDIF SUPPORTS_FOR_IN}\r\n { IJclTree }\r\n function GetRoot: IJclTreeIterator;\r\n function GetTraverseOrder: TJclTraverseOrder;\r\n procedure SetTraverseOrder(Value: TJclTraverseOrder);\r\n property Root: IJclTreeIterator read GetRoot;\r\n property TraverseOrder: TJclTraverseOrder read GetTraverseOrder write SetTraverseOrder;\r\n end;\r\n\r\n TJclTreeIterator = class(TJclAbstractIterator, IJclIterator, IJclTreeIterator)\r\n protected\r\n FCursor: TJclTree.TTreeNode;\r\n FStart: TItrStart;\r\n FOwnTree: TJclTree;\r\n FEqualityComparer: IJclEqualityComparer; // keep a reference of tree interface\r\n procedure AssignPropertiesTo(Dest: TJclAbstractIterator); override;\r\n function GetNextCursor: TJclTree.TTreeNode; virtual; abstract;\r\n // return next node on the same level\r\n function GetNextSibling: TJclTree.TTreeNode; virtual; abstract;\r\n function GetPreviousCursor: TJclTree.TTreeNode; virtual; abstract;\r\n public\r\n constructor Create(OwnTree: TJclTree; ACursor: TJclTree.TTreeNode; AValid: Boolean; AStart: TItrStart);\r\n { IJclIterator }\r\n function Add(const AItem: T): Boolean;\r\n procedure Extract;\r\n function GetItem: T;\r\n function HasNext: Boolean;\r\n function HasPrevious: Boolean;\r\n function Insert(const AItem: T): Boolean;\r\n function IteratorEquals(const AIterator: IJclIterator): Boolean;\r\n function Next: T;\r\n function NextIndex: Integer;\r\n function Previous: T;\r\n function PreviousIndex: Integer;\r\n procedure Remove;\r\n procedure Reset;\r\n procedure SetItem(const AItem: T);\r\n {$IFDEF SUPPORTS_FOR_IN}\r\n function MoveNext: Boolean;\r\n property Current: T read GetItem;\r\n {$ENDIF SUPPORTS_FOR_IN}\r\n { IJclTreeIterator }\r\n function AddChild(const AItem: T): Boolean;\r\n function ChildrenCount: Integer;\r\n procedure DeleteChild(Index: Integer);\r\n procedure DeleteChildren;\r\n procedure ExtractChild(Index: Integer);\r\n procedure ExtractChildren;\r\n function GetChild(Index: Integer): T;\r\n function HasChild(Index: Integer): Boolean;\r\n function HasParent: Boolean;\r\n function IndexOfChild(const AItem: T): Integer;\r\n function InsertChild(Index: Integer; const AItem: T): Boolean;\r\n function Parent: T;\r\n procedure SetChild(Index: Integer; const AItem: T);\r\n end;\r\n\r\n TJclPreOrderTreeIterator = class(TJclTreeIterator, IJclIterator, IJclTreeIterator, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclIntfCloneable, IJclCloneable)\r\n protected\r\n function CreateEmptyIterator: TJclAbstractIterator; override;\r\n function GetNextCursor: TJclTree.TTreeNode; override;\r\n function GetNextSibling: TJclTree.TTreeNode; override;\r\n function GetPreviousCursor: TJclTree.TTreeNode; override;\r\n end;\r\n\r\n TJclPostOrderTreeIterator = class(TJclTreeIterator, IJclIterator, IJclTreeIterator, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclIntfCloneable, IJclCloneable)\r\n protected\r\n function CreateEmptyIterator: TJclAbstractIterator; override;\r\n function GetNextCursor: TJclTree.TTreeNode; override;\r\n function GetNextSibling: TJclTree.TTreeNode; override;\r\n function GetPreviousCursor: TJclTree.TTreeNode; override;\r\n end;\r\n\r\n // E = External helper to compare items for equality\r\n TJclTreeE = class(TJclTree, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclIntfCloneable, IJclCloneable, IJclBaseContainer, IJclContainer, IJclItemOwner, IJclEqualityComparer,\r\n IJclCollection, IJclTree)\r\n private\r\n FEqualityComparer: IJclEqualityComparer;\r\n protected\r\n procedure AssignPropertiesTo(Dest: TJclAbstractContainerBase); override;\r\n function CreateEmptyContainer: TJclAbstractContainerBase; override;\r\n public\r\n constructor Create(const AEqualityComparer: IJclEqualityComparer; AOwnsItems: Boolean);\r\n { IJclEqualityComparer }\r\n function ItemsEqual(const A, B: T): Boolean; override;\r\n property EqualityComparer: IJclEqualityComparer read FEqualityComparer write FEqualityComparer;\r\n end;\r\n\r\n // F = Function to compare items for equality\r\n TJclTreeF = class(TJclTree, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclIntfCloneable, IJclCloneable, IJclBaseContainer, IJclContainer, IJclItemOwner, IJclEqualityComparer,\r\n IJclCollection, IJclTree)\r\n protected\r\n function CreateEmptyContainer: TJclAbstractContainerBase; override;\r\n public\r\n constructor Create(ACompare: TCompare; AOwnsItems: Boolean);\r\n end;\r\n\r\n // I = Items can compare themselves to an other for equality\r\n TJclTreeI> = class(TJclTree, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclIntfCloneable, IJclCloneable, IJclBaseContainer, IJclContainer, IJclItemOwner, IJclEqualityComparer,\r\n IJclCollection, IJclTree)\r\n protected\r\n function CreateEmptyContainer: TJclAbstractContainerBase; override;\r\n public\r\n { IJclEqualityComparer }\r\n function ItemsEqual(const A, B: T): Boolean; override;\r\n end;\r\n\r\n //DOM-IGNORE-END\r\n {$ENDIF SUPPORTS_GENERICS}\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jcl.svn.sourceforge.net/svnroot/jcl/tags/JCL-2.4-Build4571/jcl/source/common/JclTrees.pas $';\r\n Revision: '$Revision: 3739 $';\r\n Date: '$Date: 2012-02-21 18:37:18 +0100 (mar. 21 févr. 2012) $';\r\n LogPath: 'JCL\\source\\common';\r\n Extra: '';\r\n Data: nil\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n {$IFDEF HAS_UNITSCOPE}\r\n System.SysUtils;\r\n {$ELSE ~HAS_UNITSCOPE}\r\n SysUtils;\r\n {$ENDIF ~HAS_UNITSCOPE}\r\n\r\n//=== { TJclIntfTreeNode } =======================================================\r\n\r\nfunction TJclIntfTreeNode.IndexOfChild(AChild: TJclIntfTreeNode): Integer;\r\nbegin\r\n for Result := 0 to ChildrenCount - 1 do\r\n if Children[Result] = AChild then\r\n Exit;\r\n Result := -1;\r\nend;\r\n\r\nfunction TJclIntfTreeNode.IndexOfValue(const AInterface: IInterface;\r\n const AEqualityComparer: IJclIntfEqualityComparer): Integer;\r\nbegin\r\n for Result := 0 to ChildrenCount - 1 do\r\n if AEqualityComparer.ItemsEqual(TJclIntfTreeNode(Children[Result]).Value, AInterface) then\r\n Exit;\r\n Result := -1;\r\nend;\r\n\r\n//=== { TJclIntfTree } =======================================================\r\n\r\nconstructor TJclIntfTree.Create();\r\nbegin\r\n inherited Create();\r\n FTraverseOrder := toPreOrder;\r\nend;\r\n\r\ndestructor TJclIntfTree.Destroy;\r\nbegin\r\n FReadOnly := False;\r\n Clear;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJclIntfTree.Add(const AInterface: IInterface): Boolean;\r\nvar\r\n NewNode: TJclIntfTreeNode;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := AllowDefaultElements or not ItemsEqual(AInterface, nil);\r\n\r\n if Result then\r\n begin\r\n if FRoot <> nil then\r\n begin\r\n Result := (not Contains(AInterface)) or CheckDuplicate;\r\n if Result then\r\n begin\r\n if FRoot.ChildrenCount = Length(FRoot.Children) then\r\n SetLength(FRoot.Children, CalcGrowCapacity(Length(FRoot.Children), FRoot.ChildrenCount));\r\n if FRoot.ChildrenCount < Length(FRoot.Children) then\r\n begin\r\n NewNode := TJclIntfTreeNode.Create;\r\n NewNode.Value := AInterface;\r\n NewNode.Parent := FRoot;\r\n FRoot.Children[FRoot.ChildrenCount] := NewNode;\r\n Inc(FRoot.ChildrenCount);\r\n Inc(FSize);\r\n end\r\n else\r\n Result := False;\r\n end;\r\n end\r\n else\r\n begin\r\n FRoot := TJclIntfTreeNode.Create;\r\n FRoot.Value := AInterface;\r\n Inc(FSize);\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfTree.AddAll(const ACollection: IJclIntfCollection): Boolean;\r\nvar\r\n It: IJclIntfIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n Result := Add(It.Next) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclIntfTree.AssignDataTo(Dest: TJclAbstractContainerBase);\r\nvar\r\n ADest: TJclIntfTree;\r\n ACollection: IJclIntfCollection;\r\nbegin\r\n inherited AssignDataTo(Dest);\r\n if Dest is TJclIntfTree then\r\n begin\r\n ADest := TJclIntfTree(Dest);\r\n ADest.Clear;\r\n ADest.FSize := FSize;\r\n if FRoot <> nil then\r\n ADest.FRoot := CloneNode(FRoot, nil);\r\n end\r\n else\r\n if Supports(IInterface(Dest), IJclIntfCollection, ACollection) then\r\n begin\r\n ACollection.Clear;\r\n ACollection.AddAll(Self);\r\n end;\r\nend;\r\n\r\nprocedure TJclIntfTree.AssignPropertiesTo(Dest: TJclAbstractContainerBase);\r\nbegin\r\n inherited AssignPropertiesto(Dest);\r\n if Dest is TJclIntfTree then\r\n TJclIntfTree(Dest).FTraverseOrder := FTraverseOrder;\r\nend;\r\n\r\nprocedure TJclIntfTree.Clear;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FRoot <> nil then\r\n RemoveNode(FRoot);\r\n FSize := 0;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfTree.CloneNode(Node, Parent: TJclIntfTreeNode): TJclIntfTreeNode;\r\nvar\r\n Index: Integer;\r\nbegin\r\n Result := TJclIntfTreeNode.Create;\r\n Result.Value := Node.Value;\r\n Result.Parent := Parent;\r\n SetLength(Result.Children, Node.ChildrenCount);\r\n Result.ChildrenCount := Node.ChildrenCount;\r\n for Index := 0 to Node.ChildrenCount - 1 do\r\n Result.Children[Index] := CloneNode(TJclIntfTreeNode(Node.Children[Index]), Result); // recursive call\r\nend;\r\n\r\nfunction TJclIntfTree.CollectionEquals(const ACollection: IJclIntfCollection): Boolean;\r\nvar\r\n It, ItSelf: IJclIntfIterator;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n if FSize <> ACollection.Size then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n ItSelf := First;\r\n while ItSelf.HasNext do\r\n if not ItemsEqual(ItSelf.Next, It.Next) then\r\n begin\r\n Result := False;\r\n Break;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfTree.Contains(const AInterface: IInterface): Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FRoot <> nil then\r\n Result := NodeContains(FRoot, AInterface)\r\n else\r\n Result := False;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfTree.ContainsAll(const ACollection: IJclIntfCollection): Boolean;\r\nvar\r\n It: IJclIntfIterator;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := True;\r\n if ACollection = nil then\r\n Exit;\r\n It := ACollection.First;\r\n while Result and It.HasNext do\r\n Result := Contains(It.Next);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfTree.Extract(const AInterface: IInterface): Boolean;\r\nvar\r\n It: IJclIntfIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := FRoot <> nil;\r\n if Result then\r\n begin\r\n It := First;\r\n while It.HasNext do\r\n if ItemsEqual(It.Next, AInterface) then\r\n begin\r\n It.Extract;\r\n if RemoveSingleElement then\r\n Break;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfTree.ExtractAll(const ACollection: IJclIntfCollection): Boolean;\r\nvar\r\n It: IJclIntfIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n Result := Extract(It.Next) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclIntfTree.ExtractNode(var ANode: TJclIntfTreeNode);\r\nvar\r\n Index, ChildIndex, NewCapacity: Integer;\r\n Parent: TJclIntfTreeNode;\r\nbegin\r\n for Index := ANode.ChildrenCount - 1 downto 0 do\r\n {$IFDEF BCB}\r\n ExtractNode(TJclIntfTreeNode(ANode.Children[Index]));\r\n {$ELSE ~BCB}\r\n ExtractNode(ANode.Children[Index]);\r\n {$ENDIF ~BCB}\r\n Parent := ANode.Parent;\r\n if Parent <> nil then\r\n begin\r\n ChildIndex := Parent.IndexOfChild(ANode);\r\n for Index := ChildIndex + 1 to Parent.ChildrenCount - 1 do\r\n Parent.Children[Index - 1] := Parent.Children[Index];\r\n Dec(Parent.ChildrenCount);\r\n NewCapacity := CalcPackCapacity(Length(Parent.Children), Parent.ChildrenCount);\r\n if NewCapacity < Length(Parent.Children) then\r\n SetLength(Parent.Children, NewCapacity);\r\n FreeAndNil(ANode);\r\n end\r\n else\r\n begin\r\n FreeAndNil(ANode);\r\n FRoot := nil;\r\n end;\r\n Dec(FSize);\r\nend;\r\n\r\nfunction TJclIntfTree.First: IJclIntfIterator;\r\nvar\r\n Start: TJclIntfTreeNode;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Start := FRoot;\r\n case GetTraverseOrder of\r\n toPreOrder:\r\n Result := TJclPreOrderIntfTreeIterator.Create(Self, Start, False, isFirst);\r\n toPostOrder:\r\n begin\r\n if Start <> nil then\r\n while (Start.ChildrenCount > 0) do\r\n Start := TJclIntfTreeNode(Start.Children[0]);\r\n Result := TJclPostOrderIntfTreeIterator.Create(Self, Start, False, isFirst);\r\n end;\r\n else\r\n Result := nil;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\n{$IFDEF SUPPORTS_FOR_IN}\r\nfunction TJclIntfTree.GetEnumerator: IJclIntfIterator;\r\nbegin\r\n Result := First;\r\nend;\r\n{$ENDIF SUPPORTS_FOR_IN}\r\n\r\nfunction TJclIntfTree.GetRoot: IJclIntfTreeIterator;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n case GetTraverseOrder of\r\n toPreOrder:\r\n Result := TJclPreOrderIntfTreeIterator.Create(Self, FRoot, False, isRoot);\r\n toPostOrder:\r\n Result := TJclPostOrderIntfTreeIterator.Create(Self, FRoot, False, isRoot);\r\n else\r\n Result := nil;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfTree.GetTraverseOrder: TJclTraverseOrder;\r\nbegin\r\n Result := FTraverseOrder;\r\nend;\r\n\r\nfunction TJclIntfTree.IsEmpty: Boolean;\r\nbegin\r\n Result := FSize = 0;\r\nend;\r\n\r\nfunction TJclIntfTree.Last: IJclIntfIterator;\r\nvar\r\n Start: TJclIntfTreeNode;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Start := FRoot;\r\n case FTraverseOrder of\r\n toPreOrder:\r\n begin\r\n if Start <> nil then\r\n while Start.ChildrenCount > 0 do\r\n Start := TJclIntfTreeNode(Start.Children[Start.ChildrenCount - 1]);\r\n Result := TJclPreOrderIntfTreeIterator.Create(Self, Start, False, isLast);\r\n end;\r\n toPostOrder:\r\n Result := TJclPostOrderIntfTreeIterator.Create(Self, Start, False, isLast);\r\n else\r\n Result := nil;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfTree.NodeContains(ANode: TJclIntfTreeNode; const AInterface: IInterface): Boolean;\r\nvar\r\n Index: Integer;\r\nbegin\r\n Result := ItemsEqual(ANode.Value, AInterface);\r\n if not Result then\r\n for Index := 0 to ANode.ChildrenCount - 1 do\r\n begin\r\n Result := NodeContains(TJclIntfTreeNode(ANode.Children[Index]), AInterface);\r\n if Result then\r\n Break;\r\n end;\r\nend;\r\n\r\nprocedure TJclIntfTree.Pack;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FRoot <> nil then\r\n PackNode(FRoot);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclIntfTree.PackNode(ANode: TJclIntfTreeNode);\r\nvar\r\n Index: Integer;\r\nbegin\r\n SetLength(ANode.Children, ANode.ChildrenCount);\r\n for Index := 0 to ANode.ChildrenCount - 1 do\r\n PackNode(TJclIntfTreeNode(ANode.Children[Index]));\r\nend;\r\n\r\nfunction TJclIntfTree.Remove(const AInterface: IInterface): Boolean;\r\nvar\r\n Extracted: IInterface;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := Extract(AInterface);\r\n if Result then\r\n begin\r\n Extracted := AInterface;\r\n FreeObject(Extracted);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfTree.RemoveAll(const ACollection: IJclIntfCollection): Boolean;\r\nvar\r\n It: IJclIntfIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n Result := Remove(It.Next) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclIntfTree.RemoveNode(var ANode: TJclIntfTreeNode);\r\nvar\r\n Index, ChildIndex, NewCapacity: Integer;\r\n Parent: TJclIntfTreeNode;\r\nbegin\r\n for Index := ANode.ChildrenCount - 1 downto 0 do\r\n {$IFDEF BCB}\r\n RemoveNode(TJclIntfTreeNode(ANode.Children[Index]));\r\n {$ELSE ~BCB}\r\n RemoveNode(ANode.Children[Index]);\r\n {$ENDIF ~BCB}\r\n FreeObject(ANode.Value);\r\n Parent := ANode.Parent;\r\n if Parent <> nil then\r\n begin\r\n ChildIndex := Parent.IndexOfChild(ANode);\r\n for Index := ChildIndex + 1 to Parent.ChildrenCount - 1 do\r\n Parent.Children[Index - 1] := Parent.Children[Index];\r\n Dec(Parent.ChildrenCount);\r\n NewCapacity := CalcPackCapacity(Length(Parent.Children), Parent.ChildrenCount);\r\n if NewCapacity < Length(Parent.Children) then\r\n SetLength(Parent.Children, NewCapacity);\r\n FreeAndNil(ANode);\r\n end\r\n else\r\n begin\r\n FreeAndNil(ANode);\r\n FRoot := nil;\r\n end;\r\n Dec(FSize);\r\nend;\r\n\r\nfunction TJclIntfTree.RetainAll(const ACollection: IJclIntfCollection): Boolean;\r\nvar\r\n It: IJclIntfIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := First;\r\n while It.HasNext do\r\n if not ACollection.Contains(It.Next) then\r\n It.Remove;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclIntfTree.SetCapacity(Value: Integer);\r\nbegin\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nprocedure TJclIntfTree.SetTraverseOrder(Value: TJclTraverseOrder);\r\nbegin\r\n FTraverseOrder := Value;\r\nend;\r\n\r\nfunction TJclIntfTree.Size: Integer;\r\nbegin\r\n Result := FSize;\r\nend;\r\n\r\nfunction TJclIntfTree.CreateEmptyContainer: TJclAbstractContainerBase;\r\nbegin\r\n Result := TJclIntfTree.Create;\r\n AssignPropertiesTo(Result);\r\nend;\r\n\r\n//=== { TJclIntfTreeIterator } ===========================================================\r\n\r\nconstructor TJclIntfTreeIterator.Create(OwnTree: TJclIntfTree; ACursor: TJclIntfTreeNode; AValid: Boolean; AStart: TItrStart);\r\nbegin\r\n inherited Create(AValid);\r\n FCursor := ACursor;\r\n FOwnTree := OwnTree;\r\n FStart := AStart;\r\n FEqualityComparer := OwnTree as IJclIntfEqualityComparer;\r\nend;\r\n\r\nfunction TJclIntfTreeIterator.Add(const AInterface: IInterface): Boolean;\r\nvar\r\n ParentNode, NewNode: TJclIntfTreeNode;\r\nbegin\r\n if FOwnTree.ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n // add sibling or, if FCursor is root node, behave like TJclIntfTree.Add\r\n Result := (FCursor <> nil) and (FOwnTree.AllowDefaultElements or not FEqualityComparer.ItemsEqual(AInterface, nil))\r\n and ((not FOwnTree.Contains(AInterface)) or FOwnTree.CheckDuplicate);\r\n\r\n if Result then\r\n begin\r\n ParentNode := FCursor.Parent;\r\n if ParentNode = nil then\r\n ParentNode := FCursor;\r\n\r\n if ParentNode.ChildrenCount = Length(ParentNode.Children) then\r\n SetLength(ParentNode.Children, FOwnTree.CalcGrowCapacity(Length(ParentNode.Children), ParentNode.ChildrenCount));\r\n if ParentNode.ChildrenCount < Length(ParentNode.Children) then\r\n begin\r\n NewNode := TJclIntfTreeNode.Create;\r\n NewNode.Value := AInterface;\r\n NewNode.Parent := ParentNode;\r\n ParentNode.Children[ParentNode.ChildrenCount] := NewNode;\r\n Inc(ParentNode.ChildrenCount);\r\n Inc(FOwnTree.FSize);\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.WriteUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfTreeIterator.AddChild(const AInterface: IInterface): Boolean;\r\nvar\r\n NewNode: TJclIntfTreeNode;\r\nbegin\r\n if FOwnTree.ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := (FCursor <> nil) and (FOwnTree.AllowDefaultElements or not FEqualityComparer.ItemsEqual(AInterface, nil))\r\n and ((not FOwnTree.Contains(AInterface)) or FOwnTree.CheckDuplicate);\r\n\r\n if Result then\r\n begin\r\n if FCursor.ChildrenCount = Length(FCursor.Children) then\r\n SetLength(FCursor.Children, FOwnTree.CalcGrowCapacity(Length(FCursor.Children), FCursor.ChildrenCount));\r\n if FCursor.ChildrenCount < Length(FCursor.Children) then\r\n begin\r\n NewNode := TJclIntfTreeNode.Create;\r\n NewNode.Value := AInterface;\r\n NewNode.Parent := FCursor;\r\n FCursor.Children[FCursor.ChildrenCount] := NewNode;\r\n Inc(FCursor.ChildrenCount);\r\n Inc(FOwnTree.FSize);\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.WriteUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclIntfTreeIterator.AssignPropertiesTo(Dest: TJclAbstractIterator);\r\nvar\r\n ADest: TJclIntfTreeIterator;\r\nbegin\r\n inherited AssignPropertiesTo(Dest);\r\n if Dest is TJclIntfTreeIterator then\r\n begin\r\n ADest := TJclIntfTreeIterator(Dest);\r\n ADest.FCursor := FCursor;\r\n ADest.FOwnTree := FOwnTree;\r\n ADest.FEqualityComparer := FEqualityComparer;\r\n ADest.FStart := FStart;\r\n end;\r\nend;\r\n\r\nfunction TJclIntfTreeIterator.ChildrenCount: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FCursor <> nil then\r\n Result := FCursor.ChildrenCount\r\n else\r\n Result := 0;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclIntfTreeIterator.DeleteChild(Index: Integer);\r\nbegin\r\n if FOwnTree.ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if (FCursor <> nil) and (Index >= 0) and (Index < FCursor.ChildrenCount) then\r\n {$IFDEF BCB}\r\n FOwnTree.RemoveNode(TJclIntfTreeNode(FCursor.Children[Index]))\r\n {$ELSE ~BCB}\r\n FOwnTree.RemoveNode(FCursor.Children[Index])\r\n {$ENDIF ~BCB}\r\n else\r\n raise EJclOutOfBoundsError.Create;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.WriteUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclIntfTreeIterator.DeleteChildren;\r\nvar\r\n Index: Integer;\r\nbegin\r\n if FOwnTree.ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FCursor <> nil then\r\n begin\r\n for Index := FCursor.ChildrenCount - 1 downto 0 do\r\n {$IFDEF BCB}\r\n FOwnTree.RemoveNode(TJclIntfTreeNode(FCursor.Children[Index]));\r\n {$ELSE ~BCB}\r\n FOwnTree.RemoveNode(FCursor.Children[Index]);\r\n {$ENDIF ~BCB}\r\n SetLength(FCursor.Children, 0);\r\n FCursor.ChildrenCount := 0;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.WriteUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclIntfTreeIterator.Extract;\r\nvar\r\n OldCursor: TJclIntfTreeNode;\r\nbegin\r\n if FOwnTree.ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n CheckValid;\r\n Valid := False;\r\n OldCursor := FCursor;\r\n FCursor := GetNextSibling;\r\n if OldCursor <> nil then\r\n FOwnTree.ExtractNode(OldCursor);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.WriteUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclIntfTreeIterator.ExtractChild(Index: Integer);\r\nbegin\r\n if FOwnTree.ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if (FCursor <> nil) and (Index >= 0) and (Index < FCursor.ChildrenCount) then\r\n {$IFDEF BCB}\r\n FOwnTree.ExtractNode(TJclIntfTreeNode(FCursor.Children[Index]))\r\n {$ELSE ~BCB}\r\n FOwnTree.ExtractNode(FCursor.Children[Index])\r\n {$ENDIF ~BCB}\r\n else\r\n raise EJclOutOfBoundsError.Create;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.WriteUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclIntfTreeIterator.ExtractChildren;\r\nvar\r\n Index: Integer;\r\nbegin\r\n if FOwnTree.ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FCursor <> nil then\r\n begin\r\n for Index := FCursor.ChildrenCount - 1 downto 0 do\r\n {$IFDEF BCB}\r\n FOwnTree.ExtractNode(TJclIntfTreeNode(FCursor.Children[Index]));\r\n {$ELSE ~BCB}\r\n FOwnTree.ExtractNode(FCursor.Children[Index]);\r\n {$ENDIF ~BCB}\r\n SetLength(FCursor.Children, 0);\r\n FCursor.ChildrenCount := 0;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.WriteUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfTreeIterator.GetChild(Index: Integer): IInterface;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := nil;\r\n if (FCursor <> nil) and (Index >= 0) and (Index < FCursor.ChildrenCount) then\r\n FCursor := TJclIntfTreeNode(FCursor.Children[Index]);\r\n if FCursor <> nil then\r\n Result := FCursor.Value\r\n else\r\n if not FOwnTree.ReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfTreeIterator.GetObject: IInterface;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n CheckValid;\r\n Result := nil;\r\n if FCursor <> nil then\r\n Result := FCursor.Value\r\n else\r\n if not FOwnTree.ReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfTreeIterator.HasChild(Index: Integer): Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := (FCursor <> nil) and (Index >= 0) and (Index < FCursor.ChildrenCount);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfTreeIterator.HasNext: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Valid then\r\n Result := GetNextCursor <> nil\r\n else\r\n Result := FCursor <> nil;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfTreeIterator.HasParent: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := (FCursor <> nil) and (FCursor.Parent <> nil);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfTreeIterator.HasPrevious: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Valid then\r\n Result := GetPreviousCursor <> nil\r\n else\r\n Result := FCursor <> nil;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfTreeIterator.IndexOfChild(const AInterface: IInterface): Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FCursor <> nil then\r\n Result := FCursor.IndexOfValue(AInterface, FEqualityComparer)\r\n else\r\n Result := -1;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfTreeIterator.Insert(const AInterface: IInterface): Boolean;\r\nvar\r\n ParentNode, NewNode: TJclIntfTreeNode;\r\n Index, I: Integer;\r\nbegin\r\n if FOwnTree.ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n // insert sibling or, if FCursor is root node, behave like TJclIntfTree.Insert\r\n Result := (FCursor <> nil) and (FOwnTree.AllowDefaultElements or not FEqualityComparer.ItemsEqual(AInterface, nil))\r\n and ((not FOwnTree.Contains(AInterface)) or FOwnTree.CheckDuplicate);\r\n\r\n if Result then\r\n begin\r\n if FCursor.Parent <> nil then\r\n begin\r\n ParentNode := FCursor.Parent;\r\n Index := 0;\r\n while (Index < ParentNode.ChildrenCount) and (ParentNode.Children[Index] <> FCursor) do\r\n Inc(Index);\r\n end\r\n else\r\n begin\r\n ParentNode := FCursor;\r\n Index := 0;\r\n end;\r\n\r\n if ParentNode.ChildrenCount = Length(ParentNode.Children) then\r\n SetLength(ParentNode.Children, FOwnTree.CalcGrowCapacity(Length(ParentNode.Children), ParentNode.ChildrenCount));\r\n if ParentNode.ChildrenCount < Length(ParentNode.Children) then\r\n begin\r\n NewNode := TJclIntfTreeNode.Create;\r\n NewNode.Value := AInterface;\r\n NewNode.Parent := ParentNode;\r\n for I := ParentNode.ChildrenCount - 1 downto Index do\r\n ParentNode.Children[I + 1] := ParentNode.Children[I];\r\n ParentNode.Children[Index] := NewNode;\r\n Inc(ParentNode.ChildrenCount);\r\n Inc(FOwnTree.FSize);\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.WriteUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfTreeIterator.InsertChild(Index: Integer; const AInterface: IInterface): Boolean;\r\nvar\r\n NewNode: TJclIntfTreeNode;\r\n I: Integer;\r\nbegin\r\n if FOwnTree.ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n // insert sibling or, if FCursor is root node, behave like TJclIntfTree.Insert\r\n Result := (FCursor <> nil) and (FOwnTree.AllowDefaultElements or not FEqualityComparer.ItemsEqual(AInterface, nil))\r\n and ((not FOwnTree.Contains(AInterface)) or FOwnTree.CheckDuplicate);\r\n\r\n if Result then\r\n begin\r\n if FCursor.ChildrenCount = Length(FCursor.Children) then\r\n SetLength(FCursor.Children, FOwnTree.CalcGrowCapacity(Length(FCursor.Children), FCursor.ChildrenCount));\r\n if FCursor.ChildrenCount < Length(FCursor.Children) then\r\n begin\r\n NewNode := TJclIntfTreeNode.Create;\r\n NewNode.Value := AInterface;\r\n NewNode.Parent := FCursor;\r\n for I := FCursor.ChildrenCount - 1 downto Index do\r\n FCursor.Children[I + 1] := FCursor.Children[I];\r\n FCursor.Children[Index] := NewNode;\r\n Inc(FCursor.ChildrenCount);\r\n Inc(FOwnTree.FSize);\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.WriteUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfTreeIterator.IteratorEquals(const AIterator: IJclIntfIterator): Boolean;\r\nvar\r\n Obj: TObject;\r\n ItrObj: TJclIntfTreeIterator;\r\nbegin\r\n Result := False;\r\n if AIterator = nil then\r\n Exit;\r\n Obj := AIterator.GetIteratorReference;\r\n if Obj is TJclIntfTreeIterator then\r\n begin\r\n ItrObj := TJclIntfTreeIterator(Obj);\r\n Result := (FOwnTree = ItrObj.FOwnTree) and (FCursor = ItrObj.FCursor) and (Valid = ItrObj.Valid);\r\n end;\r\nend;\r\n\r\n{$IFDEF SUPPORTS_FOR_IN}\r\nfunction TJclIntfTreeIterator.MoveNext: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Valid then\r\n FCursor := GetNextCursor\r\n else\r\n Valid := True;\r\n Result := FCursor <> nil;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n{$ENDIF SUPPORTS_FOR_IN}\r\n\r\nfunction TJclIntfTreeIterator.Next: IInterface;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Valid then\r\n FCursor := GetNextCursor\r\n else\r\n Valid := True;\r\n Result := nil;\r\n if FCursor <> nil then\r\n Result := FCursor.Value\r\n else\r\n if not FOwnTree.ReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfTreeIterator.NextIndex: Integer;\r\nbegin\r\n // No index\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nfunction TJclIntfTreeIterator.Parent: IInterface;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := nil;\r\n if FCursor <> nil then\r\n FCursor := FCursor.Parent;\r\n if FCursor <> nil then\r\n Result := FCursor.Value\r\n else\r\n if not FOwnTree.ReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfTreeIterator.Previous: IInterface;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Valid then\r\n FCursor := GetPreviousCursor\r\n else\r\n Valid := True;\r\n Result := nil;\r\n if FCursor <> nil then\r\n Result := FCursor.Value\r\n else\r\n if not FOwnTree.ReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfTreeIterator.PreviousIndex: Integer;\r\nbegin\r\n // No index\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nprocedure TJclIntfTreeIterator.Remove;\r\nvar\r\n OldCursor: TJclIntfTreeNode;\r\nbegin\r\n if FOwnTree.ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n CheckValid;\r\n Valid := False;\r\n OldCursor := FCursor;\r\n FCursor := GetNextSibling;\r\n if OldCursor <> nil then\r\n FOwnTree.RemoveNode(OldCursor);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.WriteUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclIntfTreeIterator.Reset;\r\nvar\r\n NewCursor: TJclIntfTreeNode;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Valid := False;\r\n case FStart of\r\n isFirst:\r\n begin\r\n NewCursor := FCursor;\r\n while NewCursor <> nil do\r\n begin\r\n NewCursor := GetPreviousCursor;\r\n if NewCursor <> nil then\r\n FCursor := NewCursor;\r\n end;\r\n end;\r\n isLast:\r\n begin\r\n NewCursor := FCursor;\r\n while NewCursor <> nil do\r\n begin\r\n NewCursor := GetNextCursor;\r\n if NewCursor <> nil then\r\n FCursor := NewCursor;\r\n end;\r\n end;\r\n isRoot:\r\n begin\r\n while (FCursor <> nil) and (FCursor.Parent <> nil) do\r\n FCursor := FCursor.Parent;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclIntfTreeIterator.SetChild(Index: Integer; const AInterface: IInterface);\r\nbegin\r\n if FOwnTree.ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if (FCursor <> nil) and (Index >= 0) and (Index < FCursor.ChildrenCount) then\r\n TJclIntfTreeNode(FCursor.Children[Index]).Value := AInterface\r\n else\r\n raise EJclOutOfBoundsError.Create;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.WriteUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclIntfTreeIterator.SetObject(const AInterface: IInterface);\r\nbegin\r\n if FOwnTree.ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n CheckValid;\r\n if FCursor <> nil then\r\n begin\r\n FOwnTree.FreeObject(FCursor.Value);\r\n FCursor.Value := AInterface;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.WriteUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\n//=== { TJclPreOrderIntfTreeIterator } ===================================================\r\n\r\nfunction TJclPreOrderIntfTreeIterator.CreateEmptyIterator: TJclAbstractIterator;\r\nbegin\r\n Result := TJclPreOrderIntfTreeIterator.Create(FOwnTree, FCursor, Valid, FStart);\r\nend;\r\n\r\nfunction TJclPreOrderIntfTreeIterator.GetNextCursor: TJclIntfTreeNode;\r\nvar\r\n LastRet: TJclIntfTreeNode;\r\nbegin\r\n Result := FCursor;\r\n if Result = nil then\r\n Exit;\r\n LastRet := Result;\r\n if Result.ChildrenCount > 0 then\r\n Result := TJclIntfTreeNode(Result.Children[0])\r\n else\r\n begin\r\n Result := Result.Parent;\r\n while (Result <> nil) and (Result.IndexOfChild(LastRet) = (Result.ChildrenCount - 1)) do\r\n begin\r\n LastRet := Result;\r\n Result := Result.Parent;\r\n end;\r\n if Result <> nil then // not root = return successor\r\n Result := TJclIntfTreeNode(Result.Children[Result.IndexOfChild(LastRet) + 1]);\r\n end;\r\nend;\r\n\r\nfunction TJclPreOrderIntfTreeIterator.GetNextSibling: TJclIntfTreeNode;\r\nvar\r\n LastRet: TJclIntfTreeNode;\r\nbegin\r\n Result := FCursor;\r\n if Result = nil then\r\n Exit;\r\n LastRet := Result;\r\n\r\n Result := Result.Parent;\r\n while (Result <> nil) and (Result.IndexOfChild(LastRet) = (Result.ChildrenCount - 1)) do\r\n begin\r\n LastRet := Result;\r\n Result := Result.Parent;\r\n end;\r\n if Result <> nil then // not root = return successor\r\n Result := TJclIntfTreeNode(Result.Children[Result.IndexOfChild(LastRet) + 1]);\r\nend;\r\n\r\nfunction TJclPreOrderIntfTreeIterator.GetPreviousCursor: TJclIntfTreeNode;\r\nvar\r\n LastRet: TJclIntfTreeNode;\r\nbegin\r\n Result := FCursor;\r\n if Result = nil then\r\n Exit;\r\n LastRet := Result;\r\n Result := Result.Parent;\r\n if (Result <> nil) and (Result.IndexOfChild(LastRet) > 0) then\r\n // come from Right\r\n begin\r\n Result := TJclIntfTreeNode(Result.Children[Result.IndexOfChild(LastRet) - 1]);\r\n while (Result.ChildrenCount > 0) do // descend down the tree\r\n Result := TJclIntfTreeNode(Result.Children[Result.ChildrenCount - 1]);\r\n end;\r\nend;\r\n\r\n//=== { TJclPostOrderIntfTreeIterator } ==================================================\r\n\r\nfunction TJclPostOrderIntfTreeIterator.CreateEmptyIterator: TJclAbstractIterator;\r\nbegin\r\n Result := TJclPostOrderIntfTreeIterator.Create(FOwnTree, FCursor, Valid, FStart);\r\nend;\r\n\r\nfunction TJclPostOrderIntfTreeIterator.GetNextCursor: TJclIntfTreeNode;\r\nvar\r\n LastRet: TJclIntfTreeNode;\r\nbegin\r\n Result := FCursor;\r\n if Result = nil then\r\n Exit;\r\n LastRet := Result;\r\n Result := Result.Parent;\r\n if (Result <> nil) and (Result.IndexOfChild(LastRet) <> (Result.ChildrenCount - 1)) then\r\n begin\r\n Result := TJclIntfTreeNode(Result.Children[Result.IndexOfChild(LastRet) + 1]);\r\n while Result.ChildrenCount > 0 do\r\n Result := TJclIntfTreeNode(Result.Children[0]);\r\n end;\r\nend;\r\n\r\nfunction TJclPostOrderIntfTreeIterator.GetNextSibling: TJclIntfTreeNode;\r\nvar\r\n LastRet: TJclIntfTreeNode;\r\nbegin\r\n Result := FCursor;\r\n if Result = nil then\r\n Exit;\r\n LastRet := Result;\r\n Result := Result.Parent;\r\n\r\n if (Result <> nil) and (Result.IndexOfChild(LastRet) <> (Result.ChildrenCount - 1)) then\r\n begin\r\n Result := TJclIntfTreeNode(Result.Children[Result.IndexOfChild(LastRet) + 1]);\r\n while Result.ChildrenCount > 0 do\r\n Result := TJclIntfTreeNode(Result.Children[0]);\r\n end;\r\nend;\r\n\r\nfunction TJclPostOrderIntfTreeIterator.GetPreviousCursor: TJclIntfTreeNode;\r\nvar\r\n LastRet: TJclIntfTreeNode;\r\nbegin\r\n Result := FCursor;\r\n if Result = nil then\r\n Exit;\r\n if Result.ChildrenCount > 0 then\r\n Result := TJclIntfTreeNode(Result.Children[Result.ChildrenCount - 1])\r\n else\r\n begin\r\n LastRet := Result;\r\n Result := Result.Parent;\r\n while (Result <> nil) and (Result.IndexOfChild(LastRet) = 0) do\r\n begin\r\n LastRet := Result;\r\n Result := Result.Parent;\r\n end;\r\n if Result <> nil then // not root\r\n Result := TJclIntfTreeNode(Result.Children[Result.IndexOfChild(LastRet) - 1]);\r\n end;\r\nend;\r\n\r\n//=== { TJclAnsiStrTreeNode } =======================================================\r\n\r\nfunction TJclAnsiStrTreeNode.IndexOfChild(AChild: TJclAnsiStrTreeNode): Integer;\r\nbegin\r\n for Result := 0 to ChildrenCount - 1 do\r\n if Children[Result] = AChild then\r\n Exit;\r\n Result := -1;\r\nend;\r\n\r\nfunction TJclAnsiStrTreeNode.IndexOfValue(const AString: AnsiString;\r\n const AEqualityComparer: IJclAnsiStrEqualityComparer): Integer;\r\nbegin\r\n for Result := 0 to ChildrenCount - 1 do\r\n if AEqualityComparer.ItemsEqual(TJclAnsiStrTreeNode(Children[Result]).Value, AString) then\r\n Exit;\r\n Result := -1;\r\nend;\r\n\r\n//=== { TJclAnsiStrTree } =======================================================\r\n\r\nconstructor TJclAnsiStrTree.Create();\r\nbegin\r\n inherited Create();\r\n FTraverseOrder := toPreOrder;\r\nend;\r\n\r\ndestructor TJclAnsiStrTree.Destroy;\r\nbegin\r\n FReadOnly := False;\r\n Clear;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJclAnsiStrTree.Add(const AString: AnsiString): Boolean;\r\nvar\r\n NewNode: TJclAnsiStrTreeNode;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := AllowDefaultElements or not ItemsEqual(AString, '');\r\n\r\n if Result then\r\n begin\r\n if FRoot <> nil then\r\n begin\r\n Result := (not Contains(AString)) or CheckDuplicate;\r\n if Result then\r\n begin\r\n if FRoot.ChildrenCount = Length(FRoot.Children) then\r\n SetLength(FRoot.Children, CalcGrowCapacity(Length(FRoot.Children), FRoot.ChildrenCount));\r\n if FRoot.ChildrenCount < Length(FRoot.Children) then\r\n begin\r\n NewNode := TJclAnsiStrTreeNode.Create;\r\n NewNode.Value := AString;\r\n NewNode.Parent := FRoot;\r\n FRoot.Children[FRoot.ChildrenCount] := NewNode;\r\n Inc(FRoot.ChildrenCount);\r\n Inc(FSize);\r\n end\r\n else\r\n Result := False;\r\n end;\r\n end\r\n else\r\n begin\r\n FRoot := TJclAnsiStrTreeNode.Create;\r\n FRoot.Value := AString;\r\n Inc(FSize);\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclAnsiStrTree.AddAll(const ACollection: IJclAnsiStrCollection): Boolean;\r\nvar\r\n It: IJclAnsiStrIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n Result := Add(It.Next) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclAnsiStrTree.AssignDataTo(Dest: TJclAbstractContainerBase);\r\nvar\r\n ADest: TJclAnsiStrTree;\r\n ACollection: IJclAnsiStrCollection;\r\nbegin\r\n inherited AssignDataTo(Dest);\r\n if Dest is TJclAnsiStrTree then\r\n begin\r\n ADest := TJclAnsiStrTree(Dest);\r\n ADest.Clear;\r\n ADest.FSize := FSize;\r\n if FRoot <> nil then\r\n ADest.FRoot := CloneNode(FRoot, nil);\r\n end\r\n else\r\n if Supports(IInterface(Dest), IJclAnsiStrCollection, ACollection) then\r\n begin\r\n ACollection.Clear;\r\n ACollection.AddAll(Self);\r\n end;\r\nend;\r\n\r\nprocedure TJclAnsiStrTree.AssignPropertiesTo(Dest: TJclAbstractContainerBase);\r\nbegin\r\n inherited AssignPropertiesto(Dest);\r\n if Dest is TJclAnsiStrTree then\r\n TJclAnsiStrTree(Dest).FTraverseOrder := FTraverseOrder;\r\nend;\r\n\r\nprocedure TJclAnsiStrTree.Clear;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FRoot <> nil then\r\n RemoveNode(FRoot);\r\n FSize := 0;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclAnsiStrTree.CloneNode(Node, Parent: TJclAnsiStrTreeNode): TJclAnsiStrTreeNode;\r\nvar\r\n Index: Integer;\r\nbegin\r\n Result := TJclAnsiStrTreeNode.Create;\r\n Result.Value := Node.Value;\r\n Result.Parent := Parent;\r\n SetLength(Result.Children, Node.ChildrenCount);\r\n Result.ChildrenCount := Node.ChildrenCount;\r\n for Index := 0 to Node.ChildrenCount - 1 do\r\n Result.Children[Index] := CloneNode(TJclAnsiStrTreeNode(Node.Children[Index]), Result); // recursive call\r\nend;\r\n\r\nfunction TJclAnsiStrTree.CollectionEquals(const ACollection: IJclAnsiStrCollection): Boolean;\r\nvar\r\n It, ItSelf: IJclAnsiStrIterator;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n if FSize <> ACollection.Size then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n ItSelf := First;\r\n while ItSelf.HasNext do\r\n if not ItemsEqual(ItSelf.Next, It.Next) then\r\n begin\r\n Result := False;\r\n Break;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclAnsiStrTree.Contains(const AString: AnsiString): Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FRoot <> nil then\r\n Result := NodeContains(FRoot, AString)\r\n else\r\n Result := False;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclAnsiStrTree.ContainsAll(const ACollection: IJclAnsiStrCollection): Boolean;\r\nvar\r\n It: IJclAnsiStrIterator;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := True;\r\n if ACollection = nil then\r\n Exit;\r\n It := ACollection.First;\r\n while Result and It.HasNext do\r\n Result := Contains(It.Next);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclAnsiStrTree.Extract(const AString: AnsiString): Boolean;\r\nvar\r\n It: IJclAnsiStrIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := FRoot <> nil;\r\n if Result then\r\n begin\r\n It := First;\r\n while It.HasNext do\r\n if ItemsEqual(It.Next, AString) then\r\n begin\r\n It.Extract;\r\n if RemoveSingleElement then\r\n Break;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclAnsiStrTree.ExtractAll(const ACollection: IJclAnsiStrCollection): Boolean;\r\nvar\r\n It: IJclAnsiStrIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n Result := Extract(It.Next) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclAnsiStrTree.ExtractNode(var ANode: TJclAnsiStrTreeNode);\r\nvar\r\n Index, ChildIndex, NewCapacity: Integer;\r\n Parent: TJclAnsiStrTreeNode;\r\nbegin\r\n for Index := ANode.ChildrenCount - 1 downto 0 do\r\n {$IFDEF BCB}\r\n ExtractNode(TJclAnsiStrTreeNode(ANode.Children[Index]));\r\n {$ELSE ~BCB}\r\n ExtractNode(ANode.Children[Index]);\r\n {$ENDIF ~BCB}\r\n Parent := ANode.Parent;\r\n if Parent <> nil then\r\n begin\r\n ChildIndex := Parent.IndexOfChild(ANode);\r\n for Index := ChildIndex + 1 to Parent.ChildrenCount - 1 do\r\n Parent.Children[Index - 1] := Parent.Children[Index];\r\n Dec(Parent.ChildrenCount);\r\n NewCapacity := CalcPackCapacity(Length(Parent.Children), Parent.ChildrenCount);\r\n if NewCapacity < Length(Parent.Children) then\r\n SetLength(Parent.Children, NewCapacity);\r\n FreeAndNil(ANode);\r\n end\r\n else\r\n begin\r\n FreeAndNil(ANode);\r\n FRoot := nil;\r\n end;\r\n Dec(FSize);\r\nend;\r\n\r\nfunction TJclAnsiStrTree.First: IJclAnsiStrIterator;\r\nvar\r\n Start: TJclAnsiStrTreeNode;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Start := FRoot;\r\n case GetTraverseOrder of\r\n toPreOrder:\r\n Result := TJclPreOrderAnsiStrTreeIterator.Create(Self, Start, False, isFirst);\r\n toPostOrder:\r\n begin\r\n if Start <> nil then\r\n while (Start.ChildrenCount > 0) do\r\n Start := TJclAnsiStrTreeNode(Start.Children[0]);\r\n Result := TJclPostOrderAnsiStrTreeIterator.Create(Self, Start, False, isFirst);\r\n end;\r\n else\r\n Result := nil;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\n{$IFDEF SUPPORTS_FOR_IN}\r\nfunction TJclAnsiStrTree.GetEnumerator: IJclAnsiStrIterator;\r\nbegin\r\n Result := First;\r\nend;\r\n{$ENDIF SUPPORTS_FOR_IN}\r\n\r\nfunction TJclAnsiStrTree.GetRoot: IJclAnsiStrTreeIterator;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n case GetTraverseOrder of\r\n toPreOrder:\r\n Result := TJclPreOrderAnsiStrTreeIterator.Create(Self, FRoot, False, isRoot);\r\n toPostOrder:\r\n Result := TJclPostOrderAnsiStrTreeIterator.Create(Self, FRoot, False, isRoot);\r\n else\r\n Result := nil;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclAnsiStrTree.GetTraverseOrder: TJclTraverseOrder;\r\nbegin\r\n Result := FTraverseOrder;\r\nend;\r\n\r\nfunction TJclAnsiStrTree.IsEmpty: Boolean;\r\nbegin\r\n Result := FSize = 0;\r\nend;\r\n\r\nfunction TJclAnsiStrTree.Last: IJclAnsiStrIterator;\r\nvar\r\n Start: TJclAnsiStrTreeNode;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Start := FRoot;\r\n case FTraverseOrder of\r\n toPreOrder:\r\n begin\r\n if Start <> nil then\r\n while Start.ChildrenCount > 0 do\r\n Start := TJclAnsiStrTreeNode(Start.Children[Start.ChildrenCount - 1]);\r\n Result := TJclPreOrderAnsiStrTreeIterator.Create(Self, Start, False, isLast);\r\n end;\r\n toPostOrder:\r\n Result := TJclPostOrderAnsiStrTreeIterator.Create(Self, Start, False, isLast);\r\n else\r\n Result := nil;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclAnsiStrTree.NodeContains(ANode: TJclAnsiStrTreeNode; const AString: AnsiString): Boolean;\r\nvar\r\n Index: Integer;\r\nbegin\r\n Result := ItemsEqual(ANode.Value, AString);\r\n if not Result then\r\n for Index := 0 to ANode.ChildrenCount - 1 do\r\n begin\r\n Result := NodeContains(TJclAnsiStrTreeNode(ANode.Children[Index]), AString);\r\n if Result then\r\n Break;\r\n end;\r\nend;\r\n\r\nprocedure TJclAnsiStrTree.Pack;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FRoot <> nil then\r\n PackNode(FRoot);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclAnsiStrTree.PackNode(ANode: TJclAnsiStrTreeNode);\r\nvar\r\n Index: Integer;\r\nbegin\r\n SetLength(ANode.Children, ANode.ChildrenCount);\r\n for Index := 0 to ANode.ChildrenCount - 1 do\r\n PackNode(TJclAnsiStrTreeNode(ANode.Children[Index]));\r\nend;\r\n\r\nfunction TJclAnsiStrTree.Remove(const AString: AnsiString): Boolean;\r\nvar\r\n Extracted: AnsiString;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := Extract(AString);\r\n if Result then\r\n begin\r\n Extracted := AString;\r\n FreeString(Extracted);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclAnsiStrTree.RemoveAll(const ACollection: IJclAnsiStrCollection): Boolean;\r\nvar\r\n It: IJclAnsiStrIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n Result := Remove(It.Next) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclAnsiStrTree.RemoveNode(var ANode: TJclAnsiStrTreeNode);\r\nvar\r\n Index, ChildIndex, NewCapacity: Integer;\r\n Parent: TJclAnsiStrTreeNode;\r\nbegin\r\n for Index := ANode.ChildrenCount - 1 downto 0 do\r\n {$IFDEF BCB}\r\n RemoveNode(TJclAnsiStrTreeNode(ANode.Children[Index]));\r\n {$ELSE ~BCB}\r\n RemoveNode(ANode.Children[Index]);\r\n {$ENDIF ~BCB}\r\n FreeString(ANode.Value);\r\n Parent := ANode.Parent;\r\n if Parent <> nil then\r\n begin\r\n ChildIndex := Parent.IndexOfChild(ANode);\r\n for Index := ChildIndex + 1 to Parent.ChildrenCount - 1 do\r\n Parent.Children[Index - 1] := Parent.Children[Index];\r\n Dec(Parent.ChildrenCount);\r\n NewCapacity := CalcPackCapacity(Length(Parent.Children), Parent.ChildrenCount);\r\n if NewCapacity < Length(Parent.Children) then\r\n SetLength(Parent.Children, NewCapacity);\r\n FreeAndNil(ANode);\r\n end\r\n else\r\n begin\r\n FreeAndNil(ANode);\r\n FRoot := nil;\r\n end;\r\n Dec(FSize);\r\nend;\r\n\r\nfunction TJclAnsiStrTree.RetainAll(const ACollection: IJclAnsiStrCollection): Boolean;\r\nvar\r\n It: IJclAnsiStrIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := First;\r\n while It.HasNext do\r\n if not ACollection.Contains(It.Next) then\r\n It.Remove;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclAnsiStrTree.SetCapacity(Value: Integer);\r\nbegin\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nprocedure TJclAnsiStrTree.SetTraverseOrder(Value: TJclTraverseOrder);\r\nbegin\r\n FTraverseOrder := Value;\r\nend;\r\n\r\nfunction TJclAnsiStrTree.Size: Integer;\r\nbegin\r\n Result := FSize;\r\nend;\r\n\r\nfunction TJclAnsiStrTree.CreateEmptyContainer: TJclAbstractContainerBase;\r\nbegin\r\n Result := TJclAnsiStrTree.Create;\r\n AssignPropertiesTo(Result);\r\nend;\r\n\r\n//=== { TJclAnsiStrTreeIterator } ===========================================================\r\n\r\nconstructor TJclAnsiStrTreeIterator.Create(OwnTree: TJclAnsiStrTree; ACursor: TJclAnsiStrTreeNode; AValid: Boolean; AStart: TItrStart);\r\nbegin\r\n inherited Create(AValid);\r\n FCursor := ACursor;\r\n FOwnTree := OwnTree;\r\n FStart := AStart;\r\n FEqualityComparer := OwnTree as IJclAnsiStrEqualityComparer;\r\nend;\r\n\r\nfunction TJclAnsiStrTreeIterator.Add(const AString: AnsiString): Boolean;\r\nvar\r\n ParentNode, NewNode: TJclAnsiStrTreeNode;\r\nbegin\r\n if FOwnTree.ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n // add sibling or, if FCursor is root node, behave like TJclAnsiStrTree.Add\r\n Result := (FCursor <> nil) and (FOwnTree.AllowDefaultElements or not FEqualityComparer.ItemsEqual(AString, ''))\r\n and ((not FOwnTree.Contains(AString)) or FOwnTree.CheckDuplicate);\r\n\r\n if Result then\r\n begin\r\n ParentNode := FCursor.Parent;\r\n if ParentNode = nil then\r\n ParentNode := FCursor;\r\n\r\n if ParentNode.ChildrenCount = Length(ParentNode.Children) then\r\n SetLength(ParentNode.Children, FOwnTree.CalcGrowCapacity(Length(ParentNode.Children), ParentNode.ChildrenCount));\r\n if ParentNode.ChildrenCount < Length(ParentNode.Children) then\r\n begin\r\n NewNode := TJclAnsiStrTreeNode.Create;\r\n NewNode.Value := AString;\r\n NewNode.Parent := ParentNode;\r\n ParentNode.Children[ParentNode.ChildrenCount] := NewNode;\r\n Inc(ParentNode.ChildrenCount);\r\n Inc(FOwnTree.FSize);\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.WriteUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclAnsiStrTreeIterator.AddChild(const AString: AnsiString): Boolean;\r\nvar\r\n NewNode: TJclAnsiStrTreeNode;\r\nbegin\r\n if FOwnTree.ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := (FCursor <> nil) and (FOwnTree.AllowDefaultElements or not FEqualityComparer.ItemsEqual(AString, ''))\r\n and ((not FOwnTree.Contains(AString)) or FOwnTree.CheckDuplicate);\r\n\r\n if Result then\r\n begin\r\n if FCursor.ChildrenCount = Length(FCursor.Children) then\r\n SetLength(FCursor.Children, FOwnTree.CalcGrowCapacity(Length(FCursor.Children), FCursor.ChildrenCount));\r\n if FCursor.ChildrenCount < Length(FCursor.Children) then\r\n begin\r\n NewNode := TJclAnsiStrTreeNode.Create;\r\n NewNode.Value := AString;\r\n NewNode.Parent := FCursor;\r\n FCursor.Children[FCursor.ChildrenCount] := NewNode;\r\n Inc(FCursor.ChildrenCount);\r\n Inc(FOwnTree.FSize);\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.WriteUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclAnsiStrTreeIterator.AssignPropertiesTo(Dest: TJclAbstractIterator);\r\nvar\r\n ADest: TJclAnsiStrTreeIterator;\r\nbegin\r\n inherited AssignPropertiesTo(Dest);\r\n if Dest is TJclAnsiStrTreeIterator then\r\n begin\r\n ADest := TJclAnsiStrTreeIterator(Dest);\r\n ADest.FCursor := FCursor;\r\n ADest.FOwnTree := FOwnTree;\r\n ADest.FEqualityComparer := FEqualityComparer;\r\n ADest.FStart := FStart;\r\n end;\r\nend;\r\n\r\nfunction TJclAnsiStrTreeIterator.ChildrenCount: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FCursor <> nil then\r\n Result := FCursor.ChildrenCount\r\n else\r\n Result := 0;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclAnsiStrTreeIterator.DeleteChild(Index: Integer);\r\nbegin\r\n if FOwnTree.ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if (FCursor <> nil) and (Index >= 0) and (Index < FCursor.ChildrenCount) then\r\n {$IFDEF BCB}\r\n FOwnTree.RemoveNode(TJclAnsiStrTreeNode(FCursor.Children[Index]))\r\n {$ELSE ~BCB}\r\n FOwnTree.RemoveNode(FCursor.Children[Index])\r\n {$ENDIF ~BCB}\r\n else\r\n raise EJclOutOfBoundsError.Create;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.WriteUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclAnsiStrTreeIterator.DeleteChildren;\r\nvar\r\n Index: Integer;\r\nbegin\r\n if FOwnTree.ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FCursor <> nil then\r\n begin\r\n for Index := FCursor.ChildrenCount - 1 downto 0 do\r\n {$IFDEF BCB}\r\n FOwnTree.RemoveNode(TJclAnsiStrTreeNode(FCursor.Children[Index]));\r\n {$ELSE ~BCB}\r\n FOwnTree.RemoveNode(FCursor.Children[Index]);\r\n {$ENDIF ~BCB}\r\n SetLength(FCursor.Children, 0);\r\n FCursor.ChildrenCount := 0;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.WriteUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclAnsiStrTreeIterator.Extract;\r\nvar\r\n OldCursor: TJclAnsiStrTreeNode;\r\nbegin\r\n if FOwnTree.ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n CheckValid;\r\n Valid := False;\r\n OldCursor := FCursor;\r\n FCursor := GetNextSibling;\r\n if OldCursor <> nil then\r\n FOwnTree.ExtractNode(OldCursor);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.WriteUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclAnsiStrTreeIterator.ExtractChild(Index: Integer);\r\nbegin\r\n if FOwnTree.ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if (FCursor <> nil) and (Index >= 0) and (Index < FCursor.ChildrenCount) then\r\n {$IFDEF BCB}\r\n FOwnTree.ExtractNode(TJclAnsiStrTreeNode(FCursor.Children[Index]))\r\n {$ELSE ~BCB}\r\n FOwnTree.ExtractNode(FCursor.Children[Index])\r\n {$ENDIF ~BCB}\r\n else\r\n raise EJclOutOfBoundsError.Create;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.WriteUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclAnsiStrTreeIterator.ExtractChildren;\r\nvar\r\n Index: Integer;\r\nbegin\r\n if FOwnTree.ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FCursor <> nil then\r\n begin\r\n for Index := FCursor.ChildrenCount - 1 downto 0 do\r\n {$IFDEF BCB}\r\n FOwnTree.ExtractNode(TJclAnsiStrTreeNode(FCursor.Children[Index]));\r\n {$ELSE ~BCB}\r\n FOwnTree.ExtractNode(FCursor.Children[Index]);\r\n {$ENDIF ~BCB}\r\n SetLength(FCursor.Children, 0);\r\n FCursor.ChildrenCount := 0;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.WriteUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclAnsiStrTreeIterator.GetChild(Index: Integer): AnsiString;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := '';\r\n if (FCursor <> nil) and (Index >= 0) and (Index < FCursor.ChildrenCount) then\r\n FCursor := TJclAnsiStrTreeNode(FCursor.Children[Index]);\r\n if FCursor <> nil then\r\n Result := FCursor.Value\r\n else\r\n if not FOwnTree.ReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclAnsiStrTreeIterator.GetString: AnsiString;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n CheckValid;\r\n Result := '';\r\n if FCursor <> nil then\r\n Result := FCursor.Value\r\n else\r\n if not FOwnTree.ReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclAnsiStrTreeIterator.HasChild(Index: Integer): Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := (FCursor <> nil) and (Index >= 0) and (Index < FCursor.ChildrenCount);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclAnsiStrTreeIterator.HasNext: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Valid then\r\n Result := GetNextCursor <> nil\r\n else\r\n Result := FCursor <> nil;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclAnsiStrTreeIterator.HasParent: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := (FCursor <> nil) and (FCursor.Parent <> nil);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclAnsiStrTreeIterator.HasPrevious: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Valid then\r\n Result := GetPreviousCursor <> nil\r\n else\r\n Result := FCursor <> nil;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclAnsiStrTreeIterator.IndexOfChild(const AString: AnsiString): Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FCursor <> nil then\r\n Result := FCursor.IndexOfValue(AString, FEqualityComparer)\r\n else\r\n Result := -1;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclAnsiStrTreeIterator.Insert(const AString: AnsiString): Boolean;\r\nvar\r\n ParentNode, NewNode: TJclAnsiStrTreeNode;\r\n Index, I: Integer;\r\nbegin\r\n if FOwnTree.ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n // insert sibling or, if FCursor is root node, behave like TJclAnsiStrTree.Insert\r\n Result := (FCursor <> nil) and (FOwnTree.AllowDefaultElements or not FEqualityComparer.ItemsEqual(AString, ''))\r\n and ((not FOwnTree.Contains(AString)) or FOwnTree.CheckDuplicate);\r\n\r\n if Result then\r\n begin\r\n if FCursor.Parent <> nil then\r\n begin\r\n ParentNode := FCursor.Parent;\r\n Index := 0;\r\n while (Index < ParentNode.ChildrenCount) and (ParentNode.Children[Index] <> FCursor) do\r\n Inc(Index);\r\n end\r\n else\r\n begin\r\n ParentNode := FCursor;\r\n Index := 0;\r\n end;\r\n\r\n if ParentNode.ChildrenCount = Length(ParentNode.Children) then\r\n SetLength(ParentNode.Children, FOwnTree.CalcGrowCapacity(Length(ParentNode.Children), ParentNode.ChildrenCount));\r\n if ParentNode.ChildrenCount < Length(ParentNode.Children) then\r\n begin\r\n NewNode := TJclAnsiStrTreeNode.Create;\r\n NewNode.Value := AString;\r\n NewNode.Parent := ParentNode;\r\n for I := ParentNode.ChildrenCount - 1 downto Index do\r\n ParentNode.Children[I + 1] := ParentNode.Children[I];\r\n ParentNode.Children[Index] := NewNode;\r\n Inc(ParentNode.ChildrenCount);\r\n Inc(FOwnTree.FSize);\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.WriteUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclAnsiStrTreeIterator.InsertChild(Index: Integer; const AString: AnsiString): Boolean;\r\nvar\r\n NewNode: TJclAnsiStrTreeNode;\r\n I: Integer;\r\nbegin\r\n if FOwnTree.ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n // insert sibling or, if FCursor is root node, behave like TJclAnsiStrTree.Insert\r\n Result := (FCursor <> nil) and (FOwnTree.AllowDefaultElements or not FEqualityComparer.ItemsEqual(AString, ''))\r\n and ((not FOwnTree.Contains(AString)) or FOwnTree.CheckDuplicate);\r\n\r\n if Result then\r\n begin\r\n if FCursor.ChildrenCount = Length(FCursor.Children) then\r\n SetLength(FCursor.Children, FOwnTree.CalcGrowCapacity(Length(FCursor.Children), FCursor.ChildrenCount));\r\n if FCursor.ChildrenCount < Length(FCursor.Children) then\r\n begin\r\n NewNode := TJclAnsiStrTreeNode.Create;\r\n NewNode.Value := AString;\r\n NewNode.Parent := FCursor;\r\n for I := FCursor.ChildrenCount - 1 downto Index do\r\n FCursor.Children[I + 1] := FCursor.Children[I];\r\n FCursor.Children[Index] := NewNode;\r\n Inc(FCursor.ChildrenCount);\r\n Inc(FOwnTree.FSize);\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.WriteUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclAnsiStrTreeIterator.IteratorEquals(const AIterator: IJclAnsiStrIterator): Boolean;\r\nvar\r\n Obj: TObject;\r\n ItrObj: TJclAnsiStrTreeIterator;\r\nbegin\r\n Result := False;\r\n if AIterator = nil then\r\n Exit;\r\n Obj := AIterator.GetIteratorReference;\r\n if Obj is TJclAnsiStrTreeIterator then\r\n begin\r\n ItrObj := TJclAnsiStrTreeIterator(Obj);\r\n Result := (FOwnTree = ItrObj.FOwnTree) and (FCursor = ItrObj.FCursor) and (Valid = ItrObj.Valid);\r\n end;\r\nend;\r\n\r\n{$IFDEF SUPPORTS_FOR_IN}\r\nfunction TJclAnsiStrTreeIterator.MoveNext: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Valid then\r\n FCursor := GetNextCursor\r\n else\r\n Valid := True;\r\n Result := FCursor <> nil;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n{$ENDIF SUPPORTS_FOR_IN}\r\n\r\nfunction TJclAnsiStrTreeIterator.Next: AnsiString;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Valid then\r\n FCursor := GetNextCursor\r\n else\r\n Valid := True;\r\n Result := '';\r\n if FCursor <> nil then\r\n Result := FCursor.Value\r\n else\r\n if not FOwnTree.ReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclAnsiStrTreeIterator.NextIndex: Integer;\r\nbegin\r\n // No index\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nfunction TJclAnsiStrTreeIterator.Parent: AnsiString;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := '';\r\n if FCursor <> nil then\r\n FCursor := FCursor.Parent;\r\n if FCursor <> nil then\r\n Result := FCursor.Value\r\n else\r\n if not FOwnTree.ReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclAnsiStrTreeIterator.Previous: AnsiString;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Valid then\r\n FCursor := GetPreviousCursor\r\n else\r\n Valid := True;\r\n Result := '';\r\n if FCursor <> nil then\r\n Result := FCursor.Value\r\n else\r\n if not FOwnTree.ReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclAnsiStrTreeIterator.PreviousIndex: Integer;\r\nbegin\r\n // No index\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nprocedure TJclAnsiStrTreeIterator.Remove;\r\nvar\r\n OldCursor: TJclAnsiStrTreeNode;\r\nbegin\r\n if FOwnTree.ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n CheckValid;\r\n Valid := False;\r\n OldCursor := FCursor;\r\n FCursor := GetNextSibling;\r\n if OldCursor <> nil then\r\n FOwnTree.RemoveNode(OldCursor);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.WriteUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclAnsiStrTreeIterator.Reset;\r\nvar\r\n NewCursor: TJclAnsiStrTreeNode;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Valid := False;\r\n case FStart of\r\n isFirst:\r\n begin\r\n NewCursor := FCursor;\r\n while NewCursor <> nil do\r\n begin\r\n NewCursor := GetPreviousCursor;\r\n if NewCursor <> nil then\r\n FCursor := NewCursor;\r\n end;\r\n end;\r\n isLast:\r\n begin\r\n NewCursor := FCursor;\r\n while NewCursor <> nil do\r\n begin\r\n NewCursor := GetNextCursor;\r\n if NewCursor <> nil then\r\n FCursor := NewCursor;\r\n end;\r\n end;\r\n isRoot:\r\n begin\r\n while (FCursor <> nil) and (FCursor.Parent <> nil) do\r\n FCursor := FCursor.Parent;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclAnsiStrTreeIterator.SetChild(Index: Integer; const AString: AnsiString);\r\nbegin\r\n if FOwnTree.ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if (FCursor <> nil) and (Index >= 0) and (Index < FCursor.ChildrenCount) then\r\n TJclAnsiStrTreeNode(FCursor.Children[Index]).Value := AString\r\n else\r\n raise EJclOutOfBoundsError.Create;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.WriteUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclAnsiStrTreeIterator.SetString(const AString: AnsiString);\r\nbegin\r\n if FOwnTree.ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n CheckValid;\r\n if FCursor <> nil then\r\n begin\r\n FOwnTree.FreeString(FCursor.Value);\r\n FCursor.Value := AString;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.WriteUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\n//=== { TJclPreOrderAnsiStrTreeIterator } ===================================================\r\n\r\nfunction TJclPreOrderAnsiStrTreeIterator.CreateEmptyIterator: TJclAbstractIterator;\r\nbegin\r\n Result := TJclPreOrderAnsiStrTreeIterator.Create(FOwnTree, FCursor, Valid, FStart);\r\nend;\r\n\r\nfunction TJclPreOrderAnsiStrTreeIterator.GetNextCursor: TJclAnsiStrTreeNode;\r\nvar\r\n LastRet: TJclAnsiStrTreeNode;\r\nbegin\r\n Result := FCursor;\r\n if Result = nil then\r\n Exit;\r\n LastRet := Result;\r\n if Result.ChildrenCount > 0 then\r\n Result := TJclAnsiStrTreeNode(Result.Children[0])\r\n else\r\n begin\r\n Result := Result.Parent;\r\n while (Result <> nil) and (Result.IndexOfChild(LastRet) = (Result.ChildrenCount - 1)) do\r\n begin\r\n LastRet := Result;\r\n Result := Result.Parent;\r\n end;\r\n if Result <> nil then // not root = return successor\r\n Result := TJclAnsiStrTreeNode(Result.Children[Result.IndexOfChild(LastRet) + 1]);\r\n end;\r\nend;\r\n\r\nfunction TJclPreOrderAnsiStrTreeIterator.GetNextSibling: TJclAnsiStrTreeNode;\r\nvar\r\n LastRet: TJclAnsiStrTreeNode;\r\nbegin\r\n Result := FCursor;\r\n if Result = nil then\r\n Exit;\r\n LastRet := Result;\r\n\r\n Result := Result.Parent;\r\n while (Result <> nil) and (Result.IndexOfChild(LastRet) = (Result.ChildrenCount - 1)) do\r\n begin\r\n LastRet := Result;\r\n Result := Result.Parent;\r\n end;\r\n if Result <> nil then // not root = return successor\r\n Result := TJclAnsiStrTreeNode(Result.Children[Result.IndexOfChild(LastRet) + 1]);\r\nend;\r\n\r\nfunction TJclPreOrderAnsiStrTreeIterator.GetPreviousCursor: TJclAnsiStrTreeNode;\r\nvar\r\n LastRet: TJclAnsiStrTreeNode;\r\nbegin\r\n Result := FCursor;\r\n if Result = nil then\r\n Exit;\r\n LastRet := Result;\r\n Result := Result.Parent;\r\n if (Result <> nil) and (Result.IndexOfChild(LastRet) > 0) then\r\n // come from Right\r\n begin\r\n Result := TJclAnsiStrTreeNode(Result.Children[Result.IndexOfChild(LastRet) - 1]);\r\n while (Result.ChildrenCount > 0) do // descend down the tree\r\n Result := TJclAnsiStrTreeNode(Result.Children[Result.ChildrenCount - 1]);\r\n end;\r\nend;\r\n\r\n//=== { TJclPostOrderAnsiStrTreeIterator } ==================================================\r\n\r\nfunction TJclPostOrderAnsiStrTreeIterator.CreateEmptyIterator: TJclAbstractIterator;\r\nbegin\r\n Result := TJclPostOrderAnsiStrTreeIterator.Create(FOwnTree, FCursor, Valid, FStart);\r\nend;\r\n\r\nfunction TJclPostOrderAnsiStrTreeIterator.GetNextCursor: TJclAnsiStrTreeNode;\r\nvar\r\n LastRet: TJclAnsiStrTreeNode;\r\nbegin\r\n Result := FCursor;\r\n if Result = nil then\r\n Exit;\r\n LastRet := Result;\r\n Result := Result.Parent;\r\n if (Result <> nil) and (Result.IndexOfChild(LastRet) <> (Result.ChildrenCount - 1)) then\r\n begin\r\n Result := TJclAnsiStrTreeNode(Result.Children[Result.IndexOfChild(LastRet) + 1]);\r\n while Result.ChildrenCount > 0 do\r\n Result := TJclAnsiStrTreeNode(Result.Children[0]);\r\n end;\r\nend;\r\n\r\nfunction TJclPostOrderAnsiStrTreeIterator.GetNextSibling: TJclAnsiStrTreeNode;\r\nvar\r\n LastRet: TJclAnsiStrTreeNode;\r\nbegin\r\n Result := FCursor;\r\n if Result = nil then\r\n Exit;\r\n LastRet := Result;\r\n Result := Result.Parent;\r\n\r\n if (Result <> nil) and (Result.IndexOfChild(LastRet) <> (Result.ChildrenCount - 1)) then\r\n begin\r\n Result := TJclAnsiStrTreeNode(Result.Children[Result.IndexOfChild(LastRet) + 1]);\r\n while Result.ChildrenCount > 0 do\r\n Result := TJclAnsiStrTreeNode(Result.Children[0]);\r\n end;\r\nend;\r\n\r\nfunction TJclPostOrderAnsiStrTreeIterator.GetPreviousCursor: TJclAnsiStrTreeNode;\r\nvar\r\n LastRet: TJclAnsiStrTreeNode;\r\nbegin\r\n Result := FCursor;\r\n if Result = nil then\r\n Exit;\r\n if Result.ChildrenCount > 0 then\r\n Result := TJclAnsiStrTreeNode(Result.Children[Result.ChildrenCount - 1])\r\n else\r\n begin\r\n LastRet := Result;\r\n Result := Result.Parent;\r\n while (Result <> nil) and (Result.IndexOfChild(LastRet) = 0) do\r\n begin\r\n LastRet := Result;\r\n Result := Result.Parent;\r\n end;\r\n if Result <> nil then // not root\r\n Result := TJclAnsiStrTreeNode(Result.Children[Result.IndexOfChild(LastRet) - 1]);\r\n end;\r\nend;\r\n\r\n//=== { TJclWideStrTreeNode } =======================================================\r\n\r\nfunction TJclWideStrTreeNode.IndexOfChild(AChild: TJclWideStrTreeNode): Integer;\r\nbegin\r\n for Result := 0 to ChildrenCount - 1 do\r\n if Children[Result] = AChild then\r\n Exit;\r\n Result := -1;\r\nend;\r\n\r\nfunction TJclWideStrTreeNode.IndexOfValue(const AString: WideString;\r\n const AEqualityComparer: IJclWideStrEqualityComparer): Integer;\r\nbegin\r\n for Result := 0 to ChildrenCount - 1 do\r\n if AEqualityComparer.ItemsEqual(TJclWideStrTreeNode(Children[Result]).Value, AString) then\r\n Exit;\r\n Result := -1;\r\nend;\r\n\r\n//=== { TJclWideStrTree } =======================================================\r\n\r\nconstructor TJclWideStrTree.Create();\r\nbegin\r\n inherited Create();\r\n FTraverseOrder := toPreOrder;\r\nend;\r\n\r\ndestructor TJclWideStrTree.Destroy;\r\nbegin\r\n FReadOnly := False;\r\n Clear;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJclWideStrTree.Add(const AString: WideString): Boolean;\r\nvar\r\n NewNode: TJclWideStrTreeNode;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := AllowDefaultElements or not ItemsEqual(AString, '');\r\n\r\n if Result then\r\n begin\r\n if FRoot <> nil then\r\n begin\r\n Result := (not Contains(AString)) or CheckDuplicate;\r\n if Result then\r\n begin\r\n if FRoot.ChildrenCount = Length(FRoot.Children) then\r\n SetLength(FRoot.Children, CalcGrowCapacity(Length(FRoot.Children), FRoot.ChildrenCount));\r\n if FRoot.ChildrenCount < Length(FRoot.Children) then\r\n begin\r\n NewNode := TJclWideStrTreeNode.Create;\r\n NewNode.Value := AString;\r\n NewNode.Parent := FRoot;\r\n FRoot.Children[FRoot.ChildrenCount] := NewNode;\r\n Inc(FRoot.ChildrenCount);\r\n Inc(FSize);\r\n end\r\n else\r\n Result := False;\r\n end;\r\n end\r\n else\r\n begin\r\n FRoot := TJclWideStrTreeNode.Create;\r\n FRoot.Value := AString;\r\n Inc(FSize);\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclWideStrTree.AddAll(const ACollection: IJclWideStrCollection): Boolean;\r\nvar\r\n It: IJclWideStrIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n Result := Add(It.Next) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclWideStrTree.AssignDataTo(Dest: TJclAbstractContainerBase);\r\nvar\r\n ADest: TJclWideStrTree;\r\n ACollection: IJclWideStrCollection;\r\nbegin\r\n inherited AssignDataTo(Dest);\r\n if Dest is TJclWideStrTree then\r\n begin\r\n ADest := TJclWideStrTree(Dest);\r\n ADest.Clear;\r\n ADest.FSize := FSize;\r\n if FRoot <> nil then\r\n ADest.FRoot := CloneNode(FRoot, nil);\r\n end\r\n else\r\n if Supports(IInterface(Dest), IJclWideStrCollection, ACollection) then\r\n begin\r\n ACollection.Clear;\r\n ACollection.AddAll(Self);\r\n end;\r\nend;\r\n\r\nprocedure TJclWideStrTree.AssignPropertiesTo(Dest: TJclAbstractContainerBase);\r\nbegin\r\n inherited AssignPropertiesto(Dest);\r\n if Dest is TJclWideStrTree then\r\n TJclWideStrTree(Dest).FTraverseOrder := FTraverseOrder;\r\nend;\r\n\r\nprocedure TJclWideStrTree.Clear;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FRoot <> nil then\r\n RemoveNode(FRoot);\r\n FSize := 0;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclWideStrTree.CloneNode(Node, Parent: TJclWideStrTreeNode): TJclWideStrTreeNode;\r\nvar\r\n Index: Integer;\r\nbegin\r\n Result := TJclWideStrTreeNode.Create;\r\n Result.Value := Node.Value;\r\n Result.Parent := Parent;\r\n SetLength(Result.Children, Node.ChildrenCount);\r\n Result.ChildrenCount := Node.ChildrenCount;\r\n for Index := 0 to Node.ChildrenCount - 1 do\r\n Result.Children[Index] := CloneNode(TJclWideStrTreeNode(Node.Children[Index]), Result); // recursive call\r\nend;\r\n\r\nfunction TJclWideStrTree.CollectionEquals(const ACollection: IJclWideStrCollection): Boolean;\r\nvar\r\n It, ItSelf: IJclWideStrIterator;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n if FSize <> ACollection.Size then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n ItSelf := First;\r\n while ItSelf.HasNext do\r\n if not ItemsEqual(ItSelf.Next, It.Next) then\r\n begin\r\n Result := False;\r\n Break;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclWideStrTree.Contains(const AString: WideString): Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FRoot <> nil then\r\n Result := NodeContains(FRoot, AString)\r\n else\r\n Result := False;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclWideStrTree.ContainsAll(const ACollection: IJclWideStrCollection): Boolean;\r\nvar\r\n It: IJclWideStrIterator;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := True;\r\n if ACollection = nil then\r\n Exit;\r\n It := ACollection.First;\r\n while Result and It.HasNext do\r\n Result := Contains(It.Next);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclWideStrTree.Extract(const AString: WideString): Boolean;\r\nvar\r\n It: IJclWideStrIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := FRoot <> nil;\r\n if Result then\r\n begin\r\n It := First;\r\n while It.HasNext do\r\n if ItemsEqual(It.Next, AString) then\r\n begin\r\n It.Extract;\r\n if RemoveSingleElement then\r\n Break;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclWideStrTree.ExtractAll(const ACollection: IJclWideStrCollection): Boolean;\r\nvar\r\n It: IJclWideStrIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n Result := Extract(It.Next) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclWideStrTree.ExtractNode(var ANode: TJclWideStrTreeNode);\r\nvar\r\n Index, ChildIndex, NewCapacity: Integer;\r\n Parent: TJclWideStrTreeNode;\r\nbegin\r\n for Index := ANode.ChildrenCount - 1 downto 0 do\r\n {$IFDEF BCB}\r\n ExtractNode(TJclWideStrTreeNode(ANode.Children[Index]));\r\n {$ELSE ~BCB}\r\n ExtractNode(ANode.Children[Index]);\r\n {$ENDIF ~BCB}\r\n Parent := ANode.Parent;\r\n if Parent <> nil then\r\n begin\r\n ChildIndex := Parent.IndexOfChild(ANode);\r\n for Index := ChildIndex + 1 to Parent.ChildrenCount - 1 do\r\n Parent.Children[Index - 1] := Parent.Children[Index];\r\n Dec(Parent.ChildrenCount);\r\n NewCapacity := CalcPackCapacity(Length(Parent.Children), Parent.ChildrenCount);\r\n if NewCapacity < Length(Parent.Children) then\r\n SetLength(Parent.Children, NewCapacity);\r\n FreeAndNil(ANode);\r\n end\r\n else\r\n begin\r\n FreeAndNil(ANode);\r\n FRoot := nil;\r\n end;\r\n Dec(FSize);\r\nend;\r\n\r\nfunction TJclWideStrTree.First: IJclWideStrIterator;\r\nvar\r\n Start: TJclWideStrTreeNode;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Start := FRoot;\r\n case GetTraverseOrder of\r\n toPreOrder:\r\n Result := TJclPreOrderWideStrTreeIterator.Create(Self, Start, False, isFirst);\r\n toPostOrder:\r\n begin\r\n if Start <> nil then\r\n while (Start.ChildrenCount > 0) do\r\n Start := TJclWideStrTreeNode(Start.Children[0]);\r\n Result := TJclPostOrderWideStrTreeIterator.Create(Self, Start, False, isFirst);\r\n end;\r\n else\r\n Result := nil;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\n{$IFDEF SUPPORTS_FOR_IN}\r\nfunction TJclWideStrTree.GetEnumerator: IJclWideStrIterator;\r\nbegin\r\n Result := First;\r\nend;\r\n{$ENDIF SUPPORTS_FOR_IN}\r\n\r\nfunction TJclWideStrTree.GetRoot: IJclWideStrTreeIterator;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n case GetTraverseOrder of\r\n toPreOrder:\r\n Result := TJclPreOrderWideStrTreeIterator.Create(Self, FRoot, False, isRoot);\r\n toPostOrder:\r\n Result := TJclPostOrderWideStrTreeIterator.Create(Self, FRoot, False, isRoot);\r\n else\r\n Result := nil;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclWideStrTree.GetTraverseOrder: TJclTraverseOrder;\r\nbegin\r\n Result := FTraverseOrder;\r\nend;\r\n\r\nfunction TJclWideStrTree.IsEmpty: Boolean;\r\nbegin\r\n Result := FSize = 0;\r\nend;\r\n\r\nfunction TJclWideStrTree.Last: IJclWideStrIterator;\r\nvar\r\n Start: TJclWideStrTreeNode;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Start := FRoot;\r\n case FTraverseOrder of\r\n toPreOrder:\r\n begin\r\n if Start <> nil then\r\n while Start.ChildrenCount > 0 do\r\n Start := TJclWideStrTreeNode(Start.Children[Start.ChildrenCount - 1]);\r\n Result := TJclPreOrderWideStrTreeIterator.Create(Self, Start, False, isLast);\r\n end;\r\n toPostOrder:\r\n Result := TJclPostOrderWideStrTreeIterator.Create(Self, Start, False, isLast);\r\n else\r\n Result := nil;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclWideStrTree.NodeContains(ANode: TJclWideStrTreeNode; const AString: WideString): Boolean;\r\nvar\r\n Index: Integer;\r\nbegin\r\n Result := ItemsEqual(ANode.Value, AString);\r\n if not Result then\r\n for Index := 0 to ANode.ChildrenCount - 1 do\r\n begin\r\n Result := NodeContains(TJclWideStrTreeNode(ANode.Children[Index]), AString);\r\n if Result then\r\n Break;\r\n end;\r\nend;\r\n\r\nprocedure TJclWideStrTree.Pack;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FRoot <> nil then\r\n PackNode(FRoot);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclWideStrTree.PackNode(ANode: TJclWideStrTreeNode);\r\nvar\r\n Index: Integer;\r\nbegin\r\n SetLength(ANode.Children, ANode.ChildrenCount);\r\n for Index := 0 to ANode.ChildrenCount - 1 do\r\n PackNode(TJclWideStrTreeNode(ANode.Children[Index]));\r\nend;\r\n\r\nfunction TJclWideStrTree.Remove(const AString: WideString): Boolean;\r\nvar\r\n Extracted: WideString;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := Extract(AString);\r\n if Result then\r\n begin\r\n Extracted := AString;\r\n FreeString(Extracted);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclWideStrTree.RemoveAll(const ACollection: IJclWideStrCollection): Boolean;\r\nvar\r\n It: IJclWideStrIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n Result := Remove(It.Next) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclWideStrTree.RemoveNode(var ANode: TJclWideStrTreeNode);\r\nvar\r\n Index, ChildIndex, NewCapacity: Integer;\r\n Parent: TJclWideStrTreeNode;\r\nbegin\r\n for Index := ANode.ChildrenCount - 1 downto 0 do\r\n {$IFDEF BCB}\r\n RemoveNode(TJclWideStrTreeNode(ANode.Children[Index]));\r\n {$ELSE ~BCB}\r\n RemoveNode(ANode.Children[Index]);\r\n {$ENDIF ~BCB}\r\n FreeString(ANode.Value);\r\n Parent := ANode.Parent;\r\n if Parent <> nil then\r\n begin\r\n ChildIndex := Parent.IndexOfChild(ANode);\r\n for Index := ChildIndex + 1 to Parent.ChildrenCount - 1 do\r\n Parent.Children[Index - 1] := Parent.Children[Index];\r\n Dec(Parent.ChildrenCount);\r\n NewCapacity := CalcPackCapacity(Length(Parent.Children), Parent.ChildrenCount);\r\n if NewCapacity < Length(Parent.Children) then\r\n SetLength(Parent.Children, NewCapacity);\r\n FreeAndNil(ANode);\r\n end\r\n else\r\n begin\r\n FreeAndNil(ANode);\r\n FRoot := nil;\r\n end;\r\n Dec(FSize);\r\nend;\r\n\r\nfunction TJclWideStrTree.RetainAll(const ACollection: IJclWideStrCollection): Boolean;\r\nvar\r\n It: IJclWideStrIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := First;\r\n while It.HasNext do\r\n if not ACollection.Contains(It.Next) then\r\n It.Remove;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclWideStrTree.SetCapacity(Value: Integer);\r\nbegin\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nprocedure TJclWideStrTree.SetTraverseOrder(Value: TJclTraverseOrder);\r\nbegin\r\n FTraverseOrder := Value;\r\nend;\r\n\r\nfunction TJclWideStrTree.Size: Integer;\r\nbegin\r\n Result := FSize;\r\nend;\r\n\r\nfunction TJclWideStrTree.CreateEmptyContainer: TJclAbstractContainerBase;\r\nbegin\r\n Result := TJclWideStrTree.Create;\r\n AssignPropertiesTo(Result);\r\nend;\r\n\r\n//=== { TJclWideStrTreeIterator } ===========================================================\r\n\r\nconstructor TJclWideStrTreeIterator.Create(OwnTree: TJclWideStrTree; ACursor: TJclWideStrTreeNode; AValid: Boolean; AStart: TItrStart);\r\nbegin\r\n inherited Create(AValid);\r\n FCursor := ACursor;\r\n FOwnTree := OwnTree;\r\n FStart := AStart;\r\n FEqualityComparer := OwnTree as IJclWideStrEqualityComparer;\r\nend;\r\n\r\nfunction TJclWideStrTreeIterator.Add(const AString: WideString): Boolean;\r\nvar\r\n ParentNode, NewNode: TJclWideStrTreeNode;\r\nbegin\r\n if FOwnTree.ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n // add sibling or, if FCursor is root node, behave like TJclWideStrTree.Add\r\n Result := (FCursor <> nil) and (FOwnTree.AllowDefaultElements or not FEqualityComparer.ItemsEqual(AString, ''))\r\n and ((not FOwnTree.Contains(AString)) or FOwnTree.CheckDuplicate);\r\n\r\n if Result then\r\n begin\r\n ParentNode := FCursor.Parent;\r\n if ParentNode = nil then\r\n ParentNode := FCursor;\r\n\r\n if ParentNode.ChildrenCount = Length(ParentNode.Children) then\r\n SetLength(ParentNode.Children, FOwnTree.CalcGrowCapacity(Length(ParentNode.Children), ParentNode.ChildrenCount));\r\n if ParentNode.ChildrenCount < Length(ParentNode.Children) then\r\n begin\r\n NewNode := TJclWideStrTreeNode.Create;\r\n NewNode.Value := AString;\r\n NewNode.Parent := ParentNode;\r\n ParentNode.Children[ParentNode.ChildrenCount] := NewNode;\r\n Inc(ParentNode.ChildrenCount);\r\n Inc(FOwnTree.FSize);\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.WriteUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclWideStrTreeIterator.AddChild(const AString: WideString): Boolean;\r\nvar\r\n NewNode: TJclWideStrTreeNode;\r\nbegin\r\n if FOwnTree.ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := (FCursor <> nil) and (FOwnTree.AllowDefaultElements or not FEqualityComparer.ItemsEqual(AString, ''))\r\n and ((not FOwnTree.Contains(AString)) or FOwnTree.CheckDuplicate);\r\n\r\n if Result then\r\n begin\r\n if FCursor.ChildrenCount = Length(FCursor.Children) then\r\n SetLength(FCursor.Children, FOwnTree.CalcGrowCapacity(Length(FCursor.Children), FCursor.ChildrenCount));\r\n if FCursor.ChildrenCount < Length(FCursor.Children) then\r\n begin\r\n NewNode := TJclWideStrTreeNode.Create;\r\n NewNode.Value := AString;\r\n NewNode.Parent := FCursor;\r\n FCursor.Children[FCursor.ChildrenCount] := NewNode;\r\n Inc(FCursor.ChildrenCount);\r\n Inc(FOwnTree.FSize);\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.WriteUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclWideStrTreeIterator.AssignPropertiesTo(Dest: TJclAbstractIterator);\r\nvar\r\n ADest: TJclWideStrTreeIterator;\r\nbegin\r\n inherited AssignPropertiesTo(Dest);\r\n if Dest is TJclWideStrTreeIterator then\r\n begin\r\n ADest := TJclWideStrTreeIterator(Dest);\r\n ADest.FCursor := FCursor;\r\n ADest.FOwnTree := FOwnTree;\r\n ADest.FEqualityComparer := FEqualityComparer;\r\n ADest.FStart := FStart;\r\n end;\r\nend;\r\n\r\nfunction TJclWideStrTreeIterator.ChildrenCount: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FCursor <> nil then\r\n Result := FCursor.ChildrenCount\r\n else\r\n Result := 0;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclWideStrTreeIterator.DeleteChild(Index: Integer);\r\nbegin\r\n if FOwnTree.ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if (FCursor <> nil) and (Index >= 0) and (Index < FCursor.ChildrenCount) then\r\n {$IFDEF BCB}\r\n FOwnTree.RemoveNode(TJclWideStrTreeNode(FCursor.Children[Index]))\r\n {$ELSE ~BCB}\r\n FOwnTree.RemoveNode(FCursor.Children[Index])\r\n {$ENDIF ~BCB}\r\n else\r\n raise EJclOutOfBoundsError.Create;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.WriteUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclWideStrTreeIterator.DeleteChildren;\r\nvar\r\n Index: Integer;\r\nbegin\r\n if FOwnTree.ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FCursor <> nil then\r\n begin\r\n for Index := FCursor.ChildrenCount - 1 downto 0 do\r\n {$IFDEF BCB}\r\n FOwnTree.RemoveNode(TJclWideStrTreeNode(FCursor.Children[Index]));\r\n {$ELSE ~BCB}\r\n FOwnTree.RemoveNode(FCursor.Children[Index]);\r\n {$ENDIF ~BCB}\r\n SetLength(FCursor.Children, 0);\r\n FCursor.ChildrenCount := 0;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.WriteUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclWideStrTreeIterator.Extract;\r\nvar\r\n OldCursor: TJclWideStrTreeNode;\r\nbegin\r\n if FOwnTree.ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n CheckValid;\r\n Valid := False;\r\n OldCursor := FCursor;\r\n FCursor := GetNextSibling;\r\n if OldCursor <> nil then\r\n FOwnTree.ExtractNode(OldCursor);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.WriteUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclWideStrTreeIterator.ExtractChild(Index: Integer);\r\nbegin\r\n if FOwnTree.ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if (FCursor <> nil) and (Index >= 0) and (Index < FCursor.ChildrenCount) then\r\n {$IFDEF BCB}\r\n FOwnTree.ExtractNode(TJclWideStrTreeNode(FCursor.Children[Index]))\r\n {$ELSE ~BCB}\r\n FOwnTree.ExtractNode(FCursor.Children[Index])\r\n {$ENDIF ~BCB}\r\n else\r\n raise EJclOutOfBoundsError.Create;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.WriteUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclWideStrTreeIterator.ExtractChildren;\r\nvar\r\n Index: Integer;\r\nbegin\r\n if FOwnTree.ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FCursor <> nil then\r\n begin\r\n for Index := FCursor.ChildrenCount - 1 downto 0 do\r\n {$IFDEF BCB}\r\n FOwnTree.ExtractNode(TJclWideStrTreeNode(FCursor.Children[Index]));\r\n {$ELSE ~BCB}\r\n FOwnTree.ExtractNode(FCursor.Children[Index]);\r\n {$ENDIF ~BCB}\r\n SetLength(FCursor.Children, 0);\r\n FCursor.ChildrenCount := 0;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.WriteUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclWideStrTreeIterator.GetChild(Index: Integer): WideString;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := '';\r\n if (FCursor <> nil) and (Index >= 0) and (Index < FCursor.ChildrenCount) then\r\n FCursor := TJclWideStrTreeNode(FCursor.Children[Index]);\r\n if FCursor <> nil then\r\n Result := FCursor.Value\r\n else\r\n if not FOwnTree.ReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclWideStrTreeIterator.GetString: WideString;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n CheckValid;\r\n Result := '';\r\n if FCursor <> nil then\r\n Result := FCursor.Value\r\n else\r\n if not FOwnTree.ReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclWideStrTreeIterator.HasChild(Index: Integer): Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := (FCursor <> nil) and (Index >= 0) and (Index < FCursor.ChildrenCount);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclWideStrTreeIterator.HasNext: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Valid then\r\n Result := GetNextCursor <> nil\r\n else\r\n Result := FCursor <> nil;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclWideStrTreeIterator.HasParent: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := (FCursor <> nil) and (FCursor.Parent <> nil);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclWideStrTreeIterator.HasPrevious: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Valid then\r\n Result := GetPreviousCursor <> nil\r\n else\r\n Result := FCursor <> nil;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclWideStrTreeIterator.IndexOfChild(const AString: WideString): Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FCursor <> nil then\r\n Result := FCursor.IndexOfValue(AString, FEqualityComparer)\r\n else\r\n Result := -1;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclWideStrTreeIterator.Insert(const AString: WideString): Boolean;\r\nvar\r\n ParentNode, NewNode: TJclWideStrTreeNode;\r\n Index, I: Integer;\r\nbegin\r\n if FOwnTree.ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n // insert sibling or, if FCursor is root node, behave like TJclWideStrTree.Insert\r\n Result := (FCursor <> nil) and (FOwnTree.AllowDefaultElements or not FEqualityComparer.ItemsEqual(AString, ''))\r\n and ((not FOwnTree.Contains(AString)) or FOwnTree.CheckDuplicate);\r\n\r\n if Result then\r\n begin\r\n if FCursor.Parent <> nil then\r\n begin\r\n ParentNode := FCursor.Parent;\r\n Index := 0;\r\n while (Index < ParentNode.ChildrenCount) and (ParentNode.Children[Index] <> FCursor) do\r\n Inc(Index);\r\n end\r\n else\r\n begin\r\n ParentNode := FCursor;\r\n Index := 0;\r\n end;\r\n\r\n if ParentNode.ChildrenCount = Length(ParentNode.Children) then\r\n SetLength(ParentNode.Children, FOwnTree.CalcGrowCapacity(Length(ParentNode.Children), ParentNode.ChildrenCount));\r\n if ParentNode.ChildrenCount < Length(ParentNode.Children) then\r\n begin\r\n NewNode := TJclWideStrTreeNode.Create;\r\n NewNode.Value := AString;\r\n NewNode.Parent := ParentNode;\r\n for I := ParentNode.ChildrenCount - 1 downto Index do\r\n ParentNode.Children[I + 1] := ParentNode.Children[I];\r\n ParentNode.Children[Index] := NewNode;\r\n Inc(ParentNode.ChildrenCount);\r\n Inc(FOwnTree.FSize);\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.WriteUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclWideStrTreeIterator.InsertChild(Index: Integer; const AString: WideString): Boolean;\r\nvar\r\n NewNode: TJclWideStrTreeNode;\r\n I: Integer;\r\nbegin\r\n if FOwnTree.ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n // insert sibling or, if FCursor is root node, behave like TJclWideStrTree.Insert\r\n Result := (FCursor <> nil) and (FOwnTree.AllowDefaultElements or not FEqualityComparer.ItemsEqual(AString, ''))\r\n and ((not FOwnTree.Contains(AString)) or FOwnTree.CheckDuplicate);\r\n\r\n if Result then\r\n begin\r\n if FCursor.ChildrenCount = Length(FCursor.Children) then\r\n SetLength(FCursor.Children, FOwnTree.CalcGrowCapacity(Length(FCursor.Children), FCursor.ChildrenCount));\r\n if FCursor.ChildrenCount < Length(FCursor.Children) then\r\n begin\r\n NewNode := TJclWideStrTreeNode.Create;\r\n NewNode.Value := AString;\r\n NewNode.Parent := FCursor;\r\n for I := FCursor.ChildrenCount - 1 downto Index do\r\n FCursor.Children[I + 1] := FCursor.Children[I];\r\n FCursor.Children[Index] := NewNode;\r\n Inc(FCursor.ChildrenCount);\r\n Inc(FOwnTree.FSize);\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.WriteUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclWideStrTreeIterator.IteratorEquals(const AIterator: IJclWideStrIterator): Boolean;\r\nvar\r\n Obj: TObject;\r\n ItrObj: TJclWideStrTreeIterator;\r\nbegin\r\n Result := False;\r\n if AIterator = nil then\r\n Exit;\r\n Obj := AIterator.GetIteratorReference;\r\n if Obj is TJclWideStrTreeIterator then\r\n begin\r\n ItrObj := TJclWideStrTreeIterator(Obj);\r\n Result := (FOwnTree = ItrObj.FOwnTree) and (FCursor = ItrObj.FCursor) and (Valid = ItrObj.Valid);\r\n end;\r\nend;\r\n\r\n{$IFDEF SUPPORTS_FOR_IN}\r\nfunction TJclWideStrTreeIterator.MoveNext: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Valid then\r\n FCursor := GetNextCursor\r\n else\r\n Valid := True;\r\n Result := FCursor <> nil;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n{$ENDIF SUPPORTS_FOR_IN}\r\n\r\nfunction TJclWideStrTreeIterator.Next: WideString;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Valid then\r\n FCursor := GetNextCursor\r\n else\r\n Valid := True;\r\n Result := '';\r\n if FCursor <> nil then\r\n Result := FCursor.Value\r\n else\r\n if not FOwnTree.ReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclWideStrTreeIterator.NextIndex: Integer;\r\nbegin\r\n // No index\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nfunction TJclWideStrTreeIterator.Parent: WideString;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := '';\r\n if FCursor <> nil then\r\n FCursor := FCursor.Parent;\r\n if FCursor <> nil then\r\n Result := FCursor.Value\r\n else\r\n if not FOwnTree.ReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclWideStrTreeIterator.Previous: WideString;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Valid then\r\n FCursor := GetPreviousCursor\r\n else\r\n Valid := True;\r\n Result := '';\r\n if FCursor <> nil then\r\n Result := FCursor.Value\r\n else\r\n if not FOwnTree.ReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclWideStrTreeIterator.PreviousIndex: Integer;\r\nbegin\r\n // No index\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nprocedure TJclWideStrTreeIterator.Remove;\r\nvar\r\n OldCursor: TJclWideStrTreeNode;\r\nbegin\r\n if FOwnTree.ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n CheckValid;\r\n Valid := False;\r\n OldCursor := FCursor;\r\n FCursor := GetNextSibling;\r\n if OldCursor <> nil then\r\n FOwnTree.RemoveNode(OldCursor);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.WriteUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclWideStrTreeIterator.Reset;\r\nvar\r\n NewCursor: TJclWideStrTreeNode;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Valid := False;\r\n case FStart of\r\n isFirst:\r\n begin\r\n NewCursor := FCursor;\r\n while NewCursor <> nil do\r\n begin\r\n NewCursor := GetPreviousCursor;\r\n if NewCursor <> nil then\r\n FCursor := NewCursor;\r\n end;\r\n end;\r\n isLast:\r\n begin\r\n NewCursor := FCursor;\r\n while NewCursor <> nil do\r\n begin\r\n NewCursor := GetNextCursor;\r\n if NewCursor <> nil then\r\n FCursor := NewCursor;\r\n end;\r\n end;\r\n isRoot:\r\n begin\r\n while (FCursor <> nil) and (FCursor.Parent <> nil) do\r\n FCursor := FCursor.Parent;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclWideStrTreeIterator.SetChild(Index: Integer; const AString: WideString);\r\nbegin\r\n if FOwnTree.ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if (FCursor <> nil) and (Index >= 0) and (Index < FCursor.ChildrenCount) then\r\n TJclWideStrTreeNode(FCursor.Children[Index]).Value := AString\r\n else\r\n raise EJclOutOfBoundsError.Create;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.WriteUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclWideStrTreeIterator.SetString(const AString: WideString);\r\nbegin\r\n if FOwnTree.ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n CheckValid;\r\n if FCursor <> nil then\r\n begin\r\n FOwnTree.FreeString(FCursor.Value);\r\n FCursor.Value := AString;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.WriteUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\n//=== { TJclPreOrderWideStrTreeIterator } ===================================================\r\n\r\nfunction TJclPreOrderWideStrTreeIterator.CreateEmptyIterator: TJclAbstractIterator;\r\nbegin\r\n Result := TJclPreOrderWideStrTreeIterator.Create(FOwnTree, FCursor, Valid, FStart);\r\nend;\r\n\r\nfunction TJclPreOrderWideStrTreeIterator.GetNextCursor: TJclWideStrTreeNode;\r\nvar\r\n LastRet: TJclWideStrTreeNode;\r\nbegin\r\n Result := FCursor;\r\n if Result = nil then\r\n Exit;\r\n LastRet := Result;\r\n if Result.ChildrenCount > 0 then\r\n Result := TJclWideStrTreeNode(Result.Children[0])\r\n else\r\n begin\r\n Result := Result.Parent;\r\n while (Result <> nil) and (Result.IndexOfChild(LastRet) = (Result.ChildrenCount - 1)) do\r\n begin\r\n LastRet := Result;\r\n Result := Result.Parent;\r\n end;\r\n if Result <> nil then // not root = return successor\r\n Result := TJclWideStrTreeNode(Result.Children[Result.IndexOfChild(LastRet) + 1]);\r\n end;\r\nend;\r\n\r\nfunction TJclPreOrderWideStrTreeIterator.GetNextSibling: TJclWideStrTreeNode;\r\nvar\r\n LastRet: TJclWideStrTreeNode;\r\nbegin\r\n Result := FCursor;\r\n if Result = nil then\r\n Exit;\r\n LastRet := Result;\r\n\r\n Result := Result.Parent;\r\n while (Result <> nil) and (Result.IndexOfChild(LastRet) = (Result.ChildrenCount - 1)) do\r\n begin\r\n LastRet := Result;\r\n Result := Result.Parent;\r\n end;\r\n if Result <> nil then // not root = return successor\r\n Result := TJclWideStrTreeNode(Result.Children[Result.IndexOfChild(LastRet) + 1]);\r\nend;\r\n\r\nfunction TJclPreOrderWideStrTreeIterator.GetPreviousCursor: TJclWideStrTreeNode;\r\nvar\r\n LastRet: TJclWideStrTreeNode;\r\nbegin\r\n Result := FCursor;\r\n if Result = nil then\r\n Exit;\r\n LastRet := Result;\r\n Result := Result.Parent;\r\n if (Result <> nil) and (Result.IndexOfChild(LastRet) > 0) then\r\n // come from Right\r\n begin\r\n Result := TJclWideStrTreeNode(Result.Children[Result.IndexOfChild(LastRet) - 1]);\r\n while (Result.ChildrenCount > 0) do // descend down the tree\r\n Result := TJclWideStrTreeNode(Result.Children[Result.ChildrenCount - 1]);\r\n end;\r\nend;\r\n\r\n//=== { TJclPostOrderWideStrTreeIterator } ==================================================\r\n\r\nfunction TJclPostOrderWideStrTreeIterator.CreateEmptyIterator: TJclAbstractIterator;\r\nbegin\r\n Result := TJclPostOrderWideStrTreeIterator.Create(FOwnTree, FCursor, Valid, FStart);\r\nend;\r\n\r\nfunction TJclPostOrderWideStrTreeIterator.GetNextCursor: TJclWideStrTreeNode;\r\nvar\r\n LastRet: TJclWideStrTreeNode;\r\nbegin\r\n Result := FCursor;\r\n if Result = nil then\r\n Exit;\r\n LastRet := Result;\r\n Result := Result.Parent;\r\n if (Result <> nil) and (Result.IndexOfChild(LastRet) <> (Result.ChildrenCount - 1)) then\r\n begin\r\n Result := TJclWideStrTreeNode(Result.Children[Result.IndexOfChild(LastRet) + 1]);\r\n while Result.ChildrenCount > 0 do\r\n Result := TJclWideStrTreeNode(Result.Children[0]);\r\n end;\r\nend;\r\n\r\nfunction TJclPostOrderWideStrTreeIterator.GetNextSibling: TJclWideStrTreeNode;\r\nvar\r\n LastRet: TJclWideStrTreeNode;\r\nbegin\r\n Result := FCursor;\r\n if Result = nil then\r\n Exit;\r\n LastRet := Result;\r\n Result := Result.Parent;\r\n\r\n if (Result <> nil) and (Result.IndexOfChild(LastRet) <> (Result.ChildrenCount - 1)) then\r\n begin\r\n Result := TJclWideStrTreeNode(Result.Children[Result.IndexOfChild(LastRet) + 1]);\r\n while Result.ChildrenCount > 0 do\r\n Result := TJclWideStrTreeNode(Result.Children[0]);\r\n end;\r\nend;\r\n\r\nfunction TJclPostOrderWideStrTreeIterator.GetPreviousCursor: TJclWideStrTreeNode;\r\nvar\r\n LastRet: TJclWideStrTreeNode;\r\nbegin\r\n Result := FCursor;\r\n if Result = nil then\r\n Exit;\r\n if Result.ChildrenCount > 0 then\r\n Result := TJclWideStrTreeNode(Result.Children[Result.ChildrenCount - 1])\r\n else\r\n begin\r\n LastRet := Result;\r\n Result := Result.Parent;\r\n while (Result <> nil) and (Result.IndexOfChild(LastRet) = 0) do\r\n begin\r\n LastRet := Result;\r\n Result := Result.Parent;\r\n end;\r\n if Result <> nil then // not root\r\n Result := TJclWideStrTreeNode(Result.Children[Result.IndexOfChild(LastRet) - 1]);\r\n end;\r\nend;\r\n\r\n{$IFDEF SUPPORTS_UNICODE_STRING}\r\n//=== { TJclUnicodeStrTreeNode } =======================================================\r\n\r\nfunction TJclUnicodeStrTreeNode.IndexOfChild(AChild: TJclUnicodeStrTreeNode): Integer;\r\nbegin\r\n for Result := 0 to ChildrenCount - 1 do\r\n if Children[Result] = AChild then\r\n Exit;\r\n Result := -1;\r\nend;\r\n\r\nfunction TJclUnicodeStrTreeNode.IndexOfValue(const AString: UnicodeString;\r\n const AEqualityComparer: IJclUnicodeStrEqualityComparer): Integer;\r\nbegin\r\n for Result := 0 to ChildrenCount - 1 do\r\n if AEqualityComparer.ItemsEqual(TJclUnicodeStrTreeNode(Children[Result]).Value, AString) then\r\n Exit;\r\n Result := -1;\r\nend;\r\n{$ENDIF SUPPORTS_UNICODE_STRING}\r\n\r\n{$IFDEF SUPPORTS_UNICODE_STRING}\r\n//=== { TJclUnicodeStrTree } =======================================================\r\n\r\nconstructor TJclUnicodeStrTree.Create();\r\nbegin\r\n inherited Create();\r\n FTraverseOrder := toPreOrder;\r\nend;\r\n\r\ndestructor TJclUnicodeStrTree.Destroy;\r\nbegin\r\n FReadOnly := False;\r\n Clear;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJclUnicodeStrTree.Add(const AString: UnicodeString): Boolean;\r\nvar\r\n NewNode: TJclUnicodeStrTreeNode;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := AllowDefaultElements or not ItemsEqual(AString, '');\r\n\r\n if Result then\r\n begin\r\n if FRoot <> nil then\r\n begin\r\n Result := (not Contains(AString)) or CheckDuplicate;\r\n if Result then\r\n begin\r\n if FRoot.ChildrenCount = Length(FRoot.Children) then\r\n SetLength(FRoot.Children, CalcGrowCapacity(Length(FRoot.Children), FRoot.ChildrenCount));\r\n if FRoot.ChildrenCount < Length(FRoot.Children) then\r\n begin\r\n NewNode := TJclUnicodeStrTreeNode.Create;\r\n NewNode.Value := AString;\r\n NewNode.Parent := FRoot;\r\n FRoot.Children[FRoot.ChildrenCount] := NewNode;\r\n Inc(FRoot.ChildrenCount);\r\n Inc(FSize);\r\n end\r\n else\r\n Result := False;\r\n end;\r\n end\r\n else\r\n begin\r\n FRoot := TJclUnicodeStrTreeNode.Create;\r\n FRoot.Value := AString;\r\n Inc(FSize);\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclUnicodeStrTree.AddAll(const ACollection: IJclUnicodeStrCollection): Boolean;\r\nvar\r\n It: IJclUnicodeStrIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n Result := Add(It.Next) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclUnicodeStrTree.AssignDataTo(Dest: TJclAbstractContainerBase);\r\nvar\r\n ADest: TJclUnicodeStrTree;\r\n ACollection: IJclUnicodeStrCollection;\r\nbegin\r\n inherited AssignDataTo(Dest);\r\n if Dest is TJclUnicodeStrTree then\r\n begin\r\n ADest := TJclUnicodeStrTree(Dest);\r\n ADest.Clear;\r\n ADest.FSize := FSize;\r\n if FRoot <> nil then\r\n ADest.FRoot := CloneNode(FRoot, nil);\r\n end\r\n else\r\n if Supports(IInterface(Dest), IJclUnicodeStrCollection, ACollection) then\r\n begin\r\n ACollection.Clear;\r\n ACollection.AddAll(Self);\r\n end;\r\nend;\r\n\r\nprocedure TJclUnicodeStrTree.AssignPropertiesTo(Dest: TJclAbstractContainerBase);\r\nbegin\r\n inherited AssignPropertiesto(Dest);\r\n if Dest is TJclUnicodeStrTree then\r\n TJclUnicodeStrTree(Dest).FTraverseOrder := FTraverseOrder;\r\nend;\r\n\r\nprocedure TJclUnicodeStrTree.Clear;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FRoot <> nil then\r\n RemoveNode(FRoot);\r\n FSize := 0;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclUnicodeStrTree.CloneNode(Node, Parent: TJclUnicodeStrTreeNode): TJclUnicodeStrTreeNode;\r\nvar\r\n Index: Integer;\r\nbegin\r\n Result := TJclUnicodeStrTreeNode.Create;\r\n Result.Value := Node.Value;\r\n Result.Parent := Parent;\r\n SetLength(Result.Children, Node.ChildrenCount);\r\n Result.ChildrenCount := Node.ChildrenCount;\r\n for Index := 0 to Node.ChildrenCount - 1 do\r\n Result.Children[Index] := CloneNode(TJclUnicodeStrTreeNode(Node.Children[Index]), Result); // recursive call\r\nend;\r\n\r\nfunction TJclUnicodeStrTree.CollectionEquals(const ACollection: IJclUnicodeStrCollection): Boolean;\r\nvar\r\n It, ItSelf: IJclUnicodeStrIterator;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n if FSize <> ACollection.Size then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n ItSelf := First;\r\n while ItSelf.HasNext do\r\n if not ItemsEqual(ItSelf.Next, It.Next) then\r\n begin\r\n Result := False;\r\n Break;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclUnicodeStrTree.Contains(const AString: UnicodeString): Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FRoot <> nil then\r\n Result := NodeContains(FRoot, AString)\r\n else\r\n Result := False;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclUnicodeStrTree.ContainsAll(const ACollection: IJclUnicodeStrCollection): Boolean;\r\nvar\r\n It: IJclUnicodeStrIterator;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := True;\r\n if ACollection = nil then\r\n Exit;\r\n It := ACollection.First;\r\n while Result and It.HasNext do\r\n Result := Contains(It.Next);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclUnicodeStrTree.Extract(const AString: UnicodeString): Boolean;\r\nvar\r\n It: IJclUnicodeStrIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := FRoot <> nil;\r\n if Result then\r\n begin\r\n It := First;\r\n while It.HasNext do\r\n if ItemsEqual(It.Next, AString) then\r\n begin\r\n It.Extract;\r\n if RemoveSingleElement then\r\n Break;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclUnicodeStrTree.ExtractAll(const ACollection: IJclUnicodeStrCollection): Boolean;\r\nvar\r\n It: IJclUnicodeStrIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n Result := Extract(It.Next) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclUnicodeStrTree.ExtractNode(var ANode: TJclUnicodeStrTreeNode);\r\nvar\r\n Index, ChildIndex, NewCapacity: Integer;\r\n Parent: TJclUnicodeStrTreeNode;\r\nbegin\r\n for Index := ANode.ChildrenCount - 1 downto 0 do\r\n {$IFDEF BCB}\r\n ExtractNode(TJclUnicodeStrTreeNode(ANode.Children[Index]));\r\n {$ELSE ~BCB}\r\n ExtractNode(ANode.Children[Index]);\r\n {$ENDIF ~BCB}\r\n Parent := ANode.Parent;\r\n if Parent <> nil then\r\n begin\r\n ChildIndex := Parent.IndexOfChild(ANode);\r\n for Index := ChildIndex + 1 to Parent.ChildrenCount - 1 do\r\n Parent.Children[Index - 1] := Parent.Children[Index];\r\n Dec(Parent.ChildrenCount);\r\n NewCapacity := CalcPackCapacity(Length(Parent.Children), Parent.ChildrenCount);\r\n if NewCapacity < Length(Parent.Children) then\r\n SetLength(Parent.Children, NewCapacity);\r\n FreeAndNil(ANode);\r\n end\r\n else\r\n begin\r\n FreeAndNil(ANode);\r\n FRoot := nil;\r\n end;\r\n Dec(FSize);\r\nend;\r\n\r\nfunction TJclUnicodeStrTree.First: IJclUnicodeStrIterator;\r\nvar\r\n Start: TJclUnicodeStrTreeNode;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Start := FRoot;\r\n case GetTraverseOrder of\r\n toPreOrder:\r\n Result := TJclPreOrderUnicodeStrTreeIterator.Create(Self, Start, False, isFirst);\r\n toPostOrder:\r\n begin\r\n if Start <> nil then\r\n while (Start.ChildrenCount > 0) do\r\n Start := TJclUnicodeStrTreeNode(Start.Children[0]);\r\n Result := TJclPostOrderUnicodeStrTreeIterator.Create(Self, Start, False, isFirst);\r\n end;\r\n else\r\n Result := nil;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\n{$IFDEF SUPPORTS_FOR_IN}\r\nfunction TJclUnicodeStrTree.GetEnumerator: IJclUnicodeStrIterator;\r\nbegin\r\n Result := First;\r\nend;\r\n{$ENDIF SUPPORTS_FOR_IN}\r\n\r\nfunction TJclUnicodeStrTree.GetRoot: IJclUnicodeStrTreeIterator;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n case GetTraverseOrder of\r\n toPreOrder:\r\n Result := TJclPreOrderUnicodeStrTreeIterator.Create(Self, FRoot, False, isRoot);\r\n toPostOrder:\r\n Result := TJclPostOrderUnicodeStrTreeIterator.Create(Self, FRoot, False, isRoot);\r\n else\r\n Result := nil;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclUnicodeStrTree.GetTraverseOrder: TJclTraverseOrder;\r\nbegin\r\n Result := FTraverseOrder;\r\nend;\r\n\r\nfunction TJclUnicodeStrTree.IsEmpty: Boolean;\r\nbegin\r\n Result := FSize = 0;\r\nend;\r\n\r\nfunction TJclUnicodeStrTree.Last: IJclUnicodeStrIterator;\r\nvar\r\n Start: TJclUnicodeStrTreeNode;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Start := FRoot;\r\n case FTraverseOrder of\r\n toPreOrder:\r\n begin\r\n if Start <> nil then\r\n while Start.ChildrenCount > 0 do\r\n Start := TJclUnicodeStrTreeNode(Start.Children[Start.ChildrenCount - 1]);\r\n Result := TJclPreOrderUnicodeStrTreeIterator.Create(Self, Start, False, isLast);\r\n end;\r\n toPostOrder:\r\n Result := TJclPostOrderUnicodeStrTreeIterator.Create(Self, Start, False, isLast);\r\n else\r\n Result := nil;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclUnicodeStrTree.NodeContains(ANode: TJclUnicodeStrTreeNode; const AString: UnicodeString): Boolean;\r\nvar\r\n Index: Integer;\r\nbegin\r\n Result := ItemsEqual(ANode.Value, AString);\r\n if not Result then\r\n for Index := 0 to ANode.ChildrenCount - 1 do\r\n begin\r\n Result := NodeContains(TJclUnicodeStrTreeNode(ANode.Children[Index]), AString);\r\n if Result then\r\n Break;\r\n end;\r\nend;\r\n\r\nprocedure TJclUnicodeStrTree.Pack;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FRoot <> nil then\r\n PackNode(FRoot);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclUnicodeStrTree.PackNode(ANode: TJclUnicodeStrTreeNode);\r\nvar\r\n Index: Integer;\r\nbegin\r\n SetLength(ANode.Children, ANode.ChildrenCount);\r\n for Index := 0 to ANode.ChildrenCount - 1 do\r\n PackNode(TJclUnicodeStrTreeNode(ANode.Children[Index]));\r\nend;\r\n\r\nfunction TJclUnicodeStrTree.Remove(const AString: UnicodeString): Boolean;\r\nvar\r\n Extracted: UnicodeString;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := Extract(AString);\r\n if Result then\r\n begin\r\n Extracted := AString;\r\n FreeString(Extracted);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclUnicodeStrTree.RemoveAll(const ACollection: IJclUnicodeStrCollection): Boolean;\r\nvar\r\n It: IJclUnicodeStrIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n Result := Remove(It.Next) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclUnicodeStrTree.RemoveNode(var ANode: TJclUnicodeStrTreeNode);\r\nvar\r\n Index, ChildIndex, NewCapacity: Integer;\r\n Parent: TJclUnicodeStrTreeNode;\r\nbegin\r\n for Index := ANode.ChildrenCount - 1 downto 0 do\r\n {$IFDEF BCB}\r\n RemoveNode(TJclUnicodeStrTreeNode(ANode.Children[Index]));\r\n {$ELSE ~BCB}\r\n RemoveNode(ANode.Children[Index]);\r\n {$ENDIF ~BCB}\r\n FreeString(ANode.Value);\r\n Parent := ANode.Parent;\r\n if Parent <> nil then\r\n begin\r\n ChildIndex := Parent.IndexOfChild(ANode);\r\n for Index := ChildIndex + 1 to Parent.ChildrenCount - 1 do\r\n Parent.Children[Index - 1] := Parent.Children[Index];\r\n Dec(Parent.ChildrenCount);\r\n NewCapacity := CalcPackCapacity(Length(Parent.Children), Parent.ChildrenCount);\r\n if NewCapacity < Length(Parent.Children) then\r\n SetLength(Parent.Children, NewCapacity);\r\n FreeAndNil(ANode);\r\n end\r\n else\r\n begin\r\n FreeAndNil(ANode);\r\n FRoot := nil;\r\n end;\r\n Dec(FSize);\r\nend;\r\n\r\nfunction TJclUnicodeStrTree.RetainAll(const ACollection: IJclUnicodeStrCollection): Boolean;\r\nvar\r\n It: IJclUnicodeStrIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := First;\r\n while It.HasNext do\r\n if not ACollection.Contains(It.Next) then\r\n It.Remove;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclUnicodeStrTree.SetCapacity(Value: Integer);\r\nbegin\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nprocedure TJclUnicodeStrTree.SetTraverseOrder(Value: TJclTraverseOrder);\r\nbegin\r\n FTraverseOrder := Value;\r\nend;\r\n\r\nfunction TJclUnicodeStrTree.Size: Integer;\r\nbegin\r\n Result := FSize;\r\nend;\r\n\r\nfunction TJclUnicodeStrTree.CreateEmptyContainer: TJclAbstractContainerBase;\r\nbegin\r\n Result := TJclUnicodeStrTree.Create;\r\n AssignPropertiesTo(Result);\r\nend;\r\n\r\n{$ENDIF SUPPORTS_UNICODE_STRING}\r\n\r\n{$IFDEF SUPPORTS_UNICODE_STRING}\r\n//=== { TJclUnicodeStrTreeIterator } ===========================================================\r\n\r\nconstructor TJclUnicodeStrTreeIterator.Create(OwnTree: TJclUnicodeStrTree; ACursor: TJclUnicodeStrTreeNode; AValid: Boolean; AStart: TItrStart);\r\nbegin\r\n inherited Create(AValid);\r\n FCursor := ACursor;\r\n FOwnTree := OwnTree;\r\n FStart := AStart;\r\n FEqualityComparer := OwnTree as IJclUnicodeStrEqualityComparer;\r\nend;\r\n\r\nfunction TJclUnicodeStrTreeIterator.Add(const AString: UnicodeString): Boolean;\r\nvar\r\n ParentNode, NewNode: TJclUnicodeStrTreeNode;\r\nbegin\r\n if FOwnTree.ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n // add sibling or, if FCursor is root node, behave like TJclUnicodeStrTree.Add\r\n Result := (FCursor <> nil) and (FOwnTree.AllowDefaultElements or not FEqualityComparer.ItemsEqual(AString, ''))\r\n and ((not FOwnTree.Contains(AString)) or FOwnTree.CheckDuplicate);\r\n\r\n if Result then\r\n begin\r\n ParentNode := FCursor.Parent;\r\n if ParentNode = nil then\r\n ParentNode := FCursor;\r\n\r\n if ParentNode.ChildrenCount = Length(ParentNode.Children) then\r\n SetLength(ParentNode.Children, FOwnTree.CalcGrowCapacity(Length(ParentNode.Children), ParentNode.ChildrenCount));\r\n if ParentNode.ChildrenCount < Length(ParentNode.Children) then\r\n begin\r\n NewNode := TJclUnicodeStrTreeNode.Create;\r\n NewNode.Value := AString;\r\n NewNode.Parent := ParentNode;\r\n ParentNode.Children[ParentNode.ChildrenCount] := NewNode;\r\n Inc(ParentNode.ChildrenCount);\r\n Inc(FOwnTree.FSize);\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.WriteUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclUnicodeStrTreeIterator.AddChild(const AString: UnicodeString): Boolean;\r\nvar\r\n NewNode: TJclUnicodeStrTreeNode;\r\nbegin\r\n if FOwnTree.ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := (FCursor <> nil) and (FOwnTree.AllowDefaultElements or not FEqualityComparer.ItemsEqual(AString, ''))\r\n and ((not FOwnTree.Contains(AString)) or FOwnTree.CheckDuplicate);\r\n\r\n if Result then\r\n begin\r\n if FCursor.ChildrenCount = Length(FCursor.Children) then\r\n SetLength(FCursor.Children, FOwnTree.CalcGrowCapacity(Length(FCursor.Children), FCursor.ChildrenCount));\r\n if FCursor.ChildrenCount < Length(FCursor.Children) then\r\n begin\r\n NewNode := TJclUnicodeStrTreeNode.Create;\r\n NewNode.Value := AString;\r\n NewNode.Parent := FCursor;\r\n FCursor.Children[FCursor.ChildrenCount] := NewNode;\r\n Inc(FCursor.ChildrenCount);\r\n Inc(FOwnTree.FSize);\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.WriteUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclUnicodeStrTreeIterator.AssignPropertiesTo(Dest: TJclAbstractIterator);\r\nvar\r\n ADest: TJclUnicodeStrTreeIterator;\r\nbegin\r\n inherited AssignPropertiesTo(Dest);\r\n if Dest is TJclUnicodeStrTreeIterator then\r\n begin\r\n ADest := TJclUnicodeStrTreeIterator(Dest);\r\n ADest.FCursor := FCursor;\r\n ADest.FOwnTree := FOwnTree;\r\n ADest.FEqualityComparer := FEqualityComparer;\r\n ADest.FStart := FStart;\r\n end;\r\nend;\r\n\r\nfunction TJclUnicodeStrTreeIterator.ChildrenCount: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FCursor <> nil then\r\n Result := FCursor.ChildrenCount\r\n else\r\n Result := 0;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclUnicodeStrTreeIterator.DeleteChild(Index: Integer);\r\nbegin\r\n if FOwnTree.ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if (FCursor <> nil) and (Index >= 0) and (Index < FCursor.ChildrenCount) then\r\n {$IFDEF BCB}\r\n FOwnTree.RemoveNode(TJclUnicodeStrTreeNode(FCursor.Children[Index]))\r\n {$ELSE ~BCB}\r\n FOwnTree.RemoveNode(FCursor.Children[Index])\r\n {$ENDIF ~BCB}\r\n else\r\n raise EJclOutOfBoundsError.Create;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.WriteUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclUnicodeStrTreeIterator.DeleteChildren;\r\nvar\r\n Index: Integer;\r\nbegin\r\n if FOwnTree.ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FCursor <> nil then\r\n begin\r\n for Index := FCursor.ChildrenCount - 1 downto 0 do\r\n {$IFDEF BCB}\r\n FOwnTree.RemoveNode(TJclUnicodeStrTreeNode(FCursor.Children[Index]));\r\n {$ELSE ~BCB}\r\n FOwnTree.RemoveNode(FCursor.Children[Index]);\r\n {$ENDIF ~BCB}\r\n SetLength(FCursor.Children, 0);\r\n FCursor.ChildrenCount := 0;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.WriteUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclUnicodeStrTreeIterator.Extract;\r\nvar\r\n OldCursor: TJclUnicodeStrTreeNode;\r\nbegin\r\n if FOwnTree.ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n CheckValid;\r\n Valid := False;\r\n OldCursor := FCursor;\r\n FCursor := GetNextSibling;\r\n if OldCursor <> nil then\r\n FOwnTree.ExtractNode(OldCursor);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.WriteUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclUnicodeStrTreeIterator.ExtractChild(Index: Integer);\r\nbegin\r\n if FOwnTree.ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if (FCursor <> nil) and (Index >= 0) and (Index < FCursor.ChildrenCount) then\r\n {$IFDEF BCB}\r\n FOwnTree.ExtractNode(TJclUnicodeStrTreeNode(FCursor.Children[Index]))\r\n {$ELSE ~BCB}\r\n FOwnTree.ExtractNode(FCursor.Children[Index])\r\n {$ENDIF ~BCB}\r\n else\r\n raise EJclOutOfBoundsError.Create;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.WriteUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclUnicodeStrTreeIterator.ExtractChildren;\r\nvar\r\n Index: Integer;\r\nbegin\r\n if FOwnTree.ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FCursor <> nil then\r\n begin\r\n for Index := FCursor.ChildrenCount - 1 downto 0 do\r\n {$IFDEF BCB}\r\n FOwnTree.ExtractNode(TJclUnicodeStrTreeNode(FCursor.Children[Index]));\r\n {$ELSE ~BCB}\r\n FOwnTree.ExtractNode(FCursor.Children[Index]);\r\n {$ENDIF ~BCB}\r\n SetLength(FCursor.Children, 0);\r\n FCursor.ChildrenCount := 0;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.WriteUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclUnicodeStrTreeIterator.GetChild(Index: Integer): UnicodeString;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := '';\r\n if (FCursor <> nil) and (Index >= 0) and (Index < FCursor.ChildrenCount) then\r\n FCursor := TJclUnicodeStrTreeNode(FCursor.Children[Index]);\r\n if FCursor <> nil then\r\n Result := FCursor.Value\r\n else\r\n if not FOwnTree.ReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclUnicodeStrTreeIterator.GetString: UnicodeString;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n CheckValid;\r\n Result := '';\r\n if FCursor <> nil then\r\n Result := FCursor.Value\r\n else\r\n if not FOwnTree.ReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclUnicodeStrTreeIterator.HasChild(Index: Integer): Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := (FCursor <> nil) and (Index >= 0) and (Index < FCursor.ChildrenCount);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclUnicodeStrTreeIterator.HasNext: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Valid then\r\n Result := GetNextCursor <> nil\r\n else\r\n Result := FCursor <> nil;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclUnicodeStrTreeIterator.HasParent: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := (FCursor <> nil) and (FCursor.Parent <> nil);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclUnicodeStrTreeIterator.HasPrevious: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Valid then\r\n Result := GetPreviousCursor <> nil\r\n else\r\n Result := FCursor <> nil;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclUnicodeStrTreeIterator.IndexOfChild(const AString: UnicodeString): Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FCursor <> nil then\r\n Result := FCursor.IndexOfValue(AString, FEqualityComparer)\r\n else\r\n Result := -1;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclUnicodeStrTreeIterator.Insert(const AString: UnicodeString): Boolean;\r\nvar\r\n ParentNode, NewNode: TJclUnicodeStrTreeNode;\r\n Index, I: Integer;\r\nbegin\r\n if FOwnTree.ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n // insert sibling or, if FCursor is root node, behave like TJclUnicodeStrTree.Insert\r\n Result := (FCursor <> nil) and (FOwnTree.AllowDefaultElements or not FEqualityComparer.ItemsEqual(AString, ''))\r\n and ((not FOwnTree.Contains(AString)) or FOwnTree.CheckDuplicate);\r\n\r\n if Result then\r\n begin\r\n if FCursor.Parent <> nil then\r\n begin\r\n ParentNode := FCursor.Parent;\r\n Index := 0;\r\n while (Index < ParentNode.ChildrenCount) and (ParentNode.Children[Index] <> FCursor) do\r\n Inc(Index);\r\n end\r\n else\r\n begin\r\n ParentNode := FCursor;\r\n Index := 0;\r\n end;\r\n\r\n if ParentNode.ChildrenCount = Length(ParentNode.Children) then\r\n SetLength(ParentNode.Children, FOwnTree.CalcGrowCapacity(Length(ParentNode.Children), ParentNode.ChildrenCount));\r\n if ParentNode.ChildrenCount < Length(ParentNode.Children) then\r\n begin\r\n NewNode := TJclUnicodeStrTreeNode.Create;\r\n NewNode.Value := AString;\r\n NewNode.Parent := ParentNode;\r\n for I := ParentNode.ChildrenCount - 1 downto Index do\r\n ParentNode.Children[I + 1] := ParentNode.Children[I];\r\n ParentNode.Children[Index] := NewNode;\r\n Inc(ParentNode.ChildrenCount);\r\n Inc(FOwnTree.FSize);\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.WriteUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclUnicodeStrTreeIterator.InsertChild(Index: Integer; const AString: UnicodeString): Boolean;\r\nvar\r\n NewNode: TJclUnicodeStrTreeNode;\r\n I: Integer;\r\nbegin\r\n if FOwnTree.ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n // insert sibling or, if FCursor is root node, behave like TJclUnicodeStrTree.Insert\r\n Result := (FCursor <> nil) and (FOwnTree.AllowDefaultElements or not FEqualityComparer.ItemsEqual(AString, ''))\r\n and ((not FOwnTree.Contains(AString)) or FOwnTree.CheckDuplicate);\r\n\r\n if Result then\r\n begin\r\n if FCursor.ChildrenCount = Length(FCursor.Children) then\r\n SetLength(FCursor.Children, FOwnTree.CalcGrowCapacity(Length(FCursor.Children), FCursor.ChildrenCount));\r\n if FCursor.ChildrenCount < Length(FCursor.Children) then\r\n begin\r\n NewNode := TJclUnicodeStrTreeNode.Create;\r\n NewNode.Value := AString;\r\n NewNode.Parent := FCursor;\r\n for I := FCursor.ChildrenCount - 1 downto Index do\r\n FCursor.Children[I + 1] := FCursor.Children[I];\r\n FCursor.Children[Index] := NewNode;\r\n Inc(FCursor.ChildrenCount);\r\n Inc(FOwnTree.FSize);\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.WriteUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclUnicodeStrTreeIterator.IteratorEquals(const AIterator: IJclUnicodeStrIterator): Boolean;\r\nvar\r\n Obj: TObject;\r\n ItrObj: TJclUnicodeStrTreeIterator;\r\nbegin\r\n Result := False;\r\n if AIterator = nil then\r\n Exit;\r\n Obj := AIterator.GetIteratorReference;\r\n if Obj is TJclUnicodeStrTreeIterator then\r\n begin\r\n ItrObj := TJclUnicodeStrTreeIterator(Obj);\r\n Result := (FOwnTree = ItrObj.FOwnTree) and (FCursor = ItrObj.FCursor) and (Valid = ItrObj.Valid);\r\n end;\r\nend;\r\n\r\n{$IFDEF SUPPORTS_FOR_IN}\r\nfunction TJclUnicodeStrTreeIterator.MoveNext: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Valid then\r\n FCursor := GetNextCursor\r\n else\r\n Valid := True;\r\n Result := FCursor <> nil;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n{$ENDIF SUPPORTS_FOR_IN}\r\n\r\nfunction TJclUnicodeStrTreeIterator.Next: UnicodeString;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Valid then\r\n FCursor := GetNextCursor\r\n else\r\n Valid := True;\r\n Result := '';\r\n if FCursor <> nil then\r\n Result := FCursor.Value\r\n else\r\n if not FOwnTree.ReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclUnicodeStrTreeIterator.NextIndex: Integer;\r\nbegin\r\n // No index\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nfunction TJclUnicodeStrTreeIterator.Parent: UnicodeString;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := '';\r\n if FCursor <> nil then\r\n FCursor := FCursor.Parent;\r\n if FCursor <> nil then\r\n Result := FCursor.Value\r\n else\r\n if not FOwnTree.ReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclUnicodeStrTreeIterator.Previous: UnicodeString;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Valid then\r\n FCursor := GetPreviousCursor\r\n else\r\n Valid := True;\r\n Result := '';\r\n if FCursor <> nil then\r\n Result := FCursor.Value\r\n else\r\n if not FOwnTree.ReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclUnicodeStrTreeIterator.PreviousIndex: Integer;\r\nbegin\r\n // No index\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nprocedure TJclUnicodeStrTreeIterator.Remove;\r\nvar\r\n OldCursor: TJclUnicodeStrTreeNode;\r\nbegin\r\n if FOwnTree.ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n CheckValid;\r\n Valid := False;\r\n OldCursor := FCursor;\r\n FCursor := GetNextSibling;\r\n if OldCursor <> nil then\r\n FOwnTree.RemoveNode(OldCursor);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.WriteUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclUnicodeStrTreeIterator.Reset;\r\nvar\r\n NewCursor: TJclUnicodeStrTreeNode;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Valid := False;\r\n case FStart of\r\n isFirst:\r\n begin\r\n NewCursor := FCursor;\r\n while NewCursor <> nil do\r\n begin\r\n NewCursor := GetPreviousCursor;\r\n if NewCursor <> nil then\r\n FCursor := NewCursor;\r\n end;\r\n end;\r\n isLast:\r\n begin\r\n NewCursor := FCursor;\r\n while NewCursor <> nil do\r\n begin\r\n NewCursor := GetNextCursor;\r\n if NewCursor <> nil then\r\n FCursor := NewCursor;\r\n end;\r\n end;\r\n isRoot:\r\n begin\r\n while (FCursor <> nil) and (FCursor.Parent <> nil) do\r\n FCursor := FCursor.Parent;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclUnicodeStrTreeIterator.SetChild(Index: Integer; const AString: UnicodeString);\r\nbegin\r\n if FOwnTree.ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if (FCursor <> nil) and (Index >= 0) and (Index < FCursor.ChildrenCount) then\r\n TJclUnicodeStrTreeNode(FCursor.Children[Index]).Value := AString\r\n else\r\n raise EJclOutOfBoundsError.Create;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.WriteUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclUnicodeStrTreeIterator.SetString(const AString: UnicodeString);\r\nbegin\r\n if FOwnTree.ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n CheckValid;\r\n if FCursor <> nil then\r\n begin\r\n FOwnTree.FreeString(FCursor.Value);\r\n FCursor.Value := AString;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.WriteUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\n//=== { TJclPreOrderUnicodeStrTreeIterator } ===================================================\r\n\r\nfunction TJclPreOrderUnicodeStrTreeIterator.CreateEmptyIterator: TJclAbstractIterator;\r\nbegin\r\n Result := TJclPreOrderUnicodeStrTreeIterator.Create(FOwnTree, FCursor, Valid, FStart);\r\nend;\r\n\r\nfunction TJclPreOrderUnicodeStrTreeIterator.GetNextCursor: TJclUnicodeStrTreeNode;\r\nvar\r\n LastRet: TJclUnicodeStrTreeNode;\r\nbegin\r\n Result := FCursor;\r\n if Result = nil then\r\n Exit;\r\n LastRet := Result;\r\n if Result.ChildrenCount > 0 then\r\n Result := TJclUnicodeStrTreeNode(Result.Children[0])\r\n else\r\n begin\r\n Result := Result.Parent;\r\n while (Result <> nil) and (Result.IndexOfChild(LastRet) = (Result.ChildrenCount - 1)) do\r\n begin\r\n LastRet := Result;\r\n Result := Result.Parent;\r\n end;\r\n if Result <> nil then // not root = return successor\r\n Result := TJclUnicodeStrTreeNode(Result.Children[Result.IndexOfChild(LastRet) + 1]);\r\n end;\r\nend;\r\n\r\nfunction TJclPreOrderUnicodeStrTreeIterator.GetNextSibling: TJclUnicodeStrTreeNode;\r\nvar\r\n LastRet: TJclUnicodeStrTreeNode;\r\nbegin\r\n Result := FCursor;\r\n if Result = nil then\r\n Exit;\r\n LastRet := Result;\r\n\r\n Result := Result.Parent;\r\n while (Result <> nil) and (Result.IndexOfChild(LastRet) = (Result.ChildrenCount - 1)) do\r\n begin\r\n LastRet := Result;\r\n Result := Result.Parent;\r\n end;\r\n if Result <> nil then // not root = return successor\r\n Result := TJclUnicodeStrTreeNode(Result.Children[Result.IndexOfChild(LastRet) + 1]);\r\nend;\r\n\r\nfunction TJclPreOrderUnicodeStrTreeIterator.GetPreviousCursor: TJclUnicodeStrTreeNode;\r\nvar\r\n LastRet: TJclUnicodeStrTreeNode;\r\nbegin\r\n Result := FCursor;\r\n if Result = nil then\r\n Exit;\r\n LastRet := Result;\r\n Result := Result.Parent;\r\n if (Result <> nil) and (Result.IndexOfChild(LastRet) > 0) then\r\n // come from Right\r\n begin\r\n Result := TJclUnicodeStrTreeNode(Result.Children[Result.IndexOfChild(LastRet) - 1]);\r\n while (Result.ChildrenCount > 0) do // descend down the tree\r\n Result := TJclUnicodeStrTreeNode(Result.Children[Result.ChildrenCount - 1]);\r\n end;\r\nend;\r\n\r\n//=== { TJclPostOrderUnicodeStrTreeIterator } ==================================================\r\n\r\nfunction TJclPostOrderUnicodeStrTreeIterator.CreateEmptyIterator: TJclAbstractIterator;\r\nbegin\r\n Result := TJclPostOrderUnicodeStrTreeIterator.Create(FOwnTree, FCursor, Valid, FStart);\r\nend;\r\n\r\nfunction TJclPostOrderUnicodeStrTreeIterator.GetNextCursor: TJclUnicodeStrTreeNode;\r\nvar\r\n LastRet: TJclUnicodeStrTreeNode;\r\nbegin\r\n Result := FCursor;\r\n if Result = nil then\r\n Exit;\r\n LastRet := Result;\r\n Result := Result.Parent;\r\n if (Result <> nil) and (Result.IndexOfChild(LastRet) <> (Result.ChildrenCount - 1)) then\r\n begin\r\n Result := TJclUnicodeStrTreeNode(Result.Children[Result.IndexOfChild(LastRet) + 1]);\r\n while Result.ChildrenCount > 0 do\r\n Result := TJclUnicodeStrTreeNode(Result.Children[0]);\r\n end;\r\nend;\r\n\r\nfunction TJclPostOrderUnicodeStrTreeIterator.GetNextSibling: TJclUnicodeStrTreeNode;\r\nvar\r\n LastRet: TJclUnicodeStrTreeNode;\r\nbegin\r\n Result := FCursor;\r\n if Result = nil then\r\n Exit;\r\n LastRet := Result;\r\n Result := Result.Parent;\r\n\r\n if (Result <> nil) and (Result.IndexOfChild(LastRet) <> (Result.ChildrenCount - 1)) then\r\n begin\r\n Result := TJclUnicodeStrTreeNode(Result.Children[Result.IndexOfChild(LastRet) + 1]);\r\n while Result.ChildrenCount > 0 do\r\n Result := TJclUnicodeStrTreeNode(Result.Children[0]);\r\n end;\r\nend;\r\n\r\nfunction TJclPostOrderUnicodeStrTreeIterator.GetPreviousCursor: TJclUnicodeStrTreeNode;\r\nvar\r\n LastRet: TJclUnicodeStrTreeNode;\r\nbegin\r\n Result := FCursor;\r\n if Result = nil then\r\n Exit;\r\n if Result.ChildrenCount > 0 then\r\n Result := TJclUnicodeStrTreeNode(Result.Children[Result.ChildrenCount - 1])\r\n else\r\n begin\r\n LastRet := Result;\r\n Result := Result.Parent;\r\n while (Result <> nil) and (Result.IndexOfChild(LastRet) = 0) do\r\n begin\r\n LastRet := Result;\r\n Result := Result.Parent;\r\n end;\r\n if Result <> nil then // not root\r\n Result := TJclUnicodeStrTreeNode(Result.Children[Result.IndexOfChild(LastRet) - 1]);\r\n end;\r\nend;\r\n{$ENDIF SUPPORTS_UNICODE_STRING}\r\n\r\n//=== { TJclSingleTreeNode } =======================================================\r\n\r\nfunction TJclSingleTreeNode.IndexOfChild(AChild: TJclSingleTreeNode): Integer;\r\nbegin\r\n for Result := 0 to ChildrenCount - 1 do\r\n if Children[Result] = AChild then\r\n Exit;\r\n Result := -1;\r\nend;\r\n\r\nfunction TJclSingleTreeNode.IndexOfValue(const AValue: Single;\r\n const AEqualityComparer: IJclSingleEqualityComparer): Integer;\r\nbegin\r\n for Result := 0 to ChildrenCount - 1 do\r\n if AEqualityComparer.ItemsEqual(TJclSingleTreeNode(Children[Result]).Value, AValue) then\r\n Exit;\r\n Result := -1;\r\nend;\r\n\r\n//=== { TJclSingleTree } =======================================================\r\n\r\nconstructor TJclSingleTree.Create();\r\nbegin\r\n inherited Create();\r\n FTraverseOrder := toPreOrder;\r\nend;\r\n\r\ndestructor TJclSingleTree.Destroy;\r\nbegin\r\n FReadOnly := False;\r\n Clear;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJclSingleTree.Add(const AValue: Single): Boolean;\r\nvar\r\n NewNode: TJclSingleTreeNode;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := AllowDefaultElements or not ItemsEqual(AValue, 0.0);\r\n\r\n if Result then\r\n begin\r\n if FRoot <> nil then\r\n begin\r\n Result := (not Contains(AValue)) or CheckDuplicate;\r\n if Result then\r\n begin\r\n if FRoot.ChildrenCount = Length(FRoot.Children) then\r\n SetLength(FRoot.Children, CalcGrowCapacity(Length(FRoot.Children), FRoot.ChildrenCount));\r\n if FRoot.ChildrenCount < Length(FRoot.Children) then\r\n begin\r\n NewNode := TJclSingleTreeNode.Create;\r\n NewNode.Value := AValue;\r\n NewNode.Parent := FRoot;\r\n FRoot.Children[FRoot.ChildrenCount] := NewNode;\r\n Inc(FRoot.ChildrenCount);\r\n Inc(FSize);\r\n end\r\n else\r\n Result := False;\r\n end;\r\n end\r\n else\r\n begin\r\n FRoot := TJclSingleTreeNode.Create;\r\n FRoot.Value := AValue;\r\n Inc(FSize);\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSingleTree.AddAll(const ACollection: IJclSingleCollection): Boolean;\r\nvar\r\n It: IJclSingleIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n Result := Add(It.Next) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclSingleTree.AssignDataTo(Dest: TJclAbstractContainerBase);\r\nvar\r\n ADest: TJclSingleTree;\r\n ACollection: IJclSingleCollection;\r\nbegin\r\n inherited AssignDataTo(Dest);\r\n if Dest is TJclSingleTree then\r\n begin\r\n ADest := TJclSingleTree(Dest);\r\n ADest.Clear;\r\n ADest.FSize := FSize;\r\n if FRoot <> nil then\r\n ADest.FRoot := CloneNode(FRoot, nil);\r\n end\r\n else\r\n if Supports(IInterface(Dest), IJclSingleCollection, ACollection) then\r\n begin\r\n ACollection.Clear;\r\n ACollection.AddAll(Self);\r\n end;\r\nend;\r\n\r\nprocedure TJclSingleTree.AssignPropertiesTo(Dest: TJclAbstractContainerBase);\r\nbegin\r\n inherited AssignPropertiesto(Dest);\r\n if Dest is TJclSingleTree then\r\n TJclSingleTree(Dest).FTraverseOrder := FTraverseOrder;\r\nend;\r\n\r\nprocedure TJclSingleTree.Clear;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FRoot <> nil then\r\n RemoveNode(FRoot);\r\n FSize := 0;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSingleTree.CloneNode(Node, Parent: TJclSingleTreeNode): TJclSingleTreeNode;\r\nvar\r\n Index: Integer;\r\nbegin\r\n Result := TJclSingleTreeNode.Create;\r\n Result.Value := Node.Value;\r\n Result.Parent := Parent;\r\n SetLength(Result.Children, Node.ChildrenCount);\r\n Result.ChildrenCount := Node.ChildrenCount;\r\n for Index := 0 to Node.ChildrenCount - 1 do\r\n Result.Children[Index] := CloneNode(TJclSingleTreeNode(Node.Children[Index]), Result); // recursive call\r\nend;\r\n\r\nfunction TJclSingleTree.CollectionEquals(const ACollection: IJclSingleCollection): Boolean;\r\nvar\r\n It, ItSelf: IJclSingleIterator;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n if FSize <> ACollection.Size then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n ItSelf := First;\r\n while ItSelf.HasNext do\r\n if not ItemsEqual(ItSelf.Next, It.Next) then\r\n begin\r\n Result := False;\r\n Break;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSingleTree.Contains(const AValue: Single): Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FRoot <> nil then\r\n Result := NodeContains(FRoot, AValue)\r\n else\r\n Result := False;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSingleTree.ContainsAll(const ACollection: IJclSingleCollection): Boolean;\r\nvar\r\n It: IJclSingleIterator;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := True;\r\n if ACollection = nil then\r\n Exit;\r\n It := ACollection.First;\r\n while Result and It.HasNext do\r\n Result := Contains(It.Next);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSingleTree.Extract(const AValue: Single): Boolean;\r\nvar\r\n It: IJclSingleIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := FRoot <> nil;\r\n if Result then\r\n begin\r\n It := First;\r\n while It.HasNext do\r\n if ItemsEqual(It.Next, AValue) then\r\n begin\r\n It.Extract;\r\n if RemoveSingleElement then\r\n Break;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSingleTree.ExtractAll(const ACollection: IJclSingleCollection): Boolean;\r\nvar\r\n It: IJclSingleIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n Result := Extract(It.Next) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclSingleTree.ExtractNode(var ANode: TJclSingleTreeNode);\r\nvar\r\n Index, ChildIndex, NewCapacity: Integer;\r\n Parent: TJclSingleTreeNode;\r\nbegin\r\n for Index := ANode.ChildrenCount - 1 downto 0 do\r\n {$IFDEF BCB}\r\n ExtractNode(TJclSingleTreeNode(ANode.Children[Index]));\r\n {$ELSE ~BCB}\r\n ExtractNode(ANode.Children[Index]);\r\n {$ENDIF ~BCB}\r\n Parent := ANode.Parent;\r\n if Parent <> nil then\r\n begin\r\n ChildIndex := Parent.IndexOfChild(ANode);\r\n for Index := ChildIndex + 1 to Parent.ChildrenCount - 1 do\r\n Parent.Children[Index - 1] := Parent.Children[Index];\r\n Dec(Parent.ChildrenCount);\r\n NewCapacity := CalcPackCapacity(Length(Parent.Children), Parent.ChildrenCount);\r\n if NewCapacity < Length(Parent.Children) then\r\n SetLength(Parent.Children, NewCapacity);\r\n FreeAndNil(ANode);\r\n end\r\n else\r\n begin\r\n FreeAndNil(ANode);\r\n FRoot := nil;\r\n end;\r\n Dec(FSize);\r\nend;\r\n\r\nfunction TJclSingleTree.First: IJclSingleIterator;\r\nvar\r\n Start: TJclSingleTreeNode;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Start := FRoot;\r\n case GetTraverseOrder of\r\n toPreOrder:\r\n Result := TJclPreOrderSingleTreeIterator.Create(Self, Start, False, isFirst);\r\n toPostOrder:\r\n begin\r\n if Start <> nil then\r\n while (Start.ChildrenCount > 0) do\r\n Start := TJclSingleTreeNode(Start.Children[0]);\r\n Result := TJclPostOrderSingleTreeIterator.Create(Self, Start, False, isFirst);\r\n end;\r\n else\r\n Result := nil;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\n{$IFDEF SUPPORTS_FOR_IN}\r\nfunction TJclSingleTree.GetEnumerator: IJclSingleIterator;\r\nbegin\r\n Result := First;\r\nend;\r\n{$ENDIF SUPPORTS_FOR_IN}\r\n\r\nfunction TJclSingleTree.GetRoot: IJclSingleTreeIterator;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n case GetTraverseOrder of\r\n toPreOrder:\r\n Result := TJclPreOrderSingleTreeIterator.Create(Self, FRoot, False, isRoot);\r\n toPostOrder:\r\n Result := TJclPostOrderSingleTreeIterator.Create(Self, FRoot, False, isRoot);\r\n else\r\n Result := nil;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSingleTree.GetTraverseOrder: TJclTraverseOrder;\r\nbegin\r\n Result := FTraverseOrder;\r\nend;\r\n\r\nfunction TJclSingleTree.IsEmpty: Boolean;\r\nbegin\r\n Result := FSize = 0;\r\nend;\r\n\r\nfunction TJclSingleTree.Last: IJclSingleIterator;\r\nvar\r\n Start: TJclSingleTreeNode;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Start := FRoot;\r\n case FTraverseOrder of\r\n toPreOrder:\r\n begin\r\n if Start <> nil then\r\n while Start.ChildrenCount > 0 do\r\n Start := TJclSingleTreeNode(Start.Children[Start.ChildrenCount - 1]);\r\n Result := TJclPreOrderSingleTreeIterator.Create(Self, Start, False, isLast);\r\n end;\r\n toPostOrder:\r\n Result := TJclPostOrderSingleTreeIterator.Create(Self, Start, False, isLast);\r\n else\r\n Result := nil;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSingleTree.NodeContains(ANode: TJclSingleTreeNode; const AValue: Single): Boolean;\r\nvar\r\n Index: Integer;\r\nbegin\r\n Result := ItemsEqual(ANode.Value, AValue);\r\n if not Result then\r\n for Index := 0 to ANode.ChildrenCount - 1 do\r\n begin\r\n Result := NodeContains(TJclSingleTreeNode(ANode.Children[Index]), AValue);\r\n if Result then\r\n Break;\r\n end;\r\nend;\r\n\r\nprocedure TJclSingleTree.Pack;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FRoot <> nil then\r\n PackNode(FRoot);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclSingleTree.PackNode(ANode: TJclSingleTreeNode);\r\nvar\r\n Index: Integer;\r\nbegin\r\n SetLength(ANode.Children, ANode.ChildrenCount);\r\n for Index := 0 to ANode.ChildrenCount - 1 do\r\n PackNode(TJclSingleTreeNode(ANode.Children[Index]));\r\nend;\r\n\r\nfunction TJclSingleTree.Remove(const AValue: Single): Boolean;\r\nvar\r\n Extracted: Single;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := Extract(AValue);\r\n if Result then\r\n begin\r\n Extracted := AValue;\r\n FreeSingle(Extracted);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSingleTree.RemoveAll(const ACollection: IJclSingleCollection): Boolean;\r\nvar\r\n It: IJclSingleIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n Result := Remove(It.Next) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclSingleTree.RemoveNode(var ANode: TJclSingleTreeNode);\r\nvar\r\n Index, ChildIndex, NewCapacity: Integer;\r\n Parent: TJclSingleTreeNode;\r\nbegin\r\n for Index := ANode.ChildrenCount - 1 downto 0 do\r\n {$IFDEF BCB}\r\n RemoveNode(TJclSingleTreeNode(ANode.Children[Index]));\r\n {$ELSE ~BCB}\r\n RemoveNode(ANode.Children[Index]);\r\n {$ENDIF ~BCB}\r\n FreeSingle(ANode.Value);\r\n Parent := ANode.Parent;\r\n if Parent <> nil then\r\n begin\r\n ChildIndex := Parent.IndexOfChild(ANode);\r\n for Index := ChildIndex + 1 to Parent.ChildrenCount - 1 do\r\n Parent.Children[Index - 1] := Parent.Children[Index];\r\n Dec(Parent.ChildrenCount);\r\n NewCapacity := CalcPackCapacity(Length(Parent.Children), Parent.ChildrenCount);\r\n if NewCapacity < Length(Parent.Children) then\r\n SetLength(Parent.Children, NewCapacity);\r\n FreeAndNil(ANode);\r\n end\r\n else\r\n begin\r\n FreeAndNil(ANode);\r\n FRoot := nil;\r\n end;\r\n Dec(FSize);\r\nend;\r\n\r\nfunction TJclSingleTree.RetainAll(const ACollection: IJclSingleCollection): Boolean;\r\nvar\r\n It: IJclSingleIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := First;\r\n while It.HasNext do\r\n if not ACollection.Contains(It.Next) then\r\n It.Remove;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclSingleTree.SetCapacity(Value: Integer);\r\nbegin\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nprocedure TJclSingleTree.SetTraverseOrder(Value: TJclTraverseOrder);\r\nbegin\r\n FTraverseOrder := Value;\r\nend;\r\n\r\nfunction TJclSingleTree.Size: Integer;\r\nbegin\r\n Result := FSize;\r\nend;\r\n\r\nfunction TJclSingleTree.CreateEmptyContainer: TJclAbstractContainerBase;\r\nbegin\r\n Result := TJclSingleTree.Create;\r\n AssignPropertiesTo(Result);\r\nend;\r\n\r\n//=== { TJclSingleTreeIterator } ===========================================================\r\n\r\nconstructor TJclSingleTreeIterator.Create(OwnTree: TJclSingleTree; ACursor: TJclSingleTreeNode; AValid: Boolean; AStart: TItrStart);\r\nbegin\r\n inherited Create(AValid);\r\n FCursor := ACursor;\r\n FOwnTree := OwnTree;\r\n FStart := AStart;\r\n FEqualityComparer := OwnTree as IJclSingleEqualityComparer;\r\nend;\r\n\r\nfunction TJclSingleTreeIterator.Add(const AValue: Single): Boolean;\r\nvar\r\n ParentNode, NewNode: TJclSingleTreeNode;\r\nbegin\r\n if FOwnTree.ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n // add sibling or, if FCursor is root node, behave like TJclSingleTree.Add\r\n Result := (FCursor <> nil) and (FOwnTree.AllowDefaultElements or not FEqualityComparer.ItemsEqual(AValue, 0.0))\r\n and ((not FOwnTree.Contains(AValue)) or FOwnTree.CheckDuplicate);\r\n\r\n if Result then\r\n begin\r\n ParentNode := FCursor.Parent;\r\n if ParentNode = nil then\r\n ParentNode := FCursor;\r\n\r\n if ParentNode.ChildrenCount = Length(ParentNode.Children) then\r\n SetLength(ParentNode.Children, FOwnTree.CalcGrowCapacity(Length(ParentNode.Children), ParentNode.ChildrenCount));\r\n if ParentNode.ChildrenCount < Length(ParentNode.Children) then\r\n begin\r\n NewNode := TJclSingleTreeNode.Create;\r\n NewNode.Value := AValue;\r\n NewNode.Parent := ParentNode;\r\n ParentNode.Children[ParentNode.ChildrenCount] := NewNode;\r\n Inc(ParentNode.ChildrenCount);\r\n Inc(FOwnTree.FSize);\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.WriteUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSingleTreeIterator.AddChild(const AValue: Single): Boolean;\r\nvar\r\n NewNode: TJclSingleTreeNode;\r\nbegin\r\n if FOwnTree.ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := (FCursor <> nil) and (FOwnTree.AllowDefaultElements or not FEqualityComparer.ItemsEqual(AValue, 0.0))\r\n and ((not FOwnTree.Contains(AValue)) or FOwnTree.CheckDuplicate);\r\n\r\n if Result then\r\n begin\r\n if FCursor.ChildrenCount = Length(FCursor.Children) then\r\n SetLength(FCursor.Children, FOwnTree.CalcGrowCapacity(Length(FCursor.Children), FCursor.ChildrenCount));\r\n if FCursor.ChildrenCount < Length(FCursor.Children) then\r\n begin\r\n NewNode := TJclSingleTreeNode.Create;\r\n NewNode.Value := AValue;\r\n NewNode.Parent := FCursor;\r\n FCursor.Children[FCursor.ChildrenCount] := NewNode;\r\n Inc(FCursor.ChildrenCount);\r\n Inc(FOwnTree.FSize);\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.WriteUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclSingleTreeIterator.AssignPropertiesTo(Dest: TJclAbstractIterator);\r\nvar\r\n ADest: TJclSingleTreeIterator;\r\nbegin\r\n inherited AssignPropertiesTo(Dest);\r\n if Dest is TJclSingleTreeIterator then\r\n begin\r\n ADest := TJclSingleTreeIterator(Dest);\r\n ADest.FCursor := FCursor;\r\n ADest.FOwnTree := FOwnTree;\r\n ADest.FEqualityComparer := FEqualityComparer;\r\n ADest.FStart := FStart;\r\n end;\r\nend;\r\n\r\nfunction TJclSingleTreeIterator.ChildrenCount: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FCursor <> nil then\r\n Result := FCursor.ChildrenCount\r\n else\r\n Result := 0;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclSingleTreeIterator.DeleteChild(Index: Integer);\r\nbegin\r\n if FOwnTree.ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if (FCursor <> nil) and (Index >= 0) and (Index < FCursor.ChildrenCount) then\r\n {$IFDEF BCB}\r\n FOwnTree.RemoveNode(TJclSingleTreeNode(FCursor.Children[Index]))\r\n {$ELSE ~BCB}\r\n FOwnTree.RemoveNode(FCursor.Children[Index])\r\n {$ENDIF ~BCB}\r\n else\r\n raise EJclOutOfBoundsError.Create;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.WriteUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclSingleTreeIterator.DeleteChildren;\r\nvar\r\n Index: Integer;\r\nbegin\r\n if FOwnTree.ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FCursor <> nil then\r\n begin\r\n for Index := FCursor.ChildrenCount - 1 downto 0 do\r\n {$IFDEF BCB}\r\n FOwnTree.RemoveNode(TJclSingleTreeNode(FCursor.Children[Index]));\r\n {$ELSE ~BCB}\r\n FOwnTree.RemoveNode(FCursor.Children[Index]);\r\n {$ENDIF ~BCB}\r\n SetLength(FCursor.Children, 0);\r\n FCursor.ChildrenCount := 0;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.WriteUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclSingleTreeIterator.Extract;\r\nvar\r\n OldCursor: TJclSingleTreeNode;\r\nbegin\r\n if FOwnTree.ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n CheckValid;\r\n Valid := False;\r\n OldCursor := FCursor;\r\n FCursor := GetNextSibling;\r\n if OldCursor <> nil then\r\n FOwnTree.ExtractNode(OldCursor);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.WriteUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclSingleTreeIterator.ExtractChild(Index: Integer);\r\nbegin\r\n if FOwnTree.ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if (FCursor <> nil) and (Index >= 0) and (Index < FCursor.ChildrenCount) then\r\n {$IFDEF BCB}\r\n FOwnTree.ExtractNode(TJclSingleTreeNode(FCursor.Children[Index]))\r\n {$ELSE ~BCB}\r\n FOwnTree.ExtractNode(FCursor.Children[Index])\r\n {$ENDIF ~BCB}\r\n else\r\n raise EJclOutOfBoundsError.Create;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.WriteUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclSingleTreeIterator.ExtractChildren;\r\nvar\r\n Index: Integer;\r\nbegin\r\n if FOwnTree.ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FCursor <> nil then\r\n begin\r\n for Index := FCursor.ChildrenCount - 1 downto 0 do\r\n {$IFDEF BCB}\r\n FOwnTree.ExtractNode(TJclSingleTreeNode(FCursor.Children[Index]));\r\n {$ELSE ~BCB}\r\n FOwnTree.ExtractNode(FCursor.Children[Index]);\r\n {$ENDIF ~BCB}\r\n SetLength(FCursor.Children, 0);\r\n FCursor.ChildrenCount := 0;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.WriteUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSingleTreeIterator.GetChild(Index: Integer): Single;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := 0.0;\r\n if (FCursor <> nil) and (Index >= 0) and (Index < FCursor.ChildrenCount) then\r\n FCursor := TJclSingleTreeNode(FCursor.Children[Index]);\r\n if FCursor <> nil then\r\n Result := FCursor.Value\r\n else\r\n if not FOwnTree.ReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSingleTreeIterator.GetValue: Single;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n CheckValid;\r\n Result := 0.0;\r\n if FCursor <> nil then\r\n Result := FCursor.Value\r\n else\r\n if not FOwnTree.ReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSingleTreeIterator.HasChild(Index: Integer): Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := (FCursor <> nil) and (Index >= 0) and (Index < FCursor.ChildrenCount);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSingleTreeIterator.HasNext: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Valid then\r\n Result := GetNextCursor <> nil\r\n else\r\n Result := FCursor <> nil;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSingleTreeIterator.HasParent: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := (FCursor <> nil) and (FCursor.Parent <> nil);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSingleTreeIterator.HasPrevious: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Valid then\r\n Result := GetPreviousCursor <> nil\r\n else\r\n Result := FCursor <> nil;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSingleTreeIterator.IndexOfChild(const AValue: Single): Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FCursor <> nil then\r\n Result := FCursor.IndexOfValue(AValue, FEqualityComparer)\r\n else\r\n Result := -1;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSingleTreeIterator.Insert(const AValue: Single): Boolean;\r\nvar\r\n ParentNode, NewNode: TJclSingleTreeNode;\r\n Index, I: Integer;\r\nbegin\r\n if FOwnTree.ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n // insert sibling or, if FCursor is root node, behave like TJclSingleTree.Insert\r\n Result := (FCursor <> nil) and (FOwnTree.AllowDefaultElements or not FEqualityComparer.ItemsEqual(AValue, 0.0))\r\n and ((not FOwnTree.Contains(AValue)) or FOwnTree.CheckDuplicate);\r\n\r\n if Result then\r\n begin\r\n if FCursor.Parent <> nil then\r\n begin\r\n ParentNode := FCursor.Parent;\r\n Index := 0;\r\n while (Index < ParentNode.ChildrenCount) and (ParentNode.Children[Index] <> FCursor) do\r\n Inc(Index);\r\n end\r\n else\r\n begin\r\n ParentNode := FCursor;\r\n Index := 0;\r\n end;\r\n\r\n if ParentNode.ChildrenCount = Length(ParentNode.Children) then\r\n SetLength(ParentNode.Children, FOwnTree.CalcGrowCapacity(Length(ParentNode.Children), ParentNode.ChildrenCount));\r\n if ParentNode.ChildrenCount < Length(ParentNode.Children) then\r\n begin\r\n NewNode := TJclSingleTreeNode.Create;\r\n NewNode.Value := AValue;\r\n NewNode.Parent := ParentNode;\r\n for I := ParentNode.ChildrenCount - 1 downto Index do\r\n ParentNode.Children[I + 1] := ParentNode.Children[I];\r\n ParentNode.Children[Index] := NewNode;\r\n Inc(ParentNode.ChildrenCount);\r\n Inc(FOwnTree.FSize);\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.WriteUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSingleTreeIterator.InsertChild(Index: Integer; const AValue: Single): Boolean;\r\nvar\r\n NewNode: TJclSingleTreeNode;\r\n I: Integer;\r\nbegin\r\n if FOwnTree.ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n // insert sibling or, if FCursor is root node, behave like TJclSingleTree.Insert\r\n Result := (FCursor <> nil) and (FOwnTree.AllowDefaultElements or not FEqualityComparer.ItemsEqual(AValue, 0.0))\r\n and ((not FOwnTree.Contains(AValue)) or FOwnTree.CheckDuplicate);\r\n\r\n if Result then\r\n begin\r\n if FCursor.ChildrenCount = Length(FCursor.Children) then\r\n SetLength(FCursor.Children, FOwnTree.CalcGrowCapacity(Length(FCursor.Children), FCursor.ChildrenCount));\r\n if FCursor.ChildrenCount < Length(FCursor.Children) then\r\n begin\r\n NewNode := TJclSingleTreeNode.Create;\r\n NewNode.Value := AValue;\r\n NewNode.Parent := FCursor;\r\n for I := FCursor.ChildrenCount - 1 downto Index do\r\n FCursor.Children[I + 1] := FCursor.Children[I];\r\n FCursor.Children[Index] := NewNode;\r\n Inc(FCursor.ChildrenCount);\r\n Inc(FOwnTree.FSize);\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.WriteUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSingleTreeIterator.IteratorEquals(const AIterator: IJclSingleIterator): Boolean;\r\nvar\r\n Obj: TObject;\r\n ItrObj: TJclSingleTreeIterator;\r\nbegin\r\n Result := False;\r\n if AIterator = nil then\r\n Exit;\r\n Obj := AIterator.GetIteratorReference;\r\n if Obj is TJclSingleTreeIterator then\r\n begin\r\n ItrObj := TJclSingleTreeIterator(Obj);\r\n Result := (FOwnTree = ItrObj.FOwnTree) and (FCursor = ItrObj.FCursor) and (Valid = ItrObj.Valid);\r\n end;\r\nend;\r\n\r\n{$IFDEF SUPPORTS_FOR_IN}\r\nfunction TJclSingleTreeIterator.MoveNext: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Valid then\r\n FCursor := GetNextCursor\r\n else\r\n Valid := True;\r\n Result := FCursor <> nil;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n{$ENDIF SUPPORTS_FOR_IN}\r\n\r\nfunction TJclSingleTreeIterator.Next: Single;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Valid then\r\n FCursor := GetNextCursor\r\n else\r\n Valid := True;\r\n Result := 0.0;\r\n if FCursor <> nil then\r\n Result := FCursor.Value\r\n else\r\n if not FOwnTree.ReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSingleTreeIterator.NextIndex: Integer;\r\nbegin\r\n // No index\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nfunction TJclSingleTreeIterator.Parent: Single;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := 0.0;\r\n if FCursor <> nil then\r\n FCursor := FCursor.Parent;\r\n if FCursor <> nil then\r\n Result := FCursor.Value\r\n else\r\n if not FOwnTree.ReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSingleTreeIterator.Previous: Single;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Valid then\r\n FCursor := GetPreviousCursor\r\n else\r\n Valid := True;\r\n Result := 0.0;\r\n if FCursor <> nil then\r\n Result := FCursor.Value\r\n else\r\n if not FOwnTree.ReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSingleTreeIterator.PreviousIndex: Integer;\r\nbegin\r\n // No index\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nprocedure TJclSingleTreeIterator.Remove;\r\nvar\r\n OldCursor: TJclSingleTreeNode;\r\nbegin\r\n if FOwnTree.ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n CheckValid;\r\n Valid := False;\r\n OldCursor := FCursor;\r\n FCursor := GetNextSibling;\r\n if OldCursor <> nil then\r\n FOwnTree.RemoveNode(OldCursor);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.WriteUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclSingleTreeIterator.Reset;\r\nvar\r\n NewCursor: TJclSingleTreeNode;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Valid := False;\r\n case FStart of\r\n isFirst:\r\n begin\r\n NewCursor := FCursor;\r\n while NewCursor <> nil do\r\n begin\r\n NewCursor := GetPreviousCursor;\r\n if NewCursor <> nil then\r\n FCursor := NewCursor;\r\n end;\r\n end;\r\n isLast:\r\n begin\r\n NewCursor := FCursor;\r\n while NewCursor <> nil do\r\n begin\r\n NewCursor := GetNextCursor;\r\n if NewCursor <> nil then\r\n FCursor := NewCursor;\r\n end;\r\n end;\r\n isRoot:\r\n begin\r\n while (FCursor <> nil) and (FCursor.Parent <> nil) do\r\n FCursor := FCursor.Parent;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclSingleTreeIterator.SetChild(Index: Integer; const AValue: Single);\r\nbegin\r\n if FOwnTree.ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if (FCursor <> nil) and (Index >= 0) and (Index < FCursor.ChildrenCount) then\r\n TJclSingleTreeNode(FCursor.Children[Index]).Value := AValue\r\n else\r\n raise EJclOutOfBoundsError.Create;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.WriteUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclSingleTreeIterator.SetValue(const AValue: Single);\r\nbegin\r\n if FOwnTree.ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n CheckValid;\r\n if FCursor <> nil then\r\n begin\r\n FOwnTree.FreeSingle(FCursor.Value);\r\n FCursor.Value := AValue;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.WriteUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\n//=== { TJclPreOrderSingleTreeIterator } ===================================================\r\n\r\nfunction TJclPreOrderSingleTreeIterator.CreateEmptyIterator: TJclAbstractIterator;\r\nbegin\r\n Result := TJclPreOrderSingleTreeIterator.Create(FOwnTree, FCursor, Valid, FStart);\r\nend;\r\n\r\nfunction TJclPreOrderSingleTreeIterator.GetNextCursor: TJclSingleTreeNode;\r\nvar\r\n LastRet: TJclSingleTreeNode;\r\nbegin\r\n Result := FCursor;\r\n if Result = nil then\r\n Exit;\r\n LastRet := Result;\r\n if Result.ChildrenCount > 0 then\r\n Result := TJclSingleTreeNode(Result.Children[0])\r\n else\r\n begin\r\n Result := Result.Parent;\r\n while (Result <> nil) and (Result.IndexOfChild(LastRet) = (Result.ChildrenCount - 1)) do\r\n begin\r\n LastRet := Result;\r\n Result := Result.Parent;\r\n end;\r\n if Result <> nil then // not root = return successor\r\n Result := TJclSingleTreeNode(Result.Children[Result.IndexOfChild(LastRet) + 1]);\r\n end;\r\nend;\r\n\r\nfunction TJclPreOrderSingleTreeIterator.GetNextSibling: TJclSingleTreeNode;\r\nvar\r\n LastRet: TJclSingleTreeNode;\r\nbegin\r\n Result := FCursor;\r\n if Result = nil then\r\n Exit;\r\n LastRet := Result;\r\n\r\n Result := Result.Parent;\r\n while (Result <> nil) and (Result.IndexOfChild(LastRet) = (Result.ChildrenCount - 1)) do\r\n begin\r\n LastRet := Result;\r\n Result := Result.Parent;\r\n end;\r\n if Result <> nil then // not root = return successor\r\n Result := TJclSingleTreeNode(Result.Children[Result.IndexOfChild(LastRet) + 1]);\r\nend;\r\n\r\nfunction TJclPreOrderSingleTreeIterator.GetPreviousCursor: TJclSingleTreeNode;\r\nvar\r\n LastRet: TJclSingleTreeNode;\r\nbegin\r\n Result := FCursor;\r\n if Result = nil then\r\n Exit;\r\n LastRet := Result;\r\n Result := Result.Parent;\r\n if (Result <> nil) and (Result.IndexOfChild(LastRet) > 0) then\r\n // come from Right\r\n begin\r\n Result := TJclSingleTreeNode(Result.Children[Result.IndexOfChild(LastRet) - 1]);\r\n while (Result.ChildrenCount > 0) do // descend down the tree\r\n Result := TJclSingleTreeNode(Result.Children[Result.ChildrenCount - 1]);\r\n end;\r\nend;\r\n\r\n//=== { TJclPostOrderSingleTreeIterator } ==================================================\r\n\r\nfunction TJclPostOrderSingleTreeIterator.CreateEmptyIterator: TJclAbstractIterator;\r\nbegin\r\n Result := TJclPostOrderSingleTreeIterator.Create(FOwnTree, FCursor, Valid, FStart);\r\nend;\r\n\r\nfunction TJclPostOrderSingleTreeIterator.GetNextCursor: TJclSingleTreeNode;\r\nvar\r\n LastRet: TJclSingleTreeNode;\r\nbegin\r\n Result := FCursor;\r\n if Result = nil then\r\n Exit;\r\n LastRet := Result;\r\n Result := Result.Parent;\r\n if (Result <> nil) and (Result.IndexOfChild(LastRet) <> (Result.ChildrenCount - 1)) then\r\n begin\r\n Result := TJclSingleTreeNode(Result.Children[Result.IndexOfChild(LastRet) + 1]);\r\n while Result.ChildrenCount > 0 do\r\n Result := TJclSingleTreeNode(Result.Children[0]);\r\n end;\r\nend;\r\n\r\nfunction TJclPostOrderSingleTreeIterator.GetNextSibling: TJclSingleTreeNode;\r\nvar\r\n LastRet: TJclSingleTreeNode;\r\nbegin\r\n Result := FCursor;\r\n if Result = nil then\r\n Exit;\r\n LastRet := Result;\r\n Result := Result.Parent;\r\n\r\n if (Result <> nil) and (Result.IndexOfChild(LastRet) <> (Result.ChildrenCount - 1)) then\r\n begin\r\n Result := TJclSingleTreeNode(Result.Children[Result.IndexOfChild(LastRet) + 1]);\r\n while Result.ChildrenCount > 0 do\r\n Result := TJclSingleTreeNode(Result.Children[0]);\r\n end;\r\nend;\r\n\r\nfunction TJclPostOrderSingleTreeIterator.GetPreviousCursor: TJclSingleTreeNode;\r\nvar\r\n LastRet: TJclSingleTreeNode;\r\nbegin\r\n Result := FCursor;\r\n if Result = nil then\r\n Exit;\r\n if Result.ChildrenCount > 0 then\r\n Result := TJclSingleTreeNode(Result.Children[Result.ChildrenCount - 1])\r\n else\r\n begin\r\n LastRet := Result;\r\n Result := Result.Parent;\r\n while (Result <> nil) and (Result.IndexOfChild(LastRet) = 0) do\r\n begin\r\n LastRet := Result;\r\n Result := Result.Parent;\r\n end;\r\n if Result <> nil then // not root\r\n Result := TJclSingleTreeNode(Result.Children[Result.IndexOfChild(LastRet) - 1]);\r\n end;\r\nend;\r\n\r\n//=== { TJclDoubleTreeNode } =======================================================\r\n\r\nfunction TJclDoubleTreeNode.IndexOfChild(AChild: TJclDoubleTreeNode): Integer;\r\nbegin\r\n for Result := 0 to ChildrenCount - 1 do\r\n if Children[Result] = AChild then\r\n Exit;\r\n Result := -1;\r\nend;\r\n\r\nfunction TJclDoubleTreeNode.IndexOfValue(const AValue: Double;\r\n const AEqualityComparer: IJclDoubleEqualityComparer): Integer;\r\nbegin\r\n for Result := 0 to ChildrenCount - 1 do\r\n if AEqualityComparer.ItemsEqual(TJclDoubleTreeNode(Children[Result]).Value, AValue) then\r\n Exit;\r\n Result := -1;\r\nend;\r\n\r\n//=== { TJclDoubleTree } =======================================================\r\n\r\nconstructor TJclDoubleTree.Create();\r\nbegin\r\n inherited Create();\r\n FTraverseOrder := toPreOrder;\r\nend;\r\n\r\ndestructor TJclDoubleTree.Destroy;\r\nbegin\r\n FReadOnly := False;\r\n Clear;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJclDoubleTree.Add(const AValue: Double): Boolean;\r\nvar\r\n NewNode: TJclDoubleTreeNode;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := AllowDefaultElements or not ItemsEqual(AValue, 0.0);\r\n\r\n if Result then\r\n begin\r\n if FRoot <> nil then\r\n begin\r\n Result := (not Contains(AValue)) or CheckDuplicate;\r\n if Result then\r\n begin\r\n if FRoot.ChildrenCount = Length(FRoot.Children) then\r\n SetLength(FRoot.Children, CalcGrowCapacity(Length(FRoot.Children), FRoot.ChildrenCount));\r\n if FRoot.ChildrenCount < Length(FRoot.Children) then\r\n begin\r\n NewNode := TJclDoubleTreeNode.Create;\r\n NewNode.Value := AValue;\r\n NewNode.Parent := FRoot;\r\n FRoot.Children[FRoot.ChildrenCount] := NewNode;\r\n Inc(FRoot.ChildrenCount);\r\n Inc(FSize);\r\n end\r\n else\r\n Result := False;\r\n end;\r\n end\r\n else\r\n begin\r\n FRoot := TJclDoubleTreeNode.Create;\r\n FRoot.Value := AValue;\r\n Inc(FSize);\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclDoubleTree.AddAll(const ACollection: IJclDoubleCollection): Boolean;\r\nvar\r\n It: IJclDoubleIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n Result := Add(It.Next) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclDoubleTree.AssignDataTo(Dest: TJclAbstractContainerBase);\r\nvar\r\n ADest: TJclDoubleTree;\r\n ACollection: IJclDoubleCollection;\r\nbegin\r\n inherited AssignDataTo(Dest);\r\n if Dest is TJclDoubleTree then\r\n begin\r\n ADest := TJclDoubleTree(Dest);\r\n ADest.Clear;\r\n ADest.FSize := FSize;\r\n if FRoot <> nil then\r\n ADest.FRoot := CloneNode(FRoot, nil);\r\n end\r\n else\r\n if Supports(IInterface(Dest), IJclDoubleCollection, ACollection) then\r\n begin\r\n ACollection.Clear;\r\n ACollection.AddAll(Self);\r\n end;\r\nend;\r\n\r\nprocedure TJclDoubleTree.AssignPropertiesTo(Dest: TJclAbstractContainerBase);\r\nbegin\r\n inherited AssignPropertiesto(Dest);\r\n if Dest is TJclDoubleTree then\r\n TJclDoubleTree(Dest).FTraverseOrder := FTraverseOrder;\r\nend;\r\n\r\nprocedure TJclDoubleTree.Clear;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FRoot <> nil then\r\n RemoveNode(FRoot);\r\n FSize := 0;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclDoubleTree.CloneNode(Node, Parent: TJclDoubleTreeNode): TJclDoubleTreeNode;\r\nvar\r\n Index: Integer;\r\nbegin\r\n Result := TJclDoubleTreeNode.Create;\r\n Result.Value := Node.Value;\r\n Result.Parent := Parent;\r\n SetLength(Result.Children, Node.ChildrenCount);\r\n Result.ChildrenCount := Node.ChildrenCount;\r\n for Index := 0 to Node.ChildrenCount - 1 do\r\n Result.Children[Index] := CloneNode(TJclDoubleTreeNode(Node.Children[Index]), Result); // recursive call\r\nend;\r\n\r\nfunction TJclDoubleTree.CollectionEquals(const ACollection: IJclDoubleCollection): Boolean;\r\nvar\r\n It, ItSelf: IJclDoubleIterator;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n if FSize <> ACollection.Size then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n ItSelf := First;\r\n while ItSelf.HasNext do\r\n if not ItemsEqual(ItSelf.Next, It.Next) then\r\n begin\r\n Result := False;\r\n Break;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclDoubleTree.Contains(const AValue: Double): Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FRoot <> nil then\r\n Result := NodeContains(FRoot, AValue)\r\n else\r\n Result := False;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclDoubleTree.ContainsAll(const ACollection: IJclDoubleCollection): Boolean;\r\nvar\r\n It: IJclDoubleIterator;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := True;\r\n if ACollection = nil then\r\n Exit;\r\n It := ACollection.First;\r\n while Result and It.HasNext do\r\n Result := Contains(It.Next);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclDoubleTree.Extract(const AValue: Double): Boolean;\r\nvar\r\n It: IJclDoubleIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := FRoot <> nil;\r\n if Result then\r\n begin\r\n It := First;\r\n while It.HasNext do\r\n if ItemsEqual(It.Next, AValue) then\r\n begin\r\n It.Extract;\r\n if RemoveSingleElement then\r\n Break;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclDoubleTree.ExtractAll(const ACollection: IJclDoubleCollection): Boolean;\r\nvar\r\n It: IJclDoubleIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n Result := Extract(It.Next) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclDoubleTree.ExtractNode(var ANode: TJclDoubleTreeNode);\r\nvar\r\n Index, ChildIndex, NewCapacity: Integer;\r\n Parent: TJclDoubleTreeNode;\r\nbegin\r\n for Index := ANode.ChildrenCount - 1 downto 0 do\r\n {$IFDEF BCB}\r\n ExtractNode(TJclDoubleTreeNode(ANode.Children[Index]));\r\n {$ELSE ~BCB}\r\n ExtractNode(ANode.Children[Index]);\r\n {$ENDIF ~BCB}\r\n Parent := ANode.Parent;\r\n if Parent <> nil then\r\n begin\r\n ChildIndex := Parent.IndexOfChild(ANode);\r\n for Index := ChildIndex + 1 to Parent.ChildrenCount - 1 do\r\n Parent.Children[Index - 1] := Parent.Children[Index];\r\n Dec(Parent.ChildrenCount);\r\n NewCapacity := CalcPackCapacity(Length(Parent.Children), Parent.ChildrenCount);\r\n if NewCapacity < Length(Parent.Children) then\r\n SetLength(Parent.Children, NewCapacity);\r\n FreeAndNil(ANode);\r\n end\r\n else\r\n begin\r\n FreeAndNil(ANode);\r\n FRoot := nil;\r\n end;\r\n Dec(FSize);\r\nend;\r\n\r\nfunction TJclDoubleTree.First: IJclDoubleIterator;\r\nvar\r\n Start: TJclDoubleTreeNode;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Start := FRoot;\r\n case GetTraverseOrder of\r\n toPreOrder:\r\n Result := TJclPreOrderDoubleTreeIterator.Create(Self, Start, False, isFirst);\r\n toPostOrder:\r\n begin\r\n if Start <> nil then\r\n while (Start.ChildrenCount > 0) do\r\n Start := TJclDoubleTreeNode(Start.Children[0]);\r\n Result := TJclPostOrderDoubleTreeIterator.Create(Self, Start, False, isFirst);\r\n end;\r\n else\r\n Result := nil;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\n{$IFDEF SUPPORTS_FOR_IN}\r\nfunction TJclDoubleTree.GetEnumerator: IJclDoubleIterator;\r\nbegin\r\n Result := First;\r\nend;\r\n{$ENDIF SUPPORTS_FOR_IN}\r\n\r\nfunction TJclDoubleTree.GetRoot: IJclDoubleTreeIterator;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n case GetTraverseOrder of\r\n toPreOrder:\r\n Result := TJclPreOrderDoubleTreeIterator.Create(Self, FRoot, False, isRoot);\r\n toPostOrder:\r\n Result := TJclPostOrderDoubleTreeIterator.Create(Self, FRoot, False, isRoot);\r\n else\r\n Result := nil;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclDoubleTree.GetTraverseOrder: TJclTraverseOrder;\r\nbegin\r\n Result := FTraverseOrder;\r\nend;\r\n\r\nfunction TJclDoubleTree.IsEmpty: Boolean;\r\nbegin\r\n Result := FSize = 0;\r\nend;\r\n\r\nfunction TJclDoubleTree.Last: IJclDoubleIterator;\r\nvar\r\n Start: TJclDoubleTreeNode;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Start := FRoot;\r\n case FTraverseOrder of\r\n toPreOrder:\r\n begin\r\n if Start <> nil then\r\n while Start.ChildrenCount > 0 do\r\n Start := TJclDoubleTreeNode(Start.Children[Start.ChildrenCount - 1]);\r\n Result := TJclPreOrderDoubleTreeIterator.Create(Self, Start, False, isLast);\r\n end;\r\n toPostOrder:\r\n Result := TJclPostOrderDoubleTreeIterator.Create(Self, Start, False, isLast);\r\n else\r\n Result := nil;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclDoubleTree.NodeContains(ANode: TJclDoubleTreeNode; const AValue: Double): Boolean;\r\nvar\r\n Index: Integer;\r\nbegin\r\n Result := ItemsEqual(ANode.Value, AValue);\r\n if not Result then\r\n for Index := 0 to ANode.ChildrenCount - 1 do\r\n begin\r\n Result := NodeContains(TJclDoubleTreeNode(ANode.Children[Index]), AValue);\r\n if Result then\r\n Break;\r\n end;\r\nend;\r\n\r\nprocedure TJclDoubleTree.Pack;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FRoot <> nil then\r\n PackNode(FRoot);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclDoubleTree.PackNode(ANode: TJclDoubleTreeNode);\r\nvar\r\n Index: Integer;\r\nbegin\r\n SetLength(ANode.Children, ANode.ChildrenCount);\r\n for Index := 0 to ANode.ChildrenCount - 1 do\r\n PackNode(TJclDoubleTreeNode(ANode.Children[Index]));\r\nend;\r\n\r\nfunction TJclDoubleTree.Remove(const AValue: Double): Boolean;\r\nvar\r\n Extracted: Double;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := Extract(AValue);\r\n if Result then\r\n begin\r\n Extracted := AValue;\r\n FreeDouble(Extracted);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclDoubleTree.RemoveAll(const ACollection: IJclDoubleCollection): Boolean;\r\nvar\r\n It: IJclDoubleIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n Result := Remove(It.Next) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclDoubleTree.RemoveNode(var ANode: TJclDoubleTreeNode);\r\nvar\r\n Index, ChildIndex, NewCapacity: Integer;\r\n Parent: TJclDoubleTreeNode;\r\nbegin\r\n for Index := ANode.ChildrenCount - 1 downto 0 do\r\n {$IFDEF BCB}\r\n RemoveNode(TJclDoubleTreeNode(ANode.Children[Index]));\r\n {$ELSE ~BCB}\r\n RemoveNode(ANode.Children[Index]);\r\n {$ENDIF ~BCB}\r\n FreeDouble(ANode.Value);\r\n Parent := ANode.Parent;\r\n if Parent <> nil then\r\n begin\r\n ChildIndex := Parent.IndexOfChild(ANode);\r\n for Index := ChildIndex + 1 to Parent.ChildrenCount - 1 do\r\n Parent.Children[Index - 1] := Parent.Children[Index];\r\n Dec(Parent.ChildrenCount);\r\n NewCapacity := CalcPackCapacity(Length(Parent.Children), Parent.ChildrenCount);\r\n if NewCapacity < Length(Parent.Children) then\r\n SetLength(Parent.Children, NewCapacity);\r\n FreeAndNil(ANode);\r\n end\r\n else\r\n begin\r\n FreeAndNil(ANode);\r\n FRoot := nil;\r\n end;\r\n Dec(FSize);\r\nend;\r\n\r\nfunction TJclDoubleTree.RetainAll(const ACollection: IJclDoubleCollection): Boolean;\r\nvar\r\n It: IJclDoubleIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := First;\r\n while It.HasNext do\r\n if not ACollection.Contains(It.Next) then\r\n It.Remove;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclDoubleTree.SetCapacity(Value: Integer);\r\nbegin\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nprocedure TJclDoubleTree.SetTraverseOrder(Value: TJclTraverseOrder);\r\nbegin\r\n FTraverseOrder := Value;\r\nend;\r\n\r\nfunction TJclDoubleTree.Size: Integer;\r\nbegin\r\n Result := FSize;\r\nend;\r\n\r\nfunction TJclDoubleTree.CreateEmptyContainer: TJclAbstractContainerBase;\r\nbegin\r\n Result := TJclDoubleTree.Create;\r\n AssignPropertiesTo(Result);\r\nend;\r\n\r\n//=== { TJclDoubleTreeIterator } ===========================================================\r\n\r\nconstructor TJclDoubleTreeIterator.Create(OwnTree: TJclDoubleTree; ACursor: TJclDoubleTreeNode; AValid: Boolean; AStart: TItrStart);\r\nbegin\r\n inherited Create(AValid);\r\n FCursor := ACursor;\r\n FOwnTree := OwnTree;\r\n FStart := AStart;\r\n FEqualityComparer := OwnTree as IJclDoubleEqualityComparer;\r\nend;\r\n\r\nfunction TJclDoubleTreeIterator.Add(const AValue: Double): Boolean;\r\nvar\r\n ParentNode, NewNode: TJclDoubleTreeNode;\r\nbegin\r\n if FOwnTree.ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n // add sibling or, if FCursor is root node, behave like TJclDoubleTree.Add\r\n Result := (FCursor <> nil) and (FOwnTree.AllowDefaultElements or not FEqualityComparer.ItemsEqual(AValue, 0.0))\r\n and ((not FOwnTree.Contains(AValue)) or FOwnTree.CheckDuplicate);\r\n\r\n if Result then\r\n begin\r\n ParentNode := FCursor.Parent;\r\n if ParentNode = nil then\r\n ParentNode := FCursor;\r\n\r\n if ParentNode.ChildrenCount = Length(ParentNode.Children) then\r\n SetLength(ParentNode.Children, FOwnTree.CalcGrowCapacity(Length(ParentNode.Children), ParentNode.ChildrenCount));\r\n if ParentNode.ChildrenCount < Length(ParentNode.Children) then\r\n begin\r\n NewNode := TJclDoubleTreeNode.Create;\r\n NewNode.Value := AValue;\r\n NewNode.Parent := ParentNode;\r\n ParentNode.Children[ParentNode.ChildrenCount] := NewNode;\r\n Inc(ParentNode.ChildrenCount);\r\n Inc(FOwnTree.FSize);\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.WriteUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclDoubleTreeIterator.AddChild(const AValue: Double): Boolean;\r\nvar\r\n NewNode: TJclDoubleTreeNode;\r\nbegin\r\n if FOwnTree.ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := (FCursor <> nil) and (FOwnTree.AllowDefaultElements or not FEqualityComparer.ItemsEqual(AValue, 0.0))\r\n and ((not FOwnTree.Contains(AValue)) or FOwnTree.CheckDuplicate);\r\n\r\n if Result then\r\n begin\r\n if FCursor.ChildrenCount = Length(FCursor.Children) then\r\n SetLength(FCursor.Children, FOwnTree.CalcGrowCapacity(Length(FCursor.Children), FCursor.ChildrenCount));\r\n if FCursor.ChildrenCount < Length(FCursor.Children) then\r\n begin\r\n NewNode := TJclDoubleTreeNode.Create;\r\n NewNode.Value := AValue;\r\n NewNode.Parent := FCursor;\r\n FCursor.Children[FCursor.ChildrenCount] := NewNode;\r\n Inc(FCursor.ChildrenCount);\r\n Inc(FOwnTree.FSize);\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.WriteUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclDoubleTreeIterator.AssignPropertiesTo(Dest: TJclAbstractIterator);\r\nvar\r\n ADest: TJclDoubleTreeIterator;\r\nbegin\r\n inherited AssignPropertiesTo(Dest);\r\n if Dest is TJclDoubleTreeIterator then\r\n begin\r\n ADest := TJclDoubleTreeIterator(Dest);\r\n ADest.FCursor := FCursor;\r\n ADest.FOwnTree := FOwnTree;\r\n ADest.FEqualityComparer := FEqualityComparer;\r\n ADest.FStart := FStart;\r\n end;\r\nend;\r\n\r\nfunction TJclDoubleTreeIterator.ChildrenCount: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FCursor <> nil then\r\n Result := FCursor.ChildrenCount\r\n else\r\n Result := 0;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclDoubleTreeIterator.DeleteChild(Index: Integer);\r\nbegin\r\n if FOwnTree.ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if (FCursor <> nil) and (Index >= 0) and (Index < FCursor.ChildrenCount) then\r\n {$IFDEF BCB}\r\n FOwnTree.RemoveNode(TJclDoubleTreeNode(FCursor.Children[Index]))\r\n {$ELSE ~BCB}\r\n FOwnTree.RemoveNode(FCursor.Children[Index])\r\n {$ENDIF ~BCB}\r\n else\r\n raise EJclOutOfBoundsError.Create;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.WriteUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclDoubleTreeIterator.DeleteChildren;\r\nvar\r\n Index: Integer;\r\nbegin\r\n if FOwnTree.ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FCursor <> nil then\r\n begin\r\n for Index := FCursor.ChildrenCount - 1 downto 0 do\r\n {$IFDEF BCB}\r\n FOwnTree.RemoveNode(TJclDoubleTreeNode(FCursor.Children[Index]));\r\n {$ELSE ~BCB}\r\n FOwnTree.RemoveNode(FCursor.Children[Index]);\r\n {$ENDIF ~BCB}\r\n SetLength(FCursor.Children, 0);\r\n FCursor.ChildrenCount := 0;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.WriteUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclDoubleTreeIterator.Extract;\r\nvar\r\n OldCursor: TJclDoubleTreeNode;\r\nbegin\r\n if FOwnTree.ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n CheckValid;\r\n Valid := False;\r\n OldCursor := FCursor;\r\n FCursor := GetNextSibling;\r\n if OldCursor <> nil then\r\n FOwnTree.ExtractNode(OldCursor);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.WriteUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclDoubleTreeIterator.ExtractChild(Index: Integer);\r\nbegin\r\n if FOwnTree.ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if (FCursor <> nil) and (Index >= 0) and (Index < FCursor.ChildrenCount) then\r\n {$IFDEF BCB}\r\n FOwnTree.ExtractNode(TJclDoubleTreeNode(FCursor.Children[Index]))\r\n {$ELSE ~BCB}\r\n FOwnTree.ExtractNode(FCursor.Children[Index])\r\n {$ENDIF ~BCB}\r\n else\r\n raise EJclOutOfBoundsError.Create;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.WriteUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclDoubleTreeIterator.ExtractChildren;\r\nvar\r\n Index: Integer;\r\nbegin\r\n if FOwnTree.ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FCursor <> nil then\r\n begin\r\n for Index := FCursor.ChildrenCount - 1 downto 0 do\r\n {$IFDEF BCB}\r\n FOwnTree.ExtractNode(TJclDoubleTreeNode(FCursor.Children[Index]));\r\n {$ELSE ~BCB}\r\n FOwnTree.ExtractNode(FCursor.Children[Index]);\r\n {$ENDIF ~BCB}\r\n SetLength(FCursor.Children, 0);\r\n FCursor.ChildrenCount := 0;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.WriteUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclDoubleTreeIterator.GetChild(Index: Integer): Double;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := 0.0;\r\n if (FCursor <> nil) and (Index >= 0) and (Index < FCursor.ChildrenCount) then\r\n FCursor := TJclDoubleTreeNode(FCursor.Children[Index]);\r\n if FCursor <> nil then\r\n Result := FCursor.Value\r\n else\r\n if not FOwnTree.ReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclDoubleTreeIterator.GetValue: Double;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n CheckValid;\r\n Result := 0.0;\r\n if FCursor <> nil then\r\n Result := FCursor.Value\r\n else\r\n if not FOwnTree.ReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclDoubleTreeIterator.HasChild(Index: Integer): Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := (FCursor <> nil) and (Index >= 0) and (Index < FCursor.ChildrenCount);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclDoubleTreeIterator.HasNext: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Valid then\r\n Result := GetNextCursor <> nil\r\n else\r\n Result := FCursor <> nil;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclDoubleTreeIterator.HasParent: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := (FCursor <> nil) and (FCursor.Parent <> nil);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclDoubleTreeIterator.HasPrevious: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Valid then\r\n Result := GetPreviousCursor <> nil\r\n else\r\n Result := FCursor <> nil;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclDoubleTreeIterator.IndexOfChild(const AValue: Double): Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FCursor <> nil then\r\n Result := FCursor.IndexOfValue(AValue, FEqualityComparer)\r\n else\r\n Result := -1;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclDoubleTreeIterator.Insert(const AValue: Double): Boolean;\r\nvar\r\n ParentNode, NewNode: TJclDoubleTreeNode;\r\n Index, I: Integer;\r\nbegin\r\n if FOwnTree.ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n // insert sibling or, if FCursor is root node, behave like TJclDoubleTree.Insert\r\n Result := (FCursor <> nil) and (FOwnTree.AllowDefaultElements or not FEqualityComparer.ItemsEqual(AValue, 0.0))\r\n and ((not FOwnTree.Contains(AValue)) or FOwnTree.CheckDuplicate);\r\n\r\n if Result then\r\n begin\r\n if FCursor.Parent <> nil then\r\n begin\r\n ParentNode := FCursor.Parent;\r\n Index := 0;\r\n while (Index < ParentNode.ChildrenCount) and (ParentNode.Children[Index] <> FCursor) do\r\n Inc(Index);\r\n end\r\n else\r\n begin\r\n ParentNode := FCursor;\r\n Index := 0;\r\n end;\r\n\r\n if ParentNode.ChildrenCount = Length(ParentNode.Children) then\r\n SetLength(ParentNode.Children, FOwnTree.CalcGrowCapacity(Length(ParentNode.Children), ParentNode.ChildrenCount));\r\n if ParentNode.ChildrenCount < Length(ParentNode.Children) then\r\n begin\r\n NewNode := TJclDoubleTreeNode.Create;\r\n NewNode.Value := AValue;\r\n NewNode.Parent := ParentNode;\r\n for I := ParentNode.ChildrenCount - 1 downto Index do\r\n ParentNode.Children[I + 1] := ParentNode.Children[I];\r\n ParentNode.Children[Index] := NewNode;\r\n Inc(ParentNode.ChildrenCount);\r\n Inc(FOwnTree.FSize);\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.WriteUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclDoubleTreeIterator.InsertChild(Index: Integer; const AValue: Double): Boolean;\r\nvar\r\n NewNode: TJclDoubleTreeNode;\r\n I: Integer;\r\nbegin\r\n if FOwnTree.ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n // insert sibling or, if FCursor is root node, behave like TJclDoubleTree.Insert\r\n Result := (FCursor <> nil) and (FOwnTree.AllowDefaultElements or not FEqualityComparer.ItemsEqual(AValue, 0.0))\r\n and ((not FOwnTree.Contains(AValue)) or FOwnTree.CheckDuplicate);\r\n\r\n if Result then\r\n begin\r\n if FCursor.ChildrenCount = Length(FCursor.Children) then\r\n SetLength(FCursor.Children, FOwnTree.CalcGrowCapacity(Length(FCursor.Children), FCursor.ChildrenCount));\r\n if FCursor.ChildrenCount < Length(FCursor.Children) then\r\n begin\r\n NewNode := TJclDoubleTreeNode.Create;\r\n NewNode.Value := AValue;\r\n NewNode.Parent := FCursor;\r\n for I := FCursor.ChildrenCount - 1 downto Index do\r\n FCursor.Children[I + 1] := FCursor.Children[I];\r\n FCursor.Children[Index] := NewNode;\r\n Inc(FCursor.ChildrenCount);\r\n Inc(FOwnTree.FSize);\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.WriteUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclDoubleTreeIterator.IteratorEquals(const AIterator: IJclDoubleIterator): Boolean;\r\nvar\r\n Obj: TObject;\r\n ItrObj: TJclDoubleTreeIterator;\r\nbegin\r\n Result := False;\r\n if AIterator = nil then\r\n Exit;\r\n Obj := AIterator.GetIteratorReference;\r\n if Obj is TJclDoubleTreeIterator then\r\n begin\r\n ItrObj := TJclDoubleTreeIterator(Obj);\r\n Result := (FOwnTree = ItrObj.FOwnTree) and (FCursor = ItrObj.FCursor) and (Valid = ItrObj.Valid);\r\n end;\r\nend;\r\n\r\n{$IFDEF SUPPORTS_FOR_IN}\r\nfunction TJclDoubleTreeIterator.MoveNext: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Valid then\r\n FCursor := GetNextCursor\r\n else\r\n Valid := True;\r\n Result := FCursor <> nil;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n{$ENDIF SUPPORTS_FOR_IN}\r\n\r\nfunction TJclDoubleTreeIterator.Next: Double;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Valid then\r\n FCursor := GetNextCursor\r\n else\r\n Valid := True;\r\n Result := 0.0;\r\n if FCursor <> nil then\r\n Result := FCursor.Value\r\n else\r\n if not FOwnTree.ReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclDoubleTreeIterator.NextIndex: Integer;\r\nbegin\r\n // No index\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nfunction TJclDoubleTreeIterator.Parent: Double;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := 0.0;\r\n if FCursor <> nil then\r\n FCursor := FCursor.Parent;\r\n if FCursor <> nil then\r\n Result := FCursor.Value\r\n else\r\n if not FOwnTree.ReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclDoubleTreeIterator.Previous: Double;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Valid then\r\n FCursor := GetPreviousCursor\r\n else\r\n Valid := True;\r\n Result := 0.0;\r\n if FCursor <> nil then\r\n Result := FCursor.Value\r\n else\r\n if not FOwnTree.ReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclDoubleTreeIterator.PreviousIndex: Integer;\r\nbegin\r\n // No index\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nprocedure TJclDoubleTreeIterator.Remove;\r\nvar\r\n OldCursor: TJclDoubleTreeNode;\r\nbegin\r\n if FOwnTree.ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n CheckValid;\r\n Valid := False;\r\n OldCursor := FCursor;\r\n FCursor := GetNextSibling;\r\n if OldCursor <> nil then\r\n FOwnTree.RemoveNode(OldCursor);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.WriteUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclDoubleTreeIterator.Reset;\r\nvar\r\n NewCursor: TJclDoubleTreeNode;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Valid := False;\r\n case FStart of\r\n isFirst:\r\n begin\r\n NewCursor := FCursor;\r\n while NewCursor <> nil do\r\n begin\r\n NewCursor := GetPreviousCursor;\r\n if NewCursor <> nil then\r\n FCursor := NewCursor;\r\n end;\r\n end;\r\n isLast:\r\n begin\r\n NewCursor := FCursor;\r\n while NewCursor <> nil do\r\n begin\r\n NewCursor := GetNextCursor;\r\n if NewCursor <> nil then\r\n FCursor := NewCursor;\r\n end;\r\n end;\r\n isRoot:\r\n begin\r\n while (FCursor <> nil) and (FCursor.Parent <> nil) do\r\n FCursor := FCursor.Parent;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclDoubleTreeIterator.SetChild(Index: Integer; const AValue: Double);\r\nbegin\r\n if FOwnTree.ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if (FCursor <> nil) and (Index >= 0) and (Index < FCursor.ChildrenCount) then\r\n TJclDoubleTreeNode(FCursor.Children[Index]).Value := AValue\r\n else\r\n raise EJclOutOfBoundsError.Create;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.WriteUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclDoubleTreeIterator.SetValue(const AValue: Double);\r\nbegin\r\n if FOwnTree.ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n CheckValid;\r\n if FCursor <> nil then\r\n begin\r\n FOwnTree.FreeDouble(FCursor.Value);\r\n FCursor.Value := AValue;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.WriteUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\n//=== { TJclPreOrderDoubleTreeIterator } ===================================================\r\n\r\nfunction TJclPreOrderDoubleTreeIterator.CreateEmptyIterator: TJclAbstractIterator;\r\nbegin\r\n Result := TJclPreOrderDoubleTreeIterator.Create(FOwnTree, FCursor, Valid, FStart);\r\nend;\r\n\r\nfunction TJclPreOrderDoubleTreeIterator.GetNextCursor: TJclDoubleTreeNode;\r\nvar\r\n LastRet: TJclDoubleTreeNode;\r\nbegin\r\n Result := FCursor;\r\n if Result = nil then\r\n Exit;\r\n LastRet := Result;\r\n if Result.ChildrenCount > 0 then\r\n Result := TJclDoubleTreeNode(Result.Children[0])\r\n else\r\n begin\r\n Result := Result.Parent;\r\n while (Result <> nil) and (Result.IndexOfChild(LastRet) = (Result.ChildrenCount - 1)) do\r\n begin\r\n LastRet := Result;\r\n Result := Result.Parent;\r\n end;\r\n if Result <> nil then // not root = return successor\r\n Result := TJclDoubleTreeNode(Result.Children[Result.IndexOfChild(LastRet) + 1]);\r\n end;\r\nend;\r\n\r\nfunction TJclPreOrderDoubleTreeIterator.GetNextSibling: TJclDoubleTreeNode;\r\nvar\r\n LastRet: TJclDoubleTreeNode;\r\nbegin\r\n Result := FCursor;\r\n if Result = nil then\r\n Exit;\r\n LastRet := Result;\r\n\r\n Result := Result.Parent;\r\n while (Result <> nil) and (Result.IndexOfChild(LastRet) = (Result.ChildrenCount - 1)) do\r\n begin\r\n LastRet := Result;\r\n Result := Result.Parent;\r\n end;\r\n if Result <> nil then // not root = return successor\r\n Result := TJclDoubleTreeNode(Result.Children[Result.IndexOfChild(LastRet) + 1]);\r\nend;\r\n\r\nfunction TJclPreOrderDoubleTreeIterator.GetPreviousCursor: TJclDoubleTreeNode;\r\nvar\r\n LastRet: TJclDoubleTreeNode;\r\nbegin\r\n Result := FCursor;\r\n if Result = nil then\r\n Exit;\r\n LastRet := Result;\r\n Result := Result.Parent;\r\n if (Result <> nil) and (Result.IndexOfChild(LastRet) > 0) then\r\n // come from Right\r\n begin\r\n Result := TJclDoubleTreeNode(Result.Children[Result.IndexOfChild(LastRet) - 1]);\r\n while (Result.ChildrenCount > 0) do // descend down the tree\r\n Result := TJclDoubleTreeNode(Result.Children[Result.ChildrenCount - 1]);\r\n end;\r\nend;\r\n\r\n//=== { TJclPostOrderDoubleTreeIterator } ==================================================\r\n\r\nfunction TJclPostOrderDoubleTreeIterator.CreateEmptyIterator: TJclAbstractIterator;\r\nbegin\r\n Result := TJclPostOrderDoubleTreeIterator.Create(FOwnTree, FCursor, Valid, FStart);\r\nend;\r\n\r\nfunction TJclPostOrderDoubleTreeIterator.GetNextCursor: TJclDoubleTreeNode;\r\nvar\r\n LastRet: TJclDoubleTreeNode;\r\nbegin\r\n Result := FCursor;\r\n if Result = nil then\r\n Exit;\r\n LastRet := Result;\r\n Result := Result.Parent;\r\n if (Result <> nil) and (Result.IndexOfChild(LastRet) <> (Result.ChildrenCount - 1)) then\r\n begin\r\n Result := TJclDoubleTreeNode(Result.Children[Result.IndexOfChild(LastRet) + 1]);\r\n while Result.ChildrenCount > 0 do\r\n Result := TJclDoubleTreeNode(Result.Children[0]);\r\n end;\r\nend;\r\n\r\nfunction TJclPostOrderDoubleTreeIterator.GetNextSibling: TJclDoubleTreeNode;\r\nvar\r\n LastRet: TJclDoubleTreeNode;\r\nbegin\r\n Result := FCursor;\r\n if Result = nil then\r\n Exit;\r\n LastRet := Result;\r\n Result := Result.Parent;\r\n\r\n if (Result <> nil) and (Result.IndexOfChild(LastRet) <> (Result.ChildrenCount - 1)) then\r\n begin\r\n Result := TJclDoubleTreeNode(Result.Children[Result.IndexOfChild(LastRet) + 1]);\r\n while Result.ChildrenCount > 0 do\r\n Result := TJclDoubleTreeNode(Result.Children[0]);\r\n end;\r\nend;\r\n\r\nfunction TJclPostOrderDoubleTreeIterator.GetPreviousCursor: TJclDoubleTreeNode;\r\nvar\r\n LastRet: TJclDoubleTreeNode;\r\nbegin\r\n Result := FCursor;\r\n if Result = nil then\r\n Exit;\r\n if Result.ChildrenCount > 0 then\r\n Result := TJclDoubleTreeNode(Result.Children[Result.ChildrenCount - 1])\r\n else\r\n begin\r\n LastRet := Result;\r\n Result := Result.Parent;\r\n while (Result <> nil) and (Result.IndexOfChild(LastRet) = 0) do\r\n begin\r\n LastRet := Result;\r\n Result := Result.Parent;\r\n end;\r\n if Result <> nil then // not root\r\n Result := TJclDoubleTreeNode(Result.Children[Result.IndexOfChild(LastRet) - 1]);\r\n end;\r\nend;\r\n\r\n//=== { TJclExtendedTreeNode } =======================================================\r\n\r\nfunction TJclExtendedTreeNode.IndexOfChild(AChild: TJclExtendedTreeNode): Integer;\r\nbegin\r\n for Result := 0 to ChildrenCount - 1 do\r\n if Children[Result] = AChild then\r\n Exit;\r\n Result := -1;\r\nend;\r\n\r\nfunction TJclExtendedTreeNode.IndexOfValue(const AValue: Extended;\r\n const AEqualityComparer: IJclExtendedEqualityComparer): Integer;\r\nbegin\r\n for Result := 0 to ChildrenCount - 1 do\r\n if AEqualityComparer.ItemsEqual(TJclExtendedTreeNode(Children[Result]).Value, AValue) then\r\n Exit;\r\n Result := -1;\r\nend;\r\n\r\n//=== { TJclExtendedTree } =======================================================\r\n\r\nconstructor TJclExtendedTree.Create();\r\nbegin\r\n inherited Create();\r\n FTraverseOrder := toPreOrder;\r\nend;\r\n\r\ndestructor TJclExtendedTree.Destroy;\r\nbegin\r\n FReadOnly := False;\r\n Clear;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJclExtendedTree.Add(const AValue: Extended): Boolean;\r\nvar\r\n NewNode: TJclExtendedTreeNode;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := AllowDefaultElements or not ItemsEqual(AValue, 0.0);\r\n\r\n if Result then\r\n begin\r\n if FRoot <> nil then\r\n begin\r\n Result := (not Contains(AValue)) or CheckDuplicate;\r\n if Result then\r\n begin\r\n if FRoot.ChildrenCount = Length(FRoot.Children) then\r\n SetLength(FRoot.Children, CalcGrowCapacity(Length(FRoot.Children), FRoot.ChildrenCount));\r\n if FRoot.ChildrenCount < Length(FRoot.Children) then\r\n begin\r\n NewNode := TJclExtendedTreeNode.Create;\r\n NewNode.Value := AValue;\r\n NewNode.Parent := FRoot;\r\n FRoot.Children[FRoot.ChildrenCount] := NewNode;\r\n Inc(FRoot.ChildrenCount);\r\n Inc(FSize);\r\n end\r\n else\r\n Result := False;\r\n end;\r\n end\r\n else\r\n begin\r\n FRoot := TJclExtendedTreeNode.Create;\r\n FRoot.Value := AValue;\r\n Inc(FSize);\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclExtendedTree.AddAll(const ACollection: IJclExtendedCollection): Boolean;\r\nvar\r\n It: IJclExtendedIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n Result := Add(It.Next) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclExtendedTree.AssignDataTo(Dest: TJclAbstractContainerBase);\r\nvar\r\n ADest: TJclExtendedTree;\r\n ACollection: IJclExtendedCollection;\r\nbegin\r\n inherited AssignDataTo(Dest);\r\n if Dest is TJclExtendedTree then\r\n begin\r\n ADest := TJclExtendedTree(Dest);\r\n ADest.Clear;\r\n ADest.FSize := FSize;\r\n if FRoot <> nil then\r\n ADest.FRoot := CloneNode(FRoot, nil);\r\n end\r\n else\r\n if Supports(IInterface(Dest), IJclExtendedCollection, ACollection) then\r\n begin\r\n ACollection.Clear;\r\n ACollection.AddAll(Self);\r\n end;\r\nend;\r\n\r\nprocedure TJclExtendedTree.AssignPropertiesTo(Dest: TJclAbstractContainerBase);\r\nbegin\r\n inherited AssignPropertiesto(Dest);\r\n if Dest is TJclExtendedTree then\r\n TJclExtendedTree(Dest).FTraverseOrder := FTraverseOrder;\r\nend;\r\n\r\nprocedure TJclExtendedTree.Clear;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FRoot <> nil then\r\n RemoveNode(FRoot);\r\n FSize := 0;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclExtendedTree.CloneNode(Node, Parent: TJclExtendedTreeNode): TJclExtendedTreeNode;\r\nvar\r\n Index: Integer;\r\nbegin\r\n Result := TJclExtendedTreeNode.Create;\r\n Result.Value := Node.Value;\r\n Result.Parent := Parent;\r\n SetLength(Result.Children, Node.ChildrenCount);\r\n Result.ChildrenCount := Node.ChildrenCount;\r\n for Index := 0 to Node.ChildrenCount - 1 do\r\n Result.Children[Index] := CloneNode(TJclExtendedTreeNode(Node.Children[Index]), Result); // recursive call\r\nend;\r\n\r\nfunction TJclExtendedTree.CollectionEquals(const ACollection: IJclExtendedCollection): Boolean;\r\nvar\r\n It, ItSelf: IJclExtendedIterator;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n if FSize <> ACollection.Size then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n ItSelf := First;\r\n while ItSelf.HasNext do\r\n if not ItemsEqual(ItSelf.Next, It.Next) then\r\n begin\r\n Result := False;\r\n Break;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclExtendedTree.Contains(const AValue: Extended): Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FRoot <> nil then\r\n Result := NodeContains(FRoot, AValue)\r\n else\r\n Result := False;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclExtendedTree.ContainsAll(const ACollection: IJclExtendedCollection): Boolean;\r\nvar\r\n It: IJclExtendedIterator;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := True;\r\n if ACollection = nil then\r\n Exit;\r\n It := ACollection.First;\r\n while Result and It.HasNext do\r\n Result := Contains(It.Next);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclExtendedTree.Extract(const AValue: Extended): Boolean;\r\nvar\r\n It: IJclExtendedIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := FRoot <> nil;\r\n if Result then\r\n begin\r\n It := First;\r\n while It.HasNext do\r\n if ItemsEqual(It.Next, AValue) then\r\n begin\r\n It.Extract;\r\n if RemoveSingleElement then\r\n Break;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclExtendedTree.ExtractAll(const ACollection: IJclExtendedCollection): Boolean;\r\nvar\r\n It: IJclExtendedIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n Result := Extract(It.Next) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclExtendedTree.ExtractNode(var ANode: TJclExtendedTreeNode);\r\nvar\r\n Index, ChildIndex, NewCapacity: Integer;\r\n Parent: TJclExtendedTreeNode;\r\nbegin\r\n for Index := ANode.ChildrenCount - 1 downto 0 do\r\n {$IFDEF BCB}\r\n ExtractNode(TJclExtendedTreeNode(ANode.Children[Index]));\r\n {$ELSE ~BCB}\r\n ExtractNode(ANode.Children[Index]);\r\n {$ENDIF ~BCB}\r\n Parent := ANode.Parent;\r\n if Parent <> nil then\r\n begin\r\n ChildIndex := Parent.IndexOfChild(ANode);\r\n for Index := ChildIndex + 1 to Parent.ChildrenCount - 1 do\r\n Parent.Children[Index - 1] := Parent.Children[Index];\r\n Dec(Parent.ChildrenCount);\r\n NewCapacity := CalcPackCapacity(Length(Parent.Children), Parent.ChildrenCount);\r\n if NewCapacity < Length(Parent.Children) then\r\n SetLength(Parent.Children, NewCapacity);\r\n FreeAndNil(ANode);\r\n end\r\n else\r\n begin\r\n FreeAndNil(ANode);\r\n FRoot := nil;\r\n end;\r\n Dec(FSize);\r\nend;\r\n\r\nfunction TJclExtendedTree.First: IJclExtendedIterator;\r\nvar\r\n Start: TJclExtendedTreeNode;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Start := FRoot;\r\n case GetTraverseOrder of\r\n toPreOrder:\r\n Result := TJclPreOrderExtendedTreeIterator.Create(Self, Start, False, isFirst);\r\n toPostOrder:\r\n begin\r\n if Start <> nil then\r\n while (Start.ChildrenCount > 0) do\r\n Start := TJclExtendedTreeNode(Start.Children[0]);\r\n Result := TJclPostOrderExtendedTreeIterator.Create(Self, Start, False, isFirst);\r\n end;\r\n else\r\n Result := nil;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\n{$IFDEF SUPPORTS_FOR_IN}\r\nfunction TJclExtendedTree.GetEnumerator: IJclExtendedIterator;\r\nbegin\r\n Result := First;\r\nend;\r\n{$ENDIF SUPPORTS_FOR_IN}\r\n\r\nfunction TJclExtendedTree.GetRoot: IJclExtendedTreeIterator;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n case GetTraverseOrder of\r\n toPreOrder:\r\n Result := TJclPreOrderExtendedTreeIterator.Create(Self, FRoot, False, isRoot);\r\n toPostOrder:\r\n Result := TJclPostOrderExtendedTreeIterator.Create(Self, FRoot, False, isRoot);\r\n else\r\n Result := nil;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclExtendedTree.GetTraverseOrder: TJclTraverseOrder;\r\nbegin\r\n Result := FTraverseOrder;\r\nend;\r\n\r\nfunction TJclExtendedTree.IsEmpty: Boolean;\r\nbegin\r\n Result := FSize = 0;\r\nend;\r\n\r\nfunction TJclExtendedTree.Last: IJclExtendedIterator;\r\nvar\r\n Start: TJclExtendedTreeNode;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Start := FRoot;\r\n case FTraverseOrder of\r\n toPreOrder:\r\n begin\r\n if Start <> nil then\r\n while Start.ChildrenCount > 0 do\r\n Start := TJclExtendedTreeNode(Start.Children[Start.ChildrenCount - 1]);\r\n Result := TJclPreOrderExtendedTreeIterator.Create(Self, Start, False, isLast);\r\n end;\r\n toPostOrder:\r\n Result := TJclPostOrderExtendedTreeIterator.Create(Self, Start, False, isLast);\r\n else\r\n Result := nil;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclExtendedTree.NodeContains(ANode: TJclExtendedTreeNode; const AValue: Extended): Boolean;\r\nvar\r\n Index: Integer;\r\nbegin\r\n Result := ItemsEqual(ANode.Value, AValue);\r\n if not Result then\r\n for Index := 0 to ANode.ChildrenCount - 1 do\r\n begin\r\n Result := NodeContains(TJclExtendedTreeNode(ANode.Children[Index]), AValue);\r\n if Result then\r\n Break;\r\n end;\r\nend;\r\n\r\nprocedure TJclExtendedTree.Pack;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FRoot <> nil then\r\n PackNode(FRoot);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclExtendedTree.PackNode(ANode: TJclExtendedTreeNode);\r\nvar\r\n Index: Integer;\r\nbegin\r\n SetLength(ANode.Children, ANode.ChildrenCount);\r\n for Index := 0 to ANode.ChildrenCount - 1 do\r\n PackNode(TJclExtendedTreeNode(ANode.Children[Index]));\r\nend;\r\n\r\nfunction TJclExtendedTree.Remove(const AValue: Extended): Boolean;\r\nvar\r\n Extracted: Extended;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := Extract(AValue);\r\n if Result then\r\n begin\r\n Extracted := AValue;\r\n FreeExtended(Extracted);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclExtendedTree.RemoveAll(const ACollection: IJclExtendedCollection): Boolean;\r\nvar\r\n It: IJclExtendedIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n Result := Remove(It.Next) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclExtendedTree.RemoveNode(var ANode: TJclExtendedTreeNode);\r\nvar\r\n Index, ChildIndex, NewCapacity: Integer;\r\n Parent: TJclExtendedTreeNode;\r\nbegin\r\n for Index := ANode.ChildrenCount - 1 downto 0 do\r\n {$IFDEF BCB}\r\n RemoveNode(TJclExtendedTreeNode(ANode.Children[Index]));\r\n {$ELSE ~BCB}\r\n RemoveNode(ANode.Children[Index]);\r\n {$ENDIF ~BCB}\r\n FreeExtended(ANode.Value);\r\n Parent := ANode.Parent;\r\n if Parent <> nil then\r\n begin\r\n ChildIndex := Parent.IndexOfChild(ANode);\r\n for Index := ChildIndex + 1 to Parent.ChildrenCount - 1 do\r\n Parent.Children[Index - 1] := Parent.Children[Index];\r\n Dec(Parent.ChildrenCount);\r\n NewCapacity := CalcPackCapacity(Length(Parent.Children), Parent.ChildrenCount);\r\n if NewCapacity < Length(Parent.Children) then\r\n SetLength(Parent.Children, NewCapacity);\r\n FreeAndNil(ANode);\r\n end\r\n else\r\n begin\r\n FreeAndNil(ANode);\r\n FRoot := nil;\r\n end;\r\n Dec(FSize);\r\nend;\r\n\r\nfunction TJclExtendedTree.RetainAll(const ACollection: IJclExtendedCollection): Boolean;\r\nvar\r\n It: IJclExtendedIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := First;\r\n while It.HasNext do\r\n if not ACollection.Contains(It.Next) then\r\n It.Remove;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclExtendedTree.SetCapacity(Value: Integer);\r\nbegin\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nprocedure TJclExtendedTree.SetTraverseOrder(Value: TJclTraverseOrder);\r\nbegin\r\n FTraverseOrder := Value;\r\nend;\r\n\r\nfunction TJclExtendedTree.Size: Integer;\r\nbegin\r\n Result := FSize;\r\nend;\r\n\r\nfunction TJclExtendedTree.CreateEmptyContainer: TJclAbstractContainerBase;\r\nbegin\r\n Result := TJclExtendedTree.Create;\r\n AssignPropertiesTo(Result);\r\nend;\r\n\r\n//=== { TJclExtendedTreeIterator } ===========================================================\r\n\r\nconstructor TJclExtendedTreeIterator.Create(OwnTree: TJclExtendedTree; ACursor: TJclExtendedTreeNode; AValid: Boolean; AStart: TItrStart);\r\nbegin\r\n inherited Create(AValid);\r\n FCursor := ACursor;\r\n FOwnTree := OwnTree;\r\n FStart := AStart;\r\n FEqualityComparer := OwnTree as IJclExtendedEqualityComparer;\r\nend;\r\n\r\nfunction TJclExtendedTreeIterator.Add(const AValue: Extended): Boolean;\r\nvar\r\n ParentNode, NewNode: TJclExtendedTreeNode;\r\nbegin\r\n if FOwnTree.ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n // add sibling or, if FCursor is root node, behave like TJclExtendedTree.Add\r\n Result := (FCursor <> nil) and (FOwnTree.AllowDefaultElements or not FEqualityComparer.ItemsEqual(AValue, 0.0))\r\n and ((not FOwnTree.Contains(AValue)) or FOwnTree.CheckDuplicate);\r\n\r\n if Result then\r\n begin\r\n ParentNode := FCursor.Parent;\r\n if ParentNode = nil then\r\n ParentNode := FCursor;\r\n\r\n if ParentNode.ChildrenCount = Length(ParentNode.Children) then\r\n SetLength(ParentNode.Children, FOwnTree.CalcGrowCapacity(Length(ParentNode.Children), ParentNode.ChildrenCount));\r\n if ParentNode.ChildrenCount < Length(ParentNode.Children) then\r\n begin\r\n NewNode := TJclExtendedTreeNode.Create;\r\n NewNode.Value := AValue;\r\n NewNode.Parent := ParentNode;\r\n ParentNode.Children[ParentNode.ChildrenCount] := NewNode;\r\n Inc(ParentNode.ChildrenCount);\r\n Inc(FOwnTree.FSize);\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.WriteUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclExtendedTreeIterator.AddChild(const AValue: Extended): Boolean;\r\nvar\r\n NewNode: TJclExtendedTreeNode;\r\nbegin\r\n if FOwnTree.ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := (FCursor <> nil) and (FOwnTree.AllowDefaultElements or not FEqualityComparer.ItemsEqual(AValue, 0.0))\r\n and ((not FOwnTree.Contains(AValue)) or FOwnTree.CheckDuplicate);\r\n\r\n if Result then\r\n begin\r\n if FCursor.ChildrenCount = Length(FCursor.Children) then\r\n SetLength(FCursor.Children, FOwnTree.CalcGrowCapacity(Length(FCursor.Children), FCursor.ChildrenCount));\r\n if FCursor.ChildrenCount < Length(FCursor.Children) then\r\n begin\r\n NewNode := TJclExtendedTreeNode.Create;\r\n NewNode.Value := AValue;\r\n NewNode.Parent := FCursor;\r\n FCursor.Children[FCursor.ChildrenCount] := NewNode;\r\n Inc(FCursor.ChildrenCount);\r\n Inc(FOwnTree.FSize);\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.WriteUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclExtendedTreeIterator.AssignPropertiesTo(Dest: TJclAbstractIterator);\r\nvar\r\n ADest: TJclExtendedTreeIterator;\r\nbegin\r\n inherited AssignPropertiesTo(Dest);\r\n if Dest is TJclExtendedTreeIterator then\r\n begin\r\n ADest := TJclExtendedTreeIterator(Dest);\r\n ADest.FCursor := FCursor;\r\n ADest.FOwnTree := FOwnTree;\r\n ADest.FEqualityComparer := FEqualityComparer;\r\n ADest.FStart := FStart;\r\n end;\r\nend;\r\n\r\nfunction TJclExtendedTreeIterator.ChildrenCount: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FCursor <> nil then\r\n Result := FCursor.ChildrenCount\r\n else\r\n Result := 0;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclExtendedTreeIterator.DeleteChild(Index: Integer);\r\nbegin\r\n if FOwnTree.ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if (FCursor <> nil) and (Index >= 0) and (Index < FCursor.ChildrenCount) then\r\n {$IFDEF BCB}\r\n FOwnTree.RemoveNode(TJclExtendedTreeNode(FCursor.Children[Index]))\r\n {$ELSE ~BCB}\r\n FOwnTree.RemoveNode(FCursor.Children[Index])\r\n {$ENDIF ~BCB}\r\n else\r\n raise EJclOutOfBoundsError.Create;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.WriteUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclExtendedTreeIterator.DeleteChildren;\r\nvar\r\n Index: Integer;\r\nbegin\r\n if FOwnTree.ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FCursor <> nil then\r\n begin\r\n for Index := FCursor.ChildrenCount - 1 downto 0 do\r\n {$IFDEF BCB}\r\n FOwnTree.RemoveNode(TJclExtendedTreeNode(FCursor.Children[Index]));\r\n {$ELSE ~BCB}\r\n FOwnTree.RemoveNode(FCursor.Children[Index]);\r\n {$ENDIF ~BCB}\r\n SetLength(FCursor.Children, 0);\r\n FCursor.ChildrenCount := 0;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.WriteUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclExtendedTreeIterator.Extract;\r\nvar\r\n OldCursor: TJclExtendedTreeNode;\r\nbegin\r\n if FOwnTree.ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n CheckValid;\r\n Valid := False;\r\n OldCursor := FCursor;\r\n FCursor := GetNextSibling;\r\n if OldCursor <> nil then\r\n FOwnTree.ExtractNode(OldCursor);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.WriteUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclExtendedTreeIterator.ExtractChild(Index: Integer);\r\nbegin\r\n if FOwnTree.ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if (FCursor <> nil) and (Index >= 0) and (Index < FCursor.ChildrenCount) then\r\n {$IFDEF BCB}\r\n FOwnTree.ExtractNode(TJclExtendedTreeNode(FCursor.Children[Index]))\r\n {$ELSE ~BCB}\r\n FOwnTree.ExtractNode(FCursor.Children[Index])\r\n {$ENDIF ~BCB}\r\n else\r\n raise EJclOutOfBoundsError.Create;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.WriteUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclExtendedTreeIterator.ExtractChildren;\r\nvar\r\n Index: Integer;\r\nbegin\r\n if FOwnTree.ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FCursor <> nil then\r\n begin\r\n for Index := FCursor.ChildrenCount - 1 downto 0 do\r\n {$IFDEF BCB}\r\n FOwnTree.ExtractNode(TJclExtendedTreeNode(FCursor.Children[Index]));\r\n {$ELSE ~BCB}\r\n FOwnTree.ExtractNode(FCursor.Children[Index]);\r\n {$ENDIF ~BCB}\r\n SetLength(FCursor.Children, 0);\r\n FCursor.ChildrenCount := 0;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.WriteUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclExtendedTreeIterator.GetChild(Index: Integer): Extended;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := 0.0;\r\n if (FCursor <> nil) and (Index >= 0) and (Index < FCursor.ChildrenCount) then\r\n FCursor := TJclExtendedTreeNode(FCursor.Children[Index]);\r\n if FCursor <> nil then\r\n Result := FCursor.Value\r\n else\r\n if not FOwnTree.ReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclExtendedTreeIterator.GetValue: Extended;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n CheckValid;\r\n Result := 0.0;\r\n if FCursor <> nil then\r\n Result := FCursor.Value\r\n else\r\n if not FOwnTree.ReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclExtendedTreeIterator.HasChild(Index: Integer): Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := (FCursor <> nil) and (Index >= 0) and (Index < FCursor.ChildrenCount);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclExtendedTreeIterator.HasNext: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Valid then\r\n Result := GetNextCursor <> nil\r\n else\r\n Result := FCursor <> nil;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclExtendedTreeIterator.HasParent: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := (FCursor <> nil) and (FCursor.Parent <> nil);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclExtendedTreeIterator.HasPrevious: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Valid then\r\n Result := GetPreviousCursor <> nil\r\n else\r\n Result := FCursor <> nil;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclExtendedTreeIterator.IndexOfChild(const AValue: Extended): Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FCursor <> nil then\r\n Result := FCursor.IndexOfValue(AValue, FEqualityComparer)\r\n else\r\n Result := -1;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclExtendedTreeIterator.Insert(const AValue: Extended): Boolean;\r\nvar\r\n ParentNode, NewNode: TJclExtendedTreeNode;\r\n Index, I: Integer;\r\nbegin\r\n if FOwnTree.ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n // insert sibling or, if FCursor is root node, behave like TJclExtendedTree.Insert\r\n Result := (FCursor <> nil) and (FOwnTree.AllowDefaultElements or not FEqualityComparer.ItemsEqual(AValue, 0.0))\r\n and ((not FOwnTree.Contains(AValue)) or FOwnTree.CheckDuplicate);\r\n\r\n if Result then\r\n begin\r\n if FCursor.Parent <> nil then\r\n begin\r\n ParentNode := FCursor.Parent;\r\n Index := 0;\r\n while (Index < ParentNode.ChildrenCount) and (ParentNode.Children[Index] <> FCursor) do\r\n Inc(Index);\r\n end\r\n else\r\n begin\r\n ParentNode := FCursor;\r\n Index := 0;\r\n end;\r\n\r\n if ParentNode.ChildrenCount = Length(ParentNode.Children) then\r\n SetLength(ParentNode.Children, FOwnTree.CalcGrowCapacity(Length(ParentNode.Children), ParentNode.ChildrenCount));\r\n if ParentNode.ChildrenCount < Length(ParentNode.Children) then\r\n begin\r\n NewNode := TJclExtendedTreeNode.Create;\r\n NewNode.Value := AValue;\r\n NewNode.Parent := ParentNode;\r\n for I := ParentNode.ChildrenCount - 1 downto Index do\r\n ParentNode.Children[I + 1] := ParentNode.Children[I];\r\n ParentNode.Children[Index] := NewNode;\r\n Inc(ParentNode.ChildrenCount);\r\n Inc(FOwnTree.FSize);\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.WriteUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclExtendedTreeIterator.InsertChild(Index: Integer; const AValue: Extended): Boolean;\r\nvar\r\n NewNode: TJclExtendedTreeNode;\r\n I: Integer;\r\nbegin\r\n if FOwnTree.ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n // insert sibling or, if FCursor is root node, behave like TJclExtendedTree.Insert\r\n Result := (FCursor <> nil) and (FOwnTree.AllowDefaultElements or not FEqualityComparer.ItemsEqual(AValue, 0.0))\r\n and ((not FOwnTree.Contains(AValue)) or FOwnTree.CheckDuplicate);\r\n\r\n if Result then\r\n begin\r\n if FCursor.ChildrenCount = Length(FCursor.Children) then\r\n SetLength(FCursor.Children, FOwnTree.CalcGrowCapacity(Length(FCursor.Children), FCursor.ChildrenCount));\r\n if FCursor.ChildrenCount < Length(FCursor.Children) then\r\n begin\r\n NewNode := TJclExtendedTreeNode.Create;\r\n NewNode.Value := AValue;\r\n NewNode.Parent := FCursor;\r\n for I := FCursor.ChildrenCount - 1 downto Index do\r\n FCursor.Children[I + 1] := FCursor.Children[I];\r\n FCursor.Children[Index] := NewNode;\r\n Inc(FCursor.ChildrenCount);\r\n Inc(FOwnTree.FSize);\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.WriteUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclExtendedTreeIterator.IteratorEquals(const AIterator: IJclExtendedIterator): Boolean;\r\nvar\r\n Obj: TObject;\r\n ItrObj: TJclExtendedTreeIterator;\r\nbegin\r\n Result := False;\r\n if AIterator = nil then\r\n Exit;\r\n Obj := AIterator.GetIteratorReference;\r\n if Obj is TJclExtendedTreeIterator then\r\n begin\r\n ItrObj := TJclExtendedTreeIterator(Obj);\r\n Result := (FOwnTree = ItrObj.FOwnTree) and (FCursor = ItrObj.FCursor) and (Valid = ItrObj.Valid);\r\n end;\r\nend;\r\n\r\n{$IFDEF SUPPORTS_FOR_IN}\r\nfunction TJclExtendedTreeIterator.MoveNext: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Valid then\r\n FCursor := GetNextCursor\r\n else\r\n Valid := True;\r\n Result := FCursor <> nil;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n{$ENDIF SUPPORTS_FOR_IN}\r\n\r\nfunction TJclExtendedTreeIterator.Next: Extended;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Valid then\r\n FCursor := GetNextCursor\r\n else\r\n Valid := True;\r\n Result := 0.0;\r\n if FCursor <> nil then\r\n Result := FCursor.Value\r\n else\r\n if not FOwnTree.ReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclExtendedTreeIterator.NextIndex: Integer;\r\nbegin\r\n // No index\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nfunction TJclExtendedTreeIterator.Parent: Extended;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := 0.0;\r\n if FCursor <> nil then\r\n FCursor := FCursor.Parent;\r\n if FCursor <> nil then\r\n Result := FCursor.Value\r\n else\r\n if not FOwnTree.ReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclExtendedTreeIterator.Previous: Extended;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Valid then\r\n FCursor := GetPreviousCursor\r\n else\r\n Valid := True;\r\n Result := 0.0;\r\n if FCursor <> nil then\r\n Result := FCursor.Value\r\n else\r\n if not FOwnTree.ReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclExtendedTreeIterator.PreviousIndex: Integer;\r\nbegin\r\n // No index\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nprocedure TJclExtendedTreeIterator.Remove;\r\nvar\r\n OldCursor: TJclExtendedTreeNode;\r\nbegin\r\n if FOwnTree.ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n CheckValid;\r\n Valid := False;\r\n OldCursor := FCursor;\r\n FCursor := GetNextSibling;\r\n if OldCursor <> nil then\r\n FOwnTree.RemoveNode(OldCursor);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.WriteUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclExtendedTreeIterator.Reset;\r\nvar\r\n NewCursor: TJclExtendedTreeNode;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Valid := False;\r\n case FStart of\r\n isFirst:\r\n begin\r\n NewCursor := FCursor;\r\n while NewCursor <> nil do\r\n begin\r\n NewCursor := GetPreviousCursor;\r\n if NewCursor <> nil then\r\n FCursor := NewCursor;\r\n end;\r\n end;\r\n isLast:\r\n begin\r\n NewCursor := FCursor;\r\n while NewCursor <> nil do\r\n begin\r\n NewCursor := GetNextCursor;\r\n if NewCursor <> nil then\r\n FCursor := NewCursor;\r\n end;\r\n end;\r\n isRoot:\r\n begin\r\n while (FCursor <> nil) and (FCursor.Parent <> nil) do\r\n FCursor := FCursor.Parent;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclExtendedTreeIterator.SetChild(Index: Integer; const AValue: Extended);\r\nbegin\r\n if FOwnTree.ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if (FCursor <> nil) and (Index >= 0) and (Index < FCursor.ChildrenCount) then\r\n TJclExtendedTreeNode(FCursor.Children[Index]).Value := AValue\r\n else\r\n raise EJclOutOfBoundsError.Create;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.WriteUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclExtendedTreeIterator.SetValue(const AValue: Extended);\r\nbegin\r\n if FOwnTree.ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n CheckValid;\r\n if FCursor <> nil then\r\n begin\r\n FOwnTree.FreeExtended(FCursor.Value);\r\n FCursor.Value := AValue;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.WriteUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\n//=== { TJclPreOrderExtendedTreeIterator } ===================================================\r\n\r\nfunction TJclPreOrderExtendedTreeIterator.CreateEmptyIterator: TJclAbstractIterator;\r\nbegin\r\n Result := TJclPreOrderExtendedTreeIterator.Create(FOwnTree, FCursor, Valid, FStart);\r\nend;\r\n\r\nfunction TJclPreOrderExtendedTreeIterator.GetNextCursor: TJclExtendedTreeNode;\r\nvar\r\n LastRet: TJclExtendedTreeNode;\r\nbegin\r\n Result := FCursor;\r\n if Result = nil then\r\n Exit;\r\n LastRet := Result;\r\n if Result.ChildrenCount > 0 then\r\n Result := TJclExtendedTreeNode(Result.Children[0])\r\n else\r\n begin\r\n Result := Result.Parent;\r\n while (Result <> nil) and (Result.IndexOfChild(LastRet) = (Result.ChildrenCount - 1)) do\r\n begin\r\n LastRet := Result;\r\n Result := Result.Parent;\r\n end;\r\n if Result <> nil then // not root = return successor\r\n Result := TJclExtendedTreeNode(Result.Children[Result.IndexOfChild(LastRet) + 1]);\r\n end;\r\nend;\r\n\r\nfunction TJclPreOrderExtendedTreeIterator.GetNextSibling: TJclExtendedTreeNode;\r\nvar\r\n LastRet: TJclExtendedTreeNode;\r\nbegin\r\n Result := FCursor;\r\n if Result = nil then\r\n Exit;\r\n LastRet := Result;\r\n\r\n Result := Result.Parent;\r\n while (Result <> nil) and (Result.IndexOfChild(LastRet) = (Result.ChildrenCount - 1)) do\r\n begin\r\n LastRet := Result;\r\n Result := Result.Parent;\r\n end;\r\n if Result <> nil then // not root = return successor\r\n Result := TJclExtendedTreeNode(Result.Children[Result.IndexOfChild(LastRet) + 1]);\r\nend;\r\n\r\nfunction TJclPreOrderExtendedTreeIterator.GetPreviousCursor: TJclExtendedTreeNode;\r\nvar\r\n LastRet: TJclExtendedTreeNode;\r\nbegin\r\n Result := FCursor;\r\n if Result = nil then\r\n Exit;\r\n LastRet := Result;\r\n Result := Result.Parent;\r\n if (Result <> nil) and (Result.IndexOfChild(LastRet) > 0) then\r\n // come from Right\r\n begin\r\n Result := TJclExtendedTreeNode(Result.Children[Result.IndexOfChild(LastRet) - 1]);\r\n while (Result.ChildrenCount > 0) do // descend down the tree\r\n Result := TJclExtendedTreeNode(Result.Children[Result.ChildrenCount - 1]);\r\n end;\r\nend;\r\n\r\n//=== { TJclPostOrderExtendedTreeIterator } ==================================================\r\n\r\nfunction TJclPostOrderExtendedTreeIterator.CreateEmptyIterator: TJclAbstractIterator;\r\nbegin\r\n Result := TJclPostOrderExtendedTreeIterator.Create(FOwnTree, FCursor, Valid, FStart);\r\nend;\r\n\r\nfunction TJclPostOrderExtendedTreeIterator.GetNextCursor: TJclExtendedTreeNode;\r\nvar\r\n LastRet: TJclExtendedTreeNode;\r\nbegin\r\n Result := FCursor;\r\n if Result = nil then\r\n Exit;\r\n LastRet := Result;\r\n Result := Result.Parent;\r\n if (Result <> nil) and (Result.IndexOfChild(LastRet) <> (Result.ChildrenCount - 1)) then\r\n begin\r\n Result := TJclExtendedTreeNode(Result.Children[Result.IndexOfChild(LastRet) + 1]);\r\n while Result.ChildrenCount > 0 do\r\n Result := TJclExtendedTreeNode(Result.Children[0]);\r\n end;\r\nend;\r\n\r\nfunction TJclPostOrderExtendedTreeIterator.GetNextSibling: TJclExtendedTreeNode;\r\nvar\r\n LastRet: TJclExtendedTreeNode;\r\nbegin\r\n Result := FCursor;\r\n if Result = nil then\r\n Exit;\r\n LastRet := Result;\r\n Result := Result.Parent;\r\n\r\n if (Result <> nil) and (Result.IndexOfChild(LastRet) <> (Result.ChildrenCount - 1)) then\r\n begin\r\n Result := TJclExtendedTreeNode(Result.Children[Result.IndexOfChild(LastRet) + 1]);\r\n while Result.ChildrenCount > 0 do\r\n Result := TJclExtendedTreeNode(Result.Children[0]);\r\n end;\r\nend;\r\n\r\nfunction TJclPostOrderExtendedTreeIterator.GetPreviousCursor: TJclExtendedTreeNode;\r\nvar\r\n LastRet: TJclExtendedTreeNode;\r\nbegin\r\n Result := FCursor;\r\n if Result = nil then\r\n Exit;\r\n if Result.ChildrenCount > 0 then\r\n Result := TJclExtendedTreeNode(Result.Children[Result.ChildrenCount - 1])\r\n else\r\n begin\r\n LastRet := Result;\r\n Result := Result.Parent;\r\n while (Result <> nil) and (Result.IndexOfChild(LastRet) = 0) do\r\n begin\r\n LastRet := Result;\r\n Result := Result.Parent;\r\n end;\r\n if Result <> nil then // not root\r\n Result := TJclExtendedTreeNode(Result.Children[Result.IndexOfChild(LastRet) - 1]);\r\n end;\r\nend;\r\n\r\n//=== { TJclIntegerTreeNode } =======================================================\r\n\r\nfunction TJclIntegerTreeNode.IndexOfChild(AChild: TJclIntegerTreeNode): Integer;\r\nbegin\r\n for Result := 0 to ChildrenCount - 1 do\r\n if Children[Result] = AChild then\r\n Exit;\r\n Result := -1;\r\nend;\r\n\r\nfunction TJclIntegerTreeNode.IndexOfValue(AValue: Integer;\r\n const AEqualityComparer: IJclIntegerEqualityComparer): Integer;\r\nbegin\r\n for Result := 0 to ChildrenCount - 1 do\r\n if AEqualityComparer.ItemsEqual(TJclIntegerTreeNode(Children[Result]).Value, AValue) then\r\n Exit;\r\n Result := -1;\r\nend;\r\n\r\n//=== { TJclIntegerTree } =======================================================\r\n\r\nconstructor TJclIntegerTree.Create();\r\nbegin\r\n inherited Create();\r\n FTraverseOrder := toPreOrder;\r\nend;\r\n\r\ndestructor TJclIntegerTree.Destroy;\r\nbegin\r\n FReadOnly := False;\r\n Clear;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJclIntegerTree.Add(AValue: Integer): Boolean;\r\nvar\r\n NewNode: TJclIntegerTreeNode;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := AllowDefaultElements or not ItemsEqual(AValue, 0);\r\n\r\n if Result then\r\n begin\r\n if FRoot <> nil then\r\n begin\r\n Result := (not Contains(AValue)) or CheckDuplicate;\r\n if Result then\r\n begin\r\n if FRoot.ChildrenCount = Length(FRoot.Children) then\r\n SetLength(FRoot.Children, CalcGrowCapacity(Length(FRoot.Children), FRoot.ChildrenCount));\r\n if FRoot.ChildrenCount < Length(FRoot.Children) then\r\n begin\r\n NewNode := TJclIntegerTreeNode.Create;\r\n NewNode.Value := AValue;\r\n NewNode.Parent := FRoot;\r\n FRoot.Children[FRoot.ChildrenCount] := NewNode;\r\n Inc(FRoot.ChildrenCount);\r\n Inc(FSize);\r\n end\r\n else\r\n Result := False;\r\n end;\r\n end\r\n else\r\n begin\r\n FRoot := TJclIntegerTreeNode.Create;\r\n FRoot.Value := AValue;\r\n Inc(FSize);\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntegerTree.AddAll(const ACollection: IJclIntegerCollection): Boolean;\r\nvar\r\n It: IJclIntegerIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n Result := Add(It.Next) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclIntegerTree.AssignDataTo(Dest: TJclAbstractContainerBase);\r\nvar\r\n ADest: TJclIntegerTree;\r\n ACollection: IJclIntegerCollection;\r\nbegin\r\n inherited AssignDataTo(Dest);\r\n if Dest is TJclIntegerTree then\r\n begin\r\n ADest := TJclIntegerTree(Dest);\r\n ADest.Clear;\r\n ADest.FSize := FSize;\r\n if FRoot <> nil then\r\n ADest.FRoot := CloneNode(FRoot, nil);\r\n end\r\n else\r\n if Supports(IInterface(Dest), IJclIntegerCollection, ACollection) then\r\n begin\r\n ACollection.Clear;\r\n ACollection.AddAll(Self);\r\n end;\r\nend;\r\n\r\nprocedure TJclIntegerTree.AssignPropertiesTo(Dest: TJclAbstractContainerBase);\r\nbegin\r\n inherited AssignPropertiesto(Dest);\r\n if Dest is TJclIntegerTree then\r\n TJclIntegerTree(Dest).FTraverseOrder := FTraverseOrder;\r\nend;\r\n\r\nprocedure TJclIntegerTree.Clear;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FRoot <> nil then\r\n RemoveNode(FRoot);\r\n FSize := 0;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntegerTree.CloneNode(Node, Parent: TJclIntegerTreeNode): TJclIntegerTreeNode;\r\nvar\r\n Index: Integer;\r\nbegin\r\n Result := TJclIntegerTreeNode.Create;\r\n Result.Value := Node.Value;\r\n Result.Parent := Parent;\r\n SetLength(Result.Children, Node.ChildrenCount);\r\n Result.ChildrenCount := Node.ChildrenCount;\r\n for Index := 0 to Node.ChildrenCount - 1 do\r\n Result.Children[Index] := CloneNode(TJclIntegerTreeNode(Node.Children[Index]), Result); // recursive call\r\nend;\r\n\r\nfunction TJclIntegerTree.CollectionEquals(const ACollection: IJclIntegerCollection): Boolean;\r\nvar\r\n It, ItSelf: IJclIntegerIterator;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n if FSize <> ACollection.Size then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n ItSelf := First;\r\n while ItSelf.HasNext do\r\n if not ItemsEqual(ItSelf.Next, It.Next) then\r\n begin\r\n Result := False;\r\n Break;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntegerTree.Contains(AValue: Integer): Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FRoot <> nil then\r\n Result := NodeContains(FRoot, AValue)\r\n else\r\n Result := False;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntegerTree.ContainsAll(const ACollection: IJclIntegerCollection): Boolean;\r\nvar\r\n It: IJclIntegerIterator;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := True;\r\n if ACollection = nil then\r\n Exit;\r\n It := ACollection.First;\r\n while Result and It.HasNext do\r\n Result := Contains(It.Next);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntegerTree.Extract(AValue: Integer): Boolean;\r\nvar\r\n It: IJclIntegerIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := FRoot <> nil;\r\n if Result then\r\n begin\r\n It := First;\r\n while It.HasNext do\r\n if ItemsEqual(It.Next, AValue) then\r\n begin\r\n It.Extract;\r\n if RemoveSingleElement then\r\n Break;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntegerTree.ExtractAll(const ACollection: IJclIntegerCollection): Boolean;\r\nvar\r\n It: IJclIntegerIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n Result := Extract(It.Next) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclIntegerTree.ExtractNode(var ANode: TJclIntegerTreeNode);\r\nvar\r\n Index, ChildIndex, NewCapacity: Integer;\r\n Parent: TJclIntegerTreeNode;\r\nbegin\r\n for Index := ANode.ChildrenCount - 1 downto 0 do\r\n {$IFDEF BCB}\r\n ExtractNode(TJclIntegerTreeNode(ANode.Children[Index]));\r\n {$ELSE ~BCB}\r\n ExtractNode(ANode.Children[Index]);\r\n {$ENDIF ~BCB}\r\n Parent := ANode.Parent;\r\n if Parent <> nil then\r\n begin\r\n ChildIndex := Parent.IndexOfChild(ANode);\r\n for Index := ChildIndex + 1 to Parent.ChildrenCount - 1 do\r\n Parent.Children[Index - 1] := Parent.Children[Index];\r\n Dec(Parent.ChildrenCount);\r\n NewCapacity := CalcPackCapacity(Length(Parent.Children), Parent.ChildrenCount);\r\n if NewCapacity < Length(Parent.Children) then\r\n SetLength(Parent.Children, NewCapacity);\r\n FreeAndNil(ANode);\r\n end\r\n else\r\n begin\r\n FreeAndNil(ANode);\r\n FRoot := nil;\r\n end;\r\n Dec(FSize);\r\nend;\r\n\r\nfunction TJclIntegerTree.First: IJclIntegerIterator;\r\nvar\r\n Start: TJclIntegerTreeNode;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Start := FRoot;\r\n case GetTraverseOrder of\r\n toPreOrder:\r\n Result := TJclPreOrderIntegerTreeIterator.Create(Self, Start, False, isFirst);\r\n toPostOrder:\r\n begin\r\n if Start <> nil then\r\n while (Start.ChildrenCount > 0) do\r\n Start := TJclIntegerTreeNode(Start.Children[0]);\r\n Result := TJclPostOrderIntegerTreeIterator.Create(Self, Start, False, isFirst);\r\n end;\r\n else\r\n Result := nil;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\n{$IFDEF SUPPORTS_FOR_IN}\r\nfunction TJclIntegerTree.GetEnumerator: IJclIntegerIterator;\r\nbegin\r\n Result := First;\r\nend;\r\n{$ENDIF SUPPORTS_FOR_IN}\r\n\r\nfunction TJclIntegerTree.GetRoot: IJclIntegerTreeIterator;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n case GetTraverseOrder of\r\n toPreOrder:\r\n Result := TJclPreOrderIntegerTreeIterator.Create(Self, FRoot, False, isRoot);\r\n toPostOrder:\r\n Result := TJclPostOrderIntegerTreeIterator.Create(Self, FRoot, False, isRoot);\r\n else\r\n Result := nil;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntegerTree.GetTraverseOrder: TJclTraverseOrder;\r\nbegin\r\n Result := FTraverseOrder;\r\nend;\r\n\r\nfunction TJclIntegerTree.IsEmpty: Boolean;\r\nbegin\r\n Result := FSize = 0;\r\nend;\r\n\r\nfunction TJclIntegerTree.Last: IJclIntegerIterator;\r\nvar\r\n Start: TJclIntegerTreeNode;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Start := FRoot;\r\n case FTraverseOrder of\r\n toPreOrder:\r\n begin\r\n if Start <> nil then\r\n while Start.ChildrenCount > 0 do\r\n Start := TJclIntegerTreeNode(Start.Children[Start.ChildrenCount - 1]);\r\n Result := TJclPreOrderIntegerTreeIterator.Create(Self, Start, False, isLast);\r\n end;\r\n toPostOrder:\r\n Result := TJclPostOrderIntegerTreeIterator.Create(Self, Start, False, isLast);\r\n else\r\n Result := nil;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntegerTree.NodeContains(ANode: TJclIntegerTreeNode; AValue: Integer): Boolean;\r\nvar\r\n Index: Integer;\r\nbegin\r\n Result := ItemsEqual(ANode.Value, AValue);\r\n if not Result then\r\n for Index := 0 to ANode.ChildrenCount - 1 do\r\n begin\r\n Result := NodeContains(TJclIntegerTreeNode(ANode.Children[Index]), AValue);\r\n if Result then\r\n Break;\r\n end;\r\nend;\r\n\r\nprocedure TJclIntegerTree.Pack;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FRoot <> nil then\r\n PackNode(FRoot);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclIntegerTree.PackNode(ANode: TJclIntegerTreeNode);\r\nvar\r\n Index: Integer;\r\nbegin\r\n SetLength(ANode.Children, ANode.ChildrenCount);\r\n for Index := 0 to ANode.ChildrenCount - 1 do\r\n PackNode(TJclIntegerTreeNode(ANode.Children[Index]));\r\nend;\r\n\r\nfunction TJclIntegerTree.Remove(AValue: Integer): Boolean;\r\nvar\r\n Extracted: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := Extract(AValue);\r\n if Result then\r\n begin\r\n Extracted := AValue;\r\n FreeInteger(Extracted);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntegerTree.RemoveAll(const ACollection: IJclIntegerCollection): Boolean;\r\nvar\r\n It: IJclIntegerIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n Result := Remove(It.Next) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclIntegerTree.RemoveNode(var ANode: TJclIntegerTreeNode);\r\nvar\r\n Index, ChildIndex, NewCapacity: Integer;\r\n Parent: TJclIntegerTreeNode;\r\nbegin\r\n for Index := ANode.ChildrenCount - 1 downto 0 do\r\n {$IFDEF BCB}\r\n RemoveNode(TJclIntegerTreeNode(ANode.Children[Index]));\r\n {$ELSE ~BCB}\r\n RemoveNode(ANode.Children[Index]);\r\n {$ENDIF ~BCB}\r\n FreeInteger(ANode.Value);\r\n Parent := ANode.Parent;\r\n if Parent <> nil then\r\n begin\r\n ChildIndex := Parent.IndexOfChild(ANode);\r\n for Index := ChildIndex + 1 to Parent.ChildrenCount - 1 do\r\n Parent.Children[Index - 1] := Parent.Children[Index];\r\n Dec(Parent.ChildrenCount);\r\n NewCapacity := CalcPackCapacity(Length(Parent.Children), Parent.ChildrenCount);\r\n if NewCapacity < Length(Parent.Children) then\r\n SetLength(Parent.Children, NewCapacity);\r\n FreeAndNil(ANode);\r\n end\r\n else\r\n begin\r\n FreeAndNil(ANode);\r\n FRoot := nil;\r\n end;\r\n Dec(FSize);\r\nend;\r\n\r\nfunction TJclIntegerTree.RetainAll(const ACollection: IJclIntegerCollection): Boolean;\r\nvar\r\n It: IJclIntegerIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := First;\r\n while It.HasNext do\r\n if not ACollection.Contains(It.Next) then\r\n It.Remove;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclIntegerTree.SetCapacity(Value: Integer);\r\nbegin\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nprocedure TJclIntegerTree.SetTraverseOrder(Value: TJclTraverseOrder);\r\nbegin\r\n FTraverseOrder := Value;\r\nend;\r\n\r\nfunction TJclIntegerTree.Size: Integer;\r\nbegin\r\n Result := FSize;\r\nend;\r\n\r\nfunction TJclIntegerTree.CreateEmptyContainer: TJclAbstractContainerBase;\r\nbegin\r\n Result := TJclIntegerTree.Create;\r\n AssignPropertiesTo(Result);\r\nend;\r\n\r\n//=== { TJclIntegerTreeIterator } ===========================================================\r\n\r\nconstructor TJclIntegerTreeIterator.Create(OwnTree: TJclIntegerTree; ACursor: TJclIntegerTreeNode; AValid: Boolean; AStart: TItrStart);\r\nbegin\r\n inherited Create(AValid);\r\n FCursor := ACursor;\r\n FOwnTree := OwnTree;\r\n FStart := AStart;\r\n FEqualityComparer := OwnTree as IJclIntegerEqualityComparer;\r\nend;\r\n\r\nfunction TJclIntegerTreeIterator.Add(AValue: Integer): Boolean;\r\nvar\r\n ParentNode, NewNode: TJclIntegerTreeNode;\r\nbegin\r\n if FOwnTree.ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n // add sibling or, if FCursor is root node, behave like TJclIntegerTree.Add\r\n Result := (FCursor <> nil) and (FOwnTree.AllowDefaultElements or not FEqualityComparer.ItemsEqual(AValue, 0))\r\n and ((not FOwnTree.Contains(AValue)) or FOwnTree.CheckDuplicate);\r\n\r\n if Result then\r\n begin\r\n ParentNode := FCursor.Parent;\r\n if ParentNode = nil then\r\n ParentNode := FCursor;\r\n\r\n if ParentNode.ChildrenCount = Length(ParentNode.Children) then\r\n SetLength(ParentNode.Children, FOwnTree.CalcGrowCapacity(Length(ParentNode.Children), ParentNode.ChildrenCount));\r\n if ParentNode.ChildrenCount < Length(ParentNode.Children) then\r\n begin\r\n NewNode := TJclIntegerTreeNode.Create;\r\n NewNode.Value := AValue;\r\n NewNode.Parent := ParentNode;\r\n ParentNode.Children[ParentNode.ChildrenCount] := NewNode;\r\n Inc(ParentNode.ChildrenCount);\r\n Inc(FOwnTree.FSize);\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.WriteUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntegerTreeIterator.AddChild(AValue: Integer): Boolean;\r\nvar\r\n NewNode: TJclIntegerTreeNode;\r\nbegin\r\n if FOwnTree.ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := (FCursor <> nil) and (FOwnTree.AllowDefaultElements or not FEqualityComparer.ItemsEqual(AValue, 0))\r\n and ((not FOwnTree.Contains(AValue)) or FOwnTree.CheckDuplicate);\r\n\r\n if Result then\r\n begin\r\n if FCursor.ChildrenCount = Length(FCursor.Children) then\r\n SetLength(FCursor.Children, FOwnTree.CalcGrowCapacity(Length(FCursor.Children), FCursor.ChildrenCount));\r\n if FCursor.ChildrenCount < Length(FCursor.Children) then\r\n begin\r\n NewNode := TJclIntegerTreeNode.Create;\r\n NewNode.Value := AValue;\r\n NewNode.Parent := FCursor;\r\n FCursor.Children[FCursor.ChildrenCount] := NewNode;\r\n Inc(FCursor.ChildrenCount);\r\n Inc(FOwnTree.FSize);\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.WriteUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclIntegerTreeIterator.AssignPropertiesTo(Dest: TJclAbstractIterator);\r\nvar\r\n ADest: TJclIntegerTreeIterator;\r\nbegin\r\n inherited AssignPropertiesTo(Dest);\r\n if Dest is TJclIntegerTreeIterator then\r\n begin\r\n ADest := TJclIntegerTreeIterator(Dest);\r\n ADest.FCursor := FCursor;\r\n ADest.FOwnTree := FOwnTree;\r\n ADest.FEqualityComparer := FEqualityComparer;\r\n ADest.FStart := FStart;\r\n end;\r\nend;\r\n\r\nfunction TJclIntegerTreeIterator.ChildrenCount: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FCursor <> nil then\r\n Result := FCursor.ChildrenCount\r\n else\r\n Result := 0;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclIntegerTreeIterator.DeleteChild(Index: Integer);\r\nbegin\r\n if FOwnTree.ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if (FCursor <> nil) and (Index >= 0) and (Index < FCursor.ChildrenCount) then\r\n {$IFDEF BCB}\r\n FOwnTree.RemoveNode(TJclIntegerTreeNode(FCursor.Children[Index]))\r\n {$ELSE ~BCB}\r\n FOwnTree.RemoveNode(FCursor.Children[Index])\r\n {$ENDIF ~BCB}\r\n else\r\n raise EJclOutOfBoundsError.Create;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.WriteUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclIntegerTreeIterator.DeleteChildren;\r\nvar\r\n Index: Integer;\r\nbegin\r\n if FOwnTree.ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FCursor <> nil then\r\n begin\r\n for Index := FCursor.ChildrenCount - 1 downto 0 do\r\n {$IFDEF BCB}\r\n FOwnTree.RemoveNode(TJclIntegerTreeNode(FCursor.Children[Index]));\r\n {$ELSE ~BCB}\r\n FOwnTree.RemoveNode(FCursor.Children[Index]);\r\n {$ENDIF ~BCB}\r\n SetLength(FCursor.Children, 0);\r\n FCursor.ChildrenCount := 0;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.WriteUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclIntegerTreeIterator.Extract;\r\nvar\r\n OldCursor: TJclIntegerTreeNode;\r\nbegin\r\n if FOwnTree.ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n CheckValid;\r\n Valid := False;\r\n OldCursor := FCursor;\r\n FCursor := GetNextSibling;\r\n if OldCursor <> nil then\r\n FOwnTree.ExtractNode(OldCursor);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.WriteUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclIntegerTreeIterator.ExtractChild(Index: Integer);\r\nbegin\r\n if FOwnTree.ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if (FCursor <> nil) and (Index >= 0) and (Index < FCursor.ChildrenCount) then\r\n {$IFDEF BCB}\r\n FOwnTree.ExtractNode(TJclIntegerTreeNode(FCursor.Children[Index]))\r\n {$ELSE ~BCB}\r\n FOwnTree.ExtractNode(FCursor.Children[Index])\r\n {$ENDIF ~BCB}\r\n else\r\n raise EJclOutOfBoundsError.Create;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.WriteUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclIntegerTreeIterator.ExtractChildren;\r\nvar\r\n Index: Integer;\r\nbegin\r\n if FOwnTree.ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FCursor <> nil then\r\n begin\r\n for Index := FCursor.ChildrenCount - 1 downto 0 do\r\n {$IFDEF BCB}\r\n FOwnTree.ExtractNode(TJclIntegerTreeNode(FCursor.Children[Index]));\r\n {$ELSE ~BCB}\r\n FOwnTree.ExtractNode(FCursor.Children[Index]);\r\n {$ENDIF ~BCB}\r\n SetLength(FCursor.Children, 0);\r\n FCursor.ChildrenCount := 0;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.WriteUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntegerTreeIterator.GetChild(Index: Integer): Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := 0;\r\n if (FCursor <> nil) and (Index >= 0) and (Index < FCursor.ChildrenCount) then\r\n FCursor := TJclIntegerTreeNode(FCursor.Children[Index]);\r\n if FCursor <> nil then\r\n Result := FCursor.Value\r\n else\r\n if not FOwnTree.ReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntegerTreeIterator.GetValue: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n CheckValid;\r\n Result := 0;\r\n if FCursor <> nil then\r\n Result := FCursor.Value\r\n else\r\n if not FOwnTree.ReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntegerTreeIterator.HasChild(Index: Integer): Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := (FCursor <> nil) and (Index >= 0) and (Index < FCursor.ChildrenCount);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntegerTreeIterator.HasNext: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Valid then\r\n Result := GetNextCursor <> nil\r\n else\r\n Result := FCursor <> nil;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntegerTreeIterator.HasParent: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := (FCursor <> nil) and (FCursor.Parent <> nil);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntegerTreeIterator.HasPrevious: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Valid then\r\n Result := GetPreviousCursor <> nil\r\n else\r\n Result := FCursor <> nil;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntegerTreeIterator.IndexOfChild(AValue: Integer): Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FCursor <> nil then\r\n Result := FCursor.IndexOfValue(AValue, FEqualityComparer)\r\n else\r\n Result := -1;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntegerTreeIterator.Insert(AValue: Integer): Boolean;\r\nvar\r\n ParentNode, NewNode: TJclIntegerTreeNode;\r\n Index, I: Integer;\r\nbegin\r\n if FOwnTree.ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n // insert sibling or, if FCursor is root node, behave like TJclIntegerTree.Insert\r\n Result := (FCursor <> nil) and (FOwnTree.AllowDefaultElements or not FEqualityComparer.ItemsEqual(AValue, 0))\r\n and ((not FOwnTree.Contains(AValue)) or FOwnTree.CheckDuplicate);\r\n\r\n if Result then\r\n begin\r\n if FCursor.Parent <> nil then\r\n begin\r\n ParentNode := FCursor.Parent;\r\n Index := 0;\r\n while (Index < ParentNode.ChildrenCount) and (ParentNode.Children[Index] <> FCursor) do\r\n Inc(Index);\r\n end\r\n else\r\n begin\r\n ParentNode := FCursor;\r\n Index := 0;\r\n end;\r\n\r\n if ParentNode.ChildrenCount = Length(ParentNode.Children) then\r\n SetLength(ParentNode.Children, FOwnTree.CalcGrowCapacity(Length(ParentNode.Children), ParentNode.ChildrenCount));\r\n if ParentNode.ChildrenCount < Length(ParentNode.Children) then\r\n begin\r\n NewNode := TJclIntegerTreeNode.Create;\r\n NewNode.Value := AValue;\r\n NewNode.Parent := ParentNode;\r\n for I := ParentNode.ChildrenCount - 1 downto Index do\r\n ParentNode.Children[I + 1] := ParentNode.Children[I];\r\n ParentNode.Children[Index] := NewNode;\r\n Inc(ParentNode.ChildrenCount);\r\n Inc(FOwnTree.FSize);\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.WriteUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntegerTreeIterator.InsertChild(Index: Integer; AValue: Integer): Boolean;\r\nvar\r\n NewNode: TJclIntegerTreeNode;\r\n I: Integer;\r\nbegin\r\n if FOwnTree.ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n // insert sibling or, if FCursor is root node, behave like TJclIntegerTree.Insert\r\n Result := (FCursor <> nil) and (FOwnTree.AllowDefaultElements or not FEqualityComparer.ItemsEqual(AValue, 0))\r\n and ((not FOwnTree.Contains(AValue)) or FOwnTree.CheckDuplicate);\r\n\r\n if Result then\r\n begin\r\n if FCursor.ChildrenCount = Length(FCursor.Children) then\r\n SetLength(FCursor.Children, FOwnTree.CalcGrowCapacity(Length(FCursor.Children), FCursor.ChildrenCount));\r\n if FCursor.ChildrenCount < Length(FCursor.Children) then\r\n begin\r\n NewNode := TJclIntegerTreeNode.Create;\r\n NewNode.Value := AValue;\r\n NewNode.Parent := FCursor;\r\n for I := FCursor.ChildrenCount - 1 downto Index do\r\n FCursor.Children[I + 1] := FCursor.Children[I];\r\n FCursor.Children[Index] := NewNode;\r\n Inc(FCursor.ChildrenCount);\r\n Inc(FOwnTree.FSize);\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.WriteUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntegerTreeIterator.IteratorEquals(const AIterator: IJclIntegerIterator): Boolean;\r\nvar\r\n Obj: TObject;\r\n ItrObj: TJclIntegerTreeIterator;\r\nbegin\r\n Result := False;\r\n if AIterator = nil then\r\n Exit;\r\n Obj := AIterator.GetIteratorReference;\r\n if Obj is TJclIntegerTreeIterator then\r\n begin\r\n ItrObj := TJclIntegerTreeIterator(Obj);\r\n Result := (FOwnTree = ItrObj.FOwnTree) and (FCursor = ItrObj.FCursor) and (Valid = ItrObj.Valid);\r\n end;\r\nend;\r\n\r\n{$IFDEF SUPPORTS_FOR_IN}\r\nfunction TJclIntegerTreeIterator.MoveNext: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Valid then\r\n FCursor := GetNextCursor\r\n else\r\n Valid := True;\r\n Result := FCursor <> nil;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n{$ENDIF SUPPORTS_FOR_IN}\r\n\r\nfunction TJclIntegerTreeIterator.Next: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Valid then\r\n FCursor := GetNextCursor\r\n else\r\n Valid := True;\r\n Result := 0;\r\n if FCursor <> nil then\r\n Result := FCursor.Value\r\n else\r\n if not FOwnTree.ReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntegerTreeIterator.NextIndex: Integer;\r\nbegin\r\n // No index\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nfunction TJclIntegerTreeIterator.Parent: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := 0;\r\n if FCursor <> nil then\r\n FCursor := FCursor.Parent;\r\n if FCursor <> nil then\r\n Result := FCursor.Value\r\n else\r\n if not FOwnTree.ReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntegerTreeIterator.Previous: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Valid then\r\n FCursor := GetPreviousCursor\r\n else\r\n Valid := True;\r\n Result := 0;\r\n if FCursor <> nil then\r\n Result := FCursor.Value\r\n else\r\n if not FOwnTree.ReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntegerTreeIterator.PreviousIndex: Integer;\r\nbegin\r\n // No index\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nprocedure TJclIntegerTreeIterator.Remove;\r\nvar\r\n OldCursor: TJclIntegerTreeNode;\r\nbegin\r\n if FOwnTree.ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n CheckValid;\r\n Valid := False;\r\n OldCursor := FCursor;\r\n FCursor := GetNextSibling;\r\n if OldCursor <> nil then\r\n FOwnTree.RemoveNode(OldCursor);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.WriteUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclIntegerTreeIterator.Reset;\r\nvar\r\n NewCursor: TJclIntegerTreeNode;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Valid := False;\r\n case FStart of\r\n isFirst:\r\n begin\r\n NewCursor := FCursor;\r\n while NewCursor <> nil do\r\n begin\r\n NewCursor := GetPreviousCursor;\r\n if NewCursor <> nil then\r\n FCursor := NewCursor;\r\n end;\r\n end;\r\n isLast:\r\n begin\r\n NewCursor := FCursor;\r\n while NewCursor <> nil do\r\n begin\r\n NewCursor := GetNextCursor;\r\n if NewCursor <> nil then\r\n FCursor := NewCursor;\r\n end;\r\n end;\r\n isRoot:\r\n begin\r\n while (FCursor <> nil) and (FCursor.Parent <> nil) do\r\n FCursor := FCursor.Parent;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclIntegerTreeIterator.SetChild(Index: Integer; AValue: Integer);\r\nbegin\r\n if FOwnTree.ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if (FCursor <> nil) and (Index >= 0) and (Index < FCursor.ChildrenCount) then\r\n TJclIntegerTreeNode(FCursor.Children[Index]).Value := AValue\r\n else\r\n raise EJclOutOfBoundsError.Create;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.WriteUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclIntegerTreeIterator.SetValue(AValue: Integer);\r\nbegin\r\n if FOwnTree.ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n CheckValid;\r\n if FCursor <> nil then\r\n begin\r\n FOwnTree.FreeInteger(FCursor.Value);\r\n FCursor.Value := AValue;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.WriteUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\n//=== { TJclPreOrderIntegerTreeIterator } ===================================================\r\n\r\nfunction TJclPreOrderIntegerTreeIterator.CreateEmptyIterator: TJclAbstractIterator;\r\nbegin\r\n Result := TJclPreOrderIntegerTreeIterator.Create(FOwnTree, FCursor, Valid, FStart);\r\nend;\r\n\r\nfunction TJclPreOrderIntegerTreeIterator.GetNextCursor: TJclIntegerTreeNode;\r\nvar\r\n LastRet: TJclIntegerTreeNode;\r\nbegin\r\n Result := FCursor;\r\n if Result = nil then\r\n Exit;\r\n LastRet := Result;\r\n if Result.ChildrenCount > 0 then\r\n Result := TJclIntegerTreeNode(Result.Children[0])\r\n else\r\n begin\r\n Result := Result.Parent;\r\n while (Result <> nil) and (Result.IndexOfChild(LastRet) = (Result.ChildrenCount - 1)) do\r\n begin\r\n LastRet := Result;\r\n Result := Result.Parent;\r\n end;\r\n if Result <> nil then // not root = return successor\r\n Result := TJclIntegerTreeNode(Result.Children[Result.IndexOfChild(LastRet) + 1]);\r\n end;\r\nend;\r\n\r\nfunction TJclPreOrderIntegerTreeIterator.GetNextSibling: TJclIntegerTreeNode;\r\nvar\r\n LastRet: TJclIntegerTreeNode;\r\nbegin\r\n Result := FCursor;\r\n if Result = nil then\r\n Exit;\r\n LastRet := Result;\r\n\r\n Result := Result.Parent;\r\n while (Result <> nil) and (Result.IndexOfChild(LastRet) = (Result.ChildrenCount - 1)) do\r\n begin\r\n LastRet := Result;\r\n Result := Result.Parent;\r\n end;\r\n if Result <> nil then // not root = return successor\r\n Result := TJclIntegerTreeNode(Result.Children[Result.IndexOfChild(LastRet) + 1]);\r\nend;\r\n\r\nfunction TJclPreOrderIntegerTreeIterator.GetPreviousCursor: TJclIntegerTreeNode;\r\nvar\r\n LastRet: TJclIntegerTreeNode;\r\nbegin\r\n Result := FCursor;\r\n if Result = nil then\r\n Exit;\r\n LastRet := Result;\r\n Result := Result.Parent;\r\n if (Result <> nil) and (Result.IndexOfChild(LastRet) > 0) then\r\n // come from Right\r\n begin\r\n Result := TJclIntegerTreeNode(Result.Children[Result.IndexOfChild(LastRet) - 1]);\r\n while (Result.ChildrenCount > 0) do // descend down the tree\r\n Result := TJclIntegerTreeNode(Result.Children[Result.ChildrenCount - 1]);\r\n end;\r\nend;\r\n\r\n//=== { TJclPostOrderIntegerTreeIterator } ==================================================\r\n\r\nfunction TJclPostOrderIntegerTreeIterator.CreateEmptyIterator: TJclAbstractIterator;\r\nbegin\r\n Result := TJclPostOrderIntegerTreeIterator.Create(FOwnTree, FCursor, Valid, FStart);\r\nend;\r\n\r\nfunction TJclPostOrderIntegerTreeIterator.GetNextCursor: TJclIntegerTreeNode;\r\nvar\r\n LastRet: TJclIntegerTreeNode;\r\nbegin\r\n Result := FCursor;\r\n if Result = nil then\r\n Exit;\r\n LastRet := Result;\r\n Result := Result.Parent;\r\n if (Result <> nil) and (Result.IndexOfChild(LastRet) <> (Result.ChildrenCount - 1)) then\r\n begin\r\n Result := TJclIntegerTreeNode(Result.Children[Result.IndexOfChild(LastRet) + 1]);\r\n while Result.ChildrenCount > 0 do\r\n Result := TJclIntegerTreeNode(Result.Children[0]);\r\n end;\r\nend;\r\n\r\nfunction TJclPostOrderIntegerTreeIterator.GetNextSibling: TJclIntegerTreeNode;\r\nvar\r\n LastRet: TJclIntegerTreeNode;\r\nbegin\r\n Result := FCursor;\r\n if Result = nil then\r\n Exit;\r\n LastRet := Result;\r\n Result := Result.Parent;\r\n\r\n if (Result <> nil) and (Result.IndexOfChild(LastRet) <> (Result.ChildrenCount - 1)) then\r\n begin\r\n Result := TJclIntegerTreeNode(Result.Children[Result.IndexOfChild(LastRet) + 1]);\r\n while Result.ChildrenCount > 0 do\r\n Result := TJclIntegerTreeNode(Result.Children[0]);\r\n end;\r\nend;\r\n\r\nfunction TJclPostOrderIntegerTreeIterator.GetPreviousCursor: TJclIntegerTreeNode;\r\nvar\r\n LastRet: TJclIntegerTreeNode;\r\nbegin\r\n Result := FCursor;\r\n if Result = nil then\r\n Exit;\r\n if Result.ChildrenCount > 0 then\r\n Result := TJclIntegerTreeNode(Result.Children[Result.ChildrenCount - 1])\r\n else\r\n begin\r\n LastRet := Result;\r\n Result := Result.Parent;\r\n while (Result <> nil) and (Result.IndexOfChild(LastRet) = 0) do\r\n begin\r\n LastRet := Result;\r\n Result := Result.Parent;\r\n end;\r\n if Result <> nil then // not root\r\n Result := TJclIntegerTreeNode(Result.Children[Result.IndexOfChild(LastRet) - 1]);\r\n end;\r\nend;\r\n\r\n//=== { TJclCardinalTreeNode } =======================================================\r\n\r\nfunction TJclCardinalTreeNode.IndexOfChild(AChild: TJclCardinalTreeNode): Integer;\r\nbegin\r\n for Result := 0 to ChildrenCount - 1 do\r\n if Children[Result] = AChild then\r\n Exit;\r\n Result := -1;\r\nend;\r\n\r\nfunction TJclCardinalTreeNode.IndexOfValue(AValue: Cardinal;\r\n const AEqualityComparer: IJclCardinalEqualityComparer): Integer;\r\nbegin\r\n for Result := 0 to ChildrenCount - 1 do\r\n if AEqualityComparer.ItemsEqual(TJclCardinalTreeNode(Children[Result]).Value, AValue) then\r\n Exit;\r\n Result := -1;\r\nend;\r\n\r\n//=== { TJclCardinalTree } =======================================================\r\n\r\nconstructor TJclCardinalTree.Create();\r\nbegin\r\n inherited Create();\r\n FTraverseOrder := toPreOrder;\r\nend;\r\n\r\ndestructor TJclCardinalTree.Destroy;\r\nbegin\r\n FReadOnly := False;\r\n Clear;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJclCardinalTree.Add(AValue: Cardinal): Boolean;\r\nvar\r\n NewNode: TJclCardinalTreeNode;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := AllowDefaultElements or not ItemsEqual(AValue, 0);\r\n\r\n if Result then\r\n begin\r\n if FRoot <> nil then\r\n begin\r\n Result := (not Contains(AValue)) or CheckDuplicate;\r\n if Result then\r\n begin\r\n if FRoot.ChildrenCount = Length(FRoot.Children) then\r\n SetLength(FRoot.Children, CalcGrowCapacity(Length(FRoot.Children), FRoot.ChildrenCount));\r\n if FRoot.ChildrenCount < Length(FRoot.Children) then\r\n begin\r\n NewNode := TJclCardinalTreeNode.Create;\r\n NewNode.Value := AValue;\r\n NewNode.Parent := FRoot;\r\n FRoot.Children[FRoot.ChildrenCount] := NewNode;\r\n Inc(FRoot.ChildrenCount);\r\n Inc(FSize);\r\n end\r\n else\r\n Result := False;\r\n end;\r\n end\r\n else\r\n begin\r\n FRoot := TJclCardinalTreeNode.Create;\r\n FRoot.Value := AValue;\r\n Inc(FSize);\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclCardinalTree.AddAll(const ACollection: IJclCardinalCollection): Boolean;\r\nvar\r\n It: IJclCardinalIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n Result := Add(It.Next) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclCardinalTree.AssignDataTo(Dest: TJclAbstractContainerBase);\r\nvar\r\n ADest: TJclCardinalTree;\r\n ACollection: IJclCardinalCollection;\r\nbegin\r\n inherited AssignDataTo(Dest);\r\n if Dest is TJclCardinalTree then\r\n begin\r\n ADest := TJclCardinalTree(Dest);\r\n ADest.Clear;\r\n ADest.FSize := FSize;\r\n if FRoot <> nil then\r\n ADest.FRoot := CloneNode(FRoot, nil);\r\n end\r\n else\r\n if Supports(IInterface(Dest), IJclCardinalCollection, ACollection) then\r\n begin\r\n ACollection.Clear;\r\n ACollection.AddAll(Self);\r\n end;\r\nend;\r\n\r\nprocedure TJclCardinalTree.AssignPropertiesTo(Dest: TJclAbstractContainerBase);\r\nbegin\r\n inherited AssignPropertiesto(Dest);\r\n if Dest is TJclCardinalTree then\r\n TJclCardinalTree(Dest).FTraverseOrder := FTraverseOrder;\r\nend;\r\n\r\nprocedure TJclCardinalTree.Clear;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FRoot <> nil then\r\n RemoveNode(FRoot);\r\n FSize := 0;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclCardinalTree.CloneNode(Node, Parent: TJclCardinalTreeNode): TJclCardinalTreeNode;\r\nvar\r\n Index: Integer;\r\nbegin\r\n Result := TJclCardinalTreeNode.Create;\r\n Result.Value := Node.Value;\r\n Result.Parent := Parent;\r\n SetLength(Result.Children, Node.ChildrenCount);\r\n Result.ChildrenCount := Node.ChildrenCount;\r\n for Index := 0 to Node.ChildrenCount - 1 do\r\n Result.Children[Index] := CloneNode(TJclCardinalTreeNode(Node.Children[Index]), Result); // recursive call\r\nend;\r\n\r\nfunction TJclCardinalTree.CollectionEquals(const ACollection: IJclCardinalCollection): Boolean;\r\nvar\r\n It, ItSelf: IJclCardinalIterator;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n if FSize <> ACollection.Size then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n ItSelf := First;\r\n while ItSelf.HasNext do\r\n if not ItemsEqual(ItSelf.Next, It.Next) then\r\n begin\r\n Result := False;\r\n Break;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclCardinalTree.Contains(AValue: Cardinal): Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FRoot <> nil then\r\n Result := NodeContains(FRoot, AValue)\r\n else\r\n Result := False;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclCardinalTree.ContainsAll(const ACollection: IJclCardinalCollection): Boolean;\r\nvar\r\n It: IJclCardinalIterator;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := True;\r\n if ACollection = nil then\r\n Exit;\r\n It := ACollection.First;\r\n while Result and It.HasNext do\r\n Result := Contains(It.Next);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclCardinalTree.Extract(AValue: Cardinal): Boolean;\r\nvar\r\n It: IJclCardinalIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := FRoot <> nil;\r\n if Result then\r\n begin\r\n It := First;\r\n while It.HasNext do\r\n if ItemsEqual(It.Next, AValue) then\r\n begin\r\n It.Extract;\r\n if RemoveSingleElement then\r\n Break;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclCardinalTree.ExtractAll(const ACollection: IJclCardinalCollection): Boolean;\r\nvar\r\n It: IJclCardinalIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n Result := Extract(It.Next) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclCardinalTree.ExtractNode(var ANode: TJclCardinalTreeNode);\r\nvar\r\n Index, ChildIndex, NewCapacity: Integer;\r\n Parent: TJclCardinalTreeNode;\r\nbegin\r\n for Index := ANode.ChildrenCount - 1 downto 0 do\r\n {$IFDEF BCB}\r\n ExtractNode(TJclCardinalTreeNode(ANode.Children[Index]));\r\n {$ELSE ~BCB}\r\n ExtractNode(ANode.Children[Index]);\r\n {$ENDIF ~BCB}\r\n Parent := ANode.Parent;\r\n if Parent <> nil then\r\n begin\r\n ChildIndex := Parent.IndexOfChild(ANode);\r\n for Index := ChildIndex + 1 to Parent.ChildrenCount - 1 do\r\n Parent.Children[Index - 1] := Parent.Children[Index];\r\n Dec(Parent.ChildrenCount);\r\n NewCapacity := CalcPackCapacity(Length(Parent.Children), Parent.ChildrenCount);\r\n if NewCapacity < Length(Parent.Children) then\r\n SetLength(Parent.Children, NewCapacity);\r\n FreeAndNil(ANode);\r\n end\r\n else\r\n begin\r\n FreeAndNil(ANode);\r\n FRoot := nil;\r\n end;\r\n Dec(FSize);\r\nend;\r\n\r\nfunction TJclCardinalTree.First: IJclCardinalIterator;\r\nvar\r\n Start: TJclCardinalTreeNode;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Start := FRoot;\r\n case GetTraverseOrder of\r\n toPreOrder:\r\n Result := TJclPreOrderCardinalTreeIterator.Create(Self, Start, False, isFirst);\r\n toPostOrder:\r\n begin\r\n if Start <> nil then\r\n while (Start.ChildrenCount > 0) do\r\n Start := TJclCardinalTreeNode(Start.Children[0]);\r\n Result := TJclPostOrderCardinalTreeIterator.Create(Self, Start, False, isFirst);\r\n end;\r\n else\r\n Result := nil;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\n{$IFDEF SUPPORTS_FOR_IN}\r\nfunction TJclCardinalTree.GetEnumerator: IJclCardinalIterator;\r\nbegin\r\n Result := First;\r\nend;\r\n{$ENDIF SUPPORTS_FOR_IN}\r\n\r\nfunction TJclCardinalTree.GetRoot: IJclCardinalTreeIterator;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n case GetTraverseOrder of\r\n toPreOrder:\r\n Result := TJclPreOrderCardinalTreeIterator.Create(Self, FRoot, False, isRoot);\r\n toPostOrder:\r\n Result := TJclPostOrderCardinalTreeIterator.Create(Self, FRoot, False, isRoot);\r\n else\r\n Result := nil;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclCardinalTree.GetTraverseOrder: TJclTraverseOrder;\r\nbegin\r\n Result := FTraverseOrder;\r\nend;\r\n\r\nfunction TJclCardinalTree.IsEmpty: Boolean;\r\nbegin\r\n Result := FSize = 0;\r\nend;\r\n\r\nfunction TJclCardinalTree.Last: IJclCardinalIterator;\r\nvar\r\n Start: TJclCardinalTreeNode;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Start := FRoot;\r\n case FTraverseOrder of\r\n toPreOrder:\r\n begin\r\n if Start <> nil then\r\n while Start.ChildrenCount > 0 do\r\n Start := TJclCardinalTreeNode(Start.Children[Start.ChildrenCount - 1]);\r\n Result := TJclPreOrderCardinalTreeIterator.Create(Self, Start, False, isLast);\r\n end;\r\n toPostOrder:\r\n Result := TJclPostOrderCardinalTreeIterator.Create(Self, Start, False, isLast);\r\n else\r\n Result := nil;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclCardinalTree.NodeContains(ANode: TJclCardinalTreeNode; AValue: Cardinal): Boolean;\r\nvar\r\n Index: Integer;\r\nbegin\r\n Result := ItemsEqual(ANode.Value, AValue);\r\n if not Result then\r\n for Index := 0 to ANode.ChildrenCount - 1 do\r\n begin\r\n Result := NodeContains(TJclCardinalTreeNode(ANode.Children[Index]), AValue);\r\n if Result then\r\n Break;\r\n end;\r\nend;\r\n\r\nprocedure TJclCardinalTree.Pack;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FRoot <> nil then\r\n PackNode(FRoot);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclCardinalTree.PackNode(ANode: TJclCardinalTreeNode);\r\nvar\r\n Index: Integer;\r\nbegin\r\n SetLength(ANode.Children, ANode.ChildrenCount);\r\n for Index := 0 to ANode.ChildrenCount - 1 do\r\n PackNode(TJclCardinalTreeNode(ANode.Children[Index]));\r\nend;\r\n\r\nfunction TJclCardinalTree.Remove(AValue: Cardinal): Boolean;\r\nvar\r\n Extracted: Cardinal;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := Extract(AValue);\r\n if Result then\r\n begin\r\n Extracted := AValue;\r\n FreeCardinal(Extracted);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclCardinalTree.RemoveAll(const ACollection: IJclCardinalCollection): Boolean;\r\nvar\r\n It: IJclCardinalIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n Result := Remove(It.Next) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclCardinalTree.RemoveNode(var ANode: TJclCardinalTreeNode);\r\nvar\r\n Index, ChildIndex, NewCapacity: Integer;\r\n Parent: TJclCardinalTreeNode;\r\nbegin\r\n for Index := ANode.ChildrenCount - 1 downto 0 do\r\n {$IFDEF BCB}\r\n RemoveNode(TJclCardinalTreeNode(ANode.Children[Index]));\r\n {$ELSE ~BCB}\r\n RemoveNode(ANode.Children[Index]);\r\n {$ENDIF ~BCB}\r\n FreeCardinal(ANode.Value);\r\n Parent := ANode.Parent;\r\n if Parent <> nil then\r\n begin\r\n ChildIndex := Parent.IndexOfChild(ANode);\r\n for Index := ChildIndex + 1 to Parent.ChildrenCount - 1 do\r\n Parent.Children[Index - 1] := Parent.Children[Index];\r\n Dec(Parent.ChildrenCount);\r\n NewCapacity := CalcPackCapacity(Length(Parent.Children), Parent.ChildrenCount);\r\n if NewCapacity < Length(Parent.Children) then\r\n SetLength(Parent.Children, NewCapacity);\r\n FreeAndNil(ANode);\r\n end\r\n else\r\n begin\r\n FreeAndNil(ANode);\r\n FRoot := nil;\r\n end;\r\n Dec(FSize);\r\nend;\r\n\r\nfunction TJclCardinalTree.RetainAll(const ACollection: IJclCardinalCollection): Boolean;\r\nvar\r\n It: IJclCardinalIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := First;\r\n while It.HasNext do\r\n if not ACollection.Contains(It.Next) then\r\n It.Remove;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclCardinalTree.SetCapacity(Value: Integer);\r\nbegin\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nprocedure TJclCardinalTree.SetTraverseOrder(Value: TJclTraverseOrder);\r\nbegin\r\n FTraverseOrder := Value;\r\nend;\r\n\r\nfunction TJclCardinalTree.Size: Integer;\r\nbegin\r\n Result := FSize;\r\nend;\r\n\r\nfunction TJclCardinalTree.CreateEmptyContainer: TJclAbstractContainerBase;\r\nbegin\r\n Result := TJclCardinalTree.Create;\r\n AssignPropertiesTo(Result);\r\nend;\r\n\r\n//=== { TJclCardinalTreeIterator } ===========================================================\r\n\r\nconstructor TJclCardinalTreeIterator.Create(OwnTree: TJclCardinalTree; ACursor: TJclCardinalTreeNode; AValid: Boolean; AStart: TItrStart);\r\nbegin\r\n inherited Create(AValid);\r\n FCursor := ACursor;\r\n FOwnTree := OwnTree;\r\n FStart := AStart;\r\n FEqualityComparer := OwnTree as IJclCardinalEqualityComparer;\r\nend;\r\n\r\nfunction TJclCardinalTreeIterator.Add(AValue: Cardinal): Boolean;\r\nvar\r\n ParentNode, NewNode: TJclCardinalTreeNode;\r\nbegin\r\n if FOwnTree.ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n // add sibling or, if FCursor is root node, behave like TJclCardinalTree.Add\r\n Result := (FCursor <> nil) and (FOwnTree.AllowDefaultElements or not FEqualityComparer.ItemsEqual(AValue, 0))\r\n and ((not FOwnTree.Contains(AValue)) or FOwnTree.CheckDuplicate);\r\n\r\n if Result then\r\n begin\r\n ParentNode := FCursor.Parent;\r\n if ParentNode = nil then\r\n ParentNode := FCursor;\r\n\r\n if ParentNode.ChildrenCount = Length(ParentNode.Children) then\r\n SetLength(ParentNode.Children, FOwnTree.CalcGrowCapacity(Length(ParentNode.Children), ParentNode.ChildrenCount));\r\n if ParentNode.ChildrenCount < Length(ParentNode.Children) then\r\n begin\r\n NewNode := TJclCardinalTreeNode.Create;\r\n NewNode.Value := AValue;\r\n NewNode.Parent := ParentNode;\r\n ParentNode.Children[ParentNode.ChildrenCount] := NewNode;\r\n Inc(ParentNode.ChildrenCount);\r\n Inc(FOwnTree.FSize);\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.WriteUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclCardinalTreeIterator.AddChild(AValue: Cardinal): Boolean;\r\nvar\r\n NewNode: TJclCardinalTreeNode;\r\nbegin\r\n if FOwnTree.ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := (FCursor <> nil) and (FOwnTree.AllowDefaultElements or not FEqualityComparer.ItemsEqual(AValue, 0))\r\n and ((not FOwnTree.Contains(AValue)) or FOwnTree.CheckDuplicate);\r\n\r\n if Result then\r\n begin\r\n if FCursor.ChildrenCount = Length(FCursor.Children) then\r\n SetLength(FCursor.Children, FOwnTree.CalcGrowCapacity(Length(FCursor.Children), FCursor.ChildrenCount));\r\n if FCursor.ChildrenCount < Length(FCursor.Children) then\r\n begin\r\n NewNode := TJclCardinalTreeNode.Create;\r\n NewNode.Value := AValue;\r\n NewNode.Parent := FCursor;\r\n FCursor.Children[FCursor.ChildrenCount] := NewNode;\r\n Inc(FCursor.ChildrenCount);\r\n Inc(FOwnTree.FSize);\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.WriteUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclCardinalTreeIterator.AssignPropertiesTo(Dest: TJclAbstractIterator);\r\nvar\r\n ADest: TJclCardinalTreeIterator;\r\nbegin\r\n inherited AssignPropertiesTo(Dest);\r\n if Dest is TJclCardinalTreeIterator then\r\n begin\r\n ADest := TJclCardinalTreeIterator(Dest);\r\n ADest.FCursor := FCursor;\r\n ADest.FOwnTree := FOwnTree;\r\n ADest.FEqualityComparer := FEqualityComparer;\r\n ADest.FStart := FStart;\r\n end;\r\nend;\r\n\r\nfunction TJclCardinalTreeIterator.ChildrenCount: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FCursor <> nil then\r\n Result := FCursor.ChildrenCount\r\n else\r\n Result := 0;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclCardinalTreeIterator.DeleteChild(Index: Integer);\r\nbegin\r\n if FOwnTree.ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if (FCursor <> nil) and (Index >= 0) and (Index < FCursor.ChildrenCount) then\r\n {$IFDEF BCB}\r\n FOwnTree.RemoveNode(TJclCardinalTreeNode(FCursor.Children[Index]))\r\n {$ELSE ~BCB}\r\n FOwnTree.RemoveNode(FCursor.Children[Index])\r\n {$ENDIF ~BCB}\r\n else\r\n raise EJclOutOfBoundsError.Create;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.WriteUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclCardinalTreeIterator.DeleteChildren;\r\nvar\r\n Index: Integer;\r\nbegin\r\n if FOwnTree.ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FCursor <> nil then\r\n begin\r\n for Index := FCursor.ChildrenCount - 1 downto 0 do\r\n {$IFDEF BCB}\r\n FOwnTree.RemoveNode(TJclCardinalTreeNode(FCursor.Children[Index]));\r\n {$ELSE ~BCB}\r\n FOwnTree.RemoveNode(FCursor.Children[Index]);\r\n {$ENDIF ~BCB}\r\n SetLength(FCursor.Children, 0);\r\n FCursor.ChildrenCount := 0;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.WriteUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclCardinalTreeIterator.Extract;\r\nvar\r\n OldCursor: TJclCardinalTreeNode;\r\nbegin\r\n if FOwnTree.ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n CheckValid;\r\n Valid := False;\r\n OldCursor := FCursor;\r\n FCursor := GetNextSibling;\r\n if OldCursor <> nil then\r\n FOwnTree.ExtractNode(OldCursor);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.WriteUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclCardinalTreeIterator.ExtractChild(Index: Integer);\r\nbegin\r\n if FOwnTree.ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if (FCursor <> nil) and (Index >= 0) and (Index < FCursor.ChildrenCount) then\r\n {$IFDEF BCB}\r\n FOwnTree.ExtractNode(TJclCardinalTreeNode(FCursor.Children[Index]))\r\n {$ELSE ~BCB}\r\n FOwnTree.ExtractNode(FCursor.Children[Index])\r\n {$ENDIF ~BCB}\r\n else\r\n raise EJclOutOfBoundsError.Create;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.WriteUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclCardinalTreeIterator.ExtractChildren;\r\nvar\r\n Index: Integer;\r\nbegin\r\n if FOwnTree.ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FCursor <> nil then\r\n begin\r\n for Index := FCursor.ChildrenCount - 1 downto 0 do\r\n {$IFDEF BCB}\r\n FOwnTree.ExtractNode(TJclCardinalTreeNode(FCursor.Children[Index]));\r\n {$ELSE ~BCB}\r\n FOwnTree.ExtractNode(FCursor.Children[Index]);\r\n {$ENDIF ~BCB}\r\n SetLength(FCursor.Children, 0);\r\n FCursor.ChildrenCount := 0;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.WriteUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclCardinalTreeIterator.GetChild(Index: Integer): Cardinal;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := 0;\r\n if (FCursor <> nil) and (Index >= 0) and (Index < FCursor.ChildrenCount) then\r\n FCursor := TJclCardinalTreeNode(FCursor.Children[Index]);\r\n if FCursor <> nil then\r\n Result := FCursor.Value\r\n else\r\n if not FOwnTree.ReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclCardinalTreeIterator.GetValue: Cardinal;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n CheckValid;\r\n Result := 0;\r\n if FCursor <> nil then\r\n Result := FCursor.Value\r\n else\r\n if not FOwnTree.ReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclCardinalTreeIterator.HasChild(Index: Integer): Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := (FCursor <> nil) and (Index >= 0) and (Index < FCursor.ChildrenCount);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclCardinalTreeIterator.HasNext: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Valid then\r\n Result := GetNextCursor <> nil\r\n else\r\n Result := FCursor <> nil;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclCardinalTreeIterator.HasParent: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := (FCursor <> nil) and (FCursor.Parent <> nil);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclCardinalTreeIterator.HasPrevious: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Valid then\r\n Result := GetPreviousCursor <> nil\r\n else\r\n Result := FCursor <> nil;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclCardinalTreeIterator.IndexOfChild(AValue: Cardinal): Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FCursor <> nil then\r\n Result := FCursor.IndexOfValue(AValue, FEqualityComparer)\r\n else\r\n Result := -1;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclCardinalTreeIterator.Insert(AValue: Cardinal): Boolean;\r\nvar\r\n ParentNode, NewNode: TJclCardinalTreeNode;\r\n Index, I: Integer;\r\nbegin\r\n if FOwnTree.ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n // insert sibling or, if FCursor is root node, behave like TJclCardinalTree.Insert\r\n Result := (FCursor <> nil) and (FOwnTree.AllowDefaultElements or not FEqualityComparer.ItemsEqual(AValue, 0))\r\n and ((not FOwnTree.Contains(AValue)) or FOwnTree.CheckDuplicate);\r\n\r\n if Result then\r\n begin\r\n if FCursor.Parent <> nil then\r\n begin\r\n ParentNode := FCursor.Parent;\r\n Index := 0;\r\n while (Index < ParentNode.ChildrenCount) and (ParentNode.Children[Index] <> FCursor) do\r\n Inc(Index);\r\n end\r\n else\r\n begin\r\n ParentNode := FCursor;\r\n Index := 0;\r\n end;\r\n\r\n if ParentNode.ChildrenCount = Length(ParentNode.Children) then\r\n SetLength(ParentNode.Children, FOwnTree.CalcGrowCapacity(Length(ParentNode.Children), ParentNode.ChildrenCount));\r\n if ParentNode.ChildrenCount < Length(ParentNode.Children) then\r\n begin\r\n NewNode := TJclCardinalTreeNode.Create;\r\n NewNode.Value := AValue;\r\n NewNode.Parent := ParentNode;\r\n for I := ParentNode.ChildrenCount - 1 downto Index do\r\n ParentNode.Children[I + 1] := ParentNode.Children[I];\r\n ParentNode.Children[Index] := NewNode;\r\n Inc(ParentNode.ChildrenCount);\r\n Inc(FOwnTree.FSize);\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.WriteUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclCardinalTreeIterator.InsertChild(Index: Integer; AValue: Cardinal): Boolean;\r\nvar\r\n NewNode: TJclCardinalTreeNode;\r\n I: Integer;\r\nbegin\r\n if FOwnTree.ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n // insert sibling or, if FCursor is root node, behave like TJclCardinalTree.Insert\r\n Result := (FCursor <> nil) and (FOwnTree.AllowDefaultElements or not FEqualityComparer.ItemsEqual(AValue, 0))\r\n and ((not FOwnTree.Contains(AValue)) or FOwnTree.CheckDuplicate);\r\n\r\n if Result then\r\n begin\r\n if FCursor.ChildrenCount = Length(FCursor.Children) then\r\n SetLength(FCursor.Children, FOwnTree.CalcGrowCapacity(Length(FCursor.Children), FCursor.ChildrenCount));\r\n if FCursor.ChildrenCount < Length(FCursor.Children) then\r\n begin\r\n NewNode := TJclCardinalTreeNode.Create;\r\n NewNode.Value := AValue;\r\n NewNode.Parent := FCursor;\r\n for I := FCursor.ChildrenCount - 1 downto Index do\r\n FCursor.Children[I + 1] := FCursor.Children[I];\r\n FCursor.Children[Index] := NewNode;\r\n Inc(FCursor.ChildrenCount);\r\n Inc(FOwnTree.FSize);\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.WriteUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclCardinalTreeIterator.IteratorEquals(const AIterator: IJclCardinalIterator): Boolean;\r\nvar\r\n Obj: TObject;\r\n ItrObj: TJclCardinalTreeIterator;\r\nbegin\r\n Result := False;\r\n if AIterator = nil then\r\n Exit;\r\n Obj := AIterator.GetIteratorReference;\r\n if Obj is TJclCardinalTreeIterator then\r\n begin\r\n ItrObj := TJclCardinalTreeIterator(Obj);\r\n Result := (FOwnTree = ItrObj.FOwnTree) and (FCursor = ItrObj.FCursor) and (Valid = ItrObj.Valid);\r\n end;\r\nend;\r\n\r\n{$IFDEF SUPPORTS_FOR_IN}\r\nfunction TJclCardinalTreeIterator.MoveNext: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Valid then\r\n FCursor := GetNextCursor\r\n else\r\n Valid := True;\r\n Result := FCursor <> nil;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n{$ENDIF SUPPORTS_FOR_IN}\r\n\r\nfunction TJclCardinalTreeIterator.Next: Cardinal;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Valid then\r\n FCursor := GetNextCursor\r\n else\r\n Valid := True;\r\n Result := 0;\r\n if FCursor <> nil then\r\n Result := FCursor.Value\r\n else\r\n if not FOwnTree.ReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclCardinalTreeIterator.NextIndex: Integer;\r\nbegin\r\n // No index\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nfunction TJclCardinalTreeIterator.Parent: Cardinal;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := 0;\r\n if FCursor <> nil then\r\n FCursor := FCursor.Parent;\r\n if FCursor <> nil then\r\n Result := FCursor.Value\r\n else\r\n if not FOwnTree.ReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclCardinalTreeIterator.Previous: Cardinal;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Valid then\r\n FCursor := GetPreviousCursor\r\n else\r\n Valid := True;\r\n Result := 0;\r\n if FCursor <> nil then\r\n Result := FCursor.Value\r\n else\r\n if not FOwnTree.ReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclCardinalTreeIterator.PreviousIndex: Integer;\r\nbegin\r\n // No index\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nprocedure TJclCardinalTreeIterator.Remove;\r\nvar\r\n OldCursor: TJclCardinalTreeNode;\r\nbegin\r\n if FOwnTree.ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n CheckValid;\r\n Valid := False;\r\n OldCursor := FCursor;\r\n FCursor := GetNextSibling;\r\n if OldCursor <> nil then\r\n FOwnTree.RemoveNode(OldCursor);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.WriteUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclCardinalTreeIterator.Reset;\r\nvar\r\n NewCursor: TJclCardinalTreeNode;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Valid := False;\r\n case FStart of\r\n isFirst:\r\n begin\r\n NewCursor := FCursor;\r\n while NewCursor <> nil do\r\n begin\r\n NewCursor := GetPreviousCursor;\r\n if NewCursor <> nil then\r\n FCursor := NewCursor;\r\n end;\r\n end;\r\n isLast:\r\n begin\r\n NewCursor := FCursor;\r\n while NewCursor <> nil do\r\n begin\r\n NewCursor := GetNextCursor;\r\n if NewCursor <> nil then\r\n FCursor := NewCursor;\r\n end;\r\n end;\r\n isRoot:\r\n begin\r\n while (FCursor <> nil) and (FCursor.Parent <> nil) do\r\n FCursor := FCursor.Parent;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclCardinalTreeIterator.SetChild(Index: Integer; AValue: Cardinal);\r\nbegin\r\n if FOwnTree.ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if (FCursor <> nil) and (Index >= 0) and (Index < FCursor.ChildrenCount) then\r\n TJclCardinalTreeNode(FCursor.Children[Index]).Value := AValue\r\n else\r\n raise EJclOutOfBoundsError.Create;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.WriteUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclCardinalTreeIterator.SetValue(AValue: Cardinal);\r\nbegin\r\n if FOwnTree.ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n CheckValid;\r\n if FCursor <> nil then\r\n begin\r\n FOwnTree.FreeCardinal(FCursor.Value);\r\n FCursor.Value := AValue;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.WriteUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\n//=== { TJclPreOrderCardinalTreeIterator } ===================================================\r\n\r\nfunction TJclPreOrderCardinalTreeIterator.CreateEmptyIterator: TJclAbstractIterator;\r\nbegin\r\n Result := TJclPreOrderCardinalTreeIterator.Create(FOwnTree, FCursor, Valid, FStart);\r\nend;\r\n\r\nfunction TJclPreOrderCardinalTreeIterator.GetNextCursor: TJclCardinalTreeNode;\r\nvar\r\n LastRet: TJclCardinalTreeNode;\r\nbegin\r\n Result := FCursor;\r\n if Result = nil then\r\n Exit;\r\n LastRet := Result;\r\n if Result.ChildrenCount > 0 then\r\n Result := TJclCardinalTreeNode(Result.Children[0])\r\n else\r\n begin\r\n Result := Result.Parent;\r\n while (Result <> nil) and (Result.IndexOfChild(LastRet) = (Result.ChildrenCount - 1)) do\r\n begin\r\n LastRet := Result;\r\n Result := Result.Parent;\r\n end;\r\n if Result <> nil then // not root = return successor\r\n Result := TJclCardinalTreeNode(Result.Children[Result.IndexOfChild(LastRet) + 1]);\r\n end;\r\nend;\r\n\r\nfunction TJclPreOrderCardinalTreeIterator.GetNextSibling: TJclCardinalTreeNode;\r\nvar\r\n LastRet: TJclCardinalTreeNode;\r\nbegin\r\n Result := FCursor;\r\n if Result = nil then\r\n Exit;\r\n LastRet := Result;\r\n\r\n Result := Result.Parent;\r\n while (Result <> nil) and (Result.IndexOfChild(LastRet) = (Result.ChildrenCount - 1)) do\r\n begin\r\n LastRet := Result;\r\n Result := Result.Parent;\r\n end;\r\n if Result <> nil then // not root = return successor\r\n Result := TJclCardinalTreeNode(Result.Children[Result.IndexOfChild(LastRet) + 1]);\r\nend;\r\n\r\nfunction TJclPreOrderCardinalTreeIterator.GetPreviousCursor: TJclCardinalTreeNode;\r\nvar\r\n LastRet: TJclCardinalTreeNode;\r\nbegin\r\n Result := FCursor;\r\n if Result = nil then\r\n Exit;\r\n LastRet := Result;\r\n Result := Result.Parent;\r\n if (Result <> nil) and (Result.IndexOfChild(LastRet) > 0) then\r\n // come from Right\r\n begin\r\n Result := TJclCardinalTreeNode(Result.Children[Result.IndexOfChild(LastRet) - 1]);\r\n while (Result.ChildrenCount > 0) do // descend down the tree\r\n Result := TJclCardinalTreeNode(Result.Children[Result.ChildrenCount - 1]);\r\n end;\r\nend;\r\n\r\n//=== { TJclPostOrderCardinalTreeIterator } ==================================================\r\n\r\nfunction TJclPostOrderCardinalTreeIterator.CreateEmptyIterator: TJclAbstractIterator;\r\nbegin\r\n Result := TJclPostOrderCardinalTreeIterator.Create(FOwnTree, FCursor, Valid, FStart);\r\nend;\r\n\r\nfunction TJclPostOrderCardinalTreeIterator.GetNextCursor: TJclCardinalTreeNode;\r\nvar\r\n LastRet: TJclCardinalTreeNode;\r\nbegin\r\n Result := FCursor;\r\n if Result = nil then\r\n Exit;\r\n LastRet := Result;\r\n Result := Result.Parent;\r\n if (Result <> nil) and (Result.IndexOfChild(LastRet) <> (Result.ChildrenCount - 1)) then\r\n begin\r\n Result := TJclCardinalTreeNode(Result.Children[Result.IndexOfChild(LastRet) + 1]);\r\n while Result.ChildrenCount > 0 do\r\n Result := TJclCardinalTreeNode(Result.Children[0]);\r\n end;\r\nend;\r\n\r\nfunction TJclPostOrderCardinalTreeIterator.GetNextSibling: TJclCardinalTreeNode;\r\nvar\r\n LastRet: TJclCardinalTreeNode;\r\nbegin\r\n Result := FCursor;\r\n if Result = nil then\r\n Exit;\r\n LastRet := Result;\r\n Result := Result.Parent;\r\n\r\n if (Result <> nil) and (Result.IndexOfChild(LastRet) <> (Result.ChildrenCount - 1)) then\r\n begin\r\n Result := TJclCardinalTreeNode(Result.Children[Result.IndexOfChild(LastRet) + 1]);\r\n while Result.ChildrenCount > 0 do\r\n Result := TJclCardinalTreeNode(Result.Children[0]);\r\n end;\r\nend;\r\n\r\nfunction TJclPostOrderCardinalTreeIterator.GetPreviousCursor: TJclCardinalTreeNode;\r\nvar\r\n LastRet: TJclCardinalTreeNode;\r\nbegin\r\n Result := FCursor;\r\n if Result = nil then\r\n Exit;\r\n if Result.ChildrenCount > 0 then\r\n Result := TJclCardinalTreeNode(Result.Children[Result.ChildrenCount - 1])\r\n else\r\n begin\r\n LastRet := Result;\r\n Result := Result.Parent;\r\n while (Result <> nil) and (Result.IndexOfChild(LastRet) = 0) do\r\n begin\r\n LastRet := Result;\r\n Result := Result.Parent;\r\n end;\r\n if Result <> nil then // not root\r\n Result := TJclCardinalTreeNode(Result.Children[Result.IndexOfChild(LastRet) - 1]);\r\n end;\r\nend;\r\n\r\n//=== { TJclInt64TreeNode } =======================================================\r\n\r\nfunction TJclInt64TreeNode.IndexOfChild(AChild: TJclInt64TreeNode): Integer;\r\nbegin\r\n for Result := 0 to ChildrenCount - 1 do\r\n if Children[Result] = AChild then\r\n Exit;\r\n Result := -1;\r\nend;\r\n\r\nfunction TJclInt64TreeNode.IndexOfValue(const AValue: Int64;\r\n const AEqualityComparer: IJclInt64EqualityComparer): Integer;\r\nbegin\r\n for Result := 0 to ChildrenCount - 1 do\r\n if AEqualityComparer.ItemsEqual(TJclInt64TreeNode(Children[Result]).Value, AValue) then\r\n Exit;\r\n Result := -1;\r\nend;\r\n\r\n//=== { TJclInt64Tree } =======================================================\r\n\r\nconstructor TJclInt64Tree.Create();\r\nbegin\r\n inherited Create();\r\n FTraverseOrder := toPreOrder;\r\nend;\r\n\r\ndestructor TJclInt64Tree.Destroy;\r\nbegin\r\n FReadOnly := False;\r\n Clear;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJclInt64Tree.Add(const AValue: Int64): Boolean;\r\nvar\r\n NewNode: TJclInt64TreeNode;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := AllowDefaultElements or not ItemsEqual(AValue, 0);\r\n\r\n if Result then\r\n begin\r\n if FRoot <> nil then\r\n begin\r\n Result := (not Contains(AValue)) or CheckDuplicate;\r\n if Result then\r\n begin\r\n if FRoot.ChildrenCount = Length(FRoot.Children) then\r\n SetLength(FRoot.Children, CalcGrowCapacity(Length(FRoot.Children), FRoot.ChildrenCount));\r\n if FRoot.ChildrenCount < Length(FRoot.Children) then\r\n begin\r\n NewNode := TJclInt64TreeNode.Create;\r\n NewNode.Value := AValue;\r\n NewNode.Parent := FRoot;\r\n FRoot.Children[FRoot.ChildrenCount] := NewNode;\r\n Inc(FRoot.ChildrenCount);\r\n Inc(FSize);\r\n end\r\n else\r\n Result := False;\r\n end;\r\n end\r\n else\r\n begin\r\n FRoot := TJclInt64TreeNode.Create;\r\n FRoot.Value := AValue;\r\n Inc(FSize);\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclInt64Tree.AddAll(const ACollection: IJclInt64Collection): Boolean;\r\nvar\r\n It: IJclInt64Iterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n Result := Add(It.Next) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclInt64Tree.AssignDataTo(Dest: TJclAbstractContainerBase);\r\nvar\r\n ADest: TJclInt64Tree;\r\n ACollection: IJclInt64Collection;\r\nbegin\r\n inherited AssignDataTo(Dest);\r\n if Dest is TJclInt64Tree then\r\n begin\r\n ADest := TJclInt64Tree(Dest);\r\n ADest.Clear;\r\n ADest.FSize := FSize;\r\n if FRoot <> nil then\r\n ADest.FRoot := CloneNode(FRoot, nil);\r\n end\r\n else\r\n if Supports(IInterface(Dest), IJclInt64Collection, ACollection) then\r\n begin\r\n ACollection.Clear;\r\n ACollection.AddAll(Self);\r\n end;\r\nend;\r\n\r\nprocedure TJclInt64Tree.AssignPropertiesTo(Dest: TJclAbstractContainerBase);\r\nbegin\r\n inherited AssignPropertiesto(Dest);\r\n if Dest is TJclInt64Tree then\r\n TJclInt64Tree(Dest).FTraverseOrder := FTraverseOrder;\r\nend;\r\n\r\nprocedure TJclInt64Tree.Clear;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FRoot <> nil then\r\n RemoveNode(FRoot);\r\n FSize := 0;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclInt64Tree.CloneNode(Node, Parent: TJclInt64TreeNode): TJclInt64TreeNode;\r\nvar\r\n Index: Integer;\r\nbegin\r\n Result := TJclInt64TreeNode.Create;\r\n Result.Value := Node.Value;\r\n Result.Parent := Parent;\r\n SetLength(Result.Children, Node.ChildrenCount);\r\n Result.ChildrenCount := Node.ChildrenCount;\r\n for Index := 0 to Node.ChildrenCount - 1 do\r\n Result.Children[Index] := CloneNode(TJclInt64TreeNode(Node.Children[Index]), Result); // recursive call\r\nend;\r\n\r\nfunction TJclInt64Tree.CollectionEquals(const ACollection: IJclInt64Collection): Boolean;\r\nvar\r\n It, ItSelf: IJclInt64Iterator;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n if FSize <> ACollection.Size then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n ItSelf := First;\r\n while ItSelf.HasNext do\r\n if not ItemsEqual(ItSelf.Next, It.Next) then\r\n begin\r\n Result := False;\r\n Break;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclInt64Tree.Contains(const AValue: Int64): Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FRoot <> nil then\r\n Result := NodeContains(FRoot, AValue)\r\n else\r\n Result := False;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclInt64Tree.ContainsAll(const ACollection: IJclInt64Collection): Boolean;\r\nvar\r\n It: IJclInt64Iterator;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := True;\r\n if ACollection = nil then\r\n Exit;\r\n It := ACollection.First;\r\n while Result and It.HasNext do\r\n Result := Contains(It.Next);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclInt64Tree.Extract(const AValue: Int64): Boolean;\r\nvar\r\n It: IJclInt64Iterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := FRoot <> nil;\r\n if Result then\r\n begin\r\n It := First;\r\n while It.HasNext do\r\n if ItemsEqual(It.Next, AValue) then\r\n begin\r\n It.Extract;\r\n if RemoveSingleElement then\r\n Break;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclInt64Tree.ExtractAll(const ACollection: IJclInt64Collection): Boolean;\r\nvar\r\n It: IJclInt64Iterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n Result := Extract(It.Next) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclInt64Tree.ExtractNode(var ANode: TJclInt64TreeNode);\r\nvar\r\n Index, ChildIndex, NewCapacity: Integer;\r\n Parent: TJclInt64TreeNode;\r\nbegin\r\n for Index := ANode.ChildrenCount - 1 downto 0 do\r\n {$IFDEF BCB}\r\n ExtractNode(TJclInt64TreeNode(ANode.Children[Index]));\r\n {$ELSE ~BCB}\r\n ExtractNode(ANode.Children[Index]);\r\n {$ENDIF ~BCB}\r\n Parent := ANode.Parent;\r\n if Parent <> nil then\r\n begin\r\n ChildIndex := Parent.IndexOfChild(ANode);\r\n for Index := ChildIndex + 1 to Parent.ChildrenCount - 1 do\r\n Parent.Children[Index - 1] := Parent.Children[Index];\r\n Dec(Parent.ChildrenCount);\r\n NewCapacity := CalcPackCapacity(Length(Parent.Children), Parent.ChildrenCount);\r\n if NewCapacity < Length(Parent.Children) then\r\n SetLength(Parent.Children, NewCapacity);\r\n FreeAndNil(ANode);\r\n end\r\n else\r\n begin\r\n FreeAndNil(ANode);\r\n FRoot := nil;\r\n end;\r\n Dec(FSize);\r\nend;\r\n\r\nfunction TJclInt64Tree.First: IJclInt64Iterator;\r\nvar\r\n Start: TJclInt64TreeNode;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Start := FRoot;\r\n case GetTraverseOrder of\r\n toPreOrder:\r\n Result := TJclPreOrderInt64TreeIterator.Create(Self, Start, False, isFirst);\r\n toPostOrder:\r\n begin\r\n if Start <> nil then\r\n while (Start.ChildrenCount > 0) do\r\n Start := TJclInt64TreeNode(Start.Children[0]);\r\n Result := TJclPostOrderInt64TreeIterator.Create(Self, Start, False, isFirst);\r\n end;\r\n else\r\n Result := nil;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\n{$IFDEF SUPPORTS_FOR_IN}\r\nfunction TJclInt64Tree.GetEnumerator: IJclInt64Iterator;\r\nbegin\r\n Result := First;\r\nend;\r\n{$ENDIF SUPPORTS_FOR_IN}\r\n\r\nfunction TJclInt64Tree.GetRoot: IJclInt64TreeIterator;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n case GetTraverseOrder of\r\n toPreOrder:\r\n Result := TJclPreOrderInt64TreeIterator.Create(Self, FRoot, False, isRoot);\r\n toPostOrder:\r\n Result := TJclPostOrderInt64TreeIterator.Create(Self, FRoot, False, isRoot);\r\n else\r\n Result := nil;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclInt64Tree.GetTraverseOrder: TJclTraverseOrder;\r\nbegin\r\n Result := FTraverseOrder;\r\nend;\r\n\r\nfunction TJclInt64Tree.IsEmpty: Boolean;\r\nbegin\r\n Result := FSize = 0;\r\nend;\r\n\r\nfunction TJclInt64Tree.Last: IJclInt64Iterator;\r\nvar\r\n Start: TJclInt64TreeNode;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Start := FRoot;\r\n case FTraverseOrder of\r\n toPreOrder:\r\n begin\r\n if Start <> nil then\r\n while Start.ChildrenCount > 0 do\r\n Start := TJclInt64TreeNode(Start.Children[Start.ChildrenCount - 1]);\r\n Result := TJclPreOrderInt64TreeIterator.Create(Self, Start, False, isLast);\r\n end;\r\n toPostOrder:\r\n Result := TJclPostOrderInt64TreeIterator.Create(Self, Start, False, isLast);\r\n else\r\n Result := nil;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclInt64Tree.NodeContains(ANode: TJclInt64TreeNode; const AValue: Int64): Boolean;\r\nvar\r\n Index: Integer;\r\nbegin\r\n Result := ItemsEqual(ANode.Value, AValue);\r\n if not Result then\r\n for Index := 0 to ANode.ChildrenCount - 1 do\r\n begin\r\n Result := NodeContains(TJclInt64TreeNode(ANode.Children[Index]), AValue);\r\n if Result then\r\n Break;\r\n end;\r\nend;\r\n\r\nprocedure TJclInt64Tree.Pack;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FRoot <> nil then\r\n PackNode(FRoot);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclInt64Tree.PackNode(ANode: TJclInt64TreeNode);\r\nvar\r\n Index: Integer;\r\nbegin\r\n SetLength(ANode.Children, ANode.ChildrenCount);\r\n for Index := 0 to ANode.ChildrenCount - 1 do\r\n PackNode(TJclInt64TreeNode(ANode.Children[Index]));\r\nend;\r\n\r\nfunction TJclInt64Tree.Remove(const AValue: Int64): Boolean;\r\nvar\r\n Extracted: Int64;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := Extract(AValue);\r\n if Result then\r\n begin\r\n Extracted := AValue;\r\n FreeInt64(Extracted);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclInt64Tree.RemoveAll(const ACollection: IJclInt64Collection): Boolean;\r\nvar\r\n It: IJclInt64Iterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n Result := Remove(It.Next) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclInt64Tree.RemoveNode(var ANode: TJclInt64TreeNode);\r\nvar\r\n Index, ChildIndex, NewCapacity: Integer;\r\n Parent: TJclInt64TreeNode;\r\nbegin\r\n for Index := ANode.ChildrenCount - 1 downto 0 do\r\n {$IFDEF BCB}\r\n RemoveNode(TJclInt64TreeNode(ANode.Children[Index]));\r\n {$ELSE ~BCB}\r\n RemoveNode(ANode.Children[Index]);\r\n {$ENDIF ~BCB}\r\n FreeInt64(ANode.Value);\r\n Parent := ANode.Parent;\r\n if Parent <> nil then\r\n begin\r\n ChildIndex := Parent.IndexOfChild(ANode);\r\n for Index := ChildIndex + 1 to Parent.ChildrenCount - 1 do\r\n Parent.Children[Index - 1] := Parent.Children[Index];\r\n Dec(Parent.ChildrenCount);\r\n NewCapacity := CalcPackCapacity(Length(Parent.Children), Parent.ChildrenCount);\r\n if NewCapacity < Length(Parent.Children) then\r\n SetLength(Parent.Children, NewCapacity);\r\n FreeAndNil(ANode);\r\n end\r\n else\r\n begin\r\n FreeAndNil(ANode);\r\n FRoot := nil;\r\n end;\r\n Dec(FSize);\r\nend;\r\n\r\nfunction TJclInt64Tree.RetainAll(const ACollection: IJclInt64Collection): Boolean;\r\nvar\r\n It: IJclInt64Iterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := First;\r\n while It.HasNext do\r\n if not ACollection.Contains(It.Next) then\r\n It.Remove;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclInt64Tree.SetCapacity(Value: Integer);\r\nbegin\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nprocedure TJclInt64Tree.SetTraverseOrder(Value: TJclTraverseOrder);\r\nbegin\r\n FTraverseOrder := Value;\r\nend;\r\n\r\nfunction TJclInt64Tree.Size: Integer;\r\nbegin\r\n Result := FSize;\r\nend;\r\n\r\nfunction TJclInt64Tree.CreateEmptyContainer: TJclAbstractContainerBase;\r\nbegin\r\n Result := TJclInt64Tree.Create;\r\n AssignPropertiesTo(Result);\r\nend;\r\n\r\n//=== { TJclInt64TreeIterator } ===========================================================\r\n\r\nconstructor TJclInt64TreeIterator.Create(OwnTree: TJclInt64Tree; ACursor: TJclInt64TreeNode; AValid: Boolean; AStart: TItrStart);\r\nbegin\r\n inherited Create(AValid);\r\n FCursor := ACursor;\r\n FOwnTree := OwnTree;\r\n FStart := AStart;\r\n FEqualityComparer := OwnTree as IJclInt64EqualityComparer;\r\nend;\r\n\r\nfunction TJclInt64TreeIterator.Add(const AValue: Int64): Boolean;\r\nvar\r\n ParentNode, NewNode: TJclInt64TreeNode;\r\nbegin\r\n if FOwnTree.ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n // add sibling or, if FCursor is root node, behave like TJclInt64Tree.Add\r\n Result := (FCursor <> nil) and (FOwnTree.AllowDefaultElements or not FEqualityComparer.ItemsEqual(AValue, 0))\r\n and ((not FOwnTree.Contains(AValue)) or FOwnTree.CheckDuplicate);\r\n\r\n if Result then\r\n begin\r\n ParentNode := FCursor.Parent;\r\n if ParentNode = nil then\r\n ParentNode := FCursor;\r\n\r\n if ParentNode.ChildrenCount = Length(ParentNode.Children) then\r\n SetLength(ParentNode.Children, FOwnTree.CalcGrowCapacity(Length(ParentNode.Children), ParentNode.ChildrenCount));\r\n if ParentNode.ChildrenCount < Length(ParentNode.Children) then\r\n begin\r\n NewNode := TJclInt64TreeNode.Create;\r\n NewNode.Value := AValue;\r\n NewNode.Parent := ParentNode;\r\n ParentNode.Children[ParentNode.ChildrenCount] := NewNode;\r\n Inc(ParentNode.ChildrenCount);\r\n Inc(FOwnTree.FSize);\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.WriteUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclInt64TreeIterator.AddChild(const AValue: Int64): Boolean;\r\nvar\r\n NewNode: TJclInt64TreeNode;\r\nbegin\r\n if FOwnTree.ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := (FCursor <> nil) and (FOwnTree.AllowDefaultElements or not FEqualityComparer.ItemsEqual(AValue, 0))\r\n and ((not FOwnTree.Contains(AValue)) or FOwnTree.CheckDuplicate);\r\n\r\n if Result then\r\n begin\r\n if FCursor.ChildrenCount = Length(FCursor.Children) then\r\n SetLength(FCursor.Children, FOwnTree.CalcGrowCapacity(Length(FCursor.Children), FCursor.ChildrenCount));\r\n if FCursor.ChildrenCount < Length(FCursor.Children) then\r\n begin\r\n NewNode := TJclInt64TreeNode.Create;\r\n NewNode.Value := AValue;\r\n NewNode.Parent := FCursor;\r\n FCursor.Children[FCursor.ChildrenCount] := NewNode;\r\n Inc(FCursor.ChildrenCount);\r\n Inc(FOwnTree.FSize);\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.WriteUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclInt64TreeIterator.AssignPropertiesTo(Dest: TJclAbstractIterator);\r\nvar\r\n ADest: TJclInt64TreeIterator;\r\nbegin\r\n inherited AssignPropertiesTo(Dest);\r\n if Dest is TJclInt64TreeIterator then\r\n begin\r\n ADest := TJclInt64TreeIterator(Dest);\r\n ADest.FCursor := FCursor;\r\n ADest.FOwnTree := FOwnTree;\r\n ADest.FEqualityComparer := FEqualityComparer;\r\n ADest.FStart := FStart;\r\n end;\r\nend;\r\n\r\nfunction TJclInt64TreeIterator.ChildrenCount: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FCursor <> nil then\r\n Result := FCursor.ChildrenCount\r\n else\r\n Result := 0;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclInt64TreeIterator.DeleteChild(Index: Integer);\r\nbegin\r\n if FOwnTree.ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if (FCursor <> nil) and (Index >= 0) and (Index < FCursor.ChildrenCount) then\r\n {$IFDEF BCB}\r\n FOwnTree.RemoveNode(TJclInt64TreeNode(FCursor.Children[Index]))\r\n {$ELSE ~BCB}\r\n FOwnTree.RemoveNode(FCursor.Children[Index])\r\n {$ENDIF ~BCB}\r\n else\r\n raise EJclOutOfBoundsError.Create;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.WriteUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclInt64TreeIterator.DeleteChildren;\r\nvar\r\n Index: Integer;\r\nbegin\r\n if FOwnTree.ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FCursor <> nil then\r\n begin\r\n for Index := FCursor.ChildrenCount - 1 downto 0 do\r\n {$IFDEF BCB}\r\n FOwnTree.RemoveNode(TJclInt64TreeNode(FCursor.Children[Index]));\r\n {$ELSE ~BCB}\r\n FOwnTree.RemoveNode(FCursor.Children[Index]);\r\n {$ENDIF ~BCB}\r\n SetLength(FCursor.Children, 0);\r\n FCursor.ChildrenCount := 0;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.WriteUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclInt64TreeIterator.Extract;\r\nvar\r\n OldCursor: TJclInt64TreeNode;\r\nbegin\r\n if FOwnTree.ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n CheckValid;\r\n Valid := False;\r\n OldCursor := FCursor;\r\n FCursor := GetNextSibling;\r\n if OldCursor <> nil then\r\n FOwnTree.ExtractNode(OldCursor);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.WriteUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclInt64TreeIterator.ExtractChild(Index: Integer);\r\nbegin\r\n if FOwnTree.ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if (FCursor <> nil) and (Index >= 0) and (Index < FCursor.ChildrenCount) then\r\n {$IFDEF BCB}\r\n FOwnTree.ExtractNode(TJclInt64TreeNode(FCursor.Children[Index]))\r\n {$ELSE ~BCB}\r\n FOwnTree.ExtractNode(FCursor.Children[Index])\r\n {$ENDIF ~BCB}\r\n else\r\n raise EJclOutOfBoundsError.Create;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.WriteUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclInt64TreeIterator.ExtractChildren;\r\nvar\r\n Index: Integer;\r\nbegin\r\n if FOwnTree.ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FCursor <> nil then\r\n begin\r\n for Index := FCursor.ChildrenCount - 1 downto 0 do\r\n {$IFDEF BCB}\r\n FOwnTree.ExtractNode(TJclInt64TreeNode(FCursor.Children[Index]));\r\n {$ELSE ~BCB}\r\n FOwnTree.ExtractNode(FCursor.Children[Index]);\r\n {$ENDIF ~BCB}\r\n SetLength(FCursor.Children, 0);\r\n FCursor.ChildrenCount := 0;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.WriteUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclInt64TreeIterator.GetChild(Index: Integer): Int64;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := 0;\r\n if (FCursor <> nil) and (Index >= 0) and (Index < FCursor.ChildrenCount) then\r\n FCursor := TJclInt64TreeNode(FCursor.Children[Index]);\r\n if FCursor <> nil then\r\n Result := FCursor.Value\r\n else\r\n if not FOwnTree.ReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclInt64TreeIterator.GetValue: Int64;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n CheckValid;\r\n Result := 0;\r\n if FCursor <> nil then\r\n Result := FCursor.Value\r\n else\r\n if not FOwnTree.ReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclInt64TreeIterator.HasChild(Index: Integer): Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := (FCursor <> nil) and (Index >= 0) and (Index < FCursor.ChildrenCount);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclInt64TreeIterator.HasNext: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Valid then\r\n Result := GetNextCursor <> nil\r\n else\r\n Result := FCursor <> nil;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclInt64TreeIterator.HasParent: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := (FCursor <> nil) and (FCursor.Parent <> nil);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclInt64TreeIterator.HasPrevious: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Valid then\r\n Result := GetPreviousCursor <> nil\r\n else\r\n Result := FCursor <> nil;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclInt64TreeIterator.IndexOfChild(const AValue: Int64): Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FCursor <> nil then\r\n Result := FCursor.IndexOfValue(AValue, FEqualityComparer)\r\n else\r\n Result := -1;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclInt64TreeIterator.Insert(const AValue: Int64): Boolean;\r\nvar\r\n ParentNode, NewNode: TJclInt64TreeNode;\r\n Index, I: Integer;\r\nbegin\r\n if FOwnTree.ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n // insert sibling or, if FCursor is root node, behave like TJclInt64Tree.Insert\r\n Result := (FCursor <> nil) and (FOwnTree.AllowDefaultElements or not FEqualityComparer.ItemsEqual(AValue, 0))\r\n and ((not FOwnTree.Contains(AValue)) or FOwnTree.CheckDuplicate);\r\n\r\n if Result then\r\n begin\r\n if FCursor.Parent <> nil then\r\n begin\r\n ParentNode := FCursor.Parent;\r\n Index := 0;\r\n while (Index < ParentNode.ChildrenCount) and (ParentNode.Children[Index] <> FCursor) do\r\n Inc(Index);\r\n end\r\n else\r\n begin\r\n ParentNode := FCursor;\r\n Index := 0;\r\n end;\r\n\r\n if ParentNode.ChildrenCount = Length(ParentNode.Children) then\r\n SetLength(ParentNode.Children, FOwnTree.CalcGrowCapacity(Length(ParentNode.Children), ParentNode.ChildrenCount));\r\n if ParentNode.ChildrenCount < Length(ParentNode.Children) then\r\n begin\r\n NewNode := TJclInt64TreeNode.Create;\r\n NewNode.Value := AValue;\r\n NewNode.Parent := ParentNode;\r\n for I := ParentNode.ChildrenCount - 1 downto Index do\r\n ParentNode.Children[I + 1] := ParentNode.Children[I];\r\n ParentNode.Children[Index] := NewNode;\r\n Inc(ParentNode.ChildrenCount);\r\n Inc(FOwnTree.FSize);\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.WriteUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclInt64TreeIterator.InsertChild(Index: Integer; const AValue: Int64): Boolean;\r\nvar\r\n NewNode: TJclInt64TreeNode;\r\n I: Integer;\r\nbegin\r\n if FOwnTree.ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n // insert sibling or, if FCursor is root node, behave like TJclInt64Tree.Insert\r\n Result := (FCursor <> nil) and (FOwnTree.AllowDefaultElements or not FEqualityComparer.ItemsEqual(AValue, 0))\r\n and ((not FOwnTree.Contains(AValue)) or FOwnTree.CheckDuplicate);\r\n\r\n if Result then\r\n begin\r\n if FCursor.ChildrenCount = Length(FCursor.Children) then\r\n SetLength(FCursor.Children, FOwnTree.CalcGrowCapacity(Length(FCursor.Children), FCursor.ChildrenCount));\r\n if FCursor.ChildrenCount < Length(FCursor.Children) then\r\n begin\r\n NewNode := TJclInt64TreeNode.Create;\r\n NewNode.Value := AValue;\r\n NewNode.Parent := FCursor;\r\n for I := FCursor.ChildrenCount - 1 downto Index do\r\n FCursor.Children[I + 1] := FCursor.Children[I];\r\n FCursor.Children[Index] := NewNode;\r\n Inc(FCursor.ChildrenCount);\r\n Inc(FOwnTree.FSize);\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.WriteUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclInt64TreeIterator.IteratorEquals(const AIterator: IJclInt64Iterator): Boolean;\r\nvar\r\n Obj: TObject;\r\n ItrObj: TJclInt64TreeIterator;\r\nbegin\r\n Result := False;\r\n if AIterator = nil then\r\n Exit;\r\n Obj := AIterator.GetIteratorReference;\r\n if Obj is TJclInt64TreeIterator then\r\n begin\r\n ItrObj := TJclInt64TreeIterator(Obj);\r\n Result := (FOwnTree = ItrObj.FOwnTree) and (FCursor = ItrObj.FCursor) and (Valid = ItrObj.Valid);\r\n end;\r\nend;\r\n\r\n{$IFDEF SUPPORTS_FOR_IN}\r\nfunction TJclInt64TreeIterator.MoveNext: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Valid then\r\n FCursor := GetNextCursor\r\n else\r\n Valid := True;\r\n Result := FCursor <> nil;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n{$ENDIF SUPPORTS_FOR_IN}\r\n\r\nfunction TJclInt64TreeIterator.Next: Int64;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Valid then\r\n FCursor := GetNextCursor\r\n else\r\n Valid := True;\r\n Result := 0;\r\n if FCursor <> nil then\r\n Result := FCursor.Value\r\n else\r\n if not FOwnTree.ReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclInt64TreeIterator.NextIndex: Integer;\r\nbegin\r\n // No index\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nfunction TJclInt64TreeIterator.Parent: Int64;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := 0;\r\n if FCursor <> nil then\r\n FCursor := FCursor.Parent;\r\n if FCursor <> nil then\r\n Result := FCursor.Value\r\n else\r\n if not FOwnTree.ReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclInt64TreeIterator.Previous: Int64;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Valid then\r\n FCursor := GetPreviousCursor\r\n else\r\n Valid := True;\r\n Result := 0;\r\n if FCursor <> nil then\r\n Result := FCursor.Value\r\n else\r\n if not FOwnTree.ReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclInt64TreeIterator.PreviousIndex: Integer;\r\nbegin\r\n // No index\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nprocedure TJclInt64TreeIterator.Remove;\r\nvar\r\n OldCursor: TJclInt64TreeNode;\r\nbegin\r\n if FOwnTree.ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n CheckValid;\r\n Valid := False;\r\n OldCursor := FCursor;\r\n FCursor := GetNextSibling;\r\n if OldCursor <> nil then\r\n FOwnTree.RemoveNode(OldCursor);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.WriteUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclInt64TreeIterator.Reset;\r\nvar\r\n NewCursor: TJclInt64TreeNode;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Valid := False;\r\n case FStart of\r\n isFirst:\r\n begin\r\n NewCursor := FCursor;\r\n while NewCursor <> nil do\r\n begin\r\n NewCursor := GetPreviousCursor;\r\n if NewCursor <> nil then\r\n FCursor := NewCursor;\r\n end;\r\n end;\r\n isLast:\r\n begin\r\n NewCursor := FCursor;\r\n while NewCursor <> nil do\r\n begin\r\n NewCursor := GetNextCursor;\r\n if NewCursor <> nil then\r\n FCursor := NewCursor;\r\n end;\r\n end;\r\n isRoot:\r\n begin\r\n while (FCursor <> nil) and (FCursor.Parent <> nil) do\r\n FCursor := FCursor.Parent;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclInt64TreeIterator.SetChild(Index: Integer; const AValue: Int64);\r\nbegin\r\n if FOwnTree.ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if (FCursor <> nil) and (Index >= 0) and (Index < FCursor.ChildrenCount) then\r\n TJclInt64TreeNode(FCursor.Children[Index]).Value := AValue\r\n else\r\n raise EJclOutOfBoundsError.Create;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.WriteUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclInt64TreeIterator.SetValue(const AValue: Int64);\r\nbegin\r\n if FOwnTree.ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n CheckValid;\r\n if FCursor <> nil then\r\n begin\r\n FOwnTree.FreeInt64(FCursor.Value);\r\n FCursor.Value := AValue;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.WriteUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\n//=== { TJclPreOrderInt64TreeIterator } ===================================================\r\n\r\nfunction TJclPreOrderInt64TreeIterator.CreateEmptyIterator: TJclAbstractIterator;\r\nbegin\r\n Result := TJclPreOrderInt64TreeIterator.Create(FOwnTree, FCursor, Valid, FStart);\r\nend;\r\n\r\nfunction TJclPreOrderInt64TreeIterator.GetNextCursor: TJclInt64TreeNode;\r\nvar\r\n LastRet: TJclInt64TreeNode;\r\nbegin\r\n Result := FCursor;\r\n if Result = nil then\r\n Exit;\r\n LastRet := Result;\r\n if Result.ChildrenCount > 0 then\r\n Result := TJclInt64TreeNode(Result.Children[0])\r\n else\r\n begin\r\n Result := Result.Parent;\r\n while (Result <> nil) and (Result.IndexOfChild(LastRet) = (Result.ChildrenCount - 1)) do\r\n begin\r\n LastRet := Result;\r\n Result := Result.Parent;\r\n end;\r\n if Result <> nil then // not root = return successor\r\n Result := TJclInt64TreeNode(Result.Children[Result.IndexOfChild(LastRet) + 1]);\r\n end;\r\nend;\r\n\r\nfunction TJclPreOrderInt64TreeIterator.GetNextSibling: TJclInt64TreeNode;\r\nvar\r\n LastRet: TJclInt64TreeNode;\r\nbegin\r\n Result := FCursor;\r\n if Result = nil then\r\n Exit;\r\n LastRet := Result;\r\n\r\n Result := Result.Parent;\r\n while (Result <> nil) and (Result.IndexOfChild(LastRet) = (Result.ChildrenCount - 1)) do\r\n begin\r\n LastRet := Result;\r\n Result := Result.Parent;\r\n end;\r\n if Result <> nil then // not root = return successor\r\n Result := TJclInt64TreeNode(Result.Children[Result.IndexOfChild(LastRet) + 1]);\r\nend;\r\n\r\nfunction TJclPreOrderInt64TreeIterator.GetPreviousCursor: TJclInt64TreeNode;\r\nvar\r\n LastRet: TJclInt64TreeNode;\r\nbegin\r\n Result := FCursor;\r\n if Result = nil then\r\n Exit;\r\n LastRet := Result;\r\n Result := Result.Parent;\r\n if (Result <> nil) and (Result.IndexOfChild(LastRet) > 0) then\r\n // come from Right\r\n begin\r\n Result := TJclInt64TreeNode(Result.Children[Result.IndexOfChild(LastRet) - 1]);\r\n while (Result.ChildrenCount > 0) do // descend down the tree\r\n Result := TJclInt64TreeNode(Result.Children[Result.ChildrenCount - 1]);\r\n end;\r\nend;\r\n\r\n//=== { TJclPostOrderInt64TreeIterator } ==================================================\r\n\r\nfunction TJclPostOrderInt64TreeIterator.CreateEmptyIterator: TJclAbstractIterator;\r\nbegin\r\n Result := TJclPostOrderInt64TreeIterator.Create(FOwnTree, FCursor, Valid, FStart);\r\nend;\r\n\r\nfunction TJclPostOrderInt64TreeIterator.GetNextCursor: TJclInt64TreeNode;\r\nvar\r\n LastRet: TJclInt64TreeNode;\r\nbegin\r\n Result := FCursor;\r\n if Result = nil then\r\n Exit;\r\n LastRet := Result;\r\n Result := Result.Parent;\r\n if (Result <> nil) and (Result.IndexOfChild(LastRet) <> (Result.ChildrenCount - 1)) then\r\n begin\r\n Result := TJclInt64TreeNode(Result.Children[Result.IndexOfChild(LastRet) + 1]);\r\n while Result.ChildrenCount > 0 do\r\n Result := TJclInt64TreeNode(Result.Children[0]);\r\n end;\r\nend;\r\n\r\nfunction TJclPostOrderInt64TreeIterator.GetNextSibling: TJclInt64TreeNode;\r\nvar\r\n LastRet: TJclInt64TreeNode;\r\nbegin\r\n Result := FCursor;\r\n if Result = nil then\r\n Exit;\r\n LastRet := Result;\r\n Result := Result.Parent;\r\n\r\n if (Result <> nil) and (Result.IndexOfChild(LastRet) <> (Result.ChildrenCount - 1)) then\r\n begin\r\n Result := TJclInt64TreeNode(Result.Children[Result.IndexOfChild(LastRet) + 1]);\r\n while Result.ChildrenCount > 0 do\r\n Result := TJclInt64TreeNode(Result.Children[0]);\r\n end;\r\nend;\r\n\r\nfunction TJclPostOrderInt64TreeIterator.GetPreviousCursor: TJclInt64TreeNode;\r\nvar\r\n LastRet: TJclInt64TreeNode;\r\nbegin\r\n Result := FCursor;\r\n if Result = nil then\r\n Exit;\r\n if Result.ChildrenCount > 0 then\r\n Result := TJclInt64TreeNode(Result.Children[Result.ChildrenCount - 1])\r\n else\r\n begin\r\n LastRet := Result;\r\n Result := Result.Parent;\r\n while (Result <> nil) and (Result.IndexOfChild(LastRet) = 0) do\r\n begin\r\n LastRet := Result;\r\n Result := Result.Parent;\r\n end;\r\n if Result <> nil then // not root\r\n Result := TJclInt64TreeNode(Result.Children[Result.IndexOfChild(LastRet) - 1]);\r\n end;\r\nend;\r\n\r\n//=== { TJclPtrTreeNode } =======================================================\r\n\r\nfunction TJclPtrTreeNode.IndexOfChild(AChild: TJclPtrTreeNode): Integer;\r\nbegin\r\n for Result := 0 to ChildrenCount - 1 do\r\n if Children[Result] = AChild then\r\n Exit;\r\n Result := -1;\r\nend;\r\n\r\nfunction TJclPtrTreeNode.IndexOfValue(APtr: Pointer;\r\n const AEqualityComparer: IJclPtrEqualityComparer): Integer;\r\nbegin\r\n for Result := 0 to ChildrenCount - 1 do\r\n if AEqualityComparer.ItemsEqual(TJclPtrTreeNode(Children[Result]).Value, APtr) then\r\n Exit;\r\n Result := -1;\r\nend;\r\n\r\n//=== { TJclPtrTree } =======================================================\r\n\r\nconstructor TJclPtrTree.Create();\r\nbegin\r\n inherited Create();\r\n FTraverseOrder := toPreOrder;\r\nend;\r\n\r\ndestructor TJclPtrTree.Destroy;\r\nbegin\r\n FReadOnly := False;\r\n Clear;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJclPtrTree.Add(APtr: Pointer): Boolean;\r\nvar\r\n NewNode: TJclPtrTreeNode;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := AllowDefaultElements or not ItemsEqual(APtr, nil);\r\n\r\n if Result then\r\n begin\r\n if FRoot <> nil then\r\n begin\r\n Result := (not Contains(APtr)) or CheckDuplicate;\r\n if Result then\r\n begin\r\n if FRoot.ChildrenCount = Length(FRoot.Children) then\r\n SetLength(FRoot.Children, CalcGrowCapacity(Length(FRoot.Children), FRoot.ChildrenCount));\r\n if FRoot.ChildrenCount < Length(FRoot.Children) then\r\n begin\r\n NewNode := TJclPtrTreeNode.Create;\r\n NewNode.Value := APtr;\r\n NewNode.Parent := FRoot;\r\n FRoot.Children[FRoot.ChildrenCount] := NewNode;\r\n Inc(FRoot.ChildrenCount);\r\n Inc(FSize);\r\n end\r\n else\r\n Result := False;\r\n end;\r\n end\r\n else\r\n begin\r\n FRoot := TJclPtrTreeNode.Create;\r\n FRoot.Value := APtr;\r\n Inc(FSize);\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclPtrTree.AddAll(const ACollection: IJclPtrCollection): Boolean;\r\nvar\r\n It: IJclPtrIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n Result := Add(It.Next) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclPtrTree.AssignDataTo(Dest: TJclAbstractContainerBase);\r\nvar\r\n ADest: TJclPtrTree;\r\n ACollection: IJclPtrCollection;\r\nbegin\r\n inherited AssignDataTo(Dest);\r\n if Dest is TJclPtrTree then\r\n begin\r\n ADest := TJclPtrTree(Dest);\r\n ADest.Clear;\r\n ADest.FSize := FSize;\r\n if FRoot <> nil then\r\n ADest.FRoot := CloneNode(FRoot, nil);\r\n end\r\n else\r\n if Supports(IInterface(Dest), IJclPtrCollection, ACollection) then\r\n begin\r\n ACollection.Clear;\r\n ACollection.AddAll(Self);\r\n end;\r\nend;\r\n\r\nprocedure TJclPtrTree.AssignPropertiesTo(Dest: TJclAbstractContainerBase);\r\nbegin\r\n inherited AssignPropertiesto(Dest);\r\n if Dest is TJclPtrTree then\r\n TJclPtrTree(Dest).FTraverseOrder := FTraverseOrder;\r\nend;\r\n\r\nprocedure TJclPtrTree.Clear;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FRoot <> nil then\r\n RemoveNode(FRoot);\r\n FSize := 0;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclPtrTree.CloneNode(Node, Parent: TJclPtrTreeNode): TJclPtrTreeNode;\r\nvar\r\n Index: Integer;\r\nbegin\r\n Result := TJclPtrTreeNode.Create;\r\n Result.Value := Node.Value;\r\n Result.Parent := Parent;\r\n SetLength(Result.Children, Node.ChildrenCount);\r\n Result.ChildrenCount := Node.ChildrenCount;\r\n for Index := 0 to Node.ChildrenCount - 1 do\r\n Result.Children[Index] := CloneNode(TJclPtrTreeNode(Node.Children[Index]), Result); // recursive call\r\nend;\r\n\r\nfunction TJclPtrTree.CollectionEquals(const ACollection: IJclPtrCollection): Boolean;\r\nvar\r\n It, ItSelf: IJclPtrIterator;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n if FSize <> ACollection.Size then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n ItSelf := First;\r\n while ItSelf.HasNext do\r\n if not ItemsEqual(ItSelf.Next, It.Next) then\r\n begin\r\n Result := False;\r\n Break;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclPtrTree.Contains(APtr: Pointer): Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FRoot <> nil then\r\n Result := NodeContains(FRoot, APtr)\r\n else\r\n Result := False;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclPtrTree.ContainsAll(const ACollection: IJclPtrCollection): Boolean;\r\nvar\r\n It: IJclPtrIterator;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := True;\r\n if ACollection = nil then\r\n Exit;\r\n It := ACollection.First;\r\n while Result and It.HasNext do\r\n Result := Contains(It.Next);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclPtrTree.Extract(APtr: Pointer): Boolean;\r\nvar\r\n It: IJclPtrIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := FRoot <> nil;\r\n if Result then\r\n begin\r\n It := First;\r\n while It.HasNext do\r\n if ItemsEqual(It.Next, APtr) then\r\n begin\r\n It.Extract;\r\n if RemoveSingleElement then\r\n Break;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclPtrTree.ExtractAll(const ACollection: IJclPtrCollection): Boolean;\r\nvar\r\n It: IJclPtrIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n Result := Extract(It.Next) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclPtrTree.ExtractNode(var ANode: TJclPtrTreeNode);\r\nvar\r\n Index, ChildIndex, NewCapacity: Integer;\r\n Parent: TJclPtrTreeNode;\r\nbegin\r\n for Index := ANode.ChildrenCount - 1 downto 0 do\r\n {$IFDEF BCB}\r\n ExtractNode(TJclPtrTreeNode(ANode.Children[Index]));\r\n {$ELSE ~BCB}\r\n ExtractNode(ANode.Children[Index]);\r\n {$ENDIF ~BCB}\r\n Parent := ANode.Parent;\r\n if Parent <> nil then\r\n begin\r\n ChildIndex := Parent.IndexOfChild(ANode);\r\n for Index := ChildIndex + 1 to Parent.ChildrenCount - 1 do\r\n Parent.Children[Index - 1] := Parent.Children[Index];\r\n Dec(Parent.ChildrenCount);\r\n NewCapacity := CalcPackCapacity(Length(Parent.Children), Parent.ChildrenCount);\r\n if NewCapacity < Length(Parent.Children) then\r\n SetLength(Parent.Children, NewCapacity);\r\n FreeAndNil(ANode);\r\n end\r\n else\r\n begin\r\n FreeAndNil(ANode);\r\n FRoot := nil;\r\n end;\r\n Dec(FSize);\r\nend;\r\n\r\nfunction TJclPtrTree.First: IJclPtrIterator;\r\nvar\r\n Start: TJclPtrTreeNode;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Start := FRoot;\r\n case GetTraverseOrder of\r\n toPreOrder:\r\n Result := TJclPreOrderPtrTreeIterator.Create(Self, Start, False, isFirst);\r\n toPostOrder:\r\n begin\r\n if Start <> nil then\r\n while (Start.ChildrenCount > 0) do\r\n Start := TJclPtrTreeNode(Start.Children[0]);\r\n Result := TJclPostOrderPtrTreeIterator.Create(Self, Start, False, isFirst);\r\n end;\r\n else\r\n Result := nil;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\n{$IFDEF SUPPORTS_FOR_IN}\r\nfunction TJclPtrTree.GetEnumerator: IJclPtrIterator;\r\nbegin\r\n Result := First;\r\nend;\r\n{$ENDIF SUPPORTS_FOR_IN}\r\n\r\nfunction TJclPtrTree.GetRoot: IJclPtrTreeIterator;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n case GetTraverseOrder of\r\n toPreOrder:\r\n Result := TJclPreOrderPtrTreeIterator.Create(Self, FRoot, False, isRoot);\r\n toPostOrder:\r\n Result := TJclPostOrderPtrTreeIterator.Create(Self, FRoot, False, isRoot);\r\n else\r\n Result := nil;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclPtrTree.GetTraverseOrder: TJclTraverseOrder;\r\nbegin\r\n Result := FTraverseOrder;\r\nend;\r\n\r\nfunction TJclPtrTree.IsEmpty: Boolean;\r\nbegin\r\n Result := FSize = 0;\r\nend;\r\n\r\nfunction TJclPtrTree.Last: IJclPtrIterator;\r\nvar\r\n Start: TJclPtrTreeNode;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Start := FRoot;\r\n case FTraverseOrder of\r\n toPreOrder:\r\n begin\r\n if Start <> nil then\r\n while Start.ChildrenCount > 0 do\r\n Start := TJclPtrTreeNode(Start.Children[Start.ChildrenCount - 1]);\r\n Result := TJclPreOrderPtrTreeIterator.Create(Self, Start, False, isLast);\r\n end;\r\n toPostOrder:\r\n Result := TJclPostOrderPtrTreeIterator.Create(Self, Start, False, isLast);\r\n else\r\n Result := nil;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclPtrTree.NodeContains(ANode: TJclPtrTreeNode; APtr: Pointer): Boolean;\r\nvar\r\n Index: Integer;\r\nbegin\r\n Result := ItemsEqual(ANode.Value, APtr);\r\n if not Result then\r\n for Index := 0 to ANode.ChildrenCount - 1 do\r\n begin\r\n Result := NodeContains(TJclPtrTreeNode(ANode.Children[Index]), APtr);\r\n if Result then\r\n Break;\r\n end;\r\nend;\r\n\r\nprocedure TJclPtrTree.Pack;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FRoot <> nil then\r\n PackNode(FRoot);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclPtrTree.PackNode(ANode: TJclPtrTreeNode);\r\nvar\r\n Index: Integer;\r\nbegin\r\n SetLength(ANode.Children, ANode.ChildrenCount);\r\n for Index := 0 to ANode.ChildrenCount - 1 do\r\n PackNode(TJclPtrTreeNode(ANode.Children[Index]));\r\nend;\r\n\r\nfunction TJclPtrTree.Remove(APtr: Pointer): Boolean;\r\nvar\r\n Extracted: Pointer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := Extract(APtr);\r\n if Result then\r\n begin\r\n Extracted := APtr;\r\n FreePointer(Extracted);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclPtrTree.RemoveAll(const ACollection: IJclPtrCollection): Boolean;\r\nvar\r\n It: IJclPtrIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n Result := Remove(It.Next) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclPtrTree.RemoveNode(var ANode: TJclPtrTreeNode);\r\nvar\r\n Index, ChildIndex, NewCapacity: Integer;\r\n Parent: TJclPtrTreeNode;\r\nbegin\r\n for Index := ANode.ChildrenCount - 1 downto 0 do\r\n {$IFDEF BCB}\r\n RemoveNode(TJclPtrTreeNode(ANode.Children[Index]));\r\n {$ELSE ~BCB}\r\n RemoveNode(ANode.Children[Index]);\r\n {$ENDIF ~BCB}\r\n FreePointer(ANode.Value);\r\n Parent := ANode.Parent;\r\n if Parent <> nil then\r\n begin\r\n ChildIndex := Parent.IndexOfChild(ANode);\r\n for Index := ChildIndex + 1 to Parent.ChildrenCount - 1 do\r\n Parent.Children[Index - 1] := Parent.Children[Index];\r\n Dec(Parent.ChildrenCount);\r\n NewCapacity := CalcPackCapacity(Length(Parent.Children), Parent.ChildrenCount);\r\n if NewCapacity < Length(Parent.Children) then\r\n SetLength(Parent.Children, NewCapacity);\r\n FreeAndNil(ANode);\r\n end\r\n else\r\n begin\r\n FreeAndNil(ANode);\r\n FRoot := nil;\r\n end;\r\n Dec(FSize);\r\nend;\r\n\r\nfunction TJclPtrTree.RetainAll(const ACollection: IJclPtrCollection): Boolean;\r\nvar\r\n It: IJclPtrIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := First;\r\n while It.HasNext do\r\n if not ACollection.Contains(It.Next) then\r\n It.Remove;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclPtrTree.SetCapacity(Value: Integer);\r\nbegin\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nprocedure TJclPtrTree.SetTraverseOrder(Value: TJclTraverseOrder);\r\nbegin\r\n FTraverseOrder := Value;\r\nend;\r\n\r\nfunction TJclPtrTree.Size: Integer;\r\nbegin\r\n Result := FSize;\r\nend;\r\n\r\nfunction TJclPtrTree.CreateEmptyContainer: TJclAbstractContainerBase;\r\nbegin\r\n Result := TJclPtrTree.Create;\r\n AssignPropertiesTo(Result);\r\nend;\r\n\r\n//=== { TJclPtrTreeIterator } ===========================================================\r\n\r\nconstructor TJclPtrTreeIterator.Create(OwnTree: TJclPtrTree; ACursor: TJclPtrTreeNode; AValid: Boolean; AStart: TItrStart);\r\nbegin\r\n inherited Create(AValid);\r\n FCursor := ACursor;\r\n FOwnTree := OwnTree;\r\n FStart := AStart;\r\n FEqualityComparer := OwnTree as IJclPtrEqualityComparer;\r\nend;\r\n\r\nfunction TJclPtrTreeIterator.Add(APtr: Pointer): Boolean;\r\nvar\r\n ParentNode, NewNode: TJclPtrTreeNode;\r\nbegin\r\n if FOwnTree.ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n // add sibling or, if FCursor is root node, behave like TJclPtrTree.Add\r\n Result := (FCursor <> nil) and (FOwnTree.AllowDefaultElements or not FEqualityComparer.ItemsEqual(APtr, nil))\r\n and ((not FOwnTree.Contains(APtr)) or FOwnTree.CheckDuplicate);\r\n\r\n if Result then\r\n begin\r\n ParentNode := FCursor.Parent;\r\n if ParentNode = nil then\r\n ParentNode := FCursor;\r\n\r\n if ParentNode.ChildrenCount = Length(ParentNode.Children) then\r\n SetLength(ParentNode.Children, FOwnTree.CalcGrowCapacity(Length(ParentNode.Children), ParentNode.ChildrenCount));\r\n if ParentNode.ChildrenCount < Length(ParentNode.Children) then\r\n begin\r\n NewNode := TJclPtrTreeNode.Create;\r\n NewNode.Value := APtr;\r\n NewNode.Parent := ParentNode;\r\n ParentNode.Children[ParentNode.ChildrenCount] := NewNode;\r\n Inc(ParentNode.ChildrenCount);\r\n Inc(FOwnTree.FSize);\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.WriteUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclPtrTreeIterator.AddChild(APtr: Pointer): Boolean;\r\nvar\r\n NewNode: TJclPtrTreeNode;\r\nbegin\r\n if FOwnTree.ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := (FCursor <> nil) and (FOwnTree.AllowDefaultElements or not FEqualityComparer.ItemsEqual(APtr, nil))\r\n and ((not FOwnTree.Contains(APtr)) or FOwnTree.CheckDuplicate);\r\n\r\n if Result then\r\n begin\r\n if FCursor.ChildrenCount = Length(FCursor.Children) then\r\n SetLength(FCursor.Children, FOwnTree.CalcGrowCapacity(Length(FCursor.Children), FCursor.ChildrenCount));\r\n if FCursor.ChildrenCount < Length(FCursor.Children) then\r\n begin\r\n NewNode := TJclPtrTreeNode.Create;\r\n NewNode.Value := APtr;\r\n NewNode.Parent := FCursor;\r\n FCursor.Children[FCursor.ChildrenCount] := NewNode;\r\n Inc(FCursor.ChildrenCount);\r\n Inc(FOwnTree.FSize);\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.WriteUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclPtrTreeIterator.AssignPropertiesTo(Dest: TJclAbstractIterator);\r\nvar\r\n ADest: TJclPtrTreeIterator;\r\nbegin\r\n inherited AssignPropertiesTo(Dest);\r\n if Dest is TJclPtrTreeIterator then\r\n begin\r\n ADest := TJclPtrTreeIterator(Dest);\r\n ADest.FCursor := FCursor;\r\n ADest.FOwnTree := FOwnTree;\r\n ADest.FEqualityComparer := FEqualityComparer;\r\n ADest.FStart := FStart;\r\n end;\r\nend;\r\n\r\nfunction TJclPtrTreeIterator.ChildrenCount: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FCursor <> nil then\r\n Result := FCursor.ChildrenCount\r\n else\r\n Result := 0;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclPtrTreeIterator.DeleteChild(Index: Integer);\r\nbegin\r\n if FOwnTree.ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if (FCursor <> nil) and (Index >= 0) and (Index < FCursor.ChildrenCount) then\r\n {$IFDEF BCB}\r\n FOwnTree.RemoveNode(TJclPtrTreeNode(FCursor.Children[Index]))\r\n {$ELSE ~BCB}\r\n FOwnTree.RemoveNode(FCursor.Children[Index])\r\n {$ENDIF ~BCB}\r\n else\r\n raise EJclOutOfBoundsError.Create;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.WriteUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclPtrTreeIterator.DeleteChildren;\r\nvar\r\n Index: Integer;\r\nbegin\r\n if FOwnTree.ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FCursor <> nil then\r\n begin\r\n for Index := FCursor.ChildrenCount - 1 downto 0 do\r\n {$IFDEF BCB}\r\n FOwnTree.RemoveNode(TJclPtrTreeNode(FCursor.Children[Index]));\r\n {$ELSE ~BCB}\r\n FOwnTree.RemoveNode(FCursor.Children[Index]);\r\n {$ENDIF ~BCB}\r\n SetLength(FCursor.Children, 0);\r\n FCursor.ChildrenCount := 0;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.WriteUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclPtrTreeIterator.Extract;\r\nvar\r\n OldCursor: TJclPtrTreeNode;\r\nbegin\r\n if FOwnTree.ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n CheckValid;\r\n Valid := False;\r\n OldCursor := FCursor;\r\n FCursor := GetNextSibling;\r\n if OldCursor <> nil then\r\n FOwnTree.ExtractNode(OldCursor);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.WriteUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclPtrTreeIterator.ExtractChild(Index: Integer);\r\nbegin\r\n if FOwnTree.ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if (FCursor <> nil) and (Index >= 0) and (Index < FCursor.ChildrenCount) then\r\n {$IFDEF BCB}\r\n FOwnTree.ExtractNode(TJclPtrTreeNode(FCursor.Children[Index]))\r\n {$ELSE ~BCB}\r\n FOwnTree.ExtractNode(FCursor.Children[Index])\r\n {$ENDIF ~BCB}\r\n else\r\n raise EJclOutOfBoundsError.Create;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.WriteUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclPtrTreeIterator.ExtractChildren;\r\nvar\r\n Index: Integer;\r\nbegin\r\n if FOwnTree.ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FCursor <> nil then\r\n begin\r\n for Index := FCursor.ChildrenCount - 1 downto 0 do\r\n {$IFDEF BCB}\r\n FOwnTree.ExtractNode(TJclPtrTreeNode(FCursor.Children[Index]));\r\n {$ELSE ~BCB}\r\n FOwnTree.ExtractNode(FCursor.Children[Index]);\r\n {$ENDIF ~BCB}\r\n SetLength(FCursor.Children, 0);\r\n FCursor.ChildrenCount := 0;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.WriteUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclPtrTreeIterator.GetChild(Index: Integer): Pointer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := nil;\r\n if (FCursor <> nil) and (Index >= 0) and (Index < FCursor.ChildrenCount) then\r\n FCursor := TJclPtrTreeNode(FCursor.Children[Index]);\r\n if FCursor <> nil then\r\n Result := FCursor.Value\r\n else\r\n if not FOwnTree.ReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclPtrTreeIterator.GetPointer: Pointer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n CheckValid;\r\n Result := nil;\r\n if FCursor <> nil then\r\n Result := FCursor.Value\r\n else\r\n if not FOwnTree.ReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclPtrTreeIterator.HasChild(Index: Integer): Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := (FCursor <> nil) and (Index >= 0) and (Index < FCursor.ChildrenCount);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclPtrTreeIterator.HasNext: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Valid then\r\n Result := GetNextCursor <> nil\r\n else\r\n Result := FCursor <> nil;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclPtrTreeIterator.HasParent: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := (FCursor <> nil) and (FCursor.Parent <> nil);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclPtrTreeIterator.HasPrevious: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Valid then\r\n Result := GetPreviousCursor <> nil\r\n else\r\n Result := FCursor <> nil;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclPtrTreeIterator.IndexOfChild(APtr: Pointer): Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FCursor <> nil then\r\n Result := FCursor.IndexOfValue(APtr, FEqualityComparer)\r\n else\r\n Result := -1;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclPtrTreeIterator.Insert(APtr: Pointer): Boolean;\r\nvar\r\n ParentNode, NewNode: TJclPtrTreeNode;\r\n Index, I: Integer;\r\nbegin\r\n if FOwnTree.ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n // insert sibling or, if FCursor is root node, behave like TJclPtrTree.Insert\r\n Result := (FCursor <> nil) and (FOwnTree.AllowDefaultElements or not FEqualityComparer.ItemsEqual(APtr, nil))\r\n and ((not FOwnTree.Contains(APtr)) or FOwnTree.CheckDuplicate);\r\n\r\n if Result then\r\n begin\r\n if FCursor.Parent <> nil then\r\n begin\r\n ParentNode := FCursor.Parent;\r\n Index := 0;\r\n while (Index < ParentNode.ChildrenCount) and (ParentNode.Children[Index] <> FCursor) do\r\n Inc(Index);\r\n end\r\n else\r\n begin\r\n ParentNode := FCursor;\r\n Index := 0;\r\n end;\r\n\r\n if ParentNode.ChildrenCount = Length(ParentNode.Children) then\r\n SetLength(ParentNode.Children, FOwnTree.CalcGrowCapacity(Length(ParentNode.Children), ParentNode.ChildrenCount));\r\n if ParentNode.ChildrenCount < Length(ParentNode.Children) then\r\n begin\r\n NewNode := TJclPtrTreeNode.Create;\r\n NewNode.Value := APtr;\r\n NewNode.Parent := ParentNode;\r\n for I := ParentNode.ChildrenCount - 1 downto Index do\r\n ParentNode.Children[I + 1] := ParentNode.Children[I];\r\n ParentNode.Children[Index] := NewNode;\r\n Inc(ParentNode.ChildrenCount);\r\n Inc(FOwnTree.FSize);\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.WriteUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclPtrTreeIterator.InsertChild(Index: Integer; APtr: Pointer): Boolean;\r\nvar\r\n NewNode: TJclPtrTreeNode;\r\n I: Integer;\r\nbegin\r\n if FOwnTree.ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n // insert sibling or, if FCursor is root node, behave like TJclPtrTree.Insert\r\n Result := (FCursor <> nil) and (FOwnTree.AllowDefaultElements or not FEqualityComparer.ItemsEqual(APtr, nil))\r\n and ((not FOwnTree.Contains(APtr)) or FOwnTree.CheckDuplicate);\r\n\r\n if Result then\r\n begin\r\n if FCursor.ChildrenCount = Length(FCursor.Children) then\r\n SetLength(FCursor.Children, FOwnTree.CalcGrowCapacity(Length(FCursor.Children), FCursor.ChildrenCount));\r\n if FCursor.ChildrenCount < Length(FCursor.Children) then\r\n begin\r\n NewNode := TJclPtrTreeNode.Create;\r\n NewNode.Value := APtr;\r\n NewNode.Parent := FCursor;\r\n for I := FCursor.ChildrenCount - 1 downto Index do\r\n FCursor.Children[I + 1] := FCursor.Children[I];\r\n FCursor.Children[Index] := NewNode;\r\n Inc(FCursor.ChildrenCount);\r\n Inc(FOwnTree.FSize);\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.WriteUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclPtrTreeIterator.IteratorEquals(const AIterator: IJclPtrIterator): Boolean;\r\nvar\r\n Obj: TObject;\r\n ItrObj: TJclPtrTreeIterator;\r\nbegin\r\n Result := False;\r\n if AIterator = nil then\r\n Exit;\r\n Obj := AIterator.GetIteratorReference;\r\n if Obj is TJclPtrTreeIterator then\r\n begin\r\n ItrObj := TJclPtrTreeIterator(Obj);\r\n Result := (FOwnTree = ItrObj.FOwnTree) and (FCursor = ItrObj.FCursor) and (Valid = ItrObj.Valid);\r\n end;\r\nend;\r\n\r\n{$IFDEF SUPPORTS_FOR_IN}\r\nfunction TJclPtrTreeIterator.MoveNext: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Valid then\r\n FCursor := GetNextCursor\r\n else\r\n Valid := True;\r\n Result := FCursor <> nil;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n{$ENDIF SUPPORTS_FOR_IN}\r\n\r\nfunction TJclPtrTreeIterator.Next: Pointer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Valid then\r\n FCursor := GetNextCursor\r\n else\r\n Valid := True;\r\n Result := nil;\r\n if FCursor <> nil then\r\n Result := FCursor.Value\r\n else\r\n if not FOwnTree.ReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclPtrTreeIterator.NextIndex: Integer;\r\nbegin\r\n // No index\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nfunction TJclPtrTreeIterator.Parent: Pointer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := nil;\r\n if FCursor <> nil then\r\n FCursor := FCursor.Parent;\r\n if FCursor <> nil then\r\n Result := FCursor.Value\r\n else\r\n if not FOwnTree.ReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclPtrTreeIterator.Previous: Pointer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Valid then\r\n FCursor := GetPreviousCursor\r\n else\r\n Valid := True;\r\n Result := nil;\r\n if FCursor <> nil then\r\n Result := FCursor.Value\r\n else\r\n if not FOwnTree.ReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclPtrTreeIterator.PreviousIndex: Integer;\r\nbegin\r\n // No index\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nprocedure TJclPtrTreeIterator.Remove;\r\nvar\r\n OldCursor: TJclPtrTreeNode;\r\nbegin\r\n if FOwnTree.ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n CheckValid;\r\n Valid := False;\r\n OldCursor := FCursor;\r\n FCursor := GetNextSibling;\r\n if OldCursor <> nil then\r\n FOwnTree.RemoveNode(OldCursor);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.WriteUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclPtrTreeIterator.Reset;\r\nvar\r\n NewCursor: TJclPtrTreeNode;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Valid := False;\r\n case FStart of\r\n isFirst:\r\n begin\r\n NewCursor := FCursor;\r\n while NewCursor <> nil do\r\n begin\r\n NewCursor := GetPreviousCursor;\r\n if NewCursor <> nil then\r\n FCursor := NewCursor;\r\n end;\r\n end;\r\n isLast:\r\n begin\r\n NewCursor := FCursor;\r\n while NewCursor <> nil do\r\n begin\r\n NewCursor := GetNextCursor;\r\n if NewCursor <> nil then\r\n FCursor := NewCursor;\r\n end;\r\n end;\r\n isRoot:\r\n begin\r\n while (FCursor <> nil) and (FCursor.Parent <> nil) do\r\n FCursor := FCursor.Parent;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclPtrTreeIterator.SetChild(Index: Integer; APtr: Pointer);\r\nbegin\r\n if FOwnTree.ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if (FCursor <> nil) and (Index >= 0) and (Index < FCursor.ChildrenCount) then\r\n TJclPtrTreeNode(FCursor.Children[Index]).Value := APtr\r\n else\r\n raise EJclOutOfBoundsError.Create;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.WriteUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclPtrTreeIterator.SetPointer(APtr: Pointer);\r\nbegin\r\n if FOwnTree.ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n CheckValid;\r\n if FCursor <> nil then\r\n begin\r\n FOwnTree.FreePointer(FCursor.Value);\r\n FCursor.Value := APtr;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.WriteUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\n//=== { TJclPreOrderPtrTreeIterator } ===================================================\r\n\r\nfunction TJclPreOrderPtrTreeIterator.CreateEmptyIterator: TJclAbstractIterator;\r\nbegin\r\n Result := TJclPreOrderPtrTreeIterator.Create(FOwnTree, FCursor, Valid, FStart);\r\nend;\r\n\r\nfunction TJclPreOrderPtrTreeIterator.GetNextCursor: TJclPtrTreeNode;\r\nvar\r\n LastRet: TJclPtrTreeNode;\r\nbegin\r\n Result := FCursor;\r\n if Result = nil then\r\n Exit;\r\n LastRet := Result;\r\n if Result.ChildrenCount > 0 then\r\n Result := TJclPtrTreeNode(Result.Children[0])\r\n else\r\n begin\r\n Result := Result.Parent;\r\n while (Result <> nil) and (Result.IndexOfChild(LastRet) = (Result.ChildrenCount - 1)) do\r\n begin\r\n LastRet := Result;\r\n Result := Result.Parent;\r\n end;\r\n if Result <> nil then // not root = return successor\r\n Result := TJclPtrTreeNode(Result.Children[Result.IndexOfChild(LastRet) + 1]);\r\n end;\r\nend;\r\n\r\nfunction TJclPreOrderPtrTreeIterator.GetNextSibling: TJclPtrTreeNode;\r\nvar\r\n LastRet: TJclPtrTreeNode;\r\nbegin\r\n Result := FCursor;\r\n if Result = nil then\r\n Exit;\r\n LastRet := Result;\r\n\r\n Result := Result.Parent;\r\n while (Result <> nil) and (Result.IndexOfChild(LastRet) = (Result.ChildrenCount - 1)) do\r\n begin\r\n LastRet := Result;\r\n Result := Result.Parent;\r\n end;\r\n if Result <> nil then // not root = return successor\r\n Result := TJclPtrTreeNode(Result.Children[Result.IndexOfChild(LastRet) + 1]);\r\nend;\r\n\r\nfunction TJclPreOrderPtrTreeIterator.GetPreviousCursor: TJclPtrTreeNode;\r\nvar\r\n LastRet: TJclPtrTreeNode;\r\nbegin\r\n Result := FCursor;\r\n if Result = nil then\r\n Exit;\r\n LastRet := Result;\r\n Result := Result.Parent;\r\n if (Result <> nil) and (Result.IndexOfChild(LastRet) > 0) then\r\n // come from Right\r\n begin\r\n Result := TJclPtrTreeNode(Result.Children[Result.IndexOfChild(LastRet) - 1]);\r\n while (Result.ChildrenCount > 0) do // descend down the tree\r\n Result := TJclPtrTreeNode(Result.Children[Result.ChildrenCount - 1]);\r\n end;\r\nend;\r\n\r\n//=== { TJclPostOrderPtrTreeIterator } ==================================================\r\n\r\nfunction TJclPostOrderPtrTreeIterator.CreateEmptyIterator: TJclAbstractIterator;\r\nbegin\r\n Result := TJclPostOrderPtrTreeIterator.Create(FOwnTree, FCursor, Valid, FStart);\r\nend;\r\n\r\nfunction TJclPostOrderPtrTreeIterator.GetNextCursor: TJclPtrTreeNode;\r\nvar\r\n LastRet: TJclPtrTreeNode;\r\nbegin\r\n Result := FCursor;\r\n if Result = nil then\r\n Exit;\r\n LastRet := Result;\r\n Result := Result.Parent;\r\n if (Result <> nil) and (Result.IndexOfChild(LastRet) <> (Result.ChildrenCount - 1)) then\r\n begin\r\n Result := TJclPtrTreeNode(Result.Children[Result.IndexOfChild(LastRet) + 1]);\r\n while Result.ChildrenCount > 0 do\r\n Result := TJclPtrTreeNode(Result.Children[0]);\r\n end;\r\nend;\r\n\r\nfunction TJclPostOrderPtrTreeIterator.GetNextSibling: TJclPtrTreeNode;\r\nvar\r\n LastRet: TJclPtrTreeNode;\r\nbegin\r\n Result := FCursor;\r\n if Result = nil then\r\n Exit;\r\n LastRet := Result;\r\n Result := Result.Parent;\r\n\r\n if (Result <> nil) and (Result.IndexOfChild(LastRet) <> (Result.ChildrenCount - 1)) then\r\n begin\r\n Result := TJclPtrTreeNode(Result.Children[Result.IndexOfChild(LastRet) + 1]);\r\n while Result.ChildrenCount > 0 do\r\n Result := TJclPtrTreeNode(Result.Children[0]);\r\n end;\r\nend;\r\n\r\nfunction TJclPostOrderPtrTreeIterator.GetPreviousCursor: TJclPtrTreeNode;\r\nvar\r\n LastRet: TJclPtrTreeNode;\r\nbegin\r\n Result := FCursor;\r\n if Result = nil then\r\n Exit;\r\n if Result.ChildrenCount > 0 then\r\n Result := TJclPtrTreeNode(Result.Children[Result.ChildrenCount - 1])\r\n else\r\n begin\r\n LastRet := Result;\r\n Result := Result.Parent;\r\n while (Result <> nil) and (Result.IndexOfChild(LastRet) = 0) do\r\n begin\r\n LastRet := Result;\r\n Result := Result.Parent;\r\n end;\r\n if Result <> nil then // not root\r\n Result := TJclPtrTreeNode(Result.Children[Result.IndexOfChild(LastRet) - 1]);\r\n end;\r\nend;\r\n\r\n//=== { TJclTreeNode } =======================================================\r\n\r\nfunction TJclTreeNode.IndexOfChild(AChild: TJclTreeNode): Integer;\r\nbegin\r\n for Result := 0 to ChildrenCount - 1 do\r\n if Children[Result] = AChild then\r\n Exit;\r\n Result := -1;\r\nend;\r\n\r\nfunction TJclTreeNode.IndexOfValue(AObject: TObject;\r\n const AEqualityComparer: IJclEqualityComparer): Integer;\r\nbegin\r\n for Result := 0 to ChildrenCount - 1 do\r\n if AEqualityComparer.ItemsEqual(TJclTreeNode(Children[Result]).Value, AObject) then\r\n Exit;\r\n Result := -1;\r\nend;\r\n\r\n//=== { TJclTree } =======================================================\r\n\r\nconstructor TJclTree.Create(AOwnsObjects: Boolean);\r\nbegin\r\n inherited Create(AOwnsObjects);\r\n FTraverseOrder := toPreOrder;\r\nend;\r\n\r\ndestructor TJclTree.Destroy;\r\nbegin\r\n FReadOnly := False;\r\n Clear;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJclTree.Add(AObject: TObject): Boolean;\r\nvar\r\n NewNode: TJclTreeNode;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := AllowDefaultElements or not ItemsEqual(AObject, nil);\r\n\r\n if Result then\r\n begin\r\n if FRoot <> nil then\r\n begin\r\n Result := (not Contains(AObject)) or CheckDuplicate;\r\n if Result then\r\n begin\r\n if FRoot.ChildrenCount = Length(FRoot.Children) then\r\n SetLength(FRoot.Children, CalcGrowCapacity(Length(FRoot.Children), FRoot.ChildrenCount));\r\n if FRoot.ChildrenCount < Length(FRoot.Children) then\r\n begin\r\n NewNode := TJclTreeNode.Create;\r\n NewNode.Value := AObject;\r\n NewNode.Parent := FRoot;\r\n FRoot.Children[FRoot.ChildrenCount] := NewNode;\r\n Inc(FRoot.ChildrenCount);\r\n Inc(FSize);\r\n end\r\n else\r\n Result := False;\r\n end;\r\n end\r\n else\r\n begin\r\n FRoot := TJclTreeNode.Create;\r\n FRoot.Value := AObject;\r\n Inc(FSize);\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclTree.AddAll(const ACollection: IJclCollection): Boolean;\r\nvar\r\n It: IJclIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n Result := Add(It.Next) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclTree.AssignDataTo(Dest: TJclAbstractContainerBase);\r\nvar\r\n ADest: TJclTree;\r\n ACollection: IJclCollection;\r\nbegin\r\n inherited AssignDataTo(Dest);\r\n if Dest is TJclTree then\r\n begin\r\n ADest := TJclTree(Dest);\r\n ADest.Clear;\r\n ADest.FSize := FSize;\r\n if FRoot <> nil then\r\n ADest.FRoot := CloneNode(FRoot, nil);\r\n end\r\n else\r\n if Supports(IInterface(Dest), IJclCollection, ACollection) then\r\n begin\r\n ACollection.Clear;\r\n ACollection.AddAll(Self);\r\n end;\r\nend;\r\n\r\nprocedure TJclTree.AssignPropertiesTo(Dest: TJclAbstractContainerBase);\r\nbegin\r\n inherited AssignPropertiesto(Dest);\r\n if Dest is TJclTree then\r\n TJclTree(Dest).FTraverseOrder := FTraverseOrder;\r\nend;\r\n\r\nprocedure TJclTree.Clear;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FRoot <> nil then\r\n RemoveNode(FRoot);\r\n FSize := 0;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclTree.CloneNode(Node, Parent: TJclTreeNode): TJclTreeNode;\r\nvar\r\n Index: Integer;\r\nbegin\r\n Result := TJclTreeNode.Create;\r\n Result.Value := Node.Value;\r\n Result.Parent := Parent;\r\n SetLength(Result.Children, Node.ChildrenCount);\r\n Result.ChildrenCount := Node.ChildrenCount;\r\n for Index := 0 to Node.ChildrenCount - 1 do\r\n Result.Children[Index] := CloneNode(TJclTreeNode(Node.Children[Index]), Result); // recursive call\r\nend;\r\n\r\nfunction TJclTree.CollectionEquals(const ACollection: IJclCollection): Boolean;\r\nvar\r\n It, ItSelf: IJclIterator;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n if FSize <> ACollection.Size then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n ItSelf := First;\r\n while ItSelf.HasNext do\r\n if not ItemsEqual(ItSelf.Next, It.Next) then\r\n begin\r\n Result := False;\r\n Break;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclTree.Contains(AObject: TObject): Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FRoot <> nil then\r\n Result := NodeContains(FRoot, AObject)\r\n else\r\n Result := False;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclTree.ContainsAll(const ACollection: IJclCollection): Boolean;\r\nvar\r\n It: IJclIterator;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := True;\r\n if ACollection = nil then\r\n Exit;\r\n It := ACollection.First;\r\n while Result and It.HasNext do\r\n Result := Contains(It.Next);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclTree.Extract(AObject: TObject): Boolean;\r\nvar\r\n It: IJclIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := FRoot <> nil;\r\n if Result then\r\n begin\r\n It := First;\r\n while It.HasNext do\r\n if ItemsEqual(It.Next, AObject) then\r\n begin\r\n It.Extract;\r\n if RemoveSingleElement then\r\n Break;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclTree.ExtractAll(const ACollection: IJclCollection): Boolean;\r\nvar\r\n It: IJclIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n Result := Extract(It.Next) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclTree.ExtractNode(var ANode: TJclTreeNode);\r\nvar\r\n Index, ChildIndex, NewCapacity: Integer;\r\n Parent: TJclTreeNode;\r\nbegin\r\n for Index := ANode.ChildrenCount - 1 downto 0 do\r\n {$IFDEF BCB}\r\n ExtractNode(TJclTreeNode(ANode.Children[Index]));\r\n {$ELSE ~BCB}\r\n ExtractNode(ANode.Children[Index]);\r\n {$ENDIF ~BCB}\r\n Parent := ANode.Parent;\r\n if Parent <> nil then\r\n begin\r\n ChildIndex := Parent.IndexOfChild(ANode);\r\n for Index := ChildIndex + 1 to Parent.ChildrenCount - 1 do\r\n Parent.Children[Index - 1] := Parent.Children[Index];\r\n Dec(Parent.ChildrenCount);\r\n NewCapacity := CalcPackCapacity(Length(Parent.Children), Parent.ChildrenCount);\r\n if NewCapacity < Length(Parent.Children) then\r\n SetLength(Parent.Children, NewCapacity);\r\n FreeAndNil(ANode);\r\n end\r\n else\r\n begin\r\n FreeAndNil(ANode);\r\n FRoot := nil;\r\n end;\r\n Dec(FSize);\r\nend;\r\n\r\nfunction TJclTree.First: IJclIterator;\r\nvar\r\n Start: TJclTreeNode;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Start := FRoot;\r\n case GetTraverseOrder of\r\n toPreOrder:\r\n Result := TJclPreOrderTreeIterator.Create(Self, Start, False, isFirst);\r\n toPostOrder:\r\n begin\r\n if Start <> nil then\r\n while (Start.ChildrenCount > 0) do\r\n Start := TJclTreeNode(Start.Children[0]);\r\n Result := TJclPostOrderTreeIterator.Create(Self, Start, False, isFirst);\r\n end;\r\n else\r\n Result := nil;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\n{$IFDEF SUPPORTS_FOR_IN}\r\nfunction TJclTree.GetEnumerator: IJclIterator;\r\nbegin\r\n Result := First;\r\nend;\r\n{$ENDIF SUPPORTS_FOR_IN}\r\n\r\nfunction TJclTree.GetRoot: IJclTreeIterator;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n case GetTraverseOrder of\r\n toPreOrder:\r\n Result := TJclPreOrderTreeIterator.Create(Self, FRoot, False, isRoot);\r\n toPostOrder:\r\n Result := TJclPostOrderTreeIterator.Create(Self, FRoot, False, isRoot);\r\n else\r\n Result := nil;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclTree.GetTraverseOrder: TJclTraverseOrder;\r\nbegin\r\n Result := FTraverseOrder;\r\nend;\r\n\r\nfunction TJclTree.IsEmpty: Boolean;\r\nbegin\r\n Result := FSize = 0;\r\nend;\r\n\r\nfunction TJclTree.Last: IJclIterator;\r\nvar\r\n Start: TJclTreeNode;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Start := FRoot;\r\n case FTraverseOrder of\r\n toPreOrder:\r\n begin\r\n if Start <> nil then\r\n while Start.ChildrenCount > 0 do\r\n Start := TJclTreeNode(Start.Children[Start.ChildrenCount - 1]);\r\n Result := TJclPreOrderTreeIterator.Create(Self, Start, False, isLast);\r\n end;\r\n toPostOrder:\r\n Result := TJclPostOrderTreeIterator.Create(Self, Start, False, isLast);\r\n else\r\n Result := nil;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclTree.NodeContains(ANode: TJclTreeNode; AObject: TObject): Boolean;\r\nvar\r\n Index: Integer;\r\nbegin\r\n Result := ItemsEqual(ANode.Value, AObject);\r\n if not Result then\r\n for Index := 0 to ANode.ChildrenCount - 1 do\r\n begin\r\n Result := NodeContains(TJclTreeNode(ANode.Children[Index]), AObject);\r\n if Result then\r\n Break;\r\n end;\r\nend;\r\n\r\nprocedure TJclTree.Pack;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FRoot <> nil then\r\n PackNode(FRoot);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclTree.PackNode(ANode: TJclTreeNode);\r\nvar\r\n Index: Integer;\r\nbegin\r\n SetLength(ANode.Children, ANode.ChildrenCount);\r\n for Index := 0 to ANode.ChildrenCount - 1 do\r\n PackNode(TJclTreeNode(ANode.Children[Index]));\r\nend;\r\n\r\nfunction TJclTree.Remove(AObject: TObject): Boolean;\r\nvar\r\n Extracted: TObject;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := Extract(AObject);\r\n if Result then\r\n begin\r\n Extracted := AObject;\r\n FreeObject(Extracted);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclTree.RemoveAll(const ACollection: IJclCollection): Boolean;\r\nvar\r\n It: IJclIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n Result := Remove(It.Next) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclTree.RemoveNode(var ANode: TJclTreeNode);\r\nvar\r\n Index, ChildIndex, NewCapacity: Integer;\r\n Parent: TJclTreeNode;\r\nbegin\r\n for Index := ANode.ChildrenCount - 1 downto 0 do\r\n {$IFDEF BCB}\r\n RemoveNode(TJclTreeNode(ANode.Children[Index]));\r\n {$ELSE ~BCB}\r\n RemoveNode(ANode.Children[Index]);\r\n {$ENDIF ~BCB}\r\n FreeObject(ANode.Value);\r\n Parent := ANode.Parent;\r\n if Parent <> nil then\r\n begin\r\n ChildIndex := Parent.IndexOfChild(ANode);\r\n for Index := ChildIndex + 1 to Parent.ChildrenCount - 1 do\r\n Parent.Children[Index - 1] := Parent.Children[Index];\r\n Dec(Parent.ChildrenCount);\r\n NewCapacity := CalcPackCapacity(Length(Parent.Children), Parent.ChildrenCount);\r\n if NewCapacity < Length(Parent.Children) then\r\n SetLength(Parent.Children, NewCapacity);\r\n FreeAndNil(ANode);\r\n end\r\n else\r\n begin\r\n FreeAndNil(ANode);\r\n FRoot := nil;\r\n end;\r\n Dec(FSize);\r\nend;\r\n\r\nfunction TJclTree.RetainAll(const ACollection: IJclCollection): Boolean;\r\nvar\r\n It: IJclIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := First;\r\n while It.HasNext do\r\n if not ACollection.Contains(It.Next) then\r\n It.Remove;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclTree.SetCapacity(Value: Integer);\r\nbegin\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nprocedure TJclTree.SetTraverseOrder(Value: TJclTraverseOrder);\r\nbegin\r\n FTraverseOrder := Value;\r\nend;\r\n\r\nfunction TJclTree.Size: Integer;\r\nbegin\r\n Result := FSize;\r\nend;\r\n\r\nfunction TJclTree.CreateEmptyContainer: TJclAbstractContainerBase;\r\nbegin\r\n Result := TJclTree.Create(False);\r\n AssignPropertiesTo(Result);\r\nend;\r\n\r\n//=== { TJclTreeIterator } ===========================================================\r\n\r\nconstructor TJclTreeIterator.Create(OwnTree: TJclTree; ACursor: TJclTreeNode; AValid: Boolean; AStart: TItrStart);\r\nbegin\r\n inherited Create(AValid);\r\n FCursor := ACursor;\r\n FOwnTree := OwnTree;\r\n FStart := AStart;\r\n FEqualityComparer := OwnTree as IJclEqualityComparer;\r\nend;\r\n\r\nfunction TJclTreeIterator.Add(AObject: TObject): Boolean;\r\nvar\r\n ParentNode, NewNode: TJclTreeNode;\r\nbegin\r\n if FOwnTree.ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n // add sibling or, if FCursor is root node, behave like TJclTree.Add\r\n Result := (FCursor <> nil) and (FOwnTree.AllowDefaultElements or not FEqualityComparer.ItemsEqual(AObject, nil))\r\n and ((not FOwnTree.Contains(AObject)) or FOwnTree.CheckDuplicate);\r\n\r\n if Result then\r\n begin\r\n ParentNode := FCursor.Parent;\r\n if ParentNode = nil then\r\n ParentNode := FCursor;\r\n\r\n if ParentNode.ChildrenCount = Length(ParentNode.Children) then\r\n SetLength(ParentNode.Children, FOwnTree.CalcGrowCapacity(Length(ParentNode.Children), ParentNode.ChildrenCount));\r\n if ParentNode.ChildrenCount < Length(ParentNode.Children) then\r\n begin\r\n NewNode := TJclTreeNode.Create;\r\n NewNode.Value := AObject;\r\n NewNode.Parent := ParentNode;\r\n ParentNode.Children[ParentNode.ChildrenCount] := NewNode;\r\n Inc(ParentNode.ChildrenCount);\r\n Inc(FOwnTree.FSize);\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.WriteUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclTreeIterator.AddChild(AObject: TObject): Boolean;\r\nvar\r\n NewNode: TJclTreeNode;\r\nbegin\r\n if FOwnTree.ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := (FCursor <> nil) and (FOwnTree.AllowDefaultElements or not FEqualityComparer.ItemsEqual(AObject, nil))\r\n and ((not FOwnTree.Contains(AObject)) or FOwnTree.CheckDuplicate);\r\n\r\n if Result then\r\n begin\r\n if FCursor.ChildrenCount = Length(FCursor.Children) then\r\n SetLength(FCursor.Children, FOwnTree.CalcGrowCapacity(Length(FCursor.Children), FCursor.ChildrenCount));\r\n if FCursor.ChildrenCount < Length(FCursor.Children) then\r\n begin\r\n NewNode := TJclTreeNode.Create;\r\n NewNode.Value := AObject;\r\n NewNode.Parent := FCursor;\r\n FCursor.Children[FCursor.ChildrenCount] := NewNode;\r\n Inc(FCursor.ChildrenCount);\r\n Inc(FOwnTree.FSize);\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.WriteUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclTreeIterator.AssignPropertiesTo(Dest: TJclAbstractIterator);\r\nvar\r\n ADest: TJclTreeIterator;\r\nbegin\r\n inherited AssignPropertiesTo(Dest);\r\n if Dest is TJclTreeIterator then\r\n begin\r\n ADest := TJclTreeIterator(Dest);\r\n ADest.FCursor := FCursor;\r\n ADest.FOwnTree := FOwnTree;\r\n ADest.FEqualityComparer := FEqualityComparer;\r\n ADest.FStart := FStart;\r\n end;\r\nend;\r\n\r\nfunction TJclTreeIterator.ChildrenCount: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FCursor <> nil then\r\n Result := FCursor.ChildrenCount\r\n else\r\n Result := 0;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclTreeIterator.DeleteChild(Index: Integer);\r\nbegin\r\n if FOwnTree.ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if (FCursor <> nil) and (Index >= 0) and (Index < FCursor.ChildrenCount) then\r\n {$IFDEF BCB}\r\n FOwnTree.RemoveNode(TJclTreeNode(FCursor.Children[Index]))\r\n {$ELSE ~BCB}\r\n FOwnTree.RemoveNode(FCursor.Children[Index])\r\n {$ENDIF ~BCB}\r\n else\r\n raise EJclOutOfBoundsError.Create;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.WriteUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclTreeIterator.DeleteChildren;\r\nvar\r\n Index: Integer;\r\nbegin\r\n if FOwnTree.ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FCursor <> nil then\r\n begin\r\n for Index := FCursor.ChildrenCount - 1 downto 0 do\r\n {$IFDEF BCB}\r\n FOwnTree.RemoveNode(TJclTreeNode(FCursor.Children[Index]));\r\n {$ELSE ~BCB}\r\n FOwnTree.RemoveNode(FCursor.Children[Index]);\r\n {$ENDIF ~BCB}\r\n SetLength(FCursor.Children, 0);\r\n FCursor.ChildrenCount := 0;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.WriteUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclTreeIterator.Extract;\r\nvar\r\n OldCursor: TJclTreeNode;\r\nbegin\r\n if FOwnTree.ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n CheckValid;\r\n Valid := False;\r\n OldCursor := FCursor;\r\n FCursor := GetNextSibling;\r\n if OldCursor <> nil then\r\n FOwnTree.ExtractNode(OldCursor);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.WriteUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclTreeIterator.ExtractChild(Index: Integer);\r\nbegin\r\n if FOwnTree.ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if (FCursor <> nil) and (Index >= 0) and (Index < FCursor.ChildrenCount) then\r\n {$IFDEF BCB}\r\n FOwnTree.ExtractNode(TJclTreeNode(FCursor.Children[Index]))\r\n {$ELSE ~BCB}\r\n FOwnTree.ExtractNode(FCursor.Children[Index])\r\n {$ENDIF ~BCB}\r\n else\r\n raise EJclOutOfBoundsError.Create;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.WriteUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclTreeIterator.ExtractChildren;\r\nvar\r\n Index: Integer;\r\nbegin\r\n if FOwnTree.ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FCursor <> nil then\r\n begin\r\n for Index := FCursor.ChildrenCount - 1 downto 0 do\r\n {$IFDEF BCB}\r\n FOwnTree.ExtractNode(TJclTreeNode(FCursor.Children[Index]));\r\n {$ELSE ~BCB}\r\n FOwnTree.ExtractNode(FCursor.Children[Index]);\r\n {$ENDIF ~BCB}\r\n SetLength(FCursor.Children, 0);\r\n FCursor.ChildrenCount := 0;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.WriteUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclTreeIterator.GetChild(Index: Integer): TObject;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := nil;\r\n if (FCursor <> nil) and (Index >= 0) and (Index < FCursor.ChildrenCount) then\r\n FCursor := TJclTreeNode(FCursor.Children[Index]);\r\n if FCursor <> nil then\r\n Result := FCursor.Value\r\n else\r\n if not FOwnTree.ReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclTreeIterator.GetObject: TObject;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n CheckValid;\r\n Result := nil;\r\n if FCursor <> nil then\r\n Result := FCursor.Value\r\n else\r\n if not FOwnTree.ReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclTreeIterator.HasChild(Index: Integer): Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := (FCursor <> nil) and (Index >= 0) and (Index < FCursor.ChildrenCount);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclTreeIterator.HasNext: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Valid then\r\n Result := GetNextCursor <> nil\r\n else\r\n Result := FCursor <> nil;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclTreeIterator.HasParent: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := (FCursor <> nil) and (FCursor.Parent <> nil);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclTreeIterator.HasPrevious: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Valid then\r\n Result := GetPreviousCursor <> nil\r\n else\r\n Result := FCursor <> nil;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclTreeIterator.IndexOfChild(AObject: TObject): Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FCursor <> nil then\r\n Result := FCursor.IndexOfValue(AObject, FEqualityComparer)\r\n else\r\n Result := -1;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclTreeIterator.Insert(AObject: TObject): Boolean;\r\nvar\r\n ParentNode, NewNode: TJclTreeNode;\r\n Index, I: Integer;\r\nbegin\r\n if FOwnTree.ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n // insert sibling or, if FCursor is root node, behave like TJclTree.Insert\r\n Result := (FCursor <> nil) and (FOwnTree.AllowDefaultElements or not FEqualityComparer.ItemsEqual(AObject, nil))\r\n and ((not FOwnTree.Contains(AObject)) or FOwnTree.CheckDuplicate);\r\n\r\n if Result then\r\n begin\r\n if FCursor.Parent <> nil then\r\n begin\r\n ParentNode := FCursor.Parent;\r\n Index := 0;\r\n while (Index < ParentNode.ChildrenCount) and (ParentNode.Children[Index] <> FCursor) do\r\n Inc(Index);\r\n end\r\n else\r\n begin\r\n ParentNode := FCursor;\r\n Index := 0;\r\n end;\r\n\r\n if ParentNode.ChildrenCount = Length(ParentNode.Children) then\r\n SetLength(ParentNode.Children, FOwnTree.CalcGrowCapacity(Length(ParentNode.Children), ParentNode.ChildrenCount));\r\n if ParentNode.ChildrenCount < Length(ParentNode.Children) then\r\n begin\r\n NewNode := TJclTreeNode.Create;\r\n NewNode.Value := AObject;\r\n NewNode.Parent := ParentNode;\r\n for I := ParentNode.ChildrenCount - 1 downto Index do\r\n ParentNode.Children[I + 1] := ParentNode.Children[I];\r\n ParentNode.Children[Index] := NewNode;\r\n Inc(ParentNode.ChildrenCount);\r\n Inc(FOwnTree.FSize);\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.WriteUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclTreeIterator.InsertChild(Index: Integer; AObject: TObject): Boolean;\r\nvar\r\n NewNode: TJclTreeNode;\r\n I: Integer;\r\nbegin\r\n if FOwnTree.ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n // insert sibling or, if FCursor is root node, behave like TJclTree.Insert\r\n Result := (FCursor <> nil) and (FOwnTree.AllowDefaultElements or not FEqualityComparer.ItemsEqual(AObject, nil))\r\n and ((not FOwnTree.Contains(AObject)) or FOwnTree.CheckDuplicate);\r\n\r\n if Result then\r\n begin\r\n if FCursor.ChildrenCount = Length(FCursor.Children) then\r\n SetLength(FCursor.Children, FOwnTree.CalcGrowCapacity(Length(FCursor.Children), FCursor.ChildrenCount));\r\n if FCursor.ChildrenCount < Length(FCursor.Children) then\r\n begin\r\n NewNode := TJclTreeNode.Create;\r\n NewNode.Value := AObject;\r\n NewNode.Parent := FCursor;\r\n for I := FCursor.ChildrenCount - 1 downto Index do\r\n FCursor.Children[I + 1] := FCursor.Children[I];\r\n FCursor.Children[Index] := NewNode;\r\n Inc(FCursor.ChildrenCount);\r\n Inc(FOwnTree.FSize);\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.WriteUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclTreeIterator.IteratorEquals(const AIterator: IJclIterator): Boolean;\r\nvar\r\n Obj: TObject;\r\n ItrObj: TJclTreeIterator;\r\nbegin\r\n Result := False;\r\n if AIterator = nil then\r\n Exit;\r\n Obj := AIterator.GetIteratorReference;\r\n if Obj is TJclTreeIterator then\r\n begin\r\n ItrObj := TJclTreeIterator(Obj);\r\n Result := (FOwnTree = ItrObj.FOwnTree) and (FCursor = ItrObj.FCursor) and (Valid = ItrObj.Valid);\r\n end;\r\nend;\r\n\r\n{$IFDEF SUPPORTS_FOR_IN}\r\nfunction TJclTreeIterator.MoveNext: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Valid then\r\n FCursor := GetNextCursor\r\n else\r\n Valid := True;\r\n Result := FCursor <> nil;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n{$ENDIF SUPPORTS_FOR_IN}\r\n\r\nfunction TJclTreeIterator.Next: TObject;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Valid then\r\n FCursor := GetNextCursor\r\n else\r\n Valid := True;\r\n Result := nil;\r\n if FCursor <> nil then\r\n Result := FCursor.Value\r\n else\r\n if not FOwnTree.ReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclTreeIterator.NextIndex: Integer;\r\nbegin\r\n // No index\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nfunction TJclTreeIterator.Parent: TObject;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := nil;\r\n if FCursor <> nil then\r\n FCursor := FCursor.Parent;\r\n if FCursor <> nil then\r\n Result := FCursor.Value\r\n else\r\n if not FOwnTree.ReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclTreeIterator.Previous: TObject;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Valid then\r\n FCursor := GetPreviousCursor\r\n else\r\n Valid := True;\r\n Result := nil;\r\n if FCursor <> nil then\r\n Result := FCursor.Value\r\n else\r\n if not FOwnTree.ReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclTreeIterator.PreviousIndex: Integer;\r\nbegin\r\n // No index\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nprocedure TJclTreeIterator.Remove;\r\nvar\r\n OldCursor: TJclTreeNode;\r\nbegin\r\n if FOwnTree.ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n CheckValid;\r\n Valid := False;\r\n OldCursor := FCursor;\r\n FCursor := GetNextSibling;\r\n if OldCursor <> nil then\r\n FOwnTree.RemoveNode(OldCursor);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.WriteUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclTreeIterator.Reset;\r\nvar\r\n NewCursor: TJclTreeNode;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Valid := False;\r\n case FStart of\r\n isFirst:\r\n begin\r\n NewCursor := FCursor;\r\n while NewCursor <> nil do\r\n begin\r\n NewCursor := GetPreviousCursor;\r\n if NewCursor <> nil then\r\n FCursor := NewCursor;\r\n end;\r\n end;\r\n isLast:\r\n begin\r\n NewCursor := FCursor;\r\n while NewCursor <> nil do\r\n begin\r\n NewCursor := GetNextCursor;\r\n if NewCursor <> nil then\r\n FCursor := NewCursor;\r\n end;\r\n end;\r\n isRoot:\r\n begin\r\n while (FCursor <> nil) and (FCursor.Parent <> nil) do\r\n FCursor := FCursor.Parent;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclTreeIterator.SetChild(Index: Integer; AObject: TObject);\r\nbegin\r\n if FOwnTree.ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if (FCursor <> nil) and (Index >= 0) and (Index < FCursor.ChildrenCount) then\r\n TJclTreeNode(FCursor.Children[Index]).Value := AObject\r\n else\r\n raise EJclOutOfBoundsError.Create;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.WriteUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclTreeIterator.SetObject(AObject: TObject);\r\nbegin\r\n if FOwnTree.ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n CheckValid;\r\n if FCursor <> nil then\r\n begin\r\n FOwnTree.FreeObject(FCursor.Value);\r\n FCursor.Value := AObject;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.WriteUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\n//=== { TJclPreOrderTreeIterator } ===================================================\r\n\r\nfunction TJclPreOrderTreeIterator.CreateEmptyIterator: TJclAbstractIterator;\r\nbegin\r\n Result := TJclPreOrderTreeIterator.Create(FOwnTree, FCursor, Valid, FStart);\r\nend;\r\n\r\nfunction TJclPreOrderTreeIterator.GetNextCursor: TJclTreeNode;\r\nvar\r\n LastRet: TJclTreeNode;\r\nbegin\r\n Result := FCursor;\r\n if Result = nil then\r\n Exit;\r\n LastRet := Result;\r\n if Result.ChildrenCount > 0 then\r\n Result := TJclTreeNode(Result.Children[0])\r\n else\r\n begin\r\n Result := Result.Parent;\r\n while (Result <> nil) and (Result.IndexOfChild(LastRet) = (Result.ChildrenCount - 1)) do\r\n begin\r\n LastRet := Result;\r\n Result := Result.Parent;\r\n end;\r\n if Result <> nil then // not root = return successor\r\n Result := TJclTreeNode(Result.Children[Result.IndexOfChild(LastRet) + 1]);\r\n end;\r\nend;\r\n\r\nfunction TJclPreOrderTreeIterator.GetNextSibling: TJclTreeNode;\r\nvar\r\n LastRet: TJclTreeNode;\r\nbegin\r\n Result := FCursor;\r\n if Result = nil then\r\n Exit;\r\n LastRet := Result;\r\n\r\n Result := Result.Parent;\r\n while (Result <> nil) and (Result.IndexOfChild(LastRet) = (Result.ChildrenCount - 1)) do\r\n begin\r\n LastRet := Result;\r\n Result := Result.Parent;\r\n end;\r\n if Result <> nil then // not root = return successor\r\n Result := TJclTreeNode(Result.Children[Result.IndexOfChild(LastRet) + 1]);\r\nend;\r\n\r\nfunction TJclPreOrderTreeIterator.GetPreviousCursor: TJclTreeNode;\r\nvar\r\n LastRet: TJclTreeNode;\r\nbegin\r\n Result := FCursor;\r\n if Result = nil then\r\n Exit;\r\n LastRet := Result;\r\n Result := Result.Parent;\r\n if (Result <> nil) and (Result.IndexOfChild(LastRet) > 0) then\r\n // come from Right\r\n begin\r\n Result := TJclTreeNode(Result.Children[Result.IndexOfChild(LastRet) - 1]);\r\n while (Result.ChildrenCount > 0) do // descend down the tree\r\n Result := TJclTreeNode(Result.Children[Result.ChildrenCount - 1]);\r\n end;\r\nend;\r\n\r\n//=== { TJclPostOrderTreeIterator } ==================================================\r\n\r\nfunction TJclPostOrderTreeIterator.CreateEmptyIterator: TJclAbstractIterator;\r\nbegin\r\n Result := TJclPostOrderTreeIterator.Create(FOwnTree, FCursor, Valid, FStart);\r\nend;\r\n\r\nfunction TJclPostOrderTreeIterator.GetNextCursor: TJclTreeNode;\r\nvar\r\n LastRet: TJclTreeNode;\r\nbegin\r\n Result := FCursor;\r\n if Result = nil then\r\n Exit;\r\n LastRet := Result;\r\n Result := Result.Parent;\r\n if (Result <> nil) and (Result.IndexOfChild(LastRet) <> (Result.ChildrenCount - 1)) then\r\n begin\r\n Result := TJclTreeNode(Result.Children[Result.IndexOfChild(LastRet) + 1]);\r\n while Result.ChildrenCount > 0 do\r\n Result := TJclTreeNode(Result.Children[0]);\r\n end;\r\nend;\r\n\r\nfunction TJclPostOrderTreeIterator.GetNextSibling: TJclTreeNode;\r\nvar\r\n LastRet: TJclTreeNode;\r\nbegin\r\n Result := FCursor;\r\n if Result = nil then\r\n Exit;\r\n LastRet := Result;\r\n Result := Result.Parent;\r\n\r\n if (Result <> nil) and (Result.IndexOfChild(LastRet) <> (Result.ChildrenCount - 1)) then\r\n begin\r\n Result := TJclTreeNode(Result.Children[Result.IndexOfChild(LastRet) + 1]);\r\n while Result.ChildrenCount > 0 do\r\n Result := TJclTreeNode(Result.Children[0]);\r\n end;\r\nend;\r\n\r\nfunction TJclPostOrderTreeIterator.GetPreviousCursor: TJclTreeNode;\r\nvar\r\n LastRet: TJclTreeNode;\r\nbegin\r\n Result := FCursor;\r\n if Result = nil then\r\n Exit;\r\n if Result.ChildrenCount > 0 then\r\n Result := TJclTreeNode(Result.Children[Result.ChildrenCount - 1])\r\n else\r\n begin\r\n LastRet := Result;\r\n Result := Result.Parent;\r\n while (Result <> nil) and (Result.IndexOfChild(LastRet) = 0) do\r\n begin\r\n LastRet := Result;\r\n Result := Result.Parent;\r\n end;\r\n if Result <> nil then // not root\r\n Result := TJclTreeNode(Result.Children[Result.IndexOfChild(LastRet) - 1]);\r\n end;\r\nend;\r\n\r\n\r\n{$IFDEF SUPPORTS_GENERICS}\r\n//DOM-IGNORE-BEGIN\r\n\r\n//=== { TJclTreeNode } =======================================================\r\n\r\nfunction TJclTreeNode.IndexOfChild(AChild: TJclTreeNode): Integer;\r\nbegin\r\n for Result := 0 to ChildrenCount - 1 do\r\n if Children[Result] = AChild then\r\n Exit;\r\n Result := -1;\r\nend;\r\n\r\nfunction TJclTreeNode.IndexOfValue(const AItem: T;\r\n const AEqualityComparer: IJclEqualityComparer): Integer;\r\nbegin\r\n for Result := 0 to ChildrenCount - 1 do\r\n if AEqualityComparer.ItemsEqual(TJclTreeNode(Children[Result]).Value, AItem) then\r\n Exit;\r\n Result := -1;\r\nend;\r\n\r\n//=== { TJclTree } =======================================================\r\n\r\nconstructor TJclTree.Create(AOwnsItems: Boolean);\r\nbegin\r\n inherited Create(AOwnsItems);\r\n FTraverseOrder := toPreOrder;\r\nend;\r\n\r\ndestructor TJclTree.Destroy;\r\nbegin\r\n FReadOnly := False;\r\n Clear;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJclTree.Add(const AItem: T): Boolean;\r\nvar\r\n NewNode: TTreeNode;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := AllowDefaultElements or not ItemsEqual(AItem, Default(T));\r\n\r\n if Result then\r\n begin\r\n if FRoot <> nil then\r\n begin\r\n Result := (not Contains(AItem)) or CheckDuplicate;\r\n if Result then\r\n begin\r\n if FRoot.ChildrenCount = Length(FRoot.Children) then\r\n SetLength(FRoot.Children, CalcGrowCapacity(Length(FRoot.Children), FRoot.ChildrenCount));\r\n if FRoot.ChildrenCount < Length(FRoot.Children) then\r\n begin\r\n NewNode := TTreeNode.Create;\r\n NewNode.Value := AItem;\r\n NewNode.Parent := FRoot;\r\n FRoot.Children[FRoot.ChildrenCount] := NewNode;\r\n Inc(FRoot.ChildrenCount);\r\n Inc(FSize);\r\n end\r\n else\r\n Result := False;\r\n end;\r\n end\r\n else\r\n begin\r\n FRoot := TTreeNode.Create;\r\n FRoot.Value := AItem;\r\n Inc(FSize);\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclTree.AddAll(const ACollection: IJclCollection): Boolean;\r\nvar\r\n It: IJclIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n Result := Add(It.Next) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclTree.AssignDataTo(Dest: TJclAbstractContainerBase);\r\nvar\r\n ADest: TJclTree;\r\n ACollection: IJclCollection;\r\nbegin\r\n inherited AssignDataTo(Dest);\r\n if Dest is TJclTree then\r\n begin\r\n ADest := TJclTree(Dest);\r\n ADest.Clear;\r\n ADest.FSize := FSize;\r\n if FRoot <> nil then\r\n ADest.FRoot := CloneNode(FRoot, nil);\r\n end\r\n else\r\n if Supports(IInterface(Dest), IJclCollection, ACollection) then\r\n begin\r\n ACollection.Clear;\r\n ACollection.AddAll(Self);\r\n end;\r\nend;\r\n\r\nprocedure TJclTree.AssignPropertiesTo(Dest: TJclAbstractContainerBase);\r\nbegin\r\n inherited AssignPropertiesto(Dest);\r\n if Dest is TJclTree then\r\n TJclTree(Dest).FTraverseOrder := FTraverseOrder;\r\nend;\r\n\r\nprocedure TJclTree.Clear;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FRoot <> nil then\r\n RemoveNode(FRoot);\r\n FSize := 0;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclTree.CloneNode(Node, Parent: TTreeNode): TTreeNode;\r\nvar\r\n Index: Integer;\r\nbegin\r\n Result := TTreeNode.Create;\r\n Result.Value := Node.Value;\r\n Result.Parent := Parent;\r\n SetLength(Result.Children, Node.ChildrenCount);\r\n Result.ChildrenCount := Node.ChildrenCount;\r\n for Index := 0 to Node.ChildrenCount - 1 do\r\n Result.Children[Index] := CloneNode(TTreeNode(Node.Children[Index]), Result); // recursive call\r\nend;\r\n\r\nfunction TJclTree.CollectionEquals(const ACollection: IJclCollection): Boolean;\r\nvar\r\n It, ItSelf: IJclIterator;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n if FSize <> ACollection.Size then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n ItSelf := First;\r\n while ItSelf.HasNext do\r\n if not ItemsEqual(ItSelf.Next, It.Next) then\r\n begin\r\n Result := False;\r\n Break;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclTree.Contains(const AItem: T): Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FRoot <> nil then\r\n Result := NodeContains(FRoot, AItem)\r\n else\r\n Result := False;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclTree.ContainsAll(const ACollection: IJclCollection): Boolean;\r\nvar\r\n It: IJclIterator;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := True;\r\n if ACollection = nil then\r\n Exit;\r\n It := ACollection.First;\r\n while Result and It.HasNext do\r\n Result := Contains(It.Next);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclTree.Extract(const AItem: T): Boolean;\r\nvar\r\n It: IJclIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := FRoot <> nil;\r\n if Result then\r\n begin\r\n It := First;\r\n while It.HasNext do\r\n if ItemsEqual(It.Next, AItem) then\r\n begin\r\n It.Extract;\r\n if RemoveSingleElement then\r\n Break;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclTree.ExtractAll(const ACollection: IJclCollection): Boolean;\r\nvar\r\n It: IJclIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n Result := Extract(It.Next) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclTree.ExtractNode(var ANode: TTreeNode);\r\nvar\r\n Index, ChildIndex, NewCapacity: Integer;\r\n Parent: TTreeNode;\r\nbegin\r\n for Index := ANode.ChildrenCount - 1 downto 0 do\r\n {$IFDEF BCB}\r\n ExtractNode(TTreeNode(ANode.Children[Index]));\r\n {$ELSE ~BCB}\r\n ExtractNode(ANode.Children[Index]);\r\n {$ENDIF ~BCB}\r\n Parent := ANode.Parent;\r\n if Parent <> nil then\r\n begin\r\n ChildIndex := Parent.IndexOfChild(ANode);\r\n for Index := ChildIndex + 1 to Parent.ChildrenCount - 1 do\r\n Parent.Children[Index - 1] := Parent.Children[Index];\r\n Dec(Parent.ChildrenCount);\r\n NewCapacity := CalcPackCapacity(Length(Parent.Children), Parent.ChildrenCount);\r\n if NewCapacity < Length(Parent.Children) then\r\n SetLength(Parent.Children, NewCapacity);\r\n FreeAndNil(ANode);\r\n end\r\n else\r\n begin\r\n FreeAndNil(ANode);\r\n FRoot := nil;\r\n end;\r\n Dec(FSize);\r\nend;\r\n\r\nfunction TJclTree.First: IJclIterator;\r\nvar\r\n Start: TTreeNode;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Start := FRoot;\r\n case GetTraverseOrder of\r\n toPreOrder:\r\n Result := TPreOrderTreeIterator.Create(Self, Start, False, isFirst);\r\n toPostOrder:\r\n begin\r\n if Start <> nil then\r\n while (Start.ChildrenCount > 0) do\r\n Start := TTreeNode(Start.Children[0]);\r\n Result := TPostOrderTreeIterator.Create(Self, Start, False, isFirst);\r\n end;\r\n else\r\n Result := nil;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\n{$IFDEF SUPPORTS_FOR_IN}\r\nfunction TJclTree.GetEnumerator: IJclIterator;\r\nbegin\r\n Result := First;\r\nend;\r\n{$ENDIF SUPPORTS_FOR_IN}\r\n\r\nfunction TJclTree.GetRoot: IJclTreeIterator;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n case GetTraverseOrder of\r\n toPreOrder:\r\n Result := TPreOrderTreeIterator.Create(Self, FRoot, False, isRoot);\r\n toPostOrder:\r\n Result := TPostOrderTreeIterator.Create(Self, FRoot, False, isRoot);\r\n else\r\n Result := nil;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclTree.GetTraverseOrder: TJclTraverseOrder;\r\nbegin\r\n Result := FTraverseOrder;\r\nend;\r\n\r\nfunction TJclTree.IsEmpty: Boolean;\r\nbegin\r\n Result := FSize = 0;\r\nend;\r\n\r\nfunction TJclTree.Last: IJclIterator;\r\nvar\r\n Start: TTreeNode;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Start := FRoot;\r\n case FTraverseOrder of\r\n toPreOrder:\r\n begin\r\n if Start <> nil then\r\n while Start.ChildrenCount > 0 do\r\n Start := TTreeNode(Start.Children[Start.ChildrenCount - 1]);\r\n Result := TPreOrderTreeIterator.Create(Self, Start, False, isLast);\r\n end;\r\n toPostOrder:\r\n Result := TPostOrderTreeIterator.Create(Self, Start, False, isLast);\r\n else\r\n Result := nil;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclTree.NodeContains(ANode: TTreeNode; const AItem: T): Boolean;\r\nvar\r\n Index: Integer;\r\nbegin\r\n Result := ItemsEqual(ANode.Value, AItem);\r\n if not Result then\r\n for Index := 0 to ANode.ChildrenCount - 1 do\r\n begin\r\n Result := NodeContains(TTreeNode(ANode.Children[Index]), AItem);\r\n if Result then\r\n Break;\r\n end;\r\nend;\r\n\r\nprocedure TJclTree.Pack;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FRoot <> nil then\r\n PackNode(FRoot);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclTree.PackNode(ANode: TTreeNode);\r\nvar\r\n Index: Integer;\r\nbegin\r\n SetLength(ANode.Children, ANode.ChildrenCount);\r\n for Index := 0 to ANode.ChildrenCount - 1 do\r\n PackNode(TTreeNode(ANode.Children[Index]));\r\nend;\r\n\r\nfunction TJclTree.Remove(const AItem: T): Boolean;\r\nvar\r\n Extracted: T;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := Extract(AItem);\r\n if Result then\r\n begin\r\n Extracted := AItem;\r\n FreeItem(Extracted);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclTree.RemoveAll(const ACollection: IJclCollection): Boolean;\r\nvar\r\n It: IJclIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n Result := Remove(It.Next) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclTree.RemoveNode(var ANode: TTreeNode);\r\nvar\r\n Index, ChildIndex, NewCapacity: Integer;\r\n Parent: TTreeNode;\r\nbegin\r\n for Index := ANode.ChildrenCount - 1 downto 0 do\r\n {$IFDEF BCB}\r\n RemoveNode(TTreeNode(ANode.Children[Index]));\r\n {$ELSE ~BCB}\r\n RemoveNode(ANode.Children[Index]);\r\n {$ENDIF ~BCB}\r\n FreeItem(ANode.Value);\r\n Parent := ANode.Parent;\r\n if Parent <> nil then\r\n begin\r\n ChildIndex := Parent.IndexOfChild(ANode);\r\n for Index := ChildIndex + 1 to Parent.ChildrenCount - 1 do\r\n Parent.Children[Index - 1] := Parent.Children[Index];\r\n Dec(Parent.ChildrenCount);\r\n NewCapacity := CalcPackCapacity(Length(Parent.Children), Parent.ChildrenCount);\r\n if NewCapacity < Length(Parent.Children) then\r\n SetLength(Parent.Children, NewCapacity);\r\n FreeAndNil(ANode);\r\n end\r\n else\r\n begin\r\n FreeAndNil(ANode);\r\n FRoot := nil;\r\n end;\r\n Dec(FSize);\r\nend;\r\n\r\nfunction TJclTree.RetainAll(const ACollection: IJclCollection): Boolean;\r\nvar\r\n It: IJclIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := First;\r\n while It.HasNext do\r\n if not ACollection.Contains(It.Next) then\r\n It.Remove;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclTree.SetCapacity(Value: Integer);\r\nbegin\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nprocedure TJclTree.SetTraverseOrder(Value: TJclTraverseOrder);\r\nbegin\r\n FTraverseOrder := Value;\r\nend;\r\n\r\nfunction TJclTree.Size: Integer;\r\nbegin\r\n Result := FSize;\r\nend;\r\n\r\n//=== { TJclTreeIterator } ===========================================================\r\n\r\nconstructor TJclTreeIterator.Create(OwnTree: TJclTree; ACursor: TJclTreeNode; AValid: Boolean; AStart: TItrStart);\r\nbegin\r\n inherited Create(AValid);\r\n FCursor := ACursor;\r\n FOwnTree := OwnTree;\r\n FStart := AStart;\r\n FEqualityComparer := OwnTree as IJclEqualityComparer;\r\nend;\r\n\r\nfunction TJclTreeIterator.Add(const AItem: T): Boolean;\r\nvar\r\n ParentNode, NewNode: TJclTreeNode;\r\nbegin\r\n if FOwnTree.ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n // add sibling or, if FCursor is root node, behave like TJclTree.Add\r\n Result := (FCursor <> nil) and (FOwnTree.AllowDefaultElements or not FEqualityComparer.ItemsEqual(AItem, Default(T)))\r\n and ((not FOwnTree.Contains(AItem)) or FOwnTree.CheckDuplicate);\r\n\r\n if Result then\r\n begin\r\n ParentNode := FCursor.Parent;\r\n if ParentNode = nil then\r\n ParentNode := FCursor;\r\n\r\n if ParentNode.ChildrenCount = Length(ParentNode.Children) then\r\n SetLength(ParentNode.Children, FOwnTree.CalcGrowCapacity(Length(ParentNode.Children), ParentNode.ChildrenCount));\r\n if ParentNode.ChildrenCount < Length(ParentNode.Children) then\r\n begin\r\n NewNode := TJclTreeNode.Create;\r\n NewNode.Value := AItem;\r\n NewNode.Parent := ParentNode;\r\n ParentNode.Children[ParentNode.ChildrenCount] := NewNode;\r\n Inc(ParentNode.ChildrenCount);\r\n Inc(FOwnTree.FSize);\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.WriteUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclTreeIterator.AddChild(const AItem: T): Boolean;\r\nvar\r\n NewNode: TJclTreeNode;\r\nbegin\r\n if FOwnTree.ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := (FCursor <> nil) and (FOwnTree.AllowDefaultElements or not FEqualityComparer.ItemsEqual(AItem, Default(T)))\r\n and ((not FOwnTree.Contains(AItem)) or FOwnTree.CheckDuplicate);\r\n\r\n if Result then\r\n begin\r\n if FCursor.ChildrenCount = Length(FCursor.Children) then\r\n SetLength(FCursor.Children, FOwnTree.CalcGrowCapacity(Length(FCursor.Children), FCursor.ChildrenCount));\r\n if FCursor.ChildrenCount < Length(FCursor.Children) then\r\n begin\r\n NewNode := TJclTreeNode.Create;\r\n NewNode.Value := AItem;\r\n NewNode.Parent := FCursor;\r\n FCursor.Children[FCursor.ChildrenCount] := NewNode;\r\n Inc(FCursor.ChildrenCount);\r\n Inc(FOwnTree.FSize);\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.WriteUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclTreeIterator.AssignPropertiesTo(Dest: TJclAbstractIterator);\r\nvar\r\n ADest: TJclTreeIterator;\r\nbegin\r\n inherited AssignPropertiesTo(Dest);\r\n if Dest is TJclTreeIterator then\r\n begin\r\n ADest := TJclTreeIterator(Dest);\r\n ADest.FCursor := FCursor;\r\n ADest.FOwnTree := FOwnTree;\r\n ADest.FEqualityComparer := FEqualityComparer;\r\n ADest.FStart := FStart;\r\n end;\r\nend;\r\n\r\nfunction TJclTreeIterator.ChildrenCount: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FCursor <> nil then\r\n Result := FCursor.ChildrenCount\r\n else\r\n Result := 0;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclTreeIterator.DeleteChild(Index: Integer);\r\nbegin\r\n if FOwnTree.ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if (FCursor <> nil) and (Index >= 0) and (Index < FCursor.ChildrenCount) then\r\n {$IFDEF BCB}\r\n FOwnTree.RemoveNode(TJclTreeNode(FCursor.Children[Index]))\r\n {$ELSE ~BCB}\r\n FOwnTree.RemoveNode(FCursor.Children[Index])\r\n {$ENDIF ~BCB}\r\n else\r\n raise EJclOutOfBoundsError.Create;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.WriteUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclTreeIterator.DeleteChildren;\r\nvar\r\n Index: Integer;\r\nbegin\r\n if FOwnTree.ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FCursor <> nil then\r\n begin\r\n for Index := FCursor.ChildrenCount - 1 downto 0 do\r\n {$IFDEF BCB}\r\n FOwnTree.RemoveNode(TJclTreeNode(FCursor.Children[Index]));\r\n {$ELSE ~BCB}\r\n FOwnTree.RemoveNode(FCursor.Children[Index]);\r\n {$ENDIF ~BCB}\r\n SetLength(FCursor.Children, 0);\r\n FCursor.ChildrenCount := 0;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.WriteUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclTreeIterator.Extract;\r\nvar\r\n OldCursor: TJclTreeNode;\r\nbegin\r\n if FOwnTree.ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n CheckValid;\r\n Valid := False;\r\n OldCursor := FCursor;\r\n FCursor := GetNextSibling;\r\n if OldCursor <> nil then\r\n FOwnTree.ExtractNode(OldCursor);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.WriteUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclTreeIterator.ExtractChild(Index: Integer);\r\nbegin\r\n if FOwnTree.ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if (FCursor <> nil) and (Index >= 0) and (Index < FCursor.ChildrenCount) then\r\n {$IFDEF BCB}\r\n FOwnTree.ExtractNode(TJclTreeNode(FCursor.Children[Index]))\r\n {$ELSE ~BCB}\r\n FOwnTree.ExtractNode(FCursor.Children[Index])\r\n {$ENDIF ~BCB}\r\n else\r\n raise EJclOutOfBoundsError.Create;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.WriteUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclTreeIterator.ExtractChildren;\r\nvar\r\n Index: Integer;\r\nbegin\r\n if FOwnTree.ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FCursor <> nil then\r\n begin\r\n for Index := FCursor.ChildrenCount - 1 downto 0 do\r\n {$IFDEF BCB}\r\n FOwnTree.ExtractNode(TJclTreeNode(FCursor.Children[Index]));\r\n {$ELSE ~BCB}\r\n FOwnTree.ExtractNode(FCursor.Children[Index]);\r\n {$ENDIF ~BCB}\r\n SetLength(FCursor.Children, 0);\r\n FCursor.ChildrenCount := 0;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.WriteUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclTreeIterator.GetChild(Index: Integer): T;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := Default(T);\r\n if (FCursor <> nil) and (Index >= 0) and (Index < FCursor.ChildrenCount) then\r\n FCursor := TJclTreeNode(FCursor.Children[Index]);\r\n if FCursor <> nil then\r\n Result := FCursor.Value\r\n else\r\n if not FOwnTree.ReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclTreeIterator.GetItem: T;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n CheckValid;\r\n Result := Default(T);\r\n if FCursor <> nil then\r\n Result := FCursor.Value\r\n else\r\n if not FOwnTree.ReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclTreeIterator.HasChild(Index: Integer): Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := (FCursor <> nil) and (Index >= 0) and (Index < FCursor.ChildrenCount);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclTreeIterator.HasNext: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Valid then\r\n Result := GetNextCursor <> nil\r\n else\r\n Result := FCursor <> nil;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclTreeIterator.HasParent: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := (FCursor <> nil) and (FCursor.Parent <> nil);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclTreeIterator.HasPrevious: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Valid then\r\n Result := GetPreviousCursor <> nil\r\n else\r\n Result := FCursor <> nil;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclTreeIterator.IndexOfChild(const AItem: T): Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if FCursor <> nil then\r\n Result := FCursor.IndexOfValue(AItem, FEqualityComparer)\r\n else\r\n Result := -1;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclTreeIterator.Insert(const AItem: T): Boolean;\r\nvar\r\n ParentNode, NewNode: TJclTreeNode;\r\n Index, I: Integer;\r\nbegin\r\n if FOwnTree.ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n // insert sibling or, if FCursor is root node, behave like TJclTree.Insert\r\n Result := (FCursor <> nil) and (FOwnTree.AllowDefaultElements or not FEqualityComparer.ItemsEqual(AItem, Default(T)))\r\n and ((not FOwnTree.Contains(AItem)) or FOwnTree.CheckDuplicate);\r\n\r\n if Result then\r\n begin\r\n if FCursor.Parent <> nil then\r\n begin\r\n ParentNode := FCursor.Parent;\r\n Index := 0;\r\n while (Index < ParentNode.ChildrenCount) and (ParentNode.Children[Index] <> FCursor) do\r\n Inc(Index);\r\n end\r\n else\r\n begin\r\n ParentNode := FCursor;\r\n Index := 0;\r\n end;\r\n\r\n if ParentNode.ChildrenCount = Length(ParentNode.Children) then\r\n SetLength(ParentNode.Children, FOwnTree.CalcGrowCapacity(Length(ParentNode.Children), ParentNode.ChildrenCount));\r\n if ParentNode.ChildrenCount < Length(ParentNode.Children) then\r\n begin\r\n NewNode := TJclTreeNode.Create;\r\n NewNode.Value := AItem;\r\n NewNode.Parent := ParentNode;\r\n for I := ParentNode.ChildrenCount - 1 downto Index do\r\n ParentNode.Children[I + 1] := ParentNode.Children[I];\r\n ParentNode.Children[Index] := NewNode;\r\n Inc(ParentNode.ChildrenCount);\r\n Inc(FOwnTree.FSize);\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.WriteUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclTreeIterator.InsertChild(Index: Integer; const AItem: T): Boolean;\r\nvar\r\n NewNode: TJclTreeNode;\r\n I: Integer;\r\nbegin\r\n if FOwnTree.ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n // insert sibling or, if FCursor is root node, behave like TJclTree.Insert\r\n Result := (FCursor <> nil) and (FOwnTree.AllowDefaultElements or not FEqualityComparer.ItemsEqual(AItem, Default(T)))\r\n and ((not FOwnTree.Contains(AItem)) or FOwnTree.CheckDuplicate);\r\n\r\n if Result then\r\n begin\r\n if FCursor.ChildrenCount = Length(FCursor.Children) then\r\n SetLength(FCursor.Children, FOwnTree.CalcGrowCapacity(Length(FCursor.Children), FCursor.ChildrenCount));\r\n if FCursor.ChildrenCount < Length(FCursor.Children) then\r\n begin\r\n NewNode := TJclTreeNode.Create;\r\n NewNode.Value := AItem;\r\n NewNode.Parent := FCursor;\r\n for I := FCursor.ChildrenCount - 1 downto Index do\r\n FCursor.Children[I + 1] := FCursor.Children[I];\r\n FCursor.Children[Index] := NewNode;\r\n Inc(FCursor.ChildrenCount);\r\n Inc(FOwnTree.FSize);\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.WriteUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclTreeIterator.IteratorEquals(const AIterator: IJclIterator): Boolean;\r\nvar\r\n Obj: TObject;\r\n ItrObj: TJclTreeIterator;\r\nbegin\r\n Result := False;\r\n if AIterator = nil then\r\n Exit;\r\n Obj := AIterator.GetIteratorReference;\r\n if Obj is TJclTreeIterator then\r\n begin\r\n ItrObj := TJclTreeIterator(Obj);\r\n Result := (FOwnTree = ItrObj.FOwnTree) and (FCursor = ItrObj.FCursor) and (Valid = ItrObj.Valid);\r\n end;\r\nend;\r\n\r\n{$IFDEF SUPPORTS_FOR_IN}\r\nfunction TJclTreeIterator.MoveNext: Boolean;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Valid then\r\n FCursor := GetNextCursor\r\n else\r\n Valid := True;\r\n Result := FCursor <> nil;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n{$ENDIF SUPPORTS_FOR_IN}\r\n\r\nfunction TJclTreeIterator.Next: T;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Valid then\r\n FCursor := GetNextCursor\r\n else\r\n Valid := True;\r\n Result := Default(T);\r\n if FCursor <> nil then\r\n Result := FCursor.Value\r\n else\r\n if not FOwnTree.ReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclTreeIterator.NextIndex: Integer;\r\nbegin\r\n // No index\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nfunction TJclTreeIterator.Parent: T;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := Default(T);\r\n if FCursor <> nil then\r\n FCursor := FCursor.Parent;\r\n if FCursor <> nil then\r\n Result := FCursor.Value\r\n else\r\n if not FOwnTree.ReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclTreeIterator.Previous: T;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Valid then\r\n FCursor := GetPreviousCursor\r\n else\r\n Valid := True;\r\n Result := Default(T);\r\n if FCursor <> nil then\r\n Result := FCursor.Value\r\n else\r\n if not FOwnTree.ReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create('');\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclTreeIterator.PreviousIndex: Integer;\r\nbegin\r\n // No index\r\n raise EJclOperationNotSupportedError.Create;\r\nend;\r\n\r\nprocedure TJclTreeIterator.Remove;\r\nvar\r\n OldCursor: TJclTreeNode;\r\nbegin\r\n if FOwnTree.ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n CheckValid;\r\n Valid := False;\r\n OldCursor := FCursor;\r\n FCursor := GetNextSibling;\r\n if OldCursor <> nil then\r\n FOwnTree.RemoveNode(OldCursor);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.WriteUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclTreeIterator.Reset;\r\nvar\r\n NewCursor: TJclTreeNode;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.ReadLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Valid := False;\r\n case FStart of\r\n isFirst:\r\n begin\r\n NewCursor := FCursor;\r\n while NewCursor <> nil do\r\n begin\r\n NewCursor := GetPreviousCursor;\r\n if NewCursor <> nil then\r\n FCursor := NewCursor;\r\n end;\r\n end;\r\n isLast:\r\n begin\r\n NewCursor := FCursor;\r\n while NewCursor <> nil do\r\n begin\r\n NewCursor := GetNextCursor;\r\n if NewCursor <> nil then\r\n FCursor := NewCursor;\r\n end;\r\n end;\r\n isRoot:\r\n begin\r\n while (FCursor <> nil) and (FCursor.Parent <> nil) do\r\n FCursor := FCursor.Parent;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.ReadUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclTreeIterator.SetChild(Index: Integer; const AItem: T);\r\nbegin\r\n if FOwnTree.ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if (FCursor <> nil) and (Index >= 0) and (Index < FCursor.ChildrenCount) then\r\n TJclTreeNode(FCursor.Children[Index]).Value := AItem\r\n else\r\n raise EJclOutOfBoundsError.Create;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.WriteUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclTreeIterator.SetItem(const AItem: T);\r\nbegin\r\n if FOwnTree.ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n FOwnTree.WriteLock;\r\n try\r\n {$ENDIF THREADSAFE}\r\n CheckValid;\r\n if FCursor <> nil then\r\n begin\r\n FOwnTree.FreeItem(FCursor.Value);\r\n FCursor.Value := AItem;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n FOwnTree.WriteUnlock;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\n//=== { TJclPreOrderTreeIterator } ===================================================\r\n\r\nfunction TJclPreOrderTreeIterator.CreateEmptyIterator: TJclAbstractIterator;\r\nbegin\r\n Result := TJclPreOrderTreeIterator.Create(FOwnTree, FCursor, Valid, FStart);\r\nend;\r\n\r\nfunction TJclPreOrderTreeIterator.GetNextCursor: TJclTreeNode;\r\nvar\r\n LastRet: TJclTreeNode;\r\nbegin\r\n Result := FCursor;\r\n if Result = nil then\r\n Exit;\r\n LastRet := Result;\r\n if Result.ChildrenCount > 0 then\r\n Result := TJclTreeNode(Result.Children[0])\r\n else\r\n begin\r\n Result := Result.Parent;\r\n while (Result <> nil) and (Result.IndexOfChild(LastRet) = (Result.ChildrenCount - 1)) do\r\n begin\r\n LastRet := Result;\r\n Result := Result.Parent;\r\n end;\r\n if Result <> nil then // not root = return successor\r\n Result := TJclTreeNode(Result.Children[Result.IndexOfChild(LastRet) + 1]);\r\n end;\r\nend;\r\n\r\nfunction TJclPreOrderTreeIterator.GetNextSibling: TJclTreeNode;\r\nvar\r\n LastRet: TJclTreeNode;\r\nbegin\r\n Result := FCursor;\r\n if Result = nil then\r\n Exit;\r\n LastRet := Result;\r\n\r\n Result := Result.Parent;\r\n while (Result <> nil) and (Result.IndexOfChild(LastRet) = (Result.ChildrenCount - 1)) do\r\n begin\r\n LastRet := Result;\r\n Result := Result.Parent;\r\n end;\r\n if Result <> nil then // not root = return successor\r\n Result := TJclTreeNode(Result.Children[Result.IndexOfChild(LastRet) + 1]);\r\nend;\r\n\r\nfunction TJclPreOrderTreeIterator.GetPreviousCursor: TJclTreeNode;\r\nvar\r\n LastRet: TJclTreeNode;\r\nbegin\r\n Result := FCursor;\r\n if Result = nil then\r\n Exit;\r\n LastRet := Result;\r\n Result := Result.Parent;\r\n if (Result <> nil) and (Result.IndexOfChild(LastRet) > 0) then\r\n // come from Right\r\n begin\r\n Result := TJclTreeNode(Result.Children[Result.IndexOfChild(LastRet) - 1]);\r\n while (Result.ChildrenCount > 0) do // descend down the tree\r\n Result := TJclTreeNode(Result.Children[Result.ChildrenCount - 1]);\r\n end;\r\nend;\r\n\r\n//=== { TJclPostOrderTreeIterator } ==================================================\r\n\r\nfunction TJclPostOrderTreeIterator.CreateEmptyIterator: TJclAbstractIterator;\r\nbegin\r\n Result := TJclPostOrderTreeIterator.Create(FOwnTree, FCursor, Valid, FStart);\r\nend;\r\n\r\nfunction TJclPostOrderTreeIterator.GetNextCursor: TJclTreeNode;\r\nvar\r\n LastRet: TJclTreeNode;\r\nbegin\r\n Result := FCursor;\r\n if Result = nil then\r\n Exit;\r\n LastRet := Result;\r\n Result := Result.Parent;\r\n if (Result <> nil) and (Result.IndexOfChild(LastRet) <> (Result.ChildrenCount - 1)) then\r\n begin\r\n Result := TJclTreeNode(Result.Children[Result.IndexOfChild(LastRet) + 1]);\r\n while Result.ChildrenCount > 0 do\r\n Result := TJclTreeNode(Result.Children[0]);\r\n end;\r\nend;\r\n\r\nfunction TJclPostOrderTreeIterator.GetNextSibling: TJclTreeNode;\r\nvar\r\n LastRet: TJclTreeNode;\r\nbegin\r\n Result := FCursor;\r\n if Result = nil then\r\n Exit;\r\n LastRet := Result;\r\n Result := Result.Parent;\r\n\r\n if (Result <> nil) and (Result.IndexOfChild(LastRet) <> (Result.ChildrenCount - 1)) then\r\n begin\r\n Result := TJclTreeNode(Result.Children[Result.IndexOfChild(LastRet) + 1]);\r\n while Result.ChildrenCount > 0 do\r\n Result := TJclTreeNode(Result.Children[0]);\r\n end;\r\nend;\r\n\r\nfunction TJclPostOrderTreeIterator.GetPreviousCursor: TJclTreeNode;\r\nvar\r\n LastRet: TJclTreeNode;\r\nbegin\r\n Result := FCursor;\r\n if Result = nil then\r\n Exit;\r\n if Result.ChildrenCount > 0 then\r\n Result := TJclTreeNode(Result.Children[Result.ChildrenCount - 1])\r\n else\r\n begin\r\n LastRet := Result;\r\n Result := Result.Parent;\r\n while (Result <> nil) and (Result.IndexOfChild(LastRet) = 0) do\r\n begin\r\n LastRet := Result;\r\n Result := Result.Parent;\r\n end;\r\n if Result <> nil then // not root\r\n Result := TJclTreeNode(Result.Children[Result.IndexOfChild(LastRet) - 1]);\r\n end;\r\nend;\r\n\r\n//=== { TJclTreeE } =======================================================\r\n\r\nconstructor TJclTreeE.Create(const AEqualityComparer: IJclEqualityComparer; AOwnsItems: Boolean);\r\nbegin\r\n inherited Create(AOwnsItems);\r\n FEqualityComparer := AEqualityComparer;\r\nend;\r\n\r\nprocedure TJclTreeE.AssignPropertiesTo(Dest: TJclAbstractContainerBase);\r\nbegin\r\n inherited AssignPropertiesTo(Dest);\r\n if Dest is TJclTreeE then\r\n TJclTreeE(Dest).FEqualityComparer := FEqualityComparer;\r\nend;\r\n\r\nfunction TJclTreeE.CreateEmptyContainer: TJclAbstractContainerBase;\r\nbegin\r\n Result := TJclTreeE.Create(EqualityComparer, False);\r\n AssignPropertiesTo(Result);\r\nend;\r\n\r\nfunction TJclTreeE.ItemsEqual(const A, B: T): Boolean;\r\nbegin\r\n if EqualityComparer <> nil then\r\n Result := EqualityComparer.ItemsEqual(A, B)\r\n else\r\n Result := inherited ItemsEqual(A, B);\r\nend;\r\n\r\n//=== { TJclTreeF } =======================================================\r\n\r\nconstructor TJclTreeF.Create(ACompare: TCompare; AOwnsItems: Boolean);\r\nbegin\r\n inherited Create(AOwnsItems);\r\n SetCompare(ACompare);\r\nend;\r\n\r\nfunction TJclTreeF.CreateEmptyContainer: TJclAbstractContainerBase;\r\nbegin\r\n Result := TJclTreeF.Create(Compare, False);\r\n AssignPropertiesTo(Result);\r\nend;\r\n\r\n//=== { TJclTreeI } =======================================================\r\n\r\nfunction TJclTreeI.CreateEmptyContainer: TJclAbstractContainerBase;\r\nbegin\r\n Result := TJclTreeI.Create(False);\r\n AssignPropertiesTo(Result);\r\nend;\r\n\r\nfunction TJclTreeI.ItemsEqual(const A, B: T): Boolean;\r\nbegin\r\n if Assigned(FEqualityCompare) then\r\n Result := FEqualityCompare(A, B)\r\n else\r\n Result := A.Equals(B);\r\nend;\r\n\r\n//DOM-IGNORE-END\r\n{$ENDIF SUPPORTS_GENERICS}\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jcl/source/common/JclUnicode.pas", "content": "{**************************************************************************************************}\r\n{ }\r\n{ Project JEDI Code Library (JCL) }\r\n{ }\r\n{ The contents of this file are subject to the Mozilla Public License Version 1.1 (the \"License\"); }\r\n{ you may not use this file except in compliance with the License. You may obtain a copy of the }\r\n{ License at http://www.mozilla.org/MPL/ }\r\n{ }\r\n{ Software distributed under the License is distributed on an \"AS IS\" basis, WITHOUT WARRANTY OF }\r\n{ ANY KIND, either express or implied. See the License for the specific language governing rights }\r\n{ and limitations under the License. }\r\n{ }\r\n{ The Original Code is JclUnicode.pas. }\r\n{ }\r\n{ The Initial Developer of the Original Code is Mike Lischke (public att lischke-online dott de). }\r\n{ Portions created by Mike Lischke are Copyright (C) 1999-2000 Mike Lischke. All Rights Reserved. }\r\n{ }\r\n{ Contributor(s): }\r\n{ Marcel van Brakel }\r\n{ Andreas Hausladen (ahuser) }\r\n{ Mike Lischke }\r\n{ Flier Lu (flier) }\r\n{ Robert Marquardt (marquardt) }\r\n{ Robert Rossmair (rrossmair) }\r\n{ Olivier Sannier (obones) }\r\n{ Matthias Thoma (mthoma) }\r\n{ Petr Vones (pvones) }\r\n{ Peter Schraut (http://www.console-dev.de) }\r\n{ Florent Ouchet (outchy) }\r\n{ glchapman }\r\n{ }\r\n{**************************************************************************************************}\r\n{ }\r\n{ Various Unicode related routines }\r\n{ }\r\n{**************************************************************************************************}\r\n{ }\r\n{ Last modified: $Date:: 2012-09-04 16:08:04 +0200 (mar. 04 sept. 2012) $ }\r\n{ Revision: $Rev:: 3861 $ }\r\n{ Author: $Author:: outchy $ }\r\n{ }\r\n{**************************************************************************************************}\r\n\r\nunit JclUnicode;\r\n\r\n{$I jcl.inc}\r\n\r\n// Copyright (c) 1999-2000 Mike Lischke (public att lischke-online dott de)\r\n//\r\n\r\n// 10-JUL-2005: (changes by Peter Schraut)\r\n// - added CodeBlockName, returns the blockname as string\r\n// - added CodeBlockRange, returns the range of the specified codeblock\r\n// - updated TUnicodeBlock to reflect changes in unicode 4.1\r\n// - updated CodeBlockFromChar to reflect changes in unicode 4.1\r\n// - Notes:\r\n// Here are a few suggestions to reflect latest namechanges in unicode 4.1,\r\n// but they were not done due to compatibility with old code:\r\n// ubGreek should be renamed to ubGreekandCoptic\r\n// ubCombiningMarksforSymbols should be renamed to ubCombiningDiacriticalMarksforSymbols\r\n// ubPrivateUse should be renamed to ubPrivateUseArea\r\n//\r\n//\r\n// 19-SEP-2003: (changes by Andreas Hausladen)\r\n// - added OWN_WIDESTRING_MEMMGR for faster memory managment in TWideStringList\r\n// under Windows\r\n// - fixed: TWideStringList.Destroy does not set OnChange and OnChanging to nil before calling Clear\r\n//\r\n//\r\n// 29-MAR-2002: MT\r\n// - WideNormalize now returns strings with normalization mode nfNone unchanged.\r\n// - Bug fix in WideCompose: Raised exception when Result of WideComposeHangul was an\r\n// empty string. (#0000044)\r\n// - Bug fix in WideAdjustLineBreaks\r\n// - Added Asserts were needed.\r\n// - TWideStrings.IndexOfName now takes care of NormalizeForm as well.\r\n// - TWideStrings.IndexOf now takes care of NormalizeForm as well.\r\n// - TWideString.List Find now uses the same NormalizationForm for the search string as it uses\r\n// within the list itself.\r\n//\r\n// 29-NOV-2001:\r\n// - bug fix\r\n// 06-JUN-2001:\r\n// - small changes\r\n// 28-APR-2001:\r\n// - bug fixes\r\n// 05-APR-2001:\r\n// - bug fixes\r\n// 23-MAR-2001:\r\n// - WideSameText\r\n// - small changes\r\n// 10-FEB-2001:\r\n// - bug fix in StringToWideStringEx and WideStringToStringEx\r\n// 05-FEB-2001:\r\n// - TWideStrings.GetSeparatedText changed (no separator anymore after the last line)\r\n// 29-JAN-2001:\r\n// - PrepareUnicodeData\r\n// - LoadInProgress critical section is now created at init time to avoid critical thread races\r\n// - bug fixes\r\n// 26-JAN-2001:\r\n// - ExpandANSIString\r\n// - TWideStrings.SaveUnicode is by default True now\r\n// 20..21-JAN-2001:\r\n// - StrUpperW, StrLowerW and StrTitleW removed because they potentially would need\r\n// a reallocation to work correctly (use the WideString versions instead)\r\n// - further improvements related to internal data\r\n// - introduced TUnicodeBlock\r\n// - CodeBlockFromChar improved\r\n// 07-JAN-2001:\r\n// optimized access to character properties, combining class etc.\r\n// 06-JAN-2001:\r\n// TWideStrings and TWideStringList improved\r\n// APR-DEC 2000: versions 2.1 - 2.6\r\n// - preparation for public rlease\r\n// - additional conversion routines\r\n// - JCL compliance\r\n// - character properties unified\r\n// - character properties data and lookup improvements\r\n// - reworked Unicode data resource file\r\n// - improved simple string comparation routines (StrCompW, StrLCompW etc., include surrogate fix)\r\n// - special case folding data for language neutral case insensitive comparations included\r\n// - optimized decomposition\r\n// - composition and normalization support\r\n// - normalization conformance tests applied\r\n// - bug fixes\r\n// FEB-MAR 2000: version 2.0\r\n// - Unicode regular expressions (URE) search class (TURESearch)\r\n// - generic search engine base class for both the Boyer-Moore and the RE search class\r\n// - whole word only search in UTBM, bug fixes in UTBM\r\n// - string decompositon (including hangul)\r\n// OCT/99 - JAN/2000: version 1.0\r\n// - basic Unicode implementation, more than 100 WideString/UCS2 and UCS4 core functions\r\n// - TWideStrings and TWideStringList classes\r\n// - Unicode Tuned Boyer-Moore search class (TUTBMSearch)\r\n// - low and high level Unicode/Wide* functions\r\n// - low level Unicode UCS4 data import and functions\r\n// - helper functions\r\n//\r\n// Version 2.9\r\n// This unit contains routines and classes to manage and work with Unicode/WideString strings.\r\n// You need Delphi 4 or higher to compile this code.\r\n//\r\n// Publicly available low level functions are all preceded by \"Unicode...\" (e.g.\r\n// in UnicodeToUpper) while the high level functions use the Str... or Wide...\r\n// naming scheme (e.g. StrLICompW and WideUpperCase).\r\n//\r\n// The normalization implementation in this unit has successfully and completely passed the\r\n// official normative conformance testing as of Annex 9 in Technical Report #15\r\n// (Unicode Standard Annex #15, http://www.unicode.org/unicode/reports/tr15, from 2000-08-31).\r\n//\r\n// Open issues:\r\n// - Yet to do things in the URE class are:\r\n// - check all character classes if they match correctly\r\n// - optimize rebuild of DFA (build only when pattern changes)\r\n// - set flag parameter of ExecuteURE\r\n// - add \\d any decimal digit\r\n// \\D any character that is not a decimal digit\r\n// \\s any whitespace character\r\n// \\S any character that is not a whitespace character\r\n// \\w any \"word\" character\r\n// \\W any \"non-word\" character\r\n// - The wide string classes still compare text with functions provided by the\r\n// particular system. This works usually fine under WinNT/W2K (although also\r\n// there are limitations like maximum text lengths). Under Win9x conversions\r\n// from and to MBCS are necessary which are bound to a particular locale and\r\n// so very limited in general use. These comparisons should be changed so that\r\n// the code in this unit is used.\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n {$IFDEF HAS_UNITSCOPE}\r\n {$IFDEF MSWINDOWS}\r\n Winapi.Windows,\r\n {$ENDIF MSWINDOWS}\r\n System.SysUtils, System.Classes,\r\n {$IFDEF HAS_UNIT_CHARACTER}\r\n System.Character,\r\n {$ENDIF HAS_UNIT_CHARACTER}\r\n {$ELSE ~HAS_UNITSCOPE}\r\n {$IFDEF MSWINDOWS}\r\n Windows,\r\n {$ENDIF MSWINDOWS}\r\n SysUtils, Classes,\r\n {$IFDEF HAS_UNIT_CHARACTER}\r\n Character,\r\n {$ENDIF HAS_UNIT_CHARACTER}\r\n {$ENDIF ~HAS_UNITSCOPE}\r\n JclBase;\r\n\r\n{$IFNDEF FPC}\r\n {$IFDEF MSWINDOWS}\r\n {$DEFINE OWN_WIDESTRING_MEMMGR}\r\n {$ENDIF MSWINDOWS}\r\n{$ENDIF ~FPC}\r\n\r\nconst\r\n // definitions of often used characters:\r\n // Note: Use them only for tests of a certain character not to determine character\r\n // classes (like white spaces) as in Unicode are often many code points defined\r\n // being in a certain class. Hence your best option is to use the various\r\n // UnicodeIs* functions.\r\n WideNull = WideChar(#0);\r\n WideTabulator = WideChar(#9);\r\n WideSpace = WideChar(#32);\r\n\r\n // logical line breaks\r\n WideLF = WideChar(#10);\r\n WideLineFeed = WideChar(#10);\r\n WideVerticalTab = WideChar(#11);\r\n WideFormFeed = WideChar(#12);\r\n WideCR = WideChar(#13);\r\n WideCarriageReturn = WideChar(#13);\r\n WideCRLF = WideString(#13#10);\r\n WideLineSeparator = WideChar($2028);\r\n WideParagraphSeparator = WideChar($2029);\r\n\r\n // byte order marks for Unicode files\r\n // Unicode text files (in UTF-16 format) should contain $FFFE as first character to\r\n // identify such a file clearly. Depending on the system where the file was created\r\n // on this appears either in big endian or little endian style.\r\n BOM_LSB_FIRST = WideChar($FEFF);\r\n BOM_MSB_FIRST = WideChar($FFFE);\r\n\r\ntype\r\n TSaveFormat = ( sfUTF16LSB, sfUTF16MSB, sfUTF8, sfAnsi );\r\n\r\nconst\r\n sfUnicodeLSB = sfUTF16LSB;\r\n sfUnicodeMSB = sfUTF16MSB;\r\n\r\ntype\r\n // various predefined or otherwise useful character property categories\r\n TCharacterCategory = (\r\n // normative categories\r\n ccLetterUppercase,\r\n ccLetterLowercase,\r\n ccLetterTitlecase,\r\n ccMarkNonSpacing,\r\n ccMarkSpacingCombining,\r\n ccMarkEnclosing,\r\n ccNumberDecimalDigit,\r\n ccNumberLetter,\r\n ccNumberOther,\r\n ccSeparatorSpace,\r\n ccSeparatorLine,\r\n ccSeparatorParagraph,\r\n ccOtherControl,\r\n ccOtherFormat,\r\n ccOtherSurrogate,\r\n ccOtherPrivate,\r\n ccOtherUnassigned,\r\n // informative categories\r\n ccLetterModifier,\r\n ccLetterOther,\r\n ccPunctuationConnector,\r\n ccPunctuationDash,\r\n ccPunctuationOpen,\r\n ccPunctuationClose,\r\n ccPunctuationInitialQuote,\r\n ccPunctuationFinalQuote,\r\n ccPunctuationOther,\r\n ccSymbolMath,\r\n ccSymbolCurrency,\r\n ccSymbolModifier,\r\n ccSymbolOther,\r\n // bidirectional categories\r\n ccLeftToRight,\r\n ccLeftToRightEmbedding,\r\n ccLeftToRightOverride,\r\n ccRightToLeft,\r\n ccRightToLeftArabic,\r\n ccRightToLeftEmbedding,\r\n ccRightToLeftOverride,\r\n ccPopDirectionalFormat,\r\n ccEuropeanNumber,\r\n ccEuropeanNumberSeparator,\r\n ccEuropeanNumberTerminator,\r\n ccArabicNumber,\r\n ccCommonNumberSeparator,\r\n ccBoundaryNeutral,\r\n ccSegmentSeparator, // this includes tab and vertical tab\r\n ccWhiteSpace, // Separator characters and control characters which should be treated by programming languages as \"white space\" for the purpose of parsing elements.\r\n ccOtherNeutrals,\r\n // self defined categories, they do not appear in the Unicode data file\r\n ccComposed, // can be decomposed\r\n ccNonBreaking,\r\n ccSymmetric, // has left and right forms\r\n ccHexDigit, // Characters commonly used for the representation of hexadecimal numbers, plus their compatibility equivalents.\r\n ccQuotationMark, // Punctuation characters that function as quotation marks.\r\n ccMirroring,\r\n ccAssigned, // means there is a definition in the Unicode standard\r\n ccASCIIHexDigit, // ASCII characters commonly used for the representation of hexadecimal numbers\r\n ccBidiControl, // Format control characters which have specific functions in the Unicode Bidirectional Algorithm [UAX9].\r\n ccDash, // Punctuation characters explicitly called out as dashes in the Unicode Standard, plus their compatibility equivalents. Most of these have the General_Category value Pd, but some have the General_Category value Sm because of their use in mathematics.\r\n ccDeprecated, // For a machine-readable list of deprecated characters. No characters will ever be removed from the standard, but the usage of deprecated characters is strongly discouraged.\r\n ccDiacritic, // Characters that linguistically modify the meaning of another character to which they apply. Some diacritics are not combining characters, and some combining characters are not diacritics.\r\n ccExtender, // Characters whose principal function is to extend the value or shape of a preceding alphabetic character. Typical of these are length and iteration marks.\r\n ccHyphen, // Dashes which are used to mark connections between pieces of words, plus the Katakana middle dot. The Katakana middle dot functions like a hyphen, but is shaped like a dot rather than a dash.\r\n ccIdeographic, // Characters considered to be CJKV (Chinese, Japanese, Korean, and Vietnamese) ideographs.\r\n ccIDSBinaryOperator, // Used in Ideographic Description Sequences.\r\n ccIDSTrinaryOperator, // Used in Ideographic Description Sequences.\r\n ccJoinControl, // Format control characters which have specific functions for control of cursive joining and ligation.\r\n ccLogicalOrderException, // There are a small number of characters that do not use logical order. These characters require special handling in most processing.\r\n ccNonCharacterCodePoint, // Code points permanently reserved for internal use.\r\n ccOtherAlphabetic, // Used in deriving the Alphabetic property.\r\n ccOtherDefaultIgnorableCodePoint, // Used in deriving the Default_Ignorable_Code_Point property.\r\n ccOtherGraphemeExtend, // Used in deriving the Grapheme_Extend property.\r\n ccOtherIDContinue, // Used for backward compatibility of ID_Continue.\r\n ccOtherIDStart, // Used for backward compatibility of ID_Start.\r\n ccOtherLowercase, // Used in deriving the Lowercase property.\r\n ccOtherMath, // Used in deriving the Math property.\r\n ccOtherUppercase, // Used in deriving the Uppercase property.\r\n ccPatternSyntax, // Used for pattern syntax as described in UAX #31: Unicode Identifier and Pattern Syntax [UAX31].\r\n ccPatternWhiteSpace,\r\n ccRadical, // Used in Ideographic Description Sequences.\r\n ccSoftDotted, // Characters with a \"soft dot\", like i or j. An accent placed on these characters causes the dot to disappear. An explicit dot above can be added where required, such as in Lithuanian.\r\n ccSTerm, // Sentence Terminal. Used in UAX #29: Unicode Text Segmentation [UAX29].\r\n ccTerminalPunctuation, // Punctuation characters that generally mark the end of textual units.\r\n ccUnifiedIdeograph, // Used in Ideographic Description Sequences.\r\n ccVariationSelector // Indicates characters that are Variation Selectors. For details on the behavior of these characters, see StandardizedVariants.html, Section 16.4, \"Variation Selectors\" in [Unicode], and the Unicode Ideographic Variation Database [UTS37].\r\n );\r\n TCharacterCategories = set of TCharacterCategory;\r\n\r\n{$IFDEF HAS_UNIT_CHARACTER}\r\ntype\r\n TCharacterUnicodeCategory = ccLetterUppercase..ccSymbolOther;\r\n\r\nconst\r\n CharacterCategoryToUnicodeCategory: array [TCharacterUnicodeCategory] of TUnicodeCategory =\r\n ( TUnicodeCategory.ucUppercaseLetter, // ccLetterUppercase\r\n TUnicodeCategory.ucLowercaseLetter, // ccLetterLowercase\r\n TUnicodeCategory.ucTitlecaseLetter, // ccLetterTitlecase\r\n TUnicodeCategory.ucNonSpacingMark, // ccMarkNonSpacing\r\n TUnicodeCategory.ucCombiningMark, // ccMarkSpacingCombining\r\n TUnicodeCategory.ucEnclosingMark, // ccMarkEnclosing\r\n TUnicodeCategory.ucDecimalNumber, // ccNumberDecimalDigit\r\n TUnicodeCategory.ucLetterNumber, // ccNumberLetter\r\n TUnicodeCategory.ucOtherNumber, // ccNumberOther\r\n TUnicodeCategory.ucSpaceSeparator, // ccSeparatorSpace\r\n TUnicodeCategory.ucLineSeparator, // ccSeparatorLine\r\n TUnicodeCategory.ucParagraphSeparator, // ccSeparatorParagraph\r\n TUnicodeCategory.ucControl, // ccOtherControl\r\n TUnicodeCategory.ucFormat, // ccOtherFormat\r\n TUnicodeCategory.ucSurrogate, // ccOtherSurrogate\r\n TUnicodeCategory.ucPrivateUse, // ccOtherPrivate\r\n TUnicodeCategory.ucUnassigned, // ccOtherUnassigned\r\n TUnicodeCategory.ucModifierLetter, // ccLetterModifier\r\n TUnicodeCategory.ucOtherLetter, // ccLetterOther\r\n TUnicodeCategory.ucConnectPunctuation, // ccPunctuationConnector\r\n TUnicodeCategory.ucDashPunctuation, // ccPunctuationDash\r\n TUnicodeCategory.ucOpenPunctuation, // ccPunctuationOpen\r\n TUnicodeCategory.ucClosePunctuation, // ccPunctuationClose\r\n TUnicodeCategory.ucInitialPunctuation, // ccPunctuationInitialQuote\r\n TUnicodeCategory.ucFinalPunctuation, // ccPunctuationFinalQuote\r\n TUnicodeCategory.ucOtherPunctuation, // ccPunctuationOther\r\n TUnicodeCategory.ucMathSymbol, // ccSymbolMath\r\n TUnicodeCategory.ucCurrencySymbol, // ccSymbolCurrency\r\n TUnicodeCategory.ucModifierSymbol, // ccSymbolModifier\r\n TUnicodeCategory.ucOtherSymbol ); // ccSymbolOther\r\n\r\n UnicodeCategoryToCharacterCategory: array [TUnicodeCategory] of TCharacterCategory =\r\n ( ccOtherControl, // ucControl\r\n ccOtherFormat, // ucFormat\r\n ccOtherUnassigned, // ucUnassigned\r\n ccOtherPrivate, // ucPrivateUse\r\n ccOtherSurrogate, // ucSurrogate\r\n ccLetterLowercase, // ucLowercaseLetter\r\n ccLetterModifier, // ucModifierLetter\r\n ccLetterOther, // ucOtherLetter\r\n ccLetterTitlecase, // ucTitlecaseLetter\r\n ccLetterUppercase, // ucUppercaseLetter\r\n ccMarkSpacingCombining, // ucCombiningMark\r\n ccMarkEnclosing, // ucEnclosingMark\r\n ccMarkNonSpacing, // ucNonSpacingMark\r\n ccNumberDecimalDigit, // ucDecimalNumber\r\n ccNumberLetter, // ucLetterNumber\r\n ccNumberOther, // ucOtherNumber\r\n ccPunctuationConnector, // ucConnectPunctuation\r\n ccPunctuationDash, // ucDashPunctuation\r\n ccPunctuationClose, // ucClosePunctuation\r\n ccPunctuationFinalQuote, // ucFinalPunctuation\r\n ccPunctuationInitialQuote, // ucInitialPunctuation\r\n ccPunctuationOther, // ucOtherPunctuation\r\n ccPunctuationOpen, // ucOpenPunctuation\r\n ccSymbolCurrency, // ucCurrencySymbol\r\n ccSymbolModifier, // ucModifierSymbol\r\n ccSymbolMath, // ucMathSymbol\r\n ccSymbolOther, // ucOtherSymbol\r\n ccSeparatorLine, // ucLineSeparator\r\n ccSeparatorParagraph, // ucParagraphSeparator\r\n ccSeparatorSpace ); // ucSpaceSeparator\r\n\r\nfunction CharacterCategoriesToUnicodeCategory(const Categories: TCharacterCategories): TUnicodeCategory;\r\nfunction UnicodeCategoryToCharacterCategories(Category: TUnicodeCategory): TCharacterCategories;\r\n{$ENDIF HAS_UNIT_CHARACTER}\r\n\r\ntype\r\n // four forms of normalization are defined:\r\n TNormalizationForm = (\r\n nfNone, // do not normalize\r\n nfC, // canonical decomposition followed by canonical composition (this is most often used)\r\n nfD, // canonical decomposition\r\n nfKC, // compatibility decomposition followed by a canonical composition\r\n nfKD // compatibility decomposition\r\n );\r\n\r\n // 16 compatibility formatting tags are defined:\r\n TCompatibilityFormattingTag = (\r\n cftCanonical, // default when no CFT is explicited\r\n cftFont, // Font variant (for example, a blackletter form)\r\n cftNoBreak, // No-break version of a space or hyphen\r\n cftInitial, // Initial presentation form (Arabic)\r\n cftMedial, // Medial presentation form (Arabic)\r\n cftFinal, // Final presentation form (Arabic)\r\n cftIsolated, // Isolated presentation form (Arabic)\r\n cftCircle, // Encircled form\r\n cftSuper, // Superscript form\r\n cftSub, // Subscript form\r\n cftVertical, // Vertical layout presentation form\r\n cftWide, // Wide (or zenkaku) compatibility character\r\n cftNarrow, // Narrow (or hankaku) compatibility character\r\n cftSmall, // Small variant form (CNS compatibility)\r\n cftSquare, // CJK squared font variant\r\n cftFraction, // Vulgar fraction form\r\n cftCompat // Otherwise unspecified compatibility character\r\n );\r\n TCompatibilityFormattingTags = set of TCompatibilityFormattingTag;\r\n\r\n // used to hold information about the start and end\r\n // position of a unicodeblock.\r\n TUnicodeBlockRange = record\r\n RangeStart,\r\n RangeEnd: Cardinal;\r\n end;\r\n\r\n // An Unicode block usually corresponds to a particular language script but\r\n // can also represent special characters, musical symbols and the like.\r\n // http://www.unicode.org/Public/5.0.0/ucd/Blocks.txt\r\n TUnicodeBlock = (\r\n ubUndefined,\r\n ubBasicLatin,\r\n ubLatin1Supplement,\r\n ubLatinExtendedA,\r\n ubLatinExtendedB,\r\n ubIPAExtensions,\r\n ubSpacingModifierLetters,\r\n ubCombiningDiacriticalMarks,\r\n ubGreekandCoptic,\r\n ubCyrillic,\r\n ubCyrillicSupplement,\r\n ubArmenian,\r\n ubHebrew,\r\n ubArabic,\r\n ubSyriac,\r\n ubArabicSupplement,\r\n ubThaana,\r\n ubNKo,\r\n ubSamaritan,\r\n ubMandaic,\r\n ubDevanagari,\r\n ubBengali,\r\n ubGurmukhi,\r\n ubGujarati,\r\n ubOriya,\r\n ubTamil,\r\n ubTelugu,\r\n ubKannada,\r\n ubMalayalam,\r\n ubSinhala,\r\n ubThai,\r\n ubLao,\r\n ubTibetan,\r\n ubMyanmar,\r\n ubGeorgian,\r\n ubHangulJamo,\r\n ubEthiopic,\r\n ubEthiopicSupplement,\r\n ubCherokee,\r\n ubUnifiedCanadianAboriginalSyllabics,\r\n ubOgham,\r\n ubRunic,\r\n ubTagalog,\r\n ubHanunoo,\r\n ubBuhid,\r\n ubTagbanwa,\r\n ubKhmer,\r\n ubMongolian,\r\n ubUnifiedCanadianAboriginalSyllabicsExtended,\r\n ubLimbu,\r\n ubTaiLe,\r\n ubNewTaiLue,\r\n ubKhmerSymbols,\r\n ubBuginese,\r\n ubTaiTham,\r\n ubBalinese,\r\n ubSundanese,\r\n ubBatak,\r\n ubLepcha,\r\n ubOlChiki,\r\n ubVedicExtensions,\r\n ubPhoneticExtensions,\r\n ubPhoneticExtensionsSupplement,\r\n ubCombiningDiacriticalMarksSupplement,\r\n ubLatinExtendedAdditional,\r\n ubGreekExtended,\r\n ubGeneralPunctuation,\r\n ubSuperscriptsandSubscripts,\r\n ubCurrencySymbols,\r\n ubCombiningDiacriticalMarksforSymbols,\r\n ubLetterlikeSymbols,\r\n ubNumberForms,\r\n ubArrows,\r\n ubMathematicalOperators,\r\n ubMiscellaneousTechnical,\r\n ubControlPictures,\r\n ubOpticalCharacterRecognition,\r\n ubEnclosedAlphanumerics,\r\n ubBoxDrawing,\r\n ubBlockElements,\r\n ubGeometricShapes,\r\n ubMiscellaneousSymbols,\r\n ubDingbats,\r\n ubMiscellaneousMathematicalSymbolsA,\r\n ubSupplementalArrowsA,\r\n ubBraillePatterns,\r\n ubSupplementalArrowsB,\r\n ubMiscellaneousMathematicalSymbolsB,\r\n ubSupplementalMathematicalOperators,\r\n ubMiscellaneousSymbolsandArrows,\r\n ubGlagolitic,\r\n ubLatinExtendedC,\r\n ubCoptic,\r\n ubGeorgianSupplement,\r\n ubTifinagh,\r\n ubEthiopicExtended,\r\n ubCyrillicExtendedA,\r\n ubSupplementalPunctuation,\r\n ubCJKRadicalsSupplement,\r\n ubKangxiRadicals,\r\n ubIdeographicDescriptionCharacters,\r\n ubCJKSymbolsandPunctuation,\r\n ubHiragana,\r\n ubKatakana,\r\n ubBopomofo,\r\n ubHangulCompatibilityJamo,\r\n ubKanbun,\r\n ubBopomofoExtended,\r\n ubCJKStrokes,\r\n ubKatakanaPhoneticExtensions,\r\n ubEnclosedCJKLettersandMonths,\r\n ubCJKCompatibility,\r\n ubCJKUnifiedIdeographsExtensionA,\r\n ubYijingHexagramSymbols,\r\n ubCJKUnifiedIdeographs,\r\n ubYiSyllables,\r\n ubYiRadicals,\r\n ubLisu,\r\n ubVai,\r\n ubCyrillicExtendedB,\r\n ubBamum,\r\n ubModifierToneLetters,\r\n ubLatinExtendedD,\r\n ubSylotiNagri,\r\n ubCommonIndicNumberForms,\r\n ubPhagsPa,\r\n ubSaurashtra,\r\n ubDevanagariExtended,\r\n ubKayahLi,\r\n ubRejang,\r\n ubHangulJamoExtendedA,\r\n ubJavanese,\r\n ubCham,\r\n ubMyanmarExtendedA,\r\n ubTaiViet,\r\n ubEthiopicExtendedA,\r\n ubMeeteiMayek,\r\n ubHangulSyllables,\r\n ubHangulJamoExtendedB,\r\n ubHighSurrogates,\r\n ubHighPrivateUseSurrogates,\r\n ubLowSurrogates,\r\n ubPrivateUseArea,\r\n ubCJKCompatibilityIdeographs,\r\n ubAlphabeticPresentationForms,\r\n ubArabicPresentationFormsA,\r\n ubVariationSelectors,\r\n ubVerticalForms,\r\n ubCombiningHalfMarks,\r\n ubCJKCompatibilityForms,\r\n ubSmallFormVariants,\r\n ubArabicPresentationFormsB,\r\n ubHalfwidthandFullwidthForms,\r\n ubSpecials,\r\n ubLinearBSyllabary,\r\n ubLinearBIdeograms,\r\n ubAegeanNumbers,\r\n ubAncientGreekNumbers,\r\n ubAncientSymbols,\r\n ubPhaistosDisc,\r\n ubLycian,\r\n ubCarian,\r\n ubOldItalic,\r\n ubGothic,\r\n ubUgaritic,\r\n ubOldPersian,\r\n ubDeseret,\r\n ubShavian,\r\n ubOsmanya,\r\n ubCypriotSyllabary,\r\n ubImperialAramaic,\r\n ubPhoenician,\r\n ubLydian,\r\n ubKharoshthi,\r\n ubOldSouthArabian,\r\n ubAvestan,\r\n ubInscriptionalParthian,\r\n ubInscriptionalPahlavi,\r\n ubOldTurkic,\r\n ubRumiNumeralSymbols,\r\n ubBrahmi,\r\n ubKaithi,\r\n ubCuneiform,\r\n ubCuneiformNumbersAndPunctuation,\r\n ubEgyptianHieroglyphs,\r\n ubBamumSupplement,\r\n ubKanaSupplement,\r\n ubByzantineMusicalSymbols,\r\n ubMusicalSymbols,\r\n ubAncientGreekMusicalNotation,\r\n ubTaiXuanJingSymbols,\r\n ubCountingRodNumerals,\r\n ubMathematicalAlphanumericSymbols,\r\n ubMahjongTiles,\r\n ubDominoTiles,\r\n ubPlayingCards,\r\n ubEnclosedAlphanumericSupplement,\r\n ubEnclosedIdeographicSupplement,\r\n ubMiscellaneousSymbolsAndPictographs,\r\n ubEmoticons,\r\n ubTransportAndMapSymbols,\r\n ubAlchemicalSymbols,\r\n ubCJKUnifiedIdeographsExtensionB,\r\n ubCJKUnifiedIdeographsExtensionC,\r\n ubCJKUnifiedIdeographsExtensionD,\r\n ubCJKCompatibilityIdeographsSupplement,\r\n ubTags,\r\n ubVariationSelectorsSupplement,\r\n ubSupplementaryPrivateUseAreaA,\r\n ubSupplementaryPrivateUseAreaB\r\n );\r\n\r\n TUnicodeBlockData = record\r\n Range: TUnicodeBlockRange;\r\n Name: string;\r\n end;\r\n PUnicodeBlockData = ^TUnicodeBlockData;\r\n\r\nconst\r\n UnicodeBlockData: array [TUnicodeBlock] of TUnicodeBlockData =\r\n ((Range:(RangeStart: $FFFFFFFF; RangeEnd: $0000); Name: 'No-block'),\r\n (Range:(RangeStart: $0000; RangeEnd: $007F); Name: 'Basic Latin'),\r\n (Range:(RangeStart: $0080; RangeEnd: $00FF); Name: 'Latin-1 Supplement'),\r\n (Range:(RangeStart: $0100; RangeEnd: $017F); Name: 'Latin Extended-A'),\r\n (Range:(RangeStart: $0180; RangeEnd: $024F); Name: 'Latin Extended-B'),\r\n (Range:(RangeStart: $0250; RangeEnd: $02AF); Name: 'IPA Extensions'),\r\n (Range:(RangeStart: $02B0; RangeEnd: $02FF); Name: 'Spacing Modifier Letters'),\r\n (Range:(RangeStart: $0300; RangeEnd: $036F); Name: 'Combining Diacritical Marks'),\r\n (Range:(RangeStart: $0370; RangeEnd: $03FF); Name: 'Greek and Coptic'),\r\n (Range:(RangeStart: $0400; RangeEnd: $04FF); Name: 'Cyrillic'),\r\n (Range:(RangeStart: $0500; RangeEnd: $052F); Name: 'Cyrillic Supplement'),\r\n (Range:(RangeStart: $0530; RangeEnd: $058F); Name: 'Armenian'),\r\n (Range:(RangeStart: $0590; RangeEnd: $05FF); Name: 'Hebrew'),\r\n (Range:(RangeStart: $0600; RangeEnd: $06FF); Name: 'Arabic'),\r\n (Range:(RangeStart: $0700; RangeEnd: $074F); Name: 'Syriac'),\r\n (Range:(RangeStart: $0750; RangeEnd: $077F); Name: 'Arabic Supplement'),\r\n (Range:(RangeStart: $0780; RangeEnd: $07BF); Name: 'Thaana'),\r\n (Range:(RangeStart: $07C0; RangeEnd: $07FF); Name: 'NKo'),\r\n (Range:(RangeStart: $0800; RangeEnd: $083F); Name: 'Samaritan'),\r\n (Range:(RangeStart: $0840; RangeEnd: $085F); Name: 'Mandaic'),\r\n (Range:(RangeStart: $0900; RangeEnd: $097F); Name: 'Devanagari'),\r\n (Range:(RangeStart: $0980; RangeEnd: $09FF); Name: 'Bengali'),\r\n (Range:(RangeStart: $0A00; RangeEnd: $0A7F); Name: 'Gurmukhi'),\r\n (Range:(RangeStart: $0A80; RangeEnd: $0AFF); Name: 'Gujarati'),\r\n (Range:(RangeStart: $0B00; RangeEnd: $0B7F); Name: 'Oriya'),\r\n (Range:(RangeStart: $0B80; RangeEnd: $0BFF); Name: 'Tamil'),\r\n (Range:(RangeStart: $0C00; RangeEnd: $0C7F); Name: 'Telugu'),\r\n (Range:(RangeStart: $0C80; RangeEnd: $0CFF); Name: 'Kannada'),\r\n (Range:(RangeStart: $0D00; RangeEnd: $0D7F); Name: 'Malayalam'),\r\n (Range:(RangeStart: $0D80; RangeEnd: $0DFF); Name: 'Sinhala'),\r\n (Range:(RangeStart: $0E00; RangeEnd: $0E7F); Name: 'Thai'),\r\n (Range:(RangeStart: $0E80; RangeEnd: $0EFF); Name: 'Lao'),\r\n (Range:(RangeStart: $0F00; RangeEnd: $0FFF); Name: 'Tibetan'),\r\n (Range:(RangeStart: $1000; RangeEnd: $109F); Name: 'Myanmar'),\r\n (Range:(RangeStart: $10A0; RangeEnd: $10FF); Name: 'Georgian'),\r\n (Range:(RangeStart: $1100; RangeEnd: $11FF); Name: 'Hangul Jamo'),\r\n (Range:(RangeStart: $1200; RangeEnd: $137F); Name: 'Ethiopic'),\r\n (Range:(RangeStart: $1380; RangeEnd: $139F); Name: 'Ethiopic Supplement'),\r\n (Range:(RangeStart: $13A0; RangeEnd: $13FF); Name: 'Cherokee'),\r\n (Range:(RangeStart: $1400; RangeEnd: $167F); Name: 'Unified Canadian Aboriginal Syllabics'),\r\n (Range:(RangeStart: $1680; RangeEnd: $169F); Name: 'Ogham'),\r\n (Range:(RangeStart: $16A0; RangeEnd: $16FF); Name: 'Runic'),\r\n (Range:(RangeStart: $1700; RangeEnd: $171F); Name: 'Tagalog'),\r\n (Range:(RangeStart: $1720; RangeEnd: $173F); Name: 'Hanunoo'),\r\n (Range:(RangeStart: $1740; RangeEnd: $175F); Name: 'Buhid'),\r\n (Range:(RangeStart: $1760; RangeEnd: $177F); Name: 'Tagbanwa'),\r\n (Range:(RangeStart: $1780; RangeEnd: $17FF); Name: 'Khmer'),\r\n (Range:(RangeStart: $1800; RangeEnd: $18AF); Name: 'Mongolian'),\r\n (Range:(RangeStart: $18B0; RangeEnd: $18FF); Name: 'Unified Canadian Aboriginal Syllabics Extended'),\r\n (Range:(RangeStart: $1900; RangeEnd: $194F); Name: 'Limbu'),\r\n (Range:(RangeStart: $1950; RangeEnd: $197F); Name: 'Tai Le'),\r\n (Range:(RangeStart: $1980; RangeEnd: $19DF); Name: 'New Tai Lue'),\r\n (Range:(RangeStart: $19E0; RangeEnd: $19FF); Name: 'Khmer Symbols'),\r\n (Range:(RangeStart: $1A00; RangeEnd: $1A1F); Name: 'Buginese'),\r\n (Range:(RangeStart: $1A20; RangeEnd: $1AAF); Name: 'Tai Tham'),\r\n (Range:(RangeStart: $1B00; RangeEnd: $1B7F); Name: 'Balinese'),\r\n (Range:(RangeStart: $1B80; RangeEnd: $1BBF); Name: 'Sundanese'),\r\n (Range:(RangeStart: $1BC0; RangeEnd: $1BFF); Name: 'Batak'),\r\n (Range:(RangeStart: $1C00; RangeEnd: $1C4F); Name: 'Lepcha'),\r\n (Range:(RangeStart: $1C50; RangeEnd: $1C7F); Name: 'Ol Chiki'),\r\n (Range:(RangeStart: $1CD0; RangeEnd: $1CFF); Name: 'Vedic Extensions'),\r\n (Range:(RangeStart: $1D00; RangeEnd: $1D7F); Name: 'Phonetic Extensions'),\r\n (Range:(RangeStart: $1D80; RangeEnd: $1DBF); Name: 'Phonetic Extensions Supplement'),\r\n (Range:(RangeStart: $1DC0; RangeEnd: $1DFF); Name: 'Combining Diacritical Marks Supplement'),\r\n (Range:(RangeStart: $1E00; RangeEnd: $1EFF); Name: 'Latin Extended Additional'),\r\n (Range:(RangeStart: $1F00; RangeEnd: $1FFF); Name: 'Greek Extended'),\r\n (Range:(RangeStart: $2000; RangeEnd: $206F); Name: 'General Punctuation'),\r\n (Range:(RangeStart: $2070; RangeEnd: $209F); Name: 'Superscripts and Subscripts'),\r\n (Range:(RangeStart: $20A0; RangeEnd: $20CF); Name: 'Currency Symbols'),\r\n (Range:(RangeStart: $20D0; RangeEnd: $20FF); Name: 'Combining Diacritical Marks for Symbols'),\r\n (Range:(RangeStart: $2100; RangeEnd: $214F); Name: 'Letterlike Symbols'),\r\n (Range:(RangeStart: $2150; RangeEnd: $218F); Name: 'Number Forms'),\r\n (Range:(RangeStart: $2190; RangeEnd: $21FF); Name: 'Arrows'),\r\n (Range:(RangeStart: $2200; RangeEnd: $22FF); Name: 'Mathematical Operators'),\r\n (Range:(RangeStart: $2300; RangeEnd: $23FF); Name: 'Miscellaneous Technical'),\r\n (Range:(RangeStart: $2400; RangeEnd: $243F); Name: 'Control Pictures'),\r\n (Range:(RangeStart: $2440; RangeEnd: $245F); Name: 'Optical Character Recognition'),\r\n (Range:(RangeStart: $2460; RangeEnd: $24FF); Name: 'Enclosed Alphanumerics'),\r\n (Range:(RangeStart: $2500; RangeEnd: $257F); Name: 'Box Drawing'),\r\n (Range:(RangeStart: $2580; RangeEnd: $259F); Name: 'Block Elements'),\r\n (Range:(RangeStart: $25A0; RangeEnd: $25FF); Name: 'Geometric Shapes'),\r\n (Range:(RangeStart: $2600; RangeEnd: $26FF); Name: 'Miscellaneous Symbols'),\r\n (Range:(RangeStart: $2700; RangeEnd: $27BF); Name: 'Dingbats'),\r\n (Range:(RangeStart: $27C0; RangeEnd: $27EF); Name: 'Miscellaneous Mathematical Symbols-A'),\r\n (Range:(RangeStart: $27F0; RangeEnd: $27FF); Name: 'Supplemental Arrows-A'),\r\n (Range:(RangeStart: $2800; RangeEnd: $28FF); Name: 'Braille Patterns'),\r\n (Range:(RangeStart: $2900; RangeEnd: $297F); Name: 'Supplemental Arrows-B'),\r\n (Range:(RangeStart: $2980; RangeEnd: $29FF); Name: 'Miscellaneous Mathematical Symbols-B'),\r\n (Range:(RangeStart: $2A00; RangeEnd: $2AFF); Name: 'Supplemental Mathematical Operators'),\r\n (Range:(RangeStart: $2B00; RangeEnd: $2BFF); Name: 'Miscellaneous Symbols and Arrows'),\r\n (Range:(RangeStart: $2C00; RangeEnd: $2C5F); Name: 'Glagolitic'),\r\n (Range:(RangeStart: $2C60; RangeEnd: $2C7F); Name: 'Latin Extended-C'),\r\n (Range:(RangeStart: $2C80; RangeEnd: $2CFF); Name: 'Coptic'),\r\n (Range:(RangeStart: $2D00; RangeEnd: $2D2F); Name: 'Georgian Supplement'),\r\n (Range:(RangeStart: $2D30; RangeEnd: $2D7F); Name: 'Tifinagh'),\r\n (Range:(RangeStart: $2D80; RangeEnd: $2DDF); Name: 'Ethiopic Extended'),\r\n (Range:(RangeStart: $2DE0; RangeEnd: $2DFF); Name: 'Cyrillic Extended-A'),\r\n (Range:(RangeStart: $2E00; RangeEnd: $2E7F); Name: 'Supplemental Punctuation'),\r\n (Range:(RangeStart: $2E80; RangeEnd: $2EFF); Name: 'CJK Radicals Supplement'),\r\n (Range:(RangeStart: $2F00; RangeEnd: $2FDF); Name: 'Kangxi Radicals'),\r\n (Range:(RangeStart: $2FF0; RangeEnd: $2FFF); Name: 'Ideographic Description Characters'),\r\n (Range:(RangeStart: $3000; RangeEnd: $303F); Name: 'CJK Symbols and Punctuation'),\r\n (Range:(RangeStart: $3040; RangeEnd: $309F); Name: 'Hiragana'),\r\n (Range:(RangeStart: $30A0; RangeEnd: $30FF); Name: 'Katakana'),\r\n (Range:(RangeStart: $3100; RangeEnd: $312F); Name: 'Bopomofo'),\r\n (Range:(RangeStart: $3130; RangeEnd: $318F); Name: 'Hangul Compatibility Jamo'),\r\n (Range:(RangeStart: $3190; RangeEnd: $319F); Name: 'Kanbun'),\r\n (Range:(RangeStart: $31A0; RangeEnd: $31BF); Name: 'Bopomofo Extended'),\r\n (Range:(RangeStart: $31C0; RangeEnd: $31EF); Name: 'CJK Strokes'),\r\n (Range:(RangeStart: $31F0; RangeEnd: $31FF); Name: 'Katakana Phonetic Extensions'),\r\n (Range:(RangeStart: $3200; RangeEnd: $32FF); Name: 'Enclosed CJK Letters and Months'),\r\n (Range:(RangeStart: $3300; RangeEnd: $33FF); Name: 'CJK Compatibility'),\r\n (Range:(RangeStart: $3400; RangeEnd: $4DBF); Name: 'CJK Unified Ideographs Extension A'),\r\n (Range:(RangeStart: $4DC0; RangeEnd: $4DFF); Name: 'Yijing Hexagram Symbols'),\r\n (Range:(RangeStart: $4E00; RangeEnd: $9FFF); Name: 'CJK Unified Ideographs'),\r\n (Range:(RangeStart: $A000; RangeEnd: $A48F); Name: 'Yi Syllables'),\r\n (Range:(RangeStart: $A490; RangeEnd: $A4CF); Name: 'Yi Radicals'),\r\n (Range:(RangeStart: $A4D0; RangeEnd: $A4FF); Name: 'Lisu'),\r\n (Range:(RangeStart: $A500; RangeEnd: $A63F); Name: 'Vai'),\r\n (Range:(RangeStart: $A640; RangeEnd: $A69F); Name: 'Cyrillic Extended-B'),\r\n (Range:(RangeStart: $A6A0; RangeEnd: $A6FF); Name: 'Bamum'),\r\n (Range:(RangeStart: $A700; RangeEnd: $A71F); Name: 'Modifier Tone Letters'),\r\n (Range:(RangeStart: $A720; RangeEnd: $A7FF); Name: 'Latin Extended-D'),\r\n (Range:(RangeStart: $A800; RangeEnd: $A82F); Name: 'Syloti Nagri'),\r\n (Range:(RangeStart: $A830; RangeEnd: $A83F); Name: 'Common Indic Number Forms'),\r\n (Range:(RangeStart: $A840; RangeEnd: $A87F); Name: 'Phags-pa'),\r\n (Range:(RangeStart: $A880; RangeEnd: $A8DF); Name: 'Saurashtra'),\r\n (Range:(RangeStart: $A8E0; RangeEnd: $A8FF); Name: 'Devanagari Extended'),\r\n (Range:(RangeStart: $A900; RangeEnd: $A92F); Name: 'Kayah Li'),\r\n (Range:(RangeStart: $A930; RangeEnd: $A95F); Name: 'Rejang'),\r\n (Range:(RangeStart: $A960; RangeEnd: $A97F); Name: 'Hangul Jamo Extended-A'),\r\n (Range:(RangeStart: $A980; RangeEnd: $A9DF); Name: 'Javanese'),\r\n (Range:(RangeStart: $AA00; RangeEnd: $AA5F); Name: 'Cham'),\r\n (Range:(RangeStart: $AA60; RangeEnd: $AA7F); Name: 'Myanmar Extended-A'),\r\n (Range:(RangeStart: $AA80; RangeEnd: $AADF); Name: 'Tai Viet'),\r\n (Range:(RangeStart: $AB00; RangeEnd: $AB2F); Name: 'Ethiopic Extended-A'),\r\n (Range:(RangeStart: $ABC0; RangeEnd: $ABFF); Name: 'Meetei Mayek'),\r\n (Range:(RangeStart: $AC00; RangeEnd: $D7AF); Name: 'Hangul Syllables'),\r\n (Range:(RangeStart: $D7B0; RangeEnd: $D7FF); Name: 'Hangul Jamo Extended-B'),\r\n (Range:(RangeStart: $D800; RangeEnd: $DB7F); Name: 'High Surrogates'),\r\n (Range:(RangeStart: $DB80; RangeEnd: $DBFF); Name: 'High Private Use Surrogates'),\r\n (Range:(RangeStart: $DC00; RangeEnd: $DFFF); Name: 'Low Surrogates'),\r\n (Range:(RangeStart: $E000; RangeEnd: $F8FF); Name: 'Private Use Area'),\r\n (Range:(RangeStart: $F900; RangeEnd: $FAFF); Name: 'CJK Compatibility Ideographs'),\r\n (Range:(RangeStart: $FB00; RangeEnd: $FB4F); Name: 'Alphabetic Presentation Forms'),\r\n (Range:(RangeStart: $FB50; RangeEnd: $FDFF); Name: 'Arabic Presentation Forms-A'),\r\n (Range:(RangeStart: $FE00; RangeEnd: $FE0F); Name: 'Variation Selectors'),\r\n (Range:(RangeStart: $FE10; RangeEnd: $FE1F); Name: 'Vertical Forms'),\r\n (Range:(RangeStart: $FE20; RangeEnd: $FE2F); Name: 'Combining Half Marks'),\r\n (Range:(RangeStart: $FE30; RangeEnd: $FE4F); Name: 'CJK Compatibility Forms'),\r\n (Range:(RangeStart: $FE50; RangeEnd: $FE6F); Name: 'Small Form Variants'),\r\n (Range:(RangeStart: $FE70; RangeEnd: $FEFF); Name: 'Arabic Presentation Forms-B'),\r\n (Range:(RangeStart: $FF00; RangeEnd: $FFEF); Name: 'Halfwidth and Fullwidth Forms'),\r\n (Range:(RangeStart: $FFF0; RangeEnd: $FFFF); Name: 'Specials'),\r\n (Range:(RangeStart: $10000; RangeEnd: $1007F); Name: 'Linear B Syllabary'),\r\n (Range:(RangeStart: $10080; RangeEnd: $100FF); Name: 'Linear B Ideograms'),\r\n (Range:(RangeStart: $10100; RangeEnd: $1013F); Name: 'Aegean Numbers'),\r\n (Range:(RangeStart: $10140; RangeEnd: $1018F); Name: 'Ancient Greek Numbers'),\r\n (Range:(RangeStart: $10190; RangeEnd: $101CF); Name: 'Ancient Symbols'),\r\n (Range:(RangeStart: $101D0; RangeEnd: $101FF); Name: 'Phaistos Disc'),\r\n (Range:(RangeStart: $10280; RangeEnd: $1029F); Name: 'Lycian'),\r\n (Range:(RangeStart: $102A0; RangeEnd: $102DF); Name: 'Carian'),\r\n (Range:(RangeStart: $10300; RangeEnd: $1032F); Name: 'Old Italic'),\r\n (Range:(RangeStart: $10330; RangeEnd: $1034F); Name: 'Gothic'),\r\n (Range:(RangeStart: $10380; RangeEnd: $1039F); Name: 'Ugaritic'),\r\n (Range:(RangeStart: $103A0; RangeEnd: $103DF); Name: 'Old Persian'),\r\n (Range:(RangeStart: $10400; RangeEnd: $1044F); Name: 'Deseret'),\r\n (Range:(RangeStart: $10450; RangeEnd: $1047F); Name: 'Shavian'),\r\n (Range:(RangeStart: $10480; RangeEnd: $104AF); Name: 'Osmanya'),\r\n (Range:(RangeStart: $10800; RangeEnd: $1083F); Name: 'Cypriot Syllabary'),\r\n (Range:(RangeStart: $10840; RangeEnd: $1085F); Name: 'Imperial Aramaic'),\r\n (Range:(RangeStart: $10900; RangeEnd: $1091F); Name: 'Phoenician'),\r\n (Range:(RangeStart: $10920; RangeEnd: $1093F); Name: 'Lydian'),\r\n (Range:(RangeStart: $10A00; RangeEnd: $10A5F); Name: 'Kharoshthi'),\r\n (Range:(RangeStart: $10A60; RangeEnd: $10A7F); Name: 'Old South Arabian'),\r\n (Range:(RangeStart: $10B00; RangeEnd: $10B3F); Name: 'Avestan'),\r\n (Range:(RangeStart: $10B40; RangeEnd: $10B5F); Name: 'Inscriptional Parthian'),\r\n (Range:(RangeStart: $10B60; RangeEnd: $10B7F); Name: 'Inscriptional Pahlavi'),\r\n (Range:(RangeStart: $10C00; RangeEnd: $10C4F); Name: 'Old Turkic'),\r\n (Range:(RangeStart: $10E60; RangeEnd: $10E7F); Name: 'Rumi Numeral Symbols'),\r\n (Range:(RangeStart: $11000; RangeEnd: $1107F); Name: 'Brahmi'),\r\n (Range:(RangeStart: $11080; RangeEnd: $110CF); Name: 'Kaithi'),\r\n (Range:(RangeStart: $12000; RangeEnd: $123FF); Name: 'Cuneiform'),\r\n (Range:(RangeStart: $12400; RangeEnd: $1247F); Name: 'Cuneiform Numbers and Punctuation'),\r\n (Range:(RangeStart: $13000; RangeEnd: $1342F); Name: 'Egyptian Hieroglyphs'),\r\n (Range:(RangeStart: $16800; RangeEnd: $16A3F); Name: 'Bamum Supplement'),\r\n (Range:(RangeStart: $1B000; RangeEnd: $1B0FF); Name: 'Kana Supplement'),\r\n (Range:(RangeStart: $1D000; RangeEnd: $1D0FF); Name: 'Byzantine Musical Symbols'),\r\n (Range:(RangeStart: $1D100; RangeEnd: $1D1FF); Name: 'Musical Symbols'),\r\n (Range:(RangeStart: $1D200; RangeEnd: $1D24F); Name: 'Ancient Greek Musical Notation'),\r\n (Range:(RangeStart: $1D300; RangeEnd: $1D35F); Name: 'Tai Xuan Jing Symbols'),\r\n (Range:(RangeStart: $1D360; RangeEnd: $1D37F); Name: 'Counting Rod Numerals'),\r\n (Range:(RangeStart: $1D400; RangeEnd: $1D7FF); Name: 'Mathematical Alphanumeric Symbols'),\r\n (Range:(RangeStart: $1F000; RangeEnd: $1F02F); Name: 'Mahjong Tiles'),\r\n (Range:(RangeStart: $1F030; RangeEnd: $1F09F); Name: 'Domino Tiles'),\r\n (Range:(RangeStart: $1F0A0; RangeEnd: $1F0FF); Name: 'Playing Cards'),\r\n (Range:(RangeStart: $1F100; RangeEnd: $1F1FF); Name: 'Enclosed Alphanumeric Supplement'),\r\n (Range:(RangeStart: $1F200; RangeEnd: $1F2FF); Name: 'Enclosed Ideographic Supplement'),\r\n (Range:(RangeStart: $1F300; RangeEnd: $1F5FF); Name: 'Miscellaneous Symbols And Pictographs'),\r\n (Range:(RangeStart: $1F600; RangeEnd: $1F64F); Name: 'Emoticons'),\r\n (Range:(RangeStart: $1F680; RangeEnd: $1F6FF); Name: 'Transport And Map Symbols'),\r\n (Range:(RangeStart: $1F700; RangeEnd: $1F77F); Name: 'Alchemical Symbols'),\r\n (Range:(RangeStart: $20000; RangeEnd: $2A6DF); Name: 'CJK Unified Ideographs Extension B'),\r\n (Range:(RangeStart: $2A700; RangeEnd: $2B73F); Name: 'CJK Unified Ideographs Extension C'),\r\n (Range:(RangeStart: $2B740; RangeEnd: $2B81F); Name: 'CJK Unified Ideographs Extension D'),\r\n (Range:(RangeStart: $2F800; RangeEnd: $2FA1F); Name: 'CJK Compatibility Ideographs Supplement'),\r\n (Range:(RangeStart: $E0000; RangeEnd: $E007F); Name: 'Tags'),\r\n (Range:(RangeStart: $E0100; RangeEnd: $E01EF); Name: 'Variation Selectors Supplement'),\r\n (Range:(RangeStart: $F0000; RangeEnd: $FFFFF); Name: 'Supplementary Private Use Area-A'),\r\n (Range:(RangeStart: $100000; RangeEnd: $10FFFF); Name: 'Supplementary Private Use Area-B'));\r\n\r\n{$IFNDEF UNICODE_RTL_DATABASE}\r\n\r\ntype\r\n TWideStrings = class;\r\n\r\n TSearchFlag = (\r\n sfCaseSensitive, // match letter case\r\n sfIgnoreNonSpacing, // ignore non-spacing characters in search\r\n sfSpaceCompress, // handle several consecutive white spaces as one white space\r\n // (this applies to the pattern as well as the search text)\r\n sfWholeWordOnly // match only text at end/start and/or surrounded by white spaces\r\n );\r\n\r\n TSearchFlags = set of TSearchFlag;\r\n\r\n // a generic search class defininition used for tuned Boyer-Moore and Unicode\r\n // regular expression searches\r\n TSearchEngine = class(TObject)\r\n private\r\n FResults: TList; // 2 entries for each result (start and stop position)\r\n FOwner: TWideStrings; // at the moment unused, perhaps later to access strings faster\r\n protected\r\n function GetCount: SizeInt; virtual;\r\n public\r\n constructor Create(AOwner: TWideStrings); virtual;\r\n destructor Destroy; override;\r\n\r\n procedure AddResult(Start, Stop: SizeInt); virtual;\r\n procedure Clear; virtual;\r\n procedure ClearResults; virtual;\r\n procedure DeleteResult(Index: SizeInt); virtual;\r\n procedure FindPrepare(const Pattern: WideString; Options: TSearchFlags); overload; virtual; abstract;\r\n procedure FindPrepare(Pattern: PWideChar; PatternLength: SizeInt; Options: TSearchFlags); overload; virtual; abstract;\r\n function FindFirst(const Text: WideString; var Start, Stop: SizeInt): Boolean; overload; virtual; abstract;\r\n function FindFirst(Text: PWideChar; TextLen: SizeInt; var Start, Stop: SizeInt): Boolean; overload; virtual; abstract;\r\n function FindAll(const Text: WideString): Boolean; overload; virtual; abstract;\r\n function FindAll(Text: PWideChar; TextLen: SizeInt): Boolean; overload; virtual; abstract;\r\n procedure GetResult(Index: SizeInt; var Start, Stop: SizeInt); virtual;\r\n\r\n property Count: SizeInt read GetCount;\r\n end;\r\n\r\n // The Unicode Tuned Boyer-Moore (UTBM) search implementation is an extended\r\n // translation created from a free package written by Mark Leisher (mleisher att crl dott nmsu dott edu).\r\n //\r\n // The code handles high and low surrogates as well as case (in)dependency,\r\n // can ignore non-spacing characters and allows optionally to return whole\r\n // words only.\r\n\r\n // single pattern character\r\n PUTBMChar = ^TUTBMChar;\r\n TUTBMChar = record\r\n LoCase,\r\n UpCase,\r\n TitleCase: UCS4;\r\n end;\r\n\r\n PUTBMSkip = ^TUTBMSkip;\r\n TUTBMSkip = record\r\n BMChar: PUTBMChar;\r\n SkipValues: Integer;\r\n end;\r\n\r\n TUTBMSearch = class(TSearchEngine)\r\n private\r\n FFlags: TSearchFlags;\r\n FPattern: PUTBMChar;\r\n FPatternUsed: SizeInt;\r\n FPatternSize: SizeInt;\r\n FPatternLength: SizeInt;\r\n FSkipValues: PUTBMSkip;\r\n FSkipsUsed: SizeInt;\r\n FMD4: SizeInt;\r\n protected\r\n procedure ClearPattern;\r\n procedure Compile(Pattern: PUCS2; PatternLength: SizeInt; Flags: TSearchFlags);\r\n function Find(Text: PUCS2; TextLen: SizeInt; var MatchStart, MatchEnd: SizeInt): Boolean;\r\n function GetSkipValue(TextStart, TextEnd: PUCS2): SizeInt;\r\n function Match(Text, Start, Stop: PUCS2; var MatchStart, MatchEnd: SizeInt): Boolean;\r\n public\r\n procedure Clear; override;\r\n procedure FindPrepare(const Pattern: WideString; Options: TSearchFlags); overload; override;\r\n procedure FindPrepare(Pattern: PWideChar; PatternLength: SizeInt; Options: TSearchFlags); overload; override;\r\n function FindFirst(const Text: WideString; var Start, Stop: SizeInt): Boolean; overload; override;\r\n function FindFirst(Text: PWideChar; TextLen: SizeInt; var Start, Stop: SizeInt): Boolean; overload; override;\r\n function FindAll(const Text: WideString): Boolean; overload; override;\r\n function FindAll(Text: PWideChar; TextLen: SizeInt): Boolean; overload; override;\r\n end;\r\n\r\n // Regular expression search engine for text in UCS2 form taking surrogates\r\n // into account. This implementation is an improved translation from the URE\r\n // package written by Mark Leisher (mleisher att crl dott nmsu dott edu) who used a variation\r\n // of the RE->DFA algorithm done by Mark Hopkins (markh att csd4 dott csd dott uwm dott edu).\r\n // Assumptions:\r\n // o Regular expression and text already normalized.\r\n // o Conversion to lower case assumes a 1-1 mapping.\r\n //\r\n // Definitions:\r\n // Separator - any one of U+2028, U+2029, NL, CR.\r\n //\r\n // Operators:\r\n // . - match any character\r\n // * - match zero or more of the last subexpression\r\n // + - match one or more of the last subexpression\r\n // ? - match zero or one of the last subexpression\r\n // () - subexpression grouping\r\n // {m, n} - match at least m occurences and up to n occurences\r\n // Note: both values can be 0 or ommitted which denotes then a unlimiting bound\r\n // {,} and {0,} and {0, 0} correspond to *\r\n // {, 1} and {0, 1} correspond to ?\r\n // {1,} and {1, 0} correspond to +\r\n // {m} - match exactly m occurences\r\n //\r\n // Notes:\r\n // o The \".\" operator normally does not match separators, but a flag is\r\n // available that will allow this operator to match a separator.\r\n //\r\n // Literals and Constants:\r\n // c - literal UCS2 character\r\n // \\x.... - hexadecimal number of up to 4 digits\r\n // \\X.... - hexadecimal number of up to 4 digits\r\n // \\u.... - hexadecimal number of up to 4 digits\r\n // \\U.... - hexadecimal number of up to 4 digits\r\n //\r\n // Character classes:\r\n // [...] - Character class\r\n // [^...] - Negated character class\r\n // \\pN1,N2,...,Nn - Character properties class\r\n // \\PN1,N2,...,Nn - Negated character properties class\r\n //\r\n // POSIX character classes recognized:\r\n // :alnum:\r\n // :alpha:\r\n // :cntrl:\r\n // :digit:\r\n // :graph:\r\n // :lower:\r\n // :print:\r\n // :punct:\r\n // :space:\r\n // :upper:\r\n // :xdigit:\r\n //\r\n // Notes:\r\n // o Character property classes are \\p or \\P followed by a comma separated\r\n // list of integers between 0 and the maximum entry index in TCharacterCategory.\r\n // These integers directly correspond to the TCharacterCategory enumeration entries.\r\n // Note: upper, lower and title case classes need to have case sensitive search\r\n // be enabled to match correctly!\r\n //\r\n // o Character classes can contain literals, constants and character\r\n // property classes. Example:\r\n //\r\n // [abc\\U10A\\p0,13,4]\r\n\r\n // structure used to handle a compacted range of characters\r\n PUcRange = ^TUcRange;\r\n TUcRange = record\r\n MinCode,\r\n MaxCode: UCS4;\r\n end;\r\n\r\n TUcCClass = record\r\n Ranges: array of TUcRange;\r\n RangesUsed: SizeInt;\r\n end;\r\n\r\n // either a single character or a list of character classes\r\n TUcSymbol = record\r\n Chr: UCS4;\r\n CCL: TUcCClass;\r\n end;\r\n\r\n // this is a general element structure used for expressions and stack elements\r\n TUcElement = record\r\n OnStack: Boolean;\r\n AType,\r\n LHS,\r\n RHS: SizeInt;\r\n end;\r\n\r\n // this is a structure used to track a list or a stack of states\r\n PUcStateList = ^TUcStateList;\r\n TUcStateList = record\r\n List: array of SizeInt;\r\n ListUsed: SizeInt;\r\n end;\r\n\r\n // structure to track the list of unique states for a symbol during reduction\r\n PUcSymbolTableEntry = ^TUcSymbolTableEntry;\r\n TUcSymbolTableEntry = record\r\n ID,\r\n AType: SizeInt;\r\n Mods,\r\n Categories: TCharacterCategories;\r\n Symbol: TUcSymbol;\r\n States: TUcStateList;\r\n end;\r\n\r\n // structure to hold a single State\r\n PUcState = ^TUcState;\r\n TUcState = record\r\n ID: SizeInt;\r\n Accepting: Boolean;\r\n StateList: TUcStateList;\r\n Transitions: array of TUcElement;\r\n TransitionsUsed: SizeInt;\r\n end;\r\n\r\n // structure used for keeping lists of states\r\n TUcStateTable = record\r\n States: array of TUcState;\r\n StatesUsed: SizeInt;\r\n end;\r\n\r\n // structure to track pairs of DFA states when equivalent states are merged\r\n TUcEquivalent = record\r\n Left,\r\n Right: SizeInt;\r\n end;\r\n\r\n TUcExpressionList = record\r\n Expressions: array of TUcElement;\r\n ExpressionsUsed: SizeInt;\r\n end;\r\n\r\n TUcSymbolTable = record\r\n Symbols: array of TUcSymbolTableEntry;\r\n SymbolsUsed: SizeInt;\r\n end;\r\n\r\n TUcEquivalentList = record\r\n Equivalents: array of TUcEquivalent;\r\n EquivalentsUsed: SizeInt;\r\n end;\r\n\r\n // structure used for constructing the NFA and reducing to a minimal DFA\r\n PUREBuffer = ^TUREBuffer;\r\n TUREBuffer = record\r\n Reducing: Boolean;\r\n Error: Integer;\r\n Flags: Cardinal;\r\n Stack: TUcStateList;\r\n SymbolTable: TUcSymbolTable; // table of unique symbols encountered\r\n ExpressionList: TUcExpressionList; // tracks the unique expressions generated\r\n // for the NFA and when the NFA is reduced\r\n States: TUcStateTable; // the reduced table of unique groups of NFA states\r\n EquivalentList: TUcEquivalentList; // tracks states when equivalent states are merged\r\n end;\r\n\r\n TUcTransition = record\r\n Symbol,\r\n NextState: SizeInt;\r\n end;\r\n\r\n PDFAState = ^TDFAState;\r\n TDFAState = record\r\n Accepting: Boolean;\r\n NumberTransitions: SizeInt;\r\n StartTransition: SizeInt;\r\n end;\r\n\r\n TDFAStates = record\r\n States: array of TDFAState;\r\n StatesUsed: SizeInt;\r\n end;\r\n\r\n TUcTransitions = record\r\n Transitions: array of TUcTransition;\r\n TransitionsUsed: SizeInt;\r\n end;\r\n\r\n TDFA = record\r\n Flags: Cardinal;\r\n SymbolTable: TUcSymbolTable;\r\n StateList: TDFAStates;\r\n TransitionList: TUcTransitions;\r\n end;\r\n\r\n TURESearch = class(TSearchEngine)\r\n private\r\n FUREBuffer: TUREBuffer;\r\n FDFA: TDFA;\r\n protected\r\n procedure AddEquivalentPair(L, R: SizeInt);\r\n procedure AddRange(var CCL: TUcCClass; Range: TUcRange);\r\n function AddState(NewStates: array of SizeInt): SizeInt;\r\n procedure AddSymbolState(Symbol, State: SizeInt);\r\n function BuildCharacterClass(CP: PUCS2; Limit: SizeInt; Symbol: PUcSymbolTableEntry): SizeInt;\r\n procedure ClearUREBuffer;\r\n function CompileSymbol(S: PUCS2; Limit: SizeInt; Symbol: PUcSymbolTableEntry): SizeInt;\r\n procedure CompileURE(RE: PWideChar; RELength: SizeInt; Casefold: Boolean);\r\n procedure CollectPendingOperations(var State: SizeInt);\r\n function ConvertRegExpToNFA(RE: PWideChar; RELength: SizeInt): SizeInt;\r\n function ExecuteURE(Flags: Cardinal; Text: PUCS2; TextLen: SizeInt; var MatchStart, MatchEnd: SizeInt): Boolean;\r\n procedure ClearDFA;\r\n procedure HexDigitSetup(Symbol: PUcSymbolTableEntry);\r\n function MakeExpression(AType, LHS, RHS: SizeInt): SizeInt;\r\n function MakeHexNumber(NP: PUCS2; Limit: SizeInt; var Number: UCS4): SizeInt;\r\n function MakeSymbol(S: PUCS2; Limit: SizeInt; out Consumed: SizeInt): SizeInt;\r\n procedure MergeEquivalents;\r\n function ParsePropertyList(Properties: PUCS2; Limit: SizeInt; var Categories: TCharacterCategories): SizeInt;\r\n function Peek: SizeInt;\r\n function Pop: SizeInt;\r\n function PosixCCL(CP: PUCS2; Limit: SizeInt; Symbol: PUcSymbolTableEntry): SizeInt;\r\n function ProbeLowSurrogate(LeftState: PUCS2; Limit: SizeInt; var Code: UCS4): SizeInt;\r\n procedure Push(V: SizeInt);\r\n procedure Reduce(Start: SizeInt);\r\n procedure SpaceSetup(Symbol: PUcSymbolTableEntry; Categories: TCharacterCategories);\r\n function SymbolsAreDifferent(A, B: PUcSymbolTableEntry): Boolean;\r\n public\r\n procedure Clear; override;\r\n procedure FindPrepare(const Pattern: WideString; Options: TSearchFlags); overload; override;\r\n procedure FindPrepare(Pattern: PWideChar; PatternLength: SizeInt; Options: TSearchFlags); overload; override;\r\n function FindFirst(const Text: WideString; var Start, Stop: SizeInt): Boolean; overload; override;\r\n function FindFirst(Text: PWideChar; TextLen: SizeInt; var Start, Stop: SizeInt): Boolean; overload; override;\r\n function FindAll(const Text: WideString): Boolean; overload; override;\r\n function FindAll(Text: PWideChar; TextLen: SizeInt): Boolean; overload; override;\r\n end;\r\n\r\n // Event used to give the application a chance to switch the way of how to save\r\n // the text in TWideStrings if the text contains characters not only from the\r\n // ANSI block but the save type is ANSI. On triggering the event the application\r\n // can change the property SaveUnicode as needed. This property is again checked\r\n // after the callback returns.\r\n TConfirmConversionEvent = procedure (Sender: TWideStrings; var Allowed: Boolean) of object;\r\n\r\n TWideStrings = class(TPersistent)\r\n private\r\n FUpdateCount: Integer;\r\n FLanguage: LCID; // language can usually left alone, the system's default is used\r\n FSaved: Boolean; // set in SaveToStream, True in case saving was successfull otherwise False\r\n FNormalizationForm: TNormalizationForm; // determines in which form Unicode strings should be stored\r\n FOnConfirmConversion: TConfirmConversionEvent;\r\n FSaveFormat: TSaveFormat; // overrides the FSaveUnicode flag, initialized when a file is loaded,\r\n // expect losses if it is set to sfAnsi before saving\r\n function GetCommaText: WideString;\r\n function GetName(Index: Integer): WideString;\r\n function GetValue(const Name: WideString): WideString;\r\n procedure ReadData(Reader: TReader);\r\n procedure SetCommaText(const Value: WideString);\r\n procedure SetNormalizationForm(const Value: TNormalizationForm);\r\n procedure SetValue(const Name, Value: WideString);\r\n procedure WriteData(Writer: TWriter);\r\n function GetSaveUnicode: Boolean;\r\n procedure SetSaveUnicode(const Value: Boolean);\r\n protected\r\n procedure DefineProperties(Filer: TFiler); override;\r\n procedure DoConfirmConversion(var Allowed: Boolean); virtual;\r\n procedure Error(const Msg: string; Data: Integer);\r\n function Get(Index: Integer): WideString; virtual; abstract;\r\n function GetCapacity: Integer; virtual;\r\n function GetCount: Integer; virtual; abstract;\r\n function GetObject(Index: Integer): TObject; virtual;\r\n function GetTextStr: WideString; virtual;\r\n procedure Put(Index: Integer; const S: WideString); virtual; abstract;\r\n procedure PutObject(Index: Integer; AObject: TObject); virtual; abstract;\r\n procedure SetCapacity(NewCapacity: Integer); virtual;\r\n procedure SetUpdateState(Updating: Boolean); virtual;\r\n procedure SetLanguage(Value: LCID); virtual;\r\n public\r\n constructor Create;\r\n\r\n function Add(const S: WideString): Integer; virtual;\r\n function AddObject(const S: WideString; AObject: TObject): Integer; virtual;\r\n procedure Append(const S: WideString);\r\n procedure AddStrings(Strings: TStrings); overload; virtual;\r\n procedure AddStrings(Strings: TWideStrings); overload; virtual;\r\n procedure Assign(Source: TPersistent); override;\r\n procedure AssignTo(Dest: TPersistent); override;\r\n procedure BeginUpdate;\r\n procedure Clear; virtual; abstract;\r\n procedure Delete(Index: Integer); virtual; abstract;\r\n procedure EndUpdate;\r\n function Equals(Strings: TWideStrings): Boolean; {$IFDEF RTL200_UP} reintroduce; {$ENDIF RTL200_UP}\r\n procedure Exchange(Index1, Index2: Integer); virtual;\r\n function GetSeparatedText(Separators: WideString): WideString; virtual;\r\n function GetText: PWideChar; virtual;\r\n function IndexOf(const S: WideString): Integer; virtual;\r\n function IndexOfName(const Name: WideString): Integer;\r\n function IndexOfObject(AObject: TObject): Integer;\r\n procedure Insert(Index: Integer; const S: WideString); virtual; abstract;\r\n procedure InsertObject(Index: Integer; const S: WideString; AObject: TObject);\r\n procedure LoadFromFile(const FileName: TFileName); virtual;\r\n procedure LoadFromStream(Stream: TStream); virtual;\r\n procedure Move(CurIndex, NewIndex: Integer); virtual;\r\n procedure SaveToFile(const FileName: TFileName); virtual;\r\n procedure SaveToStream(Stream: TStream; WithBOM: Boolean = True); virtual;\r\n procedure SetText(const Value: WideString); virtual;\r\n\r\n property Capacity: Integer read GetCapacity write SetCapacity;\r\n property CommaText: WideString read GetCommaText write SetCommaText;\r\n property Count: Integer read GetCount;\r\n property Language: LCID read FLanguage write SetLanguage;\r\n property Names[Index: Integer]: WideString read GetName;\r\n property NormalizationForm: TNormalizationForm read FNormalizationForm write SetNormalizationForm default nfC;\r\n property Objects[Index: Integer]: TObject read GetObject write PutObject;\r\n property Values[const Name: WideString]: WideString read GetValue write SetValue;\r\n property Saved: Boolean read FSaved;\r\n property SaveUnicode: Boolean read GetSaveUnicode write SetSaveUnicode default True;\r\n property SaveFormat: TSaveFormat read FSaveFormat write FSaveFormat default sfUnicodeLSB;\r\n property Strings[Index: Integer]: WideString read Get write Put; default;\r\n property Text: WideString read GetTextStr write SetText;\r\n\r\n property OnConfirmConversion: TConfirmConversionEvent read FOnConfirmConversion write FOnConfirmConversion;\r\n end;\r\n\r\n //----- TWideStringList class\r\n TWideStringItem = record\r\n {$IFDEF OWN_WIDESTRING_MEMMGR}\r\n FString: PWideChar; // \"array of WideChar\";\r\n {$ELSE ~OWN_WIDESTRING_MEMMGR}\r\n FString: WideString;\r\n {$ENDIF ~OWN_WIDESTRING_MEMMGR}\r\n FObject: TObject;\r\n end;\r\n\r\n TWideStringItemList = array of TWideStringItem;\r\n\r\n TWideStringList = class(TWideStrings)\r\n private\r\n FList: TWideStringItemList;\r\n FCount: Integer;\r\n FSorted: Boolean;\r\n FDuplicates: TDuplicates;\r\n FOnChange: TNotifyEvent;\r\n FOnChanging: TNotifyEvent;\r\n procedure ExchangeItems(Index1, Index2: Integer);\r\n procedure Grow;\r\n procedure QuickSort(L, R: Integer);\r\n procedure InsertItem(Index: Integer; const S: WideString);\r\n procedure SetSorted(Value: Boolean);\r\n {$IFDEF OWN_WIDESTRING_MEMMGR}\r\n procedure SetListString(Index: Integer; const S: WideString);\r\n {$ENDIF OWN_WIDESTRING_MEMMGR}\r\n protected\r\n procedure Changed; virtual;\r\n procedure Changing; virtual;\r\n function Get(Index: Integer): WideString; override;\r\n function GetCapacity: Integer; override;\r\n function GetCount: Integer; override;\r\n function GetObject(Index: Integer): TObject; override;\r\n procedure Put(Index: Integer; const S: WideString); override;\r\n procedure PutObject(Index: Integer; AObject: TObject); override;\r\n procedure SetCapacity(NewCapacity: Integer); override;\r\n procedure SetUpdateState(Updating: Boolean); override;\r\n procedure SetLanguage(Value: LCID); override;\r\n public\r\n destructor Destroy; override;\r\n\r\n function Add(const S: WideString): Integer; override;\r\n procedure Clear; override;\r\n procedure Delete(Index: Integer); override;\r\n procedure Exchange(Index1, Index2: Integer); override;\r\n function Find(const S: WideString; var Index: Integer): Boolean; virtual;\r\n function IndexOf(const S: WideString): Integer; override;\r\n procedure Insert(Index: Integer; const S: WideString); override;\r\n procedure Sort; virtual;\r\n\r\n property Duplicates: TDuplicates read FDuplicates write FDuplicates;\r\n property Sorted: Boolean read FSorted write SetSorted;\r\n property OnChange: TNotifyEvent read FOnChange write FOnChange;\r\n property OnChanging: TNotifyEvent read FOnChanging write FOnChanging;\r\n end;\r\n\r\n{$ENDIF ~UNICODE_RTL_DATABASE}\r\n\r\n{\r\n// all these functions are now in JclWideStrings.pas\r\nfunction StrLenW(Str: PWideChar): SizeInt;\r\nfunction StrEndW(Str: PWideChar): PWideChar;\r\nfunction StrMoveW(Dest, Source: PWideChar; Count: SizeInt): PWideChar;\r\nfunction StrCopyW(Dest, Source: PWideChar): PWideChar;\r\nfunction StrECopyW(Dest, Source: PWideChar): PWideChar;\r\nfunction StrLCopyW(Dest, Source: PWideChar; MaxLen: SizeInt): PWideChar;\r\nfunction StrPCopyWW(Dest: PWideChar; const Source: WideString): PWideChar; overload;\r\nfunction StrPCopyW(Dest: PWideChar; const Source: AnsiString): PWideChar;\r\nfunction StrPLCopyWW(Dest: PWideChar; const Source: WideString; MaxLen: SizeInt): PWideChar;\r\nfunction StrPLCopyW(Dest: PWideChar; const Source: AnsiString; MaxLen: SizeInt): PWideChar;\r\nfunction StrCatW(Dest: PWideChar; const Source: PWideChar): PWideChar;\r\nfunction StrLCatW(Dest, Source: PWideChar; MaxLen: SizeInt): PWideChar;\r\nfunction StrCompW(const Str1, Str2: PWideChar): Integer;\r\nfunction StrICompW(const Str1, Str2: PWideChar): Integer;\r\nfunction StrLCompW(const Str1, Str2: PWideChar; MaxLen: SizeInt): Integer;\r\nfunction StrLICompW(const Str1, Str2: PWideChar; MaxLen: SizeInt): Integer;\r\nfunction StrNScanW(const Str1, Str2: PWideChar): SizeInt;\r\nfunction StrRNScanW(const Str1, Str2: PWideChar): SizeInt;\r\nfunction StrScanW(Str: PWideChar; Chr: WideChar): PWideChar; overload;\r\nfunction StrScanW(Str: PWideChar; Chr: WideChar; StrLen: SizeInt): PWideChar; overload;\r\nfunction StrRScanW(Str: PWideChar; Chr: WideChar): PWideChar;\r\nfunction StrPosW(Str, SubStr: PWideChar): PWideChar;\r\nfunction StrAllocW(WideSize: SizeInt): PWideChar;\r\nfunction StrBufSizeW(const Str: PWideChar): SizeInt;\r\nfunction StrNewW(const Str: PWideChar): PWideChar; overload;\r\nfunction StrNewW(const Str: WideString): PWideChar; overload;\r\nprocedure StrDisposeW(Str: PWideChar);\r\nprocedure StrDisposeAndNilW(var Str: PWideChar);\r\nprocedure StrSwapByteOrder(Str: PWideChar);\r\n}\r\n\r\n// functions involving Delphi wide strings\r\nfunction WideAdjustLineBreaks(const S: WideString): WideString;\r\nfunction WideCharPos(const S: WideString; const Ch: WideChar; const Index: SizeInt): SizeInt; //az\r\n{$IFNDEF UNICODE_RTL_DATABASE}\r\nfunction WideCompose(const S: WideString; Compatible: Boolean = True): WideString; overload;\r\nfunction WideCompose(const S: WideString; Tags: TCompatibilityFormattingTags): WideString; overload;\r\nfunction WideDecompose(const S: WideString; Compatible: Boolean = True): WideString; overload;\r\nfunction WideDecompose(const S: WideString; Tags: TCompatibilityFormattingTags): WideString; overload;\r\n{$ENDIF ~UNICODE_RTL_DATABASE}\r\nfunction WideExtractQuotedStr(var Src: PWideChar; Quote: WideChar): WideString;\r\nfunction WideQuotedStr(const S: WideString; Quote: WideChar): WideString;\r\nfunction WideStringOfChar(C: WideChar; Count: SizeInt): WideString;\r\n\r\n// case conversion function\r\ntype\r\n TCaseType = (ctFold, ctLower, ctTitle, ctUpper);\r\n\r\n{$IFNDEF UNICODE_RTL_DATABASE}\r\nfunction WideNormalize(const S: WideString; Form: TNormalizationForm): WideString;\r\n\r\nfunction WideCaseConvert(C: WideChar; CaseType: TCaseType): WideString; overload;\r\nfunction WideCaseConvert(const S: WideString; CaseType: TCaseType): WideString; overload;\r\nfunction WideCaseFolding(C: WideChar): WideString; overload; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF SUPPORTS_INLINE}\r\nfunction WideCaseFolding(const S: WideString): WideString; overload; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF SUPPORTS_INLINE}\r\nfunction WideTitleCase(C: WideChar): WideString; overload; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF SUPPORTS_INLINE}\r\nfunction WideTitleCase(const S: WideString): WideString; overload; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF SUPPORTS_INLINE}\r\n{$ENDIF ~UNICODE_RTL_DATABASE}\r\nfunction WideLowerCase(C: WideChar): WideString; overload; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF SUPPORTS_INLINE}\r\nfunction WideLowerCase(const S: WideString): WideString; overload; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF SUPPORTS_INLINE}\r\nfunction WideUpperCase(C: WideChar): WideString; overload; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF SUPPORTS_INLINE}\r\nfunction WideUpperCase(const S: WideString): WideString; overload; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF SUPPORTS_INLINE}\r\n\r\nfunction WideSameText(const Str1, Str2: WideString): Boolean;\r\nfunction WideTrim(const S: WideString): WideString;\r\nfunction WideTrimLeft(const S: WideString): WideString;\r\nfunction WideTrimRight(const S: WideString): WideString;\r\n\r\ntype\r\n // result type for number retrieval functions\r\n TUcNumber = record\r\n Numerator,\r\n Denominator: Integer;\r\n end;\r\n\r\n// Low level character routines\r\n{$IFNDEF UNICODE_RTL_DATABASE}\r\nfunction UnicodeNumberLookup(Code: UCS4; var Number: TUcNumber): Boolean;\r\nfunction UnicodeCompose(const Codes: array of UCS4; out Composite: UCS4; Compatible: Boolean = True): Integer; overload;\r\nfunction UnicodeCompose(const Codes: array of UCS4; out Composite: UCS4; Tags: TCompatibilityFormattingTags): Integer; overload;\r\nfunction UnicodeCaseFold(Code: UCS4): TUCS4Array;\r\nfunction UnicodeDecompose(Code: UCS4; Compatible: Boolean = True): TUCS4Array; overload;\r\nfunction UnicodeDecompose(Code: UCS4; Tags: TCompatibilityFormattingTags): TUCS4Array; overload;\r\nfunction UnicodeToTitle(Code: UCS4): TUCS4Array;\r\n{$ENDIF ~UNICODE_RTL_DATABASE}\r\nfunction UnicodeToUpper(Code: UCS4): TUCS4Array;\r\nfunction UnicodeToLower(Code: UCS4): TUCS4Array;\r\n\r\n// Character test routines\r\nfunction UnicodeIsAlpha(C: UCS4): Boolean;\r\nfunction UnicodeIsDigit(C: UCS4): Boolean;\r\nfunction UnicodeIsAlphaNum(C: UCS4): Boolean;\r\nfunction UnicodeIsNumberOther(C: UCS4): Boolean;\r\nfunction UnicodeIsCased(C: UCS4): Boolean;\r\nfunction UnicodeIsControl(C: UCS4): Boolean;\r\nfunction UnicodeIsSpace(C: UCS4): Boolean;\r\nfunction UnicodeIsWhiteSpace(C: UCS4): Boolean;\r\nfunction UnicodeIsBlank(C: UCS4): Boolean;\r\nfunction UnicodeIsPunctuation(C: UCS4): Boolean;\r\nfunction UnicodeIsGraph(C: UCS4): Boolean;\r\nfunction UnicodeIsPrintable(C: UCS4): Boolean;\r\nfunction UnicodeIsUpper(C: UCS4): Boolean;\r\nfunction UnicodeIsLower(C: UCS4): Boolean;\r\nfunction UnicodeIsTitle(C: UCS4): Boolean;\r\n{$IFNDEF UNICODE_RTL_DATABASE}\r\nfunction UnicodeIsHexDigit(C: UCS4): Boolean;\r\n{$ENDIF ~UNICODE_RTL_DATABASE}\r\nfunction UnicodeIsIsoControl(C: UCS4): Boolean;\r\nfunction UnicodeIsFormatControl(C: UCS4): Boolean;\r\nfunction UnicodeIsSymbol(C: UCS4): Boolean;\r\nfunction UnicodeIsNumber(C: UCS4): Boolean;\r\nfunction UnicodeIsNonSpacing(C: UCS4): Boolean;\r\nfunction UnicodeIsOpenPunctuation(C: UCS4): Boolean;\r\nfunction UnicodeIsClosePunctuation(C: UCS4): Boolean;\r\nfunction UnicodeIsInitialPunctuation(C: UCS4): Boolean;\r\nfunction UnicodeIsFinalPunctuation(C: UCS4): Boolean;\r\n{$IFNDEF UNICODE_RTL_DATABASE}\r\nfunction UnicodeIsComposed(C: UCS4): Boolean;\r\nfunction UnicodeIsQuotationMark(C: UCS4): Boolean;\r\nfunction UnicodeIsSymmetric(C: UCS4): Boolean;\r\nfunction UnicodeIsMirroring(C: UCS4): Boolean;\r\nfunction UnicodeIsNonBreaking(C: UCS4): Boolean;\r\n\r\n// Directionality functions\r\nfunction UnicodeIsRightToLeft(C: UCS4): Boolean;\r\nfunction UnicodeIsLeftToRight(C: UCS4): Boolean;\r\nfunction UnicodeIsStrong(C: UCS4): Boolean;\r\nfunction UnicodeIsWeak(C: UCS4): Boolean;\r\nfunction UnicodeIsNeutral(C: UCS4): Boolean;\r\nfunction UnicodeIsSeparator(C: UCS4): Boolean;\r\n\r\n// Other character test functions\r\nfunction UnicodeIsMark(C: UCS4): Boolean;\r\nfunction UnicodeIsModifier(C: UCS4): Boolean;\r\n{$ENDIF ~UNICODE_RTL_DATABASE}\r\nfunction UnicodeIsLetterNumber(C: UCS4): Boolean;\r\nfunction UnicodeIsConnectionPunctuation(C: UCS4): Boolean;\r\nfunction UnicodeIsDash(C: UCS4): Boolean;\r\nfunction UnicodeIsMath(C: UCS4): Boolean;\r\nfunction UnicodeIsCurrency(C: UCS4): Boolean;\r\nfunction UnicodeIsModifierSymbol(C: UCS4): Boolean;\r\nfunction UnicodeIsSpacingMark(C: UCS4): Boolean;\r\nfunction UnicodeIsEnclosing(C: UCS4): Boolean;\r\nfunction UnicodeIsPrivate(C: UCS4): Boolean;\r\nfunction UnicodeIsSurrogate(C: UCS4): Boolean;\r\nfunction UnicodeIsLineSeparator(C: UCS4): Boolean;\r\nfunction UnicodeIsParagraphSeparator(C: UCS4): Boolean;\r\nfunction UnicodeIsIdentifierStart(C: UCS4): Boolean;\r\nfunction UnicodeIsIdentifierPart(C: UCS4): Boolean;\r\nfunction UnicodeIsDefined(C: UCS4): Boolean;\r\nfunction UnicodeIsUndefined(C: UCS4): Boolean;\r\nfunction UnicodeIsHan(C: UCS4): Boolean;\r\nfunction UnicodeIsHangul(C: UCS4): Boolean;\r\n\r\nfunction UnicodeIsUnassigned(C: UCS4): Boolean;\r\nfunction UnicodeIsLetterOther(C: UCS4): Boolean;\r\nfunction UnicodeIsConnector(C: UCS4): Boolean;\r\nfunction UnicodeIsPunctuationOther(C: UCS4): Boolean;\r\nfunction UnicodeIsSymbolOther(C: UCS4): Boolean;\r\n{$IFNDEF UNICODE_RTL_DATABASE}\r\nfunction UnicodeIsLeftToRightEmbedding(C: UCS4): Boolean;\r\nfunction UnicodeIsLeftToRightOverride(C: UCS4): Boolean;\r\nfunction UnicodeIsRightToLeftArabic(C: UCS4): Boolean;\r\nfunction UnicodeIsRightToLeftEmbedding(C: UCS4): Boolean;\r\nfunction UnicodeIsRightToLeftOverride(C: UCS4): Boolean;\r\nfunction UnicodeIsPopDirectionalFormat(C: UCS4): Boolean;\r\nfunction UnicodeIsEuropeanNumber(C: UCS4): Boolean;\r\nfunction UnicodeIsEuropeanNumberSeparator(C: UCS4): Boolean;\r\nfunction UnicodeIsEuropeanNumberTerminator(C: UCS4): Boolean;\r\nfunction UnicodeIsArabicNumber(C: UCS4): Boolean;\r\nfunction UnicodeIsCommonNumberSeparator(C: UCS4): Boolean;\r\nfunction UnicodeIsBoundaryNeutral(C: UCS4): Boolean;\r\nfunction UnicodeIsSegmentSeparator(C: UCS4): Boolean;\r\nfunction UnicodeIsOtherNeutrals(C: UCS4): Boolean;\r\nfunction UnicodeIsASCIIHexDigit(C: UCS4): Boolean;\r\nfunction UnicodeIsBidiControl(C: UCS4): Boolean;\r\nfunction UnicodeIsDeprecated(C: UCS4): Boolean;\r\nfunction UnicodeIsDiacritic(C: UCS4): Boolean;\r\nfunction UnicodeIsExtender(C: UCS4): Boolean;\r\nfunction UnicodeIsHyphen(C: UCS4): Boolean;\r\nfunction UnicodeIsIdeographic(C: UCS4): Boolean;\r\nfunction UnicodeIsIDSBinaryOperator(C: UCS4): Boolean;\r\nfunction UnicodeIsIDSTrinaryOperator(C: UCS4): Boolean;\r\nfunction UnicodeIsJoinControl(C: UCS4): Boolean;\r\nfunction UnicodeIsLogicalOrderException(C: UCS4): Boolean;\r\nfunction UnicodeIsNonCharacterCodePoint(C: UCS4): Boolean;\r\nfunction UnicodeIsOtherAlphabetic(C: UCS4): Boolean;\r\nfunction UnicodeIsOtherDefaultIgnorableCodePoint(C: UCS4): Boolean;\r\nfunction UnicodeIsOtherGraphemeExtend(C: UCS4): Boolean;\r\nfunction UnicodeIsOtherIDContinue(C: UCS4): Boolean;\r\nfunction UnicodeIsOtherIDStart(C: UCS4): Boolean;\r\nfunction UnicodeIsOtherLowercase(C: UCS4): Boolean;\r\nfunction UnicodeIsOtherMath(C: UCS4): Boolean;\r\nfunction UnicodeIsOtherUppercase(C: UCS4): Boolean;\r\nfunction UnicodeIsPatternSyntax(C: UCS4): Boolean;\r\nfunction UnicodeIsPatternWhiteSpace(C: UCS4): Boolean;\r\nfunction UnicodeIsRadical(C: UCS4): Boolean;\r\nfunction UnicodeIsSoftDotted(C: UCS4): Boolean;\r\nfunction UnicodeIsSTerm(C: UCS4): Boolean;\r\nfunction UnicodeIsTerminalPunctuation(C: UCS4): Boolean;\r\nfunction UnicodeIsUnifiedIdeograph(C: UCS4): Boolean;\r\nfunction UnicodeIsVariationSelector(C: UCS4): Boolean;\r\n{$ENDIF ~UNICODE_RTL_DATABASE}\r\n\r\n// Utility functions\r\nfunction CharSetFromLocale(Language: LCID): Byte;\r\nfunction GetCharSetFromLocale(Language: LCID; out FontCharSet: Byte): Boolean;\r\nfunction CodePageFromLocale(Language: LCID): Word;\r\nfunction CodeBlockName(const CB: TUnicodeBlock): string;\r\nfunction CodeBlockRange(const CB: TUnicodeBlock): TUnicodeBlockRange;\r\nfunction CodeBlockFromChar(const C: UCS4): TUnicodeBlock;\r\nfunction KeyboardCodePage: Word;\r\nfunction KeyUnicode(C: Char): WideChar;\r\nfunction StringToWideStringEx(const S: AnsiString; CodePage: Word): WideString;\r\nfunction TranslateString(const S: AnsiString; CP1, CP2: Word): AnsiString;\r\nfunction WideStringToStringEx(const WS: WideString; CodePage: Word): AnsiString;\r\n\r\ntype\r\n TCompareFunc = function (const W1, W2: WideString; Locale: LCID): Integer;\r\n\r\nvar\r\n WideCompareText: TCompareFunc;\r\n\r\ntype\r\n EJclUnicodeError = class(EJclError);\r\n\r\n// functions to load Unicode data from resource\r\nprocedure LoadCharacterCategories;\r\nprocedure LoadCaseMappingData;\r\nprocedure LoadDecompositionData;\r\nprocedure LoadCombiningClassData;\r\nprocedure LoadNumberData;\r\nprocedure LoadCompositionData;\r\n\r\n// functions around TUCS4Array\r\nfunction UCS4Array(Ch: UCS4): TUCS4Array;\r\nfunction UCS4ArrayConcat(Left, Right: UCS4): TUCS4Array; overload; {$IFDEF SUPPORTS_INLINE}inline;{$ENDIF}\r\nprocedure UCS4ArrayConcat(var Left: TUCS4Array; Right: UCS4); overload; {$IFDEF SUPPORTS_INLINE}inline;{$ENDIF}\r\nprocedure UCS4ArrayConcat(var Left: TUCS4Array; const Right: TUCS4Array); overload; {$IFDEF SUPPORTS_INLINE}inline;{$ENDIF}\r\nfunction UCS4ArrayEquals(const Left: TUCS4Array; const Right: TUCS4Array): Boolean; overload; {$IFDEF SUPPORTS_INLINE}inline;{$ENDIF}\r\nfunction UCS4ArrayEquals(const Left: TUCS4Array; Right: UCS4): Boolean; overload; {$IFDEF SUPPORTS_INLINE}inline;{$ENDIF}\r\nfunction UCS4ArrayEquals(const Left: TUCS4Array; const Right: AnsiString): Boolean; overload; {$IFDEF SUPPORTS_INLINE}inline;{$ENDIF}\r\nfunction UCS4ArrayEquals(const Left: TUCS4Array; Right: AnsiChar): Boolean; overload; {$IFDEF SUPPORTS_INLINE}inline;{$ENDIF}\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jcl.svn.sourceforge.net/svnroot/jcl/tags/JCL-2.4-Build4571/jcl/source/common/JclUnicode.pas $';\r\n Revision: '$Revision: 3861 $';\r\n Date: '$Date: 2012-09-04 16:08:04 +0200 (mar. 04 sept. 2012) $';\r\n LogPath: 'JCL\\source\\common';\r\n Extra: '';\r\n Data: nil\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\n// Unicode data for case mapping, decomposition, numbers etc. This data is\r\n// loaded on demand which means only those parts will be put in memory which are\r\n// needed by one of the lookup functions.\r\n// Note: There is a little tool called UDExtract which creates a resouce script from\r\n// the Unicode database file which can be compiled to the needed res file.\r\n// This tool, including its source code, can be downloaded from www.lischke-online.de/Unicode.html.\r\n\r\n{$IFNDEF UNICODE_RTL_DATABASE}\r\n{$IFDEF UNICODE_RAW_DATA}\r\n{$R JclUnicode.res}\r\n{$ENDIF UNICODE_RAW_DATA}\r\n{$IFDEF UNICODE_BZIP2_DATA}\r\n{$R JclUnicodeBZip2.res}\r\n{$ENDIF UNICODE_BZIP2_DATA}\r\n{$IFDEF UNICODE_ZLIB_DATA}\r\n{$R JclUnicodeZLib.res}\r\n{$ENDIF UNICODE_ZLIB_DATA}\r\n{$ENDIF ~UNICODE_RTL_DATABASE}\r\n\r\nuses\r\n {$IFDEF HAS_UNIT_RTLCONSTS}\r\n {$IFDEF HAS_UNITSCOPE}\r\n System.RtlConsts,\r\n {$ELSE ~HAS_UNITSCOPE}\r\n RtlConsts,\r\n {$ENDIF ~HAS_UNITSCOPE}\r\n {$ENDIF HAS_UNIT_RTLCONSTS}\r\n {$IFNDEF UNICODE_RTL_DATABASE}\r\n {$IFDEF UNICODE_BZIP2_DATA}\r\n BZip2,\r\n {$ENDIF UNICODE_BZIP2_DATA}\r\n {$IFDEF UNICODE_ZLIB_DATA}\r\n ZLibh,\r\n {$ENDIF UNICODE_ZLIB_DATA}\r\n JclStreams,\r\n {$IFNDEF UNICODE_RAW_DATA}\r\n JclCompression,\r\n {$ENDIF ~UNICODE_RAW_DATA}\r\n {$ENDIF ~UNICODE_RTL_DATABASE}\r\n JclResources, JclSynch, JclSysUtils, JclSysInfo, JclStringConversions, JclWideStrings;\r\n\r\nconst\r\n {$IFDEF FPC} // declarations from unit [Rtl]Consts\r\n SDuplicateString = 'String list does not allow duplicates';\r\n SListIndexError = 'List index out of bounds (%d)';\r\n SSortedListError = 'Operation not allowed on sorted string list';\r\n {$ENDIF FPC}\r\n // some predefined sets to shorten parameter lists below and ease repeative usage\r\n ClassLetter = [ccLetterUppercase, ccLetterLowercase, ccLetterTitlecase, ccLetterModifier, ccLetterOther];\r\n ClassSpace = [ccSeparatorSpace];\r\n ClassPunctuation = [ccPunctuationConnector, ccPunctuationDash, ccPunctuationOpen, ccPunctuationClose,\r\n ccPunctuationOther, ccPunctuationInitialQuote, ccPunctuationFinalQuote];\r\n ClassMark = [ccMarkNonSpacing, ccMarkSpacingCombining, ccMarkEnclosing];\r\n ClassNumber = [ccNumberDecimalDigit, ccNumberLetter, ccNumberOther];\r\n ClassSymbol = [ccSymbolMath, ccSymbolCurrency, ccSymbolModifier, ccSymbolOther];\r\n ClassEuropeanNumber = [ccEuropeanNumber, ccEuropeanNumberSeparator, ccEuropeanNumberTerminator];\r\n\r\n // used to negate a set of categories\r\n ClassAll = [Low(TCharacterCategory)..High(TCharacterCategory)];\r\n\r\n{$IFDEF HAS_UNIT_CHARACTER}\r\nfunction CharacterCategoriesToUnicodeCategory(const Categories: TCharacterCategories): TUnicodeCategory;\r\nvar\r\n Category: TCharacterUnicodeCategory;\r\nbegin\r\n for Category := Low(TCharacterUnicodeCategory) to High(TCharacterUnicodeCategory) do\r\n if Category in Categories then\r\n begin\r\n Result := CharacterCategoryToUnicodeCategory[Category];\r\n Exit;\r\n end;\r\n Result := TUnicodeCategory.ucUnassigned;\r\nend;\r\n\r\nfunction UnicodeCategoryToCharacterCategories(Category: TUnicodeCategory): TCharacterCategories;\r\nbegin\r\n Result := [];\r\n Include(Result, UnicodeCategoryToCharacterCategory[Category]);\r\nend;\r\n{$ENDIF HAS_UNIT_CHARACTER}\r\n\r\n{$IFDEF UNICODE_RTL_DATABASE}\r\nprocedure LoadCharacterCategories;\r\nbegin\r\n // do nothing, the RTL database is already loaded\r\nend;\r\n\r\nprocedure LoadCaseMappingData;\r\nbegin\r\n // do nothing, the RTL database is already loaded\r\nend;\r\n\r\nprocedure LoadDecompositionData;\r\nbegin\r\n // do nothing, the RTL database is already loaded\r\nend;\r\n\r\nprocedure LoadCombiningClassData;\r\nbegin\r\n // do nothing, the RTL database is already loaded\r\nend;\r\n\r\nprocedure LoadNumberData;\r\nbegin\r\n // do nothing, the RTL database is already loaded\r\nend;\r\n\r\nprocedure LoadCompositionData;\r\nbegin\r\n // do nothing, the RTL database is already loaded\r\nend;\r\n{$ELSE ~UNICODE_RTL_DATABASE}\r\nvar\r\n // As the global data can be accessed by several threads it should be guarded\r\n // while the data is loaded.\r\n LoadInProgress: TJclCriticalSection;\r\n\r\nfunction OpenResourceStream(const ResName: string): TJclEasyStream;\r\nvar\r\n ResourceStream: TStream;\r\n {$IFNDEF UNICODE_RAW_DATA}\r\n DecompressionStream: TStream;\r\n RawStream: TMemoryStream;\r\n {$ENDIF ~UNICODE_RAW_DATA}\r\nbegin\r\n ResourceStream := TResourceStream.Create(HInstance, ResName, 'UNICODEDATA');\r\n {$IFDEF UNICODE_RAW_DATA}\r\n Result := TJclEasyStream.Create(ResourceStream, True);\r\n {$ENDIF UNICODE_RAW_DATA}\r\n {$IFDEF UNICODE_BZIP2_DATA}\r\n try\r\n LoadBZip2;\r\n DecompressionStream := TJclBZIP2DecompressionStream.Create(ResourceStream);\r\n try\r\n RawStream := TMemoryStream.Create;\r\n StreamCopy(DecompressionStream, RawStream);\r\n RawStream.Seek(0, soBeginning);\r\n Result := TJclEasyStream.Create(RawStream, True);\r\n finally\r\n DecompressionStream.Free;\r\n end;\r\n finally\r\n ResourceStream.Free;\r\n end;\r\n {$ENDIF UNICODE_BZIP2_DATA}\r\n {$IFDEF UNICODE_ZLIB_DATA}\r\n try\r\n LoadZLib;\r\n DecompressionStream := TJclZLibDecompressStream.Create(ResourceStream);\r\n try\r\n RawStream := TMemoryStream.Create;\r\n StreamCopy(DecompressionStream, RawStream);\r\n RawStream.Seek(0, soBeginning);\r\n Result := TJclEasyStream.Create(RawStream, True);\r\n finally\r\n DecompressionStream.Free;\r\n end;\r\n finally\r\n ResourceStream.Free;\r\n end;\r\n {$ENDIF UNICODE_ZLIB_DATA}\r\nend;\r\n\r\nfunction StreamReadChar(Stream: TStream): Cardinal;\r\nbegin\r\n Result := 0;\r\n Stream.ReadBuffer(Result, 3);\r\nend;\r\n\r\n//----------------- support for character categories -----------------------------------------------\r\n\r\n// Character category data is quite a large block since every defined character in Unicode is assigned at least\r\n// one category. Because of this we cannot use a sparse matrix to provide quick access as implemented for\r\n// e.g. composition data.\r\n// The approach used here is based on the fact that an application seldomly uses all characters defined in Unicode\r\n// simultanously. In fact the opposite is true. Most application will use either Western Europe or Arabic or\r\n// Far East character data, but very rarely all together. Based on this fact is the implementation of virtual\r\n// memory using the systems paging file (aka file mapping) to load only into virtual memory what is used currently.\r\n// The implementation is not yet finished and needs a lot of improvements yet.\r\n\r\ntype\r\n // start and stop of a range of code points\r\n TRange = record\r\n Start,\r\n Stop: Cardinal;\r\n end;\r\n\r\n TRangeArray = array of TRange;\r\n TCategoriesArray = array of array of TCharacterCategories;\r\n\r\nvar\r\n // character categories, stored in the system's swap file and mapped on demand\r\n CategoriesLoaded: Boolean;\r\n Categories: array [Byte] of TCategoriesArray;\r\n\r\nprocedure LoadCharacterCategories;\r\n// Loads the character categories data (as saved by the Unicode database extractor, see also\r\n// the comments about JclUnicode.res above).\r\nvar\r\n Size: Integer;\r\n Stream: TJclEasyStream;\r\n Category: TCharacterCategory;\r\n Buffer: TRangeArray;\r\n First, Second, Third: Byte;\r\n J, K: Integer;\r\nbegin\r\n // Data already loaded?\r\n if not CategoriesLoaded then\r\n begin\r\n // make sure no other code is currently modifying the global data area\r\n LoadInProgress.Enter;\r\n try\r\n CategoriesLoaded := True;\r\n Stream := OpenResourceStream('CATEGORIES');\r\n try\r\n while Stream.Position < Stream.Size do\r\n begin\r\n // a) read which category is current in the stream\r\n Category := TCharacterCategory(Stream.ReadByte);\r\n // b) read the size of the ranges and the ranges themself\r\n Size := Stream.ReadInteger;\r\n if Size > 0 then\r\n begin\r\n SetLength(Buffer, Size);\r\n for J := 0 to Size - 1 do\r\n begin\r\n Buffer[J].Start := StreamReadChar(Stream);\r\n Buffer[J].Stop := StreamReadChar(Stream);\r\n end;\r\n\r\n // c) go through every range and add the current category to each code point\r\n for J := 0 to Size - 1 do\r\n for K := Buffer[J].Start to Buffer[J].Stop do\r\n begin\r\n Assert(K < $1000000, LoadResString(@RsCategoryUnicodeChar));\r\n\r\n First := (K shr 16) and $FF;\r\n Second := (K shr 8) and $FF;\r\n Third := K and $FF;\r\n // add second step array if not yet done\r\n if Categories[First] = nil then\r\n SetLength(Categories[First], 256);\r\n if Categories[First, Second] = nil then\r\n SetLength(Categories[First, Second], 256);\r\n // The array is allocated on the exact size, but the compiler generates\r\n // a 32 bit \"BTS\" instruction that accesses memory beyond the allocated block.\r\n if Third < 255 then\r\n Include(Categories[First, Second, Third], Category)\r\n else\r\n Categories[First, Second, Third] := Categories[First, Second, Third] + [Category];\r\n end;\r\n end;\r\n end;\r\n // Assert(Stream.Position = Stream.Size);\r\n finally\r\n Stream.Free;\r\n end;\r\n finally\r\n LoadInProgress.Leave;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction CategoryLookup(Code: Cardinal; Cats: TCharacterCategories): Boolean; overload;\r\n// determines whether the Code is in the given category\r\nvar\r\n First, Second, Third: Byte;\r\nbegin\r\n Assert(Code < $1000000, LoadResString(@RsCategoryUnicodeChar));\r\n\r\n // load property data if not already done\r\n if not CategoriesLoaded then\r\n LoadCharacterCategories;\r\n\r\n First := (Code shr 16) and $FF;\r\n Second := (Code shr 8) and $FF;\r\n Third := Code and $FF;\r\n if (Categories[First] <> nil) and (Categories[First, Second] <> nil) then\r\n Result := Categories[First, Second, Third] * Cats <> []\r\n else\r\n Result := False;\r\nend;\r\n\r\n//----------------- support for case mapping -------------------------------------------------------\r\n\r\ntype\r\n TCase = array [TCaseType] of TUCS4Array; // mapping for case fold, lower, title and upper in this order\r\n TCaseArray = array of array of TCase;\r\n\r\nvar\r\n // An array for all case mappings (including 1 to many casing if saved by the extraction program).\r\n // The organization is a sparse, two stage matrix.\r\n // SingletonMapping is to quickly return a single default mapping.\r\n CaseDataLoaded: Boolean;\r\n CaseMapping: array [Byte] of TCaseArray;\r\n\r\nprocedure LoadCaseMappingData;\r\nvar\r\n Stream: TJclEasyStream;\r\n I, J, Code, Size: Integer;\r\n First, Second, Third: Byte;\r\nbegin\r\n if not CaseDataLoaded then\r\n begin\r\n // make sure no other code is currently modifying the global data area\r\n LoadInProgress.Enter;\r\n\r\n try\r\n CaseDataLoaded := True;\r\n Stream := OpenResourceStream('CASE');\r\n try\r\n // the first entry in the stream is the number of entries in the case mapping table\r\n Size := Stream.ReadInteger;\r\n for I := 0 to Size - 1 do\r\n begin\r\n // a) read actual code point\r\n Code := StreamReadChar(Stream);\r\n Assert(Code < $1000000, LoadResString(@RsCasedUnicodeChar));\r\n\r\n // if there is no high byte entry in the first stage table then create one\r\n First := (Code shr 16) and $FF;\r\n Second := (Code shr 8) and $FF;\r\n Third := Code and $FF;\r\n if CaseMapping[First] = nil then\r\n SetLength(CaseMapping[First], 256);\r\n if CaseMapping[First, Second] = nil then\r\n SetLength(CaseMapping[First, Second], 256);\r\n\r\n // b) read fold case array\r\n Size := Stream.ReadByte;\r\n if Size > 0 then\r\n begin\r\n SetLength(CaseMapping[First, Second, Third, ctFold], Size);\r\n for J := 0 to Size - 1 do\r\n CaseMapping[First, Second, Third, ctFold, J] := StreamReadChar(Stream);\r\n end;\r\n // c) read lower case array\r\n Size := Stream.ReadByte;\r\n if Size > 0 then\r\n begin\r\n SetLength(CaseMapping[First, Second, Third, ctLower], Size);\r\n for J := 0 to Size - 1 do\r\n CaseMapping[First, Second, Third, ctLower, J] := StreamReadChar(Stream);\r\n end;\r\n // d) read title case array\r\n Size := Stream.ReadByte;\r\n if Size > 0 then\r\n begin\r\n SetLength(CaseMapping[First, Second, Third, ctTitle], Size);\r\n for J := 0 to Size - 1 do\r\n CaseMapping[First, Second, Third, ctTitle, J] := StreamReadChar(Stream);\r\n end;\r\n // e) read upper case array\r\n Size := Stream.ReadByte;\r\n if Size > 0 then\r\n begin\r\n SetLength(CaseMapping[First, Second, Third, ctUpper], Size);\r\n for J := 0 to Size - 1 do\r\n CaseMapping[First, Second, Third, ctUpper, J] := StreamReadChar(Stream);\r\n end;\r\n end;\r\n Assert(Stream.Position = Stream.Size);\r\n finally\r\n Stream.Free;\r\n end;\r\n finally\r\n LoadInProgress.Leave;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction CaseLookup(Code: Cardinal; CaseType: TCaseType; var Mapping: TUCS4Array): Boolean;\r\n// Performs a lookup of the given code; returns True if Found, with Mapping referring to the mapping.\r\n// ctFold is handled specially: if no mapping is found then result of looking up ctLower\r\n// is returned\r\nvar\r\n First, Second, Third: Byte;\r\nbegin\r\n Assert(Code < $1000000, LoadResString(@RsCasedUnicodeChar));\r\n\r\n // load case mapping data if not already done\r\n if not CaseDataLoaded then\r\n LoadCaseMappingData;\r\n\r\n First := (Code shr 16) and $FF;\r\n Second := (Code shr 8) and $FF;\r\n Third := Code and $FF;\r\n // Check first stage table whether there is a mapping for a particular block and\r\n // (if so) then whether there is a mapping or not.\r\n if (CaseMapping[First] <> nil) and (CaseMapping[First, Second] <> nil) and\r\n (CaseMapping[First, Second, Third, CaseType] <> nil) then\r\n Mapping := CaseMapping[First, Second, Third, CaseType]\r\n else\r\n Mapping := nil;\r\n Result := Assigned(Mapping);\r\n // defer to lower case if no fold case exists\r\n if not Result and (CaseType = ctFold) and (CaseMapping[First] <> nil) and\r\n (CaseMapping[First, Second] <> nil) and (CaseMapping[First, Second, Third, ctLower] <> nil) then\r\n begin\r\n Mapping := CaseMapping[First, Second, Third, ctLower];\r\n Result := Assigned(Mapping);\r\n end;\r\nend;\r\n\r\nfunction UnicodeCaseFold(Code: UCS4): TUCS4Array;\r\n// This function returnes an array of special case fold mappings if there is one defined for the given\r\n// code, otherwise the lower case will be returned. This all applies only to cased code points.\r\n// Uncased code points are returned unchanged.\r\nbegin\r\n SetLength(Result, 0);\r\n if not CaseLookup(Code, ctFold, Result) then\r\n begin\r\n SetLength(Result, 1);\r\n Result[0] := Code;\r\n end;\r\nend;\r\n\r\n{$ENDIF ~UNICODE_RTL_DATABASE}\r\n\r\nfunction UnicodeToUpper(Code: UCS4): TUCS4Array;\r\nbegin\r\n {$IFDEF UNICODE_RTL_DATABASE}\r\n SetLength(Result, 1);\r\n Result[0] := Ord(TCharacter.ToUpper(Chr(Code)));\r\n {$ELSE ~UNICODE_RTL_DATABASE}\r\n SetLength(Result, 0);\r\n if not CaseLookup(Code, ctUpper, Result) then\r\n begin\r\n SetLength(Result, 1);\r\n Result[0] := Code;\r\n end;\r\n {$ENDIF ~UNICODE_RTL_DATABASE}\r\nend;\r\n\r\nfunction UnicodeToLower(Code: UCS4): TUCS4Array;\r\nbegin\r\n {$IFDEF UNICODE_RTL_DATABASE}\r\n SetLength(Result, 1);\r\n Result[0] := Ord(TCharacter.ToLower(Chr(Code)));\r\n {$ELSE ~UNICODE_RTL_DATABASE}\r\n SetLength(Result, 0);\r\n if not CaseLookup(Code, ctLower, Result) then\r\n begin\r\n SetLength(Result, 1);\r\n Result[0] := Code;\r\n end;\r\n {$ENDIF ~UNICODE_RTL_DATABASE}\r\nend;\r\n\r\n{$IFNDEF UNICODE_RTL_DATABASE}\r\n\r\nfunction UnicodeToTitle(Code: UCS4): TUCS4Array;\r\nbegin\r\n SetLength(Result, 0);\r\n if not CaseLookup(Code, ctTitle, Result) then\r\n begin\r\n SetLength(Result, 1);\r\n Result[0] := Code;\r\n end;\r\nend;\r\n\r\n//----------------- support for decomposition ------------------------------------------------------\r\n\r\nconst\r\n // constants for hangul composition and hangul-to-jamo decomposition\r\n SBase = $AC00; // hangul syllables start code point\r\n LBase = $1100; // leading syllable\r\n VBase = $1161;\r\n TBase = $11A7; // trailing syllable\r\n LCount = 19;\r\n VCount = 21;\r\n TCount = 28;\r\n NCount = VCount * TCount; // 588\r\n SCount = LCount * NCount; // 11172\r\n\r\ntype\r\n TDecomposition = record\r\n Tag: TCompatibilityFormattingTag;\r\n Leaves: TUCS4Array;\r\n end;\r\n TDecompositions = array of array of TDecomposition;\r\n TDecompositionsArray = array [Byte] of TDecompositions;\r\n\r\nvar\r\n // list of decompositions, organized (again) as three stage matrix\r\n // Note: there are two tables, one for canonical decompositions and the other one\r\n // for compatibility decompositions.\r\n DecompositionsLoaded: Boolean;\r\n Decompositions: TDecompositionsArray;\r\n\r\nprocedure LoadDecompositionData;\r\nvar\r\n Stream: TJclEasyStream;\r\n I, J, Code, Size: Integer;\r\n First, Second, Third: Byte;\r\nbegin\r\n if not DecompositionsLoaded then\r\n begin\r\n // make sure no other code is currently modifying the global data area\r\n LoadInProgress.Enter;\r\n\r\n try\r\n DecompositionsLoaded := True;\r\n Stream := OpenResourceStream('DECOMPOSITION');\r\n try\r\n // determine how many decomposition entries we have\r\n Size := Stream.ReadInteger;\r\n for I := 0 to Size - 1 do\r\n begin\r\n Code := StreamReadChar(Stream);\r\n\r\n Assert(Code < $1000000, LoadResString(@RsDecomposedUnicodeChar));\r\n\r\n First := (Code shr 16) and $FF;\r\n Second := (Code shr 8) and $FF;\r\n Third := Code and $FF;\r\n\r\n // if there is no high byte entry in the first stage table then create one\r\n if Decompositions[First] = nil then\r\n SetLength(Decompositions[First], 256);\r\n if Decompositions[First, Second] = nil then\r\n SetLength(Decompositions[First, Second], 256);\r\n\r\n Size := Stream.ReadByte;\r\n if Size > 0 then\r\n begin\r\n Decompositions[First, Second, Third].Tag := TCompatibilityFormattingTag(Stream.ReadByte);\r\n SetLength(Decompositions[First, Second, Third].Leaves, Size);\r\n for J := 0 to Size - 1 do\r\n Decompositions[First, Second, Third].Leaves[J] := StreamReadChar(Stream);\r\n end;\r\n end;\r\n Assert(Stream.Position = Stream.Size);\r\n finally\r\n Stream.Free;\r\n end;\r\n finally\r\n LoadInProgress.Leave;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction UnicodeDecomposeHangul(Code: UCS4): TUCS4Array;\r\n// algorithmically decomposes hangul character\r\nvar\r\n Rest: Integer;\r\nbegin\r\n Dec(Code, SBase);\r\n Rest := Code mod TCount;\r\n if Rest = 0 then\r\n SetLength(Result, 2)\r\n else\r\n SetLength(Result, 3);\r\n Result[0] := LBase + (Code div NCount);\r\n Result[1] := VBase + ((Code mod NCount) div TCount);\r\n if Rest <> 0 then\r\n Result[2] := TBase + Rest;\r\nend;\r\n\r\nfunction UnicodeDecompose(Code: UCS4; Compatible: Boolean): TUCS4Array;\r\nvar\r\n First, Second, Third: Byte;\r\nbegin\r\n Assert(Code < $1000000, LoadResString(@RsDecomposedUnicodeChar));\r\n\r\n // load decomposition data if not already done\r\n if not DecompositionsLoaded then\r\n LoadDecompositionData;\r\n\r\n Result := nil;\r\n\r\n // if the code is hangul then decomposition is algorithmically\r\n if UnicodeIsHangul(Code) then\r\n Result := UnicodeDecomposeHangul(Code)\r\n else\r\n begin\r\n First := (Code shr 16) and $FF;\r\n Second := (Code shr 8) and $FF;\r\n Third := Code and $FF;\r\n\r\n if (Decompositions[First] <> nil) and (Decompositions[First, Second] <> nil)\r\n and (Decompositions[First, Second, Third].Leaves <> nil)\r\n and (Compatible or (Decompositions[First, Second, Third].Tag = cftCanonical)) then\r\n Result := Decompositions[First, Second, Third].Leaves\r\n else\r\n Result := nil;\r\n end;\r\nend;\r\n\r\nfunction UnicodeDecompose(Code: UCS4; Tags: TCompatibilityFormattingTags): TUCS4Array;\r\nvar\r\n First, Second, Third: Byte;\r\nbegin\r\n Assert(Code < $1000000, LoadResString(@RsDecomposedUnicodeChar));\r\n\r\n // load decomposition data if not already done\r\n if not DecompositionsLoaded then\r\n LoadDecompositionData;\r\n\r\n Result := nil;\r\n\r\n // if the code is hangul then decomposition is algorithmically\r\n if UnicodeIsHangul(Code) then\r\n Result := UnicodeDecomposeHangul(Code)\r\n else\r\n begin\r\n First := (Code shr 16) and $FF;\r\n Second := (Code shr 8) and $FF;\r\n Third := Code and $FF;\r\n\r\n if (Decompositions[First] <> nil) and (Decompositions[First, Second] <> nil)\r\n and (Decompositions[First, Second, Third].Leaves <> nil)\r\n and (Decompositions[First, Second, Third].Tag in Tags) then\r\n Result := Decompositions[First, Second, Third].Leaves\r\n else\r\n Result := nil;\r\n end;\r\nend;\r\n\r\n//----------------- support for combining classes --------------------------------------------------\r\n\r\ntype\r\n TClassArray = array of array of Byte;\r\n\r\nvar\r\n // canonical combining classes, again as two stage matrix\r\n CCCsLoaded: Boolean;\r\n CCCs: array [Byte] of TClassArray;\r\n\r\nprocedure LoadCombiningClassData;\r\nvar\r\n Stream: TJclEasyStream;\r\n I, J, K, Size: Integer;\r\n Buffer: TRangeArray;\r\n First, Second, Third: Byte;\r\nbegin\r\n // make sure no other code is currently modifying the global data area\r\n LoadInProgress.Enter;\r\n\r\n try\r\n if not CCCsLoaded then\r\n begin\r\n CCCsLoaded := True;\r\n Stream := OpenResourceStream('COMBINING');\r\n try\r\n while Stream.Position < Stream.Size do\r\n begin\r\n // a) determine which class is stored here\r\n I := Stream.ReadByte;\r\n // b) determine how many ranges are assigned to this class\r\n Size := Stream.ReadByte;\r\n // c) read start and stop code of each range\r\n if Size > 0 then\r\n begin\r\n SetLength(Buffer, Size);\r\n for J := 0 to Size - 1 do\r\n begin\r\n Buffer[J].Start := StreamReadChar(Stream);\r\n Buffer[J].Stop := StreamReadChar(Stream);\r\n end;\r\n\r\n // d) put this class in every of the code points just loaded\r\n for J := 0 to Size - 1 do\r\n for K := Buffer[J].Start to Buffer[J].Stop do\r\n begin\r\n // (outchy) TODO: handle in a cleaner way\r\n Assert(K < $1000000, LoadResString(@RsCombiningClassUnicodeChar));\r\n First := (K shr 16) and $FF;\r\n Second := (K shr 8) and $FF;\r\n Third := K and $FF;\r\n // add second step array if not yet done\r\n if CCCs[First] = nil then\r\n SetLength(CCCs[First], 256);\r\n if CCCs[First, Second] = nil then\r\n SetLength(CCCs[First, Second], 256);\r\n CCCs[First, Second, Third] := I;\r\n end;\r\n end;\r\n end;\r\n // Assert(Stream.Position = Stream.Size);\r\n finally\r\n Stream.Free;\r\n end;\r\n end;\r\n finally\r\n LoadInProgress.Leave;\r\n end;\r\nend;\r\n\r\nfunction CanonicalCombiningClass(Code: Cardinal): Cardinal;\r\nvar\r\n First, Second, Third: Byte;\r\nbegin\r\n Assert(Code < $1000000, LoadResString(@RsCombiningClassUnicodeChar));\r\n\r\n // load combining class data if not already done\r\n if not CCCsLoaded then\r\n LoadCombiningClassData;\r\n\r\n First := (Code shr 16) and $FF;\r\n Second := (Code shr 8) and $FF;\r\n Third := Code and $FF;\r\n if (CCCs[First] <> nil) and (CCCs[First, Second] <> nil) then\r\n Result := CCCs[First, Second, Third]\r\n else\r\n Result := 0;\r\nend;\r\n\r\n//----------------- support for numeric values -----------------------------------------------------\r\n\r\ntype\r\n // structures for handling numbers\r\n TCodeIndex = record\r\n Code,\r\n Index: Cardinal;\r\n end;\r\n\r\nvar\r\n // array to hold the number equivalents for specific codes\r\n NumberCodes: array of TCodeIndex;\r\n // array of numbers used in NumberCodes\r\n Numbers: array of TUcNumber;\r\n\r\nprocedure LoadNumberData;\r\nvar\r\n Stream: TJclEasyStream;\r\n Size, I: Integer;\r\nbegin\r\n // make sure no other code is currently modifying the global data area\r\n LoadInProgress.Enter;\r\n\r\n try\r\n if NumberCodes = nil then\r\n begin\r\n Stream := OpenResourceStream('NUMBERS');\r\n try\r\n // Numbers are special (compared to other Unicode data) as they utilize two\r\n // arrays, one containing all used numbers (in nominator-denominator format) and\r\n // another one which maps a code point to one of the numbers in the first array.\r\n\r\n // a) determine size of numbers array\r\n Size := Stream.ReadByte;\r\n SetLength(Numbers, Size);\r\n // b) read numbers data\r\n for I := 0 to Size - 1 do\r\n begin\r\n Numbers[I].Numerator := Stream.ReadInteger;\r\n Numbers[I].Denominator := Stream.ReadInteger;\r\n end;\r\n // c) determine size of index array\r\n Size := Stream.ReadInteger;\r\n SetLength(NumberCodes, Size);\r\n // d) read index data\r\n for I := 0 to Size - 1 do\r\n begin\r\n NumberCodes[I].Code := StreamReadChar(Stream);\r\n NumberCodes[I].Index := Stream.ReadByte;\r\n end;\r\n Assert(Stream.Position = Stream.Size);\r\n finally\r\n Stream.Free;\r\n end;\r\n end;\r\n finally\r\n LoadInProgress.Leave;\r\n end;\r\nend;\r\n\r\nfunction UnicodeNumberLookup(Code: UCS4; var Number: TUcNumber): Boolean;\r\n// Searches for the given code and returns its number equivalent (if there is one).\r\n// Typical cases are: '1/6' (U+2159), '3/8' (U+215C), 'XII' (U+216B) etc.\r\n// Result is set to True if the code could be found.\r\nvar\r\n L, R, M: Integer;\r\nbegin\r\n // load number data if not already done\r\n if NumberCodes = nil then\r\n LoadNumberData;\r\n\r\n Result := False;\r\n L := 0;\r\n R := High(NumberCodes);\r\n while L <= R do\r\n begin\r\n M := (L + R) shr 1;\r\n if Code > NumberCodes[M].Code then\r\n L := M + 1\r\n else\r\n begin\r\n if Code < NumberCodes[M].Code then\r\n R := M - 1\r\n else\r\n begin\r\n Number := Numbers[NumberCodes[M].Index];\r\n Result := True;\r\n Break;\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\n//----------------- support for composition --------------------------------------------------------\r\n\r\ntype\r\n // maps between a pair of code points to a composite code point\r\n // Note: the source pair is packed into one 4 byte value to speed up search.\r\n TComposition = record\r\n Code: Cardinal;\r\n Tag: TCompatibilityFormattingTag;\r\n First: Cardinal;\r\n Next: array of Cardinal;\r\n end;\r\n\r\nvar\r\n // list of composition mappings\r\n Compositions: array of TComposition;\r\n MaxCompositionSize: Integer;\r\n\r\nprocedure LoadCompositionData;\r\nvar\r\n Stream: TJclEasyStream;\r\n I, J, Size: Integer;\r\nbegin\r\n // make sure no other code is currently modifying the global data area\r\n LoadInProgress.Enter;\r\n\r\n try\r\n if Compositions = nil then\r\n begin\r\n Stream := OpenResourceStream('COMPOSITION');\r\n try\r\n // a) determine size of compositions array\r\n Size := Stream.ReadInteger;\r\n SetLength(Compositions, Size);\r\n // b) read data\r\n for I := 0 to Size - 1 do\r\n begin\r\n Compositions[I].Code := StreamReadChar(Stream);\r\n Size := Stream.ReadByte;\r\n if Size > MaxCompositionSize then\r\n MaxCompositionSize := Size;\r\n SetLength(Compositions[I].Next, Size - 1);\r\n Compositions[I].Tag := TCompatibilityFormattingTag(Stream.ReadByte);\r\n Compositions[I].First := StreamReadChar(Stream);\r\n for J := 0 to Size - 2 do\r\n Compositions[I].Next[J] := StreamReadChar(Stream);\r\n end;\r\n Assert(Stream.Position = Stream.Size);\r\n finally\r\n Stream.Free;\r\n end;\r\n end;\r\n finally\r\n LoadInProgress.Leave;\r\n end;\r\nend;\r\n\r\nfunction UnicodeCompose(const Codes: array of UCS4; out Composite: UCS4; Compatible: Boolean): Integer;\r\n// Maps the sequence of Codes (up to MaxCompositionSize codes) to a composite\r\n// Result is the number of Codes that were composed (at least 1 if Codes is not empty)\r\nvar\r\n L, R, M, I, HighCodes, HighNext: Integer;\r\nbegin\r\n if Compositions = nil then\r\n LoadCompositionData;\r\n\r\n Result := 0;\r\n HighCodes := High(Codes);\r\n\r\n if HighCodes = -1 then\r\n Exit;\r\n\r\n if HighCodes = 0 then\r\n begin\r\n Result := 1;\r\n Composite := Codes[0];\r\n Exit;\r\n end;\r\n\r\n L := 0;\r\n R := High(Compositions);\r\n\r\n while L <= R do\r\n begin\r\n M := (L + R) shr 1;\r\n if Compositions[M].First > Codes[0] then\r\n R := M - 1\r\n else\r\n if Compositions[M].First < Codes[0] then\r\n L := M + 1\r\n else\r\n begin\r\n // back to the first element where Codes[0] = First\r\n while (M > 0) and (Compositions[M-1].First = Codes[0]) do\r\n Dec(M);\r\n\r\n while (M <= High(Compositions)) and (Compositions[M].First = Codes[0]) do\r\n begin\r\n HighNext := High(Compositions[M].Next);\r\n Result := 0;\r\n\r\n if (HighNext < HighCodes) // enough characters in buffer to be tested\r\n and (Compatible or (Compositions[M].Tag = cftCanonical)) then\r\n begin\r\n for I := 0 to HighNext do\r\n if Compositions[M].Next[I] = Codes[I + 1] then\r\n Result := I + 2 { +1 for first, +1 because of 0-based array }\r\n else\r\n Break;\r\n\r\n if Result = HighNext + 2 then // all codes matched\r\n begin\r\n Composite := Compositions[M].Code;\r\n Exit;\r\n end;\r\n end;\r\n\r\n Inc(M);\r\n end;\r\n Break;\r\n end;\r\n end;\r\n Result := 1;\r\n Composite := Codes[0];\r\nend;\r\n\r\nfunction UnicodeCompose(const Codes: array of UCS4; out Composite: UCS4; Tags: TCompatibilityFormattingTags): Integer;\r\n// Maps the sequence of Codes (up to MaxCompositionSize codes) to a composite\r\n// Result is the number of Codes that were composed (at least 1 if Codes is not empty)\r\nvar\r\n L, R, M, I, HighCodes, HighNext: Integer;\r\nbegin\r\n if Compositions = nil then\r\n LoadCompositionData;\r\n\r\n Result := 0;\r\n HighCodes := High(Codes);\r\n\r\n if HighCodes = -1 then\r\n Exit;\r\n\r\n if HighCodes = 0 then\r\n begin\r\n Result := 1;\r\n Composite := Codes[0];\r\n Exit;\r\n end;\r\n\r\n L := 0;\r\n R := High(Compositions);\r\n\r\n while L <= R do\r\n begin\r\n M := (L + R) shr 1;\r\n if Compositions[M].First > Codes[0] then\r\n R := M - 1\r\n else\r\n if Compositions[M].First < Codes[0] then\r\n L := M + 1\r\n else\r\n begin\r\n // back to the first element where Codes[0] = First\r\n while (M > 0) and (Compositions[M-1].First = Codes[0]) do\r\n Dec(M);\r\n\r\n while (M <= High(Compositions)) and (Compositions[M].First = Codes[0]) do\r\n begin\r\n HighNext := High(Compositions[M].Next);\r\n Result := 0;\r\n\r\n if (HighNext < HighCodes) // enough characters in buffer to be tested\r\n and (Compositions[M].Tag in Tags) then\r\n begin\r\n for I := 0 to HighNext do\r\n if Compositions[M].Next[I] = Codes[I + 1] then\r\n Result := I + 2 { +1 for first, +1 because of 0-based array }\r\n else\r\n Break;\r\n\r\n if Result = HighNext + 2 then // all codes matched\r\n begin\r\n Composite := Compositions[M].Code;\r\n Exit;\r\n end;\r\n end;\r\n\r\n Inc(M);\r\n end;\r\n Break;\r\n end;\r\n end;\r\n Result := 1;\r\n Composite := Codes[0];\r\nend;\r\n\r\n//=== { TSearchEngine } ======================================================\r\n\r\nconstructor TSearchEngine.Create(AOwner: TWideStrings);\r\nbegin\r\n inherited Create;\r\n FOwner := AOwner;\r\n FResults := TList.Create;\r\nend;\r\n\r\ndestructor TSearchEngine.Destroy;\r\nbegin\r\n Clear;\r\n FResults.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TSearchEngine.AddResult(Start, Stop: SizeInt);\r\nbegin\r\n FResults.Add(Pointer(Start));\r\n FResults.Add(Pointer(Stop));\r\nend;\r\n\r\nprocedure TSearchEngine.Clear;\r\nbegin\r\n ClearResults;\r\nend;\r\n\r\nprocedure TSearchEngine.ClearResults;\r\nbegin\r\n FResults.Clear;\r\nend;\r\n\r\nprocedure TSearchEngine.DeleteResult(Index: SizeInt);\r\n// explicitly deletes a search result\r\nbegin\r\n with FResults do\r\n begin\r\n // start index\r\n Delete(2 * Index);\r\n // stop index\r\n Delete(2 * Index);\r\n end;\r\nend;\r\n\r\nfunction TSearchEngine.GetCount: SizeInt;\r\n// returns the number of matches found\r\nbegin\r\n Result := FResults.Count div 2;\r\nend;\r\n\r\nprocedure TSearchEngine.GetResult(Index: SizeInt; var Start, Stop: SizeInt);\r\n// returns the start position of a match (end position can be determined by\r\n// adding the length of the pattern to the start position)\r\nbegin\r\n Start := SizeInt(FResults[2 * Index]);\r\n Stop := SizeInt(FResults[2 * Index + 1]);\r\nend;\r\n\r\n//----------------- TUTBSearch ---------------------------------------------------------------------\r\n\r\nprocedure TUTBMSearch.ClearPattern;\r\nbegin\r\n FreeMem(FPattern);\r\n FPattern := nil;\r\n FFlags := [];\r\n FPatternUsed := 0;\r\n FPatternSize := 0;\r\n FPatternLength := 0;\r\n FreeMem(FSkipValues);\r\n FSkipValues := nil;\r\n FSkipsUsed := 0;\r\n FMD4 := 0;\r\nend;\r\n\r\nfunction TUTBMSearch.GetSkipValue(TextStart, TextEnd: PUCS2): SizeInt;\r\n// looks up the SkipValues value for a character\r\nvar\r\n I: SizeInt;\r\n C1,\r\n C2: UCS4;\r\n Sp: PUTBMSkip;\r\nbegin\r\n Result := 0;\r\n if TJclAddr(TextStart) < TJclAddr(TextEnd) then\r\n begin\r\n C1 := UCS4(TextStart^);\r\n if (TextStart + 1) < TextEnd then\r\n C2 := UCS4((TextStart + 1)^)\r\n else\r\n C2 := $FFFFFFFF;\r\n if (SurrogateHighStart <= C1) and (C1 <= SurrogateHighEnd) and\r\n (SurrogateLowStart <= C2) and (C2 <= $DDDD) then\r\n C1 := $10000 + (((C1 and $03FF) shl 10) or (C2 and $03FF));\r\n\r\n Sp := FSkipValues;\r\n for I := 0 to FSkipsUsed - 1 do\r\n begin\r\n if not (Boolean(C1 xor Sp.BMChar.UpCase) and\r\n Boolean(C1 xor Sp.BMChar.LoCase) and\r\n Boolean(C1 xor Sp.BMChar.TitleCase)) then\r\n begin\r\n if (TextEnd - TextStart) < Sp.SkipValues then\r\n Result := TextEnd - TextStart\r\n else\r\n Result := Sp.SkipValues;\r\n Exit;\r\n end;\r\n Inc(Sp);\r\n end;\r\n Result := FPatternLength;\r\n end;\r\nend;\r\n\r\nfunction TUTBMSearch.Match(Text, Start, Stop: PUCS2; var MatchStart, MatchEnd: SizeInt): Boolean;\r\n// Checks once whether the text at position Start (which points to the end of the\r\n// current text part to be matched) matches.\r\n// Note: If whole words only are allowed then the left and right border tests are\r\n// done here too. The keypoint for the right border is that the next character\r\n// after the search string is either the text end or a space character.\r\n// For the left side this is similar, but there is nothing like a string\r\n// start marker (like the string end marker #0).\r\n//\r\n// It seems not obvious, but we still can use the passed Text pointer to do\r\n// the left check. Although this pointer might not point to the real string\r\n// start (e.g. in TUTBMSearch.FindAll Text is incremented as needed) it is\r\n// still a valid check mark. The reason is that Text either points to the\r\n// real string start or a previous match (happend already, keep in mind the\r\n// search options do not change in the FindAll loop) and the character just\r\n// before Text is a space character.\r\n// This fact implies, though, that strings passed to Find (or FindFirst,\r\n// FindAll in TUTBMSearch) always really start at the given address. Although\r\n// this might not be the case in some circumstances (e.g. if you pass only\r\n// the selection from an editor) it is still assumed that a pattern matching\r\n// from the first position on (from the search string start) also matches\r\n// when whole words only are allowed.\r\nvar\r\n CheckSpace: Boolean;\r\n C1, C2: UCS4;\r\n Count: SizeInt;\r\n Cp: PUTBMChar;\r\nbegin\r\n // be pessimistic\r\n Result := False;\r\n\r\n // set the potential match endpoint first\r\n MatchEnd := (Start - Text) + 1;\r\n\r\n C1 := UCS4(Start^);\r\n if (Start + 1) < Stop then\r\n C2 := UCS4((Start + 1)^)\r\n else\r\n C2 := $FFFFFFFF;\r\n if (SurrogateHighStart <= C1) and (C1 <= SurrogateHighEnd) and\r\n (SurrogateLowStart <= C2) and (C2 <= SurrogateLowEnd) then\r\n begin\r\n C1 := $10000 + (((C1 and $03FF) shl 10) or (C2 and $03FF));\r\n // Adjust the match end point to occur after the UTF-16 character.\r\n Inc(MatchEnd);\r\n end;\r\n\r\n // check special cases\r\n if FPatternUsed = 1 then\r\n begin\r\n MatchStart := Start - Text;\r\n Result := True;\r\n Exit;\r\n end;\r\n\r\n // Early out if entire words need to be matched and the next character\r\n // in the search string is neither the string end nor a space character.\r\n if (sfWholeWordOnly in FFlags) and\r\n not ((Start + 1)^ = WideNull) and\r\n not UnicodeIsWhiteSpace(UCS4((Start + 1)^)) then\r\n Exit;\r\n\r\n // compare backward\r\n Cp := FPattern;\r\n Inc(Cp, FPatternUsed - 1);\r\n\r\n Count := FPatternLength;\r\n while (Start >= Text) and (Count > 0) do\r\n begin\r\n // ignore non-spacing characters if indicated\r\n if sfIgnoreNonSpacing in FFlags then\r\n begin\r\n while (Start > Text) and UnicodeIsNonSpacing(C1) do\r\n begin\r\n Dec(Start);\r\n C2 := UCS4(Start^);\r\n if (Start - 1) > Text then\r\n C1 := UCS4((Start - 1)^)\r\n else\r\n C1 := $FFFFFFFF;\r\n if (SurrogateLowStart <= C2) and (C2 <= SurrogateLowEnd) and\r\n (SurrogateHighStart <= C1) and (C1 <= SurrogateHighEnd) then\r\n begin\r\n C1 := $10000 + (((C1 and $03FF) shl 10) or (C2 and $03FF));\r\n Dec(Start);\r\n end\r\n else\r\n C1 := C2;\r\n end;\r\n end;\r\n\r\n // handle space compression if indicated\r\n if sfSpaceCompress in FFlags then\r\n begin\r\n CheckSpace := False;\r\n while (Start > Text) and (UnicodeIsWhiteSpace(C1) or UnicodeIsControl(C1)) do\r\n begin\r\n CheckSpace := UnicodeIsWhiteSpace(C1);\r\n Dec(Start);\r\n C2 := UCS4(Start^);\r\n if (Start - 1) > Text then\r\n C1 := UCS4((Start - 1)^)\r\n else\r\n C1 := $FFFFFFFF;\r\n if (SurrogateLowStart <= C2) and (C2 <= SurrogateLowEnd) and\r\n (SurrogateHighStart <= C1) and (C1 <= SurrogateHighEnd) then\r\n begin\r\n C1 := $10000 + (((C1 and $03FF) shl 10) or (C2 and $03FF));\r\n Dec(Start);\r\n end\r\n else\r\n C1 := C2;\r\n end;\r\n // Handle things if space compression was indicated and one or\r\n // more member characters were found.\r\n if CheckSpace then\r\n begin\r\n if Cp.UpCase <> $20 then\r\n Exit;\r\n Dec(Cp);\r\n Dec(Count);\r\n // If Count is 0 at this place then the space character(s) was the first\r\n // in the pattern and we need to correct the start position.\r\n if Count = 0 then\r\n Inc(Start);\r\n end;\r\n end;\r\n\r\n // handle the normal comparison cases\r\n if (Count > 0) and\r\n (Boolean(C1 xor Cp.UpCase) and\r\n Boolean(C1 xor Cp.LoCase) and\r\n Boolean(C1 xor Cp.TitleCase)) then\r\n Exit;\r\n\r\n if C1 >= $10000 then\r\n Dec(Count, 2)\r\n else\r\n Dec(Count, 1);\r\n if Count > 0 then\r\n begin\r\n Dec(Cp);\r\n // get the next preceding character\r\n if Start > Text then\r\n begin\r\n Dec(Start);\r\n C2 := UCS4(Start^);\r\n if (Start - 1) > Text then\r\n C1 := UCS4((Start - 1)^)\r\n else\r\n C1 := $FFFFFFFF;\r\n if (SurrogateLowStart <= C2) and (C2 <= SurrogateLowEnd) and\r\n (SurrogateHighStart <= C1) and (C1 <= SurrogateHighEnd) then\r\n begin\r\n C1 := $10000 + (((C1 and $03FF) shl 10) or (C2 and $03FF));\r\n Dec(Start);\r\n end\r\n else\r\n C1 := C2;\r\n end;\r\n end;\r\n end;\r\n\r\n // So far the string matched. Now check its left border for a space character\r\n // if whole word only are allowed.\r\n if not (sfWholeWordOnly in FFlags) or\r\n (Start <= Text) or\r\n UnicodeIsWhiteSpace(UCS4((Start - 1)^)) then\r\n begin\r\n // set the match start position\r\n MatchStart := Start - Text;\r\n Result := True;\r\n end;\r\nend;\r\n\r\nprocedure TUTBMSearch.Compile(Pattern: PUCS2; PatternLength: SizeInt; Flags: TSearchFlags);\r\nvar\r\n HaveSpace: Boolean;\r\n I, J, K,\r\n SLen: SizeInt;\r\n Cp: PUTBMChar;\r\n Sp: PUTBMSkip;\r\n C1, C2,\r\n Sentinel: UCS4;\r\nbegin\r\n if (Pattern <> nil) and (Pattern^ <> #0) and (PatternLength > 0) then\r\n begin\r\n // do some initialization\r\n FFlags := Flags;\r\n // extra skip flag\r\n FMD4 := 1;\r\n\r\n Sentinel := 0;\r\n\r\n // allocate more storage if necessary\r\n FPattern := AllocMem(SizeOf(TUTBMChar) * PatternLength);\r\n FSkipValues := AllocMem(SizeOf(TUTBMSkip) * PatternLength);\r\n FPatternSize := PatternLength;\r\n\r\n // Preprocess the pattern to remove controls (if specified) and determine case.\r\n Cp := FPattern;\r\n I := 0;\r\n HaveSpace := False;\r\n while I < PatternLength do\r\n begin\r\n C1 := UCS4(Pattern[I]);\r\n if (I + 1) < PatternLength then\r\n C2 := UCS4(Pattern[I + 1])\r\n else\r\n C2 := $FFFFFFFF;\r\n if (SurrogateHighStart <= C1) and (C1 <= SurrogateHighEnd) and\r\n (SurrogateLowStart <= C2) and (C2 <= SurrogateLowEnd) then\r\n C1 := $10000 + (((C1 and $03FF) shl 10) or (C2 and $03FF));\r\n\r\n // Make sure the HaveSpace flag is turned off if the character is not an\r\n // appropriate one.\r\n if not UnicodeIsWhiteSpace(C1) then\r\n HaveSpace := False;\r\n\r\n // If non-spacing characters should be ignored, do it here.\r\n if (sfIgnoreNonSpacing in Flags) and UnicodeIsNonSpacing(C1) then\r\n begin\r\n Inc(I);\r\n Continue;\r\n end;\r\n\r\n // check if spaces and controls need to be compressed\r\n if sfSpaceCompress in Flags then\r\n begin\r\n if UnicodeIsWhiteSpace(C1) then\r\n begin\r\n if not HaveSpace then\r\n begin\r\n // Add a space and set the flag.\r\n Cp.UpCase := $20;\r\n Cp.LoCase := $20;\r\n Cp.TitleCase := $20;\r\n Inc(Cp);\r\n\r\n // increase the real pattern length\r\n Inc(FPatternLength);\r\n Sentinel := $20;\r\n HaveSpace := True;\r\n end;\r\n Inc(I);\r\n Continue;\r\n end;\r\n\r\n // ignore all control characters\r\n if UnicodeIsControl(C1) then\r\n begin\r\n Inc(I);\r\n Continue;\r\n end;\r\n end;\r\n\r\n // add the character\r\n if not (sfCaseSensitive in Flags) then\r\n begin\r\n { TODO : use the entire mapping, not only the first character }\r\n Cp.UpCase := UnicodeToUpper(C1)[0];\r\n Cp.LoCase := UnicodeToLower(C1)[0];\r\n Cp.TitleCase := UnicodeToTitle(C1)[0];\r\n end\r\n else\r\n begin\r\n Cp.UpCase := C1;\r\n Cp.LoCase := C1;\r\n Cp.TitleCase := C1;\r\n end;\r\n\r\n Sentinel := Cp.UpCase;\r\n\r\n // move to the next character\r\n Inc(Cp);\r\n\r\n // increase the real pattern length appropriately\r\n if C1 >= $10000 then\r\n Inc(FPatternLength, 2)\r\n else\r\n Inc(FPatternLength);\r\n\r\n // increment the loop index for UTF-16 characters\r\n if C1 > $10000 then\r\n Inc(I, 2)\r\n else\r\n Inc(I);\r\n end;\r\n\r\n // set the number of characters actually used\r\n FPatternUsed := (TJclAddr(Cp) - TJclAddr(FPattern)) div SizeOf(TUTBMChar);\r\n\r\n // Go through and construct the skip array and determine the actual length\r\n // of the pattern in UCS2 terms.\r\n SLen := FPatternLength - 1;\r\n Cp := FPattern;\r\n K := 0;\r\n for I := 0 to FPatternUsed - 1 do\r\n begin\r\n // locate the character in the FSkipValues array\r\n Sp := FSkipValues;\r\n J := 0;\r\n while (J < FSkipsUsed) and (Sp.BMChar.UpCase <> Cp.UpCase) do\r\n begin\r\n Inc(J);\r\n Inc(Sp);\r\n end;\r\n\r\n // If the character is not found, set the new FSkipValues element and\r\n // increase the number of FSkipValues elements.\r\n if J = FSkipsUsed then\r\n begin\r\n Sp.BMChar := Cp;\r\n Inc(FSkipsUsed);\r\n end;\r\n\r\n // Set the updated FSkipValues value. If the character is UTF-16 and is\r\n // not the last one in the pattern, add one to its FSkipValues value.\r\n Sp.SkipValues := SLen - K;\r\n if (Cp.UpCase >= $10000) and ((K + 2) < SLen) then\r\n Inc(Sp.SkipValues);\r\n\r\n // set the new extra FSkipValues for the sentinel character\r\n if ((Cp.UpCase >= $10000) and\r\n ((K + 2) <= SLen) or ((K + 1) <= SLen) and\r\n (Cp.UpCase = Sentinel)) then\r\n FMD4 := SLen - K;\r\n\r\n // increase the actual index\r\n if Cp.UpCase >= $10000 then\r\n Inc(K, 2)\r\n else\r\n Inc(K);\r\n Inc(Cp);\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TUTBMSearch.Find(Text: PUCS2; TextLen: SizeInt; var MatchStart, MatchEnd: SizeInt): Boolean;\r\n// this is the main matching routine using a tuned Boyer-Moore algorithm\r\nvar\r\n K: SizeInt;\r\n Start,\r\n Stop: PUCS2;\r\nbegin\r\n Result := False;\r\n if (FPattern <> nil) and (FPatternUsed > 0) and (Text <> nil) and\r\n (TextLen > 0) and (TextLen >= FPatternLength) then\r\n begin\r\n Start := Text + FPatternLength - 1;\r\n Stop := Text + TextLen;\r\n\r\n // adjust the start point if it points to a low surrogate\r\n if (SurrogateLowStart <= UCS4(Start^)) and\r\n (UCS4(Start^) <= SurrogateLowEnd) and\r\n (SurrogateHighStart <= UCS4((Start - 1)^)) and\r\n (UCS4((Start - 1)^) <= SurrogateHighEnd) then\r\n Dec(Start);\r\n\r\n while Start < Stop do\r\n begin\r\n repeat\r\n K := GetSkipValue(Start, Stop);\r\n if K = 0 then\r\n Break;\r\n Inc(Start, K);\r\n if (Start < Stop) and\r\n (SurrogateLowStart <= UCS4(Start^)) and\r\n (UCS4(Start^) <= SurrogateLowEnd) and\r\n (SurrogateHighStart <= UCS4((Start - 1)^)) and\r\n (UCS4((Start - 1)^) <= SurrogateHighEnd) then\r\n Dec(Start);\r\n until False;\r\n\r\n if (Start < Stop) and Match(Text, Start, Stop, MatchStart, MatchEnd) then\r\n begin\r\n Result := True;\r\n Break;\r\n end;\r\n Inc(Start, FMD4);\r\n if (Start < Stop) and\r\n (SurrogateLowStart <= UCS4(Start^)) and\r\n (UCS4(Start^) <= SurrogateLowEnd) and\r\n (SurrogateHighStart <= UCS4((Start - 1)^)) and\r\n (UCS4((Start - 1)^) <= SurrogateHighEnd) then\r\n Dec(Start);\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TUTBMSearch.Clear;\r\nbegin\r\n ClearPattern;\r\n inherited Clear;\r\nend;\r\n\r\nfunction TUTBMSearch.FindAll(const Text: WideString): Boolean;\r\nbegin\r\n Result := FindAll(PWideChar(Text), Length(Text));\r\nend;\r\n\r\nfunction TUTBMSearch.FindAll(Text: PWideChar; TextLen: SizeInt): Boolean;\r\n// Looks for all occurences of the pattern passed to FindPrepare and creates an\r\n// internal list of their positions.\r\nvar\r\n Start, Stop: SizeInt;\r\n Run: PWideChar;\r\n RunLen: SizeInt;\r\nbegin\r\n ClearResults;\r\n Run := Text;\r\n RunLen := TextLen;\r\n Start := 0;\r\n Stop := 0;\r\n // repeat to find all occurences of the pattern\r\n while Find(Run, RunLen, Start, Stop) do\r\n begin\r\n // store this result (consider text pointer movement)...\r\n AddResult(Start + (Run - Text), Stop + (Run - Text));\r\n // ... and advance text position and length\r\n Inc(Run, Stop);\r\n Dec(RunLen, Stop);\r\n end;\r\n Result := Count > 0;\r\nend;\r\n\r\nfunction TUTBMSearch.FindFirst(const Text: WideString; var Start, Stop: SizeInt): Boolean;\r\n// Looks for the first occurence of the pattern passed to FindPrepare in Text and\r\n// returns True if one could be found (in which case Start and Stop are set to\r\n// the according indices) otherwise False. This function is in particular of\r\n// interest if only one occurence needs to be found.\r\nbegin\r\n ClearResults;\r\n Result := Find(PWideChar(Text), Length(Text), Start, Stop);\r\n if Result then\r\n AddResult(Start, Stop);\r\nend;\r\n\r\nfunction TUTBMSearch.FindFirst(Text: PWideChar; TextLen: SizeInt; var Start, Stop: SizeInt): Boolean;\r\n// Same as the WideString version of this method.\r\nbegin\r\n ClearResults;\r\n Result := Find(Text, TextLen, Start, Stop);\r\n if Result then\r\n AddResult(Start, Stop);\r\nend;\r\n\r\nprocedure TUTBMSearch.FindPrepare(const Pattern: WideString; Options: TSearchFlags);\r\nbegin\r\n FindPrepare(PWideChar(Pattern), Length(Pattern), Options);\r\nend;\r\n\r\nprocedure TUTBMSearch.FindPrepare(Pattern: PWideChar; PatternLength: SizeInt; Options: TSearchFlags);\r\n// prepares following search by compiling the given pattern into an internal structure\r\nbegin\r\n Compile(Pattern, PatternLength, Options);\r\nend;\r\n\r\n//----------------- Unicode RE search core ---------------------------------------------------------\r\n\r\nconst\r\n // error codes\r\n _URE_OK = 0;\r\n _URE_UNEXPECTED_EOS = -1;\r\n _URE_CCLASS_OPEN = -2;\r\n _URE_UNBALANCED_GROUP = -3;\r\n _URE_INVALID_PROPERTY = -4;\r\n _URE_INVALID_RANGE = -5;\r\n _URE_RANGE_OPEN = -6;\r\n\r\n // options that can be combined for searching\r\n URE_IGNORE_NONSPACING = $01;\r\n URE_DONT_MATCHES_SEPARATORS = $02;\r\n\r\nconst\r\n // Flags used internally in the DFA\r\n _URE_DFA_CASEFOLD = $01;\r\n _URE_DFA_BLANKLINE = $02;\r\n\r\n // symbol types for the DFA\r\n _URE_ANY_CHAR = 1;\r\n _URE_CHAR = 2;\r\n _URE_CCLASS = 3;\r\n _URE_NCCLASS = 4;\r\n _URE_BOL_ANCHOR = 5;\r\n _URE_EOL_ANCHOR = 6;\r\n\r\n // op codes for converting the NFA to a DFA\r\n _URE_SYMBOL = 10;\r\n _URE_PAREN = 11;\r\n _URE_QUEST = 12;\r\n _URE_STAR = 13;\r\n _URE_PLUS = 14;\r\n _URE_ONE = 15;\r\n _URE_AND = 16;\r\n _URE_OR = 17;\r\n\r\n _URE_NOOP = $FFFF;\r\n\r\n//----------------- TURESearch ---------------------------------------------------------------------\r\n\r\nprocedure TURESearch.Clear;\r\nbegin\r\n inherited Clear;\r\n ClearUREBuffer;\r\n ClearDFA;\r\nend;\r\n\r\nprocedure TURESearch.Push(V: SizeInt);\r\nbegin\r\n with FUREBuffer do\r\n begin\r\n // If the 'Reducing' parameter is True, check to see if the value passed is\r\n // already on the stack.\r\n if Reducing and ExpressionList.Expressions[Word(V)].OnStack then\r\n Exit;\r\n\r\n if Stack.ListUsed = Length(Stack.List) then\r\n SetLength(Stack.List, Length(Stack.List) + 8);\r\n Stack.List[Stack.ListUsed] := V;\r\n Inc(Stack.ListUsed);\r\n\r\n // If the 'reducing' parameter is True, flag the element as being on the Stack.\r\n if Reducing then\r\n ExpressionList.Expressions[Word(V)].OnStack := True;\r\n end;\r\nend;\r\n\r\nfunction TURESearch.Peek: SizeInt;\r\nbegin\r\n if FUREBuffer.Stack.ListUsed = 0 then\r\n Result := _URE_NOOP\r\n else\r\n Result := FUREBuffer.Stack.List[FUREBuffer.Stack.ListUsed - 1];\r\nend;\r\n\r\nfunction TURESearch.Pop: SizeInt;\r\nbegin\r\n if FUREBuffer.Stack.ListUsed = 0 then\r\n Result := _URE_NOOP\r\n else\r\n begin\r\n Dec(FUREBuffer.Stack.ListUsed);\r\n Result := FUREBuffer.Stack.List[FUREBuffer.Stack.ListUsed];\r\n if FUREBuffer.Reducing then\r\n FUREBuffer.ExpressionList.Expressions[Word(Result)].OnStack := False;\r\n end;\r\nend;\r\n\r\nfunction TURESearch.ParsePropertyList(Properties: PUCS2; Limit: SizeInt;\r\n var Categories: TCharacterCategories): SizeInt;\r\n// Parse a comma-separated list of integers that represent character properties.\r\n// Combine them into a set of categories and return the number of characters consumed.\r\nvar\r\n N: SizeInt;\r\n Run,\r\n ListEnd: PUCS2;\r\nbegin\r\n Run := Properties;\r\n ListEnd := Run + Limit;\r\n\r\n N := 0;\r\n Categories := [];\r\n while (FUREBuffer.Error = _URE_OK) and (Run < ListEnd) do\r\n begin\r\n if Run^ = ',' then\r\n begin\r\n // Encountered a comma, so take the number parsed so far as category and\r\n // reset the number.\r\n Include(Categories, TCharacterCategory(N));\r\n N := 0;\r\n end\r\n else\r\n begin\r\n if (Run^ >= '0') and (Run^ <= '9') then\r\n begin\r\n // Encountered a digit, so start or continue building the SizeInt that\r\n // represents the character category.\r\n N := (N * 10) + SizeInt(Word(Run^) - Ord('0'));\r\n end\r\n else\r\n begin\r\n // Encountered something that is not part of the property list.\r\n // Indicate that we are done.\r\n Break;\r\n end;\r\n end;\r\n\r\n // If the number is to large then there is a problem.\r\n // Most likely a missing comma separator.\r\n if SizeInt(N) > Ord(High(TCharacterCategory)) then\r\n FUREBuffer.Error := _URE_INVALID_PROPERTY;\r\n Inc(Run);\r\n end;\r\n\r\n // Return the number of characters consumed.\r\n Result := Run - Properties;\r\nend;\r\n\r\nfunction TURESearch.MakeHexNumber(NP: PUCS2; Limit: SizeInt; var Number: UCS4): SizeInt;\r\n// Collect a hex number with 1 to 4 digits and return the number of characters used.\r\nvar\r\n I: SizeInt;\r\n Run,\r\n ListEnd: PUCS2;\r\nbegin\r\n Run := np;\r\n ListEnd := Run + Limit;\r\n\r\n Number := 0;\r\n I := 0;\r\n while (I < 4) and (Run < ListEnd) do\r\n begin\r\n if (Run^ >= '0') and (Run^ <= '9') then\r\n Number := (Number shl 4) or (Cardinal(Word(Run^) - Ord('0')))\r\n else\r\n begin\r\n if (Run^ >= 'A') and (Run^ <= 'F') then\r\n Number := (Number shl 4) or (Cardinal(Word(Run^) - Ord('A')) + 10)\r\n else\r\n begin\r\n if (Run^ >= 'a') and (Run^ <= 'f') then\r\n Number := (Number shl 4) or (Cardinal(Word(Run^) - Ord('a')) + 10)\r\n else\r\n Break;\r\n end;\r\n end;\r\n Inc(I);\r\n Inc(Run);\r\n end;\r\n\r\n Result := Run - NP;\r\nend;\r\n\r\nprocedure TURESearch.AddRange(var CCL: TUcCClass; Range: TUcRange);\r\n// Insert a Range into a character class, removing duplicates and ordering them\r\n// in increasing Range-start order.\r\nvar\r\n I: SizeInt;\r\n Temp: UCS4;\r\nbegin\r\n // If the `Casefold' flag is set, then make sure both endpoints of the Range\r\n // are converted to lower.\r\n if (FUREBuffer.Flags and _URE_DFA_CASEFOLD) <> 0 then\r\n begin\r\n { TODO : use the entire mapping, not only the first character }\r\n Range.MinCode := UnicodeToLower(Range.MinCode)[0];\r\n Range.MaxCode := UnicodeToLower(Range.MaxCode)[0];\r\n end;\r\n\r\n // Swap the Range endpoints if they are not in increasing order.\r\n if Range.MinCode > Range.MaxCode then\r\n begin\r\n Temp := Range.MinCode;\r\n Range.MinCode := Range.MaxCode;\r\n Range.MaxCode := Temp;\r\n end;\r\n\r\n I := 0;\r\n while (I < CCL.RangesUsed) and (Range.MinCode < CCL.Ranges[I].MinCode) do\r\n Inc(I);\r\n\r\n // check for a duplicate\r\n if (I < CCL.RangesUsed) and (Range.MinCode = CCL.Ranges[I].MinCode) and\r\n (Range.MaxCode = CCL.Ranges[I].MaxCode) then\r\n Exit;\r\n\r\n if CCL.RangesUsed = Length(CCL.Ranges) then\r\n SetLength(CCL.Ranges, Length(CCL.Ranges) + 8);\r\n\r\n if I < CCL.RangesUsed then\r\n Move(CCL.Ranges[I], CCL.Ranges[I + 1], SizeOf(TUcRange) * (CCL.RangesUsed - I));\r\n\r\n CCL.Ranges[I].MinCode := Range.MinCode;\r\n CCL.Ranges[I].MaxCode := Range.MaxCode;\r\n Inc(CCL.RangesUsed);\r\nend;\r\n\r\ntype\r\n PTrie = ^TTrie;\r\n TTrie = record\r\n Key: UCS2;\r\n Len,\r\n Next: SizeInt;\r\n Setup: SizeInt;\r\n Categories: TCharacterCategories;\r\n end;\r\n\r\nprocedure TURESearch.SpaceSetup(Symbol: PUcSymbolTableEntry; Categories: TCharacterCategories);\r\nvar\r\n Range: TUcRange;\r\nbegin\r\n Symbol.Categories := Symbol.Categories + Categories;\r\n\r\n Range.MinCode := UCS4(WideTabulator);\r\n Range.MaxCode := UCS4(WideTabulator);\r\n AddRange(Symbol.Symbol.CCL, Range);\r\n Range.MinCode := UCS4(WideCarriageReturn);\r\n Range.MaxCode := UCS4(WideCarriageReturn);\r\n AddRange(Symbol.Symbol.CCL, Range);\r\n Range.MinCode := UCS4(WideLineFeed);\r\n Range.MaxCode := UCS4(WideLineFeed);\r\n AddRange(Symbol.Symbol.CCL, Range);\r\n Range.MinCode := UCS4(WideFormFeed);\r\n Range.MaxCode := UCS4(WideFormFeed);\r\n AddRange(Symbol.Symbol.CCL, Range);\r\n Range.MinCode := $FEFF;\r\n Range.MaxCode := $FEFF;\r\n AddRange(Symbol.Symbol.CCL, Range);\r\nend;\r\n\r\nprocedure TURESearch.HexDigitSetup(Symbol: PUcSymbolTableEntry);\r\nvar\r\n Range: TUcRange;\r\nbegin\r\n Range.MinCode := UCS4('0');\r\n Range.MaxCode := UCS4('9');\r\n AddRange(Symbol.Symbol.CCL, Range);\r\n Range.MinCode := UCS4('A');\r\n Range.MaxCode := UCS4('F');\r\n AddRange(Symbol.Symbol.CCL, Range);\r\n Range.MinCode := UCS4('a');\r\n Range.MaxCode := UCS4('f');\r\n AddRange(Symbol.Symbol.CCL, Range);\r\nend;\r\n\r\nconst\r\n CClassTrie: array [0..64] of TTrie = (\r\n (Key: #$003A; Len: 1; Next: 1; Setup: 0; Categories: []),\r\n (Key: #$0061; Len: 9; Next: 10; Setup: 0; Categories: []),\r\n (Key: #$0063; Len: 8; Next: 19; Setup: 0; Categories: []),\r\n (Key: #$0064; Len: 7; Next: 24; Setup: 0; Categories: []),\r\n (Key: #$0067; Len: 6; Next: 29; Setup: 0; Categories: []),\r\n (Key: #$006C; Len: 5; Next: 34; Setup: 0; Categories: []),\r\n (Key: #$0070; Len: 4; Next: 39; Setup: 0; Categories: []),\r\n (Key: #$0073; Len: 3; Next: 49; Setup: 0; Categories: []),\r\n (Key: #$0075; Len: 2; Next: 54; Setup: 0; Categories: []),\r\n (Key: #$0078; Len: 1; Next: 59; Setup: 0; Categories: []),\r\n (Key: #$006C; Len: 1; Next: 11; Setup: 0; Categories: []),\r\n (Key: #$006E; Len: 2; Next: 13; Setup: 0; Categories: []),\r\n (Key: #$0070; Len: 1; Next: 16; Setup: 0; Categories: []),\r\n (Key: #$0075; Len: 1; Next: 14; Setup: 0; Categories: []),\r\n (Key: #$006D; Len: 1; Next: 15; Setup: 0; Categories: []),\r\n (Key: #$003A; Len: 1; Next: 16; Setup: 1; Categories: ClassLetter + ClassNumber),\r\n (Key: #$0068; Len: 1; Next: 17; Setup: 0; Categories: []),\r\n (Key: #$0061; Len: 1; Next: 18; Setup: 0; Categories: []),\r\n (Key: #$003A; Len: 1; Next: 19; Setup: 1; Categories: ClassLetter),\r\n (Key: #$006E; Len: 1; Next: 20; Setup: 0; Categories: []),\r\n (Key: #$0074; Len: 1; Next: 21; Setup: 0; Categories: []),\r\n (Key: #$0072; Len: 1; Next: 22; Setup: 0; Categories: []),\r\n (Key: #$006C; Len: 1; Next: 23; Setup: 0; Categories: []),\r\n (Key: #$003A; Len: 1; Next: 24; Setup: 1; Categories: [ccOtherControl, ccOtherFormat]),\r\n (Key: #$0069; Len: 1; Next: 25; Setup: 0; Categories: []),\r\n (Key: #$0067; Len: 1; Next: 26; Setup: 0; Categories: []),\r\n (Key: #$0069; Len: 1; Next: 27; Setup: 0; Categories: []),\r\n (Key: #$0074; Len: 1; Next: 28; Setup: 0; Categories: []),\r\n (Key: #$003A; Len: 1; Next: 29; Setup: 1; Categories: ClassNumber),\r\n (Key: #$0072; Len: 1; Next: 30; Setup: 0; Categories: []),\r\n (Key: #$0061; Len: 1; Next: 31; Setup: 0; Categories: []),\r\n (Key: #$0070; Len: 1; Next: 32; Setup: 0; Categories: []),\r\n (Key: #$0068; Len: 1; Next: 33; Setup: 0; Categories: []),\r\n (Key: #$003A; Len: 1; Next: 34; Setup: 1; Categories: ClassMark + ClassNumber + ClassLetter + ClassPunctuation +\r\n ClassSymbol),\r\n (Key: #$006F; Len: 1; Next: 35; Setup: 0; Categories: []),\r\n (Key: #$0077; Len: 1; Next: 36; Setup: 0; Categories: []),\r\n (Key: #$0065; Len: 1; Next: 37; Setup: 0; Categories: []),\r\n (Key: #$0072; Len: 1; Next: 38; Setup: 0; Categories: []),\r\n (Key: #$003A; Len: 1; Next: 39; Setup: 1; Categories: [ccLetterLowercase]),\r\n (Key: #$0072; Len: 2; Next: 41; Setup: 0; Categories: []),\r\n (Key: #$0075; Len: 1; Next: 45; Setup: 0; Categories: []),\r\n (Key: #$0069; Len: 1; Next: 42; Setup: 0; Categories: []),\r\n (Key: #$006E; Len: 1; Next: 43; Setup: 0; Categories: []),\r\n (Key: #$0074; Len: 1; Next: 44; Setup: 0; Categories: []),\r\n (Key: #$003A; Len: 1; Next: 45; Setup: 1; Categories: ClassMark + ClassNumber + ClassLetter + ClassPunctuation +\r\n ClassSymbol + [ccSeparatorSpace]),\r\n (Key: #$006E; Len: 1; Next: 46; Setup: 0; Categories: []),\r\n (Key: #$0063; Len: 1; Next: 47; Setup: 0; Categories: []),\r\n (Key: #$0074; Len: 1; Next: 48; Setup: 0; Categories: []),\r\n (Key: #$003A; Len: 1; Next: 49; Setup: 1; Categories: ClassPunctuation),\r\n (Key: #$0070; Len: 1; Next: 50; Setup: 0; Categories: []),\r\n (Key: #$0061; Len: 1; Next: 51; Setup: 0; Categories: []),\r\n (Key: #$0063; Len: 1; Next: 52; Setup: 0; Categories: []),\r\n (Key: #$0065; Len: 1; Next: 53; Setup: 0; Categories: []),\r\n (Key: #$003A; Len: 1; Next: 54; Setup: 2; Categories: ClassSpace),\r\n (Key: #$0070; Len: 1; Next: 55; Setup: 0; Categories: []),\r\n (Key: #$0070; Len: 1; Next: 56; Setup: 0; Categories: []),\r\n (Key: #$0065; Len: 1; Next: 57; Setup: 0; Categories: []),\r\n (Key: #$0072; Len: 1; Next: 58; Setup: 0; Categories: []),\r\n (Key: #$003A; Len: 1; Next: 59; Setup: 1; Categories: [ccLetterUppercase]),\r\n (Key: #$0064; Len: 1; Next: 60; Setup: 0; Categories: []),\r\n (Key: #$0069; Len: 1; Next: 61; Setup: 0; Categories: []),\r\n (Key: #$0067; Len: 1; Next: 62; Setup: 0; Categories: []),\r\n (Key: #$0069; Len: 1; Next: 63; Setup: 0; Categories: []),\r\n (Key: #$0074; Len: 1; Next: 64; Setup: 0; Categories: []),\r\n (Key: #$003A; Len: 1; Next: 65; Setup: 3; Categories: [])\r\n );\r\n\r\nfunction TURESearch.PosixCCL(CP: PUCS2; Limit: SizeInt; Symbol: PUcSymbolTableEntry): SizeInt;\r\n// Probe for one of the POSIX colon delimited character classes in the static trie.\r\nvar\r\n I: SizeInt;\r\n N: SizeInt;\r\n TP: PTrie;\r\n Run,\r\n ListEnd: PUCS2;\r\nbegin\r\n Result := 0;\r\n // If the number of characters left is less than 7,\r\n // then this cannot be interpreted as one of the colon delimited classes.\r\n if Limit >= 7 then\r\n begin\r\n Run := cp;\r\n ListEnd := Run + Limit;\r\n TP := @CClassTrie[0];\r\n I := 0;\r\n while (Run < ListEnd) and (I < 8) do\r\n begin\r\n N := TP.Len;\r\n while (N > 0) and (TP.Key <> Run^) do\r\n begin\r\n Inc(TP);\r\n Dec(N);\r\n end;\r\n\r\n if N = 0 then\r\n begin\r\n Result := 0;\r\n Exit;\r\n end;\r\n\r\n if (Run^ = ':') and ((I = 6) or (I = 7)) then\r\n begin\r\n Inc(Run);\r\n Break;\r\n end;\r\n if (Run + 1) < ListEnd then\r\n TP := @CClassTrie[TP.Next];\r\n Inc(I);\r\n Inc(Run);\r\n end;\r\n\r\n Result := Run - CP;\r\n case TP.Setup of\r\n 1:\r\n Symbol.Categories := Symbol.Categories + TP.Categories;\r\n 2:\r\n SpaceSetup(Symbol, TP.Categories);\r\n 3:\r\n HexDigitSetup(Symbol);\r\n else\r\n Result := 0;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TURESearch.BuildCharacterClass(CP: PUCS2; Limit: SizeInt; Symbol: PUcSymbolTableEntry): SizeInt;\r\n// Construct a list of ranges and return the number of characters consumed.\r\nvar\r\n RangeEnd: SizeInt;\r\n N: SizeInt;\r\n Run,\r\n ListEnd: PUCS2;\r\n C, Last: UCS4;\r\n Range: TUcRange;\r\nbegin\r\n Run := cp;\r\n ListEnd := Run + Limit;\r\n\r\n if Run^ = '^' then\r\n begin\r\n Symbol.AType := _URE_NCCLASS;\r\n Inc(Run);\r\n end\r\n else\r\n Symbol.AType := _URE_CCLASS;\r\n\r\n Last := 0;\r\n RangeEnd := 0;\r\n while (FUREBuffer.Error = _URE_OK) and (Run < ListEnd) do\r\n begin\r\n // Allow for the special case []abc], where the first closing bracket would end an empty\r\n // character class, which makes no sense. Hence this bracket is treaded literally.\r\n if (Run^ = ']') and (Symbol.Symbol.CCL.RangesUsed > 0) then\r\n Break;\r\n\r\n C := UCS4(Run^);\r\n Inc(Run);\r\n\r\n // escape character\r\n if C = Ord('\\') then\r\n begin\r\n if Run = ListEnd then\r\n begin\r\n // The EOS was encountered when expecting the reverse solidus to be followed by the character it is escaping.\r\n // Set an Error code and return the number of characters consumed up to this point.\r\n FUREBuffer.Error := _URE_UNEXPECTED_EOS;\r\n Result := Run - CP;\r\n Exit;\r\n end;\r\n\r\n C := UCS4(Run^);\r\n Inc(Run);\r\n case UCS2(C) of\r\n 'a':\r\n C := $07;\r\n 'b':\r\n C := $08;\r\n 'f':\r\n C := $0C;\r\n 'n':\r\n C := $0A;\r\n 'R':\r\n C := $0D;\r\n 't':\r\n C := $09;\r\n 'v':\r\n C := $0B;\r\n 'p', 'P':\r\n begin\r\n Inc(Run, ParsePropertyList(Run, ListEnd - Run, Symbol.Categories));\r\n // Invert the bit mask of the properties if this is a negated character class or if 'P' is used to specify\r\n // a list of character properties that should *not* match in a character class.\r\n if C = Ord('P') then\r\n Symbol.Categories := ClassAll - Symbol.Categories;\r\n Continue;\r\n end;\r\n 'x', 'X', 'u', 'U':\r\n begin\r\n if (Run < ListEnd) and\r\n ((Run^ >= '0') and (Run^ <= '9') or\r\n (Run^ >= 'A') and (Run^ <= 'F') or\r\n (Run^ >= 'a') and (Run^ <= 'f')) then\r\n Inc(Run, MakeHexNumber(Run, ListEnd - Run, C));\r\n end;\r\n end;\r\n end\r\n else\r\n begin\r\n if C = Ord(':') then\r\n begin\r\n // Probe for a POSIX colon delimited character class.\r\n Dec(Run);\r\n N := PosixCCL(Run, ListEnd - Run, Symbol);\r\n if N = 0 then\r\n Inc(Run)\r\n else\r\n begin\r\n Inc(Run, N);\r\n Continue;\r\n end;\r\n end;\r\n end;\r\n\r\n // Check to see if the current character is a low surrogate that needs\r\n // to be combined with a preceding high surrogate.\r\n if Last <> 0 then\r\n begin\r\n if (C >= SurrogateLowStart) and (C <= SurrogateLowEnd) then\r\n begin\r\n // Construct the UTF16 character code.\r\n C := $10000 + (((Last and $03FF) shl 10) or (C and $03FF))\r\n end\r\n else\r\n begin\r\n // Add the isolated high surrogate to the range.\r\n if RangeEnd = 1 then\r\n Range.MaxCode := Last and $FFFF\r\n else\r\n begin\r\n Range.MinCode := Last and $FFFF;\r\n Range.MaxCode := Last and $FFFF;\r\n end;\r\n\r\n AddRange(Symbol.Symbol.CCL, Range);\r\n RangeEnd := 0;\r\n end;\r\n end;\r\n\r\n // Clear the Last character code.\r\n Last := 0;\r\n\r\n // This slightly awkward code handles the different cases needed to construct a range.\r\n if (C >= SurrogateHighStart) and (C <= SurrogateHighEnd) then\r\n begin\r\n // If the high surrogate is followed by a Range indicator, simply add it as the Range start. Otherwise,\r\n // save it in the next character is a low surrogate.\r\n if Run^ = '-' then\r\n begin\r\n Inc(Run);\r\n Range.MinCode := C;\r\n RangeEnd := 1;\r\n end\r\n else\r\n Last := C;\r\n end\r\n else\r\n begin\r\n if RangeEnd = 1 then\r\n begin\r\n Range.MaxCode := C;\r\n AddRange(Symbol.Symbol.CCL, Range);\r\n RangeEnd := 0;\r\n end\r\n else\r\n begin\r\n Range.MinCode := C;\r\n Range.MaxCode := C;\r\n if Run^ = '-' then\r\n begin\r\n Inc(Run);\r\n RangeEnd := 1;\r\n end\r\n else\r\n AddRange(Symbol.Symbol.CCL, Range);\r\n end;\r\n end;\r\n end;\r\n\r\n if (Run < ListEnd) and (Run^ = ']') then\r\n Inc(Run)\r\n else\r\n begin\r\n // The parse was not terminated by the character class close symbol (']'), so set an error code.\r\n FUREBuffer.Error := _URE_CCLASS_OPEN;\r\n end;\r\n Result := Run - CP;\r\nend;\r\n\r\nfunction TURESearch.ProbeLowSurrogate(LeftState: PUCS2; Limit: SizeInt; var Code: UCS4): SizeInt;\r\n// probes for a low surrogate hex code\r\nvar\r\n I: SizeInt;\r\n Run,\r\n ListEnd: PUCS2;\r\nbegin\r\n I := 0;\r\n Code := 0;\r\n Run := LeftState;\r\n ListEnd := Run + Limit;\r\n\r\n while (I < 4) and (Run < ListEnd) do\r\n begin\r\n if (Run^ >= '0') and (Run^ <= '9') then\r\n Code := (Code shl 4) or (Cardinal(Word(Run^) - Ord('0')))\r\n else\r\n begin\r\n if (Run^ >= 'A') and (Run^ <= 'F') then\r\n Code := (Code shl 4) or (Cardinal(Word(Run^) - Ord('A')) + 10)\r\n else\r\n begin\r\n if (Run^ >= 'a') and (Run^ <= 'f') then\r\n Code := (Code shl 4) or (Cardinal(Word(Run^) - Ord('a')) + 10)\r\n else\r\n Break;\r\n end;\r\n end;\r\n Inc(Run);\r\n end;\r\n\r\n if (SurrogateLowStart <= Code) and (Code <= SurrogateLowEnd) then\r\n Result := Run - LeftState\r\n else\r\n Result := 0;\r\nend;\r\n\r\nfunction TURESearch.CompileSymbol(S: PUCS2; Limit: SizeInt; Symbol: PUcSymbolTableEntry): SizeInt;\r\nvar\r\n C: UCS4;\r\n Run,\r\n ListEnd: PUCS2;\r\nbegin\r\n Run := S;\r\n ListEnd := S + Limit;\r\n\r\n C := UCS4(Run^);\r\n Inc(Run);\r\n if C = Ord('\\') then\r\n begin\r\n if Run = ListEnd then\r\n begin\r\n // The EOS was encountered when expecting the reverse solidus to be followed\r\n // by the character it is escaping. Set an Error code and return the number\r\n // of characters consumed up to this point.\r\n FUREBuffer.Error := _URE_UNEXPECTED_EOS;\r\n Result := Run - S;\r\n Exit;\r\n end;\r\n\r\n C := UCS4(Run^);\r\n Inc(Run);\r\n case UCS2(C) of\r\n 'p', 'P':\r\n begin\r\n if UCS2(C) = 'p' then\r\n Symbol.AType :=_URE_CCLASS\r\n else\r\n Symbol.AType :=_URE_NCCLASS;\r\n Inc(Run, ParsePropertyList(Run, ListEnd - Run, Symbol.Categories));\r\n end;\r\n 'a':\r\n begin\r\n Symbol.AType := _URE_CHAR;\r\n Symbol.Symbol.Chr := $07;\r\n end;\r\n 'b':\r\n begin\r\n Symbol.AType := _URE_CHAR;\r\n Symbol.Symbol.Chr := $08;\r\n end;\r\n 'f':\r\n begin\r\n Symbol.AType := _URE_CHAR;\r\n Symbol.Symbol.Chr := $0C;\r\n end;\r\n 'n':\r\n begin\r\n Symbol.AType := _URE_CHAR;\r\n Symbol.Symbol.Chr := $0A;\r\n end;\r\n 'r':\r\n begin\r\n Symbol.AType := _URE_CHAR;\r\n Symbol.Symbol.Chr := $0D;\r\n end;\r\n 't':\r\n begin\r\n Symbol.AType := _URE_CHAR;\r\n Symbol.Symbol.Chr := $09;\r\n end;\r\n 'v':\r\n begin\r\n Symbol.AType := _URE_CHAR;\r\n Symbol.Symbol.Chr := $0B;\r\n end;\r\n else\r\n case UCS2(C) of\r\n 'x', 'X', 'u', 'U':\r\n begin\r\n // Collect between 1 and 4 digits representing an UCS2 code.\r\n if (Run < ListEnd) and\r\n ((Run^ >= '0') and (Run^ <= '9') or\r\n (Run^ >= 'A') and (Run^ <= 'F') or\r\n (Run^ >= 'a') and (Run^ <= 'f')) then\r\n Inc(Run, MakeHexNumber(Run, ListEnd - Run, C));\r\n end;\r\n end;\r\n\r\n // Simply add an escaped character here.\r\n Symbol.AType := _URE_CHAR;\r\n Symbol.Symbol.Chr := C;\r\n end;\r\n end\r\n else\r\n begin\r\n if (UCS2(C) = '^') or (UCS2(C) = '$') then\r\n begin\r\n // Handle the BOL and EOL anchors. This actually consists simply of setting\r\n // a flag that indicates that the user supplied anchor match function should\r\n // be called. This needs to be done instead of simply matching line/paragraph\r\n // separators because beginning-of-text and end-of-text tests are needed as well.\r\n if UCS2(C) = '^' then\r\n Symbol.AType := _URE_BOL_ANCHOR\r\n else\r\n Symbol.AType := _URE_EOL_ANCHOR;\r\n end\r\n else\r\n begin\r\n if UCS2(C) = '[' then\r\n begin\r\n // construct a character class\r\n Inc(Run, BuildCharacterClass(Run, ListEnd - Run, Symbol));\r\n end\r\n else\r\n begin\r\n if UCS2(C) = '.' then\r\n Symbol.AType := _URE_ANY_CHAR\r\n else\r\n begin\r\n Symbol.AType := _URE_CHAR;\r\n Symbol.Symbol.Chr := C;\r\n end;\r\n end;\r\n end;\r\n end;\r\n\r\n // If the symbol type happens to be a character and is a high surrogate, then\r\n // probe forward to see if it is followed by a low surrogate that needs to be added.\r\n if (Run < ListEnd) and\r\n (Symbol.AType = _URE_CHAR) and\r\n (SurrogateHighStart <= Symbol.Symbol.Chr) and\r\n (Symbol.Symbol.Chr <= SurrogateHighEnd) then\r\n begin\r\n if (SurrogateLowStart <= UCS4(Run^)) and\r\n (UCS4(Run^) <= SurrogateLowEnd) then\r\n begin\r\n Symbol.Symbol.Chr := $10000 + (((Symbol.Symbol.Chr and $03FF) shl 10) or (UCS4(Run^) and $03FF));\r\n Inc(Run);\r\n end\r\n else\r\n begin\r\n if (Run^ = '\\') and (((Run + 1)^ = 'x') or ((Run + 1)^ = 'X') or\r\n ((Run + 1)^ = 'u') or ((Run + 1)^ = 'U')) then\r\n begin\r\n Inc(Run, ProbeLowSurrogate(Run + 2, ListEnd - (Run + 2), C));\r\n if (SurrogateLowStart <= C) and (C <= SurrogateLowEnd) then\r\n begin\r\n // Take into account the \\[xu] in front of the hex code.\r\n Inc(Run, 2);\r\n Symbol.Symbol.Chr := $10000 + (((Symbol.Symbol.Chr and $03FF) shl 10) or (C and $03FF));\r\n end;\r\n end;\r\n end;\r\n end;\r\n\r\n // Last, make sure any _URE_CHAR type symbols are changed to lower if the\r\n // 'Casefold' flag is set.\r\n { TODO : use the entire mapping, not only the first character and use the\r\n case fold abilities of the unit. }\r\n if ((FUREBuffer.Flags and _URE_DFA_CASEFOLD) <> 0) and (Symbol.AType = _URE_CHAR) then\r\n Symbol.Symbol.Chr := UnicodeToLower(Symbol.Symbol.Chr)[0];\r\n\r\n // If the symbol constructed is anything other than one of the anchors,\r\n // make sure the _URE_DFA_BLANKLINE flag is removed.\r\n if (Symbol.AType <> _URE_BOL_ANCHOR) and (Symbol.AType <> _URE_EOL_ANCHOR) then\r\n FUREBuffer.Flags := FUREBuffer.Flags and not _URE_DFA_BLANKLINE;\r\n\r\n // Return the number of characters consumed.\r\n Result := Run - S;\r\nend;\r\n\r\nfunction TURESearch.SymbolsAreDifferent(A, B: PUcSymbolTableEntry): Boolean;\r\nbegin\r\n Result := False;\r\n if (A.AType <> B.AType) or (A.Mods <> B.Mods) or (A.Categories <> B.Categories) then\r\n Result := True\r\n else\r\n begin\r\n if (A.AType = _URE_CCLASS) or (A.AType = _URE_NCCLASS) then\r\n begin\r\n if A.Symbol.CCL.RangesUsed <> B.Symbol.CCL.RangesUsed then\r\n Result := True\r\n else\r\n begin\r\n if (A.Symbol.CCL.RangesUsed > 0) and\r\n not CompareMem(@A.Symbol.CCL.Ranges[0], @B.Symbol.CCL.Ranges[0],\r\n SizeOf(TUcRange) * A.Symbol.CCL.RangesUsed) then\r\n Result := True;;\r\n end;\r\n end\r\n else\r\n begin\r\n if (A.AType = _URE_CHAR) and (A.Symbol.Chr <> B.Symbol.Chr) then\r\n Result := True;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TURESearch.MakeSymbol(S: PUCS2; Limit: SizeInt; out Consumed: SizeInt): SizeInt;\r\n// constructs a symbol, but only keep unique symbols\r\nvar\r\n I: SizeInt;\r\n Start: PUcSymbolTableEntry;\r\n Symbol: TUcSymbolTableEntry;\r\nbegin\r\n // Build the next symbol so we can test to see if it is already in the symbol table.\r\n ResetMemory(Symbol, SizeOf(TUcSymbolTableEntry));\r\n Consumed := CompileSymbol(S, Limit, @Symbol);\r\n\r\n // Check to see if the symbol exists.\r\n I := 0;\r\n Start := @FUREBuffer.SymbolTable.Symbols[0];\r\n while (I < FUREBuffer.SymbolTable.SymbolsUsed) and SymbolsAreDifferent(@Symbol, Start) do\r\n begin\r\n Inc(I);\r\n Inc(Start);\r\n end;\r\n\r\n if I < FUREBuffer.SymbolTable.SymbolsUsed then\r\n begin\r\n // Free up any ranges used for the symbol.\r\n if (Symbol.AType = _URE_CCLASS) or (Symbol.AType = _URE_NCCLASS) then\r\n Symbol.Symbol.CCL.Ranges := nil;\r\n Result := FUREBuffer.SymbolTable.Symbols[I].ID;\r\n Exit;\r\n end;\r\n\r\n // Need to add the new symbol.\r\n if FUREBuffer.SymbolTable.SymbolsUsed = Length(FUREBuffer.SymbolTable.Symbols) then\r\n begin\r\n SetLength(FUREBuffer.SymbolTable.Symbols, Length(FUREBuffer.SymbolTable.Symbols) + 8);\r\n end;\r\n\r\n Symbol.ID := FUREBuffer.SymbolTable.SymbolsUsed;\r\n Inc(FUREBuffer.SymbolTable.SymbolsUsed);\r\n FUREBuffer.SymbolTable.Symbols[Symbol.ID] := Symbol;\r\n Result := Symbol.ID;\r\nend;\r\n\r\nfunction TURESearch.MakeExpression(AType, LHS, RHS: SizeInt): SizeInt;\r\nvar\r\n I: SizeInt;\r\nbegin\r\n // Determine if the expression already exists or not.\r\n with FUREBuffer.ExpressionList do\r\n begin\r\n for I := 0 to ExpressionsUsed - 1 do\r\n begin\r\n if (Expressions[I].AType = AType) and\r\n (Expressions[I].LHS = LHS) and\r\n (Expressions[I].RHS = RHS) then\r\n begin\r\n Result := I;\r\n Exit;\r\n end;\r\n end;\r\n\r\n // Need to add a new expression.\r\n if ExpressionsUsed = Length(Expressions) then\r\n SetLength(Expressions, Length(Expressions) + 8);\r\n\r\n Expressions[ExpressionsUsed].OnStack := False;\r\n Expressions[ExpressionsUsed].AType := AType;\r\n Expressions[ExpressionsUsed].LHS := LHS;\r\n Expressions[ExpressionsUsed].RHS := RHS;\r\n\r\n Result := ExpressionsUsed;\r\n Inc(ExpressionsUsed);\r\n end;\r\nend;\r\n\r\nfunction IsSpecial(C: Word): Boolean;\r\nbegin\r\n case C of\r\n Word('+'),\r\n Word('*'),\r\n Word('?'),\r\n Word('{'),\r\n Word('|'),\r\n Word(')'):\r\n Result := True;\r\n else\r\n Result := False;\r\n end;\r\nend;\r\n\r\nprocedure TURESearch.CollectPendingOperations(var State: SizeInt);\r\n// collects all pending AND and OR operations and make corresponding expressions\r\nvar\r\n Operation: SizeInt;\r\nbegin\r\n repeat\r\n Operation := Peek;\r\n if (Operation <> _URE_AND) and (Operation <> _URE_OR) then\r\n Break;\r\n // make an expression with the AND or OR operator and its right hand side\r\n Operation := Pop;\r\n State := MakeExpression(Operation, Pop, State);\r\n until False;\r\nend;\r\n\r\nfunction TURESearch.ConvertRegExpToNFA(RE: PWideChar; RELength: SizeInt): SizeInt;\r\n// Converts the regular expression into an NFA in a form that will be easy to\r\n// reduce to a DFA. The starting state for the reduction will be returned.\r\nvar\r\n C: UCS2;\r\n Head, Tail: PUCS2;\r\n S: WideString;\r\n Symbol,\r\n State,\r\n LastState,\r\n Used,\r\n M, N: SizeInt;\r\n I: SizeInt;\r\nbegin\r\n State := _URE_NOOP;\r\n\r\n Head := RE;\r\n Tail := Head + RELength;\r\n while (FUREBuffer.Error = _URE_OK) and (Head < Tail) do\r\n begin\r\n C := Head^;\r\n Inc(Head);\r\n case C of\r\n '(':\r\n Push(_URE_PAREN);\r\n ')': // check for the case of too many close parentheses\r\n begin\r\n if Peek = _URE_NOOP then\r\n begin\r\n FUREBuffer.Error := _URE_UNBALANCED_GROUP;\r\n Break;\r\n end;\r\n CollectPendingOperations(State);\r\n // remove the _URE_PAREN off the stack\r\n Pop;\r\n end;\r\n '*':\r\n State := MakeExpression(_URE_STAR, State, _URE_NOOP);\r\n '+':\r\n State := MakeExpression(_URE_PLUS, State, _URE_NOOP);\r\n '?':\r\n State := MakeExpression(_URE_QUEST, State, _URE_NOOP);\r\n '|':\r\n begin\r\n CollectPendingOperations(State);\r\n Push(State);\r\n Push(_URE_OR);\r\n end;\r\n '{': // expressions of the form {m, n}\r\n begin\r\n C := #0;\r\n M := 0;\r\n N := 0;\r\n // get first number\r\n while UnicodeIsWhiteSpace(UCS4(Head^)) do\r\n Inc(Head);\r\n // very slow implementation\r\n S := '';\r\n while (Head^ >= WideChar('0')) and (Head^ <= WideChar('9')) do\r\n begin\r\n S := S + Head^;\r\n Inc(Head);\r\n end;\r\n if S <> '' then\r\n M := StrToInt(S);\r\n\r\n while UnicodeIsWhiteSpace(UCS4(Head^)) do\r\n Inc(Head);\r\n if (Head^ <> ',') and (Head^ <> '}') then\r\n begin\r\n FUREBuffer.Error := _URE_INVALID_RANGE;\r\n Break;\r\n end;\r\n\r\n // check for an upper limit\r\n if Head^ <> '}' then\r\n begin\r\n Inc(Head);\r\n // get second number\r\n while UnicodeIsWhiteSpace(UCS4(Head^)) do\r\n Inc(Head);\r\n // very slow implementation\r\n S := '';\r\n while (Head^ >= WideChar('0')) and (Head^ <= WideChar('9')) do\r\n begin\r\n S := S + Head^;\r\n Inc(Head);\r\n end;\r\n if S <> '' then\r\n N := StrToInt(S);\r\n end\r\n else\r\n N := M;\r\n\r\n if Head^ <> '}' then\r\n begin\r\n FUREBuffer.Error := _URE_RANGE_OPEN;\r\n Break;\r\n end\r\n else\r\n Inc(Head);\r\n\r\n // N = 0 means unlimited number of occurences\r\n if N = 0 then\r\n begin\r\n case M of\r\n 0: // {,} {0,} {0, 0} mean the same as the star operator\r\n State := MakeExpression(_URE_STAR, State, _URE_NOOP);\r\n 1: // {1,} {1, 0} mean the same as the plus operator\r\n State := MakeExpression(_URE_PLUS, State, _URE_NOOP);\r\n else\r\n begin\r\n // encapsulate the expanded branches as would they be in parenthesis\r\n // in order to avoid unwanted concatenation with pending operations/symbols\r\n Push(_URE_PAREN);\r\n // {m,} {m, 0} mean M fixed occurences plus star operator\r\n // make E^m...\r\n for I := 1 to M - 1 do\r\n begin\r\n Push(State);\r\n Push(_URE_AND);\r\n end;\r\n // ...and repeat the last symbol one or more times\r\n State := MakeExpression(_URE_PLUS, State, _URE_NOOP);\r\n CollectPendingOperations(State);\r\n Pop;\r\n end;\r\n end;\r\n end\r\n else\r\n begin\r\n // check proper range limits\r\n if M > N then\r\n begin\r\n FUREBuffer.Error := _URE_INVALID_RANGE;\r\n Break;\r\n end;\r\n\r\n // check special case {0, 1} (which corresponds to the ? operator)\r\n if (M = 0) and (N = 1) then\r\n State := MakeExpression(_URE_QUEST, State, _URE_NOOP)\r\n else\r\n begin\r\n // handle the general case by expanding {m, n} into the equivalent\r\n // expression E^m | E^(m + 1) | ... | E^n\r\n\r\n // encapsulate the expanded branches as would they be in parenthesis\r\n // in order to avoid unwanted concatenation with pending operations/symbols\r\n Push(_URE_PAREN);\r\n // keep initial state as this is the one all alternatives start from\r\n LastState := State;\r\n\r\n // Consider the special case M = 0 first. Because there's no construct\r\n // to enter a pure epsilon-transition into the expression array I\r\n // work around with the question mark operator to describe the first\r\n // and second branch alternative.\r\n if M = 0 then\r\n begin\r\n State := MakeExpression(_URE_QUEST, State, _URE_NOOP);\r\n Inc(M, 2);\r\n // Mark the pending OR operation (there must always follow at\r\n // least on more alternative because the special case {0, 1} has\r\n // already been handled).\r\n Push(State);\r\n Push(_URE_OR);\r\n end;\r\n\r\n while M <= N do\r\n begin\r\n State := LastState;\r\n // create E^M\r\n for I := 1 to SizeInt(M) - 1 do\r\n begin\r\n Push(State);\r\n Push(_URE_AND);\r\n end;\r\n // finish the branch and mark it as pending OR operation if it\r\n // isn't the last one\r\n CollectPendingOperations(State);\r\n if M < N then\r\n begin\r\n Push(State);\r\n Push(_URE_OR);\r\n end;\r\n Inc(M);\r\n end;\r\n // remove the _URE_PAREN off the stack\r\n Pop;\r\n end;\r\n end;\r\n end;\r\n else\r\n Dec(Head);\r\n Symbol := MakeSymbol(Head, Tail - Head, Used);\r\n Inc(Head, Used);\r\n State := MakeExpression(_URE_SYMBOL, Symbol, _URE_NOOP);\r\n end;\r\n\r\n if (C <> '(') and (C <> '|') and (C <> '{') and (Head < Tail) and\r\n (not IsSpecial(Word(Head^)) or (Head^ = '(')) then\r\n begin\r\n Push(State);\r\n Push(_URE_AND);\r\n end;\r\n end;\r\n\r\n CollectPendingOperations(State);\r\n if FUREBuffer.Stack.ListUsed > 0 then\r\n FUREBuffer.Error := _URE_UNBALANCED_GROUP;\r\n\r\n if FUREBuffer.Error = _URE_OK then\r\n Result := State\r\n else\r\n Result := _URE_NOOP;\r\nend;\r\n\r\nprocedure TURESearch.AddSymbolState(Symbol, State: SizeInt);\r\nvar\r\n I, J: SizeInt;\r\n Found: Boolean;\r\nbegin\r\n // Locate the symbol in the symbol table so the state can be added.\r\n // If the symbol doesn't exist, then we are in serious trouble.\r\n with FUREBuffer.SymbolTable do\r\n begin\r\n I := 0;\r\n while (I < SymbolsUsed) and (Symbol <> Symbols[I].ID) do\r\n Inc(I);\r\n\r\n Assert(I < SymbolsUsed);\r\n end;\r\n\r\n // Now find out if the state exists in the symbol's state list.\r\n with FUREBuffer.SymbolTable.Symbols[I].States do\r\n begin\r\n Found := False;\r\n for J := 0 to ListUsed - 1 do\r\n begin\r\n if State <= List[J] then\r\n begin\r\n Found := True;\r\n Break;\r\n end;\r\n end;\r\n\r\n if not Found then\r\n J := ListUsed;\r\n if not Found or (State < List[J]) then\r\n begin\r\n // Need to add the state in order.\r\n if ListUsed = Length(List) then\r\n SetLength(List, Length(List) + 8);\r\n if J < ListUsed then\r\n Move(List[J], List[J + 1], SizeOf(SizeInt) * (ListUsed - J));\r\n List[J] := State;\r\n Inc(ListUsed);\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TURESearch.AddState(NewStates: array of SizeInt): SizeInt;\r\nvar\r\n I: SizeInt;\r\n Found: Boolean;\r\nbegin\r\n Found := False;\r\n for I := 0 to FUREBuffer.States.StatesUsed - 1 do\r\n begin\r\n if (FUREBuffer.States.States[I].StateList.ListUsed = Length(NewStates)) and\r\n CompareMem(@NewStates[0], @FUREBuffer.States.States[I].StateList.List[0],\r\n SizeOf(SizeInt) * Length(NewStates)) then\r\n begin\r\n Found := True;\r\n Break;\r\n end;\r\n end;\r\n\r\n if not Found then\r\n begin\r\n // Need to add a new DFA State (set of NFA states).\r\n if FUREBuffer.States.StatesUsed = Length(FUREBuffer.States.States) then\r\n SetLength(FUREBuffer.States.States, Length(FUREBuffer.States.States) + 8);\r\n\r\n with FUREBuffer.States.States[FUREBuffer.States.StatesUsed] do\r\n begin\r\n ID := FUREBuffer.States.StatesUsed;\r\n if (StateList.ListUsed + Length(NewStates)) >= Length(StateList.List) then\r\n SetLength(StateList.List, Length(StateList.List) + Length(NewStates) + 8);\r\n Move(NewStates[0], StateList.List[StateList.ListUsed], SizeOf(SizeInt) * Length(NewStates));\r\n Inc(StateList.ListUsed, Length(NewStates));\r\n end;\r\n Inc(FUREBuffer.States.StatesUsed);\r\n end;\r\n\r\n // Return the ID of the DFA state representing a group of NFA States.\r\n if Found then\r\n Result := I\r\n else\r\n Result := FUREBuffer.States.StatesUsed - 1;\r\nend;\r\n\r\nprocedure TURESearch.Reduce(Start: SizeInt);\r\nvar\r\n I, J,\r\n Symbols: SizeInt;\r\n State,\r\n RHS,\r\n s1, s2,\r\n ns1, ns2: SizeInt;\r\n Evaluating: Boolean;\r\nbegin\r\n FUREBuffer.Reducing := True;\r\n\r\n // Add the starting state for the reduction.\r\n AddState([Start]);\r\n\r\n // Process each set of NFA states that get created.\r\n I := 0;\r\n // further states are added in the loop\r\n while I < FUREBuffer.States.StatesUsed do\r\n begin\r\n with FUREBuffer, States.States[I], ExpressionList do\r\n begin\r\n // Push the current states on the stack.\r\n for J := 0 to StateList.ListUsed - 1 do\r\n Push(StateList.List[J]);\r\n\r\n // Reduce the NFA states.\r\n Accepting := False;\r\n Symbols := 0;\r\n J := 0;\r\n // need a while loop here as the stack will be modified within the loop and\r\n // so also its usage count used to terminate the loop\r\n while J < FUREBuffer.Stack.ListUsed do\r\n begin\r\n State := FUREBuffer.Stack.List[J];\r\n Evaluating := True;\r\n\r\n // This inner loop is the iterative equivalent of recursively\r\n // reducing subexpressions generated as a result of a reduction.\r\n while Evaluating do\r\n begin\r\n case Expressions[State].AType of\r\n _URE_SYMBOL:\r\n begin\r\n ns1 := MakeExpression(_URE_ONE, _URE_NOOP, _URE_NOOP);\r\n AddSymbolState(Expressions[State].LHS, ns1);\r\n Inc(Symbols);\r\n Evaluating := False;\r\n end;\r\n _URE_ONE:\r\n begin\r\n Accepting := True;\r\n Evaluating := False;\r\n end;\r\n _URE_QUEST:\r\n begin\r\n s1 := Expressions[State].LHS;\r\n ns1 := MakeExpression(_URE_ONE, _URE_NOOP, _URE_NOOP);\r\n State := MakeExpression(_URE_OR, ns1, s1);\r\n end;\r\n _URE_PLUS:\r\n begin\r\n s1 := Expressions[State].LHS;\r\n ns1 := MakeExpression(_URE_STAR, s1, _URE_NOOP);\r\n State := MakeExpression(_URE_AND, s1, ns1);\r\n end;\r\n _URE_STAR:\r\n begin\r\n s1 := Expressions[State].LHS;\r\n ns1 := MakeExpression(_URE_ONE, _URE_NOOP, _URE_NOOP);\r\n ns2 := MakeExpression(_URE_PLUS, s1, _URE_NOOP);\r\n State := MakeExpression(_URE_OR, ns1, ns2);\r\n end;\r\n _URE_OR:\r\n begin\r\n s1 := Expressions[State].LHS;\r\n s2 := Expressions[State].RHS;\r\n Push(s1);\r\n Push(s2);\r\n Evaluating := False;\r\n end;\r\n _URE_AND:\r\n begin\r\n s1 := Expressions[State].LHS;\r\n s2 := Expressions[State].RHS;\r\n case Expressions[s1].AType of\r\n _URE_SYMBOL:\r\n begin\r\n AddSymbolState(Expressions[s1].LHS, s2);\r\n Inc(Symbols);\r\n Evaluating := False;\r\n end;\r\n _URE_ONE:\r\n State := s2;\r\n _URE_QUEST:\r\n begin\r\n ns1 := Expressions[s1].LHS;\r\n ns2 := MakeExpression(_URE_AND, ns1, s2);\r\n State := MakeExpression(_URE_OR, s2, ns2);\r\n end;\r\n _URE_PLUS:\r\n begin\r\n ns1 := Expressions[s1].LHS;\r\n ns2 := MakeExpression(_URE_OR, s2, State);\r\n State := MakeExpression(_URE_AND, ns1, ns2);\r\n end;\r\n _URE_STAR:\r\n begin\r\n ns1 := Expressions[s1].LHS;\r\n ns2 := MakeExpression(_URE_AND, ns1, State);\r\n State := MakeExpression(_URE_OR, s2, ns2);\r\n end;\r\n _URE_OR:\r\n begin\r\n ns1 := Expressions[s1].LHS;\r\n ns2 := Expressions[s1].RHS;\r\n ns1 := MakeExpression(_URE_AND, ns1, s2);\r\n ns2 := MakeExpression(_URE_AND, ns2, s2);\r\n State := MakeExpression(_URE_OR, ns1, ns2);\r\n end;\r\n _URE_AND:\r\n begin\r\n ns1 := Expressions[s1].LHS;\r\n ns2 := Expressions[s1].RHS;\r\n ns2 := MakeExpression(_URE_AND, ns2, s2);\r\n State := MakeExpression(_URE_AND, ns1, ns2);\r\n end;\r\n end;\r\n end;\r\n end;\r\n end;\r\n Inc(J);\r\n end;\r\n\r\n // clear the state stack\r\n while Pop <> _URE_NOOP do\r\n { nothing };\r\n\r\n // generate the DFA states for the symbols collected during the current reduction\r\n if (TransitionsUsed + Symbols) > Length(Transitions) then\r\n SetLength(Transitions, Length(Transitions) + Symbols);\r\n\r\n // go through the symbol table and generate the DFA state transitions for\r\n // each symbol that has collected NFA states\r\n Symbols := 0;\r\n J := 0;\r\n while J < FUREBuffer.SymbolTable.SymbolsUsed do\r\n begin\r\n begin\r\n if FUREBuffer.SymbolTable.Symbols[J].States.ListUsed > 0 then\r\n begin\r\n Transitions[Symbols].LHS := FUREBuffer.SymbolTable.Symbols[J].ID;\r\n with FUREBuffer.SymbolTable.Symbols[J] do\r\n begin\r\n RHS := AddState(Copy(States.List, 0, States.ListUsed));\r\n States.ListUsed := 0;\r\n end;\r\n Transitions[Symbols].RHS := RHS;\r\n Inc(Symbols);\r\n end;\r\n end;\r\n Inc(J);\r\n end;\r\n\r\n // set the number of transitions actually used\r\n // Note: we need again to qualify a part of the TransistionsUsed path since the\r\n // state array could be reallocated in the AddState call above and the\r\n // with ... do will then be invalid.\r\n States.States[I].TransitionsUsed := Symbols;\r\n end;\r\n Inc(I);\r\n end;\r\n FUREBuffer.Reducing := False;\r\nend;\r\n\r\nprocedure TURESearch.AddEquivalentPair(L, R: SizeInt);\r\nvar\r\n I: SizeInt;\r\nbegin\r\n L := FUREBuffer.States.States[L].ID;\r\n R := FUREBuffer.States.States[R].ID;\r\n\r\n if L <> R then\r\n begin\r\n if L > R then\r\n begin\r\n I := L;\r\n L := R;\r\n R := I;\r\n end;\r\n\r\n // Check to see if the equivalence pair already exists.\r\n I := 0;\r\n with FUREBuffer.EquivalentList do\r\n begin\r\n while (I < EquivalentsUsed) and\r\n ((Equivalents[I].Left <> L) or (Equivalents[I].Right <> R)) do\r\n Inc(I);\r\n\r\n if I >= EquivalentsUsed then\r\n begin\r\n if EquivalentsUsed = Length(Equivalents) then\r\n SetLength(Equivalents, Length(Equivalents) + 8);\r\n\r\n Equivalents[EquivalentsUsed].Left := L;\r\n Equivalents[EquivalentsUsed].Right := R;\r\n Inc(EquivalentsUsed);\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TURESearch.MergeEquivalents;\r\n// merges the DFA states that are equivalent\r\nvar\r\n I, J, K,\r\n Equal: SizeInt;\r\n Done: Boolean;\r\n State1, State2,\r\n LeftState,\r\n RightState: PUcState;\r\nbegin\r\n for I := 0 to FUREBuffer.States.StatesUsed - 1 do\r\n begin\r\n State1 := @FUREBuffer.States.States[I];\r\n if State1.ID = SizeInt(I) then\r\n begin\r\n J := 0;\r\n while J < I do\r\n begin\r\n State2 := @FUREBuffer.States.States[J];\r\n if State2.ID = SizeInt(J) then\r\n begin\r\n FUREBuffer.EquivalentList.EquivalentsUsed := 0;\r\n AddEquivalentPair(I, J);\r\n\r\n Done := False;\r\n Equal := 0;\r\n while Equal < FUREBuffer.EquivalentList.EquivalentsUsed do\r\n begin\r\n LeftState := @FUREBuffer.States.States[FUREBuffer.EquivalentList.Equivalents[Equal].Left];\r\n RightState := @FUREBuffer.States.States[FUREBuffer.EquivalentList.Equivalents[Equal].Right];\r\n\r\n if (LeftState.Accepting <> RightState.Accepting) or\r\n (LeftState.TransitionsUsed <> RightState.TransitionsUsed) then\r\n begin\r\n Done := True;\r\n Break;\r\n end;\r\n\r\n K := 0;\r\n while (K < LeftState.TransitionsUsed) and\r\n (LeftState.Transitions[K].LHS = RightState.Transitions[K].LHS) do\r\n Inc(K);\r\n\r\n if K < LeftState.TransitionsUsed then\r\n begin\r\n Done := True;\r\n Break;\r\n end;\r\n\r\n for K := 0 to LeftState.TransitionsUsed - 1 do\r\n AddEquivalentPair(LeftState.Transitions[K].RHS, RightState.Transitions[K].RHS);\r\n\r\n Inc(Equal);\r\n end;\r\n\r\n if not Done then\r\n Break;\r\n end;\r\n Inc(J);\r\n end;\r\n\r\n if J < I then\r\n begin\r\n with FUREBuffer do\r\n begin\r\n for Equal := 0 to EquivalentList.EquivalentsUsed - 1 do\r\n begin\r\n States.States[EquivalentList.Equivalents[Equal].Right].ID :=\r\n States.States[EquivalentList.Equivalents[Equal].Left].ID;\r\n end;\r\n end;\r\n end;\r\n\r\n end;\r\n end;\r\n\r\n // Renumber the states appropriately\r\n State1 := @FUREBuffer.States.States[0];\r\n Equal := 0;\r\n for I := 0 to FUREBuffer.States.StatesUsed - 1 do\r\n begin\r\n if State1.ID = SizeInt(I) then\r\n begin\r\n State1.ID := Equal;\r\n Inc(Equal);\r\n end\r\n else\r\n State1.ID := FUREBuffer.States.States[State1.ID].ID;\r\n Inc(State1);\r\n end;\r\nend;\r\n\r\nprocedure TURESearch.ClearUREBuffer;\r\nvar\r\n I: SizeInt;\r\nbegin\r\n with FUREBuffer do\r\n begin\r\n // quite a few dynamic arrays to free\r\n Stack.List := nil;\r\n ExpressionList.Expressions := nil;\r\n\r\n // the symbol table has been handed over to the DFA and will be freed on\r\n // release of the DFA\r\n SymbolTable.SymbolsUsed := 0;\r\n\r\n for I := 0 to States.StatesUsed - 1 do\r\n begin\r\n States.States[I].Transitions := nil;\r\n States.States[I].StateList.List := nil;\r\n States.States[I].StateList.ListUsed := 0;\r\n States.States[I].TransitionsUsed := 0;\r\n end;\r\n\r\n States.StatesUsed := 0;\r\n States.States := nil;\r\n EquivalentList.Equivalents := nil;\r\n end;\r\n ResetMemory(FUREBuffer, SizeOf(FUREBuffer));\r\nend;\r\n\r\nprocedure TURESearch.CompileURE(RE: PWideChar; RELength: SizeInt; Casefold: Boolean);\r\nvar\r\n I, J: SizeInt;\r\n State: SizeInt;\r\n Run: PUcState;\r\n TP: SizeInt;\r\n\r\n procedure UREError(Text: string; RE: PWideChar);\r\n var\r\n S: string;\r\n begin\r\n S := RE;\r\n raise EJclUnicodeError.CreateResFmt(@RsUREErrorFmt, [LoadResString(@RsUREBaseString), Text, S]);\r\n end;\r\n\r\nbegin\r\n // be paranoid\r\n if (RE <> nil) and (RE^ <> WideNull) and (RELength > 0) then\r\n begin\r\n // Reset the various fields of the compilation buffer. Default the Flags\r\n // to indicate the presense of the \"^$\" pattern. If any other pattern\r\n // occurs, then this flag will be removed. This is done to catch this\r\n // special pattern and handle it specially when matching.\r\n ClearUREBuffer;\r\n ClearDFA;\r\n FUREBuffer.Flags := _URE_DFA_BLANKLINE;\r\n if Casefold then\r\n FUREBuffer.Flags := FUREBuffer.Flags or _URE_DFA_CASEFOLD;\r\n\r\n // Construct the NFA. If this stage returns a 0, then an error occured or an\r\n // empty expression was passed.\r\n State := ConvertRegExpToNFA(RE, RELength);\r\n if State <> _URE_NOOP then\r\n begin\r\n // Do the expression reduction to get the initial DFA.\r\n Reduce(State);\r\n\r\n // Merge all the equivalent DFA States.\r\n MergeEquivalents;\r\n\r\n // Construct the minimal DFA.\r\n FDFA.Flags := FUREBuffer.Flags and (_URE_DFA_CASEFOLD or _URE_DFA_BLANKLINE);\r\n\r\n // Free up the NFA state groups and transfer the symbols from the buffer\r\n // to the DFA.\r\n FDFA.SymbolTable := FUREBuffer.SymbolTable;\r\n FUREBuffer.SymbolTable.Symbols := nil;\r\n\r\n // Collect the total number of states and transitions needed for the DFA.\r\n State := 0;\r\n for I := 0 to FUREBuffer.States.StatesUsed - 1 do\r\n begin\r\n if FUREBuffer.States.States[I].ID = State then\r\n begin\r\n Inc(FDFA.StateList.StatesUsed);\r\n Inc(FDFA.TransitionList.TransitionsUsed, FUREBuffer.States.States[I].TransitionsUsed);\r\n Inc(State);\r\n end;\r\n end;\r\n\r\n // Allocate enough space for the states and transitions.\r\n SetLength(FDFA.StateList.States, FDFA.StateList.StatesUsed);\r\n SetLength(FDFA.TransitionList.Transitions, FDFA.TransitionList.TransitionsUsed);\r\n\r\n // Actually transfer the DFA States from the buffer.\r\n State := 0;\r\n TP := 0;\r\n Run := @FUREBuffer.States.States[0];\r\n for I := 0 to FUREBuffer.States.StatesUsed - 1 do\r\n begin\r\n if Run.ID = State then\r\n begin\r\n FDFA.StateList.States[I].StartTransition := TP;\r\n FDFA.StateList.States[I].NumberTransitions := Run.TransitionsUsed;\r\n FDFA.StateList.States[I].Accepting := Run.Accepting;\r\n\r\n // Add the transitions for the state\r\n for J := 0 to FDFA.StateList.States[I].NumberTransitions - 1 do\r\n begin\r\n FDFA.TransitionList.Transitions[TP].Symbol := Run.Transitions[J].LHS;\r\n FDFA.TransitionList.Transitions[TP].NextState :=\r\n FUREBuffer.States.States[Run.Transitions[J].RHS].ID;\r\n Inc(TP);\r\n end;\r\n\r\n Inc(State);\r\n end;\r\n Inc(Run);\r\n end;\r\n end\r\n else\r\n begin\r\n // there might be an error while parsing the pattern, show it if so\r\n case FUREBuffer.Error of\r\n _URE_UNEXPECTED_EOS:\r\n UREError(LoadResString(@RsUREUnexpectedEOS), RE);\r\n _URE_CCLASS_OPEN:\r\n UREError(LoadResString(@RsURECharacterClassOpen), RE);\r\n _URE_UNBALANCED_GROUP:\r\n UREError(LoadResString(@RsUREUnbalancedGroup), RE);\r\n _URE_INVALID_PROPERTY:\r\n UREError(LoadResString(@RsUREInvalidCharProperty), RE);\r\n _URE_INVALID_RANGE:\r\n UREError(LoadResString(@RsUREInvalidRepeatRange), RE);\r\n _URE_RANGE_OPEN:\r\n UREError(LoadResString(@RsURERepeatRangeOpen), RE);\r\n else\r\n // expression was empty\r\n raise EJclUnicodeError.CreateRes(@RsUREExpressionEmpty);\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TURESearch.ClearDFA;\r\nvar\r\n I: SizeInt;\r\nbegin\r\n with FDFA do\r\n begin\r\n for I := 0 to SymbolTable.SymbolsUsed - 1 do\r\n begin\r\n if (SymbolTable.Symbols[I].AType = _URE_CCLASS) or\r\n (SymbolTable.Symbols[I].AType = _URE_NCCLASS) then\r\n SymbolTable.Symbols[I].Symbol.CCL.Ranges := nil;\r\n end;\r\n\r\n for I := 0 to SymbolTable.SymbolsUsed - 1 do\r\n begin\r\n FDFA.SymbolTable.Symbols[I].States.List := nil;\r\n FDFA.SymbolTable.Symbols[I].States.ListUsed := 0;\r\n end;\r\n SymbolTable.SymbolsUsed := 0;\r\n\r\n SymbolTable.Symbols := nil;\r\n StateList.States := nil;\r\n TransitionList.Transitions := nil;\r\n end;\r\n ResetMemory(FDFA, SizeOf(FDFA));\r\nend;\r\n\r\nfunction IsSeparator(C: UCS4): Boolean;\r\nbegin\r\n Result := (C = $D) or (C = $A) or (C = $2028) or (C = $2029);\r\nend;\r\n\r\nfunction TURESearch.ExecuteURE(Flags: Cardinal; Text: PUCS2; TextLen: SizeInt; var MatchStart,\r\n MatchEnd: SizeInt): Boolean;\r\nvar\r\n I, J: SizeInt;\r\n Matched,\r\n Found: Boolean;\r\n Start, Stop: SizeInt;\r\n C: UCS4;\r\n Run, Tail, lp: PUCS2;\r\n LastState: PDFAState;\r\n Symbol: PUcSymbolTableEntry;\r\n Rp: PUcRange;\r\n LCMapping: TUCS4Array;\r\nbegin\r\n Result := False;\r\n if Text <> nil then\r\n begin\r\n // Handle the special case of an empty string matching the \"^$\" pattern.\r\n if (Textlen = 0) and ((FDFA.Flags and _URE_DFA_BLANKLINE) <> 0) then\r\n begin\r\n MatchStart := 0;\r\n MatchEnd := 0;\r\n Result := True;\r\n Exit;\r\n end;\r\n\r\n Run := Text;\r\n Tail := Run + TextLen;\r\n Start := -1;\r\n Stop := -1;\r\n LastState := @FDFA.StateList.States[0];\r\n\r\n Found := False;\r\n while not Found and (Run < Tail) do\r\n begin\r\n lp := Run;\r\n C := UCS4(Run^);\r\n Inc(Run);\r\n\r\n // Check to see if this is a high surrogate that should be combined with a\r\n // following low surrogate.\r\n if (Run < Tail) and\r\n (SurrogateHighStart <= C) and (C <= SurrogateHighEnd) and\r\n (SurrogateLowStart <= UCS4(Run^)) and (UCS4(Run^) <= SurrogateLowEnd) then\r\n begin\r\n C := $10000 + (((C and $03FF) shl 10) or (UCS4(Run^) and $03FF));\r\n Inc(Run);\r\n end;\r\n\r\n // Determine if the character is non-spacing and should be skipped.\r\n if ((Flags and URE_IGNORE_NONSPACING) <> 0) and UnicodeIsNonSpacing(C) then\r\n begin\r\n Inc(Run);\r\n Continue;\r\n end;\r\n\r\n if (FDFA.Flags and _URE_DFA_CASEFOLD) <> 0 then\r\n begin\r\n SetLength(LCMapping, 0);\r\n { TODO : use the entire mapping, not only the first character }\r\n // (CaseLookup used for a little extra speed: avoids dynamic array allocation)\r\n if CaseLookup(C, ctLower, LCMapping) then\r\n C := LCMapping[0];\r\n end;\r\n\r\n // See if one of the transitions matches.\r\n I := LastState.NumberTransitions - 1;\r\n Matched := False;\r\n\r\n while not Matched and (I >= 0) do\r\n begin\r\n Symbol := @FDFA.SymbolTable.Symbols[FDFA.TransitionList.Transitions[LastState.StartTransition + I].Symbol];\r\n case Symbol.AType of\r\n _URE_ANY_CHAR:\r\n if ((Flags and URE_DONT_MATCHES_SEPARATORS) <> 0) or\r\n not IsSeparator(C) then\r\n Matched := True;\r\n _URE_CHAR:\r\n if C = Symbol.Symbol.Chr then\r\n Matched := True;\r\n _URE_BOL_ANCHOR:\r\n if Lp = Text then\r\n begin\r\n Run := lp;\r\n Matched := True;\r\n end\r\n else\r\n begin\r\n if IsSeparator(C) then\r\n begin\r\n if (C = $D) and (Run < Tail) and (Run^ = #$A) then\r\n Inc(Run);\r\n Lp := Run;\r\n Matched := True;\r\n end;\r\n end;\r\n _URE_EOL_ANCHOR:\r\n if IsSeparator(C) then\r\n begin\r\n // Put the pointer back before the separator so the match end\r\n // position will be correct. This will also cause the `Run'\r\n // pointer to be advanced over the current separator once the\r\n // match end point has been recorded.\r\n Run := Lp;\r\n Matched := True;\r\n end;\r\n _URE_CCLASS,\r\n _URE_NCCLASS:\r\n with Symbol^ do\r\n begin\r\n if Categories <> [] then\r\n Matched := CategoryLookup(C, Categories);\r\n if Symbol.CCL.RangesUsed > 0 then\r\n begin\r\n Rp := @Symbol.CCL.Ranges[0];\r\n for J := 0 to Symbol.CCL.RangesUsed - 1 do\r\n begin\r\n if (Rp.MinCode <= C) and (C <= Rp.MaxCode) then\r\n begin\r\n Matched := True;\r\n Break;\r\n end;\r\n Inc(Rp);\r\n end;\r\n end;\r\n\r\n if AType = _URE_NCCLASS then\r\n Matched := not Matched;\r\n end;\r\n end;\r\n\r\n if Matched then\r\n begin\r\n if Start = -1 then\r\n Start := Lp - Text\r\n else\r\n Stop := Run - Text;\r\n\r\n LastState := @FDFA.StateList.States[FDFA.TransitionList.Transitions[LastState.StartTransition + I].NextState];\r\n\r\n // If the match was an EOL anchor, adjust the pointer past the separator\r\n // that caused the match. The correct match position has been recorded\r\n // already.\r\n if Symbol.AType = _URE_EOL_ANCHOR then\r\n begin\r\n // skip the character that caused the match\r\n Inc(Run);\r\n // handle the infamous CRLF situation\r\n if (Run < Tail) and (C = $D) and (Run^ = #$A) then\r\n Inc(Run);\r\n end;\r\n end;\r\n Dec(I);\r\n end;\r\n\r\n if not Matched then\r\n begin\r\n Found := LastState.Accepting;\r\n if not Found then\r\n begin\r\n // If the last state was not accepting, then reset and start over.\r\n LastState := @FDFA.StateList.States[0];\r\n Start := -1;\r\n Stop := -1;\r\n end\r\n else\r\n begin\r\n // set start and stop pointer if not yet done\r\n if Start = -1 then\r\n begin\r\n Start := Lp - Text;\r\n Stop := Run - Text;\r\n end\r\n else\r\n begin\r\n if Stop = -1 then\r\n Stop := Lp - Text;\r\n end;\r\n end;\r\n end\r\n else\r\n begin\r\n if Run = Tail then\r\n begin\r\n if not LastState.Accepting then\r\n begin\r\n // This ugly hack is to make sure the end-of-line anchors match\r\n // when the source text hits the end. This is only done if the last\r\n // subexpression matches.\r\n for I := 0 to LastState.NumberTransitions - 1 do\r\n begin\r\n if Found then\r\n Break;\r\n Symbol := @FDFA.SymbolTable.Symbols[FDFA.TransitionList.Transitions[LastState.StartTransition + I].Symbol];\r\n if Symbol.AType =_URE_EOL_ANCHOR then\r\n begin\r\n LastState := @FDFA.StateList.States[FDFA.TransitionList.Transitions[LastState.StartTransition + I].NextState];\r\n if LastState.Accepting then\r\n begin\r\n Stop := Run - Text;\r\n Found := True;\r\n end\r\n else\r\n Break;\r\n end;\r\n end;\r\n end\r\n else\r\n begin\r\n // Make sure any conditions that match all the way to the end of\r\n // the string match.\r\n Found := True;\r\n Stop := Run - Text;\r\n end;\r\n end;\r\n end;\r\n end;\r\n\r\n if Found then\r\n begin\r\n MatchStart := Start;\r\n MatchEnd := Stop;\r\n end;\r\n Result := Found;\r\n end;\r\nend;\r\n\r\nfunction TURESearch.FindAll(const Text: WideString): Boolean;\r\nbegin\r\n Result := FindAll(PWideChar(Text), Length(Text));\r\nend;\r\n\r\nfunction TURESearch.FindAll(Text: PWideChar; TextLen: SizeInt): Boolean;\r\n// Looks for all occurences of the pattern passed to FindPrepare and creates an\r\n// internal list of their positions.\r\nvar\r\n Start, Stop: SizeInt;\r\n Run: PWideChar;\r\n RunLen: SizeInt;\r\nbegin\r\n ClearResults;\r\n Run := Text;\r\n RunLen := TextLen;\r\n // repeat to find all occurences of the pattern\r\n Start := 0;\r\n Stop := 0;\r\n while ExecuteURE(0, Run, RunLen, Start, Stop) do\r\n begin\r\n // store this result (consider text pointer movement)...\r\n AddResult(Start + (Run - Text), Stop + (Run - Text));\r\n // ... and advance text position and length\r\n Inc(Run, Stop);\r\n Dec(RunLen, Stop);\r\n end;\r\n Result := FResults.Count > 0;\r\nend;\r\n\r\nfunction TURESearch.FindFirst(const Text: WideString; var Start, Stop: SizeInt): Boolean;\r\nbegin\r\n Result := FindFirst(PWideChar(Text), Length(Text), Start, Stop);\r\nend;\r\n\r\nfunction TURESearch.FindFirst(Text: PWideChar; TextLen: SizeInt; var Start, Stop: SizeInt): Boolean;\r\n// Looks for the first occurence of the pattern passed to FindPrepare in Text and\r\n// returns True if one could be found (in which case Start and Stop are set to\r\n// the according indices) otherwise False. This function is in particular of\r\n// interest if only one occurence needs to be found.\r\nbegin\r\n ClearResults;\r\n Result := ExecuteURE(0, Text, TextLen, Start, Stop);\r\n if Result then\r\n AddResult(Start, Stop);\r\nend;\r\n\r\nprocedure TURESearch.FindPrepare(Pattern: PWideChar; PatternLength: SizeInt; Options: TSearchFlags);\r\nbegin\r\n CompileURE(Pattern, PatternLength, not (sfCaseSensitive in Options));\r\nend;\r\n\r\nprocedure TURESearch.FindPrepare(const Pattern: WideString; Options: TSearchFlags);\r\nbegin\r\n CompileURE(PWideChar(Pattern), Length(Pattern), not (sfCaseSensitive in Options));\r\nend;\r\n\r\n//=== { TWideStrings } =======================================================\r\n\r\nconstructor TWideStrings.Create;\r\nbegin\r\n inherited Create;\r\n FLanguage := GetUserDefaultLCID;\r\n FNormalizationForm := nfC;\r\n FSaveFormat := sfUnicodeLSB;\r\nend;\r\n\r\nprocedure TWideStrings.SetLanguage(Value: LCID);\r\nbegin\r\n FLanguage := Value;\r\nend;\r\n\r\nfunction TWideStrings.GetSaveUnicode: Boolean;\r\nbegin\r\n Result := SaveFormat = sfUnicodeLSB;\r\nend;\r\n\r\nprocedure TWideStrings.SetSaveUnicode(const Value: Boolean);\r\nbegin\r\n if Value then\r\n SaveFormat := sfUnicodeLSB\r\n else\r\n SaveFormat := sfAnsi;\r\nend;\r\n\r\nfunction TWideStrings.Add(const S: WideString): Integer;\r\nbegin\r\n Result := GetCount;\r\n Insert(Result, S);\r\nend;\r\n\r\nfunction TWideStrings.AddObject(const S: WideString; AObject: TObject): Integer;\r\nbegin\r\n Result := Add(S);\r\n PutObject(Result, AObject);\r\nend;\r\n\r\nprocedure TWideStrings.Append(const S: WideString);\r\nbegin\r\n Add(S);\r\nend;\r\n\r\nprocedure TWideStrings.AddStrings(Strings: TStrings);\r\nvar\r\n I: Integer;\r\n {$IFNDEF SUPPORTS_UNICODE}\r\n CP: Word;\r\n {$ENDIF ~SUPPORTS_UNICODE}\r\nbegin\r\n BeginUpdate;\r\n try\r\n {$IFNDEF SUPPORTS_UNICODE}\r\n CP := CodePageFromLocale(FLanguage);\r\n {$ENDIF ~SUPPORTS_UNICODE}\r\n for I := 0 to Strings.Count - 1 do\r\n begin\r\n {$IFDEF SUPPORTS_UNICODE}\r\n AddObject(Strings[I], Strings.Objects[I])\r\n {$ELSE ~SUPPORTS_UNICODE}\r\n AddObject(StringToWideStringEx(Strings[I], CP), Strings.Objects[I])\r\n {$ENDIF ~SUPPORTS_UNICODE}\r\n end;\r\n finally\r\n EndUpdate;\r\n end;\r\nend;\r\n\r\nprocedure TWideStrings.AddStrings(Strings: TWideStrings);\r\nvar\r\n I: Integer;\r\nbegin\r\n Assert(Strings <> nil);\r\n\r\n BeginUpdate;\r\n try\r\n for I := 0 to Strings.Count - 1 do\r\n AddObject(Strings[I], Strings.Objects[I]);\r\n finally\r\n EndUpdate;\r\n end;\r\nend;\r\n\r\nprocedure TWideStrings.Assign(Source: TPersistent);\r\n// usual assignment routine, but able to assign wide and small strings\r\nbegin\r\n if Source is TWideStrings then\r\n begin\r\n BeginUpdate;\r\n try\r\n Clear;\r\n AddStrings(TWideStrings(Source));\r\n finally\r\n EndUpdate;\r\n end;\r\n end\r\n else\r\n begin\r\n if Source is TStrings then\r\n begin\r\n BeginUpdate;\r\n try\r\n Clear;\r\n AddStrings(TStrings(Source));\r\n finally\r\n EndUpdate;\r\n end;\r\n end\r\n else\r\n inherited Assign(Source);\r\n end;\r\nend;\r\n\r\nprocedure TWideStrings.AssignTo(Dest: TPersistent);\r\n// need to do also assignment to old style TStrings, but this class doesn't know\r\n// TWideStrings, so we need to do it from here\r\nvar\r\n I: Integer;\r\n {$IFNDEF SUPPORTS_UNICODE}\r\n CP: Word;\r\n {$ENDIF ~SUPPORTS_UNICODE}\r\nbegin\r\n if Dest is TStrings then\r\n begin\r\n with Dest as TStrings do\r\n begin\r\n BeginUpdate;\r\n try\r\n {$IFNDEF SUPPORTS_UNICODE}\r\n CP := CodePageFromLocale(FLanguage);\r\n {$ENDIF SUPPORTS_UNICODE}\r\n Clear;\r\n for I := 0 to Self.Count - 1 do\r\n begin\r\n {$IFDEF SUPPORTS_UNICODE}\r\n AddObject(Self[I], Self.Objects[I]);\r\n {$ELSE ~SUPPORTS_UNICODE}\r\n AddObject(WideStringToStringEx(Self[I], CP), Self.Objects[I]);\r\n {$ENDIF ~SUPPORTS_UNICODE}\r\n end;\r\n finally\r\n EndUpdate;\r\n end;\r\n end;\r\n end\r\n else\r\n begin\r\n if Dest is TWideStrings then\r\n begin\r\n with Dest as TWideStrings do\r\n begin\r\n BeginUpdate;\r\n try\r\n Clear;\r\n AddStrings(Self);\r\n finally\r\n EndUpdate;\r\n end;\r\n end;\r\n end\r\n else\r\n inherited AssignTo(Dest);\r\n end;\r\nend;\r\n\r\nprocedure TWideStrings.BeginUpdate;\r\nbegin\r\n if FUpdateCount = 0 then\r\n SetUpdateState(True);\r\n Inc(FUpdateCount);\r\nend;\r\n\r\nprocedure TWideStrings.DefineProperties(Filer: TFiler);\r\n\r\n// Defines a private property for the content of the list.\r\n// There's a bug in the handling of text DFMs in Classes.pas which prevents\r\n// WideStrings from loading under some circumstances. Zbysek Hlinka\r\n// (zhlinka att login dott cz) brought this to my attention and supplied also a solution.\r\n// See ReadData and WriteData methods for implementation details.\r\n\r\n //--------------- local function --------------------------------------------\r\n\r\n function DoWrite: Boolean;\r\n begin\r\n if Filer.Ancestor <> nil then\r\n begin\r\n Result := True;\r\n if Filer.Ancestor is TWideStrings then\r\n Result := not Equals(TWideStrings(Filer.Ancestor))\r\n end\r\n else\r\n Result := Count > 0;\r\n end;\r\n\r\n //--------------- end local function ----------------------------------------\r\n\r\nbegin\r\n Filer.DefineProperty('WideStrings', ReadData, WriteData, DoWrite);\r\nend;\r\n\r\nprocedure TWideStrings.DoConfirmConversion(var Allowed: Boolean);\r\nbegin\r\n if Assigned(FOnConfirmConversion) then\r\n FOnConfirmConversion(Self, Allowed);\r\nend;\r\n\r\nprocedure TWideStrings.EndUpdate;\r\nbegin\r\n Dec(FUpdateCount);\r\n if FUpdateCount = 0 then\r\n SetUpdateState(False);\r\nend;\r\n\r\nfunction TWideStrings.Equals(Strings: TWideStrings): Boolean;\r\nvar\r\n I, Count: Integer;\r\nbegin\r\n Assert(Strings <> nil);\r\n\r\n Result := False;\r\n Count := GetCount;\r\n if Count <> Strings.GetCount then\r\n Exit;\r\n { TODO : use internal comparation routine as soon as composition is implemented }\r\n for I := 0 to Count - 1 do\r\n if Get(I) <> Strings.Get(I) then\r\n Exit;\r\n Result := True;\r\nend;\r\n\r\nprocedure TWideStrings.Error(const Msg: string; Data: Integer);\r\n\r\n function ReturnAddr: Pointer;\r\n asm\r\n {$IFDEF CPU32}\r\n MOV EAX, EBP\r\n MOV EAX, [EAX + 4]\r\n {$ENDIF CPU32}\r\n {$IFDEF CPU64}\r\n MOV RAX, RBP\r\n MOV RAX, [RAX + 8]\r\n {$ENDIF CPU64}\r\n end;\r\n\r\nbegin\r\n raise EStringListError.CreateFmt(Msg, [Data]) at ReturnAddr;\r\nend;\r\n\r\nprocedure TWideStrings.Exchange(Index1, Index2: Integer);\r\nvar\r\n TempObject: TObject;\r\n TempString: WideString;\r\nbegin\r\n BeginUpdate;\r\n try\r\n TempString := Strings[Index1];\r\n TempObject := Objects[Index1];\r\n Strings[Index1] := Strings[Index2];\r\n Objects[Index1] := Objects[Index2];\r\n Strings[Index2] := TempString;\r\n Objects[Index2] := TempObject;\r\n finally\r\n EndUpdate;\r\n end;\r\nend;\r\n\r\nfunction TWideStrings.GetCapacity: Integer;\r\n// Descendants may optionally override/replace this default implementation.\r\nbegin\r\n Result := Count;\r\nend;\r\n\r\nfunction TWideStrings.GetCommaText: WideString;\r\nvar\r\n S: WideString;\r\n P: PWideChar;\r\n I, Count: Integer;\r\nbegin\r\n Count := GetCount;\r\n if (Count = 1) and (Get(0) = '') then\r\n Result := '\"\"'\r\n else\r\n begin\r\n Result := '';\r\n for I := 0 to Count - 1 do\r\n begin\r\n S := Get(I);\r\n P := PWideChar(S);\r\n while (P^ > WideSpace) and (P^ <> '\"') and (P^ <> ',') do\r\n Inc(P);\r\n if P^ <> WideNull then\r\n S := WideQuotedStr(S, '\"');\r\n Result := Result + S + ',';\r\n end;\r\n System.Delete(Result, Length(Result), 1);\r\n end;\r\nend;\r\n\r\nfunction TWideStrings.GetName(Index: Integer): WideString;\r\nvar\r\n P: Integer;\r\nbegin\r\n Result := Get(Index);\r\n P := Pos('=', Result);\r\n if P > 0 then\r\n SetLength(Result, P - 1)\r\n else\r\n Result := '';\r\nend;\r\n\r\nfunction TWideStrings.GetObject(Index: Integer): TObject;\r\nbegin\r\n Result := nil;\r\nend;\r\n\r\nfunction TWideStrings.GetSeparatedText(Separators: WideString): WideString;\r\n// Same as GetText but with customizable separator characters.\r\nvar\r\n I, L,\r\n Size,\r\n Count,\r\n SepSize: Integer;\r\n P: PWideChar;\r\n S: WideString;\r\nbegin\r\n Count := GetCount;\r\n SepSize := Length(Separators);\r\n Size := 0;\r\n for I := 0 to Count - 1 do\r\n Inc(Size, Length(Get(I)) + SepSize);\r\n\r\n // set one separator less, the last line does not need a trailing separator\r\n SetLength(Result, Size - SepSize);\r\n if Size > 0 then\r\n begin\r\n P := Pointer(Result);\r\n I := 0;\r\n while True do\r\n begin\r\n S := Get(I);\r\n L := Length(S);\r\n if L <> 0 then\r\n begin\r\n // add current string\r\n System.Move(Pointer(S)^, P^, 2 * L);\r\n Inc(P, L);\r\n end;\r\n Inc(I);\r\n if I = Count then\r\n Break;\r\n\r\n // add separators\r\n System.Move(Pointer(Separators)^, P^, SizeOf(WideChar) * SepSize);\r\n Inc(P, SepSize);\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TWideStrings.GetTextStr: WideString;\r\nbegin\r\n Result := GetSeparatedText(WideCRLF);\r\nend;\r\n\r\nfunction TWideStrings.GetText: PWideChar;\r\nbegin\r\n Result := StrNewW(GetTextStr);\r\nend;\r\n\r\nfunction TWideStrings.GetValue(const Name: WideString): WideString;\r\nvar\r\n I: Integer;\r\nbegin\r\n I := IndexOfName(Name);\r\n if I >= 0 then\r\n Result := Copy(Get(I), Length(Name) + 2, MaxInt)\r\n else\r\n Result := '';\r\nend;\r\n\r\nfunction TWideStrings.IndexOf(const S: WideString): Integer;\r\nvar\r\n NormString: WideString;\r\nbegin\r\n NormString := WideNormalize(S, FNormalizationForm);\r\n\r\n for Result := 0 to GetCount - 1 do\r\n if WideCompareText(Get(Result), NormString, FLanguage) = 0 then\r\n Exit;\r\n Result := -1;\r\nend;\r\n\r\nfunction TWideStrings.IndexOfName(const Name: WideString): Integer;\r\nvar\r\n P: Integer;\r\n S: WideString;\r\n NormName: WideString;\r\nbegin\r\n NormName := WideNormalize(Name, FNormalizationForm);\r\n\r\n for Result := 0 to GetCount - 1 do\r\n begin\r\n S := Get(Result);\r\n P := Pos('=', S);\r\n if (P > 0) and (WideCompareText(Copy(S, 1, P - 1), NormName, FLanguage) = 0) then\r\n Exit;\r\n end;\r\n Result := -1;\r\nend;\r\n\r\nfunction TWideStrings.IndexOfObject(AObject: TObject): Integer;\r\nbegin\r\n for Result := 0 to GetCount - 1 do\r\n if GetObject(Result) = AObject then\r\n Exit;\r\n Result := -1;\r\nend;\r\n\r\nprocedure TWideStrings.InsertObject(Index: Integer; const S: WideString; AObject: TObject);\r\nbegin\r\n Insert(Index, S);\r\n PutObject(Index, AObject);\r\nend;\r\n\r\nprocedure TWideStrings.LoadFromFile(const FileName: TFileName);\r\nvar\r\n Stream: TStream;\r\nbegin\r\n try\r\n Stream := TFileStream.Create(FileName, fmOpenRead or fmShareDenyWrite);\r\n try\r\n LoadFromStream(Stream);\r\n finally\r\n Stream.Free;\r\n end;\r\n except\r\n RaiseLastOSError;\r\n end;\r\nend;\r\n\r\nprocedure TWideStrings.LoadFromStream(Stream: TStream);\r\n// usual loader routine, but enhanced to handle byte order marks in stream\r\nvar\r\n Size,\r\n BytesRead: Integer;\r\n ByteOrderMask: array [0..5] of Byte; // BOM size is max 5 bytes (cf: wikipedia)\r\n // but it is easier to implement with a multiple of 2\r\n Loaded: Boolean;\r\n SW: WideString;\r\n SA: AnsiString;\r\nbegin\r\n BeginUpdate;\r\n try\r\n Loaded := False;\r\n\r\n Size := Stream.Size - Stream.Position;\r\n ByteOrderMask[0] := 0;\r\n BytesRead := Stream.Read(ByteOrderMask[0],SizeOf(ByteOrderMask));\r\n\r\n // UTF16 LSB = Unicode LSB\r\n if (BytesRead >= 2) and (ByteOrderMask[0] = BOM_UTF16_LSB[0])\r\n and (ByteOrderMask[1] = BOM_UTF16_LSB[1]) then\r\n begin\r\n FSaveFormat := sfUTF16LSB;\r\n SetLength(SW, (Size - 2) div SizeOf(WideChar));\r\n Assert((Size and 1) <> 1,'Number of chars must be a multiple of 2');\r\n if BytesRead > 2 then\r\n begin\r\n System.Move(ByteOrderMask[2], SW[1], BytesRead-2); // max 4 bytes = 2 widechars\r\n if Size > BytesRead then\r\n // first 2 chars (maximum) were copied by System.Move\r\n Stream.Read(SW[3], Size-BytesRead);\r\n end;\r\n SetText(SW);\r\n Loaded := True;\r\n end;\r\n\r\n // UTF16 MSB = Unicode MSB\r\n if (BytesRead >= 2) and (ByteOrderMask[0] = BOM_UTF16_MSB[0])\r\n and (ByteOrderMask[1] = BOM_UTF16_MSB[1]) then\r\n begin\r\n FSaveFormat := sfUTF16MSB;\r\n SetLength(SW, (Size - 2) div SizeOf(WideChar));\r\n Assert((Size and 1) <> 1,'Number of chars must be a multiple of 2');\r\n if BytesRead > 2 then\r\n begin\r\n System.Move(ByteOrderMask[2],SW[1],BytesRead-2); // max 4 bytes = 2 widechars\r\n if Size > BytesRead then\r\n // first 2 chars (maximum) were copied by System.Move\r\n Stream.Read(SW[3], Size-BytesRead);\r\n StrSwapByteOrder(PWideChar(SW));\r\n end;\r\n SetText(SW);\r\n Loaded := True;\r\n end;\r\n\r\n // UTF8\r\n if (BytesRead >= 3) and (ByteOrderMask[0] = BOM_UTF8[0])\r\n and (ByteOrderMask[1] = BOM_UTF8[1]) and (ByteOrderMask[2] = BOM_UTF8[2]) then\r\n begin\r\n FSaveFormat := sfUTF8;\r\n SetLength(SA, (Size-3) div SizeOf(AnsiChar));\r\n if BytesRead > 3 then\r\n begin\r\n System.Move(ByteOrderMask[3],SA[1],BytesRead-3); // max 3 bytes = 3 chars\r\n if Size > BytesRead then\r\n // first 3 chars were copied by System.Move\r\n Stream.Read(SA[4], Size-BytesRead);\r\n SW := UTF8ToWideString(SA);\r\n end;\r\n SetText(SW);\r\n Loaded := True;\r\n end;\r\n\r\n // default case (Ansi)\r\n if not Loaded then\r\n begin\r\n FSaveFormat := sfAnsi;\r\n SetLength(SA, Size div SizeOf(AnsiChar));\r\n if BytesRead > 0 then\r\n begin\r\n System.Move(ByteOrderMask[0], SA[1], BytesRead); // max 6 bytes = 6 chars\r\n if Size > BytesRead then\r\n Stream.Read(SA[7], Size-BytesRead); // first 6 chars were copied by System.Move\r\n end;\r\n SetText(StringToWideStringEx(SA, CodePageFromLocale(FLanguage)));\r\n end;\r\n finally\r\n EndUpdate;\r\n end;\r\nend;\r\n\r\nprocedure TWideStrings.Move(CurIndex, NewIndex: Integer);\r\nvar\r\n TempObject: TObject;\r\n TempString: WideString;\r\nbegin\r\n if CurIndex <> NewIndex then\r\n begin\r\n BeginUpdate;\r\n try\r\n TempString := Get(CurIndex);\r\n TempObject := GetObject(CurIndex);\r\n Delete(CurIndex);\r\n InsertObject(NewIndex, TempString, TempObject);\r\n finally\r\n EndUpdate;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TWideStrings.ReadData(Reader: TReader);\r\nbegin\r\n case Reader.NextValue of\r\n vaLString, vaString:\r\n SetText(Reader.ReadString);\r\n else\r\n SetText(Reader.{$IFDEF RTL240_UP}ReadString{$ELSE}ReadWideString{$ENDIF});\r\n end;\r\nend;\r\n\r\nprocedure TWideStrings.SaveToFile(const FileName: TFileName);\r\nvar\r\n Stream: TStream;\r\nbegin\r\n Stream := TFileStream.Create(FileName, fmCreate);\r\n try\r\n SaveToStream(Stream);\r\n finally\r\n Stream.Free;\r\n end;\r\nend;\r\n\r\nprocedure TWideStrings.SaveToStream(Stream: TStream; WithBOM: Boolean = True);\r\n// Saves the currently loaded text into the given stream. WithBOM determines whether to write a\r\n// byte order mark or not. Note: when saved as ANSI text there will never be a BOM.\r\nvar\r\n SW: WideString;\r\n SA: AnsiString;\r\n Allowed: Boolean;\r\n Run: PWideChar;\r\nbegin\r\n // The application can decide in which format to save the content.\r\n // If FSaveUnicode is False then all strings are saved in standard ANSI format\r\n // which is also loadable by TStrings but you should be aware that all Unicode\r\n // strings are then converted to ANSI based on the current system locale.\r\n // An extra event is supplied to ask the user about the potential loss of\r\n // information when converting Unicode to ANSI strings.\r\n SW := GetTextStr;\r\n Allowed := True;\r\n FSaved := False; // be pessimistic\r\n // A check for potential information loss makes only sense if the application has\r\n // set an event to be used as call back to ask about the conversion.\r\n if (FSaveFormat = sfAnsi) and Assigned(FOnConfirmConversion) then\r\n begin\r\n // application requests to save only ANSI characters, so check the text and\r\n // call back in case information could be lost\r\n Run := PWideChar(SW);\r\n // only ask if there's at least one Unicode character in the text\r\n while (Run^>#0) and (run^<=#255) do\r\n Inc(Run);\r\n // Note: The application can still set FSaveUnicode to True in the callback.\r\n if Run^ <> WideNull then\r\n DoConfirmConversion(Allowed);\r\n end;\r\n\r\n if Allowed then\r\n begin\r\n // only save if allowed\r\n case SaveFormat of\r\n sfUTF16LSB :\r\n begin\r\n if WithBOM then\r\n Stream.WriteBuffer(BOM_UTF16_LSB[0],SizeOf(BOM_UTF16_LSB));\r\n if Length(SW) > 0 then\r\n Stream.WriteBuffer(SW[1],Length(SW)*SizeOf(UTF16));\r\n FSaved := True;\r\n end;\r\n sfUTF16MSB :\r\n begin\r\n if WithBOM then\r\n Stream.WriteBuffer(BOM_UTF16_MSB[0],SizeOf(BOM_UTF16_MSB));\r\n if Length(SW) > 0 then\r\n begin\r\n StrSwapByteOrder(PWideChar(SW));\r\n Stream.WriteBuffer(SW[1],Length(SW)*SizeOf(UTF16));\r\n end;\r\n FSaved := True;\r\n end;\r\n sfUTF8 :\r\n begin\r\n if WithBOM then\r\n Stream.WriteBuffer(BOM_UTF8[0],SizeOf(BOM_UTF8));\r\n if Length(SW) > 0 then\r\n begin\r\n SA := WideStringToUTF8(SW);\r\n Stream.WriteBuffer(SA[1],Length(SA)*SizeOf(UTF8));\r\n end;\r\n FSaved := True;\r\n end;\r\n sfAnsi :\r\n begin\r\n if Length(SW) > 0 then\r\n begin\r\n SA := WideStringToStringEx(SW,CodePageFromLocale(FLanguage));\r\n Stream.WriteBuffer(SA[1],Length(SA)*SizeOf(AnsiChar));\r\n end;\r\n FSaved := True;\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TWideStrings.SetCapacity(NewCapacity: Integer);\r\nbegin\r\n // do nothing - descendants may optionally implement this method\r\nend;\r\n\r\nprocedure TWideStrings.SetCommaText(const Value: WideString);\r\nvar\r\n P, P1: PWideChar;\r\n S: WideString;\r\nbegin\r\n BeginUpdate;\r\n try\r\n Clear;\r\n P := PWideChar(Value);\r\n while (P^ >= #1) and (P^ <= WideSpace) do\r\n Inc(P);\r\n while P^ <> WideNull do\r\n begin\r\n if P^ = '\"' then\r\n S := WideExtractQuotedStr(P, '\"')\r\n else\r\n begin\r\n P1 := P;\r\n while (P^ > WideSpace) and (P^ <> ',') do\r\n Inc(P);\r\n SetString(S, P1, P - P1);\r\n end;\r\n Add(S);\r\n\r\n while (P^ >= #1) and (P^ <= WideSpace) do\r\n Inc(P);\r\n if P^ = ',' then\r\n begin\r\n repeat\r\n Inc(P);\r\n until not ((P^ >= #1) and (P^ <= WideSpace));\r\n end;\r\n end;\r\n finally\r\n EndUpdate;\r\n end;\r\nend;\r\n\r\nprocedure TWideStrings.SetText(const Value: WideString);\r\nvar\r\n Head,\r\n Tail: PWideChar;\r\n S: WideString;\r\nbegin\r\n BeginUpdate;\r\n try\r\n Clear;\r\n Head := PWideChar(Value);\r\n while Head^ <> WideNull do\r\n begin\r\n Tail := Head;\r\n while (Tail^ <> WideNull) and (Tail^ <> WideLineFeed) and (Tail^ <> WideCarriageReturn) and\r\n (Tail^ <> WideVerticalTab) and (Tail^ <> WideFormFeed) and (Tail^ <> WideLineSeparator) and\r\n (Tail^ <> WideParagraphSeparator) do\r\n Inc(Tail);\r\n SetString(S, Head, Tail - Head);\r\n Add(S);\r\n Head := Tail;\r\n if Head^ <> WideNull then\r\n begin\r\n Inc(Head);\r\n if (Tail^ = WideCarriageReturn) and (Head^ = WideLineFeed) then\r\n Inc(Head);\r\n end;\r\n end;\r\n finally\r\n EndUpdate;\r\n end;\r\nend;\r\n\r\nprocedure TWideStrings.SetUpdateState(Updating: Boolean);\r\nbegin\r\nend;\r\n\r\nprocedure TWideStrings.SetNormalizationForm(const Value: TNormalizationForm);\r\nvar\r\n I: Integer;\r\nbegin\r\n if FNormalizationForm <> Value then\r\n begin\r\n FNormalizationForm := Value;\r\n if FNormalizationForm <> nfNone then\r\n begin\r\n // renormalize all strings according to the new form\r\n for I := 0 to GetCount - 1 do\r\n Put(I, WideNormalize(Get(I), FNormalizationForm));\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TWideStrings.SetValue(const Name, Value: WideString);\r\nvar\r\n I : Integer;\r\nbegin\r\n I := IndexOfName(Name);\r\n if Value <> '' then\r\n begin\r\n if I < 0 then\r\n I := Add('');\r\n Put(I, Name + '=' + Value);\r\n end\r\n else\r\n begin\r\n if I >= 0 then\r\n Delete(I);\r\n end;\r\nend;\r\n\r\nprocedure TWideStrings.WriteData(Writer: TWriter);\r\nbegin\r\n Writer.{$IFDEF RTL240_UP}WriteString{$ELSE}WriteWideString{$ENDIF}(GetTextStr);\r\nend;\r\n\r\n//=== { TWideStringList } ====================================================\r\n\r\ndestructor TWideStringList.Destroy;\r\nbegin\r\n FOnChange := nil;\r\n FOnChanging := nil;\r\n Clear;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TWideStringList.Add(const S: WideString): Integer;\r\nbegin\r\n if not Sorted then\r\n Result := FCount\r\n else\r\n begin\r\n if Find(S, Result) then\r\n begin\r\n case Duplicates of\r\n dupIgnore:\r\n Exit;\r\n dupError:\r\n Error(SDuplicateString, 0);\r\n end;\r\n end;\r\n end;\r\n InsertItem(Result, S);\r\nend;\r\n\r\nprocedure TWideStringList.Changed;\r\nbegin\r\n if (FUpdateCount = 0) and Assigned(FOnChange) then\r\n FOnChange(Self);\r\nend;\r\n\r\nprocedure TWideStringList.Changing;\r\nbegin\r\n if (FUpdateCount = 0) and Assigned(FOnChanging) then\r\n FOnChanging(Self);\r\nend;\r\n\r\nprocedure TWideStringList.Clear;\r\n{$IFDEF OWN_WIDESTRING_MEMMGR}\r\nvar\r\n I: Integer;\r\n{$ENDIF OWN_WIDESTRING_MEMMGR}\r\nbegin\r\n if FCount <> 0 then\r\n begin\r\n Changing;\r\n {$IFDEF OWN_WIDESTRING_MEMMGR}\r\n for I := 0 to FCount - 1 do\r\n with FList[I] do\r\n if TDynWideCharArray(FString) <> nil then\r\n TDynWideCharArray(FString) := nil;\r\n {$ENDIF OWN_WIDESTRING_MEMMGR}\r\n // this will automatically finalize the array\r\n FList := nil;\r\n FCount := 0;\r\n SetCapacity(0);\r\n Changed;\r\n end;\r\nend;\r\n\r\nprocedure TWideStringList.Delete(Index: Integer);\r\nbegin\r\n if Cardinal(Index) >= Cardinal(FCount) then\r\n Error(SListIndexError, Index);\r\n Changing;\r\n\r\n {$IFDEF OWN_WIDESTRING_MEMMGR}\r\n SetListString(Index, '');\r\n {$ELSE ~OWN_WIDESTRING_MEMMGR}\r\n FList[Index].FString := '';\r\n {$ENDIF ~OWN_WIDESTRING_MEMMGR}\r\n Dec(FCount);\r\n if Index < FCount then\r\n begin\r\n System.Move(FList[Index + 1], FList[Index], (FCount - Index) * SizeOf(TWideStringItem));\r\n Pointer(FList[FCount].FString) := nil; // avoid freeing the string, the address is now used in another element\r\n end;\r\n Changed;\r\nend;\r\n\r\nprocedure TWideStringList.Exchange(Index1, Index2: Integer);\r\nbegin\r\n if Cardinal(Index1) >= Cardinal(FCount) then\r\n Error(SListIndexError, Index1);\r\n if Cardinal(Index2) >= Cardinal(FCount) then\r\n Error(SListIndexError, Index2);\r\n Changing;\r\n ExchangeItems(Index1, Index2);\r\n Changed;\r\nend;\r\n\r\nprocedure TWideStringList.ExchangeItems(Index1, Index2: Integer);\r\nvar\r\n Temp: TWideStringItem;\r\nbegin\r\n Temp := FList[Index1];\r\n FList[Index1] := FList[Index2];\r\n FList[Index2] := Temp;\r\nend;\r\n\r\nfunction TWideStringList.Find(const S: WideString; var Index: Integer): Boolean;\r\nvar\r\n L, H, I, C: Integer;\r\n NormString: WideString;\r\nbegin\r\n Result := False;\r\n NormString := WideNormalize(S, FNormalizationForm);\r\n L := 0;\r\n H := FCount - 1;\r\n while L <= H do\r\n begin\r\n I := (L + H) shr 1;\r\n C := WideCompareText(FList[I].FString, NormString, FLanguage);\r\n if C < 0 then\r\n L := I+1\r\n else\r\n begin\r\n H := I - 1;\r\n if C = 0 then\r\n begin\r\n Result := True;\r\n if Duplicates <> dupAccept then\r\n L := I;\r\n end;\r\n end;\r\n end;\r\n Index := L;\r\nend;\r\n\r\nfunction TWideStringList.Get(Index: Integer): WideString;\r\n{$IFDEF OWN_WIDESTRING_MEMMGR}\r\nvar\r\n Len: Integer;\r\n{$ENDIF OWN_WIDESTRING_MEMMGR}\r\nbegin\r\n if Cardinal(Index) >= Cardinal(FCount) then\r\n Error(SListIndexError, Index);\r\n {$IFDEF OWN_WIDESTRING_MEMMGR}\r\n with FList[Index] do\r\n begin\r\n Len := Length(TDynWideCharArray(FString));\r\n if Len > 0 then\r\n begin\r\n SetLength(Result, Len - 1); // exclude #0\r\n if Result <> '' then\r\n System.Move(FString^, Result[1], Len * SizeOf(WideChar));\r\n end\r\n else\r\n Result := '';\r\n end;\r\n {$ELSE ~OWN_WIDESTRING_MEMMGR}\r\n Result := FList[Index].FString;\r\n {$ENDIF ~OWN_WIDESTRING_MEMMGR}\r\nend;\r\n\r\nfunction TWideStringList.GetCapacity: Integer;\r\nbegin\r\n Result := Length(FList);\r\nend;\r\n\r\nfunction TWideStringList.GetCount: Integer;\r\nbegin\r\n Result := FCount;\r\nend;\r\n\r\nfunction TWideStringList.GetObject(Index: Integer): TObject;\r\nbegin\r\n if Cardinal(Index) >= Cardinal(FCount) then\r\n Error(SListIndexError, Index);\r\n Result := FList[Index].FObject;\r\nend;\r\n\r\nprocedure TWideStringList.Grow;\r\nvar\r\n Delta,\r\n Len: Integer;\r\nbegin\r\n Len := Length(FList);\r\n if Len > 64 then\r\n Delta := Len div 4\r\n else\r\n begin\r\n if Len > 8 then\r\n Delta := 16\r\n else\r\n Delta := 4;\r\n end;\r\n SetCapacity(Len + Delta);\r\nend;\r\n\r\nfunction TWideStringList.IndexOf(const S: WideString): Integer;\r\nbegin\r\n if not Sorted then\r\n Result := inherited IndexOf(S)\r\n else\r\n if not Find(S, Result) then\r\n Result := -1;\r\nend;\r\n\r\nprocedure TWideStringList.Insert(Index: Integer; const S: WideString);\r\nbegin\r\n if Sorted then\r\n Error(SSortedListError, 0);\r\n if Cardinal(Index) > Cardinal(FCount) then\r\n Error(SListIndexError, Index);\r\n InsertItem(Index, S);\r\nend;\r\n\r\n{$IFDEF OWN_WIDESTRING_MEMMGR}\r\nprocedure TWideStringList.SetListString(Index: Integer; const S: WideString);\r\nvar\r\n Len: Integer;\r\n A: TDynWideCharArray;\r\nbegin\r\n with FList[Index] do\r\n begin\r\n Pointer(A) := TDynWideCharArray(FString);\r\n if A <> nil then\r\n A := nil; // free memory\r\n\r\n Len := Length(S);\r\n if Len > 0 then\r\n begin\r\n SetLength(A, Len + 1); // include #0\r\n System.Move(S[1], A[0], Len * SizeOf(WideChar));\r\n A[Len] := #0;\r\n end;\r\n\r\n FString := PWideChar(A);\r\n Pointer(A) := nil; // do not release the array on procedure exit\r\n end;\r\nend;\r\n{$ENDIF OWN_WIDESTRING_MEMMGR}\r\n\r\nprocedure TWideStringList.InsertItem(Index: Integer; const S: WideString);\r\nbegin\r\n Changing;\r\n if FCount = Length(FList) then\r\n Grow;\r\n if Index < FCount then\r\n System.Move(FList[Index], FList[Index + 1], (FCount - Index) * SizeOf(TWideStringItem));\r\n with FList[Index] do\r\n begin\r\n Pointer(FString) := nil; // avoid freeing the string, the address is now used in another element\r\n FObject := nil;\r\n if (FNormalizationForm <> nfNone) and (Length(S) > 0) then\r\n {$IFDEF OWN_WIDESTRING_MEMMGR}\r\n SetListString(Index, WideNormalize(S, FNormalizationForm))\r\n else\r\n SetListString(Index, S);\r\n {$ELSE ~OWN_WIDESTRING_MEMMGR}\r\n FString := WideNormalize(S, FNormalizationForm)\r\n else\r\n FString := S;\r\n {$ENDIF ~OWN_WIDESTRING_MEMMGR}\r\n end;\r\n Inc(FCount);\r\n Changed;\r\nend;\r\n\r\nprocedure TWideStringList.Put(Index: Integer; const S: WideString);\r\nbegin\r\n if Sorted then\r\n Error(SSortedListError, 0);\r\n if Cardinal(Index) >= Cardinal(FCount) then\r\n Error(SListIndexError, Index);\r\n Changing;\r\n\r\n if (FNormalizationForm <> nfNone) and (Length(S) > 0) then\r\n {$IFDEF OWN_WIDESTRING_MEMMGR}\r\n SetListString(Index, WideNormalize(S, FNormalizationForm))\r\n else\r\n SetListString(Index, S);\r\n {$ELSE ~OWN_WIDESTRING_MEMMGR}\r\n FList[Index].FString := WideNormalize(S, FNormalizationForm)\r\n else\r\n FList[Index].FString := S;\r\n {$ENDIF ~OWN_WIDESTRING_MEMMGR}\r\n Changed;\r\nend;\r\n\r\nprocedure TWideStringList.PutObject(Index: Integer; AObject: TObject);\r\nbegin\r\n if Cardinal(Index) >= Cardinal(FCount) then\r\n Error(SListIndexError, Index);\r\n Changing;\r\n FList[Index].FObject := AObject;\r\n Changed;\r\nend;\r\n\r\nprocedure TWideStringList.QuickSort(L, R: Integer);\r\nvar\r\n I, J: Integer;\r\n P: WideString;\r\nbegin\r\n repeat\r\n I := L;\r\n J := R;\r\n P := FList[(L + R) shr 1].FString;\r\n repeat\r\n while WideCompareText(FList[I].FString, P, FLanguage) < 0 do\r\n Inc(I);\r\n while WideCompareText(FList[J].FString, P, FLanguage) > 0 do\r\n Dec(J);\r\n if I <= J then\r\n begin\r\n ExchangeItems(I, J);\r\n Inc(I);\r\n Dec(J);\r\n end;\r\n until I > J;\r\n if L < J then\r\n QuickSort(L, J);\r\n L := I;\r\n until I >= R;\r\nend;\r\n\r\nprocedure TWideStringList.SetCapacity(NewCapacity: Integer);\r\nbegin\r\n SetLength(FList, NewCapacity);\r\n if NewCapacity < FCount then\r\n FCount := NewCapacity;\r\nend;\r\n\r\nprocedure TWideStringList.SetSorted(Value: Boolean);\r\nbegin\r\n if FSorted <> Value then\r\n begin\r\n if Value then\r\n Sort;\r\n FSorted := Value;\r\n end;\r\nend;\r\n\r\nprocedure TWideStringList.SetUpdateState(Updating: Boolean);\r\nbegin\r\n if Updating then\r\n Changing\r\n else\r\n Changed;\r\nend;\r\n\r\nprocedure TWideStringList.Sort;\r\nbegin\r\n if not Sorted and (FCount > 1) then\r\n begin\r\n Changing;\r\n QuickSort(0, FCount - 1);\r\n Changed;\r\n end;\r\nend;\r\n\r\nprocedure TWideStringList.SetLanguage(Value: LCID);\r\nbegin\r\n inherited SetLanguage(Value);\r\n if Sorted then\r\n Sort;\r\nend;\r\n\r\n{$ENDIF ~UNICODE_RTL_DATABASE}\r\n\r\n// exchanges in each character of the given string the low order and high order\r\n// byte to go from LSB to MSB and vice versa.\r\n// EAX contains address of string\r\n\r\nfunction WideAdjustLineBreaks(const S: WideString): WideString;\r\nvar\r\n Source,\r\n SourceEnd,\r\n Dest: PWideChar;\r\nbegin\r\n Source := Pointer(S);\r\n SourceEnd := Source + Length(S);\r\n\r\n Source := Pointer(S);\r\n SetString(Result, nil, SourceEnd - Source);\r\n Dest := Pointer(Result);\r\n\r\n while Source < SourceEnd do\r\n begin\r\n case Source^ of\r\n WideLineFeed:\r\n begin\r\n Dest^ := WideLineSeparator;\r\n Inc(Dest);\r\n Inc(Source);\r\n end;\r\n WideCarriageReturn:\r\n begin\r\n Dest^ := WideLineSeparator;\r\n Inc(Dest);\r\n Inc(Source);\r\n if Source^ = WideLineFeed then\r\n Inc(Source);\r\n end;\r\n else\r\n Dest^ := Source^;\r\n Inc(Dest);\r\n Inc(Source);\r\n end;\r\n end;\r\n\r\n SetLength(Result, (TJclAddr(Dest) - TJclAddr(Result)) div 2);\r\nend;\r\n\r\nfunction WideQuotedStr(const S: WideString; Quote: WideChar): WideString;\r\n// works like QuotedStr from SysUtils.pas but can insert any quotation character\r\nvar\r\n P, Src,\r\n Dest: PWideChar;\r\n AddCount: SizeInt;\r\nbegin\r\n AddCount := 0;\r\n P := StrScanW(PWideChar(S), Quote);\r\n while (P <> nil) do\r\n begin\r\n Inc(P);\r\n Inc(AddCount);\r\n P := StrScanW(P, Quote);\r\n end;\r\n\r\n if AddCount = 0 then\r\n Result := Quote + S + Quote\r\n else\r\n begin\r\n SetLength(Result, Length(S) + AddCount + 2);\r\n Dest := PWideChar(Result);\r\n Dest^ := Quote;\r\n Inc(Dest);\r\n Src := PWideChar(S);\r\n P := StrScanW(Src, Quote);\r\n repeat\r\n Inc(P);\r\n Move(Src^, Dest^, 2 * (P - Src));\r\n Inc(Dest, P - Src);\r\n Dest^ := Quote;\r\n Inc(Dest);\r\n Src := P;\r\n P := StrScanW(Src, Quote);\r\n until P = nil;\r\n P := StrEndW(Src);\r\n Move(Src^, Dest^, 2 * (P - Src));\r\n Inc(Dest, P - Src);\r\n Dest^ := Quote;\r\n end;\r\nend;\r\n\r\nfunction WideExtractQuotedStr(var Src: PWideChar; Quote: WideChar): WideString;\r\n// extracts a string enclosed in quote characters given by Quote\r\nvar\r\n P, Dest: PWideChar;\r\n DropCount: SizeInt;\r\nbegin\r\n Result := '';\r\n if (Src = nil) or (Src^ <> Quote) then\r\n Exit;\r\n\r\n Inc(Src);\r\n DropCount := 1;\r\n P := Src;\r\n Src := StrScanW(Src, Quote);\r\n\r\n while Src <> nil do // count adjacent pairs of quote chars\r\n begin\r\n Inc(Src);\r\n if Src^ <> Quote then\r\n Break;\r\n Inc(Src);\r\n Inc(DropCount);\r\n Src := StrScanW(Src, Quote);\r\n end;\r\n\r\n if Src = nil then\r\n Src := StrEndW(P);\r\n if (Src - P) <= 1 then\r\n Exit;\r\n\r\n if DropCount = 1 then\r\n SetString(Result, P, Src - P - 1)\r\n else\r\n begin\r\n SetLength(Result, Src - P - DropCount);\r\n Dest := PWideChar(Result);\r\n Src := StrScanW(P, Quote);\r\n while Src <> nil do\r\n begin\r\n Inc(Src);\r\n if Src^ <> Quote then\r\n Break;\r\n Move(P^, Dest^, 2 * (Src - P));\r\n Inc(Dest, Src - P);\r\n Inc(Src);\r\n P := Src;\r\n Src := StrScanW(Src, Quote);\r\n end;\r\n if Src = nil then\r\n Src := StrEndW(P);\r\n Move(P^, Dest^, 2 * (Src - P - 1));\r\n end;\r\nend;\r\n\r\nfunction WideStringOfChar(C: WideChar; Count: SizeInt): WideString;\r\n// returns a string of Count characters filled with C\r\nvar\r\n I: SizeInt;\r\nbegin\r\n SetLength(Result, Count);\r\n for I := 1 to Count do\r\n Result[I] := C;\r\nend;\r\n\r\nfunction WideTrim(const S: WideString): WideString;\r\nvar\r\n I, L: SizeInt;\r\nbegin\r\n L := Length(S);\r\n I := 1;\r\n while (I <= L) and (UnicodeIsWhiteSpace(UCS4(S[I])) or UnicodeIsControl(UCS4(S[I]))) do\r\n Inc(I);\r\n if I > L then\r\n Result := ''\r\n else\r\n begin\r\n while UnicodeIsWhiteSpace(UCS4(S[L])) or UnicodeIsControl(UCS4(S[L])) do\r\n Dec(L);\r\n Result := Copy(S, I, L - I + 1);\r\n end;\r\nend;\r\n\r\nfunction WideTrimLeft(const S: WideString): WideString;\r\nvar\r\n I, L: SizeInt;\r\nbegin\r\n L := Length(S);\r\n I := 1;\r\n while (I <= L) and (UnicodeIsWhiteSpace(UCS4(S[I])) or UnicodeIsControl(UCS4(S[I]))) do\r\n Inc(I);\r\n Result := Copy(S, I, Maxint);\r\nend;\r\n\r\nfunction WideTrimRight(const S: WideString): WideString;\r\nvar\r\n I: SizeInt;\r\nbegin\r\n I := Length(S);\r\n while (I > 0) and (UnicodeIsWhiteSpace(UCS4(S[I])) or UnicodeIsControl(UCS4(S[I]))) do\r\n Dec(I);\r\n Result := Copy(S, 1, I);\r\nend;\r\n\r\n// returns the index of character Ch in S, starts searching at index Index\r\n// Note: This is a quick memory search. No attempt is made to interpret either\r\n// the given charcter nor the string (ligatures, modifiers, surrogates etc.)\r\n// Code from Azret Botash.\r\n\r\nfunction WideCharPos(const S: WideString; const Ch: WideChar; const Index: SizeInt): SizeInt;\r\nvar\r\n P, R: PWideChar;\r\nbegin\r\n if (Index > 0) and (Index <= Length(S)) then\r\n begin\r\n P := PWideChar(@S[Index]);\r\n R := StrScanW(P, Ch);\r\n if R <> nil then\r\n Result := R - P + Index\r\n else\r\n Result := 0;\r\n end\r\n else\r\n Result := 0;\r\nend;\r\n\r\n{$IFNDEF UNICODE_RTL_DATABASE}\r\n\r\nfunction WideComposeHangul(const Source: WideString): WideString;\r\nvar\r\n Len: SizeInt;\r\n Ch, Last: WideChar;\r\n I: SizeInt;\r\n LIndex, VIndex,\r\n SIndex, TIndex: SizeInt;\r\nbegin\r\n Result := '';\r\n Len := Length(Source);\r\n if Len > 0 then\r\n begin\r\n Last := Source[1];\r\n Result := Last;\r\n\r\n for I := 2 to Len do\r\n begin\r\n Ch := Source[I];\r\n\r\n // 1. check to see if two current characters are L and V\r\n LIndex := Word(Last) - LBase;\r\n if (0 <= LIndex) and (LIndex < LCount) then\r\n begin\r\n VIndex := Word(Ch) - VBase;\r\n if (0 <= VIndex) and (VIndex < VCount) then\r\n begin\r\n // make syllable of form LV\r\n Last := WideChar((SBase + (LIndex * VCount + VIndex) * TCount));\r\n Result[Length(Result)] := Last; // reset last\r\n Continue; // discard Ch\r\n end;\r\n end;\r\n\r\n // 2. check to see if two current characters are LV and T\r\n SIndex := Word(Last) - SBase;\r\n if (0 <= SIndex) and (SIndex < SCount) and ((SIndex mod TCount) = 0) then\r\n begin\r\n TIndex := Word(Ch) - TBase;\r\n if (0 <= TIndex) and (TIndex <= TCount) then\r\n begin\r\n // make syllable of form LVT\r\n Inc(Word(Last), TIndex);\r\n Result[Length(Result)] := Last; // reset last\r\n Continue; // discard Ch\r\n end;\r\n end;\r\n\r\n // if neither case was true, just add the character\r\n Last := Ch;\r\n Result := Result + Ch;\r\n end;\r\n end;\r\nend;\r\n\r\n// Returns canonical composition of characters in S.\r\n\r\nfunction WideCompose(const S: WideString; Compatible: Boolean): WideString;\r\nvar\r\n Buffer: array of UCS4;\r\n LastInPos, InPos, OutPos, BufferSize, NbProcessed: SizeInt;\r\n Composite: UCS4;\r\nbegin\r\n // Set an arbitrary length for the result. This is automatically done when checking\r\n // for hangul composition.\r\n Result := WideComposeHangul(S);\r\n\r\n if Result = '' then\r\n Exit;\r\n\r\n if Compositions = nil then\r\n LoadCompositionData;\r\n\r\n LastInPos := Length(Result);\r\n if LastInPos > MaxCompositionSize then\r\n SetLength(Buffer, MaxCompositionSize)\r\n else\r\n SetLength(Buffer, LastInPos);\r\n\r\n BufferSize := 0;\r\n InPos := 0;\r\n OutPos := 0;\r\n\r\n while (InPos < LastInPos) or (BufferSize > 0) do\r\n begin\r\n // fill buffer from input\r\n\r\n while BufferSize < Length(Buffer) do\r\n begin\r\n if InPos < LastInPos then\r\n begin\r\n Inc(InPos);\r\n Buffer[BufferSize] := UCS4(Result[InPos]);\r\n Inc(BufferSize);\r\n end\r\n else\r\n SetLength(Buffer, BufferSize);\r\n end;\r\n\r\n if Length(Buffer) = 0 then\r\n Break;\r\n\r\n NbProcessed := UnicodeCompose(Buffer, Composite, Compatible);\r\n if NbProcessed = 0 then\r\n Break;\r\n\r\n if BufferSize > NbProcessed then\r\n Move(Buffer[NbProcessed], Buffer[0], (BufferSize - NbProcessed) * SizeOf(UCS4));\r\n Dec(BufferSize, NbProcessed);\r\n\r\n Inc(OutPos);\r\n Result[OutPos] := UCS2(Composite);\r\n end;\r\n // since we have likely shortened the source string we have to set the correct length on exit\r\n SetLength(Result, OutPos);\r\nend;\r\n\r\nfunction WideCompose(const S: WideString; Tags: TCompatibilityFormattingTags): WideString;\r\nvar\r\n Buffer: array of UCS4;\r\n LastInPos, InPos, OutPos, BufferSize, NbProcessed: SizeInt;\r\n Composite: UCS4;\r\nbegin\r\n // Set an arbitrary length for the result. This is automatically done when checking\r\n // for hangul composition.\r\n Result := WideComposeHangul(S);\r\n\r\n if Result = '' then\r\n Exit;\r\n\r\n if Compositions = nil then\r\n LoadCompositionData;\r\n\r\n LastInPos := Length(Result);\r\n if LastInPos > MaxCompositionSize then\r\n SetLength(Buffer, MaxCompositionSize)\r\n else\r\n SetLength(Buffer, LastInPos);\r\n\r\n BufferSize := 0;\r\n InPos := 0;\r\n OutPos := 0;\r\n\r\n while (InPos < LastInPos) or (BufferSize > 0) do\r\n begin\r\n // fill buffer from input\r\n\r\n while BufferSize < Length(Buffer) do\r\n begin\r\n if InPos < LastInPos then\r\n begin\r\n Inc(InPos);\r\n Buffer[BufferSize] := UCS4(Result[InPos]);\r\n Inc(BufferSize);\r\n end\r\n else\r\n SetLength(Buffer, BufferSize);\r\n end;\r\n\r\n if Length(Buffer) = 0 then\r\n Break;\r\n\r\n NbProcessed := UnicodeCompose(Buffer, Composite, Tags);\r\n if NbProcessed = 0 then\r\n Break;\r\n\r\n if BufferSize > NbProcessed then\r\n Move(Buffer[NbProcessed], Buffer[0], (BufferSize - NbProcessed) * SizeOf(UCS4));\r\n Dec(BufferSize, NbProcessed);\r\n\r\n Inc(OutPos);\r\n Result[OutPos] := UCS2(Composite);\r\n end;\r\n // since we have likely shortened the source string we have to set the correct length on exit\r\n SetLength(Result, OutPos);\r\nend;\r\n\r\nprocedure FixCanonical(var S: WideString);\r\n// Examines S and reorders all combining marks in the string so that they are in canonical order.\r\nvar\r\n I: SizeInt;\r\n Temp: WideChar;\r\n CurrentClass,\r\n LastClass: Cardinal;\r\nbegin\r\n I := Length(S);\r\n if I > 1 then\r\n begin\r\n CurrentClass := CanonicalCombiningClass(UCS4(S[I]));\r\n repeat\r\n Dec(I);\r\n LastClass := CurrentClass;\r\n CurrentClass := CanonicalCombiningClass(UCS4(S[I]));\r\n\r\n // A swap is presumed to be rare (and a double-swap very rare),\r\n // so don't worry about efficiency here.\r\n if (CurrentClass > LastClass) and (LastClass > 0) then\r\n begin\r\n // swap characters\r\n Temp := S[I];\r\n S[I] := S[I + 1];\r\n S[I + 1] := Temp;\r\n\r\n // if not at end, backup (one further, to compensate for loop)\r\n if I < Length(S) - 1 then\r\n Inc(I, 2);\r\n // reset type, since we swapped.\r\n CurrentClass := CanonicalCombiningClass(UCS4(S[I]));\r\n end;\r\n until I = 1;\r\n end;\r\nend;\r\n\r\nfunction WideDecompose(const S: WideString; Compatible: Boolean): WideString;\r\n// returns a string with all characters of S but decomposed, e.g. is returned as E^ etc.\r\nvar\r\n I, J: SizeInt;\r\n Decomp: TUCS4Array;\r\nbegin\r\n Result := '';\r\n Decomp := nil;\r\n\r\n // iterate through each source code point\r\n for I := 1 to Length(S) do\r\n begin\r\n Decomp := UnicodeDecompose(UCS4(S[I]), Compatible);\r\n if Decomp = nil then\r\n Result := Result + S[I]\r\n else\r\n for J := 0 to High(Decomp) do\r\n Result := Result + WideChar(Decomp[J]);\r\n end;\r\n\r\n // combining marks must be sorted according to their canonical combining class\r\n FixCanonical(Result);\r\nend;\r\n\r\nfunction WideDecompose(const S: WideString; Tags: TCompatibilityFormattingTags): WideString;\r\n// returns a string with all characters of S but decomposed, e.g. is returned as E^ etc.\r\nvar\r\n I, J: SizeInt;\r\n Decomp: TUCS4Array;\r\nbegin\r\n Result := '';\r\n Decomp := nil;\r\n\r\n // iterate through each source code point\r\n for I := 1 to Length(S) do\r\n begin\r\n Decomp := UnicodeDecompose(UCS4(S[I]), Tags);\r\n if Decomp = nil then\r\n Result := Result + S[I]\r\n else\r\n for J := 0 to High(Decomp) do\r\n Result := Result + WideChar(Decomp[J]);\r\n end;\r\n\r\n // combining marks must be sorted according to their canonical combining class\r\n FixCanonical(Result);\r\nend;\r\n\r\nfunction WideNormalize(const S: WideString; Form: TNormalizationForm): WideString;\r\nvar\r\n Temp: WideString;\r\n Compatible: Boolean;\r\nbegin\r\n Result := S;\r\n\r\n if Form = nfNone then\r\n Exit; // No normalization needed.\r\n\r\n Compatible := Form in [nfKC, nfKD];\r\n if Form in [nfD, nfKD] then\r\n Result := WideDecompose(S, Compatible)\r\n else\r\n begin\r\n Temp := WideDecompose(S, Compatible);\r\n Result := WideCompose(Temp, Compatible);\r\n end;\r\nend;\r\n\r\n{$ENDIF ~UNICODE_RTL_DATABASE}\r\n\r\nfunction WideSameText(const Str1, Str2: WideString): Boolean;\r\n// Compares both strings case-insensitively and returns True if both are equal, otherwise False is returned.\r\nbegin\r\n Result := Length(Str1) = Length(Str2);\r\n if Result then\r\n Result := StrICompW(PWideChar(Str1), PWideChar(Str2)) = 0;\r\nend;\r\n\r\n//----------------- general purpose case mapping ---------------------------------------------------\r\n\r\n{$IFNDEF UNICODE_RTL_DATABASE}\r\n\r\nfunction WideCaseConvert(C: WideChar; CaseType: TCaseType): WideString;\r\nvar\r\n I, RPos: SizeInt;\r\n Mapping: TUCS4Array;\r\nbegin\r\n SetLength(Mapping, 0);\r\n if not CaseLookup(UCS4(C), CaseType, Mapping) then\r\n Result := C\r\n else\r\n begin\r\n SetLength(Result, 2 * Length(Mapping));\r\n RPos := 1;\r\n for I := Low(Mapping) to High(Mapping) do\r\n UTF16SetNextChar(Result, RPos, Mapping[I]);\r\n if RPos > 0 then\r\n SetLength(Result, RPos - 1)\r\n else\r\n raise EJclUnexpectedEOSequenceError.Create;\r\n end;\r\nend;\r\n\r\nfunction WideCaseConvert(const S: WideString; CaseType: TCaseType): WideString;\r\nvar\r\n SLen, RLen, SPos, RPos, K, MapLen: SizeInt;\r\n Code: UCS4;\r\n Mapping: TUCS4Array;\r\nbegin\r\n SetLength(Mapping, 0);\r\n SLen := Length(S);\r\n RLen := SLen;\r\n SetLength(Result, RLen);\r\n SPos := 1;\r\n RPos := 1;\r\n while (SPos > 0) and (SPos <= SLen) do\r\n begin\r\n Code := UTF16GetNextChar(S, SPos);\r\n if SPos = -1 then\r\n raise EJclUnexpectedEOSequenceError.Create;\r\n\r\n if CaseLookup(Code, CaseType, Mapping) then\r\n begin\r\n MapLen:= Length(Mapping);\r\n if MapLen = 1 then\r\n Code := Mapping[0];\r\n end\r\n else\r\n MapLen := 1;\r\n\r\n if MapLen = 1 then\r\n begin\r\n if not UTF16SetNextChar(Result, RPos, Code) then\r\n begin\r\n Inc(RLen, SLen);\r\n SetLength(Result, RLen);\r\n UTF16SetNextChar(Result, RPos, Code);\r\n end;\r\n end\r\n else\r\n begin\r\n for K := Low(Mapping) to High(Mapping) do\r\n if not UTF16SetNextChar(Result, RPos, Code) then\r\n begin\r\n Inc(RLen, SLen);\r\n SetLength(Result, RLen);\r\n UTF16SetNextChar(Result, RPos, Code);\r\n end;\r\n end;\r\n end;\r\n if RPos > 0 then\r\n SetLength(Result, RPos - 1)\r\n else\r\n raise EJclUnexpectedEOSequenceError.Create;\r\nend;\r\n\r\n// Note that most of the assigned code points don't have a case mapping and are therefore\r\n// returned as they are. Other code points, however, might be converted into several characters\r\n// like the german (eszett) whose upper case mapping is SS.\r\n\r\nfunction WideCaseFolding(C: WideChar): WideString;\r\n// Special case folding function to map a string to either its lower case or\r\n// to special cases. This can be used for case-insensitive comparation.\r\nbegin\r\n Result:= WideCaseConvert(C, ctFold);\r\nend;\r\n\r\nfunction WideCaseFolding(const S: WideString): WideString;\r\nbegin\r\n Result:= WideCaseConvert(S, ctFold);\r\nend;\r\n\r\n{$ENDIF ~UNICODE_RTL_DATABASE}\r\n\r\nfunction WideLowerCase(C: WideChar): WideString;\r\nbegin\r\n {$IFDEF UNICODE_RTL_DATABASE}\r\n Result := TCharacter.ToLower(C);\r\n {$ELSE ~UNICODE_RTL_DATABASE}\r\n Result:= WideCaseConvert(C, ctLower);\r\n {$ENDIF ~UNICODE_RTL_DATABASE}\r\nend;\r\n\r\nfunction WideLowerCase(const S: WideString): WideString;\r\nbegin\r\n {$IFDEF UNICODE_RTL_DATABASE}\r\n Result := TCharacter.ToLower(S);\r\n {$ELSE ~UNICODE_RTL_DATABASE}\r\n Result:= WideCaseConvert(S, ctLower);\r\n {$ENDIF ~UNICODE_RTL_DATABASE}\r\nend;\r\n\r\n{$IFNDEF UNICODE_RTL_DATABASE}\r\n\r\nfunction WideTitleCase(C: WideChar): WideString;\r\nbegin\r\n Result:= WideCaseConvert(C, ctTitle);\r\nend;\r\n\r\nfunction WideTitleCase(const S: WideString): WideString;\r\nbegin\r\n Result:= WideCaseConvert(S, ctTitle);\r\nend;\r\n\r\n{$ENDIF ~UNICODE_RTL_DATABASE}\r\n\r\nfunction WideUpperCase(C: WideChar): WideString;\r\nbegin\r\n {$IFDEF UNICODE_RTL_DATABASE}\r\n Result := TCharacter.ToUpper(C);\r\n {$ELSE ~UNICODE_RTL_DATABASE}\r\n Result:= WideCaseConvert(C, ctUpper);\r\n {$ENDIF ~UNICODE_RTL_DATABASE}\r\nend;\r\n\r\nfunction WideUpperCase(const S: WideString): WideString;\r\nbegin\r\n {$IFDEF UNICODE_RTL_DATABASE}\r\n Result := TCharacter.ToUpper(S);\r\n {$ELSE ~UNICODE_RTL_DATABASE}\r\n Result:= WideCaseConvert(S, ctUpper);\r\n {$ENDIF ~UNICODE_RTL_DATABASE}\r\nend;\r\n\r\n//----------------- character test routines --------------------------------------------------------\r\n\r\nfunction UnicodeIsAlpha(C: UCS4): Boolean; // Is the character alphabetic?\r\nbegin\r\n {$IFDEF UNICODE_RTL_DATABASE}\r\n Result := TCharacter.IsLetter(Chr(C));\r\n {$ELSE ~UNICODE_RTL_DATABASE}\r\n Result := CategoryLookup(C, ClassLetter);\r\n {$ENDIF ~UNICODE_RTL_DATABASE}\r\nend;\r\n\r\nfunction UnicodeIsDigit(C: UCS4): Boolean; // Is the character a digit?\r\nbegin\r\n {$IFDEF UNICODE_RTL_DATABASE}\r\n Result := TCharacter.IsDigit(Chr(C));\r\n {$ELSE ~UNICODE_RTL_DATABASE}\r\n Result := CategoryLookup(C, [ccNumberDecimalDigit]);\r\n {$ENDIF ~UNICODE_RTL_DATABASE}\r\nend;\r\n\r\nfunction UnicodeIsAlphaNum(C: UCS4): Boolean; // Is the character alphabetic or a number?\r\nbegin\r\n {$IFDEF UNICODE_RTL_DATABASE}\r\n Result := TCharacter.IsLetterOrDigit(Chr(C));\r\n {$ELSE ~UNICODE_RTL_DATABASE}\r\n Result := CategoryLookup(C, ClassLetter + [ccNumberDecimalDigit]);\r\n {$ENDIF ~UNICODE_RTL_DATABASE}\r\nend;\r\n\r\nfunction UnicodeIsNumberOther(C: UCS4): Boolean;\r\nbegin\r\n {$IFDEF UNICODE_RTL_DATABASE}\r\n Result := TCharacter.GetUnicodeCategory(Chr(C)) = TUnicodeCategory.ucOtherNumber;\r\n {$ELSE ~UNICODE_RTL_DATABASE}\r\n Result := CategoryLookup(C, [ccNumberOther]);\r\n {$ENDIF ~UNICODE_RTL_DATABASE}\r\nend;\r\n\r\nfunction UnicodeIsCased(C: UCS4): Boolean;\r\n// Is the character a \"cased\" character, i.e. either lower case, title case or upper case\r\nbegin\r\n {$IFDEF UNICODE_RTL_DATABASE}\r\n Result := TCharacter.GetUnicodeCategory(Chr(C)) in\r\n [TUnicodeCategory.ucLowercaseLetter, TUnicodeCategory.ucTitlecaseLetter, TUnicodeCategory.ucUppercaseLetter];\r\n {$ELSE ~UNICODE_RTL_DATABASE}\r\n Result := CategoryLookup(C, [ccLetterLowercase, ccLetterTitleCase, ccLetterUppercase]);\r\n {$ENDIF ~UNICODE_RTL_DATABASE}\r\nend;\r\n\r\nfunction UnicodeIsControl(C: UCS4): Boolean;\r\n// Is the character a control character?\r\nbegin\r\n {$IFDEF UNICODE_RTL_DATABASE}\r\n Result := TCharacter.GetUnicodeCategory(Chr(C)) in\r\n [TUnicodeCategory.ucControl, TUnicodeCategory.ucFormat];\r\n {$ELSE ~UNICODE_RTL_DATABASE}\r\n Result := CategoryLookup(C, [ccOtherControl, ccOtherFormat]);\r\n {$ENDIF ~UNICODE_RTL_DATABASE}\r\nend;\r\n\r\nfunction UnicodeIsSpace(C: UCS4): Boolean;\r\n// Is the character a spacing character?\r\nbegin\r\n {$IFDEF UNICODE_RTL_DATABASE}\r\n Result := TCharacter.GetUnicodeCategory(Chr(C)) = TUnicodeCategory.ucSpaceSeparator;\r\n {$ELSE ~UNICODE_RTL_DATABASE}\r\n Result := CategoryLookup(C, ClassSpace);\r\n {$ENDIF ~UNICODE_RTL_DATABASE}\r\nend;\r\n\r\nfunction UnicodeIsWhiteSpace(C: UCS4): Boolean;\r\n// Is the character a white space character (same as UnicodeIsSpace plus\r\n// tabulator, new line etc.)?\r\nbegin\r\n {$IFDEF UNICODE_RTL_DATABASE}\r\n Result := TCharacter.IsWhiteSpace(Chr(C));\r\n {$ELSE ~UNICODE_RTL_DATABASE}\r\n Result := CategoryLookup(C, ClassSpace + [ccWhiteSpace, ccSegmentSeparator]);\r\n {$ENDIF ~UNICODE_RTL_DATABASE}\r\nend;\r\n\r\nfunction UnicodeIsBlank(C: UCS4): Boolean;\r\n// Is the character a space separator?\r\nbegin\r\n {$IFDEF UNICODE_RTL_DATABASE}\r\n Result := TCharacter.GetUnicodeCategory(Chr(C)) = TUnicodeCategory.ucSpaceSeparator;\r\n {$ELSE ~UNICODE_RTL_DATABASE}\r\n Result := CategoryLookup(C, [ccSeparatorSpace]);\r\n {$ENDIF ~UNICODE_RTL_DATABASE}\r\nend;\r\n\r\nfunction UnicodeIsPunctuation(C: UCS4): Boolean;\r\n// Is the character a punctuation mark?\r\nbegin\r\n {$IFDEF UNICODE_RTL_DATABASE}\r\n Result := TCharacter.GetUnicodeCategory(Chr(C)) in\r\n [TUnicodeCategory.ucConnectPunctuation, TUnicodeCategory.ucDashPunctuation,\r\n TUnicodeCategory.ucClosePunctuation, TUnicodeCategory.ucFinalPunctuation,\r\n TUnicodeCategory.ucInitialPunctuation, TUnicodeCategory.ucOtherPunctuation,\r\n TUnicodeCategory.ucOpenPunctuation];\r\n {$ELSE ~UNICODE_RTL_DATABASE}\r\n Result := CategoryLookup(C, ClassPunctuation);\r\n {$ENDIF ~UNICODE_RTL_DATABASE}\r\nend;\r\n\r\nfunction UnicodeIsGraph(C: UCS4): Boolean;\r\n// Is the character graphical?\r\nbegin\r\n {$IFDEF UNICODE_RTL_DATABASE}\r\n Result := TCharacter.GetUnicodeCategory(Chr(C)) in\r\n [TUnicodeCategory.ucCombiningMark, TUnicodeCategory.ucEnclosingMark,\r\n TUnicodeCategory.ucNonSpacingMark,\r\n TUnicodeCategory.ucDecimalNumber, TUnicodeCategory.ucLetterNumber,\r\n TUnicodeCategory.ucOtherNumber,\r\n TUnicodeCategory.ucLowercaseLetter, TUnicodeCategory.ucModifierLetter,\r\n TUnicodeCategory.ucOtherLetter, TUnicodeCategory.ucTitlecaseLetter,\r\n TUnicodeCategory.ucUppercaseLetter,\r\n TUnicodeCategory.ucConnectPunctuation, TUnicodeCategory.ucDashPunctuation,\r\n TUnicodeCategory.ucClosePunctuation, TUnicodeCategory.ucFinalPunctuation,\r\n TUnicodeCategory.ucInitialPunctuation, TUnicodeCategory.ucOtherPunctuation,\r\n TUnicodeCategory.ucOpenPunctuation,\r\n TUnicodeCategory.ucCurrencySymbol, TUnicodeCategory.ucModifierSymbol,\r\n TUnicodeCategory.ucMathSymbol, TUnicodeCategory.ucOtherSymbol];\r\n {$ELSE ~UNICODE_RTL_DATABASE}\r\n Result := CategoryLookup(C, ClassMark + ClassNumber + ClassLetter + ClassPunctuation + ClassSymbol);\r\n {$ENDIF ~UNICODE_RTL_DATABASE}\r\nend;\r\n\r\nfunction UnicodeIsPrintable(C: UCS4): Boolean;\r\n// Is the character printable?\r\nbegin\r\n {$IFDEF UNICODE_RTL_DATABASE}\r\n Result := TCharacter.GetUnicodeCategory(Chr(C)) in\r\n [TUnicodeCategory.ucCombiningMark, TUnicodeCategory.ucEnclosingMark,\r\n TUnicodeCategory.ucNonSpacingMark,\r\n TUnicodeCategory.ucDecimalNumber, TUnicodeCategory.ucLetterNumber,\r\n TUnicodeCategory.ucOtherNumber,\r\n TUnicodeCategory.ucLowercaseLetter, TUnicodeCategory.ucModifierLetter,\r\n TUnicodeCategory.ucOtherLetter, TUnicodeCategory.ucTitlecaseLetter,\r\n TUnicodeCategory.ucUppercaseLetter,\r\n TUnicodeCategory.ucConnectPunctuation, TUnicodeCategory.ucDashPunctuation,\r\n TUnicodeCategory.ucClosePunctuation, TUnicodeCategory.ucFinalPunctuation,\r\n TUnicodeCategory.ucInitialPunctuation, TUnicodeCategory.ucOtherPunctuation,\r\n TUnicodeCategory.ucOpenPunctuation,\r\n TUnicodeCategory.ucCurrencySymbol, TUnicodeCategory.ucModifierSymbol,\r\n TUnicodeCategory.ucMathSymbol, TUnicodeCategory.ucOtherSymbol,\r\n TUnicodeCategory.ucSpaceSeparator];\r\n {$ELSE ~UNICODE_RTL_DATABASE}\r\n Result := CategoryLookup(C, ClassMark + ClassNumber + ClassLetter + ClassPunctuation + ClassSymbol +\r\n [ccSeparatorSpace]);\r\n {$ENDIF ~UNICODE_RTL_DATABASE}\r\nend;\r\n\r\nfunction UnicodeIsUpper(C: UCS4): Boolean;\r\n// Is the character already upper case?\r\nbegin\r\n {$IFDEF UNICODE_RTL_DATABASE}\r\n Result := TCharacter.GetUnicodeCategory(Chr(C)) = TUnicodeCategory.ucUppercaseLetter;\r\n {$ELSE ~UNICODE_RTL_DATABASE}\r\n Result := CategoryLookup(C, [ccLetterUppercase]);\r\n {$ENDIF ~UNICODE_RTL_DATABASE}\r\nend;\r\n\r\nfunction UnicodeIsLower(C: UCS4): Boolean;\r\n// Is the character already lower case?\r\nbegin\r\n {$IFDEF UNICODE_RTL_DATABASE}\r\n Result := TCharacter.GetUnicodeCategory(Chr(C)) = TUnicodeCategory.ucLowercaseLetter;\r\n {$ELSE ~UNICODE_RTL_DATABASE}\r\n Result := CategoryLookup(C, [ccLetterLowercase]);\r\n {$ENDIF ~UNICODE_RTL_DATABASE}\r\nend;\r\n\r\nfunction UnicodeIsTitle(C: UCS4): Boolean;\r\n// Is the character already title case?\r\nbegin\r\n {$IFDEF UNICODE_RTL_DATABASE}\r\n Result := TCharacter.GetUnicodeCategory(Chr(C)) = TUnicodeCategory.ucTitlecaseLetter;\r\n {$ELSE ~UNICODE_RTL_DATABASE}\r\n Result := CategoryLookup(C, [ccLetterTitlecase]);\r\n {$ENDIF ~UNICODE_RTL_DATABASE}\r\nend;\r\n\r\n{$IFNDEF UNICODE_RTL_DATABASE}\r\nfunction UnicodeIsHexDigit(C: UCS4): Boolean;\r\n// Is the character a hex digit?\r\nbegin\r\n Result := CategoryLookup(C, [ccHexDigit]);\r\nend;\r\n{$ENDIF ~UNICODE_RTL_DATABASE}\r\n\r\nfunction UnicodeIsIsoControl(C: UCS4): Boolean;\r\n// Is the character a C0 control character (< 32)?\r\nbegin\r\n {$IFDEF UNICODE_RTL_DATABASE}\r\n Result := TCharacter.GetUnicodeCategory(Chr(C)) = TUnicodeCategory.ucControl;\r\n {$ELSE ~UNICODE_RTL_DATABASE}\r\n Result := CategoryLookup(C, [ccOtherControl]);\r\n {$ENDIF ~UNICODE_RTL_DATABASE}\r\nend;\r\n\r\nfunction UnicodeIsFormatControl(C: UCS4): Boolean;\r\n// Is the character a format control character?\r\nbegin\r\n {$IFDEF UNICODE_RTL_DATABASE}\r\n Result := TCharacter.GetUnicodeCategory(Chr(C)) = TUnicodeCategory.ucFormat;\r\n {$ELSE ~UNICODE_RTL_DATABASE}\r\n Result := CategoryLookup(C, [ccOtherFormat]);\r\n {$ENDIF ~UNICODE_RTL_DATABASE}\r\nend;\r\n\r\nfunction UnicodeIsSymbol(C: UCS4): Boolean;\r\n// Is the character a symbol?\r\nbegin\r\n {$IFDEF UNICODE_RTL_DATABASE}\r\n Result := TCharacter.GetUnicodeCategory(Chr(C)) in\r\n [TUnicodeCategory.ucCurrencySymbol, TUnicodeCategory.ucModifierSymbol,\r\n TUnicodeCategory.ucMathSymbol, TUnicodeCategory.ucOtherSymbol];\r\n {$ELSE ~UNICODE_RTL_DATABASE}\r\n Result := CategoryLookup(C, ClassSymbol);\r\n {$ENDIF ~UNICODE_RTL_DATABASE}\r\nend;\r\n\r\nfunction UnicodeIsNumber(C: UCS4): Boolean;\r\n// Is the character a number or digit?\r\nbegin\r\n {$IFDEF UNICODE_RTL_DATABASE}\r\n Result := TCharacter.GetUnicodeCategory(Chr(C)) in\r\n [TUnicodeCategory.ucDecimalNumber, TUnicodeCategory.ucLetterNumber,\r\n TUnicodeCategory.ucOtherNumber];\r\n {$ELSE ~UNICODE_RTL_DATABASE}\r\n Result := CategoryLookup(C, ClassNumber);\r\n {$ENDIF ~UNICODE_RTL_DATABASE}\r\nend;\r\n\r\nfunction UnicodeIsNonSpacing(C: UCS4): Boolean;\r\n// Is the character non-spacing?\r\nbegin\r\n {$IFDEF UNICODE_RTL_DATABASE}\r\n Result := TCharacter.GetUnicodeCategory(Chr(C)) = TUnicodeCategory.ucNonSpacingMark;\r\n {$ELSE ~UNICODE_RTL_DATABASE}\r\n Result := CategoryLookup(C, [ccMarkNonSpacing]);\r\n {$ENDIF ~UNICODE_RTL_DATABASE}\r\nend;\r\n\r\nfunction UnicodeIsOpenPunctuation(C: UCS4): Boolean;\r\n// Is the character an open/left punctuation (e.g. '[')?\r\nbegin\r\n {$IFDEF UNICODE_RTL_DATABASE}\r\n Result := TCharacter.GetUnicodeCategory(Chr(C)) = TUnicodeCategory.ucOpenPunctuation;\r\n {$ELSE ~UNICODE_RTL_DATABASE}\r\n Result := CategoryLookup(C, [ccPunctuationOpen]);\r\n {$ENDIF ~UNICODE_RTL_DATABASE}\r\nend;\r\n\r\nfunction UnicodeIsClosePunctuation(C: UCS4): Boolean;\r\n// Is the character an close/right punctuation (e.g. ']')?\r\nbegin\r\n {$IFDEF UNICODE_RTL_DATABASE}\r\n Result := TCharacter.GetUnicodeCategory(Chr(C)) = TUnicodeCategory.ucClosePunctuation;\r\n {$ELSE ~UNICODE_RTL_DATABASE}\r\n Result := CategoryLookup(C, [ccPunctuationClose]);\r\n {$ENDIF ~UNICODE_RTL_DATABASE}\r\nend;\r\n\r\nfunction UnicodeIsInitialPunctuation(C: UCS4): Boolean;\r\n// Is the character an initial punctuation (e.g. U+2018 LEFT SINGLE QUOTATION MARK)?\r\nbegin\r\n {$IFDEF UNICODE_RTL_DATABASE}\r\n Result := TCharacter.GetUnicodeCategory(Chr(C)) = TUnicodeCategory.ucInitialPunctuation;\r\n {$ELSE ~UNICODE_RTL_DATABASE}\r\n Result := CategoryLookup(C, [ccPunctuationInitialQuote]);\r\n {$ENDIF ~UNICODE_RTL_DATABASE}\r\nend;\r\n\r\nfunction UnicodeIsFinalPunctuation(C: UCS4): Boolean;\r\n// Is the character a final punctuation (e.g. U+2019 RIGHT SINGLE QUOTATION MARK)?\r\nbegin\r\n {$IFDEF UNICODE_RTL_DATABASE}\r\n Result := TCharacter.GetUnicodeCategory(Chr(C)) = TUnicodeCategory.ucFinalPunctuation;\r\n {$ELSE ~UNICODE_RTL_DATABASE}\r\n Result := CategoryLookup(C, [ccPunctuationFinalQuote]);\r\n {$ENDIF ~UNICODE_RTL_DATABASE}\r\nend;\r\n\r\n{$IFNDEF UNICODE_RTL_DATABASE}\r\nfunction UnicodeIsComposed(C: UCS4): Boolean;\r\n// Can the character be decomposed into a set of other characters?\r\nbegin\r\n Result := CategoryLookup(C, [ccComposed]);\r\nend;\r\n\r\nfunction UnicodeIsQuotationMark(C: UCS4): Boolean;\r\n// Is the character one of the many quotation marks?\r\nbegin\r\n Result := CategoryLookup(C, [ccQuotationMark]);\r\nend;\r\n\r\nfunction UnicodeIsSymmetric(C: UCS4): Boolean;\r\n// Is the character one that has an opposite form (i.e. <>)?\r\nbegin\r\n Result := CategoryLookup(C, [ccSymmetric]);\r\nend;\r\n\r\nfunction UnicodeIsMirroring(C: UCS4): Boolean;\r\n// Is the character mirroring (superset of symmetric)?\r\nbegin\r\n Result := CategoryLookup(C, [ccMirroring]);\r\nend;\r\n\r\nfunction UnicodeIsNonBreaking(C: UCS4): Boolean;\r\n// Is the character non-breaking (i.e. non-breaking space)?\r\nbegin\r\n Result := CategoryLookup(C, [ccNonBreaking]);\r\nend;\r\n\r\nfunction UnicodeIsRightToLeft(C: UCS4): Boolean;\r\n// Does the character have strong right-to-left directionality (i.e. Arabic letters)?\r\nbegin\r\n Result := CategoryLookup(C, [ccRightToLeft]);\r\nend;\r\n\r\nfunction UnicodeIsLeftToRight(C: UCS4): Boolean;\r\n// Does the character have strong left-to-right directionality (i.e. Latin letters)?\r\nbegin\r\n Result := CategoryLookup(C, [ccLeftToRight]);\r\nend;\r\n\r\nfunction UnicodeIsStrong(C: UCS4): Boolean;\r\n// Does the character have strong directionality?\r\nbegin\r\n Result := CategoryLookup(C, [ccLeftToRight, ccRightToLeft]);\r\nend;\r\n\r\nfunction UnicodeIsWeak(C: UCS4): Boolean;\r\n// Does the character have weak directionality (i.e. numbers)?\r\nbegin\r\n Result := CategoryLookup(C, ClassEuropeanNumber + [ccArabicNumber, ccCommonNumberSeparator]);\r\nend;\r\n\r\nfunction UnicodeIsNeutral(C: UCS4): Boolean;\r\n// Does the character have neutral directionality (i.e. whitespace)?\r\nbegin\r\n Result := CategoryLookup(C, [ccSeparatorParagraph, ccSegmentSeparator, ccWhiteSpace, ccOtherNeutrals]);\r\nend;\r\n\r\nfunction UnicodeIsSeparator(C: UCS4): Boolean;\r\n// Is the character a block or segment separator?\r\nbegin\r\n Result := CategoryLookup(C, [ccSeparatorParagraph, ccSegmentSeparator]);\r\nend;\r\n\r\nfunction UnicodeIsMark(C: UCS4): Boolean;\r\n// Is the character a mark of some kind?\r\nbegin\r\n Result := CategoryLookup(C, ClassMark);\r\nend;\r\n\r\nfunction UnicodeIsModifier(C: UCS4): Boolean;\r\n// Is the character a letter modifier?\r\nbegin\r\n Result := CategoryLookup(C, [ccLetterModifier]);\r\nend;\r\n{$ENDIF ~UNICODE_RTL_DATABASE}\r\n\r\nfunction UnicodeIsLetterNumber(C: UCS4): Boolean;\r\n// Is the character a number represented by a letter?\r\nbegin\r\n {$IFDEF UNICODE_RTL_DATABASE}\r\n Result := TCharacter.GetUnicodeCategory(Chr(C)) = TUnicodeCategory.ucLetterNumber;\r\n {$ELSE ~UNICODE_RTL_DATABASE}\r\n Result := CategoryLookup(C, [ccNumberLetter]);\r\n {$ENDIF ~UNICODE_RTL_DATABASE}\r\nend;\r\n\r\nfunction UnicodeIsConnectionPunctuation(C: UCS4): Boolean;\r\n// Is the character connecting punctuation?\r\nbegin\r\n {$IFDEF UNICODE_RTL_DATABASE}\r\n Result := TCharacter.GetUnicodeCategory(Chr(C)) = TUnicodeCategory.ucConnectPunctuation;\r\n {$ELSE ~UNICODE_RTL_DATABASE}\r\n Result := CategoryLookup(C, [ccPunctuationConnector]);\r\n {$ENDIF ~UNICODE_RTL_DATABASE}\r\nend;\r\n\r\nfunction UnicodeIsDash(C: UCS4): Boolean;\r\n// Is the character a dash punctuation?\r\nbegin\r\n {$IFDEF UNICODE_RTL_DATABASE}\r\n Result := TCharacter.GetUnicodeCategory(Chr(C)) = TUnicodeCategory.ucDashPunctuation;\r\n {$ELSE ~UNICODE_RTL_DATABASE}\r\n Result := CategoryLookup(C, [ccPunctuationDash]);\r\n {$ENDIF ~UNICODE_RTL_DATABASE}\r\nend;\r\n\r\nfunction UnicodeIsMath(C: UCS4): Boolean;\r\n// Is the character a math character?\r\nbegin\r\n {$IFDEF UNICODE_RTL_DATABASE}\r\n Result := TCharacter.GetUnicodeCategory(Chr(C)) = TUnicodeCategory.ucMathSymbol;\r\n {$ELSE ~UNICODE_RTL_DATABASE}\r\n Result := CategoryLookup(C, [ccSymbolMath]);\r\n {$ENDIF ~UNICODE_RTL_DATABASE}\r\nend;\r\n\r\nfunction UnicodeIsCurrency(C: UCS4): Boolean;\r\n// Is the character a currency character?\r\nbegin\r\n {$IFDEF UNICODE_RTL_DATABASE}\r\n Result := TCharacter.GetUnicodeCategory(Chr(C)) = TUnicodeCategory.ucCurrencySymbol;\r\n {$ELSE ~UNICODE_RTL_DATABASE}\r\n Result := CategoryLookup(C, [ccSymbolCurrency]);\r\n {$ENDIF ~UNICODE_RTL_DATABASE}\r\nend;\r\n\r\nfunction UnicodeIsModifierSymbol(C: UCS4): Boolean;\r\n// Is the character a modifier symbol?\r\nbegin\r\n {$IFDEF UNICODE_RTL_DATABASE}\r\n Result := TCharacter.GetUnicodeCategory(Chr(C)) = TUnicodeCategory.ucModifierSymbol;\r\n {$ELSE ~UNICODE_RTL_DATABASE}\r\n Result := CategoryLookup(C, [ccSymbolModifier]);\r\n {$ENDIF ~UNICODE_RTL_DATABASE}\r\nend;\r\n\r\nfunction UnicodeIsSpacingMark(C: UCS4): Boolean;\r\n// Is the character a spacing mark?\r\nbegin\r\n {$IFDEF UNICODE_RTL_DATABASE}\r\n Result := TCharacter.GetUnicodeCategory(Chr(C)) in\r\n [TUnicodeCategory.ucLineSeparator, TUnicodeCategory.ucParagraphSeparator,\r\n TUnicodeCategory.ucSpaceSeparator];\r\n {$ELSE ~UNICODE_RTL_DATABASE}\r\n Result := CategoryLookup(C, [ccMarkSpacingCombining]);\r\n {$ENDIF ~UNICODE_RTL_DATABASE}\r\nend;\r\n\r\nfunction UnicodeIsEnclosing(C: UCS4): Boolean;\r\n// Is the character enclosing (i.e. enclosing box)?\r\nbegin\r\n {$IFDEF UNICODE_RTL_DATABASE}\r\n Result := TCharacter.GetUnicodeCategory(Chr(C)) = TUnicodeCategory.ucEnclosingMark;\r\n {$ELSE ~UNICODE_RTL_DATABASE}\r\n Result := CategoryLookup(C, [ccMarkEnclosing]);\r\n {$ENDIF ~UNICODE_RTL_DATABASE}\r\nend;\r\n\r\nfunction UnicodeIsPrivate(C: UCS4): Boolean;\r\n// Is the character from the Private Use Area?\r\nbegin\r\n {$IFDEF UNICODE_RTL_DATABASE}\r\n Result := TCharacter.GetUnicodeCategory(Chr(C)) = TUnicodeCategory.ucPrivateUse;\r\n {$ELSE ~UNICODE_RTL_DATABASE}\r\n Result := CategoryLookup(C, [ccOtherPrivate]);\r\n {$ENDIF ~UNICODE_RTL_DATABASE}\r\nend;\r\n\r\nfunction UnicodeIsSurrogate(C: UCS4): Boolean;\r\n// Is the character one of the surrogate codes?\r\nbegin\r\n {$IFDEF UNICODE_RTL_DATABASE}\r\n Result := TCharacter.GetUnicodeCategory(Chr(C)) = TUnicodeCategory.ucSurrogate;\r\n {$ELSE ~UNICODE_RTL_DATABASE}\r\n Result := CategoryLookup(C, [ccOtherSurrogate]);\r\n {$ENDIF ~UNICODE_RTL_DATABASE}\r\nend;\r\n\r\nfunction UnicodeIsLineSeparator(C: UCS4): Boolean;\r\n// Is the character a line separator?\r\nbegin\r\n {$IFDEF UNICODE_RTL_DATABASE}\r\n Result := TCharacter.GetUnicodeCategory(Chr(C)) = TUnicodeCategory.ucLineSeparator;\r\n {$ELSE ~UNICODE_RTL_DATABASE}\r\n Result := CategoryLookup(C, [ccSeparatorLine]);\r\n {$ENDIF ~UNICODE_RTL_DATABASE}\r\nend;\r\n\r\nfunction UnicodeIsParagraphSeparator(C: UCS4): Boolean;\r\n// Is th character a paragraph separator;\r\nbegin\r\n {$IFDEF UNICODE_RTL_DATABASE}\r\n Result := TCharacter.GetUnicodeCategory(Chr(C)) = TUnicodeCategory.ucParagraphSeparator;\r\n {$ELSE ~UNICODE_RTL_DATABASE}\r\n Result := CategoryLookup(C, [ccSeparatorParagraph]);\r\n {$ENDIF ~UNICODE_RTL_DATABASE}\r\nend;\r\n\r\nfunction UnicodeIsIdentifierStart(C: UCS4): Boolean;\r\n// Can the character begin an identifier?\r\nbegin\r\n {$IFDEF UNICODE_RTL_DATABASE}\r\n Result := TCharacter.GetUnicodeCategory(Chr(C)) in\r\n [TUnicodeCategory.ucLowercaseLetter, TUnicodeCategory.ucModifierLetter,\r\n TUnicodeCategory.ucOtherLetter, TUnicodeCategory.ucTitlecaseLetter,\r\n TUnicodeCategory.ucUppercaseLetter,\r\n TUnicodeCategory.ucLetterNumber];\r\n {$ELSE ~UNICODE_RTL_DATABASE}\r\n Result := CategoryLookup(C, ClassLetter + [ccNumberLetter]);\r\n {$ENDIF ~UNICODE_RTL_DATABASE}\r\nend;\r\n\r\nfunction UnicodeIsIdentifierPart(C: UCS4): Boolean;\r\n// Can the character appear in an identifier?\r\nbegin\r\n {$IFDEF UNICODE_RTL_DATABASE}\r\n Result := TCharacter.GetUnicodeCategory(Chr(C)) in\r\n [TUnicodeCategory.ucLowercaseLetter, TUnicodeCategory.ucModifierLetter,\r\n TUnicodeCategory.ucOtherLetter, TUnicodeCategory.ucTitlecaseLetter,\r\n TUnicodeCategory.ucUppercaseLetter,\r\n TUnicodeCategory.ucLetterNumber, TUnicodeCategory.ucDecimalNumber,\r\n TUnicodeCategory.ucNonSpacingMark, TUnicodeCategory.ucCombiningMark,\r\n TUnicodeCategory.ucConnectPunctuation,\r\n TUnicodeCategory.ucFormat];\r\n {$ELSE ~UNICODE_RTL_DATABASE}\r\n Result := CategoryLookup(C, ClassLetter + [ccNumberLetter, ccMarkNonSpacing, ccMarkSpacingCombining,\r\n ccNumberDecimalDigit, ccPunctuationConnector, ccOtherFormat]);\r\n {$ENDIF ~UNICODE_RTL_DATABASE}\r\nend;\r\n\r\nfunction UnicodeIsDefined(C: UCS4): Boolean;\r\n// Is the character defined (appears in one of the data files)?\r\nbegin\r\n {$IFDEF UNICODE_RTL_DATABASE}\r\n Result := TCharacter.GetUnicodeCategory(Chr(C)) <> TUnicodeCategory.ucUnassigned;\r\n {$ELSE ~UNICODE_RTL_DATABASE}\r\n Result := CategoryLookup(C, [ccAssigned]);\r\n {$ENDIF ~UNICODE_RTL_DATABASE}\r\nend;\r\n\r\nfunction UnicodeIsUndefined(C: UCS4): Boolean;\r\n// Is the character undefined (not assigned in the Unicode database)?\r\nbegin\r\n {$IFDEF UNICODE_RTL_DATABASE}\r\n Result := TCharacter.GetUnicodeCategory(Chr(C)) = TUnicodeCategory.ucUnassigned;\r\n {$ELSE ~UNICODE_RTL_DATABASE}\r\n Result := not CategoryLookup(C, [ccAssigned]);\r\n {$ENDIF ~UNICODE_RTL_DATABASE}\r\nend;\r\n\r\nfunction UnicodeIsHan(C: UCS4): Boolean;\r\n// Is the character a Han ideograph?\r\nbegin\r\n Result := ((C >= $4E00) and (C <= $9FFF)) or ((C >= $F900) and (C <= $FAFF));\r\nend;\r\n\r\nfunction UnicodeIsHangul(C: UCS4): Boolean;\r\n// Is the character a pre-composed Hangul syllable?\r\nbegin\r\n Result := (C >= $AC00) and (C <= $D7FF);\r\nend;\r\n\r\nfunction UnicodeIsUnassigned(C: UCS4): Boolean;\r\nbegin\r\n {$IFDEF UNICODE_RTL_DATABASE}\r\n Result := TCharacter.GetUnicodeCategory(Chr(C)) = TUnicodeCategory.ucUnassigned;\r\n {$ELSE ~UNICODE_RTL_DATABASE}\r\n Result := CategoryLookup(C, [ccOtherUnassigned]);\r\n {$ENDIF ~UNICODE_RTL_DATABASE}\r\nend;\r\n\r\nfunction UnicodeIsLetterOther(C: UCS4): Boolean;\r\nbegin\r\n {$IFDEF UNICODE_RTL_DATABASE}\r\n Result := TCharacter.GetUnicodeCategory(Chr(C)) = TUnicodeCategory.ucOtherLetter;\r\n {$ELSE ~UNICODE_RTL_DATABASE}\r\n Result := CategoryLookup(C, [ccLetterOther]);\r\n {$ENDIF ~UNICODE_RTL_DATABASE}\r\nend;\r\n\r\nfunction UnicodeIsConnector(C: UCS4): Boolean;\r\nbegin\r\n {$IFDEF UNICODE_RTL_DATABASE}\r\n Result := TCharacter.GetUnicodeCategory(Chr(C)) = TUnicodeCategory.ucConnectPunctuation;\r\n {$ELSE ~UNICODE_RTL_DATABASE}\r\n Result := CategoryLookup(C, [ccPunctuationConnector]);\r\n {$ENDIF ~UNICODE_RTL_DATABASE}\r\nend;\r\n\r\nfunction UnicodeIsPunctuationOther(C: UCS4): Boolean;\r\nbegin\r\n {$IFDEF UNICODE_RTL_DATABASE}\r\n Result := TCharacter.GetUnicodeCategory(Chr(C)) = TUnicodeCategory.ucOtherPunctuation;\r\n {$ELSE ~UNICODE_RTL_DATABASE}\r\n Result := CategoryLookup(C, [ccPunctuationOther]);\r\n {$ENDIF ~UNICODE_RTL_DATABASE}\r\nend;\r\n\r\nfunction UnicodeIsSymbolOther(C: UCS4): Boolean;\r\nbegin\r\n {$IFDEF UNICODE_RTL_DATABASE}\r\n Result := TCharacter.GetUnicodeCategory(Chr(C)) = TUnicodeCategory.ucOtherSymbol;\r\n {$ELSE ~UNICODE_RTL_DATABASE}\r\n Result := CategoryLookup(C, [ccSymbolOther]);\r\n {$ENDIF ~UNICODE_RTL_DATABASE}\r\nend;\r\n\r\n{$IFNDEF UNICODE_RTL_DATABASE}\r\nfunction UnicodeIsLeftToRightEmbedding(C: UCS4): Boolean;\r\nbegin\r\n Result := CategoryLookup(C, [ccLeftToRightEmbedding]);\r\nend;\r\n\r\nfunction UnicodeIsLeftToRightOverride(C: UCS4): Boolean;\r\nbegin\r\n Result := CategoryLookup(C, [ccLeftToRightOverride]);\r\nend;\r\n\r\nfunction UnicodeIsRightToLeftArabic(C: UCS4): Boolean;\r\nbegin\r\n Result := CategoryLookup(C, [ccRightToLeftArabic]);\r\nend;\r\n\r\nfunction UnicodeIsRightToLeftEmbedding(C: UCS4): Boolean;\r\nbegin\r\n Result := CategoryLookup(C, [ccRightToLeftEmbedding]);\r\nend;\r\n\r\nfunction UnicodeIsRightToLeftOverride(C: UCS4): Boolean;\r\nbegin\r\n Result := CategoryLookup(C, [ccRightToLeftOverride]);\r\nend;\r\n\r\nfunction UnicodeIsPopDirectionalFormat(C: UCS4): Boolean;\r\nbegin\r\n Result := CategoryLookup(C, [ccPopDirectionalFormat]);\r\nend;\r\n\r\nfunction UnicodeIsEuropeanNumber(C: UCS4): Boolean;\r\nbegin\r\n Result := CategoryLookup(C, [ccEuropeanNumber]);\r\nend;\r\n\r\nfunction UnicodeIsEuropeanNumberSeparator(C: UCS4): Boolean;\r\nbegin\r\n Result := CategoryLookup(C, [ccEuropeanNumberSeparator]);\r\nend;\r\n\r\nfunction UnicodeIsEuropeanNumberTerminator(C: UCS4): Boolean;\r\nbegin\r\n Result := CategoryLookup(C, [ccEuropeanNumberTerminator]);\r\nend;\r\n\r\nfunction UnicodeIsArabicNumber(C: UCS4): Boolean;\r\nbegin\r\n Result := CategoryLookup(C, [ccArabicNumber]);\r\nend;\r\n\r\nfunction UnicodeIsCommonNumberSeparator(C: UCS4): Boolean;\r\nbegin\r\n Result := CategoryLookup(C, [ccCommonNumberSeparator]);\r\nend;\r\n\r\nfunction UnicodeIsBoundaryNeutral(C: UCS4): Boolean;\r\nbegin\r\n Result := CategoryLookup(C, [ccBoundaryNeutral]);\r\nend;\r\n\r\nfunction UnicodeIsSegmentSeparator(C: UCS4): Boolean;\r\nbegin\r\n Result := CategoryLookup(C, [ccSegmentSeparator]);\r\nend;\r\n\r\nfunction UnicodeIsOtherNeutrals(C: UCS4): Boolean;\r\nbegin\r\n Result := CategoryLookup(C, [ccOtherNeutrals]);\r\nend;\r\n\r\nfunction UnicodeIsASCIIHexDigit(C: UCS4): Boolean;\r\nbegin\r\n Result := CategoryLookup(C, [ccASCIIHexDigit]);\r\nend;\r\n\r\nfunction UnicodeIsBidiControl(C: UCS4): Boolean;\r\nbegin\r\n Result := CategoryLookup(C, [ccBidiControl]);\r\nend;\r\n\r\nfunction UnicodeIsDeprecated(C: UCS4): Boolean;\r\nbegin\r\n Result := CategoryLookup(C, [ccDeprecated]);\r\nend;\r\n\r\nfunction UnicodeIsDiacritic(C: UCS4): Boolean;\r\nbegin\r\n Result := CategoryLookup(C, [ccDiacritic]);\r\nend;\r\n\r\nfunction UnicodeIsExtender(C: UCS4): Boolean;\r\nbegin\r\n Result := CategoryLookup(C, [ccExtender]);\r\nend;\r\n\r\nfunction UnicodeIsHyphen(C: UCS4): Boolean;\r\nbegin\r\n Result := CategoryLookup(C, [ccHyphen]);\r\nend;\r\n\r\nfunction UnicodeIsIdeographic(C: UCS4): Boolean;\r\nbegin\r\n Result := CategoryLookup(C, [ccIdeographic]);\r\nend;\r\n\r\nfunction UnicodeIsIDSBinaryOperator(C: UCS4): Boolean;\r\nbegin\r\n Result := CategoryLookup(C, [ccIDSBinaryOperator]);\r\nend;\r\n\r\nfunction UnicodeIsIDSTrinaryOperator(C: UCS4): Boolean;\r\nbegin\r\n Result := CategoryLookup(C, [ccIDSTrinaryOperator]);\r\nend;\r\n\r\nfunction UnicodeIsJoinControl(C: UCS4): Boolean;\r\nbegin\r\n Result := CategoryLookup(C, [ccJoinControl]);\r\nend;\r\n\r\nfunction UnicodeIsLogicalOrderException(C: UCS4): Boolean;\r\nbegin\r\n Result := CategoryLookup(C, [ccLogicalOrderException]);\r\nend;\r\n\r\nfunction UnicodeIsNonCharacterCodePoint(C: UCS4): Boolean;\r\nbegin\r\n Result := CategoryLookup(C, [ccNonCharacterCodePoint]);\r\nend;\r\n\r\nfunction UnicodeIsOtherAlphabetic(C: UCS4): Boolean;\r\nbegin\r\n Result := CategoryLookup(C, [ccOtherAlphabetic]);\r\nend;\r\n\r\nfunction UnicodeIsOtherDefaultIgnorableCodePoint(C: UCS4): Boolean;\r\nbegin\r\n Result := CategoryLookup(C, [ccOtherDefaultIgnorableCodePoint]);\r\nend;\r\n\r\nfunction UnicodeIsOtherGraphemeExtend(C: UCS4): Boolean;\r\nbegin\r\n Result := CategoryLookup(C, [ccOtherGraphemeExtend]);\r\nend;\r\n\r\nfunction UnicodeIsOtherIDContinue(C: UCS4): Boolean;\r\nbegin\r\n Result := CategoryLookup(C, [ccOtherIDContinue]);\r\nend;\r\n\r\nfunction UnicodeIsOtherIDStart(C: UCS4): Boolean;\r\nbegin\r\n Result := CategoryLookup(C, [ccOtherIDStart]);\r\nend;\r\n\r\nfunction UnicodeIsOtherLowercase(C: UCS4): Boolean;\r\nbegin\r\n Result := CategoryLookup(C, [ccOtherLowercase]);\r\nend;\r\n\r\nfunction UnicodeIsOtherMath(C: UCS4): Boolean;\r\nbegin\r\n Result := CategoryLookup(C, [ccOtherMath]);\r\nend;\r\n\r\nfunction UnicodeIsOtherUppercase(C: UCS4): Boolean;\r\nbegin\r\n Result := CategoryLookup(C, [ccOtherUppercase]);\r\nend;\r\n\r\nfunction UnicodeIsPatternSyntax(C: UCS4): Boolean;\r\nbegin\r\n Result := CategoryLookup(C, [ccPatternSyntax]);\r\nend;\r\n\r\nfunction UnicodeIsPatternWhiteSpace(C: UCS4): Boolean;\r\nbegin\r\n Result := CategoryLookup(C, [ccPatternWhiteSpace]);\r\nend;\r\n\r\nfunction UnicodeIsRadical(C: UCS4): Boolean;\r\nbegin\r\n Result := CategoryLookup(C, [ccRadical]);\r\nend;\r\n\r\nfunction UnicodeIsSoftDotted(C: UCS4): Boolean;\r\nbegin\r\n Result := CategoryLookup(C, [ccSoftDotted]);\r\nend;\r\n\r\nfunction UnicodeIsSTerm(C: UCS4): Boolean;\r\nbegin\r\n Result := CategoryLookup(C, [ccSTerm]);\r\nend;\r\n\r\nfunction UnicodeIsTerminalPunctuation(C: UCS4): Boolean;\r\nbegin\r\n Result := CategoryLookup(C, [ccTerminalPunctuation]);\r\nend;\r\n\r\nfunction UnicodeIsUnifiedIdeograph(C: UCS4): Boolean;\r\nbegin\r\n Result := CategoryLookup(C, [ccUnifiedIdeograph]);\r\nend;\r\n\r\nfunction UnicodeIsVariationSelector(C: UCS4): Boolean;\r\nbegin\r\n Result := CategoryLookup(C, [ccVariationSelector]);\r\nend;\r\n{$ENDIF ~UNICODE_RTL_DATABASE}\r\n\r\n// I need to fix a problem (introduced by MS) here. The first parameter can be a pointer\r\n// (and is so defined) or can be a normal DWORD, depending on the dwFlags parameter.\r\n// As usual, lpSrc has been translated to a var parameter. But this does not work in\r\n// our case, hence the redeclaration of the function with a pointer as first parameter.\r\n\r\nfunction TranslateCharsetInfoEx(lpSrc: SizeInt; out lpCs: TCharsetInfo; dwFlags: DWORD): BOOL; stdcall;\r\n external 'gdi32.dll' name 'TranslateCharsetInfo';\r\n\r\nfunction GetCharSetFromLocale(Language: LCID; out FontCharSet: Byte): Boolean;\r\nconst\r\n TCI_SRCLOCALE = $1000;\r\nvar\r\n CP: Word;\r\n CSI: TCharsetInfo;\r\nbegin\r\n if GetWindowsVersion in [wvUnknown, wvWin95, wvWin95OSR2, wvWin98, wvWin98SE,\r\n wvWinME, wvWinNT31, wvWinNT35, wvWinNT351, wvWinNT4] then\r\n begin\r\n // these versions of Windows don't support TCI_SRCLOCALE\r\n CP := CodePageFromLocale(Language);\r\n if CP = 0 then\r\n RaiseLastOSError;\r\n Result := TranslateCharsetInfoEx(CP, CSI, TCI_SRCCODEPAGE);\r\n end\r\n else\r\n Result := TranslateCharsetInfoEx(Language, CSI, TCI_SRCLOCALE);\r\n\r\n if Result then\r\n FontCharset := CSI.ciCharset;\r\nend;\r\n\r\nfunction CharSetFromLocale(Language: LCID): Byte;\r\nbegin\r\n if not GetCharSetFromLocale(Language, Result) then\r\n RaiseLastOSError;\r\nend;\r\n\r\nfunction CodePageFromLocale(Language: LCID): Word;\r\n// determines the code page for a given locale\r\nvar\r\n Buf: array [0..6] of Char;\r\nbegin\r\n GetLocaleInfo(Language, LOCALE_IDefaultAnsiCodePage, Buf, 6);\r\n Result := StrToIntDef(Buf, GetACP);\r\nend;\r\n\r\nfunction KeyboardCodePage: Word;\r\nbegin\r\n Result := CodePageFromLocale(GetKeyboardLayout(0) and $FFFF);\r\nend;\r\n\r\nfunction KeyUnicode(C: Char): WideChar;\r\n// converts the given character (as it comes with a WM_CHAR message) into its\r\n// corresponding Unicode character depending on the active keyboard layout\r\nbegin\r\n MultiByteToWideChar(KeyboardCodePage, MB_USEGLYPHCHARS, @C, 1, @Result, 1);\r\nend;\r\n\r\nfunction CodeBlockRange(const CB: TUnicodeBlock): TUnicodeBlockRange;\r\n// http://www.unicode.org/Public/5.0.0/ucd/Blocks.txt\r\nbegin\r\n Result := UnicodeBlockData[CB].Range;\r\nend;\r\n\r\n\r\n// Names taken from http://www.unicode.org/Public/5.0.0/ucd/Blocks.txt\r\nfunction CodeBlockName(const CB: TUnicodeBlock): string;\r\nbegin\r\n Result := UnicodeBlockData[CB].Name;\r\nend;\r\n\r\n// Returns an ID for the Unicode code block to which C belongs.\r\n// If C does not belong to any of the defined blocks then ubUndefined is returned.\r\n// Note: the code blocks listed here are based on Unicode Version 5.0.0\r\nfunction CodeBlockFromChar(const C: UCS4): TUnicodeBlock;\r\n// http://www.unicode.org/Public/5.0.0/ucd/Blocks.txt\r\nvar\r\n L, H, I: TUnicodeBlock;\r\nbegin\r\n Result := ubUndefined;\r\n L := ubBasicLatin;\r\n H := High(TUnicodeBlock);\r\n while L <= H do\r\n begin\r\n I := TUnicodeBlock((Cardinal(L) + Cardinal(H)) shr 1);\r\n if (C >= UnicodeBlockData[I].Range.RangeStart) and (C <= UnicodeBlockData[I].Range.RangeEnd) then\r\n begin\r\n Result := I;\r\n Break;\r\n end\r\n else\r\n if C < UnicodeBlockData[I].Range.RangeStart then\r\n begin\r\n Dec(I);\r\n H := I;\r\n end\r\n else\r\n begin\r\n Inc(I);\r\n L := I;\r\n end;\r\n end;\r\nend;\r\n\r\n\r\nfunction CompareTextWin95(const W1, W2: WideString; Locale: LCID): SizeInt;\r\n// special comparation function for Win9x since there's no system defined\r\n// comparation function, returns -1 if W1 < W2, 0 if W1 = W2 or 1 if W1 > W2\r\nvar\r\n S1, S2: AnsiString;\r\n CP: Word;\r\n L1, L2: SizeInt;\r\nbegin\r\n L1 := Length(W1);\r\n L2 := Length(W2);\r\n SetLength(S1, L1);\r\n SetLength(S2, L2);\r\n CP := CodePageFromLocale(Locale);\r\n WideCharToMultiByte(CP, 0, PWideChar(W1), L1, PAnsiChar(S1), L1, nil, nil);\r\n WideCharToMultiByte(CP, 0, PWideChar(W2), L2, PAnsiChar(S2), L2, nil, nil);\r\n Result := CompareStringA(Locale, NORM_IGNORECASE, PAnsiChar(S1), Length(S1),\r\n PAnsiChar(S2), Length(S2)) - 2;\r\nend;\r\n\r\nfunction CompareTextWinNT(const W1, W2: WideString; Locale: LCID): SizeInt;\r\n// Wrapper function for WinNT since there's no system defined comparation function\r\n// in Win9x and we need a central comparation function for TWideStringList.\r\n// Returns -1 if W1 < W2, 0 if W1 = W2 or 1 if W1 > W2\r\nbegin\r\n Result := CompareStringW(Locale, NORM_IGNORECASE, PWideChar(W1), Length(W1),\r\n PWideChar(W2), Length(W2)) - 2;\r\nend;\r\n\r\nfunction StringToWideStringEx(const S: AnsiString; CodePage: Word): WideString;\r\nvar\r\n InputLength,\r\n OutputLength: SizeInt;\r\nbegin\r\n InputLength := Length(S);\r\n OutputLength := MultiByteToWideChar(CodePage, 0, PAnsiChar(S), InputLength, nil, 0);\r\n SetLength(Result, OutputLength);\r\n MultiByteToWideChar(CodePage, 0, PAnsiChar(S), InputLength, PWideChar(Result), OutputLength);\r\nend;\r\n\r\nfunction WideStringToStringEx(const WS: WideString; CodePage: Word): AnsiString;\r\nvar\r\n InputLength,\r\n OutputLength: SizeInt;\r\nbegin\r\n InputLength := Length(WS);\r\n OutputLength := WideCharToMultiByte(CodePage, 0, PWideChar(WS), InputLength, nil, 0, nil, nil);\r\n SetLength(Result, OutputLength);\r\n WideCharToMultiByte(CodePage, 0, PWideChar(WS), InputLength, PAnsiChar(Result), OutputLength, nil, nil);\r\nend;\r\n\r\nfunction TranslateString(const S: AnsiString; CP1, CP2: Word): AnsiString;\r\nbegin\r\n Result:= WideStringToStringEx(StringToWideStringEx(S, CP1), CP2);\r\nend;\r\n\r\nfunction UCS4Array(Ch: UCS4): TUCS4Array;\r\nbegin\r\n SetLength(Result, 1);\r\n Result[0] := Ch;\r\nend;\r\n\r\nfunction UCS4ArrayConcat(Left, Right: UCS4): TUCS4Array;\r\nbegin\r\n SetLength(Result, 2);\r\n Result[0] := Left;\r\n Result[1] := Right;\r\nend;\r\n\r\nprocedure UCS4ArrayConcat(var Left: TUCS4Array; Right: UCS4);\r\nvar\r\n I: SizeInt;\r\nbegin\r\n I := Length(Left);\r\n SetLength(Left, I + 1);\r\n Left[I] := Right;\r\nend;\r\n\r\nprocedure UCS4ArrayConcat(var Left: TUCS4Array; const Right: TUCS4Array);\r\nvar\r\n I, J: SizeInt;\r\nbegin\r\n I := Length(Left);\r\n J := Length(Right);\r\n SetLength(Left, I + J);\r\n Move(Right[0], Left[I], J * SizeOf(Right[0]));\r\nend;\r\n\r\nfunction UCS4ArrayEquals(const Left: TUCS4Array; const Right: TUCS4Array): Boolean;\r\nvar\r\n I: SizeInt;\r\nbegin\r\n I := Length(Left);\r\n Result := I = Length(Right);\r\n while Result do\r\n begin\r\n Dec(I);\r\n Result := (I >= 0) and (Left[I] = Right[I]);\r\n end;\r\n Result := I < 0;\r\nend;\r\n\r\nfunction UCS4ArrayEquals(const Left: TUCS4Array; Right: UCS4): Boolean;\r\nbegin\r\n Result := (Length(Left) = 1) and (Left[0] = Right);\r\nend;\r\n\r\nfunction UCS4ArrayEquals(const Left: TUCS4Array; const Right: AnsiString): Boolean;\r\nvar\r\n I: SizeInt;\r\nbegin\r\n I := Length(Left);\r\n Result := I = Length(Right);\r\n while Result do\r\n begin\r\n Dec(I);\r\n Result := (I >= 0) and (Left[I] = Ord(Right[I + 1]));\r\n end;\r\n Result := I < 0;\r\nend;\r\n\r\nfunction UCS4ArrayEquals(const Left: TUCS4Array; Right: AnsiChar): Boolean;\r\nbegin\r\n Result := (Length(Left) = 1) and (Left[0] = Ord(Right));\r\nend;\r\n\r\nprocedure PrepareUnicodeData;\r\n// Prepares structures which are globally needed.\r\nbegin\r\n {$IFNDEF UNICODE_RTL_DATABASE}\r\n LoadInProgress := TJclCriticalSection.Create;\r\n {$ENDIF ~UNICODE_RTL_DATABASE}\r\n\r\n if (Win32Platform and VER_PLATFORM_WIN32_NT) <> 0 then\r\n @WideCompareText := @CompareTextWinNT\r\n else\r\n @WideCompareText := @CompareTextWin95;\r\nend;\r\n\r\nprocedure FreeUnicodeData;\r\n// Frees all data which has been allocated and which is not automatically freed by Delphi.\r\nbegin\r\n {$IFNDEF UNICODE_RTL_DATABASE}\r\n FreeAndNil(LoadInProgress);\r\n {$ENDIF ~UNICODE_RTL_DATABASE}\r\nend;\r\n\r\ninitialization\r\n PrepareUnicodeData;\r\n {$IFDEF UNITVERSIONING}\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n {$ENDIF UNITVERSIONING}\r\n\r\nfinalization\r\n {$IFDEF UNITVERSIONING}\r\n UnregisterUnitVersion(HInstance);\r\n {$ENDIF UNITVERSIONING}\r\n FreeUnicodeData;\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jcl/source/common/JclUnicode.rc", "content": "/****************************************************************************************************\r\n\r\n\r\n ..\\..\\jcl\\source\\common\\JclUnicode.rc\r\n\r\n\r\n Produced by UDExtract written by Dipl. Ing. Mike Lischke, public@lischke-online.de\r\n\r\n\r\n****************************************************************************************************/\r\n\r\n\r\nLANGUAGE 0,0 CATEGORIES UNICODEDATA LOADONCALL MOVEABLE DISCARDABLE\r\n{\r\n '00 5B 02 00 00 41 00 00 5A 00 00 C0 00 00 D6 00 00 D8 00 00 DE 00 00 00 01 00 00 01 00 02 01 00'\r\n '02 01 00 04 01 00 04 01 00 06 01 00 06 01 00 08 01 00 08 01 00 0A 01 00 0A 01 00 0C 01 00 0C 01'\r\n '00 0E 01 00 0E 01 00 10 01 00 10 01 00 12 01 00 12 01 00 14 01 00 14 01 00 16 01 00 16 01 00 18'\r\n '01 00 18 01 00 1A 01 00 1A 01 00 1C 01 00 1C 01 00 1E 01 00 1E 01 00 20 01 00 20 01 00 22 01 00'\r\n '22 01 00 24 01 00 24 01 00 26 01 00 26 01 00 28 01 00 28 01 00 2A 01 00 2A 01 00 2C 01 00 2C 01'\r\n '00 2E 01 00 2E 01 00 30 01 00 30 01 00 32 01 00 32 01 00 34 01 00 34 01 00 36 01 00 36 01 00 39'\r\n '01 00 39 01 00 3B 01 00 3B 01 00 3D 01 00 3D 01 00 3F 01 00 3F 01 00 41 01 00 41 01 00 43 01 00'\r\n '43 01 00 45 01 00 45 01 00 47 01 00 47 01 00 4A 01 00 4A 01 00 4C 01 00 4C 01 00 4E 01 00 4E 01'\r\n '00 50 01 00 50 01 00 52 01 00 52 01 00 54 01 00 54 01 00 56 01 00 56 01 00 58 01 00 58 01 00 5A'\r\n '01 00 5A 01 00 5C 01 00 5C 01 00 5E 01 00 5E 01 00 60 01 00 60 01 00 62 01 00 62 01 00 64 01 00'\r\n '64 01 00 66 01 00 66 01 00 68 01 00 68 01 00 6A 01 00 6A 01 00 6C 01 00 6C 01 00 6E 01 00 6E 01'\r\n '00 70 01 00 70 01 00 72 01 00 72 01 00 74 01 00 74 01 00 76 01 00 76 01 00 78 01 00 79 01 00 7B'\r\n '01 00 7B 01 00 7D 01 00 7D 01 00 81 01 00 82 01 00 84 01 00 84 01 00 86 01 00 87 01 00 89 01 00'\r\n '8B 01 00 8E 01 00 91 01 00 93 01 00 94 01 00 96 01 00 98 01 00 9C 01 00 9D 01 00 9F 01 00 A0 01'\r\n '00 A2 01 00 A2 01 00 A4 01 00 A4 01 00 A6 01 00 A7 01 00 A9 01 00 A9 01 00 AC 01 00 AC 01 00 AE'\r\n '01 00 AF 01 00 B1 01 00 B3 01 00 B5 01 00 B5 01 00 B7 01 00 B8 01 00 BC 01 00 BC 01 00 C4 01 00'\r\n 'C4 01 00 C7 01 00 C7 01 00 CA 01 00 CA 01 00 CD 01 00 CD 01 00 CF 01 00 CF 01 00 D1 01 00 D1 01'\r\n '00 D3 01 00 D3 01 00 D5 01 00 D5 01 00 D7 01 00 D7 01 00 D9 01 00 D9 01 00 DB 01 00 DB 01 00 DE'\r\n '01 00 DE 01 00 E0 01 00 E0 01 00 E2 01 00 E2 01 00 E4 01 00 E4 01 00 E6 01 00 E6 01 00 E8 01 00'\r\n 'E8 01 00 EA 01 00 EA 01 00 EC 01 00 EC 01 00 EE 01 00 EE 01 00 F1 01 00 F1 01 00 F4 01 00 F4 01'\r\n '00 F6 01 00 F8 01 00 FA 01 00 FA 01 00 FC 01 00 FC 01 00 FE 01 00 FE 01 00 00 02 00 00 02 00 02'\r\n '02 00 02 02 00 04 02 00 04 02 00 06 02 00 06 02 00 08 02 00 08 02 00 0A 02 00 0A 02 00 0C 02 00'\r\n '0C 02 00 0E 02 00 0E 02 00 10 02 00 10 02 00 12 02 00 12 02 00 14 02 00 14 02 00 16 02 00 16 02'\r\n '00 18 02 00 18 02 00 1A 02 00 1A 02 00 1C 02 00 1C 02 00 1E 02 00 1E 02 00 20 02 00 20 02 00 22'\r\n '02 00 22 02 00 24 02 00 24 02 00 26 02 00 26 02 00 28 02 00 28 02 00 2A 02 00 2A 02 00 2C 02 00'\r\n '2C 02 00 2E 02 00 2E 02 00 30 02 00 30 02 00 32 02 00 32 02 00 3A 02 00 3B 02 00 3D 02 00 3E 02'\r\n '00 41 02 00 41 02 00 43 02 00 46 02 00 48 02 00 48 02 00 4A 02 00 4A 02 00 4C 02 00 4C 02 00 4E'\r\n '02 00 4E 02 00 70 03 00 70 03 00 72 03 00 72 03 00 76 03 00 76 03 00 86 03 00 86 03 00 88 03 00'\r\n '8A 03 00 8C 03 00 8C 03 00 8E 03 00 8F 03 00 91 03 00 A1 03 00 A3 03 00 AB 03 00 CF 03 00 CF 03'\r\n '00 D2 03 00 D4 03 00 D8 03 00 D8 03 00 DA 03 00 DA 03 00 DC 03 00 DC 03 00 DE 03 00 DE 03 00 E0'\r\n '03 00 E0 03 00 E2 03 00 E2 03 00 E4 03 00 E4 03 00 E6 03 00 E6 03 00 E8 03 00 E8 03 00 EA 03 00'\r\n 'EA 03 00 EC 03 00 EC 03 00 EE 03 00 EE 03 00 F4 03 00 F4 03 00 F7 03 00 F7 03 00 F9 03 00 FA 03'\r\n '00 FD 03 00 2F 04 00 60 04 00 60 04 00 62 04 00 62 04 00 64 04 00 64 04 00 66 04 00 66 04 00 68'\r\n '04 00 68 04 00 6A 04 00 6A 04 00 6C 04 00 6C 04 00 6E 04 00 6E 04 00 70 04 00 70 04 00 72 04 00'\r\n '72 04 00 74 04 00 74 04 00 76 04 00 76 04 00 78 04 00 78 04 00 7A 04 00 7A 04 00 7C 04 00 7C 04'\r\n '00 7E 04 00 7E 04 00 80 04 00 80 04 00 8A 04 00 8A 04 00 8C 04 00 8C 04 00 8E 04 00 8E 04 00 90'\r\n '04 00 90 04 00 92 04 00 92 04 00 94 04 00 94 04 00 96 04 00 96 04 00 98 04 00 98 04 00 9A 04 00'\r\n '9A 04 00 9C 04 00 9C 04 00 9E 04 00 9E 04 00 A0 04 00 A0 04 00 A2 04 00 A2 04 00 A4 04 00 A4 04'\r\n '00 A6 04 00 A6 04 00 A8 04 00 A8 04 00 AA 04 00 AA 04 00 AC 04 00 AC 04 00 AE 04 00 AE 04 00 B0'\r\n '04 00 B0 04 00 B2 04 00 B2 04 00 B4 04 00 B4 04 00 B6 04 00 B6 04 00 B8 04 00 B8 04 00 BA 04 00'\r\n 'BA 04 00 BC 04 00 BC 04 00 BE 04 00 BE 04 00 C0 04 00 C1 04 00 C3 04 00 C3 04 00 C5 04 00 C5 04'\r\n '00 C7 04 00 C7 04 00 C9 04 00 C9 04 00 CB 04 00 CB 04 00 CD 04 00 CD 04 00 D0 04 00 D0 04 00 D2'\r\n '04 00 D2 04 00 D4 04 00 D4 04 00 D6 04 00 D6 04 00 D8 04 00 D8 04 00 DA 04 00 DA 04 00 DC 04 00'\r\n 'DC 04 00 DE 04 00 DE 04 00 E0 04 00 E0 04 00 E2 04 00 E2 04 00 E4 04 00 E4 04 00 E6 04 00 E6 04'\r\n '00 E8 04 00 E8 04 00 EA 04 00 EA 04 00 EC 04 00 EC 04 00 EE 04 00 EE 04 00 F0 04 00 F0 04 00 F2'\r\n '04 00 F2 04 00 F4 04 00 F4 04 00 F6 04 00 F6 04 00 F8 04 00 F8 04 00 FA 04 00 FA 04 00 FC 04 00'\r\n 'FC 04 00 FE 04 00 FE 04 00 00 05 00 00 05 00 02 05 00 02 05 00 04 05 00 04 05 00 06 05 00 06 05'\r\n '00 08 05 00 08 05 00 0A 05 00 0A 05 00 0C 05 00 0C 05 00 0E 05 00 0E 05 00 10 05 00 10 05 00 12'\r\n '05 00 12 05 00 14 05 00 14 05 00 16 05 00 16 05 00 18 05 00 18 05 00 1A 05 00 1A 05 00 1C 05 00'\r\n '1C 05 00 1E 05 00 1E 05 00 20 05 00 20 05 00 22 05 00 22 05 00 24 05 00 24 05 00 26 05 00 26 05'\r\n '00 31 05 00 56 05 00 A0 10 00 C5 10 00 00 1E 00 00 1E 00 02 1E 00 02 1E 00 04 1E 00 04 1E 00 06'\r\n '1E 00 06 1E 00 08 1E 00 08 1E 00 0A 1E 00 0A 1E 00 0C 1E 00 0C 1E 00 0E 1E 00 0E 1E 00 10 1E 00'\r\n '10 1E 00 12 1E 00 12 1E 00 14 1E 00 14 1E 00 16 1E 00 16 1E 00 18 1E 00 18 1E 00 1A 1E 00 1A 1E'\r\n '00 1C 1E 00 1C 1E 00 1E 1E 00 1E 1E 00 20 1E 00 20 1E 00 22 1E 00 22 1E 00 24 1E 00 24 1E 00 26'\r\n '1E 00 26 1E 00 28 1E 00 28 1E 00 2A 1E 00 2A 1E 00 2C 1E 00 2C 1E 00 2E 1E 00 2E 1E 00 30 1E 00'\r\n '30 1E 00 32 1E 00 32 1E 00 34 1E 00 34 1E 00 36 1E 00 36 1E 00 38 1E 00 38 1E 00 3A 1E 00 3A 1E'\r\n '00 3C 1E 00 3C 1E 00 3E 1E 00 3E 1E 00 40 1E 00 40 1E 00 42 1E 00 42 1E 00 44 1E 00 44 1E 00 46'\r\n '1E 00 46 1E 00 48 1E 00 48 1E 00 4A 1E 00 4A 1E 00 4C 1E 00 4C 1E 00 4E 1E 00 4E 1E 00 50 1E 00'\r\n '50 1E 00 52 1E 00 52 1E 00 54 1E 00 54 1E 00 56 1E 00 56 1E 00 58 1E 00 58 1E 00 5A 1E 00 5A 1E'\r\n '00 5C 1E 00 5C 1E 00 5E 1E 00 5E 1E 00 60 1E 00 60 1E 00 62 1E 00 62 1E 00 64 1E 00 64 1E 00 66'\r\n '1E 00 66 1E 00 68 1E 00 68 1E 00 6A 1E 00 6A 1E 00 6C 1E 00 6C 1E 00 6E 1E 00 6E 1E 00 70 1E 00'\r\n '70 1E 00 72 1E 00 72 1E 00 74 1E 00 74 1E 00 76 1E 00 76 1E 00 78 1E 00 78 1E 00 7A 1E 00 7A 1E'\r\n '00 7C 1E 00 7C 1E 00 7E 1E 00 7E 1E 00 80 1E 00 80 1E 00 82 1E 00 82 1E 00 84 1E 00 84 1E 00 86'\r\n '1E 00 86 1E 00 88 1E 00 88 1E 00 8A 1E 00 8A 1E 00 8C 1E 00 8C 1E 00 8E 1E 00 8E 1E 00 90 1E 00'\r\n '90 1E 00 92 1E 00 92 1E 00 94 1E 00 94 1E 00 9E 1E 00 9E 1E 00 A0 1E 00 A0 1E 00 A2 1E 00 A2 1E'\r\n '00 A4 1E 00 A4 1E 00 A6 1E 00 A6 1E 00 A8 1E 00 A8 1E 00 AA 1E 00 AA 1E 00 AC 1E 00 AC 1E 00 AE'\r\n '1E 00 AE 1E 00 B0 1E 00 B0 1E 00 B2 1E 00 B2 1E 00 B4 1E 00 B4 1E 00 B6 1E 00 B6 1E 00 B8 1E 00'\r\n 'B8 1E 00 BA 1E 00 BA 1E 00 BC 1E 00 BC 1E 00 BE 1E 00 BE 1E 00 C0 1E 00 C0 1E 00 C2 1E 00 C2 1E'\r\n '00 C4 1E 00 C4 1E 00 C6 1E 00 C6 1E 00 C8 1E 00 C8 1E 00 CA 1E 00 CA 1E 00 CC 1E 00 CC 1E 00 CE'\r\n '1E 00 CE 1E 00 D0 1E 00 D0 1E 00 D2 1E 00 D2 1E 00 D4 1E 00 D4 1E 00 D6 1E 00 D6 1E 00 D8 1E 00'\r\n 'D8 1E 00 DA 1E 00 DA 1E 00 DC 1E 00 DC 1E 00 DE 1E 00 DE 1E 00 E0 1E 00 E0 1E 00 E2 1E 00 E2 1E'\r\n '00 E4 1E 00 E4 1E 00 E6 1E 00 E6 1E 00 E8 1E 00 E8 1E 00 EA 1E 00 EA 1E 00 EC 1E 00 EC 1E 00 EE'\r\n '1E 00 EE 1E 00 F0 1E 00 F0 1E 00 F2 1E 00 F2 1E 00 F4 1E 00 F4 1E 00 F6 1E 00 F6 1E 00 F8 1E 00'\r\n 'F8 1E 00 FA 1E 00 FA 1E 00 FC 1E 00 FC 1E 00 FE 1E 00 FE 1E 00 08 1F 00 0F 1F 00 18 1F 00 1D 1F'\r\n '00 28 1F 00 2F 1F 00 38 1F 00 3F 1F 00 48 1F 00 4D 1F 00 59 1F 00 59 1F 00 5B 1F 00 5B 1F 00 5D'\r\n '1F 00 5D 1F 00 5F 1F 00 5F 1F 00 68 1F 00 6F 1F 00 B8 1F 00 BB 1F 00 C8 1F 00 CB 1F 00 D8 1F 00'\r\n 'DB 1F 00 E8 1F 00 EC 1F 00 F8 1F 00 FB 1F 00 02 21 00 02 21 00 07 21 00 07 21 00 0B 21 00 0D 21'\r\n '00 10 21 00 12 21 00 15 21 00 15 21 00 19 21 00 1D 21 00 24 21 00 24 21 00 26 21 00 26 21 00 28'\r\n '21 00 28 21 00 2A 21 00 2D 21 00 30 21 00 33 21 00 3E 21 00 3F 21 00 45 21 00 45 21 00 83 21 00'\r\n '83 21 00 00 2C 00 2E 2C 00 60 2C 00 60 2C 00 62 2C 00 64 2C 00 67 2C 00 67 2C 00 69 2C 00 69 2C'\r\n '00 6B 2C 00 6B 2C 00 6D 2C 00 70 2C 00 72 2C 00 72 2C 00 75 2C 00 75 2C 00 7E 2C 00 80 2C 00 82'\r\n '2C 00 82 2C 00 84 2C 00 84 2C 00 86 2C 00 86 2C 00 88 2C 00 88 2C 00 8A 2C 00 8A 2C 00 8C 2C 00'\r\n '8C 2C 00 8E 2C 00 8E 2C 00 90 2C 00 90 2C 00 92 2C 00 92 2C 00 94 2C 00 94 2C 00 96 2C 00 96 2C'\r\n '00 98 2C 00 98 2C 00 9A 2C 00 9A 2C 00 9C 2C 00 9C 2C 00 9E 2C 00 9E 2C 00 A0 2C 00 A0 2C 00 A2'\r\n '2C 00 A2 2C 00 A4 2C 00 A4 2C 00 A6 2C 00 A6 2C 00 A8 2C 00 A8 2C 00 AA 2C 00 AA 2C 00 AC 2C 00'\r\n 'AC 2C 00 AE 2C 00 AE 2C 00 B0 2C 00 B0 2C 00 B2 2C 00 B2 2C 00 B4 2C 00 B4 2C 00 B6 2C 00 B6 2C'\r\n '00 B8 2C 00 B8 2C 00 BA 2C 00 BA 2C 00 BC 2C 00 BC 2C 00 BE 2C 00 BE 2C 00 C0 2C 00 C0 2C 00 C2'\r\n '2C 00 C2 2C 00 C4 2C 00 C4 2C 00 C6 2C 00 C6 2C 00 C8 2C 00 C8 2C 00 CA 2C 00 CA 2C 00 CC 2C 00'\r\n 'CC 2C 00 CE 2C 00 CE 2C 00 D0 2C 00 D0 2C 00 D2 2C 00 D2 2C 00 D4 2C 00 D4 2C 00 D6 2C 00 D6 2C'\r\n '00 D8 2C 00 D8 2C 00 DA 2C 00 DA 2C 00 DC 2C 00 DC 2C 00 DE 2C 00 DE 2C 00 E0 2C 00 E0 2C 00 E2'\r\n '2C 00 E2 2C 00 EB 2C 00 EB 2C 00 ED 2C 00 ED 2C 00 40 A6 00 40 A6 00 42 A6 00 42 A6 00 44 A6 00'\r\n '44 A6 00 46 A6 00 46 A6 00 48 A6 00 48 A6 00 4A A6 00 4A A6 00 4C A6 00 4C A6 00 4E A6 00 4E A6'\r\n '00 50 A6 00 50 A6 00 52 A6 00 52 A6 00 54 A6 00 54 A6 00 56 A6 00 56 A6 00 58 A6 00 58 A6 00 5A'\r\n 'A6 00 5A A6 00 5C A6 00 5C A6 00 5E A6 00 5E A6 00 60 A6 00 60 A6 00 62 A6 00 62 A6 00 64 A6 00'\r\n '64 A6 00 66 A6 00 66 A6 00 68 A6 00 68 A6 00 6A A6 00 6A A6 00 6C A6 00 6C A6 00 80 A6 00 80 A6'\r\n '00 82 A6 00 82 A6 00 84 A6 00 84 A6 00 86 A6 00 86 A6 00 88 A6 00 88 A6 00 8A A6 00 8A A6 00 8C'\r\n 'A6 00 8C A6 00 8E A6 00 8E A6 00 90 A6 00 90 A6 00 92 A6 00 92 A6 00 94 A6 00 94 A6 00 96 A6 00'\r\n '96 A6 00 22 A7 00 22 A7 00 24 A7 00 24 A7 00 26 A7 00 26 A7 00 28 A7 00 28 A7 00 2A A7 00 2A A7'\r\n '00 2C A7 00 2C A7 00 2E A7 00 2E A7 00 32 A7 00 32 A7 00 34 A7 00 34 A7 00 36 A7 00 36 A7 00 38'\r\n 'A7 00 38 A7 00 3A A7 00 3A A7 00 3C A7 00 3C A7 00 3E A7 00 3E A7 00 40 A7 00 40 A7 00 42 A7 00'\r\n '42 A7 00 44 A7 00 44 A7 00 46 A7 00 46 A7 00 48 A7 00 48 A7 00 4A A7 00 4A A7 00 4C A7 00 4C A7'\r\n '00 4E A7 00 4E A7 00 50 A7 00 50 A7 00 52 A7 00 52 A7 00 54 A7 00 54 A7 00 56 A7 00 56 A7 00 58'\r\n 'A7 00 58 A7 00 5A A7 00 5A A7 00 5C A7 00 5C A7 00 5E A7 00 5E A7 00 60 A7 00 60 A7 00 62 A7 00'\r\n '62 A7 00 64 A7 00 64 A7 00 66 A7 00 66 A7 00 68 A7 00 68 A7 00 6A A7 00 6A A7 00 6C A7 00 6C A7'\r\n '00 6E A7 00 6E A7 00 79 A7 00 79 A7 00 7B A7 00 7B A7 00 7D A7 00 7E A7 00 80 A7 00 80 A7 00 82'\r\n 'A7 00 82 A7 00 84 A7 00 84 A7 00 86 A7 00 86 A7 00 8B A7 00 8B A7 00 8D A7 00 8D A7 00 90 A7 00'\r\n '90 A7 00 A0 A7 00 A0 A7 00 A2 A7 00 A2 A7 00 A4 A7 00 A4 A7 00 A6 A7 00 A6 A7 00 A8 A7 00 A8 A7'\r\n '00 21 FF 00 3A FF 00 00 04 01 27 04 01 00 D4 01 19 D4 01 34 D4 01 4D D4 01 68 D4 01 81 D4 01 9C'\r\n 'D4 01 9C D4 01 9E D4 01 9F D4 01 A2 D4 01 A2 D4 01 A5 D4 01 A6 D4 01 A9 D4 01 AC D4 01 AE D4 01'\r\n 'B5 D4 01 D0 D4 01 E9 D4 01 04 D5 01 05 D5 01 07 D5 01 0A D5 01 0D D5 01 14 D5 01 16 D5 01 1C D5'\r\n '01 38 D5 01 39 D5 01 3B D5 01 3E D5 01 40 D5 01 44 D5 01 46 D5 01 46 D5 01 4A D5 01 50 D5 01 6C'\r\n 'D5 01 85 D5 01 A0 D5 01 B9 D5 01 D4 D5 01 ED D5 01 08 D6 01 21 D6 01 3C D6 01 55 D6 01 70 D6 01'\r\n '89 D6 01 A8 D6 01 C0 D6 01 E2 D6 01 FA D6 01 1C D7 01 34 D7 01 56 D7 01 6E D7 01 90 D7 01 A8 D7'\r\n '01 CA D7 01 CA D7 01 01 61 02 00 00 61 00 00 7A 00 00 AA 00 00 AA 00 00 B5 00 00 B5 00 00 BA 00'\r\n '00 BA 00 00 DF 00 00 F6 00 00 F8 00 00 FF 00 00 01 01 00 01 01 00 03 01 00 03 01 00 05 01 00 05'\r\n '01 00 07 01 00 07 01 00 09 01 00 09 01 00 0B 01 00 0B 01 00 0D 01 00 0D 01 00 0F 01 00 0F 01 00'\r\n '11 01 00 11 01 00 13 01 00 13 01 00 15 01 00 15 01 00 17 01 00 17 01 00 19 01 00 19 01 00 1B 01'\r\n '00 1B 01 00 1D 01 00 1D 01 00 1F 01 00 1F 01 00 21 01 00 21 01 00 23 01 00 23 01 00 25 01 00 25'\r\n '01 00 27 01 00 27 01 00 29 01 00 29 01 00 2B 01 00 2B 01 00 2D 01 00 2D 01 00 2F 01 00 2F 01 00'\r\n '31 01 00 31 01 00 33 01 00 33 01 00 35 01 00 35 01 00 37 01 00 38 01 00 3A 01 00 3A 01 00 3C 01'\r\n '00 3C 01 00 3E 01 00 3E 01 00 40 01 00 40 01 00 42 01 00 42 01 00 44 01 00 44 01 00 46 01 00 46'\r\n '01 00 48 01 00 49 01 00 4B 01 00 4B 01 00 4D 01 00 4D 01 00 4F 01 00 4F 01 00 51 01 00 51 01 00'\r\n '53 01 00 53 01 00 55 01 00 55 01 00 57 01 00 57 01 00 59 01 00 59 01 00 5B 01 00 5B 01 00 5D 01'\r\n '00 5D 01 00 5F 01 00 5F 01 00 61 01 00 61 01 00 63 01 00 63 01 00 65 01 00 65 01 00 67 01 00 67'\r\n '01 00 69 01 00 69 01 00 6B 01 00 6B 01 00 6D 01 00 6D 01 00 6F 01 00 6F 01 00 71 01 00 71 01 00'\r\n '73 01 00 73 01 00 75 01 00 75 01 00 77 01 00 77 01 00 7A 01 00 7A 01 00 7C 01 00 7C 01 00 7E 01'\r\n '00 80 01 00 83 01 00 83 01 00 85 01 00 85 01 00 88 01 00 88 01 00 8C 01 00 8D 01 00 92 01 00 92'\r\n '01 00 95 01 00 95 01 00 99 01 00 9B 01 00 9E 01 00 9E 01 00 A1 01 00 A1 01 00 A3 01 00 A3 01 00'\r\n 'A5 01 00 A5 01 00 A8 01 00 A8 01 00 AA 01 00 AB 01 00 AD 01 00 AD 01 00 B0 01 00 B0 01 00 B4 01'\r\n '00 B4 01 00 B6 01 00 B6 01 00 B9 01 00 BA 01 00 BD 01 00 BF 01 00 C6 01 00 C6 01 00 C9 01 00 C9'\r\n '01 00 CC 01 00 CC 01 00 CE 01 00 CE 01 00 D0 01 00 D0 01 00 D2 01 00 D2 01 00 D4 01 00 D4 01 00'\r\n 'D6 01 00 D6 01 00 D8 01 00 D8 01 00 DA 01 00 DA 01 00 DC 01 00 DD 01 00 DF 01 00 DF 01 00 E1 01'\r\n '00 E1 01 00 E3 01 00 E3 01 00 E5 01 00 E5 01 00 E7 01 00 E7 01 00 E9 01 00 E9 01 00 EB 01 00 EB'\r\n '01 00 ED 01 00 ED 01 00 EF 01 00 F0 01 00 F3 01 00 F3 01 00 F5 01 00 F5 01 00 F9 01 00 F9 01 00'\r\n 'FB 01 00 FB 01 00 FD 01 00 FD 01 00 FF 01 00 FF 01 00 01 02 00 01 02 00 03 02 00 03 02 00 05 02'\r\n '00 05 02 00 07 02 00 07 02 00 09 02 00 09 02 00 0B 02 00 0B 02 00 0D 02 00 0D 02 00 0F 02 00 0F'\r\n '02 00 11 02 00 11 02 00 13 02 00 13 02 00 15 02 00 15 02 00 17 02 00 17 02 00 19 02 00 19 02 00'\r\n '1B 02 00 1B 02 00 1D 02 00 1D 02 00 1F 02 00 1F 02 00 21 02 00 21 02 00 23 02 00 23 02 00 25 02'\r\n '00 25 02 00 27 02 00 27 02 00 29 02 00 29 02 00 2B 02 00 2B 02 00 2D 02 00 2D 02 00 2F 02 00 2F'\r\n '02 00 31 02 00 31 02 00 33 02 00 39 02 00 3C 02 00 3C 02 00 3F 02 00 40 02 00 42 02 00 42 02 00'\r\n '47 02 00 47 02 00 49 02 00 49 02 00 4B 02 00 4B 02 00 4D 02 00 4D 02 00 4F 02 00 93 02 00 95 02'\r\n '00 AF 02 00 71 03 00 71 03 00 73 03 00 73 03 00 77 03 00 77 03 00 7B 03 00 7D 03 00 90 03 00 90'\r\n '03 00 AC 03 00 CE 03 00 D0 03 00 D1 03 00 D5 03 00 D7 03 00 D9 03 00 D9 03 00 DB 03 00 DB 03 00'\r\n 'DD 03 00 DD 03 00 DF 03 00 DF 03 00 E1 03 00 E1 03 00 E3 03 00 E3 03 00 E5 03 00 E5 03 00 E7 03'\r\n '00 E7 03 00 E9 03 00 E9 03 00 EB 03 00 EB 03 00 ED 03 00 ED 03 00 EF 03 00 F3 03 00 F5 03 00 F5'\r\n '03 00 F8 03 00 F8 03 00 FB 03 00 FC 03 00 30 04 00 5F 04 00 61 04 00 61 04 00 63 04 00 63 04 00'\r\n '65 04 00 65 04 00 67 04 00 67 04 00 69 04 00 69 04 00 6B 04 00 6B 04 00 6D 04 00 6D 04 00 6F 04'\r\n '00 6F 04 00 71 04 00 71 04 00 73 04 00 73 04 00 75 04 00 75 04 00 77 04 00 77 04 00 79 04 00 79'\r\n '04 00 7B 04 00 7B 04 00 7D 04 00 7D 04 00 7F 04 00 7F 04 00 81 04 00 81 04 00 8B 04 00 8B 04 00'\r\n '8D 04 00 8D 04 00 8F 04 00 8F 04 00 91 04 00 91 04 00 93 04 00 93 04 00 95 04 00 95 04 00 97 04'\r\n '00 97 04 00 99 04 00 99 04 00 9B 04 00 9B 04 00 9D 04 00 9D 04 00 9F 04 00 9F 04 00 A1 04 00 A1'\r\n '04 00 A3 04 00 A3 04 00 A5 04 00 A5 04 00 A7 04 00 A7 04 00 A9 04 00 A9 04 00 AB 04 00 AB 04 00'\r\n 'AD 04 00 AD 04 00 AF 04 00 AF 04 00 B1 04 00 B1 04 00 B3 04 00 B3 04 00 B5 04 00 B5 04 00 B7 04'\r\n '00 B7 04 00 B9 04 00 B9 04 00 BB 04 00 BB 04 00 BD 04 00 BD 04 00 BF 04 00 BF 04 00 C2 04 00 C2'\r\n '04 00 C4 04 00 C4 04 00 C6 04 00 C6 04 00 C8 04 00 C8 04 00 CA 04 00 CA 04 00 CC 04 00 CC 04 00'\r\n 'CE 04 00 CF 04 00 D1 04 00 D1 04 00 D3 04 00 D3 04 00 D5 04 00 D5 04 00 D7 04 00 D7 04 00 D9 04'\r\n '00 D9 04 00 DB 04 00 DB 04 00 DD 04 00 DD 04 00 DF 04 00 DF 04 00 E1 04 00 E1 04 00 E3 04 00 E3'\r\n '04 00 E5 04 00 E5 04 00 E7 04 00 E7 04 00 E9 04 00 E9 04 00 EB 04 00 EB 04 00 ED 04 00 ED 04 00'\r\n 'EF 04 00 EF 04 00 F1 04 00 F1 04 00 F3 04 00 F3 04 00 F5 04 00 F5 04 00 F7 04 00 F7 04 00 F9 04'\r\n '00 F9 04 00 FB 04 00 FB 04 00 FD 04 00 FD 04 00 FF 04 00 FF 04 00 01 05 00 01 05 00 03 05 00 03'\r\n '05 00 05 05 00 05 05 00 07 05 00 07 05 00 09 05 00 09 05 00 0B 05 00 0B 05 00 0D 05 00 0D 05 00'\r\n '0F 05 00 0F 05 00 11 05 00 11 05 00 13 05 00 13 05 00 15 05 00 15 05 00 17 05 00 17 05 00 19 05'\r\n '00 19 05 00 1B 05 00 1B 05 00 1D 05 00 1D 05 00 1F 05 00 1F 05 00 21 05 00 21 05 00 23 05 00 23'\r\n '05 00 25 05 00 25 05 00 27 05 00 27 05 00 61 05 00 87 05 00 00 1D 00 2B 1D 00 62 1D 00 77 1D 00'\r\n '79 1D 00 9A 1D 00 01 1E 00 01 1E 00 03 1E 00 03 1E 00 05 1E 00 05 1E 00 07 1E 00 07 1E 00 09 1E'\r\n '00 09 1E 00 0B 1E 00 0B 1E 00 0D 1E 00 0D 1E 00 0F 1E 00 0F 1E 00 11 1E 00 11 1E 00 13 1E 00 13'\r\n '1E 00 15 1E 00 15 1E 00 17 1E 00 17 1E 00 19 1E 00 19 1E 00 1B 1E 00 1B 1E 00 1D 1E 00 1D 1E 00'\r\n '1F 1E 00 1F 1E 00 21 1E 00 21 1E 00 23 1E 00 23 1E 00 25 1E 00 25 1E 00 27 1E 00 27 1E 00 29 1E'\r\n '00 29 1E 00 2B 1E 00 2B 1E 00 2D 1E 00 2D 1E 00 2F 1E 00 2F 1E 00 31 1E 00 31 1E 00 33 1E 00 33'\r\n '1E 00 35 1E 00 35 1E 00 37 1E 00 37 1E 00 39 1E 00 39 1E 00 3B 1E 00 3B 1E 00 3D 1E 00 3D 1E 00'\r\n '3F 1E 00 3F 1E 00 41 1E 00 41 1E 00 43 1E 00 43 1E 00 45 1E 00 45 1E 00 47 1E 00 47 1E 00 49 1E'\r\n '00 49 1E 00 4B 1E 00 4B 1E 00 4D 1E 00 4D 1E 00 4F 1E 00 4F 1E 00 51 1E 00 51 1E 00 53 1E 00 53'\r\n '1E 00 55 1E 00 55 1E 00 57 1E 00 57 1E 00 59 1E 00 59 1E 00 5B 1E 00 5B 1E 00 5D 1E 00 5D 1E 00'\r\n '5F 1E 00 5F 1E 00 61 1E 00 61 1E 00 63 1E 00 63 1E 00 65 1E 00 65 1E 00 67 1E 00 67 1E 00 69 1E'\r\n '00 69 1E 00 6B 1E 00 6B 1E 00 6D 1E 00 6D 1E 00 6F 1E 00 6F 1E 00 71 1E 00 71 1E 00 73 1E 00 73'\r\n '1E 00 75 1E 00 75 1E 00 77 1E 00 77 1E 00 79 1E 00 79 1E 00 7B 1E 00 7B 1E 00 7D 1E 00 7D 1E 00'\r\n '7F 1E 00 7F 1E 00 81 1E 00 81 1E 00 83 1E 00 83 1E 00 85 1E 00 85 1E 00 87 1E 00 87 1E 00 89 1E'\r\n '00 89 1E 00 8B 1E 00 8B 1E 00 8D 1E 00 8D 1E 00 8F 1E 00 8F 1E 00 91 1E 00 91 1E 00 93 1E 00 93'\r\n '1E 00 95 1E 00 9D 1E 00 9F 1E 00 9F 1E 00 A1 1E 00 A1 1E 00 A3 1E 00 A3 1E 00 A5 1E 00 A5 1E 00'\r\n 'A7 1E 00 A7 1E 00 A9 1E 00 A9 1E 00 AB 1E 00 AB 1E 00 AD 1E 00 AD 1E 00 AF 1E 00 AF 1E 00 B1 1E'\r\n '00 B1 1E 00 B3 1E 00 B3 1E 00 B5 1E 00 B5 1E 00 B7 1E 00 B7 1E 00 B9 1E 00 B9 1E 00 BB 1E 00 BB'\r\n '1E 00 BD 1E 00 BD 1E 00 BF 1E 00 BF 1E 00 C1 1E 00 C1 1E 00 C3 1E 00 C3 1E 00 C5 1E 00 C5 1E 00'\r\n 'C7 1E 00 C7 1E 00 C9 1E 00 C9 1E 00 CB 1E 00 CB 1E 00 CD 1E 00 CD 1E 00 CF 1E 00 CF 1E 00 D1 1E'\r\n '00 D1 1E 00 D3 1E 00 D3 1E 00 D5 1E 00 D5 1E 00 D7 1E 00 D7 1E 00 D9 1E 00 D9 1E 00 DB 1E 00 DB'\r\n '1E 00 DD 1E 00 DD 1E 00 DF 1E 00 DF 1E 00 E1 1E 00 E1 1E 00 E3 1E 00 E3 1E 00 E5 1E 00 E5 1E 00'\r\n 'E7 1E 00 E7 1E 00 E9 1E 00 E9 1E 00 EB 1E 00 EB 1E 00 ED 1E 00 ED 1E 00 EF 1E 00 EF 1E 00 F1 1E'\r\n '00 F1 1E 00 F3 1E 00 F3 1E 00 F5 1E 00 F5 1E 00 F7 1E 00 F7 1E 00 F9 1E 00 F9 1E 00 FB 1E 00 FB'\r\n '1E 00 FD 1E 00 FD 1E 00 FF 1E 00 07 1F 00 10 1F 00 15 1F 00 20 1F 00 27 1F 00 30 1F 00 37 1F 00'\r\n '40 1F 00 45 1F 00 50 1F 00 57 1F 00 60 1F 00 67 1F 00 70 1F 00 7D 1F 00 80 1F 00 87 1F 00 90 1F'\r\n '00 97 1F 00 A0 1F 00 A7 1F 00 B0 1F 00 B4 1F 00 B6 1F 00 B7 1F 00 BE 1F 00 BE 1F 00 C2 1F 00 C4'\r\n '1F 00 C6 1F 00 C7 1F 00 D0 1F 00 D3 1F 00 D6 1F 00 D7 1F 00 E0 1F 00 E7 1F 00 F2 1F 00 F4 1F 00'\r\n 'F6 1F 00 F7 1F 00 0A 21 00 0A 21 00 0E 21 00 0F 21 00 13 21 00 13 21 00 2F 21 00 2F 21 00 34 21'\r\n '00 34 21 00 39 21 00 39 21 00 3C 21 00 3D 21 00 46 21 00 49 21 00 4E 21 00 4E 21 00 84 21 00 84'\r\n '21 00 30 2C 00 5E 2C 00 61 2C 00 61 2C 00 65 2C 00 66 2C 00 68 2C 00 68 2C 00 6A 2C 00 6A 2C 00'\r\n '6C 2C 00 6C 2C 00 71 2C 00 71 2C 00 73 2C 00 74 2C 00 76 2C 00 7C 2C 00 81 2C 00 81 2C 00 83 2C'\r\n '00 83 2C 00 85 2C 00 85 2C 00 87 2C 00 87 2C 00 89 2C 00 89 2C 00 8B 2C 00 8B 2C 00 8D 2C 00 8D'\r\n '2C 00 8F 2C 00 8F 2C 00 91 2C 00 91 2C 00 93 2C 00 93 2C 00 95 2C 00 95 2C 00 97 2C 00 97 2C 00'\r\n '99 2C 00 99 2C 00 9B 2C 00 9B 2C 00 9D 2C 00 9D 2C 00 9F 2C 00 9F 2C 00 A1 2C 00 A1 2C 00 A3 2C'\r\n '00 A3 2C 00 A5 2C 00 A5 2C 00 A7 2C 00 A7 2C 00 A9 2C 00 A9 2C 00 AB 2C 00 AB 2C 00 AD 2C 00 AD'\r\n '2C 00 AF 2C 00 AF 2C 00 B1 2C 00 B1 2C 00 B3 2C 00 B3 2C 00 B5 2C 00 B5 2C 00 B7 2C 00 B7 2C 00'\r\n 'B9 2C 00 B9 2C 00 BB 2C 00 BB 2C 00 BD 2C 00 BD 2C 00 BF 2C 00 BF 2C 00 C1 2C 00 C1 2C 00 C3 2C'\r\n '00 C3 2C 00 C5 2C 00 C5 2C 00 C7 2C 00 C7 2C 00 C9 2C 00 C9 2C 00 CB 2C 00 CB 2C 00 CD 2C 00 CD'\r\n '2C 00 CF 2C 00 CF 2C 00 D1 2C 00 D1 2C 00 D3 2C 00 D3 2C 00 D5 2C 00 D5 2C 00 D7 2C 00 D7 2C 00'\r\n 'D9 2C 00 D9 2C 00 DB 2C 00 DB 2C 00 DD 2C 00 DD 2C 00 DF 2C 00 DF 2C 00 E1 2C 00 E1 2C 00 E3 2C'\r\n '00 E4 2C 00 EC 2C 00 EC 2C 00 EE 2C 00 EE 2C 00 00 2D 00 25 2D 00 41 A6 00 41 A6 00 43 A6 00 43'\r\n 'A6 00 45 A6 00 45 A6 00 47 A6 00 47 A6 00 49 A6 00 49 A6 00 4B A6 00 4B A6 00 4D A6 00 4D A6 00'\r\n '4F A6 00 4F A6 00 51 A6 00 51 A6 00 53 A6 00 53 A6 00 55 A6 00 55 A6 00 57 A6 00 57 A6 00 59 A6'\r\n '00 59 A6 00 5B A6 00 5B A6 00 5D A6 00 5D A6 00 5F A6 00 5F A6 00 61 A6 00 61 A6 00 63 A6 00 63'\r\n 'A6 00 65 A6 00 65 A6 00 67 A6 00 67 A6 00 69 A6 00 69 A6 00 6B A6 00 6B A6 00 6D A6 00 6D A6 00'\r\n '81 A6 00 81 A6 00 83 A6 00 83 A6 00 85 A6 00 85 A6 00 87 A6 00 87 A6 00 89 A6 00 89 A6 00 8B A6'\r\n '00 8B A6 00 8D A6 00 8D A6 00 8F A6 00 8F A6 00 91 A6 00 91 A6 00 93 A6 00 93 A6 00 95 A6 00 95'\r\n 'A6 00 97 A6 00 97 A6 00 23 A7 00 23 A7 00 25 A7 00 25 A7 00 27 A7 00 27 A7 00 29 A7 00 29 A7 00'\r\n '2B A7 00 2B A7 00 2D A7 00 2D A7 00 2F A7 00 31 A7 00 33 A7 00 33 A7 00 35 A7 00 35 A7 00 37 A7'\r\n '00 37 A7 00 39 A7 00 39 A7 00 3B A7 00 3B A7 00 3D A7 00 3D A7 00 3F A7 00 3F A7 00 41 A7 00 41'\r\n 'A7 00 43 A7 00 43 A7 00 45 A7 00 45 A7 00 47 A7 00 47 A7 00 49 A7 00 49 A7 00 4B A7 00 4B A7 00'\r\n '4D A7 00 4D A7 00 4F A7 00 4F A7 00 51 A7 00 51 A7 00 53 A7 00 53 A7 00 55 A7 00 55 A7 00 57 A7'\r\n '00 57 A7 00 59 A7 00 59 A7 00 5B A7 00 5B A7 00 5D A7 00 5D A7 00 5F A7 00 5F A7 00 61 A7 00 61'\r\n 'A7 00 63 A7 00 63 A7 00 65 A7 00 65 A7 00 67 A7 00 67 A7 00 69 A7 00 69 A7 00 6B A7 00 6B A7 00'\r\n '6D A7 00 6D A7 00 6F A7 00 6F A7 00 71 A7 00 78 A7 00 7A A7 00 7A A7 00 7C A7 00 7C A7 00 7F A7'\r\n '00 7F A7 00 81 A7 00 81 A7 00 83 A7 00 83 A7 00 85 A7 00 85 A7 00 87 A7 00 87 A7 00 8C A7 00 8C'\r\n 'A7 00 8E A7 00 8E A7 00 91 A7 00 91 A7 00 A1 A7 00 A1 A7 00 A3 A7 00 A3 A7 00 A5 A7 00 A5 A7 00'\r\n 'A7 A7 00 A7 A7 00 A9 A7 00 A9 A7 00 FA A7 00 FA A7 00 00 FB 00 06 FB 00 13 FB 00 17 FB 00 41 FF'\r\n '00 5A FF 00 28 04 01 4F 04 01 1A D4 01 33 D4 01 4E D4 01 54 D4 01 56 D4 01 67 D4 01 82 D4 01 9B'\r\n 'D4 01 B6 D4 01 B9 D4 01 BB D4 01 BB D4 01 BD D4 01 C3 D4 01 C5 D4 01 CF D4 01 EA D4 01 03 D5 01'\r\n '1E D5 01 37 D5 01 52 D5 01 6B D5 01 86 D5 01 9F D5 01 BA D5 01 D3 D5 01 EE D5 01 07 D6 01 22 D6'\r\n '01 3B D6 01 56 D6 01 6F D6 01 8A D6 01 A5 D6 01 C2 D6 01 DA D6 01 DC D6 01 E1 D6 01 FC D6 01 14'\r\n 'D7 01 16 D7 01 1B D7 01 36 D7 01 4E D7 01 50 D7 01 55 D7 01 70 D7 01 88 D7 01 8A D7 01 8F D7 01'\r\n 'AA D7 01 C2 D7 01 C4 D7 01 C9 D7 01 CB D7 01 CB D7 01 02 0A 00 00 00 C5 01 00 C5 01 00 C8 01 00'\r\n 'C8 01 00 CB 01 00 CB 01 00 F2 01 00 F2 01 00 88 1F 00 8F 1F 00 98 1F 00 9F 1F 00 A8 1F 00 AF 1F'\r\n '00 BC 1F 00 BC 1F 00 CC 1F 00 CC 1F 00 FC 1F 00 FC 1F 00 03 C9 00 00 00 00 03 00 6F 03 00 83 04'\r\n '00 89 04 00 91 05 00 BD 05 00 BF 05 00 BF 05 00 C1 05 00 C2 05 00 C4 05 00 C5 05 00 C7 05 00 C7'\r\n '05 00 10 06 00 1A 06 00 4B 06 00 5F 06 00 70 06 00 70 06 00 D6 06 00 DC 06 00 DF 06 00 E4 06 00'\r\n 'E7 06 00 E8 06 00 EA 06 00 ED 06 00 11 07 00 11 07 00 30 07 00 4A 07 00 A6 07 00 B0 07 00 EB 07'\r\n '00 F3 07 00 16 08 00 19 08 00 1B 08 00 23 08 00 25 08 00 27 08 00 29 08 00 2D 08 00 59 08 00 5B'\r\n '08 00 00 09 00 02 09 00 3A 09 00 3A 09 00 3C 09 00 3C 09 00 41 09 00 48 09 00 4D 09 00 4D 09 00'\r\n '51 09 00 57 09 00 62 09 00 63 09 00 81 09 00 81 09 00 BC 09 00 BC 09 00 C1 09 00 C4 09 00 CD 09'\r\n '00 CD 09 00 E2 09 00 E3 09 00 01 0A 00 02 0A 00 3C 0A 00 3C 0A 00 41 0A 00 42 0A 00 47 0A 00 48'\r\n '0A 00 4B 0A 00 4D 0A 00 51 0A 00 51 0A 00 70 0A 00 71 0A 00 75 0A 00 75 0A 00 81 0A 00 82 0A 00'\r\n 'BC 0A 00 BC 0A 00 C1 0A 00 C5 0A 00 C7 0A 00 C8 0A 00 CD 0A 00 CD 0A 00 E2 0A 00 E3 0A 00 01 0B'\r\n '00 01 0B 00 3C 0B 00 3C 0B 00 3F 0B 00 3F 0B 00 41 0B 00 44 0B 00 4D 0B 00 4D 0B 00 56 0B 00 56'\r\n '0B 00 62 0B 00 63 0B 00 82 0B 00 82 0B 00 C0 0B 00 C0 0B 00 CD 0B 00 CD 0B 00 3E 0C 00 40 0C 00'\r\n '46 0C 00 48 0C 00 4A 0C 00 4D 0C 00 55 0C 00 56 0C 00 62 0C 00 63 0C 00 BC 0C 00 BC 0C 00 BF 0C'\r\n '00 BF 0C 00 C6 0C 00 C6 0C 00 CC 0C 00 CD 0C 00 E2 0C 00 E3 0C 00 41 0D 00 44 0D 00 4D 0D 00 4D'\r\n '0D 00 62 0D 00 63 0D 00 CA 0D 00 CA 0D 00 D2 0D 00 D4 0D 00 D6 0D 00 D6 0D 00 31 0E 00 31 0E 00'\r\n '34 0E 00 3A 0E 00 47 0E 00 4E 0E 00 B1 0E 00 B1 0E 00 B4 0E 00 B9 0E 00 BB 0E 00 BC 0E 00 C8 0E'\r\n '00 CD 0E 00 18 0F 00 19 0F 00 35 0F 00 35 0F 00 37 0F 00 37 0F 00 39 0F 00 39 0F 00 71 0F 00 7E'\r\n '0F 00 80 0F 00 84 0F 00 86 0F 00 87 0F 00 8D 0F 00 97 0F 00 99 0F 00 BC 0F 00 C6 0F 00 C6 0F 00'\r\n '2D 10 00 30 10 00 32 10 00 37 10 00 39 10 00 3A 10 00 3D 10 00 3E 10 00 58 10 00 59 10 00 5E 10'\r\n '00 60 10 00 71 10 00 74 10 00 82 10 00 82 10 00 85 10 00 86 10 00 8D 10 00 8D 10 00 9D 10 00 9D'\r\n '10 00 5D 13 00 5F 13 00 12 17 00 14 17 00 32 17 00 34 17 00 52 17 00 53 17 00 72 17 00 73 17 00'\r\n 'B7 17 00 BD 17 00 C6 17 00 C6 17 00 C9 17 00 D3 17 00 DD 17 00 DD 17 00 0B 18 00 0D 18 00 A9 18'\r\n '00 A9 18 00 20 19 00 22 19 00 27 19 00 28 19 00 32 19 00 32 19 00 39 19 00 3B 19 00 17 1A 00 18'\r\n '1A 00 56 1A 00 56 1A 00 58 1A 00 5E 1A 00 60 1A 00 60 1A 00 62 1A 00 62 1A 00 65 1A 00 6C 1A 00'\r\n '73 1A 00 7C 1A 00 7F 1A 00 7F 1A 00 00 1B 00 03 1B 00 34 1B 00 34 1B 00 36 1B 00 3A 1B 00 3C 1B'\r\n '00 3C 1B 00 42 1B 00 42 1B 00 6B 1B 00 73 1B 00 80 1B 00 81 1B 00 A2 1B 00 A5 1B 00 A8 1B 00 A9'\r\n '1B 00 E6 1B 00 E6 1B 00 E8 1B 00 E9 1B 00 ED 1B 00 ED 1B 00 EF 1B 00 F1 1B 00 2C 1C 00 33 1C 00'\r\n '36 1C 00 37 1C 00 D0 1C 00 D2 1C 00 D4 1C 00 E0 1C 00 E2 1C 00 E8 1C 00 ED 1C 00 ED 1C 00 C0 1D'\r\n '00 E6 1D 00 FC 1D 00 FF 1D 00 D0 20 00 F0 20 00 EF 2C 00 F1 2C 00 7F 2D 00 7F 2D 00 E0 2D 00 FF'\r\n '2D 00 2A 30 00 2F 30 00 99 30 00 9A 30 00 6F A6 00 72 A6 00 7C A6 00 7D A6 00 F0 A6 00 F1 A6 00'\r\n '02 A8 00 02 A8 00 06 A8 00 06 A8 00 0B A8 00 0B A8 00 25 A8 00 26 A8 00 C4 A8 00 C4 A8 00 E0 A8'\r\n '00 F1 A8 00 26 A9 00 2D A9 00 47 A9 00 51 A9 00 80 A9 00 82 A9 00 B3 A9 00 B3 A9 00 B6 A9 00 B9'\r\n 'A9 00 BC A9 00 BC A9 00 29 AA 00 2E AA 00 31 AA 00 32 AA 00 35 AA 00 36 AA 00 43 AA 00 43 AA 00'\r\n '4C AA 00 4C AA 00 B0 AA 00 B0 AA 00 B2 AA 00 B4 AA 00 B7 AA 00 B8 AA 00 BE AA 00 BF AA 00 C1 AA'\r\n '00 C1 AA 00 E5 AB 00 E5 AB 00 E8 AB 00 E8 AB 00 ED AB 00 ED AB 00 1E FB 00 1E FB 00 00 FE 00 0F'\r\n 'FE 00 20 FE 00 26 FE 00 FD 01 01 FD 01 01 01 0A 01 03 0A 01 05 0A 01 06 0A 01 0C 0A 01 0F 0A 01'\r\n '38 0A 01 3A 0A 01 3F 0A 01 3F 0A 01 01 10 01 01 10 01 38 10 01 46 10 01 80 10 01 81 10 01 B3 10'\r\n '01 B6 10 01 B9 10 01 BA 10 01 67 D1 01 69 D1 01 7B D1 01 82 D1 01 85 D1 01 8B D1 01 AA D1 01 AD'\r\n 'D1 01 42 D2 01 44 D2 01 00 01 0E EF 01 0E 04 71 00 00 00 03 09 00 03 09 00 3B 09 00 3B 09 00 3E'\r\n '09 00 40 09 00 49 09 00 4C 09 00 4E 09 00 4F 09 00 82 09 00 83 09 00 BE 09 00 C0 09 00 C7 09 00'\r\n 'C8 09 00 CB 09 00 CC 09 00 D7 09 00 D7 09 00 03 0A 00 03 0A 00 3E 0A 00 40 0A 00 83 0A 00 83 0A'\r\n '00 BE 0A 00 C0 0A 00 C9 0A 00 C9 0A 00 CB 0A 00 CC 0A 00 02 0B 00 03 0B 00 3E 0B 00 3E 0B 00 40'\r\n '0B 00 40 0B 00 47 0B 00 48 0B 00 4B 0B 00 4C 0B 00 57 0B 00 57 0B 00 BE 0B 00 BF 0B 00 C1 0B 00'\r\n 'C2 0B 00 C6 0B 00 C8 0B 00 CA 0B 00 CC 0B 00 D7 0B 00 D7 0B 00 01 0C 00 03 0C 00 41 0C 00 44 0C'\r\n '00 82 0C 00 83 0C 00 BE 0C 00 BE 0C 00 C0 0C 00 C4 0C 00 C7 0C 00 C8 0C 00 CA 0C 00 CB 0C 00 D5'\r\n '0C 00 D6 0C 00 02 0D 00 03 0D 00 3E 0D 00 40 0D 00 46 0D 00 48 0D 00 4A 0D 00 4C 0D 00 57 0D 00'\r\n '57 0D 00 82 0D 00 83 0D 00 CF 0D 00 D1 0D 00 D8 0D 00 DF 0D 00 F2 0D 00 F3 0D 00 3E 0F 00 3F 0F'\r\n '00 7F 0F 00 7F 0F 00 2B 10 00 2C 10 00 31 10 00 31 10 00 38 10 00 38 10 00 3B 10 00 3C 10 00 56'\r\n '10 00 57 10 00 62 10 00 64 10 00 67 10 00 6D 10 00 83 10 00 84 10 00 87 10 00 8C 10 00 8F 10 00'\r\n '8F 10 00 9A 10 00 9C 10 00 B6 17 00 B6 17 00 BE 17 00 C5 17 00 C7 17 00 C8 17 00 23 19 00 26 19'\r\n '00 29 19 00 2B 19 00 30 19 00 31 19 00 33 19 00 38 19 00 B0 19 00 C0 19 00 C8 19 00 C9 19 00 19'\r\n '1A 00 1B 1A 00 55 1A 00 55 1A 00 57 1A 00 57 1A 00 61 1A 00 61 1A 00 63 1A 00 64 1A 00 6D 1A 00'\r\n '72 1A 00 04 1B 00 04 1B 00 35 1B 00 35 1B 00 3B 1B 00 3B 1B 00 3D 1B 00 41 1B 00 43 1B 00 44 1B'\r\n '00 82 1B 00 82 1B 00 A1 1B 00 A1 1B 00 A6 1B 00 A7 1B 00 AA 1B 00 AA 1B 00 E7 1B 00 E7 1B 00 EA'\r\n '1B 00 EC 1B 00 EE 1B 00 EE 1B 00 F2 1B 00 F3 1B 00 24 1C 00 2B 1C 00 34 1C 00 35 1C 00 E1 1C 00'\r\n 'E1 1C 00 F2 1C 00 F2 1C 00 23 A8 00 24 A8 00 27 A8 00 27 A8 00 80 A8 00 81 A8 00 B4 A8 00 C3 A8'\r\n '00 52 A9 00 53 A9 00 83 A9 00 83 A9 00 B4 A9 00 B5 A9 00 BA A9 00 BB A9 00 BD A9 00 C0 A9 00 2F'\r\n 'AA 00 30 AA 00 33 AA 00 34 AA 00 4D AA 00 4D AA 00 7B AA 00 7B AA 00 E3 AB 00 E4 AB 00 E6 AB 00'\r\n 'E7 AB 00 E9 AB 00 EA AB 00 EC AB 00 EC AB 00 00 10 01 00 10 01 02 10 01 02 10 01 82 10 01 82 10'\r\n '01 B0 10 01 B2 10 01 B7 10 01 B8 10 01 65 D1 01 66 D1 01 6D D1 01 72 D1 01 05 04 00 00 00 88 04'\r\n '00 89 04 00 DD 20 00 E0 20 00 E2 20 00 E4 20 00 70 A6 00 72 A6 00 06 26 00 00 00 30 00 00 39 00'\r\n '00 60 06 00 69 06 00 F0 06 00 F9 06 00 C0 07 00 C9 07 00 66 09 00 6F 09 00 E6 09 00 EF 09 00 66'\r\n '0A 00 6F 0A 00 E6 0A 00 EF 0A 00 66 0B 00 6F 0B 00 E6 0B 00 EF 0B 00 66 0C 00 6F 0C 00 E6 0C 00'\r\n 'EF 0C 00 66 0D 00 6F 0D 00 50 0E 00 59 0E 00 D0 0E 00 D9 0E 00 20 0F 00 29 0F 00 40 10 00 49 10'\r\n '00 90 10 00 99 10 00 E0 17 00 E9 17 00 10 18 00 19 18 00 46 19 00 4F 19 00 D0 19 00 D9 19 00 80'\r\n '1A 00 89 1A 00 90 1A 00 99 1A 00 50 1B 00 59 1B 00 B0 1B 00 B9 1B 00 40 1C 00 49 1C 00 50 1C 00'\r\n '59 1C 00 20 A6 00 29 A6 00 D0 A8 00 D9 A8 00 00 A9 00 09 A9 00 D0 A9 00 D9 A9 00 50 AA 00 59 AA'\r\n '00 F0 AB 00 F9 AB 00 10 FF 00 19 FF 00 A0 04 01 A9 04 01 66 10 01 6F 10 01 CE D7 01 FF D7 01 07'\r\n '0C 00 00 00 EE 16 00 F0 16 00 60 21 00 82 21 00 85 21 00 88 21 00 07 30 00 07 30 00 21 30 00 29'\r\n '30 00 38 30 00 3A 30 00 E6 A6 00 EF A6 00 40 01 01 74 01 01 41 03 01 41 03 01 4A 03 01 4A 03 01'\r\n 'D1 03 01 D5 03 01 00 24 01 62 24 01 08 29 00 00 00 B2 00 00 B3 00 00 B9 00 00 B9 00 00 BC 00 00'\r\n 'BE 00 00 F4 09 00 F9 09 00 72 0B 00 77 0B 00 F0 0B 00 F2 0B 00 78 0C 00 7E 0C 00 70 0D 00 75 0D'\r\n '00 2A 0F 00 33 0F 00 69 13 00 7C 13 00 F0 17 00 F9 17 00 DA 19 00 DA 19 00 70 20 00 70 20 00 74'\r\n '20 00 79 20 00 80 20 00 89 20 00 50 21 00 5F 21 00 89 21 00 89 21 00 60 24 00 9B 24 00 EA 24 00'\r\n 'FF 24 00 76 27 00 93 27 00 FD 2C 00 FD 2C 00 92 31 00 95 31 00 20 32 00 29 32 00 51 32 00 5F 32'\r\n '00 80 32 00 89 32 00 B1 32 00 BF 32 00 30 A8 00 35 A8 00 07 01 01 33 01 01 75 01 01 78 01 01 8A'\r\n '01 01 8A 01 01 20 03 01 23 03 01 58 08 01 5F 08 01 16 09 01 1B 09 01 40 0A 01 47 0A 01 7D 0A 01'\r\n '7E 0A 01 58 0B 01 5F 0B 01 78 0B 01 7F 0B 01 60 0E 01 7E 0E 01 52 10 01 65 10 01 60 D3 01 71 D3'\r\n '01 00 F1 01 0A F1 01 09 08 00 00 00 20 00 00 20 00 00 A0 00 00 A0 00 00 80 16 00 80 16 00 0E 18'\r\n '00 0E 18 00 00 20 00 0A 20 00 2F 20 00 2F 20 00 5F 20 00 5F 20 00 00 30 00 00 30 00 0A 01 00 00'\r\n '00 28 20 00 28 20 00 0B 05 00 00 00 0A 00 00 0A 00 00 0D 00 00 0D 00 00 1C 00 00 1E 00 00 85 00'\r\n '00 85 00 00 29 20 00 29 20 00 0C 02 00 00 00 00 00 00 1F 00 00 7F 00 00 9F 00 00 0D 0F 00 00 00'\r\n 'AD 00 00 AD 00 00 00 06 00 03 06 00 DD 06 00 DD 06 00 0F 07 00 0F 07 00 B4 17 00 B5 17 00 0B 20'\r\n '00 0F 20 00 2A 20 00 2E 20 00 60 20 00 64 20 00 6A 20 00 6F 20 00 FF FE 00 FF FE 00 F9 FF 00 FB'\r\n 'FF 00 BD 10 01 BD 10 01 73 D1 01 7A D1 01 01 00 0E 01 00 0E 20 00 0E 7F 00 0E 0E 01 00 00 00 00'\r\n 'D8 00 FF DF 00 0F 03 00 00 00 00 E0 00 FF F8 00 00 00 0F FD FF 0F 00 00 10 FD FF 10 11 31 00 00'\r\n '00 B0 02 00 C1 02 00 C6 02 00 D1 02 00 E0 02 00 E4 02 00 EC 02 00 EC 02 00 EE 02 00 EE 02 00 74'\r\n '03 00 74 03 00 7A 03 00 7A 03 00 59 05 00 59 05 00 40 06 00 40 06 00 E5 06 00 E6 06 00 F4 07 00'\r\n 'F5 07 00 FA 07 00 FA 07 00 1A 08 00 1A 08 00 24 08 00 24 08 00 28 08 00 28 08 00 71 09 00 71 09'\r\n '00 46 0E 00 46 0E 00 C6 0E 00 C6 0E 00 FC 10 00 FC 10 00 D7 17 00 D7 17 00 43 18 00 43 18 00 A7'\r\n '1A 00 A7 1A 00 78 1C 00 7D 1C 00 2C 1D 00 61 1D 00 78 1D 00 78 1D 00 9B 1D 00 BF 1D 00 71 20 00'\r\n '71 20 00 7F 20 00 7F 20 00 90 20 00 9C 20 00 7D 2C 00 7D 2C 00 6F 2D 00 6F 2D 00 2F 2E 00 2F 2E'\r\n '00 05 30 00 05 30 00 31 30 00 35 30 00 3B 30 00 3B 30 00 9D 30 00 9E 30 00 FC 30 00 FE 30 00 15'\r\n 'A0 00 15 A0 00 F8 A4 00 FD A4 00 0C A6 00 0C A6 00 7F A6 00 7F A6 00 17 A7 00 1F A7 00 70 A7 00'\r\n '70 A7 00 88 A7 00 88 A7 00 CF A9 00 CF A9 00 70 AA 00 70 AA 00 DD AA 00 DD AA 00 70 FF 00 70 FF'\r\n '00 9E FF 00 9F FF 00 12 43 01 00 00 BB 01 00 BB 01 00 C0 01 00 C3 01 00 94 02 00 94 02 00 D0 05'\r\n '00 EA 05 00 F0 05 00 F2 05 00 20 06 00 3F 06 00 41 06 00 4A 06 00 6E 06 00 6F 06 00 71 06 00 D3'\r\n '06 00 D5 06 00 D5 06 00 EE 06 00 EF 06 00 FA 06 00 FC 06 00 FF 06 00 FF 06 00 10 07 00 10 07 00'\r\n '12 07 00 2F 07 00 4D 07 00 A5 07 00 B1 07 00 B1 07 00 CA 07 00 EA 07 00 00 08 00 15 08 00 40 08'\r\n '00 58 08 00 04 09 00 39 09 00 3D 09 00 3D 09 00 50 09 00 50 09 00 58 09 00 61 09 00 72 09 00 77'\r\n '09 00 79 09 00 7F 09 00 85 09 00 8C 09 00 8F 09 00 90 09 00 93 09 00 A8 09 00 AA 09 00 B0 09 00'\r\n 'B2 09 00 B2 09 00 B6 09 00 B9 09 00 BD 09 00 BD 09 00 CE 09 00 CE 09 00 DC 09 00 DD 09 00 DF 09'\r\n '00 E1 09 00 F0 09 00 F1 09 00 05 0A 00 0A 0A 00 0F 0A 00 10 0A 00 13 0A 00 28 0A 00 2A 0A 00 30'\r\n '0A 00 32 0A 00 33 0A 00 35 0A 00 36 0A 00 38 0A 00 39 0A 00 59 0A 00 5C 0A 00 5E 0A 00 5E 0A 00'\r\n '72 0A 00 74 0A 00 85 0A 00 8D 0A 00 8F 0A 00 91 0A 00 93 0A 00 A8 0A 00 AA 0A 00 B0 0A 00 B2 0A'\r\n '00 B3 0A 00 B5 0A 00 B9 0A 00 BD 0A 00 BD 0A 00 D0 0A 00 D0 0A 00 E0 0A 00 E1 0A 00 05 0B 00 0C'\r\n '0B 00 0F 0B 00 10 0B 00 13 0B 00 28 0B 00 2A 0B 00 30 0B 00 32 0B 00 33 0B 00 35 0B 00 39 0B 00'\r\n '3D 0B 00 3D 0B 00 5C 0B 00 5D 0B 00 5F 0B 00 61 0B 00 71 0B 00 71 0B 00 83 0B 00 83 0B 00 85 0B'\r\n '00 8A 0B 00 8E 0B 00 90 0B 00 92 0B 00 95 0B 00 99 0B 00 9A 0B 00 9C 0B 00 9C 0B 00 9E 0B 00 9F'\r\n '0B 00 A3 0B 00 A4 0B 00 A8 0B 00 AA 0B 00 AE 0B 00 B9 0B 00 D0 0B 00 D0 0B 00 05 0C 00 0C 0C 00'\r\n '0E 0C 00 10 0C 00 12 0C 00 28 0C 00 2A 0C 00 33 0C 00 35 0C 00 39 0C 00 3D 0C 00 3D 0C 00 58 0C'\r\n '00 59 0C 00 60 0C 00 61 0C 00 85 0C 00 8C 0C 00 8E 0C 00 90 0C 00 92 0C 00 A8 0C 00 AA 0C 00 B3'\r\n '0C 00 B5 0C 00 B9 0C 00 BD 0C 00 BD 0C 00 DE 0C 00 DE 0C 00 E0 0C 00 E1 0C 00 F1 0C 00 F2 0C 00'\r\n '05 0D 00 0C 0D 00 0E 0D 00 10 0D 00 12 0D 00 3A 0D 00 3D 0D 00 3D 0D 00 4E 0D 00 4E 0D 00 60 0D'\r\n '00 61 0D 00 7A 0D 00 7F 0D 00 85 0D 00 96 0D 00 9A 0D 00 B1 0D 00 B3 0D 00 BB 0D 00 BD 0D 00 BD'\r\n '0D 00 C0 0D 00 C6 0D 00 01 0E 00 30 0E 00 32 0E 00 33 0E 00 40 0E 00 45 0E 00 81 0E 00 82 0E 00'\r\n '84 0E 00 84 0E 00 87 0E 00 88 0E 00 8A 0E 00 8A 0E 00 8D 0E 00 8D 0E 00 94 0E 00 97 0E 00 99 0E'\r\n '00 9F 0E 00 A1 0E 00 A3 0E 00 A5 0E 00 A5 0E 00 A7 0E 00 A7 0E 00 AA 0E 00 AB 0E 00 AD 0E 00 B0'\r\n '0E 00 B2 0E 00 B3 0E 00 BD 0E 00 BD 0E 00 C0 0E 00 C4 0E 00 DC 0E 00 DD 0E 00 00 0F 00 00 0F 00'\r\n '40 0F 00 47 0F 00 49 0F 00 6C 0F 00 88 0F 00 8C 0F 00 00 10 00 2A 10 00 3F 10 00 3F 10 00 50 10'\r\n '00 55 10 00 5A 10 00 5D 10 00 61 10 00 61 10 00 65 10 00 66 10 00 6E 10 00 70 10 00 75 10 00 81'\r\n '10 00 8E 10 00 8E 10 00 D0 10 00 FA 10 00 00 11 00 48 12 00 4A 12 00 4D 12 00 50 12 00 56 12 00'\r\n '58 12 00 58 12 00 5A 12 00 5D 12 00 60 12 00 88 12 00 8A 12 00 8D 12 00 90 12 00 B0 12 00 B2 12'\r\n '00 B5 12 00 B8 12 00 BE 12 00 C0 12 00 C0 12 00 C2 12 00 C5 12 00 C8 12 00 D6 12 00 D8 12 00 10'\r\n '13 00 12 13 00 15 13 00 18 13 00 5A 13 00 80 13 00 8F 13 00 A0 13 00 F4 13 00 01 14 00 6C 16 00'\r\n '6F 16 00 7F 16 00 81 16 00 9A 16 00 A0 16 00 EA 16 00 00 17 00 0C 17 00 0E 17 00 11 17 00 20 17'\r\n '00 31 17 00 40 17 00 51 17 00 60 17 00 6C 17 00 6E 17 00 70 17 00 80 17 00 B3 17 00 DC 17 00 DC'\r\n '17 00 20 18 00 42 18 00 44 18 00 77 18 00 80 18 00 A8 18 00 AA 18 00 AA 18 00 B0 18 00 F5 18 00'\r\n '00 19 00 1C 19 00 50 19 00 6D 19 00 70 19 00 74 19 00 80 19 00 AB 19 00 C1 19 00 C7 19 00 00 1A'\r\n '00 16 1A 00 20 1A 00 54 1A 00 05 1B 00 33 1B 00 45 1B 00 4B 1B 00 83 1B 00 A0 1B 00 AE 1B 00 AF'\r\n '1B 00 C0 1B 00 E5 1B 00 00 1C 00 23 1C 00 4D 1C 00 4F 1C 00 5A 1C 00 77 1C 00 E9 1C 00 EC 1C 00'\r\n 'EE 1C 00 F1 1C 00 35 21 00 38 21 00 30 2D 00 65 2D 00 80 2D 00 96 2D 00 A0 2D 00 A6 2D 00 A8 2D'\r\n '00 AE 2D 00 B0 2D 00 B6 2D 00 B8 2D 00 BE 2D 00 C0 2D 00 C6 2D 00 C8 2D 00 CE 2D 00 D0 2D 00 D6'\r\n '2D 00 D8 2D 00 DE 2D 00 06 30 00 06 30 00 3C 30 00 3C 30 00 41 30 00 96 30 00 9F 30 00 9F 30 00'\r\n 'A1 30 00 FA 30 00 FF 30 00 FF 30 00 05 31 00 2D 31 00 31 31 00 8E 31 00 A0 31 00 BA 31 00 F0 31'\r\n '00 FF 31 00 00 34 00 B5 4D 00 00 4E 00 CB 9F 00 00 A0 00 14 A0 00 16 A0 00 8C A4 00 D0 A4 00 F7'\r\n 'A4 00 00 A5 00 0B A6 00 10 A6 00 1F A6 00 2A A6 00 2B A6 00 6E A6 00 6E A6 00 A0 A6 00 E5 A6 00'\r\n 'FB A7 00 01 A8 00 03 A8 00 05 A8 00 07 A8 00 0A A8 00 0C A8 00 22 A8 00 40 A8 00 73 A8 00 82 A8'\r\n '00 B3 A8 00 F2 A8 00 F7 A8 00 FB A8 00 FB A8 00 0A A9 00 25 A9 00 30 A9 00 46 A9 00 60 A9 00 7C'\r\n 'A9 00 84 A9 00 B2 A9 00 00 AA 00 28 AA 00 40 AA 00 42 AA 00 44 AA 00 4B AA 00 60 AA 00 6F AA 00'\r\n '71 AA 00 76 AA 00 7A AA 00 7A AA 00 80 AA 00 AF AA 00 B1 AA 00 B1 AA 00 B5 AA 00 B6 AA 00 B9 AA'\r\n '00 BD AA 00 C0 AA 00 C0 AA 00 C2 AA 00 C2 AA 00 DB AA 00 DC AA 00 01 AB 00 06 AB 00 09 AB 00 0E'\r\n 'AB 00 11 AB 00 16 AB 00 20 AB 00 26 AB 00 28 AB 00 2E AB 00 C0 AB 00 E2 AB 00 00 AC 00 A3 D7 00'\r\n 'B0 D7 00 C6 D7 00 CB D7 00 FB D7 00 00 F9 00 2D FA 00 30 FA 00 6D FA 00 70 FA 00 D9 FA 00 1D FB'\r\n '00 1D FB 00 1F FB 00 28 FB 00 2A FB 00 36 FB 00 38 FB 00 3C FB 00 3E FB 00 3E FB 00 40 FB 00 41'\r\n 'FB 00 43 FB 00 44 FB 00 46 FB 00 B1 FB 00 D3 FB 00 3D FD 00 50 FD 00 8F FD 00 92 FD 00 C7 FD 00'\r\n 'F0 FD 00 FB FD 00 70 FE 00 74 FE 00 76 FE 00 FC FE 00 66 FF 00 6F FF 00 71 FF 00 9D FF 00 A0 FF'\r\n '00 BE FF 00 C2 FF 00 C7 FF 00 CA FF 00 CF FF 00 D2 FF 00 D7 FF 00 DA FF 00 DC FF 00 00 00 01 0B'\r\n '00 01 0D 00 01 26 00 01 28 00 01 3A 00 01 3C 00 01 3D 00 01 3F 00 01 4D 00 01 50 00 01 5D 00 01'\r\n '80 00 01 FA 00 01 80 02 01 9C 02 01 A0 02 01 D0 02 01 00 03 01 1E 03 01 30 03 01 40 03 01 42 03'\r\n '01 49 03 01 80 03 01 9D 03 01 A0 03 01 C3 03 01 C8 03 01 CF 03 01 50 04 01 9D 04 01 00 08 01 05'\r\n '08 01 08 08 01 08 08 01 0A 08 01 35 08 01 37 08 01 38 08 01 3C 08 01 3C 08 01 3F 08 01 55 08 01'\r\n '00 09 01 15 09 01 20 09 01 39 09 01 00 0A 01 00 0A 01 10 0A 01 13 0A 01 15 0A 01 17 0A 01 19 0A'\r\n '01 33 0A 01 60 0A 01 7C 0A 01 00 0B 01 35 0B 01 40 0B 01 55 0B 01 60 0B 01 72 0B 01 00 0C 01 48'\r\n '0C 01 03 10 01 37 10 01 83 10 01 AF 10 01 00 20 01 6E 23 01 00 30 01 2E 34 01 00 68 01 38 6A 01'\r\n '00 B0 01 01 B0 01 00 00 02 D6 A6 02 00 A7 02 34 B7 02 40 B7 02 1D B8 02 00 F8 02 1D FA 02 13 06'\r\n '00 00 00 5F 00 00 5F 00 00 3F 20 00 40 20 00 54 20 00 54 20 00 33 FE 00 34 FE 00 4D FE 00 4F FE'\r\n '00 3F FF 00 3F FF 00 14 13 00 00 00 2D 00 00 2D 00 00 8A 05 00 8A 05 00 BE 05 00 BE 05 00 00 14'\r\n '00 00 14 00 06 18 00 06 18 00 10 20 00 15 20 00 53 20 00 53 20 00 7B 20 00 7B 20 00 8B 20 00 8B'\r\n '20 00 12 22 00 12 22 00 17 2E 00 17 2E 00 1A 2E 00 1A 2E 00 1C 30 00 1C 30 00 30 30 00 30 30 00'\r\n 'A0 30 00 A0 30 00 31 FE 00 32 FE 00 58 FE 00 58 FE 00 63 FE 00 63 FE 00 0D FF 00 0D FF 00 15 48'\r\n '00 00 00 28 00 00 28 00 00 5B 00 00 5B 00 00 7B 00 00 7B 00 00 3A 0F 00 3A 0F 00 3C 0F 00 3C 0F'\r\n '00 9B 16 00 9B 16 00 1A 20 00 1A 20 00 1E 20 00 1E 20 00 45 20 00 45 20 00 7D 20 00 7D 20 00 8D'\r\n '20 00 8D 20 00 29 23 00 29 23 00 68 27 00 68 27 00 6A 27 00 6A 27 00 6C 27 00 6C 27 00 6E 27 00'\r\n '6E 27 00 70 27 00 70 27 00 72 27 00 72 27 00 74 27 00 74 27 00 C5 27 00 C5 27 00 E6 27 00 E6 27'\r\n '00 E8 27 00 E8 27 00 EA 27 00 EA 27 00 EC 27 00 EC 27 00 EE 27 00 EE 27 00 83 29 00 83 29 00 85'\r\n '29 00 85 29 00 87 29 00 87 29 00 89 29 00 89 29 00 8B 29 00 8B 29 00 8D 29 00 8D 29 00 8F 29 00'\r\n '8F 29 00 91 29 00 91 29 00 93 29 00 93 29 00 95 29 00 95 29 00 97 29 00 97 29 00 D8 29 00 D8 29'\r\n '00 DA 29 00 DA 29 00 FC 29 00 FC 29 00 22 2E 00 22 2E 00 24 2E 00 24 2E 00 26 2E 00 26 2E 00 28'\r\n '2E 00 28 2E 00 08 30 00 08 30 00 0A 30 00 0A 30 00 0C 30 00 0C 30 00 0E 30 00 0E 30 00 10 30 00'\r\n '10 30 00 14 30 00 14 30 00 16 30 00 16 30 00 18 30 00 18 30 00 1A 30 00 1A 30 00 1D 30 00 1D 30'\r\n '00 3E FD 00 3E FD 00 17 FE 00 17 FE 00 35 FE 00 35 FE 00 37 FE 00 37 FE 00 39 FE 00 39 FE 00 3B'\r\n 'FE 00 3B FE 00 3D FE 00 3D FE 00 3F FE 00 3F FE 00 41 FE 00 41 FE 00 43 FE 00 43 FE 00 47 FE 00'\r\n '47 FE 00 59 FE 00 59 FE 00 5B FE 00 5B FE 00 5D FE 00 5D FE 00 08 FF 00 08 FF 00 3B FF 00 3B FF'\r\n '00 5B FF 00 5B FF 00 5F FF 00 5F FF 00 62 FF 00 62 FF 00 16 46 00 00 00 29 00 00 29 00 00 5D 00'\r\n '00 5D 00 00 7D 00 00 7D 00 00 3B 0F 00 3B 0F 00 3D 0F 00 3D 0F 00 9C 16 00 9C 16 00 46 20 00 46'\r\n '20 00 7E 20 00 7E 20 00 8E 20 00 8E 20 00 2A 23 00 2A 23 00 69 27 00 69 27 00 6B 27 00 6B 27 00'\r\n '6D 27 00 6D 27 00 6F 27 00 6F 27 00 71 27 00 71 27 00 73 27 00 73 27 00 75 27 00 75 27 00 C6 27'\r\n '00 C6 27 00 E7 27 00 E7 27 00 E9 27 00 E9 27 00 EB 27 00 EB 27 00 ED 27 00 ED 27 00 EF 27 00 EF'\r\n '27 00 84 29 00 84 29 00 86 29 00 86 29 00 88 29 00 88 29 00 8A 29 00 8A 29 00 8C 29 00 8C 29 00'\r\n '8E 29 00 8E 29 00 90 29 00 90 29 00 92 29 00 92 29 00 94 29 00 94 29 00 96 29 00 96 29 00 98 29'\r\n '00 98 29 00 D9 29 00 D9 29 00 DB 29 00 DB 29 00 FD 29 00 FD 29 00 23 2E 00 23 2E 00 25 2E 00 25'\r\n '2E 00 27 2E 00 27 2E 00 29 2E 00 29 2E 00 09 30 00 09 30 00 0B 30 00 0B 30 00 0D 30 00 0D 30 00'\r\n '0F 30 00 0F 30 00 11 30 00 11 30 00 15 30 00 15 30 00 17 30 00 17 30 00 19 30 00 19 30 00 1B 30'\r\n '00 1B 30 00 1E 30 00 1F 30 00 3F FD 00 3F FD 00 18 FE 00 18 FE 00 36 FE 00 36 FE 00 38 FE 00 38'\r\n 'FE 00 3A FE 00 3A FE 00 3C FE 00 3C FE 00 3E FE 00 3E FE 00 40 FE 00 40 FE 00 42 FE 00 42 FE 00'\r\n '44 FE 00 44 FE 00 48 FE 00 48 FE 00 5A FE 00 5A FE 00 5C FE 00 5C FE 00 5E FE 00 5E FE 00 09 FF'\r\n '00 09 FF 00 3D FF 00 3D FF 00 5D FF 00 5D FF 00 60 FF 00 60 FF 00 63 FF 00 63 FF 00 17 0B 00 00'\r\n '00 AB 00 00 AB 00 00 18 20 00 18 20 00 1B 20 00 1C 20 00 1F 20 00 1F 20 00 39 20 00 39 20 00 02'\r\n '2E 00 02 2E 00 04 2E 00 04 2E 00 09 2E 00 09 2E 00 0C 2E 00 0C 2E 00 1C 2E 00 1C 2E 00 20 2E 00'\r\n '20 2E 00 18 0A 00 00 00 BB 00 00 BB 00 00 19 20 00 19 20 00 1D 20 00 1D 20 00 3A 20 00 3A 20 00'\r\n '03 2E 00 03 2E 00 05 2E 00 05 2E 00 0A 2E 00 0A 2E 00 0D 2E 00 0D 2E 00 1D 2E 00 1D 2E 00 21 2E'\r\n '00 21 2E 00 19 80 00 00 00 21 00 00 23 00 00 25 00 00 27 00 00 2A 00 00 2A 00 00 2C 00 00 2C 00'\r\n '00 2E 00 00 2F 00 00 3A 00 00 3B 00 00 3F 00 00 40 00 00 5C 00 00 5C 00 00 A1 00 00 A1 00 00 B7'\r\n '00 00 B7 00 00 BF 00 00 BF 00 00 7E 03 00 7E 03 00 87 03 00 87 03 00 5A 05 00 5F 05 00 89 05 00'\r\n '89 05 00 C0 05 00 C0 05 00 C3 05 00 C3 05 00 C6 05 00 C6 05 00 F3 05 00 F4 05 00 09 06 00 0A 06'\r\n '00 0C 06 00 0D 06 00 1B 06 00 1B 06 00 1E 06 00 1F 06 00 6A 06 00 6D 06 00 D4 06 00 D4 06 00 00'\r\n '07 00 0D 07 00 F7 07 00 F9 07 00 30 08 00 3E 08 00 5E 08 00 5E 08 00 64 09 00 65 09 00 70 09 00'\r\n '70 09 00 F4 0D 00 F4 0D 00 4F 0E 00 4F 0E 00 5A 0E 00 5B 0E 00 04 0F 00 12 0F 00 85 0F 00 85 0F'\r\n '00 D0 0F 00 D4 0F 00 D9 0F 00 DA 0F 00 4A 10 00 4F 10 00 FB 10 00 FB 10 00 61 13 00 68 13 00 6D'\r\n '16 00 6E 16 00 EB 16 00 ED 16 00 35 17 00 36 17 00 D4 17 00 D6 17 00 D8 17 00 DA 17 00 00 18 00'\r\n '05 18 00 07 18 00 0A 18 00 44 19 00 45 19 00 1E 1A 00 1F 1A 00 A0 1A 00 A6 1A 00 A8 1A 00 AD 1A'\r\n '00 5A 1B 00 60 1B 00 FC 1B 00 FF 1B 00 3B 1C 00 3F 1C 00 7E 1C 00 7F 1C 00 D3 1C 00 D3 1C 00 16'\r\n '20 00 17 20 00 20 20 00 27 20 00 30 20 00 38 20 00 3B 20 00 3E 20 00 41 20 00 43 20 00 47 20 00'\r\n '51 20 00 53 20 00 53 20 00 55 20 00 5E 20 00 F9 2C 00 FC 2C 00 FE 2C 00 FF 2C 00 70 2D 00 70 2D'\r\n '00 00 2E 00 01 2E 00 06 2E 00 08 2E 00 0B 2E 00 0B 2E 00 0E 2E 00 16 2E 00 18 2E 00 19 2E 00 1B'\r\n '2E 00 1B 2E 00 1E 2E 00 1F 2E 00 2A 2E 00 2E 2E 00 30 2E 00 31 2E 00 01 30 00 03 30 00 3D 30 00'\r\n '3D 30 00 FB 30 00 FB 30 00 FE A4 00 FF A4 00 0D A6 00 0F A6 00 73 A6 00 73 A6 00 7E A6 00 7E A6'\r\n '00 F2 A6 00 F7 A6 00 74 A8 00 77 A8 00 CE A8 00 CF A8 00 F8 A8 00 FA A8 00 2E A9 00 2F A9 00 5F'\r\n 'A9 00 5F A9 00 C1 A9 00 CD A9 00 DE A9 00 DF A9 00 5C AA 00 5F AA 00 DE AA 00 DF AA 00 EB AB 00'\r\n 'EB AB 00 10 FE 00 16 FE 00 19 FE 00 19 FE 00 30 FE 00 30 FE 00 45 FE 00 46 FE 00 49 FE 00 4C FE'\r\n '00 50 FE 00 52 FE 00 54 FE 00 57 FE 00 5F FE 00 61 FE 00 68 FE 00 68 FE 00 6A FE 00 6B FE 00 01'\r\n 'FF 00 03 FF 00 05 FF 00 07 FF 00 0A FF 00 0A FF 00 0C FF 00 0C FF 00 0E FF 00 0F FF 00 1A FF 00'\r\n '1B FF 00 1F FF 00 20 FF 00 3C FF 00 3C FF 00 61 FF 00 61 FF 00 64 FF 00 65 FF 00 00 01 01 01 01'\r\n '01 9F 03 01 9F 03 01 D0 03 01 D0 03 01 57 08 01 57 08 01 1F 09 01 1F 09 01 3F 09 01 3F 09 01 50'\r\n '0A 01 58 0A 01 7F 0A 01 7F 0A 01 39 0B 01 3F 0B 01 47 10 01 4D 10 01 BB 10 01 BC 10 01 BE 10 01'\r\n 'C1 10 01 70 24 01 73 24 01 1A 42 00 00 00 2B 00 00 2B 00 00 3C 00 00 3E 00 00 7C 00 00 7C 00 00'\r\n '7E 00 00 7E 00 00 AC 00 00 AC 00 00 B1 00 00 B1 00 00 D7 00 00 D7 00 00 F7 00 00 F7 00 00 F6 03'\r\n '00 F6 03 00 06 06 00 08 06 00 44 20 00 44 20 00 52 20 00 52 20 00 7A 20 00 7C 20 00 8A 20 00 8C'\r\n '20 00 18 21 00 18 21 00 40 21 00 44 21 00 4B 21 00 4B 21 00 90 21 00 94 21 00 9A 21 00 9B 21 00'\r\n 'A0 21 00 A0 21 00 A3 21 00 A3 21 00 A6 21 00 A6 21 00 AE 21 00 AE 21 00 CE 21 00 CF 21 00 D2 21'\r\n '00 D2 21 00 D4 21 00 D4 21 00 F4 21 00 FF 22 00 08 23 00 0B 23 00 20 23 00 21 23 00 7C 23 00 7C'\r\n '23 00 9B 23 00 B3 23 00 DC 23 00 E1 23 00 B7 25 00 B7 25 00 C1 25 00 C1 25 00 F8 25 00 FF 25 00'\r\n '6F 26 00 6F 26 00 C0 27 00 C4 27 00 C7 27 00 CA 27 00 CC 27 00 CC 27 00 CE 27 00 E5 27 00 F0 27'\r\n '00 FF 27 00 00 29 00 82 29 00 99 29 00 D7 29 00 DC 29 00 FB 29 00 FE 29 00 FF 2A 00 30 2B 00 44'\r\n '2B 00 47 2B 00 4C 2B 00 29 FB 00 29 FB 00 62 FE 00 62 FE 00 64 FE 00 66 FE 00 0B FF 00 0B FF 00'\r\n '1C FF 00 1E FF 00 5C FF 00 5C FF 00 5E FF 00 5E FF 00 E2 FF 00 E2 FF 00 E9 FF 00 EC FF 00 C1 D6'\r\n '01 C1 D6 01 DB D6 01 DB D6 01 FB D6 01 FB D6 01 15 D7 01 15 D7 01 35 D7 01 35 D7 01 4F D7 01 4F'\r\n 'D7 01 6F D7 01 6F D7 01 89 D7 01 89 D7 01 A9 D7 01 A9 D7 01 C3 D7 01 C3 D7 01 1B 10 00 00 00 24'\r\n '00 00 24 00 00 A2 00 00 A5 00 00 0B 06 00 0B 06 00 F2 09 00 F3 09 00 FB 09 00 FB 09 00 F1 0A 00'\r\n 'F1 0A 00 F9 0B 00 F9 0B 00 3F 0E 00 3F 0E 00 DB 17 00 DB 17 00 A0 20 00 B9 20 00 38 A8 00 38 A8'\r\n '00 FC FD 00 FC FD 00 69 FE 00 69 FE 00 04 FF 00 04 FF 00 E0 FF 00 E1 FF 00 E5 FF 00 E6 FF 00 1C'\r\n '1B 00 00 00 5E 00 00 5E 00 00 60 00 00 60 00 00 A8 00 00 A8 00 00 AF 00 00 AF 00 00 B4 00 00 B4'\r\n '00 00 B8 00 00 B8 00 00 C2 02 00 C5 02 00 D2 02 00 DF 02 00 E5 02 00 EB 02 00 ED 02 00 ED 02 00'\r\n 'EF 02 00 FF 02 00 75 03 00 75 03 00 84 03 00 85 03 00 BD 1F 00 BD 1F 00 BF 1F 00 C1 1F 00 CD 1F'\r\n '00 CF 1F 00 DD 1F 00 DF 1F 00 ED 1F 00 EF 1F 00 FD 1F 00 FE 1F 00 9B 30 00 9C 30 00 00 A7 00 16'\r\n 'A7 00 20 A7 00 21 A7 00 89 A7 00 8A A7 00 B2 FB 00 C1 FB 00 3E FF 00 3E FF 00 40 FF 00 40 FF 00'\r\n 'E3 FF 00 E3 FF 00 1D A4 00 00 00 A6 00 00 A7 00 00 A9 00 00 A9 00 00 AE 00 00 AE 00 00 B0 00 00'\r\n 'B0 00 00 B6 00 00 B6 00 00 82 04 00 82 04 00 0E 06 00 0F 06 00 DE 06 00 DE 06 00 E9 06 00 E9 06'\r\n '00 FD 06 00 FE 06 00 F6 07 00 F6 07 00 FA 09 00 FA 09 00 70 0B 00 70 0B 00 F3 0B 00 F8 0B 00 FA'\r\n '0B 00 FA 0B 00 7F 0C 00 7F 0C 00 79 0D 00 79 0D 00 01 0F 00 03 0F 00 13 0F 00 17 0F 00 1A 0F 00'\r\n '1F 0F 00 34 0F 00 34 0F 00 36 0F 00 36 0F 00 38 0F 00 38 0F 00 BE 0F 00 C5 0F 00 C7 0F 00 CC 0F'\r\n '00 CE 0F 00 CF 0F 00 D5 0F 00 D8 0F 00 9E 10 00 9F 10 00 60 13 00 60 13 00 90 13 00 99 13 00 40'\r\n '19 00 40 19 00 DE 19 00 FF 19 00 61 1B 00 6A 1B 00 74 1B 00 7C 1B 00 00 21 00 01 21 00 03 21 00'\r\n '06 21 00 08 21 00 09 21 00 14 21 00 14 21 00 16 21 00 17 21 00 1E 21 00 23 21 00 25 21 00 25 21'\r\n '00 27 21 00 27 21 00 29 21 00 29 21 00 2E 21 00 2E 21 00 3A 21 00 3B 21 00 4A 21 00 4A 21 00 4C'\r\n '21 00 4D 21 00 4F 21 00 4F 21 00 95 21 00 99 21 00 9C 21 00 9F 21 00 A1 21 00 A2 21 00 A4 21 00'\r\n 'A5 21 00 A7 21 00 AD 21 00 AF 21 00 CD 21 00 D0 21 00 D1 21 00 D3 21 00 D3 21 00 D5 21 00 F3 21'\r\n '00 00 23 00 07 23 00 0C 23 00 1F 23 00 22 23 00 28 23 00 2B 23 00 7B 23 00 7D 23 00 9A 23 00 B4'\r\n '23 00 DB 23 00 E2 23 00 F3 23 00 00 24 00 26 24 00 40 24 00 4A 24 00 9C 24 00 E9 24 00 00 25 00'\r\n 'B6 25 00 B8 25 00 C0 25 00 C2 25 00 F7 25 00 00 26 00 6E 26 00 70 26 00 FF 26 00 01 27 00 67 27'\r\n '00 94 27 00 BF 27 00 00 28 00 FF 28 00 00 2B 00 2F 2B 00 45 2B 00 46 2B 00 50 2B 00 59 2B 00 E5'\r\n '2C 00 EA 2C 00 80 2E 00 99 2E 00 9B 2E 00 F3 2E 00 00 2F 00 D5 2F 00 F0 2F 00 FB 2F 00 04 30 00'\r\n '04 30 00 12 30 00 13 30 00 20 30 00 20 30 00 36 30 00 37 30 00 3E 30 00 3F 30 00 90 31 00 91 31'\r\n '00 96 31 00 9F 31 00 C0 31 00 E3 31 00 00 32 00 1E 32 00 2A 32 00 50 32 00 60 32 00 7F 32 00 8A'\r\n '32 00 B0 32 00 C0 32 00 FE 32 00 00 33 00 FF 33 00 C0 4D 00 FF 4D 00 90 A4 00 C6 A4 00 28 A8 00'\r\n '2B A8 00 36 A8 00 37 A8 00 39 A8 00 39 A8 00 77 AA 00 79 AA 00 FD FD 00 FD FD 00 E4 FF 00 E4 FF'\r\n '00 E8 FF 00 E8 FF 00 ED FF 00 EE FF 00 FC FF 00 FD FF 00 02 01 01 02 01 01 37 01 01 3F 01 01 79'\r\n '01 01 89 01 01 90 01 01 9B 01 01 D0 01 01 FC 01 01 00 D0 01 F5 D0 01 00 D1 01 26 D1 01 29 D1 01'\r\n '64 D1 01 6A D1 01 6C D1 01 83 D1 01 84 D1 01 8C D1 01 A9 D1 01 AE D1 01 DD D1 01 00 D2 01 41 D2'\r\n '01 45 D2 01 45 D2 01 00 D3 01 56 D3 01 00 F0 01 2B F0 01 30 F0 01 93 F0 01 A0 F0 01 AE F0 01 B1'\r\n 'F0 01 BE F0 01 C1 F0 01 CF F0 01 D1 F0 01 DF F0 01 10 F1 01 2E F1 01 30 F1 01 69 F1 01 70 F1 01'\r\n '9A F1 01 E6 F1 01 02 F2 01 10 F2 01 3A F2 01 40 F2 01 48 F2 01 50 F2 01 51 F2 01 00 F3 01 20 F3'\r\n '01 30 F3 01 35 F3 01 37 F3 01 7C F3 01 80 F3 01 93 F3 01 A0 F3 01 C4 F3 01 C6 F3 01 CA F3 01 E0'\r\n 'F3 01 F0 F3 01 00 F4 01 3E F4 01 40 F4 01 40 F4 01 42 F4 01 F7 F4 01 F9 F4 01 FC F4 01 00 F5 01'\r\n '3D F5 01 50 F5 01 67 F5 01 FB F5 01 FF F5 01 01 F6 01 10 F6 01 12 F6 01 14 F6 01 16 F6 01 16 F6'\r\n '01 18 F6 01 18 F6 01 1A F6 01 1A F6 01 1C F6 01 1E F6 01 20 F6 01 25 F6 01 28 F6 01 2B F6 01 2D'\r\n 'F6 01 2D F6 01 30 F6 01 33 F6 01 35 F6 01 40 F6 01 45 F6 01 4F F6 01 80 F6 01 C5 F6 01 00 F7 01'\r\n '73 F7 01 1E 08 02 00 00 41 00 00 5A 00 00 61 00 00 7A 00 00 AA 00 00 AA 00 00 B5 00 00 B5 00 00'\r\n 'BA 00 00 BA 00 00 C0 00 00 D6 00 00 D8 00 00 F6 00 00 F8 00 00 B8 02 00 BB 02 00 C1 02 00 D0 02'\r\n '00 D1 02 00 E0 02 00 E4 02 00 EE 02 00 EE 02 00 70 03 00 73 03 00 76 03 00 77 03 00 7A 03 00 7D'\r\n '03 00 86 03 00 86 03 00 88 03 00 8A 03 00 8C 03 00 8C 03 00 8E 03 00 A1 03 00 A3 03 00 F5 03 00'\r\n 'F7 03 00 82 04 00 8A 04 00 27 05 00 31 05 00 56 05 00 59 05 00 5F 05 00 61 05 00 87 05 00 89 05'\r\n '00 89 05 00 03 09 00 39 09 00 3B 09 00 3B 09 00 3D 09 00 40 09 00 49 09 00 4C 09 00 4E 09 00 50'\r\n '09 00 58 09 00 61 09 00 64 09 00 77 09 00 79 09 00 7F 09 00 82 09 00 83 09 00 85 09 00 8C 09 00'\r\n '8F 09 00 90 09 00 93 09 00 A8 09 00 AA 09 00 B0 09 00 B2 09 00 B2 09 00 B6 09 00 B9 09 00 BD 09'\r\n '00 C0 09 00 C7 09 00 C8 09 00 CB 09 00 CC 09 00 CE 09 00 CE 09 00 D7 09 00 D7 09 00 DC 09 00 DD'\r\n '09 00 DF 09 00 E1 09 00 E6 09 00 F1 09 00 F4 09 00 FA 09 00 03 0A 00 03 0A 00 05 0A 00 0A 0A 00'\r\n '0F 0A 00 10 0A 00 13 0A 00 28 0A 00 2A 0A 00 30 0A 00 32 0A 00 33 0A 00 35 0A 00 36 0A 00 38 0A'\r\n '00 39 0A 00 3E 0A 00 40 0A 00 59 0A 00 5C 0A 00 5E 0A 00 5E 0A 00 66 0A 00 6F 0A 00 72 0A 00 74'\r\n '0A 00 83 0A 00 83 0A 00 85 0A 00 8D 0A 00 8F 0A 00 91 0A 00 93 0A 00 A8 0A 00 AA 0A 00 B0 0A 00'\r\n 'B2 0A 00 B3 0A 00 B5 0A 00 B9 0A 00 BD 0A 00 C0 0A 00 C9 0A 00 C9 0A 00 CB 0A 00 CC 0A 00 D0 0A'\r\n '00 D0 0A 00 E0 0A 00 E1 0A 00 E6 0A 00 EF 0A 00 02 0B 00 03 0B 00 05 0B 00 0C 0B 00 0F 0B 00 10'\r\n '0B 00 13 0B 00 28 0B 00 2A 0B 00 30 0B 00 32 0B 00 33 0B 00 35 0B 00 39 0B 00 3D 0B 00 3E 0B 00'\r\n '40 0B 00 40 0B 00 47 0B 00 48 0B 00 4B 0B 00 4C 0B 00 57 0B 00 57 0B 00 5C 0B 00 5D 0B 00 5F 0B'\r\n '00 61 0B 00 66 0B 00 77 0B 00 83 0B 00 83 0B 00 85 0B 00 8A 0B 00 8E 0B 00 90 0B 00 92 0B 00 95'\r\n '0B 00 99 0B 00 9A 0B 00 9C 0B 00 9C 0B 00 9E 0B 00 9F 0B 00 A3 0B 00 A4 0B 00 A8 0B 00 AA 0B 00'\r\n 'AE 0B 00 B9 0B 00 BE 0B 00 BF 0B 00 C1 0B 00 C2 0B 00 C6 0B 00 C8 0B 00 CA 0B 00 CC 0B 00 D0 0B'\r\n '00 D0 0B 00 D7 0B 00 D7 0B 00 E6 0B 00 F2 0B 00 01 0C 00 03 0C 00 05 0C 00 0C 0C 00 0E 0C 00 10'\r\n '0C 00 12 0C 00 28 0C 00 2A 0C 00 33 0C 00 35 0C 00 39 0C 00 3D 0C 00 3D 0C 00 41 0C 00 44 0C 00'\r\n '58 0C 00 59 0C 00 60 0C 00 61 0C 00 66 0C 00 6F 0C 00 7F 0C 00 7F 0C 00 82 0C 00 83 0C 00 85 0C'\r\n '00 8C 0C 00 8E 0C 00 90 0C 00 92 0C 00 A8 0C 00 AA 0C 00 B3 0C 00 B5 0C 00 B9 0C 00 BD 0C 00 C4'\r\n '0C 00 C6 0C 00 C8 0C 00 CA 0C 00 CB 0C 00 D5 0C 00 D6 0C 00 DE 0C 00 DE 0C 00 E0 0C 00 E1 0C 00'\r\n 'E6 0C 00 EF 0C 00 F1 0C 00 F2 0C 00 02 0D 00 03 0D 00 05 0D 00 0C 0D 00 0E 0D 00 10 0D 00 12 0D'\r\n '00 3A 0D 00 3D 0D 00 40 0D 00 46 0D 00 48 0D 00 4A 0D 00 4C 0D 00 4E 0D 00 4E 0D 00 57 0D 00 57'\r\n '0D 00 60 0D 00 61 0D 00 66 0D 00 75 0D 00 79 0D 00 7F 0D 00 82 0D 00 83 0D 00 85 0D 00 96 0D 00'\r\n '9A 0D 00 B1 0D 00 B3 0D 00 BB 0D 00 BD 0D 00 BD 0D 00 C0 0D 00 C6 0D 00 CF 0D 00 D1 0D 00 D8 0D'\r\n '00 DF 0D 00 F2 0D 00 F4 0D 00 01 0E 00 30 0E 00 32 0E 00 33 0E 00 40 0E 00 46 0E 00 4F 0E 00 5B'\r\n '0E 00 81 0E 00 82 0E 00 84 0E 00 84 0E 00 87 0E 00 88 0E 00 8A 0E 00 8A 0E 00 8D 0E 00 8D 0E 00'\r\n '94 0E 00 97 0E 00 99 0E 00 9F 0E 00 A1 0E 00 A3 0E 00 A5 0E 00 A5 0E 00 A7 0E 00 A7 0E 00 AA 0E'\r\n '00 AB 0E 00 AD 0E 00 B0 0E 00 B2 0E 00 B3 0E 00 BD 0E 00 BD 0E 00 C0 0E 00 C4 0E 00 C6 0E 00 C6'\r\n '0E 00 D0 0E 00 D9 0E 00 DC 0E 00 DD 0E 00 00 0F 00 17 0F 00 1A 0F 00 34 0F 00 36 0F 00 36 0F 00'\r\n '38 0F 00 38 0F 00 3E 0F 00 47 0F 00 49 0F 00 6C 0F 00 7F 0F 00 7F 0F 00 85 0F 00 85 0F 00 88 0F'\r\n '00 8C 0F 00 BE 0F 00 C5 0F 00 C7 0F 00 CC 0F 00 CE 0F 00 DA 0F 00 00 10 00 2C 10 00 31 10 00 31'\r\n '10 00 38 10 00 38 10 00 3B 10 00 3C 10 00 3F 10 00 57 10 00 5A 10 00 5D 10 00 61 10 00 70 10 00'\r\n '75 10 00 81 10 00 83 10 00 84 10 00 87 10 00 8C 10 00 8E 10 00 9C 10 00 9E 10 00 C5 10 00 D0 10'\r\n '00 FC 10 00 00 11 00 48 12 00 4A 12 00 4D 12 00 50 12 00 56 12 00 58 12 00 58 12 00 5A 12 00 5D'\r\n '12 00 60 12 00 88 12 00 8A 12 00 8D 12 00 90 12 00 B0 12 00 B2 12 00 B5 12 00 B8 12 00 BE 12 00'\r\n 'C0 12 00 C0 12 00 C2 12 00 C5 12 00 C8 12 00 D6 12 00 D8 12 00 10 13 00 12 13 00 15 13 00 18 13'\r\n '00 5A 13 00 60 13 00 7C 13 00 80 13 00 8F 13 00 A0 13 00 F4 13 00 01 14 00 7F 16 00 81 16 00 9A'\r\n '16 00 A0 16 00 F0 16 00 00 17 00 0C 17 00 0E 17 00 11 17 00 20 17 00 31 17 00 35 17 00 36 17 00'\r\n '40 17 00 51 17 00 60 17 00 6C 17 00 6E 17 00 70 17 00 80 17 00 B6 17 00 BE 17 00 C5 17 00 C7 17'\r\n '00 C8 17 00 D4 17 00 DA 17 00 DC 17 00 DC 17 00 E0 17 00 E9 17 00 10 18 00 19 18 00 20 18 00 77'\r\n '18 00 80 18 00 A8 18 00 AA 18 00 AA 18 00 B0 18 00 F5 18 00 00 19 00 1C 19 00 23 19 00 26 19 00'\r\n '29 19 00 2B 19 00 30 19 00 31 19 00 33 19 00 38 19 00 46 19 00 6D 19 00 70 19 00 74 19 00 80 19'\r\n '00 AB 19 00 B0 19 00 C9 19 00 D0 19 00 DA 19 00 00 1A 00 16 1A 00 19 1A 00 1B 1A 00 1E 1A 00 55'\r\n '1A 00 57 1A 00 57 1A 00 61 1A 00 61 1A 00 63 1A 00 64 1A 00 6D 1A 00 72 1A 00 80 1A 00 89 1A 00'\r\n '90 1A 00 99 1A 00 A0 1A 00 AD 1A 00 04 1B 00 33 1B 00 35 1B 00 35 1B 00 3B 1B 00 3B 1B 00 3D 1B'\r\n '00 41 1B 00 43 1B 00 4B 1B 00 50 1B 00 6A 1B 00 74 1B 00 7C 1B 00 82 1B 00 A1 1B 00 A6 1B 00 A7'\r\n '1B 00 AA 1B 00 AA 1B 00 AE 1B 00 B9 1B 00 C0 1B 00 E5 1B 00 E7 1B 00 E7 1B 00 EA 1B 00 EC 1B 00'\r\n 'EE 1B 00 EE 1B 00 F2 1B 00 F3 1B 00 FC 1B 00 2B 1C 00 34 1C 00 35 1C 00 3B 1C 00 49 1C 00 4D 1C'\r\n '00 7F 1C 00 D3 1C 00 D3 1C 00 E1 1C 00 E1 1C 00 E9 1C 00 EC 1C 00 EE 1C 00 F2 1C 00 00 1D 00 BF'\r\n '1D 00 00 1E 00 15 1F 00 18 1F 00 1D 1F 00 20 1F 00 45 1F 00 48 1F 00 4D 1F 00 50 1F 00 57 1F 00'\r\n '59 1F 00 59 1F 00 5B 1F 00 5B 1F 00 5D 1F 00 5D 1F 00 5F 1F 00 7D 1F 00 80 1F 00 B4 1F 00 B6 1F'\r\n '00 BC 1F 00 BE 1F 00 BE 1F 00 C2 1F 00 C4 1F 00 C6 1F 00 CC 1F 00 D0 1F 00 D3 1F 00 D6 1F 00 DB'\r\n '1F 00 E0 1F 00 EC 1F 00 F2 1F 00 F4 1F 00 F6 1F 00 FC 1F 00 0E 20 00 0E 20 00 71 20 00 71 20 00'\r\n '7F 20 00 7F 20 00 90 20 00 9C 20 00 02 21 00 02 21 00 07 21 00 07 21 00 0A 21 00 13 21 00 15 21'\r\n '00 15 21 00 19 21 00 1D 21 00 24 21 00 24 21 00 26 21 00 26 21 00 28 21 00 28 21 00 2A 21 00 2D'\r\n '21 00 2F 21 00 39 21 00 3C 21 00 3F 21 00 45 21 00 49 21 00 4E 21 00 4F 21 00 60 21 00 88 21 00'\r\n '36 23 00 7A 23 00 95 23 00 95 23 00 9C 24 00 E9 24 00 AC 26 00 AC 26 00 00 28 00 FF 28 00 00 2C'\r\n '00 2E 2C 00 30 2C 00 5E 2C 00 60 2C 00 E4 2C 00 EB 2C 00 EE 2C 00 00 2D 00 25 2D 00 30 2D 00 65'\r\n '2D 00 6F 2D 00 70 2D 00 80 2D 00 96 2D 00 A0 2D 00 A6 2D 00 A8 2D 00 AE 2D 00 B0 2D 00 B6 2D 00'\r\n 'B8 2D 00 BE 2D 00 C0 2D 00 C6 2D 00 C8 2D 00 CE 2D 00 D0 2D 00 D6 2D 00 D8 2D 00 DE 2D 00 05 30'\r\n '00 07 30 00 21 30 00 29 30 00 31 30 00 35 30 00 38 30 00 3C 30 00 41 30 00 96 30 00 9D 30 00 9F'\r\n '30 00 A1 30 00 FA 30 00 FC 30 00 FF 30 00 05 31 00 2D 31 00 31 31 00 8E 31 00 90 31 00 BA 31 00'\r\n 'F0 31 00 1C 32 00 20 32 00 4F 32 00 60 32 00 7B 32 00 7F 32 00 B0 32 00 C0 32 00 CB 32 00 D0 32'\r\n '00 FE 32 00 00 33 00 76 33 00 7B 33 00 DD 33 00 E0 33 00 FE 33 00 00 34 00 B5 4D 00 00 4E 00 CB'\r\n '9F 00 00 A0 00 8C A4 00 D0 A4 00 0C A6 00 10 A6 00 2B A6 00 40 A6 00 6E A6 00 80 A6 00 97 A6 00'\r\n 'A0 A6 00 EF A6 00 F2 A6 00 F7 A6 00 22 A7 00 87 A7 00 89 A7 00 8E A7 00 90 A7 00 91 A7 00 A0 A7'\r\n '00 A9 A7 00 FA A7 00 01 A8 00 03 A8 00 05 A8 00 07 A8 00 0A A8 00 0C A8 00 24 A8 00 27 A8 00 27'\r\n 'A8 00 30 A8 00 37 A8 00 40 A8 00 73 A8 00 80 A8 00 C3 A8 00 CE A8 00 D9 A8 00 F2 A8 00 FB A8 00'\r\n '00 A9 00 25 A9 00 2E A9 00 46 A9 00 52 A9 00 53 A9 00 5F A9 00 7C A9 00 83 A9 00 B2 A9 00 B4 A9'\r\n '00 B5 A9 00 BA A9 00 BB A9 00 BD A9 00 CD A9 00 CF A9 00 D9 A9 00 DE A9 00 DF A9 00 00 AA 00 28'\r\n 'AA 00 2F AA 00 30 AA 00 33 AA 00 34 AA 00 40 AA 00 42 AA 00 44 AA 00 4B AA 00 4D AA 00 4D AA 00'\r\n '50 AA 00 59 AA 00 5C AA 00 7B AA 00 80 AA 00 AF AA 00 B1 AA 00 B1 AA 00 B5 AA 00 B6 AA 00 B9 AA'\r\n '00 BD AA 00 C0 AA 00 C0 AA 00 C2 AA 00 C2 AA 00 DB AA 00 DF AA 00 01 AB 00 06 AB 00 09 AB 00 0E'\r\n 'AB 00 11 AB 00 16 AB 00 20 AB 00 26 AB 00 28 AB 00 2E AB 00 C0 AB 00 E4 AB 00 E6 AB 00 E7 AB 00'\r\n 'E9 AB 00 EC AB 00 F0 AB 00 F9 AB 00 00 AC 00 A3 D7 00 B0 D7 00 C6 D7 00 CB D7 00 FB D7 00 00 D8'\r\n '00 2D FA 00 30 FA 00 6D FA 00 70 FA 00 D9 FA 00 00 FB 00 06 FB 00 13 FB 00 17 FB 00 21 FF 00 3A'\r\n 'FF 00 41 FF 00 5A FF 00 66 FF 00 BE FF 00 C2 FF 00 C7 FF 00 CA FF 00 CF FF 00 D2 FF 00 D7 FF 00'\r\n 'DA FF 00 DC FF 00 00 00 01 0B 00 01 0D 00 01 26 00 01 28 00 01 3A 00 01 3C 00 01 3D 00 01 3F 00'\r\n '01 4D 00 01 50 00 01 5D 00 01 80 00 01 FA 00 01 00 01 01 00 01 01 02 01 01 02 01 01 07 01 01 33'\r\n '01 01 37 01 01 3F 01 01 D0 01 01 FC 01 01 80 02 01 9C 02 01 A0 02 01 D0 02 01 00 03 01 1E 03 01'\r\n '20 03 01 23 03 01 30 03 01 4A 03 01 80 03 01 9D 03 01 9F 03 01 C3 03 01 C8 03 01 D5 03 01 00 04'\r\n '01 9D 04 01 A0 04 01 A9 04 01 00 10 01 00 10 01 02 10 01 37 10 01 47 10 01 4D 10 01 66 10 01 6F'\r\n '10 01 82 10 01 B2 10 01 B7 10 01 B8 10 01 BB 10 01 C1 10 01 00 20 01 6E 23 01 00 24 01 62 24 01'\r\n '70 24 01 73 24 01 00 30 01 2E 34 01 00 68 01 38 6A 01 00 B0 01 01 B0 01 00 D0 01 F5 D0 01 00 D1'\r\n '01 26 D1 01 29 D1 01 66 D1 01 6A D1 01 72 D1 01 83 D1 01 84 D1 01 8C D1 01 A9 D1 01 AE D1 01 DD'\r\n 'D1 01 60 D3 01 71 D3 01 00 D4 01 54 D4 01 56 D4 01 9C D4 01 9E D4 01 9F D4 01 A2 D4 01 A2 D4 01'\r\n 'A5 D4 01 A6 D4 01 A9 D4 01 AC D4 01 AE D4 01 B9 D4 01 BB D4 01 BB D4 01 BD D4 01 C3 D4 01 C5 D4'\r\n '01 05 D5 01 07 D5 01 0A D5 01 0D D5 01 14 D5 01 16 D5 01 1C D5 01 1E D5 01 39 D5 01 3B D5 01 3E'\r\n 'D5 01 40 D5 01 44 D5 01 46 D5 01 46 D5 01 4A D5 01 50 D5 01 52 D5 01 A5 D6 01 A8 D6 01 DA D6 01'\r\n 'DC D6 01 14 D7 01 16 D7 01 4E D7 01 50 D7 01 88 D7 01 8A D7 01 C2 D7 01 C4 D7 01 CB D7 01 10 F1'\r\n '01 2E F1 01 30 F1 01 69 F1 01 70 F1 01 9A F1 01 E6 F1 01 02 F2 01 10 F2 01 3A F2 01 40 F2 01 48'\r\n 'F2 01 50 F2 01 51 F2 01 8C F4 01 8C F4 01 24 F5 01 24 F5 01 00 00 02 D6 A6 02 00 A7 02 34 B7 02'\r\n '40 B7 02 1D B8 02 00 F8 02 1D FA 02 00 00 0F FD FF 0F 00 00 10 FD FF 10 1F 01 00 00 00 2A 20 00'\r\n '2A 20 00 20 01 00 00 00 2D 20 00 2D 20 00 21 2F 00 00 00 BE 05 00 BE 05 00 C0 05 00 C0 05 00 C3'\r\n '05 00 C3 05 00 C6 05 00 C6 05 00 D0 05 00 EA 05 00 F0 05 00 F4 05 00 C0 07 00 EA 07 00 F4 07 00'\r\n 'F5 07 00 FA 07 00 FA 07 00 00 08 00 15 08 00 1A 08 00 1A 08 00 24 08 00 24 08 00 28 08 00 28 08'\r\n '00 30 08 00 3E 08 00 40 08 00 58 08 00 5E 08 00 5E 08 00 0F 20 00 0F 20 00 1D FB 00 1D FB 00 1F'\r\n 'FB 00 28 FB 00 2A FB 00 36 FB 00 38 FB 00 3C FB 00 3E FB 00 3E FB 00 40 FB 00 41 FB 00 43 FB 00'\r\n '44 FB 00 46 FB 00 4F FB 00 00 08 01 05 08 01 08 08 01 08 08 01 0A 08 01 35 08 01 37 08 01 38 08'\r\n '01 3C 08 01 3C 08 01 3F 08 01 55 08 01 57 08 01 5F 08 01 00 09 01 1B 09 01 20 09 01 39 09 01 3F'\r\n '09 01 3F 09 01 00 0A 01 00 0A 01 10 0A 01 13 0A 01 15 0A 01 17 0A 01 19 0A 01 33 0A 01 40 0A 01'\r\n '47 0A 01 50 0A 01 58 0A 01 60 0A 01 7F 0A 01 00 0B 01 35 0B 01 40 0B 01 55 0B 01 58 0B 01 72 0B'\r\n '01 78 0B 01 7F 0B 01 00 0C 01 48 0C 01 22 15 00 00 00 08 06 00 08 06 00 0B 06 00 0B 06 00 0D 06'\r\n '00 0D 06 00 1B 06 00 1B 06 00 1E 06 00 4A 06 00 6D 06 00 6F 06 00 71 06 00 D5 06 00 E5 06 00 E6'\r\n '06 00 EE 06 00 EF 06 00 FA 06 00 0D 07 00 10 07 00 10 07 00 12 07 00 2F 07 00 4D 07 00 A5 07 00'\r\n 'B1 07 00 B1 07 00 50 FB 00 C1 FB 00 D3 FB 00 3D FD 00 50 FD 00 8F FD 00 92 FD 00 C7 FD 00 F0 FD'\r\n '00 FC FD 00 70 FE 00 74 FE 00 76 FE 00 FC FE 00 23 01 00 00 00 2B 20 00 2B 20 00 24 01 00 00 00'\r\n '2E 20 00 2E 20 00 25 01 00 00 00 2C 20 00 2C 20 00 26 0B 00 00 00 30 00 00 39 00 00 B2 00 00 B3'\r\n '00 00 B9 00 00 B9 00 00 F0 06 00 F9 06 00 70 20 00 70 20 00 74 20 00 79 20 00 80 20 00 89 20 00'\r\n '88 24 00 9B 24 00 10 FF 00 19 FF 00 CE D7 01 FF D7 01 00 F1 01 0A F1 01 27 09 00 00 00 2B 00 00'\r\n '2B 00 00 2D 00 00 2D 00 00 7A 20 00 7B 20 00 8A 20 00 8B 20 00 12 22 00 12 22 00 29 FB 00 29 FB'\r\n '00 62 FE 00 63 FE 00 0B FF 00 0B FF 00 0D FF 00 0D FF 00 28 15 00 00 00 23 00 00 25 00 00 A2 00'\r\n '00 A5 00 00 B0 00 00 B1 00 00 09 06 00 0A 06 00 6A 06 00 6A 06 00 F2 09 00 F3 09 00 FB 09 00 FB'\r\n '09 00 F1 0A 00 F1 0A 00 F9 0B 00 F9 0B 00 3F 0E 00 3F 0E 00 DB 17 00 DB 17 00 30 20 00 34 20 00'\r\n 'A0 20 00 B9 20 00 2E 21 00 2E 21 00 13 22 00 13 22 00 38 A8 00 39 A8 00 5F FE 00 5F FE 00 69 FE'\r\n '00 6A FE 00 03 FF 00 05 FF 00 E0 FF 00 E1 FF 00 E5 FF 00 E6 FF 00 29 06 00 00 00 00 06 00 03 06'\r\n '00 60 06 00 69 06 00 6B 06 00 6C 06 00 DD 06 00 DD 06 00 0F 07 00 0F 07 00 60 0E 01 7E 0E 01 2A'\r\n '0D 00 00 00 2C 00 00 2C 00 00 2E 00 00 2F 00 00 3A 00 00 3A 00 00 A0 00 00 A0 00 00 0C 06 00 0C'\r\n '06 00 2F 20 00 2F 20 00 44 20 00 44 20 00 50 FE 00 50 FE 00 52 FE 00 52 FE 00 55 FE 00 55 FE 00'\r\n '0C FF 00 0C FF 00 0E FF 00 0F FF 00 1A FF 00 1A FF 00 2B 0C 00 00 00 00 00 00 08 00 00 0E 00 00'\r\n '1B 00 00 7F 00 00 84 00 00 86 00 00 9F 00 00 AD 00 00 AD 00 00 0B 20 00 0D 20 00 60 20 00 64 20'\r\n '00 6A 20 00 6F 20 00 FF FE 00 FF FE 00 73 D1 01 7A D1 01 01 00 0E 01 00 0E 20 00 0E 7F 00 0E 2C'\r\n '03 00 00 00 09 00 00 09 00 00 0B 00 00 0B 00 00 1F 00 00 1F 00 00 2D 0B 00 00 00 09 00 00 0D 00'\r\n '00 20 00 00 20 00 00 85 00 00 85 00 00 A0 00 00 A0 00 00 80 16 00 80 16 00 0E 18 00 0E 18 00 00'\r\n '20 00 0A 20 00 28 20 00 29 20 00 2F 20 00 2F 20 00 5F 20 00 5F 20 00 00 30 00 00 30 00 2E B7 00'\r\n '00 00 21 00 00 22 00 00 26 00 00 2A 00 00 3B 00 00 40 00 00 5B 00 00 60 00 00 7B 00 00 7E 00 00'\r\n 'A1 00 00 A1 00 00 A6 00 00 A9 00 00 AB 00 00 AC 00 00 AE 00 00 AF 00 00 B4 00 00 B4 00 00 B6 00'\r\n '00 B8 00 00 BB 00 00 BF 00 00 D7 00 00 D7 00 00 F7 00 00 F7 00 00 B9 02 00 BA 02 00 C2 02 00 CF'\r\n '02 00 D2 02 00 DF 02 00 E5 02 00 ED 02 00 EF 02 00 FF 02 00 74 03 00 75 03 00 7E 03 00 7E 03 00'\r\n '84 03 00 85 03 00 87 03 00 87 03 00 F6 03 00 F6 03 00 8A 05 00 8A 05 00 06 06 00 07 06 00 0E 06'\r\n '00 0F 06 00 DE 06 00 DE 06 00 E9 06 00 E9 06 00 F6 07 00 F9 07 00 F3 0B 00 F8 0B 00 FA 0B 00 FA'\r\n '0B 00 78 0C 00 7E 0C 00 3A 0F 00 3D 0F 00 90 13 00 99 13 00 00 14 00 00 14 00 9B 16 00 9C 16 00'\r\n 'F0 17 00 F9 17 00 00 18 00 0A 18 00 40 19 00 40 19 00 44 19 00 45 19 00 DE 19 00 FF 19 00 BD 1F'\r\n '00 BD 1F 00 BF 1F 00 C1 1F 00 CD 1F 00 CF 1F 00 DD 1F 00 DF 1F 00 ED 1F 00 EF 1F 00 FD 1F 00 FE'\r\n '1F 00 10 20 00 27 20 00 35 20 00 43 20 00 45 20 00 5E 20 00 7C 20 00 7E 20 00 8C 20 00 8E 20 00'\r\n '00 21 00 01 21 00 03 21 00 06 21 00 08 21 00 09 21 00 14 21 00 14 21 00 16 21 00 18 21 00 1E 21'\r\n '00 23 21 00 25 21 00 25 21 00 27 21 00 27 21 00 29 21 00 29 21 00 3A 21 00 3B 21 00 40 21 00 44'\r\n '21 00 4A 21 00 4D 21 00 50 21 00 5F 21 00 89 21 00 89 21 00 90 21 00 11 22 00 14 22 00 35 23 00'\r\n '7B 23 00 94 23 00 96 23 00 F3 23 00 00 24 00 26 24 00 40 24 00 4A 24 00 60 24 00 87 24 00 EA 24'\r\n '00 AB 26 00 AD 26 00 FF 26 00 01 27 00 CA 27 00 CC 27 00 CC 27 00 CE 27 00 FF 27 00 00 29 00 4C'\r\n '2B 00 50 2B 00 59 2B 00 E5 2C 00 EA 2C 00 F9 2C 00 FF 2C 00 00 2E 00 31 2E 00 80 2E 00 99 2E 00'\r\n '9B 2E 00 F3 2E 00 00 2F 00 D5 2F 00 F0 2F 00 FB 2F 00 01 30 00 04 30 00 08 30 00 20 30 00 30 30'\r\n '00 30 30 00 36 30 00 37 30 00 3D 30 00 3F 30 00 9B 30 00 9C 30 00 A0 30 00 A0 30 00 FB 30 00 FB'\r\n '30 00 C0 31 00 E3 31 00 1D 32 00 1E 32 00 50 32 00 5F 32 00 7C 32 00 7E 32 00 B1 32 00 BF 32 00'\r\n 'CC 32 00 CF 32 00 77 33 00 7A 33 00 DE 33 00 DF 33 00 FF 33 00 FF 33 00 C0 4D 00 FF 4D 00 90 A4'\r\n '00 C6 A4 00 0D A6 00 0F A6 00 73 A6 00 73 A6 00 7E A6 00 7F A6 00 00 A7 00 21 A7 00 88 A7 00 88'\r\n 'A7 00 28 A8 00 2B A8 00 74 A8 00 77 A8 00 3E FD 00 3F FD 00 FD FD 00 FD FD 00 10 FE 00 19 FE 00'\r\n '30 FE 00 4F FE 00 51 FE 00 51 FE 00 54 FE 00 54 FE 00 56 FE 00 5E FE 00 60 FE 00 61 FE 00 64 FE'\r\n '00 66 FE 00 68 FE 00 68 FE 00 6B FE 00 6B FE 00 01 FF 00 02 FF 00 06 FF 00 0A FF 00 1B FF 00 20'\r\n 'FF 00 3B FF 00 40 FF 00 5B FF 00 65 FF 00 E2 FF 00 E4 FF 00 E8 FF 00 EE FF 00 F9 FF 00 FD FF 00'\r\n '01 01 01 01 01 01 40 01 01 8A 01 01 90 01 01 9B 01 01 1F 09 01 1F 09 01 39 0B 01 3F 0B 01 52 10'\r\n '01 65 10 01 00 D2 01 41 D2 01 45 D2 01 45 D2 01 00 D3 01 56 D3 01 DB D6 01 DB D6 01 15 D7 01 15'\r\n 'D7 01 4F D7 01 4F D7 01 89 D7 01 89 D7 01 C3 D7 01 C3 D7 01 00 F0 01 2B F0 01 30 F0 01 93 F0 01'\r\n 'A0 F0 01 AE F0 01 B1 F0 01 BE F0 01 C1 F0 01 CF F0 01 D1 F0 01 DF F0 01 00 F3 01 20 F3 01 30 F3'\r\n '01 35 F3 01 37 F3 01 7C F3 01 80 F3 01 93 F3 01 A0 F3 01 C4 F3 01 C6 F3 01 CA F3 01 E0 F3 01 F0'\r\n 'F3 01 00 F4 01 3E F4 01 40 F4 01 40 F4 01 42 F4 01 8B F4 01 8D F4 01 F7 F4 01 F9 F4 01 FC F4 01'\r\n '00 F5 01 23 F5 01 25 F5 01 3D F5 01 50 F5 01 67 F5 01 FB F5 01 FF F5 01 01 F6 01 10 F6 01 12 F6'\r\n '01 14 F6 01 16 F6 01 16 F6 01 18 F6 01 18 F6 01 1A F6 01 1A F6 01 1C F6 01 1E F6 01 20 F6 01 25'\r\n 'F6 01 28 F6 01 2B F6 01 2D F6 01 2D F6 01 30 F6 01 33 F6 01 35 F6 01 40 F6 01 45 F6 01 4F F6 01'\r\n '80 F6 01 C5 F6 01 00 F7 01 73 F7 01 2F 5C 01 00 00 A0 00 00 A0 00 00 A8 00 00 A8 00 00 AA 00 00'\r\n 'AA 00 00 AF 00 00 AF 00 00 B2 00 00 B5 00 00 B8 00 00 BA 00 00 BC 00 00 BE 00 00 C0 00 00 C5 00'\r\n '00 C7 00 00 CF 00 00 D1 00 00 D6 00 00 D9 00 00 DD 00 00 E0 00 00 E5 00 00 E7 00 00 EF 00 00 F1'\r\n '00 00 F6 00 00 F9 00 00 FD 00 00 FF 00 00 0F 01 00 12 01 00 25 01 00 28 01 00 30 01 00 32 01 00'\r\n '37 01 00 39 01 00 40 01 00 43 01 00 49 01 00 4C 01 00 51 01 00 54 01 00 65 01 00 68 01 00 7F 01'\r\n '00 A0 01 00 A1 01 00 AF 01 00 B0 01 00 C4 01 00 DC 01 00 DE 01 00 E3 01 00 E6 01 00 F5 01 00 F8'\r\n '01 00 1B 02 00 1E 02 00 1F 02 00 26 02 00 33 02 00 B0 02 00 B8 02 00 D8 02 00 DD 02 00 E0 02 00'\r\n 'E4 02 00 40 03 00 41 03 00 43 03 00 44 03 00 74 03 00 74 03 00 7A 03 00 7A 03 00 7E 03 00 7E 03'\r\n '00 84 03 00 8A 03 00 8C 03 00 8C 03 00 8E 03 00 90 03 00 AA 03 00 B0 03 00 CA 03 00 CE 03 00 D0'\r\n '03 00 D6 03 00 F0 03 00 F2 03 00 F4 03 00 F5 03 00 F9 03 00 F9 03 00 00 04 00 01 04 00 03 04 00'\r\n '03 04 00 07 04 00 07 04 00 0C 04 00 0E 04 00 19 04 00 19 04 00 39 04 00 39 04 00 50 04 00 51 04'\r\n '00 53 04 00 53 04 00 57 04 00 57 04 00 5C 04 00 5E 04 00 76 04 00 77 04 00 C1 04 00 C2 04 00 D0'\r\n '04 00 D3 04 00 D6 04 00 D7 04 00 DA 04 00 DF 04 00 E2 04 00 E7 04 00 EA 04 00 F5 04 00 F8 04 00'\r\n 'F9 04 00 87 05 00 87 05 00 22 06 00 26 06 00 75 06 00 78 06 00 C0 06 00 C0 06 00 C2 06 00 C2 06'\r\n '00 D3 06 00 D3 06 00 29 09 00 29 09 00 31 09 00 31 09 00 34 09 00 34 09 00 58 09 00 5F 09 00 CB'\r\n '09 00 CC 09 00 DC 09 00 DD 09 00 DF 09 00 DF 09 00 33 0A 00 33 0A 00 36 0A 00 36 0A 00 59 0A 00'\r\n '5B 0A 00 5E 0A 00 5E 0A 00 48 0B 00 48 0B 00 4B 0B 00 4C 0B 00 5C 0B 00 5D 0B 00 94 0B 00 94 0B'\r\n '00 CA 0B 00 CC 0B 00 48 0C 00 48 0C 00 C0 0C 00 C0 0C 00 C7 0C 00 C8 0C 00 CA 0C 00 CB 0C 00 4A'\r\n '0D 00 4C 0D 00 DA 0D 00 DA 0D 00 DC 0D 00 DE 0D 00 33 0E 00 33 0E 00 B3 0E 00 B3 0E 00 DC 0E 00'\r\n 'DD 0E 00 0C 0F 00 0C 0F 00 43 0F 00 43 0F 00 4D 0F 00 4D 0F 00 52 0F 00 52 0F 00 57 0F 00 57 0F'\r\n '00 5C 0F 00 5C 0F 00 69 0F 00 69 0F 00 73 0F 00 73 0F 00 75 0F 00 79 0F 00 81 0F 00 81 0F 00 93'\r\n '0F 00 93 0F 00 9D 0F 00 9D 0F 00 A2 0F 00 A2 0F 00 A7 0F 00 A7 0F 00 AC 0F 00 AC 0F 00 B9 0F 00'\r\n 'B9 0F 00 26 10 00 26 10 00 FC 10 00 FC 10 00 06 1B 00 06 1B 00 08 1B 00 08 1B 00 0A 1B 00 0A 1B'\r\n '00 0C 1B 00 0C 1B 00 0E 1B 00 0E 1B 00 12 1B 00 12 1B 00 3B 1B 00 3B 1B 00 3D 1B 00 3D 1B 00 40'\r\n '1B 00 41 1B 00 43 1B 00 43 1B 00 2C 1D 00 2E 1D 00 30 1D 00 3A 1D 00 3C 1D 00 4D 1D 00 4F 1D 00'\r\n '6A 1D 00 78 1D 00 78 1D 00 9B 1D 00 BF 1D 00 00 1E 00 9B 1E 00 A0 1E 00 F9 1E 00 00 1F 00 15 1F'\r\n '00 18 1F 00 1D 1F 00 20 1F 00 45 1F 00 48 1F 00 4D 1F 00 50 1F 00 57 1F 00 59 1F 00 59 1F 00 5B'\r\n '1F 00 5B 1F 00 5D 1F 00 5D 1F 00 5F 1F 00 7D 1F 00 80 1F 00 B4 1F 00 B6 1F 00 C4 1F 00 C6 1F 00'\r\n 'D3 1F 00 D6 1F 00 DB 1F 00 DD 1F 00 EF 1F 00 F2 1F 00 F4 1F 00 F6 1F 00 FE 1F 00 00 20 00 0A 20'\r\n '00 11 20 00 11 20 00 17 20 00 17 20 00 24 20 00 26 20 00 2F 20 00 2F 20 00 33 20 00 34 20 00 36'\r\n '20 00 37 20 00 3C 20 00 3C 20 00 3E 20 00 3E 20 00 47 20 00 49 20 00 57 20 00 57 20 00 5F 20 00'\r\n '5F 20 00 70 20 00 71 20 00 74 20 00 8E 20 00 90 20 00 9C 20 00 A8 20 00 A8 20 00 00 21 00 03 21'\r\n '00 05 21 00 07 21 00 09 21 00 13 21 00 15 21 00 16 21 00 19 21 00 1D 21 00 20 21 00 22 21 00 24'\r\n '21 00 24 21 00 26 21 00 26 21 00 28 21 00 28 21 00 2A 21 00 2D 21 00 2F 21 00 31 21 00 33 21 00'\r\n '39 21 00 3B 21 00 40 21 00 45 21 00 49 21 00 50 21 00 7F 21 00 89 21 00 89 21 00 9A 21 00 9B 21'\r\n '00 AE 21 00 AE 21 00 CD 21 00 CF 21 00 04 22 00 04 22 00 09 22 00 09 22 00 0C 22 00 0C 22 00 24'\r\n '22 00 24 22 00 26 22 00 26 22 00 2C 22 00 2D 22 00 2F 22 00 30 22 00 41 22 00 41 22 00 44 22 00'\r\n '44 22 00 47 22 00 47 22 00 49 22 00 49 22 00 60 22 00 60 22 00 62 22 00 62 22 00 6D 22 00 71 22'\r\n '00 74 22 00 75 22 00 78 22 00 79 22 00 80 22 00 81 22 00 84 22 00 85 22 00 88 22 00 89 22 00 AC'\r\n '22 00 AF 22 00 E0 22 00 E3 22 00 EA 22 00 ED 22 00 29 23 00 2A 23 00 60 24 00 EA 24 00 0C 2A 00'\r\n '0C 2A 00 74 2A 00 76 2A 00 DC 2A 00 DC 2A 00 7C 2C 00 7D 2C 00 6F 2D 00 6F 2D 00 9F 2E 00 9F 2E'\r\n '00 F3 2E 00 F3 2E 00 00 2F 00 D5 2F 00 00 30 00 00 30 00 36 30 00 36 30 00 38 30 00 3A 30 00 4C'\r\n '30 00 4C 30 00 4E 30 00 4E 30 00 50 30 00 50 30 00 52 30 00 52 30 00 54 30 00 54 30 00 56 30 00'\r\n '56 30 00 58 30 00 58 30 00 5A 30 00 5A 30 00 5C 30 00 5C 30 00 5E 30 00 5E 30 00 60 30 00 60 30'\r\n '00 62 30 00 62 30 00 65 30 00 65 30 00 67 30 00 67 30 00 69 30 00 69 30 00 70 30 00 71 30 00 73'\r\n '30 00 74 30 00 76 30 00 77 30 00 79 30 00 7A 30 00 7C 30 00 7D 30 00 94 30 00 94 30 00 9B 30 00'\r\n '9C 30 00 9E 30 00 9F 30 00 AC 30 00 AC 30 00 AE 30 00 AE 30 00 B0 30 00 B0 30 00 B2 30 00 B2 30'\r\n '00 B4 30 00 B4 30 00 B6 30 00 B6 30 00 B8 30 00 B8 30 00 BA 30 00 BA 30 00 BC 30 00 BC 30 00 BE'\r\n '30 00 BE 30 00 C0 30 00 C0 30 00 C2 30 00 C2 30 00 C5 30 00 C5 30 00 C7 30 00 C7 30 00 C9 30 00'\r\n 'C9 30 00 D0 30 00 D1 30 00 D3 30 00 D4 30 00 D6 30 00 D7 30 00 D9 30 00 DA 30 00 DC 30 00 DD 30'\r\n '00 F4 30 00 F4 30 00 F7 30 00 FA 30 00 FE 30 00 FF 30 00 31 31 00 8E 31 00 92 31 00 9F 31 00 00'\r\n '32 00 1E 32 00 20 32 00 47 32 00 50 32 00 7E 32 00 80 32 00 FE 32 00 00 33 00 FF 33 00 70 A7 00'\r\n '70 A7 00 00 F9 00 0D FA 00 10 FA 00 10 FA 00 12 FA 00 12 FA 00 15 FA 00 1E FA 00 20 FA 00 20 FA'\r\n '00 22 FA 00 22 FA 00 25 FA 00 26 FA 00 2A FA 00 2D FA 00 30 FA 00 6D FA 00 70 FA 00 D9 FA 00 00'\r\n 'FB 00 06 FB 00 13 FB 00 17 FB 00 1D FB 00 1D FB 00 1F FB 00 36 FB 00 38 FB 00 3C FB 00 3E FB 00'\r\n '3E FB 00 40 FB 00 41 FB 00 43 FB 00 44 FB 00 46 FB 00 B1 FB 00 D3 FB 00 3D FD 00 50 FD 00 8F FD'\r\n '00 92 FD 00 C7 FD 00 F0 FD 00 FC FD 00 10 FE 00 19 FE 00 30 FE 00 44 FE 00 47 FE 00 52 FE 00 54'\r\n 'FE 00 66 FE 00 68 FE 00 6B FE 00 70 FE 00 72 FE 00 74 FE 00 74 FE 00 76 FE 00 FC FE 00 01 FF 00'\r\n 'BE FF 00 C2 FF 00 C7 FF 00 CA FF 00 CF FF 00 D2 FF 00 D7 FF 00 DA FF 00 DC FF 00 E0 FF 00 E6 FF'\r\n '00 E8 FF 00 EE FF 00 9A 10 01 9A 10 01 9C 10 01 9C 10 01 AB 10 01 AB 10 01 5E D1 01 64 D1 01 BB'\r\n 'D1 01 C0 D1 01 00 D4 01 54 D4 01 56 D4 01 9C D4 01 9E D4 01 9F D4 01 A2 D4 01 A2 D4 01 A5 D4 01'\r\n 'A6 D4 01 A9 D4 01 AC D4 01 AE D4 01 B9 D4 01 BB D4 01 BB D4 01 BD D4 01 C3 D4 01 C5 D4 01 05 D5'\r\n '01 07 D5 01 0A D5 01 0D D5 01 14 D5 01 16 D5 01 1C D5 01 1E D5 01 39 D5 01 3B D5 01 3E D5 01 40'\r\n 'D5 01 44 D5 01 46 D5 01 46 D5 01 4A D5 01 50 D5 01 52 D5 01 A5 D6 01 A8 D6 01 CB D7 01 CE D7 01'\r\n 'FF D7 01 00 F1 01 0A F1 01 10 F1 01 2E F1 01 30 F1 01 4F F1 01 90 F1 01 90 F1 01 00 F2 01 02 F2'\r\n '01 10 F2 01 3A F2 01 40 F2 01 48 F2 01 50 F2 01 51 F2 01 00 F8 02 1D FA 02 30 05 00 00 00 A0 00'\r\n '00 A0 00 00 0C 0F 00 0C 0F 00 07 20 00 07 20 00 11 20 00 11 20 00 2F 20 00 2F 20 00 31 B3 00 00'\r\n '00 28 00 00 29 00 00 5B 00 00 5B 00 00 5D 00 00 5D 00 00 7B 00 00 7B 00 00 7D 00 00 7D 00 00 AB'\r\n '00 00 AB 00 00 BB 00 00 BB 00 00 BE 02 00 BF 02 00 C2 02 00 C3 02 00 D2 02 00 D3 02 00 F1 02 00'\r\n 'F2 02 00 18 03 00 19 03 00 1C 03 00 1C 03 00 39 03 00 39 03 00 50 03 00 51 03 00 54 03 00 55 03'\r\n '00 57 03 00 57 03 00 06 07 00 07 07 00 D5 0F 00 D8 0F 00 FE 1D 00 FE 1D 00 0E 20 00 0F 20 00 18'\r\n '20 00 19 20 00 1C 20 00 1D 20 00 2A 20 00 2B 20 00 2D 20 00 2E 20 00 39 20 00 3A 20 00 45 20 00'\r\n '46 20 00 4C 20 00 4D 20 00 7D 20 00 7E 20 00 8D 20 00 8E 20 00 D0 20 00 D1 20 00 D6 20 00 D7 20'\r\n '00 EC 20 00 EF 20 00 90 21 00 90 21 00 92 21 00 92 21 00 9A 21 00 9E 21 00 A0 21 00 A0 21 00 A2'\r\n '21 00 A4 21 00 A6 21 00 A6 21 00 A9 21 00 AC 21 00 B0 21 00 B3 21 00 BC 21 00 C4 21 00 C6 21 00'\r\n 'C7 21 00 C9 21 00 C9 21 00 CB 21 00 CD 21 00 CF 21 00 D0 21 00 D2 21 00 D2 21 00 DA 21 00 DD 21'\r\n '00 E0 21 00 E0 21 00 E2 21 00 E2 21 00 E4 21 00 E6 21 00 E8 21 00 E8 21 00 F4 21 00 F4 21 00 F6'\r\n '21 00 F8 21 00 FA 21 00 FB 21 00 FD 21 00 FE 21 00 A2 22 00 A3 22 00 AB 22 00 AB 22 00 C9 22 00'\r\n 'CC 22 00 08 23 00 0F 23 00 1C 23 00 1F 23 00 26 23 00 26 23 00 29 23 00 2B 23 00 45 23 00 48 23'\r\n '00 9B 23 00 A9 23 00 AB 23 00 AD 23 00 B0 23 00 B1 23 00 B8 23 00 B9 23 00 BE 23 00 BF 23 00 CB'\r\n '23 00 CC 23 00 E9 23 00 EA 23 00 ED 23 00 EE 23 00 0C 25 00 2B 25 00 2D 25 00 2E 25 00 31 25 00'\r\n '32 25 00 35 25 00 36 25 00 39 25 00 3A 25 00 3D 25 00 3E 25 00 43 25 00 46 25 00 49 25 00 4A 25'\r\n '00 52 25 00 63 25 00 6D 25 00 72 25 00 74 25 00 74 25 00 76 25 00 76 25 00 78 25 00 78 25 00 7A'\r\n '25 00 7A 25 00 8C 25 00 8C 25 00 8F 25 00 90 25 00 95 25 00 98 25 00 9A 25 00 9A 25 00 9D 25 00'\r\n '9E 25 00 A7 25 00 A8 25 00 B6 25 00 BB 25 00 C0 25 00 C5 25 00 D0 25 00 D1 25 00 D6 25 00 D7 25'\r\n '00 DC 25 00 DF 25 00 E2 25 00 E5 25 00 E7 25 00 EA 25 00 ED 25 00 EE 25 00 F0 25 00 FA 25 00 FF'\r\n '25 00 FF 25 00 1A 26 00 1C 26 00 1E 26 00 1E 26 00 9E 26 00 9F 26 00 E5 26 00 E6 26 00 68 27 00'\r\n '75 27 00 C5 27 00 C6 27 00 D5 27 00 D6 27 00 DD 27 00 DE 27 00 E2 27 00 EF 27 00 F4 27 00 F6 27'\r\n '00 F8 27 00 F9 27 00 FB 27 00 FF 27 00 00 29 00 03 29 00 05 29 00 07 29 00 0C 29 00 11 29 00 14'\r\n '29 00 20 29 00 33 29 00 33 29 00 36 29 00 37 29 00 42 29 00 43 29 00 45 29 00 47 29 00 4C 29 00'\r\n '4D 29 00 4F 29 00 4F 29 00 51 29 00 62 29 00 64 29 00 64 29 00 66 29 00 6D 29 00 71 29 00 75 29'\r\n '00 7C 29 00 7D 29 00 83 29 00 92 29 00 97 29 00 98 29 00 A8 29 00 AF 29 00 B3 29 00 B4 29 00 D1'\r\n '29 00 D2 29 00 D4 29 00 D5 29 00 D8 29 00 DB 29 00 E8 29 00 E9 29 00 FC 29 00 FD 29 00 2D 2A 00'\r\n '2E 2A 00 34 2A 00 35 2A 00 CD 2A 00 CE 2A 00 E5 2A 00 E5 2A 00 0E 2B 00 11 2B 00 14 2B 00 17 2B'\r\n '00 30 2B 00 42 2B 00 45 2B 00 4C 2B 00 02 2E 00 05 2E 00 09 2E 00 0A 2E 00 0C 2E 00 0D 2E 00 1C'\r\n '2E 00 1D 2E 00 20 2E 00 29 2E 00 F8 2F 00 F9 2F 00 08 30 00 11 30 00 14 30 00 1B 30 00 A7 32 00'\r\n 'A8 32 00 C1 A9 00 C2 A9 00 3E FD 00 3F FD 00 20 FE 00 25 FE 00 35 FE 00 44 FE 00 47 FE 00 48 FE'\r\n '00 59 FE 00 5E FE 00 08 FF 00 09 FF 00 3B FF 00 3B FF 00 3D FF 00 3D FF 00 5B FF 00 5B FF 00 5D'\r\n 'FF 00 5D FF 00 5F FF 00 60 FF 00 62 FF 00 63 FF 00 E9 FF 00 E9 FF 00 EB FF 00 EB FF 00 06 D1 01'\r\n '07 D1 01 4A D1 01 4D D1 01 48 F4 01 49 F4 01 0D F5 01 0E F5 01 28 00 0E 29 00 0E 5B 00 0E 5B 00'\r\n '0E 5D 00 0E 5D 00 0E 7B 00 0E 7B 00 0E 7D 00 0E 7D 00 0E 32 06 00 00 00 30 00 00 39 00 00 41 00'\r\n '00 46 00 00 61 00 00 66 00 00 10 FF 00 19 FF 00 21 FF 00 26 FF 00 41 FF 00 46 FF 00 33 0C 00 00'\r\n '00 22 00 00 22 00 00 27 00 00 27 00 00 AB 00 00 AB 00 00 BB 00 00 BB 00 00 18 20 00 1F 20 00 39'\r\n '20 00 3A 20 00 0C 30 00 0F 30 00 1D 30 00 1F 30 00 41 FE 00 44 FE 00 02 FF 00 02 FF 00 07 FF 00'\r\n '07 FF 00 62 FF 00 63 FF 00 34 6F 00 00 00 28 00 00 29 00 00 3C 00 00 3C 00 00 3E 00 00 3E 00 00'\r\n '5B 00 00 5B 00 00 5D 00 00 5D 00 00 7B 00 00 7B 00 00 7D 00 00 7D 00 00 AB 00 00 AB 00 00 BB 00'\r\n '00 BB 00 00 3A 0F 00 3D 0F 00 9B 16 00 9C 16 00 39 20 00 3A 20 00 45 20 00 46 20 00 7D 20 00 7E'\r\n '20 00 8D 20 00 8E 20 00 40 21 00 40 21 00 01 22 00 04 22 00 08 22 00 0D 22 00 11 22 00 11 22 00'\r\n '15 22 00 16 22 00 1A 22 00 1D 22 00 1F 22 00 22 22 00 24 22 00 24 22 00 26 22 00 26 22 00 2B 22'\r\n '00 33 22 00 39 22 00 39 22 00 3B 22 00 4C 22 00 52 22 00 55 22 00 5F 22 00 60 22 00 62 22 00 62'\r\n '22 00 64 22 00 6B 22 00 6E 22 00 8C 22 00 8F 22 00 92 22 00 98 22 00 98 22 00 A2 22 00 A3 22 00'\r\n 'A6 22 00 B8 22 00 BE 22 00 BF 22 00 C9 22 00 CD 22 00 D0 22 00 D1 22 00 D6 22 00 ED 22 00 F0 22'\r\n '00 FF 22 00 08 23 00 0B 23 00 20 23 00 21 23 00 29 23 00 2A 23 00 68 27 00 75 27 00 C0 27 00 C0'\r\n '27 00 C3 27 00 C6 27 00 C8 27 00 C9 27 00 CC 27 00 CC 27 00 D3 27 00 D6 27 00 DC 27 00 DE 27 00'\r\n 'E2 27 00 EF 27 00 83 29 00 98 29 00 9B 29 00 AF 29 00 B8 29 00 B8 29 00 C0 29 00 C5 29 00 C9 29'\r\n '00 C9 29 00 CE 29 00 D2 29 00 D4 29 00 D5 29 00 D8 29 00 DC 29 00 E1 29 00 E1 29 00 E3 29 00 E5'\r\n '29 00 E8 29 00 E9 29 00 F4 29 00 F9 29 00 FC 29 00 FD 29 00 0A 2A 00 1C 2A 00 1E 2A 00 21 2A 00'\r\n '24 2A 00 24 2A 00 26 2A 00 26 2A 00 29 2A 00 29 2A 00 2B 2A 00 2E 2A 00 34 2A 00 35 2A 00 3C 2A'\r\n '00 3E 2A 00 57 2A 00 58 2A 00 64 2A 00 65 2A 00 6A 2A 00 6D 2A 00 6F 2A 00 70 2A 00 73 2A 00 74'\r\n '2A 00 79 2A 00 A3 2A 00 A6 2A 00 AD 2A 00 AF 2A 00 D6 2A 00 DC 2A 00 DC 2A 00 DE 2A 00 DE 2A 00'\r\n 'E2 2A 00 E6 2A 00 EC 2A 00 EE 2A 00 F3 2A 00 F3 2A 00 F7 2A 00 FB 2A 00 FD 2A 00 FD 2A 00 02 2E'\r\n '00 05 2E 00 09 2E 00 0A 2E 00 0C 2E 00 0D 2E 00 1C 2E 00 1D 2E 00 20 2E 00 29 2E 00 08 30 00 11'\r\n '30 00 14 30 00 1B 30 00 59 FE 00 5E FE 00 64 FE 00 65 FE 00 08 FF 00 09 FF 00 1C FF 00 1C FF 00'\r\n '1E FF 00 1E FF 00 3B FF 00 3B FF 00 3D FF 00 3D FF 00 5B FF 00 5B FF 00 5D FF 00 5D FF 00 5F FF'\r\n '00 60 FF 00 62 FF 00 63 FF 00 DB D6 01 DB D6 01 15 D7 01 15 D7 01 4F D7 01 4F D7 01 89 D7 01 89'\r\n 'D7 01 C3 D7 01 C3 D7 01 35 F5 01 00 00 00 00 00 77 03 00 7A 03 00 7E 03 00 84 03 00 8A 03 00 8C'\r\n '03 00 8C 03 00 8E 03 00 A1 03 00 A3 03 00 27 05 00 31 05 00 56 05 00 59 05 00 5F 05 00 61 05 00'\r\n '87 05 00 89 05 00 8A 05 00 91 05 00 C7 05 00 D0 05 00 EA 05 00 F0 05 00 F4 05 00 00 06 00 03 06'\r\n '00 06 06 00 1B 06 00 1E 06 00 0D 07 00 0F 07 00 4A 07 00 4D 07 00 B1 07 00 C0 07 00 FA 07 00 00'\r\n '08 00 2D 08 00 30 08 00 3E 08 00 40 08 00 5B 08 00 5E 08 00 5E 08 00 00 09 00 77 09 00 79 09 00'\r\n '7F 09 00 81 09 00 83 09 00 85 09 00 8C 09 00 8F 09 00 90 09 00 93 09 00 A8 09 00 AA 09 00 B0 09'\r\n '00 B2 09 00 B2 09 00 B6 09 00 B9 09 00 BC 09 00 C4 09 00 C7 09 00 C8 09 00 CB 09 00 CE 09 00 D7'\r\n '09 00 D7 09 00 DC 09 00 DD 09 00 DF 09 00 E3 09 00 E6 09 00 FB 09 00 01 0A 00 03 0A 00 05 0A 00'\r\n '0A 0A 00 0F 0A 00 10 0A 00 13 0A 00 28 0A 00 2A 0A 00 30 0A 00 32 0A 00 33 0A 00 35 0A 00 36 0A'\r\n '00 38 0A 00 39 0A 00 3C 0A 00 3C 0A 00 3E 0A 00 42 0A 00 47 0A 00 48 0A 00 4B 0A 00 4D 0A 00 51'\r\n '0A 00 51 0A 00 59 0A 00 5C 0A 00 5E 0A 00 5E 0A 00 66 0A 00 75 0A 00 81 0A 00 83 0A 00 85 0A 00'\r\n '8D 0A 00 8F 0A 00 91 0A 00 93 0A 00 A8 0A 00 AA 0A 00 B0 0A 00 B2 0A 00 B3 0A 00 B5 0A 00 B9 0A'\r\n '00 BC 0A 00 C5 0A 00 C7 0A 00 C9 0A 00 CB 0A 00 CD 0A 00 D0 0A 00 D0 0A 00 E0 0A 00 E3 0A 00 E6'\r\n '0A 00 EF 0A 00 F1 0A 00 F1 0A 00 01 0B 00 03 0B 00 05 0B 00 0C 0B 00 0F 0B 00 10 0B 00 13 0B 00'\r\n '28 0B 00 2A 0B 00 30 0B 00 32 0B 00 33 0B 00 35 0B 00 39 0B 00 3C 0B 00 44 0B 00 47 0B 00 48 0B'\r\n '00 4B 0B 00 4D 0B 00 56 0B 00 57 0B 00 5C 0B 00 5D 0B 00 5F 0B 00 63 0B 00 66 0B 00 77 0B 00 82'\r\n '0B 00 83 0B 00 85 0B 00 8A 0B 00 8E 0B 00 90 0B 00 92 0B 00 95 0B 00 99 0B 00 9A 0B 00 9C 0B 00'\r\n '9C 0B 00 9E 0B 00 9F 0B 00 A3 0B 00 A4 0B 00 A8 0B 00 AA 0B 00 AE 0B 00 B9 0B 00 BE 0B 00 C2 0B'\r\n '00 C6 0B 00 C8 0B 00 CA 0B 00 CD 0B 00 D0 0B 00 D0 0B 00 D7 0B 00 D7 0B 00 E6 0B 00 FA 0B 00 01'\r\n '0C 00 03 0C 00 05 0C 00 0C 0C 00 0E 0C 00 10 0C 00 12 0C 00 28 0C 00 2A 0C 00 33 0C 00 35 0C 00'\r\n '39 0C 00 3D 0C 00 44 0C 00 46 0C 00 48 0C 00 4A 0C 00 4D 0C 00 55 0C 00 56 0C 00 58 0C 00 59 0C'\r\n '00 60 0C 00 63 0C 00 66 0C 00 6F 0C 00 78 0C 00 7F 0C 00 82 0C 00 83 0C 00 85 0C 00 8C 0C 00 8E'\r\n '0C 00 90 0C 00 92 0C 00 A8 0C 00 AA 0C 00 B3 0C 00 B5 0C 00 B9 0C 00 BC 0C 00 C4 0C 00 C6 0C 00'\r\n 'C8 0C 00 CA 0C 00 CD 0C 00 D5 0C 00 D6 0C 00 DE 0C 00 DE 0C 00 E0 0C 00 E3 0C 00 E6 0C 00 EF 0C'\r\n '00 F1 0C 00 F2 0C 00 02 0D 00 03 0D 00 05 0D 00 0C 0D 00 0E 0D 00 10 0D 00 12 0D 00 3A 0D 00 3D'\r\n '0D 00 44 0D 00 46 0D 00 48 0D 00 4A 0D 00 4E 0D 00 57 0D 00 57 0D 00 60 0D 00 63 0D 00 66 0D 00'\r\n '75 0D 00 79 0D 00 7F 0D 00 82 0D 00 83 0D 00 85 0D 00 96 0D 00 9A 0D 00 B1 0D 00 B3 0D 00 BB 0D'\r\n '00 BD 0D 00 BD 0D 00 C0 0D 00 C6 0D 00 CA 0D 00 CA 0D 00 CF 0D 00 D4 0D 00 D6 0D 00 D6 0D 00 D8'\r\n '0D 00 DF 0D 00 F2 0D 00 F4 0D 00 01 0E 00 3A 0E 00 3F 0E 00 5B 0E 00 81 0E 00 82 0E 00 84 0E 00'\r\n '84 0E 00 87 0E 00 88 0E 00 8A 0E 00 8A 0E 00 8D 0E 00 8D 0E 00 94 0E 00 97 0E 00 99 0E 00 9F 0E'\r\n '00 A1 0E 00 A3 0E 00 A5 0E 00 A5 0E 00 A7 0E 00 A7 0E 00 AA 0E 00 AB 0E 00 AD 0E 00 B9 0E 00 BB'\r\n '0E 00 BD 0E 00 C0 0E 00 C4 0E 00 C6 0E 00 C6 0E 00 C8 0E 00 CD 0E 00 D0 0E 00 D9 0E 00 DC 0E 00'\r\n 'DD 0E 00 00 0F 00 47 0F 00 49 0F 00 6C 0F 00 71 0F 00 97 0F 00 99 0F 00 BC 0F 00 BE 0F 00 CC 0F'\r\n '00 CE 0F 00 DA 0F 00 00 10 00 C5 10 00 D0 10 00 FC 10 00 00 11 00 48 12 00 4A 12 00 4D 12 00 50'\r\n '12 00 56 12 00 58 12 00 58 12 00 5A 12 00 5D 12 00 60 12 00 88 12 00 8A 12 00 8D 12 00 90 12 00'\r\n 'B0 12 00 B2 12 00 B5 12 00 B8 12 00 BE 12 00 C0 12 00 C0 12 00 C2 12 00 C5 12 00 C8 12 00 D6 12'\r\n '00 D8 12 00 10 13 00 12 13 00 15 13 00 18 13 00 5A 13 00 5D 13 00 7C 13 00 80 13 00 99 13 00 A0'\r\n '13 00 F4 13 00 00 14 00 9C 16 00 A0 16 00 F0 16 00 00 17 00 0C 17 00 0E 17 00 14 17 00 20 17 00'\r\n '36 17 00 40 17 00 53 17 00 60 17 00 6C 17 00 6E 17 00 70 17 00 72 17 00 73 17 00 80 17 00 DD 17'\r\n '00 E0 17 00 E9 17 00 F0 17 00 F9 17 00 00 18 00 0E 18 00 10 18 00 19 18 00 20 18 00 77 18 00 80'\r\n '18 00 AA 18 00 B0 18 00 F5 18 00 00 19 00 1C 19 00 20 19 00 2B 19 00 30 19 00 3B 19 00 40 19 00'\r\n '40 19 00 44 19 00 6D 19 00 70 19 00 74 19 00 80 19 00 AB 19 00 B0 19 00 C9 19 00 D0 19 00 DA 19'\r\n '00 DE 19 00 1B 1A 00 1E 1A 00 5E 1A 00 60 1A 00 7C 1A 00 7F 1A 00 89 1A 00 90 1A 00 99 1A 00 A0'\r\n '1A 00 AD 1A 00 00 1B 00 4B 1B 00 50 1B 00 7C 1B 00 80 1B 00 AA 1B 00 AE 1B 00 B9 1B 00 C0 1B 00'\r\n 'F3 1B 00 FC 1B 00 37 1C 00 3B 1C 00 49 1C 00 4D 1C 00 7F 1C 00 D0 1C 00 F2 1C 00 00 1D 00 E6 1D'\r\n '00 FC 1D 00 15 1F 00 18 1F 00 1D 1F 00 20 1F 00 45 1F 00 48 1F 00 4D 1F 00 50 1F 00 57 1F 00 59'\r\n '1F 00 59 1F 00 5B 1F 00 5B 1F 00 5D 1F 00 5D 1F 00 5F 1F 00 7D 1F 00 80 1F 00 B4 1F 00 B6 1F 00'\r\n 'C4 1F 00 C6 1F 00 D3 1F 00 D6 1F 00 DB 1F 00 DD 1F 00 EF 1F 00 F2 1F 00 F4 1F 00 F6 1F 00 FE 1F'\r\n '00 00 20 00 64 20 00 6A 20 00 71 20 00 74 20 00 8E 20 00 90 20 00 9C 20 00 A0 20 00 B9 20 00 D0'\r\n '20 00 F0 20 00 00 21 00 89 21 00 90 21 00 F3 23 00 00 24 00 26 24 00 40 24 00 4A 24 00 60 24 00'\r\n 'FF 26 00 01 27 00 CA 27 00 CC 27 00 CC 27 00 CE 27 00 4C 2B 00 50 2B 00 59 2B 00 00 2C 00 2E 2C'\r\n '00 30 2C 00 5E 2C 00 60 2C 00 F1 2C 00 F9 2C 00 25 2D 00 30 2D 00 65 2D 00 6F 2D 00 70 2D 00 7F'\r\n '2D 00 96 2D 00 A0 2D 00 A6 2D 00 A8 2D 00 AE 2D 00 B0 2D 00 B6 2D 00 B8 2D 00 BE 2D 00 C0 2D 00'\r\n 'C6 2D 00 C8 2D 00 CE 2D 00 D0 2D 00 D6 2D 00 D8 2D 00 DE 2D 00 E0 2D 00 31 2E 00 80 2E 00 99 2E'\r\n '00 9B 2E 00 F3 2E 00 00 2F 00 D5 2F 00 F0 2F 00 FB 2F 00 00 30 00 3F 30 00 41 30 00 96 30 00 99'\r\n '30 00 FF 30 00 05 31 00 2D 31 00 31 31 00 8E 31 00 90 31 00 BA 31 00 C0 31 00 E3 31 00 F0 31 00'\r\n '1E 32 00 20 32 00 FE 32 00 00 33 00 B5 4D 00 C0 4D 00 CB 9F 00 00 A0 00 8C A4 00 90 A4 00 C6 A4'\r\n '00 D0 A4 00 2B A6 00 40 A6 00 73 A6 00 7C A6 00 97 A6 00 A0 A6 00 F7 A6 00 00 A7 00 8E A7 00 90'\r\n 'A7 00 91 A7 00 A0 A7 00 A9 A7 00 FA A7 00 2B A8 00 30 A8 00 39 A8 00 40 A8 00 77 A8 00 80 A8 00'\r\n 'C4 A8 00 CE A8 00 D9 A8 00 E0 A8 00 FB A8 00 00 A9 00 53 A9 00 5F A9 00 7C A9 00 80 A9 00 CD A9'\r\n '00 CF A9 00 D9 A9 00 DE A9 00 DF A9 00 00 AA 00 36 AA 00 40 AA 00 4D AA 00 50 AA 00 59 AA 00 5C'\r\n 'AA 00 7B AA 00 80 AA 00 C2 AA 00 DB AA 00 DF AA 00 01 AB 00 06 AB 00 09 AB 00 0E AB 00 11 AB 00'\r\n '16 AB 00 20 AB 00 26 AB 00 28 AB 00 2E AB 00 C0 AB 00 ED AB 00 F0 AB 00 F9 AB 00 00 AC 00 A3 D7'\r\n '00 B0 D7 00 C6 D7 00 CB D7 00 FB D7 00 00 D8 00 2D FA 00 30 FA 00 6D FA 00 70 FA 00 D9 FA 00 00'\r\n 'FB 00 06 FB 00 13 FB 00 17 FB 00 1D FB 00 36 FB 00 38 FB 00 3C FB 00 3E FB 00 3E FB 00 40 FB 00'\r\n '41 FB 00 43 FB 00 44 FB 00 46 FB 00 C1 FB 00 D3 FB 00 3F FD 00 50 FD 00 8F FD 00 92 FD 00 C7 FD'\r\n '00 F0 FD 00 FD FD 00 00 FE 00 19 FE 00 20 FE 00 26 FE 00 30 FE 00 52 FE 00 54 FE 00 66 FE 00 68'\r\n 'FE 00 6B FE 00 70 FE 00 74 FE 00 76 FE 00 FC FE 00 FF FE 00 FF FE 00 01 FF 00 BE FF 00 C2 FF 00'\r\n 'C7 FF 00 CA FF 00 CF FF 00 D2 FF 00 D7 FF 00 DA FF 00 DC FF 00 E0 FF 00 E6 FF 00 E8 FF 00 EE FF'\r\n '00 F9 FF 00 FD FF 00 00 00 01 0B 00 01 0D 00 01 26 00 01 28 00 01 3A 00 01 3C 00 01 3D 00 01 3F'\r\n '00 01 4D 00 01 50 00 01 5D 00 01 80 00 01 FA 00 01 00 01 01 02 01 01 07 01 01 33 01 01 37 01 01'\r\n '8A 01 01 90 01 01 9B 01 01 D0 01 01 FD 01 01 80 02 01 9C 02 01 A0 02 01 D0 02 01 00 03 01 1E 03'\r\n '01 20 03 01 23 03 01 30 03 01 4A 03 01 80 03 01 9D 03 01 9F 03 01 C3 03 01 C8 03 01 D5 03 01 00'\r\n '04 01 9D 04 01 A0 04 01 A9 04 01 00 08 01 05 08 01 08 08 01 08 08 01 0A 08 01 35 08 01 37 08 01'\r\n '38 08 01 3C 08 01 3C 08 01 3F 08 01 55 08 01 57 08 01 5F 08 01 00 09 01 1B 09 01 1F 09 01 39 09'\r\n '01 3F 09 01 3F 09 01 00 0A 01 03 0A 01 05 0A 01 06 0A 01 0C 0A 01 13 0A 01 15 0A 01 17 0A 01 19'\r\n '0A 01 33 0A 01 38 0A 01 3A 0A 01 3F 0A 01 47 0A 01 50 0A 01 58 0A 01 60 0A 01 7F 0A 01 00 0B 01'\r\n '35 0B 01 39 0B 01 55 0B 01 58 0B 01 72 0B 01 78 0B 01 7F 0B 01 00 0C 01 48 0C 01 60 0E 01 7E 0E'\r\n '01 00 10 01 4D 10 01 52 10 01 6F 10 01 80 10 01 C1 10 01 00 20 01 6E 23 01 00 24 01 62 24 01 70'\r\n '24 01 73 24 01 00 30 01 2E 34 01 00 68 01 38 6A 01 00 B0 01 01 B0 01 00 D0 01 F5 D0 01 00 D1 01'\r\n '26 D1 01 29 D1 01 DD D1 01 00 D2 01 45 D2 01 00 D3 01 56 D3 01 60 D3 01 71 D3 01 00 D4 01 54 D4'\r\n '01 56 D4 01 9C D4 01 9E D4 01 9F D4 01 A2 D4 01 A2 D4 01 A5 D4 01 A6 D4 01 A9 D4 01 AC D4 01 AE'\r\n 'D4 01 B9 D4 01 BB D4 01 BB D4 01 BD D4 01 C3 D4 01 C5 D4 01 05 D5 01 07 D5 01 0A D5 01 0D D5 01'\r\n '14 D5 01 16 D5 01 1C D5 01 1E D5 01 39 D5 01 3B D5 01 3E D5 01 40 D5 01 44 D5 01 46 D5 01 46 D5'\r\n '01 4A D5 01 50 D5 01 52 D5 01 A5 D6 01 A8 D6 01 CB D7 01 CE D7 01 FF D7 01 00 F0 01 2B F0 01 30'\r\n 'F0 01 93 F0 01 A0 F0 01 AE F0 01 B1 F0 01 BE F0 01 C1 F0 01 CF F0 01 D1 F0 01 DF F0 01 00 F1 01'\r\n '0A F1 01 10 F1 01 2E F1 01 30 F1 01 69 F1 01 70 F1 01 9A F1 01 E6 F1 01 02 F2 01 10 F2 01 3A F2'\r\n '01 40 F2 01 48 F2 01 50 F2 01 51 F2 01 00 F3 01 20 F3 01 30 F3 01 35 F3 01 37 F3 01 7C F3 01 80'\r\n 'F3 01 93 F3 01 A0 F3 01 C4 F3 01 C6 F3 01 CA F3 01 E0 F3 01 F0 F3 01 00 F4 01 3E F4 01 40 F4 01'\r\n '40 F4 01 42 F4 01 F7 F4 01 F9 F4 01 FC F4 01 00 F5 01 3D F5 01 50 F5 01 67 F5 01 FB F5 01 FF F5'\r\n '01 01 F6 01 10 F6 01 12 F6 01 14 F6 01 16 F6 01 16 F6 01 18 F6 01 18 F6 01 1A F6 01 1A F6 01 1C'\r\n 'F6 01 1E F6 01 20 F6 01 25 F6 01 28 F6 01 2B F6 01 2D F6 01 2D F6 01 30 F6 01 33 F6 01 35 F6 01'\r\n '40 F6 01 45 F6 01 4F F6 01 80 F6 01 C5 F6 01 00 F7 01 73 F7 01 00 00 02 D6 A6 02 00 A7 02 34 B7'\r\n '02 40 B7 02 1D B8 02 00 F8 02 1D FA 02 01 00 0E 01 00 0E 20 00 0E 7F 00 0E 00 01 0E EF 01 0E 00'\r\n '00 0F FD FF 0F 00 00 10 FD FF 10 36 03 00 00 00 30 00 00 39 00 00 41 00 00 46 00 00 61 00 00 66'\r\n '00 00 37 02 00 00 00 0E 20 00 0F 20 00 2A 20 00 2E 20 00 39 09 00 00 00 49 01 00 49 01 00 73 06'\r\n '00 73 06 00 77 0F 00 77 0F 00 79 0F 00 79 0F 00 A3 17 00 A4 17 00 6A 20 00 6F 20 00 29 23 00 2A'\r\n '23 00 01 00 0E 01 00 0E 20 00 0E 7F 00 0E 3A 75 00 00 00 5E 00 00 5E 00 00 60 00 00 60 00 00 A8'\r\n '00 00 A8 00 00 AF 00 00 AF 00 00 B4 00 00 B4 00 00 B7 00 00 B8 00 00 B0 02 00 4E 03 00 50 03 00'\r\n '57 03 00 5D 03 00 62 03 00 74 03 00 75 03 00 7A 03 00 7A 03 00 84 03 00 85 03 00 83 04 00 87 04'\r\n '00 59 05 00 59 05 00 91 05 00 A1 05 00 A3 05 00 BD 05 00 BF 05 00 BF 05 00 C1 05 00 C2 05 00 C4'\r\n '05 00 C4 05 00 4B 06 00 52 06 00 57 06 00 58 06 00 DF 06 00 E0 06 00 E5 06 00 E6 06 00 EA 06 00'\r\n 'EC 06 00 30 07 00 4A 07 00 A6 07 00 B0 07 00 EB 07 00 F5 07 00 18 08 00 19 08 00 3C 09 00 3C 09'\r\n '00 4D 09 00 4D 09 00 51 09 00 54 09 00 71 09 00 71 09 00 BC 09 00 BC 09 00 CD 09 00 CD 09 00 3C'\r\n '0A 00 3C 0A 00 4D 0A 00 4D 0A 00 BC 0A 00 BC 0A 00 CD 0A 00 CD 0A 00 3C 0B 00 3C 0B 00 4D 0B 00'\r\n '4D 0B 00 CD 0B 00 CD 0B 00 4D 0C 00 4D 0C 00 BC 0C 00 BC 0C 00 CD 0C 00 CD 0C 00 4D 0D 00 4D 0D'\r\n '00 CA 0D 00 CA 0D 00 47 0E 00 4C 0E 00 4E 0E 00 4E 0E 00 C8 0E 00 CC 0E 00 18 0F 00 19 0F 00 35'\r\n '0F 00 35 0F 00 37 0F 00 37 0F 00 39 0F 00 39 0F 00 3E 0F 00 3F 0F 00 82 0F 00 84 0F 00 86 0F 00'\r\n '87 0F 00 C6 0F 00 C6 0F 00 37 10 00 37 10 00 39 10 00 3A 10 00 87 10 00 8D 10 00 8F 10 00 8F 10'\r\n '00 9A 10 00 9B 10 00 C9 17 00 D3 17 00 DD 17 00 DD 17 00 39 19 00 3B 19 00 75 1A 00 7C 1A 00 7F'\r\n '1A 00 7F 1A 00 34 1B 00 34 1B 00 44 1B 00 44 1B 00 6B 1B 00 73 1B 00 AA 1B 00 AA 1B 00 36 1C 00'\r\n '37 1C 00 78 1C 00 7D 1C 00 D0 1C 00 E8 1C 00 ED 1C 00 ED 1C 00 2C 1D 00 6A 1D 00 C4 1D 00 CF 1D'\r\n '00 FD 1D 00 FF 1D 00 BD 1F 00 BD 1F 00 BF 1F 00 C1 1F 00 CD 1F 00 CF 1F 00 DD 1F 00 DF 1F 00 ED'\r\n '1F 00 EF 1F 00 FD 1F 00 FE 1F 00 EF 2C 00 F1 2C 00 2F 2E 00 2F 2E 00 2A 30 00 2F 30 00 99 30 00'\r\n '9C 30 00 FC 30 00 FC 30 00 6F A6 00 6F A6 00 7C A6 00 7D A6 00 7F A6 00 7F A6 00 F0 A6 00 F1 A6'\r\n '00 17 A7 00 21 A7 00 88 A7 00 88 A7 00 C4 A8 00 C4 A8 00 E0 A8 00 F1 A8 00 2B A9 00 2E A9 00 53'\r\n 'A9 00 53 A9 00 B3 A9 00 B3 A9 00 C0 A9 00 C0 A9 00 7B AA 00 7B AA 00 BF AA 00 C2 AA 00 EC AB 00'\r\n 'ED AB 00 1E FB 00 1E FB 00 20 FE 00 26 FE 00 3E FF 00 3E FF 00 40 FF 00 40 FF 00 70 FF 00 70 FF'\r\n '00 9E FF 00 9F FF 00 E3 FF 00 E3 FF 00 B9 10 01 BA 10 01 67 D1 01 69 D1 01 6D D1 01 72 D1 01 7B'\r\n 'D1 01 82 D1 01 85 D1 01 8B D1 01 AA D1 01 AD D1 01 3B 14 00 00 00 B7 00 00 B7 00 00 D0 02 00 D1'\r\n '02 00 40 06 00 40 06 00 FA 07 00 FA 07 00 46 0E 00 46 0E 00 C6 0E 00 C6 0E 00 43 18 00 43 18 00'\r\n 'A7 1A 00 A7 1A 00 36 1C 00 36 1C 00 7B 1C 00 7B 1C 00 05 30 00 05 30 00 31 30 00 35 30 00 9D 30'\r\n '00 9E 30 00 FC 30 00 FE 30 00 15 A0 00 15 A0 00 0C A6 00 0C A6 00 CF A9 00 CF A9 00 70 AA 00 70'\r\n 'AA 00 DD AA 00 DD AA 00 70 FF 00 70 FF 00 3C 0A 00 00 00 2D 00 00 2D 00 00 AD 00 00 AD 00 00 8A'\r\n '05 00 8A 05 00 06 18 00 06 18 00 10 20 00 11 20 00 17 2E 00 17 2E 00 FB 30 00 FB 30 00 63 FE 00'\r\n '63 FE 00 0D FF 00 0D FF 00 65 FF 00 65 FF 00 3D 0C 00 00 00 06 30 00 07 30 00 21 30 00 29 30 00'\r\n '38 30 00 3A 30 00 00 34 00 B5 4D 00 00 4E 00 CB 9F 00 00 F9 00 2D FA 00 30 FA 00 6D FA 00 70 FA'\r\n '00 D9 FA 00 00 00 02 D6 A6 02 00 A7 02 34 B7 02 40 B7 02 1D B8 02 00 F8 02 1D FA 02 3E 02 00 00'\r\n '00 F0 2F 00 F1 2F 00 F4 2F 00 FB 2F 00 3F 01 00 00 00 F2 2F 00 F3 2F 00 40 01 00 00 00 0C 20 00'\r\n '0D 20 00 41 05 00 00 00 40 0E 00 44 0E 00 C0 0E 00 C4 0E 00 B5 AA 00 B6 AA 00 B9 AA 00 B9 AA 00'\r\n 'BB AA 00 BC AA 00 42 12 00 00 00 D0 FD 00 EF FD 00 FE FF 00 FF FF 00 FE FF 01 FF FF 01 FE FF 02'\r\n 'FF FF 02 FE FF 03 FF FF 03 FE FF 04 FF FF 04 FE FF 05 FF FF 05 FE FF 06 FF FF 06 FE FF 07 FF FF'\r\n '07 FE FF 08 FF FF 08 FE FF 09 FF FF 09 FE FF 0A FF FF 0A FE FF 0B FF FF 0B FE FF 0C FF FF 0C FE'\r\n 'FF 0D FF FF 0D FE FF 0E FF FF 0E FE FF 0F FF FF 0F FE FF 10 FF FF 10 43 91 00 00 00 45 03 00 45'\r\n '03 00 B0 05 00 BD 05 00 BF 05 00 BF 05 00 C1 05 00 C2 05 00 C4 05 00 C5 05 00 C7 05 00 C7 05 00'\r\n '10 06 00 1A 06 00 4B 06 00 57 06 00 59 06 00 5F 06 00 70 06 00 70 06 00 D6 06 00 DC 06 00 E1 06'\r\n '00 E4 06 00 E7 06 00 E8 06 00 ED 06 00 ED 06 00 11 07 00 11 07 00 30 07 00 3F 07 00 A6 07 00 B0'\r\n '07 00 16 08 00 17 08 00 1B 08 00 23 08 00 25 08 00 27 08 00 29 08 00 2C 08 00 00 09 00 03 09 00'\r\n '3A 09 00 3B 09 00 3E 09 00 4C 09 00 4E 09 00 4F 09 00 55 09 00 57 09 00 62 09 00 63 09 00 81 09'\r\n '00 83 09 00 BE 09 00 C4 09 00 C7 09 00 C8 09 00 CB 09 00 CC 09 00 D7 09 00 D7 09 00 E2 09 00 E3'\r\n '09 00 01 0A 00 03 0A 00 3E 0A 00 42 0A 00 47 0A 00 48 0A 00 4B 0A 00 4C 0A 00 51 0A 00 51 0A 00'\r\n '70 0A 00 71 0A 00 75 0A 00 75 0A 00 81 0A 00 83 0A 00 BE 0A 00 C5 0A 00 C7 0A 00 C9 0A 00 CB 0A'\r\n '00 CC 0A 00 E2 0A 00 E3 0A 00 01 0B 00 03 0B 00 3E 0B 00 44 0B 00 47 0B 00 48 0B 00 4B 0B 00 4C'\r\n '0B 00 56 0B 00 57 0B 00 62 0B 00 63 0B 00 82 0B 00 82 0B 00 BE 0B 00 C2 0B 00 C6 0B 00 C8 0B 00'\r\n 'CA 0B 00 CC 0B 00 D7 0B 00 D7 0B 00 01 0C 00 03 0C 00 3E 0C 00 44 0C 00 46 0C 00 48 0C 00 4A 0C'\r\n '00 4C 0C 00 55 0C 00 56 0C 00 62 0C 00 63 0C 00 82 0C 00 83 0C 00 BE 0C 00 C4 0C 00 C6 0C 00 C8'\r\n '0C 00 CA 0C 00 CC 0C 00 D5 0C 00 D6 0C 00 E2 0C 00 E3 0C 00 02 0D 00 03 0D 00 3E 0D 00 44 0D 00'\r\n '46 0D 00 48 0D 00 4A 0D 00 4C 0D 00 57 0D 00 57 0D 00 62 0D 00 63 0D 00 82 0D 00 83 0D 00 CF 0D'\r\n '00 D4 0D 00 D6 0D 00 D6 0D 00 D8 0D 00 DF 0D 00 F2 0D 00 F3 0D 00 31 0E 00 31 0E 00 34 0E 00 3A'\r\n '0E 00 4D 0E 00 4D 0E 00 B1 0E 00 B1 0E 00 B4 0E 00 B9 0E 00 BB 0E 00 BC 0E 00 CD 0E 00 CD 0E 00'\r\n '71 0F 00 81 0F 00 8D 0F 00 97 0F 00 99 0F 00 BC 0F 00 2B 10 00 36 10 00 38 10 00 38 10 00 3B 10'\r\n '00 3E 10 00 56 10 00 59 10 00 5E 10 00 60 10 00 62 10 00 62 10 00 67 10 00 68 10 00 71 10 00 74'\r\n '10 00 82 10 00 86 10 00 9C 10 00 9D 10 00 5F 13 00 5F 13 00 12 17 00 13 17 00 32 17 00 33 17 00'\r\n '52 17 00 53 17 00 72 17 00 73 17 00 B6 17 00 C8 17 00 A9 18 00 A9 18 00 20 19 00 2B 19 00 30 19'\r\n '00 38 19 00 B0 19 00 C0 19 00 C8 19 00 C9 19 00 17 1A 00 1B 1A 00 55 1A 00 5E 1A 00 61 1A 00 74'\r\n '1A 00 00 1B 00 04 1B 00 35 1B 00 43 1B 00 80 1B 00 82 1B 00 A1 1B 00 A9 1B 00 E7 1B 00 F1 1B 00'\r\n '24 1C 00 35 1C 00 F2 1C 00 F2 1C 00 B6 24 00 E9 24 00 E0 2D 00 FF 2D 00 23 A8 00 27 A8 00 80 A8'\r\n '00 81 A8 00 B4 A8 00 C3 A8 00 26 A9 00 2A A9 00 47 A9 00 52 A9 00 80 A9 00 83 A9 00 B4 A9 00 BF'\r\n 'A9 00 29 AA 00 36 AA 00 43 AA 00 43 AA 00 4C AA 00 4D AA 00 B0 AA 00 B0 AA 00 B2 AA 00 B4 AA 00'\r\n 'B7 AA 00 B8 AA 00 BE AA 00 BE AA 00 E3 AB 00 EA AB 00 1E FB 00 1E FB 00 01 0A 01 03 0A 01 05 0A'\r\n '01 06 0A 01 0C 0A 01 0F 0A 01 00 10 01 02 10 01 38 10 01 45 10 01 82 10 01 82 10 01 B0 10 01 B8'\r\n '10 01 44 0A 00 00 00 4F 03 00 4F 03 00 5F 11 00 60 11 00 65 20 00 69 20 00 64 31 00 64 31 00 A0'\r\n 'FF 00 A0 FF 00 F0 FF 00 F8 FF 00 00 00 0E 00 00 0E 02 00 0E 1F 00 0E 80 00 0E FF 00 0E F0 01 0E'\r\n 'FF 0F 0E 45 10 00 00 00 BE 09 00 BE 09 00 D7 09 00 D7 09 00 3E 0B 00 3E 0B 00 57 0B 00 57 0B 00'\r\n 'BE 0B 00 BE 0B 00 D7 0B 00 D7 0B 00 C2 0C 00 C2 0C 00 D5 0C 00 D6 0C 00 3E 0D 00 3E 0D 00 57 0D'\r\n '00 57 0D 00 CF 0D 00 CF 0D 00 DF 0D 00 DF 0D 00 0C 20 00 0D 20 00 9E FF 00 9F FF 00 65 D1 01 65'\r\n 'D1 01 6E D1 01 72 D1 01 46 04 00 00 00 B7 00 00 B7 00 00 87 03 00 87 03 00 69 13 00 71 13 00 DA'\r\n '19 00 DA 19 00 47 03 00 00 00 18 21 00 18 21 00 2E 21 00 2E 21 00 9B 30 00 9C 30 00 48 0D 00 00'\r\n '00 B0 02 00 B8 02 00 C0 02 00 C1 02 00 E0 02 00 E4 02 00 45 03 00 45 03 00 7A 03 00 7A 03 00 2C'\r\n '1D 00 61 1D 00 78 1D 00 78 1D 00 9B 1D 00 BF 1D 00 90 20 00 94 20 00 70 21 00 7F 21 00 D0 24 00'\r\n 'E9 24 00 7D 2C 00 7D 2C 00 70 A7 00 70 A7 00 49 64 00 00 00 5E 00 00 5E 00 00 D0 03 00 D2 03 00'\r\n 'D5 03 00 D5 03 00 F0 03 00 F1 03 00 F4 03 00 F5 03 00 16 20 00 16 20 00 32 20 00 34 20 00 40 20'\r\n '00 40 20 00 61 20 00 64 20 00 7D 20 00 7E 20 00 8D 20 00 8E 20 00 D0 20 00 DC 20 00 E1 20 00 E1'\r\n '20 00 E5 20 00 E6 20 00 EB 20 00 EF 20 00 02 21 00 02 21 00 07 21 00 07 21 00 0A 21 00 13 21 00'\r\n '15 21 00 15 21 00 19 21 00 1D 21 00 24 21 00 24 21 00 28 21 00 29 21 00 2C 21 00 2D 21 00 2F 21'\r\n '00 31 21 00 33 21 00 38 21 00 3C 21 00 3F 21 00 45 21 00 49 21 00 95 21 00 99 21 00 9C 21 00 9F'\r\n '21 00 A1 21 00 A2 21 00 A4 21 00 A5 21 00 A7 21 00 A7 21 00 A9 21 00 AD 21 00 B0 21 00 B1 21 00'\r\n 'B6 21 00 B7 21 00 BC 21 00 CD 21 00 D0 21 00 D1 21 00 D3 21 00 D3 21 00 D5 21 00 DB 21 00 DD 21'\r\n '00 DD 21 00 E4 21 00 E5 21 00 B4 23 00 B5 23 00 B7 23 00 B7 23 00 D0 23 00 D0 23 00 E2 23 00 E2'\r\n '23 00 A0 25 00 A1 25 00 AE 25 00 B6 25 00 BC 25 00 C0 25 00 C6 25 00 C7 25 00 CA 25 00 CB 25 00'\r\n 'CF 25 00 D3 25 00 E2 25 00 E2 25 00 E4 25 00 E4 25 00 E7 25 00 EC 25 00 05 26 00 06 26 00 40 26'\r\n '00 40 26 00 42 26 00 42 26 00 60 26 00 63 26 00 6D 26 00 6E 26 00 C5 27 00 C6 27 00 E6 27 00 EF'\r\n '27 00 83 29 00 98 29 00 D8 29 00 DB 29 00 FC 29 00 FD 29 00 61 FE 00 61 FE 00 63 FE 00 63 FE 00'\r\n '68 FE 00 68 FE 00 3C FF 00 3C FF 00 3E FF 00 3E FF 00 00 D4 01 54 D4 01 56 D4 01 9C D4 01 9E D4'\r\n '01 9F D4 01 A2 D4 01 A2 D4 01 A5 D4 01 A6 D4 01 A9 D4 01 AC D4 01 AE D4 01 B9 D4 01 BB D4 01 BB'\r\n 'D4 01 BD D4 01 C3 D4 01 C5 D4 01 05 D5 01 07 D5 01 0A D5 01 0D D5 01 14 D5 01 16 D5 01 1C D5 01'\r\n '1E D5 01 39 D5 01 3B D5 01 3E D5 01 40 D5 01 44 D5 01 46 D5 01 46 D5 01 4A D5 01 50 D5 01 52 D5'\r\n '01 A5 D6 01 A8 D6 01 C0 D6 01 C2 D6 01 DA D6 01 DC D6 01 FA D6 01 FC D6 01 14 D7 01 16 D7 01 34'\r\n 'D7 01 36 D7 01 4E D7 01 50 D7 01 6E D7 01 70 D7 01 88 D7 01 8A D7 01 A8 D7 01 AA D7 01 C2 D7 01'\r\n 'C4 D7 01 CB D7 01 CE D7 01 FF D7 01 4A 02 00 00 00 60 21 00 6F 21 00 B6 24 00 CF 24 00 4B 1C 00'\r\n '00 00 21 00 00 2F 00 00 3A 00 00 40 00 00 5B 00 00 5E 00 00 60 00 00 60 00 00 7B 00 00 7E 00 00'\r\n 'A1 00 00 A7 00 00 A9 00 00 A9 00 00 AB 00 00 AC 00 00 AE 00 00 AE 00 00 B0 00 00 B1 00 00 B6 00'\r\n '00 B6 00 00 BB 00 00 BB 00 00 BF 00 00 BF 00 00 D7 00 00 D7 00 00 F7 00 00 F7 00 00 10 20 00 27'\r\n '20 00 30 20 00 3E 20 00 41 20 00 53 20 00 55 20 00 5E 20 00 90 21 00 5F 24 00 00 25 00 75 27 00'\r\n '94 27 00 FF 2B 00 00 2E 00 7F 2E 00 01 30 00 03 30 00 08 30 00 20 30 00 30 30 00 30 30 00 3E FD'\r\n '00 3F FD 00 45 FE 00 46 FE 00 4C 05 00 00 00 09 00 00 0D 00 00 20 00 00 20 00 00 85 00 00 85 00'\r\n '00 0E 20 00 0F 20 00 28 20 00 29 20 00 4D 03 00 00 00 80 2E 00 99 2E 00 9B 2E 00 F3 2E 00 00 2F'\r\n '00 D5 2F 00 4E 1F 00 00 00 69 00 00 6A 00 00 2F 01 00 2F 01 00 49 02 00 49 02 00 68 02 00 68 02'\r\n '00 9D 02 00 9D 02 00 B2 02 00 B2 02 00 F3 03 00 F3 03 00 56 04 00 56 04 00 58 04 00 58 04 00 62'\r\n '1D 00 62 1D 00 96 1D 00 96 1D 00 A4 1D 00 A4 1D 00 A8 1D 00 A8 1D 00 2D 1E 00 2D 1E 00 CB 1E 00'\r\n 'CB 1E 00 71 20 00 71 20 00 48 21 00 49 21 00 7C 2C 00 7C 2C 00 22 D4 01 23 D4 01 56 D4 01 57 D4'\r\n '01 8A D4 01 8B D4 01 BE D4 01 BF D4 01 F2 D4 01 F3 D4 01 26 D5 01 27 D5 01 5A D5 01 5B D5 01 8E'\r\n 'D5 01 8F D5 01 C2 D5 01 C3 D5 01 F6 D5 01 F7 D5 01 2A D6 01 2B D6 01 5E D6 01 5F D6 01 92 D6 01'\r\n '93 D6 01 4F 2F 00 00 00 21 00 00 21 00 00 2E 00 00 2E 00 00 3F 00 00 3F 00 00 5C 05 00 5C 05 00'\r\n '5E 05 00 5E 05 00 89 05 00 89 05 00 1F 06 00 1F 06 00 D4 06 00 D4 06 00 00 07 00 02 07 00 F9 07'\r\n '00 F9 07 00 64 09 00 65 09 00 4A 10 00 4B 10 00 62 13 00 62 13 00 67 13 00 68 13 00 6E 16 00 6E'\r\n '16 00 35 17 00 36 17 00 03 18 00 03 18 00 09 18 00 09 18 00 44 19 00 45 19 00 A8 1A 00 AB 1A 00'\r\n '5A 1B 00 5B 1B 00 5E 1B 00 5F 1B 00 3B 1C 00 3C 1C 00 7E 1C 00 7F 1C 00 3C 20 00 3D 20 00 47 20'\r\n '00 49 20 00 2E 2E 00 2E 2E 00 02 30 00 02 30 00 FF A4 00 FF A4 00 0E A6 00 0F A6 00 F3 A6 00 F3'\r\n 'A6 00 F7 A6 00 F7 A6 00 76 A8 00 77 A8 00 CE A8 00 CF A8 00 2F A9 00 2F A9 00 C8 A9 00 C9 A9 00'\r\n '5D AA 00 5F AA 00 EB AB 00 EB AB 00 52 FE 00 52 FE 00 56 FE 00 57 FE 00 01 FF 00 01 FF 00 0E FF'\r\n '00 0E FF 00 1F FF 00 1F FF 00 61 FF 00 61 FF 00 56 0A 01 57 0A 01 47 10 01 48 10 01 BE 10 01 C1'\r\n '10 01 50 43 00 00 00 21 00 00 21 00 00 2C 00 00 2C 00 00 2E 00 00 2E 00 00 3A 00 00 3B 00 00 3F'\r\n '00 00 3F 00 00 7E 03 00 7E 03 00 87 03 00 87 03 00 89 05 00 89 05 00 C3 05 00 C3 05 00 0C 06 00'\r\n '0C 06 00 1B 06 00 1B 06 00 1F 06 00 1F 06 00 D4 06 00 D4 06 00 00 07 00 0A 07 00 0C 07 00 0C 07'\r\n '00 F8 07 00 F9 07 00 30 08 00 3E 08 00 5E 08 00 5E 08 00 64 09 00 65 09 00 5A 0E 00 5B 0E 00 08'\r\n '0F 00 08 0F 00 0D 0F 00 12 0F 00 4A 10 00 4B 10 00 61 13 00 68 13 00 6D 16 00 6E 16 00 EB 16 00'\r\n 'ED 16 00 D4 17 00 D6 17 00 DA 17 00 DA 17 00 02 18 00 05 18 00 08 18 00 09 18 00 44 19 00 45 19'\r\n '00 A8 1A 00 AB 1A 00 5A 1B 00 5B 1B 00 5D 1B 00 5F 1B 00 3B 1C 00 3F 1C 00 7E 1C 00 7F 1C 00 3C'\r\n '20 00 3D 20 00 47 20 00 49 20 00 2E 2E 00 2E 2E 00 01 30 00 02 30 00 FE A4 00 FF A4 00 0D A6 00'\r\n '0F A6 00 F3 A6 00 F7 A6 00 76 A8 00 77 A8 00 CE A8 00 CF A8 00 2F A9 00 2F A9 00 C7 A9 00 C9 A9'\r\n '00 5D AA 00 5F AA 00 DF AA 00 DF AA 00 EB AB 00 EB AB 00 50 FE 00 52 FE 00 54 FE 00 57 FE 00 01'\r\n 'FF 00 01 FF 00 0C FF 00 0C FF 00 0E FF 00 0E FF 00 1A FF 00 1B FF 00 1F FF 00 1F FF 00 61 FF 00'\r\n '61 FF 00 64 FF 00 64 FF 00 9F 03 01 9F 03 01 D0 03 01 D0 03 01 57 08 01 57 08 01 1F 09 01 1F 09'\r\n '01 3A 0B 01 3F 0B 01 47 10 01 4D 10 01 BE 10 01 C1 10 01 70 24 01 73 24 01 51 0C 00 00 00 00 34'\r\n '00 B5 4D 00 00 4E 00 CB 9F 00 0E FA 00 0F FA 00 11 FA 00 11 FA 00 13 FA 00 14 FA 00 1F FA 00 1F'\r\n 'FA 00 21 FA 00 21 FA 00 23 FA 00 24 FA 00 27 FA 00 29 FA 00 00 00 02 D6 A6 02 00 A7 02 34 B7 02'\r\n '40 B7 02 1D B8 02 52 03 00 00 00 0B 18 00 0D 18 00 00 FE 00 0F FE 00 00 01 0E EF 01 0E'\r\n}\r\n\r\n\r\nLANGUAGE 0,0 CASE UNICODEDATA LOADONCALL MOVEABLE DISCARDABLE\r\n{\r\n '51 08 00 00 41 00 00 01 61 00 00 01 61 00 00 00 00 42 00 00 01 62 00 00 01 62 00 00 00 00 43 00'\r\n '00 01 63 00 00 01 63 00 00 00 00 44 00 00 01 64 00 00 01 64 00 00 00 00 45 00 00 01 65 00 00 01'\r\n '65 00 00 00 00 46 00 00 01 66 00 00 01 66 00 00 00 00 47 00 00 01 67 00 00 01 67 00 00 00 00 48'\r\n '00 00 01 68 00 00 01 68 00 00 00 00 49 00 00 01 69 00 00 01 69 00 00 01 49 00 00 01 49 00 00 4A'\r\n '00 00 01 6A 00 00 01 6A 00 00 01 4A 00 00 01 4A 00 00 4B 00 00 01 6B 00 00 01 6B 00 00 00 00 4C'\r\n '00 00 01 6C 00 00 01 6C 00 00 00 00 4D 00 00 01 6D 00 00 01 6D 00 00 00 00 4E 00 00 01 6E 00 00'\r\n '01 6E 00 00 00 00 4F 00 00 01 6F 00 00 01 6F 00 00 00 00 50 00 00 01 70 00 00 01 70 00 00 00 00'\r\n '51 00 00 01 71 00 00 01 71 00 00 00 00 52 00 00 01 72 00 00 01 72 00 00 00 00 53 00 00 01 73 00'\r\n '00 01 73 00 00 00 00 54 00 00 01 74 00 00 01 74 00 00 00 00 55 00 00 01 75 00 00 01 75 00 00 00'\r\n '00 56 00 00 01 76 00 00 01 76 00 00 00 00 57 00 00 01 77 00 00 01 77 00 00 00 00 58 00 00 01 78'\r\n '00 00 01 78 00 00 00 00 59 00 00 01 79 00 00 01 79 00 00 00 00 5A 00 00 01 7A 00 00 01 7A 00 00'\r\n '00 00 61 00 00 00 00 01 41 00 00 01 41 00 00 62 00 00 00 00 01 42 00 00 01 42 00 00 63 00 00 00'\r\n '00 01 43 00 00 01 43 00 00 64 00 00 00 00 01 44 00 00 01 44 00 00 65 00 00 00 00 01 45 00 00 01'\r\n '45 00 00 66 00 00 00 00 01 46 00 00 01 46 00 00 67 00 00 00 00 01 47 00 00 01 47 00 00 68 00 00'\r\n '00 00 01 48 00 00 01 48 00 00 69 00 00 00 01 69 00 00 01 49 00 00 01 49 00 00 6A 00 00 00 00 01'\r\n '4A 00 00 01 4A 00 00 6B 00 00 00 00 01 4B 00 00 01 4B 00 00 6C 00 00 00 00 01 4C 00 00 01 4C 00'\r\n '00 6D 00 00 00 00 01 4D 00 00 01 4D 00 00 6E 00 00 00 00 01 4E 00 00 01 4E 00 00 6F 00 00 00 00'\r\n '01 4F 00 00 01 4F 00 00 70 00 00 00 00 01 50 00 00 01 50 00 00 71 00 00 00 00 01 51 00 00 01 51'\r\n '00 00 72 00 00 00 00 01 52 00 00 01 52 00 00 73 00 00 00 00 01 53 00 00 01 53 00 00 74 00 00 00'\r\n '00 01 54 00 00 01 54 00 00 75 00 00 00 00 01 55 00 00 01 55 00 00 76 00 00 00 00 01 56 00 00 01'\r\n '56 00 00 77 00 00 00 00 01 57 00 00 01 57 00 00 78 00 00 00 00 01 58 00 00 01 58 00 00 79 00 00'\r\n '00 00 01 59 00 00 01 59 00 00 7A 00 00 00 00 01 5A 00 00 01 5A 00 00 B5 00 00 01 BC 03 00 00 01'\r\n '9C 03 00 01 9C 03 00 C0 00 00 01 E0 00 00 01 E0 00 00 00 00 C1 00 00 01 E1 00 00 01 E1 00 00 00'\r\n '00 C2 00 00 01 E2 00 00 01 E2 00 00 00 00 C3 00 00 01 E3 00 00 01 E3 00 00 00 00 C4 00 00 01 E4'\r\n '00 00 01 E4 00 00 00 00 C5 00 00 01 E5 00 00 01 E5 00 00 00 00 C6 00 00 01 E6 00 00 01 E6 00 00'\r\n '00 00 C7 00 00 01 E7 00 00 01 E7 00 00 00 00 C8 00 00 01 E8 00 00 01 E8 00 00 00 00 C9 00 00 01'\r\n 'E9 00 00 01 E9 00 00 00 00 CA 00 00 01 EA 00 00 01 EA 00 00 00 00 CB 00 00 01 EB 00 00 01 EB 00'\r\n '00 00 00 CC 00 00 01 EC 00 00 01 EC 00 00 01 CC 00 00 01 CC 00 00 CD 00 00 01 ED 00 00 01 ED 00'\r\n '00 01 CD 00 00 01 CD 00 00 CE 00 00 01 EE 00 00 01 EE 00 00 00 00 CF 00 00 01 EF 00 00 01 EF 00'\r\n '00 00 00 D0 00 00 01 F0 00 00 01 F0 00 00 00 00 D1 00 00 01 F1 00 00 01 F1 00 00 00 00 D2 00 00'\r\n '01 F2 00 00 01 F2 00 00 00 00 D3 00 00 01 F3 00 00 01 F3 00 00 00 00 D4 00 00 01 F4 00 00 01 F4'\r\n '00 00 00 00 D5 00 00 01 F5 00 00 01 F5 00 00 00 00 D6 00 00 01 F6 00 00 01 F6 00 00 00 00 D8 00'\r\n '00 01 F8 00 00 01 F8 00 00 00 00 D9 00 00 01 F9 00 00 01 F9 00 00 00 00 DA 00 00 01 FA 00 00 01'\r\n 'FA 00 00 00 00 DB 00 00 01 FB 00 00 01 FB 00 00 00 00 DC 00 00 01 FC 00 00 01 FC 00 00 00 00 DD'\r\n '00 00 01 FD 00 00 01 FD 00 00 00 00 DE 00 00 01 FE 00 00 01 FE 00 00 00 00 DF 00 00 02 73 00 00'\r\n '73 00 00 01 DF 00 00 02 53 00 00 73 00 00 02 53 00 00 53 00 00 E0 00 00 00 00 01 C0 00 00 01 C0'\r\n '00 00 E1 00 00 00 00 01 C1 00 00 01 C1 00 00 E2 00 00 00 00 01 C2 00 00 01 C2 00 00 E3 00 00 00'\r\n '00 01 C3 00 00 01 C3 00 00 E4 00 00 00 00 01 C4 00 00 01 C4 00 00 E5 00 00 00 00 01 C5 00 00 01'\r\n 'C5 00 00 E6 00 00 00 00 01 C6 00 00 01 C6 00 00 E7 00 00 00 00 01 C7 00 00 01 C7 00 00 E8 00 00'\r\n '00 00 01 C8 00 00 01 C8 00 00 E9 00 00 00 00 01 C9 00 00 01 C9 00 00 EA 00 00 00 00 01 CA 00 00'\r\n '01 CA 00 00 EB 00 00 00 00 01 CB 00 00 01 CB 00 00 EC 00 00 00 00 01 CC 00 00 01 CC 00 00 ED 00'\r\n '00 00 00 01 CD 00 00 01 CD 00 00 EE 00 00 00 00 01 CE 00 00 01 CE 00 00 EF 00 00 00 00 01 CF 00'\r\n '00 01 CF 00 00 F0 00 00 00 00 01 D0 00 00 01 D0 00 00 F1 00 00 00 00 01 D1 00 00 01 D1 00 00 F2'\r\n '00 00 00 00 01 D2 00 00 01 D2 00 00 F3 00 00 00 00 01 D3 00 00 01 D3 00 00 F4 00 00 00 00 01 D4'\r\n '00 00 01 D4 00 00 F5 00 00 00 00 01 D5 00 00 01 D5 00 00 F6 00 00 00 00 01 D6 00 00 01 D6 00 00'\r\n 'F8 00 00 00 00 01 D8 00 00 01 D8 00 00 F9 00 00 00 00 01 D9 00 00 01 D9 00 00 FA 00 00 00 00 01'\r\n 'DA 00 00 01 DA 00 00 FB 00 00 00 00 01 DB 00 00 01 DB 00 00 FC 00 00 00 00 01 DC 00 00 01 DC 00'\r\n '00 FD 00 00 00 00 01 DD 00 00 01 DD 00 00 FE 00 00 00 00 01 DE 00 00 01 DE 00 00 FF 00 00 00 00'\r\n '01 78 01 00 01 78 01 00 00 01 00 01 01 01 00 01 01 01 00 00 00 01 01 00 00 00 01 00 01 00 01 00'\r\n '01 00 02 01 00 01 03 01 00 01 03 01 00 00 00 03 01 00 00 00 01 02 01 00 01 02 01 00 04 01 00 01'\r\n '05 01 00 01 05 01 00 00 00 05 01 00 00 00 01 04 01 00 01 04 01 00 06 01 00 01 07 01 00 01 07 01'\r\n '00 00 00 07 01 00 00 00 01 06 01 00 01 06 01 00 08 01 00 01 09 01 00 01 09 01 00 00 00 09 01 00'\r\n '00 00 01 08 01 00 01 08 01 00 0A 01 00 01 0B 01 00 01 0B 01 00 00 00 0B 01 00 00 00 01 0A 01 00'\r\n '01 0A 01 00 0C 01 00 01 0D 01 00 01 0D 01 00 00 00 0D 01 00 00 00 01 0C 01 00 01 0C 01 00 0E 01'\r\n '00 01 0F 01 00 01 0F 01 00 00 00 0F 01 00 00 00 01 0E 01 00 01 0E 01 00 10 01 00 01 11 01 00 01'\r\n '11 01 00 00 00 11 01 00 00 00 01 10 01 00 01 10 01 00 12 01 00 01 13 01 00 01 13 01 00 00 00 13'\r\n '01 00 00 00 01 12 01 00 01 12 01 00 14 01 00 01 15 01 00 01 15 01 00 00 00 15 01 00 00 00 01 14'\r\n '01 00 01 14 01 00 16 01 00 01 17 01 00 01 17 01 00 00 00 17 01 00 00 00 01 16 01 00 01 16 01 00'\r\n '18 01 00 01 19 01 00 01 19 01 00 00 00 19 01 00 00 00 01 18 01 00 01 18 01 00 1A 01 00 01 1B 01'\r\n '00 01 1B 01 00 00 00 1B 01 00 00 00 01 1A 01 00 01 1A 01 00 1C 01 00 01 1D 01 00 01 1D 01 00 00'\r\n '00 1D 01 00 00 00 01 1C 01 00 01 1C 01 00 1E 01 00 01 1F 01 00 01 1F 01 00 00 00 1F 01 00 00 00'\r\n '01 1E 01 00 01 1E 01 00 20 01 00 01 21 01 00 01 21 01 00 00 00 21 01 00 00 00 01 20 01 00 01 20'\r\n '01 00 22 01 00 01 23 01 00 01 23 01 00 00 00 23 01 00 00 00 01 22 01 00 01 22 01 00 24 01 00 01'\r\n '25 01 00 01 25 01 00 00 00 25 01 00 00 00 01 24 01 00 01 24 01 00 26 01 00 01 27 01 00 01 27 01'\r\n '00 00 00 27 01 00 00 00 01 26 01 00 01 26 01 00 28 01 00 01 29 01 00 01 29 01 00 01 28 01 00 01'\r\n '28 01 00 29 01 00 00 00 01 28 01 00 01 28 01 00 2A 01 00 01 2B 01 00 01 2B 01 00 00 00 2B 01 00'\r\n '00 00 01 2A 01 00 01 2A 01 00 2C 01 00 01 2D 01 00 01 2D 01 00 00 00 2D 01 00 00 00 01 2C 01 00'\r\n '01 2C 01 00 2E 01 00 01 2F 01 00 01 2F 01 00 01 2E 01 00 01 2E 01 00 2F 01 00 00 00 01 2E 01 00'\r\n '01 2E 01 00 30 01 00 02 69 00 00 07 03 00 01 69 00 00 01 30 01 00 01 30 01 00 31 01 00 00 00 01'\r\n '49 00 00 01 49 00 00 32 01 00 01 33 01 00 01 33 01 00 00 00 33 01 00 00 00 01 32 01 00 01 32 01'\r\n '00 34 01 00 01 35 01 00 01 35 01 00 00 00 35 01 00 00 00 01 34 01 00 01 34 01 00 36 01 00 01 37'\r\n '01 00 01 37 01 00 00 00 37 01 00 00 00 01 36 01 00 01 36 01 00 39 01 00 01 3A 01 00 01 3A 01 00'\r\n '00 00 3A 01 00 00 00 01 39 01 00 01 39 01 00 3B 01 00 01 3C 01 00 01 3C 01 00 00 00 3C 01 00 00'\r\n '00 01 3B 01 00 01 3B 01 00 3D 01 00 01 3E 01 00 01 3E 01 00 00 00 3E 01 00 00 00 01 3D 01 00 01'\r\n '3D 01 00 3F 01 00 01 40 01 00 01 40 01 00 00 00 40 01 00 00 00 01 3F 01 00 01 3F 01 00 41 01 00'\r\n '01 42 01 00 01 42 01 00 00 00 42 01 00 00 00 01 41 01 00 01 41 01 00 43 01 00 01 44 01 00 01 44'\r\n '01 00 00 00 44 01 00 00 00 01 43 01 00 01 43 01 00 45 01 00 01 46 01 00 01 46 01 00 00 00 46 01'\r\n '00 00 00 01 45 01 00 01 45 01 00 47 01 00 01 48 01 00 01 48 01 00 00 00 48 01 00 00 00 01 47 01'\r\n '00 01 47 01 00 49 01 00 02 BC 02 00 6E 00 00 01 49 01 00 02 BC 02 00 4E 00 00 02 BC 02 00 4E 00'\r\n '00 4A 01 00 01 4B 01 00 01 4B 01 00 00 00 4B 01 00 00 00 01 4A 01 00 01 4A 01 00 4C 01 00 01 4D'\r\n '01 00 01 4D 01 00 00 00 4D 01 00 00 00 01 4C 01 00 01 4C 01 00 4E 01 00 01 4F 01 00 01 4F 01 00'\r\n '00 00 4F 01 00 00 00 01 4E 01 00 01 4E 01 00 50 01 00 01 51 01 00 01 51 01 00 00 00 51 01 00 00'\r\n '00 01 50 01 00 01 50 01 00 52 01 00 01 53 01 00 01 53 01 00 00 00 53 01 00 00 00 01 52 01 00 01'\r\n '52 01 00 54 01 00 01 55 01 00 01 55 01 00 00 00 55 01 00 00 00 01 54 01 00 01 54 01 00 56 01 00'\r\n '01 57 01 00 01 57 01 00 00 00 57 01 00 00 00 01 56 01 00 01 56 01 00 58 01 00 01 59 01 00 01 59'\r\n '01 00 00 00 59 01 00 00 00 01 58 01 00 01 58 01 00 5A 01 00 01 5B 01 00 01 5B 01 00 00 00 5B 01'\r\n '00 00 00 01 5A 01 00 01 5A 01 00 5C 01 00 01 5D 01 00 01 5D 01 00 00 00 5D 01 00 00 00 01 5C 01'\r\n '00 01 5C 01 00 5E 01 00 01 5F 01 00 01 5F 01 00 00 00 5F 01 00 00 00 01 5E 01 00 01 5E 01 00 60'\r\n '01 00 01 61 01 00 01 61 01 00 00 00 61 01 00 00 00 01 60 01 00 01 60 01 00 62 01 00 01 63 01 00'\r\n '01 63 01 00 00 00 63 01 00 00 00 01 62 01 00 01 62 01 00 64 01 00 01 65 01 00 01 65 01 00 00 00'\r\n '65 01 00 00 00 01 64 01 00 01 64 01 00 66 01 00 01 67 01 00 01 67 01 00 00 00 67 01 00 00 00 01'\r\n '66 01 00 01 66 01 00 68 01 00 01 69 01 00 01 69 01 00 00 00 69 01 00 00 00 01 68 01 00 01 68 01'\r\n '00 6A 01 00 01 6B 01 00 01 6B 01 00 00 00 6B 01 00 00 00 01 6A 01 00 01 6A 01 00 6C 01 00 01 6D'\r\n '01 00 01 6D 01 00 00 00 6D 01 00 00 00 01 6C 01 00 01 6C 01 00 6E 01 00 01 6F 01 00 01 6F 01 00'\r\n '00 00 6F 01 00 00 00 01 6E 01 00 01 6E 01 00 70 01 00 01 71 01 00 01 71 01 00 00 00 71 01 00 00'\r\n '00 01 70 01 00 01 70 01 00 72 01 00 01 73 01 00 01 73 01 00 00 00 73 01 00 00 00 01 72 01 00 01'\r\n '72 01 00 74 01 00 01 75 01 00 01 75 01 00 00 00 75 01 00 00 00 01 74 01 00 01 74 01 00 76 01 00'\r\n '01 77 01 00 01 77 01 00 00 00 77 01 00 00 00 01 76 01 00 01 76 01 00 78 01 00 01 FF 00 00 01 FF'\r\n '00 00 00 00 79 01 00 01 7A 01 00 01 7A 01 00 00 00 7A 01 00 00 00 01 79 01 00 01 79 01 00 7B 01'\r\n '00 01 7C 01 00 01 7C 01 00 00 00 7C 01 00 00 00 01 7B 01 00 01 7B 01 00 7D 01 00 01 7E 01 00 01'\r\n '7E 01 00 00 00 7E 01 00 00 00 01 7D 01 00 01 7D 01 00 7F 01 00 01 73 00 00 00 01 53 00 00 01 53'\r\n '00 00 80 01 00 00 00 01 43 02 00 01 43 02 00 81 01 00 01 53 02 00 01 53 02 00 00 00 82 01 00 01'\r\n '83 01 00 01 83 01 00 00 00 83 01 00 00 00 01 82 01 00 01 82 01 00 84 01 00 01 85 01 00 01 85 01'\r\n '00 00 00 85 01 00 00 00 01 84 01 00 01 84 01 00 86 01 00 01 54 02 00 01 54 02 00 00 00 87 01 00'\r\n '01 88 01 00 01 88 01 00 00 00 88 01 00 00 00 01 87 01 00 01 87 01 00 89 01 00 01 56 02 00 01 56'\r\n '02 00 00 00 8A 01 00 01 57 02 00 01 57 02 00 00 00 8B 01 00 01 8C 01 00 01 8C 01 00 00 00 8C 01'\r\n '00 00 00 01 8B 01 00 01 8B 01 00 8E 01 00 01 DD 01 00 01 DD 01 00 00 00 8F 01 00 01 59 02 00 01'\r\n '59 02 00 00 00 90 01 00 01 5B 02 00 01 5B 02 00 00 00 91 01 00 01 92 01 00 01 92 01 00 00 00 92'\r\n '01 00 00 00 01 91 01 00 01 91 01 00 93 01 00 01 60 02 00 01 60 02 00 00 00 94 01 00 01 63 02 00'\r\n '01 63 02 00 00 00 95 01 00 00 00 01 F6 01 00 01 F6 01 00 96 01 00 01 69 02 00 01 69 02 00 00 00'\r\n '97 01 00 01 68 02 00 01 68 02 00 00 00 98 01 00 01 99 01 00 01 99 01 00 00 00 99 01 00 00 00 01'\r\n '98 01 00 01 98 01 00 9A 01 00 00 00 01 3D 02 00 01 3D 02 00 9C 01 00 01 6F 02 00 01 6F 02 00 00'\r\n '00 9D 01 00 01 72 02 00 01 72 02 00 00 00 9E 01 00 00 00 01 20 02 00 01 20 02 00 9F 01 00 01 75'\r\n '02 00 01 75 02 00 00 00 A0 01 00 01 A1 01 00 01 A1 01 00 00 00 A1 01 00 00 00 01 A0 01 00 01 A0'\r\n '01 00 A2 01 00 01 A3 01 00 01 A3 01 00 00 00 A3 01 00 00 00 01 A2 01 00 01 A2 01 00 A4 01 00 01'\r\n 'A5 01 00 01 A5 01 00 00 00 A5 01 00 00 00 01 A4 01 00 01 A4 01 00 A6 01 00 01 80 02 00 01 80 02'\r\n '00 00 00 A7 01 00 01 A8 01 00 01 A8 01 00 00 00 A8 01 00 00 00 01 A7 01 00 01 A7 01 00 A9 01 00'\r\n '01 83 02 00 01 83 02 00 00 00 AC 01 00 01 AD 01 00 01 AD 01 00 00 00 AD 01 00 00 00 01 AC 01 00'\r\n '01 AC 01 00 AE 01 00 01 88 02 00 01 88 02 00 00 00 AF 01 00 01 B0 01 00 01 B0 01 00 00 00 B0 01'\r\n '00 00 00 01 AF 01 00 01 AF 01 00 B1 01 00 01 8A 02 00 01 8A 02 00 00 00 B2 01 00 01 8B 02 00 01'\r\n '8B 02 00 00 00 B3 01 00 01 B4 01 00 01 B4 01 00 00 00 B4 01 00 00 00 01 B3 01 00 01 B3 01 00 B5'\r\n '01 00 01 B6 01 00 01 B6 01 00 00 00 B6 01 00 00 00 01 B5 01 00 01 B5 01 00 B7 01 00 01 92 02 00'\r\n '01 92 02 00 00 00 B8 01 00 01 B9 01 00 01 B9 01 00 00 00 B9 01 00 00 00 01 B8 01 00 01 B8 01 00'\r\n 'BC 01 00 01 BD 01 00 01 BD 01 00 00 00 BD 01 00 00 00 01 BC 01 00 01 BC 01 00 BF 01 00 00 00 01'\r\n 'F7 01 00 01 F7 01 00 C4 01 00 01 C6 01 00 01 C6 01 00 01 C5 01 00 00 C5 01 00 01 C6 01 00 01 C6'\r\n '01 00 01 C5 01 00 01 C4 01 00 C6 01 00 00 00 01 C5 01 00 01 C4 01 00 C7 01 00 01 C9 01 00 01 C9'\r\n '01 00 01 C8 01 00 00 C8 01 00 01 C9 01 00 01 C9 01 00 01 C8 01 00 01 C7 01 00 C9 01 00 00 00 01'\r\n 'C8 01 00 01 C7 01 00 CA 01 00 01 CC 01 00 01 CC 01 00 01 CB 01 00 00 CB 01 00 01 CC 01 00 01 CC'\r\n '01 00 01 CB 01 00 01 CA 01 00 CC 01 00 00 00 01 CB 01 00 01 CA 01 00 CD 01 00 01 CE 01 00 01 CE'\r\n '01 00 00 00 CE 01 00 00 00 01 CD 01 00 01 CD 01 00 CF 01 00 01 D0 01 00 01 D0 01 00 00 00 D0 01'\r\n '00 00 00 01 CF 01 00 01 CF 01 00 D1 01 00 01 D2 01 00 01 D2 01 00 00 00 D2 01 00 00 00 01 D1 01'\r\n '00 01 D1 01 00 D3 01 00 01 D4 01 00 01 D4 01 00 00 00 D4 01 00 00 00 01 D3 01 00 01 D3 01 00 D5'\r\n '01 00 01 D6 01 00 01 D6 01 00 00 00 D6 01 00 00 00 01 D5 01 00 01 D5 01 00 D7 01 00 01 D8 01 00'\r\n '01 D8 01 00 00 00 D8 01 00 00 00 01 D7 01 00 01 D7 01 00 D9 01 00 01 DA 01 00 01 DA 01 00 00 00'\r\n 'DA 01 00 00 00 01 D9 01 00 01 D9 01 00 DB 01 00 01 DC 01 00 01 DC 01 00 00 00 DC 01 00 00 00 01'\r\n 'DB 01 00 01 DB 01 00 DD 01 00 00 00 01 8E 01 00 01 8E 01 00 DE 01 00 01 DF 01 00 01 DF 01 00 00'\r\n '00 DF 01 00 00 00 01 DE 01 00 01 DE 01 00 E0 01 00 01 E1 01 00 01 E1 01 00 00 00 E1 01 00 00 00'\r\n '01 E0 01 00 01 E0 01 00 E2 01 00 01 E3 01 00 01 E3 01 00 00 00 E3 01 00 00 00 01 E2 01 00 01 E2'\r\n '01 00 E4 01 00 01 E5 01 00 01 E5 01 00 00 00 E5 01 00 00 00 01 E4 01 00 01 E4 01 00 E6 01 00 01'\r\n 'E7 01 00 01 E7 01 00 00 00 E7 01 00 00 00 01 E6 01 00 01 E6 01 00 E8 01 00 01 E9 01 00 01 E9 01'\r\n '00 00 00 E9 01 00 00 00 01 E8 01 00 01 E8 01 00 EA 01 00 01 EB 01 00 01 EB 01 00 00 00 EB 01 00'\r\n '00 00 01 EA 01 00 01 EA 01 00 EC 01 00 01 ED 01 00 01 ED 01 00 00 00 ED 01 00 00 00 01 EC 01 00'\r\n '01 EC 01 00 EE 01 00 01 EF 01 00 01 EF 01 00 00 00 EF 01 00 00 00 01 EE 01 00 01 EE 01 00 F0 01'\r\n '00 02 6A 00 00 0C 03 00 01 F0 01 00 02 4A 00 00 0C 03 00 02 4A 00 00 0C 03 00 F1 01 00 01 F3 01'\r\n '00 01 F3 01 00 01 F2 01 00 00 F2 01 00 01 F3 01 00 01 F3 01 00 01 F2 01 00 01 F1 01 00 F3 01 00'\r\n '00 00 01 F2 01 00 01 F1 01 00 F4 01 00 01 F5 01 00 01 F5 01 00 00 00 F5 01 00 00 00 01 F4 01 00'\r\n '01 F4 01 00 F6 01 00 01 95 01 00 01 95 01 00 00 00 F7 01 00 01 BF 01 00 01 BF 01 00 00 00 F8 01'\r\n '00 01 F9 01 00 01 F9 01 00 00 00 F9 01 00 00 00 01 F8 01 00 01 F8 01 00 FA 01 00 01 FB 01 00 01'\r\n 'FB 01 00 00 00 FB 01 00 00 00 01 FA 01 00 01 FA 01 00 FC 01 00 01 FD 01 00 01 FD 01 00 00 00 FD'\r\n '01 00 00 00 01 FC 01 00 01 FC 01 00 FE 01 00 01 FF 01 00 01 FF 01 00 00 00 FF 01 00 00 00 01 FE'\r\n '01 00 01 FE 01 00 00 02 00 01 01 02 00 01 01 02 00 00 00 01 02 00 00 00 01 00 02 00 01 00 02 00'\r\n '02 02 00 01 03 02 00 01 03 02 00 00 00 03 02 00 00 00 01 02 02 00 01 02 02 00 04 02 00 01 05 02'\r\n '00 01 05 02 00 00 00 05 02 00 00 00 01 04 02 00 01 04 02 00 06 02 00 01 07 02 00 01 07 02 00 00'\r\n '00 07 02 00 00 00 01 06 02 00 01 06 02 00 08 02 00 01 09 02 00 01 09 02 00 00 00 09 02 00 00 00'\r\n '01 08 02 00 01 08 02 00 0A 02 00 01 0B 02 00 01 0B 02 00 00 00 0B 02 00 00 00 01 0A 02 00 01 0A'\r\n '02 00 0C 02 00 01 0D 02 00 01 0D 02 00 00 00 0D 02 00 00 00 01 0C 02 00 01 0C 02 00 0E 02 00 01'\r\n '0F 02 00 01 0F 02 00 00 00 0F 02 00 00 00 01 0E 02 00 01 0E 02 00 10 02 00 01 11 02 00 01 11 02'\r\n '00 00 00 11 02 00 00 00 01 10 02 00 01 10 02 00 12 02 00 01 13 02 00 01 13 02 00 00 00 13 02 00'\r\n '00 00 01 12 02 00 01 12 02 00 14 02 00 01 15 02 00 01 15 02 00 00 00 15 02 00 00 00 01 14 02 00'\r\n '01 14 02 00 16 02 00 01 17 02 00 01 17 02 00 00 00 17 02 00 00 00 01 16 02 00 01 16 02 00 18 02'\r\n '00 01 19 02 00 01 19 02 00 00 00 19 02 00 00 00 01 18 02 00 01 18 02 00 1A 02 00 01 1B 02 00 01'\r\n '1B 02 00 00 00 1B 02 00 00 00 01 1A 02 00 01 1A 02 00 1C 02 00 01 1D 02 00 01 1D 02 00 00 00 1D'\r\n '02 00 00 00 01 1C 02 00 01 1C 02 00 1E 02 00 01 1F 02 00 01 1F 02 00 00 00 1F 02 00 00 00 01 1E'\r\n '02 00 01 1E 02 00 20 02 00 01 9E 01 00 01 9E 01 00 00 00 22 02 00 01 23 02 00 01 23 02 00 00 00'\r\n '23 02 00 00 00 01 22 02 00 01 22 02 00 24 02 00 01 25 02 00 01 25 02 00 00 00 25 02 00 00 00 01'\r\n '24 02 00 01 24 02 00 26 02 00 01 27 02 00 01 27 02 00 00 00 27 02 00 00 00 01 26 02 00 01 26 02'\r\n '00 28 02 00 01 29 02 00 01 29 02 00 00 00 29 02 00 00 00 01 28 02 00 01 28 02 00 2A 02 00 01 2B'\r\n '02 00 01 2B 02 00 00 00 2B 02 00 00 00 01 2A 02 00 01 2A 02 00 2C 02 00 01 2D 02 00 01 2D 02 00'\r\n '00 00 2D 02 00 00 00 01 2C 02 00 01 2C 02 00 2E 02 00 01 2F 02 00 01 2F 02 00 00 00 2F 02 00 00'\r\n '00 01 2E 02 00 01 2E 02 00 30 02 00 01 31 02 00 01 31 02 00 00 00 31 02 00 00 00 01 30 02 00 01'\r\n '30 02 00 32 02 00 01 33 02 00 01 33 02 00 00 00 33 02 00 00 00 01 32 02 00 01 32 02 00 3A 02 00'\r\n '01 65 2C 00 01 65 2C 00 00 00 3B 02 00 01 3C 02 00 01 3C 02 00 00 00 3C 02 00 00 00 01 3B 02 00'\r\n '01 3B 02 00 3D 02 00 01 9A 01 00 01 9A 01 00 00 00 3E 02 00 01 66 2C 00 01 66 2C 00 00 00 3F 02'\r\n '00 00 00 01 7E 2C 00 01 7E 2C 00 40 02 00 00 00 01 7F 2C 00 01 7F 2C 00 41 02 00 01 42 02 00 01'\r\n '42 02 00 00 00 42 02 00 00 00 01 41 02 00 01 41 02 00 43 02 00 01 80 01 00 01 80 01 00 00 00 44'\r\n '02 00 01 89 02 00 01 89 02 00 00 00 45 02 00 01 8C 02 00 01 8C 02 00 00 00 46 02 00 01 47 02 00'\r\n '01 47 02 00 00 00 47 02 00 00 00 01 46 02 00 01 46 02 00 48 02 00 01 49 02 00 01 49 02 00 00 00'\r\n '49 02 00 00 00 01 48 02 00 01 48 02 00 4A 02 00 01 4B 02 00 01 4B 02 00 00 00 4B 02 00 00 00 01'\r\n '4A 02 00 01 4A 02 00 4C 02 00 01 4D 02 00 01 4D 02 00 00 00 4D 02 00 00 00 01 4C 02 00 01 4C 02'\r\n '00 4E 02 00 01 4F 02 00 01 4F 02 00 00 00 4F 02 00 00 00 01 4E 02 00 01 4E 02 00 50 02 00 00 00'\r\n '01 6F 2C 00 01 6F 2C 00 51 02 00 00 00 01 6D 2C 00 01 6D 2C 00 52 02 00 00 00 01 70 2C 00 01 70'\r\n '2C 00 53 02 00 00 00 01 81 01 00 01 81 01 00 54 02 00 00 00 01 86 01 00 01 86 01 00 56 02 00 00'\r\n '00 01 89 01 00 01 89 01 00 57 02 00 00 00 01 8A 01 00 01 8A 01 00 59 02 00 00 00 01 8F 01 00 01'\r\n '8F 01 00 5B 02 00 00 00 01 90 01 00 01 90 01 00 60 02 00 00 00 01 93 01 00 01 93 01 00 63 02 00'\r\n '00 00 01 94 01 00 01 94 01 00 65 02 00 00 00 01 8D A7 00 01 8D A7 00 68 02 00 00 00 01 97 01 00'\r\n '01 97 01 00 69 02 00 00 00 01 96 01 00 01 96 01 00 6B 02 00 00 00 01 62 2C 00 01 62 2C 00 6F 02'\r\n '00 00 00 01 9C 01 00 01 9C 01 00 71 02 00 00 00 01 6E 2C 00 01 6E 2C 00 72 02 00 00 00 01 9D 01'\r\n '00 01 9D 01 00 75 02 00 00 00 01 9F 01 00 01 9F 01 00 7D 02 00 00 00 01 64 2C 00 01 64 2C 00 80'\r\n '02 00 00 00 01 A6 01 00 01 A6 01 00 83 02 00 00 00 01 A9 01 00 01 A9 01 00 88 02 00 00 00 01 AE'\r\n '01 00 01 AE 01 00 89 02 00 00 00 01 44 02 00 01 44 02 00 8A 02 00 00 00 01 B1 01 00 01 B1 01 00'\r\n '8B 02 00 00 00 01 B2 01 00 01 B2 01 00 8C 02 00 00 00 01 45 02 00 01 45 02 00 92 02 00 00 00 01'\r\n 'B7 01 00 01 B7 01 00 07 03 00 00 01 07 03 00 01 07 03 00 01 07 03 00 45 03 00 01 B9 03 00 00 01'\r\n '99 03 00 01 99 03 00 70 03 00 01 71 03 00 01 71 03 00 00 00 71 03 00 00 00 01 70 03 00 01 70 03'\r\n '00 72 03 00 01 73 03 00 01 73 03 00 00 00 73 03 00 00 00 01 72 03 00 01 72 03 00 76 03 00 01 77'\r\n '03 00 01 77 03 00 00 00 77 03 00 00 00 01 76 03 00 01 76 03 00 7B 03 00 00 00 01 FD 03 00 01 FD'\r\n '03 00 7C 03 00 00 00 01 FE 03 00 01 FE 03 00 7D 03 00 00 00 01 FF 03 00 01 FF 03 00 86 03 00 01'\r\n 'AC 03 00 01 AC 03 00 00 00 88 03 00 01 AD 03 00 01 AD 03 00 00 00 89 03 00 01 AE 03 00 01 AE 03'\r\n '00 00 00 8A 03 00 01 AF 03 00 01 AF 03 00 00 00 8C 03 00 01 CC 03 00 01 CC 03 00 00 00 8E 03 00'\r\n '01 CD 03 00 01 CD 03 00 00 00 8F 03 00 01 CE 03 00 01 CE 03 00 00 00 90 03 00 03 B9 03 00 08 03'\r\n '00 01 03 00 01 90 03 00 03 99 03 00 08 03 00 01 03 00 03 99 03 00 08 03 00 01 03 00 91 03 00 01'\r\n 'B1 03 00 01 B1 03 00 00 00 92 03 00 01 B2 03 00 01 B2 03 00 00 00 93 03 00 01 B3 03 00 01 B3 03'\r\n '00 00 00 94 03 00 01 B4 03 00 01 B4 03 00 00 00 95 03 00 01 B5 03 00 01 B5 03 00 00 00 96 03 00'\r\n '01 B6 03 00 01 B6 03 00 00 00 97 03 00 01 B7 03 00 01 B7 03 00 00 00 98 03 00 01 B8 03 00 01 B8'\r\n '03 00 00 00 99 03 00 01 B9 03 00 01 B9 03 00 00 00 9A 03 00 01 BA 03 00 01 BA 03 00 00 00 9B 03'\r\n '00 01 BB 03 00 01 BB 03 00 00 00 9C 03 00 01 BC 03 00 01 BC 03 00 00 00 9D 03 00 01 BD 03 00 01'\r\n 'BD 03 00 00 00 9E 03 00 01 BE 03 00 01 BE 03 00 00 00 9F 03 00 01 BF 03 00 01 BF 03 00 00 00 A0'\r\n '03 00 01 C0 03 00 01 C0 03 00 00 00 A1 03 00 01 C1 03 00 01 C1 03 00 00 00 A3 03 00 01 C3 03 00'\r\n '01 C3 03 00 01 A3 03 00 01 A3 03 00 A4 03 00 01 C4 03 00 01 C4 03 00 00 00 A5 03 00 01 C5 03 00'\r\n '01 C5 03 00 00 00 A6 03 00 01 C6 03 00 01 C6 03 00 00 00 A7 03 00 01 C7 03 00 01 C7 03 00 00 00'\r\n 'A8 03 00 01 C8 03 00 01 C8 03 00 00 00 A9 03 00 01 C9 03 00 01 C9 03 00 00 00 AA 03 00 01 CA 03'\r\n '00 01 CA 03 00 00 00 AB 03 00 01 CB 03 00 01 CB 03 00 00 00 AC 03 00 00 00 01 86 03 00 01 86 03'\r\n '00 AD 03 00 00 00 01 88 03 00 01 88 03 00 AE 03 00 00 00 01 89 03 00 01 89 03 00 AF 03 00 00 00'\r\n '01 8A 03 00 01 8A 03 00 B0 03 00 03 C5 03 00 08 03 00 01 03 00 01 B0 03 00 03 A5 03 00 08 03 00'\r\n '01 03 00 03 A5 03 00 08 03 00 01 03 00 B1 03 00 00 00 01 91 03 00 01 91 03 00 B2 03 00 00 00 01'\r\n '92 03 00 01 92 03 00 B3 03 00 00 00 01 93 03 00 01 93 03 00 B4 03 00 00 00 01 94 03 00 01 94 03'\r\n '00 B5 03 00 00 00 01 95 03 00 01 95 03 00 B6 03 00 00 00 01 96 03 00 01 96 03 00 B7 03 00 00 00'\r\n '01 97 03 00 01 97 03 00 B8 03 00 00 00 01 98 03 00 01 98 03 00 B9 03 00 00 00 01 99 03 00 01 99'\r\n '03 00 BA 03 00 00 00 01 9A 03 00 01 9A 03 00 BB 03 00 00 00 01 9B 03 00 01 9B 03 00 BC 03 00 00'\r\n '00 01 9C 03 00 01 9C 03 00 BD 03 00 00 00 01 9D 03 00 01 9D 03 00 BE 03 00 00 00 01 9E 03 00 01'\r\n '9E 03 00 BF 03 00 00 00 01 9F 03 00 01 9F 03 00 C0 03 00 00 00 01 A0 03 00 01 A0 03 00 C1 03 00'\r\n '00 00 01 A1 03 00 01 A1 03 00 C2 03 00 01 C3 03 00 00 01 A3 03 00 01 A3 03 00 C3 03 00 00 00 01'\r\n 'A3 03 00 01 A3 03 00 C4 03 00 00 00 01 A4 03 00 01 A4 03 00 C5 03 00 00 00 01 A5 03 00 01 A5 03'\r\n '00 C6 03 00 00 00 01 A6 03 00 01 A6 03 00 C7 03 00 00 00 01 A7 03 00 01 A7 03 00 C8 03 00 00 00'\r\n '01 A8 03 00 01 A8 03 00 C9 03 00 00 00 01 A9 03 00 01 A9 03 00 CA 03 00 00 00 01 AA 03 00 01 AA'\r\n '03 00 CB 03 00 00 00 01 AB 03 00 01 AB 03 00 CC 03 00 00 00 01 8C 03 00 01 8C 03 00 CD 03 00 00'\r\n '00 01 8E 03 00 01 8E 03 00 CE 03 00 00 00 01 8F 03 00 01 8F 03 00 CF 03 00 01 D7 03 00 01 D7 03'\r\n '00 00 00 D0 03 00 01 B2 03 00 00 01 92 03 00 01 92 03 00 D1 03 00 01 B8 03 00 00 01 98 03 00 01'\r\n '98 03 00 D5 03 00 01 C6 03 00 00 01 A6 03 00 01 A6 03 00 D6 03 00 01 C0 03 00 00 01 A0 03 00 01'\r\n 'A0 03 00 D7 03 00 00 00 01 CF 03 00 01 CF 03 00 D8 03 00 01 D9 03 00 01 D9 03 00 00 00 D9 03 00'\r\n '00 00 01 D8 03 00 01 D8 03 00 DA 03 00 01 DB 03 00 01 DB 03 00 00 00 DB 03 00 00 00 01 DA 03 00'\r\n '01 DA 03 00 DC 03 00 01 DD 03 00 01 DD 03 00 00 00 DD 03 00 00 00 01 DC 03 00 01 DC 03 00 DE 03'\r\n '00 01 DF 03 00 01 DF 03 00 00 00 DF 03 00 00 00 01 DE 03 00 01 DE 03 00 E0 03 00 01 E1 03 00 01'\r\n 'E1 03 00 00 00 E1 03 00 00 00 01 E0 03 00 01 E0 03 00 E2 03 00 01 E3 03 00 01 E3 03 00 00 00 E3'\r\n '03 00 00 00 01 E2 03 00 01 E2 03 00 E4 03 00 01 E5 03 00 01 E5 03 00 00 00 E5 03 00 00 00 01 E4'\r\n '03 00 01 E4 03 00 E6 03 00 01 E7 03 00 01 E7 03 00 00 00 E7 03 00 00 00 01 E6 03 00 01 E6 03 00'\r\n 'E8 03 00 01 E9 03 00 01 E9 03 00 00 00 E9 03 00 00 00 01 E8 03 00 01 E8 03 00 EA 03 00 01 EB 03'\r\n '00 01 EB 03 00 00 00 EB 03 00 00 00 01 EA 03 00 01 EA 03 00 EC 03 00 01 ED 03 00 01 ED 03 00 00'\r\n '00 ED 03 00 00 00 01 EC 03 00 01 EC 03 00 EE 03 00 01 EF 03 00 01 EF 03 00 00 00 EF 03 00 00 00'\r\n '01 EE 03 00 01 EE 03 00 F0 03 00 01 BA 03 00 00 01 9A 03 00 01 9A 03 00 F1 03 00 01 C1 03 00 00'\r\n '01 A1 03 00 01 A1 03 00 F2 03 00 00 00 01 F9 03 00 01 F9 03 00 F4 03 00 01 B8 03 00 01 B8 03 00'\r\n '00 00 F5 03 00 01 B5 03 00 00 01 95 03 00 01 95 03 00 F7 03 00 01 F8 03 00 01 F8 03 00 00 00 F8'\r\n '03 00 00 00 01 F7 03 00 01 F7 03 00 F9 03 00 01 F2 03 00 01 F2 03 00 00 00 FA 03 00 01 FB 03 00'\r\n '01 FB 03 00 00 00 FB 03 00 00 00 01 FA 03 00 01 FA 03 00 FD 03 00 01 7B 03 00 01 7B 03 00 00 00'\r\n 'FE 03 00 01 7C 03 00 01 7C 03 00 00 00 FF 03 00 01 7D 03 00 01 7D 03 00 00 00 00 04 00 01 50 04'\r\n '00 01 50 04 00 00 00 01 04 00 01 51 04 00 01 51 04 00 00 00 02 04 00 01 52 04 00 01 52 04 00 00'\r\n '00 03 04 00 01 53 04 00 01 53 04 00 00 00 04 04 00 01 54 04 00 01 54 04 00 00 00 05 04 00 01 55'\r\n '04 00 01 55 04 00 00 00 06 04 00 01 56 04 00 01 56 04 00 00 00 07 04 00 01 57 04 00 01 57 04 00'\r\n '00 00 08 04 00 01 58 04 00 01 58 04 00 00 00 09 04 00 01 59 04 00 01 59 04 00 00 00 0A 04 00 01'\r\n '5A 04 00 01 5A 04 00 00 00 0B 04 00 01 5B 04 00 01 5B 04 00 00 00 0C 04 00 01 5C 04 00 01 5C 04'\r\n '00 00 00 0D 04 00 01 5D 04 00 01 5D 04 00 00 00 0E 04 00 01 5E 04 00 01 5E 04 00 00 00 0F 04 00'\r\n '01 5F 04 00 01 5F 04 00 00 00 10 04 00 01 30 04 00 01 30 04 00 00 00 11 04 00 01 31 04 00 01 31'\r\n '04 00 00 00 12 04 00 01 32 04 00 01 32 04 00 00 00 13 04 00 01 33 04 00 01 33 04 00 00 00 14 04'\r\n '00 01 34 04 00 01 34 04 00 00 00 15 04 00 01 35 04 00 01 35 04 00 00 00 16 04 00 01 36 04 00 01'\r\n '36 04 00 00 00 17 04 00 01 37 04 00 01 37 04 00 00 00 18 04 00 01 38 04 00 01 38 04 00 00 00 19'\r\n '04 00 01 39 04 00 01 39 04 00 00 00 1A 04 00 01 3A 04 00 01 3A 04 00 00 00 1B 04 00 01 3B 04 00'\r\n '01 3B 04 00 00 00 1C 04 00 01 3C 04 00 01 3C 04 00 00 00 1D 04 00 01 3D 04 00 01 3D 04 00 00 00'\r\n '1E 04 00 01 3E 04 00 01 3E 04 00 00 00 1F 04 00 01 3F 04 00 01 3F 04 00 00 00 20 04 00 01 40 04'\r\n '00 01 40 04 00 00 00 21 04 00 01 41 04 00 01 41 04 00 00 00 22 04 00 01 42 04 00 01 42 04 00 00'\r\n '00 23 04 00 01 43 04 00 01 43 04 00 00 00 24 04 00 01 44 04 00 01 44 04 00 00 00 25 04 00 01 45'\r\n '04 00 01 45 04 00 00 00 26 04 00 01 46 04 00 01 46 04 00 00 00 27 04 00 01 47 04 00 01 47 04 00'\r\n '00 00 28 04 00 01 48 04 00 01 48 04 00 00 00 29 04 00 01 49 04 00 01 49 04 00 00 00 2A 04 00 01'\r\n '4A 04 00 01 4A 04 00 00 00 2B 04 00 01 4B 04 00 01 4B 04 00 00 00 2C 04 00 01 4C 04 00 01 4C 04'\r\n '00 00 00 2D 04 00 01 4D 04 00 01 4D 04 00 00 00 2E 04 00 01 4E 04 00 01 4E 04 00 00 00 2F 04 00'\r\n '01 4F 04 00 01 4F 04 00 00 00 30 04 00 00 00 01 10 04 00 01 10 04 00 31 04 00 00 00 01 11 04 00'\r\n '01 11 04 00 32 04 00 00 00 01 12 04 00 01 12 04 00 33 04 00 00 00 01 13 04 00 01 13 04 00 34 04'\r\n '00 00 00 01 14 04 00 01 14 04 00 35 04 00 00 00 01 15 04 00 01 15 04 00 36 04 00 00 00 01 16 04'\r\n '00 01 16 04 00 37 04 00 00 00 01 17 04 00 01 17 04 00 38 04 00 00 00 01 18 04 00 01 18 04 00 39'\r\n '04 00 00 00 01 19 04 00 01 19 04 00 3A 04 00 00 00 01 1A 04 00 01 1A 04 00 3B 04 00 00 00 01 1B'\r\n '04 00 01 1B 04 00 3C 04 00 00 00 01 1C 04 00 01 1C 04 00 3D 04 00 00 00 01 1D 04 00 01 1D 04 00'\r\n '3E 04 00 00 00 01 1E 04 00 01 1E 04 00 3F 04 00 00 00 01 1F 04 00 01 1F 04 00 40 04 00 00 00 01'\r\n '20 04 00 01 20 04 00 41 04 00 00 00 01 21 04 00 01 21 04 00 42 04 00 00 00 01 22 04 00 01 22 04'\r\n '00 43 04 00 00 00 01 23 04 00 01 23 04 00 44 04 00 00 00 01 24 04 00 01 24 04 00 45 04 00 00 00'\r\n '01 25 04 00 01 25 04 00 46 04 00 00 00 01 26 04 00 01 26 04 00 47 04 00 00 00 01 27 04 00 01 27'\r\n '04 00 48 04 00 00 00 01 28 04 00 01 28 04 00 49 04 00 00 00 01 29 04 00 01 29 04 00 4A 04 00 00'\r\n '00 01 2A 04 00 01 2A 04 00 4B 04 00 00 00 01 2B 04 00 01 2B 04 00 4C 04 00 00 00 01 2C 04 00 01'\r\n '2C 04 00 4D 04 00 00 00 01 2D 04 00 01 2D 04 00 4E 04 00 00 00 01 2E 04 00 01 2E 04 00 4F 04 00'\r\n '00 00 01 2F 04 00 01 2F 04 00 50 04 00 00 00 01 00 04 00 01 00 04 00 51 04 00 00 00 01 01 04 00'\r\n '01 01 04 00 52 04 00 00 00 01 02 04 00 01 02 04 00 53 04 00 00 00 01 03 04 00 01 03 04 00 54 04'\r\n '00 00 00 01 04 04 00 01 04 04 00 55 04 00 00 00 01 05 04 00 01 05 04 00 56 04 00 00 00 01 06 04'\r\n '00 01 06 04 00 57 04 00 00 00 01 07 04 00 01 07 04 00 58 04 00 00 00 01 08 04 00 01 08 04 00 59'\r\n '04 00 00 00 01 09 04 00 01 09 04 00 5A 04 00 00 00 01 0A 04 00 01 0A 04 00 5B 04 00 00 00 01 0B'\r\n '04 00 01 0B 04 00 5C 04 00 00 00 01 0C 04 00 01 0C 04 00 5D 04 00 00 00 01 0D 04 00 01 0D 04 00'\r\n '5E 04 00 00 00 01 0E 04 00 01 0E 04 00 5F 04 00 00 00 01 0F 04 00 01 0F 04 00 60 04 00 01 61 04'\r\n '00 01 61 04 00 00 00 61 04 00 00 00 01 60 04 00 01 60 04 00 62 04 00 01 63 04 00 01 63 04 00 00'\r\n '00 63 04 00 00 00 01 62 04 00 01 62 04 00 64 04 00 01 65 04 00 01 65 04 00 00 00 65 04 00 00 00'\r\n '01 64 04 00 01 64 04 00 66 04 00 01 67 04 00 01 67 04 00 00 00 67 04 00 00 00 01 66 04 00 01 66'\r\n '04 00 68 04 00 01 69 04 00 01 69 04 00 00 00 69 04 00 00 00 01 68 04 00 01 68 04 00 6A 04 00 01'\r\n '6B 04 00 01 6B 04 00 00 00 6B 04 00 00 00 01 6A 04 00 01 6A 04 00 6C 04 00 01 6D 04 00 01 6D 04'\r\n '00 00 00 6D 04 00 00 00 01 6C 04 00 01 6C 04 00 6E 04 00 01 6F 04 00 01 6F 04 00 00 00 6F 04 00'\r\n '00 00 01 6E 04 00 01 6E 04 00 70 04 00 01 71 04 00 01 71 04 00 00 00 71 04 00 00 00 01 70 04 00'\r\n '01 70 04 00 72 04 00 01 73 04 00 01 73 04 00 00 00 73 04 00 00 00 01 72 04 00 01 72 04 00 74 04'\r\n '00 01 75 04 00 01 75 04 00 00 00 75 04 00 00 00 01 74 04 00 01 74 04 00 76 04 00 01 77 04 00 01'\r\n '77 04 00 00 00 77 04 00 00 00 01 76 04 00 01 76 04 00 78 04 00 01 79 04 00 01 79 04 00 00 00 79'\r\n '04 00 00 00 01 78 04 00 01 78 04 00 7A 04 00 01 7B 04 00 01 7B 04 00 00 00 7B 04 00 00 00 01 7A'\r\n '04 00 01 7A 04 00 7C 04 00 01 7D 04 00 01 7D 04 00 00 00 7D 04 00 00 00 01 7C 04 00 01 7C 04 00'\r\n '7E 04 00 01 7F 04 00 01 7F 04 00 00 00 7F 04 00 00 00 01 7E 04 00 01 7E 04 00 80 04 00 01 81 04'\r\n '00 01 81 04 00 00 00 81 04 00 00 00 01 80 04 00 01 80 04 00 8A 04 00 01 8B 04 00 01 8B 04 00 00'\r\n '00 8B 04 00 00 00 01 8A 04 00 01 8A 04 00 8C 04 00 01 8D 04 00 01 8D 04 00 00 00 8D 04 00 00 00'\r\n '01 8C 04 00 01 8C 04 00 8E 04 00 01 8F 04 00 01 8F 04 00 00 00 8F 04 00 00 00 01 8E 04 00 01 8E'\r\n '04 00 90 04 00 01 91 04 00 01 91 04 00 00 00 91 04 00 00 00 01 90 04 00 01 90 04 00 92 04 00 01'\r\n '93 04 00 01 93 04 00 00 00 93 04 00 00 00 01 92 04 00 01 92 04 00 94 04 00 01 95 04 00 01 95 04'\r\n '00 00 00 95 04 00 00 00 01 94 04 00 01 94 04 00 96 04 00 01 97 04 00 01 97 04 00 00 00 97 04 00'\r\n '00 00 01 96 04 00 01 96 04 00 98 04 00 01 99 04 00 01 99 04 00 00 00 99 04 00 00 00 01 98 04 00'\r\n '01 98 04 00 9A 04 00 01 9B 04 00 01 9B 04 00 00 00 9B 04 00 00 00 01 9A 04 00 01 9A 04 00 9C 04'\r\n '00 01 9D 04 00 01 9D 04 00 00 00 9D 04 00 00 00 01 9C 04 00 01 9C 04 00 9E 04 00 01 9F 04 00 01'\r\n '9F 04 00 00 00 9F 04 00 00 00 01 9E 04 00 01 9E 04 00 A0 04 00 01 A1 04 00 01 A1 04 00 00 00 A1'\r\n '04 00 00 00 01 A0 04 00 01 A0 04 00 A2 04 00 01 A3 04 00 01 A3 04 00 00 00 A3 04 00 00 00 01 A2'\r\n '04 00 01 A2 04 00 A4 04 00 01 A5 04 00 01 A5 04 00 00 00 A5 04 00 00 00 01 A4 04 00 01 A4 04 00'\r\n 'A6 04 00 01 A7 04 00 01 A7 04 00 00 00 A7 04 00 00 00 01 A6 04 00 01 A6 04 00 A8 04 00 01 A9 04'\r\n '00 01 A9 04 00 00 00 A9 04 00 00 00 01 A8 04 00 01 A8 04 00 AA 04 00 01 AB 04 00 01 AB 04 00 00'\r\n '00 AB 04 00 00 00 01 AA 04 00 01 AA 04 00 AC 04 00 01 AD 04 00 01 AD 04 00 00 00 AD 04 00 00 00'\r\n '01 AC 04 00 01 AC 04 00 AE 04 00 01 AF 04 00 01 AF 04 00 00 00 AF 04 00 00 00 01 AE 04 00 01 AE'\r\n '04 00 B0 04 00 01 B1 04 00 01 B1 04 00 00 00 B1 04 00 00 00 01 B0 04 00 01 B0 04 00 B2 04 00 01'\r\n 'B3 04 00 01 B3 04 00 00 00 B3 04 00 00 00 01 B2 04 00 01 B2 04 00 B4 04 00 01 B5 04 00 01 B5 04'\r\n '00 00 00 B5 04 00 00 00 01 B4 04 00 01 B4 04 00 B6 04 00 01 B7 04 00 01 B7 04 00 00 00 B7 04 00'\r\n '00 00 01 B6 04 00 01 B6 04 00 B8 04 00 01 B9 04 00 01 B9 04 00 00 00 B9 04 00 00 00 01 B8 04 00'\r\n '01 B8 04 00 BA 04 00 01 BB 04 00 01 BB 04 00 00 00 BB 04 00 00 00 01 BA 04 00 01 BA 04 00 BC 04'\r\n '00 01 BD 04 00 01 BD 04 00 00 00 BD 04 00 00 00 01 BC 04 00 01 BC 04 00 BE 04 00 01 BF 04 00 01'\r\n 'BF 04 00 00 00 BF 04 00 00 00 01 BE 04 00 01 BE 04 00 C0 04 00 01 CF 04 00 01 CF 04 00 00 00 C1'\r\n '04 00 01 C2 04 00 01 C2 04 00 00 00 C2 04 00 00 00 01 C1 04 00 01 C1 04 00 C3 04 00 01 C4 04 00'\r\n '01 C4 04 00 00 00 C4 04 00 00 00 01 C3 04 00 01 C3 04 00 C5 04 00 01 C6 04 00 01 C6 04 00 00 00'\r\n 'C6 04 00 00 00 01 C5 04 00 01 C5 04 00 C7 04 00 01 C8 04 00 01 C8 04 00 00 00 C8 04 00 00 00 01'\r\n 'C7 04 00 01 C7 04 00 C9 04 00 01 CA 04 00 01 CA 04 00 00 00 CA 04 00 00 00 01 C9 04 00 01 C9 04'\r\n '00 CB 04 00 01 CC 04 00 01 CC 04 00 00 00 CC 04 00 00 00 01 CB 04 00 01 CB 04 00 CD 04 00 01 CE'\r\n '04 00 01 CE 04 00 00 00 CE 04 00 00 00 01 CD 04 00 01 CD 04 00 CF 04 00 00 00 01 C0 04 00 01 C0'\r\n '04 00 D0 04 00 01 D1 04 00 01 D1 04 00 00 00 D1 04 00 00 00 01 D0 04 00 01 D0 04 00 D2 04 00 01'\r\n 'D3 04 00 01 D3 04 00 00 00 D3 04 00 00 00 01 D2 04 00 01 D2 04 00 D4 04 00 01 D5 04 00 01 D5 04'\r\n '00 00 00 D5 04 00 00 00 01 D4 04 00 01 D4 04 00 D6 04 00 01 D7 04 00 01 D7 04 00 00 00 D7 04 00'\r\n '00 00 01 D6 04 00 01 D6 04 00 D8 04 00 01 D9 04 00 01 D9 04 00 00 00 D9 04 00 00 00 01 D8 04 00'\r\n '01 D8 04 00 DA 04 00 01 DB 04 00 01 DB 04 00 00 00 DB 04 00 00 00 01 DA 04 00 01 DA 04 00 DC 04'\r\n '00 01 DD 04 00 01 DD 04 00 00 00 DD 04 00 00 00 01 DC 04 00 01 DC 04 00 DE 04 00 01 DF 04 00 01'\r\n 'DF 04 00 00 00 DF 04 00 00 00 01 DE 04 00 01 DE 04 00 E0 04 00 01 E1 04 00 01 E1 04 00 00 00 E1'\r\n '04 00 00 00 01 E0 04 00 01 E0 04 00 E2 04 00 01 E3 04 00 01 E3 04 00 00 00 E3 04 00 00 00 01 E2'\r\n '04 00 01 E2 04 00 E4 04 00 01 E5 04 00 01 E5 04 00 00 00 E5 04 00 00 00 01 E4 04 00 01 E4 04 00'\r\n 'E6 04 00 01 E7 04 00 01 E7 04 00 00 00 E7 04 00 00 00 01 E6 04 00 01 E6 04 00 E8 04 00 01 E9 04'\r\n '00 01 E9 04 00 00 00 E9 04 00 00 00 01 E8 04 00 01 E8 04 00 EA 04 00 01 EB 04 00 01 EB 04 00 00'\r\n '00 EB 04 00 00 00 01 EA 04 00 01 EA 04 00 EC 04 00 01 ED 04 00 01 ED 04 00 00 00 ED 04 00 00 00'\r\n '01 EC 04 00 01 EC 04 00 EE 04 00 01 EF 04 00 01 EF 04 00 00 00 EF 04 00 00 00 01 EE 04 00 01 EE'\r\n '04 00 F0 04 00 01 F1 04 00 01 F1 04 00 00 00 F1 04 00 00 00 01 F0 04 00 01 F0 04 00 F2 04 00 01'\r\n 'F3 04 00 01 F3 04 00 00 00 F3 04 00 00 00 01 F2 04 00 01 F2 04 00 F4 04 00 01 F5 04 00 01 F5 04'\r\n '00 00 00 F5 04 00 00 00 01 F4 04 00 01 F4 04 00 F6 04 00 01 F7 04 00 01 F7 04 00 00 00 F7 04 00'\r\n '00 00 01 F6 04 00 01 F6 04 00 F8 04 00 01 F9 04 00 01 F9 04 00 00 00 F9 04 00 00 00 01 F8 04 00'\r\n '01 F8 04 00 FA 04 00 01 FB 04 00 01 FB 04 00 00 00 FB 04 00 00 00 01 FA 04 00 01 FA 04 00 FC 04'\r\n '00 01 FD 04 00 01 FD 04 00 00 00 FD 04 00 00 00 01 FC 04 00 01 FC 04 00 FE 04 00 01 FF 04 00 01'\r\n 'FF 04 00 00 00 FF 04 00 00 00 01 FE 04 00 01 FE 04 00 00 05 00 01 01 05 00 01 01 05 00 00 00 01'\r\n '05 00 00 00 01 00 05 00 01 00 05 00 02 05 00 01 03 05 00 01 03 05 00 00 00 03 05 00 00 00 01 02'\r\n '05 00 01 02 05 00 04 05 00 01 05 05 00 01 05 05 00 00 00 05 05 00 00 00 01 04 05 00 01 04 05 00'\r\n '06 05 00 01 07 05 00 01 07 05 00 00 00 07 05 00 00 00 01 06 05 00 01 06 05 00 08 05 00 01 09 05'\r\n '00 01 09 05 00 00 00 09 05 00 00 00 01 08 05 00 01 08 05 00 0A 05 00 01 0B 05 00 01 0B 05 00 00'\r\n '00 0B 05 00 00 00 01 0A 05 00 01 0A 05 00 0C 05 00 01 0D 05 00 01 0D 05 00 00 00 0D 05 00 00 00'\r\n '01 0C 05 00 01 0C 05 00 0E 05 00 01 0F 05 00 01 0F 05 00 00 00 0F 05 00 00 00 01 0E 05 00 01 0E'\r\n '05 00 10 05 00 01 11 05 00 01 11 05 00 00 00 11 05 00 00 00 01 10 05 00 01 10 05 00 12 05 00 01'\r\n '13 05 00 01 13 05 00 00 00 13 05 00 00 00 01 12 05 00 01 12 05 00 14 05 00 01 15 05 00 01 15 05'\r\n '00 00 00 15 05 00 00 00 01 14 05 00 01 14 05 00 16 05 00 01 17 05 00 01 17 05 00 00 00 17 05 00'\r\n '00 00 01 16 05 00 01 16 05 00 18 05 00 01 19 05 00 01 19 05 00 00 00 19 05 00 00 00 01 18 05 00'\r\n '01 18 05 00 1A 05 00 01 1B 05 00 01 1B 05 00 00 00 1B 05 00 00 00 01 1A 05 00 01 1A 05 00 1C 05'\r\n '00 01 1D 05 00 01 1D 05 00 00 00 1D 05 00 00 00 01 1C 05 00 01 1C 05 00 1E 05 00 01 1F 05 00 01'\r\n '1F 05 00 00 00 1F 05 00 00 00 01 1E 05 00 01 1E 05 00 20 05 00 01 21 05 00 01 21 05 00 00 00 21'\r\n '05 00 00 00 01 20 05 00 01 20 05 00 22 05 00 01 23 05 00 01 23 05 00 00 00 23 05 00 00 00 01 22'\r\n '05 00 01 22 05 00 24 05 00 01 25 05 00 01 25 05 00 00 00 25 05 00 00 00 01 24 05 00 01 24 05 00'\r\n '26 05 00 01 27 05 00 01 27 05 00 00 00 27 05 00 00 00 01 26 05 00 01 26 05 00 31 05 00 01 61 05'\r\n '00 01 61 05 00 00 00 32 05 00 01 62 05 00 01 62 05 00 00 00 33 05 00 01 63 05 00 01 63 05 00 00'\r\n '00 34 05 00 01 64 05 00 01 64 05 00 00 00 35 05 00 01 65 05 00 01 65 05 00 00 00 36 05 00 01 66'\r\n '05 00 01 66 05 00 00 00 37 05 00 01 67 05 00 01 67 05 00 00 00 38 05 00 01 68 05 00 01 68 05 00'\r\n '00 00 39 05 00 01 69 05 00 01 69 05 00 00 00 3A 05 00 01 6A 05 00 01 6A 05 00 00 00 3B 05 00 01'\r\n '6B 05 00 01 6B 05 00 00 00 3C 05 00 01 6C 05 00 01 6C 05 00 00 00 3D 05 00 01 6D 05 00 01 6D 05'\r\n '00 00 00 3E 05 00 01 6E 05 00 01 6E 05 00 00 00 3F 05 00 01 6F 05 00 01 6F 05 00 00 00 40 05 00'\r\n '01 70 05 00 01 70 05 00 00 00 41 05 00 01 71 05 00 01 71 05 00 00 00 42 05 00 01 72 05 00 01 72'\r\n '05 00 00 00 43 05 00 01 73 05 00 01 73 05 00 00 00 44 05 00 01 74 05 00 01 74 05 00 00 00 45 05'\r\n '00 01 75 05 00 01 75 05 00 00 00 46 05 00 01 76 05 00 01 76 05 00 00 00 47 05 00 01 77 05 00 01'\r\n '77 05 00 00 00 48 05 00 01 78 05 00 01 78 05 00 00 00 49 05 00 01 79 05 00 01 79 05 00 00 00 4A'\r\n '05 00 01 7A 05 00 01 7A 05 00 00 00 4B 05 00 01 7B 05 00 01 7B 05 00 00 00 4C 05 00 01 7C 05 00'\r\n '01 7C 05 00 00 00 4D 05 00 01 7D 05 00 01 7D 05 00 00 00 4E 05 00 01 7E 05 00 01 7E 05 00 00 00'\r\n '4F 05 00 01 7F 05 00 01 7F 05 00 00 00 50 05 00 01 80 05 00 01 80 05 00 00 00 51 05 00 01 81 05'\r\n '00 01 81 05 00 00 00 52 05 00 01 82 05 00 01 82 05 00 00 00 53 05 00 01 83 05 00 01 83 05 00 00'\r\n '00 54 05 00 01 84 05 00 01 84 05 00 00 00 55 05 00 01 85 05 00 01 85 05 00 00 00 56 05 00 01 86'\r\n '05 00 01 86 05 00 00 00 61 05 00 00 00 01 31 05 00 01 31 05 00 62 05 00 00 00 01 32 05 00 01 32'\r\n '05 00 63 05 00 00 00 01 33 05 00 01 33 05 00 64 05 00 00 00 01 34 05 00 01 34 05 00 65 05 00 00'\r\n '00 01 35 05 00 01 35 05 00 66 05 00 00 00 01 36 05 00 01 36 05 00 67 05 00 00 00 01 37 05 00 01'\r\n '37 05 00 68 05 00 00 00 01 38 05 00 01 38 05 00 69 05 00 00 00 01 39 05 00 01 39 05 00 6A 05 00'\r\n '00 00 01 3A 05 00 01 3A 05 00 6B 05 00 00 00 01 3B 05 00 01 3B 05 00 6C 05 00 00 00 01 3C 05 00'\r\n '01 3C 05 00 6D 05 00 00 00 01 3D 05 00 01 3D 05 00 6E 05 00 00 00 01 3E 05 00 01 3E 05 00 6F 05'\r\n '00 00 00 01 3F 05 00 01 3F 05 00 70 05 00 00 00 01 40 05 00 01 40 05 00 71 05 00 00 00 01 41 05'\r\n '00 01 41 05 00 72 05 00 00 00 01 42 05 00 01 42 05 00 73 05 00 00 00 01 43 05 00 01 43 05 00 74'\r\n '05 00 00 00 01 44 05 00 01 44 05 00 75 05 00 00 00 01 45 05 00 01 45 05 00 76 05 00 00 00 01 46'\r\n '05 00 01 46 05 00 77 05 00 00 00 01 47 05 00 01 47 05 00 78 05 00 00 00 01 48 05 00 01 48 05 00'\r\n '79 05 00 00 00 01 49 05 00 01 49 05 00 7A 05 00 00 00 01 4A 05 00 01 4A 05 00 7B 05 00 00 00 01'\r\n '4B 05 00 01 4B 05 00 7C 05 00 00 00 01 4C 05 00 01 4C 05 00 7D 05 00 00 00 01 4D 05 00 01 4D 05'\r\n '00 7E 05 00 00 00 01 4E 05 00 01 4E 05 00 7F 05 00 00 00 01 4F 05 00 01 4F 05 00 80 05 00 00 00'\r\n '01 50 05 00 01 50 05 00 81 05 00 00 00 01 51 05 00 01 51 05 00 82 05 00 00 00 01 52 05 00 01 52'\r\n '05 00 83 05 00 00 00 01 53 05 00 01 53 05 00 84 05 00 00 00 01 54 05 00 01 54 05 00 85 05 00 00'\r\n '00 01 55 05 00 01 55 05 00 86 05 00 00 00 01 56 05 00 01 56 05 00 87 05 00 02 65 05 00 82 05 00'\r\n '01 87 05 00 02 35 05 00 82 05 00 02 35 05 00 52 05 00 A0 10 00 01 00 2D 00 01 00 2D 00 00 00 A1'\r\n '10 00 01 01 2D 00 01 01 2D 00 00 00 A2 10 00 01 02 2D 00 01 02 2D 00 00 00 A3 10 00 01 03 2D 00'\r\n '01 03 2D 00 00 00 A4 10 00 01 04 2D 00 01 04 2D 00 00 00 A5 10 00 01 05 2D 00 01 05 2D 00 00 00'\r\n 'A6 10 00 01 06 2D 00 01 06 2D 00 00 00 A7 10 00 01 07 2D 00 01 07 2D 00 00 00 A8 10 00 01 08 2D'\r\n '00 01 08 2D 00 00 00 A9 10 00 01 09 2D 00 01 09 2D 00 00 00 AA 10 00 01 0A 2D 00 01 0A 2D 00 00'\r\n '00 AB 10 00 01 0B 2D 00 01 0B 2D 00 00 00 AC 10 00 01 0C 2D 00 01 0C 2D 00 00 00 AD 10 00 01 0D'\r\n '2D 00 01 0D 2D 00 00 00 AE 10 00 01 0E 2D 00 01 0E 2D 00 00 00 AF 10 00 01 0F 2D 00 01 0F 2D 00'\r\n '00 00 B0 10 00 01 10 2D 00 01 10 2D 00 00 00 B1 10 00 01 11 2D 00 01 11 2D 00 00 00 B2 10 00 01'\r\n '12 2D 00 01 12 2D 00 00 00 B3 10 00 01 13 2D 00 01 13 2D 00 00 00 B4 10 00 01 14 2D 00 01 14 2D'\r\n '00 00 00 B5 10 00 01 15 2D 00 01 15 2D 00 00 00 B6 10 00 01 16 2D 00 01 16 2D 00 00 00 B7 10 00'\r\n '01 17 2D 00 01 17 2D 00 00 00 B8 10 00 01 18 2D 00 01 18 2D 00 00 00 B9 10 00 01 19 2D 00 01 19'\r\n '2D 00 00 00 BA 10 00 01 1A 2D 00 01 1A 2D 00 00 00 BB 10 00 01 1B 2D 00 01 1B 2D 00 00 00 BC 10'\r\n '00 01 1C 2D 00 01 1C 2D 00 00 00 BD 10 00 01 1D 2D 00 01 1D 2D 00 00 00 BE 10 00 01 1E 2D 00 01'\r\n '1E 2D 00 00 00 BF 10 00 01 1F 2D 00 01 1F 2D 00 00 00 C0 10 00 01 20 2D 00 01 20 2D 00 00 00 C1'\r\n '10 00 01 21 2D 00 01 21 2D 00 00 00 C2 10 00 01 22 2D 00 01 22 2D 00 00 00 C3 10 00 01 23 2D 00'\r\n '01 23 2D 00 00 00 C4 10 00 01 24 2D 00 01 24 2D 00 00 00 C5 10 00 01 25 2D 00 01 25 2D 00 00 00'\r\n '79 1D 00 00 00 01 7D A7 00 01 7D A7 00 7D 1D 00 00 00 01 63 2C 00 01 63 2C 00 00 1E 00 01 01 1E'\r\n '00 01 01 1E 00 00 00 01 1E 00 00 00 01 00 1E 00 01 00 1E 00 02 1E 00 01 03 1E 00 01 03 1E 00 00'\r\n '00 03 1E 00 00 00 01 02 1E 00 01 02 1E 00 04 1E 00 01 05 1E 00 01 05 1E 00 00 00 05 1E 00 00 00'\r\n '01 04 1E 00 01 04 1E 00 06 1E 00 01 07 1E 00 01 07 1E 00 00 00 07 1E 00 00 00 01 06 1E 00 01 06'\r\n '1E 00 08 1E 00 01 09 1E 00 01 09 1E 00 00 00 09 1E 00 00 00 01 08 1E 00 01 08 1E 00 0A 1E 00 01'\r\n '0B 1E 00 01 0B 1E 00 00 00 0B 1E 00 00 00 01 0A 1E 00 01 0A 1E 00 0C 1E 00 01 0D 1E 00 01 0D 1E'\r\n '00 00 00 0D 1E 00 00 00 01 0C 1E 00 01 0C 1E 00 0E 1E 00 01 0F 1E 00 01 0F 1E 00 00 00 0F 1E 00'\r\n '00 00 01 0E 1E 00 01 0E 1E 00 10 1E 00 01 11 1E 00 01 11 1E 00 00 00 11 1E 00 00 00 01 10 1E 00'\r\n '01 10 1E 00 12 1E 00 01 13 1E 00 01 13 1E 00 00 00 13 1E 00 00 00 01 12 1E 00 01 12 1E 00 14 1E'\r\n '00 01 15 1E 00 01 15 1E 00 00 00 15 1E 00 00 00 01 14 1E 00 01 14 1E 00 16 1E 00 01 17 1E 00 01'\r\n '17 1E 00 00 00 17 1E 00 00 00 01 16 1E 00 01 16 1E 00 18 1E 00 01 19 1E 00 01 19 1E 00 00 00 19'\r\n '1E 00 00 00 01 18 1E 00 01 18 1E 00 1A 1E 00 01 1B 1E 00 01 1B 1E 00 00 00 1B 1E 00 00 00 01 1A'\r\n '1E 00 01 1A 1E 00 1C 1E 00 01 1D 1E 00 01 1D 1E 00 00 00 1D 1E 00 00 00 01 1C 1E 00 01 1C 1E 00'\r\n '1E 1E 00 01 1F 1E 00 01 1F 1E 00 00 00 1F 1E 00 00 00 01 1E 1E 00 01 1E 1E 00 20 1E 00 01 21 1E'\r\n '00 01 21 1E 00 00 00 21 1E 00 00 00 01 20 1E 00 01 20 1E 00 22 1E 00 01 23 1E 00 01 23 1E 00 00'\r\n '00 23 1E 00 00 00 01 22 1E 00 01 22 1E 00 24 1E 00 01 25 1E 00 01 25 1E 00 00 00 25 1E 00 00 00'\r\n '01 24 1E 00 01 24 1E 00 26 1E 00 01 27 1E 00 01 27 1E 00 00 00 27 1E 00 00 00 01 26 1E 00 01 26'\r\n '1E 00 28 1E 00 01 29 1E 00 01 29 1E 00 00 00 29 1E 00 00 00 01 28 1E 00 01 28 1E 00 2A 1E 00 01'\r\n '2B 1E 00 01 2B 1E 00 00 00 2B 1E 00 00 00 01 2A 1E 00 01 2A 1E 00 2C 1E 00 01 2D 1E 00 01 2D 1E'\r\n '00 00 00 2D 1E 00 00 00 01 2C 1E 00 01 2C 1E 00 2E 1E 00 01 2F 1E 00 01 2F 1E 00 00 00 2F 1E 00'\r\n '00 00 01 2E 1E 00 01 2E 1E 00 30 1E 00 01 31 1E 00 01 31 1E 00 00 00 31 1E 00 00 00 01 30 1E 00'\r\n '01 30 1E 00 32 1E 00 01 33 1E 00 01 33 1E 00 00 00 33 1E 00 00 00 01 32 1E 00 01 32 1E 00 34 1E'\r\n '00 01 35 1E 00 01 35 1E 00 00 00 35 1E 00 00 00 01 34 1E 00 01 34 1E 00 36 1E 00 01 37 1E 00 01'\r\n '37 1E 00 00 00 37 1E 00 00 00 01 36 1E 00 01 36 1E 00 38 1E 00 01 39 1E 00 01 39 1E 00 00 00 39'\r\n '1E 00 00 00 01 38 1E 00 01 38 1E 00 3A 1E 00 01 3B 1E 00 01 3B 1E 00 00 00 3B 1E 00 00 00 01 3A'\r\n '1E 00 01 3A 1E 00 3C 1E 00 01 3D 1E 00 01 3D 1E 00 00 00 3D 1E 00 00 00 01 3C 1E 00 01 3C 1E 00'\r\n '3E 1E 00 01 3F 1E 00 01 3F 1E 00 00 00 3F 1E 00 00 00 01 3E 1E 00 01 3E 1E 00 40 1E 00 01 41 1E'\r\n '00 01 41 1E 00 00 00 41 1E 00 00 00 01 40 1E 00 01 40 1E 00 42 1E 00 01 43 1E 00 01 43 1E 00 00'\r\n '00 43 1E 00 00 00 01 42 1E 00 01 42 1E 00 44 1E 00 01 45 1E 00 01 45 1E 00 00 00 45 1E 00 00 00'\r\n '01 44 1E 00 01 44 1E 00 46 1E 00 01 47 1E 00 01 47 1E 00 00 00 47 1E 00 00 00 01 46 1E 00 01 46'\r\n '1E 00 48 1E 00 01 49 1E 00 01 49 1E 00 00 00 49 1E 00 00 00 01 48 1E 00 01 48 1E 00 4A 1E 00 01'\r\n '4B 1E 00 01 4B 1E 00 00 00 4B 1E 00 00 00 01 4A 1E 00 01 4A 1E 00 4C 1E 00 01 4D 1E 00 01 4D 1E'\r\n '00 00 00 4D 1E 00 00 00 01 4C 1E 00 01 4C 1E 00 4E 1E 00 01 4F 1E 00 01 4F 1E 00 00 00 4F 1E 00'\r\n '00 00 01 4E 1E 00 01 4E 1E 00 50 1E 00 01 51 1E 00 01 51 1E 00 00 00 51 1E 00 00 00 01 50 1E 00'\r\n '01 50 1E 00 52 1E 00 01 53 1E 00 01 53 1E 00 00 00 53 1E 00 00 00 01 52 1E 00 01 52 1E 00 54 1E'\r\n '00 01 55 1E 00 01 55 1E 00 00 00 55 1E 00 00 00 01 54 1E 00 01 54 1E 00 56 1E 00 01 57 1E 00 01'\r\n '57 1E 00 00 00 57 1E 00 00 00 01 56 1E 00 01 56 1E 00 58 1E 00 01 59 1E 00 01 59 1E 00 00 00 59'\r\n '1E 00 00 00 01 58 1E 00 01 58 1E 00 5A 1E 00 01 5B 1E 00 01 5B 1E 00 00 00 5B 1E 00 00 00 01 5A'\r\n '1E 00 01 5A 1E 00 5C 1E 00 01 5D 1E 00 01 5D 1E 00 00 00 5D 1E 00 00 00 01 5C 1E 00 01 5C 1E 00'\r\n '5E 1E 00 01 5F 1E 00 01 5F 1E 00 00 00 5F 1E 00 00 00 01 5E 1E 00 01 5E 1E 00 60 1E 00 01 61 1E'\r\n '00 01 61 1E 00 00 00 61 1E 00 00 00 01 60 1E 00 01 60 1E 00 62 1E 00 01 63 1E 00 01 63 1E 00 00'\r\n '00 63 1E 00 00 00 01 62 1E 00 01 62 1E 00 64 1E 00 01 65 1E 00 01 65 1E 00 00 00 65 1E 00 00 00'\r\n '01 64 1E 00 01 64 1E 00 66 1E 00 01 67 1E 00 01 67 1E 00 00 00 67 1E 00 00 00 01 66 1E 00 01 66'\r\n '1E 00 68 1E 00 01 69 1E 00 01 69 1E 00 00 00 69 1E 00 00 00 01 68 1E 00 01 68 1E 00 6A 1E 00 01'\r\n '6B 1E 00 01 6B 1E 00 00 00 6B 1E 00 00 00 01 6A 1E 00 01 6A 1E 00 6C 1E 00 01 6D 1E 00 01 6D 1E'\r\n '00 00 00 6D 1E 00 00 00 01 6C 1E 00 01 6C 1E 00 6E 1E 00 01 6F 1E 00 01 6F 1E 00 00 00 6F 1E 00'\r\n '00 00 01 6E 1E 00 01 6E 1E 00 70 1E 00 01 71 1E 00 01 71 1E 00 00 00 71 1E 00 00 00 01 70 1E 00'\r\n '01 70 1E 00 72 1E 00 01 73 1E 00 01 73 1E 00 00 00 73 1E 00 00 00 01 72 1E 00 01 72 1E 00 74 1E'\r\n '00 01 75 1E 00 01 75 1E 00 00 00 75 1E 00 00 00 01 74 1E 00 01 74 1E 00 76 1E 00 01 77 1E 00 01'\r\n '77 1E 00 00 00 77 1E 00 00 00 01 76 1E 00 01 76 1E 00 78 1E 00 01 79 1E 00 01 79 1E 00 00 00 79'\r\n '1E 00 00 00 01 78 1E 00 01 78 1E 00 7A 1E 00 01 7B 1E 00 01 7B 1E 00 00 00 7B 1E 00 00 00 01 7A'\r\n '1E 00 01 7A 1E 00 7C 1E 00 01 7D 1E 00 01 7D 1E 00 00 00 7D 1E 00 00 00 01 7C 1E 00 01 7C 1E 00'\r\n '7E 1E 00 01 7F 1E 00 01 7F 1E 00 00 00 7F 1E 00 00 00 01 7E 1E 00 01 7E 1E 00 80 1E 00 01 81 1E'\r\n '00 01 81 1E 00 00 00 81 1E 00 00 00 01 80 1E 00 01 80 1E 00 82 1E 00 01 83 1E 00 01 83 1E 00 00'\r\n '00 83 1E 00 00 00 01 82 1E 00 01 82 1E 00 84 1E 00 01 85 1E 00 01 85 1E 00 00 00 85 1E 00 00 00'\r\n '01 84 1E 00 01 84 1E 00 86 1E 00 01 87 1E 00 01 87 1E 00 00 00 87 1E 00 00 00 01 86 1E 00 01 86'\r\n '1E 00 88 1E 00 01 89 1E 00 01 89 1E 00 00 00 89 1E 00 00 00 01 88 1E 00 01 88 1E 00 8A 1E 00 01'\r\n '8B 1E 00 01 8B 1E 00 00 00 8B 1E 00 00 00 01 8A 1E 00 01 8A 1E 00 8C 1E 00 01 8D 1E 00 01 8D 1E'\r\n '00 00 00 8D 1E 00 00 00 01 8C 1E 00 01 8C 1E 00 8E 1E 00 01 8F 1E 00 01 8F 1E 00 00 00 8F 1E 00'\r\n '00 00 01 8E 1E 00 01 8E 1E 00 90 1E 00 01 91 1E 00 01 91 1E 00 00 00 91 1E 00 00 00 01 90 1E 00'\r\n '01 90 1E 00 92 1E 00 01 93 1E 00 01 93 1E 00 00 00 93 1E 00 00 00 01 92 1E 00 01 92 1E 00 94 1E'\r\n '00 01 95 1E 00 01 95 1E 00 00 00 95 1E 00 00 00 01 94 1E 00 01 94 1E 00 96 1E 00 02 68 00 00 31'\r\n '03 00 01 96 1E 00 02 48 00 00 31 03 00 02 48 00 00 31 03 00 97 1E 00 02 74 00 00 08 03 00 01 97'\r\n '1E 00 02 54 00 00 08 03 00 02 54 00 00 08 03 00 98 1E 00 02 77 00 00 0A 03 00 01 98 1E 00 02 57'\r\n '00 00 0A 03 00 02 57 00 00 0A 03 00 99 1E 00 02 79 00 00 0A 03 00 01 99 1E 00 02 59 00 00 0A 03'\r\n '00 02 59 00 00 0A 03 00 9A 1E 00 02 61 00 00 BE 02 00 01 9A 1E 00 02 41 00 00 BE 02 00 02 41 00'\r\n '00 BE 02 00 9B 1E 00 01 61 1E 00 00 01 60 1E 00 01 60 1E 00 9E 1E 00 02 73 00 00 73 00 00 01 DF'\r\n '00 00 00 00 A0 1E 00 01 A1 1E 00 01 A1 1E 00 00 00 A1 1E 00 00 00 01 A0 1E 00 01 A0 1E 00 A2 1E'\r\n '00 01 A3 1E 00 01 A3 1E 00 00 00 A3 1E 00 00 00 01 A2 1E 00 01 A2 1E 00 A4 1E 00 01 A5 1E 00 01'\r\n 'A5 1E 00 00 00 A5 1E 00 00 00 01 A4 1E 00 01 A4 1E 00 A6 1E 00 01 A7 1E 00 01 A7 1E 00 00 00 A7'\r\n '1E 00 00 00 01 A6 1E 00 01 A6 1E 00 A8 1E 00 01 A9 1E 00 01 A9 1E 00 00 00 A9 1E 00 00 00 01 A8'\r\n '1E 00 01 A8 1E 00 AA 1E 00 01 AB 1E 00 01 AB 1E 00 00 00 AB 1E 00 00 00 01 AA 1E 00 01 AA 1E 00'\r\n 'AC 1E 00 01 AD 1E 00 01 AD 1E 00 00 00 AD 1E 00 00 00 01 AC 1E 00 01 AC 1E 00 AE 1E 00 01 AF 1E'\r\n '00 01 AF 1E 00 00 00 AF 1E 00 00 00 01 AE 1E 00 01 AE 1E 00 B0 1E 00 01 B1 1E 00 01 B1 1E 00 00'\r\n '00 B1 1E 00 00 00 01 B0 1E 00 01 B0 1E 00 B2 1E 00 01 B3 1E 00 01 B3 1E 00 00 00 B3 1E 00 00 00'\r\n '01 B2 1E 00 01 B2 1E 00 B4 1E 00 01 B5 1E 00 01 B5 1E 00 00 00 B5 1E 00 00 00 01 B4 1E 00 01 B4'\r\n '1E 00 B6 1E 00 01 B7 1E 00 01 B7 1E 00 00 00 B7 1E 00 00 00 01 B6 1E 00 01 B6 1E 00 B8 1E 00 01'\r\n 'B9 1E 00 01 B9 1E 00 00 00 B9 1E 00 00 00 01 B8 1E 00 01 B8 1E 00 BA 1E 00 01 BB 1E 00 01 BB 1E'\r\n '00 00 00 BB 1E 00 00 00 01 BA 1E 00 01 BA 1E 00 BC 1E 00 01 BD 1E 00 01 BD 1E 00 00 00 BD 1E 00'\r\n '00 00 01 BC 1E 00 01 BC 1E 00 BE 1E 00 01 BF 1E 00 01 BF 1E 00 00 00 BF 1E 00 00 00 01 BE 1E 00'\r\n '01 BE 1E 00 C0 1E 00 01 C1 1E 00 01 C1 1E 00 00 00 C1 1E 00 00 00 01 C0 1E 00 01 C0 1E 00 C2 1E'\r\n '00 01 C3 1E 00 01 C3 1E 00 00 00 C3 1E 00 00 00 01 C2 1E 00 01 C2 1E 00 C4 1E 00 01 C5 1E 00 01'\r\n 'C5 1E 00 00 00 C5 1E 00 00 00 01 C4 1E 00 01 C4 1E 00 C6 1E 00 01 C7 1E 00 01 C7 1E 00 00 00 C7'\r\n '1E 00 00 00 01 C6 1E 00 01 C6 1E 00 C8 1E 00 01 C9 1E 00 01 C9 1E 00 00 00 C9 1E 00 00 00 01 C8'\r\n '1E 00 01 C8 1E 00 CA 1E 00 01 CB 1E 00 01 CB 1E 00 00 00 CB 1E 00 00 00 01 CA 1E 00 01 CA 1E 00'\r\n 'CC 1E 00 01 CD 1E 00 01 CD 1E 00 00 00 CD 1E 00 00 00 01 CC 1E 00 01 CC 1E 00 CE 1E 00 01 CF 1E'\r\n '00 01 CF 1E 00 00 00 CF 1E 00 00 00 01 CE 1E 00 01 CE 1E 00 D0 1E 00 01 D1 1E 00 01 D1 1E 00 00'\r\n '00 D1 1E 00 00 00 01 D0 1E 00 01 D0 1E 00 D2 1E 00 01 D3 1E 00 01 D3 1E 00 00 00 D3 1E 00 00 00'\r\n '01 D2 1E 00 01 D2 1E 00 D4 1E 00 01 D5 1E 00 01 D5 1E 00 00 00 D5 1E 00 00 00 01 D4 1E 00 01 D4'\r\n '1E 00 D6 1E 00 01 D7 1E 00 01 D7 1E 00 00 00 D7 1E 00 00 00 01 D6 1E 00 01 D6 1E 00 D8 1E 00 01'\r\n 'D9 1E 00 01 D9 1E 00 00 00 D9 1E 00 00 00 01 D8 1E 00 01 D8 1E 00 DA 1E 00 01 DB 1E 00 01 DB 1E'\r\n '00 00 00 DB 1E 00 00 00 01 DA 1E 00 01 DA 1E 00 DC 1E 00 01 DD 1E 00 01 DD 1E 00 00 00 DD 1E 00'\r\n '00 00 01 DC 1E 00 01 DC 1E 00 DE 1E 00 01 DF 1E 00 01 DF 1E 00 00 00 DF 1E 00 00 00 01 DE 1E 00'\r\n '01 DE 1E 00 E0 1E 00 01 E1 1E 00 01 E1 1E 00 00 00 E1 1E 00 00 00 01 E0 1E 00 01 E0 1E 00 E2 1E'\r\n '00 01 E3 1E 00 01 E3 1E 00 00 00 E3 1E 00 00 00 01 E2 1E 00 01 E2 1E 00 E4 1E 00 01 E5 1E 00 01'\r\n 'E5 1E 00 00 00 E5 1E 00 00 00 01 E4 1E 00 01 E4 1E 00 E6 1E 00 01 E7 1E 00 01 E7 1E 00 00 00 E7'\r\n '1E 00 00 00 01 E6 1E 00 01 E6 1E 00 E8 1E 00 01 E9 1E 00 01 E9 1E 00 00 00 E9 1E 00 00 00 01 E8'\r\n '1E 00 01 E8 1E 00 EA 1E 00 01 EB 1E 00 01 EB 1E 00 00 00 EB 1E 00 00 00 01 EA 1E 00 01 EA 1E 00'\r\n 'EC 1E 00 01 ED 1E 00 01 ED 1E 00 00 00 ED 1E 00 00 00 01 EC 1E 00 01 EC 1E 00 EE 1E 00 01 EF 1E'\r\n '00 01 EF 1E 00 00 00 EF 1E 00 00 00 01 EE 1E 00 01 EE 1E 00 F0 1E 00 01 F1 1E 00 01 F1 1E 00 00'\r\n '00 F1 1E 00 00 00 01 F0 1E 00 01 F0 1E 00 F2 1E 00 01 F3 1E 00 01 F3 1E 00 00 00 F3 1E 00 00 00'\r\n '01 F2 1E 00 01 F2 1E 00 F4 1E 00 01 F5 1E 00 01 F5 1E 00 00 00 F5 1E 00 00 00 01 F4 1E 00 01 F4'\r\n '1E 00 F6 1E 00 01 F7 1E 00 01 F7 1E 00 00 00 F7 1E 00 00 00 01 F6 1E 00 01 F6 1E 00 F8 1E 00 01'\r\n 'F9 1E 00 01 F9 1E 00 00 00 F9 1E 00 00 00 01 F8 1E 00 01 F8 1E 00 FA 1E 00 01 FB 1E 00 01 FB 1E'\r\n '00 00 00 FB 1E 00 00 00 01 FA 1E 00 01 FA 1E 00 FC 1E 00 01 FD 1E 00 01 FD 1E 00 00 00 FD 1E 00'\r\n '00 00 01 FC 1E 00 01 FC 1E 00 FE 1E 00 01 FF 1E 00 01 FF 1E 00 00 00 FF 1E 00 00 00 01 FE 1E 00'\r\n '01 FE 1E 00 00 1F 00 00 00 01 08 1F 00 01 08 1F 00 01 1F 00 00 00 01 09 1F 00 01 09 1F 00 02 1F'\r\n '00 00 00 01 0A 1F 00 01 0A 1F 00 03 1F 00 00 00 01 0B 1F 00 01 0B 1F 00 04 1F 00 00 00 01 0C 1F'\r\n '00 01 0C 1F 00 05 1F 00 00 00 01 0D 1F 00 01 0D 1F 00 06 1F 00 00 00 01 0E 1F 00 01 0E 1F 00 07'\r\n '1F 00 00 00 01 0F 1F 00 01 0F 1F 00 08 1F 00 01 00 1F 00 01 00 1F 00 00 00 09 1F 00 01 01 1F 00'\r\n '01 01 1F 00 00 00 0A 1F 00 01 02 1F 00 01 02 1F 00 00 00 0B 1F 00 01 03 1F 00 01 03 1F 00 00 00'\r\n '0C 1F 00 01 04 1F 00 01 04 1F 00 00 00 0D 1F 00 01 05 1F 00 01 05 1F 00 00 00 0E 1F 00 01 06 1F'\r\n '00 01 06 1F 00 00 00 0F 1F 00 01 07 1F 00 01 07 1F 00 00 00 10 1F 00 00 00 01 18 1F 00 01 18 1F'\r\n '00 11 1F 00 00 00 01 19 1F 00 01 19 1F 00 12 1F 00 00 00 01 1A 1F 00 01 1A 1F 00 13 1F 00 00 00'\r\n '01 1B 1F 00 01 1B 1F 00 14 1F 00 00 00 01 1C 1F 00 01 1C 1F 00 15 1F 00 00 00 01 1D 1F 00 01 1D'\r\n '1F 00 18 1F 00 01 10 1F 00 01 10 1F 00 00 00 19 1F 00 01 11 1F 00 01 11 1F 00 00 00 1A 1F 00 01'\r\n '12 1F 00 01 12 1F 00 00 00 1B 1F 00 01 13 1F 00 01 13 1F 00 00 00 1C 1F 00 01 14 1F 00 01 14 1F'\r\n '00 00 00 1D 1F 00 01 15 1F 00 01 15 1F 00 00 00 20 1F 00 00 00 01 28 1F 00 01 28 1F 00 21 1F 00'\r\n '00 00 01 29 1F 00 01 29 1F 00 22 1F 00 00 00 01 2A 1F 00 01 2A 1F 00 23 1F 00 00 00 01 2B 1F 00'\r\n '01 2B 1F 00 24 1F 00 00 00 01 2C 1F 00 01 2C 1F 00 25 1F 00 00 00 01 2D 1F 00 01 2D 1F 00 26 1F'\r\n '00 00 00 01 2E 1F 00 01 2E 1F 00 27 1F 00 00 00 01 2F 1F 00 01 2F 1F 00 28 1F 00 01 20 1F 00 01'\r\n '20 1F 00 00 00 29 1F 00 01 21 1F 00 01 21 1F 00 00 00 2A 1F 00 01 22 1F 00 01 22 1F 00 00 00 2B'\r\n '1F 00 01 23 1F 00 01 23 1F 00 00 00 2C 1F 00 01 24 1F 00 01 24 1F 00 00 00 2D 1F 00 01 25 1F 00'\r\n '01 25 1F 00 00 00 2E 1F 00 01 26 1F 00 01 26 1F 00 00 00 2F 1F 00 01 27 1F 00 01 27 1F 00 00 00'\r\n '30 1F 00 00 00 01 38 1F 00 01 38 1F 00 31 1F 00 00 00 01 39 1F 00 01 39 1F 00 32 1F 00 00 00 01'\r\n '3A 1F 00 01 3A 1F 00 33 1F 00 00 00 01 3B 1F 00 01 3B 1F 00 34 1F 00 00 00 01 3C 1F 00 01 3C 1F'\r\n '00 35 1F 00 00 00 01 3D 1F 00 01 3D 1F 00 36 1F 00 00 00 01 3E 1F 00 01 3E 1F 00 37 1F 00 00 00'\r\n '01 3F 1F 00 01 3F 1F 00 38 1F 00 01 30 1F 00 01 30 1F 00 00 00 39 1F 00 01 31 1F 00 01 31 1F 00'\r\n '00 00 3A 1F 00 01 32 1F 00 01 32 1F 00 00 00 3B 1F 00 01 33 1F 00 01 33 1F 00 00 00 3C 1F 00 01'\r\n '34 1F 00 01 34 1F 00 00 00 3D 1F 00 01 35 1F 00 01 35 1F 00 00 00 3E 1F 00 01 36 1F 00 01 36 1F'\r\n '00 00 00 3F 1F 00 01 37 1F 00 01 37 1F 00 00 00 40 1F 00 00 00 01 48 1F 00 01 48 1F 00 41 1F 00'\r\n '00 00 01 49 1F 00 01 49 1F 00 42 1F 00 00 00 01 4A 1F 00 01 4A 1F 00 43 1F 00 00 00 01 4B 1F 00'\r\n '01 4B 1F 00 44 1F 00 00 00 01 4C 1F 00 01 4C 1F 00 45 1F 00 00 00 01 4D 1F 00 01 4D 1F 00 48 1F'\r\n '00 01 40 1F 00 01 40 1F 00 00 00 49 1F 00 01 41 1F 00 01 41 1F 00 00 00 4A 1F 00 01 42 1F 00 01'\r\n '42 1F 00 00 00 4B 1F 00 01 43 1F 00 01 43 1F 00 00 00 4C 1F 00 01 44 1F 00 01 44 1F 00 00 00 4D'\r\n '1F 00 01 45 1F 00 01 45 1F 00 00 00 50 1F 00 02 C5 03 00 13 03 00 01 50 1F 00 02 A5 03 00 13 03'\r\n '00 02 A5 03 00 13 03 00 51 1F 00 00 00 01 59 1F 00 01 59 1F 00 52 1F 00 03 C5 03 00 13 03 00 00'\r\n '03 00 01 52 1F 00 03 A5 03 00 13 03 00 00 03 00 03 A5 03 00 13 03 00 00 03 00 53 1F 00 00 00 01'\r\n '5B 1F 00 01 5B 1F 00 54 1F 00 03 C5 03 00 13 03 00 01 03 00 01 54 1F 00 03 A5 03 00 13 03 00 01'\r\n '03 00 03 A5 03 00 13 03 00 01 03 00 55 1F 00 00 00 01 5D 1F 00 01 5D 1F 00 56 1F 00 03 C5 03 00'\r\n '13 03 00 42 03 00 01 56 1F 00 03 A5 03 00 13 03 00 42 03 00 03 A5 03 00 13 03 00 42 03 00 57 1F'\r\n '00 00 00 01 5F 1F 00 01 5F 1F 00 59 1F 00 01 51 1F 00 01 51 1F 00 00 00 5B 1F 00 01 53 1F 00 01'\r\n '53 1F 00 00 00 5D 1F 00 01 55 1F 00 01 55 1F 00 00 00 5F 1F 00 01 57 1F 00 01 57 1F 00 00 00 60'\r\n '1F 00 00 00 01 68 1F 00 01 68 1F 00 61 1F 00 00 00 01 69 1F 00 01 69 1F 00 62 1F 00 00 00 01 6A'\r\n '1F 00 01 6A 1F 00 63 1F 00 00 00 01 6B 1F 00 01 6B 1F 00 64 1F 00 00 00 01 6C 1F 00 01 6C 1F 00'\r\n '65 1F 00 00 00 01 6D 1F 00 01 6D 1F 00 66 1F 00 00 00 01 6E 1F 00 01 6E 1F 00 67 1F 00 00 00 01'\r\n '6F 1F 00 01 6F 1F 00 68 1F 00 01 60 1F 00 01 60 1F 00 00 00 69 1F 00 01 61 1F 00 01 61 1F 00 00'\r\n '00 6A 1F 00 01 62 1F 00 01 62 1F 00 00 00 6B 1F 00 01 63 1F 00 01 63 1F 00 00 00 6C 1F 00 01 64'\r\n '1F 00 01 64 1F 00 00 00 6D 1F 00 01 65 1F 00 01 65 1F 00 00 00 6E 1F 00 01 66 1F 00 01 66 1F 00'\r\n '00 00 6F 1F 00 01 67 1F 00 01 67 1F 00 00 00 70 1F 00 00 00 01 BA 1F 00 01 BA 1F 00 71 1F 00 00'\r\n '00 01 BB 1F 00 01 BB 1F 00 72 1F 00 00 00 01 C8 1F 00 01 C8 1F 00 73 1F 00 00 00 01 C9 1F 00 01'\r\n 'C9 1F 00 74 1F 00 00 00 01 CA 1F 00 01 CA 1F 00 75 1F 00 00 00 01 CB 1F 00 01 CB 1F 00 76 1F 00'\r\n '00 00 01 DA 1F 00 01 DA 1F 00 77 1F 00 00 00 01 DB 1F 00 01 DB 1F 00 78 1F 00 00 00 01 F8 1F 00'\r\n '01 F8 1F 00 79 1F 00 00 00 01 F9 1F 00 01 F9 1F 00 7A 1F 00 00 00 01 EA 1F 00 01 EA 1F 00 7B 1F'\r\n '00 00 00 01 EB 1F 00 01 EB 1F 00 7C 1F 00 00 00 01 FA 1F 00 01 FA 1F 00 7D 1F 00 00 00 01 FB 1F'\r\n '00 01 FB 1F 00 80 1F 00 02 00 1F 00 B9 03 00 01 80 1F 00 01 88 1F 00 01 88 1F 00 81 1F 00 02 01'\r\n '1F 00 B9 03 00 01 81 1F 00 01 89 1F 00 01 89 1F 00 82 1F 00 02 02 1F 00 B9 03 00 01 82 1F 00 01'\r\n '8A 1F 00 01 8A 1F 00 83 1F 00 02 03 1F 00 B9 03 00 01 83 1F 00 01 8B 1F 00 01 8B 1F 00 84 1F 00'\r\n '02 04 1F 00 B9 03 00 01 84 1F 00 01 8C 1F 00 01 8C 1F 00 85 1F 00 02 05 1F 00 B9 03 00 01 85 1F'\r\n '00 01 8D 1F 00 01 8D 1F 00 86 1F 00 02 06 1F 00 B9 03 00 01 86 1F 00 01 8E 1F 00 01 8E 1F 00 87'\r\n '1F 00 02 07 1F 00 B9 03 00 01 87 1F 00 01 8F 1F 00 01 8F 1F 00 88 1F 00 02 00 1F 00 B9 03 00 01'\r\n '80 1F 00 01 88 1F 00 02 08 1F 00 99 03 00 89 1F 00 02 01 1F 00 B9 03 00 01 81 1F 00 01 89 1F 00'\r\n '02 09 1F 00 99 03 00 8A 1F 00 02 02 1F 00 B9 03 00 01 82 1F 00 01 8A 1F 00 02 0A 1F 00 99 03 00'\r\n '8B 1F 00 02 03 1F 00 B9 03 00 01 83 1F 00 01 8B 1F 00 02 0B 1F 00 99 03 00 8C 1F 00 02 04 1F 00'\r\n 'B9 03 00 01 84 1F 00 01 8C 1F 00 02 0C 1F 00 99 03 00 8D 1F 00 02 05 1F 00 B9 03 00 01 85 1F 00'\r\n '01 8D 1F 00 02 0D 1F 00 99 03 00 8E 1F 00 02 06 1F 00 B9 03 00 01 86 1F 00 01 8E 1F 00 02 0E 1F'\r\n '00 99 03 00 8F 1F 00 02 07 1F 00 B9 03 00 01 87 1F 00 01 8F 1F 00 02 0F 1F 00 99 03 00 90 1F 00'\r\n '02 20 1F 00 B9 03 00 01 90 1F 00 01 98 1F 00 01 98 1F 00 91 1F 00 02 21 1F 00 B9 03 00 01 91 1F'\r\n '00 01 99 1F 00 01 99 1F 00 92 1F 00 02 22 1F 00 B9 03 00 01 92 1F 00 01 9A 1F 00 01 9A 1F 00 93'\r\n '1F 00 02 23 1F 00 B9 03 00 01 93 1F 00 01 9B 1F 00 01 9B 1F 00 94 1F 00 02 24 1F 00 B9 03 00 01'\r\n '94 1F 00 01 9C 1F 00 01 9C 1F 00 95 1F 00 02 25 1F 00 B9 03 00 01 95 1F 00 01 9D 1F 00 01 9D 1F'\r\n '00 96 1F 00 02 26 1F 00 B9 03 00 01 96 1F 00 01 9E 1F 00 01 9E 1F 00 97 1F 00 02 27 1F 00 B9 03'\r\n '00 01 97 1F 00 01 9F 1F 00 01 9F 1F 00 98 1F 00 02 20 1F 00 B9 03 00 01 90 1F 00 01 98 1F 00 02'\r\n '28 1F 00 99 03 00 99 1F 00 02 21 1F 00 B9 03 00 01 91 1F 00 01 99 1F 00 02 29 1F 00 99 03 00 9A'\r\n '1F 00 02 22 1F 00 B9 03 00 01 92 1F 00 01 9A 1F 00 02 2A 1F 00 99 03 00 9B 1F 00 02 23 1F 00 B9'\r\n '03 00 01 93 1F 00 01 9B 1F 00 02 2B 1F 00 99 03 00 9C 1F 00 02 24 1F 00 B9 03 00 01 94 1F 00 01'\r\n '9C 1F 00 02 2C 1F 00 99 03 00 9D 1F 00 02 25 1F 00 B9 03 00 01 95 1F 00 01 9D 1F 00 02 2D 1F 00'\r\n '99 03 00 9E 1F 00 02 26 1F 00 B9 03 00 01 96 1F 00 01 9E 1F 00 02 2E 1F 00 99 03 00 9F 1F 00 02'\r\n '27 1F 00 B9 03 00 01 97 1F 00 01 9F 1F 00 02 2F 1F 00 99 03 00 A0 1F 00 02 60 1F 00 B9 03 00 01'\r\n 'A0 1F 00 01 A8 1F 00 01 A8 1F 00 A1 1F 00 02 61 1F 00 B9 03 00 01 A1 1F 00 01 A9 1F 00 01 A9 1F'\r\n '00 A2 1F 00 02 62 1F 00 B9 03 00 01 A2 1F 00 01 AA 1F 00 01 AA 1F 00 A3 1F 00 02 63 1F 00 B9 03'\r\n '00 01 A3 1F 00 01 AB 1F 00 01 AB 1F 00 A4 1F 00 02 64 1F 00 B9 03 00 01 A4 1F 00 01 AC 1F 00 01'\r\n 'AC 1F 00 A5 1F 00 02 65 1F 00 B9 03 00 01 A5 1F 00 01 AD 1F 00 01 AD 1F 00 A6 1F 00 02 66 1F 00'\r\n 'B9 03 00 01 A6 1F 00 01 AE 1F 00 01 AE 1F 00 A7 1F 00 02 67 1F 00 B9 03 00 01 A7 1F 00 01 AF 1F'\r\n '00 01 AF 1F 00 A8 1F 00 02 60 1F 00 B9 03 00 01 A0 1F 00 01 A8 1F 00 02 68 1F 00 99 03 00 A9 1F'\r\n '00 02 61 1F 00 B9 03 00 01 A1 1F 00 01 A9 1F 00 02 69 1F 00 99 03 00 AA 1F 00 02 62 1F 00 B9 03'\r\n '00 01 A2 1F 00 01 AA 1F 00 02 6A 1F 00 99 03 00 AB 1F 00 02 63 1F 00 B9 03 00 01 A3 1F 00 01 AB'\r\n '1F 00 02 6B 1F 00 99 03 00 AC 1F 00 02 64 1F 00 B9 03 00 01 A4 1F 00 01 AC 1F 00 02 6C 1F 00 99'\r\n '03 00 AD 1F 00 02 65 1F 00 B9 03 00 01 A5 1F 00 01 AD 1F 00 02 6D 1F 00 99 03 00 AE 1F 00 02 66'\r\n '1F 00 B9 03 00 01 A6 1F 00 01 AE 1F 00 02 6E 1F 00 99 03 00 AF 1F 00 02 67 1F 00 B9 03 00 01 A7'\r\n '1F 00 01 AF 1F 00 02 6F 1F 00 99 03 00 B0 1F 00 00 00 01 B8 1F 00 01 B8 1F 00 B1 1F 00 00 00 01'\r\n 'B9 1F 00 01 B9 1F 00 B2 1F 00 02 70 1F 00 B9 03 00 01 B2 1F 00 02 BA 1F 00 45 03 00 02 BA 1F 00'\r\n '99 03 00 B3 1F 00 02 B1 03 00 B9 03 00 01 B3 1F 00 01 BC 1F 00 01 BC 1F 00 B4 1F 00 02 AC 03 00'\r\n 'B9 03 00 01 B4 1F 00 02 86 03 00 45 03 00 02 86 03 00 99 03 00 B6 1F 00 02 B1 03 00 42 03 00 01'\r\n 'B6 1F 00 02 91 03 00 42 03 00 02 91 03 00 42 03 00 B7 1F 00 03 B1 03 00 42 03 00 B9 03 00 01 B7'\r\n '1F 00 03 91 03 00 42 03 00 45 03 00 03 91 03 00 42 03 00 99 03 00 B8 1F 00 01 B0 1F 00 01 B0 1F'\r\n '00 00 00 B9 1F 00 01 B1 1F 00 01 B1 1F 00 00 00 BA 1F 00 01 70 1F 00 01 70 1F 00 00 00 BB 1F 00'\r\n '01 71 1F 00 01 71 1F 00 00 00 BC 1F 00 02 B1 03 00 B9 03 00 01 B3 1F 00 01 BC 1F 00 02 91 03 00'\r\n '99 03 00 BE 1F 00 01 B9 03 00 00 01 99 03 00 01 99 03 00 C2 1F 00 02 74 1F 00 B9 03 00 01 C2 1F'\r\n '00 02 CA 1F 00 45 03 00 02 CA 1F 00 99 03 00 C3 1F 00 02 B7 03 00 B9 03 00 01 C3 1F 00 01 CC 1F'\r\n '00 01 CC 1F 00 C4 1F 00 02 AE 03 00 B9 03 00 01 C4 1F 00 02 89 03 00 45 03 00 02 89 03 00 99 03'\r\n '00 C6 1F 00 02 B7 03 00 42 03 00 01 C6 1F 00 02 97 03 00 42 03 00 02 97 03 00 42 03 00 C7 1F 00'\r\n '03 B7 03 00 42 03 00 B9 03 00 01 C7 1F 00 03 97 03 00 42 03 00 45 03 00 03 97 03 00 42 03 00 99'\r\n '03 00 C8 1F 00 01 72 1F 00 01 72 1F 00 00 00 C9 1F 00 01 73 1F 00 01 73 1F 00 00 00 CA 1F 00 01'\r\n '74 1F 00 01 74 1F 00 00 00 CB 1F 00 01 75 1F 00 01 75 1F 00 00 00 CC 1F 00 02 B7 03 00 B9 03 00'\r\n '01 C3 1F 00 01 CC 1F 00 02 97 03 00 99 03 00 D0 1F 00 00 00 01 D8 1F 00 01 D8 1F 00 D1 1F 00 00'\r\n '00 01 D9 1F 00 01 D9 1F 00 D2 1F 00 03 B9 03 00 08 03 00 00 03 00 01 D2 1F 00 03 99 03 00 08 03'\r\n '00 00 03 00 03 99 03 00 08 03 00 00 03 00 D3 1F 00 03 B9 03 00 08 03 00 01 03 00 01 D3 1F 00 03'\r\n '99 03 00 08 03 00 01 03 00 03 99 03 00 08 03 00 01 03 00 D6 1F 00 02 B9 03 00 42 03 00 01 D6 1F'\r\n '00 02 99 03 00 42 03 00 02 99 03 00 42 03 00 D7 1F 00 03 B9 03 00 08 03 00 42 03 00 01 D7 1F 00'\r\n '03 99 03 00 08 03 00 42 03 00 03 99 03 00 08 03 00 42 03 00 D8 1F 00 01 D0 1F 00 01 D0 1F 00 00'\r\n '00 D9 1F 00 01 D1 1F 00 01 D1 1F 00 00 00 DA 1F 00 01 76 1F 00 01 76 1F 00 00 00 DB 1F 00 01 77'\r\n '1F 00 01 77 1F 00 00 00 E0 1F 00 00 00 01 E8 1F 00 01 E8 1F 00 E1 1F 00 00 00 01 E9 1F 00 01 E9'\r\n '1F 00 E2 1F 00 03 C5 03 00 08 03 00 00 03 00 01 E2 1F 00 03 A5 03 00 08 03 00 00 03 00 03 A5 03'\r\n '00 08 03 00 00 03 00 E3 1F 00 03 C5 03 00 08 03 00 01 03 00 01 E3 1F 00 03 A5 03 00 08 03 00 01'\r\n '03 00 03 A5 03 00 08 03 00 01 03 00 E4 1F 00 02 C1 03 00 13 03 00 01 E4 1F 00 02 A1 03 00 13 03'\r\n '00 02 A1 03 00 13 03 00 E5 1F 00 00 00 01 EC 1F 00 01 EC 1F 00 E6 1F 00 02 C5 03 00 42 03 00 01'\r\n 'E6 1F 00 02 A5 03 00 42 03 00 02 A5 03 00 42 03 00 E7 1F 00 03 C5 03 00 08 03 00 42 03 00 01 E7'\r\n '1F 00 03 A5 03 00 08 03 00 42 03 00 03 A5 03 00 08 03 00 42 03 00 E8 1F 00 01 E0 1F 00 01 E0 1F'\r\n '00 00 00 E9 1F 00 01 E1 1F 00 01 E1 1F 00 00 00 EA 1F 00 01 7A 1F 00 01 7A 1F 00 00 00 EB 1F 00'\r\n '01 7B 1F 00 01 7B 1F 00 00 00 EC 1F 00 01 E5 1F 00 01 E5 1F 00 00 00 F2 1F 00 02 7C 1F 00 B9 03'\r\n '00 01 F2 1F 00 02 FA 1F 00 45 03 00 02 FA 1F 00 99 03 00 F3 1F 00 02 C9 03 00 B9 03 00 01 F3 1F'\r\n '00 01 FC 1F 00 01 FC 1F 00 F4 1F 00 02 CE 03 00 B9 03 00 01 F4 1F 00 02 8F 03 00 45 03 00 02 8F'\r\n '03 00 99 03 00 F6 1F 00 02 C9 03 00 42 03 00 01 F6 1F 00 02 A9 03 00 42 03 00 02 A9 03 00 42 03'\r\n '00 F7 1F 00 03 C9 03 00 42 03 00 B9 03 00 01 F7 1F 00 03 A9 03 00 42 03 00 45 03 00 03 A9 03 00'\r\n '42 03 00 99 03 00 F8 1F 00 01 78 1F 00 01 78 1F 00 00 00 F9 1F 00 01 79 1F 00 01 79 1F 00 00 00'\r\n 'FA 1F 00 01 7C 1F 00 01 7C 1F 00 00 00 FB 1F 00 01 7D 1F 00 01 7D 1F 00 00 00 FC 1F 00 02 C9 03'\r\n '00 B9 03 00 01 F3 1F 00 01 FC 1F 00 02 A9 03 00 99 03 00 26 21 00 01 C9 03 00 01 C9 03 00 00 00'\r\n '2A 21 00 01 6B 00 00 01 6B 00 00 00 00 2B 21 00 01 E5 00 00 01 E5 00 00 00 00 32 21 00 01 4E 21'\r\n '00 01 4E 21 00 00 00 4E 21 00 00 00 01 32 21 00 01 32 21 00 60 21 00 01 70 21 00 01 70 21 00 00'\r\n '00 61 21 00 01 71 21 00 01 71 21 00 00 00 62 21 00 01 72 21 00 01 72 21 00 00 00 63 21 00 01 73'\r\n '21 00 01 73 21 00 00 00 64 21 00 01 74 21 00 01 74 21 00 00 00 65 21 00 01 75 21 00 01 75 21 00'\r\n '00 00 66 21 00 01 76 21 00 01 76 21 00 00 00 67 21 00 01 77 21 00 01 77 21 00 00 00 68 21 00 01'\r\n '78 21 00 01 78 21 00 00 00 69 21 00 01 79 21 00 01 79 21 00 00 00 6A 21 00 01 7A 21 00 01 7A 21'\r\n '00 00 00 6B 21 00 01 7B 21 00 01 7B 21 00 00 00 6C 21 00 01 7C 21 00 01 7C 21 00 00 00 6D 21 00'\r\n '01 7D 21 00 01 7D 21 00 00 00 6E 21 00 01 7E 21 00 01 7E 21 00 00 00 6F 21 00 01 7F 21 00 01 7F'\r\n '21 00 00 00 70 21 00 00 00 01 60 21 00 01 60 21 00 71 21 00 00 00 01 61 21 00 01 61 21 00 72 21'\r\n '00 00 00 01 62 21 00 01 62 21 00 73 21 00 00 00 01 63 21 00 01 63 21 00 74 21 00 00 00 01 64 21'\r\n '00 01 64 21 00 75 21 00 00 00 01 65 21 00 01 65 21 00 76 21 00 00 00 01 66 21 00 01 66 21 00 77'\r\n '21 00 00 00 01 67 21 00 01 67 21 00 78 21 00 00 00 01 68 21 00 01 68 21 00 79 21 00 00 00 01 69'\r\n '21 00 01 69 21 00 7A 21 00 00 00 01 6A 21 00 01 6A 21 00 7B 21 00 00 00 01 6B 21 00 01 6B 21 00'\r\n '7C 21 00 00 00 01 6C 21 00 01 6C 21 00 7D 21 00 00 00 01 6D 21 00 01 6D 21 00 7E 21 00 00 00 01'\r\n '6E 21 00 01 6E 21 00 7F 21 00 00 00 01 6F 21 00 01 6F 21 00 83 21 00 01 84 21 00 01 84 21 00 00'\r\n '00 84 21 00 00 00 01 83 21 00 01 83 21 00 B6 24 00 01 D0 24 00 01 D0 24 00 00 00 B7 24 00 01 D1'\r\n '24 00 01 D1 24 00 00 00 B8 24 00 01 D2 24 00 01 D2 24 00 00 00 B9 24 00 01 D3 24 00 01 D3 24 00'\r\n '00 00 BA 24 00 01 D4 24 00 01 D4 24 00 00 00 BB 24 00 01 D5 24 00 01 D5 24 00 00 00 BC 24 00 01'\r\n 'D6 24 00 01 D6 24 00 00 00 BD 24 00 01 D7 24 00 01 D7 24 00 00 00 BE 24 00 01 D8 24 00 01 D8 24'\r\n '00 00 00 BF 24 00 01 D9 24 00 01 D9 24 00 00 00 C0 24 00 01 DA 24 00 01 DA 24 00 00 00 C1 24 00'\r\n '01 DB 24 00 01 DB 24 00 00 00 C2 24 00 01 DC 24 00 01 DC 24 00 00 00 C3 24 00 01 DD 24 00 01 DD'\r\n '24 00 00 00 C4 24 00 01 DE 24 00 01 DE 24 00 00 00 C5 24 00 01 DF 24 00 01 DF 24 00 00 00 C6 24'\r\n '00 01 E0 24 00 01 E0 24 00 00 00 C7 24 00 01 E1 24 00 01 E1 24 00 00 00 C8 24 00 01 E2 24 00 01'\r\n 'E2 24 00 00 00 C9 24 00 01 E3 24 00 01 E3 24 00 00 00 CA 24 00 01 E4 24 00 01 E4 24 00 00 00 CB'\r\n '24 00 01 E5 24 00 01 E5 24 00 00 00 CC 24 00 01 E6 24 00 01 E6 24 00 00 00 CD 24 00 01 E7 24 00'\r\n '01 E7 24 00 00 00 CE 24 00 01 E8 24 00 01 E8 24 00 00 00 CF 24 00 01 E9 24 00 01 E9 24 00 00 00'\r\n 'D0 24 00 00 00 01 B6 24 00 01 B6 24 00 D1 24 00 00 00 01 B7 24 00 01 B7 24 00 D2 24 00 00 00 01'\r\n 'B8 24 00 01 B8 24 00 D3 24 00 00 00 01 B9 24 00 01 B9 24 00 D4 24 00 00 00 01 BA 24 00 01 BA 24'\r\n '00 D5 24 00 00 00 01 BB 24 00 01 BB 24 00 D6 24 00 00 00 01 BC 24 00 01 BC 24 00 D7 24 00 00 00'\r\n '01 BD 24 00 01 BD 24 00 D8 24 00 00 00 01 BE 24 00 01 BE 24 00 D9 24 00 00 00 01 BF 24 00 01 BF'\r\n '24 00 DA 24 00 00 00 01 C0 24 00 01 C0 24 00 DB 24 00 00 00 01 C1 24 00 01 C1 24 00 DC 24 00 00'\r\n '00 01 C2 24 00 01 C2 24 00 DD 24 00 00 00 01 C3 24 00 01 C3 24 00 DE 24 00 00 00 01 C4 24 00 01'\r\n 'C4 24 00 DF 24 00 00 00 01 C5 24 00 01 C5 24 00 E0 24 00 00 00 01 C6 24 00 01 C6 24 00 E1 24 00'\r\n '00 00 01 C7 24 00 01 C7 24 00 E2 24 00 00 00 01 C8 24 00 01 C8 24 00 E3 24 00 00 00 01 C9 24 00'\r\n '01 C9 24 00 E4 24 00 00 00 01 CA 24 00 01 CA 24 00 E5 24 00 00 00 01 CB 24 00 01 CB 24 00 E6 24'\r\n '00 00 00 01 CC 24 00 01 CC 24 00 E7 24 00 00 00 01 CD 24 00 01 CD 24 00 E8 24 00 00 00 01 CE 24'\r\n '00 01 CE 24 00 E9 24 00 00 00 01 CF 24 00 01 CF 24 00 00 2C 00 01 30 2C 00 01 30 2C 00 00 00 01'\r\n '2C 00 01 31 2C 00 01 31 2C 00 00 00 02 2C 00 01 32 2C 00 01 32 2C 00 00 00 03 2C 00 01 33 2C 00'\r\n '01 33 2C 00 00 00 04 2C 00 01 34 2C 00 01 34 2C 00 00 00 05 2C 00 01 35 2C 00 01 35 2C 00 00 00'\r\n '06 2C 00 01 36 2C 00 01 36 2C 00 00 00 07 2C 00 01 37 2C 00 01 37 2C 00 00 00 08 2C 00 01 38 2C'\r\n '00 01 38 2C 00 00 00 09 2C 00 01 39 2C 00 01 39 2C 00 00 00 0A 2C 00 01 3A 2C 00 01 3A 2C 00 00'\r\n '00 0B 2C 00 01 3B 2C 00 01 3B 2C 00 00 00 0C 2C 00 01 3C 2C 00 01 3C 2C 00 00 00 0D 2C 00 01 3D'\r\n '2C 00 01 3D 2C 00 00 00 0E 2C 00 01 3E 2C 00 01 3E 2C 00 00 00 0F 2C 00 01 3F 2C 00 01 3F 2C 00'\r\n '00 00 10 2C 00 01 40 2C 00 01 40 2C 00 00 00 11 2C 00 01 41 2C 00 01 41 2C 00 00 00 12 2C 00 01'\r\n '42 2C 00 01 42 2C 00 00 00 13 2C 00 01 43 2C 00 01 43 2C 00 00 00 14 2C 00 01 44 2C 00 01 44 2C'\r\n '00 00 00 15 2C 00 01 45 2C 00 01 45 2C 00 00 00 16 2C 00 01 46 2C 00 01 46 2C 00 00 00 17 2C 00'\r\n '01 47 2C 00 01 47 2C 00 00 00 18 2C 00 01 48 2C 00 01 48 2C 00 00 00 19 2C 00 01 49 2C 00 01 49'\r\n '2C 00 00 00 1A 2C 00 01 4A 2C 00 01 4A 2C 00 00 00 1B 2C 00 01 4B 2C 00 01 4B 2C 00 00 00 1C 2C'\r\n '00 01 4C 2C 00 01 4C 2C 00 00 00 1D 2C 00 01 4D 2C 00 01 4D 2C 00 00 00 1E 2C 00 01 4E 2C 00 01'\r\n '4E 2C 00 00 00 1F 2C 00 01 4F 2C 00 01 4F 2C 00 00 00 20 2C 00 01 50 2C 00 01 50 2C 00 00 00 21'\r\n '2C 00 01 51 2C 00 01 51 2C 00 00 00 22 2C 00 01 52 2C 00 01 52 2C 00 00 00 23 2C 00 01 53 2C 00'\r\n '01 53 2C 00 00 00 24 2C 00 01 54 2C 00 01 54 2C 00 00 00 25 2C 00 01 55 2C 00 01 55 2C 00 00 00'\r\n '26 2C 00 01 56 2C 00 01 56 2C 00 00 00 27 2C 00 01 57 2C 00 01 57 2C 00 00 00 28 2C 00 01 58 2C'\r\n '00 01 58 2C 00 00 00 29 2C 00 01 59 2C 00 01 59 2C 00 00 00 2A 2C 00 01 5A 2C 00 01 5A 2C 00 00'\r\n '00 2B 2C 00 01 5B 2C 00 01 5B 2C 00 00 00 2C 2C 00 01 5C 2C 00 01 5C 2C 00 00 00 2D 2C 00 01 5D'\r\n '2C 00 01 5D 2C 00 00 00 2E 2C 00 01 5E 2C 00 01 5E 2C 00 00 00 30 2C 00 00 00 01 00 2C 00 01 00'\r\n '2C 00 31 2C 00 00 00 01 01 2C 00 01 01 2C 00 32 2C 00 00 00 01 02 2C 00 01 02 2C 00 33 2C 00 00'\r\n '00 01 03 2C 00 01 03 2C 00 34 2C 00 00 00 01 04 2C 00 01 04 2C 00 35 2C 00 00 00 01 05 2C 00 01'\r\n '05 2C 00 36 2C 00 00 00 01 06 2C 00 01 06 2C 00 37 2C 00 00 00 01 07 2C 00 01 07 2C 00 38 2C 00'\r\n '00 00 01 08 2C 00 01 08 2C 00 39 2C 00 00 00 01 09 2C 00 01 09 2C 00 3A 2C 00 00 00 01 0A 2C 00'\r\n '01 0A 2C 00 3B 2C 00 00 00 01 0B 2C 00 01 0B 2C 00 3C 2C 00 00 00 01 0C 2C 00 01 0C 2C 00 3D 2C'\r\n '00 00 00 01 0D 2C 00 01 0D 2C 00 3E 2C 00 00 00 01 0E 2C 00 01 0E 2C 00 3F 2C 00 00 00 01 0F 2C'\r\n '00 01 0F 2C 00 40 2C 00 00 00 01 10 2C 00 01 10 2C 00 41 2C 00 00 00 01 11 2C 00 01 11 2C 00 42'\r\n '2C 00 00 00 01 12 2C 00 01 12 2C 00 43 2C 00 00 00 01 13 2C 00 01 13 2C 00 44 2C 00 00 00 01 14'\r\n '2C 00 01 14 2C 00 45 2C 00 00 00 01 15 2C 00 01 15 2C 00 46 2C 00 00 00 01 16 2C 00 01 16 2C 00'\r\n '47 2C 00 00 00 01 17 2C 00 01 17 2C 00 48 2C 00 00 00 01 18 2C 00 01 18 2C 00 49 2C 00 00 00 01'\r\n '19 2C 00 01 19 2C 00 4A 2C 00 00 00 01 1A 2C 00 01 1A 2C 00 4B 2C 00 00 00 01 1B 2C 00 01 1B 2C'\r\n '00 4C 2C 00 00 00 01 1C 2C 00 01 1C 2C 00 4D 2C 00 00 00 01 1D 2C 00 01 1D 2C 00 4E 2C 00 00 00'\r\n '01 1E 2C 00 01 1E 2C 00 4F 2C 00 00 00 01 1F 2C 00 01 1F 2C 00 50 2C 00 00 00 01 20 2C 00 01 20'\r\n '2C 00 51 2C 00 00 00 01 21 2C 00 01 21 2C 00 52 2C 00 00 00 01 22 2C 00 01 22 2C 00 53 2C 00 00'\r\n '00 01 23 2C 00 01 23 2C 00 54 2C 00 00 00 01 24 2C 00 01 24 2C 00 55 2C 00 00 00 01 25 2C 00 01'\r\n '25 2C 00 56 2C 00 00 00 01 26 2C 00 01 26 2C 00 57 2C 00 00 00 01 27 2C 00 01 27 2C 00 58 2C 00'\r\n '00 00 01 28 2C 00 01 28 2C 00 59 2C 00 00 00 01 29 2C 00 01 29 2C 00 5A 2C 00 00 00 01 2A 2C 00'\r\n '01 2A 2C 00 5B 2C 00 00 00 01 2B 2C 00 01 2B 2C 00 5C 2C 00 00 00 01 2C 2C 00 01 2C 2C 00 5D 2C'\r\n '00 00 00 01 2D 2C 00 01 2D 2C 00 5E 2C 00 00 00 01 2E 2C 00 01 2E 2C 00 60 2C 00 01 61 2C 00 01'\r\n '61 2C 00 00 00 61 2C 00 00 00 01 60 2C 00 01 60 2C 00 62 2C 00 01 6B 02 00 01 6B 02 00 00 00 63'\r\n '2C 00 01 7D 1D 00 01 7D 1D 00 00 00 64 2C 00 01 7D 02 00 01 7D 02 00 00 00 65 2C 00 00 00 01 3A'\r\n '02 00 01 3A 02 00 66 2C 00 00 00 01 3E 02 00 01 3E 02 00 67 2C 00 01 68 2C 00 01 68 2C 00 00 00'\r\n '68 2C 00 00 00 01 67 2C 00 01 67 2C 00 69 2C 00 01 6A 2C 00 01 6A 2C 00 00 00 6A 2C 00 00 00 01'\r\n '69 2C 00 01 69 2C 00 6B 2C 00 01 6C 2C 00 01 6C 2C 00 00 00 6C 2C 00 00 00 01 6B 2C 00 01 6B 2C'\r\n '00 6D 2C 00 01 51 02 00 01 51 02 00 00 00 6E 2C 00 01 71 02 00 01 71 02 00 00 00 6F 2C 00 01 50'\r\n '02 00 01 50 02 00 00 00 70 2C 00 01 52 02 00 01 52 02 00 00 00 72 2C 00 01 73 2C 00 01 73 2C 00'\r\n '00 00 73 2C 00 00 00 01 72 2C 00 01 72 2C 00 75 2C 00 01 76 2C 00 01 76 2C 00 00 00 76 2C 00 00'\r\n '00 01 75 2C 00 01 75 2C 00 7E 2C 00 01 3F 02 00 01 3F 02 00 00 00 7F 2C 00 01 40 02 00 01 40 02'\r\n '00 00 00 80 2C 00 01 81 2C 00 01 81 2C 00 00 00 81 2C 00 00 00 01 80 2C 00 01 80 2C 00 82 2C 00'\r\n '01 83 2C 00 01 83 2C 00 00 00 83 2C 00 00 00 01 82 2C 00 01 82 2C 00 84 2C 00 01 85 2C 00 01 85'\r\n '2C 00 00 00 85 2C 00 00 00 01 84 2C 00 01 84 2C 00 86 2C 00 01 87 2C 00 01 87 2C 00 00 00 87 2C'\r\n '00 00 00 01 86 2C 00 01 86 2C 00 88 2C 00 01 89 2C 00 01 89 2C 00 00 00 89 2C 00 00 00 01 88 2C'\r\n '00 01 88 2C 00 8A 2C 00 01 8B 2C 00 01 8B 2C 00 00 00 8B 2C 00 00 00 01 8A 2C 00 01 8A 2C 00 8C'\r\n '2C 00 01 8D 2C 00 01 8D 2C 00 00 00 8D 2C 00 00 00 01 8C 2C 00 01 8C 2C 00 8E 2C 00 01 8F 2C 00'\r\n '01 8F 2C 00 00 00 8F 2C 00 00 00 01 8E 2C 00 01 8E 2C 00 90 2C 00 01 91 2C 00 01 91 2C 00 00 00'\r\n '91 2C 00 00 00 01 90 2C 00 01 90 2C 00 92 2C 00 01 93 2C 00 01 93 2C 00 00 00 93 2C 00 00 00 01'\r\n '92 2C 00 01 92 2C 00 94 2C 00 01 95 2C 00 01 95 2C 00 00 00 95 2C 00 00 00 01 94 2C 00 01 94 2C'\r\n '00 96 2C 00 01 97 2C 00 01 97 2C 00 00 00 97 2C 00 00 00 01 96 2C 00 01 96 2C 00 98 2C 00 01 99'\r\n '2C 00 01 99 2C 00 00 00 99 2C 00 00 00 01 98 2C 00 01 98 2C 00 9A 2C 00 01 9B 2C 00 01 9B 2C 00'\r\n '00 00 9B 2C 00 00 00 01 9A 2C 00 01 9A 2C 00 9C 2C 00 01 9D 2C 00 01 9D 2C 00 00 00 9D 2C 00 00'\r\n '00 01 9C 2C 00 01 9C 2C 00 9E 2C 00 01 9F 2C 00 01 9F 2C 00 00 00 9F 2C 00 00 00 01 9E 2C 00 01'\r\n '9E 2C 00 A0 2C 00 01 A1 2C 00 01 A1 2C 00 00 00 A1 2C 00 00 00 01 A0 2C 00 01 A0 2C 00 A2 2C 00'\r\n '01 A3 2C 00 01 A3 2C 00 00 00 A3 2C 00 00 00 01 A2 2C 00 01 A2 2C 00 A4 2C 00 01 A5 2C 00 01 A5'\r\n '2C 00 00 00 A5 2C 00 00 00 01 A4 2C 00 01 A4 2C 00 A6 2C 00 01 A7 2C 00 01 A7 2C 00 00 00 A7 2C'\r\n '00 00 00 01 A6 2C 00 01 A6 2C 00 A8 2C 00 01 A9 2C 00 01 A9 2C 00 00 00 A9 2C 00 00 00 01 A8 2C'\r\n '00 01 A8 2C 00 AA 2C 00 01 AB 2C 00 01 AB 2C 00 00 00 AB 2C 00 00 00 01 AA 2C 00 01 AA 2C 00 AC'\r\n '2C 00 01 AD 2C 00 01 AD 2C 00 00 00 AD 2C 00 00 00 01 AC 2C 00 01 AC 2C 00 AE 2C 00 01 AF 2C 00'\r\n '01 AF 2C 00 00 00 AF 2C 00 00 00 01 AE 2C 00 01 AE 2C 00 B0 2C 00 01 B1 2C 00 01 B1 2C 00 00 00'\r\n 'B1 2C 00 00 00 01 B0 2C 00 01 B0 2C 00 B2 2C 00 01 B3 2C 00 01 B3 2C 00 00 00 B3 2C 00 00 00 01'\r\n 'B2 2C 00 01 B2 2C 00 B4 2C 00 01 B5 2C 00 01 B5 2C 00 00 00 B5 2C 00 00 00 01 B4 2C 00 01 B4 2C'\r\n '00 B6 2C 00 01 B7 2C 00 01 B7 2C 00 00 00 B7 2C 00 00 00 01 B6 2C 00 01 B6 2C 00 B8 2C 00 01 B9'\r\n '2C 00 01 B9 2C 00 00 00 B9 2C 00 00 00 01 B8 2C 00 01 B8 2C 00 BA 2C 00 01 BB 2C 00 01 BB 2C 00'\r\n '00 00 BB 2C 00 00 00 01 BA 2C 00 01 BA 2C 00 BC 2C 00 01 BD 2C 00 01 BD 2C 00 00 00 BD 2C 00 00'\r\n '00 01 BC 2C 00 01 BC 2C 00 BE 2C 00 01 BF 2C 00 01 BF 2C 00 00 00 BF 2C 00 00 00 01 BE 2C 00 01'\r\n 'BE 2C 00 C0 2C 00 01 C1 2C 00 01 C1 2C 00 00 00 C1 2C 00 00 00 01 C0 2C 00 01 C0 2C 00 C2 2C 00'\r\n '01 C3 2C 00 01 C3 2C 00 00 00 C3 2C 00 00 00 01 C2 2C 00 01 C2 2C 00 C4 2C 00 01 C5 2C 00 01 C5'\r\n '2C 00 00 00 C5 2C 00 00 00 01 C4 2C 00 01 C4 2C 00 C6 2C 00 01 C7 2C 00 01 C7 2C 00 00 00 C7 2C'\r\n '00 00 00 01 C6 2C 00 01 C6 2C 00 C8 2C 00 01 C9 2C 00 01 C9 2C 00 00 00 C9 2C 00 00 00 01 C8 2C'\r\n '00 01 C8 2C 00 CA 2C 00 01 CB 2C 00 01 CB 2C 00 00 00 CB 2C 00 00 00 01 CA 2C 00 01 CA 2C 00 CC'\r\n '2C 00 01 CD 2C 00 01 CD 2C 00 00 00 CD 2C 00 00 00 01 CC 2C 00 01 CC 2C 00 CE 2C 00 01 CF 2C 00'\r\n '01 CF 2C 00 00 00 CF 2C 00 00 00 01 CE 2C 00 01 CE 2C 00 D0 2C 00 01 D1 2C 00 01 D1 2C 00 00 00'\r\n 'D1 2C 00 00 00 01 D0 2C 00 01 D0 2C 00 D2 2C 00 01 D3 2C 00 01 D3 2C 00 00 00 D3 2C 00 00 00 01'\r\n 'D2 2C 00 01 D2 2C 00 D4 2C 00 01 D5 2C 00 01 D5 2C 00 00 00 D5 2C 00 00 00 01 D4 2C 00 01 D4 2C'\r\n '00 D6 2C 00 01 D7 2C 00 01 D7 2C 00 00 00 D7 2C 00 00 00 01 D6 2C 00 01 D6 2C 00 D8 2C 00 01 D9'\r\n '2C 00 01 D9 2C 00 00 00 D9 2C 00 00 00 01 D8 2C 00 01 D8 2C 00 DA 2C 00 01 DB 2C 00 01 DB 2C 00'\r\n '00 00 DB 2C 00 00 00 01 DA 2C 00 01 DA 2C 00 DC 2C 00 01 DD 2C 00 01 DD 2C 00 00 00 DD 2C 00 00'\r\n '00 01 DC 2C 00 01 DC 2C 00 DE 2C 00 01 DF 2C 00 01 DF 2C 00 00 00 DF 2C 00 00 00 01 DE 2C 00 01'\r\n 'DE 2C 00 E0 2C 00 01 E1 2C 00 01 E1 2C 00 00 00 E1 2C 00 00 00 01 E0 2C 00 01 E0 2C 00 E2 2C 00'\r\n '01 E3 2C 00 01 E3 2C 00 00 00 E3 2C 00 00 00 01 E2 2C 00 01 E2 2C 00 EB 2C 00 01 EC 2C 00 01 EC'\r\n '2C 00 00 00 EC 2C 00 00 00 01 EB 2C 00 01 EB 2C 00 ED 2C 00 01 EE 2C 00 01 EE 2C 00 00 00 EE 2C'\r\n '00 00 00 01 ED 2C 00 01 ED 2C 00 00 2D 00 00 00 01 A0 10 00 01 A0 10 00 01 2D 00 00 00 01 A1 10'\r\n '00 01 A1 10 00 02 2D 00 00 00 01 A2 10 00 01 A2 10 00 03 2D 00 00 00 01 A3 10 00 01 A3 10 00 04'\r\n '2D 00 00 00 01 A4 10 00 01 A4 10 00 05 2D 00 00 00 01 A5 10 00 01 A5 10 00 06 2D 00 00 00 01 A6'\r\n '10 00 01 A6 10 00 07 2D 00 00 00 01 A7 10 00 01 A7 10 00 08 2D 00 00 00 01 A8 10 00 01 A8 10 00'\r\n '09 2D 00 00 00 01 A9 10 00 01 A9 10 00 0A 2D 00 00 00 01 AA 10 00 01 AA 10 00 0B 2D 00 00 00 01'\r\n 'AB 10 00 01 AB 10 00 0C 2D 00 00 00 01 AC 10 00 01 AC 10 00 0D 2D 00 00 00 01 AD 10 00 01 AD 10'\r\n '00 0E 2D 00 00 00 01 AE 10 00 01 AE 10 00 0F 2D 00 00 00 01 AF 10 00 01 AF 10 00 10 2D 00 00 00'\r\n '01 B0 10 00 01 B0 10 00 11 2D 00 00 00 01 B1 10 00 01 B1 10 00 12 2D 00 00 00 01 B2 10 00 01 B2'\r\n '10 00 13 2D 00 00 00 01 B3 10 00 01 B3 10 00 14 2D 00 00 00 01 B4 10 00 01 B4 10 00 15 2D 00 00'\r\n '00 01 B5 10 00 01 B5 10 00 16 2D 00 00 00 01 B6 10 00 01 B6 10 00 17 2D 00 00 00 01 B7 10 00 01'\r\n 'B7 10 00 18 2D 00 00 00 01 B8 10 00 01 B8 10 00 19 2D 00 00 00 01 B9 10 00 01 B9 10 00 1A 2D 00'\r\n '00 00 01 BA 10 00 01 BA 10 00 1B 2D 00 00 00 01 BB 10 00 01 BB 10 00 1C 2D 00 00 00 01 BC 10 00'\r\n '01 BC 10 00 1D 2D 00 00 00 01 BD 10 00 01 BD 10 00 1E 2D 00 00 00 01 BE 10 00 01 BE 10 00 1F 2D'\r\n '00 00 00 01 BF 10 00 01 BF 10 00 20 2D 00 00 00 01 C0 10 00 01 C0 10 00 21 2D 00 00 00 01 C1 10'\r\n '00 01 C1 10 00 22 2D 00 00 00 01 C2 10 00 01 C2 10 00 23 2D 00 00 00 01 C3 10 00 01 C3 10 00 24'\r\n '2D 00 00 00 01 C4 10 00 01 C4 10 00 25 2D 00 00 00 01 C5 10 00 01 C5 10 00 40 A6 00 01 41 A6 00'\r\n '01 41 A6 00 00 00 41 A6 00 00 00 01 40 A6 00 01 40 A6 00 42 A6 00 01 43 A6 00 01 43 A6 00 00 00'\r\n '43 A6 00 00 00 01 42 A6 00 01 42 A6 00 44 A6 00 01 45 A6 00 01 45 A6 00 00 00 45 A6 00 00 00 01'\r\n '44 A6 00 01 44 A6 00 46 A6 00 01 47 A6 00 01 47 A6 00 00 00 47 A6 00 00 00 01 46 A6 00 01 46 A6'\r\n '00 48 A6 00 01 49 A6 00 01 49 A6 00 00 00 49 A6 00 00 00 01 48 A6 00 01 48 A6 00 4A A6 00 01 4B'\r\n 'A6 00 01 4B A6 00 00 00 4B A6 00 00 00 01 4A A6 00 01 4A A6 00 4C A6 00 01 4D A6 00 01 4D A6 00'\r\n '00 00 4D A6 00 00 00 01 4C A6 00 01 4C A6 00 4E A6 00 01 4F A6 00 01 4F A6 00 00 00 4F A6 00 00'\r\n '00 01 4E A6 00 01 4E A6 00 50 A6 00 01 51 A6 00 01 51 A6 00 00 00 51 A6 00 00 00 01 50 A6 00 01'\r\n '50 A6 00 52 A6 00 01 53 A6 00 01 53 A6 00 00 00 53 A6 00 00 00 01 52 A6 00 01 52 A6 00 54 A6 00'\r\n '01 55 A6 00 01 55 A6 00 00 00 55 A6 00 00 00 01 54 A6 00 01 54 A6 00 56 A6 00 01 57 A6 00 01 57'\r\n 'A6 00 00 00 57 A6 00 00 00 01 56 A6 00 01 56 A6 00 58 A6 00 01 59 A6 00 01 59 A6 00 00 00 59 A6'\r\n '00 00 00 01 58 A6 00 01 58 A6 00 5A A6 00 01 5B A6 00 01 5B A6 00 00 00 5B A6 00 00 00 01 5A A6'\r\n '00 01 5A A6 00 5C A6 00 01 5D A6 00 01 5D A6 00 00 00 5D A6 00 00 00 01 5C A6 00 01 5C A6 00 5E'\r\n 'A6 00 01 5F A6 00 01 5F A6 00 00 00 5F A6 00 00 00 01 5E A6 00 01 5E A6 00 60 A6 00 01 61 A6 00'\r\n '01 61 A6 00 00 00 61 A6 00 00 00 01 60 A6 00 01 60 A6 00 62 A6 00 01 63 A6 00 01 63 A6 00 00 00'\r\n '63 A6 00 00 00 01 62 A6 00 01 62 A6 00 64 A6 00 01 65 A6 00 01 65 A6 00 00 00 65 A6 00 00 00 01'\r\n '64 A6 00 01 64 A6 00 66 A6 00 01 67 A6 00 01 67 A6 00 00 00 67 A6 00 00 00 01 66 A6 00 01 66 A6'\r\n '00 68 A6 00 01 69 A6 00 01 69 A6 00 00 00 69 A6 00 00 00 01 68 A6 00 01 68 A6 00 6A A6 00 01 6B'\r\n 'A6 00 01 6B A6 00 00 00 6B A6 00 00 00 01 6A A6 00 01 6A A6 00 6C A6 00 01 6D A6 00 01 6D A6 00'\r\n '00 00 6D A6 00 00 00 01 6C A6 00 01 6C A6 00 80 A6 00 01 81 A6 00 01 81 A6 00 00 00 81 A6 00 00'\r\n '00 01 80 A6 00 01 80 A6 00 82 A6 00 01 83 A6 00 01 83 A6 00 00 00 83 A6 00 00 00 01 82 A6 00 01'\r\n '82 A6 00 84 A6 00 01 85 A6 00 01 85 A6 00 00 00 85 A6 00 00 00 01 84 A6 00 01 84 A6 00 86 A6 00'\r\n '01 87 A6 00 01 87 A6 00 00 00 87 A6 00 00 00 01 86 A6 00 01 86 A6 00 88 A6 00 01 89 A6 00 01 89'\r\n 'A6 00 00 00 89 A6 00 00 00 01 88 A6 00 01 88 A6 00 8A A6 00 01 8B A6 00 01 8B A6 00 00 00 8B A6'\r\n '00 00 00 01 8A A6 00 01 8A A6 00 8C A6 00 01 8D A6 00 01 8D A6 00 00 00 8D A6 00 00 00 01 8C A6'\r\n '00 01 8C A6 00 8E A6 00 01 8F A6 00 01 8F A6 00 00 00 8F A6 00 00 00 01 8E A6 00 01 8E A6 00 90'\r\n 'A6 00 01 91 A6 00 01 91 A6 00 00 00 91 A6 00 00 00 01 90 A6 00 01 90 A6 00 92 A6 00 01 93 A6 00'\r\n '01 93 A6 00 00 00 93 A6 00 00 00 01 92 A6 00 01 92 A6 00 94 A6 00 01 95 A6 00 01 95 A6 00 00 00'\r\n '95 A6 00 00 00 01 94 A6 00 01 94 A6 00 96 A6 00 01 97 A6 00 01 97 A6 00 00 00 97 A6 00 00 00 01'\r\n '96 A6 00 01 96 A6 00 22 A7 00 01 23 A7 00 01 23 A7 00 00 00 23 A7 00 00 00 01 22 A7 00 01 22 A7'\r\n '00 24 A7 00 01 25 A7 00 01 25 A7 00 00 00 25 A7 00 00 00 01 24 A7 00 01 24 A7 00 26 A7 00 01 27'\r\n 'A7 00 01 27 A7 00 00 00 27 A7 00 00 00 01 26 A7 00 01 26 A7 00 28 A7 00 01 29 A7 00 01 29 A7 00'\r\n '00 00 29 A7 00 00 00 01 28 A7 00 01 28 A7 00 2A A7 00 01 2B A7 00 01 2B A7 00 00 00 2B A7 00 00'\r\n '00 01 2A A7 00 01 2A A7 00 2C A7 00 01 2D A7 00 01 2D A7 00 00 00 2D A7 00 00 00 01 2C A7 00 01'\r\n '2C A7 00 2E A7 00 01 2F A7 00 01 2F A7 00 00 00 2F A7 00 00 00 01 2E A7 00 01 2E A7 00 32 A7 00'\r\n '01 33 A7 00 01 33 A7 00 00 00 33 A7 00 00 00 01 32 A7 00 01 32 A7 00 34 A7 00 01 35 A7 00 01 35'\r\n 'A7 00 00 00 35 A7 00 00 00 01 34 A7 00 01 34 A7 00 36 A7 00 01 37 A7 00 01 37 A7 00 00 00 37 A7'\r\n '00 00 00 01 36 A7 00 01 36 A7 00 38 A7 00 01 39 A7 00 01 39 A7 00 00 00 39 A7 00 00 00 01 38 A7'\r\n '00 01 38 A7 00 3A A7 00 01 3B A7 00 01 3B A7 00 00 00 3B A7 00 00 00 01 3A A7 00 01 3A A7 00 3C'\r\n 'A7 00 01 3D A7 00 01 3D A7 00 00 00 3D A7 00 00 00 01 3C A7 00 01 3C A7 00 3E A7 00 01 3F A7 00'\r\n '01 3F A7 00 00 00 3F A7 00 00 00 01 3E A7 00 01 3E A7 00 40 A7 00 01 41 A7 00 01 41 A7 00 00 00'\r\n '41 A7 00 00 00 01 40 A7 00 01 40 A7 00 42 A7 00 01 43 A7 00 01 43 A7 00 00 00 43 A7 00 00 00 01'\r\n '42 A7 00 01 42 A7 00 44 A7 00 01 45 A7 00 01 45 A7 00 00 00 45 A7 00 00 00 01 44 A7 00 01 44 A7'\r\n '00 46 A7 00 01 47 A7 00 01 47 A7 00 00 00 47 A7 00 00 00 01 46 A7 00 01 46 A7 00 48 A7 00 01 49'\r\n 'A7 00 01 49 A7 00 00 00 49 A7 00 00 00 01 48 A7 00 01 48 A7 00 4A A7 00 01 4B A7 00 01 4B A7 00'\r\n '00 00 4B A7 00 00 00 01 4A A7 00 01 4A A7 00 4C A7 00 01 4D A7 00 01 4D A7 00 00 00 4D A7 00 00'\r\n '00 01 4C A7 00 01 4C A7 00 4E A7 00 01 4F A7 00 01 4F A7 00 00 00 4F A7 00 00 00 01 4E A7 00 01'\r\n '4E A7 00 50 A7 00 01 51 A7 00 01 51 A7 00 00 00 51 A7 00 00 00 01 50 A7 00 01 50 A7 00 52 A7 00'\r\n '01 53 A7 00 01 53 A7 00 00 00 53 A7 00 00 00 01 52 A7 00 01 52 A7 00 54 A7 00 01 55 A7 00 01 55'\r\n 'A7 00 00 00 55 A7 00 00 00 01 54 A7 00 01 54 A7 00 56 A7 00 01 57 A7 00 01 57 A7 00 00 00 57 A7'\r\n '00 00 00 01 56 A7 00 01 56 A7 00 58 A7 00 01 59 A7 00 01 59 A7 00 00 00 59 A7 00 00 00 01 58 A7'\r\n '00 01 58 A7 00 5A A7 00 01 5B A7 00 01 5B A7 00 00 00 5B A7 00 00 00 01 5A A7 00 01 5A A7 00 5C'\r\n 'A7 00 01 5D A7 00 01 5D A7 00 00 00 5D A7 00 00 00 01 5C A7 00 01 5C A7 00 5E A7 00 01 5F A7 00'\r\n '01 5F A7 00 00 00 5F A7 00 00 00 01 5E A7 00 01 5E A7 00 60 A7 00 01 61 A7 00 01 61 A7 00 00 00'\r\n '61 A7 00 00 00 01 60 A7 00 01 60 A7 00 62 A7 00 01 63 A7 00 01 63 A7 00 00 00 63 A7 00 00 00 01'\r\n '62 A7 00 01 62 A7 00 64 A7 00 01 65 A7 00 01 65 A7 00 00 00 65 A7 00 00 00 01 64 A7 00 01 64 A7'\r\n '00 66 A7 00 01 67 A7 00 01 67 A7 00 00 00 67 A7 00 00 00 01 66 A7 00 01 66 A7 00 68 A7 00 01 69'\r\n 'A7 00 01 69 A7 00 00 00 69 A7 00 00 00 01 68 A7 00 01 68 A7 00 6A A7 00 01 6B A7 00 01 6B A7 00'\r\n '00 00 6B A7 00 00 00 01 6A A7 00 01 6A A7 00 6C A7 00 01 6D A7 00 01 6D A7 00 00 00 6D A7 00 00'\r\n '00 01 6C A7 00 01 6C A7 00 6E A7 00 01 6F A7 00 01 6F A7 00 00 00 6F A7 00 00 00 01 6E A7 00 01'\r\n '6E A7 00 79 A7 00 01 7A A7 00 01 7A A7 00 00 00 7A A7 00 00 00 01 79 A7 00 01 79 A7 00 7B A7 00'\r\n '01 7C A7 00 01 7C A7 00 00 00 7C A7 00 00 00 01 7B A7 00 01 7B A7 00 7D A7 00 01 79 1D 00 01 79'\r\n '1D 00 00 00 7E A7 00 01 7F A7 00 01 7F A7 00 00 00 7F A7 00 00 00 01 7E A7 00 01 7E A7 00 80 A7'\r\n '00 01 81 A7 00 01 81 A7 00 00 00 81 A7 00 00 00 01 80 A7 00 01 80 A7 00 82 A7 00 01 83 A7 00 01'\r\n '83 A7 00 00 00 83 A7 00 00 00 01 82 A7 00 01 82 A7 00 84 A7 00 01 85 A7 00 01 85 A7 00 00 00 85'\r\n 'A7 00 00 00 01 84 A7 00 01 84 A7 00 86 A7 00 01 87 A7 00 01 87 A7 00 00 00 87 A7 00 00 00 01 86'\r\n 'A7 00 01 86 A7 00 8B A7 00 01 8C A7 00 01 8C A7 00 00 00 8C A7 00 00 00 01 8B A7 00 01 8B A7 00'\r\n '8D A7 00 01 65 02 00 01 65 02 00 00 00 90 A7 00 01 91 A7 00 01 91 A7 00 00 00 91 A7 00 00 00 01'\r\n '90 A7 00 01 90 A7 00 A0 A7 00 01 A1 A7 00 01 A1 A7 00 00 00 A1 A7 00 00 00 01 A0 A7 00 01 A0 A7'\r\n '00 A2 A7 00 01 A3 A7 00 01 A3 A7 00 00 00 A3 A7 00 00 00 01 A2 A7 00 01 A2 A7 00 A4 A7 00 01 A5'\r\n 'A7 00 01 A5 A7 00 00 00 A5 A7 00 00 00 01 A4 A7 00 01 A4 A7 00 A6 A7 00 01 A7 A7 00 01 A7 A7 00'\r\n '00 00 A7 A7 00 00 00 01 A6 A7 00 01 A6 A7 00 A8 A7 00 01 A9 A7 00 01 A9 A7 00 00 00 A9 A7 00 00'\r\n '00 01 A8 A7 00 01 A8 A7 00 00 FB 00 02 66 00 00 66 00 00 01 00 FB 00 02 46 00 00 66 00 00 02 46'\r\n '00 00 46 00 00 01 FB 00 02 66 00 00 69 00 00 01 01 FB 00 02 46 00 00 69 00 00 02 46 00 00 49 00'\r\n '00 02 FB 00 02 66 00 00 6C 00 00 01 02 FB 00 02 46 00 00 6C 00 00 02 46 00 00 4C 00 00 03 FB 00'\r\n '03 66 00 00 66 00 00 69 00 00 01 03 FB 00 03 46 00 00 66 00 00 69 00 00 03 46 00 00 46 00 00 49'\r\n '00 00 04 FB 00 03 66 00 00 66 00 00 6C 00 00 01 04 FB 00 03 46 00 00 66 00 00 6C 00 00 03 46 00'\r\n '00 46 00 00 4C 00 00 05 FB 00 02 73 00 00 74 00 00 01 05 FB 00 02 53 00 00 74 00 00 02 53 00 00'\r\n '54 00 00 06 FB 00 02 73 00 00 74 00 00 01 06 FB 00 02 53 00 00 74 00 00 02 53 00 00 54 00 00 13'\r\n 'FB 00 02 74 05 00 76 05 00 01 13 FB 00 02 44 05 00 76 05 00 02 44 05 00 46 05 00 14 FB 00 02 74'\r\n '05 00 65 05 00 01 14 FB 00 02 44 05 00 65 05 00 02 44 05 00 35 05 00 15 FB 00 02 74 05 00 6B 05'\r\n '00 01 15 FB 00 02 44 05 00 6B 05 00 02 44 05 00 3B 05 00 16 FB 00 02 7E 05 00 76 05 00 01 16 FB'\r\n '00 02 4E 05 00 76 05 00 02 4E 05 00 46 05 00 17 FB 00 02 74 05 00 6D 05 00 01 17 FB 00 02 44 05'\r\n '00 6D 05 00 02 44 05 00 3D 05 00 21 FF 00 01 41 FF 00 01 41 FF 00 00 00 22 FF 00 01 42 FF 00 01'\r\n '42 FF 00 00 00 23 FF 00 01 43 FF 00 01 43 FF 00 00 00 24 FF 00 01 44 FF 00 01 44 FF 00 00 00 25'\r\n 'FF 00 01 45 FF 00 01 45 FF 00 00 00 26 FF 00 01 46 FF 00 01 46 FF 00 00 00 27 FF 00 01 47 FF 00'\r\n '01 47 FF 00 00 00 28 FF 00 01 48 FF 00 01 48 FF 00 00 00 29 FF 00 01 49 FF 00 01 49 FF 00 00 00'\r\n '2A FF 00 01 4A FF 00 01 4A FF 00 00 00 2B FF 00 01 4B FF 00 01 4B FF 00 00 00 2C FF 00 01 4C FF'\r\n '00 01 4C FF 00 00 00 2D FF 00 01 4D FF 00 01 4D FF 00 00 00 2E FF 00 01 4E FF 00 01 4E FF 00 00'\r\n '00 2F FF 00 01 4F FF 00 01 4F FF 00 00 00 30 FF 00 01 50 FF 00 01 50 FF 00 00 00 31 FF 00 01 51'\r\n 'FF 00 01 51 FF 00 00 00 32 FF 00 01 52 FF 00 01 52 FF 00 00 00 33 FF 00 01 53 FF 00 01 53 FF 00'\r\n '00 00 34 FF 00 01 54 FF 00 01 54 FF 00 00 00 35 FF 00 01 55 FF 00 01 55 FF 00 00 00 36 FF 00 01'\r\n '56 FF 00 01 56 FF 00 00 00 37 FF 00 01 57 FF 00 01 57 FF 00 00 00 38 FF 00 01 58 FF 00 01 58 FF'\r\n '00 00 00 39 FF 00 01 59 FF 00 01 59 FF 00 00 00 3A FF 00 01 5A FF 00 01 5A FF 00 00 00 41 FF 00'\r\n '00 00 01 21 FF 00 01 21 FF 00 42 FF 00 00 00 01 22 FF 00 01 22 FF 00 43 FF 00 00 00 01 23 FF 00'\r\n '01 23 FF 00 44 FF 00 00 00 01 24 FF 00 01 24 FF 00 45 FF 00 00 00 01 25 FF 00 01 25 FF 00 46 FF'\r\n '00 00 00 01 26 FF 00 01 26 FF 00 47 FF 00 00 00 01 27 FF 00 01 27 FF 00 48 FF 00 00 00 01 28 FF'\r\n '00 01 28 FF 00 49 FF 00 00 00 01 29 FF 00 01 29 FF 00 4A FF 00 00 00 01 2A FF 00 01 2A FF 00 4B'\r\n 'FF 00 00 00 01 2B FF 00 01 2B FF 00 4C FF 00 00 00 01 2C FF 00 01 2C FF 00 4D FF 00 00 00 01 2D'\r\n 'FF 00 01 2D FF 00 4E FF 00 00 00 01 2E FF 00 01 2E FF 00 4F FF 00 00 00 01 2F FF 00 01 2F FF 00'\r\n '50 FF 00 00 00 01 30 FF 00 01 30 FF 00 51 FF 00 00 00 01 31 FF 00 01 31 FF 00 52 FF 00 00 00 01'\r\n '32 FF 00 01 32 FF 00 53 FF 00 00 00 01 33 FF 00 01 33 FF 00 54 FF 00 00 00 01 34 FF 00 01 34 FF'\r\n '00 55 FF 00 00 00 01 35 FF 00 01 35 FF 00 56 FF 00 00 00 01 36 FF 00 01 36 FF 00 57 FF 00 00 00'\r\n '01 37 FF 00 01 37 FF 00 58 FF 00 00 00 01 38 FF 00 01 38 FF 00 59 FF 00 00 00 01 39 FF 00 01 39'\r\n 'FF 00 5A FF 00 00 00 01 3A FF 00 01 3A FF 00 00 04 01 01 28 04 01 01 28 04 01 00 00 01 04 01 01'\r\n '29 04 01 01 29 04 01 00 00 02 04 01 01 2A 04 01 01 2A 04 01 00 00 03 04 01 01 2B 04 01 01 2B 04'\r\n '01 00 00 04 04 01 01 2C 04 01 01 2C 04 01 00 00 05 04 01 01 2D 04 01 01 2D 04 01 00 00 06 04 01'\r\n '01 2E 04 01 01 2E 04 01 00 00 07 04 01 01 2F 04 01 01 2F 04 01 00 00 08 04 01 01 30 04 01 01 30'\r\n '04 01 00 00 09 04 01 01 31 04 01 01 31 04 01 00 00 0A 04 01 01 32 04 01 01 32 04 01 00 00 0B 04'\r\n '01 01 33 04 01 01 33 04 01 00 00 0C 04 01 01 34 04 01 01 34 04 01 00 00 0D 04 01 01 35 04 01 01'\r\n '35 04 01 00 00 0E 04 01 01 36 04 01 01 36 04 01 00 00 0F 04 01 01 37 04 01 01 37 04 01 00 00 10'\r\n '04 01 01 38 04 01 01 38 04 01 00 00 11 04 01 01 39 04 01 01 39 04 01 00 00 12 04 01 01 3A 04 01'\r\n '01 3A 04 01 00 00 13 04 01 01 3B 04 01 01 3B 04 01 00 00 14 04 01 01 3C 04 01 01 3C 04 01 00 00'\r\n '15 04 01 01 3D 04 01 01 3D 04 01 00 00 16 04 01 01 3E 04 01 01 3E 04 01 00 00 17 04 01 01 3F 04'\r\n '01 01 3F 04 01 00 00 18 04 01 01 40 04 01 01 40 04 01 00 00 19 04 01 01 41 04 01 01 41 04 01 00'\r\n '00 1A 04 01 01 42 04 01 01 42 04 01 00 00 1B 04 01 01 43 04 01 01 43 04 01 00 00 1C 04 01 01 44'\r\n '04 01 01 44 04 01 00 00 1D 04 01 01 45 04 01 01 45 04 01 00 00 1E 04 01 01 46 04 01 01 46 04 01'\r\n '00 00 1F 04 01 01 47 04 01 01 47 04 01 00 00 20 04 01 01 48 04 01 01 48 04 01 00 00 21 04 01 01'\r\n '49 04 01 01 49 04 01 00 00 22 04 01 01 4A 04 01 01 4A 04 01 00 00 23 04 01 01 4B 04 01 01 4B 04'\r\n '01 00 00 24 04 01 01 4C 04 01 01 4C 04 01 00 00 25 04 01 01 4D 04 01 01 4D 04 01 00 00 26 04 01'\r\n '01 4E 04 01 01 4E 04 01 00 00 27 04 01 01 4F 04 01 01 4F 04 01 00 00 28 04 01 00 00 01 00 04 01'\r\n '01 00 04 01 29 04 01 00 00 01 01 04 01 01 01 04 01 2A 04 01 00 00 01 02 04 01 01 02 04 01 2B 04'\r\n '01 00 00 01 03 04 01 01 03 04 01 2C 04 01 00 00 01 04 04 01 01 04 04 01 2D 04 01 00 00 01 05 04'\r\n '01 01 05 04 01 2E 04 01 00 00 01 06 04 01 01 06 04 01 2F 04 01 00 00 01 07 04 01 01 07 04 01 30'\r\n '04 01 00 00 01 08 04 01 01 08 04 01 31 04 01 00 00 01 09 04 01 01 09 04 01 32 04 01 00 00 01 0A'\r\n '04 01 01 0A 04 01 33 04 01 00 00 01 0B 04 01 01 0B 04 01 34 04 01 00 00 01 0C 04 01 01 0C 04 01'\r\n '35 04 01 00 00 01 0D 04 01 01 0D 04 01 36 04 01 00 00 01 0E 04 01 01 0E 04 01 37 04 01 00 00 01'\r\n '0F 04 01 01 0F 04 01 38 04 01 00 00 01 10 04 01 01 10 04 01 39 04 01 00 00 01 11 04 01 01 11 04'\r\n '01 3A 04 01 00 00 01 12 04 01 01 12 04 01 3B 04 01 00 00 01 13 04 01 01 13 04 01 3C 04 01 00 00'\r\n '01 14 04 01 01 14 04 01 3D 04 01 00 00 01 15 04 01 01 15 04 01 3E 04 01 00 00 01 16 04 01 01 16'\r\n '04 01 3F 04 01 00 00 01 17 04 01 01 17 04 01 40 04 01 00 00 01 18 04 01 01 18 04 01 41 04 01 00'\r\n '00 01 19 04 01 01 19 04 01 42 04 01 00 00 01 1A 04 01 01 1A 04 01 43 04 01 00 00 01 1B 04 01 01'\r\n '1B 04 01 44 04 01 00 00 01 1C 04 01 01 1C 04 01 45 04 01 00 00 01 1D 04 01 01 1D 04 01 46 04 01'\r\n '00 00 01 1E 04 01 01 1E 04 01 47 04 01 00 00 01 1F 04 01 01 1F 04 01 48 04 01 00 00 01 20 04 01'\r\n '01 20 04 01 49 04 01 00 00 01 21 04 01 01 21 04 01 4A 04 01 00 00 01 22 04 01 01 22 04 01 4B 04'\r\n '01 00 00 01 23 04 01 01 23 04 01 4C 04 01 00 00 01 24 04 01 01 24 04 01 4D 04 01 00 00 01 25 04'\r\n '01 01 25 04 01 4E 04 01 00 00 01 26 04 01 01 26 04 01 4F 04 01 00 00 01 27 04 01 01 27 04 01'\r\n}\r\n\r\n\r\nLANGUAGE 0,0 DECOMPOSITION UNICODEDATA LOADONCALL MOVEABLE DISCARDABLE\r\n{\r\n 'B7 15 00 00 A0 00 00 01 02 20 00 00 A8 00 00 02 10 20 00 00 08 03 00 AA 00 00 01 08 61 00 00 AF'\r\n '00 00 02 10 20 00 00 04 03 00 B2 00 00 01 08 32 00 00 B3 00 00 01 08 33 00 00 B4 00 00 02 10 20'\r\n '00 00 01 03 00 B5 00 00 01 10 BC 03 00 B8 00 00 02 10 20 00 00 27 03 00 B9 00 00 01 08 31 00 00'\r\n 'BA 00 00 01 08 6F 00 00 BC 00 00 03 0F 31 00 00 44 20 00 34 00 00 BD 00 00 03 0F 31 00 00 44 20'\r\n '00 32 00 00 BE 00 00 03 0F 33 00 00 44 20 00 34 00 00 C0 00 00 02 00 41 00 00 00 03 00 C1 00 00'\r\n '02 00 41 00 00 01 03 00 C2 00 00 02 00 41 00 00 02 03 00 C3 00 00 02 00 41 00 00 03 03 00 C4 00'\r\n '00 02 00 41 00 00 08 03 00 C5 00 00 02 00 41 00 00 0A 03 00 C7 00 00 02 00 43 00 00 27 03 00 C8'\r\n '00 00 02 00 45 00 00 00 03 00 C9 00 00 02 00 45 00 00 01 03 00 CA 00 00 02 00 45 00 00 02 03 00'\r\n 'CB 00 00 02 00 45 00 00 08 03 00 CC 00 00 02 00 49 00 00 00 03 00 CD 00 00 02 00 49 00 00 01 03'\r\n '00 CE 00 00 02 00 49 00 00 02 03 00 CF 00 00 02 00 49 00 00 08 03 00 D1 00 00 02 00 4E 00 00 03'\r\n '03 00 D2 00 00 02 00 4F 00 00 00 03 00 D3 00 00 02 00 4F 00 00 01 03 00 D4 00 00 02 00 4F 00 00'\r\n '02 03 00 D5 00 00 02 00 4F 00 00 03 03 00 D6 00 00 02 00 4F 00 00 08 03 00 D9 00 00 02 00 55 00'\r\n '00 00 03 00 DA 00 00 02 00 55 00 00 01 03 00 DB 00 00 02 00 55 00 00 02 03 00 DC 00 00 02 00 55'\r\n '00 00 08 03 00 DD 00 00 02 00 59 00 00 01 03 00 E0 00 00 02 00 61 00 00 00 03 00 E1 00 00 02 00'\r\n '61 00 00 01 03 00 E2 00 00 02 00 61 00 00 02 03 00 E3 00 00 02 00 61 00 00 03 03 00 E4 00 00 02'\r\n '00 61 00 00 08 03 00 E5 00 00 02 00 61 00 00 0A 03 00 E7 00 00 02 00 63 00 00 27 03 00 E8 00 00'\r\n '02 00 65 00 00 00 03 00 E9 00 00 02 00 65 00 00 01 03 00 EA 00 00 02 00 65 00 00 02 03 00 EB 00'\r\n '00 02 00 65 00 00 08 03 00 EC 00 00 02 00 69 00 00 00 03 00 ED 00 00 02 00 69 00 00 01 03 00 EE'\r\n '00 00 02 00 69 00 00 02 03 00 EF 00 00 02 00 69 00 00 08 03 00 F1 00 00 02 00 6E 00 00 03 03 00'\r\n 'F2 00 00 02 00 6F 00 00 00 03 00 F3 00 00 02 00 6F 00 00 01 03 00 F4 00 00 02 00 6F 00 00 02 03'\r\n '00 F5 00 00 02 00 6F 00 00 03 03 00 F6 00 00 02 00 6F 00 00 08 03 00 F9 00 00 02 00 75 00 00 00'\r\n '03 00 FA 00 00 02 00 75 00 00 01 03 00 FB 00 00 02 00 75 00 00 02 03 00 FC 00 00 02 00 75 00 00'\r\n '08 03 00 FD 00 00 02 00 79 00 00 01 03 00 FF 00 00 02 00 79 00 00 08 03 00 00 01 00 02 00 41 00'\r\n '00 04 03 00 01 01 00 02 00 61 00 00 04 03 00 02 01 00 02 00 41 00 00 06 03 00 03 01 00 02 00 61'\r\n '00 00 06 03 00 04 01 00 02 00 41 00 00 28 03 00 05 01 00 02 00 61 00 00 28 03 00 06 01 00 02 00'\r\n '43 00 00 01 03 00 07 01 00 02 00 63 00 00 01 03 00 08 01 00 02 00 43 00 00 02 03 00 09 01 00 02'\r\n '00 63 00 00 02 03 00 0A 01 00 02 00 43 00 00 07 03 00 0B 01 00 02 00 63 00 00 07 03 00 0C 01 00'\r\n '02 00 43 00 00 0C 03 00 0D 01 00 02 00 63 00 00 0C 03 00 0E 01 00 02 00 44 00 00 0C 03 00 0F 01'\r\n '00 02 00 64 00 00 0C 03 00 12 01 00 02 00 45 00 00 04 03 00 13 01 00 02 00 65 00 00 04 03 00 14'\r\n '01 00 02 00 45 00 00 06 03 00 15 01 00 02 00 65 00 00 06 03 00 16 01 00 02 00 45 00 00 07 03 00'\r\n '17 01 00 02 00 65 00 00 07 03 00 18 01 00 02 00 45 00 00 28 03 00 19 01 00 02 00 65 00 00 28 03'\r\n '00 1A 01 00 02 00 45 00 00 0C 03 00 1B 01 00 02 00 65 00 00 0C 03 00 1C 01 00 02 00 47 00 00 02'\r\n '03 00 1D 01 00 02 00 67 00 00 02 03 00 1E 01 00 02 00 47 00 00 06 03 00 1F 01 00 02 00 67 00 00'\r\n '06 03 00 20 01 00 02 00 47 00 00 07 03 00 21 01 00 02 00 67 00 00 07 03 00 22 01 00 02 00 47 00'\r\n '00 27 03 00 23 01 00 02 00 67 00 00 27 03 00 24 01 00 02 00 48 00 00 02 03 00 25 01 00 02 00 68'\r\n '00 00 02 03 00 28 01 00 02 00 49 00 00 03 03 00 29 01 00 02 00 69 00 00 03 03 00 2A 01 00 02 00'\r\n '49 00 00 04 03 00 2B 01 00 02 00 69 00 00 04 03 00 2C 01 00 02 00 49 00 00 06 03 00 2D 01 00 02'\r\n '00 69 00 00 06 03 00 2E 01 00 02 00 49 00 00 28 03 00 2F 01 00 02 00 69 00 00 28 03 00 30 01 00'\r\n '02 00 49 00 00 07 03 00 32 01 00 02 10 49 00 00 4A 00 00 33 01 00 02 10 69 00 00 6A 00 00 34 01'\r\n '00 02 00 4A 00 00 02 03 00 35 01 00 02 00 6A 00 00 02 03 00 36 01 00 02 00 4B 00 00 27 03 00 37'\r\n '01 00 02 00 6B 00 00 27 03 00 39 01 00 02 00 4C 00 00 01 03 00 3A 01 00 02 00 6C 00 00 01 03 00'\r\n '3B 01 00 02 00 4C 00 00 27 03 00 3C 01 00 02 00 6C 00 00 27 03 00 3D 01 00 02 00 4C 00 00 0C 03'\r\n '00 3E 01 00 02 00 6C 00 00 0C 03 00 3F 01 00 02 10 4C 00 00 B7 00 00 40 01 00 02 10 6C 00 00 B7'\r\n '00 00 43 01 00 02 00 4E 00 00 01 03 00 44 01 00 02 00 6E 00 00 01 03 00 45 01 00 02 00 4E 00 00'\r\n '27 03 00 46 01 00 02 00 6E 00 00 27 03 00 47 01 00 02 00 4E 00 00 0C 03 00 48 01 00 02 00 6E 00'\r\n '00 0C 03 00 49 01 00 02 10 BC 02 00 6E 00 00 4C 01 00 02 00 4F 00 00 04 03 00 4D 01 00 02 00 6F'\r\n '00 00 04 03 00 4E 01 00 02 00 4F 00 00 06 03 00 4F 01 00 02 00 6F 00 00 06 03 00 50 01 00 02 00'\r\n '4F 00 00 0B 03 00 51 01 00 02 00 6F 00 00 0B 03 00 54 01 00 02 00 52 00 00 01 03 00 55 01 00 02'\r\n '00 72 00 00 01 03 00 56 01 00 02 00 52 00 00 27 03 00 57 01 00 02 00 72 00 00 27 03 00 58 01 00'\r\n '02 00 52 00 00 0C 03 00 59 01 00 02 00 72 00 00 0C 03 00 5A 01 00 02 00 53 00 00 01 03 00 5B 01'\r\n '00 02 00 73 00 00 01 03 00 5C 01 00 02 00 53 00 00 02 03 00 5D 01 00 02 00 73 00 00 02 03 00 5E'\r\n '01 00 02 00 53 00 00 27 03 00 5F 01 00 02 00 73 00 00 27 03 00 60 01 00 02 00 53 00 00 0C 03 00'\r\n '61 01 00 02 00 73 00 00 0C 03 00 62 01 00 02 00 54 00 00 27 03 00 63 01 00 02 00 74 00 00 27 03'\r\n '00 64 01 00 02 00 54 00 00 0C 03 00 65 01 00 02 00 74 00 00 0C 03 00 68 01 00 02 00 55 00 00 03'\r\n '03 00 69 01 00 02 00 75 00 00 03 03 00 6A 01 00 02 00 55 00 00 04 03 00 6B 01 00 02 00 75 00 00'\r\n '04 03 00 6C 01 00 02 00 55 00 00 06 03 00 6D 01 00 02 00 75 00 00 06 03 00 6E 01 00 02 00 55 00'\r\n '00 0A 03 00 6F 01 00 02 00 75 00 00 0A 03 00 70 01 00 02 00 55 00 00 0B 03 00 71 01 00 02 00 75'\r\n '00 00 0B 03 00 72 01 00 02 00 55 00 00 28 03 00 73 01 00 02 00 75 00 00 28 03 00 74 01 00 02 00'\r\n '57 00 00 02 03 00 75 01 00 02 00 77 00 00 02 03 00 76 01 00 02 00 59 00 00 02 03 00 77 01 00 02'\r\n '00 79 00 00 02 03 00 78 01 00 02 00 59 00 00 08 03 00 79 01 00 02 00 5A 00 00 01 03 00 7A 01 00'\r\n '02 00 7A 00 00 01 03 00 7B 01 00 02 00 5A 00 00 07 03 00 7C 01 00 02 00 7A 00 00 07 03 00 7D 01'\r\n '00 02 00 5A 00 00 0C 03 00 7E 01 00 02 00 7A 00 00 0C 03 00 7F 01 00 01 10 73 00 00 A0 01 00 02'\r\n '00 4F 00 00 1B 03 00 A1 01 00 02 00 6F 00 00 1B 03 00 AF 01 00 02 00 55 00 00 1B 03 00 B0 01 00'\r\n '02 00 75 00 00 1B 03 00 C4 01 00 03 10 44 00 00 5A 00 00 0C 03 00 C5 01 00 03 10 44 00 00 7A 00'\r\n '00 0C 03 00 C6 01 00 03 10 64 00 00 7A 00 00 0C 03 00 C7 01 00 02 10 4C 00 00 4A 00 00 C8 01 00'\r\n '02 10 4C 00 00 6A 00 00 C9 01 00 02 10 6C 00 00 6A 00 00 CA 01 00 02 10 4E 00 00 4A 00 00 CB 01'\r\n '00 02 10 4E 00 00 6A 00 00 CC 01 00 02 10 6E 00 00 6A 00 00 CD 01 00 02 00 41 00 00 0C 03 00 CE'\r\n '01 00 02 00 61 00 00 0C 03 00 CF 01 00 02 00 49 00 00 0C 03 00 D0 01 00 02 00 69 00 00 0C 03 00'\r\n 'D1 01 00 02 00 4F 00 00 0C 03 00 D2 01 00 02 00 6F 00 00 0C 03 00 D3 01 00 02 00 55 00 00 0C 03'\r\n '00 D4 01 00 02 00 75 00 00 0C 03 00 D5 01 00 03 00 55 00 00 08 03 00 04 03 00 D6 01 00 03 00 75'\r\n '00 00 08 03 00 04 03 00 D7 01 00 03 00 55 00 00 08 03 00 01 03 00 D8 01 00 03 00 75 00 00 08 03'\r\n '00 01 03 00 D9 01 00 03 00 55 00 00 08 03 00 0C 03 00 DA 01 00 03 00 75 00 00 08 03 00 0C 03 00'\r\n 'DB 01 00 03 00 55 00 00 08 03 00 00 03 00 DC 01 00 03 00 75 00 00 08 03 00 00 03 00 DE 01 00 03'\r\n '00 41 00 00 08 03 00 04 03 00 DF 01 00 03 00 61 00 00 08 03 00 04 03 00 E0 01 00 03 00 41 00 00'\r\n '07 03 00 04 03 00 E1 01 00 03 00 61 00 00 07 03 00 04 03 00 E2 01 00 02 00 C6 00 00 04 03 00 E3'\r\n '01 00 02 00 E6 00 00 04 03 00 E6 01 00 02 00 47 00 00 0C 03 00 E7 01 00 02 00 67 00 00 0C 03 00'\r\n 'E8 01 00 02 00 4B 00 00 0C 03 00 E9 01 00 02 00 6B 00 00 0C 03 00 EA 01 00 02 00 4F 00 00 28 03'\r\n '00 EB 01 00 02 00 6F 00 00 28 03 00 EC 01 00 03 00 4F 00 00 28 03 00 04 03 00 ED 01 00 03 00 6F'\r\n '00 00 28 03 00 04 03 00 EE 01 00 02 00 B7 01 00 0C 03 00 EF 01 00 02 00 92 02 00 0C 03 00 F0 01'\r\n '00 02 00 6A 00 00 0C 03 00 F1 01 00 02 10 44 00 00 5A 00 00 F2 01 00 02 10 44 00 00 7A 00 00 F3'\r\n '01 00 02 10 64 00 00 7A 00 00 F4 01 00 02 00 47 00 00 01 03 00 F5 01 00 02 00 67 00 00 01 03 00'\r\n 'F8 01 00 02 00 4E 00 00 00 03 00 F9 01 00 02 00 6E 00 00 00 03 00 FA 01 00 03 00 41 00 00 0A 03'\r\n '00 01 03 00 FB 01 00 03 00 61 00 00 0A 03 00 01 03 00 FC 01 00 02 00 C6 00 00 01 03 00 FD 01 00'\r\n '02 00 E6 00 00 01 03 00 FE 01 00 02 00 D8 00 00 01 03 00 FF 01 00 02 00 F8 00 00 01 03 00 00 02'\r\n '00 02 00 41 00 00 0F 03 00 01 02 00 02 00 61 00 00 0F 03 00 02 02 00 02 00 41 00 00 11 03 00 03'\r\n '02 00 02 00 61 00 00 11 03 00 04 02 00 02 00 45 00 00 0F 03 00 05 02 00 02 00 65 00 00 0F 03 00'\r\n '06 02 00 02 00 45 00 00 11 03 00 07 02 00 02 00 65 00 00 11 03 00 08 02 00 02 00 49 00 00 0F 03'\r\n '00 09 02 00 02 00 69 00 00 0F 03 00 0A 02 00 02 00 49 00 00 11 03 00 0B 02 00 02 00 69 00 00 11'\r\n '03 00 0C 02 00 02 00 4F 00 00 0F 03 00 0D 02 00 02 00 6F 00 00 0F 03 00 0E 02 00 02 00 4F 00 00'\r\n '11 03 00 0F 02 00 02 00 6F 00 00 11 03 00 10 02 00 02 00 52 00 00 0F 03 00 11 02 00 02 00 72 00'\r\n '00 0F 03 00 12 02 00 02 00 52 00 00 11 03 00 13 02 00 02 00 72 00 00 11 03 00 14 02 00 02 00 55'\r\n '00 00 0F 03 00 15 02 00 02 00 75 00 00 0F 03 00 16 02 00 02 00 55 00 00 11 03 00 17 02 00 02 00'\r\n '75 00 00 11 03 00 18 02 00 02 00 53 00 00 26 03 00 19 02 00 02 00 73 00 00 26 03 00 1A 02 00 02'\r\n '00 54 00 00 26 03 00 1B 02 00 02 00 74 00 00 26 03 00 1E 02 00 02 00 48 00 00 0C 03 00 1F 02 00'\r\n '02 00 68 00 00 0C 03 00 26 02 00 02 00 41 00 00 07 03 00 27 02 00 02 00 61 00 00 07 03 00 28 02'\r\n '00 02 00 45 00 00 27 03 00 29 02 00 02 00 65 00 00 27 03 00 2A 02 00 03 00 4F 00 00 08 03 00 04'\r\n '03 00 2B 02 00 03 00 6F 00 00 08 03 00 04 03 00 2C 02 00 03 00 4F 00 00 03 03 00 04 03 00 2D 02'\r\n '00 03 00 6F 00 00 03 03 00 04 03 00 2E 02 00 02 00 4F 00 00 07 03 00 2F 02 00 02 00 6F 00 00 07'\r\n '03 00 30 02 00 03 00 4F 00 00 07 03 00 04 03 00 31 02 00 03 00 6F 00 00 07 03 00 04 03 00 32 02'\r\n '00 02 00 59 00 00 04 03 00 33 02 00 02 00 79 00 00 04 03 00 B0 02 00 01 08 68 00 00 B1 02 00 01'\r\n '08 66 02 00 B2 02 00 01 08 6A 00 00 B3 02 00 01 08 72 00 00 B4 02 00 01 08 79 02 00 B5 02 00 01'\r\n '08 7B 02 00 B6 02 00 01 08 81 02 00 B7 02 00 01 08 77 00 00 B8 02 00 01 08 79 00 00 D8 02 00 02'\r\n '10 20 00 00 06 03 00 D9 02 00 02 10 20 00 00 07 03 00 DA 02 00 02 10 20 00 00 0A 03 00 DB 02 00'\r\n '02 10 20 00 00 28 03 00 DC 02 00 02 10 20 00 00 03 03 00 DD 02 00 02 10 20 00 00 0B 03 00 E0 02'\r\n '00 01 08 63 02 00 E1 02 00 01 08 6C 00 00 E2 02 00 01 08 73 00 00 E3 02 00 01 08 78 00 00 E4 02'\r\n '00 01 08 95 02 00 40 03 00 01 00 00 03 00 41 03 00 01 00 01 03 00 43 03 00 01 00 13 03 00 44 03'\r\n '00 02 00 08 03 00 01 03 00 74 03 00 01 00 B9 02 00 7A 03 00 02 10 20 00 00 45 03 00 7E 03 00 01'\r\n '00 3B 00 00 84 03 00 02 10 20 00 00 01 03 00 85 03 00 03 00 20 00 00 08 03 00 01 03 00 86 03 00'\r\n '02 00 91 03 00 01 03 00 87 03 00 01 00 B7 00 00 88 03 00 02 00 95 03 00 01 03 00 89 03 00 02 00'\r\n '97 03 00 01 03 00 8A 03 00 02 00 99 03 00 01 03 00 8C 03 00 02 00 9F 03 00 01 03 00 8E 03 00 02'\r\n '00 A5 03 00 01 03 00 8F 03 00 02 00 A9 03 00 01 03 00 90 03 00 03 00 B9 03 00 08 03 00 01 03 00'\r\n 'AA 03 00 02 00 99 03 00 08 03 00 AB 03 00 02 00 A5 03 00 08 03 00 AC 03 00 02 00 B1 03 00 01 03'\r\n '00 AD 03 00 02 00 B5 03 00 01 03 00 AE 03 00 02 00 B7 03 00 01 03 00 AF 03 00 02 00 B9 03 00 01'\r\n '03 00 B0 03 00 03 00 C5 03 00 08 03 00 01 03 00 CA 03 00 02 00 B9 03 00 08 03 00 CB 03 00 02 00'\r\n 'C5 03 00 08 03 00 CC 03 00 02 00 BF 03 00 01 03 00 CD 03 00 02 00 C5 03 00 01 03 00 CE 03 00 02'\r\n '00 C9 03 00 01 03 00 D0 03 00 01 10 B2 03 00 D1 03 00 01 10 B8 03 00 D2 03 00 01 10 A5 03 00 D3'\r\n '03 00 02 00 A5 03 00 01 03 00 D4 03 00 02 00 A5 03 00 08 03 00 D5 03 00 01 10 C6 03 00 D6 03 00'\r\n '01 10 C0 03 00 F0 03 00 01 10 BA 03 00 F1 03 00 01 10 C1 03 00 F2 03 00 01 10 C2 03 00 F4 03 00'\r\n '01 10 98 03 00 F5 03 00 01 10 B5 03 00 F9 03 00 01 10 A3 03 00 00 04 00 02 00 15 04 00 00 03 00'\r\n '01 04 00 02 00 15 04 00 08 03 00 03 04 00 02 00 13 04 00 01 03 00 07 04 00 02 00 06 04 00 08 03'\r\n '00 0C 04 00 02 00 1A 04 00 01 03 00 0D 04 00 02 00 18 04 00 00 03 00 0E 04 00 02 00 23 04 00 06'\r\n '03 00 19 04 00 02 00 18 04 00 06 03 00 39 04 00 02 00 38 04 00 06 03 00 50 04 00 02 00 35 04 00'\r\n '00 03 00 51 04 00 02 00 35 04 00 08 03 00 53 04 00 02 00 33 04 00 01 03 00 57 04 00 02 00 56 04'\r\n '00 08 03 00 5C 04 00 02 00 3A 04 00 01 03 00 5D 04 00 02 00 38 04 00 00 03 00 5E 04 00 02 00 43'\r\n '04 00 06 03 00 76 04 00 02 00 74 04 00 0F 03 00 77 04 00 02 00 75 04 00 0F 03 00 C1 04 00 02 00'\r\n '16 04 00 06 03 00 C2 04 00 02 00 36 04 00 06 03 00 D0 04 00 02 00 10 04 00 06 03 00 D1 04 00 02'\r\n '00 30 04 00 06 03 00 D2 04 00 02 00 10 04 00 08 03 00 D3 04 00 02 00 30 04 00 08 03 00 D6 04 00'\r\n '02 00 15 04 00 06 03 00 D7 04 00 02 00 35 04 00 06 03 00 DA 04 00 02 00 D8 04 00 08 03 00 DB 04'\r\n '00 02 00 D9 04 00 08 03 00 DC 04 00 02 00 16 04 00 08 03 00 DD 04 00 02 00 36 04 00 08 03 00 DE'\r\n '04 00 02 00 17 04 00 08 03 00 DF 04 00 02 00 37 04 00 08 03 00 E2 04 00 02 00 18 04 00 04 03 00'\r\n 'E3 04 00 02 00 38 04 00 04 03 00 E4 04 00 02 00 18 04 00 08 03 00 E5 04 00 02 00 38 04 00 08 03'\r\n '00 E6 04 00 02 00 1E 04 00 08 03 00 E7 04 00 02 00 3E 04 00 08 03 00 EA 04 00 02 00 E8 04 00 08'\r\n '03 00 EB 04 00 02 00 E9 04 00 08 03 00 EC 04 00 02 00 2D 04 00 08 03 00 ED 04 00 02 00 4D 04 00'\r\n '08 03 00 EE 04 00 02 00 23 04 00 04 03 00 EF 04 00 02 00 43 04 00 04 03 00 F0 04 00 02 00 23 04'\r\n '00 08 03 00 F1 04 00 02 00 43 04 00 08 03 00 F2 04 00 02 00 23 04 00 0B 03 00 F3 04 00 02 00 43'\r\n '04 00 0B 03 00 F4 04 00 02 00 27 04 00 08 03 00 F5 04 00 02 00 47 04 00 08 03 00 F8 04 00 02 00'\r\n '2B 04 00 08 03 00 F9 04 00 02 00 4B 04 00 08 03 00 87 05 00 02 10 65 05 00 82 05 00 22 06 00 02'\r\n '00 27 06 00 53 06 00 23 06 00 02 00 27 06 00 54 06 00 24 06 00 02 00 48 06 00 54 06 00 25 06 00'\r\n '02 00 27 06 00 55 06 00 26 06 00 02 00 4A 06 00 54 06 00 75 06 00 02 10 27 06 00 74 06 00 76 06'\r\n '00 02 10 48 06 00 74 06 00 77 06 00 02 10 C7 06 00 74 06 00 78 06 00 02 10 4A 06 00 74 06 00 C0'\r\n '06 00 02 00 D5 06 00 54 06 00 C2 06 00 02 00 C1 06 00 54 06 00 D3 06 00 02 00 D2 06 00 54 06 00'\r\n '29 09 00 02 00 28 09 00 3C 09 00 31 09 00 02 00 30 09 00 3C 09 00 34 09 00 02 00 33 09 00 3C 09'\r\n '00 58 09 00 02 00 15 09 00 3C 09 00 59 09 00 02 00 16 09 00 3C 09 00 5A 09 00 02 00 17 09 00 3C'\r\n '09 00 5B 09 00 02 00 1C 09 00 3C 09 00 5C 09 00 02 00 21 09 00 3C 09 00 5D 09 00 02 00 22 09 00'\r\n '3C 09 00 5E 09 00 02 00 2B 09 00 3C 09 00 5F 09 00 02 00 2F 09 00 3C 09 00 CB 09 00 02 00 C7 09'\r\n '00 BE 09 00 CC 09 00 02 00 C7 09 00 D7 09 00 DC 09 00 02 00 A1 09 00 BC 09 00 DD 09 00 02 00 A2'\r\n '09 00 BC 09 00 DF 09 00 02 00 AF 09 00 BC 09 00 33 0A 00 02 00 32 0A 00 3C 0A 00 36 0A 00 02 00'\r\n '38 0A 00 3C 0A 00 59 0A 00 02 00 16 0A 00 3C 0A 00 5A 0A 00 02 00 17 0A 00 3C 0A 00 5B 0A 00 02'\r\n '00 1C 0A 00 3C 0A 00 5E 0A 00 02 00 2B 0A 00 3C 0A 00 48 0B 00 02 00 47 0B 00 56 0B 00 4B 0B 00'\r\n '02 00 47 0B 00 3E 0B 00 4C 0B 00 02 00 47 0B 00 57 0B 00 5C 0B 00 02 00 21 0B 00 3C 0B 00 5D 0B'\r\n '00 02 00 22 0B 00 3C 0B 00 94 0B 00 02 00 92 0B 00 D7 0B 00 CA 0B 00 02 00 C6 0B 00 BE 0B 00 CB'\r\n '0B 00 02 00 C7 0B 00 BE 0B 00 CC 0B 00 02 00 C6 0B 00 D7 0B 00 48 0C 00 02 00 46 0C 00 56 0C 00'\r\n 'C0 0C 00 02 00 BF 0C 00 D5 0C 00 C7 0C 00 02 00 C6 0C 00 D5 0C 00 C8 0C 00 02 00 C6 0C 00 D6 0C'\r\n '00 CA 0C 00 02 00 C6 0C 00 C2 0C 00 CB 0C 00 03 00 C6 0C 00 C2 0C 00 D5 0C 00 4A 0D 00 02 00 46'\r\n '0D 00 3E 0D 00 4B 0D 00 02 00 47 0D 00 3E 0D 00 4C 0D 00 02 00 46 0D 00 57 0D 00 DA 0D 00 02 00'\r\n 'D9 0D 00 CA 0D 00 DC 0D 00 02 00 D9 0D 00 CF 0D 00 DD 0D 00 03 00 D9 0D 00 CF 0D 00 CA 0D 00 DE'\r\n '0D 00 02 00 D9 0D 00 DF 0D 00 33 0E 00 02 10 4D 0E 00 32 0E 00 B3 0E 00 02 10 CD 0E 00 B2 0E 00'\r\n 'DC 0E 00 02 10 AB 0E 00 99 0E 00 DD 0E 00 02 10 AB 0E 00 A1 0E 00 0C 0F 00 01 02 0B 0F 00 43 0F'\r\n '00 02 00 42 0F 00 B7 0F 00 4D 0F 00 02 00 4C 0F 00 B7 0F 00 52 0F 00 02 00 51 0F 00 B7 0F 00 57'\r\n '0F 00 02 00 56 0F 00 B7 0F 00 5C 0F 00 02 00 5B 0F 00 B7 0F 00 69 0F 00 02 00 40 0F 00 B5 0F 00'\r\n '73 0F 00 02 00 71 0F 00 72 0F 00 75 0F 00 02 00 71 0F 00 74 0F 00 76 0F 00 02 00 B2 0F 00 80 0F'\r\n '00 77 0F 00 03 10 B2 0F 00 71 0F 00 80 0F 00 78 0F 00 02 00 B3 0F 00 80 0F 00 79 0F 00 03 10 B3'\r\n '0F 00 71 0F 00 80 0F 00 81 0F 00 02 00 71 0F 00 80 0F 00 93 0F 00 02 00 92 0F 00 B7 0F 00 9D 0F'\r\n '00 02 00 9C 0F 00 B7 0F 00 A2 0F 00 02 00 A1 0F 00 B7 0F 00 A7 0F 00 02 00 A6 0F 00 B7 0F 00 AC'\r\n '0F 00 02 00 AB 0F 00 B7 0F 00 B9 0F 00 02 00 90 0F 00 B5 0F 00 26 10 00 02 00 25 10 00 2E 10 00'\r\n 'FC 10 00 01 08 DC 10 00 06 1B 00 02 00 05 1B 00 35 1B 00 08 1B 00 02 00 07 1B 00 35 1B 00 0A 1B'\r\n '00 02 00 09 1B 00 35 1B 00 0C 1B 00 02 00 0B 1B 00 35 1B 00 0E 1B 00 02 00 0D 1B 00 35 1B 00 12'\r\n '1B 00 02 00 11 1B 00 35 1B 00 3B 1B 00 02 00 3A 1B 00 35 1B 00 3D 1B 00 02 00 3C 1B 00 35 1B 00'\r\n '40 1B 00 02 00 3E 1B 00 35 1B 00 41 1B 00 02 00 3F 1B 00 35 1B 00 43 1B 00 02 00 42 1B 00 35 1B'\r\n '00 2C 1D 00 01 08 41 00 00 2D 1D 00 01 08 C6 00 00 2E 1D 00 01 08 42 00 00 30 1D 00 01 08 44 00'\r\n '00 31 1D 00 01 08 45 00 00 32 1D 00 01 08 8E 01 00 33 1D 00 01 08 47 00 00 34 1D 00 01 08 48 00'\r\n '00 35 1D 00 01 08 49 00 00 36 1D 00 01 08 4A 00 00 37 1D 00 01 08 4B 00 00 38 1D 00 01 08 4C 00'\r\n '00 39 1D 00 01 08 4D 00 00 3A 1D 00 01 08 4E 00 00 3C 1D 00 01 08 4F 00 00 3D 1D 00 01 08 22 02'\r\n '00 3E 1D 00 01 08 50 00 00 3F 1D 00 01 08 52 00 00 40 1D 00 01 08 54 00 00 41 1D 00 01 08 55 00'\r\n '00 42 1D 00 01 08 57 00 00 43 1D 00 01 08 61 00 00 44 1D 00 01 08 50 02 00 45 1D 00 01 08 51 02'\r\n '00 46 1D 00 01 08 02 1D 00 47 1D 00 01 08 62 00 00 48 1D 00 01 08 64 00 00 49 1D 00 01 08 65 00'\r\n '00 4A 1D 00 01 08 59 02 00 4B 1D 00 01 08 5B 02 00 4C 1D 00 01 08 5C 02 00 4D 1D 00 01 08 67 00'\r\n '00 4F 1D 00 01 08 6B 00 00 50 1D 00 01 08 6D 00 00 51 1D 00 01 08 4B 01 00 52 1D 00 01 08 6F 00'\r\n '00 53 1D 00 01 08 54 02 00 54 1D 00 01 08 16 1D 00 55 1D 00 01 08 17 1D 00 56 1D 00 01 08 70 00'\r\n '00 57 1D 00 01 08 74 00 00 58 1D 00 01 08 75 00 00 59 1D 00 01 08 1D 1D 00 5A 1D 00 01 08 6F 02'\r\n '00 5B 1D 00 01 08 76 00 00 5C 1D 00 01 08 25 1D 00 5D 1D 00 01 08 B2 03 00 5E 1D 00 01 08 B3 03'\r\n '00 5F 1D 00 01 08 B4 03 00 60 1D 00 01 08 C6 03 00 61 1D 00 01 08 C7 03 00 62 1D 00 01 09 69 00'\r\n '00 63 1D 00 01 09 72 00 00 64 1D 00 01 09 75 00 00 65 1D 00 01 09 76 00 00 66 1D 00 01 09 B2 03'\r\n '00 67 1D 00 01 09 B3 03 00 68 1D 00 01 09 C1 03 00 69 1D 00 01 09 C6 03 00 6A 1D 00 01 09 C7 03'\r\n '00 78 1D 00 01 08 3D 04 00 9B 1D 00 01 08 52 02 00 9C 1D 00 01 08 63 00 00 9D 1D 00 01 08 55 02'\r\n '00 9E 1D 00 01 08 F0 00 00 9F 1D 00 01 08 5C 02 00 A0 1D 00 01 08 66 00 00 A1 1D 00 01 08 5F 02'\r\n '00 A2 1D 00 01 08 61 02 00 A3 1D 00 01 08 65 02 00 A4 1D 00 01 08 68 02 00 A5 1D 00 01 08 69 02'\r\n '00 A6 1D 00 01 08 6A 02 00 A7 1D 00 01 08 7B 1D 00 A8 1D 00 01 08 9D 02 00 A9 1D 00 01 08 6D 02'\r\n '00 AA 1D 00 01 08 85 1D 00 AB 1D 00 01 08 9F 02 00 AC 1D 00 01 08 71 02 00 AD 1D 00 01 08 70 02'\r\n '00 AE 1D 00 01 08 72 02 00 AF 1D 00 01 08 73 02 00 B0 1D 00 01 08 74 02 00 B1 1D 00 01 08 75 02'\r\n '00 B2 1D 00 01 08 78 02 00 B3 1D 00 01 08 82 02 00 B4 1D 00 01 08 83 02 00 B5 1D 00 01 08 AB 01'\r\n '00 B6 1D 00 01 08 89 02 00 B7 1D 00 01 08 8A 02 00 B8 1D 00 01 08 1C 1D 00 B9 1D 00 01 08 8B 02'\r\n '00 BA 1D 00 01 08 8C 02 00 BB 1D 00 01 08 7A 00 00 BC 1D 00 01 08 90 02 00 BD 1D 00 01 08 91 02'\r\n '00 BE 1D 00 01 08 92 02 00 BF 1D 00 01 08 B8 03 00 00 1E 00 02 00 41 00 00 25 03 00 01 1E 00 02'\r\n '00 61 00 00 25 03 00 02 1E 00 02 00 42 00 00 07 03 00 03 1E 00 02 00 62 00 00 07 03 00 04 1E 00'\r\n '02 00 42 00 00 23 03 00 05 1E 00 02 00 62 00 00 23 03 00 06 1E 00 02 00 42 00 00 31 03 00 07 1E'\r\n '00 02 00 62 00 00 31 03 00 08 1E 00 03 00 43 00 00 27 03 00 01 03 00 09 1E 00 03 00 63 00 00 27'\r\n '03 00 01 03 00 0A 1E 00 02 00 44 00 00 07 03 00 0B 1E 00 02 00 64 00 00 07 03 00 0C 1E 00 02 00'\r\n '44 00 00 23 03 00 0D 1E 00 02 00 64 00 00 23 03 00 0E 1E 00 02 00 44 00 00 31 03 00 0F 1E 00 02'\r\n '00 64 00 00 31 03 00 10 1E 00 02 00 44 00 00 27 03 00 11 1E 00 02 00 64 00 00 27 03 00 12 1E 00'\r\n '02 00 44 00 00 2D 03 00 13 1E 00 02 00 64 00 00 2D 03 00 14 1E 00 03 00 45 00 00 04 03 00 00 03'\r\n '00 15 1E 00 03 00 65 00 00 04 03 00 00 03 00 16 1E 00 03 00 45 00 00 04 03 00 01 03 00 17 1E 00'\r\n '03 00 65 00 00 04 03 00 01 03 00 18 1E 00 02 00 45 00 00 2D 03 00 19 1E 00 02 00 65 00 00 2D 03'\r\n '00 1A 1E 00 02 00 45 00 00 30 03 00 1B 1E 00 02 00 65 00 00 30 03 00 1C 1E 00 03 00 45 00 00 27'\r\n '03 00 06 03 00 1D 1E 00 03 00 65 00 00 27 03 00 06 03 00 1E 1E 00 02 00 46 00 00 07 03 00 1F 1E'\r\n '00 02 00 66 00 00 07 03 00 20 1E 00 02 00 47 00 00 04 03 00 21 1E 00 02 00 67 00 00 04 03 00 22'\r\n '1E 00 02 00 48 00 00 07 03 00 23 1E 00 02 00 68 00 00 07 03 00 24 1E 00 02 00 48 00 00 23 03 00'\r\n '25 1E 00 02 00 68 00 00 23 03 00 26 1E 00 02 00 48 00 00 08 03 00 27 1E 00 02 00 68 00 00 08 03'\r\n '00 28 1E 00 02 00 48 00 00 27 03 00 29 1E 00 02 00 68 00 00 27 03 00 2A 1E 00 02 00 48 00 00 2E'\r\n '03 00 2B 1E 00 02 00 68 00 00 2E 03 00 2C 1E 00 02 00 49 00 00 30 03 00 2D 1E 00 02 00 69 00 00'\r\n '30 03 00 2E 1E 00 03 00 49 00 00 08 03 00 01 03 00 2F 1E 00 03 00 69 00 00 08 03 00 01 03 00 30'\r\n '1E 00 02 00 4B 00 00 01 03 00 31 1E 00 02 00 6B 00 00 01 03 00 32 1E 00 02 00 4B 00 00 23 03 00'\r\n '33 1E 00 02 00 6B 00 00 23 03 00 34 1E 00 02 00 4B 00 00 31 03 00 35 1E 00 02 00 6B 00 00 31 03'\r\n '00 36 1E 00 02 00 4C 00 00 23 03 00 37 1E 00 02 00 6C 00 00 23 03 00 38 1E 00 03 00 4C 00 00 23'\r\n '03 00 04 03 00 39 1E 00 03 00 6C 00 00 23 03 00 04 03 00 3A 1E 00 02 00 4C 00 00 31 03 00 3B 1E'\r\n '00 02 00 6C 00 00 31 03 00 3C 1E 00 02 00 4C 00 00 2D 03 00 3D 1E 00 02 00 6C 00 00 2D 03 00 3E'\r\n '1E 00 02 00 4D 00 00 01 03 00 3F 1E 00 02 00 6D 00 00 01 03 00 40 1E 00 02 00 4D 00 00 07 03 00'\r\n '41 1E 00 02 00 6D 00 00 07 03 00 42 1E 00 02 00 4D 00 00 23 03 00 43 1E 00 02 00 6D 00 00 23 03'\r\n '00 44 1E 00 02 00 4E 00 00 07 03 00 45 1E 00 02 00 6E 00 00 07 03 00 46 1E 00 02 00 4E 00 00 23'\r\n '03 00 47 1E 00 02 00 6E 00 00 23 03 00 48 1E 00 02 00 4E 00 00 31 03 00 49 1E 00 02 00 6E 00 00'\r\n '31 03 00 4A 1E 00 02 00 4E 00 00 2D 03 00 4B 1E 00 02 00 6E 00 00 2D 03 00 4C 1E 00 03 00 4F 00'\r\n '00 03 03 00 01 03 00 4D 1E 00 03 00 6F 00 00 03 03 00 01 03 00 4E 1E 00 03 00 4F 00 00 03 03 00'\r\n '08 03 00 4F 1E 00 03 00 6F 00 00 03 03 00 08 03 00 50 1E 00 03 00 4F 00 00 04 03 00 00 03 00 51'\r\n '1E 00 03 00 6F 00 00 04 03 00 00 03 00 52 1E 00 03 00 4F 00 00 04 03 00 01 03 00 53 1E 00 03 00'\r\n '6F 00 00 04 03 00 01 03 00 54 1E 00 02 00 50 00 00 01 03 00 55 1E 00 02 00 70 00 00 01 03 00 56'\r\n '1E 00 02 00 50 00 00 07 03 00 57 1E 00 02 00 70 00 00 07 03 00 58 1E 00 02 00 52 00 00 07 03 00'\r\n '59 1E 00 02 00 72 00 00 07 03 00 5A 1E 00 02 00 52 00 00 23 03 00 5B 1E 00 02 00 72 00 00 23 03'\r\n '00 5C 1E 00 03 00 52 00 00 23 03 00 04 03 00 5D 1E 00 03 00 72 00 00 23 03 00 04 03 00 5E 1E 00'\r\n '02 00 52 00 00 31 03 00 5F 1E 00 02 00 72 00 00 31 03 00 60 1E 00 02 00 53 00 00 07 03 00 61 1E'\r\n '00 02 00 73 00 00 07 03 00 62 1E 00 02 00 53 00 00 23 03 00 63 1E 00 02 00 73 00 00 23 03 00 64'\r\n '1E 00 03 00 53 00 00 01 03 00 07 03 00 65 1E 00 03 00 73 00 00 01 03 00 07 03 00 66 1E 00 03 00'\r\n '53 00 00 0C 03 00 07 03 00 67 1E 00 03 00 73 00 00 0C 03 00 07 03 00 68 1E 00 03 00 53 00 00 23'\r\n '03 00 07 03 00 69 1E 00 03 00 73 00 00 23 03 00 07 03 00 6A 1E 00 02 00 54 00 00 07 03 00 6B 1E'\r\n '00 02 00 74 00 00 07 03 00 6C 1E 00 02 00 54 00 00 23 03 00 6D 1E 00 02 00 74 00 00 23 03 00 6E'\r\n '1E 00 02 00 54 00 00 31 03 00 6F 1E 00 02 00 74 00 00 31 03 00 70 1E 00 02 00 54 00 00 2D 03 00'\r\n '71 1E 00 02 00 74 00 00 2D 03 00 72 1E 00 02 00 55 00 00 24 03 00 73 1E 00 02 00 75 00 00 24 03'\r\n '00 74 1E 00 02 00 55 00 00 30 03 00 75 1E 00 02 00 75 00 00 30 03 00 76 1E 00 02 00 55 00 00 2D'\r\n '03 00 77 1E 00 02 00 75 00 00 2D 03 00 78 1E 00 03 00 55 00 00 03 03 00 01 03 00 79 1E 00 03 00'\r\n '75 00 00 03 03 00 01 03 00 7A 1E 00 03 00 55 00 00 04 03 00 08 03 00 7B 1E 00 03 00 75 00 00 04'\r\n '03 00 08 03 00 7C 1E 00 02 00 56 00 00 03 03 00 7D 1E 00 02 00 76 00 00 03 03 00 7E 1E 00 02 00'\r\n '56 00 00 23 03 00 7F 1E 00 02 00 76 00 00 23 03 00 80 1E 00 02 00 57 00 00 00 03 00 81 1E 00 02'\r\n '00 77 00 00 00 03 00 82 1E 00 02 00 57 00 00 01 03 00 83 1E 00 02 00 77 00 00 01 03 00 84 1E 00'\r\n '02 00 57 00 00 08 03 00 85 1E 00 02 00 77 00 00 08 03 00 86 1E 00 02 00 57 00 00 07 03 00 87 1E'\r\n '00 02 00 77 00 00 07 03 00 88 1E 00 02 00 57 00 00 23 03 00 89 1E 00 02 00 77 00 00 23 03 00 8A'\r\n '1E 00 02 00 58 00 00 07 03 00 8B 1E 00 02 00 78 00 00 07 03 00 8C 1E 00 02 00 58 00 00 08 03 00'\r\n '8D 1E 00 02 00 78 00 00 08 03 00 8E 1E 00 02 00 59 00 00 07 03 00 8F 1E 00 02 00 79 00 00 07 03'\r\n '00 90 1E 00 02 00 5A 00 00 02 03 00 91 1E 00 02 00 7A 00 00 02 03 00 92 1E 00 02 00 5A 00 00 23'\r\n '03 00 93 1E 00 02 00 7A 00 00 23 03 00 94 1E 00 02 00 5A 00 00 31 03 00 95 1E 00 02 00 7A 00 00'\r\n '31 03 00 96 1E 00 02 00 68 00 00 31 03 00 97 1E 00 02 00 74 00 00 08 03 00 98 1E 00 02 00 77 00'\r\n '00 0A 03 00 99 1E 00 02 00 79 00 00 0A 03 00 9A 1E 00 02 10 61 00 00 BE 02 00 9B 1E 00 02 00 73'\r\n '00 00 07 03 00 A0 1E 00 02 00 41 00 00 23 03 00 A1 1E 00 02 00 61 00 00 23 03 00 A2 1E 00 02 00'\r\n '41 00 00 09 03 00 A3 1E 00 02 00 61 00 00 09 03 00 A4 1E 00 03 00 41 00 00 02 03 00 01 03 00 A5'\r\n '1E 00 03 00 61 00 00 02 03 00 01 03 00 A6 1E 00 03 00 41 00 00 02 03 00 00 03 00 A7 1E 00 03 00'\r\n '61 00 00 02 03 00 00 03 00 A8 1E 00 03 00 41 00 00 02 03 00 09 03 00 A9 1E 00 03 00 61 00 00 02'\r\n '03 00 09 03 00 AA 1E 00 03 00 41 00 00 02 03 00 03 03 00 AB 1E 00 03 00 61 00 00 02 03 00 03 03'\r\n '00 AC 1E 00 03 00 41 00 00 23 03 00 02 03 00 AD 1E 00 03 00 61 00 00 23 03 00 02 03 00 AE 1E 00'\r\n '03 00 41 00 00 06 03 00 01 03 00 AF 1E 00 03 00 61 00 00 06 03 00 01 03 00 B0 1E 00 03 00 41 00'\r\n '00 06 03 00 00 03 00 B1 1E 00 03 00 61 00 00 06 03 00 00 03 00 B2 1E 00 03 00 41 00 00 06 03 00'\r\n '09 03 00 B3 1E 00 03 00 61 00 00 06 03 00 09 03 00 B4 1E 00 03 00 41 00 00 06 03 00 03 03 00 B5'\r\n '1E 00 03 00 61 00 00 06 03 00 03 03 00 B6 1E 00 03 00 41 00 00 23 03 00 06 03 00 B7 1E 00 03 00'\r\n '61 00 00 23 03 00 06 03 00 B8 1E 00 02 00 45 00 00 23 03 00 B9 1E 00 02 00 65 00 00 23 03 00 BA'\r\n '1E 00 02 00 45 00 00 09 03 00 BB 1E 00 02 00 65 00 00 09 03 00 BC 1E 00 02 00 45 00 00 03 03 00'\r\n 'BD 1E 00 02 00 65 00 00 03 03 00 BE 1E 00 03 00 45 00 00 02 03 00 01 03 00 BF 1E 00 03 00 65 00'\r\n '00 02 03 00 01 03 00 C0 1E 00 03 00 45 00 00 02 03 00 00 03 00 C1 1E 00 03 00 65 00 00 02 03 00'\r\n '00 03 00 C2 1E 00 03 00 45 00 00 02 03 00 09 03 00 C3 1E 00 03 00 65 00 00 02 03 00 09 03 00 C4'\r\n '1E 00 03 00 45 00 00 02 03 00 03 03 00 C5 1E 00 03 00 65 00 00 02 03 00 03 03 00 C6 1E 00 03 00'\r\n '45 00 00 23 03 00 02 03 00 C7 1E 00 03 00 65 00 00 23 03 00 02 03 00 C8 1E 00 02 00 49 00 00 09'\r\n '03 00 C9 1E 00 02 00 69 00 00 09 03 00 CA 1E 00 02 00 49 00 00 23 03 00 CB 1E 00 02 00 69 00 00'\r\n '23 03 00 CC 1E 00 02 00 4F 00 00 23 03 00 CD 1E 00 02 00 6F 00 00 23 03 00 CE 1E 00 02 00 4F 00'\r\n '00 09 03 00 CF 1E 00 02 00 6F 00 00 09 03 00 D0 1E 00 03 00 4F 00 00 02 03 00 01 03 00 D1 1E 00'\r\n '03 00 6F 00 00 02 03 00 01 03 00 D2 1E 00 03 00 4F 00 00 02 03 00 00 03 00 D3 1E 00 03 00 6F 00'\r\n '00 02 03 00 00 03 00 D4 1E 00 03 00 4F 00 00 02 03 00 09 03 00 D5 1E 00 03 00 6F 00 00 02 03 00'\r\n '09 03 00 D6 1E 00 03 00 4F 00 00 02 03 00 03 03 00 D7 1E 00 03 00 6F 00 00 02 03 00 03 03 00 D8'\r\n '1E 00 03 00 4F 00 00 23 03 00 02 03 00 D9 1E 00 03 00 6F 00 00 23 03 00 02 03 00 DA 1E 00 03 00'\r\n '4F 00 00 1B 03 00 01 03 00 DB 1E 00 03 00 6F 00 00 1B 03 00 01 03 00 DC 1E 00 03 00 4F 00 00 1B'\r\n '03 00 00 03 00 DD 1E 00 03 00 6F 00 00 1B 03 00 00 03 00 DE 1E 00 03 00 4F 00 00 1B 03 00 09 03'\r\n '00 DF 1E 00 03 00 6F 00 00 1B 03 00 09 03 00 E0 1E 00 03 00 4F 00 00 1B 03 00 03 03 00 E1 1E 00'\r\n '03 00 6F 00 00 1B 03 00 03 03 00 E2 1E 00 03 00 4F 00 00 1B 03 00 23 03 00 E3 1E 00 03 00 6F 00'\r\n '00 1B 03 00 23 03 00 E4 1E 00 02 00 55 00 00 23 03 00 E5 1E 00 02 00 75 00 00 23 03 00 E6 1E 00'\r\n '02 00 55 00 00 09 03 00 E7 1E 00 02 00 75 00 00 09 03 00 E8 1E 00 03 00 55 00 00 1B 03 00 01 03'\r\n '00 E9 1E 00 03 00 75 00 00 1B 03 00 01 03 00 EA 1E 00 03 00 55 00 00 1B 03 00 00 03 00 EB 1E 00'\r\n '03 00 75 00 00 1B 03 00 00 03 00 EC 1E 00 03 00 55 00 00 1B 03 00 09 03 00 ED 1E 00 03 00 75 00'\r\n '00 1B 03 00 09 03 00 EE 1E 00 03 00 55 00 00 1B 03 00 03 03 00 EF 1E 00 03 00 75 00 00 1B 03 00'\r\n '03 03 00 F0 1E 00 03 00 55 00 00 1B 03 00 23 03 00 F1 1E 00 03 00 75 00 00 1B 03 00 23 03 00 F2'\r\n '1E 00 02 00 59 00 00 00 03 00 F3 1E 00 02 00 79 00 00 00 03 00 F4 1E 00 02 00 59 00 00 23 03 00'\r\n 'F5 1E 00 02 00 79 00 00 23 03 00 F6 1E 00 02 00 59 00 00 09 03 00 F7 1E 00 02 00 79 00 00 09 03'\r\n '00 F8 1E 00 02 00 59 00 00 03 03 00 F9 1E 00 02 00 79 00 00 03 03 00 00 1F 00 02 00 B1 03 00 13'\r\n '03 00 01 1F 00 02 00 B1 03 00 14 03 00 02 1F 00 03 00 B1 03 00 13 03 00 00 03 00 03 1F 00 03 00'\r\n 'B1 03 00 14 03 00 00 03 00 04 1F 00 03 00 B1 03 00 13 03 00 01 03 00 05 1F 00 03 00 B1 03 00 14'\r\n '03 00 01 03 00 06 1F 00 03 00 B1 03 00 13 03 00 42 03 00 07 1F 00 03 00 B1 03 00 14 03 00 42 03'\r\n '00 08 1F 00 02 00 91 03 00 13 03 00 09 1F 00 02 00 91 03 00 14 03 00 0A 1F 00 03 00 91 03 00 13'\r\n '03 00 00 03 00 0B 1F 00 03 00 91 03 00 14 03 00 00 03 00 0C 1F 00 03 00 91 03 00 13 03 00 01 03'\r\n '00 0D 1F 00 03 00 91 03 00 14 03 00 01 03 00 0E 1F 00 03 00 91 03 00 13 03 00 42 03 00 0F 1F 00'\r\n '03 00 91 03 00 14 03 00 42 03 00 10 1F 00 02 00 B5 03 00 13 03 00 11 1F 00 02 00 B5 03 00 14 03'\r\n '00 12 1F 00 03 00 B5 03 00 13 03 00 00 03 00 13 1F 00 03 00 B5 03 00 14 03 00 00 03 00 14 1F 00'\r\n '03 00 B5 03 00 13 03 00 01 03 00 15 1F 00 03 00 B5 03 00 14 03 00 01 03 00 18 1F 00 02 00 95 03'\r\n '00 13 03 00 19 1F 00 02 00 95 03 00 14 03 00 1A 1F 00 03 00 95 03 00 13 03 00 00 03 00 1B 1F 00'\r\n '03 00 95 03 00 14 03 00 00 03 00 1C 1F 00 03 00 95 03 00 13 03 00 01 03 00 1D 1F 00 03 00 95 03'\r\n '00 14 03 00 01 03 00 20 1F 00 02 00 B7 03 00 13 03 00 21 1F 00 02 00 B7 03 00 14 03 00 22 1F 00'\r\n '03 00 B7 03 00 13 03 00 00 03 00 23 1F 00 03 00 B7 03 00 14 03 00 00 03 00 24 1F 00 03 00 B7 03'\r\n '00 13 03 00 01 03 00 25 1F 00 03 00 B7 03 00 14 03 00 01 03 00 26 1F 00 03 00 B7 03 00 13 03 00'\r\n '42 03 00 27 1F 00 03 00 B7 03 00 14 03 00 42 03 00 28 1F 00 02 00 97 03 00 13 03 00 29 1F 00 02'\r\n '00 97 03 00 14 03 00 2A 1F 00 03 00 97 03 00 13 03 00 00 03 00 2B 1F 00 03 00 97 03 00 14 03 00'\r\n '00 03 00 2C 1F 00 03 00 97 03 00 13 03 00 01 03 00 2D 1F 00 03 00 97 03 00 14 03 00 01 03 00 2E'\r\n '1F 00 03 00 97 03 00 13 03 00 42 03 00 2F 1F 00 03 00 97 03 00 14 03 00 42 03 00 30 1F 00 02 00'\r\n 'B9 03 00 13 03 00 31 1F 00 02 00 B9 03 00 14 03 00 32 1F 00 03 00 B9 03 00 13 03 00 00 03 00 33'\r\n '1F 00 03 00 B9 03 00 14 03 00 00 03 00 34 1F 00 03 00 B9 03 00 13 03 00 01 03 00 35 1F 00 03 00'\r\n 'B9 03 00 14 03 00 01 03 00 36 1F 00 03 00 B9 03 00 13 03 00 42 03 00 37 1F 00 03 00 B9 03 00 14'\r\n '03 00 42 03 00 38 1F 00 02 00 99 03 00 13 03 00 39 1F 00 02 00 99 03 00 14 03 00 3A 1F 00 03 00'\r\n '99 03 00 13 03 00 00 03 00 3B 1F 00 03 00 99 03 00 14 03 00 00 03 00 3C 1F 00 03 00 99 03 00 13'\r\n '03 00 01 03 00 3D 1F 00 03 00 99 03 00 14 03 00 01 03 00 3E 1F 00 03 00 99 03 00 13 03 00 42 03'\r\n '00 3F 1F 00 03 00 99 03 00 14 03 00 42 03 00 40 1F 00 02 00 BF 03 00 13 03 00 41 1F 00 02 00 BF'\r\n '03 00 14 03 00 42 1F 00 03 00 BF 03 00 13 03 00 00 03 00 43 1F 00 03 00 BF 03 00 14 03 00 00 03'\r\n '00 44 1F 00 03 00 BF 03 00 13 03 00 01 03 00 45 1F 00 03 00 BF 03 00 14 03 00 01 03 00 48 1F 00'\r\n '02 00 9F 03 00 13 03 00 49 1F 00 02 00 9F 03 00 14 03 00 4A 1F 00 03 00 9F 03 00 13 03 00 00 03'\r\n '00 4B 1F 00 03 00 9F 03 00 14 03 00 00 03 00 4C 1F 00 03 00 9F 03 00 13 03 00 01 03 00 4D 1F 00'\r\n '03 00 9F 03 00 14 03 00 01 03 00 50 1F 00 02 00 C5 03 00 13 03 00 51 1F 00 02 00 C5 03 00 14 03'\r\n '00 52 1F 00 03 00 C5 03 00 13 03 00 00 03 00 53 1F 00 03 00 C5 03 00 14 03 00 00 03 00 54 1F 00'\r\n '03 00 C5 03 00 13 03 00 01 03 00 55 1F 00 03 00 C5 03 00 14 03 00 01 03 00 56 1F 00 03 00 C5 03'\r\n '00 13 03 00 42 03 00 57 1F 00 03 00 C5 03 00 14 03 00 42 03 00 59 1F 00 02 00 A5 03 00 14 03 00'\r\n '5B 1F 00 03 00 A5 03 00 14 03 00 00 03 00 5D 1F 00 03 00 A5 03 00 14 03 00 01 03 00 5F 1F 00 03'\r\n '00 A5 03 00 14 03 00 42 03 00 60 1F 00 02 00 C9 03 00 13 03 00 61 1F 00 02 00 C9 03 00 14 03 00'\r\n '62 1F 00 03 00 C9 03 00 13 03 00 00 03 00 63 1F 00 03 00 C9 03 00 14 03 00 00 03 00 64 1F 00 03'\r\n '00 C9 03 00 13 03 00 01 03 00 65 1F 00 03 00 C9 03 00 14 03 00 01 03 00 66 1F 00 03 00 C9 03 00'\r\n '13 03 00 42 03 00 67 1F 00 03 00 C9 03 00 14 03 00 42 03 00 68 1F 00 02 00 A9 03 00 13 03 00 69'\r\n '1F 00 02 00 A9 03 00 14 03 00 6A 1F 00 03 00 A9 03 00 13 03 00 00 03 00 6B 1F 00 03 00 A9 03 00'\r\n '14 03 00 00 03 00 6C 1F 00 03 00 A9 03 00 13 03 00 01 03 00 6D 1F 00 03 00 A9 03 00 14 03 00 01'\r\n '03 00 6E 1F 00 03 00 A9 03 00 13 03 00 42 03 00 6F 1F 00 03 00 A9 03 00 14 03 00 42 03 00 70 1F'\r\n '00 02 00 B1 03 00 00 03 00 71 1F 00 02 00 B1 03 00 01 03 00 72 1F 00 02 00 B5 03 00 00 03 00 73'\r\n '1F 00 02 00 B5 03 00 01 03 00 74 1F 00 02 00 B7 03 00 00 03 00 75 1F 00 02 00 B7 03 00 01 03 00'\r\n '76 1F 00 02 00 B9 03 00 00 03 00 77 1F 00 02 00 B9 03 00 01 03 00 78 1F 00 02 00 BF 03 00 00 03'\r\n '00 79 1F 00 02 00 BF 03 00 01 03 00 7A 1F 00 02 00 C5 03 00 00 03 00 7B 1F 00 02 00 C5 03 00 01'\r\n '03 00 7C 1F 00 02 00 C9 03 00 00 03 00 7D 1F 00 02 00 C9 03 00 01 03 00 80 1F 00 03 00 B1 03 00'\r\n '13 03 00 45 03 00 81 1F 00 03 00 B1 03 00 14 03 00 45 03 00 82 1F 00 04 00 B1 03 00 13 03 00 00'\r\n '03 00 45 03 00 83 1F 00 04 00 B1 03 00 14 03 00 00 03 00 45 03 00 84 1F 00 04 00 B1 03 00 13 03'\r\n '00 01 03 00 45 03 00 85 1F 00 04 00 B1 03 00 14 03 00 01 03 00 45 03 00 86 1F 00 04 00 B1 03 00'\r\n '13 03 00 42 03 00 45 03 00 87 1F 00 04 00 B1 03 00 14 03 00 42 03 00 45 03 00 88 1F 00 03 00 91'\r\n '03 00 13 03 00 45 03 00 89 1F 00 03 00 91 03 00 14 03 00 45 03 00 8A 1F 00 04 00 91 03 00 13 03'\r\n '00 00 03 00 45 03 00 8B 1F 00 04 00 91 03 00 14 03 00 00 03 00 45 03 00 8C 1F 00 04 00 91 03 00'\r\n '13 03 00 01 03 00 45 03 00 8D 1F 00 04 00 91 03 00 14 03 00 01 03 00 45 03 00 8E 1F 00 04 00 91'\r\n '03 00 13 03 00 42 03 00 45 03 00 8F 1F 00 04 00 91 03 00 14 03 00 42 03 00 45 03 00 90 1F 00 03'\r\n '00 B7 03 00 13 03 00 45 03 00 91 1F 00 03 00 B7 03 00 14 03 00 45 03 00 92 1F 00 04 00 B7 03 00'\r\n '13 03 00 00 03 00 45 03 00 93 1F 00 04 00 B7 03 00 14 03 00 00 03 00 45 03 00 94 1F 00 04 00 B7'\r\n '03 00 13 03 00 01 03 00 45 03 00 95 1F 00 04 00 B7 03 00 14 03 00 01 03 00 45 03 00 96 1F 00 04'\r\n '00 B7 03 00 13 03 00 42 03 00 45 03 00 97 1F 00 04 00 B7 03 00 14 03 00 42 03 00 45 03 00 98 1F'\r\n '00 03 00 97 03 00 13 03 00 45 03 00 99 1F 00 03 00 97 03 00 14 03 00 45 03 00 9A 1F 00 04 00 97'\r\n '03 00 13 03 00 00 03 00 45 03 00 9B 1F 00 04 00 97 03 00 14 03 00 00 03 00 45 03 00 9C 1F 00 04'\r\n '00 97 03 00 13 03 00 01 03 00 45 03 00 9D 1F 00 04 00 97 03 00 14 03 00 01 03 00 45 03 00 9E 1F'\r\n '00 04 00 97 03 00 13 03 00 42 03 00 45 03 00 9F 1F 00 04 00 97 03 00 14 03 00 42 03 00 45 03 00'\r\n 'A0 1F 00 03 00 C9 03 00 13 03 00 45 03 00 A1 1F 00 03 00 C9 03 00 14 03 00 45 03 00 A2 1F 00 04'\r\n '00 C9 03 00 13 03 00 00 03 00 45 03 00 A3 1F 00 04 00 C9 03 00 14 03 00 00 03 00 45 03 00 A4 1F'\r\n '00 04 00 C9 03 00 13 03 00 01 03 00 45 03 00 A5 1F 00 04 00 C9 03 00 14 03 00 01 03 00 45 03 00'\r\n 'A6 1F 00 04 00 C9 03 00 13 03 00 42 03 00 45 03 00 A7 1F 00 04 00 C9 03 00 14 03 00 42 03 00 45'\r\n '03 00 A8 1F 00 03 00 A9 03 00 13 03 00 45 03 00 A9 1F 00 03 00 A9 03 00 14 03 00 45 03 00 AA 1F'\r\n '00 04 00 A9 03 00 13 03 00 00 03 00 45 03 00 AB 1F 00 04 00 A9 03 00 14 03 00 00 03 00 45 03 00'\r\n 'AC 1F 00 04 00 A9 03 00 13 03 00 01 03 00 45 03 00 AD 1F 00 04 00 A9 03 00 14 03 00 01 03 00 45'\r\n '03 00 AE 1F 00 04 00 A9 03 00 13 03 00 42 03 00 45 03 00 AF 1F 00 04 00 A9 03 00 14 03 00 42 03'\r\n '00 45 03 00 B0 1F 00 02 00 B1 03 00 06 03 00 B1 1F 00 02 00 B1 03 00 04 03 00 B2 1F 00 03 00 B1'\r\n '03 00 00 03 00 45 03 00 B3 1F 00 02 00 B1 03 00 45 03 00 B4 1F 00 03 00 B1 03 00 01 03 00 45 03'\r\n '00 B6 1F 00 02 00 B1 03 00 42 03 00 B7 1F 00 03 00 B1 03 00 42 03 00 45 03 00 B8 1F 00 02 00 91'\r\n '03 00 06 03 00 B9 1F 00 02 00 91 03 00 04 03 00 BA 1F 00 02 00 91 03 00 00 03 00 BB 1F 00 02 00'\r\n '91 03 00 01 03 00 BC 1F 00 02 00 91 03 00 45 03 00 BD 1F 00 02 10 20 00 00 13 03 00 BE 1F 00 01'\r\n '00 B9 03 00 BF 1F 00 02 10 20 00 00 13 03 00 C0 1F 00 02 10 20 00 00 42 03 00 C1 1F 00 03 00 20'\r\n '00 00 08 03 00 42 03 00 C2 1F 00 03 00 B7 03 00 00 03 00 45 03 00 C3 1F 00 02 00 B7 03 00 45 03'\r\n '00 C4 1F 00 03 00 B7 03 00 01 03 00 45 03 00 C6 1F 00 02 00 B7 03 00 42 03 00 C7 1F 00 03 00 B7'\r\n '03 00 42 03 00 45 03 00 C8 1F 00 02 00 95 03 00 00 03 00 C9 1F 00 02 00 95 03 00 01 03 00 CA 1F'\r\n '00 02 00 97 03 00 00 03 00 CB 1F 00 02 00 97 03 00 01 03 00 CC 1F 00 02 00 97 03 00 45 03 00 CD'\r\n '1F 00 03 00 20 00 00 13 03 00 00 03 00 CE 1F 00 03 00 20 00 00 13 03 00 01 03 00 CF 1F 00 03 00'\r\n '20 00 00 13 03 00 42 03 00 D0 1F 00 02 00 B9 03 00 06 03 00 D1 1F 00 02 00 B9 03 00 04 03 00 D2'\r\n '1F 00 03 00 B9 03 00 08 03 00 00 03 00 D3 1F 00 03 00 B9 03 00 08 03 00 01 03 00 D6 1F 00 02 00'\r\n 'B9 03 00 42 03 00 D7 1F 00 03 00 B9 03 00 08 03 00 42 03 00 D8 1F 00 02 00 99 03 00 06 03 00 D9'\r\n '1F 00 02 00 99 03 00 04 03 00 DA 1F 00 02 00 99 03 00 00 03 00 DB 1F 00 02 00 99 03 00 01 03 00'\r\n 'DD 1F 00 03 00 20 00 00 14 03 00 00 03 00 DE 1F 00 03 00 20 00 00 14 03 00 01 03 00 DF 1F 00 03'\r\n '00 20 00 00 14 03 00 42 03 00 E0 1F 00 02 00 C5 03 00 06 03 00 E1 1F 00 02 00 C5 03 00 04 03 00'\r\n 'E2 1F 00 03 00 C5 03 00 08 03 00 00 03 00 E3 1F 00 03 00 C5 03 00 08 03 00 01 03 00 E4 1F 00 02'\r\n '00 C1 03 00 13 03 00 E5 1F 00 02 00 C1 03 00 14 03 00 E6 1F 00 02 00 C5 03 00 42 03 00 E7 1F 00'\r\n '03 00 C5 03 00 08 03 00 42 03 00 E8 1F 00 02 00 A5 03 00 06 03 00 E9 1F 00 02 00 A5 03 00 04 03'\r\n '00 EA 1F 00 02 00 A5 03 00 00 03 00 EB 1F 00 02 00 A5 03 00 01 03 00 EC 1F 00 02 00 A1 03 00 14'\r\n '03 00 ED 1F 00 03 00 20 00 00 08 03 00 00 03 00 EE 1F 00 03 00 20 00 00 08 03 00 01 03 00 EF 1F'\r\n '00 01 00 60 00 00 F2 1F 00 03 00 C9 03 00 00 03 00 45 03 00 F3 1F 00 02 00 C9 03 00 45 03 00 F4'\r\n '1F 00 03 00 C9 03 00 01 03 00 45 03 00 F6 1F 00 02 00 C9 03 00 42 03 00 F7 1F 00 03 00 C9 03 00'\r\n '42 03 00 45 03 00 F8 1F 00 02 00 9F 03 00 00 03 00 F9 1F 00 02 00 9F 03 00 01 03 00 FA 1F 00 02'\r\n '00 A9 03 00 00 03 00 FB 1F 00 02 00 A9 03 00 01 03 00 FC 1F 00 02 00 A9 03 00 45 03 00 FD 1F 00'\r\n '02 00 20 00 00 01 03 00 FE 1F 00 02 10 20 00 00 14 03 00 00 20 00 01 00 20 00 00 01 20 00 01 00'\r\n '20 00 00 02 20 00 01 10 20 00 00 03 20 00 01 10 20 00 00 04 20 00 01 10 20 00 00 05 20 00 01 10'\r\n '20 00 00 06 20 00 01 10 20 00 00 07 20 00 01 02 20 00 00 08 20 00 01 10 20 00 00 09 20 00 01 10'\r\n '20 00 00 0A 20 00 01 10 20 00 00 11 20 00 01 02 10 20 00 17 20 00 02 10 20 00 00 33 03 00 24 20'\r\n '00 01 10 2E 00 00 25 20 00 02 10 2E 00 00 2E 00 00 26 20 00 03 10 2E 00 00 2E 00 00 2E 00 00 2F'\r\n '20 00 01 02 20 00 00 33 20 00 02 10 32 20 00 32 20 00 34 20 00 03 10 32 20 00 32 20 00 32 20 00'\r\n '36 20 00 02 10 35 20 00 35 20 00 37 20 00 03 10 35 20 00 35 20 00 35 20 00 3C 20 00 02 10 21 00'\r\n '00 21 00 00 3E 20 00 02 10 20 00 00 05 03 00 47 20 00 02 10 3F 00 00 3F 00 00 48 20 00 02 10 3F'\r\n '00 00 21 00 00 49 20 00 02 10 21 00 00 3F 00 00 57 20 00 04 10 32 20 00 32 20 00 32 20 00 32 20'\r\n '00 5F 20 00 01 10 20 00 00 70 20 00 01 08 30 00 00 71 20 00 01 08 69 00 00 74 20 00 01 08 34 00'\r\n '00 75 20 00 01 08 35 00 00 76 20 00 01 08 36 00 00 77 20 00 01 08 37 00 00 78 20 00 01 08 38 00'\r\n '00 79 20 00 01 08 39 00 00 7A 20 00 01 08 2B 00 00 7B 20 00 01 08 12 22 00 7C 20 00 01 08 3D 00'\r\n '00 7D 20 00 01 08 28 00 00 7E 20 00 01 08 29 00 00 7F 20 00 01 08 6E 00 00 80 20 00 01 09 30 00'\r\n '00 81 20 00 01 09 31 00 00 82 20 00 01 09 32 00 00 83 20 00 01 09 33 00 00 84 20 00 01 09 34 00'\r\n '00 85 20 00 01 09 35 00 00 86 20 00 01 09 36 00 00 87 20 00 01 09 37 00 00 88 20 00 01 09 38 00'\r\n '00 89 20 00 01 09 39 00 00 8A 20 00 01 09 2B 00 00 8B 20 00 01 09 12 22 00 8C 20 00 01 09 3D 00'\r\n '00 8D 20 00 01 09 28 00 00 8E 20 00 01 09 29 00 00 90 20 00 01 09 61 00 00 91 20 00 01 09 65 00'\r\n '00 92 20 00 01 09 6F 00 00 93 20 00 01 09 78 00 00 94 20 00 01 09 59 02 00 95 20 00 01 09 68 00'\r\n '00 96 20 00 01 09 6B 00 00 97 20 00 01 09 6C 00 00 98 20 00 01 09 6D 00 00 99 20 00 01 09 6E 00'\r\n '00 9A 20 00 01 09 70 00 00 9B 20 00 01 09 73 00 00 9C 20 00 01 09 74 00 00 A8 20 00 02 10 52 00'\r\n '00 73 00 00 00 21 00 03 10 61 00 00 2F 00 00 63 00 00 01 21 00 03 10 61 00 00 2F 00 00 73 00 00'\r\n '02 21 00 01 01 43 00 00 03 21 00 02 10 B0 00 00 43 00 00 05 21 00 03 10 63 00 00 2F 00 00 6F 00'\r\n '00 06 21 00 03 10 63 00 00 2F 00 00 75 00 00 07 21 00 01 10 90 01 00 09 21 00 02 10 B0 00 00 46'\r\n '00 00 0A 21 00 01 01 67 00 00 0B 21 00 01 01 48 00 00 0C 21 00 01 01 48 00 00 0D 21 00 01 01 48'\r\n '00 00 0E 21 00 01 01 68 00 00 0F 21 00 01 01 27 01 00 10 21 00 01 01 49 00 00 11 21 00 01 01 49'\r\n '00 00 12 21 00 01 01 4C 00 00 13 21 00 01 01 6C 00 00 15 21 00 01 01 4E 00 00 16 21 00 02 10 4E'\r\n '00 00 6F 00 00 19 21 00 01 01 50 00 00 1A 21 00 01 01 51 00 00 1B 21 00 01 01 52 00 00 1C 21 00'\r\n '01 01 52 00 00 1D 21 00 01 01 52 00 00 20 21 00 02 08 53 00 00 4D 00 00 21 21 00 03 10 54 00 00'\r\n '45 00 00 4C 00 00 22 21 00 02 08 54 00 00 4D 00 00 24 21 00 01 01 5A 00 00 26 21 00 01 00 A9 03'\r\n '00 28 21 00 01 01 5A 00 00 2A 21 00 01 00 4B 00 00 2B 21 00 02 00 41 00 00 0A 03 00 2C 21 00 01'\r\n '01 42 00 00 2D 21 00 01 01 43 00 00 2F 21 00 01 01 65 00 00 30 21 00 01 01 45 00 00 31 21 00 01'\r\n '01 46 00 00 33 21 00 01 01 4D 00 00 34 21 00 01 01 6F 00 00 35 21 00 01 10 D0 05 00 36 21 00 01'\r\n '10 D1 05 00 37 21 00 01 10 D2 05 00 38 21 00 01 10 D3 05 00 39 21 00 01 01 69 00 00 3B 21 00 03'\r\n '10 46 00 00 41 00 00 58 00 00 3C 21 00 01 01 C0 03 00 3D 21 00 01 01 B3 03 00 3E 21 00 01 01 93'\r\n '03 00 3F 21 00 01 01 A0 03 00 40 21 00 01 01 11 22 00 45 21 00 01 01 44 00 00 46 21 00 01 01 64'\r\n '00 00 47 21 00 01 01 65 00 00 48 21 00 01 01 69 00 00 49 21 00 01 01 6A 00 00 50 21 00 03 0F 31'\r\n '00 00 44 20 00 37 00 00 51 21 00 03 0F 31 00 00 44 20 00 39 00 00 52 21 00 04 0F 31 00 00 44 20'\r\n '00 31 00 00 30 00 00 53 21 00 03 0F 31 00 00 44 20 00 33 00 00 54 21 00 03 0F 32 00 00 44 20 00'\r\n '33 00 00 55 21 00 03 0F 31 00 00 44 20 00 35 00 00 56 21 00 03 0F 32 00 00 44 20 00 35 00 00 57'\r\n '21 00 03 0F 33 00 00 44 20 00 35 00 00 58 21 00 03 0F 34 00 00 44 20 00 35 00 00 59 21 00 03 0F'\r\n '31 00 00 44 20 00 36 00 00 5A 21 00 03 0F 35 00 00 44 20 00 36 00 00 5B 21 00 03 0F 31 00 00 44'\r\n '20 00 38 00 00 5C 21 00 03 0F 33 00 00 44 20 00 38 00 00 5D 21 00 03 0F 35 00 00 44 20 00 38 00'\r\n '00 5E 21 00 03 0F 37 00 00 44 20 00 38 00 00 5F 21 00 02 0F 31 00 00 44 20 00 60 21 00 01 10 49'\r\n '00 00 61 21 00 02 10 49 00 00 49 00 00 62 21 00 03 10 49 00 00 49 00 00 49 00 00 63 21 00 02 10'\r\n '49 00 00 56 00 00 64 21 00 01 10 56 00 00 65 21 00 02 10 56 00 00 49 00 00 66 21 00 03 10 56 00'\r\n '00 49 00 00 49 00 00 67 21 00 04 10 56 00 00 49 00 00 49 00 00 49 00 00 68 21 00 02 10 49 00 00'\r\n '58 00 00 69 21 00 01 10 58 00 00 6A 21 00 02 10 58 00 00 49 00 00 6B 21 00 03 10 58 00 00 49 00'\r\n '00 49 00 00 6C 21 00 01 10 4C 00 00 6D 21 00 01 10 43 00 00 6E 21 00 01 10 44 00 00 6F 21 00 01'\r\n '10 4D 00 00 70 21 00 01 10 69 00 00 71 21 00 02 10 69 00 00 69 00 00 72 21 00 03 10 69 00 00 69'\r\n '00 00 69 00 00 73 21 00 02 10 69 00 00 76 00 00 74 21 00 01 10 76 00 00 75 21 00 02 10 76 00 00'\r\n '69 00 00 76 21 00 03 10 76 00 00 69 00 00 69 00 00 77 21 00 04 10 76 00 00 69 00 00 69 00 00 69'\r\n '00 00 78 21 00 02 10 69 00 00 78 00 00 79 21 00 01 10 78 00 00 7A 21 00 02 10 78 00 00 69 00 00'\r\n '7B 21 00 03 10 78 00 00 69 00 00 69 00 00 7C 21 00 01 10 6C 00 00 7D 21 00 01 10 63 00 00 7E 21'\r\n '00 01 10 64 00 00 7F 21 00 01 10 6D 00 00 89 21 00 03 0F 30 00 00 44 20 00 33 00 00 9A 21 00 02'\r\n '00 90 21 00 38 03 00 9B 21 00 02 00 92 21 00 38 03 00 AE 21 00 02 00 94 21 00 38 03 00 CD 21 00'\r\n '02 00 D0 21 00 38 03 00 CE 21 00 02 00 D4 21 00 38 03 00 CF 21 00 02 00 D2 21 00 38 03 00 04 22'\r\n '00 02 00 03 22 00 38 03 00 09 22 00 02 00 08 22 00 38 03 00 0C 22 00 02 00 0B 22 00 38 03 00 24'\r\n '22 00 02 00 23 22 00 38 03 00 26 22 00 02 00 25 22 00 38 03 00 2C 22 00 02 10 2B 22 00 2B 22 00'\r\n '2D 22 00 03 10 2B 22 00 2B 22 00 2B 22 00 2F 22 00 02 10 2E 22 00 2E 22 00 30 22 00 03 10 2E 22'\r\n '00 2E 22 00 2E 22 00 41 22 00 02 00 3C 22 00 38 03 00 44 22 00 02 00 43 22 00 38 03 00 47 22 00'\r\n '02 00 45 22 00 38 03 00 49 22 00 02 00 48 22 00 38 03 00 60 22 00 02 00 3D 00 00 38 03 00 62 22'\r\n '00 02 00 61 22 00 38 03 00 6D 22 00 02 00 4D 22 00 38 03 00 6E 22 00 02 00 3C 00 00 38 03 00 6F'\r\n '22 00 02 00 3E 00 00 38 03 00 70 22 00 02 00 64 22 00 38 03 00 71 22 00 02 00 65 22 00 38 03 00'\r\n '74 22 00 02 00 72 22 00 38 03 00 75 22 00 02 00 73 22 00 38 03 00 78 22 00 02 00 76 22 00 38 03'\r\n '00 79 22 00 02 00 77 22 00 38 03 00 80 22 00 02 00 7A 22 00 38 03 00 81 22 00 02 00 7B 22 00 38'\r\n '03 00 84 22 00 02 00 82 22 00 38 03 00 85 22 00 02 00 83 22 00 38 03 00 88 22 00 02 00 86 22 00'\r\n '38 03 00 89 22 00 02 00 87 22 00 38 03 00 AC 22 00 02 00 A2 22 00 38 03 00 AD 22 00 02 00 A8 22'\r\n '00 38 03 00 AE 22 00 02 00 A9 22 00 38 03 00 AF 22 00 02 00 AB 22 00 38 03 00 E0 22 00 02 00 7C'\r\n '22 00 38 03 00 E1 22 00 02 00 7D 22 00 38 03 00 E2 22 00 02 00 91 22 00 38 03 00 E3 22 00 02 00'\r\n '92 22 00 38 03 00 EA 22 00 02 00 B2 22 00 38 03 00 EB 22 00 02 00 B3 22 00 38 03 00 EC 22 00 02'\r\n '00 B4 22 00 38 03 00 ED 22 00 02 00 B5 22 00 38 03 00 29 23 00 01 00 08 30 00 2A 23 00 01 00 09'\r\n '30 00 60 24 00 01 07 31 00 00 61 24 00 01 07 32 00 00 62 24 00 01 07 33 00 00 63 24 00 01 07 34'\r\n '00 00 64 24 00 01 07 35 00 00 65 24 00 01 07 36 00 00 66 24 00 01 07 37 00 00 67 24 00 01 07 38'\r\n '00 00 68 24 00 01 07 39 00 00 69 24 00 02 07 31 00 00 30 00 00 6A 24 00 02 07 31 00 00 31 00 00'\r\n '6B 24 00 02 07 31 00 00 32 00 00 6C 24 00 02 07 31 00 00 33 00 00 6D 24 00 02 07 31 00 00 34 00'\r\n '00 6E 24 00 02 07 31 00 00 35 00 00 6F 24 00 02 07 31 00 00 36 00 00 70 24 00 02 07 31 00 00 37'\r\n '00 00 71 24 00 02 07 31 00 00 38 00 00 72 24 00 02 07 31 00 00 39 00 00 73 24 00 02 07 32 00 00'\r\n '30 00 00 74 24 00 03 10 28 00 00 31 00 00 29 00 00 75 24 00 03 10 28 00 00 32 00 00 29 00 00 76'\r\n '24 00 03 10 28 00 00 33 00 00 29 00 00 77 24 00 03 10 28 00 00 34 00 00 29 00 00 78 24 00 03 10'\r\n '28 00 00 35 00 00 29 00 00 79 24 00 03 10 28 00 00 36 00 00 29 00 00 7A 24 00 03 10 28 00 00 37'\r\n '00 00 29 00 00 7B 24 00 03 10 28 00 00 38 00 00 29 00 00 7C 24 00 03 10 28 00 00 39 00 00 29 00'\r\n '00 7D 24 00 04 10 28 00 00 31 00 00 30 00 00 29 00 00 7E 24 00 04 10 28 00 00 31 00 00 31 00 00'\r\n '29 00 00 7F 24 00 04 10 28 00 00 31 00 00 32 00 00 29 00 00 80 24 00 04 10 28 00 00 31 00 00 33'\r\n '00 00 29 00 00 81 24 00 04 10 28 00 00 31 00 00 34 00 00 29 00 00 82 24 00 04 10 28 00 00 31 00'\r\n '00 35 00 00 29 00 00 83 24 00 04 10 28 00 00 31 00 00 36 00 00 29 00 00 84 24 00 04 10 28 00 00'\r\n '31 00 00 37 00 00 29 00 00 85 24 00 04 10 28 00 00 31 00 00 38 00 00 29 00 00 86 24 00 04 10 28'\r\n '00 00 31 00 00 39 00 00 29 00 00 87 24 00 04 10 28 00 00 32 00 00 30 00 00 29 00 00 88 24 00 02'\r\n '10 31 00 00 2E 00 00 89 24 00 02 10 32 00 00 2E 00 00 8A 24 00 02 10 33 00 00 2E 00 00 8B 24 00'\r\n '02 10 34 00 00 2E 00 00 8C 24 00 02 10 35 00 00 2E 00 00 8D 24 00 02 10 36 00 00 2E 00 00 8E 24'\r\n '00 02 10 37 00 00 2E 00 00 8F 24 00 02 10 38 00 00 2E 00 00 90 24 00 02 10 39 00 00 2E 00 00 91'\r\n '24 00 03 10 31 00 00 30 00 00 2E 00 00 92 24 00 03 10 31 00 00 31 00 00 2E 00 00 93 24 00 03 10'\r\n '31 00 00 32 00 00 2E 00 00 94 24 00 03 10 31 00 00 33 00 00 2E 00 00 95 24 00 03 10 31 00 00 34'\r\n '00 00 2E 00 00 96 24 00 03 10 31 00 00 35 00 00 2E 00 00 97 24 00 03 10 31 00 00 36 00 00 2E 00'\r\n '00 98 24 00 03 10 31 00 00 37 00 00 2E 00 00 99 24 00 03 10 31 00 00 38 00 00 2E 00 00 9A 24 00'\r\n '03 10 31 00 00 39 00 00 2E 00 00 9B 24 00 03 10 32 00 00 30 00 00 2E 00 00 9C 24 00 03 10 28 00'\r\n '00 61 00 00 29 00 00 9D 24 00 03 10 28 00 00 62 00 00 29 00 00 9E 24 00 03 10 28 00 00 63 00 00'\r\n '29 00 00 9F 24 00 03 10 28 00 00 64 00 00 29 00 00 A0 24 00 03 10 28 00 00 65 00 00 29 00 00 A1'\r\n '24 00 03 10 28 00 00 66 00 00 29 00 00 A2 24 00 03 10 28 00 00 67 00 00 29 00 00 A3 24 00 03 10'\r\n '28 00 00 68 00 00 29 00 00 A4 24 00 03 10 28 00 00 69 00 00 29 00 00 A5 24 00 03 10 28 00 00 6A'\r\n '00 00 29 00 00 A6 24 00 03 10 28 00 00 6B 00 00 29 00 00 A7 24 00 03 10 28 00 00 6C 00 00 29 00'\r\n '00 A8 24 00 03 10 28 00 00 6D 00 00 29 00 00 A9 24 00 03 10 28 00 00 6E 00 00 29 00 00 AA 24 00'\r\n '03 10 28 00 00 6F 00 00 29 00 00 AB 24 00 03 10 28 00 00 70 00 00 29 00 00 AC 24 00 03 10 28 00'\r\n '00 71 00 00 29 00 00 AD 24 00 03 10 28 00 00 72 00 00 29 00 00 AE 24 00 03 10 28 00 00 73 00 00'\r\n '29 00 00 AF 24 00 03 10 28 00 00 74 00 00 29 00 00 B0 24 00 03 10 28 00 00 75 00 00 29 00 00 B1'\r\n '24 00 03 10 28 00 00 76 00 00 29 00 00 B2 24 00 03 10 28 00 00 77 00 00 29 00 00 B3 24 00 03 10'\r\n '28 00 00 78 00 00 29 00 00 B4 24 00 03 10 28 00 00 79 00 00 29 00 00 B5 24 00 03 10 28 00 00 7A'\r\n '00 00 29 00 00 B6 24 00 01 07 41 00 00 B7 24 00 01 07 42 00 00 B8 24 00 01 07 43 00 00 B9 24 00'\r\n '01 07 44 00 00 BA 24 00 01 07 45 00 00 BB 24 00 01 07 46 00 00 BC 24 00 01 07 47 00 00 BD 24 00'\r\n '01 07 48 00 00 BE 24 00 01 07 49 00 00 BF 24 00 01 07 4A 00 00 C0 24 00 01 07 4B 00 00 C1 24 00'\r\n '01 07 4C 00 00 C2 24 00 01 07 4D 00 00 C3 24 00 01 07 4E 00 00 C4 24 00 01 07 4F 00 00 C5 24 00'\r\n '01 07 50 00 00 C6 24 00 01 07 51 00 00 C7 24 00 01 07 52 00 00 C8 24 00 01 07 53 00 00 C9 24 00'\r\n '01 07 54 00 00 CA 24 00 01 07 55 00 00 CB 24 00 01 07 56 00 00 CC 24 00 01 07 57 00 00 CD 24 00'\r\n '01 07 58 00 00 CE 24 00 01 07 59 00 00 CF 24 00 01 07 5A 00 00 D0 24 00 01 07 61 00 00 D1 24 00'\r\n '01 07 62 00 00 D2 24 00 01 07 63 00 00 D3 24 00 01 07 64 00 00 D4 24 00 01 07 65 00 00 D5 24 00'\r\n '01 07 66 00 00 D6 24 00 01 07 67 00 00 D7 24 00 01 07 68 00 00 D8 24 00 01 07 69 00 00 D9 24 00'\r\n '01 07 6A 00 00 DA 24 00 01 07 6B 00 00 DB 24 00 01 07 6C 00 00 DC 24 00 01 07 6D 00 00 DD 24 00'\r\n '01 07 6E 00 00 DE 24 00 01 07 6F 00 00 DF 24 00 01 07 70 00 00 E0 24 00 01 07 71 00 00 E1 24 00'\r\n '01 07 72 00 00 E2 24 00 01 07 73 00 00 E3 24 00 01 07 74 00 00 E4 24 00 01 07 75 00 00 E5 24 00'\r\n '01 07 76 00 00 E6 24 00 01 07 77 00 00 E7 24 00 01 07 78 00 00 E8 24 00 01 07 79 00 00 E9 24 00'\r\n '01 07 7A 00 00 EA 24 00 01 07 30 00 00 0C 2A 00 04 10 2B 22 00 2B 22 00 2B 22 00 2B 22 00 74 2A'\r\n '00 03 10 3A 00 00 3A 00 00 3D 00 00 75 2A 00 02 10 3D 00 00 3D 00 00 76 2A 00 03 10 3D 00 00 3D'\r\n '00 00 3D 00 00 DC 2A 00 02 00 DD 2A 00 38 03 00 7C 2C 00 01 09 6A 00 00 7D 2C 00 01 08 56 00 00'\r\n '6F 2D 00 01 08 61 2D 00 9F 2E 00 01 10 CD 6B 00 F3 2E 00 01 10 9F 9F 00 00 2F 00 01 10 00 4E 00'\r\n '01 2F 00 01 10 28 4E 00 02 2F 00 01 10 36 4E 00 03 2F 00 01 10 3F 4E 00 04 2F 00 01 10 59 4E 00'\r\n '05 2F 00 01 10 85 4E 00 06 2F 00 01 10 8C 4E 00 07 2F 00 01 10 A0 4E 00 08 2F 00 01 10 BA 4E 00'\r\n '09 2F 00 01 10 3F 51 00 0A 2F 00 01 10 65 51 00 0B 2F 00 01 10 6B 51 00 0C 2F 00 01 10 82 51 00'\r\n '0D 2F 00 01 10 96 51 00 0E 2F 00 01 10 AB 51 00 0F 2F 00 01 10 E0 51 00 10 2F 00 01 10 F5 51 00'\r\n '11 2F 00 01 10 00 52 00 12 2F 00 01 10 9B 52 00 13 2F 00 01 10 F9 52 00 14 2F 00 01 10 15 53 00'\r\n '15 2F 00 01 10 1A 53 00 16 2F 00 01 10 38 53 00 17 2F 00 01 10 41 53 00 18 2F 00 01 10 5C 53 00'\r\n '19 2F 00 01 10 69 53 00 1A 2F 00 01 10 82 53 00 1B 2F 00 01 10 B6 53 00 1C 2F 00 01 10 C8 53 00'\r\n '1D 2F 00 01 10 E3 53 00 1E 2F 00 01 10 D7 56 00 1F 2F 00 01 10 1F 57 00 20 2F 00 01 10 EB 58 00'\r\n '21 2F 00 01 10 02 59 00 22 2F 00 01 10 0A 59 00 23 2F 00 01 10 15 59 00 24 2F 00 01 10 27 59 00'\r\n '25 2F 00 01 10 73 59 00 26 2F 00 01 10 50 5B 00 27 2F 00 01 10 80 5B 00 28 2F 00 01 10 F8 5B 00'\r\n '29 2F 00 01 10 0F 5C 00 2A 2F 00 01 10 22 5C 00 2B 2F 00 01 10 38 5C 00 2C 2F 00 01 10 6E 5C 00'\r\n '2D 2F 00 01 10 71 5C 00 2E 2F 00 01 10 DB 5D 00 2F 2F 00 01 10 E5 5D 00 30 2F 00 01 10 F1 5D 00'\r\n '31 2F 00 01 10 FE 5D 00 32 2F 00 01 10 72 5E 00 33 2F 00 01 10 7A 5E 00 34 2F 00 01 10 7F 5E 00'\r\n '35 2F 00 01 10 F4 5E 00 36 2F 00 01 10 FE 5E 00 37 2F 00 01 10 0B 5F 00 38 2F 00 01 10 13 5F 00'\r\n '39 2F 00 01 10 50 5F 00 3A 2F 00 01 10 61 5F 00 3B 2F 00 01 10 73 5F 00 3C 2F 00 01 10 C3 5F 00'\r\n '3D 2F 00 01 10 08 62 00 3E 2F 00 01 10 36 62 00 3F 2F 00 01 10 4B 62 00 40 2F 00 01 10 2F 65 00'\r\n '41 2F 00 01 10 34 65 00 42 2F 00 01 10 87 65 00 43 2F 00 01 10 97 65 00 44 2F 00 01 10 A4 65 00'\r\n '45 2F 00 01 10 B9 65 00 46 2F 00 01 10 E0 65 00 47 2F 00 01 10 E5 65 00 48 2F 00 01 10 F0 66 00'\r\n '49 2F 00 01 10 08 67 00 4A 2F 00 01 10 28 67 00 4B 2F 00 01 10 20 6B 00 4C 2F 00 01 10 62 6B 00'\r\n '4D 2F 00 01 10 79 6B 00 4E 2F 00 01 10 B3 6B 00 4F 2F 00 01 10 CB 6B 00 50 2F 00 01 10 D4 6B 00'\r\n '51 2F 00 01 10 DB 6B 00 52 2F 00 01 10 0F 6C 00 53 2F 00 01 10 14 6C 00 54 2F 00 01 10 34 6C 00'\r\n '55 2F 00 01 10 6B 70 00 56 2F 00 01 10 2A 72 00 57 2F 00 01 10 36 72 00 58 2F 00 01 10 3B 72 00'\r\n '59 2F 00 01 10 3F 72 00 5A 2F 00 01 10 47 72 00 5B 2F 00 01 10 59 72 00 5C 2F 00 01 10 5B 72 00'\r\n '5D 2F 00 01 10 AC 72 00 5E 2F 00 01 10 84 73 00 5F 2F 00 01 10 89 73 00 60 2F 00 01 10 DC 74 00'\r\n '61 2F 00 01 10 E6 74 00 62 2F 00 01 10 18 75 00 63 2F 00 01 10 1F 75 00 64 2F 00 01 10 28 75 00'\r\n '65 2F 00 01 10 30 75 00 66 2F 00 01 10 8B 75 00 67 2F 00 01 10 92 75 00 68 2F 00 01 10 76 76 00'\r\n '69 2F 00 01 10 7D 76 00 6A 2F 00 01 10 AE 76 00 6B 2F 00 01 10 BF 76 00 6C 2F 00 01 10 EE 76 00'\r\n '6D 2F 00 01 10 DB 77 00 6E 2F 00 01 10 E2 77 00 6F 2F 00 01 10 F3 77 00 70 2F 00 01 10 3A 79 00'\r\n '71 2F 00 01 10 B8 79 00 72 2F 00 01 10 BE 79 00 73 2F 00 01 10 74 7A 00 74 2F 00 01 10 CB 7A 00'\r\n '75 2F 00 01 10 F9 7A 00 76 2F 00 01 10 73 7C 00 77 2F 00 01 10 F8 7C 00 78 2F 00 01 10 36 7F 00'\r\n '79 2F 00 01 10 51 7F 00 7A 2F 00 01 10 8A 7F 00 7B 2F 00 01 10 BD 7F 00 7C 2F 00 01 10 01 80 00'\r\n '7D 2F 00 01 10 0C 80 00 7E 2F 00 01 10 12 80 00 7F 2F 00 01 10 33 80 00 80 2F 00 01 10 7F 80 00'\r\n '81 2F 00 01 10 89 80 00 82 2F 00 01 10 E3 81 00 83 2F 00 01 10 EA 81 00 84 2F 00 01 10 F3 81 00'\r\n '85 2F 00 01 10 FC 81 00 86 2F 00 01 10 0C 82 00 87 2F 00 01 10 1B 82 00 88 2F 00 01 10 1F 82 00'\r\n '89 2F 00 01 10 6E 82 00 8A 2F 00 01 10 72 82 00 8B 2F 00 01 10 78 82 00 8C 2F 00 01 10 4D 86 00'\r\n '8D 2F 00 01 10 6B 86 00 8E 2F 00 01 10 40 88 00 8F 2F 00 01 10 4C 88 00 90 2F 00 01 10 63 88 00'\r\n '91 2F 00 01 10 7E 89 00 92 2F 00 01 10 8B 89 00 93 2F 00 01 10 D2 89 00 94 2F 00 01 10 00 8A 00'\r\n '95 2F 00 01 10 37 8C 00 96 2F 00 01 10 46 8C 00 97 2F 00 01 10 55 8C 00 98 2F 00 01 10 78 8C 00'\r\n '99 2F 00 01 10 9D 8C 00 9A 2F 00 01 10 64 8D 00 9B 2F 00 01 10 70 8D 00 9C 2F 00 01 10 B3 8D 00'\r\n '9D 2F 00 01 10 AB 8E 00 9E 2F 00 01 10 CA 8E 00 9F 2F 00 01 10 9B 8F 00 A0 2F 00 01 10 B0 8F 00'\r\n 'A1 2F 00 01 10 B5 8F 00 A2 2F 00 01 10 91 90 00 A3 2F 00 01 10 49 91 00 A4 2F 00 01 10 C6 91 00'\r\n 'A5 2F 00 01 10 CC 91 00 A6 2F 00 01 10 D1 91 00 A7 2F 00 01 10 77 95 00 A8 2F 00 01 10 80 95 00'\r\n 'A9 2F 00 01 10 1C 96 00 AA 2F 00 01 10 B6 96 00 AB 2F 00 01 10 B9 96 00 AC 2F 00 01 10 E8 96 00'\r\n 'AD 2F 00 01 10 51 97 00 AE 2F 00 01 10 5E 97 00 AF 2F 00 01 10 62 97 00 B0 2F 00 01 10 69 97 00'\r\n 'B1 2F 00 01 10 CB 97 00 B2 2F 00 01 10 ED 97 00 B3 2F 00 01 10 F3 97 00 B4 2F 00 01 10 01 98 00'\r\n 'B5 2F 00 01 10 A8 98 00 B6 2F 00 01 10 DB 98 00 B7 2F 00 01 10 DF 98 00 B8 2F 00 01 10 96 99 00'\r\n 'B9 2F 00 01 10 99 99 00 BA 2F 00 01 10 AC 99 00 BB 2F 00 01 10 A8 9A 00 BC 2F 00 01 10 D8 9A 00'\r\n 'BD 2F 00 01 10 DF 9A 00 BE 2F 00 01 10 25 9B 00 BF 2F 00 01 10 2F 9B 00 C0 2F 00 01 10 32 9B 00'\r\n 'C1 2F 00 01 10 3C 9B 00 C2 2F 00 01 10 5A 9B 00 C3 2F 00 01 10 E5 9C 00 C4 2F 00 01 10 75 9E 00'\r\n 'C5 2F 00 01 10 7F 9E 00 C6 2F 00 01 10 A5 9E 00 C7 2F 00 01 10 BB 9E 00 C8 2F 00 01 10 C3 9E 00'\r\n 'C9 2F 00 01 10 CD 9E 00 CA 2F 00 01 10 D1 9E 00 CB 2F 00 01 10 F9 9E 00 CC 2F 00 01 10 FD 9E 00'\r\n 'CD 2F 00 01 10 0E 9F 00 CE 2F 00 01 10 13 9F 00 CF 2F 00 01 10 20 9F 00 D0 2F 00 01 10 3B 9F 00'\r\n 'D1 2F 00 01 10 4A 9F 00 D2 2F 00 01 10 52 9F 00 D3 2F 00 01 10 8D 9F 00 D4 2F 00 01 10 9C 9F 00'\r\n 'D5 2F 00 01 10 A0 9F 00 00 30 00 01 0B 20 00 00 36 30 00 01 10 12 30 00 38 30 00 01 10 41 53 00'\r\n '39 30 00 01 10 44 53 00 3A 30 00 01 10 45 53 00 4C 30 00 02 00 4B 30 00 99 30 00 4E 30 00 02 00'\r\n '4D 30 00 99 30 00 50 30 00 02 00 4F 30 00 99 30 00 52 30 00 02 00 51 30 00 99 30 00 54 30 00 02'\r\n '00 53 30 00 99 30 00 56 30 00 02 00 55 30 00 99 30 00 58 30 00 02 00 57 30 00 99 30 00 5A 30 00'\r\n '02 00 59 30 00 99 30 00 5C 30 00 02 00 5B 30 00 99 30 00 5E 30 00 02 00 5D 30 00 99 30 00 60 30'\r\n '00 02 00 5F 30 00 99 30 00 62 30 00 02 00 61 30 00 99 30 00 65 30 00 02 00 64 30 00 99 30 00 67'\r\n '30 00 02 00 66 30 00 99 30 00 69 30 00 02 00 68 30 00 99 30 00 70 30 00 02 00 6F 30 00 99 30 00'\r\n '71 30 00 02 00 6F 30 00 9A 30 00 73 30 00 02 00 72 30 00 99 30 00 74 30 00 02 00 72 30 00 9A 30'\r\n '00 76 30 00 02 00 75 30 00 99 30 00 77 30 00 02 00 75 30 00 9A 30 00 79 30 00 02 00 78 30 00 99'\r\n '30 00 7A 30 00 02 00 78 30 00 9A 30 00 7C 30 00 02 00 7B 30 00 99 30 00 7D 30 00 02 00 7B 30 00'\r\n '9A 30 00 94 30 00 02 00 46 30 00 99 30 00 9B 30 00 02 10 20 00 00 99 30 00 9C 30 00 02 10 20 00'\r\n '00 9A 30 00 9E 30 00 02 00 9D 30 00 99 30 00 9F 30 00 02 0A 88 30 00 8A 30 00 AC 30 00 02 00 AB'\r\n '30 00 99 30 00 AE 30 00 02 00 AD 30 00 99 30 00 B0 30 00 02 00 AF 30 00 99 30 00 B2 30 00 02 00'\r\n 'B1 30 00 99 30 00 B4 30 00 02 00 B3 30 00 99 30 00 B6 30 00 02 00 B5 30 00 99 30 00 B8 30 00 02'\r\n '00 B7 30 00 99 30 00 BA 30 00 02 00 B9 30 00 99 30 00 BC 30 00 02 00 BB 30 00 99 30 00 BE 30 00'\r\n '02 00 BD 30 00 99 30 00 C0 30 00 02 00 BF 30 00 99 30 00 C2 30 00 02 00 C1 30 00 99 30 00 C5 30'\r\n '00 02 00 C4 30 00 99 30 00 C7 30 00 02 00 C6 30 00 99 30 00 C9 30 00 02 00 C8 30 00 99 30 00 D0'\r\n '30 00 02 00 CF 30 00 99 30 00 D1 30 00 02 00 CF 30 00 9A 30 00 D3 30 00 02 00 D2 30 00 99 30 00'\r\n 'D4 30 00 02 00 D2 30 00 9A 30 00 D6 30 00 02 00 D5 30 00 99 30 00 D7 30 00 02 00 D5 30 00 9A 30'\r\n '00 D9 30 00 02 00 D8 30 00 99 30 00 DA 30 00 02 00 D8 30 00 9A 30 00 DC 30 00 02 00 DB 30 00 99'\r\n '30 00 DD 30 00 02 00 DB 30 00 9A 30 00 F4 30 00 02 00 A6 30 00 99 30 00 F7 30 00 02 00 EF 30 00'\r\n '99 30 00 F8 30 00 02 00 F0 30 00 99 30 00 F9 30 00 02 00 F1 30 00 99 30 00 FA 30 00 02 00 F2 30'\r\n '00 99 30 00 FE 30 00 02 00 FD 30 00 99 30 00 FF 30 00 02 0A B3 30 00 C8 30 00 31 31 00 01 10 00'\r\n '11 00 32 31 00 01 10 01 11 00 33 31 00 01 10 AA 11 00 34 31 00 01 10 02 11 00 35 31 00 01 10 AC'\r\n '11 00 36 31 00 01 10 AD 11 00 37 31 00 01 10 03 11 00 38 31 00 01 10 04 11 00 39 31 00 01 10 05'\r\n '11 00 3A 31 00 01 10 B0 11 00 3B 31 00 01 10 B1 11 00 3C 31 00 01 10 B2 11 00 3D 31 00 01 10 B3'\r\n '11 00 3E 31 00 01 10 B4 11 00 3F 31 00 01 10 B5 11 00 40 31 00 01 10 1A 11 00 41 31 00 01 10 06'\r\n '11 00 42 31 00 01 10 07 11 00 43 31 00 01 10 08 11 00 44 31 00 01 10 21 11 00 45 31 00 01 10 09'\r\n '11 00 46 31 00 01 10 0A 11 00 47 31 00 01 10 0B 11 00 48 31 00 01 10 0C 11 00 49 31 00 01 10 0D'\r\n '11 00 4A 31 00 01 10 0E 11 00 4B 31 00 01 10 0F 11 00 4C 31 00 01 10 10 11 00 4D 31 00 01 10 11'\r\n '11 00 4E 31 00 01 10 12 11 00 4F 31 00 01 10 61 11 00 50 31 00 01 10 62 11 00 51 31 00 01 10 63'\r\n '11 00 52 31 00 01 10 64 11 00 53 31 00 01 10 65 11 00 54 31 00 01 10 66 11 00 55 31 00 01 10 67'\r\n '11 00 56 31 00 01 10 68 11 00 57 31 00 01 10 69 11 00 58 31 00 01 10 6A 11 00 59 31 00 01 10 6B'\r\n '11 00 5A 31 00 01 10 6C 11 00 5B 31 00 01 10 6D 11 00 5C 31 00 01 10 6E 11 00 5D 31 00 01 10 6F'\r\n '11 00 5E 31 00 01 10 70 11 00 5F 31 00 01 10 71 11 00 60 31 00 01 10 72 11 00 61 31 00 01 10 73'\r\n '11 00 62 31 00 01 10 74 11 00 63 31 00 01 10 75 11 00 64 31 00 01 10 60 11 00 65 31 00 01 10 14'\r\n '11 00 66 31 00 01 10 15 11 00 67 31 00 01 10 C7 11 00 68 31 00 01 10 C8 11 00 69 31 00 01 10 CC'\r\n '11 00 6A 31 00 01 10 CE 11 00 6B 31 00 01 10 D3 11 00 6C 31 00 01 10 D7 11 00 6D 31 00 01 10 D9'\r\n '11 00 6E 31 00 01 10 1C 11 00 6F 31 00 01 10 DD 11 00 70 31 00 01 10 DF 11 00 71 31 00 01 10 1D'\r\n '11 00 72 31 00 01 10 1E 11 00 73 31 00 01 10 20 11 00 74 31 00 01 10 22 11 00 75 31 00 01 10 23'\r\n '11 00 76 31 00 01 10 27 11 00 77 31 00 01 10 29 11 00 78 31 00 01 10 2B 11 00 79 31 00 01 10 2C'\r\n '11 00 7A 31 00 01 10 2D 11 00 7B 31 00 01 10 2E 11 00 7C 31 00 01 10 2F 11 00 7D 31 00 01 10 32'\r\n '11 00 7E 31 00 01 10 36 11 00 7F 31 00 01 10 40 11 00 80 31 00 01 10 47 11 00 81 31 00 01 10 4C'\r\n '11 00 82 31 00 01 10 F1 11 00 83 31 00 01 10 F2 11 00 84 31 00 01 10 57 11 00 85 31 00 01 10 58'\r\n '11 00 86 31 00 01 10 59 11 00 87 31 00 01 10 84 11 00 88 31 00 01 10 85 11 00 89 31 00 01 10 88'\r\n '11 00 8A 31 00 01 10 91 11 00 8B 31 00 01 10 92 11 00 8C 31 00 01 10 94 11 00 8D 31 00 01 10 9E'\r\n '11 00 8E 31 00 01 10 A1 11 00 92 31 00 01 08 00 4E 00 93 31 00 01 08 8C 4E 00 94 31 00 01 08 09'\r\n '4E 00 95 31 00 01 08 DB 56 00 96 31 00 01 08 0A 4E 00 97 31 00 01 08 2D 4E 00 98 31 00 01 08 0B'\r\n '4E 00 99 31 00 01 08 32 75 00 9A 31 00 01 08 59 4E 00 9B 31 00 01 08 19 4E 00 9C 31 00 01 08 01'\r\n '4E 00 9D 31 00 01 08 29 59 00 9E 31 00 01 08 30 57 00 9F 31 00 01 08 BA 4E 00 00 32 00 03 10 28'\r\n '00 00 00 11 00 29 00 00 01 32 00 03 10 28 00 00 02 11 00 29 00 00 02 32 00 03 10 28 00 00 03 11'\r\n '00 29 00 00 03 32 00 03 10 28 00 00 05 11 00 29 00 00 04 32 00 03 10 28 00 00 06 11 00 29 00 00'\r\n '05 32 00 03 10 28 00 00 07 11 00 29 00 00 06 32 00 03 10 28 00 00 09 11 00 29 00 00 07 32 00 03'\r\n '10 28 00 00 0B 11 00 29 00 00 08 32 00 03 10 28 00 00 0C 11 00 29 00 00 09 32 00 03 10 28 00 00'\r\n '0E 11 00 29 00 00 0A 32 00 03 10 28 00 00 0F 11 00 29 00 00 0B 32 00 03 10 28 00 00 10 11 00 29'\r\n '00 00 0C 32 00 03 10 28 00 00 11 11 00 29 00 00 0D 32 00 03 10 28 00 00 12 11 00 29 00 00 0E 32'\r\n '00 04 10 28 00 00 00 11 00 61 11 00 29 00 00 0F 32 00 04 10 28 00 00 02 11 00 61 11 00 29 00 00'\r\n '10 32 00 04 10 28 00 00 03 11 00 61 11 00 29 00 00 11 32 00 04 10 28 00 00 05 11 00 61 11 00 29'\r\n '00 00 12 32 00 04 10 28 00 00 06 11 00 61 11 00 29 00 00 13 32 00 04 10 28 00 00 07 11 00 61 11'\r\n '00 29 00 00 14 32 00 04 10 28 00 00 09 11 00 61 11 00 29 00 00 15 32 00 04 10 28 00 00 0B 11 00'\r\n '61 11 00 29 00 00 16 32 00 04 10 28 00 00 0C 11 00 61 11 00 29 00 00 17 32 00 04 10 28 00 00 0E'\r\n '11 00 61 11 00 29 00 00 18 32 00 04 10 28 00 00 0F 11 00 61 11 00 29 00 00 19 32 00 04 10 28 00'\r\n '00 10 11 00 61 11 00 29 00 00 1A 32 00 04 10 28 00 00 11 11 00 61 11 00 29 00 00 1B 32 00 04 10'\r\n '28 00 00 12 11 00 61 11 00 29 00 00 1C 32 00 04 10 28 00 00 0C 11 00 6E 11 00 29 00 00 1D 32 00'\r\n '07 10 28 00 00 0B 11 00 69 11 00 0C 11 00 65 11 00 AB 11 00 29 00 00 1E 32 00 06 10 28 00 00 0B'\r\n '11 00 69 11 00 12 11 00 6E 11 00 29 00 00 20 32 00 03 10 28 00 00 00 4E 00 29 00 00 21 32 00 03'\r\n '10 28 00 00 8C 4E 00 29 00 00 22 32 00 03 10 28 00 00 09 4E 00 29 00 00 23 32 00 03 10 28 00 00'\r\n 'DB 56 00 29 00 00 24 32 00 03 10 28 00 00 94 4E 00 29 00 00 25 32 00 03 10 28 00 00 6D 51 00 29'\r\n '00 00 26 32 00 03 10 28 00 00 03 4E 00 29 00 00 27 32 00 03 10 28 00 00 6B 51 00 29 00 00 28 32'\r\n '00 03 10 28 00 00 5D 4E 00 29 00 00 29 32 00 03 10 28 00 00 41 53 00 29 00 00 2A 32 00 03 10 28'\r\n '00 00 08 67 00 29 00 00 2B 32 00 03 10 28 00 00 6B 70 00 29 00 00 2C 32 00 03 10 28 00 00 34 6C'\r\n '00 29 00 00 2D 32 00 03 10 28 00 00 28 67 00 29 00 00 2E 32 00 03 10 28 00 00 D1 91 00 29 00 00'\r\n '2F 32 00 03 10 28 00 00 1F 57 00 29 00 00 30 32 00 03 10 28 00 00 E5 65 00 29 00 00 31 32 00 03'\r\n '10 28 00 00 2A 68 00 29 00 00 32 32 00 03 10 28 00 00 09 67 00 29 00 00 33 32 00 03 10 28 00 00'\r\n '3E 79 00 29 00 00 34 32 00 03 10 28 00 00 0D 54 00 29 00 00 35 32 00 03 10 28 00 00 79 72 00 29'\r\n '00 00 36 32 00 03 10 28 00 00 A1 8C 00 29 00 00 37 32 00 03 10 28 00 00 5D 79 00 29 00 00 38 32'\r\n '00 03 10 28 00 00 B4 52 00 29 00 00 39 32 00 03 10 28 00 00 E3 4E 00 29 00 00 3A 32 00 03 10 28'\r\n '00 00 7C 54 00 29 00 00 3B 32 00 03 10 28 00 00 66 5B 00 29 00 00 3C 32 00 03 10 28 00 00 E3 76'\r\n '00 29 00 00 3D 32 00 03 10 28 00 00 01 4F 00 29 00 00 3E 32 00 03 10 28 00 00 C7 8C 00 29 00 00'\r\n '3F 32 00 03 10 28 00 00 54 53 00 29 00 00 40 32 00 03 10 28 00 00 6D 79 00 29 00 00 41 32 00 03'\r\n '10 28 00 00 11 4F 00 29 00 00 42 32 00 03 10 28 00 00 EA 81 00 29 00 00 43 32 00 03 10 28 00 00'\r\n 'F3 81 00 29 00 00 44 32 00 01 07 4F 55 00 45 32 00 01 07 7C 5E 00 46 32 00 01 07 87 65 00 47 32'\r\n '00 01 07 8F 7B 00 50 32 00 03 0E 50 00 00 54 00 00 45 00 00 51 32 00 02 07 32 00 00 31 00 00 52'\r\n '32 00 02 07 32 00 00 32 00 00 53 32 00 02 07 32 00 00 33 00 00 54 32 00 02 07 32 00 00 34 00 00'\r\n '55 32 00 02 07 32 00 00 35 00 00 56 32 00 02 07 32 00 00 36 00 00 57 32 00 02 07 32 00 00 37 00'\r\n '00 58 32 00 02 07 32 00 00 38 00 00 59 32 00 02 07 32 00 00 39 00 00 5A 32 00 02 07 33 00 00 30'\r\n '00 00 5B 32 00 02 07 33 00 00 31 00 00 5C 32 00 02 07 33 00 00 32 00 00 5D 32 00 02 07 33 00 00'\r\n '33 00 00 5E 32 00 02 07 33 00 00 34 00 00 5F 32 00 02 07 33 00 00 35 00 00 60 32 00 01 07 00 11'\r\n '00 61 32 00 01 07 02 11 00 62 32 00 01 07 03 11 00 63 32 00 01 07 05 11 00 64 32 00 01 07 06 11'\r\n '00 65 32 00 01 07 07 11 00 66 32 00 01 07 09 11 00 67 32 00 01 07 0B 11 00 68 32 00 01 07 0C 11'\r\n '00 69 32 00 01 07 0E 11 00 6A 32 00 01 07 0F 11 00 6B 32 00 01 07 10 11 00 6C 32 00 01 07 11 11'\r\n '00 6D 32 00 01 07 12 11 00 6E 32 00 02 07 00 11 00 61 11 00 6F 32 00 02 07 02 11 00 61 11 00 70'\r\n '32 00 02 07 03 11 00 61 11 00 71 32 00 02 07 05 11 00 61 11 00 72 32 00 02 07 06 11 00 61 11 00'\r\n '73 32 00 02 07 07 11 00 61 11 00 74 32 00 02 07 09 11 00 61 11 00 75 32 00 02 07 0B 11 00 61 11'\r\n '00 76 32 00 02 07 0C 11 00 61 11 00 77 32 00 02 07 0E 11 00 61 11 00 78 32 00 02 07 0F 11 00 61'\r\n '11 00 79 32 00 02 07 10 11 00 61 11 00 7A 32 00 02 07 11 11 00 61 11 00 7B 32 00 02 07 12 11 00'\r\n '61 11 00 7C 32 00 05 07 0E 11 00 61 11 00 B7 11 00 00 11 00 69 11 00 7D 32 00 04 07 0C 11 00 6E'\r\n '11 00 0B 11 00 74 11 00 7E 32 00 02 07 0B 11 00 6E 11 00 80 32 00 01 07 00 4E 00 81 32 00 01 07'\r\n '8C 4E 00 82 32 00 01 07 09 4E 00 83 32 00 01 07 DB 56 00 84 32 00 01 07 94 4E 00 85 32 00 01 07'\r\n '6D 51 00 86 32 00 01 07 03 4E 00 87 32 00 01 07 6B 51 00 88 32 00 01 07 5D 4E 00 89 32 00 01 07'\r\n '41 53 00 8A 32 00 01 07 08 67 00 8B 32 00 01 07 6B 70 00 8C 32 00 01 07 34 6C 00 8D 32 00 01 07'\r\n '28 67 00 8E 32 00 01 07 D1 91 00 8F 32 00 01 07 1F 57 00 90 32 00 01 07 E5 65 00 91 32 00 01 07'\r\n '2A 68 00 92 32 00 01 07 09 67 00 93 32 00 01 07 3E 79 00 94 32 00 01 07 0D 54 00 95 32 00 01 07'\r\n '79 72 00 96 32 00 01 07 A1 8C 00 97 32 00 01 07 5D 79 00 98 32 00 01 07 B4 52 00 99 32 00 01 07'\r\n 'D8 79 00 9A 32 00 01 07 37 75 00 9B 32 00 01 07 73 59 00 9C 32 00 01 07 69 90 00 9D 32 00 01 07'\r\n '2A 51 00 9E 32 00 01 07 70 53 00 9F 32 00 01 07 E8 6C 00 A0 32 00 01 07 05 98 00 A1 32 00 01 07'\r\n '11 4F 00 A2 32 00 01 07 99 51 00 A3 32 00 01 07 63 6B 00 A4 32 00 01 07 0A 4E 00 A5 32 00 01 07'\r\n '2D 4E 00 A6 32 00 01 07 0B 4E 00 A7 32 00 01 07 E6 5D 00 A8 32 00 01 07 F3 53 00 A9 32 00 01 07'\r\n '3B 53 00 AA 32 00 01 07 97 5B 00 AB 32 00 01 07 66 5B 00 AC 32 00 01 07 E3 76 00 AD 32 00 01 07'\r\n '01 4F 00 AE 32 00 01 07 C7 8C 00 AF 32 00 01 07 54 53 00 B0 32 00 01 07 1C 59 00 B1 32 00 02 07'\r\n '33 00 00 36 00 00 B2 32 00 02 07 33 00 00 37 00 00 B3 32 00 02 07 33 00 00 38 00 00 B4 32 00 02'\r\n '07 33 00 00 39 00 00 B5 32 00 02 07 34 00 00 30 00 00 B6 32 00 02 07 34 00 00 31 00 00 B7 32 00'\r\n '02 07 34 00 00 32 00 00 B8 32 00 02 07 34 00 00 33 00 00 B9 32 00 02 07 34 00 00 34 00 00 BA 32'\r\n '00 02 07 34 00 00 35 00 00 BB 32 00 02 07 34 00 00 36 00 00 BC 32 00 02 07 34 00 00 37 00 00 BD'\r\n '32 00 02 07 34 00 00 38 00 00 BE 32 00 02 07 34 00 00 39 00 00 BF 32 00 02 07 35 00 00 30 00 00'\r\n 'C0 32 00 02 10 31 00 00 08 67 00 C1 32 00 02 10 32 00 00 08 67 00 C2 32 00 02 10 33 00 00 08 67'\r\n '00 C3 32 00 02 10 34 00 00 08 67 00 C4 32 00 02 10 35 00 00 08 67 00 C5 32 00 02 10 36 00 00 08'\r\n '67 00 C6 32 00 02 10 37 00 00 08 67 00 C7 32 00 02 10 38 00 00 08 67 00 C8 32 00 02 10 39 00 00'\r\n '08 67 00 C9 32 00 03 10 31 00 00 30 00 00 08 67 00 CA 32 00 03 10 31 00 00 31 00 00 08 67 00 CB'\r\n '32 00 03 10 31 00 00 32 00 00 08 67 00 CC 32 00 02 0E 48 00 00 67 00 00 CD 32 00 03 0E 65 00 00'\r\n '72 00 00 67 00 00 CE 32 00 02 0E 65 00 00 56 00 00 CF 32 00 03 0E 4C 00 00 54 00 00 44 00 00 D0'\r\n '32 00 01 07 A2 30 00 D1 32 00 01 07 A4 30 00 D2 32 00 01 07 A6 30 00 D3 32 00 01 07 A8 30 00 D4'\r\n '32 00 01 07 AA 30 00 D5 32 00 01 07 AB 30 00 D6 32 00 01 07 AD 30 00 D7 32 00 01 07 AF 30 00 D8'\r\n '32 00 01 07 B1 30 00 D9 32 00 01 07 B3 30 00 DA 32 00 01 07 B5 30 00 DB 32 00 01 07 B7 30 00 DC'\r\n '32 00 01 07 B9 30 00 DD 32 00 01 07 BB 30 00 DE 32 00 01 07 BD 30 00 DF 32 00 01 07 BF 30 00 E0'\r\n '32 00 01 07 C1 30 00 E1 32 00 01 07 C4 30 00 E2 32 00 01 07 C6 30 00 E3 32 00 01 07 C8 30 00 E4'\r\n '32 00 01 07 CA 30 00 E5 32 00 01 07 CB 30 00 E6 32 00 01 07 CC 30 00 E7 32 00 01 07 CD 30 00 E8'\r\n '32 00 01 07 CE 30 00 E9 32 00 01 07 CF 30 00 EA 32 00 01 07 D2 30 00 EB 32 00 01 07 D5 30 00 EC'\r\n '32 00 01 07 D8 30 00 ED 32 00 01 07 DB 30 00 EE 32 00 01 07 DE 30 00 EF 32 00 01 07 DF 30 00 F0'\r\n '32 00 01 07 E0 30 00 F1 32 00 01 07 E1 30 00 F2 32 00 01 07 E2 30 00 F3 32 00 01 07 E4 30 00 F4'\r\n '32 00 01 07 E6 30 00 F5 32 00 01 07 E8 30 00 F6 32 00 01 07 E9 30 00 F7 32 00 01 07 EA 30 00 F8'\r\n '32 00 01 07 EB 30 00 F9 32 00 01 07 EC 30 00 FA 32 00 01 07 ED 30 00 FB 32 00 01 07 EF 30 00 FC'\r\n '32 00 01 07 F0 30 00 FD 32 00 01 07 F1 30 00 FE 32 00 01 07 F2 30 00 00 33 00 05 0E A2 30 00 CF'\r\n '30 00 9A 30 00 FC 30 00 C8 30 00 01 33 00 04 0E A2 30 00 EB 30 00 D5 30 00 A1 30 00 02 33 00 05'\r\n '0E A2 30 00 F3 30 00 D8 30 00 9A 30 00 A2 30 00 03 33 00 03 0E A2 30 00 FC 30 00 EB 30 00 04 33'\r\n '00 05 0E A4 30 00 CB 30 00 F3 30 00 AF 30 00 99 30 00 05 33 00 03 0E A4 30 00 F3 30 00 C1 30 00'\r\n '06 33 00 03 0E A6 30 00 A9 30 00 F3 30 00 07 33 00 06 0E A8 30 00 B9 30 00 AF 30 00 FC 30 00 C8'\r\n '30 00 99 30 00 08 33 00 04 0E A8 30 00 FC 30 00 AB 30 00 FC 30 00 09 33 00 03 0E AA 30 00 F3 30'\r\n '00 B9 30 00 0A 33 00 03 0E AA 30 00 FC 30 00 E0 30 00 0B 33 00 03 0E AB 30 00 A4 30 00 EA 30 00'\r\n '0C 33 00 04 0E AB 30 00 E9 30 00 C3 30 00 C8 30 00 0D 33 00 04 0E AB 30 00 ED 30 00 EA 30 00 FC'\r\n '30 00 0E 33 00 04 0E AB 30 00 99 30 00 ED 30 00 F3 30 00 0F 33 00 04 0E AB 30 00 99 30 00 F3 30'\r\n '00 DE 30 00 10 33 00 06 0E AD 30 00 99 30 00 AD 30 00 99 30 00 AB 30 00 99 30 00 11 33 00 04 0E'\r\n 'AD 30 00 99 30 00 CB 30 00 FC 30 00 12 33 00 04 0E AD 30 00 E5 30 00 EA 30 00 FC 30 00 13 33 00'\r\n '08 0E AD 30 00 99 30 00 EB 30 00 AD 30 00 99 30 00 BF 30 00 99 30 00 FC 30 00 14 33 00 02 0E AD'\r\n '30 00 ED 30 00 15 33 00 06 0E AD 30 00 ED 30 00 AF 30 00 99 30 00 E9 30 00 E0 30 00 16 33 00 06'\r\n '0E AD 30 00 ED 30 00 E1 30 00 FC 30 00 C8 30 00 EB 30 00 17 33 00 05 0E AD 30 00 ED 30 00 EF 30'\r\n '00 C3 30 00 C8 30 00 18 33 00 04 0E AF 30 00 99 30 00 E9 30 00 E0 30 00 19 33 00 06 0E AF 30 00'\r\n '99 30 00 E9 30 00 E0 30 00 C8 30 00 F3 30 00 1A 33 00 06 0E AF 30 00 EB 30 00 BB 30 00 99 30 00'\r\n 'A4 30 00 ED 30 00 1B 33 00 04 0E AF 30 00 ED 30 00 FC 30 00 CD 30 00 1C 33 00 03 0E B1 30 00 FC'\r\n '30 00 B9 30 00 1D 33 00 03 0E B3 30 00 EB 30 00 CA 30 00 1E 33 00 04 0E B3 30 00 FC 30 00 DB 30'\r\n '00 9A 30 00 1F 33 00 04 0E B5 30 00 A4 30 00 AF 30 00 EB 30 00 20 33 00 05 0E B5 30 00 F3 30 00'\r\n 'C1 30 00 FC 30 00 E0 30 00 21 33 00 05 0E B7 30 00 EA 30 00 F3 30 00 AF 30 00 99 30 00 22 33 00'\r\n '03 0E BB 30 00 F3 30 00 C1 30 00 23 33 00 03 0E BB 30 00 F3 30 00 C8 30 00 24 33 00 04 0E BF 30'\r\n '00 99 30 00 FC 30 00 B9 30 00 25 33 00 03 0E C6 30 00 99 30 00 B7 30 00 26 33 00 03 0E C8 30 00'\r\n '99 30 00 EB 30 00 27 33 00 02 0E C8 30 00 F3 30 00 28 33 00 02 0E CA 30 00 CE 30 00 29 33 00 03'\r\n '0E CE 30 00 C3 30 00 C8 30 00 2A 33 00 03 0E CF 30 00 A4 30 00 C4 30 00 2B 33 00 06 0E CF 30 00'\r\n '9A 30 00 FC 30 00 BB 30 00 F3 30 00 C8 30 00 2C 33 00 04 0E CF 30 00 9A 30 00 FC 30 00 C4 30 00'\r\n '2D 33 00 05 0E CF 30 00 99 30 00 FC 30 00 EC 30 00 EB 30 00 2E 33 00 06 0E D2 30 00 9A 30 00 A2'\r\n '30 00 B9 30 00 C8 30 00 EB 30 00 2F 33 00 04 0E D2 30 00 9A 30 00 AF 30 00 EB 30 00 30 33 00 03'\r\n '0E D2 30 00 9A 30 00 B3 30 00 31 33 00 03 0E D2 30 00 99 30 00 EB 30 00 32 33 00 06 0E D5 30 00'\r\n 'A1 30 00 E9 30 00 C3 30 00 C8 30 00 99 30 00 33 33 00 04 0E D5 30 00 A3 30 00 FC 30 00 C8 30 00'\r\n '34 33 00 06 0E D5 30 00 99 30 00 C3 30 00 B7 30 00 A7 30 00 EB 30 00 35 33 00 03 0E D5 30 00 E9'\r\n '30 00 F3 30 00 36 33 00 05 0E D8 30 00 AF 30 00 BF 30 00 FC 30 00 EB 30 00 37 33 00 03 0E D8 30'\r\n '00 9A 30 00 BD 30 00 38 33 00 04 0E D8 30 00 9A 30 00 CB 30 00 D2 30 00 39 33 00 03 0E D8 30 00'\r\n 'EB 30 00 C4 30 00 3A 33 00 04 0E D8 30 00 9A 30 00 F3 30 00 B9 30 00 3B 33 00 07 0E D8 30 00 9A'\r\n '30 00 FC 30 00 D8 30 00 9A 30 00 B7 30 00 99 30 00 3C 33 00 04 0E D8 30 00 99 30 00 FC 30 00 BF'\r\n '30 00 3D 33 00 05 0E DB 30 00 9A 30 00 A4 30 00 F3 30 00 C8 30 00 3E 33 00 04 0E DB 30 00 99 30'\r\n '00 EB 30 00 C8 30 00 3F 33 00 02 0E DB 30 00 F3 30 00 40 33 00 07 0E DB 30 00 9A 30 00 F3 30 00'\r\n 'DB 30 00 9A 30 00 C8 30 00 99 30 00 41 33 00 03 0E DB 30 00 FC 30 00 EB 30 00 42 33 00 03 0E DB'\r\n '30 00 FC 30 00 F3 30 00 43 33 00 04 0E DE 30 00 A4 30 00 AF 30 00 ED 30 00 44 33 00 03 0E DE 30'\r\n '00 A4 30 00 EB 30 00 45 33 00 03 0E DE 30 00 C3 30 00 CF 30 00 46 33 00 03 0E DE 30 00 EB 30 00'\r\n 'AF 30 00 47 33 00 05 0E DE 30 00 F3 30 00 B7 30 00 E7 30 00 F3 30 00 48 33 00 04 0E DF 30 00 AF'\r\n '30 00 ED 30 00 F3 30 00 49 33 00 02 0E DF 30 00 EA 30 00 4A 33 00 06 0E DF 30 00 EA 30 00 CF 30'\r\n '00 99 30 00 FC 30 00 EB 30 00 4B 33 00 03 0E E1 30 00 AB 30 00 99 30 00 4C 33 00 05 0E E1 30 00'\r\n 'AB 30 00 99 30 00 C8 30 00 F3 30 00 4D 33 00 04 0E E1 30 00 FC 30 00 C8 30 00 EB 30 00 4E 33 00'\r\n '04 0E E4 30 00 FC 30 00 C8 30 00 99 30 00 4F 33 00 03 0E E4 30 00 FC 30 00 EB 30 00 50 33 00 03'\r\n '0E E6 30 00 A2 30 00 F3 30 00 51 33 00 04 0E EA 30 00 C3 30 00 C8 30 00 EB 30 00 52 33 00 02 0E'\r\n 'EA 30 00 E9 30 00 53 33 00 04 0E EB 30 00 D2 30 00 9A 30 00 FC 30 00 54 33 00 05 0E EB 30 00 FC'\r\n '30 00 D5 30 00 99 30 00 EB 30 00 55 33 00 02 0E EC 30 00 E0 30 00 56 33 00 06 0E EC 30 00 F3 30'\r\n '00 C8 30 00 B1 30 00 99 30 00 F3 30 00 57 33 00 03 0E EF 30 00 C3 30 00 C8 30 00 58 33 00 02 10'\r\n '30 00 00 B9 70 00 59 33 00 02 10 31 00 00 B9 70 00 5A 33 00 02 10 32 00 00 B9 70 00 5B 33 00 02'\r\n '10 33 00 00 B9 70 00 5C 33 00 02 10 34 00 00 B9 70 00 5D 33 00 02 10 35 00 00 B9 70 00 5E 33 00'\r\n '02 10 36 00 00 B9 70 00 5F 33 00 02 10 37 00 00 B9 70 00 60 33 00 02 10 38 00 00 B9 70 00 61 33'\r\n '00 02 10 39 00 00 B9 70 00 62 33 00 03 10 31 00 00 30 00 00 B9 70 00 63 33 00 03 10 31 00 00 31'\r\n '00 00 B9 70 00 64 33 00 03 10 31 00 00 32 00 00 B9 70 00 65 33 00 03 10 31 00 00 33 00 00 B9 70'\r\n '00 66 33 00 03 10 31 00 00 34 00 00 B9 70 00 67 33 00 03 10 31 00 00 35 00 00 B9 70 00 68 33 00'\r\n '03 10 31 00 00 36 00 00 B9 70 00 69 33 00 03 10 31 00 00 37 00 00 B9 70 00 6A 33 00 03 10 31 00'\r\n '00 38 00 00 B9 70 00 6B 33 00 03 10 31 00 00 39 00 00 B9 70 00 6C 33 00 03 10 32 00 00 30 00 00'\r\n 'B9 70 00 6D 33 00 03 10 32 00 00 31 00 00 B9 70 00 6E 33 00 03 10 32 00 00 32 00 00 B9 70 00 6F'\r\n '33 00 03 10 32 00 00 33 00 00 B9 70 00 70 33 00 03 10 32 00 00 34 00 00 B9 70 00 71 33 00 03 0E'\r\n '68 00 00 50 00 00 61 00 00 72 33 00 02 0E 64 00 00 61 00 00 73 33 00 02 0E 41 00 00 55 00 00 74'\r\n '33 00 03 0E 62 00 00 61 00 00 72 00 00 75 33 00 02 0E 6F 00 00 56 00 00 76 33 00 02 0E 70 00 00'\r\n '63 00 00 77 33 00 02 0E 64 00 00 6D 00 00 78 33 00 03 0E 64 00 00 6D 00 00 32 00 00 79 33 00 03'\r\n '0E 64 00 00 6D 00 00 33 00 00 7A 33 00 02 0E 49 00 00 55 00 00 7B 33 00 02 0E 73 5E 00 10 62 00'\r\n '7C 33 00 02 0E 2D 66 00 8C 54 00 7D 33 00 02 0E 27 59 00 63 6B 00 7E 33 00 02 0E 0E 66 00 BB 6C'\r\n '00 7F 33 00 04 0E 2A 68 00 0F 5F 00 1A 4F 00 3E 79 00 80 33 00 02 0E 70 00 00 41 00 00 81 33 00'\r\n '02 0E 6E 00 00 41 00 00 82 33 00 02 0E BC 03 00 41 00 00 83 33 00 02 0E 6D 00 00 41 00 00 84 33'\r\n '00 02 0E 6B 00 00 41 00 00 85 33 00 02 0E 4B 00 00 42 00 00 86 33 00 02 0E 4D 00 00 42 00 00 87'\r\n '33 00 02 0E 47 00 00 42 00 00 88 33 00 03 0E 63 00 00 61 00 00 6C 00 00 89 33 00 04 0E 6B 00 00'\r\n '63 00 00 61 00 00 6C 00 00 8A 33 00 02 0E 70 00 00 46 00 00 8B 33 00 02 0E 6E 00 00 46 00 00 8C'\r\n '33 00 02 0E BC 03 00 46 00 00 8D 33 00 02 0E BC 03 00 67 00 00 8E 33 00 02 0E 6D 00 00 67 00 00'\r\n '8F 33 00 02 0E 6B 00 00 67 00 00 90 33 00 02 0E 48 00 00 7A 00 00 91 33 00 03 0E 6B 00 00 48 00'\r\n '00 7A 00 00 92 33 00 03 0E 4D 00 00 48 00 00 7A 00 00 93 33 00 03 0E 47 00 00 48 00 00 7A 00 00'\r\n '94 33 00 03 0E 54 00 00 48 00 00 7A 00 00 95 33 00 02 0E BC 03 00 6C 00 00 96 33 00 02 0E 6D 00'\r\n '00 6C 00 00 97 33 00 02 0E 64 00 00 6C 00 00 98 33 00 02 0E 6B 00 00 6C 00 00 99 33 00 02 0E 66'\r\n '00 00 6D 00 00 9A 33 00 02 0E 6E 00 00 6D 00 00 9B 33 00 02 0E BC 03 00 6D 00 00 9C 33 00 02 0E'\r\n '6D 00 00 6D 00 00 9D 33 00 02 0E 63 00 00 6D 00 00 9E 33 00 02 0E 6B 00 00 6D 00 00 9F 33 00 03'\r\n '0E 6D 00 00 6D 00 00 32 00 00 A0 33 00 03 0E 63 00 00 6D 00 00 32 00 00 A1 33 00 02 0E 6D 00 00'\r\n '32 00 00 A2 33 00 03 0E 6B 00 00 6D 00 00 32 00 00 A3 33 00 03 0E 6D 00 00 6D 00 00 33 00 00 A4'\r\n '33 00 03 0E 63 00 00 6D 00 00 33 00 00 A5 33 00 02 0E 6D 00 00 33 00 00 A6 33 00 03 0E 6B 00 00'\r\n '6D 00 00 33 00 00 A7 33 00 03 0E 6D 00 00 15 22 00 73 00 00 A8 33 00 04 0E 6D 00 00 15 22 00 73'\r\n '00 00 32 00 00 A9 33 00 02 0E 50 00 00 61 00 00 AA 33 00 03 0E 6B 00 00 50 00 00 61 00 00 AB 33'\r\n '00 03 0E 4D 00 00 50 00 00 61 00 00 AC 33 00 03 0E 47 00 00 50 00 00 61 00 00 AD 33 00 03 0E 72'\r\n '00 00 61 00 00 64 00 00 AE 33 00 05 0E 72 00 00 61 00 00 64 00 00 15 22 00 73 00 00 AF 33 00 06'\r\n '0E 72 00 00 61 00 00 64 00 00 15 22 00 73 00 00 32 00 00 B0 33 00 02 0E 70 00 00 73 00 00 B1 33'\r\n '00 02 0E 6E 00 00 73 00 00 B2 33 00 02 0E BC 03 00 73 00 00 B3 33 00 02 0E 6D 00 00 73 00 00 B4'\r\n '33 00 02 0E 70 00 00 56 00 00 B5 33 00 02 0E 6E 00 00 56 00 00 B6 33 00 02 0E BC 03 00 56 00 00'\r\n 'B7 33 00 02 0E 6D 00 00 56 00 00 B8 33 00 02 0E 6B 00 00 56 00 00 B9 33 00 02 0E 4D 00 00 56 00'\r\n '00 BA 33 00 02 0E 70 00 00 57 00 00 BB 33 00 02 0E 6E 00 00 57 00 00 BC 33 00 02 0E BC 03 00 57'\r\n '00 00 BD 33 00 02 0E 6D 00 00 57 00 00 BE 33 00 02 0E 6B 00 00 57 00 00 BF 33 00 02 0E 4D 00 00'\r\n '57 00 00 C0 33 00 02 0E 6B 00 00 A9 03 00 C1 33 00 02 0E 4D 00 00 A9 03 00 C2 33 00 04 0E 61 00'\r\n '00 2E 00 00 6D 00 00 2E 00 00 C3 33 00 02 0E 42 00 00 71 00 00 C4 33 00 02 0E 63 00 00 63 00 00'\r\n 'C5 33 00 02 0E 63 00 00 64 00 00 C6 33 00 04 0E 43 00 00 15 22 00 6B 00 00 67 00 00 C7 33 00 03'\r\n '0E 43 00 00 6F 00 00 2E 00 00 C8 33 00 02 0E 64 00 00 42 00 00 C9 33 00 02 0E 47 00 00 79 00 00'\r\n 'CA 33 00 02 0E 68 00 00 61 00 00 CB 33 00 02 0E 48 00 00 50 00 00 CC 33 00 02 0E 69 00 00 6E 00'\r\n '00 CD 33 00 02 0E 4B 00 00 4B 00 00 CE 33 00 02 0E 4B 00 00 4D 00 00 CF 33 00 02 0E 6B 00 00 74'\r\n '00 00 D0 33 00 02 0E 6C 00 00 6D 00 00 D1 33 00 02 0E 6C 00 00 6E 00 00 D2 33 00 03 0E 6C 00 00'\r\n '6F 00 00 67 00 00 D3 33 00 02 0E 6C 00 00 78 00 00 D4 33 00 02 0E 6D 00 00 62 00 00 D5 33 00 03'\r\n '0E 6D 00 00 69 00 00 6C 00 00 D6 33 00 03 0E 6D 00 00 6F 00 00 6C 00 00 D7 33 00 02 0E 50 00 00'\r\n '48 00 00 D8 33 00 04 0E 70 00 00 2E 00 00 6D 00 00 2E 00 00 D9 33 00 03 0E 50 00 00 50 00 00 4D'\r\n '00 00 DA 33 00 02 0E 50 00 00 52 00 00 DB 33 00 02 0E 73 00 00 72 00 00 DC 33 00 02 0E 53 00 00'\r\n '76 00 00 DD 33 00 02 0E 57 00 00 62 00 00 DE 33 00 03 0E 56 00 00 15 22 00 6D 00 00 DF 33 00 03'\r\n '0E 41 00 00 15 22 00 6D 00 00 E0 33 00 02 10 31 00 00 E5 65 00 E1 33 00 02 10 32 00 00 E5 65 00'\r\n 'E2 33 00 02 10 33 00 00 E5 65 00 E3 33 00 02 10 34 00 00 E5 65 00 E4 33 00 02 10 35 00 00 E5 65'\r\n '00 E5 33 00 02 10 36 00 00 E5 65 00 E6 33 00 02 10 37 00 00 E5 65 00 E7 33 00 02 10 38 00 00 E5'\r\n '65 00 E8 33 00 02 10 39 00 00 E5 65 00 E9 33 00 03 10 31 00 00 30 00 00 E5 65 00 EA 33 00 03 10'\r\n '31 00 00 31 00 00 E5 65 00 EB 33 00 03 10 31 00 00 32 00 00 E5 65 00 EC 33 00 03 10 31 00 00 33'\r\n '00 00 E5 65 00 ED 33 00 03 10 31 00 00 34 00 00 E5 65 00 EE 33 00 03 10 31 00 00 35 00 00 E5 65'\r\n '00 EF 33 00 03 10 31 00 00 36 00 00 E5 65 00 F0 33 00 03 10 31 00 00 37 00 00 E5 65 00 F1 33 00'\r\n '03 10 31 00 00 38 00 00 E5 65 00 F2 33 00 03 10 31 00 00 39 00 00 E5 65 00 F3 33 00 03 10 32 00'\r\n '00 30 00 00 E5 65 00 F4 33 00 03 10 32 00 00 31 00 00 E5 65 00 F5 33 00 03 10 32 00 00 32 00 00'\r\n 'E5 65 00 F6 33 00 03 10 32 00 00 33 00 00 E5 65 00 F7 33 00 03 10 32 00 00 34 00 00 E5 65 00 F8'\r\n '33 00 03 10 32 00 00 35 00 00 E5 65 00 F9 33 00 03 10 32 00 00 36 00 00 E5 65 00 FA 33 00 03 10'\r\n '32 00 00 37 00 00 E5 65 00 FB 33 00 03 10 32 00 00 38 00 00 E5 65 00 FC 33 00 03 10 32 00 00 39'\r\n '00 00 E5 65 00 FD 33 00 03 10 33 00 00 30 00 00 E5 65 00 FE 33 00 03 10 33 00 00 31 00 00 E5 65'\r\n '00 FF 33 00 03 0E 67 00 00 61 00 00 6C 00 00 70 A7 00 01 08 6F A7 00 00 F9 00 01 00 48 8C 00 01'\r\n 'F9 00 01 00 F4 66 00 02 F9 00 01 00 CA 8E 00 03 F9 00 01 00 C8 8C 00 04 F9 00 01 00 D1 6E 00 05'\r\n 'F9 00 01 00 32 4E 00 06 F9 00 01 00 E5 53 00 07 F9 00 01 00 9C 9F 00 08 F9 00 01 00 9C 9F 00 09'\r\n 'F9 00 01 00 51 59 00 0A F9 00 01 00 D1 91 00 0B F9 00 01 00 87 55 00 0C F9 00 01 00 48 59 00 0D'\r\n 'F9 00 01 00 F6 61 00 0E F9 00 01 00 69 76 00 0F F9 00 01 00 85 7F 00 10 F9 00 01 00 3F 86 00 11'\r\n 'F9 00 01 00 BA 87 00 12 F9 00 01 00 F8 88 00 13 F9 00 01 00 8F 90 00 14 F9 00 01 00 02 6A 00 15'\r\n 'F9 00 01 00 1B 6D 00 16 F9 00 01 00 D9 70 00 17 F9 00 01 00 DE 73 00 18 F9 00 01 00 3D 84 00 19'\r\n 'F9 00 01 00 6A 91 00 1A F9 00 01 00 F1 99 00 1B F9 00 01 00 82 4E 00 1C F9 00 01 00 75 53 00 1D'\r\n 'F9 00 01 00 04 6B 00 1E F9 00 01 00 1B 72 00 1F F9 00 01 00 2D 86 00 20 F9 00 01 00 1E 9E 00 21'\r\n 'F9 00 01 00 50 5D 00 22 F9 00 01 00 EB 6F 00 23 F9 00 01 00 CD 85 00 24 F9 00 01 00 64 89 00 25'\r\n 'F9 00 01 00 C9 62 00 26 F9 00 01 00 D8 81 00 27 F9 00 01 00 1F 88 00 28 F9 00 01 00 CA 5E 00 29'\r\n 'F9 00 01 00 17 67 00 2A F9 00 01 00 6A 6D 00 2B F9 00 01 00 FC 72 00 2C F9 00 01 00 CE 90 00 2D'\r\n 'F9 00 01 00 86 4F 00 2E F9 00 01 00 B7 51 00 2F F9 00 01 00 DE 52 00 30 F9 00 01 00 C4 64 00 31'\r\n 'F9 00 01 00 D3 6A 00 32 F9 00 01 00 10 72 00 33 F9 00 01 00 E7 76 00 34 F9 00 01 00 01 80 00 35'\r\n 'F9 00 01 00 06 86 00 36 F9 00 01 00 5C 86 00 37 F9 00 01 00 EF 8D 00 38 F9 00 01 00 32 97 00 39'\r\n 'F9 00 01 00 6F 9B 00 3A F9 00 01 00 FA 9D 00 3B F9 00 01 00 8C 78 00 3C F9 00 01 00 7F 79 00 3D'\r\n 'F9 00 01 00 A0 7D 00 3E F9 00 01 00 C9 83 00 3F F9 00 01 00 04 93 00 40 F9 00 01 00 7F 9E 00 41'\r\n 'F9 00 01 00 D6 8A 00 42 F9 00 01 00 DF 58 00 43 F9 00 01 00 04 5F 00 44 F9 00 01 00 60 7C 00 45'\r\n 'F9 00 01 00 7E 80 00 46 F9 00 01 00 62 72 00 47 F9 00 01 00 CA 78 00 48 F9 00 01 00 C2 8C 00 49'\r\n 'F9 00 01 00 F7 96 00 4A F9 00 01 00 D8 58 00 4B F9 00 01 00 62 5C 00 4C F9 00 01 00 13 6A 00 4D'\r\n 'F9 00 01 00 DA 6D 00 4E F9 00 01 00 0F 6F 00 4F F9 00 01 00 2F 7D 00 50 F9 00 01 00 37 7E 00 51'\r\n 'F9 00 01 00 4B 96 00 52 F9 00 01 00 D2 52 00 53 F9 00 01 00 8B 80 00 54 F9 00 01 00 DC 51 00 55'\r\n 'F9 00 01 00 CC 51 00 56 F9 00 01 00 1C 7A 00 57 F9 00 01 00 BE 7D 00 58 F9 00 01 00 F1 83 00 59'\r\n 'F9 00 01 00 75 96 00 5A F9 00 01 00 80 8B 00 5B F9 00 01 00 CF 62 00 5C F9 00 01 00 02 6A 00 5D'\r\n 'F9 00 01 00 FE 8A 00 5E F9 00 01 00 39 4E 00 5F F9 00 01 00 E7 5B 00 60 F9 00 01 00 12 60 00 61'\r\n 'F9 00 01 00 87 73 00 62 F9 00 01 00 70 75 00 63 F9 00 01 00 17 53 00 64 F9 00 01 00 FB 78 00 65'\r\n 'F9 00 01 00 BF 4F 00 66 F9 00 01 00 A9 5F 00 67 F9 00 01 00 0D 4E 00 68 F9 00 01 00 CC 6C 00 69'\r\n 'F9 00 01 00 78 65 00 6A F9 00 01 00 22 7D 00 6B F9 00 01 00 C3 53 00 6C F9 00 01 00 5E 58 00 6D'\r\n 'F9 00 01 00 01 77 00 6E F9 00 01 00 49 84 00 6F F9 00 01 00 AA 8A 00 70 F9 00 01 00 BA 6B 00 71'\r\n 'F9 00 01 00 B0 8F 00 72 F9 00 01 00 88 6C 00 73 F9 00 01 00 FE 62 00 74 F9 00 01 00 E5 82 00 75'\r\n 'F9 00 01 00 A0 63 00 76 F9 00 01 00 65 75 00 77 F9 00 01 00 AE 4E 00 78 F9 00 01 00 69 51 00 79'\r\n 'F9 00 01 00 C9 51 00 7A F9 00 01 00 81 68 00 7B F9 00 01 00 E7 7C 00 7C F9 00 01 00 6F 82 00 7D'\r\n 'F9 00 01 00 D2 8A 00 7E F9 00 01 00 CF 91 00 7F F9 00 01 00 F5 52 00 80 F9 00 01 00 42 54 00 81'\r\n 'F9 00 01 00 73 59 00 82 F9 00 01 00 EC 5E 00 83 F9 00 01 00 C5 65 00 84 F9 00 01 00 FE 6F 00 85'\r\n 'F9 00 01 00 2A 79 00 86 F9 00 01 00 AD 95 00 87 F9 00 01 00 6A 9A 00 88 F9 00 01 00 97 9E 00 89'\r\n 'F9 00 01 00 CE 9E 00 8A F9 00 01 00 9B 52 00 8B F9 00 01 00 C6 66 00 8C F9 00 01 00 77 6B 00 8D'\r\n 'F9 00 01 00 62 8F 00 8E F9 00 01 00 74 5E 00 8F F9 00 01 00 90 61 00 90 F9 00 01 00 00 62 00 91'\r\n 'F9 00 01 00 9A 64 00 92 F9 00 01 00 23 6F 00 93 F9 00 01 00 49 71 00 94 F9 00 01 00 89 74 00 95'\r\n 'F9 00 01 00 CA 79 00 96 F9 00 01 00 F4 7D 00 97 F9 00 01 00 6F 80 00 98 F9 00 01 00 26 8F 00 99'\r\n 'F9 00 01 00 EE 84 00 9A F9 00 01 00 23 90 00 9B F9 00 01 00 4A 93 00 9C F9 00 01 00 17 52 00 9D'\r\n 'F9 00 01 00 A3 52 00 9E F9 00 01 00 BD 54 00 9F F9 00 01 00 C8 70 00 A0 F9 00 01 00 C2 88 00 A1'\r\n 'F9 00 01 00 AA 8A 00 A2 F9 00 01 00 C9 5E 00 A3 F9 00 01 00 F5 5F 00 A4 F9 00 01 00 7B 63 00 A5'\r\n 'F9 00 01 00 AE 6B 00 A6 F9 00 01 00 3E 7C 00 A7 F9 00 01 00 75 73 00 A8 F9 00 01 00 E4 4E 00 A9'\r\n 'F9 00 01 00 F9 56 00 AA F9 00 01 00 E7 5B 00 AB F9 00 01 00 BA 5D 00 AC F9 00 01 00 1C 60 00 AD'\r\n 'F9 00 01 00 B2 73 00 AE F9 00 01 00 69 74 00 AF F9 00 01 00 9A 7F 00 B0 F9 00 01 00 46 80 00 B1'\r\n 'F9 00 01 00 34 92 00 B2 F9 00 01 00 F6 96 00 B3 F9 00 01 00 48 97 00 B4 F9 00 01 00 18 98 00 B5'\r\n 'F9 00 01 00 8B 4F 00 B6 F9 00 01 00 AE 79 00 B7 F9 00 01 00 B4 91 00 B8 F9 00 01 00 B8 96 00 B9'\r\n 'F9 00 01 00 E1 60 00 BA F9 00 01 00 86 4E 00 BB F9 00 01 00 DA 50 00 BC F9 00 01 00 EE 5B 00 BD'\r\n 'F9 00 01 00 3F 5C 00 BE F9 00 01 00 99 65 00 BF F9 00 01 00 02 6A 00 C0 F9 00 01 00 CE 71 00 C1'\r\n 'F9 00 01 00 42 76 00 C2 F9 00 01 00 FC 84 00 C3 F9 00 01 00 7C 90 00 C4 F9 00 01 00 8D 9F 00 C5'\r\n 'F9 00 01 00 88 66 00 C6 F9 00 01 00 2E 96 00 C7 F9 00 01 00 89 52 00 C8 F9 00 01 00 7B 67 00 C9'\r\n 'F9 00 01 00 F3 67 00 CA F9 00 01 00 41 6D 00 CB F9 00 01 00 9C 6E 00 CC F9 00 01 00 09 74 00 CD'\r\n 'F9 00 01 00 59 75 00 CE F9 00 01 00 6B 78 00 CF F9 00 01 00 10 7D 00 D0 F9 00 01 00 5E 98 00 D1'\r\n 'F9 00 01 00 6D 51 00 D2 F9 00 01 00 2E 62 00 D3 F9 00 01 00 78 96 00 D4 F9 00 01 00 2B 50 00 D5'\r\n 'F9 00 01 00 19 5D 00 D6 F9 00 01 00 EA 6D 00 D7 F9 00 01 00 2A 8F 00 D8 F9 00 01 00 8B 5F 00 D9'\r\n 'F9 00 01 00 44 61 00 DA F9 00 01 00 17 68 00 DB F9 00 01 00 87 73 00 DC F9 00 01 00 86 96 00 DD'\r\n 'F9 00 01 00 29 52 00 DE F9 00 01 00 0F 54 00 DF F9 00 01 00 65 5C 00 E0 F9 00 01 00 13 66 00 E1'\r\n 'F9 00 01 00 4E 67 00 E2 F9 00 01 00 A8 68 00 E3 F9 00 01 00 E5 6C 00 E4 F9 00 01 00 06 74 00 E5'\r\n 'F9 00 01 00 E2 75 00 E6 F9 00 01 00 79 7F 00 E7 F9 00 01 00 CF 88 00 E8 F9 00 01 00 E1 88 00 E9'\r\n 'F9 00 01 00 CC 91 00 EA F9 00 01 00 E2 96 00 EB F9 00 01 00 3F 53 00 EC F9 00 01 00 BA 6E 00 ED'\r\n 'F9 00 01 00 1D 54 00 EE F9 00 01 00 D0 71 00 EF F9 00 01 00 98 74 00 F0 F9 00 01 00 FA 85 00 F1'\r\n 'F9 00 01 00 A3 96 00 F2 F9 00 01 00 57 9C 00 F3 F9 00 01 00 9F 9E 00 F4 F9 00 01 00 97 67 00 F5'\r\n 'F9 00 01 00 CB 6D 00 F6 F9 00 01 00 E8 81 00 F7 F9 00 01 00 CB 7A 00 F8 F9 00 01 00 20 7B 00 F9'\r\n 'F9 00 01 00 92 7C 00 FA F9 00 01 00 C0 72 00 FB F9 00 01 00 99 70 00 FC F9 00 01 00 58 8B 00 FD'\r\n 'F9 00 01 00 C0 4E 00 FE F9 00 01 00 36 83 00 FF F9 00 01 00 3A 52 00 00 FA 00 01 00 07 52 00 01'\r\n 'FA 00 01 00 A6 5E 00 02 FA 00 01 00 D3 62 00 03 FA 00 01 00 D6 7C 00 04 FA 00 01 00 85 5B 00 05'\r\n 'FA 00 01 00 1E 6D 00 06 FA 00 01 00 B4 66 00 07 FA 00 01 00 3B 8F 00 08 FA 00 01 00 4C 88 00 09'\r\n 'FA 00 01 00 4D 96 00 0A FA 00 01 00 8B 89 00 0B FA 00 01 00 D3 5E 00 0C FA 00 01 00 40 51 00 0D'\r\n 'FA 00 01 00 C0 55 00 10 FA 00 01 00 5A 58 00 12 FA 00 01 00 74 66 00 15 FA 00 01 00 DE 51 00 16'\r\n 'FA 00 01 00 2A 73 00 17 FA 00 01 00 CA 76 00 18 FA 00 01 00 3C 79 00 19 FA 00 01 00 5E 79 00 1A'\r\n 'FA 00 01 00 65 79 00 1B FA 00 01 00 8F 79 00 1C FA 00 01 00 56 97 00 1D FA 00 01 00 BE 7C 00 1E'\r\n 'FA 00 01 00 BD 7F 00 20 FA 00 01 00 12 86 00 22 FA 00 01 00 F8 8A 00 25 FA 00 01 00 38 90 00 26'\r\n 'FA 00 01 00 FD 90 00 2A FA 00 01 00 EF 98 00 2B FA 00 01 00 FC 98 00 2C FA 00 01 00 28 99 00 2D'\r\n 'FA 00 01 00 B4 9D 00 30 FA 00 01 00 AE 4F 00 31 FA 00 01 00 E7 50 00 32 FA 00 01 00 4D 51 00 33'\r\n 'FA 00 01 00 C9 52 00 34 FA 00 01 00 E4 52 00 35 FA 00 01 00 51 53 00 36 FA 00 01 00 9D 55 00 37'\r\n 'FA 00 01 00 06 56 00 38 FA 00 01 00 68 56 00 39 FA 00 01 00 40 58 00 3A FA 00 01 00 A8 58 00 3B'\r\n 'FA 00 01 00 64 5C 00 3C FA 00 01 00 6E 5C 00 3D FA 00 01 00 94 60 00 3E FA 00 01 00 68 61 00 3F'\r\n 'FA 00 01 00 8E 61 00 40 FA 00 01 00 F2 61 00 41 FA 00 01 00 4F 65 00 42 FA 00 01 00 E2 65 00 43'\r\n 'FA 00 01 00 91 66 00 44 FA 00 01 00 85 68 00 45 FA 00 01 00 77 6D 00 46 FA 00 01 00 1A 6E 00 47'\r\n 'FA 00 01 00 22 6F 00 48 FA 00 01 00 6E 71 00 49 FA 00 01 00 2B 72 00 4A FA 00 01 00 22 74 00 4B'\r\n 'FA 00 01 00 91 78 00 4C FA 00 01 00 3E 79 00 4D FA 00 01 00 49 79 00 4E FA 00 01 00 48 79 00 4F'\r\n 'FA 00 01 00 50 79 00 50 FA 00 01 00 56 79 00 51 FA 00 01 00 5D 79 00 52 FA 00 01 00 8D 79 00 53'\r\n 'FA 00 01 00 8E 79 00 54 FA 00 01 00 40 7A 00 55 FA 00 01 00 81 7A 00 56 FA 00 01 00 C0 7B 00 57'\r\n 'FA 00 01 00 F4 7D 00 58 FA 00 01 00 09 7E 00 59 FA 00 01 00 41 7E 00 5A FA 00 01 00 72 7F 00 5B'\r\n 'FA 00 01 00 05 80 00 5C FA 00 01 00 ED 81 00 5D FA 00 01 00 79 82 00 5E FA 00 01 00 79 82 00 5F'\r\n 'FA 00 01 00 57 84 00 60 FA 00 01 00 10 89 00 61 FA 00 01 00 96 89 00 62 FA 00 01 00 01 8B 00 63'\r\n 'FA 00 01 00 39 8B 00 64 FA 00 01 00 D3 8C 00 65 FA 00 01 00 08 8D 00 66 FA 00 01 00 B6 8F 00 67'\r\n 'FA 00 01 00 38 90 00 68 FA 00 01 00 E3 96 00 69 FA 00 01 00 FF 97 00 6A FA 00 01 00 3B 98 00 6B'\r\n 'FA 00 01 00 75 60 00 6C FA 00 01 00 EE 42 02 6D FA 00 01 00 18 82 00 70 FA 00 01 00 26 4E 00 71'\r\n 'FA 00 01 00 B5 51 00 72 FA 00 01 00 68 51 00 73 FA 00 01 00 80 4F 00 74 FA 00 01 00 45 51 00 75'\r\n 'FA 00 01 00 80 51 00 76 FA 00 01 00 C7 52 00 77 FA 00 01 00 FA 52 00 78 FA 00 01 00 9D 55 00 79'\r\n 'FA 00 01 00 55 55 00 7A FA 00 01 00 99 55 00 7B FA 00 01 00 E2 55 00 7C FA 00 01 00 5A 58 00 7D'\r\n 'FA 00 01 00 B3 58 00 7E FA 00 01 00 44 59 00 7F FA 00 01 00 54 59 00 80 FA 00 01 00 62 5A 00 81'\r\n 'FA 00 01 00 28 5B 00 82 FA 00 01 00 D2 5E 00 83 FA 00 01 00 D9 5E 00 84 FA 00 01 00 69 5F 00 85'\r\n 'FA 00 01 00 AD 5F 00 86 FA 00 01 00 D8 60 00 87 FA 00 01 00 4E 61 00 88 FA 00 01 00 08 61 00 89'\r\n 'FA 00 01 00 8E 61 00 8A FA 00 01 00 60 61 00 8B FA 00 01 00 F2 61 00 8C FA 00 01 00 34 62 00 8D'\r\n 'FA 00 01 00 C4 63 00 8E FA 00 01 00 1C 64 00 8F FA 00 01 00 52 64 00 90 FA 00 01 00 56 65 00 91'\r\n 'FA 00 01 00 74 66 00 92 FA 00 01 00 17 67 00 93 FA 00 01 00 1B 67 00 94 FA 00 01 00 56 67 00 95'\r\n 'FA 00 01 00 79 6B 00 96 FA 00 01 00 BA 6B 00 97 FA 00 01 00 41 6D 00 98 FA 00 01 00 DB 6E 00 99'\r\n 'FA 00 01 00 CB 6E 00 9A FA 00 01 00 22 6F 00 9B FA 00 01 00 1E 70 00 9C FA 00 01 00 6E 71 00 9D'\r\n 'FA 00 01 00 A7 77 00 9E FA 00 01 00 35 72 00 9F FA 00 01 00 AF 72 00 A0 FA 00 01 00 2A 73 00 A1'\r\n 'FA 00 01 00 71 74 00 A2 FA 00 01 00 06 75 00 A3 FA 00 01 00 3B 75 00 A4 FA 00 01 00 1D 76 00 A5'\r\n 'FA 00 01 00 1F 76 00 A6 FA 00 01 00 CA 76 00 A7 FA 00 01 00 DB 76 00 A8 FA 00 01 00 F4 76 00 A9'\r\n 'FA 00 01 00 4A 77 00 AA FA 00 01 00 40 77 00 AB FA 00 01 00 CC 78 00 AC FA 00 01 00 B1 7A 00 AD'\r\n 'FA 00 01 00 C0 7B 00 AE FA 00 01 00 7B 7C 00 AF FA 00 01 00 5B 7D 00 B0 FA 00 01 00 F4 7D 00 B1'\r\n 'FA 00 01 00 3E 7F 00 B2 FA 00 01 00 05 80 00 B3 FA 00 01 00 52 83 00 B4 FA 00 01 00 EF 83 00 B5'\r\n 'FA 00 01 00 79 87 00 B6 FA 00 01 00 41 89 00 B7 FA 00 01 00 86 89 00 B8 FA 00 01 00 96 89 00 B9'\r\n 'FA 00 01 00 BF 8A 00 BA FA 00 01 00 F8 8A 00 BB FA 00 01 00 CB 8A 00 BC FA 00 01 00 01 8B 00 BD'\r\n 'FA 00 01 00 FE 8A 00 BE FA 00 01 00 ED 8A 00 BF FA 00 01 00 39 8B 00 C0 FA 00 01 00 8A 8B 00 C1'\r\n 'FA 00 01 00 08 8D 00 C2 FA 00 01 00 38 8F 00 C3 FA 00 01 00 72 90 00 C4 FA 00 01 00 99 91 00 C5'\r\n 'FA 00 01 00 76 92 00 C6 FA 00 01 00 7C 96 00 C7 FA 00 01 00 E3 96 00 C8 FA 00 01 00 56 97 00 C9'\r\n 'FA 00 01 00 DB 97 00 CA FA 00 01 00 FF 97 00 CB FA 00 01 00 0B 98 00 CC FA 00 01 00 3B 98 00 CD'\r\n 'FA 00 01 00 12 9B 00 CE FA 00 01 00 9C 9F 00 CF FA 00 01 00 4A 28 02 D0 FA 00 01 00 44 28 02 D1'\r\n 'FA 00 01 00 D5 33 02 D2 FA 00 01 00 9D 3B 00 D3 FA 00 01 00 18 40 00 D4 FA 00 01 00 39 40 00 D5'\r\n 'FA 00 01 00 49 52 02 D6 FA 00 01 00 D0 5C 02 D7 FA 00 01 00 D3 7E 02 D8 FA 00 01 00 43 9F 00 D9'\r\n 'FA 00 01 00 8E 9F 00 00 FB 00 02 10 66 00 00 66 00 00 01 FB 00 02 10 66 00 00 69 00 00 02 FB 00'\r\n '02 10 66 00 00 6C 00 00 03 FB 00 03 10 66 00 00 66 00 00 69 00 00 04 FB 00 03 10 66 00 00 66 00'\r\n '00 6C 00 00 05 FB 00 02 10 73 00 00 74 00 00 06 FB 00 02 10 73 00 00 74 00 00 13 FB 00 02 10 74'\r\n '05 00 76 05 00 14 FB 00 02 10 74 05 00 65 05 00 15 FB 00 02 10 74 05 00 6B 05 00 16 FB 00 02 10'\r\n '7E 05 00 76 05 00 17 FB 00 02 10 74 05 00 6D 05 00 1D FB 00 02 00 D9 05 00 B4 05 00 1F FB 00 02'\r\n '00 F2 05 00 B7 05 00 20 FB 00 01 01 E2 05 00 21 FB 00 01 01 D0 05 00 22 FB 00 01 01 D3 05 00 23'\r\n 'FB 00 01 01 D4 05 00 24 FB 00 01 01 DB 05 00 25 FB 00 01 01 DC 05 00 26 FB 00 01 01 DD 05 00 27'\r\n 'FB 00 01 01 E8 05 00 28 FB 00 01 01 EA 05 00 29 FB 00 01 01 2B 00 00 2A FB 00 02 00 E9 05 00 C1'\r\n '05 00 2B FB 00 02 00 E9 05 00 C2 05 00 2C FB 00 03 00 E9 05 00 BC 05 00 C1 05 00 2D FB 00 03 00'\r\n 'E9 05 00 BC 05 00 C2 05 00 2E FB 00 02 00 D0 05 00 B7 05 00 2F FB 00 02 00 D0 05 00 B8 05 00 30'\r\n 'FB 00 02 00 D0 05 00 BC 05 00 31 FB 00 02 00 D1 05 00 BC 05 00 32 FB 00 02 00 D2 05 00 BC 05 00'\r\n '33 FB 00 02 00 D3 05 00 BC 05 00 34 FB 00 02 00 D4 05 00 BC 05 00 35 FB 00 02 00 D5 05 00 BC 05'\r\n '00 36 FB 00 02 00 D6 05 00 BC 05 00 38 FB 00 02 00 D8 05 00 BC 05 00 39 FB 00 02 00 D9 05 00 BC'\r\n '05 00 3A FB 00 02 00 DA 05 00 BC 05 00 3B FB 00 02 00 DB 05 00 BC 05 00 3C FB 00 02 00 DC 05 00'\r\n 'BC 05 00 3E FB 00 02 00 DE 05 00 BC 05 00 40 FB 00 02 00 E0 05 00 BC 05 00 41 FB 00 02 00 E1 05'\r\n '00 BC 05 00 43 FB 00 02 00 E3 05 00 BC 05 00 44 FB 00 02 00 E4 05 00 BC 05 00 46 FB 00 02 00 E6'\r\n '05 00 BC 05 00 47 FB 00 02 00 E7 05 00 BC 05 00 48 FB 00 02 00 E8 05 00 BC 05 00 49 FB 00 02 00'\r\n 'E9 05 00 BC 05 00 4A FB 00 02 00 EA 05 00 BC 05 00 4B FB 00 02 00 D5 05 00 B9 05 00 4C FB 00 02'\r\n '00 D1 05 00 BF 05 00 4D FB 00 02 00 DB 05 00 BF 05 00 4E FB 00 02 00 E4 05 00 BF 05 00 4F FB 00'\r\n '02 10 D0 05 00 DC 05 00 50 FB 00 01 06 71 06 00 51 FB 00 01 05 71 06 00 52 FB 00 01 06 7B 06 00'\r\n '53 FB 00 01 05 7B 06 00 54 FB 00 01 03 7B 06 00 55 FB 00 01 04 7B 06 00 56 FB 00 01 06 7E 06 00'\r\n '57 FB 00 01 05 7E 06 00 58 FB 00 01 03 7E 06 00 59 FB 00 01 04 7E 06 00 5A FB 00 01 06 80 06 00'\r\n '5B FB 00 01 05 80 06 00 5C FB 00 01 03 80 06 00 5D FB 00 01 04 80 06 00 5E FB 00 01 06 7A 06 00'\r\n '5F FB 00 01 05 7A 06 00 60 FB 00 01 03 7A 06 00 61 FB 00 01 04 7A 06 00 62 FB 00 01 06 7F 06 00'\r\n '63 FB 00 01 05 7F 06 00 64 FB 00 01 03 7F 06 00 65 FB 00 01 04 7F 06 00 66 FB 00 01 06 79 06 00'\r\n '67 FB 00 01 05 79 06 00 68 FB 00 01 03 79 06 00 69 FB 00 01 04 79 06 00 6A FB 00 01 06 A4 06 00'\r\n '6B FB 00 01 05 A4 06 00 6C FB 00 01 03 A4 06 00 6D FB 00 01 04 A4 06 00 6E FB 00 01 06 A6 06 00'\r\n '6F FB 00 01 05 A6 06 00 70 FB 00 01 03 A6 06 00 71 FB 00 01 04 A6 06 00 72 FB 00 01 06 84 06 00'\r\n '73 FB 00 01 05 84 06 00 74 FB 00 01 03 84 06 00 75 FB 00 01 04 84 06 00 76 FB 00 01 06 83 06 00'\r\n '77 FB 00 01 05 83 06 00 78 FB 00 01 03 83 06 00 79 FB 00 01 04 83 06 00 7A FB 00 01 06 86 06 00'\r\n '7B FB 00 01 05 86 06 00 7C FB 00 01 03 86 06 00 7D FB 00 01 04 86 06 00 7E FB 00 01 06 87 06 00'\r\n '7F FB 00 01 05 87 06 00 80 FB 00 01 03 87 06 00 81 FB 00 01 04 87 06 00 82 FB 00 01 06 8D 06 00'\r\n '83 FB 00 01 05 8D 06 00 84 FB 00 01 06 8C 06 00 85 FB 00 01 05 8C 06 00 86 FB 00 01 06 8E 06 00'\r\n '87 FB 00 01 05 8E 06 00 88 FB 00 01 06 88 06 00 89 FB 00 01 05 88 06 00 8A FB 00 01 06 98 06 00'\r\n '8B FB 00 01 05 98 06 00 8C FB 00 01 06 91 06 00 8D FB 00 01 05 91 06 00 8E FB 00 01 06 A9 06 00'\r\n '8F FB 00 01 05 A9 06 00 90 FB 00 01 03 A9 06 00 91 FB 00 01 04 A9 06 00 92 FB 00 01 06 AF 06 00'\r\n '93 FB 00 01 05 AF 06 00 94 FB 00 01 03 AF 06 00 95 FB 00 01 04 AF 06 00 96 FB 00 01 06 B3 06 00'\r\n '97 FB 00 01 05 B3 06 00 98 FB 00 01 03 B3 06 00 99 FB 00 01 04 B3 06 00 9A FB 00 01 06 B1 06 00'\r\n '9B FB 00 01 05 B1 06 00 9C FB 00 01 03 B1 06 00 9D FB 00 01 04 B1 06 00 9E FB 00 01 06 BA 06 00'\r\n '9F FB 00 01 05 BA 06 00 A0 FB 00 01 06 BB 06 00 A1 FB 00 01 05 BB 06 00 A2 FB 00 01 03 BB 06 00'\r\n 'A3 FB 00 01 04 BB 06 00 A4 FB 00 02 06 D5 06 00 54 06 00 A5 FB 00 02 05 D5 06 00 54 06 00 A6 FB'\r\n '00 01 06 C1 06 00 A7 FB 00 01 05 C1 06 00 A8 FB 00 01 03 C1 06 00 A9 FB 00 01 04 C1 06 00 AA FB'\r\n '00 01 06 BE 06 00 AB FB 00 01 05 BE 06 00 AC FB 00 01 03 BE 06 00 AD FB 00 01 04 BE 06 00 AE FB'\r\n '00 01 06 D2 06 00 AF FB 00 01 05 D2 06 00 B0 FB 00 02 06 D2 06 00 54 06 00 B1 FB 00 02 05 D2 06'\r\n '00 54 06 00 D3 FB 00 01 06 AD 06 00 D4 FB 00 01 05 AD 06 00 D5 FB 00 01 03 AD 06 00 D6 FB 00 01'\r\n '04 AD 06 00 D7 FB 00 01 06 C7 06 00 D8 FB 00 01 05 C7 06 00 D9 FB 00 01 06 C6 06 00 DA FB 00 01'\r\n '05 C6 06 00 DB FB 00 01 06 C8 06 00 DC FB 00 01 05 C8 06 00 DD FB 00 02 06 C7 06 00 74 06 00 DE'\r\n 'FB 00 01 06 CB 06 00 DF FB 00 01 05 CB 06 00 E0 FB 00 01 06 C5 06 00 E1 FB 00 01 05 C5 06 00 E2'\r\n 'FB 00 01 06 C9 06 00 E3 FB 00 01 05 C9 06 00 E4 FB 00 01 06 D0 06 00 E5 FB 00 01 05 D0 06 00 E6'\r\n 'FB 00 01 03 D0 06 00 E7 FB 00 01 04 D0 06 00 E8 FB 00 01 03 49 06 00 E9 FB 00 01 04 49 06 00 EA'\r\n 'FB 00 03 06 4A 06 00 54 06 00 27 06 00 EB FB 00 03 05 4A 06 00 54 06 00 27 06 00 EC FB 00 03 06'\r\n '4A 06 00 54 06 00 D5 06 00 ED FB 00 03 05 4A 06 00 54 06 00 D5 06 00 EE FB 00 03 06 4A 06 00 54'\r\n '06 00 48 06 00 EF FB 00 03 05 4A 06 00 54 06 00 48 06 00 F0 FB 00 03 06 4A 06 00 54 06 00 C7 06'\r\n '00 F1 FB 00 03 05 4A 06 00 54 06 00 C7 06 00 F2 FB 00 03 06 4A 06 00 54 06 00 C6 06 00 F3 FB 00'\r\n '03 05 4A 06 00 54 06 00 C6 06 00 F4 FB 00 03 06 4A 06 00 54 06 00 C8 06 00 F5 FB 00 03 05 4A 06'\r\n '00 54 06 00 C8 06 00 F6 FB 00 03 06 4A 06 00 54 06 00 D0 06 00 F7 FB 00 03 05 4A 06 00 54 06 00'\r\n 'D0 06 00 F8 FB 00 03 03 4A 06 00 54 06 00 D0 06 00 F9 FB 00 03 06 4A 06 00 54 06 00 49 06 00 FA'\r\n 'FB 00 03 05 4A 06 00 54 06 00 49 06 00 FB FB 00 03 03 4A 06 00 54 06 00 49 06 00 FC FB 00 01 06'\r\n 'CC 06 00 FD FB 00 01 05 CC 06 00 FE FB 00 01 03 CC 06 00 FF FB 00 01 04 CC 06 00 00 FC 00 03 06'\r\n '4A 06 00 54 06 00 2C 06 00 01 FC 00 03 06 4A 06 00 54 06 00 2D 06 00 02 FC 00 03 06 4A 06 00 54'\r\n '06 00 45 06 00 03 FC 00 03 06 4A 06 00 54 06 00 49 06 00 04 FC 00 03 06 4A 06 00 54 06 00 4A 06'\r\n '00 05 FC 00 02 06 28 06 00 2C 06 00 06 FC 00 02 06 28 06 00 2D 06 00 07 FC 00 02 06 28 06 00 2E'\r\n '06 00 08 FC 00 02 06 28 06 00 45 06 00 09 FC 00 02 06 28 06 00 49 06 00 0A FC 00 02 06 28 06 00'\r\n '4A 06 00 0B FC 00 02 06 2A 06 00 2C 06 00 0C FC 00 02 06 2A 06 00 2D 06 00 0D FC 00 02 06 2A 06'\r\n '00 2E 06 00 0E FC 00 02 06 2A 06 00 45 06 00 0F FC 00 02 06 2A 06 00 49 06 00 10 FC 00 02 06 2A'\r\n '06 00 4A 06 00 11 FC 00 02 06 2B 06 00 2C 06 00 12 FC 00 02 06 2B 06 00 45 06 00 13 FC 00 02 06'\r\n '2B 06 00 49 06 00 14 FC 00 02 06 2B 06 00 4A 06 00 15 FC 00 02 06 2C 06 00 2D 06 00 16 FC 00 02'\r\n '06 2C 06 00 45 06 00 17 FC 00 02 06 2D 06 00 2C 06 00 18 FC 00 02 06 2D 06 00 45 06 00 19 FC 00'\r\n '02 06 2E 06 00 2C 06 00 1A FC 00 02 06 2E 06 00 2D 06 00 1B FC 00 02 06 2E 06 00 45 06 00 1C FC'\r\n '00 02 06 33 06 00 2C 06 00 1D FC 00 02 06 33 06 00 2D 06 00 1E FC 00 02 06 33 06 00 2E 06 00 1F'\r\n 'FC 00 02 06 33 06 00 45 06 00 20 FC 00 02 06 35 06 00 2D 06 00 21 FC 00 02 06 35 06 00 45 06 00'\r\n '22 FC 00 02 06 36 06 00 2C 06 00 23 FC 00 02 06 36 06 00 2D 06 00 24 FC 00 02 06 36 06 00 2E 06'\r\n '00 25 FC 00 02 06 36 06 00 45 06 00 26 FC 00 02 06 37 06 00 2D 06 00 27 FC 00 02 06 37 06 00 45'\r\n '06 00 28 FC 00 02 06 38 06 00 45 06 00 29 FC 00 02 06 39 06 00 2C 06 00 2A FC 00 02 06 39 06 00'\r\n '45 06 00 2B FC 00 02 06 3A 06 00 2C 06 00 2C FC 00 02 06 3A 06 00 45 06 00 2D FC 00 02 06 41 06'\r\n '00 2C 06 00 2E FC 00 02 06 41 06 00 2D 06 00 2F FC 00 02 06 41 06 00 2E 06 00 30 FC 00 02 06 41'\r\n '06 00 45 06 00 31 FC 00 02 06 41 06 00 49 06 00 32 FC 00 02 06 41 06 00 4A 06 00 33 FC 00 02 06'\r\n '42 06 00 2D 06 00 34 FC 00 02 06 42 06 00 45 06 00 35 FC 00 02 06 42 06 00 49 06 00 36 FC 00 02'\r\n '06 42 06 00 4A 06 00 37 FC 00 02 06 43 06 00 27 06 00 38 FC 00 02 06 43 06 00 2C 06 00 39 FC 00'\r\n '02 06 43 06 00 2D 06 00 3A FC 00 02 06 43 06 00 2E 06 00 3B FC 00 02 06 43 06 00 44 06 00 3C FC'\r\n '00 02 06 43 06 00 45 06 00 3D FC 00 02 06 43 06 00 49 06 00 3E FC 00 02 06 43 06 00 4A 06 00 3F'\r\n 'FC 00 02 06 44 06 00 2C 06 00 40 FC 00 02 06 44 06 00 2D 06 00 41 FC 00 02 06 44 06 00 2E 06 00'\r\n '42 FC 00 02 06 44 06 00 45 06 00 43 FC 00 02 06 44 06 00 49 06 00 44 FC 00 02 06 44 06 00 4A 06'\r\n '00 45 FC 00 02 06 45 06 00 2C 06 00 46 FC 00 02 06 45 06 00 2D 06 00 47 FC 00 02 06 45 06 00 2E'\r\n '06 00 48 FC 00 02 06 45 06 00 45 06 00 49 FC 00 02 06 45 06 00 49 06 00 4A FC 00 02 06 45 06 00'\r\n '4A 06 00 4B FC 00 02 06 46 06 00 2C 06 00 4C FC 00 02 06 46 06 00 2D 06 00 4D FC 00 02 06 46 06'\r\n '00 2E 06 00 4E FC 00 02 06 46 06 00 45 06 00 4F FC 00 02 06 46 06 00 49 06 00 50 FC 00 02 06 46'\r\n '06 00 4A 06 00 51 FC 00 02 06 47 06 00 2C 06 00 52 FC 00 02 06 47 06 00 45 06 00 53 FC 00 02 06'\r\n '47 06 00 49 06 00 54 FC 00 02 06 47 06 00 4A 06 00 55 FC 00 02 06 4A 06 00 2C 06 00 56 FC 00 02'\r\n '06 4A 06 00 2D 06 00 57 FC 00 02 06 4A 06 00 2E 06 00 58 FC 00 02 06 4A 06 00 45 06 00 59 FC 00'\r\n '02 06 4A 06 00 49 06 00 5A FC 00 02 06 4A 06 00 4A 06 00 5B FC 00 02 06 30 06 00 70 06 00 5C FC'\r\n '00 02 06 31 06 00 70 06 00 5D FC 00 02 06 49 06 00 70 06 00 5E FC 00 03 06 20 00 00 4C 06 00 51'\r\n '06 00 5F FC 00 03 06 20 00 00 4D 06 00 51 06 00 60 FC 00 03 06 20 00 00 4E 06 00 51 06 00 61 FC'\r\n '00 03 06 20 00 00 4F 06 00 51 06 00 62 FC 00 03 06 20 00 00 50 06 00 51 06 00 63 FC 00 03 06 20'\r\n '00 00 51 06 00 70 06 00 64 FC 00 03 05 4A 06 00 54 06 00 31 06 00 65 FC 00 03 05 4A 06 00 54 06'\r\n '00 32 06 00 66 FC 00 03 05 4A 06 00 54 06 00 45 06 00 67 FC 00 03 05 4A 06 00 54 06 00 46 06 00'\r\n '68 FC 00 03 05 4A 06 00 54 06 00 49 06 00 69 FC 00 03 05 4A 06 00 54 06 00 4A 06 00 6A FC 00 02'\r\n '05 28 06 00 31 06 00 6B FC 00 02 05 28 06 00 32 06 00 6C FC 00 02 05 28 06 00 45 06 00 6D FC 00'\r\n '02 05 28 06 00 46 06 00 6E FC 00 02 05 28 06 00 49 06 00 6F FC 00 02 05 28 06 00 4A 06 00 70 FC'\r\n '00 02 05 2A 06 00 31 06 00 71 FC 00 02 05 2A 06 00 32 06 00 72 FC 00 02 05 2A 06 00 45 06 00 73'\r\n 'FC 00 02 05 2A 06 00 46 06 00 74 FC 00 02 05 2A 06 00 49 06 00 75 FC 00 02 05 2A 06 00 4A 06 00'\r\n '76 FC 00 02 05 2B 06 00 31 06 00 77 FC 00 02 05 2B 06 00 32 06 00 78 FC 00 02 05 2B 06 00 45 06'\r\n '00 79 FC 00 02 05 2B 06 00 46 06 00 7A FC 00 02 05 2B 06 00 49 06 00 7B FC 00 02 05 2B 06 00 4A'\r\n '06 00 7C FC 00 02 05 41 06 00 49 06 00 7D FC 00 02 05 41 06 00 4A 06 00 7E FC 00 02 05 42 06 00'\r\n '49 06 00 7F FC 00 02 05 42 06 00 4A 06 00 80 FC 00 02 05 43 06 00 27 06 00 81 FC 00 02 05 43 06'\r\n '00 44 06 00 82 FC 00 02 05 43 06 00 45 06 00 83 FC 00 02 05 43 06 00 49 06 00 84 FC 00 02 05 43'\r\n '06 00 4A 06 00 85 FC 00 02 05 44 06 00 45 06 00 86 FC 00 02 05 44 06 00 49 06 00 87 FC 00 02 05'\r\n '44 06 00 4A 06 00 88 FC 00 02 05 45 06 00 27 06 00 89 FC 00 02 05 45 06 00 45 06 00 8A FC 00 02'\r\n '05 46 06 00 31 06 00 8B FC 00 02 05 46 06 00 32 06 00 8C FC 00 02 05 46 06 00 45 06 00 8D FC 00'\r\n '02 05 46 06 00 46 06 00 8E FC 00 02 05 46 06 00 49 06 00 8F FC 00 02 05 46 06 00 4A 06 00 90 FC'\r\n '00 02 05 49 06 00 70 06 00 91 FC 00 02 05 4A 06 00 31 06 00 92 FC 00 02 05 4A 06 00 32 06 00 93'\r\n 'FC 00 02 05 4A 06 00 45 06 00 94 FC 00 02 05 4A 06 00 46 06 00 95 FC 00 02 05 4A 06 00 49 06 00'\r\n '96 FC 00 02 05 4A 06 00 4A 06 00 97 FC 00 03 03 4A 06 00 54 06 00 2C 06 00 98 FC 00 03 03 4A 06'\r\n '00 54 06 00 2D 06 00 99 FC 00 03 03 4A 06 00 54 06 00 2E 06 00 9A FC 00 03 03 4A 06 00 54 06 00'\r\n '45 06 00 9B FC 00 03 03 4A 06 00 54 06 00 47 06 00 9C FC 00 02 03 28 06 00 2C 06 00 9D FC 00 02'\r\n '03 28 06 00 2D 06 00 9E FC 00 02 03 28 06 00 2E 06 00 9F FC 00 02 03 28 06 00 45 06 00 A0 FC 00'\r\n '02 03 28 06 00 47 06 00 A1 FC 00 02 03 2A 06 00 2C 06 00 A2 FC 00 02 03 2A 06 00 2D 06 00 A3 FC'\r\n '00 02 03 2A 06 00 2E 06 00 A4 FC 00 02 03 2A 06 00 45 06 00 A5 FC 00 02 03 2A 06 00 47 06 00 A6'\r\n 'FC 00 02 03 2B 06 00 45 06 00 A7 FC 00 02 03 2C 06 00 2D 06 00 A8 FC 00 02 03 2C 06 00 45 06 00'\r\n 'A9 FC 00 02 03 2D 06 00 2C 06 00 AA FC 00 02 03 2D 06 00 45 06 00 AB FC 00 02 03 2E 06 00 2C 06'\r\n '00 AC FC 00 02 03 2E 06 00 45 06 00 AD FC 00 02 03 33 06 00 2C 06 00 AE FC 00 02 03 33 06 00 2D'\r\n '06 00 AF FC 00 02 03 33 06 00 2E 06 00 B0 FC 00 02 03 33 06 00 45 06 00 B1 FC 00 02 03 35 06 00'\r\n '2D 06 00 B2 FC 00 02 03 35 06 00 2E 06 00 B3 FC 00 02 03 35 06 00 45 06 00 B4 FC 00 02 03 36 06'\r\n '00 2C 06 00 B5 FC 00 02 03 36 06 00 2D 06 00 B6 FC 00 02 03 36 06 00 2E 06 00 B7 FC 00 02 03 36'\r\n '06 00 45 06 00 B8 FC 00 02 03 37 06 00 2D 06 00 B9 FC 00 02 03 38 06 00 45 06 00 BA FC 00 02 03'\r\n '39 06 00 2C 06 00 BB FC 00 02 03 39 06 00 45 06 00 BC FC 00 02 03 3A 06 00 2C 06 00 BD FC 00 02'\r\n '03 3A 06 00 45 06 00 BE FC 00 02 03 41 06 00 2C 06 00 BF FC 00 02 03 41 06 00 2D 06 00 C0 FC 00'\r\n '02 03 41 06 00 2E 06 00 C1 FC 00 02 03 41 06 00 45 06 00 C2 FC 00 02 03 42 06 00 2D 06 00 C3 FC'\r\n '00 02 03 42 06 00 45 06 00 C4 FC 00 02 03 43 06 00 2C 06 00 C5 FC 00 02 03 43 06 00 2D 06 00 C6'\r\n 'FC 00 02 03 43 06 00 2E 06 00 C7 FC 00 02 03 43 06 00 44 06 00 C8 FC 00 02 03 43 06 00 45 06 00'\r\n 'C9 FC 00 02 03 44 06 00 2C 06 00 CA FC 00 02 03 44 06 00 2D 06 00 CB FC 00 02 03 44 06 00 2E 06'\r\n '00 CC FC 00 02 03 44 06 00 45 06 00 CD FC 00 02 03 44 06 00 47 06 00 CE FC 00 02 03 45 06 00 2C'\r\n '06 00 CF FC 00 02 03 45 06 00 2D 06 00 D0 FC 00 02 03 45 06 00 2E 06 00 D1 FC 00 02 03 45 06 00'\r\n '45 06 00 D2 FC 00 02 03 46 06 00 2C 06 00 D3 FC 00 02 03 46 06 00 2D 06 00 D4 FC 00 02 03 46 06'\r\n '00 2E 06 00 D5 FC 00 02 03 46 06 00 45 06 00 D6 FC 00 02 03 46 06 00 47 06 00 D7 FC 00 02 03 47'\r\n '06 00 2C 06 00 D8 FC 00 02 03 47 06 00 45 06 00 D9 FC 00 02 03 47 06 00 70 06 00 DA FC 00 02 03'\r\n '4A 06 00 2C 06 00 DB FC 00 02 03 4A 06 00 2D 06 00 DC FC 00 02 03 4A 06 00 2E 06 00 DD FC 00 02'\r\n '03 4A 06 00 45 06 00 DE FC 00 02 03 4A 06 00 47 06 00 DF FC 00 03 04 4A 06 00 54 06 00 45 06 00'\r\n 'E0 FC 00 03 04 4A 06 00 54 06 00 47 06 00 E1 FC 00 02 04 28 06 00 45 06 00 E2 FC 00 02 04 28 06'\r\n '00 47 06 00 E3 FC 00 02 04 2A 06 00 45 06 00 E4 FC 00 02 04 2A 06 00 47 06 00 E5 FC 00 02 04 2B'\r\n '06 00 45 06 00 E6 FC 00 02 04 2B 06 00 47 06 00 E7 FC 00 02 04 33 06 00 45 06 00 E8 FC 00 02 04'\r\n '33 06 00 47 06 00 E9 FC 00 02 04 34 06 00 45 06 00 EA FC 00 02 04 34 06 00 47 06 00 EB FC 00 02'\r\n '04 43 06 00 44 06 00 EC FC 00 02 04 43 06 00 45 06 00 ED FC 00 02 04 44 06 00 45 06 00 EE FC 00'\r\n '02 04 46 06 00 45 06 00 EF FC 00 02 04 46 06 00 47 06 00 F0 FC 00 02 04 4A 06 00 45 06 00 F1 FC'\r\n '00 02 04 4A 06 00 47 06 00 F2 FC 00 03 04 40 06 00 4E 06 00 51 06 00 F3 FC 00 03 04 40 06 00 4F'\r\n '06 00 51 06 00 F4 FC 00 03 04 40 06 00 50 06 00 51 06 00 F5 FC 00 02 06 37 06 00 49 06 00 F6 FC'\r\n '00 02 06 37 06 00 4A 06 00 F7 FC 00 02 06 39 06 00 49 06 00 F8 FC 00 02 06 39 06 00 4A 06 00 F9'\r\n 'FC 00 02 06 3A 06 00 49 06 00 FA FC 00 02 06 3A 06 00 4A 06 00 FB FC 00 02 06 33 06 00 49 06 00'\r\n 'FC FC 00 02 06 33 06 00 4A 06 00 FD FC 00 02 06 34 06 00 49 06 00 FE FC 00 02 06 34 06 00 4A 06'\r\n '00 FF FC 00 02 06 2D 06 00 49 06 00 00 FD 00 02 06 2D 06 00 4A 06 00 01 FD 00 02 06 2C 06 00 49'\r\n '06 00 02 FD 00 02 06 2C 06 00 4A 06 00 03 FD 00 02 06 2E 06 00 49 06 00 04 FD 00 02 06 2E 06 00'\r\n '4A 06 00 05 FD 00 02 06 35 06 00 49 06 00 06 FD 00 02 06 35 06 00 4A 06 00 07 FD 00 02 06 36 06'\r\n '00 49 06 00 08 FD 00 02 06 36 06 00 4A 06 00 09 FD 00 02 06 34 06 00 2C 06 00 0A FD 00 02 06 34'\r\n '06 00 2D 06 00 0B FD 00 02 06 34 06 00 2E 06 00 0C FD 00 02 06 34 06 00 45 06 00 0D FD 00 02 06'\r\n '34 06 00 31 06 00 0E FD 00 02 06 33 06 00 31 06 00 0F FD 00 02 06 35 06 00 31 06 00 10 FD 00 02'\r\n '06 36 06 00 31 06 00 11 FD 00 02 05 37 06 00 49 06 00 12 FD 00 02 05 37 06 00 4A 06 00 13 FD 00'\r\n '02 05 39 06 00 49 06 00 14 FD 00 02 05 39 06 00 4A 06 00 15 FD 00 02 05 3A 06 00 49 06 00 16 FD'\r\n '00 02 05 3A 06 00 4A 06 00 17 FD 00 02 05 33 06 00 49 06 00 18 FD 00 02 05 33 06 00 4A 06 00 19'\r\n 'FD 00 02 05 34 06 00 49 06 00 1A FD 00 02 05 34 06 00 4A 06 00 1B FD 00 02 05 2D 06 00 49 06 00'\r\n '1C FD 00 02 05 2D 06 00 4A 06 00 1D FD 00 02 05 2C 06 00 49 06 00 1E FD 00 02 05 2C 06 00 4A 06'\r\n '00 1F FD 00 02 05 2E 06 00 49 06 00 20 FD 00 02 05 2E 06 00 4A 06 00 21 FD 00 02 05 35 06 00 49'\r\n '06 00 22 FD 00 02 05 35 06 00 4A 06 00 23 FD 00 02 05 36 06 00 49 06 00 24 FD 00 02 05 36 06 00'\r\n '4A 06 00 25 FD 00 02 05 34 06 00 2C 06 00 26 FD 00 02 05 34 06 00 2D 06 00 27 FD 00 02 05 34 06'\r\n '00 2E 06 00 28 FD 00 02 05 34 06 00 45 06 00 29 FD 00 02 05 34 06 00 31 06 00 2A FD 00 02 05 33'\r\n '06 00 31 06 00 2B FD 00 02 05 35 06 00 31 06 00 2C FD 00 02 05 36 06 00 31 06 00 2D FD 00 02 03'\r\n '34 06 00 2C 06 00 2E FD 00 02 03 34 06 00 2D 06 00 2F FD 00 02 03 34 06 00 2E 06 00 30 FD 00 02'\r\n '03 34 06 00 45 06 00 31 FD 00 02 03 33 06 00 47 06 00 32 FD 00 02 03 34 06 00 47 06 00 33 FD 00'\r\n '02 03 37 06 00 45 06 00 34 FD 00 02 04 33 06 00 2C 06 00 35 FD 00 02 04 33 06 00 2D 06 00 36 FD'\r\n '00 02 04 33 06 00 2E 06 00 37 FD 00 02 04 34 06 00 2C 06 00 38 FD 00 02 04 34 06 00 2D 06 00 39'\r\n 'FD 00 02 04 34 06 00 2E 06 00 3A FD 00 02 04 37 06 00 45 06 00 3B FD 00 02 04 38 06 00 45 06 00'\r\n '3C FD 00 02 05 27 06 00 4B 06 00 3D FD 00 02 06 27 06 00 4B 06 00 50 FD 00 03 03 2A 06 00 2C 06'\r\n '00 45 06 00 51 FD 00 03 05 2A 06 00 2D 06 00 2C 06 00 52 FD 00 03 03 2A 06 00 2D 06 00 2C 06 00'\r\n '53 FD 00 03 03 2A 06 00 2D 06 00 45 06 00 54 FD 00 03 03 2A 06 00 2E 06 00 45 06 00 55 FD 00 03'\r\n '03 2A 06 00 45 06 00 2C 06 00 56 FD 00 03 03 2A 06 00 45 06 00 2D 06 00 57 FD 00 03 03 2A 06 00'\r\n '45 06 00 2E 06 00 58 FD 00 03 05 2C 06 00 45 06 00 2D 06 00 59 FD 00 03 03 2C 06 00 45 06 00 2D'\r\n '06 00 5A FD 00 03 05 2D 06 00 45 06 00 4A 06 00 5B FD 00 03 05 2D 06 00 45 06 00 49 06 00 5C FD'\r\n '00 03 03 33 06 00 2D 06 00 2C 06 00 5D FD 00 03 03 33 06 00 2C 06 00 2D 06 00 5E FD 00 03 05 33'\r\n '06 00 2C 06 00 49 06 00 5F FD 00 03 05 33 06 00 45 06 00 2D 06 00 60 FD 00 03 03 33 06 00 45 06'\r\n '00 2D 06 00 61 FD 00 03 03 33 06 00 45 06 00 2C 06 00 62 FD 00 03 05 33 06 00 45 06 00 45 06 00'\r\n '63 FD 00 03 03 33 06 00 45 06 00 45 06 00 64 FD 00 03 05 35 06 00 2D 06 00 2D 06 00 65 FD 00 03'\r\n '03 35 06 00 2D 06 00 2D 06 00 66 FD 00 03 05 35 06 00 45 06 00 45 06 00 67 FD 00 03 05 34 06 00'\r\n '2D 06 00 45 06 00 68 FD 00 03 03 34 06 00 2D 06 00 45 06 00 69 FD 00 03 05 34 06 00 2C 06 00 4A'\r\n '06 00 6A FD 00 03 05 34 06 00 45 06 00 2E 06 00 6B FD 00 03 03 34 06 00 45 06 00 2E 06 00 6C FD'\r\n '00 03 05 34 06 00 45 06 00 45 06 00 6D FD 00 03 03 34 06 00 45 06 00 45 06 00 6E FD 00 03 05 36'\r\n '06 00 2D 06 00 49 06 00 6F FD 00 03 05 36 06 00 2E 06 00 45 06 00 70 FD 00 03 03 36 06 00 2E 06'\r\n '00 45 06 00 71 FD 00 03 05 37 06 00 45 06 00 2D 06 00 72 FD 00 03 03 37 06 00 45 06 00 2D 06 00'\r\n '73 FD 00 03 03 37 06 00 45 06 00 45 06 00 74 FD 00 03 05 37 06 00 45 06 00 4A 06 00 75 FD 00 03'\r\n '05 39 06 00 2C 06 00 45 06 00 76 FD 00 03 05 39 06 00 45 06 00 45 06 00 77 FD 00 03 03 39 06 00'\r\n '45 06 00 45 06 00 78 FD 00 03 05 39 06 00 45 06 00 49 06 00 79 FD 00 03 05 3A 06 00 45 06 00 45'\r\n '06 00 7A FD 00 03 05 3A 06 00 45 06 00 4A 06 00 7B FD 00 03 05 3A 06 00 45 06 00 49 06 00 7C FD'\r\n '00 03 05 41 06 00 2E 06 00 45 06 00 7D FD 00 03 03 41 06 00 2E 06 00 45 06 00 7E FD 00 03 05 42'\r\n '06 00 45 06 00 2D 06 00 7F FD 00 03 05 42 06 00 45 06 00 45 06 00 80 FD 00 03 05 44 06 00 2D 06'\r\n '00 45 06 00 81 FD 00 03 05 44 06 00 2D 06 00 4A 06 00 82 FD 00 03 05 44 06 00 2D 06 00 49 06 00'\r\n '83 FD 00 03 03 44 06 00 2C 06 00 2C 06 00 84 FD 00 03 05 44 06 00 2C 06 00 2C 06 00 85 FD 00 03'\r\n '05 44 06 00 2E 06 00 45 06 00 86 FD 00 03 03 44 06 00 2E 06 00 45 06 00 87 FD 00 03 05 44 06 00'\r\n '45 06 00 2D 06 00 88 FD 00 03 03 44 06 00 45 06 00 2D 06 00 89 FD 00 03 03 45 06 00 2D 06 00 2C'\r\n '06 00 8A FD 00 03 03 45 06 00 2D 06 00 45 06 00 8B FD 00 03 05 45 06 00 2D 06 00 4A 06 00 8C FD'\r\n '00 03 03 45 06 00 2C 06 00 2D 06 00 8D FD 00 03 03 45 06 00 2C 06 00 45 06 00 8E FD 00 03 03 45'\r\n '06 00 2E 06 00 2C 06 00 8F FD 00 03 03 45 06 00 2E 06 00 45 06 00 92 FD 00 03 03 45 06 00 2C 06'\r\n '00 2E 06 00 93 FD 00 03 03 47 06 00 45 06 00 2C 06 00 94 FD 00 03 03 47 06 00 45 06 00 45 06 00'\r\n '95 FD 00 03 03 46 06 00 2D 06 00 45 06 00 96 FD 00 03 05 46 06 00 2D 06 00 49 06 00 97 FD 00 03'\r\n '05 46 06 00 2C 06 00 45 06 00 98 FD 00 03 03 46 06 00 2C 06 00 45 06 00 99 FD 00 03 05 46 06 00'\r\n '2C 06 00 49 06 00 9A FD 00 03 05 46 06 00 45 06 00 4A 06 00 9B FD 00 03 05 46 06 00 45 06 00 49'\r\n '06 00 9C FD 00 03 05 4A 06 00 45 06 00 45 06 00 9D FD 00 03 03 4A 06 00 45 06 00 45 06 00 9E FD'\r\n '00 03 05 28 06 00 2E 06 00 4A 06 00 9F FD 00 03 05 2A 06 00 2C 06 00 4A 06 00 A0 FD 00 03 05 2A'\r\n '06 00 2C 06 00 49 06 00 A1 FD 00 03 05 2A 06 00 2E 06 00 4A 06 00 A2 FD 00 03 05 2A 06 00 2E 06'\r\n '00 49 06 00 A3 FD 00 03 05 2A 06 00 45 06 00 4A 06 00 A4 FD 00 03 05 2A 06 00 45 06 00 49 06 00'\r\n 'A5 FD 00 03 05 2C 06 00 45 06 00 4A 06 00 A6 FD 00 03 05 2C 06 00 2D 06 00 49 06 00 A7 FD 00 03'\r\n '05 2C 06 00 45 06 00 49 06 00 A8 FD 00 03 05 33 06 00 2E 06 00 49 06 00 A9 FD 00 03 05 35 06 00'\r\n '2D 06 00 4A 06 00 AA FD 00 03 05 34 06 00 2D 06 00 4A 06 00 AB FD 00 03 05 36 06 00 2D 06 00 4A'\r\n '06 00 AC FD 00 03 05 44 06 00 2C 06 00 4A 06 00 AD FD 00 03 05 44 06 00 45 06 00 4A 06 00 AE FD'\r\n '00 03 05 4A 06 00 2D 06 00 4A 06 00 AF FD 00 03 05 4A 06 00 2C 06 00 4A 06 00 B0 FD 00 03 05 4A'\r\n '06 00 45 06 00 4A 06 00 B1 FD 00 03 05 45 06 00 45 06 00 4A 06 00 B2 FD 00 03 05 42 06 00 45 06'\r\n '00 4A 06 00 B3 FD 00 03 05 46 06 00 2D 06 00 4A 06 00 B4 FD 00 03 03 42 06 00 45 06 00 2D 06 00'\r\n 'B5 FD 00 03 03 44 06 00 2D 06 00 45 06 00 B6 FD 00 03 05 39 06 00 45 06 00 4A 06 00 B7 FD 00 03'\r\n '05 43 06 00 45 06 00 4A 06 00 B8 FD 00 03 03 46 06 00 2C 06 00 2D 06 00 B9 FD 00 03 05 45 06 00'\r\n '2E 06 00 4A 06 00 BA FD 00 03 03 44 06 00 2C 06 00 45 06 00 BB FD 00 03 05 43 06 00 45 06 00 45'\r\n '06 00 BC FD 00 03 05 44 06 00 2C 06 00 45 06 00 BD FD 00 03 05 46 06 00 2C 06 00 2D 06 00 BE FD'\r\n '00 03 05 2C 06 00 2D 06 00 4A 06 00 BF FD 00 03 05 2D 06 00 2C 06 00 4A 06 00 C0 FD 00 03 05 45'\r\n '06 00 2C 06 00 4A 06 00 C1 FD 00 03 05 41 06 00 45 06 00 4A 06 00 C2 FD 00 03 05 28 06 00 2D 06'\r\n '00 4A 06 00 C3 FD 00 03 03 43 06 00 45 06 00 45 06 00 C4 FD 00 03 03 39 06 00 2C 06 00 45 06 00'\r\n 'C5 FD 00 03 03 35 06 00 45 06 00 45 06 00 C6 FD 00 03 05 33 06 00 2E 06 00 4A 06 00 C7 FD 00 03'\r\n '05 46 06 00 2C 06 00 4A 06 00 F0 FD 00 03 06 35 06 00 44 06 00 D2 06 00 F1 FD 00 03 06 42 06 00'\r\n '44 06 00 D2 06 00 F2 FD 00 04 06 27 06 00 44 06 00 44 06 00 47 06 00 F3 FD 00 04 06 27 06 00 43'\r\n '06 00 28 06 00 31 06 00 F4 FD 00 04 06 45 06 00 2D 06 00 45 06 00 2F 06 00 F5 FD 00 04 06 35 06'\r\n '00 44 06 00 39 06 00 45 06 00 F6 FD 00 04 06 31 06 00 33 06 00 48 06 00 44 06 00 F7 FD 00 04 06'\r\n '39 06 00 44 06 00 4A 06 00 47 06 00 F8 FD 00 04 06 48 06 00 33 06 00 44 06 00 45 06 00 F9 FD 00'\r\n '03 06 35 06 00 44 06 00 49 06 00 FA FD 00 12 06 35 06 00 44 06 00 49 06 00 20 00 00 27 06 00 44'\r\n '06 00 44 06 00 47 06 00 20 00 00 39 06 00 44 06 00 4A 06 00 47 06 00 20 00 00 48 06 00 33 06 00'\r\n '44 06 00 45 06 00 FB FD 00 08 06 2C 06 00 44 06 00 20 00 00 2C 06 00 44 06 00 27 06 00 44 06 00'\r\n '47 06 00 FC FD 00 04 06 31 06 00 CC 06 00 27 06 00 44 06 00 10 FE 00 01 0A 2C 00 00 11 FE 00 01'\r\n '0A 01 30 00 12 FE 00 01 0A 02 30 00 13 FE 00 01 0A 3A 00 00 14 FE 00 01 0A 3B 00 00 15 FE 00 01'\r\n '0A 21 00 00 16 FE 00 01 0A 3F 00 00 17 FE 00 01 0A 16 30 00 18 FE 00 01 0A 17 30 00 19 FE 00 03'\r\n '0A 2E 00 00 2E 00 00 2E 00 00 30 FE 00 02 0A 2E 00 00 2E 00 00 31 FE 00 01 0A 14 20 00 32 FE 00'\r\n '01 0A 13 20 00 33 FE 00 01 0A 5F 00 00 34 FE 00 01 0A 5F 00 00 35 FE 00 01 0A 28 00 00 36 FE 00'\r\n '01 0A 29 00 00 37 FE 00 01 0A 7B 00 00 38 FE 00 01 0A 7D 00 00 39 FE 00 01 0A 14 30 00 3A FE 00'\r\n '01 0A 15 30 00 3B FE 00 01 0A 10 30 00 3C FE 00 01 0A 11 30 00 3D FE 00 01 0A 0A 30 00 3E FE 00'\r\n '01 0A 0B 30 00 3F FE 00 01 0A 08 30 00 40 FE 00 01 0A 09 30 00 41 FE 00 01 0A 0C 30 00 42 FE 00'\r\n '01 0A 0D 30 00 43 FE 00 01 0A 0E 30 00 44 FE 00 01 0A 0F 30 00 47 FE 00 01 0A 5B 00 00 48 FE 00'\r\n '01 0A 5D 00 00 49 FE 00 02 10 20 00 00 05 03 00 4A FE 00 02 10 20 00 00 05 03 00 4B FE 00 02 10'\r\n '20 00 00 05 03 00 4C FE 00 02 10 20 00 00 05 03 00 4D FE 00 01 10 5F 00 00 4E FE 00 01 10 5F 00'\r\n '00 4F FE 00 01 10 5F 00 00 50 FE 00 01 0D 2C 00 00 51 FE 00 01 0D 01 30 00 52 FE 00 01 0D 2E 00'\r\n '00 54 FE 00 01 0D 3B 00 00 55 FE 00 01 0D 3A 00 00 56 FE 00 01 0D 3F 00 00 57 FE 00 01 0D 21 00'\r\n '00 58 FE 00 01 0D 14 20 00 59 FE 00 01 0D 28 00 00 5A FE 00 01 0D 29 00 00 5B FE 00 01 0D 7B 00'\r\n '00 5C FE 00 01 0D 7D 00 00 5D FE 00 01 0D 14 30 00 5E FE 00 01 0D 15 30 00 5F FE 00 01 0D 23 00'\r\n '00 60 FE 00 01 0D 26 00 00 61 FE 00 01 0D 2A 00 00 62 FE 00 01 0D 2B 00 00 63 FE 00 01 0D 2D 00'\r\n '00 64 FE 00 01 0D 3C 00 00 65 FE 00 01 0D 3E 00 00 66 FE 00 01 0D 3D 00 00 68 FE 00 01 0D 5C 00'\r\n '00 69 FE 00 01 0D 24 00 00 6A FE 00 01 0D 25 00 00 6B FE 00 01 0D 40 00 00 70 FE 00 02 06 20 00'\r\n '00 4B 06 00 71 FE 00 02 04 40 06 00 4B 06 00 72 FE 00 02 06 20 00 00 4C 06 00 74 FE 00 02 06 20'\r\n '00 00 4D 06 00 76 FE 00 02 06 20 00 00 4E 06 00 77 FE 00 02 04 40 06 00 4E 06 00 78 FE 00 02 06'\r\n '20 00 00 4F 06 00 79 FE 00 02 04 40 06 00 4F 06 00 7A FE 00 02 06 20 00 00 50 06 00 7B FE 00 02'\r\n '04 40 06 00 50 06 00 7C FE 00 02 06 20 00 00 51 06 00 7D FE 00 02 04 40 06 00 51 06 00 7E FE 00'\r\n '02 06 20 00 00 52 06 00 7F FE 00 02 04 40 06 00 52 06 00 80 FE 00 01 06 21 06 00 81 FE 00 02 06'\r\n '27 06 00 53 06 00 82 FE 00 02 05 27 06 00 53 06 00 83 FE 00 02 06 27 06 00 54 06 00 84 FE 00 02'\r\n '05 27 06 00 54 06 00 85 FE 00 02 06 48 06 00 54 06 00 86 FE 00 02 05 48 06 00 54 06 00 87 FE 00'\r\n '02 06 27 06 00 55 06 00 88 FE 00 02 05 27 06 00 55 06 00 89 FE 00 02 06 4A 06 00 54 06 00 8A FE'\r\n '00 02 05 4A 06 00 54 06 00 8B FE 00 02 03 4A 06 00 54 06 00 8C FE 00 02 04 4A 06 00 54 06 00 8D'\r\n 'FE 00 01 06 27 06 00 8E FE 00 01 05 27 06 00 8F FE 00 01 06 28 06 00 90 FE 00 01 05 28 06 00 91'\r\n 'FE 00 01 03 28 06 00 92 FE 00 01 04 28 06 00 93 FE 00 01 06 29 06 00 94 FE 00 01 05 29 06 00 95'\r\n 'FE 00 01 06 2A 06 00 96 FE 00 01 05 2A 06 00 97 FE 00 01 03 2A 06 00 98 FE 00 01 04 2A 06 00 99'\r\n 'FE 00 01 06 2B 06 00 9A FE 00 01 05 2B 06 00 9B FE 00 01 03 2B 06 00 9C FE 00 01 04 2B 06 00 9D'\r\n 'FE 00 01 06 2C 06 00 9E FE 00 01 05 2C 06 00 9F FE 00 01 03 2C 06 00 A0 FE 00 01 04 2C 06 00 A1'\r\n 'FE 00 01 06 2D 06 00 A2 FE 00 01 05 2D 06 00 A3 FE 00 01 03 2D 06 00 A4 FE 00 01 04 2D 06 00 A5'\r\n 'FE 00 01 06 2E 06 00 A6 FE 00 01 05 2E 06 00 A7 FE 00 01 03 2E 06 00 A8 FE 00 01 04 2E 06 00 A9'\r\n 'FE 00 01 06 2F 06 00 AA FE 00 01 05 2F 06 00 AB FE 00 01 06 30 06 00 AC FE 00 01 05 30 06 00 AD'\r\n 'FE 00 01 06 31 06 00 AE FE 00 01 05 31 06 00 AF FE 00 01 06 32 06 00 B0 FE 00 01 05 32 06 00 B1'\r\n 'FE 00 01 06 33 06 00 B2 FE 00 01 05 33 06 00 B3 FE 00 01 03 33 06 00 B4 FE 00 01 04 33 06 00 B5'\r\n 'FE 00 01 06 34 06 00 B6 FE 00 01 05 34 06 00 B7 FE 00 01 03 34 06 00 B8 FE 00 01 04 34 06 00 B9'\r\n 'FE 00 01 06 35 06 00 BA FE 00 01 05 35 06 00 BB FE 00 01 03 35 06 00 BC FE 00 01 04 35 06 00 BD'\r\n 'FE 00 01 06 36 06 00 BE FE 00 01 05 36 06 00 BF FE 00 01 03 36 06 00 C0 FE 00 01 04 36 06 00 C1'\r\n 'FE 00 01 06 37 06 00 C2 FE 00 01 05 37 06 00 C3 FE 00 01 03 37 06 00 C4 FE 00 01 04 37 06 00 C5'\r\n 'FE 00 01 06 38 06 00 C6 FE 00 01 05 38 06 00 C7 FE 00 01 03 38 06 00 C8 FE 00 01 04 38 06 00 C9'\r\n 'FE 00 01 06 39 06 00 CA FE 00 01 05 39 06 00 CB FE 00 01 03 39 06 00 CC FE 00 01 04 39 06 00 CD'\r\n 'FE 00 01 06 3A 06 00 CE FE 00 01 05 3A 06 00 CF FE 00 01 03 3A 06 00 D0 FE 00 01 04 3A 06 00 D1'\r\n 'FE 00 01 06 41 06 00 D2 FE 00 01 05 41 06 00 D3 FE 00 01 03 41 06 00 D4 FE 00 01 04 41 06 00 D5'\r\n 'FE 00 01 06 42 06 00 D6 FE 00 01 05 42 06 00 D7 FE 00 01 03 42 06 00 D8 FE 00 01 04 42 06 00 D9'\r\n 'FE 00 01 06 43 06 00 DA FE 00 01 05 43 06 00 DB FE 00 01 03 43 06 00 DC FE 00 01 04 43 06 00 DD'\r\n 'FE 00 01 06 44 06 00 DE FE 00 01 05 44 06 00 DF FE 00 01 03 44 06 00 E0 FE 00 01 04 44 06 00 E1'\r\n 'FE 00 01 06 45 06 00 E2 FE 00 01 05 45 06 00 E3 FE 00 01 03 45 06 00 E4 FE 00 01 04 45 06 00 E5'\r\n 'FE 00 01 06 46 06 00 E6 FE 00 01 05 46 06 00 E7 FE 00 01 03 46 06 00 E8 FE 00 01 04 46 06 00 E9'\r\n 'FE 00 01 06 47 06 00 EA FE 00 01 05 47 06 00 EB FE 00 01 03 47 06 00 EC FE 00 01 04 47 06 00 ED'\r\n 'FE 00 01 06 48 06 00 EE FE 00 01 05 48 06 00 EF FE 00 01 06 49 06 00 F0 FE 00 01 05 49 06 00 F1'\r\n 'FE 00 01 06 4A 06 00 F2 FE 00 01 05 4A 06 00 F3 FE 00 01 03 4A 06 00 F4 FE 00 01 04 4A 06 00 F5'\r\n 'FE 00 03 06 44 06 00 27 06 00 53 06 00 F6 FE 00 03 05 44 06 00 27 06 00 53 06 00 F7 FE 00 03 06'\r\n '44 06 00 27 06 00 54 06 00 F8 FE 00 03 05 44 06 00 27 06 00 54 06 00 F9 FE 00 03 06 44 06 00 27'\r\n '06 00 55 06 00 FA FE 00 03 05 44 06 00 27 06 00 55 06 00 FB FE 00 02 06 44 06 00 27 06 00 FC FE'\r\n '00 02 05 44 06 00 27 06 00 01 FF 00 01 0B 21 00 00 02 FF 00 01 0B 22 00 00 03 FF 00 01 0B 23 00'\r\n '00 04 FF 00 01 0B 24 00 00 05 FF 00 01 0B 25 00 00 06 FF 00 01 0B 26 00 00 07 FF 00 01 0B 27 00'\r\n '00 08 FF 00 01 0B 28 00 00 09 FF 00 01 0B 29 00 00 0A FF 00 01 0B 2A 00 00 0B FF 00 01 0B 2B 00'\r\n '00 0C FF 00 01 0B 2C 00 00 0D FF 00 01 0B 2D 00 00 0E FF 00 01 0B 2E 00 00 0F FF 00 01 0B 2F 00'\r\n '00 10 FF 00 01 0B 30 00 00 11 FF 00 01 0B 31 00 00 12 FF 00 01 0B 32 00 00 13 FF 00 01 0B 33 00'\r\n '00 14 FF 00 01 0B 34 00 00 15 FF 00 01 0B 35 00 00 16 FF 00 01 0B 36 00 00 17 FF 00 01 0B 37 00'\r\n '00 18 FF 00 01 0B 38 00 00 19 FF 00 01 0B 39 00 00 1A FF 00 01 0B 3A 00 00 1B FF 00 01 0B 3B 00'\r\n '00 1C FF 00 01 0B 3C 00 00 1D FF 00 01 0B 3D 00 00 1E FF 00 01 0B 3E 00 00 1F FF 00 01 0B 3F 00'\r\n '00 20 FF 00 01 0B 40 00 00 21 FF 00 01 0B 41 00 00 22 FF 00 01 0B 42 00 00 23 FF 00 01 0B 43 00'\r\n '00 24 FF 00 01 0B 44 00 00 25 FF 00 01 0B 45 00 00 26 FF 00 01 0B 46 00 00 27 FF 00 01 0B 47 00'\r\n '00 28 FF 00 01 0B 48 00 00 29 FF 00 01 0B 49 00 00 2A FF 00 01 0B 4A 00 00 2B FF 00 01 0B 4B 00'\r\n '00 2C FF 00 01 0B 4C 00 00 2D FF 00 01 0B 4D 00 00 2E FF 00 01 0B 4E 00 00 2F FF 00 01 0B 4F 00'\r\n '00 30 FF 00 01 0B 50 00 00 31 FF 00 01 0B 51 00 00 32 FF 00 01 0B 52 00 00 33 FF 00 01 0B 53 00'\r\n '00 34 FF 00 01 0B 54 00 00 35 FF 00 01 0B 55 00 00 36 FF 00 01 0B 56 00 00 37 FF 00 01 0B 57 00'\r\n '00 38 FF 00 01 0B 58 00 00 39 FF 00 01 0B 59 00 00 3A FF 00 01 0B 5A 00 00 3B FF 00 01 0B 5B 00'\r\n '00 3C FF 00 01 0B 5C 00 00 3D FF 00 01 0B 5D 00 00 3E FF 00 01 0B 5E 00 00 3F FF 00 01 0B 5F 00'\r\n '00 40 FF 00 01 0B 60 00 00 41 FF 00 01 0B 61 00 00 42 FF 00 01 0B 62 00 00 43 FF 00 01 0B 63 00'\r\n '00 44 FF 00 01 0B 64 00 00 45 FF 00 01 0B 65 00 00 46 FF 00 01 0B 66 00 00 47 FF 00 01 0B 67 00'\r\n '00 48 FF 00 01 0B 68 00 00 49 FF 00 01 0B 69 00 00 4A FF 00 01 0B 6A 00 00 4B FF 00 01 0B 6B 00'\r\n '00 4C FF 00 01 0B 6C 00 00 4D FF 00 01 0B 6D 00 00 4E FF 00 01 0B 6E 00 00 4F FF 00 01 0B 6F 00'\r\n '00 50 FF 00 01 0B 70 00 00 51 FF 00 01 0B 71 00 00 52 FF 00 01 0B 72 00 00 53 FF 00 01 0B 73 00'\r\n '00 54 FF 00 01 0B 74 00 00 55 FF 00 01 0B 75 00 00 56 FF 00 01 0B 76 00 00 57 FF 00 01 0B 77 00'\r\n '00 58 FF 00 01 0B 78 00 00 59 FF 00 01 0B 79 00 00 5A FF 00 01 0B 7A 00 00 5B FF 00 01 0B 7B 00'\r\n '00 5C FF 00 01 0B 7C 00 00 5D FF 00 01 0B 7D 00 00 5E FF 00 01 0B 7E 00 00 5F FF 00 01 0B 85 29'\r\n '00 60 FF 00 01 0B 86 29 00 61 FF 00 01 0C 02 30 00 62 FF 00 01 0C 0C 30 00 63 FF 00 01 0C 0D 30'\r\n '00 64 FF 00 01 0C 01 30 00 65 FF 00 01 0C FB 30 00 66 FF 00 01 0C F2 30 00 67 FF 00 01 0C A1 30'\r\n '00 68 FF 00 01 0C A3 30 00 69 FF 00 01 0C A5 30 00 6A FF 00 01 0C A7 30 00 6B FF 00 01 0C A9 30'\r\n '00 6C FF 00 01 0C E3 30 00 6D FF 00 01 0C E5 30 00 6E FF 00 01 0C E7 30 00 6F FF 00 01 0C C3 30'\r\n '00 70 FF 00 01 0C FC 30 00 71 FF 00 01 0C A2 30 00 72 FF 00 01 0C A4 30 00 73 FF 00 01 0C A6 30'\r\n '00 74 FF 00 01 0C A8 30 00 75 FF 00 01 0C AA 30 00 76 FF 00 01 0C AB 30 00 77 FF 00 01 0C AD 30'\r\n '00 78 FF 00 01 0C AF 30 00 79 FF 00 01 0C B1 30 00 7A FF 00 01 0C B3 30 00 7B FF 00 01 0C B5 30'\r\n '00 7C FF 00 01 0C B7 30 00 7D FF 00 01 0C B9 30 00 7E FF 00 01 0C BB 30 00 7F FF 00 01 0C BD 30'\r\n '00 80 FF 00 01 0C BF 30 00 81 FF 00 01 0C C1 30 00 82 FF 00 01 0C C4 30 00 83 FF 00 01 0C C6 30'\r\n '00 84 FF 00 01 0C C8 30 00 85 FF 00 01 0C CA 30 00 86 FF 00 01 0C CB 30 00 87 FF 00 01 0C CC 30'\r\n '00 88 FF 00 01 0C CD 30 00 89 FF 00 01 0C CE 30 00 8A FF 00 01 0C CF 30 00 8B FF 00 01 0C D2 30'\r\n '00 8C FF 00 01 0C D5 30 00 8D FF 00 01 0C D8 30 00 8E FF 00 01 0C DB 30 00 8F FF 00 01 0C DE 30'\r\n '00 90 FF 00 01 0C DF 30 00 91 FF 00 01 0C E0 30 00 92 FF 00 01 0C E1 30 00 93 FF 00 01 0C E2 30'\r\n '00 94 FF 00 01 0C E4 30 00 95 FF 00 01 0C E6 30 00 96 FF 00 01 0C E8 30 00 97 FF 00 01 0C E9 30'\r\n '00 98 FF 00 01 0C EA 30 00 99 FF 00 01 0C EB 30 00 9A FF 00 01 0C EC 30 00 9B FF 00 01 0C ED 30'\r\n '00 9C FF 00 01 0C EF 30 00 9D FF 00 01 0C F3 30 00 9E FF 00 01 0C 99 30 00 9F FF 00 01 0C 9A 30'\r\n '00 A0 FF 00 01 0C 60 11 00 A1 FF 00 01 0C 00 11 00 A2 FF 00 01 0C 01 11 00 A3 FF 00 01 0C AA 11'\r\n '00 A4 FF 00 01 0C 02 11 00 A5 FF 00 01 0C AC 11 00 A6 FF 00 01 0C AD 11 00 A7 FF 00 01 0C 03 11'\r\n '00 A8 FF 00 01 0C 04 11 00 A9 FF 00 01 0C 05 11 00 AA FF 00 01 0C B0 11 00 AB FF 00 01 0C B1 11'\r\n '00 AC FF 00 01 0C B2 11 00 AD FF 00 01 0C B3 11 00 AE FF 00 01 0C B4 11 00 AF FF 00 01 0C B5 11'\r\n '00 B0 FF 00 01 0C 1A 11 00 B1 FF 00 01 0C 06 11 00 B2 FF 00 01 0C 07 11 00 B3 FF 00 01 0C 08 11'\r\n '00 B4 FF 00 01 0C 21 11 00 B5 FF 00 01 0C 09 11 00 B6 FF 00 01 0C 0A 11 00 B7 FF 00 01 0C 0B 11'\r\n '00 B8 FF 00 01 0C 0C 11 00 B9 FF 00 01 0C 0D 11 00 BA FF 00 01 0C 0E 11 00 BB FF 00 01 0C 0F 11'\r\n '00 BC FF 00 01 0C 10 11 00 BD FF 00 01 0C 11 11 00 BE FF 00 01 0C 12 11 00 C2 FF 00 01 0C 61 11'\r\n '00 C3 FF 00 01 0C 62 11 00 C4 FF 00 01 0C 63 11 00 C5 FF 00 01 0C 64 11 00 C6 FF 00 01 0C 65 11'\r\n '00 C7 FF 00 01 0C 66 11 00 CA FF 00 01 0C 67 11 00 CB FF 00 01 0C 68 11 00 CC FF 00 01 0C 69 11'\r\n '00 CD FF 00 01 0C 6A 11 00 CE FF 00 01 0C 6B 11 00 CF FF 00 01 0C 6C 11 00 D2 FF 00 01 0C 6D 11'\r\n '00 D3 FF 00 01 0C 6E 11 00 D4 FF 00 01 0C 6F 11 00 D5 FF 00 01 0C 70 11 00 D6 FF 00 01 0C 71 11'\r\n '00 D7 FF 00 01 0C 72 11 00 DA FF 00 01 0C 73 11 00 DB FF 00 01 0C 74 11 00 DC FF 00 01 0C 75 11'\r\n '00 E0 FF 00 01 0B A2 00 00 E1 FF 00 01 0B A3 00 00 E2 FF 00 01 0B AC 00 00 E3 FF 00 02 0B 20 00'\r\n '00 04 03 00 E4 FF 00 01 0B A6 00 00 E5 FF 00 01 0B A5 00 00 E6 FF 00 01 0B A9 20 00 E8 FF 00 01'\r\n '0C 02 25 00 E9 FF 00 01 0C 90 21 00 EA FF 00 01 0C 91 21 00 EB FF 00 01 0C 92 21 00 EC FF 00 01'\r\n '0C 93 21 00 ED FF 00 01 0C A0 25 00 EE FF 00 01 0C CB 25 00 9A 10 01 02 00 99 10 01 BA 10 01 9C'\r\n '10 01 02 00 9B 10 01 BA 10 01 AB 10 01 02 00 A5 10 01 BA 10 01 5E D1 01 02 00 57 D1 01 65 D1 01'\r\n '5F D1 01 02 00 58 D1 01 65 D1 01 60 D1 01 03 00 58 D1 01 65 D1 01 6E D1 01 61 D1 01 03 00 58 D1'\r\n '01 65 D1 01 6F D1 01 62 D1 01 03 00 58 D1 01 65 D1 01 70 D1 01 63 D1 01 03 00 58 D1 01 65 D1 01'\r\n '71 D1 01 64 D1 01 03 00 58 D1 01 65 D1 01 72 D1 01 BB D1 01 02 00 B9 D1 01 65 D1 01 BC D1 01 02'\r\n '00 BA D1 01 65 D1 01 BD D1 01 03 00 B9 D1 01 65 D1 01 6E D1 01 BE D1 01 03 00 BA D1 01 65 D1 01'\r\n '6E D1 01 BF D1 01 03 00 B9 D1 01 65 D1 01 6F D1 01 C0 D1 01 03 00 BA D1 01 65 D1 01 6F D1 01 00'\r\n 'D4 01 01 01 41 00 00 01 D4 01 01 01 42 00 00 02 D4 01 01 01 43 00 00 03 D4 01 01 01 44 00 00 04'\r\n 'D4 01 01 01 45 00 00 05 D4 01 01 01 46 00 00 06 D4 01 01 01 47 00 00 07 D4 01 01 01 48 00 00 08'\r\n 'D4 01 01 01 49 00 00 09 D4 01 01 01 4A 00 00 0A D4 01 01 01 4B 00 00 0B D4 01 01 01 4C 00 00 0C'\r\n 'D4 01 01 01 4D 00 00 0D D4 01 01 01 4E 00 00 0E D4 01 01 01 4F 00 00 0F D4 01 01 01 50 00 00 10'\r\n 'D4 01 01 01 51 00 00 11 D4 01 01 01 52 00 00 12 D4 01 01 01 53 00 00 13 D4 01 01 01 54 00 00 14'\r\n 'D4 01 01 01 55 00 00 15 D4 01 01 01 56 00 00 16 D4 01 01 01 57 00 00 17 D4 01 01 01 58 00 00 18'\r\n 'D4 01 01 01 59 00 00 19 D4 01 01 01 5A 00 00 1A D4 01 01 01 61 00 00 1B D4 01 01 01 62 00 00 1C'\r\n 'D4 01 01 01 63 00 00 1D D4 01 01 01 64 00 00 1E D4 01 01 01 65 00 00 1F D4 01 01 01 66 00 00 20'\r\n 'D4 01 01 01 67 00 00 21 D4 01 01 01 68 00 00 22 D4 01 01 01 69 00 00 23 D4 01 01 01 6A 00 00 24'\r\n 'D4 01 01 01 6B 00 00 25 D4 01 01 01 6C 00 00 26 D4 01 01 01 6D 00 00 27 D4 01 01 01 6E 00 00 28'\r\n 'D4 01 01 01 6F 00 00 29 D4 01 01 01 70 00 00 2A D4 01 01 01 71 00 00 2B D4 01 01 01 72 00 00 2C'\r\n 'D4 01 01 01 73 00 00 2D D4 01 01 01 74 00 00 2E D4 01 01 01 75 00 00 2F D4 01 01 01 76 00 00 30'\r\n 'D4 01 01 01 77 00 00 31 D4 01 01 01 78 00 00 32 D4 01 01 01 79 00 00 33 D4 01 01 01 7A 00 00 34'\r\n 'D4 01 01 01 41 00 00 35 D4 01 01 01 42 00 00 36 D4 01 01 01 43 00 00 37 D4 01 01 01 44 00 00 38'\r\n 'D4 01 01 01 45 00 00 39 D4 01 01 01 46 00 00 3A D4 01 01 01 47 00 00 3B D4 01 01 01 48 00 00 3C'\r\n 'D4 01 01 01 49 00 00 3D D4 01 01 01 4A 00 00 3E D4 01 01 01 4B 00 00 3F D4 01 01 01 4C 00 00 40'\r\n 'D4 01 01 01 4D 00 00 41 D4 01 01 01 4E 00 00 42 D4 01 01 01 4F 00 00 43 D4 01 01 01 50 00 00 44'\r\n 'D4 01 01 01 51 00 00 45 D4 01 01 01 52 00 00 46 D4 01 01 01 53 00 00 47 D4 01 01 01 54 00 00 48'\r\n 'D4 01 01 01 55 00 00 49 D4 01 01 01 56 00 00 4A D4 01 01 01 57 00 00 4B D4 01 01 01 58 00 00 4C'\r\n 'D4 01 01 01 59 00 00 4D D4 01 01 01 5A 00 00 4E D4 01 01 01 61 00 00 4F D4 01 01 01 62 00 00 50'\r\n 'D4 01 01 01 63 00 00 51 D4 01 01 01 64 00 00 52 D4 01 01 01 65 00 00 53 D4 01 01 01 66 00 00 54'\r\n 'D4 01 01 01 67 00 00 56 D4 01 01 01 69 00 00 57 D4 01 01 01 6A 00 00 58 D4 01 01 01 6B 00 00 59'\r\n 'D4 01 01 01 6C 00 00 5A D4 01 01 01 6D 00 00 5B D4 01 01 01 6E 00 00 5C D4 01 01 01 6F 00 00 5D'\r\n 'D4 01 01 01 70 00 00 5E D4 01 01 01 71 00 00 5F D4 01 01 01 72 00 00 60 D4 01 01 01 73 00 00 61'\r\n 'D4 01 01 01 74 00 00 62 D4 01 01 01 75 00 00 63 D4 01 01 01 76 00 00 64 D4 01 01 01 77 00 00 65'\r\n 'D4 01 01 01 78 00 00 66 D4 01 01 01 79 00 00 67 D4 01 01 01 7A 00 00 68 D4 01 01 01 41 00 00 69'\r\n 'D4 01 01 01 42 00 00 6A D4 01 01 01 43 00 00 6B D4 01 01 01 44 00 00 6C D4 01 01 01 45 00 00 6D'\r\n 'D4 01 01 01 46 00 00 6E D4 01 01 01 47 00 00 6F D4 01 01 01 48 00 00 70 D4 01 01 01 49 00 00 71'\r\n 'D4 01 01 01 4A 00 00 72 D4 01 01 01 4B 00 00 73 D4 01 01 01 4C 00 00 74 D4 01 01 01 4D 00 00 75'\r\n 'D4 01 01 01 4E 00 00 76 D4 01 01 01 4F 00 00 77 D4 01 01 01 50 00 00 78 D4 01 01 01 51 00 00 79'\r\n 'D4 01 01 01 52 00 00 7A D4 01 01 01 53 00 00 7B D4 01 01 01 54 00 00 7C D4 01 01 01 55 00 00 7D'\r\n 'D4 01 01 01 56 00 00 7E D4 01 01 01 57 00 00 7F D4 01 01 01 58 00 00 80 D4 01 01 01 59 00 00 81'\r\n 'D4 01 01 01 5A 00 00 82 D4 01 01 01 61 00 00 83 D4 01 01 01 62 00 00 84 D4 01 01 01 63 00 00 85'\r\n 'D4 01 01 01 64 00 00 86 D4 01 01 01 65 00 00 87 D4 01 01 01 66 00 00 88 D4 01 01 01 67 00 00 89'\r\n 'D4 01 01 01 68 00 00 8A D4 01 01 01 69 00 00 8B D4 01 01 01 6A 00 00 8C D4 01 01 01 6B 00 00 8D'\r\n 'D4 01 01 01 6C 00 00 8E D4 01 01 01 6D 00 00 8F D4 01 01 01 6E 00 00 90 D4 01 01 01 6F 00 00 91'\r\n 'D4 01 01 01 70 00 00 92 D4 01 01 01 71 00 00 93 D4 01 01 01 72 00 00 94 D4 01 01 01 73 00 00 95'\r\n 'D4 01 01 01 74 00 00 96 D4 01 01 01 75 00 00 97 D4 01 01 01 76 00 00 98 D4 01 01 01 77 00 00 99'\r\n 'D4 01 01 01 78 00 00 9A D4 01 01 01 79 00 00 9B D4 01 01 01 7A 00 00 9C D4 01 01 01 41 00 00 9E'\r\n 'D4 01 01 01 43 00 00 9F D4 01 01 01 44 00 00 A2 D4 01 01 01 47 00 00 A5 D4 01 01 01 4A 00 00 A6'\r\n 'D4 01 01 01 4B 00 00 A9 D4 01 01 01 4E 00 00 AA D4 01 01 01 4F 00 00 AB D4 01 01 01 50 00 00 AC'\r\n 'D4 01 01 01 51 00 00 AE D4 01 01 01 53 00 00 AF D4 01 01 01 54 00 00 B0 D4 01 01 01 55 00 00 B1'\r\n 'D4 01 01 01 56 00 00 B2 D4 01 01 01 57 00 00 B3 D4 01 01 01 58 00 00 B4 D4 01 01 01 59 00 00 B5'\r\n 'D4 01 01 01 5A 00 00 B6 D4 01 01 01 61 00 00 B7 D4 01 01 01 62 00 00 B8 D4 01 01 01 63 00 00 B9'\r\n 'D4 01 01 01 64 00 00 BB D4 01 01 01 66 00 00 BD D4 01 01 01 68 00 00 BE D4 01 01 01 69 00 00 BF'\r\n 'D4 01 01 01 6A 00 00 C0 D4 01 01 01 6B 00 00 C1 D4 01 01 01 6C 00 00 C2 D4 01 01 01 6D 00 00 C3'\r\n 'D4 01 01 01 6E 00 00 C5 D4 01 01 01 70 00 00 C6 D4 01 01 01 71 00 00 C7 D4 01 01 01 72 00 00 C8'\r\n 'D4 01 01 01 73 00 00 C9 D4 01 01 01 74 00 00 CA D4 01 01 01 75 00 00 CB D4 01 01 01 76 00 00 CC'\r\n 'D4 01 01 01 77 00 00 CD D4 01 01 01 78 00 00 CE D4 01 01 01 79 00 00 CF D4 01 01 01 7A 00 00 D0'\r\n 'D4 01 01 01 41 00 00 D1 D4 01 01 01 42 00 00 D2 D4 01 01 01 43 00 00 D3 D4 01 01 01 44 00 00 D4'\r\n 'D4 01 01 01 45 00 00 D5 D4 01 01 01 46 00 00 D6 D4 01 01 01 47 00 00 D7 D4 01 01 01 48 00 00 D8'\r\n 'D4 01 01 01 49 00 00 D9 D4 01 01 01 4A 00 00 DA D4 01 01 01 4B 00 00 DB D4 01 01 01 4C 00 00 DC'\r\n 'D4 01 01 01 4D 00 00 DD D4 01 01 01 4E 00 00 DE D4 01 01 01 4F 00 00 DF D4 01 01 01 50 00 00 E0'\r\n 'D4 01 01 01 51 00 00 E1 D4 01 01 01 52 00 00 E2 D4 01 01 01 53 00 00 E3 D4 01 01 01 54 00 00 E4'\r\n 'D4 01 01 01 55 00 00 E5 D4 01 01 01 56 00 00 E6 D4 01 01 01 57 00 00 E7 D4 01 01 01 58 00 00 E8'\r\n 'D4 01 01 01 59 00 00 E9 D4 01 01 01 5A 00 00 EA D4 01 01 01 61 00 00 EB D4 01 01 01 62 00 00 EC'\r\n 'D4 01 01 01 63 00 00 ED D4 01 01 01 64 00 00 EE D4 01 01 01 65 00 00 EF D4 01 01 01 66 00 00 F0'\r\n 'D4 01 01 01 67 00 00 F1 D4 01 01 01 68 00 00 F2 D4 01 01 01 69 00 00 F3 D4 01 01 01 6A 00 00 F4'\r\n 'D4 01 01 01 6B 00 00 F5 D4 01 01 01 6C 00 00 F6 D4 01 01 01 6D 00 00 F7 D4 01 01 01 6E 00 00 F8'\r\n 'D4 01 01 01 6F 00 00 F9 D4 01 01 01 70 00 00 FA D4 01 01 01 71 00 00 FB D4 01 01 01 72 00 00 FC'\r\n 'D4 01 01 01 73 00 00 FD D4 01 01 01 74 00 00 FE D4 01 01 01 75 00 00 FF D4 01 01 01 76 00 00 00'\r\n 'D5 01 01 01 77 00 00 01 D5 01 01 01 78 00 00 02 D5 01 01 01 79 00 00 03 D5 01 01 01 7A 00 00 04'\r\n 'D5 01 01 01 41 00 00 05 D5 01 01 01 42 00 00 07 D5 01 01 01 44 00 00 08 D5 01 01 01 45 00 00 09'\r\n 'D5 01 01 01 46 00 00 0A D5 01 01 01 47 00 00 0D D5 01 01 01 4A 00 00 0E D5 01 01 01 4B 00 00 0F'\r\n 'D5 01 01 01 4C 00 00 10 D5 01 01 01 4D 00 00 11 D5 01 01 01 4E 00 00 12 D5 01 01 01 4F 00 00 13'\r\n 'D5 01 01 01 50 00 00 14 D5 01 01 01 51 00 00 16 D5 01 01 01 53 00 00 17 D5 01 01 01 54 00 00 18'\r\n 'D5 01 01 01 55 00 00 19 D5 01 01 01 56 00 00 1A D5 01 01 01 57 00 00 1B D5 01 01 01 58 00 00 1C'\r\n 'D5 01 01 01 59 00 00 1E D5 01 01 01 61 00 00 1F D5 01 01 01 62 00 00 20 D5 01 01 01 63 00 00 21'\r\n 'D5 01 01 01 64 00 00 22 D5 01 01 01 65 00 00 23 D5 01 01 01 66 00 00 24 D5 01 01 01 67 00 00 25'\r\n 'D5 01 01 01 68 00 00 26 D5 01 01 01 69 00 00 27 D5 01 01 01 6A 00 00 28 D5 01 01 01 6B 00 00 29'\r\n 'D5 01 01 01 6C 00 00 2A D5 01 01 01 6D 00 00 2B D5 01 01 01 6E 00 00 2C D5 01 01 01 6F 00 00 2D'\r\n 'D5 01 01 01 70 00 00 2E D5 01 01 01 71 00 00 2F D5 01 01 01 72 00 00 30 D5 01 01 01 73 00 00 31'\r\n 'D5 01 01 01 74 00 00 32 D5 01 01 01 75 00 00 33 D5 01 01 01 76 00 00 34 D5 01 01 01 77 00 00 35'\r\n 'D5 01 01 01 78 00 00 36 D5 01 01 01 79 00 00 37 D5 01 01 01 7A 00 00 38 D5 01 01 01 41 00 00 39'\r\n 'D5 01 01 01 42 00 00 3B D5 01 01 01 44 00 00 3C D5 01 01 01 45 00 00 3D D5 01 01 01 46 00 00 3E'\r\n 'D5 01 01 01 47 00 00 40 D5 01 01 01 49 00 00 41 D5 01 01 01 4A 00 00 42 D5 01 01 01 4B 00 00 43'\r\n 'D5 01 01 01 4C 00 00 44 D5 01 01 01 4D 00 00 46 D5 01 01 01 4F 00 00 4A D5 01 01 01 53 00 00 4B'\r\n 'D5 01 01 01 54 00 00 4C D5 01 01 01 55 00 00 4D D5 01 01 01 56 00 00 4E D5 01 01 01 57 00 00 4F'\r\n 'D5 01 01 01 58 00 00 50 D5 01 01 01 59 00 00 52 D5 01 01 01 61 00 00 53 D5 01 01 01 62 00 00 54'\r\n 'D5 01 01 01 63 00 00 55 D5 01 01 01 64 00 00 56 D5 01 01 01 65 00 00 57 D5 01 01 01 66 00 00 58'\r\n 'D5 01 01 01 67 00 00 59 D5 01 01 01 68 00 00 5A D5 01 01 01 69 00 00 5B D5 01 01 01 6A 00 00 5C'\r\n 'D5 01 01 01 6B 00 00 5D D5 01 01 01 6C 00 00 5E D5 01 01 01 6D 00 00 5F D5 01 01 01 6E 00 00 60'\r\n 'D5 01 01 01 6F 00 00 61 D5 01 01 01 70 00 00 62 D5 01 01 01 71 00 00 63 D5 01 01 01 72 00 00 64'\r\n 'D5 01 01 01 73 00 00 65 D5 01 01 01 74 00 00 66 D5 01 01 01 75 00 00 67 D5 01 01 01 76 00 00 68'\r\n 'D5 01 01 01 77 00 00 69 D5 01 01 01 78 00 00 6A D5 01 01 01 79 00 00 6B D5 01 01 01 7A 00 00 6C'\r\n 'D5 01 01 01 41 00 00 6D D5 01 01 01 42 00 00 6E D5 01 01 01 43 00 00 6F D5 01 01 01 44 00 00 70'\r\n 'D5 01 01 01 45 00 00 71 D5 01 01 01 46 00 00 72 D5 01 01 01 47 00 00 73 D5 01 01 01 48 00 00 74'\r\n 'D5 01 01 01 49 00 00 75 D5 01 01 01 4A 00 00 76 D5 01 01 01 4B 00 00 77 D5 01 01 01 4C 00 00 78'\r\n 'D5 01 01 01 4D 00 00 79 D5 01 01 01 4E 00 00 7A D5 01 01 01 4F 00 00 7B D5 01 01 01 50 00 00 7C'\r\n 'D5 01 01 01 51 00 00 7D D5 01 01 01 52 00 00 7E D5 01 01 01 53 00 00 7F D5 01 01 01 54 00 00 80'\r\n 'D5 01 01 01 55 00 00 81 D5 01 01 01 56 00 00 82 D5 01 01 01 57 00 00 83 D5 01 01 01 58 00 00 84'\r\n 'D5 01 01 01 59 00 00 85 D5 01 01 01 5A 00 00 86 D5 01 01 01 61 00 00 87 D5 01 01 01 62 00 00 88'\r\n 'D5 01 01 01 63 00 00 89 D5 01 01 01 64 00 00 8A D5 01 01 01 65 00 00 8B D5 01 01 01 66 00 00 8C'\r\n 'D5 01 01 01 67 00 00 8D D5 01 01 01 68 00 00 8E D5 01 01 01 69 00 00 8F D5 01 01 01 6A 00 00 90'\r\n 'D5 01 01 01 6B 00 00 91 D5 01 01 01 6C 00 00 92 D5 01 01 01 6D 00 00 93 D5 01 01 01 6E 00 00 94'\r\n 'D5 01 01 01 6F 00 00 95 D5 01 01 01 70 00 00 96 D5 01 01 01 71 00 00 97 D5 01 01 01 72 00 00 98'\r\n 'D5 01 01 01 73 00 00 99 D5 01 01 01 74 00 00 9A D5 01 01 01 75 00 00 9B D5 01 01 01 76 00 00 9C'\r\n 'D5 01 01 01 77 00 00 9D D5 01 01 01 78 00 00 9E D5 01 01 01 79 00 00 9F D5 01 01 01 7A 00 00 A0'\r\n 'D5 01 01 01 41 00 00 A1 D5 01 01 01 42 00 00 A2 D5 01 01 01 43 00 00 A3 D5 01 01 01 44 00 00 A4'\r\n 'D5 01 01 01 45 00 00 A5 D5 01 01 01 46 00 00 A6 D5 01 01 01 47 00 00 A7 D5 01 01 01 48 00 00 A8'\r\n 'D5 01 01 01 49 00 00 A9 D5 01 01 01 4A 00 00 AA D5 01 01 01 4B 00 00 AB D5 01 01 01 4C 00 00 AC'\r\n 'D5 01 01 01 4D 00 00 AD D5 01 01 01 4E 00 00 AE D5 01 01 01 4F 00 00 AF D5 01 01 01 50 00 00 B0'\r\n 'D5 01 01 01 51 00 00 B1 D5 01 01 01 52 00 00 B2 D5 01 01 01 53 00 00 B3 D5 01 01 01 54 00 00 B4'\r\n 'D5 01 01 01 55 00 00 B5 D5 01 01 01 56 00 00 B6 D5 01 01 01 57 00 00 B7 D5 01 01 01 58 00 00 B8'\r\n 'D5 01 01 01 59 00 00 B9 D5 01 01 01 5A 00 00 BA D5 01 01 01 61 00 00 BB D5 01 01 01 62 00 00 BC'\r\n 'D5 01 01 01 63 00 00 BD D5 01 01 01 64 00 00 BE D5 01 01 01 65 00 00 BF D5 01 01 01 66 00 00 C0'\r\n 'D5 01 01 01 67 00 00 C1 D5 01 01 01 68 00 00 C2 D5 01 01 01 69 00 00 C3 D5 01 01 01 6A 00 00 C4'\r\n 'D5 01 01 01 6B 00 00 C5 D5 01 01 01 6C 00 00 C6 D5 01 01 01 6D 00 00 C7 D5 01 01 01 6E 00 00 C8'\r\n 'D5 01 01 01 6F 00 00 C9 D5 01 01 01 70 00 00 CA D5 01 01 01 71 00 00 CB D5 01 01 01 72 00 00 CC'\r\n 'D5 01 01 01 73 00 00 CD D5 01 01 01 74 00 00 CE D5 01 01 01 75 00 00 CF D5 01 01 01 76 00 00 D0'\r\n 'D5 01 01 01 77 00 00 D1 D5 01 01 01 78 00 00 D2 D5 01 01 01 79 00 00 D3 D5 01 01 01 7A 00 00 D4'\r\n 'D5 01 01 01 41 00 00 D5 D5 01 01 01 42 00 00 D6 D5 01 01 01 43 00 00 D7 D5 01 01 01 44 00 00 D8'\r\n 'D5 01 01 01 45 00 00 D9 D5 01 01 01 46 00 00 DA D5 01 01 01 47 00 00 DB D5 01 01 01 48 00 00 DC'\r\n 'D5 01 01 01 49 00 00 DD D5 01 01 01 4A 00 00 DE D5 01 01 01 4B 00 00 DF D5 01 01 01 4C 00 00 E0'\r\n 'D5 01 01 01 4D 00 00 E1 D5 01 01 01 4E 00 00 E2 D5 01 01 01 4F 00 00 E3 D5 01 01 01 50 00 00 E4'\r\n 'D5 01 01 01 51 00 00 E5 D5 01 01 01 52 00 00 E6 D5 01 01 01 53 00 00 E7 D5 01 01 01 54 00 00 E8'\r\n 'D5 01 01 01 55 00 00 E9 D5 01 01 01 56 00 00 EA D5 01 01 01 57 00 00 EB D5 01 01 01 58 00 00 EC'\r\n 'D5 01 01 01 59 00 00 ED D5 01 01 01 5A 00 00 EE D5 01 01 01 61 00 00 EF D5 01 01 01 62 00 00 F0'\r\n 'D5 01 01 01 63 00 00 F1 D5 01 01 01 64 00 00 F2 D5 01 01 01 65 00 00 F3 D5 01 01 01 66 00 00 F4'\r\n 'D5 01 01 01 67 00 00 F5 D5 01 01 01 68 00 00 F6 D5 01 01 01 69 00 00 F7 D5 01 01 01 6A 00 00 F8'\r\n 'D5 01 01 01 6B 00 00 F9 D5 01 01 01 6C 00 00 FA D5 01 01 01 6D 00 00 FB D5 01 01 01 6E 00 00 FC'\r\n 'D5 01 01 01 6F 00 00 FD D5 01 01 01 70 00 00 FE D5 01 01 01 71 00 00 FF D5 01 01 01 72 00 00 00'\r\n 'D6 01 01 01 73 00 00 01 D6 01 01 01 74 00 00 02 D6 01 01 01 75 00 00 03 D6 01 01 01 76 00 00 04'\r\n 'D6 01 01 01 77 00 00 05 D6 01 01 01 78 00 00 06 D6 01 01 01 79 00 00 07 D6 01 01 01 7A 00 00 08'\r\n 'D6 01 01 01 41 00 00 09 D6 01 01 01 42 00 00 0A D6 01 01 01 43 00 00 0B D6 01 01 01 44 00 00 0C'\r\n 'D6 01 01 01 45 00 00 0D D6 01 01 01 46 00 00 0E D6 01 01 01 47 00 00 0F D6 01 01 01 48 00 00 10'\r\n 'D6 01 01 01 49 00 00 11 D6 01 01 01 4A 00 00 12 D6 01 01 01 4B 00 00 13 D6 01 01 01 4C 00 00 14'\r\n 'D6 01 01 01 4D 00 00 15 D6 01 01 01 4E 00 00 16 D6 01 01 01 4F 00 00 17 D6 01 01 01 50 00 00 18'\r\n 'D6 01 01 01 51 00 00 19 D6 01 01 01 52 00 00 1A D6 01 01 01 53 00 00 1B D6 01 01 01 54 00 00 1C'\r\n 'D6 01 01 01 55 00 00 1D D6 01 01 01 56 00 00 1E D6 01 01 01 57 00 00 1F D6 01 01 01 58 00 00 20'\r\n 'D6 01 01 01 59 00 00 21 D6 01 01 01 5A 00 00 22 D6 01 01 01 61 00 00 23 D6 01 01 01 62 00 00 24'\r\n 'D6 01 01 01 63 00 00 25 D6 01 01 01 64 00 00 26 D6 01 01 01 65 00 00 27 D6 01 01 01 66 00 00 28'\r\n 'D6 01 01 01 67 00 00 29 D6 01 01 01 68 00 00 2A D6 01 01 01 69 00 00 2B D6 01 01 01 6A 00 00 2C'\r\n 'D6 01 01 01 6B 00 00 2D D6 01 01 01 6C 00 00 2E D6 01 01 01 6D 00 00 2F D6 01 01 01 6E 00 00 30'\r\n 'D6 01 01 01 6F 00 00 31 D6 01 01 01 70 00 00 32 D6 01 01 01 71 00 00 33 D6 01 01 01 72 00 00 34'\r\n 'D6 01 01 01 73 00 00 35 D6 01 01 01 74 00 00 36 D6 01 01 01 75 00 00 37 D6 01 01 01 76 00 00 38'\r\n 'D6 01 01 01 77 00 00 39 D6 01 01 01 78 00 00 3A D6 01 01 01 79 00 00 3B D6 01 01 01 7A 00 00 3C'\r\n 'D6 01 01 01 41 00 00 3D D6 01 01 01 42 00 00 3E D6 01 01 01 43 00 00 3F D6 01 01 01 44 00 00 40'\r\n 'D6 01 01 01 45 00 00 41 D6 01 01 01 46 00 00 42 D6 01 01 01 47 00 00 43 D6 01 01 01 48 00 00 44'\r\n 'D6 01 01 01 49 00 00 45 D6 01 01 01 4A 00 00 46 D6 01 01 01 4B 00 00 47 D6 01 01 01 4C 00 00 48'\r\n 'D6 01 01 01 4D 00 00 49 D6 01 01 01 4E 00 00 4A D6 01 01 01 4F 00 00 4B D6 01 01 01 50 00 00 4C'\r\n 'D6 01 01 01 51 00 00 4D D6 01 01 01 52 00 00 4E D6 01 01 01 53 00 00 4F D6 01 01 01 54 00 00 50'\r\n 'D6 01 01 01 55 00 00 51 D6 01 01 01 56 00 00 52 D6 01 01 01 57 00 00 53 D6 01 01 01 58 00 00 54'\r\n 'D6 01 01 01 59 00 00 55 D6 01 01 01 5A 00 00 56 D6 01 01 01 61 00 00 57 D6 01 01 01 62 00 00 58'\r\n 'D6 01 01 01 63 00 00 59 D6 01 01 01 64 00 00 5A D6 01 01 01 65 00 00 5B D6 01 01 01 66 00 00 5C'\r\n 'D6 01 01 01 67 00 00 5D D6 01 01 01 68 00 00 5E D6 01 01 01 69 00 00 5F D6 01 01 01 6A 00 00 60'\r\n 'D6 01 01 01 6B 00 00 61 D6 01 01 01 6C 00 00 62 D6 01 01 01 6D 00 00 63 D6 01 01 01 6E 00 00 64'\r\n 'D6 01 01 01 6F 00 00 65 D6 01 01 01 70 00 00 66 D6 01 01 01 71 00 00 67 D6 01 01 01 72 00 00 68'\r\n 'D6 01 01 01 73 00 00 69 D6 01 01 01 74 00 00 6A D6 01 01 01 75 00 00 6B D6 01 01 01 76 00 00 6C'\r\n 'D6 01 01 01 77 00 00 6D D6 01 01 01 78 00 00 6E D6 01 01 01 79 00 00 6F D6 01 01 01 7A 00 00 70'\r\n 'D6 01 01 01 41 00 00 71 D6 01 01 01 42 00 00 72 D6 01 01 01 43 00 00 73 D6 01 01 01 44 00 00 74'\r\n 'D6 01 01 01 45 00 00 75 D6 01 01 01 46 00 00 76 D6 01 01 01 47 00 00 77 D6 01 01 01 48 00 00 78'\r\n 'D6 01 01 01 49 00 00 79 D6 01 01 01 4A 00 00 7A D6 01 01 01 4B 00 00 7B D6 01 01 01 4C 00 00 7C'\r\n 'D6 01 01 01 4D 00 00 7D D6 01 01 01 4E 00 00 7E D6 01 01 01 4F 00 00 7F D6 01 01 01 50 00 00 80'\r\n 'D6 01 01 01 51 00 00 81 D6 01 01 01 52 00 00 82 D6 01 01 01 53 00 00 83 D6 01 01 01 54 00 00 84'\r\n 'D6 01 01 01 55 00 00 85 D6 01 01 01 56 00 00 86 D6 01 01 01 57 00 00 87 D6 01 01 01 58 00 00 88'\r\n 'D6 01 01 01 59 00 00 89 D6 01 01 01 5A 00 00 8A D6 01 01 01 61 00 00 8B D6 01 01 01 62 00 00 8C'\r\n 'D6 01 01 01 63 00 00 8D D6 01 01 01 64 00 00 8E D6 01 01 01 65 00 00 8F D6 01 01 01 66 00 00 90'\r\n 'D6 01 01 01 67 00 00 91 D6 01 01 01 68 00 00 92 D6 01 01 01 69 00 00 93 D6 01 01 01 6A 00 00 94'\r\n 'D6 01 01 01 6B 00 00 95 D6 01 01 01 6C 00 00 96 D6 01 01 01 6D 00 00 97 D6 01 01 01 6E 00 00 98'\r\n 'D6 01 01 01 6F 00 00 99 D6 01 01 01 70 00 00 9A D6 01 01 01 71 00 00 9B D6 01 01 01 72 00 00 9C'\r\n 'D6 01 01 01 73 00 00 9D D6 01 01 01 74 00 00 9E D6 01 01 01 75 00 00 9F D6 01 01 01 76 00 00 A0'\r\n 'D6 01 01 01 77 00 00 A1 D6 01 01 01 78 00 00 A2 D6 01 01 01 79 00 00 A3 D6 01 01 01 7A 00 00 A4'\r\n 'D6 01 01 01 31 01 00 A5 D6 01 01 01 37 02 00 A8 D6 01 01 01 91 03 00 A9 D6 01 01 01 92 03 00 AA'\r\n 'D6 01 01 01 93 03 00 AB D6 01 01 01 94 03 00 AC D6 01 01 01 95 03 00 AD D6 01 01 01 96 03 00 AE'\r\n 'D6 01 01 01 97 03 00 AF D6 01 01 01 98 03 00 B0 D6 01 01 01 99 03 00 B1 D6 01 01 01 9A 03 00 B2'\r\n 'D6 01 01 01 9B 03 00 B3 D6 01 01 01 9C 03 00 B4 D6 01 01 01 9D 03 00 B5 D6 01 01 01 9E 03 00 B6'\r\n 'D6 01 01 01 9F 03 00 B7 D6 01 01 01 A0 03 00 B8 D6 01 01 01 A1 03 00 B9 D6 01 01 01 98 03 00 BA'\r\n 'D6 01 01 01 A3 03 00 BB D6 01 01 01 A4 03 00 BC D6 01 01 01 A5 03 00 BD D6 01 01 01 A6 03 00 BE'\r\n 'D6 01 01 01 A7 03 00 BF D6 01 01 01 A8 03 00 C0 D6 01 01 01 A9 03 00 C1 D6 01 01 01 07 22 00 C2'\r\n 'D6 01 01 01 B1 03 00 C3 D6 01 01 01 B2 03 00 C4 D6 01 01 01 B3 03 00 C5 D6 01 01 01 B4 03 00 C6'\r\n 'D6 01 01 01 B5 03 00 C7 D6 01 01 01 B6 03 00 C8 D6 01 01 01 B7 03 00 C9 D6 01 01 01 B8 03 00 CA'\r\n 'D6 01 01 01 B9 03 00 CB D6 01 01 01 BA 03 00 CC D6 01 01 01 BB 03 00 CD D6 01 01 01 BC 03 00 CE'\r\n 'D6 01 01 01 BD 03 00 CF D6 01 01 01 BE 03 00 D0 D6 01 01 01 BF 03 00 D1 D6 01 01 01 C0 03 00 D2'\r\n 'D6 01 01 01 C1 03 00 D3 D6 01 01 01 C2 03 00 D4 D6 01 01 01 C3 03 00 D5 D6 01 01 01 C4 03 00 D6'\r\n 'D6 01 01 01 C5 03 00 D7 D6 01 01 01 C6 03 00 D8 D6 01 01 01 C7 03 00 D9 D6 01 01 01 C8 03 00 DA'\r\n 'D6 01 01 01 C9 03 00 DB D6 01 01 01 02 22 00 DC D6 01 01 01 B5 03 00 DD D6 01 01 01 B8 03 00 DE'\r\n 'D6 01 01 01 BA 03 00 DF D6 01 01 01 C6 03 00 E0 D6 01 01 01 C1 03 00 E1 D6 01 01 01 C0 03 00 E2'\r\n 'D6 01 01 01 91 03 00 E3 D6 01 01 01 92 03 00 E4 D6 01 01 01 93 03 00 E5 D6 01 01 01 94 03 00 E6'\r\n 'D6 01 01 01 95 03 00 E7 D6 01 01 01 96 03 00 E8 D6 01 01 01 97 03 00 E9 D6 01 01 01 98 03 00 EA'\r\n 'D6 01 01 01 99 03 00 EB D6 01 01 01 9A 03 00 EC D6 01 01 01 9B 03 00 ED D6 01 01 01 9C 03 00 EE'\r\n 'D6 01 01 01 9D 03 00 EF D6 01 01 01 9E 03 00 F0 D6 01 01 01 9F 03 00 F1 D6 01 01 01 A0 03 00 F2'\r\n 'D6 01 01 01 A1 03 00 F3 D6 01 01 01 98 03 00 F4 D6 01 01 01 A3 03 00 F5 D6 01 01 01 A4 03 00 F6'\r\n 'D6 01 01 01 A5 03 00 F7 D6 01 01 01 A6 03 00 F8 D6 01 01 01 A7 03 00 F9 D6 01 01 01 A8 03 00 FA'\r\n 'D6 01 01 01 A9 03 00 FB D6 01 01 01 07 22 00 FC D6 01 01 01 B1 03 00 FD D6 01 01 01 B2 03 00 FE'\r\n 'D6 01 01 01 B3 03 00 FF D6 01 01 01 B4 03 00 00 D7 01 01 01 B5 03 00 01 D7 01 01 01 B6 03 00 02'\r\n 'D7 01 01 01 B7 03 00 03 D7 01 01 01 B8 03 00 04 D7 01 01 01 B9 03 00 05 D7 01 01 01 BA 03 00 06'\r\n 'D7 01 01 01 BB 03 00 07 D7 01 01 01 BC 03 00 08 D7 01 01 01 BD 03 00 09 D7 01 01 01 BE 03 00 0A'\r\n 'D7 01 01 01 BF 03 00 0B D7 01 01 01 C0 03 00 0C D7 01 01 01 C1 03 00 0D D7 01 01 01 C2 03 00 0E'\r\n 'D7 01 01 01 C3 03 00 0F D7 01 01 01 C4 03 00 10 D7 01 01 01 C5 03 00 11 D7 01 01 01 C6 03 00 12'\r\n 'D7 01 01 01 C7 03 00 13 D7 01 01 01 C8 03 00 14 D7 01 01 01 C9 03 00 15 D7 01 01 01 02 22 00 16'\r\n 'D7 01 01 01 B5 03 00 17 D7 01 01 01 B8 03 00 18 D7 01 01 01 BA 03 00 19 D7 01 01 01 C6 03 00 1A'\r\n 'D7 01 01 01 C1 03 00 1B D7 01 01 01 C0 03 00 1C D7 01 01 01 91 03 00 1D D7 01 01 01 92 03 00 1E'\r\n 'D7 01 01 01 93 03 00 1F D7 01 01 01 94 03 00 20 D7 01 01 01 95 03 00 21 D7 01 01 01 96 03 00 22'\r\n 'D7 01 01 01 97 03 00 23 D7 01 01 01 98 03 00 24 D7 01 01 01 99 03 00 25 D7 01 01 01 9A 03 00 26'\r\n 'D7 01 01 01 9B 03 00 27 D7 01 01 01 9C 03 00 28 D7 01 01 01 9D 03 00 29 D7 01 01 01 9E 03 00 2A'\r\n 'D7 01 01 01 9F 03 00 2B D7 01 01 01 A0 03 00 2C D7 01 01 01 A1 03 00 2D D7 01 01 01 98 03 00 2E'\r\n 'D7 01 01 01 A3 03 00 2F D7 01 01 01 A4 03 00 30 D7 01 01 01 A5 03 00 31 D7 01 01 01 A6 03 00 32'\r\n 'D7 01 01 01 A7 03 00 33 D7 01 01 01 A8 03 00 34 D7 01 01 01 A9 03 00 35 D7 01 01 01 07 22 00 36'\r\n 'D7 01 01 01 B1 03 00 37 D7 01 01 01 B2 03 00 38 D7 01 01 01 B3 03 00 39 D7 01 01 01 B4 03 00 3A'\r\n 'D7 01 01 01 B5 03 00 3B D7 01 01 01 B6 03 00 3C D7 01 01 01 B7 03 00 3D D7 01 01 01 B8 03 00 3E'\r\n 'D7 01 01 01 B9 03 00 3F D7 01 01 01 BA 03 00 40 D7 01 01 01 BB 03 00 41 D7 01 01 01 BC 03 00 42'\r\n 'D7 01 01 01 BD 03 00 43 D7 01 01 01 BE 03 00 44 D7 01 01 01 BF 03 00 45 D7 01 01 01 C0 03 00 46'\r\n 'D7 01 01 01 C1 03 00 47 D7 01 01 01 C2 03 00 48 D7 01 01 01 C3 03 00 49 D7 01 01 01 C4 03 00 4A'\r\n 'D7 01 01 01 C5 03 00 4B D7 01 01 01 C6 03 00 4C D7 01 01 01 C7 03 00 4D D7 01 01 01 C8 03 00 4E'\r\n 'D7 01 01 01 C9 03 00 4F D7 01 01 01 02 22 00 50 D7 01 01 01 B5 03 00 51 D7 01 01 01 B8 03 00 52'\r\n 'D7 01 01 01 BA 03 00 53 D7 01 01 01 C6 03 00 54 D7 01 01 01 C1 03 00 55 D7 01 01 01 C0 03 00 56'\r\n 'D7 01 01 01 91 03 00 57 D7 01 01 01 92 03 00 58 D7 01 01 01 93 03 00 59 D7 01 01 01 94 03 00 5A'\r\n 'D7 01 01 01 95 03 00 5B D7 01 01 01 96 03 00 5C D7 01 01 01 97 03 00 5D D7 01 01 01 98 03 00 5E'\r\n 'D7 01 01 01 99 03 00 5F D7 01 01 01 9A 03 00 60 D7 01 01 01 9B 03 00 61 D7 01 01 01 9C 03 00 62'\r\n 'D7 01 01 01 9D 03 00 63 D7 01 01 01 9E 03 00 64 D7 01 01 01 9F 03 00 65 D7 01 01 01 A0 03 00 66'\r\n 'D7 01 01 01 A1 03 00 67 D7 01 01 01 98 03 00 68 D7 01 01 01 A3 03 00 69 D7 01 01 01 A4 03 00 6A'\r\n 'D7 01 01 01 A5 03 00 6B D7 01 01 01 A6 03 00 6C D7 01 01 01 A7 03 00 6D D7 01 01 01 A8 03 00 6E'\r\n 'D7 01 01 01 A9 03 00 6F D7 01 01 01 07 22 00 70 D7 01 01 01 B1 03 00 71 D7 01 01 01 B2 03 00 72'\r\n 'D7 01 01 01 B3 03 00 73 D7 01 01 01 B4 03 00 74 D7 01 01 01 B5 03 00 75 D7 01 01 01 B6 03 00 76'\r\n 'D7 01 01 01 B7 03 00 77 D7 01 01 01 B8 03 00 78 D7 01 01 01 B9 03 00 79 D7 01 01 01 BA 03 00 7A'\r\n 'D7 01 01 01 BB 03 00 7B D7 01 01 01 BC 03 00 7C D7 01 01 01 BD 03 00 7D D7 01 01 01 BE 03 00 7E'\r\n 'D7 01 01 01 BF 03 00 7F D7 01 01 01 C0 03 00 80 D7 01 01 01 C1 03 00 81 D7 01 01 01 C2 03 00 82'\r\n 'D7 01 01 01 C3 03 00 83 D7 01 01 01 C4 03 00 84 D7 01 01 01 C5 03 00 85 D7 01 01 01 C6 03 00 86'\r\n 'D7 01 01 01 C7 03 00 87 D7 01 01 01 C8 03 00 88 D7 01 01 01 C9 03 00 89 D7 01 01 01 02 22 00 8A'\r\n 'D7 01 01 01 B5 03 00 8B D7 01 01 01 B8 03 00 8C D7 01 01 01 BA 03 00 8D D7 01 01 01 C6 03 00 8E'\r\n 'D7 01 01 01 C1 03 00 8F D7 01 01 01 C0 03 00 90 D7 01 01 01 91 03 00 91 D7 01 01 01 92 03 00 92'\r\n 'D7 01 01 01 93 03 00 93 D7 01 01 01 94 03 00 94 D7 01 01 01 95 03 00 95 D7 01 01 01 96 03 00 96'\r\n 'D7 01 01 01 97 03 00 97 D7 01 01 01 98 03 00 98 D7 01 01 01 99 03 00 99 D7 01 01 01 9A 03 00 9A'\r\n 'D7 01 01 01 9B 03 00 9B D7 01 01 01 9C 03 00 9C D7 01 01 01 9D 03 00 9D D7 01 01 01 9E 03 00 9E'\r\n 'D7 01 01 01 9F 03 00 9F D7 01 01 01 A0 03 00 A0 D7 01 01 01 A1 03 00 A1 D7 01 01 01 98 03 00 A2'\r\n 'D7 01 01 01 A3 03 00 A3 D7 01 01 01 A4 03 00 A4 D7 01 01 01 A5 03 00 A5 D7 01 01 01 A6 03 00 A6'\r\n 'D7 01 01 01 A7 03 00 A7 D7 01 01 01 A8 03 00 A8 D7 01 01 01 A9 03 00 A9 D7 01 01 01 07 22 00 AA'\r\n 'D7 01 01 01 B1 03 00 AB D7 01 01 01 B2 03 00 AC D7 01 01 01 B3 03 00 AD D7 01 01 01 B4 03 00 AE'\r\n 'D7 01 01 01 B5 03 00 AF D7 01 01 01 B6 03 00 B0 D7 01 01 01 B7 03 00 B1 D7 01 01 01 B8 03 00 B2'\r\n 'D7 01 01 01 B9 03 00 B3 D7 01 01 01 BA 03 00 B4 D7 01 01 01 BB 03 00 B5 D7 01 01 01 BC 03 00 B6'\r\n 'D7 01 01 01 BD 03 00 B7 D7 01 01 01 BE 03 00 B8 D7 01 01 01 BF 03 00 B9 D7 01 01 01 C0 03 00 BA'\r\n 'D7 01 01 01 C1 03 00 BB D7 01 01 01 C2 03 00 BC D7 01 01 01 C3 03 00 BD D7 01 01 01 C4 03 00 BE'\r\n 'D7 01 01 01 C5 03 00 BF D7 01 01 01 C6 03 00 C0 D7 01 01 01 C7 03 00 C1 D7 01 01 01 C8 03 00 C2'\r\n 'D7 01 01 01 C9 03 00 C3 D7 01 01 01 02 22 00 C4 D7 01 01 01 B5 03 00 C5 D7 01 01 01 B8 03 00 C6'\r\n 'D7 01 01 01 BA 03 00 C7 D7 01 01 01 C6 03 00 C8 D7 01 01 01 C1 03 00 C9 D7 01 01 01 C0 03 00 CA'\r\n 'D7 01 01 01 DC 03 00 CB D7 01 01 01 DD 03 00 CE D7 01 01 01 30 00 00 CF D7 01 01 01 31 00 00 D0'\r\n 'D7 01 01 01 32 00 00 D1 D7 01 01 01 33 00 00 D2 D7 01 01 01 34 00 00 D3 D7 01 01 01 35 00 00 D4'\r\n 'D7 01 01 01 36 00 00 D5 D7 01 01 01 37 00 00 D6 D7 01 01 01 38 00 00 D7 D7 01 01 01 39 00 00 D8'\r\n 'D7 01 01 01 30 00 00 D9 D7 01 01 01 31 00 00 DA D7 01 01 01 32 00 00 DB D7 01 01 01 33 00 00 DC'\r\n 'D7 01 01 01 34 00 00 DD D7 01 01 01 35 00 00 DE D7 01 01 01 36 00 00 DF D7 01 01 01 37 00 00 E0'\r\n 'D7 01 01 01 38 00 00 E1 D7 01 01 01 39 00 00 E2 D7 01 01 01 30 00 00 E3 D7 01 01 01 31 00 00 E4'\r\n 'D7 01 01 01 32 00 00 E5 D7 01 01 01 33 00 00 E6 D7 01 01 01 34 00 00 E7 D7 01 01 01 35 00 00 E8'\r\n 'D7 01 01 01 36 00 00 E9 D7 01 01 01 37 00 00 EA D7 01 01 01 38 00 00 EB D7 01 01 01 39 00 00 EC'\r\n 'D7 01 01 01 30 00 00 ED D7 01 01 01 31 00 00 EE D7 01 01 01 32 00 00 EF D7 01 01 01 33 00 00 F0'\r\n 'D7 01 01 01 34 00 00 F1 D7 01 01 01 35 00 00 F2 D7 01 01 01 36 00 00 F3 D7 01 01 01 37 00 00 F4'\r\n 'D7 01 01 01 38 00 00 F5 D7 01 01 01 39 00 00 F6 D7 01 01 01 30 00 00 F7 D7 01 01 01 31 00 00 F8'\r\n 'D7 01 01 01 32 00 00 F9 D7 01 01 01 33 00 00 FA D7 01 01 01 34 00 00 FB D7 01 01 01 35 00 00 FC'\r\n 'D7 01 01 01 36 00 00 FD D7 01 01 01 37 00 00 FE D7 01 01 01 38 00 00 FF D7 01 01 01 39 00 00 00'\r\n 'F1 01 02 10 30 00 00 2E 00 00 01 F1 01 02 10 30 00 00 2C 00 00 02 F1 01 02 10 31 00 00 2C 00 00'\r\n '03 F1 01 02 10 32 00 00 2C 00 00 04 F1 01 02 10 33 00 00 2C 00 00 05 F1 01 02 10 34 00 00 2C 00'\r\n '00 06 F1 01 02 10 35 00 00 2C 00 00 07 F1 01 02 10 36 00 00 2C 00 00 08 F1 01 02 10 37 00 00 2C'\r\n '00 00 09 F1 01 02 10 38 00 00 2C 00 00 0A F1 01 02 10 39 00 00 2C 00 00 10 F1 01 03 10 28 00 00'\r\n '41 00 00 29 00 00 11 F1 01 03 10 28 00 00 42 00 00 29 00 00 12 F1 01 03 10 28 00 00 43 00 00 29'\r\n '00 00 13 F1 01 03 10 28 00 00 44 00 00 29 00 00 14 F1 01 03 10 28 00 00 45 00 00 29 00 00 15 F1'\r\n '01 03 10 28 00 00 46 00 00 29 00 00 16 F1 01 03 10 28 00 00 47 00 00 29 00 00 17 F1 01 03 10 28'\r\n '00 00 48 00 00 29 00 00 18 F1 01 03 10 28 00 00 49 00 00 29 00 00 19 F1 01 03 10 28 00 00 4A 00'\r\n '00 29 00 00 1A F1 01 03 10 28 00 00 4B 00 00 29 00 00 1B F1 01 03 10 28 00 00 4C 00 00 29 00 00'\r\n '1C F1 01 03 10 28 00 00 4D 00 00 29 00 00 1D F1 01 03 10 28 00 00 4E 00 00 29 00 00 1E F1 01 03'\r\n '10 28 00 00 4F 00 00 29 00 00 1F F1 01 03 10 28 00 00 50 00 00 29 00 00 20 F1 01 03 10 28 00 00'\r\n '51 00 00 29 00 00 21 F1 01 03 10 28 00 00 52 00 00 29 00 00 22 F1 01 03 10 28 00 00 53 00 00 29'\r\n '00 00 23 F1 01 03 10 28 00 00 54 00 00 29 00 00 24 F1 01 03 10 28 00 00 55 00 00 29 00 00 25 F1'\r\n '01 03 10 28 00 00 56 00 00 29 00 00 26 F1 01 03 10 28 00 00 57 00 00 29 00 00 27 F1 01 03 10 28'\r\n '00 00 58 00 00 29 00 00 28 F1 01 03 10 28 00 00 59 00 00 29 00 00 29 F1 01 03 10 28 00 00 5A 00'\r\n '00 29 00 00 2A F1 01 03 10 14 30 00 53 00 00 15 30 00 2B F1 01 01 07 43 00 00 2C F1 01 01 07 52'\r\n '00 00 2D F1 01 02 07 43 00 00 44 00 00 2E F1 01 02 07 57 00 00 5A 00 00 30 F1 01 01 0E 41 00 00'\r\n '31 F1 01 01 0E 42 00 00 32 F1 01 01 0E 43 00 00 33 F1 01 01 0E 44 00 00 34 F1 01 01 0E 45 00 00'\r\n '35 F1 01 01 0E 46 00 00 36 F1 01 01 0E 47 00 00 37 F1 01 01 0E 48 00 00 38 F1 01 01 0E 49 00 00'\r\n '39 F1 01 01 0E 4A 00 00 3A F1 01 01 0E 4B 00 00 3B F1 01 01 0E 4C 00 00 3C F1 01 01 0E 4D 00 00'\r\n '3D F1 01 01 0E 4E 00 00 3E F1 01 01 0E 4F 00 00 3F F1 01 01 0E 50 00 00 40 F1 01 01 0E 51 00 00'\r\n '41 F1 01 01 0E 52 00 00 42 F1 01 01 0E 53 00 00 43 F1 01 01 0E 54 00 00 44 F1 01 01 0E 55 00 00'\r\n '45 F1 01 01 0E 56 00 00 46 F1 01 01 0E 57 00 00 47 F1 01 01 0E 58 00 00 48 F1 01 01 0E 59 00 00'\r\n '49 F1 01 01 0E 5A 00 00 4A F1 01 02 0E 48 00 00 56 00 00 4B F1 01 02 0E 4D 00 00 56 00 00 4C F1'\r\n '01 02 0E 53 00 00 44 00 00 4D F1 01 02 0E 53 00 00 53 00 00 4E F1 01 03 0E 50 00 00 50 00 00 56'\r\n '00 00 4F F1 01 02 0E 57 00 00 43 00 00 90 F1 01 02 0E 44 00 00 4A 00 00 00 F2 01 02 0E 7B 30 00'\r\n '4B 30 00 01 F2 01 02 0E B3 30 00 B3 30 00 02 F2 01 01 0E B5 30 00 10 F2 01 01 0E 4B 62 00 11 F2'\r\n '01 01 0E 57 5B 00 12 F2 01 01 0E CC 53 00 13 F2 01 02 0E C6 30 00 99 30 00 14 F2 01 01 0E 8C 4E'\r\n '00 15 F2 01 01 0E 1A 59 00 16 F2 01 01 0E E3 89 00 17 F2 01 01 0E 29 59 00 18 F2 01 01 0E A4 4E'\r\n '00 19 F2 01 01 0E 20 66 00 1A F2 01 01 0E 21 71 00 1B F2 01 01 0E 99 65 00 1C F2 01 01 0E 4D 52'\r\n '00 1D F2 01 01 0E 8C 5F 00 1E F2 01 01 0E 8D 51 00 1F F2 01 01 0E B0 65 00 20 F2 01 01 0E 1D 52'\r\n '00 21 F2 01 01 0E 42 7D 00 22 F2 01 01 0E 1F 75 00 23 F2 01 01 0E A9 8C 00 24 F2 01 01 0E F0 58'\r\n '00 25 F2 01 01 0E 39 54 00 26 F2 01 01 0E 14 6F 00 27 F2 01 01 0E 95 62 00 28 F2 01 01 0E 55 63'\r\n '00 29 F2 01 01 0E 00 4E 00 2A F2 01 01 0E 09 4E 00 2B F2 01 01 0E 4A 90 00 2C F2 01 01 0E E6 5D'\r\n '00 2D F2 01 01 0E 2D 4E 00 2E F2 01 01 0E F3 53 00 2F F2 01 01 0E 07 63 00 30 F2 01 01 0E 70 8D'\r\n '00 31 F2 01 01 0E 53 62 00 32 F2 01 01 0E 81 79 00 33 F2 01 01 0E 7A 7A 00 34 F2 01 01 0E 08 54'\r\n '00 35 F2 01 01 0E 80 6E 00 36 F2 01 01 0E 09 67 00 37 F2 01 01 0E 08 67 00 38 F2 01 01 0E 33 75'\r\n '00 39 F2 01 01 0E 72 52 00 3A F2 01 01 0E B6 55 00 40 F2 01 03 10 14 30 00 2C 67 00 15 30 00 41'\r\n 'F2 01 03 10 14 30 00 09 4E 00 15 30 00 42 F2 01 03 10 14 30 00 8C 4E 00 15 30 00 43 F2 01 03 10'\r\n '14 30 00 89 5B 00 15 30 00 44 F2 01 03 10 14 30 00 B9 70 00 15 30 00 45 F2 01 03 10 14 30 00 53'\r\n '62 00 15 30 00 46 F2 01 03 10 14 30 00 D7 76 00 15 30 00 47 F2 01 03 10 14 30 00 DD 52 00 15 30'\r\n '00 48 F2 01 03 10 14 30 00 57 65 00 15 30 00 50 F2 01 01 07 97 5F 00 51 F2 01 01 07 EF 53 00 00'\r\n 'F8 02 01 00 3D 4E 00 01 F8 02 01 00 38 4E 00 02 F8 02 01 00 41 4E 00 03 F8 02 01 00 22 01 02 04'\r\n 'F8 02 01 00 60 4F 00 05 F8 02 01 00 AE 4F 00 06 F8 02 01 00 BB 4F 00 07 F8 02 01 00 02 50 00 08'\r\n 'F8 02 01 00 7A 50 00 09 F8 02 01 00 99 50 00 0A F8 02 01 00 E7 50 00 0B F8 02 01 00 CF 50 00 0C'\r\n 'F8 02 01 00 9E 34 00 0D F8 02 01 00 3A 06 02 0E F8 02 01 00 4D 51 00 0F F8 02 01 00 54 51 00 10'\r\n 'F8 02 01 00 64 51 00 11 F8 02 01 00 77 51 00 12 F8 02 01 00 1C 05 02 13 F8 02 01 00 B9 34 00 14'\r\n 'F8 02 01 00 67 51 00 15 F8 02 01 00 8D 51 00 16 F8 02 01 00 4B 05 02 17 F8 02 01 00 97 51 00 18'\r\n 'F8 02 01 00 A4 51 00 19 F8 02 01 00 CC 4E 00 1A F8 02 01 00 AC 51 00 1B F8 02 01 00 B5 51 00 1C'\r\n 'F8 02 01 00 DF 91 02 1D F8 02 01 00 F5 51 00 1E F8 02 01 00 03 52 00 1F F8 02 01 00 DF 34 00 20'\r\n 'F8 02 01 00 3B 52 00 21 F8 02 01 00 46 52 00 22 F8 02 01 00 72 52 00 23 F8 02 01 00 77 52 00 24'\r\n 'F8 02 01 00 15 35 00 25 F8 02 01 00 C7 52 00 26 F8 02 01 00 C9 52 00 27 F8 02 01 00 E4 52 00 28'\r\n 'F8 02 01 00 FA 52 00 29 F8 02 01 00 05 53 00 2A F8 02 01 00 06 53 00 2B F8 02 01 00 17 53 00 2C'\r\n 'F8 02 01 00 49 53 00 2D F8 02 01 00 51 53 00 2E F8 02 01 00 5A 53 00 2F F8 02 01 00 73 53 00 30'\r\n 'F8 02 01 00 7D 53 00 31 F8 02 01 00 7F 53 00 32 F8 02 01 00 7F 53 00 33 F8 02 01 00 7F 53 00 34'\r\n 'F8 02 01 00 2C 0A 02 35 F8 02 01 00 70 70 00 36 F8 02 01 00 CA 53 00 37 F8 02 01 00 DF 53 00 38'\r\n 'F8 02 01 00 63 0B 02 39 F8 02 01 00 EB 53 00 3A F8 02 01 00 F1 53 00 3B F8 02 01 00 06 54 00 3C'\r\n 'F8 02 01 00 9E 54 00 3D F8 02 01 00 38 54 00 3E F8 02 01 00 48 54 00 3F F8 02 01 00 68 54 00 40'\r\n 'F8 02 01 00 A2 54 00 41 F8 02 01 00 F6 54 00 42 F8 02 01 00 10 55 00 43 F8 02 01 00 53 55 00 44'\r\n 'F8 02 01 00 63 55 00 45 F8 02 01 00 84 55 00 46 F8 02 01 00 84 55 00 47 F8 02 01 00 99 55 00 48'\r\n 'F8 02 01 00 AB 55 00 49 F8 02 01 00 B3 55 00 4A F8 02 01 00 C2 55 00 4B F8 02 01 00 16 57 00 4C'\r\n 'F8 02 01 00 06 56 00 4D F8 02 01 00 17 57 00 4E F8 02 01 00 51 56 00 4F F8 02 01 00 74 56 00 50'\r\n 'F8 02 01 00 07 52 00 51 F8 02 01 00 EE 58 00 52 F8 02 01 00 CE 57 00 53 F8 02 01 00 F4 57 00 54'\r\n 'F8 02 01 00 0D 58 00 55 F8 02 01 00 8B 57 00 56 F8 02 01 00 32 58 00 57 F8 02 01 00 31 58 00 58'\r\n 'F8 02 01 00 AC 58 00 59 F8 02 01 00 E4 14 02 5A F8 02 01 00 F2 58 00 5B F8 02 01 00 F7 58 00 5C'\r\n 'F8 02 01 00 06 59 00 5D F8 02 01 00 1A 59 00 5E F8 02 01 00 22 59 00 5F F8 02 01 00 62 59 00 60'\r\n 'F8 02 01 00 A8 16 02 61 F8 02 01 00 EA 16 02 62 F8 02 01 00 EC 59 00 63 F8 02 01 00 1B 5A 00 64'\r\n 'F8 02 01 00 27 5A 00 65 F8 02 01 00 D8 59 00 66 F8 02 01 00 66 5A 00 67 F8 02 01 00 EE 36 00 68'\r\n 'F8 02 01 00 FC 36 00 69 F8 02 01 00 08 5B 00 6A F8 02 01 00 3E 5B 00 6B F8 02 01 00 3E 5B 00 6C'\r\n 'F8 02 01 00 C8 19 02 6D F8 02 01 00 C3 5B 00 6E F8 02 01 00 D8 5B 00 6F F8 02 01 00 E7 5B 00 70'\r\n 'F8 02 01 00 F3 5B 00 71 F8 02 01 00 18 1B 02 72 F8 02 01 00 FF 5B 00 73 F8 02 01 00 06 5C 00 74'\r\n 'F8 02 01 00 53 5F 00 75 F8 02 01 00 22 5C 00 76 F8 02 01 00 81 37 00 77 F8 02 01 00 60 5C 00 78'\r\n 'F8 02 01 00 6E 5C 00 79 F8 02 01 00 C0 5C 00 7A F8 02 01 00 8D 5C 00 7B F8 02 01 00 E4 1D 02 7C'\r\n 'F8 02 01 00 43 5D 00 7D F8 02 01 00 E6 1D 02 7E F8 02 01 00 6E 5D 00 7F F8 02 01 00 6B 5D 00 80'\r\n 'F8 02 01 00 7C 5D 00 81 F8 02 01 00 E1 5D 00 82 F8 02 01 00 E2 5D 00 83 F8 02 01 00 2F 38 00 84'\r\n 'F8 02 01 00 FD 5D 00 85 F8 02 01 00 28 5E 00 86 F8 02 01 00 3D 5E 00 87 F8 02 01 00 69 5E 00 88'\r\n 'F8 02 01 00 62 38 00 89 F8 02 01 00 83 21 02 8A F8 02 01 00 7C 38 00 8B F8 02 01 00 B0 5E 00 8C'\r\n 'F8 02 01 00 B3 5E 00 8D F8 02 01 00 B6 5E 00 8E F8 02 01 00 CA 5E 00 8F F8 02 01 00 92 A3 02 90'\r\n 'F8 02 01 00 FE 5E 00 91 F8 02 01 00 31 23 02 92 F8 02 01 00 31 23 02 93 F8 02 01 00 01 82 00 94'\r\n 'F8 02 01 00 22 5F 00 95 F8 02 01 00 22 5F 00 96 F8 02 01 00 C7 38 00 97 F8 02 01 00 B8 32 02 98'\r\n 'F8 02 01 00 DA 61 02 99 F8 02 01 00 62 5F 00 9A F8 02 01 00 6B 5F 00 9B F8 02 01 00 E3 38 00 9C'\r\n 'F8 02 01 00 9A 5F 00 9D F8 02 01 00 CD 5F 00 9E F8 02 01 00 D7 5F 00 9F F8 02 01 00 F9 5F 00 A0'\r\n 'F8 02 01 00 81 60 00 A1 F8 02 01 00 3A 39 00 A2 F8 02 01 00 1C 39 00 A3 F8 02 01 00 94 60 00 A4'\r\n 'F8 02 01 00 D4 26 02 A5 F8 02 01 00 C7 60 00 A6 F8 02 01 00 48 61 00 A7 F8 02 01 00 4C 61 00 A8'\r\n 'F8 02 01 00 4E 61 00 A9 F8 02 01 00 4C 61 00 AA F8 02 01 00 7A 61 00 AB F8 02 01 00 8E 61 00 AC'\r\n 'F8 02 01 00 B2 61 00 AD F8 02 01 00 A4 61 00 AE F8 02 01 00 AF 61 00 AF F8 02 01 00 DE 61 00 B0'\r\n 'F8 02 01 00 F2 61 00 B1 F8 02 01 00 F6 61 00 B2 F8 02 01 00 10 62 00 B3 F8 02 01 00 1B 62 00 B4'\r\n 'F8 02 01 00 5D 62 00 B5 F8 02 01 00 B1 62 00 B6 F8 02 01 00 D4 62 00 B7 F8 02 01 00 50 63 00 B8'\r\n 'F8 02 01 00 0C 2B 02 B9 F8 02 01 00 3D 63 00 BA F8 02 01 00 FC 62 00 BB F8 02 01 00 68 63 00 BC'\r\n 'F8 02 01 00 83 63 00 BD F8 02 01 00 E4 63 00 BE F8 02 01 00 F1 2B 02 BF F8 02 01 00 22 64 00 C0'\r\n 'F8 02 01 00 C5 63 00 C1 F8 02 01 00 A9 63 00 C2 F8 02 01 00 2E 3A 00 C3 F8 02 01 00 69 64 00 C4'\r\n 'F8 02 01 00 7E 64 00 C5 F8 02 01 00 9D 64 00 C6 F8 02 01 00 77 64 00 C7 F8 02 01 00 6C 3A 00 C8'\r\n 'F8 02 01 00 4F 65 00 C9 F8 02 01 00 6C 65 00 CA F8 02 01 00 0A 30 02 CB F8 02 01 00 E3 65 00 CC'\r\n 'F8 02 01 00 F8 66 00 CD F8 02 01 00 49 66 00 CE F8 02 01 00 19 3B 00 CF F8 02 01 00 91 66 00 D0'\r\n 'F8 02 01 00 08 3B 00 D1 F8 02 01 00 E4 3A 00 D2 F8 02 01 00 92 51 00 D3 F8 02 01 00 95 51 00 D4'\r\n 'F8 02 01 00 00 67 00 D5 F8 02 01 00 9C 66 00 D6 F8 02 01 00 AD 80 00 D7 F8 02 01 00 D9 43 00 D8'\r\n 'F8 02 01 00 17 67 00 D9 F8 02 01 00 1B 67 00 DA F8 02 01 00 21 67 00 DB F8 02 01 00 5E 67 00 DC'\r\n 'F8 02 01 00 53 67 00 DD F8 02 01 00 C3 33 02 DE F8 02 01 00 49 3B 00 DF F8 02 01 00 FA 67 00 E0'\r\n 'F8 02 01 00 85 67 00 E1 F8 02 01 00 52 68 00 E2 F8 02 01 00 85 68 00 E3 F8 02 01 00 6D 34 02 E4'\r\n 'F8 02 01 00 8E 68 00 E5 F8 02 01 00 1F 68 00 E6 F8 02 01 00 14 69 00 E7 F8 02 01 00 9D 3B 00 E8'\r\n 'F8 02 01 00 42 69 00 E9 F8 02 01 00 A3 69 00 EA F8 02 01 00 EA 69 00 EB F8 02 01 00 A8 6A 00 EC'\r\n 'F8 02 01 00 A3 36 02 ED F8 02 01 00 DB 6A 00 EE F8 02 01 00 18 3C 00 EF F8 02 01 00 21 6B 00 F0'\r\n 'F8 02 01 00 A7 38 02 F1 F8 02 01 00 54 6B 00 F2 F8 02 01 00 4E 3C 00 F3 F8 02 01 00 72 6B 00 F4'\r\n 'F8 02 01 00 9F 6B 00 F5 F8 02 01 00 BA 6B 00 F6 F8 02 01 00 BB 6B 00 F7 F8 02 01 00 8D 3A 02 F8'\r\n 'F8 02 01 00 0B 1D 02 F9 F8 02 01 00 FA 3A 02 FA F8 02 01 00 4E 6C 00 FB F8 02 01 00 BC 3C 02 FC'\r\n 'F8 02 01 00 BF 6C 00 FD F8 02 01 00 CD 6C 00 FE F8 02 01 00 67 6C 00 FF F8 02 01 00 16 6D 00 00'\r\n 'F9 02 01 00 3E 6D 00 01 F9 02 01 00 77 6D 00 02 F9 02 01 00 41 6D 00 03 F9 02 01 00 69 6D 00 04'\r\n 'F9 02 01 00 78 6D 00 05 F9 02 01 00 85 6D 00 06 F9 02 01 00 1E 3D 02 07 F9 02 01 00 34 6D 00 08'\r\n 'F9 02 01 00 2F 6E 00 09 F9 02 01 00 6E 6E 00 0A F9 02 01 00 33 3D 00 0B F9 02 01 00 CB 6E 00 0C'\r\n 'F9 02 01 00 C7 6E 00 0D F9 02 01 00 D1 3E 02 0E F9 02 01 00 F9 6D 00 0F F9 02 01 00 6E 6F 00 10'\r\n 'F9 02 01 00 5E 3F 02 11 F9 02 01 00 8E 3F 02 12 F9 02 01 00 C6 6F 00 13 F9 02 01 00 39 70 00 14'\r\n 'F9 02 01 00 1E 70 00 15 F9 02 01 00 1B 70 00 16 F9 02 01 00 96 3D 00 17 F9 02 01 00 4A 70 00 18'\r\n 'F9 02 01 00 7D 70 00 19 F9 02 01 00 77 70 00 1A F9 02 01 00 AD 70 00 1B F9 02 01 00 25 05 02 1C'\r\n 'F9 02 01 00 45 71 00 1D F9 02 01 00 63 42 02 1E F9 02 01 00 9C 71 00 1F F9 02 01 00 AB 43 02 20'\r\n 'F9 02 01 00 28 72 00 21 F9 02 01 00 35 72 00 22 F9 02 01 00 50 72 00 23 F9 02 01 00 08 46 02 24'\r\n 'F9 02 01 00 80 72 00 25 F9 02 01 00 95 72 00 26 F9 02 01 00 35 47 02 27 F9 02 01 00 14 48 02 28'\r\n 'F9 02 01 00 7A 73 00 29 F9 02 01 00 8B 73 00 2A F9 02 01 00 AC 3E 00 2B F9 02 01 00 A5 73 00 2C'\r\n 'F9 02 01 00 B8 3E 00 2D F9 02 01 00 B8 3E 00 2E F9 02 01 00 47 74 00 2F F9 02 01 00 5C 74 00 30'\r\n 'F9 02 01 00 71 74 00 31 F9 02 01 00 85 74 00 32 F9 02 01 00 CA 74 00 33 F9 02 01 00 1B 3F 00 34'\r\n 'F9 02 01 00 24 75 00 35 F9 02 01 00 36 4C 02 36 F9 02 01 00 3E 75 00 37 F9 02 01 00 92 4C 02 38'\r\n 'F9 02 01 00 70 75 00 39 F9 02 01 00 9F 21 02 3A F9 02 01 00 10 76 00 3B F9 02 01 00 A1 4F 02 3C'\r\n 'F9 02 01 00 B8 4F 02 3D F9 02 01 00 44 50 02 3E F9 02 01 00 FC 3F 00 3F F9 02 01 00 08 40 00 40'\r\n 'F9 02 01 00 F4 76 00 41 F9 02 01 00 F3 50 02 42 F9 02 01 00 F2 50 02 43 F9 02 01 00 19 51 02 44'\r\n 'F9 02 01 00 33 51 02 45 F9 02 01 00 1E 77 00 46 F9 02 01 00 1F 77 00 47 F9 02 01 00 1F 77 00 48'\r\n 'F9 02 01 00 4A 77 00 49 F9 02 01 00 39 40 00 4A F9 02 01 00 8B 77 00 4B F9 02 01 00 46 40 00 4C'\r\n 'F9 02 01 00 96 40 00 4D F9 02 01 00 1D 54 02 4E F9 02 01 00 4E 78 00 4F F9 02 01 00 8C 78 00 50'\r\n 'F9 02 01 00 CC 78 00 51 F9 02 01 00 E3 40 00 52 F9 02 01 00 26 56 02 53 F9 02 01 00 56 79 00 54'\r\n 'F9 02 01 00 9A 56 02 55 F9 02 01 00 C5 56 02 56 F9 02 01 00 8F 79 00 57 F9 02 01 00 EB 79 00 58'\r\n 'F9 02 01 00 2F 41 00 59 F9 02 01 00 40 7A 00 5A F9 02 01 00 4A 7A 00 5B F9 02 01 00 4F 7A 00 5C'\r\n 'F9 02 01 00 7C 59 02 5D F9 02 01 00 A7 5A 02 5E F9 02 01 00 A7 5A 02 5F F9 02 01 00 EE 7A 00 60'\r\n 'F9 02 01 00 02 42 00 61 F9 02 01 00 AB 5B 02 62 F9 02 01 00 C6 7B 00 63 F9 02 01 00 C9 7B 00 64'\r\n 'F9 02 01 00 27 42 00 65 F9 02 01 00 80 5C 02 66 F9 02 01 00 D2 7C 00 67 F9 02 01 00 A0 42 00 68'\r\n 'F9 02 01 00 E8 7C 00 69 F9 02 01 00 E3 7C 00 6A F9 02 01 00 00 7D 00 6B F9 02 01 00 86 5F 02 6C'\r\n 'F9 02 01 00 63 7D 00 6D F9 02 01 00 01 43 00 6E F9 02 01 00 C7 7D 00 6F F9 02 01 00 02 7E 00 70'\r\n 'F9 02 01 00 45 7E 00 71 F9 02 01 00 34 43 00 72 F9 02 01 00 28 62 02 73 F9 02 01 00 47 62 02 74'\r\n 'F9 02 01 00 59 43 00 75 F9 02 01 00 D9 62 02 76 F9 02 01 00 7A 7F 00 77 F9 02 01 00 3E 63 02 78'\r\n 'F9 02 01 00 95 7F 00 79 F9 02 01 00 FA 7F 00 7A F9 02 01 00 05 80 00 7B F9 02 01 00 DA 64 02 7C'\r\n 'F9 02 01 00 23 65 02 7D F9 02 01 00 60 80 00 7E F9 02 01 00 A8 65 02 7F F9 02 01 00 70 80 00 80'\r\n 'F9 02 01 00 5F 33 02 81 F9 02 01 00 D5 43 00 82 F9 02 01 00 B2 80 00 83 F9 02 01 00 03 81 00 84'\r\n 'F9 02 01 00 0B 44 00 85 F9 02 01 00 3E 81 00 86 F9 02 01 00 B5 5A 00 87 F9 02 01 00 A7 67 02 88'\r\n 'F9 02 01 00 B5 67 02 89 F9 02 01 00 93 33 02 8A F9 02 01 00 9C 33 02 8B F9 02 01 00 01 82 00 8C'\r\n 'F9 02 01 00 04 82 00 8D F9 02 01 00 9E 8F 00 8E F9 02 01 00 6B 44 00 8F F9 02 01 00 91 82 00 90'\r\n 'F9 02 01 00 8B 82 00 91 F9 02 01 00 9D 82 00 92 F9 02 01 00 B3 52 00 93 F9 02 01 00 B1 82 00 94'\r\n 'F9 02 01 00 B3 82 00 95 F9 02 01 00 BD 82 00 96 F9 02 01 00 E6 82 00 97 F9 02 01 00 3C 6B 02 98'\r\n 'F9 02 01 00 E5 82 00 99 F9 02 01 00 1D 83 00 9A F9 02 01 00 63 83 00 9B F9 02 01 00 AD 83 00 9C'\r\n 'F9 02 01 00 23 83 00 9D F9 02 01 00 BD 83 00 9E F9 02 01 00 E7 83 00 9F F9 02 01 00 57 84 00 A0'\r\n 'F9 02 01 00 53 83 00 A1 F9 02 01 00 CA 83 00 A2 F9 02 01 00 CC 83 00 A3 F9 02 01 00 DC 83 00 A4'\r\n 'F9 02 01 00 36 6C 02 A5 F9 02 01 00 6B 6D 02 A6 F9 02 01 00 D5 6C 02 A7 F9 02 01 00 2B 45 00 A8'\r\n 'F9 02 01 00 F1 84 00 A9 F9 02 01 00 F3 84 00 AA F9 02 01 00 16 85 00 AB F9 02 01 00 CA 73 02 AC'\r\n 'F9 02 01 00 64 85 00 AD F9 02 01 00 2C 6F 02 AE F9 02 01 00 5D 45 00 AF F9 02 01 00 61 45 00 B0'\r\n 'F9 02 01 00 B1 6F 02 B1 F9 02 01 00 D2 70 02 B2 F9 02 01 00 6B 45 00 B3 F9 02 01 00 50 86 00 B4'\r\n 'F9 02 01 00 5C 86 00 B5 F9 02 01 00 67 86 00 B6 F9 02 01 00 69 86 00 B7 F9 02 01 00 A9 86 00 B8'\r\n 'F9 02 01 00 88 86 00 B9 F9 02 01 00 0E 87 00 BA F9 02 01 00 E2 86 00 BB F9 02 01 00 79 87 00 BC'\r\n 'F9 02 01 00 28 87 00 BD F9 02 01 00 6B 87 00 BE F9 02 01 00 86 87 00 BF F9 02 01 00 D7 45 00 C0'\r\n 'F9 02 01 00 E1 87 00 C1 F9 02 01 00 01 88 00 C2 F9 02 01 00 F9 45 00 C3 F9 02 01 00 60 88 00 C4'\r\n 'F9 02 01 00 63 88 00 C5 F9 02 01 00 67 76 02 C6 F9 02 01 00 D7 88 00 C7 F9 02 01 00 DE 88 00 C8'\r\n 'F9 02 01 00 35 46 00 C9 F9 02 01 00 FA 88 00 CA F9 02 01 00 BB 34 00 CB F9 02 01 00 AE 78 02 CC'\r\n 'F9 02 01 00 66 79 02 CD F9 02 01 00 BE 46 00 CE F9 02 01 00 C7 46 00 CF F9 02 01 00 A0 8A 00 D0'\r\n 'F9 02 01 00 ED 8A 00 D1 F9 02 01 00 8A 8B 00 D2 F9 02 01 00 55 8C 00 D3 F9 02 01 00 A8 7C 02 D4'\r\n 'F9 02 01 00 AB 8C 00 D5 F9 02 01 00 C1 8C 00 D6 F9 02 01 00 1B 8D 00 D7 F9 02 01 00 77 8D 00 D8'\r\n 'F9 02 01 00 2F 7F 02 D9 F9 02 01 00 04 08 02 DA F9 02 01 00 CB 8D 00 DB F9 02 01 00 BC 8D 00 DC'\r\n 'F9 02 01 00 F0 8D 00 DD F9 02 01 00 DE 08 02 DE F9 02 01 00 D4 8E 00 DF F9 02 01 00 38 8F 00 E0'\r\n 'F9 02 01 00 D2 85 02 E1 F9 02 01 00 ED 85 02 E2 F9 02 01 00 94 90 00 E3 F9 02 01 00 F1 90 00 E4'\r\n 'F9 02 01 00 11 91 00 E5 F9 02 01 00 2E 87 02 E6 F9 02 01 00 1B 91 00 E7 F9 02 01 00 38 92 00 E8'\r\n 'F9 02 01 00 D7 92 00 E9 F9 02 01 00 D8 92 00 EA F9 02 01 00 7C 92 00 EB F9 02 01 00 F9 93 00 EC'\r\n 'F9 02 01 00 15 94 00 ED F9 02 01 00 FA 8B 02 EE F9 02 01 00 8B 95 00 EF F9 02 01 00 95 49 00 F0'\r\n 'F9 02 01 00 B7 95 00 F1 F9 02 01 00 77 8D 02 F2 F9 02 01 00 E6 49 00 F3 F9 02 01 00 C3 96 00 F4'\r\n 'F9 02 01 00 B2 5D 00 F5 F9 02 01 00 23 97 00 F6 F9 02 01 00 45 91 02 F7 F9 02 01 00 1A 92 02 F8'\r\n 'F9 02 01 00 6E 4A 00 F9 F9 02 01 00 76 4A 00 FA F9 02 01 00 E0 97 00 FB F9 02 01 00 0A 94 02 FC'\r\n 'F9 02 01 00 B2 4A 00 FD F9 02 01 00 96 94 02 FE F9 02 01 00 0B 98 00 FF F9 02 01 00 0B 98 00 00'\r\n 'FA 02 01 00 29 98 00 01 FA 02 01 00 B6 95 02 02 FA 02 01 00 E2 98 00 03 FA 02 01 00 33 4B 00 04'\r\n 'FA 02 01 00 29 99 00 05 FA 02 01 00 A7 99 00 06 FA 02 01 00 C2 99 00 07 FA 02 01 00 FE 99 00 08'\r\n 'FA 02 01 00 CE 4B 00 09 FA 02 01 00 30 9B 02 0A FA 02 01 00 12 9B 00 0B FA 02 01 00 40 9C 00 0C'\r\n 'FA 02 01 00 FD 9C 00 0D FA 02 01 00 CE 4C 00 0E FA 02 01 00 ED 4C 00 0F FA 02 01 00 67 9D 00 10'\r\n 'FA 02 01 00 CE A0 02 11 FA 02 01 00 F8 4C 00 12 FA 02 01 00 05 A1 02 13 FA 02 01 00 0E A2 02 14'\r\n 'FA 02 01 00 91 A2 02 15 FA 02 01 00 BB 9E 00 16 FA 02 01 00 56 4D 00 17 FA 02 01 00 F9 9E 00 18'\r\n 'FA 02 01 00 FE 9E 00 19 FA 02 01 00 05 9F 00 1A FA 02 01 00 0F 9F 00 1B FA 02 01 00 16 9F 00 1C'\r\n 'FA 02 01 00 3B 9F 00 1D FA 02 01 00 00 A6 02'\r\n}\r\n\r\n\r\nLANGUAGE 0,0 COMBINING UNICODEDATA LOADONCALL MOVEABLE DISCARDABLE\r\n{\r\n '01 09 34 03 00 38 03 00 D4 1C 00 D4 1C 00 E2 1C 00 E8 1C 00 D2 20 00 D3 20 00 D8 20 00 DA 20 00'\r\n 'E5 20 00 E6 20 00 EA 20 00 EB 20 00 39 0A 01 39 0A 01 67 D1 01 69 D1 01 07 0C 3C 09 00 3C 09 00'\r\n 'BC 09 00 BC 09 00 3C 0A 00 3C 0A 00 BC 0A 00 BC 0A 00 3C 0B 00 3C 0B 00 BC 0C 00 BC 0C 00 37 10'\r\n '00 37 10 00 34 1B 00 34 1B 00 E6 1B 00 E6 1B 00 37 1C 00 37 1C 00 B3 A9 00 B3 A9 00 BA 10 01 BA'\r\n '10 01 08 01 99 30 00 9A 30 00 09 1D 4D 09 00 4D 09 00 CD 09 00 CD 09 00 4D 0A 00 4D 0A 00 CD 0A'\r\n '00 CD 0A 00 4D 0B 00 4D 0B 00 CD 0B 00 CD 0B 00 4D 0C 00 4D 0C 00 CD 0C 00 CD 0C 00 4D 0D 00 4D'\r\n '0D 00 CA 0D 00 CA 0D 00 3A 0E 00 3A 0E 00 84 0F 00 84 0F 00 39 10 00 3A 10 00 14 17 00 14 17 00'\r\n '34 17 00 34 17 00 D2 17 00 D2 17 00 60 1A 00 60 1A 00 44 1B 00 44 1B 00 AA 1B 00 AA 1B 00 F2 1B'\r\n '00 F3 1B 00 7F 2D 00 7F 2D 00 06 A8 00 06 A8 00 C4 A8 00 C4 A8 00 53 A9 00 53 A9 00 C0 A9 00 C0'\r\n 'A9 00 ED AB 00 ED AB 00 3F 0A 01 3F 0A 01 46 10 01 46 10 01 B9 10 01 B9 10 01 0A 01 B0 05 00 B0'\r\n '05 00 0B 01 B1 05 00 B1 05 00 0C 01 B2 05 00 B2 05 00 0D 01 B3 05 00 B3 05 00 0E 01 B4 05 00 B4'\r\n '05 00 0F 01 B5 05 00 B5 05 00 10 01 B6 05 00 B6 05 00 11 01 B7 05 00 B7 05 00 12 02 B8 05 00 B8'\r\n '05 00 C7 05 00 C7 05 00 13 01 B9 05 00 BA 05 00 14 01 BB 05 00 BB 05 00 15 01 BC 05 00 BC 05 00'\r\n '16 01 BD 05 00 BD 05 00 17 01 BF 05 00 BF 05 00 18 01 C1 05 00 C1 05 00 19 01 C2 05 00 C2 05 00'\r\n '1A 01 1E FB 00 1E FB 00 1B 01 4B 06 00 4B 06 00 1C 01 4C 06 00 4C 06 00 1D 01 4D 06 00 4D 06 00'\r\n '1E 02 18 06 00 18 06 00 4E 06 00 4E 06 00 1F 02 19 06 00 19 06 00 4F 06 00 4F 06 00 20 02 1A 06'\r\n '00 1A 06 00 50 06 00 50 06 00 21 01 51 06 00 51 06 00 22 01 52 06 00 52 06 00 23 01 70 06 00 70'\r\n '06 00 24 01 11 07 00 11 07 00 54 01 55 0C 00 55 0C 00 5B 01 56 0C 00 56 0C 00 67 01 38 0E 00 39'\r\n '0E 00 6B 01 48 0E 00 4B 0E 00 76 01 B8 0E 00 B9 0E 00 7A 01 C8 0E 00 CB 0E 00 81 01 71 0F 00 71'\r\n '0F 00 82 03 72 0F 00 72 0F 00 7A 0F 00 7D 0F 00 80 0F 00 80 0F 00 84 01 74 0F 00 74 0F 00 CA 03'\r\n '21 03 00 22 03 00 27 03 00 28 03 00 D0 1D 00 D0 1D 00 D6 01 CE 1D 00 CE 1D 00 D8 04 1B 03 00 1B'\r\n '03 00 39 0F 00 39 0F 00 65 D1 01 66 D1 01 6E D1 01 72 D1 01 DA 01 2A 30 00 2A 30 00 DC 3B 16 03'\r\n '00 19 03 00 1C 03 00 20 03 00 23 03 00 26 03 00 29 03 00 33 03 00 39 03 00 3C 03 00 47 03 00 49'\r\n '03 00 4D 03 00 4E 03 00 53 03 00 56 03 00 59 03 00 5A 03 00 91 05 00 91 05 00 96 05 00 96 05 00'\r\n '9B 05 00 9B 05 00 A2 05 00 A7 05 00 AA 05 00 AA 05 00 C5 05 00 C5 05 00 55 06 00 56 06 00 5C 06'\r\n '00 5C 06 00 5F 06 00 5F 06 00 E3 06 00 E3 06 00 EA 06 00 EA 06 00 ED 06 00 ED 06 00 31 07 00 31'\r\n '07 00 34 07 00 34 07 00 37 07 00 39 07 00 3B 07 00 3C 07 00 3E 07 00 3E 07 00 42 07 00 42 07 00'\r\n '44 07 00 44 07 00 46 07 00 46 07 00 48 07 00 48 07 00 F2 07 00 F2 07 00 59 08 00 5B 08 00 52 09'\r\n '00 52 09 00 18 0F 00 19 0F 00 35 0F 00 35 0F 00 37 0F 00 37 0F 00 C6 0F 00 C6 0F 00 8D 10 00 8D'\r\n '10 00 3B 19 00 3B 19 00 18 1A 00 18 1A 00 7F 1A 00 7F 1A 00 6C 1B 00 6C 1B 00 D5 1C 00 D9 1C 00'\r\n 'DC 1C 00 DF 1C 00 ED 1C 00 ED 1C 00 C2 1D 00 C2 1D 00 CA 1D 00 CA 1D 00 CF 1D 00 CF 1D 00 FD 1D'\r\n '00 FD 1D 00 FF 1D 00 FF 1D 00 E8 20 00 E8 20 00 EC 20 00 EF 20 00 2B A9 00 2D A9 00 B4 AA 00 B4'\r\n 'AA 00 FD 01 01 FD 01 01 0D 0A 01 0D 0A 01 3A 0A 01 3A 0A 01 7B D1 01 82 D1 01 8A D1 01 8B D1 01'\r\n 'DE 04 9A 05 00 9A 05 00 AD 05 00 AD 05 00 39 19 00 39 19 00 2D 30 00 2D 30 00 E0 01 2E 30 00 2F'\r\n '30 00 E2 01 6D D1 01 6D D1 01 E4 03 AE 05 00 AE 05 00 A9 18 00 A9 18 00 2B 30 00 2B 30 00 E6 54'\r\n '00 03 00 14 03 00 3D 03 00 44 03 00 46 03 00 46 03 00 4A 03 00 4C 03 00 50 03 00 52 03 00 57 03'\r\n '00 57 03 00 5B 03 00 5B 03 00 63 03 00 6F 03 00 83 04 00 87 04 00 92 05 00 95 05 00 97 05 00 99'\r\n '05 00 9C 05 00 A1 05 00 A8 05 00 A9 05 00 AB 05 00 AC 05 00 AF 05 00 AF 05 00 C4 05 00 C4 05 00'\r\n '10 06 00 17 06 00 53 06 00 54 06 00 57 06 00 5B 06 00 5D 06 00 5E 06 00 D6 06 00 DC 06 00 DF 06'\r\n '00 E2 06 00 E4 06 00 E4 06 00 E7 06 00 E8 06 00 EB 06 00 EC 06 00 30 07 00 30 07 00 32 07 00 33'\r\n '07 00 35 07 00 36 07 00 3A 07 00 3A 07 00 3D 07 00 3D 07 00 3F 07 00 41 07 00 43 07 00 43 07 00'\r\n '45 07 00 45 07 00 47 07 00 47 07 00 49 07 00 4A 07 00 EB 07 00 F1 07 00 F3 07 00 F3 07 00 16 08'\r\n '00 19 08 00 1B 08 00 23 08 00 25 08 00 27 08 00 29 08 00 2D 08 00 51 09 00 51 09 00 53 09 00 54'\r\n '09 00 82 0F 00 83 0F 00 86 0F 00 87 0F 00 5D 13 00 5F 13 00 DD 17 00 DD 17 00 3A 19 00 3A 19 00'\r\n '17 1A 00 17 1A 00 75 1A 00 7C 1A 00 6B 1B 00 6B 1B 00 6D 1B 00 73 1B 00 D0 1C 00 D2 1C 00 DA 1C'\r\n '00 DB 1C 00 E0 1C 00 E0 1C 00 C0 1D 00 C1 1D 00 C3 1D 00 C9 1D 00 CB 1D 00 CC 1D 00 D1 1D 00 E6'\r\n '1D 00 FE 1D 00 FE 1D 00 D0 20 00 D1 20 00 D4 20 00 D7 20 00 DB 20 00 DC 20 00 E1 20 00 E1 20 00'\r\n 'E7 20 00 E7 20 00 E9 20 00 E9 20 00 F0 20 00 F0 20 00 EF 2C 00 F1 2C 00 E0 2D 00 FF 2D 00 6F A6'\r\n '00 6F A6 00 7C A6 00 7D A6 00 F0 A6 00 F1 A6 00 E0 A8 00 F1 A8 00 B0 AA 00 B0 AA 00 B2 AA 00 B3'\r\n 'AA 00 B7 AA 00 B8 AA 00 BE AA 00 BF AA 00 C1 AA 00 C1 AA 00 20 FE 00 26 FE 00 0F 0A 01 0F 0A 01'\r\n '38 0A 01 38 0A 01 85 D1 01 89 D1 01 AA D1 01 AD D1 01 42 D2 01 44 D2 01 E8 04 15 03 00 15 03 00'\r\n '1A 03 00 1A 03 00 58 03 00 58 03 00 2C 30 00 2C 30 00 E9 04 5C 03 00 5C 03 00 5F 03 00 5F 03 00'\r\n '62 03 00 62 03 00 FC 1D 00 FC 1D 00 EA 03 5D 03 00 5E 03 00 60 03 00 61 03 00 CD 1D 00 CD 1D 00'\r\n 'F0 01 45 03 00 45 03 00'\r\n}\r\n\r\n\r\nLANGUAGE 0,0 NUMBERS UNICODEDATA LOADONCALL MOVEABLE DISCARDABLE\r\n{\r\n '70 00 00 00 00 01 00 00 00 01 00 00 00 01 00 00 00 02 00 00 00 01 00 00 00 03 00 00 00 01 00 00'\r\n '00 04 00 00 00 01 00 00 00 05 00 00 00 01 00 00 00 06 00 00 00 01 00 00 00 07 00 00 00 01 00 00'\r\n '00 08 00 00 00 01 00 00 00 09 00 00 00 01 00 00 00 01 00 00 00 04 00 00 00 01 00 00 00 02 00 00'\r\n '00 03 00 00 00 04 00 00 00 01 00 00 00 10 00 00 00 01 00 00 00 08 00 00 00 03 00 00 00 10 00 00'\r\n '00 10 00 00 00 01 00 00 00 0A 00 00 00 01 00 00 00 64 00 00 00 01 00 00 00 E8 03 00 00 01 00 00'\r\n '00 03 00 00 00 02 00 00 00 05 00 00 00 02 00 00 00 07 00 00 00 02 00 00 00 09 00 00 00 02 00 00'\r\n '00 0B 00 00 00 02 00 00 00 0D 00 00 00 02 00 00 00 0F 00 00 00 02 00 00 00 11 00 00 00 02 00 00'\r\n '00 FF FF FF FF 02 00 00 00 14 00 00 00 01 00 00 00 1E 00 00 00 01 00 00 00 28 00 00 00 01 00 00'\r\n '00 32 00 00 00 01 00 00 00 3C 00 00 00 01 00 00 00 46 00 00 00 01 00 00 00 50 00 00 00 01 00 00'\r\n '00 5A 00 00 00 01 00 00 00 10 27 00 00 01 00 00 00 11 00 00 00 01 00 00 00 12 00 00 00 01 00 00'\r\n '00 13 00 00 00 01 00 00 00 01 00 00 00 07 00 00 00 01 00 00 00 09 00 00 00 01 00 00 00 0A 00 00'\r\n '00 01 00 00 00 03 00 00 00 02 00 00 00 03 00 00 00 01 00 00 00 05 00 00 00 02 00 00 00 05 00 00'\r\n '00 03 00 00 00 05 00 00 00 04 00 00 00 05 00 00 00 01 00 00 00 06 00 00 00 05 00 00 00 06 00 00'\r\n '00 03 00 00 00 08 00 00 00 05 00 00 00 08 00 00 00 07 00 00 00 08 00 00 00 0B 00 00 00 01 00 00'\r\n '00 0C 00 00 00 01 00 00 00 F4 01 00 00 01 00 00 00 88 13 00 00 01 00 00 00 50 C3 00 00 01 00 00'\r\n '00 A0 86 01 00 01 00 00 00 0D 00 00 00 01 00 00 00 0E 00 00 00 01 00 00 00 0F 00 00 00 01 00 00'\r\n '00 15 00 00 00 01 00 00 00 16 00 00 00 01 00 00 00 17 00 00 00 01 00 00 00 18 00 00 00 01 00 00'\r\n '00 19 00 00 00 01 00 00 00 1A 00 00 00 01 00 00 00 1B 00 00 00 01 00 00 00 1C 00 00 00 01 00 00'\r\n '00 1D 00 00 00 01 00 00 00 1F 00 00 00 01 00 00 00 20 00 00 00 01 00 00 00 21 00 00 00 01 00 00'\r\n '00 22 00 00 00 01 00 00 00 23 00 00 00 01 00 00 00 24 00 00 00 01 00 00 00 25 00 00 00 01 00 00'\r\n '00 26 00 00 00 01 00 00 00 27 00 00 00 01 00 00 00 29 00 00 00 01 00 00 00 2A 00 00 00 01 00 00'\r\n '00 2B 00 00 00 01 00 00 00 2C 00 00 00 01 00 00 00 2D 00 00 00 01 00 00 00 2E 00 00 00 01 00 00'\r\n '00 2F 00 00 00 01 00 00 00 30 00 00 00 01 00 00 00 31 00 00 00 01 00 00 00 C8 00 00 00 01 00 00'\r\n '00 2C 01 00 00 01 00 00 00 90 01 00 00 01 00 00 00 58 02 00 00 01 00 00 00 BC 02 00 00 01 00 00'\r\n '00 20 03 00 00 01 00 00 00 84 03 00 00 01 00 00 00 D0 07 00 00 01 00 00 00 B8 0B 00 00 01 00 00'\r\n '00 A0 0F 00 00 01 00 00 00 70 17 00 00 01 00 00 00 58 1B 00 00 01 00 00 00 40 1F 00 00 01 00 00'\r\n '00 28 23 00 00 01 00 00 00 20 4E 00 00 01 00 00 00 30 75 00 00 01 00 00 00 40 9C 00 00 01 00 00'\r\n '00 60 EA 00 00 01 00 00 00 70 11 01 00 01 00 00 00 80 38 01 00 01 00 00 00 90 5F 01 00 01 00 00'\r\n '00 50 04 00 00 30 00 00 00 31 00 00 01 32 00 00 02 33 00 00 03 34 00 00 04 35 00 00 05 36 00 00'\r\n '06 37 00 00 07 38 00 00 08 39 00 00 09 B2 00 00 02 B3 00 00 03 B9 00 00 01 BC 00 00 0A BD 00 00'\r\n '0B BE 00 00 0C 60 06 00 00 61 06 00 01 62 06 00 02 63 06 00 03 64 06 00 04 65 06 00 05 66 06 00'\r\n '06 67 06 00 07 68 06 00 08 69 06 00 09 F0 06 00 00 F1 06 00 01 F2 06 00 02 F3 06 00 03 F4 06 00'\r\n '04 F5 06 00 05 F6 06 00 06 F7 06 00 07 F8 06 00 08 F9 06 00 09 C0 07 00 00 C1 07 00 01 C2 07 00'\r\n '02 C3 07 00 03 C4 07 00 04 C5 07 00 05 C6 07 00 06 C7 07 00 07 C8 07 00 08 C9 07 00 09 66 09 00'\r\n '00 67 09 00 01 68 09 00 02 69 09 00 03 6A 09 00 04 6B 09 00 05 6C 09 00 06 6D 09 00 07 6E 09 00'\r\n '08 6F 09 00 09 E6 09 00 00 E7 09 00 01 E8 09 00 02 E9 09 00 03 EA 09 00 04 EB 09 00 05 EC 09 00'\r\n '06 ED 09 00 07 EE 09 00 08 EF 09 00 09 F4 09 00 0D F5 09 00 0E F6 09 00 0F F7 09 00 0A F8 09 00'\r\n '0C F9 09 00 10 66 0A 00 00 67 0A 00 01 68 0A 00 02 69 0A 00 03 6A 0A 00 04 6B 0A 00 05 6C 0A 00'\r\n '06 6D 0A 00 07 6E 0A 00 08 6F 0A 00 09 E6 0A 00 00 E7 0A 00 01 E8 0A 00 02 E9 0A 00 03 EA 0A 00'\r\n '04 EB 0A 00 05 EC 0A 00 06 ED 0A 00 07 EE 0A 00 08 EF 0A 00 09 66 0B 00 00 67 0B 00 01 68 0B 00'\r\n '02 69 0B 00 03 6A 0B 00 04 6B 0B 00 05 6C 0B 00 06 6D 0B 00 07 6E 0B 00 08 6F 0B 00 09 72 0B 00'\r\n '0A 73 0B 00 0B 74 0B 00 0C 75 0B 00 0D 76 0B 00 0E 77 0B 00 0F E6 0B 00 00 E7 0B 00 01 E8 0B 00'\r\n '02 E9 0B 00 03 EA 0B 00 04 EB 0B 00 05 EC 0B 00 06 ED 0B 00 07 EE 0B 00 08 EF 0B 00 09 F0 0B 00'\r\n '11 F1 0B 00 12 F2 0B 00 13 66 0C 00 00 67 0C 00 01 68 0C 00 02 69 0C 00 03 6A 0C 00 04 6B 0C 00'\r\n '05 6C 0C 00 06 6D 0C 00 07 6E 0C 00 08 6F 0C 00 09 78 0C 00 00 79 0C 00 01 7A 0C 00 02 7B 0C 00'\r\n '03 7C 0C 00 01 7D 0C 00 02 7E 0C 00 03 E6 0C 00 00 E7 0C 00 01 E8 0C 00 02 E9 0C 00 03 EA 0C 00'\r\n '04 EB 0C 00 05 EC 0C 00 06 ED 0C 00 07 EE 0C 00 08 EF 0C 00 09 66 0D 00 00 67 0D 00 01 68 0D 00'\r\n '02 69 0D 00 03 6A 0D 00 04 6B 0D 00 05 6C 0D 00 06 6D 0D 00 07 6E 0D 00 08 6F 0D 00 09 70 0D 00'\r\n '11 71 0D 00 12 72 0D 00 13 73 0D 00 0A 74 0D 00 0B 75 0D 00 0C 50 0E 00 00 51 0E 00 01 52 0E 00'\r\n '02 53 0E 00 03 54 0E 00 04 55 0E 00 05 56 0E 00 06 57 0E 00 07 58 0E 00 08 59 0E 00 09 D0 0E 00'\r\n '00 D1 0E 00 01 D2 0E 00 02 D3 0E 00 03 D4 0E 00 04 D5 0E 00 05 D6 0E 00 06 D7 0E 00 07 D8 0E 00'\r\n '08 D9 0E 00 09 20 0F 00 00 21 0F 00 01 22 0F 00 02 23 0F 00 03 24 0F 00 04 25 0F 00 05 26 0F 00'\r\n '06 27 0F 00 07 28 0F 00 08 29 0F 00 09 2A 0F 00 0B 2B 0F 00 14 2C 0F 00 15 2D 0F 00 16 2E 0F 00'\r\n '17 2F 0F 00 18 30 0F 00 19 31 0F 00 1A 32 0F 00 1B 33 0F 00 1C 40 10 00 00 41 10 00 01 42 10 00'\r\n '02 43 10 00 03 44 10 00 04 45 10 00 05 46 10 00 06 47 10 00 07 48 10 00 08 49 10 00 09 90 10 00'\r\n '00 91 10 00 01 92 10 00 02 93 10 00 03 94 10 00 04 95 10 00 05 96 10 00 06 97 10 00 07 98 10 00'\r\n '08 99 10 00 09 69 13 00 01 6A 13 00 02 6B 13 00 03 6C 13 00 04 6D 13 00 05 6E 13 00 06 6F 13 00'\r\n '07 70 13 00 08 71 13 00 09 72 13 00 11 73 13 00 1D 74 13 00 1E 75 13 00 1F 76 13 00 20 77 13 00'\r\n '21 78 13 00 22 79 13 00 23 7A 13 00 24 7B 13 00 12 7C 13 00 25 EE 16 00 26 EF 16 00 27 F0 16 00'\r\n '28 E0 17 00 00 E1 17 00 01 E2 17 00 02 E3 17 00 03 E4 17 00 04 E5 17 00 05 E6 17 00 06 E7 17 00'\r\n '07 E8 17 00 08 E9 17 00 09 F0 17 00 00 F1 17 00 01 F2 17 00 02 F3 17 00 03 F4 17 00 04 F5 17 00'\r\n '05 F6 17 00 06 F7 17 00 07 F8 17 00 08 F9 17 00 09 10 18 00 00 11 18 00 01 12 18 00 02 13 18 00'\r\n '03 14 18 00 04 15 18 00 05 16 18 00 06 17 18 00 07 18 18 00 08 19 18 00 09 46 19 00 00 47 19 00'\r\n '01 48 19 00 02 49 19 00 03 4A 19 00 04 4B 19 00 05 4C 19 00 06 4D 19 00 07 4E 19 00 08 4F 19 00'\r\n '09 D0 19 00 00 D1 19 00 01 D2 19 00 02 D3 19 00 03 D4 19 00 04 D5 19 00 05 D6 19 00 06 D7 19 00'\r\n '07 D8 19 00 08 D9 19 00 09 DA 19 00 01 80 1A 00 00 81 1A 00 01 82 1A 00 02 83 1A 00 03 84 1A 00'\r\n '04 85 1A 00 05 86 1A 00 06 87 1A 00 07 88 1A 00 08 89 1A 00 09 90 1A 00 00 91 1A 00 01 92 1A 00'\r\n '02 93 1A 00 03 94 1A 00 04 95 1A 00 05 96 1A 00 06 97 1A 00 07 98 1A 00 08 99 1A 00 09 50 1B 00'\r\n '00 51 1B 00 01 52 1B 00 02 53 1B 00 03 54 1B 00 04 55 1B 00 05 56 1B 00 06 57 1B 00 07 58 1B 00'\r\n '08 59 1B 00 09 B0 1B 00 00 B1 1B 00 01 B2 1B 00 02 B3 1B 00 03 B4 1B 00 04 B5 1B 00 05 B6 1B 00'\r\n '06 B7 1B 00 07 B8 1B 00 08 B9 1B 00 09 40 1C 00 00 41 1C 00 01 42 1C 00 02 43 1C 00 03 44 1C 00'\r\n '04 45 1C 00 05 46 1C 00 06 47 1C 00 07 48 1C 00 08 49 1C 00 09 50 1C 00 00 51 1C 00 01 52 1C 00'\r\n '02 53 1C 00 03 54 1C 00 04 55 1C 00 05 56 1C 00 06 57 1C 00 07 58 1C 00 08 59 1C 00 09 70 20 00'\r\n '00 74 20 00 04 75 20 00 05 76 20 00 06 77 20 00 07 78 20 00 08 79 20 00 09 80 20 00 00 81 20 00'\r\n '01 82 20 00 02 83 20 00 03 84 20 00 04 85 20 00 05 86 20 00 06 87 20 00 07 88 20 00 08 89 20 00'\r\n '09 50 21 00 29 51 21 00 2A 52 21 00 2B 53 21 00 2C 54 21 00 2D 55 21 00 2E 56 21 00 2F 57 21 00'\r\n '30 58 21 00 31 59 21 00 32 5A 21 00 33 5B 21 00 0E 5C 21 00 34 5D 21 00 35 5E 21 00 36 5F 21 00'\r\n '01 60 21 00 01 61 21 00 02 62 21 00 03 63 21 00 04 64 21 00 05 65 21 00 06 66 21 00 07 67 21 00'\r\n '08 68 21 00 09 69 21 00 11 6A 21 00 37 6B 21 00 38 6C 21 00 20 6D 21 00 12 6E 21 00 39 6F 21 00'\r\n '13 70 21 00 01 71 21 00 02 72 21 00 03 73 21 00 04 74 21 00 05 75 21 00 06 76 21 00 07 77 21 00'\r\n '08 78 21 00 09 79 21 00 11 7A 21 00 37 7B 21 00 38 7C 21 00 20 7D 21 00 12 7E 21 00 39 7F 21 00'\r\n '13 80 21 00 13 81 21 00 3A 82 21 00 25 85 21 00 06 86 21 00 20 87 21 00 3B 88 21 00 3C 89 21 00'\r\n '00 60 24 00 01 61 24 00 02 62 24 00 03 63 24 00 04 64 24 00 05 65 24 00 06 66 24 00 07 67 24 00'\r\n '08 68 24 00 09 69 24 00 11 6A 24 00 37 6B 24 00 38 6C 24 00 3D 6D 24 00 3E 6E 24 00 3F 6F 24 00'\r\n '10 70 24 00 26 71 24 00 27 72 24 00 28 73 24 00 1D 74 24 00 01 75 24 00 02 76 24 00 03 77 24 00'\r\n '04 78 24 00 05 79 24 00 06 7A 24 00 07 7B 24 00 08 7C 24 00 09 7D 24 00 11 7E 24 00 37 7F 24 00'\r\n '38 80 24 00 3D 81 24 00 3E 82 24 00 3F 83 24 00 10 84 24 00 26 85 24 00 27 86 24 00 28 87 24 00'\r\n '1D 88 24 00 01 89 24 00 02 8A 24 00 03 8B 24 00 04 8C 24 00 05 8D 24 00 06 8E 24 00 07 8F 24 00'\r\n '08 90 24 00 09 91 24 00 11 92 24 00 37 93 24 00 38 94 24 00 3D 95 24 00 3E 96 24 00 3F 97 24 00'\r\n '10 98 24 00 26 99 24 00 27 9A 24 00 28 9B 24 00 1D EA 24 00 00 EB 24 00 37 EC 24 00 38 ED 24 00'\r\n '3D EE 24 00 3E EF 24 00 3F F0 24 00 10 F1 24 00 26 F2 24 00 27 F3 24 00 28 F4 24 00 1D F5 24 00'\r\n '01 F6 24 00 02 F7 24 00 03 F8 24 00 04 F9 24 00 05 FA 24 00 06 FB 24 00 07 FC 24 00 08 FD 24 00'\r\n '09 FE 24 00 11 FF 24 00 00 76 27 00 01 77 27 00 02 78 27 00 03 79 27 00 04 7A 27 00 05 7B 27 00'\r\n '06 7C 27 00 07 7D 27 00 08 7E 27 00 09 7F 27 00 11 80 27 00 01 81 27 00 02 82 27 00 03 83 27 00'\r\n '04 84 27 00 05 85 27 00 06 86 27 00 07 87 27 00 08 88 27 00 09 89 27 00 11 8A 27 00 01 8B 27 00'\r\n '02 8C 27 00 03 8D 27 00 04 8E 27 00 05 8F 27 00 06 90 27 00 07 91 27 00 08 92 27 00 09 93 27 00'\r\n '11 FD 2C 00 0B 07 30 00 00 21 30 00 01 22 30 00 02 23 30 00 03 24 30 00 04 25 30 00 05 26 30 00'\r\n '06 27 30 00 07 28 30 00 08 29 30 00 09 38 30 00 11 39 30 00 1D 3A 30 00 1E 92 31 00 01 93 31 00'\r\n '02 94 31 00 03 95 31 00 04 20 32 00 01 21 32 00 02 22 32 00 03 23 32 00 04 24 32 00 05 25 32 00'\r\n '06 26 32 00 07 27 32 00 08 28 32 00 09 29 32 00 11 51 32 00 40 52 32 00 41 53 32 00 42 54 32 00'\r\n '43 55 32 00 44 56 32 00 45 57 32 00 46 58 32 00 47 59 32 00 48 5A 32 00 1E 5B 32 00 49 5C 32 00'\r\n '4A 5D 32 00 4B 5E 32 00 4C 5F 32 00 4D 80 32 00 01 81 32 00 02 82 32 00 03 83 32 00 04 84 32 00'\r\n '05 85 32 00 06 86 32 00 07 87 32 00 08 88 32 00 09 89 32 00 11 B1 32 00 4E B2 32 00 4F B3 32 00'\r\n '50 B4 32 00 51 B5 32 00 1F B6 32 00 52 B7 32 00 53 B8 32 00 54 B9 32 00 55 BA 32 00 56 BB 32 00'\r\n '57 BC 32 00 58 BD 32 00 59 BE 32 00 5A BF 32 00 20 20 A6 00 00 21 A6 00 01 22 A6 00 02 23 A6 00'\r\n '03 24 A6 00 04 25 A6 00 05 26 A6 00 06 27 A6 00 07 28 A6 00 08 29 A6 00 09 E6 A6 00 01 E7 A6 00'\r\n '02 E8 A6 00 03 E9 A6 00 04 EA A6 00 05 EB A6 00 06 EC A6 00 07 ED A6 00 08 EE A6 00 09 EF A6 00'\r\n '00 30 A8 00 0A 31 A8 00 0B 32 A8 00 0C 33 A8 00 0D 34 A8 00 0E 35 A8 00 0F D0 A8 00 00 D1 A8 00'\r\n '01 D2 A8 00 02 D3 A8 00 03 D4 A8 00 04 D5 A8 00 05 D6 A8 00 06 D7 A8 00 07 D8 A8 00 08 D9 A8 00'\r\n '09 00 A9 00 00 01 A9 00 01 02 A9 00 02 03 A9 00 03 04 A9 00 04 05 A9 00 05 06 A9 00 06 07 A9 00'\r\n '07 08 A9 00 08 09 A9 00 09 D0 A9 00 00 D1 A9 00 01 D2 A9 00 02 D3 A9 00 03 D4 A9 00 04 D5 A9 00'\r\n '05 D6 A9 00 06 D7 A9 00 07 D8 A9 00 08 D9 A9 00 09 50 AA 00 00 51 AA 00 01 52 AA 00 02 53 AA 00'\r\n '03 54 AA 00 04 55 AA 00 05 56 AA 00 06 57 AA 00 07 58 AA 00 08 59 AA 00 09 F0 AB 00 00 F1 AB 00'\r\n '01 F2 AB 00 02 F3 AB 00 03 F4 AB 00 04 F5 AB 00 05 F6 AB 00 06 F7 AB 00 07 F8 AB 00 08 F9 AB 00'\r\n '09 6B F9 00 03 73 F9 00 11 78 F9 00 02 B2 F9 00 00 D1 F9 00 06 D3 F9 00 06 FD F9 00 11 10 FF 00'\r\n '00 11 FF 00 01 12 FF 00 02 13 FF 00 03 14 FF 00 04 15 FF 00 05 16 FF 00 06 17 FF 00 07 18 FF 00'\r\n '08 19 FF 00 09 07 01 01 01 08 01 01 02 09 01 01 03 0A 01 01 04 0B 01 01 05 0C 01 01 06 0D 01 01'\r\n '07 0E 01 01 08 0F 01 01 09 10 01 01 11 11 01 01 1D 12 01 01 1E 13 01 01 1F 14 01 01 20 15 01 01'\r\n '21 16 01 01 22 17 01 01 23 18 01 01 24 19 01 01 12 1A 01 01 5B 1B 01 01 5C 1C 01 01 5D 1D 01 01'\r\n '39 1E 01 01 5E 1F 01 01 5F 20 01 01 60 21 01 01 61 22 01 01 13 23 01 01 62 24 01 01 63 25 01 01'\r\n '64 26 01 01 3A 27 01 01 65 28 01 01 66 29 01 01 67 2A 01 01 68 2B 01 01 25 2C 01 01 69 2D 01 01'\r\n '6A 2E 01 01 6B 2F 01 01 3B 30 01 01 6C 31 01 01 6D 32 01 01 6E 33 01 01 6F 40 01 01 0A 41 01 01'\r\n '0B 42 01 01 01 43 01 01 05 44 01 01 20 45 01 01 39 46 01 01 3A 47 01 01 3B 48 01 01 05 49 01 01'\r\n '11 4A 01 01 20 4B 01 01 12 4C 01 01 39 4D 01 01 13 4E 01 01 3A 4F 01 01 05 50 01 01 11 51 01 01'\r\n '20 52 01 01 12 53 01 01 39 54 01 01 13 55 01 01 25 56 01 01 3B 57 01 01 11 58 01 01 01 59 01 01'\r\n '01 5A 01 01 01 5B 01 01 02 5C 01 01 02 5D 01 01 02 5E 01 01 02 5F 01 01 05 60 01 01 11 61 01 01'\r\n '11 62 01 01 11 63 01 01 11 64 01 01 11 65 01 01 1E 66 01 01 20 67 01 01 20 68 01 01 20 69 01 01'\r\n '20 6A 01 01 12 6B 01 01 5C 6C 01 01 39 6D 01 01 39 6E 01 01 39 6F 01 01 39 70 01 01 39 71 01 01'\r\n '13 72 01 01 3A 73 01 01 05 74 01 01 20 75 01 01 0B 76 01 01 0B 77 01 01 2D 78 01 01 0C 8A 01 01'\r\n '00 20 03 01 01 21 03 01 05 22 03 01 11 23 03 01 20 41 03 01 24 4A 03 01 61 D1 03 01 01 D2 03 01'\r\n '02 D3 03 01 11 D4 03 01 1D D5 03 01 12 A0 04 01 00 A1 04 01 01 A2 04 01 02 A3 04 01 03 A4 04 01'\r\n '04 A5 04 01 05 A6 04 01 06 A7 04 01 07 A8 04 01 08 A9 04 01 09 58 08 01 01 59 08 01 02 5A 08 01'\r\n '03 5B 08 01 11 5C 08 01 1D 5D 08 01 12 5E 08 01 13 5F 08 01 25 16 09 01 01 17 09 01 11 18 09 01'\r\n '1D 19 09 01 12 1A 09 01 02 1B 09 01 03 40 0A 01 01 41 0A 01 02 42 0A 01 03 43 0A 01 04 44 0A 01'\r\n '11 45 0A 01 1D 46 0A 01 12 47 0A 01 13 7D 0A 01 01 7E 0A 01 20 58 0B 01 01 59 0B 01 02 5A 0B 01'\r\n '03 5B 0B 01 04 5C 0B 01 11 5D 0B 01 1D 5E 0B 01 12 5F 0B 01 13 78 0B 01 01 79 0B 01 02 7A 0B 01'\r\n '03 7B 0B 01 04 7C 0B 01 11 7D 0B 01 1D 7E 0B 01 12 7F 0B 01 13 60 0E 01 01 61 0E 01 02 62 0E 01'\r\n '03 63 0E 01 04 64 0E 01 05 65 0E 01 06 66 0E 01 07 67 0E 01 08 68 0E 01 09 69 0E 01 11 6A 0E 01'\r\n '1D 6B 0E 01 1E 6C 0E 01 1F 6D 0E 01 20 6E 0E 01 21 6F 0E 01 22 70 0E 01 23 71 0E 01 24 72 0E 01'\r\n '12 73 0E 01 5B 74 0E 01 5C 75 0E 01 5D 76 0E 01 39 77 0E 01 5E 78 0E 01 5F 79 0E 01 60 7A 0E 01'\r\n '61 7B 0E 01 0B 7C 0E 01 0A 7D 0E 01 2C 7E 0E 01 2D 52 10 01 01 53 10 01 02 54 10 01 03 55 10 01'\r\n '04 56 10 01 05 57 10 01 06 58 10 01 07 59 10 01 08 5A 10 01 09 5B 10 01 11 5C 10 01 1D 5D 10 01'\r\n '1E 5E 10 01 1F 5F 10 01 20 60 10 01 21 61 10 01 22 62 10 01 23 63 10 01 24 64 10 01 12 65 10 01'\r\n '13 66 10 01 00 67 10 01 01 68 10 01 02 69 10 01 03 6A 10 01 04 6B 10 01 05 6C 10 01 06 6D 10 01'\r\n '07 6E 10 01 08 6F 10 01 09 00 24 01 02 01 24 01 03 02 24 01 04 03 24 01 05 04 24 01 06 05 24 01'\r\n '07 06 24 01 08 07 24 01 09 08 24 01 03 09 24 01 04 0A 24 01 05 0B 24 01 06 0C 24 01 07 0D 24 01'\r\n '08 0E 24 01 09 0F 24 01 04 10 24 01 05 11 24 01 06 12 24 01 07 13 24 01 08 14 24 01 09 15 24 01'\r\n '01 16 24 01 02 17 24 01 03 18 24 01 04 19 24 01 05 1A 24 01 06 1B 24 01 07 1C 24 01 08 1D 24 01'\r\n '09 1E 24 01 01 1F 24 01 02 20 24 01 03 21 24 01 04 22 24 01 05 23 24 01 02 24 24 01 03 25 24 01'\r\n '03 26 24 01 04 27 24 01 05 28 24 01 06 29 24 01 07 2A 24 01 08 2B 24 01 09 2C 24 01 01 2D 24 01'\r\n '02 2E 24 01 03 2F 24 01 03 30 24 01 04 31 24 01 05 34 24 01 01 35 24 01 02 36 24 01 03 37 24 01'\r\n '03 38 24 01 04 39 24 01 05 3A 24 01 03 3B 24 01 03 3C 24 01 04 3D 24 01 04 3E 24 01 04 3F 24 01'\r\n '04 40 24 01 06 41 24 01 07 42 24 01 07 43 24 01 07 44 24 01 08 45 24 01 08 46 24 01 09 47 24 01'\r\n '09 48 24 01 09 49 24 01 09 4A 24 01 02 4B 24 01 03 4C 24 01 04 4D 24 01 05 4E 24 01 06 4F 24 01'\r\n '01 50 24 01 02 51 24 01 03 52 24 01 04 53 24 01 04 54 24 01 05 55 24 01 05 58 24 01 01 59 24 01'\r\n '02 5A 24 01 2C 5B 24 01 2D 5C 24 01 33 5D 24 01 2C 5E 24 01 2D 5F 24 01 0E 60 24 01 0A 61 24 01'\r\n '32 62 24 01 0A 60 D3 01 01 61 D3 01 02 62 D3 01 03 63 D3 01 04 64 D3 01 05 65 D3 01 06 66 D3 01'\r\n '07 67 D3 01 08 68 D3 01 09 69 D3 01 11 6A D3 01 1D 6B D3 01 1E 6C D3 01 1F 6D D3 01 20 6E D3 01'\r\n '21 6F D3 01 22 70 D3 01 23 71 D3 01 24 CE D7 01 00 CF D7 01 01 D0 D7 01 02 D1 D7 01 03 D2 D7 01'\r\n '04 D3 D7 01 05 D4 D7 01 06 D5 D7 01 07 D6 D7 01 08 D7 D7 01 09 D8 D7 01 00 D9 D7 01 01 DA D7 01'\r\n '02 DB D7 01 03 DC D7 01 04 DD D7 01 05 DE D7 01 06 DF D7 01 07 E0 D7 01 08 E1 D7 01 09 E2 D7 01'\r\n '00 E3 D7 01 01 E4 D7 01 02 E5 D7 01 03 E6 D7 01 04 E7 D7 01 05 E8 D7 01 06 E9 D7 01 07 EA D7 01'\r\n '08 EB D7 01 09 EC D7 01 00 ED D7 01 01 EE D7 01 02 EF D7 01 03 F0 D7 01 04 F1 D7 01 05 F2 D7 01'\r\n '06 F3 D7 01 07 F4 D7 01 08 F5 D7 01 09 F6 D7 01 00 F7 D7 01 01 F8 D7 01 02 F9 D7 01 03 FA D7 01'\r\n '04 FB D7 01 05 FC D7 01 06 FD D7 01 07 FE D7 01 08 FF D7 01 09 00 F1 01 00 01 F1 01 00 02 F1 01'\r\n '01 03 F1 01 02 04 F1 01 03 05 F1 01 04 06 F1 01 05 07 F1 01 06 08 F1 01 07 09 F1 01 08 0A F1 01'\r\n '09 90 F8 02 09'\r\n}\r\n\r\n\r\nLANGUAGE 0,0 COMPOSITION UNICODEDATA LOADONCALL MOVEABLE DISCARDABLE\r\n{\r\n '59 11 00 00 84 03 00 02 10 20 00 00 01 03 00 B4 00 00 02 10 20 00 00 01 03 00 DC 02 00 02 10 20'\r\n '00 00 03 03 00 AF 00 00 02 10 20 00 00 04 03 00 E3 FF 00 02 0B 20 00 00 04 03 00 3E 20 00 02 10'\r\n '20 00 00 05 03 00 4B FE 00 02 10 20 00 00 05 03 00 49 FE 00 02 10 20 00 00 05 03 00 4C FE 00 02'\r\n '10 20 00 00 05 03 00 4A FE 00 02 10 20 00 00 05 03 00 D8 02 00 02 10 20 00 00 06 03 00 D9 02 00'\r\n '02 10 20 00 00 07 03 00 ED 1F 00 03 00 20 00 00 08 03 00 00 03 00 85 03 00 03 00 20 00 00 08 03'\r\n '00 01 03 00 C1 1F 00 03 00 20 00 00 08 03 00 42 03 00 A8 00 00 02 10 20 00 00 08 03 00 DA 02 00'\r\n '02 10 20 00 00 0A 03 00 DD 02 00 02 10 20 00 00 0B 03 00 CD 1F 00 03 00 20 00 00 13 03 00 00 03'\r\n '00 CE 1F 00 03 00 20 00 00 13 03 00 01 03 00 CF 1F 00 03 00 20 00 00 13 03 00 42 03 00 BF 1F 00'\r\n '02 10 20 00 00 13 03 00 BD 1F 00 02 10 20 00 00 13 03 00 DD 1F 00 03 00 20 00 00 14 03 00 00 03'\r\n '00 DE 1F 00 03 00 20 00 00 14 03 00 01 03 00 DF 1F 00 03 00 20 00 00 14 03 00 42 03 00 FE 1F 00'\r\n '02 10 20 00 00 14 03 00 B8 00 00 02 10 20 00 00 27 03 00 DB 02 00 02 10 20 00 00 28 03 00 17 20'\r\n '00 02 10 20 00 00 33 03 00 C0 1F 00 02 10 20 00 00 42 03 00 7A 03 00 02 10 20 00 00 45 03 00 70'\r\n 'FE 00 02 06 20 00 00 4B 06 00 5E FC 00 03 06 20 00 00 4C 06 00 51 06 00 72 FE 00 02 06 20 00 00'\r\n '4C 06 00 5F FC 00 03 06 20 00 00 4D 06 00 51 06 00 74 FE 00 02 06 20 00 00 4D 06 00 60 FC 00 03'\r\n '06 20 00 00 4E 06 00 51 06 00 76 FE 00 02 06 20 00 00 4E 06 00 61 FC 00 03 06 20 00 00 4F 06 00'\r\n '51 06 00 78 FE 00 02 06 20 00 00 4F 06 00 62 FC 00 03 06 20 00 00 50 06 00 51 06 00 7A FE 00 02'\r\n '06 20 00 00 50 06 00 63 FC 00 03 06 20 00 00 51 06 00 70 06 00 7C FE 00 02 06 20 00 00 51 06 00'\r\n '7E FE 00 02 06 20 00 00 52 06 00 9B 30 00 02 10 20 00 00 99 30 00 9C 30 00 02 10 20 00 00 9A 30'\r\n '00 00 30 00 01 0B 20 00 00 09 20 00 01 10 20 00 00 08 20 00 01 10 20 00 00 0A 20 00 01 10 20 00'\r\n '00 A0 00 00 01 02 20 00 00 5F 20 00 01 10 20 00 00 2F 20 00 01 02 20 00 00 04 20 00 01 10 20 00'\r\n '00 03 20 00 01 10 20 00 00 02 20 00 01 10 20 00 00 05 20 00 01 10 20 00 00 07 20 00 01 02 20 00'\r\n '00 06 20 00 01 10 20 00 00 3C 20 00 02 10 21 00 00 21 00 00 49 20 00 02 10 21 00 00 3F 00 00 15'\r\n 'FE 00 01 0A 21 00 00 01 FF 00 01 0B 21 00 00 57 FE 00 01 0D 21 00 00 02 FF 00 01 0B 22 00 00 03'\r\n 'FF 00 01 0B 23 00 00 5F FE 00 01 0D 23 00 00 69 FE 00 01 0D 24 00 00 04 FF 00 01 0B 24 00 00 6A'\r\n 'FE 00 01 0D 25 00 00 05 FF 00 01 0B 25 00 00 06 FF 00 01 0B 26 00 00 60 FE 00 01 0D 26 00 00 07'\r\n 'FF 00 01 0B 27 00 00 74 24 00 03 10 28 00 00 31 00 00 29 00 00 7D 24 00 04 10 28 00 00 31 00 00'\r\n '30 00 00 29 00 00 7E 24 00 04 10 28 00 00 31 00 00 31 00 00 29 00 00 7F 24 00 04 10 28 00 00 31'\r\n '00 00 32 00 00 29 00 00 80 24 00 04 10 28 00 00 31 00 00 33 00 00 29 00 00 81 24 00 04 10 28 00'\r\n '00 31 00 00 34 00 00 29 00 00 82 24 00 04 10 28 00 00 31 00 00 35 00 00 29 00 00 83 24 00 04 10'\r\n '28 00 00 31 00 00 36 00 00 29 00 00 84 24 00 04 10 28 00 00 31 00 00 37 00 00 29 00 00 85 24 00'\r\n '04 10 28 00 00 31 00 00 38 00 00 29 00 00 86 24 00 04 10 28 00 00 31 00 00 39 00 00 29 00 00 75'\r\n '24 00 03 10 28 00 00 32 00 00 29 00 00 87 24 00 04 10 28 00 00 32 00 00 30 00 00 29 00 00 76 24'\r\n '00 03 10 28 00 00 33 00 00 29 00 00 77 24 00 03 10 28 00 00 34 00 00 29 00 00 78 24 00 03 10 28'\r\n '00 00 35 00 00 29 00 00 79 24 00 03 10 28 00 00 36 00 00 29 00 00 7A 24 00 03 10 28 00 00 37 00'\r\n '00 29 00 00 7B 24 00 03 10 28 00 00 38 00 00 29 00 00 7C 24 00 03 10 28 00 00 39 00 00 29 00 00'\r\n '10 F1 01 03 10 28 00 00 41 00 00 29 00 00 11 F1 01 03 10 28 00 00 42 00 00 29 00 00 12 F1 01 03'\r\n '10 28 00 00 43 00 00 29 00 00 13 F1 01 03 10 28 00 00 44 00 00 29 00 00 14 F1 01 03 10 28 00 00'\r\n '45 00 00 29 00 00 15 F1 01 03 10 28 00 00 46 00 00 29 00 00 16 F1 01 03 10 28 00 00 47 00 00 29'\r\n '00 00 17 F1 01 03 10 28 00 00 48 00 00 29 00 00 18 F1 01 03 10 28 00 00 49 00 00 29 00 00 19 F1'\r\n '01 03 10 28 00 00 4A 00 00 29 00 00 1A F1 01 03 10 28 00 00 4B 00 00 29 00 00 1B F1 01 03 10 28'\r\n '00 00 4C 00 00 29 00 00 1C F1 01 03 10 28 00 00 4D 00 00 29 00 00 1D F1 01 03 10 28 00 00 4E 00'\r\n '00 29 00 00 1E F1 01 03 10 28 00 00 4F 00 00 29 00 00 1F F1 01 03 10 28 00 00 50 00 00 29 00 00'\r\n '20 F1 01 03 10 28 00 00 51 00 00 29 00 00 21 F1 01 03 10 28 00 00 52 00 00 29 00 00 22 F1 01 03'\r\n '10 28 00 00 53 00 00 29 00 00 23 F1 01 03 10 28 00 00 54 00 00 29 00 00 24 F1 01 03 10 28 00 00'\r\n '55 00 00 29 00 00 25 F1 01 03 10 28 00 00 56 00 00 29 00 00 26 F1 01 03 10 28 00 00 57 00 00 29'\r\n '00 00 27 F1 01 03 10 28 00 00 58 00 00 29 00 00 28 F1 01 03 10 28 00 00 59 00 00 29 00 00 29 F1'\r\n '01 03 10 28 00 00 5A 00 00 29 00 00 9C 24 00 03 10 28 00 00 61 00 00 29 00 00 9D 24 00 03 10 28'\r\n '00 00 62 00 00 29 00 00 9E 24 00 03 10 28 00 00 63 00 00 29 00 00 9F 24 00 03 10 28 00 00 64 00'\r\n '00 29 00 00 A0 24 00 03 10 28 00 00 65 00 00 29 00 00 A1 24 00 03 10 28 00 00 66 00 00 29 00 00'\r\n 'A2 24 00 03 10 28 00 00 67 00 00 29 00 00 A3 24 00 03 10 28 00 00 68 00 00 29 00 00 A4 24 00 03'\r\n '10 28 00 00 69 00 00 29 00 00 A5 24 00 03 10 28 00 00 6A 00 00 29 00 00 A6 24 00 03 10 28 00 00'\r\n '6B 00 00 29 00 00 A7 24 00 03 10 28 00 00 6C 00 00 29 00 00 A8 24 00 03 10 28 00 00 6D 00 00 29'\r\n '00 00 A9 24 00 03 10 28 00 00 6E 00 00 29 00 00 AA 24 00 03 10 28 00 00 6F 00 00 29 00 00 AB 24'\r\n '00 03 10 28 00 00 70 00 00 29 00 00 AC 24 00 03 10 28 00 00 71 00 00 29 00 00 AD 24 00 03 10 28'\r\n '00 00 72 00 00 29 00 00 AE 24 00 03 10 28 00 00 73 00 00 29 00 00 AF 24 00 03 10 28 00 00 74 00'\r\n '00 29 00 00 B0 24 00 03 10 28 00 00 75 00 00 29 00 00 B1 24 00 03 10 28 00 00 76 00 00 29 00 00'\r\n 'B2 24 00 03 10 28 00 00 77 00 00 29 00 00 B3 24 00 03 10 28 00 00 78 00 00 29 00 00 B4 24 00 03'\r\n '10 28 00 00 79 00 00 29 00 00 B5 24 00 03 10 28 00 00 7A 00 00 29 00 00 00 32 00 03 10 28 00 00'\r\n '00 11 00 29 00 00 0E 32 00 04 10 28 00 00 00 11 00 61 11 00 29 00 00 01 32 00 03 10 28 00 00 02'\r\n '11 00 29 00 00 0F 32 00 04 10 28 00 00 02 11 00 61 11 00 29 00 00 02 32 00 03 10 28 00 00 03 11'\r\n '00 29 00 00 10 32 00 04 10 28 00 00 03 11 00 61 11 00 29 00 00 03 32 00 03 10 28 00 00 05 11 00'\r\n '29 00 00 11 32 00 04 10 28 00 00 05 11 00 61 11 00 29 00 00 04 32 00 03 10 28 00 00 06 11 00 29'\r\n '00 00 12 32 00 04 10 28 00 00 06 11 00 61 11 00 29 00 00 05 32 00 03 10 28 00 00 07 11 00 29 00'\r\n '00 13 32 00 04 10 28 00 00 07 11 00 61 11 00 29 00 00 06 32 00 03 10 28 00 00 09 11 00 29 00 00'\r\n '14 32 00 04 10 28 00 00 09 11 00 61 11 00 29 00 00 07 32 00 03 10 28 00 00 0B 11 00 29 00 00 15'\r\n '32 00 04 10 28 00 00 0B 11 00 61 11 00 29 00 00 1D 32 00 07 10 28 00 00 0B 11 00 69 11 00 0C 11'\r\n '00 65 11 00 AB 11 00 29 00 00 1E 32 00 06 10 28 00 00 0B 11 00 69 11 00 12 11 00 6E 11 00 29 00'\r\n '00 08 32 00 03 10 28 00 00 0C 11 00 29 00 00 16 32 00 04 10 28 00 00 0C 11 00 61 11 00 29 00 00'\r\n '1C 32 00 04 10 28 00 00 0C 11 00 6E 11 00 29 00 00 09 32 00 03 10 28 00 00 0E 11 00 29 00 00 17'\r\n '32 00 04 10 28 00 00 0E 11 00 61 11 00 29 00 00 0A 32 00 03 10 28 00 00 0F 11 00 29 00 00 18 32'\r\n '00 04 10 28 00 00 0F 11 00 61 11 00 29 00 00 0B 32 00 03 10 28 00 00 10 11 00 29 00 00 19 32 00'\r\n '04 10 28 00 00 10 11 00 61 11 00 29 00 00 0C 32 00 03 10 28 00 00 11 11 00 29 00 00 1A 32 00 04'\r\n '10 28 00 00 11 11 00 61 11 00 29 00 00 0D 32 00 03 10 28 00 00 12 11 00 29 00 00 1B 32 00 04 10'\r\n '28 00 00 12 11 00 61 11 00 29 00 00 20 32 00 03 10 28 00 00 00 4E 00 29 00 00 26 32 00 03 10 28'\r\n '00 00 03 4E 00 29 00 00 22 32 00 03 10 28 00 00 09 4E 00 29 00 00 28 32 00 03 10 28 00 00 5D 4E'\r\n '00 29 00 00 21 32 00 03 10 28 00 00 8C 4E 00 29 00 00 24 32 00 03 10 28 00 00 94 4E 00 29 00 00'\r\n '39 32 00 03 10 28 00 00 E3 4E 00 29 00 00 3D 32 00 03 10 28 00 00 01 4F 00 29 00 00 41 32 00 03'\r\n '10 28 00 00 11 4F 00 29 00 00 27 32 00 03 10 28 00 00 6B 51 00 29 00 00 25 32 00 03 10 28 00 00'\r\n '6D 51 00 29 00 00 38 32 00 03 10 28 00 00 B4 52 00 29 00 00 29 32 00 03 10 28 00 00 41 53 00 29'\r\n '00 00 3F 32 00 03 10 28 00 00 54 53 00 29 00 00 34 32 00 03 10 28 00 00 0D 54 00 29 00 00 3A 32'\r\n '00 03 10 28 00 00 7C 54 00 29 00 00 23 32 00 03 10 28 00 00 DB 56 00 29 00 00 2F 32 00 03 10 28'\r\n '00 00 1F 57 00 29 00 00 3B 32 00 03 10 28 00 00 66 5B 00 29 00 00 30 32 00 03 10 28 00 00 E5 65'\r\n '00 29 00 00 2A 32 00 03 10 28 00 00 08 67 00 29 00 00 32 32 00 03 10 28 00 00 09 67 00 29 00 00'\r\n '2D 32 00 03 10 28 00 00 28 67 00 29 00 00 31 32 00 03 10 28 00 00 2A 68 00 29 00 00 2C 32 00 03'\r\n '10 28 00 00 34 6C 00 29 00 00 2B 32 00 03 10 28 00 00 6B 70 00 29 00 00 35 32 00 03 10 28 00 00'\r\n '79 72 00 29 00 00 3C 32 00 03 10 28 00 00 E3 76 00 29 00 00 33 32 00 03 10 28 00 00 3E 79 00 29'\r\n '00 00 37 32 00 03 10 28 00 00 5D 79 00 29 00 00 40 32 00 03 10 28 00 00 6D 79 00 29 00 00 42 32'\r\n '00 03 10 28 00 00 EA 81 00 29 00 00 43 32 00 03 10 28 00 00 F3 81 00 29 00 00 36 32 00 03 10 28'\r\n '00 00 A1 8C 00 29 00 00 3E 32 00 03 10 28 00 00 C7 8C 00 29 00 00 2E 32 00 03 10 28 00 00 D1 91'\r\n '00 29 00 00 35 FE 00 01 0A 28 00 00 8D 20 00 01 09 28 00 00 59 FE 00 01 0D 28 00 00 08 FF 00 01'\r\n '0B 28 00 00 7D 20 00 01 08 28 00 00 36 FE 00 01 0A 29 00 00 5A FE 00 01 0D 29 00 00 8E 20 00 01'\r\n '09 29 00 00 09 FF 00 01 0B 29 00 00 7E 20 00 01 08 29 00 00 61 FE 00 01 0D 2A 00 00 0A FF 00 01'\r\n '0B 2A 00 00 62 FE 00 01 0D 2B 00 00 0B FF 00 01 0B 2B 00 00 29 FB 00 01 01 2B 00 00 8A 20 00 01'\r\n '09 2B 00 00 7A 20 00 01 08 2B 00 00 0C FF 00 01 0B 2C 00 00 50 FE 00 01 0D 2C 00 00 10 FE 00 01'\r\n '0A 2C 00 00 0D FF 00 01 0B 2D 00 00 63 FE 00 01 0D 2D 00 00 26 20 00 03 10 2E 00 00 2E 00 00 2E'\r\n '00 00 19 FE 00 03 0A 2E 00 00 2E 00 00 2E 00 00 25 20 00 02 10 2E 00 00 2E 00 00 30 FE 00 02 0A'\r\n '2E 00 00 2E 00 00 24 20 00 01 10 2E 00 00 52 FE 00 01 0D 2E 00 00 0E FF 00 01 0B 2E 00 00 0F FF'\r\n '00 01 0B 2F 00 00 01 F1 01 02 10 30 00 00 2C 00 00 00 F1 01 02 10 30 00 00 2E 00 00 89 21 00 03'\r\n '0F 30 00 00 44 20 00 33 00 00 58 33 00 02 10 30 00 00 B9 70 00 F6 D7 01 01 01 30 00 00 D8 D7 01'\r\n '01 01 30 00 00 EC D7 01 01 01 30 00 00 70 20 00 01 08 30 00 00 E2 D7 01 01 01 30 00 00 CE D7 01'\r\n '01 01 30 00 00 10 FF 00 01 0B 30 00 00 EA 24 00 01 07 30 00 00 80 20 00 01 09 30 00 00 02 F1 01'\r\n '02 10 31 00 00 2C 00 00 88 24 00 02 10 31 00 00 2E 00 00 91 24 00 03 10 31 00 00 30 00 00 2E 00'\r\n '00 E9 33 00 03 10 31 00 00 30 00 00 E5 65 00 C9 32 00 03 10 31 00 00 30 00 00 08 67 00 62 33 00'\r\n '03 10 31 00 00 30 00 00 B9 70 00 69 24 00 02 07 31 00 00 30 00 00 92 24 00 03 10 31 00 00 31 00'\r\n '00 2E 00 00 EA 33 00 03 10 31 00 00 31 00 00 E5 65 00 CA 32 00 03 10 31 00 00 31 00 00 08 67 00'\r\n '63 33 00 03 10 31 00 00 31 00 00 B9 70 00 6A 24 00 02 07 31 00 00 31 00 00 93 24 00 03 10 31 00'\r\n '00 32 00 00 2E 00 00 EB 33 00 03 10 31 00 00 32 00 00 E5 65 00 CB 32 00 03 10 31 00 00 32 00 00'\r\n '08 67 00 64 33 00 03 10 31 00 00 32 00 00 B9 70 00 6B 24 00 02 07 31 00 00 32 00 00 94 24 00 03'\r\n '10 31 00 00 33 00 00 2E 00 00 EC 33 00 03 10 31 00 00 33 00 00 E5 65 00 65 33 00 03 10 31 00 00'\r\n '33 00 00 B9 70 00 6C 24 00 02 07 31 00 00 33 00 00 95 24 00 03 10 31 00 00 34 00 00 2E 00 00 ED'\r\n '33 00 03 10 31 00 00 34 00 00 E5 65 00 66 33 00 03 10 31 00 00 34 00 00 B9 70 00 6D 24 00 02 07'\r\n '31 00 00 34 00 00 96 24 00 03 10 31 00 00 35 00 00 2E 00 00 EE 33 00 03 10 31 00 00 35 00 00 E5'\r\n '65 00 67 33 00 03 10 31 00 00 35 00 00 B9 70 00 6E 24 00 02 07 31 00 00 35 00 00 97 24 00 03 10'\r\n '31 00 00 36 00 00 2E 00 00 EF 33 00 03 10 31 00 00 36 00 00 E5 65 00 68 33 00 03 10 31 00 00 36'\r\n '00 00 B9 70 00 6F 24 00 02 07 31 00 00 36 00 00 98 24 00 03 10 31 00 00 37 00 00 2E 00 00 F0 33'\r\n '00 03 10 31 00 00 37 00 00 E5 65 00 69 33 00 03 10 31 00 00 37 00 00 B9 70 00 70 24 00 02 07 31'\r\n '00 00 37 00 00 99 24 00 03 10 31 00 00 38 00 00 2E 00 00 F1 33 00 03 10 31 00 00 38 00 00 E5 65'\r\n '00 6A 33 00 03 10 31 00 00 38 00 00 B9 70 00 71 24 00 02 07 31 00 00 38 00 00 9A 24 00 03 10 31'\r\n '00 00 39 00 00 2E 00 00 F2 33 00 03 10 31 00 00 39 00 00 E5 65 00 6B 33 00 03 10 31 00 00 39 00'\r\n '00 B9 70 00 72 24 00 02 07 31 00 00 39 00 00 52 21 00 04 0F 31 00 00 44 20 00 31 00 00 30 00 00'\r\n 'BD 00 00 03 0F 31 00 00 44 20 00 32 00 00 53 21 00 03 0F 31 00 00 44 20 00 33 00 00 BC 00 00 03'\r\n '0F 31 00 00 44 20 00 34 00 00 55 21 00 03 0F 31 00 00 44 20 00 35 00 00 59 21 00 03 0F 31 00 00'\r\n '44 20 00 36 00 00 50 21 00 03 0F 31 00 00 44 20 00 37 00 00 5B 21 00 03 0F 31 00 00 44 20 00 38'\r\n '00 00 51 21 00 03 0F 31 00 00 44 20 00 39 00 00 5F 21 00 02 0F 31 00 00 44 20 00 E0 33 00 02 10'\r\n '31 00 00 E5 65 00 C0 32 00 02 10 31 00 00 08 67 00 59 33 00 02 10 31 00 00 B9 70 00 E3 D7 01 01'\r\n '01 31 00 00 F7 D7 01 01 01 31 00 00 D9 D7 01 01 01 31 00 00 81 20 00 01 09 31 00 00 B9 00 00 01'\r\n '08 31 00 00 60 24 00 01 07 31 00 00 CF D7 01 01 01 31 00 00 11 FF 00 01 0B 31 00 00 ED D7 01 01'\r\n '01 31 00 00 03 F1 01 02 10 32 00 00 2C 00 00 89 24 00 02 10 32 00 00 2E 00 00 9B 24 00 03 10 32'\r\n '00 00 30 00 00 2E 00 00 F3 33 00 03 10 32 00 00 30 00 00 E5 65 00 6C 33 00 03 10 32 00 00 30 00'\r\n '00 B9 70 00 73 24 00 02 07 32 00 00 30 00 00 F4 33 00 03 10 32 00 00 31 00 00 E5 65 00 6D 33 00'\r\n '03 10 32 00 00 31 00 00 B9 70 00 51 32 00 02 07 32 00 00 31 00 00 F5 33 00 03 10 32 00 00 32 00'\r\n '00 E5 65 00 6E 33 00 03 10 32 00 00 32 00 00 B9 70 00 52 32 00 02 07 32 00 00 32 00 00 F6 33 00'\r\n '03 10 32 00 00 33 00 00 E5 65 00 6F 33 00 03 10 32 00 00 33 00 00 B9 70 00 53 32 00 02 07 32 00'\r\n '00 33 00 00 F7 33 00 03 10 32 00 00 34 00 00 E5 65 00 70 33 00 03 10 32 00 00 34 00 00 B9 70 00'\r\n '54 32 00 02 07 32 00 00 34 00 00 F8 33 00 03 10 32 00 00 35 00 00 E5 65 00 55 32 00 02 07 32 00'\r\n '00 35 00 00 F9 33 00 03 10 32 00 00 36 00 00 E5 65 00 56 32 00 02 07 32 00 00 36 00 00 FA 33 00'\r\n '03 10 32 00 00 37 00 00 E5 65 00 57 32 00 02 07 32 00 00 37 00 00 FB 33 00 03 10 32 00 00 38 00'\r\n '00 E5 65 00 58 32 00 02 07 32 00 00 38 00 00 FC 33 00 03 10 32 00 00 39 00 00 E5 65 00 59 32 00'\r\n '02 07 32 00 00 39 00 00 54 21 00 03 0F 32 00 00 44 20 00 33 00 00 56 21 00 03 0F 32 00 00 44 20'\r\n '00 35 00 00 E1 33 00 02 10 32 00 00 E5 65 00 C1 32 00 02 10 32 00 00 08 67 00 5A 33 00 02 10 32'\r\n '00 00 B9 70 00 82 20 00 01 09 32 00 00 12 FF 00 01 0B 32 00 00 61 24 00 01 07 32 00 00 EE D7 01'\r\n '01 01 32 00 00 DA D7 01 01 01 32 00 00 E4 D7 01 01 01 32 00 00 D0 D7 01 01 01 32 00 00 B2 00 00'\r\n '01 08 32 00 00 F8 D7 01 01 01 32 00 00 04 F1 01 02 10 33 00 00 2C 00 00 8A 24 00 02 10 33 00 00'\r\n '2E 00 00 FD 33 00 03 10 33 00 00 30 00 00 E5 65 00 5A 32 00 02 07 33 00 00 30 00 00 FE 33 00 03'\r\n '10 33 00 00 31 00 00 E5 65 00 5B 32 00 02 07 33 00 00 31 00 00 5C 32 00 02 07 33 00 00 32 00 00'\r\n '5D 32 00 02 07 33 00 00 33 00 00 5E 32 00 02 07 33 00 00 34 00 00 5F 32 00 02 07 33 00 00 35 00'\r\n '00 B1 32 00 02 07 33 00 00 36 00 00 B2 32 00 02 07 33 00 00 37 00 00 B3 32 00 02 07 33 00 00 38'\r\n '00 00 B4 32 00 02 07 33 00 00 39 00 00 BE 00 00 03 0F 33 00 00 44 20 00 34 00 00 57 21 00 03 0F'\r\n '33 00 00 44 20 00 35 00 00 5C 21 00 03 0F 33 00 00 44 20 00 38 00 00 E2 33 00 02 10 33 00 00 E5'\r\n '65 00 C2 32 00 02 10 33 00 00 08 67 00 5B 33 00 02 10 33 00 00 B9 70 00 83 20 00 01 09 33 00 00'\r\n 'E5 D7 01 01 01 33 00 00 D1 D7 01 01 01 33 00 00 B3 00 00 01 08 33 00 00 F9 D7 01 01 01 33 00 00'\r\n '62 24 00 01 07 33 00 00 DB D7 01 01 01 33 00 00 13 FF 00 01 0B 33 00 00 EF D7 01 01 01 33 00 00'\r\n '05 F1 01 02 10 34 00 00 2C 00 00 8B 24 00 02 10 34 00 00 2E 00 00 B5 32 00 02 07 34 00 00 30 00'\r\n '00 B6 32 00 02 07 34 00 00 31 00 00 B7 32 00 02 07 34 00 00 32 00 00 B8 32 00 02 07 34 00 00 33'\r\n '00 00 B9 32 00 02 07 34 00 00 34 00 00 BA 32 00 02 07 34 00 00 35 00 00 BB 32 00 02 07 34 00 00'\r\n '36 00 00 BC 32 00 02 07 34 00 00 37 00 00 BD 32 00 02 07 34 00 00 38 00 00 BE 32 00 02 07 34 00'\r\n '00 39 00 00 58 21 00 03 0F 34 00 00 44 20 00 35 00 00 E3 33 00 02 10 34 00 00 E5 65 00 C3 32 00'\r\n '02 10 34 00 00 08 67 00 5C 33 00 02 10 34 00 00 B9 70 00 14 FF 00 01 0B 34 00 00 63 24 00 01 07'\r\n '34 00 00 FA D7 01 01 01 34 00 00 E6 D7 01 01 01 34 00 00 DC D7 01 01 01 34 00 00 84 20 00 01 09'\r\n '34 00 00 D2 D7 01 01 01 34 00 00 74 20 00 01 08 34 00 00 F0 D7 01 01 01 34 00 00 06 F1 01 02 10'\r\n '35 00 00 2C 00 00 8C 24 00 02 10 35 00 00 2E 00 00 BF 32 00 02 07 35 00 00 30 00 00 5A 21 00 03'\r\n '0F 35 00 00 44 20 00 36 00 00 5D 21 00 03 0F 35 00 00 44 20 00 38 00 00 E4 33 00 02 10 35 00 00'\r\n 'E5 65 00 C4 32 00 02 10 35 00 00 08 67 00 5D 33 00 02 10 35 00 00 B9 70 00 15 FF 00 01 0B 35 00'\r\n '00 FB D7 01 01 01 35 00 00 D3 D7 01 01 01 35 00 00 DD D7 01 01 01 35 00 00 E7 D7 01 01 01 35 00'\r\n '00 F1 D7 01 01 01 35 00 00 64 24 00 01 07 35 00 00 75 20 00 01 08 35 00 00 85 20 00 01 09 35 00'\r\n '00 07 F1 01 02 10 36 00 00 2C 00 00 8D 24 00 02 10 36 00 00 2E 00 00 E5 33 00 02 10 36 00 00 E5'\r\n '65 00 C5 32 00 02 10 36 00 00 08 67 00 5E 33 00 02 10 36 00 00 B9 70 00 D4 D7 01 01 01 36 00 00'\r\n '76 20 00 01 08 36 00 00 16 FF 00 01 0B 36 00 00 E8 D7 01 01 01 36 00 00 FC D7 01 01 01 36 00 00'\r\n 'DE D7 01 01 01 36 00 00 86 20 00 01 09 36 00 00 F2 D7 01 01 01 36 00 00 65 24 00 01 07 36 00 00'\r\n '08 F1 01 02 10 37 00 00 2C 00 00 8E 24 00 02 10 37 00 00 2E 00 00 5E 21 00 03 0F 37 00 00 44 20'\r\n '00 38 00 00 E6 33 00 02 10 37 00 00 E5 65 00 C6 32 00 02 10 37 00 00 08 67 00 5F 33 00 02 10 37'\r\n '00 00 B9 70 00 E9 D7 01 01 01 37 00 00 87 20 00 01 09 37 00 00 77 20 00 01 08 37 00 00 FD D7 01'\r\n '01 01 37 00 00 D5 D7 01 01 01 37 00 00 F3 D7 01 01 01 37 00 00 17 FF 00 01 0B 37 00 00 66 24 00'\r\n '01 07 37 00 00 DF D7 01 01 01 37 00 00 09 F1 01 02 10 38 00 00 2C 00 00 8F 24 00 02 10 38 00 00'\r\n '2E 00 00 E7 33 00 02 10 38 00 00 E5 65 00 C7 32 00 02 10 38 00 00 08 67 00 60 33 00 02 10 38 00'\r\n '00 B9 70 00 F4 D7 01 01 01 38 00 00 FE D7 01 01 01 38 00 00 67 24 00 01 07 38 00 00 EA D7 01 01'\r\n '01 38 00 00 88 20 00 01 09 38 00 00 78 20 00 01 08 38 00 00 18 FF 00 01 0B 38 00 00 E0 D7 01 01'\r\n '01 38 00 00 D6 D7 01 01 01 38 00 00 0A F1 01 02 10 39 00 00 2C 00 00 90 24 00 02 10 39 00 00 2E'\r\n '00 00 E8 33 00 02 10 39 00 00 E5 65 00 C8 32 00 02 10 39 00 00 08 67 00 61 33 00 02 10 39 00 00'\r\n 'B9 70 00 F5 D7 01 01 01 39 00 00 19 FF 00 01 0B 39 00 00 D7 D7 01 01 01 39 00 00 FF D7 01 01 01'\r\n '39 00 00 68 24 00 01 07 39 00 00 EB D7 01 01 01 39 00 00 79 20 00 01 08 39 00 00 E1 D7 01 01 01'\r\n '39 00 00 89 20 00 01 09 39 00 00 74 2A 00 03 10 3A 00 00 3A 00 00 3D 00 00 13 FE 00 01 0A 3A 00'\r\n '00 1A FF 00 01 0B 3A 00 00 55 FE 00 01 0D 3A 00 00 54 FE 00 01 0D 3B 00 00 1B FF 00 01 0B 3B 00'\r\n '00 14 FE 00 01 0A 3B 00 00 6E 22 00 02 00 3C 00 00 38 03 00 64 FE 00 01 0D 3C 00 00 1C FF 00 01'\r\n '0B 3C 00 00 76 2A 00 03 10 3D 00 00 3D 00 00 3D 00 00 75 2A 00 02 10 3D 00 00 3D 00 00 60 22 00'\r\n '02 00 3D 00 00 38 03 00 7C 20 00 01 08 3D 00 00 8C 20 00 01 09 3D 00 00 66 FE 00 01 0D 3D 00 00'\r\n '1D FF 00 01 0B 3D 00 00 6F 22 00 02 00 3E 00 00 38 03 00 65 FE 00 01 0D 3E 00 00 1E FF 00 01 0B'\r\n '3E 00 00 48 20 00 02 10 3F 00 00 21 00 00 47 20 00 02 10 3F 00 00 3F 00 00 56 FE 00 01 0D 3F 00'\r\n '00 1F FF 00 01 0B 3F 00 00 16 FE 00 01 0A 3F 00 00 6B FE 00 01 0D 40 00 00 20 FF 00 01 0B 40 00'\r\n '00 73 33 00 02 0E 41 00 00 55 00 00 C0 00 00 02 00 41 00 00 00 03 00 C1 00 00 02 00 41 00 00 01'\r\n '03 00 A6 1E 00 03 00 41 00 00 02 03 00 00 03 00 A4 1E 00 03 00 41 00 00 02 03 00 01 03 00 AA 1E'\r\n '00 03 00 41 00 00 02 03 00 03 03 00 A8 1E 00 03 00 41 00 00 02 03 00 09 03 00 C2 00 00 02 00 41'\r\n '00 00 02 03 00 C3 00 00 02 00 41 00 00 03 03 00 00 01 00 02 00 41 00 00 04 03 00 B0 1E 00 03 00'\r\n '41 00 00 06 03 00 00 03 00 AE 1E 00 03 00 41 00 00 06 03 00 01 03 00 B4 1E 00 03 00 41 00 00 06'\r\n '03 00 03 03 00 B2 1E 00 03 00 41 00 00 06 03 00 09 03 00 02 01 00 02 00 41 00 00 06 03 00 E0 01'\r\n '00 03 00 41 00 00 07 03 00 04 03 00 26 02 00 02 00 41 00 00 07 03 00 DE 01 00 03 00 41 00 00 08'\r\n '03 00 04 03 00 C4 00 00 02 00 41 00 00 08 03 00 A2 1E 00 02 00 41 00 00 09 03 00 FA 01 00 03 00'\r\n '41 00 00 0A 03 00 01 03 00 C5 00 00 02 00 41 00 00 0A 03 00 CD 01 00 02 00 41 00 00 0C 03 00 00'\r\n '02 00 02 00 41 00 00 0F 03 00 02 02 00 02 00 41 00 00 11 03 00 AC 1E 00 03 00 41 00 00 23 03 00'\r\n '02 03 00 B6 1E 00 03 00 41 00 00 23 03 00 06 03 00 A0 1E 00 02 00 41 00 00 23 03 00 00 1E 00 02'\r\n '00 41 00 00 25 03 00 04 01 00 02 00 41 00 00 28 03 00 DF 33 00 03 0E 41 00 00 15 22 00 6D 00 00'\r\n '38 D5 01 01 01 41 00 00 9C D4 01 01 01 41 00 00 D0 D4 01 01 01 41 00 00 04 D5 01 01 01 41 00 00'\r\n '6C D5 01 01 01 41 00 00 00 D4 01 01 01 41 00 00 A0 D5 01 01 01 41 00 00 30 F1 01 01 0E 41 00 00'\r\n '08 D6 01 01 01 41 00 00 2C 1D 00 01 08 41 00 00 21 FF 00 01 0B 41 00 00 70 D6 01 01 01 41 00 00'\r\n '3C D6 01 01 01 41 00 00 34 D4 01 01 01 41 00 00 D4 D5 01 01 01 41 00 00 B6 24 00 01 07 41 00 00'\r\n '68 D4 01 01 01 41 00 00 C3 33 00 02 0E 42 00 00 71 00 00 02 1E 00 02 00 42 00 00 07 03 00 04 1E'\r\n '00 02 00 42 00 00 23 03 00 06 1E 00 02 00 42 00 00 31 03 00 35 D4 01 01 01 42 00 00 2C 21 00 01'\r\n '01 42 00 00 39 D5 01 01 01 42 00 00 A1 D5 01 01 01 42 00 00 69 D4 01 01 01 42 00 00 01 D4 01 01'\r\n '01 42 00 00 D1 D4 01 01 01 42 00 00 B7 24 00 01 07 42 00 00 22 FF 00 01 0B 42 00 00 6D D5 01 01'\r\n '01 42 00 00 05 D5 01 01 01 42 00 00 3D D6 01 01 01 42 00 00 71 D6 01 01 01 42 00 00 31 F1 01 01'\r\n '0E 42 00 00 D5 D5 01 01 01 42 00 00 09 D6 01 01 01 42 00 00 2E 1D 00 01 08 42 00 00 2D F1 01 02'\r\n '07 43 00 00 44 00 00 C7 33 00 03 0E 43 00 00 6F 00 00 2E 00 00 06 01 00 02 00 43 00 00 01 03 00'\r\n '08 01 00 02 00 43 00 00 02 03 00 0A 01 00 02 00 43 00 00 07 03 00 0C 01 00 02 00 43 00 00 0C 03'\r\n '00 08 1E 00 03 00 43 00 00 27 03 00 01 03 00 C7 00 00 02 00 43 00 00 27 03 00 C6 33 00 04 0E 43'\r\n '00 00 15 22 00 6B 00 00 67 00 00 72 D6 01 01 01 43 00 00 02 21 00 01 01 43 00 00 6A D4 01 01 01'\r\n '43 00 00 B8 24 00 01 07 43 00 00 D2 D4 01 01 01 43 00 00 3E D6 01 01 01 43 00 00 6D 21 00 01 10'\r\n '43 00 00 23 FF 00 01 0B 43 00 00 A2 D5 01 01 01 43 00 00 2D 21 00 01 01 43 00 00 02 D4 01 01 01'\r\n '43 00 00 0A D6 01 01 01 43 00 00 2B F1 01 01 07 43 00 00 D6 D5 01 01 01 43 00 00 9E D4 01 01 01'\r\n '43 00 00 6E D5 01 01 01 43 00 00 32 F1 01 01 0E 43 00 00 36 D4 01 01 01 43 00 00 90 F1 01 02 0E'\r\n '44 00 00 4A 00 00 C4 01 00 03 10 44 00 00 5A 00 00 0C 03 00 F1 01 00 02 10 44 00 00 5A 00 00 C5'\r\n '01 00 03 10 44 00 00 7A 00 00 0C 03 00 F2 01 00 02 10 44 00 00 7A 00 00 0A 1E 00 02 00 44 00 00'\r\n '07 03 00 0E 01 00 02 00 44 00 00 0C 03 00 0C 1E 00 02 00 44 00 00 23 03 00 10 1E 00 02 00 44 00'\r\n '00 27 03 00 12 1E 00 02 00 44 00 00 2D 03 00 0E 1E 00 02 00 44 00 00 31 03 00 07 D5 01 01 01 44'\r\n '00 00 0B D6 01 01 01 44 00 00 D3 D4 01 01 01 44 00 00 D7 D5 01 01 01 44 00 00 03 D4 01 01 01 44'\r\n '00 00 24 FF 00 01 0B 44 00 00 6E 21 00 01 10 44 00 00 37 D4 01 01 01 44 00 00 6B D4 01 01 01 44'\r\n '00 00 33 F1 01 01 0E 44 00 00 45 21 00 01 01 44 00 00 6F D5 01 01 01 44 00 00 30 1D 00 01 08 44'\r\n '00 00 A3 D5 01 01 01 44 00 00 3B D5 01 01 01 44 00 00 3F D6 01 01 01 44 00 00 9F D4 01 01 01 44'\r\n '00 00 B9 24 00 01 07 44 00 00 73 D6 01 01 01 44 00 00 C8 00 00 02 00 45 00 00 00 03 00 C9 00 00'\r\n '02 00 45 00 00 01 03 00 C0 1E 00 03 00 45 00 00 02 03 00 00 03 00 BE 1E 00 03 00 45 00 00 02 03'\r\n '00 01 03 00 C4 1E 00 03 00 45 00 00 02 03 00 03 03 00 C2 1E 00 03 00 45 00 00 02 03 00 09 03 00'\r\n 'CA 00 00 02 00 45 00 00 02 03 00 BC 1E 00 02 00 45 00 00 03 03 00 14 1E 00 03 00 45 00 00 04 03'\r\n '00 00 03 00 16 1E 00 03 00 45 00 00 04 03 00 01 03 00 12 01 00 02 00 45 00 00 04 03 00 14 01 00'\r\n '02 00 45 00 00 06 03 00 16 01 00 02 00 45 00 00 07 03 00 CB 00 00 02 00 45 00 00 08 03 00 BA 1E'\r\n '00 02 00 45 00 00 09 03 00 1A 01 00 02 00 45 00 00 0C 03 00 04 02 00 02 00 45 00 00 0F 03 00 06'\r\n '02 00 02 00 45 00 00 11 03 00 C6 1E 00 03 00 45 00 00 23 03 00 02 03 00 B8 1E 00 02 00 45 00 00'\r\n '23 03 00 1C 1E 00 03 00 45 00 00 27 03 00 06 03 00 28 02 00 02 00 45 00 00 27 03 00 18 01 00 02'\r\n '00 45 00 00 28 03 00 18 1E 00 02 00 45 00 00 2D 03 00 1A 1E 00 02 00 45 00 00 30 03 00 04 D4 01'\r\n '01 01 45 00 00 38 D4 01 01 01 45 00 00 74 D6 01 01 01 45 00 00 D8 D5 01 01 01 45 00 00 BA 24 00'\r\n '01 07 45 00 00 70 D5 01 01 01 45 00 00 3C D5 01 01 01 45 00 00 31 1D 00 01 08 45 00 00 34 F1 01'\r\n '01 0E 45 00 00 0C D6 01 01 01 45 00 00 08 D5 01 01 01 45 00 00 40 D6 01 01 01 45 00 00 A4 D5 01'\r\n '01 01 45 00 00 6C D4 01 01 01 45 00 00 25 FF 00 01 0B 45 00 00 30 21 00 01 01 45 00 00 D4 D4 01'\r\n '01 01 45 00 00 3B 21 00 03 10 46 00 00 41 00 00 58 00 00 1E 1E 00 02 00 46 00 00 07 03 00 39 D4'\r\n '01 01 01 46 00 00 26 FF 00 01 0B 46 00 00 6D D4 01 01 01 46 00 00 71 D5 01 01 01 46 00 00 0D D6'\r\n '01 01 01 46 00 00 3D D5 01 01 01 46 00 00 D5 D4 01 01 01 46 00 00 BB 24 00 01 07 46 00 00 31 21'\r\n '00 01 01 46 00 00 05 D4 01 01 01 46 00 00 75 D6 01 01 01 46 00 00 41 D6 01 01 01 46 00 00 A5 D5'\r\n '01 01 01 46 00 00 09 D5 01 01 01 46 00 00 D9 D5 01 01 01 46 00 00 35 F1 01 01 0E 46 00 00 87 33'\r\n '00 02 0E 47 00 00 42 00 00 93 33 00 03 0E 47 00 00 48 00 00 7A 00 00 AC 33 00 03 0E 47 00 00 50'\r\n '00 00 61 00 00 C9 33 00 02 0E 47 00 00 79 00 00 F4 01 00 02 00 47 00 00 01 03 00 1C 01 00 02 00'\r\n '47 00 00 02 03 00 20 1E 00 02 00 47 00 00 04 03 00 1E 01 00 02 00 47 00 00 06 03 00 20 01 00 02'\r\n '00 47 00 00 07 03 00 E6 01 00 02 00 47 00 00 0C 03 00 22 01 00 02 00 47 00 00 27 03 00 A2 D4 01'\r\n '01 01 47 00 00 6E D4 01 01 01 47 00 00 33 1D 00 01 08 47 00 00 0A D5 01 01 01 47 00 00 27 FF 00'\r\n '01 0B 47 00 00 0E D6 01 01 01 47 00 00 A6 D5 01 01 01 47 00 00 BC 24 00 01 07 47 00 00 3E D5 01'\r\n '01 01 47 00 00 42 D6 01 01 01 47 00 00 76 D6 01 01 01 47 00 00 D6 D4 01 01 01 47 00 00 DA D5 01'\r\n '01 01 47 00 00 72 D5 01 01 01 47 00 00 3A D4 01 01 01 47 00 00 06 D4 01 01 01 47 00 00 36 F1 01'\r\n '01 0E 47 00 00 CB 33 00 02 0E 48 00 00 50 00 00 4A F1 01 02 0E 48 00 00 56 00 00 CC 32 00 02 0E'\r\n '48 00 00 67 00 00 90 33 00 02 0E 48 00 00 7A 00 00 24 01 00 02 00 48 00 00 02 03 00 22 1E 00 02'\r\n '00 48 00 00 07 03 00 26 1E 00 02 00 48 00 00 08 03 00 1E 02 00 02 00 48 00 00 0C 03 00 24 1E 00'\r\n '02 00 48 00 00 23 03 00 28 1E 00 02 00 48 00 00 27 03 00 2A 1E 00 02 00 48 00 00 2E 03 00 D7 D4'\r\n '01 01 01 48 00 00 0D 21 00 01 01 48 00 00 37 F1 01 01 0E 48 00 00 0B 21 00 01 01 48 00 00 0C 21'\r\n '00 01 01 48 00 00 34 1D 00 01 08 48 00 00 28 FF 00 01 0B 48 00 00 A7 D5 01 01 01 48 00 00 0F D6'\r\n '01 01 01 48 00 00 73 D5 01 01 01 48 00 00 BD 24 00 01 07 48 00 00 6F D4 01 01 01 48 00 00 3B D4'\r\n '01 01 01 48 00 00 DB D5 01 01 01 48 00 00 07 D4 01 01 01 48 00 00 77 D6 01 01 01 48 00 00 43 D6'\r\n '01 01 01 48 00 00 62 21 00 03 10 49 00 00 49 00 00 49 00 00 61 21 00 02 10 49 00 00 49 00 00 32'\r\n '01 00 02 10 49 00 00 4A 00 00 7A 33 00 02 0E 49 00 00 55 00 00 63 21 00 02 10 49 00 00 56 00 00'\r\n '68 21 00 02 10 49 00 00 58 00 00 CC 00 00 02 00 49 00 00 00 03 00 CD 00 00 02 00 49 00 00 01 03'\r\n '00 CE 00 00 02 00 49 00 00 02 03 00 28 01 00 02 00 49 00 00 03 03 00 2A 01 00 02 00 49 00 00 04'\r\n '03 00 2C 01 00 02 00 49 00 00 06 03 00 30 01 00 02 00 49 00 00 07 03 00 2E 1E 00 03 00 49 00 00'\r\n '08 03 00 01 03 00 CF 00 00 02 00 49 00 00 08 03 00 C8 1E 00 02 00 49 00 00 09 03 00 CF 01 00 02'\r\n '00 49 00 00 0C 03 00 08 02 00 02 00 49 00 00 0F 03 00 0A 02 00 02 00 49 00 00 11 03 00 CA 1E 00'\r\n '02 00 49 00 00 23 03 00 2E 01 00 02 00 49 00 00 28 03 00 2C 1E 00 02 00 49 00 00 30 03 00 DC D5'\r\n '01 01 01 49 00 00 44 D6 01 01 01 49 00 00 10 21 00 01 01 49 00 00 11 21 00 01 01 49 00 00 40 D5'\r\n '01 01 01 49 00 00 08 D4 01 01 01 49 00 00 D8 D4 01 01 01 49 00 00 A8 D5 01 01 01 49 00 00 10 D6'\r\n '01 01 01 49 00 00 70 D4 01 01 01 49 00 00 3C D4 01 01 01 49 00 00 74 D5 01 01 01 49 00 00 29 FF'\r\n '00 01 0B 49 00 00 38 F1 01 01 0E 49 00 00 78 D6 01 01 01 49 00 00 60 21 00 01 10 49 00 00 35 1D'\r\n '00 01 08 49 00 00 BE 24 00 01 07 49 00 00 34 01 00 02 00 4A 00 00 02 03 00 A5 D4 01 01 01 4A 00'\r\n '00 3D D4 01 01 01 4A 00 00 0D D5 01 01 01 4A 00 00 79 D6 01 01 01 4A 00 00 09 D4 01 01 01 4A 00'\r\n '00 75 D5 01 01 01 4A 00 00 BF 24 00 01 07 4A 00 00 D9 D4 01 01 01 4A 00 00 39 F1 01 01 0E 4A 00'\r\n '00 36 1D 00 01 08 4A 00 00 45 D6 01 01 01 4A 00 00 71 D4 01 01 01 4A 00 00 41 D5 01 01 01 4A 00'\r\n '00 2A FF 00 01 0B 4A 00 00 11 D6 01 01 01 4A 00 00 A9 D5 01 01 01 4A 00 00 DD D5 01 01 01 4A 00'\r\n '00 85 33 00 02 0E 4B 00 00 42 00 00 CD 33 00 02 0E 4B 00 00 4B 00 00 CE 33 00 02 0E 4B 00 00 4D'\r\n '00 00 30 1E 00 02 00 4B 00 00 01 03 00 E8 01 00 02 00 4B 00 00 0C 03 00 32 1E 00 02 00 4B 00 00'\r\n '23 03 00 36 01 00 02 00 4B 00 00 27 03 00 34 1E 00 02 00 4B 00 00 31 03 00 42 D5 01 01 01 4B 00'\r\n '00 76 D5 01 01 01 4B 00 00 A6 D4 01 01 01 4B 00 00 AA D5 01 01 01 4B 00 00 DE D5 01 01 01 4B 00'\r\n '00 2B FF 00 01 0B 4B 00 00 72 D4 01 01 01 4B 00 00 7A D6 01 01 01 4B 00 00 46 D6 01 01 01 4B 00'\r\n '00 3E D4 01 01 01 4B 00 00 0A D4 01 01 01 4B 00 00 3A F1 01 01 0E 4B 00 00 0E D5 01 01 01 4B 00'\r\n '00 DA D4 01 01 01 4B 00 00 C0 24 00 01 07 4B 00 00 37 1D 00 01 08 4B 00 00 12 D6 01 01 01 4B 00'\r\n '00 C7 01 00 02 10 4C 00 00 4A 00 00 CF 32 00 03 0E 4C 00 00 54 00 00 44 00 00 C8 01 00 02 10 4C'\r\n '00 00 6A 00 00 3F 01 00 02 10 4C 00 00 B7 00 00 39 01 00 02 00 4C 00 00 01 03 00 3D 01 00 02 00'\r\n '4C 00 00 0C 03 00 38 1E 00 03 00 4C 00 00 23 03 00 04 03 00 36 1E 00 02 00 4C 00 00 23 03 00 3B'\r\n '01 00 02 00 4C 00 00 27 03 00 3C 1E 00 02 00 4C 00 00 2D 03 00 3A 1E 00 02 00 4C 00 00 31 03 00'\r\n 'DB D4 01 01 01 4C 00 00 3B F1 01 01 0E 4C 00 00 7B D6 01 01 01 4C 00 00 6C 21 00 01 10 4C 00 00'\r\n '43 D5 01 01 01 4C 00 00 13 D6 01 01 01 4C 00 00 3F D4 01 01 01 4C 00 00 47 D6 01 01 01 4C 00 00'\r\n '38 1D 00 01 08 4C 00 00 12 21 00 01 01 4C 00 00 77 D5 01 01 01 4C 00 00 0B D4 01 01 01 4C 00 00'\r\n 'DF D5 01 01 01 4C 00 00 2C FF 00 01 0B 4C 00 00 AB D5 01 01 01 4C 00 00 73 D4 01 01 01 4C 00 00'\r\n 'C1 24 00 01 07 4C 00 00 0F D5 01 01 01 4C 00 00 86 33 00 02 0E 4D 00 00 42 00 00 92 33 00 03 0E'\r\n '4D 00 00 48 00 00 7A 00 00 AB 33 00 03 0E 4D 00 00 50 00 00 61 00 00 4B F1 01 02 0E 4D 00 00 56'\r\n '00 00 B9 33 00 02 0E 4D 00 00 56 00 00 BF 33 00 02 0E 4D 00 00 57 00 00 3E 1E 00 02 00 4D 00 00'\r\n '01 03 00 40 1E 00 02 00 4D 00 00 07 03 00 42 1E 00 02 00 4D 00 00 23 03 00 C1 33 00 02 0E 4D 00'\r\n '00 A9 03 00 2D FF 00 01 0B 4D 00 00 48 D6 01 01 01 4D 00 00 74 D4 01 01 01 4D 00 00 33 21 00 01'\r\n '01 4D 00 00 10 D5 01 01 01 4D 00 00 6F 21 00 01 10 4D 00 00 44 D5 01 01 01 4D 00 00 40 D4 01 01'\r\n '01 4D 00 00 14 D6 01 01 01 4D 00 00 3C F1 01 01 0E 4D 00 00 C2 24 00 01 07 4D 00 00 E0 D5 01 01'\r\n '01 4D 00 00 DC D4 01 01 01 4D 00 00 7C D6 01 01 01 4D 00 00 AC D5 01 01 01 4D 00 00 39 1D 00 01'\r\n '08 4D 00 00 78 D5 01 01 01 4D 00 00 0C D4 01 01 01 4D 00 00 CA 01 00 02 10 4E 00 00 4A 00 00 CB'\r\n '01 00 02 10 4E 00 00 6A 00 00 16 21 00 02 10 4E 00 00 6F 00 00 F8 01 00 02 00 4E 00 00 00 03 00'\r\n '43 01 00 02 00 4E 00 00 01 03 00 D1 00 00 02 00 4E 00 00 03 03 00 44 1E 00 02 00 4E 00 00 07 03'\r\n '00 47 01 00 02 00 4E 00 00 0C 03 00 46 1E 00 02 00 4E 00 00 23 03 00 45 01 00 02 00 4E 00 00 27'\r\n '03 00 4A 1E 00 02 00 4E 00 00 2D 03 00 48 1E 00 02 00 4E 00 00 31 03 00 41 D4 01 01 01 4E 00 00'\r\n '7D D6 01 01 01 4E 00 00 75 D4 01 01 01 4E 00 00 49 D6 01 01 01 4E 00 00 3D F1 01 01 0E 4E 00 00'\r\n '15 21 00 01 01 4E 00 00 79 D5 01 01 01 4E 00 00 15 D6 01 01 01 4E 00 00 E1 D5 01 01 01 4E 00 00'\r\n 'DD D4 01 01 01 4E 00 00 C3 24 00 01 07 4E 00 00 A9 D4 01 01 01 4E 00 00 3A 1D 00 01 08 4E 00 00'\r\n '2E FF 00 01 0B 4E 00 00 AD D5 01 01 01 4E 00 00 0D D4 01 01 01 4E 00 00 11 D5 01 01 01 4E 00 00'\r\n 'D2 00 00 02 00 4F 00 00 00 03 00 D3 00 00 02 00 4F 00 00 01 03 00 D2 1E 00 03 00 4F 00 00 02 03'\r\n '00 00 03 00 D0 1E 00 03 00 4F 00 00 02 03 00 01 03 00 D6 1E 00 03 00 4F 00 00 02 03 00 03 03 00'\r\n 'D4 1E 00 03 00 4F 00 00 02 03 00 09 03 00 D4 00 00 02 00 4F 00 00 02 03 00 4C 1E 00 03 00 4F 00'\r\n '00 03 03 00 01 03 00 2C 02 00 03 00 4F 00 00 03 03 00 04 03 00 4E 1E 00 03 00 4F 00 00 03 03 00'\r\n '08 03 00 D5 00 00 02 00 4F 00 00 03 03 00 50 1E 00 03 00 4F 00 00 04 03 00 00 03 00 52 1E 00 03'\r\n '00 4F 00 00 04 03 00 01 03 00 4C 01 00 02 00 4F 00 00 04 03 00 4E 01 00 02 00 4F 00 00 06 03 00'\r\n '30 02 00 03 00 4F 00 00 07 03 00 04 03 00 2E 02 00 02 00 4F 00 00 07 03 00 2A 02 00 03 00 4F 00'\r\n '00 08 03 00 04 03 00 D6 00 00 02 00 4F 00 00 08 03 00 CE 1E 00 02 00 4F 00 00 09 03 00 50 01 00'\r\n '02 00 4F 00 00 0B 03 00 D1 01 00 02 00 4F 00 00 0C 03 00 0C 02 00 02 00 4F 00 00 0F 03 00 0E 02'\r\n '00 02 00 4F 00 00 11 03 00 DC 1E 00 03 00 4F 00 00 1B 03 00 00 03 00 DA 1E 00 03 00 4F 00 00 1B'\r\n '03 00 01 03 00 E0 1E 00 03 00 4F 00 00 1B 03 00 03 03 00 DE 1E 00 03 00 4F 00 00 1B 03 00 09 03'\r\n '00 E2 1E 00 03 00 4F 00 00 1B 03 00 23 03 00 A0 01 00 02 00 4F 00 00 1B 03 00 D8 1E 00 03 00 4F'\r\n '00 00 23 03 00 02 03 00 CC 1E 00 02 00 4F 00 00 23 03 00 EC 01 00 03 00 4F 00 00 28 03 00 04 03'\r\n '00 EA 01 00 02 00 4F 00 00 28 03 00 AE D5 01 01 01 4F 00 00 7E D6 01 01 01 4F 00 00 E2 D5 01 01'\r\n '01 4F 00 00 3C 1D 00 01 08 4F 00 00 AA D4 01 01 01 4F 00 00 76 D4 01 01 01 4F 00 00 C4 24 00 01'\r\n '07 4F 00 00 4A D6 01 01 01 4F 00 00 46 D5 01 01 01 4F 00 00 42 D4 01 01 01 4F 00 00 2F FF 00 01'\r\n '0B 4F 00 00 0E D4 01 01 01 4F 00 00 12 D5 01 01 01 4F 00 00 7A D5 01 01 01 4F 00 00 3E F1 01 01'\r\n '0E 4F 00 00 16 D6 01 01 01 4F 00 00 DE D4 01 01 01 4F 00 00 D7 33 00 02 0E 50 00 00 48 00 00 D9'\r\n '33 00 03 0E 50 00 00 50 00 00 4D 00 00 4E F1 01 03 0E 50 00 00 50 00 00 56 00 00 DA 33 00 02 0E'\r\n '50 00 00 52 00 00 50 32 00 03 0E 50 00 00 54 00 00 45 00 00 A9 33 00 02 0E 50 00 00 61 00 00 54'\r\n '1E 00 02 00 50 00 00 01 03 00 56 1E 00 02 00 50 00 00 07 03 00 19 21 00 01 01 50 00 00 7B D5 01'\r\n '01 01 50 00 00 E3 D5 01 01 01 50 00 00 3E 1D 00 01 08 50 00 00 0F D4 01 01 01 50 00 00 3F F1 01'\r\n '01 0E 50 00 00 17 D6 01 01 01 50 00 00 77 D4 01 01 01 50 00 00 AB D4 01 01 01 50 00 00 DF D4 01'\r\n '01 01 50 00 00 30 FF 00 01 0B 50 00 00 C5 24 00 01 07 50 00 00 13 D5 01 01 01 50 00 00 7F D6 01'\r\n '01 01 50 00 00 43 D4 01 01 01 50 00 00 AF D5 01 01 01 50 00 00 4B D6 01 01 01 50 00 00 40 F1 01'\r\n '01 0E 51 00 00 80 D6 01 01 01 51 00 00 7C D5 01 01 01 51 00 00 E4 D5 01 01 01 51 00 00 14 D5 01'\r\n '01 01 51 00 00 AC D4 01 01 01 51 00 00 10 D4 01 01 01 51 00 00 1A 21 00 01 01 51 00 00 78 D4 01'\r\n '01 01 51 00 00 C6 24 00 01 07 51 00 00 31 FF 00 01 0B 51 00 00 B0 D5 01 01 01 51 00 00 44 D4 01'\r\n '01 01 51 00 00 4C D6 01 01 01 51 00 00 E0 D4 01 01 01 51 00 00 18 D6 01 01 01 51 00 00 A8 20 00'\r\n '02 10 52 00 00 73 00 00 54 01 00 02 00 52 00 00 01 03 00 58 1E 00 02 00 52 00 00 07 03 00 58 01'\r\n '00 02 00 52 00 00 0C 03 00 10 02 00 02 00 52 00 00 0F 03 00 12 02 00 02 00 52 00 00 11 03 00 5C'\r\n '1E 00 03 00 52 00 00 23 03 00 04 03 00 5A 1E 00 02 00 52 00 00 23 03 00 56 01 00 02 00 52 00 00'\r\n '27 03 00 5E 1E 00 02 00 52 00 00 31 03 00 19 D6 01 01 01 52 00 00 41 F1 01 01 0E 52 00 00 E5 D5'\r\n '01 01 01 52 00 00 1D 21 00 01 01 52 00 00 1B 21 00 01 01 52 00 00 1C 21 00 01 01 52 00 00 E1 D4'\r\n '01 01 01 52 00 00 2C F1 01 01 07 52 00 00 C7 24 00 01 07 52 00 00 45 D4 01 01 01 52 00 00 81 D6'\r\n '01 01 01 52 00 00 32 FF 00 01 0B 52 00 00 B1 D5 01 01 01 52 00 00 4D D6 01 01 01 52 00 00 7D D5'\r\n '01 01 01 52 00 00 11 D4 01 01 01 52 00 00 3F 1D 00 01 08 52 00 00 79 D4 01 01 01 52 00 00 4C F1'\r\n '01 02 0E 53 00 00 44 00 00 20 21 00 02 08 53 00 00 4D 00 00 4D F1 01 02 0E 53 00 00 53 00 00 DC'\r\n '33 00 02 0E 53 00 00 76 00 00 64 1E 00 03 00 53 00 00 01 03 00 07 03 00 5A 01 00 02 00 53 00 00'\r\n '01 03 00 5C 01 00 02 00 53 00 00 02 03 00 60 1E 00 02 00 53 00 00 07 03 00 66 1E 00 03 00 53 00'\r\n '00 0C 03 00 07 03 00 60 01 00 02 00 53 00 00 0C 03 00 68 1E 00 03 00 53 00 00 23 03 00 07 03 00'\r\n '62 1E 00 02 00 53 00 00 23 03 00 18 02 00 02 00 53 00 00 26 03 00 5E 01 00 02 00 53 00 00 27 03'\r\n '00 7A D4 01 01 01 53 00 00 82 D6 01 01 01 53 00 00 12 D4 01 01 01 53 00 00 46 D4 01 01 01 53 00'\r\n '00 B2 D5 01 01 01 53 00 00 33 FF 00 01 0B 53 00 00 4A D5 01 01 01 53 00 00 7E D5 01 01 01 53 00'\r\n '00 4E D6 01 01 01 53 00 00 16 D5 01 01 01 53 00 00 C8 24 00 01 07 53 00 00 AE D4 01 01 01 53 00'\r\n '00 E6 D5 01 01 01 53 00 00 1A D6 01 01 01 53 00 00 42 F1 01 01 0E 53 00 00 E2 D4 01 01 01 53 00'\r\n '00 21 21 00 03 10 54 00 00 45 00 00 4C 00 00 94 33 00 03 0E 54 00 00 48 00 00 7A 00 00 22 21 00'\r\n '02 08 54 00 00 4D 00 00 6A 1E 00 02 00 54 00 00 07 03 00 64 01 00 02 00 54 00 00 0C 03 00 6C 1E'\r\n '00 02 00 54 00 00 23 03 00 1A 02 00 02 00 54 00 00 26 03 00 62 01 00 02 00 54 00 00 27 03 00 70'\r\n '1E 00 02 00 54 00 00 2D 03 00 6E 1E 00 02 00 54 00 00 31 03 00 7F D5 01 01 01 54 00 00 34 FF 00'\r\n '01 0B 54 00 00 13 D4 01 01 01 54 00 00 83 D6 01 01 01 54 00 00 7B D4 01 01 01 54 00 00 40 1D 00'\r\n '01 08 54 00 00 B3 D5 01 01 01 54 00 00 4F D6 01 01 01 54 00 00 47 D4 01 01 01 54 00 00 1B D6 01'\r\n '01 01 54 00 00 43 F1 01 01 0E 54 00 00 17 D5 01 01 01 54 00 00 4B D5 01 01 01 54 00 00 E3 D4 01'\r\n '01 01 54 00 00 AF D4 01 01 01 54 00 00 E7 D5 01 01 01 54 00 00 C9 24 00 01 07 54 00 00 D9 00 00'\r\n '02 00 55 00 00 00 03 00 DA 00 00 02 00 55 00 00 01 03 00 DB 00 00 02 00 55 00 00 02 03 00 78 1E'\r\n '00 03 00 55 00 00 03 03 00 01 03 00 68 01 00 02 00 55 00 00 03 03 00 7A 1E 00 03 00 55 00 00 04'\r\n '03 00 08 03 00 6A 01 00 02 00 55 00 00 04 03 00 6C 01 00 02 00 55 00 00 06 03 00 DB 01 00 03 00'\r\n '55 00 00 08 03 00 00 03 00 D7 01 00 03 00 55 00 00 08 03 00 01 03 00 D5 01 00 03 00 55 00 00 08'\r\n '03 00 04 03 00 D9 01 00 03 00 55 00 00 08 03 00 0C 03 00 DC 00 00 02 00 55 00 00 08 03 00 E6 1E'\r\n '00 02 00 55 00 00 09 03 00 6E 01 00 02 00 55 00 00 0A 03 00 70 01 00 02 00 55 00 00 0B 03 00 D3'\r\n '01 00 02 00 55 00 00 0C 03 00 14 02 00 02 00 55 00 00 0F 03 00 16 02 00 02 00 55 00 00 11 03 00'\r\n 'EA 1E 00 03 00 55 00 00 1B 03 00 00 03 00 E8 1E 00 03 00 55 00 00 1B 03 00 01 03 00 EE 1E 00 03'\r\n '00 55 00 00 1B 03 00 03 03 00 EC 1E 00 03 00 55 00 00 1B 03 00 09 03 00 F0 1E 00 03 00 55 00 00'\r\n '1B 03 00 23 03 00 AF 01 00 02 00 55 00 00 1B 03 00 E4 1E 00 02 00 55 00 00 23 03 00 72 1E 00 02'\r\n '00 55 00 00 24 03 00 72 01 00 02 00 55 00 00 28 03 00 76 1E 00 02 00 55 00 00 2D 03 00 74 1E 00'\r\n '02 00 55 00 00 30 03 00 41 1D 00 01 08 55 00 00 35 FF 00 01 0B 55 00 00 50 D6 01 01 01 55 00 00'\r\n '48 D4 01 01 01 55 00 00 B4 D5 01 01 01 55 00 00 14 D4 01 01 01 55 00 00 18 D5 01 01 01 55 00 00'\r\n '44 F1 01 01 0E 55 00 00 CA 24 00 01 07 55 00 00 E4 D4 01 01 01 55 00 00 B0 D4 01 01 01 55 00 00'\r\n '7C D4 01 01 01 55 00 00 84 D6 01 01 01 55 00 00 1C D6 01 01 01 55 00 00 E8 D5 01 01 01 55 00 00'\r\n '4C D5 01 01 01 55 00 00 80 D5 01 01 01 55 00 00 67 21 00 04 10 56 00 00 49 00 00 49 00 00 49 00'\r\n '00 66 21 00 03 10 56 00 00 49 00 00 49 00 00 65 21 00 02 10 56 00 00 49 00 00 7C 1E 00 02 00 56'\r\n '00 00 03 03 00 7E 1E 00 02 00 56 00 00 23 03 00 DE 33 00 03 0E 56 00 00 15 22 00 6D 00 00 E5 D4'\r\n '01 01 01 56 00 00 4D D5 01 01 01 56 00 00 36 FF 00 01 0B 56 00 00 7D 2C 00 01 08 56 00 00 45 F1'\r\n '01 01 0E 56 00 00 85 D6 01 01 01 56 00 00 19 D5 01 01 01 56 00 00 1D D6 01 01 01 56 00 00 15 D4'\r\n '01 01 01 56 00 00 B5 D5 01 01 01 56 00 00 81 D5 01 01 01 56 00 00 E9 D5 01 01 01 56 00 00 64 21'\r\n '00 01 10 56 00 00 7D D4 01 01 01 56 00 00 B1 D4 01 01 01 56 00 00 CB 24 00 01 07 56 00 00 51 D6'\r\n '01 01 01 56 00 00 49 D4 01 01 01 56 00 00 4F F1 01 02 0E 57 00 00 43 00 00 2E F1 01 02 07 57 00'\r\n '00 5A 00 00 DD 33 00 02 0E 57 00 00 62 00 00 80 1E 00 02 00 57 00 00 00 03 00 82 1E 00 02 00 57'\r\n '00 00 01 03 00 74 01 00 02 00 57 00 00 02 03 00 86 1E 00 02 00 57 00 00 07 03 00 84 1E 00 02 00'\r\n '57 00 00 08 03 00 88 1E 00 02 00 57 00 00 23 03 00 7E D4 01 01 01 57 00 00 42 1D 00 01 08 57 00'\r\n '00 4E D5 01 01 01 57 00 00 16 D4 01 01 01 57 00 00 E6 D4 01 01 01 57 00 00 46 F1 01 01 0E 57 00'\r\n '00 86 D6 01 01 01 57 00 00 1E D6 01 01 01 57 00 00 4A D4 01 01 01 57 00 00 37 FF 00 01 0B 57 00'\r\n '00 82 D5 01 01 01 57 00 00 52 D6 01 01 01 57 00 00 B2 D4 01 01 01 57 00 00 CC 24 00 01 07 57 00'\r\n '00 1A D5 01 01 01 57 00 00 EA D5 01 01 01 57 00 00 B6 D5 01 01 01 57 00 00 6B 21 00 03 10 58 00'\r\n '00 49 00 00 49 00 00 6A 21 00 02 10 58 00 00 49 00 00 8A 1E 00 02 00 58 00 00 07 03 00 8C 1E 00'\r\n '02 00 58 00 00 08 03 00 B7 D5 01 01 01 58 00 00 EB D5 01 01 01 58 00 00 1F D6 01 01 01 58 00 00'\r\n 'CD 24 00 01 07 58 00 00 4B D4 01 01 01 58 00 00 47 F1 01 01 0E 58 00 00 7F D4 01 01 01 58 00 00'\r\n '69 21 00 01 10 58 00 00 4F D5 01 01 01 58 00 00 B3 D4 01 01 01 58 00 00 E7 D4 01 01 01 58 00 00'\r\n '1B D5 01 01 01 58 00 00 38 FF 00 01 0B 58 00 00 83 D5 01 01 01 58 00 00 53 D6 01 01 01 58 00 00'\r\n '17 D4 01 01 01 58 00 00 87 D6 01 01 01 58 00 00 F2 1E 00 02 00 59 00 00 00 03 00 DD 00 00 02 00'\r\n '59 00 00 01 03 00 76 01 00 02 00 59 00 00 02 03 00 F8 1E 00 02 00 59 00 00 03 03 00 32 02 00 02'\r\n '00 59 00 00 04 03 00 8E 1E 00 02 00 59 00 00 07 03 00 78 01 00 02 00 59 00 00 08 03 00 F6 1E 00'\r\n '02 00 59 00 00 09 03 00 F4 1E 00 02 00 59 00 00 23 03 00 54 D6 01 01 01 59 00 00 20 D6 01 01 01'\r\n '59 00 00 18 D4 01 01 01 59 00 00 1C D5 01 01 01 59 00 00 B8 D5 01 01 01 59 00 00 4C D4 01 01 01'\r\n '59 00 00 CE 24 00 01 07 59 00 00 50 D5 01 01 01 59 00 00 80 D4 01 01 01 59 00 00 84 D5 01 01 01'\r\n '59 00 00 88 D6 01 01 01 59 00 00 EC D5 01 01 01 59 00 00 39 FF 00 01 0B 59 00 00 48 F1 01 01 0E'\r\n '59 00 00 E8 D4 01 01 01 59 00 00 B4 D4 01 01 01 59 00 00 79 01 00 02 00 5A 00 00 01 03 00 90 1E'\r\n '00 02 00 5A 00 00 02 03 00 7B 01 00 02 00 5A 00 00 07 03 00 7D 01 00 02 00 5A 00 00 0C 03 00 92'\r\n '1E 00 02 00 5A 00 00 23 03 00 94 1E 00 02 00 5A 00 00 31 03 00 3A FF 00 01 0B 5A 00 00 55 D6 01'\r\n '01 01 5A 00 00 89 D6 01 01 01 5A 00 00 B5 D4 01 01 01 5A 00 00 81 D4 01 01 01 5A 00 00 E9 D4 01'\r\n '01 01 5A 00 00 24 21 00 01 01 5A 00 00 28 21 00 01 01 5A 00 00 49 F1 01 01 0E 5A 00 00 21 D6 01'\r\n '01 01 5A 00 00 4D D4 01 01 01 5A 00 00 ED D5 01 01 01 5A 00 00 19 D4 01 01 01 5A 00 00 CF 24 00'\r\n '01 07 5A 00 00 85 D5 01 01 01 5A 00 00 B9 D5 01 01 01 5A 00 00 3B FF 00 01 0B 5B 00 00 47 FE 00'\r\n '01 0A 5B 00 00 68 FE 00 01 0D 5C 00 00 3C FF 00 01 0B 5C 00 00 3D FF 00 01 0B 5D 00 00 48 FE 00'\r\n '01 0A 5D 00 00 3E FF 00 01 0B 5E 00 00 33 FE 00 01 0A 5F 00 00 4D FE 00 01 10 5F 00 00 34 FE 00'\r\n '01 0A 5F 00 00 4F FE 00 01 10 5F 00 00 4E FE 00 01 10 5F 00 00 3F FF 00 01 0B 5F 00 00 40 FF 00'\r\n '01 0B 60 00 00 C2 33 00 04 0E 61 00 00 2E 00 00 6D 00 00 2E 00 00 00 21 00 03 10 61 00 00 2F 00'\r\n '00 63 00 00 01 21 00 03 10 61 00 00 2F 00 00 73 00 00 9A 1E 00 02 10 61 00 00 BE 02 00 E0 00 00'\r\n '02 00 61 00 00 00 03 00 E1 00 00 02 00 61 00 00 01 03 00 A7 1E 00 03 00 61 00 00 02 03 00 00 03'\r\n '00 A5 1E 00 03 00 61 00 00 02 03 00 01 03 00 AB 1E 00 03 00 61 00 00 02 03 00 03 03 00 A9 1E 00'\r\n '03 00 61 00 00 02 03 00 09 03 00 E2 00 00 02 00 61 00 00 02 03 00 E3 00 00 02 00 61 00 00 03 03'\r\n '00 01 01 00 02 00 61 00 00 04 03 00 B1 1E 00 03 00 61 00 00 06 03 00 00 03 00 AF 1E 00 03 00 61'\r\n '00 00 06 03 00 01 03 00 B5 1E 00 03 00 61 00 00 06 03 00 03 03 00 B3 1E 00 03 00 61 00 00 06 03'\r\n '00 09 03 00 03 01 00 02 00 61 00 00 06 03 00 E1 01 00 03 00 61 00 00 07 03 00 04 03 00 27 02 00'\r\n '02 00 61 00 00 07 03 00 DF 01 00 03 00 61 00 00 08 03 00 04 03 00 E4 00 00 02 00 61 00 00 08 03'\r\n '00 A3 1E 00 02 00 61 00 00 09 03 00 FB 01 00 03 00 61 00 00 0A 03 00 01 03 00 E5 00 00 02 00 61'\r\n '00 00 0A 03 00 CE 01 00 02 00 61 00 00 0C 03 00 01 02 00 02 00 61 00 00 0F 03 00 03 02 00 02 00'\r\n '61 00 00 11 03 00 AD 1E 00 03 00 61 00 00 23 03 00 02 03 00 B7 1E 00 03 00 61 00 00 23 03 00 06'\r\n '03 00 A1 1E 00 02 00 61 00 00 23 03 00 01 1E 00 02 00 61 00 00 25 03 00 05 01 00 02 00 61 00 00'\r\n '28 03 00 D0 24 00 01 07 61 00 00 B6 D4 01 01 01 61 00 00 90 20 00 01 09 61 00 00 EE D5 01 01 01'\r\n '61 00 00 1E D5 01 01 01 61 00 00 22 D6 01 01 01 61 00 00 86 D5 01 01 01 61 00 00 52 D5 01 01 01'\r\n '61 00 00 AA 00 00 01 08 61 00 00 43 1D 00 01 08 61 00 00 41 FF 00 01 0B 61 00 00 EA D4 01 01 01'\r\n '61 00 00 82 D4 01 01 01 61 00 00 8A D6 01 01 01 61 00 00 4E D4 01 01 01 61 00 00 BA D5 01 01 01'\r\n '61 00 00 1A D4 01 01 01 61 00 00 56 D6 01 01 01 61 00 00 74 33 00 03 0E 62 00 00 61 00 00 72 00'\r\n '00 03 1E 00 02 00 62 00 00 07 03 00 05 1E 00 02 00 62 00 00 23 03 00 07 1E 00 02 00 62 00 00 31'\r\n '03 00 87 D5 01 01 01 62 00 00 4F D4 01 01 01 62 00 00 1F D5 01 01 01 62 00 00 8B D6 01 01 01 62'\r\n '00 00 BB D5 01 01 01 62 00 00 57 D6 01 01 01 62 00 00 EF D5 01 01 01 62 00 00 EB D4 01 01 01 62'\r\n '00 00 47 1D 00 01 08 62 00 00 1B D4 01 01 01 62 00 00 83 D4 01 01 01 62 00 00 23 D6 01 01 01 62'\r\n '00 00 D1 24 00 01 07 62 00 00 53 D5 01 01 01 62 00 00 42 FF 00 01 0B 62 00 00 B7 D4 01 01 01 62'\r\n '00 00 05 21 00 03 10 63 00 00 2F 00 00 6F 00 00 06 21 00 03 10 63 00 00 2F 00 00 75 00 00 88 33'\r\n '00 03 0E 63 00 00 61 00 00 6C 00 00 C4 33 00 02 0E 63 00 00 63 00 00 C5 33 00 02 0E 63 00 00 64'\r\n '00 00 A0 33 00 03 0E 63 00 00 6D 00 00 32 00 00 A4 33 00 03 0E 63 00 00 6D 00 00 33 00 00 9D 33'\r\n '00 02 0E 63 00 00 6D 00 00 07 01 00 02 00 63 00 00 01 03 00 09 01 00 02 00 63 00 00 02 03 00 0B'\r\n '01 00 02 00 63 00 00 07 03 00 0D 01 00 02 00 63 00 00 0C 03 00 09 1E 00 03 00 63 00 00 27 03 00'\r\n '01 03 00 E7 00 00 02 00 63 00 00 27 03 00 24 D6 01 01 01 63 00 00 54 D5 01 01 01 63 00 00 43 FF'\r\n '00 01 0B 63 00 00 F0 D5 01 01 01 63 00 00 9C 1D 00 01 08 63 00 00 88 D5 01 01 01 63 00 00 8C D6'\r\n '01 01 01 63 00 00 50 D4 01 01 01 63 00 00 EC D4 01 01 01 63 00 00 D2 24 00 01 07 63 00 00 B8 D4'\r\n '01 01 01 63 00 00 84 D4 01 01 01 63 00 00 58 D6 01 01 01 63 00 00 20 D5 01 01 01 63 00 00 BC D5'\r\n '01 01 01 63 00 00 1C D4 01 01 01 63 00 00 7D 21 00 01 10 63 00 00 C8 33 00 02 0E 64 00 00 42 00'\r\n '00 72 33 00 02 0E 64 00 00 61 00 00 97 33 00 02 0E 64 00 00 6C 00 00 78 33 00 03 0E 64 00 00 6D'\r\n '00 00 32 00 00 79 33 00 03 0E 64 00 00 6D 00 00 33 00 00 77 33 00 02 0E 64 00 00 6D 00 00 C6 01'\r\n '00 03 10 64 00 00 7A 00 00 0C 03 00 F3 01 00 02 10 64 00 00 7A 00 00 0B 1E 00 02 00 64 00 00 07'\r\n '03 00 0F 01 00 02 00 64 00 00 0C 03 00 0D 1E 00 02 00 64 00 00 23 03 00 11 1E 00 02 00 64 00 00'\r\n '27 03 00 13 1E 00 02 00 64 00 00 2D 03 00 0F 1E 00 02 00 64 00 00 31 03 00 1D D4 01 01 01 64 00'\r\n '00 51 D4 01 01 01 64 00 00 BD D5 01 01 01 64 00 00 F1 D5 01 01 01 64 00 00 46 21 00 01 01 64 00'\r\n '00 21 D5 01 01 01 64 00 00 55 D5 01 01 01 64 00 00 ED D4 01 01 01 64 00 00 85 D4 01 01 01 64 00'\r\n '00 B9 D4 01 01 01 64 00 00 59 D6 01 01 01 64 00 00 25 D6 01 01 01 64 00 00 D3 24 00 01 07 64 00'\r\n '00 89 D5 01 01 01 64 00 00 8D D6 01 01 01 64 00 00 48 1D 00 01 08 64 00 00 44 FF 00 01 0B 64 00'\r\n '00 7E 21 00 01 10 64 00 00 CE 32 00 02 0E 65 00 00 56 00 00 CD 32 00 03 0E 65 00 00 72 00 00 67'\r\n '00 00 E8 00 00 02 00 65 00 00 00 03 00 E9 00 00 02 00 65 00 00 01 03 00 C1 1E 00 03 00 65 00 00'\r\n '02 03 00 00 03 00 BF 1E 00 03 00 65 00 00 02 03 00 01 03 00 C5 1E 00 03 00 65 00 00 02 03 00 03'\r\n '03 00 C3 1E 00 03 00 65 00 00 02 03 00 09 03 00 EA 00 00 02 00 65 00 00 02 03 00 BD 1E 00 02 00'\r\n '65 00 00 03 03 00 15 1E 00 03 00 65 00 00 04 03 00 00 03 00 17 1E 00 03 00 65 00 00 04 03 00 01'\r\n '03 00 13 01 00 02 00 65 00 00 04 03 00 15 01 00 02 00 65 00 00 06 03 00 17 01 00 02 00 65 00 00'\r\n '07 03 00 EB 00 00 02 00 65 00 00 08 03 00 BB 1E 00 02 00 65 00 00 09 03 00 1B 01 00 02 00 65 00'\r\n '00 0C 03 00 05 02 00 02 00 65 00 00 0F 03 00 07 02 00 02 00 65 00 00 11 03 00 C7 1E 00 03 00 65'\r\n '00 00 23 03 00 02 03 00 B9 1E 00 02 00 65 00 00 23 03 00 1D 1E 00 03 00 65 00 00 27 03 00 06 03'\r\n '00 29 02 00 02 00 65 00 00 27 03 00 19 01 00 02 00 65 00 00 28 03 00 19 1E 00 02 00 65 00 00 2D'\r\n '03 00 1B 1E 00 02 00 65 00 00 30 03 00 8A D5 01 01 01 65 00 00 EE D4 01 01 01 65 00 00 45 FF 00'\r\n '01 0B 65 00 00 2F 21 00 01 01 65 00 00 56 D5 01 01 01 65 00 00 49 1D 00 01 08 65 00 00 26 D6 01'\r\n '01 01 65 00 00 8E D6 01 01 01 65 00 00 86 D4 01 01 01 65 00 00 5A D6 01 01 01 65 00 00 22 D5 01'\r\n '01 01 65 00 00 BE D5 01 01 01 65 00 00 1E D4 01 01 01 65 00 00 47 21 00 01 01 65 00 00 91 20 00'\r\n '01 09 65 00 00 F2 D5 01 01 01 65 00 00 D4 24 00 01 07 65 00 00 52 D4 01 01 01 65 00 00 03 FB 00'\r\n '03 10 66 00 00 66 00 00 69 00 00 04 FB 00 03 10 66 00 00 66 00 00 6C 00 00 00 FB 00 02 10 66 00'\r\n '00 66 00 00 01 FB 00 02 10 66 00 00 69 00 00 02 FB 00 02 10 66 00 00 6C 00 00 99 33 00 02 0E 66'\r\n '00 00 6D 00 00 1F 1E 00 02 00 66 00 00 07 03 00 8F D6 01 01 01 66 00 00 5B D6 01 01 01 66 00 00'\r\n '53 D4 01 01 01 66 00 00 8B D5 01 01 01 66 00 00 D5 24 00 01 07 66 00 00 23 D5 01 01 01 66 00 00'\r\n '57 D5 01 01 01 66 00 00 EF D4 01 01 01 66 00 00 BF D5 01 01 01 66 00 00 F3 D5 01 01 01 66 00 00'\r\n '46 FF 00 01 0B 66 00 00 A0 1D 00 01 08 66 00 00 87 D4 01 01 01 66 00 00 1F D4 01 01 01 66 00 00'\r\n '27 D6 01 01 01 66 00 00 BB D4 01 01 01 66 00 00 FF 33 00 03 0E 67 00 00 61 00 00 6C 00 00 F5 01'\r\n '00 02 00 67 00 00 01 03 00 1D 01 00 02 00 67 00 00 02 03 00 21 1E 00 02 00 67 00 00 04 03 00 1F'\r\n '01 00 02 00 67 00 00 06 03 00 21 01 00 02 00 67 00 00 07 03 00 E7 01 00 02 00 67 00 00 0C 03 00'\r\n '23 01 00 02 00 67 00 00 27 03 00 5C D6 01 01 01 67 00 00 88 D4 01 01 01 67 00 00 24 D5 01 01 01'\r\n '67 00 00 F0 D4 01 01 01 67 00 00 90 D6 01 01 01 67 00 00 F4 D5 01 01 01 67 00 00 20 D4 01 01 01'\r\n '67 00 00 58 D5 01 01 01 67 00 00 28 D6 01 01 01 67 00 00 D6 24 00 01 07 67 00 00 8C D5 01 01 01'\r\n '67 00 00 47 FF 00 01 0B 67 00 00 C0 D5 01 01 01 67 00 00 54 D4 01 01 01 67 00 00 0A 21 00 01 01'\r\n '67 00 00 4D 1D 00 01 08 67 00 00 71 33 00 03 0E 68 00 00 50 00 00 61 00 00 CA 33 00 02 0E 68 00'\r\n '00 61 00 00 25 01 00 02 00 68 00 00 02 03 00 23 1E 00 02 00 68 00 00 07 03 00 27 1E 00 02 00 68'\r\n '00 00 08 03 00 1F 02 00 02 00 68 00 00 0C 03 00 25 1E 00 02 00 68 00 00 23 03 00 29 1E 00 02 00'\r\n '68 00 00 27 03 00 2B 1E 00 02 00 68 00 00 2E 03 00 96 1E 00 02 00 68 00 00 31 03 00 B0 02 00 01'\r\n '08 68 00 00 48 FF 00 01 0B 68 00 00 F5 D5 01 01 01 68 00 00 F1 D4 01 01 01 68 00 00 0E 21 00 01'\r\n '01 68 00 00 C1 D5 01 01 01 68 00 00 91 D6 01 01 01 68 00 00 89 D4 01 01 01 68 00 00 25 D5 01 01'\r\n '01 68 00 00 5D D6 01 01 01 68 00 00 8D D5 01 01 01 68 00 00 D7 24 00 01 07 68 00 00 21 D4 01 01'\r\n '01 68 00 00 29 D6 01 01 01 68 00 00 BD D4 01 01 01 68 00 00 59 D5 01 01 01 68 00 00 95 20 00 01'\r\n '09 68 00 00 72 21 00 03 10 69 00 00 69 00 00 69 00 00 71 21 00 02 10 69 00 00 69 00 00 33 01 00'\r\n '02 10 69 00 00 6A 00 00 CC 33 00 02 0E 69 00 00 6E 00 00 73 21 00 02 10 69 00 00 76 00 00 78 21'\r\n '00 02 10 69 00 00 78 00 00 EC 00 00 02 00 69 00 00 00 03 00 ED 00 00 02 00 69 00 00 01 03 00 EE'\r\n '00 00 02 00 69 00 00 02 03 00 29 01 00 02 00 69 00 00 03 03 00 2B 01 00 02 00 69 00 00 04 03 00'\r\n '2D 01 00 02 00 69 00 00 06 03 00 2F 1E 00 03 00 69 00 00 08 03 00 01 03 00 EF 00 00 02 00 69 00'\r\n '00 08 03 00 C9 1E 00 02 00 69 00 00 09 03 00 D0 01 00 02 00 69 00 00 0C 03 00 09 02 00 02 00 69'\r\n '00 00 0F 03 00 0B 02 00 02 00 69 00 00 11 03 00 CB 1E 00 02 00 69 00 00 23 03 00 2F 01 00 02 00'\r\n '69 00 00 28 03 00 2D 1E 00 02 00 69 00 00 30 03 00 2A D6 01 01 01 69 00 00 56 D4 01 01 01 69 00'\r\n '00 C2 D5 01 01 01 69 00 00 5A D5 01 01 01 69 00 00 70 21 00 01 10 69 00 00 F2 D4 01 01 01 69 00'\r\n '00 5E D6 01 01 01 69 00 00 22 D4 01 01 01 69 00 00 D8 24 00 01 07 69 00 00 8E D5 01 01 01 69 00'\r\n '00 26 D5 01 01 01 69 00 00 71 20 00 01 08 69 00 00 F6 D5 01 01 01 69 00 00 8A D4 01 01 01 69 00'\r\n '00 62 1D 00 01 09 69 00 00 48 21 00 01 01 69 00 00 49 FF 00 01 0B 69 00 00 BE D4 01 01 01 69 00'\r\n '00 92 D6 01 01 01 69 00 00 39 21 00 01 01 69 00 00 35 01 00 02 00 6A 00 00 02 03 00 F0 01 00 02'\r\n '00 6A 00 00 0C 03 00 23 D4 01 01 01 6A 00 00 5F D6 01 01 01 6A 00 00 93 D6 01 01 01 6A 00 00 57'\r\n 'D4 01 01 01 6A 00 00 D9 24 00 01 07 6A 00 00 8F D5 01 01 01 6A 00 00 8B D4 01 01 01 6A 00 00 BF'\r\n 'D4 01 01 01 6A 00 00 5B D5 01 01 01 6A 00 00 F7 D5 01 01 01 6A 00 00 C3 D5 01 01 01 6A 00 00 7C'\r\n '2C 00 01 09 6A 00 00 27 D5 01 01 01 6A 00 00 B2 02 00 01 08 6A 00 00 2B D6 01 01 01 6A 00 00 49'\r\n '21 00 01 01 6A 00 00 4A FF 00 01 0B 6A 00 00 F3 D4 01 01 01 6A 00 00 84 33 00 02 0E 6B 00 00 41'\r\n '00 00 91 33 00 03 0E 6B 00 00 48 00 00 7A 00 00 AA 33 00 03 0E 6B 00 00 50 00 00 61 00 00 B8 33'\r\n '00 02 0E 6B 00 00 56 00 00 BE 33 00 02 0E 6B 00 00 57 00 00 89 33 00 04 0E 6B 00 00 63 00 00 61'\r\n '00 00 6C 00 00 8F 33 00 02 0E 6B 00 00 67 00 00 98 33 00 02 0E 6B 00 00 6C 00 00 A2 33 00 03 0E'\r\n '6B 00 00 6D 00 00 32 00 00 A6 33 00 03 0E 6B 00 00 6D 00 00 33 00 00 9E 33 00 02 0E 6B 00 00 6D'\r\n '00 00 CF 33 00 02 0E 6B 00 00 74 00 00 31 1E 00 02 00 6B 00 00 01 03 00 E9 01 00 02 00 6B 00 00'\r\n '0C 03 00 33 1E 00 02 00 6B 00 00 23 03 00 37 01 00 02 00 6B 00 00 27 03 00 35 1E 00 02 00 6B 00'\r\n '00 31 03 00 C0 33 00 02 0E 6B 00 00 A9 03 00 5C D5 01 01 01 6B 00 00 F4 D4 01 01 01 6B 00 00 90'\r\n 'D5 01 01 01 6B 00 00 28 D5 01 01 01 6B 00 00 4F 1D 00 01 08 6B 00 00 24 D4 01 01 01 6B 00 00 2C'\r\n 'D6 01 01 01 6B 00 00 F8 D5 01 01 01 6B 00 00 96 20 00 01 09 6B 00 00 C4 D5 01 01 01 6B 00 00 4B'\r\n 'FF 00 01 0B 6B 00 00 DA 24 00 01 07 6B 00 00 60 D6 01 01 01 6B 00 00 C0 D4 01 01 01 6B 00 00 58'\r\n 'D4 01 01 01 6B 00 00 94 D6 01 01 01 6B 00 00 8C D4 01 01 01 6B 00 00 C9 01 00 02 10 6C 00 00 6A'\r\n '00 00 D0 33 00 02 0E 6C 00 00 6D 00 00 D1 33 00 02 0E 6C 00 00 6E 00 00 D2 33 00 03 0E 6C 00 00'\r\n '6F 00 00 67 00 00 D3 33 00 02 0E 6C 00 00 78 00 00 40 01 00 02 10 6C 00 00 B7 00 00 3A 01 00 02'\r\n '00 6C 00 00 01 03 00 3E 01 00 02 00 6C 00 00 0C 03 00 39 1E 00 03 00 6C 00 00 23 03 00 04 03 00'\r\n '37 1E 00 02 00 6C 00 00 23 03 00 3C 01 00 02 00 6C 00 00 27 03 00 3D 1E 00 02 00 6C 00 00 2D 03'\r\n '00 3B 1E 00 02 00 6C 00 00 31 03 00 61 D6 01 01 01 6C 00 00 E1 02 00 01 08 6C 00 00 95 D6 01 01'\r\n '01 6C 00 00 91 D5 01 01 01 6C 00 00 DB 24 00 01 07 6C 00 00 C5 D5 01 01 01 6C 00 00 29 D5 01 01'\r\n '01 6C 00 00 13 21 00 01 01 6C 00 00 97 20 00 01 09 6C 00 00 25 D4 01 01 01 6C 00 00 8D D4 01 01'\r\n '01 6C 00 00 C1 D4 01 01 01 6C 00 00 59 D4 01 01 01 6C 00 00 F5 D4 01 01 01 6C 00 00 4C FF 00 01'\r\n '0B 6C 00 00 7C 21 00 01 10 6C 00 00 2D D6 01 01 01 6C 00 00 F9 D5 01 01 01 6C 00 00 5D D5 01 01'\r\n '01 6C 00 00 A1 33 00 02 0E 6D 00 00 32 00 00 A5 33 00 02 0E 6D 00 00 33 00 00 83 33 00 02 0E 6D'\r\n '00 00 41 00 00 B7 33 00 02 0E 6D 00 00 56 00 00 BD 33 00 02 0E 6D 00 00 57 00 00 D4 33 00 02 0E'\r\n '6D 00 00 62 00 00 8E 33 00 02 0E 6D 00 00 67 00 00 D5 33 00 03 0E 6D 00 00 69 00 00 6C 00 00 96'\r\n '33 00 02 0E 6D 00 00 6C 00 00 9F 33 00 03 0E 6D 00 00 6D 00 00 32 00 00 A3 33 00 03 0E 6D 00 00'\r\n '6D 00 00 33 00 00 9C 33 00 02 0E 6D 00 00 6D 00 00 D6 33 00 03 0E 6D 00 00 6F 00 00 6C 00 00 B3'\r\n '33 00 02 0E 6D 00 00 73 00 00 3F 1E 00 02 00 6D 00 00 01 03 00 41 1E 00 02 00 6D 00 00 07 03 00'\r\n '43 1E 00 02 00 6D 00 00 23 03 00 A8 33 00 04 0E 6D 00 00 15 22 00 73 00 00 32 00 00 A7 33 00 03'\r\n '0E 6D 00 00 15 22 00 73 00 00 DC 24 00 01 07 6D 00 00 C6 D5 01 01 01 6D 00 00 8E D4 01 01 01 6D'\r\n '00 00 96 D6 01 01 01 6D 00 00 2E D6 01 01 01 6D 00 00 62 D6 01 01 01 6D 00 00 2A D5 01 01 01 6D'\r\n '00 00 26 D4 01 01 01 6D 00 00 5E D5 01 01 01 6D 00 00 98 20 00 01 09 6D 00 00 F6 D4 01 01 01 6D'\r\n '00 00 5A D4 01 01 01 6D 00 00 7F 21 00 01 10 6D 00 00 92 D5 01 01 01 6D 00 00 4D FF 00 01 0B 6D'\r\n '00 00 50 1D 00 01 08 6D 00 00 FA D5 01 01 01 6D 00 00 C2 D4 01 01 01 6D 00 00 81 33 00 02 0E 6E'\r\n '00 00 41 00 00 8B 33 00 02 0E 6E 00 00 46 00 00 B5 33 00 02 0E 6E 00 00 56 00 00 BB 33 00 02 0E'\r\n '6E 00 00 57 00 00 CC 01 00 02 10 6E 00 00 6A 00 00 9A 33 00 02 0E 6E 00 00 6D 00 00 B1 33 00 02'\r\n '0E 6E 00 00 73 00 00 F9 01 00 02 00 6E 00 00 00 03 00 44 01 00 02 00 6E 00 00 01 03 00 F1 00 00'\r\n '02 00 6E 00 00 03 03 00 45 1E 00 02 00 6E 00 00 07 03 00 48 01 00 02 00 6E 00 00 0C 03 00 47 1E'\r\n '00 02 00 6E 00 00 23 03 00 46 01 00 02 00 6E 00 00 27 03 00 4B 1E 00 02 00 6E 00 00 2D 03 00 49'\r\n '1E 00 02 00 6E 00 00 31 03 00 F7 D4 01 01 01 6E 00 00 63 D6 01 01 01 6E 00 00 99 20 00 01 09 6E'\r\n '00 00 DD 24 00 01 07 6E 00 00 8F D4 01 01 01 6E 00 00 5B D4 01 01 01 6E 00 00 2B D5 01 01 01 6E'\r\n '00 00 93 D5 01 01 01 6E 00 00 4E FF 00 01 0B 6E 00 00 97 D6 01 01 01 6E 00 00 27 D4 01 01 01 6E'\r\n '00 00 2F D6 01 01 01 6E 00 00 FB D5 01 01 01 6E 00 00 5F D5 01 01 01 6E 00 00 C3 D4 01 01 01 6E'\r\n '00 00 7F 20 00 01 08 6E 00 00 C7 D5 01 01 01 6E 00 00 75 33 00 02 0E 6F 00 00 56 00 00 F2 00 00'\r\n '02 00 6F 00 00 00 03 00 F3 00 00 02 00 6F 00 00 01 03 00 D3 1E 00 03 00 6F 00 00 02 03 00 00 03'\r\n '00 D1 1E 00 03 00 6F 00 00 02 03 00 01 03 00 D7 1E 00 03 00 6F 00 00 02 03 00 03 03 00 D5 1E 00'\r\n '03 00 6F 00 00 02 03 00 09 03 00 F4 00 00 02 00 6F 00 00 02 03 00 4D 1E 00 03 00 6F 00 00 03 03'\r\n '00 01 03 00 2D 02 00 03 00 6F 00 00 03 03 00 04 03 00 4F 1E 00 03 00 6F 00 00 03 03 00 08 03 00'\r\n 'F5 00 00 02 00 6F 00 00 03 03 00 51 1E 00 03 00 6F 00 00 04 03 00 00 03 00 53 1E 00 03 00 6F 00'\r\n '00 04 03 00 01 03 00 4D 01 00 02 00 6F 00 00 04 03 00 4F 01 00 02 00 6F 00 00 06 03 00 31 02 00'\r\n '03 00 6F 00 00 07 03 00 04 03 00 2F 02 00 02 00 6F 00 00 07 03 00 2B 02 00 03 00 6F 00 00 08 03'\r\n '00 04 03 00 F6 00 00 02 00 6F 00 00 08 03 00 CF 1E 00 02 00 6F 00 00 09 03 00 51 01 00 02 00 6F'\r\n '00 00 0B 03 00 D2 01 00 02 00 6F 00 00 0C 03 00 0D 02 00 02 00 6F 00 00 0F 03 00 0F 02 00 02 00'\r\n '6F 00 00 11 03 00 DD 1E 00 03 00 6F 00 00 1B 03 00 00 03 00 DB 1E 00 03 00 6F 00 00 1B 03 00 01'\r\n '03 00 E1 1E 00 03 00 6F 00 00 1B 03 00 03 03 00 DF 1E 00 03 00 6F 00 00 1B 03 00 09 03 00 E3 1E'\r\n '00 03 00 6F 00 00 1B 03 00 23 03 00 A1 01 00 02 00 6F 00 00 1B 03 00 D9 1E 00 03 00 6F 00 00 23'\r\n '03 00 02 03 00 CD 1E 00 02 00 6F 00 00 23 03 00 ED 01 00 03 00 6F 00 00 28 03 00 04 03 00 EB 01'\r\n '00 02 00 6F 00 00 28 03 00 90 D4 01 01 01 6F 00 00 64 D6 01 01 01 6F 00 00 28 D4 01 01 01 6F 00'\r\n '00 94 D5 01 01 01 6F 00 00 98 D6 01 01 01 6F 00 00 30 D6 01 01 01 6F 00 00 52 1D 00 01 08 6F 00'\r\n '00 60 D5 01 01 01 6F 00 00 BA 00 00 01 08 6F 00 00 4F FF 00 01 0B 6F 00 00 5C D4 01 01 01 6F 00'\r\n '00 34 21 00 01 01 6F 00 00 DE 24 00 01 07 6F 00 00 F8 D4 01 01 01 6F 00 00 2C D5 01 01 01 6F 00'\r\n '00 C8 D5 01 01 01 6F 00 00 92 20 00 01 09 6F 00 00 FC D5 01 01 01 6F 00 00 D8 33 00 04 0E 70 00'\r\n '00 2E 00 00 6D 00 00 2E 00 00 80 33 00 02 0E 70 00 00 41 00 00 8A 33 00 02 0E 70 00 00 46 00 00'\r\n 'B4 33 00 02 0E 70 00 00 56 00 00 BA 33 00 02 0E 70 00 00 57 00 00 76 33 00 02 0E 70 00 00 63 00'\r\n '00 B0 33 00 02 0E 70 00 00 73 00 00 55 1E 00 02 00 70 00 00 01 03 00 57 1E 00 02 00 70 00 00 07'\r\n '03 00 61 D5 01 01 01 70 00 00 29 D4 01 01 01 70 00 00 9A 20 00 01 09 70 00 00 65 D6 01 01 01 70'\r\n '00 00 FD D5 01 01 01 70 00 00 C9 D5 01 01 01 70 00 00 C5 D4 01 01 01 70 00 00 95 D5 01 01 01 70'\r\n '00 00 F9 D4 01 01 01 70 00 00 5D D4 01 01 01 70 00 00 91 D4 01 01 01 70 00 00 DF 24 00 01 07 70'\r\n '00 00 31 D6 01 01 01 70 00 00 2D D5 01 01 01 70 00 00 99 D6 01 01 01 70 00 00 50 FF 00 01 0B 70'\r\n '00 00 56 1D 00 01 08 70 00 00 32 D6 01 01 01 71 00 00 5E D4 01 01 01 71 00 00 E0 24 00 01 07 71'\r\n '00 00 9A D6 01 01 01 71 00 00 CA D5 01 01 01 71 00 00 62 D5 01 01 01 71 00 00 92 D4 01 01 01 71'\r\n '00 00 2E D5 01 01 01 71 00 00 96 D5 01 01 01 71 00 00 2A D4 01 01 01 71 00 00 66 D6 01 01 01 71'\r\n '00 00 FA D4 01 01 01 71 00 00 C6 D4 01 01 01 71 00 00 51 FF 00 01 0B 71 00 00 FE D5 01 01 01 71'\r\n '00 00 AF 33 00 06 0E 72 00 00 61 00 00 64 00 00 15 22 00 73 00 00 32 00 00 AE 33 00 05 0E 72 00'\r\n '00 61 00 00 64 00 00 15 22 00 73 00 00 AD 33 00 03 0E 72 00 00 61 00 00 64 00 00 55 01 00 02 00'\r\n '72 00 00 01 03 00 59 1E 00 02 00 72 00 00 07 03 00 59 01 00 02 00 72 00 00 0C 03 00 11 02 00 02'\r\n '00 72 00 00 0F 03 00 13 02 00 02 00 72 00 00 11 03 00 5D 1E 00 03 00 72 00 00 23 03 00 04 03 00'\r\n '5B 1E 00 02 00 72 00 00 23 03 00 57 01 00 02 00 72 00 00 27 03 00 5F 1E 00 02 00 72 00 00 31 03'\r\n '00 33 D6 01 01 01 72 00 00 63 1D 00 01 09 72 00 00 CB D5 01 01 01 72 00 00 97 D5 01 01 01 72 00'\r\n '00 FF D5 01 01 01 72 00 00 5F D4 01 01 01 72 00 00 52 FF 00 01 0B 72 00 00 2B D4 01 01 01 72 00'\r\n '00 C7 D4 01 01 01 72 00 00 67 D6 01 01 01 72 00 00 9B D6 01 01 01 72 00 00 E1 24 00 01 07 72 00'\r\n '00 63 D5 01 01 01 72 00 00 FB D4 01 01 01 72 00 00 2F D5 01 01 01 72 00 00 B3 02 00 01 08 72 00'\r\n '00 93 D4 01 01 01 72 00 00 DB 33 00 02 0E 73 00 00 72 00 00 05 FB 00 02 10 73 00 00 74 00 00 06'\r\n 'FB 00 02 10 73 00 00 74 00 00 65 1E 00 03 00 73 00 00 01 03 00 07 03 00 5B 01 00 02 00 73 00 00'\r\n '01 03 00 5D 01 00 02 00 73 00 00 02 03 00 61 1E 00 02 00 73 00 00 07 03 00 9B 1E 00 02 00 73 00'\r\n '00 07 03 00 67 1E 00 03 00 73 00 00 0C 03 00 07 03 00 61 01 00 02 00 73 00 00 0C 03 00 69 1E 00'\r\n '03 00 73 00 00 23 03 00 07 03 00 63 1E 00 02 00 73 00 00 23 03 00 19 02 00 02 00 73 00 00 26 03'\r\n '00 5F 01 00 02 00 73 00 00 27 03 00 60 D4 01 01 01 73 00 00 E2 02 00 01 08 73 00 00 E2 24 00 01'\r\n '07 73 00 00 C8 D4 01 01 01 73 00 00 9C D6 01 01 01 73 00 00 00 D6 01 01 01 73 00 00 94 D4 01 01'\r\n '01 73 00 00 7F 01 00 01 10 73 00 00 CC D5 01 01 01 73 00 00 FC D4 01 01 01 73 00 00 68 D6 01 01'\r\n '01 73 00 00 2C D4 01 01 01 73 00 00 30 D5 01 01 01 73 00 00 53 FF 00 01 0B 73 00 00 64 D5 01 01'\r\n '01 73 00 00 34 D6 01 01 01 73 00 00 98 D5 01 01 01 73 00 00 9B 20 00 01 09 73 00 00 6B 1E 00 02'\r\n '00 74 00 00 07 03 00 97 1E 00 02 00 74 00 00 08 03 00 65 01 00 02 00 74 00 00 0C 03 00 6D 1E 00'\r\n '02 00 74 00 00 23 03 00 1B 02 00 02 00 74 00 00 26 03 00 63 01 00 02 00 74 00 00 27 03 00 71 1E'\r\n '00 02 00 74 00 00 2D 03 00 6F 1E 00 02 00 74 00 00 31 03 00 99 D5 01 01 01 74 00 00 9D D6 01 01'\r\n '01 74 00 00 9C 20 00 01 09 74 00 00 61 D4 01 01 01 74 00 00 E3 24 00 01 07 74 00 00 69 D6 01 01'\r\n '01 74 00 00 54 FF 00 01 0B 74 00 00 57 1D 00 01 08 74 00 00 FD D4 01 01 01 74 00 00 2D D4 01 01'\r\n '01 74 00 00 65 D5 01 01 01 74 00 00 C9 D4 01 01 01 74 00 00 01 D6 01 01 01 74 00 00 CD D5 01 01'\r\n '01 74 00 00 31 D5 01 01 01 74 00 00 35 D6 01 01 01 74 00 00 95 D4 01 01 01 74 00 00 F9 00 00 02'\r\n '00 75 00 00 00 03 00 FA 00 00 02 00 75 00 00 01 03 00 FB 00 00 02 00 75 00 00 02 03 00 79 1E 00'\r\n '03 00 75 00 00 03 03 00 01 03 00 69 01 00 02 00 75 00 00 03 03 00 7B 1E 00 03 00 75 00 00 04 03'\r\n '00 08 03 00 6B 01 00 02 00 75 00 00 04 03 00 6D 01 00 02 00 75 00 00 06 03 00 DC 01 00 03 00 75'\r\n '00 00 08 03 00 00 03 00 D8 01 00 03 00 75 00 00 08 03 00 01 03 00 D6 01 00 03 00 75 00 00 08 03'\r\n '00 04 03 00 DA 01 00 03 00 75 00 00 08 03 00 0C 03 00 FC 00 00 02 00 75 00 00 08 03 00 E7 1E 00'\r\n '02 00 75 00 00 09 03 00 6F 01 00 02 00 75 00 00 0A 03 00 71 01 00 02 00 75 00 00 0B 03 00 D4 01'\r\n '00 02 00 75 00 00 0C 03 00 15 02 00 02 00 75 00 00 0F 03 00 17 02 00 02 00 75 00 00 11 03 00 EB'\r\n '1E 00 03 00 75 00 00 1B 03 00 00 03 00 E9 1E 00 03 00 75 00 00 1B 03 00 01 03 00 EF 1E 00 03 00'\r\n '75 00 00 1B 03 00 03 03 00 ED 1E 00 03 00 75 00 00 1B 03 00 09 03 00 F1 1E 00 03 00 75 00 00 1B'\r\n '03 00 23 03 00 B0 01 00 02 00 75 00 00 1B 03 00 E5 1E 00 02 00 75 00 00 23 03 00 73 1E 00 02 00'\r\n '75 00 00 24 03 00 73 01 00 02 00 75 00 00 28 03 00 77 1E 00 02 00 75 00 00 2D 03 00 75 1E 00 02'\r\n '00 75 00 00 30 03 00 55 FF 00 01 0B 75 00 00 58 1D 00 01 08 75 00 00 32 D5 01 01 01 75 00 00 6A'\r\n 'D6 01 01 01 75 00 00 62 D4 01 01 01 75 00 00 E4 24 00 01 07 75 00 00 96 D4 01 01 01 75 00 00 02'\r\n 'D6 01 01 01 75 00 00 FE D4 01 01 01 75 00 00 2E D4 01 01 01 75 00 00 CE D5 01 01 01 75 00 00 66'\r\n 'D5 01 01 01 75 00 00 CA D4 01 01 01 75 00 00 36 D6 01 01 01 75 00 00 9A D5 01 01 01 75 00 00 9E'\r\n 'D6 01 01 01 75 00 00 64 1D 00 01 09 75 00 00 77 21 00 04 10 76 00 00 69 00 00 69 00 00 69 00 00'\r\n '76 21 00 03 10 76 00 00 69 00 00 69 00 00 75 21 00 02 10 76 00 00 69 00 00 7D 1E 00 02 00 76 00'\r\n '00 03 03 00 7F 1E 00 02 00 76 00 00 23 03 00 97 D4 01 01 01 76 00 00 E5 24 00 01 07 76 00 00 CB'\r\n 'D4 01 01 01 76 00 00 9F D6 01 01 01 76 00 00 9B D5 01 01 01 76 00 00 37 D6 01 01 01 76 00 00 67'\r\n 'D5 01 01 01 76 00 00 CF D5 01 01 01 76 00 00 03 D6 01 01 01 76 00 00 5B 1D 00 01 08 76 00 00 65'\r\n '1D 00 01 09 76 00 00 FF D4 01 01 01 76 00 00 63 D4 01 01 01 76 00 00 6B D6 01 01 01 76 00 00 74'\r\n '21 00 01 10 76 00 00 2F D4 01 01 01 76 00 00 33 D5 01 01 01 76 00 00 56 FF 00 01 0B 76 00 00 81'\r\n '1E 00 02 00 77 00 00 00 03 00 83 1E 00 02 00 77 00 00 01 03 00 75 01 00 02 00 77 00 00 02 03 00'\r\n '87 1E 00 02 00 77 00 00 07 03 00 85 1E 00 02 00 77 00 00 08 03 00 98 1E 00 02 00 77 00 00 0A 03'\r\n '00 89 1E 00 02 00 77 00 00 23 03 00 A0 D6 01 01 01 77 00 00 6C D6 01 01 01 77 00 00 04 D6 01 01'\r\n '01 77 00 00 30 D4 01 01 01 77 00 00 34 D5 01 01 01 77 00 00 9C D5 01 01 01 77 00 00 98 D4 01 01'\r\n '01 77 00 00 D0 D5 01 01 01 77 00 00 68 D5 01 01 01 77 00 00 38 D6 01 01 01 77 00 00 CC D4 01 01'\r\n '01 77 00 00 00 D5 01 01 01 77 00 00 57 FF 00 01 0B 77 00 00 64 D4 01 01 01 77 00 00 E6 24 00 01'\r\n '07 77 00 00 B7 02 00 01 08 77 00 00 7B 21 00 03 10 78 00 00 69 00 00 69 00 00 7A 21 00 02 10 78'\r\n '00 00 69 00 00 8B 1E 00 02 00 78 00 00 07 03 00 8D 1E 00 02 00 78 00 00 08 03 00 E3 02 00 01 08'\r\n '78 00 00 65 D4 01 01 01 78 00 00 01 D5 01 01 01 78 00 00 9D D5 01 01 01 78 00 00 E7 24 00 01 07'\r\n '78 00 00 CD D4 01 01 01 78 00 00 31 D4 01 01 01 78 00 00 99 D4 01 01 01 78 00 00 05 D6 01 01 01'\r\n '78 00 00 79 21 00 01 10 78 00 00 39 D6 01 01 01 78 00 00 35 D5 01 01 01 78 00 00 6D D6 01 01 01'\r\n '78 00 00 D1 D5 01 01 01 78 00 00 58 FF 00 01 0B 78 00 00 93 20 00 01 09 78 00 00 A1 D6 01 01 01'\r\n '78 00 00 69 D5 01 01 01 78 00 00 F3 1E 00 02 00 79 00 00 00 03 00 FD 00 00 02 00 79 00 00 01 03'\r\n '00 77 01 00 02 00 79 00 00 02 03 00 F9 1E 00 02 00 79 00 00 03 03 00 33 02 00 02 00 79 00 00 04'\r\n '03 00 8F 1E 00 02 00 79 00 00 07 03 00 FF 00 00 02 00 79 00 00 08 03 00 F7 1E 00 02 00 79 00 00'\r\n '09 03 00 99 1E 00 02 00 79 00 00 0A 03 00 F5 1E 00 02 00 79 00 00 23 03 00 A2 D6 01 01 01 79 00'\r\n '00 9A D4 01 01 01 79 00 00 36 D5 01 01 01 79 00 00 59 FF 00 01 0B 79 00 00 CE D4 01 01 01 79 00'\r\n '00 3A D6 01 01 01 79 00 00 9E D5 01 01 01 79 00 00 B8 02 00 01 08 79 00 00 6E D6 01 01 01 79 00'\r\n '00 66 D4 01 01 01 79 00 00 32 D4 01 01 01 79 00 00 E8 24 00 01 07 79 00 00 D2 D5 01 01 01 79 00'\r\n '00 6A D5 01 01 01 79 00 00 06 D6 01 01 01 79 00 00 02 D5 01 01 01 79 00 00 7A 01 00 02 00 7A 00'\r\n '00 01 03 00 91 1E 00 02 00 7A 00 00 02 03 00 7C 01 00 02 00 7A 00 00 07 03 00 7E 01 00 02 00 7A'\r\n '00 00 0C 03 00 93 1E 00 02 00 7A 00 00 23 03 00 95 1E 00 02 00 7A 00 00 31 03 00 07 D6 01 01 01'\r\n '7A 00 00 CF D4 01 01 01 7A 00 00 D3 D5 01 01 01 7A 00 00 BB 1D 00 01 08 7A 00 00 9F D5 01 01 01'\r\n '7A 00 00 33 D4 01 01 01 7A 00 00 9B D4 01 01 01 7A 00 00 3B D6 01 01 01 7A 00 00 A3 D6 01 01 01'\r\n '7A 00 00 03 D5 01 01 01 7A 00 00 6F D6 01 01 01 7A 00 00 6B D5 01 01 01 7A 00 00 5A FF 00 01 0B'\r\n '7A 00 00 E9 24 00 01 07 7A 00 00 37 D5 01 01 01 7A 00 00 67 D4 01 01 01 7A 00 00 5B FE 00 01 0D'\r\n '7B 00 00 5B FF 00 01 0B 7B 00 00 37 FE 00 01 0A 7B 00 00 5C FF 00 01 0B 7C 00 00 38 FE 00 01 0A'\r\n '7D 00 00 5C FE 00 01 0D 7D 00 00 5D FF 00 01 0B 7D 00 00 5E FF 00 01 0B 7E 00 00 E0 FF 00 01 0B'\r\n 'A2 00 00 E1 FF 00 01 0B A3 00 00 E5 FF 00 01 0B A5 00 00 E4 FF 00 01 0B A6 00 00 E2 FF 00 01 0B'\r\n 'AC 00 00 03 21 00 02 10 B0 00 00 43 00 00 09 21 00 02 10 B0 00 00 46 00 00 FC 01 00 02 00 C6 00'\r\n '00 01 03 00 E2 01 00 02 00 C6 00 00 04 03 00 2D 1D 00 01 08 C6 00 00 FE 01 00 02 00 D8 00 00 01'\r\n '03 00 FD 01 00 02 00 E6 00 00 01 03 00 E3 01 00 02 00 E6 00 00 04 03 00 9E 1D 00 01 08 F0 00 00'\r\n 'FF 01 00 02 00 F8 00 00 01 03 00 0F 21 00 01 01 27 01 00 A4 D6 01 01 01 31 01 00 51 1D 00 01 08'\r\n '4B 01 00 32 1D 00 01 08 8E 01 00 07 21 00 01 10 90 01 00 B5 1D 00 01 08 AB 01 00 EE 01 00 02 00'\r\n 'B7 01 00 0C 03 00 3D 1D 00 01 08 22 02 00 A5 D6 01 01 01 37 02 00 44 1D 00 01 08 50 02 00 45 1D'\r\n '00 01 08 51 02 00 9B 1D 00 01 08 52 02 00 53 1D 00 01 08 54 02 00 9D 1D 00 01 08 55 02 00 94 20'\r\n '00 01 09 59 02 00 4A 1D 00 01 08 59 02 00 4B 1D 00 01 08 5B 02 00 4C 1D 00 01 08 5C 02 00 9F 1D'\r\n '00 01 08 5C 02 00 A1 1D 00 01 08 5F 02 00 A2 1D 00 01 08 61 02 00 E0 02 00 01 08 63 02 00 A3 1D'\r\n '00 01 08 65 02 00 B1 02 00 01 08 66 02 00 A4 1D 00 01 08 68 02 00 A5 1D 00 01 08 69 02 00 A6 1D'\r\n '00 01 08 6A 02 00 A9 1D 00 01 08 6D 02 00 5A 1D 00 01 08 6F 02 00 AD 1D 00 01 08 70 02 00 AC 1D'\r\n '00 01 08 71 02 00 AE 1D 00 01 08 72 02 00 AF 1D 00 01 08 73 02 00 B0 1D 00 01 08 74 02 00 B1 1D'\r\n '00 01 08 75 02 00 B2 1D 00 01 08 78 02 00 B4 02 00 01 08 79 02 00 B5 02 00 01 08 7B 02 00 B6 02'\r\n '00 01 08 81 02 00 B3 1D 00 01 08 82 02 00 B4 1D 00 01 08 83 02 00 B6 1D 00 01 08 89 02 00 B7 1D'\r\n '00 01 08 8A 02 00 B9 1D 00 01 08 8B 02 00 BA 1D 00 01 08 8C 02 00 BC 1D 00 01 08 90 02 00 BD 1D'\r\n '00 01 08 91 02 00 EF 01 00 02 00 92 02 00 0C 03 00 BE 1D 00 01 08 92 02 00 E4 02 00 01 08 95 02'\r\n '00 A8 1D 00 01 08 9D 02 00 AB 1D 00 01 08 9F 02 00 49 01 00 02 10 BC 02 00 6E 00 00 BA 1F 00 02'\r\n '00 91 03 00 00 03 00 86 03 00 02 00 91 03 00 01 03 00 B9 1F 00 02 00 91 03 00 04 03 00 B8 1F 00'\r\n '02 00 91 03 00 06 03 00 8A 1F 00 04 00 91 03 00 13 03 00 00 03 00 45 03 00 0A 1F 00 03 00 91 03'\r\n '00 13 03 00 00 03 00 8C 1F 00 04 00 91 03 00 13 03 00 01 03 00 45 03 00 0C 1F 00 03 00 91 03 00'\r\n '13 03 00 01 03 00 8E 1F 00 04 00 91 03 00 13 03 00 42 03 00 45 03 00 0E 1F 00 03 00 91 03 00 13'\r\n '03 00 42 03 00 88 1F 00 03 00 91 03 00 13 03 00 45 03 00 08 1F 00 02 00 91 03 00 13 03 00 8B 1F'\r\n '00 04 00 91 03 00 14 03 00 00 03 00 45 03 00 0B 1F 00 03 00 91 03 00 14 03 00 00 03 00 8D 1F 00'\r\n '04 00 91 03 00 14 03 00 01 03 00 45 03 00 0D 1F 00 03 00 91 03 00 14 03 00 01 03 00 8F 1F 00 04'\r\n '00 91 03 00 14 03 00 42 03 00 45 03 00 0F 1F 00 03 00 91 03 00 14 03 00 42 03 00 89 1F 00 03 00'\r\n '91 03 00 14 03 00 45 03 00 09 1F 00 02 00 91 03 00 14 03 00 BC 1F 00 02 00 91 03 00 45 03 00 90'\r\n 'D7 01 01 01 91 03 00 1C D7 01 01 01 91 03 00 56 D7 01 01 01 91 03 00 A8 D6 01 01 01 91 03 00 E2'\r\n 'D6 01 01 01 91 03 00 E3 D6 01 01 01 92 03 00 57 D7 01 01 01 92 03 00 1D D7 01 01 01 92 03 00 91'\r\n 'D7 01 01 01 92 03 00 A9 D6 01 01 01 92 03 00 AA D6 01 01 01 93 03 00 1E D7 01 01 01 93 03 00 E4'\r\n 'D6 01 01 01 93 03 00 58 D7 01 01 01 93 03 00 92 D7 01 01 01 93 03 00 3E 21 00 01 01 93 03 00 AB'\r\n 'D6 01 01 01 94 03 00 93 D7 01 01 01 94 03 00 59 D7 01 01 01 94 03 00 1F D7 01 01 01 94 03 00 E5'\r\n 'D6 01 01 01 94 03 00 C8 1F 00 02 00 95 03 00 00 03 00 88 03 00 02 00 95 03 00 01 03 00 1A 1F 00'\r\n '03 00 95 03 00 13 03 00 00 03 00 1C 1F 00 03 00 95 03 00 13 03 00 01 03 00 18 1F 00 02 00 95 03'\r\n '00 13 03 00 1B 1F 00 03 00 95 03 00 14 03 00 00 03 00 1D 1F 00 03 00 95 03 00 14 03 00 01 03 00'\r\n '19 1F 00 02 00 95 03 00 14 03 00 E6 D6 01 01 01 95 03 00 20 D7 01 01 01 95 03 00 94 D7 01 01 01'\r\n '95 03 00 AC D6 01 01 01 95 03 00 5A D7 01 01 01 95 03 00 5B D7 01 01 01 96 03 00 95 D7 01 01 01'\r\n '96 03 00 E7 D6 01 01 01 96 03 00 AD D6 01 01 01 96 03 00 21 D7 01 01 01 96 03 00 CA 1F 00 02 00'\r\n '97 03 00 00 03 00 89 03 00 02 00 97 03 00 01 03 00 9A 1F 00 04 00 97 03 00 13 03 00 00 03 00 45'\r\n '03 00 2A 1F 00 03 00 97 03 00 13 03 00 00 03 00 9C 1F 00 04 00 97 03 00 13 03 00 01 03 00 45 03'\r\n '00 2C 1F 00 03 00 97 03 00 13 03 00 01 03 00 9E 1F 00 04 00 97 03 00 13 03 00 42 03 00 45 03 00'\r\n '2E 1F 00 03 00 97 03 00 13 03 00 42 03 00 98 1F 00 03 00 97 03 00 13 03 00 45 03 00 28 1F 00 02'\r\n '00 97 03 00 13 03 00 9B 1F 00 04 00 97 03 00 14 03 00 00 03 00 45 03 00 2B 1F 00 03 00 97 03 00'\r\n '14 03 00 00 03 00 9D 1F 00 04 00 97 03 00 14 03 00 01 03 00 45 03 00 2D 1F 00 03 00 97 03 00 14'\r\n '03 00 01 03 00 9F 1F 00 04 00 97 03 00 14 03 00 42 03 00 45 03 00 2F 1F 00 03 00 97 03 00 14 03'\r\n '00 42 03 00 99 1F 00 03 00 97 03 00 14 03 00 45 03 00 29 1F 00 02 00 97 03 00 14 03 00 CC 1F 00'\r\n '02 00 97 03 00 45 03 00 22 D7 01 01 01 97 03 00 5C D7 01 01 01 97 03 00 AE D6 01 01 01 97 03 00'\r\n '96 D7 01 01 01 97 03 00 E8 D6 01 01 01 97 03 00 5D D7 01 01 01 98 03 00 2D D7 01 01 01 98 03 00'\r\n 'F3 D6 01 01 01 98 03 00 B9 D6 01 01 01 98 03 00 E9 D6 01 01 01 98 03 00 A1 D7 01 01 01 98 03 00'\r\n '97 D7 01 01 01 98 03 00 AF D6 01 01 01 98 03 00 23 D7 01 01 01 98 03 00 67 D7 01 01 01 98 03 00'\r\n 'F4 03 00 01 10 98 03 00 DA 1F 00 02 00 99 03 00 00 03 00 8A 03 00 02 00 99 03 00 01 03 00 D9 1F'\r\n '00 02 00 99 03 00 04 03 00 D8 1F 00 02 00 99 03 00 06 03 00 AA 03 00 02 00 99 03 00 08 03 00 3A'\r\n '1F 00 03 00 99 03 00 13 03 00 00 03 00 3C 1F 00 03 00 99 03 00 13 03 00 01 03 00 3E 1F 00 03 00'\r\n '99 03 00 13 03 00 42 03 00 38 1F 00 02 00 99 03 00 13 03 00 3B 1F 00 03 00 99 03 00 14 03 00 00'\r\n '03 00 3D 1F 00 03 00 99 03 00 14 03 00 01 03 00 3F 1F 00 03 00 99 03 00 14 03 00 42 03 00 39 1F'\r\n '00 02 00 99 03 00 14 03 00 24 D7 01 01 01 99 03 00 98 D7 01 01 01 99 03 00 EA D6 01 01 01 99 03'\r\n '00 5E D7 01 01 01 99 03 00 B0 D6 01 01 01 99 03 00 B1 D6 01 01 01 9A 03 00 EB D6 01 01 01 9A 03'\r\n '00 99 D7 01 01 01 9A 03 00 5F D7 01 01 01 9A 03 00 25 D7 01 01 01 9A 03 00 EC D6 01 01 01 9B 03'\r\n '00 60 D7 01 01 01 9B 03 00 9A D7 01 01 01 9B 03 00 26 D7 01 01 01 9B 03 00 B2 D6 01 01 01 9B 03'\r\n '00 9B D7 01 01 01 9C 03 00 61 D7 01 01 01 9C 03 00 B3 D6 01 01 01 9C 03 00 ED D6 01 01 01 9C 03'\r\n '00 27 D7 01 01 01 9C 03 00 28 D7 01 01 01 9D 03 00 EE D6 01 01 01 9D 03 00 62 D7 01 01 01 9D 03'\r\n '00 B4 D6 01 01 01 9D 03 00 9C D7 01 01 01 9D 03 00 63 D7 01 01 01 9E 03 00 9D D7 01 01 01 9E 03'\r\n '00 B5 D6 01 01 01 9E 03 00 EF D6 01 01 01 9E 03 00 29 D7 01 01 01 9E 03 00 F8 1F 00 02 00 9F 03'\r\n '00 00 03 00 8C 03 00 02 00 9F 03 00 01 03 00 4A 1F 00 03 00 9F 03 00 13 03 00 00 03 00 4C 1F 00'\r\n '03 00 9F 03 00 13 03 00 01 03 00 48 1F 00 02 00 9F 03 00 13 03 00 4B 1F 00 03 00 9F 03 00 14 03'\r\n '00 00 03 00 4D 1F 00 03 00 9F 03 00 14 03 00 01 03 00 49 1F 00 02 00 9F 03 00 14 03 00 F0 D6 01'\r\n '01 01 9F 03 00 9E D7 01 01 01 9F 03 00 2A D7 01 01 01 9F 03 00 B6 D6 01 01 01 9F 03 00 64 D7 01'\r\n '01 01 9F 03 00 2B D7 01 01 01 A0 03 00 3F 21 00 01 01 A0 03 00 65 D7 01 01 01 A0 03 00 9F D7 01'\r\n '01 01 A0 03 00 B7 D6 01 01 01 A0 03 00 F1 D6 01 01 01 A0 03 00 EC 1F 00 02 00 A1 03 00 14 03 00'\r\n 'F2 D6 01 01 01 A1 03 00 2C D7 01 01 01 A1 03 00 A0 D7 01 01 01 A1 03 00 66 D7 01 01 01 A1 03 00'\r\n 'B8 D6 01 01 01 A1 03 00 68 D7 01 01 01 A3 03 00 F4 D6 01 01 01 A3 03 00 2E D7 01 01 01 A3 03 00'\r\n 'A2 D7 01 01 01 A3 03 00 BA D6 01 01 01 A3 03 00 F9 03 00 01 10 A3 03 00 A3 D7 01 01 01 A4 03 00'\r\n 'F5 D6 01 01 01 A4 03 00 69 D7 01 01 01 A4 03 00 2F D7 01 01 01 A4 03 00 BB D6 01 01 01 A4 03 00'\r\n 'EA 1F 00 02 00 A5 03 00 00 03 00 8E 03 00 02 00 A5 03 00 01 03 00 D3 03 00 02 00 A5 03 00 01 03'\r\n '00 E9 1F 00 02 00 A5 03 00 04 03 00 E8 1F 00 02 00 A5 03 00 06 03 00 D4 03 00 02 00 A5 03 00 08'\r\n '03 00 AB 03 00 02 00 A5 03 00 08 03 00 5B 1F 00 03 00 A5 03 00 14 03 00 00 03 00 5D 1F 00 03 00'\r\n 'A5 03 00 14 03 00 01 03 00 5F 1F 00 03 00 A5 03 00 14 03 00 42 03 00 59 1F 00 02 00 A5 03 00 14'\r\n '03 00 6A D7 01 01 01 A5 03 00 BC D6 01 01 01 A5 03 00 A4 D7 01 01 01 A5 03 00 F6 D6 01 01 01 A5'\r\n '03 00 30 D7 01 01 01 A5 03 00 D2 03 00 01 10 A5 03 00 6B D7 01 01 01 A6 03 00 A5 D7 01 01 01 A6'\r\n '03 00 31 D7 01 01 01 A6 03 00 F7 D6 01 01 01 A6 03 00 BD D6 01 01 01 A6 03 00 A6 D7 01 01 01 A7'\r\n '03 00 32 D7 01 01 01 A7 03 00 F8 D6 01 01 01 A7 03 00 BE D6 01 01 01 A7 03 00 6C D7 01 01 01 A7'\r\n '03 00 BF D6 01 01 01 A8 03 00 F9 D6 01 01 01 A8 03 00 A7 D7 01 01 01 A8 03 00 33 D7 01 01 01 A8'\r\n '03 00 6D D7 01 01 01 A8 03 00 FA 1F 00 02 00 A9 03 00 00 03 00 8F 03 00 02 00 A9 03 00 01 03 00'\r\n 'AA 1F 00 04 00 A9 03 00 13 03 00 00 03 00 45 03 00 6A 1F 00 03 00 A9 03 00 13 03 00 00 03 00 AC'\r\n '1F 00 04 00 A9 03 00 13 03 00 01 03 00 45 03 00 6C 1F 00 03 00 A9 03 00 13 03 00 01 03 00 AE 1F'\r\n '00 04 00 A9 03 00 13 03 00 42 03 00 45 03 00 6E 1F 00 03 00 A9 03 00 13 03 00 42 03 00 A8 1F 00'\r\n '03 00 A9 03 00 13 03 00 45 03 00 68 1F 00 02 00 A9 03 00 13 03 00 AB 1F 00 04 00 A9 03 00 14 03'\r\n '00 00 03 00 45 03 00 6B 1F 00 03 00 A9 03 00 14 03 00 00 03 00 AD 1F 00 04 00 A9 03 00 14 03 00'\r\n '01 03 00 45 03 00 6D 1F 00 03 00 A9 03 00 14 03 00 01 03 00 AF 1F 00 04 00 A9 03 00 14 03 00 42'\r\n '03 00 45 03 00 6F 1F 00 03 00 A9 03 00 14 03 00 42 03 00 A9 1F 00 03 00 A9 03 00 14 03 00 45 03'\r\n '00 69 1F 00 02 00 A9 03 00 14 03 00 FC 1F 00 02 00 A9 03 00 45 03 00 6E D7 01 01 01 A9 03 00 C0'\r\n 'D6 01 01 01 A9 03 00 FA D6 01 01 01 A9 03 00 A8 D7 01 01 01 A9 03 00 34 D7 01 01 01 A9 03 00 B2'\r\n '1F 00 03 00 B1 03 00 00 03 00 45 03 00 70 1F 00 02 00 B1 03 00 00 03 00 B4 1F 00 03 00 B1 03 00'\r\n '01 03 00 45 03 00 AC 03 00 02 00 B1 03 00 01 03 00 B1 1F 00 02 00 B1 03 00 04 03 00 B0 1F 00 02'\r\n '00 B1 03 00 06 03 00 82 1F 00 04 00 B1 03 00 13 03 00 00 03 00 45 03 00 02 1F 00 03 00 B1 03 00'\r\n '13 03 00 00 03 00 84 1F 00 04 00 B1 03 00 13 03 00 01 03 00 45 03 00 04 1F 00 03 00 B1 03 00 13'\r\n '03 00 01 03 00 86 1F 00 04 00 B1 03 00 13 03 00 42 03 00 45 03 00 06 1F 00 03 00 B1 03 00 13 03'\r\n '00 42 03 00 80 1F 00 03 00 B1 03 00 13 03 00 45 03 00 00 1F 00 02 00 B1 03 00 13 03 00 83 1F 00'\r\n '04 00 B1 03 00 14 03 00 00 03 00 45 03 00 03 1F 00 03 00 B1 03 00 14 03 00 00 03 00 85 1F 00 04'\r\n '00 B1 03 00 14 03 00 01 03 00 45 03 00 05 1F 00 03 00 B1 03 00 14 03 00 01 03 00 87 1F 00 04 00'\r\n 'B1 03 00 14 03 00 42 03 00 45 03 00 07 1F 00 03 00 B1 03 00 14 03 00 42 03 00 81 1F 00 03 00 B1'\r\n '03 00 14 03 00 45 03 00 01 1F 00 02 00 B1 03 00 14 03 00 B7 1F 00 03 00 B1 03 00 42 03 00 45 03'\r\n '00 B6 1F 00 02 00 B1 03 00 42 03 00 B3 1F 00 02 00 B1 03 00 45 03 00 C2 D6 01 01 01 B1 03 00 FC'\r\n 'D6 01 01 01 B1 03 00 AA D7 01 01 01 B1 03 00 70 D7 01 01 01 B1 03 00 36 D7 01 01 01 B1 03 00 D0'\r\n '03 00 01 10 B2 03 00 AB D7 01 01 01 B2 03 00 FD D6 01 01 01 B2 03 00 71 D7 01 01 01 B2 03 00 C3'\r\n 'D6 01 01 01 B2 03 00 37 D7 01 01 01 B2 03 00 66 1D 00 01 09 B2 03 00 5D 1D 00 01 08 B2 03 00 3D'\r\n '21 00 01 01 B3 03 00 38 D7 01 01 01 B3 03 00 72 D7 01 01 01 B3 03 00 5E 1D 00 01 08 B3 03 00 C4'\r\n 'D6 01 01 01 B3 03 00 FE D6 01 01 01 B3 03 00 67 1D 00 01 09 B3 03 00 AC D7 01 01 01 B3 03 00 5F'\r\n '1D 00 01 08 B4 03 00 73 D7 01 01 01 B4 03 00 39 D7 01 01 01 B4 03 00 C5 D6 01 01 01 B4 03 00 AD'\r\n 'D7 01 01 01 B4 03 00 FF D6 01 01 01 B4 03 00 72 1F 00 02 00 B5 03 00 00 03 00 AD 03 00 02 00 B5'\r\n '03 00 01 03 00 12 1F 00 03 00 B5 03 00 13 03 00 00 03 00 14 1F 00 03 00 B5 03 00 13 03 00 01 03'\r\n '00 10 1F 00 02 00 B5 03 00 13 03 00 13 1F 00 03 00 B5 03 00 14 03 00 00 03 00 15 1F 00 03 00 B5'\r\n '03 00 14 03 00 01 03 00 11 1F 00 02 00 B5 03 00 14 03 00 16 D7 01 01 01 B5 03 00 50 D7 01 01 01'\r\n 'B5 03 00 C6 D6 01 01 01 B5 03 00 8A D7 01 01 01 B5 03 00 DC D6 01 01 01 B5 03 00 AE D7 01 01 01'\r\n 'B5 03 00 00 D7 01 01 01 B5 03 00 74 D7 01 01 01 B5 03 00 3A D7 01 01 01 B5 03 00 F5 03 00 01 10'\r\n 'B5 03 00 C4 D7 01 01 01 B5 03 00 AF D7 01 01 01 B6 03 00 C7 D6 01 01 01 B6 03 00 01 D7 01 01 01'\r\n 'B6 03 00 3B D7 01 01 01 B6 03 00 75 D7 01 01 01 B6 03 00 C2 1F 00 03 00 B7 03 00 00 03 00 45 03'\r\n '00 74 1F 00 02 00 B7 03 00 00 03 00 C4 1F 00 03 00 B7 03 00 01 03 00 45 03 00 AE 03 00 02 00 B7'\r\n '03 00 01 03 00 92 1F 00 04 00 B7 03 00 13 03 00 00 03 00 45 03 00 22 1F 00 03 00 B7 03 00 13 03'\r\n '00 00 03 00 94 1F 00 04 00 B7 03 00 13 03 00 01 03 00 45 03 00 24 1F 00 03 00 B7 03 00 13 03 00'\r\n '01 03 00 96 1F 00 04 00 B7 03 00 13 03 00 42 03 00 45 03 00 26 1F 00 03 00 B7 03 00 13 03 00 42'\r\n '03 00 90 1F 00 03 00 B7 03 00 13 03 00 45 03 00 20 1F 00 02 00 B7 03 00 13 03 00 93 1F 00 04 00'\r\n 'B7 03 00 14 03 00 00 03 00 45 03 00 23 1F 00 03 00 B7 03 00 14 03 00 00 03 00 95 1F 00 04 00 B7'\r\n '03 00 14 03 00 01 03 00 45 03 00 25 1F 00 03 00 B7 03 00 14 03 00 01 03 00 97 1F 00 04 00 B7 03'\r\n '00 14 03 00 42 03 00 45 03 00 27 1F 00 03 00 B7 03 00 14 03 00 42 03 00 91 1F 00 03 00 B7 03 00'\r\n '14 03 00 45 03 00 21 1F 00 02 00 B7 03 00 14 03 00 C7 1F 00 03 00 B7 03 00 42 03 00 45 03 00 C6'\r\n '1F 00 02 00 B7 03 00 42 03 00 C3 1F 00 02 00 B7 03 00 45 03 00 76 D7 01 01 01 B7 03 00 3C D7 01'\r\n '01 01 B7 03 00 C8 D6 01 01 01 B7 03 00 02 D7 01 01 01 B7 03 00 B0 D7 01 01 01 B7 03 00 51 D7 01'\r\n '01 01 B8 03 00 C5 D7 01 01 01 B8 03 00 03 D7 01 01 01 B8 03 00 D1 03 00 01 10 B8 03 00 3D D7 01'\r\n '01 01 B8 03 00 17 D7 01 01 01 B8 03 00 DD D6 01 01 01 B8 03 00 BF 1D 00 01 08 B8 03 00 B1 D7 01'\r\n '01 01 B8 03 00 C9 D6 01 01 01 B8 03 00 8B D7 01 01 01 B8 03 00 77 D7 01 01 01 B8 03 00 76 1F 00'\r\n '02 00 B9 03 00 00 03 00 AF 03 00 02 00 B9 03 00 01 03 00 D1 1F 00 02 00 B9 03 00 04 03 00 D0 1F'\r\n '00 02 00 B9 03 00 06 03 00 D2 1F 00 03 00 B9 03 00 08 03 00 00 03 00 90 03 00 03 00 B9 03 00 08'\r\n '03 00 01 03 00 D7 1F 00 03 00 B9 03 00 08 03 00 42 03 00 CA 03 00 02 00 B9 03 00 08 03 00 32 1F'\r\n '00 03 00 B9 03 00 13 03 00 00 03 00 34 1F 00 03 00 B9 03 00 13 03 00 01 03 00 36 1F 00 03 00 B9'\r\n '03 00 13 03 00 42 03 00 30 1F 00 02 00 B9 03 00 13 03 00 33 1F 00 03 00 B9 03 00 14 03 00 00 03'\r\n '00 35 1F 00 03 00 B9 03 00 14 03 00 01 03 00 37 1F 00 03 00 B9 03 00 14 03 00 42 03 00 31 1F 00'\r\n '02 00 B9 03 00 14 03 00 D6 1F 00 02 00 B9 03 00 42 03 00 04 D7 01 01 01 B9 03 00 B2 D7 01 01 01'\r\n 'B9 03 00 3E D7 01 01 01 B9 03 00 CA D6 01 01 01 B9 03 00 78 D7 01 01 01 B9 03 00 C6 D7 01 01 01'\r\n 'BA 03 00 79 D7 01 01 01 BA 03 00 8C D7 01 01 01 BA 03 00 CB D6 01 01 01 BA 03 00 18 D7 01 01 01'\r\n 'BA 03 00 DE D6 01 01 01 BA 03 00 05 D7 01 01 01 BA 03 00 3F D7 01 01 01 BA 03 00 52 D7 01 01 01'\r\n 'BA 03 00 B3 D7 01 01 01 BA 03 00 F0 03 00 01 10 BA 03 00 06 D7 01 01 01 BB 03 00 B4 D7 01 01 01'\r\n 'BB 03 00 40 D7 01 01 01 BB 03 00 CC D6 01 01 01 BB 03 00 7A D7 01 01 01 BB 03 00 82 33 00 02 0E'\r\n 'BC 03 00 41 00 00 8C 33 00 02 0E BC 03 00 46 00 00 B6 33 00 02 0E BC 03 00 56 00 00 BC 33 00 02'\r\n '0E BC 03 00 57 00 00 8D 33 00 02 0E BC 03 00 67 00 00 95 33 00 02 0E BC 03 00 6C 00 00 9B 33 00'\r\n '02 0E BC 03 00 6D 00 00 B2 33 00 02 0E BC 03 00 73 00 00 CD D6 01 01 01 BC 03 00 41 D7 01 01 01'\r\n 'BC 03 00 B5 D7 01 01 01 BC 03 00 7B D7 01 01 01 BC 03 00 B5 00 00 01 10 BC 03 00 07 D7 01 01 01'\r\n 'BC 03 00 7C D7 01 01 01 BD 03 00 08 D7 01 01 01 BD 03 00 42 D7 01 01 01 BD 03 00 CE D6 01 01 01'\r\n 'BD 03 00 B6 D7 01 01 01 BD 03 00 B7 D7 01 01 01 BE 03 00 CF D6 01 01 01 BE 03 00 09 D7 01 01 01'\r\n 'BE 03 00 43 D7 01 01 01 BE 03 00 7D D7 01 01 01 BE 03 00 78 1F 00 02 00 BF 03 00 00 03 00 CC 03'\r\n '00 02 00 BF 03 00 01 03 00 42 1F 00 03 00 BF 03 00 13 03 00 00 03 00 44 1F 00 03 00 BF 03 00 13'\r\n '03 00 01 03 00 40 1F 00 02 00 BF 03 00 13 03 00 43 1F 00 03 00 BF 03 00 14 03 00 00 03 00 45 1F'\r\n '00 03 00 BF 03 00 14 03 00 01 03 00 41 1F 00 02 00 BF 03 00 14 03 00 44 D7 01 01 01 BF 03 00 7E'\r\n 'D7 01 01 01 BF 03 00 B8 D7 01 01 01 BF 03 00 D0 D6 01 01 01 BF 03 00 0A D7 01 01 01 BF 03 00 3C'\r\n '21 00 01 01 C0 03 00 7F D7 01 01 01 C0 03 00 D1 D6 01 01 01 C0 03 00 D6 03 00 01 10 C0 03 00 C9'\r\n 'D7 01 01 01 C0 03 00 45 D7 01 01 01 C0 03 00 8F D7 01 01 01 C0 03 00 E1 D6 01 01 01 C0 03 00 B9'\r\n 'D7 01 01 01 C0 03 00 1B D7 01 01 01 C0 03 00 0B D7 01 01 01 C0 03 00 55 D7 01 01 01 C0 03 00 E4'\r\n '1F 00 02 00 C1 03 00 13 03 00 E5 1F 00 02 00 C1 03 00 14 03 00 F1 03 00 01 10 C1 03 00 E0 D6 01'\r\n '01 01 C1 03 00 0C D7 01 01 01 C1 03 00 D2 D6 01 01 01 C1 03 00 1A D7 01 01 01 C1 03 00 68 1D 00'\r\n '01 09 C1 03 00 46 D7 01 01 01 C1 03 00 BA D7 01 01 01 C1 03 00 C8 D7 01 01 01 C1 03 00 80 D7 01'\r\n '01 01 C1 03 00 8E D7 01 01 01 C1 03 00 54 D7 01 01 01 C1 03 00 47 D7 01 01 01 C2 03 00 F2 03 00'\r\n '01 10 C2 03 00 BB D7 01 01 01 C2 03 00 D3 D6 01 01 01 C2 03 00 81 D7 01 01 01 C2 03 00 0D D7 01'\r\n '01 01 C2 03 00 82 D7 01 01 01 C3 03 00 0E D7 01 01 01 C3 03 00 48 D7 01 01 01 C3 03 00 D4 D6 01'\r\n '01 01 C3 03 00 BC D7 01 01 01 C3 03 00 D5 D6 01 01 01 C4 03 00 49 D7 01 01 01 C4 03 00 BD D7 01'\r\n '01 01 C4 03 00 0F D7 01 01 01 C4 03 00 83 D7 01 01 01 C4 03 00 7A 1F 00 02 00 C5 03 00 00 03 00'\r\n 'CD 03 00 02 00 C5 03 00 01 03 00 E1 1F 00 02 00 C5 03 00 04 03 00 E0 1F 00 02 00 C5 03 00 06 03'\r\n '00 E2 1F 00 03 00 C5 03 00 08 03 00 00 03 00 B0 03 00 03 00 C5 03 00 08 03 00 01 03 00 E7 1F 00'\r\n '03 00 C5 03 00 08 03 00 42 03 00 CB 03 00 02 00 C5 03 00 08 03 00 52 1F 00 03 00 C5 03 00 13 03'\r\n '00 00 03 00 54 1F 00 03 00 C5 03 00 13 03 00 01 03 00 56 1F 00 03 00 C5 03 00 13 03 00 42 03 00'\r\n '50 1F 00 02 00 C5 03 00 13 03 00 53 1F 00 03 00 C5 03 00 14 03 00 00 03 00 55 1F 00 03 00 C5 03'\r\n '00 14 03 00 01 03 00 57 1F 00 03 00 C5 03 00 14 03 00 42 03 00 51 1F 00 02 00 C5 03 00 14 03 00'\r\n 'E6 1F 00 02 00 C5 03 00 42 03 00 10 D7 01 01 01 C5 03 00 4A D7 01 01 01 C5 03 00 D6 D6 01 01 01'\r\n 'C5 03 00 BE D7 01 01 01 C5 03 00 84 D7 01 01 01 C5 03 00 DF D6 01 01 01 C6 03 00 53 D7 01 01 01'\r\n 'C6 03 00 D7 D6 01 01 01 C6 03 00 4B D7 01 01 01 C6 03 00 C7 D7 01 01 01 C6 03 00 8D D7 01 01 01'\r\n 'C6 03 00 11 D7 01 01 01 C6 03 00 D5 03 00 01 10 C6 03 00 85 D7 01 01 01 C6 03 00 19 D7 01 01 01'\r\n 'C6 03 00 60 1D 00 01 08 C6 03 00 69 1D 00 01 09 C6 03 00 BF D7 01 01 01 C6 03 00 12 D7 01 01 01'\r\n 'C7 03 00 6A 1D 00 01 09 C7 03 00 C0 D7 01 01 01 C7 03 00 61 1D 00 01 08 C7 03 00 86 D7 01 01 01'\r\n 'C7 03 00 D8 D6 01 01 01 C7 03 00 4C D7 01 01 01 C7 03 00 D9 D6 01 01 01 C8 03 00 87 D7 01 01 01'\r\n 'C8 03 00 13 D7 01 01 01 C8 03 00 C1 D7 01 01 01 C8 03 00 4D D7 01 01 01 C8 03 00 F2 1F 00 03 00'\r\n 'C9 03 00 00 03 00 45 03 00 7C 1F 00 02 00 C9 03 00 00 03 00 F4 1F 00 03 00 C9 03 00 01 03 00 45'\r\n '03 00 CE 03 00 02 00 C9 03 00 01 03 00 A2 1F 00 04 00 C9 03 00 13 03 00 00 03 00 45 03 00 62 1F'\r\n '00 03 00 C9 03 00 13 03 00 00 03 00 A4 1F 00 04 00 C9 03 00 13 03 00 01 03 00 45 03 00 64 1F 00'\r\n '03 00 C9 03 00 13 03 00 01 03 00 A6 1F 00 04 00 C9 03 00 13 03 00 42 03 00 45 03 00 66 1F 00 03'\r\n '00 C9 03 00 13 03 00 42 03 00 A0 1F 00 03 00 C9 03 00 13 03 00 45 03 00 60 1F 00 02 00 C9 03 00'\r\n '13 03 00 A3 1F 00 04 00 C9 03 00 14 03 00 00 03 00 45 03 00 63 1F 00 03 00 C9 03 00 14 03 00 00'\r\n '03 00 A5 1F 00 04 00 C9 03 00 14 03 00 01 03 00 45 03 00 65 1F 00 03 00 C9 03 00 14 03 00 01 03'\r\n '00 A7 1F 00 04 00 C9 03 00 14 03 00 42 03 00 45 03 00 67 1F 00 03 00 C9 03 00 14 03 00 42 03 00'\r\n 'A1 1F 00 03 00 C9 03 00 14 03 00 45 03 00 61 1F 00 02 00 C9 03 00 14 03 00 F7 1F 00 03 00 C9 03'\r\n '00 42 03 00 45 03 00 F6 1F 00 02 00 C9 03 00 42 03 00 F3 1F 00 02 00 C9 03 00 45 03 00 14 D7 01'\r\n '01 01 C9 03 00 DA D6 01 01 01 C9 03 00 4E D7 01 01 01 C9 03 00 88 D7 01 01 01 C9 03 00 C2 D7 01'\r\n '01 01 C9 03 00 CA D7 01 01 01 DC 03 00 CB D7 01 01 01 DD 03 00 07 04 00 02 00 06 04 00 08 03 00'\r\n 'D0 04 00 02 00 10 04 00 06 03 00 D2 04 00 02 00 10 04 00 08 03 00 03 04 00 02 00 13 04 00 01 03'\r\n '00 00 04 00 02 00 15 04 00 00 03 00 D6 04 00 02 00 15 04 00 06 03 00 01 04 00 02 00 15 04 00 08'\r\n '03 00 C1 04 00 02 00 16 04 00 06 03 00 DC 04 00 02 00 16 04 00 08 03 00 DE 04 00 02 00 17 04 00'\r\n '08 03 00 0D 04 00 02 00 18 04 00 00 03 00 E2 04 00 02 00 18 04 00 04 03 00 19 04 00 02 00 18 04'\r\n '00 06 03 00 E4 04 00 02 00 18 04 00 08 03 00 0C 04 00 02 00 1A 04 00 01 03 00 E6 04 00 02 00 1E'\r\n '04 00 08 03 00 EE 04 00 02 00 23 04 00 04 03 00 0E 04 00 02 00 23 04 00 06 03 00 F0 04 00 02 00'\r\n '23 04 00 08 03 00 F2 04 00 02 00 23 04 00 0B 03 00 F4 04 00 02 00 27 04 00 08 03 00 F8 04 00 02'\r\n '00 2B 04 00 08 03 00 EC 04 00 02 00 2D 04 00 08 03 00 D1 04 00 02 00 30 04 00 06 03 00 D3 04 00'\r\n '02 00 30 04 00 08 03 00 53 04 00 02 00 33 04 00 01 03 00 50 04 00 02 00 35 04 00 00 03 00 D7 04'\r\n '00 02 00 35 04 00 06 03 00 51 04 00 02 00 35 04 00 08 03 00 C2 04 00 02 00 36 04 00 06 03 00 DD'\r\n '04 00 02 00 36 04 00 08 03 00 DF 04 00 02 00 37 04 00 08 03 00 5D 04 00 02 00 38 04 00 00 03 00'\r\n 'E3 04 00 02 00 38 04 00 04 03 00 39 04 00 02 00 38 04 00 06 03 00 E5 04 00 02 00 38 04 00 08 03'\r\n '00 5C 04 00 02 00 3A 04 00 01 03 00 78 1D 00 01 08 3D 04 00 E7 04 00 02 00 3E 04 00 08 03 00 EF'\r\n '04 00 02 00 43 04 00 04 03 00 5E 04 00 02 00 43 04 00 06 03 00 F1 04 00 02 00 43 04 00 08 03 00'\r\n 'F3 04 00 02 00 43 04 00 0B 03 00 F5 04 00 02 00 47 04 00 08 03 00 F9 04 00 02 00 4B 04 00 08 03'\r\n '00 ED 04 00 02 00 4D 04 00 08 03 00 57 04 00 02 00 56 04 00 08 03 00 76 04 00 02 00 74 04 00 0F'\r\n '03 00 77 04 00 02 00 75 04 00 0F 03 00 DA 04 00 02 00 D8 04 00 08 03 00 DB 04 00 02 00 D9 04 00'\r\n '08 03 00 EA 04 00 02 00 E8 04 00 08 03 00 EB 04 00 02 00 E9 04 00 08 03 00 87 05 00 02 10 65 05'\r\n '00 82 05 00 14 FB 00 02 10 74 05 00 65 05 00 15 FB 00 02 10 74 05 00 6B 05 00 17 FB 00 02 10 74'\r\n '05 00 6D 05 00 13 FB 00 02 10 74 05 00 76 05 00 16 FB 00 02 10 7E 05 00 76 05 00 4F FB 00 02 10'\r\n 'D0 05 00 DC 05 00 35 21 00 01 10 D0 05 00 21 FB 00 01 01 D0 05 00 36 21 00 01 10 D1 05 00 37 21'\r\n '00 01 10 D2 05 00 22 FB 00 01 01 D3 05 00 38 21 00 01 10 D3 05 00 23 FB 00 01 01 D4 05 00 24 FB'\r\n '00 01 01 DB 05 00 25 FB 00 01 01 DC 05 00 26 FB 00 01 01 DD 05 00 20 FB 00 01 01 E2 05 00 27 FB'\r\n '00 01 01 E8 05 00 28 FB 00 01 01 EA 05 00 80 FE 00 01 06 21 06 00 F3 FD 00 04 06 27 06 00 43 06'\r\n '00 28 06 00 31 06 00 F2 FD 00 04 06 27 06 00 44 06 00 44 06 00 47 06 00 3D FD 00 02 06 27 06 00'\r\n '4B 06 00 3C FD 00 02 05 27 06 00 4B 06 00 81 FE 00 02 06 27 06 00 53 06 00 22 06 00 02 00 27 06'\r\n '00 53 06 00 82 FE 00 02 05 27 06 00 53 06 00 83 FE 00 02 06 27 06 00 54 06 00 84 FE 00 02 05 27'\r\n '06 00 54 06 00 23 06 00 02 00 27 06 00 54 06 00 88 FE 00 02 05 27 06 00 55 06 00 87 FE 00 02 06'\r\n '27 06 00 55 06 00 25 06 00 02 00 27 06 00 55 06 00 75 06 00 02 10 27 06 00 74 06 00 8E FE 00 01'\r\n '05 27 06 00 8D FE 00 01 06 27 06 00 9C FC 00 02 03 28 06 00 2C 06 00 05 FC 00 02 06 28 06 00 2C'\r\n '06 00 C2 FD 00 03 05 28 06 00 2D 06 00 4A 06 00 06 FC 00 02 06 28 06 00 2D 06 00 9D FC 00 02 03'\r\n '28 06 00 2D 06 00 9E FD 00 03 05 28 06 00 2E 06 00 4A 06 00 07 FC 00 02 06 28 06 00 2E 06 00 9E'\r\n 'FC 00 02 03 28 06 00 2E 06 00 6A FC 00 02 05 28 06 00 31 06 00 6B FC 00 02 05 28 06 00 32 06 00'\r\n '08 FC 00 02 06 28 06 00 45 06 00 9F FC 00 02 03 28 06 00 45 06 00 6C FC 00 02 05 28 06 00 45 06'\r\n '00 E1 FC 00 02 04 28 06 00 45 06 00 6D FC 00 02 05 28 06 00 46 06 00 A0 FC 00 02 03 28 06 00 47'\r\n '06 00 E2 FC 00 02 04 28 06 00 47 06 00 6E FC 00 02 05 28 06 00 49 06 00 09 FC 00 02 06 28 06 00'\r\n '49 06 00 6F FC 00 02 05 28 06 00 4A 06 00 0A FC 00 02 06 28 06 00 4A 06 00 92 FE 00 01 04 28 06'\r\n '00 8F FE 00 01 06 28 06 00 90 FE 00 01 05 28 06 00 91 FE 00 01 03 28 06 00 93 FE 00 01 06 29 06'\r\n '00 94 FE 00 01 05 29 06 00 50 FD 00 03 03 2A 06 00 2C 06 00 45 06 00 A0 FD 00 03 05 2A 06 00 2C'\r\n '06 00 49 06 00 9F FD 00 03 05 2A 06 00 2C 06 00 4A 06 00 A1 FC 00 02 03 2A 06 00 2C 06 00 0B FC'\r\n '00 02 06 2A 06 00 2C 06 00 52 FD 00 03 03 2A 06 00 2D 06 00 2C 06 00 51 FD 00 03 05 2A 06 00 2D'\r\n '06 00 2C 06 00 53 FD 00 03 03 2A 06 00 2D 06 00 45 06 00 0C FC 00 02 06 2A 06 00 2D 06 00 A2 FC'\r\n '00 02 03 2A 06 00 2D 06 00 54 FD 00 03 03 2A 06 00 2E 06 00 45 06 00 A2 FD 00 03 05 2A 06 00 2E'\r\n '06 00 49 06 00 A1 FD 00 03 05 2A 06 00 2E 06 00 4A 06 00 0D FC 00 02 06 2A 06 00 2E 06 00 A3 FC'\r\n '00 02 03 2A 06 00 2E 06 00 70 FC 00 02 05 2A 06 00 31 06 00 71 FC 00 02 05 2A 06 00 32 06 00 55'\r\n 'FD 00 03 03 2A 06 00 45 06 00 2C 06 00 56 FD 00 03 03 2A 06 00 45 06 00 2D 06 00 57 FD 00 03 03'\r\n '2A 06 00 45 06 00 2E 06 00 A4 FD 00 03 05 2A 06 00 45 06 00 49 06 00 A3 FD 00 03 05 2A 06 00 45'\r\n '06 00 4A 06 00 A4 FC 00 02 03 2A 06 00 45 06 00 0E FC 00 02 06 2A 06 00 45 06 00 72 FC 00 02 05'\r\n '2A 06 00 45 06 00 E3 FC 00 02 04 2A 06 00 45 06 00 73 FC 00 02 05 2A 06 00 46 06 00 E4 FC 00 02'\r\n '04 2A 06 00 47 06 00 A5 FC 00 02 03 2A 06 00 47 06 00 0F FC 00 02 06 2A 06 00 49 06 00 74 FC 00'\r\n '02 05 2A 06 00 49 06 00 10 FC 00 02 06 2A 06 00 4A 06 00 75 FC 00 02 05 2A 06 00 4A 06 00 97 FE'\r\n '00 01 03 2A 06 00 98 FE 00 01 04 2A 06 00 96 FE 00 01 05 2A 06 00 95 FE 00 01 06 2A 06 00 11 FC'\r\n '00 02 06 2B 06 00 2C 06 00 76 FC 00 02 05 2B 06 00 31 06 00 77 FC 00 02 05 2B 06 00 32 06 00 12'\r\n 'FC 00 02 06 2B 06 00 45 06 00 E5 FC 00 02 04 2B 06 00 45 06 00 78 FC 00 02 05 2B 06 00 45 06 00'\r\n 'A6 FC 00 02 03 2B 06 00 45 06 00 79 FC 00 02 05 2B 06 00 46 06 00 E6 FC 00 02 04 2B 06 00 47 06'\r\n '00 13 FC 00 02 06 2B 06 00 49 06 00 7A FC 00 02 05 2B 06 00 49 06 00 7B FC 00 02 05 2B 06 00 4A'\r\n '06 00 14 FC 00 02 06 2B 06 00 4A 06 00 9B FE 00 01 03 2B 06 00 9A FE 00 01 05 2B 06 00 99 FE 00'\r\n '01 06 2B 06 00 9C FE 00 01 04 2B 06 00 A6 FD 00 03 05 2C 06 00 2D 06 00 49 06 00 BE FD 00 03 05'\r\n '2C 06 00 2D 06 00 4A 06 00 A7 FC 00 02 03 2C 06 00 2D 06 00 15 FC 00 02 06 2C 06 00 2D 06 00 FB'\r\n 'FD 00 08 06 2C 06 00 44 06 00 20 00 00 2C 06 00 44 06 00 27 06 00 44 06 00 47 06 00 59 FD 00 03'\r\n '03 2C 06 00 45 06 00 2D 06 00 58 FD 00 03 05 2C 06 00 45 06 00 2D 06 00 A7 FD 00 03 05 2C 06 00'\r\n '45 06 00 49 06 00 A5 FD 00 03 05 2C 06 00 45 06 00 4A 06 00 A8 FC 00 02 03 2C 06 00 45 06 00 16'\r\n 'FC 00 02 06 2C 06 00 45 06 00 1D FD 00 02 05 2C 06 00 49 06 00 01 FD 00 02 06 2C 06 00 49 06 00'\r\n '02 FD 00 02 06 2C 06 00 4A 06 00 1E FD 00 02 05 2C 06 00 4A 06 00 9F FE 00 01 03 2C 06 00 A0 FE'\r\n '00 01 04 2C 06 00 9D FE 00 01 06 2C 06 00 9E FE 00 01 05 2C 06 00 BF FD 00 03 05 2D 06 00 2C 06'\r\n '00 4A 06 00 17 FC 00 02 06 2D 06 00 2C 06 00 A9 FC 00 02 03 2D 06 00 2C 06 00 5B FD 00 03 05 2D'\r\n '06 00 45 06 00 49 06 00 5A FD 00 03 05 2D 06 00 45 06 00 4A 06 00 18 FC 00 02 06 2D 06 00 45 06'\r\n '00 AA FC 00 02 03 2D 06 00 45 06 00 1B FD 00 02 05 2D 06 00 49 06 00 FF FC 00 02 06 2D 06 00 49'\r\n '06 00 1C FD 00 02 05 2D 06 00 4A 06 00 00 FD 00 02 06 2D 06 00 4A 06 00 A1 FE 00 01 06 2D 06 00'\r\n 'A3 FE 00 01 03 2D 06 00 A4 FE 00 01 04 2D 06 00 A2 FE 00 01 05 2D 06 00 AB FC 00 02 03 2E 06 00'\r\n '2C 06 00 19 FC 00 02 06 2E 06 00 2C 06 00 1A FC 00 02 06 2E 06 00 2D 06 00 AC FC 00 02 03 2E 06'\r\n '00 45 06 00 1B FC 00 02 06 2E 06 00 45 06 00 03 FD 00 02 06 2E 06 00 49 06 00 1F FD 00 02 05 2E'\r\n '06 00 49 06 00 20 FD 00 02 05 2E 06 00 4A 06 00 04 FD 00 02 06 2E 06 00 4A 06 00 A8 FE 00 01 04'\r\n '2E 06 00 A7 FE 00 01 03 2E 06 00 A5 FE 00 01 06 2E 06 00 A6 FE 00 01 05 2E 06 00 AA FE 00 01 05'\r\n '2F 06 00 A9 FE 00 01 06 2F 06 00 5B FC 00 02 06 30 06 00 70 06 00 AC FE 00 01 05 30 06 00 AB FE'\r\n '00 01 06 30 06 00 F6 FD 00 04 06 31 06 00 33 06 00 48 06 00 44 06 00 5C FC 00 02 06 31 06 00 70'\r\n '06 00 FC FD 00 04 06 31 06 00 CC 06 00 27 06 00 44 06 00 AD FE 00 01 06 31 06 00 AE FE 00 01 05'\r\n '31 06 00 AF FE 00 01 06 32 06 00 B0 FE 00 01 05 32 06 00 5D FD 00 03 03 33 06 00 2C 06 00 2D 06'\r\n '00 5E FD 00 03 05 33 06 00 2C 06 00 49 06 00 AD FC 00 02 03 33 06 00 2C 06 00 1C FC 00 02 06 33'\r\n '06 00 2C 06 00 34 FD 00 02 04 33 06 00 2C 06 00 5C FD 00 03 03 33 06 00 2D 06 00 2C 06 00 AE FC'\r\n '00 02 03 33 06 00 2D 06 00 35 FD 00 02 04 33 06 00 2D 06 00 1D FC 00 02 06 33 06 00 2D 06 00 A8'\r\n 'FD 00 03 05 33 06 00 2E 06 00 49 06 00 C6 FD 00 03 05 33 06 00 2E 06 00 4A 06 00 AF FC 00 02 03'\r\n '33 06 00 2E 06 00 1E FC 00 02 06 33 06 00 2E 06 00 36 FD 00 02 04 33 06 00 2E 06 00 2A FD 00 02'\r\n '05 33 06 00 31 06 00 0E FD 00 02 06 33 06 00 31 06 00 61 FD 00 03 03 33 06 00 45 06 00 2C 06 00'\r\n '5F FD 00 03 05 33 06 00 45 06 00 2D 06 00 60 FD 00 03 03 33 06 00 45 06 00 2D 06 00 62 FD 00 03'\r\n '05 33 06 00 45 06 00 45 06 00 63 FD 00 03 03 33 06 00 45 06 00 45 06 00 1F FC 00 02 06 33 06 00'\r\n '45 06 00 B0 FC 00 02 03 33 06 00 45 06 00 E7 FC 00 02 04 33 06 00 45 06 00 E8 FC 00 02 04 33 06'\r\n '00 47 06 00 31 FD 00 02 03 33 06 00 47 06 00 FB FC 00 02 06 33 06 00 49 06 00 17 FD 00 02 05 33'\r\n '06 00 49 06 00 18 FD 00 02 05 33 06 00 4A 06 00 FC FC 00 02 06 33 06 00 4A 06 00 B4 FE 00 01 04'\r\n '33 06 00 B3 FE 00 01 03 33 06 00 B1 FE 00 01 06 33 06 00 B2 FE 00 01 05 33 06 00 69 FD 00 03 05'\r\n '34 06 00 2C 06 00 4A 06 00 37 FD 00 02 04 34 06 00 2C 06 00 2D FD 00 02 03 34 06 00 2C 06 00 09'\r\n 'FD 00 02 06 34 06 00 2C 06 00 25 FD 00 02 05 34 06 00 2C 06 00 67 FD 00 03 05 34 06 00 2D 06 00'\r\n '45 06 00 68 FD 00 03 03 34 06 00 2D 06 00 45 06 00 AA FD 00 03 05 34 06 00 2D 06 00 4A 06 00 38'\r\n 'FD 00 02 04 34 06 00 2D 06 00 0A FD 00 02 06 34 06 00 2D 06 00 26 FD 00 02 05 34 06 00 2D 06 00'\r\n '2E FD 00 02 03 34 06 00 2D 06 00 27 FD 00 02 05 34 06 00 2E 06 00 0B FD 00 02 06 34 06 00 2E 06'\r\n '00 39 FD 00 02 04 34 06 00 2E 06 00 2F FD 00 02 03 34 06 00 2E 06 00 0D FD 00 02 06 34 06 00 31'\r\n '06 00 29 FD 00 02 05 34 06 00 31 06 00 6A FD 00 03 05 34 06 00 45 06 00 2E 06 00 6B FD 00 03 03'\r\n '34 06 00 45 06 00 2E 06 00 6C FD 00 03 05 34 06 00 45 06 00 45 06 00 6D FD 00 03 03 34 06 00 45'\r\n '06 00 45 06 00 E9 FC 00 02 04 34 06 00 45 06 00 28 FD 00 02 05 34 06 00 45 06 00 0C FD 00 02 06'\r\n '34 06 00 45 06 00 30 FD 00 02 03 34 06 00 45 06 00 32 FD 00 02 03 34 06 00 47 06 00 EA FC 00 02'\r\n '04 34 06 00 47 06 00 FD FC 00 02 06 34 06 00 49 06 00 19 FD 00 02 05 34 06 00 49 06 00 FE FC 00'\r\n '02 06 34 06 00 4A 06 00 1A FD 00 02 05 34 06 00 4A 06 00 B8 FE 00 01 04 34 06 00 B5 FE 00 01 06'\r\n '34 06 00 B6 FE 00 01 05 34 06 00 B7 FE 00 01 03 34 06 00 65 FD 00 03 03 35 06 00 2D 06 00 2D 06'\r\n '00 64 FD 00 03 05 35 06 00 2D 06 00 2D 06 00 A9 FD 00 03 05 35 06 00 2D 06 00 4A 06 00 B1 FC 00'\r\n '02 03 35 06 00 2D 06 00 20 FC 00 02 06 35 06 00 2D 06 00 B2 FC 00 02 03 35 06 00 2E 06 00 0F FD'\r\n '00 02 06 35 06 00 31 06 00 2B FD 00 02 05 35 06 00 31 06 00 F5 FD 00 04 06 35 06 00 44 06 00 39'\r\n '06 00 45 06 00 FA FD 00 12 06 35 06 00 44 06 00 49 06 00 20 00 00 27 06 00 44 06 00 44 06 00 47'\r\n '06 00 20 00 00 39 06 00 44 06 00 4A 06 00 47 06 00 20 00 00 48 06 00 33 06 00 44 06 00 45 06 00'\r\n 'F9 FD 00 03 06 35 06 00 44 06 00 49 06 00 F0 FD 00 03 06 35 06 00 44 06 00 D2 06 00 66 FD 00 03'\r\n '05 35 06 00 45 06 00 45 06 00 C5 FD 00 03 03 35 06 00 45 06 00 45 06 00 B3 FC 00 02 03 35 06 00'\r\n '45 06 00 21 FC 00 02 06 35 06 00 45 06 00 05 FD 00 02 06 35 06 00 49 06 00 21 FD 00 02 05 35 06'\r\n '00 49 06 00 06 FD 00 02 06 35 06 00 4A 06 00 22 FD 00 02 05 35 06 00 4A 06 00 BC FE 00 01 04 35'\r\n '06 00 B9 FE 00 01 06 35 06 00 BA FE 00 01 05 35 06 00 BB FE 00 01 03 35 06 00 22 FC 00 02 06 36'\r\n '06 00 2C 06 00 B4 FC 00 02 03 36 06 00 2C 06 00 6E FD 00 03 05 36 06 00 2D 06 00 49 06 00 AB FD'\r\n '00 03 05 36 06 00 2D 06 00 4A 06 00 23 FC 00 02 06 36 06 00 2D 06 00 B5 FC 00 02 03 36 06 00 2D'\r\n '06 00 6F FD 00 03 05 36 06 00 2E 06 00 45 06 00 70 FD 00 03 03 36 06 00 2E 06 00 45 06 00 24 FC'\r\n '00 02 06 36 06 00 2E 06 00 B6 FC 00 02 03 36 06 00 2E 06 00 2C FD 00 02 05 36 06 00 31 06 00 10'\r\n 'FD 00 02 06 36 06 00 31 06 00 25 FC 00 02 06 36 06 00 45 06 00 B7 FC 00 02 03 36 06 00 45 06 00'\r\n '07 FD 00 02 06 36 06 00 49 06 00 23 FD 00 02 05 36 06 00 49 06 00 24 FD 00 02 05 36 06 00 4A 06'\r\n '00 08 FD 00 02 06 36 06 00 4A 06 00 C0 FE 00 01 04 36 06 00 BD FE 00 01 06 36 06 00 BE FE 00 01'\r\n '05 36 06 00 BF FE 00 01 03 36 06 00 26 FC 00 02 06 37 06 00 2D 06 00 B8 FC 00 02 03 37 06 00 2D'\r\n '06 00 72 FD 00 03 03 37 06 00 45 06 00 2D 06 00 71 FD 00 03 05 37 06 00 45 06 00 2D 06 00 73 FD'\r\n '00 03 03 37 06 00 45 06 00 45 06 00 74 FD 00 03 05 37 06 00 45 06 00 4A 06 00 27 FC 00 02 06 37'\r\n '06 00 45 06 00 33 FD 00 02 03 37 06 00 45 06 00 3A FD 00 02 04 37 06 00 45 06 00 11 FD 00 02 05'\r\n '37 06 00 49 06 00 F5 FC 00 02 06 37 06 00 49 06 00 12 FD 00 02 05 37 06 00 4A 06 00 F6 FC 00 02'\r\n '06 37 06 00 4A 06 00 C3 FE 00 01 03 37 06 00 C4 FE 00 01 04 37 06 00 C1 FE 00 01 06 37 06 00 C2'\r\n 'FE 00 01 05 37 06 00 B9 FC 00 02 03 38 06 00 45 06 00 28 FC 00 02 06 38 06 00 45 06 00 3B FD 00'\r\n '02 04 38 06 00 45 06 00 C5 FE 00 01 06 38 06 00 C6 FE 00 01 05 38 06 00 C7 FE 00 01 03 38 06 00'\r\n 'C8 FE 00 01 04 38 06 00 C4 FD 00 03 03 39 06 00 2C 06 00 45 06 00 75 FD 00 03 05 39 06 00 2C 06'\r\n '00 45 06 00 BA FC 00 02 03 39 06 00 2C 06 00 29 FC 00 02 06 39 06 00 2C 06 00 F7 FD 00 04 06 39'\r\n '06 00 44 06 00 4A 06 00 47 06 00 77 FD 00 03 03 39 06 00 45 06 00 45 06 00 76 FD 00 03 05 39 06'\r\n '00 45 06 00 45 06 00 78 FD 00 03 05 39 06 00 45 06 00 49 06 00 B6 FD 00 03 05 39 06 00 45 06 00'\r\n '4A 06 00 2A FC 00 02 06 39 06 00 45 06 00 BB FC 00 02 03 39 06 00 45 06 00 F7 FC 00 02 06 39 06'\r\n '00 49 06 00 13 FD 00 02 05 39 06 00 49 06 00 14 FD 00 02 05 39 06 00 4A 06 00 F8 FC 00 02 06 39'\r\n '06 00 4A 06 00 CB FE 00 01 03 39 06 00 CC FE 00 01 04 39 06 00 C9 FE 00 01 06 39 06 00 CA FE 00'\r\n '01 05 39 06 00 BC FC 00 02 03 3A 06 00 2C 06 00 2B FC 00 02 06 3A 06 00 2C 06 00 79 FD 00 03 05'\r\n '3A 06 00 45 06 00 45 06 00 7B FD 00 03 05 3A 06 00 45 06 00 49 06 00 7A FD 00 03 05 3A 06 00 45'\r\n '06 00 4A 06 00 BD FC 00 02 03 3A 06 00 45 06 00 2C FC 00 02 06 3A 06 00 45 06 00 15 FD 00 02 05'\r\n '3A 06 00 49 06 00 F9 FC 00 02 06 3A 06 00 49 06 00 FA FC 00 02 06 3A 06 00 4A 06 00 16 FD 00 02'\r\n '05 3A 06 00 4A 06 00 D0 FE 00 01 04 3A 06 00 CF FE 00 01 03 3A 06 00 CD FE 00 01 06 3A 06 00 CE'\r\n 'FE 00 01 05 3A 06 00 71 FE 00 02 04 40 06 00 4B 06 00 F2 FC 00 03 04 40 06 00 4E 06 00 51 06 00'\r\n '77 FE 00 02 04 40 06 00 4E 06 00 F3 FC 00 03 04 40 06 00 4F 06 00 51 06 00 79 FE 00 02 04 40 06'\r\n '00 4F 06 00 F4 FC 00 03 04 40 06 00 50 06 00 51 06 00 7B FE 00 02 04 40 06 00 50 06 00 7D FE 00'\r\n '02 04 40 06 00 51 06 00 7F FE 00 02 04 40 06 00 52 06 00 2D FC 00 02 06 41 06 00 2C 06 00 BE FC'\r\n '00 02 03 41 06 00 2C 06 00 2E FC 00 02 06 41 06 00 2D 06 00 BF FC 00 02 03 41 06 00 2D 06 00 7D'\r\n 'FD 00 03 03 41 06 00 2E 06 00 45 06 00 7C FD 00 03 05 41 06 00 2E 06 00 45 06 00 C0 FC 00 02 03'\r\n '41 06 00 2E 06 00 2F FC 00 02 06 41 06 00 2E 06 00 C1 FD 00 03 05 41 06 00 45 06 00 4A 06 00 30'\r\n 'FC 00 02 06 41 06 00 45 06 00 C1 FC 00 02 03 41 06 00 45 06 00 31 FC 00 02 06 41 06 00 49 06 00'\r\n '7C FC 00 02 05 41 06 00 49 06 00 32 FC 00 02 06 41 06 00 4A 06 00 7D FC 00 02 05 41 06 00 4A 06'\r\n '00 D4 FE 00 01 04 41 06 00 D2 FE 00 01 05 41 06 00 D1 FE 00 01 06 41 06 00 D3 FE 00 01 03 41 06'\r\n '00 C2 FC 00 02 03 42 06 00 2D 06 00 33 FC 00 02 06 42 06 00 2D 06 00 F1 FD 00 03 06 42 06 00 44'\r\n '06 00 D2 06 00 7E FD 00 03 05 42 06 00 45 06 00 2D 06 00 B4 FD 00 03 03 42 06 00 45 06 00 2D 06'\r\n '00 7F FD 00 03 05 42 06 00 45 06 00 45 06 00 B2 FD 00 03 05 42 06 00 45 06 00 4A 06 00 34 FC 00'\r\n '02 06 42 06 00 45 06 00 C3 FC 00 02 03 42 06 00 45 06 00 35 FC 00 02 06 42 06 00 49 06 00 7E FC'\r\n '00 02 05 42 06 00 49 06 00 7F FC 00 02 05 42 06 00 4A 06 00 36 FC 00 02 06 42 06 00 4A 06 00 D8'\r\n 'FE 00 01 04 42 06 00 D7 FE 00 01 03 42 06 00 D6 FE 00 01 05 42 06 00 D5 FE 00 01 06 42 06 00 37'\r\n 'FC 00 02 06 43 06 00 27 06 00 80 FC 00 02 05 43 06 00 27 06 00 38 FC 00 02 06 43 06 00 2C 06 00'\r\n 'C4 FC 00 02 03 43 06 00 2C 06 00 39 FC 00 02 06 43 06 00 2D 06 00 C5 FC 00 02 03 43 06 00 2D 06'\r\n '00 C6 FC 00 02 03 43 06 00 2E 06 00 3A FC 00 02 06 43 06 00 2E 06 00 3B FC 00 02 06 43 06 00 44'\r\n '06 00 81 FC 00 02 05 43 06 00 44 06 00 EB FC 00 02 04 43 06 00 44 06 00 C7 FC 00 02 03 43 06 00'\r\n '44 06 00 C3 FD 00 03 03 43 06 00 45 06 00 45 06 00 BB FD 00 03 05 43 06 00 45 06 00 45 06 00 B7'\r\n 'FD 00 03 05 43 06 00 45 06 00 4A 06 00 82 FC 00 02 05 43 06 00 45 06 00 C8 FC 00 02 03 43 06 00'\r\n '45 06 00 3C FC 00 02 06 43 06 00 45 06 00 EC FC 00 02 04 43 06 00 45 06 00 3D FC 00 02 06 43 06'\r\n '00 49 06 00 83 FC 00 02 05 43 06 00 49 06 00 3E FC 00 02 06 43 06 00 4A 06 00 84 FC 00 02 05 43'\r\n '06 00 4A 06 00 DC FE 00 01 04 43 06 00 D9 FE 00 01 06 43 06 00 DA FE 00 01 05 43 06 00 DB FE 00'\r\n '01 03 43 06 00 F6 FE 00 03 05 44 06 00 27 06 00 53 06 00 F5 FE 00 03 06 44 06 00 27 06 00 53 06'\r\n '00 F7 FE 00 03 06 44 06 00 27 06 00 54 06 00 F8 FE 00 03 05 44 06 00 27 06 00 54 06 00 F9 FE 00'\r\n '03 06 44 06 00 27 06 00 55 06 00 FA FE 00 03 05 44 06 00 27 06 00 55 06 00 FB FE 00 02 06 44 06'\r\n '00 27 06 00 FC FE 00 02 05 44 06 00 27 06 00 83 FD 00 03 03 44 06 00 2C 06 00 2C 06 00 84 FD 00'\r\n '03 05 44 06 00 2C 06 00 2C 06 00 BA FD 00 03 03 44 06 00 2C 06 00 45 06 00 BC FD 00 03 05 44 06'\r\n '00 2C 06 00 45 06 00 AC FD 00 03 05 44 06 00 2C 06 00 4A 06 00 3F FC 00 02 06 44 06 00 2C 06 00'\r\n 'C9 FC 00 02 03 44 06 00 2C 06 00 B5 FD 00 03 03 44 06 00 2D 06 00 45 06 00 80 FD 00 03 05 44 06'\r\n '00 2D 06 00 45 06 00 82 FD 00 03 05 44 06 00 2D 06 00 49 06 00 81 FD 00 03 05 44 06 00 2D 06 00'\r\n '4A 06 00 CA FC 00 02 03 44 06 00 2D 06 00 40 FC 00 02 06 44 06 00 2D 06 00 86 FD 00 03 03 44 06'\r\n '00 2E 06 00 45 06 00 85 FD 00 03 05 44 06 00 2E 06 00 45 06 00 41 FC 00 02 06 44 06 00 2E 06 00'\r\n 'CB FC 00 02 03 44 06 00 2E 06 00 88 FD 00 03 03 44 06 00 45 06 00 2D 06 00 87 FD 00 03 05 44 06'\r\n '00 45 06 00 2D 06 00 AD FD 00 03 05 44 06 00 45 06 00 4A 06 00 ED FC 00 02 04 44 06 00 45 06 00'\r\n 'CC FC 00 02 03 44 06 00 45 06 00 42 FC 00 02 06 44 06 00 45 06 00 85 FC 00 02 05 44 06 00 45 06'\r\n '00 CD FC 00 02 03 44 06 00 47 06 00 43 FC 00 02 06 44 06 00 49 06 00 86 FC 00 02 05 44 06 00 49'\r\n '06 00 87 FC 00 02 05 44 06 00 4A 06 00 44 FC 00 02 06 44 06 00 4A 06 00 DE FE 00 01 05 44 06 00'\r\n 'DD FE 00 01 06 44 06 00 E0 FE 00 01 04 44 06 00 DF FE 00 01 03 44 06 00 88 FC 00 02 05 45 06 00'\r\n '27 06 00 8C FD 00 03 03 45 06 00 2C 06 00 2D 06 00 92 FD 00 03 03 45 06 00 2C 06 00 2E 06 00 8D'\r\n 'FD 00 03 03 45 06 00 2C 06 00 45 06 00 C0 FD 00 03 05 45 06 00 2C 06 00 4A 06 00 CE FC 00 02 03'\r\n '45 06 00 2C 06 00 45 FC 00 02 06 45 06 00 2C 06 00 89 FD 00 03 03 45 06 00 2D 06 00 2C 06 00 F4'\r\n 'FD 00 04 06 45 06 00 2D 06 00 45 06 00 2F 06 00 8A FD 00 03 03 45 06 00 2D 06 00 45 06 00 8B FD'\r\n '00 03 05 45 06 00 2D 06 00 4A 06 00 CF FC 00 02 03 45 06 00 2D 06 00 46 FC 00 02 06 45 06 00 2D'\r\n '06 00 8E FD 00 03 03 45 06 00 2E 06 00 2C 06 00 8F FD 00 03 03 45 06 00 2E 06 00 45 06 00 B9 FD'\r\n '00 03 05 45 06 00 2E 06 00 4A 06 00 47 FC 00 02 06 45 06 00 2E 06 00 D0 FC 00 02 03 45 06 00 2E'\r\n '06 00 B1 FD 00 03 05 45 06 00 45 06 00 4A 06 00 89 FC 00 02 05 45 06 00 45 06 00 D1 FC 00 02 03'\r\n '45 06 00 45 06 00 48 FC 00 02 06 45 06 00 45 06 00 49 FC 00 02 06 45 06 00 49 06 00 4A FC 00 02'\r\n '06 45 06 00 4A 06 00 E2 FE 00 01 05 45 06 00 E3 FE 00 01 03 45 06 00 E4 FE 00 01 04 45 06 00 E1'\r\n 'FE 00 01 06 45 06 00 B8 FD 00 03 03 46 06 00 2C 06 00 2D 06 00 BD FD 00 03 05 46 06 00 2C 06 00'\r\n '2D 06 00 98 FD 00 03 03 46 06 00 2C 06 00 45 06 00 97 FD 00 03 05 46 06 00 2C 06 00 45 06 00 99'\r\n 'FD 00 03 05 46 06 00 2C 06 00 49 06 00 C7 FD 00 03 05 46 06 00 2C 06 00 4A 06 00 D2 FC 00 02 03'\r\n '46 06 00 2C 06 00 4B FC 00 02 06 46 06 00 2C 06 00 95 FD 00 03 03 46 06 00 2D 06 00 45 06 00 96'\r\n 'FD 00 03 05 46 06 00 2D 06 00 49 06 00 B3 FD 00 03 05 46 06 00 2D 06 00 4A 06 00 4C FC 00 02 06'\r\n '46 06 00 2D 06 00 D3 FC 00 02 03 46 06 00 2D 06 00 D4 FC 00 02 03 46 06 00 2E 06 00 4D FC 00 02'\r\n '06 46 06 00 2E 06 00 8A FC 00 02 05 46 06 00 31 06 00 8B FC 00 02 05 46 06 00 32 06 00 9B FD 00'\r\n '03 05 46 06 00 45 06 00 49 06 00 9A FD 00 03 05 46 06 00 45 06 00 4A 06 00 8C FC 00 02 05 46 06'\r\n '00 45 06 00 EE FC 00 02 04 46 06 00 45 06 00 D5 FC 00 02 03 46 06 00 45 06 00 4E FC 00 02 06 46'\r\n '06 00 45 06 00 8D FC 00 02 05 46 06 00 46 06 00 D6 FC 00 02 03 46 06 00 47 06 00 EF FC 00 02 04'\r\n '46 06 00 47 06 00 4F FC 00 02 06 46 06 00 49 06 00 8E FC 00 02 05 46 06 00 49 06 00 50 FC 00 02'\r\n '06 46 06 00 4A 06 00 8F FC 00 02 05 46 06 00 4A 06 00 E8 FE 00 01 04 46 06 00 E5 FE 00 01 06 46'\r\n '06 00 E7 FE 00 01 03 46 06 00 E6 FE 00 01 05 46 06 00 51 FC 00 02 06 47 06 00 2C 06 00 D7 FC 00'\r\n '02 03 47 06 00 2C 06 00 93 FD 00 03 03 47 06 00 45 06 00 2C 06 00 94 FD 00 03 03 47 06 00 45 06'\r\n '00 45 06 00 D8 FC 00 02 03 47 06 00 45 06 00 52 FC 00 02 06 47 06 00 45 06 00 53 FC 00 02 06 47'\r\n '06 00 49 06 00 54 FC 00 02 06 47 06 00 4A 06 00 D9 FC 00 02 03 47 06 00 70 06 00 EB FE 00 01 03'\r\n '47 06 00 EA FE 00 01 05 47 06 00 E9 FE 00 01 06 47 06 00 EC FE 00 01 04 47 06 00 F8 FD 00 04 06'\r\n '48 06 00 33 06 00 44 06 00 45 06 00 24 06 00 02 00 48 06 00 54 06 00 86 FE 00 02 05 48 06 00 54'\r\n '06 00 85 FE 00 02 06 48 06 00 54 06 00 76 06 00 02 10 48 06 00 74 06 00 ED FE 00 01 06 48 06 00'\r\n 'EE FE 00 01 05 48 06 00 90 FC 00 02 05 49 06 00 70 06 00 5D FC 00 02 06 49 06 00 70 06 00 F0 FE'\r\n '00 01 05 49 06 00 EF FE 00 01 06 49 06 00 E9 FB 00 01 04 49 06 00 E8 FB 00 01 03 49 06 00 AF FD'\r\n '00 03 05 4A 06 00 2C 06 00 4A 06 00 55 FC 00 02 06 4A 06 00 2C 06 00 DA FC 00 02 03 4A 06 00 2C'\r\n '06 00 AE FD 00 03 05 4A 06 00 2D 06 00 4A 06 00 DB FC 00 02 03 4A 06 00 2D 06 00 56 FC 00 02 06'\r\n '4A 06 00 2D 06 00 DC FC 00 02 03 4A 06 00 2E 06 00 57 FC 00 02 06 4A 06 00 2E 06 00 91 FC 00 02'\r\n '05 4A 06 00 31 06 00 92 FC 00 02 05 4A 06 00 32 06 00 9D FD 00 03 03 4A 06 00 45 06 00 45 06 00'\r\n '9C FD 00 03 05 4A 06 00 45 06 00 45 06 00 B0 FD 00 03 05 4A 06 00 45 06 00 4A 06 00 58 FC 00 02'\r\n '06 4A 06 00 45 06 00 F0 FC 00 02 04 4A 06 00 45 06 00 DD FC 00 02 03 4A 06 00 45 06 00 93 FC 00'\r\n '02 05 4A 06 00 45 06 00 94 FC 00 02 05 4A 06 00 46 06 00 DE FC 00 02 03 4A 06 00 47 06 00 F1 FC'\r\n '00 02 04 4A 06 00 47 06 00 95 FC 00 02 05 4A 06 00 49 06 00 59 FC 00 02 06 4A 06 00 49 06 00 5A'\r\n 'FC 00 02 06 4A 06 00 4A 06 00 96 FC 00 02 05 4A 06 00 4A 06 00 EB FB 00 03 05 4A 06 00 54 06 00'\r\n '27 06 00 EA FB 00 03 06 4A 06 00 54 06 00 27 06 00 00 FC 00 03 06 4A 06 00 54 06 00 2C 06 00 97'\r\n 'FC 00 03 03 4A 06 00 54 06 00 2C 06 00 01 FC 00 03 06 4A 06 00 54 06 00 2D 06 00 98 FC 00 03 03'\r\n '4A 06 00 54 06 00 2D 06 00 99 FC 00 03 03 4A 06 00 54 06 00 2E 06 00 64 FC 00 03 05 4A 06 00 54'\r\n '06 00 31 06 00 65 FC 00 03 05 4A 06 00 54 06 00 32 06 00 DF FC 00 03 04 4A 06 00 54 06 00 45 06'\r\n '00 9A FC 00 03 03 4A 06 00 54 06 00 45 06 00 02 FC 00 03 06 4A 06 00 54 06 00 45 06 00 66 FC 00'\r\n '03 05 4A 06 00 54 06 00 45 06 00 67 FC 00 03 05 4A 06 00 54 06 00 46 06 00 9B FC 00 03 03 4A 06'\r\n '00 54 06 00 47 06 00 E0 FC 00 03 04 4A 06 00 54 06 00 47 06 00 EE FB 00 03 06 4A 06 00 54 06 00'\r\n '48 06 00 EF FB 00 03 05 4A 06 00 54 06 00 48 06 00 68 FC 00 03 05 4A 06 00 54 06 00 49 06 00 F9'\r\n 'FB 00 03 06 4A 06 00 54 06 00 49 06 00 03 FC 00 03 06 4A 06 00 54 06 00 49 06 00 FB FB 00 03 03'\r\n '4A 06 00 54 06 00 49 06 00 FA FB 00 03 05 4A 06 00 54 06 00 49 06 00 69 FC 00 03 05 4A 06 00 54'\r\n '06 00 4A 06 00 04 FC 00 03 06 4A 06 00 54 06 00 4A 06 00 F3 FB 00 03 05 4A 06 00 54 06 00 C6 06'\r\n '00 F2 FB 00 03 06 4A 06 00 54 06 00 C6 06 00 F0 FB 00 03 06 4A 06 00 54 06 00 C7 06 00 F1 FB 00'\r\n '03 05 4A 06 00 54 06 00 C7 06 00 F5 FB 00 03 05 4A 06 00 54 06 00 C8 06 00 F4 FB 00 03 06 4A 06'\r\n '00 54 06 00 C8 06 00 F7 FB 00 03 05 4A 06 00 54 06 00 D0 06 00 F8 FB 00 03 03 4A 06 00 54 06 00'\r\n 'D0 06 00 F6 FB 00 03 06 4A 06 00 54 06 00 D0 06 00 EC FB 00 03 06 4A 06 00 54 06 00 D5 06 00 ED'\r\n 'FB 00 03 05 4A 06 00 54 06 00 D5 06 00 89 FE 00 02 06 4A 06 00 54 06 00 26 06 00 02 00 4A 06 00'\r\n '54 06 00 8A FE 00 02 05 4A 06 00 54 06 00 8B FE 00 02 03 4A 06 00 54 06 00 8C FE 00 02 04 4A 06'\r\n '00 54 06 00 78 06 00 02 10 4A 06 00 74 06 00 F2 FE 00 01 05 4A 06 00 F1 FE 00 01 06 4A 06 00 F4'\r\n 'FE 00 01 04 4A 06 00 F3 FE 00 01 03 4A 06 00 50 FB 00 01 06 71 06 00 51 FB 00 01 05 71 06 00 67'\r\n 'FB 00 01 05 79 06 00 68 FB 00 01 03 79 06 00 69 FB 00 01 04 79 06 00 66 FB 00 01 06 79 06 00 5F'\r\n 'FB 00 01 05 7A 06 00 5E FB 00 01 06 7A 06 00 61 FB 00 01 04 7A 06 00 60 FB 00 01 03 7A 06 00 55'\r\n 'FB 00 01 04 7B 06 00 52 FB 00 01 06 7B 06 00 53 FB 00 01 05 7B 06 00 54 FB 00 01 03 7B 06 00 59'\r\n 'FB 00 01 04 7E 06 00 58 FB 00 01 03 7E 06 00 56 FB 00 01 06 7E 06 00 57 FB 00 01 05 7E 06 00 63'\r\n 'FB 00 01 05 7F 06 00 62 FB 00 01 06 7F 06 00 65 FB 00 01 04 7F 06 00 64 FB 00 01 03 7F 06 00 5B'\r\n 'FB 00 01 05 80 06 00 5A FB 00 01 06 80 06 00 5D FB 00 01 04 80 06 00 5C FB 00 01 03 80 06 00 77'\r\n 'FB 00 01 05 83 06 00 78 FB 00 01 03 83 06 00 79 FB 00 01 04 83 06 00 76 FB 00 01 06 83 06 00 74'\r\n 'FB 00 01 03 84 06 00 73 FB 00 01 05 84 06 00 72 FB 00 01 06 84 06 00 75 FB 00 01 04 84 06 00 7C'\r\n 'FB 00 01 03 86 06 00 7D FB 00 01 04 86 06 00 7A FB 00 01 06 86 06 00 7B FB 00 01 05 86 06 00 81'\r\n 'FB 00 01 04 87 06 00 7E FB 00 01 06 87 06 00 7F FB 00 01 05 87 06 00 80 FB 00 01 03 87 06 00 88'\r\n 'FB 00 01 06 88 06 00 89 FB 00 01 05 88 06 00 85 FB 00 01 05 8C 06 00 84 FB 00 01 06 8C 06 00 83'\r\n 'FB 00 01 05 8D 06 00 82 FB 00 01 06 8D 06 00 87 FB 00 01 05 8E 06 00 86 FB 00 01 06 8E 06 00 8D'\r\n 'FB 00 01 05 91 06 00 8C FB 00 01 06 91 06 00 8B FB 00 01 05 98 06 00 8A FB 00 01 06 98 06 00 6C'\r\n 'FB 00 01 03 A4 06 00 6D FB 00 01 04 A4 06 00 6A FB 00 01 06 A4 06 00 6B FB 00 01 05 A4 06 00 70'\r\n 'FB 00 01 03 A6 06 00 71 FB 00 01 04 A6 06 00 6E FB 00 01 06 A6 06 00 6F FB 00 01 05 A6 06 00 90'\r\n 'FB 00 01 03 A9 06 00 91 FB 00 01 04 A9 06 00 8E FB 00 01 06 A9 06 00 8F FB 00 01 05 A9 06 00 D4'\r\n 'FB 00 01 05 AD 06 00 D3 FB 00 01 06 AD 06 00 D6 FB 00 01 04 AD 06 00 D5 FB 00 01 03 AD 06 00 93'\r\n 'FB 00 01 05 AF 06 00 92 FB 00 01 06 AF 06 00 95 FB 00 01 04 AF 06 00 94 FB 00 01 03 AF 06 00 9C'\r\n 'FB 00 01 03 B1 06 00 9B FB 00 01 05 B1 06 00 9A FB 00 01 06 B1 06 00 9D FB 00 01 04 B1 06 00 98'\r\n 'FB 00 01 03 B3 06 00 97 FB 00 01 05 B3 06 00 96 FB 00 01 06 B3 06 00 99 FB 00 01 04 B3 06 00 9E'\r\n 'FB 00 01 06 BA 06 00 9F FB 00 01 05 BA 06 00 A2 FB 00 01 03 BB 06 00 A3 FB 00 01 04 BB 06 00 A0'\r\n 'FB 00 01 06 BB 06 00 A1 FB 00 01 05 BB 06 00 AC FB 00 01 03 BE 06 00 AD FB 00 01 04 BE 06 00 AA'\r\n 'FB 00 01 06 BE 06 00 AB FB 00 01 05 BE 06 00 C2 06 00 02 00 C1 06 00 54 06 00 A9 FB 00 01 04 C1'\r\n '06 00 A8 FB 00 01 03 C1 06 00 A6 FB 00 01 06 C1 06 00 A7 FB 00 01 05 C1 06 00 E1 FB 00 01 05 C5'\r\n '06 00 E0 FB 00 01 06 C5 06 00 D9 FB 00 01 06 C6 06 00 DA FB 00 01 05 C6 06 00 DD FB 00 02 06 C7'\r\n '06 00 74 06 00 77 06 00 02 10 C7 06 00 74 06 00 D7 FB 00 01 06 C7 06 00 D8 FB 00 01 05 C7 06 00'\r\n 'DB FB 00 01 06 C8 06 00 DC FB 00 01 05 C8 06 00 E3 FB 00 01 05 C9 06 00 E2 FB 00 01 06 C9 06 00'\r\n 'DF FB 00 01 05 CB 06 00 DE FB 00 01 06 CB 06 00 FE FB 00 01 03 CC 06 00 FF FB 00 01 04 CC 06 00'\r\n 'FC FB 00 01 06 CC 06 00 FD FB 00 01 05 CC 06 00 E4 FB 00 01 06 D0 06 00 E7 FB 00 01 04 D0 06 00'\r\n 'E6 FB 00 01 03 D0 06 00 E5 FB 00 01 05 D0 06 00 D3 06 00 02 00 D2 06 00 54 06 00 B0 FB 00 02 06'\r\n 'D2 06 00 54 06 00 B1 FB 00 02 05 D2 06 00 54 06 00 AE FB 00 01 06 D2 06 00 AF FB 00 01 05 D2 06'\r\n '00 C0 06 00 02 00 D5 06 00 54 06 00 A5 FB 00 02 05 D5 06 00 54 06 00 A4 FB 00 02 06 D5 06 00 54'\r\n '06 00 29 09 00 02 00 28 09 00 3C 09 00 31 09 00 02 00 30 09 00 3C 09 00 34 09 00 02 00 33 09 00'\r\n '3C 09 00 CB 09 00 02 00 C7 09 00 BE 09 00 CC 09 00 02 00 C7 09 00 D7 09 00 4B 0B 00 02 00 47 0B'\r\n '00 3E 0B 00 48 0B 00 02 00 47 0B 00 56 0B 00 4C 0B 00 02 00 47 0B 00 57 0B 00 94 0B 00 02 00 92'\r\n '0B 00 D7 0B 00 CA 0B 00 02 00 C6 0B 00 BE 0B 00 CC 0B 00 02 00 C6 0B 00 D7 0B 00 CB 0B 00 02 00'\r\n 'C7 0B 00 BE 0B 00 48 0C 00 02 00 46 0C 00 56 0C 00 C0 0C 00 02 00 BF 0C 00 D5 0C 00 CB 0C 00 03'\r\n '00 C6 0C 00 C2 0C 00 D5 0C 00 CA 0C 00 02 00 C6 0C 00 C2 0C 00 C7 0C 00 02 00 C6 0C 00 D5 0C 00'\r\n 'C8 0C 00 02 00 C6 0C 00 D6 0C 00 4A 0D 00 02 00 46 0D 00 3E 0D 00 4C 0D 00 02 00 46 0D 00 57 0D'\r\n '00 4B 0D 00 02 00 47 0D 00 3E 0D 00 DA 0D 00 02 00 D9 0D 00 CA 0D 00 DD 0D 00 03 00 D9 0D 00 CF'\r\n '0D 00 CA 0D 00 DC 0D 00 02 00 D9 0D 00 CF 0D 00 DE 0D 00 02 00 D9 0D 00 DF 0D 00 33 0E 00 02 10'\r\n '4D 0E 00 32 0E 00 DC 0E 00 02 10 AB 0E 00 99 0E 00 DD 0E 00 02 10 AB 0E 00 A1 0E 00 B3 0E 00 02'\r\n '10 CD 0E 00 B2 0E 00 0C 0F 00 01 02 0B 0F 00 77 0F 00 03 10 B2 0F 00 71 0F 00 80 0F 00 79 0F 00'\r\n '03 10 B3 0F 00 71 0F 00 80 0F 00 26 10 00 02 00 25 10 00 2E 10 00 FC 10 00 01 08 DC 10 00 6E 32'\r\n '00 02 07 00 11 00 61 11 00 31 31 00 01 10 00 11 00 A1 FF 00 01 0C 00 11 00 60 32 00 01 07 00 11'\r\n '00 32 31 00 01 10 01 11 00 A2 FF 00 01 0C 01 11 00 6F 32 00 02 07 02 11 00 61 11 00 34 31 00 01'\r\n '10 02 11 00 61 32 00 01 07 02 11 00 A4 FF 00 01 0C 02 11 00 70 32 00 02 07 03 11 00 61 11 00 A7'\r\n 'FF 00 01 0C 03 11 00 62 32 00 01 07 03 11 00 37 31 00 01 10 03 11 00 A8 FF 00 01 0C 04 11 00 38'\r\n '31 00 01 10 04 11 00 71 32 00 02 07 05 11 00 61 11 00 A9 FF 00 01 0C 05 11 00 39 31 00 01 10 05'\r\n '11 00 63 32 00 01 07 05 11 00 72 32 00 02 07 06 11 00 61 11 00 64 32 00 01 07 06 11 00 41 31 00'\r\n '01 10 06 11 00 B1 FF 00 01 0C 06 11 00 73 32 00 02 07 07 11 00 61 11 00 65 32 00 01 07 07 11 00'\r\n '42 31 00 01 10 07 11 00 B2 FF 00 01 0C 07 11 00 B3 FF 00 01 0C 08 11 00 43 31 00 01 10 08 11 00'\r\n '74 32 00 02 07 09 11 00 61 11 00 66 32 00 01 07 09 11 00 45 31 00 01 10 09 11 00 B5 FF 00 01 0C'\r\n '09 11 00 46 31 00 01 10 0A 11 00 B6 FF 00 01 0C 0A 11 00 75 32 00 02 07 0B 11 00 61 11 00 7E 32'\r\n '00 02 07 0B 11 00 6E 11 00 B7 FF 00 01 0C 0B 11 00 67 32 00 01 07 0B 11 00 47 31 00 01 10 0B 11'\r\n '00 76 32 00 02 07 0C 11 00 61 11 00 7D 32 00 04 07 0C 11 00 6E 11 00 0B 11 00 74 11 00 48 31 00'\r\n '01 10 0C 11 00 B8 FF 00 01 0C 0C 11 00 68 32 00 01 07 0C 11 00 B9 FF 00 01 0C 0D 11 00 49 31 00'\r\n '01 10 0D 11 00 7C 32 00 05 07 0E 11 00 61 11 00 B7 11 00 00 11 00 69 11 00 77 32 00 02 07 0E 11'\r\n '00 61 11 00 BA FF 00 01 0C 0E 11 00 69 32 00 01 07 0E 11 00 4A 31 00 01 10 0E 11 00 78 32 00 02'\r\n '07 0F 11 00 61 11 00 6A 32 00 01 07 0F 11 00 4B 31 00 01 10 0F 11 00 BB FF 00 01 0C 0F 11 00 79'\r\n '32 00 02 07 10 11 00 61 11 00 4C 31 00 01 10 10 11 00 BC FF 00 01 0C 10 11 00 6B 32 00 01 07 10'\r\n '11 00 7A 32 00 02 07 11 11 00 61 11 00 4D 31 00 01 10 11 11 00 BD FF 00 01 0C 11 11 00 6C 32 00'\r\n '01 07 11 11 00 7B 32 00 02 07 12 11 00 61 11 00 4E 31 00 01 10 12 11 00 6D 32 00 01 07 12 11 00'\r\n 'BE FF 00 01 0C 12 11 00 65 31 00 01 10 14 11 00 66 31 00 01 10 15 11 00 40 31 00 01 10 1A 11 00'\r\n 'B0 FF 00 01 0C 1A 11 00 6E 31 00 01 10 1C 11 00 71 31 00 01 10 1D 11 00 72 31 00 01 10 1E 11 00'\r\n '73 31 00 01 10 20 11 00 44 31 00 01 10 21 11 00 B4 FF 00 01 0C 21 11 00 74 31 00 01 10 22 11 00'\r\n '75 31 00 01 10 23 11 00 76 31 00 01 10 27 11 00 77 31 00 01 10 29 11 00 78 31 00 01 10 2B 11 00'\r\n '79 31 00 01 10 2C 11 00 7A 31 00 01 10 2D 11 00 7B 31 00 01 10 2E 11 00 7C 31 00 01 10 2F 11 00'\r\n '7D 31 00 01 10 32 11 00 7E 31 00 01 10 36 11 00 7F 31 00 01 10 40 11 00 80 31 00 01 10 47 11 00'\r\n '81 31 00 01 10 4C 11 00 84 31 00 01 10 57 11 00 85 31 00 01 10 58 11 00 86 31 00 01 10 59 11 00'\r\n 'A0 FF 00 01 0C 60 11 00 64 31 00 01 10 60 11 00 C2 FF 00 01 0C 61 11 00 4F 31 00 01 10 61 11 00'\r\n 'C3 FF 00 01 0C 62 11 00 50 31 00 01 10 62 11 00 51 31 00 01 10 63 11 00 C4 FF 00 01 0C 63 11 00'\r\n '52 31 00 01 10 64 11 00 C5 FF 00 01 0C 64 11 00 C6 FF 00 01 0C 65 11 00 53 31 00 01 10 65 11 00'\r\n 'C7 FF 00 01 0C 66 11 00 54 31 00 01 10 66 11 00 CA FF 00 01 0C 67 11 00 55 31 00 01 10 67 11 00'\r\n '56 31 00 01 10 68 11 00 CB FF 00 01 0C 68 11 00 CC FF 00 01 0C 69 11 00 57 31 00 01 10 69 11 00'\r\n '58 31 00 01 10 6A 11 00 CD FF 00 01 0C 6A 11 00 59 31 00 01 10 6B 11 00 CE FF 00 01 0C 6B 11 00'\r\n 'CF FF 00 01 0C 6C 11 00 5A 31 00 01 10 6C 11 00 5B 31 00 01 10 6D 11 00 D2 FF 00 01 0C 6D 11 00'\r\n '5C 31 00 01 10 6E 11 00 D3 FF 00 01 0C 6E 11 00 D4 FF 00 01 0C 6F 11 00 5D 31 00 01 10 6F 11 00'\r\n '5E 31 00 01 10 70 11 00 D5 FF 00 01 0C 70 11 00 D6 FF 00 01 0C 71 11 00 5F 31 00 01 10 71 11 00'\r\n '60 31 00 01 10 72 11 00 D7 FF 00 01 0C 72 11 00 61 31 00 01 10 73 11 00 DA FF 00 01 0C 73 11 00'\r\n '62 31 00 01 10 74 11 00 DB FF 00 01 0C 74 11 00 DC FF 00 01 0C 75 11 00 63 31 00 01 10 75 11 00'\r\n '87 31 00 01 10 84 11 00 88 31 00 01 10 85 11 00 89 31 00 01 10 88 11 00 8A 31 00 01 10 91 11 00'\r\n '8B 31 00 01 10 92 11 00 8C 31 00 01 10 94 11 00 8D 31 00 01 10 9E 11 00 8E 31 00 01 10 A1 11 00'\r\n '33 31 00 01 10 AA 11 00 A3 FF 00 01 0C AA 11 00 A5 FF 00 01 0C AC 11 00 35 31 00 01 10 AC 11 00'\r\n 'A6 FF 00 01 0C AD 11 00 36 31 00 01 10 AD 11 00 3A 31 00 01 10 B0 11 00 AA FF 00 01 0C B0 11 00'\r\n '3B 31 00 01 10 B1 11 00 AB FF 00 01 0C B1 11 00 AC FF 00 01 0C B2 11 00 3C 31 00 01 10 B2 11 00'\r\n 'AD FF 00 01 0C B3 11 00 3D 31 00 01 10 B3 11 00 3E 31 00 01 10 B4 11 00 AE FF 00 01 0C B4 11 00'\r\n 'AF FF 00 01 0C B5 11 00 3F 31 00 01 10 B5 11 00 67 31 00 01 10 C7 11 00 68 31 00 01 10 C8 11 00'\r\n '69 31 00 01 10 CC 11 00 6A 31 00 01 10 CE 11 00 6B 31 00 01 10 D3 11 00 6C 31 00 01 10 D7 11 00'\r\n '6D 31 00 01 10 D9 11 00 6F 31 00 01 10 DD 11 00 70 31 00 01 10 DF 11 00 82 31 00 01 10 F1 11 00'\r\n '83 31 00 01 10 F2 11 00 06 1B 00 02 00 05 1B 00 35 1B 00 08 1B 00 02 00 07 1B 00 35 1B 00 0A 1B'\r\n '00 02 00 09 1B 00 35 1B 00 0C 1B 00 02 00 0B 1B 00 35 1B 00 0E 1B 00 02 00 0D 1B 00 35 1B 00 12'\r\n '1B 00 02 00 11 1B 00 35 1B 00 3B 1B 00 02 00 3A 1B 00 35 1B 00 3D 1B 00 02 00 3C 1B 00 35 1B 00'\r\n '40 1B 00 02 00 3E 1B 00 35 1B 00 41 1B 00 02 00 3F 1B 00 35 1B 00 43 1B 00 02 00 42 1B 00 35 1B'\r\n '00 46 1D 00 01 08 02 1D 00 54 1D 00 01 08 16 1D 00 55 1D 00 01 08 17 1D 00 B8 1D 00 01 08 1C 1D'\r\n '00 59 1D 00 01 08 1D 1D 00 5C 1D 00 01 08 25 1D 00 A7 1D 00 01 08 7B 1D 00 AA 1D 00 01 08 85 1D'\r\n '00 11 20 00 01 02 10 20 00 32 FE 00 01 0A 13 20 00 58 FE 00 01 0D 14 20 00 31 FE 00 01 0A 14 20'\r\n '00 57 20 00 04 10 32 20 00 32 20 00 32 20 00 32 20 00 34 20 00 03 10 32 20 00 32 20 00 32 20 00'\r\n '33 20 00 02 10 32 20 00 32 20 00 37 20 00 03 10 35 20 00 35 20 00 35 20 00 36 20 00 02 10 35 20'\r\n '00 35 20 00 E6 FF 00 01 0B A9 20 00 9A 21 00 02 00 90 21 00 38 03 00 E9 FF 00 01 0C 90 21 00 EA'\r\n 'FF 00 01 0C 91 21 00 9B 21 00 02 00 92 21 00 38 03 00 EB FF 00 01 0C 92 21 00 EC FF 00 01 0C 93'\r\n '21 00 AE 21 00 02 00 94 21 00 38 03 00 CD 21 00 02 00 D0 21 00 38 03 00 CF 21 00 02 00 D2 21 00'\r\n '38 03 00 CE 21 00 02 00 D4 21 00 38 03 00 DB D6 01 01 01 02 22 00 4F D7 01 01 01 02 22 00 15 D7'\r\n '01 01 01 02 22 00 89 D7 01 01 01 02 22 00 C3 D7 01 01 01 02 22 00 04 22 00 02 00 03 22 00 38 03'\r\n '00 C1 D6 01 01 01 07 22 00 A9 D7 01 01 01 07 22 00 6F D7 01 01 01 07 22 00 35 D7 01 01 01 07 22'\r\n '00 FB D6 01 01 01 07 22 00 09 22 00 02 00 08 22 00 38 03 00 0C 22 00 02 00 0B 22 00 38 03 00 40'\r\n '21 00 01 01 11 22 00 8B 20 00 01 09 12 22 00 7B 20 00 01 08 12 22 00 24 22 00 02 00 23 22 00 38'\r\n '03 00 26 22 00 02 00 25 22 00 38 03 00 0C 2A 00 04 10 2B 22 00 2B 22 00 2B 22 00 2B 22 00 2D 22'\r\n '00 03 10 2B 22 00 2B 22 00 2B 22 00 2C 22 00 02 10 2B 22 00 2B 22 00 30 22 00 03 10 2E 22 00 2E'\r\n '22 00 2E 22 00 2F 22 00 02 10 2E 22 00 2E 22 00 41 22 00 02 00 3C 22 00 38 03 00 44 22 00 02 00'\r\n '43 22 00 38 03 00 47 22 00 02 00 45 22 00 38 03 00 49 22 00 02 00 48 22 00 38 03 00 6D 22 00 02'\r\n '00 4D 22 00 38 03 00 62 22 00 02 00 61 22 00 38 03 00 70 22 00 02 00 64 22 00 38 03 00 71 22 00'\r\n '02 00 65 22 00 38 03 00 74 22 00 02 00 72 22 00 38 03 00 75 22 00 02 00 73 22 00 38 03 00 78 22'\r\n '00 02 00 76 22 00 38 03 00 79 22 00 02 00 77 22 00 38 03 00 80 22 00 02 00 7A 22 00 38 03 00 81'\r\n '22 00 02 00 7B 22 00 38 03 00 E0 22 00 02 00 7C 22 00 38 03 00 E1 22 00 02 00 7D 22 00 38 03 00'\r\n '84 22 00 02 00 82 22 00 38 03 00 85 22 00 02 00 83 22 00 38 03 00 88 22 00 02 00 86 22 00 38 03'\r\n '00 89 22 00 02 00 87 22 00 38 03 00 E2 22 00 02 00 91 22 00 38 03 00 E3 22 00 02 00 92 22 00 38'\r\n '03 00 AC 22 00 02 00 A2 22 00 38 03 00 AD 22 00 02 00 A8 22 00 38 03 00 AE 22 00 02 00 A9 22 00'\r\n '38 03 00 AF 22 00 02 00 AB 22 00 38 03 00 EA 22 00 02 00 B2 22 00 38 03 00 EB 22 00 02 00 B3 22'\r\n '00 38 03 00 EC 22 00 02 00 B4 22 00 38 03 00 ED 22 00 02 00 B5 22 00 38 03 00 E8 FF 00 01 0C 02'\r\n '25 00 ED FF 00 01 0C A0 25 00 EE FF 00 01 0C CB 25 00 5F FF 00 01 0B 85 29 00 60 FF 00 01 0B 86'\r\n '29 00 6F 2D 00 01 08 61 2D 00 11 FE 00 01 0A 01 30 00 64 FF 00 01 0C 01 30 00 51 FE 00 01 0D 01'\r\n '30 00 12 FE 00 01 0A 02 30 00 61 FF 00 01 0C 02 30 00 3F FE 00 01 0A 08 30 00 40 FE 00 01 0A 09'\r\n '30 00 3D FE 00 01 0A 0A 30 00 3E FE 00 01 0A 0B 30 00 41 FE 00 01 0A 0C 30 00 62 FF 00 01 0C 0C'\r\n '30 00 42 FE 00 01 0A 0D 30 00 63 FF 00 01 0C 0D 30 00 43 FE 00 01 0A 0E 30 00 44 FE 00 01 0A 0F'\r\n '30 00 3B FE 00 01 0A 10 30 00 3C FE 00 01 0A 11 30 00 36 30 00 01 10 12 30 00 2A F1 01 03 10 14'\r\n '30 00 53 00 00 15 30 00 41 F2 01 03 10 14 30 00 09 4E 00 15 30 00 42 F2 01 03 10 14 30 00 8C 4E'\r\n '00 15 30 00 47 F2 01 03 10 14 30 00 DD 52 00 15 30 00 43 F2 01 03 10 14 30 00 89 5B 00 15 30 00'\r\n '45 F2 01 03 10 14 30 00 53 62 00 15 30 00 48 F2 01 03 10 14 30 00 57 65 00 15 30 00 40 F2 01 03'\r\n '10 14 30 00 2C 67 00 15 30 00 44 F2 01 03 10 14 30 00 B9 70 00 15 30 00 46 F2 01 03 10 14 30 00'\r\n 'D7 76 00 15 30 00 5D FE 00 01 0D 14 30 00 39 FE 00 01 0A 14 30 00 3A FE 00 01 0A 15 30 00 5E FE'\r\n '00 01 0D 15 30 00 17 FE 00 01 0A 16 30 00 18 FE 00 01 0A 17 30 00 94 30 00 02 00 46 30 00 99 30'\r\n '00 4C 30 00 02 00 4B 30 00 99 30 00 4E 30 00 02 00 4D 30 00 99 30 00 50 30 00 02 00 4F 30 00 99'\r\n '30 00 52 30 00 02 00 51 30 00 99 30 00 54 30 00 02 00 53 30 00 99 30 00 56 30 00 02 00 55 30 00'\r\n '99 30 00 58 30 00 02 00 57 30 00 99 30 00 5A 30 00 02 00 59 30 00 99 30 00 5C 30 00 02 00 5B 30'\r\n '00 99 30 00 5E 30 00 02 00 5D 30 00 99 30 00 60 30 00 02 00 5F 30 00 99 30 00 62 30 00 02 00 61'\r\n '30 00 99 30 00 65 30 00 02 00 64 30 00 99 30 00 67 30 00 02 00 66 30 00 99 30 00 69 30 00 02 00'\r\n '68 30 00 99 30 00 70 30 00 02 00 6F 30 00 99 30 00 71 30 00 02 00 6F 30 00 9A 30 00 73 30 00 02'\r\n '00 72 30 00 99 30 00 74 30 00 02 00 72 30 00 9A 30 00 76 30 00 02 00 75 30 00 99 30 00 77 30 00'\r\n '02 00 75 30 00 9A 30 00 79 30 00 02 00 78 30 00 99 30 00 7A 30 00 02 00 78 30 00 9A 30 00 00 F2'\r\n '01 02 0E 7B 30 00 4B 30 00 7C 30 00 02 00 7B 30 00 99 30 00 7D 30 00 02 00 7B 30 00 9A 30 00 9F'\r\n '30 00 02 0A 88 30 00 8A 30 00 9E FF 00 01 0C 99 30 00 9F FF 00 01 0C 9A 30 00 9E 30 00 02 00 9D'\r\n '30 00 99 30 00 67 FF 00 01 0C A1 30 00 00 33 00 05 0E A2 30 00 CF 30 00 9A 30 00 FC 30 00 C8 30'\r\n '00 01 33 00 04 0E A2 30 00 EB 30 00 D5 30 00 A1 30 00 02 33 00 05 0E A2 30 00 F3 30 00 D8 30 00'\r\n '9A 30 00 A2 30 00 03 33 00 03 0E A2 30 00 FC 30 00 EB 30 00 71 FF 00 01 0C A2 30 00 D0 32 00 01'\r\n '07 A2 30 00 68 FF 00 01 0C A3 30 00 04 33 00 05 0E A4 30 00 CB 30 00 F3 30 00 AF 30 00 99 30 00'\r\n '05 33 00 03 0E A4 30 00 F3 30 00 C1 30 00 72 FF 00 01 0C A4 30 00 D1 32 00 01 07 A4 30 00 69 FF'\r\n '00 01 0C A5 30 00 F4 30 00 02 00 A6 30 00 99 30 00 06 33 00 03 0E A6 30 00 A9 30 00 F3 30 00 D2'\r\n '32 00 01 07 A6 30 00 73 FF 00 01 0C A6 30 00 6A FF 00 01 0C A7 30 00 07 33 00 06 0E A8 30 00 B9'\r\n '30 00 AF 30 00 FC 30 00 C8 30 00 99 30 00 08 33 00 04 0E A8 30 00 FC 30 00 AB 30 00 FC 30 00 D3'\r\n '32 00 01 07 A8 30 00 74 FF 00 01 0C A8 30 00 6B FF 00 01 0C A9 30 00 09 33 00 03 0E AA 30 00 F3'\r\n '30 00 B9 30 00 0A 33 00 03 0E AA 30 00 FC 30 00 E0 30 00 D4 32 00 01 07 AA 30 00 75 FF 00 01 0C'\r\n 'AA 30 00 0E 33 00 04 0E AB 30 00 99 30 00 ED 30 00 F3 30 00 0F 33 00 04 0E AB 30 00 99 30 00 F3'\r\n '30 00 DE 30 00 AC 30 00 02 00 AB 30 00 99 30 00 0B 33 00 03 0E AB 30 00 A4 30 00 EA 30 00 0C 33'\r\n '00 04 0E AB 30 00 E9 30 00 C3 30 00 C8 30 00 0D 33 00 04 0E AB 30 00 ED 30 00 EA 30 00 FC 30 00'\r\n '76 FF 00 01 0C AB 30 00 D5 32 00 01 07 AB 30 00 10 33 00 06 0E AD 30 00 99 30 00 AD 30 00 99 30'\r\n '00 AB 30 00 99 30 00 11 33 00 04 0E AD 30 00 99 30 00 CB 30 00 FC 30 00 13 33 00 08 0E AD 30 00'\r\n '99 30 00 EB 30 00 AD 30 00 99 30 00 BF 30 00 99 30 00 FC 30 00 AE 30 00 02 00 AD 30 00 99 30 00'\r\n '12 33 00 04 0E AD 30 00 E5 30 00 EA 30 00 FC 30 00 15 33 00 06 0E AD 30 00 ED 30 00 AF 30 00 99'\r\n '30 00 E9 30 00 E0 30 00 16 33 00 06 0E AD 30 00 ED 30 00 E1 30 00 FC 30 00 C8 30 00 EB 30 00 17'\r\n '33 00 05 0E AD 30 00 ED 30 00 EF 30 00 C3 30 00 C8 30 00 14 33 00 02 0E AD 30 00 ED 30 00 D6 32'\r\n '00 01 07 AD 30 00 77 FF 00 01 0C AD 30 00 19 33 00 06 0E AF 30 00 99 30 00 E9 30 00 E0 30 00 C8'\r\n '30 00 F3 30 00 18 33 00 04 0E AF 30 00 99 30 00 E9 30 00 E0 30 00 B0 30 00 02 00 AF 30 00 99 30'\r\n '00 1A 33 00 06 0E AF 30 00 EB 30 00 BB 30 00 99 30 00 A4 30 00 ED 30 00 1B 33 00 04 0E AF 30 00'\r\n 'ED 30 00 FC 30 00 CD 30 00 D7 32 00 01 07 AF 30 00 78 FF 00 01 0C AF 30 00 B2 30 00 02 00 B1 30'\r\n '00 99 30 00 1C 33 00 03 0E B1 30 00 FC 30 00 B9 30 00 D8 32 00 01 07 B1 30 00 79 FF 00 01 0C B1'\r\n '30 00 B4 30 00 02 00 B3 30 00 99 30 00 01 F2 01 02 0E B3 30 00 B3 30 00 FF 30 00 02 0A B3 30 00'\r\n 'C8 30 00 1D 33 00 03 0E B3 30 00 EB 30 00 CA 30 00 1E 33 00 04 0E B3 30 00 FC 30 00 DB 30 00 9A'\r\n '30 00 D9 32 00 01 07 B3 30 00 7A FF 00 01 0C B3 30 00 B6 30 00 02 00 B5 30 00 99 30 00 1F 33 00'\r\n '04 0E B5 30 00 A4 30 00 AF 30 00 EB 30 00 20 33 00 05 0E B5 30 00 F3 30 00 C1 30 00 FC 30 00 E0'\r\n '30 00 7B FF 00 01 0C B5 30 00 02 F2 01 01 0E B5 30 00 DA 32 00 01 07 B5 30 00 B8 30 00 02 00 B7'\r\n '30 00 99 30 00 21 33 00 05 0E B7 30 00 EA 30 00 F3 30 00 AF 30 00 99 30 00 7C FF 00 01 0C B7 30'\r\n '00 DB 32 00 01 07 B7 30 00 BA 30 00 02 00 B9 30 00 99 30 00 7D FF 00 01 0C B9 30 00 DC 32 00 01'\r\n '07 B9 30 00 BC 30 00 02 00 BB 30 00 99 30 00 22 33 00 03 0E BB 30 00 F3 30 00 C1 30 00 23 33 00'\r\n '03 0E BB 30 00 F3 30 00 C8 30 00 DD 32 00 01 07 BB 30 00 7E FF 00 01 0C BB 30 00 BE 30 00 02 00'\r\n 'BD 30 00 99 30 00 7F FF 00 01 0C BD 30 00 DE 32 00 01 07 BD 30 00 24 33 00 04 0E BF 30 00 99 30'\r\n '00 FC 30 00 B9 30 00 C0 30 00 02 00 BF 30 00 99 30 00 DF 32 00 01 07 BF 30 00 80 FF 00 01 0C BF'\r\n '30 00 C2 30 00 02 00 C1 30 00 99 30 00 E0 32 00 01 07 C1 30 00 81 FF 00 01 0C C1 30 00 6F FF 00'\r\n '01 0C C3 30 00 C5 30 00 02 00 C4 30 00 99 30 00 82 FF 00 01 0C C4 30 00 E1 32 00 01 07 C4 30 00'\r\n '25 33 00 03 0E C6 30 00 99 30 00 B7 30 00 C7 30 00 02 00 C6 30 00 99 30 00 13 F2 01 02 0E C6 30'\r\n '00 99 30 00 E2 32 00 01 07 C6 30 00 83 FF 00 01 0C C6 30 00 26 33 00 03 0E C8 30 00 99 30 00 EB'\r\n '30 00 C9 30 00 02 00 C8 30 00 99 30 00 27 33 00 02 0E C8 30 00 F3 30 00 84 FF 00 01 0C C8 30 00'\r\n 'E3 32 00 01 07 C8 30 00 28 33 00 02 0E CA 30 00 CE 30 00 85 FF 00 01 0C CA 30 00 E4 32 00 01 07'\r\n 'CA 30 00 86 FF 00 01 0C CB 30 00 E5 32 00 01 07 CB 30 00 87 FF 00 01 0C CC 30 00 E6 32 00 01 07'\r\n 'CC 30 00 E7 32 00 01 07 CD 30 00 88 FF 00 01 0C CD 30 00 29 33 00 03 0E CE 30 00 C3 30 00 C8 30'\r\n '00 89 FF 00 01 0C CE 30 00 E8 32 00 01 07 CE 30 00 2D 33 00 05 0E CF 30 00 99 30 00 FC 30 00 EC'\r\n '30 00 EB 30 00 D0 30 00 02 00 CF 30 00 99 30 00 2B 33 00 06 0E CF 30 00 9A 30 00 FC 30 00 BB 30'\r\n '00 F3 30 00 C8 30 00 2C 33 00 04 0E CF 30 00 9A 30 00 FC 30 00 C4 30 00 D1 30 00 02 00 CF 30 00'\r\n '9A 30 00 2A 33 00 03 0E CF 30 00 A4 30 00 C4 30 00 8A FF 00 01 0C CF 30 00 E9 32 00 01 07 CF 30'\r\n '00 31 33 00 03 0E D2 30 00 99 30 00 EB 30 00 D3 30 00 02 00 D2 30 00 99 30 00 2E 33 00 06 0E D2'\r\n '30 00 9A 30 00 A2 30 00 B9 30 00 C8 30 00 EB 30 00 2F 33 00 04 0E D2 30 00 9A 30 00 AF 30 00 EB'\r\n '30 00 30 33 00 03 0E D2 30 00 9A 30 00 B3 30 00 D4 30 00 02 00 D2 30 00 9A 30 00 8B FF 00 01 0C'\r\n 'D2 30 00 EA 32 00 01 07 D2 30 00 34 33 00 06 0E D5 30 00 99 30 00 C3 30 00 B7 30 00 A7 30 00 EB'\r\n '30 00 D6 30 00 02 00 D5 30 00 99 30 00 D7 30 00 02 00 D5 30 00 9A 30 00 32 33 00 06 0E D5 30 00'\r\n 'A1 30 00 E9 30 00 C3 30 00 C8 30 00 99 30 00 33 33 00 04 0E D5 30 00 A3 30 00 FC 30 00 C8 30 00'\r\n '35 33 00 03 0E D5 30 00 E9 30 00 F3 30 00 8C FF 00 01 0C D5 30 00 EB 32 00 01 07 D5 30 00 3C 33'\r\n '00 04 0E D8 30 00 99 30 00 FC 30 00 BF 30 00 D9 30 00 02 00 D8 30 00 99 30 00 37 33 00 03 0E D8'\r\n '30 00 9A 30 00 BD 30 00 38 33 00 04 0E D8 30 00 9A 30 00 CB 30 00 D2 30 00 3A 33 00 04 0E D8 30'\r\n '00 9A 30 00 F3 30 00 B9 30 00 3B 33 00 07 0E D8 30 00 9A 30 00 FC 30 00 D8 30 00 9A 30 00 B7 30'\r\n '00 99 30 00 DA 30 00 02 00 D8 30 00 9A 30 00 36 33 00 05 0E D8 30 00 AF 30 00 BF 30 00 FC 30 00'\r\n 'EB 30 00 39 33 00 03 0E D8 30 00 EB 30 00 C4 30 00 EC 32 00 01 07 D8 30 00 8D FF 00 01 0C D8 30'\r\n '00 3E 33 00 04 0E DB 30 00 99 30 00 EB 30 00 C8 30 00 DC 30 00 02 00 DB 30 00 99 30 00 3D 33 00'\r\n '05 0E DB 30 00 9A 30 00 A4 30 00 F3 30 00 C8 30 00 40 33 00 07 0E DB 30 00 9A 30 00 F3 30 00 DB'\r\n '30 00 9A 30 00 C8 30 00 99 30 00 DD 30 00 02 00 DB 30 00 9A 30 00 3F 33 00 02 0E DB 30 00 F3 30'\r\n '00 41 33 00 03 0E DB 30 00 FC 30 00 EB 30 00 42 33 00 03 0E DB 30 00 FC 30 00 F3 30 00 8E FF 00'\r\n '01 0C DB 30 00 ED 32 00 01 07 DB 30 00 43 33 00 04 0E DE 30 00 A4 30 00 AF 30 00 ED 30 00 44 33'\r\n '00 03 0E DE 30 00 A4 30 00 EB 30 00 45 33 00 03 0E DE 30 00 C3 30 00 CF 30 00 46 33 00 03 0E DE'\r\n '30 00 EB 30 00 AF 30 00 47 33 00 05 0E DE 30 00 F3 30 00 B7 30 00 E7 30 00 F3 30 00 EE 32 00 01'\r\n '07 DE 30 00 8F FF 00 01 0C DE 30 00 48 33 00 04 0E DF 30 00 AF 30 00 ED 30 00 F3 30 00 4A 33 00'\r\n '06 0E DF 30 00 EA 30 00 CF 30 00 99 30 00 FC 30 00 EB 30 00 49 33 00 02 0E DF 30 00 EA 30 00 EF'\r\n '32 00 01 07 DF 30 00 90 FF 00 01 0C DF 30 00 91 FF 00 01 0C E0 30 00 F0 32 00 01 07 E0 30 00 4C'\r\n '33 00 05 0E E1 30 00 AB 30 00 99 30 00 C8 30 00 F3 30 00 4B 33 00 03 0E E1 30 00 AB 30 00 99 30'\r\n '00 4D 33 00 04 0E E1 30 00 FC 30 00 C8 30 00 EB 30 00 F1 32 00 01 07 E1 30 00 92 FF 00 01 0C E1'\r\n '30 00 93 FF 00 01 0C E2 30 00 F2 32 00 01 07 E2 30 00 6C FF 00 01 0C E3 30 00 4E 33 00 04 0E E4'\r\n '30 00 FC 30 00 C8 30 00 99 30 00 4F 33 00 03 0E E4 30 00 FC 30 00 EB 30 00 F3 32 00 01 07 E4 30'\r\n '00 94 FF 00 01 0C E4 30 00 6D FF 00 01 0C E5 30 00 50 33 00 03 0E E6 30 00 A2 30 00 F3 30 00 95'\r\n 'FF 00 01 0C E6 30 00 F4 32 00 01 07 E6 30 00 6E FF 00 01 0C E7 30 00 96 FF 00 01 0C E8 30 00 F5'\r\n '32 00 01 07 E8 30 00 97 FF 00 01 0C E9 30 00 F6 32 00 01 07 E9 30 00 51 33 00 04 0E EA 30 00 C3'\r\n '30 00 C8 30 00 EB 30 00 52 33 00 02 0E EA 30 00 E9 30 00 98 FF 00 01 0C EA 30 00 F7 32 00 01 07'\r\n 'EA 30 00 53 33 00 04 0E EB 30 00 D2 30 00 9A 30 00 FC 30 00 54 33 00 05 0E EB 30 00 FC 30 00 D5'\r\n '30 00 99 30 00 EB 30 00 99 FF 00 01 0C EB 30 00 F8 32 00 01 07 EB 30 00 55 33 00 02 0E EC 30 00'\r\n 'E0 30 00 56 33 00 06 0E EC 30 00 F3 30 00 C8 30 00 B1 30 00 99 30 00 F3 30 00 F9 32 00 01 07 EC'\r\n '30 00 9A FF 00 01 0C EC 30 00 FA 32 00 01 07 ED 30 00 9B FF 00 01 0C ED 30 00 F7 30 00 02 00 EF'\r\n '30 00 99 30 00 57 33 00 03 0E EF 30 00 C3 30 00 C8 30 00 9C FF 00 01 0C EF 30 00 FB 32 00 01 07'\r\n 'EF 30 00 F8 30 00 02 00 F0 30 00 99 30 00 FC 32 00 01 07 F0 30 00 F9 30 00 02 00 F1 30 00 99 30'\r\n '00 FD 32 00 01 07 F1 30 00 FA 30 00 02 00 F2 30 00 99 30 00 66 FF 00 01 0C F2 30 00 FE 32 00 01'\r\n '07 F2 30 00 9D FF 00 01 0C F3 30 00 65 FF 00 01 0C FB 30 00 70 FF 00 01 0C FC 30 00 FE 30 00 02'\r\n '00 FD 30 00 99 30 00 80 32 00 01 07 00 4E 00 00 2F 00 01 10 00 4E 00 92 31 00 01 08 00 4E 00 29'\r\n 'F2 01 01 0E 00 4E 00 9C 31 00 01 08 01 4E 00 86 32 00 01 07 03 4E 00 82 32 00 01 07 09 4E 00 94'\r\n '31 00 01 08 09 4E 00 2A F2 01 01 0E 09 4E 00 A4 32 00 01 07 0A 4E 00 96 31 00 01 08 0A 4E 00 98'\r\n '31 00 01 08 0B 4E 00 A6 32 00 01 07 0B 4E 00 9B 31 00 01 08 19 4E 00 01 2F 00 01 10 28 4E 00 A5'\r\n '32 00 01 07 2D 4E 00 97 31 00 01 08 2D 4E 00 2D F2 01 01 0E 2D 4E 00 02 2F 00 01 10 36 4E 00 03'\r\n '2F 00 01 10 3F 4E 00 04 2F 00 01 10 59 4E 00 9A 31 00 01 08 59 4E 00 88 32 00 01 07 5D 4E 00 05'\r\n '2F 00 01 10 85 4E 00 81 32 00 01 07 8C 4E 00 14 F2 01 01 0E 8C 4E 00 06 2F 00 01 10 8C 4E 00 93'\r\n '31 00 01 08 8C 4E 00 84 32 00 01 07 94 4E 00 07 2F 00 01 10 A0 4E 00 18 F2 01 01 0E A4 4E 00 9F'\r\n '31 00 01 08 BA 4E 00 08 2F 00 01 10 BA 4E 00 AD 32 00 01 07 01 4F 00 A1 32 00 01 07 11 4F 00 9D'\r\n '32 00 01 07 2A 51 00 09 2F 00 01 10 3F 51 00 0A 2F 00 01 10 65 51 00 87 32 00 01 07 6B 51 00 0B'\r\n '2F 00 01 10 6B 51 00 85 32 00 01 07 6D 51 00 0C 2F 00 01 10 82 51 00 1E F2 01 01 0E 8D 51 00 0D'\r\n '2F 00 01 10 96 51 00 A2 32 00 01 07 99 51 00 0E 2F 00 01 10 AB 51 00 0F 2F 00 01 10 E0 51 00 10'\r\n '2F 00 01 10 F5 51 00 11 2F 00 01 10 00 52 00 20 F2 01 01 0E 1D 52 00 1C F2 01 01 0E 4D 52 00 39'\r\n 'F2 01 01 0E 72 52 00 12 2F 00 01 10 9B 52 00 98 32 00 01 07 B4 52 00 13 2F 00 01 10 F9 52 00 14'\r\n '2F 00 01 10 15 53 00 15 2F 00 01 10 1A 53 00 16 2F 00 01 10 38 53 00 A9 32 00 01 07 3B 53 00 38'\r\n '30 00 01 10 41 53 00 17 2F 00 01 10 41 53 00 89 32 00 01 07 41 53 00 39 30 00 01 10 44 53 00 3A'\r\n '30 00 01 10 45 53 00 AF 32 00 01 07 54 53 00 18 2F 00 01 10 5C 53 00 19 2F 00 01 10 69 53 00 9E'\r\n '32 00 01 07 70 53 00 1A 2F 00 01 10 82 53 00 1B 2F 00 01 10 B6 53 00 1C 2F 00 01 10 C8 53 00 12'\r\n 'F2 01 01 0E CC 53 00 1D 2F 00 01 10 E3 53 00 51 F2 01 01 07 EF 53 00 2E F2 01 01 0E F3 53 00 A8'\r\n '32 00 01 07 F3 53 00 34 F2 01 01 0E 08 54 00 94 32 00 01 07 0D 54 00 25 F2 01 01 0E 39 54 00 44'\r\n '32 00 01 07 4F 55 00 3A F2 01 01 0E B6 55 00 1E 2F 00 01 10 D7 56 00 83 32 00 01 07 DB 56 00 95'\r\n '31 00 01 08 DB 56 00 8F 32 00 01 07 1F 57 00 1F 2F 00 01 10 1F 57 00 9E 31 00 01 08 30 57 00 20'\r\n '2F 00 01 10 EB 58 00 24 F2 01 01 0E F0 58 00 21 2F 00 01 10 02 59 00 22 2F 00 01 10 0A 59 00 23'\r\n '2F 00 01 10 15 59 00 15 F2 01 01 0E 1A 59 00 B0 32 00 01 07 1C 59 00 7D 33 00 02 0E 27 59 00 63'\r\n '6B 00 24 2F 00 01 10 27 59 00 17 F2 01 01 0E 29 59 00 9D 31 00 01 08 29 59 00 9B 32 00 01 07 73'\r\n '59 00 25 2F 00 01 10 73 59 00 26 2F 00 01 10 50 5B 00 11 F2 01 01 0E 57 5B 00 AB 32 00 01 07 66'\r\n '5B 00 27 2F 00 01 10 80 5B 00 AA 32 00 01 07 97 5B 00 28 2F 00 01 10 F8 5B 00 29 2F 00 01 10 0F'\r\n '5C 00 2A 2F 00 01 10 22 5C 00 2B 2F 00 01 10 38 5C 00 2C 2F 00 01 10 6E 5C 00 2D 2F 00 01 10 71'\r\n '5C 00 2E 2F 00 01 10 DB 5D 00 2F 2F 00 01 10 E5 5D 00 2C F2 01 01 0E E6 5D 00 A7 32 00 01 07 E6'\r\n '5D 00 30 2F 00 01 10 F1 5D 00 31 2F 00 01 10 FE 5D 00 32 2F 00 01 10 72 5E 00 7B 33 00 02 0E 73'\r\n '5E 00 10 62 00 33 2F 00 01 10 7A 5E 00 45 32 00 01 07 7C 5E 00 34 2F 00 01 10 7F 5E 00 35 2F 00'\r\n '01 10 F4 5E 00 36 2F 00 01 10 FE 5E 00 37 2F 00 01 10 0B 5F 00 38 2F 00 01 10 13 5F 00 39 2F 00'\r\n '01 10 50 5F 00 3A 2F 00 01 10 61 5F 00 3B 2F 00 01 10 73 5F 00 1D F2 01 01 0E 8C 5F 00 50 F2 01'\r\n '01 07 97 5F 00 3C 2F 00 01 10 C3 5F 00 3D 2F 00 01 10 08 62 00 3E 2F 00 01 10 36 62 00 3F 2F 00'\r\n '01 10 4B 62 00 10 F2 01 01 0E 4B 62 00 31 F2 01 01 0E 53 62 00 27 F2 01 01 0E 95 62 00 2F F2 01'\r\n '01 0E 07 63 00 28 F2 01 01 0E 55 63 00 40 2F 00 01 10 2F 65 00 41 2F 00 01 10 34 65 00 46 32 00'\r\n '01 07 87 65 00 42 2F 00 01 10 87 65 00 43 2F 00 01 10 97 65 00 1B F2 01 01 0E 99 65 00 44 2F 00'\r\n '01 10 A4 65 00 1F F2 01 01 0E B0 65 00 45 2F 00 01 10 B9 65 00 46 2F 00 01 10 E0 65 00 47 2F 00'\r\n '01 10 E5 65 00 90 32 00 01 07 E5 65 00 7E 33 00 02 0E 0E 66 00 BB 6C 00 19 F2 01 01 0E 20 66 00'\r\n '7C 33 00 02 0E 2D 66 00 8C 54 00 48 2F 00 01 10 F0 66 00 37 F2 01 01 0E 08 67 00 49 2F 00 01 10'\r\n '08 67 00 8A 32 00 01 07 08 67 00 36 F2 01 01 0E 09 67 00 92 32 00 01 07 09 67 00 8D 32 00 01 07'\r\n '28 67 00 4A 2F 00 01 10 28 67 00 7F 33 00 04 0E 2A 68 00 0F 5F 00 1A 4F 00 3E 79 00 91 32 00 01'\r\n '07 2A 68 00 4B 2F 00 01 10 20 6B 00 4C 2F 00 01 10 62 6B 00 A3 32 00 01 07 63 6B 00 4D 2F 00 01'\r\n '10 79 6B 00 4E 2F 00 01 10 B3 6B 00 4F 2F 00 01 10 CB 6B 00 9F 2E 00 01 10 CD 6B 00 50 2F 00 01'\r\n '10 D4 6B 00 51 2F 00 01 10 DB 6B 00 52 2F 00 01 10 0F 6C 00 53 2F 00 01 10 14 6C 00 8C 32 00 01'\r\n '07 34 6C 00 54 2F 00 01 10 34 6C 00 9F 32 00 01 07 E8 6C 00 35 F2 01 01 0E 80 6E 00 26 F2 01 01'\r\n '0E 14 6F 00 8B 32 00 01 07 6B 70 00 55 2F 00 01 10 6B 70 00 1A F2 01 01 0E 21 71 00 56 2F 00 01'\r\n '10 2A 72 00 57 2F 00 01 10 36 72 00 58 2F 00 01 10 3B 72 00 59 2F 00 01 10 3F 72 00 5A 2F 00 01'\r\n '10 47 72 00 5B 2F 00 01 10 59 72 00 5C 2F 00 01 10 5B 72 00 95 32 00 01 07 79 72 00 5D 2F 00 01'\r\n '10 AC 72 00 5E 2F 00 01 10 84 73 00 5F 2F 00 01 10 89 73 00 60 2F 00 01 10 DC 74 00 61 2F 00 01'\r\n '10 E6 74 00 62 2F 00 01 10 18 75 00 63 2F 00 01 10 1F 75 00 22 F2 01 01 0E 1F 75 00 64 2F 00 01'\r\n '10 28 75 00 65 2F 00 01 10 30 75 00 99 31 00 01 08 32 75 00 38 F2 01 01 0E 33 75 00 9A 32 00 01'\r\n '07 37 75 00 66 2F 00 01 10 8B 75 00 67 2F 00 01 10 92 75 00 68 2F 00 01 10 76 76 00 69 2F 00 01'\r\n '10 7D 76 00 6A 2F 00 01 10 AE 76 00 6B 2F 00 01 10 BF 76 00 AC 32 00 01 07 E3 76 00 6C 2F 00 01'\r\n '10 EE 76 00 6D 2F 00 01 10 DB 77 00 6E 2F 00 01 10 E2 77 00 6F 2F 00 01 10 F3 77 00 70 2F 00 01'\r\n '10 3A 79 00 93 32 00 01 07 3E 79 00 97 32 00 01 07 5D 79 00 32 F2 01 01 0E 81 79 00 71 2F 00 01'\r\n '10 B8 79 00 72 2F 00 01 10 BE 79 00 99 32 00 01 07 D8 79 00 73 2F 00 01 10 74 7A 00 33 F2 01 01'\r\n '0E 7A 7A 00 74 2F 00 01 10 CB 7A 00 75 2F 00 01 10 F9 7A 00 47 32 00 01 07 8F 7B 00 76 2F 00 01'\r\n '10 73 7C 00 77 2F 00 01 10 F8 7C 00 21 F2 01 01 0E 42 7D 00 78 2F 00 01 10 36 7F 00 79 2F 00 01'\r\n '10 51 7F 00 7A 2F 00 01 10 8A 7F 00 7B 2F 00 01 10 BD 7F 00 7C 2F 00 01 10 01 80 00 7D 2F 00 01'\r\n '10 0C 80 00 7E 2F 00 01 10 12 80 00 7F 2F 00 01 10 33 80 00 80 2F 00 01 10 7F 80 00 81 2F 00 01'\r\n '10 89 80 00 82 2F 00 01 10 E3 81 00 83 2F 00 01 10 EA 81 00 84 2F 00 01 10 F3 81 00 85 2F 00 01'\r\n '10 FC 81 00 86 2F 00 01 10 0C 82 00 87 2F 00 01 10 1B 82 00 88 2F 00 01 10 1F 82 00 89 2F 00 01'\r\n '10 6E 82 00 8A 2F 00 01 10 72 82 00 8B 2F 00 01 10 78 82 00 8C 2F 00 01 10 4D 86 00 8D 2F 00 01'\r\n '10 6B 86 00 8E 2F 00 01 10 40 88 00 8F 2F 00 01 10 4C 88 00 90 2F 00 01 10 63 88 00 91 2F 00 01'\r\n '10 7E 89 00 92 2F 00 01 10 8B 89 00 93 2F 00 01 10 D2 89 00 16 F2 01 01 0E E3 89 00 94 2F 00 01'\r\n '10 00 8A 00 95 2F 00 01 10 37 8C 00 96 2F 00 01 10 46 8C 00 97 2F 00 01 10 55 8C 00 98 2F 00 01'\r\n '10 78 8C 00 99 2F 00 01 10 9D 8C 00 96 32 00 01 07 A1 8C 00 23 F2 01 01 0E A9 8C 00 AE 32 00 01'\r\n '07 C7 8C 00 9A 2F 00 01 10 64 8D 00 30 F2 01 01 0E 70 8D 00 9B 2F 00 01 10 70 8D 00 9C 2F 00 01'\r\n '10 B3 8D 00 9D 2F 00 01 10 AB 8E 00 9E 2F 00 01 10 CA 8E 00 9F 2F 00 01 10 9B 8F 00 A0 2F 00 01'\r\n '10 B0 8F 00 A1 2F 00 01 10 B5 8F 00 2B F2 01 01 0E 4A 90 00 9C 32 00 01 07 69 90 00 A2 2F 00 01'\r\n '10 91 90 00 A3 2F 00 01 10 49 91 00 A4 2F 00 01 10 C6 91 00 A5 2F 00 01 10 CC 91 00 8E 32 00 01'\r\n '07 D1 91 00 A6 2F 00 01 10 D1 91 00 A7 2F 00 01 10 77 95 00 A8 2F 00 01 10 80 95 00 A9 2F 00 01'\r\n '10 1C 96 00 AA 2F 00 01 10 B6 96 00 AB 2F 00 01 10 B9 96 00 AC 2F 00 01 10 E8 96 00 AD 2F 00 01'\r\n '10 51 97 00 AE 2F 00 01 10 5E 97 00 AF 2F 00 01 10 62 97 00 B0 2F 00 01 10 69 97 00 B1 2F 00 01'\r\n '10 CB 97 00 B2 2F 00 01 10 ED 97 00 B3 2F 00 01 10 F3 97 00 B4 2F 00 01 10 01 98 00 A0 32 00 01'\r\n '07 05 98 00 B5 2F 00 01 10 A8 98 00 B6 2F 00 01 10 DB 98 00 B7 2F 00 01 10 DF 98 00 B8 2F 00 01'\r\n '10 96 99 00 B9 2F 00 01 10 99 99 00 BA 2F 00 01 10 AC 99 00 BB 2F 00 01 10 A8 9A 00 BC 2F 00 01'\r\n '10 D8 9A 00 BD 2F 00 01 10 DF 9A 00 BE 2F 00 01 10 25 9B 00 BF 2F 00 01 10 2F 9B 00 C0 2F 00 01'\r\n '10 32 9B 00 C1 2F 00 01 10 3C 9B 00 C2 2F 00 01 10 5A 9B 00 C3 2F 00 01 10 E5 9C 00 C4 2F 00 01'\r\n '10 75 9E 00 C5 2F 00 01 10 7F 9E 00 C6 2F 00 01 10 A5 9E 00 C7 2F 00 01 10 BB 9E 00 C8 2F 00 01'\r\n '10 C3 9E 00 C9 2F 00 01 10 CD 9E 00 CA 2F 00 01 10 D1 9E 00 CB 2F 00 01 10 F9 9E 00 CC 2F 00 01'\r\n '10 FD 9E 00 CD 2F 00 01 10 0E 9F 00 CE 2F 00 01 10 13 9F 00 CF 2F 00 01 10 20 9F 00 D0 2F 00 01'\r\n '10 3B 9F 00 D1 2F 00 01 10 4A 9F 00 D2 2F 00 01 10 52 9F 00 D3 2F 00 01 10 8D 9F 00 D4 2F 00 01'\r\n '10 9C 9F 00 F3 2E 00 01 10 9F 9F 00 D5 2F 00 01 10 A0 9F 00 70 A7 00 01 08 6F A7 00 9A 10 01 02'\r\n '00 99 10 01 BA 10 01 9C 10 01 02 00 9B 10 01 BA 10 01 AB 10 01 02 00 A5 10 01 BA 10 01'\r\n}\r\n" }, { "path": "External/Jedi/Jcl/source/common/JclUnicodeBzip2.rc", "content": "/****************************************************************************************************\r\n\r\n\r\n ..\\..\\jcl\\source\\common\\JclUnicodeBzip2.rc\r\n\r\n\r\n Produced by UDExtract written by Dipl. Ing. Mike Lischke, public@lischke-online.de\r\n\r\n\r\n****************************************************************************************************/\r\n\r\n\r\nLANGUAGE 0,0 CATEGORIES UNICODEDATA LOADONCALL MOVEABLE DISCARDABLE\r\n{\r\n '42 5A 68 39 31 41 59 26 53 59 66 5E E3 3F 00 08 D9 7F FF FF FF FF FF FF FF FF FF FF FF FF FF FF'\r\n 'FF FF FF FF FF FF FF FF FF FF FF FF FF FF FF FF FF FF FF E0 36 FF 6B CA AA 9D F7 87 C4 11 42 45'\r\n '45 10 94 0A 24 A8 04 40 45 41 40 14 0A 02 81 52 48 50 29 4A 0A 12 7C 3C 05 F0 00 1F 4E 0D 35 DB'\r\n '06 45 D6 EE AA CB 91 2E DB 4A D6 D6 57 3B 5A EE 13 A0 AB 9D CE E8 00 DD B4 AD 68 07 6C B6 E8 5B'\r\n '06 9D C6 3A 80 00 00 08 50 34 ED 2E 00 A3 AD 0E 8B EB 38 60 83 51 FA A4 88 99 26 05 1E 9A 35 4F'\r\n '06 81 A2 78 A6 CA 4D 89 EA 6A 78 13 1A 09 EA 4F D2 62 79 13 61 06 05 4F C0 53 F4 01 FA A1 B5 32'\r\n '9A 6A 66 9A 06 93 CD 03 49 8D 4C 18 93 19 31 11 81 A2 62 66 9A 68 46 9A 60 C4 8C C9 A6 9B 53 4D'\r\n 'EA 6A 4D 95 41 25 25 29 EA 69 E3 1A 79 A2 00 41 34 C2 26 99 0D 4D 53 F5 4F CA 83 6A 68 D3 43 40'\r\n '34 00 03 40 34 CD 26 43 D4 1A 06 86 C5 00 00 00 00 D0 00 00 00 00 00 0D 0D 00 D3 40 00 D3 40 02'\r\n '4A 94 A1 E9 E6 C6 22 20 13 20 98 40 D5 3C 24 F0 90 13 4D 00 00 00 00 0D 00 00 00 00 00 00 00 00'\r\n '00 00 00 00 00 00 00 00 00 00 00 06 8D 24 4D 04 68 4A 7B 22 8F 26 93 7A A7 A7 A6 93 68 A6 6D 3C'\r\n '42 7A 6A 62 53 F6 9A 46 4D 4F 29 A8 C3 C2 12 68 31 34 F4 0D 4D E8 9A 6A 6D 26 D2 7A 87 85 3D 13'\r\n 'C2 6D 26 93 35 3D 4D 1A 06 6A 6F 7A A8 19 4F 35 21 EA 68 32 68 DA 9E 90 D3 D4 68 7A 86 47 94 D9'\r\n '27 E5 08 F4 D2 08 94 91 34 83 26 A2 9B D9 1A 4F 14 C4 A7 EA 4F 32 20 D4 F3 53 D3 46 86 98 49 9A'\r\n 'A7 B4 C4 C5 4F DE A9 EA 18 15 3F 04 13 D5 3C C9 4F 7A 91 3D A1 A9 84 C5 3C 53 6D 19 14 CF 54 FD'\r\n '51 B4 CD A2 50 D3 35 3C A1 FA 24 79 A2 9B 29 9E A6 93 F5 13 47 A8 F5 30 C9 36 9E 80 43 4D 18 53'\r\n 'F5 41 24 82 26 40 11 94 C0 4D 4D 53 FD 4D A2 69 9A 89 B2 6A 6C 09 A9 E2 9E A9 FA 7A 54 FD 26 A6'\r\n 'F4 64 9E 91 E4 53 F2 28 DB 44 F2 19 34 34 6A 8F D5 3C 64 D5 3F 15 07 E8 91 E9 3D 4F 53 D4 F2 6A'\r\n '64 D8 A3 DA A7 B5 43 D1 3D 46 8C 64 CA 7A 69 EA 9B D4 33 44 D3 D4 DA 4F 35 0A 7E 29 0F D1 A9 99'\r\n '42 7A 9E 84 B4 E1 23 3A 49 11 C1 F8 53 97 E8 1B 5E DB C9 6E E7 A9 6C CE A5 3D 2E 5C 2C 74 59 5F'\r\n '33 6B 83 52 A5 EF 49 B1 FA B5 BF 65 AF 7D 9A 6C EE E4 D1 31 84 7B 96 5D 6F CF E2 E0 F8 AE 8F 3D'\r\n 'C5 87 6F 1E BE 2F B1 C9 CA DE BB EB 5D 6E 8C BA 6F 9B A2 83 3B EB DE 76 C2 65 F0 B3 E0 E1 C9 82'\r\n 'DA 34 AD 88 2B 2B 24 BF 53 CB B6 31 EB EB 3A B4 2E 3C 98 64 7C 81 D2 5D 4A 79 10 9F 27 DF 31 1C'\r\n 'E2 E3 9A 9D 9C 98 7C C2 9A BC 9A 54 55 F3 A1 6B D2 C1 22 F9 94 53 50 D8 8A 39 C9 4F 98 A2 94 24'\r\n 'AD 95 90 CA 66 5A 01 47 66 8E 92 15 80 B4 0B 21 E4 2D 9F 52 AB 6B 6A 81 43 A7 AA DB 3C 94 0D 7B'\r\n '06 19 C7 25 4B 74 52 48 B0 C9 5D 49 A3 A2 50 8C 62 E6 3F 61 44 AE F7 45 8D 19 17 49 18 11 64 6D'\r\n '2C 19 78 85 D2 19 A3 A3 01 6E DC F6 5C 80 FC 55 1D 36 CE A8 8C 76 D3 21 7D 4C B8 0B 1A FC 69 07'\r\n '6B 19 9A 93 48 25 03 D4 86 EB 41 9C 51 A7 7D DA 1A B1 9B B5 A2 F2 3D B2 99 3F 64 AB 3D C9 FD BA'\r\n 'AB 0E 98 ED EB F7 04 3B 97 18 37 B3 D1 02 23 8C 76 D3 24 F3 C0 86 23 BB E1 FB CC DE 63 40 29 38'\r\n '5B 5E 88 56 57 29 EF 7A A8 97 54 F0 6E 63 81 54 FC 58 DD 33 D7 4A DB 03 CA 73 66 73 1B D3 51 4A'\r\n '27 F8 F3 EC 51 E6 0F 2D 79 67 D5 8B 3C 3C 13 EB 27 AE 92 8E 7F 1A 40 82 B0 C7 F9 AA 64 D2 25 3E'\r\n '4E 23 E3 CB 11 E8 86 FD 94 2E 02 F0 31 23 83 02 E9 9A 54 1C 10 A9 C2 49 01 B1 07 41 16 2B ED 57'\r\n '3D F3 41 E9 A5 8D 3D 8F 62 7D 93 55 21 1F B4 61 AB BA 4C 4E F2 3C D4 93 79 A4 68 1C FD 57 B9 BE'\r\n 'DF 43 42 7F 3E 87 A5 BE 9F 3F 0F 4F 59 29 C0 A8 5D 70 57 04 62 83 BD 8F 62 B7 0E 38 9C 57 71 EE'\r\n '5D C9 6B 89 BD CF 7F 98 0A AB F4 AE 83 9E 7F F0 A7 75 F0 D9 5B 1F DC DB 3C 72 6E 21 B7 04 DE D8'\r\n '65 EE 22 C6 E5 99 23 97 8F 63 54 92 4A 49 99 17 A4 1C FA C7 DE A4 98 F3 31 C3 D2 06 C3 5E D9 7A'\r\n '67 BD 74 EF 4C FD 26 E3 56 F1 18 D3 99 7B 97 B2 0B E2 16 0B A2 AB E2 F4 EC 2B DF 5E AF 20 3D 15'\r\n 'C6 FF 9A 3D F7 05 35 DE 37 8D 37 BB 9E EB ED DC 08 8B 13 45 11 37 12 3C 75 BF 34 82 41 B8 28 0D'\r\n '61 E8 EA E8 F3 96 15 AF 84 B2 AA 8A 4B 69 AA 35 0E 71 51 41 E3 F6 3E 3C 78 F1 FE 88 CA 73 BC C9'\r\n '3C E4 E4 E4 E5 85 B6 CC EB 5C E2 D2 B1 A0 43 CD D8 C8 F8 EF 35 14 5A 44 8A 89 12 2B C8 CE E9 BC'\r\n '88 1E 8E E6 18 D5 D4 D0 9E 10 3D C1 37 74 1D BE A2 6F C4 D8 31 2E 58 C1 6D D9 14 BC AD 9B D6 54'\r\n '21 42 80 BA 07 37 9C E7 A3 E9 21 50 E7 0D 03 DD CF BC 73 A8 A2 50 88 21 78 D4 53 26 A6 4D 12 F4'\r\n '1A 95 28 AF 3C 8A 25 42 85 8D 1C EA 0B 15 34 AE BE 0B 4E 00 C6 95 55 52 A8 A9 7D 4A F9 17 17 76'\r\n '18 DE DE A6 B2 85 0F 40 C6 61 C7 43 39 C1 95 64 CA A8 37 2D CB 72 C3 C1 CD 34 95 65 26 FF 83 81'\r\n '49 5F 9E EC 58 16 12 F1 7C 57 6C 2E 2D B9 C1 38 5C 5C 5A 5A 8B 77 EA CE 52 4E B3 52 C0 C4 17 88'\r\n 'F7 B9 CB 11 F0 50 14 37 9D 9D 86 9B 32 B9 78 58 28 9E 40 EC C5 07 17 1E 40 F2 93 95 55 E5 33 64'\r\n 'AE B3 CE EF 69 F8 73 D6 0F 85 DF 77 10 4F 87 32 BF CB F7 E6 14 02 23 A4 79 8C E6 70 E4 5D 85 CE'\r\n 'AE 27 EF BD 17 73 D8 B9 83 D6 F2 AD A3 13 26 73 84 C4 01 F0 71 05 05 B1 6C 5E 4A DB B1 D4 94 EF'\r\n '19 26 94 48 91 37 D5 BE 5C 9A 6E 99 94 8C C6 63 31 98 82 0D 48 E9 8B B9 7C ED 81 D5 46 4C 31 43'\r\n '42 D0 BB 67 A4 23 A4 A9 15 2A 3E D7 1C 71 CD AB 6A 6C D4 28 29 CE 5E 10 D2 8A 14 28 34 89 12 09'\r\n '68 D1 40 F2 5A 64 C9 9C 86 65 35 BB B7 76 77 49 E8 55 B7 8B 99 86 18 D6 79 D1 8F 37 E7 19 96 4E'\r\n '9C 84 F3 FA E6 75 B2 C5 02 04 0A 78 2E 3C 91 87 A7 D9 0D E8 10 35 98 06 B8 41 40 82 B1 AA FF 28'\r\n 'DC B6 58 DA 17 C1 71 76 0B 25 47 7D F4 E3 9C 1E 12 A6 A3 49 D7 55 D5 62 55 2A 15 A9 74 23 5A DF'\r\n '2A 54 73 AC 46 8B 8A 8C 78 5F 67 9E 72 07 07 07 1C B9 C7 49 8C 30 B8 71 A6 4C 26 A6 48 99 9C A1'\r\n '25 BF 79 79 D3 E7 7C 54 45 3E 1B 22 64 C3 14 26 70 05 16 A0 CD 30 9A 9C F7 F9 F8 90 C8 61 93 19'\r\n 'D6 19 8A 97 90 60 33 DF E3 C1 C3 DE 6A 4E 64 C9 86 4C 98 2D 66 19 4A 92 10 38 F9 20 3D 3D 0F 11'\r\n 'C2 F4 3C 7A D5 CA 1A 42 D6 62 E0 E1 BA 27 2C 82 41 6D AB 75 37 2A 8D 7C 96 3A C3 5A 46 B3 59 AC'\r\n 'CC 58 E1 B1 9B 05 09 C9 EF 35 15 0A 14 5A 58 CF B6 34 46 DA 5D E6 FE 26 A3 AC D0 41 07 29 5E 1D'\r\n '78 18 15 AC 57 7F D0 E2 11 A6 11 04 10 1D C1 CD F7 03 38 6B 20 73 38 CC 19 19 30 C3 14 28 19 E0'\r\n 'A1 42 9E 78 6D 0E 30 C9 8E 68 E6 F2 B6 10 3C 08 0A 41 69 E1 AA 48 91 22 B4 28 C5 66 92 91 22 5C'\r\n 'FC B3 5A 4A 46 BA 15 01 62 C5 91 57 13 A7 22 81 E4 AF 25 77 D7 8F 10 44 4A E2 12 D3 52 A7 98 BB'\r\n 'D1 8D 2B A0 E0 49 86 27 63 37 96 CE C3 10 E1 71 04 38 CC CB 02 21 B9 73 6D A0 D4 5F E1 F0 D2 64'\r\n '54 94 98 2C 16 0B BB AE 82 5C 0E 54 2A 26 72 96 C7 4A 52 25 26 38 90 C3 17 D8 58 1B B9 7B B1 1B'\r\n '85 D6 44 EA C1 B5 3A 2B 5A E0 41 02 07 1D A3 C7 ED 73 C7 F0 5D 0C 66 F0 18 8C 44 CF 1B 36 5C 6E'\r\n '2F F1 EE BC 2F C3 A7 B8 A8 6C F3 FC 1E A4 6F 49 05 4A 8E E3 F9 17 27 BA E0 6D 47 4A CE 6F 8E 9C'\r\n 'AF 29 CD CC B7 62 03 2B 9C 65 2C EE 8F 39 F2 1C EE 49 91 67 5E 06 D8 CE 46 24 54 5C C9 0C 26 19'\r\n '87 E0 4C 75 D7 5D 77 0D 5B 42 FB 0B 3B 76 96 DB 6D F6 1E 05 A3 AE B8 5D 7B 8B 6E 34 A3 B4 8B CB'\r\n 'CE CA EC 9D 25 85 81 41 61 59 03 53 45 D1 5B 07 3B 56 1B 3C 7E 53 05 81 C4 B8 95 8B 58 B1 62 55'\r\n '61 B3 B0 30 C6 67 07 5D BE EA D1 65 D9 B5 8E 93 A7 13 1D 6B AB D2 67 33 9E 46 60 CC 62 38 E9 DB'\r\n 'BF 70 E3 97 A7 39 4C 5C 73 4B 9A 16 85 A1 40 78 AB 74 22 14 11 BD 9F 5D 4E 05 53 AB 6B 2B 16 44'\r\n '06 DA 84 67 B9 CA 95 CF 5D 75 0A 95 AA F2 42 C5 8D 96 45 88 82 0E B5 5D C7 1C A1 4C 55 03 18 AF'\r\n '58 8C 58 98 C4 18 8D EA 71 C0 32 10 09 D6 6E 73 A8 E0 CE 32 C1 60 A4 12 25 75 07 00 61 40 44 BA'\r\n '82 80 91 24 48 93 2D 0B 42 DF 83 4C C5 FC CC 32 20 3E D5 02 A7 21 25 62 D6 47 8D 0E B4 28 41 C2'\r\n '41 10 B3 C1 04 10 95 14 10 47 4D C6 FD A4 CE 56 B9 C9 86 20 42 4C 36 F0 E6 5C 6C 98 CC 11 59 53'\r\n '0D 04 F5 E0 54 8B 01 81 98 20 3C 7D 6F 4F 1E 9E 63 15 2A 04 29 06 29 08 CC E4 44 88 44 88 C3 03'\r\n '34 A3 12 20 77 37 B9 5D 7D 25 23 BC 19 8A 51 E5 AA 2A E9 E9 A4 33 AA 0A 15 E5 27 26 2A 54 14 89'\r\n '13 3A 0E 61 9D D6 4C CB AA 27 3B A4 66 58 19 8A 43 36 63 15 65 67 22 EE F2 77 9C B5 17 17 6A 57'\r\n 'B9 CB D5 D7 78 EA A9 67 35 2E C2 D0 19 8C E8 90 66 30 39 E7 CD 86 18 60 A9 54 9D 63 98 D4 BB 52'\r\n '90 C0 C6 FB 6F 3A 04 09 D4 6F 9C 9C A8 E8 F0 E7 27 3C 22 72 6A 7A 38 CE 4E 47 1D 0E 67 3A 61 C7'\r\n '1C 31 08 20 7D 4B 50 72 AA C0 75 4A A7 8F BD C6 92 F2 A6 18 61 81 90 C5 59 A4 41 E0 F7 9C 60 F4'\r\n '3D 1D EA A0 40 81 97 74 E3 C7 D4 AA 0E BF 1C 55 92 89 D3 15 1B D9 86 3B 05 81 23 8E 24 4C 9C 6B'\r\n '38 49 B4 A6 20 19 CB 61 DC 61 86 20 0F 79 53 C1 E2 B0 39 18 3E 71 40 CE 0D 9E 08 1D 70 C2 8B AE'\r\n '20 CE BB 9D C5 42 6B 72 35 1B A8 C5 C3 50 A1 CE 72 2C EB 32 BA E8 AD DE 6D 40 EB A5 3B 8E 30 C7'\r\n '71 CD 8B 62 33 9D 0A 54 28 4C 99 D7 28 A8 66 B2 C7 8C 23 10 D3 8C AB 25 5A 74 9E 34 DA 06 18 64'\r\n 'F6 18 C5 72 88 44 22 28 A8 B9 C4 4B 8B 95 EB AA A3 40 63 AC A2 44 89 0A 59 C2 82 85 25 04 41 64'\r\n '3B 78 D5 46 33 19 79 7C BB 53 27 33 87 A3 36 68 1D 60 74 41 07 5F 12 C4 1D FA AA C6 A5 5F 07 29'\r\n '85 8D 81 6C 4D 2A C2 4A 44 8B 8E 5D 3D 80 E1 AB BC EA D5 75 D6 6A 17 49 13 82 F7 BC 79 97 19 8C'\r\n 'DD CA 48 91 23 AD D9 CE 4C 99 3F 26 EA 63 70 98 C0 A2 A1 44 5E 5E 65 47 51 63 8E DC 86 41 8C A6'\r\n '52 62 CA 65 CB D6 5C 72 09 12 2D 22 44 89 12 7E D2 ED F6 41 93 1C A9 C7 2A 30 C3 0C 32 63 49 61'\r\n '80 E6 11 A8 71 81 8E 40 CC 78 60 82 14 0E 3F 84 85 8A 6C 44 EE 53 11 86 18 63 3E 68 DE 51 1C 21'\r\n '0B B1 53 A3 A2 A6 70 39 D5 4A 9C EA CB 0E C9 89 8B 69 73 4A F0 AD 4A B5 24 38 E3 1B 87 01 C6 CE'\r\n '67 DE 0C C4 8C C0 48 91 22 49 48 91 AB 7B 54 D6 E0 DA 4C 82 64 CE 2D 43 0C 4C 4C 6A 98 69 34 AB'\r\n 'B4 E2 E6 20 38 E3 8C 30 99 26 31 C4 CE 06 60 1C D2 9D CD CB C2 B4 15 2A 42 20 82 08 85 B8 E0 D0'\r\n 'B4 E8 30 B1 63 42 30 17 60 E4 BB A0 89 12 C0 B9 6B A4 A4 29 4A 92 92 8D ED 2B 52 E5 91 DB D0 A6'\r\n 'A8 D8 B3 AB 2C 2C B0 C7 D5 65 AB B7 37 54 DD CD 41 A8 CE 67 33 99 F3 E6 CC 13 86 63 31 A9 6A 35'\r\n '1A 0D 06 08 B9 1D 3D A2 F2 EA 08 91 3A 59 30 A0 6C 62 04 08 10 20 1A 58 EB 40 81 80 4F 0B 06 18'\r\n 'EF 18 E2 8C 49 98 18 2C 16 0A A4 1D DD AC 31 40 7B 86 43 0C 74 76 48 D0 C3 1A 83 3E 73 B9 A3 C7'\r\n 'F1 58 B1 55 55 55 51 D3 BB 9D 86 6F 12 C4 61 8A 35 C1 C4 38 E6 6F 2D 5B 8D 86 C2 EB B6 18 E0 68'\r\n 'B4 10 42 21 C7 32 9B AF 3A FE 19 18 93 26 5E 2F 01 22 52 52 25 D7 9D DC 34 26 4C 70 34 31 43 B6'\r\n '77 4E 6B 98 E2 A3 50 C0 61 86 F0 5C EE 38 EB B6 74 0E 77 21 39 C7 03 8E 31 42 85 28 4C E6 91 79'\r\n '79 79 7A 2F 2F 2F C1 7A 4B AE 6A 13 26 4C 99 22 44 8D 7A CE C2 91 22 3A FB 18 E1 CD 10 41 E6 51'\r\n '52 A5 6B DE B5 C6 0A A5 60 82 8A 84 CD D4 28 73 F3 9C FC EB 9E 1C E5 E1 5D ED 76 B1 AB AF AC 72'\r\n 'E4 28 A0 E8 DD 51 BA B7 56 56 15 95 8E AE BB CB 96 85 61 64 DC 16 05 55 15 55 53 9C 55 E0 D2 79'\r\n '3B F3 1D 92 B3 42 35 F2 8E BB C0 1C AE 2D BA E1 8B 7A 1C 5E 5E 6D EE 3B 03 5E 05 2E 77 33 83 65'\r\n 'E6 DB 0B AD A6 9A 4A 0A 08 C4 76 95 B8 79 AE 73 21 AC BB 11 89 62 26 B6 A3 12 9F 64 A1 33 AB 4C'\r\n '59 1E 01 E8 70 C1 75 C4 18 1C 07 3A 88 20 D8 1B 33 98 18 18 61 06 64 30 CC 98 A2 28 E6 54 D0 51'\r\n '11 A0 CE 57 31 39 91 64 5E 11 D6 3C 39 75 A5 AE 45 F9 C2 64 D4 D7 02 E4 5A 33 79 95 E2 E4 C0 7F'\r\n '0E D1 52 65 F2 3A 78 E5 21 48 D7 A4 E5 94 8A AD D2 B8 B2 BE F3 8C 96 BC 26 68 EE 8C 68 10 E5 24'\r\n '79 12 EF 54 96 C9 93 3A 80 4C 9C CC 09 93 53 34 CA 47 6A 68 99 32 47 59 68 5C EA 85 0A 1C 7C 5D'\r\n 'CC FB D8 DB 8D 58 B2 A8 AA 66 2C 66 20 EE 05 51 5A BA F1 BA B0 E3 B0 33 1B C5 C8 63 69 B6 14 13'\r\n '15 2C 4D 4E 44 E4 6E 53 E1 B9 6D 4C 1D DE F6 C4 55 15 2A 1A CB 77 4F 35 89 8A 31 30 C0 7C 16 52'\r\n '47 3A D8 B9 41 B4 26 33 04 4E 48 C4 E2 89 BD 12 2A 26 D0 D2 B5 2A 69 30 0E D2 ED AD 6B A4 D6 67'\r\n 'CE 63 52 08 20 66 C3 92 08 E4 47 20 72 06 0B 0C 15 82 C7 17 36 06 06 06 1A 31 2C 58 2C 2B 22 C1'\r\n '60 82 20 83 A6 A5 C5 4A 95 20 31 A9 54 62 2C 46 28 50 CF 46 61 86 19 84 C3 2C 56 2B 15 8A C5 58'\r\n '2D 62 D6 A9 52 A5 48 88 09 12 24 65 32 99 4C A6 4C 8B 2D C1 9F C4 5D 71 99 4C 9A 99 BB A1 86 18'\r\n '64 C5 06 9A 99 E5 29 9B F5 2B C5 42 85 0A 0B A9 62 C8 7B 97 1A 99 79 34 A7 32 67 0D 0A 12 09 A9'\r\n '9B D5 37 8D 0A C2 AA 71 CA 14 29 42 95 63 21 91 64 32 1D 43 A8 75 18 0C 86 A5 A5 62 68 26 4C C3'\r\n 'B4 30 C7 A1 27 1C 76 36 2C 04 C3 2C 13 8E 8A 14 26 4C 9D 82 86 2A CA 6A 44 80 91 23 CA 09 93 09'\r\n '48 C5 55 48 3A C4 CE 0C F9 D8 62 87 7C 28 A8 51 59 59 36 2B 34 70 2A 95 EE 67 0D B7 0E 4C C3 1C'\r\n 'F5 1E 60 F1 29 2C 0B 6A A8 CC E7 5C A0 63 31 98 B8 4E 10 E1 38 0A D5 6B 80 A9 C1 25 25 29 1C 01'\r\n '2E FC CD A9 D6 C2 87 34 C9 92 2F 2F BC 83 85 65 35 57 BB 32 64 CD 45 0A 14 A1 45 39 12 35 C8 91'\r\n '84 89 5E 73 2E 03 2E 43 21 DA 4E AF BC CA 59 60 B7 65 59 4D F0 A7 50 F2 34 8F D4 47 50 DF DF 2C'\r\n 'AF 57 AE 4E 35 C6 B1 2F BC ED 05 54 89 2C CA F3 C1 DA 34 49 68 B1 32 56 99 7E 5A 9D E9 2D 53 26'\r\n '76 0B 50 B0 68 DF 71 DC C0 50 A0 88 DE DA 19 46 76 26 89 F0 14 24 4D 57 0C 86 45 8E 53 21 0B 2E'\r\n '5C A5 2F F2 A4 49 49 EE EC 94 DE A1 45 AD 52 86 2C 52 86 EC EE 1B 8A 27 42 71 CF 1B 9B 6A D2 B6'\r\n 'AE 9A A7 CB B4 E6 0B 18 65 00 86 85 B0 26 79 14 45 6D 52 25 5A 60 63 29 6E 52 73 21 32 64 8E 02'\r\n 'FB CB D7 56 EB CC A6 41 96 51 B6 A7 53 91 79 23 CB CC 99 EE AA 84 C9 2D 3C A4 89 2C A6 52 AB 29'\r\n '94 F3 23 8A D9 4C A6 53 29 94 CB 94 CA B8 32 99 4C A1 11 23 52 99 34 4F 91 14 18 58 0C 77 C7 1C'\r\n 'DD 0B 53 9A 9C 71 38 C7 61 76 16 95 DA 4E 77 CA D7 51 62 DC 85 BB 18 1A 57 7B 13 10 31 31 21 6D'\r\n '71 8D 07 2C CB C2 F4 17 F1 C8 D2 B4 AD 2B 4A D8 A1 0E 93 94 26 22 73 99 91 6A 5A 8C 86 E2 BD 89'\r\n '12 4A 44 A4 6D 32 98 DF D7 BE F3 71 21 48 BC 74 CA 44 86 97 14 8B D1 7D E6 2A CA F2 F0 E0 C8 6C'\r\n '4E 5E 95 E7 14 8B EF 38 65 86 E1 E8 77 C9 84 C5 71 3B B4 50 BB 91 6D 5B 56 93 B4 AF 57 84 62 46'\r\n '25 90 29 54 9A 09 07 B4 A8 85 12 22 8E 84 C1 39 93 26 43 11 88 3C E1 35 A4 99 A0 5A 14 CD 0A 84'\r\n '8B 1E 02 67 2C CC 26 49 72 AC 15 03 9A 86 38 EE 83 C3 00 C2 61 89 1A 24 6B 09 CE 73 30 28 51 60'\r\n '32 18 62 CA CB 15 68 1A 87 CB 07 98 A1 8B 0C 86 18 D0 BC 9A 2A 19 83 31 E6 39 94 1C 2B 41 0E 9D'\r\n '27 72 94 29 4C 15 28 5E 5E 8B EE E0 24 66 52 25 CD 29 6B 26 55 54 62 80 D7 50 C5 6A 5C EB 5A D2'\r\n 'BB 07 6F 95 62 76 96 15 35 C0 3A 23 4D 4C A7 50 B1 DC 59 4C 80 B2 64 C8 72 28 57 9A B4 CC BC A4'\r\n '89 17 99 D1 9D 19 91 33 32 A1 45 B0 66 2C 38 EC C7 71 3A 75 3A 78 B2 A2 9B DE 6D E5 E8 8A 80 F1'\r\n 'E5 09 E3 C9 9C E7 A7 97 0A 0A 95 9D 3C 78 C1 C5 C1 07 0A D4 55 67 08 46 AE 0C 4C 45 62 C6 70 82'\r\n '14 47 82 A7 60 D3 52 14 65 CB 94 3B E9 DB AC 2C 22 45 60 B0 0B 45 81 C6 B9 2B 34 2A 4E 8D 75 99'\r\n 'D6 73 91 CE B8 EF 6E 30 58 07 88 AF 57 97 2B 6D B4 A6 46 95 40 C6 5C 99 0D 5D 85 3E 97 65 59 56'\r\n '82 74 67 C1 41 04 41 A4 88 14 07 23 B8 E2 91 B6 F3 A5 75 16 F9 BE 1A 14 07 18 73 DE 54 3B 13 99'\r\n '3F 2D 72 D0 33 B8 E6 C5 D8 3A 56 95 D9 20 D4 E7 35 DC D5 36 0E 3B 8E 1C 01 52 36 AA C0 80 65 32'\r\n '95 05 50 7A 32 9A D7 7D 74 AA D8 81 04 5E 16 26 1E 3C D5 02 10 84 20 52 68 EF 86 80 81 01 E0 FA'\r\n 'C2 08 A9 5E 99 30 C3 3D E5 69 EE 39 DA 71 4B 86 61 33 39 E5 8A 70 8C 68 18 63 B6 E3 E6 46 64 70'\r\n '89 8D 74 53 35 04 8B CD 48 CC 17 AC A1 A3 0E DC E4 75 FE 8B A6 E5 C8 98 61 81 95 81 CD DC 4A A5'\r\n '56 BA E2 05 4A B0 C3 03 21 90 C0 C1 42 8B 00 6F 2F 43 52 A1 A8 66 45 94 8B EA B6 4A 47 0A E8 46'\r\n 'BE 56 39 DC 7D A2 7E BC 18 AA AF 07 0C 1B 21 67 3C 5D 9D E3 00 82 19 9A 67 32 DE DC 60 2C 05 7A'\r\n 'A3 5A D6 BB 4A A2 A3 A9 59 62 D1 C6 4D 6D A6 0B 6D FD A5 B7 83 59 B1 1A 96 CD 87 11 89 84 16 AF'\r\n '25 8A CD 13 53 26 4F 3D 09 85 E5 E6 E0 BD 17 E5 5D B5 D9 2F 0B CD 41 20 7E 69 91 DC 0A 2C 6E 56'\r\n '61 85 65 BA 3C AB AB 52 0C 47 1E 85 15 0A 2E BA 29 D3 22 45 A6 4C F3 E8 B2 A1 4A 2A 14 45 85 DB'\r\n '56 18 CE 1A F5 E9 A9 D9 A9 C4 B4 58 56 2D 65 DA 11 D0 22 39 EA 56 B1 A1 C6 E1 07 43 9C 30 41 9C'\r\n '38 0D 0A B0 43 21 8C 55 28 4C 99 D0 A7 D1 22 F2 F2 BD 95 D5 5E 79 13 26 4D 58 9A A8 51 79 AD ED'\r\n 'E6 38 DC 71 F3 85 0A 14 2F 2A 5E 62 12 EB CC 26 75 2C 58 8C 46 23 49 80 36 40 9C 27 2E C9 76 7C'\r\n 'A6 70 79 18 40 2D 6C 22 44 88 44 30 0C 11 81 9D 1B F9 D5 A0 8F 05 42 21 39 94 70 EA 8B 4E A4 E5'\r\n '0C C3 1C 29 B7 27 77 33 90 42 83 3A 20 4E 62 B5 38 CC 99 0C 30 C0 C3 0D D2 B1 54 E9 76 C7 8F 30'\r\n 'B0 E4 62 9E 97 4B 52 CC 11 18 61 AC 22 44 80 40 79 A3 40 F3 19 42 85 14 C9 93 27 32 78 14 5B 16'\r\n 'E3 73 9E 08 50 A0 82 14 28 4E 68 B4 BC 2B 71 30 99 B4 28 50 CE 48 CD 98 C4 99 63 C1 33 86 85 0A'\r\n '14 28 BC 43 0C CD E2 D3 85 47 95 3B 32 8B 10 4F 1E 3D 58 AC 5C EA D5 23 A8 A0 A2 89 49 47 74 08'\r\n '05 6C 30 CB 01 D0 C7 2E A2 84 8C A6 53 29 94 CB C4 5E 5F 05 E6 B2 43 22 64 C9 93 0E 65 4A 14 38'\r\n 'F9 82 85 0A 14 54 28 51 77 D3 1D D3 BC E3 1C CE EB 18 39 48 1C EA C1 03 0C 50 D9 79 7A BD 71 AC'\r\n '09 93 26 4C B5 8C C5 0D 23 55 CD 90 41 17 44 10 A0 82 15 4A 95 0A 95 59 8C D6 B1 52 02 20 80 82'\r\n '08 35 C0 41 03 33 18 3A 60 CA CC 33 0C 71 F1 AE 3E 35 6A 99 91 A4 AA 37 B7 B9 0E 57 06 18 DA 9F'\r\n '97 2C F6 06 6E C6 53 21 75 70 E2 ED 2D 89 8C 0C D2 0B 7A D4 0A DA 69 24 5A 38 71 6A B4 E1 CC 6D'\r\n '56 A9 D6 28 A9 4A 1B 76 9B 46 5D 20 E3 89 CE 10 C1 C7 1D 0C F7 38 FC 98 97 43 8E 98 E6 EA DD 77'\r\n '54 F3 82 CF 55 08 70 71 D3 67 C2 B0 AE E4 50 66 0A AE 1E 78 E8 20 50 88 4E BC D2 90 EB 7F 7C DE'\r\n 'BB 7C 83 A9 BE 50 29 4C 82 CA B2 AC A6 4C 86 4E AE 6A 78 33 0B 64 C9 9B 15 D7 50 A2 A6 C1 86 87'\r\n '8D 5E 84 DC 6E 0E 32 65 88 E8 D5 06 83 6A 82 9E CD 3B 5D 76 B5 E2 40 78 F7 8F 1E 27 3C 99 E8 EC'\r\n 'E5 2A AA F5 DE 0A AA 0C 86 4C 86 34 71 1C 45 B8 A9 A7 35 01 39 73 96 19 43 BE B7 55 02 10 2A 82'\r\n '3B 9B 57 64 91 24 C8 DD 54 32 8D A1 1A AA 78 D5 A9 56 61 96 97 46 82 34 F2 D4 3B 55 55 55 1C 77'\r\n 'F0 C1 08 88 7C 57 99 0E FE F1 0E E3 9D 62 08 3C 46 AB 15 EF 57 CB F2 AE FE F5 DA 97 A7 19 F7 B3'\r\n '93 06 3D 04 AA 80 2C 46 4D 1D 6B 7F CF 01 9A 19 2C AF 37 E8 66 EA 6B AA 20 A8 E9 2A 64 46 E9 FE'\r\n '67 6F B5 7E A8 2D 2F F8 39 67 66 48 15 65 27 1C B9 AE 37 0E 0D 31 80 51 90 55 0B 5E 40 B3 20 59'\r\n '18 F2 05 16 4D 03 D9 B3 22 5A 46 67 5C BA D9 9A D1 AE 4E D8 CF 39 F3 6A 6B CD C9 B0 BF 6A 0D 34'\r\n 'CD 35 87 A0 A6 46 CE B4 D3 9A 39 9C AB 26 6A 9D D3 5A C0 CD 66 9A D6 46 DC CE 33 8D A9 9E 0C D8'\r\n '28 E8 83 D6 4F 5A 29 B3 6D 11 DC 9C 22 ED D3 76 E7 BE EA 5B E4 3D B3 DB 33 65 DC F3 A3 9D F2 3B'\r\n '3C 79 8E 76 8D DA 43 E6 25 CD 14 2D 2F 67 0B E8 76 98 D3 B9 D7 A7 7B 66 A0 C5 13 10 9D F4 BB 52'\r\n '6A 9C ED 5B B5 86 B4 99 26 8C E1 90 2F A6 40 F7 CD 41 A3 34 E4 D9 AE 35 67 D5 69 76 AD DA F3 60'\r\n 'EF 05 8F 6B 5E 99 36 24 E1 3A 6C 8D 89 3C 4E 93 E5 07 7E ED 9B A7 8D A1 F5 9F 61 3B B5 F9 8D A1'\r\n 'F3 96 C9 E7 6D BF E6 E3 71 B5 3E C3 6A 6E BF 5A 1D DB B7 BB DD FE FF 83 BD A2 E5 BB 87 C3 A4 38'\r\n 'DC 6E 3F 1F 91 C8 D8 6C 1D 45 34 B8 87 E4 6A 8D 91 36 4D 6B B5 E6 B8 9C D8 71 4B 2F 15 D3 5C 5F'\r\n '2D 8D DD BB 89 C4 E2 1C 42 88 A1 A4 A4 E2 7D DC 97 B8 6F 73 3B 0E 35 27 35 EF BD EA 57 B9 0F 53'\r\n '3D 4E F7 39 EF CC FD 0E 51 CF DB 59 D3 DC B7 92 DF 13 4D 5D 07 25 51 B8 73 CD 55 2F 52 9C 63 8A'\r\n '52 9D 12 A8 B7 74 9D FA 1F 9F 31 DF 91 56 74 CA C8 4E 8A EA 83 A8 E7 54 BA B4 EA 95 C4 05 79 18'\r\n 'EB 11 7B 25 DA 3D 58 3B F5 6E 06 E7 09 EE BA B8 37 35 C0 52 FF B6 03 15 0A BE 71 7F 77 FC 38 A7'\r\n 'DD 38 D8 CD 8A DC 84 CD 07 11 28 39 4F 25 54 A8 6E 3E 53 57 CA F7 94 9F 70 F4 0D CD EF FB 43 75'\r\n 'F6 2A D6 DC 52 DD 50 A2 FD 9B 7E 85 6D 9F 56 29 35 EA CF 15 1B 14 4A 16 2D 03 B0 0B F6 B9 5C 8C'\r\n 'ED 06 62 F3 92 A2 A0 19 E7 29 8A 32 40 52 0B 7E E9 E6 09 62 A0 88 04 12 28 26 4F 46 0E 49 E9 86'\r\n '55 F2 0E 90 98 62 81 0A 55 43 1E 28 A9 4A 28 CF A8 2E 4C 53 D4 AA A4 88 72 90 51 4C 26 55 EB 68'\r\n '20 29 94 84 A8 9A 0A 73 D8 5F 04 51 05 5A 99 30 48 3D C7 38 A2 A8 13 35 A7 4A AA 5B 16 5A 55 2A'\r\n 'B4 A2 E5 5A CD 57 A9 65 52 AF 7A 34 6D 28 A0 97 D3 53 05 B3 C2 A2 91 40 2B 29 55 85 69 56 7A 6B'\r\n '25 95 F9 D3 89 53 45 31 2A 8A BA 2B 48 9E A6 20 77 AA 37 0A 0D 3B D1 55 40 85 D0 59 8A 2D E4 53'\r\n '89 CE 56 94 11 70 9E AA 12 29 85 3A A2 AD DC F7 94 11 48 26 15 75 35 0D 18 D5 22 AB 42 82 1C E4'\r\n '4A A2 F8 08 A2 0E 9C BA 4E A2 12 4F 3D B3 81 F3 22 AA 94 1F 6E 48 AE AD 9C 2B 55 55 05 3D 52 C5'\r\n '1A 48 A0 AA 05 BA BB 70 58 BB 96 54 56 45 A5 15 5A 7C AA 88 9E F8 95 06 2A 45 EE 09 4A 05 55 3C'\r\n 'D4 14 5D 22 75 96 A3 6F 2E 2A B2 78 F4 CD 65 C3 8A 96 13 3C B2 98 AA CC C6 22 6B 04 AA AB 89 C7'\r\n '8F 79 2A A4 A9 A9 42 50 96 F1 54 2C 34 89 A4 0A F7 69 8B 29 82 2A 45 20 D6 54 C4 AA E1 3A C3 22'\r\n '71 CE 70 AC 15 94 D5 DC 27 04 8F 7A 88 FB 97 0D 70 D2 91 95 35 B1 40 BC 54 95 18 29 15 1C 25 01'\r\n 'C2 A8 AE 13 91 17 83 91 46 44 F8 8F 99 4C A4 49 3C 27 72 2B 0E 45 22 55 54 8A 1E 38 62 2A 91 04'\r\n '40 19 18 46 AC 3B 0A 31 AA 48 31 30 94 24 2B D4 25 08 91 95 99 56 10 AC 92 0A 2E 28 2A 2A 54 41'\r\n 'E8 28 A7 A2 B2 72 8A 82 72 65 20 CA 83 42 4A 0A 75 4D 40 20 D0 53 8E 54 11 69 91 49 45 51 4F 2A'\r\n 'AA 05 02 09 C5 FA A2 A0 57 15 65 40 2E 54 24 27 98 2B A4 24 95 A1 8A 1B 1D 6E EF B7 3C 18 EF 07'\r\n 'B7 9C D7 59 61 5B 4B 69 6E 20 20 3C 32 40 EF 0B 79 6F 2D 44 07 74 88 0E E4 80 E7 90 10 10 10 10'\r\n '10 5C 9D 03 A0 20 20 20 08 1D 00 BC 22 02 02 A8 BB 15 C4 11 CE 81 D5 84 04 04 04 04 04 07 E6 5D'\r\n 'C8 0A E2 CB 7A 75 6D 67 52 B6 B4 F4 F1 1F D7 C7 AD F5 EB 48 5D 37 74 E2 C5 38 28 F3 88 A5 59 14'\r\n '8B EC BA 1D F5 EC 56 8D BF DD 45 9F DA 47 4E 4D 31 4F DB DD 1A CE B4 9A 48 CD 76 8F 47 A2 97 B1'\r\n '56 2D 6D A7 07 A4 6E DB 4B 2D 25 66 96 16 76 42 E4 BE 64 B3 AB E3 B9 7C 19 B7 66 FB A5 0A 13 96'\r\n '4B 23 DA DA 12 7D 62 6D 8C E9 F6 14 8E FD F1 DF F1 6B 2D 68 B0 2B D3 74 9D C2 50 02 AF 11 25 7A'\r\n 'E9 86 AE B5 25 E0 0C 6E 12 F1 D5 F1 3A DF CB E4 95 8B 96 C0 E0 70 1B 4E 37 FB F8 DE FE F7 8B C5'\r\n 'E2 BD 79 90 AE F5 F5 F5 39 BB 5C 10 AD 14 6F 48 45 77 6F 4B 4A DA 50 A5 8D D3 97 4A 5E 3A 15 3B'\r\n '5B 4F 67 5D 8C 72 8E 79 E6 B5 AD A7 71 4C 9A D5 A3 E4 F3 9E 7A 13 57 31 92 34 FC D5 64 89 33 87'\r\n '8D EC CA 36 43 E9 87 B2 07 0A 76 FA 9F A9 DC 26 DF A8 61 37 A7 73 5B A9 FC 1F 6F F0 E9 FC E3 0D'\r\n 'CD A7 2F 73 4E 6C DD F2 66 84 A1 37 46 E8 F6 8D C9 EC 9E D1 BA 37 46 E8 F6 8F 70 DA 9B A3 74 6E'\r\n '8D D1 85 30 86 10 C2 9C 8E FF 80 34 1D 5B FD 6E F7 80 1E CC DE B4 B1 5E CD 64 7A BB F2 C5 BF 0F'\r\n '57 A2 A6 0A AA 9B C1 BC 45 F0 06 DA FF 03 62 5E 6E 39 FC 99 2B CD BE BD 77 27 AE 36 C1 C6 C9 7A'\r\n '33 0F 28 3C CC 58 48 35 E9 90 99 80 1B 5E 26 D0 7C 54 2F 3D 0B EB 5B 35 B2 A7 D9 63 6F 4D C5 AC'\r\n '3E 2B AD D6 6E 28 EB 5C DD 5F 6F D3 D7 41 BB 31 76 47 40 E8 0A E2 02 B8 D1 95 C7 30 AE 2B 8A E2'\r\n 'B8 C8 19 63 2E 65 8C B1 96 32 85 7B EE CB 8B EF 3F 02 4C 88 40 65 4C C1 56 79 24 17 58 2F 2D 94'\r\n '74 3F FB 87 01 2A 40 4A 1E E9 28 7B BC A7 40 ED 71 30 4D 90 16 04 05 79 62 53 9A 92 F6 46 3F C1'\r\n 'EB 1F 29 18 C3 11 88 C5 01 32 46 23 12 C6 74 FF 85 79 18 DA 9A 02 31 B1 23 11 88 C4 62 78 9E 37'\r\n '26 D4 DC 15 E4 62 84 DD 1E 5D 0B A8 77 2B 26 75 4A 13 76 46 1F 23 1A F2 02 31 18 9C 35 D4 5A FD'\r\n '73 61 9F CE CD 0B 6D 09 EF DA 12 21 30 98 59 A1 68 4C 3A 26 85 A1 7D A1 68 4C 2C D0 B4 26 13 09'\r\n '85 E6 85 A1 30 B3 42 D0 98 4F 8C 70 CC 26 13 09 84 E1 9C 38 ED 0B 42 4C 21 B5 07 0C C2 6E 4D D4'\r\n 'D3 A6 5D 34 BD CF 59 72 F6 CF 72 DE D5 B9 43 58 16 09 31 4C FD 52 2E 4D A2 AC 9F D5 42 EC AF 3A'\r\n 'DB 23 D0 13 9E 13 A0 74 F1 06 65 3A 79 D0 10 59 9D 03 AD 46 CE F6 E8 1D 6D 38 C4 17 B4 E8 1D 01'\r\n '01 01 01 01 01 C7 37 64 04 07 20 80 A3 2B 6D EE A4 F1 9E 81 D0 77 CE A4 74 04 05 61 FC 98 75 F1'\r\n '9D 46 1C 34 DA 35 3E 2E BC 7D 1A FD 34 8A 31 E0 C4 71 61 D1 05 58 16 37 85 B9 EF 76 4D 9D 7D 7B'\r\n '84 ED D0 C6 D6 89 6E 4D 6A 67 1E 78 11 51 82 8A 50 EB 4E 3C EB 8B 7A 55 D5 3A 46 FE A9 CF CC D8'\r\n '66 E1 18 C6 2A C4 E6 E8 4F 77 F5 65 30 17 92 DE DA 7A CF 06 D4 4F 9E 0A CF 99 D3 50 A0 3B 01 4D'\r\n 'D4 8B 71 00 8B 47 64 89 1E C4 67 75 2F F5 59 EE 30 E5 E3 E2 F4 9E 6A AB AA 6F 1D 36 ED DA 7E 0B'\r\n 'B4 B5 51 70 B8 5C A7 36 8B 85 E5 2A 25 85 E1 2E 0D E1 BC 0F BB C5 86 DF 17 B8 6F 0A E8 CB 5A B3'\r\n '42 7B DF B3 1B 83 22 6F EE B5 46 D4 F5 B6 FB 66 6D B7 79 4B 21 B5 5B 63 BA 27 3B A3 6B B5 D0 E5'\r\n 'D9 CF 9F BB 31 F8 EC E4 76 73 E8 4E EC E1 B3 15 BA CE 63 67 CC 89 9C 60 8D 52 5A 70 F2 AC C4 E4'\r\n '32 F4 CC E3 49 9A 36 24 3A 0C EE D3 0D B2 2D 0F DD 30 21 3B 8F C4 66 BF AE 12 77 FC 63 45 21 E4'\r\n 'A9 77 84 5D 41 B3 2D A4 F0 1F 6C 6E A9 DD BB 56 6E 6E 6E F7 1B 9A 11 EE AE 29 31 8C 2B 5E 98 E2'\r\n '21 22 24 5C 75 19 7F EF 7B 3D 3E 1B 2D 4B 07 5E 75 DB 4B 26 D3 69 A8 2A 3A C3 66 6C C7 1B 93 B8'\r\n '35 94 D9 FC A9 F0 82 9F BC 65 88 F5 4E B6 31 56 64 1E 13 D2 E3 EA 47 06 DD 7C D1 3F AC 33 0F 09'\r\n 'F8 1E 13 FA C7 92 6D 0C 31 0C 47 4B 6C B9 01 82 C8 B3 21 40 98 CF 4E A0 EF 76 D2 87 F9 B9 68 B3'\r\n 'F6 F5 9B BE 36 C6 3B E6 FD E7 EB 66 3F 54 E5 6D 5A 88 4F 7E AD 56 6E E9 D0 F0 99 1B 82 FC E1 D5'\r\n '28 7F AF A0 B4 2C 81 48 B6 5D E5 D2 D3 37 BC B6 C2 5D 87 76 CE F1 55 29 6E 8B 2F FD 18 EC 77 77'\r\n 'D9 40 D8 FF 42 E1 21 53 38 CE 83 3A 5C E6 F3 4B 69 4C 9B CE 7A 7E 87 D2 7F 1B F8 DF C4 F0 1E 03'\r\n 'A7 77 E3 FE AE 1E EB CB F3 24 37 98 83 79 49 5A 4D DE 9C C1 3C 00 FF 47 3B 38 60 4D 81 F3 C3 8F'\r\n 'C3 7D 66 87 51 30 2C 8A A5 7E 98 16 BD D8 0A 22 BB 82 1B 77 DE 5C 7C F3 DD 1B A1 E4 8E 8F 39 D9'\r\n '89 4F BE 3B 81 5B D2 DC A9 03 AE EB 7B D4 F8 E7 7A 19 1F 11 01 2E 58 81 2F 54 04 17 AA 02 DD 7B'\r\n '9B 0B 35 CC 56 26 5A E6 F1 D4 B2 48 63 35 4E A5 EB 1E C5 DD BA D7 84 F4 CF 84 FC 09 D1 BE F8 74'\r\n '6D E5 CE 2D E3 6A E1 CA B5 04 86 AB DC 7E 07 61 FC 0F 85 62 1A 97 57 AA 6E 35 B4 B7 EA 03 0B D4'\r\n '7D 76 89 8F D4 16 0E 44 CA 57 E8 4F DE 37 56 20 67 7F 4E 22 99 D2 4A A5 97 D4 6C BE 23 65 B2 D9'\r\n '6C B6 5F F7 7E F3 A5 BE D1 5F C8 68 AE 06 8C BA F5 8F 92 97 B7 C3 BC 04 28 1D 42 74 4F DF 33 46'\r\n 'B4 3E 48 4F B0 0B 74 E1 BE 15 54 FD 1A 50 AC 50 2D C0 F8 A3 94 68 5D 5C 06 B2 4B 84 DC A6 C8 38'\r\n '2D C8 B9 4F 86 9A F4 EE 52 45 C4 9D 08 93 AB 0E 33 07 67 6E 31 3B 44 F6 6C 75 47 8B 69 ED 50 B6'\r\n 'AD 89 5C 5B 04 62 1D 05 19 D9 F8 98 9A C5 7D 66 AF 5E 54 16 49 C4 99 2C 6B 7E AF 15 FA BF 5A 85'\r\n 'A8 5A 85 A8 57 4B 50 A9 E9 F4 CC C7 EF 56 6D 4B 9B 29 1C 6F 6A 40 C1 1E E8 75 3A A8 8D CC A6 95'\r\n '6B 8A 0D 28 0E 89 3D 96 42 8D 2D 62 C8 5C CB 05 4A 55 6B F0 39 89 D8 87 3E 75 83 07 57 9D BF D3'\r\n '36 92 A3 4D C6 F1 D2 D4 F9 7C F1 2C 68 2A 81 D1 3E 4B EC 3D 5B F0 BD 7F 61 F6 1F 55 F5 5F 50 7D'\r\n '47 D4 7E D3 C1 75 8E B1 62 2E 63 56 D6 5D AA 4E FD AD F1 D5 C1 9B 41 F6 83 D2 0B 5A A0 FE C0 E7'\r\n '49 F9 D7 F4 55 32 B2 3C A2 9E 52 79 51 A5 87 45 90 9B 4E 3B AE 39 62 B6 48 FA 66 7B E2 E8 CA 06'\r\n '6F 35 7F 28 66 9C CD 53 E7 9A 49 6B 66 A3 0A 65 BC B7 0E 83 CF C0 9D 5F 0B 35 CE EF 39 73 7D AD'\r\n 'D0 06 80 AD 7E DF BB F6 FD F0 DB F6 FD B6 6F 1D 4D E1 C3 49 6D 5B A5 7B EB BD FA 73 A7 2F F9 6B'\r\n '4E 1A ED EA CA E5 1B 4E D8 2A 6A 3F 2B 1A BB 95 8E 1E 36 9C D3 7C AD 3E 9D 5D 65 B0 B2 24 A5 28'\r\n 'DB DA E6 C2 CE 16 59 76 AD 96 CB A4 73 CE 79 C0 70 1C 3E 33 A9 E6 A4 3A 9B 7E 6A 56 D0 7E DD 6E'\r\n '73 3F 61 9F 73 FD E2 5E 31 D4 86 4B C4 17 88 57 2F 01 BC AC A2 57 9B F0 20 CE 49 5C 40 9A 90 5F'\r\n 'D5 06 E7 F5 53 3A 34 C9 15 75 6E 70 BB 23 22 3C CB 14 4C E4 19 97 AD 50 5D 7F 29 B7 B0 F4 E1 97'\r\n '39 B7 BA CE 3A 25 A2 5D E5 CF 4F 77 A3 5D 32 CF 52 30 E4 7B 86 C3 C3 CD 33 63 B0 C2 E4 30 C2 19'\r\n '33 0E 6F 06 2D 77 CC B8 89 45 A6 08 CB 40 2C 53 40 57 E7 E8 5E A8 A9 C9 07 11 8D 40 47 82 80 0D'\r\n '38 50 4E 5A 75 89 86 96 A9 C7 4A F0 B3 AA FE D7 39 51 E5 5A 70 67 F1 13 70 DC 64 3E EA 65 C4 1B'\r\n '17 EC 9E 17 3D 2F 10 1C 1A 80 C6 F4 00 06 50 66 56 0C 9B 96 AA 1B 62 AC DE 6B F2 5A 1E 11 D7 9D'\r\n '79 A9 A8 AD 82 72 9D 19 5C BC CA B9 52 BE D2 63 F1 95 72 3E 05 A7 6B 4B 6F 40 A5 B7 ED 5C FB D3'\r\n 'E8 3C 7B EF 8F E0 7D C7 B2 1D C0 F5 8F B6 F6 4F 60 FE 27 B1 7C B1 FC E3 AC 5C 85 FF A5 DD F6 6C'\r\n 'F0 CC 0F 0C CE 40 D6 7F E1 36 B5 67 89 06 CF 1D 2B 2C F8 64 71 F3 8C E5 5B 58 EE B8 C6 D5 4C 0A'\r\n 'D5 BB 47 8B 30 9C 89 88 E5 82 C6 9B 2A 38 0E 8D A0 7C 78 22 6D A2 05 19 27 2B 14 37 8E C9 79 A9'\r\n 'E6 42 C0 7D 8D 4D 8E A0 F7 25 A4 26 96 85 6E 3B 9D 7F F9 ED AD 98 9D 7C 77 9D A7 59 A4 29 B4 2D'\r\n 'AA 8F 72 98 4E 5F 02 BC 6D 1B A7 05 8A 7A 1E 21 5B 3E BE D2 C1 CF 7A 9E 9B 31 DD D4 3F 19 73 56'\r\n '09 4C 2E 2F 93 B6 65 A7 F2 7B 96 B4 AB 1B 25 E1 F3 F6 10 19 4F 3D D4 3F ED 5E C4 A7 D4 0B E1 CD'\r\n '12 1A F8 46 BF A9 30 DF C9 5B E4 AB 7C 3D C9 F9 6B 8D 8F 5E A0 63 57 AE 95 E3 B3 39 5E EC E4 4A'\r\n '7C 2F F0 3B B2 BF CA 77 D7 79 FD 96 D4 C0 AE 73 D7 59 41 0E 70 8E 76 00 C8 4F 23 A5 FF 81 E1 D3'\r\n '18 62 0F 0B C7 F3 C6 08 D5 3B 55 A0 70 D0 F3 A8 C2 68 29 A1 1A 15 CC 5D D8 66 AD F6 28 DA A7 5C'\r\n '36 F4 AF D7 F0 B4 0F AF 0B 04 9B B7 59 29 EF 85 B4 34 18 39 0F 95 CD 87 BD 3E DE BA CE C2 FC EC'\r\n '9D 7F 3D 67 97 AA B7 9E A3 7F B7 E9 F3 A7 BC 86 FA 8A E1 E6 0D 1A DE 45 D0 78 AC 7C D1 81 BE 23'\r\n '0A 2C 43 53 89 15 71 17 97 39 BD B8 2D 05 A6 8E EA AF 6A 43 85 AC 60 31 07 B7 D0 5C 41 78 E6 C9'\r\n '9F F0 67 4C FF 61 2B 29 F5 BB BA 3A E2 68 7C 03 F9 E2 53 73 B8 FA 7F 3A BE 97 22 42 BE 01 8C AE'\r\n 'D8 52 1D F3 64 BE 76 D4 AD FB 0E 06 BC BA C5 77 58 9D DE BE BD 6B 9D 73 89 BE 47 1A 44 35 11 09'\r\n '16 10 A2 91 4A 47 C8 CB D0 17 FB 22 7D CD 5B 6E E9 1B 77 48 E8 9D 10 E8 5C FB 87 76 4E E5 E5 1E'\r\n '5D BD 6F 9F 19 BC 71 6E DC 77 AF 28 ED DC 17 16 80 5E 30 F7 39 6D D3 7A DF 1B 37 7E D7 EE 9B BA'\r\n 'F7 74 BB BF 2C 9C FD 97 B1 AF 62 96 3C E3 22 57 BD 29 6D 9E 2F ED 39 D6 E4 72 D1 C5 30 13 5F 1A'\r\n '11 06 28 6E 47 9A E0 1E 0C 81 30 9B D1 E1 35 33 49 D5 71 BE 31 17 EA 4E F3 2D 40 DB 99 D2 72 66'\r\n 'D0 0E A3 6D 44 F6 47 1C 58 D6 02 BB 02 18 49 B7 7B E1 B6 3E 56 52 2B E7 AF 6C F1 4C 93 37 B4 7C'\r\n '4F A5 94 E5 78 6B 4D 0A 22 89 A3 50 9B 68 75 A5 70 E4 D6 86 5C F6 55 85 1A E2 F8 2C EF D9 DC B3'\r\n '29 0D 52 30 5A 5B 64 ED B6 E5 B0 BF 10 D5 FD E6 8C D4 F8 1A 33 C0 8B 3F D6 2E E9 7D 02 F3 A4 D4'\r\n 'E4 9D 0C 2B 73 1D D5 C8 EC 03 90 5A 7B F7 CB 0B 36 BE 22 59 34 C2 17 B4 B9 E3 79 D9 C3 41 EB 9F'\r\n '70 86 F7 12 4F 57 8E 4E 3D A8 1F 2D 79 47 2C E1 65 F7 A6 B9 F4 89 23 FE AD BD 52 97 64 C5 BF AC'\r\n '3F EC 23 58 AB A0 0B 91 31 7F CD E9 B9 B3 7F 15 B3 E5 D7 6F 70 EA 31 3F 80 F3 09 0F A8 1E 31 D4'\r\n 'F4 7A 33 47 06 7F 8C F6 B1 A3 46 2C 37 58 AE F2 DB 68 E8 EC F5 6A 4C 35 3F 82 BC 9B A3 18 A9 9B'\r\n '72 9E 30 76 E3 64 7C 72 07 7B 80 77 A5 61 9A D5 3E 64 E6 52 30 53 02 19 80 EB 6D BC DE 95 B1 22'\r\n '7F BE 26 4C 76 F4 F6 9E 90 A0 C7 DC 61 CC C7 11 3E 07 96 AD 1D AA B4 66 E3 E1 EB 70 0D 8F 52 88'\r\n '74 AB 95 22 34 1A C5 72 58 58 7F B3 03 AC 90 EC 56 D1 5F 64 9E DF 02 EE D7 9B 7A 77 14 8E 3E 84'\r\n '78 D8 00 2C 10 18 32 FC 9A AF 3C F6 D2 1A 63 E4 9D C1 A5 4F FE 3C 8F A5 BF E2 46 FB 7D CA 27 5E'\r\n '1F 43 AF 76 4C 55 96 1A F3 D9 F2 2F 3B 5D 3C F5 03 53 74 DE 58 9E F6 ED 7C 86 48 DA 3D 37 AD 6B'\r\n '93 B6 84 68 FE A0 F4 46 77 6E D2 DE 93 23 18 7B 02 E5 E5 AF 93 97 95 07 D9 66 A4 F0 DC 38 8B B7'\r\n 'F3 58 4A 1C 49 4D 57 47 30 19 0B 31 47 AB C1 BD 23 C6 CB 0C 01 D8 7F 38 26 E2 87 3B 15 87 80 35'\r\n '9B BF 64 6E C1 7B 8E C3 8C 28 AC 86 8A C7 A1 00 7C 90 88 C8 F1 56 0A 7C 1D 9D DD 55 BD AF 66 E3'\r\n 'ED 60 1C 91 5F E4 E5 73 4E F7 2D CC 68 48 19 8D 9F 94 7F 7C CA F6 39 C9 EE 29 7E 63 D2 D0 B7 AA'\r\n '51 66 B9 B8 9A E6 C6 BE F5 C3 71 3F 95 D8 AF 70 DD CB C5 DC C3 24 53 39 C3 08 C8 94 2B 92 D1 C6'\r\n '88 58 F4 0C B8 E6 F3 DF C8 C3 39 CD FC 3B 6D 35 FD F4 4C 2F 9D 82 FA 8F F9 1F 24 C6 AB C8 C7 8D'\r\n 'C1 8A 77 91 5D BE 5D AE 71 96 5A 67 9E FF CF 21 7E 5D 9C 16 E8 6C 4C 66 85 31 35 25 A6 6F 6C D7'\r\n '18 13 02 60 8C 31 A2 B3 BB 0F D8 3D A0 76 20 F7 C7 4E 77 47 AF 3C 73 BB 30 9E C8 C2 61 3C 2A 86'\r\n 'D8 B6 C8 EC 0E CC F1 CE CC F6 C7 98 76 07 5A 76 87 98 7E B1 BD 1E C1 5C 69 CD 41 A7 35 07 28 F2'\r\n '0F 1C E5 A3 CD 23 17 73 52 6A 4C 01 82 2F 05 FC BE 9A 73 52 5E 4C 19 E9 1F 09 CC 30 06 14 CE 1E'\r\n 'F9 9A 33 46 70 D5 1C 63 86 63 0E 19 8E 2A 8F 64 A9 3D A3 1C 6E 4D D1 B9 35 64 C1 AB 3E 93 52 65'\r\n 'CC B1 A2 2A 0D 11 A3 34 87 BA 7F A3 16 6A 8D 49 AA 3F 02 88 A2 28 8C 61 30 6B 49 93 7A 70 09 E3'\r\n '83 D4 77 D4 ED 41 34 6B CB 13 32 4A 9E E9 D4 25 8F A8 96 34 06 80 D5 13 66 B8 FA 8A 73 9C 53 1C'\r\n 'E3 92 4F 9C 92 C4 FC CE 59 4E 7E 46 D4 8C 40 55 9D 42 4E 33 AA 2A 7A 26 DF 4C ED CB B7 67 34 FA'\r\n '4D D9 BC 37 86 B0 DB 9B 93 7C 56 1B F3 7A 6F 4D F1 5A 54 1C 72 9C E7 1C D3 9C 54 1C 32 A8 E8 95'\r\n '47 3C E8 1B 93 6E 72 4A A2 C0 A1 2A 4A 92 98 A5 29 4A FF 57 3C F0 EA D2 B8 AD 38 05 21 5E 72 8E'\r\n '49 CA 2B 8A B2 B0 AC 3A 27 44 AC 2B 0A C2 AC AF 3A 05 29 D0 23 16 05 61 4E 74 CA 92 A8 AC 2B 8E'\r\n '91 56 55 91 4E A9 14 8A 75 08 0A E3 AE 58 16 17 B7 56 BB AE 75 C8 0A FA C7 18 06 2A F6 35 89 AD'\r\n '4C 49 A9 26 A6 2D 6B 61 26 D7 C7 47 48 B7 A3 17 A9 1F 1F 55 D0 67 4B 9E 91 4E CA 56 F2 3F 2E 37'\r\n 'DF C2 A3 8E 66 FB 76 CD FD 0A 5B 76 3B 6C 91 40 C9 F4 94 F2 4B 64 C5 3A D6 3D 3A E9 BD 76 A9 CC'\r\n 'D1 25 A0 F9 B3 BF 0E 72 DF 63 63 75 CD 44 CC 65 2C AC C8 A5 90 D6 E4 36 6F EC FB 35 DB 3B 62 3D'\r\n '6C 53 8D 81 21 AF 0E CB B4 EC A6 7E B7 62 B5 CB 60 FD 6C 46 EB C3 59 D8 B2 D6 76 0B AD 35 CF 4B'\r\n '4D 6C 9A 7D 73 5C E8 9F DC D4 E9 B4 A7 42 1D 00 5F D6 BF E7 AA BA B0 D0 B2 E7 B3 E0 D9 58 0B F2'\r\n 'DD 2F FE 22 79 96 32 1C 4E 25 EE 13 3D 4E 5B DD 4A D6 DF 13 3D 86 A7 75 6C 95 B6 B6 E8 D1 58 E6'\r\n 'D6 16 4F 66 5D B5 95 81 58 DE 47 57 2C 9C 88 72 28 71 A9 6D F8 CE E2 F1 BF EF F7 2D CB DB 8A D7'\r\n 'AF 3C 7E 8E A5 BC 86 0D 58 53 AC FA B0 7B 77 BF 8C BB FC D5 AB 6B 52 C5 A6 F6 CD E3 54 F4 64 A1'\r\n 'F4 6A 5D 66 B4 DC BB 74 5C 5D D9 35 63 B1 D5 09 54 C8 54 76 19 0C 8F 6D D5 84 AA BA 36 DA 85 73'\r\n 'B5 2A 97 D9 53 54 A4 1E E1 F4 59 0A DF 51 B7 B2 C2 6F 3F A1 99 B4 F4 17 7B D8 8A E3 12 D7 D0 5E'\r\n '72 B6 A7 8E CF BB B2 66 15 DE 9F 97 CD A5 67 35 93 ED 4F 3B FA B1 7D 1C 91 78 C3 1E B9 77 8A F5'\r\n '3D 4C 47 5C E0 6E EB 6E B4 D0 E0 3D 70 2A 1C 03 D5 31 FB 62 AD 0E 9F EF BD A6 FE D2 23 3D 6F 09'\r\n 'E7 76 28 5D 82 79 7E DB E7 C4 C5 DE FF 3F DB 7F 6E 6D 91 EB CC C8 EC 72 06 2E 6E 6B 1D 34 4C CC'\r\n 'E4 F5 92 58 89 15 D8 E9 CC 98 1F 29 8C 22 A1 06 03 83 3E FC 0E 4F C0 69 5C EB 7D F6 B3 EF 75 0E'\r\n 'E3 DD 29 E0 AC 00 CC 79 E3 77 9D EE 27 11 09 46 AF F4 05 5E 9D 19 AB D3 63 93 70 CB 1E 9A 33 24'\r\n '96 41 EC 2E 3F DB 55 EE 66 45 1C A3 94 39 6C 13 8E C8 72 7E C9 3C 6E B0 64 DB 2E D5 5A 7D 47 16'\r\n 'FD B1 D5 31 C2 D8 3C E5 1D 93 BE 3E 3B 19 93 73 72 10 AC DD 84 93 CD 6A 91 C7 C7 49 0B F8 E3 ED'\r\n '6D 16 3D 35 B7 FC 7D F8 5A E6 C3 83 1C A0 32 2D C6 A9 CC 1B 60 1D B1 5E 1B D8 2C 74 28 58 97 5D'\r\n 'EC FD D4 8F 3B 9D 0E 43 1A BD A3 D1 6A B3 DA C2 99 B6 8B 4D 2A C7 C3 87 60 BB CB 14 60 15 35 36'\r\n '09 6C 15 32 25 9B 4B 4C CA 66 14 AA 9A 7D A1 4C D6 C8 BB 96 B9 8B 9B F5 AC 37 37 03 3B CC DA 4E'\r\n '4F 6C 36 3C 85 66 D8 C3 FB 1D B2 5F 8B 56 2A E7 24 86 FE 2A 4D 4F A3 F1 11 F8 D0 71 E5 54 A2 94'\r\n '1B A1 52 9B 38 FB B1 B2 EC 1B B1 D9 51 D1 EC A1 79 29 31 4A B5 24 DB 05 60 A8 0C A2 A0 95 89 3B'\r\n '97 58 91 65 5D 96 9F C9 CE 3F 23 92 4B 26 BE CB 20 B2 59 19 29 F9 4B 4E 32 49 64 B6 0B 0C A7 15'\r\n 'FB 11 88 99 D8 3D 80 C0 B2 06 4C B7 AB 5B 37 31 59 57 F5 7D 55 78 DF F5 9A AD 9A A4 C6 52 2C 2A'\r\n 'C2 2A 9C 6E 03 05 C3 E1 42 A3 BF 2F 5E F7 7B BE 7A B4 BC DD 75 DB 59 E8 B1 9E 8B 58 98 D6 AD 5B'\r\n '1A B3 CD F3 D4 C7 34 D3 F9 7B ED 4A D3 2F 3D 79 BE 7D 81 A1 4A CC D9 7B BF C2 F3 CD 5B E7 A5 E3'\r\n 'F6 BF 62 DB 67 33 9F 64 B4 37 B0 F2 92 B7 19 59 57 B3 9F 7D 4E 62 7F DE F0 76 7E 17 85 98 8E F0'\r\n '64 33 3B 3B 5B B5 9A 7E 3C B9 5E EC 4A D1 6C 15 54 4B 45 40 02 85 1D 2C 06 0C 89 4A C4 DE A7 73'\r\n 'E0 8D 44 17 BA 25 74 67 6C 5B BF B2 CF 93 F1 D4 95 F5 17 E7 35 0C 39 38 F1 01 C8 02 D8 6E 1B 1F'\r\n '5E BE 73 2B D8 78 5B CF BF 97 CC 6B B7 9E 3F 93 47 33 87 ED B1 31 AD 58 78 30 FD 8B 60 58 75 77'\r\n '58 35 83 F8 BC DC 1F F4 5D 4D 46 AB 4F A9 B3 FD B2 FE 55 D5 97 7E 5F D0 F7 2B A6 C9 89 8E 97 A3'\r\n '57 E2 F9 18 AC 3F DD 78 FA 7D 0E 63 75 0D 99 39 8B CC BC E2 A9 AD 92 57 4D 36 9A DE 98 99 77 49'\r\n 'AB 7D 95 21 B1 E6 6F F4 38 ED DC 7D E9 58 AD 27 91 9B A5 9B DE FC C9 F2 75 F5 91 8F 97 7D A5 EB'\r\n 'A8 A4 22 C8 30 BA CC 52 71 BD 87 B9 EB B7 E2 77 CF 77 2D D6 EE AA EA C6 8C ED 8D C1 D3 1B 93 20'\r\n '6D B2 DC 54 BA F5 9D DA AC E4 8A 6C 17 D8 23 3D E5 AF AB 91 B3 5B 34 DA 76 20 07 E6 F9 16 43 C7'\r\n '9F AC 5D D5 9F C0 B2 2F 18 A0 31 87 90 71 CC 41 E5 76 EE F2 EC 9D C4 27 5D 5D B2 A0 F2 AA EB B6'\r\n '9F B3 CD EF 7C 14 BB 86 A6 35 A8 49 03 26 4A 04 40 63 0E EE 27 FD 73 3E 3E DF CF EA B7 BE 1F 06'\r\n 'D0 EF BC 33 F8 BF 36 77 63 DE FD 5E 1B FB 7C ED F2 B2 F3 FD DD 82 EB 7A 3E 77 93 2D 65 E1 68 B5'\r\n 'E6 BC 8C 7C 47 C8 6B 8A 73 9C 44 29 CA 72 50 94 23 13 D6 77 7F 17 5D 4F 74 D0 8F 74 DD 1C 37 DE'\r\n 'E3 35 4A 68 27 74 AD 95 57 EF 4B D6 5F 46 5F CA E1 2A 25 C5 B4 D5 DF 2D 2D 6D 73 A9 01 6A 5B 99'\r\n 'BF EB 56 CF D5 87 7D 57 DF F1 1D 77 B2 FA 90 A3 9E F1 5A 8F 53 EF F0 D2 63 17 A6 C6 A4 A1 FF 6B'\r\n '37 3A 56 4E 72 89 4C A9 E5 AD D6 DF 35 AB 98 B5 9C BD 55 55 85 E6 AB DE F4 A5 65 6D B2 92 6B BB'\r\n 'DF FD BF 6F C3 6A FB 7C 68 EF 7B 2E 2C B2 EE BC 4C 7E 47 25 93 DE 2D 95 C7 C0 B9 B1 33 F7 B5 06'\r\n '44 FD 53 E1 CD 7E CB 65 B2 AA B7 E6 E0 1F 7B 63 D4 70 26 C6 D7 C5 9E 8B 88 30 C8 05 C2 C7 12 47'\r\n '86 D3 DA 32 7B 52 C6 BA 99 0F 7F C9 4E 51 C1 32 A5 ED 75 3B 63 84 6C 0E 11 C2 3D A8 B1 A7 2E ED'\r\n 'AC 77 26 C4 EB 27 64 A6 45 2D 7A DD 57 F1 C2 E2 71 71 06 24 88 44 22 11 08 84 42 21 10 88 44 22'\r\n '11 08 84 43 2D E5 3A 23 A2 11 08 86 38 C6 98 F2 7C 88 6E 8A 02 60 D3 94 04 F9 C5 3D A2 9C A7 3D'\r\n 'C3 EB 33 67 04 EB 13 24 D1 85 36 A6 10 A2 38 27 58 CE 9F 19 C2 37 26 DC CF 1C 23 AC 50 94 24 07'\r\n '0C D9 9A 43 6E 6E 0D A1 B4 34 C4 E9 B3 36 84 C1 B4 37 87 D6 66 4C C1 BB 37 86 B0 D6 1B 53 5A 6B'\r\n '4F 84 D5 9A C3 5A 6A 49 83 E5 36 A7 CC 6F 0E 41 36 7C E6 52 6F 3C 9E DB 7D AB 3F 2A E5 EF 3B 6E'\r\n 'AC 98 9C 46 6A F9 36 4D FB E9 67 DA C6 25 94 6B 2D 8B 2A 26 E9 6A D5 B5 BD BB 57 68 4B 58 4E 0C'\r\n 'AB 00 AA B6 A9 BF 74 6E 89 CF 3C EB CD BC D3 99 73 0F 2A E5 9C A3 F2 1E 3D F8 ED DD AA DA BB 34'\r\n '98 CF 89 31 AC 4B 48 C4 D6 7C 70 B8 9D 47 6D CA 80 5B 8D 24 86 FF 91 AF 8F 86 AA 1C 0A 7F 77 CB'\r\n '73 94 DB 5A AA 1E B9 6A 96 F3 A1 D2 FA DE E1 C5 AE 91 91 5B 88 40 BA 30 B7 36 57 9E 52 0D A7 EA'\r\n '36 84 BB 14 27 52 DC E9 0E CD E7 7B 78 BC 61 ED B8 76 6B 04 C6 99 80 DA 86 D3 21 DD 83 AA 5F 50'\r\n '42 58 F4 C2 18 3E ED CF 51 F5 E2 98 9E B1 DC E4 0A 9C 4F 6A E3 8A C9 E7 BE 88 00 90 A8 83 FA A8'\r\n '1B 06 CE 2A 56 D6 8B 84 94 57 D2 96 F4 C9 91 DD 31 A6 1A D3 9B 33 0F AC CD 8C D0 0E 1C 8E 53 DF'\r\n '91 C9 CB D1 86 9C D9 53 38 CE 33 8C E8 82 C5 D2 6C 5E 9C 79 54 C2 BB 24 95 89 92 98 1C 24 4A 4E'\r\n '87 9E 15 37 72 D2 2B F0 7A 69 02 AF 9D 8C 8B CA AB 6E 26 5F 8D FE 56 A2 45 17 15 EB 3C 68 A8 BA'\r\n 'FF 0E 02 EA AE 0A A8 50 2B 15 F8 F7 6D B1 56 2A 91 61 95 27 9A DC 22 E1 2A 2C 3E B0 C4 6F F7 FB'\r\n 'ED F5 8F 27 A5 BE ED F8 13 D5 EC BF 2C 85 F5 E8 77 D4 9D 75 BA C3 EF 67 50 DB F4 ED DA E9 0C 79'\r\n '77 6D 99 59 15 91 5A B5 AA 59 35 93 53 0B 50 9F 4F FE E6 FD 0A 5D 4B A9 75 95 D0 4B 4B 49 CB 4B'\r\n '4B 67 FF A6 7F 16 A7 79 4D B5 AE DF D0 3F 9F 73 DD AA B7 26 BD 25 71 7A F7 84 87 0A F2 83 62 CA'\r\n '41 06 88 C1 3A 3C 8F 7D 6B D4 D2 6F 74 AF A4 F9 FA 70 DF 1E 4C F2 3C 99 C9 55 69 5C BB B7 F0 2E'\r\n '6C 6D 9D B6 7B 52 49 8A D8 93 55 F7 0D 82 6E 09 B3 42 30 9C 9C 25 FF F4 CC 9A AF 63 AA EB CB A0'\r\n '7B 8B F0 67 76 CD FB B8 15 FC 73 38 6E 6F 6E BE AF D6 CC DD DB DA 5E 27 CE 88 97 DF 12 9A 5D 35'\r\n '2A 2E 74 BB 8E 5F 71 69 69 3E A4 3E 43 16 31 56 04 5D BB 01 79 24 A9 A3 18 31 88 04 42 27 6B 14'\r\n '0A 10 08 C8 C5 84 16 04 63 18 41 21 11 8C 49 11 23 06 31 56 24 58 C1 8C 51 C4 42 81 01 24 41 83'\r\n '01 8C 08 31 50 90 48 C5 42 30 02 B4 01 28 04 11 8C 61 18 0C 23 04 4A 42 91 48 40 84 55 28 94 10'\r\n 'A0 24 20 0C 20 9D 84 0A 45 08 10 C7 F6 D4 14 B1 10 2B 44 42 0C 00 B1 4A 22 C0 21 DA C4 A4 06 44'\r\n '08 24 56 31 08 11 13 B6 82 14 62 48 AC 48 A4 8A 32 32 10 20 01 06 2A 07 8C 14 6D 8A 5C B5 90 0A'\r\n 'C1 14 61 10 08 11 24 00 91 20 91 8C 49 18 C5 19 16 2B 05 24 06 04 0C 3C 68 C4 08 91 54 89 10 8C'\r\n '8C 40 84 00 22 91 48 30 91 50 90 49 18 31 55 24 06 D4 82 34 8A 6B 22 81 46 A2 8A 89 42 20 46 04'\r\n '80 84 80 90 20 C9 20 A9 18 A4 82 21 18 88 FB 70 16 84 56 10 02 11 06 10 08 44 18 31 46 40 02 24'\r\n '1D A3 00 68 40 49 01 61 01 61 11 23 10 8F A7 45 68 C4 18 C0 42 04 44 83 15 EE 62 09 46 29 18 2C'\r\n '08 09 02 03 24 61 20 09 CE C2 90 45 90 16 46 30 42 44 46 10 0B 04 01 A1 06 41 58 C1 A1 06 90 04'\r\n '90 8C 44 A0 41 A2 C4 53 B7 A3 55 54 18 C2 0A 30 60 84 82 C8 A3 12 00 46 22 C8 09 08 00 42 28 91'\r\n '80 92 02 04 64 8A 04 52 0A 11 20 04 08 A8 40 8A 04 80 24 82 30 81 18 28 C7 D6 A2 A9 48 83 16 0A'\r\n '81 20 31 91 80 B2 46 29 08 09 06 31 84 60 01 12 06 39 90 85 12 20 C1 88 DC 48 77 14 38 7A A8 56'\r\n '08 42 20 91 62 A3 04 88 B9 4C FE EF 21 73 BA 84 A7 9D CC 32 A9 57 7D 70 50 E4 18 C4 C5 22 98 9B'\r\n 'FC 24 4D 07 E3 9E 59 F5 6C 6C B3 A3 E1 DB FD 19 0E 05 D7 E1 85 E5 CD C5 A8 4F 9C F2 DE 73 CE 79'\r\n 'CF 3F A9 01 72 3A A7 58 CF 1D 33 3E 5E 4F E4 7A 46 7C FD 49 63 AC 68 0E 99 A1 2A CD 11 60 68 CB'\r\n '03 48 7F 93 D8 2B 09 72 31 85 34 A4 53 E8 22 9F 41 14 8A 56 11 6E 77 38 DB CD 4B 76 29 ED 4A BB'\r\n '31 EF 25 D8 94 D5 86 5E 3F 91 30 5A 30 76 6B 44 57 45 22 91 48 A4 52 29 14 C7 18 F2 29 7A 22 92'\r\n '84 53 D8 33 26 64 8A 6B CF E4 D1 D5 A3 AA EB 89 BB AC 5E ED 3B 4F 6E 63 71 BD 99 A3 E2 B8 C3 CC'\r\n 'B1 F6 0A 64 67 A1 A8 DC A4 54 D5 24 3E 36 D7 6D 2A DD E2 83 DC CD 51 D1 B6 8C A3 38 47 08 A3 BA'\r\n '3B B5 76 14 F1 ED 0E B0 76 84 F7 8C C1 61 A2 8C 4A 9B 53 7E 6F 4C D1 60 66 8D C1 BD 35 86 F8 DD'\r\n '9F DC 7C 7C 7C 7C 7C 7C 7C 7E E6 E7 DC F8 F8 F8 F8 F8 F8 F8 F8 F8 F8 F8 F8 F8 F8 F8 F8 F8 F8 F8'\r\n 'F8 F8 F8 F8 F8 F8 F8 F8 F8 F8 F8 F8 F8 F8 F9 92 32 47 B6 3F DF 2C B3 4D EC 2F B6 C3 42 68 8F FE'\r\n '30 66 0F 03 86 24 C9 32 4C 93 24 C9 32 FD 27 EC 70 55 B0 43 A2 47 49 BA 4C 93 21 61 24 DE 6A CB'\r\n 'B5 AB 2E DC 68 CD 79 01 01 01 01 CA 35 98 C7 11 EA 0F F7 6C 58 77 32 D2 C4 C4 B6 99 14 33 49 93'\r\n '54 88 E2 61 27 57 15 47 BD 9D E3 AF 7D 65 9D 95 AA FF 92 6B 2F 0D B9 74 F7 ED D8 A7 B2 D4 8D C1'\r\n '3D A6 09 38 3E 2B AB 5A 4A F6 42 2F 14 EF 81 74 81 B9 8D 62 0C DB 11 E8 07 6B D7 92 22 22 D1 FA'\r\n '89 BD 50 C3 BE D8 2E A1 9D EC FE 92 17 79 F3 DB AE 6C 63 12 B9 B1 8D 5B 1E 23 46 2E FF 87 41 6C'\r\n '5D FF 71 9C F8 96 C5 EA 37 AE 1F 2E 76 DB 29 2A D8 76 8C 9A C9 DA E8 95 9D CB 17 64 ED 55 A5 CB'\r\n '16 FC 87 B1 70 B2 1E BB 8F 5D D7 28 5D E2 77 6C DB 8A 77 12 79 6E 15 BE 2C 55 2F BB 6F 35 BF BB'\r\n '70 7A 7E D4 B6 63 72 72 0E 26 51 E7 EB 10 F3 96 30 32 49 90 0C 81 85 F8 30 07 1E 2E 82 94 55 6F'\r\n '33 03 C1 1B C8 2E E2 EF 23 5B F3 B6 C0 8C 21 BA 1B A0 46 DF 71 17 71 02 B9 46 D9 36 83 67 B3 10'\r\n '4B D4 0E 18 DA 6D 3E 47 4D B3 A7 44 D9 8F 63 20 42 B7 A0 72 4F 44 71 98 1C 65 96 54 E4 99 8C BB'\r\n '0D 97 63 82 70 4A BF 14 CC 9D 1E 59 C6 88 B7 83 97 BB 78 5E 99 B7 8D F1 79 FA 54 E9 3C 8C D8 1B'\r\n '5E 75 20 3A 00 E3 B9 2E 29 C8 72 72 75 A9 66 9E BB FF 8D 3D 24 E5 7A EB E3 A4 29 7A 93 52 28 CF'\r\n 'A6 53 F6 AF 95 CB 1C 20 79 9C D0 FF B9 15 32 14 8D 48 D1 23 D5 56 F9 C5 2E 28 88 84 48 83 08 0B'\r\n '04 80 C8 81 23 08 29 08 00 11 80 90 82 E7 20 85 20 02 48 0C 8A 32 E2 80 72 E9 97 4A 15 88 29 C0'\r\n '48 51 82 A4 80 10 62 10 8A 48 29 08 84 52 08 C8 82 48 01 12 28 C6 2A 40 82 24 88 A1 18 0C 48 AC'\r\n '08 A8 41 83 18 01 01 80 84 18 80 40 22 8B 18 8A 46 22 1B 38 00 52 0A C4 8A 84 18 00 B0 90 83 22'\r\n 'AC 08 9C 26 51 89 18 C0 8A 2C 8E 44 96 DC 99 BF C6 D6 71 8F BA 56 CB 75 BE 2E 17 3B FD 7B BA 4C'\r\n '13 79 BC C1 9B BA FB AF 06 57 D9 98 8B 4C A1 83 56 B4 D7 9D F9 D2 1B 93 FA 0F 7C F9 E7 0F CD FA'\r\n 'D7 32 F4 31 D1 58 9A 43 BF 45 4D 31 2B C0 04 00 97 C1 7C 72 50 E9 11 48 08 90 28 49 52 B9 00 36'\r\n 'CB CD FE 3F C2 B7 AE FF 2B 01 DE 7D 74 B7 3E 2F 89 C6 F8 FB 9E 2B 6B F9 6D 42 27 E5 4F C8 9B C1'\r\n '30 53 74 99 04 F5 D3 8A F6 A0 6B 75 A9 C5 89 92 D3 EB 13 E8 26 3F A4 F9 BF 37 5F DE E3 44 72 30'\r\n 'F4 7C 14 FD 7A 3E 69 36 E9 E8 27 A2 9A 94 D0 FA 61 9F FA 3E 9D 50 37 1F 4D 3F D9 3C E4 E8 53 30'\r\n '9F CC 26 91 30 7B 40 DD 79 BF 46 AE 7B CB F3 7C 6F F3 D1 47 25 3B E1 F2 B2 BA 5F E1 55 D2 BA 58'\r\n 'FE E6 5C 58 D6 31 8C A9 52 F3 7F ED 4E 56 DC E6 AF 5B CA 5F C2 E1 B1 C6 5E 29 3E 59 7F 8E 9B D5'\r\n 'BC EF 9A CF 28 EF 29 B3 A9 C7 98 A2 BC F6 5C 65 A6 D6 9C 45 7F 76 F2 F8 04 F2 92 35 C8 CF 31 FE'\r\n '97 82 FA CD 73 83 96 51 CC 71 5E 4A 5B A3 D6 E2 7B B7 CE C5 D3 C5 DF 08 1F 88 38 C9 D7 A5 9C 0B'\r\n '54 EC AD 56 BF 2C 1F 73 C3 2A 9E 72 55 58 9C 0A DA CE 53 8B EB AD 25 D3 69 69 38 C7 CC BC B5 BC'\r\n 'AB 7D 28 F9 A9 C4 8A 01 C9 B1 56 32 11 10 8C 00 63 15 0B D8 A8 51 80 24 60 AC 88 04 80 00 46 02'\r\n '24 82 04 88 A9 20 AC 83 DF B1 40 C1 92 92 8F 20 EF 5C A3 9A 7A 47 EA 3A F7 26 EA DF 6D C2 82 16'\r\n 'CC 5E 22 77 EE A2 81 1F 5C 3C 10 AA 1B B5 2E 06 0A F7 D4 C2 4B CF 4D D0 04 E1 88 1D 48 70 C3 22'\r\n '12 CA 90 15 E7 D2 60 78 4D C3 C8 3A 67 CD 7C 36 F9 BE 72 0E 59 E3 1D FB 87 10 2D E6 85 9E 96 DE'\r\n '8E B9 B9 1B 9E F2 BF CC F3 EA 36 0F D6 70 82 05 CF DD A3 F1 9D 95 2A EE 38 FA 8F B9 FF AE 39 ED'\r\n 'DC F3 5C 02 E9 8F 5E CA 3F 0D FC EE 79 E7 07 F6 0F 78 3A 07 E5 B9 16 E1 F1 5E 55 FB A3 C7 3B 67'\r\n '18 E3 DF E7 72 6F C4 71 28 16 58 5F 49 32 48 70 5F B8 40 0E 4C B7 DE 23 27 AC 5E 32 EF 8D E6 3A'\r\n 'F5 DC A7 50 EA 31 7C 4B CB C9 BC EC DE 2C DB 66 CD BB E3 7C 7F 3F A1 1A 11 F6 68 F5 E4 5A 7D DA'\r\n '1C 80 2D 33 C0 DE 0F B9 0A 83 FB 65 4D 14 E4 CE B2 62 CC 71 54 7C 9D 60 6E 03 64 BB 40 CC 86 91'\r\n 'EE 0C 80 52 F1 83 7C 1B 90 ED AE 08 7D 8C AD 39 F3 0E 5D 08 18 B2 31 81 08 AB 12 21 FA 66 6E 98'\r\n '8F 54 92 33 96 65 63 95 C3 06 B8 3E 60 5A ED FE F8 68 4B 58 56 30 9E C5 B1 6E 41 5C 9B 93 67 82'\r\n '77 22 36 77 23 0E 07 EB F2 3B A1 EB 79 5A 92 24 89 3F 02 E2 E5 DE 23 C1 71 D4 B9 E0 18 4C 5A FE'\r\n '0D C4 8B 8C F5 1E 6D B4 C6 B4 E1 1E A8 EC 0C BF BC D9 96 CD 52 35 56 79 D3 1A 61 E9 CD 72 9A 5C'\r\n '85 52 DE 07 D8 7A 6A B8 15 E3 49 AD F1 62 D7 FA 14 DD 63 24 67 B7 01 DF 7C 81 58 A0 8D 72 F1 79'\r\n '10 79 D4 A3 C1 3E 01 F4 66 33 A5 BA 3B 4D DC 3D C8 DF B7 20 58 09 2F 17 DC DC 14 A6 13 33 11 1E'\r\n '9A C1 44 E8 EA D6 76 45 08 E9 6D 3C CF 51 91 40 6F 48 0C D9 4A 3C FA 04 49 FA BF B7 E2 78 98 1F'\r\n '47 C5 DF ED 7F 2F 0F B0 EC 7A 4F A3 A5 6F CB 63 4B D1 3B 41 25 91 9A CB 5B D9 3E F4 0B 56 6C AB'\r\n '2E B3 6A D1 45 F6 93 ED 2B 4F 8B 0E 0F EE D0 C7 9A C7 69 95 DC AD B2 54 B7 55 BB 7A BB F7 75 ED'\r\n '37 88 75 C3 37 CC EC F3 56 29 54 D1 58 90 A5 56 EB A6 35 2D 92 76 94 C7 40 93 4A B0 62 C5 E3 11'\r\n 'D2 98 59 0D 2E 59 89 89 33 CA 5A D9 E7 91 CF A7 F4 30 79 99 66 3E 35 1B E2 BB 8C 18 F3 72 17 50'\r\n '73 11 33 9C D3 5C 5F D3 E6 3A 1B DB 2C 78 7F E5 E8 3C 9F EC AC 1E 57 F1 64 7A FA 4F C9 9B FE FC'\r\n '3C 20 EB C2 7F E3 0F A0 1F A4 39 61 7D FD E1 9D E8 74 07 7C 63 EF F7 96 8B EC 67 02 1B C3 80 4C'\r\n '43 D4 CD 0E A4 F3 E0 B7 21 F0 38 5C E6 AA A8 6D D5 45 DD E7 B3 78 09 20 95 52 09 55 20 95 55 55'\r\n '55 55 55 55 55 5B C4 B7 66 64 25 C1 02 0A A4 0A A8 A0 05 BB BC CA 65 2F 2B A8 5B 5D 5D 5E 58 52'\r\n 'DD DE 7F F1 77 24 53 85 09 06 65 EE 33 F0'\r\n}\r\n\r\n\r\nLANGUAGE 0,0 CASE UNICODEDATA LOADONCALL MOVEABLE DISCARDABLE\r\n{\r\n '42 5A 68 39 31 41 59 26 53 59 51 64 61 BC 00 2F 8E FF FF FF FF FF FF FF FF FF FF FF FF FF FF FF'\r\n 'FF FF FF FF FF FF FF FF FF FF FF FF FF FF FF FF FF FF FF E0 38 CB 80 00 00 00 00 F0 F8 50 7D 8C'\r\n '0C 00 00 00 00 00 00 38 14 48 91 40 0E 40 0C A2 29 40 00 77 DF 10 01 F0 38 0D CA 76 CE 4D BD 3B'\r\n 'DE 00 00 C5 01 81 B3 01 80 00 60 89 2B 64 88 33 20 04 C0 00 00 00 00 00 00 00 ED C8 07 00 00 00'\r\n '00 7D 60 55 53 FF D5 4A 85 1A 3F D5 43 1A 80 7A 99 31 8D EA 41 30 34 D0 69 A6 53 44 34 DA 9E D1'\r\n '9A A7 A6 53 1A 31 A0 4F 50 6F 50 06 FC A8 84 DE 90 D3 40 32 34 1E 69 4D A9 93 46 99 EA 1A 03 26'\r\n '9A 0D 1A 34 0C 8D 35 30 C4 13 D3 23 4D 34 4D E9 34 79 42 68 D5 43 29 FE AA 41 80 4A 7F A8 89 9F'\r\n 'EA 80 3F 4F 2A 00 07 E8 4F 54 3F 54 03 F5 26 41 EA 7A A6 DA A7 A8 C8 36 81 E8 9F 95 3D 28 99 FA'\r\n '94 F5 35 3D 41 88 D0 00 34 69 EA 3F 54 33 49 98 0D 53 68 8F 53 7A 90 03 F5 40 D1 A3 47 A8 DA 8D'\r\n 'A2 79 47 A6 A3 CA 68 D3 40 F5 1E 4F 4D 4C A0 95 4F D2 46 D9 29 52 A0 00 00 00 00 00 00 0D 00 01'\r\n 'A0 00 00 00 00 00 68 34 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 1A 9E 98 4A 4A 69 26 A0 00'\r\n '00 00 00 3F 54 00 26 00 00 00 00 00 00 00 00 26 09 80 00 00 00 00 00 00 00 00 00 00 00 98 00 00'\r\n '09 3D 54 95 4D 49 EA 68 0D 00 60 8F 50 FD 51 90 00 00 D0 00 03 40 00 00 1A 0D 00 1A 0D 00 00 00'\r\n '07 FA A8 34 D0 00 00 1F A9 00 00 01 A0 00 01 A0 00 00 1A 01 21 51 4A 9E D2 7A 4F 41 4D A6 43 49'\r\n 'EC 49 B5 32 69 E5 31 34 69 0D A4 1A 0C 11 E9 A6 A6 26 43 3F D5 23 4C 8D 33 44 36 44 D2 64 FF D5'\r\n '48 DA 4D 34 C9 EA 62 7A 8C 99 34 18 00 09 A3 08 7A 09 8D 34 61 26 99 31 31 30 02 1B 6A 9B 4F D5'\r\n '13 10 7A 46 D2 33 6B B6 DB EE 37 3F 67 DB F7 7D FF 86 E9 46 EF 79 BD DF 6F F8 1C 1E 14 71 4D A0'\r\n 'F7 05 F3 FC 2C 38 18 90 71 61 63 63 F8 32 10 87 93 13 2B 2D 14 B3 74 3B 1A 3E CF 67 B5 63 57 AB'\r\n '29 4A 52 94 A5 9C 85 0A 14 28 50 A1 42 85 0A 14 28 50 A1 42 EC 94 A5 29 76 05 29 4A 52 B2 CB 3E'\r\n '0F 07 83 C1 E0 F0 78 3C 1E 0F 07 83 C1 E0 F3 BE 00 39 CF 3C F3 DF 3E F3 FF 57 F6 58 F2 22 A4 88'\r\n '99 32 49 8B 24 4E 44 64 52 7A CD 79 96 BB 6D 79 96 BB 6D 79 96 BB 6D 79 96 BB 62 32 29 22 32 29'\r\n '22 32 29 22 32 29 2D 79 96 BB 6D 79 96 BB 6D 79 8A D9 5C 46 0C 6D A3 E4 F2 BB 6F E2 EC 59 BA F7'\r\n '6E EC 59 BA F7 6E EC 59 BA EF 57 76 36 B7 66 DB BB 1B 47 76 6D 9B B1 B5 BB 36 DD D8 F2 DC E8 F4'\r\n 'D3 F5 CE AB 37 23 68 BC 6D A2 56 B7 23 5D 95 76 5E AC 37 2C 0D 6E 45 23 45 FE 2C EE BD 54 6D AE'\r\n '89 97 2D B2 DA B3 2D B2 CC B9 77 77 63 D5 AF 66 EE C7 9B AF 66 EE C7 9B AF 77 6B 37 24 91 99 92'\r\n '49 E6 53 2E 5B 63 33 24 90 46 DB E8 C9 24 6D B6 DB 6D F7 E7 7F BB 75 5B 57 75 AB D7 37 75 EE EA'\r\n 'B6 A9 33 AB 6F 69 BB F3 4D F5 D7 5D 49 D7 49 6E EE C9 BA 97 6D DD 92 54 95 F4 3D D6 DB 7D 9A 49'\r\n '36 FB F9 8F B2 49 24 BB E9 75 0A 5D 77 49 B2 49 DE 92 49 7B D2 49 64 92 B2 7A 92 5D B6 DB BB 6D'\r\n 'B6 C3 24 9B BA 2D B7 61 32 48 E1 8D B7 4C 98 33 31 94 92 09 24 CB F6 9D BD 47 6E 5B 6B B9 55 B6'\r\n '3D CA AD BB 61 B9 6D DB 0D CB 5A D9 92 65 78 DC 4C B7 11 78 DC 4C B6 D3 2F D8 A5 6A D5 7C 29 AD'\r\n '28 A3 71 A5 6B AE AC 78 D3 59 E1 45 1C 92 35 91 47 23 59 14 76 D8 EE 55 16 59 AE CA DA 89 47 6C'\r\n '8E E5 56 B5 32 29 D9 AB 6A A5 B6 99 6D A6 5B 6D D9 36 CA B2 DA EC AB 2D B5 8B 24 8D B6 DB 6D B6'\r\n 'DA 49 24 95 0D B6 C4 92 49 24 90 95 99 99 99 99 88 A5 19 78 DB 0D 26 8A 59 91 F6 5E 1D 9D 3C B5'\r\n '5B 11 91 49 11 91 49 D5 79 96 BB 6D 79 96 BB 6D 79 96 BB 6D 79 96 BB 62 32 29 22 32 29 22 32 29'\r\n '22 32 29 2D 79 96 BB 6D 79 96 BB 6D 66 D5 6C 57 2A 91 B7 9E 26 B5 DB 7B FB 16 6E BD DB BB 16 6E'\r\n 'BD DB BB 16 55 3A 96 C7 DE 8F B7 57 AD EF 6F 6E AC 6B AE A7 56 EE C6 D5 76 58 D5 56 E7 7B B6 76'\r\n '8E 76 88 CC 6D A2 F1 B6 89 5D 37 23 5D 2A ED D8 CC C9 03 57 22 91 A2 FC 29 D7 6D ED A8 EE EB A2'\r\n '65 CB 6C B6 AC CB 6C B3 2E 5E B7 5A DA AB B7 63 CD D7 B3 77 67 88 CE BA 7D 6E D7 D6 6A B6 C6 66'\r\n '49 23 33 24 91 99 24 61 B6 DB 76 46 DB 6D B6 F2 4E ED DE DD DD BB 2D DA BB D6 AF 0F 77 5E EE AB'\r\n '6A 93 3A B6 F7 4D D4 B7 77 64 DD 4B 77 76 4D D4 BA DD D9 25 49 5F 0B 75 B6 DF 66 92 4D BE FE 78'\r\n '6A 77 9A 49 25 DF 4B B4 29 76 EF C9 B2 49 DD 24 92 B6 DC EE 12 4A CF 52 4B 76 DB 65 32 49 B0 89'\r\n '24 DD D1 6D BB 09 92 47 0C 6D BA 64 C1 99 8C A4 90 49 2E E9 93 BB AD EC AD AA DA AD AA DB 1F 59'\r\n '55 B7 6C 37 2D B1 99 92 6C 7B 72 DC AF 1B 89 96 E2 2F 1B 89 96 DA 65 F8 72 B5 6A BE 14 D6 94 51'\r\n 'B8 D2 B5 D7 56 3C 69 AC EF 45 1C 92 35 91 47 23 59 14 71 63 C6 9A C7 AA 38 DA 89 47 1B 86 6C 56'\r\n '64 53 B3 56 D5 4B 6D 32 DB 4D B6 D9 B2 6D 95 65 B5 D9 4D B6 31 24 92 C9 24 6D B6 DB 69 24 92 50'\r\n '36 DB 12 49 1B 6D 93 33 1B 49 66 62 29 36 5E 36 C3 49 A2 95 64 13 CF 41 23 0F 7C 57 1B C2 38 E9'\r\n '71 1B A5 C7 A2 37 1B 9D DF 3A 51 A3 46 8D 1A 34 68 D1 45 14 51 45 14 51 A3 46 8D 1A 2C 51 45 1A'\r\n '2C 68 B1 A2 C5 AB 76 95 AA F1 2A F8 56 BE 19 5F 0E B7 C4 2B E2 52 FB 4D 73 0D 2C 09 A7 5F 36 83'\r\n '30 F9 91 81 F6 DA E6 98 1F 71 AE 6D A5 F7 59 CE 31 73 AC FB CD 2D 40 CF BE C5 CF 33 9F 62 E8 1F'\r\n 'E0 68 D4 B3 F0 B1 06 31 85 58 B9 55 B4 4A AB 78 55 71 12 AB 19 31 DB 84 15 58 D8 55 73 12 B9 77'\r\n '2D 63 71 B1 2A 8B 98 B2 1B 8C 4A AC 74 58 FC 7C 4A AD CA 2A B2 11 15 6E 75 5D 52 8C B5 DE 4B 74'\r\n 'A5 55 91 95 64 A0 55 93 AB 75 A5 55 94 85 5B B4 10 83 2A F5 8D 44 06 8D A2 C6 C6 B1 5A D7 EB 36'\r\n 'DE 83 17 A2 C3 D2 68 F4 D8 7A 8D 1E AB 47 AC C3 D7 6B FA B1 7F 66 1F DD A3 D8 61 A1 7B 11 AD 13'\r\n 'BF 18 7F 86 1E CB 0D 93 0F 69 96 18 7B 6C F7 18 7F 96 7B AD 1E FB 17 FA 6B FD B1 7F C6 BF EB 46'\r\n 'CD FC 0D 19 32 BB 8A 11 5E 32 BD C2 94 57 8D AE E6 90 AC DC 6B C7 52 15 E3 EB DC A9 45 79 09 5E'\r\n 'E7 11 5D D4 2E AE A2 2E AE A5 77 70 2B DD 2B C8 D2 57 92 AF 27 4A AF 75 AF 29 4A AF 76 AF 77 A5'\r\n '15 E5 60 57 BC 42 BF 8B 11 5F C6 CD D1 5E F3 15 79 69 5E F5 02 B7 7A DB CF 67 33 5B DE 64 E5 CE'\r\n '23 3B BE F0 13 8C 5C 49 EC 9A F0 2E 95 FB C5 71 A5 C7 4A 97 AC A1 AD 2E 3C 1C 95 A4 09 07 85 F5'\r\n '3F 0B EB A7 75 DA 68 AF 0D E1 AE 74 D1 A3 46 8D 14 51 BB B7 14 51 45 14 68 D1 A3 45 7C 0B 8F 10'\r\n 'DC 51 46 8D 16 34 58 D1 63 6D 7C 12 BB A6 DA F0 FE 1C 86 19 A4 25 CC 34 0A DD 34 26 31 51 89 86'\r\n '09 81 48 C0 0C D3 13 18 92 39 37 A5 69 69 19 7C D2 BD B7 B3 6D BA 1B 16 8D 96 B4 94 BA 12 DA 5A'\r\n 'C1 34 B9 2A 4B 27 42 DB DA 5C 8B 58 46 96 89 AD 0B 0B C7 A0 C7 18 7A 10 E0 CC 55 0B 3E F8 F6 16'\r\n 'F9 E8 17 0C 4B 00 C1 09 1C 73 49 06 9B 6F 22 12 B8 60 9B 04 D8 1C 0B 59 76 92 4B 00 F8 D6 8C EE'\r\n '72 23 8C CD C0 E2 F8 A8 19 AA A2 38 97 C4 34 7D 66 60 D8 60 DF 0E C3 86 FA 70 E1 76 A9 C2 33 83'\r\n 'FA 50 33 2D 70 4C CC 30 E0 59 97 E5 A2 32 EF E8 B5 F4 1F 00 D1 6A 33 96 AA F4 B4 78 65 E1 3D FC'\r\n 'AF 09 F0 1F 17 A1 90 A8 A1 08 6A 49 AE 22 8A 22 29 0A 92 6B D4 B8 E3 8C 30 D6 2C 30 C3 59 99 AE'\r\n '22 22 88 8A 42 A4 9A 21 0A 8A 10 86 A4 9A 22 8A 22 29 0A 92 6A 10 AC 16 2C 30 C3 59 99 AC 58 A2'\r\n '22 8A 29 24 21 D4 50 85 45 24 D4 51 44 45 14 52 48 43 A8 A1 0A 8A 49 A8 A2 88 8A 28 A4 90 87 51'\r\n '42 15 14 93 51 45 11 14 51 49 21 0E A2 84 2A 29 26 A2 8A 22 29 0A 92 42 1D 45 08 43 52 4D 45 14'\r\n '44 52 15 24 84 3A 8A 10 86 A4 9B E6 28 A2 39 52 15 24 DC 21 B8 B9 21 0D 49 37 CC 51 44 72 A2 6D'\r\n 'F4 C6 6D AE 46 53 6F AE 5A 69 A3 94 D4 52 48 43 A8 A1 0A 8A 49 A8 A2 88 8A 28 A4 90 87 51 42 15'\r\n '14 93 51 45 11 14 51 49 21 0E A2 84 2A 29 26 88 A2 88 8A 26 DC 84 37 14 21 52 4D 34 D3 43 4E 15'\r\n '24 87 2D 31 8C D3 6F 5E A2 A2 C5 88 C5 98 56 66 6B C4 D7 7D 9D 9A ED 76 76 76 6B BE FB EC E7 B5'\r\n 'DA ED 76 8E D7 7D 95 DF 7D EB B5 DF 67 66 BB 5D 9D 9D 9A EF BE FB 39 ED 76 BB 5D A3 B5 DF 65 76'\r\n 'A2 90 86 A2 84 21 A9 0A 92 90 A2 89 A6 9A 69 B1 9A 6C A6 9B 29 A6 9A 69 A6 9A 69 B1 9A 6C A6 9B'\r\n '29 A1 A6 9A 69 A6 9A 79 08 73 21 51 48 54 74 84 D3 4D 34 D3 4D 8C D3 65 3B 2A D5 AB B2 AE C6 6A'\r\n 'F6 6C D6 59 65 9C DA 69 B2 9A 6C AF 0D 0A C5 98 61 87 39 86 10 87 51 46 53 4D 8C D3 4D 8C D3 63'\r\n '18 CE 9A 6C A6 9B 19 A6 9B 19 A6 C6 31 9D 3B 2A D5 AB B2 AD 5A 6C A6 CA 6C 66 9B 2A 42 A2 8A 42'\r\n 'A4 A2 29 0A 90 A9 08 31 8C DB 4D 36 53 4D 36 53 65 36 31 9C B6 53 4D 36 53 4D F2 CE 5B 29 F4 31'\r\n '8F 4C DB 4D 9D 1A F0 CA 2E 22 90 A9 08 42 10 C2 CC 30 C3 58 B3 0C 35 8B 30 AE 31 66 15 98 61 86'\r\n '18 61 66 0B 30 AC 59 86 1A C5 98 57 18 B3 0A CC 30 C3 0C 30 B3 05 98 56 2C 85 45 21 5C 48 43 52'\r\n '10 84 21 B2 0A 42 A2 8B 30 AC 59 85 71 C4 21 52 15 21 08 43 AE 0C 59 85 62 C5 98 56 2C C2 8C 30'\r\n 'C3 59 85 66 18 61 87 5C 62 CC 2B 16 2C C2 B1 66 14 61 86 1A CC 2B 30 C3 0C 3A E3 16 61 58 B3 B3'\r\n '0D 62 CC 28 C3 0C 35 98 42 10 86 F8 93 70 E6 29 E2 3D 1A C5 98 51 86 6F 0E 73 0F 01 D1 86 18 5F'\r\n '19 9B C3 9C 59 DF 46 B1 66 14 18 62 C3 59 87 66 18 61 85 F1 31 61 AC 59 DE 1A C5 98 51 08 54 87'\r\n '64 21 08 5F 13 B5 86 B1 67 78 6B 16 61 44 31 61 0E C8 42 10 9C 36 53 B2 AD 5D 94 59 13 19 CC 84'\r\n '21 0E B8 6C A7 65 5A BB 2C 89 8C DC 84 21 CD D9 57 B2 B6 B7 B3 66 CE 6E CB 2C E6 EC AB D9 5B 5B'\r\n 'D9 B3 67 37 B3 66 B6 D5 5A 2C B2 BC 0A 28 A2 18 CF 01 38 87 52 10 87 3C 45 21 52 15 14 51 44 43'\r\n '16 18 61 86 F3 2B 0C 2B 88 A4 2A 42 A2 8A 28 88 66 B0 C3 0C 2F 31 E1 0E B8 C5 98 56 61 59 99 AC'\r\n '58 8C 30 C3 0C 3A C5 90 86 B8 98 AB 30 AC 58 B3 0A C5 9E 0A E3 0E D7 67 67 67 5D AE D7 7D 9D 9A'\r\n 'E2 29 0A 8A 29 0A 8A 23 95 0C DE 18 61 BC 4D 6F 0C 35 C6 29 0A 8A 29 0A 8A 22 10 84 39 8A 29 08'\r\n '6B 88 A4 2A 28 A2 89 A1 98 A1 08 75 14 52 15 C3 5D A9 0A 90 86 A2 19 9A 84 21 08 42 71 22 A6 9B'\r\n '29 B1 9A 89 A4 31 8C 63 18 C7 C3 57 65 5D 96 68 D9 15 96 59 65 96 D7 16 A2 6C A6 C6 33 91 8C 63'\r\n '18 C6 59 68 DE CA DE CD 9A E3 7B 36 7C 1F 6C 63 1F 28 62 6C AB B2 CB 39 B8 31 8C 63 2D B1 9A 6C'\r\n 'A6 C6 33 97 DF 78 61 87 7C F6 76 76 67 7D 95 21 57 B2 9A BD 9B 36 6C EB 7B 2F B1 72 D9 4F B2 9A'\r\n 'F0 28 9B 18 C6 31 8C 6E CA BB 2A D5 AB B2 26 31 9B C8 42 1C B6 53 63 34 D3 4D 8C 63 2C B3 65 DA'\r\n 'EA CA BD 15 6A D5 AB BB 2C B2 CB 36 44 F6 AF BE 29 A6 B7 65 5D 97 C5 96 75 76 AA D7 69 BE 29 A6'\r\n 'AD AB 2C BE 2C B2 E5 8C D4 51 49 C5 45 21 B3 66 F8 D9 D1 BD A8 9A 69 BE 29 A6 AD 5D 96 5F 16 59'\r\n 'BB BA B5 7A 2B 6B 69 AB 5D 59 65 16 59 65 91 33 62 69 E8 A6 9A DA 74 51 82 8A 25 2C D3 50 CA 6D'\r\n '18 18 A2 8C 14 51 29 66 E7 32 18 61 70 1E 41 03 84 30 66 76 E2 B0 67 1F 20 33 90 4E A8 80 D5 78'\r\n 'A9 90 3E 30 E9 10 19 39 90 C3 20 9C 82 5B 4D BC CA 69 90 4E 40 E1 10 19 E2 30 76 63 29 EF 68 C0'\r\n 'C6 8C DD 0C 68 D1 34 E9 D3 BA 33 4E E8 68 1E 68 CD D0 C6 8D 13 4B 3A 74 EB 19 A7 74 63 D1 9B A1'\r\n '8D 1A 26 90 C1 D3 A7 58 CD 3A 74 BD 19 BA 18 D1 A3 45 67 4E 9D EB 8A 6E 86 9B 29 B1 F0 C6 75 6A'\r\n 'D5 AB BE 2A D6 F6 56 F6 6F 8D 9C BB 2B 4E 9D DE 66 E8 D1 A1 EE 8D E6 87 BA 33 4E 9D DE 66 9D D1'\r\n 'A1 6E 8D E6 8D 1B 74 E9 DD 19 A7 74 68 5B A3 46 87 BB CC D3 A7 5E 53 50 A1 5A 18 A2 8C 12 9A 6B'\r\n 'CA 6A E5 0A D1 45 14 4A 69 AF 3D 34 E9 D6 34 D5 D9 CE AE CA BE 78 2A D5 AB 4D 34 D8 CE 93 3A 6C'\r\n 'AE 93 65 F1 AB 56 AD 5A B5 76 59 AB B2 AD 5D 94 DD 24 D3 4D F1 4D 36 31 9C B6 66 E8 A1 53 4D 34'\r\n 'DD 1A 34 3D D1 9B A3 05 E1 A6 9A 69 A4 5E 1A 6D 19 68 C1 01 86 5C A6 90 B8 69 B4 30 AD 18 34 31'\r\n 'A1 69 D7 9A 74 8D 05 83 A7 74 66 E8 C1 A0 6F 34 2A B2 9A 45 0C 65 A1 2B B2 8D 8B 93 65 6D 35 6A'\r\n 'D1 61 67 88 2D 36 53 4D 94 32 CB 35 6A D5 AB 45 8A C5 76 55 AB B2 82 C2 CB 35 77 C5 5A B5 C1 76'\r\n '55 D9 56 8C 14 51 42 A6 9A 79 4D A2 8A E8 22 83 0C D1 42 A7 96 8A 28 A2 8A 28 34 DD A1 53 CB 45'\r\n '16 8A 28 A0 D3 60 C8 79 20 82 08 20 80 C3 2D 0A 9A C5 14 65 14 51 41 66 9A 77 46 69 E6 D9 65 9C'\r\n 'DD 96 68 B1 5A B5 6A EC AB 5C 5D 96 59 CD D9 66 8B 15 AD 3B 46 52 28 A2 8A 28 A2 F2 9A 69 B4 65'\r\n '22 8A 28 A2 8A 2F 29 A6 9B A3 42 D2 34 68 D1 A3 46 8D 1B CD 3A 74 EA A1 52 28 62 8A 32 8A 2F 29'\r\n '66 9A A8 43 A3 43 14 51 D0 D1 79 4D 34 D5 02 10 21 04 19 04 E4 28 C3 0D A3 05 14 51 43 B4 67 29'\r\n 'A6 9A 69 10 41 04 0E 1E 8F 29 A6 9A 6D 18 28 A2 8A 24 02 18 61 90 60 82 08 20 61 14 51 0C 20 82'\r\n '08 16 0B 2D 60 60 30 C3 0F 8C B2 DE 06 18 61 71 14 53 C6 71 86 31 71 E0 C6 59 A4 40 64 10 28 79'\r\n '0C 30 C3 0F 20 82 08 1C 3C 85 96 F9 81 83 20 81 06 43 78 C8 7C 2D 86 1B 30 12 3B 88 08 11 E1 11'\r\n 'CE 43 C1 C0 8F 71 E3 0E 60 1E B0 05 E1 E3 ED D1 8E 00 44 64 93 A3 08 02 10 F8 40 46 92 79 CE 77'\r\n 'AE EA E2 BA E4 E3 BD 00 88 00 DA 76 BB 4E B6 E9 3A AA E3 BB 5D AA EB BA 08 82 20 01 8C 59 42 78'\r\n '4F 58 3A EA 2E 8D 24 8E 22 8A B8 2D AA 9E 53 C0 8A 57 47 00 60 8E 1E 6E EA D2 00 3B A8 01 6E 08'\r\n '40 06 45 C1 26 08 40 06 44 24 C1 08 00 C8 84 98 21 1C A7 2D 42 DA A9 1B CE 70 80 8A 3B B8 37 6A'\r\n 'AF 07 11 4A D6 15 C8 B3 9C CC 91 85 2A A4 00 6D 42 DC 10 80 0C 88 49 82 10 01 98 44 C1 26 43 04'\r\n '19 CE 24 90 93 04 3C 14 E3 AB 99 22 9E 23 39 C4 51 17 70 6E D5 7C 46 73 88 A2 37 70 6E DE CF A3'\r\n 'CE 23 CD DC 15 E4 30 F3 86 64 3C 64 70 32 43 C6 43 21 82 00 2F 19 0C B2 38 5E 33 C4 40 EE EB 37'\r\n 'BF 83 66 6C C9 D6 72 10 DE 0E 9E 59 2B 10 F4 64 C1 B3 36 4D 62 10 DE 04 63 71 DB 9C 67 9D 2C D2'\r\n 'EE 53 0F 44 43 C4 69 56 ED 9A 45 3C 47 4A DD 50 F1 90 73 21 5D ED EB 7C EF 44 D5 1C 67 00 1C D3'\r\n 'EB AE DF 89 EE 78 26 86 E8 DA E3 95 3A EA 4B DC 58 17 C2 E2 68 D3 A3 68 E3 95 E0 33 AC CB DE 26'\r\n '8D A3 94 77 CD 3C DC 8F 7C 76 3D 1E 52 19 1D 9E 76 33 AE B5 F2 9E 42 11 E7 5D 45 D1 BD 75 D3 E5'\r\n '3C 84 25 63 5D 69 AD B6 F9 E3 68 E9 1A 4D F5 A6 B6 DB E4 E7 74 77 AA 39 53 5D 6B B9 DF 59 92 F8'\r\n 'E5 D1 9A A3 95 C6 1D 54 9B 91 EC B4 4D D1 CA 87 55 26 E4 7B 1B A9 74 74 BA EA 74 DD D9 77 52 E8'\r\n 'E9 75 D3 E9 BB BB BA 36 8D 6A F9 BB B0 86 45 55 DB 61 02 8C AB C3 DD D7 C1 D8 F0 75 D7 77 69 3A'\r\n 'EB A4 3A 3A 69 E0 5D 3E A4 1B B8 34 DE 18 79 C0 B5 EC 9D FE BA 5C A6 18 79 D4 EA F5 B4 75 70 73'\r\n '4D 3C EC 78 BA 7D 3E 6E E0 A6 70 F3 4F 38 B5 EB E6 EE 71 F0 F3 4F 23 7D 3E B8 B4 5A E5 1C 6F C1'\r\n '7C DF 5C 1D 23 4B 3B AE 5B 76 DB 60 72 B5 AA 39 D5 96 DA 29 85 BE 94 EB AD E0 EB AE B7 81 94 B3'\r\n '6C B6 DE 32 12 EC 85 96 D9 BD 65 32 74 A7 57 AD DB D0 DC BD 65 A9 75 3A 9D A7 63 0B 3C 75 D7 D7'\r\n '73 BD 6D 74 82 B8 DE 9D DE F2 EB 79 5C 73 CB EB 96 DE B6 BA 5C 5F 7C BE 9B 6E 98 40 E8 EA DD 82'\r\n '0E 8F 3B C7 BB A7 BB 34 86 47 78 A3 BB 37 67 11 1B B9 BB 37 60 08 81 22 92 04 47 62 07 63 BA F7'\r\n '7A BC 64 0B 55 B0 04 45 36 BB 67 3A 78 05 4A 30 97 00 E1 E1 3C 24 61 07 4C 42 21 D2 CC 2D 35 CC'\r\n '3C 5D 27 20 47 93 BD 8A 77 97 07 62 3B 6E 76 76 BE 04 45 DD 5B 37 5F 02 23 4D 35 DA F8 11 02 18'\r\n 'A4 B0 0D 3C D3 AA A0 30 F1 96 9A C3 C2 66 45 14 58 78 48 2F 1A 73 1F 34 8C B9 5D 50 F0 90 66 49'\r\n '15 B9 C0 6E 55 DD 6A 9C 27 86 E5 59 0E 6F 00 1C 20 12 01 20 60 E1 99 08 8F 07 2E 45 08 85 90 01'\r\n '78 D6 38 97 01 13 21 85 91 C2 42 CC 47 1E 0C 3C 99 82 5C A4 3B 9C 15 65 CC 85 A8 B0 80 4C CC 86'\r\n '28 B8 12 C8 44 21 4C E0 8B 21 10 B7 17 06 18 61 8E 21 C3 12 86 2C 17 C3 CE 6E B7 B3 48 D7 9C DD'\r\n '55 DB 81 9E 65 B8 ED 54 17 9C CB 71 D9 48 08 F1 DA 9D CA 40 47 96 D7 65 3C 44 65 B6 5B C1 84 5B'\r\n '6B 97 38 35 60 DD DD B7 77 82 AC 1A B7 72 4E 0C CC 8A 4D B7 82 66 55 6E 48 38 4C 52 3E 73 4C 92'\r\n '3E 72 19 24 7C E3 6D B4 08 05 24 19 0C E6 37 B0 72 37 19 20 9E 24 90 24 06 5B C0 9A 4E 8A 28 54'\r\n 'B5 4B A6 98 8A 0A 76 8D 3F 33 CD 73 7C E7 3B A8 E7 BA 0D 4F E2 DB B0 D8 7F 3F A4 FC 9F 97 F3 F4'\r\n 'D7 1D 47 59 D7 76 1D 9F E9 FD 57 AB F7 1B 7A ED 9E D9 76 D7 69 B3 D9 6B B6 3F 4F D1 4F 51 53 B1'\r\n 'EC AD 5B C0 5A B6 5F B1 1A B0 AA EB 2B 6C 2C 6D 2D B5 B7 37 B8 2F F0 E0 63 64 44 CA 4B B0 FE F7'\r\n '79 BB 96 F6 4A 52 8C 8F 8F C9 E4 71 F8 DC 5E 27 0F C7 F1 78 5D 2F 67 85 DD F8 7D DB CF 3C F3 CF'\r\n '3C F3 CF 3C F3 CF 3C F3 CF 3C F6 4E 4A 52 94 A5 29 4A 52 94 A5 08 42 10 84 21 08 42 10 84 21 08'\r\n '42 10 84 21 08 42 10 84 21 08 42 10 84 21 08 44 99 32 64 C9 93 26 4C 99 32 64 C9 93 26 4C 97 5D'\r\n '75 D7 5D 77 C9 DE CC 28 A4 C2 9E 20 4C 4C 4C 28 A7 BD F0 3D E7 0F BB D1 70 01 94 0F C8 A0 2F DD'\r\n '83 B7 81 86 F4 53 EF 83 1D F8 E3 70 05 47 04 32 E1 0A 98 E1 54 51 56 61 59 1E 24 64 03 3E 18 AD'\r\n 'E1 89 2E 20 AE E2 89 26 84 02 BD 48 E5 C8 8E 5D 81 00 6B 63 24 2C B9 42 CE 4C 5A F2 C3 6E 60 6F'\r\n 'CD 16 DC D1 35 CE 14 7C F1 47 CF 14 7D 01 45 D1 14 32 82 86 54 50 F4 85 0F 4C 5D 51 3A EA A6 A3'\r\n '79 D7 4D 7B 4A AC 77 E9 96 07 B7 52 E2 ED 68 BC 7D 30 9A F2 64 3F 75 34 2A FB 61 9E 1C DA 6C 36'\r\n '93 81 AC E8 78 78 83 7B 3E 2F 71 5E D0 F9 0D A8 84 2C 0A 41 CA B6 A5 0F 69 86 0A F0 C1 9E 9D F3'\r\n '11 91 84 C8 6A B0 EA 44 4F DD A9 CB 82 8B 34 D8 DF 0E AB 1E B4 66 6A 74 FD BE FE 9B DD C8 AF 0D'\r\n '74 BE C5 8F A9 0E C4 64 D9 08 96 63 D1 71 68 3D 04 6D 46 8D 26 C3 47 A3 CC 6E 22 5B 0F 37 36 DC'\r\n '67 B8 15 7A 15 04 BB 21 1F 26 A9 25 E1 08 F9 35 59 1D 10 8F 93 3E 74 1F 3B 0F 9E 07 D7 A1 F5 F0'\r\n 'D0 BF 0F F0 03 FE F8 7B FC 5F E0 84 9F 04 9F 84 B0 82 58 61 28 01 2C 40 94 10 96 28 7E 48 44 22'\r\n '29 91 C7 1B 0D 2A 3E 00 8E 40 45 01 90 54 13 64 68 92 AD 09 13 C8 22 03 24 11 0F E5 91 E0 C7 C6'\r\n '85 8B 07 12 06 1E 17 F7 91 F8 23 EC 17 BD FC 0B F2 7F 51 2F 81 2F 5E 13 F4 3B 75 79 77 75 73 DE'\r\n '73 70 E2 DE D9 BB 6B 5B 49 7B 33 95 59 2B B1 54 D6 C2 BD 63 43 AB 96 56 B3 59 59 2F 57 55 53 2E'\r\n 'C9 8F 66 9D 82 FA 6E D5 2C BD 1D 14 BD 0F 60 E3 97 50 6D 67 A7 3B B3 7D CE DC D7 6A 66 63 B3 BA'\r\n '97 22 C2 2B 27 5F AD D5 EA 4B 74 FA 52 B2 9D 1E 87 3F 9D CD E6 72 E4 F9 52 44 E4 71 F6 D2 2A 53'\r\n '48 12 41 31 00 20 20 D1 26 4D C9 AB 22 6A 92 4B 6A 97 26 C6 AA 36 82 0D 15 93 62 D4 6B 46 A8 D5'\r\n '1A A3 54 6A 8D 51 AA 35 46 A8 D5 1A A3 54 5A 8B 51 6A 2A 8A A3 54 6A 8D 51 AA 35 46 D2 6C 6A 5E'\r\n '26 E6 DC 6D 8D B1 B5 1A D1 AD 1A D1 AD 1B 51 5A 4A AE B9 72 02 42 00 48 41 0D B6 29 08 90 C6 29'\r\n '08 20 90 80 12 10 4A 42 02 90 80 12 10 11 21 00 24 20 04 84 00 90 80 12 10 4A 42 00 48 41 04 84'\r\n '10 48 40 09 08 01 21 00 24 20 04 84 00 90 80 89 08 24 48 41 22 42 09 12 10 48 90 82 44 84 04 48'\r\n '40 44 84 40 A4 20 0A 42 09 12 10 48 90 82 44 84 12 24 20 91 21 12 11 18 84 08 11 18 21 32 C5 8B'\r\n '16 2C 58 B1 62 C5 8B 16 2C 58 C9 87 0E 1C 38 70 E1 C4 C9 C8 C7 FC 2D 38 5D 7C 5C 5C 5B ED 86 2D'\r\n 'EC 7C 7A 9F 04 2E 1C 86 2B FC 5C 52 C0 C3 E0 61 6E DF 60 60 5F C9 6E 6F F5 1A 8D 41 8C 63 18 C6'\r\n '31 8C 63 18 C6 31 8C 63 18 C6 31 8C 63 18 C6 31 8C 63 18 C6 31 8D 62 63 18 C6 31 8C 63 18 C6 31'\r\n 'AC EC C2 D6 D0 2D 6D 43 36 D8 33 6D C3 36 E0 33 4E 19 B0 C3 36 E4 33 62 06 6C 50 CD BA 0C DB B0'\r\n 'CD BC 03 FE 30 7E AC 1E 7F CA 0F D6 03 F5 A0 F8 B0 7F F3 07 EB 81 FF 30 3F 5E 0F D8 04 27 3E 71'\r\n '38 86 AF 57 3B B1 13 A8 1E 87 D6 1F E6 40 79 18 61 E4 62 07 91 8A 18 58 72 24 48 91 22 46 16 16'\r\n '14 8D 96 BF 0A 46 2E 1E 26 26 26 2A D8 B8 B8 B8 F4 58 D8 D8 F4 B8 F5 7D A8 78 F3 38 D8 B8 98 72'\r\n '30 B7 5B 9D C6 DF 07 03 6D B5 D4 29 1F 68 E4 6B FD 9B 77 CD 5E DE 45 89 73 0F BF 52 19 CA 5D 2D'\r\n '65 45 2D 15 25 24 9D 60 02 81 42 10 5B 02 F0 77 2B 5C 12 5B 55 07 B3 A6 C5 C5 E5 5F F4 B9 7D EE'\r\n '3B 99 69 6E 7D F7 42 F9 8C A5 F7 8F 43 F5 60 7E 9C 0C EC EC DE B3 DC 15 4F 70 4E C1 EB F5 FA EF'\r\n '1E 3C 78 F1 E3 C7 8F 3D 3E 0F A5 E8 F9 9E BB 3D BB 2C B2 CB 2C B2 CB 2C B2 CB 2C B2 CB 2C B2 CB'\r\n '2C B2 CB 2C B2 C3 0C 30 C6 C5 86 18 61 86 18 61 86 18 61 86 18 D7 B0 C3 0C 31 C1 A6 A4 9B A2 52'\r\n '88 6B 2D 0B 65 E0 E1 28 A0 28 0A 00 28 A2 80 A0 28 A4 FA 93 36 16 3D F6 97 EE 6F 2F 3F 96 7F BB'\r\n '7A 78 8F E7 89 F2 7E 57 95 89 05 E3 30 BC BC BC D0 76 1F C7 6B C0 1F B1 9A 21 9B 06 6B D9 B1 19'\r\n 'AD E7 E1 AE B7 87 74 5E EC 53 D8 9B 3D 71 AE BF D6 F8 06 D0 5F 8C 2E EF D4 35 6C BF 66 C0 66 B1'\r\n '97 FA FF 83 B4 ED 1B B4 8E D2 BB 4D 47 8B 49 71 EB D3 6A 71 A9 E6 54 C6 A8 99 B9 EA 55 63 D5 DA'\r\n 'E3 D6 4D DD 29 F9 EB 7E F6 96 59 2F 7F 9A F9 0C 5F 33 91 0B 20 B9 15 F7 FE B5 8C 6F C1 65 DB FB'\r\n '36 76 7A 45 32 6D 26 72 6D 76 BE 7D BD 13 D7 13 6F 1D E5 21 BD 72 F4 4D E5 F6 F1 BD E6 CF F5 48'\r\n '89 DB 77 5A 59 9F EF BC 18 FB D1 8F BE 17 1B F1 71 C0 17 1F 97 82 9B F3 5C 6E B8 49 AE 3C B8 E4'\r\n 'C9 AE 0A 2E 0C 2E 23 C5 C4 80 59 21 8D EB 10 9F DD 72 9B 8B 29 F1 EB 7A 5D 25 F5 F6 0A FA F8 E1'\r\n 'D5 AA C5 0C 88 B6 F4 F1 65 34 6C A8 28 A2 4B 2B 2B 2F 87 BD FD 5F 98 DD 14 36 82 04 92 92 44 E1'\r\n '04 83 E9 9E 96 91 E6 3E FF B8 7B 1F 5E 25 D1 F4 2F 70 F6 4E DD DE 87 47 75 AD 2A 28 96 96 98 1B'\r\n '2C 0D 9E 05 D9 FD 9D 2D EE 5B 0E AD 71 18 8A 2D 39 7A FE C5 B5 B5 B7 C2 02 CE DB 0B 85 C2 60 B1'\r\n '18 59 B5 61 A6 2E D1 B4 B3 2C 2C DE 99 D9 BD 2B B5 B4 BE A2 F7 47 C8 D1 C8 5A E1 28 D0 DB 9F 5E'\r\n 'CA E0 E5 26 30 E0 25 9D E6 83 3F C7 D3 9E A3 8E CE DD D9 6B 80 31 AA 74 98 94 18 7A 49 03 C2 DD'\r\n '6E 77 14 B3 4B 57 6B E8 07 AA D4 6D C3 07 03 6D B5 8F 3D B4 9D B0 72 76 30 5F EC DB BE 8B 49 07'\r\n 'B9 BC 0F 3F EF 7C F5 8F 57 F2 8E F9 18 82 22 F8 A9 C1 2A B1 DC EE 77 3B 9D 77 3F EB C6 78 C8 2C'\r\n '60 D4 41 CE C5 CE 98 D6 4C 58 E4 67 A1 9F E3 C9 98 EE B7 EC F6 9B B7 3F D0 EE 77 14 1E DE 79 BC'\r\n 'FB 7A 06 EB 9B F8 9B B7 F1 37 6F E2 B6 60 C2 DA 9F 1D 8D 3F 89 1B 7D 0D 99 8D F1 C7 6A F7 BB DD'\r\n 'DC 5E ED 42 8D D7 E1 53 52 6A 86 31 FC EA 3A 2A 1D E4 FC F4 F4 EC EC E4 8A F8 54 07 9E 79 E7 9E'\r\n '79 E7 9E 79 E7 D0 E6 B2 8F 90 9E 9A ED 47 C7 C7 98 C6 31 8C 63 18 C6 31 8C 63 18 C6 31 8C 63 18'\r\n 'C6 31 8C 63 18 C6 31 8C 63 18 C6 31 8C 63 18 C6 31 8C 63 18 C6 31 8C 63 18 C6 31 8C 63 18 C6 31'\r\n '8C 63 18 C6 31 8C 63 18 C6 31 8C 63 18 C6 31 8C 63 18 C6 31 8C 63 18 C6 31 8C 63 4D 70 F8 9C 58'\r\n '5D E8 57 33 D3 90 A7 61 73 21 5E 42 75 09 DF 59 DC 27 90 AF 61 5F 42 BF 85 81 09 D6 83 DC 6C 1C'\r\n '67 D8 CF F1 B0 B1 B0 F1 A0 63 1D FA CE FD 87 79 A7 79 C7 79 E7 68 CE 4E 76 90 EF 40 EF 44 EF 48'\r\n 'EF 4C EF DA 77 A8 77 AA 77 AC 77 AE 77 B0 77 B2 76 94 EF 68 ED 31 DE D9 DE E1 DE E9 DE F1 DA 73'\r\n 'BD F3 B5 07 7C 07 6A 4E D5 1F AC 3F 5A 7C 59 FF CC FD 71 FF 31 FA F3 F6 07 FF 43 FE 73 FE 83 FE'\r\n '93 F6 27 FD 47 FD 67 EC B1 A7 86 6C F8 CD A0 19 AB 86 45 08 CD A2 19 B4 63 36 90 3A A5 0E A9 86'\r\n '6A F0 ED 80 CE A7 1A 0C 44 4A 81 A0 C8 23 52 2F 6A 85 C5 58 B8 AC 0F 99 87 35 A2 FA B8 5F 34 17'\r\n '35 E1 AD 80 74 D4 3B B1 17 56 43 32 CC 3C B4 0E AD 43 C6 C1 E3 71 7F 6C 2F ED C3 F7 01 1B 81 96'\r\n 'E4 65 F7 86 5D C8 CA BA 11 2E C4 4B C1 13 19 D0 C9 76 31 DE 0C 9B D1 0A F8 64 DF 8C 9C 01 DF FC'\r\n 'A8 BD 1E 3C 11 E3 7C 11 7E 21 E1 08 78 62 1C 01 0F 10 43 82 21 E2 88 70 84 3C 61 0F 1C 43 F0 08'\r\n '79 02 1A 01 28 61 2C 91 99 10 78 72 86 6E 58 45 11 E1 48 22 90 47 2F 2A 26 4C 34 32 3C 18 F8 D0'\r\n 'B1 60 E2 40 C3 C2 7E FB 05 EF 7F 02 FE FA F5 E3 B7 57 97 77 57 3D E7 37 0E 2D ED 9B B6 B5 B4 B3'\r\n 'B2 B1 6B 61 5E D2 BA B5 9D 65 5D 55 4B 2A 86 34 EC 17 D3 52 D2 51 D1 50 AE A0 9F 9E 3E 76 73 BB'\r\n '37 DC ED CD 76 A6 66 3B 2B 65 FB 0B 0E 56 AB AF D6 EA F5 25 BA 7D 29 59 4E 8F 43 9F CE E6 F3 39'\r\n '72 7C A9 2E 4F 23 8F 22 A7 8D F8 F1 78 9C 39 08 C8 C8 C8 CF 22 32 32 32 31 24 92 49 24 92 49 24'\r\n '92 49 24 92 49 24 92 49 24 92 49 24 92 49 24 92 4B 49 A4 D2 27 4E 9D 3A 74 E9 D3 A7 4E 9D 3A 74'\r\n 'E9 D3 A7 4E 9D 3A 74 E9 D3 A7 4E 9D 3A 74 E9 D3 A7 4E 9D 3F 19 48 01 4A 95 2A 54 A9 52 A5 4A 95'\r\n '2A 54 A9 54 A9 52 A5 4A 95 2A 54 A9 52 A5 4A 95 2A CC CC CC CC CC CC CC CC 6E 91 BA 56 E9 9B A7'\r\n '6E A1 BA 96 EA 9B AB 6E B1 BA D6 EB 9B 23 6B B6 C3 6C B7 09 B2 B7 5E DD 83 76 2D 99 BB 26 EC DB'\r\n 'B4 6E D5 BB 66 ED DB B8 6C ED C3 6E E5 B8 8D C5 6E E9 BB B6 EF 1B BD 6D A6 EF 9B 6E F9 AB DB CB'\r\n 'BB A8 B1 2E 61 9E E2 DE DA D6 D2 CE C8 D6 36 15 E5 84 CB 0B 92 BA B6 B2 AE AA A6 A2 9E 9A 96 92'\r\n '8E 8A 8C 14 00 50 01 40 05 00 00 14 A3 50 26 40 1A 20 34 89 D3 68 FC FF 3B CD FD 9F AF F5 7F CF'\r\n 'E9 FD 1F F1 E6 7F BF FB 7F AF FA 7F 9C 05 50 15 C0 3A 02 C8 1D 88 12 F0 16 C0 EC C0 98 81 33 03'\r\n 'B5 02 6B A9 C4 EA 71 7A 9C 6E A7 1F A9 D9 D1 EC F6 BB 35 F5 E5 29 4A 52 94 A5 29 4A 52 94 A5 29'\r\n '4A 52 94 A5 29 4A 52 94 A5 29 4A 52 94 A5 29 4A 52 94 A5 29 4A 52 96 C2 C0 2C 6C 41 A3 03 56 40'\r\n 'D5 98 35 68 0D 5A 83 56 C0 D5 B8 35 70 02 69 93 CC D7 35 A6 87 32 46 AE 41 A8 80 D4 50 6A E8 1A'\r\n 'BB 06 AF 01 AB D0 69 A0 79 E7 9E 79 E7 9E 79 E7 9E 79 E7 9E 79 E7 9E 79 E7 9E 79 E7 9E 79 E7 B4'\r\n '74 74 74 74 74 74 5F A2 7E 8D FA 47 E9 6D A9 9F A7 7E A1 FA 97 EA 9F AB 3D 63 F5 B6 F5 CF 91 F5'\r\n 'DF 61 F6 5F 84 F9 5F AF 7E C1 AB 17 CC FD 93 F6 6F DA 3F 6A FD B3 F6 EF DC 3E 77 E1 BF 72 FC 47'\r\n 'E2 BF 74 FD DB F7 93 9B E0 ED 43 B0 85 44 A6 97 7D BD EE B7 9B B9 6F 64 A6 AE F9 10 F4 99 12 A4'\r\n 'BB 8F 17 1B 17 13 0E D1 45 2A B5 12 30 B7 5B 93 CD 69 F7 1B 7C 1C 0D B4 D4 D7 73 B5 D2 69 35 51'\r\n 'F6 8E 46 BF D9 CD 37 39 6D A4 EE 36 57 CD 5E DE 5D DD 45 9B 89 73 0E C3 61 0C F7 16 F6 DA 5B 6C'\r\n 'A5 00 26 00 14 01 11 78 49 C1 82 22 22 0B 93 83 24 44 44 11 17 27 05 DE DC 43 6B 08 88 2E 9C 11'\r\n '18 82 22 E3 83 10 B0 88 82 E3 82 23 10 44 5C 70 62 18 44 41 71 C1 11 88 22 2E 38 31 11 11 05 C7'\r\n '04 46 20 82 00 44 C1 30 00 87 C1 9E 83 3F 06 82 0A E8 34 30 68 A0 D1 C1 A4 83 4B 06 9A 0A F8 2C'\r\n '20 D3 C1 63 06 A2 0D 2B 28 35 30 6A B4 6A 0C 63 18 C6 31 8C 63 18 C6 31 8C 63 18 C6 31 8C 63 18'\r\n 'C6 31 8C 63 18 C4 21 08 42 10 84 21 08 42 10 84 21 08 42 10 84 21 08 42 10 84 21 08 54 54 60 A0'\r\n '02 80 0A 00 28 00 A0 00 04 C0 00 04 46 20 88 C1 88 88 88 30 44 4D B0 82 23 06 08 88 88 30 64 8C'\r\n '41 11 83 04 44 44 41 92 31 04 60 C1 11 11 06 08 8C 41 11 83 11 11 10 60 88 C4 11 18 31 11 11 06'\r\n '0B DE 7D F4 9D 75 18 82 23 06 EC EC EC EC EC EC EC EC EC EC 54 A9 52 AF F0 54 A9 52 A5 53 1D 95'\r\n 'B2 FF 6C 6F C5 B9 DC 6D F6 DB 58 CD A6 D3 EA D8 FD 3F 47 CF 17 B0 D7 F8 B3 FC 39 D9 B3 33 1B 25'\r\n 'B2 F2 72 67 2B 54 A9 56 A7 AD AA EA F5 3A 92 D2 BE 3C EC EC EC EC EC ED DA 8D D7 E1 F7 FD DF 6C'\r\n '6F D9 B9 DC 6D F6 DB 58 CD A6 CF 65 F5 D9 D9 D9 D9 A0 82 08 20 82 08 20 82 08 20 82 08 20 82 08'\r\n '20 82 08 20 63 18 C6 31 8C 63 18 C6 31 4A 52 94 A5 29 4A 52 94 A5 29 4A 52 94 A5 29 4A 52 94 A5'\r\n '29 4A 52 94 A5 29 4A 52 94 A5 29 4A 52 94 A5 29 4A 52 94 A5 29 4A 52 94 A5 29 4A 52 94 A5 29 4A'\r\n '52 94 A5 29 4A 52 94 A5 29 4A 52 94 A5 29 4A 52 FC 48 48 48 0E 8F 0C 2F E2 05 FC 50 BF F1 0B F8'\r\n 'C1 7A 90 BE 44 2F E3 85 FC 80 BF 92 17 C9 05 FC A0 BE 4C 2F E5 85 FC C0 BF 9A 17 F3 82 FE 78 5F'\r\n 'D0 0D BA 21 B4 A0 6D 2A 1B 74 83 6E 98 65 2C 19 75 03 2E A8 65 D6 0C BA E1 92 A0 C9 58 64 70 64'\r\n 'B0 31 EC 06 32 E1 8A D0 C7 B2 18 CC 06 33 21 8F 68 30 9A 0C 7B 61 8F 70 78 E6 C7 8F BA 3C 73 83'\r\n 'C7 3A 32 89 19 9E 99 CC F8 73 40 1C AE 0E 68 43 9A 20 E6 8C 39 A4 0E 69 43 9A 61 68 BC 5A B0 0E'\r\n '69 C3 96 21 CD 40 B6 64 1C D4 87 15 41 CD 58 73 58 34 19 84 6B 42 35 C1 16 81 1A F0 8D 80 45 A8'\r\n '77 62 1D D9 07 76 61 DD A0 77 6A 1D B6 0E DB 87 76 C1 DD B8 76 E0 3B B8 0E DC 87 7D E0 EE E4 3B'\r\n 'BA 0E EE C3 BB C0 ED D0 76 EC 78 5E 0F 0D E8 F0 DF 0F 0D F8 F0 E0 04 7B E1 17 A1 1C 10 8B E0 8B'\r\n 'F0 8E 10 47 0C 23 00 23 88 11 82 11 C5 08 C2 08 E3 04 71 C2 3E 00 8E 40 45 00 8C 30 8E 48 46 20'\r\n '47 28 23 96 11 44 65 A2 32 F3 7C 3A 19 FA 1E 4F 93 9F E5 79 5E 56 76 6E 62 48 E5 E5 44 C9 86 86'\r\n '47 83 1F 1A 16 2C 1C 48 18 78 4F DF 60 BD EF E0 5F DF 5E BC 76 EA F2 EE EA E7 BC E6 E1 C5 BD B3'\r\n '76 D6 B6 76 56 2D 6C 2B DA 57 56 B3 AC AB AA A9 65 50 C6 9D 82 FA 6A 5A 4A 3A 2A 15 DE 65 04 FC'\r\n 'F1 F3 B3 9D D9 BE E7 6E 6B B5 33 31 D9 5B 2F D8 58 72 B5 5D 7E B7 57 A9 2D D3 E9 4A CA 74 7A 1C'\r\n 'FE 77 37 99 CB 93 E5 49 72 79 1C 79 15 3C 6C FF C4 10 02 00 40 08 01 00 20 00 10 03 67 C7 E7 C8'\r\n '67 97 30 D9 91 F9 9C 28 91 D1 0B 10 D1 38 59 11 D9 05 C8 36 47 0A 14 74 2F 6D FD BA 7D 3E 9F 4F'\r\n '6D EA 6F BA 2F F4 72 BA 3B 5C FD F7 3D FE 7E 57 3E FB CB CB E7 DD F9 3D E7 EF F2 78 1C FF 6F CF'\r\n '39 CE 73 9C E7 39 CE 73 9C E7 39 CE 73 9C E7 39 CE 73 9C E7 39 CE 73 9C E7 39 CE 73 9C E7 39 CE'\r\n '73 9C E7 39 CE 73 9C E7 39 CE 73 9F C3 87 A3 73 E2 44 D1 8B C2 BA D1 BB F1 6F 34 68 68 27 E7 A7'\r\n '67 26 E6 AF 7C 56 BB 17 DF 49 BE C6 CF C6 BF EC 4E CE 4D CD 69 F4 DA A8 DE 33 9A 1B 4F 1E 3E 86'\r\n 'D7 87 B6 D0 C0 E2 60 E8 50 D0 4F CF 4E CE 4D CD 6D F8 BB 8D 0D CF 1B 75 A1 85 C7 91 A1 87 C8 C4'\r\n 'D0 A1 A0 9F 9E 9D 9C 9B 9A C5 E4 63 7B 18 FC 97 7D 89 39 B2 BD 89 D9 C9 B9 AD 3E 9B 23 AE 8E BA'\r\n '7A F9 3D 7D 3E 9B 4B A4 7B 8D 2F AD BB E3 EF 3A DD D7 23 7B D6 DF 72 5F EB 50 D0 4F CF 4E CE 4D'\r\n 'CD 6F BA 7B EC 0D FF 43 80 EB 83 D1 E1 3A E0 F3 38 4E 77 DC 5D FB 58 E9 22 B7 2A 93 58 D1 12 81'\r\n '12 44 A4 25 12 24 CA A6 25 2A 24 CB 60 46 08 91 16 24 B2 44 96 75 24 6E 89 33 2B 09 E2 CC 26 83'\r\n '92 39 72 4D 06 A4 69 9C 44 AC 88 D7 38 99 96 84 B3 CE 26 6B 62 36 CE 26 75 15 AD 1A 49 AD 53 7C'\r\n 'BF 26 71 1B FC BF 26 AF E3 CB 25 A5 3B 56 3E 04 C3 5B AC A8 AE 65 8B 52 D3 C9 F2 35 BA CF 27 E6'\r\n 'D7 6B 75 90 09 59 17 17 17 17 17 17 1A 34 68 D1 A3 46 8D 1A 35 0D 04 FC F4 EC E4 DC D7 98 E3 8E'\r\n '38 E3 8E 38 E3 8E 38 E3 8E 39 43 41 3F 3D 3B 39 37 34 E3 8E 38 E3 8E 38 E3 8E 38 E3 8E 39 43 41'\r\n '3F 3D 3B 39 37 35 CD FD 7F 8B 9B FB 3F 27 36 37 A1 7D CC F3 FA 1F A7 F4 5A CF CF CF 60 CF CF C7'\r\n 'A0 A0 81 43 43 43 43 71 A8 D4 FE 7F 2E BF 37 2E EA 26 4D CA 08 3F 7E FF 1A 2A 2A 2A 2A 2A 2A 2A'\r\n '2A 2A 2A 2A 29 C3 87 0E 1C 5A 5A 5A 5A 5A 5A 56 D6 D6 D6 D6 D6 D6 D6 B1 62 C5 8B 16 2C 58 D2 52'\r\n '52 52 49 71 F7 D4 94 8B 97 2E 5D 37 37 37 37 37 37 37 37 F9 A5 A5 A5 BF C6 5A 52 52 4E 4F 9B CD'\r\n 'F3 39 92 32 32 32 32 32 32 32 26 31 B8 1C 0E 07 03 81 E7 78 18 2D 34 D3 4D 44 89 12 24 48 91 22'\r\n '30 C3 0C 30 C3 0C 31 5D 4F 95 95 95 95 95 95 95 95 F3 BE 6E FB 9C A7 39 4E 72 9C E2 3A 23 A2 3A'\r\n '23 A2 39 23 92 39 23 92 39 23 92 39 23 92 33 23 32 33 23 32 33 23 32 33 23 32 33 AA 5F CC A1 A1'\r\n '9F 9F 9F F9 0E F3 BC 8C 41 18 31 11 11 05 DE 4E 05 3A 74 19 F9 F9 FE D3 3F 3F 3F 3F 3F 3F 3F B8'\r\n 'CF F5 3B 1E 64 08 10 20 40 81 02 04 08 10 20 40 81 02 04 08 1E 86 A4 04 21 08 42 10 A2 44 88 D4'\r\n '58 B1 62 C5 83 02 0E A6 0E AA 0F 6D 07 B7 83 ED 60 F7 10 7B 98 2A C1 D5 C1 D6 41 D6 41 D6 C1 D7'\r\n '41 D7 C1 D8 7D 81 05 65 F0 E0 AD B2 D8 EC 3C 0F 80 EF FD FB BE F9 7F 97 79 6F 96 79 5F 95 79 4F'\r\n '82 F0 58 82 22 F0 73 83 11 11 11 05 C9 C1 88 23 10 44 5C 9C 0A 00 4C 00 67 E7 F0 78 3D 1E AF 0F'\r\n '32 14 2E F3 BC F5 3A BD 2E AF 9B E6 F0 B8 5C 8F 37 91 E3 43 86 AA AA AA AA AA AA AA AA AA AA AA'\r\n 'AA AA AA AA AA AA AA AA BF F7 CA E2 E0 60 63 7C 2D BE 87 9D A1 EA E8 72 B9 79 DA 19 DE 57 85 E1'\r\n '6F 7C 2D D6 87 AC A9 35 64 D6 13 5A 4D 71 35 E4 D8 13 62 4D 91 16 24 12 08 83 25 11 28 C9 48 4A'\r\n '52 53 12 9C 95 04 A9 25 51 2A C9 58 4A D2 57 10 95 D5 B5 95 75 55 35 14 F4 D4 B4 94 74 5D BF 34'\r\n 'F3 3F 32 EF 3C C7 CC 3C 0F 80 EF FD FB BE FA 0F A1 22 22 20 BD 0E 70 62 08 C4 11 17 27 04 62 22'\r\n '22 20 B9 73 84 41 18 82 22 E4 E0 C6 31 06 0B 8E 22 08 C5 11 71 C1 88 88 D0 5C E7 08 82 31 44 5C'\r\n 'E7 03 1E 3B C7 7A B3 F7 EF DF BF 5C B9 72 E5 CB 97 2E 7E FD FB F7 EF E1 F8 98 30 60 C1 83 03 78'\r\n 'AC 60 57 C0 B0 80 D6 04 4A D8 95 DE 9C 46 91 37 9B CE 06 F3 76 A3 93 C7 C4 51 03 0D 9D 65 5D 56'\r\n '13 F7 D8 2C EB 2A EA 9E F7 F0 2F E8 A8 57 50 62 DF F8 BE FF BB ED 8D FB 37 3B 8D BE DB 6B 19 B4'\r\n 'DD 49 72 79 1C 79 15 3C 6E FB BD F7 5C 4E AA 52 94 A5 29 4A 52 94 A5 29 4A 52 94 A5 29 4A 52 94'\r\n 'A5 29 4A 52 94 A5 29 4A 52 94 21 08 42 10 84 21 08 42 10 84 21 08 42 10 84 21 08 42 10 84 21 08'\r\n '42 10 84 21 08 42 10 84 21 08 8D 8D 8D 8D 8D 8D 8D 8D 8D 8D 8D 95 F1 6E B7 4A 29 29 29 29 29 1A'\r\n 'B5 6A D5 AB 56 AD 72 B2 B2 B2 B2 B2 92 D0 7C F9 F3 E7 CF B3 34 2D 6D 6D 6D 6D 6D 58 DA DD DD B6'\r\n 'AA BB BB BB 57 EB 2B F5 D5 FB 0A FD 95 7A 55 7E D2 BD 32 BF 6D 5F B8 AF DD 57 EF 2B D3 AB F7 D5'\r\n 'EA 15 FC 0D 0E D5 34 59 F0 AC FD EB 3F 82 CF FA 59 FF 6B 3F F1 67 F1 59 FF AB 3F 92 CF 89 67 FF'\r\n '2C F8 D6 6A D6 7C 8B 3E 55 9A CA 8E C4 5D 4C BE BA DD 6E BD 6E C1 6F F4 5B F3 AD FA 16 FD 2B 76'\r\n '2B 7E A5 BF 5A DD 92 DD 9A DD A2 D8 C6 92 E1 A6 E5 A4 CC CB 4E D0 69 34 3F 23 4E D8 F4 9A 7A BE'\r\n '92 6B 69 B0 DF BA 3F 3F 97 AF D7 25 38 12 9D 16 47 84 A7 86 0C F8 C1 A0 18 2B 86 0D 08 4A 88 25'\r\n '46 12 A4 09 52 8C 3A 61 86 BC 61 B0 18 74 E1 26 21 2A 80 93 20 95 48 C4 AA 18 95 63 12 B0 62 33'\r\n '19 95 A1 2A E1 98 D0 38 AF 0E 2C 03 86 A1 C5 88 71 64 1C 59 87 16 81 C5 A8 70 D8 38 6E 1C 5B 07'\r\n '16 E1 C3 80 F6 E0 3D 72 1E F7 83 DB 90 F6 E8 3D BB 0F 6F 03 D7 41 EB B0 F5 E0 C8 BD 0F 2F 43 C7'\r\n '6E AF 2E EE AE 7B CE 6E 1C 5B DB 37 6D 1D 6A 5B 4B 3B 2B 16 B6 15 ED 2B AB 59 D6 55 D5 54 B2 95'\r\n 'A8 E9 B1 96 A7 60 BE 9A 96 92 8E 8A 85 75 04 FC F1 FD D9 BE DC DF 73 B7 35 35 33 31 D9 5B 2F D8'\r\n '58 72 B5 5D 7E B7 57 A9 2D D3 E9 4A CA 74 7A 1C FE 77 37 99 CB 93 E5 49 72 79 1C 79 15 3C 6F C7'\r\n '8B C4 E1 C8 47 98 B1 DC 2E 0F 03 7F BE DE EF 37 4A 01 00 20 1A 22 00 01 14 04 C0 80 10 00 13 28'\r\n '50 A1 42 85 0A 14 28 50 A3 79 BB 97 2E 5C B9 72 E5 CB 97 2E 5C B9 72 E5 CB 7B 25 29 4A 54 18 C6'\r\n '31 8C 63 18 C6 31 8C 63 18 C6 31 8C 63 18 C6 31 8C 63 18 C6 31 88 42 10 84 21 08 42 10 84 21 08'\r\n '42 10 84 21 08 42 10 84 21 08 42 10 87 DB ED C6 28 8B B6 E0 C6 31 1A 0B 8E 22 08 C5 11 73 9C C4'\r\n '41 60 8C 24 A5 82 23 11 05 88 30 62 08 8B 04 44 62 0B 10 46 20 8B 2E 71 CE 44 46 20 B1 04 62 08'\r\n 'B0 44 46 0B 10 46 22 0B 04 44 60 C1 62 08 C6 08 2C 84 44 44 45 88 23 11 05 90 88 88 C1 62 08 C4'\r\n '11 60 88 88 88 B1 04 62 23 93 88 2C 11 11 11 82 25 AA 58 82 31 06 22 0B 04 44 44 60 C1 67 36 E1'\r\n 'C1 18 83 11 0D A5 82 22 22 32 E7 6E 70 72 EB 97 5C C1 66 41 88 31 04 58 22 22 33 97 38 C1 62 08'\r\n 'C4 1A 65 24 58 22 22 22 9C B9 B8 82 C4 11 88 30 44 58 22 22 23 32 20 B1 04 62 0C 11 16 08 88 88'\r\n 'CC 88 2C E5 CB 82 31 06 08 8B 04 44 46 20 8C 44 98 83 04 46 22 22 22 31 04 60 24 C4 14 E5 71 39'\r\n '22 30 44 44 46 5C 9C 82 31 12 62 0C 11 82 22 22 31 04 62 24 C4 19 CB 9C 44 44 44 44 62 0C 18 83'\r\n '39 73 88 88 88 88 8C 41 83 10 44 44 44 44 60 C1 88 22 22 22 30 60 C4 11 11 11 83 18 8B 93 88 88'\r\n '2E 73 91 11 8B 93 82 22 31 06 0B 93 88 88 22 22 22 2E 4E 32 44 62 0C 17 27 11 10 44 44 0E 39 17'\r\n '27 04 44 0E 75 39 17 44 18 2E 4E 0C 41 11 11 17 27 10 44 5C 70 60 C1 71 C1 88 65 2E 39 11 11 17'\r\n '1C 41 11 71 C4 18 2E 38 31 05 11 10 24 5C 71 04 42 21 06 0B 8E 0C 41 11 02 45 C7 04 44 11 06 0B'\r\n '8E 22 08 88 88 8B 8E 08 8C 44 18 2E 73 91 11 11 11 11 11 83 10 60 8C 19 B9 4E 44 44 44 44 22 E7'\r\n '38 82 E5 38 2E 73 91 11 11 11 18 31 10 22 04 44 5C E7 22 22 22 22 80 C1 11 71 C1 11 11 18 23 06'\r\n '08 8C 11 11 11 82 30 60 B9 CE 46 0C 11 11 11 11 82 E3 82 30 91 11 11 11 83 18 22 08 88 A4 88 C1'\r\n '21 82 20 88 8A 02 23 06 32 62 20 88 A4 88 8C E5 CE 31 82 22 24 A4 88 88 C4 46 20 8C E5 CE 31 11'\r\n '11 88 88 C4 41 11 88 8C 11 88 88 C4 11 18 88 8C 44 44 62 0C E5 CE 23 11 11 82 30 44 44 E7 52 EB'\r\n 'A4 52 44 44 51 88 C1 06 08 A4 88 C4 46 08 28 88 A4 88 C4 44 10 67 3A 97 5D 31 24 63 18 83 06 9D'\r\n '54 EA EB 9B 58 2A 60 88 A3 10 62 08 22 28 C4 60 C1 88 8C 40 60 C1 88 C6 30 63 04 14 E5 CB 88 8A'\r\n '48 C4 18 C1 06 8C 44 52 46 22 0C 60 83 4E 80 54 31 AA 28 63 63 60 C6 36 6B 7C 3F 0B 59 E0 EA FC'\r\n '0E FF BE FD FD EF 79 DD F7 5A AF 6F 55 DB 6A B9 27 DF EF 73 B3 B3 B3 B3 B3 B3 B3 B3 B3 B3 B3 96'\r\n '59 65 96 59 65 96 59 65 96 59 65 96 59 65 96 59 65 96 59 65 96 59 65 96 59 66 DE 70 6D E7 86 DA'\r\n '30 D9 38 6D A4 0D BD 00 DB D1 0D BD 20 DB D3 0D BF 68 6D EA 06 DE A8 6D EB 06 DE B8 6D EC 06 DE'\r\n 'C8 94 D2 89 4F 68 73 F4 C1 B7 B6 1B 7B 81 B7 BA 1B 7B C2 57 4E 25 7D F1 2B A8 12 BF 00 95 D4 89'\r\n '5D 50 95 FD C2 57 E1 12 BF BC 4A FF 01 2A 70 F0 61 82 87 B8 B7 B6 B5 B4 B3 B2 35 8D 85 79 61 32'\r\n 'C2 E4 AE AD AC AB AA A9 A8 A7 A6 A5 A4 A3 A2 18 A0 C4 88 A2 80 13 00 00 13 00 13 00 00 0A 00 5E'\r\n 'DE 7D 1F A1 F3 F3 3F C7 A7 E9 73 BD 1F DD FB 79 B1 E3 C7 8F 1E 3C 78 F1 E3 C7 8F 1E 3C 78 F1 E3'\r\n 'C7 8F 1E 3C 7E 37 F4 EA 72 70 70 70 70 49 1F 99 CC E6 73 39 84 21 08 42 10 84 21 08 42 10 84 21'\r\n '08 42 10 84 21 08 42 10 84 21 08 42 10 84 21 08 42 10 84 21 09 E2 63 30 18 CC 87 2A 10 72 8A 1C'\r\n 'AA F0 E5 58 07 2A C4 3A 06 0E 85 90 74 2C C3 A1 68 1D 0B 50 E8 5B 07 42 DC 1D B8 07 4E 0E C3 07'\r\n '6E 41 D8 80 EC 50 76 E8 1D BB 07 6F 01 DB D0 75 A0 76 F8 1D 6C 1D D9 83 B7 E0 EC 60 75 C0 77 68'\r\n '0E E4 ED 66 64 ED 82 4E 00 49 C1 09 3B 70 F2 F7 01 D4 F5 77 41 EA E1 06 97 EC C8 0C 9C 30 C9 C4'\r\n '0C 9C 50 C9 C6 0D EE 38 6B 90 E8 72 E4 87 2E 50 72 F2 03 96 80 C8 40 64 4A 92 EE 3E 36 2E 26 1C'\r\n '8C 2D D6 E7 71 B7 C1 C0 DB 6D 63 ED 1C 8D 7F B3 6E F9 AB DB CB BB A8 B5 31 2E 61 9E E2 DE D6 DA'\r\n 'D6 D2 CE C8 D6 36 15 E5 84 CA 72 41 40 00 05 00 14 00 51 40 50 14 23 10 62 31 93 3E 03 C4 4B AE'\r\n '91 18 88 C4 18 8C 41 11 88 C1 71 C1 88 C1 11 11 88 88 B8 E0 C4 62 08 88 C4 46 03 06 08 B9 D2 EB'\r\n 'A8 88 88 8A 0C 11 04 44 52 44 60 C4 00 62 22 22 30 62 08 22 E7 4B AE A2 30 18 2C 18 31 04 66 B5'\r\n '8B 5D 57 5C EA 22 30 45 06 0E 0E 20 88 88 C1 8E 6E 72 83 18 88 22 22 30 4A 60 C0 41 11 11 83 05'\r\n '06 22 20 DC 70 46 0C 24 60 88 82 82 28 0C 11 11 88 22 29 2E AD D1 CE 84 60 C1 46 31 04 41 18 30'\r\n '18 A4 8C 18 88 28 AE 74 B9 D0 8C 18 22 30 70 71 11 49 82 30 51 14 46 31 11 8C 18 30 60 8B 9C E6'\r\n '22 22 20 8A 4C 10 41 18 88 48 88 8C 18 89 31 10 46 48 C1 88 31 10 91 11 82 08 93 10 44 64 8C 18'\r\n '88 23 11 04 44 44 60 C4 41 18 88 22 22 23 06 22 0C 41 11 11 18 88 88 31 92 22 22 23 11 10 46 08'\r\n '88 88 88 8C 44 44 98 22 22 32 44 62 22 24 8A 22 22 22 31 11 12 44 44 46 48 C4 44 11 11 11 11 11'\r\n '88 88 22 22 22 30 62 22 08 88 88 8A 4C 44 41 11 11 11 90 82 24 88 D2 62 02 28 8A 4C 04 49 12 44'\r\n '46 22 4C 11 93 06 20 88 88 88 8B 84 84 84 84 92 A4 AA 8F 86 F8 6F 85 F0 FD 75 BF 0F F2 9F 29 D7'\r\n '5D 73 CC 92 4C F9 54 BB EC 4A 22 23 11 18 22 22 22 92 85 01 40 95 5D 28 92 97 94 C4 A6 65 42 94'\r\n '59 55 F2 AC 25 58 CA 34 AB 29 56 6A AA AA AA AA AA AA AA AA AA AA AA AA AA AA AA AA AA AA AB AB'\r\n 'B7 EF EF B2 DB CB D9 E5 DF E5 C6 CB 73 2F 69 97 D2 E9 6D B7 F8 1B FC 1D FE DF 7E AA FA B5 F5 8B'\r\n 'EB 57 D7 2F AF 5F 60 BE C5 7D 92 EB 2F 05 71 2E 35 E8 97 A3 5E 91 7A 55 E9 97 A7 5E A1 7A 95 EA'\r\n '97 AB 5E B1 7A D5 EB 97 25 75 6D 65 5D 55 4D 45 3D 35 2D 25 1D 10 C5 05 6D 96 C7 61 AF D7 6B 75'\r\n '9A B6 18 50 01 40 05 00 14 FF E2 EE 48 A7 0A 12 0A 2C 8C 37 80'\r\n}\r\n\r\n\r\nLANGUAGE 0,0 DECOMPOSITION UNICODEDATA LOADONCALL MOVEABLE DISCARDABLE\r\n{\r\n '42 5A 68 39 31 41 59 26 53 59 4A 0C 4F 7A 00 5E 63 FF FF FF FF FF FF FF FF FF FF FF FF FF FF FF'\r\n 'FF FF FF FF FF FF FF FF FF FF FF FF FF FF FF FF FF FF FF E0 5A B4 BD 07 43 D0 03 40 00 09 00 3E'\r\n 'F0 14 14 17 8A 09 4C 99 64 53 D1 A6 94 40 52 DE DC 25 54 12 92 84 A4 05 50 55 22 50 02 80 05 14'\r\n '95 05 29 54 92 10 A9 6F 8F 00 00 7C 00 10 07 D5 1E 66 A0 03 15 BE FB BA E2 0F 96 86 11 81 CF 97'\r\n 'DE EE D6 FA 9F 00 02 50 05 87 53 D2 81 9E 73 B9 3B 6B 83 07 CD 00 5A B0 C8 F7 55 06 15 CE B4 7D'\r\n '0F BD E6 EC 2F B0 79 94 01 4A 01 23 BE D8 2A 40 A9 D0 D1 40 28 92 A9 02 51 45 00 00 00 BC 00 05'\r\n '0F B8 1C 2E 00 00 00 06 40 00 C4 A4 6A 9E A0 D3 08 D3 D2 78 A7 A3 51 A7 A9 FA 93 D3 24 F2 6A 6C'\r\n '34 4F 41 34 D1 A6 34 32 6A 7A 68 64 C2 A7 FA 83 26 34 68 69 A9 98 11 93 23 4C 83 4C 24 F3 23 41'\r\n 'A6 81 A0 1A 00 34 62 19 30 9A 64 C0 30 49 A6 06 40 31 30 AA A1 13 42 01 34 06 80 00 20 C0 8C 40'\r\n 'D0 0D 34 34 4D 35 36 9A 01 0F D2 86 4D 3D 41 4F 69 93 21 A7 A9 90 48 F0 68 D2 60 69 30 D0 68 53'\r\n 'D3 4D A6 93 08 F4 C9 AA 7E 9A 69 53 F0 2A 7E 53 C2 87 B4 2A 6F 4D 4F 23 1A 06 99 1A 9F A4 98 CA'\r\n '90 68 26 81 92 09 32 41 A0 02 32 35 1B 23 46 8D 23 26 8D A9 BD 43 53 4D 53 F0 86 8D 27 E9 30 88'\r\n 'C5 0F 53 F5 4D 1F AA 34 6D 40 19 00 19 1E A0 68 00 00 00 01 A0 F5 00 00 00 1E 90 3D 46 D4 D1 E5'\r\n '00 00 0D 4F 69 24 41 1A 11 94 C9 E9 23 4D A2 6D 23 23 CA 6A 7E A1 31 89 81 9E 92 9A 9B 50 DA 23'\r\n 'D0 04 C0 01 18 23 68 06 A3 43 40 0D 1A 01 A6 46 00 4C 06 80 0F 50 98 D1 31 A0 68 13 04 D3 21 A0'\r\n 'F5 31 18 26 01 27 AA 54 92 28 F5 46 68 64 8D 34 64 D3 23 4C 8F 53 23 23 20 68 32 68 D0 1A 69 A0'\r\n 'D0 D3 13 47 A2 32 32 32 7A 26 9A 0D 0C 80 C8 32 68 D0 C8 D0 D3 D4 F5 0D 06 26 9A 31 34 03 26 43'\r\n '4C 23 23 46 4C 10 61 19 18 10 00 93 52 20 99 04 10 10 D0 4F 49 EA 9E 26 89 E8 1A 69 3D 47 90 54'\r\n 'F7 A8 62 6D 05 3C 4C A4 F3 4F 44 51 BD 29 EA 7E 29 9E A2 9F A6 53 62 9B 42 9E A6 CD 23 65 1E 54'\r\n 'D8 D4 6C 9A 1A 4C 53 CD 43 D1 85 32 8F D1 A9 E8 D4 F4 6A 63 D1 4F 54 6D 95 3D 47 B4 27 A0 8F 49'\r\n '1B 66 A8 C1 34 9D 25 4A B8 D9 FD 26 9F 9A E7 75 79 5D 2E 97 A4 E8 6E 03 A3 1D 7F 49 9D E4 DE F8'\r\n '1F 96 97 50 AF 41 CB 74 5C C7 47 A8 E9 18 71 97 CD 38 D7 B3 67 FE 5B 0A FA FC 30 37 1B 8D C6 E3'\r\n '71 FA 77 1B 8D C6 E3 EB 9D FD 4A DF 7E 2F D6 DF 2D 3E 36 06 66 4F F6 F9 5C 0F 3F C5 F1 BF 47 0A'\r\n '8B F6 E8 A9 54 AF 4B 4F 51 62 DD 55 CB D8 31 D6 D7 66 D3 61 AB 67 0E 5D 3B 78 20 A3 3D D9 7D B4'\r\n 'FE 04 18 50 E2 0E 44 68 F2 24 CA 96 51 73 0C 34 FD CF C1 F1 FC 3B DF 87 6F B7 DB ED F6 FB 74 10'\r\n '41 04 10 D4 A2 8A 28 A2 8D 4C FE 7F C6 FE 7C EE E6 B5 5E 53 17 4D A2 AD 59 87 15 9C 56 74 EA B3'\r\n 'BA DC 3E 17 D5 F8 E8 C3 4A EB 4B E4 6F 77 BF 21 EA FF 1B FB 2F 75 A2 DB E1 1B 57 34 6D 7C 24 D1'\r\n '10 62 C0 48 22 20 02 20 30 5E 39 78 E8 C6 11 7A B2 08 79 B9 90 1F C1 D6 2C F2 16 B1 9C 6C DC DE'\r\n '34 30 4E CE 19 8A E9 C4 0E 93 BB 7C E5 CB 86 CE 4E 73 9D 87 8B 22 8C F9 F0 20 3C 59 65 55 6C E7'\r\n 'A1 1E 84 5D F9 B3 21 BC 67 DE A4 40 7E 02 FD 47 4F 2C 94 81 B5 3B F1 11 01 01 14 5F BF 7E FD AB'\r\n 'E7 CF 9F 37 70 02 76 FF CA 53 89 5D FC C6 49 B0 C7 A0 F6 0D CE F9 EB D6 BA C7 CF AE EE D9 B3 6A'\r\n 'D6 07 51 D4 59 59 74 FB 1E A3 A8 BF B9 DD 43 BF 9D 4E 6E EE BE D2 D1 59 52 C0 66 4C 89 29 29 9E'\r\n '19 67 24 9C 1B 22 9C E5 89 10 E7 8D 18 C6 91 21 37 0E DD BB 76 F9 16 52 5B 35 66 D2 4B 76 ED D5'\r\n '78 F7 C7 DB F9 1B 8F 27 F8 F9 5E 5F 67 E5 A8 A4 2B 6A F8 FB 87 EE DF BC E0 E3 70 71 F8 38 39 BC'\r\n 'FE 01 C9 E4 A0 BC 65 A4 93 33 77 E6 BC 9E 67 E0 C7 9E 9D DC 4B 5D 71 8B 64 07 83 4F CE F6 7F 71'\r\n '67 38 D7 50 6E 9E 40 87 3B B3 BF B9 B9 B8 B8 68 D2 E2 85 C4 91 10 8F 1E BE C6 2C 58 B1 6E 22 43'\r\n 'ED 34 31 C8 FE CA 44 08 BF C5 03 A3 7C CA 35 89 C1 14 62 4B 97 E5 3E 7C AD 7B F7 EF DF C7 8F 06'\r\n '0B 70 AF 6E 9C 17 5D 8A 20 85 FC 07 8F 7C BC F8 78 6F 1E 3C 78 F1 E3 77 8F 1E 3C 78 C0 59 A8 E4'\r\n 'DB B8 67 3B 11 91 03 9D 68 91 0D 70 B1 01 F1 A6 37 86 69 57 09 00 1A 64 45 0D E6 DF CF B4 D0 C5'\r\n 'AB 6A 22 D9 48 2F CB FC AA 3C 32 B0 8C 6D 2E 09 6A AC F8 DB AC 32 E2 3D 7A 6A B6 25 C1 61 A9 AA'\r\n 'A4 5B D7 15 C6 AA D5 65 65 C9 24 92 49 24 92 49 26 7C 38 5B 3B 33 94 CE 74 BB 3B 33 7D 73 A2 D5'\r\n '3D 7F 4E 76 2D EE D4 F6 17 E0 F0 DC 38 47 74 8B 33 64 38 70 68 91 86 95 79 F0 9D 38 36 EE 71 6F'\r\n 'DD C7 34 C0 73 74 EE 44 85 6C 9D DC E3 2A AB CA EC 5C 36 D4 DC 52 C4 68 D1 F5 AD A6 71 C3 86 8D'\r\n '26 5D 4A D1 49 E4 A1 E7 5F 3E 87 0E 9E 0C 58 B3 ED 6B F9 2A F4 94 58 D5 E9 A7 04 F8 F6 56 26 BE'\r\n '6E AE 29 EB A6 CD 34 C8 B1 62 C5 52 0A 56 12 A6 1A 1B 65 CA F5 9A 39 C6 A8 4D 45 59 AE 26 B3 99'\r\n '32 64 C7 8F 1E 3C A8 E9 D1 5D CE 90 E0 D9 D9 32 62 44 7C 94 A5 2C 2C 17 55 56 56 EE EC 2C 0F 19'\r\n 'AC 97 35 CD D8 46 3B 8A B1 E3 4A 8C C5 F5 EC 88 F1 A0 51 A1 71 3E 75 5A B5 6A D5 AB 56 AD 5C 45'\r\n '14 51 45 14 51 45 14 9D 73 3E 94 F9 54 A9 51 9D 4A 95 B5 0B 4C 9F 46 EA EA EA EA FE FF 26 FE 9D'\r\n 'EB 26 AC 1A DE BC B7 CD 98 76 7C 8A 57 06 74 F1 F5 28 D2 E5 CB 97 2E 5C B9 72 E9 B4 91 5D 5F 7C'\r\n 'C5 F4 BB E9 97 90 6E D5 B7 9B 6F 3A 9D 36 F3 E6 4C BA 67 17 00 09 6F 2E 44 89 12 24 48 91 22 43'\r\n '25 14 51 45 14 51 45 14 B0 6C 33 A6 69 5D 3F 6D 0E 3D 37 37 02 3F 43 CB 15 62 4E 6B 5D 00 20 08'\r\n '8C 01 2C 02 96 01 4A 76 56 16 16 56 56 0C EB D0 6B 71 3A 5D 17 58 0D AD 04 04 08 0D DB 99 81 30'\r\n '89 97 BA 83 67 3E 74 D8 D0 1B 4E 71 3E BD CD BC 96 70 DF 5C D0 9B 46 0E 03 F8 22 03 02 01 AC 08'\r\n '0A 04 23 20 22 ED 9B 3B A6 27 44 C0 66 A8 2A CC AC C8 0B 94 E2 34 29 52 0C 16 97 92 AC E7 C6 68'\r\n 'C8 19 34 28 15 99 4B 75 83 6C BA 71 A7 57 C7 F4 70 91 81 19 20 C8 D7 B3 D1 C7 47 BA E8 73 F1 D3'\r\n 'C3 87 3C 1E 0D 7C 1E 4E 39 DD 1E 8F 31 FA E7 71 73 83 83 5E 73 F2 E3 46 86 7C 25 94 05 05 61 58'\r\n '4D 9D C7 C7 B4 56 24 78 F1 7D 2C 56 8B 82 E2 D0 5A 09 9F DA AF 12 3C 78 9E 9E 73 3F 29 38 B1 E2'\r\n 'E3 5F 21 12 BE 3C 2B 8B 56 69 41 89 11 DE FA 43 02 17 C9 BB 7C F9 E7 A3 9F 46 33 D7 EE D8 DF E4'\r\n 'A7 76 A3 D9 AD BD 2C DA 48 BC 86 FD 5B 47 0D EF 69 DE D4 B8 64 93 E8 30 6F FD 34 1D A2 DB 0A 75'\r\n 'CA D0 A2 38 79 8D C5 5E DA 00 A9 09 AB 4B FC 44 E2 99 E3 2B 62 5B 61 16 90 98 B4 8D 8C 20 62 E4'\r\n '18 1A D7 58 51 65 8E D4 A1 06 2C 78 71 20 25 61 61 26 24 88 F4 F3 A9 AB 06 2C 7D 0A 12 95 90 E5'\r\n 'EB A9 16 4C D0 7F 71 6F A1 5D C3 F1 14 04 0A 20 51 62 85 DC 16 F7 96 B8 F0 59 2A D2 7B 76 96 46'\r\n 'BC 66 9C 17 90 61 26 A6 35 AA 71 D3 07 8F E1 27 11 63 A6 BA 29 83 B7 B5 EE F9 24 F4 69 03 96 75'\r\n 'EC E9 52 4D 20 8D 6A F5 25 13 74 9B 70 86 EA 2D 84 D6 60 78 16 30 20 2F 9D 5D 30 62 7C 3B 28 5A'\r\n '6B 24 D8 53 41 46 6C 87 D9 09 C0 6D 4A 94 C8 B1 72 13 9C DA 90 1A D6 14 2C FE 7D 0C 1B 44 EF 21'\r\n '3B D3 64 A7 63 29 AA AF 22 4C AF 94 93 EB E0 9D 1A CF 13 25 AB 26 4C 99 32 3D EB 2D 1D D3 48 E8'\r\n '67 D9 40 61 DA B6 74 63 C7 BE C8 55 D2 7A 37 2F E2 E4 5E 27 2C AF 28 5E 5D 46 4B 21 19 F1 61 C3'\r\n 'AB 91 0D 8B 7A E8 30 72 41 0B 56 A1 29 FB FC 9F 55 2A 12 9F 3E 45 0A 14 9E 3C F5 A3 D2 74 EB 99'\r\n '60 E4 6F 5C 12 68 C7 10 06 F3 60 DB BF 7F A7 5D 89 3C F2 90 EC E1 42 D3 F3 0A B2 41 88 0A C5 B2'\r\n '86 D7 2A D8 16 15 20 53 8F 24 D1 B4 E9 B2 4A 45 A4 18 35 A6 26 20 C9 89 E7 B5 82 F6 B1 DD BF 0B'\r\n 'D7 2C E2 B2 A5 6C EA 0A C8 59 51 70 B5 67 20 91 E3 08 B9 6E 50 30 81 86 A5 2B B8 10 2B 2A 96 14'\r\n 'AD 04 85 AF 2B 33 8B A9 59 E5 02 87 27 06 0E A5 E8 21 34 8F AD EB 9D 48 5E 8E 04 68 8B 67 01 55'\r\n 'A7 B2 31 8C 63 33 7C 82 08 40 83 45 50 CF 47 8E 66 12 7B 46 B4 48 96 D2 14 49 36 CF 28 DA 68 11'\r\n '8C 9E 7B 39 6C B5 A2 D1 34 E9 B7 96 EA D2 B9 FB F4 B1 6C 6C D3 B4 37 2B 09 7D 1C 25 6E 6C 21 AD'\r\n '6A B6 9A 1C 36 A0 AD 8A 73 5E 68 A5 42 84 DD 4B 14 F1 E9 5C D7 44 88 9B 4D 0C A2 A8 A4 A9 71 62'\r\n 'A9 25 34 EC B9 38 30 52 46 5C 92 A7 1A AC 08 09 A9 63 64 9D AA 1C 9B F7 F1 2D 50 58 80 63 58 AA'\r\n 'AD A4 C7 EF F0 5C A3 5F 15 FB F4 10 6B A6 7A F7 02 34 24 B1 D7 7C F9 68 88 C7 72 E4 CF 47 11 CB'\r\n '9B 33 E0 39 73 34 F6 BA 47 0E 29 A0 86 8D BB 7A E4 10 B5 6E DF 49 19 14 79 27 0E 28 A0 83 D7 0E'\r\n '2C D0 A4 F9 86 2C D0 42 E5 86 32 A8 22 8D 36 18 9F 47 02 C3 21 D3 A9 E8 21 90 E9 D5 9A 16 F6 6E'\r\n 'DD 9C F2 E6 B0 C4 E4 51 BB 70 E1 44 0C D9 B3 63 9D 86 BA 71 59 BA 9A EB E3 6F 4F C8 ED 6C B3 B3'\r\n '79 1A EB 56 6F 37 5D 7C 46 6D BE 3E F6 F3 37 BF 7D 70 D9 79 9A 23 49 3C BD 75 59 1F C0 CF 36 6F'\r\n '83 3E 1C F3 A7 5A 94 AE DD 34 0D 2E 1D 34 86 6D ED 75 E5 72 5B 65 55 7A B9 E7 FF C6 6E 56 9A 7D'\r\n 'EA A8 DB B5 6B 14 E7 82 D1 A9 CF 83 35 B9 CE D1 A1 9E A4 B9 8D 57 12 A1 CF 87 24 C6 46 13 D3 B9'\r\n 'AB 1F 08 ED AA E2 1A 65 56 86 35 54 4C 6A B8 86 32 A5 9F 55 54 0E D3 09 63 33 C1 65 66 74 AA 2C'\r\n '6A 67 C0 C3 56 D5 1A 68 D4 69 06 7A 34 D1 97 80 E1 0A 6D 30 1C 1F 10 F5 06 0D E4 FC 43 C1 62 85'\r\n '07 A8 54 6F 41 E1 DA 2C 91 EA D5 87 05 FB C5 14 51 45 14 51 45 14 51 45 14 52 ED EA 16 87 5D E5'\r\n '16 8E 6C 5D D3 B5 B4 72 8B C6 56 8E CF 70 E1 CB 2A 2F 51 96 D6 83 F3 E0 54 69 69 09 09 AD 6D 2D'\r\n '70 64 C9 6B 6D 4E FD AD C6 02 F4 9F E0 B3 B9 7B 82 D2 E9 BD BB 26 8F 2E 9B DC B3 6D 75 6B 75 30'\r\n 'F7 57 D7 8E 17 BC 93 51 BA 96 AF 70 1B 9E B9 E3 17 8E 2F 0F 5F 80 E2 ED 9D 7B A6 F2 AE 6E 93 A4'\r\n 'C5 DB C8 D1 EF 9C DB 52 79 1D CD EC C7 B7 CE AD 26 A4 E5 8B DA D6 ED 2F DC 5F 21 4A 8D FB 17 DA'\r\n '96 10 A6 E6 FD D5 E5 30 73 7F 7D 73 4D CC 9A 13 2D DC C9 BD BC 93 41 CC 97 75 6D F0 1D 4B 9D 66'\r\n 'D9 CC C9 D6 38 0E A5 DF 2B 80 C4 BB E3 DE 37 95 7B 80 DE 4F D8 F9 EC 27 16 1F 6D F8 45 0C 17 36'\r\n '1F 8D C5 E6 13 A9 37 EA 96 C6 BE 44 58 70 1E B0 D5 45 14 51 45 14 51 45 14 51 45 14 51 45 14 51'\r\n '4C 28 0B 70 EC 6A 3F 69 C3 C0 AA FD C3 DA AF 5D 52 AA DD E5 47 D5 5B BF AA D6 05 9B 48 35 59 C2'\r\n 'AA CA 1D 56 50 F0 99 41 C3 C1 5E 02 C7 CB C1 67 01 EB DA 8D 9F 9E 9B 67 F7 ED 9F D0 66 FE DD 77'\r\n 'F2 2E D7 83 C4 4A ED 9C 29 5F 55 DB 58 9C F5 DA BD 87 BC EE 78 FA EB 78 FE 2E B7 C7 6F E9 76 FB'\r\n 'BA 5E 53 D6 29 EB 0E CA 89 51 57 BE 63 54 30 54 BD 43 89 26 26 1E E5 3B 30 89 8B 04 A2 78 ED 70'\r\n '66 89 30 88 13 DE 9D 41 16 99 81 F4 5D C6 32 86 CC A6 48 41 0C 83 24 26 2A 30 34 91 98 8B 29 A6'\r\n '78 6E 44 08 DE 5D 3C BA F0 C9 02 63 18 A4 A0 8A 8A 11 48 33 0D 24 86 2A 64 12 48 59 0D 26 6F 1E'\r\n '57 C3 24 01 81 5F A5 94 D8 58 67 A9 68 A4 92 84 44 4F 3C 95 24 11 67 8E 9D B5 C8 99 AA 32 51 A2'\r\n '8A 48 86 19 AF FF 6B 5E 79 6D 78 ED 6B 8B 69 6D 9A D4 DB 66 B5 7E 03 6D BF 4F A3 12 16 C6 8B 26'\r\n '31 89 23 18 B0 D5 57 E0 AF A2 6F 43 AE 57 5C 1E A9 1D B7 8A B7 BF AF 26 BC 9E F6 BE 6D 41 E7 39'\r\n '17 3C 9E CA DE 42 C8 15 59 31 42 99 29 8F C1 AC 64 07 3A 25 22 2C 36 C9 27 87 F5 C1 56 DD 6B 79'\r\n 'FE 9B 10 B2 40 90 9B CB B7 0C 42 6F 3B 57 74 81 43 72 EC 51 6C 5E 3D 24 BB C3 C3 3B B9 B3 8B AD'\r\n 'E6 DD 71 78 EE EE E1 B9 D2 6E E2 E9 02 F4 7D D8 3C 23 5B 84 6D DD C1 BD 69 AE FD 2F 5D E3 8D C8'\r\n '81 CB A7 3B 73 17 A2 6E C8 F1 34 5D AC 0A 15 AA 51 60 8C 01 54 92 E6 07 98 76 67 4C 8C BB 6A FA'\r\n '1D 97 83 C1 C3 98 B3 F2 5D 6F 24 F3 C1 37 13 69 7B A6 9F BB 00 B2 03 7F 3F C1 B8 96 1B 6C CD 6B'\r\n '8F 10 69 80 D5 90 F2 5D BB 02 E5 33 A5 BA 5C 91 F1 77 85 52 A4 3B 5F 08 95 F1 4B 26 14 D2 AB 32'\r\n 'C0 62 86 0A 9F BD F7 CB 79 75 4D 2C 9A F6 BC A5 91 DB 86 CD 26 00 DE B0 2A 97 0A A5 73 D9 62 CA'\r\n '6D 65 F3 C3 03 3C 29 52 82 8C 84 8A 26 3A 16 24 8E 90 36 9B 61 20 E0 2B D8 B3 0B 44 C4 DA A6 B1'\r\n 'C0 54 ED 4E D8 43 06 35 40 D3 57 96 BA 54 AE 5D C8 A2 31 BC B4 4A E0 D2 AA AB 4A B0 17 43 05 77'\r\n '78 87 64 D5 34 A5 ED 56 70 A4 0D A6 DB 6D 36 EC 9A 80 DB 42 42 84 8A 26 3A 42 C2 D0 74 81 E1 75'\r\n '14 4D D1 51 0E 02 C7 1B 4B 38 5A 93 13 6A B0 54 62 97 42 92 C3 8D EB 16 CC B2 89 81 80 93 2D DC'\r\n '7C 89 2F 96 EC 71 BB 86 28 2C 16 29 7C AA C8 71 DD C6 D7 18 8D F0 BD AE 85 5D B9 83 75 76 AC 5E'\r\n 'ED 8E 2A 68 99 22 A6 94 68 69 BB 16 68 6B 5A 0B 40 82 E8 B3 03 43 19 86 C2 D5 81 8A 14 76 33 56'\r\n '6C AB 16 29 2D 62 B6 70 AB 15 47 14 65 87 BF 49 80 98 2A 17 8B 67 61 C4 04 11 46 22 4F 5F AD 7C'\r\n '55 95 16 D5 F7 F5 BB 26 4B AD DB 39 BA D5 D5 B3 57 36 8D 9E 7C AB C3 78 B5 74 C6 4D 19 A6 54 62'\r\n 'A3 24 94 92 0B 23 69 D4 92 7C F4 82 49 37 97 D8 74 FC 78 18 30 82 92 13 0D 75 E8 3D 8E C0 B1 64'\r\n 'E5 95 57 B6 1A 16 39 79 F4 E9 AE EA 2A 85 52 44 02 01 49 22 01 00 80 5B BA 5B A5 8E 81 A0 B7 58'\r\n 'D4 A6 B6 E7 BD DD DA A3 4E C2 B0 9E 08 53 19 5B 0B 59 35 CA BD 7C 55 8B 53 95 D1 F2 BF AD 7C C3'\r\n '09 CC CD 02 80 DE 06 91 29 44 06 48 AA C3 9A C4 49 E3 C5 C6 4B A9 AE 95 76 6E 9A 83 5E 19 2D E3'\r\n 'C7 51 75 35 DB 79 6A A4 DA 92 AB CC AB 94 CE 51 D6 DA A4 10 3A C4 86 F1 84 C0 64 88 31 11 14 51'\r\n '9D 58 48 75 70 B9 7A 85 A0 13 AA 8C 09 7B 02 AB 04 95 2D 2D 68 AA C2 B9 E1 D1 62 80 B0 21 CD CD'\r\n '59 14 96 81 3A 20 B0 60 98 D2 49 58 6B 7A EF DF 1D E3 CE BB BA EE E8 88 88 14 51 64 97 47 AA 38'\r\n 'CC A0 3A 15 3A E3 43 78 9C BD 0A E8 B9 8C C1 BF FF BD 1F 2F E1 70 EA 84 E8 04 0C CA 80 2B 05 11'\r\n '10 64 1E BC 4A 94 74 00 1B A3 68 00 0D 54 88 B7 11 0D BB A4 2C 2E 7A A6 CB 80 85 23 EE F6 7D 1F'\r\n '6A 5B 01 CC 19 1B F8 42 51 CE B9 46 D7 6E D2 54 BB DF 77 7B BE DF F8 B0 DC 39 08 4E 75 14 14 8A'\r\n '34 0C 52 AA 93 6E E8 4D F8 1D AE 05 1C 1E 1C 20 51 77 86 1B CD D7 DC 38 8C 00 48 84 75 35 B1 B6'\r\n 'E5 19 BA EA 54 BB AF D2 F5 36 ED 30 C4 54 59 A3 D9 1E 89 51 BA BA EE 97 2B A0 77 39 14 68 C5 05'\r\n '7A 3B FB 5C 0B E3 BF 75 B7 D4 2A 11 19 83 E8 BB CE 4F 95 C3 81 8E 42 20 88 82 08 88 6B 45 6C AD'\r\n '6A DA 89 43 2E EB AF 3B F6 FA 1A 98 E4 24 38 50 41 EC DD 1D 10 A4 6F EA 3F D6 B8 69 83 21 B8 18'\r\n '1F 98 D6 EC 24 B0 90 C0 20 68 FA BF 43 FC FF EE DC 65 90 C0 04 43 3D 6A DE 32 8D CF 25 CA 5C 77'\r\n 'D6 F4 BE FF 47 C9 E3 7F E1 BC CB 29 BD 2B 47 4D 69 65 FC D7 3B 5C B4 D0 CB 28 9B E8 AC 1D 34 2A'\r\n '5F BE F4 F9 97 B8 84 E7 88 80 EA 75 AF C7 30 A4 CD F3 B9 B7 B8 9C F5 08 10 56 AB 75 D8 64 14 98'\r\n 'E4 DF E3 F4 B7 7D 77 2A 0F 0C F8 03 DD 6B 44 9B E8 A3 57 6B B9 97 7C 76 1F BB A9 73 03 C3 51 D6'\r\n 'F4 6E 5B BC 75 D4 2A 5D F1 3A FE F7 A4 E8 6E 36 65 9C 20 B2 02 81 1D 94 42 87 89 2B 57 0C 0A 97'\r\n '7C 4F 86 E8 5B 61 95 62 48 22 10 50 22 80 67 56 CC A9 76 DD 3F E0 FA 8E F3 61 89 41 80 0C 20 03'\r\n '07 EC 75 86 DB 71 B9 DA 7B 55 D3 50 82 0E FC 4F 5D FB 1B 36 0A 0A 8D 80 1A 6C 38 80 10 BB 47 D4'\r\n 'C7 77 84 FB 18 C0 A0 81 82 3F 1F 29 65 90 01 09 8F BF 8F 03 B9 EE 63 02 82 A3 00 5D 04 4A 24 02'\r\n '14 8F 5D 1F 1C 5D 60 5E B6 20 6E 6A E4 85 23 DF 7F AA FF 41 DC 5E B6 19 98 48 39 7D DE 09 49 8F'\r\n '8B 97 89 8C 7B CC 0A 54 18 00 8C 1C 1C 38 20 85 23 EE 6B E3 3B BB 8A 56 DA 04 0B 07 0C 02 14 8F'\r\n '95 19 BB B8 9D 08 EE 77 B8 08 24 7C B6 CF EB DB 8D 71 41 51 99 D5 5D C1 21 48 F6 E7 F6 7D AB 86'\r\n '13 2F 6E CB 62 06 52 3A E9 F6 7A E7 71 3C EC 2C 08 48 09 21 1F B6 6E C8 52 3D DD E7 81 E2 3D C4'\r\n 'C0 A3 83 09 D5 37 70 85 23 CC 72 B4 BD C3 4E 92 B9 62 FE 11 D3 18 15 2E FB 0D 7D 96 BC 35 DA 65'\r\n '9A 01 11 11 36 85 AC 56 DB ED DA 41 09 8F E6 47 5A 1D C4 E8 61 10 90 EE 97 BA 14 8F B7 7F F6 5A'\r\n 'C1 A6 62 8B 89 09 25 D2 E6 52 3D 9F 3F A9 97 DF C3 8A 54 C0 4F 88 A1 41 BA 3E 09 0A 47 EE 69 D7'\r\n '8E C4 40 A5 4C 88 16 AB 29 A4 51 64 B1 DB DF 6E D2 A5 DE 6E DF F7 69 B0 C3 11 84 AD 2D 34 BE 9A'\r\n '4A 63 BC 9E AD E8 7E 33 D0 F4 2F 37 B6 6A 80 00 00 04 7A 50 1A E1 28 D7 09 44 A2 51 92 37 33 B5'\r\n '65 9F 26 4E 19 E7 C0 81 20 CC 33 41 ED AE 4A 4D 93 34 10 6E 04 21 01 F0 3B 66 CB 75 9D 64 A9 77'\r\n 'D4 70 FA 5F 1F D2 D0 C7 20 76 7B 0A A7 40 65 DE 5E 2E 6E 9D 3C 34 1C 8F 09 11 3C 70 50 91 04 84'\r\n 'CB 11 E3 FD D7 C8 D3 02 C4 42 C1 08 02 43 00 02 BF 6A 40 43 40 64 29 1E 71 C8 D6 22 05 2A 0C 02'\r\n 'D5 40 00 82 28 3D 70 98 C2 13 1F 7F 8C B4 F7 B8 81 42 00 0A 83 08 08 88 79 68 A3 05 85 C6 00 42'\r\n '63 DB 8E 0C 44 09 82 A0 4D 10 28 8D 12 20 82 13 38 EE BD B7 71 30 40 4C 18 27 23 40 6E E8 EE 84'\r\n 'C7 C1 1C 11 E6 E3 02 84 5F 46 90 36 30 0B 49 3E B6 AC 3A 9B B7 59 B5 4B BF C5 BB ED 37 73 37 6D'\r\n '32 08 6E 66 C2 C4 E4 F3 97 B9 81 37 FC FD F8 70 95 31 7C 4F 0F 29 C3 CE 70 E0 6E CC 15 62 C8 6C'\r\n '78 5E 3C BE CE 26 26 3B AD 13 46 24 26 3E 9E 9D 0D 39 1A 66 34 A8 20 60 CB 33 B8 54 CB 24 CB 20'\r\n '86 0C B1 7D 46 FE D7 FC 3D 2D FB CC A1 B9 62 4D 9C C9 D9 48 5A C5 E5 70 E1 5C 38 05 4C 5F 11 F2'\r\n 'FC 86 FD FB C4 C1 40 30 55 C8 7C E5 51 29 E5 2C 8F 2C 89 0B A0 7F 1F C3 F8 1B F7 CC 4C 84 19 16'\r\n '33 44 0A DB F7 E1 BF 7D 4C 9F 13 AE DE 4F 3D BC C4 9B 81 27 7D C8 42 91 18 7A 24 96 45 18 60 0D'\r\n '48 4A 06 BE 76 9A B2 6A 44 85 33 D7 5E F3 C6 BE 82 64 34 32 2A 83 53 41 28 AC 34 40 24 2A 1E CF'\r\n '3C E2 EE 18 A7 9D 4D 54 44 44 A2 81 04 CF 8D 3F 93 C3 10 2D 4B 5B 94 61 62 12 73 04 84 C6 FD F7'\r\n '36 22 05 A9 9D B9 E4 43 96 0B E7 09 33 0D F4 5D 34 5B 68 10 A8 7C EF A3 E0 E7 98 AC DC C0 AE D4'\r\n '42 88 59 C0 08 4C 71 DE 43 8A 33 D0 F3 EF 42 05 12 3F 77 0B 48 20 87 D6 32 42 99 E3 B7 F6 FB 32'\r\n 'B4 CA 90 88 51 0A CE 48 18 DF EB 75 3D 67 AC C3 8D C9 62 88 5C 76 92 A6 0F 65 BB FD FE CF 77 16'\r\n 'FD 33 DE 68 0C 45 8A 8B 04 65 05 23 BE A8 EC BB CE 17 CB 85 30 66 2D B7 F9 AE C3 7E FD F8 E5 BC'\r\n '54 36 48 02 C0 A2 A8 DB B5 5A 09 09 8D 63 E1 D2 D2 6B 03 31 43 42 44 02 5F 0F 46 60 D4 79 55 C2'\r\n '14 CD 77 B9 F4 CB 6E 18 E8 0A A9 99 72 42 A8 42 0E CC B4 BE 57 95 30 6D A7 5D E7 F5 D3 0C 75 33'\r\n '04 44 05 52 91 29 64 92 5E 40 21 6A 39 95 B7 6E B9 ED 0D 85 4D 65 F1 7C D7 6B 98 14 0A 09 40 45'\r\n 'BA DF C0 BB 94 CA 86 AF E1 7E 47 CB D3 14 82 23 B2 29 02 06 07 E2 14 48 F2 C8 E3 01 83 1A E3 DE'\r\n 'E3 B3 8C 4E 98 04 66 64 2C 72 53 1D 4E 94 98 18 C3 76 FC F7 93 03 16 DB FC 36 FF 35 BF 7E 46 D9'\r\n '36 32 52 84 AB 12 49 54 23 D0 DB AE D2 26 0C 71 E7 47 A9 0F 32 83 01 08 81 21 82 00 BD 75 B0 BF'\r\n '67 18 52 0C 4C 78 F9 7D DF 13 11 4A 60 03 B2 21 A4 82 9E EE F9 A6 32 C2 E4 96 B1 4C F2 E6 EC F7'\r\n 'F9 65 4A 38 34 40 86 0C B2 C9 44 87 AB D8 CF 3C CA C5 33 F4 7A FB 78 33 CE 94 C0 33 30 11 10 74'\r\n '91 41 E4 78 C6 0A 85 33 F1 7E 0E 3B 18 C5 28 E4 46 63 E1 27 97 EC FF 9A 72 A1 9A 69 9E 87 A0 29'\r\n '93 1E DE 96 79 DD 86 62 80 19 C5 11 54 8C 15 5A A6 CA D6 B7 D7 5D 66 33 17 93 B1 E6 ED DB B7 13'\r\n '51 03 31 B2 B4 3B 75 DB ED 2B 74 30 9E 22 DB FB 9D FB F7 EE 33 9B 8A 85 08 6F AB 0E FB 64 AF 80'\r\n '10 4F AB E4 7D E6 31 05 40 E4 2A 61 0C F8 A7 2E 07 98 96 58 C9 51 89 09 B9 DD D7 23 0F 33 CB 2D'\r\n 'D1 6D 55 2C 55 E1 54 3E 7E FA DB 1D 45 2A 63 D5 72 69 A4 C3 64 14 4C 6C 04 96 A2 DA 6C D2 D5 A5'\r\n '23 30 D3 B6 D0 D2 60 69 31 54 41 91 82 14 60 C2 29 0E AA 05 76 75 77 08 27 9F 6F B6 E4 C2 C0 C0'\r\n '13 30 0D 3B AE A2 62 41 BB 71 85 4C 11 21 36 B8 C6 09 83 82 32 99 91 8C 74 B8 92 90 31 EE A7 85'\r\n 'C0 C1 49 4A 7A C6 F7 37 22 98 A0 32 A7 92 88 70 F0 A9 14 99 09 11 C7 32 0D C9 84 C8 03 9B F8 0A'\r\n 'A0 E1 A1 76 C0 42 9C 79 1F 77 CD C1 76 A8 E0 19 98 33 AE 59 71 96 59 EC D1 74 D0 90 A7 CB DD 9E'\r\n '64 C1 B1 8C 82 89 61 61 62 10 A7 B3 F0 31 F2 B0 53 13 18 E3 F1 A5 23 CB 66 4B 96 44 85 3C BC 9C'\r\n 'B9 99 14 C4 C6 59 6E 51 2C B6 64 B9 64 86 66 65 3F B2 EA FA B8 26 0C 31 BE 81 63 7A 16 20 82 14'\r\n 'E3 C8 FC 08 2B 4E 70 65 C0 BE AE B8 5C 61 0A 98 F5 31 82 C4 E9 40 20 E5 06 F3 7A 02 42 9B FC 9E'\r\n '27 B5 05 3F A5 A0 CC 18 C5 15 14 11 96 92 56 B0 91 95 67 B9 AB 9B 76 E1 31 F2 FE CF D1 EA 4C F7'\r\n '08 66 54 00 CC DF 48 11 04 4C 53 D5 DC A5 5B A1 94 CD 00 4A 22 03 1E 95 CD 30 39 19 84 C6 D8 F6'\r\n '9D 8E B3 1D 75 28 45 13 35 1A 72 AD 4D 75 0C 26 3F DC F2 1B 62 0A 70 E2 A0 18 30 60 03 33 30 A6'\r\n '13 C3 89 28 39 1E 26 C3 18 26 2A 63 B1 B7 B5 82 9D CE 0C 0A 83 10 B0 22 18 CC A7 AF A3 F1 5C 99'\r\n 'EE 44 94 32 23 23 0F 27 0E E4 18 A7 9F 8B F0 BF 0D 05 78 05 53 15 01 04 2C 08 82 0C 53 FB 8E 76'\r\n 'F7 B1 05 38 72 43 06 75 32 24 33 20 49 DF 41 21 28 F4 A7 21 8C 00 18 A7 8F 79 AF 5F 05 3B E0 20'\r\n '2A 80 62 20 44 14 89 BA 3E 74 7C 78 29 C4 00 87 E4 DB 94 62 43 2C 86 59 09 19 19 83 26 CB B2 3D'\r\n '9C 13 63 08 1C 92 91 94 C1 89 AE A6 BA 97 98 6B D3 EC B5 9A EB 32 24 C9 0E 05 70 4B 27 8C 0C 62'\r\n '46 60 37 63 48 28 82 29 99 18 9D 80 30 86 7D B5 17 B8 02 44 DA 4F E9 5C B4 D0 C4 16 28 99 55 29'\r\n '2A A1 4A B4 15 15 31 B1 A1 A6 93 09 8D FA 90 E4 F7 14 A4 81 18 40 66 EC E1 DC 06 03 48 EB 78 BD'\r\n '68 29 DC C4 60 72 41 A0 50 67 E3 36 43 2C 83 14 F1 DA C7 3B 00 5E 08 50 C5 4C C9 30 61 14 F0 83'\r\n '01 60 03 26 EC 79 BE 47 50 D7 1C 76 14 94 AC AE 50 4B 2E D4 AB BB 71 DA 5B 68 CC 78 BB 0D BB 66'\r\n '78 E9 16 28 E4 55 E1 AE 97 30 17 6F 8B CF 02 FB 41 98 FD 3F 75 DA EA 19 ED 98 AA 65 41 52 30 42'\r\n '92 9B ED B1 71 4D 70 35 2D A8 33 0E D3 A1 CB C5 AC DB A1 9C A8 E5 86 C2 89 06 31 8A 60 2E 01 94'\r\n 'F4 F6 21 C0 AD C8 A9 41 27 40 A2 47 D1 9B 85 72 00 CA 7F 73 D4 F2 3C A8 02 CE 2A 55 94 21 28 33'\r\n '86 10 16 08 C9 B3 E4 3D C0 7B 02 14 32 D5 28 5D B8 6A 5B 55 83 30 D7 86 5E 63 50 D9 A8 66 2A C9'\r\n '9D 25 14 E3 2B 85 B8 06 53 BD E9 7B 81 69 95 05 CE 68 2E 16 E4 64 D7 F8 9E 4B B8 0F 32 E0 AB 9A'\r\n 'C3 40 E0 C4 CC 81 94 F6 3B 81 56 62 31 73 11 2B 8F 8D 70 C5 4F 63 83 A6 E0 59 8A 65 7B 8E 85 C4'\r\n '89 BB A9 DA C0 59 84 C9 AD CD B1 09 13 47 CC EC 5C 0B F1 88 4C 50 CD DC 74 5C 84 89 9F 82 8E E0'\r\n '3B D0 54 CE 6F C8 57 00 C9 9F 7B C2 70 1F 9D 31 4D F3 88 85 83 29 C6 5C FE EB 00 62 62 95 84 F2'\r\n '62 15 8C A7 1E A6 46 E0 3C E6 0C CE F7 F3 D6 E0 C9 BE E7 C2 A5 EE 05 E6 54 33 6B E1 6E 44 64 D8'\r\n 'F4 3E 97 51 C0 79 95 35 38 8E 92 C0 23 29 E5 C1 47 70 1E 60 51 CF 9B 1A 2C 11 94 E3 EB F1 FC 28'\r\n '02 29 40 66 6E FA 2B 91 93 3F D8 EE 5C 0B B1 4C 19 DE F9 2D E6 68 53 E2 7A D7 B8 14 F8 B3 2A 07'\r\n '93 F8 B2 70 65 EE 9D DC 0A DC 4C 5E FE AA DC 80 32 6C 74 6F 70 2E C5 14 77 F0 D6 67 F6 50 10 AB'\r\n 'BD 2A BB 81 59 8A 0F 98 FD E2 B9 03 26 7F 74 FD 57 01 E6 54 0E FB 15 C8 8C 99 FC 41 D8 B8 17 62'\r\n '9F CF EF 92 C4 65 2B 0E 87 CD B0 16 6E 71 8A 23 A7 A0 AD 19 83 CD E5 D3 49 A6 90 CB EC D6 AA 91'\r\n '5A AA 69 33 A7 5E D2 B5 83 30 DF BA 26 E4 F7 2A 0A A0 3F 3B 77 88 B0 01 94 F3 7E 3B 80 FD 79 8A'\r\n '07 E7 F1 95 CC 9B A9 CC 6B 81 7F 8D 31 4D 4D D9 FD D4 84 11 95 33 F5 CE 20 0B 39 4C 19 83 30 74'\r\n 'F0 DF B0 AE 01 94 FB EF 42 22 00 89 8A 0F 3B AF F1 15 C8 19 33 EA FD DB 80 FA 95 39 86 68 88 60'\r\n 'CC D1 10 D0 C5 86 35 34 82 32 97 7B F0 62 20 08 98 A0 B5 F0 AE 64 DD 8E E5 80 B6 40 98 19 91 9F'\r\n 'AE 88 28 1D 88 88 90 C8 80 27 E0 57 04 65 3E F7 3F 62 00 B7 EA 26 28 4F 20 48 64 08 76 B5 57 00'\r\n 'CA 7B FE 6F 72 20 0B EB C5 3A D8 CF D2 6D EC A5 83 29 E3 D1 C7 43 00 5E 05 2A 22 51 F0 25 04 46'\r\n '53 E4 7C B8 EC 40 17 E9 56 A7 18 C6 72 C0 23 13 D3 8F 8E EB 00 61 E9 5F A3 2D 9E 34 A0 8C A7 11'\r\n '1E 7C 01 78 2A 03 30 75 4B 27 E5 B1 3F 0B C6 69 83 2A 63 BD C7 4B 00 5E 83 15 09 CF F7 88 E0 18'\r\n '93 F1 B9 8E E0 3C DC 74 4E CA 0E 18 7A 2B 06 4D EF FC 4D 3E 44 01 D8 8E 61 D4 1D B1 82 F4 17 06'\r\n '53 FC DF 5F 1D 7C 01 88 A0 AF 3A 39 8B 00 18 68 F7 91 D3 80 22 28 2B E3 C1 17 80 B0 0C 36 FF 22'\r\n '22 00 88 00 50 8C 8C 56 3B B4 73 07 2F 7D E9 D8 0B 4E C2 61 2C B6 5B 18 6C 65 7B 81 7E 2D E8 2A'\r\n 'FA 42 C0 23 6F 7D E7 C4 01 13 A7 AF 50 B0 7E 67 6D 26 40 E4 CF CA FD 24 40 11 42 EB D5 54 AA A5'\r\n '52 B4 74 1B 0D 6D E2 EC ED 8C 4C 4D DC 7D 4D DB 83 76 26 D4 CF CF EB 4E 0C 4B CB 8F 1E 3A B0 04'\r\n '52 13 72 85 BE 34 0A 63 E1 CB 20 0C 4C 62 5F 6B 10 04 4F 8E E8 56 88 BA C1 18 61 1C 5F 93 00 43'\r\n '39 95 1D E4 7B 64 E4 0E 61 F9 3A 7A 90 04 4D CC 0A FC 88 EF 16 01 18 61 1C 9E E3 80 F3 98 70 64'\r\n '8E E5 23 22 F7 D2 70 62 61 FB DE 67 36 00 89 96 A9 9E DD BD 6D B6 89 81 B7 CF ED EF 36 86 DC B2'\r\n 'DA A0 F4 D6 AA 91 5A AA 4A 88 B8 5C 78 B2 C0 06 26 31 F0 62 00 86 BF 5C C2 03 AC 42 07 20 61 83'\r\n 'FD 7D 1C 9E 61 DC 54 1A BB 85 50 E4 0C 30 F8 7C 9D 9A 41 45 07 C6 BD 81 AC 42 14 11 86 10 DE 87'\r\n '7C E4 F8 E8 08 A3 D8 8D 3B 3B 8A A3 50 4B 9A E1 A6 9A 4D 36 6C CC D9 9E DA 2F 12 E6 9D 6E BE AB'\r\n '59 AE 46 7A 9B 15 1E 8A D5 52 2B 55 49 47 11 C0 86 56 B9 96 FD E5 CC 28 B0 30 C3 2E 1C BE 16 44'\r\n 'F3 A6 1D 42 C4 24 19 80 62 43 BF EB 44 41 44 EA E4 10 0A 2C 56 B6 F0 ED 70 36 FD 96 F0 CD 2C 67'\r\n '55 02 60 5E 8A 3A 3B B7 6E 9B B1 CB 21 2F 64 17 05 20 CA 83 3E 96 EE CB 93 D6 82 AE F2 35 0E 5E'\r\n '79 A0 98 DF F0 34 88 28 A6 D0 01 7B 44 96 07 F1 B0 82 01 C8 6C FB 5D 91 05 14 D6 A1 1D E4 A1 C0'\r\n '30 C1 FB F7 F6 5C 9E 83 2F 48 3D C4 B1 84 18 23 12 18 F5 B1 9E 0B 0E 54 06 60 F5 23 08 2D ED C4'\r\n '8C 28 82 30 C3 D4 77 72 63 F9 F3 0B 7B 20 B0 23 12 1E A7 CD E9 EE B9 36 40 F3 08 82 AE E2 47 F1'\r\n 'DA 26 10 6F 7A 1A C4 13 08 09 A0 51 5C 44 4A 00 61 EF 97 1E 2F 99 E8 C1 71 26 55 88 00 42 C0 06'\r\n '60 7E 1F 92 E6 F9 6D 66 B8 86 5E AF 59 CF DB 7D A3 8F 27 47 E9 F9 1D B3 6E 26 90 41 62 C4 73 EE'\r\n '44 2C 11 86 0F F6 D1 DF 41 44 0A 28 42 43 06 2B 0A EA E4 61 83 F4 FC 4B 15 D8 20 B1 71 D4 55 F3'\r\n '85 82 23 26 11 EE F3 37 28 69 A8 7A C8 49 DC 88 A0 C8 A2 53 06 26 39 FE 7B 76 ED A6 18 BA 29 E3'\r\n '29 54 AA A5 52 94 4B 6D DB B6 DB 64 4C 0E C6 FF 83 DC 38 69 9F 4F 5F A0 14 4A 22 EB 04 40 C3 08'\r\n '96 91 03 7A 74 3E F7 2C 94 4B 18 27 5C 02 30 C3 D6 FC 66 30 30 D3 35 C6 14 4A 1D 1C 88 C4 B3 EE'\r\n '78 97 0E D3 30 0E D9 A0 B1 18 97 07 6A DB 0D 98 13 1E B7 65 1B 24 4B 9B 3C CF 3F A9 A1 A6 27 40'\r\n '66 7A EB D1 56 C6 D0 4C 1F 6B F4 FB 6A E1 E8 57 25 24 09 56 BA 0B 83 0C 79 76 BB FB 06 02 C0 C4'\r\n 'ED 60 96 23 29 1E 35 B6 C3 00 D8 51 45 63 B3 65 84 B6 C2 26 0F 61 E7 7B 6D 87 0C 43 65 A8 CB 4D'\r\n '0A D2 09 23 B7 67 CC CE C4 F4 15 37 33 B2 BB 85 50 61 8D FA 1F 87 B9 5E 62 67 72 90 E7 92 C9 D9'\r\n 'CC C2 B9 18 63 E5 76 73 87 28 A0 A1 8B C2 05 70 6E 0C 29 EF F9 EF 72 BC E6 7C EE 70 40 BA 0E 85'\r\n '25 16 7B CE A7 8B D2 69 C3 2C A8 A2 AB 60 B5 B0 89 77 D2 78 AD 9B 26 13 30 51 31 CC 73 04 B3 CC'\r\n 'F3 BC EC E6 01 9F 84 A3 2D 83 B0 12 CE CF 2B 9C DF 80 6C 12 69 50 66 82 A0 18 91 D7 DA C5 8A D3'\r\n '03 B3 7D B8 F3 59 C6 01 E0 18 F0 8F 2F C1 65 91 65 62 88 85 16 C6 02 19 85 37 E5 3B 93 0A 65 75'\r\n '15 B0 39 10 30 A7 E0 50 94 45 10 35 0E 80 96 7B 0F A9 F4 3B 26 13 56 63 9C 8E 69 67 7F 92 E8 E7'\r\n '39 31 36 0C CB 61 E2 B4 0B 17 74 EC 36 4B 5C 50 72 CB 29 2C 5D E8 67 94 B5 C5 D8 CA CF 3C CB 2B'\r\n '12 EE 67 D0 67 2D 75 CC C4 A2 D9 E7 78 58 BB F5 59 E7 2F 0B E4 65 95 80 06 25 DD 9E 2B B9 CE 5F'\r\n '53 11 CA 8B 6C D9 72 C5 DD 9E 2F 39 6B CC D2 B3 33 CC 0B 17 7D 8F 99 D7 64 C0 D8 22 76 B5 82 89'\r\n '1E FF 67 DE D8 BD B9 8B 83 06 0C 52 E0 0B A0 53 C5 AD 62 F9 73 2B 42 15 6E 45 79 05 29 1D F1 7B'\r\n '97 DB 4C 15 88 02 B5 8A C2 47 6E 65 AC 56 98 2B 0B 58 58 48 F8 7E 27 B5 62 B4 C1 58 88 5A C4 2C'\r\n '24 7E 3F D8 A9 55 88 56 B5 05 51 23 7E 6D 4B 63 10 D9 61 6B 15 83 1F EB 3B 7E B5 C9 80 B5 AD 6B'\r\n '06 3F 95 C9 FB CB 00 C1 8C A7 6B 59 48 30 63 F5 9E A0 4A 41 33 6A B3 CF 38 5C C1 D7 9F 98 5E EC'\r\n 'BE 41 26 59 4C 14 C1 DF E5 77 6C 0C 30 42 A2 B5 22 90 91 DB CA 7A 80 C4 2B 5A 95 44 8E BD 0E CD'\r\n '40 62 AD 6A 05 44 8E BD 8E 1A 81 81 99 9E 66 65 DC FD 36 41 C7 86 0C CC CF 38 5C BB DF 64 16 B2'\r\n 'A1 89 8E 24 B9 77 BE F6 99 05 EE AE 46 59 40 B9 77 D1 65 90 5E E9 96 59 5C BB DA FF DF C3 30 C3'\r\n '07 D3 36 00 01 6B 02 61 D9 3F B4 A8 14 53 1A 56 B5 26 0C 71 E5 E5 60 C2 A2 B5 22 A8 91 D7 D5 48'\r\n '0E 09 24 91 12 03 8A 5C CF 24 98 1C 19 10 67 94 A0 24 12 0F BD A2 43 A6 CC CE D4 E0 FD 7F 67 DF'\r\n 'C2 F3 B8 7B 4B DF E3 0F B6 B4 EC 59 7E 8D 84 3F 4A 9A 79 FE EF BB 0B 85 77 CA AD F3 3E 96 B0 D5'\r\n 'FF 4A 9E AD 4F 0A 82 9A 77 99 C2 F8 FD 3D FF AE D7 2F F8 EF BA 53 D4 BE EC F7 B7 ED B7 9B AD E5'\r\n '74 39 7D 68 98 43 F7 C8 D1 EC DC 72 17 60 72 50 E3 D7 4C 4D 71 90 BD 1D 55 CF 3F 12 D7 26 B2 ED'\r\n '17 79 DC 66 29 6D AE 11 D0 57 58 4E D9 D5 51 D2 5C F6 1E 28 B1 EF 25 A7 A7 BC 5E C3 1D A6 46 2B'\r\n '4C AD 6D 6C B7 AF 72 86 19 A2 87 B8 8F 6D 6B 80 AF 05 03 B3 75 1C 88 6B ED 91 4E 5E 26 CF DC 7D'\r\n '87 D8 7D 97 D9 7D 5F A3 DE 92 01 46 50 A6 FE F3 76 8F F7 B9 93 EB 17 11 14 A8 10 99 05 01 4A 10'\r\n '04 A5 4A 06 08 A4 94 48 0C 68 7C EF 57 0C 49 09 22 48 A4 63 4C 6C A6 82 33 46 18 4A 42 10 81 11'\r\n '10 FF 63 8D 04 C6 20 C3 02 12 69 13 61 4D 84 09 19 A2 82 9A 44 48 36 18 30 B3 4C C1 8C A4 4C A0'\r\n 'CC 9B 18 10 14 89 31 85 11 52 4C 94 99 0A 26 C2 50 6F A8 EE A2 09 24 D8 C8 80 45 18 98 5F 76 E2'\r\n '69 8C 4B 26 63 19 24 49 26 8A 63 03 28 8C 90 23 32 68 A6 5B E2 7B 72 4A 24 84 85 24 31 84 43 49'\r\n '81 9A 46 44 10 10 29 88 93 10 A2 01 30 B1 12 66 12 99 BE F7 5E 89 92 D1 6D 8A CB B6 EF 60 00 03'\r\n '6D 80 00 C6 C6 D8 03 6D 80 00 0D B6 00 03 1B 60 00 31 B6 00 00 36 C6 D8 31 B1 80 0C 6D 80 00 0D'\r\n 'B6 00 00 36 D8 00 0C 6D 80 00 C6 D8 36 00 DB 60 00 03 6D 83 60 0D B6 0D 80 36 C6 D8 31 B6 00 00'\r\n '36 D8 00 00 DB 60 00 03 6D 80 00 0D B6 00 00 36 D8 00 00 DB 60 00 03 6C 6D 80 36 D8 00 00 DB 60'\r\n '00 03 6D 80 00 0D B6 00 00 36 D8 00 0C 6D 80 00 0D B6 00 03 1B 63 60 03 6D 80 00 0D B6 00 00 36'\r\n 'D8 00 00 DB 60 00 03 6D 80 00 0D B6 00 00 36 D8 00 0C 6D 80 00 0D B6 00 00 36 9B 00 00 18 C0 00'\r\n '01 8C 00 00 18 C0 00 01 A1 80 00 02 00 00 00 40 00 00 08 00 00 01 00 00 77 77 78 DE 26 4C 99 32'\r\n '64 C9 65 32 64 C9 93 26 4C 99 32 64 C9 93 26 4C 99 32 64 CC C5 49 45 15 25 15 25 14 51 45 15 25'\r\n '49 45 14 51 52 51 45 17 C0 DA F4 B7 A5 B5 22 A0 8B 11 19 5A F3 F7 8A D5 1A 88 DB 16 8A C6 DA 65'\r\n 'A0 D6 A3 58 DA 2D 62 B1 B4 CD 6A C9 B5 63 59 2D A2 B1 B6 4D 63 6D 16 B4 6D 56 8B 6A 8D B5 8D 56'\r\n '8D B6 CA 0D 7A AD FD AC BF 9B E7 57 49 8C AA 90 66 30 42 01 84 18 10 41 92 42 D7 16 44 D6 ED 6D'\r\n 'B6 F2 D3 5A 2A 8D 6B 1B 6B 15 5A D9 08 03 24 09 0C 7F F6 B5 81 16 1F 97 FD 9B DA 42 EC 14 90 05'\r\n '0A D5 FD 76 B7 7A 7E DB 6A BC FF 42 ED 63 58 D6 2D 8B 66 B3 56 D9 9A CC D6 35 8D 63 55 5E 4D B5'\r\n '3C 35 D5 AB 96 D8 D6 D8 B5 53 35 E1 A3 46 8D 04 20 08 90 00 84 30 89 04 00 04 84 0B 0F D2 A6 6D'\r\n '76 6D DC 1B 9F AB EC E2 FE BC 3F AD A4 3F 3F CF F2 7C C7 B0 36 F0 3C F8 1E 7F 9D BA F3 FC FC E5'\r\n '9C 6E C7 B0 AF D8 75 5D 87 61 B0 99 D8 7B BD 8F 5F B2 EC 7B 1C 9C 3C 3C E5 5E 26 77 73 B9 F3 BA'\r\n 'FA BB 2B 32 00 7B 62 00 04 00 C1 1F 86 81 27 E5 30 F5 8C 24 3D 52 07 A9 43 F1 99 21 3F 21 92 4F'\r\n '9E 45 80 77 E8 04 9F EF 60 42 78 28 01 9A 49 81 FF 0A F8 EF DB 30 D1 0F 58 FA DF 5B 50 33 F5 3D'\r\n 'F0 CF 52 FE 1A DF F3 7E E1 BE A3 F7 3D EA 5E A1 F1 0D 5E A1 FE B7 EE D7 A8 5F F1 7F 41 AF F2 AF'\r\n '52 FF 42 4F DE 7F 6D 21 CF FD 77 F6 ED DF BF B4 93 C3 A1 20 7F 7D 24 3F 47 F0 BD 6A 53 66 95 8B'\r\n 'E2 ED BA 43 27 5D 75 CE 89 DD 6E 26 64 D1 2A 6C 9B A7 03 77 57 72 AE 94 DD DD A6 BB B9 34 4D 33'\r\n '60 4B 13 9B 98 13 28 60 4B BA BA 92 62 46 51 96 48 05 25 4B 1A 62 1C E8 46 98 08 91 9A 1B BB 82'\r\n '32 03 28 90 9D DC C8 B9 D4 8E 5D 10 92 26 89 74 3A 92 89 00 86 07 77 0D 09 26 3B AE 92 64 05 73'\r\n '8B BB 76 17 13 C7 E1 DB 55 AF 41 AA D5 2F F1 76 BE AF C7 58 C6 C5 90 AA C1 51 6F 78 F9 2E D5 BC'\r\n '2C 91 46 8A 28 D1 45 14 6D AD FA 41 CF 87 2B D8 FA 03 A2 EF B8 40 50 D4 39 53 82 2C 88 3E A0 94'\r\n '81 E2 32 F5 3C 54 39 B3 94 0B E9 87 2B E6 7E F0 AA 88 85 50 C3 36 FC 8F 72 F0 B7 E1 CD 86 36 12'\r\n '64 C2 AC F6 B7 A0 49 9B 9D F6 2A 86 2E 57 00 1E 14 38 5B A0 D5 6D F2 3A 5D FE 38 E2 E9 43 3B F7'\r\n '72 81 BE E5 F3 B8 D9 80 DD DF 90 21 CA 0C 5F 23 DF A4 90 FC 61 EE 7D 1E E6 79 5F AC 7E 7B F2 EF'\r\n '72 0A 16 03 D6 1C A1 BD F9 4A 22 D3 07 5F 70 23 F7 97 70 00 00 1F 1B FC 2F 93 F2 F2 F3 5D D0 79'\r\n 'BF 81 E7 7B FF FF 7E 4B D5 5A 86 8C 18 28 69 BE 45 CC D4 7E C2 DE 08 B5 29 78 42 5E 7F F4 B9 DA'\r\n '76 29 ED 3C AE 17 27 32 C7 59 0B 64 C2 BD 98 14 A2 70 29 55 5E 32 A9 55 55 55 7A FE BB AC BD F8'\r\n 'A9 AC 8B 50 AB 8E 5D 7E 7D 7E 67 5F D7 BD 39 7C BE 5F 2B 91 CA E4 F2 C5 74 D3 4E 66 A7 8A 0A 63'\r\n '1A 69 BD AD 06 75 2E 60 D9 B5 54 49 37 BD 41 B7 9F F7 DF 37 E9 EA 6A DB 6A 25 49 73 74 B7 F3 79'\r\n '1A 91 20 74 BA 45 F4 F0 B5 F0 B0 A1 45 30 D6 AA 74 36 95 35 F4 B7 33 40 03 15 8F FB 7F E2 7D EF'\r\n '67 2F D5 BC F4 40 DB 00 80 5B 00 5A EC A8 DF A2 92 01 80 08 83 60 0C 0A 78 08 85 E0 82 21 7D 7B'\r\n '58 0C CF 45 8E 77 EB E7 99 1C F5 41 A6 27 0C 78 6F DF 86 9F CE F2 27 AE 2E 57 B6 FB 3F E9 B6 3A'\r\n 'E8 AA BC E3 A6 6E DD 86 15 A6 9E DB AC E5 4E A8 10 08 00 0C EE 9E E6 A0 92 11 FC 28 4C 0C 2C 72'\r\n '9A 21 0A 75 B8 EF D6 59 F8 F1 CE 74 90 43 8E 82 CE 9D 71 CC 63 7A EA F3 F7 F8 2D 29 6E FE 87 2D'\r\n 'FA 1D 0F 27 D3 E9 FA 7D 0E 8F 2A B5 9C FD 3F 47 D3 DE 55 A5 22 2D 68 8A 51 9A D6 88 89 4A B5 88'\r\n 'BD E2 22 B5 9C E7 36 66 6B DD D1 27 39 CD 9A 28 AB C9 FD A7 2B FB 3B 36 63 1B 36 67 9E BA EC AD'\r\n '67 3D 34 D9 B3 BC 94 AB 5C 62 F7 C6 29 46 6B 5B 18 C6 19 AD 6C 61 DF 18 A5 19 99 99 99 AD 67 73'\r\n '19 74 D3 4D 34 51 5D 45 0E 77 1B 46 18 F7 A5 BE 34 65 0E 73 D7 BB 45 D9 8C 60 9F 3F A6 51 94 5A'\r\n '08 20 78 91 23 1F 5A D1 83 98 D2 A7 2E D2 09 94 3F 36 2A 38 CD 54 08 07 32 9C D1 6B D8 AF 31 9B'\r\n 'F1 64 DA 00 20 B4 83 98 DD 05 0F C5 8A 2D 66 30 63 23 FE 15 B5 A1 DF AA 73 9E 57 1A E9 B0 3C 5B'\r\n '6E 73 83 BE 33 D0 F5 5D D0 30 18 D9 6A ED A2 23 5E EE 81 CE 73 C0 96 EC CE B5 67 39 CF C8 4C CE'\r\n 'AD 51 39 D8 EA 8D 0D C7 E8 52 FE B0 EF D4 86 63 1A 02 4D 6E CA 5F 74 EE D7 6F EE 28 66 DD 19 99'\r\n '35 B9 54 C6 C7 35 C2 36 D7 F3 0E 75 EE 8E 66 F6 B8 06 34 8B B6 64 02 62 8C 37 59 C1 74 22 22 22'\r\n '22 22 22 22 DB 6D B7 BE D8 E8 2A 93 6D D7 68 BD 68 97 E8 8C 72 D6 7C FA DD 84 E3 4C F5 5C D7 18'\r\n '49 5E F9 22 8B 76 AA A9 52 A5 55 4A 95 2A AA 54 A9 55 52 A5 4A AA 95 2A 46 BC 9C F9 DB 1C F7 27'\r\n '68 73 D7 35 36 1B 68 47 84 56 FE 23 8A 90 4E AE 33 43 C7 74 9E 31 9D E3 32 90 A4 13 14 C3 54 D2'\r\n '59 86 31 95 7C D9 82 03 A9 CE E4 20 46 FD 53 0D 9D 44 1A 77 88 54 A2 74 AA AB 99 91 04 2E 37 25'\r\n '0B 90 9C 85 E4 F3 23 9C C7 20 62 C2 32 32 CC 6C 54 63 38 C5 33 83 E2 D1 3C 07 16 27 2D 13 DD 37'\r\n 'A1 5E A5 53 DA 9D CC AA AC 88 04 75 05 DC 6A A7 B1 3B D5 2A A8 CD E1 6A 98 C6 C3 10 00 55 47 18'\r\n '65 2D CC 77 C7 63 05 37 A7 3B E5 AA D8 20 EF 04 EF 4E EE A4 33 29 50 5B 1C E6 A8 7B 37 8E A0 54'\r\n '39 CE 7A 89 81 00 30 E3 BA 42 F0 E7 39 E7 DC 24 6B E2 9C EA C2 39 1A 61 66 9A 11 91 38 AB 29 12'\r\n '10 26 55 29 E9 1D CA 09 55 3E 3B 45 30 4F 38 E9 2D 77 6A 64 CF 54 C4 BC 14 10 C4 8A 63 A4 E8 FC'\r\n '0C 74 F6 6F B1 5B 93 96 DC 79 F3 F4 39 B2 CE 14 9B 98 1B 81 86 E4 D8 AA DC AA AE 6E 4D D5 72 21'\r\n '8E 9C 35 AA B4 D5 56 0F 7F 52 6F B3 1B 77 93 52 61 37 52 4D DE ED 25 D8 26 90 D3 A0 D2 1A 71 4B'\r\n '83 34 86 9A 49 49 A7 60 E7 AE AD C3 9A 43 4B DB D2 69 7A 5F 17 2A 47 17 7A 71 7A 5D A9 A4 35 FD'\r\n 'F1 A4 38 B9 ED C9 CE 28 71 28 E2 07 10 49 64 9B FE 26 FB 2D EF BF AE 1C E5 7A 4A AA E4 B9 6E 8F'\r\n '37 2F 7B F2 FD 1D EF 7B AE 06 04 04 41 04 2C 27 21 55 10 46 0D 37 80 04 A9 2E 9A 67 19 74 1F AB'\r\n '32 FC C6 9B 45 A2 A0 0F E7 5F 95 2B 2B F4 48 40 6F 56 7D 34 0E 94 FA 79 C5 00 81 41 16 81 46 99'\r\n 'DE 9C 20 DC 3B 52 D6 91 91 B6 A6 ED BD BD 33 67 29 60 2E 00 AC 5B 9C 03 25 75 7C 96 10 C5 BB 0A'\r\n '89 C1 41 04 2A 5B 3B 73 77 51 CD 14 10 BA BC C1 5C 08 09 5D DC 1C E7 4A EA D6 A2 2D 1B A9 69 30'\r\n 'EA 76 78 F8 00 B5 3F 13 BB E3 89 1E 7D 3B ED EA 5B 9F F4 E4 25 5D 26 8B 9F BD EC 4B 71 B4 DB AF'\r\n 'FC 9C 53 4A CF C2 92 F3 DB 8D E0 E9 3E 5C E8 7D 7E 5B 71 24 DD 7E 2E C9 F5 5D 47 1E 8C 6B D6 DE'\r\n '94 F5 EB 65 1C A6 6B F5 5B 3A 6D EF A6 AB 6B 4A 79 61 3A 8B 97 6A 4D 1D 4A CF BB BA DB BD AA 79'\r\n '8C C7 99 C9 7A 68 A6 38 D0 BB 67 D0 39 79 B2 DB CC DD 79 C6 F3 71 EE D1 34 6E 46 AA 39 F7 6F 2A'\r\n '8C D6 F2 96 E2 5D 7F 2A 52 97 6F 87 8F C0 DB B7 70 F5 9A 52 E1 DE 91 8D 38 9C 29 2B A6 7B BC 7E'\r\n '27 2E 77 0D C2 B2 39 55 B8 56 CD 9E D9 F0 D6 73 9D 38 63 29 F0 57 86 5C A6 6E 17 6E 7A 72 38 67'\r\n 'CE 94 B8 73 E8 9F 87 C3 A7 59 99 B8 37 A6 97 BF 0E 12 9C 3C 4E 6F 5E F6 94 F8 57 1E ED 1D 78 4C'\r\n '57 84 CA FA 4E 3B 19 3A 7D 25 1D CA 77 99 C2 48 4A 61 00 48 21 01 59 01 48 C2 49 3D AB DC 1D 6D'\r\n '43 48 61 BE 91 56 25 2B 4D 22 8D A5 AC 4C BC 2E 07 77 47 2E 5C E3 B9 DC 72 2E 5C E7 2B 9D D7 01'\r\n '77 6E 44 BB AE 2B 9D 2E 9B 91 22 D5 B0 68 8A 00 92 7C 1F D5 FE 1E CB C6 FE B7 F5 BE DF 4F 53 EA'\r\n 'B7 6D F5 1B FE 7B CB 7C 8F 87 F1 7F 0F C0 E7 FC EF DD F8 B4 74 54 B9 0E E9 7A 53 30 9C 61 FA 7C'\r\n '17 9B 4E 25 1C 84 78 11 BB 8F AB 3B CF 61 A5 86 E5 CC 91 F7 3E 9F BD 68 83 C0 F0 3C 0C E4 BE C5'\r\n '17 B1 EC 20 E3 17 D2 FA 91 47 E5 F9 55 57 E6 FF F3 46 9F 4F BD F9 7E 1B 2F C1 D3 AD 67 BD BC 39'\r\n 'F7 1F F7 8C 00 4E 00 90 80 42 00 3C A8 50 0D 10 67 46 25 76 ED 73 4C 19 F9 C0 6E 90 93 2E 9D E0'\r\n '48 A0 A1 18 52 07 B9 EC BE 17 C1 AF F4 FD F7 F7 BB DF 91 E7 BB CF C8 ED BC E7 93 EB FC 57 9D FA'\r\n '35 DB F7 3F DE 86 D7 3B C9 95 98 90 84 ED 7F 69 19 C5 00 FE 6F 68 E8 59 07 F3 15 D7 5D D2 19 56'\r\n 'EA 5F 3D 69 95 F6 FD B9 19 59 59 E8 76 F1 04 18 64 91 BA C5 E7 76 67 F3 79 2F 6F 60 87 89 7D 19'\r\n 'E2 AA 1D B0 78 9F 14 51 28 A8 50 88 52 46 A5 D7 76 EB 93 C3 0F 1B C2 5E 1C 4C 97 75 C5 DD BB 70'\r\n '84 21 21 05 84 08 41 61 0D 09 D8 62 56 76 18 93 05 BA 4A E8 3A E9 29 A8 D7 78 59 96 BC CE 9B 4A'\r\n '98 86 95 BD 27 5F F5 BE FF 3B F5 B9 CD 1F DB E7 F9 BE C9 FA FC F7 6E EB 3B 97 49 AF E3 35 C4 D6'\r\n 'C1 53 D0 4B C2 E5 CB 97 3C F8 F0 7E DB 13 1A BD 09 AC 49 2A 49 25 4A 95 2A 63 0C 74 AC 66 17 93'\r\n 'C1 64 97 F8 26 C9 69 7D 6A D2 FE 67 1D 08 92 55 0B 71 29 59 90 53 08 6B F9 FF E7 7F B7 CE BD BD'\r\n 'CF 8B 3F B4 C8 7B 8D 8F A8 0F E9 D2 47 AD 31 6A 54 48 2A D2 4D 43 9E DC 52 63 88 A2 52 43 DE 09'\r\n '9A EC D9 76 68 D7 2D 75 D7 48 D3 4D 34 DE D7 5D 9B 1B 5D 7B 9B 3E 45 28 1B 29 8D 5B EE 19 36 6C'\r\n 'A5 64 15 76 22 3A 2E 12 4F 39 EB 4A 66 8B 42 91 8D C0 C8 26 B3 75 C3 CE FA 30 D3 4D 34 A6 79 A6'\r\n 'CC B5 CF 3C 96 70 92 37 7A 50 4C 28 A0 95 2A 8A AE EA 58 D2 94 A6 8E F1 17 88 80 BA 8D 83 38 88'\r\n '55 55 CF 3C F7 F1 89 40 9A 4E 73 9F 1B 77 D4 1B 64 BA 38 D6 8A DA F4 9B 78 D8 48 52 46 3A B5 AD'\r\n '29 4A D0 E4 36 6E 51 B4 38 49 0E 38 60 9C 54 D3 1B B7 71 37 F7 F2 D7 5D 31 C4 E3 7A B7 D5 E9 C4'\r\n '47 0A 28 36 6D 07 C1 3B 0C B8 12 93 38 DD 6B 8C E8 27 90 8B 65 C5 17 15 C5 29 C1 9E 9C 69 C4 E7'\r\n '39 E6 F5 C5 E3 5B 57 2C 6F 5E E3 7C E4 37 D0 30 C9 2A 63 7C E4 0E 71 9C 84 A5 14 93 B3 48 3A 87'\r\n '77 69 D7 6E F2 EF EF CF 63 A6 DD ED B2 91 EF 6F 26 F6 DD BB 76 ED DB BD BE EF 7B 68 A1 2F 7B DE'\r\n '8D 8A 23 BD AD 69 D6 8C CD 6A D6 94 A9 9E F3 58 6E 57 55 DD BB 18 DF CB 3D D1 A6 31 96 31 8D DB'\r\n 'B7 A7 BB 6E ED CA FB B7 65 B9 B6 9E 30 D8 C6 22 51 53 D1 14 D3 76 EC F7 5D 06 ED D5 B5 DA FB B7'\r\n '6D DB 96 DC F3 CB 2C 62 22 36 ED DB B0 B6 6D DD B9 77 46 E5 DC 7B 62 34 C6 13 11 5D 20 D0 31 2A'\r\n '22 21 21 85 45 0A 8A BB B7 6E DD BB 89 C6 1F CD 8B 3A 87 31 06 29 C1 F5 3D 5F FC 7D F7 B9 45 55'\r\n 'FB FC 5E 6B 81 91 0F AA CA BC EA 0F 3C C2 56 8A 21 2E 99 53 2C 97 51 05 75 93 63 2C B2 95 0C AB'\r\n 'A7 D9 4F 65 3B C3 21 F8 32 27 F2 28 32 05 FD 9F 90 C0 20 01 87 C5 33 18 87 35 89 F3 0E BA E9 EF'\r\n 'C3 38 6A AF E4 CB AE 59 12 60 EA 9F 75 61 F4 2A 99 1F BB 67 A2 4D 39 AB 19 2F DE B2 F1 38 3F 75'\r\n '73 9E 74 E7 F5 65 9D 3E 52 A4 FA 32 FF 6D 8A E5 EA B6 2A A1 97 97 9A B5 3E 25 F3 F0 21 24 2F BC'\r\n '97 93 C4 5F 6B AE 98 61 27 21 3F CA 70 B0 E7 3A EC 33 48 72 DB DE B7 19 26 28 EB 70 92 61 A3 B7'\r\n 'FC 7D 69 26 39 B2 79 DD F5 49 B7 9A 75 77 CD 27 23 5A 9F D5 AD A9 26 5E DE 73 41 A3 24 FF 1D 1C'\r\n 'CC 95 9B FF 26 AD 49 AB 3A 0F E9 D1 52 64 BC 9B A9 26 7C 3A 1F EB C3 2C 9D 9E F2 66 C2 4C D2 BD'\r\n '1E 5C B2 54 9C 7C D9 A4 75 92 3A 66 4A 9B CC 98 49 92 F8 76 DC 71 93 19 25 49 32 E1 D7 F1 F1 92'\r\n '54 E1 CB C9 2A 6F 39 CC F2 4C D3 7B A3 34 98 9D 06 01 70 CB 71 D7 41 86 04 0A 4E 4D CC 60 D3 01'\r\n 'DF 72 AE 73 75 26 40 CF 8C E2 60 11 3C 81 75 79 C6 8B 26 32 2E 64 BB C9 C5 C8 F6 32 98 3D E7 17'\r\n '17 9A D9 0C 5E 65 93 8D 82 C4 EB 72 14 A6 48 61 DC 0C C7 3B 94 2E 7B 5E C9 D2 98 1E DF 54 35 0E'\r\n '43 2E B7 C1 D5 08 71 E8 22 E3 D0 35 E0 20 3E CC 40 87 63 A0 93 84 D3 C8 74 D4 07 11 36 A7 60 C7'\r\n '90 BF 2D 25 E5 F6 B9 EA 92 76 19 B5 39 88 B6 BF 8B AB 66 AA CF CA 59 D1 58 BC 33 94 95 44 F6 7A'\r\n '13 39 1A 77 07 38 C8 02 2F 68 FD 81 ED 21 7B 1E 98 00 5D 7A 6F EC 5E 2B 96 4B 14 7F 45 B9 46 9E'\r\n '4E 79 77 77 8E 78 DB 9B 17 8F FB 79 D7 8D E4 D8 A0 F2 6E 51 63 C3 72 A7 6E DB 9E 1A E5 8A 77 70'\r\n 'B7 8A 8D 77 9A C4 A8 D6 BC 2C 77 2B 3A E3 BB B6 AD DD 77 74 12 82 AA DD AF 85 57 2D 4B 46 8E 86'\r\n '98 60 2D D4 51 80 B4 40 B4 EE B5 DD D6 BA 2B 16 AE 9A E6 AF E7 B6 D5 78 94 40 8B 12 CC 29 57 3F'\r\n '51 69 02 16 8E 79 58 2C 88 32 2B FF C5 4A 45 22 8A 0B 24 C9 73 A9 2C 91 66 28 15 6B 6C B0 43 80'\r\n '10 80 20 20 00 02 00 24 12 00 7E 7C 1E 0F 07 6D E1 E2 6D B8 35 F7 BF B3 B2 FF 5A 30 FE 3C C1 C8'\r\n 'C4 C3 EF BB DE F7 63 5B 63 E6 FB 7D 40 F3 BE F7 F8 3E 8A FE 6A BF C9 C8 74 E4 27 51 EA 1D A7 CF'\r\n '58 8C 5E D2 A8 55 91 3B 3C 3B 6B CB DE F6 09 66 2C 18 4E CF B3 EC FA 9D 67 99 E4 F3 7D 0F 33 D6'\r\n 'F5 BD 6E 30 DD BD 7C B5 10 A8 1C DE 69 48 43 00 08 89 28 D9 99 D8 90 E4 76 E9 33 01 11 40 44 80'\r\n '02 24 B2 B2 E7 B0 B9 EF 5B 81 32 6C A9 57 B5 DB 6F 00 C7 E2 75 47 94 ED 32 F0 C5 BE 1F 34 F9 6C'\r\n '9C F7 A2 F5 42 2F 5A 85 FA B2 95 84 5E 92 52 B0 05 21 D2 C6 A0 19 30 02 F1 23 21 D5 7F 6F A3 C5'\r\n 'E5 BA 39 77 BE 63 A3 CA 58 F6 5F 6E 7D FD CD F9 8B 12 10 56 11 47 83 C4 A3 CC BC A0 50 E5 B5 16'\r\n '24 30 12 04 A5 18 41 82 A9 F4 DE 13 A7 FE 0F 21 DE 79 1F 23 CC E9 F6 25 7B 2F E7 4E A7 4A CD B8'\r\n '71 27 1F 25 A5 A2 B2 0F 2D A8 B4 89 CC 6A 21 3B 7E 3E 2F EC 77 7E A3 2F 92 7F B7 E8 3D F7 C3 DB'\r\n '31 87 69 5C 6F 09 C5 81 65 11 70 7B D6 AD C8 96 3C 73 75 70 6C D9 8D 0D 20 AC CB 9D D2 BA 9D 0E'\r\n 'CC B9 1C 2B C7 8B C4 94 91 ED DD 76 4B C2 E9 A3 BB B6 10 AB 96 F2 FE 9F B9 79 BC 79 26 DA C5 D9'\r\n '67 2F 8B C1 BB BC 6A 44 26 D4 7C 17 92 2C 20 9E 18 5D C8 EE 38 A9 25 4C 4D 51 57 BC 40 62 A2 92'\r\n '20 6B 52 F2 13 1A 54 ED 44 44 E7 3A 42 60 29 50 13 95 04 10 03 24 22 00 CB 89 A7 63 A5 85 79 F4'\r\n '76 5C 2F 0F DE FF EE 47 A5 F2 76 FD BF 6F B3 F4 FD 7D B9 02 44 9D A2 03 C3 D7 77 04 44 E8 88 18'\r\n '12 00 F8 FB AE 9A F7 A2 C3 CA E4 BD BB 6E E2 DD 94 92 00 05 01 9E 12 CA 01 3A D2 81 40 0F 9F 4B'\r\n 'B1 41 C9 58 4F 07 DA 77 3E 2F FC 6C F5 7E 07 2F 1D FF F4 44 FD 6F A2 FD 9D D8 44 49 07 D5 DE 92'\r\n 'F4 9E 5B 7A CD A6 D7 90 DE B5 83 40 01 51 99 77 6B 97 8F 46 C1 01 19 E7 7E 3B C7 89 00 45 28 2A'\r\n '10 85 C9 55 85 A3 54 D6 36 95 39 B5 52 F0 01 82 00 97 B6 17 BD 99 42 5E D5 04 61 64 95 06 0B 04'\r\n '61 54 0D 4A 04 00 08 76 06 90 9B 4D 36 EC DB B3 49 B2 15 2A 20 2C AD D7 75 E5 37 89 9E 3B 13 A5'\r\n 'DB BA E4 A8 31 57 86 A1 82 08 5E F6 B5 D2 D6 A8 59 A4 92 92 01 43 22 21 65 55 73 68 D4 51 B7 83'\r\n '2B 62 2C 49 98 11 10 17 5F 9D D8 19 04 6F 15 5B DB 98 CE FF E3 6D FD 33 3E D0 21 1A BD 16 AE 3E'\r\n '76 F6 FD 83 0E DC FC BD B5 1A 3F ED 6F EF 40 81 9C E7 21 45 87 0F DE 89 12 24 48 91 3E FC BF BF'\r\n '7B F8 70 F8 B6 3C 5F 57 F0 F5 A5 FE 1D E6 1C E9 92 A4 C6 8D 12 1C 38 50 A1 42 84 BA EB AE BA EB'\r\n 'AE BA EB AE BA E7 C4 67 A1 69 8A D7 42 D9 7F D1 BF CC E3 AF 63 5A E4 8D 35 AA E6 38 FB 5E 6E 9E'\r\n 'E6 3E 4C 1F 32 CB 2F 53 37 2C 75 43 C4 1F 6C 53 E3 97 A9 1D E8 F7 43 B4 1D 90 F5 A3 E1 0E 48 F6'\r\n 'B6 9D 0C AD 9E 9E 8E 66 9F 81 ED 6B 7B BE DB 77 C2 F2 FC AE 6F B4 FA 39 DA 54 6B 56 BE AD 5A 9D'\r\n '6A 79 EA D5 AB 56 AD 5A B6 2E 25 6A D8 B3 6B 5C 5F D6 C4 AB 87 85 82 A5 6A D5 9E D6 AD 5A EA B5'\r\n '6A D5 AE AB 56 AD 5A B5 4A D4 00 84 E8 3E 10 E9 54 3C 53 D7 B2 EC 0F 12 20 62 D9 71 A0 EC 7A 75'\r\n '83 16 43 14 84 86 48 59 14 96 45 93 E0 24 08 59 2F D3 AB 16 65 98 58 1E 9D 40 C5 87 D5 A4 BA 13'\r\n '16 06 2C B0 90 C1 93 E5 7E A5 06 AC C9 90 94 CA 40 30 64 86 2C 81 F5 48 18 21 0B 6E A9 2B 5A 80'\r\n '76 98 67 8E 1D 4F E8 F8 DE 53 F3 3E DF FC C4 EE 39 FC FE DB 9D F6 7D B7 E3 7D FF AF F9 BA C3 9E'\r\n '7C 74 90 3A 28 41 E8 54 9B D9 64 0E AD 80 55 DE DE 33 F8 BC 4A 9A 5F A3 85 73 77 DC BB FC BC 3C'\r\n '5A 64 98 BE 3F 8F E3 E1 60 7E 8A 0F FB C2 F2 BB BF F4 89 17 1F 6B 87 E6 D6 F2 69 EE 70 9F 6D 22'\r\n 'D2 EC D6 2A 55 9D 6B 89 F7 F2 B9 71 71 BA 73 7D 3E 65 97 37 3A DB 9D CE 9D 23 E6 49 63 4B 90 42'\r\n '7E 22 19 FC 6C 9C BC 4A BA 5A 2A 6A 3A 3A 3A 3A 3A 3A 3A 3A 3E 36 F3 79 DD 78 BE DF 67 DF 73 BB'\r\n '0F 7F 5B AA D5 A0 04 D7 89 00 19 88 00 67 30 8A 6D 9E C3 61 B0 57 60 AC C9 DD 0F 49 B3 DA ED 76'\r\n 'BE 3F BB BE F5 3A BC 69 EE 8F AB D0 E7 CD F3 39 9C 9E 3F 32 8B ED 9A B9 4B 49 C1 DF F0 BF 97 B5'\r\n 'EC FA 95 9D BE EF A1 E8 F6 F1 3B 72 B5 B1 1D 2F B5 B5 90 BA E3 69 79 D0 32 EE AE A8 3A 96 97 56'\r\n '76 5F 12 24 51 2E B9 5D 09 B8 92 0A BE C4 C4 E2 E2 62 46 64 C3 9D 71 71 71 71 75 7D 6C 8D 0D BA'\r\n '24 68 B5 35 13 56 A6 EF 54 53 A5 A7 4F 1B 19 3E 30 83 E4 2C C9 39 E2 F7 6E FB 2E 89 28 28 A4 14'\r\n '7E BC 75 8D C9 6B 99 9D 81 7C 9F 1F 0D 3E 46 2D B0 98 A5 06 E2 F8 3B C5 EB 9E BD 1A 32 F7 EB 35'\r\n '04 D9 8A FA 3C 77 2A 94 E8 B9 86 F2 29 44 94 CD C6 BB 76 AD B6 1B 37 6E 2C 57 11 4B 1D B8 EE 20'\r\n '6D 0F 24 88 FB 5B 50 E1 91 26 5C 69 72 08 1C 71 E5 10 49 25 96 54 70 62 20 00 10 00 8E 80 00 36'\r\n 'FB C3 A1 DB 5B 43 E0 79 91 1E D9 44 B9 D9 B3 DA B6 6B F1 79 3F F1 BB F9 BC EC C9 D6 F5 FF D3 DF'\r\n 'F2 7C 9F 7E B0 C3 77 BE 61 AC BB 5B B9 CF 2F 26 6F E0 61 57 E7 A7 5F DA 1F 0F 9B BC 63 59 BB E6'\r\n '40 BF 9C FA BD B1 AE F5 FB FC 8F 77 E2 E6 73 BF AB 36 76 2D ED D6 D6 E6 F1 CF A7 F9 67 79 57 A1'\r\n 'A6 9A A1 FA 65 4A 92 D3 4F 4F 4A DE 4F 6B 4E 7A 2C 5E ED D2 B5 54 37 30 E2 44 52 A9 54 1B 1D 1A'\r\n '65 1D 55 0F 5E BD BD D0 50 A3 EF BE 4D 52 49 3B 2D 9B 36 55 68 4E 1B 7B 5C 54 F2 E5 4B 11 D3 97'\r\n '4A EF 33 2F 6F 65 CB 96 F1 E3 C9 72 C3 0F 47 11 C2 B9 52 B2 04 12 14 18 EB 56 94 F7 43 42 03 B2'\r\n '08 20 61 86 0C C3 21 1C 70 C2 8C E5 BB 99 79 BC 6F BF 85 F7 F1 B8 DF DF 89 C4 E2 F2 3F 0F C7 F2'\r\n 'FB B8 5B C2 06 E4 74 A3 D6 98 A4 11 02 10 40 48 24 EB 04 84 02 80 0F 2E 30 A8 8A 8A AD 5A D6 1F'\r\n '42 49 52 F6 FF 47 BB CF D5 7B 7F F1 7F CF F1 7D FF BD F7 BF 9B F9 BE E7 DC FB 8F 7F F3 BB 8E E3'\r\n 'C7 DD 6A F5 56 53 6C A7 59 59 77 3D C5 F4 FE 6B 51 3E 8D 0E CB B1 B6 C0 BF C0 A5 65 AE E8 BA 2B'\r\n '4F EB FD 7B CF F3 D6 6C F8 5F B7 DD D6 F3 DF E5 EF 7E 5D 66 BF 59 AB E6 6A FA 63 EC 09 EA EA 7A'\r\n 'B4 B2 1D FC 4A 69 83 7B 5B D7 7D 3E 49 3B DA A5 03 AF 61 DE F5 77 F0 10 20 43 61 F9 31 D1 7D FF'\r\n 'DF 61 3D 95 95 F8 51 FE 0F C3 F2 54 79 15 01 DA A3 B5 B5 F2 DE 1B C3 FD 5E 3F E7 6D E5 79 9B 8F'\r\n '2B CD B4 47 E7 57 F7 D3 D8 FD F4 8B BE CF B3 EB E2 F1 3E BF FE E4 7A 9E B6 E9 BD CE EF 77 D1 4D'\r\n '7C 9B 4A CB DE C8 A8 60 4F 61 24 E2 CE 7F 46 7B 83 C0 E3 D6 56 6B E7 DE 67 F7 FB FF 44 93 4D BF'\r\n '37 15 0B 04 58 53 5D 99 B9 B6 3D 9A AB 6B 4E D5 E5 27 4F A8 BA 67 83 4B B7 A1 FC 88 BB 3F 93 C0'\r\n '03 91 C9 DB 00 00 1C 14 00 80 0F 2A 8F CC DB CD 74 77 EB BE 4D FF 4E 6B 8B F3 EE 37 FB AD F7 EF'\r\n 'DD 6F BB 7D B5 8B 7B 9D CE D7 B5 7B 7B 6A 8F E4 46 E9 D3 BD 2A 79 DE B5 35 3C D0 20 E8 02 81 07'\r\n '23 7F DD F3 71 C9 AC E9 3F 97 65 D4 65 EF B3 39 AC F6 A7 23 1F 53 9F F0 6A F8 3E 0F 8F DD FE ED'\r\n 'BF 4F D4 E8 34 1B EE 07 A3 23 B9 B0 EE 09 60 20 16 3D C9 C4 E0 50 1D 08 49 12 68 C4 84 11 02 10'\r\n '25 7E EF A7 6A 7E F0 04 80 42 11 11 00 02 22 8D BE 4C 9C 7D 84 A9 5C E6 A7 61 F0 FA 5C 2F BF 89'\r\n 'C4 E2 33 8E D1 9E BE AB B5 C4 84 BE 3C 78 D1 A3 58 57 D8 50 3D A3 67 46 4E CE C1 11 63 C7 2C 61'\r\n '86 9C 9C E5 F2 E0 C1 82 1C 58 D8 89 6C 31 69 AA 7B 14 F4 FC 7E 3D 15 16 B3 36 4C D9 BB B1 AB AB'\r\n 'E7 F3 EA EA E7 67 79 6C 5D 3B 42 18 73 CE 9E 3B 78 F2 82 80 2A 1A EA EA EA E8 83 D2 52 52 76 A9'\r\n '69 52 DD 08 20 82 09 A5 A5 56 B9 75 CD CD 75 75 CD CD 85 87 64 10 01 02 B1 00 00 55 55 72 FC 1F'\r\n '37 6E 00 3D D4 00 83 DA 40 00 20 F8 5E 11 E0 DD AD 6B 4E AC B5 AD 6F 5A D3 7D 58 30 B0 16 01 62'\r\n 'D4 85 A3 56 7E B8 B2 35 42 C1 0C 90 21 F1 90 03 46 40 35 7D D3 21 89 FC 3F E5 A8 4D BF 8E EE 00'\r\n '71 C7 3D 78 12 36 DC 95 6B 62 D2 7E 6C 1A B2 D0 D5 AD A1 AB 59 25 BD 84 DE 90 DE 90 DE 90 9C EE'\r\n '75 1B F7 D6 AC 9C 79 D4 93 5D 3F F1 F2 BE 5B CB 7E 77 A5 CC DD CD D0 98 16 18 9B 41 62 CF 68 09'\r\n '1B 6E 4A B5 B6 B5 83 5C 56 4B 5B 7B AF B1 B3 81 BF C1 AD FB C5 DF BE 9B 52 AD AD 73 6B 11 52 01'\r\n 'B5 E7 6D F0 BE 52 E0 1A 68 51 A3 02 CB 6B 25 A1 48 5A D5 2A A8 90 AA B6 97 92 68 81 34 D9 F5 3F'\r\n '81 72 13 66 CA 0D 8C 0B 36 12 59 2D 6A 0A AA 90 94 D5 B6 5A 49 B1 03 97 8F 96 AC 01 B7 0A 4E 14'\r\n '2C DC C0 9F 33 CA 51 0D CE DA A2 28 14 D6 EA 2A AA 12 AA DB AE 43 63 11 92 1A 30 FC 4F 17 C9 DC'\r\n '7B EF 03 F3 BE 27 EC 74 7A 7F 71 F8 DF A1 E3 7F 63 EE BE 27 EE FE 6D CA 6F 43 78 6D D7 26 17 69'\r\n '32 2D 0F 3F D5 BD 58 F6 D5 35 B7 BB A3 AB ED 36 5D 39 BF D7 C7 A4 5D 67 77 B9 FE 6C A8 1F 70 D8'\r\n '73 ED 9B D2 75 57 3A EA 73 92 72 3D D6 78 3A F2 E7 87 1F A5 53 CD F9 9F 4F EF DC 55 EB 77 7A 2C'\r\n '60 77 98 B5 9B AF CA 55 55 DF EA AE 7F 6D D7 12 9F 38 7E F5 04 07 5D 01 C4 AB B5 61 59 3F 9D 66'\r\n 'C3 A8 B9 AA F6 74 D5 9D FE C2 9A D5 88 57 F6 AE C2 62 9D 09 97 E9 A1 5E E2 38 4C 85 8E 22 7C 97'\r\n '3A D8 D0 B2 26 5E E3 64 EB E5 6B E4 6C 9C D9 E3 E5 2E 9D BB 76 3C 35 83 E9 6C C0 15 42 E5 B0 57'\r\n 'B1 7D B5 A8 C7 5A 1A D1 D9 8E C9 A3 47 F0 47 66 07 CB C4 DB 01 F8 12 0B 16 13 CC 7A CA 2C 27 FF'\r\n 'DD 3A 9D DB FE 37 06 7E 6C 62 3A FE 9F B2 FB CE EF FD 1F 1B EF 7B DE E3 FD 5E E7 1A EA D6 B7 9B'\r\n 'E9 A9 4F F6 CF DE EF E9 BD FE B7 97 67 D0 66 BF E3 8D BA B1 AE DD 34 F7 A7 7E CD E6 7E 55 A7 5A'\r\n '6B E7 C2 BC A2 FB A1 C3 85 09 E3 C8 C5 97 F9 F1 BA CF FD F1 36 3B 1D 2E CF 8D B2 DF 7C E5 FC FE'\r\n '2E CF 89 9B 8C 82 5C 5F DA A1 F4 03 ED 09 B8 CA B3 57 D8 37 A8 C9 1F EA D3 A9 DD 2A 9A CE 19 25'\r\n 'B0 45 6F 97 96 47 C9 F9 0A F0 C9 10 CF 8A C8 C5 50 7B DE A7 7E 9A 8C D6 57 51 FF 3F 5A FB D1 E7'\r\n '5A 36 4D 4E 6D B1 7C 64 4B E1 40 2F 7D 81 F3 5F 1D F8 8C 83 E6 3F 9B 1D 5A 63 4E F2 4E 06 F3 FE'\r\n '5D 70 2E 6F F1 BC DA 76 32 EE E2 E6 36 76 66 AF FF 97 A1 9C 5F 6B B7 F3 BE 5F C7 F0 E2 25 B3 17'\r\n '76 D6 7B 53 F7 7E 69 FC 33 F8 5E D1 E4 1F BF B4 3D D9 ED E8 78 F6 D4 69 5B 6D EC 6E B6 5D 7C BB'\r\n 'DF 9A FB D0 F0 77 49 89 27 F8 93 E8 93 E3 12 49 24 EE BF 4F E6 F2 7C 4F 03 C0 F2 10 78 3D 7D B6'\r\n '8D ED D0 EC 45 79 B1 92 A2 EB 69 46 AD CE 4D B8 DB CC 4C FF DD EA 03 D1 7F 75 75 0A EA 1D CA 89'\r\n 'DC DC D9 5C DC B3 59 29 16 94 53 A3 45 C1 11 41 04 90 51 C0 DE F1 F9 1F 9B 60 5D 98 72 5C 8D 33'\r\n '28 B1 62 C5 8A AB 09 08 14 0A 2B 19 83 01 C0 C7 21 B4 D5 3F 51 AC C5 CF 28 70 2A C0 21 48 B5 D7'\r\n 'CC 9F 95 24 AB E0 1A F0 31 BD F3 36 11 66 0D 5B E3 2C 38 12 D3 AE 19 88 94 83 8E A9 85 70 1C EE'\r\n '3E 1A 0D 11 2A 62 51 96 29 90 43 DF F2 3C A3 4E EB 8D BD 67 A8 4C C5 CC F4 54 69 29 E1 24 7B 0E'\r\n '5E 55 45 29 65 9F 6E 91 B1 81 F6 ED 55 1F A2 E5 64 71 D1 84 8C F7 8D D3 78 94 F4 9C A0 8C 64 62'\r\n 'A2 ED 54 6D AD 94 7E 03 60 59 F1 ED AD AD A4 39 89 05 BE 3E 3C 57 FA 27 64 9B 63 1E 48 2A DF 22'\r\n '73 C6 F1 96 7A 63 1B 40 80 2C 28 08 9C 25 A3 34 D2 25 4F 4D BB E5 94 28 39 15 0C 0A D0 6E BB 13'\r\n 'A7 E8 10 6E 11 D3 6B 92 82 0E 19 C3 82 CE 6C B7 36 33 04 0B 01 54 15 CF 97 3F 6D 9F 41 81 66 34'\r\n '05 56 F0 50 6E 28 2D 46 89 8C 22 1A 28 6D 20 02 CB A3 1D DD 93 9B 38 4B AC 25 B7 A6 6A 63 E3 06'\r\n '9C 40 03 6E 1B 72 90 03 51 CD 16 A8 F4 CB A0 7C 9F 6E 73 73 97 39 73 97 39 73 97 31 A1 8D 0C 6B'\r\n 'BF AB 28 A3 EF CE 9A C3 BE 5A 4B 0B DF F8 6F 47 F5 3E 3F E8 F7 2F A5 E6 76 79 3F 77 E3 7F DF D6'\r\n '37 66 4E 26 24 2D 76 4B F8 CA 54 16 47 43 2A 77 2B 07 94 42 DC 0E 4E 03 4C 19 BC 1C 1E 6E 0E 0F'\r\n '3B 07 06 5C 57 2D F5 15 95 49 52 AB B2 AA A9 55 5A AE D2 AE DA AE E2 AE EA AA C5 5D E5 52 65 D8'\r\n '6C D6 8B 11 FC 5D 96 4C 58 BE 0A 64 98 ED 2E 5A 3E 7A E4 4B B6 E1 85 F6 F2 40 04 00 79 E8 A7 A7'\r\n '75 6D FA E7 A7 5D 27 EC 11 11 10 01 E9 C0 C0 61 0E 88 40 9D 10 A0 24 50 0A 50 29 24 DF F7 92 E5'\r\n 'DE CC FA 6F B4 73 34 6E FA 4E D6 36 E2 3E BE 44 89 12 3C 4A EF 8B F1 A1 D1 83 8B E8 4E A2 E8 FA'\r\n '9C 2A AD D7 4E AE B2 93 F8 7F 0D F5 0D 15 07 3F 9F F3 F3 F8 35 3D 8E AB 06 17 0C 18 5C B0 61 74'\r\n 'C2 A9 85 63 06 09 6F AF AC D2 BA CF 43 85 79 7F 7B 7B C8 BB B9 BD 47 75 34 6D CD CD CA 87 99 B1'\r\n '43 C6 3E F8 FD 8D 8D 8D 85 B9 AB 76 32 D2 50 50 24 48 91 22 44 49 12 24 48 91 22 34 68 D1 A3 46'\r\n '8D 1A 34 68 D1 A3 46 8F 2C 5C C1 54 0A A8 56 02 AB 15 88 BA 4B D7 0A B4 56 8C C5 68 2E BB 3C C6'\r\n '97 CF B2 2F DC CA 97 2F 28 BC B3 9B E5 E5 37 CC 73 9E 1B 60 E1 CA 0A 5B 03 96 0E 2B 09 73 0A 71'\r\n 'B0 D0 F3 5B 6D 36 96 7C 07 52 E0 C1 95 12 26 CC 5F 9F E7 FC 3F 1E 37 E3 C5 CD FC F8 DC 8E 47 23'\r\n '91 C5 E4 72 2A 85 61 02 5F 53 28 38 12 08 08 89 08 17 82 51 21 08 37 25 02 8F 75 4A 81 CF 96 0A'\r\n '4F A2 61 8B 82 77 85 51 53 D4 F5 9C 3E D7 CD FC 2F 09 D8 7B 0F B4 FD 4F 31 FD 7F 99 F5 9E 87 82'\r\n '9F 0F 5F 0F 0F 89 C4 6D C3 A7 61 4D 6F E9 7D 8A 7F 5F 21 C6 46 AF 1F 95 A3 A3 A0 ED BD EC F7 41'\r\n '4E 12 B6 34 6B 58 D2 51 36 A6 EF C7 85 4F D6 B1 79 A7 63 F2 41 77 55 54 16 C3 5E E7 42 7B EE 32'\r\n 'D1 15 95 96 AA 1D 54 5A B6 6B 6D 16 A3 5B 6A B6 4E AC 85 CC 12 08 AA 23 B6 70 1A 63 07 18 7C 9C'\r\n '93 B2 F6 83 0C 71 35 84 D6 D9 16 56 57 62 A6 A1 3F 67 BD 57 90 8E F3 2F 03 2B 12 DD 36 12 5C 74'\r\n 'AF F6 B6 8C 25 56 99 3B 44 BF 26 01 30 49 84 4C 32 62 12 39 24 13 14 98 C4 C7 DA 8E FE 3C 08 F1'\r\n 'E3 C7 8F 1E 3C 72 A2 0E 54 99 7A 6B 5B AF 85 09 CB 96 AD 1A 1E 34 18 70 85 D9 7E FB 64 F3 4D 2C'\r\n 'B9 83 4B 97 04 A8 D2 A3 94 61 C6 9D 1A 34 A9 52 A5 16 51 86 9E 79 E7 9F E3 00 8A BD 6D 2C CD B8'\r\n '14 5D 57 29 D5 11 C6 11 48 52 24 6D AA 6E A5 36 9D 55 5A D6 E7 37 A5 AD 67 E5 44 27 B6 AC B9 D1'\r\n '0F 9E EA AF 2C B9 F4 08 B7 CD FB 1E 6F E0 5F A8 D8 D8 D8 D8 23 90 1C 64 91 A5 85 B2 D5 94 6D 6C'\r\n '02 6A BB EA 01 5C 54 50 DB 88 A2 53 C5 C5 85 8E 22 A8 A9 D3 A0 DB B7 6A 95 4C 1A 2A 95 6B 6D C9'\r\n '32 12 07 88 40 AD 51 09 A5 A8 F5 35 0A 6B 51 02 2D DF BA 69 E6 1A D1 AA F4 20 04 0C 63 6D 9B EF'\r\n 'B1 90 45 18 1B D2 56 FA 28 78 93 83 C3 85 60 9C 0A A2 A7 C4 AA 77 6D 77 51 B9 A2 CA 35 6B C0 D1'\r\n 'CD 24 76 D1 42 4B 3A EB 57 4D 0A A2 A7 77 FD 9F E8 F6 BF 91 FD DC A0 13 8B 7F 0A E2 AB 5E 43 6A'\r\n 'B0 9C A9 37 5B 8E C5 0C E3 78 F8 EA E9 89 54 51 E4 7E EE C6 ED DB 8B 58 B5 91 B5 59 46 DB AE 13'\r\n 'AE 60 6F 40 FB CE 1B 6D DE F8 8F AD FF 25 FF 3F EA 6B 86 F7 84 A6 94 6B 85 C2 6A C9 BD 26 FD FB'\r\n 'ED E3 79 BF C3 EE DB 90 E8 69 50 52 4C DC FC DF D2 5B FF 74 00 C5 93 72 4C 9B 0E 49 AF 57 5D EF'\r\n 'EC D7 F5 B0 A0 86 C6 1B 1C FD C7 EE 16 F9 09 21 C4 90 C9 87 33 3D E5 8D 9F 51 DA DB DC FC 6A 81'\r\n '88 8A 13 2C B7 FD E7 DD 72 76 7D 0B E6 75 90 1D 12 45 80 76 4C 8A 41 49 D4 DB 44 D6 D7 8D AA 30'\r\n '4E 54 F0 F6 F0 9D 82 BE 12 8A AA AA 55 AD 6E 43 55 CE A4 0C D5 3C EC CE 67 96 4D 96 77 05 BC F7'\r\n '1E 83 CB F0 F0 B2 B5 96 B6 87 AC 02 01 B6 CD 6A 44 DA 81 A2 4D 44 5B 6F A9 BA F7 4A 78 5A 8B A5'\r\n 'D9 DE 7B EE EB F2 71 FC A6 1C 38 55 70 55 6D 5C 2D 6B 23 6B 59 56 D6 B8 43 83 0D 55 5E 0C 39 9C'\r\n '2E 0C D7 51 B4 D3 5A F0 58 75 31 2C EF 50 6D B7 A8 00 98 0D 30 14 48 AB 51 5B 6F 29 97 BD 52 52'\r\n '15 56 BD C0 0D 89 0D A8 06 C4 15 43 62 4A DB B6 A5 84 36 A7 95 F7 5E E7 87 FC 7E C7 30 90 38 90'\r\n 'E2 9C 76 B4 B1 65 B5 A4 2C A5 AD 69 66 05 AD 44 14 96 B5 48 B2 42 0D AA DC 74 10 E3 48 71 B3 72'\r\n '27 1D 57 12 60 85 A3 C4 9E CB E5 7D 0E 1C CD BB 85 37 D1 45 52 D0 53 5B EA AA D6 5C 09 55 7B DC'\r\n '93 54 81 A2 8E E7 3D D7 15 18 A6 E4 BE E6 6B A5 09 4A 35 21 4E B6 D6 D0 35 48 2C 03 25 06 6A EB'\r\n 'AD C6 31 B0 56 B5 43 F0 B5 A8 EB B2 AD 66 04 30 63 19 B1 D9 B2 F3 2B A8 36 65 49 60 D8 9F 07 DD'\r\n 'DC 80 69 A5 04 37 6E BD EF 02 6C 49 33 8E D7 6E A5 24 B5 29 0B CA 7C 1F 79 56 B2 59 B3 EA 80 D8'\r\n 'A5 98 E3 35 6A 39 0A A6 C4 0E 9B 42 19 40 48 DB 70 28 25 48 DB 6D C0 A5 6D 57 6B 59 2B 5A F8 5E'\r\n '01 AB 8A 49 A2 88 6E 77 61 75 11 86 EB D1 E3 3F 97 1B 80 63 9D 00 62 09 33 70 C2 F3 0A 4A 07 3A'\r\n '32 F5 FE AF 3F 45 EE EA 19 A4 16 49 94 43 5A D7 5A 55 43 0A 94 EB 89 47 A0 A0 C1 90 C2 AA 40 B8'\r\n '21 93 FE BC D1 41 11 10 12 02 62 08 F3 3E B6 B1 7E FF D6 97 C6 D4 7B 34 1B 60 98 37 5F 4F FB B5'\r\n '3A 1E 84 3B 3B B4 50 E8 2E EF F6 FA E4 56 49 65 9D 99 BC A7 E6 6E F3 F9 2C CD E8 FF D7 FD 2E 44'\r\n '43 B0 60 11 54 CC 19 10 9F 47 A3 20 07 40 C7 D3 DB EC 2F E4 B6 DF D3 FC DF 8F 86 3F 23 7F CA F3'\r\n '94 43 72 40 C0 1E 2E 2E 2B AD E8 11 65 43 0A A3 8F C1 FE 3F 63 82 39 B9 C4 D6 F2 FB EE FC E0 42'\r\n '5B 88 88 10 01 70 01 6A D4 C4 23 51 0A 1E 36 3C EE 9B 4D 9F EB BF E3 F6 78 1B 7E 17 F0 D5 7B 5F'\r\n '7D E7 3B FD 54 47 62 DF E9 69 FD F0 13 F2 77 56 5E 4F E8 B2 DE 84 C3 64 E5 57 4A BE D2 18 08 04'\r\n '92 02 04 00 AF 20 08 05 80 C9 4A 4A 00 88 80 22 89 43 62 63 7C 7A 9C D7 F8 BE A7 67 AD FC 64 F3'\r\n '8F F1 3F B7 53 30 E7 49 B7 B2 9A 52 9B FD 4B 77 BD 8F F0 F5 60 F5 8F 88 42 41 12 10 02 08 88 09'\r\n '02 1C 30 30 22 72 98 04 80 DC 43 77 F0 D9 76 99 EE 6B 53 F1 59 E0 7C DC 5E 0E A5 2C 0E 87 5B 01'\r\n 'EF FA E3 FC BC 7E 46 E4 88 66 F7 AB E8 7D 4D FE 13 3F 05 1F 41 A5 C3 1A 4A F0 20 05 78 80 06 50'\r\n '90 95 E4 10 24 99 25 42 51 4B 81 74 9D A2 7D 87 D8 7B 4C 3A EF 6D D9 FE 5F 7B FF CF BF EF FE 26'\r\n 'BF 33 F1 7E 93 97 7D 54 80 1C 89 00 E4 12 28 11 CA 0C 1C 87 01 20 20 21 C8 D7 78 34 1E F9 BE DF'\r\n 'EE E3 06 9B 2F 0B D1 57 EA 43 E8 6C E0 48 42 38 66 50 24 81 21 0C E2 51 CD B6 12 F7 15 6B 1A B0'\r\n '22 87 35 A3 D9 FF 1F 63 D8 3E 37 F7 EE 7A 0C FE E7 F9 3C 1B 10 9C 6C 86 D8 9C 7C 7C 4D E7 15 54'\r\n '30 25 A8 FD 23 DE 76 FF E0 F8 9E B7 0F FE B6 43 A0 90 D5 08 69 05 71 31 C0 E4 31 4A 40 64 21 83'\r\n '7B EE F4 BE C5 4F 63 C5 A1 DB FC 5A FE A7 DC DC 33 9A E0 1C 08 01 00 1B 90 41 CB 93 00 03 91 0A'\r\n 'EB CD 2D 68 DD A7 29 E3 E8 66 A5 F1 EE D0 FF A8 3A 1C 75 01 7D DB 99 BF BB 1C C0 F4 40 80 27 12'\r\n '90 80 0E 80 44 44 41 EB D3 10 8F 44 0F E6 B6 FF A7 1D 52 1B C0 12 01 16 10 07 E2 00 0C 9F F8 1F'\r\n '07 3D F0 F5 6B F8 BD B3 9F 64 39 78 67 CA F9 FC 5F DA 75 6D 1C 2D C9 14 00 8E 84 08 47 36 BA 49'\r\n '35 B7 1F 3F 6C 58 96 48 ED 8F C9 F6 BA 9E E5 A3 70 85 9A 60 02 38 10 00 07 12 22 F9 59 39 9A AF'\r\n '7F DC 6F DC 5A 7D BC AF C0 B7 91 DB F9 AD C8 42 52 12 08 81 2D 04 08 C7 CF 9B 7F D2 EC FC 4D 87'\r\n '2A ED 8C 4E CB 79 6D E6 F5 BC 4C 9D 73 4E 75 97 6C E8 00 02 C4 71 84 08 F4 40 92 41 F2 04 B8 CC'\r\n '37 B7 33 7B 07 0B 77 53 F3 CC 79 F4 5D 85 ED 9E AF F5 FB 2E FF D9 7A 7E 8F 75 FE 7A 09 D2 49 D2'\r\n '49 D1 7D E7 C8 FB EF 37 FE BB FE 0F 7D DD E7 D8 FC 9A 80 6E 61 01 18 89 39 83 82 ED 50 22 04 00'\r\n '12 69 CA 00 63 02 06 BB 30 75 FD 3F AF AB FF 75 0D A0 3F 1F 55 F0 24 38 09 61 F9 5F 07 88 AB 3D'\r\n '5F 27 0F CE A2 4E 63 24 E8 24 BA 4B 73 28 3B 06 05 0A 9D 0C 2D 3A 2C 3A 18 14 79 4F DE ED BE 87'\r\n 'F2 EB 67 C0 C3 DE F9 0E 1F AB B6 BB FF 81 F3 7E 77 EC 7F B3 2F 2F F2 3C C6 9D 56 00 14 8F 3A 83'\r\n 'AA 56 42 A3 22 DB 96 DB A7 64 EA 5B 69 A9 B6 2F 32 7B FF BF F6 F8 DD 3F 0B EE FA EF 35 B9 AB A3'\r\n 'A9 35 F6 44 AD AC D4 7B 0E 00 8A 87 27 2D B3 65 A1 84 A9 82 38 D1 C7 DC 78 3D E7 D3 79 5F EA FC'\r\n '0F 77 AF CF EE E3 B4 92 B7 54 92 28 A2 83 C6 F1 BC 68 B3 BA 79 13 FB 7F 83 F5 5E 97 E3 F8 7F 6B'\r\n 'ED BD 2F 9E EE FE 4F E9 E1 B3 F9 7A 75 E0 6F D7 FF BF 75 84 92 74 39 FF C9 ED 2D D5 8F 58 C8 53'\r\n '3A 10 8C 91 8F 59 52 C1 65 EB 2D 33 4E AD 3D 37 E7 FD 77 EF 7F CB DB 7F B3 F8 70 D7 E6 FB 1F 7D'\r\n '9F EE FA 7E 2E 4E 67 28 4E 56 4E E9 90 E6 28 8F 37 2A 9B D0 E4 10 10 04 4A 1F 5A 18 13 3C 81 30'\r\n '18 44 A6 C5 8C 81 00 2F C7 B9 10 59 14 7E AF 0F 3F EA F7 BC BC FD AF 7C F5 EA E4 92 73 45 45 3A'\r\n '1D 0B 0B 39 BC 94 74 13 F5 CD FF 5D 5C DF 25 7E D3 D1 7E 5E FD 78 B8 AD 21 0D A2 2A 71 33 86 17'\r\n '50 5E 2A A3 2A A1 66 10 E2 4F DB F7 9F A9 F3 31 CD 99 BB 59 0A 64 D9 55 24 D8 2B B6 83 6B 32 4B'\r\n '86 34 74 FB EF 0B 47 27 B1 CB 3D 76 D8 24 D8 88 0B 60 5C 51 10 39 04 0E 24 02 91 72 94 17 10 D8'\r\n 'CF D8 66 F5 BF FB CB 35 EC FC FC 74 8C 6F E9 2F C7 FD 9D A6 6A 5F F8 EB 84 F5 7D 5D 10 A7 9E 85'\r\n '55 52 40 E7 A2 8A BD 5D 4B 74 65 DA A2 C2 BD 52 5A C5 18 F5 76 3C C7 AF F0 B5 F1 3B BE 16 F0 7E'\r\n '97 C6 7E E7 3F E4 F0 FB 1F 97 C9 CE B8 07 66 C9 CE 1E 55 45 94 82 BC FE 6D 17 15 02 F9 5A 73 EC'\r\n '4A 1E 7A 57 BF 7E B3 A7 FA BD F7 9D ED FF 8B AA FB DF 27 FF FE CF 45 A1 E3 BB 6E 2E 6F DF 57 37'\r\n 'A3 52 1C D4 9D 14 59 0E 6A AB D0 1E 8D 16 99 51 B2 D3 A2 98 99 D1 FC 7E 8B F0 F7 FD DF E3 7B CE'\r\n 'DE FE 6B B6 DA 1C 4F 2A 42 99 1D D2 80 22 29 C9 C7 C9 69 71 E4 4B BC 89 C5 E7 BF 4B B6 FA FF 15'\r\n 'EA FD 0D B6 EB E7 BE D7 8F 93 09 26 1B E5 12 3C 68 9C 89 7B 14 AC E4 4E 44 FD 6F 49 D9 75 3D 57'\r\n 'F2 7E CF 65 F7 FD 4F D8 76 40 8E CF 8B F5 FC BC 9E DE 89 CE E7 54 87 2A 1C DB D7 31 24 67 39 25'\r\n '26 09 F4 7E 07 63 D3 FA D7 E1 FE 66 CE 1E EB E2 DA 1B F8 AA 42 93 73 08 B0 11 16 82 D4 90 CA 71'\r\n '11 22 82 05 6C 58 5C DF D9 D5 D9 F6 59 3D 83 4D 1F CF A8 AB EF EE 76 7F 57 F8 F6 59 35 EE F7 8E'\r\n 'DE 0B 58 05 00 27 57 6A 17 A2 87 93 64 29 90 44 7A 4C C3 02 8E 93 58 12 8C FA 55 CD FC 0F 69 EE'\r\n '3F 9F E3 7E A7 FE 79 7E 3F B6 B6 ED DF E6 AE 1C CA 90 A7 8B 92 C5 89 CC 61 C8 90 54 E6 6C A2 73'\r\n '12 F9 D7 59 FB 5F A3 E7 77 F9 3F DF FC FE 76 3E 83 77 6D FD 1C 38 93 94 12 2F 35 00 A4 9C C6 43'\r\n '91 21 15 18 44 AA 09 08 C0 F4 9C 5C AF A2 A7 10 50 B5 F8 64 70 7D 5F 83 F2 77 46 87 76 E9 C8 91'\r\n 'E3 D2 90 00 0A 20 04 72 22 20 24 78 81 5E 0A 04 14 0A 52 01 5E 3F F3 E3 6D 3D D4 FB 9E 26 4F 4D'\r\n 'AC F7 7E 48 6B 73 2A 32 EB 5B 6B 44 08 00 CC 48 4B 11 00 39 8A C1 9C F4 9C F4 E7 79 CD E7 A0 E9'\r\n 'F0 C7 AC F6 1F 7B 8F C9 DC 04 E0 C2 64 31 9B DB 09 6A EB 6D 0B 70 E1 F0 39 DE CF D4 DB D6 7C D7'\r\n 'D0 EC D9 D7 54 03 70 C9 D0 48 6E 45 83 38 24 28 82 2C FA AD A4 DE 45 AF 99 F7 77 1E C9 F9 7F F6'\r\n 'E5 76 A9 FB C5 EE 56 E8 FE EE 1F 15 96 48 C6 5B D4 82 F9 EF C5 7B 97 F7 77 48 80 12 30 84 34 21'\r\n 'D7 AA 46 76 0C A8 33 44 BD 8F 41 E1 BA EF F3 D7 87 FC 9E E7 DC 7A EF BC FB 5A D4 E6 73 39 9C CB'\r\n '84 60 43 94 10 21 3D BF 89 DC 7E 67 AB DF 97 BF 4E 03 46 8D 1A 1D 02 11 98 90 08 0C BF 4A EF 5F'\r\n '63 DD 62 7B 9B 8C 89 7B 8D 32 FE 20 80 1D 93 27 74 A9 3A 5D 2E 4F 2F EF FD 8F 33 CC FF 63 67 B7'\r\n 'FE FD FD 43 D4 C2 48 A4 DE 93 6F A1 F2 FE CF 0F B9 C7 DC 39 F5 3A 9D 4E A6 04 30 43 34 0F 4D F2'\r\n 'FF 13 C7 FA CF 5D FB 9F 99 FD 39 7E 87 53 ED B6 F5 DC BC BC BC B8 10 E5 55 49 CA 20 4A 7B DE 61'\r\n '30 37 3D 43 DC D7 6B 74 9A FE 9F F3 E1 AD B4 60 AC 30 DC 00 01 81 BC 10 28 90 09 91 B6 E7 38 D7'\r\n 'A6 50 FD 94 2B FA 8A 90 08 C8 48 48 42 04 88 1B 0F 1D D4 2E D3 59 DB CE FD F2 1E EA EB F7 E7 C9'\r\n 'F2 E6 F5 8D 5D 30 42 04 40 12 01 33 FF 26 66 05 86 D9 6E 4B 77 CC EB B6 5B 9E 1D F3 6B 3B 39 90'\r\n '58 00 02 7B 1E 9E BB 50 57 76 76 69 2C B2 CB 3F 40 84 01 12 01 3C CF 2F E5 C1 CA B8 45 27 05 20'\r\n '67 84 00 C2 00 40 EF 7D 0A 8D 7B 7F C3 A9 E9 8D D7 6C FD 7D D7 5E BA AF 5E BD 39 01 B8 90 84 0F'\r\n '2E FF 00 7B 86 DF 07 03 DC 4C 17 5D 75 CE 04 07 BC E1 48 42 7B FA AC 1C C3 5C 70 AF F4 86 DA 78'\r\n '56 3F F0 C2 EE 1C 36 30 13 56 20 04 C8 10 26 26 86 72 3F DE B2 16 79 70 90 B3 54 80 44 C4 44 08'\r\n 'B0 81 1F F4 7B 9E 3A C8 17 BA 47 A7 46 DB 5C 2C 93 02 03 21 02 6D 54 9F 95 D7 7E 72 FA 43 FA 73'\r\n 'EB 72 09 B1 05 93 62 4F 61 EE BC 6F 83 EA 3B 2F B1 FB 3F 49 87 C7 FA BF 43 9D BF 83 FA B9 38 76'\r\n '9D A5 01 CA F7 2F 8D C6 AC C9 3D 3F 9B BF 6B 6E FA DF F7 7B EF 0B FC DF AF 6E 1C 36 90 DC CE 0C'\r\n '27 FD BC 8F C3 5C E9 A6 50 02 13 C6 FE DC 0D DE 6F F7 FC 8F FF 3C 2E F8 55 20 04 01 02 13 B8 37'\r\n 'DD DD EF CD D0 69 7A 3F B3 5F F4 F3 70 5F 33 02 74 C2 43 B7 64 F8 9F AE F7 AF A5 FC 1E FE DF ED'\r\n 'FF 57 F3 78 8C 37 7C EF 63 BA 10 EF 14 3B 3E CF 96 F3 95 81 4C 27 C5 F7 DD 2F EB FD DF 59 8E FF'\r\n '03 74 2C 68 86 A8 14 93 AA 40 F4 7D 3F 6F 91 2E 19 24 31 40 FF 97 D5 79 FC 61 7D 19 0E D1 00 F5'\r\n 'DE 3F CD 7D 4F F3 72 78 EC A0 69 04 87 D0 B2 4E FF E7 7C BF 85 F5 9F 93 B3 C0 F6 1F 5F 99 D0 C4'\r\n '4F 41 CD EB FE 4E 13 04 07 00 40 80 24 11 20 13 75 EA F1 76 DE 86 3D 4D 0F 39 B2 E6 95 F4 D5 C5'\r\n 'FA 19 90 80 0D 44 40 60 76 87 1D 49 3E DB E6 F3 BD 0F AF FA 8E EB 4F F1 7B 9E 2F 27 AE 5D 1A C8'\r\n '86 FF 25 A7 08 4E E1 52 71 7E 9F D7 F7 FE 67 EE 3B 9F 2D F1 B6 12 6F 82 04 3C 82 48 4E A9 3B 86'\r\n '71 A1 C1 03 CD F4 3B CE 86 90 C0 93 46 04 3D 7F B5 FE AF C7 F0 FF 07 C1 C7 E2 69 0D 81 38 95 84'\r\n 'FE E7 D5 FE 1F F8 71 86 0A 01 8B 09 EC 79 4D 8E 2A 24 04 08 42 22 20 04 F9 B2 63 7B 5E 47 D3 CD'\r\n 'E7 4D C0 4E 9F 7D CC AC E7 FB 35 20 35 6A 00 04 37 5D EC 7C 61 47 E5 DB 52 FD 6F 11 FB F9 7F A7'\r\n '0F 47 F8 F9 61 F3 BA EE 28 1C 90 42 72 32 4E B2 C4 A0 F1 08 5D 8B 09 C6 DE 0C B2 4B B0 F1 88 4E'\r\n 'EB 8F EC AD 03 06 D8 34 88 06 1F 03 2C E1 78 64 C8 15 0F 21 A7 E1 7A 4C 21 8B 34 D6 A5 31 4D 88'\r\n '4D 50 9A 05 9A 26 2C B2 1F 40 A9 30 70 86 BA EB AE 04 D8 E9 AD 01 A2 4E DF EE 35 85 89 93 09 83'\r\n '25 A0 81 6C B2 6D 26 E1 00 30 51 57 6E DD BB 70 9B 99 A2 4D 8C 93 65 AA 0E 97 2D 00 E3 70 1D 59'\r\n '31 43 09 8A 50 60 C5 84 C9 2B 0A 09 42 4D AC 9B 76 ED DB 8E 58 91 76 22 68 C2 88 05 D0 36 30 36'\r\n '6C D9 B2 E0 6C 43 31 D8 94 8A 40 D8 31 BD 40 B3 66 10 35 62 1B 36 6C D9 8E 79 41 4D 9B 28 26 88'\r\n '1A 6D FD 0A 99 B7 A5 CE 82 18 B2 5C C7 1A 0D BB 76 ED CB 45 D2 80 5D 7E BB 75 16 26 0A 92 68 6D'\r\n '65 5B 2A 21 8A 10 BA 46 05 E8 6F 50 C6 AA B0 68 97 61 30 82 05 5A A5 24 85 90 05 8C 61 37 24 C5'\r\n '98 B8 A4 0C B1 81 93 68 4A 64 0A 49 15 15 90 C5 98 B2 E9 08 B2 64 81 81 0B 6D DB 69 70 33 C2 82'\r\n '16 86 18 6D DB 84 34 4D 35 28 0D 9B 2A 12 AA CB 22 53 68 40 50 8C 12 60 E0 85 D2 E9 23 0D 9B 36'\r\n '6C C0 26 29 8B 24 52 20 90 CD 36 6C A8 60 E0 86 AC 95 21 6A 92 52 11 46 6E 49 6B 06 BA EB AD C9'\r\n 'AB A2 01 9C 33 A2 49 50 42 EC 25 95 24 B4 19 2C DD 90 96 60 21 9E 76 92 1B 5B 85 69 41 9A 63 8E'\r\n '21 33 DA 56 C6 19 24 DA C9 99 A6 95 30 D0 D3 12 59 92 66 92 61 0C 30 B4 C1 00 D1 86 8E 4C 29 97'\r\n '64 03 26 21 96 56 08 19 63 95 A1 32 49 31 C6 89 8A B8 21 83 16 28 68 C0 D5 CB 2D B6 31 43 3C E8'\r\n '36 21 74 9B 19 29 26 18 54 B2 2C 2E C9 49 2F 86 16 24 96 4B 28 B6 A0 86 98 54 76 6C D9 A6 01 0D'\r\n '10 E2 EF 3F A7 B2 FB 9F C2 FE 5F 3F ED 7E EF FC BF 81 F0 3E 17 80 7B DE 1D 77 ED 77 7E D0 F4 BF'\r\n '92 55 31 AC E0 7D D2 6C 36 73 CE 93 09 D7 51 52 75 49 29 3A DE B5 68 0E C1 EC 01 32 64 C5 03 26'\r\n '4E C2 D4 2C 84 F5 BF F1 ED 7E 56 3F B9 CE DE 2B B9 D1 F6 DE 2C CF 03 C9 A7 B6 B3 EB BE DE E9 FF'\r\n '8B F0 7D 70 FE 08 DF A6 E2 2E 15 77 67 79 CB 59 F3 37 DB CA 3A 1E 0D 4F 4E 8F E5 F6 D5 F4 3D FE'\r\n '8A E3 53 C0 D0 69 8F C5 C4 37 D7 D8 45 93 99 C4 F9 90 E0 74 7D C9 3D CE 9D 3A 4B 75 19 DD 3C AD'\r\n '77 55 73 6F 9C 40 B2 89 5E 8B 1A 42 6C 37 CC EA 68 68 34 F6 1A 45 BF EC 68 B3 B4 5D 8D DE C1 2D'\r\n '38 BA 27 E6 40 3B 25 D6 86 C9 2A 20 28 71 17 40 C0 D4 3E AA 51 79 6C A4 37 62 46 B5 D0 BB 94 23'\r\n '79 2F AD B4 61 AD 19 21 7A B7 2C EE D8 48 BC 8F 7C 3E A4 8C B1 8C 19 6A 86 4E 0D 8E 32 D7 8D 62'\r\n '1A 3B A9 4B A6 32 80 C1 8E D3 62 F5 CF 20 B3 36 07 92 FE 53 82 C9 0C 87 90 A4 BE 1E 10 CF C8 84'\r\n 'F8 C9 07 BF 8C 3C 53 4D 8A 6C 82 CB 8E 3A 00 01 02 F1 00 20 C2 40 08 22 8A 2C A1 86 18 63 5E 8A'\r\n '28 A2 8A 29 63 0C 30 C7 3D 7A F5 EB D7 AF 5E BD 7A F4 59 83 0A 2C C1 86 18 61 86 18 61 86 18 61'\r\n '86 18 6F 4C 61 86 18 61 4C 18 61 86 18 61 85 14 51 44 10 40 82 08 20 82 08 20 82 08 20 82 08 20'\r\n '82 08 20 82 08 20 82 08 20 82 08 20 82 08 20 82 76 ED DB B7 6E E6 3C 78 F1 E3 C7 8F 1E 3C 30 20'\r\n '8D 0C 30 C3 0C 30 C3 0C 30 C3 0C 30 C3 0C 30 C3 0C 30 C3 0C 30 C3 0C 30 C3 0C 30 C3 3C 41 04 10'\r\n '41 04 10 41 04 10 41 04 10 41 04 10 41 04 10 41 04 10 41 04 10 41 04 10 41 04 10 41 04 10 41 04'\r\n '10 41 04 10 23 8E 38 ED 93 8E 3C F8 07 9E 79 E7 9E 79 E7 FF 98 27 8F B6 04 00 0C D3 DB 00 02 00'\r\n '5F ED 81 04 00 35 F8 3E B0 8E DE BD 7A 30 C3 0A 28 A7 1C 2F E5 10 40 82 0B C4 76 ED CB 97 2D DB'\r\n 'B7 6A 73 6D 8D 8D 86 67 34 D7 39 99 C7 33 64 C9 93 16 2C 57 AF 5F AB AB AA B1 62 CD 3D 3D 35 6A'\r\n 'D5 9C 72 B5 2A 54 E8 68 68 67 E7 E7 E6 E6 E6 E5 E5 E5 E4 E4 E4 E3 E3 E3 A7 4E 9F 17 17 17 0F 0F'\r\n '0F 07 07 06 FE FE FE FA FA FA F2 F2 F2 EE EE ED 2A 54 A9 12 24 B6 B6 B6 B5 B5 B5 46 8D 1D A5 A5'\r\n 'A5 9D 9D 9D 42 24 48 90 A1 42 86 CA CA CA CA C6 C6 C6 C4 E3 8E 39 09 A6 9A 8C F3 4D B7 30 C3 25'\r\n '40 93 02 44 08 F0 23 40 8B 00 88 04 0B 01 A9 10 08 80 44 02 20 91 04 88 24 41 22 09 10 48 80 44'\r\n '12 20 91 04 88 24 41 22 09 10 08 80 44 08 04 11 2A 2C 58 B2 A3 46 95 1E 3C 78 F1 E3 C8 91 26 49'\r\n 'E7 9E 79 67 9E 77 38 10 40 03 92 80 10 18 E6 DE F9 33 9F 3F 03 FD 7F 07 CB ED FE EF 1B F1 FC BE'\r\n 'DF A1 F9 FF 2F 03 DB B7 8B C7 D3 55 A5 22 CB 4B 56 E6 C2 CB 49 57 F5 97 67 A4 C4 BD B2 9B A2 D1'\r\n '5F D0 A3 A1 CE 53 A7 6F 71 A0 CE 6F BC 9D AE F7 71 B5 DE 79 1B 5D DE DF 6B E7 78 F6 58 B7 56 58'\r\n '89 6C B0 D1 A5 EE A1 A1 C2 4A 87 05 2A 1C 04 A8 6F EE 91 26 BA 44 9A E9 12 6B A4 49 AE 90 A6 BA'\r\n 'B2 4C 96 C1 32 5B 04 C9 4C BF 4A 66 02 53 F0 52 9F 84 95 26 09 89 70 4B BB C1 26 F7 06 52 6E D3'\r\n '6C 2D 39 19 D8 76 99 38 B1 93 D8 9B 17 1B 31 C1 8B 88 57 98 9B 42 60 F9 EA 5D 17 AD 13 55 5E 46'\r\n 'A1 50 F5 16 93 0B 54 E2 61 30 38 98 6C 8E 26 23 43 9E 92 EC 77 4E 99 1D 04 91 88 14 57 07 12 46'\r\n 'C9 C4 C5 7E 71 51 E1 1C 5C 91 CE 2A 64 A2 64 C9 8E 71 85 92 71 A6 1E 79 E7 9E 79 FC 90 00 F1 50'\r\n '02 0A 04 00 82 07 15 00 00 03 EC EF C0 A4 57 E5 BA C5 E6 6D E6 6B 72 AB 96 B1 57 BD 35 E7 31 55'\r\n '71 A9 52 BE 8F 2B 28 AA 49 8A B0 B3 25 92 4B 2B 29 90 98 E2 18 B6 90 C9 59 30 66 17 98 58 97 19'\r\n '21 76 C9 61 08 5A E5 ED 48 4C 10 31 43 0C 28 98 B0 30 61 2E C2 C9 76 B1 A9 21 7B D8 B4 86 0C 85'\r\n 'D0 C1 70 A2 01 48 42 D8 5E D2 AA F6 93 06 43 04 09 8A 15 85 0A 60 C9 0B 24 B2 01 74 0B 63 4B 76'\r\n '4C 12 01 74 97 6F 55 2E C8 17 B5 37 A0 25 92 52 05 D0 C5 80 52 05 08 10 0E 28 20 50 11 20 11 21'\r\n '20 14 40 C8 94 08 4E DF B5 D9 75 DD 67 FA 7E CF F1 D5 75 1B 1E 9B 5F AD D6 73 F9 7A 8A DC A6 9B'\r\n '47 A0 CF 62 D4 A7 7B E4 F6 BE 95 F5 D5 AD 0F D6 5D 74 BD 6F 3F CF 6A 66 CE E5 AB 5B 77 93 F0 AF'\r\n 'AF 2E B8 FD 47 47 D0 62 E9 B9 6F 57 D4 FF E6 FF 7D BD DE 6E FF 9F 9B E5 FF 1D C6 DE B8 1F 09 22'\r\n '09 0A 20 01 5C 20 01 B3 EA D1 DB 55 C2 8D 86 CE 1B 96 20 40 85 69 86 ED F6 3B A8 78 CF AC 33 B8'\r\n 'B8 D8 D9 D9 56 16 12 2C 64 D8 C9 B0 CE CD 99 8F 36 F6 6D C5 9D 5C 4C 2A 95 71 31 31 31 16 24 81'\r\n '0A 59 E2 81 08 E4 40 84 02 88 10 0E F6 F4 60 AA C2 0A 04 59 24 30 49 FB 5F A3 87 5B DC F7 1E 67'\r\n 'E9 BF 43 D8 F9 1F 99 F8 BE 7B F8 FE D3 EC 7A 34 EF 7F E7 E3 61 EA 6F 89 B2 88 56 8A 7E CC 9F 3E'\r\n 'FE 24 61 F8 6A 51 2D 59 CF CB E8 F0 B9 93 EC 58 6B 32 FE 1C EE B2 DE 36 E6 7E AB 27 23 D6 1B BF'\r\n 'C5 E9 E3 BD DE 9D BE C8 99 EF 3E C9 87 5B 67 37 D2 73 C0 4E 3D 6C 1E 32 58 D4 F8 7D B6 6C E7 FE'\r\n '9E 32 CE 70 7D DB 4A F3 52 B4 B2 4A 4E 32 6A 4A A7 F5 9F 7F 5E 93 17 BE AF 42 FE AD 47 72 AF B5'\r\n '9E C0 EB FE C7 5F 68 DC 62 AC F3 56 95 30 9C C6 92 EE 2F AC 1D 47 94 B6 CB 18 7B 43 64 5C B3 29'\r\n 'F4 5C F4 B8 84 48 CD 6E D5 93 85 4D 31 B5 21 63 46 D2 34 A2 9C EA 96 F7 5A 3A CD AD A5 EC 1D 31'\r\n '88 50 C1 C1 18 71 E1 93 20 D8 8D 9E 3C 7E FE 46 C9 51 0D 16 18 F0 0E 24 C8 25 16 3C 68 86 4B 2A'\r\n '4C 78 E4 98 79 A7 94 79 E7 1C 71 EA 41 06 C9 02 04 00 83 9E 81 02 00 40 F0 7D 96 28 65 B3 BF F0'\r\n 'EC FA 35 BE 1F FB E6 E1 75 FA 7F 5F 50 99 D1 66 3C C0 E9 52 99 F5 B2 FE 4B FF 7C 95 CD 12 FB FC'\r\n '46 FF 09 FF 0D 4D 9D AC EE 17 AB 80 58 64 52 AF EA EF 7D 42 6D E9 9F FB D5 7E BC 03 E6 B8 7B E5'\r\n '6C EB 97 4F B2 E8 74 66 67 48 B8 A8 93 C0 BC C8 EE 32 3A 8D 44 59 CE DB 89 B9 BF BA 9B A6 D7 A5'\r\n 'DE 31 29 3D 6D 8D 2C 34 B7 33 F8 08 59 74 5A 33 EE 75 99 26 9F 59 09 24 AA 83 94 25 C7 EB E2 6B'\r\n 'C5 EE DD 41 42 AE C8 FD 45 D1 60 DD 3A 56 D6 D6 04 07 58 29 89 D0 10 33 B5 6F 34 DA A7 1F 1B 21'\r\n 'EB 35 90 9B 10 B1 3C 8D 29 4A A2 65 33 93 94 BD B3 7C FD 80 98 0E ED 5B 81 8A 84 BF 5D 88 AC 1A'\r\n 'EC 11 04 B3 9F BD 3A 4C 92 DD C9 7A 44 99 31 62 EC C0 85 1A 04 69 30 C8 8B 20 98 D2 A5 12 74 B3'\r\n '0B 2C B3 0E 34 F3 8F CD 74 77 C2 A4 7E 47 C6 A9 0D 61 3E E4 FF E2 5F AD E8 7E 62 45 FA FC E2 FE'\r\n '3F 3E 07 ED B5 F6 7C ED C9 B6 99 5C 14 D1 78 27 23 DE FE CE FB FF 5A F7 A5 EE FB 15 16 1F 2E 7D'\r\n '0D 4D D7 CB A7 32 F7 3B E9 F6 EC 53 F5 FD 95 4F 70 F9 D5 98 95 1F 3A 9F 7F B3 F5 75 70 09 E8 71'\r\n 'B5 A9 C5 4B 4F C8 E6 45 52 D9 AF 4F 26 DC C5 D0 6F C8 31 3E 25 6A 3D 09 CB 67 63 EC 28 D9 E9 A2'\r\n 'C7 A2 5D 0B 03 BD DB 44 C8 EE DB DB A6 8F EC 6E B2 F0 75 A5 59 9F 6B 0B 12 42 AB 24 B9 7A 38 4E'\r\n '2E CA C7 BD 53 29 5B B6 E7 18 BA E2 DC 77 98 EE 34 A3 B4 90 22 78 1A F1 21 BF 6D 99 2D C3 37 19'\r\n '5A 81 0A 40 4C 9D 41 28 3D 8D 37 F0 22 C5 98 29 AF 5F 99 2C 66 84 C0 34 E8 E5 9E 66 CC 08 AF 45'\r\n '36 3C 58 92 4C 24 E3 21 93 24 93 4D 91 32 5C B2 4A 24 C2 8D 38 E3 4F 3F 2C 00 00 B5 40 0A 04 00'\r\n '20 40 00 19 08 01 07 72 CA FE BA 73 FF 7F B3 DE EA 18 C7 E4 31 A7 F4 DF 71 4E 0F E7 42 B3 AF C4'\r\n '44 1D CF 5B 3F F8 FD 13 E9 F5 0B F4 BC BA 49 EE 5F 03 DF FE 7A C7 DE 56 D2 EF F8 74 23 D2 EA EA'\r\n '5E 35 F7 28 72 94 72 DF D3 FB 8D FE D4 D4 DB BA ED 7A DD 14 DF 0D 8F 53 9B AB B1 C1 DE BD CC FA'\r\n 'AF EC 33 EB BB 4F 31 78 52 EA 56 EC F5 75 54 F5 EC EF B3 DF 77 2D 2D 14 69 54 31 A7 EF 64 BB B8'\r\n 'A7 78 31 78 0C 4C 7D 19 B3 84 D9 66 31 B8 6A EF 21 6D E4 B7 8C 1C 34 6D 13 15 F2 64 6A 1C 13 85'\r\n 'A5 01 53 29 02 27 8A D7 32 3A AC E4 8E 07 66 1E A1 B9 24 60 49 D0 4F 96 A2 33 97 8E B6 5F 6C 67'\r\n '1F A0 A9 AC 05 90 DC C6 82 BD BE 87 9F CE FA 47 E6 EF F7 9E 17 CD 4F FA A7 FF 65 E4 19 29 F7 7E'\r\n '57 F2 AA F6 68 BD 15 EF 7D 7B 3B 8B 6F 0C 10 00 03 C2 40 08 2F A3 EE 0E 81 7F B8 54 5C 37 7E AE'\r\n 'A5 D2 DF E7 FB F8 B6 FD CA BF 5F 32 BE DE C2 A7 76 C3 E9 F6 8C 28 2F 63 9F 46 9B 5B AF 67 4D 37'\r\n 'A1 AB CC EE 4D 55 CF 71 F2 26 EF 0D 96 8F 3A DF B1 C3 CD 6B C3 AC E4 DD 76 A9 67 2F E8 39 16 47'\r\n 'DF 28 60 BB 2E A6 E3 A9 42 16 CE 60 61 94 39 69 F1 EB 6F 2E 3B C2 60 57 27 B5 D0 78 9E C2 B9 86'\r\n '56 AC 06 EE 5D 36 48 CF 61 82 48 09 EE 61 46 84 41 CA 0B 2F 16 F1 C6 BE 25 FE 76 B6 52 FB B6 F9'\r\n '8C 76 18 EB 27 69 A7 AA D5 E8 AD 03 CE CC 16 40 4F 62 A9 7C 93 0D 2E 26 1E 2E 2E 06 7E 38 4F B5'\r\n '8F 99 16 5C 89 25 9A 74 B3 0C 36 61 86 9C 7B 16 5E 40 1A 88 01 04 1B EA FD F7 DD FD 7E EB DA FF'\r\n '2B CC F9 3A 57 95 FF 3D 05 EF 7F 7F D1 F4 3D 23 A4 3B 22 59 10 DF 8A FC F7 BB 25 C6 38 C2 63 93'\r\n '2C 72 A3 45 38 D3 8A 34 E2 A6 52 DB B1 CD EA 23 A5 B5 A6 B5 E3 53 5B 53 DB 53 A3 5D 96 F1 7E FF'\r\n 'E8 DE 70 38 1F 47 C9 C1 EF 5F 33 55 5F 7E CD 5D B6 4B 55 97 39 8D B5 6E F3 9B 2E BE 50 D9 7A 65'\r\n '18 1A 18 3A 18 7A 38 7A 18 BA 29 F4 5B 30 C8 54 D9 8E 55 7D 7C 12 24 4A 91 51 1E 34 89 12 09 B3'\r\n 'B5 B5 47 6B 25 C9 45 14 D9 F9 59 F3 2F EE D7 B6 81 1C A2 8A 28 A2 8A C2 4C 51 79 D8 B8 F9 D9 58'\r\n 'F9 39 4E 1C 38 70 DD BB 76 CD 8F 6E DD BB 76 C6 B7 39 C3 83 9C B9 3D CB 97 2E 5C BC 08 20 9D BF'\r\n '8D B4 41 B2 49 85 1C D2 A2 47 30 A8 B2 A2 0E 3C A8 E6 CC 26 61 E7 4C 34 F3 CE 3E 61 E7 9E 7F 82'\r\n '08 00 4E A0 04 10 41 E7 08 11 01 11 20 55 C6 C6 C6 C6 C6 C6 C6 C6 C6 C6 C6 C6 C6 C6 C6 D4 EA 79'\r\n 'CC BC BD 46 97 55 AA E6 39 8E 63 2B 96 E7 F9 FE 5B 2F 2F 98 CB CB D7 6B B5 DA ED 76 BB 2E 8D 95'\r\n '95 1A 3D 1E 66 66 66 65 C6 67 4F D3 DD 74 FD 3F 2D 95 95 95 5A B5 6E 57 2B 61 9C C6 CE 67 BF 87'\r\n '8D A1 F7 FF 7F 8B E2 F0 3C 4F 03 E9 F8 76 BF 37 D3 65 63 61 59 61 63 63 F7 FD EF 79 D5 FD FE F9'\r\n 'CE CE 34 EA 23 4E 34 E3 60 53 1A 74 2B 8E BC F9 D0 68 68 68 A8 CD D0 D0 A6 3B AD A2 72 95 2A 54'\r\n 'A9 53 29 52 95 4A 88 56 AC 99 32 D5 CA 39 6A C5 AB 56 9D 2D 71 53 0B C0 C0 2D 84 CC 2C 33 4E 3C'\r\n 'F5 AD 9B 64 64 B1 66 C9 96 6B 26 9A FD B0 00 02 99 00 20 00 D7 C5 F0 FF AE F3 E0 F1 7C BF 33 77'\r\n 'F6 F9 06 15 2A 39 1A 50 76 9E F9 1C BF B3 71 C6 E1 F0 3A 1C 8D D7 A3 3C 79 B3 0A 97 25 8C 51 E1'\r\n 'F9 BD 18 1D 0F 5F D7 E7 4E 73 7E AF 87 DA F6 B7 9F 2D 1C E7 43 96 71 A6 4C 2C A2 65 CA 93 BD DE'\r\n '70 FA D4 BD 5A 5F 9A 97 AB D4 9E 9D 9A E2 71 BB 13 53 5C AE E1 E7 9E 79 E7 9E 79 E7 9F CC D1 D1'\r\n '99 31 41 86 18 61 82 8B 0A 2B E7 C1 04 C6 0C 1A 16 6C D9 96 58 E3 8E 3D FD FE 8A 65 57 E9 AF B4'\r\n '15 61 29 C3 5A A9 6E A2 C4 E9 D5 2C D3 D4 CC 59 2A 54 AB EC CD 4C 9C 9D 4C 75 78 F9 1A 58 BA 7A'\r\n '5A BA AA 94 A9 52 A5 4A 95 AA 73 95 2D 8E 59 65 96 B3 4F 4D 62 C5 B0 75 41 03 E0 01 00 20 02 2A'\r\n '00 46 DB 0C 33 A7 4E 9D 0A 28 A2 0A 30 DF 8E 72 73 87 C3 E3 71 26 A6 BC 48 32 64 CB 97 2E 59 04'\r\n '0E 3C A9 52 A4 CA 97 2E 59 65 97 B9 A0 A1 9E 9E 9F 9F E9 74 A8 68 68 E8 FA DD 6A 8A 8A 8A 8A 8A'\r\n '83 0C EC 76 37 9B CD E6 F3 99 CC E6 50 76 28 0C A0 A1 E9 D4 54 D3 53 50 50 54 D4 D4 F5 D7 77 7B'\r\n 'AB B0 70 AE 54 D5 B8 5F 58 43 9B C4 BA 24 5D A9 21 D2 1B E4 4A C8 77 81 A7 A8 F0 25 A3 84 9D 70'\r\n 'EB C7 0F 25 88 FA C3 89 9B AE 3B 31 C5 50 D2 10 CE E3 2B 2F 37 3F 09 54 C5 78 AA 64 13 8F AE 2E'\r\n '96 50 AD 35 05 D8 CF 15 AA ED 15 CA 57 3C 56 52 FD 35 FA 42 AE 5A C1 6A FD 6D 60 DF 88 FC A8 CF'\r\n '66 42 33 68 C8 86 4A 84 41 92 DF 0F B4 F8 B0 C1 04 1F FF 17 72 45 38 50 90 4A 0C 4F 7A'\r\n}\r\n\r\n\r\nLANGUAGE 0,0 COMBINING UNICODEDATA LOADONCALL MOVEABLE DISCARDABLE\r\n{\r\n '42 5A 68 39 31 41 59 26 53 59 9A 6F 78 17 00 00 F9 FF FF FF FF FF FF FF FF FF FF BF FF FF FF FB'\r\n 'AF FF 1E FF BA 33 BC 31 FF FF FF FF FF FF FF FF FE F8 0F D0 03 BE 00 66 A6 A9 00 2A A9 FE D5 31'\r\n '26 26 53 4C 8C 9E 93 4D A6 A6 02 0C 9A 34 32 1A 00 C0 99 A1 A2 01 90 C4 69 89 80 1A 8C 34 1A 87'\r\n 'A8 31 18 8C 46 13 4D 30 07 A2 23 27 A6 88 F5 34 34 F4 1A 4C 8C 34 69 33 4D 44 36 50 0F 53 6A 68'\r\n '00 00 3C A7 A8 32 00 00 00 01 A0 00 01 A0 01 A0 00 00 00 00 00 00 00 00 00 00 00 00 00 00 40 D0'\r\n 'D0 0D 00 68 19 00 1A 03 40 03 08 00 00 C4 00 00 03 08 00 0D 00 0D 0D 01 A0 00 19 00 00 D0 01 A0'\r\n '0D 00 00 0D 04 0D 0D 00 D0 06 81 90 01 A0 34 00 30 80 00 0C 40 00 00 30 80 00 D0 00 D0 D0 1A 00'\r\n '01 90 00 0D 00 1A 00 D0 00 00 D0 1A 7A 88 89 A4 D3 53 D3 49 B4 13 26 A6 4C 8D 03 40 34 0D 00 68'\r\n '00 1A 00 00 00 00 1A 03 46 80 00 0D A8 00 00 D3 40 D0 00 00 00 0D 0C 83 26 9E 92 33 B9 9E F3 64'\r\n 'A9 96 38 D6 06 A6 FB 0E 20 91 67 27 8B 11 6E 52 95 13 B7 81 29 29 6A 9E 70 E2 81 3E 33 A7 09 38'\r\n 'F7 63 88 B3 94 35 B9 3C AC 3E 31 5B 20 0A 81 AD 2B CC B4 5A 42 14 61 CB 2F 4A A2 EF 16 2B 2B BB'\r\n 'DA 16 2D 17 53 B1 37 8A D1 71 64 D6 2C A4 CB BF 19 38 B0 6D 44 21 08 12 00 B7 62 1C 2A 55 2A 95'\r\n 'B5 66 8A 12 06 BE A6 21 E2 22 30 AE 5D 4A 56 EA A6 4E E9 C6 99 02 8A CE ED 7A EE 21 6B 2F 6B 22'\r\n 'E9 4E 9B 53 BC 05 3C 3C 6A F5 94 CA 29 4E F3 71 D5 13 92 99 66 B3 B4 19 52 E1 2B 52 13 61 09 2C'\r\n '90 D5 21 25 91 C4 74 18 77 22 1D DD 80 B0 F0 2B B5 82 AF 70 65 48 56 A5 46 62 49 E5 09 D5 74 2B'\r\n '48 50 F8 49 D5 81 58 56 15 D2 B0 AF 26 95 97 76 C4 C0 56 53 C9 DE 73 C0 87 24 80 87 7B DA 70 67'\r\n '39 0B 35 85 4A 94 E6 25 15 2A 9E 72 74 4E 51 21 3C 93 98 6E E0 A6 B1 2F E4 A8 15 54 D7 7B 90 AE'\r\n '84 51 66 FD D3 64 B1 D7 C7 89 96 32 F8 0B 63 CA 7D 9F 94 97 3C 25 57 CD A9 8A FD 15 BC 2B CD 9F'\r\n '35 99 E5 EC 57 3F 51 6D 5D 90 35 05 E0 80 00 E5 10 0B 01 4C 4C 22 44 91 D2 B5 01 22 D1 CB 2B 4B'\r\n '6A 4A AA F4 3C 87 03 91 C6 5E 5F 54 5F 7B 24 40 80 04 46 20 32 50 49 09 4C 6C 65 59 89 93 1E E4'\r\n '86 EC 74 F8 FA F0 FC 09 42 90 70 70 D0 B1 31 25 4E D1 0A C6 17 2E C7 47 81 23 23 24 0C A1 84 AC'\r\n 'E4 AC B4 0C 59 8E DF AD 3E 7D 4D 52 F5 DA 7F DB CB DB E2 D4 29 59 81 F1 FB FC D5 61 AB C5 FA AC'\r\n 'C3 C6 2D 40 EF EF F0 3E 46 30 70 70 81 52 A4 B8 8A D2 A6 F0 B4 9D 2B 63 64 51 45 14 51 44 13 6B'\r\n '6C 41 04 10 41 06 37 14 FC 61 E5 62 CA 33 60 B6 93 6D C2 6E C3 6E CB F7 F8 08 20 82 0C D0 31 E1'\r\n '86 1C DA 3B BA 68 98 A8 94 48 C2 21 B1 1C E6 7E 89 2B FC 50 A2 60 62 1E 17 55 09 89 C1 25 63 5D'\r\n 'F0 1D B0 4B CB DB 85 CD CD D4 D5 D8 4D 4C 5E 05 E8 16 5A 80 9E 04 81 3C 09 01 48 24 3E C7 C0 80'\r\n '0A 6E 63 E6 4F C6 4A 98 B4 D4 D6 BC 4A 53 7C 96 F8 B8 0F E7 34 91 F3 39 65 19 A2 9D 8A A9 4E 53'\r\n '78 78 C6 D0 AC FE BD 1A EE B8 A1 E5 5E AA D5 38 F7 57 4F 19 CD D0 25 12 9F 9D 9F 80 8A 84 6C E3'\r\n '81 D4 51 99 C4 C5 66 9B 88 71 7D 13 E1 CB 2A 30 C5 FA 2C 1F B3 F1 8E 4A 70 34 9D 6E 68 8E 9C DA'\r\n '09 B7 6C 40 B6 6B 84 9C FB F5 67 78 85 58 5C 47 04 E9 BD B1 6E E6 85 6F 5A 8F 21 3B C9 2E AD 1E'\r\n 'F8 95 BA D7 89 DE 14 86 E4 32 B5 A2 C8 C9 23 20 09 2B 64 64 67 75 D1 29 FD 0D 6C 21 13 79 25 19'\r\n '66 22 18 D9 F1 89 08 B0 BB 5A 51 FA 7A 88 15 EA CA 9A FF 19 95 39 2C 78 5A 34 94 BA 41 00 BF 9D'\r\n '07 A8 43 06 CC A6 00 4A A6 4C 8D 0D 99 69 A7 12 8C 34 AE 18 B8 A3 65 26 79 C0 F6 E3 5C B6 28 10'\r\n 'EC 39 32 7D 06 60 D2 5C D0 4B B9 FC 14 EF 92 FC C4 CD 7E 25 D1 E0 3A CD E1 9B 04 25 41 E6 7F 1A'\r\n '6F DB A1 D3 E9 27 1F CD 14 56 66 CB 09 92 AE C3 02 48 42 6C 90 97 E2 24 D0 30 33 00 26 10 C8 19'\r\n '03 02 34 AE 99 27 12 06 6C 11 27 18 13 36 D8 35 F0 C9 28 04 26 18 48 43 8E 03 20 64 C0 C8 18 61'\r\n '32 21 D9 BE 45 BC DF F1 D8 53 D3 79 33 1F 02 56 F3 DA 2B 83 E6 D4 DB 37 E9 2D 1E 8E 9D 17 3B AB'\r\n 'A7 D0 A2 A4 AF F3 89 D2 73 04 67 18 01 02 40 C0 01 9D 1C 01 00 80 19 81 03 20 48 19 30 33 24 0C'\r\n 'DA 8D 27 F9 A7 E1 35 1A 9F F7 55 D0 63 E3 F0 D9 ED 5D 7C 82 F0 F8 D7 66 6B 62 64 09 98 19 90 26'\r\n '64 B4 E8 4E 37 E9 A5 76 5F F8 BB 92 29 C2 84 84 D3 7B C0 B8'\r\n}\r\n\r\n\r\nLANGUAGE 0,0 NUMBERS UNICODEDATA LOADONCALL MOVEABLE DISCARDABLE\r\n{\r\n '42 5A 68 39 31 41 59 26 53 59 87 40 B2 8A 00 09 03 7F FF FF FF FF FF FF FF FF FF FF FF FF FF FF'\r\n 'FF FF FF FF FF FF FC 7F F8 7F FF FF E1 FF FF FF FF FF FF E0 0B 7B 7C 18 01 F3 0E F7 DC 79 00 03'\r\n 'EF 8F AE 62 B2 1E DB 77 D8 66 FA D7 BE F7 DB DF 4F 18 22 40 0C 21 E6 A4 F4 86 21 A1 A6 80 32 32'\r\n '34 C9 A6 26 D4 D3 09 A6 87 A8 F2 40 3D 26 8D A4 D1 88 C9 A6 9A 7E A9 B4 D3 13 4C 46 D3 52 7E A4'\r\n 'D3 35 30 4F 49 B1 4F 4D 11 8F 52 34 0D 00 31 E8 81 00 33 53 D4 C9 A6 40 05 4D 24 D4 C8 69 8C 4D'\r\n '1A 46 6A 1A 0C 3D 27 A7 A8 13 12 78 53 35 36 9A 69 A2 66 86 8D 10 D0 D1 A6 98 87 93 53 13 09 FA'\r\n '9A 86 80 C1 01 A1 B5 00 00 00 03 4D 34 00 07 A8 03 08 1A 34 D0 00 60 85 53 4D A3 48 D4 6C 9E 04'\r\n '46 F2 28 F5 14 F5 40 00 00 1A 03 4D 00 00 3D 40 00 01 A0 00 D0 00 00 68 06 47 A8 00 00 00 06 80'\r\n '00 00 00 1A 00 00 01 15 4F F5 19 0C A7 A1 3D 41 46 C3 52 03 D4 03 40 00 D0 00 00 D3 40 00 00 1A'\r\n '68 00 68 00 01 90 00 68 D0 00 00 00 00 07 A8 00 00 00 00 00 00 44 CD 22 9E 94 C8 8F 49 EA 9F A4'\r\n 'DA 9B 14 08 64 06 01 30 00 4C 4C 8C 98 86 81 80 00 09 80 11 89 A6 34 04 62 62 18 64 D4 C2 69 93'\r\n 'D4 18 83 4C 68 9A 62 69 80 13 13 23 43 26 04 61 18 09 4F 52 48 D0 8D 0D 2A 78 99 4F C5 27 B5 33'\r\n 'D4 D5 3C A3 4F D0 A6 F5 20 3F 54 C9 EA 69 F8 A8 34 19 06 8F 6A 83 D4 7A 9A 0D A9 A7 A2 7A 69 EA'\r\n '83 13 D4 FD 50 68 06 9B D5 00 34 D0 1A 34 03 20 62 00 00 0D A6 90 00 1A 03 61 35 1A 69 98 80 95'\r\n 'EC A6 B9 A3 C6 86 42 C1 60 96 4B 29 F1 EB CB 0D A9 ED CB 90 95 29 94 53 72 ED 40 22 DB D7 DF 83'\r\n '0E 53 16 7D 07 08 41 E8 6E C1 F1 20 42 89 12 45 71 B2 68 53 4E 27 42 90 21 48 04 48 90 A1 86 3E'\r\n 'ED 0E 10 05 DA 1E 1D D0 18 57 41 D1 87 04 07 4B 36 6A B2 C5 8A 49 62 AC 1A 16 12 C4 C8 A2 F2 B6'\r\n '64 A2 29 00 72 08 44 4F 7F 02 A6 20 32 52 22 9B 29 03 68 C0 73 6C 65 EF E4 F0 37 33 29 D5 3F CF'\r\n '59 85 64 D6 FD 7D 56 25 AB 29 91 D6 FD 1A 04 6C 7E 6C 81 B8 F9 D2 1C C2 07 87 63 39 0C F6 0D 06'\r\n '3C 42 76 09 D8 BD 93 10 67 77 52 40 6B B6 3F 32 90 06 D1 94 8C AC E9 D0 63 99 D9 55 D7 55 19 CE'\r\n '5B B7 CC BF CA 72 96 0C FC EA A9 E2 6A 90 C4 A4 98 49 B3 4C 4B DD 76 57 1F 6B 7A F5 EC 3B 98 98'\r\n 'B5 FC FA 88 23 2D 88 88 14 05 85 21 09 28 06 80 22 06 A0 14 BA 21 00 22 10 C6 31 81 A4 49 26 9B'\r\n '11 2D 57 48 B6 32 9C BA 22 51 03 95 2B AA 6D 2B 5A D0 34 19 A9 9A B5 62 0C 18 CD 86 86 B6 73 50'\r\n 'D4 A9 90 B4 26 3B 18 C6 35 B2 48 31 12 04 8B 62 29 CA D7 29 0E 52 DC 0D B8 C6 31 2E A4 CE 54 E4'\r\n '21 25 73 A9 73 A7 35 2E 4A 99 0B 86 63 B1 8C 63 9D 25 56 1B 1C 0A 6B A2 2A 0A E3 A9 CA 5B 81 B3'\r\n '5C 63 18 5A 23 6A 2D 10 96 5A D3 B1 AD 9E 46 35 2A 64 2D 09 D0 C6 31 8D 6C 83 60 48 A1 29 4A 72'\r\n 'CE 27 40 D4 34 25 29 4A A3 1B 74 90 84 B2 22 B0 09 8C B0 42 57 08 5D 98 EB 5A D6 01 20 58 02 28'\r\n '0A 52 9C B3 81 D0 17 42 84 A5 29 54 61 6E 9A D6 40 16 01 31 96 08 4A E1 0B B3 1D 6B 5A C0 24 0B'\r\n '01 0C 0A 08 A2 29 CB 38 35 09 1A 86 95 29 4A 5C 62 7C 7B 84 24 A2 2C 11 9C CC 14 A9 90 8D 53 A1'\r\n '8C 63 04 64 1B 02 45 09 4A 53 96 71 3A 06 E8 D0 94 A5 2A 8C 6D D3 58 96 40 16 01 31 96 08 4A E1'\r\n '0B B3 1D 6B 5A C0 24 0B 00 45 01 4A 53 96 70 3A 02 E8 50 94 A5 2A 8C 2D D3 5A 5A A2 B4 AA AA 40'\r\n '28 29 53 12 8A 2E 21 35 59 65 52 18 D5 63 C0 89 66 89 62 D3 67 63 CF 46 3A 74 69 E2 74 DC 89 2E'\r\n '99 86 52 5D 38 1A 65 68 92 E7 39 A4 11 03 90 94 00 23 AA A9 28 00 88 DE 44 85 2C E5 4E 3D B0 48'\r\n '84 AB 1C 8D D3 02 05 36 BD E8 E5 34 53 21 10 CC CD 55 55 55 B9 66 B0 A5 BA 55 49 A4 99 33 35 D4'\r\n '93 12 8A B8 33 34 99 AE 3C 63 2C 4B 23 12 CD 4A A8 AA AA 28 2A 44 AC 2A C2 12 C8 44 D9 61 81 56'\r\n '01 16 06 21 11 58 0A D0 06 B9 82 52 15 48 66 42 58 88 88 3E 0F 12 F7 BB DF F2 FC 9F 6E 5B C9 DA'\r\n '76 90 75 7B 3D D6 FB A2 DC E7 6F FA 3D 2A 53 8F 50 90 33 B4 14 27 2A D1 C1 3F 20 83 9E 9F 8F AD'\r\n 'AF C5 35 65 51 A3 2A A5 BC CA 9D 15 46 A2 82 A2 A6 B1 3E 35 13 6D 32 A2 ED A9 CA 6F 55 A7 9E 46'\r\n 'A0 FC D1 B8 A3 9C C4 6E 0A 42 9B 44 8D 22 6A 04 EA 27 91 4D 73 54 8A 9D 44 34 0B 93 E8 71 26 CB'\r\n '96 02 42 41 4C 8A 51 64 8D 9F B9 9C 44 BC 9E 56 5D EC BD EA 5A 5A FF 2B 80 C8 C1 87 29 29 4B 10'\r\n '07 97 49 B2 95 91 00 5C 41 33 83 AA B0 04 18 0B 15 18 14 32 20 5B BA DC 48 2E DD 92 E5 DC 0B B7'\r\n '6A A5 DC 00 B8 DA C0 68 90 5C 62 BA ED DB A5 2D DB 82 CD B6 DA 60 A1 22 B5 B3 6E DD 54 B5 6A 0B'\r\n '36 9A 98 2C 57 5C D7 5C 16 2B 6B 48 B1 5D 73 5D 70 59 B3 5B 2C 16 2B AE 6B AE 09 6C 16 58 8A AA'\r\n 'B3 66 BA C2 BA CB 13 0B 2E 0D BC 0A 44 49 88 81 84 F8 62 14 CB 60 81 0A 07 40 20 0F 7A B1 CA E0'\r\n '90 91 8F 46 B5 AF 81 20 7B 4D AD 42 00 05 36 42 6A 11 35 A8 C8 15 54 29 AA A8 55 55 CC 2C 26 B5'\r\n 'B0 34 A1 92 A1 A1 23 D0 92 0A 20 50 55 04 09 45 55 66 65 95 9A E9 44 86 06 14 86 14 52 05 04 41'\r\n '56 05 81 60 8E 93 79 4A 27 1E 49 84 2C 49 28 C2 20 C0 22 90 A0 B1 02 20 88 2A C0 B0 28 1F DB 27'\r\n 'DF BD 9F 07 63 CD 62 70 B8 59 5B BF 17 85 84 C2 23 90 C4 82 90 C2 20 82 29 0B 02 90 3A D9 89 41'\r\n '45 81 10 50 F3 3F 4F B0 EC 7B 2F A9 F5 7D 5F D6 F5 5E B7 07 05 04 57 DC C8 48 A4 30 C2 0C 22 90'\r\n 'B0 28 0E 44 92 82 AC 18 73 20 A0 2A 08 C7 4F 21 22 88 AC 20 82 29 0A A1 0D E9 25 05 58 2C 4C 82'\r\n 'C7 3D C3 DE 72 7B CE 27 A1 E2 F3 FD 3F 3B C6 F3 7D C6 EF 8F E7 36 BE CB 9D D5 EA D0 47 D7 48 4A'\r\n 'B0 A0 88 A4 29 10 E3 4C 4A 0A B0 6B A6 41 60 FD 9D 9F 07 B4 EA F8 5D AF E8 FD 3F 1B F5 67 DD BA'\r\n '82 3C C4 84 E7 CC C3 10 88 A4 2C 10 F7 99 25 05 58 31 66 41 60 77 1A 9A 9A 9D 4F 53 A9 D4 5A B6'\r\n '82 38 52 12 A3 10 88 A4 2C 11 8D 32 28 2A C1 76 64 16 36 1F EF 61 DB EC 3C 57 25 C3 F5 9D 6E EF'\r\n '89 E8 F8 BB EE 37 45 DC 6F F8 FB 7D BF 2B 99 99 99 8D 8C F8 5E 06 F7 7B C0 F6 9E A6 D5 A8 51 CF'\r\n '49 61 04 11 85 85 B6 C1 12 9B 64 89 56 16 0D 93 2C 5F BF 7E FD FB F7 EF DF BF 7E FD FB F7 EF E1'\r\n 'C3 83 0D 3D 27 8D B4 E4 E4 F3 5C 77 19 C9 F8 F9 67 5E AD 01 20 81 F0 56 F9 9E F7 BD EF 7B DE F7'\r\n 'BD EF 7B DE FB EF E4 32 79 C7 0E 2A E5 99 4A E2 F2 4E 22 EC 96 F4 E3 2C D6 F5 17 43 5A 46 AF 4C'\r\n '7E 38 20 42 10 04 60 80 46 44 23 4F 02 13 DB B8 84 6C D0 84 21 08 42 10 84 23 E2 80 5F 00 00 1D'\r\n '08 C7 5F DF 9F 0D 19 30 F4 F3 86 10 85 5D 62 88 CA B3 20 04 FC C5 85 16 DE 8F 5F 45 B6 A2 B0 A4'\r\n 'D7 5D 6E AA 95 7C AE F2 26 DA B5 6A D5 A3 43 C7 8F 28 4C 4E 30 92 49 24 92 48 22 21 3B 04 08 10'\r\n '30 89 C8 AB 90 48 04 A1 00 29 C5 14 51 67 55 10 30 C3 0D 4A AD 5A B2 07 1C 71 CC CC 99 00 14 0B'\r\n 'E4 AE 79 17 52 65 72 59 C9 B4 94 BB 95 BC AF BD BE EC 42 18 3D 0A 76 32 61 6B 35 B2 F1 92 CB 99'\r\n '46 CA 2F 5E D9 B4 94 93 66 8D A8 59 B3 66 CE 03 42 8C 03 71 82 09 71 C7 8F 08 41 3C 38 E3 04 20'\r\n '18 08 A0 B0 2C 1F 1E 63 9E 62 28 28 8A F0 72 75 FD E3 91 C8 C7 C7 C2 D1 F2 DE 5F 73 B9 DC E8 E8'\r\n 'E8 E8 E8 F9 8E B3 A5 D6 F9 A4 35 CA A8 94 7A CE 9B 99 A4 BB AE 4B 61 49 7A 1E 87 A5 DD EE B2 B0'\r\n 'AB 97 23 87 5F 13 D4 71 78 1C 6A 5F C2 9F CD 0C F5 0A 35 49 15 2A 9F 97 11 FB 3E E6 18 4B 9F EC'\r\n '6C 6C 6C 7A 43 AB 1C 5C 8E A3 4D 95 0C 23 EA 0F E2 28 8F 50 7D 43 05 36 54 3D AA 2B 25 56 43 5A'\r\n 'AB A2 3D 0B 06 E6 18 4D 10 DD A1 BC 43 7A 86 CD 0D F2 1F 0C ED FA 24 08 91 7A DF 40 8D 30 07 3D'\r\n '67 CF AB 80 95 A2 56 89 70 67 DA A6 FA 50 36 70 61 7E A5 44 64 61 90 08 10 81 08 10 81 08 10 81'\r\n '36 C2 43 88 6C 48 63 2A A2 4C 00 A8 E8 1B 02 C1 80 08 40 2A C7 6B 3D 1D 24 18 C6 D4 A4 14 8D F7'\r\n '2F CB 78 4C DD 3C DD 3C DD 3C DD 3C DD 3C DF 05 A7 A9 8A 6B 35 53 B5 D0 A4 51 04 10 82 04 20 45'\r\n '0B 21 8F 18 41 A7 C6 4C 32 61 CD 0E 68 D5 23 A5 23 A5 23 A4 01 19 B1 EB 87 63 A3 20 7D 0B CC 24'\r\n '1E CE 0B 65 03 01 B1 52 A1 C2 95 09 DC 6D 1C 58 B8 E2 AB 52 A5 24 42 70 D2 0E 38 00 11 92 B3 2C'\r\n '05 21 54 11 8B 84 3C 2D 25 31 72 EE A3 E0 CB 0C EA 58 3E 7E 53 BA 77 8A E7 94 EB 2B 62 62 3C 95'\r\n 'B1 4A 3E 15 AB 15 7C 6B A2 D5 DD 5E 2D 85 BB BD 5C 7B E9 7C BE 2A 92 FD 73 2A 1D E4 84 7D 2E 04'\r\n '9A 6F CD 31 C3 D2 F5 47 77 B3 15 31 C7 31 2A 61 CD 8B 6D 11 BF E8 DB 70 38 33 96 DC 48 D4 2C 37'\r\n '71 F3 AC 29 D8 D9 B5 4E 7E 20 E5 43 25 96 8D 7A 92 A8 38 53 35 73 03 58 12 4B 56 BF 5C 2A AE 84'\r\n '9C E7 C5 7D AD BF 7B 03 0B 0F ED 88 BD 32 69 BC 1B 3B 2B 4F 3F 90 76 43 0C 9E E2 82 E1 49 16 14'\r\n '2D AB EE 6E 16 AD 5B 5A DB A6 DA E9 72 E5 AD AD ED 0A 62 C5 8B 18 BA C6 2B D7 31 5E B5 86 AA 2A'\r\n '08 37 92 C0 9C 2C 18 75 25 CB 17 08 37 80 DB 8B 04 02 C2 ED C1 3A 97 04 30 81 7C AC 41 59 57 23'\r\n '57 55 C7 AA A8 55 50 B1 2A CA 64 94 D4 A8 E9 68 C6 A3 49 5C 95 1D 6A 4E 2B BE 80 27 EC F0 28 6C'\r\n 'D6 04 F0 53 D8 0C 43 66 AC 38 EF EA 87 F1 87 02 A2 B9 B8 15 11 E2 6C EF 15 76 1D 06 5C 10 36 1E'\r\n '85 BA 52 C0 D6 D3 25 2C 31 8D 04 DB 7A 63 0D 67 26 A6 1A 4E 40 D1 B6 7A 7A 18 10 78 FA EA CA FC'\r\n 'F4 2B AE 7C 27 4A 8C C3 C5 E2 16 3F C4 C0 2B 3A FF 9D D7 BA BE BB 6B 5D DF 36 FD 9C 6E 74 B4 B4'\r\n 'A4 A3 26 49 67 4E EF 0F 1E 8E 24 92 49 24 92 49 C5 C6 C3 C5 C5 58 85 ED EE 2E 1A 9C 56 E6 E9 CB'\r\n '45 D5 72 76 47 0C 83 66 07 A6 F4 26 79 B6 51 74 52 67 A5 31 0F 30 84 C5 36 1C 34 C8 9B 03 D1 88'\r\n '48 6E 32 14 14 3A FA 74 D7 2A B0 9A 1A 16 A8 61 BA CB D5 17 AA 9C 0A 8A AA C2 B9 60 AA AB 78 76'\r\n '0C 4A 8E 69 26 6C 4A 5B 26 4D DA A2 B2 96 56 5D 89 08 63 3B 12 11 AA D2 48 44 A5 85 5A 3A EA A5'\r\n 'B5 D5 63 20 D3 04 4B 6C 02 53 91 34 C8 A6 0A 29 B2 C7 14 02 99 77 C2 65 96 9B 9F 0E 8D 00 32 F6'\r\n 'E3 66 43 A3 C0 0C B5 0E 9F 0E A6 A8 32 9A 8D 3E 1D E7 28 32 D2 E6 91 B2 A4 03 2D 2E 6D 1B 3A 74'\r\n 'E9 12 DA A8 5A 28 33 81 64 32 9E 0C B3 E3 3A 1A 42 41 0E 5A 67 9A D9 D2 A5 27 2E 4D 08 7D 32 74'\r\n 'C7 93 27 DD 04 EF 15 C6 28 61 EA 03 BC 37 44 5D 4C D6 98 65 1F E1 41 40 DD 4C 5F 80 4B AB BE A4'\r\n 'A5 22 71 2B 62 70 C6 08 D8 A6 C5 3A 56 04 C9 25 A2 9C AC 01 93 4E 06 A4 AA EA 58 6A 71 35 69 53'\r\n 'DD DD 7F 50 F7 67 67 29 65 D5 37 60 CA 52 A6 A6 60 BE A2 D1 BD 05 A5 8A 9A B1 20 C3 6A 91 70 B0'\r\n 'E0 D7 B6 BA A2 CD 56 F9 BB D0 62 B8 1B E2 BA B3 31 60 D7 B7 71 26 57 2A CF 63 00 A2 E9 33 2B 95'\r\n '67 D1 80 E0 A1 59 95 8A F0 82 E4 6B 22 AC 08 25 5A 0C 36 5D 5F 15 60 C9 71 47 24 F2 B7 8C 6C 60'\r\n 'DE E0 A7 57 36 45 F5 B6 BE 98 18 A4 C0 F3 4B 44 59 6C 8C 11 3E 89 8D 9F B6 68 EF AB 1F 41 B8 19'\r\n '18 4C F4 CE E1 D3 6D 88 BB A7 CD 99 89 88 8E 9E 32 BA F3 13 C8 F4 A1 75 E0 44 8F 4A 26 AD 26 24'\r\n '17 CD 12 76 F6 90 C9 90 A3 8F 4E 61 BB 87 6B DE E3 45 59 75 86 D3 2F 0C 32 F9 02 D2 65 EB 83 C3'\r\n '6D 71 CF D6 98 FB 64 31 F6 D9 06 0A 6E 39 1C 80 D4 3F 84 14 67 F0 9F 95 F1 12 47 64 64 8D 1C 10'\r\n 'B2 AA 88 09 4C 07 5A 8A E8 23 97 59 01 1C 56 42 19 1A 08 4D 80 69 BC 03 4D E0 66 9C C4 DA BB 18'\r\n '05 C9 C5 BD C4 D5 43 D3 37 A6 6F 4C DE 99 BC 78 B3 2B 8C 2E 32 BB 72 B9 D9 D5 99 45 14 51 45 14'\r\n '51 4B 99 47 31 93 62 7C 83 04 19 20 D1 0F 64 1B 7D 7C 7D 7D 78 7D 24 E1 C4 65 B9 A5 14 51 45 14'\r\n '51 45 76 AD 2C EC BA FE 37 2E 5C B9 37 05 AF 57 C5 E4 62 AD 9D C5 77 29 56 1D CB 0B 6D 60 75 9B'\r\n 'D7 AF 5E 3C 97 B6 CB FB 6B F9 DA 4D 22 E8 99 8B 51 92 8C AC 24 94 99 D8 22 7A EA 45 10 C3 0A 25'\r\n 'D9 B4 94 94 94 74 74 74 7B 1D 87 CB AB CE 66 E7 F7 BB CF 01 85 26 7B C8 8E 45 2A FE D2 26 82 29'\r\n '7D AB 0D B4 8A 5F F2 BB 79 2C 84 6D AD BB 15 6C 2F 2E 26 D6 64 EF 66 D8 5A B1 BE CD 48 DB 4A DF'\r\n 'E6 E5 2D E5 F0 33 92 FD 59 9B 99 DC A5 C7 BA 6A E6 7B 30 8C 01 25 49 00 91 50 02 45 49 1A 8D 42'\r\n '42 40 D7 B3 98 E6 39 C8 72 1C 85 09 22 BA 55 45 C0 1D 30 C2 AA 00 1C CC 08 5C B5 6B C7 C8 72 D7'\r\n '2D 21 72 DD A4 34 AD E0 A1 A5 6A B4 39 FD 2B 78 68 7A 2D 2B 97 93 7A E9 2F 10 65 95 4A 5D B6 C9'\r\n 'AE 47 AE 8C A8 99 18 71 48 A1 A0 76 2D 30 DB 23 00 5D A3 2E 31 A2 F1 19 61 68 4E 88 42 D0 B5 9A'\r\n '65 F8 B6 27 DB F6 6D 35 6A 75 0B C8 F7 1E 2F C5 2F 9A 78 56 C8 B3 85 07 E5 70 93 F8 EC A4 58 B1'\r\n '62 C5 E5 99 A3 90 7F F1 77 24 53 85 09 08 74 0B 28 A0'\r\n}\r\n\r\n\r\nLANGUAGE 0,0 COMPOSITION UNICODEDATA LOADONCALL MOVEABLE DISCARDABLE\r\n{\r\n '42 5A 68 39 31 41 59 26 53 59 FD 20 B0 78 00 47 AF 7F FF FF FF FF FF FF FF FF FF FF FF FF FF FF'\r\n 'FF FF FF FF FF FF FF FF FF FF FF FF FF FF FF FF FF FF FF E0 48 B4 BD 00 00 00 00 00 00 0F B5 55'\r\n '05 F2 88 02 20 14 51 27 D0 1D EC 07 52 00 00 00 00 F2 32 A0 4D B4 D0 00 28 10 1F 0F 80 00 70 07'\r\n '74 EE 5E 3D F6 FA 0C 5B 01 A0 12 FB E7 BE 6C AE BE 00 05 00 1F 77 AA 1D 53 D0 4B AD AC EF 53 75'\r\n '7C 00 3E F7 70 D1 E7 1F 66 70 A7 BD 15 23 EF 79 BB 0D D8 27 C5 00 50 0A 3E DA 42 55 4D 0D 05 29'\r\n '63 61 54 80 A0 03 80 00 7D 0C E1 C6 E0 0D 00 03 22 49 A4 F4 53 D3 53 65 19 8C 93 53 C1 A3 4A 7F'\r\n 'A9 18 93 F4 13 C9 30 34 D1 4F DA 46 94 FD 4F 4C 26 26 26 A7 80 34 99 A6 08 60 98 01 31 18 43 0C'\r\n '99 46 68 D0 C8 C8 06 81 31 88 C1 34 C8 C9 93 18 24 60 0D 00 03 2A A8 45 30 41 34 C2 61 34 D0 D0'\r\n '00 D4 C0 04 64 C9 82 62 11 92 66 A6 98 A3 0D 13 D1 3D 53 F5 35 3F 4A 6D A6 82 68 69 18 41 84 C9'\r\n 'A7 A9 A3 07 A4 27 A9 8C 9E A4 C6 9A 9E A7 94 F3 48 34 D4 F5 00 1A 34 68 0D 1A 61 34 1F A9 A8 F4'\r\n '7A 81 A2 06 A7 A1 34 10 04 20 13 24 F5 30 4A 7E 98 94 FC A6 51 ED 4F 46 A4 FD 1A 8D A3 52 0F 51'\r\n 'E5 1E A7 A8 7A 27 A4 0D 34 68 03 41 A0 1A 00 07 A9 B5 00 D0 D1 A6 83 CA 34 06 9E 48 03 41 EA 34'\r\n 'F4 86 8C 80 32 69 EA 7A 80 F5 0F 46 A0 CC A0 24 22 48 10 09 18 4A 7B 23 46 A9 A7 A8 DA 8D 1E 88'\r\n 'F2 47 93 24 7A 8F 29 A7 A9 A1 EA 6D 26 9E A1 A3 4D 0D 1A 1E 8C 88 CD 32 69 8A 79 47 A9 EA 06 C4'\r\n '46 D3 22 3D 43 D4 64 F5 00 D3 D2 1E 9A 9E A1 E5 34 F1 21 E9 1E A7 94 01 EA 79 43 D4 69 E4 6A 32'\r\n '69 EA 3D 47 A4 06 9F A9 52 53 52 0D 03 D0 83 40 68 D0 0D 00 32 06 80 68 34 32 34 1A 68 00 68 0C'\r\n '4D 1A 0D 1A 06 8D 00 00 00 34 33 D4 81 90 D0 69 88 68 0D 00 01 88 69 A0 06 80 03 D1 36 A0 3F 54'\r\n '09 35 10 42 84 11 A6 84 CA 6D 26 4C A6 7A 88 FD 10 9E A3 C8 98 9B 51 90 CD 13 D4 D1 BD 50 D1 A6'\r\n '4D 3D 21 88 D3 20 68 0D 36 91 91 A6 D4 7A 81 A6 81 A0 34 0D 03 10 34 7A 80 0D 06 8C 8D 06 23 46'\r\n '8D 00 06 80 D0 34 38 5D B7 23 BB D1 B9 BD BF C8 EB 79 5C BE D7 D4 F7 5E AA F0 62 D7 1A AB 77 58'\r\n 'B9 CE FC 0E C8 DC 6E 6F DF EB 7B 7E C6 07 65 DC F2 BB AF 4F DE 2A AC C6 64 3B DA F6 7D 1F 57 73'\r\n 'B3 F5 F6 7E DF B5 EC FB 5F B9 0B 2E 7F 5F FE E4 64 56 E3 60 E1 5E E3 9E 91 F8 3E 09 3A 1A 0E 34'\r\n 'F7 03 E2 CC 3E 81 0E 6E 72 24 69 12 A6 CF 4F A0 A3 47 49 52 BD 35 9A 8B 97 B0 04 41 58 EA EB 32'\r\n '66 D1 AB 66 EE 1C BA 19 E3 D7 CF E0 41 87 12 2C 68 E4 6F F7 FB FD FE FB 7D AF D7 EB F5 FA F3 18'\r\n 'C6 31 8C 62 90 C6 37 A8 D1 CC E6 78 5F BB D6 F1 53 4B 95 CA EB B8 DC 9E 4F 2B 95 F1 9B 6A 1C 3F'\r\n '1F B4 ED 3C FE 9F DA F4 3D 28 74 B9 92 BA F1 73 FD C3 DB F4 CD FB 7E 99 38 58 92 62 33 33 00 91'\r\n 'C3 52 A0 B2 D2 04 0D 35 2A 54 84 C8 41 09 D7 65 A8 EA FC DE 62 49 26 9F 8B E5 B9 D4 EA 7D E8 E1'\r\n 'DC 1B CF 78 BE 35 28 1F 11 CF 01 E8 A4 69 A2 10 84 69 A3 1A CD 98 F1 FB B6 93 4D 34 DE 7B BB 95'\r\n '29 20 88 4A BF 15 5F 84 79 C1 18 05 F3 91 F1 F9 DC EF 8D 33 E1 FE 8A CB 88 42 10 84 F3 CF 3C C3'\r\n 'D1 E3 B3 1E 3C 18 30 C0 C7 B7 06 37 47 BA 67 D8 26 9A B0 22 45 B5 92 97 CF F6 39 B3 40 81 12 5F'\r\n 'B2 5E E5 CF 63 37 D9 79 3A 74 D6 D3 77 4D 8F 2A BF AD 98 95 69 93 28 55 AD A8 FD 30 1D 39 9F 27'\r\n 'A2 5A F5 C7 34 84 B0 B5 02 95 7A 04 22 74 60 37 16 2A 70 22 B8 DA EB AE BC 18 B0 A1 3C E1 A1 B9'\r\n '7E ED CB 71 BE 57 89 F2 FC 5D A4 92 6D C8 A9 28 48 8E 39 0E 1B 70 22 39 06 2C 10 89 75 D2 07 0A'\r\n 'D5 E7 4C 92 4B 2D 24 A5 82 BB E3 A0 97 B6 A5 0A 47 88 84 48 8B AE D8 02 94 94 F7 17 FE 5B 4D 48'\r\n '91 62 B4 A6 E5 60 6A 0B 58 35 75 5C 72 33 DB F1 2D 49 F7 11 7F 53 06 08 91 35 F5 B5 E6 08 41 34'\r\n 'E5 66 EC 4B 9C 52 99 4A B5 7B F2 83 67 CA 86 EE 6A 54 96 A5 4A 8A 53 E7 4E 9D 3A 10 2F 92 64 48'\r\n '46 05 0F F2 A3 10 8E 6A F5 41 E0 AE BB 8E 38 E2 6E 38 E3 8E 32 07 C2 1A 8F 3C 5B C6 07 49 3E 0B'\r\n 'C4 BD 60 E0 7C 94 65 24 4F 23 61 00 02 33 2A 51 3C 76 6D BD BF A6 D8 09 B4 4A 80 FC 9B 63 CE 7C'\r\n '42 1B 18 F3 B8 E1 31 0B 23 6D 93 60 57 61 0E BE 53 C9 4D 86 09 E4 32 FA 8F 90 84 21 08 42 10 84'\r\n '21 08 42 10 84 25 23 F7 1B 6C 92 0C 3C 6D A4 4F DE 30 DA 14 EE A9 32 57 69 A2 79 27 CB A9 C1 66'\r\n '02 12 F6 47 B2 D3 44 F2 8F F4 97 E4 1B 16 A4 E2 53 CA 3B CE BA 4D C3 C8 21 6B 9A 7C FB 97 66 60'\r\n '49 28 10 B3 C7 8C C9 4B 4B 3C 28 59 5C C5 0F 0E 96 DB BD A6 5C 48 95 AC 54 95 2B 8B C0 E0 55 C5'\r\n '6A 7C FA 15 A7 0F 14 15 D7 BE B9 EE D7 1D 17 F5 04 81 63 CB 7C 93 DF 7D F7 FC A3 E3 51 D4 26 E4'\r\n '4B 30 4C CA A4 21 6A 2F 4D CA 6D 53 A7 17 53 52 24 48 8E EE 37 98 22 27 9A 79 0F A3 45 07 5D AF'\r\n '22 85 04 11 9D 3E 82 9A A7 BD 14 B2 A9 62 4A D4 4A 0D 51 71 26 F4 CF 9F 5A 7B 99 B2 51 9B 3E 45'\r\n '8B 9A FA AE ED E8 DE DE DA DA DA DC 40 5B 88 A2 8A 28 A2 7B FA 98 6F 5F B1 6A A5 FB 57 2C 5F D7'\r\n 'D6 B9 C3 EB 70 E1 C3 83 2E 5E 1E 6C 50 15 60 9D 56 A8 F2 2C C6 B1 61 32 DE C5 E7 DF 9A FB EF BE'\r\n 'FB FA 99 72 64 62 64 D9 D7 70 64 A9 92 A9 66 E1 8F 7A A5 EA B2 61 15 F4 99 9C CE C8 1D 16 E2 06'\r\n '99 32 64 B9 72 E5 CB 41 04 26 22 8A 30 52 49 24 29 E3 84 D4 37 D7 72 33 57 04 21 D0 92 95 9D 49'\r\n '58 A2 C5 10 09 D1 C5 11 04 D8 C6 21 C3 9B 6E 64 35 AB D1 C6 83 17 2A 4F AB 43 1B 16 84 02 03 81'\r\n '81 B4 D0 C8 31 89 5C D5 EB C6 9D AF 2A D5 6B 1A F6 6A 5B B7 41 E3 66 91 7C 97 57 CB 10 23 08 51'\r\n '6C 10 40 12 C1 E7 8A 21 0B 3C F5 70 52 56 D4 A5 60 02 AA 80 C4 72 8A 10 04 15 2A 58 D9 A8 BD 0B'\r\n '34 BE 6E 75 D4 05 C4 A8 96 10 C2 1E B5 75 11 AF 62 3C CF 9C F9 F0 4E 54 4A AA 31 38 B2 93 66 CE'\r\n '25 B4 D2 39 31 26 98 C5 89 09 53 66 C8 81 A0 49 1C 98 93 4C 62 AC 9B D2 64 BD E6 69 83 00 E8 22'\r\n '83 04 62 E1 6F 70 AB AD 25 F9 92 3E 87 01 65 0E 51 51 AC 41 F5 29 D3 9C B5 99 F3 38 3B E9 5F 42'\r\n '64 E9 91 0B 26 64 C8 FA F9 5A 42 3A 55 A1 F9 8C 4B 39 06 E9 C4 6D 0C 74 10 95 0E 25 36 7E 87 0F'\r\n '89 BD 7E EA 71 9E 5A EC DB A7 C5 79 E4 10 69 DD 7D 8C 56 13 3E 42 0C 6D 97 3A D1 A3 CE 90 9B C6'\r\n 'C3 9B EE 26 84 14 5B 8D A9 17 71 34 A6 96 C0 59 CA 30 B6 21 12 E1 37 04 05 1E F1 03 43 B3 B2 C7'\r\n '55 40 8D 46 44 AC 9C 04 28 50 92 9C 49 93 65 F1 12 9B 5A 0B 12 F0 F9 BB E8 9A 9C 57 E8 C5 67 2E'\r\n '37 90 C7 77 80 A4 B9 02 10 98 10 00 C6 D3 77 4B 7B 61 54 92 9C 67 63 C9 92 E4 14 A4 C4 85 18 FB'\r\n '31 D0 BA 80 44 8B 46 8F 05 05 17 82 A4 00 97 11 D8 12 35 75 60 F0 52 06 A2 2A 8A 2F A2 80 43 A3'\r\n '12 12 C8 F0 11 D5 68 20 C0 A5 3D 40 67 88 DE B3 CF 72 2B AC 90 6F D5 6B 88 66 0F 6B 7E AC 89 1B'\r\n 'FB E9 4A C1 72 5C BC A7 D5 5C 90 55 35 18 BA 78 85 B5 B6 EC 0C 63 A8 8A 08 51 91 4E 7D 22 BE F3'\r\n '52 11 C7 AA 67 34 70 D6 4D 18 2A AB 0D AB B2 24 5F E1 46 51 CE 24 98 6B 49 93 B6 8E 7B D6 E6 17'\r\n '7B 10 C5 53 4B B2 E5 ED EF 4B DB 95 22 41 B8 8C EE 51 F3 8B 86 CB 41 45 D7 50 B9 27 55 C7 0D AB'\r\n '31 FD 57 1C F3 68 F0 DC 72 8F 5C CC 3B 41 04 EA 40 FD 67 CC 72 91 EB CF 81 4A 2C 5B 6F 55 90 6E'\r\n 'BB E0 25 0E 6B 4D E3 93 4C 92 BD 26 B0 40 12 2B 21 8A 9D DC 13 12 3E 2C 7A 97 48 CD 84 04 07 D9'\r\n '25 D5 A3 3E 57 64 09 67 9D 8D 8E DB 45 4A 25 6D 67 5D E1 43 04 27 40 10 85 15 61 80 10 98 F8 A3'\r\n '8F 67 79 2C B3 E0 5E C5 2F 7E 5C BE 4C 06 EB 0C 31 BC DE 58 86 B9 52 11 62 CE 9C 60 87 C2 95 2A'\r\n 'AA 50 71 02 90 4D 04 84 21 23 14 71 8C EA 21 C5 97 2C 8C A0 E7 5F C1 4A 45 C4 48 84 19 93 2A D5'\r\n '83 25 2C EB 4F 8F 1D A3 CC 18 7A C7 0D 2A 7A 1A 31 9B 87 16 01 F0 F7 B5 A3 4B 0E BA 8B AE AF 02'\r\n '60 F0 D3 FD FB 90 E5 3C F4 05 F0 BD 92 63 53 65 4A 4B 79 1C 42 4B AD B7 D6 4C 98 96 4D 64 76 74'\r\n '4B 96 85 55 72 49 48 BD 63 CF 22 B6 FC AB 89 6D 1F A8 F3 D4 B5 44 26 40 F1 1D 77 AF 6D 34 63 C7'\r\n 'C0 5E B2 34 68 6E 9B 79 6D A8 D1 96 2E 14 34 84 48 84 70 54 1A B0 FD C3 68 6F 83 84 B9 27 36 DD'\r\n '0D E3 D3 EA DA 68 B7 6B 34 4A 8B B1 2B 93 78 F9 31 DA 6A E9 A8 3C CB 36 CD 3F 1B 6D DB 35 DC ED'\r\n 'DC EB 35 71 B6 DE AC D3 D4 CA DB 75 ED 1F 9A BB 62 21 1E 66 5E 03 1A C6 36 9A 21 A1 5B 61 88 A6'\r\n '82 FA EF 15 1A EC 32 55 97 16 74 62 33 99 38 5A 6C E7 DE 61 8C 76 8D BC DB 79 1F 8F 79 57 17 B7'\r\n '13 75 B6 CF B4 37 E1 C3 25 99 0D 34 6A EA 6C 30 C1 F6 38 90 63 30 80 AB 9A 2E 46 59 42 5C 0D CC'\r\n '0D 53 8A FC 79 F0 D3 29 59 3C 84 A2 BA E5 57 65 65 99 AC 7D 45 C6 8C DA 0B 94 AA 8E 82 8A 10 9B'\r\n '43 1E A8 C7 B3 A0 84 D1 94 9A BA 2A 12 06 8C 55 0A AE 85 48 4D 16 88 45 20 92 5A 63 5F 38 E8 E7'\r\n '4C 94 36 53 25 BB 7B 3A 20 D6 3E E9 F8 96 A9 5C FB 73 B3 B2 5B 73 9F CE D9 AE 1B 65 BA B8 8B 39'\r\n '99 8B EA D7 D8 4B 2E B5 99 09 CC 69 1B 31 D8 D8 9A 64 8C 56 8A 52 94 D2 E4 47 CE 92 28 9E 92 08'\r\n '20 85 D8 BB 1B 16 95 59 9A F2 18 2D E7 59 D6 68 D1 21 6B 36 5C 6D 36 BD E7 0F C9 96 FD 12 D8 6B'\r\n '52 F6 BE 5A 74 D8 D7 F3 AE AF AF 56 7A CC 61 4D 5A 5A F2 73 19 4C 18 46 DE 1B 17 B0 42 20 61 83'\r\n 'B1 6A 16 19 F9 98 8F 28 B9 99 76 6D 6C CC E4 C6 06 93 8D 93 17 1E 56 0D 8A CC 8C 8C 5D 9E CC CC'\r\n '0D 62 65 F6 B1 E0 46 83 6D E0 AB 3E 96 46 F1 C4 B9 4D BC 5C 8B F3 72 B8 5B E9 65 6B 19 8A E3 EC'\r\n '6C 76 38 75 D9 C9 87 5B 23 2F EB 50 CB A9 0D FB F6 AB B7 4F 62 ED 44 E9 DB C1 AF A9 52 DD 76 69'\r\n 'C5 90 C6 6C 38 F2 EA 61 C8 BD 2F E0 75 D5 B2 B1 47 FE 5D 04 9D 6A 7F DB C8 9C 90 A3 0F 1C 0D 96'\r\n 'E6 FD BC BA 60 27 22 3C 06 E1 6A 50 A0 8A 28 A2 8A 28 A8 92 44 21 08 92 49 24 92 49 25 72 32 7D'\r\n '3D 94 B0 C6 5B 33 1A 22 B3 AF 98 DA 23 39 98 B5 ED C4 24 6D 2C 32 5D 30 A3 B2 5D 2B A6 4D 2A C8'\r\n '26 95 64 93 42 B2 09 11 48 D9 CB 99 58 F1 21 36 7E 58 51 A1 96 2E 36 67 C9 4F 13 56 E2 89 97 68'\r\n 'C2 75 44 35 DD 12 68 D6 B2 ED F5 53 72 F2 D0 5E 6F 57 0A 7E 2E 4A 4B 32 A1 9E 61 88 3C C8 D7 59'\r\n '83 F8 E4 DC 66 A3 7A 79 21 DE 08 E3 80 00 47 00 0F CB F8 D9 9F 9B 61 80 11 04 45 52 42 AA 95 06'\r\n '21 54 14 32 06 61 88 C8 40 26 22 44 54 B0 63 3F F6 4C 9A CA 48 5D 42 14 A4 82 49 18 40 64 91 84'\r\n '0F 79 92 4F C5 41 61 10 4C C3 21 31 18 61 84 44 30 C2 60 C0 03 DE 8F AE 67 34 52 14 52 AF 02 D4'\r\n '96 04 FC 2A 61 86 1F 92 4E 45 20 6B 2A 12 EA B3 68 CD 42 62 10 19 9A C9 2B 32 B1 FE 7D 6A 40 78'\r\n 'A2 52 22 C3 B6 49 3C DF CE 80 12 51 09 BF 91 8A 24 C4 40 44 11 9A AE 51 84 11 9A D9 25 B1 01 20'\r\n 'CA 97 09 09 98 68 DB A5 97 46 8C 5B 59 8A 4B 33 65 96 52 69 6D B4 65 58 8C B4 96 20 27 27 6E 06'\r\n '88 64 CA 21 99 6D 0C D9 B2 5D CA CB A5 32 A1 01 52 C5 5C AC 27 44 65 C4 34 8C 86 A5 D9 4B 05 A4'\r\n '20 8C 01 54 93 06 7E 2D E5 0B 69 F5 82 7E 5F EB BC C6 91 68 58 04 DC 73 0B B8 80 DB 69 18 B6 D4'\r\n '86 41 B0 70 D3 BE 75 45 11 AB 81 78 0C B1 6C 2D 38 A4 99 11 C8 5B EE 7B A3 5B 05 B0 CF DD 2C 55'\r\n '99 DA D6 D1 A5 60 1C 56 4A A5 CD 52 BC 73 65 AC 2F 78 C1 BC D2 A5 05 1B AB B2 C6 9D C1 C8 E8 91'\r\n 'B1 B7 25 54 75 21 6A 27 22 A1 C1 B2 D9 93 29 AA 6B 15 30 E3 2E 46 32 2B 0A 2E 5B AA 28 99 62 95'\r\n '06 24 61 77 6A AD 49 30 47 21 87 8A 23 43 2D 85 61 5A 75 2C 91 B1 B5 51 58 25 D5 2A 50 51 75 76'\r\n '58 D3 82 8A 5B 2A 9C E0 B2 C5 C5 62 CA 6E A8 D6 A5 C6 EA 60 68 53 1A 28 D2 61 0A 4B 1D 62 B4 DB'\r\n '2D 44 C9 91 27 91 F5 FE 06 17 AE DC DB 8C B1 41 45 34 D3 30 D0 88 DD D5 B2 8B 95 69 2A C5 AB 4A'\r\n 'BD 5E 10 B6 91 65 46 93 BA E8 ED A2 B0 8B 32 70 6A 67 BE 5D 67 48 51 CF 0D 0D 51 C7 75 0F 7A 51'\r\n '65 94 14 EC EE 90 82 0C 44 3E 82 10 FA 02 20 29 20 79 69 2A 23 11 28 95 23 4C A2 05 04 8C 0A 64'\r\n '16 47 D5 08 16 CB 20 50 C5 88 C1 63 06 2A 31 51 92 4A 49 05 91 B9 E8 49 3D 54 82 49 3B 8C 72 79'\r\n 'FE C4 0C B0 82 92 13 1A B5 6E DE 73 7E CA 29 9B 8A 4B AC 69 28 DC DD C7 A7 56 BC 24 85 D5 51 24'\r\n '24 85 55 51 24 24 84 90 F5 76 6E 19 B6 23 24 5E FD 95 6C DF 57 73 BA 57 4C 6A 0A 0F 22 15 9A AF'\r\n '6D 6C B3 7E F6 9A A7 1E 43 4B 6E DA 50 35 01 A1 35 22 02 00 88 C3 C8 62 24 B6 D8 89 40 C2 84 0A'\r\n '89 02 D8 89 29 22 0C 2E 49 80 14 14 91 10 46 22 03 23 20 A0 19 64 A4 18 D3 27 9D 75 20 C8 79 A8'\r\n '06 04 08 8A 43 CC 09 0F 32 1D C5 D4 2E 01 3C B8 C0 98 B0 44 60 92 A5 CB B8 88 C2 BC 41 E3 62 80'\r\n 'B0 21 E4 70 AC 8A 4B 81 3C 60 B0 60 91 60 88 88 45 61 3C BF 1B 57 A2 AA 8A AA 14 51 45 14 51 45'\r\n '92 61 1F 2C F0 9B 80 F4 54 F5 A7 53 BC 9E 4F 8E BC 68 61 3C 62 78 82 05 94 43 D4 22 94 31 0A A2'\r\n '96 55 12 36 03 68 E1 80 DB DA 00 35 A2 4B 6D 23 6B 6E CC C6 7D CD 89 B1 70 6C D8 1D 0C 3A EC 84'\r\n 'A3 BF 82 8D BB 65 A6 C4 A4 3B C8 14 21 55 05 5A 94 25 50 6B 70 9C 64 F9 7D 14 72 F2 96 9C 89 4C'\r\n '90 41 46 10 76 6E CE 30 57 93 C5 70 E2 3C 0D 0A 24 47 A4 04 4A 16 50 D9 21 08 11 A8 30 64 91 34'\r\n 'C0 90 86 D6 9E 06 0C 69 D1 34 30 0C 3C 8D 03 22 22 03 0C D1 47 77 C7 D6 86 18 74 34 30 38 69 32'\r\n 'E5 96 E4 68 61 D8 21 DE E6 B0 D6 EB 69 8D 95 43 21 3B 90 35 75 13 CE A3 87 AC 14 9C D7 29 7C 95'\r\n '53 84 AC B9 42 F2 55 44 D5 15 87 86 AB 04 83 05 A4 64 58 98 E5 A2 BC 89 33 90 83 C9 E5 D2 45 6F'\r\n 'E9 33 11 77 5C 09 1F 0B 28 25 A6 1C 75 6A 7A 98 5B F5 BA 4E 3E AC DE 43 73 72 CA F4 8F 43 54 FD'\r\n '1E 83 17 88 41 64 05 90 16 48 8F 72 56 9C 32 DA F5 DA 2C C1 20 A1 05 20 2C 05 84 CD 65 96 F9 BA'\r\n 'D1 7E CB 27 11 2C 0E 7E 2A B8 EB B4 C6 8D AD E6 A5 79 1C 03 DB E3 88 5A 60 31 05 71 34 30 53 FC'\r\n 'F3 98 50 C2 44 49 64 60 A6 9B D9 9C 64 D8 26 EF 0C B7 BB 46 2F 04 CD 5A 58 FC 4E 4A 2C DA 56 9D'\r\n '7E 6E A6 1E DD 95 62 04 47 4E 99 6F 93 92 AE 39 72 CB 7C 9C 95 71 CB 9B A5 E3 25 16 73 5E 9B A6'\r\n '61 F3 74 51 63 F1 F9 A0 B7 B3 25 5C 0A 06 56 5C B2 DE CE FE 8B 0C 47 DB 3A 65 BF A0 D6 8B C5 25'\r\n '79 0E 99 6F DF 75 A2 F0 C2 41 54 44 3B C1 76 56 F1 BC 50 BF 6B BD 96 0E 0A 3C 7F 19 5B 4C 0F 6E'\r\n 'F6 58 3D 64 BA EA B6 CC 3F 89 DE CB C2 15 EC 2C B7 75 B6 5B ED 77 B2 F0 C8 4E 6C A4 A4 51 64 B3'\r\n 'DE 31 B6 5B EF 1B D1 78 18 4A DD 97 B7 68 5B E9 ED 9B 64 D2 6E 52 48 00 00 00 08 74 D1 D0 D5 10'\r\n '43 17 62 21 89 C1 3B 23 52 63 BC 76 08 13 65 CC FA BF 4B 8F 09 76 26 ED 11 58 08 34 24 99 38 0E'\r\n '38 1D 07 04 10 89 EA 19 6F 4E 46 C3 DC 56 59 65 67 26 30 79 E9 EB 09 BC 6D 98 7F C9 B2 A4 2C A8'\r\n '42 90 84 68 75 AA D0 CC 3F 3D A2 AC 42 71 60 10 B9 7B DD 6D 98 79 D1 76 00 22 51 24 3D 2A B3 73'\r\n '77 B6 61 EF EC A2 59 49 46 BA AD 33 1E F3 A2 C8 16 24 EC 89 4E F7 5B 66 1F B6 D9 52 7B 34 81 86'\r\n '01 72 4F BF D1 6E FD 5D 70 CC 3D 9B 38 B2 2C 03 16 4F BD 7D EE CC 93 9E 77 CB 32 F9 5C 9B B0 44'\r\n '82 C3 0F 7B 11 F8 7B C1 9A ED E6 B9 4C 8F C9 F2 54 36 30 3B CE 4B AF 65 C5 70 86 5F 23 82 A1 B1'\r\n '04 43 B6 7C 0C 85 68 C4 F7 CE BA CF 5A A3 49 E2 D8 12 02 80 C2 11 B0 22 05 AD 69 57 43 07 3C 3A'\r\n '04 80 99 84 1A 88 81 69 4A 47 96 69 F6 BC 95 0E 10 44 5E D0 11 91 64 3E 10 18 28 A7 60 2C 85 9D'\r\n '6E 36 C6 D3 07 3C CB 42 00 2D 30 0C 54 A0 33 9C D6 71 40 4F 22 41 96 16 03 11 39 CD 9C 88 9E B6'\r\n '61 98 68 22 33 92 44 C1 8B 85 4A 36 98 22 A8 25 25 26 73 0C BB 2E 8D 33 1C 21 BD E3 4C C3 B2 EB'\r\n '78 7E 27 CC 2B 06 27 99 C5 ED F7 A6 65 E7 14 1B 4C 1B DD E5 30 EA E8 EC 71 3D 7E AF 2C C3 5A 6B'\r\n '83 00 C4 15 51 60 89 41 49 BA 9E 2F 5F C6 76 E5 16 B8 6B 81 50 C0 11 42 15 54 6B 57 97 0A D6 9A'\r\n 'D4 5C 34 55 06 38 C6 0C 6F 78 DB 32 D6 DA D0 A2 89 8C 12 17 45 84 1D 6B D1 DE 66 5A DB 5B 30 08'\r\n '88 0A A5 22 54 21 16 43 12 01 0B A2 EB 7B F3 77 93 4D 6E B6 CC 2D 92 E7 37 8E 31 C5 6F 13 2D 6E'\r\n 'B5 23 8A B8 41 0B B4 73 AF 3F 79 32 D6 E8 D9 15 86 1B B4 F0 17 81 31 D9 C6 F0 65 AD D1 A9 30 C9'\r\n '4A 11 B2 49 2A C4 7C ED 6B 06 1C D5 69 85 C2 4A 40 27 C1 D6 0D EF 7B 98 77 55 A0 55 BA 4F 17 93'\r\n '8C 9E C3 77 C5 71 32 F1 55 92 92 91 A4 ED E3 18 3D 8E F8 77 30 F1 55 A8 C2 AA A5 15 A7 5A CC CB'\r\n 'A4 CC 8B F0 6D 7F 5B DE FD 76 F1 B5 AE B9 E9 CC C3 94 E4 B0 58 A2 2A 91 82 AB 54 DA B5 AC 6B 59'\r\n '9E 37 D5 71 46 84 0E 06 D5 A1 E3 7C 5D 33 1E 76 A5 CB 1A 01 7D 75 97 BE 38 F7 FE 72 6B D0 E6 63'\r\n '1B 86 52 97 BD 9A 30 3C EB 9E 6B 13 3A 94 57 11 71 55 2C AC 42 E8 BF 5B 7B DE CC CD 6E 56 A0 A3'\r\n '28 09 3E F9 58 78 D7 1C 56 26 4D CA 38 96 A8 83 23 04 29 19 70 E2 B0 EB 3B F3 B8 C9 AE 25 56 8A'\r\n '85 32 35 E5 79 B8 C0 FB 6D F3 CD 62 67 99 47 24 42 D1 39 F2 EE CF 7A AF 61 AE BA E8 CC DF 52 8D'\r\n '0C B5 77 9D EF 01 9D CE 2F 88 0E 3B C9 5C E3 8E 3C FC CD 73 28 D0 2A A5 D3 5B EB 8E 38 CC D7 12'\r\n '8A 51 DF 1B DE F3 35 B9 45 1C B5 C7 3C 5E DC CD CA 2A 0E B9 D5 E9 86 75 37 76 0E EF 57 A6 67 53'\r\n '37 60 9E 9F 1B BD B3 3B 95 F4 36 15 37 C6 CD E7 23 B9 5F 39 C9 80 62 0A A8 B0 4B A1 24 AD 42 46'\r\n '55 BE 9D 60 DE 33 37 2B 8D 14 A6 14 57 78 D9 BC 4C EE 56 77 4C C3 41 4A 27 A3 B3 7F 07 89 9E 25'\r\n '71 C1 42 28 98 45 A7 8A E0 E3 13 3B 8E F4 50 22 20 2A 98 4A F3 F7 82 DC 3C 6B 27 83 13 5C 47 37'\r\n 'B6 5C 4D DE CD E0 33 B9 5B D4 95 30 83 13 78 D9 BC 4C EE 67 64 C2 60 28 DD EC DE 26 77 2B 7A 94'\r\n '8B 86 4A 58 4A D4 65 78 FD 9E B2 71 99 AE 25 67 82 89 81 5E 38 E0 E3 13 3C 4A E3 80 A7 D4 E7 B3'\r\n '14 F5 D7 47 58 86 7A 95 D3 D1 84 A4 42 98 31 E3 8E 0E 31 33 C4 E3 8C 2A C8 74 E5 0A AE 92 DE BA'\r\n 'E8 EB 30 CF 53 AE A4 C2 2B 8D 02 51 C7 B7 C7 9F CE 66 B9 9C F2 58 2C 51 31 54 A4 60 AA D4 2A 27'\r\n '3E 1E B2 74 73 A9 DD D4 EB 46 3A C1 12 87 AE 75 C9 CF DC 6E 6F 88 EA CA F8 51 A1 E7 DF F3 C9 90'\r\n 'CE C3 1D 98 10 C2 52 D4 6B 7B A3 66 03 3B 0D D6 41 56 63 B4 41 B6 A8 6F 8E 35 C1 90 D7 13 17 B2'\r\n '28 98 AC 43 36 60 53 DF 35 82 C3 19 0C 6A 5A A2 0C 8C 18 5B 1C 97 28 6C CA CC 8A 0B C2 CB 05 AB'\r\n '36 CC 42 8B 67 51 96 62 83 19 05 E4 95 D9 7A D2 8B 7F 3F 96 62 83 19 82 F2 2D 5D B5 06 FA 8B 32'\r\n '28 31 90 D6 48 62 71 9A 17 FB F9 D9 70 C6 C3 1B 98 16 28 A1 88 94 EB 1A 2F 28 E8 31 47 7F 1B 77'\r\n '46 CF 4B 13 5C 07 15 68 E9 37 8D 9E C7 01 AD 86 6A E6 D3 EC B1 B3 CE C4 D6 C3 34 5C D6 8F 2B 18'\r\n '1D 06 AE D9 AD 79 D7 85 D0 0F 78 66 24 CA 51 50 19 E1 9B 33 12 5D FC DA 80 D2 01 E4 A3 5A E7 A5'\r\n '28 ED 03 40 28 82 73 8F 63 3E C9 40 79 81 35 50 49 77 A2 80 CE 03 A4 14 97 7E 82 80 CE 1A A9 7C'\r\n 'BB DF 16 19 D8 6E A5 ED FB 3D F3 66 57 61 BA 96 BA D7 16 18 D0 1D 20 A0 97 7E 42 C4 C3 5A 40 2E'\r\n 'F4 E2 48 9B 4F 36 11 26 40 45 56 69 29 7A 05 02 3B 0D D4 B3 5A FB BD E5 F2 D9 AD 86 28 B3 ED 77'\r\n 'D9 61 8D 06 AA 59 AD 7C 45 86 34 1A A9 7F E3 F1 54 B3 21 9A 97 E4 BA F3 6B 08 BA 9A D0 7B 5C AA'\r\n '95 54 AA 50 99 A7 7E AE 83 1B 9B D1 66 28 7E 2B C7 DF B0 CE C3 74 59 AD 71 61 8D 06 BD 7D 9C 99'\r\n 'E3 3C 7C 16 21 AE 03 3B 2C 51 4C 1F 6D DF F4 AC 31 B0 DD 16 7E 07 A6 82 F2 19 E4 F0 61 54 AA A5'\r\n '52 84 C9 AD F7 AF 08 F0 1C 51 66 B5 ED 2C 31 A0 D7 10 B1 62 FB 3A A3 27 19 20 4A 40 0F 4B AB 32'\r\n 'BC 06 7F 17 8C 3D 69 99 8C 20 21 6D 14 07 98 11 A8 50 DD 13 E7 9E 7D 53 00 EC 04 D5 48 75 7F 72'\r\n 'C0 45 C0 8D 15 A4 B3 F3 AD 08 C8 09 20 5F 72 BE 7F 8A C0 45 C0 8D 02 82 41 05 B9 F3 8D DC 28 86'\r\n '59 C3 15 4D 8F 9A F1 A1 46 03 85 35 6F 5C 31 9B 39 B3 41 79 C3 3E 6A 1D EE 66 5E FB 79 53 61 BD'\r\n 'D9 8D EF BF 73 1B 0D EE CC 7A DD C9 DF B3 E1 F3 C0 71 C4 97 18 91 9C 91 4B 23 80 EA A1 9D 5D 60'\r\n 'CE 03 F3 D4 34 A9 D3 50 D2 02 49 42 19 0F F8 6A 6B 4D 06 B4 7A AC 2A 95 54 AA 56 55 A1 AD F3 C5'\r\n 'CC FD E3 90 E7 18 ED 4A FF 5F E0 EA 59 A0 D5 3D 94 38 D5 74 1B C4 C9 B0 DD 69 98 DE FE 1A E6 0D'\r\n '86 EB 6A BC D5 98 DA B3 06 60 CD 32 67 01 E3 C6 CF C1 A2 D6 70 CF 16 76 AF 36 62 D8 1B 36 B2 6C'\r\n '37 53 49 8D EF D0 B9 83 61 BD DA B3 C8 A5 52 AA 95 4A 58 99 E2 F8 B0 C1 B0 DD 9E 76 B2 37 BD D0'\r\n '60 DC DD 9B DE 46 F7 5B 2C 30 6E 6E B2 23 8D 6A A1 83 53 55 A8 8A 3E 3A AC F9 F5 41 66 A6 B0 59'\r\n '8C EE 82 CD 4D 59 A7 14 BD 52 A9 55 4A A5 29 86 8C 6E F6 17 31 37 35 57 E4 D1 5B D5 05 9A 9A BD'\r\n '86 05 8A 0C 4A FF 6E 8C 21 71 48 4C 1A 9A BC E2 8D 6A A5 9A 9A BB 73 AD 16 7B 04 C9 B9 BB D6 0A'\r\n 'FF 76 EA 59 A9 AB D6 0A D6 B1 61 83 53 56 7C 67 A4 64 BE 38 A0 B3 73 7C 16 28 8C C7 FB EF 52 C3'\r\n '06 A5 3F 15 65 EB 3F 03 8C 09 A8 EC 54 BD 68 C3 AC E4 4D 44 76 51 7B D6 AE 60 D4 E2 A5 EB 40 6A'\r\n 'E6 3C FD CD DE 11 FF 86 FA 4E 30 64 DC DD 5E 82 A2 C5 88 D7 DC 6F 77 30 6E 6F 66 2C A9 84 4B DD'\r\n 'EB 18 13 33 55 76 66 76 60 C6 F8 E2 C3 06 E7 16 51 BC 17 BD C0 E1 84 E3 13 26 C6 9C AF 93 4A A5'\r\n '55 2A 94 A3 7B DE EE 60 D8 D3 DE E7 E2 CB 31 C7 1C 5C C1 C1 D9 56 F8 3A EA F1 CF 33 9B 98 39 39'\r\n 'B2 EF 9E 6C C7 08 56 4D 51 2F 1C 54 32 67 24 BF 89 CD 05 B9 33 67 60 CC 6B 5D AA D8 61 D9 BB 95'\r\n '13 2E B4 6A 5B 92 85 2E C8 14 EC 71 62 88 4A C6 28 65 2B 78 32 A0 8E B2 C1 15 3B 59 B2 D3 55 AD'\r\n '15 31 F0 9B 9B B3 0E F0 77 4B C7 19 E1 4B 98 75 37 65 A6 D2 B2 32 9C CC DD BD BD A5 17 A1 6A 97'\r\n '53 5C 60 53 14 66 54 B7 31 A3 02 89 58 19 4E 25 07 62 5E 06 53 89 AB 85 E8 CC A2 D5 CC CD 87 C3'\r\n '6F D4 5E B6 25 0E E6 EE 6B 54 67 42 A5 3A 94 65 2F 05 50 B8 94 61 2F 15 42 E2 71 6B 2F 12 7A FA'\r\n '2D CC 68 58 E0 65 37 1A 14 1B 65 37 1A 23 6C 2B BD 89 46 99 8C B2 9C 46 81 B1 90 0A 69 3B 28 25'\r\n 'B5 1D AC A8 DB 65 E0 6A 3C 27 32 64 B6 A3 B5 15 B2 AC 06 A6 6C 28 95 5A 4C 23 A5 C5 52 2D 02 B5'\r\n '1D A9 1A 28 8A 3A 57 42 B4 8B 51 DA E6 AB 89 66 30 A3 C2 C5 67 63 C1 85 4F 0A 05 DD AA 76 10 8D'\r\n '5D D2 A7 60 E3 63 77 74 A9 D8 45 1E E5 82 54 14 EC 24 61 44 53 45 84 A6 AE 29 76 11 5D A9 76 10'\r\n 'B2 E3 6E 83 29 4A C8 A3 B0 64 54 45 1D 04 54 52 8E 82 47 51 6E DD 85 C3 95 98 00 29 47 61 23 CA'\r\n 'E9 53 B1 CA 22 8E 89 29 A8 E8 FA 09 8E EF CD D7 FE 2B FD 1F F9 60 10 9A DA A6 99 74 76 5E 1F 43'\r\n '9D 39 CF 94 D8 A5 EB 4D 1E EC CC 78 0A 09 DF AE AF AC FA 2A 93 0B 8D C3 98 E1 D5 CC 14 E7 55 CC'\r\n 'CB D4 F0 FB 3B 74 D7 BC B9 7E 07 77 99 2B D6 FB 77 09 F7 73 5B CD E7 E1 2C C7 57 5A 79 91 EE 35'\r\n '37 00 FD DF 0A 7E E2 9E 2D 65 85 7A 0B 0B D3 86 B1 AE EE 8B 19 9D 9D D2 79 9B 63 D8 A3 9D ED 5B'\r\n 'D8 CC D9 5B D2 5B F7 8A 2A C2 B4 AC B4 B4 B4 36 81 0D C2 53 26 12 DD 67 67 5D AE 5D 91 A9 A8 94'\r\n 'EA EC B5 DE 3D 28 E9 D4 AC 8E C1 7A D1 F2 96 2F 6E 10 42 08 93 21 5A 84 AA B2 A1 1C FE 20 7E F2'\r\n '60 13 26 01 32 64 89 00 4C 98 04 89 12 26 4C 02 53 70 EC 7A 54 4A 48 8B 2C 2C A5 96 A5 20 45 20'\r\n 'A8 C5 A4 AB 2C 2C 11 0B 0B 45 C5 2A 55 97 0A CA B2 A5 2C B4 96 E4 51 65 84 54 52 C1 44 B2 D9 72'\r\n 'DB 12 C5 59 4B 81 0B 2D B7 2D 16 D4 B5 6D 88 42 CB 16 58 2D 25 32 E5 8B 2C 62 5B 8B 0B 16 D8 22'\r\n 'DB 65 59 40 B6 AD 4B 71 95 68 95 20 85 80 4B 97 12 D5 A8 4B 65 5B 2A CB 96 29 4B 88 31 4A B2 5B'\r\n '10 82 2C 63 2C 4A 55 10 8A 96 DB 52 C2 DA B5 51 65 4A 4B 65 02 92 85 32 59 72 90 AB 2D AC 51 2D'\r\n 'B6 AC B6 25 B1 2C B6 11 2D 4B 17 22 58 4B 2D A9 68 8A 96 2E 54 5C 8A 2D A8 5C 54 45 B6 8A B6 AE'\r\n '99 60 88 24 42 30 31 10 C1 10 86 22 01 88 21 0C 44 8C 10 C0 11 91 11 12 22 10 82 09 01 13 11 21'\r\n '21 24 46 43 11 92 18 4C 21 21 92 00 8C 05 82 C5 82 C1 18 29 14 52 7C D1 0F 44 F4 48 08 A0 2A 8A'\r\n '45 14 58 84 37 2E 48 02 C8 B0 58 45 00 55 21 14 44 82 8B 02 0A 0A 40 58 11 64 16 44 60 2C 24 82'\r\n 'AC 92 0B 20 2C 58 41 60 0A 0A B2 0A 00 28 48 2C 24 80 B2 00 29 21 14 21 05 84 91 05 58 7F 0E 60'\r\n 'A4 98 95 52 0C C4 10 20 15 62 C8 90 95 09 24 97 04 90 50 05 08 45 92 11 40 21 23 08 03 24 09 0F'\r\n 'DF E6 EE 22 C3 F2 58 FE 05 C8 61 82 92 10 9F C1 61 2B E6 E8 80 06 D8 40 90 50 80 A4 91 60 92 6C'\r\n '40 0D 34 24 8A 6D 30 18 B8 5F F9 CB 7C 4E 33 E2 79 DE 23 91 F0 FF BF C7 F2 FF CF C3 D9 ED FD F1'\r\n 'E3 47 7D 1F 4A E7 64 7B 64 7B 0B 0C F1 EF BB DD F5 E9 A9 76 7D 79 CA 5A 5E BC 8D 2E 45 35 1D 25'\r\n '35 37 E3 B8 DC 7D DF 63 3D D6 06 06 0D 1E E6 93 DF 00 00 3F E1 82 48 EA 5A 03 B4 62 11 FB AC E8'\r\n '58 9B 4B D7 B1 02 EF D8 09 74 0C 01 2F 15 A1 24 BA 36 80 E3 8E 97 B4 A4 7B A6 FA 39 D1 77 90 0C'\r\n 'DD 9F 71 D2 5F C1 62 FC D7 FF 4C F7 5C 3D E1 F5 EF 9C E2 2C 93 5D C4 39 A4 D7 E6 AF 18 99 C6 6D'\r\n '2E 67 32 C9 39 97 3C E6 3C 75 CC 99 9F B7 D5 7B F5 87 D9 21 24 84 F5 23 05 22 C5 91 48 8A 80 45'\r\n '50 16 49 14 88 8A 0B 05 05 05 82 82 82 82 92 66 77 1D F3 BC DD F7 54 D9 62 32 6A AD F6 CD 64 C9'\r\n 'BD 6A DE 37 CE FD 2D 04 00 49 3E 8F E3 BE 95 58 C4 22 03 6A 5F C5 F6 BF C9 D7 C9 FF B7 DE 51 98'\r\n '9E F5 0A 27 C8 27 A2 F7 65 F2 90 CB FF 7D 3D 58 38 F8 51 52 34 ED 78 1E C7 0D 9D 9B 29 B3 12 AB'\r\n 'B0 E1 54 92 70 44 24 92 49 27 2C AE 66 D6 A0 55 13 08 84 BA 26 C2 24 91 33 D6 2A B5 D4 36 75 3E'\r\n 'E1 F4 0B 3D 9D A5 11 07 6E CD A1 B7 5F 2F C9 D8 6B E4 09 F9 8A 6D 8B 5D 9C CB 35 3B 37 39 DA D9'\r\n 'EC E5 C4 13 6B B5 7F B5 A4 3D 49 48 13 78 D1 F2 2C BC 1A 96 78 FD 79 7F 44 02 50 AE 76 3F 1F E0'\r\n 'DA FD 54 92 B6 14 C0 40 15 00 2A C0 FD 3E 96 CE D0 04 20 C6 02 0C 38 52 C0 2C 02 0D 71 5E F6 A0'\r\n '38 0A F3 BE DA CB 1A 3F F9 AB B0 18 E3 90 C7 2C 72 6A D6 BD 21 70 88 F9 D2 FF 32 3D 23 BD 95 24'\r\n 'DA 50 5B DA 03 AE 1E BE 4D 2B 89 38 90 E2 46 C7 59 73 75 B9 5C D5 55 79 5B EC DB F4 EF C8 3C AC'\r\n '5E 1E 3C AB CF B9 D0 E3 CA C6 2E F6 FB 2A 6D AE FA AA FE 01 9E FA 29 5E E7 B9 E0 6E EB F0 B8 5C'\r\n '8E E3 B8 EE 3B 9E 1C A5 29 4A 56 DB 6D B6 D6 B5 AD 6B 6D B2 94 A5 29 5B 6D B6 93 4A 52 94 A5 5D'\r\n 'DD DD ED 77 77 77 B6 72 94 A5 29 6E 65 DC F8 1B 9A D9 E7 9E 78 61 86 18 61 9E 79 F1 69 4A 52 94'\r\n 'BA EB AE BA B5 AD 6B 5B AE BA 73 9C E7 3B AC B4 CE 73 9C E7 5A CA 52 94 A5 6B BB BB BC 9D DD EB'\r\n '4B AE D1 EC 2D B7 8D DD 70 34 E9 66 E3 6C A7 74 AA BE FB CB DC DE 5D DE B1 9A D8 C7 85 CA DF E6'\r\n '4B 88 FA CC CD C2 E3 BB 61 BC AA B5 EE EF E3 FB D4 4F 2D E0 06 B7 2B 6F 82 AA BF ED C0 55 09 CB'\r\n '01 55 7C 82 38 B2 08 4E 9A B1 89 6F A6 52 97 A6 9A B0 CA 52 94 A5 E9 CE 41 52 E1 7C C6 31 8A 9C'\r\n '69 A5 7C A5 11 4A D5 25 0D 00 DF 70 A5 58 BF 8C 61 AB 68 63 EA 42 76 57 DC 21 28 CF FC 2E 4D 64'\r\n '63 2C 28 50 EE 90 84 F8 E9 AF D1 31 08 E7 87 55 9C 0A 41 2B 1D 81 21 42 C1 81 85 8C 66 35 4C 0C'\r\n '57 D7 27 D5 BC 30 A9 F9 20 1C 07 68 D4 30 36 44 B6 1B B2 21 08 42 10 84 22 49 3B BA 7B 06 60 49'\r\n '24 92 4E DA 24 52 2C 23 1E 05 96 74 6F 0D 4E 8A F0 8E 74 40 06 E6 55 46 93 82 5D D9 65 9A D8 C6'\r\n '39 67 91 91 8C 59 65 97 76 59 65 DD 96 5F 08 44 05 C5 80 C0 56 04 31 28 6C 30 D5 95 89 91 B0 42'\r\n '4E 4F 3C 02 10 FC FF 0A 79 63 90 90 F3 11 23 EF 8F A4 52 94 BA 68 83 C4 03 80 06 19 CF 72 25 52'\r\n 'DB 29 5E 44 27 52 19 C3 14 28 43 8D 14 60 07 3D 46 41 97 09 44 24 02 86 79 23 A6 31 AF 9C 90 F3'\r\n '8C 68 90 F1 F4 28 49 A4 63 58 3D 93 74 60 5D 4B 6C A4 24 0D 0A BB 37 60 FD 0A 1C 07 1F 44 F3 C9'\r\n '6B 42 84 2D 4F 5E 91 8C 62 8C 7A 0F 3C 00 21 96 F1 5C 40 BA 25 36 52 E7 87 3E E1 51 50 CE 18 DB'\r\n '2B 43 26 B1 07 B2 92 CF 24 6C C5 29 4A CE 6B 37 8A 09 01 C0 04 21 3B 79 43 43 00 CA 52 BA 8F 9F'\r\n '57 3C 72 9C B9 8C 68 8A 41 81 AC 91 C7 01 8C 5C E4 87 B5 9D 22 F0 4A 59 65 A5 9A 06 72 0F 5E E6'\r\n '1C CE E8 40 B1 06 BA 44 52 08 8F 73 48 EC 6C 2A 95 31 8F 76 2E 55 C8 4C 8C AA 44 34 0C 82 25 61'\r\n 'B5 12 AB C4 24 2C E7 99 74 B3 96 89 4A 46 36 67 31 28 D0 85 BC 89 99 E4 65 B0 AA B1 D9 65 BF 7F'\r\n '82 C0 06 6E 87 25 7A 09 87 43 7E 7D 02 02 1E 9F 81 4E 83 00 31 57 D7 79 6C C8 01 D7 49 2F 32 59'\r\n '93 84 34 72 0B 76 2A 19 4A 00 3C B0 A6 AA 3C A2 21 19 65 0B 67 EE 95 71 A6 19 04 70 54 DD 48 04'\r\n '20 C9 06 E0 93 DB DB 48 00 0C 69 D0 92 01 E6 5C 8B CF CD 47 6E 0D 9A 3B 24 28 8B 4B 32 05 4C D5'\r\n '1F B4 D3 88 02 08 48 3C D4 8F 9A 1A 9B 84 38 E0 22 45 B6 9C 77 F2 12 46 E5 D4 81 3A 98 B2 90 00'\r\n 'B5 89 49 DA DB A8 1C 70 17 6E 7D 83 10 B0 EC 66 44 E0 02 A8 F5 E4 EC DF 1E E6 CA 2A 5C DD 25 7B'\r\n 'B9 F6 17 E0 68 18 04 F1 4B 2E 46 FA 1A 94 B4 A2 D9 E1 52 B6 9C A6 A7 B9 43 6A 21 58 D7 9E A2 B7'\r\n 'EE 10 87 00 0B 5A 21 2F A9 95 0B 88 9A 6C 28 CC E8 BD 49 40 03 8A AE A4 46 E0 E0 59 DD 93 1B 5B'\r\n 'A1 06 3B 3A C4 DB 11 7C 19 71 0D 19 A4 0D 74 F6 4C 32 F0 0B B2 64 25 E5 D6 49 48 A8 20 58 A6 B7'\r\n 'A0 A2 78 F3 14 A2 BA A9 4B 4A EA 68 4D 29 57 2A 89 8D DB 24 02 06 E2 44 EA B8 69 58 12 A6 2A 26'\r\n '21 95 DE 26 1A 08 25 55 03 EE 48 D6 3D 01 51 DE B0 8C F3 1B 04 AA 8A 47 47 56 A1 8C 65 27 C7 82'\r\n '47 18 9B 04 C6 02 C9 98 43 24 63 DB 71 DE E9 49 DE A2 7B B5 ED 6A CD A7 99 9C 6E E1 04 55 4E 59'\r\n 'C2 DE 96 0A C4 F5 0B 93 CF 6B 9F 1E 95 AE EF 1F 3E 77 1B 6F B3 68 DE EE F4 7E 96 11 3D 22 87 A5'\r\n 'B9 C1 DA D1 AE FC 34 66 C9 BA CA F9 C9 67 16 E6 EC D0 56 86 7E 93 DF 33 EF 47 35 FB A3 56 AE 92'\r\n '39 13 42 A5 2E F2 F0 87 A2 29 21 A9 81 03 68 89 A2 66 83 CE 03 8E 38 0E D3 08 02 41 08 0A C8 0A'\r\n '46 12 49 6B CF E6 6E 1D E8 65 F5 B8 23 14 4B 6C 23 4C BA 44 62 68 94 16 2A 2D CA 82 D2 C5 43 2A'\r\n 'AA B2 5A 96 20 96 E5 40 64 84 6C 23 83 20 D4 64 82 8E B2 B1 22 20 EC BC 1E D3 8E F9 9F 41 E0 7E'\r\n '7E 99 9E BF EF F3 25 FC DD BE EF 16 DC ED C1 CF 45 DA 03 B3 B3 94 0D 71 E8 3B 0F CC 1E F0 FC FD'\r\n '2C 84 C7 9C C7 31 A8 95 8F 73 3A B2 B4 FA 90 94 9E 3C D1 57 0F 6D B6 71 FE 3F C7 CF CF 40 36 C3'\r\n '61 E5 79 5F BB C8 CB D8 2D FD D9 0D 43 F3 7C DE 45 22 0F 3B CE 40 EC FA 74 C2 7A 1E 87 5D D6 BB'\r\n '5D 81 81 24 00 04 80 9F D9 32 49 27 6D E9 D6 4E F5 3B A2 11 25 CB 92 B2 30 31 BD 03 20 C6 D8 C6'\r\n '99 07 12 45 20 FF DE F3 F5 FB 6F 33 E1 F2 7C E7 39 CB F6 9E 6B D1 73 7C 54 CD CC E6 D5 BD 0F EE'\r\n 'F3 7B 39 B7 42 46 F5 FA 4D F3 88 DE 86 F7 7C 41 42 22 0C 61 18 9C 44 24 56 54 68 C1 A6 68 89 A5'\r\n 'B1 18 89 6C A4 B7 2E 5B 2C B2 04 24 50 90 84 8A 11 90 6A 45 1A 06 A3 80 E4 14 18 85 0A B4 50 88'\r\n '30 16 15 00 C2 10 B7 05 32 7A 1F FC FB 0F B4 EE F8 CE CB F2 3B 2F A5 DE 75 5E 63 7D FB 7C B7 DD'\r\n 'EB 8F 64 D9 92 9C F0 65 5C F9 B9 ED 32 2E 4F 5D E6 AB 35 77 F8 D1 79 3C CE 91 0A 14 9A 12 8A 11'\r\n '59 69 14 61 E3 48 3A B1 EE B9 D2 F6 65 A2 0F F0 5F 6B F9 BA A7 5D 77 AE 22 08 6A C9 63 C6 22 33'\r\n 'A3 E0 AA DD F7 BB D0 E3 D2 AF 75 E9 6F 0D 6F 8C 1D 3C C6 C2 6E 2B 35 32 0A F1 C6 8F 8B C9 C3 A9'\r\n '53 24 96 7D 0B B3 8E 1B 09 66 76 0B AB 7D 32 CF 36 B2 53 CE DB B1 B3 2D 75 1A 02 BB 06 F9 B6 B5'\r\n 'DE 2A 13 35 45 C9 A9 8A BB 35 5E 57 D0 A0 89 17 D1 3B 63 99 99 0F A0 9B 85 5A FA E2 B7 1B 6D AD'\r\n 'BA 06 03 0C A3 FC 67 31 65 E2 DB 6C 8B 1B 03 66 62 98 C9 52 59 23 2D F7 E6 F1 0F 37 BA 4F 17 15'\r\n 'AC D6 59 A6 62 89 6C C5 F8 2D EB 75 DA D8 55 A7 5D 4A F2 94 A9 B5 3F 1C 6C E2 AF 92 2A E5 AC 9E'\r\n 'F8 74 CA 22 44 8F 3A 72 B6 55 61 48 CC 66 A3 48 B0 22 8D A1 86 C3 10 D8 25 B9 63 1D 7C 35 F5 6D'\r\n '6D E5 37 4D 14 CA 3F 03 5A E8 D3 62 D5 85 A3 2A B1 49 87 B9 36 CC A2 6C CC 5D 4B 04 9F 50 BB 40'\r\n 'AE 35 07 19 E5 84 F6 72 CE D7 7B 97 3B AF BE 55 AD 6C C5 AF 0F A4 5F B6 17 45 42 54 ED 92 59 C5'\r\n '51 2B 70 49 0A CA AB 2A 38 5D 2F 0D 62 ED 9A A2 9C F3 6D 6D 18 85 C4 E3 86 58 E0 23 39 4A FA 1B'\r\n 'B2 B1 DE CB 32 44 A3 5A 81 CC 98 3C D7 52 3C 64 C8 8C 2E B0 26 B4 E9 AD 78 98 AD FA 2F 34 D2 34'\r\n 'E7 86 5A B3 0B 96 59 68 63 4D 43 0B 30 16 CB 4E 28 1D 4A 15 58 E9 BB 58 93 A2 53 2B 34 39 E2 98'\r\n '4E C9 D1 34 51 80 C1 94 DD 0A 2A C7 2C 93 22 32 BF 37 C2 62 92 26 A1 34 E1 84 72 D0 FA A8 9A 13'\r\n '2D 1A A3 A3 4D 9A 74 26 AB AE CB 67 60 7B 7C 69 C3 D1 A5 9B 2C BC DF D7 F1 F9 BF 8E 7F A1 EA 4C'\r\n 'FD FE EB 62 BB ED 8A DA 45 55 56 C2 FE 06 92 38 D7 50 72 0A 3E 7F B5 82 C2 01 84 F3 DB 58 0F 0A'\r\n '3C 8E CE 36 A6 C2 A4 52 94 D8 F2 D0 7B CF EC AB 70 51 3D B5 D7 F2 2D F6 9B B3 8E EC 53 77 95 7E'\r\n 'F4 74 EF 6E 47 5E 29 2E 3D EF B5 C1 4C 1B 75 53 63 7F BE BA C4 29 F6 F2 46 41 F6 BC 0B 12 98 9F'\r\n '9C F4 4E B6 52 B5 A3 53 93 FA 91 5B 15 57 F1 F8 67 3E 1F B4 BE 54 E6 D5 DB 95 2D 0B 2E DF 89 8E'\r\n '96 9C E4 15 12 6B FC 37 04 44 65 B5 57 8B 1B B3 DE F8 C9 6E D5 56 2A BA AB 4E AA 5C 6F 7B 6B F3'\r\n 'FC 57 A2 AC 72 D1 FC 53 09 EC E9 8A D8 AB B5 8E 1B D2 AD B6 F2 FA 97 EB 25 E0 F0 32 55 A6 95 CE'\r\n '33 6E FF 3C F8 2B 4C 3E 03 87 D4 A4 6A 9F BB 8D 69 EC AF B2 52 55 E6 AF 0D 7B 2F B6 A4 95 59 5B'\r\n 'BF B0 3B A4 7A 31 4D 0B E7 9B 9F CE AD DA F4 9C AB 2B AD D0 CB EB 27 7D BE 1D EC EA D1 2F 27 31'\r\n '9B AE DC 99 57 38 B7 9C 9E 0A B3 9A AA A9 9D 8B BB E1 50 4D 1A BD 6D CA FC A7 76 E1 D9 60 DC E4'\r\n 'DF 25 8D 46 A4 8D FD 75 8E 86 69 56 72 9D 7C 9D 24 0C 51 FB 34 E9 19 A2 03 D1 48 87 E9 3D 11 55'\r\n '30 70 E6 CA E5 D2 9A C7 39 37 6B 1B 1C 64 12 E8 A8 9A AA 88 A4 AF A1 B5 34 3B 1E 73 12 67 07 56'\r\n 'BA C0 A9 DE 71 6F 5E 32 46 82 33 ED 93 A8 4E AF 14 EC 5E 7F 96 7A 7E BE 48 EC 9F 89 72 BC F2 F1'\r\n '2E 8F E7 F5 11 BB 8C 9C 5A 07 69 5A C3 E1 2A 9A E5 10 82 89 C0 47 44 97 20 86 4E 82 27 9A F1 EE'\r\n '10 B7 00 70 19 28 D2 86 66 D2 43 1C B4 CB BB D3 1B 5B D1 C9 05 54 B3 32 6A F2 20 33 01 04 10 62'\r\n '5F 61 BA A2 BE 1A B1 E2 BF 3B 7E 3F 51 7A F5 5C 5B F8 C9 09 3F 1A BE DF DB DC F9 4F 6E AA AA A9'\r\n '53 7F F7 93 49 2A 63 13 21 AE CA 90 C8 D4 AD 56 DD 2B 4C CA CC 25 FD BE 8B 98 64 50 55 C3 29 05'\r\n '22 B7 52 15 52 A4 A6 D9 2A 61 22 DA 33 34 C9 97 33 32 A6 1B 2A CC B5 4B 6E 64 23 4D 55 45 51 41'\r\n '17 15 3F 91 78 2E 86 8E 97 9E B3 91 72 A2 8C 05 A2 0A 41 AA 21 55 44 28 59 05 81 14 0F A5 64 80'\r\n '58 A2 04 58 C5 55 92 40 63 8C D8 5A 20 C8 BF 50 CA 45 90 9A 1D 20 19 40 C6 F1 41 31 80 92 50 31'\r\n '0F 88 DE E7 67 9F 90 3B 4D FE 7F A9 E1 C7 B0 4B 61 01 0C 74 22 63 8A 88 18 13 A0 84 24 C2 04 6C'\r\n '47 43 41 96 EC 21 70 15 60 30 37 BA 92 C1 59 E2 F2 EF 94 C4 E3 9D D9 36 64 01 C7 E4 77 9E BF C5'\r\n 'D6 D7 DE F4 FA 7D 42 8F AD D6 E6 6C 87 F1 17 18 01 91 D4 4E C2 04 3A 8C 1B 50 42 4C 04 5F 2D 29'\r\n '59 09 9F 2E A0 1A 64 81 82 78 FE 63 CA EF FA FF 2B 7F B8 F6 5E 3F 09 F3 3E CA 55 7F 32 BB DC 0B'\r\n '12 10 56 11 44 F0 BE 2A AF 0D 62 58 2C C7 93 45 92 19 11 02 8D 8C 48 6D 9F 31 C0 E2 BF 0B D8 76'\r\n '7D 2F 61 BA E0 F0 78 CA F2 BA A5 5B F2 AB 67 69 9B AD CA 54 9A C8 37 E4 D1 72 78 AA A3 27 A3 E1'\r\n 'F0 7A 7F BD F9 AD FD 89 F6 1F D4 F8 BF 77 DB 35 0F 46 BB CA 78 3C 39 30 A2 2E 5F 64 D5 F9 09 73'\r\n 'D8 60 A3 2D B6 8D 0D 0C 10 63 4D 50 85 41 A1 5A 18 CA 45 A1 85 D9 71 18 88 BE FF 45 44 4B 4A 18'\r\n '2D 55 48 A8 A8 14 93 1E EB D9 E6 F0 2B 27 38 D3 95 C3 AC 5D 94 29 6F A4 D6 DD 5D 0E B5 96 CB CA'\r\n 'D9 80 31 54 A6 2B 19 CD 12 4D 05 15 54 48 CD 6C 55 4A CD 65 B5 73 2B BB BC CE 89 2D DC C6 30 66'\r\n '5A DD 0F AC E8 37 9B CF 7B 5F 74 67 40 6C B7 A3 6E 83 5B 75 B7 00 DA 65 B4 D8 62 36 97 91 D2 F8'\r\n '7D C2 7A 97 E4 3D DF BB F4 31 F9 04 4F AC F5 3F 5D DD 98 89 20 9E 2F 13 E0 C4 9E 12 0C 86 55 CD'\r\n '9C 09 84 02 60 48 31 2D C9 53 4D B9 81 05 51 63 AF 3E EC 45 55 51 41 20 A8 42 18 25 56 6C 92 12'\r\n '65 4A 2E 1E 45 68 01 A1 80 32 EB 17 74 D4 19 75 10 C6 4D 13 2E 46 43 22 32 5B 22 E5 C9 2D 8B 0C'\r\n 'A5 65 34 D3 4D B4 C1 B8 EE 55 12 44 28 48 5B 54 35 52 28 C7 04 A8 D3 28 82 31 64 11 82 0C 31 77'\r\n '72 AA A0 A0 11 19 11 0A 54 02 99 05 80 A0 B2 61 62 12 28 B2 00 92 49 07 F7 3C 6F 07 C9 F7 03 FA'\r\n '21 04 04 07 9D 3A 9B AF F6 1C 1C F8 9E 26 9F 63 DB DE 36 C8 C3 8E 9E DB E4 72 D9 60 9F D4 FE A0'\r\n '7D 0F D9 71 CA FF 85 D0 77 97 D2 8B 15 A0 0F BA 1F 63 DE 7D 8F 44 26 87 D8 EA 07 C4 FB 21 78 25'\r\n '85 19 52 5D 75 C6 9A A1 C4 E2 ED 71 6E B9 DD AC B2 CA D6 B7 5D 70 F1 EE F1 E3 EA 9F FE F8 15 C1'\r\n '3F 78 F0 AE EE DD 06 AE EF 1F 43 3F 71 B1 EA F6 7B DC 2D 10 A0 FF 16 F5 FD D7 7D 1B 9F 79 DF 12'\r\n '62 7E AE D7 85 93 C2 37 71 5B 9C F7 B7 7F D6 3D DE 3D BD 7F DB CD E3 0B DB 7C 3E CB D3 74 B9 7D'\r\n '9F E2 B9 F0 BE B7 BF F7 DD DF AA FE BE 3D EA FF 66 B8 B8 B0 F1 8B AB DD F7 61 C5 FA 21 7E D6 D8'\r\n '5B DB B4 9F A4 D8 01 D5 A9 4F 16 D1 B8 9F 84 19 DF FF B0 DF F1 C3 7D 63 E8 4F 6D ED BD 33 D6 49'\r\n '3C CF 29 F1 5C 3D 63 E5 B3 0C 91 CE 6E D0 F6 9E 6D 61 16 12 43 26 10 69 24 86 CE 4A A5 15 50 0A'\r\n '1F 29 00 23 48 B6 22 D9 42 49 A6 5A 01 4C A4 09 6C 81 6C 27 17 52 3A A8 1E F1 9D 6B 3C 47 97 EF'\r\n 'B9 2F 6D EC FD CA 3D 06 DE DF 31 B9 C6 FB 7E AB A1 F2 7D BE A1 6F 00 0D EB 10 F7 90 5A F5 10 74'\r\n '7D 6F 59 E1 F2 5E 82 3B FF C3 EF AB AC 9E AC F3 F7 85 8D 17 2F E9 FA 7E 99 4B 0F 53 AF ED D9 6D'\r\n '17 7B 15 75 7C 0D 6E CF F5 8F C5 A0 B1 28 B9 87 77 02 94 D7 8A FC C9 A8 E5 EA 38 CD EF 3A 5C 8E'\r\n '97 EA F7 93 7A 1F 73 97 CD 69 5C D3 BF 30 D9 A9 BD 5B 0E EA ED 37 A6 A8 3A DD 6E BD 94 B4 B4 B4'\r\n 'B5 94 BD 2C C7 6A 6D 3F 72 AF C4 85 4F 3F A1 D2 90 00 94 A9 30 00 03 ED FA A4 3C CA D9 99 99 9F'\r\n '2E 67 CB F7 24 7A 7A 34 35 C5 EB ED D1 E1 E4 96 39 2D 2B FD E5 3A BD 29 39 3E 7F 32 4E 6B 9D FA'\r\n '96 2F 39 F9 EF B8 7B 8F A7 E7 F9 0C 54 76 C5 63 54 96 AA 32 53 BA 49 0A 95 76 94 E8 A8 C7 D5 77'\r\n '6D 6D 35 DA B4 B6 B4 B2 2A 54 AB 5B 69 39 6F D9 AB 88 06 4E 9D E4 1D 3A E5 3A 5E B5 B5 B5 B5 B1'\r\n '93 5E 22 E5 2D 4A 97 2A 85 09 BA F3 75 D4 B7 14 B4 87 5C DF 64 F8 DA 35 C2 44 78 75 D0 57 AE EE'\r\n '2E 81 04 17 0D E0 90 A5 D2 27 F0 95 E3 E4 DE 9A C1 C3 BE C1 C4 C0 F1 07 81 08 25 86 82 37 9E 99'\r\n '93 16 2E 73 F5 91 A2 0F 56 26 B3 91 97 20 3F 98 B9 BB 87 50 A0 C2 D2 D4 D1 5B A6 B1 5A C5 AB 45'\r\n '1B 51 DC 37 5A 6E B5 1B 33 74 F4 67 AC D9 B8 70 33 E8 8F 22 3E 19 D3 A7 50 06 85 0A 24 48 6F 49'\r\n '39 26 48 02 4D 8B 36 DF FB 8D C5 6F 6A C7 58 B2 A9 2D 97 DD F9 48 E2 E9 D6 7D 7B 9F 4F 73 55 1A'\r\n '4B D9 8A 9F EC E8 7A D8 5C DD CA 5F 6A F9 23 7B CE 67 DA 9B EA E5 32 33 CC E1 87 6B A1 59 C6 DC'\r\n '72 B9 BB A5 0A 15 94 CE A7 E2 62 91 D9 FB B8 E6 18 5C 70 3A BC 07 AF 5E 29 40 80 FD 83 C9 F3 FD'\r\n '07 2E 68 8A E5 E4 F5 2C 9A B6 6D 91 93 92 CE AB 1E 63 16 57 14 41 04 2D 8D 8A 7B B6 5F C3 02 04'\r\n '06 2A D5 AB C5 AD 81 6F A7 5E 66 E5 FB E7 E1 2D 58 B7 14 A9 C2 AF DF BF 5A B5 6B F7 EB 97 61 69'\r\n '1E 7C FA E9 7A F6 AD 1D E4 E4 C1 08 E9 D6 6A 5C B9 72 B5 6A C5 51 22 32 8D 19 66 9A CC F4 B9 EF'\r\n 'DF 3F D5 63 AA FD FB CD 6D 67 51 99 33 80 10 67 49 01 F9 13 36 05 09 39 02 40 00 4C 90 14 04 FF'\r\n '42 64 89 13 4C 4D 19 71 18 81 0C 78 09 99 AB 4C F8 3C 2F 3E FC 1F CB 6B C5 72 7F 13 FA 71 FF D7'\r\n '8E FC 7A FB 4F FC D6 D6 BD AF CD ED 6B 54 AD 56 B5 6E FF DC E2 B1 CA EC 6C 5A B3 ED 3F 4A EE 5C'\r\n '79 6F 76 FC EB 1C EF A7 FD DE BA EF EC 76 DE CF EB FB 5F E3 F5 3C CF 51 FC 9E 87 B0 EE 7D 57 3D'\r\n 'E9 FE E7 A2 7C F8 B9 98 A3 1B 0E 7D 31 B8 D1 7D 17 4B 58 E6 B3 31 7A 18 41 1B DE C2 8D 70 1B CB'\r\n 'FB 2E F5 77 B3 2D 85 85 B0 2B E6 79 9C 0A 1F FA A1 D3 B4 28 56 D2 45 5C 5E 3F B7 B2 F4 D4 7B 9E'\r\n 'EF B1 B4 F7 AC CA 7B F5 B5 E7 7B FD E9 D4 5C DE 6F 33 91 C7 E6 72 79 FF 0F CD F2 A9 DD EE E5 6E'\r\n 'AE 6E B3 3B F2 58 14 49 06 A4 2F D4 7D 29 2D 2F C3 E1 73 7B 9D C4 F8 C6 31 BB DD EE 23 98 B1 6E'\r\n '62 DE D8 A4 B2 35 FA A7 93 E9 26 A7 A8 2E 56 A6 76 DD 1B E9 F9 A9 F9 AD 76 BB CE FF 7E 7F 3B 5C'\r\n '01 2F CC 98 04 80 E8 4D 48 F9 3F AC CE F9 1F E5 BE 97 FD 78 DC 2D 9E FB E5 DE ED FE 5D ED 4D 4E'\r\n '6E 75 4D 4D 47 D4 65 AD A1 5D F9 55 8D 75 10 50 F5 A8 67 E8 79 84 E7 B2 40 00 0F 18 00 13 F2 2A'\r\n 'EA B0 7F B4 A9 DA 7C 69 BE 5C C7 67 BB CA DE E0 72 BB BE 87 43 A1 B7 F1 7D D7 7F EA 38 DE B3 C0'\r\n 'DF F3 FC 3F 2F E9 7C C9 F4 7B F3 A8 08 02 91 3D D1 46 2E 2B E2 E3 08 0E 10 80 E0 DA 77 A4 00 24'\r\n '48 91 2D 71 30 00 00 09 0D 76 D7 79 ED 6E A6 36 9B 4E 57 22 61 56 4B 26 6D 22 B5 D0 80 A5 42 84'\r\n '5A 88 DE 2F 48 DE 23 78 8D EB AB 6B BA E2 76 5F 4D 3E 63 A4 DD C3 97 B0 45 14 5F DB F6 E8 F4 5A'\r\n '34 68 0B 97 57 B6 B5 C7 27 E9 69 28 68 79 BC D9 A9 AC F5 09 D4 28 5D DE A8 A8 94 94 A8 A8 95 E8'\r\n 'F4 53 6A 2E 5C 08 32 DA 8B D7 2F 5F D8 EC 30 98 AD AD AD AD 6E E2 6E 6E 6E 72 76 7E D8 C0 41 04'\r\n '10 47 CF D5 A3 47 6B 6B 5B FA BF A7 FA 7F A4 FD 67 B9 24 3D CF B9 FC 9F EA 3D 7E 61 EE 99 3D D2'\r\n '43 7B A0 23 F5 75 24 9F 52 A8 FD 5B 54 8D 54 5A 4D 32 AE 8B 60 FD 55 10 A0 0D A1 21 C3 24 9F 52'\r\n '82 0D 0F BF 69 19 24 BB 1D 1A 5C 8E 4A 75 EF 2E 89 52 9B A7 2A D2 C3 EB E1 01 1A 18 21 19 F4 C4'\r\n '1A 58 8D 4C 42 DD 6E A1 AB 5A 69 68 CF B1 04 67 D1 CC 73 3C CF BC C8 D3 B6 6B 12 46 47 07 21 01'\r\n '93 72 15 25 0C 95 68 DC D6 93 62 20 2E BE FC F4 46 16 DA 2D B5 14 AA 20 25 51 6B 10 41 81 20 01'\r\n 'A2 CA AC 00 DE EC D0 49 CF 45 07 4C 16 E9 B9 70 1B A0 59 49 21 D5 E2 E4 C3 27 49 03 9E 7D 3F A5'\r\n 'C4 21 A4 DF 15 02 9B 18 5A 28 50 85 30 93 9A C5 AB 69 2D 0C 0D BD AD B9 49 1A DA D0 36 5E 68 E3'\r\n '60 2F 87 CB C4 1A B5 A0 D8 9C 80 4D 68 36 A3 49 54 D7 BB 16 66 9B 6C 4B 43 47 63 F2 FB 9C 87 BD'\r\n 'EF BF 53 BD FE 1D F7 17 DA 77 89 EF 25 A1 44 11 BB 5B 8F 7F 77 14 C7 31 A7 6D C5 96 4F BE DE E7'\r\n '39 89 6B B2 FB 9C A4 7F 52 B4 92 7B D5 18 D3 49 0A 5C 7C BB 9D 09 9D 6E 1A 6F D8 BE 9C D4 E2 4D'\r\n '49 BE 9D AF 2F 76 A6 F1 43 DE B3 97 32 D4 7D 2F CF 56 63 80 B2 9B 3E A6 51 33 4A B4 CA A4 EB 31'\r\n '33 29 6B A7 12 32 2B 42 14 FE 3B 9A B9 A6 7A 92 CE 42 A6 28 9A AA 6B 1E C5 34 FA 4D 24 AA 28 B2'\r\n 'EB E9 F2 D7 A2 B1 4D 57 6E C1 3D F5 8C 3B BB A6 86 4E 2C BA 28 9C E5 F6 12 DD 0B F6 98 30 6E 6F'\r\n 'F0 94 E1 A9 C1 63 1B 4D 7E AE 52 E5 EB D7 B9 6D 9A E0 FB 16 62 65 23 CE 68 91 36 AE B2 24 D9 ED'\r\n '92 38 50 E3 41 4A 96 7E 47 91 E0 9C EB F4 DA D0 06 30 3D CB ED 59 43 3A 9F A1 E1 56 3E A6 06 4E'\r\n '8F 3F 17 4F 59 E9 6B 7E FD 75 3F D1 C1 D1 A8 DE 7F 7C E3 78 16 E5 AB 7A 9B 6C CB FE 87 66 E7 83'\r\n '43 F8 51 7F 42 92 BA 29 BF 21 BE 7B 0A FF 9F 4B EF 96 E7 7F 9C 8C 42 B4 5C BE 2D E9 99 C9 96 CD'\r\n '9A B5 68 D0 68 11 A0 BF A1 1F C5 35 BB A0 A8 C1 FA 80 28 4D 42 AA 9D 73 CF BA 81 8D 06 BC 0D EC'\r\n '29 0F 26 41 D4 05 BB 04 38 BB 07 E4 FC AF CE 1A 22 0F 3B D6 74 7D D1 50 FF 5E 4F BC 29 5C FA 84'\r\n '4C 3E 9A 04 F9 C8 7F B9 4A A2 09 20 28 DC CE 87 31 1E D7 EE F4 A0 FD 15 A3 F3 5E 1F 37 24 FC 6F'\r\n '29 3D 66 F2 7A B7 4D 93 FA C7 CA 2D 67 AA 3A 78 84 79 24 7F C7 91 C7 59 EE F2 4A F5 6C 94 2C 61'\r\n '69 27 60 4D B5 00 8A 88 EB 42 E8 7B CF 95 E8 7A 1E 85 84 3F 20 98 24 C4 8A 96 A9 5B 2D C7 8B F0'\r\n '4B ED 1D FA C4 3B F6 C4 1F 51 51 EB 39 76 FF B3 BF 2E B7 D7 C0 C1 52 B4 2A 7D 40 EA 07 D3 96 6E'\r\n 'A7 52 AC 58 F2 E1 66 09 31 0D 27 4F 83 25 1B 99 07 0E F7 82 A4 E3 79 9D 1F 8B D3 FC 5F D3 FE DF'\r\n '53 FB 7C 9F 9F E1 7E 0F B5 F3 3C CF E6 F0 BA 5F 0F EB CB DD E3 71 FF FA EC DA 41 48 5C 79 63 1D'\r\n '19 78 B1 20 A9 C7 A1 41 0A 50 02 9C 00 7F 50 79 9E 67 47 5D AE 7B 76 B6 B6 AF DA 74 72 10 21 24'\r\n 'A4 E0 BE 5F 71 D9 68 DF EC 7D A9 6C 02 0E D5 3C D7 3E DD 94 41 09 1A A4 C4 1B 47 91 D2 0B 60 21'\r\n '33 BA 98 B2 BF B7 0E 71 FB 13 84 3F 19 65 21 88 38 30 B8 42 D2 E3 44 5D 3A 89 95 68 D9 0E AA 3D'\r\n '0E 77 6C 89 F0 DB 7B 36 5F A7 15 41 AA E5 2A 84 E4 8A E5 B0 64 D8 C1 C4 AA B1 E9 CA ED 53 3C B9'\r\n 'F4 DA E3 4B EE 45 EA 0E F5 FD 3D AA 4B 3D 8D 12 DC 77 D5 BB 37 4A 3F 5C DB 5D 55 10 15 BF 52 53'\r\n '67 99 AD D1 58 52 23 39 DA 40 39 F7 DE A0 10 38 F0 AB 42 9E 21 34 08 88 82 4C 27 19 F2 04 D7 47'\r\n '3B B3 49 28 42 8B 05 37 4E 6C 50 08 16 24 31 12 85 0E AC AB 20 31 84 A5 98 93 01 CD FA 14 DA A2'\r\n '31 BA 3E CE 01 ED F0 C4 CF CD B7 C4 61 A8 56 10 D8 8B B1 08 D0 D0 58 56 D6 0B 85 18 83 D3 C9 EA'\r\n 'F5 81 79 B0 90 A3 96 46 AC D5 23 C1 19 04 13 30 25 E1 01 C1 D1 E8 88 67 00 7A 6D FE CC 9D FE DA'\r\n '96 07 1C A8 56 55 4A A9 55 2A A5 56 47 19 1C 64 71 9E A0 45 63 10 F5 0C C6 57 45 3F B4 75 F0 3E'\r\n 'E3 DD F8 BE 07 AB E7 3C 4E BB 77 BF CC 95 68 75 6E 94 2B FB F6 FA 2A 73 FA A7 F2 A2 0D 2D 8B 2F'\r\n '8A 72 4C 64 97 BD 1B D5 47 3A 67 0E 4A 1C 39 D6 38 72 0B B5 CB 51 21 87 DA A8 41 DB 41 52 82 A9'\r\n '05 5A 0E E2 0E EA 0A C4 15 A8 2B 90 3F 83 61 AD 5E 2B 96 8E F5 94 E8 68 32 0A 2B F7 AA AD D5 32'\r\n 'D5 5C 25 CA D0 C2 E8 F4 89 66 4F 22 90 91 E4 97 26 4D 3C 7D E1 12 C4 67 08 84 21 00 08 40 2E E4'\r\n '08 1C F1 00 01 E2 38 A3 38 63 11 85 DC BF 93 DE D3 A7 8A A7 D9 C7 C6 A9 C6 73 BB FD 79 9F 22 6F'\r\n '79 3A 74 E9 DF 12 7A D7 BF DA 61 B7 83 E2 97 B1 98 DB FE 9D BF 9B B3 53 51 DA FA FE BF CA 72 76'\r\n '6E 56 57 89 2B C5 A6 A5 A0 4E 9E DD 3A 7B 74 E9 EE 93 D4 A7 AC 4E 9E E4 E9 B2 86 D7 A0 B3 BE 34'\r\n '6C D9 BE 85 C5 B5 D1 7B 7E 50 F7 77 86 EE 01 BD 76 1E 11 06 88 56 AD 5A B4 98 08 D5 E2 98 9B 9B'\r\n '30 60 C1 83 05 4C 18 30 60 C1 82 E5 CB 97 2E 5C B9 72 E5 CB 97 2E 5C BE 28 A7 85 F1 8A 7C 54 A2'\r\n 'A0 15 30 A8 53 26 15 18 BA 29 C5 54 2A 9D 1C 75 66 99 62 1D 5D 02 0C 1C 58 98 C3 AD 3C 79 6E 4B'\r\n '1C 91 16 08 E2 00 50 53 8E 8D D0 A9 E0 C5 87 A8 AD 51 11 D6 33 59 04 86 AB E0 B6 6D 01 CF F3 FD'\r\n '7B 4E 6F 9B E7 39 DD AF 39 FD F9 EF F5 B5 D8 D8 D8 D8 E7 76 36 3B 86 4E D4 9D A5 36 6C 46 19 9D'\r\n '9E D9 93 78 AA 46 CF 3C 36 06 ED 52 B6 26 D5 B9 70 AE 53 93 AC DE C3 E4 B6 3D 8F 37 DE F0 78 BE'\r\n 'B7 A1 EF 3E 9B 9D FF 5F 4F E9 78 98 37 DA 37 D7 DC 7E 3A CE 35 22 7A 2B 5F 8F 9A 7F A7 D0 D4 C4'\r\n '4B CF 93 CC CC CB 60 B6 EE 66 58 F9 D4 3A 13 C9 34 3B 53 AB 28 AC 1E B7 A4 A3 B2 07 3A CB 82 D9'\r\n '85 4D 48 4A F4 FB B2 D3 3D 78 C5 8A D9 D9 A5 28 94 AA 5B 44 85 92 17 49 E1 48 FD 2B E4 C9 CC 08'\r\n '81 CB 0D 26 AA B0 83 78 E8 F1 E1 F1 99 86 1B A1 14 08 A3 58 58 18 B5 15 14 98 34 B5 D5 58 85 EE'\r\n 'B1 AF 71 6F ED 4D 9D B8 C3 B8 68 CD 9C 68 48 33 A1 33 84 D2 13 58 4D A1 37 84 E2 13 98 4E A1 0D'\r\n '09 DC 27 90 9E B3 7A D1 EB 57 AF 5E BD 7A F5 EB D8 6E 5D 43 7F 05 2A 25 B9 ED DB AE 5D A6 A9 51'\r\n '0C 5B 38 6E 2E B3 46 5A C4 47 8F 12 24 56 30 60 B6 86 F2 03 D8 71 87 8E 3B C7 90 20 40 81 12 1C'\r\n '68 E4 10 41 04 6C 80 02 68 0E CC D7 F3 03 5C 53 92 93 B2 E9 8E A5 8E EA DB 2A 5D A4 72 3B A8 23'\r\n 'CE C8 31 F0 E2 39 28 BA 2C 13 0D 7B 1A 85 4F 9E AC CF 56 AD 5A C3 95 43 63 AA 28 8E A9 C6 55 52'\r\n 'DD DD E0 87 0E AA 88 73 54 23 7D 85 1D 5F 56 65 30 21 54 57 62 1D 93 93 AA 69 85 14 50 F6 55 60'\r\n '93 6A C0 1E 79 B2 C6 73 19 4D 25 73 D9 78 67 47 3C 95 49 54 B4 94 3D 35 C6 48 20 90 74 51 43 D4'\r\n 'F4 68 C5 2C 39 AA 15 53 53 8F 56 9D 53 55 42 46 D9 52 AD 06 7C F0 43 CD C5 96 25 F2 D4 B6 BA A0'\r\n 'B7 4E 10 09 BE 39 1E AF 10 36 24 1D 51 43 0A E5 2A DE 7A A2 FA CD 9B 38 E6 DB B9 55 75 6A 75 58'\r\n 'C4 0E D4 87 E7 B9 AF 82 ED A3 5B 1E 42 84 AA E7 10 36 C0 D6 F8 B8 1D 99 2A 06 1C B2 4B 48 5B 42'\r\n '77 62 BB 95 20 65 B6 01 A6 05 5E 8B DA 42 A3 25 E2 B8 81 8A 80 A4 3B 90 16 07 72 47 9A 25 85 D7'\r\n '37 BB 0A 8B 3B 7B 55 3B AA AA 94 69 EA F3 03 A7 8A A8 1B 16 E8 AE 9A 43 9E AA E2 2D 54 24 3A E2'\r\n '3D 29 42 2D 75 80 32 C8 68 45 AE AA 58 B6 F4 CA 4E 5B 31 0E 39 AE 68 44 79 C5 55 52 5A 8D D5 5E'\r\n '08 1A 56 2C 57 94 E4 A2 B9 79 B2 BA 74 A8 CE 39 15 1E 68 56 32 28 E1 28 25 37 5A 65 AB 65 D4 6C'\r\n '8C A6 8A BB A4 25 99 A5 0D 27 48 52 4E AB 94 2D E9 29 89 02 1C A7 41 54 72 97 49 76 05 B2 CB A9'\r\n '57 50 95 57 70 8B 29 90 14 02 2C 81 D3 78 A9 03 A6 4D 2C 77 45 BC A7 4E 63 13 7B 18 F2 D1 54 34'\r\n '15 5C D8 DD 58 98 86 1C 62 A4 38 42 69 E9 E5 B5 9D 75 48 C5 14 B2 71 C5 4A 95 2A 53 0E 9A BA 9D'\r\n '24 E9 80 A4 34 ED A8 9D 25 05 8B CD 17 6C EA E9 78 47 AA 38 AB B8 49 86 22 B1 4D E7 58 94 62 0E'\r\n 'D2 EC 12 E8 AE 1A 24 9C 71 52 07 4C 3A BC 59 03 84 0D 1C D5 72 CE 59 6C 67 55 44 0D F5 CD 55 2D'\r\n 'D8 92 E8 5E B1 58 2F 15 76 39 54 54 83 20 E4 B7 52 50 CA 91 D5 D5 DC 6C 64 84 A3 4B 21 0B 73 8A'\r\n '21 CE 6A 06 DB E6 A5 BC D1 85 3A A2 61 33 52 4D 66 A0 61 D6 6E C1 46 65 72 D4 A6 F5 8B 2E 14 C8'\r\n 'A4 2A 31 0C 5B 8C 14 0E 0C B6 A9 AC 06 90 31 55 09 82 DA 0C A5 4C 46 67 48 06 CE FE FF AE FC 2F'\r\n '0B D4 FE AA 6A 3D F4 74 AE 11 97 AD 55 B3 CA 94 AF FC 99 2C B6 66 63 93 F7 EF F9 AD 8C 40 10 11'\r\n '9A 77 91 22 23 87 6B 78 C3 E8 9F CA 49 84 8C 34 8C 4C AA D1 24 70 18 D9 50 DA 56 52 4F 34 48 58'\r\n '3A A0 D2 69 9F 3D E6 7C 9F C8 FD 67 DB FD 37 D5 7C 97 F2 B7 B7 E6 FE BF C1 B8 D0 8D C1 89 6C 83'\r\n '06 DA DC 64 AB A3 6F 13 73 FC BD FF D8 78 FE CF 55 F3 1D C6 B5 A4 6B B4 96 A6 D3 43 35 3D 7C 4A'\r\n '19 AE CC 54 F8 5C 9E FF AA E5 7B 5F B6 DF 77 3E 2E 32 F5 DC FF 29 5D 5F 21 3D 7E 3E AB AB F1 00'\r\n '78 92 1E 5D 79 56 46 3E 63 56 F9 88 2F 98 9F 09 F7 4F B9 F6 3A E1 60 01 B6 12 6C 48 A4 BA 9D 5D'\r\n '11 E7 37 E3 FA 2C ED 24 D7 6D 40 AD 4A 1C 62 54 DB 8E 31 7A 4C 48 B1 7E B7 EE 12 A4 25 ED A1 5C'\r\n 'A7 0E 2E B1 C5 D1 62 A9 F2 9F A9 4B 0E 92 19 42 64 55 2C DB 46 37 46 50 F9 DF A0 BD 30 15 A6 3C'\r\n '3C CD 2C CF 8C EE B9 DF 3D F2 0A EC 3F 18 E3 B5 B9 5D D6 AD 9B 41 50 82 55 AF 20 C6 B6 5E CB 54'\r\n 'DB 1A 0C 34 17 AF D6 7A CE AF C7 7D 27 7D D7 68 D8 68 35 34 1C 1D 6F 45 EE 3C C7 53 EE F3 68 18'\r\n '1C B0 3C 3C FB BF 57 FC 9F A3 F7 15 B9 0F 31 16 06 FD 0F 7D F7 1F 45 C7 FE 3D A7 04 3B EC 04 E7'\r\n 'BF 1F 0F AA FE BF 81 DB 70 3E 47 CD 6A DE 34 83 3B E9 F5 E0 24 71 A9 A5 C2 A3 22 AC 6D A4 D0 DF'\r\n '1D 56 28 DF AD AD 32 07 09 0C A4 B6 14 C0 D3 75 4A 33 6F 17 43 CF 03 B0 F5 A7 C0 9A 34 7A 6C FA'\r\n 'AE 24 31 89 67 1A 84 09 A4 50 C9 95 AA 4C 43 B3 1F 5B 9D 71 BB 21 9A A8 4D AA 1C 6A E5 A5 C3 07'\r\n '17 A7 29 86 55 6E A4 29 80 5A 41 13 6C 34 DC D6 E8 52 77 7A EF 0F C8 7A BF 9D FB A3 D3 FA FF B9'\r\n 'F9 9F C4 6E 00 0C 32 39 E8 44 30 80 26 10 18 E6 50 80 A0 20 39 BB 68 22 1C DF 4D DE BB D6 74 10'\r\n '1D 32 4E 54 55 0D 6A EF 15 49 D2 52 9F 3F E5 FC A6 E2 84 5A 3A EB 64 86 F9 AA 45 35 D5 8E E8 0E'\r\n 'BE 4E 6B 5C 73 70 03 4A 82 6D 86 0B 82 F1 65 16 A9 4F 35 CA 63 8C A9 C5 D4 83 A6 82 70 E5 D0 19'\r\n '69 88 ED AC 6F 77 08 5B 85 78 28 63 BA B4 96 0B C3 C2 7D 37 79 FE 27 DA 7F DF 85 E7 3C BE CF 5C'\r\n 'DA DB 80 6D 3A 1C 90 16 BB 36 59 1D 38 A6 D0 56 D5 C7 B7 23 4A 66 AB 74 52 7D A7 A8 FE 97 A5 5F'\r\n 'DC 75 DD CD 48 1D A2 72 A8 B2 91 41 AE DA 28 54 06 61 30 2F 62 1D DD D4 BC 6A A0 65 80 69 55 D9'\r\n '48 CC 51 76 61 E1 B7 75 C5 FC 2D C3 8E 6A 05 0C 84 30 AA 69 E7 8B BC 0C 8F 3C F6 5E 79 E6 C2 5B'\r\n '21 B3 9E 31 45 BC B4 F2 D4 0F 42 7C A8 82 C8 1C 6D 27 3D 54 87 5C 62 C2 70 06 18 75 F3 F8 E3 F3'\r\n '1F 39 67 5C D1 05 08 6F 88 CD 29 E9 A9 A1 86 BB 0E 23 7F C7 F3 BC F7 4F D0 65 DD 7F 16 B6 B6 DE'\r\n 'DD 24 6D 42 20 D8 60 98 C5 53 C3 5E 0C E4 B9 94 7C 37 45 F1 55 FF 1F 6B 78 EB 57 03 75 C2 58 1C'\r\n '30 14 67 5D 5D E9 93 8F FB 7C 46 6D E0 12 3D 50 4A 42 69 90 8B 8A E5 0D 17 A2 85 E8 FA 6F 6B 38'\r\n 'FF D2 F0 BB BF AD F6 BA B6 19 B5 B5 01 36 83 5D 92 22 5C A4 CA DA 86 CA 78 3E 47 E5 7E CF FF BE'\r\n 'EA FE A3 FF 5D 90 0E D4 87 48 B0 43 B5 3B 93 B9 9F 01 F6 3F 2D B2 4E 18 19 18 95 55 BB 2A 70 9E'\r\n '0E 68 D2 E9 24 D0 84 B4 52 24 B4 32 C4 BF 6D F7 DE C9 F8 9F 1B B2 C7 62 FE 36 7D 6E 43 F1 3C DF'\r\n 'E0 61 23 6D ED 34 8D A6 90 E3 4B 3B A4 D6 DF B2 F5 1D E7 41 C5 6C B6 E6 84 05 DC 84 80 16 7C 97'\r\n '79 E4 B6 34 A5 6C 68 88 54 88 42 BF 27 E8 54 42 1A 0C 00 B6 E7 F0 D8 08 60 60 02 94 B2 EB EF 88'\r\n '02 26 00 76 1F 7B ED FC 76 A4 A7 46 84 29 03 00 36 3A BF 5B C9 F4 7C DA D6 B6 56 10 16 6B 94 80'\r\n '1C 5F 0F 90 53 C1 DC 8C 00 91 80 18 FE 2F 5F F2 FE 93 C5 9C 84 05 C0 C0 2B BF E0 F0 F8 73 20 55'\r\n '63 1A CC 05 20 EA A1 E7 21 6C 0F A3 F6 B5 AD F1 CE 21 9D 89 63 17 8B 41 C1 D1 10 76 1F 93 CE D6'\r\n '6C F9 50 B8 4C 17 7B FF DE 7F 89 DC C0 2C C3 11 18 88 D0 46 04 1A 0F 87 E0 BE 5F C9 EE 79 ED F6'\r\n '5E 56 9D 1B 5B 70 0E 2F 77 0C 6C 4B 68 3B 9E B8 FB 2C FA 30 06 59 A2 0F 71 E4 E9 AC D9 A2 03 C6'\r\n 'EB FD 55 25 B0 D0 7B AE B7 C0 D7 D5 84 79 96 85 F1 7A FF 17 B6 A3 2C 02 39 16 C3 6B 6F 4D AD 2D'\r\n '11 A0 CB 24 4A 61 6C 51 A0 B2 32 D2 4A 83 69 0E F2 43 EE 7E 5B 76 06 A0 81 E3 60 7B AF A4 F9 7F'\r\n '99 D4 30 06 A1 A0 E5 BC 4E 83 79 F4 7D E7 29 99 20 D0 86 06 E1 A6 20 AE 1B B7 FA BF 0A D2 C9 AD'\r\n 'EE 59 A0 1F BA F9 DF 98 B8 4D 41 21 27 9C C8 07 6F 99 D5 C0 EE F4 FB B8 86 20 1C 24 8B E0 F4 FE'\r\n 'A7 B7 FF 1C C8 C8 16 A1 A0 E9 E8 51 05 34 1C 5D 22 01 4C 0F 1B D0 FC 5E 93 F0 FA 6F 95 F4 BD D6'\r\n 'A4 6A D4 80 ED 77 BD 77 53 EC BC E7 C2 FD 5F E8 F2 37 7A 80 D7 43 41 AE D2 20 98 6F DA A1 21 70'\r\n '69 85 A1 EF 2C 0F 8E 64 A7 BF 86 91 90 C6 8D 32 E1 96 42 A1 F1 DE F7 F1 DE F9 98 74 CE B8 A9 4C'\r\n '79 A0 3A 64 3A B4 28 99 4B 60 63 10 EB AE BA D4 38 EA BA 48 7C 3F F5 FA 85 C3 4C 85 41 92 B5 A2'\r\n 'CE D1 90 99 44 3B 3B 3B 3B 33 3B 59 D3 39 64 39 BA 83 D6 0B 90 EE 72 76 54 99 43 33 49 53 23 03'\r\n '6E 2E A0 22 43 9E 7B 3B 35 AD 12 B9 A3 95 91 84 30 84 DE F7 C6 24 DA 1B 38 A9 48 A1 38 19 75 40'\r\n '5D 50 01 D3 10 E3 9E 39 D7 1B 87 29 5C D4 27 3D 9F 35 46 D3 15 A6 A4 0B 86 33 5D 75 D7 66 F8 E5'\r\n '82 D4 F5 5F 37 54 35 81 88 D2 6A 6A B2 B4 19 98 2B 69 31 5B 57 29 14 EB 29 46 18 19 82 05 5B 40'\r\n '16 80 2C 63 03 0E 5C A1 30 65 9A 61 60 5B 02 52 83 03 4C D2 61 21 16 06 29 81 CF 65 4C 01 BC D4'\r\n '97 0E B5 D9 BC 87 29 CF 54 B3 96 02 57 2C 88 58 03 06 19 4C A6 52 18 87 3C F3 CE 48 69 21 A4 88'\r\n '24 E1 39 E6 83 28 19 92 90 A8 02 8F 6A 05 D9 C7 3D 75 88 70 F4 84 E2 70 94 10 60 C3 0C 0B 12 17'\r\n '04 30 CC 30 92 E1 BD 58 07 63 82 56 EB A6 6B 5A 09 BE 2B B0 4E 12 1B 9C F3 47 39 79 D1 2D 03 84'\r\n '86 61 9C DC CA 06 58 1C 21 CA 4A 4C 32 49 B8 6F 76 04 DE B7 66 D2 19 D5 43 0E 9A 43 31 90 CF 5A'\r\n 'EC C1 94 35 BA 38 C5 40 58 63 15 2C 60 2C 29 C6 28 81 6C B5 16 E8 26 39 79 DF 3C EA 10 CA 07 34'\r\n '51 07 55 84 6A A1 84 E5 63 CA 69 90 79 AA 40 3F E8 FD 87 9F 4D F0 E8 FA BE 51 8E 04 0E 72 8F E3'\r\n 'FA 70 3D 47 CA 36 3D DB 63 73 5F CD 7F 63 9D EB 04 BE 8F DC D9 FF 59 1F 97 E9 91 45 AB B7 BA F7'\r\n 'A7 BE 0F D8 38 9F 7F 7E 73 E4 94 9F AC DB 4F 74 37 58 5E 3F A2 7C 5E E6 B6 FE D3 98 A7 A9 C4 B5'\r\n '92 C6 97 6F 9B 69 91 5F DB EE CE F8 3C 23 71 68 94 5B CE 61 38 55 D1 9D 2D E3 77 CD AB B7 19 53'\r\n '8C 29 6D 3A BB B4 D5 14 B6 0C 6B 15 19 28 87 C2 9A B5 6B E4 CF F3 ED F0 AC 8E 6B 67 69 5A 59 2C'\r\n '2D 55 86 0C 64 07 11 E9 59 AA 75 60 89 4E 26 76 33 2C 8C A0 55 20 6C 77 C6 A0 58 2B 1F 69 87 1B'\r\n '0E F7 45 B3 9C 46 90 B4 C5 D2 71 92 AB 54 75 D9 6B 63 32 50 C1 40 2E B4 5D 42 D4 1A 0E A8 A3 39'\r\n '84 42 B6 AE 5C 84 EB 59 EE A8 90 DC 32 76 D0 68 EE 1F 38 6D 05 FC 62 06 79 0E 08 EF 1B 93 24 48'\r\n 'C9 30 09 00 23 E1 44 14 40 C4 84 C4 31 44 10 31 23 0A 20 A2 44 62 20 82 B1 62 28 AC 45 62 C6 3B'\r\n '11 61 B1 62 10 A1 88 28 22 06 28 A1 86 28 82 84 28 9B 71 63 88 2B 11 44 10 51 42 08 31 01 0C 41'\r\n '01 0C 15 EB D8 02 0A F5 EB C1 05 80 2C 01 05 7A E0 41 07 51 7A F6 00 AE 5C BD 80 2B 97 AF 04 15'\r\n 'EC 18 47 5E BD 7B 05 CC 17 30 60 38 20 B0 04 16 00 C7 09 83 06 01 04 C0 10 41 09 83 06 00 84 C0'\r\n '16 00 84 B9 7B 00 42 5C C0 10 42 60 40 21 86 C0 10 C3 0C 10 C3 08 35 E1 84 10 6C 01 04 30 D8 02'\r\n '18 61 86 10 21 06 10 21 86 1B 00 82 0C 10 42 0C 10 42 0D 80 61 07 1C 31 C7 1E 34 76 44 11 16 30'\r\n 'E4 11 18 71 C8 23 CF 1D C4 81 20 00 64 82 40 00 09 92 8D 20 00 04 95 7D 3C 61 03 17 57 54 36 22'\r\n '88 28 A3 86 3F 9E 20 60 B0 09 7F A4 BD 72 E5 BA 6B 56 2B 1F 4F 49 52 A1 F4 74 54 0E A4 7D 11 D3'\r\n 'A7 D0 4B A1 A0 91 32 5C E4 A9 51 23 CE CD 43 9B 98 7C F8 F9 83 E5 65 E5 E5 F8 F2 F1 B2 72 71 F1'\r\n 'B1 F0 F1 71 70 F1 31 30 B0 B0 70 30 30 6F B0 2F EF 0E 9D 35 78 72 EA EE F2 E6 EC D1 9B AB 93 26'\r\n '4C DA DC 5C 5A 98 B6 2C 5F C3 E1 2F E1 2C 58 B5 A5 A5 A1 42 85 6C CA D3 94 B0 B3 B2 B3 B3 B0 B3'\r\n 'B2 F0 58 58 D9 0F 1C 71 E2 45 B4 8E 5E 2C 62 22 45 8B 6F 01 B3 57 CF 5B 3C 6C D5 E3 B6 AD 06 19'\r\n 'B6 98 AD 06 6A 33 51 9A 8C D4 66 A3 0C D9 B0 CD 46 6A 33 51 9A 8C 33 61 9B 35 19 A8 CD 06 19 AB'\r\n '41 9A 8C 34 07 6E DD C0 79 01 EB D7 AF 5E BD 7C F9 FB F7 E4 10 41 11 08 20 8E A8 04 80 03 D6 C7'\r\n 'CF BB E1 EF E5 3D 0F B3 85 F0 F9 BF 66 CB F8 6D 78 5B 5F 53 83 B9 FE 5F 64 7F 93 D7 E0 E8 9B 5F'\r\n '91 AF A7 F1 D2 B1 C7 DA A7 67 63 8F 4F 8B D6 63 B3 67 1F 16 E7 03 73 2F 57 7E FF BD F2 FE 47 47'\r\n 'CB F0 3D F7 C7 F2 7A 3E FF C8 F8 DE 3F 81 E1 F8 DE 07 8B E1 94 B8 3B 34 54 BD 69 C3 25 6D CA 5E'\r\n 'D9 DC 5E 1B 28 64 A9 93 66 4A 9B 28 64 D9 B3 36 76 26 CC 9B EF 99 B8 37 61 70 6E 34 6B 7B D2 0C'\r\n '9C 20 ED C7 88 ED C4 63 07 6F 62 99 89 72 72 09 D3 46 9F 2C AC B3 CE C9 BF 3D 80 F7 00 6C 0C 68'\r\n 'F6 F1 9E 1F 4B 8B 95 A9 8F 96 EA 29 F8 B7 E3 68 24 60 85 0B 84 70 D1 24 6D 09 A8 F9 F0 C7 6F 0D'\r\n '48 F0 DC AA 63 A6 98 78 6E 97 02 18 2C D5 BA 84 20 E3 0F AB 0C 61 E1 34 68 EC 78 63 B8 88 FC 61'\r\n '9F C2 1A 20 F0 5F 8F 0E 34 42 08 1C 71 C7 20 82 39 E0 01 B1 26 01 22 64 C0 00 00 3D BF B2 43 D8'\r\n '26 48 98 04 89 95 8A 92 28 40 F9 54 B7 0A 8E 59 53 DA 63 41 72 1A 56 61 85 A4 2D 52 90 86 B3 A2'\r\n 'D8 84 C3 2F 18 96 60 64 98 61 84 B1 49 55 59 4D 89 61 85 DC 30 D2 51 A8 EA 62 84 AE E8 A4 95 35'\r\n '6C 11 72 02 6D 25 2E E8 AA BA 12 B6 85 86 B1 50 97 04 A3 4A 9A 15 B4 56 23 65 B4 61 89 16 C4 5B'\r\n '45 C8 5B 12 BA 8E E0 82 9A 51 AB 62 4D 89 5D DD 11 A5 93 44 65 E2 08 F6 9D 67 DF FD EF 51 F7 9D'\r\n '37 FC FA EF 5D EA FB DE E3 B8 ED B9 BD 9F 2B D2 F2 38 DC 5D FD DC F9 31 E0 E8 FB 9F 37 63 5A D5'\r\n '7F 47 52 7F 71 DB 7E 5F 6B CA AB 5B 93 D7 EB 7B BB 39 31 60 BF E8 FA DE DF B5 D3 C7 EC 7C EF 37'\r\n 'E7 FC DF 99 D2 F2 BC 8F 1B C4 F9 3F 27 A3 E1 CF 08 A2 09 42 01 88 0E 0F 67 EB CD F0 76 B4 4B D2'\r\n 'A4 86 99 8D 19 EB 9A 61 BB BC DC 8E 0B B4 37 77 38 3C 1D D7 E8 50 9B 46 95 1A 57 37 6A D4 DE AB'\r\n '8A AD EB 1B 5B 7A 36 76 B6 F6 F6 F6 D3 09 C2 3A FF 54 33 80 E0 12 04 AF 8D C5 A3 00 59 22 90 82'\r\n '20 0C 64 87 B2 F4 7D 87 9D E5 7B F7 C0 FC 07 AD 22 AF C4 72 4F 32 EB 1E 8E B2 73 AA 5A CF 7E A7'\r\n '2A FB 12 EC A7 89 40 8A AF 30 E7 F3 70 32 FB E5 FB 94 57 77 28 B4 90 E2 F8 F0 CD 44 50 C3 9A 85'\r\n '05 1E 7E 62 43 78 36 C5 63 77 3B D5 55 B7 B9 11 BC 20 E8 23 4C 8B 3F 28 FE 93 98 4C DF 06 13 74'\r\n '3D B5 0A F2 F5 15 AD 48 9C FE 51 AB EC 33 99 A9 95 29 CA 64 BB 51 72 E5 CB 16 87 00 11 A2 33 66'\r\n 'F8 40 45 6C 2E AD 1D 7D 96 2E 2F 88 ED ED 91 5C 86 F0 19 BE 19 C8 CE 20 C3 77 06 0B E8 0F E2 45'\r\n 'D0 D0 F5 2E 09 92 24 05 44 B7 FE 70 76 BC 1A 79 6D A4 8F C5 C2 A6 96 DB 71 29 E6 3E 1D FE D7 E2'\r\n '7E F9 F3 E7 CF 9F 3E 76 30 C3 3A 74 E5 CB 98 F0 A1 42 7B 02 13 F7 E4 10 41 04 10 47 26 7C DD 9F'\r\n '22 77 93 3D FE A7 B9 1F EB B5 CB ED 72 E7 6E AC 71 AE F8 1C 6D EF 0B 85 C6 E0 F1 65 2A 0E F8 A5'\r\n 'AA 4E DA F6 BC 18 17 14 56 58 37 34 A5 30 6E AA 2D 30 6E FB 76 95 45 AA CB 77 4B F7 4B 56 97 AE'\r\n '2F 82 6B BF E2 C1 37 61 5F 5E 89 E3 C7 84 52 91 9E 42 76 6B CA 16 2D 68 58 2C 47 4E 85 C1 42 DF'\r\n '5B 5B 5A E4 DE 1A 25 2B 16 2C 58 B1 62 C3 A6 D6 2D 77 81 86 E5 96 19 E1 99 BE 74 33 87 4F 86 7A'\r\n 'F9 F3 E7 C4 10 41 04 42 87 02 0C 18 70 A1 43 20 82 08 20 86 0D 1E 33 1A 3B F8 4D DE C7 86 E5 EC'\r\n '68 6E E0 39 74 EA 03 D8 F1 61 45 20 78 B1 C8 20 72 22 90 41 04 79 00 12 00 00 25 C9 81 D6 26 48'\r\n '00 3E D9 29 29 29 29 29 29 29 29 29 29 29 29 29 29 2E D3 B4 E6 72 F9 7C AE 47 6D DB 76 5D 97 65'\r\n 'D8 72 79 BC DE 4F 2F 97 D9 72 F9 7C FE 7F 3F 9F CF E7 F2 ED DB AF 6E DF 75 DE F7 BD EF 7B 7B BD'\r\n 'EF BB EC 1D F7 7D C9 EC 3B 0E C3 8B C5 E2 F1 3F 4E CE EA 4B 75 BC 33 71 BE 55 6E 60 C2 BB 5B 46'\r\n '4B 2C C4 65 67 65 E0 AD F0 59 59 58 D8 EA F5 BB F6 16 03 B0 1E 38 F3 B1 C7 8E 3C 76 B4 51 C7 6F'\r\n '6D 4D 34 3B 69 C9 C9 D9 E8 F9 79 74 43 D1 E6 0E 7C F9 F3 E7 CF C0 40 7D 02 01 90 A1 84 FE 0A 18'\r\n '03 A4 46 91 22 41 E0 A6 87 16 25 ED EC 44 F1 4E DF 47 1C 82 12 2C 59 88 7B 43 49 4A 9C 85 2A B4'\r\n '7B 80 01 44 4C 02 5A 7B 1F E5 BF DE EF 36 3E EF F4 FC 3A 3E AC 68 70 1E 8D 9A D9 9E AF AB D3 E7'\r\n '7B 7C 9E 3F 0A 5B A1 F3 7C 73 24 47 8B 0E 0B FD 07 6E 9C 7B F3 0D 65 BE 8F A3 AD 29 D5 E6 7E 3B'\r\n '8D C6 F7 F3 9E 94 96 E9 8F 1E 34 58 90 E1 41 80 FF FC EF 78 F4 74 34 14 3C 3A 1A 09 F9 99 7E 57'\r\n '23 93 4F CA E5 49 F7 48 20 82 08 20 82 08 20 8E A6 66 64 58 B9 51 A3 46 8D 18 51 5B BB 64 C8 20'\r\n 'B4 1B 36 9C D2 D2 D2 89 11 D3 A7 4E AF 2F 33 0D A0 BC 36 6B 2D 01 D3 F7 C9 10 24 44 8F 07 05 02'\r\n '3C E4 58 E8 E0 40 80 6B 1D 11 E3 C8 B0 D0 E1 E2 66 E0 67 66 A5 4A 80 F9 F3 E7 CF 9F 48 7F 25 02'\r\n '47 B0 A1 44 88 8F 3B 39 1A 34 8D 92 92 03 78 01 32 44 98 B1 62 C5 7A F5 EB C5 14 51 05 62 C7 F8'\r\n '4A 4A 71 F8 FC 9E 47 2B 95 E9 36 7E FE 0C 18 30 46 19 D3 A8 10 20 3F 81 06 0C 18 91 22 6D A6 E7'\r\n '26 66 66 A6 BB 1D 89 C9 C9 E9 EA 3A 3A 5A 5A 5A 5A 5A 58 D1 A9 E9 FF 1F C7 7B BD EA 75 3A 93 74'\r\n 'F3 71 A6 E7 3B 34 B5 14 54 53 73 75 15 15 14 C9 AB 2B 13 1C 3B 6E 7E AB 53 3E B4 65 D7 57 19 83'\r\n '5C 9F 19 79 43 45 50 8C C2 F7 39 10 21 24 74 16 0A 67 59 EE 83 3D A0 E9 43 A1 32 34 5D 69 3A 17'\r\n '29 53 76 2C 1E 21 89 91 E3 3A 82 2A 1C 03 EF A1 61 E8 8B 9B 8A 2A A4 42 AB F1 8B A6 9B 31 31 F4'\r\n 'C0 A1 87 9F 9D 9F 9A 2A 64 89 D2 67 A8 50 1B 41 1A 43 79 AB 15 BC 66 71 9C C6 80 DC 68 D0 59 3A'\r\n '66 CA 20 64 80 03 FF C5 DC 91 4E 14 24 3F 48 2C 1E 00'\r\n}\r\n" }, { "path": "External/Jedi/Jcl/source/common/JclUnicodeZLib.rc", "content": "/****************************************************************************************************\r\n\r\n\r\n ..\\..\\jcl\\source\\common\\JclUnicodeZLib.rc\r\n\r\n\r\n Produced by UDExtract written by Dipl. Ing. Mike Lischke, public@lischke-online.de\r\n\r\n\r\n****************************************************************************************************/\r\n\r\n\r\nLANGUAGE 0,0 CATEGORIES UNICODEDATA LOADONCALL MOVEABLE DISCARDABLE\r\n{\r\n '78 DA DD DD 07 74 54 D5 DA 3E F0 67 CF 24 93 4C 1F 12 48 9B 84 29 61 12 26 8D 49 42 AF A1 17 89'\r\n '20 2A 45 14 42 55 54 9A 80 15 A5 89 05 51 B1 DE 6B 05 15 43 8A 05 45 11 04 21 22 C5 02 92 48 8A'\r\n '05 04 51 50 11 24 74 49 48 CE 7F CE B3 99 7C 03 01 3F EE FD DA 5A 7F D6 6F 69 40 A4 4C E6 9C B3'\r\n 'F7 FB 3E FB 0D 46 6A 80 EE C0 0D 40 09 50 09 7C 0B FC 08 40 A8 34 14 42 3A 0A 27 03 99 C8 42 36'\r\n '8A A0 A6 14 45 31 14 47 F1 D4 9C 9C E4 A6 16 94 44 2D 29 85 D2 28 83 7C 94 45 AD A9 2D 75 A0 4E'\r\n 'D4 85 BA 51 77 EA 49 BD A9 2F 0D A0 81 74 35 0D A6 21 74 1D 0D A5 E1 74 03 DD 48 A3 28 8F C6 D2'\r\n '78 9A 48 B7 D0 AD 74 3B 4D A1 69 74 07 CD A4 3B E9 6E 81 7B 04 EE A3 FB 69 9E C0 7C 81 07 E9 21'\r\n '81 87 05 1E 15 78 4C E0 09 81 A7 04 9E 11 78 56 E0 79 81 7F 0A BC 2C F0 8A C0 52 81 65 02 AF D3'\r\n '72 CA 17 58 21 50 48 6F D1 3B 02 EF 0A BC 27 B0 4A E0 43 FA 48 60 8D C0 7A DA 4C DB E8 4B DA 41'\r\n '3B A9 8C 76 51 05 55 D1 77 F4 03 FD 48 FB 68 3F FD 42 07 E9 37 3A 44 87 E9 4F 3A 46 27 E9 B4 C0'\r\n '5F 02 35 74 8E EA 09 1A 95 86 42 48 47 E1 64 20 13 59 C8 46 11 D4 94 A2 28 86 E2 28 9E 9A 93 93'\r\n 'DC D4 82 92 A8 25 A5 50 1A 65 90 8F B2 A8 A3 06 9D 34 E8 A2 41 57 0D BA 53 4F 0D FA 68 D0 8F 06'\r\n 'D0 40 BA 9A A6 69 55 77 D0 9D F4 10 3D A2 C5 22 2D 16 D3 13 5A 3C A9 C5 53 5A BC A6 C5 1B 5A 14'\r\n '6B B1 93 BE D1 A2 5C 8B 6F E9 7B DA 4D 3F D2 3E DA 4F BF D0 41 FA 8D 0E D1 61 FA 93 4E D2 19 3A'\r\n 'AB 45 8D 16 75 5A B4 0A 41 1E 8D A5 F1 34 91 6E A1 5B E9 76 9A 42 D3 E8 0E 9A 49 77 D2 DD 74 2F'\r\n 'CD A6 07 68 2E 2D A2 C5 F4 04 2D A1 A7 E9 59 7A 9E FE 49 2F D2 CB F4 2A 2D A3 D7 69 39 E5 53 01'\r\n '15 D1 5B F4 0E AD A4 F7 E9 03 5A 4D 6B E8 63 5A 4F 1B A8 24 04 9F 86 E0 33 DA 42 DB E8 0B FA 8A'\r\n '76 50 29 7D 43 E5 54 49 DF D2 F7 B4 9B 7E A4 7D B4 9F 7E A1 83 F4 1B 1D A2 C3 F4 27 55 D3 71 3A'\r\n '49 A7 E9 2F AA A1 73 54 4F 08 55 69 28 84 74 14 4E 06 32 91 85 6C 14 41 4D 29 8A 62 28 8E E2 A9'\r\n '39 39 C9 4D 2D 28 89 32 43 31 34 14 CB 6C D8 62 03 9A AB 34 14 42 3A 0A 27 03 99 C8 42 36 8A A0'\r\n 'A6 14 45 31 14 47 F1 D4 9C 9C E4 A6 16 94 44 2D 29 85 D2 28 83 7C 94 45 AD A9 2D B5 A7 8E D4 99'\r\n 'BA 52 0E F5 A0 5E D4 87 FA D1 00 1A 48 57 D3 60 1A 42 D7 D1 50 1A 4E 37 D0 8D 34 8A F2 68 2C 8D'\r\n 'A7 89 74 0B DD 4A B7 D3 14 9A 46 77 D0 4C BA 93 EE A6 7B 69 36 3D 40 73 69 3E 3D 48 0F D1 23 B4'\r\n '88 16 D3 13 B4 84 9E A6 67 E9 55 5A 46 AF D3 72 CA A7 02 2A A2 B7 E8 1D 5A 49 EF D3 07 B4 9A D6'\r\n 'D0 C7 B4 9E 36 50 09 6D A2 CD B4 95 3E A7 2F 69 3B 7D 4D A5 F4 0D 95 53 25 7D 4B DF D3 6E FA 91'\r\n 'F6 D1 7E FA 85 0E D2 6F 74 88 0E D3 9F 54 4D C7 E9 24 9D A6 BF A8 86 CE 51 3D 85 3B 60 75 20 C6'\r\n '81 04 07 5A 3A D0 CA 81 F6 0E 74 73 A0 9F 03 B9 0E 8C A0 91 74 13 8D A6 5B 1C 98 EA C0 1A 07 D6'\r\n '39 F0 B9 03 5F 39 F0 AD 03 3F 38 F0 9B 03 87 1D F8 CB 81 5A 07 34 2E 55 18 19 5D 30 BB 60 73 21'\r\n 'C2 85 66 14 EB 42 82 0B 2D 28 89 5A 52 8A 0B E9 2E F8 5C C8 76 A1 AB 0B DD 5C E8 4D 0B 08 69 C8'\r\n '48 43 1E 8D 4D C3 F8 34 DC 4C 93 E8 36 9A 9C 86 69 69 B8 83 66 D1 03 69 98 9B 86 F9 F4 20 3D 44'\r\n '8F D0 22 5A 4C 4F D0 12 7A 9A 9E A5 E7 E9 9F F4 22 BD 4C AF D2 32 7A 9D 96 53 3E 15 50 11 BD 45'\r\n 'EF D0 4A 7A 9F 3E A0 D5 B4 86 3E A6 F5 B4 81 4A 68 13 6D A6 AD F4 39 7D 49 DB E9 6B 2A A5 6F A8'\r\n '9C 2A E9 5B FA 9E 76 D3 8F B4 8F F6 D3 1F 74 84 72 F2 55 3D A8 17 F5 A1 7E 34 80 06 D2 D5 34 98'\r\n '86 D0 75 34 94 86 D3 0D 74 23 8D A2 3C 1A 4B E3 69 22 DD 42 B7 D2 ED 34 97 E6 D3 83 F4 10 3D 42'\r\n '8B 68 31 3D 41 4B E8 69 7A 96 9E 27 F7 0A 55 0B 4A A2 96 94 42 69 94 41 59 D4 9A DA 52 7B EA 48'\r\n '9D A9 2B E5 50 0F EA 45 7D A8 1F 0D A0 81 74 35 0D A6 21 74 1D 0D A5 E1 74 03 DD 48 A3 28 8F C6'\r\n 'D2 78 9A 48 B7 D0 AD 74 3B 4D A1 7B E8 3E BA 7F 05 1E 58 81 B9 34 9F 1E A4 87 E8 31 7A 9C 96 D0'\r\n '32 7A 9D 96 53 3E 15 90 4B 41 47 05 FE 1D 54 B2 7F 13 55 2E 62 CB 45 EB 72 91 5B 2E 6E 29 17 F3'\r\n 'CA C5 CB F4 6A B9 58 5A 2E 5E A7 37 CB 45 7E B9 28 2C 17 6F 95 8B 77 CA C5 87 E5 A2 B4 5C FC 5E'\r\n '2E 42 2A 44 68 85 08 AB 10 86 0A 61 AE 10 4D 2B 44 54 85 88 AF 10 ED 2B 44 87 0A D1 A9 42 74 AD'\r\n '10 39 15 A2 57 85 E8 43 03 2A C4 E0 0A 71 7B 85 58 58 21 96 55 88 B5 15 A2 BC 42 1C A9 10 E1 95'\r\n 'C2 55 29 3A 57 8A EB 2B C5 B4 4A F1 68 A5 28 A8 14 25 95 62 7F A5 A8 A9 14 F1 55 A2 75 95 18 5A'\r\n '25 A6 54 89 25 55 A2 A0 4A 7C 49 62 8C 7F 39 3E 06 B8 17 28 A2 0F E9 63 DA 0B 9C 06 FE 02 FC 7F'\r\n '4F 21 54 5A 0A A5 30 D2 93 91 CC 64 A5 26 14 49 CD 28 9A 62 C9 4E 09 E4 20 17 25 92 87 92 C9 4B'\r\n 'A9 94 4E AD 28 93 B2 A9 0D B5 13 68 2F D0 91 3A 53 57 CA A1 1E D4 8B FA 50 3F 81 FE 02 57 51 2E'\r\n '0D A2 6B E8 5A BA 9E 86 D1 08 1A 49 37 D1 68 1A 43 E3 68 02 DD 4C 93 E8 36 9A 4C 53 69 3A CD A0'\r\n '59 74 17 DD 4B B3 E9 01 81 B9 02 0B 68 21 3D 42 8B 05 1E 17 78 9A 9E A3 17 04 5E 12 78 95 5E A3'\r\n '37 E8 4D 2A A0 22 81 62 81 B7 69 25 7D 40 AB 69 AD C0 C7 02 9F 08 6C 14 D8 4A 5F D0 76 FA 9A 4A'\r\n 'E9 1B 2A A7 4A FA 96 BE A7 DD 02 7B 04 F6 D2 4F F4 33 1D A0 5F E9 77 FA 83 8E D0 51 81 6A 81 13'\r\n '74 8A CE 52 2D D5 91 42 42 A3 D2 52 28 85 91 9E 8C 64 26 2B 35 A1 48 6A 46 D1 14 4B 76 4A 20 07'\r\n 'B9 28 91 3C 94 4C 5E 4A A5 74 6A 45 99 94 AD 41 07 0D 3A 53 37 0D 72 34 E8 41 7D A9 3F 5D 45 B9'\r\n '34 48 83 67 34 78 4E 83 77 35 98 AE 55 CD A0 BB E8 3E 2D EE D7 62 09 BD A5 C5 D7 5A 94 6A 51 A6'\r\n '45 85 16 55 5A 7C 47 3F D0 1E DA 4B 3F D1 CF 74 80 7E A5 DF E9 0F 3A 42 47 B5 38 A1 C5 29 FA 8B'\r\n '6A B5 38 A7 85 2F 04 A3 43 30 86 C6 D1 04 BA 99 26 D1 6D 34 99 A6 D2 74 9A 41 B3 E8 2E BA 87 EE'\r\n 'A3 FB 69 0E CD A3 C7 E8 71 7A 92 9E A2 67 E8 39 FA 07 BD 40 2F D1 2B B4 94 5E A3 37 E8 4D 5A 41'\r\n '85 54 4C 6F D3 BB F4 1E AD A2 0F E9 23 5A 4B EB E8 13 DA 48 9B 68 33 6D A5 CF E9 4B DA 4E 5F 87'\r\n '60 67 08 CA 68 17 55 50 15 7D 47 3F D0 1E DA 4B 3F D1 CF 74 80 7E A5 DF E9 0F 3A 42 47 E9 18 9D'\r\n 'A0 53 74 86 CE 52 2D D5 91 42 22 54 A5 A5 50 0A 23 3D 19 C9 4C 56 6A 42 91 D4 8C A2 29 96 EC 94'\r\n '40 0E 72 51 22 79 28 99 C6 84 E2 61 FF 3E 35 01 A9 09 18 9B 80 BB 12 70 4F 02 5E 4C 80 68 AE D2'\r\n '52 28 85 91 9E 8C 64 26 2B 35 A1 48 6A 46 D1 14 4B 76 4A 20 07 B9 28 91 3C 94 4C 5E 4A A5 74 6A'\r\n '45 99 94 4D 6D A8 1D 75 A0 4E D4 85 BA 51 77 EA 49 BD A9 2F F5 A7 AB 28 97 06 D1 35 74 2D 5D 4F'\r\n 'C3 68 04 8D A4 9B 68 34 8D A1 71 34 81 6E A6 49 74 1B 4D A6 A9 34 9D 66 D0 2C BA 8B EE A1 FB E8'\r\n '7E 9A 43 F3 68 01 2D A4 87 E9 51 7A 8C 1E A7 27 E9 29 7A 86 9E 6B 8E 57 9A 63 29 BD 46 6F D0 9B'\r\n 'B4 82 0A A9 98 DE A6 77 E9 3D 5A 45 1F D2 47 B4 96 D6 D1 27 B4 91 3E A5 CF 68 0B 6D A3 2F E8 2B'\r\n 'DA 41 3B A9 8C 76 51 05 55 D1 77 F4 03 ED A1 BD F4 13 FD 4C 07 E8 57 FA 9D FE A0 23 74 94 8E D1'\r\n '09 3A 45 67 E8 2C D5 52 1D 29 FE F7 B3 03 36 07 9A 39 E0 74 20 D9 01 9F 03 ED 1C C8 71 A0 B7 03'\r\n '83 1D 18 E6 40 9E 03 37 3B 30 CD 81 FB 1D 98 EB C0 C3 0E 2C 71 E0 1F 0E 2C 73 60 85 03 2B 1D F8'\r\n 'C0 81 D5 0E 7C E4 C0 06 DA E4 C0 66 07 B6 3A B0 CD 81 52 07 76 39 50 E9 40 95 03 FB 1C F8 D5 81'\r\n 'E3 0E 9C 74 E0 B4 03 67 1C 30 B8 54 16 17 AC 2E 44 52 2B 6A 4D 1D A8 B3 0B 5D 5C E8 E3 42 7F 17'\r\n 'AE A6 07 C9 97 86 51 69 18 43 13 D2 30 31 0D B7 D0 AD 74 3B 4D A7 19 69 98 99 86 3B D3 30 3B 0D'\r\n 'F3 68 01 2D A4 87 E9 51 7A 8C 1E A7 27 E9 29 7A 86 9E A3 7F D0 0B F4 12 BD 42 4B E9 35 7A 83 DE'\r\n 'A4 15 54 48 C5 F4 36 BD 4B EF D1 2A FA 90 3E A2 B5 B4 8E 3E A1 8D F4 29 7D 46 5B 68 1B 7D 41 5F'\r\n 'D1 0E DA 49 65 B4 8B 2A A8 8A BE A3 1F 68 0F ED A5 9F E8 E7 34 FC 92 86 C3 F4 27 21 1D 9E 74 74'\r\n 'CF 57 F5 A4 DE D4 97 FA D3 55 94 4B 83 E8 1A BA 96 AE A7 61 34 82 46 D2 4D 34 9A C6 D0 38 9A 40'\r\n '37 D3 24 BA 8D 26 D3 3C 5A 40 0B E9 61 7A 94 1E A3 C7 E9 49 7A 8A 9E A1 E7 E8 1F 94 B8 42 E5 A1'\r\n '64 F2 52 2A A5 53 AB 15 C8 5C 81 6C 6A 43 ED A8 03 75 A2 2E D4 8D BA 53 4F EA 4D 7D A9 3F 5D 45'\r\n 'B9 34 88 AE A1 6B E9 7A 1A 46 23 68 24 DD 44 A3 69 0C 8D A3 09 74 33 4D A2 DB 68 32 4D A5 E9 2B'\r\n '70 F7 0A DC 4B B3 69 0E CD A3 05 B4 90 1E A6 C5 F4 04 3D 45 AF D1 1B F4 26 AD A0 42 AA 21 D4 42'\r\n '57 8B C8 5A 44 D7 A2 BB 82 1B 14 B4 0C 11 83 42 44 5C B9 C8 2E 17 57 97 8B EB CA C5 D0 72 71 73'\r\n 'B9 98 5F 2E 5E 2A 17 AB CB C5 DA 72 B1 8E 3E 29 17 9F 95 8B 2D E5 62 67 B9 38 54 2E B4 15 A2 79'\r\n '85 68 57 21 86 54 88 DB 2A C4 43 15 62 69 85 F8 B8 42 EC AA 10 7F FA F7 9A 95 C2 5D 29 3A 55 8A'\r\n 'A1 95 62 6A A5 58 54 29 DE AC 14 9B 2A C5 F7 95 62 77 A5 F8 A9 52 9C AB 14 4D AB 44 54 95 B0 57'\r\n '89 B6 55 E2 EA 2A 31 B8 4A 5C 5F 25 A6 55 89 47 AA C4 A2 2A F1 64 95 28 AA 12 9B AA C4 E6 2A F1'\r\n '45 95 F8 8A 34 06 00 5B 84 EA 73 FA 8A 8E D3 23 0E 3C E9 C0 3F 1D 58 EA 40 81 03 EF 3A B0 9E B6'\r\n 'D3 39 D2 7E E1 FF 05 A0 C5 54 2D 16 84 E0 51 FF A2 30 14 9F 84 62 23 7D 1A 8A 4D A1 D8 1C 8A 2D'\r\n 'A1 D8 46 36 1D E2 74 B8 4A 87 D1 3A 4C A3 4A 1D 76 EB B0 57 87 5F 74 F8 55 87 DF 74 38 A4 C3 11'\r\n '1D 9A 84 A9 7C 61 18 10 86 FC 30 AC 0C C3 1F 61 38 11 86 A8 70 C4 86 C3 1E 8E C4 70 78 C2 91 1C'\r\n '0E 6F 38 D2 C3 31 22 1C 23 C3 01 3D 34 7A 74 A4 CE D4 5D 8F 7E 7A E4 D2 35 7A 0C D3 63 AC 1E E3'\r\n 'F4 98 47 EB E9 53 3D 36 EB B1 83 F6 EB F1 B3 1E C2 00 FF 4B D3 99 BA 1B D0 C3 80 BE 06 F4 33 E0'\r\n '2A 03 72 0D B8 86 A6 19 30 DD 80 59 34 CF 80 F9 06 AC A7 4F 0D D8 62 C0 36 03 3E 37 60 07 ED 37'\r\n 'E0 67 03 84 51 D5 99 BA 51 77 23 7A 19 91 4B 43 69 AC 11 E3 8C 98 4F 25 B4 83 BA 9A 90 63 42 1F'\r\n '13 FA 99 30 C0 84 5C 13 AE 37 61 A8 09 63 4D 18 67 C2 7A DA 48 5B 69 BB 09 3B 4C D8 6F C2 CF 26'\r\n '74 37 A3 97 19 B9 34 D6 8C 71 66 7C 49 DF 98 51 6E 46 25 65 5A 54 AD 2D E8 68 41 5F 0B AE B6 E0'\r\n '3D FA C0 82 B5 16 AC B3 60 BD 05 9F 5B B0 C3 82 18 2B 62 AD 68 43 ED A8 03 4D B7 E2 01 2B E6 5A'\r\n 'F1 A0 15 0F 59 F1 B0 15 8F 5B F1 0F 2B 5E B0 62 BD 15 5B 29 DD 06 9F 0D 59 36 B4 B3 A1 83 0D 1D'\r\n '6D E8 62 43 57 1B 86 DB 30 C2 86 51 36 E4 D9 30 DD 86 99 36 CC A7 85 36 3C 64 C3 E3 F4 0A DD 14'\r\n '89 D1 91 88 88 46 D3 68 64 45 A3 75 34 86 44 E3 DA 68 DC 11 8D 19 D1 F8 28 1A 9F 44 63 2B 7D 11'\r\n '8D 5D D1 D8 43 C6 18 98 63 50 48 CE 58 B8 63 91 1C 8B 96 B1 C8 A2 0E B1 E8 14 8B E8 38 C4 C4 61'\r\n '28 0D 8F C3 A8 38 E4 D1 58 9A 10 87 DB E3 30 23 0E B3 E3 30 87 60 87 D6 8E D6 D4 D6 8E 8E 76 74'\r\n 'A6 1E 74 9B 1D 33 EC 98 6B C7 3C 3B 5E B7 E3 4D 3B 0A EC 28 B4 E3 20 FD 66 C7 EF 76 1C A1 A3 76'\r\n '1C B3 23 2D 1E D9 F1 68 1B 8F 76 F1 28 8D C7 37 F1 28 8F C7 BE 78 EC 8F C7 6F F1 38 42 25 09 38'\r\n '98 80 73 09 50 12 50 EA 44 B5 13 47 D3 70 2C 0D 73 D2 55 FB D2 A1 A4 23 C5 87 56 3E BC E0 C3 8B'\r\n '3E 4C CD C7 1D F9 98 9D 8F FB F3 51 9D 8F 63 F9 D0 14 A8 74 64 24 4F 01 92 0A B0 99 F6 15 E0 98'\r\n 'FF BB 85 48 2F 44 DF 42 5C 53 88 B9 85 98 5F 88 55 B4 BA 10 6B 0B B1 9E BC 45 C8 28 42 66 11 B2'\r\n '8A D0 A6 08 6D 8B D0 93 06 D2 4A 7A BF 08 1F 14 E1 A3 22 AC 29 C2 86 22 6C 2C C2 A7 74 A0 58 F5'\r\n '1B 1D A1 E6 B5 2A D4 C3 5A 0F 67 3D 92 EA 51 27 84 9F 30 08 AD 41 84 1A 84 CE 20 4C 06 61 35 88'\r\n 'F6 06 D1 D1 20 BA 91 B0 A9 DA DB 44 1F 9B 98 6B 13 F3 6C 62 95 4D AC B6 89 B5 36 F1 B1 4D DC 5C'\r\n '26 26 95 89 FB CA C4 FC 32 B1 B0 4C 3C 56 26 8A CA C4 DB 65 A2 C7 37 A2 D7 37 02 C2 72 54 58 42'\r\n 'A6 AB 77 2E BD AA 13 75 D5 23 47 8F FE 7A 0C D4 E3 6A 3D 06 E9 31 5F 8F 05 7A 6C D0 A3 44 8F 6D'\r\n '7A 7C AE C7 57 7A 6C D7 A3 8A B4 06 55 57 03 72 0C 58 40 1B 0C 28 31 E0 0B FA CA 80 ED FE BB 88'\r\n '11 5A FF E5 4B 39 D4 D7 88 7E 46 5C 65 C4 40 23 86 D1 06 23 36 1A F1 A9 11 9B 8C D8 6A C4 E7 46'\r\n '7C 69 C4 76 23 AA 48 98 A0 F5 5F C4 26 F4 32 61 BE 09 0B 4C D8 40 25 26 6C 36 61 9B 09 9F 9B F0'\r\n 'A5 09 5F 99 50 61 42 A5 09 1A 33 B4 66 74 35 23 C7 8C 3E 66 F4 33 63 80 19 03 CD 18 46 F3 CD 58'\r\n '60 C6 4E 33 CA CC F8 D6 8C BD 66 1C 37 E3 84 FF E7 5B D1 CD 8A 39 94 6A 43 9A 0D 99 D4 9E 3A D9'\r\n 'D0 D9 86 A1 36 0C B3 61 AC 0D E3 6D B8 D9 86 C9 36 2C B0 E1 41 1B 1E B6 61 B1 0D 4F D2 8B 36 BC'\r\n '6C C3 EA 68 D5 86 68 6C 89 C6 B6 68 7C 1E 8D C4 58 24 C5 C2 1B 8B D4 58 F8 62 91 19 8B EC 58 B4'\r\n '8F C5 CA 58 94 C4 E2 F3 58 7C 11 8B D8 38 D8 E3 70 3D 0D A3 31 34 2E 0E E3 E3 30 39 0E 77 C4 21'\r\n 'C4 AE 6A 43 9D A8 8B 1D DD ED E8 69 47 2F 3B E6 D3 6B 94 6F C7 0A 3B 8A E8 57 3A 64 C7 61 3B FE'\r\n 'A4 E3 76 9C B0 A3 45 3C 52 E3 D1 3A 1E 6D E2 F1 13 1D A7 C4 02 B4 28 40 32 CD 2D C0 BC 02 7C 50'\r\n '80 CF 0A 30 A4 10 D7 16 62 01 7D 50 88 0F 0B F1 71 21 D6 15 E2 93 42 94 14 A2 55 11 7C 45 C8 2E'\r\n '42 EB 22 E4 D2 7D F4 73 31 7E 29 C6 C1 62 FC 5A 8C DF 8B 71 A8 18 87 49 06 75 34 34 9F 56 DA C4'\r\n 'FB 36 F1 91 4D AC B1 89 09 65 62 62 99 98 5C 26 EE 28 13 A1 21 FE B7 EA 23 7C BE EE 71 62 9F 13'\r\n 'FB 9D F8 C5 89 69 BC C2 75 49 FE FF E8 03 3A 00 79 3A 4C D2 A1 5A 87 B3 3A 94 84 E1 8B 30 4C D4'\r\n '63 AA 1E 07 F5 38 AA C7 44 03 A6 1A 70 D0 80 A3 06 4C 34 62 AA 11 07 8D 38 6A C4 44 13 A6 9A 70'\r\n 'D0 84 A3 26 4C 34 63 AA 19 83 2D 18 61 41 A9 05 DF 59 E0 B4 C2 6B 45 8E 0D FD 6D 58 62 C3 0B 36'\r\n 'EC 8B C6 EF D1 B0 C5 20 36 06 7D 62 31 28 16 A5 B1 F8 2E 16 73 E3 F0 68 1C 96 C4 E1 85 38 0C B6'\r\n '63 84 1D 2B ED 58 6B 47 4E 3C FA C7 63 70 3C 46 C4 C3 99 0F 6F 3E 4A 0B F0 5D 01 50 08 7D 21 4A'\r\n '0B F1 5D 21 06 17 61 44 11 AA 8B 71 B6 18 36 05 B1 0A 96 85 88 C2 10 31 D1 26 A6 DA C4 D7 55 42'\r\n 'A9 12 61 26 FF 5F F4 CF 28 54 47 21 CF 85 F9 2E 2C 74 E1 11 17 C2 7C 2A 97 0F 5E 1F DA FB D0 D1'\r\n '87 83 F9 38 9A 8F 1C 21 66 0A D1 5D AB 1A 40 65 5A 51 A1 55 03 4E 63 5B 88 70 AF FF 17 7B 1F 58'\r\n '05 AC A5 F5 C0 06 E0 A4 1E 67 F5 B8 C3 88 BB 8C A8 36 E2 B8 11 77 9B F0 80 09 D3 CC 98 65 46 8A'\r\n '15 D9 56 4C 8A C4 EC 48 54 47 E3 6C 34 BE 8F 55 4D 73 AA 66 3A 71 8F 13 73 9D 78 D4 89 C1 2E 8C'\r\n '76 E1 51 CA 6B 81 97 5A E0 50 0B 28 2D 70 67 32 9E 49 46 5D 9A EA E9 4C 3C 97 09 67 16 BC 59 B8'\r\n '26 0B A3 B3 30 37 0B 8F 66 E1 BD 2C 6C CC 82 AF 00 6D 0A 10 26 44 B6 10 B3 84 B8 5B 88 45 E4 D4'\r\n '8A 44 AD 18 1E 2E 46 87 8B 28 BD B0 EB 45 8E 41 F4 35 88 FB 0D E2 01 83 18 6E 14 A3 8D E2 6E A3'\r\n '98 63 14 79 16 F1 80 45 0C F1 BF 95 6C 22 6F 97 98 BE 4B 4D FA 18 8E 09 BD 7F 9D 04 27 2D A3 B9'\r\n '51 2A 4B 8C CA FF A3 06 27 5A D1 68 52 DF 5B 3E 35 63 06 B4 74 AA 8C A1 FE 0F 0D 64 A6 78 86 0D'\r\n '16 92 D7 A9 32 69 C0 6F 0E 60 0E B0 D4 FF B3 AC FE EF BD 4D D0 41 AB C3 1E B2 86 A9 3E 88 C6 87'\r\n 'FE A7 B4 13 56 27 52 9C C8 70 22 CF 89 F1 4E DC EA C4 54 27 94 7A D5 59 05 B5 0A 3E B1 09 BF 19'\r\n '65 E2 DE 32 21 E3 6E 4E 58 E6 C0 62 51 FF 74 F8 16 CA 5E 58 B5 EA 87 FB A0 FC E5 FF 97 B5 4E F1'\r\n 'FF C6 B6 3A C5 D6 24 D3 FF DD 95 1A 7C AA C1 56 0D CA 34 D8 A7 C1 2F 1A 1C A6 3F 69 A6 56 75 2F'\r\n '8D 08 55 E5 E8 54 07 74 38 A8 C3 C9 30 9C 0A 43 0D C5 85 AB 5A 50 4B 9A AE 57 F5 B1 A8 B6 D2 39'\r\n '9B AA 2A 5A D5 33 46 B5 22 4E 75 77 3C EE 8F 47 5A 02 C6 24 E0 6E 7A 29 01 1B 13 30 DD A9 9A 43'\r\n '4B 9C 78 D9 89 FB D3 54 53 D3 55 AD 32 54 A1 3E 55 A6 0F 6D 7C E8 44 AF F8 F0 AA 0F E7 7C A8 F7'\r\n 'A1 D9 32 D5 5F CB 51 B7 1C A6 7C D5 1C 8A 5E 01 C7 0A 4C A3 47 68 67 A1 6A 5A 91 6A 0F 4D 53 54'\r\n 'AF 2A 58 AA 20 A2 A7 FF D5 5C 27 54 25 02 9F 09 3C AB 51 95 86 E2 50 28 AA 43 71 3C 14 4E 1D BA'\r\n 'E9 D0 5D 87 01 3A 4C D1 61 AA 0E D3 75 D8 A5 43 05 FD A9 C3 51 1D 6A 74 38 A7 83 42 B6 30 55 44'\r\n '18 5A 85 21 37 0C 6F 86 E1 3D FA 32 0C 87 C2 80 70 34 0B 47 4E 38 86 87 23 44 8F 0E 7A 74 A1 C1'\r\n '34 5C 8F 31 FE 4B 52 8F BB F4 B8 47 8F 39 7A 2C D4 63 B1 1E 4F EA B1 44 8F 67 F4 28 D0 A3 48 8F'\r\n '95 7A BC 4F AB F5 58 AB C7 27 F4 35 ED D6 63 8F 1E 7B F5 F8 49 8F 6A 3D 8E E9 11 6A 80 C1 00 AB'\r\n '01 36 03 22 0D 68 69 40 8A 01 3E 03 B2 0C C8 36 A0 8D 01 6D 0D 68 6F 40 07 03 46 18 70 A3 01 A3'\r\n 'E8 0E 03 66 1A B0 D0 80 C7 0D 78 D2 80 A7 0C 78 C6 80 02 03 8A 0C 58 69 C0 FB 06 AC 32 E0 43 03'\r\n 'D6 1A F0 09 95 D2 3E 03 7E 32 20 D4 08 93 11 56 23 6C 46 44 1A D1 D2 88 14 23 7C 46 64 19 91 6D'\r\n '44 1B 23 3A 18 D1 85 6E 34 E2 26 23 46 1B 31 C6 88 E9 B4 80 16 1A B1 C8 88 27 8C 58 62 C4 D3 46'\r\n '3C 67 C4 0B 46 BC 68 C4 CB F4 AA 11 4B 8D 78 C3 88 E5 46 14 18 51 64 C4 3B 46 AC 35 A2 94 42 4D'\r\n '30 99 60 31 C1 66 42 84 09 2D 4D 48 31 21 DB 84 36 26 74 30 A1 0B 0D 37 61 84 09 79 26 8C 31 61'\r\n 'A1 09 8B 4D 78 C2 84 25 26 3C 6D 42 81 09 45 26 AC 32 E1 43 13 D6 9A F0 09 FD 48 FB 4C F8 C9 84'\r\n '63 26 1C 37 21 D4 0C 93 19 16 33 6C 66 44 98 D1 D1 8C 2E 74 35 E5 99 31 C6 8C 7B CD 98 63 C6 42'\r\n '33 9E 37 E3 45 33 DE 33 63 95 19 EB CC F8 84 4A CC D8 6A F6 2F CF E0 B3 20 CB 82 6C 0B 72 2C E8'\r\n '6D C1 3C 0B E6 5B F0 20 3D 6C C1 23 16 2C A2 C7 E9 59 0B FE 61 C1 0B 16 2C B5 E0 35 0B DE B0 E0'\r\n '4D 5A 41 45 16 14 5B F0 B6 05 2B 2D 78 DF 82 55 16 7C 42 25 16 6C B6 60 B7 05 7B 2C FE 1B 85 2A'\r\n 'C7 8A BE 56 F4 B7 E2 76 2B 1E B1 62 B1 7A EB 40 8A 0D DD 68 B0 0D D7 DB 70 83 7F 13 62 C3 18 9A'\r\n '60 C3 44 1B A6 D8 30 CD 86 59 36 CC B3 E1 09 2A B5 A1 C6 06 34 41 BF 08 0C 88 40 6E 04 06 47 60'\r\n '68 04 86 D3 0D 11 B8 29 02 79 11 78 24 02 8B 22 F0 78 04 96 44 60 65 04 DE 8F C0 87 11 58 13 81'\r\n '0D 11 28 A1 4D 11 D8 12 81 CF 23 50 19 81 6F 23 60 F3 EF 7C 22 D1 2C 12 31 91 B8 21 12 73 23 F1'\r\n '64 24 96 45 E2 64 24 44 53 DC 1E 85 A9 51 98 13 85 79 51 78 31 0A CB A2 70 28 0A 88 86 29 1A 96'\r\n '68 34 89 86 33 1A 99 D1 C8 89 C6 35 D1 C8 8B C6 ED D1 98 12 8D 69 D1 98 1B 8D 55 D1 D8 4D CE 18'\r\n 'F4 88 41 AF 18 DC 15 83 B9 31 28 88 41 11 AD 8C C1 29 FF B3 21 16 F1 B1 18 1C 8B C9 FE 47 5E 2C'\r\n '66 FA 1F F9 B1 28 8E C5 A7 B1 D8 16 0B C4 21 2A 0E CE 38 5C 17 87 50 3B B2 ED E8 6D C7 55 76 2C'\r\n 'B0 63 99 1D EF D8 F1 AE 1D 25 76 1C B0 AB 0F 8C C4 78 E4 C6 63 50 3C 6E 88 C7 5D F1 F8 3D 1E 87'\r\n 'E3 F1 67 3C 8E F9 D7 62 2E B4 77 C1 97 8E 09 E9 98 9B 8E E7 D3 B1 2C 1D F9 E9 28 48 C7 3B E9 58'\r\n '99 8E D5 E9 58 93 8E 0D E9 28 49 C7 D6 74 7C 9E 8E AF D3 51 9A 8E CA 74 7C 9B 8E 1F D3 A1 F3 A9'\r\n '3A 53 77 1F 9E F7 61 29 BD E6 43 8D 0F 0A 85 66 22 3D 13 99 99 78 22 13 CB 32 F1 71 26 AA 33 A1'\r\n 'F8 1F 12 AD F1 61 2E 70 35 BE 5A AA 3E 1B 9B 2E 43 D4 32 2C 5E 8E D2 E5 38 B3 1C 78 13 C6 7C D8'\r\n 'F2 E1 C8 47 4A 3E 52 F3 31 85 96 E5 E3 40 3E 6A 57 40 14 40 5B 80 50 FF 83 BB 00 86 02 98 0A E0'\r\n '2E 40 4E 01 66 14 60 7E 01 56 15 E0 78 01 CE 14 A0 96 0C 85 F0 14 C2 57 88 3E 85 C8 2B C4 EC 42'\r\n '3C 58 88 F7 0B D5 9E 7E CB 22 E4 14 A1 47 11 7A 15 E1 AA 22 E4 15 61 6A 11 A6 17 E1 CE 22 DC 4B'\r\n '73 8B F0 6E 11 DE A3 0F 8B B0 BA 08 6B 8B F0 49 11 4A 68 13 FD 50 84 DD 45 10 C5 D0 15 43 5F 0C'\r\n '4B 31 9A 14 23 AA 18 CE 62 24 15 A3 65 31 32 8A 51 52 8C FD FE A5 E8 5B 78 A3 0A 2B AB B0 B5 0A'\r\n '5F 55 A1 B6 0A 38 8B F4 1A F8 6A 30 B9 06 D3 6A F0 5D 0D 12 6A 55 8E 5A B4 AC 45 4A 2D DA D6 A2'\r\n '7D 2D 3A D7 A2 2B E5 D4 A2 7B 2D 7A D6 A2 57 2D FA D4 E2 BD 5A EC AA 45 97 3A 0C AE C3 93 75 78'\r\n 'BA 0E DB EA 50 5D 87 DA 3A 4C AB C7 CC 7A DC 59 8F 73 F5 98 A8 60 AA 82 E9 0A 5E F1 2F F8 14 6C'\r\n '50 B0 49 C1 36 05 5F 2A D8 A9 E0 1B 05 55 0A BE 57 B0 5B 51 53 F0 FE BD 90 FF DE 90 04 D1 12 A2'\r\n '23 44 67 88 2E 10 DD 20 72 21 06 43 DC 04 31 17 A2 C6 FF 4F 8D 78 59 23 96 69 44 A9 46 4D 3E 34'\r\n 'D7 0A 9F 56 E4 68 45 0F AD E8 AF 15 73 B5 E2 15 AD 58 A6 15 9F 69 C5 E7 5A B1 53 2B 06 87 88 57'\r\n '42 D4 28 7D 68 B8 08 27 43 B8 68 13 2E DA 85 8B F6 E1 A2 33 75 0B 17 D7 87 AB A9 89 66 7A E1 D4'\r\n '8B 0E FA F3 B9 7B 9B 41 44 1A 44 33 83 88 36 88 58 83 C8 36 88 3C 83 98 6D 50 93 15 6D 8C 22 C7'\r\n '28 AE F7 2F C3 8C E2 0E A3 1A CF EF 67 12 5A 9B 68 67 13 0B 6C E2 5D 9B 1A BA 9F 92 A8 46 E9 33'\r\n '5A AB 71 F5 F6 B7 AA 5D 7E B1 52 4D 5B 57 E6 6B B0 42 D3 FA 23 4D CE 47 9A 84 35 1A FC A5 49 A8'\r\n 'D1 44 EA FC 2F C2 68 EA E6 44 8E 13 D7 51 76 3D 5A D7 23 B7 1E 83 EA D1 4D 51 35 8D 84 5A BA 56'\r\n '2D 0A 55 6D 20 34 55 E9 62 54 36 27 9A 39 71 2D DD 47 8F 51 84 5B 15 9D A1 8A A3 78 9F CA 47 CB'\r\n '28 B3 1E 59 F5 18 4E E3 C8 AC A8 9A F5 53 57 88 34 92 EE A3 8E 56 55 67 7A 29 4A 15 E7 54 35 A7'\r\n 'DE 74 3F 3D 4E DE 44 D5 2D C9 AA 5B E9 76 9A 42 D3 E8 0E 9A 49 5B E8 20 FD 46 87 E8 30 FD 49 0B'\r\n 'BC AA 85 F4 30 3D 4A 8F D1 E3 F4 24 3D 45 CF D0 73 F4 0F FA 96 BE A7 73 E4 CE 50 B5 A0 24 6A 49'\r\n 'E1 3E 95 81 4C 64 21 1B 35 A5 28 8A A1 38 4A A0 AE 75 AA E8 7A 55 1B 6A 47 1D A8 13 75 A1 6E D4'\r\n '9D 7A 52 5F 1A 41 23 E9 26 0A 57 54 9D 68 24 8D A6 B1 14 D5 C7 FF 49 F3 D2 4D 74 3F 75 B2 AA BA'\r\n 'D0 CB 51 AA 3E 4E D5 03 F4 04 A5 24 AA 26 25 AB 6E A3 C9 34 95 A6 D3 0C 9A 45 5B E9 57 FA 9D FE'\r\n 'A0 23 74 94 1E F4 AA 1E A2 47 68 11 2D A6 27 68 09 3D 4D CF D2 F3 F4 4F FA 8E 7E A0 3A 4A CC 50'\r\n '79 28 99 BC A4 F7 A9 8C 64 26 2B 35 A1 66 14 4D B1 64 A7 E6 3E 38 7C E8 56 A7 8A A9 57 B5 A5 F6'\r\n 'D4 91 3A 53 57 CA A1 1E D4 8B FA D1 0D 74 23 8D 22 BD A2 EA 42 37 51 1E 8D A3 68 A3 FF 13 55 4C'\r\n '31 4E 95 DD 89 78 27 1C D4 81 34 19 AA 10 D2 93 89 E2 C9 49 31 6A C1 7F 1D C5 3A 55 09 D4 91 B4'\r\n '19 AA 50 32 90 99 12 C8 45 B1 73 FD BF 80 0B 48 04 3C 40 32 90 42 69 94 01 B4 F2 5F F1 FE F7 8F'\r\n 'FF 1E 05 E4 00 37 D2 6B F4 11 6D A4 07 B4 AA 87 E9 86 50 8C 0E C5 A3 54 42 9F D1 56 3A 11 8A 93'\r\n 'A1 D0 EB 60 D0 C1 A4 83 59 07 3B 35 D7 C1 A1 C3 AD 3A 4C D6 A1 9C 10 06 73 18 CE 84 E1 6C 18 7C'\r\n 'E1 E8 1A 8E 51 34 5E 8F 09 7A 4C A3 93 66 D5 20 8B EA 06 0B 46 5A 10 62 45 84 15 0B A9 D4 8A 72'\r\n '2B BE B3 E2 7B 2B 06 D8 30 C8 86 5A 1A 13 89 5B 22 31 39 0A 53 A2 F0 47 14 8E 44 A1 4D 34 DA 46'\r\n 'A3 3C 1A 95 D1 F8 36 1A DF 47 FB 3F 2D 08 8D 41 58 0C 0C FE 05 54 2C 7A C7 A2 79 1C 1C 71 58 16'\r\n '87 FC 38 14 C4 E1 ED 38 DC 60 47 9E 1D E7 EC 50 EC E8 14 8F 6E F1 78 20 1E 73 E2 B1 8B A2 9C 88'\r\n '76 C2 E9 44 B2 13 3E 27 DA 3B D1 C9 89 AE 4E 74 77 A2 A7 13 7D 9D B8 26 70 CB BE DE 89 51 4E 9C'\r\n '4D C3 B9 34 D4 A7 41 49 C3 B4 74 95 FF 13 20 32 A0 F3 DF 84 32 60 24 4B 06 A2 FC 9F 75 FF E7 2D'\r\n '03 76 6A 9E 01 47 06 52 32 90 91 01 5F 06 32 FD FF 8B 0F 5A 1F BA 50 2D D5 2F 87 B2 1C E6 7C 58'\r\n 'F3 31 83 1E A0 E3 F9 38 93 8F 99 05 B8 AB 00 5F 17 60 67 01 FE 2A 40 4D 01 32 0A D1 AA 10 A3 E9'\r\n 'D3 42 EC 28 C4 8F 85 D8 5B 88 1B 8B 30 BA 08 3F 16 61 6F 11 FE 28 56 D9 EA 11 55 8F 58 F2 51 EF'\r\n '7A F4 A9 47 FF 7A 0C AC C7 E0 7A 0C A9 C7 75 F5 18 56 8F D1 F5 18 53 8F 5B E8 D6 7A DC 56 0F A1'\r\n '40 AB 20 54 41 98 02 03 99 C8 A2 C0 AA 20 4E 81 5D 81 43 81 53 41 67 1A 43 E3 15 4C 60 16 D2 FF'\r\n '6D A9 56 55 4A C3 C2 55 0E BD AA 1B 0D 36 88 E1 06 31 87 3A 18 45 37 A3 E8 6B 13 B9 36 B1 CE 26'\r\n 'D6 DB C4 06 9B F8 D4 26 A6 B5 10 33 5A 88 B8 1E FE 8B 20 95 3A 03 5D 81 D9 F4 00 BD 45 EF 51 15'\r\n '9D A1 D3 5A 95 4E 87 70 1D 7A 39 55 43 E8 5E 27 66 3B B1 C8 89 C5 FE EB DA A5 CA 71 A1 97 0B 57'\r\n 'D1 12 17 9E 75 E1 45 17 5E 72 61 19 BD 41 F9 F4 0E 7D ED C2 4E 17 BE A1 72 3A E9 82 E2 46 78 22'\r\n '8C 89 70 26 C2 95 88 D9 F4 52 22 56 25 62 77 22 7E 4A C4 47 1E D5 A7 F4 97 07 8A 07 53 93 54 25'\r\n 'C9 D8 9C 8C 6D C9 F8 32 19 DB E9 EB 64 1C 48 46 75 32 94 64 F5 49 31 DF 8B 17 BC A8 F2 62 B7 17'\r\n 'B5 5E D4 7B A1 A4 C0 97 8A 5E A9 E8 9B 8A 81 A9 F0 D6 AA C6 D6 AB C6 FB 17 79 F5 30 2A AA 78 05'\r\n 'CD 15 DC 48 A3 68 3F FD AE E0 B0 82 4F 2B 85 DF 0F 54 4B CD AA 54 6D 68 10 4D A5 47 A9 90 3E 23'\r\n 'BB 7F BB 85 16 F4 BA BA 48 87 51 A7 3A AE C7 09 3D 6A E9 98 41 75 D6 A8 EA 66 51 FD 10 AD 5A E6'\r\n 'C4 5A FF C5 56 A0 3A 57 A7 9A 54 AF 0A 51 54 FB 14 FC A4 E0 80 82 83 FE 3F BE 7F E7 82 51 94 47'\r\n '05 F4 2E 7D 40 6B 68 93 06 5B 34 F8 46 83 BD 1A 1C D0 E0 0F 0D 8E D0 51 0D 14 0D 66 69 55 0F 6A'\r\n 'B1 50 8B 4F 1C AA 8D 0E 7C EA C0 0E 07 76 3A B0 C7 81 BD 0E 1C 71 E0 A8 03 75 0E D4 3B F0 92 0F'\r\n '2F FB 80 15 88 5A 01 E7 0A B8 56 E0 D1 15 58 B4 02 EF D7 E2 53 FF D2 5B 51 E5 D0 CF 94 E0 DF A6'\r\n '20 5F FD 1F 50 48 EF D0 4A 5A 4D F3 43 54 16 1D AC 3A FC 48 BF 53 9D 0E F5 3A 9C 0E 53 D5 E8 55'\r\n 'D3 8C AA 13 46 FC 65 44 0D CD 31 A9 EE 31 AB 84 15 5A 2B 22 AD 88 B6 22 CE 0A 87 15 AD A9 2D B5'\r\n 'A7 0D 56 6C B1 62 9B 15 DB AD F8 DA 8A 9D 56 54 58 F1 AD 15 AF DA B0 D4 86 BC 48 D5 92 48 BC 10'\r\n '89 9C 58 D5 8F B1 50 62 31 C6 8E 5B ED 98 69 C7 6C BB FA B8 11 2E 68 5D D0 B9 10 EE 82 DE 85 A6'\r\n '14 E5 42 B4 0B CD 5D 48 74 C1 43 C9 E4 A5 0C EA E8 42 27 17 06 D0 40 17 72 5D 18 44 CF B9 F0 82'\r\n '0B 2F BB B0 D4 85 D7 5C 78 DD 85 E5 2E BC E9 C2 0A 17 DE 76 E1 5D 17 76 B8 50 EA 42 99 0B BB A8'\r\n 'C2 85 13 7C EA 85 25 C2 94 08 47 22 DC 89 68 99 88 D4 44 DC 97 88 FB 13 F1 62 22 3E 48 C4 0F 89'\r\n 'D8 9F 88 13 89 EA 3B 31 A9 05 72 5A 60 40 0B BC DC 02 BF B7 50 1F 97 AB 3D 58 E3 41 89 07 9B 3C'\r\n '38 E3 7F 7A 26 61 4A 12 A6 25 41 F1 EF 69 92 71 73 32 9E 4D C6 C6 64 75 05 AD B4 54 6F 2E AD 52'\r\n 'D1 3B 15 7D 52 31 38 15 23 52 71 20 0D 87 D2 30 37 03 2F 64 E0 A5 0C 9C E0 D3 B6 A2 15 AA 5B A1'\r\n 'B6 15 42 7C AA 08 1F 22 7D 70 52 5B 1F DA F9 D7 94 FE D5 8A 0F 4B 32 F1 54 26 9E CF C4 D2 4C 94'\r\n '64 E2 67 FF 46 37 0B CD B3 90 92 85 C1 59 C8 CB C2 9C 2C 2C CA C2 CA 2C 94 64 A1 3E 0B C8 86 92'\r\n '8D 92 5C 28 B9 58 B2 1C 5B 97 A3 65 01 52 0B D0 B6 00 ED 0A D0 81 EE 2A C2 3D 45 A8 AB 53 FD A2'\r\n 'A8 7E A3 23 0A FE 54 70 4E 41 9D 02 8D 10 7E ED 84 E8 26 C4 3D 42 3C 2A C4 12 21 5E 12 A2 54 88'\r\n '73 42 0D 28 9F 2A 55 4F B6 26 95 09 6F 99 18 5F 26 6E 2D 13 B7 97 89 05 65 E2 C1 32 B1 B8 4C 14'\r\n '96 89 77 CA C4 9E 32 35 C4 DC FD 1B D1 9B B0 4B 0C DD A5 46 90 53 AB 85 AF 5A 3C 53 2D 96 55 8B'\r\n '77 AA C5 7B D5 62 43 B5 F8 B4 5A EC AC 16 65 D5 62 6F B5 B0 1D 13 19 C7 84 EF 98 98 74 4C 4C 3B'\r\n '26 5E 3C 26 0E 1E 13 9A E3 C2 76 5C 74 3C 2E 72 8E 8B 7E C7 C5 E0 E3 E2 9A E3 6A 94 D9 79 42 F8'\r\n '4E 88 36 27 44 BB 13 62 F6 09 31 F7 84 78 E6 84 58 76 42 6C 3E 21 B6 9E 10 5F 9E 10 FB 4E 88 EA'\r\n '13 EA 39 D9 AE 27 45 0E F5 38 29 CE 9C 14 67 4F 8A 73 27 D5 18 74 97 53 62 F0 29 71 F3 29 51 7B'\r\n '4A 28 A7 84 38 2D 6C A7 45 C4 69 D1 F4 B4 88 A2 18 8A A3 F8 D3 A2 F9 69 E1 3C 2D 3C A7 45 CB D3'\r\n '22 F5 B4 48 27 DF 69 91 7D 5A B4 39 2D 72 4E 8B DE A7 C5 A0 D3 62 EE 69 B1 E5 B4 C0 19 31 E3 8C'\r\n '68 1E DE 70 44 FC 72 27 00 1A 8E 8E CB 73 00 FE ED E3 3A 96 BD 4B 83 CA DE B2 E0 3D 8D 29 E6 3B'\r\n '99 62 BE 97 29 E6 4B 1E 85 95 87 60 4F F1 9C EA 7C 9E 1A 4D 0E 1C 35 1C C1 A5 9B 4C 92 CA 05 9C'\r\n '96 F5 5B D9 50 ED 72 61 43 B5 A1 96 3B 3E A8 96 2B 5B AC 57 58 D1 BD A8 0D 2B AB BB B2 19 1B 5C'\r\n 'E3 3D C8 1A EF 49 DE C0 64 93 F6 CA EB BD B2 9D 1B 5C F5 95 6D 33 59 FB 95 6D DE 2B AC 00 5F D4'\r\n '0A 0E AE 06 CB 26 9C 6C 0E 5F 61 65 F8 6F 1A C8 C1 15 E3 89 6C 5D FD 57 2A C6 97 6B 47 CB 4A B2'\r\n '6C 4A 1F 64 6B 4C B6 A6 AF A4 B6 2C DB D7 C1 15 66 D9 74 94 0F 13 D9 D6 FE 4F 6B CE 9B 19 6D B9'\r\n 'A8 DD 1D 5C 85 96 2D 4C 59 8B 96 6D F0 4B 56 A4 2F 6A 8C CB EA B4 6C 8F CB 1A F5 44 36 FB EE 61'\r\n 'A5 5A 36 CC FF BE 5E 7D 51 3B FD 64 A3 0A 76 1F EE 37 46 FE 4F D6 B1 65 D3 49 B6 6C 1B 6A DA F2'\r\n 'B1 7C D1 03 B9 6B 50 95 5B 36 FC E5 E6 47 56 BC 2F 7A 5C 7F CF 1A F8 25 E3 00 DD 18 07 68 A8 87'\r\n '37 D4 C0 83 43 01 4F 30 0E F0 2A 0F 24 97 B2 21 F6 3F 5D 15 CF 63 73 F6 A2 DA 78 70 55 BC FA 52'\r\n '55 71 B9 9D BB 64 6D FC A2 20 43 39 37 7B B2 5A 1E DC 08 77 FE 6D CD FC 72 F1 87 3E 8D 6A E9 2B'\r\n '19 85 28 65 5B 59 56 D4 65 2C A2 F9 DF C6 22 82 5B EF CB B8 D5 0C 61 05 FE 92 41 89 AB EC 6A 7B'\r\n 'BE 61 79 35 BF 51 5C E2 1D B6 ED 65 AD FE 72 D1 09 FF 26 B6 21 3A D1 89 0D FE DC A0 AD AC 0C 53'\r\n '34 54 F5 8F C7 AB E7 0C 36 26 A8 7D E2 66 81 C3 BA 4E A6 AD E5 31 5D 99 B9 BE E4 61 5D 99 BF 96'\r\n '69 EB F5 8D D2 D6 DB 83 D2 D6 3F 30 6D 7D 38 28 6D 7D CE C1 06 B1 F3 12 CD D5 E0 C3 BD 06 A6 B0'\r\n 'AF E4 58 6F AB 40 3A 5B 1E EB 95 E9 6C FF 72 32 8F 49 84 B6 89 B8 37 11 CF 91 5C F4 BD 95 A4 3A'\r\n 'BF A0 E3 D1 5F 99 E0 CE 63 D6 F8 8F A0 94 B1 EC 77 4C E5 36 FE DF EB 7A 84 06 E5 20 64 8B B8 7D'\r\n '50 07 E4 95 A0 0E C8 B9 46 1D 90 25 81 0E 48 7C 96 1A 48 18 C4 25 E1 7D 5C 15 CA 25 E1 57 59 28'\r\n '0D 2C 0C EF CC C6 7D D9 D8 93 8D 7D D9 A8 CF BE B8 63 22 7B 25 26 76 49 52 79 FE 76 0A CF BE FE'\r\n '83 5D 92 A3 81 22 82 9B A9 DB 47 99 B7 5D C2 BC ED B2 40 AE B6 71 0F A5 21 8C E3 E3 F2 53 F6 53'\r\n 'E6 32 92 F3 35 A3 24 C7 D9 4F 01 FB 29 19 EC A7 C8 A8 CE 68 76 55 16 B0 AB 72 51 60 67 07 7B E0'\r\n 'DF 05 4A 15 B2 E7 12 1C E1 09 EE BF C8 38 8F 0C A9 DC C8 50 CF 15 F6 5F F6 5E 41 FF 25 38 1C 74'\r\n 'B8 F8 7C 08 E6 12 1D 99 6F 2F EE C8 04 A7 8F E5 D1 56 99 41 9E F8 DF D4 49 91 07 48 E5 12 5E 06'\r\n '51 E4 42 5E 2E DE 1B F7 59 64 34 C5 C7 AC 8D EC B3 2C 0D F4 59 D4 DC 0D FB 2C 32 D6 D3 10 7D 6A'\r\n '67 3B 5F 64 91 41 9F F9 41 01 A8 75 2C B8 9C EF 92 30 B3 23 8B 2F 97 E8 98 5C B8 8D 98 C8 6D C4'\r\n '1D 97 DA 46 9C 8F C1 04 72 D9 7F 7F DC B7 71 52 FB 92 87 7E 9B FF ED A1 DF 21 15 6A 52 BB 20 90'\r\n 'D4 96 19 6D 99 CE 96 B9 6C 99 C8 FE AA EA 5F D8 AC 2C 3E A9 6A 71 4A 75 B9 6E 51 70 F6 C5 A1 A6'\r\n '63 52 98 AD 71 AA 1F A6 3B 55 AE 56 FE 0F 65 6B A8 71 D5 B5 21 EC 71 32 54 4D 92 1D 0A BB 20 FF'\r\n '22 03 1B 8D 53 30 B2 EA 2A 83 1C B2 F6 6A 65 A8 E7 5F 6A 1D 0E AA C5 95 34 E3 86 31 01 05 26 A0'\r\n '64 4B 4E 56 F1 2E D7 98 93 29 29 59 E3 CB 63 8D 2F B8 49 37 9C 4D 3A 99 9B 92 AD 3A 77 33 FF CB'\r\n '13 CE 6A 9D 2C 26 99 2F 2C 3E 0F 60 E5 59 26 5F 2A 02 21 A1 86 E4 8B 39 EC B2 99 97 C1 AC DB 5C'\r\n 'B2 3B 7A EE C2 EE 68 A2 FA C9 4A 75 AA 5A A8 1F 66 30 1B E5 51 3F 4C 73 AA 92 8C 0D D1 BF E0 28'\r\n '9B 0C 00 36 0E A5 3D C2 20 9A 8C D7 C9 48 9D 0C 84 25 EB 1B CA 99 B2 6D 78 2F 5B 82 8B 82 5A 82'\r\n '0D 25 BD 71 81 62 9E 6C FA B5 54 5F 25 D9 0B 90 85 B7 95 AC 7B CA 72 FD AD 74 25 45 38 9F 13 AD'\r\n '9D E7 4B 71 B2 70 13 E9 56 B5 67 A1 61 34 AB C1 93 58 07 96 15 E0 E0 B2 9C 57 ED 8B CA 50 99 CC'\r\n '3F DE A6 C3 ED 17 06 CC 64 12 2E C5 8C 46 8D 8A 8E 81 0C 9C 89 DD 05 99 7B 93 D5 D9 C1 81 7A B4'\r\n 'DF F5 74 51 B9 D9 2F D5 24 73 6E E1 80 45 8D 84 AB 69 B7 07 81 87 98 79 93 71 37 A3 13 E6 4B 05'\r\n 'DA 1A 87 D8 D2 D4 E4 9A 9E 8C E4 A0 74 A3 FC 61 73 20 B4 27 83 76 97 8B EE B5 64 00 AF 71 80 2F'\r\n 'E3 23 D9 B8 71 AB 75 27 B5 65 D3 89 0D 9A 91 AC 64 DE C7 CA B5 6C D3 E4 B3 68 C8 27 90 5A 37 6C'\r\n 'A8 6D AE 66 6D 73 1D DB 37 C1 75 ED B5 1A 7C AC 51 6B 9E 3B 83 6A 9E 0D D5 CE 99 AC 76 CA 76 8F'\r\n 'AC 79 CA A6 8F AC 86 CB FE B4 4E 87 30 DD 25 CA 91 A7 D9 CA 09 2E 3E CA 30 66 47 F6 25 65 D1 50'\r\n '76 B5 5F 62 8F 52 46 32 C1 16 8C 2C 26 CA 46 8C 2C 29 5E 49 AD D5 C6 E6 4B 1B 36 5C 7A B3 C9 32'\r\n '9B 1D CF C5 EC 78 FE 4D 21 32 E6 F2 85 48 59 82 94 35 FD 01 2C 41 06 87 43 97 B8 D0 C4 8D A6 6E'\r\n 'B4 61 25 F1 D9 44 3C DF A8 80 98 D7 02 0F 33 40 5A 9C 84 B7 03 E5 C2 E0 EA BC AC CB 0F BC B0 50'\r\n '78 96 8D 21 B0 C5 73 B9 A2 A1 60 D1 30 9C E5 42 D9 E3 97 45 C3 2E 2C 1A CA CA B3 EC FA CB C6 90'\r\n '2C 1D 26 B0 74 38 98 91 D5 D9 59 78 20 10 59 DD 9E 85 9D 59 B8 2B 1B F7 66 E3 C7 6C EC 65 0D F1'\r\n 'A2 32 E2 45 4D A5 39 2C 54 BB 02 C1 44 59 64 94 0D A6 AE EC B1 CA F2 A2 2D D0 30 1A 54 8F 6B E8'\r\n '3A 1A CA CE 69 1E 5B 45 B2 D3 20 1B 46 B7 05 1A 46 1A 05 3A B6 8A EC 6C 0C 75 62 9D 7C 24 5B 42'\r\n 'FB 03 25 CB 3F 15 35 5D 5A A7 C8 1E 91 C8 61 CC 56 96 29 65 7B 48 36 83 64 90 B6 71 21 52 76 2C'\r\n '64 AF 42 76 29 64 7F 42 76 26 AE A4 4C F9 6F 17 1F 1F 3B 29 1E BF B0 04 99 78 4A 78 FE 57 0A 91'\r\n 'AD 6E 14 81 7B 90 6C 83 C8 42 A4 6C 86 BC CF 72 E4 1A 96 23 65 AE BA 04 D8 02 6C 03 76 02 65 2C'\r\n '50 7E 07 EC 51 73 BA 38 00 FC 0A 1C 05 8E B1 64 79 16 A8 E3 F4 12 2B 07 58 7A 38 84 52 CE 9B 6C'\r\n 'C7 01 93 39 1C 24 D9 9F 63 23 AF E1 90 C8 09 1C F7 38 87 23 18 5F E3 90 C5 95 1C A6 B8 9B 03 11'\r\n '7F E6 F8 C3 53 1C 6D 68 E7 B8 41 07 87 0B 66 6B D4 3C B0 7F BD F4 AD 06 7B 02 85 D1 1C 2D BA 6B'\r\n 'D1 53 8B 5E DA 0B F2 C0 0D 37 B0 E0 C2 E8 12 2D 8A B4 58 A9 C5 97 81 B1 0F 95 5A 54 6B 71 9C 83'\r\n 'FD 4E 71 AA 9F 1F 42 20 42 A0 A5 30 32 85 C0 12 82 58 EA 40 83 43 70 4D 08 AE A5 61 74 63 08 46'\r\n '71 8C DF 5D 1C 83 B7 89 23 EE 76 71 AC 5D 15 07 DA ED E5 F8 BA 5F 39 AC EE 14 07 D1 9D 0D 51 EB'\r\n 'B0 7E 6E 1D 92 74 98 A5 C3 DD 3A 94 D0 26 DA 45 5E BD 2A 93 5A D3 70 3D 46 07 8A AA 0D 85 54 BF'\r\n '6C 96 47 DB D2 08 03 46 06 4A A2 FD 82 4A 90 B2 F8 F8 2C C9 42 61 3F 1E 53 2B A1 E0 F3 29 B2 DC'\r\n 'F6 3D ED 36 E3 47 B3 5A 1D CB 66 25 6B 55 A0 68 65 B2 AA 7A 52 2E 0D A1 61 74 23 4D A2 19 34 CB'\r\n '8A 7B AC 98 47 CF D0 2B F4 3A AD A0 B7 68 2D 25 D9 54 32 9B AD B3 AB C2 C9 40 26 B2 50 04 35 94'\r\n '4E FC 72 02 05 14 BF B4 04 64 24 C0 97 80 8E 09 E8 9C 80 DC 04 0C 4A C0 AD 17 26 BA D1 1C 2F 71'\r\n '78 DB D9 E6 EA 83 FC BF 52 F8 90 C5 8E 86 32 C7 1E 3E B2 1A CA 1C FE 07 97 7C F6 37 A1 68 6A E1'\r\n '5F 1E 06 D6 01 D9 5C 5E B5 75 A2 9D 13 9D A9 2B F5 75 A2 BF 13 C3 48 AE 15 A6 B1 50 32 93 8F 3B'\r\n '59 28 29 20 F0 B9 17 CA 72 89 3E 50 2E 89 0A 94 4B 9C 2E B8 FF B6 68 92 C9 71 68 1D 02 4F 42 59'\r\n '3A F1 3F 06 E7 04 1E 83 B2 C1 2D DB D9 3B D8 CE 0E 71 AB F4 64 A2 16 94 44 69 6E A4 BB D1 CA 0D'\r\n '9F 1B DD A9 17 F5 A5 FE 94 47 63 69 B2 1B D3 DD 98 E9 C6 2C 37 EE 76 E3 1E 37 E6 BA 31 CF 8D 07'\r\n 'DD 58 E8 C6 23 6E 3C EA C6 5B 6E BC EB C6 3E 37 7E 76 E3 90 1B 47 DC 6A 10 2D 25 51 7D FC FA 9F'\r\n 'BD A6 14 D5 CC 14 DC 99 82 DD 34 3B 28 9F BF 34 43 75 22 E8 01 2B 57 5D 6D 49 1E 4B 19 48 57 D3'\r\n '60 1A 42 D7 D1 50 1A 4E 37 D0 8D 34 8A F2 68 2C 4D A0 9B 69 12 4D F3 61 BA 0F 33 7C 98 E9 C3 9D'\r\n '3E DC E5 C3 3D 3E DC EB C3 6C 1F EE F7 E1 59 92 0F F3 57 59 06 7A 8B DE A1 95 F4 3E 7D 40 AB 69'\r\n '0D 7D 4C EB 69 03 95 D0 26 DA 42 DB E8 0B 2A F5 A1 CC 87 5D 3E 94 FB 50 E9 43 95 0F DF F9 F0 BD'\r\n '0F BB 7D D8 E3 C3 49 3A C3 22 54 3D 8B 50 B2 FC F4 34 FB 92 B2 23 E9 CC 42 5F 2E 2E 1E E0 79 98'\r\n '86 5E A4 3C BF E0 7F 3C 98 6B 60 A3 08 6A 56 83 E6 35 70 92 9B 3C 35 48 AA 41 4A CD DF 95 4B 1A'\r\n '76 A4 FF 5E 8C F5 5C D0 92 A4 17 83 77 32 B7 32 31 B0 FA F0 6F E3 EE E0 4E AE 61 33 27 FE B6 28'\r\n 'B3 8F 5B 19 B9 18 79 D1 26 FC 5E A6 62 1A C5 DE E8 BA 32 51 52 F6 7F 53 BC F8 AA 4A 04 6F 18 1B'\r\n '4A 15 83 8E 89 25 84 E3 97 E9 AB B2 18 E1 53 4F 0C 9D DF 67 F1 06 1F E6 54 C9 DB 95 BC 45 65 AE'\r\n '92 E9 51 6F 20 3D 2A E3 88 32 43 2A 43 89 32 FD 26 C3 6B 1B 34 D8 C8 4D C7 67 DC 74 EC D2 E0 98'\r\n '06 C7 35 88 D1 22 56 8B 78 EA 40 83 B5 B8 46 8B EB B4 B8 5E 8B 61 A4 0B 43 58 D8 F9 14 42 7D 82'\r\n 'CA C2 2A 45 0C 03 71 F1 0C C4 A5 70 D7 9D CE 0D 77 07 86 E3 7A 33 00 39 D0 89 5C 86 55 1F 60 58'\r\n 'D5 7F 97 2C 75 A2 CC 89 4A 27 AA 9C 38 EC C4 51 A7 BA A4 F7 7B 9A FC F7 B5 57 03 C1 1D 19 32 90'\r\n 'C1 9D 42 17 DE 72 61 A5 0B AB 5C 58 EF C2 66 17 B6 BA B0 CD 85 2F E8 AB C0 4D B0 34 10 EB F9 DE'\r\n '85 3D 2E EC A3 FD F4 8B 0B 07 5D F8 8D 4E D2 69 17 FE 72 A1 C6 85 5A 17 EA 5C A8 F7 FF 8E 6E BC'\r\n 'E1 46 31 7D E1 C6 76 46 82 AC 89 88 67 82 21 89 BC 0C 31 F4 4E 44 3F C6 83 0A 13 51 9C 88 B7 13'\r\n 'B1 32 11 EF 25 62 4D 22 D6 26 62 43 22 36 26 E2 AB 44 6C 4F C4 EF 89 38 94 88 23 89 F8 33 11 26'\r\n '0F 52 3D 48 F7 20 C3 83 4C 0F B2 3C 68 E3 41 5B 0F 3A 78 D0 D1 83 2E 1E 74 F5 A0 A7 07 7D 3C E8'\r\n 'EF C1 00 0F 86 78 30 CE 83 C9 1E DC E1 C1 4C BA 93 EE A6 7B 69 31 3D E9 C1 12 0F 9E F3 E0 9F 1E'\r\n 'BC 48 AF 78 F0 AA 07 2B 3C 28 60 90 62 1D 83 14 5B 3C 28 F5 A0 CC 83 4A 0F AA 3C D8 ED C1 5E 0F'\r\n 'F6 7B 70 C0 83 5F 3D 38 E4 C1 11 0F FE F4 A0 DA 83 1A 26 9C FC E2 92 10 9F 84 E6 F4 6A 12 96 26'\r\n 'E1 40 12 0E 26 A9 71 E3 59 8C 12 6F 4D 46 45 32 2A 93 B1 27 19 3F 26 63 3F 83 A9 27 93 71 3A 19'\r\n '7F 25 E3 6C 32 6A 03 1B 2E AD 17 A1 5E 84 79 61 F2 A2 89 17 4D BD 70 7A 91 4D 6D BD 68 E7 45 0F'\r\n '2F 7A 7A D1 DB 8B BE FE DD 99 17 B9 5E 0C A2 6B BC 18 EB C5 78 9A E8 C5 64 2F A6 7B 31 CB 8B D9'\r\n '5E DC CF A8 F2 D3 0C 1D FF D3 8B 02 2F DE F5 62 95 17 1F 78 51 E6 C5 37 5E 94 7B 51 C1 30 F2 0F'\r\n '5E FC E6 C5 EF 0C 23 D7 79 91 9E 82 8C 14 B4 4E 41 9B 14 EC 48 C1 D7 29 38 40 96 54 34 49 45 D3'\r\n '54 44 A7 AA 21 AD 1E CC 94 F8 B7 8A 1A C6 3C F5 8C 79 9A 18 F3 8C 67 CC D3 C9 70 EC 5F AD 70 B6'\r\n '95 BA 31 6C C2 C0 B2 DD 87 15 59 28 C8 52 D3 7D 9B 0A CF 6F CD 9C F5 F0 30 A4 2C EF 80 FD 18 3D'\r\n '1E C5 C4 B1 3E 90 38 96 71 56 99 3B 96 A1 D6 D1 0C B5 8E 65 A8 F5 77 FA 83 74 65 22 AC 4C 0C 28'\r\n '13 B9 65 A2 DF 49 D1 FF A4 30 9F 12 96 53 A2 25 2C 5E 58 46 D2 4D 74 1F DD 4F 59 BA 86 0A 58 77'\r\n 'A0 0F 53 11 13 71 BE C6 E5 52 90 C4 9A 78 1F 45 6D 48 B3 F6 E1 66 68 35 F9 C2 BB 49 4C 20 45 EB'\r\n 'BF CE 4D 0C 01 27 30 E6 DB 9D 7F 37 0D B7 91 61 24 FF DC AD A7 36 DC AC 3A 07 22 80 5D AF EC C6'\r\n '25 6B 17 B2 5E 11 7C 63 09 BE A5 E4 70 91 24 B8 00 0A 77 C3 EC 56 4B 04 7E CD DC 88 72 23 CE 8D'\r\n '04 37 1C 6E B8 2F 5C 12 A5 BA 91 ED 46 07 EA E4 C6 40 37 86 B8 71 BD 1B A3 83 96 41 E3 DD B8 CD'\r\n '8D 29 6E 2C 76 E3 49 37 9E 76 E3 9F 24 6F 14 F9 6E AC 71 63 83 1B 1B 79 BB D8 E1 46 A9 1B 65 6E'\r\n '54 72 31 54 ED BE 38 53 28 97 47 F2 C2 29 A1 CF 78 F9 7C 9E 8C 2F 02 D5 89 5D BC 94 76 07 5D 4A'\r\n '0B F8 C6 7E 89 6F EC 35 54 E2 C5 16 2F BE A0 AF 2F 7C 93 EF F6 E2 27 FA D9 8B 03 81 37 FC 49 2F'\r\n 'CE 06 DE F6 86 14 C4 A7 A0 79 0A 5C 29 68 41 49 E4 A5 D4 A0 8B A2 73 0A BA A6 60 58 0A 86 A7 60'\r\n '7C 0A 26 A4 E0 D6 14 4C 4E C1 D4 14 4C 4B C1 0C AE ED EE 49 C1 1B 29 C8 4F C1 DB 29 78 37 05 95'\r\n '81 A5 DE 8F B4 3F 05 07 53 70 38 05 7F A6 E0 04 9D 49 41 6D 0A EA E8 EF 2F A8 E0 4B 49 5E 26 E3'\r\n 'EB 31 21 70 B1 C4 07 C2 91 CD AF EC C2 F9 FB 9A 43 9B 53 3C 0E 7B 3E D6 D3 78 DF 2A 03 3D 97 0B'\r\n 'F1 2C 0A 55 87 B8 6C BB B0 07 20 EB AB BA 40 F1 DB CC B2 EA 00 16 B6 DF 0B 53 3B 04 B2 2B 90 1E'\r\n 'D4 03 18 19 E8 01 20 28 EE 33 EF 8A E3 3E EB 39 94 A5 21 EE D3 38 E8 F3 33 83 3E B5 1C D6 F2 2F'\r\n '45 7C E4 58 97 AE 97 19 EB 72 51 F4 47 0E 77 B9 C2 D0 CF FA C0 E8 17 19 FA D9 11 14 FA F9 39 10'\r\n 'FA 91 25 70 71 C5 D1 9F CE 1C 12 D3 10 FA 91 A3 62 82 43 3F E3 02 A1 9F F9 FF B5 D0 4F 70 DC 67'\r\n '47 A3 B8 4F CD 15 C7 7D 7A 5D 6A 50 4D 43 F4 67 5C 20 FA 73 F7 15 47 7F D6 5F 18 FD D9 D1 28 FA'\r\n 'F3 F3 15 47 7F 7A 05 45 7F 82 43 3F E3 FE F5 D0 8F 1C A2 B3 33 68 88 CE 45 01 A0 8E EC 6F FC 77'\r\n '85 7E E4 18 9E 8B E2 3E 72 24 CF 45 A1 9F 86 70 CF F4 A0 01 3C 1B 2E 0C F4 FC AF C5 71 6E 0A C4'\r\n '71 5E 08 C4 71 D0 54 7D F4 5D 14 C4 69 CA 20 8E 8C E0 5C 7B 61 04 47 8E F6 99 CB 41 3E 32 70 D3'\r\n '50 E6 B7 C4 5C 1C BE B9 28 76 E3 0C 04 6E 3A C5 FE 47 43 E0 6F 02 37 3F C6 9E 8F DA C8 F1 3F 72'\r\n 'D8 CF 45 C1 1A 04 02 34 B3 39 E0 27 38 2E 23 63 31 ED 2E 0C C4 94 06 E2 2F 72 78 CF FF 74 15 48'\r\n '76 99 2E AA E1 C8 C6 9A 1C 1A 84 40 DB A1 71 93 A1 71 63 A1 A1 A5 70 51 78 E5 18 DB 0B 17 C5 56'\r\n 'E6 FC 5B B1 95 7D E9 7F D7 A0 00 1B 11 32 C2 F2 C2 65 62 2B B2 29 51 9D 79 BE 7A 20 2B 06 1F E6'\r\n 'AA 6D 87 86 48 8A 6C 3E 94 2E 3F 1F 49 99 C1 C1 48 32 92 72 86 2D 88 C6 31 94 54 C6 4D 3A 30 6E'\r\n '72 17 E3 26 9B 03 71 93 7D 81 B8 49 43 C4 64 EE A5 02 25 6D 19 22 69 1C 1C B9 F2 68 C8 91 7F 37'\r\n '0E 92 F0 9F 55 36 64 0B BA 5B A3 CA 46 5D 9D 3A 8A 29 36 30 8A C9 77 A9 CA 46 43 4D 43 76 32 AF'\r\n 'BC B2 21 DB 2C FF 52 00 25 38 7A B2 28 28 3D 5E F7 5F 0C A0 FC 8B 09 03 C7 85 09 83 E0 C1 54 17'\r\n 'E5 0C 1A 86 54 5D 32 6D D0 E1 32 69 03 D9 A1 06 A3 30 43 18 85 99 FB EF C6 5F 64 5A BE A1 3D F5'\r\n '7F 18 79 F9 8F AA D1 95 34 C1 2E AC 2C FD 7F 93 D8 BF 5C 40 27 B8 F3 2F 07 92 05 47 76 DA 6A 2F'\r\n 'B9 AF 6D A7 CE D5 B1 04 0D CA E9 A0 46 37 FA B3 1D 36 43 A7 BA CB AA BA 87 DE 88 C6 F2 E8 F3 A1'\r\n '03 B9 57 0B FE 4D 3B CE FA 4F 8F 33 7D C4 26 DE 4A 0D AE 66 1D 6D 98 16 37 69 31 56 7B BE A9 2F'\r\n '3B 63 B2 A9 BF 20 04 0F 87 9C 9F 9A E3 DF 3D BC 16 8A 37 2E 35 08 D2 EF 2A 1D 86 E8 30 4C 87 E1'\r\n '1C FB B8 2F 10 9D 39 A4 C3 61 DD C5 03 1F 4F 85 21 86 03 1F E5 30 C7 86 31 8E D7 E9 CF 4F DC 91'\r\n '03 1C E5 E8 46 B9 AE CF 25 39 8A 51 8E 5F 94 23 17 E5 98 45 39 4E 31 97 2B 53 39 36 71 07 C9 F1'\r\n '88 72 4D D7 D7 82 81 9C 81 78 35 57 58 DB 2F 3F F4 50 4E 4D 9B 1F 34 F4 50 0E 3A 6C 17 34 E2 F0'\r\n '61 8E 2F 6C 98 8E F6 92 ED 82 D1 84 72 F8 E0 AC A0 C1 82 72 A4 60 2F 92 63 04 65 28 57 0E 07 94'\r\n 'D3 83 4A 83 C6 02 A6 B1 EF B4 39 01 3B 13 50 C7 E1 80 57 12 74 90 A3 03 E5 54 A1 86 A1 81 2F 33'\r\n '1A 7A 8E A3 03 A7 06 46 07 CA 19 42 72 80 60 74 50 AB 3E 78 68 60 2A 53 97 D7 92 1C 17 58 42 72'\r\n 'FE D9 46 3E F1 0E 07 0D FB 93 CF 96 E0 A3 6B C1 F3 87 E4 31 B6 E0 41 7E 72 0A 5A E3 71 7E 9D 9A'\r\n '22 70 AC 58 9E 6E 91 03 9B 64 48 2D 78 18 53 F0 00 A6 B6 1C B4 78 1F 05 0F 54 6A 3C 4A 49 0E 51'\r\n 'BA DC B0 A4 CE 86 86 31 0B 32 E9 73 3E CC 12 18 B0 A0 76 E2 38 48 41 46 27 82 47 25 4C A0 2E 6A'\r\n '49 4A D7 68 7A D9 05 79 DA 46 53 38 2E 77 3B E9 AA DE 19 FC 6B A6 63 AD 70 92 2B A7 6E 6A 0D E0'\r\n '78 2B 9C 68 A5 76 CC 01 13 73 48 DD D5 4A 7C 8E 05 BD 02 1B 89 86 EC AA DF BA 22 AC 2F 42 8F 08'\r\n 'FF 4F 29 AD C3 D1 3A D4 2B 50 14 FF 3F 85 A2 88 7A 45 A3 28 9A 7A 45 AB 28 DA 7A 25 44 51 42 EA'\r\n '95 50 45 09 AD 57 74 8A A2 AB 57 C2 14 25 AC 5E 09 57 94 F0 7A 45 AF 28 FA 7A C5 A0 28 86 7A C5'\r\n 'A8 28 C6 7A C5 A4 28 A6 7A C5 AC 28 E6 7A C5 A2 28 96 7A C5 AA 28 D6 7A C5 A6 28 B6 9E 4F F9 7F'\r\n 'C3 DE 5A D5 CA 2B 9B 1E EB BF 7B 8C 68 34 43 F6 A7 A0 19 B2 47 2E 9C 21 DB 2D 70 4B 89 0A 47 74'\r\n 'A3 E9 B1 69 2C 51 68 39 34 56 8E 81 6C 18 00 79 FD 85 13 63 E5 30 C8 CD 97 1A 06 D9 30 37 56 DB'\r\n 'A8 B4 30 F0 32 13 63 E5 C0 C8 E0 82 C1 F6 A0 59 B1 72 6C 64 AF 0B CF FB C8 AD 7F F0 94 D8 0D 7F'\r\n '3B 36 B2 EB 85 DB F1 81 17 CE 8D 6D 18 27 19 BC BD DE 1E D8 5E CB E9 B1 0D E3 24 7B 5D 6A 9C A4'\r\n '9C 27 DB 30 54 B2 F1 56 F8 C4 85 B3 65 73 A9 F1 6C D9 1D 34 9D 6D FC E0 B9 B1 A9 36 B4 0D 3A 75'\r\n 'D2 95 43 28 1B 66 C5 8E A5 9B 6D B8 25 68 6E EC 43 3C 72 F2 8A 4D 1D 14 2B 67 C5 46 72 56 6C F6'\r\n '85 B3 62 57 F3 34 47 C3 4C 58 B9 4D BC 68 20 65 74 60 20 E5 28 1E B8 98 C9 CD 9F 1C 3F D9 93 9B'\r\n '3F 79 74 A2 90 47 24 8E 71 9C 64 9B C0 08 C9 D5 CC FF CB A9 AC 89 8D 06 49 26 15 22 85 53 56 87'\r\n '70 EB 20 C7 49 6E E4 64 D5 E0 69 AA B9 97 99 A6 BA 81 43 25 0F 05 6E A7 8D 27 A5 CA 70 75 7B 9B'\r\n 'E8 1D 34 5A 72 8D 4D F4 52 EF 59 83 B4 AA D1 4D 90 D7 04 13 9C 98 E4 DF 34 66 AA 96 71 06 4F B5'\r\n '82 BF D4 35 BA 7F 39 A2 7E 31 4F 07 2C 73 D5 C8 A3 A5 5A 58 14 AB A5 B7 7A D0 7A 03 2F 03 F9 BE'\r\n '97 A3 4D 1B 06 99 6E 08 BC FF 36 99 54 F2 9D D4 95 6F 20 F9 8E D9 49 7B 49 DE 92 E4 4D 7F 42 99'\r\n '3A F1 72 0A 6F F4 7D 42 1A 6E EB 32 2C 38 29 12 D3 23 CF CF 5A EC AB AE 8C E4 39 79 99 14 95 8D'\r\n 'ED 7E 66 39 DF CF 7F 3F 2C E1 71 47 99 E7 91 B7 15 B9 52 69 3C 73 CF BF 3B 7E D6 89 69 CC 21 94'\r\n 'F2 13 26 67 EE C9 5E 73 FF F1 0D 0B A4 52 7E ED CF 0A AA D6 E2 58 20 E0 13 E5 54 65 31 5E 91 43'\r\n '63 B8 05 BF A8 41 B8 DB 89 9F E8 80 13 07 9D F8 83 6D C2 2B 39 81 D2 92 09 C2 B4 0B 63 14 ED 2F'\r\n '3C 81 F2 37 47 99 57 B0 D1 F8 36 1B 8D EF B9 B0 DA 85 8F D8 6E 6C 7C B8 F9 07 F6 17 F7 B0 AD 78'\r\n 'C0 A5 1E 65 FE 30 11 1F 51 29 ED A7 65 1E BC E6 C1 3B EC C0 AD 67 07 6E AB 07 DB 3C F8 D2 83 AF'\r\n '3C D8 E9 C1 2E B6 DF FC 7E A1 5F 3D 38 EC 41 68 92 3A A4 34 87 7A 50 5E 12 C6 25 61 32 0F 40 CB'\r\n '96 DB C1 A0 DE 80 6C 6E C9 FA FE 18 66 FB E4 C3 53 66 FB E4 70 07 B9 78 F8 3F D9 D6 94 04 4D 5E'\r\n 'AF 09 9A BC DE 3A 68 F2 FA 94 A0 C9 EB 05 41 93 D7 1B B6 44 03 D4 E7 75 9E 0B 53 5D EA AD 62 67'\r\n '0B 5C 15 2F F3 B9 32 97 2C 93 B9 0D 4B F3 86 7C 6E C3 A1 FE 86 7C EE 3B 81 CC B5 3C DA BF 2E 10'\r\n 'D1 BD 28 A5 6B 0B 8C 15 91 03 45 1A 86 88 2C 71 61 34 0F A7 CF E2 F1 73 25 55 4D 8C CE 09 0C 05'\r\n '09 4E 86 CA A6 9F 1C D7 31 30 F4 92 99 64 B9 33 91 09 E4 5C F5 3A 6D 5C D6 B9 DA E1 FF E1 49 C0'\r\n 'AD 38 FF 45 C1 E4 97 5B BA 85 5E A1 F7 E9 04 BF EC D1 D0 10 D5 70 1A CB AF 53 F3 3C 2D A7 02 92'\r\n '5F 2C 46 7E C1 11 79 D0 AB 1F 2F 8C D9 FC E2 17 EE 72 91 C8 B7 C8 B0 72 B1 A8 5C 3C 56 2E 36 94'\r\n '8B 8D E5 E2 78 B9 38 51 2E 92 2A 44 72 85 B8 A1 42 8C AC 10 4F 54 88 27 2B C4 A6 0A F1 59 85 38'\r\n '5D 21 CE 54 88 94 4A 91 5A 29 46 55 8A D1 95 E2 E9 4A F1 4C A5 18 D4 4A 7E 96 5C CC 90 67 70 CC'\r\n '8D DF 8D A1 AA 51 24 CF 41 3B 38 9E A6 61 30 8D 86 51 66 3F 39 8C 66 80 0D 57 F9 1F 5E 91 AA 9B'\r\n '39 5C 66 0A 87 CB C8 73 88 DA 18 95 9E 64 82 B9 20 0E C5 1C 1F 33 D2 8E 51 76 8C E6 F8 98 CE 81'\r\n 'F1 31 9D 9D E8 12 08 73 65 70 B0 8B C6 A7 52 38 C6 C5 C2 C4 ED 09 3A 43 77 06 0D 70 69 C5 D1 2D'\r\n '9F 17 E2 8B 42 DC C4 71 2D 72 50 8B CC BD 0F E5 28 16 A1 A8 2C E4 20 39 5A 65 A8 41 0C 33 A8 E7'\r\n '77 FA 05 C6 A3 0C EE D9 F0 F2 34 04 ED 33 82 26 02 75 BB 70 F2 8F 7C A9 E4 B9 13 19 C0 97 C7 2B'\r\n '2E 7A F1 0C 61 30 D1 5F 97 99 ED 23 27 F9 84 5B 55 66 CE F3 91 2F 70 E3 B9 3D 72 62 CF F7 A4 E1'\r\n 'C4 9E F0 CB BC CC 37 05 5E E6 6E 97 7F 99 05 5F E6 E0 69 39 27 2E F3 02 6F 0B 7A 81 F7 06 CD C3'\r\n '09 9E 78 23 5F E6 86 43 06 96 A0 99 36 8E A0 69 36 7E 97 9B 63 D3 31 68 6A 4D F0 BC 9A 6B 78 4C'\r\n '21 68 5F 61 A9 81 B5 06 4D 28 B2 06 4D 6B E0 20 17 25 D6 A0 45 0D 92 6B E0 BD D4 7E 63 88 7A 61'\r\n 'CB 91 FA 72 68 BB AC 5E FC 3F BF 3E 01 E7'\r\n}\r\n\r\n\r\nLANGUAGE 0,0 CASE UNICODEDATA LOADONCALL MOVEABLE DISCARDABLE\r\n{\r\n '78 DA 6D 9D 05 A0 A6 55 D5 FD D7 7E 87 A1 BB 45 E0 A5 73 2E DD CD C0 D0 DD 60 51 43 77 B7 20 88'\r\n '12 82 58 88 1D A4 22 82 01 A8 A8 74 37 D2 21 21 60 60 61 83 F1 FF ED B5 EE 8C F8 9F EF FB FC 9D'\r\n 'B5 CF DA B7 9E B3 CF 7D DE 7D F4 B9 EF 6C 3F AD B4 A1 54 7B 05 69 3C C1 DE 41 DA 88 60 9F 20 6D'\r\n '4C B0 6F 90 26 10 4C 0C D2 26 04 FB 05 69 53 82 FD 83 B4 19 C1 01 41 DA 9C E0 C0 51 36 0F 5B 20'\r\n '07 8D B2 45 D8 12 39 38 48 5B 11 1C 12 A4 AD 09 0E 0D D2 36 04 87 05 69 5B 82 C3 83 B4 1D C1 11'\r\n '41 DA 9E E0 C8 20 ED 40 70 54 90 76 24 38 3A 48 3B 11 1C 13 A4 9D 09 8E 0D D2 2E 04 C7 05 69 57'\r\n '82 E3 83 B4 1B C1 09 41 DA 9D E0 C4 20 ED 41 70 52 90 BC AA B5 61 F0 AA D6 F8 E0 55 AD 8D 82 57'\r\n 'B5 36 0E 5E D5 9A 10 BC AA B5 49 F0 AA D6 A6 C1 AB 5A 9B 85 03 F5 BF 4B 7B 90 93 A3 8B EA C5 AC'\r\n '2D 83 17 B3 B6 0A 5E CC DA 3A 78 31 6B 9B E0 C5 AC 6D 83 17 B3 B6 0B 5E CC DA 3E 78 31 6B 87 E0'\r\n 'C5 AC 1D 83 17 B3 76 0A 5E CC DA 39 78 31 6B 97 E0 C5 AC 5D 83 17 B3 76 0B 5E CC DA 3D 78 31 6B'\r\n '8F F0 7D E4 A6 31 0C 5F 18 63 6E 26 7C 31 48 B7 10 BC 14 A4 5B 09 5E 0E D2 6D 04 AF 04 E9 76 82'\r\n '5F 04 E9 0E 82 57 83 74 27 C1 6B 41 BA 8B E0 F5 20 DD 4D F0 CB 20 DD 43 F0 AB 20 DD 4B F0 EB 20'\r\n 'DD 47 F0 9B 20 DD 4F F0 C6 28 F7 87 07 90 DF 8E F2 40 78 10 F9 5D 90 1E 22 F8 7D 90 1E 26 F8 43'\r\n '90 1E 21 F8 63 90 1E 25 78 33 48 8F 11 FC 29 48 3F 23 F8 73 90 1E 27 F8 4B 90 9E 20 F8 6B 90 9E'\r\n '22 F8 7B 90 9E 26 F8 47 90 9E 21 78 2B 48 CF 12 BC 1D A4 E7 08 FE 19 A4 E7 09 FE 15 A4 17 08 FE'\r\n '1D A4 9F 4B 83 A3 BD 21 AA C3 1D 1D B6 F0 1F 57 A9 6E 0E AE 52 DD 12 5C A5 BA 35 B8 4A 75 5B 70'\r\n '95 EA F6 E0 2A D5 1D C1 55 AA 3B 83 AB 54 77 05 57 A9 EE 0E AE 52 DD 13 5C A5 BA 37 B8 4A 75 5F'\r\n '78 C3 93 D1 3A FD D6 93 D1 0A B9 32 F5 60 70 65 EA A1 E0 CA D4 C3 C1 95 A9 47 82 2B 53 8F 06 57'\r\n 'A6 1E 0B AE 4C FD 2C B8 32 F5 78 70 65 EA 89 E0 CA D4 53 C1 95 A9 A7 83 2B 53 CF 04 57 A6 9E 0D'\r\n 'AE 4C 3D 17 5C 99 7A 3E B8 32 F5 42 F8 8F 27 27 94 11 52 81 D8 C3 E8 FF 0F 18 C6 04 C9 43 B5 05'\r\n '53 21 63 83 E4 A1 DA 82 A9 91 69 82 E4 A1 DA 82 69 91 E9 82 E4 A1 DA 82 E9 91 19 82 E4 A1 DA 82'\r\n '19 91 99 82 E4 A1 DA 82 99 91 59 82 E4 A1 DA 82 59 91 D9 82 E4 A1 DA 82 D9 91 39 82 E4 A1 DA 82'\r\n '39 91 B9 82 E4 A1 DA 82 B9 91 79 82 E4 A1 DA 82 79 91 77 05 C9 43 B5 05 F3 21 EF 0E 92 87 6A 0B'\r\n 'E6 47 16 08 92 87 6A 0B 16 44 86 41 F2 50 6D C1 42 C8 C2 41 F2 50 6D C1 22 C8 A2 41 F2 50 6D C1'\r\n '62 C8 E2 41 F2 50 6D C1 12 C8 92 41 F2 50 6D C1 52 C8 D2 A3 2C 15 96 76 7E 74 B2 0C B2 6C 90 3C'\r\n '54 5B 30 0E 19 09 92 87 6A 0B 96 43 96 1F 65 B9 B0 BC F3 A3 93 15 D8 64 BC 70 4D 33 26 AF 5F 4C'\r\n '9B 15 FD 21 A3 2F 66 2B E1 AD 1C 24 0F D5 16 AC 82 AC 1A 24 0F D5 16 AC 86 AC 1E 24 0F D5 16 AC'\r\n '89 AC 15 24 0F D5 16 AC 8D AC 13 24 0F D5 16 AC 8B AC 17 24 0F D5 16 AC 8F 6C 10 24 0F D5 16 6C'\r\n '88 8C 0F 34 56 CE B4 05 1B 21 1B 07 1A 2B 67 DA 82 09 C8 26 81 C6 CA 99 B6 60 53 64 B3 40 63 E5'\r\n '4C 5B B0 39 0B 78 D3 A0 5F BD 6B 34 E4 E5 7B 54 B6 E0 43 B6 0C F4 56 FE AC B6 60 2B 64 EB 40 6F'\r\n 'E5 4C 5B B0 0D B2 6D A0 B7 72 A6 2D D8 0E D9 3E D0 5B 39 D3 16 EC 80 EC 18 B8 C7 3B D3 16 EC 84'\r\n 'EC 1C E8 AD 9C 69 0B 76 41 76 0D F4 56 CE B4 05 BB 21 BB 07 7A 2B 67 DA 82 3D 90 F7 04 C9 43 B5'\r\n '05 EF 45 DE 17 24 0F D5 16 BC 1F F9 40 90 3C 54 5B B0 27 B2 57 A0 53 73 A6 2D D8 1B D9 27 D0 A9'\r\n '39 D3 16 EC 8B 4C 0C 74 6A CE B4 05 FB 21 FB 07 3A 35 67 DA 82 03 90 03 03 9D 9A 33 6D C1 41 C8'\r\n 'C1 81 36 CD 99 B6 E0 10 E4 D0 40 9B E6 4C 5B 70 18 72 78 A0 4D 73 A6 2D 38 02 39 32 D0 A6 39 D3'\r\n '16 1C 85 1C 1D 78 29 76 A6 2D 38 06 39 36 D0 A6 39 D3 16 1C 87 1C 1F 68 D3 9C 69 0B FA 55 83 D7'\r\n '8F F2 6B C8 89 4C 4E 0A B4 69 FE B0 B6 E0 64 E4 94 20 79 A8 B6 E0 54 E4 B4 20 79 A8 B6 E0 83 95'\r\n '9E 7C 52 17 79 7A 7E 3B 06 E6 8C DE 61 03 23 7D 88 C9 99 41 F2 50 6D C1 59 C8 87 83 E4 A1 DA 82'\r\n 'B3 7B E7 0D 8C F4 11 26 1F 0D 92 87 6A 0B CE E9 6D 38 30 D2 B9 BD 45 07 46 3A 8F C9 F9 41 F2 50'\r\n '6D C1 05 C8 F3 41 BA B0 37 EF C0 48 1F EF FD 3A 30 D2 45 4C 3E 11 24 0F D5 16 7C B2 77 DE C0 48'\r\n '9F EA BD 37 30 D2 A7 FD 61 7F 2D F3 99 DE 47 03 23 5D DC BB 68 60 A4 CF 32 B9 24 48 1E AA 2D F8'\r\n '5C 6E 58 03 F3 85 DE 3A 03 23 7D B1 37 C1 C0 48 5F CA 0B CB C0 7C B9 F7 C4 C0 48 5F 61 F2 D5 20'\r\n '79 A8 B6 E0 6B C8 D7 83 E4 A1 DA 82 4B 91 CB 82 E4 A1 DA 82 CB 91 D3 07 46 BA 82 C9 95 41 F2 50'\r\n '6D C1 55 5D DC 81 91 AE 66 F2 AD 20 79 A8 B6 E0 9A 2E E1 C0 48 DF 66 72 6D 90 3C 54 5B 70 1D 72'\r\n 'EE C0 48 DF E9 9A 0D 8C F4 5D 26 DF 0B 92 87 6A 0B BE 8F 5C 1F 24 0F D5 16 DC D0 25 1C 18 E9 46'\r\n '26 3F 08 92 87 6A 0B 6E 42 7E 1C 24 0F D5 16 FC D4 93 BF 95 B9 1D B9 73 94 3B 48 DC F1 BF F3 22'\r\n '7F A7 3F 7E 74 72 17 72 CF 28 77 93 B8 FB 7F E7 45 FE 1E 7F FC E8 E4 5E E4 FE 51 EE 23 71 DF FF'\r\n 'CE 8B FC FD FE F8 D1 C9 03 C8 83 81 A3 89 33 6D C1 43 C8 C3 81 A3 89 33 6D C1 23 C8 A3 81 A3 89'\r\n '33 6D C1 63 C8 CF 02 47 13 67 DA 82 C7 91 27 02 47 13 67 DA 82 27 91 A7 02 E7 14 67 DA 82 A7 91'\r\n '67 02 E7 14 67 DA 82 67 91 E7 02 E7 14 67 DA 02 FF 4E 56 FF 86 C2 0B C8 CF 03 E7 14 67 DA 82 17'\r\n '91 97 02 07 13 67 DA 82 97 91 57 02 07 13 67 DA 82 5F 20 AF 06 0E 26 CE B4 05 AF 21 AF 07 0E 26'\r\n 'CE B4 05 BF 44 7E 15 38 98 38 D3 16 FC 1A F9 4D E0 60 E2 4C 5B F0 06 F2 DB C0 C1 C4 99 B6 E0 77'\r\n 'C8 EF 03 07 13 67 DA 82 3F D0 0D 1C 24 CD 48 67 D5 E1 16 0E 47 E5 8F 7C C8 9F 46 79 93 4F 7A F3'\r\n '7F E7 45 FE 4F FE 5A A3 93 3F 23 7F 09 1C 58 9C 69 0B FA BE F4 E9 20 F5 86 FE 69 E0 F4 42 F0 8F'\r\n 'C0 E9 C5 9F D3 16 BC 85 BC 1D 38 BD 38 D3 16 FC 13 F9 57 E0 F4 E2 4C 5B F0 EF 7E D1 09 9C 5E 9C'\r\n '69 0B C4 2F 62 85 3E 9E F8 F4 32 30 03 64 4C E0 F4 92 F4 C0 4C 85 8C 0D 9C 5E 9C 69 0B A6 46 A6'\r\n '09 74 A5 CE B4 05 D3 22 D3 05 4E 2F CE B4 05 D3 23 33 04 4E 2F CE B4 05 33 22 33 05 4E 2F CE B4'\r\n '05 33 23 B3 04 4E 2F CE B4 05 B3 22 B3 05 4E 2F CE B4 05 B3 23 73 04 4E 2F CE B4 05 73 22 73 05'\r\n '4E 2F CE B4 05 73 23 F3 04 4E 2F CE B4 05 F3 22 EF 0A 9C 5E 9C 69 0B E6 43 DE 1D 38 BD 38 D3 16'\r\n 'CC 8F 2C 10 38 BD 38 D3 16 2C 88 0C 03 A7 17 67 DA 82 7E 45 E1 B5 A5 FC FA B2 08 93 45 03 07 16'\r\n '7F 58 5B B0 18 B2 78 E0 C0 E2 4C 5B B0 04 B2 64 E0 C0 E2 4C 5B B0 14 B2 74 90 3C 54 5B B0 0C B2'\r\n '6C E0 A8 E2 4C 5B 30 0E 19 09 1C 55 9C 69 0B 96 43 96 0F 92 87 6A 0B 56 40 56 0C 92 87 6A 0B 56'\r\n '42 56 0E 9C 4D 9C 69 0B D6 42 26 8E 33 D2 DA 4C D6 09 1C 2D FC 61 6D 41 BF 2C F3 02 5D 7E 91 5E'\r\n '8F C9 7E E3 8C B4 BE 3F EC B4 71 66 03 4F 3E 38 CE 6C C8 87 8D 0F 1C 2D 9C 69 0B BA 53 3A BD 0C'\r\n '47 0B 26 E7 04 69 02 C1 F9 81 A3 05 C1 A6 41 F2 50 6D C1 66 C8 E6 41 F2 50 6D C1 16 C8 96 81 B3'\r\n '84 33 6D C1 56 C8 D6 81 B3 84 33 6D C1 36 C8 B6 81 B3 84 33 6D C1 76 9E 1C 3E CE 6C EF C9 A1 E3'\r\n 'CC 0E 9E 1C 31 CE B8 D5 AB 6E FC C0 6D 5B 75 13 07 6E CE AA 5B 35 70 73 56 DD AA 81 BB AE EA 1E'\r\n '0C DC 75 55 F7 60 E0 DE AA BA D3 02 F7 56 D5 9D 16 4C F4 E4 63 57 18 B7 53 D5 CD 15 B8 D1 AA 6E'\r\n 'BB E0 60 4F F6 1E 67 DC 41 55 F7 53 70 A4 27 87 8D 33 6E A7 AA 9B 2B 70 07 55 DD 4F C1 A9 9E EC'\r\n '3B CE B8 01 AA 6E 87 C0 6D 4E 75 D3 03 6E 66 AA 5B 1B 70 F9 AA 8B 09 EE 5F AA BB 19 70 FF 52 DD'\r\n 'CD 80 0B 5B 5D 66 70 63 52 DD A6 C0 34 FD DF 95 F6 01 7B 94 09 C8 0F DA BB 64 8C 39 02 39 32 70'\r\n '6E 18 E3 E5 1F 63 8E 42 8E 0E 9C 1B 9C 69 0B 8E 43 8E 0F 9C 0E 9C 69 0B 4E F6 E4 5F 63 CC 29 9E'\r\n 'FC 7B 8C 39 D5 93 FF 8C 31 67 23 57 07 DA 6F 82 6F 05 E9 1C 82 6B 02 ED 37 C1 B7 03 1D 37 C1 FD'\r\n '41 BA 80 E0 81 40 C7 4D F0 60 A0 E3 1E A3 31 5C DF B4 CC F9 4F CF 2E 99 34 FB 6F 74 11 E3 75 81'\r\n '4E 9C E0 3B 41 FA 24 C1 77 03 9D 38 C1 F7 02 9D 38 C1 F7 83 F4 19 82 EB 03 9D 38 C1 0D 81 4E 9C'\r\n 'E0 C6 40 27 9E C5 F6 82 EB 73 04 3F 0C D2 E7 09 7E 14 A4 FE AF B2 6F 0A B4 E5 04 3F 0E B4 E5 04'\r\n '3F 09 D2 97 09 7E 1A 68 CB 09 6E 0E B4 E5 04 B7 04 3A 71 82 DB 46 F9 7A B8 14 B9 3D D0 8F 13 DC'\r\n '11 A4 CB 09 EE 0C F4 E3 04 77 05 FA 71 82 BB 83 74 15 C1 3D 41 FA 06 C1 BD 41 FA 26 C1 7D 81 4E'\r\n 'DD 45 EE EA 82 EB 59 5D 5D 70 3D AB AB 0B AE 67 75 75 E1 5A 0A 73 C7 E4 82 F5 EC B2 C9 05 9B 1C'\r\n 'B9 50 D5 65 03 17 AA BA 6C E0 42 55 97 0D 5C A8 EA B2 81 0B 55 5D 36 70 A1 AA CB 06 2E 54 75 D9'\r\n 'C0 85 AA 2E 1B B8 50 93 7E 35 5C A8 EA B2 81 0B 55 5D 36 70 A1 26 FD 2F 10 2E 54 75 D9 C0 85 AA'\r\n '2E 1B B8 50 D5 65 03 17 AA BA 6C E0 42 55 97 0D 6E 4D B1 26 57 EB 36 27 47 27 2E 59 75 01 C1 25'\r\n 'AB 2E 20 B8 64 D5 05 04 97 AC BA 80 E0 92 55 17 10 5C B2 EA 02 82 4B 56 5D 40 70 C9 AA 0B 08 FE'\r\n 'B5 AA FE 25 03 FF 5A 55 FF 92 81 7F AD AA 7F C9 E0 21 E4 C9 C0 21 60 F4 B7 66 52 2D 1E 19 DD F7'\r\n '93 56 F3 F1 D1 8D 35 E9 87 7C 62 74 BF 4E 5A 05 7F 91 EA 2F 09 4F 21 4F 07 C9 43 B5 05 CF 20 CF'\r\n '06 C9 43 B5 05 CF 21 CF 07 C9 43 B5 05 2F 20 3F 0F 74 FA CE B4 05 2F 22 2F 05 3A 7D 67 DA 82 97'\r\n '91 57 02 9D BE 33 6D C1 2F 90 57 03 9D BE 33 6D C1 6B C8 EB 81 4E DF 99 B6 E0 97 C8 AF 02 9D BE'\r\n '33 6D C1 AF 91 DF 04 3A 7D 67 DA 82 37 90 DF 06 3A 7D 67 DA 82 DF 21 BF 0F 74 FA CE B4 05 7F 18'\r\n 'BD A5 4C DA A8 7F 1C BD 0F 4C DA 5D 6F FA 83 FF 31 C6 FC F9 9D 77 A7 BF 8C DE CD 26 FD 8E FC 0D'\r\n 'F9 7B A0 81 F7 A7 B5 05 FD D9 6F 06 E9 2D 82 B7 03 0D BC 3F AC 2D E8 FB FE C9 41 EA FB FE 29 81'\r\n '9E 9D E0 D4 C0 FF 4D A5 DA 2E 74 EB AD DA 3E D0 CC 13 EC 10 E8 D9 09 76 0C 7C 0A C1 4E 81 9E 9D'\r\n '60 E7 20 4D 4D B0 4B A0 67 27 D8 35 48 D3 12 EC 16 E8 D9 09 76 0F D2 F4 04 7B 04 7A 76 82 F7 04'\r\n '8E 47 04 EF 0D F4 EC 04 EF 0B D2 CC 04 EF 0F F4 EC 04 1F 08 D2 AC 04 2B 04 7A 76 82 15 83 34 3B'\r\n 'C1 4A 81 9E 9D 60 E5 20 CD 49 B0 4A A0 67 27 58 35 48 73 13 AC 16 E8 D9 09 56 0F D2 BC 04 6B 04'\r\n '7A 76 82 35 83 34 1F C1 5A 81 9E 9D 60 ED 20 CD 4F B0 4E A0 67 27 58 37 48 0B 12 AC 17 E8 D9 09'\r\n 'D6 0F D2 42 04 1B 04 69 61 82 0D 03 0D 3C C1 F8 40 03 4F B0 51 90 16 23 D8 38 D0 C0 13 4C 08 D2'\r\n '12 04 9B 04 1A 78 82 4D 83 B4 14 C1 66 81 06 9E 60 F3 20 2D 43 B0 45 A0 81 27 D8 32 48 E3 08 B6'\r\n '0A 34 F0 04 5B 07 69 39 82 6D 02 0D 3C C1 B6 41 72 5D AA AB 04 AE 4B 75 95 C0 75 A9 AE 12 B8 2E'\r\n 'D5 55 02 D7 A5 BA 4A E0 BA 54 57 09 5C 97 EA 2A 81 EB 52 5D 25 70 5D AA AB 04 AE 4B 75 95 C0 75'\r\n 'A9 AE 12 B8 2E D5 55 02 D7 A5 BA 4A E0 BA 54 57 09 5C 97 EA 2A 81 EB 52 5D 25 70 5D AA AB 04 AE'\r\n '4B 75 95 C0 75 A9 AE 12 B8 2E D5 55 02 D7 A5 BA 4A E0 BA 54 57 09 5C 97 EA 2A 81 EB 52 5D 25 70'\r\n '5D AA AB 04 AE 4B 75 95 C0 75 A9 AE 12 B8 2E D5 55 02 D7 A5 BA 4A E0 BA 54 57 09 5C 97 EA 2A 81'\r\n 'EB 52 5D 25 C8 7D A0 EF 0A E0 FB 40 F5 5D 01 7C 1F A8 BE 2B 80 EF 03 D5 77 05 D8 29 F7 8E A9 8C'\r\n 'EF 03 D5 77 05 F0 7D A0 FA AE 00 BE 0F 54 DF 15 C0 F7 81 EA BB 02 F8 3E 50 7D 57 00 DF 07 AA EF'\r\n '0A E0 FB 40 F5 5D 01 7C 1F A8 BE 2B 80 EF 03 D5 77 05 F0 7D A0 FA AE 00 BE 0F 54 DF 15 60 4F 64'\r\n 'AF 20 79 A8 B6 60 6F 64 9F 20 79 A8 B6 60 5F 64 62 90 3C 54 5B B0 1F B2 7F 90 3C 54 5B 70 00 72'\r\n '60 90 3C 54 5B 70 10 72 70 90 3C 54 5B 70 08 72 68 90 3C 54 5B 70 18 72 78 90 3C 54 5B 70 04 72'\r\n '64 E0 88 E0 4C 5B 70 14 72 74 E0 88 E0 4C 5B 70 0C 72 6C 90 3C 54 5B 70 1C 72 7C E0 F0 E0 4C 5B'\r\n '70 02 72 62 90 3C 54 5B 70 12 72 72 90 3C 54 5B 70 0A 72 6A 90 3C 54 5B 70 1A F2 C1 20 79 A8 B6'\r\n 'E0 74 E4 8C 20 79 A8 B6 E0 5C E4 BC 20 79 A8 B6 E0 7C E4 63 41 F2 50 6D C1 05 C8 85 81 A3 88 33'\r\n '6D C1 C7 91 8B 82 E4 A1 DA 82 4F 20 9F 0C 1C 39 9C 69 0B 3E 85 7C 3A 70 E4 70 A6 2D F8 0C 72 71'\r\n 'E0 C8 E1 4C 5B F0 59 E4 92 C0 91 C3 99 B6 E0 73 C8 E7 03 47 0E 67 DA 82 2F 20 5F 0C 1C 39 9C 69'\r\n '0B BE 84 7C 39 70 E4 70 A6 2D F8 0A F2 D5 C0 91 C3 99 B6 E0 6B C8 D7 03 E7 0F 67 DA 82 4B 91 CB'\r\n '02 27 0F 67 DA 82 CB 91 2B 02 27 0F 67 DA 82 2B 91 AB 02 27 0F 67 DA 82 6F 20 DF 0C 9C 3C 9C 69'\r\n '0B AE 46 BE 15 24 0F D5 16 5C 83 7C 3B 48 1E AA 2D B8 16 B9 2E 48 1E AA 2D F8 0E F2 DD 20 79 A8'\r\n 'B6 E0 7B C8 F7 83 E4 A1 DA 82 EB 91 1B 82 E4 A1 DA 82 1B 91 1F 04 C9 43 B5 05 3F 44 7E 14 24 0F'\r\n 'D5 16 DC 84 FC 38 48 1E AA 2D F8 09 F2 D3 20 79 A8 B6 E0 66 E4 A1 20 DD 42 70 6B 90 3C 54 5B 70'\r\n '1B 72 7B 90 3C 54 5B 70 07 72 67 90 3C 54 5B 70 17 72 77 90 3C 54 5B 70 0F 72 6F 90 3C 54 5B 70'\r\n '1F 72 7F 90 3C 54 5B F0 00 F2 60 90 3C 54 5B E0 1F BD FA 42 E0 61 E4 91 20 79 A8 B6 E0 51 E4 B1'\r\n '20 79 A8 B6 E0 67 C8 E3 41 F2 50 6D C1 13 C8 93 41 F2 50 6D C1 53 C8 D3 81 93 87 33 6D C1 33 C8'\r\n 'B3 81 93 87 33 6D C1 73 C8 F3 81 93 87 33 6D C1 0B C8 CF 03 27 0F 67 DA 82 17 91 97 02 27 0F 67'\r\n 'DA 82 97 91 57 02 27 0F 67 DA 82 5F 20 AF 06 4E 1E CE B4 05 AF 21 AF 07 4E 1E CE B4 05 BF 44 7E'\r\n '15 38 79 38 D3 16 FC 1A F9 4D E0 E4 E1 4C 5B F0 06 F2 DB C0 C9 C3 99 B6 E0 77 C8 EF 03 27 0F 67'\r\n 'DA 82 3F 20 7F 0C 92 87 6A 0B DE 44 FE 14 24 0F D5 16 FC 19 F9 4B E0 00 E2 4C 5B F0 57 E4 6F 41'\r\n 'F2 50 6D C1 DF 91 7F 04 C9 43 B5 05 6F 21 6F 07 8E 22 CE B4 05 FF 44 FE 15 24 0F D5 16 FC 1B F9'\r\n '4F E0 5C E2 4C 5B A0 B1 34 1D A1 DB 09 37 25 63 CD 00 19 13 38 97 38 D3 16 4C 85 8C 0D 7C BE 33'\r\n '6D C1 D4 C8 34 81 73 89 33 6D C1 B4 C8 74 81 73 89 33 6D C1 F4 C8 0C 81 73 89 33 6D C1 8C C8 4C'\r\n '81 73 89 33 6D C1 CC C8 2C 81 73 89 33 6D C1 AC C8 6C 81 73 89 33 6D C1 EC C8 1C 81 73 89 33 6D'\r\n 'C1 9C C8 5C 81 73 89 33 6D C1 DC C8 3C 81 73 89 33 6D C1 BC C8 BB 02 E7 12 67 DA 82 F9 90 77 07'\r\n 'CE 25 CE B4 05 F3 23 0B 04 CE 25 CE B4 05 0B 22 C3 C0 B9 C4 99 B6 60 21 64 E1 C0 B9 C4 99 B6 60'\r\n '11 64 D1 C0 B9 C4 99 B6 60 31 64 F1 C0 B9 C4 99 B6 60 09 64 C9 C0 B9 C4 99 B6 60 45 64 AF 20 AD'\r\n '44 B0 77 90 56 26 D8 27 48 AB 10 EC 1B A4 55 09 26 06 69 35 82 FD 82 B4 3A C1 FE 41 5A 83 E0 80'\r\n '20 AD 49 70 60 90 D6 22 38 28 48 6B 13 1C 1C A4 75 08 0E 09 D2 BA 04 87 06 69 3D 82 C3 82 B4 3E'\r\n 'C1 E1 41 DA 80 E0 88 20 6D 48 70 64 90 C6 13 1C 15 A4 8D 08 8E 0E D2 C6 04 C7 04 69 02 C1 B1 41'\r\n 'DA 84 E0 B8 20 6D 4A 70 7C 90 36 23 38 21 48 9B 13 9C 18 A4 2D 08 4E 0A D2 96 04 27 07 69 2B 82'\r\n '53 82 B4 35 C1 A9 41 DA 86 E0 B4 20 6D 4B F0 C1 20 6D 47 70 7A 90 B6 27 38 23 48 3B 10 7C 28 48'\r\n '3B 12 9C 19 A4 9D 08 CE 0A D2 CE 04 1F 0E D2 2E 04 67 07 1A 74 97 BE 6B 0E AE 72 75 CD C1 55 AE'\r\n 'AE 39 B8 CA D5 35 07 57 B9 BA E6 E0 2A 57 D7 1C 5C E5 EA 9A 83 AB 5C 5D 73 70 95 AB 6B 0E AE 72'\r\n '75 CD C1 55 AE AE 39 B8 CA D5 35 07 57 B9 BA E6 E0 2A 57 D7 1C 5C E5 EA 9A 83 AB 5C 5D 73 70 95'\r\n 'AB 6B 0E AE 72 75 CD C1 55 AE AE 39 B8 CA D5 35 07 57 B9 BA E6 E0 2A 57 D7 1C 5C E5 EA 9A 83 AB'\r\n '5C 5D 73 70 95 AB 6B 0E AE 72 75 CD C1 55 AE AE 39 B8 CA D5 35 07 57 B9 BA E6 E0 2A 57 D7 1C 5C'\r\n 'E5 EA 9A 83 AB 5C 5D 73 70 95 AB 6B 0E AE 72 75 CD C1 55 AE AE 39 B8 CA D5 35 07 57 B9 BA E6 E0'\r\n '2A 57 D7 1C 3E C2 CD 7C A2 BF 4E 75 B8 AA C3 16 BE DE 57 66 E5 66 3F 62 E8 6F 99 D4 88 91 BE C6'\r\n '64 30 62 E8 6F 99 8C 19 31 D2 A5 4C A6 1A 31 F4 B7 4C C6 8E 18 E9 72 26 53 8F 18 FA 5B 26 D3 8C'\r\n '18 E9 4A 26 D3 8E 18 FA 5B 26 D3 8D 18 E9 1B 4C A6 1F 31 F4 B7 4C 66 18 31 D2 D5 4C 66 1C 31 F4'\r\n 'B7 4C 66 1A 31 D2 35 4C 66 1E 31 F4 B7 4C 66 19 31 D2 B5 4C 66 1D 31 F4 B7 4C 66 1B 31 D2 77 98'\r\n 'CC 3E 62 E8 6F 99 CC 31 62 A4 EF 31 99 73 C4 D0 DF 32 99 6B C4 48 D7 33 99 7B C4 D0 DF 32 99 67'\r\n 'C4 48 37 32 99 77 C4 D0 DF 32 79 D7 88 91 7E C8 64 BE 11 43 7F CB E4 DD 23 46 BA 89 C9 FC 23 86'\r\n 'FE 96 C9 02 23 46 FA 09 93 05 47 0C FD 2D 93 E1 88 91 6E 66 B2 D0 88 A1 BF 65 B2 F0 88 A1 BF 65'\r\n 'B2 C8 88 91 6E 63 B2 E8 88 A1 BF 65 B2 D8 88 91 EE 60 B2 F8 88 E1 80 B9 80 1F 3D BB C2 9C EA C9'\r\n '3E E3 8C 16 A4 EC A1 5F 7C DC 07 2C 68 06 C8 98 40 1F E0 4C 5B 30 15 32 36 D0 07 38 D3 16 4C 8D'\r\n '4C 13 E8 03 9C 69 0B A6 45 A6 0B F4 01 CE B4 05 D3 23 33 04 FA 00 67 DA 82 19 91 99 02 7D 80 33'\r\n '6D C1 CC C8 2C 81 3E C0 99 B6 60 56 64 B6 40 1F E0 4C 5B 30 3B 32 47 A0 0F 70 A6 2D 98 13 99 2B'\r\n 'D0 07 38 D3 16 CC 8D CC 13 E8 03 9C 69 0B E6 45 DE 15 E8 03 9C 69 0B E6 43 DE 1D E8 03 9C 69 0B'\r\n 'E6 47 16 08 F4 01 CE B4 05 0B 22 C3 40 1F 90 52 2C 68 16 42 16 0E F4 01 CE B4 05 8B 20 8B 06 FA'\r\n '00 67 DA 82 C5 90 C5 03 7D 80 33 6D C1 12 C8 92 81 3E C0 99 B6 60 29 64 E9 20 79 A8 B6 60 19 64'\r\n 'D9 20 79 A8 B6 60 1C 32 12 24 0F D5 16 2C 87 2C 1F 24 0F D5 16 AC 80 AC 18 24 0F D5 16 AC 84 AC'\r\n '1C 68 3E 9C 69 0B 56 41 56 0D 34 1F CE B4 05 AB 21 AB 07 9A 0F 67 DA 82 35 90 35 03 CD 87 33 6D'\r\n 'C1 5A C8 DA 81 E6 C3 99 B6 60 1D 64 DD 40 F3 E1 4C 5B B0 1E B2 7E A0 F9 70 A6 2D D8 00 D9 30 D0'\r\n '7C 38 D3 16 8C 47 36 0A 34 1F CE B4 05 1B 23 13 02 CD 87 33 6D C1 26 C8 A6 81 E6 C3 99 B6 60 33'\r\n '64 F3 40 F3 E1 4C 5B B0 05 B2 65 A0 F9 70 A6 2D D8 0A D9 3A D0 7C 38 D3 16 6C 83 6C 1B 68 3E 9C'\r\n '69 0B B6 43 B6 0F 34 1F CE B4 05 3B 20 3B 06 9A 0F 67 DA 82 9D 90 9D 03 CD 87 33 6D C1 2E C8 AE'\r\n '41 F2 50 6D C1 6E C8 EE 41 F2 50 6D C1 1E C8 7B 82 E4 A1 DA 82 F7 22 EF 0B 92 87 6A 0B DE 8F 7C'\r\n '20 48 1E AA 2D D8 13 D9 2B D0 FE 38 D3 16 EC 8D EC 13 24 0F D5 16 EC 8B 4C 0C 92 87 6A 0B F6 43'\r\n 'F6 0F 92 87 6A 0B 0E 40 0E 0C 92 87 6A 0B 0E 42 0E 0E 92 87 6A 0B 0E 41 0E 0D 92 87 6A 0B 0E 43'\r\n '0E 0F 92 87 6A 0B 8E 40 8E 0C 92 87 6A 0B 8E 42 8E 0E 92 87 6A 0B 8E 41 8E 0D 92 87 6A 0B 8E 43'\r\n '8E 0F 92 87 6A 0B 4E 40 4E 0C BC 7C 38 D3 16 9C 84 9C 1C 24 0F D5 16 9C 82 9C 1A 24 0F D5 16 9C'\r\n '86 7C 30 48 1E AA 2D 38 1D 39 23 48 1E AA 2D F8 10 72 66 90 3C 54 5B 70 16 F2 E1 20 79 A8 B6 E0'\r\n '6C E4 23 41 F2 50 6D C1 47 91 73 82 E4 A1 DA 82 73 91 F3 82 E4 A1 DA 82 F3 91 8F 05 C9 43 B5 05'\r\n '17 20 17 06 C9 43 B5 05 1F 47 2E 0A 92 87 6A 0B 3E 81 7C 32 48 1E AA 2D F8 14 F2 E9 20 79 A8 B6'\r\n 'E0 33 BC 0C 1F C0 7D B2 FF A7 7C C2 CD 1C 8E CA C5 18 C7 C8 CF 0C 74 B8 93 C3 51 F9 2C C6 F1 D2'\r\n 'F4 FD 3F 4D 13 EE EA 70 54 2E C1 38 31 B9 0E 77 4F 2E F2 39 8C BD 68 4B FA 51 2D C2 0D 1D 8E CA'\r\n 'E7 47 7F 8B 26 FD FE 7C 69 C1 77 FE E9 9B F4 15 EC AF 06 3A 4A 5F 45 5B F0 35 E4 EB 81 8E D2 99'\r\n 'B6 E0 52 E4 B2 40 47 E9 4C 5B 70 39 72 45 A0 A3 74 A6 2D B8 12 B9 2A D0 51 3A D3 16 7C 03 F9 66'\r\n 'A0 A3 74 A6 2D B8 1A F9 56 A0 A3 74 A6 2D B8 06 F9 76 A0 A3 74 A6 2D B8 16 B9 2E D0 51 3A D3 16'\r\n '7C 07 F9 6E A0 A3 74 A6 2D F8 1E F2 FD 40 47 E9 4C 5B 70 3D 72 43 A0 A3 74 A6 2D B8 11 F9 41 A0'\r\n 'A3 74 A6 2D F8 21 F2 A3 40 47 E9 4C 5B 70 13 F2 E3 40 47 E9 4C 5B F0 13 E4 A7 81 8E D2 99 B6 E0'\r\n '66 E4 96 40 47 E9 4C 5B 70 2B 72 5B A0 A3 74 A6 2D B8 1D B9 23 D0 51 3A D3 16 DC 89 DC 15 24 0F'\r\n 'D5 16 DC 8D DC 13 24 0F D5 16 DC 8B DC 17 24 0F D5 16 DC 8F 3C 10 24 0F D5 16 3C 88 3C 14 24 0F'\r\n 'D5 16 3C 8C 3C 12 24 0F D5 16 3C 8A 3C 16 24 0F D5 16 FC 0C 79 3C 48 1E AA 2D 78 02 79 32 48 1E'\r\n 'AA 2D 78 0A 79 3A 48 1E AA 2D 78 06 79 36 48 1E AA 2D 78 0E 79 3E 48 1E AA 2D 78 01 F9 79 90 3C'\r\n '54 5B F0 22 F2 52 90 3C 54 5B F0 32 F2 4A 90 3C 54 5B F0 0B E4 D5 20 79 A8 B6 E0 35 E4 F5 20 79'\r\n 'A8 B6 E0 97 C8 AF 82 E4 A1 DA 82 5F 23 BF 09 92 87 6A 0B DE 40 7E 1B 24 0F D5 16 FC 0E F9 7D 90'\r\n '3C 54 5B F0 07 E4 8F 41 F2 50 6D C1 9B C8 9F 82 E4 A1 DA 82 3F 23 7F 09 92 87 6A 0B FE 8A FC 2D'\r\n '48 1E AA 2D F8 3B F2 8F 20 79 A8 B6 E0 2D E4 ED 20 79 A8 B6 E0 9F C8 BF 82 E4 A1 DA 82 7F 23 FF'\r\n '09 92 87 6A 0B 34 F4 A1 65 18 3C 99 6E 68 06 9E 4C 3F 34 63 3C 99 61 68 A6 F2 64 C6 A1 19 EB C9'\r\n '4C 43 33 B5 27 33 0F CD 34 9E CC 32 34 FD D5 15 38 29 11 54 E0 06 4D 30 08 9C 94 08 C6 04 A9 BF'\r\n 'C3 54 81 93 12 C1 D8 20 F5 77 98 3A 70 52 22 98 26 48 B3 FA 9B CE 3B 34 B3 79 F2 AE A1 99 DD 93'\r\n 'F9 86 66 0E 4F DE 3D 34 73 7A 32 FF D0 CC E5 C9 02 43 D3 5F 67 D6 C0 79 88 60 B6 20 F5 D7 99 3D'\r\n '70 1E 22 98 23 48 FD 75 E6 0C 9C 87 08 E6 0A D2 42 FE D2 4B 0D CD C2 9E 2C 3D 34 8B 78 B2 CC D0'\r\n '2C EA C9 B2 43 B3 98 27 E3 86 66 71 4F 46 86 66 09 4F 96 1B 9A 25 3D 59 7E 68 FA 3B 2C 14 38 F5'\r\n '10 2C 1C A4 FE 0E 8B 04 4E 3D 04 8B 06 A9 BF C3 62 81 53 0F C1 E2 41 EA EF B0 44 E0 D4 43 B0 64'\r\n '90 56 F0 37 5D 63 68 56 F4 64 CD A1 59 C9 93 B5 86 66 65 4F D6 1E 9A 55 3C 59 67 68 56 F5 64 DD'\r\n 'A1 59 CD 93 F5 86 66 75 4F D6 1F 9A FE 0E 2B 04 4E 3D 04 2B 06 A9 BF C3 4A 81 53 0F C1 CA 41 EA'\r\n 'EF B0 4A E0 D4 43 B0 6A 90 FA 3B AC 16 38 F5 10 AC 1E A4 0D FC 4D 37 1B 9A 0D 3D D9 7C 68 C6 7B'\r\n 'B2 C5 D0 6C E4 C9 96 43 B3 B1 27 5B 0D CD 04 4F B6 1E 9A FE 3A 1B 04 CE 36 04 1B 06 A9 BF CE F8'\r\n 'C0 D9 86 60 A3 20 F5 D7 D9 38 70 B6 21 98 10 A4 ED F8 85 BC 63 8C E6 A0 BF E9 F0 32 87 A3 B2 BD'\r\n 'BF ED EE 43 B3 C3 D0 0F 63 62 8B 8F ED D9 65 93 66 FF 8D 76 F4 67 BC 67 68 76 9A FC 19 FD F8 E6'\r\n '4E 93 3F A3 C6 BC 23 DA D9 9F F1 BE A1 D9 65 F2 67 8C 27 B9 CB E4 CF 18 3F E6 1D D1 AE FE 8C 0F'\r\n '0C 4D FF 70 DB 07 8E 3F 04 3B 06 4E 3C 04 3B 07 0E 39 04 BB 06 69 4F 7F 81 03 86 66 2F 4F 0E 1C'\r\n '9A BD 3D 39 68 68 F6 F1 E4 E0 A1 D9 D7 93 43 86 66 A2 27 87 0E CD 7E 9E 1C 36 34 FB 7B 72 F8 D0'\r\n 'F4 77 D8 33 70 C8 21 D8 2B 48 FD 1D F6 0E 1C 72 08 F6 09 52 7F 87 7D 03 87 1C 82 89 41 EA EF B0'\r\n '5F E0 90 43 B0 7F 90 8E F0 37 FD E1 D0 1C E9 C9 8F 86 E6 28 4F EE 1E 9A A3 3D B9 67 68 8E F1 E4'\r\n 'DE A1 39 D6 93 FB 86 E6 38 4F 9E 19 9A E3 3D 79 76 68 4E F0 E4 EF 43 73 A2 27 FF 18 9A 93 3C F9'\r\n 'F5 D0 9C EC C9 6F 86 E6 14 4F DE 1A 9A 53 3D 79 7B 68 4E 67 B7 71 D3 EE 67 A0 09 EB A3 E1 0C DC'\r\n '8A 4B 58 E7 84 0F E1 0E E2 12 D6 B9 E1 4C DC 31 71 09 EB BC 70 16 EE 54 71 09 EB FC F0 61 DC B1'\r\n '71 09 EB 63 E1 6C DC A9 E3 12 D6 05 E1 23 B8 D3 C4 25 AC 0B C3 47 A7 F8 79 07 BC F6 5C 32 46 E7'\r\n '4C F1 23 0F A6 73 E2 DC 29 7E EA C1 F4 4E 9C 37 C5 0F 3E 98 C1 89 F3 A7 F8 D9 07 33 3A F1 B1 29'\r\n '7E FC C1 4C 4E 5C 30 C5 15 0C 66 76 E2 C2 29 2E 62 30 8B 13 1F 27 5A 28 09 C2 FA 6C B8 08 77 E1'\r\n 'B8 84 75 49 F8 04 EE 22 71 09 EB 73 E1 93 B8 8B C6 25 AC CF 87 4F E1 2E 16 97 B0 BE 10 3E 8D BB'\r\n '78 5C C2 FA 62 F8 0C EE 12 71 09 EB 4B E1 62 DC 25 E3 12 D6 97 C3 67 A7 F8 79 07 4B F9 42 2E 99'\r\n 'E2 47 1E 2C ED C4 E7 A6 F8 A9 07 CB 38 F1 F9 29 7E F0 C1 B2 4E 7C 61 8A 9F 7D 30 CE 89 2F 4E F1'\r\n 'E3 0F 46 9C F8 D2 14 57 30 58 CE 89 2F 4F 71 11 83 E5 9D F8 0A D1 9E 49 10 D6 95 E1 AB B8 7B C5'\r\n '25 AC AB C2 D7 70 F7 8E 4B 58 DF 08 5F C7 DD 27 2E 61 7D 33 5C 8A BB 6F 5C C2 BA 3A 5C 86 3B 31'\r\n '2E 61 7D 2B 5C 8E BB 5F 5C C2 BA 26 5C 81 BB 7F 5C C2 FA 76 B8 72 8A 9F 77 70 80 2F E4 AA 29 7E'\r\n 'E4 C1 81 4E 7C 63 8A 9F 7A 70 90 13 DF 9C E2 07 1F 1C EC C4 D5 53 FC EC 83 43 9C F8 D6 14 3F FE'\r\n 'E0 50 27 AE 99 E2 0A 06 87 39 F1 ED 29 2E 62 70 B8 13 D7 FA A6 73 E3 D0 5C E7 C9 0F 86 E6 3B 7C'\r\n 'CC 11 F9 94 0E B9 79 4E 18 63 E1 B3 BE 8B 71 9D 1F FA 2F C2 BA 29 7C 0F F7 EA B8 1D 9E ED BF 99'\r\n '69 E1 33 AE CF 67 F4 0B 57 87 17 39 1C 95 1B 78 25 4B AE 3F B5 67 F1 F9 EC D1 88 2F D0 3F E2 B5'\r\n '81 93 2D C1 75 41 EA 5B FB 11 81 93 2D C1 91 41 BA 69 8A 1F B3 BF 23 5F EC 27 C3 FF FD 5B 9E 5B'\r\n 'C9 1C 93 6B ED F0 DE 5C EB BD BE D6 DB 30 6E C8 17 21 AC FB C3 ED B8 D7 C4 ED F0 9C 5C EB 39 FE'\r\n 'EA 77 E6 33 FA 5A 3B BC 38 D7 1A B9 8B AB BB 61 F2 B5 F6 EC E2 C9 D7 7A F1 A4 6B ED 97 A4 A3 02'\r\n 'A7 5E 82 A3 83 D4 2F 49 C7 04 4E BD 04 C7 06 E9 FE 29 7E CC FE 8E 7C B1 87 5D D4 A7 86 E6 11 4F'\r\n '9E 1E 9A 47 87 93 FE E2 A7 7B 96 9E 5D 32 69 F6 DF E8 B1 E1 3B FF 2C E8 B1 E1 FF F9 67 41 4F F0'\r\n 'DD 7E 90 2B EE F0 92 5C 71 E4 C9 C9 5F A0 D3 4F 4E FE 02 E3 C7 BC 23 EA 1F EF E1 C0 B9 98 E0 91'\r\n '20 F5 4B ED 71 81 73 31 C1 F1 41 7A D1 D7 F2 CB A1 79 C9 93 5F 0D CD CB C3 49 7F 19 D3 17 F6 F2'\r\n '70 D2 DF C3 68 CC 3B A2 57 86 EF FC F3 99 57 86 FF E7 9F CF FC 82 AB B9 25 CD 58 87 5F 4D FF 17'\r\n '79 D5 DF F2 8D A1 79 2D 8D 62 5F E2 6B 69 14 C7 8F 99 24 AF 4F FE 4E 9D 7E 7D F2 77 1A 3F E6 1D'\r\n '51 5F C7 8B 81 93 34 C1 4B 41 EA C6 E1 A4 C0 49 9A E0 E4 20 F5 F7 7E 35 48 6F F2 6D 4F C9 1E EE'\r\n 'F0 AD EC E1 B7 BC 87 FF 84 71 4F 36 07 61 FD 33 FC 19 F7 C1 B8 1D 5E 98 3D 7C A1 77 CD 5F F3 19'\r\n 'FD 03 77 78 55 AE 27 F2 37 AE E0 9E C9 7B B8 67 57 4D DE C3 57 4D DA C3 DD 08 9D 10 38 49 13 9C'\r\n '18 A4 6E 77 4E 09 9C A4 09 4E 0D D2 3F A7 F8 31 FB 3B F2 C5 96 58 F8 1D 7F 45 B5 CC C2 EF 78 B7'\r\n 'BB 65 17 7E C7 9B 90 AD C4 64 9B 20 79 A8 B6 60 4F E4 88 20 ED 45 70 64 90 F6 26 38 2A 48 FB 10'\r\n '1C 1D A4 7D 09 8E 09 D2 44 82 63 83 B4 1F C1 71 41 DA 9F E0 F8 20 1D 40 70 42 A0 A9 25 38 31 D0'\r\n 'D4 12 9C 14 68 6A 09 4E 0E 34 B5 04 A7 04 9A 5A 82 53 03 4D 2D C1 69 81 A6 96 E0 83 81 A6 D6 17'\r\n 'D7 57 05 BE 8E EA AB 02 5F 47 F5 55 81 AF A3 FA AA C0 D7 51 7D 55 E0 EB A8 BE 2A F0 75 54 5F 15'\r\n 'F8 3A AA AF 0A 7C 1D D5 57 05 BE 8E EA AB 02 5F 47 F5 55 81 AF A3 FA AA C0 D7 51 7D 55 E0 EB A8'\r\n 'BE 2A F0 75 54 5F 15 F8 3A AA AF 0A CE 44 CE 0A 92 87 6A 0B AE 5F 8C BB 42 90 6E 20 78 24 48 37'\r\n '12 3C 1A 78 45 20 78 2C F0 8A 40 F0 B3 C0 2B 02 C1 E3 81 57 04 82 27 82 F4 63 82 27 83 F4 13 82'\r\n 'A7 82 F4 53 82 A7 83 74 33 C1 33 41 BA 85 E0 D9 20 DD 4A F0 5C 90 6E 23 78 3E 48 B7 13 BC 10 A4'\r\n '3B 08 7E 1E A4 3B 09 5E 0C D2 5D 04 2F 05 E9 6E 82 97 03 77 7D 82 57 02 77 7D 82 5F 04 EE FA 04'\r\n 'AF 06 EE FA 04 AF 05 E9 01 82 D7 83 F4 20 C1 2F 83 F4 10 C1 AF 82 E4 95 AC 5E 57 F0 4A 56 AF 2B'\r\n '78 25 AB D7 15 BC 92 D5 EB 0A 5E C9 EA 75 05 AF 64 F5 BA 82 57 B2 7A 5D C1 2B 59 BD AE E0 95 AC'\r\n '5E 57 F0 4A 56 AF 2B 78 25 AB D7 15 BC 92 D5 EB 0A 5E C9 EA 75 05 AF 64 F5 BA 82 57 B2 7A 5D C1'\r\n '2B 59 BD AE E0 95 AC 5E 57 F0 4A 56 AF 2B 78 25 AB D7 15 BC 92 D5 EB 0A 5E C9 EA 75 05 AF 64 F5'\r\n 'BA 82 57 B2 7A 5D C1 2B 59 BD AE E0 95 AC 5E 57 F0 4A 56 AF 2B 68 9C 6A 85 D0 FF AD 91 6A C5 20'\r\n '1A 65 6E 3F 81 D7 1C 82 95 83 34 15 C1 2A 41 1A 4B B0 6A 90 A6 26 58 2D 48 D3 10 AC 1E A4 69 09'\r\n 'D6 08 D2 74 04 6B 06 69 7A 82 B5 82 34 03 C1 DA 41 9A 91 60 9D 20 CD 44 B0 6E 90 66 26 58 2F 48'\r\n 'B3 10 AC 1F A4 59 09 36 08 D2 6C 04 1B 06 69 76 82 F1 41 9A 83 60 A3 20 CD 49 B0 71 90 E6 22 98'\r\n '10 A4 B9 09 36 09 D2 3C 04 9B 06 69 5E 82 CD 82 F4 2E 82 CD 83 34 1F C1 16 41 7A 37 C1 96 41 9A'\r\n '9F 60 AB 20 2D 40 B0 75 90 16 24 D8 26 48 43 82 6D 83 B4 10 C1 76 41 5A 98 60 FB 20 2D 42 B0 43'\r\n '90 16 25 D8 31 48 8B 11 EC 14 A4 C5 09 76 0E D2 12 04 BB 04 69 49 82 5D 83 B4 14 C1 6E 41 5A 9A'\r\n '60 F7 C0 6B 16 C1 1E 81 D7 2C 82 F7 04 B6 0E C1 7B 83 34 42 F0 BE 20 2D 47 F0 FE 20 65 6B F5 46'\r\n '03 6F AD EA 8D 06 DE 5A D5 1B 0D BC B5 AA 37 1A 78 6B 55 6F 34 F0 D6 AA DE 68 E0 AD 55 BD D1 C0'\r\n '5B AB 7A A3 81 B7 56 F5 46 03 6F AD EA 8D 06 DE 5A D5 1B 0D BC B5 AA 37 1A 78 6B 55 6F 34 F0 D6'\r\n 'AA DE 68 E0 AD 55 BD D1 C0 5B AB 7A A3 81 B7 56 F5 46 03 6F AD EA 8D 06 DE 5A D5 1B 0D BC B5 AA'\r\n '37 1A 78 6B 55 6F 34 F0 D6 AA DE 68 E0 AD 55 BD D1 C0 5B AB 7A A3 81 B7 56 F5 46 03 6F AD EA 8D'\r\n '06 DE 5A D5 1B 0D BC B5 AA 37 1A 78 6B 55 6F 34 F0 D6 AA DE 68 E0 AD 55 BD D1 C0 5B AB 7A A3 81'\r\n 'B7 56 F5 46 03 6F AD EA 8D 06 DE 5A D5 1B 0D BC B5 AA 37 1A 78 6B 55 6F 34 F0 D6 AA DE 68 E0 AD'\r\n '55 BD D1 C0 5B AB 7A A3 81 B7 56 F5 46 03 6F AD EA 8D 06 DE 5A D5 1B 0D BC B5 AA 37 1A BC 37 B7'\r\n 'A5 71 C6 5B AB 7A A3 81 B7 56 F5 46 83 3D 91 BD 02 3D 92 33 6D 41 BF 75 C3 C1 03 43 8F C4 E4 D4'\r\n '05 0C 3D 52 4F 06 86 1E C9 9F D3 EF E0 01 7E 33 8E EA B7 E6 80 FD F9 B0 03 02 3D 92 33 6D C1 81'\r\n 'C8 41 81 1E C9 99 B6 E0 60 E4 90 40 8F E4 4C 5B D0 6F 79 B1 FD C0 D0 23 31 39 72 60 E8 91 FA 97'\r\n '7C 60 E8 91 FA F7 7A 60 A4 A3 98 1C 1D 24 0F D5 16 1C 8B 1C 17 24 0F D5 16 F4 9B 88 AC 3F 30 52'\r\n 'BF 89 C8 06 03 23 9D CE E4 8C 20 79 A8 B6 E0 43 C8 99 41 F2 50 6D C1 59 C8 87 83 E4 A1 DA 82 B3'\r\n '91 8F 04 C9 43 B5 05 1F 45 CE 09 92 87 6A 0B CE 45 CE 0B 92 87 6A 0B CE 47 3E 16 24 0F D5 16 5C'\r\n '80 5C 18 24 0F D5 16 7C 1C B9 28 48 1E AA 2D F8 04 F2 C9 20 79 A8 B6 E0 53 C8 A7 83 E4 A1 DA 82'\r\n 'CF 20 17 07 C9 43 B5 05 9F 45 2E 09 92 87 6A 0B 3E 87 7C 3E 48 1E AA 2D F8 02 F2 C5 20 79 A8 B6'\r\n 'E0 4B C8 97 83 E4 A1 DA 82 AF 20 5F 0D 92 87 6A 0B BE 86 7C 3D 48 1E AA 2D B8 14 B9 2C 48 1E AA'\r\n '2D B8 1C B9 22 48 1E AA 2D B8 12 B9 2A 48 1E AA 2D F8 06 F2 CD 20 79 A8 B6 E0 6A E4 5B 41 F2 50'\r\n '6D C1 35 C8 B7 83 E4 A1 DA 82 6B 91 EB 82 E4 A1 DA 82 EF 20 DF 0D 92 87 6A 0B BE 87 7C 3F 48 1E'\r\n 'AA 2D B8 1E B9 21 D0 52 3B D3 16 DC 88 FC 20 D0 52 3B D3 16 FC 10 F9 51 A0 A5 76 A6 2D B8 09 F9'\r\n '71 A0 A5 76 A6 2D F8 09 F2 D3 40 4B ED 4C 5B 70 33 72 4B A0 A5 76 A6 2D B8 15 B9 2D D0 52 3B D3'\r\n '16 DC 8E DC 11 68 A9 9D 69 0B EE 44 EE 0A B4 D4 CE B4 05 77 23 F7 04 5A 6A 67 DA 82 7B 91 FB 02'\r\n '2D B5 33 6D C1 FD C8 03 81 96 DA 99 B6 E0 41 E4 A1 40 4B ED 4C 5B F0 30 F2 48 90 3C 54 5B F0 28'\r\n 'F2 58 90 3C 54 5B F0 33 E4 F1 20 79 A8 B6 E0 09 E4 C9 20 79 A8 B6 E0 29 E4 E9 20 79 A8 B6 E0 19'\r\n 'E4 D9 20 79 A8 B6 E0 39 E4 F9 20 79 A8 B6 E0 05 E4 E7 41 F2 50 6D C1 8B C8 4B 41 F2 50 6D C1 CB'\r\n 'C8 2B 41 F2 50 6D C1 6F 90 37 82 E4 A1 DA 82 DF 22 BF 0B 92 87 6A 0B FC C0 78 F5 E3 E3 8D 27 FD'\r\n 'F8 38 F8 81 F1 EA C7 C7 C1 0F 8C 57 3F 3E 0E 7E 60 BC FA F1 71 F0 03 E3 D5 8F 8F 83 1F 18 AF 7E'\r\n '7C 1C FC C0 78 F5 E3 E3 E0 07 C6 AB 1F 1F 07 3F 30 5E FD F8 38 F8 81 F1 EA C7 C7 C1 0F 8C 57 3F'\r\n '3E 0E 7E 60 BC FA F1 71 F0 03 E3 D5 8F 8F 83 1F 18 AF 7E 7C 1C FC C0 78 F5 E3 E3 E0 07 C6 AB 1F'\r\n '1F 07 3F 30 5E FD F8 38 F8 81 F1 EA C7 C7 C1 0F 8C 57 3F 3E 0E 7E 60 BC FA F1 71 F0 03 E3 D5 8F'\r\n '8F 83 1F 18 AF 7E 7C 1C FC C0 78 F5 E3 E3 E0 07 C6 AB 1F 1F 07 3F 30 5E FD F8 38 F8 81 F1 EA C7'\r\n 'C7 C1 0F 8C 57 3F 3E 0E 7E 60 BC FA F1 71 F0 03 E3 D5 8F 8F 83 1F 18 AF 7E 7C 1C FC C0 78 F5 E3'\r\n 'E3 E0 07 C6 AB 1F 1F 07 3F 30 5E FD F8 38 F8 81 F1 EA C7 C7 C1 0F 8C 57 3F 3E 0E 7E 60 BC FA F1'\r\n '71 F0 03 E3 D5 8F 8F C3 06 97 73 8A 08 92 87 6A 0B C6 23 1B 05 C9 43 B5 05 1B 23 13 82 E4 A1 DA'\r\n '82 4D 90 4D 83 E4 A1 DA 82 CD 90 CD 83 E4 A1 DA 82 2D 90 2D 83 E4 A1 DA 82 AD 90 AD 83 E4 A1 DA'\r\n '82 6D 90 6D 83 E4 A1 DA 82 ED 90 ED 83 E4 A1 DA 82 1D 90 1D 83 E4 A1 DA 82 9D 90 9D 83 E4 A1 DA'\r\n '82 5D 90 5D 83 E4 A1 DA 82 DD 90 DD 83 E4 A1 DA 82 3D 90 F7 04 C9 43 B5 05 EF 45 DE 17 24 0F D5'\r\n '16 BC 1F F9 40 90 3C 54 5B B0 27 B2 57 A0 01 74 A6 2D D8 1B D9 27 D0 00 3A D3 16 EC 8B 4C 0C 34'\r\n '80 CE B4 05 FB 21 FB 07 C9 43 B5 05 07 20 07 06 C9 43 B5 05 07 21 07 07 C9 43 B5 05 87 20 87 06'\r\n 'C9 43 B5 05 A7 23 67 04 7A 31 67 DA 82 0F 21 67 06 7A 31 67 DA 82 B3 90 0F 07 7A 31 67 DA 82 B3'\r\n '91 8F 04 7A 31 67 DA 82 8F 22 E7 04 7A 31 67 DA 82 73 91 F3 02 BD 98 33 6D C1 F9 C8 C7 02 BD 98'\r\n '33 6D C1 05 C8 85 81 5E CC 99 B6 E0 E3 C8 45 81 5E CC 99 B6 E0 13 C8 27 03 BD 98 33 6D C1 A7 90'\r\n '4F 07 7A 31 67 DA 82 CF 20 17 07 7A 31 67 DA 82 45 AE E0 10 12 38 FA 5E E1 43 CA 15 66 31 64 F1'\r\n 'C0 D1 D7 99 B6 60 09 64 C9 C0 D1 D7 99 B6 60 29 64 E9 C0 D1 D7 99 B6 60 19 64 D9 C0 D1 D7 99 B6'\r\n '60 1C 32 12 78 25 70 A6 2D 58 0E 59 3E 48 1E AA 2D 58 09 59 39 48 1E AA 2D 58 05 59 35 48 1E AA'\r\n '2D 58 0D 59 3D 48 1E AA 2D 58 03 59 33 48 1E AA 2D 58 0B 59 3B 48 1E AA 2D 58 07 59 37 48 1E AA'\r\n '2D 58 0F 59 3F 48 1E AA 2D D8 00 D9 30 70 E7 73 A6 2D 18 8F 6C 14 B8 F3 39 D3 16 6C 8C 4C 08 DC'\r\n 'F9 9C 69 0B 36 41 36 0D DC F9 9C 69 0B 36 43 36 0F DC F9 9C 69 0B B6 40 B6 0C DC F9 9C 69 0B B6'\r\n '42 B6 0E DC F9 9C 69 0B B6 41 B6 0D DC F9 9C 69 0B B6 43 B6 0F DC F9 9C 69 0B 76 40 76 0C DC F9'\r\n '9C 69 0B 76 42 76 0E DC F9 9C 69 0B 76 41 76 0D DC F9 9C 69 0B 76 43 76 0F DC F9 9C 69 0B F6 40'\r\n 'DE 13 B8 F3 39 D3 16 BC 17 79 5F E0 CE E7 4C 5B F0 7E E4 03 81 3B 9F 33 6D C1 9E C8 5E 81 3B 9F'\r\n '33 6D C1 DE C8 3E 81 3B 9F 33 6D C1 BE C8 C4 C0 9D CF 99 B6 60 3F 64 FF C0 9D CF 99 B6 E0 00 E4'\r\n 'C0 C0 9D CF 99 B6 E0 20 E4 E0 C0 9D CF 99 B6 E0 10 E4 D0 C0 9D CF 99 B6 E0 30 E4 F0 C0 D1 D7 99'\r\n 'B6 E0 44 E4 A4 20 79 A8 B6 E0 64 E4 94 20 79 A8 B6 A0 FF A0 EB C4 05 8C 74 1A 93 0F 06 8E BE FE'\r\n 'B0 B6 E0 74 E4 8C C0 ED D6 99 B6 E0 43 C8 99 81 DB AD 33 6D C1 59 C8 87 03 B7 5B 67 DA 82 B3 91'\r\n '8F 04 6E B7 CE B4 05 E7 21 E7 07 C9 43 B5 05 FD 7E 93 13 07 46 FA 38 93 8B 02 77 4B 7F 58 5B F0'\r\n '15 E4 AB 81 33 A0 33 6D C1 D7 90 AF 07 CE 80 CE B4 05 97 22 97 05 CE 80 CE B4 05 97 23 57 04 CE'\r\n '80 CE B4 05 57 22 57 05 CE 80 CE B4 05 7A 5B 83 FD FC 8F 11 55 87 9B 38 6C D9 C4 FF 30 4C E7 FA'\r\n '1F 6F A8 E4 0E 4C 6E 73 24 B9 FE 47 9C 06 C9 1D 92 DC 56 D2 98 B7 35 26 5F B3 3F B5 67 9B 4C 9A'\r\n '8D C9 57 E6 0B 4C 35 F9 83 FA 6B 4C 35 F9 83 0E 99 FC 41 7C A5 B1 6F FB 91 FB FE 27 9C 3A CC 3F'\r\n '3E D4 B2 93 34 F5 7F 73 53 FF FF B9 39 30 8E F1 1F BB 56 87 1B 3B 6C D9 64 AC E6 4C AE FF 9E 7B'\r\n 'CE E4 26 26 B7 EA 58 CD 95 5C FF 75 F6 5C C9 1D 9C DC DA 63 35 37 C6 69 F9 9A 1D 6E 93 AF B9 8D'\r\n 'BF E6 3C F9 BC FE DB ED 79 F2 79 87 E6 F3 D6 1D AB 85 FF C3 3D 35 48 8B 10 8C 0F BC A0 11 6C 14'\r\n 'A4 C5 08 36 0E BC A0 11 4C 08 D2 12 04 9B 04 5E D0 08 36 0D D2 52 04 9B 05 5E D0 08 36 0F D2 32'\r\n '04 5B 04 5E D0 08 B6 0C D2 38 82 AD 02 2F 68 04 5B 07 69 39 82 6D 02 2F 68 04 DB 06 69 05 82 ED'\r\n '82 B4 22 C1 F6 41 5A 89 60 87 C0 4B 1D C1 8E 41 5A 85 60 A7 C0 4B 1D C1 CE 41 5A 8D 60 97 C0 4B'\r\n '1D C1 AE 41 5A 83 60 B7 C0 4B 1D C1 EE 41 5A 8B 60 8F C0 8B D3 7F FC 5F 5D FE C7 78 25 AB D7 15'\r\n 'BC 92 D5 EB 0A 5E C9 EA 75 05 AF 64 F5 BA 82 57 B2 7A 5D C1 2B 59 BD AE E0 95 AC 5E 57 F0 4A 56'\r\n 'AF 2B 78 25 AB D7 15 BC 92 D5 EB 0A 5E C9 EA 75 05 AF 64 F5 BA 82 57 B2 7A 5D C1 2B 59 BD AE E0'\r\n '95 AC 5E 57 F0 4A 56 AF 2B 78 25 AB D7 15 BC 92 D5 EB 0A 5E C9 EA 75 05 AF 64 F5 BA 82 57 B2 7A'\r\n '5D C1 2B 59 BD AE E0 95 AC 5E 57 F0 4A 56 AF 2B 78 25 AB D7 15 34 55 D5 52 C1 FF DA 4F 2D 1D FA'\r\n '4D FB AA 96 09 FD A6 7D 55 CB 86 7E D3 BE AA 71 A1 DF B4 AF 6A 24 F4 9B F6 55 2D 17 FA 4D FB AA'\r\n '96 0F FD A6 7D 55 2B 84 7E D3 BE AA 15 43 BF 69 5F D5 4A A1 DF B4 AF 6A E5 D0 6F DA 57 B5 4A E8'\r\n '37 ED AB 5A 35 F4 9B F6 55 AD 16 FA 4D FB AA 56 0F FD A6 7D 55 6B 84 7E D3 BE AA 35 43 BF 69 5F'\r\n 'D5 5A A1 DF B4 AF 6A ED D0 6F DA 57 B5 4E E8 37 ED AB 5A 37 F4 9B F6 55 AD 17 FA 4D FB AA D6 0F'\r\n 'FD A6 7D 55 1B 84 7E D3 BE AA 0D 43 BF 69 5F D5 F8 D0 6F DA 57 B5 51 E8 37 ED AB DA 38 F4 9B F6'\r\n '55 4D 08 FD A6 7D 55 9B 84 7E D3 BE AA 4D 43 BF 69 5F D5 66 A1 DF B4 AF 6A F3 D0 6F DA 57 B5 45'\r\n 'E8 37 ED AB DA 32 F4 9B F6 55 6D 15 FA 4D FB AA B6 0E FD A6 7D 55 DB 84 7E D3 BE AA 6D 43 BF 69'\r\n '9F FF C9 28 A6 E0 FA 57 EF 06 70 FD AB 77 03 B8 FE D5 BB 01 C6 65 CF 30 01 D7 BF 7A 37 80 EB 5F'\r\n 'BD 1B C0 F5 AF DE 0D E0 FA 57 EF 06 70 FD AB 77 03 B8 FE D5 BB 01 5C FF EA DD 00 AE 7F F5 6E 00'\r\n 'D7 BF 7A 37 80 EB 5F BD 1B C0 F5 AF DE 0D E0 FA 57 EF 06 70 FD AB 77 03 B8 FE D5 BB 01 5C FF EA'\r\n 'DD 00 AE 7F F5 6E 00 D7 BF 7A 37 80 EB 5F BD 1B C0 F5 AF DE 0D E0 FA 57 EF 06 70 FD AB 77 03 B8'\r\n 'FE D5 BB 01 5C FF EA DD 00 AE 7F F5 6E 00 D7 BF 7A 37 80 EB 5F BD 1B C0 F5 AF DE 0D E0 FA 57 EF'\r\n '06 70 FD AB 77 03 B8 FE D5 BB 01 5C FF EA DD 00 AE 7F F5 6E 00 D7 BF 7A 37 80 EB 5F BD 1B C0 F5'\r\n 'AF DE 0D F0 FF 00 DC 05 D8 64'\r\n}\r\n\r\n\r\nLANGUAGE 0,0 DECOMPOSITION UNICODEDATA LOADONCALL MOVEABLE DISCARDABLE\r\n{\r\n '78 DA 5C 9D 07 74 55 C5 D7 C5 77 12 12 3A E4 61 2F 24 80 80 48 7D 24 74 10 E9 4D 08 84 DE 7B E8'\r\n '35 90 40 E8 BD 77 95 2E 88 95 DE 11 41 05 2B 20 45 05 4C 44 C1 DE B1 F7 06 FC BF BD 67 CE CB 75'\r\n '7D 6B BD C5 6F 9F 73 E6 CE CC 9B 33 77 66 EE 7B 0F 38 7C 0B F0 18 10 15 5D 02 D8 0A 44 C7 93 F9'\r\n '62 B0 9D AE 7C FD 80 3D E6 CA 13 83 FD 72 25 01 07 C4 64 E0 A0 85 A2 62 70 88 7F C6 BF 10 83 E7'\r\n 'CC 75 6F 0C 8E A8 54 55 E0 A8 38 1A 78 01 88 29 4A BB 49 09 54 03 5E 0C 2C D6 78 4C 56 72 24 F6'\r\n '12 2B 41 43 D0 87 97 4D B2 89 57 4C 46 C7 E0 55 93 31 31 78 CD 24 7B FC BA C9 02 31 38 29 D9 D8'\r\n '75 E3 94 64 53 57 D9 1B 26 59 D9 69 93 AC EC 8C 49 D6 70 56 B2 A5 2B 7B CE 24 CB BE 69 92 65 DF'\r\n '32 C9 B2 E7 25 53 5C 1F 2E 48 B6 75 97 5D 34 C9 CB DE 31 C9 CB B2 4D B2 6C 8E 49 D6 F0 9E 64 27'\r\n '77 D9 FB 26 79 D9 65 93 BC EC 8A 49 96 FD 40 B2 9B 2B F0 B1 64 3F 77 D9 27 26 E9 FD D4 24 2F FB'\r\n 'CC 24 5B FB DC 24 6B F8 C2 24 47 E7 2B C9 01 6E 74 BE 96 4C 73 95 7D 63 92 95 5D 35 C9 CA BE 35'\r\n 'C9 1A BE 93 1C EA CA 7E 6F 92 65 7F 30 C9 B2 3F 9A 64 D9 9F 25 47 B9 3E FC 22 39 DA 5D F6 AB 49'\r\n '5E F6 9B 49 5E F6 BB 49 96 FD C3 24 6B F8 5B 32 C3 5D F6 8F 49 5E F6 AF 49 5E 76 CD 24 CB 5E 97'\r\n 'CC 72 05 FE 67 92 5E 44 F9 F9 C0 99 1B 15 E5 DF 3C 65 B4 79 E3 62 10 63 5E CA 3C E6 2D 17 83 58'\r\n 'F3 52 C6 45 F9 69 C4 7A F3 46 F9 31 A3 CC 67 5E F6 21 BF 79 29 0B 98 37 6F 0C 0A 9A 97 B2 90 79'\r\n '0B C5 A0 B0 79 29 8B 48 36 71 B2 A8 E4 40 27 8B 45 F9 89 C8 4E DE 14 E5 47 9D F2 66 F3 B2 93 B7'\r\n '98 97 F2 56 F3 B2 89 DB CC 4B 79 BB 79 D9 F5 3B CC 4B 79 A7 79 D9 C4 5D E6 A5 BC 5B B2 B9 EB 7A'\r\n '71 C9 C1 4E 26 98 97 4D 24 9A 97 B2 84 79 D9 44 49 F3 52 96 32 2F A7 D1 3D E6 A5 2C 2D D9 C2 55'\r\n '56 46 72 88 93 E5 A2 FC 8D C3 1C DF 17 E5 67 09 65 79 F3 F2 6D 56 30 2F 65 45 F3 B2 E1 4A E6 A5'\r\n 'AC 6C 5E BE A1 2A E6 A5 0C 9B 97 DD 49 A2 8C A7 6C 05 24 4B B2 C0 30 A0 9A 0A B4 72 7D A8 2E 39'\r\n 'CC C9 1A 92 0F BA FE D6 94 1C EE 64 6D C9 D6 2E C7 75 24 47 38 59 D7 BC 2C 50 CF BC 94 F7 9B 97'\r\n '23 59 DF BC 94 0F A8 61 7A 0F 03 0D 24 47 38 D9 38 CA 2F 15 AC AC 49 94 BF 2F 28 9B 9A 97 95 35'\r\n '33 2F 65 73 F3 B2 B2 16 E6 A5 6C A9 CA 5E 70 56 EB 28 BF 80 70 A0 DA 44 F9 BB 85 32 C5 BC 1C A8'\r\n 'B6 E6 A5 6C 67 DE 82 31 48 35 2F 65 47 C9 F6 AE 0F 9D 24 D3 9D EC 6C 5E F6 A1 8B 79 29 BB 9A 97'\r\n '7D E8 66 5E CA EE 92 1D DC 65 3D 24 C7 39 D9 D3 BC 1C DF 5E E6 A5 EC 6D 5E 56 D6 C7 BC 94 7D CD'\r\n 'CB CA FA 99 97 B2 BF 64 47 57 60 80 E4 78 27 07 9A 97 05 D2 CC 4B 39 24 CA 2F 8E 9C 46 43 A3 FC'\r\n '4A 40 39 CC BC 1C 92 E1 E6 A5 1C 61 5E 0E C9 48 F3 52 8E 32 2F 57 C4 D1 E6 A5 1C 63 5E 0E D4 58'\r\n 'F3 52 A6 9B 97 53 6E 9C 79 29 C7 4B 76 71 6F 33 43 72 82 93 99 51 7E AD A6 9C 10 E5 57 23 CA 89'\r\n 'E6 E5 C2 94 25 D9 DD 8D D9 24 C9 49 4E 4E 36 2F A7 F2 14 F3 52 4E 35 2F DF F1 34 F3 52 4E 8F E2'\r\n '76 CB 31 7B CC 12 7C 57 0C B6 58 82 29 F7 58 67 29 F7 5A 67 29 5F 8B 42 4C 3C 17 1D 5F D9 EB 66'\r\n 'F9 FA 4E C8 1A 18 B1 4E DA 2C E6 6D 73 CA 24 6F 9B 37 6C 42 53 9E 96 4C 71 05 CE 98 A4 F7 AC E4'\r\n '28 27 CF D9 72 CA CA DE B4 E5 94 F2 2D BB 59 29 DF B6 5B 98 F2 BC BD 07 CA 0B F6 1E 28 2F DA 7B'\r\n 'A0 7C C7 DE 03 65 36 FB 69 3B 22 D3 9A 23 2B 23 62 BD 1B C4 38 9A 97 82 18 AD F7 82 18 6B 79 3F'\r\n '88 D1 BA 1C C4 28 AE 04 31 8A 0F 65 35 8C B4 F0 91 AC 7E 11 EB 63 8B E5 75 D6 27 16 F3 D6 A7 EA'\r\n 'F2 09 37 F7 3E 93 FC D2 C9 2F 6D C1 64 A3 5F D9 82 49 F9 B5 AD 45 94 DF D8 5A 44 79 D5 46 85 B3'\r\n 'EC 5B 1B 15 CA EF D4 8A F7 B2 BE EF 65 8D 8E 58 3F A8 D8 E1 28 5D FC A3 E4 AA 68 C9 9F 6C D1 A3'\r\n 'FC 59 F9 F1 13 E0 17 93 CC F7 AF 92 3E F5 BF 59 FF 38 60 BF 5B FF 28 FF B2 15 89 6D FD 6D 2B 92'\r\n 'F6 64 7B F7 05 DC F8 FE 6B EF DE 5B D7 EC DD 53 5E B7 77 4F 79 43 F2 92 DF A4 25 FF 72 92 C2 CD'\r\n '94 A2 BC 32 DA CF 14 CA 68 F3 86 B8 49 9B 97 32 4F B4 DF C8 58 20 36 DA 6F 64 94 71 E6 65 81 BC'\r\n 'E6 A5 CC 17 ED E7 1A 0B E4 8F F6 73 8D B2 80 79 59 A0 A0 79 29 0B 45 FB B1 66 81 C2 D1 7E AC 29'\r\n '8B 98 97 05 8A 9A 97 32 3E DA 2F 88 2C 10 8A F6 0B 22 65 31 F3 B2 C0 4D E6 A5 BC 39 DA CF 61 16'\r\n 'B8 25 DA CF 61 CA 5B CD CB 02 B7 99 97 F2 F6 68 BF 20 96 E5 D6 1D ED 17 44 CA 3B A3 FD D2 47 79'\r\n '57 B4 5F FA 28 13 A2 FD 16 CB 9C 26 46 FB 2D 96 B2 AC 8D 19 67 E0 BD 36 66 94 E5 6C 74 B8 8E DE'\r\n '67 A3 43 59 3E DA CF 23 3F 93 2B 44 FB 79 E4 AD 8A 16 8B 71 56 25 8B 79 AB B2 8D 09 2B AE 62 63'\r\n '42 19 B6 2B FC DC AF 6A 57 78 2B 29 DA 2F 7B 94 C9 D1 7E 31 A4 DC 1B CD 67 02 76 7B 9F 38 28 1A'\r\n 'FB 45 CE D2 03 22 07 EF A0 98 15 8D 43 E2 E4 68 3C 2B CE E4 F4 16 B9 CA 3E E7 E2 C0 A5 68 FF B8'\r\n 'C1 D5 FC 3D 93 6C F6 7D 93 9C 8D 97 4D F2 16 B9 62 92 EF E4 03 93 5C D8 3F 56 4D 03 A2 F1 89 C8'\r\n 'D5 ED 53 91 83 FF 99 38 11 F8 5C 7C 24 1A 0D 38 3F 35 EF 1B 8A 9C B7 8D C5 9B B8 A1 73 B2 DA 22'\r\n '33 5E AE 23 5C A2 63 7C ED 4D B9 64 CB 55 17 98 13 93 FB A4 34 97 53 1A 25 22 0B D3 3C 5D BE D2'\r\n 'C9 F9 2A CB D3 C2 02 B9 1E 71 AE 85 92 6B 9C 5C 24 B9 CE C9 25 92 9B 9D 5C 26 F9 94 93 CB 25 B7'\r\n '39 B9 42 4D 1C 89 B1 26 B6 DB 95 B4 76 58 71 CA 9D 92 FB 5C 81 5D 92 87 9C DC 2D 79 D8 C9 3D 92'\r\n '47 9C DC AB FA 5E 8F D4 77 DA 02 B4 CE 48 FA C0 59 C9 E3 AE C0 39 F3 EA D1 49 F2 0D 27 DF E6 9F'\r\n 'F1 FB B9 DC 8B CF 71 AD 17 D9 97 8B C1 5B 78 27 E8 5E B6 A2 27 B8 C4 8B 2F 71 19 13 8F 72 0D 13'\r\n '5F E6 43 85 F8 0A 1F 23 C4 B5 5C AF 44 BE 87 BF C5 27 B8 AC E4 61 55 B7 E4 51 C6 A2 4C B2 D6 18'\r\n 'C9 9B F2 B8 F3 BC 64 9C F3 16 92 BC D3 79 0B 4B DE EE 2E 2B 22 79 4F 1E 4D AD 3B CC 4B 59 5B B2'\r\n '96 93 ED 24 AB BB B2 A9 26 59 59 07 C9 64 57 59 17 C9 CE CE DB 53 B2 8E F3 F6 B2 1A 78 59 6F C9'\r\n 'C6 AE B2 4C C9 F1 79 B4 3E 4C 90 CC 70 F2 65 C9 5B 5D 81 57 24 6B 38 F9 B6 64 BC 93 E7 25 C3 4E'\r\n '5E 30 2F 5B BB 68 5E CA 1C 7B F3 2C F0 AE 75 92 F2 7D C9 4B AE C0 65 C9 F7 9C BC 62 AD E9 71 D3'\r\n '5A A3 FC 50 F2 36 27 3F 92 AC E9 E4 A7 36 24 DA E0 EC 0D 51 7E 6E 5E 3D 6E 9A 97 F2 4B C9 04 27'\r\n 'BF 92 AC EF E4 55 C9 AF 9D FC 56 F2 1B 27 BF 93 AC E4 E4 F7 92 6D 9C FC C1 72 C1 26 7E B4 31 A3'\r\n 'FC C9 BC 7A DC 34 2F E5 2F E6 E5 BD FD AB 79 29 7F 93 BC D7 15 F8 5D B2 B9 93 7F 49 56 70 F2 6F'\r\n 'C9 07 9D 9C 1F CB 9B 35 2D 16 B3 62 51 2A 4E 97 C5 A1 43 1C EE 31 D9 31 0E A5 25 5B 38 59 C6 BC'\r\n '9D E2 50 56 B2 95 F3 66 50 C6 D3 3B 3E 0E 99 92 2D 9C 9C 20 79 D2 C9 89 92 AD 9C 7C 49 97 65 BB'\r\n 'CB 5E 91 7C D9 C9 8B 92 17 9C BC 2F 3F 65 B9 FC A8 97 1F 55 25 C3 4E 56 93 4C 76 B2 AB E4 2D 4E'\r\n '76 93 BC D5 C9 EE 92 B7 39 D9 43 F2 6E 27 7B 4A 96 74 B2 97 64 29 27 7B 4B 56 70 B2 8F 64 15 27'\r\n 'CF 48 9E CC 8F 63 F9 71 D6 E4 BB F9 71 45 72 4B 7E BC 90 1F 1F 48 3E EE E4 47 92 7B 9C 4C 2E 40'\r\n '99 54 00 F5 0A A0 86 64 2D 27 BB 49 DE EA 64 77 C9 DB 9C EC 21 79 B7 93 BD 25 2B 38 D9 A2 A0 32'\r\n '54 10 9D 0B E2 41 93 F5 0B A2 B5 C9 2E 05 D1 53 B2 64 41 D4 2B 88 5E 92 A5 9C 7C 58 72 55 41 BC'\r\n '5B 10 A7 25 4F 14 C4 B1 82 38 23 79 D2 C9 B3 E6 65 81 16 85 28 9B 15 42 E7 42 78 49 F2 78 21 64'\r\n '17 C2 49 C9 13 4E 9E 32 99 53 08 A7 4D BE 52 08 67 0A F1 B6 F5 92 65 5A 15 56 25 85 51 BF 30 1E'\r\n '94 6C EE 64 6B F3 76 29 8C F7 25 DF 2B 8C D3 85 71 C5 E4 5B 85 F1 41 61 56 E2 25 03 1F 5A E0 A3'\r\n 'C2 48 2E C2 59 D1 A6 08 92 8A E0 80 E4 B9 22 D8 5F 04 57 24 77 14 C1 BA 22 F8 C0 E4 96 22 28 54'\r\n '94 E7 A5 82 45 D1 B8 28 2F 6F 54 14 87 8B A2 8D 64 6B 27 DB 4B A6 3A D9 45 B2 B3 93 3D 25 7B 38'\r\n '39 54 B2 41 51 1C 2A 8A 71 92 63 8B 22 BD 28 32 4C 8E 2F 8A 4C C9 FD 45 31 A3 28 26 14 E5 C3 01'\r\n 'E5 58 67 4D 54 E0 80 93 59 0A 1C 88 04 66 DA C5 94 0F 49 AE 72 0D 3D 2A B9 D1 C9 C7 25 B7 38 F9'\r\n '8C E4 D3 4E EE 94 DC E1 E4 11 C9 15 AE 53 65 E3 29 CB C4 A3 72 3C AE C5 73 07 BE 12 8F B8 BB E8'\r\n '8A BD 0B D5 EF 42 3E C9 BC 4E 16 90 CC EF 64 21 C9 82 4E 16 91 2C EC 64 31 C9 90 93 75 25 EB 38'\r\n '79 BF 64 3D 27 1B 48 D6 77 B2 A1 E4 03 4E 36 96 6C E4 64 C5 E2 EC 00 0F 56 95 44 1E 6B 2B 8B 8D'\r\n '80 B0 C8 43 74 55 91 47 AC 24 71 59 14 92 45 1E A3 AB 89 3C A6 55 17 79 E8 AC 21 F2 91 A9 A6 C8'\r\n '03 7F 2D 91 CF 56 B5 C5 36 40 1D 91 07 ED 7A 22 8F 53 F7 8B A5 D8 37 B1 1D F0 80 C8 43 66 03 91'\r\n '87 C2 86 22 0F 92 8D 44 3E 85 36 2E EE 3F B1 6D E2 CA F3 D4 27 A6 72 2E 8A D1 C5 D1 5C EC 0F B4'\r\n '10 79 E2 6F 29 F2 3C D8 4A EC C6 D5 4F EC C1 29 24 F6 E4 DA 2B F2 19 A0 AD C8 A7 92 76 E2 48 20'\r\n 'D5 F5 3F 0A ED 8B FB 0F 76 3B B8 FE F0 9C 2A DE 5A 1C 9D C4 DB 8A A3 B3 38 06 E8 22 F2 E4 DA 55'\r\n 'E4 69 B7 9B 58 BC 38 BA BB EB 39 23 C5 4C A0 A7 58 A6 38 7A 89 3C 29 F4 16 0F C4 A0 8F 78 30 06'\r\n '7D DD F8 F3 39 43 3C 19 83 FE 64 7E 9E E0 07 88 3C 34 0E 14 59 7F 9A C8 FA 06 89 AC 67 B0 C8 7A'\r\n '86 88 3C 3B 0C 15 59 CF 30 91 F5 4C 54 7D F7 E7 C1 06 37 BE 9C AD E2 00 E0 51 37 BE D1 D8 24 FE'\r\n '04 6C B6 71 79 4C 1C 04 6C 11 FB 70 05 74 E3 1E 8D 27 DC 78 46 E3 49 71 08 4F 32 E2 50 CE 73 71'\r\n '58 34 9E 11 27 17 C7 56 F1 51 1E D6 DC 78 46 63 BB 38 B7 38 76 88 9B A3 B1 53 1C 1B 8D 5D 6E FC'\r\n 'A2 B1 5B 4C E7 F2 2A 8E 8B C6 5E 37 9E 3C BD B9 F1 E4 5D 2A 4E E4 4D 29 CE 8A C6 41 71 36 8F 74'\r\n 'E2 8E 28 3C 2B 2E E4 B9 4E 5C 14 8D E7 C4 BB 8B E3 88 B8 38 1A 47 C5 25 D1 78 5E E4 63 E0 0B E2'\r\n '8A 68 BC 28 AE 8C C6 31 91 4F 93 C7 45 9E DC 90 E0 1F 34 CA F0 6C 95 E0 1F 34 28 A3 25 1B B9 F3'\r\n '77 8C 64 7F FF 04 60 DE 7B F8 C8 66 5E CA 38 F3 56 E5 39 CC BC 94 F9 12 B8 2E FA 0F ED 79 4E CA'\r\n '2F 6B 40 C4 2A 90 E0 3F 31 D5 A7 AB 09 FE 13 53 7D BA 6A 5E 56 59 D8 BC 94 45 CC CB 2A 8B 9A 97'\r\n '32 DE BC AC 2F 64 5E CA 62 E6 AD C4 07 37 F3 52 DE AC B6 FD 27 B1 14 B7 C8 4A 8B 58 B7 06 31 F6'\r\n 'EB B6 20 46 EB F6 04 FF B0 C5 2A EE 48 F0 0F 5B 94 77 9A 37 CC 87 38 F3 52 DE 6D F5 B0 13 3C 91'\r\n '15 B7 7A BC 95 A0 62 CD DC 5B 4C 94 1C E4 64 89 04 FF 78 CE B6 4A 26 F8 C7 73 CA 52 09 FE 61 90'\r\n '05 EE 49 F0 0F 83 94 A5 CD CB E1 28 63 5E CA B2 E6 E5 21 E7 5E F3 52 96 33 AF 1E 11 CD AB 47 44'\r\n 'F3 56 E6 F3 A1 79 29 2B 26 F8 07 68 BE 81 4A 09 FE 01 9A B2 B2 7A DF 32 F2 4C 53 45 D6 D0 88 15'\r\n '4E F0 1F 6F 50 56 4D F0 1F 6F 50 26 99 97 9D 4A 36 2F 65 35 F3 32 5D D5 CD 4B 59 23 C1 7F D4 CA'\r\n '02 35 13 FC 47 AD 94 B5 D4 8A F7 72 14 6A CB 1A 11 B1 EA D8 15 BC B8 AE 5D 41 59 CF BC 4C C9 FD'\r\n 'E6 A5 AC 2F D9 C6 75 EA 01 C9 91 4E 36 30 2F 87 B2 A1 79 29 1B 99 97 AD 34 36 2F 65 93 04 FF 01'\r\n '09 0B 34 4D F0 1F 90 50 36 33 2F 0B 34 37 2F 65 0B F3 B2 3B 2D CD 4B D9 CA BC EC CE 83 E6 A5 6C'\r\n '9D 90 FB 20 CE 1E B5 49 C8 7D 10 A7 95 12 C4 38 CC 6D 83 18 AD 76 16 F3 F3 35 D5 62 DE 6A 1F C4'\r\n '58 4B 87 20 46 AB A3 9A 6E E7 3F 17 96 1C E3 3F 17 36 2F DF 52 17 F3 52 76 4D F0 1F 78 50 76 4B'\r\n 'F0 1F 78 50 76 37 2F DF 68 0F F3 52 F6 54 2B ED 23 B9 E9 25 2B 3D 62 F5 B6 2B 38 08 7D EC 0A CA'\r\n 'BE 09 FE C3 10 56 D9 2F C1 7F 18 42 D9 DF BC BC 72 80 79 29 07 AA 3E FF 59 34 CB A4 C9 1A 17 B1'\r\n '06 59 AC 90 B3 06 5B CC 5B 43 2C 76 8F B3 86 5A CC 5B C3 12 FC C7 2E 94 C3 13 FC C7 2E 94 23 CC'\r\n 'CB 32 23 CD 4B 39 CA BC EC F6 68 F3 52 8E 31 2F D3 38 D6 BC 94 E9 09 FE A3 9F D2 6C 2B C1 7F F4'\r\n '43 39 DE BC BC 91 32 CC 4B 99 69 5E 5E 36 C1 BC 94 13 13 FC 87 95 7E 16 64 25 F8 0F 2B BD 35 C9'\r\n '62 79 DC 2C 98 6C 31 6F 4D 51 15 9D 5D C9 A9 92 99 4E 4E 33 2F DF C6 74 F3 52 CE 48 F0 9F 6A F3'\r\n 'FA 99 09 FE 53 6D CA 59 E6 65 43 B3 CD 4B 39 C7 BC 6C 62 AE 79 29 E7 99 97 83 36 DF BC 94 0B CC'\r\n 'CB 26 16 9A 97 72 91 64 57 57 60 B1 E4 44 27 97 98 97 95 2D 35 2F E5 B2 04 FF 61 12 0B 2C 4F F0'\r\n '1F 26 51 AE 48 F0 1F 91 47 C7 60 65 82 FF 88 9C 72 95 79 D9 C4 43 E6 A5 7C D8 BC 4C D1 23 E6 A5'\r\n '5C 6D 0B 1C E5 1A CB 16 5B 5B 6B 9D 2C 10 83 75 D6 1A E5 7A CA 78 6E 79 C7 A2 B1 21 98 9B 8F D9'\r\n '9E C8 26 B6 D8 9E 48 F9 B8 79 F3 C7 E0 09 F3 52 3E 99 E0 3F 3A 8D 76 59 7B 2A C1 7F 74 EA AD A7'\r\n '83 18 C5 33 41 8C 62 6B 10 63 2D DB 82 18 AD ED 41 8C 79 DD 11 C4 68 ED B4 18 3B 44 C7 2E 8B 79'\r\n '6B B7 C5 E2 FC 67 3E 16 F3 D6 DE 20 46 B1 2F 88 51 EC 0F 62 6C FD 40 10 A3 75 30 88 B1 F5 43 41'\r\n '8C D6 B3 41 5F E8 38 1C F4 85 D6 73 B6 4F D2 3A 62 FB 24 E5 51 F3 B2 E2 E7 CD 4B F9 82 79 59 E5'\r\n '8B E6 A5 3C 66 7B AA 1F CB E3 B6 A7 7A EB A5 20 A6 DF 15 04 31 8A 57 82 18 EB 7E 35 88 D1 7A 2D'\r\n '88 B1 85 D7 83 18 AD 13 16 F3 63 79 D2 62 DE 3A 65 3B 25 AB 78 C3 76 4A CA D3 E6 65 99 33 E6 A5'\r\n '3C 9B E0 3F 56 A5 3C 97 E0 3F 56 A5 7C D3 BC BC EC 2D F3 52 BE 6D 2B B8 7F 57 E7 6D 05 F7 D6 85'\r\n '20 A6 DF 22 04 31 8A 77 82 18 6B C9 0E 62 B4 72 82 18 DF D5 BB 41 8C D6 25 8B F9 77 F5 9E C5 BC'\r\n 'F5 BE C5 EE 72 AD 5F B6 98 B7 AE 04 31 8A 0F 82 98 BE 56 09 62 6C FD A3 20 46 EB E3 20 C6 D6 3F'\r\n '09 62 B4 3E 0D 62 EC C0 67 41 8C D6 E7 B6 5E 52 7E 61 EB 25 E5 97 E6 65 C5 5F 99 97 F2 6B 5B 29'\r\n '7D 4F BF B1 95 D2 5B 57 83 18 C5 B7 41 8C E2 BB 20 C6 5A BE 0F 62 B4 7E 08 62 EC E9 8F 41 8C D6'\r\n '4F 41 8C 7D FA 39 88 D1 FA C5 D6 34 FD 3C C2 56 19 CA DF CC CB 02 BF 9B 97 F2 0F F3 B2 B9 3F CD'\r\n '4B F9 97 79 D9 D0 DF E6 A5 44 A2 FF 80 F7 26 BE 2B 93 37 33 69 89 BA 95 9D 97 22 C6 AC 9B 9D 95'\r\n '27 88 71 1C 62 83 18 AD B8 20 D6 88 5B 64 10 A3 95 2F D1 7F 86 CD 58 7E 93 0C 14 50 99 95 91 96'\r\n '0A 9A E5 5B 2A 14 C4 F4 A1 6B 10 A3 55 24 88 B1 EE A2 41 8C 56 7C A2 FF A4 9A B1 90 49 06 8A A9'\r\n 'CC A1 48 4B 37 99 E5 5B BA 39 88 B1 EE 5B 82 98 4E EB 89 FE 83 76 C6 EE 30 C9 C0 9D 2A F3 48 A4'\r\n 'B6 BB CC F2 B5 DD 1D C4 78 7D F1 20 46 AB 44 A2 FF E8 9C B1 92 26 19 28 A5 32 87 23 B5 DD 63 96'\r\n 'AF AD 74 10 E3 F5 65 82 18 AD B2 41 8C EF FB DE 20 46 AB 5C A2 FF 56 80 B1 FB 4C 32 50 5E 65 D6'\r\n '44 5A AA 60 96 6F A9 62 10 63 DD 95 82 18 AD CA 41 8C 75 57 09 62 B4 C2 89 FE A3 7E C6 AA 9A 64'\r\n '20 29 D1 7F BD E0 5B 4A 36 CB B7 54 2D 88 B1 EE EA 41 8C 56 8D 20 C6 BA 6B 06 31 5A B5 12 FD 97'\r\n '14 8C D5 36 C9 40 1D 95 59 17 69 A9 AE 59 BE A5 7A 41 8C 75 DF 1F C4 68 D5 0F 62 AC FB 81 20 46'\r\n 'AB 41 A2 FF A2 82 B1 86 26 15 50 99 E3 91 96 1A 9B E5 5B 6A 12 C4 F4 B3 8D 20 46 AB 45 A2 FF 2E'\r\n '86 B1 96 26 19 68 A5 32 9B 23 B5 3D 68 96 AF AD 75 10 D3 A9 3E 88 D1 6A 97 E8 BF 39 61 2C D5 24'\r\n '03 ED 13 FD D7 2F BE B6 0E 66 F9 DA 3A 06 31 1D DB 83 98 4E EE 41 8C EF BB 4B 10 A3 D5 2D D1 7F'\r\n 'D5 42 AB 87 02 4F 45 2A EC 15 58 AC A2 4F 60 F1 A2 BE 89 FE DB 1C 56 D8 CF 24 03 FD 55 E6 8D 48'\r\n 'F7 06 98 E5 6B 1B 18 C4 58 5B 5A 10 A3 35 28 88 B1 EE C1 41 8C D6 90 44 FF 65 16 63 43 4D 32 30'\r\n '4C 65 B6 45 5A 1A 6E 96 6F 69 44 10 63 DD 23 83 18 AD 51 41 8C 75 8F 0E 62 B4 C6 D8 DA 48 DF D8'\r\n 'C4 DC AF C4 D2 6D 75 D1 43 41 62 EE B7 63 E3 ED BE D6 F2 9D 98 FB 45 59 A6 DD 19 F4 4E 48 CC FD'\r\n 'CE 6C A2 CD 2D 7A B3 12 73 BF 1A 9B 64 59 A5 77 72 62 EE B7 64 53 6C 30 E9 9D 9A 98 FB 85 D9 8C'\r\n '60 C9 6D CA 93 78 B0 E4 D2 9A 95 88 3C C1 32 4E C7 6C 73 DC 1C 71 CC 09 4A 44 39 C7 DC A0 84 77'\r\n 'CC 0B 4A 34 72 8E F9 41 09 EF 58 10 2C C5 B4 16 06 4B 31 AD 45 2A BC F2 3F 3D 58 6C 8E DC 1E 2C'\r\n '09 4A F8 06 97 06 25 BC 63 59 50 C2 37 B8 3C 28 E1 1D 2B 82 65 90 D6 CA 60 19 A4 B5 4A 85 0F FF'\r\n 'A7 07 0F 99 23 B7 07 0F 07 25 7C 83 8F 04 25 BC 63 75 50 C2 37 B8 26 28 E1 1D 6B 83 E5 91 D6 BA'\r\n '60 79 A4 B5 5E 85 D7 FC A7 07 1B CC 91 DB 83 8D 41 09 DF E0 A3 41 09 EF D8 14 94 F0 0D 6E 0E 4A'\r\n '78 C7 63 C1 7D 42 6B 4B 70 9F D0 7A 5C 85 DF F8 4F 0F 9E 30 47 6E 0F 9E 0C 4A F8 06 9F 0A 4A 78'\r\n 'C7 D3 41 09 DF E0 33 41 09 EF D8 1A DC 3F B4 B6 05 F7 0F AD ED 2A BC ED 3F 3D D8 61 8E DC 1E EC'\r\n '0C 4A F8 06 77 05 25 BC 63 77 50 C2 37 B8 27 28 E1 1D 7B ED D6 E4 53 C2 3E 93 FA 3D B2 DD 13 BE'\r\n '9D 03 16 A0 3C 68 01 5F FD B3 16 60 55 87 2D E0 6B 7D CE 4E 2B AC F5 88 49 D6 7A D4 24 4B 3E 9F'\r\n '98 FB ED FC 0B 26 79 D9 8B 89 FE CB 7C 76 F7 58 A2 BE F2 E7 7E 10 B8 5E 32 C9 26 5E 4E CC FD AA'\r\n '9F D6 2B 36 7B 7D 6F 5F B5 05 84 F2 35 0B F8 DE 9E B0 00 AF 38 69 01 DF DB 53 76 46 51 FE 13 73'\r\n '7F 22 70 DA 4E 00 F4 9E 49 CC FD B5 C0 59 93 BC EC 9C 75 C2 27 E8 CD C0 62 B1 B7 02 8B 6D BC 6D'\r\n 'AB 97 BE 57 36 C9 E1 B8 90 98 FB 63 02 3D 53 24 FE F7 A7 05 39 56 8C 17 BF 1B 04 68 5D B2 3D 5C'\r\n 'BF CB 30 C9 AA DE 37 C9 92 97 13 73 7F CE F0 81 75 C2 4F 98 0F 03 8B B1 8F 02 8B B5 7E 6C 4B 26'\r\n '6B FD C4 A4 7E 6B 95 98 FB EB 04 8A CF 12 FF FB 5B 85 CF 55 EC 65 37 B3 BE 30 C9 AA BE B4 8B 59'\r\n 'E5 57 41 71 5A 5F DB AE C8 06 BE 31 C9 06 AE 9A D4 E3 40 62 EE 8F 15 BE 93 DC E2 EA FB 3E C8 33'\r\n 'C5 0F 89 FF FD 81 C7 8F 9A 21 7D 81 5F EC BE F5 D9 FF D5 96 79 CA DF 2C E0 B3 FF 87 05 D8 99 3F'\r\n '2D E0 B3 FF 97 9D 2E F4 2B AC C4 DC DF 7F FC 63 9B 23 BD FF 26 E6 FE FE E3 9A 49 5E 76 5D D2 FF'\r\n 'F0 E4 86 4D 4C 8D 73 09 76 4A 5E 63 34 E9 7E 1A 63 CC 63 8C 35 C6 19 F3 96 F0 7F 4D 20 9F D9 F9'\r\n '8D 05 8C 21 C5 29 6E 2B E1 9B 4A E6 21 57 A1 CA 40 19 B9 48 BE CA 96 40 8C 49 BE AA 58 9D C9 2A'\r\n '90 54 02 7C 55 53 01 2F F9 AA A1 40 F5 12 E0 AB A6 02 5E F2 55 4F 81 92 00 5F F5 AD C1 D8 18 34'\r\n '97 7C 00 E0 AB 85 49 16 68 69 65 69 75 29 81 3C 41 ED 7C F5 B1 DE 8F 21 F3 85 81 B1 22 1F CC C7'\r\n '8B D5 80 0C B1 3A 90 29 D6 00 26 88 35 81 89 62 2D 20 4B AC 0D 4C 12 2B 00 93 C5 62 A5 30 45 BC'\r\n '1F 98 2A 96 03 A6 89 F7 01 D3 C5 51 C0 0C 32 3F DB 9B 29 56 05 66 89 49 C0 6C 31 19 98 23 B2 FD'\r\n 'B9 22 DB 9F 27 B2 FD F9 22 DB 5F 20 B2 FD 85 22 DB 5F 24 B2 FD C5 22 DB 5F 22 B2 FD A5 22 DB 5F'\r\n '26 B2 FD 15 62 3F 60 A5 98 06 AC 12 F9 1C FD 90 38 11 78 58 EC C6 05 46 1C 02 AC 16 87 03 6B C4'\r\n '11 C0 5A 71 24 B0 4E E4 FB 58 2F 8E 01 36 88 E3 80 8D E2 78 60 AB C6 BC 3D F4 09 19 53 10 A3 0F'\r\n 'CD AA C0 FD 86 3E B0 F4 1B E1 92 88 8A 6A CC C9 57 92 C5 F7 42 DF 00 C5 AA C0 00 57 40 3F 64 0E'\r\n '2C 3E 35 E7 65 F1 F8 15 51 C8 6F C5 9B 71 FA A9 86 C1 40 41 51 BF 8B 33 16 36 16 11 F9 46 8A 8A'\r\n 'F7 46 21 5E D4 AF 00 8D C5 C4 D6 5C 06 45 BE C1 5B C4 14 E0 D6 92 FE B7 AD EC C3 1D 72 B5 03 EE'\r\n '14 53 F9 EC 2E F2 BD DD 6D 2C 6E 2C C1 4B F2 75 80 BE 24 28 A9 6E 77 84 3E 1F 62 DD A5 14 E8 E8'\r\n '02 A5 55 B6 3B EF 03 52 B7 69 39 B3 CB CB 7E 10 A8 50 32 F7 EF B1 54 54 A8 11 50 C9 C6 A8 8A A8'\r\n 'EF 8F 44 56 5C 55 E4 08 24 8B AC BA 9A C8 EE 56 D7 20 BD 1D 8B 1A E2 F9 58 D4 14 2F C4 A2 96 78'\r\n '31 16 B5 55 8E 53 BC AE FA C8 EB D9 5A 57 A0 9E BC 2F F1 61 4A 3C C0 C7 28 F1 21 3E 40 89 8F F1'\r\n 'D1 49 0C 95 42 53 B1 09 87 5E 1C 08 34 B7 5E B5 B0 5A 5B 8A C3 80 76 25 73 FF 8E 0F A7 6B 6A 60'\r\n '71 B2 B6 2F 89 3C 66 F1 4F DE 05 1D 82 30 E7 7E 47 59 49 11 AB 53 10 E3 7D D0 39 88 D1 EA 52 32'\r\n 'F7 AF 0E D1 EA 2A AB 5A C4 EA 16 5C C7 FB A6 BB AC EA 11 AB 47 10 E3 3D D4 33 A8 85 56 AF A0 24'\r\n 'AD DE B2 6A 46 AC 3E CC 8E 5D D7 57 A3 C9 F9 D3 AF A4 FF 9B 07 7C F5 D7 80 7A C9 D7 00 0B 74 06'\r\n '06 AA 2C 99 26 57 67 17 1D A4 B2 9D 23 65 07 73 40 02 8B AF 21 76 31 13 33 54 17 93 C3 E4 EA EA'\r\n 'A2 C3 75 71 D7 48 D9 11 2A C0 59 36 52 E4 3C 19 25 32 43 A3 45 CE 8B 31 22 33 33 B6 A4 FF 8B 11'\r\n '7C A5 AB 02 2F F9 1A 67 81 4C 2E 7B 2A 4B 66 C8 95 E9 A2 99 2A 9B 19 29 3B 41 3D CD B5 F8 9A 68'\r\n '17 73 ED C8 D2 C5 E4 24 B9 26 BA E8 64 5D 3C 31 52 76 8A 0A F0 1E 9B 2A F2 A6 9E 26 72 0E 4D 17'\r\n 'B9 A8 2C D4 60 87 23 89 5F AF 5B 61 45 49 D4 E2 D9 5A 72 95 93 BB 25 1F 76 F2 9C E4 DB 4E BE 29'\r\n 'F9 8E 93 6F 49 5E 70 32 4F 29 CA 98 52 92 F9 25 F3 39 59 48 B2 A0 93 A5 25 EF 71 B2 AC 64 19 27'\r\n '2B 52 C6 57 28 05 BE 2A 95 62 FF BD E4 AB 8A 02 95 4B 81 AF B0 02 5E F2 D5 50 17 D7 73 17 37 91'\r\n '6C EC 64 73 C9 A6 4E B6 94 6C E1 64 5F 49 AE CC 94 FD 25 FB 39 EF 48 C9 36 4E 8E 72 95 B9 02 A3'\r\n '25 EB 3B 39 46 72 A0 2B 30 56 32 CD C9 F1 92 E9 4E 66 48 8E 73 72 A2 64 A6 93 59 92 13 9C 9C 21'\r\n '39 C9 C9 99 92 93 9D 9C 23 39 CB C9 B9 92 B3 9D 5C 20 39 CF C9 85 92 F3 9D DC 29 F9 B8 93 BB 24'\r\n 'B7 3A B9 5B 72 9B 93 7B 24 77 38 F9 B1 E4 14 27 3F 91 9C EA E4 A7 92 2B 9D FC 4C 72 95 93 57 25'\r\n 'F7 3B F9 AD E4 01 27 BF 93 3C E8 E4 F7 92 87 9C BC EF 1E 2E 94 DC A9 CB 8B DC 41 FB 96 46 54 5E'\r\n 'DE 92 FD 44 2E 0C FD 45 CE 9E 01 22 17 83 81 22 6F E7 34 91 B7 FE 20 91 37 F4 60 91 B7 F4 10 91'\r\n '6B D2 D0 D2 88 CE EB 57 A3 61 26 F9 1A 6E 92 15 8F 30 C9 BA 47 9A 64 F5 A3 4C B2 85 D1 26 D9 C8'\r\n '18 93 6C 67 AC 49 36 95 6E 92 AD 8D 93 4C 72 AD 8D 2F CD 99 54 CE B5 C6 FD 39 C3 AC 24 67 65 9A'\r\n '95 EC AC 09 66 55 73 D6 44 B3 AA 3B 2B CB AC 1A CE 9A 64 56 4D 67 4D 36 AB 96 B3 A6 98 55 DB 59'\r\n '53 4B F3 7E F6 AD 87 9D 63 5A E0 F0 3D 9A 1E 38 7C A7 66 04 0E DF AF 99 81 C3 77 6D 56 E0 F0 BD'\r\n '9B 1D 38 7C 07 E7 04 0E DF C7 B9 81 C3 77 73 5E E0 F0 3D 9D 6F 8E A4 48 4F 17 70 0C E3 AB BA 73'\r\n 'E4 42 C9 24 27 17 49 26 3B B9 58 B2 9A 93 4B 24 AB 3B B9 54 B2 86 93 CB 24 6B 3A B9 5C B2 96 93'\r\n '2B 24 6B 3B B9 52 63 E5 87 86 D6 2A B3 7C 9B 0F 99 E5 9B 7D D8 2C DF F2 23 66 F9 C6 57 9B E5 DB'\r\n '5F 63 96 EF C2 5A B3 7C 2F D6 99 E5 3B B2 DE 2C DF 97 0D B2 92 22 7D D9 68 59 EC E7 86 E2 51 B3'\r\n 'FA 3B 6B 93 59 03 9C B5 D9 AC 81 CE 7A CC AC 34 67 6D 31 6B 90 B3 1E 37 6B B0 B3 9E 30 6B 88 B3'\r\n '9E 34 6B A8 B3 9E 32 6B 98 B3 9E 36 6B B8 B3 9E 31 6B 84 B3 B6 9A 35 D2 59 DB CC 1A E5 AC ED 66'\r\n '8D 76 D6 0E B3 C6 38 6B A7 59 63 9D B5 CB AC 74 67 ED 36 6B 9C B3 F6 98 35 DE 59 7B CD CA 70 D6'\r\n '3E B3 32 9D B5 DF AC 09 CE 3A 60 D6 44 67 1D 34 2B CB 59 87 CC 9A E4 AC 67 B5 44 F0 94 74 58 E4'\r\n '81 EC 39 91 1B ED 11 91 1B ED 51 91 07 B2 E7 45 1E A8 5E 10 9B 03 2F 8A 3C 82 1E 13 B9 51 1F 17'\r\n '5B 01 2F 89 3C EB BD 2C 72 E3 7E 45 E4 46 FD AA C8 23 E7 6B 62 5B E0 75 91 E7 CE 13 22 CF 9D 27'\r\n '45 9E 33 4F 89 3C 67 BE 21 F2 58 79 5A EC 04 9C 11 79 8A 38 2B 76 01 CE 89 3C 26 BC 29 76 03 DE'\r\n '12 79 D6 7C 5B E4 C4 39 2F 72 CA 5C 10 39 59 2E 8A 9C 26 EF 88 9C 20 D9 22 A7 46 8E C8 49 F1 AE'\r\n 'C8 E9 70 49 E4 44 78 4F E4 14 78 5F 64 F2 2F 8B 4C FB 15 91 09 FF 40 64 AA 3F 14 99 E4 8F 44 A6'\r\n 'F7 63 91 89 FD 44 64 4A 3F 15 F5 D7 2E 44 A6 F1 73 91 09 FC 42 64 EA BE 14 99 B4 AF 44 A6 EB 6B'\r\n '91 89 FA 46 64 8A AE 8A BC 2D 0A 95 E7 0A 91 BB 59 F3 35 BE 3C D3 58 07 E0 8B 1B 6E 46 79 DE D7'\r\n 'F7 3B 99 A9 80 97 7C 5D 61 00 1F 94 D7 EE 32 A5 22 1F 5F F8 96 A6 92 F9 38 94 A3 2B E9 E7 7D 95'\r\n 'B0 B9 32 4F 28 E7 86 E3 57 71 F3 66 3D 8F 44 C5 23 05 51 62 B9 14 44 8B 35 52 10 23 3E 90 82 3C'\r\n '62 B7 14 C4 8A 73 53 10 27 2E 49 41 5E F1 B1 14 E4 13 8F A6 20 BF 2B 9F 8A 02 62 5A 2A 0A 8A C3'\r\n '53 51 48 9C 95 8A C2 E2 EA 54 14 11 77 A4 A2 A8 F8 71 2A E2 C5 DF 53 11 72 FD 68 8F 62 E2 86 F6'\r\n 'B8 49 FC BB 3D 6E 16 6F E9 80 5B C4 3B 3B E0 56 B1 56 07 DC 26 36 EC 80 DB C5 9E 1D 70 87 38 B4'\r\n '03 EE 74 ED 75 C0 5D E2 B3 1D 70 B7 78 AA 03 8A 8B 9F 75 40 82 F8 6E 67 24 8A 89 5D 50 42 FC B6'\r\n '2B 4A 8A D1 DD 50 4A 2C D0 0D F7 B8 76 BB A1 B4 78 6F 37 94 11 C7 75 43 59 B1 5D 0F DC 2B CE E8'\r\n '81 72 E2 5F 3D 70 9F 58 B4 27 CA 8B A5 7A A2 82 EB 67 4F 54 14 47 F5 44 25 71 6C 4F 54 16 2F F7'\r\n '42 15 F1 8B 5E 08 8B 3F F7 42 55 F1 46 2F 24 89 E9 BD 91 2C 4E EA 8D 6A E2 F4 DE A8 2E FE D6 1B'\r\n '35 5C B9 DE A8 29 16 EC 83 5A E2 4D 7D 50 DB F5 AB 0F EA 88 FD FA A0 AE EB 6F 1F D4 13 5F ED 83'\r\n 'FB C5 7C FD 51 DF E5 B7 3F 1E 10 1F EC 8F 06 62 95 34 34 14 AB A5 A1 91 38 3F 0D 8D C5 35 69 68'\r\n '22 3E 99 86 A6 E2 91 34 34 73 79 4B 43 73 D7 FF 34 B4 10 7F 1A 84 96 AE FE C1 68 E5 E6 D1 60 3C'\r\n '28 96 18 8E D6 62 FF E1 68 23 66 0D 47 8A 78 60 38 DA 8A 67 86 A3 9D F8 CE 70 A4 BA 71 19 8E F6'\r\n '6E 1C 47 A0 83 78 F3 08 74 74 FD 1A 81 4E 6E 3E 8D 41 67 B1 7C 3A BA B8 F7 91 8E AE 62 DD 74 74'\r\n '73 F3 2F 1D DD C5 E6 E9 E8 E1 E6 6D 3A 7A 8A 3D D2 D1 4B DC 99 8E DE E2 9C 71 E8 23 2E 1C 87 BE'\r\n 'E2 95 F1 E8 27 7E 39 1E FD C5 DB 33 30 C0 CD 8F 0C 0C 74 EF 27 03 69 62 38 03 83 C4 C5 19 18 2C'\r\n 'AE CA C0 10 31 33 13 43 C5 A9 99 18 26 EE CE C4 70 F1 78 26 46 88 3F 64 62 A4 7B 7F 13 30 4A FC'\r\n '74 02 46 8B BF 4E C0 18 B1 4E 16 C6 8A CF 65 21 5D 3C 96 85 71 E2 F8 49 18 EF C6 69 12 32 DC FD'\r\n '30 09 99 2E AF 53 30 C1 CD BB 29 98 E8 C6 61 3A B2 C4 D4 E9 98 24 2E 9A 8E C9 E2 8B D3 31 45 8C'\r\n '9A 81 A9 62 A1 19 98 26 16 9B 81 E9 62 F2 0C CC 70 F3 6B 06 66 BA F1 98 81 59 EE 3E 99 89 D9 E2'\r\n 'D5 99 98 E3 FA 39 13 73 C5 6B 33 31 CF D5 33 0B F3 C5 BB 66 61 81 1B A7 59 58 E8 E6 F9 2C 2C 72'\r\n 'F3 77 16 16 8B 13 67 61 89 D8 66 1E 96 BA FC CD C3 32 B1 C1 02 2C 17 5B 2F C0 0A 71 C0 02 AC 14'\r\n 'A7 2D C4 2A 37 BE 0B F1 90 78 61 21 1E 76 EB C2 22 3C 22 D6 5C 82 D5 62 B3 25 58 23 76 5A 82 B5'\r\n 'AE 9D 25 58 27 3E BA 04 EB C5 81 4B B1 41 1C B3 14 1B DD 7C 5B 8A 47 DD BA B3 0C 9B C4 D3 CB B0'\r\n 'D9 AD 33 CB F1 98 B8 77 39 B6 88 87 96 E3 71 71 E5 0A 3C 21 B6 5C 89 27 C5 13 2B F1 94 78 76 25'\r\n '9E 16 CF AF C4 33 E2 84 47 B0 D5 AD 03 8F 60 9B 78 F7 6A 6C 77 EB CE 6A EC 70 F7 CB 6A EC 14 BF'\r\n '5E 8D 5D 2E 3F 6B B0 5B EC BD 06 7B DC 7D B1 06 7B DD BA B5 06 FB 5C 9E D7 60 BF F8 FD 1A 1C 70'\r\n 'E3 BE 06 07 5D FE D6 E2 90 B8 75 2D 9E 75 F3 68 2D 0E 8B 1F AD C5 73 6E 5D 5D 87 23 E2 BA 75 38'\r\n 'EA E6 F9 3A 3C EF CA AF C7 0B E2 A5 F5 78 D1 95 5F 8F 63 62 99 0D 38 EE EE FB 0D 78 49 4C DA 80'\r\n '97 C5 7A 1B F0 8A D8 7D 03 5E 75 F7 F7 46 BC 26 66 6C C2 EB 6E 9E 6C C2 09 F1 A9 4D 38 29 3E BF'\r\n '09 A7 DC FA B2 09 6F 88 E7 36 E1 B4 1B 9F 4D 38 E3 E6 EB 26 9C 15 AF 6F C2 39 B1 C8 66 BC E9 D6'\r\n 'AB CD 78 CB AD 0F 9B F1 B6 BB 7F 37 E3 BC D8 6A 33 2E 88 ED 37 E3 A2 B8 74 33 DE 11 37 6E 46 B6'\r\n 'DB 6F 36 EB D4 18 55 B0 04 0F 9D 61 CD E3 30 6A 85 FD 3E 50 5B 6C D2 01 75 C4 A6 1D D0 3A AC 1F'\r\n 'E1 86 B1 2E 8C 14 C9 36 4E B6 93 6C EB 64 7B C9 54 27 3B 4A 76 70 B2 B3 64 27 27 BB 4A 76 71 B2'\r\n 'BB 64 37 27 7B 4A F6 70 B2 B7 64 2F 27 FB 4A F6 71 B2 BF 64 3F 27 D3 24 07 3A 39 58 72 90 93 43'\r\n '25 87 38 39 46 72 B4 93 63 4D AE 0F 63 9C 64 BA F3 8E 37 49 6F A6 64 86 F3 4E 30 49 6F 96 E4 44'\r\n 'E7 9D 64 92 DE 29 92 93 9D 77 AA 49 7A 1F 96 6C E6 BC 1B C2 FE 93 66 CA 8D 26 59 60 93 0A 3C EA'\r\n '0A 6C A6 2C B0 20 8C 45 61 EC 94 77 87 F3 EE 96 DC E5 E4 5E C9 3D 4E EE 97 DC E7 E4 41 C9 03 4E'\r\n '3E 2B 79 C8 C9 E7 24 0F 3B 79 54 F2 88 93 2F 48 3E EF E4 31 C9 17 9D 7C 49 F2 B8 93 AF 48 BE EC'\r\n 'E4 EB 92 AF 39 79 52 F2 84 93 6F 48 9E 72 F2 6D C9 B7 9C 3C 6F 92 6F E8 A2 E4 05 E7 7D C7 24 BD'\r\n '39 92 D9 CE FB AE 49 7A DF 93 BC E4 BC EF 9B A4 F7 8A E4 65 E7 FD C0 24 BD BF 49 3E ED BC 7F 4A'\r\n 'FE E8 E4 5F 92 3F 39 F9 B7 E4 CF 4E FE 23 F9 8B 93 37 24 AF 3B F9 3F 8D 2F 07 8A BD AF 5A 55 2B'\r\n '5C 08 49 62 54 08 C9 E2 F6 10 AA 89 D1 21 54 17 77 86 50 43 DC 15 42 4D 31 26 84 5A 62 9E 10 6A'\r\n '8B B1 21 D4 11 F7 86 50 57 DC 17 42 3D 71 7F 08 F7 8B 07 42 A8 2F 1E 0C E1 01 F1 50 08 0D C4 3B'\r\n '43 68 28 C6 85 D0 48 CC 1B 42 63 31 5F 08 4D C4 92 21 34 15 F3 87 D0 4C 2C 10 42 73 B1 60 08 2D'\r\n 'C4 42 21 B4 14 0B 87 D0 4A 2C 12 C2 83 62 D1 10 5A 8B F1 21 B4 11 43 21 A4 88 C5 42 68 2B F6 0B'\r\n 'A1 9D D8 3F 84 54 71 40 08 ED C5 81 21 74 10 D3 42 E8 28 0E 0A A1 93 38 38 84 CE E2 90 10 BA 88'\r\n '43 43 E8 2A 0E 0B A1 9B 38 3C 84 EE E2 88 10 7A 88 23 43 E8 29 8E 0A A1 97 38 3A 84 DE E2 98 10'\r\n 'FA 88 63 43 E8 2B A6 87 D0 4F 1C 17 42 7F 71 7C 08 03 C4 8C 10 06 8A 7D 43 48 13 6F 0E 61 90 78'\r\n '4B 08 83 C5 93 21 0C 11 4F 85 30 54 3C 1B C2 30 F1 CD 10 86 8B 17 43 18 21 BE 1B C2 48 F1 BD 10'\r\n '46 89 77 87 30 5A FC 20 84 31 E2 47 21 8C 15 8B 87 90 2E 26 84 30 4E 2C 11 C2 78 B1 54 08 19 E2'\r\n '3D 21 64 8A F7 86 30 41 BC 2F 84 89 62 85 10 B2 C4 8A 21 4C 12 2B 85 30 59 AC 1C C2 14 B1 4A 08'\r\n '53 C5 A4 10 A6 89 35 42 98 2E 36 08 61 86 D8 3C 84 99 62 EB 10 66 89 3F 87 30 5B FC 25 84 39 62'\r\n '97 10 E6 8A 5D 43 98 27 76 0B 61 BE 38 27 84 05 E2 DC 10 16 8A 0B 42 58 24 AE 0C 61 B1 B8 2A 84'\r\n '25 E2 C3 21 2C 15 37 85 B0 4C DC 12 C2 2A 32 1F 9F 38 1E 12 F9 24 F1 B0 98 3F 05 8F 88 97 3B 63'\r\n 'B5 58 20 05 6B C4 4A 29 58 2B 16 4C C1 3A 31 29 03 EB 45 3E 91 6C 10 EF 48 C1 46 31 2A 05 8F 8A'\r\n 'F7 75 C3 26 31 DC 05 9B 45 3E 99 20 C9 3F 02 F3 16 E3 23 70 94 59 D1 CE 8A 36 2B C6 59 31 66 C5'\r\n '3A 2B 8F 59 71 CE 8A 35 2B AF B3 E2 CC CA EF AC BC 66 15 74 56 3E B3 0A 39 2B BF 59 45 9C 55 C0'\r\n 'AC A2 CE 2A 68 56 BC B3 0A 99 15 72 56 61 B3 8A 39 AB 48 92 FF C8 88 EF A1 9F 73 14 35 47 74 C4'\r\n '11 6F 8E 98 88 23 64 8E D8 88 A3 98 39 E2 22 8E 9B CC 91 37 E2 B8 D9 1C F9 23 8E 5B CC 51 30 E2'\r\n 'B8 D5 1C 85 22 8E DB CC 51 24 E2 B8 DD 1C 45 23 8E 3B CC 11 1F 71 DC 69 8E 50 C4 71 97 39 8A 45'\r\n '1C 77 07 AD 8C 72 8E E2 49 C8 6B FD E0 8D 4F 37 97 87 1D 2E 92 90 84 B8 20 52 2C 72 41 89 48 CE'\r\n '53 64 95 34 6B 89 B3 4A 45 72 E7 AC 7B CC E2 C4 A3 55 DA AC 87 5D AC 8C 59 23 53 65 95 8D CC 15'\r\n '17 BB D7 AC E1 2E 56 CE AC 5E 2E 76 9F 59 3C 96 D0 2A 6F 16 1F 8E 68 55 88 5C 37 46 56 45 B3 F8'\r\n '80 43 AB 92 59 E5 5C C9 CA 66 F1 B0 49 AB 8A 59 7C 64 A5 15 36 8B 0F 60 B4 AA 9A 55 7E 88 AC A4'\r\n 'C8 FB 73 B5 24 9B 55 3F 4B 56 35 B3 0A 77 94 55 DD AC AC 74 59 35 CC DA B2 44 56 CD C8 3B 72 D7'\r\n 'D5 32 EB 60 7B 59 B5 CD FA CC BD DB 3A 66 4D 71 75 D6 35 6B 50 0F 59 F5 22 25 33 65 DD 6F 56 54'\r\n '5B 59 F5 CD 3A E9 DA 7B C0 AC 8E 6E CC 1A 44 46 DE B5 DE 30 72 67 B8 EB 1A 99 C5 87 13 5A 8D CD'\r\n 'FA D5 59 4D 92 F4 81 53 27 34 15 A7 F4 46 33 91 4F B3 CD C5 E5 93 D1 8E A5 8B B4 03 FC 17 9A A9'\r\n '49 FE B3 EB AA 40 7B 93 7C 75 30 A9 EF EF 4C 56 03 3A 99 D4 37 77 26 6B 00 5D 4C D6 04 BA 9A AC'\r\n '05 74 33 59 1B E8 2E 99 EC 3E EB EC 61 92 AD F5 34 C9 32 BD 4C F2 D5 DB 24 5B EB 63 92 AD F5 55'\r\n 'D7 75 DF 8B BC DD FB 8B BC CB 07 88 BC B9 07 8A BC A7 D3 44 DE CA 83 44 DE C1 83 45 DE 16 43 44'\r\n 'DE 32 43 45 DE A6 C3 44 DE 9D C3 45 DE 94 23 44 DE 8B 23 45 DD 40 6A DA AF 33 A3 25 FD 0A 33 46'\r\n 'D2 AF 2D 63 25 FD AA 92 2E E9 D7 93 71 92 7E 25 19 2F E9 D7 90 0C 49 BF 7A 64 4A FA 75 63 82 A4'\r\n '5F 31 26 4A FA B5 22 4B D2 AF 12 93 24 FD FA 30 59 D2 AF 0C 53 92 10 6B 97 1D 0E 69 29 E4 1D 3F'\r\n '95 4B 45 5E BF 4E B0 19 EE DE D3 AC 45 3A 66 B8 91 4B C1 4C 91 F7 FE 2C 37 32 29 98 2D F2 7E 9F'\r\n '23 F2 4E 9F 2B F2 1E 9F E7 46 36 05 F3 45 DE D7 0B 44 DE D1 0B 45 DE CB 8B 44 DE C5 8B 5D 7C 0C'\r\n '96 88 BC 73 97 8A BC 67 97 89 BC 5B 97 8B BC 4F 57 88 BC 43 57 8A BC 37 57 B9 F6 07 E3 21 91 F7'\r\n 'E3 C3 22 EF C4 47 44 DE 83 AB 45 DE 7D 6B 5C BB 59 58 2B F2 8E 5B 27 5E CA C2 7A B1 66 06 36 88'\r\n 'E3 BA 61 A3 38 74 05 1E 75 F5 A7 62 93 38 A6 03 36 8B 5F 8F C0 63 6E 86 AC C5 16 97 E1 B6 78 5C'\r\n '5C 97 8A 27 C4 01 C3 F1 A4 C8 8D F6 29 91 1B ED D3 6E C6 A4 E0 19 F1 CB 5E D8 2A FE DA 01 DB C4'\r\n 'BA 1D B0 5D 5C D3 03 3B 44 DE DF 3B 45 DE D9 BB 44 DE D3 BB 45 DE CD 7B 44 DE C7 7B C5 BB BB 61'\r\n '9F 4D 66 DE 2F FB 4D F2 7E 39 60 92 F7 CB 41 93 BC 5F 0E 49 56 73 F7 CB B3 26 79 BF 1C 36 C9 FB'\r\n 'E5 39 93 2C 7E C4 24 5F 47 4D F2 7E 79 DE 24 5B 7B C1 24 5B 7B D1 24 5B 3B 66 92 AD 1D 97 AC EE'\r\n '5A 7B 29 C9 7F 07 C3 FC BE 9C E4 BF 83 A1 7C 25 C9 7F 07 43 F9 6A 92 FF 0E 86 F2 B5 24 FF 1D 0C'\r\n 'E5 EB 49 FE 3B 18 CA 13 49 FE 3B 18 CA 93 49 FE 3B 18 CA 53 49 FE 3B 18 CA 37 92 72 BF 83 A1 75'\r\n '3A 29 F7 3B 18 5A 67 92 72 BF 83 A1 75 96 17 15 69 E1 BE BF 38 A7 15 2B CD 7D 61 40 EB 4D 05 D2'\r\n 'DC 57 F1 6F 29 D0 DA 2D 65 4D 80 B7 35 D6 8F F3 E1 47 7C 32 8C 0B 22 9F 50 2E 8A 5B F9 F8 23 6E'\r\n '0F 23 5B E4 C3 5C 8E C8 27 B9 77 45 3E C6 5D 12 F9 0C F7 9E C8 E7 92 F7 45 3E BD 5D 16 F9 E8 76'\r\n '45 E4 73 DB 07 22 1F DA 3E 14 F9 C4 F6 91 C8 C7 B5 8F 45 3E AB 7D 22 F2 41 ED 53 91 4F 69 9F 89'\r\n '7C C8 F9 5C 3C 1D C6 17 E2 99 30 BE 14 CF 86 F1 95 78 2E 8C AF C5 37 C3 F8 46 E4 C3 DB 55 91 8F'\r\n '6B DF 8A 7C 40 FB CE DD 03 61 7C EF EE DD 30 7E 10 3F 0C E3 47 F1 A3 30 7E 12 3F 0E E3 67 F1 93'\r\n '30 7E 11 3F 0D E3 57 F1 73 3E B1 B9 39 1D C6 EF EE DE 08 E3 0F F1 1B 3E BE 89 57 F9 EC 26 7E CB'\r\n '07 37 F1 3B 3E B5 89 DF 87 F1 AF C8 C7 BB 6B 22 9F ED AE 8B 7C B0 BB 21 F2 A9 8E F3 30 B6 08 C7'\r\n 'DD 3F 6F 5E 73 0F 74 51 C9 C8 23 1F AB 63 CF B7 F0 49 CF 0A FD 1A B6 A7 4A EA 98 64 A6 EF 71 77'\r\n '09 CB E5 51 09 A6 ED 8C 2B E4 1F AB 63 55 E2 49 E7 E0 C0 C6 C9 62 42 B7 39 07 EF 96 B8 22 4C EB'\r\n '11 57 D8 37 CB 4B F2 A9 E5 AD CE B1 C3 FD 99 5F 57 6D 77 97 B0 68 01 B3 18 E0 50 15 94 C5 62 6C'\r\n '82 03 50 48 97 D2 E2 98 BC EA AA 2B 6C 8E EF 5D 98 97 14 31 C7 3A E7 63 8D 45 03 07 2D 26 23 5E'\r\n 'BD F2 1F 0F F8 3F 7D 30 A4 72 DE 71 C6 D5 54 CC 1C 5F 44 AA BE 29 19 F9 AC C4 B7 91 6B FD 67 00'\r\n '0C DE 9C CC 39 BF CB 35 7A 8B 35 F0 7D 64 8C BE 71 EF E4 D6 C0 FD 49 64 34 58 CF 6D 1A 54 EF FE'\r\n '31 F2 AE 6E 57 D3 FF BD F6 0E 5D FB 5F C7 29 F7 6E EE 34 37 AB F1 1F 51 3C E9 EA B9 CB 2E FF DE'\r\n '35 C3 79 7B B7 06 71 9F B3 38 C0 C5 65 1D 70 57 71 AE 27 A8 F0 01 17 F3 1F 1B 24 CA 71 C8 D5 E5'\r\n 'AB 2E A1 1E 1E 8A A4 D8 A7 A5 A4 7C 87 DD C8 E4 4E 85 52 AA F7 F9 48 B9 7B 02 8B 9D 2D AD 4A 73'\r\n '07 8B 9D 28 A3 B0 FF 80 84 D5 94 95 75 2A 32 B4 F7 6A 2C FD 3B 2C 27 C9 5E F2 A6 BB 4F 65 DE 8C'\r\n '0C 51 79 59 6F B9 5E F2 46 AE A0 81 C8 9D DD B9 AD 56 54 AB B9 6E 96 AB A4 6E BF 15 E9 C6 77 AE'\r\n 'B5 CA BA F6 42 64 C6 1F 89 E4 A5 8A AE F5 6E 3F 0C 61 B5 E8 1D 1C AE AA 66 F9 1E 27 A9 0E 7F 1B'\r\n 'E5 4E 4D 46 92 55 07 DD 4F 44 F2 5D CD CA AD 73 85 F8 C6 9F 71 97 57 57 65 D9 EE 5A 76 BC 86 3A'\r\n '79 C9 35 7B 3C 72 EB D5 54 09 7F 5B 72 3D AB A5 7A BD C5 B9 CA 5E D4 B6 F0 B7 EE 5D D6 09 C2 FE'\r\n '96 AA 9B 8C BC E6 B8 16 B9 BB FD 27 5D F5 AC A8 1F 10 36 77 BF 1A F7 13 E1 C9 C8 30 D6 57 A1 CB'\r\n '91 F7 4A C7 03 CA CA 65 17 6E A0 AA 2F 47 DA F2 C2 BF F9 86 EA D3 E5 C8 1B 68 14 58 2C D7 58 35'\r\n '7E 18 99 63 9C A7 4D 14 F6 0E 16 6E 6A D6 AB 6E C9 6A 66 D6 B7 AE 70 73 75 F0 43 57 0B DF C2 57'\r\n '4E B4 50 75 1F 45 EA A2 A3 A5 3A F8 91 9B 9E AD 34 E4 5E E6 26 9E 35 3D A8 4A 3F 89 DC FC AD 55'\r\n '69 AE E5 A7 5E 1B 55 FA DF 3B 35 45 8E CF FF B3 90 B5 55 1D 9F 47 6A 6C 27 EB 4B 37 89 78 75 AA'\r\n '0A 5F 8D CC 05 86 DB AB 4B 57 5D 8E 3B 28 F6 6D D8 3E E8 E3 D5 1D D5 FC B7 4E 66 47 86 B9 93 CA'\r\n '7F E7 6E B6 CE 7A 0B DF 45 B2 B1 2F B2 96 75 51 83 B9 6B 46 57 96 8F E7 52 7F 64 0C BA 25 FB 53'\r\n '02 65 F7 64 7F 4A A0 EC 91 EC 4F 09 94 3D 93 FD 29 81 B2 57 B2 3F 25 50 F6 4E F6 A7 04 CA 3E C9'\r\n 'FE 94 40 D9 37 D9 9F 12 28 FB 25 FB 53 02 65 FF E4 DC 53 02 AD 01 C9 B9 A7 04 5A 03 93 73 4F 09'\r\n 'B4 D2 92 73 7F A9 41 6B 50 72 EE 2F 35 68 0D 4E CE FD A5 06 AD 21 C9 B9 BF D4 A0 35 34 39 F7 97'\r\n '1A B4 86 25 E7 FE 52 83 D6 F0 E4 DC 5F 6A D0 1A 91 9C FB 4B 0D 5A 23 CD F2 7D 19 65 96 EF CB 68'\r\n 'B3 7C 5F C6 98 E5 FB 32 56 A3 39 04 FA E7 17 FA F1 20 A3 D1 1F E8 E4 38 C9 86 D0 DF 29 1D AF 32'\r\n 'FD 7D 01 20 43 81 D1 EE 98 93 29 39 C6 FD 04 64 82 5D 39 12 98 A8 E2 5E B2 99 AC C0 62 FB 93 54'\r\n 'AC A5 AB 75 B2 E4 B8 DE 88 EF 8F 29 92 95 06 61 49 47 4C 95 BC B7 1B 78 04 9E 26 59 64 10 9E 1F'\r\n '81 E9 9A 3A 3C A5 17 ED 83 3B DB EA 71 79 86 B5 CC 0E CE 94 1C E5 E4 2C C9 17 DC DF FE 9E 2D 39'\r\n 'D2 79 E7 48 0E 77 72 AE E4 83 D0 3F 0C 33 4F B2 8D 93 F3 25 9B 3B B9 40 BD 1D E0 DE EA 08 60 A1'\r\n '9A 1D EE DE 9F 77 2C B2 66 9B 01 8B AD 59 CA 25 D6 2C E5 52 93 3C 0E 2E B3 1E 50 2E B7 1E 50 AE'\r\n '48 F6 A7 C7 49 C0 4A B5 45 AF B7 56 C9 6A 13 B1 1E 92 D5 3C 62 3D 2C AB 63 C4 7A C4 DA 60 7F 56'\r\n '5B 1B 94 6B 2C 01 FA F5 B4 35 47 B9 4E 72 90 1B FD F5 D6 61 CA 0D 56 03 E5 46 AB 81 AF 47 25 07'\r\n '38 B9 C9 6A A0 DC AC B6 47 46 B2 F9 98 8D 8F B7 B6 D8 C5 94 8F DB 9B F1 D6 13 C1 45 4C FA 93 C1'\r\n '45 B4 9E B2 8B 28 9F 0E 2E A2 F5 8C 5D 74 4B 29 FD E6 66 AB C6 3E D7 62 9D DB 74 9D 9F A6 DB ED'\r\n '3A 6F ED B0 91 F3 D6 4E 1B 39 6F ED 92 95 EE 24 C7 66 B7 16 9C 5C CB D7 BC 47 AB CC FF F3 B1 B5'\r\n 'BD 96 69 5A FB 6C E0 28 F7 DB C0 51 1E B0 B7 41 79 D0 CA F2 8E 38 64 65 29 9F B5 B2 94 87 AD 2C'\r\n 'E5 73 36 B2 94 47 6C 06 52 1E B5 1A BA F0 11 C9 6A A0 7C C1 6A A0 7C D1 6A A0 3C 66 35 50 1E B7'\r\n '1A 28 5F 32 EF B6 18 BC 6C 5E CA 57 34 88 FD DC 4F B9 46 BA 3F 5F 55 AC 91 FB C1 D3 6B 96 6E BE'\r\n '5E 37 C9 01 38 A1 2B 1A BB 81 F0 13 F6 A4 46 B0 B1 FB F9 14 AF 3F 65 B3 8C 55 BC 61 77 4D 16 70'\r\n '5A 72 88 1B C3 33 36 BF 39 FC 67 25 87 BA 9F 61 9D B3 FB 8E AF 37 4D B2 83 6F 59 9F C7 F3 11 49'\r\n '72 84 EB E5 79 93 BC EC 82 DA 1E E1 DA 66 4F 2E 5A 60 22 F0 8E 0D 07 17 A5 6C 9B 35 43 DD 7C CF'\r\n '31 6B B4 B3 DE B5 29 C3 FE 5C D2 FB 1A F3 9F 91 78 2F D9 7F DA D4 CE 75 E5 7D 2B D9 1E B8 EC D6'\r\n '25 B7 D4 5D 91 EC E0 7E D8 F5 81 64 17 D7 E2 87 BA B2 B3 1B 22 56 F5 91 AC 86 11 EB 63 DB 83 BE'\r\n '48 C3 27 B6 07 51 7E 6A 7B 10 E5 67 B6 07 51 7E 6E 7B 10 E5 17 B6 07 51 7E 69 7B 10 E5 57 B6 07'\r\n '51 7E 6D 7B 10 E5 37 C1 1E 44 EB 6A B0 07 D1 FA 36 D8 83 68 7D 17 EC 41 B4 BE 0F F6 20 5A 3F 04'\r\n '7B 10 AD 1F 83 3D 88 D6 4F C1 1E 44 EB E7 60 0F A2 F5 4B B0 07 D1 FA 35 D8 83 68 FD 16 EC 41 B4'\r\n '7E 0F F6 20 5A 7F 04 7B 10 AD 3F 83 3D 88 D6 5F 66 F9 BE FC 6D 96 EF CB 3F 66 F9 BE FC 6B 96 EF'\r\n 'CB 35 B3 7C 5F AE CB 4A 8E F4 E5 86 59 BE 2F FF 53 92 06 47 56 F1 31 CF E8 5F 85 7B 06 F8 1B 51'\r\n '68 B1 04 51 E2 6F 83 10 2D 9E 5E 86 18 F1 D4 12 E4 11 CF 8F 42 AC 98 94 82 38 F1 8B 0E C8 2B 6E'\r\n 'DC 8C 7C C6 FC 62 6A 37 14 70 E5 57 A2 A0 38 BF 13 0A B9 FA BB A1 B0 F8 47 3F 14 11 87 66 A2 A8'\r\n '38 77 3A E2 C5 07 E6 21 24 1E 9D 8F 62 E2 5F 0B 70 93 B8 7C 05 6E 16 A3 87 E1 16 F1 AE 91 B8 55'\r\n '7C 6F 0C 6E 13 3F 1C 87 DB C5 FB E7 E0 0E 71 D8 4A DC 29 FE BC 0E 77 89 B3 52 70 B7 98 D1 01 C5'\r\n 'C5 3C C3 91 E0 EA 49 47 A2 58 69 1E 4A 88 09 9B 50 52 6C D7 0B A5 C4 6F 47 E3 1E F1 DC 5C 94 16'\r\n '07 2E 44 19 F1 8D FE 28 2B 5E 9A 89 7B C5 C4 05 28 E7 C6 AB 37 EE 13 6F 1B 8C F2 AE 1F 23 51 41'\r\n 'BC 96 8E 8A E2 9B 2B 50 49 9C D7 16 95 C5 C3 A9 A8 E2 FA DF 1E 61 F1 B5 81 A8 2A 5E 1C 86 24 31'\r\n '3E 1D C9 E2 57 99 A8 26 46 CD 40 75 31 6E 1E 6A 88 3D E7 A1 A6 F8 E3 52 D4 72 79 59 83 DA E2 E8'\r\n '0D A8 23 FE F3 28 EA 8A 4B 26 A2 9E 38 3D 0B F7 8B 8F 4D 45 7D F7 3E 66 E3 01 37 1E 0F A1 81 8B'\r\n '6F 42 43 31 67 11 1A 89 1F 75 45 63 17 EF 83 26 62 DF 29 68 2A 4E 9B 81 66 62 FF 74 34 77 EF 7B'\r\n '22 5A 88 AF 2C 41 4B F1 CF D5 68 E5 C6 A7 2B 1E 74 E5 7A A2 B5 78 D3 30 B4 11 DF 1F 89 14 B1 E8'\r\n '68 B4 15 AB 4C 45 3B B1 E6 34 A4 8A 0F AE 46 7B F1 42 7B 74 10 17 CF 40 47 F1 4A 2A 3A 89 67 53'\r\n 'D1 59 BC 7B 12 BA 88 C7 A6 A2 AB CB F7 6C 74 73 79 5E 8D EE E2 8C C5 E8 21 BE D5 1F 3D 6D FE F4'\r\n '12 6F 2C 42 6F B1 76 0A FA B8 F1 ED 81 BE 62 B1 BE E8 E7 E6 EB 38 F4 17 C7 64 60 80 CB 67 07 0C'\r\n '14 FF 9D 88 34 F1 78 5B 0C 12 B7 F5 C1 60 B1 70 0A 86 B8 7E 8D C0 50 71 62 1A 86 89 A5 A6 62 B8'\r\n 'F8 6A 07 8C 10 7B 77 C5 48 97 C7 09 18 25 B6 9C 83 D1 E2 F6 45 18 E3 E6 FD 70 8C 15 F7 2E 47 BA'\r\n 'B8 60 04 C6 B9 FE F6 C7 78 77 BF CD 42 86 CB DF 00 64 8A 69 19 98 20 EE 4E C1 44 77 3F A5 22 CB'\r\n 'E5 35 15 93 C4 99 43 30 D9 BD BF 29 98 E2 E6 C5 2C 4C 75 E3 BA 08 D3 DC B8 AC C4 74 F1 F7 F6 98'\r\n '21 36 EA 88 99 E2 B8 6E 98 25 7E D7 1B B3 C5 D7 D3 30 C7 F5 63 34 E6 8A E5 B3 30 4F DC F5 08 E6'\r\n 'BB 79 BE 1E 0B C4 35 9B B0 D0 CD F3 4D 58 24 6E 68 8F C5 E2 09 1E 67 C5 09 C3 B1 D4 CD 87 E5 58'\r\n '26 8E EF 8D E5 E2 8A 7E 58 21 72 47 59 29 AE 1F 88 55 E2 3D A3 F1 90 1B A7 B1 78 58 5C 38 1E 8F'\r\n 'B8 F9 96 85 D5 6E 9D 9A 8A 35 EE 7D CD C0 5A B1 EC 72 AC 13 7F 98 83 F5 EE FA 15 D8 20 B6 7A 08'\r\n '1B 5D 1E DB E3 51 F1 89 F6 D8 24 BE D8 11 9B DD FA 36 06 8F B9 F9 BB 00 5B 2C 1F 8F BB 71 EC 8D'\r\n '27 DC F8 F4 C1 93 E2 E4 01 78 CA 8D F7 70 3C 2D D6 9F 82 67 DC 7C 1B 87 AD E2 E7 29 D8 26 FE DD'\r\n '19 DB 6D 5E ED 70 79 ED 85 9D 6E BE F6 C5 2E 71 FF 38 EC 76 F9 1A 8F 3D EE FD 4E C7 5E B1 D9 0C'\r\n 'EC 13 AB AD C2 7E B7 4E AE C6 01 B7 6E AE C1 41 F1 F6 B5 38 E4 EE 87 B6 78 D6 F5 23 0B 87 C5 83'\r\n '2B F1 9C F8 DC 6A 1C 11 3F E9 8B A3 6E 9D 49 C1 F3 EE 7E 6B 87 17 DC B8 F4 C0 8B 6E 9D ED 89 63'\r\n 'E2 BA 34 1C B7 FB E2 25 97 B7 B1 78 D9 CD 83 4C BC E2 D6 AD 39 78 55 9C B2 02 AF 89 4B 37 E3 75'\r\n '37 2F 07 E1 84 58 79 35 4E BA BC B4 C7 29 37 3E 83 F1 86 F8 EB 60 9C 16 1B 8E C4 19 B7 2F 8C C2'\r\n '59 31 FF 78 9C 13 BB 65 E0 4D 71 F8 44 BC E5 D6 B9 A9 78 DB DD 1F 6B 71 5E 1C 99 8A 0B AE FE FE'\r\n 'B8 E8 EE A7 D5 78 47 AC D0 0E D9 E2 1D BD 90 23 5E 1D 89 77 DD 7C 5C 8E 4B 6E 5C FA E0 3D B1 49'\r\n '3F BC EF F2 3D 04 97 ED 7E BE E2 C6 63 35 3E 10 EF 6B 8F 0F DD FA D3 11 1F B9 FB A8 27 3E 76 EB'\r\n 'D3 20 7C 22 A6 0C C6 A7 E2 D6 21 F8 CC DD 77 23 F0 B9 5B 77 C7 E3 0B F1 D3 0C 7C 29 66 4D C7 57'\r\n 'EE 3E 5A 80 AF DD B8 2F C0 37 6E 1D 58 89 AB AE DC 6A 7C EB C6 BB 03 BE 73 F3 60 14 BE 17 8B 77'\r\n 'C4 0F E2 DB 63 F1 A3 B8 76 3C 7E 72 EB F5 5C FC EC E6 E7 6A FC 22 76 D9 88 5F C5 CD 9B F0 9B BB'\r\n 'BF 06 E3 77 F1 CC 48 FC 21 7E 3D 13 7F 3A 7B 12 FE 12 4B 4C C6 DF E2 AA 29 F8 47 7C 29 1D FF BA'\r\n '3C 8F C1 35 B1 EB 62 5C 77 FE 14 DC 10 6B CC C6 FF C4 3A 3C EA FD 43 E6 6D 8F 28 F1 E9 DE 88 16'\r\n '2F F6 47 8C 98 33 05 79 C4 B9 3D 10 2B 26 8C 44 9C 78 70 10 F2 8A 75 97 23 9F D8 7A 01 F2 8B 6D'\r\n '56 A3 80 B8 78 21 0A BA 7A 7A A3 90 D8 20 15 85 C5 97 3A 21 5E EC DE 15 C5 C4 F1 83 70 8B F8 61'\r\n '2A 6E 15 CB 8F C3 6D E2 E9 4C DC 2E D6 CB C2 1D 62 EF 2C DC 29 A6 65 E1 2E 71 79 16 EE 16 3B AF'\r\n '41 71 F1 D8 14 24 88 2F 4E 47 09 B1 D8 3C 94 12 FF 5A 84 32 62 AD 15 28 2B 5E 5F 81 F2 E2 8F 6B'\r\n '51 41 BC B6 16 15 C5 72 EB 50 C9 BD AF 47 11 16 77 B7 45 55 F1 AB 76 48 72 EF 2B 15 C9 E2 1B ED'\r\n '51 4D FC BC 3D AA 8B A9 1D 50 43 7C B4 13 6A 8A 71 9D 51 4B 1C D2 19 B5 DD FB EE 8A 3A E2 D6 AE'\r\n 'A8 2B 0E EC 89 7A E2 A8 9E B8 5F 7C B8 2F EA BB F2 FD F0 80 B8 AC 1F 1A 88 BF F4 43 43 B1 6D 1A'\r\n '1A 89 9F A6 A1 B1 B8 72 10 9A B8 7C 0C 41 53 71 C2 48 34 13 EF 1C 85 E6 62 A9 D1 68 E1 EA 1F 8B'\r\n '96 62 85 74 B4 72 FE F1 78 D0 5D 3F 11 AD C5 FA 59 68 23 B6 CC 42 8A D8 22 0B 6D C5 76 59 68 E7'\r\n 'C6 35 0B A9 62 AF 2C B4 17 97 66 A1 83 EB 5F 16 3A BA F7 35 09 9D C4 99 93 D0 D9 E5 75 32 BA FC'\r\n 'E3 D7 E5 AE 62 FE 69 E8 26 36 9C 86 EE 62 FA 74 F4 10 63 67 A0 A7 F8 FD 4C F4 12 B3 66 A1 B7 B1'\r\n '8F D8 65 0E FA 8A F1 0B D1 4F 5C BD 10 FD C5 A8 C5 18 20 D6 5E 8C 81 6E 5E 2D 41 9A 98 6F 29 06'\r\n '89 CF 2E C7 60 CB F3 10 F1 B3 D5 18 2A FE 6F 0D 86 B9 79 BA 16 C3 C5 8C BE 18 21 FE D0 28 7A A4'\r\n '78 FB 2C 8C 11 CB A6 60 AC 78 28 15 E9 2E 1F A9 18 27 CE 68 8B F1 62 D3 54 64 38 3B 15 99 E2 C9'\r\n 'F6 98 20 FE D3 1E 13 2D FF 59 62 A7 4E 98 24 AE EB 84 C9 2E 6F 9D 30 C5 E6 FB 54 F1 40 57 4C 13'\r\n '9B 74 C3 74 B1 63 37 CC 10 FB 77 C7 4C 37 0F 7B 60 96 78 81 FB AF F8 5E 6F CC 11 87 F6 C1 5C 71'\r\n '57 1F CC 13 2F F5 C5 7C 31 A5 1F 16 B8 71 E8 87 85 36 7F 16 89 7D FB 61 B1 CD A3 25 62 B5 FE 58'\r\n '2A BE 36 00 CB C4 BB 07 62 B9 D8 7E 20 56 B8 7C A7 61 A5 DD 8F AB FE F1 E7 D8 87 C4 BB 06 E3 61'\r\n '17 1F 8C 47 5C 9E 86 63 F5 3F FE BC B2 E6 1F BF CE AF 15 2F 8F C2 3A F1 CC 28 AC B7 79 B8 C1 AD'\r\n '17 63 B0 D1 E6 E3 A3 E2 33 13 B0 49 AC 9E 8E CD E2 9E 74 3C 66 F7 FD 16 71 EC 78 3C EE EE A3 0C'\r\n '3C E1 F2 96 81 27 C5 E2 99 78 4A 4C CC C4 D3 B6 3E 3C E3 DA CD C4 56 37 EF 32 B1 4D 6C 35 01 DB'\r\n 'DD FC 9C 80 1D E2 D9 89 D8 29 EE 9B 84 5D 36 4F 77 8B 93 A7 60 8F D8 63 2A F6 DA BC DD E7 EE 8B'\r\n 'E9 D8 6F F3 F4 80 1B 9F D9 38 E8 D6 8B D9 38 E4 DE FF 7C 3C EB DE F7 42 1C 16 E7 2D C4 73 36 4F'\r\n '8F 88 C7 17 E1 A8 AD 3B CF BB F1 58 84 17 6C FE BE F8 8F 3F 7F 1E 73 F3 7F 11 8E DB 7C 7E 49 5C'\r\n 'B4 18 2F DB 7C 7E C5 CD E3 E5 78 D5 DD 37 DC 7F DD 7C 5A 89 D7 C5 CC 55 38 21 4E E1 FE 6B F3 FC'\r\n '94 AD 83 6F B8 F1 58 83 D3 36 EF CF 88 05 D7 E2 AC CD FF 73 6E 5D DC 80 37 FF F1 CF 6B 6F B9 F1'\r\n '2A 17 FD B6 9B 8F E5 A2 CF 8B D9 C9 D1 17 DC 7C AE 8B 8B EE FE 68 80 77 5C 3F 1B 20 DB AD 17 ED'\r\n 'A3 73 C4 B7 7B 46 BF EB EE C3 69 D1 97 C4 C6 9B F1 9E 9B 7F 9B 81 7F F9 90 3E C8 FD 3D B7 28 93'\r\n 'FA 5F 0B 4D F2 C1 33 E6 5F 3E 94 FA 02 FA 7F E8 02 8B B1 58 15 1B E7 3E 0C 89 0B E4 4D 92 E3 63'\r\n '91 19 8B 9B 4D A6 C5 E2 16 93 C3 63 71 AB E4 34 57 E0 36 F3 8E 8C 45 F1 7F F5 2F FE C7 E2 60 2C'\r\n '12 25 7F 89 C5 E1 58 94 F8 17 51 51 9F C6 A2 A4 F8 76 2C 4A 89 17 63 71 8F F8 4E 2C 4A 8B 97 63'\r\n '51 46 BC 12 8B B2 E2 07 B1 B8 57 FC 3A 16 E5 C4 AB B1 B8 4F AC 00 94 57 D5 DF C4 E2 E5 58 54 30'\r\n 'F9 4A 2C 2A FE AB FF E9 31 16 2F B8 40 A5 C0 62 AC B2 8A BD ED 3A 53 C5 E4 73 B1 08 9B 64 99 AA'\r\n '92 E7 9D 4C 92 BC E0 64 B2 E4 45 27 AB 49 BE E3 64 75 C9 6C 27 6B 48 E6 38 59 4B F2 92 93 B5 6D'\r\n '14 28 EB 48 BE EF 64 5D C9 CB 4E D6 93 BC E2 64 7D C9 0F 9D 6C 20 F9 B1 93 0D 25 3F 71 B2 B1 E4'\r\n '67 4E 36 91 FC DC C9 66 92 5F 3A D9 5C F2 2B 27 5B 48 7E ED 64 4B 1B 18 CA 56 92 57 9D 7C D0 BA'\r\n '7E 24 16 AD ED 1D 1F 8F 45 1B EB 19 65 8A 35 41 D9 56 69 E5 E8 B0 9F ED 38 F0 71 63 E3 90 4A C6'\r\n '92 ED 65 4F 8E 43 07 D9 64 47 32 86 EC 44 E6 21 3B 2B 3E 2D 0E 5D 14 27 BB 2A 4E 76 53 9C EC AE'\r\n 'F8 8C 38 F4 50 9C EC A9 38 D9 4B 71 B2 B7 E2 93 E2 D0 47 71 B2 AF E2 64 3F C5 C9 FE 8A 4F 8F C3'\r\n '00 C5 C9 81 8A 93 69 8A 93 83 14 CF 8A C3 60 C5 C9 21 8A 93 43 15 27 87 29 FE 64 1C 86 2B 4E 8E'\r\n '50 9C 1C A9 38 39 4A F1 A7 E3 30 5A 71 72 8C E2 E4 58 C5 C9 74 C5 E7 C4 61 9C E2 E4 78 C5 C9 0C'\r\n 'C5 C9 4C C5 67 C7 61 82 E2 E4 44 C5 C9 2C C5 C9 49 8A CF 8B C3 64 C5 C9 29 8A 93 53 15 27 A7 29'\r\n '3E 3F 0E D3 15 27 67 28 4E CE 54 9C 9C A5 F8 D2 38 CC 56 9C 9C 23 7B 49 1C E6 CA 26 E7 C9 5E 16'\r\n '87 F9 B2 C9 05 B2 17 C4 61 A1 6C 72 91 EC B5 71 58 2C 9B 5C 22 7B 65 1C 96 CA 26 97 C9 DE 16 87'\r\n 'E5 B2 C9 15 6A 9F 5C A9 F6 C9 55 8A EF 89 C3 43 8A 93 0F 2B 4E 3E A2 38 B9 5A F1 03 71 58 A3 38'\r\n 'B9 56 71 72 9D E2 E4 7A C5 F7 C5 61 83 E2 E4 46 C5 C9 47 15 27 37 29 7E 34 0E 9B 15 27 1F 93 FD'\r\n '7C 1C B6 C8 26 1F 57 79 F2 09 95 27 9F E4 54 8D F3 FF D1 CC 53 94 B1 5E 3E AD AB 5E 8E C3 33 BA'\r\n '8A DC AA AB C8 6D BA 8A DC AE F8 B1 38 EC 50 9C DC A9 38 B9 4B 71 72 B7 E2 17 E2 B0 47 71 72 AF'\r\n '5A F1 FF 71 CD 3E B5 E2 E5 45 95 DA 15 87 77 54 8A CC 56 2D 64 8E 6A 21 DF 55 FC 64 1C 2E 29 4E'\r\n 'BE 27 FB 44 1C DE 97 4D 5E 96 7D 2A 0E 57 64 93 1F A8 15 FF 5F E9 7C A8 D0 99 38 7C A4 10 F9 B1'\r\n 'EC D7 E3 F0 89 6C F2 53 D9 6F C4 E1 33 D9 E4 E7 B2 DF 8E C3 17 B2 C9 2F D5 15 F2 2B 75 85 FC 5A'\r\n '76 CB 38 7C 23 9B BC CA 35 32 CE FF B7 3E F7 C6 E1 5B 5A B1 B9 D6 77 41 8C A3 F9 7D 10 A3 F5 43'\r\n '10 6B 11 87 1F 83 18 AD 9F 82 18 DF C4 CF 41 8C D6 2F 41 8C 6F FC D7 20 46 EB B7 20 C6 41 F8 3D'\r\n '88 D1 FA 23 88 F1 5D FC 19 C4 68 FD 45 2B 26 D7 FA 3B 28 C9 F7 F7 4F 50 92 D6 BF 41 49 5A D7 34'\r\n '56 67 E3 70 5D 63 45 DE D0 D8 90 FF D3 D8 90 B8 96 5B 53 C5 38 44 05 56 A5 38 44 07 56 D3 38 C4'\r\n '5C FB 6F 9B 79 02 8B 7F C6 5E 63 32 CB B9 2A E2 4C F2 FA BC 26 2B C7 21 9F 49 D6 93 DF 24 2B 29'\r\n '60 92 35 14 94 2C EF 6A 28 64 92 35 14 36 C9 1A 8A 98 64 0D 45 4D B2 86 78 93 AC 21 24 59 C1 D5'\r\n '50 CC 24 CB DE 64 92 65 6F 36 C9 B2 B7 48 56 74 4D DC 6A 92 65 6F 93 AC E4 6A B8 DD 24 BD 77 48'\r\n '56 76 DE 3B 4D 32 70 97 49 16 B8 5B 32 D9 15 28 6E 92 05 12 4C B2 4C A2 49 96 2D 21 59 DD 15 28'\r\n '69 92 DE 52 92 35 5C 0D F7 98 64 81 D2 26 59 43 19 93 2C 5B 56 B2 A6 2B 70 AF 49 7A CB 49 D6 72'\r\n 'F2 3E C9 DA AE B2 F2 26 E9 AD 20 59 C7 79 2B 9A A4 B7 92 64 43 E7 AD 6C 92 F5 56 31 C9 86 C3 26'\r\n '59 B6 AA 49 8E 64 92 49 8E 64 B2 64 23 77 59 35 93 2C 5B DD 24 CB D6 30 C9 B2 35 25 1B BB DB AE'\r\n '96 49 36 5C DB 24 6B A8 63 92 0D D7 35 D9 24 0E F5 4C B2 DE FB 4D B2 DE FA 26 59 EF 03 92 4D 5C'\r\n '65 0D 4C B2 B2 86 26 59 59 23 93 AC A1 B1 49 D6 D0 C4 24 6B 68 2A D9 D4 D5 D0 CC 24 6B 68 6E 92'\r\n '35 B4 30 C9 57 4B 93 AC A1 95 49 D6 F0 A0 64 33 57 43 6B 93 AC A1 8D 49 D6 90 62 92 C5 DB 9A 64'\r\n '0D ED 4C B2 86 54 C9 E6 AE 86 F6 26 59 B6 83 49 96 ED 68 92 65 3B 49 B6 72 65 3B 9B 64 6B 5D 4C'\r\n 'B2 B5 AE 26 59 43 37 93 AC A1 BB 49 BE 7A 48 86 B9 E5 F3 54 22 59 D5 C9 5E 92 2D 9D EC AD 1B BC'\r\n '04 D0 9A 3D E3 09 C5 AC 36 CE EA 6B 56 8A B3 FA 99 D5 D6 59 FD CD 6A E7 AC 01 66 A5 BA 3A 07 5E'\r\n 'CB 5D A8 D8 5E 5A 60 25 F1 2C 13 58 EC F4 E0 C0 E2 E8 0C B9 F6 DF 05 6E 68 60 F1 CF 61 EC 72 6C'\r\n '39 57 E1 70 93 AC 6D 84 49 56 35 D2 24 EB 19 65 92 95 8C 36 C9 1A C6 48 96 77 35 8C 35 C9 1A D2'\r\n '4D B2 86 71 26 59 C3 78 93 AC 21 C3 24 6B C8 94 AC E0 6A 98 60 92 35 4C 34 C9 1A B2 4C B2 86 49'\r\n '26 59 C3 64 93 AC 61 8A A4 BF B9 A6 9A A4 77 9A A4 BF 8D A6 9B A4 77 86 A4 BF 8D 66 9A E4 2C 9E'\r\n '65 92 AD CD 36 C9 CB E6 98 E4 65 73 25 FD 4D 30 CF 24 0B CC 37 C9 02 0B 24 9B BA 7A 17 9A E4 6B'\r\n '91 64 33 F7 DE 16 9B E4 7B 5B 62 92 05 96 9A E4 6B 99 49 D6 BB DC 24 EB 5D 21 E9 27 D5 4A C9 56'\r\n 'AE B2 55 26 59 D9 43 26 59 D9 C3 26 79 E5 23 26 79 E5 6A 93 7C AD B9 96 BB BB 71 F2 AF 0D 2C CE'\r\n 'FF 75 81 C5 5B 60 7D 60 B1 E2 0D 81 C5 5B 68 23 2B 8C F1 FB D5 A3 26 79 FD 26 93 BC 78 B3 49 5E'\r\n 'F9 98 49 5E B6 45 D2 6F 52 8F 9B E4 65 4F 98 E4 65 4F 9A E4 65 4F 99 E4 65 4F 4B FA 89 F0 8C A4'\r\n 'DF 78 B6 9A A4 77 9B A4 DF 78 B6 9B A4 77 87 A4 DF 78 76 9A A4 77 97 A4 DF 6D 76 9B 64 F1 3D 26'\r\n '59 66 AF 49 96 DD 27 E9 77 9B FD 26 59 E0 80 49 16 38 28 E9 37 9E 43 26 59 F6 59 93 2C 7B D8 24'\r\n 'CB 3E 27 E9 37 9E 23 92 7E B7 39 2A E9 77 9B E7 4D D2 FB 82 A4 DF 6D 5E 34 49 EF 31 49 BF DB 1C'\r\n '37 C9 CA 5E 32 C9 D6 5E 36 C9 B2 AF 48 FA 7D E5 55 93 F4 BE 26 E9 B7 8D D7 4D B2 C0 09 93 AC E1'\r\n 'A4 49 CE E8 53 26 79 D9 1B 92 7E 83 38 6D 92 97 9D 31 C9 CB CE 9A 64 D9 73 26 99 B7 37 25 FD AE'\r\n 'F0 96 49 5E F6 B6 49 5E 76 DE 24 5F 17 24 FD FA 7F D1 24 CB BE 63 92 65 B3 4D B2 6C 8E 49 36 F1'\r\n 'AE A4 5F F4 2F 99 64 81 F7 4C F2 8E 79 5F D2 AF F4 97 4D B2 DE 2B 26 59 EF 07 26 79 D9 87 26 79'\r\n 'E5 47 9C EE 79 72 27 FF C7 81 C5 D8 27 2C 96 C7 CF ED 4F 4D D2 FB 99 A4 9F BA 9F 9B A4 F7 0B 49'\r\n '3F 75 BF 34 49 EF 57 92 7E 8A 7D 6D 92 DE 6F 24 AB 39 EF 55 93 F4 7E 2B E9 33 F2 9D 49 16 F8 5E'\r\n 'D2 0F F8 0F 92 7E 60 7E 34 C9 CB 7E 92 F4 6F EB 67 93 F4 FE A2 37 D2 20 CE 36 9E 5F CD F2 1B CF'\r\n '6F 66 F9 8D E7 77 3B 1B 71 F5 F8 C3 24 AB F8 D3 0E 44 F4 FE 65 92 DE BF ED 40 A4 A3 B4 49 7A FF'\r\n 'B5 53 9B 0E D1 26 E9 BD 2E 59 CD 79 6F 98 A4 F7 7F 76 5C A4 17 D7 BD A4 37 EA BA 3F 5A D2 1B 6D'\r\n '92 DE 98 EB FE E4 A8 43 B4 49 9D A0 AF FB D3 20 BD 71 26 E9 CD 7B DD 9F FB E8 CD 67 92 DE FC D7'\r\n '7D C3 AC AF 80 49 36 58 D0 24 EB 2B 64 92 83 57 D8 24 57 DC 22 D7 FD BB A0 2C 6A 4D 50 C6 5B BD'\r\n '94 21 CA 58 3F 66 C5 4C B2 B5 9B 24 FD 98 DD 6C 52 27 68 49 3F 66 B7 9A A4 F7 36 49 3F 66 B7 9B'\r\n 'A4 F7 0E 49 3F 66 77 9A A4 F7 2E 49 3F 66 77 9B A4 B7 B8 A4 1F B3 04 93 F4 26 4A FA 31 2B 61 92'\r\n 'DE 92 92 7E CC 4A 99 A4 F7 1E 49 3F 66 A5 4D D2 5B C6 1A 66 7D 65 4D EA 04 6D 92 F5 95 33 A9 13'\r\n 'B4 49 0E 49 79 7B 17 94 15 AC 09 CA 8A 56 2F 65 25 CA 18 5F 6F 65 93 3A 41 9B D4 09 DA A4 4E D0'\r\n 'D7 FD CA CC 89 9C 64 5E CA E4 EB 7E 5D 65 81 6A D7 FD CD C4 CA AA 9B 64 65 35 4C B2 B2 9A D7 FD'\r\n '7D C5 02 B5 4C B2 40 6D 93 2C 50 47 D2 57 56 57 D2 2F D2 F5 D4 5F 6E EB 0F F2 04 AD 74 7B D9 EE'\r\n '3A B7 44 BF 9B B1 4C 2A AD 58 BF A1 E9 04 6A 31 6F 75 08 2C 96 EC 68 96 DF 8F 3A 99 E5 D7 C9 CE'\r\n '81 A5 03 69 60 E9 4C AA 16 2A 46 62 DD 14 CB B5 BA 2B E6 AB D7 E1 34 B0 98 C5 9E 2A 99 1C E9 4B'\r\n '2F B3 FC 26 DA 5B 25 BD C5 92 7D CC F2 75 F6 B5 92 DE EA 17 58 2C DC 3F 28 C9 D7 80 20 C6 D7 40'\r\n 'C5 FC AE C9 57 9A 62 B9 D6 20 8B F9 92 83 65 55 8B 8C CB 10 95 CC B5 86 5A CC 4F E0 61 66 F9 91'\r\n '18 6E 25 BD 35 22 88 E9 B8 1A C4 F8 1A A5 98 DF 95 75 68 35 CB 8F FC 18 95 CC B5 C6 2A 56 33 F2'\r\n '6E D3 15 CB B5 C6 05 16 5F E3 83 92 EC 59 86 AC DA 91 59 90 69 96 2F 39 41 D7 E5 5A 13 83 18 FB'\r\n '92 25 AB 4E 24 36 29 B0 58 E7 E4 C0 62 C9 29 B2 1A 46 FA 39 55 75 E6 5A D3 14 6B 14 E9 E7 F4 C0'\r\n 'E2 6B 86 AC 26 91 F1 9C 19 58 6C 61 56 60 B1 85 D9 AA D3 EF EF 7C CD B1 98 B7 E6 9A E5 DB 9B 67'\r\n '25 BD 35 DF 62 BE F5 05 16 F3 D6 42 59 4D 23 B3 6E 51 60 F1 CF C5 BA AE 69 A4 2F 4B 2C E6 67 E4'\r\n 'D2 C0 E2 9F CB CC F2 C7 B8 E5 81 C5 3F 57 05 25 E9 78 48 56 F3 C8 FC 7C 38 B0 F8 7A 44 56 B3 48'\r\n 'EB AB D5 7A B3 C8 7B 5F 63 96 6F 6F AD 95 F4 D6 BA 20 C6 92 EB CD F2 39 DA 10 58 8C 6D BC EE 9F'\r\n 'A9 7C 7B 8F 5E F7 87 65 6F 6D 52 CC 1F 8B E9 DB 6C EB 84 9F D7 8F 05 16 6B D9 62 96 2F F9 78 60'\r\n '31 F6 84 59 BE F5 27 03 8B B1 A7 82 95 81 B1 A7 CD F2 EF EF 99 20 46 6B AB DD B7 BE CE 6D C1 9D'\r\n 'CA EB B6 07 77 23 AD 1D C1 9D 43 6B 67 30 27 68 ED 0A F2 4E 6B B7 BD 77 5F 72 8F 59 BE E4 DE 60'\r\n '5C F8 E7 3E CB BB B7 F6 07 B3 95 D6 81 20 2B B4 0E 6A 04 73 E7 F5 21 9B 59 3E 7F CF 06 F7 11 4B'\r\n '1E 96 D5 38 62 3D 17 E4 4F E7 6C 6B CF 8F E7 D1 60 96 D3 F7 7C 70 9D 0E DC C1 FB A3 F5 62 90 77'\r\n 'D6 72 2C 18 4F D6 72 DC D6 56 FF FE 5E B2 16 BC F5 B2 DD A9 BE 2F AF 58 DE FD 75 AF AA F5 DC F6'\r\n '5E B3 95 C1 B7 F7 BA AD 91 3E 76 22 C8 11 AF 3B 19 F4 85 D6 4F B4 74 F0 60 57 2F F0 64 27 AB 51'\r\n 'C4 FA E5 3A F2 68 6B 6A E2 5E 9C FC BF 9A 83 AD FA 07 FC DF E4 C8 BD 0B AB F0 94 27 87 AF CE 0F'\r\n 'E8 1F 72 B0 64 B2 FB 90 96 EE 3F E5 A8 ED A4 3F 42 FE 25 47 0B 57 C2 CF 80 BF 83 2E E9 00 78 1D'\r\n 'C5 02 AB 04 F0 DF 0E D1 FC 6F 55 34 FF 5B D1 BF D7 91 4F 67 BC 26 2E E2 C5 BD 91 4B AF 59 C7 CE'\r\n '46 7C F1 37 10 55 A0 22 10 12 A3 C2 28 26 46 87 71 93 58 07 B8 59 AC 0B DC 22 96 04 6E 15 1F 00'\r\n '6E 13 6F 0D E3 76 F1 B6 30 EE B8 81 98 02 B9 FF 14 7F F8 06 A2 CD AA AA 02 37 97 40 92 78 53 09'\r\n '24 8B 7D 80 6A C6 EA A2 FE AD 59 51 FF E8 81 38 19 A8 25 4E E5 3B 75 D7 87 51 47 BC 25 8C BA 62'\r\n '7C 18 F5 C4 50 18 F7 8B 05 C2 A8 2F 16 0C E3 01 31 5F 18 0D C4 FC 61 34 14 0B 85 D1 48 2C 1C 46'\r\n '63 B1 48 18 4D C4 A2 61 34 17 7B 70 08 C5 5E 40 CB 1B B9 FF 01 40 AB 40 3E 18 C8 D6 81 6C C3 6B'\r\n 'E2 F9 1E 52 8C 6D 8D ED C8 C2 1C D4 54 91 83 DA 5E E4 58 74 14 39 98 9D 44 0E 6E 67 51 FF 91 80'\r\n 'C8 C1 ED 2A 72 AC BA 89 1C 93 EE 22 C7 A4 87 C8 31 E9 29 72 4C 7A B9 72 61 F4 16 39 26 7D C4 7B'\r\n '80 BE 62 59 A0 9F 58 1E E8 2F 56 00 06 88 95 80 81 62 3D 20 4D AC 0F 0C 12 EF 07 86 88 3D 81 A1'\r\n '62 69 60 98 58 06 18 2E 36 00 C6 F0 2D EB E3 33 9E D6 C6 52 EA F1 86 32 DD BC AD B9 97 9B 6C C3'\r\n 'AD DB 24 9F 8D 26 58 59 CA 89 E6 E5 33 52 96 79 29 27 99 97 CF 4A 93 CD 4B 39 C5 BC 7C 7C 9A 6A'\r\n '5E CA 69 E6 6D CF FD D9 BC 94 33 D8 C3 B8 92 DC 96 6F F8 F3 64 07 EE C9 37 FC 29 93 72 B6 79 F9'\r\n 'C0 39 C7 BC 94 73 E5 6D E1 E4 3C 79 BD 9C 6F 65 3B 71 07 B6 B2 94 0B 6F F8 8F 2A 59 60 D1 0D FF'\r\n 'E9 0F E5 E2 1B FE 09 97 72 C9 0D FF 54 48 B9 54 7D E1 65 CB 48 5D BE 5C 36 57 8C 15 B2 C9 95 A4'\r\n '3E C1 59 45 EA 69 F7 21 C5 EF E3 26 AB 38 F9 88 6C 6E 46 AB 65 93 6B 54 9E 5C AB F2 E4 3A C5 F9'\r\n 'E4 BB 5E 71 72 83 E2 E4 46 C5 C9 47 15 E7 FD BE 49 71 72 B3 E2 E4 63 8A 93 5B 14 E7 9A F5 B8 E2'\r\n 'FA C0 48 71 F2 49 C5 C9 A7 14 E7 6A F9 B4 E2 E4 33 8A 93 5B 15 27 B7 29 CE D5 6E BB E2 E4 0E D9'\r\n '61 6E 6A B2 C9 5D B2 B9 B6 EC 96 4D EE 91 9D C4 CD 4B 36 B9 4F 36 97 A9 FD B2 C9 03 AA 9F 3C A8'\r\n 'FA C9 43 8A 73 E3 7C 56 71 F2 B0 E2 E4 73 8A 93 47 14 E7 9A 78 54 71 F2 79 C5 C9 17 14 27 5F 54'\r\n '9C 5B ED 31 C5 C9 E3 8A 93 2F 29 4E BE AC 38 0F 9C AF 28 4E BE AA 38 F9 9A E2 E4 EB 8A F3 49 E5'\r\n '84 E2 E4 49 C5 C9 53 8A 93 6F 28 CE 85 F7 B4 E2 E4 19 C5 C9 B3 8A 93 E7 14 E7 71 F3 4D C5 C9 B7'\r\n '14 27 DF 56 9C 3C AF 38 B7 B5 0B 8A 93 17 15 27 DF 51 9C CC 56 9C DB 50 8E E2 E4 BB 8A 93 97 14'\r\n '27 DF 53 9C 9B D0 FB 8A 93 97 15 27 AF 28 4E 7E A0 38 97 F4 0F 15 27 3F 52 9C FC 58 71 F2 13 C5'\r\n 'F5 69 8B E2 E4 67 8A EB 73 16 C5 C9 2F 14 E7 16 F9 A5 E2 E4 57 8A 93 5F 2B 4E 7E A3 38 F7 90 AB'\r\n '8A EB 23 15 C5 C9 EF 14 27 BF 57 9C 37 D3 0F 8A EB 9B 4A D9 DC BD 7E 92 4D FE 2C 9B B7 CA 2F B2'\r\n 'C9 5F 75 3D F9 9B AE 27 7F E7 16 12 E7 37 2B DE BB 7F DC F0 47 09 6F FD 19 C4 78 A7 FD 15 C4 68'\r\n 'FD 1D C4 78 C7 FE 13 C4 68 FD 7B C3 7F B9 42 EB DA 0D FF 11 33 65 D4 FF 10 55 90 EB 6D B4 58 0A'\r\n '88 11 B9 7E E6 11 B9 FE C5 8A 5C FF E2 44 AE A7 79 C5 7B 81 7C A2 FE 59 1F 51 FF 94 94 C8 75 B6'\r\n 'A0 C8 75 B6 90 C8 75 BF B0 C8 F5 B6 88 C8 75 BF A8 58 05 88 17 C3 DC 6C C5 AA 40 31 31 09 B8 49'\r\n '4C E6 66 2B 56 E3 66 2B 56 E7 66 2B D6 E0 66 2B D6 04 6E 17 6B 01 77 88 B5 81 3B 45 EE 23 77 89'\r\n 'DC 57 EE 16 B9 BE 17 17 B9 AE 27 88 5C E7 13 45 EE 33 25 44 AE E7 25 C5 86 40 29 B1 11 70 8F D8'\r\n '18 28 2D 36 01 CA 88 4D 81 B2 62 33 1E 3E C4 E6 40 39 B1 05 70 9F D8 12 28 2F B6 02 2A 88 0F F2'\r\n 'B0 21 EA FF 45 17 DB 70 FB 17 53 80 2A 62 5B 1E 0B C4 76 3C 13 88 A9 40 92 D8 1E 48 16 3B F0 4C'\r\n '20 76 E4 99 40 EC C4 33 81 D8 99 67 02 B1 0B CF 04 62 57 9E 09 C4 6E 40 1D B1 3B 50 57 E4 1E 5E'\r\n '4F E4 3E 76 BF C8 BD BC BE D8 1B 78 40 E4 BE DC 40 EC 0B 34 14 FB 01 8D C4 FE 40 63 71 00 D0 44'\r\n '1C 08 34 15 D3 80 66 E2 20 A0 B9 38 98 67 04 71 08 CF 08 E2 50 A0 95 38 8C FB A2 38 9C 3B A1 38'\r\n '82 DB A0 38 92 7B A0 38 8A BB 9E 38 9A FB 9C 38 86 3B 9B 38 96 7B 99 98 0E 74 10 C7 F1 7C 20 8E'\r\n 'E7 F9 40 CC E0 F9 40 CC E4 F9 40 9C C0 F3 81 38 11 E8 26 66 F1 7C 20 4E E2 F9 40 D4 F9 40 9C C2'\r\n 'F3 81 C8 73 42 6F 71 1A D0 47 9C 7B 1F FA 8A F3 EE 43 3F B2 10 0F 79 FD 45 9E 8D 06 88 3C 1B 0D'\r\n '14 79 5E 49 13 FF 0D 63 90 F8 4B 18 83 C5 2D 61 0C 11 9F 08 63 A8 F8 54 18 C3 C4 67 C2 18 2E 6E'\r\n '0B 63 84 F8 59 18 23 C5 2F C2 18 25 7E 15 C6 68 F1 D5 30 C6 88 D7 C2 18 2B 3E 1E 46 BA F8 64 18'\r\n 'E3 C4 A7 C3 18 2F 6E 0D 23 43 DC 1E 46 A6 B8 23 8C 09 E2 AE 30 26 8A 7B C2 C8 12 F7 85 31 49 3C'\r\n '10 C6 64 F1 50 18 53 C4 C3 61 4C 15 8F 84 31 4D 7C 3E 8C E9 E2 8B 61 CC 10 8F 87 31 53 7C 39 8C'\r\n '59 E2 6B 61 CC 16 4F 84 31 47 3C 15 C6 5C F1 74 18 F3 C4 33 61 CC 17 CF 86 B1 40 3C 17 C6 42 F1'\r\n 'CD 30 16 89 6F 85 B1 58 BC 10 C6 12 31 3B 8C A5 E2 A5 30 96 89 97 C3 58 2E 7E 18 C6 0A F1 A3 30'\r\n '56 8A 1F 87 B1 4A FC 24 8C 87 C4 4F C3 78 58 FC 3C 8C 47 C4 2F C3 58 2D 7E 1D C6 1A F1 9B 30 D6'\r\n '8A 57 C3 58 27 7E 1B C6 7A F1 BB 30 36 88 DF 87 B1 51 FC 31 8C 47 C5 5F C3 D8 24 EA 5F 12 15 D7'\r\n '87 F1 98 D8 37 84 2D 22 42 78 DC E5 3B 84 27 DC 78 87 F0 A4 9B 17 21 3C 25 EE 0C E1 69 37 EE 21'\r\n '3C 23 C6 84 B0 55 CC 13 C2 36 31 36 84 ED E2 DE 10 76 B8 7C 84 B0 53 DC 1F C2 2E 97 97 10 76 8B'\r\n '07 43 D8 E3 F2 13 C2 5E F1 CE 10 F6 89 71 21 EC 17 F3 86 70 40 CC 17 C2 41 B1 64 08 87 C4 FC 21'\r\n '3C 2B 16 08 E1 B0 58 30 84 E7 DC 7C 0D E1 88 9B AF 21 1C 15 8B 84 F0 BC 58 34 84 17 C4 F8 10 5E'\r\n '14 43 21 1C 13 8B 85 F0 8A D8 2F 84 57 C5 FE 21 BC 26 0E 08 E1 75 71 60 08 27 C4 B4 10 4E 8A 83'\r\n '42 38 2D 0E 0E E1 8C 38 24 84 B3 E2 D0 10 CE 89 C3 42 78 53 1C 1E C2 5B E2 88 10 2E 88 23 43 B8'\r\n '28 8E 0A E1 1D 71 74 08 D9 E2 98 10 72 C4 B1 21 BC 2B A6 87 F0 BE 38 2E 84 CB E2 F8 10 AE 88 19'\r\n '21 7C AC FB F3 71 E0 13 F1 09 E0 53 71 27 F0 D9 FF 10 AD 7F 70 37 4F 0C 3E 97 EB 69 E0 0B F1 29'\r\n 'E0 4B 71 5B 09 7C ED 52 57 06 DF 88 2B 4A E2 AA B8 B2 24 BE 15 57 95 C4 77 E2 43 25 F1 BD F8 58'\r\n '19 FC E0 A6 76 19 AC 8F 8F 8A C6 BA F8 A8 A3 F1 51 1B 25 37 38 B9 43 F2 29 27 7B 9F A7 EC 72 3E'\r\n '2A ED 7C 54 1F C9 AE 4E F6 3D 1F 15 63 72 D4 F9 A8 7E 81 35 FA 7C 54 FF C0 1A 73 3E 6A 40 60 8D'\r\n '3D 1F 35 30 B0 D2 CF 47 3D AF 0A 8F 38 EB 05 C9 A3 4E BE A8 32 47 22 75 1F 93 75 34 62 1D 0F 62'\r\n '6C E9 A5 20 46 0B EF 44 45 45 71 57 8B 12 B9 AB 45 8B FA EF C0 44 EE 6A 79 44 EE 6A B1 22 77 B5'\r\n '38 91 BB 5A 5E 91 BB 5A 3E 51 FF CF BA C8 5D AD 80 C8 5D AD A0 C8 5D AD 90 C8 5D AD B0 C8 5D AD'\r\n '88 C8 5D AD A8 C8 5D 2D 5E E4 AE 16 12 B9 AB 15 13 B9 AB DD 24 72 57 BB 59 E4 AE 76 8B C8 5D ED'\r\n '56 91 BB DA 6D 22 77 B5 DB 45 EE 6A 77 88 DC D5 EE 14 B9 4B DD 25 72 97 BA 5B E4 2E 55 5C E4 2E'\r\n '95 20 72 97 4A 14 B9 4B 95 10 B9 4B 95 14 B9 4B 95 12 F5 DF C2 8B DC A5 4A 8B DC A5 CA 88 DC A5'\r\n 'CA 8A DC A5 EE 15 B9 4B 95 13 F5 DF 67 88 DC A5 CA 8B DC A5 2A 88 DC A5 2A 8A DC A5 2A 89 DC A5'\r\n '2A 8B DC A5 AA 88 DC A5 C2 22 77 A9 AA 22 77 A9 24 91 BB 54 B2 C8 5D AA 9A E5 A7 BA E5 A7 86 E5'\r\n 'A7 A6 E5 A7 96 E5 A7 B6 E5 A7 8E E5 A7 AE E5 A7 9E E5 E7 7E CB 4F 7D CB CF 03 96 9F 06 96 9F 86'\r\n '96 9F 46 96 9F C6 96 9F 26 96 9F A6 96 9F 66 96 9F E6 96 9F 16 96 9F 96 96 9F 56 96 9F 07 2D 3F'\r\n 'AD 2D 3F 6D 2C 3F 29 96 9F B6 96 9F 76 96 9F 54 CB 4F 7B CB 4F 07 CB 4F 47 CB 4F 67 CB 4B 17 CB'\r\n '4B 57 CB 4B 37 CB 4B 77 CB 4B 0F CB 4B 4F CB 4B 2F CB 4B 6F CB 4B 1F CB 4B 5F CB 4B 3F CB 4B 7F'\r\n 'CB CB 00 CB CB 40 CB 4B 9A E5 65 90 E5 65 B0 E5 65 88 E5 65 A8 E5 65 98 E5 65 B8 E5 65 84 E5 65'\r\n 'A4 E5 65 94 E5 65 B4 E5 65 8C E5 65 AC E5 25 DD F2 32 CE F2 32 DE F2 92 61 79 C9 B4 BC 4C B0 BC'\r\n '4C B4 BC 64 59 5E 26 59 5E 26 5B 5E A6 58 5E A6 5A 5E A6 59 5E A6 5B 5E 66 58 5E 66 5A 5E 66 59'\r\n '5E 66 5B 5E E6 58 5E E6 5A 5E E6 59 5E E6 5B 5E 16 58 5E 16 DA 7D B3 C8 F2 B3 D8 F2 B3 C4 F2 B3'\r\n 'D4 F2 B3 CC F2 B3 DC F2 B3 C2 F2 B3 D2 F2 B3 CA F2 F3 90 E5 E7 61 CB CF 23 96 9F D5 96 9F 35 96'\r\n '9F B5 96 9F 75 96 9F F5 96 9F 0D 96 9F 8D 96 9F 4D 96 97 CD 96 97 C7 2D 0F 4F D9 B8 3F 6D E3 BE'\r\n 'CD C6 79 BB 8D F3 0E 1B E7 9D 36 CE BB 6D 7C F7 D8 F8 EE B5 F1 DD 67 E3 BB DF C6 F7 80 8D EF 41'\r\n '1B DF 43 36 BE CF DA F8 1E B6 F1 7D CE C6 F7 88 8D EF F3 36 AE 2F DA 78 1E B3 F1 3C 6E E3 F9 92'\r\n '8D E7 CB 36 9E AF D8 78 BE 6A E3 F9 BA 8D E3 09 1B C7 93 36 8E A7 6C 1C DF B0 71 3C 6D E3 78 C6'\r\n 'C6 F1 AC 8D E3 39 1B C7 37 6D 1C DF B2 71 7C DB C6 F1 BC CD F3 0B 36 9E 17 6D 3C DF B1 79 9E 6D'\r\n 'F3 3C C7 C6 F7 5D 9B E7 97 6C 9E BF 67 E3 FD BE 8D F7 65 9B E7 57 6C 9E 7F 60 E3 FF A1 8D FF 47'\r\n '36 FE 1F DB F8 7F 62 F3 FC 53 CB C3 67 96 87 CF 2D 0F 5F 58 1E BE B4 3C 7C 65 79 F8 DA F2 F0 8D'\r\n 'E5 E1 AA E5 E1 5B CB C3 77 96 87 EF 2D 0F 3F D8 3C FF D1 F2 F1 93 CD F3 9F 2D 2F BF 58 5E 7E B5'\r\n 'BC FC 66 79 F9 DD F2 F2 87 E5 E5 4F CB CB 5F 36 CF FF B6 FC FC 63 F9 F9 D7 F2 73 CD F2 73 DD F2'\r\n '73 C3 F2 F3 3F CB 0F B2 7D 7E A2 B2 7D 7E A2 B3 7D 7E 62 B2 7D 7E F2 64 FB FC C4 66 FB FC E4 CD'\r\n 'F6 79 C9 97 ED F3 92 3F DB E7 A5 40 B6 CF 4B E1 6C 9F 87 22 D9 3E 0F 45 B3 7D 1E E2 B3 7D 1E 42'\r\n 'D9 3E 0F C5 B2 7D 1E 6E CA F6 79 B8 39 DB E7 E1 D6 6C 3F FE B7 65 FB F1 BF 3D DB 8F FF 1D D9 7E'\r\n 'FC EF CC F6 E3 7F 57 B6 1F FF BB B3 FD F8 27 64 FB 71 4F CC F6 E3 5E 22 DB 8F 7B C9 6C 3F EE A5'\r\n 'B2 FD B8 DF 93 ED C7 BD 74 B6 1F F7 32 D9 7E DC CB 66 FB 71 BF 37 DB 8F 7B B9 6C 3F EE F7 65 FB'\r\n '71 2F 9F ED C7 BD 42 B6 1F F7 8A D9 7E DC 2B 65 FB 71 AF 9C ED C7 BD 4A B6 1F F7 70 B6 1F F7 AA'\r\n 'D9 7E DC 93 B2 FD B8 27 67 FB 71 AF 66 E3 5E DD C6 BD 86 8D 7B 4D 1B F7 5A 36 EE B5 6D DC EB DA'\r\n 'B8 D7 B3 71 BF DF C6 BD BE 8D 7B 83 6C 7F 1F 34 B4 F1 6F 64 E3 DF D8 C6 BF 89 8D 7F 33 1B F7 56'\r\n '36 CE 0F DA 38 B7 B6 71 6E 63 E3 9C 62 E3 DC D6 C6 B9 9D 8D 73 7B 1B E7 0E 36 CE 1D 6D 9C 3B D9'\r\n '38 77 B6 71 EE 62 E3 DC D5 C6 B9 9B 8D 73 77 1B E7 1E 36 CE 3D 6D 9C 7B D9 38 F7 B6 71 EE 63 E3'\r\n 'DC D7 C6 B9 9F 8D 73 7F 1B E7 01 36 CE 03 6D 9C D3 6C 9C 07 D9 38 0F B6 71 1E 62 E3 3C D4 C6 79'\r\n '98 8D F3 70 1B E7 11 36 CE 23 6D 9C 47 65 FB F5 67 B4 8D F7 18 1B EF B1 36 DE E9 36 DE E3 B2 FD'\r\n 'FA 33 DE C6 3D C3 C6 3D D3 C6 7D 82 8D FB 44 1B F7 2C 9B F7 93 6C FC 27 DB BC 9F 62 F3 7E 6A B6'\r\n '5F 7F A6 59 5E A6 5B 5E 66 58 5E 66 5A 5E 66 59 5E 66 5B 5E E6 58 5E E6 66 FB F5 67 9E E5 67 BE'\r\n 'E5 67 81 E5 67 A1 E5 67 91 E5 67 B1 E5 67 89 E5 67 A9 E5 67 99 E5 67 B9 E5 67 85 E5 67 A5 E5 67'\r\n '95 E5 E7 21 CB CF C3 96 9F 47 2C 3F AB 2D 3F 6B 2C 3F 6B 2D 3F EB 2C 3F EB 2D 3F 1B 2C 3F 1B 2D'\r\n '3F 8F 5A 7E 36 59 7E 36 5B 7E 1E B3 FC 6C B1 FC 3C 6E F9 79 C2 F2 F3 A4 E5 E7 29 CB CF D3 96 9F'\r\n '67 2C 3F 5B 2D 3F DB 2C 3F DB 2D 3F 3B 2C 3F 3B 2D 3F BB 2C 3F BB 2D 3F 7B 2C 3F 7B 2D 3F FB 2C'\r\n '3F FB 2D 3F 07 2C 3F 07 2D 3F 87 2C 3F CF 5A 7E 0E 5B 7E 9E B3 FC 1C B1 FC 1C B5 FC 3C 6F F9 79'\r\n 'C1 F2 F3 A2 E5 E7 98 E5 E7 B8 E5 E7 25 CB CF CB 96 9F 57 2C 3F AF 5A 7E 5E B3 FC BC 6E F9 39 61'\r\n 'F9 39 69 F9 39 65 F9 79 C3 F2 73 DA F2 73 C6 F2 73 D6 F2 73 CE F2 F3 A6 E5 E7 2D CB CF DB 96 9F'\r\n 'F3 96 9F 0B 96 9F 8B 96 9F 77 2C 3F D9 96 9F 1C CB CF BB 96 9F 4B 96 9F F7 2C 3F EF 5B 7E 2E 5B'\r\n '7E AE 58 7E 3E B0 FC 7C 68 F9 F9 C8 F2 F3 B1 E5 E7 13 CB CF A7 96 9F CF 2C 3F 9F 5B 7E BE B0 FC'\r\n '7C 69 F9 F9 CA F2 F3 B5 E5 E7 1B CB CF 55 CB CF B7 96 9F EF 2C 3F DF 5B 7E 7E B0 FC FC 68 F9 F9'\r\n 'C9 F2 F3 B3 E5 E7 17 CB CF AF 96 9F DF 2C 3F BF 5B 7E FE B0 FC FC 69 F9 F9 CB F2 F3 B7 E5 E7 1F'\r\n 'CB CF BF 96 9F 6B 96 9F EB 96 9F 1B 96 9F FF 59 7E 90 E3 F3 13 95 E3 F3 13 9D E3 F3 13 93 E3 F3'\r\n '93 27 C7 E7 27 36 C7 E7 27 2E C7 E7 27 6F 8E CF 4F BE 1C 9F 9F FC 39 3E 3F 05 72 7C 7E 0A E6 F8'\r\n 'FC 14 CA F1 F9 29 9C E3 F3 53 24 C7 E7 A7 68 8E CF 4F 7C 8E CF 4F 28 C7 E7 A7 58 8E CF CF 4D 39'\r\n '3E 3F 37 E7 F8 FC DC 92 E3 F3 73 6B 8E CF CF 6D 39 3E 3F B7 E7 F8 FC DC 91 E3 F3 73 67 8E CF CF'\r\n '5D 39 3E 3F 77 E7 F8 FC 14 CF F1 F9 49 C8 F1 F9 49 CC F1 F9 29 91 E3 F3 53 32 C7 E7 A7 54 8E CF'\r\n 'CF 3D 39 3E 3F A5 73 7C 7E CA E4 F8 FC 94 CD F1 F9 B9 37 C7 E7 A7 5C 8E CF CF 7D 39 3E 3F E5 73'\r\n '7C 7E 2A E4 F8 FC 54 CC F1 F9 A9 94 E3 F3 53 39 C7 E7 A7 4A 8E CF 4F 38 C7 E7 A7 6A 8E CF 4F 52'\r\n '8E CF 4F 72 8E CF 4F 35 CB 4F 75 CB 4F 0D CB 4F 4D CB 4F 2D CB 4F 6D CB 4F 1D CB 4F 5D CB 4F 3D'\r\n 'CB CF FD 96 9F FA 96 9F 07 2C 3F 0D 2C 3F 0D 2D 3F 8D 2C 3F 8D 2D 3F 4D 2C 3F 4D 2D 3F CD 2C 3F'\r\n 'CD 2D 3F FF D7 D2 7D 87 E7 74 FE 71 1C FF B8 8F AD 55 7B EF AD 46 43 82 D8 24 12 2B B2 A7 2C 49'\r\n '44 AC 10 9B D8 09 B1 47 62 EF 5D D4 A8 51 7B 96 9A D5 DD FE 4E 29 5A B4 B4 55 6A B5 45 D1 DF F9'\r\n '7C CF F7 BA 7A 5D AF 73 93 E7 3E E7 B9 DF F7 39 4F 9F 7F A4 9B F6 E9 AE 7D 7A 68 9F 9E DA 27 40'\r\n 'FB F4 D2 3E 81 DA 27 48 FB 04 6B 9F 10 ED 13 AA 7D C2 B4 4F B8 F6 89 D0 3E 91 DA 27 4A FB 44 6B'\r\n '9F 18 ED D3 5B FB C4 6A 9F 38 ED 13 AF 7D 12 B4 4F A2 F6 E9 A3 7D 92 B4 4F B2 F6 49 D1 3E 7D B5'\r\n '4F AA F6 E9 A7 7D D2 B4 4F 7F ED 33 40 FB 0C D4 3E 83 B4 CF 60 ED 93 AE 7D 86 68 9F A1 DA 27 43'\r\n 'FB 0C D3 3E C3 B5 CF 08 ED 33 52 FB 8C D2 3E A3 B5 CF 18 ED 33 56 FB 8C D3 3E 99 DA 67 BC F6 99'\r\n 'A0 7D 26 6A 9F 49 DA 67 B2 F6 99 A2 7D A6 6A 9F 2C ED 93 AD 7D A6 69 9F E9 DA 27 47 FB CC D0 3E'\r\n '33 B5 CF 2C ED 33 5B FB CC D1 3E 73 B5 CF 3C ED 33 5F FB 2C D0 3E 0B B5 4F AE F6 C9 D3 3E 8B B4'\r\n 'CF 62 ED B3 44 FB 2C D5 3E CB B4 CF 72 ED B3 42 FB AC D4 3E AB B4 CF 6A ED B3 46 FB AC D5 3E EB'\r\n 'B4 CF 7A ED B3 41 FB 6C D4 3E 9B B4 CF 66 DA 2C 1F B6 D0 56 06 DB 68 AE 85 ED 34 CF C2 07 74 91'\r\n '85 1D 74 B1 85 9D 74 89 85 5D 74 A9 85 DD 74 99 85 0F E9 72 0B 7B E8 0A 0B 7B E9 4A 0B FB E8 2A'\r\n '0B FB E9 6A 0B 1F D1 35 16 0E D0 B5 16 0E D2 75 16 0E D1 F5 16 0E D3 0D 16 8E E8 7C 47 E9 26 0B'\r\n 'C7 E8 66 0B C7 E9 16 0B 27 E8 FB 16 4E D2 AD 16 4E D1 6D 16 4E 53 FE 43 92 B4 50 2D 9C A1 7B 2D'\r\n '9C A5 FB 2C 7C 42 F7 5B 38 47 3F B2 70 9E 1E B0 70 81 1E B4 70 91 1E B2 70 89 1E B6 70 99 1E B1'\r\n 'F0 29 3D 6A E1 0A 3D 66 E1 33 7A DC C2 E7 F4 84 85 2F E8 49 0B 5F D2 53 16 BE A2 A7 2D 7C 4D 3F'\r\n 'B6 F0 0D 3D 63 E1 5B 7A D6 C2 77 F4 13 0B FF A3 E7 2C D8 F4 BC 85 EF E9 05 0B 57 E9 45 0B D7 E8'\r\n '25 0B 3F 50 53 0B D7 F5 7A 6F E8 F5 DD D4 EB FA 51 5F FF 93 9E EF 96 9E FF B6 F6 BC A3 3D 7F D6'\r\n '9E BF 68 CF BB DA F3 9E F6 FC 55 7B FE A6 EB FF BB F6 BC AF 3D FF D0 9E 0F B4 E7 43 ED F9 A7 F6'\r\n '7C A4 3D 1F 6B CF 27 DA F3 A9 CE F7 4C 7B FE A5 3D FF D6 9E FF 68 CF E7 DA F3 85 F6 7C A9 3D FF'\r\n 'D5 9E AF B4 E7 6B ED F9 46 7B FE A7 3D 61 BB EB 93 CF 76 7B 1A DB ED 69 D9 EE 7A E5 B7 DD 9E 05'\r\n '6C 77 DD 0A DA 6E CF 42 B6 DB B3 B0 ED F6 2C 62 BB 3D 8B DA 6E CF 62 B6 BB 9E 6F D9 EE FA BE 6D'\r\n 'BB 3D 8B DB 6E CF 77 6C B7 67 09 DB ED 59 D2 76 7B 94 B2 DD 9E A5 6D B7 67 19 DB ED 59 D6 76 7B'\r\n '96 D3 EB 2D AF D7 57 41 AF AB A2 BE BE 92 9E AF B2 9E BF 8A ED F6 AC 6A BB 3D AB D9 6E CF EA B6'\r\n 'DB B3 86 ED F6 AC 69 BB 3D 6B D9 6E CF DA B6 BB FE 75 6C B7 67 5D DB ED 59 CF 76 7B D6 B7 DD 9E'\r\n '0D 6C B7 67 43 DB ED F9 AE ED F6 6C 64 BB 3D 1B DB 6E CF 26 3A 5F 53 DB ED F9 9E ED F6 F4 B0 DD'\r\n '9E CD 6C B7 67 73 DB ED E9 69 BB 3D BD 6C B7 67 0B DB ED D9 D2 76 7B B6 B2 DD 9E DE B6 DB B3 B5'\r\n 'ED F6 6C A3 EB D3 56 7B B6 D3 9E ED 75 BD 3A 68 CF 8E BA 6E 9D B4 67 67 ED E9 A3 3D 7D B5 67 17'\r\n 'ED E9 A7 EB E9 AF EB DB 55 7B 76 D3 9E DD B5 67 0F ED D9 53 7B 04 68 CF 5E DA 33 50 7B 06 69 CF'\r\n '60 BD DE 10 BD BE 50 BD AE 30 7D 7D B8 9E 2F 42 CF 1F A9 3D A3 B4 67 B4 F6 8C D1 9E BD B5 67 AC'\r\n 'F6 8C D3 9E F1 BA FE 09 DA 33 51 7B F6 D1 9E 49 DA 33 59 7B A6 68 CF BE DA 33 55 7B F6 D3 9E 69'\r\n '3A 5F 7F ED 39 40 7B 0E D4 9E 83 B4 E7 60 ED 99 AE 3D 87 68 CF A1 DA 33 43 7B 0E D3 9E C3 B5 E7'\r\n '08 ED 39 52 D7 67 94 F6 1C AD 3D C7 E8 7A 8D D5 9E E3 74 DD 32 B5 E7 78 ED 39 41 7B 4E D4 9E 93'\r\n 'B4 E7 64 5D CF 29 BA BE 53 B5 67 96 F6 CC D6 9E D3 B4 E7 74 ED 91 A3 3D 67 68 CF 99 DA 73 96 F6'\r\n '9C AD D7 3B 47 AF 6F AE 5E D7 3C 7D FD 7C 3D DF 02 3D FF 42 ED 99 AB 3D F3 B4 E7 22 ED B9 58 7B'\r\n '2E D1 9E 4B B5 E7 32 5D FF E5 DA 73 85 F6 5C A9 3D 57 69 CF D5 DA 73 8D F6 5C AB 3D D7 69 CF F5'\r\n 'DA 73 83 CE B7 51 7B 6E D2 9E 9B B5 E7 16 ED F9 BE F6 DC AA 3D B7 69 CF ED DA F3 03 ED B9 43 7B'\r\n 'EE D4 9E BB B4 E7 6E 5D 9F 0F B5 E7 1E ED B9 57 D7 6B 9F F6 DC AF EB F6 91 F6 3C A0 3D 0F 6A CF'\r\n '43 DA F3 B0 F6 3C A2 EB 79 54 D7 F7 98 F6 3C AE 3D 4F 68 CF 93 DA F3 94 F6 38 AD 3D 3F D6 9E 67'\r\n 'B4 E7 59 ED F9 89 5E EF 39 BD BE F3 7A 5D 17 F4 F5 17 F5 7C 97 F4 FC 97 E9 75 E7 F3 9F DE 70 3E'\r\n 'EF A9 87 F3 FD 9E 36 73 BE DF D3 E6 CE F7 7B EA E9 7C BF A7 5E CE F7 7B DA C2 F9 7E 4F 5B 3A DF'\r\n 'EF 69 2B E7 EB 28 F5 76 3E A6 68 6B E7 FB BD CE 77 55 E7 BB A6 F3 FD A0 F3 5D D7 F9 6E E8 7C 37'\r\n '75 BE 1F 75 BE 9F 74 BE 5B 3A DF 6D 9D EF 8E CE F7 B3 CE F7 8B CE 77 57 E7 BB A7 F3 FD AA F3 FD'\r\n 'A6 F3 FD AE F3 DD D7 F9 FE D0 F9 1E E8 7C 0F 75 BE 3F 75 BE 47 3A DF 63 9D EF 89 CE F7 54 E7 7B'\r\n 'A6 F3 FD A5 F3 FD AD F3 FD A3 F3 3D D7 F9 5E E8 7C 2F 75 BE 7F 75 BE 57 3A DF 6B 9D EF 8D CE F7'\r\n '9F CE 87 C7 F9 E4 77 28 34 75 BE E2 EB 61 63 E7 5B 3E 0F 9B C9 A1 C5 C3 E6 72 98 9F 87 9E 72 58'\r\n '80 87 5E 72 58 90 87 2D E4 B0 10 0F 5B CA 61 61 1E B6 92 C3 22 3C F4 96 C3 A2 3C 6C 2D 87 25 1E'\r\n 'E7 73 7F 17 1F E4 97 22 EA C8 47 46 A5 74 E4 2B A3 D2 3A EA 22 A3 32 3A F2 93 51 59 1D F9 CB A8'\r\n '9C 8E BA CA A8 BC 8E BA C9 A8 82 8E BA CB A8 A2 8E 7A C8 A8 92 8E 7A CA A8 B2 8E 02 64 54 45 47'\r\n 'BD 64 54 55 47 81 32 AA A6 A3 20 19 55 D7 51 B0 8C 6A E8 28 44 46 35 75 14 2A A3 5A 3A 0A 93 51'\r\n '6D 1D 85 CB A8 8E 8E 22 64 54 57 47 91 32 AA A7 A3 28 19 D5 D7 51 B4 8C 1A E8 28 46 46 0D 75 D4'\r\n '5B 46 EF 72 54 C6 83 E7 2B EB 81 46 8F 9D 27 93 B3 B4 8D A9 73 41 4D 9C 28 1C 3B EB DB 94 87 51'\r\n 'F2 32 0F E7 6F F9 6F 9B 37 A3 4E 96 E6 D4 F9 29 4F EA FC A8 17 75 22 B4 A0 CE F2 B7 A4 CE C2 B7'\r\n 'A2 CE 92 7B 53 67 B1 5B 53 67 99 DB 50 67 81 DB 52 67 69 DB 51 67 51 DB 53 67 39 3B 50 67 21 3B'\r\n '52 67 09 3B 51 67 F1 3A 53 E7 2A 7D A8 F3 06 7C 29 7F B7 16 75 16 C9 8F 3A CB E3 4F 9D 4B EF 4A'\r\n '9D 25 E9 46 9D C5 E8 4E 9D F7 D3 C3 79 6B BC 2E E7 47 7B F2 D0 FD C7 F7 03 78 18 26 EF BD 97 1E'\r\n '3A FF 05 3A EB A5 FF 3E BC F3 33 41 FC 8B 28 D9 8D 0B 79 D8 45 B6 0D 9E 38 87 E3 3D F8 AB AC F3'\r\n 'F1 70 BF FC 8E 1C F3 C4 39 DB 01 0F 94 A0 3D 93 51 92 46 C5 A2 14 BD 12 86 D2 FC 51 F7 77 00 95'\r\n 'E1 1F CD 0D 44 59 5A 29 06 E5 E8 9D 59 28 4F 1B C6 A0 02 DD 1C 88 8A B4 46 3F 54 A2 35 87 A1 32'\r\n '5D 91 8A 2A B4 57 28 AA CA 3C 89 A8 46 E7 85 A0 3A DD 93 8A 1A B4 6A 28 6A 52 9F 89 A8 45 AB 8F'\r\n '42 6D BA 7D 2E EA D0 47 D1 A8 4B 5B 87 A3 1E 2D 33 14 F5 E9 92 64 34 A0 11 29 68 48 9D 0D FF 2E'\r\n '2D 12 88 46 B4 C7 42 34 A6 77 E3 D1 84 36 09 44 53 FA 34 0C EF D1 42 29 F0 A0 19 F3 D0 8C 86 25'\r\n 'A3 39 9D 3A 0E 9E 34 33 13 5E B4 70 38 5A D0 29 43 D0 52 E6 4F 43 2B F9 F3 34 78 53 CF 51 68 4D'\r\n '87 87 A2 0D 3D 18 81 4E 4F DC CD DC 38 8D 9B B9 B3 8E 9C 0B 73 46 3E 3A 9A 2B 23 5F 1D CD 8A E5'\r\n 'A8 8B 8E 8E 64 70 E4 A7 23 E7 C2 9C 91 BF 8E EC D1 1C 75 D5 D1 8D 50 8E BA E9 28 2A 95 A3 60 E7'\r\n '2A 0A 2D 4B 44 08 FD D3 D9 2B CF 4D 3E B4 0F 44 3E EA 1D 08 43 3B 07 C2 A2 B5 F2 99 FC B4 4F 10'\r\n '0A D0 DD 41 28 48 8F 05 A1 10 35 C1 28 4C 33 83 51 84 AE 08 46 51 7A 2F 18 C5 E8 17 C1 78 8B AE'\r\n 'F5 C2 DB B4 4D 41 53 9C F6 0A C1 3B 34 3C 04 25 68 DF 10 94 A4 63 42 50 8A 56 29 60 4A D3 23 5E'\r\n '28 43 D3 42 50 96 3A BB A3 1C ED 59 C0 94 A7 CB 42 50 81 6E 0E 41 45 7A 25 10 95 E8 CE 10 54 A6'\r\n '07 42 50 85 FE 98 6B AA D2 BF 42 50 8D 5A A1 A8 2E 7F EE 85 1A B4 AD B3 CB A8 7F 28 6A 51 A7 56'\r\n '6D B9 9E 50 D4 A1 65 5B A0 2E BD 10 8A 7A F4 52 28 EA D3 9F 43 D1 80 BE 0C 45 43 5A 20 0C EF D2'\r\n '82 61 68 44 CB 87 A1 31 ED 1E 86 26 34 24 0C 4D 69 6F 67 97 D1 11 61 F0 A0 13 C3 D0 8C 4E 0E 43'\r\n '73 D5 53 F5 A2 8D 8B 9A 16 34 23 03 2D E9 E5 30 B4 92 EB 0F 83 37 4D 29 66 5A D3 FB 61 68 43 1F'\r\n '87 A1 AD 5C 47 38 DA C9 FA 87 A3 BD F4 0D 47 07 DA 2D 1C 1D 69 FF 70 74 A2 1B C3 D1 99 FE 1D 0E'\r\n '1F 5A 22 02 BE 34 2C 02 5D 64 FE 08 F8 D1 69 11 F0 57 BB 4A EF 08 74 A3 3B 22 D0 9D EE 8F 40 0F'\r\n '7A 26 02 3D 69 B9 28 04 C8 75 44 A2 97 AC 47 14 02 65 1D 22 11 44 47 46 22 98 3A 4F F1 10 FA 30'\r\n '1A A1 F4 F3 28 84 D1 67 51 08 A7 6F 47 23 82 CE 89 42 24 6D 1E 8D 28 DA 2C 1A D1 D2 3B 1A 31 D2'\r\n 'A3 8C E9 4D 9F 44 23 96 FE 13 8D 38 39 7F 0C E2 A9 F3 94 4A 90 7D 1D 83 44 9A 1C 83 3E 74 5B 39'\r\n '93 44 7F 2F 67 92 E9 1F 31 48 A1 95 7B A3 2F AD DF 1B A9 F4 FB 18 F4 A3 FD 7A 23 4D AE B7 25 FA'\r\n 'D3 57 2D 31 80 16 8E C5 40 DA 21 16 83 D4 C1 F4 62 45 93 4E CF C6 62 88 CC 13 8B A1 72 9F C4 22'\r\n '83 3E 8D C5 30 5A A1 B2 19 4E FF 8B C5 08 B9 EE 38 8C 94 0E 89 18 25 D7 1D 87 D1 74 6A 2B 8C 91'\r\n 'FB 32 0E 63 E9 90 38 8C A3 A7 E3 90 29 F7 49 1C C6 CB 7A 54 35 13 A8 6F 3C 26 D2 BB 55 CD 24 F9'\r\n 'F9 78 4C A6 83 E2 31 85 4E 88 C7 54 7A 2B 1E 59 F4 76 3C B2 E9 7B DE 98 46 5F C7 63 3A 6D 90 80'\r\n '1C 79 5E 24 60 06 1D 90 80 99 B2 8E DE 98 45 B3 6B 9A D9 32 9F 37 E6 D0 3D 09 98 2B FB 22 01 F3'\r\n 'E8 C1 04 CC 97 FD 9B 80 05 34 6F 93 59 48 DF 24 20 57 7A D6 36 79 EA 22 9A 2F 0B 8B E5 7D 27 62'\r\n '89 BA 54 EE 43 6F 2C A3 87 9B 9B E5 F4 5A 92 59 21 D7 91 88 95 F2 BE 12 B1 8A DE F1 C6 6A BA 32'\r\n '11 6B E8 67 89 58 4B ED 44 AC A3 2F 12 B1 5E D6 B3 0F 36 C8 F3 A9 35 36 CA F3 A7 35 36 D1 C5 7D'\r\n 'B0 99 7E 5B CF 6C 91 F3 F6 C1 FB 72 FF 24 61 2B 0D 48 C2 36 1A 98 84 ED 3A FE 40 9E 87 49 D8 41'\r\n 'E7 27 61 27 DD 97 84 5D F2 9C 4A C2 6E FA 61 12 3E A4 37 93 B0 47 F6 6B 12 F6 CA FD 97 84 7D 72'\r\n 'FF 25 63 BF EC BF 64 7C 44 E3 93 71 80 EE 4D C6 41 B9 9E 64 1C A2 C1 29 38 4C DF 6A 64 8E 48 97'\r\n '14 1C 95 FD 98 8C 63 72 7F A7 E0 B8 74 49 C1 09 D9 0F 29 38 29 CF 87 46 E6 94 AC 67 5F 9C A6 E7'\r\n '52 F0 31 DD 9E 82 33 B4 69 1B 9C 95 BE 7D F1 09 9D D4 17 E7 E8 9A BE 38 2F CF C5 BE B8 40 07 B7'\r\n 'C1 45 1A 94 8A 4B 32 4E C5 65 5A D4 C3 7C 2A EB 9F 8A 2B F4 79 3F 7C 26 CF C1 7E F8 9C 56 6C 8B'\r\n '2F 68 6E 3F 7C 29 F7 4D 5B 7C 25 D7 D7 06 5F CB BE 08 C1 37 74 49 08 BE A5 48 C3 77 74 75 3F FC'\r\n '8F EE 9A 02 9B 5E F5 C5 F7 F2 5C 49 C3 55 59 AF 34 5C A3 35 D3 F0 03 4D 48 C3 75 B9 7F D2 70 43'\r\n 'EE 3F 4F 73 53 AE A3 2D 7E 94 E7 76 1A 7E A2 D3 D3 70 8B 86 F6 C7 6D 19 F7 C7 1D 9A EE 65 7E 96'\r\n '8E FD F1 0B AD DE 1F 77 69 99 01 B8 27 EB D1 16 BF 52 9F 01 F8 8D 6E 1A 80 DF E5 39 32 00 F7 E5'\r\n 'B9 32 10 7F C8 9F B7 34 0F E8 0F 03 F1 50 EE F3 76 F8 53 AE 73 10 1E D1 AD DE E6 B1 7C 1E 0E C2'\r\n '13 D9 4F ED F0 54 3E 87 06 E1 19 5D 37 08 7F D1 A3 83 F0 B7 7C FE 0E C2 3F 72 9F B7 31 CF 69 B1'\r\n 'AA E6 85 BC 9F 36 E6 A5 BC 7E 30 FE A5 C7 DB 99 57 F4 D4 60 BC 96 FD 3F 18 6F E4 F3 74 30 FE 93'\r\n 'E7 73 BA F3 C5 8B CF A9 74 E4 A3 63 D2 61 68 E7 74 58 74 40 3A F2 D3 B1 E9 28 40 A7 A7 A3 20 AD'\r\n 'D6 DE 14 A2 5E E9 28 4C DF 1B 82 22 74 C8 10 14 A5 9E ED 51 8C 7E 3A 04 6F D1 0B 43 F0 36 FD AA'\r\n '83 29 4E 5F A4 E3 1D F9 F9 A1 28 41 13 3A 9A 92 74 7E 47 53 8A 9E 1F 8A D2 B4 75 06 CA C8 F9 9C'\r\n 'FF E5 A1 95 33 50 8E 2E 6D 8F F2 B4 47 06 2A D0 89 19 A8 28 D7 9F 81 4A 74 57 06 2A D3 BA 05 4C'\r\n '15 EA 37 0C 55 69 8A 8F A9 46 57 0F 43 75 BA C3 D7 D4 A0 0D 86 A3 26 6D 31 1C B5 68 F0 70 D4 A6'\r\n '85 FD 4D 1D 3A 65 38 EA D2 25 C3 51 4F 7E AE AB A9 4F CB 74 33 0D 68 E6 08 34 A4 73 46 E0 5D BA'\r\n 'B3 03 1A D1 2D 23 D0 98 1E EE 80 26 6A 53 DA 75 24 DE A3 71 23 E1 41 87 8D 44 33 59 DF 91 68 4E'\r\n '2F 8F 84 A7 BC DF 8E F0 A2 75 46 A1 05 6D 19 60 5A 4A AF 51 68 45 F3 02 8C 37 CD 70 FE 2F 93 AE'\r\n 'AB 69 DA D0 12 A3 D1 96 6E 08 32 ED E4 BC 41 A6 3D ED 12 6C 3A D0 57 1D D1 51 DE 5F 27 74 A2 CF'\r\n '46 A3 33 7D 1A 6C 7C E8 93 60 E3 4B 2B 86 98 2E D2 33 C4 F8 49 87 31 F0 A7 D5 C7 A0 AB DA 4D 3A'\r\n '8C 41 77 E9 D5 09 3D 64 1D C6 A0 27 F5 EF 84 00 E9 D5 09 BD 68 D5 70 13 48 03 C7 22 88 CE 1D 8B'\r\n '60 7A 65 2C 42 E8 9D 4E 08 A5 F5 22 4D 18 8D 1C 87 70 BA 32 D2 44 D0 73 91 26 92 2E 18 87 28 7A'\r\n '7F 1C A2 65 FF 75 46 0C ED 94 89 DE 72 3D 99 88 A5 41 99 88 A3 13 62 4C 3C DD DA DB 24 A8 89 F4'\r\n '61 26 FA 50 E3 83 24 D9 0F B1 26 59 F6 DF 78 A4 D0 4B E3 D1 97 D6 F7 41 AA EC 83 38 D3 8F 7E 3D'\r\n '01 69 74 BD 0F FA D3 5F 27 60 80 5C FF 04 0C A4 E0 EF 91 71 CC 49 34 83 65 DF 4D 44 3A CD E7 8B'\r\n '21 72 3F 4C C4 50 39 EF 24 64 C8 FE 9C 84 61 72 3F F9 62 B8 EC C7 64 33 42 F6 49 B2 19 49 63 7C'\r\n '31 8A 5E 4D 36 A3 65 BF 4D C6 18 D9 07 29 66 AC EC CB C9 18 47 5F 4E 46 26 2D 30 05 E3 E9 B5 BE'\r\n '66 02 AD 9D 6A 26 D2 3E 53 30 89 6E 4B 35 93 65 DF 4C C1 14 9A E8 69 A6 D2 EF 7C 91 45 F7 4D 41'\r\n '36 B5 A6 62 1A 2D D6 05 D3 E5 7C 53 91 43 0F F4 C6 0C 59 C7 34 33 53 C6 69 66 16 5D E4 69 66 CB'\r\n 'FD E5 69 E6 BC 70 3F BF E7 D2 FC 59 98 47 D7 F2 F7 C8 F0 F3 B9 0B 16 D0 DC 2C 2C 94 FD 92 85 5C'\r\n 'BA 26 0B 79 74 7F 28 16 D1 BD CE E7 BF 8C B3 B0 84 9E C8 C2 52 7A 37 0B CB 68 BB 41 66 39 FD 25'\r\n '0B 2B 64 7F 65 63 A5 AC 77 36 56 C9 73 20 1B AB E5 FD 67 63 8D BC 3E 1B 6B E9 BD 6C AC A3 51 D3'\r\n 'B0 9E 86 65 63 83 DC 77 D9 D8 28 FB 31 1B 9B E8 F5 6C 6C 96 FB 6E B0 D9 22 D7 9D 6E DE 97 75 1A'\r\n '6C B6 D2 46 7E D8 46 1F 4F C3 76 B9 7F A6 E1 03 5A 6E 3A 76 C8 7C 23 CC 4E DA 77 3A 76 D1 C6 43'\r\n 'CD 6E 1A EF 87 0F 69 92 1F F6 C8 FB 1C 6A F6 CA BE CA 30 FB E4 3C 7E D8 2F CF A1 1C 7C 24 CF 89'\r\n '1C 1C A0 69 39 38 28 CF E5 1C 1C A2 DB 73 70 98 CE CC C1 11 5A 7C 06 8E D2 DB 39 38 46 C7 CD C0'\r\n '71 D9 4F 33 70 42 E6 9D 81 93 B2 2F 67 E0 14 B5 FD 70 9A DE 9A 81 8F A5 D7 4C 9C 91 E7 B3 1F CE'\r\n 'CA 7E 99 89 4F 64 3D 67 E2 9C 9C 7F B4 39 2F AF 9B 89 0B F4 E6 4C 5C 94 E7 A1 3F 2E C9 FE 9B 89'\r\n 'CB F4 98 17 3E A5 BB C7 9A 2B B4 DF 38 F3 19 3D E9 8F CF 65 FF FB E3 0B B9 7F 66 E3 4B FA 60 36'\r\n 'BE A2 B3 E7 E0 6B 1A 31 17 DF C8 3E 9D 60 BE 95 FB 72 2E BE A3 1F CF C5 FF E4 B9 38 0F B6 3C EF'\r\n 'E7 E1 7B B9 FF 27 9B AB B2 CF 0A 9B 6B F2 B9 33 0F 3F D0 E3 F3 70 9D 3E 9A 87 1B 72 BD 85 CD 4D'\r\n 'FA ED 7C FC 48 BD 17 E0 27 59 F7 E9 E6 96 5C C7 74 73 9B 2E 5E 88 3B D2 75 21 7E A6 25 73 F1 0B'\r\n '6D 3A C3 DC 95 F3 E7 E2 9E BC 3E 0F BF CA 7A E4 E1 37 FA 7D 1E 7E 97 E7 4D 1E EE CB 3A 2E C2 1F'\r\n 'B4 EC 62 3C 90 F5 99 63 1E CA 7E 5F 82 3F E5 BE ED 8E 47 F4 D0 12 3C 76 DF 8F 79 22 FB BB 3B 9E'\r\n 'D2 B3 4B F1 4C EE C7 78 FC 25 FB 78 19 FE 96 E7 45 AE F9 87 56 CA 33 CF E5 73 B4 07 5E D0 D1 3D'\r\n 'F0 92 FE B4 0C FF D2 A2 8B CD 2B 79 7D 0F BC 96 E7 F0 62 F3 46 EE E7 E5 F8 4F C5 4B C7 86 CB 91'\r\n '8F 1E 5C 62 0C BD BD 1C 16 F5 EC 89 FC F2 F7 2B 50 80 6E 5D 81 82 F4 CC 0A 14 A2 6F 56 A0 30 FD'\r\n 'BC 27 8A 50 8F 55 A6 28 2D B5 0A C5 68 A7 D5 78 8B BE 5E 8D B7 E5 E7 02 50 9C 3E 08 C0 3B 34 6D'\r\n '0D 4A C8 9F AF 37 25 E9 F3 00 94 A2 05 36 98 D2 B4 F8 46 53 86 E6 6E 34 65 E9 B1 B5 28 47 23 7B'\r\n 'A1 3C 7D B1 16 15 E4 3A D6 A2 A2 BC 6E 1D 2A D1 77 D6 A1 32 2D B7 0E 55 68 DB 75 A8 4A F1 BE F9'\r\n '3F 0F A8 C4 19'\r\n}\r\n\r\n\r\nLANGUAGE 0,0 COMBINING UNICODEDATA LOADONCALL MOVEABLE DISCARDABLE\r\n{\r\n '78 DA 1D D4 5B 50 55 65 18 C6 F1 E7 E5 E3 FB D6 DE 5B DC 6B 9B 28 EC BD D7 B2 A5 96 66 42 ED 12'\r\n '43 10 73 32 3C BB 4D 05 31 C3 53 35 E5 34 66 96 1D 2E 4C C7 52 CB A9 A6 8B 9A A9 46 EB A6 2E 08'\r\n 'B6 59 26 96 87 28 C5 EC A4 51 2E 32 33 A5 24 33 C4 D3 28 7A 59 62 DF FB CE FC 6E FF CF E5 43 D1'\r\n '32 85 31 0A 47 3C 76 CA 43 B7 87 F6 00 BF 04 38 16 E0 78 80 7F 02 74 05 38 17 E0 7C 80 8A 18 59'\r\n '4B 43 7A 2C 24 A7 A0 2A 0A AB 45 54 C5 58 8B A8 EA C3 5A 0A 58 79 82 95 A5 59 97 28 F7 58 73 13'\r\n 'DB 93 20 2B 42 9B 32 D8 9C 41 D4 CF 46 61 B5 89 6C 8C B5 89 6C 1F D6 26 B2 05 AC 4D 64 FB B2 83'\r\n 'A2 32 CE 36 B8 AC 22 81 CA 04 0A 8B 58 99 68 17 4B 52 AC 3A CD 72 E2 4A 1A 57 D3 58 5B CA 4C 23'\r\n '3B 20 6A 9A D8 3E 71 71 0B 1B 1F 23 6B 52 82 ED 16 31 DA A6 61 F5 A1 4F 35 AC 02 DA AE 61 F5 A5'\r\n '66 0D 2B 4E 3B 34 2C 97 3E D3 B0 12 F4 B9 86 D5 8F 76 6A 58 37 E4 ED D2 B0 BE 13 FD 69 B7 C6 1E'\r\n '8D 42 FA 42 C3 1A 40 2D 1A D6 40 FA 52 C3 2A A2 BD 1A 56 31 B5 6A 58 49 DA AF 61 A5 68 D0 BF B0'\r\n 'D2 34 DD C0 F2 68 86 81 E5 53 D6 C0 1A 94 57 6C 60 CD 14 37 E6 25 0D AC FB 44 90 97 32 B0 66 89'\r\n 'C1 34 DB C0 1A 42 73 0C AC A1 F4 A4 81 75 13 F5 73 60 D5 D2 DC 02 58 F5 54 57 00 6B 29 8D 89 A3'\r\n '22 8E 65 34 25 8E E9 71 3C 47 BB E2 D8 1D C7 2A FA 3E 8E 43 71 BC 48 4F B9 B0 D6 A9 95 2E AC 55'\r\n '2E D6 B8 78 41 6C A0 67 5C 58 07 D5 60 85 21 0A C3 15 6E 51 38 EC B3 A3 F4 93 0F EB 58 7E 5A C1'\r\n 'AA 70 D9 23 21 3D 1A D2 13 21 AD 0C E9 38 DD 9A 81 D5 31 76 A0 42 52 C1 53 08 14 86 2A 0C 53 18'\r\n 'A1 30 CA 36 0A 55 0A 93 15 A6 2A 64 15 66 2A D4 28 D4 29 CC 57 78 40 E1 0D CD DE 16 EF 8A 0F 34'\r\n '3E D4 C8 89 6F C4 5C 83 3A 83 05 62 B1 F8 5B 9C 13 17 C5 1D 0E 2B 13 E5 0E 2A 1C 8C 75 50 E5 E0'\r\n '6E 31 41 54 8B 49 62 8A B8 22 E6 47 50 1F C1 9C 28 2B 76 91 74 31 5A 94 8B 6F C5 EB 09 36 36 C9'\r\n '8A 53 6C AD 78 3C CD 7E F5 F0 BB 87 0E 0F 27 3D 5C 14 FB 7D 76 50 FC 2C AE 89 EB A2 3B 60 17 02'\r\n '5C 0A 30 B2 09 A5 4D D8 91 63 D7 88 AC BE 31 56 29 9E 0F 69 5D 48 AF 86 F4 5A 48 7F E6 6F D6 B0'\r\n 'B6 8A 8A 24 2B CD B0 4E BA 2D 83 DB 33 38 45 CB 43 76 5A 7D AC 61 35 15 B3 91 19 D6 55 0B 85 42'\r\n '85 71 0A D5 0A 93 C4 34 85 19 0A B3 14 E6 28 CC 13 F5 E2 61 85 15 0A EB F3 B1 31 1F 6F 6A BC A5'\r\n 'F1 8E C6 26 8D F7 34 DE D7 68 B4 C3 1A 5B 34 3E D2 F8 44 1C 10 09 83 22 83 1A 83 5A 83 79 06 F5'\r\n '06 0B 0D 16 19 1C 35 E8 30 38 69 70 CA E0 B4 38 63 D0 6D 70 DE E0 82 41 C6 61 77 3A 18 E5 60 B4'\r\n '83 BB 1C 54 8A 71 62 BC 83 7B 1C DC 2B 26 8A C9 62 AA 83 69 0E CE 3B E8 71 70 55 0C 8C 20 19 41'\r\n '3A 82 A1 11 DC 1C C1 F0 08 46 44 50 1A C1 EC 28 AB 89 A2 36 8A 75 2E D6 BB 78 D9 C5 46 17 0B FB'\r\n '63 71 7F FC 51 C4 2A 93 AC 28 C5 9E 4D 61 75 0A CB D2 6C 79 1A 4F A7 71 D8 DE B0 87 E3 1E 4E 78'\r\n 'E8 14 FB 7C B4 FA F8 DA C7 0F 3E 0E F9 F8 D1 47 E8 A3 CB 47 AF 38 1C 20 0C 70 24 C0 6F 01 4E 04'\r\n 'E8 08 F0 97 38 23 CE 8A CB E2 52 09 7A 4A D0 59 8A EB A5 58 D1 C0 56 37 60 4D 03 2E 37 A0 A7 01'\r\n '9D 8D E8 69 C4 B6 1C DB 9E 43 73 0E 3B 73 D8 95 C3 57 39 EC CD A1 55 04 BD 18 D6 0B 37 46 D6 18'\r\n 'F1 52 48 AF 84 94 0B 69 6B 48 13 DA A9 BA 9D BA F3 07 28 58 29 71 BF 28 C9 B0 B3 F9 0B 14 AC C5'\r\n 'E2 21 F1 9F CF CE A9 85 0A 8B 14 96 28 3C A8 D0 E6 B3 CB 34 51 C1 FA 1F 23 7F 60 C3'\r\n}\r\n\r\n\r\nLANGUAGE 0,0 NUMBERS UNICODEDATA LOADONCALL MOVEABLE DISCARDABLE\r\n{\r\n '78 DA 5D 97 67 78 1C E7 71 C7 67 6E F7 6E 6F EF 70 7B 77 38 92 E8 C4 2D B0 24 D8 09 2C 55 48 49'\r\n 'B6 D9 9B 24 8A 9D 00 1B C0 06 B0 F7 02 56 91 14 AB DC 28 52 35 F1 07 3B 05 46 F9 62 4B 2E 52 22'\r\n '97 C4 29 CE 97 44 E4 91 82 E4 34 57 F6 06 8A 0D B6 65 E4 E7 60 F5 84 31 9E 67 9E B9 7D E7 37 FF'\r\n '79 F1 EE DC BC C0 66 E1 47 1F B1 50 E0 8D C0 9B 81 0F 07 3E 12 78 2B F0 D1 C0 DB 8F 68 98 8F 68'\r\n '19 8F 3C A7 1E C9 31 82 E7 CF D6 62 81 5F 19 F8 CB C6 FF ED 23 14 D4 0F 05 75 43 41 BD 3F FA 78'\r\n 'E0 13 81 4F 06 3E 1D F8 1E 7E FE E8 FB 04 BA FD 03 3F 28 F0 7E E0 9F 09 FC E4 C0 CF 0C FC C2 CF'\r\n 'F6 5E D5 EB D3 C1 73 7E E0 33 8F FC DE D6 9F 9C 45 4C FE FF EF 60 3C 72 96 9F FD 4E 46 E0 CD 3F'\r\n '39 E3 70 E0 8D E0 BC C2 81 B7 02 1F 0F D8 BC C0 DF D5 5E 7F 22 13 EC FF 27 BD FE EB C7 F4 7F 7D'\r\n '22 E0 9C C0 27 03 DF 37 F0 FD 02 5F 10 F8 C2 C0 17 05 BE 38 F0 25 81 2F 0D 7C 59 E0 CB 03 9F 0D'\r\n 'BC 1B F8 8A C0 57 06 DE 0B FC 80 C0 0F 0C 7C 55 E0 07 07 7E 48 E0 87 06 7E 58 E0 87 07 7E 44 E0'\r\n '47 06 BE 3A F0 35 81 FF E9 67 79 C1 B9 9C 0A 7C 6D A8 D7 BF 1F F8 6C D0 67 47 02 FF 81 D5 EB DF'\r\n '8D 07 E7 97 EC F5 9B 0B 82 FC 92 5E 3F B6 3C E8 A3 CA 40 67 46 B0 8F 1D 41 FC 6B BD BE E1 6A 90'\r\n '9F EE 7D 0F 07 47 F7 FA 53 F5 BD 7E A6 D9 BB 77 F6 AD F4 62 68 14 AF FC 31 DA E1 71 5E F9 13 B4'\r\n 'C0 93 BC F2 D1 BC F2 31 B4 D5 DB C4 DF 21 FE 1E EC FB B4 D7 0F 68 83 1F D2 02 0D 34 CA B2 88 E8'\r\n 'F2 88 84 56 44 C4 58 19 11 73 55 44 C2 8D 11 89 34 45 C4 5A 1D 91 E8 9A 88 D8 B7 E1 BA E0 EE C0'\r\n '7D 02 77 17 EE 1E DC 7D B8 07 70 0F E1 BA E1 7E CC 19 FC 9D 25 FA F7 96 84 7E 62 89 F1 0F 96 98'\r\n 'FF 68 49 F8 9F 2C 89 FC B3 25 D6 4F 2D 89 FE 8B 25 76 23 8D DE 64 8B AE B6 25 B4 C6 16 63 AD 2D'\r\n 'E6 3A 5B C2 EB 6D 89 6C B0 C5 DA 68 4B 74 93 2D F6 45 B8 4B 70 97 E1 AE C0 5D 85 BB 06 77 1D EE'\r\n '06 DC 4D B8 5B 70 77 6D 49 DC B3 C5 B9 6F 4B F2 81 2D B1 87 B6 E4 75 DB 92 6A E4 8B D4 14 A3 4E'\r\n '8C 3A 31 EA C4 A8 13 A3 4E 8C 3A 31 EA C4 A8 13 A3 0E DC 25 B8 CB 70 57 E0 AE C2 5D 83 BB 0E 77'\r\n '03 EE 26 DC 2D B8 46 DE 6D 53 1C BD 38 7A 71 F4 E2 E8 C5 D1 8B A3 17 47 2F 8E 5E 5C EC AD 71 89'\r\n '6D 8B 4B 7C 7B 5C F2 76 C4 25 B1 33 2E CE AE B8 24 2F 92 7F 89 FC CB E4 5F 21 FF 2A F9 D7 C8 BF'\r\n '4E FE 0D F2 6F 92 7F 8B FC DB 71 49 77 C5 25 FF 4E 5C 32 8D 7C 51 9B F2 A8 99 47 CD 3C 6A E6 51'\r\n '33 8F 9A 79 D4 CC A3 66 1E 35 F3 C4 6E 86 DB 0D B7 07 6E 2F DC 3E 3E EF E7 F3 01 3E 5F 24 76 89'\r\n 'E7 CB 3C 5F E1 F9 2A 1A D7 D0 B8 8E C6 0D 34 6E A2 71 0B 8D 46 BE EC 4D 09 6A 25 A8 95 A0 56 82'\r\n '5A 09 6A 25 A8 95 A0 56 82 5A 09 B1 37 27 24 BD 25 21 F9 5B 13 92 D9 96 90 D8 F6 84 C4 77 24 24'\r\n '6F 26 43 62 96 23 3A DB 91 D0 1C 47 8C B9 8E 98 F3 1C 09 CF 77 24 B2 C0 11 AB D6 91 68 9D 23 F6'\r\n '07 70 67 E1 CE C1 E5 E0 CE C3 5D 80 FB 10 AE 13 EE 23 B8 8F E1 B2 7C 87 DC A4 68 45 52 42 95 49'\r\n '31 BC A4 98 03 92 12 1E 98 94 48 55 52 AC 41 49 89 0E 4E 8A 3D 24 29 F1 A1 49 E9 33 2C 29 7D 87'\r\n '27 A5 DF 88 A4 14 8C 4C 4A 61 75 52 8A 6A 92 52 EC 27 A5 64 54 52 4A C7 72 69 8C 4B 89 8E 4F 49'\r\n '68 42 4A 8C 89 29 31 27 A5 24 3C 39 25 91 29 29 B1 A6 A6 24 3A 2D 25 F6 29 B8 57 E0 4E C3 9D 81'\r\n '7B 15 EE 35 B8 D7 E1 DE 80 7B 13 EE 2D B8 35 19 D1 B5 19 09 AD CB 88 B1 3E 23 E6 86 8C 84 37 66'\r\n '24 B2 29 23 D6 E6 8C 44 B7 64 E8 85 8C A4 B7 65 A4 6C 7B 46 FA EF C8 48 F9 CE 8C 64 77 65 C4 6D'\r\n 'CE 48 C5 EE 8C 54 EE C9 88 B7 37 23 F9 FB 32 32 E0 66 3F 19 78 AB 9F 54 DD EE 27 83 7E CE DC F8'\r\n '45 81 E8 2F 0B 24 F4 AB 02 31 7E 5D 20 E6 6F 0A 24 7C B1 40 22 97 0A C4 BA 5C 20 D1 2B 05 F4 0A'\r\n '5C 17 DC 1D B8 4F E0 EE C2 DD 83 BB 0F F7 00 EE 21 5C 37 5C 8A C1 9C 2E 14 CD 2F 94 50 A6 50 8C'\r\n '3E 85 62 F6 2D 94 70 BF 42 89 14 14 8A 55 58 28 D1 A2 42 B1 27 33 B8 A7 14 89 4E 2D 92 D0 B4 22'\r\n '31 A6 17 89 F9 6C 91 84 9F 2B 92 C8 F3 45 62 CD 28 92 E8 0B 45 BC 43 B8 B3 70 E7 E0 72 70 E7 E1'\r\n '2E C0 7D 08 D7 09 F7 11 DC C7 70 3F 83 39 C8 25 70 A8 58 F4 70 B1 84 5E 2A 16 E3 48 B1 98 47 8B'\r\n '25 7C AC 58 22 C7 8B C5 3A 51 2C D1 93 C5 9C 3B DC 2B 70 A7 E1 CE C0 BD 0A F7 1A DC EB 70 6F C0'\r\n 'BD 09 F7 16 DC 4C 66 E9 AC 12 FA AC 84 3E 2B A1 CF 4A E8 B3 12 FA AC 84 3E 2B A1 CF 4A E8 B3 12'\r\n 'B1 BF 05 F7 6D B8 B7 E1 DE 81 FB 0E DC 77 E1 BE 07 F7 7D B8 77 E1 DE 83 1B CB A5 34 AE 94 BE 28'\r\n 'A5 2F 4A E9 8B 52 FA A2 94 BE 28 A5 2F 4A E9 8B 52 FA A2 94 BA 70 B3 E0 66 C3 CD 81 9B 0B 37 0F'\r\n '6E 3E DC 02 B8 5A B8 3A B8 CD 5C 66 DB B3 62 EE C8 4A 78 67 56 22 BB B2 62 35 67 25 BA 3B 2B F6'\r\n '41 62 87 B2 9C 45 96 B3 C8 72 16 70 47 E1 8E C1 1D 87 3B 01 77 12 6E A6 2B 83 67 B9 32 64 B6 2B'\r\n '43 E7 B8 32 6C AE 2B C3 E7 B9 32 62 BE 2B 23 17 B8 52 5D EB 4A 4D 9D 2B FE 42 57 46 2D 72 C5 59'\r\n 'EC CA 63 4B 5C 79 7C A9 2B 4F D4 BB A2 0D D8 32 57 42 CB 5D 31 56 B8 62 AE 74 25 BC CA 95 48 A3'\r\n '2B 56 93 2B D1 D5 2E FD EB 4A 7A AD 2B 4F AE 73 65 F4 7A 57 B2 1B 5C C9 DF E8 CA 98 4D AE 64 36'\r\n '93 BF 85 FC AD E4 6F 23 7F 3B F9 3B C8 DF 49 FE 2E F2 9B C9 DF 4D FE 1E F2 F7 92 BF 8F FC FD E4'\r\n '1F 20 FF 45 F2 0F 62 87 5C 79 EA B0 2B 03 8E 92 77 8C F8 71 57 9E 3E E1 CA 33 27 B9 E4 1B 3C F6'\r\n 'E7 B1 3F 8F FD 79 EC CF 63 7F 1E FB F3 D8 9F C7 FE 3C F6 E7 B1 3F 8F FD 79 EC CF 93 CF 6D F0 E4'\r\n 'F3 1B 3D F9 C2 26 4F 52 9B 3D 19 B8 C5 93 AA AD 9E 0C DA E6 F1 FD 42 6F 07 7A 3B D1 DB 85 5E 33'\r\n '7A BB D1 DB 83 DE 5E F4 F6 A1 B7 1F BD 03 E8 BD 88 DE 41 F4 0E A1 77 18 BD 97 D0 3B 82 DE 51 F4'\r\n '8E A1 77 1C BD 13 E8 9D 44 EF 65 F4 BE 88 DE 97 D0 FB 32 7A 5F 41 EF AB E8 9D 42 EF 15 F4 4E A3'\r\n '77 06 BD 57 D1 7B 0D BD D7 D1 7B 03 BD 37 D1 7B 0B BD 3F 43 EF CF D1 BB CA 1F 30 D7 60 AF C3 DE'\r\n '80 BD 09 7B 0B F6 36 6C 17 EC 1D D8 4F 60 EF C2 DE A3 F6 7D 6A 3F A0 F6 43 6A 77 53 FB B7 D4 FE'\r\n '1D B5 7F 4F ED 4F A9 FD 07 6A F7 A0 B9 B3 4A 74 57 95 84 9A AB C4 D8 5D 25 E6 9E 2A 09 EF AD 92'\r\n 'C8 BE 2A B1 F6 57 49 F4 40 95 D8 2F 56 49 FA 20 DC 21 B8 C3 70 2F C1 1D 81 3B 0A 77 0C EE 38 DC'\r\n '09 B8 93 70 2F C3 7D 11 EE 4B 70 5F 86 FB 0A DC 57 E1 4E C1 BD 02 77 1A EE 0C DC A7 C3 24 6E F1'\r\n '07 88 5B CD 7C AE 66 3E 57 33 9F AB 99 CF D5 CC E7 6A E6 73 35 F3 B9 9A F9 5C 2D F6 E8 6A 49 8F'\r\n 'A9 96 B2 A7 AA A5 FF E9 1A D1 33 35 12 7A B5 46 8C D7 6A C4 CC FA A2 AE 2F A1 0A 5F 8C 4A 5F 4C'\r\n 'CF 97 F0 00 5F 22 03 7D B1 AA 7C 89 0E F2 C5 1E EC 4B 7A 96 2F 63 67 FB 32 6E 8E 2F E3 E7 FA 32'\r\n '61 9E 2F 13 E7 FB 32 69 81 2F 93 6B 7D 99 52 E7 CB D4 85 BE F4 5F E4 CB B4 C5 BE 4C 5F E2 CB B3'\r\n '4B 7D 79 AE DE 97 E7 0F 52 E3 10 35 0E 53 E3 25 6A 1C A1 C6 51 6A 1C A3 C6 71 6A 9C A0 C6 49 6A'\r\n '7C DB 97 19 6F FB F2 C2 3B BE CC FC 8E 2F B3 BE EB 4B F9 F7 7C 99 FD 7D 5F E6 BC EB CB DC F7 7C'\r\n '99 F7 37 BE CC FF 5B 5F 16 BC EF 4B ED 0F 7C A9 FB A1 2F 0B 7F E4 4B 36 DB C2 59 B4 70 16 2D 9C'\r\n '45 0B 67 D1 C2 59 B4 70 16 2D 9C 45 0B 67 D1 C2 59 B4 F0 B7 06 CC 25 98 CB 30 57 60 AE C2 5C 83'\r\n 'B9 0E 73 03 E6 26 CC 2D B4 AA 5B 25 56 D3 2A 71 BF 55 F2 46 B5 4A E2 B1 56 71 1E 6F 95 E4 07 AD'\r\n 'CC DD 56 E6 6E 2B 73 B7 95 B9 DB CA DC 6D 65 EE B6 32 77 5B 99 BB AD CC DD 56 FE 95 68 E3 8F BD'\r\n '36 D1 50 9B 84 8C 36 31 CC 36 31 C3 6D 12 8E B4 49 C4 6A 13 2B DA 26 51 BB 8D 39 0E 77 16 EE 1C'\r\n '5C 0E EE 3C DC 05 B8 0F E1 3A E1 3E 82 FB 18 6E 66 3B B3 AF 9D D9 D7 CE EC 6B 67 F6 B5 33 FB DA'\r\n '99 7D ED CC BE 76 66 5F 3B B3 AF 9D FB A8 83 FB A8 83 FB A8 83 FB A8 83 FB A8 83 FB A8 83 FB A8'\r\n '83 FB A8 83 FB A8 83 FB A8 43 EC 75 DD CC 95 6E 49 37 77 4B E8 ED 6E F6 D0 2D 91 1C F6 29 6B A9'\r\n '1E EE AA 1E EE AA 1E EE AA 1E EE AA 1E EE AA 1E EE AA 1E EE AA 1E EE AA 1E EE AA 1E B1 2D 55 8D'\r\n 'AA 86 6C 55 23 A6 6A C6 55 C3 79 AA 91 84 AA E5 10 4A AA DA 29 D5 74 5A B5 2C 5F B5 7F 46 B5 BC'\r\n '8F 6A B6 AF AA DB 4F B5 A2 40 B5 B2 50 D5 2B 52 CD 2F 56 5D 54 A2 BA B8 54 75 49 99 EA 98 FE AA'\r\n '4B CB 55 EB B3 CA 28 55 5D 56 A1 9A A9 54 5D EE A9 AE 18 A0 BA 72 A0 EA 53 55 AA AB 06 A9 36 0E'\r\n '56 6D 1A A2 BA 7A A8 EA 80 61 AA 6B 86 AB AE 1D A1 BA 6E A4 EA D3 D5 AA EB 6B 54 37 F8 AA 1B 47'\r\n 'A9 6E 1A AB 1A 1B A7 1A 1F CF DE 27 B0 DF 89 EC 67 12 F5 26 A3 37 05 7E 2A 6B D3 D8 F3 74 D6 9F'\r\n '65 5F CF 11 7B 9E DA 33 88 BF 40 6C 26 B1 59 C4 66 13 9B 43 6C 2E B1 79 D4 9D 4F EE 02 62 B5 E8'\r\n 'D6 61 0B B1 45 9C CD 62 6C 09 B6 14 AB 27 BF 01 66 19 B6 1C 5B 81 AD C4 56 71 36 8D 68 36 61 AB'\r\n 'B1 35 D8 5A F4 D7 71 1E EB A9 B1 01 DB 88 6D C2 36 63 5B A8 B9 95 FD 6C 43 6F 3B EC 0E 7E 9F 9D'\r\n 'D8 2E D5 E1 CD AA 79 2F AB F2 FF 11 87 6C 68 B8 C2 D0 74 A5 A1 D9 71 86 7A D3 0D 5D 76 96 F5 73'\r\n '86 86 72 AC 9F 37 B4 EC 82 A1 F9 5F 37 55 BE 61 AA FE 85 A9 A1 BF 34 D5 F8 2B 53 CD BF 36 35 DC'\r\n '62 6A E4 9B A6 5A AD A6 46 DB 4C B5 6B 79 D9 75 51 0D 2D 8C AA B1 28 AA E9 C5 51 2D 5B 12 D5 FC'\r\n 'A5 51 CD D4 47 75 40 3F 1A A1 C0 D6 74 A1 AD 65 45 36 EF D4 D6 50 89 AD C6 58 9A 63 5C 4C 43 E3'\r\n '63 6A 4C 88 A9 39 31 A6 E9 49 31 2D 9B 1C D3 FC 29 31 CD EC 27 7E 20 A6 D9 5A 1A A8 2E 8E 7E 1C'\r\n 'FD B8 9A 8B E3 9A 5E 12 D7 B2 A5 71 CD AF 8F 6B A6 99 F8 6E E2 7B 88 EF 25 BE 8F F8 7E E2 07 88'\r\n 'BF 48 BC 81 A6 5B E6 68 68 B9 A3 C6 0A 47 CD 95 8E 86 57 39 1A 69 74 D4 6A 72 34 BA DA 51 7B 8D'\r\n 'A3 E9 B5 8E 96 AD 73 B4 FF 7A 47 CB 37 38 9A DD E8 A8 BB C9 D1 8A CD 8E 56 6E 71 D4 DB EA 68 FE'\r\n '36 47 17 6D 77 74 F1 0E 47 97 EC 74 74 CC 2E 47 97 36 3B 5A BF DB D1 86 3D 8E 2E DB EB 68 7C 9F'\r\n 'A3 B1 FD 8E 0E 3B E0 E8 F0 D9 34 FA 9C 94 86 E6 A6 D4 98 97 52 73 7E 4A C3 0B 52 1A A9 4D A9 55'\r\n '97 D2 E8 C2 94 DA 8B 52 9C 59 8A 33 4B 69 FF A5 29 2D AF 4F 69 B6 21 A5 EE B2 94 56 2C 4F 69 E5'\r\n '8A 94 7A 2B 53 9A BF 2A A5 99 C6 94 4A 13 9A AB D1 5C 83 E6 5A 34 D7 A1 B9 1E CD 0D 68 6E 44 73'\r\n '13 9A E2 69 48 3D 35 42 9E 9A 86 A7 61 D3 D3 48 D8 53 2B E2 69 D4 F2 D4 8E 12 B3 89 C5 88 C5 89'\r\n 'E5 11 4B 10 73 88 25 59 4F B1 9E 66 3D 9F F5 0C EB 7D 58 EF CB 97 AC 1F BA 05 E4 16 C2 14 C1 14'\r\n 'C3 94 C0 94 C2 94 C1 F4 87 29 87 C9 C2 B8 30 15 30 95 3C 7B 3C 0F C0 06 B2 56 C5 DA 20 F2 06 93'\r\n '37 84 BC A1 E4 0D 23 6F 38 DC 08 98 91 58 35 5C 0D DC 63 AC 3F CE FA 13 AC 3D 89 8D 66 7D 0C EB'\r\n '4F F1 F9 69 EC 19 9E 3F 87 7D 1E FB 02 36 16 DD 71 E8 8E C7 26 60 13 D1 9F 84 4D A6 C6 14 6C 2A'\r\n '36 0D 9B 8E E6 B3 E4 3F 47 CE F3 E8 CD 20 EF 05 6A CD 64 7D 16 EB B3 59 9F 83 CD 25 36 0F AB 25'\r\n '56 47 6C A1 A7 C3 16 79 3A 7C B1 A7 A3 96 F0 79 29 9F EB 3D 75 1A 3C 8D 2D F3 D4 67 10 C5 1A 72'\r\n 'F4 5B 8E 7E CB D1 6F 39 FA 2D 47 BF E5 E8 B7 1C FD 96 A3 DF 72 F4 5B 8E 7E CB D1 6F 39 FA 2D 47'\r\n 'BF E5 E8 B7 1C FD 96 A3 DF 72 F4 5B 4E BD 7F ED 54 F9 B7 4E D5 0F 3A 35 74 B6 53 8D 73 9D 6A E6'\r\n '3A 35 7C BE 53 23 17 3A D5 FA B0 53 A3 9D 9D 6A 7F 04 F7 31 DC CF E0 FE 1D EE 3F E0 FE 13 EE BF'\r\n 'E0 FE 1B EE E7 70 BF 80 FB 25 DC AF E0 7E 0D F7 1B B8 8B 70 97 E0 2E C3 5D 81 BB 0A 77 0D EE 3A'\r\n 'DC 0D B8 9B 70 B7 E0 6E C3 75 C1 DD 81 FB 04 EE 2E DC 3D B8 FB 70 0F E0 1E C2 75 C3 FD 16 EE 77'\r\n '70 BF 87 FB 14 EE 0F 70 3D 70 D2 A5 A2 58 A8 8B 0B A1 4B 43 66 97 1A E1 2E 35 23 5D 1A B6 BA 34'\r\n '12 ED 52 CB EE D2 68 AC 4B ED 53 0F 43 F6 FF 00 1A 08 3D 28'\r\n}\r\n\r\n\r\nLANGUAGE 0,0 COMPOSITION UNICODEDATA LOADONCALL MOVEABLE DISCARDABLE\r\n{\r\n '78 DA 5D 5D 05 94 55 D5 FB FD DE 7B CC D0 30 8F 54 14 A4 3B 86 19 BA A4 BB 87 94 EE EE 0E 25 04'\r\n '04 04 04 A4 41 10 C5 40 90 14 11 03 1B 10 B0 70 E6 A1 02 16 26 26 B6 3F C2 FF DE E7 EC 37 D7 F5'\r\n '5F EB 2D F7 DE 5F 9C F8 CE B9 E7 DE 17 0E BD A3 66 8B 22 16 4E 2A 6E 16 8A D8 33 96 49 2F 86 3D'\r\n '8D 44 6C BF AC 59 22 76 F9 5F 0B E7 F4 B4 51 71 6F 4D 88 58 BB 9B 99 B4 4D 40 DB 07 B4 6D 40 3F'\r\n '54 BB 89 11 FB 48 34 6B C4 7E BC C3 22 06 9A 2D 82 1E 6D 71 24 53 61 24 AF 06 BE A6 11 7B 52 83'\r\n '81 FA 58 F9 39 22 76 49 34 67 C4 DE 56 78 7E D7 D4 3B 81 42 53 EF 06 0A 4D BD 7C 87 4F 82 7A 29'\r\n 'A0 97 14 53 C0 E5 7F 12 28 E4 7F 1A 28 E4 DF 54 12 D4 73 1A 55 B9 88 5D D0 50 CA 47 AC B0 4A 94'\r\n '1A B1 57 14 8B B4 D9 AA 77 8B 88 4D 44 5D 12 41 DB 25 5A FF EB 16 21 6D 9F 68 5D 12 6D B2 1C 50'\r\n '03 E4 E8 E0 1C 53 E5 80 1A 28 47 47 E7 98 2E 07 D4 20 39 3A 39 C7 4C 39 A0 06 CB D1 D9 39 66 CB'\r\n '01 35 44 0E 58 27 26 DA 5C 39 A0 EE 11 ED 9A 68 5B 93 FD B0 37 27 DB 36 D1 2D C9 66 C9 16 E2 86'\r\n 'C8 5E DC 42 6E 59 84 39 84 0F 63 33 85 81 03 A4 AB 15 F7 3A 8B 74 44 18 16 26 08 B3 2A 2E 51 BA'\r\n '01 4B 59 C2 0C AF 36 A2 77 9A 15 BC 69 A1 1C A0 A1 7F 31 0A 60 4F E8 DC C0 30 75 49 B4 4E 2C 85'\r\n 'DE 69 07 8E 22 96 46 EF B4 03 47 53 97 41 AF D4 C0 44 62 59 B3 81 B4 03 B3 52 97 33 9B 5A DA 22'\r\n '49 E5 CD AA 9B 55 30 BB BB B4 65 91 4A 76 86 7B 02 83 8F 98 17 18 52 9C 61 7E 60 48 75 86 05 81'\r\n 'A1 86 33 2C 0C 0C 35 9D E1 DE C0 50 CB 19 16 05 86 DA CE B0 38 30 D4 71 86 25 81 A1 AE 33 4C D3'\r\n 'B8 FD 20 EE 93 3B 25 3E EE E9 72 FB 21 CD 90 F2 E3 99 29 E5 07 33 4B CA 8F 64 B6 94 1F C6 1C 29'\r\n '3F 86 B9 52 7E 00 49 57 43 4E 35 71 2A 2A D5 D4 A9 7C 52 CD 9C CA 2F D5 DC A9 02 52 2D 9C 2A 28'\r\n 'D5 D2 A9 42 52 AD 9C 2A 2C D5 DA A9 5B A4 DA 38 75 AB 54 5B A7 8A 48 B5 73 EA 36 A9 F6 4E DD 2E'\r\n 'D5 C1 A9 A2 52 1D 9D 2A 26 D5 C9 A9 3B A4 3A 3B 55 5C AA 8B 53 25 A4 BA 3A 55 52 2A CD A9 52 52'\r\n 'DD 9C 2A 2D D5 DD A9 32 52 3D 9C 2A 2B D5 D3 A9 72 52 BD 9C 2A 2F D5 DB A9 0A 52 77 39 B5 4D 95'\r\n '1F E4 D4 43 52 83 9D DA 2E 35 C4 A9 1D 52 43 9D 7A 58 6A 98 53 3B A5 86 3B F5 88 D4 08 A7 1E 95'\r\n '1A E9 D4 2E A9 51 4E 3D 26 35 DA A9 C7 A5 C6 38 F5 84 D4 58 A7 9E 94 1A E7 D4 6E A9 F1 4E 3D 25'\r\n '35 C1 A9 3D 52 13 9D DA 2B 35 C9 A9 A7 A5 26 3B B5 4F 6A 8A 53 FB A5 A6 3A 75 40 6A 9A 53 07 A5'\r\n 'A6 3B 75 48 6A 86 53 87 A5 66 3A F5 8C D4 2C A7 8E 48 CD 76 0A D7 90 53 16 A5 CA 93 E2 2F 2C A8'\r\n '41 CE 10 92 3B EC 54 5E B9 C3 71 77 58 EE 88 53 49 72 47 E2 EE 88 DC 09 4E 45 E5 4E 88 BB B3 C8'\r\n '9D E8 54 3E B9 13 E3 EE 04 B9 B3 3A 95 5F EE AC 71 77 A2 DC D9 9D 2A 20 77 F6 B8 3B AB DC 39 9D'\r\n '2A 28 77 CE B8 BB 68 8A 65 95 61 54 D4 72 45 6D 58 D4 F6 38 4F B1 14 4B 0C 3C F9 A2 36 DE 99 B3'\r\n 'A9 BD 5C 4E 15 52 7B B9 E2 ED DD 1E 18 7C 7C 76 C5 E7 71 AA B0 DC 79 E2 F1 39 E4 CE EB D4 2D 72'\r\n 'E7 8D BB 73 CA 9D E4 D4 AD 72 27 C5 DD B9 E4 8E 3A 55 44 EE 68 DC 9D 5B EE 7C 4E DD 26 77 BE B8'\r\n 'BB 78 7C CD 3B BA AB 34 BE 86 4E 95 8C 57 D5 A9 F2 52 FD 9C 2A 21 B5 C2 A9 D2 52 EB 9C AA 2B 75'\r\n 'D9 A9 86 52 A1 4E 54 4D E2 A3 75 AA 9C D4 98 2E EE C4 90 1A E7 54 1D A9 67 BA BA 53 41 AA 49 1A'\r\n 'D5 9D 52 DD 9C AA 21 95 BB 1B 55 3D A9 B9 4E 95 92 BA D0 83 AA 9A D4 1D 3D A9 EA 4B 0D EF 43 95'\r\n '2C F5 D5 30 AA 8A 52 D9 46 50 A5 C4 2B E1 54 15 A9 F2 4E 55 97 AA 38 92 AA B2 54 8D B1 54 95 E2'\r\n 'F3 9B 48 55 53 6A D6 64 AA 06 F1 2A 4D A7 4A 95 6A 34 8B AA 76 BC D6 4E 35 8E D7 C5 A9 A6 52 57'\r\n '16 50 35 93 FA CD A9 5A 52 3B 57 50 35 92 3A E9 54 55 A9 F7 D7 B8 B1 F0 21 03 6A 25 1E 45 B2 F3'\r\n 'EC E5 C3 01 E7 CB 87 03 E0 DD B0 67 E3 BD 91 71 88 BF 8B 7E E0 2A C6 73 4B 33 8E 4F 09 8C 03 0E'\r\n 'A2 BF 22 F6 32 ED C0 C1 D4 95 B0 79 A9 81 15 AE 59 28 04 5C CE 7C E0 6C E6 01 73 D1 5F 19 77 1E'\r\n 'C6 03 93 D8 1F 30 37 ED 55 70 B6 D3 0E 2C 5B 1C A3 AF 8A 59 B8 D7 AD 37 2D 92 23 53 95 E1 B3 93'\r\n 'A7 C9 78 B4 93 A3 34 1F B2 80 5D D9 02 30 0F 5B 04 E6 25 56 C3 7E BC 1A 0A 27 E1 91 01 9D 99 28'\r\n 'BC CB 4A 58 24 2F 68 F3 E2 7C 80 E8 95 6A CE 71 6C A2 FD 79 3E 14 0A 81 7E 28 FC 41 38 91 13 01'\r\n '7E 21 FD 8E 30 89 DD 00 AF 94 B6 50 56 E0 7C 4E 1C 18 66 5F D5 5D B7 4B 4B 9B A3 E8 76 0D 0F 62'\r\n 'FF E8 05 F5 5D 6A A6 C2 6E 7C 2B 25 53 61 37 0E 0E 7C 18 D5 28 34 91 D5 AB B5 6A C2 37 78 25 35'\r\n '53 A1 89 D3 29 99 0A 4D 0C 09 7C 68 62 B4 9A C0 EB 41 35 91 E2 9A F8 3E 35 53 A1 89 33 29 99 0A'\r\n '4D 0C 0D 7C 68 62 8C 9A 80 5A A7 26 52 5D 13 3F A4 66 2A 34 31 2C 50 48 1A AB 24 A8 F5 4A AA E1'\r\n '92 7E 4C CD 54 48 1A 1E 28 24 8D 53 12 D4 06 25 D5 74 49 3F A5 66 2A 24 8D 08 14 92 C6 2B 09 6A'\r\n 'A3 92 6A B9 A4 9F 53 33 15 92 46 06 0A 49 13 94 04 B5 49 49 B5 5D D2 2F A9 99 0A 49 A3 02 85 A4'\r\n '89 4A 82 DA AC A4 3A 2E E9 6A 6A A6 42 D2 E8 40 21 69 92 92 A0 B6 28 A9 AE 4B FA 35 35 53 21 69'\r\n '4C A0 90 34 59 49 50 5D 4B 58 96 BC D5 DD 96 F5 3B E1 25 1C E0 32 60 45 D2 4A 64 2A 94 FA C5 C0'\r\n '87 1A 76 0F 7C 28 4E EF 40 61 D6 9D 03 85 E9 F4 09 14 C6 D9 25 50 18 C0 80 12 16 96 FA 2C D5 6F'\r\n '69 8C F7 95 14 4F B1 5B 7A CB 8A 71 5F E6 E5 01 FA 97 F0 23 E1 02 5E 1E 0C C1 85 99 0D 38 90 97'\r\n '0D F0 5D F9 A3 BC 9C 80 3F 4A 47 78 19 A5 B8 CB 68 19 2F 23 BF 65 B7 B2 7E 29 F1 CB E8 B7 D4 4C'\r\n '85 F1 8C 0D 14 C6 31 85 F5 F3 EA 77 39 FC B0 C7 05 0A 61 5D 52 7C 18 D4 1F 72 F8 CB 61 7C A0 10'\r\n 'D6 55 61 78 FD 29 87 DF F2 13 02 85 B0 34 85 41 FD 25 87 DF E4 13 03 85 B0 6E 0A 83 FA 5B 0E BF'\r\n 'AD BB CB 01 F5 8F 1C 7E EB F6 90 03 EA 7F 72 F8 ED D9 53 0E A8 6B 72 F8 2D D8 4B 0E A8 EB 72 F8'\r\n '6D D6 5B 0E A8 6E 5C E5 94 F8 CE E9 11 28 F4 FF 79 AA 2F 3A 32 5E 4D F1 14 0B 7D 97 AC 98 C4 42'\r\n '2E 28 68 3E 2E 1C 70 10 17 14 F8 13 17 10 F8 B1 F0 4B E1 7B C2 43 DC 00 C0 BF A5 B3 70 A1 53 DD'\r\n '42 2F E7 42 FB 83 E5 06 C7 9C 1A 5F DA BB 38 66 AF 6E CA E1 17 B3 8F 1C 50 7D 45 D1 64 3F 51 BC'\r\n 'FA 8B A2 D4 03 44 31 B9 83 A2 28 E7 21 51 14 F0 B0 28 4A F6 8C 28 8A 74 9C 17 54 6A FC 82 EA 59'\r\n '22 53 A1 9D BE 81 42 D2 17 A9 7E F8 18 D7 6B 29 9E A2 64 7D 64 45 C9 EE 65 C9 18 C0 A9 03 DF 17'\r\n '1E 66 49 80 FF 48 0F 66 29 81 17 A4 F3 B3 C4 C0 9F A5 13 58 B2 1A AE 64 F7 B3 64 FE 58 3D C2 31'\r\n 'D7 70 45 7A 56 14 65 39 2A 8A B2 3C 27 CA C1 88 E2 F5 BC 28 A6 F3 82 28 CA F2 A2 28 CA F2 92 28'\r\n '66 78 5C 14 65 E9 C5 A9 D7 88 17 E2 72 AA 1F 06 A6 FE 7A 8A A7 98 7A 5F 59 31 F5 02 9C 02 E8 10'\r\n '4E 0D F8 3F 4E 05 F8 B5 F0 A2 70 11 4B 04 3C 27 3D 95 77 5F E0 2F D2 89 9C 7A 4D 37 F5 15 9C BA'\r\n 'BF 39 BC CC 71 D5 74 53 BF 8B E3 AA 19 3F E3 FA 05 0A C3 FF 32 D5 67 60 94 6F A4 78 8A 51 F6 93'\r\n '15 A3 2C C8 51 82 5E 63 6F C0 0F 84 97 84 DF 08 AF 0A 87 72 36 C0 69 1C 25 70 31 47 0F CC CA 51'\r\n 'D6 72 A3 5C C9 51 FA BB D1 57 A9 9E A2 FB 37 53 3C 45 F7 FD 65 45 F7 E9 6C 16 74 3A 9B 03 16 E2'\r\n '70 80 DF CA 7E 5D F8 89 70 09 BB 03 FE 2A 3D 8C C3 61 AB EC BE B6 EB 7E 15 BB F7 F7 B5 FE AC 45'\r\n 'ED 78 2D BE 4E F5 0E 0C E6 44 8A A7 18 CC 00 59 31 98 EF D8 28 E8 7D EC 04 38 83 83 02 DE 90 3D'\r\n '43 F8 9B B0 30 07 0B 1C CE 41 00 3F 95 3D 3B 07 53 C7 0D E6 01 0E C6 DF 2F BF 49 F5 14 DD 9F 4C'\r\n 'F1 14 DD 0F 94 15 DD FF CE 74 D0 9B C2 11 6C 16 78 45 7A 29 87 05 9C C9 61 01 6F 61 F7 C0 CF E4'\r\n '8F 09 73 B0 FB BA AE FB D5 EC DE DF 79 BF 4D F5 14 DD 9F 4A F1 14 DD 0F 92 15 DD FF C1 74 D0 5B'\r\n 'D9 2C F0 BC F4 BF C2 91 1C 0E F0 7B E9 59 1C 06 F0 73 E9 65 1C 1E 70 6A 45 1C 57 F5 F0 A6 05 EF'\r\n '93 70 21 F3 E1 17 B4 08 5B 05 76 E7 A3 2B B0 1B B1 3E DE BD D1 0E 2C C0 38 E0 F8 92 16 B6 06 B8'\r\n 'F4 22 36 94 21 A0 B7 33 04 38 9D 0D 37 74 AD E2 35 AD 22 46 EE E9 40 E6 34 74 39 73 39 28 D0 15'\r\n '1C 0C 70 38 DB 00 16 65 1B C0 09 0C 6D E4 42 87 D1 05 5A 8C 2E 60 6B 3E 72 DF E9 3E B9 6C 25 8A'\r\n '57 0F 46 01 EF 60 14 B0 10 C7 09 1C 43 7B 63 BC D9 A4 1D 38 05 85 CC D3 C4 7D 50 F4 0A 9E 88 F9'\r\n '41 9A 45 EC 55 D1 50 C4 1E 2F 06 0D 1A 76 1F 57 EF 0A 14 7C 4F 05 2A 12 B1 27 03 95 3D 62 AF A9'\r\n '09 A8 D7 45 11 63 21 4F B3 44 EC 80 C2 13 5D C3 FB 02 C5 EF 09 02 85 A4 43 81 42 C3 61 35 01 F5'\r\n '59 C8 3B B2 46 D8 60 D9 B0 77 40 7D 22 47 36 E7 78 43 FD 43 3D 52 CC 53 B4 F3 3F C5 E4 70 3D BE'\r\n 'A9 18 A8 B7 D5 41 AE 08 6D 8E E6 45 B7 A2 D1 88 ED D5 78 4A 45 38 BB 67 03 85 21 3D AC 0E A0 4C'\r\n 'B4 0C 06 A1 26 CB 47 EC 53 DC 15 59 F0 82 25 F9 01 55 9D 0C 6C 42 A8 6D E9 1E DF 13 66 91 7D AC'\r\n 'D0 64 7F 58 3A F9 6A 28 C4 56 B2 C5 BC AE 5C 14 FB 07 58 82 CB 0A 9C 28 7B 03 61 0D E5 A7 2B FF'\r\n '59 5E 14 C0 91 B2 BF CE 6D D0 D4 7D F6 15 E6 B0 9B FA A2 8A 72 6A A2 D5 23 56 93 39 A0 95 4B 98'\r\n 'C3 BA 19 5E EF 14 8E 92 3F 24 7C 5F 78 94 7D 02 4B 72 8C C0 71 8A 4F 10 36 8C 79 9C 24 AC CE 39'\r\n '02 33 E4 CF 2E 7B 55 CE 15 58 05 E7 45 D6 66 EE 13 DD 93 2C 6A 33 F7 B1 1E 8E 8C 44 56 BB 99 DB'\r\n 'BD D9 44 B1 4E 39 44 31 AF 5C A2 58 E1 6C 5C BD 66 EE 8B 15 84 9F 34 EF 80 3A 91 6A 59 D8 24 D6'\r\n '69 8C FB 7C 72 32 BB 67 53 9C 36 70 74 BA D7 CF 71 5A C0 73 D2 8D 14 37 0E 71 49 C0 52 9C 2E F0'\r\n '91 0C 6F AF A2 FC B0 E2 73 28 BE 12 A6 CB 76 62 8A DB 2E FF 78 E9 14 96 03 58 4B F6 D5 98 7E 9E'\r\n 'E6 EE C3 E7 37 B0 95 93 9A BB CF 69 31 A5 AB 98 9D D4 9B 72 CC 76 8E 5F E5 80 CA C1 E5 6C EE 8A'\r\n '91 27 E4 29 02 72 C9 8A F5 4E 12 45 25 F2 89 56 41 AC 28 76 41 56 0E 0B 34 67 CC E3 07 E9 1E CF'\r\n 'CB 1E 91 2E CD E9 03 C7 B3 1C C0 DA B2 8F 11 A6 72 5A C0 16 2C 0B 70 82 F2 93 B9 CA C0 47 A5 EB'\r\n '0B EF 54 7F 3B 94 7F 8C E5 07 4E 91 FD 14 97 B0 85 3B C5 DE 12 C5 C2 BE C2 65 6E 11 3F C5 8E 07'\r\n '0A BE 37 02 85 C3 E6 B5 40 E1 90 38 AD 26 A0 5E 2C E6 29 62 0A 28 26 8B 6B AD 50 A0 D0 5A BE 90'\r\n '0F 83 2A 20 8A 63 A1 90 28 EA 7D 46 4D E2 34 7A 5E 4D A2 A3 22 0A C0 2A 64 09 7B 8A 43 27 51 14'\r\n '87 CE 09 F5 E2 0F 9D E7 94 09 75 BB 1C E5 DC F9 53 5E 19 50 B7 A8 49 1C 3A B7 28 1C 4B 58 44 34'\r\n '19 1D B1 84 A0 75 84 53 63 1E 3F CC F0 F8 3C 4B 0B 9C 28 DD 40 58 9D 4B 03 AC C1 A5 E3 98 95 97'\r\n '4D FE C6 D2 BB A4 C7 AA FD 32 DC 0A EC 9A 4B 0D 4C 97 BD 3E 1E 77 92 5A BA 2F 71 7A E1 D4 E4 00'\r\n '5B BA 52 D5 65 00 68 59 26 02 C7 49 4F CA F0 98 3B E6 B1 A1 74 86 FC 2F 70 E0 C0 EA EC 08 98 20'\r\n 'FB 34 C5 37 11 3E A6 BC EC C2 8F 84 35 39 31 E0 7D 3C 15 5B B9 EF 93 1E E4 09 D3 CA 7D 0D 84 CB'\r\n '67 AF 54 67 F7 6D C8 5B 0A 9B 85 37 B0 AC 79 2B B7 E5 6E 17 C5 6A 15 2F E6 29 F6 44 31 59 B1 54'\r\n 'C5 45 31 D1 AF 45 B1 FA 25 45 B1 80 8F 70 D8 A0 E3 85 A9 AC 3B 30 47 86 D7 E5 58 16 60 9E 98 D7'\r\n '8F CB FE 22 A7 0F 6C 24 DD 54 FE E9 C2 98 DA FB 58 FE C9 C2 7A B2 27 0A 6B B1 0C C0 33 9C 5F 6B'\r\n '37 DB B6 3C 74 5A BB 6F 92 CE A6 78 2B 8E C6 D5 0A 40 65 4A 73 F8 AD DD AC 4B 16 F3 14 F3 2B 2B'\r\n '8A 3D 5F 2C EC 29 A6 5A 5A 56 6C E2 F2 A2 98 75 45 D1 AA 11 3B CF 81 80 E6 E6 3A 02 6B 73 40 C0'\r\n '9C D2 B9 84 35 58 18 60 79 16 04 F8 44 86 CF CB 1B F3 38 45 FA 25 16 06 38 41 ED D6 17 5E 90 3F'\r\n 'AB F4 0C E5 35 13 0E E6 06 6D E3 BE F5 C3 6B 50 09 1C A3 9E A6 84 3C C5 19 3C 9B 35 68 E3 1E A4'\r\n '86 28 00 45 1A 29 8A 7D 7D 96 D7 7D 1B 77 30 BD 2D 8A 5D F2 8E 28 EA 55 3E E4 29 0E 98 8A A2 D8'\r\n '30 95 45 B1 61 92 45 51 D0 AA BC E8 DB C4 7F C1 F0 AE 1A 81 3A 55 CC 53 1C 29 EF 2A 9C 77 B9 B0'\r\n 'A7 38 52 72 88 E2 48 39 AD 58 D4 BF AA 62 71 56 54 96 15 07 C4 45 D6 05 B4 79 CC 63 12 EB CD 5C'\r\n '61 63 F9 B3 A5 7B FC 50 F8 A4 EC 49 CA 9B 28 7B 03 E1 54 F9 2B 70 BD 80 75 B8 AE C0 99 8A 1F C8'\r\n '7B 05 B0 26 D7 15 78 9C EB 06 AC C1 51 B6 75 C5 7A 8C 4D 81 36 14 E6 CE F0 38 2B E6 31 BB EC D3'\r\n '64 7F 99 4D 00 3F 92 BD 2E BB 04 D6 62 17 C0 16 CA 9B 24 7F 13 E5 55 E4 10 81 51 F9 77 CB 7E 49'\r\n 'B8 98 CB DE CE 1D 11 6F 8B E2 F5 8E 68 07 94 91 E5 6C E7 D6 FA DB 90 A7 58 90 14 59 51 FA 5A B2'\r\n '62 EB D7 90 15 B7 D7 A6 6C 1F 74 BA F0 F1 74 8F 4F 49 7F 22 AC C4 F1 01 27 CB 3F 3B E6 B1 A5 B0'\r\n '91 EC 39 84 F5 38 6F 60 1E E5 7F 2C FB 2B AC 0F B0 36 EB 01 CC A7 FC 93 DC E1 ED DD 0E 7F 37 05'\r\n '87 5E 7B F7 0D 33 EF B3 72 8C C6 2D 59 F4 28 CA CA C9 B4 77 B3 6D 28 8A D9 D6 E1 6E 6D EF 66 8B'\r\n '1D 5D AB 98 77 40 D5 57 0C E6 DE 40 56 DC A2 EA 89 A2 0C 17 38 3C D0 FA 1C 36 70 4E CC EB B1 DC'\r\n '21 C0 66 19 5E E7 97 FD 4E C5 B7 92 AE C3 E9 00 F3 71 C7 02 67 28 3E A7 E2 3E 95 AE CC 32 02 F7'\r\n '48 4F 91 FF 55 96 05 98 57 F6 25 5C D8 0E 6E B9 D7 F2 1E D0 21 7E 47 D8 23 E5 EF 08 ED 78 4C 76'\r\n '70 27 C0 31 65 80 BE 2C DA 13 CB C2 29 76 70 75 6A 2C 8A AB BA A9 28 2A F3 AA 62 77 47 AC 0A C7'\r\n 'C6 8E 38 27 E0 D4 74 8F A9 9C 13 30 29 C3 EB 09 AC 09 B0 B9 74 63 C5 15 50 5E 03 D6 10 F8 1A E7'\r\n '04 FC 4C 71 17 15 37 57 71 7B 65 AF CB DA 01 67 4A E7 52 DC 69 2E 77 47 B7 25 CE 88 62 13 14 2A'\r\n 'E1 29 1E C1 FF E6 AA 76 74 27 5D 33 51 CC F3 7D F3 14 C7 5B F3 62 9E 62 CA AD 14 80 5D D2 52 56'\r\n 'CC BE 85 AC D8 17 6D 65 C5 BE 68 2D 8A 7D D1 84 63 01 BD 3B E6 71 9A 74 1B E9 86 9C 2B B0 20 6B'\r\n '04 9C 95 E1 ED 05 E5 FF 5C FA 92 F2 5E 67 4D 80 BB A5 EB 71 EE C0 AA AC 3D F0 69 C5 E7 96 3F 2A'\r\n '7D 8E 93 EA E4 A6 FA 81 28 A6 7A 8E FB BD 53 FC 69 F3 BD 40 C1 17 0B 14 2A 91 1E 28 9C D8 E9 6A'\r\n '02 AA BD 1C 11 97 54 39 9C A9 70 01 75 0C 7C 38 F1 33 94 04 D5 59 0E FF 5C DA 35 50 68 A2 7D C8'\r\n '87 31 5F 94 B7 14 35 EC DF 41 57 0D 7B 07 54 45 39 FC 3B E8 98 FA 80 7A A7 98 A7 18 6E 67 B5 93'\r\n '13 8B 2B CA 37 11 6A 04 F7 9A 3C A2 B8 D7 5C D4 60 6E 73 43 FB 38 50 18 DA 67 81 C2 24 3E 09 14'\r\n 'FA F8 22 50 D8 17 0F AB 1B A8 0F E5 F0 CF C3 67 35 2A A8 1F 42 DE 51 DE 8D FC 8A 32 A0 F6 71 CD'\r\n '40 EF 89 79 FC 42 BA 01 D7 1A F8 54 BA D7 D3 85 6F 70 4F 00 DB 2A BE A5 E2 9B CA 5F 8D 7B 03 98'\r\n '47 3A 9F FC B3 85 8D B8 07 81 85 94 FF 89 E2 CE F3 D2 EE EC 0E 8E 8F 78 6A 74 76 A7 06 2E AC 8E'\r\n '57 43 71 85 D3 E2 63 85 75 85 21 C5 87 75 73 3F 58 DA 2D 07 CE 99 6E 9C 76 67 B7 E7 7A 88 62 ED'\r\n '6E E5 A6 07 9D C3 81 00 2F 0B 1B 71 A2 C0 BC E9 5E DF C9 01 02 0B C7 BC 9E 21 FB 1E E1 A7 C2 64'\r\n '4E 14 F8 26 0B 02 CC AF F6 E6 29 AF 99 E2 F6 CB DE 4E F6 C6 6C BF 8B D9 7C 6A E0 DC 0C 8F 5F 0A'\r\n '0B 08 F7 A6 7B 4C 12 16 E1 F8 81 33 A5 4F B0 5F 60 75 8E 03 78 40 79 CD E5 6F AF F6 3F 93 BE 45'\r\n 'FA 49 7E 1C D6 D5 FD 68 A7 1B B7 41 57 57 A8 5E C5 3C 45 A1 7A C9 8A 5D 9B 14 F6 14 BB 36 9F 28'\r\n '76 6D 5F 6E B2 AE F1 1B D7 5D CA 84 EA A1 4C 1C 50 FD 65 C5 A9 74 2B 3B 06 6D C2 89 03 BF CA F0'\r\n 'BA 28 27 04 BC 4D 78 BB F0 F3 74 EF AF CC B7 FE C0 93 9C 28 B0 85 EC 0B D4 5E 0A 27 0E 3C A8 F6'\r\n '3A C8 7E B7 74 54 F1 77 72 81 81 B3 A4 DB F3 36 94 E6 6E D7 C5 71 3C 67 4B 73 DB AC 83 AC 78 5D'\r\n 'E4 56 4A 73 3F 56 1A CA A9 A6 B9 0A A1 32 77 71 7E 5E F5 15 C5 55 36 B0 98 A7 08 18 AE F0 5C 2E'\r\n '7C A0 62 A0 46 CA 51 CA 39 06 2B 03 EA 96 B0 A7 65 51 32 85 A3 7A B3 39 54 D0 85 31 8F F9 A4 5B'\r\n '0A 0F 65 78 4C 65 09 80 6D A5 EF 11 76 54 5E 21 E9 53 2C 21 70 9F F2 BF 96 BD 88 E2 9A 72 69 80'\r\n '5F C8 5F 82 8F F6 FE BA C2 ED 7D 1D AF C7 6E F1 7B 7A 49 D6 AC 9B AB D9 68 CE A3 9B 9B F9 D0 90'\r\n 'A7 98 EB 58 59 31 BB 22 61 4F 31 BB C1 0A C0 EC 26 2A 00 37 AF F1 A2 D8 26 F3 38 26 D0 1A 9C 13'\r\n '30 7F BA D7 F7 C6 3C CE 91 6E CC E5 04 1E 56 7C 27 F9 5B C9 7F 9B 74 33 CE 09 58 58 71 ED 84 97'\r\n '15 B7 5F F8 8D EC 6F B1 46 C0 8F 78 AA 77 77 37 AF 8F 45 B1 DE 17 44 B1 DE 33 B9 96 DD E3 37 A1'\r\n '91 21 EF 80 9A 2D 47 16 77 07 1A 2D 07 D4 58 51 DC 5A 2E 84 7C 8C FF C9 F5 F9 40 A1 A9 8C 40 21'\r\n 'E9 A3 40 A1 A8 17 D5 3F D4 D7 C5 3C C5 7D 60 BC 1A CE 81 A2 8A E2 B6 F3 81 28 D2 0A 84 3D C5 05'\r\n '5C 48 14 17 F0 15 0D D4 DF 76 BE 0D 14 06 F1 53 A0 30 A5 1F 02 85 EE 7E 09 14 16 77 BF BA 81 FA'\r\n '52 43 82 75 B2 68 69 50 05 E0 2E 33 5D 56 2C F9 54 51 BC 93 6A C2 A5 04 AD C9 25 07 76 E6 D2 01'\r\n '5B A7 7B 7C 26 C3 63 01 E9 5B A4 9B 73 69 81 A7 B9 64 C0 2F E5 3F 20 9C 2B 5C A4 F6 6E 17 7E AB'\r\n 'FC F6 C2 F9 C2 11 25 2C 4B 52 8F F8 3B 59 BC 86 73 FF 67 1A 86 F1 21 CE AB B9 1C 7C 0F B7 DA F7'\r\n '88 62 CE 9F F0 02 E9 11 FF F4 FA 2B F6 0E D5 21 C3 63 2D CE 0E 78 77 65 CC 16 D8 82 A3 07 2E 8E'\r\n '79 FF AD 8A 2B 2A 5D 50 F9 47 64 5F 20 FC 4E 38 94 4F B4 6C 4F 71 07 85 67 58 0D 60 17 B5 D3 46'\r\n 'F6 4E 3C D9 7A BA 5F FC 56 E5 87 C3 3D DD 87 A0 97 78 C8 F5 74 BF 54 9D CF 99 F4 74 3B 7E A1 28'\r\n '36 C2 D4 90 A7 D8 F1 4B 64 C5 75 BE 48 14 FB 70 A9 28 0A 70 0F BB 02 6D CA 05 05 76 CC F0 BA 90'\r\n 'EC 5F 0B 5B 72 EA C0 25 31 AF 8B 09 DB CA 5F 9B A5 02 2E 54 7E 57 F9 0F C9 7F 96 53 04 16 91 FF'\r\n '8A F0 59 E1 18 AE 5B AF F8 BA 8D E6 BA 79 B5 9C 63 ED E5 66 B0 42 14 33 38 CA 34 D0 EF 85 77 C4'\r\n '3C BE CD 6E 80 ED D2 BD 6E C5 61 03 E7 49 8F E2 0A 00 3B 29 EF B0 EC DF 08 6F 93 BD 0E A7 03 BC'\r\n '57 3A 4D ED 17 56 DC 7D D2 BF 72 48 BD DD 02 5C 32 4F B1 00 D3 43 9E 62 01 FE 56 00 B6 5D 4A D8'\r\n '53 9C 10 AB 64 C5 A4 66 2A 16 93 FA 53 56 5C AF BF 8B 62 85 BA B1 2B D0 E2 C2 5B D2 3D DE 9E E1'\r\n 'F1 39 61 7B D9 DF 61 09 80 9D 65 9F 2F FB 22 E9 A5 6A E7 07 E9 BA 9C 2A B0 35 4B 05 FC 56 F1 CF'\r\n '08 67 71 80 77 B9 79 AD 2E E6 29 E6 35 47 56 CC E0 6E 51 1C 5A 6B 15 80 61 AF 13 C5 FD A1 1E 7B'\r\n '00 ED CE 9E 81 CB 84 47 D2 3D 2E 10 7E 27 2C CD C7 09 60 79 61 1B 8E 0C 58 42 79 1D 14 F7 63 86'\r\n 'C7 5B A5 DF E5 CC 81 8B 65 3F 26 AC CF FE FB 60 33 F0 3B 43 E0 48 7E 67 D8 17 0F CA B4 03 1B 12'\r\n 'FB A1 02 F4 03 1B 51 F7 C7 3D 9A 7A 00 FA 03 26 01 6B 48 77 92 EE 28 BC 93 F1 C0 C6 C4 81 78 43'\r\n 'CA AF 5A 06 B9 AF 6E C6 B9 FF 1A 37 37 0C D5 DC 0F CA 43 81 C2 93 DC 16 D4 89 EA 78 D8 3E E3 0E'\r\n '1A E4 36 D3 E7 A2 28 FA 13 3C BA 07 C5 DF 7C 3D 16 28 F8 F6 04 0A 1B 6C 77 A0 F8 4E 43 4D 40 5D'\r\n '16 E5 7D 2F E4 29 36 E1 41 85 FB 2F 2C F7 07 0A 0D 1F 09 14 92 0E 07 0A 0D 47 D4 04 D4 E7 21 EF'\r\n 'F0 6F B7 CA 85 BD 03 EA 53 39 FC 0D F1 4B F5 0F F5 68 31 4F D1 CE 35 C5 F8 2F 2C BF 52 0C D4 3B'\r\n 'EA 00 1B 2A A4 26 71 17 8C 88 E2 2E F8 B4 C6 E3 DF 2B 1D 0D 14 86 B4 53 1D 40 85 44 CB 44 2C 41'\r\n '4D E2 86 F6 1E 77 09 E8 B3 DC 35 C0 D5 FC 8A 1A F8 53 86 D7 C5 84 25 63 1E 97 48 77 15 3E C5 9F'\r\n 'CC 00 9B 15 F5 D8 84 AB 0E BC A2 F6 16 0A 97 2B BF A3 F4 F3 CA 2F 22 DD 43 FE A9 BC 05 0D 76 6F'\r\n '7F 26 63 21 38 E6 C1 AE 86 09 A2 7C F2 14 C5 C5 74 1F 9B 01 ED 94 EE F1 0E E9 FB 63 1E 5F 90 EE'\r\n '29 FD B3 F4 F7 8A 6F C5 61 03 6F 93 BE 57 58 4A F1 EF B3 3C C0 34 E5 35 E5 F4 80 47 15 97 C0 DD'\r\n '3B C4 ED DE 09 D8 03 81 9A 86 A3 85 53 19 E2 A6 32 16 EF 37 79 9F 1A E2 B6 FC 9B A2 43 CD 1E 56'\r\n 'CC 38 F7 C3 A0 5D 81 4A 35 7B 48 61 50 59 B9 60 43 DC 05 90 5D 14 4B 9D 53 14 D5 C9 2D 8A 4D 92'\r\n '9D 1B 60 48 FC 3B CF 6F CC 3B A0 4A 73 4E A0 DD 32 3C 36 E3 5C 80 BF 48 6F 63 2D 80 4B A5 57 28'\r\n 'BE 73 BA C7 1F 84 E7 58 13 E0 73 D2 8B 84 BD 14 5F 5C F9 2F 0A 6F 97 FF 6E DE 6D 80 A7 38 AF A1'\r\n 'EE 53 B6 C9 A2 28 D1 46 51 94 6A 26 CB 30 34 5E 94 59 81 42 51 66 28 0C EA 04 BF FE 1C 1A FF FA'\r\n 'F3 37 7E 58 E5 55 4E EE 8F A1 AE 2E 79 43 9E 22 20 B7 AC D8 40 51 51 14 25 BF 28 1E E8 F2 8A 62'\r\n '5B 15 E5 90 41 BB 08 5F CA F0 78 55 D8 92 67 31 B0 84 74 77 E1 8F 8A 5F 2C 3C 26 EC 1D F3 58 46'\r\n 'F8 01 4B 08 5C A6 BC 95 B2 B7 E6 12 00 9B 73 69 80 F7 B0 64 C0 77 F8 6D CC 30 F7 C1 C1 DB FC B4'\r\n '60 98 BB 3A 46 E0 F6 C4 E5 1D E6 0E C9 EF 44 F9 FF 3C 72 0B 0C 8B 1F 92 2F 07 8A 3F 85 08 14 CE'\r\n 'B2 D7 03 85 33 E8 8A 9A 80 7A A9 98 A7 88 29 A8 18 FF B9 53 E1 40 A1 B5 FC 21 1F 06 55 50 14 A7'\r\n '4E 61 51 2C C0 F7 6A 12 87 DD 0B 6A 12 1D DD A6 00 2C 4B 42 D8 53 9C 69 59 45 71 A6 9D 54 2F FE'\r\n '4C 3B A6 4C A8 A2 72 F8 EF 43 2B 28 03 EA 56 35 89 33 ED 56 85 63 4D 6F 13 C5 43 FA 72 D6 1A F4'\r\n 'A7 74 8F 2D 58 63 60 35 AE 25 6B 2B 7F 1B AE 01 B0 6C CC EB 55 C2 25 CA BB 4B BA A4 E2 8F 0B 8B'\r\n 'C9 DF 4A ED AD E1 49 0A FC 55 FE 74 AE 39 B0 AB E2 22 D7 B0 7D 87 BB FF 55 6A 14 0A 18 28 5C 01'\r\n '76 0D 9B D9 AB 90 28 62 C2 A2 08 D8 CC CB 60 B8 BB 0C EE E0 14 87 BB 62 3F C0 A1 81 F6 11 A6 A5'\r\n '7B BC 3F C3 63 06 87 00 2C 25 DD 53 F8 B3 E2 5E 96 FE 4D D8 92 25 02 3E CC 92 00 EF 53 DC 1D C2'\r\n '72 EA E7 05 E9 7F 79 A9 8E 88 9F 78 7F 70 45 46 B8 0D 59 54 14 6B 59 A2 98 A7 D8 31 77 C8 8A 85'\r\n '2C 21 8A 49 7C 23 8A BD 51 4A 14 CB DB 97 5D 81 2E 4D F7 58 3A C3 E3 2F D2 AB E5 FF 5D F6 E2 B2'\r\n 'F7 92 2E 2F 7F 8C 25 00 AE 90 BD 15 A7 08 7C 45 BA 9B F2 72 70 15 81 1D 38 75 E0 24 4E 6D 64 FC'\r\n '1B 80 D3 2C FF 48 47 CB 70 8C 23 DD D4 4A 15 F3 14 93 28 27 8A 6D 7F 47 D8 53 CC A7 8C AC D8 C7'\r\n '15 44 31 B5 4A A2 55 23 B6 41 14 47 D0 81 30 3A 06 6D CD 01 02 FF E0 00 81 57 D3 3D E6 E1 00 81'\r\n 'AF CA BE 26 E6 71 99 FC 65 64 EF 27 FB 4A E9 F3 2C 00 B0 84 E2 2A C8 FF 92 74 6F C5 AD E7 F6 05'\r\n '4E E6 3D 6D 94 DB 7F 78 4D E2 5B 11 4F 53 43 9E 8E C6 DB 19 96 63 94 FB BF F0 A6 28 60 3A 8E 71'\r\n 'D1 99 B8 75 F0 14 18 E5 8E A9 1F 45 F9 16 5D 14 A5 AB 10 F2 14 C7 4D 25 51 6C 90 2A A2 D8 20 D5'\r\n '78 DD 8F 8A 7F C2 F0 B3 32 A1 DE 2A E6 29 4E 95 F7 14 CE 9B 60 D8 53 9C 2A 39 45 71 AA 9C 51 2C'\r\n 'EA 5F 4D B1 38 2E AA C8 8A 33 A2 22 8B 01 DA 23 DD E3 6B 19 1E EF 12 4E E4 79 0C FC 55 FE FE 8A'\r\n '2F 29 FD 21 8B 0B 5C A5 F8 B2 C2 49 FC 01 20 F0 4F E9 E5 8A 1F 8C DD 95 1D D8 9A 8B 09 6C C3 C5'\r\n '06 1E 97 7F AD DA AF 2B 7F 4D 8E 7A B4 AB D8 2F A2 BC 4C 18 0D 3A 20 E6 F1 41 61 4F D9 3F E2 A8'\r\n '80 0F 64 78 7D BF EC 2F 0B FB C8 FE 97 F0 75 E1 5C BC D1 CF 0E 2C 27 7D 88 5B 12 58 49 ED B7 E1'\r\n 'A8 80 6D 39 6A E0 6F 6A 6F 11 B7 C3 18 F7 8B 8F 35 BC 6C C6 C4 3F 72 7B 4A CA 5F 44 CF 29 0C 37'\r\n 'B5 E3 A2 78 EB BB 8C 6F 17 C6 B8 E7 24 7F 8C 3C 20 1F 2E C2 4D A2 B0 3E A2 A6 FC 33 C2 E3 81 C2'\r\n '33 C2 76 85 41 BD 2B 3A 15 D7 14 97 79 8C DB 78 DF 85 3C 45 ED 52 65 C5 96 A8 2D 2B 2E C9 9A B2'\r\n 'E2 3A 7C 45 2D EC C6 19 C4 3A 80 FE 9E EE 71 B5 74 79 61 27 9E 15 C0 D2 F2 57 8E 79 FC 5B FE 0D'\r\n 'BC A4 80 6F 48 B7 63 DD 80 1F 73 7D 80 03 15 FF 8A F2 7B 09 D7 C9 BE 42 FA 2D 5E 79 63 DD 95 F7'\r\n '1E 47 37 D6 4D F5 7D 51 5C 84 E7 58 8E B1 EE 91 14 55 FB 40 0E 5C 87 8D 95 79 D4 AC 1E 67 3B D6'\r\n '95 A3 91 28 CA 51 97 97 D9 D8 F8 47 E2 B5 8B 79 07 54 03 C5 A0 38 0D 65 C5 ED B5 BE 28 EA 34 88'\r\n '83 04 FD 9C 9B 04 B8 5E 7A 4D 86 C7 0B 9C 24 F0 4D E9 0A C2 FC DC 44 C0 8D 2C 0E B0 4C BA B7 AF'\r\n '14 BE 2A EC 2D FC 43 D8 9E C5 03 CE E5 25 C9 D1 A8 BF 7F D4 6E 3F E1 4E CE DE EF 92 C7 44 B1 45'\r\n 'EE 15 C5 16 3D 2A 8A 6D F8 92 28 B6 61 BA 28 9E F1 57 89 A2 94 19 2C EC 38 77 FC A1 E9 0D 72 80'\r\n 'EE 90 C3 77 F4 68 A0 D0 D7 36 85 E1 15 93 63 82 4B 3A 2C 07 DE F7 DE C9 42 8E 73 AB D1 44 14 77'\r\n '91 66 A2 A8 FF 93 BC 2C C6 B9 8F E6 A6 B8 3E 9E 50 53 DE 70 91 D5 E5 33 31 67 0D 5C 95 EE 71 43'\r\n 'CC 63 55 E1 60 61 45 C5 95 55 5C 7F E9 4D 5C 05 E0 9F B2 DF 25 9C C7 2A 03 D7 2A AE 03 AB 0F EC'\r\n 'CC 2D 0F FC 9F EC AF 29 7E 01 A7 36 DE D5 F7 7E D1 96 66 47 44 51 EA 17 44 F9 61 18 37 E5 78 B7'\r\n '9D B7 C8 8A 16 0E 8A 62 72 FF 70 EF 8D 77 77 8F E6 A2 A8 D3 55 F3 14 B7 8C 16 C5 3C 45 C9 5A 2B'\r\n '00 7B B9 95 AC A8 5E 4B 59 B1 7B DB C9 8A DD DB 46 14 BB F7 2F 8E 1B 74 48 CC E3 66 D6 01 78 89'\r\n '75 05 3E 20 7F 1F 61 A5 0C 8F 0F 0A 3B B2 1E C0 8D CA 2F A7 B8 6A D2 D7 14 37 40 F8 BA FC F3 78'\r\n '63 00 9E 94 7D 1A 67 3D C1 55 E8 57 CE 6F 82 9B F5 6F A2 98 F5 07 BC 40 27 C4 1F ED DF 0F 14 7C'\r\n 'E7 03 85 A2 64 04 8A 1F A1 A9 09 A8 0E 72 F8 CF FD AB 84 33 15 AE F8 4E 81 0F F7 D6 3F 94 04 D5'\r\n '45 0E FF 26 20 2D 50 68 A2 43 C8 87 31 5F 14 77 EC EA 6A D8 7F 1A 52 2D EC 1D 50 95 E4 F0 9F 86'\r\n 'FC A9 3E A0 DE 2D E6 29 86 DB 45 ED E4 8C D8 39 51 BE 85 53 23 B8 AB E7 15 C5 5D FD 92 06 E3 BF'\r\n '05 B8 10 28 0C ED F3 40 61 12 9F 06 0A 7D 5C 0E 14 B6 C8 4E 75 03 F5 91 1C FE CD C7 DB 1A 15 D4'\r\n '8F 21 EF F0 5F 3E 7F AF 0C A8 D5 5C 4E D0 A1 31 8F E5 A5 D7 65 78 DC 24 7B B2 B0 2B 2F 1B E0 40'\r\n 'F9 9F 37 AF 3B 71 1B 01 FB 2A BF 06 0F 47 E0 27 DC 86 FC ED 85 EC 95 95 77 4A B8 96 DB 15 78 5D'\r\n 'FA 43 9E 16 13 FF F3 99 DB 7C EE AB 89 EE 7A 5C 2E 8A EB F1 19 51 EC B6 E7 45 71 3D 4E 17 C5 1D'\r\n 'F8 80 28 2E C2 EE 2C C3 44 B7 07 7B 8A 62 2D 07 B1 43 FE 81 85 74 8F 5B 38 10 E0 B0 98 D7 37 E4'\r\n '7F 4B F8 A6 E2 D6 4B FF 23 DD 4F B8 46 F8 29 27 0C AC AE 76 AA 28 7E B3 74 67 16 8A 23 67 21 81'\r\n '29 B4 4F C2 39 96 EE F1 33 E6 03 B7 C8 7E 3A C3 E3 60 E1 5A C5 55 95 DE 20 AC 28 FB 70 E5 FD 4F'\r\n 'FA 84 B0 0B FB 05 DE 54 FC FE 54 4B CC 33 D9 3D AA 0C FD CF E1 BC 2F D5 12 FE BF F9 69 1E D8 99'\r\n 'B6 EE DC 3C 93 5D 39 7B 17 F3 14 E5 EC 2D 2B F6 7A 34 EC 29 F6 7A 7E 51 EC F5 7E DC 9A 93 E3 F7'\r\n 'E7 3E CA 84 EA A9 4C 9C 70 03 64 C5 B1 96 CA 69 80 0E E1 73 26 F0 4C 86 D7 1B 85 FF 0A 07 A4 7B'\r\n 'EC CA E9 01 2B 49 9F 14 8E 50 3B 5B 85 9F B3 BC 6C 57 F9 D7 14 57 4D FA 30 1F 02 80 0F CA 7E 81'\r\n 'FB 68 8A FB D0 22 81 6F 62 A7 B8 27 B2 C4 80 0E E3 BC A6 C4 BF 9F EE C3 C9 78 D5 4F 14 17 E2 A0'\r\n '62 9E 22 60 6B 40 47 28 D3 7F 55 3D 48 E1 50 A3 E4 F0 5F 55 0F 51 06 D4 AD 61 4F CB A2 54 0A 47'\r\n 'D5 06 72 A8 A0 5F 70 E8 44 4E 11 78 4A F6 6D 31 8F 26 5C 27 FB BC 10 EE 8C C0 B3 19 5E 5F 97 7D'\r\n 'A4 E2 2A 4B 27 CB 9F C6 12 03 87 4A D7 50 DC 26 E9 AD BC 82 80 63 38 E0 A9 6E 8A 1B 45 71 44 0E'\r\n '0B 79 8A F9 8D 93 15 33 BA 2D EC 29 66 34 44 01 98 D1 24 05 E0 4E 37 41 14 5B 62 33 FB 01 7D 28'\r\n 'E6 71 1B FB 03 0E 4A F7 FA 32 E7 0D 1C 25 7F 37 8E 17 D8 93 57 1A F0 86 E2 AA 08 87 A9 BD B7 A4'\r\n '43 CA 7B 5B F6 EA C2 9A B2 AF 57 DC 3F 3C F7 A7 B9 DB DB FF 44 B1 DC D7 44 B1 DC B3 B8 7E D3 E2'\r\n 'B7 A9 51 21 EF 80 9A 23 87 FF 7A 7A 8C 1C 50 E3 44 71 F3 B9 18 F2 31 FE EB E9 0F 03 C5 DF 68 05'\r\n '0A 49 1F 07 0A 45 BD AE FE A1 BE 29 E6 29 EE 14 13 D4 70 0E 14 55 14 37 A6 74 51 A4 15 0C 7B 8A'\r\n '8B B5 B0 28 2E D6 EF 35 50 7F 63 FA 2E 50 7C 07 1B 28 4C E9 C7 40 A1 BB AB 81 C2 E2 1E 50 37 50'\r\n '5F 69 48 B0 4E 11 2D 0D AA 00 DC 87 66 C8 8A 25 9F 26 8A 77 B5 DD B9 84 A0 BD B8 84 C0 14 2E 09'\r\n '70 74 CC E3 E0 74 8F 5F 72 E9 81 1B A4 C3 F2 DF 94 AE 2A 7C 47 F9 C3 85 A7 65 AF A5 F8 2D B2 6F'\r\n '97 1E CA D3 07 38 83 5F 4F 4F 8F 7F 94 C0 0F 09 F8 D9 42 A6 61 1A 3F 2F F0 EA 6E 0E 7E BA 5B ED'\r\n '79 A2 98 F3 46 F6 03 FA 15 C7 09 3C 23 BD 23 E6 71 6B 86 C7 DA D2 23 A4 DF 15 46 64 EF C3 3A 00'\r\n '87 71 5C C0 7F D5 CE 10 E1 18 C5 4D E5 43 2F B0 9A EC A9 6A A7 07 EB 09 5C C0 A1 CD 70 5B F8 5E'\r\n '51 AC EC B4 90 A7 D8 C2 F7 C9 8A 6B 78 B1 28 36 D6 26 51 EC A6 65 A2 FC F1 1B 3B 05 1D 2B CC 22'\r\n '4C 4E F7 58 23 C3 E3 36 E1 26 D9 DF 93 1E 29 AC A3 BC B3 F2 9B EC 3D 39 68 E0 50 D9 BF 66 11 81'\r\n '47 79 DE 01 E7 70 2D 66 C6 D7 62 36 D7 C2 AB FB 39 C6 99 6E 12 2B 45 31 89 CB 4C 03 1D C6 E6 80'\r\n 'A1 0C 8F 0F 09 BF 61 F3 C0 B7 E5 AF 2E DC 2C 4C 88 79 9C C5 1A 03 EB 4A D7 54 FE 38 E9 F7 A5 7B'\r\n '71 F8 C0 07 79 5C 01 77 CA 3F 4A FE DF 38 B4 59 6E 2D 6E 98 A7 58 8B 19 21 4F B1 16 FF 28 00 5B'\r\n '2A 35 EC 29 AE FE 07 64 C5 E4 FE 55 1A 26 F7 97 AC B8 16 37 8B 62 B1 FE 10 C5 62 3D C2 DE 41 B7'\r\n 'A4 7B AC 95 E1 B1 37 47 09 7C 47 F6 7A 8A DB 2E FF 73 AC 1A 70 BC EC C3 15 97 22 FC 96 55 03 9E'\r\n '53 FC 68 61 A2 E2 C3 D2 B3 39 AF D9 6E 8A 6B 8A 79 8A 29 CE 95 15 93 B9 47 14 67 D3 83 0A C0 B0'\r\n 'D7 8B F2 7F F0 62 8B A0 EF A6 7B FC 20 C3 E3 0B BC 36 80 3B A4 53 E5 DF 2A AC AF BC 47 85 11 C5'\r\n '4D 90 1E 23 7D 17 2B 01 FC 8E 33 02 D6 96 7D 84 DA E9 C3 6F 9D E7 00 19 07 AC CD 6F 93 81 7D A9'\r\n 'E7 62 1B 53 DF 0D CD 38 60 3F DA 81 FD 89 F7 E0 01 8F F8 08 9E 44 88 8F E2 4C 20 3E 86 33 8C F8'\r\n '38 6E DF C4 BD 18 1F 37 F2 01 F7 A3 91 EC A2 78 F0 BD CE F2 9C 70 F5 FB 42 94 1F 37 72 EE A0 37'\r\n '69 FA D0 79 6F 90 7E ED E8 65 51 04 6E 67 E0 2F 38 38 68 FA DB 79 F3 F2 49 BD 5C C8 76 B1 0E D5'\r\n '43 D6 C5 FD D2 3E 64 29 C4 55 21 CB CA 7D BE 3A 64 47 A8 F7 84 EC 27 A6 1E 0D 71 81 1A D2 54 32'\r\n '6C 8F 31 B5 76 D8 9A BB 1F 72 86 AD 05 B1 4B D8 B6 BA DF FD 85 2D CD FD 60 2C 6C 0F B9 5F 1B 85'\r\n '6D 1D 2F 85 DE 61 6B 4B 0D 6C 47 EC 13 B6 F6 C4 BE 61 DB 21 DC 49 1C 10 B6 47 DC 57 B4 61 FB 8C'\r\n '9B 70 48 D8 1E 75 5F 74 84 ED 20 F5 F0 B0 ED A2 1E 89 71 10 47 85 ED 71 E2 E8 B0 ED 76 EF F1 C3'\r\n '76 97 7B D3 12 B6 A7 DD 33 77 D8 F6 12 27 85 6D 1F 71 72 D8 F6 13 A7 84 ED 80 7B 52 40 BB EE 76'\r\n '13 B6 43 C4 99 61 7B C6 6D FE B0 1D 21 CE 09 DB B3 C4 05 61 3B 4C FF 42 F8 89 F7 C2 4E 5C 86 EA'\r\n '10 97 87 ED 18 F1 FE B0 3D 4F 5C 11 B6 17 89 AB C3 F6 12 71 4D D8 7E 66 29 D7 86 59 CA E3 34 81'\r\n '7E C9 A6 D7 87 ED 49 EA 87 C2 B6 87 B8 23 6C 6D F8 51 C3 8B EE 4D FF F3 77 20 6B 8D BB 33 2F 89'\r\n '78 8A 65 3C 26 2B 16 F9 39 51 3C 4D 2C BF C3 B2 90 FA 3F 0A DA 22 62 39 F8 97 3C 33 0D 2B 02 77'\r\n 'C8 B9 73 05 6E 18 56 05 EE A6 CE 9D 27 70 C3 B0 34 50 F0 65 53 AF 50 F7 2B AF 40 BC D7 9C 8A F4'\r\n '86 95 81 DB F7 9A 3B 70 C3 F0 40 E0 F6 BD E6 0D DC 30 2C 0B 14 7C D9 D5 2B D4 8B A2 B0 AE E6 FF'\r\n '43 0F 7A BB B0 87 F0 C9 98 C7 2F 84 97 89 6B F1 1E E4 BC C7 A2 C2 35 C2 DD F2 3F 45 7C 30 62 C5'\r\n 'CE 7B FC 52 BA 97 F4 5A 61 23 5E 4B C0 3D F4 AF C3 09 76 DE 63 6F E1 1D C2 AF E4 3F C5 21 AF 77'\r\n '45 59 1A F1 14 05 28 C2 19 AE 8F AF D1 ED 81 82 EF 16 65 40 DD 26 87 2F 6A D1 40 21 EC 56 85 41'\r\n '7D CD BE 40 8B 9F F7 B8 4E B8 57 F6 BB A4 FB 10 37 A0 0D E1 37 31 8F 4F 0B 4B C8 7E 9A 4D 6F 74'\r\n '7D 2E 8B 78 8A 0E B7 70 D1 36 FE 67 A3 55 E4 78 32 0D DB 02 B7 5F F2 CA 81 1B 86 ED 81 DB 2F 79'\r\n 'D5 C0 0D C3 A6 40 C1 57 5E 03 80 DA AA BC CC 8D 56 49 91 DE F0 50 E0 F6 BD 56 09 DC 30 EC 08 DC'\r\n 'BE D7 6A 81 1B 86 CD 81 82 AF 82 7A 85 3A 2B 0A 6B 49 16 05 B4 AF 70 5F CC E3 06 E9 6F A5 FB 51'\r\n '6F C2 00 84 BF C5 3C 1E 13 7E 27 DC 29 FF 46 E1 7E D9 4B 49 8F 10 FE 8E 09 24 01 3F E6 50 36 BB'\r\n 'C9 2E 8F 78 8A 89 7D 24 2B CE 82 0F 45 71 16 3C A5 00 3C 26 D4 E3 D4 36 C7 17 A7 41 A0 F8 99 7A'\r\n 'A0 50 84 3A CA 87 AA 2F 87 AF 6D C3 40 21 E9 CE 40 21 A9 AE 92 A0 4A 73 C0 A0 9B 84 57 62 1E FB'\r\n '4B 1F 90 3E 48 DC 82 77 1E C2 CD E7 3D 0E 10 96 11 FE 40 FF 56 BC E9 3D EF 71 8B B0 AC F0 90 FC'\r\n '5B A9 B7 E1 6D B5 F0 70 CC E3 8F C2 72 B2 97 27 3E 14 B1 9F 62 1E 07 4B 3F 23 BD 4D 7A 08 71 3B'\r\n 'B6 94 F0 48 CC E3 CF C2 0A B2 FF CD A9 EF F0 87 6B C4 53 94 A7 2D CB B3 23 5E EF F6 81 82 AF B5'\r\n '32 A0 DA C9 E1 2B DC 21 50 08 6B A3 30 A8 5F D8 27 E8 F6 F3 1E 2B 0A 9F 95 7D A8 74 25 E2 C3 58'\r\n '1C 9E 4A C0 61 D2 3B 84 47 63 1E AF 0A 7F 60 17 3B 5D 17 BF D2 04 5A F9 BC C7 87 85 C3 85 CF C9'\r\n '3F 92 FA 51 EC C7 98 C7 AA D2 8F 08 9F 97 FD 1F EE 57 E0 A3 B4 EF C2 13 69 CC E3 28 E9 6A C2 17'\r\n '64 BF C2 A1 3C E6 CA B0 2A E2 29 3F 42 0E E8 77 0A C0 16 FF 56 14 5B 3C 5D 01 D8 E2 7B 02 DA 87'\r\n '85 7C 2C 5E D6 7E 81 42 3B 03 02 85 8D DB 5B 4D 41 8D E6 88 40 5F 8C 79 DC 25 FD A7 74 B2 F4 39'\r\n 'CE 0C 38 86 FA 71 B4 25 AC 2E FC 2B E6 F1 25 E1 E3 B4 3F 11 B1 14 E1 DF 31 8F C7 85 63 65 7F 99'\r\n 'FA 49 54 4E F8 C4 79 8F A9 C2 71 C2 FF 71 C8 BB DD CC 1E 88 78 CA BF 80 C2 A3 6D F7 7F 8E E3 D1'\r\n '9C 67 A6 61 6F E0 F6 07 E3 D8 C0 0D C3 BE C0 ED 0F C6 F1 81 9B 7F 8A 3C 50 F0 8D D4 00 A0 F6 28'\r\n '2F F3 38 1E A3 48 6F 78 3A 70 FB 5E C7 05 6E 18 F6 07 6E DF EB 84 C0 0D C3 EE 40 C1 37 4A BD 42'\r\n '5D 17 E5 38 59 14 D0 57 62 1E FF 27 7C 52 F6 1A C2 43 6C EB 60 7C 94 13 D9 80 57 CF C8 E1 C7 B7'\r\n '37 E2 1D 50 07 15 C3 3F 10 23 8A FD B6 90 43 3E F8 9F 32 87 95 EF 0D 8B 02 B7 6F 30 4B E0 86 61'\r\n '49 E0 F6 13 4E 0C DC 30 CC 0F 14 7C A6 5E A1 EE 55 5E 66 99 23 8A F4 86 C5 81 DB F7 9A 10 B8 61'\r\n 'B8 2F 70 FB 5E B3 06 6E 18 16 04 0A BE 90 7A 85 3A 2A 87 4F 7A 56 0E A8 C3 A2 B0 BE C6 7A 83 5E'\r\n '17 3E 75 DE E3 44 61 2D E1 7B BC 68 0E 61 C3 50 03 6F C4 3C 4E 92 7E 5D BA B6 F4 70 7E DE 01 EC'\r\n 'C7 A7 61 60 43 9E 68 87 71 77 A2 1F 38 59 D8 9F 7E E0 1B 31 AF 6F 0A 47 30 1F B8 57 71 03 18 F7'\r\n '4C C4 A6 50 03 EB 0A DF 8C 79 7C 5A FA 5F E9 C9 9C E2 11 BF 89 23 9E F2 4F 6A B0 22 47 E2 8B 5D'\r\n '20 50 F0 25 29 03 2A BF 1C 7E 75 0A 06 0A 61 51 85 41 15 62 9F A0 9D 85 27 62 1E 97 4B 5F 94 DE'\r\n '27 6D C2 A9 C2 7A C2 3F 58 5B E0 1B D2 FB 89 CF 46 EC 64 CC 63 48 BA BE 70 9A F0 35 0E EC 68 7C'\r\n '4B 4D E5 C0 BC 7A 43 0E BF 99 F6 45 BC 03 6A 2D 77 D2 D1 FF EC FE 92 8A F4 86 75 81 DB A7 96 0E'\r\n 'DC 30 6C 08 DC 7E 4B 95 0D DC 30 AC 0E 14 7C C5 35 1C A8 07 95 97 B9 FB 4B 29 D2 1B D6 07 6E DF'\r\n '6B 99 C0 0D C3 C6 C0 ED 7B 2D 17 B8 61 58 13 28 F8 4A A8 57 A8 93 72 F8 A4 13 72 40 BD 2E 0A EB'\r\n '74 56 12 B4 81 F0 54 CC 63 58 FA 80 B0 0B F1 39 EC 36 61 44 F8 3E 57 0E D8 50 BA B0 F0 52 CC E3'\r\n 'CB DC B5 C0 83 B2 BF 25 FB FD D2 33 84 D3 39 A4 63 FE D7 E0 11 4F F9 FF 39 CB 8A 13 EC 3D 51 9C'\r\n '60 E7 38 AF 63 11 7D DC BC 3A 92 A9 F8 AD 6C E0 C3 44 4F AB 29 A8 14 39 FC 3A D7 08 14 92 6A 05'\r\n '0A 49 C9 EA 09 2A 55 0E BF 4C 35 03 85 A4 DA 81 42 52 75 25 41 C5 44 61 CD C2 D9 81 1E 12 36 12'\r\n '9E 8E 79 9C 29 7D 82 F8 7C C4 66 09 57 08 CF C4 3C DE 22 FD 89 74 82 F4 9D C2 AE C2 C3 C2 5F B8'\r\n '2A C0 44 EA 17 70 8B 10 36 16 9E 8D 79 9C 2D BD 90 DF 18 BD E8 FE F4 D6 0A D1 96 66 CF 8A F6 30'\r\n '7B 51 B4 A7 D9 4A D1 11 66 EB 45 C7 9A 6D 15 1D 67 76 48 74 8A D9 DB EC 87 ED 9E F7 78 44 38 27'\r\n 'AE 0D E3 04 66 95 9E 4B 7C 09 EB 25 6C 2A 7C 27 E6 F1 59 E9 A3 C4 E3 11 7B 37 E6 31 BB 74 33 E1'\r\n 'DD C2 99 5C 8A 97 DD E2 9D 8D 78 8A 95 6B CA 95 7B 39 BE 15 9A 07 8A 7F 41 40 19 50 CD E4 D0 45'\r\n '1B 28 FE 6C 44 61 50 CD D9 17 E8 3D C2 E7 84 EF C5 3C E6 90 6E C0 F3 FF 95 88 CD A3 06 BE 1F F3'\r\n '18 E3 5A 01 DF 92 BD 85 F0 01 E1 E7 8A 3B 26 7D 9B 30 A7 B0 BB F0 4B 0E E9 55 37 F2 AF 44 31 BA'\r\n 'AB 6C 1D F4 33 B6 02 CC 75 DE E3 39 E9 22 D2 23 79 B7 01 B6 94 7E 5E 78 4A 38 5F B8 4A D8 4D D8'\r\n '8A F8 1A 1E BE D9 0F F0 05 E9 0F 62 1E 17 48 E7 16 2E 24 BE 1E B1 3C C2 D6 C2 F4 98 C7 17 A5 33'\r\n 'A8 DF C0 5B 88 F3 1E 5F 12 E6 15 DE 2B 9C CD A9 BE E9 56 E8 ED 88 A7 FC 21 82 AC 38 37 3E 13 C5'\r\n 'B9 F1 05 97 F0 CD F8 B9 71 20 92 A9 F8 CB FD C0 87 EB F6 8C 9A 82 EA 2A 87 DF 2C DD 02 C5 FF 4F'\r\n '3C 50 48 EA AC 9E A0 D2 E4 F0 5B A7 7B A0 F8 7D 7E A0 90 D4 45 49 FC D0 43 14 D6 24 CE 0E B4 AD'\r\n '30 16 F3 78 5C 7A 91 F0 53 DA 4F A0 BF F3 1E CF 4B B7 93 3E 29 5C 29 8C 0A 33 B8 5A C0 C5 D2 B7'\r\n '0A 07 BA CF 64 F1 A4 CA DD 00 7C 59 F6 7C C4 93 78 22 A7 1D F8 8A F4 20 C6 03 97 48 7F 18 F3 D8'\r\n '5E FA 23 EA 53 78 7E 3B EF 31 BF F0 55 61 07 E1 AF AC C9 5B F1 9B E3 5C 16 C2 AB DF E5 F0 B7 C5'\r\n '77 22 DE 01 F5 08 EF 89 6F FD E7 3E 3E 58 91 DE B0 2B 70 FB D4 A1 81 9B 7F 88 31 70 FB 9B E3 F0'\r\n 'C0 0D C3 C3 81 82 6F A0 86 03 F5 A8 F2 32 EF E3 43 14 E9 0D 8F 05 6E DF EB B0 C0 CD FF 9B 2A 70'\r\n 'FB 5E 47 04 6E 18 76 06 0A BE 41 EA 15 EA 2F 39 7C D2 9F 72 40 FD 26 0A 6B 01 56 12 F4 E3 98 C7'\r\n '8E D2 4B 85 AF 09 4F 13 2F 62 87 13 2F E1 E4 CD 82 26 12 B3 70 A7 BF 47 9A 94 C5 DD 61 45 61 8D'\r\n '90 E6 CF C2 F1 1B 69 C1 2C 9C 69 4C 94 FF C7 96 28 62 5F 25 2D E4 AC 17 45 61 FD 84 B4 B0 A3 B9'\r\n '49 6F 71 2D 7C 21 8A 4B F4 56 51 A4 7D 29 CA EF 87 49 8B B8 8E BF 26 2D E6 AC 3F 91 96 72 69 79'\r\n '44 91 F6 8B 28 02 7E 15 CD 89 CD 43 5A CE 59 FF 26 AD E4 E8 0F A4 55 1C 7D 9F 34 D9 B5 F0 81 28'\r\n 'AC 69 A4 A9 AE E3 CE A4 35 DD 78 CF 8B 22 B6 8B 28 62 5F 23 AD E5 AC 97 44 61 FD 94 B4 B6 A3 FD'\r\n '48 EB B8 16 2E 8B 62 E8 75 45 91 F6 95 28 62 FB 92 D6 73 1D CF E4 85 D5 30 8B 7D 43 53 23 E7 FD'\r\n '99 B4 99 4B EF 2F 8A F4 AB A2 08 F8 4D 14 33 FF 83 B4 95 B3 FE 43 DA CE D1 1F 49 3B 38 DA 93 B4'\r\n '87 A3 D3 49 A7 66 E1 B7 E9 33 48 A7 39 FA 31 E9 87 2E E0 02 E9 47 8E 5E 21 FD D6 D1 EF 49 BF 73'\r\n 'F4 BE 04 0B 27 0D 4B B0 85 09 56 80 3F 32 99 9A 60 50 05 45 C7 24 58 61 D1 71 09 96 5F 74 7A 82'\r\n '15 22 BD C7 D1 4E A4 EF 25 D8 C5 04 AB C9 AF 6E 40 4B F0 5F 56 00 D6 A2 7E 3F C1 6A 13 CF 25 58'\r\n '49 DA 3F 48 B0 3A D4 C0 52 D4 E9 09 56 9A 78 21 C1 CA 10 D1 4E 59 E2 A5 04 2B 4E FC 22 C1 CA 11'\r\n 'BF 4D B0 F2 C4 2B 09 36 FF A6 85 12 4B 24 DA 6F 37 2C 4B 62 B9 44 6B 96 68 E5 13 AD 7A A2 FD 2A'\r\n '43 73 F7 6A 95 68 0D 6F 58 98 86 76 89 D6 00 34 C1 D3 05 37 BD 35 2D D1 4A 26 72 9F 39 BA F0 A6'\r\n '0F 00 BD 57 01 DD 12 6D 91 AC A0 A5 14 0B BA 54 D6 EE 89 76 9F 62 41 CB 28 00 74 1A 68 12 E8 D4'\r\n '44 5B 85 D1 32 76 25 47 0D DC 76 DD C2 11 8C B7 72 A2 25 80 26 7A FA DA 0D 8B 24 80 56 49 B4 B6'\r\n '89 96 28 07 D4 43 0A 07 DD AE 98 AA 2E 26 AB 62 A0 B6 2B 06 74 34 68 82 AF C6 18 D1 94 44 CB A6'\r\n 'D8 16 89 B6 43 B1 A0 63 15 00 FA 39 68 16 4F C7 C9 DA 32 D1 1E 56 2C 2A F9 85 02 40 C7 2B A0 4D'\r\n 'A2 65 57 BB A0 13 64 C5 C8 72 C8 0A BA 16 93 66 DA 03 9C 3C 70 35 8B 01 5C 03 64 CB 0F D2 5E 21'\r\n 'D1 D6 D1 0E EC 8C 29 46 2A BA 8A 60 28 0F 73 C2 5E A1 87 1D 81 42 CB 3B 39 36 AF 72 B2 3F 4F BB'\r\n '2A BF 8A 53 5D 94 E1 55 5A E0 43 DB B9 94 04 F5 88 9A 02 ED A6 98 AA 2E E6 11 E5 57 75 FD EF 0C'\r\n '14 FA CF AD 7C A8 47 95 0F 3A 91 55 A8 E8 CA 3F 49 14 E5 EF AE 56 5B B8 71 F4 08 14 7A EC 19 28'\r\n 'E4 EF 52 1F 2D 5C 8F 8F 06 0A 3D EE 52 37 50 79 D4 39 E8 64 75 03 7A 99 6B E4 E9 14 59 B1 88 5F'\r\n 'CA 8A 95 7B 4C 2D 80 E6 55 0B E8 65 AA 62 41 93 64 45 6F D3 64 05 DD C8 C5 02 DD C4 C5 04 6E E0'\r\n '62 01 D7 73 F1 80 51 66 55 72 73 9B CE AC 4A 6E FE 33 44 31 FF 7C 0A C0 C0 BE E2 68 3C 9D A9 00'\r\n 'D0 C7 39 30 4F 67 C9 8A 91 7F AD 58 0C 37 BF 5A C0 18 67 2B 00 74 8E 28 C6 58 40 01 A0 5B 39 5C'\r\n 'D0 2D 1C 26 70 33 87 09 DC C6 E1 03 1F 67 55 2B BB E2 A3 8D E3 81 42 EE 13 1C 88 57 05 D9 A2 A7'\r\n 'D7 6E 58 36 52 1C 2A C5 CD 3C 29 17 3F 63 7A 73 01 2B C7 97 B3 97 9A F3 EA 89 40 A1 AB C7 02 85'\r\n 'AE 9E 54 57 50 85 D4 15 68 51 1E 53 7E BF 87 6E 78 2B 68 58 14 69 C5 14 00 BA 83 13 05 7D 98 13'\r\n '03 3E C4 89 02 B7 73 E2 C0 97 D9 5F 95 F8 05 53 98 9D 78 B5 9B 5D 7B DA 47 31 7E 84 77 05 0A 19'\r\n 'B7 28 03 EA 29 65 80 DE C6 01 F8 DA FD AB 00 D0 DB 65 45 9A DD F0 56 5E A4 1C 11 E8 A3 1C 29 70'\r\n '17 47 CA 2B 8E 23 04 EE 61 B3 55 DD 40 6E 65 5B 9E 16 11 45 C0 5E 05 B0 5F 59 41 23 37 3C 45 BF'\r\n '77 B0 5F 4F 8B 8B A2 DF 2C 0A 60 99 D9 25 E8 13 1C 02 F0 31 0E 09 F8 38 87 00 7C 8A 58 0D 35 A1'\r\n '1D D8 87 DD 24 BB 7F A0 71 2F 5D A0 7B E8 02 FE C9 DB 0B 76 76 6A A2 B5 76 AB DF 97 B1 D5 5D EC'\r\n '75 F9 CE C6 77 C6 D3 4C 82 61 1F 1B 01 EE A7 C6 B5 70 80 1A D8 8F DB 26 D5 CD 17 F3 EC CF C2 A7'\r\n 'C6 4F BA A7 39 6B AF 6E 67 17 9E D6 C0 A4 B2 78 DA 57 C9 7E 0D F7 29 1C AA A6 62 40 8B 2A 13 F4'\r\n '49 B5 EE EB 74 22 50 A8 CF 7E 25 43 15 53 06 68 2D B5 03 5A 91 65 4D 75 97 74 9E 1B 3E 00 74 90'\r\n '46 E0 8F B4 01 6A D2 EF FA 81 81 0F 6A 70 E0 C3 6B 48 E0 C3 EB 0E F5 08 7A 40 E3 00 FD E6 BA EF'\r\n '1C F4 5B 51 5C 67 D5 6F F8 00 D0 6B 4A C3 64 0A 6B 74 A0 B7 88 62 52 D7 15 00 FA 0C D7 1F F4 30'\r\n 'D7 1F 78 90 EB 00 3C C4 75 00 8E E2 F0 6A C4 2F 92 DA 9C B7 57 55 D8 9F A7 D9 39 6F 4F CB B0 13'\r\n '4F 47 28 D3 5F 16 23 39 B1 4C F5 54 E0 43 AB 75 D4 2A 54 0E 35 05 5A 56 4D 81 56 55 5F A0 E5 64'\r\n '45 E5 73 2A 16 B4 AE 5A 00 AD A6 58 D0 DC 0A C0 7A 54 50 1A E8 68 F5 ED EF 28 63 34 2E AF C6 06'\r\n '3E DE EA 03 1F 5E DF 5D F7 7D 80 96 57 6B BC 4F AA 0F D0 64 F5 0C 9A 22 8A C5 B8 A2 34 D0 1B D7'\r\n '7D 2C 16 E3 56 B5 00 7A 53 56 14 A2 88 AC A0 CF 71 5D 40 8F 70 3D 80 CF 72 3D 80 47 B9 4E C0 61'\r\n '1C 5B 4D 57 12 BC 86 72 DC 99 6A 77 A0 D0 D2 41 EE 1C AF 8A B3 2B 4F 0F C9 8A 49 E7 BD E1 AD A8'\r\n '4D 25 0E C0 D3 3F 78 C5 D6 74 D7 6A 5D 37 A7 FF DD B0 7C 32 B4 71 07 FD 7F 9F 24 21 EB 3A DE 36'\r\n '2E 5B BB 83 A0 B9 4B FD 07 03 0A 52 7F 09 D4 B9 44 1B AE C1 FA 22 BF A9 69 79 75 58 83 04 2D A1'\r\n 'A1 83 26 68 BC 68 AA 84 C6 0B 9A 28 2B 06 50 52 56 D0 17 59 46 D0 63 2C 23 F0 79 96 11 F8 02 CB'\r\n '08 2C C9 66 6B B9 FD FA 0C 3B F3 74 3C C7 54 2B 7E 0B DC 13 28 B4 58 4A 19 50 47 94 01 3A 41 31'\r\n 'FE 00 9E C8 59 64 AA D2 CA 80 7A 56 19 3C C8 39 C8 5A AE D4 49 37 7C 00 68 19 C5 22 ED A8 62 41'\r\n 'B3 2A 00 83 29 A5 34 D0 D2 A2 18 54 36 05 80 BE C2 19 83 BE C4 19 03 8F 73 C6 C0 97 39 63 60 59'\r\n 'F6 50 DB 0D FA 39 F6 E0 E9 64 8E B8 76 FC 4C 9A C4 D9 64 AA 29 81 0F AF A9 81 0F BD 95 53 6B 50'\r\n 'A9 37 7C 6B A0 F5 78 39 7A 1A E5 20 6B BB F1 FE A1 58 D0 7C B2 A2 85 3F 65 05 7D 9D 43 04 7D 83'\r\n '53 00 BE CA 29 00 5F E3 14 80 C7 38 DE 3A FE 0A 64 96 A7 F5 D9 99 A7 6F 32 01 F4 04 13 80 27 D9'\r\n '20 F0 14 1B 04 BE C1 99 D4 8D 3F 3E 4F E3 4C 32 D5 F3 6C DC AB 0A 6C DC D3 BF 78 15 FC 77 67 CF'\r\n '50 13 BE 18 D3 D5 84 57 33 03 85 39 3E 1B 28 A4 56 54 9B 50 2F A8 27 D0 BF 64 45 78 7E 96 C4 D3'\r\n '02 A2 48 FB 5B 01 A0 67 38 19 D0 B3 9C 0C F0 2D 4E 16 78 9A 93 05 BE C8 66 EB B9 51 57 62 96 A7'\r\n 'B3 38 8A 7A F1 11 CE 09 14 1F 15 03 85 F6 5F 52 3E 6F 59 CA 07 2D C8 B1 D4 73 E1 FF C8 0A FA 3F'\r\n '51 A4 15 52 00 E8 7B 1C 19 E8 BB 1C 29 F0 6D 8E 10 F8 0E 47 08 9C 84 F7 82 59 1A BB F7 98 BF 5E'\r\n 'B7 08 A9 FF 57 A3 67 C8 01 F5 9B 1C FE 5F 8D 9E 25 07 D4 EF 72 F8 7F 35 7A 8E 1C 50 77 8B C2 3A'\r\n '4F B4 2B F6 2D 47 D8 C4 95 E0 38 27 E6 69 55 59 B1 AB 5F 96 15 F4 6E AE 69 93 F8 E5 3A 97 55 C9'\r\n '54 AF 28 8C 77 16 25 83 BE AA 18 5F B9 64 39 A0 5E 55 38 68 75 59 51 AE B9 7C 10 F7 34 45 56 A4'\r\n 'DD 2D 2B 68 3A 2B 07 7A 8E 95 02 BE CF CA 01 3F 60 25 81 AF B1 D9 A6 6E B0 A9 6C C0 D3 AB 3C 48'\r\n '9B C6 0F D2 7B 38 A6 A6 F1 8B F6 19 CE 29 53 CD 0B 7C 78 1D 0A 14 FA AE A1 06 A1 5E 57 37 A0 35'\r\n '65 C5 90 EF E1 38 3D 9D 27 8A B4 5A 0A 00 FD 90 A3 07 3D CF D1 02 63 9C 05 30 83 B3 00 D6 66 68'\r\n '33 F7 E4 37 9F 0D 78 5A 47 56 2C CB 1B EC D7 D3 BA B2 62 D0 6F CA 0A 7A 42 14 A5 AF A7 00 D0 FA'\r\n 'A2 98 FF 02 B5 0B FA 3D 6F B8 9E 9E 54 1A E8 EB AC 47 B3 78 05 5E 60 05 32 D5 D1 40 61 36 0B D5'\r\n '14 D4 29 E5 83 36 50 5F A0 3F A8 03 D0 86 B2 A2 34 F7 2A 0D B4 91 AC 68 6C 91 AC A0 17 59 25 D0'\r\n '8F 58 15 E0 C7 AC 12 F0 02 AB 06 FC F3 26 46 E1 DF 39 A5 E1 B0 84 4A CC 54 7F 05 AA 1B 0E 85 20'\r\n '12 EA 9F C0 D7 1D 57 66 E0 83 BA C6 4F 5F BC BA CE CF 64 3C BD 97 B5 68 EE CA 8D D7 A2 1B 3E C3'\r\n 'AB E7 03 1F E6 F7 62 E0 83 DA 1B 28 CC E7 CE EB BE 6D A8 B7 58 27 4F 8F 28 DF 3F E7 CD 57 86 57'\r\n '0B 03 85 2A 2D 08 14 5A 3B AD 26 A0 1A AB 61 D0 25 6A CD 5F 8B 8B 95 E1 55 13 85 41 9D 51 32 E8'\r\n '52 65 F8 7D 7F 9F 32 BC 7A 3A 50 E8 F1 47 2E A3 57 67 95 0F DA 54 AD B2 BB EB BE 62 A0 6F 2B 00'\r\n '37 80 66 0A C0 0C 96 28 00 F4 3E 51 B4 DB 5C 01 A0 9F 70 89 41 2F 71 C9 81 9F 71 0B 00 3F E5 92'\r\n '03 97 32 AB 85 5B 93 15 1C 77 8B F8 FB 9D B5 81 C2 9C 56 06 8A 27 12 67 D1 22 BE 0A EF 70 64 F2'\r\n 'B1 63 4F 97 29 C3 BF 01 FA 9D 37 B1 16 F1 55 C0 9B B8 E5 81 1B FF BD 5F 0D FA 85 78 57 0D 42 B5'\r\n '54 83 A0 AB 94 E1 DF 81 3E 10 28 FC F7 98 F2 FD 1B A6 56 4A 82 7A 4F 4D 81 1E 54 8C 2F FD 32 CD'\r\n '1B AF F7 15 83 57 6B 65 F2 E6 24 8A CA B6 15 45 DA 17 2C 27 3F C8 61 F9 80 5F B2 9C FC 74 8E E5'\r\n '05 3E C7 61 B5 8C D7 F0 25 76 99 A9 36 05 3E 44 6E 0C 7C 50 9B 03 85 0E 4F 06 0A 7D 9E E3 F8 BC'\r\n '6A C7 91 78 BA 5E AD F9 02 6E 50 86 DF D7 87 03 85 FC F6 4A 82 FA 40 4D 81 A6 8B A2 32 1D 14 00'\r\n 'BA 9C 65 69 E9 9E 03 EF 17 C5 3B E1 AD 6A CF 97 63 4B A0 D0 FA 0A 85 41 FD C4 ED EC 69 86 5A 07'\r\n 'ED A8 D6 41 57 2A 16 AF 98 02 B0 9D 7F 56 1A 68 27 C5 A2 97 55 8A 05 ED 2C 2B 7A 7B 40 56 D0 6F'\r\n '59 7A D0 AF 58 7A E0 37 5C 12 7E 26 C5 25 02 76 61 56 2B 57 AB F3 EC CC D3 07 59 B6 56 F1 77 C5'\r\n 'EB 02 85 D7 87 0A 03 ED AA 64 D0 34 51 0C A4 9B 28 7A FF 48 B1 13 71 DA B3 63 BE CD 62 C7 C0 EF'\r\n '38 20 E0 0F 1C 20 F0 6F EE FD FF BE 17 29 CD 4F A1 5B BB 93 73 09 8F 44 4F 17 F3 A0 F4 74 3A 3F'\r\n '9B 6E ED 3E 9B FE 91 8D 81 FE C4 C6 81 AB 59 80 36 AE DF 7E 1C 8D A7 BF D0 0B FA 33 A3 81 DF 5D'\r\n '43 D7 C0 6F 81 11 E0 7E 2E 59 DB F8 86 EA CE 44 AF 3E E6 34 3C DD A7 18 BF 69 2E C8 01 D5 43 E1'\r\n 'A0 17 65 C5 4E E9 29 2B E8 1A 8E A9 AD DB 34 6B 45 B1 69 1E 62 6D DB C6 6B BB 4D AD 7B 75 20 50'\r\n 'F8 6F 2F 35 05 F5 0B F7 82 A7 97 D4 17 E8 83 6A 15 74 9D 28 16 F8 13 05 A0 C4 57 95 06 BA 5E 01'\r\n '98 75 6F B5 CB 8F CD 44 F1 DA A0 00 BC BE BF E6 87 D1 CD 9D 7F 57 A0 12 33 95 5D CF 54 28 CE C6'\r\n 'EB 7E 32 5E 85 02 1F AF EB C0 07 B5 39 50 28 CD D0 EB 99 3D A0 3A C3 02 85 02 7D CA C7 49 AF 30'\r\n 'B1 2D 41 1E 54 38 E8 01 6A 78 90 07 35 22 50 A8 C2 D6 20 0F B3 FF 2C 68 13 EA A7 60 46 D8 3A 3F'\r\n '07 B3 85 1A 19 B4 C2 07 EB 20 12 2A 72 FD BF EA DA B5 CC 1E F8 DC 7D ED BF 79 A3 82 56 F8 A1 5E'\r\n '90 87 FF FE 16 44 9E C0 E3 76 D0 03 D4 2F 81 3A 89 E5 0B 22 A1 FE 08 D4 29 DC 39 82 48 A8 BF 02'\r\n 'DF 7B B8 B2 82 91 41 FD 19 44 42 FD 10 A8 0C 5C 46 41 1E D4 B2 9B 7E 37 40 95 E5 B5 E8 E9 F2 9B'\r\n '7E 63 80 DE 7F D3 6F 2D D0 15 37 FD D6 02 9D C9 CB B2 AD BB 2C 7F E5 05 07 7A 95 17 1C F0 77 5E'\r\n 'EB 9C 33 CF 02 60 67 5C 78 89 93 70 08 01 13 80 23 88 B3 50 75 5E 90 C0 51 BC 40 81 C3 19 07 1C'\r\n '40 FF EC 44 EB 4F 0D 1C 44 3F 70 20 E3 81 DD A9 E7 E0 5C A2 1F 98 C6 78 60 37 FA 81 BD E9 BF 07'\r\n '97 12 35 B0 07 E3 80 3D 19 07 1C 42 9C 97 68 83 69 07 0E 63 3C 70 28 E3 81 7D E8 9F 8F EB 84 7E'\r\n '60 3F FA 81 7D E9 07 CE A0 FF 5E 94 80 1A 38 8B 7E E0 74 C6 03 A7 D2 BE 08 6F D4 19 07 9C 4C 3B'\r\n '70 1A E3 80 73 E9 5F 82 37 1C D4 C0 D9 F4 03 E7 30 1E B8 80 F6 FB F0 A0 4F 3B 70 1E ED C0 F9 CC'\r\n '03 2E A5 7D 29 56 8E 76 E0 62 E2 0A 3C 39 D2 0E BC 97 7A 25 9E EF A8 81 F7 51 AF C2 F9 4A 0D 5C'\r\n '49 BD 06 AB 49 0D BC 9F 7A 13 D6 9C 1A 38 96 FD EC 4A B4 71 1C 07 70 34 ED C0 31 8C 03 4E A4 FF'\r\n '71 BC 7F A4 1F 38 9E 7E E0 04 FA 81 AB E9 DF 8D A3 90 7E E0 2A FA 81 0F D0 0F 4C 27 3E 8D 1B 30'\r\n 'ED C0 18 E3 80 19 CC 03 3E 48 FF 7E 9C 9F F4 03 D7 D3 0F 5C 47 3F 70 1B F1 20 AE 76 C6 01 B7 30'\r\n '0E F8 10 E3 80 9B E8 3F 8C 73 8A 7E E0 06 FA 81 9B E9 07 6E A7 7E 3E D1 76 D0 0F 7C 84 F1 2F 24'\r\n 'DA A3 F4 03 1F A6 1F B8 93 7E E0 5E FA 8F E3 79 95 7E E0 53 F4 03 F7 D0 0F 7C 8D 97 CD AB EE AA'\r\n 'D8 CD 10 D0 27 99 02 7C 9C A1 C0 27 18 0A FC 9C F8 26 8E 26 DA 81 1F 11 71 04 7C 4C 3B F0 D2 35'\r\n '5C 8C 27 DD 55 35 83 17 98 A7 E7 19 05 FA 21 A3 80 17 A8 71 00 5C A4 06 5E 26 BE 85 07 32 DA 81'\r\n '9F 52 9F C1 4D 81 1A 78 93 A3 39 9B 68 FF 72 74 C0 EB B4 03 6F 30 0E F8 25 35 8E 89 6F E8 07 7E'\r\n 'CD 78 E0 57 F4 03 3F E0 04 CF B9 09 1E E0 00 3D 3D 08 9A E0 E9 3E 36 00 BA 9F 09 C0 57 98 90 E1'\r\n '5C 8F 31 CA D3 5D CC F5 B4 42 76 04 94 CF 6E 0D B2 5B 75 D2 64 47 6B 90 A6 3A 7A 86 F4 64 76 3B'\r\n '9E DD CE 8A 9E CF 6E ED 72 F2 D7 06 39 AD 51 4E 6B 2D DA 23 A7 B5 17 ED 99 D3 D6 91 AE CD 69 E7'\r\n '73 DA 69 D2 13 39 ED 78 4E 3B 2B 0A EB 19 D2 93 CE DA 3A 17 FF C9 BA 5C D6 23 97 BD 42 FA 72 2E'\r\n 'CB C8 65 67 72 59 C4 4E E4 B2 D7 9C 3A 4D 87 57 27 45 61 3D 25 1A CB 65 6D 73 B3 91 DC D6 28 B7'\r\n 'B5 17 ED 99 DB DA 91 B6 72 D6 8F 49 3F CA 6D A7 73 DB A5 DC 68 1A F4 5D A7 2E CA 01 F5 89 E8 A7'\r\n 'B9 2D 35 0F 56 BD 43 1E 4B C9 63 17 49 F7 E4 B1 CD 79 EC 92 E8 CE 3C 76 98 F4 ED 3C 76 28 8F E5'\r\n 'CA 6B A1 70 CE BC 36 23 AF 45 92 0E E5 B5 49 79 6D 7E 5E 9B 45 75 38 AE CA 26 A1 E9 32 49 56 35'\r\n 'C9 AE 27 59 28 DB C5 24 1B CF 7F CC D9 A2 36 28 6A D5 AB 5B 28 09 74 E7 BF 16 CA 05 1C 98 62 21'\r\n 'BA 52 68 0F 45 ED 11 DA 81 13 98 12 76 29 35 E8 22 65 28 70 17 43 80 13 19 12 71 21 4F D0 04 3A'\r\n '98 21 C0 DA 4C 01 3E 49 7B 96 A8 D5 A1 06 4E 62 4A 82 4B D9 4D 17 68 5D BA 80 43 98 0A 9C CC 90'\r\n '44 17 32 94 26 D0 26 0C 01 1E 64 0A 70 0A 43 B2 BA 90 61 0C 01 6D CA 10 E0 21 86 00 0F 13 B3 45'\r\n 'AD 19 ED C0 A9 4C C9 EE 52 86 33 05 B4 05 5D C0 23 0C 05 B6 A4 CE 11 B5 67 A9 81 D3 98 92 D3 A5'\r\n 'DC 23 3A 3E 6A 47 E9 05 1D C1 56 80 AD 98 05 9C CE 90 5C 2E FA EE 14 CB 42 8A 68 38 A6 46 AD 35'\r\n '63 60 78 8E B9 C0 91 CC 05 1E A3 CE 1D B5 36 F4 03 E7 A6 58 42 D6 3C AE 8D A3 51 C3 A2 8C 8A DA'\r\n '0C B6 EB 6D CF 33 1C 74 14 D3 81 6D 99 06 9C C9 90 BC 2E 64 34 5D A0 ED E8 02 BE C0 14 E0 2C 86'\r\n '24 B9 90 F6 74 81 BE 48 17 70 0C 53 80 B3 19 12 75 21 1D 18 02 FA 12 43 80 63 19 02 9C C3 90 7C'\r\n '2E A4 23 43 40 C7 D1 05 3C CE 50 E0 30 DA 0B A0 C8 C4 82 51 6B 4C 2C 12 B5 03 F4 03 C7 53 DF 8E'\r\n '8D 40 2C 8A D5 26 16 C3 92 12 8B 47 AD 39 B1 44 D4 9E 61 3C 70 2A 75 49 2C 06 B1 14 CA 4C 2C 87'\r\n 'B2 10 2B 60 EE C4 4A 98 20 B1 32 66 41 AC 82 A1 12 AB A2 A4 C4 6A 58 13 62 0A 56 92 58 2B 6A F3'\r\n '88 8D A3 36 9F D8 2A 6A 0B 88 ED A3 B6 88 D8 33 6A 8B 89 BD A2 B6 84 D8 3B 6A 0F 73 3C 03 B1 25'\r\n 'A9 81 AF 51 A3 0E 9D A8 81 AF 53 0F 8E 5A 67 6A 60 17 E2 90 A8 BD 41 3B B0 2B F5 D0 A8 BD 49 0D'\r\n '3C 41 1C 16 B5 34 DA 81 27 A9 87 47 AD 1B 35 F0 34 F5 88 A8 75 A7 06 F6 20 8E 8C DA 19 DA 81 67'\r\n '89 D8 1E 3D 69 07 F6 22 8E 8E DA DB B4 03 7B 53 8F 89 DA 3B D4 C0 77 89 63 A3 76 17 ED C0 3E C4'\r\n '71 51 3B 47 3B B0 2F 35 36 EC 07 D4 C0 74 E2 84 A8 F5 A3 1D D8 9F 38 31 6A 19 B4 03 63 C4 49 51'\r\n '1B 40 3B 70 20 71 72 D4 CE D3 0E 1C 44 3D 25 6A 1F 53 03 07 53 E3 52 B8 40 0D BC 48 9C 86 AB 9E'\r\n '76 E0 7D C4 45 51 5B 4A 5C 1C B5 65 C4 A5 51 5B 4E 5C 13 B5 FB 89 6B A3 B6 82 B8 2E 6A 2B 89 DB'\r\n 'A3 B6 8A B8 33 6A A9 C4 A7 A2 F6 28 DB 05 3E 46 DC 1B B5 9A B4 03 1F A7 7E 3A 6A B5 A8 81 F5 88'\r\n '07 A2 F6 14 ED C0 FA D4 07 A3 B6 87 1A B8 97 78 28 6A 0D 68 07 3E 4D 7D 38 6A 0D A9 81 8D 88 CF'\r\n '44 6D 1F ED C0 FD C4 23 51 BB 93 76 E0 08 E2 49 5C EA C4 53 B8 66 89 67 71 81 12 DF C1 55 47 FC'\r\n '00 97 16 F1 3C AE 23 E2 47 38 76 89 97 70 B6 12 3F 8D DA 42 E2 D5 A8 DD 4B FC 35 6A 89 B7 E1 70'\r\n '4F B8 CD 6A DE 66 D9 48 B3 3A 9A 83 34 BB A3 B9 48 73 3A 9A 87 34 B7 A3 F9 48 A3 8E D6 27 AD E7'\r\n '68 43 D2 06 8E 36 26 6D E4 68 13 D2 3B 1D 6D 46 DA D4 D1 96 FC D1 60 B8 A8 75 23 16 2A 6A DD 89'\r\n '85 8B DA 73 C4 DB 8B 5A 6F 62 D1 A2 D6 97 58 A6 A8 3D 41 9C 53 D4 9E 22 2E 2E 6A D1 E2 B8 73 25'\r\n '15 B7 14 FE 35 88 FC C5 AD 17 FF 1A 44 81 E2 56 9D 1A D8 B3 B8 65 49 4A 81 3F FE AA 51 1C 37 B5'\r\n '4C 95 CA 7F 22 CA D3 DA 74 D4 2C 6E FE 55 8B 0E 4F BF E6 1F 8A D8 5D DC B6 94 C0 A8 57 97 E0 BF'\r\n 'C1 FE 1D 97 05 F4 0A 71 4D 09 DB 4A D7 5A E7 FA 9E 26 D0 1F 88 0F 96 B0 7D 74 AD 73 AE B7 49 DF'\r\n '73 F4 5D D2 73 8E BE 43 9A EE E8 05 FE 10 36 5C D2 3A 9D F7 58 50 B8 4C F8 BA 30 0B FF 35 F8 48'\r\n '49 A6 BC CA 94 AC 25 6D F7 79 8F 13 84 35 85 D7 E4 CF CE 94 6C 2E 25 17 69 4E 47 1B F3 F7 FD D1'\r\n '92 76 3F FF 50 44 BE 92 36 87 7F 6C 10 58 9A 21 A5 5C 48 59 D2 32 3E B1 22 6A 59 A9 A4 65 BE AA'\r\n '94 44 C9 32 55 65 44 4A 25 D3 51 B5 A4 F9 57 35 3A 3C 6D C2 D6 1A B8 D6 9A 93 36 73 B4 15 69 0B'\r\n '47 DB 90 B6 76 74 1C 69 07 47 07 93 0E 72 74 22 E9 50 47 27 91 0E 73 74 2A E9 64 47 A7 91 4E 71'\r\n '74 26 E9 74 47 67 91 CE 70 74 3E E9 6C 47 17 90 CE 71 F4 33 D2 B9 8E 7E 4E 7A B7 A3 8B 48 17 3A'\r\n 'BA 98 F4 5E 47 97 92 2E 71 74 19 E9 7D 8E 7E 41 BA C6 D1 CB A4 6B 1D DD 4B FA 88 A3 4F 93 3E E9'\r\n 'E8 3E D2 DD 8E EE 27 DD E3 E8 15 D2 43 8E 7E 4F 7A D8 D1 1F 48 9F 71 F4 47 D2 23 8E 7E EB 9E 96'\r\n 'CA D8 8F C4 87 CB D8 4F C4 33 65 6C 00 77 EB E2 0A 36 90 B8 A4 82 4D A8 C2 BF E9 51 C5 A2 BC 20'\r\n '42 C9 36 D4 3D 88 25 5B 17 5E 28 C0 7C B4 87 93 6D 90 6B 2F D9 EE A4 CE 96 6C 8D 89 D9 93 AD 21'\r\n '31 47 B2 35 22 E6 4C B6 26 C4 5C C9 36 D8 3D 74 24 5B 53 EA DC C9 36 C4 3D 74 24 5B 33 EA 3C C9'\r\n 'D6 9C 98 37 D9 EA 13 93 92 AD 01 31 9A 6C B5 92 79 87 4F B6 8A 57 43 91 A4 02 C9 FC 67 C0 0A A2'\r\n 'D5 5F BD CA DE 91 AA A9 D4 0A A7 5A 49 5D EA 4A D5 4C 6A 59 1F AA 16 52 69 83 A9 5A 4B F5 1C 46'\r\n 'D5 58 AA F2 08 AA E6 52 C7 26 52 B5 94 3A 3F 9D AA 9F 3B 34 92 AD AE 3B 34 92 AD 1E 11 F6 FE B4'\r\n '03 0B 53 17 4A B6 5B 88 85 93 6D 5D 32 9F CF 93 6D 73 B2 B5 27 6D E7 68 47 D2 0E 8E 76 26 ED E4'\r\n '68 57 D2 2E 8E 76 23 4D 73 B4 07 69 77 47 7B 91 F6 74 F4 2E D2 DE 8E F6 25 ED E3 68 7F D2 7E 8E'\r\n '0E 24 1D E0 E8 60 D2 41 8E 0E 23 1D EA E8 08 D2 E1 8E 8E 22 1D E9 E8 44 D2 09 8E 4E 12 DD 92 6C'\r\n '53 48 27 3B EB 54 51 58 A7 93 4E 73 D6 19 A2 B0 CE 22 9D E9 AC B3 45 61 B5 5F 43 E1 3C 73 92 39'\r\n 'FF B9 B4 CE 71 01 77 8B 22 60 07 68 8E A5 C9 B6 3C D9 B6 73 7F C0 BB 83 08 D7 76 46 3D E4 07 4D'\r\n 'D3 CE 64 FE 29 DC 84 3C 8F 24 DB BB 2E F7 7A B2 9D C2 5E E1 DF A9 84 ED FB 64 CB 48 36 04 85 15'\r\n 'F4 5B B2 7D E8 E2 C0 23 FC C3 89 8F B8 14 C4 4D 62 73 50 EF F1 19 12 38 92 FA D1 64 CB C2 CC 5D'\r\n 'C9 76 C6 25 EF 77 5D 27 30 73 97 33 BC 9A 6C 93 19 09 F5 3E 33 81 A3 A8 1F 4B B6 DF 39 D6 C7 5D'\r\n '42 22 13 40 77 BB 9C 73 0C 84 9A C2 40 E0 68 E2 13 C9 96 95 7F F4 F1 49 6C 36 D7 8F 9F 09 92 B3'\r\n '71 32 4F 3A C3 1E F7 DF 0F 98 0F C3 54 E6 01 C7 10 D1 74 76 F6 F2 94 EB 02 4D E4 90 42 C2 67 C9'\r\n '96 CE 1C A8 69 EE 91 24 D9 F2 B0 D1 3D AE FD 1F 5D 46 DE C0 00 F5 49 B2 ED E5 F0 BD 21 27 9B 02'\r\n 'C5 E4 AE 24 5B 2E 45 7E 97 6C AF BB 31 E6 96 E1 47 E7 46 7F D3 D9 09 0C 19 EC 14 98 C4 89 3D ED'\r\n '9A F2 FF F5 CD 46 99 E7 0D 67 5C 5E FE 54 CB 26 C3 F7 F1 D0 97 DD 7F E1 DC C7 F1 78 5B 3E 25 7E'\r\n '15 EF B0 A0 3A F8 31 BE 42 DF B9 49 17 0A CC 9F C7 0B 8A 86 0B 73 49 BD F9 E7 F8 1C 0A F0 7F E5'\r\n 'F3 B6 18 47 0D 3A C3 3D A5 25 DB AD 6C E5 BF CD 9E 72 25 BA 85 83 F8 AF F9 00 07 E8 0D 45 94 82'\r\n 'CE 5E 70 86 5D AE E5 DB 94 F2 A3 1B CC DB 38 48 D8 15 0C 33 D9 15 F0 10 9B 38 E8 32 6E 67 CD 0F'\r\n 'BA 40 2C E6 87 0C 84 9A E5 9E 08 93 ED 19 06 1E 76 81 21 5E 4E A0 78 FD CB 0B E7 B0 1B 60 51 A6'\r\n '1F 76 23 38 9D 6C C5 D8 F1 61 D7 D8 05 B7 FD 3F 62 7B 30 CC 76 4F 92 C9 F6 2C DB 3B E2 DA BB 83'\r\n 'B1 47 DC 90 FD 0C 8A B3 5C 47 E2 BB DD 6F A7 39 EE 09 13 49 BF 86 42 F4 7D CC F6 80 CF B1 9D A3'\r\n 'AE 9D 12 4C 3B EA 56 28 F3 C2 99 CB 34 D8 2E 30 1C F8 3C C3 8F F9 EB 9F 2E D0 8B 74 01 5F A4 CB'\r\n '17 AF 24 E7 F2 42 7C 00 A5 02 85 79 5E 62 38 D4 3D 4C 07 1E 67 DA 4B 2E 6D 1E 4D A0 9F 30 04 58'\r\n '9A 13 CB DC 4E E8 E2 15 C6 7A C3 A7 8C 01 9D CF 1C E0 6B 74 BD EA 5C 9F D1 05 BA 80 2E E0 04 22'\r\n '36 CD 9B 0C 79 C3 85 2C A4 09 F4 73 86 02 CB 70 88 27 9C 0B 93 3C C9 40 AF F2 73 AD 3C FD 82 B1'\r\n 'A0 F7 32 17 58 96 39 A7 E2 7B FF 2D E6 78 55 8E 3B D3 6F B9 45 8C 05 BD CC 5C 60 79 BA B0 BC EF'\r\n '24 DB 62 BA 40 BF A4 0B B8 C4 DD D8 71 89 50 03 EF A3 3E 9B 6C 5F 53 03 BF 21 62 07 2E A5 1D 58'\r\n '81 DD BF 13 BF 1A 96 D1 0A F5 2D A3 80 55 B8 96 EF C6 4B F7 83 1B E2 7B 1C A2 B7 55 E2 76 CF 3C'\r\n '7F 33 D7 A6 32 0B 9E 69 46 5D DE 57 0A 0C 15 D9 DF BB 6E 97 C1 B1 9C FD 41 7D C7 FE 80 D5 E9 3D'\r\n '17 2F C6 07 4C F3 AA 2A 7B 3A 17 3F C1 8F C5 AF E8 6A EC C9 9B FD 9E 4D 56 03 5B DC 75 91 AE 06'\r\n 'A0 EE 67 4F A0 57 D8 13 B0 06 1B CC 70 6D BF EE 56 EB 09 97 1F 63 86 37 9F 17 45 72 8A 82 77 FE'\r\n 'E7 F0 43 44 2A 7B 87 F9 D1 F8 19 53 93 BD 67 B8 20 54 62 05 BB 84 FA 9E 5D 02 1B 30 FC C3 78 31'\r\n 'B1 D9 3E 62 0F DE 50 9B 99 FE 0E 85 1D 5B 47 91 5B DC 01 89 D1 D6 0B 0C FE 90 AF 9F 6A 59 65 B8'\r\n '1E BF B5 F9 CB EF 63 35 0A 43 2D AE DE 87 AE 34 2F C7 6F 77 75 D5 D1 F7 AE FE 3F 70 68 50 2B 39'\r\n '54 60 23 F6 73 21 5E 7F CC E8 22 5B F3 86 86 6C CD 9F 22 BB E2 2B DD 98 C3 B8 10 1F 97 27 BE 36'\r\n '97 94 08 C3 9D DC AD 17 5C 44 13 F6 7E 21 3E 96 A6 81 82 6F 15 C7 00 F5 23 C7 04 6C C6 B1 7C 12'\r\n '3F 8F 70 74 36 67 B8 37 20 B9 85 D4 EB EE 09 A0 A5 D4 F7 2E B8 15 87 FA 89 6B 15 45 F9 C6 91 9F'\r\n 'D8 2C 6C 0F B0 1B 60 6B 36 FF 69 BC 6D 04 B4 E5 22 7F EA CE AD CC 1D 8F E6 DA 70 F4 DE FC 33 9B'\r\n '00 5D CD 26 80 6B 88 38 14 7F A1 1D D8 9E DD 7E 1E BF CB F9 4B B7 1D 07 96 69 EB C0 4E FF 7B 4B'\r\n 'BA CA 54 18 D6 B2 29 E0 83 C4 2F 92 ED 57 DA 81 63 A9 2F E3 69 91 89 5F FE E7 E1 A0 13 DB FD 32'\r\n '3E C8 DF 18 0E B5 8E E1 C0 71 44 DC 25 3B 33 EA 6B 77 CD 60 2C EB 69 85 FA 9D D1 C0 F1 D4 A8 CE'\r\n '06 E2 B7 C9 F6 07 ED C0 8D D4 D8 C3 7F 52 03 BB B0 F3 2B F1 8D 8F EE BA B2 26 57 DC 3E DF C4 58'\r\n 'D0 BF 18 0B 4C 63 EC F7 C9 BA EA 30 BA 6E 2C CA F7 8E 66 C4 37 D6 66 26 01 FF 66 12 B0 3B DB FB'\r\n 'C1 DD 60 7A 70 15 7E 88 EF AF 83 F1 E7 92 7F 18 09 F3 16 66 02 FF 47 8D 75 DB 4A 0D FC 8B DB ED'\r\n '67 17 DD 93 73 CE BC BF 6F 63 00 D4 35 26 00 FF 66 E0 2F 7E 7D 69 02 FD 87 A6 AB CE 74 83 26 D0'\r\n 'FF D1 F4 AB 33 0D 67 03 A0 37 E9 02 3E 44 8D 11 0D 23 5E C3 D3 32 11 93 BB C9 94 1B 2E 65 BE FB'\r\n '34 BB 23 FF DD B6 50 12 70 6D 75 BC A9 02 56 E0 4D 13 B8 8D 3A D4 D1 96 B8 CF A9 3B DA 42 F7 59'\r\n '70 47 5B 47 3B B0 22 E3 80 BB 68 CF D1 D1 36 D0 0E DC 44 CC D9 D1 1E 77 9F FA 76 B4 AD D4 B7 76'\r\n 'B4 10 FB 29 DF D1 1E A3 BD 4A 47 DB 48 3B B0 0A DB 01 86 E9 AF D5 D1 22 C4 3B 3B 5A 16 62 EF 8E'\r\n 'B6 85 71 C0 A5 CC EB D7 D1 12 68 5F DC D1 16 50 E3 DD 54 01 E6 03 13 69 07 3E C8 78 E0 22 FA D7'\r\n '75 B4 AC B4 3F DC D1 6E 61 DC AE 8E B6 83 FE E7 3B 5A 36 DA 81 4F 33 2E D4 C9 76 BA 4F 6E 3B D9'\r\n '43 C4 8A 5D 2C BB 1B 47 17 CB 41 1C D6 C5 EE A3 7D 4C 17 CB 49 0D 5C 4C 3D AE 8B E5 A2 5E D8 C5'\r\n '8A B1 FD 95 5D 2C 37 F5 86 2E F6 08 FD 9B BB 58 1E EA 3D 5D 2C 2F F1 B3 2E 96 44 FC A3 8B 45 5D'\r\n 'DD BB 5A 71 E6 15 ED 6A B7 13 3B 74 B5 BA C4 C9 5D 2D 1F FD 5B BB DA 26 B6 F3 4C 57 CB 4F FD 4F'\r\n '57 2B 40 2C 98 66 05 89 45 D2 AC 10 B1 4E 9A ED 66 5C FD 34 AB C3 37 A3 4D D2 AC 70 35 8F CB 68'\r\n '07 D6 A5 BD 79 9A D5 23 B6 48 B3 FD B4 77 4B B3 5B 18 D7 37 CD 6E 25 8E 4A B3 ED B4 4F 4C B3 22'\r\n '6E 5E 69 76 1B F1 D9 34 BB 9D 78 2A CD F2 71 7C 67 D3 AC 28 F5 E5 34 EB 02 9D F5 E7 34 AB 4A FB'\r\n '6F 69 F6 24 F3 81 35 A8 B3 75 B3 75 D4 B9 BB 59 19 EA BA DD AC 39 75 A7 EE 56 8F FA D9 EE 56 8C'\r\n 'ED 9C EF 61 F7 BA 13 B5 87 AD E7 FA 00 1F A0 BE A3 A7 DD 41 3F 70 3B ED C9 3D AD 38 F5 F7 BD AC'\r\n '34 F3 7F E9 65 25 A8 C3 BD AD 24 31 47 6F 2B E5 EA D3 DB 0A D2 5F A4 B7 1D 60 3B B7 F7 B6 BB 79'\r\n 'F9 96 EB 6D 43 C6 58 69 86 80 16 66 48 85 DE F6 10 9B 06 6E 65 E8 94 DE 56 86 7E 60 59 62 E7 3E'\r\n '16 65 5C CF 3E B6 87 FE E1 7D AC 1C ED F3 FB D8 53 D4 1B FB 58 79 EA BF FB 58 05 62 DE BE 56 91'\r\n '58 B2 AF 55 72 4B D3 D7 2A 13 C7 F7 B5 2A C4 49 7D AD 2A F1 42 3F AB 46 FC AA 9F 55 66 FB 5F F7'\r\n 'B3 27 DC 91 D7 CF 92 69 BF DA CF AA 13 6F F6 B3 14 E2 E4 FE 36 C7 FD 41 F9 FE 96 34 D8 52 69 9A'\r\n 'DD DF 5A 30 65 6E 7F AB 41 3D AF BF D5 24 FE DE DF 6A B9 D4 FE 56 9B 98 73 80 D5 21 E6 1F 60 75'\r\n 'DD 94 06 58 3D E2 A0 01 56 DF 4D 75 80 15 75 57 D1 00 EB CC D5 DC 38 C0 1A D0 FE FA 00 6B 48 CC'\r\n '36 D8 1A B9 AB 73 B0 DD 49 6C 37 D8 92 18 0F AC 4E 4C 1B 6C E5 88 EB 07 5B 35 62 D6 21 56 9E D8'\r\n '7D 88 35 66 7C B5 61 D6 84 58 63 98 B5 E4 78 EF 1B 66 4D A9 81 CD 88 1B 87 D9 6D 8C DF 3C CC 9A'\r\n '53 EF 1A 66 77 50 1F 18 66 2D A8 8F 21 CF 5D 3D C3 AC 95 2B D9 30 5B CD 76 80 F7 B0 24 79 86 DB'\r\n '0B 63 ED 56 A6 14 1F 6E 73 69 AA 32 DC 56 74 B3 D6 8C FE 65 B8 D5 76 7B 71 84 B5 71 B3 19 61 CB'\r\n '99 0D AC E5 CE B0 11 B6 D6 9D 6D 23 6C 25 B1 FC 08 6B EB CE AA 11 36 8F F7 89 8A 23 2D EF 00 2B'\r\n 'D2 C9 1A CD B2 35 EE 70 18 69 ED 18 50 7C 8C B5 27 0E 1E 63 8F D2 8E 9D D5 81 7A D6 18 EB 48 3C'\r\n '3C C6 3A 11 CF 8C B1 1D 55 81 6F 8F B1 CE D4 E9 63 AC 8B DB 01 63 AC AB DB 31 63 2D 8D 58 60 AC'\r\n 'AD 60 3B 35 C6 5A 37 57 AE B1 B6 C3 DD EC C6 5A 4D 0E 74 FE 78 2B 4B 2C 30 C1 EE 77 87 D1 44 EB'\r\n 'EE 0E A3 89 56 84 F6 12 93 AC 07 75 C5 C9 D6 D3 2D D7 64 EB 45 AC 3F D9 7A BB C3 6C B2 DD 45 6C'\r\n '35 D9 FA B8 C3 75 B2 F5 25 F6 99 6C EB D9 DE AC C9 D6 8F 7A EF 64 EB 4F 5C 34 C5 06 10 97 4D B1'\r\n '81 C4 8B 53 6D 10 F1 EB A9 36 98 78 CB 34 1B E2 2E CE 69 56 92 FD 03 87 BA C2 4D B3 61 C4 E4 69'\r\n 'B6 99 57 56 CA 34 AB 43 7F EA 34 DB C2 7E 6A 4F B3 E1 F4 DF 3F CD 46 10 D7 4E B3 91 C4 E9 D3 6D'\r\n '14 F1 EE E9 36 9A B8 6F BA 8D 21 BE 3C DD F6 32 EF F2 74 1B 4B FD D3 74 1B E7 EA 37 C3 C6 13 BF'\r\n '98 61 13 88 BF CD B0 89 C4 7A B3 EC 41 C6 63 BD 36 BA 9B C6 2C 4B 61 FF 0B 66 D9 24 FA 9F 9B 65'\r\n '93 89 C7 67 D9 66 F7 68 39 CB A6 50 4F 9D 6D A9 8C 9B 3D DB A6 BA 75 9B 6D D3 DC A1 3B DB 5A 31'\r\n 'EE 81 39 36 DD 5D 2E 73 6D 86 BB E2 E7 5A 09 C6 37 BD DB 66 BA 7A CF B3 59 C4 2E F3 6C 36 71 F9'\r\n '3C 9B 43 7C 69 9E CD 25 86 E6 DB DD C4 5C F3 ED 1E 62 BE F9 36 8F 98 3A DF E6 BB CB 77 BE 2D 70'\r\n 'F5 9E 6F 0B DD E1 BA C0 EE 25 5E 59 60 8B DC FC 16 D8 62 E2 F5 05 B6 C4 B5 B3 D0 EE 23 DE B6 D0'\r\n '96 BA 75 58 68 CB DC 49 B3 D0 96 BB 13 63 A1 DD 4F 9C B9 D0 56 10 3B 2C B1 95 6E BF 2C B1 55 C4'\r\n 'C6 4B ED 01 62 FB A5 B6 9A 38 64 A9 AD 21 DE B3 CC D6 BA F5 59 66 0F 12 CF 2D B3 42 9C E7 E5 65'\r\n 'B6 CE DD B4 96 DB 7A 62 ED 15 B6 81 D8 72 85 6D 24 76 5F 61 9B 5C 7F 2B 6C 33 F1 21 F8 59 B7 9D'\r\n '2B AC 14 F3 77 AF B0 7D D4 27 57 D8 16 FA 87 AE B4 64 DA 27 AE B4 AD D4 C0 6D EE BA 59 69 0F B9'\r\n '9B E6 2A DB 4E 3C BD CA 76 B8 9B E1 03 F6 30 F1 C0 03 B6 93 78 E4 01 AB C4 FC B6 AB 6D 1B DB 1D'\r\n 'B5 DA 1E A1 7D CD 6A 7B 94 D8 66 8D ED 22 9E 58 63 8F 11 CF AE B1 55 8C 7B 7F 8D 3D 4E 0D 7C 82'\r\n '38 63 BD 3D E9 4E F4 F5 B6 9B 78 FB 06 7B CA DD F4 36 D8 1E 77 FC 6C B0 BD C4 6F 37 D8 D3 6E 7D'\r\n '37 DA 3E 62 FF 8D B6 DF 5D FF 1B ED 80 BB 79 6E B4 83 6E DF 6C B4 43 C4 1F 37 DA 61 B7 6E 1B ED'\r\n '19 B7 FE 9B EC 61 F7 CD FD 26 3B 42 FD E4 26 7B D6 ED E3 4D 76 94 F8 E9 26 7B CE 3D 3C 6C B6 63'\r\n 'C4 CD 9B ED 79 77 3D 6E B6 17 5C FC 16 7B 91 F8 E1 16 7B C9 C5 6F B1 E3 C4 32 5B ED 65 77 CC 6E'\r\n 'B5 57 88 29 5B ED 55 62 83 AD F6 1A F1 AE AD F6 BA 3B 36 B7 D9 1B C4 69 DB ED 4D B7 DF B6 DB 09'\r\n 'E2 63 DB ED 24 F1 85 ED 76 CA 1D FB DB ED 2D E2 DB DB ED B4 AB D3 76 3B E3 AE 83 ED 76 96 78 63'\r\n 'BB BD 4D CC B3 C3 DE 71 B7 95 1D F6 AE 3B 0F 77 D8 7B EE BC D9 61 EF 13 DB EE B0 73 C4 AE 3B EC'\r\n '03 E2 CA 1D 96 4E DC B6 C3 7E E3 79 B8 63 87 65 B8 87 B3 1D 36 F1 09 FE 95 ED 27 6C 4B 52 28 6C'\r\n '9B 93 42 CF 27 85 B6 91 6E 75 74 0F E9 63 8E FE 1F 78 9A 84 0C'\r\n}\r\n" }, { "path": "External/Jedi/Jcl/source/common/JclUnitConv.pas", "content": "{**************************************************************************************************}\r\n{ }\r\n{ Project JEDI Code Library (JCL) }\r\n{ }\r\n{ The contents of this file are subject to the Mozilla Public License Version 1.1 (the \"License\"); }\r\n{ you may not use this file except in compliance with the License. You may obtain a copy of the }\r\n{ License at http://www.mozilla.org/MPL/ }\r\n{ }\r\n{ Software distributed under the License is distributed on an \"AS IS\" basis, WITHOUT WARRANTY OF }\r\n{ ANY KIND, either express or implied. See the License for the specific language governing rights }\r\n{ and limitations under the License. }\r\n{ }\r\n{ The Original Code is JclUnitConv.pas. }\r\n{ }\r\n{ The Initial Developer of the Original Code is Marcel van Brakel. }\r\n{ Portions created by Marcel van Brakel are Copyright Marcel van Brakel. All rights reserved. }\r\n{ }\r\n{ Contributor(s): }\r\n{ Marcel van Brakel }\r\n{ ESB Consultancy }\r\n{ Manlio Laschena }\r\n{ Allan Lyons }\r\n{ Robert Marquardt (marquardt) }\r\n{ Robert Rossmair (rrossmair) }\r\n{ Matthias Thoma (mthoma) }\r\n{ Petr Vones (pvones) }\r\n{ Scott Price (scottprice) }\r\n{ }\r\n{**************************************************************************************************}\r\n{ }\r\n{ Contains routines to perform conversion between various units such as length coordinate, }\r\n{ temperature, angle, mass and pressure conversions. }\r\n{ }\r\n{**************************************************************************************************}\r\n{ }\r\n{ Last modified: $Date:: 2011-09-03 00:07:50 +0200 (sam. 03 sept. 2011) $ }\r\n{ Revision: $Rev:: 3599 $ }\r\n{ Author: $Author:: outchy $ }\r\n{ }\r\n{**************************************************************************************************}\r\n\r\nunit JclUnitConv;\r\n\r\n{$I jcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n {$IFDEF HAS_UNITSCOPE}\r\n System.SysUtils,\r\n {$ELSE ~HAS_UNITSCOPE}\r\n SysUtils,\r\n {$ENDIF ~HAS_UNITSCOPE}\r\n JclBase;\r\n\r\nconst\r\n { Temperature constants }\r\n\r\n CelsiusFreezingPoint = 0.0;\r\n FahrenheitFreezingPoint = 32.0;\r\n KelvinFreezingPoint = 273.15;\r\n CelsiusBoilingPoint = 100.0 + CelsiusFreezingPoint;\r\n FahrenheitBoilingPoint = 180.0 + FahrenheitFreezingPoint;\r\n KelvinBoilingPoint = 100.0 + KelvinFreezingPoint;\r\n CelsiusAbsoluteZero = -273.15;\r\n FahrenheitAbsoluteZero = -459.67;\r\n KelvinAbsoluteZero = 0.0;\r\n\r\n { Newly added for Rankine and Reaumur Support by scottprice }\r\n RankineAbsoluteZero = 0.0;\r\n RankineAtFahrenheitZero = 459.67;\r\n RankineFreezingPoint = 491.67;\r\n RankineBoilingPoint = 180 + RankineFreezingPoint;\r\n ReaumurAbsoluteZero = -218.52;\r\n ReaumurFreezingPoint = 0.0;\r\n ReaumurBoilingPoint = 80.0;\r\n\r\n\r\n { Mathematical constants }\r\n\r\n DegPerCycle: Float = 360.0;\r\n DegPerGrad: Float = 0.9;\r\n DegPerRad: Float = 57.295779513082320876798154814105;\r\n GradPerCycle: Float = 400.0;\r\n GradPerDeg: Float = 1.1111111111111111111111111111111;\r\n GradPerRad: Float = 63.661977236758134307553505349006;\r\n RadPerCycle: Float = 6.283185307179586476925286766559;\r\n RadPerDeg: Float = 0.017453292519943295769236907684886;\r\n RadPerGrad: Float = 0.015707963267948966192313216916398;\r\n CyclePerDeg: Float = 0.0027777777777777777777777777777778;\r\n CyclePerGrad: Float = 0.0025;\r\n CyclePerRad: Float = 0.15915494309189533576888376337251;\r\n ArcMinutesPerDeg = 60.0;\r\n ArcSecondsPerArcMinute = 60.0;\r\n ArcSecondsPerDeg = ArcSecondsPerArcMinute * ArcMinutesPerDeg;\r\n DegPerArcMinute = 1 / ArcMinutesPerDeg;\r\n DegPerArcSecond = 1 / ArcSecondsPerDeg;\r\n\r\n\r\ntype\r\n { Exception classes }\r\n EUnitConversionError = class(EJclError);\r\n\r\n ETemperatureConversionError = class(EUnitConversionError);\r\n\r\n { Temperature type enumeration used for the general routine allowing for\r\n a more dynamic specification of the source or target temperature types }\r\n TTemperatureType = (ttCelsius, ttFahrenheit, ttKelvin, ttRankine, ttReaumur);\r\n\r\n\r\nfunction HowAOneLinerCanBiteYou(const Step, Max: Longint): Longint;\r\nfunction MakePercentage(const Step, Max: Longint): Longint;\r\n\r\n{ New Temperature routines }\r\n{ Old temperature routines removed and archived incase required again - scottprice }\r\n\r\nfunction CelsiusToFahrenheit(const Temperature: Float): Float;\r\nfunction CelsiusToKelvin(const Temperature: Float): Float;\r\nfunction CelsiusToRankine(const Temperature: Float): Float;\r\nfunction CelsiusToReaumur(const Temperature: Float): Float;\r\nfunction FahrenheitToCelsius(const Temperature: Float): Float;\r\nfunction FahrenheitToKelvin(const Temperature: Float): Float;\r\nfunction FahrenheitToRankine(const Temperature: Float): Float;\r\nfunction FahrenheitToReaumur(const Temperature: Float): Float;\r\nfunction KelvinToCelsius(const Temperature: Float): Float;\r\nfunction KelvinToFahrenheit(const Temperature: Float): Float;\r\nfunction KelvinToRankine(const Temperature: Float): Float;\r\nfunction KelvinToReaumur(const Temperature: Float): Float;\r\nfunction RankineToCelsius(const Temperature: Float): Float;\r\nfunction RankineToFahrenheit(const Temperature: Float): Float;\r\nfunction RankineToKelvin(const Temperature: Float): Float;\r\nfunction RankineToReaumur(const Temperature: Float): Float;\r\nfunction ReaumurToCelsius(const Temperature: Float): Float;\r\nfunction ReaumurToFahrenheit(const Temperature: Float): Float;\r\nfunction ReaumurToKelvin(const Temperature: Float): Float;\r\nfunction ReaumurToRankine(const Temperature: Float): Float;\r\nfunction ConvertTemperature(const FromType, ToType: TTemperatureType; const Temperature: Float): Float;\r\nfunction CelsiusTo(ToType: TTemperatureType; const Temperature: Float): Float;\r\nfunction FahrenheitTo(ToType: TTemperatureType; const Temperature: Float): Float;\r\nfunction KelvinTo(ToType: TTemperatureType; const Temperature: Float): Float;\r\nfunction RankineTo(ToType: TTemperatureType; const Temperature: Float): Float;\r\nfunction ReaumurTo(ToType: TTemperatureType; const Temperature: Float): Float;\r\n\r\n{ Angle conversion }\r\n\r\nfunction CycleToDeg(const Cycles: Float): Float;\r\nfunction CycleToGrad(const Cycles: Float): Float;\r\nfunction CycleToRad(const Cycles: Float): Float;\r\nfunction DegToCycle(const Degrees: Float): Float;\r\nfunction DegToGrad(const Degrees: Float): Float;\r\nfunction DegToRad(const Degrees: Float): Float;\r\nfunction GradToCycle(const Grads: Float): Float;\r\nfunction GradToDeg(const Grads: Float): Float;\r\nfunction GradToRad(const Grads: Float): Float;\r\nfunction RadToCycle(const Radians: Float): Float;\r\nfunction RadToDeg(const Radians: Float): Float;\r\nfunction RadToGrad(const Radians: Float): Float;\r\nfunction DmsToDeg(const D, M: Integer; const S: Float): Float;\r\nfunction DmsToRad(const D, M: Integer; const S: Float): Float;\r\nprocedure DegToDms(const Degrees: Float; out D, M: Integer; out S: Float);\r\nfunction DegToDmsStr(const Degrees: Float; const SecondPrecision: Cardinal = 3): string;\r\n\r\n{ Coordinate conversion }\r\n\r\nprocedure CartesianToPolar(const X, Y: Float; out R, Phi: Float);\r\nprocedure PolarToCartesian(const R, Phi: Float; out X, Y: Float);\r\nprocedure CartesianToCylinder(const X, Y, Z: Float; out R, Phi, Zeta: Float);\r\nprocedure CartesianToSpheric(const X, Y, Z: Float; out Rho, Phi, Theta: Float);\r\nprocedure CylinderToCartesian(const R, Phi, Zeta: Float; out X, Y, Z: Float);\r\nprocedure SphericToCartesian(const Rho, Theta, Phi: Float; out X, Y, Z: Float);\r\n\r\n{ Length conversion }\r\n\r\nfunction CmToInch(const Cm: Float): Float;\r\nfunction InchToCm(const Inch: Float): Float;\r\nfunction FeetToMetre(const Feet: Float): Float;\r\nfunction MetreToFeet(const Metre: Float): Float;\r\nfunction YardToMetre(const Yard: Float): Float;\r\nfunction MetreToYard(const Metre: Float): Float;\r\nfunction NmToKm(const Nm: Float): Float;\r\nfunction KmToNm(const Km: Float): Float;\r\nfunction KmToSm(const Km: Float): Float;\r\nfunction SmToKm(const Sm: Float): Float;\r\n\r\n{ Volume conversion }\r\n\r\nfunction LitreToGalUs(const Litre: Float): Float;\r\nfunction GalUsToLitre(const GalUs: Float): Float;\r\nfunction GalUsToGalCan(const GalUs: Float): Float;\r\nfunction GalCanToGalUs(const GalCan: Float): Float;\r\nfunction GalUsToGalUk(const GalUs: Float): Float;\r\nfunction GalUkToGalUs(const GalUk: Float): Float;\r\nfunction LitreToGalCan(const Litre: Float): Float;\r\nfunction GalCanToLitre(const GalCan: Float): Float;\r\nfunction LitreToGalUk(const Litre: Float): Float;\r\nfunction GalUkToLitre(const GalUk: Float): Float;\r\n\r\n{ Mass conversion }\r\n\r\nfunction KgToLb(const Kg: Float): Float;\r\nfunction LbToKg(const Lb: Float): Float;\r\nfunction KgToOz(const Kg: Float): Float;\r\nfunction OzToKg(const Oz: Float): Float;\r\nfunction CwtUsToKg(const Cwt: Float): Float;\r\nfunction CwtUkToKg(const Cwt: Float): Float;\r\nfunction KaratToKg(const Karat: Float): Float;\r\nfunction KgToCwtUs(const Kg: Float): Float;\r\nfunction KgToCwtUk(const Kg: Float): Float;\r\nfunction KgToKarat(const Kg: Float): Float;\r\nfunction KgToSton(const Kg: Float): Float;\r\nfunction KgToLton(const Kg: Float): Float;\r\nfunction StonToKg(const STon: Float): Float;\r\nfunction LtonToKg(const Lton: Float): Float;\r\nfunction QrUsToKg(const Qr: Float): Float;\r\nfunction QrUkToKg(const Qr: Float): Float;\r\nfunction KgToQrUs(const Kg: Float): Float;\r\nfunction KgToQrUk(const Kg: Float): Float;\r\n\r\n{ Pressure conversion }\r\n\r\nfunction PascalToBar(const Pa: Float): Float;\r\nfunction PascalToAt(const Pa: Float): Float;\r\nfunction PascalToTorr(const Pa: Float): Float;\r\nfunction BarToPascal(const Bar: Float): Float;\r\nfunction AtToPascal(const At: Float): Float;\r\nfunction TorrToPascal(const Torr: Float): Float;\r\n\r\n{ Other conversions }\r\n\r\nfunction KnotToMs(const Knot: Float): Float;\r\nfunction HpElectricToWatt(const HpE: Float): Float;\r\nfunction HpMetricToWatt(const HpM: Float): Float;\r\nfunction MsToKnot(const Ms: Float): Float;\r\nfunction WattToHpElectric(const W: Float): Float;\r\nfunction WattToHpMetric(const W: Float): Float;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jcl.svn.sourceforge.net/svnroot/jcl/tags/JCL-2.4-Build4571/jcl/source/common/JclUnitConv.pas $';\r\n Revision: '$Revision: 3599 $';\r\n Date: '$Date: 2011-09-03 00:07:50 +0200 (sam. 03 sept. 2011) $';\r\n LogPath: 'JCL\\source\\common';\r\n Extra: '';\r\n Data: nil\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n JclMath, JclResources;\r\n\r\nfunction HowAOneLinerCanBiteYou(const Step, Max: Longint): Longint;\r\nbegin\r\n Result := MakePercentage(Step, Max);\r\nend;\r\n\r\nfunction MakePercentage(const Step, Max: Longint): Longint;\r\nbegin\r\n Assert(Max <> 0);\r\n Result := Round((Step * 100.0) / Max);\r\nend;\r\n\r\n//=== Temperature conversion =================================================\r\n\r\nprocedure TemperatureBelowAbsoluteError;\r\nbegin\r\n raise ETemperatureConversionError.CreateRes(@RsConvTempBelowAbsoluteZero);\r\nend;\r\n\r\nfunction CelsiusToFahrenheit(const Temperature: Float): Float;\r\nbegin\r\n if Temperature < CelsiusAbsoluteZero then\r\n TemperatureBelowAbsoluteError;\r\n\r\n Result := (((FahrenheitBoilingPoint-FahrenheitFreezingPoint) /\r\n CelsiusBoilingPoint) * Temperature) + FahrenheitFreezingPoint;\r\n\r\n // F = C 1.8 + 32\r\n // Alternative: Result := Temperature * 1.8 + 32;\r\nend;\r\n\r\nfunction CelsiusToKelvin(const Temperature: Float): Float;\r\nbegin\r\n if Temperature < CelsiusAbsoluteZero then\r\n TemperatureBelowAbsoluteError;\r\n\r\n // K = C + 273.15\r\n Result := Temperature + KelvinFreezingPoint;\r\nend;\r\n\r\nfunction CelsiusToRankine(const Temperature: Float): Float;\r\nbegin\r\n if Temperature < CelsiusAbsoluteZero then\r\n TemperatureBelowAbsoluteError;\r\n\r\n // R = (C 1.8) + 32 + 459.67\r\n if Temperature = CelsiusAbsoluteZero then\r\n begin\r\n Result := RankineAbsoluteZero;\r\n end else\r\n begin\r\n Result := RankineFreezingPoint - FahrenheitFreezingPoint +\r\n CelsiusToFahrenheit(Temperature);\r\n end;\r\nend;\r\n\r\nfunction CelsiusToReaumur(const Temperature: Float): Float;\r\nbegin\r\n if Temperature < CelsiusAbsoluteZero then\r\n TemperatureBelowAbsoluteError;\r\n\r\n // R = C 0.8\r\n Result := Temperature * 0.8;\r\nend;\r\n\r\nfunction FahrenheitToCelsius(const Temperature: Float): Float;\r\nbegin\r\n if Temperature < FahrenheitAbsoluteZero then\r\n TemperatureBelowAbsoluteError;\r\n\r\n // C = (F - 32) / 1.8\r\n Result := (CelsiusBoilingPoint /\r\n (FahrenheitBoilingPoint-FahrenheitFreezingPoint)) *\r\n (Temperature - FahrenheitFreezingPoint);\r\nend;\r\n\r\nfunction FahrenheitToKelvin(const Temperature: Float): Float;\r\nbegin\r\n if Temperature < FahrenheitAbsoluteZero then\r\n TemperatureBelowAbsoluteError;\r\n\r\n // K = (F + 459.67) / 1.8\r\n Result := FahrenheitToCelsius(Temperature) + KelvinFreezingPoint;\r\nend;\r\n\r\nfunction FahrenheitToRankine(const Temperature: Float): Float;\r\nbegin\r\n if Temperature < FahrenheitAbsoluteZero then\r\n TemperatureBelowAbsoluteError;\r\n\r\n // Ra = F + 459.67\r\n Result := Temperature + RankineAtFahrenheitZero;\r\nend;\r\n\r\nfunction FahrenheitToReaumur(const Temperature: Float): Float;\r\nbegin\r\n if Temperature < FahrenheitAbsoluteZero then\r\n TemperatureBelowAbsoluteError;\r\n\r\n // R = (F - 32) / 2.25\r\n Result := (Temperature - FahrenheitFreezingPoint) / 2.25;\r\nend;\r\n\r\nfunction KelvinToCelsius(const Temperature: Float): Float;\r\nbegin\r\n if Temperature < KelvinAbsoluteZero then\r\n TemperatureBelowAbsoluteError;\r\n\r\n // C = K - 273.15\r\n Result := Temperature - KelvinFreezingPoint;\r\nend;\r\n\r\nfunction KelvinToFahrenheit(const Temperature: Float): Float;\r\nbegin\r\n if Temperature < KelvinAbsoluteZero then\r\n TemperatureBelowAbsoluteError;\r\n\r\n // F = K 1.8 - 459.67\r\n Result := FahrenheitToCelsius(Temperature - KelvinFreezingPoint);\r\nend;\r\n\r\nfunction KelvinToRankine(const Temperature: Float): Float;\r\nbegin\r\n if Temperature < KelvinAbsoluteZero then\r\n TemperatureBelowAbsoluteError;\r\n\r\n // Ra = K 1.8\r\n Result := Temperature * 1.8;\r\nend;\r\n\r\nfunction KelvinToReaumur(const Temperature: Float): Float;\r\nbegin\r\n if Temperature < KelvinAbsoluteZero then\r\n TemperatureBelowAbsoluteError;\r\n\r\n // R = (K - 273.15) 0.8\r\n Result := (Temperature - KelvinFreezingPoint) * 0.8;\r\nend;\r\n\r\nfunction RankineToCelsius(const Temperature: Float): Float;\r\nbegin\r\n if Temperature < RankineAbsoluteZero then\r\n TemperatureBelowAbsoluteError;\r\n\r\n // C = (R - 32 - 459.67) / 1.8\r\n Result := (Temperature - RankineFreezingPoint) / 1.8;\r\nend;\r\n\r\nfunction RankineToFahrenheit(const Temperature: Float): Float;\r\nbegin\r\n if Temperature < RankineAbsoluteZero then\r\n TemperatureBelowAbsoluteError;\r\n\r\n // F = R - 459.67\r\n Result := Temperature - RankineAtFahrenheitZero;\r\nend;\r\n\r\nfunction RankineToKelvin(const Temperature: Float): Float;\r\nbegin\r\n if Temperature < RankineAbsoluteZero then\r\n TemperatureBelowAbsoluteError;\r\n\r\n // K = R / 1.8\r\n Result := Temperature / 1.8;\r\nend;\r\n\r\nfunction RankineToReaumur(const Temperature: Float): Float;\r\nbegin\r\n if Temperature < RankineAbsoluteZero then\r\n TemperatureBelowAbsoluteError;\r\n\r\n // R = (Ra - 32 - 459.67) / 2.25\r\n Result := (Temperature - RankineFreezingPoint) / 2.25;\r\nend;\r\n\r\nfunction ReaumurToCelsius(const Temperature: Float): Float;\r\nbegin\r\n if Temperature < ReaumurAbsoluteZero then\r\n TemperatureBelowAbsoluteError;\r\n\r\n // C = R 1.25\r\n Result := Temperature * 1.25;\r\nend;\r\n\r\nfunction ReaumurToFahrenheit(const Temperature: Float): Float;\r\nbegin\r\n if Temperature < ReaumurAbsoluteZero then\r\n TemperatureBelowAbsoluteError;\r\n\r\n // F = R 2.25 + 32\r\n Result := (Temperature * 2.25) + FahrenheitFreezingPoint;\r\nend;\r\n\r\nfunction ReaumurToKelvin(const Temperature: Float): Float;\r\nbegin\r\n if Temperature < ReaumurAbsoluteZero then\r\n TemperatureBelowAbsoluteError;\r\n\r\n // K = R 1.25 + 273.15\r\n Result := (Temperature * 1.25) + KelvinFreezingPoint;\r\nend;\r\n\r\nfunction ReaumurToRankine(const Temperature: Float): Float;\r\nbegin\r\n if Temperature < ReaumurAbsoluteZero then\r\n TemperatureBelowAbsoluteError;\r\n\r\n // Ra = R 2.25 + 32 + 459.67\r\n Result := (Temperature * 2.25) + RankineFreezingPoint;\r\nend;\r\n\r\nfunction ConvertTemperature(const FromType, ToType: TTemperatureType; const Temperature: Float): Float;\r\nconst\r\n cToType = 'ToType';\r\n cFromType = 'FromType';\r\nbegin\r\n case FromType of\r\n { All conversions from Celcius to other formats are listed here }\r\n ttCelsius:\r\n begin\r\n case ToType of\r\n ttFahrenheit:\r\n Result := CelsiusToFahrenheit(Temperature);\r\n ttKelvin:\r\n Result := CelsiusToKelvin(Temperature);\r\n ttRankine:\r\n Result := CelsiusToRankine(Temperature);\r\n ttReaumur:\r\n Result := CelsiusToReaumur(Temperature);\r\n else\r\n raise EInvalidOp.CreateResFmt(@RsTempConvTypeError, [cToType]);\r\n end;\r\n end;\r\n { All conversions from Fahrenheit to other formats are listed here }\r\n ttFahrenheit:\r\n begin\r\n case ToType of\r\n ttCelsius:\r\n Result := FahrenheitToCelsius(Temperature);\r\n ttKelvin:\r\n Result := FahrenheitToKelvin(Temperature);\r\n ttRankine:\r\n Result := FahrenheitToRankine(Temperature);\r\n ttReaumur:\r\n Result := FahrenheitToReaumur(Temperature);\r\n else\r\n raise EInvalidOp.CreateResFmt(@RsTempConvTypeError, [cToType]);\r\n end;\r\n end;\r\n { All conversions from Kelvin to other formats are listed here }\r\n ttKelvin:\r\n begin\r\n case ToType of\r\n ttCelsius:\r\n Result := KelvinToCelsius(Temperature);\r\n ttFahrenheit:\r\n Result := KelvinToFahrenheit(Temperature);\r\n ttRankine:\r\n Result := KelvinToRankine(Temperature);\r\n ttReaumur:\r\n Result := KelvinToReaumur(Temperature);\r\n else\r\n raise EInvalidOp.CreateResFmt(@RsTempConvTypeError, [cToType]);\r\n end;\r\n end;\r\n { All conversions from Kelvin to other formats are listed here }\r\n ttRankine:\r\n begin\r\n case ToType of\r\n ttCelsius:\r\n Result := RankineToCelsius(Temperature);\r\n ttFahrenheit:\r\n Result := RankineToFahrenheit(Temperature);\r\n ttKelvin:\r\n Result := RankineToKelvin(Temperature);\r\n ttReaumur:\r\n Result := RankineToReaumur(Temperature);\r\n else\r\n raise EInvalidOp.CreateResFmt(@RsTempConvTypeError, [cToType]);\r\n end;\r\n end;\r\n { All conversions from Reaumur to other formats are listed here }\r\n ttReaumur:\r\n begin\r\n case ToType of\r\n ttCelsius:\r\n Result := ReaumurToCelsius(Temperature);\r\n ttFahrenheit:\r\n Result := ReaumurToFahrenheit(Temperature);\r\n ttKelvin:\r\n Result := ReaumurToKelvin(Temperature);\r\n ttRankine:\r\n Result := ReaumurToRankine(Temperature);\r\n else\r\n raise EInvalidOp.CreateResFmt(@RsTempConvTypeError, [cToType]);\r\n end;\r\n end;\r\n else\r\n raise EInvalidOp.CreateResFmt(@RsTempConvTypeError, [cFromType]);\r\n end;\r\nend;\r\n\r\nfunction CelsiusTo(ToType: TTemperatureType; const Temperature: Float): Float;\r\nbegin\r\n Result := ConvertTemperature(ttCelsius, ToType, Temperature);\r\nend;\r\n\r\nfunction FahrenheitTo(ToType: TTemperatureType; const Temperature: Float): Float;\r\nbegin\r\n Result := ConvertTemperature(ttFahrenheit, ToType, Temperature);\r\nend;\r\n\r\nfunction KelvinTo(ToType: TTemperatureType; const Temperature: Float): Float;\r\nbegin\r\n Result := ConvertTemperature(ttKelvin, ToType, Temperature);\r\nend;\r\n\r\nfunction RankineTo(ToType: TTemperatureType; const Temperature: Float): Float;\r\nbegin\r\n Result := ConvertTemperature(ttRankine, ToType, Temperature);\r\nend;\r\n\r\nfunction ReaumurTo(ToType: TTemperatureType; const Temperature: Float): Float;\r\nbegin\r\n Result := ConvertTemperature(ttReaumur, ToType, Temperature);\r\nend;\r\n\r\n//=== Angle conversion =======================================================\r\n\r\nfunction CycleToDeg(const Cycles: Float): Float;\r\nbegin\r\n Result := Cycles * DegPerCycle;\r\nend;\r\n\r\nfunction CycleToGrad(const Cycles: Float): Float;\r\nbegin\r\n Result := Cycles * GradPerCycle;\r\nend;\r\n\r\nfunction CycleToRad(const Cycles: Float): Float;\r\nbegin\r\n Result := Cycles * RadPerCycle;\r\nend;\r\n\r\nfunction DegToGrad(const Degrees: Float): Float;\r\nbegin\r\n Result := Degrees * GradPerDeg;\r\nend;\r\n\r\nfunction DegToCycle(const Degrees: Float): Float;\r\nbegin\r\n Result := Degrees * CyclePerDeg;\r\nend;\r\n\r\nfunction DegToRad(const Degrees: Float): Float;\r\nbegin\r\n Result := Degrees * RadPerDeg;\r\nend;\r\n\r\nfunction GradToCycle(const Grads: Float): Float;\r\nbegin\r\n Result := Grads * CyclePerGrad;\r\nend;\r\n\r\nfunction GradToDeg(const Grads: Float): Float;\r\nbegin\r\n Result := Grads * DegPerGrad;\r\nend;\r\n\r\nfunction GradToRad(const Grads: Float): Float;\r\nbegin\r\n Result := Grads * RadPerGrad;\r\nend;\r\n\r\nfunction RadToCycle(const Radians: Float): Float;\r\nbegin\r\n Result := Radians * CyclePerRad;\r\nend;\r\n\r\nfunction RadToDeg(const Radians: Float): Float;\r\nbegin\r\n Result := Radians * DegPerRad;\r\nend;\r\n\r\nfunction RadToGrad(const Radians: Float): Float;\r\nbegin\r\n Result := Radians * GradPerRad;\r\nend;\r\n\r\nfunction DmsToDeg(const D, M: Integer; const S: Float): Float;\r\nbegin\r\n DomainCheck((M < 0) or (M > 60) or (S < 0.0) or (S > 60.0));\r\n Result := Abs(D) + M * DegPerArcMinute + S * DegPerArcSecond;\r\n if D < 0 then\r\n Result := -Result;\r\nend;\r\n\r\nfunction DmsToRad(const D, M: Integer; const S: Float): Float;\r\nbegin\r\n Result := DegToRad(DmsToDeg(D, M, S));\r\nend;\r\n\r\nprocedure DegToDms(const Degrees: Float; out D, M: Integer; out S: Float);\r\nvar\r\n DD, MM: Float;\r\nbegin\r\n DD := Abs(Degrees);\r\n MM := Frac(DD) * ArcMinutesPerDeg;\r\n D := Trunc(DD);\r\n M := Trunc(MM);\r\n S := Frac(MM) * ArcSecondsPerArcMinute;\r\n if Degrees < 0 then\r\n D := -D;\r\nend;\r\n\r\nfunction DegToDmsStr(const Degrees: Float; const SecondPrecision: Cardinal = 3): string;\r\nvar\r\n D, M: Integer;\r\n S: Float;\r\nbegin\r\n DegToDMS(Degrees, D, M, S);\r\n Result := Format('%d %d'' %.*f\"', [D, M, SecondPrecision, S]);\r\nend;\r\n\r\n//=== Coordinate conversion ==================================================\r\n\r\nprocedure CartesianToCylinder(const X, Y, Z: Float; out R, Phi, Zeta: Float);\r\nbegin\r\n Zeta := Z;\r\n CartesianToPolar(X, Y, R, Phi);\r\nend;\r\n\r\nprocedure CartesianToPolar(const X, Y: Float; out R, Phi: Float);\r\nbegin\r\n R := Sqrt(Sqr(X) + Sqr(Y));\r\n Phi := ArcTan2(Y, X);\r\n if Phi < 0 then\r\n Phi := Phi + TwoPi;\r\nend;\r\n\r\nprocedure CartesianToSpheric(const X, Y, Z: Float; out Rho, Phi, Theta: Float);\r\nbegin\r\n Rho := Sqrt(X*X + Y*Y + Z*Z);\r\n Phi := ArcTan2(Y, X);\r\n if Phi < 0 then\r\n Phi := Phi + TwoPi;\r\n Theta := 0;\r\n if Rho > 0 then\r\n Theta := ArcCos(Z/Rho);\r\nend;\r\n\r\nprocedure CylinderToCartesian(const R, Phi, Zeta: Float; out X, Y, Z: Float);\r\nvar\r\n Sine, CoSine: Float;\r\nbegin\r\n SinCos(Phi, Sine, Cosine);\r\n X := R * CoSine;\r\n Y := R * Sine;\r\n Z := Zeta;\r\nend;\r\n\r\nprocedure PolarToCartesian(const R, Phi: Float; out X, Y: Float);\r\nvar\r\n Sine, CoSine: Float;\r\nbegin\r\n SinCos(Phi, Sine, CoSine);\r\n X := R * CoSine;\r\n Y := R * Sine;\r\nend;\r\n\r\nprocedure SphericToCartesian(const Rho, Theta, Phi: Float; out X, Y, Z: Float);\r\nvar\r\n SineTheta, CoSineTheta: Float;\r\n SinePhi, CoSinePhi: Float;\r\nbegin\r\n SinCos(Theta, SineTheta, CoSineTheta);\r\n SinCos(Phi, SinePhi, CoSinePhi);\r\n X := Rho * SineTheta * CoSinePhi;\r\n Y := Rho * SineTheta * SinePhi;\r\n Z := Rho * CoSineTheta;\r\nend;\r\n\r\n//=== Length conversion ======================================================\r\n\r\nfunction CmToInch(const Cm: Float): Float;\r\nbegin\r\n Result := Cm / 2.54;\r\nend;\r\n\r\nfunction InchToCm(const Inch: Float): Float;\r\nbegin\r\n Result := Inch * 2.54;\r\nend;\r\n\r\nfunction FeetToMetre(const Feet: Float): Float;\r\nbegin\r\n Result := Feet * 0.3048;\r\nend;\r\n\r\nfunction MetreToFeet(const Metre: Float): Float;\r\nbegin\r\n Result := Metre / 0.3048;\r\nend;\r\n\r\nfunction YardToMetre(const Yard: Float): Float;\r\nbegin\r\n Result := Yard * 0.9144;\r\nend;\r\n\r\nfunction MetreToYard(const Metre: Float): Float;\r\nbegin\r\n Result := Metre / 0.9144;\r\nend;\r\n\r\nfunction NmToKm(const Nm: Float): Float;\r\nbegin\r\n Result := Nm * 1.852;\r\nend;\r\n\r\nfunction KmToNm(const Km: Float): Float;\r\nbegin\r\n Result := Km / 1.852;\r\nend;\r\n\r\nfunction KmToSm(const Km: Float): Float;\r\nbegin\r\n Result := Km / 1.609344;\r\nend;\r\n\r\nfunction SmToKm(const Sm: Float): Float;\r\nbegin\r\n Result := Sm * 1.609344;\r\nend;\r\n\r\n//=== Volume conversion ======================================================\r\n\r\nfunction LitreToGalUs(const Litre: Float): Float;\r\nbegin\r\n Result := Litre / 3.785411784;\r\nend;\r\n\r\nfunction GalUsToLitre(const GalUs: Float): Float;\r\nbegin\r\n Result := GalUs * 3.785411784;\r\nend;\r\n\r\nfunction GalUsToGalCan(const GalUs: Float): Float;\r\nbegin\r\n Result := GalUs / 1.2009499255;\r\nend;\r\n\r\nfunction GalCanToGalUs(const GalCan: Float): Float;\r\nbegin\r\n Result := GalCan * 1.2009499255;\r\nend;\r\n\r\nfunction GalUsToGalUk(const GalUs: Float): Float;\r\nbegin\r\n Result := GalUs / 1.20095045385;\r\nend;\r\n\r\nfunction GalUkToGalUs(const GalUk: Float): Float;\r\nbegin\r\n Result := GalUk * 1.20095045385;\r\nend;\r\n\r\nfunction LitreToGalCan(const Litre: Float): Float;\r\nbegin\r\n Result := Litre / 4.54609;\r\nend;\r\n\r\nfunction GalCanToLitre(const GalCan: Float): Float;\r\nbegin\r\n Result := GalCan * 4.54609;\r\nend;\r\n\r\nfunction LitreToGalUk(const Litre: Float): Float;\r\nbegin\r\n Result := Litre / 4.54609;\r\nend;\r\n\r\nfunction GalUkToLitre(const GalUk: Float): Float;\r\nbegin\r\n Result := GalUk * 4.54609;\r\nend;\r\n\r\n//=== Mass conversion ========================================================\r\n\r\nfunction KgToLb(const Kg: Float): Float;\r\nbegin\r\n Result := Kg / 0.45359237;\r\nend;\r\n\r\nfunction LbToKg(const Lb: Float): Float;\r\nbegin\r\n Result := Lb * 0.45359237;\r\nend;\r\n\r\nfunction KgToOz(const Kg: Float): Float;\r\nbegin\r\n Result := Kg * 35.2739619496;\r\nend;\r\n\r\nfunction OzToKg(const Oz: Float): Float;\r\nbegin\r\n Result := Oz / 35.2739619496;\r\nend;\r\n\r\nfunction QrUsToKg(const Qr: Float) : Float;\r\nbegin\r\n Result := Qr * 11.34;\r\nend;\r\n\r\nfunction QrUkToKg(const Qr: Float) : Float;\r\nbegin\r\n Result := Qr * 12.7;\r\nend;\r\n\r\nfunction KgToQrUs(const Kg: Float) : Float;\r\nbegin\r\n Result := Kg / 11.34;\r\nend;\r\n\r\nfunction KgToQrUk(const Kg: Float) : Float;\r\nbegin\r\n Result := Kg / 12.7;\r\nend;\r\n\r\nfunction CwtUsToKg(const Cwt: Float) : Float;\r\nbegin\r\n Result := Cwt * 45.35924;\r\nend;\r\n\r\nfunction CwtUkToKg(const Cwt: Float) : Float;\r\nbegin\r\n Result := Cwt * 50.80235;\r\nend;\r\n\r\nfunction KgToCwtUs(const Kg: Float) : Float;\r\nbegin\r\n Result := Kg / 45.35924;\r\nend;\r\n\r\nfunction KgToCwtUk(const Kg: Float) : Float;\r\nbegin\r\n Result := Kg / 50.80235;\r\nend;\r\n\r\nfunction LtonToKg(const Lton: Float) : Float;\r\nbegin\r\n Result := Lton * 1016.047;\r\nend;\r\n\r\nfunction StonToKg(const Ston: Float) : Float;\r\nbegin\r\n Result := Ston * 907.1847;\r\nend;\r\n\r\nfunction KgToLton(const Kg: Float) : Float;\r\nbegin\r\n Result := Kg / 1016.047;\r\nend;\r\n\r\nfunction KgToSton(const Kg: Float) : Float;\r\nbegin\r\n Result := Kg / 907.1847;\r\nend;\r\n\r\nfunction KgToKarat(const Kg: Float) : Float;\r\nbegin\r\n Result := Kg / 0.0002;\r\nend;\r\n\r\nfunction KaratToKg(const Karat: Float) : Float;\r\nbegin\r\n Result := Karat * 0.0002;\r\nend;\r\n\r\n\r\n//=== Pressure conversion ====================================================\r\n\r\nfunction PascalToBar(const Pa: Float): Float;\r\nbegin\r\n Result := Pa / 100000.0;\r\nend;\r\n\r\nfunction PascalToAt(const Pa: Float): Float;\r\nbegin\r\n Result := Pa / (9.80665 * 10000.0);\r\nend;\r\n\r\nfunction PascalToTorr(const Pa: Float): Float;\r\nbegin\r\n Result := Pa / 133.3224;\r\nend;\r\n\r\nfunction BarToPascal(const Bar: Float): Float;\r\nbegin\r\n Result := Bar * 100000.0;\r\nend;\r\n\r\nfunction AtToPascal(const At: Float): Float;\r\nbegin\r\n Result := At * (9.80665 * 10000.0);\r\nend;\r\n\r\nfunction TorrToPascal(const Torr: Float): Float;\r\nbegin\r\n Result := Torr * 133.3224;\r\nend;\r\n\r\n//=== Other conversion =======================================================\r\n\r\nfunction KnotToMs(const Knot: Float): Float;\r\nbegin\r\n Result := Knot * 0.514444444444;\r\nend;\r\n\r\nfunction HpElectricToWatt(const HpE: Float): Float;\r\nbegin\r\n Result := HpE * 746.0;\r\nend;\r\n\r\nfunction HpMetricToWatt(const HpM: Float): Float;\r\nbegin\r\n Result := HpM * 735.4988;\r\nend;\r\n\r\nfunction MsToKnot(const Ms: Float): Float;\r\nbegin\r\n Result := Ms / 0.514444444444;\r\nend;\r\n\r\nfunction WattToHpElectric(const W: Float): Float;\r\nbegin\r\n Result := W / 746.0;\r\nend;\r\n\r\nfunction WattToHpMetric(const W: Float): Float;\r\nbegin\r\n Result := W / 735.4988;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jcl/source/common/JclUnitVersioning.pas", "content": "{**************************************************************************************************}\r\n{ }\r\n{ Project JEDI Code Library (JCL) }\r\n{ }\r\n{ The contents of this file are subject to the Mozilla Public License Version 1.1 (the \"License\"); }\r\n{ you may not use this file except in compliance with the License. You may obtain a copy of the }\r\n{ License at http://www.mozilla.org/MPL/ }\r\n{ }\r\n{ Software distributed under the License is distributed on an \"AS IS\" basis, WITHOUT WARRANTY OF }\r\n{ ANY KIND, either express or implied. See the License for the specific language governing rights }\r\n{ and limitations under the License. }\r\n{ }\r\n{ The Original Code is JclUnitVersioning.pas. }\r\n{ }\r\n{ The Initial Developer of the Original Code is Andreas Hausladen. }\r\n{ Portions created by Andreas Hausladen are Copyright (C) Andreas Hausladen. All rights reserved. }\r\n{ }\r\n{ Contributor(s): }\r\n{ Andreas Hausladen (ahuser) }\r\n{ }\r\n{**************************************************************************************************}\r\n{ }\r\n{ A unit version information system. It collects information from prepared units by each module. }\r\n{ It also works with units in DLLs. }\r\n{ }\r\n{**************************************************************************************************}\r\n{ }\r\n{ Last modified: $Date:: 2012-09-04 16:08:04 +0200 (mar. 04 sept. 2012) $ }\r\n{ Revision: $Rev:: 3861 $ }\r\n{ Author: $Author:: outchy $ }\r\n{ }\r\n{**************************************************************************************************}\r\n\r\nunit JclUnitVersioning;\r\n\r\n{$I jcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF HAS_UNIT_LIBC}\r\n Libc,\r\n {$ENDIF HAS_UNIT_LIBC}\r\n {$IFDEF HAS_UNITSCOPE}\r\n {$IFDEF MSWINDOWS}\r\n Winapi.Windows,\r\n {$ENDIF MSWINDOWS}\r\n System.SysUtils, System.Contnrs;\r\n {$ELSE ~HAS_UNITSCOPE}\r\n {$IFDEF MSWINDOWS}\r\n Windows,\r\n {$ENDIF MSWINDOWS}\r\n SysUtils, Contnrs;\r\n {$ENDIF ~HAS_UNITSCOPE}\r\n\r\ntype\r\n PUnitVersionInfo = ^TUnitVersionInfo;\r\n TUnitVersionInfo = record\r\n RCSfile: PChar; // $'RCSfile$\r\n Revision: PChar; // $'Revision$\r\n Date: PChar; // $'Date$ in UTC (GMT)\r\n LogPath: PChar; // logical file path\r\n Extra: PChar; // user defined string\r\n Data: Pointer; // user data\r\n end;\r\n\r\n TUnitVersion = class(TObject)\r\n private\r\n FInfo: PUnitVersionInfo;\r\n public\r\n constructor Create(AInfo: PUnitVersionInfo);\r\n function RCSfile: string;\r\n function Revision: string;\r\n function Date: string;\r\n function Extra: string;\r\n function LogPath: string;\r\n function Data: Pointer;\r\n function DateTime: TDateTime;\r\n function Summary: string;\r\n end;\r\n\r\n TUnitVersioningModule = class(TObject)\r\n private\r\n FInstance: THandle;\r\n FItems: TObjectList;\r\n\r\n function GetItems(Index: Integer): TUnitVersion;\r\n function GetCount: Integer;\r\n\r\n procedure Add(Info: PUnitVersionInfo);\r\n function IndexOfInfo(Info: PUnitVersionInfo): Integer;\r\n public\r\n constructor Create(AInstance: THandle);\r\n destructor Destroy; override;\r\n\r\n function IndexOf(const RCSfile: string; const LogPath: string = '*'): Integer;\r\n function FindUnit(const RCSfile: string; const LogPath: string = '*'): TUnitVersion;\r\n\r\n property Instance: THandle read FInstance;\r\n property Count: Integer read GetCount;\r\n property Items[Index: Integer]: TUnitVersion read GetItems; default;\r\n end;\r\n\r\n TCustomUnitVersioningProvider = class(TObject)\r\n public\r\n constructor Create; virtual;\r\n procedure LoadModuleUnitVersioningInfo(Instance: THandle); virtual;\r\n procedure ReleaseModuleUnitVersioningInfo(Instance: THandle); virtual;\r\n end;\r\n\r\n TUnitVersioningProviderClass = class of TCustomUnitVersioningProvider;\r\n\r\n TUnitVersioning = class(TObject)\r\n private\r\n FModules: TObjectList;\r\n FProviders: TObjectList;\r\n\r\n function GetItem(Index: Integer): TUnitVersion;\r\n function GetCount: Integer;\r\n function GetModuleCount: Integer;\r\n function GetModule(Index: Integer): TUnitVersioningModule;\r\n\r\n procedure UnregisterModule(Module: TUnitVersioningModule); overload;\r\n procedure ValidateModules;\r\n // These two methods must be virtual because they can be invoked by a DLL.\r\n // Static linking would mean that the DLL's TUnitVersioning methods handle\r\n // the call which leads to an access violation.\r\n procedure Add(Instance: THandle; Info: PUnitVersionInfo); virtual;\r\n procedure UnregisterModule(Instance: THandle); overload; virtual;\r\n public\r\n constructor Create;\r\n destructor Destroy; override;\r\n\r\n procedure RegisterProvider(AProviderClass: TUnitVersioningProviderClass);\r\n procedure LoadModuleUnitVersioningInfo(Instance: THandle);\r\n\r\n function IndexOf(const RCSfile: string; const LogPath: string = '*'): Integer;\r\n function FindUnit(const RCSfile: string; const LogPath: string = '*'): TUnitVersion;\r\n\r\n // units by modules\r\n property ModuleCount: Integer read GetModuleCount;\r\n property Modules[Index: Integer]: TUnitVersioningModule read GetModule;\r\n\r\n // all units\r\n property Count: Integer read GetCount;\r\n property Items[Index: Integer]: TUnitVersion read GetItem; default;\r\n end;\r\n\r\nprocedure RegisterUnitVersion(Instance: THandle; const Info: TUnitVersionInfo);\r\nprocedure UnregisterUnitVersion(Instance: THandle);\r\n\r\nfunction GetUnitVersioning: TUnitVersioning;\r\n\r\nprocedure ExportUnitVersioningToFile(iFileName : string);\r\n\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jcl.svn.sourceforge.net/svnroot/jcl/tags/JCL-2.4-Build4571/jcl/source/common/JclUnitVersioning.pas $';\r\n Revision: '$Revision: 3861 $';\r\n Date: '$Date: 2012-09-04 16:08:04 +0200 (mar. 04 sept. 2012) $';\r\n LogPath: 'JCL\\source\\common';\r\n Extra: '';\r\n Data: nil\r\n );\r\n\r\nimplementation\r\n\r\nuses\r\n // make TObjectList functions inlined\r\n {$IFDEF HAS_UNITSCOPE}\r\n System.Types, // inlining of TObjectList.Remove\r\n System.Classes,\r\n {$ELSE ~HAS_UNITSCOPE}\r\n Classes,\r\n {$ENDIF ~HAS_UNITSCOPE}\r\n JclSysUtils, JclSynch;\r\n\r\n// Delphi 5 does not know this function //(usc) D6/7 Per does have StartsWith\r\n// a fast version of Pos(SubStr, S) = 1\r\nfunction StartsWith(const SubStr, S: string): Boolean;\r\nvar\r\n I, Len: Integer;\r\nbegin\r\n Result := False;\r\n Len := Length(SubStr);\r\n if Len <= Length(S) then\r\n begin\r\n for I := 1 to Len do\r\n if S[I] <> SubStr[I] then\r\n Exit;\r\n Result := True;\r\n end;\r\nend;\r\n\r\nfunction CompareFilenames(const Fn1, Fn2: string): Integer;\r\nbegin\r\n {$IFDEF MSWINDOWS}\r\n Result := CompareText(Fn1, Fn2);\r\n {$ENDIF MSWINDOWS}\r\n {$IFDEF UNIX}\r\n Result := CompareStr(Fn1, Fn2);\r\n {$ENDIF UNIX}\r\nend;\r\n\r\n//=== { TUnitVersion } =======================================================\r\n\r\nconstructor TUnitVersion.Create(AInfo: PUnitVersionInfo);\r\nbegin\r\n inherited Create;\r\n FInfo := AInfo;\r\nend;\r\n\r\nfunction TUnitVersion.RCSfile: string;\r\nvar\r\n I, P: Integer;\r\nbegin\r\n Result := Trim(FInfo.RCSfile);\r\n // the + is to have CVS not touch the string\r\n if StartsWith('$' + 'RCSfile: ', Result) then // a CVS command\r\n begin\r\n Delete(Result, 1, 10);\r\n Delete(Result, Length(Result) - 1, 2);\r\n for I := Length(Result) downto 1 do\r\n if Result[I] = ',' then\r\n begin\r\n Delete(Result, I, MaxInt);\r\n Break;\r\n end;\r\n end;\r\n // the + is to have SVN not touch the string\r\n if StartsWith('$' + 'URL: ', Result) then // a SVN command\r\n begin\r\n Delete(Result, 1, 6);\r\n Delete(Result, Length(Result) - 1, 2);\r\n { TODO -oUSc : Is there any need for a function that returns the URL? }\r\n P := Pos('/', Result);\r\n while P > 0 do\r\n begin\r\n Delete(Result, 1, P);\r\n P := Pos('/', Result);\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TUnitVersion.Revision: string;\r\nbegin\r\n Result := Trim(FInfo.Revision);\r\n if StartsWith('$' + 'Revision: ', Result) then // a CVS command\r\n Result := Copy(Result, 12, Length(Result) - 11 - 2);\r\nend;\r\n\r\nfunction TUnitVersion.Date: string;\r\nbegin\r\n Result := Trim(FInfo.Date);\r\n if StartsWith('$' + 'Date: ', Result) then // a CVS command\r\n begin\r\n Delete(Result, 1, 7);\r\n Delete(Result, Length(Result) - 1, 2);\r\n end;\r\nend;\r\n\r\nfunction TUnitVersion.Data: Pointer;\r\nbegin\r\n Result := FInfo.Data;\r\nend;\r\n\r\nfunction TUnitVersion.Extra: string;\r\nbegin\r\n Result := Trim(FInfo.Extra);\r\nend;\r\n\r\nfunction TUnitVersion.LogPath: string;\r\nbegin\r\n Result := Trim(FInfo.LogPath);\r\nend;\r\n\r\nfunction TUnitVersion.DateTime: TDateTime;\r\nvar\r\n Ps: Integer;\r\n S: string;\r\n Error: Integer;\r\n Year, Month, Day, Hour, Minute, Second: Word;\r\n TimeSep: Char;\r\nbegin\r\n Result := 0;\r\n S := Date;\r\n\r\n // date: yyyy/mm/dd | yyyy-mm-dd | mm/dd/yyyy | mm-dd-yyyy | dd.mm.yyyy\r\n Ps := Pos('/', S);\r\n if Ps = 0 then\r\n Ps := Pos('-', S);\r\n if Ps <> 0 then\r\n begin\r\n if Ps = 5 then\r\n begin\r\n // yyyy/mm/dd | yyyy-mm-dd\r\n Val(Copy(S, 1, 4), Year, Error);\r\n Val(Copy(S, 6, 2), Month, Error);\r\n Val(Copy(S, 9, 2), Day, Error);\r\n end\r\n else\r\n begin\r\n // mm/dd/yyyy | mm-dd-yyyy\r\n Val(Copy(S, 1, 2), Month, Error);\r\n Val(Copy(S, 4, 2), Day, Error);\r\n Val(Copy(S, 7, 4), Year, Error);\r\n end;\r\n end\r\n else\r\n begin\r\n Ps := Pos('.', S);\r\n if Ps <> 0 then\r\n begin\r\n // dd.mm.yyyy\r\n Val(Copy(S, 1, 2), Day, Error);\r\n Val(Copy(S, 4, 2), Month, Error);\r\n Val(Copy(S, 7, 4), Year, Error);\r\n end\r\n else\r\n Exit;\r\n end;\r\n\r\n // time: hh:mm:ss | hh/mm/ss\r\n Ps := Pos(' ', S);\r\n S := Trim(Copy(S, Ps + 1, MaxInt));\r\n\r\n Ps := Pos(':', S);\r\n if Ps <> 0 then\r\n TimeSep := ':'\r\n else\r\n begin\r\n Ps := Pos('/', S);\r\n TimeSep := '/';\r\n end;\r\n Val(Copy(S, 1, Ps - 1), Hour, Error);\r\n Delete(S, 1, Ps);\r\n Ps := Pos(TimeSep, S);\r\n Val(Copy(S, 1, Ps - 1), Minute, Error);\r\n Delete(S, 1, Ps);\r\n Ps := Pos(TimeSep, S);\r\n if Ps = 0 then\r\n Ps := Length(S) + 1;\r\n Val(Copy(S, 1, Ps - 1), Second, Error);\r\n\r\n Result := EncodeDate(Year, Month, Day) + EncodeTime(Hour, Minute, Second, 0);\r\nend;\r\n\r\nfunction TUnitVersion.Summary: string;\r\nbegin\r\n Result := LogPath + #9 + RCSFile + #9 + Revision + #9 + Date;\r\n if Extra <> '' then\r\n Result := Result + #9 + Extra;\r\nend;\r\n\r\n//=== { TUnitVersioningModule } ==============================================\r\n\r\nconstructor TUnitVersioningModule.Create(AInstance: THandle);\r\nbegin\r\n inherited Create;\r\n FInstance := AInstance;\r\n FItems := TObjectList.Create;\r\nend;\r\n\r\ndestructor TUnitVersioningModule.Destroy;\r\nbegin\r\n FItems.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TUnitVersioningModule.GetCount: Integer;\r\nbegin\r\n Result := FItems.Count;\r\nend;\r\n\r\nfunction TUnitVersioningModule.GetItems(Index: Integer): TUnitVersion;\r\nbegin\r\n Result := TUnitVersion(FItems[Index]);\r\nend;\r\n\r\nprocedure TUnitVersioningModule.Add(Info: PUnitVersionInfo);\r\nbegin\r\n FItems.Add(TUnitVersion.Create(Info));\r\nend;\r\n\r\nfunction TUnitVersioningModule.IndexOfInfo(Info: PUnitVersionInfo): Integer;\r\nbegin\r\n for Result := 0 to FItems.Count - 1 do\r\n if Items[Result].FInfo = Info then\r\n Exit;\r\n Result := -1;\r\nend;\r\n\r\nfunction TUnitVersioningModule.FindUnit(const RCSfile: string; const LogPath: string): TUnitVersion;\r\nvar\r\n Index: Integer;\r\nbegin\r\n Index := IndexOf(RCSfile, LogPath);\r\n if Index <> -1 then\r\n Result := Items[Index]\r\n else\r\n Result := nil;\r\nend;\r\n\r\nfunction TUnitVersioningModule.IndexOf(const RCSfile: string; const LogPath: string): Integer;\r\nvar\r\n Item: TUnitVersion;\r\nbegin\r\n for Result := 0 to FItems.Count - 1 do\r\n begin\r\n Item := Items[Result];\r\n if CompareFilenames(Item.RCSfile, RCSfile) = 0 then\r\n if LogPath = '*' then\r\n Exit\r\n else\r\n if CompareFilenames(LogPath, Trim(Item.LogPath)) = 0 then\r\n Exit;\r\n end;\r\n Result := -1;\r\nend;\r\n\r\n//=== { TCustomUnitVersioningProvider } ======================================\r\n\r\nconstructor TCustomUnitVersioningProvider.Create;\r\nbegin\r\n inherited Create;\r\nend;\r\n\r\nprocedure TCustomUnitVersioningProvider.LoadModuleUnitVersioningInfo(Instance: THandle);\r\nbegin\r\n//\r\nend;\r\n\r\nprocedure TCustomUnitVersioningProvider.ReleaseModuleUnitVersioningInfo(Instance: THandle);\r\nbegin\r\n//\r\nend;\r\n\r\n//=== { TUnitVersioning } ====================================================\r\n\r\nconstructor TUnitVersioning.Create;\r\nbegin\r\n inherited Create;\r\n FModules := TObjectList.Create;\r\n FProviders := TObjectList.Create;\r\nend;\r\n\r\ndestructor TUnitVersioning.Destroy;\r\nbegin\r\n FProviders.Free;\r\n FModules.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TUnitVersioning.Add(Instance: THandle; Info: PUnitVersionInfo);\r\nvar\r\n I: Integer;\r\n Module: TUnitVersioningModule;\r\nbegin\r\n for I := 0 to FModules.Count - 1 do\r\n begin\r\n Module := Modules[I];\r\n if Module.Instance = Instance then\r\n begin\r\n if Module.IndexOfInfo(Info) = -1 then\r\n Module.Add(Info);\r\n Exit;\r\n end;\r\n end;\r\n // create a new module entry\r\n Module := TUnitVersioningModule.Create(Instance);\r\n FModules.Add(Module);\r\n Module.Add(Info);\r\nend;\r\n\r\nprocedure TUnitVersioning.UnregisterModule(Instance: THandle);\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := FModules.Count - 1 downto 0 do\r\n if Modules[I].Instance = Instance then\r\n begin\r\n FModules.Delete(I);\r\n Break;\r\n end;\r\n for I := 0 to FProviders.Count -1 do\r\n TCustomUnitVersioningProvider(FProviders[I]).ReleaseModuleUnitVersioningInfo(Instance);\r\nend;\r\n\r\nprocedure TUnitVersioning.UnregisterModule(Module: TUnitVersioningModule);\r\nbegin\r\n FModules.Remove(Module);\r\nend;\r\n\r\nfunction TUnitVersioning.GetCount: Integer;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := 0;\r\n ValidateModules;\r\n for I := 0 to FModules.Count - 1 do\r\n Inc(Result, Modules[I].Count);\r\nend;\r\n\r\nfunction TUnitVersioning.GetItem(Index: Integer): TUnitVersion;\r\nvar\r\n Cnt, I: Integer;\r\n Module: TUnitVersioningModule;\r\nbegin\r\n Result := nil;\r\n ValidateModules;\r\n Cnt := 0;\r\n for I := 0 to FModules.Count - 1 do\r\n begin\r\n Module := Modules[I];\r\n if Index < Cnt + Module.Count then\r\n begin\r\n Result := Module.Items[Index - Cnt];\r\n Break;\r\n end;\r\n Inc(Cnt, Module.Count);\r\n end;\r\nend;\r\n\r\nfunction TUnitVersioning.GetModuleCount: Integer;\r\nbegin\r\n ValidateModules;\r\n Result := FModules.Count;\r\nend;\r\n\r\nfunction TUnitVersioning.GetModule(Index: Integer): TUnitVersioningModule;\r\nbegin\r\n Result := TUnitVersioningModule(FModules[Index]);\r\nend;\r\n\r\n{$UNDEF FPCUNIX} // Temporary, will move to .inc's in time.\r\n{$IFDEF FPC}\r\n {$IFDEF UNIX}\r\n {$DEFIN FPCUNIX}\r\n{$ENDIF}\r\n{$ENDIF}\r\n\r\nprocedure TUnitVersioning.ValidateModules;\r\nvar\r\n I: Integer;\r\n {$IFNDEF FPCUNIX}\r\n Buffer: string;\r\n {$ENDIF ~FPCUNIX}\r\n Module: TUnitVersioningModule;\r\nbegin\r\n {$IFNDEF FPCUNIX}\r\n SetLength(Buffer, 1024);\r\n {$ENDIF ~FPCUNIX}\r\n for I := FModules.Count - 1 downto 0 do\r\n begin\r\n Module := Modules[I];\r\n {$IFDEF FPCUNIX}\r\n if dlsym(Pointer(Module.Instance), '_init') = nil then\r\n {$ELSE ~FPCUNIX}\r\n if GetModuleFileName(Module.Instance, PChar(Buffer), 1024) = 0 then\r\n {$ENDIF ~FPCUNIX}\r\n // This module is no more in memory but has not unregistered itself so\r\n // unregister it here.\r\n UnregisterModule(Module);\r\n end;\r\nend;\r\n\r\nfunction TUnitVersioning.FindUnit(const RCSfile: string; const LogPath: string): TUnitVersion;\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := 0 to FModules.Count - 1 do\r\n begin\r\n Result := Modules[I].FindUnit(RCSfile, LogPath);\r\n if Result <> nil then\r\n Exit;\r\n end;\r\n Result := nil;\r\nend;\r\n\r\nfunction TUnitVersioning.IndexOf(const RCSfile: string; const LogPath: string): Integer;\r\nvar\r\n I, Cnt, Index: Integer;\r\n Module: TUnitVersioningModule;\r\nbegin\r\n Result := -1;\r\n Cnt := 0;\r\n for I := 0 to FModules.Count - 1 do\r\n begin\r\n Module := Modules[I];\r\n Index := Module.IndexOf(RCSfile, LogPath);\r\n if Index <> -1 then\r\n begin\r\n Result := Cnt + Index;\r\n Break;\r\n end;\r\n Inc(Cnt, Module.Count);\r\n end;\r\nend;\r\n\r\nprocedure TUnitVersioning.RegisterProvider(AProviderClass: TUnitVersioningProviderClass);\r\nvar\r\n I, Idx: Integer;\r\nbegin\r\n Idx := -1;\r\n for I := 0 to FProviders.Count - 1 do\r\n if TObject(FProviders[I]).ClassType = AProviderClass then\r\n begin\r\n Idx := I;\r\n Break;\r\n end;\r\n if Idx = -1 then\r\n FProviders.Add(AProviderClass.Create);\r\nend;\r\n\r\nprocedure TUnitVersioning.LoadModuleUnitVersioningInfo(Instance: THandle);\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := 0 to FProviders.Count - 1 do\r\n TCustomUnitVersioningProvider(FProviders[I]).LoadModuleUnitVersioningInfo(Instance);\r\nend;\r\n\r\ntype\r\n PUnitVersioning = ^TUnitVersioning;\r\n\r\nvar\r\n UnitVersioningOwner: Boolean = False;\r\n GlobalUnitVersioning: TUnitVersioning = nil;\r\n UnitVersioningNPA: PUnitVersioning = nil;\r\n UnitVersioningMutex: TJclMutex;\r\n UnitVersioningFinalized: Boolean = False;\r\n\r\nfunction GetUnitVersioning: TUnitVersioning;\r\nbegin\r\n if UnitVersioningFinalized then\r\n begin\r\n Result := nil;\r\n Exit;\r\n end;\r\n\r\n if UnitVersioningMutex = nil then\r\n UnitVersioningMutex := TJclMutex.Create(nil, False, 'MutexNPA_UnitVersioning_' + IntToStr(GetCurrentProcessId));\r\n\r\n if GlobalUnitVersioning = nil then\r\n begin\r\n UnitVersioningMutex.WaitFor(INFINITE);\r\n try\r\n if UnitVersioningNPA = nil then\r\n SharedGetMem(UnitVersioningNPA, 'ShmNPA_UnitVersioning_' + IntToStr(GetCurrentProcessId), SizeOf(TUnitVersioning));\r\n if UnitVersioningNPA <> nil then\r\n begin\r\n GlobalUnitVersioning := UnitVersioningNPA^;\r\n if GlobalUnitVersioning = nil then\r\n begin\r\n GlobalUnitVersioning := TUnitVersioning.Create;\r\n UnitVersioningNPA^ := GlobalUnitVersioning;\r\n UnitVersioningOwner := True;\r\n end;\r\n end\r\n else\r\n begin\r\n GlobalUnitVersioning := TUnitVersioning.Create;\r\n UnitVersioningOwner := True;\r\n end;\r\n finally\r\n UnitVersioningMutex.Release;\r\n end;\r\n end\r\n else\r\n if UnitVersioningNPA <> nil then\r\n begin\r\n UnitVersioningMutex.WaitFor(INFINITE);\r\n try\r\n GlobalUnitVersioning := UnitVersioningNPA^; // update (maybe the owner has destroyed the instance)\r\n finally\r\n UnitVersioningMutex.Release;\r\n end;\r\n end;\r\n Result := GlobalUnitVersioning;\r\nend;\r\n\r\nprocedure FinalizeUnitVersioning;\r\nbegin\r\n UnitVersioningFinalized := True;\r\n try\r\n if UnitVersioningNPA <> nil then\r\n SharedCloseMem(UnitVersioningNPA);\r\n if (GlobalUnitVersioning <> nil) and UnitVersioningOwner then\r\n FreeAndNil(GlobalUnitVersioning)\r\n else\r\n GlobalUnitVersioning := nil;\r\n except\r\n // ignore - should never happen\r\n end;\r\n FreeAndNil(UnitVersioningMutex);\r\nend;\r\n\r\nprocedure RegisterUnitVersion(Instance: THandle; const Info: TUnitVersionInfo);\r\nvar\r\n UnitVersioning: TUnitVersioning;\r\nbegin\r\n UnitVersioning := GetUnitVersioning;\r\n if Assigned(UnitVersioning) then\r\n UnitVersioning.Add(Instance, @Info);\r\nend;\r\n\r\nprocedure UnregisterUnitVersion(Instance: THandle);\r\nvar\r\n UnitVersioning: TUnitVersioning;\r\nbegin\r\n UnitVersioning := GetUnitVersioning;\r\n if Assigned(UnitVersioning) then\r\n UnitVersioning.UnregisterModule(Instance);\r\nend;\r\n\r\nprocedure ExportUnitVersioningToFile(iFileName : string);\r\nvar\r\n I: Integer;\r\n sl: TStringList;\r\nbegin\r\n sl := TStringList.Create;\r\n try\r\n for I := 0 to GetUnitVersioning.Count - 1 do\r\n sl.Add(GetUnitVersioning.Items[I].Summary);\r\n sl.Sort;\r\n sl.SaveToFile(iFileName);\r\n finally\r\n sl.Free;\r\n end;\r\nend;\r\n\r\ninitialization\r\n{$IFDEF UNITVERSIONING}\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nfinalization\r\n{$IFDEF UNITVERSIONING}\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n FinalizeUnitVersioning;\r\n\r\nend.\r\n\r\n" }, { "path": "External/Jedi/Jcl/source/common/JclUnitVersioningProviders.pas", "content": "{**************************************************************************************************}\r\n{ }\r\n{ Project JEDI Code Library (JCL) }\r\n{ }\r\n{ The contents of this file are subject to the Mozilla Public License Version 1.1 (the \"License\"); }\r\n{ you may not use this file except in compliance with the License. You may obtain a copy of the }\r\n{ License at http://www.mozilla.org/MPL/ }\r\n{ }\r\n{ Software distributed under the License is distributed on an \"AS IS\" basis, WITHOUT WARRANTY OF }\r\n{ ANY KIND, either express or implied. See the License for the specific language governing rights }\r\n{ and limitations under the License. }\r\n{ }\r\n{ The Original Code is JclUnitVersioningProviders.pas. }\r\n{ }\r\n{ The Initial Developer of the Original Code is Uwe Schuster. }\r\n{ Portions created by Uwe Schuster are Copyright (C) Uwe Schuster. All rights reserved. }\r\n{ }\r\n{ Contributor(s): }\r\n{ Uwe Schuster (uschuster) }\r\n{ }\r\n{**************************************************************************************************}\r\n{ }\r\n{ Contains a TCustomUnitVersioningProvider implementation }\r\n{ }\r\n{ Unit owner: Uwe Schuster }\r\n{ }\r\n{**************************************************************************************************}\r\n{ }\r\n{ Last modified: $Date:: 2011-09-03 00:07:50 +0200 (sam. 03 sept. 2011) $ }\r\n{ Revision: $Rev:: 3599 $ }\r\n{ Author: $Author:: outchy $ }\r\n{ }\r\n{**************************************************************************************************}\r\n\r\nunit JclUnitVersioningProviders;\r\n\r\n{$I jcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF HAS_UNITSCOPE}\r\n {$IFDEF MSWINDOWS}\r\n Winapi.Windows,\r\n JclPeImage,\r\n {$ENDIF MSWINDOWS}\r\n System.SysUtils, System.Classes, System.Contnrs,\r\n {$ELSE ~HAS_UNITSCOPE}\r\n {$IFDEF MSWINDOWS}\r\n Windows,\r\n JclPeImage,\r\n {$ENDIF MSWINDOWS}\r\n SysUtils, Classes, Contnrs,\r\n {$ENDIF ~HAS_UNITSCOPE}\r\n {$IFDEF LINUX}\r\n Types,\r\n {$ENDIF LINUX}\r\n JclUnitVersioning;\r\n\r\ntype\r\n { TODO : store compressed? }\r\n TJclUnitVersioningList = class(TObject)\r\n private\r\n FItems: TList;\r\n function GetCount: Integer;\r\n function GetItems(AIndex: Integer): PUnitVersionInfo;\r\n public\r\n constructor Create;\r\n destructor Destroy; override;\r\n procedure Add(Info: TUnitVersionInfo);\r\n procedure Clear;\r\n function Load(AModule: HMODULE): Boolean;\r\n function LoadFromStream(AStream: TStream): Boolean;\r\n function LoadFromDefaultResource(AModule: HMODULE): Boolean;\r\n {$IFDEF MSWINDOWS}\r\n function LoadFromDefaultSection(AModule: HMODULE): Boolean;\r\n {$ENDIF MSWINDOWS}\r\n procedure SaveToFile(AFileName: string);\r\n procedure SaveToStream(AStream: TStream);\r\n property Count: Integer read GetCount;\r\n property Items[AIndex: Integer]: PUnitVersionInfo read GetItems; default;\r\n end;\r\n\r\n TJclUnitVersioningProviderModule = class(TObject)\r\n private\r\n FInfoList: TJclUnitVersioningList;\r\n FInstance: THandle;\r\n public\r\n constructor Create(Instance: THandle);\r\n destructor Destroy; override;\r\n property InfoList: TJclUnitVersioningList read FInfoList;\r\n property Instance: THandle read FInstance;\r\n end;\r\n\r\n TJclDefaultUnitVersioningProvider = class(TCustomUnitVersioningProvider)\r\n private\r\n FModules: TObjectList;\r\n function IndexOfInstance(Instance: THandle): Integer;\r\n public\r\n constructor Create; override;\r\n destructor Destroy; override;\r\n procedure LoadModuleUnitVersioningInfo(Instance: THandle); override;\r\n procedure ReleaseModuleUnitVersioningInfo(Instance: THandle); override;\r\n end;\r\n\r\n{$IFDEF MSWINDOWS}\r\nfunction InsertUnitVersioningSection(const ExecutableFileName: TFileName;\r\n AUnitList: TJclUnitVersioningList): Boolean;\r\n{$ENDIF MSWINDOWS}\r\n\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jcl.svn.sourceforge.net/svnroot/jcl/tags/JCL-2.4-Build4571/jcl/source/common/JclUnitVersioningProviders.pas $';\r\n Revision: '$Revision: 3599 $';\r\n Date: '$Date: 2011-09-03 00:07:50 +0200 (sam. 03 sept. 2011) $';\r\n LogPath: 'JCL\\source\\common';\r\n Extra: '';\r\n Data: nil\r\n );\r\n\r\nimplementation\r\n\r\nconst\r\n JclUnitVersioningDataResName = 'JCLUV';\r\n\r\nfunction NewUnitVersionInfo: PUnitVersionInfo;\r\nbegin\r\n New(Result);\r\n FillChar(Result^ , SizeOf(Result^), 0);\r\nend;\r\n\r\nprocedure DisposeUnitVersionInfo(var Value: PUnitVersionInfo);\r\nbegin\r\n StrDispose(Value^.RCSfile);\r\n StrDispose(Value^.Revision);\r\n StrDispose(Value^.Date);\r\n StrDispose(Value^.LogPath);\r\n StrDispose(Value^.Extra);\r\n Dispose(Value);\r\nend;\r\n\r\nfunction CopyUnitVersionInfo(Src: PUnitVersionInfo): PUnitVersionInfo;\r\nbegin\r\n New(Result);\r\n Result^.RCSfile := StrNew(Src^.RCSfile);\r\n Result^.Revision := StrNew(Src^.Revision);\r\n Result^.Date := StrNew(Src^.Date);\r\n Result^.LogPath := StrNew(Src^.LogPath);\r\n Result^.Extra := StrNew(Src^.Extra);\r\n Result^.Data := Src^.Data;\r\nend;\r\n\r\ntype\r\n TJclUnitVersioningHeader = record\r\n UnitCount: Integer;\r\n end;\r\n\r\n//=== { TJclUnitVersioningList } =============================================\r\n\r\nconstructor TJclUnitVersioningList.Create;\r\nbegin\r\n inherited Create;\r\n FItems := TList.Create;\r\nend;\r\n\r\ndestructor TJclUnitVersioningList.Destroy;\r\nbegin\r\n Clear;\r\n FItems.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJclUnitVersioningList.Add(Info: TUnitVersionInfo);\r\nbegin\r\n FItems.Add(CopyUnitVersionInfo(@Info));\r\nend;\r\n\r\nprocedure TJclUnitVersioningList.Clear;\r\nvar\r\n I: Integer;\r\n Item: PUnitVersionInfo;\r\nbegin\r\n for I := FItems.Count - 1 downto 0 do\r\n begin\r\n Item := PUnitVersionInfo(FItems[I]);\r\n DisposeUnitVersionInfo(Item);\r\n end;\r\n FItems.Clear;\r\nend;\r\n\r\nfunction TJclUnitVersioningList.GetCount: Integer;\r\nbegin\r\n Result := FItems.Count;\r\nend;\r\n\r\nfunction TJclUnitVersioningList.GetItems(AIndex: Integer): PUnitVersionInfo;\r\nbegin\r\n Result := FItems[AIndex];\r\nend;\r\n\r\nprocedure WriteStringToStream(AStream: TStream; const AString: string);\r\nvar\r\n StringLength: Integer;\r\nbegin\r\n if Assigned(AStream) then\r\n begin\r\n StringLength := Length(AString);\r\n AStream.Write(StringLength, SizeOf(StringLength));\r\n if StringLength > 0 then\r\n AStream.Write(PChar(AString)^, StringLength);\r\n end;\r\nend;\r\n\r\nfunction ReadStringFromStream(AStream: TStream; var AString: PChar): Boolean;\r\nvar\r\n StringLength: Integer;\r\nbegin\r\n Result := False;\r\n AString := '';\r\n if Assigned(AStream) then\r\n begin\r\n if AStream.Size - AStream.Position >= SizeOf(StringLength) then\r\n begin\r\n StringLength := 0;\r\n AStream.Read(StringLength, SizeOf(StringLength));\r\n if StringLength <= AStream.Size - AStream.Position then\r\n begin\r\n if StringLength > 0 then\r\n begin\r\n AString := StrAlloc(StringLength);\r\n Result := AStream.Read(AString^, StringLength) = StringLength;\r\n end\r\n else\r\n Result := True;\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction ReadUnitVersionInfo(AStream: TStream; out AVersionInfo: PUnitVersionInfo): Boolean;\r\nbegin\r\n AVersionInfo := NewUnitVersionInfo;\r\n Result := True;\r\n Result := Result and ReadStringFromStream(AStream, AVersionInfo^.RCSfile);\r\n Result := Result and ReadStringFromStream(AStream, AVersionInfo^.Revision);\r\n Result := Result and ReadStringFromStream(AStream, AVersionInfo^.Date);\r\n Result := Result and ReadStringFromStream(AStream, AVersionInfo^.LogPath);\r\n Result := Result and ReadStringFromStream(AStream, AVersionInfo^.Extra);\r\n AVersionInfo^.Data := nil;\r\nend;\r\n\r\nfunction TJclUnitVersioningList.Load(AModule: HMODULE): Boolean;\r\nbegin\r\n Result := LoadFromDefaultResource(AModule);\r\n {$IFDEF MSWINDOWS}\r\n if not Result then\r\n Result := LoadFromDefaultSection(AModule);\r\n {$ENDIF MSWINDOWS} \r\nend;\r\n\r\nfunction TJclUnitVersioningList.LoadFromDefaultResource(AModule: HMODULE): Boolean;\r\nvar\r\n ResourceStream: TResourceStream;\r\nbegin\r\n Result := False;\r\n if FindResource(AModule, JclUnitVersioningDataResName, RT_RCDATA) <> 0 then\r\n begin\r\n ResourceStream := TResourceStream.Create(AModule, JclUnitVersioningDataResName, RT_RCDATA);\r\n try\r\n Result := LoadFromStream(ResourceStream);\r\n finally\r\n ResourceStream.Free;\r\n end;\r\n end;\r\nend;\r\n\r\n{$IFDEF MSWINDOWS}\r\nfunction TJclUnitVersioningList.LoadFromDefaultSection(AModule: HMODULE): Boolean;\r\nvar\r\n PeSectionStream: TJclPeSectionStream;\r\nbegin\r\n Result := False;\r\n if PeMapImgFindSectionFromModule(Pointer(AModule), JclUnitVersioningDataResName) <> nil then\r\n begin\r\n PeSectionStream := TJclPeSectionStream.Create(AModule, JclUnitVersioningDataResName);\r\n try\r\n Result := LoadFromStream(PeSectionStream);\r\n finally\r\n PeSectionStream.Free;\r\n end;\r\n end;\r\nend;\r\n{$ENDIF MSWINDOWS}\r\n\r\nfunction TJclUnitVersioningList.LoadFromStream(AStream: TStream): Boolean;\r\nvar\r\n Header: TJclUnitVersioningHeader;\r\n UnitsToRead: Integer;\r\n LastReadOkay: Boolean;\r\n UnitVersionInfoPtr: PUnitVersionInfo;\r\nbegin\r\n Result := False;\r\n if Assigned(AStream) then\r\n begin\r\n Clear;\r\n Header.UnitCount := 0;\r\n AStream.Read(Header, SizeOf(Header));\r\n UnitsToRead := Header.UnitCount;\r\n LastReadOkay := True;\r\n while (UnitsToRead > 0) and LastReadOkay do\r\n begin\r\n LastReadOkay := ReadUnitVersionInfo(AStream, UnitVersionInfoPtr);\r\n if LastReadOkay then\r\n FItems.Add(UnitVersionInfoPtr);\r\n Dec(UnitsToRead);\r\n end;\r\n Result := (UnitsToRead = 0) and LastReadOkay;\r\n end;\r\nend;\r\n\r\nprocedure TJclUnitVersioningList.SaveToFile(AFileName: string);\r\nvar\r\n FileStream: TFileStream;\r\nbegin\r\n FileStream := TFileStream.Create(AFileName, fmCreate);\r\n try\r\n SaveToStream(FileStream);\r\n finally\r\n FileStream.Free;\r\n end;\r\nend;\r\n\r\nprocedure TJclUnitVersioningList.SaveToStream(AStream: TStream);\r\nvar\r\n UnitVersioningHeader: TJclUnitVersioningHeader;\r\n I: Integer;\r\nbegin\r\n UnitVersioningHeader.UnitCount := Count;\r\n AStream.Write(UnitVersioningHeader, SizeOf(UnitVersioningHeader));\r\n for I := 0 to Pred(Count) do\r\n with Items[I]^ do\r\n begin\r\n WriteStringToStream(AStream, RCSfile);\r\n WriteStringToStream(AStream, Revision);\r\n WriteStringToStream(AStream, Date);\r\n WriteStringToStream(AStream, LogPath);\r\n WriteStringToStream(AStream, Extra);\r\n end;\r\nend;\r\n\r\n//=== { TJclUnitVersioningProviderModule } ===================================\r\n\r\n{$IFDEF MSWINDOWS}\r\nfunction InsertUnitVersioningSection(const ExecutableFileName: TFileName;\r\n AUnitList: TJclUnitVersioningList): Boolean;\r\nvar\r\n SectionStream: TMemoryStream;\r\nbegin\r\n SectionStream := TMemoryStream.Create;\r\n try\r\n Result := Assigned(AUnitList);\r\n if Result then\r\n begin\r\n AUnitList.SaveToStream(SectionStream);\r\n Result := PeInsertSection(ExecutableFileName, SectionStream,\r\n JclUnitVersioningDataResName);\r\n end;\r\n finally\r\n SectionStream.Free;\r\n end;\r\nend;\r\n{$ENDIF MSWINDOWS}\r\n\r\nconstructor TJclUnitVersioningProviderModule.Create(Instance: THandle);\r\nvar\r\n I: Integer;\r\nbegin\r\n inherited Create;\r\n FInstance := Instance;\r\n FInfoList := TJclUnitVersioningList.Create;\r\n if FInfoList.Load(Instance) then\r\n for I := 0 to FInfoList.Count -1 do\r\n RegisterUnitVersion(Instance, FInfoList[I]^);\r\nend;\r\n\r\ndestructor TJclUnitVersioningProviderModule.Destroy;\r\nbegin\r\n FInfoList.Free;\r\n inherited Destroy;\r\nend;\r\n\r\n//=== { TJclDefaultUnitVersioningProvider } ==================================\r\n\r\nconstructor TJclDefaultUnitVersioningProvider.Create;\r\nbegin\r\n inherited Create;\r\n FModules := TObjectList.Create;\r\nend;\r\n\r\ndestructor TJclDefaultUnitVersioningProvider.Destroy;\r\nbegin\r\n FModules.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJclDefaultUnitVersioningProvider.IndexOfInstance(Instance: THandle): Integer;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := -1;\r\n for I := 0 to FModules.Count - 1 do\r\n if TJclUnitVersioningProviderModule(FModules[I]).Instance = Instance then\r\n begin\r\n Result := I;\r\n Break;\r\n end;\r\nend;\r\n\r\nprocedure TJclDefaultUnitVersioningProvider.LoadModuleUnitVersioningInfo(Instance: THandle);\r\nbegin\r\n if IndexOfInstance(Instance) < 0 then\r\n FModules.Add(TJclUnitVersioningProviderModule.Create(Instance));\r\nend;\r\n\r\nprocedure TJclDefaultUnitVersioningProvider.ReleaseModuleUnitVersioningInfo(Instance: THandle);\r\nvar\r\n Idx: Integer;\r\nbegin\r\n Idx := IndexOfInstance(Instance);\r\n if Idx <> -1 then\r\n FModules.Delete(Idx);\r\nend;\r\n\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jcl/source/common/JclUsesUtils.pas", "content": "{**************************************************************************************************}\r\n{ }\r\n{ Project JEDI Code Library (JCL) }\r\n{ }\r\n{ The contents of this file are subject to the Mozilla Public License Version 1.1 (the \"License\"); }\r\n{ you may not use this file except in compliance with the License. You may obtain a copy of the }\r\n{ License at http://www.mozilla.org/MPL/ }\r\n{ }\r\n{ Software distributed under the License is distributed on an \"AS IS\" basis, WITHOUT WARRANTY OF }\r\n{ ANY KIND, either express or implied. See the License for the specific language governing rights }\r\n{ and limitations under the License. }\r\n{ }\r\n{ The Original Code is JclParseUses.pas. }\r\n{ }\r\n{ The Initial Developer of the Original Code is TOndrej (tondrej att t-online dott de). }\r\n{ Portions created by TOndrej are Copyright (C) of TOndrej. }\r\n{ }\r\n{ Contributors: }\r\n{ }\r\n{**************************************************************************************************}\r\n{ }\r\n{ Last modified: $Date:: 2012-04-19 21:17:36 +0200 (jeu. 19 avr. 2012) $ }\r\n{ Revision: $Rev:: 3781 $ }\r\n{ Author: $Author:: outchy $ }\r\n{ }\r\n{**************************************************************************************************}\r\n\r\nunit JclUsesUtils;\r\n\r\n{$I jcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF HAS_UNITSCOPE}\r\n System.Classes, System.SysUtils, Winapi.Windows,\r\n {$ELSE ~HAS_UNITSCOPE}\r\n Classes, SysUtils, Windows,\r\n {$ENDIF ~HAS_UNITSCOPE}\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n JclBase;\r\n\r\ntype\r\n EUsesListError = class(EJclError);\r\n\r\n TUsesList = class\r\n private\r\n FText: string;\r\n function GetCount: Integer;\r\n function GetItems(Index: Integer): string;\r\n public\r\n constructor Create(const AText: PChar);\r\n function Add(const UnitName: string): Integer;\r\n function IndexOf(const UnitName: string): Integer;\r\n procedure Insert(Index: Integer; const UnitName: string);\r\n procedure Remove(Index: Integer);\r\n property Text: string read FText;\r\n property Count: Integer read GetCount;\r\n property Items[Index: Integer]: string read GetItems; default;\r\n end;\r\n\r\n TCustomGoal = class\r\n public\r\n constructor Create(Text: PChar); virtual; abstract;\r\n end;\r\n\r\n TProgramGoal = class(TCustomGoal)\r\n private\r\n FTextAfterUses: string;\r\n FTextBeforeUses: string;\r\n FUsesList: TUsesList;\r\n public\r\n constructor Create(Text: PChar); override;\r\n destructor Destroy; override;\r\n property TextAfterUses: string read FTextAfterUses;\r\n property TextBeforeUses: string read FTextBeforeUses;\r\n property UsesList: TUsesList read FUsesList;\r\n end;\r\n\r\n TLibraryGoal = class(TCustomGoal)\r\n private\r\n FTextAfterUses: string;\r\n FTextBeforeUses: string;\r\n FUsesList: TUsesList;\r\n public\r\n constructor Create(Text: PChar); override;\r\n destructor Destroy; override;\r\n property TextAfterUses: string read FTextAfterUses;\r\n property TextBeforeUses: string read FTextBeforeUses;\r\n property UsesList: TUsesList read FUsesList;\r\n end;\r\n\r\n TUnitGoal = class(TCustomGoal)\r\n private\r\n FTextAfterImpl: string;\r\n FTextAfterIntf: string;\r\n FTextBeforeIntf: string;\r\n FUsesImpl: TUsesList;\r\n FUsesIntf: TUsesList;\r\n public\r\n constructor Create(Text: PChar); override;\r\n destructor Destroy; override;\r\n property TextAfterImpl: string read FTextAfterImpl;\r\n property TextAfterIntf: string read FTextAfterIntf;\r\n property TextBeforeIntf: string read FTextBeforeIntf;\r\n property UsesImpl: TUsesList read FUsesImpl;\r\n property UsesIntf: TUsesList read FUsesIntf;\r\n end;\r\n\r\nfunction CreateGoal(Text: PChar): TCustomGoal;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jcl.svn.sourceforge.net/svnroot/jcl/tags/JCL-2.4-Build4571/jcl/source/common/JclUsesUtils.pas $';\r\n Revision: '$Revision: 3781 $';\r\n Date: '$Date: 2012-04-19 21:17:36 +0200 (jeu. 19 avr. 2012) $';\r\n LogPath: 'JCL\\source\\common';\r\n Extra: '';\r\n Data: nil\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n {$IFDEF HAS_UNITSCOPE}\r\n System.RtlConsts,\r\n {$IFDEF HAS_UNIT_CHARACTER}\r\n System.Character,\r\n {$ENDIF HAS_UNIT_CHARACTER}\r\n {$ELSE ~HAS_UNITSCOPE}\r\n RtlConsts,\r\n {$IFDEF HAS_UNIT_CHARACTER}\r\n Character,\r\n {$ENDIF HAS_UNIT_CHARACTER}\r\n {$ENDIF ~HAS_UNITSCOPE}\r\n JclStrings,\r\n JclDevToolsResources;\r\n\r\nconst\r\n SLibrary = 'library';\r\n SProgram = 'program';\r\n SUnit = 'unit';\r\n SUses = 'uses';\r\n\r\nfunction CharIsNotWhiteSpace(const C: Char): Boolean;\r\nbegin\r\n Result := not CharIsWhiteSpace(C);\r\nend;\r\n\r\nfunction PeekIdentifier(var P:PChar):boolean;forward;\r\n\r\nfunction PeekKeyword(var P: PChar; Keyword: PChar): Boolean; forward;\r\nfunction ReadIdentifier(var P: PChar): string; forward;\r\nprocedure SkipCommentsAndBlanks(var P: PChar); forward;\r\n\r\nfunction CheckIdentifier(var P: PChar): Boolean;\r\nbegin\r\n Result := CharIsAlpha(P^) or (P^ = '_');\r\n if Result then\r\n begin\r\n Inc(P);\r\n while CharIsValidIdentifierLetter(P^) or (P^ = '.') do\r\n Inc(P);\r\n end;\r\nend;\r\n\r\nfunction CheckKeyword(var P: PChar; Keyword: PChar): Boolean;\r\nvar\r\n KeywordLen: Integer;\r\nbegin\r\n KeywordLen := StrLen(Keyword);\r\n Result := StrLIComp(P, Keyword, KeywordLen) = 0;\r\n if Result then\r\n Inc(P, KeywordLen);\r\nend;\r\n\r\nfunction CreateGoal(Text: PChar): TCustomGoal;\r\nvar\r\n P: PChar;\r\nbegin\r\n Result := nil;\r\n P := Text;\r\n\r\n SkipCommentsAndBlanks(P);\r\n if PeekKeyword(P, SProgram) then\r\n Result := TProgramGoal.Create(Text)\r\n else\r\n if PeekKeyword(P, SLibrary) then\r\n Result := TLibraryGoal.Create(Text)\r\n else\r\n if PeekKeyword(P, SUnit) then\r\n Result := TUnitGoal.Create(Text);\r\nend;\r\n\r\nfunction PeekKeyword(var P: PChar; Keyword: PChar): Boolean;\r\nvar\r\n KeywordLen: Integer;\r\nbegin\r\n KeywordLen := StrLen(Keyword);\r\n Result := StrLIComp(P, KeyWord, KeywordLen) = 0;\r\nend;\r\n\r\n//----------------------------------------------------------------------------\r\n\r\nfunction PeekIdentifier(var P: PChar):boolean;\r\nvar Q:PChar;\r\nbegin\r\n Q := P;\r\n Result := CheckIdentifier(P);\r\n P := Q;\r\nend;\r\n\r\n\r\nfunction ReadIdentifier(var P: PChar): string;\r\nvar\r\n PStart: PChar;\r\nbegin\r\n Result := '';\r\n\r\n if CharIsAlpha(P^) then\r\n begin\r\n PStart := P;\r\n\r\n Inc(P);\r\n while CharIsValidIdentifierLetter(P^) or (P^ = '.') do\r\n Inc(P);\r\n\r\n SetString(Result, PStart, P - PStart);\r\n end;\r\nend;\r\n\r\nprocedure SkipComments(var P: PChar);\r\nvar\r\n Test: PChar;\r\nbegin\r\n if P^ = '{' then\r\n begin\r\n Test := StrScan(P, '}');\r\n if Test <> nil then\r\n P := Test + 1;\r\n end\r\n else\r\n if StrLComp(P, '(*', 2) = 0 then\r\n begin\r\n Test := StrPos(P, '*)');\r\n if Test <> nil then\r\n P := Test + 2;\r\n end\r\n else\r\n if StrLComp(P, '//', 2) = 0 then\r\n begin\r\n Test := StrPos(P, #13#10);\r\n if Test <> nil then\r\n P := Test + 2;\r\n end;\r\nend;\r\n\r\nprocedure SkipCommentsAndBlanks(var P: PChar);\r\nvar\r\n Test: PChar;\r\nbegin\r\n repeat\r\n Test := P;\r\n StrSkipChars(P, CharIsWhiteSpace);\r\n SkipComments(P);\r\n until Test = P;\r\nend;\r\n\r\n//=== { TUsesList } ==========================================================\r\n\r\nconstructor TUsesList.Create(const AText: PChar);\r\nvar\r\n P, PStart: PChar;\r\nbegin\r\n inherited Create;\r\n FText := '';\r\n if AText = nil then\r\n Exit;\r\n \r\n PStart := PChar(AText);\r\n P := PStart;\r\n if CheckKeyword(P, SUses) then\r\n begin\r\n while P^ <> #0 do\r\n begin\r\n SkipCommentsAndBlanks(P);\r\n if not CheckIdentifier(P) then\r\n raise EUsesListError.CreateRes(@RsEInvalidUses);\r\n SkipCommentsAndBlanks(P);\r\n\r\n if PeekKeyword(P, 'in') then\r\n begin\r\n Inc(P, 2);\r\n SkipCommentsAndBlanks(P);\r\n if P^ <> '''' then\r\n raise EUsesListError.CreateRes(@RsEInvalidUses);\r\n Inc(P);\r\n\r\n while (P^ <> #0) and (P^ <> '''') do\r\n Inc(P);\r\n if P^ <> '''' then\r\n raise EUsesListError.CreateRes(@RsEInvalidUses);\r\n Inc(P);\r\n SkipCommentsAndBlanks(P);\r\n end;\r\n\r\n case P^ of\r\n ',':\r\n Inc(P);\r\n ';':\r\n begin\r\n Inc(P);\r\n Break;\r\n end;\r\n else\r\n if not PeekIdentifier(P) then\r\n raise EUsesListError.CreateRes(@RsEInvalidUses);\r\n end;\r\n end;\r\n\r\n SetString(FText, PStart, P - PStart);\r\n end;\r\nend;\r\n\r\nfunction TUsesList.GetCount: Integer;\r\nvar\r\n P: PChar;\r\nbegin\r\n Result := 0;\r\n\r\n if FText = '' then\r\n Exit;\r\n\r\n P := PChar(FText);\r\n // an empty uses clause consisting of only blanks and comments\r\n // (resulting from removal of the last unit) is valid too\r\n SkipCommentsAndBlanks(P);\r\n if P^ = #0 then\r\n Exit;\r\n\r\n if not CheckKeyword(P, SUses) then\r\n raise EUsesListError.CreateRes(@RsEInvalidUses);\r\n\r\n while P^ <> #0 do\r\n begin\r\n SkipCommentsAndBlanks(P);\r\n if not CheckIdentifier(P) then\r\n raise EUsesListError.CreateRes(@RsEInvalidUses);\r\n Inc(Result);\r\n SkipCommentsAndBlanks(P);\r\n\r\n if PeekKeyword(P, 'in') then\r\n begin\r\n Inc(P, 2);\r\n SkipCommentsAndBlanks(P);\r\n if P^ <> '''' then\r\n raise EUsesListError.CreateRes(@RsEInvalidUses);\r\n Inc(P);\r\n \r\n while (P^ <> #0) and (P^ <> '''') do\r\n Inc(P);\r\n if P^ <> '''' then\r\n raise EUsesListError.CreateRes(@RsEInvalidUses);\r\n Inc(P);\r\n SkipCommentsAndBlanks(P);\r\n end;\r\n\r\n case P^ of\r\n ',':\r\n Inc(P);\r\n ';':\r\n Break;\r\n else\r\n if not PeekIdentifier(P) then\r\n raise EUsesListError.CreateRes(@RsEInvalidUses);\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TUsesList.GetItems(Index: Integer): string;\r\nvar\r\n P, PIdentifier: PChar;\r\n I: Integer;\r\nbegin\r\n Result := '';\r\n\r\n if (Index < 0) or (Index > Count - 1) then\r\n raise EUsesListError.CreateResFmt(@SListIndexError, [Index]);\r\n\r\n P := PChar(FText);\r\n if not CheckKeyword(P, SUses) then\r\n raise EUsesListError.CreateRes(@RsEInvalidUses);\r\n I := -1;\r\n while P^ <> #0 do\r\n begin\r\n SkipCommentsAndBlanks(P);\r\n PIdentifier := P;\r\n if not CheckIdentifier(P) then\r\n raise EUsesListError.CreateRes(@RsEInvalidUses);\r\n\r\n Inc(I);\r\n if I = Index then\r\n begin\r\n while CharIsValidIdentifierLetter(PIdentifier^) or (P^ = '.') do\r\n begin\r\n Result := Result + PIdentifier^;\r\n Inc(PIdentifier);\r\n end;\r\n Exit;\r\n end;\r\n SkipCommentsAndBlanks(P);\r\n\r\n if PeekKeyword(P, 'in') then\r\n begin\r\n Inc(P, 2);\r\n SkipCommentsAndBlanks(P);\r\n if P^ <> '''' then\r\n raise EUsesListError.CreateRes(@RsEInvalidUses);\r\n Inc(P);\r\n\r\n while (P^ <> #0) and (P^ <> '''') do\r\n Inc(P);\r\n if P^ <> '''' then\r\n raise EUsesListError.CreateRes(@RsEInvalidUses);\r\n Inc(P);\r\n SkipCommentsAndBlanks(P);\r\n end;\r\n\r\n case P^ of\r\n ',':\r\n Inc(P);\r\n ';':\r\n Break;\r\n else\r\n if not PeekIdentifier(P) then\r\n raise EUsesListError.CreateRes(@RsEInvalidUses);\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TUsesList.Add(const UnitName: string): Integer;\r\nvar\r\n I: Integer;\r\n P: PChar;\r\nbegin\r\n Result := -1;\r\n\r\n I := IndexOf(UnitName);\r\n if I <> -1 then\r\n raise EUsesListError.CreateResFmt(@RsEDuplicateUnit, [UnitName]);\r\n\r\n if FText = '' then\r\n begin\r\n FText := Format('%s'#13#10' %s;'#13#10#13#10, [SUses, UnitName]);\r\n try\r\n Result := IndexOf(UnitName);\r\n except\r\n FText := '';\r\n raise;\r\n end;\r\n end\r\n else\r\n begin\r\n P := PChar(FText);\r\n if not CheckKeyword(P, SUses) then\r\n raise EUsesListError.CreateRes(@RsEInvalidUses);\r\n\r\n while P^ <> #0 do\r\n begin\r\n SkipCommentsAndBlanks(P);\r\n if not CheckIdentifier(P) then\r\n raise EUsesListError.CreateRes(@RsEInvalidUses);\r\n\r\n SkipCommentsAndBlanks(P);\r\n\r\n if PeekKeyword(P, 'in') then\r\n begin\r\n Inc(P, 2);\r\n SkipCommentsAndBlanks(P);\r\n if P^ <> '''' then\r\n raise EUsesListError.CreateRes(@RsEInvalidUses);\r\n Inc(P);\r\n\r\n while (P^ <> #0) and (P^ <> '''') do\r\n Inc(P);\r\n if P^ <> '''' then\r\n raise EUsesListError.CreateRes(@RsEInvalidUses);\r\n Inc(P);\r\n SkipCommentsAndBlanks(P);\r\n end;\r\n\r\n case P^ of\r\n ',':\r\n Inc(P);\r\n ';':\r\n begin\r\n System.Insert(Format(', %s', [UnitName]), FText, P - PChar(FText) + 1);\r\n Result := IndexOf(UnitName);\r\n Break;\r\n end;\r\n else\r\n raise EUsesListError.CreateRes(@RsEInvalidUses);\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TUsesList.IndexOf(const UnitName: string): Integer;\r\nvar\r\n P, PIdentifier: PChar;\r\n Identifier: string;\r\n I: Integer;\r\nbegin\r\n Result := -1;\r\n\r\n if FText = '' then\r\n Exit;\r\n\r\n P := PChar(FText);\r\n if not CheckKeyword(P, SUses) then\r\n raise EUsesListError.CreateRes(@RsEInvalidUses);\r\n\r\n I := -1;\r\n while P^ <> #0 do\r\n begin\r\n SkipCommentsAndBlanks(P);\r\n PIdentifier := P;\r\n if not CheckIdentifier(P) then\r\n raise EUsesListError.CreateRes(@RsEInvalidUses);\r\n SetString(Identifier, PIdentifier, P - PIdentifier);\r\n\r\n Inc(I);\r\n if AnsiCompareText(UnitName, Identifier) = 0 then\r\n begin\r\n Result := I;\r\n Exit;\r\n end;\r\n SkipCommentsAndBlanks(P);\r\n\r\n if PeekKeyword(P, 'in') then\r\n begin\r\n Inc(P, 2);\r\n SkipCommentsAndBlanks(P);\r\n if P^ <> '''' then\r\n raise EUsesListError.CreateRes(@RsEInvalidUses);\r\n Inc(P);\r\n\r\n while (P^ <> #0) and (P^ <> '''') do\r\n Inc(P);\r\n if P^ <> '''' then\r\n raise EUsesListError.CreateRes(@RsEInvalidUses);\r\n Inc(P);\r\n SkipCommentsAndBlanks(P);\r\n end;\r\n\r\n case P^ of\r\n ',':\r\n Inc(P);\r\n ';':\r\n Break;\r\n else\r\n raise EUsesListError.CreateRes(@RsEInvalidUses);\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TUsesList.Insert(Index: Integer; const UnitName: string);\r\nvar\r\n I: Integer;\r\n P: PChar;\r\nbegin\r\n if (Index < 0) or (Index > Count - 1) then\r\n raise EUsesListError.CreateResFmt(@SListIndexError, [Index]);\r\n I := IndexOf(UnitName);\r\n if I <> -1 then\r\n raise EUsesListError.CreateResFmt(@RsEDuplicateUnit, [UnitName]);\r\n\r\n if FText = '' then\r\n begin\r\n FText := Format('%s'#13#10' %s;'#13#10#13#10, [SUses, UnitName]);\r\n try\r\n if Index <> IndexOf(UnitName) then\r\n Exit;\r\n except\r\n FText := '';\r\n raise;\r\n end;\r\n end\r\n else\r\n begin\r\n P := PChar(FText);\r\n if not CheckKeyword(P, SUses) then\r\n raise EUsesListError.CreateRes(@RsEInvalidUses);\r\n\r\n I := -1;\r\n while P^ <> #0 do\r\n begin\r\n SkipCommentsAndBlanks(P);\r\n Inc(I);\r\n if I = Index then\r\n begin\r\n System.Insert(Format('%s, ', [UnitName]), FText, P - PChar(FText) + 1);\r\n Exit;\r\n end;\r\n\r\n if not CheckIdentifier(P) then\r\n raise EUsesListError.CreateRes(@RsEInvalidUses);\r\n SkipCommentsAndBlanks(P);\r\n\r\n if PeekKeyword(P, 'in') then\r\n begin\r\n Inc(P, 2);\r\n SkipCommentsAndBlanks(P);\r\n if P^ <> '''' then\r\n raise EUsesListError.CreateRes(@RsEInvalidUses);\r\n Inc(P);\r\n\r\n while (P^ <> #0) and (P^ <> '''') do\r\n Inc(P);\r\n if P^ <> '''' then\r\n raise EUsesListError.CreateRes(@RsEInvalidUses);\r\n Inc(P);\r\n SkipCommentsAndBlanks(P);\r\n end;\r\n\r\n case P^ of\r\n ',':\r\n Inc(P);\r\n else\r\n raise EUsesListError.CreateRes(@RsEInvalidUses);\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TUsesList.Remove(Index: Integer);\r\nvar\r\n Count, I, DelPos: Integer;\r\n P, PIdentifier: PChar;\r\nbegin\r\n Count := GetCount;\r\n if (Index < 0) or (Index > Count - 1) then\r\n raise EUsesListError.CreateResFmt(@SListIndexError, [Index]);\r\n\r\n P := PChar(FText);\r\n if not CheckKeyword(P, SUses) then\r\n raise EUsesListError.CreateRes(@RsEInvalidUses);\r\n\r\n if (Count = 1) and (Index = 0) then\r\n begin\r\n Delete(FText, 1, Length(SUses));\r\n P := PChar(FText);\r\n end;\r\n\r\n I := -1;\r\n while P^ <> #0 do\r\n begin\r\n SkipCommentsAndBlanks(P);\r\n Inc(I);\r\n\r\n if I = Index then\r\n begin\r\n // remove unit\r\n PIdentifier := P;\r\n if not CheckIdentifier(P) then\r\n raise EUsesListError.CreateRes(@RsEInvalidUses);\r\n DelPos := PIdentifier - PChar(FText) + 1;\r\n Delete(FText, DelPos, P - PIdentifier);\r\n // skip comments and blanks\r\n P := PChar(FText) + DelPos - 1;\r\n PIdentifier := P;\r\n SkipCommentsAndBlanks(P);\r\n // check in syntax\r\n if PeekKeyword(P, 'in') then\r\n begin\r\n Inc(P, 2);\r\n SkipCommentsAndBlanks(P);\r\n if P^ <> '''' then\r\n raise EUsesListError.CreateRes(@RsEInvalidUses);\r\n Inc(P);\r\n\r\n while (P^ <> #0) and (P^ <> '''') do\r\n Inc(P);\r\n if P^ <> '''' then\r\n raise EUsesListError.CreateRes(@RsEInvalidUses);\r\n Inc(P);\r\n SkipCommentsAndBlanks(P);\r\n DelPos := PIdentifier - PChar(FText) + 1;\r\n Delete(FText, DelPos, P - PIdentifier);\r\n P := PChar(FText) + DelPos - 1;\r\n end;\r\n\r\n // remove separator\r\n case P^ of\r\n ',', ';':\r\n begin\r\n DelPos := P - PChar(FText) + 1;\r\n Delete(FText, DelPos, 1);\r\n end;\r\n else\r\n raise EUsesListError.CreateRes(@RsEInvalidUses);\r\n end;\r\n // remove trailing spaces, if any\r\n PIdentifier := PChar(FText) + DelPos - 1;\r\n P := PIdentifier;\r\n StrSkipChars(P, CharIsWhiteSpace);\r\n DelPos := PIdentifier - PChar(FText) + 1;\r\n Delete(FText, DelPos, P - PIdentifier);\r\n // skip further comments and blanks\r\n P := PChar(FText) + DelPos - 1;\r\n SkipCommentsAndBlanks(P);\r\n Exit;\r\n end;\r\n if not CheckIdentifier(P) then\r\n raise EUsesListError.CreateRes(@RsEInvalidUses);\r\n\r\n SkipCommentsAndBlanks(P);\r\n if PeekKeyword(P, 'in') then\r\n begin\r\n Inc(P, 2);\r\n SkipCommentsAndBlanks(P);\r\n if P^ <> '''' then\r\n raise EUsesListError.CreateRes(@RsEInvalidUses);\r\n Inc(P);\r\n\r\n while (P^ <> #0) and (P^ <> '''') do\r\n Inc(P);\r\n if P^ <> '''' then\r\n raise EUsesListError.CreateRes(@RsEInvalidUses);\r\n Inc(P);\r\n SkipCommentsAndBlanks(P);\r\n end;\r\n\r\n case P^ of\r\n ',', ';':\r\n begin\r\n // make sure semicolon is the last separator in case the last unit is going to be removed\r\n if (Index = Count - 1) and (I = Index - 1) then\r\n P^ := ';';\r\n Inc(P);\r\n end;\r\n else\r\n raise EUsesListError.CreateRes(@RsEInvalidUses);\r\n end;\r\n end;\r\nend;\r\n\r\n//=== { TProgramGoal } =======================================================\r\n\r\nconstructor TProgramGoal.Create(Text: PChar);\r\nvar\r\n P, PStart: PChar;\r\nbegin\r\n FTextBeforeUses := '';\r\n FTextAfterUses := '';\r\n\r\n PStart := Text;\r\n P := PStart;\r\n \r\n // check 'program' label\r\n SkipCommentsAndBlanks(P);\r\n if not CheckKeyword(P, SProgram) then\r\n raise EUsesListError.CreateRes(@RsEInvalidProgram);\r\n SkipCommentsAndBlanks(P);\r\n if not CheckIdentifier(P) then\r\n raise EUsesListError.CreateRes(@RsEInvalidProgram);\r\n SkipCommentsAndBlanks(P);\r\n if P^ <> ';' then\r\n raise EUsesListError.CreateRes(@RsEInvalidProgram);\r\n Inc(P);\r\n SkipCommentsAndBlanks(P);\r\n\r\n // remember text before uses\r\n SetString(FTextBeforeUses, PStart, P - PStart);\r\n\r\n if PeekKeyword(P, SUses) then\r\n begin\r\n FUsesList := TUsesList.Create(P);\r\n PStart := P + Length(FUsesList.Text);\r\n end\r\n else // empty uses list\r\n begin\r\n FUsesList := TUsesList.Create(nil);\r\n PStart := P;\r\n end;\r\n // remember text after uses\r\n P := StrEnd(PStart);\r\n SetString(FTextAfterUses, PStart, P - PStart);\r\nend;\r\n\r\ndestructor TProgramGoal.Destroy;\r\nbegin\r\n FUsesList.Free;\r\n inherited Destroy;\r\nend;\r\n\r\n//=== { TLibraryGoal } =======================================================\r\n\r\nconstructor TLibraryGoal.Create(Text: PChar);\r\nvar\r\n P, PStart: PChar;\r\nbegin\r\n FTextBeforeUses := '';\r\n FTextAfterUses := '';\r\n\r\n PStart := Text;\r\n P := PStart;\r\n\r\n // check 'library' label\r\n SkipCommentsAndBlanks(P);\r\n if not CheckKeyword(P, SLibrary) then\r\n raise EUsesListError.CreateRes(@RsEInvalidLibrary);\r\n SkipCommentsAndBlanks(P);\r\n if not CheckIdentifier(P) then\r\n raise EUsesListError.CreateRes(@RsEInvalidLibrary);\r\n SkipCommentsAndBlanks(P);\r\n if P^ <> ';' then\r\n raise EUsesListError.CreateRes(@RsEInvalidLibrary);\r\n Inc(P);\r\n SkipCommentsAndBlanks(P);\r\n\r\n // remember text before uses\r\n SetString(FTextBeforeUses, PStart, P - PStart);\r\n\r\n if PeekKeyword(P, SUses) then\r\n begin\r\n FUsesList := TUsesList.Create(P);\r\n PStart := P + Length(FUsesList.Text);\r\n end\r\n else // empty uses list\r\n begin\r\n FUsesList := TUsesList.Create(nil);\r\n PStart := P;\r\n end;\r\n // remember text after uses\r\n P := StrEnd(PStart);\r\n SetString(FTextAfterUses, PStart, P - PStart);\r\nend;\r\n\r\ndestructor TLibraryGoal.Destroy;\r\nbegin\r\n FUsesList.Free;\r\n inherited Destroy;\r\nend;\r\n\r\n//=== { TUnitGoal } ==========================================================\r\n\r\nconstructor TUnitGoal.Create(Text: PChar);\r\nvar\r\n P, PStart: PChar;\r\nbegin\r\n FTextBeforeIntf := '';\r\n FTextAfterIntf := '';\r\n FTextAfterImpl := '';\r\n\r\n PStart := Text;\r\n P := PStart;\r\n\r\n // check 'unit' label\r\n SkipCommentsAndBlanks(P);\r\n while (P^ <> #0) and not PeekKeyword(P, 'unit') do\r\n begin\r\n StrSkipChars(P, CharIsNotWhiteSpace);\r\n SkipCommentsAndBlanks(P);\r\n end;\r\n if not CheckKeyword(P, SUnit) then\r\n raise EUsesListError.CreateRes(@RsEInvalidUnit);\r\n SkipCommentsAndBlanks(P);\r\n if not CheckIdentifier(P) then\r\n raise EUsesListError.CreateRes(@RsEInvalidUnit);\r\n SkipCommentsAndBlanks(P);\r\n if P^ <> ';' then\r\n raise EUsesListError.CreateRes(@RsEInvalidUnit);\r\n Inc(P);\r\n // check 'interface' label\r\n// SkipCommentsAndBlanks(P);\r\n while (P^ <> #0) and not PeekKeyword(P, 'interface') do\r\n begin\r\n StrSkipChars(P, CharIsNotWhiteSpace);\r\n SkipCommentsAndBlanks(P);\r\n end;\r\n if not CheckKeyword(P, 'interface') then\r\n raise EUsesListError.CreateRes(@RsEInvalidUnit);\r\n SkipCommentsAndBlanks(P);\r\n\r\n // remember text before interface uses\r\n SetString(FTextBeforeIntf, PStart, P - PStart);\r\n if PeekKeyword(P, SUses) then\r\n begin\r\n FUsesIntf := TUsesList.Create(P);\r\n PStart := P + Length(FUsesIntf.Text);\r\n end\r\n else\r\n begin\r\n FUsesIntf := TUsesList.Create(nil);\r\n PStart := P;\r\n end;\r\n // locate implementation\r\n while (P^ <> #0) and not PeekKeyword(P, 'implementation') do\r\n begin\r\n StrSkipChars(P, CharIsNotWhiteSpace);\r\n SkipCommentsAndBlanks(P);\r\n end;\r\n if not CheckKeyword(P, 'implementation') then\r\n raise EUsesListError.CreateRes(@RsEInvalidUnit);\r\n SkipCommentsAndBlanks(P);\r\n\r\n // remember text after interface uses\r\n SetString(FTextAfterIntf, PStart, P - PStart);\r\n if PeekKeyword(P, SUses) then\r\n begin\r\n FUsesImpl := TUsesList.Create(P);\r\n PStart := P + Length(FUsesImpl.Text);\r\n end\r\n else\r\n begin\r\n FUsesImpl := TUsesList.Create(nil);\r\n PStart := P;\r\n end;\r\n // remember text after implementation uses\r\n P := StrEnd(PStart);\r\n SetString(FTextAfterImpl, PStart, P - PStart);\r\nend;\r\n\r\ndestructor TUnitGoal.Destroy;\r\nbegin\r\n FUsesIntf.Free;\r\n FUsesImpl.Free;\r\n inherited Destroy;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jcl/source/common/JclValidation.pas", "content": "{**************************************************************************************************}\r\n{ }\r\n{ Project JEDI Code Library (JCL) }\r\n{ }\r\n{ The contents of this file are subject to the Mozilla Public License Version 1.1 (the \"License\"); }\r\n{ you may not use this file except in compliance with the License. You may obtain a copy of the }\r\n{ License at http://www.mozilla.org/MPL/ }\r\n{ }\r\n{ Software distributed under the License is distributed on an \"AS IS\" basis, WITHOUT WARRANTY OF }\r\n{ ANY KIND, either express or implied. See the License for the specific language governing rights }\r\n{ and limitations under the License. }\r\n{ }\r\n{ The Original Code is JclValidation.pas }\r\n{ }\r\n{ The Initial Developer of the Original Code is Ivo Bauer. }\r\n{ Portions created by Ivo Bauer are Copyright Ivo Bauer. All rights reserved. }\r\n{ }\r\n{ Contributor(s): }\r\n{ }\r\n{**************************************************************************************************}\r\n{ }\r\n{ This unit contains ISBN validation routines }\r\n{ }\r\n{**************************************************************************************************}\r\n{ }\r\n{ Last modified: $Date:: 2009-07-30 12:08:05 +0200 (jeu. 30 juil. 2009) $ }\r\n{ Revision: $Rev:: 2892 $ }\r\n{ Author: $Author:: outchy $ }\r\n{ }\r\n{**************************************************************************************************}\r\n\r\nunit JclValidation;\r\n\r\n{$I jcl.inc}\r\n\r\ninterface\r\n\r\n{$IFDEF UNITVERSIONING}\r\nuses\r\n JclUnitVersioning;\r\n{$ENDIF UNITVERSIONING}\r\n\r\n// ISBN: International Standard Book Number\r\nfunction IsValidISBN(const ISBN: string): Boolean;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jcl.svn.sourceforge.net/svnroot/jcl/tags/JCL-2.4-Build4571/jcl/source/common/JclValidation.pas $';\r\n Revision: '$Revision: 2892 $';\r\n Date: '$Date: 2009-07-30 12:08:05 +0200 (jeu. 30 juil. 2009) $';\r\n LogPath: 'JCL\\source\\common';\r\n Extra: '';\r\n Data: nil\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n JclBase,\r\n JclSysUtils;\r\n \r\n{ TODO -cDoc : Donator: Ivo Bauer }\r\nfunction IsValidISBN(const ISBN: string): Boolean;\r\n//\r\n// References:\r\n// ===========\r\n// [1] http://isbn-international.org/en/userman/chapter4.html\r\n//\r\ntype\r\n TISBNPart = (ipGroupID, ipPublisherID, ipTitleID, ipCheckDigit);\r\n TISBNPartSizes = array [TISBNPart] of Integer;\r\nconst\r\n ISBNSize = 13;\r\n\r\nfunction CharIsISBNSpecialDigit(const C: Char): Boolean; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\nbegin\r\n case C of\r\n 'x', 'X':\r\n Result := True;\r\n else\r\n Result := False;\r\n end;\r\nend;\r\n\r\nfunction CharIsISBNSeparator(const C: Char): Boolean; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\nbegin\r\n case C of\r\n #32, '-':\r\n Result := True;\r\n else\r\n Result := False;\r\n end;\r\nend;\r\n\r\nfunction CharIsISBNCharacter(const C: Char): Boolean; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\nbegin\r\n case C of\r\n '0'..'9',\r\n 'x', 'X',\r\n #32, '-':\r\n Result := True;\r\n else\r\n Result := False;\r\n end;\r\nend;\r\n\r\nvar\r\n CurPtr, EndPtr: Integer;\r\n Accumulator, Counter: Integer;\r\n Part: TISBNPart;\r\n PartSizes: TISBNPartSizes;\r\n\r\n function IsPartSizeValid(APart: TISBNPart): Boolean;\r\n const\r\n MaxPartSizes: TISBNPartSizes = (5, 7, 6, 1);\r\n begin\r\n Result := PartSizes[APart] <= MaxPartSizes[APart];\r\n end;\r\n\r\nbegin\r\n Result := False;\r\n // At first, check the overall string length.\r\n if Length(ISBN) <> ISBNSize then\r\n Exit;\r\n\r\n CurPtr := 1;\r\n EndPtr := ISBNSize - 1;\r\n Accumulator := 0;\r\n Counter := 10;\r\n Part := ipGroupID;\r\n ResetMemory(PartSizes[Low(PartSizes)], SizeOf(PartSizes));\r\n\r\n while CurPtr <= EndPtr do\r\n begin\r\n if CharIsISBNCharacter(ISBN[CurPtr]) then\r\n begin\r\n if CharIsISBNSeparator(ISBN[CurPtr]) then\r\n begin\r\n // Switch to the next ISBN part, but take care of two conditions:\r\n // 1. Do not let Part go beyond its upper bound (ipCheckDigit).\r\n // 2. Verify if the current ISBN part does not exceed its size limit.\r\n if (Part < High(Part)) and IsPartSizeValid(Part) then\r\n Inc(Part)\r\n else\r\n Exit;\r\n end\r\n else // CurPtr^ in [ISBNDigits, ISBNSpecialDigits]\r\n begin\r\n // Is it the last character of the string?\r\n if (CurPtr = EndPtr) then\r\n begin\r\n // Check the following conditions:\r\n // 1. Make sure current ISBN Part equals to ipCheckDigit.\r\n // 2. Verify if the check digit does not exceed its size limit.\r\n if (Part <> High(Part)) and not IsPartSizeValid(Part) then\r\n Exit;\r\n end\r\n else\r\n // Special check digit is allowed to occur only at the end of ISBN.\r\n if CharIsISBNSpecialDigit(ISBN[CurPtr]) then\r\n Exit;\r\n\r\n // Increment the size of the current ISBN part.\r\n Inc(PartSizes[Part]);\r\n\r\n // Increment the accumulator by current ISBN digit multiplied by a weight.\r\n // To get more detailed information, please refer to the web site [1].\r\n if (CurPtr = EndPtr) and CharIsISBNSpecialDigit(ISBN[CurPtr]) then\r\n Inc(Accumulator, 10 * Counter)\r\n else\r\n Inc(Accumulator, (Ord(ISBN[CurPtr]) - Ord('0')) * Counter);\r\n Dec(Counter);\r\n end;\r\n Inc(CurPtr);\r\n end\r\n else\r\n Exit;\r\n end;\r\n // Accumulator content must be divisible by 11 without a remainder.\r\n Result := (Accumulator mod 11) = 0;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jcl/source/common/JclVectors.pas", "content": "{**************************************************************************************************}\r\n{ WARNING: JEDI preprocessor generated unit. Do not edit. }\r\n{**************************************************************************************************}\r\n\r\n{**************************************************************************************************}\r\n{ }\r\n{ Project JEDI Code Library (JCL) }\r\n{ }\r\n{ The contents of this file are subject to the Mozilla Public License Version 1.1 (the \"License\"); }\r\n{ you may not use this file except in compliance with the License. You may obtain a copy of the }\r\n{ License at http://www.mozilla.org/MPL/ }\r\n{ }\r\n{ Software distributed under the License is distributed on an \"AS IS\" basis, WITHOUT WARRANTY OF }\r\n{ ANY KIND, either express or implied. See the License for the specific language governing rights }\r\n{ and limitations under the License. }\r\n{ }\r\n{ The Original Code is Vector.pas. }\r\n{ }\r\n{ The Initial Developer of the Original Code is Jean-Philippe BEMPEL aka RDM. Portions created by }\r\n{ Jean-Philippe BEMPEL are Copyright (C) Jean-Philippe BEMPEL (rdm_30 att yahoo dott com) }\r\n{ All rights reserved. }\r\n{ }\r\n{ Contributors: }\r\n{ Daniele Teti (dade2004) }\r\n{ Robert Marquardt (marquardt) }\r\n{ Robert Rossmair (rrossmair) }\r\n{ Florent Ouchet (outchy) }\r\n{ }\r\n{**************************************************************************************************}\r\n{ }\r\n{ The Delphi Container Library }\r\n{ }\r\n{**************************************************************************************************}\r\n{ }\r\n{ Last modified: $Date:: 2012-02-24 12:14:46 +0100 (ven. 24 févr. 2012) $ }\r\n{ Revision: $Rev:: 3745 $ }\r\n{ Author: $Author:: outchy $ }\r\n{ }\r\n{**************************************************************************************************}\r\n\r\nunit JclVectors;\r\n\r\n{$I jcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n {$IFDEF HAS_UNITSCOPE}\r\n System.Classes,\r\n {$ELSE ~HAS_UNITSCOPE}\r\n Classes,\r\n {$ENDIF ~HAS_UNITSCOPE}\r\n JclAlgorithms, JclBase, JclAbstractContainers, JclContainerIntf, JclSynch;\r\n\r\n\r\ntype\r\n TItrStart = (isFirst, isLast);\r\n TJclIntfVector = class(TJclIntfAbstractContainer, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclIntfCloneable, IJclCloneable, IJclPackable, IJclGrowable, IJclBaseContainer,\r\n IJclIntfContainer, IJclIntfFlatContainer, IJclIntfEqualityComparer,\r\n IJclIntfCollection, IJclIntfList, IJclIntfArray)\r\n protected\r\n function CreateEmptyContainer: TJclAbstractContainerBase; override;\r\n private\r\n FItems: TDynIInterfaceArray;\r\n protected\r\n procedure AssignDataTo(Dest: TJclAbstractContainerBase); override;\r\n // fix ambiguous warnings when compiled on Delphi.net and earlier versions of Delphi.win32\r\n // complaining about possible unaffected result.\r\n function RaiseOutOfBoundsError: IInterface;\r\n public\r\n constructor Create(ACapacity: Integer); overload;\r\n constructor Create(const ACollection: IJclIntfCollection); overload;\r\n destructor Destroy; override;\r\n property Items: TDynIInterfaceArray read FItems;\r\n { IJclPackable }\r\n procedure SetCapacity(Value: Integer); override;\r\n { IJclIntfCollection }\r\n function Add(const AInterface: IInterface): Boolean;\r\n function AddAll(const ACollection: IJclIntfCollection): Boolean;\r\n procedure Clear;\r\n function CollectionEquals(const ACollection: IJclIntfCollection): Boolean;\r\n function Contains(const AInterface: IInterface): Boolean;\r\n function ContainsAll(const ACollection: IJclIntfCollection): Boolean;\r\n function Extract(const AInterface: IInterface): Boolean; \r\n function ExtractAll(const ACollection: IJclIntfCollection): Boolean;\r\n function First: IJclIntfIterator;\r\n function IsEmpty: Boolean;\r\n function Last: IJclIntfIterator;\r\n function Remove(const AInterface: IInterface): Boolean; \r\n function RemoveAll(const ACollection: IJclIntfCollection): Boolean;\r\n function RetainAll(const ACollection: IJclIntfCollection): Boolean;\r\n function Size: Integer;\r\n {$IFDEF SUPPORTS_FOR_IN}\r\n function GetEnumerator: IJclIntfIterator;\r\n {$ENDIF SUPPORTS_FOR_IN}\r\n { IJclIntfList }\r\n function Delete(Index: Integer): IInterface;\r\n function ExtractIndex(Index: Integer): IInterface;\r\n function GetObject(Index: Integer): IInterface;\r\n function IndexOf(const AInterface: IInterface): Integer;\r\n function Insert(Index: Integer; const AInterface: IInterface): Boolean;\r\n function InsertAll(Index: Integer; const ACollection: IJclIntfCollection): Boolean;\r\n function LastIndexOf(const AInterface: IInterface): Integer;\r\n procedure SetObject(Index: Integer; const AInterface: IInterface);\r\n function SubList(First, Count: Integer): IJclIntfList;\r\n end;\r\n\r\n TJclIntfVectorIterator = class(TJclAbstractIterator, IJclIntfIterator, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclIntfCloneable, IJclCloneable)\r\n private\r\n FCursor: Integer;\r\n FStart: TItrStart;\r\n FOwnList: TJclIntfVector;\r\n protected\r\n function CreateEmptyIterator: TJclAbstractIterator; override;\r\n procedure AssignPropertiesTo(Dest: TJclAbstractIterator); override;\r\n public\r\n constructor Create(AOwnList: TJclIntfVector; ACursor: Integer; AValid: Boolean; AStart: TItrStart);\r\n { IJclIntfIterator }\r\n function Add(const AInterface: IInterface): Boolean;\r\n procedure Extract;\r\n function GetObject: IInterface;\r\n function HasNext: Boolean;\r\n function HasPrevious: Boolean;\r\n function Insert(const AInterface: IInterface): Boolean;\r\n function IteratorEquals(const AIterator: IJclIntfIterator): Boolean;\r\n function Next: IInterface;\r\n function NextIndex: Integer;\r\n function Previous: IInterface;\r\n function PreviousIndex: Integer;\r\n procedure Remove;\r\n procedure Reset;\r\n procedure SetObject(const AInterface: IInterface);\r\n {$IFDEF SUPPORTS_FOR_IN}\r\n function MoveNext: Boolean;\r\n property Current: IInterface read GetObject;\r\n {$ENDIF SUPPORTS_FOR_IN}\r\n end;\r\n\r\n TJclAnsiStrVector = class(TJclAnsiStrAbstractCollection, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclIntfCloneable, IJclCloneable, IJclPackable, IJclGrowable, IJclBaseContainer,\r\n IJclAnsiStrContainer, IJclAnsiStrFlatContainer, IJclAnsiStrEqualityComparer, IJclStrBaseContainer,\r\n IJclAnsiStrCollection, IJclAnsiStrList, IJclAnsiStrArray)\r\n protected\r\n function CreateEmptyContainer: TJclAbstractContainerBase; override;\r\n private\r\n FItems: TDynAnsiStringArray;\r\n protected\r\n procedure AssignDataTo(Dest: TJclAbstractContainerBase); override;\r\n // fix ambiguous warnings when compiled on Delphi.net and earlier versions of Delphi.win32\r\n // complaining about possible unaffected result.\r\n function RaiseOutOfBoundsError: AnsiString;\r\n public\r\n constructor Create(ACapacity: Integer); overload;\r\n constructor Create(const ACollection: IJclAnsiStrCollection); overload;\r\n destructor Destroy; override;\r\n property Items: TDynAnsiStringArray read FItems;\r\n { IJclPackable }\r\n procedure SetCapacity(Value: Integer); override;\r\n { IJclAnsiStrCollection }\r\n function Add(const AString: AnsiString): Boolean; override;\r\n function AddAll(const ACollection: IJclAnsiStrCollection): Boolean; override;\r\n procedure Clear; override;\r\n function CollectionEquals(const ACollection: IJclAnsiStrCollection): Boolean; override;\r\n function Contains(const AString: AnsiString): Boolean; override;\r\n function ContainsAll(const ACollection: IJclAnsiStrCollection): Boolean; override;\r\n function Extract(const AString: AnsiString): Boolean; override;\r\n function ExtractAll(const ACollection: IJclAnsiStrCollection): Boolean; override;\r\n function First: IJclAnsiStrIterator; override;\r\n function IsEmpty: Boolean; override;\r\n function Last: IJclAnsiStrIterator; override;\r\n function Remove(const AString: AnsiString): Boolean; override;\r\n function RemoveAll(const ACollection: IJclAnsiStrCollection): Boolean; override;\r\n function RetainAll(const ACollection: IJclAnsiStrCollection): Boolean; override;\r\n function Size: Integer; override;\r\n {$IFDEF SUPPORTS_FOR_IN}\r\n function GetEnumerator: IJclAnsiStrIterator; override;\r\n {$ENDIF SUPPORTS_FOR_IN}\r\n { IJclAnsiStrList }\r\n function Delete(Index: Integer): AnsiString;\r\n function ExtractIndex(Index: Integer): AnsiString;\r\n function GetString(Index: Integer): AnsiString;\r\n function IndexOf(const AString: AnsiString): Integer;\r\n function Insert(Index: Integer; const AString: AnsiString): Boolean;\r\n function InsertAll(Index: Integer; const ACollection: IJclAnsiStrCollection): Boolean;\r\n function LastIndexOf(const AString: AnsiString): Integer;\r\n procedure SetString(Index: Integer; const AString: AnsiString);\r\n function SubList(First, Count: Integer): IJclAnsiStrList;\r\n end;\r\n\r\n TJclAnsiStrVectorIterator = class(TJclAbstractIterator, IJclAnsiStrIterator, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclIntfCloneable, IJclCloneable)\r\n private\r\n FCursor: Integer;\r\n FStart: TItrStart;\r\n FOwnList: TJclAnsiStrVector;\r\n protected\r\n function CreateEmptyIterator: TJclAbstractIterator; override;\r\n procedure AssignPropertiesTo(Dest: TJclAbstractIterator); override;\r\n public\r\n constructor Create(AOwnList: TJclAnsiStrVector; ACursor: Integer; AValid: Boolean; AStart: TItrStart);\r\n { IJclAnsiStrIterator }\r\n function Add(const AString: AnsiString): Boolean;\r\n procedure Extract;\r\n function GetString: AnsiString;\r\n function HasNext: Boolean;\r\n function HasPrevious: Boolean;\r\n function Insert(const AString: AnsiString): Boolean;\r\n function IteratorEquals(const AIterator: IJclAnsiStrIterator): Boolean;\r\n function Next: AnsiString;\r\n function NextIndex: Integer;\r\n function Previous: AnsiString;\r\n function PreviousIndex: Integer;\r\n procedure Remove;\r\n procedure Reset;\r\n procedure SetString(const AString: AnsiString);\r\n {$IFDEF SUPPORTS_FOR_IN}\r\n function MoveNext: Boolean;\r\n property Current: AnsiString read GetString;\r\n {$ENDIF SUPPORTS_FOR_IN}\r\n end;\r\n\r\n TJclWideStrVector = class(TJclWideStrAbstractCollection, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclIntfCloneable, IJclCloneable, IJclPackable, IJclGrowable, IJclBaseContainer,\r\n IJclWideStrContainer, IJclWideStrFlatContainer, IJclWideStrEqualityComparer, IJclStrBaseContainer,\r\n IJclWideStrCollection, IJclWideStrList, IJclWideStrArray)\r\n protected\r\n function CreateEmptyContainer: TJclAbstractContainerBase; override;\r\n private\r\n FItems: TDynWideStringArray;\r\n protected\r\n procedure AssignDataTo(Dest: TJclAbstractContainerBase); override;\r\n // fix ambiguous warnings when compiled on Delphi.net and earlier versions of Delphi.win32\r\n // complaining about possible unaffected result.\r\n function RaiseOutOfBoundsError: WideString;\r\n public\r\n constructor Create(ACapacity: Integer); overload;\r\n constructor Create(const ACollection: IJclWideStrCollection); overload;\r\n destructor Destroy; override;\r\n property Items: TDynWideStringArray read FItems;\r\n { IJclPackable }\r\n procedure SetCapacity(Value: Integer); override;\r\n { IJclWideStrCollection }\r\n function Add(const AString: WideString): Boolean; override;\r\n function AddAll(const ACollection: IJclWideStrCollection): Boolean; override;\r\n procedure Clear; override;\r\n function CollectionEquals(const ACollection: IJclWideStrCollection): Boolean; override;\r\n function Contains(const AString: WideString): Boolean; override;\r\n function ContainsAll(const ACollection: IJclWideStrCollection): Boolean; override;\r\n function Extract(const AString: WideString): Boolean; override;\r\n function ExtractAll(const ACollection: IJclWideStrCollection): Boolean; override;\r\n function First: IJclWideStrIterator; override;\r\n function IsEmpty: Boolean; override;\r\n function Last: IJclWideStrIterator; override;\r\n function Remove(const AString: WideString): Boolean; override;\r\n function RemoveAll(const ACollection: IJclWideStrCollection): Boolean; override;\r\n function RetainAll(const ACollection: IJclWideStrCollection): Boolean; override;\r\n function Size: Integer; override;\r\n {$IFDEF SUPPORTS_FOR_IN}\r\n function GetEnumerator: IJclWideStrIterator; override;\r\n {$ENDIF SUPPORTS_FOR_IN}\r\n { IJclWideStrList }\r\n function Delete(Index: Integer): WideString;\r\n function ExtractIndex(Index: Integer): WideString;\r\n function GetString(Index: Integer): WideString;\r\n function IndexOf(const AString: WideString): Integer;\r\n function Insert(Index: Integer; const AString: WideString): Boolean;\r\n function InsertAll(Index: Integer; const ACollection: IJclWideStrCollection): Boolean;\r\n function LastIndexOf(const AString: WideString): Integer;\r\n procedure SetString(Index: Integer; const AString: WideString);\r\n function SubList(First, Count: Integer): IJclWideStrList;\r\n end;\r\n\r\n TJclWideStrVectorIterator = class(TJclAbstractIterator, IJclWideStrIterator, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclIntfCloneable, IJclCloneable)\r\n private\r\n FCursor: Integer;\r\n FStart: TItrStart;\r\n FOwnList: TJclWideStrVector;\r\n protected\r\n function CreateEmptyIterator: TJclAbstractIterator; override;\r\n procedure AssignPropertiesTo(Dest: TJclAbstractIterator); override;\r\n public\r\n constructor Create(AOwnList: TJclWideStrVector; ACursor: Integer; AValid: Boolean; AStart: TItrStart);\r\n { IJclWideStrIterator }\r\n function Add(const AString: WideString): Boolean;\r\n procedure Extract;\r\n function GetString: WideString;\r\n function HasNext: Boolean;\r\n function HasPrevious: Boolean;\r\n function Insert(const AString: WideString): Boolean;\r\n function IteratorEquals(const AIterator: IJclWideStrIterator): Boolean;\r\n function Next: WideString;\r\n function NextIndex: Integer;\r\n function Previous: WideString;\r\n function PreviousIndex: Integer;\r\n procedure Remove;\r\n procedure Reset;\r\n procedure SetString(const AString: WideString);\r\n {$IFDEF SUPPORTS_FOR_IN}\r\n function MoveNext: Boolean;\r\n property Current: WideString read GetString;\r\n {$ENDIF SUPPORTS_FOR_IN}\r\n end;\r\n\r\n {$IFDEF SUPPORTS_UNICODE_STRING}\r\n TJclUnicodeStrVector = class(TJclUnicodeStrAbstractCollection, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclIntfCloneable, IJclCloneable, IJclPackable, IJclGrowable, IJclBaseContainer,\r\n IJclUnicodeStrContainer, IJclUnicodeStrFlatContainer, IJclUnicodeStrEqualityComparer, IJclStrBaseContainer,\r\n IJclUnicodeStrCollection, IJclUnicodeStrList, IJclUnicodeStrArray)\r\n protected\r\n function CreateEmptyContainer: TJclAbstractContainerBase; override;\r\n private\r\n FItems: TDynUnicodeStringArray;\r\n protected\r\n procedure AssignDataTo(Dest: TJclAbstractContainerBase); override;\r\n // fix ambiguous warnings when compiled on Delphi.net and earlier versions of Delphi.win32\r\n // complaining about possible unaffected result.\r\n function RaiseOutOfBoundsError: UnicodeString;\r\n public\r\n constructor Create(ACapacity: Integer); overload;\r\n constructor Create(const ACollection: IJclUnicodeStrCollection); overload;\r\n destructor Destroy; override;\r\n property Items: TDynUnicodeStringArray read FItems;\r\n { IJclPackable }\r\n procedure SetCapacity(Value: Integer); override;\r\n { IJclUnicodeStrCollection }\r\n function Add(const AString: UnicodeString): Boolean; override;\r\n function AddAll(const ACollection: IJclUnicodeStrCollection): Boolean; override;\r\n procedure Clear; override;\r\n function CollectionEquals(const ACollection: IJclUnicodeStrCollection): Boolean; override;\r\n function Contains(const AString: UnicodeString): Boolean; override;\r\n function ContainsAll(const ACollection: IJclUnicodeStrCollection): Boolean; override;\r\n function Extract(const AString: UnicodeString): Boolean; override;\r\n function ExtractAll(const ACollection: IJclUnicodeStrCollection): Boolean; override;\r\n function First: IJclUnicodeStrIterator; override;\r\n function IsEmpty: Boolean; override;\r\n function Last: IJclUnicodeStrIterator; override;\r\n function Remove(const AString: UnicodeString): Boolean; override;\r\n function RemoveAll(const ACollection: IJclUnicodeStrCollection): Boolean; override;\r\n function RetainAll(const ACollection: IJclUnicodeStrCollection): Boolean; override;\r\n function Size: Integer; override;\r\n {$IFDEF SUPPORTS_FOR_IN}\r\n function GetEnumerator: IJclUnicodeStrIterator; override;\r\n {$ENDIF SUPPORTS_FOR_IN}\r\n { IJclUnicodeStrList }\r\n function Delete(Index: Integer): UnicodeString;\r\n function ExtractIndex(Index: Integer): UnicodeString;\r\n function GetString(Index: Integer): UnicodeString;\r\n function IndexOf(const AString: UnicodeString): Integer;\r\n function Insert(Index: Integer; const AString: UnicodeString): Boolean;\r\n function InsertAll(Index: Integer; const ACollection: IJclUnicodeStrCollection): Boolean;\r\n function LastIndexOf(const AString: UnicodeString): Integer;\r\n procedure SetString(Index: Integer; const AString: UnicodeString);\r\n function SubList(First, Count: Integer): IJclUnicodeStrList;\r\n end;\r\n {$ENDIF SUPPORTS_UNICODE_STRING}\r\n\r\n {$IFDEF SUPPORTS_UNICODE_STRING}\r\n TJclUnicodeStrVectorIterator = class(TJclAbstractIterator, IJclUnicodeStrIterator, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclIntfCloneable, IJclCloneable)\r\n private\r\n FCursor: Integer;\r\n FStart: TItrStart;\r\n FOwnList: TJclUnicodeStrVector;\r\n protected\r\n function CreateEmptyIterator: TJclAbstractIterator; override;\r\n procedure AssignPropertiesTo(Dest: TJclAbstractIterator); override;\r\n public\r\n constructor Create(AOwnList: TJclUnicodeStrVector; ACursor: Integer; AValid: Boolean; AStart: TItrStart);\r\n { IJclUnicodeStrIterator }\r\n function Add(const AString: UnicodeString): Boolean;\r\n procedure Extract;\r\n function GetString: UnicodeString;\r\n function HasNext: Boolean;\r\n function HasPrevious: Boolean;\r\n function Insert(const AString: UnicodeString): Boolean;\r\n function IteratorEquals(const AIterator: IJclUnicodeStrIterator): Boolean;\r\n function Next: UnicodeString;\r\n function NextIndex: Integer;\r\n function Previous: UnicodeString;\r\n function PreviousIndex: Integer;\r\n procedure Remove;\r\n procedure Reset;\r\n procedure SetString(const AString: UnicodeString);\r\n {$IFDEF SUPPORTS_FOR_IN}\r\n function MoveNext: Boolean;\r\n property Current: UnicodeString read GetString;\r\n {$ENDIF SUPPORTS_FOR_IN}\r\n end;\r\n {$ENDIF SUPPORTS_UNICODE_STRING}\r\n\r\n {$IFDEF CONTAINER_ANSISTR}\r\n TJclStrVector = TJclAnsiStrVector;\r\n {$ENDIF CONTAINER_ANSISTR}\r\n {$IFDEF CONTAINER_WIDESTR}\r\n TJclStrVector = TJclWideStrVector;\r\n {$ENDIF CONTAINER_WIDESTR}\r\n {$IFDEF CONTAINER_UNICODESTR}\r\n TJclStrVector = TJclUnicodeStrVector;\r\n {$ENDIF CONTAINER_UNICODESTR}\r\n\r\n {$IFDEF CONTAINER_ANSISTR}\r\n TJclStrVectorIterator = TJclAnsiStrVectorIterator;\r\n {$ENDIF CONTAINER_ANSISTR}\r\n {$IFDEF CONTAINER_WIDESTR}\r\n TJclStrVectorIterator = TJclWideStrVectorIterator;\r\n {$ENDIF CONTAINER_WIDESTR}\r\n {$IFDEF CONTAINER_UNICODESTR}\r\n TJclStrVectorIterator = TJclUnicodeStrVectorIterator;\r\n {$ENDIF CONTAINER_UNICODESTR}\r\n\r\n TJclSingleVector = class(TJclSingleAbstractContainer, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclIntfCloneable, IJclCloneable, IJclPackable, IJclGrowable, IJclBaseContainer,\r\n IJclSingleContainer, IJclSingleFlatContainer, IJclSingleEqualityComparer,\r\n IJclSingleCollection, IJclSingleList, IJclSingleArray)\r\n protected\r\n function CreateEmptyContainer: TJclAbstractContainerBase; override;\r\n private\r\n FItems: TDynSingleArray;\r\n protected\r\n procedure AssignDataTo(Dest: TJclAbstractContainerBase); override;\r\n // fix ambiguous warnings when compiled on Delphi.net and earlier versions of Delphi.win32\r\n // complaining about possible unaffected result.\r\n function RaiseOutOfBoundsError: Single;\r\n public\r\n constructor Create(ACapacity: Integer); overload;\r\n constructor Create(const ACollection: IJclSingleCollection); overload;\r\n destructor Destroy; override;\r\n property Items: TDynSingleArray read FItems;\r\n { IJclPackable }\r\n procedure SetCapacity(Value: Integer); override;\r\n { IJclSingleCollection }\r\n function Add(const AValue: Single): Boolean;\r\n function AddAll(const ACollection: IJclSingleCollection): Boolean;\r\n procedure Clear;\r\n function CollectionEquals(const ACollection: IJclSingleCollection): Boolean;\r\n function Contains(const AValue: Single): Boolean;\r\n function ContainsAll(const ACollection: IJclSingleCollection): Boolean;\r\n function Extract(const AValue: Single): Boolean; \r\n function ExtractAll(const ACollection: IJclSingleCollection): Boolean;\r\n function First: IJclSingleIterator;\r\n function IsEmpty: Boolean;\r\n function Last: IJclSingleIterator;\r\n function Remove(const AValue: Single): Boolean; \r\n function RemoveAll(const ACollection: IJclSingleCollection): Boolean;\r\n function RetainAll(const ACollection: IJclSingleCollection): Boolean;\r\n function Size: Integer;\r\n {$IFDEF SUPPORTS_FOR_IN}\r\n function GetEnumerator: IJclSingleIterator;\r\n {$ENDIF SUPPORTS_FOR_IN}\r\n { IJclSingleList }\r\n function Delete(Index: Integer): Single;\r\n function ExtractIndex(Index: Integer): Single;\r\n function GetValue(Index: Integer): Single;\r\n function IndexOf(const AValue: Single): Integer;\r\n function Insert(Index: Integer; const AValue: Single): Boolean;\r\n function InsertAll(Index: Integer; const ACollection: IJclSingleCollection): Boolean;\r\n function LastIndexOf(const AValue: Single): Integer;\r\n procedure SetValue(Index: Integer; const AValue: Single);\r\n function SubList(First, Count: Integer): IJclSingleList;\r\n end;\r\n\r\n TJclSingleVectorIterator = class(TJclAbstractIterator, IJclSingleIterator, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclIntfCloneable, IJclCloneable)\r\n private\r\n FCursor: Integer;\r\n FStart: TItrStart;\r\n FOwnList: TJclSingleVector;\r\n protected\r\n function CreateEmptyIterator: TJclAbstractIterator; override;\r\n procedure AssignPropertiesTo(Dest: TJclAbstractIterator); override;\r\n public\r\n constructor Create(AOwnList: TJclSingleVector; ACursor: Integer; AValid: Boolean; AStart: TItrStart);\r\n { IJclSingleIterator }\r\n function Add(const AValue: Single): Boolean;\r\n procedure Extract;\r\n function GetValue: Single;\r\n function HasNext: Boolean;\r\n function HasPrevious: Boolean;\r\n function Insert(const AValue: Single): Boolean;\r\n function IteratorEquals(const AIterator: IJclSingleIterator): Boolean;\r\n function Next: Single;\r\n function NextIndex: Integer;\r\n function Previous: Single;\r\n function PreviousIndex: Integer;\r\n procedure Remove;\r\n procedure Reset;\r\n procedure SetValue(const AValue: Single);\r\n {$IFDEF SUPPORTS_FOR_IN}\r\n function MoveNext: Boolean;\r\n property Current: Single read GetValue;\r\n {$ENDIF SUPPORTS_FOR_IN}\r\n end;\r\n\r\n TJclDoubleVector = class(TJclDoubleAbstractContainer, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclIntfCloneable, IJclCloneable, IJclPackable, IJclGrowable, IJclBaseContainer,\r\n IJclDoubleContainer, IJclDoubleFlatContainer, IJclDoubleEqualityComparer,\r\n IJclDoubleCollection, IJclDoubleList, IJclDoubleArray)\r\n protected\r\n function CreateEmptyContainer: TJclAbstractContainerBase; override;\r\n private\r\n FItems: TDynDoubleArray;\r\n protected\r\n procedure AssignDataTo(Dest: TJclAbstractContainerBase); override;\r\n // fix ambiguous warnings when compiled on Delphi.net and earlier versions of Delphi.win32\r\n // complaining about possible unaffected result.\r\n function RaiseOutOfBoundsError: Double;\r\n public\r\n constructor Create(ACapacity: Integer); overload;\r\n constructor Create(const ACollection: IJclDoubleCollection); overload;\r\n destructor Destroy; override;\r\n property Items: TDynDoubleArray read FItems;\r\n { IJclPackable }\r\n procedure SetCapacity(Value: Integer); override;\r\n { IJclDoubleCollection }\r\n function Add(const AValue: Double): Boolean;\r\n function AddAll(const ACollection: IJclDoubleCollection): Boolean;\r\n procedure Clear;\r\n function CollectionEquals(const ACollection: IJclDoubleCollection): Boolean;\r\n function Contains(const AValue: Double): Boolean;\r\n function ContainsAll(const ACollection: IJclDoubleCollection): Boolean;\r\n function Extract(const AValue: Double): Boolean; \r\n function ExtractAll(const ACollection: IJclDoubleCollection): Boolean;\r\n function First: IJclDoubleIterator;\r\n function IsEmpty: Boolean;\r\n function Last: IJclDoubleIterator;\r\n function Remove(const AValue: Double): Boolean; \r\n function RemoveAll(const ACollection: IJclDoubleCollection): Boolean;\r\n function RetainAll(const ACollection: IJclDoubleCollection): Boolean;\r\n function Size: Integer;\r\n {$IFDEF SUPPORTS_FOR_IN}\r\n function GetEnumerator: IJclDoubleIterator;\r\n {$ENDIF SUPPORTS_FOR_IN}\r\n { IJclDoubleList }\r\n function Delete(Index: Integer): Double;\r\n function ExtractIndex(Index: Integer): Double;\r\n function GetValue(Index: Integer): Double;\r\n function IndexOf(const AValue: Double): Integer;\r\n function Insert(Index: Integer; const AValue: Double): Boolean;\r\n function InsertAll(Index: Integer; const ACollection: IJclDoubleCollection): Boolean;\r\n function LastIndexOf(const AValue: Double): Integer;\r\n procedure SetValue(Index: Integer; const AValue: Double);\r\n function SubList(First, Count: Integer): IJclDoubleList;\r\n end;\r\n\r\n TJclDoubleVectorIterator = class(TJclAbstractIterator, IJclDoubleIterator, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclIntfCloneable, IJclCloneable)\r\n private\r\n FCursor: Integer;\r\n FStart: TItrStart;\r\n FOwnList: TJclDoubleVector;\r\n protected\r\n function CreateEmptyIterator: TJclAbstractIterator; override;\r\n procedure AssignPropertiesTo(Dest: TJclAbstractIterator); override;\r\n public\r\n constructor Create(AOwnList: TJclDoubleVector; ACursor: Integer; AValid: Boolean; AStart: TItrStart);\r\n { IJclDoubleIterator }\r\n function Add(const AValue: Double): Boolean;\r\n procedure Extract;\r\n function GetValue: Double;\r\n function HasNext: Boolean;\r\n function HasPrevious: Boolean;\r\n function Insert(const AValue: Double): Boolean;\r\n function IteratorEquals(const AIterator: IJclDoubleIterator): Boolean;\r\n function Next: Double;\r\n function NextIndex: Integer;\r\n function Previous: Double;\r\n function PreviousIndex: Integer;\r\n procedure Remove;\r\n procedure Reset;\r\n procedure SetValue(const AValue: Double);\r\n {$IFDEF SUPPORTS_FOR_IN}\r\n function MoveNext: Boolean;\r\n property Current: Double read GetValue;\r\n {$ENDIF SUPPORTS_FOR_IN}\r\n end;\r\n\r\n TJclExtendedVector = class(TJclExtendedAbstractContainer, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclIntfCloneable, IJclCloneable, IJclPackable, IJclGrowable, IJclBaseContainer,\r\n IJclExtendedContainer, IJclExtendedFlatContainer, IJclExtendedEqualityComparer,\r\n IJclExtendedCollection, IJclExtendedList, IJclExtendedArray)\r\n protected\r\n function CreateEmptyContainer: TJclAbstractContainerBase; override;\r\n private\r\n FItems: TDynExtendedArray;\r\n protected\r\n procedure AssignDataTo(Dest: TJclAbstractContainerBase); override;\r\n // fix ambiguous warnings when compiled on Delphi.net and earlier versions of Delphi.win32\r\n // complaining about possible unaffected result.\r\n function RaiseOutOfBoundsError: Extended;\r\n public\r\n constructor Create(ACapacity: Integer); overload;\r\n constructor Create(const ACollection: IJclExtendedCollection); overload;\r\n destructor Destroy; override;\r\n property Items: TDynExtendedArray read FItems;\r\n { IJclPackable }\r\n procedure SetCapacity(Value: Integer); override;\r\n { IJclExtendedCollection }\r\n function Add(const AValue: Extended): Boolean;\r\n function AddAll(const ACollection: IJclExtendedCollection): Boolean;\r\n procedure Clear;\r\n function CollectionEquals(const ACollection: IJclExtendedCollection): Boolean;\r\n function Contains(const AValue: Extended): Boolean;\r\n function ContainsAll(const ACollection: IJclExtendedCollection): Boolean;\r\n function Extract(const AValue: Extended): Boolean; \r\n function ExtractAll(const ACollection: IJclExtendedCollection): Boolean;\r\n function First: IJclExtendedIterator;\r\n function IsEmpty: Boolean;\r\n function Last: IJclExtendedIterator;\r\n function Remove(const AValue: Extended): Boolean; \r\n function RemoveAll(const ACollection: IJclExtendedCollection): Boolean;\r\n function RetainAll(const ACollection: IJclExtendedCollection): Boolean;\r\n function Size: Integer;\r\n {$IFDEF SUPPORTS_FOR_IN}\r\n function GetEnumerator: IJclExtendedIterator;\r\n {$ENDIF SUPPORTS_FOR_IN}\r\n { IJclExtendedList }\r\n function Delete(Index: Integer): Extended;\r\n function ExtractIndex(Index: Integer): Extended;\r\n function GetValue(Index: Integer): Extended;\r\n function IndexOf(const AValue: Extended): Integer;\r\n function Insert(Index: Integer; const AValue: Extended): Boolean;\r\n function InsertAll(Index: Integer; const ACollection: IJclExtendedCollection): Boolean;\r\n function LastIndexOf(const AValue: Extended): Integer;\r\n procedure SetValue(Index: Integer; const AValue: Extended);\r\n function SubList(First, Count: Integer): IJclExtendedList;\r\n end;\r\n\r\n TJclExtendedVectorIterator = class(TJclAbstractIterator, IJclExtendedIterator, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclIntfCloneable, IJclCloneable)\r\n private\r\n FCursor: Integer;\r\n FStart: TItrStart;\r\n FOwnList: TJclExtendedVector;\r\n protected\r\n function CreateEmptyIterator: TJclAbstractIterator; override;\r\n procedure AssignPropertiesTo(Dest: TJclAbstractIterator); override;\r\n public\r\n constructor Create(AOwnList: TJclExtendedVector; ACursor: Integer; AValid: Boolean; AStart: TItrStart);\r\n { IJclExtendedIterator }\r\n function Add(const AValue: Extended): Boolean;\r\n procedure Extract;\r\n function GetValue: Extended;\r\n function HasNext: Boolean;\r\n function HasPrevious: Boolean;\r\n function Insert(const AValue: Extended): Boolean;\r\n function IteratorEquals(const AIterator: IJclExtendedIterator): Boolean;\r\n function Next: Extended;\r\n function NextIndex: Integer;\r\n function Previous: Extended;\r\n function PreviousIndex: Integer;\r\n procedure Remove;\r\n procedure Reset;\r\n procedure SetValue(const AValue: Extended);\r\n {$IFDEF SUPPORTS_FOR_IN}\r\n function MoveNext: Boolean;\r\n property Current: Extended read GetValue;\r\n {$ENDIF SUPPORTS_FOR_IN}\r\n end;\r\n\r\n {$IFDEF MATH_SINGLE_PRECISION}\r\n TJclFloatVector = TJclSingleVector;\r\n {$ENDIF MATH_SINGLE_PRECISION}\r\n {$IFDEF MATH_DOUBLE_PRECISION}\r\n TJclFloatVector = TJclDoubleVector;\r\n {$ENDIF MATH_DOUBLE_PRECISION}\r\n {$IFDEF MATH_EXTENDED_PRECISION}\r\n TJclFloatVector = TJclExtendedVector;\r\n {$ENDIF MATH_EXTENDED_PRECISION}\r\n\r\n {$IFDEF MATH_SINGLE_PRECISION}\r\n TJclFloatVectorIterator = TJclSingleVectorIterator;\r\n {$ENDIF MATH_SINGLE_PRECISION}\r\n {$IFDEF MATH_DOUBLE_PRECISION}\r\n TJclFloatVectorIterator = TJclDoubleVectorIterator;\r\n {$ENDIF MATH_DOUBLE_PRECISION}\r\n {$IFDEF MATH_EXTENDED_PRECISION}\r\n TJclFloatVectorIterator = TJclExtendedVectorIterator;\r\n {$ENDIF MATH_EXTENDED_PRECISION}\r\n\r\n TJclIntegerVector = class(TJclIntegerAbstractContainer, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclIntfCloneable, IJclCloneable, IJclPackable, IJclGrowable, IJclBaseContainer,\r\n IJclIntegerContainer, IJclIntegerFlatContainer, IJclIntegerEqualityComparer,\r\n IJclIntegerCollection, IJclIntegerList, IJclIntegerArray)\r\n protected\r\n function CreateEmptyContainer: TJclAbstractContainerBase; override;\r\n private\r\n FItems: TDynIntegerArray;\r\n protected\r\n procedure AssignDataTo(Dest: TJclAbstractContainerBase); override;\r\n // fix ambiguous warnings when compiled on Delphi.net and earlier versions of Delphi.win32\r\n // complaining about possible unaffected result.\r\n function RaiseOutOfBoundsError: Integer;\r\n public\r\n constructor Create(ACapacity: Integer); overload;\r\n constructor Create(const ACollection: IJclIntegerCollection); overload;\r\n destructor Destroy; override;\r\n property Items: TDynIntegerArray read FItems;\r\n { IJclPackable }\r\n procedure SetCapacity(Value: Integer); override;\r\n { IJclIntegerCollection }\r\n function Add(AValue: Integer): Boolean;\r\n function AddAll(const ACollection: IJclIntegerCollection): Boolean;\r\n procedure Clear;\r\n function CollectionEquals(const ACollection: IJclIntegerCollection): Boolean;\r\n function Contains(AValue: Integer): Boolean;\r\n function ContainsAll(const ACollection: IJclIntegerCollection): Boolean;\r\n function Extract(AValue: Integer): Boolean; \r\n function ExtractAll(const ACollection: IJclIntegerCollection): Boolean;\r\n function First: IJclIntegerIterator;\r\n function IsEmpty: Boolean;\r\n function Last: IJclIntegerIterator;\r\n function Remove(AValue: Integer): Boolean; \r\n function RemoveAll(const ACollection: IJclIntegerCollection): Boolean;\r\n function RetainAll(const ACollection: IJclIntegerCollection): Boolean;\r\n function Size: Integer;\r\n {$IFDEF SUPPORTS_FOR_IN}\r\n function GetEnumerator: IJclIntegerIterator;\r\n {$ENDIF SUPPORTS_FOR_IN}\r\n { IJclIntegerList }\r\n function Delete(Index: Integer): Integer;\r\n function ExtractIndex(Index: Integer): Integer;\r\n function GetValue(Index: Integer): Integer;\r\n function IndexOf(AValue: Integer): Integer;\r\n function Insert(Index: Integer; AValue: Integer): Boolean;\r\n function InsertAll(Index: Integer; const ACollection: IJclIntegerCollection): Boolean;\r\n function LastIndexOf(AValue: Integer): Integer;\r\n procedure SetValue(Index: Integer; AValue: Integer);\r\n function SubList(First, Count: Integer): IJclIntegerList;\r\n end;\r\n\r\n TJclIntegerVectorIterator = class(TJclAbstractIterator, IJclIntegerIterator, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclIntfCloneable, IJclCloneable)\r\n private\r\n FCursor: Integer;\r\n FStart: TItrStart;\r\n FOwnList: TJclIntegerVector;\r\n protected\r\n function CreateEmptyIterator: TJclAbstractIterator; override;\r\n procedure AssignPropertiesTo(Dest: TJclAbstractIterator); override;\r\n public\r\n constructor Create(AOwnList: TJclIntegerVector; ACursor: Integer; AValid: Boolean; AStart: TItrStart);\r\n { IJclIntegerIterator }\r\n function Add(AValue: Integer): Boolean;\r\n procedure Extract;\r\n function GetValue: Integer;\r\n function HasNext: Boolean;\r\n function HasPrevious: Boolean;\r\n function Insert(AValue: Integer): Boolean;\r\n function IteratorEquals(const AIterator: IJclIntegerIterator): Boolean;\r\n function Next: Integer;\r\n function NextIndex: Integer;\r\n function Previous: Integer;\r\n function PreviousIndex: Integer;\r\n procedure Remove;\r\n procedure Reset;\r\n procedure SetValue(AValue: Integer);\r\n {$IFDEF SUPPORTS_FOR_IN}\r\n function MoveNext: Boolean;\r\n property Current: Integer read GetValue;\r\n {$ENDIF SUPPORTS_FOR_IN}\r\n end;\r\n\r\n TJclCardinalVector = class(TJclCardinalAbstractContainer, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclIntfCloneable, IJclCloneable, IJclPackable, IJclGrowable, IJclBaseContainer,\r\n IJclCardinalContainer, IJclCardinalFlatContainer, IJclCardinalEqualityComparer,\r\n IJclCardinalCollection, IJclCardinalList, IJclCardinalArray)\r\n protected\r\n function CreateEmptyContainer: TJclAbstractContainerBase; override;\r\n private\r\n FItems: TDynCardinalArray;\r\n protected\r\n procedure AssignDataTo(Dest: TJclAbstractContainerBase); override;\r\n // fix ambiguous warnings when compiled on Delphi.net and earlier versions of Delphi.win32\r\n // complaining about possible unaffected result.\r\n function RaiseOutOfBoundsError: Cardinal;\r\n public\r\n constructor Create(ACapacity: Integer); overload;\r\n constructor Create(const ACollection: IJclCardinalCollection); overload;\r\n destructor Destroy; override;\r\n property Items: TDynCardinalArray read FItems;\r\n { IJclPackable }\r\n procedure SetCapacity(Value: Integer); override;\r\n { IJclCardinalCollection }\r\n function Add(AValue: Cardinal): Boolean;\r\n function AddAll(const ACollection: IJclCardinalCollection): Boolean;\r\n procedure Clear;\r\n function CollectionEquals(const ACollection: IJclCardinalCollection): Boolean;\r\n function Contains(AValue: Cardinal): Boolean;\r\n function ContainsAll(const ACollection: IJclCardinalCollection): Boolean;\r\n function Extract(AValue: Cardinal): Boolean; \r\n function ExtractAll(const ACollection: IJclCardinalCollection): Boolean;\r\n function First: IJclCardinalIterator;\r\n function IsEmpty: Boolean;\r\n function Last: IJclCardinalIterator;\r\n function Remove(AValue: Cardinal): Boolean; \r\n function RemoveAll(const ACollection: IJclCardinalCollection): Boolean;\r\n function RetainAll(const ACollection: IJclCardinalCollection): Boolean;\r\n function Size: Integer;\r\n {$IFDEF SUPPORTS_FOR_IN}\r\n function GetEnumerator: IJclCardinalIterator;\r\n {$ENDIF SUPPORTS_FOR_IN}\r\n { IJclCardinalList }\r\n function Delete(Index: Integer): Cardinal;\r\n function ExtractIndex(Index: Integer): Cardinal;\r\n function GetValue(Index: Integer): Cardinal;\r\n function IndexOf(AValue: Cardinal): Integer;\r\n function Insert(Index: Integer; AValue: Cardinal): Boolean;\r\n function InsertAll(Index: Integer; const ACollection: IJclCardinalCollection): Boolean;\r\n function LastIndexOf(AValue: Cardinal): Integer;\r\n procedure SetValue(Index: Integer; AValue: Cardinal);\r\n function SubList(First, Count: Integer): IJclCardinalList;\r\n end;\r\n\r\n TJclCardinalVectorIterator = class(TJclAbstractIterator, IJclCardinalIterator, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclIntfCloneable, IJclCloneable)\r\n private\r\n FCursor: Integer;\r\n FStart: TItrStart;\r\n FOwnList: TJclCardinalVector;\r\n protected\r\n function CreateEmptyIterator: TJclAbstractIterator; override;\r\n procedure AssignPropertiesTo(Dest: TJclAbstractIterator); override;\r\n public\r\n constructor Create(AOwnList: TJclCardinalVector; ACursor: Integer; AValid: Boolean; AStart: TItrStart);\r\n { IJclCardinalIterator }\r\n function Add(AValue: Cardinal): Boolean;\r\n procedure Extract;\r\n function GetValue: Cardinal;\r\n function HasNext: Boolean;\r\n function HasPrevious: Boolean;\r\n function Insert(AValue: Cardinal): Boolean;\r\n function IteratorEquals(const AIterator: IJclCardinalIterator): Boolean;\r\n function Next: Cardinal;\r\n function NextIndex: Integer;\r\n function Previous: Cardinal;\r\n function PreviousIndex: Integer;\r\n procedure Remove;\r\n procedure Reset;\r\n procedure SetValue(AValue: Cardinal);\r\n {$IFDEF SUPPORTS_FOR_IN}\r\n function MoveNext: Boolean;\r\n property Current: Cardinal read GetValue;\r\n {$ENDIF SUPPORTS_FOR_IN}\r\n end;\r\n\r\n TJclInt64Vector = class(TJclInt64AbstractContainer, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclIntfCloneable, IJclCloneable, IJclPackable, IJclGrowable, IJclBaseContainer,\r\n IJclInt64Container, IJclInt64FlatContainer, IJclInt64EqualityComparer,\r\n IJclInt64Collection, IJclInt64List, IJclInt64Array)\r\n protected\r\n function CreateEmptyContainer: TJclAbstractContainerBase; override;\r\n private\r\n FItems: TDynInt64Array;\r\n protected\r\n procedure AssignDataTo(Dest: TJclAbstractContainerBase); override;\r\n // fix ambiguous warnings when compiled on Delphi.net and earlier versions of Delphi.win32\r\n // complaining about possible unaffected result.\r\n function RaiseOutOfBoundsError: Int64;\r\n public\r\n constructor Create(ACapacity: Integer); overload;\r\n constructor Create(const ACollection: IJclInt64Collection); overload;\r\n destructor Destroy; override;\r\n property Items: TDynInt64Array read FItems;\r\n { IJclPackable }\r\n procedure SetCapacity(Value: Integer); override;\r\n { IJclInt64Collection }\r\n function Add(const AValue: Int64): Boolean;\r\n function AddAll(const ACollection: IJclInt64Collection): Boolean;\r\n procedure Clear;\r\n function CollectionEquals(const ACollection: IJclInt64Collection): Boolean;\r\n function Contains(const AValue: Int64): Boolean;\r\n function ContainsAll(const ACollection: IJclInt64Collection): Boolean;\r\n function Extract(const AValue: Int64): Boolean; \r\n function ExtractAll(const ACollection: IJclInt64Collection): Boolean;\r\n function First: IJclInt64Iterator;\r\n function IsEmpty: Boolean;\r\n function Last: IJclInt64Iterator;\r\n function Remove(const AValue: Int64): Boolean; \r\n function RemoveAll(const ACollection: IJclInt64Collection): Boolean;\r\n function RetainAll(const ACollection: IJclInt64Collection): Boolean;\r\n function Size: Integer;\r\n {$IFDEF SUPPORTS_FOR_IN}\r\n function GetEnumerator: IJclInt64Iterator;\r\n {$ENDIF SUPPORTS_FOR_IN}\r\n { IJclInt64List }\r\n function Delete(Index: Integer): Int64;\r\n function ExtractIndex(Index: Integer): Int64;\r\n function GetValue(Index: Integer): Int64;\r\n function IndexOf(const AValue: Int64): Integer;\r\n function Insert(Index: Integer; const AValue: Int64): Boolean;\r\n function InsertAll(Index: Integer; const ACollection: IJclInt64Collection): Boolean;\r\n function LastIndexOf(const AValue: Int64): Integer;\r\n procedure SetValue(Index: Integer; const AValue: Int64);\r\n function SubList(First, Count: Integer): IJclInt64List;\r\n end;\r\n\r\n TJclInt64VectorIterator = class(TJclAbstractIterator, IJclInt64Iterator, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclIntfCloneable, IJclCloneable)\r\n private\r\n FCursor: Integer;\r\n FStart: TItrStart;\r\n FOwnList: TJclInt64Vector;\r\n protected\r\n function CreateEmptyIterator: TJclAbstractIterator; override;\r\n procedure AssignPropertiesTo(Dest: TJclAbstractIterator); override;\r\n public\r\n constructor Create(AOwnList: TJclInt64Vector; ACursor: Integer; AValid: Boolean; AStart: TItrStart);\r\n { IJclInt64Iterator }\r\n function Add(const AValue: Int64): Boolean;\r\n procedure Extract;\r\n function GetValue: Int64;\r\n function HasNext: Boolean;\r\n function HasPrevious: Boolean;\r\n function Insert(const AValue: Int64): Boolean;\r\n function IteratorEquals(const AIterator: IJclInt64Iterator): Boolean;\r\n function Next: Int64;\r\n function NextIndex: Integer;\r\n function Previous: Int64;\r\n function PreviousIndex: Integer;\r\n procedure Remove;\r\n procedure Reset;\r\n procedure SetValue(const AValue: Int64);\r\n {$IFDEF SUPPORTS_FOR_IN}\r\n function MoveNext: Boolean;\r\n property Current: Int64 read GetValue;\r\n {$ENDIF SUPPORTS_FOR_IN}\r\n end;\r\n\r\n TJclPtrVector = class(TJclPtrAbstractContainer, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclIntfCloneable, IJclCloneable, IJclPackable, IJclGrowable, IJclBaseContainer,\r\n IJclPtrContainer, IJclPtrFlatContainer, IJclPtrEqualityComparer,\r\n IJclPtrCollection, IJclPtrList, IJclPtrArray)\r\n protected\r\n function CreateEmptyContainer: TJclAbstractContainerBase; override;\r\n private\r\n FItems: TDynPointerArray;\r\n protected\r\n procedure AssignDataTo(Dest: TJclAbstractContainerBase); override;\r\n // fix ambiguous warnings when compiled on Delphi.net and earlier versions of Delphi.win32\r\n // complaining about possible unaffected result.\r\n function RaiseOutOfBoundsError: Pointer;\r\n public\r\n constructor Create(ACapacity: Integer); overload;\r\n constructor Create(const ACollection: IJclPtrCollection); overload;\r\n destructor Destroy; override;\r\n property Items: TDynPointerArray read FItems;\r\n { IJclPackable }\r\n procedure SetCapacity(Value: Integer); override;\r\n { IJclPtrCollection }\r\n function Add(APtr: Pointer): Boolean;\r\n function AddAll(const ACollection: IJclPtrCollection): Boolean;\r\n procedure Clear;\r\n function CollectionEquals(const ACollection: IJclPtrCollection): Boolean;\r\n function Contains(APtr: Pointer): Boolean;\r\n function ContainsAll(const ACollection: IJclPtrCollection): Boolean;\r\n function Extract(APtr: Pointer): Boolean; \r\n function ExtractAll(const ACollection: IJclPtrCollection): Boolean;\r\n function First: IJclPtrIterator;\r\n function IsEmpty: Boolean;\r\n function Last: IJclPtrIterator;\r\n function Remove(APtr: Pointer): Boolean; \r\n function RemoveAll(const ACollection: IJclPtrCollection): Boolean;\r\n function RetainAll(const ACollection: IJclPtrCollection): Boolean;\r\n function Size: Integer;\r\n {$IFDEF SUPPORTS_FOR_IN}\r\n function GetEnumerator: IJclPtrIterator;\r\n {$ENDIF SUPPORTS_FOR_IN}\r\n { IJclPtrList }\r\n function Delete(Index: Integer): Pointer;\r\n function ExtractIndex(Index: Integer): Pointer;\r\n function GetPointer(Index: Integer): Pointer;\r\n function IndexOf(APtr: Pointer): Integer;\r\n function Insert(Index: Integer; APtr: Pointer): Boolean;\r\n function InsertAll(Index: Integer; const ACollection: IJclPtrCollection): Boolean;\r\n function LastIndexOf(APtr: Pointer): Integer;\r\n procedure SetPointer(Index: Integer; APtr: Pointer);\r\n function SubList(First, Count: Integer): IJclPtrList;\r\n end;\r\n\r\n TJclPtrVectorIterator = class(TJclAbstractIterator, IJclPtrIterator, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclIntfCloneable, IJclCloneable)\r\n private\r\n FCursor: Integer;\r\n FStart: TItrStart;\r\n FOwnList: TJclPtrVector;\r\n protected\r\n function CreateEmptyIterator: TJclAbstractIterator; override;\r\n procedure AssignPropertiesTo(Dest: TJclAbstractIterator); override;\r\n public\r\n constructor Create(AOwnList: TJclPtrVector; ACursor: Integer; AValid: Boolean; AStart: TItrStart);\r\n { IJclPtrIterator }\r\n function Add(APtr: Pointer): Boolean;\r\n procedure Extract;\r\n function GetPointer: Pointer;\r\n function HasNext: Boolean;\r\n function HasPrevious: Boolean;\r\n function Insert(APtr: Pointer): Boolean;\r\n function IteratorEquals(const AIterator: IJclPtrIterator): Boolean;\r\n function Next: Pointer;\r\n function NextIndex: Integer;\r\n function Previous: Pointer;\r\n function PreviousIndex: Integer;\r\n procedure Remove;\r\n procedure Reset;\r\n procedure SetPointer(APtr: Pointer);\r\n {$IFDEF SUPPORTS_FOR_IN}\r\n function MoveNext: Boolean;\r\n property Current: Pointer read GetPointer;\r\n {$ENDIF SUPPORTS_FOR_IN}\r\n end;\r\n\r\n TJclVector = class(TJclAbstractContainer, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclIntfCloneable, IJclCloneable, IJclPackable, IJclGrowable, IJclBaseContainer,\r\n IJclContainer, IJclFlatContainer, IJclEqualityComparer, IJclObjectOwner,\r\n IJclCollection, IJclList, IJclArray)\r\n protected\r\n function CreateEmptyContainer: TJclAbstractContainerBase; override;\r\n private\r\n FItems: TDynObjectArray;\r\n protected\r\n procedure AssignDataTo(Dest: TJclAbstractContainerBase); override;\r\n // fix ambiguous warnings when compiled on Delphi.net and earlier versions of Delphi.win32\r\n // complaining about possible unaffected result.\r\n function RaiseOutOfBoundsError: TObject;\r\n public\r\n constructor Create(ACapacity: Integer; AOwnsObjects: Boolean); overload;\r\n constructor Create(const ACollection: IJclCollection; AOwnsObjects: Boolean); overload;\r\n destructor Destroy; override;\r\n property Items: TDynObjectArray read FItems;\r\n { IJclPackable }\r\n procedure SetCapacity(Value: Integer); override;\r\n { IJclCollection }\r\n function Add(AObject: TObject): Boolean;\r\n function AddAll(const ACollection: IJclCollection): Boolean;\r\n procedure Clear;\r\n function CollectionEquals(const ACollection: IJclCollection): Boolean;\r\n function Contains(AObject: TObject): Boolean;\r\n function ContainsAll(const ACollection: IJclCollection): Boolean;\r\n function Extract(AObject: TObject): Boolean; \r\n function ExtractAll(const ACollection: IJclCollection): Boolean;\r\n function First: IJclIterator;\r\n function IsEmpty: Boolean;\r\n function Last: IJclIterator;\r\n function Remove(AObject: TObject): Boolean; \r\n function RemoveAll(const ACollection: IJclCollection): Boolean;\r\n function RetainAll(const ACollection: IJclCollection): Boolean;\r\n function Size: Integer;\r\n {$IFDEF SUPPORTS_FOR_IN}\r\n function GetEnumerator: IJclIterator;\r\n {$ENDIF SUPPORTS_FOR_IN}\r\n { IJclList }\r\n function Delete(Index: Integer): TObject;\r\n function ExtractIndex(Index: Integer): TObject;\r\n function GetObject(Index: Integer): TObject;\r\n function IndexOf(AObject: TObject): Integer;\r\n function Insert(Index: Integer; AObject: TObject): Boolean;\r\n function InsertAll(Index: Integer; const ACollection: IJclCollection): Boolean;\r\n function LastIndexOf(AObject: TObject): Integer;\r\n procedure SetObject(Index: Integer; AObject: TObject);\r\n function SubList(First, Count: Integer): IJclList;\r\n end;\r\n\r\n TJclVectorIterator = class(TJclAbstractIterator, IJclIterator, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclIntfCloneable, IJclCloneable)\r\n private\r\n FCursor: Integer;\r\n FStart: TItrStart;\r\n FOwnList: TJclVector;\r\n protected\r\n function CreateEmptyIterator: TJclAbstractIterator; override;\r\n procedure AssignPropertiesTo(Dest: TJclAbstractIterator); override;\r\n public\r\n constructor Create(AOwnList: TJclVector; ACursor: Integer; AValid: Boolean; AStart: TItrStart);\r\n { IJclIterator }\r\n function Add(AObject: TObject): Boolean;\r\n procedure Extract;\r\n function GetObject: TObject;\r\n function HasNext: Boolean;\r\n function HasPrevious: Boolean;\r\n function Insert(AObject: TObject): Boolean;\r\n function IteratorEquals(const AIterator: IJclIterator): Boolean;\r\n function Next: TObject;\r\n function NextIndex: Integer;\r\n function Previous: TObject;\r\n function PreviousIndex: Integer;\r\n procedure Remove;\r\n procedure Reset;\r\n procedure SetObject(AObject: TObject);\r\n {$IFDEF SUPPORTS_FOR_IN}\r\n function MoveNext: Boolean;\r\n property Current: TObject read GetObject;\r\n {$ENDIF SUPPORTS_FOR_IN}\r\n end;\r\n\r\n\r\n {$IFDEF SUPPORTS_GENERICS}\r\n //DOM-IGNORE-BEGIN\r\n\r\n TJclVectorIterator = class;\r\n\r\n TJclVector = class(TJclAbstractContainer, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclIntfCloneable, IJclCloneable, IJclPackable, IJclGrowable, IJclBaseContainer,\r\n IJclContainer, IJclFlatContainer, IJclEqualityComparer, IJclItemOwner,\r\n IJclCollection, IJclList, IJclArray)\r\n protected\r\n type\r\n TDynArray = array of T;\r\n TVectorIterator = TJclVectorIterator;\r\n procedure MoveArray(var List: TDynArray; FromIndex, ToIndex, Count: SizeInt);\r\n private\r\n FItems: TDynArray;\r\n protected\r\n procedure AssignDataTo(Dest: TJclAbstractContainerBase); override;\r\n // fix ambiguous warnings when compiled on Delphi.net and earlier versions of Delphi.win32\r\n // complaining about possible unaffected result.\r\n function RaiseOutOfBoundsError: T;\r\n public\r\n constructor Create(ACapacity: Integer; AOwnsItems: Boolean); overload;\r\n constructor Create(const ACollection: IJclCollection; AOwnsItems: Boolean); overload;\r\n destructor Destroy; override;\r\n property Items: TDynArray read FItems;\r\n { IJclPackable }\r\n procedure SetCapacity(Value: Integer); override;\r\n { IJclCollection }\r\n function Add(const AItem: T): Boolean;\r\n function AddAll(const ACollection: IJclCollection): Boolean;\r\n procedure Clear;\r\n function CollectionEquals(const ACollection: IJclCollection): Boolean;\r\n function Contains(const AItem: T): Boolean;\r\n function ContainsAll(const ACollection: IJclCollection): Boolean;\r\n function Extract(const AItem: T): Boolean; \r\n function ExtractAll(const ACollection: IJclCollection): Boolean;\r\n function First: IJclIterator;\r\n function IsEmpty: Boolean;\r\n function Last: IJclIterator;\r\n function Remove(const AItem: T): Boolean; \r\n function RemoveAll(const ACollection: IJclCollection): Boolean;\r\n function RetainAll(const ACollection: IJclCollection): Boolean;\r\n function Size: Integer;\r\n {$IFDEF SUPPORTS_FOR_IN}\r\n function GetEnumerator: IJclIterator;\r\n {$ENDIF SUPPORTS_FOR_IN}\r\n { IJclList }\r\n function Delete(Index: Integer): T;\r\n function ExtractIndex(Index: Integer): T;\r\n function GetItem(Index: Integer): T;\r\n function IndexOf(const AItem: T): Integer;\r\n function Insert(Index: Integer; const AItem: T): Boolean;\r\n function InsertAll(Index: Integer; const ACollection: IJclCollection): Boolean;\r\n function LastIndexOf(const AItem: T): Integer;\r\n procedure SetItem(Index: Integer; const AItem: T);\r\n function SubList(First, Count: Integer): IJclList;\r\n end;\r\n\r\n TJclVectorIterator = class(TJclAbstractIterator, IJclIterator, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclIntfCloneable, IJclCloneable)\r\n private\r\n FCursor: Integer;\r\n FStart: TItrStart;\r\n FOwnList: IJclList;\r\n protected\r\n function CreateEmptyIterator: TJclAbstractIterator; override;\r\n procedure AssignPropertiesTo(Dest: TJclAbstractIterator); override;\r\n public\r\n constructor Create(AOwnList: IJclList; ACursor: Integer; AValid: Boolean; AStart: TItrStart);\r\n { IJclIterator }\r\n function Add(const AItem: T): Boolean;\r\n procedure Extract;\r\n function GetItem: T;\r\n function HasNext: Boolean;\r\n function HasPrevious: Boolean;\r\n function Insert(const AItem: T): Boolean;\r\n function IteratorEquals(const AIterator: IJclIterator): Boolean;\r\n function Next: T;\r\n function NextIndex: Integer;\r\n function Previous: T;\r\n function PreviousIndex: Integer;\r\n procedure Remove;\r\n procedure Reset;\r\n procedure SetItem(const AItem: T);\r\n {$IFDEF SUPPORTS_FOR_IN}\r\n function MoveNext: Boolean;\r\n property Current: T read GetItem;\r\n {$ENDIF SUPPORTS_FOR_IN}\r\n end;\r\n\r\n // E = External helper to compare items for equality (GetHashCode is not used)\r\n TJclVectorE = class(TJclVector, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclIntfCloneable, IJclCloneable, IJclPackable, IJclGrowable, IJclBaseContainer, IJclContainer,\r\n IJclCollection, IJclList, IJclArray, IJclItemOwner)\r\n private\r\n FEqualityComparer: IJclEqualityComparer;\r\n protected\r\n procedure AssignPropertiesTo(Dest: TJclAbstractContainerBase); override;\r\n function CreateEmptyContainer: TJclAbstractContainerBase; override;\r\n public\r\n constructor Create(const AEqualityComparer: IJclEqualityComparer; ACapacity: Integer; AOwnsItems: Boolean);\r\n { IJclEqualityComparer }\r\n function ItemsEqual(const A, B: T): Boolean; override;\r\n property EqualityComparer: IJclEqualityComparer read FEqualityComparer write FEqualityComparer;\r\n end;\r\n\r\n // F = Function to compare items for equality\r\n TJclVectorF = class(TJclVector, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclIntfCloneable, IJclCloneable, IJclPackable, IJclGrowable, IJclBaseContainer, IJclContainer,\r\n IJclCollection, IJclList, IJclArray, IJclItemOwner)\r\n protected\r\n function CreateEmptyContainer: TJclAbstractContainerBase; override;\r\n public\r\n constructor Create(const AEqualityCompare: TEqualityCompare; ACapacity: Integer; AOwnsItems: Boolean);\r\n end;\r\n\r\n // I = Items can compare themselves to an other for equality\r\n TJclVectorI> = class(TJclVector, {$IFDEF THREADSAFE} IJclLockable, {$ENDIF THREADSAFE}\r\n IJclIntfCloneable, IJclCloneable, IJclPackable, IJclGrowable, IJclBaseContainer, IJclContainer,\r\n IJclCollection, IJclList, IJclArray, IJclItemOwner)\r\n protected\r\n function CreateEmptyContainer: TJclAbstractContainerBase; override;\r\n public\r\n { IJclEqualityComparer }\r\n function ItemsEqual(const A, B: T): Boolean; override;\r\n end;\r\n\r\n //DOM-IGNORE-END\r\n {$ENDIF SUPPORTS_GENERICS}\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jcl.svn.sourceforge.net/svnroot/jcl/tags/JCL-2.4-Build4571/jcl/source/common/JclVectors.pas $';\r\n Revision: '$Revision: 3745 $';\r\n Date: '$Date: 2012-02-24 12:14:46 +0100 (ven. 24 févr. 2012) $';\r\n LogPath: 'JCL\\source\\common';\r\n Extra: '';\r\n Data: nil\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n {$IFDEF HAS_UNITSCOPE}\r\n System.SysUtils;\r\n {$ELSE ~HAS_UNITSCOPE}\r\n SysUtils;\r\n {$ENDIF ~HAS_UNITSCOPE}\r\n\r\n//=== { TJclIntfVector } ======================================================\r\n\r\nconstructor TJclIntfVector.Create(ACapacity: Integer);\r\nbegin\r\n inherited Create();\r\n SetCapacity(ACapacity);\r\nend;\r\n\r\nconstructor TJclIntfVector.Create(const ACollection: IJclIntfCollection);\r\nbegin\r\n inherited Create();\r\n if ACollection = nil then\r\n raise EJclNoCollectionError.Create;\r\n SetCapacity(ACollection.Size);\r\n AddAll(ACollection);\r\nend;\r\n\r\ndestructor TJclIntfVector.Destroy;\r\nbegin\r\n FReadOnly := False;\r\n Clear;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJclIntfVector.Add(const AInterface: IInterface): Boolean;\r\nvar\r\n Index: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := FAllowDefaultElements or not ItemsEqual(AInterface, nil);\r\n if Result then\r\n begin\r\n if FDuplicates <> dupAccept then\r\n for Index := 0 to FSize - 1 do\r\n if ItemsEqual(AInterface, FItems[Index]) then\r\n begin\r\n Result := CheckDuplicate;\r\n Break;\r\n end;\r\n if Result then\r\n begin\r\n if FSize = FCapacity then\r\n AutoGrow;\r\n Result := FSize < FCapacity;\r\n if Result then\r\n begin\r\n FItems[FSize] := AInterface;\r\n Inc(FSize);\r\n end;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfVector.AddAll(const ACollection: IJclIntfCollection): Boolean;\r\nvar\r\n It: IJclIntfIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n Result := Add(It.Next) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclIntfVector.AssignDataTo(Dest: TJclAbstractContainerBase);\r\nvar\r\n ADest: TJclIntfVector;\r\n ACollection: IJclIntfCollection;\r\nbegin\r\n inherited AssignDataTo(Dest);\r\n if Dest is TJclIntfVector then\r\n begin\r\n ADest := TJclIntfVector(Dest);\r\n ADest.Clear;\r\n ADest.AddAll(Self);\r\n end\r\n else\r\n if Supports(IInterface(Dest), IJclIntfCollection, ACollection) then\r\n begin\r\n ACollection.Clear;\r\n ACollection.AddAll(Self);\r\n end;\r\nend;\r\n\r\nprocedure TJclIntfVector.Clear;\r\nvar\r\n I: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n for I := 0 to FSize - 1 do\r\n FreeObject(FItems[I]);\r\n FSize := 0;\r\n AutoPack;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfVector.CollectionEquals(const ACollection: IJclIntfCollection): Boolean;\r\nvar\r\n I: Integer;\r\n It: IJclIntfIterator;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n if FSize <> ACollection.Size then\r\n Exit;\r\n It := ACollection.First;\r\n for I := 0 to FSize - 1 do\r\n if not ItemsEqual(FItems[I], It.Next) then\r\n Exit;\r\n Result := True;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfVector.Contains(const AInterface: IInterface): Boolean;\r\nvar\r\n I: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n for I := 0 to FSize - 1 do\r\n if ItemsEqual(FItems[I], AInterface) then\r\n begin\r\n Result := True;\r\n Break;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfVector.ContainsAll(const ACollection: IJclIntfCollection): Boolean;\r\nvar\r\n It: IJclIntfIterator;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := True;\r\n if ACollection = nil then\r\n Exit;\r\n It := ACollection.First;\r\n while Result and It.HasNext do\r\n Result := Contains(It.Next);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfVector.Delete(Index: Integer): IInterface;\r\nvar\r\n Extracted: IInterface;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Extracted := ExtractIndex(Index);\r\n Result := FreeObject(Extracted);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfVector.Extract(const AInterface: IInterface): Boolean;\r\nvar\r\n I: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n for I := FSize - 1 downto 0 do\r\n if ItemsEqual(FItems[I], AInterface) then\r\n begin\r\n if I < (FSize - 1) then\r\n MoveArray(FItems, I + 1, I, FSize - 1 - I)\r\n else\r\n FItems[I] := nil;\r\n Dec(FSize);\r\n Result := True;\r\n if FRemoveSingleElement then\r\n Break;\r\n end;\r\n AutoPack;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfVector.ExtractAll(const ACollection: IJclIntfCollection): Boolean;\r\nvar\r\n It: IJclIntfIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n Result := Extract(It.Next) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfVector.ExtractIndex(Index: Integer): IInterface;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if (Index >= 0) and (Index < FSize) then\r\n begin\r\n Result := FItems[Index];\r\n if Index < (FSize - 1) then\r\n MoveArray(FItems, Index + 1, Index, FSize - 1 - Index)\r\n else\r\n FItems[Index] := nil;\r\n Dec(FSize);\r\n AutoPack;\r\n end\r\n else\r\n Result := RaiseOutOfBoundsError;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfVector.First: IJclIntfIterator;\r\nbegin\r\n Result := TJclIntfVectorIterator.Create(Self, 0, False, isFirst);\r\nend;\r\n\r\n{$IFDEF SUPPORTS_FOR_IN}\r\nfunction TJclIntfVector.GetEnumerator: IJclIntfIterator;\r\nbegin\r\n Result := TJclIntfVectorIterator.Create(Self, 0, False, isFirst);\r\nend;\r\n{$ENDIF SUPPORTS_FOR_IN}\r\n\r\nfunction TJclIntfVector.GetObject(Index: Integer): IInterface;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := nil;\r\n if (Index >= 0) or (Index < FSize) then\r\n Result := FItems[Index]\r\n else\r\n if not FReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create(IntToStr(Index));\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfVector.IndexOf(const AInterface: IInterface): Integer;\r\nvar\r\n I: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := -1;\r\n for I := 0 to FSize - 1 do\r\n if ItemsEqual(FItems[I], AInterface) then\r\n begin\r\n Result := I;\r\n Break;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfVector.Insert(Index: Integer; const AInterface: IInterface): Boolean;\r\nvar\r\n I: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := FAllowDefaultElements or not ItemsEqual(AInterface, nil);\r\n if (Index < 0) or (Index > FSize) then\r\n raise EJclOutOfBoundsError.Create;\r\n if Result then\r\n begin\r\n if FDuplicates <> dupAccept then\r\n for I := 0 to FSize - 1 do\r\n if ItemsEqual(AInterface, FItems[I]) then\r\n begin\r\n Result := CheckDuplicate;\r\n Break;\r\n end;\r\n if Result then\r\n begin\r\n if FSize = FCapacity then\r\n AutoGrow;\r\n Result := FSize < FCapacity;\r\n if Result then\r\n begin\r\n if Index < FSize then\r\n MoveArray(FItems, Index, Index + 1, FSize - Index);\r\n FItems[Index] := AInterface;\r\n Inc(FSize);\r\n end;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfVector.InsertAll(Index: Integer; const ACollection: IJclIntfCollection): Boolean;\r\nvar\r\n It: IJclIntfIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if (Index < 0) or (Index > FSize) then\r\n raise EJclOutOfBoundsError.Create;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := ACollection.Last;\r\n while It.HasPrevious do\r\n Result := Insert(Index, It.Previous) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfVector.IsEmpty: Boolean;\r\nbegin\r\n Result := FSize = 0;\r\nend;\r\n\r\nfunction TJclIntfVector.Last: IJclIntfIterator;\r\nbegin\r\n Result := TJclIntfVectorIterator.Create(Self, FSize - 1, False, isLast);\r\nend;\r\n\r\nfunction TJclIntfVector.LastIndexOf(const AInterface: IInterface): Integer;\r\nvar\r\n I: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := -1;\r\n for I := FSize - 1 downto 0 do\r\n if ItemsEqual(FItems[I], AInterface) then\r\n begin\r\n Result := I;\r\n Break;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfVector.RaiseOutOfBoundsError: IInterface;\r\nbegin\r\n raise EJclOutOfBoundsError.Create;\r\nend;\r\n\r\nfunction TJclIntfVector.Remove(const AInterface: IInterface): Boolean;\r\nvar\r\n Extracted: IInterface;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := Extract(AInterface);\r\n if Result then\r\n begin\r\n Extracted := AInterface;\r\n FreeObject(Extracted);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfVector.RemoveAll(const ACollection: IJclIntfCollection): Boolean;\r\nvar\r\n It: IJclIntfIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n Result := Remove(It.Next) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfVector.RetainAll(const ACollection: IJclIntfCollection): Boolean;\r\nvar\r\n I: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n for I := FSize - 1 downto 0 do\r\n if not ACollection.Contains(FItems[I]) then\r\n Delete(I);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclIntfVector.SetCapacity(Value: Integer);\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Value >= FSize then\r\n begin\r\n SetLength(FItems, Value);\r\n inherited SetCapacity(Value);\r\n end\r\n else\r\n raise EJclOutOfBoundsError.Create;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclIntfVector.SetObject(Index: Integer; const AInterface: IInterface);\r\nvar\r\n ReplaceItem: Boolean;\r\n I: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if (Index < 0) or (Index >= FSize) then\r\n raise EJclOutOfBoundsError.Create;\r\n ReplaceItem := FAllowDefaultElements or not ItemsEqual(AInterface, nil);\r\n if ReplaceItem then\r\n begin\r\n if FDuplicates <> dupAccept then\r\n for I := 0 to FSize - 1 do\r\n if ItemsEqual(AInterface, FItems[I]) then\r\n begin\r\n ReplaceItem := CheckDuplicate;\r\n Break;\r\n end;\r\n if ReplaceItem then\r\n begin\r\n FreeObject(FItems[Index]);\r\n FItems[Index] := AInterface;\r\n end;\r\n end;\r\n if not ReplaceItem then\r\n Delete(Index);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfVector.Size: Integer;\r\nbegin\r\n Result := FSize;\r\nend;\r\n\r\nfunction TJclIntfVector.SubList(First, Count: Integer): IJclIntfList;\r\nvar\r\n I: Integer;\r\n Last: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Last := First + Count - 1;\r\n if Last >= FSize then\r\n Last := FSize - 1;\r\n Result := CreateEmptyContainer as IJclIntfList;\r\n for I := First to Last do\r\n Result.Add(FItems[I]);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntfVector.CreateEmptyContainer: TJclAbstractContainerBase;\r\nbegin\r\n Result := TJclIntfVector.Create(FSize);\r\n AssignPropertiesTo(Result);\r\nend;\r\n\r\n//=== { TJclIntfVectorIterator } ===========================================================\r\n\r\nconstructor TJclIntfVectorIterator.Create(AOwnList: TJclIntfVector; ACursor: Integer; AValid: Boolean; AStart: TItrStart);\r\nbegin\r\n inherited Create(AValid);\r\n FOwnList := AOwnList;\r\n FStart := AStart;\r\n FCursor := ACursor;\r\nend;\r\n\r\nfunction TJclIntfVectorIterator.Add(const AInterface: IInterface): Boolean;\r\nbegin\r\n Result := FOwnList.Add(AInterface);\r\nend;\r\n\r\nprocedure TJclIntfVectorIterator.AssignPropertiesTo(Dest: TJclAbstractIterator);\r\nvar\r\n ADest: TJclIntfVectorIterator;\r\nbegin\r\n inherited AssignPropertiesTo(Dest);\r\n if Dest is TJclIntfVectorIterator then\r\n begin\r\n ADest := TJclIntfVectorIterator(Dest);\r\n ADest.FOwnList := FOwnList;\r\n ADest.FCursor := FCursor;\r\n ADest.FStart := FStart;\r\n end;\r\nend;\r\n\r\nfunction TJclIntfVectorIterator.CreateEmptyIterator: TJclAbstractIterator;\r\nbegin\r\n Result := TJclIntfVectorIterator.Create(FOwnList, FCursor, Valid, FStart);\r\nend;\r\n\r\nprocedure TJclIntfVectorIterator.Extract;\r\nbegin\r\n CheckValid;\r\n Valid := False;\r\n FOwnList.ExtractIndex(FCursor);\r\nend;\r\n\r\nfunction TJclIntfVectorIterator.GetObject: IInterface;\r\nbegin\r\n CheckValid;\r\n Result := FOwnList.GetObject(FCursor);\r\nend;\r\n\r\nfunction TJclIntfVectorIterator.HasNext: Boolean;\r\nbegin\r\n if Valid then\r\n Result := FCursor < (FOwnList.Size - 1)\r\n else\r\n Result := FCursor < FOwnList.Size;\r\nend;\r\n\r\nfunction TJclIntfVectorIterator.HasPrevious: Boolean;\r\nbegin\r\n if Valid then\r\n Result := FCursor > 0\r\n else\r\n Result := FCursor >= 0;\r\nend;\r\n\r\nfunction TJclIntfVectorIterator.Insert(const AInterface: IInterface): Boolean;\r\nbegin\r\n CheckValid;\r\n Result := FOwnList.Insert(FCursor, AInterface);\r\nend;\r\n\r\nfunction TJclIntfVectorIterator.IteratorEquals(const AIterator: IJclIntfIterator): Boolean;\r\nvar\r\n Obj: TObject;\r\n ItrObj: TJclIntfVectorIterator;\r\nbegin\r\n Result := False;\r\n if AIterator = nil then\r\n Exit;\r\n Obj := AIterator.GetIteratorReference;\r\n if Obj is TJclIntfVectorIterator then\r\n begin\r\n ItrObj := TJclIntfVectorIterator(Obj);\r\n Result := (FOwnList = ItrObj.FOwnList) and (FCursor = ItrObj.FCursor) and (Valid = ItrObj.Valid);\r\n end;\r\nend;\r\n\r\n{$IFDEF SUPPORTS_FOR_IN}\r\nfunction TJclIntfVectorIterator.MoveNext: Boolean;\r\nbegin\r\n if Valid then\r\n Inc(FCursor)\r\n else\r\n Valid := True;\r\n Result := FCursor < FOwnList.Size;\r\nend;\r\n{$ENDIF SUPPORTS_FOR_IN}\r\n\r\nfunction TJclIntfVectorIterator.Next: IInterface;\r\nbegin\r\n if Valid then\r\n Inc(FCursor)\r\n else\r\n Valid := True;\r\n Result := FOwnList.GetObject(FCursor);\r\nend;\r\n\r\nfunction TJclIntfVectorIterator.NextIndex: Integer;\r\nbegin\r\n if Valid then\r\n Result := FCursor + 1\r\n else\r\n Result := FCursor;\r\nend;\r\n\r\nfunction TJclIntfVectorIterator.Previous: IInterface;\r\nbegin\r\n if Valid then\r\n Dec(FCursor)\r\n else\r\n Valid := True;\r\n Result := FOwnList.GetObject(FCursor);\r\nend;\r\n\r\nfunction TJclIntfVectorIterator.PreviousIndex: Integer;\r\nbegin\r\n if Valid then\r\n Result := FCursor - 1\r\n else\r\n Result := FCursor;\r\nend;\r\n\r\nprocedure TJclIntfVectorIterator.Remove;\r\nbegin\r\n CheckValid;\r\n Valid := False;\r\n FOwnList.Delete(FCursor);\r\nend;\r\n\r\nprocedure TJclIntfVectorIterator.Reset;\r\nbegin\r\n Valid := False;\r\n case FStart of\r\n isFirst:\r\n FCursor := 0;\r\n isLast:\r\n FCursor := FOwnList.Size - 1;\r\n end;\r\nend;\r\n\r\nprocedure TJclIntfVectorIterator.SetObject(const AInterface: IInterface);\r\nbegin\r\n CheckValid;\r\n FOwnList.SetObject(FCursor, AInterface);\r\nend;\r\n\r\n//=== { TJclAnsiStrVector } ======================================================\r\n\r\nconstructor TJclAnsiStrVector.Create(ACapacity: Integer);\r\nbegin\r\n inherited Create();\r\n SetCapacity(ACapacity);\r\nend;\r\n\r\nconstructor TJclAnsiStrVector.Create(const ACollection: IJclAnsiStrCollection);\r\nbegin\r\n inherited Create();\r\n if ACollection = nil then\r\n raise EJclNoCollectionError.Create;\r\n SetCapacity(ACollection.Size);\r\n AddAll(ACollection);\r\nend;\r\n\r\ndestructor TJclAnsiStrVector.Destroy;\r\nbegin\r\n FReadOnly := False;\r\n Clear;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJclAnsiStrVector.Add(const AString: AnsiString): Boolean;\r\nvar\r\n Index: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := FAllowDefaultElements or not ItemsEqual(AString, '');\r\n if Result then\r\n begin\r\n if FDuplicates <> dupAccept then\r\n for Index := 0 to FSize - 1 do\r\n if ItemsEqual(AString, FItems[Index]) then\r\n begin\r\n Result := CheckDuplicate;\r\n Break;\r\n end;\r\n if Result then\r\n begin\r\n if FSize = FCapacity then\r\n AutoGrow;\r\n Result := FSize < FCapacity;\r\n if Result then\r\n begin\r\n FItems[FSize] := AString;\r\n Inc(FSize);\r\n end;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclAnsiStrVector.AddAll(const ACollection: IJclAnsiStrCollection): Boolean;\r\nvar\r\n It: IJclAnsiStrIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n Result := Add(It.Next) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclAnsiStrVector.AssignDataTo(Dest: TJclAbstractContainerBase);\r\nvar\r\n ADest: TJclAnsiStrVector;\r\n ACollection: IJclAnsiStrCollection;\r\nbegin\r\n inherited AssignDataTo(Dest);\r\n if Dest is TJclAnsiStrVector then\r\n begin\r\n ADest := TJclAnsiStrVector(Dest);\r\n ADest.Clear;\r\n ADest.AddAll(Self);\r\n end\r\n else\r\n if Supports(IInterface(Dest), IJclAnsiStrCollection, ACollection) then\r\n begin\r\n ACollection.Clear;\r\n ACollection.AddAll(Self);\r\n end;\r\nend;\r\n\r\nprocedure TJclAnsiStrVector.Clear;\r\nvar\r\n I: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n for I := 0 to FSize - 1 do\r\n FreeString(FItems[I]);\r\n FSize := 0;\r\n AutoPack;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclAnsiStrVector.CollectionEquals(const ACollection: IJclAnsiStrCollection): Boolean;\r\nvar\r\n I: Integer;\r\n It: IJclAnsiStrIterator;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n if FSize <> ACollection.Size then\r\n Exit;\r\n It := ACollection.First;\r\n for I := 0 to FSize - 1 do\r\n if not ItemsEqual(FItems[I], It.Next) then\r\n Exit;\r\n Result := True;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclAnsiStrVector.Contains(const AString: AnsiString): Boolean;\r\nvar\r\n I: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n for I := 0 to FSize - 1 do\r\n if ItemsEqual(FItems[I], AString) then\r\n begin\r\n Result := True;\r\n Break;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclAnsiStrVector.ContainsAll(const ACollection: IJclAnsiStrCollection): Boolean;\r\nvar\r\n It: IJclAnsiStrIterator;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := True;\r\n if ACollection = nil then\r\n Exit;\r\n It := ACollection.First;\r\n while Result and It.HasNext do\r\n Result := Contains(It.Next);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclAnsiStrVector.Delete(Index: Integer): AnsiString;\r\nvar\r\n Extracted: AnsiString;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Extracted := ExtractIndex(Index);\r\n Result := FreeString(Extracted);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclAnsiStrVector.Extract(const AString: AnsiString): Boolean;\r\nvar\r\n I: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n for I := FSize - 1 downto 0 do\r\n if ItemsEqual(FItems[I], AString) then\r\n begin\r\n if I < (FSize - 1) then\r\n MoveArray(FItems, I + 1, I, FSize - 1 - I)\r\n else\r\n FItems[I] := '';\r\n Dec(FSize);\r\n Result := True;\r\n if FRemoveSingleElement then\r\n Break;\r\n end;\r\n AutoPack;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclAnsiStrVector.ExtractAll(const ACollection: IJclAnsiStrCollection): Boolean;\r\nvar\r\n It: IJclAnsiStrIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n Result := Extract(It.Next) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclAnsiStrVector.ExtractIndex(Index: Integer): AnsiString;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if (Index >= 0) and (Index < FSize) then\r\n begin\r\n Result := FItems[Index];\r\n if Index < (FSize - 1) then\r\n MoveArray(FItems, Index + 1, Index, FSize - 1 - Index)\r\n else\r\n FItems[Index] := '';\r\n Dec(FSize);\r\n AutoPack;\r\n end\r\n else\r\n Result := RaiseOutOfBoundsError;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclAnsiStrVector.First: IJclAnsiStrIterator;\r\nbegin\r\n Result := TJclAnsiStrVectorIterator.Create(Self, 0, False, isFirst);\r\nend;\r\n\r\n{$IFDEF SUPPORTS_FOR_IN}\r\nfunction TJclAnsiStrVector.GetEnumerator: IJclAnsiStrIterator;\r\nbegin\r\n Result := TJclAnsiStrVectorIterator.Create(Self, 0, False, isFirst);\r\nend;\r\n{$ENDIF SUPPORTS_FOR_IN}\r\n\r\nfunction TJclAnsiStrVector.GetString(Index: Integer): AnsiString;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := '';\r\n if (Index >= 0) or (Index < FSize) then\r\n Result := FItems[Index]\r\n else\r\n if not FReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create(IntToStr(Index));\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclAnsiStrVector.IndexOf(const AString: AnsiString): Integer;\r\nvar\r\n I: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := -1;\r\n for I := 0 to FSize - 1 do\r\n if ItemsEqual(FItems[I], AString) then\r\n begin\r\n Result := I;\r\n Break;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclAnsiStrVector.Insert(Index: Integer; const AString: AnsiString): Boolean;\r\nvar\r\n I: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := FAllowDefaultElements or not ItemsEqual(AString, '');\r\n if (Index < 0) or (Index > FSize) then\r\n raise EJclOutOfBoundsError.Create;\r\n if Result then\r\n begin\r\n if FDuplicates <> dupAccept then\r\n for I := 0 to FSize - 1 do\r\n if ItemsEqual(AString, FItems[I]) then\r\n begin\r\n Result := CheckDuplicate;\r\n Break;\r\n end;\r\n if Result then\r\n begin\r\n if FSize = FCapacity then\r\n AutoGrow;\r\n Result := FSize < FCapacity;\r\n if Result then\r\n begin\r\n if Index < FSize then\r\n MoveArray(FItems, Index, Index + 1, FSize - Index);\r\n FItems[Index] := AString;\r\n Inc(FSize);\r\n end;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclAnsiStrVector.InsertAll(Index: Integer; const ACollection: IJclAnsiStrCollection): Boolean;\r\nvar\r\n It: IJclAnsiStrIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if (Index < 0) or (Index > FSize) then\r\n raise EJclOutOfBoundsError.Create;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := ACollection.Last;\r\n while It.HasPrevious do\r\n Result := Insert(Index, It.Previous) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclAnsiStrVector.IsEmpty: Boolean;\r\nbegin\r\n Result := FSize = 0;\r\nend;\r\n\r\nfunction TJclAnsiStrVector.Last: IJclAnsiStrIterator;\r\nbegin\r\n Result := TJclAnsiStrVectorIterator.Create(Self, FSize - 1, False, isLast);\r\nend;\r\n\r\nfunction TJclAnsiStrVector.LastIndexOf(const AString: AnsiString): Integer;\r\nvar\r\n I: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := -1;\r\n for I := FSize - 1 downto 0 do\r\n if ItemsEqual(FItems[I], AString) then\r\n begin\r\n Result := I;\r\n Break;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclAnsiStrVector.RaiseOutOfBoundsError: AnsiString;\r\nbegin\r\n raise EJclOutOfBoundsError.Create;\r\nend;\r\n\r\nfunction TJclAnsiStrVector.Remove(const AString: AnsiString): Boolean;\r\nvar\r\n Extracted: AnsiString;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := Extract(AString);\r\n if Result then\r\n begin\r\n Extracted := AString;\r\n FreeString(Extracted);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclAnsiStrVector.RemoveAll(const ACollection: IJclAnsiStrCollection): Boolean;\r\nvar\r\n It: IJclAnsiStrIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n Result := Remove(It.Next) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclAnsiStrVector.RetainAll(const ACollection: IJclAnsiStrCollection): Boolean;\r\nvar\r\n I: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n for I := FSize - 1 downto 0 do\r\n if not ACollection.Contains(FItems[I]) then\r\n Delete(I);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclAnsiStrVector.SetCapacity(Value: Integer);\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Value >= FSize then\r\n begin\r\n SetLength(FItems, Value);\r\n inherited SetCapacity(Value);\r\n end\r\n else\r\n raise EJclOutOfBoundsError.Create;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclAnsiStrVector.SetString(Index: Integer; const AString: AnsiString);\r\nvar\r\n ReplaceItem: Boolean;\r\n I: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if (Index < 0) or (Index >= FSize) then\r\n raise EJclOutOfBoundsError.Create;\r\n ReplaceItem := FAllowDefaultElements or not ItemsEqual(AString, '');\r\n if ReplaceItem then\r\n begin\r\n if FDuplicates <> dupAccept then\r\n for I := 0 to FSize - 1 do\r\n if ItemsEqual(AString, FItems[I]) then\r\n begin\r\n ReplaceItem := CheckDuplicate;\r\n Break;\r\n end;\r\n if ReplaceItem then\r\n begin\r\n FreeString(FItems[Index]);\r\n FItems[Index] := AString;\r\n end;\r\n end;\r\n if not ReplaceItem then\r\n Delete(Index);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclAnsiStrVector.Size: Integer;\r\nbegin\r\n Result := FSize;\r\nend;\r\n\r\nfunction TJclAnsiStrVector.SubList(First, Count: Integer): IJclAnsiStrList;\r\nvar\r\n I: Integer;\r\n Last: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Last := First + Count - 1;\r\n if Last >= FSize then\r\n Last := FSize - 1;\r\n Result := CreateEmptyContainer as IJclAnsiStrList;\r\n for I := First to Last do\r\n Result.Add(FItems[I]);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclAnsiStrVector.CreateEmptyContainer: TJclAbstractContainerBase;\r\nbegin\r\n Result := TJclAnsiStrVector.Create(FSize);\r\n AssignPropertiesTo(Result);\r\nend;\r\n\r\n//=== { TJclAnsiStrVectorIterator } ===========================================================\r\n\r\nconstructor TJclAnsiStrVectorIterator.Create(AOwnList: TJclAnsiStrVector; ACursor: Integer; AValid: Boolean; AStart: TItrStart);\r\nbegin\r\n inherited Create(AValid);\r\n FOwnList := AOwnList;\r\n FStart := AStart;\r\n FCursor := ACursor;\r\nend;\r\n\r\nfunction TJclAnsiStrVectorIterator.Add(const AString: AnsiString): Boolean;\r\nbegin\r\n Result := FOwnList.Add(AString);\r\nend;\r\n\r\nprocedure TJclAnsiStrVectorIterator.AssignPropertiesTo(Dest: TJclAbstractIterator);\r\nvar\r\n ADest: TJclAnsiStrVectorIterator;\r\nbegin\r\n inherited AssignPropertiesTo(Dest);\r\n if Dest is TJclAnsiStrVectorIterator then\r\n begin\r\n ADest := TJclAnsiStrVectorIterator(Dest);\r\n ADest.FOwnList := FOwnList;\r\n ADest.FCursor := FCursor;\r\n ADest.FStart := FStart;\r\n end;\r\nend;\r\n\r\nfunction TJclAnsiStrVectorIterator.CreateEmptyIterator: TJclAbstractIterator;\r\nbegin\r\n Result := TJclAnsiStrVectorIterator.Create(FOwnList, FCursor, Valid, FStart);\r\nend;\r\n\r\nprocedure TJclAnsiStrVectorIterator.Extract;\r\nbegin\r\n CheckValid;\r\n Valid := False;\r\n FOwnList.ExtractIndex(FCursor);\r\nend;\r\n\r\nfunction TJclAnsiStrVectorIterator.GetString: AnsiString;\r\nbegin\r\n CheckValid;\r\n Result := FOwnList.GetString(FCursor);\r\nend;\r\n\r\nfunction TJclAnsiStrVectorIterator.HasNext: Boolean;\r\nbegin\r\n if Valid then\r\n Result := FCursor < (FOwnList.Size - 1)\r\n else\r\n Result := FCursor < FOwnList.Size;\r\nend;\r\n\r\nfunction TJclAnsiStrVectorIterator.HasPrevious: Boolean;\r\nbegin\r\n if Valid then\r\n Result := FCursor > 0\r\n else\r\n Result := FCursor >= 0;\r\nend;\r\n\r\nfunction TJclAnsiStrVectorIterator.Insert(const AString: AnsiString): Boolean;\r\nbegin\r\n CheckValid;\r\n Result := FOwnList.Insert(FCursor, AString);\r\nend;\r\n\r\nfunction TJclAnsiStrVectorIterator.IteratorEquals(const AIterator: IJclAnsiStrIterator): Boolean;\r\nvar\r\n Obj: TObject;\r\n ItrObj: TJclAnsiStrVectorIterator;\r\nbegin\r\n Result := False;\r\n if AIterator = nil then\r\n Exit;\r\n Obj := AIterator.GetIteratorReference;\r\n if Obj is TJclAnsiStrVectorIterator then\r\n begin\r\n ItrObj := TJclAnsiStrVectorIterator(Obj);\r\n Result := (FOwnList = ItrObj.FOwnList) and (FCursor = ItrObj.FCursor) and (Valid = ItrObj.Valid);\r\n end;\r\nend;\r\n\r\n{$IFDEF SUPPORTS_FOR_IN}\r\nfunction TJclAnsiStrVectorIterator.MoveNext: Boolean;\r\nbegin\r\n if Valid then\r\n Inc(FCursor)\r\n else\r\n Valid := True;\r\n Result := FCursor < FOwnList.Size;\r\nend;\r\n{$ENDIF SUPPORTS_FOR_IN}\r\n\r\nfunction TJclAnsiStrVectorIterator.Next: AnsiString;\r\nbegin\r\n if Valid then\r\n Inc(FCursor)\r\n else\r\n Valid := True;\r\n Result := FOwnList.GetString(FCursor);\r\nend;\r\n\r\nfunction TJclAnsiStrVectorIterator.NextIndex: Integer;\r\nbegin\r\n if Valid then\r\n Result := FCursor + 1\r\n else\r\n Result := FCursor;\r\nend;\r\n\r\nfunction TJclAnsiStrVectorIterator.Previous: AnsiString;\r\nbegin\r\n if Valid then\r\n Dec(FCursor)\r\n else\r\n Valid := True;\r\n Result := FOwnList.GetString(FCursor);\r\nend;\r\n\r\nfunction TJclAnsiStrVectorIterator.PreviousIndex: Integer;\r\nbegin\r\n if Valid then\r\n Result := FCursor - 1\r\n else\r\n Result := FCursor;\r\nend;\r\n\r\nprocedure TJclAnsiStrVectorIterator.Remove;\r\nbegin\r\n CheckValid;\r\n Valid := False;\r\n FOwnList.Delete(FCursor);\r\nend;\r\n\r\nprocedure TJclAnsiStrVectorIterator.Reset;\r\nbegin\r\n Valid := False;\r\n case FStart of\r\n isFirst:\r\n FCursor := 0;\r\n isLast:\r\n FCursor := FOwnList.Size - 1;\r\n end;\r\nend;\r\n\r\nprocedure TJclAnsiStrVectorIterator.SetString(const AString: AnsiString);\r\nbegin\r\n CheckValid;\r\n FOwnList.SetString(FCursor, AString);\r\nend;\r\n\r\n//=== { TJclWideStrVector } ======================================================\r\n\r\nconstructor TJclWideStrVector.Create(ACapacity: Integer);\r\nbegin\r\n inherited Create();\r\n SetCapacity(ACapacity);\r\nend;\r\n\r\nconstructor TJclWideStrVector.Create(const ACollection: IJclWideStrCollection);\r\nbegin\r\n inherited Create();\r\n if ACollection = nil then\r\n raise EJclNoCollectionError.Create;\r\n SetCapacity(ACollection.Size);\r\n AddAll(ACollection);\r\nend;\r\n\r\ndestructor TJclWideStrVector.Destroy;\r\nbegin\r\n FReadOnly := False;\r\n Clear;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJclWideStrVector.Add(const AString: WideString): Boolean;\r\nvar\r\n Index: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := FAllowDefaultElements or not ItemsEqual(AString, '');\r\n if Result then\r\n begin\r\n if FDuplicates <> dupAccept then\r\n for Index := 0 to FSize - 1 do\r\n if ItemsEqual(AString, FItems[Index]) then\r\n begin\r\n Result := CheckDuplicate;\r\n Break;\r\n end;\r\n if Result then\r\n begin\r\n if FSize = FCapacity then\r\n AutoGrow;\r\n Result := FSize < FCapacity;\r\n if Result then\r\n begin\r\n FItems[FSize] := AString;\r\n Inc(FSize);\r\n end;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclWideStrVector.AddAll(const ACollection: IJclWideStrCollection): Boolean;\r\nvar\r\n It: IJclWideStrIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n Result := Add(It.Next) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclWideStrVector.AssignDataTo(Dest: TJclAbstractContainerBase);\r\nvar\r\n ADest: TJclWideStrVector;\r\n ACollection: IJclWideStrCollection;\r\nbegin\r\n inherited AssignDataTo(Dest);\r\n if Dest is TJclWideStrVector then\r\n begin\r\n ADest := TJclWideStrVector(Dest);\r\n ADest.Clear;\r\n ADest.AddAll(Self);\r\n end\r\n else\r\n if Supports(IInterface(Dest), IJclWideStrCollection, ACollection) then\r\n begin\r\n ACollection.Clear;\r\n ACollection.AddAll(Self);\r\n end;\r\nend;\r\n\r\nprocedure TJclWideStrVector.Clear;\r\nvar\r\n I: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n for I := 0 to FSize - 1 do\r\n FreeString(FItems[I]);\r\n FSize := 0;\r\n AutoPack;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclWideStrVector.CollectionEquals(const ACollection: IJclWideStrCollection): Boolean;\r\nvar\r\n I: Integer;\r\n It: IJclWideStrIterator;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n if FSize <> ACollection.Size then\r\n Exit;\r\n It := ACollection.First;\r\n for I := 0 to FSize - 1 do\r\n if not ItemsEqual(FItems[I], It.Next) then\r\n Exit;\r\n Result := True;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclWideStrVector.Contains(const AString: WideString): Boolean;\r\nvar\r\n I: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n for I := 0 to FSize - 1 do\r\n if ItemsEqual(FItems[I], AString) then\r\n begin\r\n Result := True;\r\n Break;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclWideStrVector.ContainsAll(const ACollection: IJclWideStrCollection): Boolean;\r\nvar\r\n It: IJclWideStrIterator;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := True;\r\n if ACollection = nil then\r\n Exit;\r\n It := ACollection.First;\r\n while Result and It.HasNext do\r\n Result := Contains(It.Next);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclWideStrVector.Delete(Index: Integer): WideString;\r\nvar\r\n Extracted: WideString;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Extracted := ExtractIndex(Index);\r\n Result := FreeString(Extracted);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclWideStrVector.Extract(const AString: WideString): Boolean;\r\nvar\r\n I: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n for I := FSize - 1 downto 0 do\r\n if ItemsEqual(FItems[I], AString) then\r\n begin\r\n if I < (FSize - 1) then\r\n MoveArray(FItems, I + 1, I, FSize - 1 - I)\r\n else\r\n FItems[I] := '';\r\n Dec(FSize);\r\n Result := True;\r\n if FRemoveSingleElement then\r\n Break;\r\n end;\r\n AutoPack;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclWideStrVector.ExtractAll(const ACollection: IJclWideStrCollection): Boolean;\r\nvar\r\n It: IJclWideStrIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n Result := Extract(It.Next) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclWideStrVector.ExtractIndex(Index: Integer): WideString;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if (Index >= 0) and (Index < FSize) then\r\n begin\r\n Result := FItems[Index];\r\n if Index < (FSize - 1) then\r\n MoveArray(FItems, Index + 1, Index, FSize - 1 - Index)\r\n else\r\n FItems[Index] := '';\r\n Dec(FSize);\r\n AutoPack;\r\n end\r\n else\r\n Result := RaiseOutOfBoundsError;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclWideStrVector.First: IJclWideStrIterator;\r\nbegin\r\n Result := TJclWideStrVectorIterator.Create(Self, 0, False, isFirst);\r\nend;\r\n\r\n{$IFDEF SUPPORTS_FOR_IN}\r\nfunction TJclWideStrVector.GetEnumerator: IJclWideStrIterator;\r\nbegin\r\n Result := TJclWideStrVectorIterator.Create(Self, 0, False, isFirst);\r\nend;\r\n{$ENDIF SUPPORTS_FOR_IN}\r\n\r\nfunction TJclWideStrVector.GetString(Index: Integer): WideString;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := '';\r\n if (Index >= 0) or (Index < FSize) then\r\n Result := FItems[Index]\r\n else\r\n if not FReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create(IntToStr(Index));\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclWideStrVector.IndexOf(const AString: WideString): Integer;\r\nvar\r\n I: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := -1;\r\n for I := 0 to FSize - 1 do\r\n if ItemsEqual(FItems[I], AString) then\r\n begin\r\n Result := I;\r\n Break;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclWideStrVector.Insert(Index: Integer; const AString: WideString): Boolean;\r\nvar\r\n I: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := FAllowDefaultElements or not ItemsEqual(AString, '');\r\n if (Index < 0) or (Index > FSize) then\r\n raise EJclOutOfBoundsError.Create;\r\n if Result then\r\n begin\r\n if FDuplicates <> dupAccept then\r\n for I := 0 to FSize - 1 do\r\n if ItemsEqual(AString, FItems[I]) then\r\n begin\r\n Result := CheckDuplicate;\r\n Break;\r\n end;\r\n if Result then\r\n begin\r\n if FSize = FCapacity then\r\n AutoGrow;\r\n Result := FSize < FCapacity;\r\n if Result then\r\n begin\r\n if Index < FSize then\r\n MoveArray(FItems, Index, Index + 1, FSize - Index);\r\n FItems[Index] := AString;\r\n Inc(FSize);\r\n end;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclWideStrVector.InsertAll(Index: Integer; const ACollection: IJclWideStrCollection): Boolean;\r\nvar\r\n It: IJclWideStrIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if (Index < 0) or (Index > FSize) then\r\n raise EJclOutOfBoundsError.Create;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := ACollection.Last;\r\n while It.HasPrevious do\r\n Result := Insert(Index, It.Previous) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclWideStrVector.IsEmpty: Boolean;\r\nbegin\r\n Result := FSize = 0;\r\nend;\r\n\r\nfunction TJclWideStrVector.Last: IJclWideStrIterator;\r\nbegin\r\n Result := TJclWideStrVectorIterator.Create(Self, FSize - 1, False, isLast);\r\nend;\r\n\r\nfunction TJclWideStrVector.LastIndexOf(const AString: WideString): Integer;\r\nvar\r\n I: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := -1;\r\n for I := FSize - 1 downto 0 do\r\n if ItemsEqual(FItems[I], AString) then\r\n begin\r\n Result := I;\r\n Break;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclWideStrVector.RaiseOutOfBoundsError: WideString;\r\nbegin\r\n raise EJclOutOfBoundsError.Create;\r\nend;\r\n\r\nfunction TJclWideStrVector.Remove(const AString: WideString): Boolean;\r\nvar\r\n Extracted: WideString;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := Extract(AString);\r\n if Result then\r\n begin\r\n Extracted := AString;\r\n FreeString(Extracted);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclWideStrVector.RemoveAll(const ACollection: IJclWideStrCollection): Boolean;\r\nvar\r\n It: IJclWideStrIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n Result := Remove(It.Next) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclWideStrVector.RetainAll(const ACollection: IJclWideStrCollection): Boolean;\r\nvar\r\n I: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n for I := FSize - 1 downto 0 do\r\n if not ACollection.Contains(FItems[I]) then\r\n Delete(I);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclWideStrVector.SetCapacity(Value: Integer);\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Value >= FSize then\r\n begin\r\n SetLength(FItems, Value);\r\n inherited SetCapacity(Value);\r\n end\r\n else\r\n raise EJclOutOfBoundsError.Create;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclWideStrVector.SetString(Index: Integer; const AString: WideString);\r\nvar\r\n ReplaceItem: Boolean;\r\n I: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if (Index < 0) or (Index >= FSize) then\r\n raise EJclOutOfBoundsError.Create;\r\n ReplaceItem := FAllowDefaultElements or not ItemsEqual(AString, '');\r\n if ReplaceItem then\r\n begin\r\n if FDuplicates <> dupAccept then\r\n for I := 0 to FSize - 1 do\r\n if ItemsEqual(AString, FItems[I]) then\r\n begin\r\n ReplaceItem := CheckDuplicate;\r\n Break;\r\n end;\r\n if ReplaceItem then\r\n begin\r\n FreeString(FItems[Index]);\r\n FItems[Index] := AString;\r\n end;\r\n end;\r\n if not ReplaceItem then\r\n Delete(Index);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclWideStrVector.Size: Integer;\r\nbegin\r\n Result := FSize;\r\nend;\r\n\r\nfunction TJclWideStrVector.SubList(First, Count: Integer): IJclWideStrList;\r\nvar\r\n I: Integer;\r\n Last: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Last := First + Count - 1;\r\n if Last >= FSize then\r\n Last := FSize - 1;\r\n Result := CreateEmptyContainer as IJclWideStrList;\r\n for I := First to Last do\r\n Result.Add(FItems[I]);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclWideStrVector.CreateEmptyContainer: TJclAbstractContainerBase;\r\nbegin\r\n Result := TJclWideStrVector.Create(FSize);\r\n AssignPropertiesTo(Result);\r\nend;\r\n\r\n//=== { TJclWideStrVectorIterator } ===========================================================\r\n\r\nconstructor TJclWideStrVectorIterator.Create(AOwnList: TJclWideStrVector; ACursor: Integer; AValid: Boolean; AStart: TItrStart);\r\nbegin\r\n inherited Create(AValid);\r\n FOwnList := AOwnList;\r\n FStart := AStart;\r\n FCursor := ACursor;\r\nend;\r\n\r\nfunction TJclWideStrVectorIterator.Add(const AString: WideString): Boolean;\r\nbegin\r\n Result := FOwnList.Add(AString);\r\nend;\r\n\r\nprocedure TJclWideStrVectorIterator.AssignPropertiesTo(Dest: TJclAbstractIterator);\r\nvar\r\n ADest: TJclWideStrVectorIterator;\r\nbegin\r\n inherited AssignPropertiesTo(Dest);\r\n if Dest is TJclWideStrVectorIterator then\r\n begin\r\n ADest := TJclWideStrVectorIterator(Dest);\r\n ADest.FOwnList := FOwnList;\r\n ADest.FCursor := FCursor;\r\n ADest.FStart := FStart;\r\n end;\r\nend;\r\n\r\nfunction TJclWideStrVectorIterator.CreateEmptyIterator: TJclAbstractIterator;\r\nbegin\r\n Result := TJclWideStrVectorIterator.Create(FOwnList, FCursor, Valid, FStart);\r\nend;\r\n\r\nprocedure TJclWideStrVectorIterator.Extract;\r\nbegin\r\n CheckValid;\r\n Valid := False;\r\n FOwnList.ExtractIndex(FCursor);\r\nend;\r\n\r\nfunction TJclWideStrVectorIterator.GetString: WideString;\r\nbegin\r\n CheckValid;\r\n Result := FOwnList.GetString(FCursor);\r\nend;\r\n\r\nfunction TJclWideStrVectorIterator.HasNext: Boolean;\r\nbegin\r\n if Valid then\r\n Result := FCursor < (FOwnList.Size - 1)\r\n else\r\n Result := FCursor < FOwnList.Size;\r\nend;\r\n\r\nfunction TJclWideStrVectorIterator.HasPrevious: Boolean;\r\nbegin\r\n if Valid then\r\n Result := FCursor > 0\r\n else\r\n Result := FCursor >= 0;\r\nend;\r\n\r\nfunction TJclWideStrVectorIterator.Insert(const AString: WideString): Boolean;\r\nbegin\r\n CheckValid;\r\n Result := FOwnList.Insert(FCursor, AString);\r\nend;\r\n\r\nfunction TJclWideStrVectorIterator.IteratorEquals(const AIterator: IJclWideStrIterator): Boolean;\r\nvar\r\n Obj: TObject;\r\n ItrObj: TJclWideStrVectorIterator;\r\nbegin\r\n Result := False;\r\n if AIterator = nil then\r\n Exit;\r\n Obj := AIterator.GetIteratorReference;\r\n if Obj is TJclWideStrVectorIterator then\r\n begin\r\n ItrObj := TJclWideStrVectorIterator(Obj);\r\n Result := (FOwnList = ItrObj.FOwnList) and (FCursor = ItrObj.FCursor) and (Valid = ItrObj.Valid);\r\n end;\r\nend;\r\n\r\n{$IFDEF SUPPORTS_FOR_IN}\r\nfunction TJclWideStrVectorIterator.MoveNext: Boolean;\r\nbegin\r\n if Valid then\r\n Inc(FCursor)\r\n else\r\n Valid := True;\r\n Result := FCursor < FOwnList.Size;\r\nend;\r\n{$ENDIF SUPPORTS_FOR_IN}\r\n\r\nfunction TJclWideStrVectorIterator.Next: WideString;\r\nbegin\r\n if Valid then\r\n Inc(FCursor)\r\n else\r\n Valid := True;\r\n Result := FOwnList.GetString(FCursor);\r\nend;\r\n\r\nfunction TJclWideStrVectorIterator.NextIndex: Integer;\r\nbegin\r\n if Valid then\r\n Result := FCursor + 1\r\n else\r\n Result := FCursor;\r\nend;\r\n\r\nfunction TJclWideStrVectorIterator.Previous: WideString;\r\nbegin\r\n if Valid then\r\n Dec(FCursor)\r\n else\r\n Valid := True;\r\n Result := FOwnList.GetString(FCursor);\r\nend;\r\n\r\nfunction TJclWideStrVectorIterator.PreviousIndex: Integer;\r\nbegin\r\n if Valid then\r\n Result := FCursor - 1\r\n else\r\n Result := FCursor;\r\nend;\r\n\r\nprocedure TJclWideStrVectorIterator.Remove;\r\nbegin\r\n CheckValid;\r\n Valid := False;\r\n FOwnList.Delete(FCursor);\r\nend;\r\n\r\nprocedure TJclWideStrVectorIterator.Reset;\r\nbegin\r\n Valid := False;\r\n case FStart of\r\n isFirst:\r\n FCursor := 0;\r\n isLast:\r\n FCursor := FOwnList.Size - 1;\r\n end;\r\nend;\r\n\r\nprocedure TJclWideStrVectorIterator.SetString(const AString: WideString);\r\nbegin\r\n CheckValid;\r\n FOwnList.SetString(FCursor, AString);\r\nend;\r\n\r\n{$IFDEF SUPPORTS_UNICODE_STRING}\r\n//=== { TJclUnicodeStrVector } ======================================================\r\n\r\nconstructor TJclUnicodeStrVector.Create(ACapacity: Integer);\r\nbegin\r\n inherited Create();\r\n SetCapacity(ACapacity);\r\nend;\r\n\r\nconstructor TJclUnicodeStrVector.Create(const ACollection: IJclUnicodeStrCollection);\r\nbegin\r\n inherited Create();\r\n if ACollection = nil then\r\n raise EJclNoCollectionError.Create;\r\n SetCapacity(ACollection.Size);\r\n AddAll(ACollection);\r\nend;\r\n\r\ndestructor TJclUnicodeStrVector.Destroy;\r\nbegin\r\n FReadOnly := False;\r\n Clear;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJclUnicodeStrVector.Add(const AString: UnicodeString): Boolean;\r\nvar\r\n Index: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := FAllowDefaultElements or not ItemsEqual(AString, '');\r\n if Result then\r\n begin\r\n if FDuplicates <> dupAccept then\r\n for Index := 0 to FSize - 1 do\r\n if ItemsEqual(AString, FItems[Index]) then\r\n begin\r\n Result := CheckDuplicate;\r\n Break;\r\n end;\r\n if Result then\r\n begin\r\n if FSize = FCapacity then\r\n AutoGrow;\r\n Result := FSize < FCapacity;\r\n if Result then\r\n begin\r\n FItems[FSize] := AString;\r\n Inc(FSize);\r\n end;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclUnicodeStrVector.AddAll(const ACollection: IJclUnicodeStrCollection): Boolean;\r\nvar\r\n It: IJclUnicodeStrIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n Result := Add(It.Next) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclUnicodeStrVector.AssignDataTo(Dest: TJclAbstractContainerBase);\r\nvar\r\n ADest: TJclUnicodeStrVector;\r\n ACollection: IJclUnicodeStrCollection;\r\nbegin\r\n inherited AssignDataTo(Dest);\r\n if Dest is TJclUnicodeStrVector then\r\n begin\r\n ADest := TJclUnicodeStrVector(Dest);\r\n ADest.Clear;\r\n ADest.AddAll(Self);\r\n end\r\n else\r\n if Supports(IInterface(Dest), IJclUnicodeStrCollection, ACollection) then\r\n begin\r\n ACollection.Clear;\r\n ACollection.AddAll(Self);\r\n end;\r\nend;\r\n\r\nprocedure TJclUnicodeStrVector.Clear;\r\nvar\r\n I: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n for I := 0 to FSize - 1 do\r\n FreeString(FItems[I]);\r\n FSize := 0;\r\n AutoPack;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclUnicodeStrVector.CollectionEquals(const ACollection: IJclUnicodeStrCollection): Boolean;\r\nvar\r\n I: Integer;\r\n It: IJclUnicodeStrIterator;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n if FSize <> ACollection.Size then\r\n Exit;\r\n It := ACollection.First;\r\n for I := 0 to FSize - 1 do\r\n if not ItemsEqual(FItems[I], It.Next) then\r\n Exit;\r\n Result := True;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclUnicodeStrVector.Contains(const AString: UnicodeString): Boolean;\r\nvar\r\n I: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n for I := 0 to FSize - 1 do\r\n if ItemsEqual(FItems[I], AString) then\r\n begin\r\n Result := True;\r\n Break;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclUnicodeStrVector.ContainsAll(const ACollection: IJclUnicodeStrCollection): Boolean;\r\nvar\r\n It: IJclUnicodeStrIterator;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := True;\r\n if ACollection = nil then\r\n Exit;\r\n It := ACollection.First;\r\n while Result and It.HasNext do\r\n Result := Contains(It.Next);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclUnicodeStrVector.Delete(Index: Integer): UnicodeString;\r\nvar\r\n Extracted: UnicodeString;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Extracted := ExtractIndex(Index);\r\n Result := FreeString(Extracted);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclUnicodeStrVector.Extract(const AString: UnicodeString): Boolean;\r\nvar\r\n I: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n for I := FSize - 1 downto 0 do\r\n if ItemsEqual(FItems[I], AString) then\r\n begin\r\n if I < (FSize - 1) then\r\n MoveArray(FItems, I + 1, I, FSize - 1 - I)\r\n else\r\n FItems[I] := '';\r\n Dec(FSize);\r\n Result := True;\r\n if FRemoveSingleElement then\r\n Break;\r\n end;\r\n AutoPack;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclUnicodeStrVector.ExtractAll(const ACollection: IJclUnicodeStrCollection): Boolean;\r\nvar\r\n It: IJclUnicodeStrIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n Result := Extract(It.Next) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclUnicodeStrVector.ExtractIndex(Index: Integer): UnicodeString;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if (Index >= 0) and (Index < FSize) then\r\n begin\r\n Result := FItems[Index];\r\n if Index < (FSize - 1) then\r\n MoveArray(FItems, Index + 1, Index, FSize - 1 - Index)\r\n else\r\n FItems[Index] := '';\r\n Dec(FSize);\r\n AutoPack;\r\n end\r\n else\r\n Result := RaiseOutOfBoundsError;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclUnicodeStrVector.First: IJclUnicodeStrIterator;\r\nbegin\r\n Result := TJclUnicodeStrVectorIterator.Create(Self, 0, False, isFirst);\r\nend;\r\n\r\n{$IFDEF SUPPORTS_FOR_IN}\r\nfunction TJclUnicodeStrVector.GetEnumerator: IJclUnicodeStrIterator;\r\nbegin\r\n Result := TJclUnicodeStrVectorIterator.Create(Self, 0, False, isFirst);\r\nend;\r\n{$ENDIF SUPPORTS_FOR_IN}\r\n\r\nfunction TJclUnicodeStrVector.GetString(Index: Integer): UnicodeString;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := '';\r\n if (Index >= 0) or (Index < FSize) then\r\n Result := FItems[Index]\r\n else\r\n if not FReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create(IntToStr(Index));\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclUnicodeStrVector.IndexOf(const AString: UnicodeString): Integer;\r\nvar\r\n I: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := -1;\r\n for I := 0 to FSize - 1 do\r\n if ItemsEqual(FItems[I], AString) then\r\n begin\r\n Result := I;\r\n Break;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclUnicodeStrVector.Insert(Index: Integer; const AString: UnicodeString): Boolean;\r\nvar\r\n I: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := FAllowDefaultElements or not ItemsEqual(AString, '');\r\n if (Index < 0) or (Index > FSize) then\r\n raise EJclOutOfBoundsError.Create;\r\n if Result then\r\n begin\r\n if FDuplicates <> dupAccept then\r\n for I := 0 to FSize - 1 do\r\n if ItemsEqual(AString, FItems[I]) then\r\n begin\r\n Result := CheckDuplicate;\r\n Break;\r\n end;\r\n if Result then\r\n begin\r\n if FSize = FCapacity then\r\n AutoGrow;\r\n Result := FSize < FCapacity;\r\n if Result then\r\n begin\r\n if Index < FSize then\r\n MoveArray(FItems, Index, Index + 1, FSize - Index);\r\n FItems[Index] := AString;\r\n Inc(FSize);\r\n end;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclUnicodeStrVector.InsertAll(Index: Integer; const ACollection: IJclUnicodeStrCollection): Boolean;\r\nvar\r\n It: IJclUnicodeStrIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if (Index < 0) or (Index > FSize) then\r\n raise EJclOutOfBoundsError.Create;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := ACollection.Last;\r\n while It.HasPrevious do\r\n Result := Insert(Index, It.Previous) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclUnicodeStrVector.IsEmpty: Boolean;\r\nbegin\r\n Result := FSize = 0;\r\nend;\r\n\r\nfunction TJclUnicodeStrVector.Last: IJclUnicodeStrIterator;\r\nbegin\r\n Result := TJclUnicodeStrVectorIterator.Create(Self, FSize - 1, False, isLast);\r\nend;\r\n\r\nfunction TJclUnicodeStrVector.LastIndexOf(const AString: UnicodeString): Integer;\r\nvar\r\n I: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := -1;\r\n for I := FSize - 1 downto 0 do\r\n if ItemsEqual(FItems[I], AString) then\r\n begin\r\n Result := I;\r\n Break;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclUnicodeStrVector.RaiseOutOfBoundsError: UnicodeString;\r\nbegin\r\n raise EJclOutOfBoundsError.Create;\r\nend;\r\n\r\nfunction TJclUnicodeStrVector.Remove(const AString: UnicodeString): Boolean;\r\nvar\r\n Extracted: UnicodeString;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := Extract(AString);\r\n if Result then\r\n begin\r\n Extracted := AString;\r\n FreeString(Extracted);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclUnicodeStrVector.RemoveAll(const ACollection: IJclUnicodeStrCollection): Boolean;\r\nvar\r\n It: IJclUnicodeStrIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n Result := Remove(It.Next) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclUnicodeStrVector.RetainAll(const ACollection: IJclUnicodeStrCollection): Boolean;\r\nvar\r\n I: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n for I := FSize - 1 downto 0 do\r\n if not ACollection.Contains(FItems[I]) then\r\n Delete(I);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclUnicodeStrVector.SetCapacity(Value: Integer);\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Value >= FSize then\r\n begin\r\n SetLength(FItems, Value);\r\n inherited SetCapacity(Value);\r\n end\r\n else\r\n raise EJclOutOfBoundsError.Create;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclUnicodeStrVector.SetString(Index: Integer; const AString: UnicodeString);\r\nvar\r\n ReplaceItem: Boolean;\r\n I: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if (Index < 0) or (Index >= FSize) then\r\n raise EJclOutOfBoundsError.Create;\r\n ReplaceItem := FAllowDefaultElements or not ItemsEqual(AString, '');\r\n if ReplaceItem then\r\n begin\r\n if FDuplicates <> dupAccept then\r\n for I := 0 to FSize - 1 do\r\n if ItemsEqual(AString, FItems[I]) then\r\n begin\r\n ReplaceItem := CheckDuplicate;\r\n Break;\r\n end;\r\n if ReplaceItem then\r\n begin\r\n FreeString(FItems[Index]);\r\n FItems[Index] := AString;\r\n end;\r\n end;\r\n if not ReplaceItem then\r\n Delete(Index);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclUnicodeStrVector.Size: Integer;\r\nbegin\r\n Result := FSize;\r\nend;\r\n\r\nfunction TJclUnicodeStrVector.SubList(First, Count: Integer): IJclUnicodeStrList;\r\nvar\r\n I: Integer;\r\n Last: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Last := First + Count - 1;\r\n if Last >= FSize then\r\n Last := FSize - 1;\r\n Result := CreateEmptyContainer as IJclUnicodeStrList;\r\n for I := First to Last do\r\n Result.Add(FItems[I]);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclUnicodeStrVector.CreateEmptyContainer: TJclAbstractContainerBase;\r\nbegin\r\n Result := TJclUnicodeStrVector.Create(FSize);\r\n AssignPropertiesTo(Result);\r\nend;\r\n\r\n{$ENDIF SUPPORTS_UNICODE_STRING}\r\n\r\n{$IFDEF SUPPORTS_UNICODE_STRING}\r\n//=== { TJclUnicodeStrVectorIterator } ===========================================================\r\n\r\nconstructor TJclUnicodeStrVectorIterator.Create(AOwnList: TJclUnicodeStrVector; ACursor: Integer; AValid: Boolean; AStart: TItrStart);\r\nbegin\r\n inherited Create(AValid);\r\n FOwnList := AOwnList;\r\n FStart := AStart;\r\n FCursor := ACursor;\r\nend;\r\n\r\nfunction TJclUnicodeStrVectorIterator.Add(const AString: UnicodeString): Boolean;\r\nbegin\r\n Result := FOwnList.Add(AString);\r\nend;\r\n\r\nprocedure TJclUnicodeStrVectorIterator.AssignPropertiesTo(Dest: TJclAbstractIterator);\r\nvar\r\n ADest: TJclUnicodeStrVectorIterator;\r\nbegin\r\n inherited AssignPropertiesTo(Dest);\r\n if Dest is TJclUnicodeStrVectorIterator then\r\n begin\r\n ADest := TJclUnicodeStrVectorIterator(Dest);\r\n ADest.FOwnList := FOwnList;\r\n ADest.FCursor := FCursor;\r\n ADest.FStart := FStart;\r\n end;\r\nend;\r\n\r\nfunction TJclUnicodeStrVectorIterator.CreateEmptyIterator: TJclAbstractIterator;\r\nbegin\r\n Result := TJclUnicodeStrVectorIterator.Create(FOwnList, FCursor, Valid, FStart);\r\nend;\r\n\r\nprocedure TJclUnicodeStrVectorIterator.Extract;\r\nbegin\r\n CheckValid;\r\n Valid := False;\r\n FOwnList.ExtractIndex(FCursor);\r\nend;\r\n\r\nfunction TJclUnicodeStrVectorIterator.GetString: UnicodeString;\r\nbegin\r\n CheckValid;\r\n Result := FOwnList.GetString(FCursor);\r\nend;\r\n\r\nfunction TJclUnicodeStrVectorIterator.HasNext: Boolean;\r\nbegin\r\n if Valid then\r\n Result := FCursor < (FOwnList.Size - 1)\r\n else\r\n Result := FCursor < FOwnList.Size;\r\nend;\r\n\r\nfunction TJclUnicodeStrVectorIterator.HasPrevious: Boolean;\r\nbegin\r\n if Valid then\r\n Result := FCursor > 0\r\n else\r\n Result := FCursor >= 0;\r\nend;\r\n\r\nfunction TJclUnicodeStrVectorIterator.Insert(const AString: UnicodeString): Boolean;\r\nbegin\r\n CheckValid;\r\n Result := FOwnList.Insert(FCursor, AString);\r\nend;\r\n\r\nfunction TJclUnicodeStrVectorIterator.IteratorEquals(const AIterator: IJclUnicodeStrIterator): Boolean;\r\nvar\r\n Obj: TObject;\r\n ItrObj: TJclUnicodeStrVectorIterator;\r\nbegin\r\n Result := False;\r\n if AIterator = nil then\r\n Exit;\r\n Obj := AIterator.GetIteratorReference;\r\n if Obj is TJclUnicodeStrVectorIterator then\r\n begin\r\n ItrObj := TJclUnicodeStrVectorIterator(Obj);\r\n Result := (FOwnList = ItrObj.FOwnList) and (FCursor = ItrObj.FCursor) and (Valid = ItrObj.Valid);\r\n end;\r\nend;\r\n\r\n{$IFDEF SUPPORTS_FOR_IN}\r\nfunction TJclUnicodeStrVectorIterator.MoveNext: Boolean;\r\nbegin\r\n if Valid then\r\n Inc(FCursor)\r\n else\r\n Valid := True;\r\n Result := FCursor < FOwnList.Size;\r\nend;\r\n{$ENDIF SUPPORTS_FOR_IN}\r\n\r\nfunction TJclUnicodeStrVectorIterator.Next: UnicodeString;\r\nbegin\r\n if Valid then\r\n Inc(FCursor)\r\n else\r\n Valid := True;\r\n Result := FOwnList.GetString(FCursor);\r\nend;\r\n\r\nfunction TJclUnicodeStrVectorIterator.NextIndex: Integer;\r\nbegin\r\n if Valid then\r\n Result := FCursor + 1\r\n else\r\n Result := FCursor;\r\nend;\r\n\r\nfunction TJclUnicodeStrVectorIterator.Previous: UnicodeString;\r\nbegin\r\n if Valid then\r\n Dec(FCursor)\r\n else\r\n Valid := True;\r\n Result := FOwnList.GetString(FCursor);\r\nend;\r\n\r\nfunction TJclUnicodeStrVectorIterator.PreviousIndex: Integer;\r\nbegin\r\n if Valid then\r\n Result := FCursor - 1\r\n else\r\n Result := FCursor;\r\nend;\r\n\r\nprocedure TJclUnicodeStrVectorIterator.Remove;\r\nbegin\r\n CheckValid;\r\n Valid := False;\r\n FOwnList.Delete(FCursor);\r\nend;\r\n\r\nprocedure TJclUnicodeStrVectorIterator.Reset;\r\nbegin\r\n Valid := False;\r\n case FStart of\r\n isFirst:\r\n FCursor := 0;\r\n isLast:\r\n FCursor := FOwnList.Size - 1;\r\n end;\r\nend;\r\n\r\nprocedure TJclUnicodeStrVectorIterator.SetString(const AString: UnicodeString);\r\nbegin\r\n CheckValid;\r\n FOwnList.SetString(FCursor, AString);\r\nend;\r\n{$ENDIF SUPPORTS_UNICODE_STRING}\r\n\r\n//=== { TJclSingleVector } ======================================================\r\n\r\nconstructor TJclSingleVector.Create(ACapacity: Integer);\r\nbegin\r\n inherited Create();\r\n SetCapacity(ACapacity);\r\nend;\r\n\r\nconstructor TJclSingleVector.Create(const ACollection: IJclSingleCollection);\r\nbegin\r\n inherited Create();\r\n if ACollection = nil then\r\n raise EJclNoCollectionError.Create;\r\n SetCapacity(ACollection.Size);\r\n AddAll(ACollection);\r\nend;\r\n\r\ndestructor TJclSingleVector.Destroy;\r\nbegin\r\n FReadOnly := False;\r\n Clear;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJclSingleVector.Add(const AValue: Single): Boolean;\r\nvar\r\n Index: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := FAllowDefaultElements or not ItemsEqual(AValue, 0.0);\r\n if Result then\r\n begin\r\n if FDuplicates <> dupAccept then\r\n for Index := 0 to FSize - 1 do\r\n if ItemsEqual(AValue, FItems[Index]) then\r\n begin\r\n Result := CheckDuplicate;\r\n Break;\r\n end;\r\n if Result then\r\n begin\r\n if FSize = FCapacity then\r\n AutoGrow;\r\n Result := FSize < FCapacity;\r\n if Result then\r\n begin\r\n FItems[FSize] := AValue;\r\n Inc(FSize);\r\n end;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSingleVector.AddAll(const ACollection: IJclSingleCollection): Boolean;\r\nvar\r\n It: IJclSingleIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n Result := Add(It.Next) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclSingleVector.AssignDataTo(Dest: TJclAbstractContainerBase);\r\nvar\r\n ADest: TJclSingleVector;\r\n ACollection: IJclSingleCollection;\r\nbegin\r\n inherited AssignDataTo(Dest);\r\n if Dest is TJclSingleVector then\r\n begin\r\n ADest := TJclSingleVector(Dest);\r\n ADest.Clear;\r\n ADest.AddAll(Self);\r\n end\r\n else\r\n if Supports(IInterface(Dest), IJclSingleCollection, ACollection) then\r\n begin\r\n ACollection.Clear;\r\n ACollection.AddAll(Self);\r\n end;\r\nend;\r\n\r\nprocedure TJclSingleVector.Clear;\r\nvar\r\n I: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n for I := 0 to FSize - 1 do\r\n FreeSingle(FItems[I]);\r\n FSize := 0;\r\n AutoPack;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSingleVector.CollectionEquals(const ACollection: IJclSingleCollection): Boolean;\r\nvar\r\n I: Integer;\r\n It: IJclSingleIterator;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n if FSize <> ACollection.Size then\r\n Exit;\r\n It := ACollection.First;\r\n for I := 0 to FSize - 1 do\r\n if not ItemsEqual(FItems[I], It.Next) then\r\n Exit;\r\n Result := True;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSingleVector.Contains(const AValue: Single): Boolean;\r\nvar\r\n I: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n for I := 0 to FSize - 1 do\r\n if ItemsEqual(FItems[I], AValue) then\r\n begin\r\n Result := True;\r\n Break;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSingleVector.ContainsAll(const ACollection: IJclSingleCollection): Boolean;\r\nvar\r\n It: IJclSingleIterator;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := True;\r\n if ACollection = nil then\r\n Exit;\r\n It := ACollection.First;\r\n while Result and It.HasNext do\r\n Result := Contains(It.Next);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSingleVector.Delete(Index: Integer): Single;\r\nvar\r\n Extracted: Single;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Extracted := ExtractIndex(Index);\r\n Result := FreeSingle(Extracted);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSingleVector.Extract(const AValue: Single): Boolean;\r\nvar\r\n I: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n for I := FSize - 1 downto 0 do\r\n if ItemsEqual(FItems[I], AValue) then\r\n begin\r\n if I < (FSize - 1) then\r\n MoveArray(FItems, I + 1, I, FSize - 1 - I)\r\n else\r\n FItems[I] := 0.0;\r\n Dec(FSize);\r\n Result := True;\r\n if FRemoveSingleElement then\r\n Break;\r\n end;\r\n AutoPack;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSingleVector.ExtractAll(const ACollection: IJclSingleCollection): Boolean;\r\nvar\r\n It: IJclSingleIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n Result := Extract(It.Next) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSingleVector.ExtractIndex(Index: Integer): Single;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if (Index >= 0) and (Index < FSize) then\r\n begin\r\n Result := FItems[Index];\r\n if Index < (FSize - 1) then\r\n MoveArray(FItems, Index + 1, Index, FSize - 1 - Index)\r\n else\r\n FItems[Index] := 0.0;\r\n Dec(FSize);\r\n AutoPack;\r\n end\r\n else\r\n Result := RaiseOutOfBoundsError;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSingleVector.First: IJclSingleIterator;\r\nbegin\r\n Result := TJclSingleVectorIterator.Create(Self, 0, False, isFirst);\r\nend;\r\n\r\n{$IFDEF SUPPORTS_FOR_IN}\r\nfunction TJclSingleVector.GetEnumerator: IJclSingleIterator;\r\nbegin\r\n Result := TJclSingleVectorIterator.Create(Self, 0, False, isFirst);\r\nend;\r\n{$ENDIF SUPPORTS_FOR_IN}\r\n\r\nfunction TJclSingleVector.GetValue(Index: Integer): Single;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := 0.0;\r\n if (Index >= 0) or (Index < FSize) then\r\n Result := FItems[Index]\r\n else\r\n if not FReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create(IntToStr(Index));\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSingleVector.IndexOf(const AValue: Single): Integer;\r\nvar\r\n I: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := -1;\r\n for I := 0 to FSize - 1 do\r\n if ItemsEqual(FItems[I], AValue) then\r\n begin\r\n Result := I;\r\n Break;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSingleVector.Insert(Index: Integer; const AValue: Single): Boolean;\r\nvar\r\n I: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := FAllowDefaultElements or not ItemsEqual(AValue, 0.0);\r\n if (Index < 0) or (Index > FSize) then\r\n raise EJclOutOfBoundsError.Create;\r\n if Result then\r\n begin\r\n if FDuplicates <> dupAccept then\r\n for I := 0 to FSize - 1 do\r\n if ItemsEqual(AValue, FItems[I]) then\r\n begin\r\n Result := CheckDuplicate;\r\n Break;\r\n end;\r\n if Result then\r\n begin\r\n if FSize = FCapacity then\r\n AutoGrow;\r\n Result := FSize < FCapacity;\r\n if Result then\r\n begin\r\n if Index < FSize then\r\n MoveArray(FItems, Index, Index + 1, FSize - Index);\r\n FItems[Index] := AValue;\r\n Inc(FSize);\r\n end;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSingleVector.InsertAll(Index: Integer; const ACollection: IJclSingleCollection): Boolean;\r\nvar\r\n It: IJclSingleIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if (Index < 0) or (Index > FSize) then\r\n raise EJclOutOfBoundsError.Create;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := ACollection.Last;\r\n while It.HasPrevious do\r\n Result := Insert(Index, It.Previous) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSingleVector.IsEmpty: Boolean;\r\nbegin\r\n Result := FSize = 0;\r\nend;\r\n\r\nfunction TJclSingleVector.Last: IJclSingleIterator;\r\nbegin\r\n Result := TJclSingleVectorIterator.Create(Self, FSize - 1, False, isLast);\r\nend;\r\n\r\nfunction TJclSingleVector.LastIndexOf(const AValue: Single): Integer;\r\nvar\r\n I: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := -1;\r\n for I := FSize - 1 downto 0 do\r\n if ItemsEqual(FItems[I], AValue) then\r\n begin\r\n Result := I;\r\n Break;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSingleVector.RaiseOutOfBoundsError: Single;\r\nbegin\r\n raise EJclOutOfBoundsError.Create;\r\nend;\r\n\r\nfunction TJclSingleVector.Remove(const AValue: Single): Boolean;\r\nvar\r\n Extracted: Single;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := Extract(AValue);\r\n if Result then\r\n begin\r\n Extracted := AValue;\r\n FreeSingle(Extracted);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSingleVector.RemoveAll(const ACollection: IJclSingleCollection): Boolean;\r\nvar\r\n It: IJclSingleIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n Result := Remove(It.Next) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSingleVector.RetainAll(const ACollection: IJclSingleCollection): Boolean;\r\nvar\r\n I: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n for I := FSize - 1 downto 0 do\r\n if not ACollection.Contains(FItems[I]) then\r\n Delete(I);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclSingleVector.SetCapacity(Value: Integer);\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Value >= FSize then\r\n begin\r\n SetLength(FItems, Value);\r\n inherited SetCapacity(Value);\r\n end\r\n else\r\n raise EJclOutOfBoundsError.Create;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclSingleVector.SetValue(Index: Integer; const AValue: Single);\r\nvar\r\n ReplaceItem: Boolean;\r\n I: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if (Index < 0) or (Index >= FSize) then\r\n raise EJclOutOfBoundsError.Create;\r\n ReplaceItem := FAllowDefaultElements or not ItemsEqual(AValue, 0.0);\r\n if ReplaceItem then\r\n begin\r\n if FDuplicates <> dupAccept then\r\n for I := 0 to FSize - 1 do\r\n if ItemsEqual(AValue, FItems[I]) then\r\n begin\r\n ReplaceItem := CheckDuplicate;\r\n Break;\r\n end;\r\n if ReplaceItem then\r\n begin\r\n FreeSingle(FItems[Index]);\r\n FItems[Index] := AValue;\r\n end;\r\n end;\r\n if not ReplaceItem then\r\n Delete(Index);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSingleVector.Size: Integer;\r\nbegin\r\n Result := FSize;\r\nend;\r\n\r\nfunction TJclSingleVector.SubList(First, Count: Integer): IJclSingleList;\r\nvar\r\n I: Integer;\r\n Last: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Last := First + Count - 1;\r\n if Last >= FSize then\r\n Last := FSize - 1;\r\n Result := CreateEmptyContainer as IJclSingleList;\r\n for I := First to Last do\r\n Result.Add(FItems[I]);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclSingleVector.CreateEmptyContainer: TJclAbstractContainerBase;\r\nbegin\r\n Result := TJclSingleVector.Create(FSize);\r\n AssignPropertiesTo(Result);\r\nend;\r\n\r\n//=== { TJclSingleVectorIterator } ===========================================================\r\n\r\nconstructor TJclSingleVectorIterator.Create(AOwnList: TJclSingleVector; ACursor: Integer; AValid: Boolean; AStart: TItrStart);\r\nbegin\r\n inherited Create(AValid);\r\n FOwnList := AOwnList;\r\n FStart := AStart;\r\n FCursor := ACursor;\r\nend;\r\n\r\nfunction TJclSingleVectorIterator.Add(const AValue: Single): Boolean;\r\nbegin\r\n Result := FOwnList.Add(AValue);\r\nend;\r\n\r\nprocedure TJclSingleVectorIterator.AssignPropertiesTo(Dest: TJclAbstractIterator);\r\nvar\r\n ADest: TJclSingleVectorIterator;\r\nbegin\r\n inherited AssignPropertiesTo(Dest);\r\n if Dest is TJclSingleVectorIterator then\r\n begin\r\n ADest := TJclSingleVectorIterator(Dest);\r\n ADest.FOwnList := FOwnList;\r\n ADest.FCursor := FCursor;\r\n ADest.FStart := FStart;\r\n end;\r\nend;\r\n\r\nfunction TJclSingleVectorIterator.CreateEmptyIterator: TJclAbstractIterator;\r\nbegin\r\n Result := TJclSingleVectorIterator.Create(FOwnList, FCursor, Valid, FStart);\r\nend;\r\n\r\nprocedure TJclSingleVectorIterator.Extract;\r\nbegin\r\n CheckValid;\r\n Valid := False;\r\n FOwnList.ExtractIndex(FCursor);\r\nend;\r\n\r\nfunction TJclSingleVectorIterator.GetValue: Single;\r\nbegin\r\n CheckValid;\r\n Result := FOwnList.GetValue(FCursor);\r\nend;\r\n\r\nfunction TJclSingleVectorIterator.HasNext: Boolean;\r\nbegin\r\n if Valid then\r\n Result := FCursor < (FOwnList.Size - 1)\r\n else\r\n Result := FCursor < FOwnList.Size;\r\nend;\r\n\r\nfunction TJclSingleVectorIterator.HasPrevious: Boolean;\r\nbegin\r\n if Valid then\r\n Result := FCursor > 0\r\n else\r\n Result := FCursor >= 0;\r\nend;\r\n\r\nfunction TJclSingleVectorIterator.Insert(const AValue: Single): Boolean;\r\nbegin\r\n CheckValid;\r\n Result := FOwnList.Insert(FCursor, AValue);\r\nend;\r\n\r\nfunction TJclSingleVectorIterator.IteratorEquals(const AIterator: IJclSingleIterator): Boolean;\r\nvar\r\n Obj: TObject;\r\n ItrObj: TJclSingleVectorIterator;\r\nbegin\r\n Result := False;\r\n if AIterator = nil then\r\n Exit;\r\n Obj := AIterator.GetIteratorReference;\r\n if Obj is TJclSingleVectorIterator then\r\n begin\r\n ItrObj := TJclSingleVectorIterator(Obj);\r\n Result := (FOwnList = ItrObj.FOwnList) and (FCursor = ItrObj.FCursor) and (Valid = ItrObj.Valid);\r\n end;\r\nend;\r\n\r\n{$IFDEF SUPPORTS_FOR_IN}\r\nfunction TJclSingleVectorIterator.MoveNext: Boolean;\r\nbegin\r\n if Valid then\r\n Inc(FCursor)\r\n else\r\n Valid := True;\r\n Result := FCursor < FOwnList.Size;\r\nend;\r\n{$ENDIF SUPPORTS_FOR_IN}\r\n\r\nfunction TJclSingleVectorIterator.Next: Single;\r\nbegin\r\n if Valid then\r\n Inc(FCursor)\r\n else\r\n Valid := True;\r\n Result := FOwnList.GetValue(FCursor);\r\nend;\r\n\r\nfunction TJclSingleVectorIterator.NextIndex: Integer;\r\nbegin\r\n if Valid then\r\n Result := FCursor + 1\r\n else\r\n Result := FCursor;\r\nend;\r\n\r\nfunction TJclSingleVectorIterator.Previous: Single;\r\nbegin\r\n if Valid then\r\n Dec(FCursor)\r\n else\r\n Valid := True;\r\n Result := FOwnList.GetValue(FCursor);\r\nend;\r\n\r\nfunction TJclSingleVectorIterator.PreviousIndex: Integer;\r\nbegin\r\n if Valid then\r\n Result := FCursor - 1\r\n else\r\n Result := FCursor;\r\nend;\r\n\r\nprocedure TJclSingleVectorIterator.Remove;\r\nbegin\r\n CheckValid;\r\n Valid := False;\r\n FOwnList.Delete(FCursor);\r\nend;\r\n\r\nprocedure TJclSingleVectorIterator.Reset;\r\nbegin\r\n Valid := False;\r\n case FStart of\r\n isFirst:\r\n FCursor := 0;\r\n isLast:\r\n FCursor := FOwnList.Size - 1;\r\n end;\r\nend;\r\n\r\nprocedure TJclSingleVectorIterator.SetValue(const AValue: Single);\r\nbegin\r\n CheckValid;\r\n FOwnList.SetValue(FCursor, AValue);\r\nend;\r\n\r\n//=== { TJclDoubleVector } ======================================================\r\n\r\nconstructor TJclDoubleVector.Create(ACapacity: Integer);\r\nbegin\r\n inherited Create();\r\n SetCapacity(ACapacity);\r\nend;\r\n\r\nconstructor TJclDoubleVector.Create(const ACollection: IJclDoubleCollection);\r\nbegin\r\n inherited Create();\r\n if ACollection = nil then\r\n raise EJclNoCollectionError.Create;\r\n SetCapacity(ACollection.Size);\r\n AddAll(ACollection);\r\nend;\r\n\r\ndestructor TJclDoubleVector.Destroy;\r\nbegin\r\n FReadOnly := False;\r\n Clear;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJclDoubleVector.Add(const AValue: Double): Boolean;\r\nvar\r\n Index: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := FAllowDefaultElements or not ItemsEqual(AValue, 0.0);\r\n if Result then\r\n begin\r\n if FDuplicates <> dupAccept then\r\n for Index := 0 to FSize - 1 do\r\n if ItemsEqual(AValue, FItems[Index]) then\r\n begin\r\n Result := CheckDuplicate;\r\n Break;\r\n end;\r\n if Result then\r\n begin\r\n if FSize = FCapacity then\r\n AutoGrow;\r\n Result := FSize < FCapacity;\r\n if Result then\r\n begin\r\n FItems[FSize] := AValue;\r\n Inc(FSize);\r\n end;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclDoubleVector.AddAll(const ACollection: IJclDoubleCollection): Boolean;\r\nvar\r\n It: IJclDoubleIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n Result := Add(It.Next) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclDoubleVector.AssignDataTo(Dest: TJclAbstractContainerBase);\r\nvar\r\n ADest: TJclDoubleVector;\r\n ACollection: IJclDoubleCollection;\r\nbegin\r\n inherited AssignDataTo(Dest);\r\n if Dest is TJclDoubleVector then\r\n begin\r\n ADest := TJclDoubleVector(Dest);\r\n ADest.Clear;\r\n ADest.AddAll(Self);\r\n end\r\n else\r\n if Supports(IInterface(Dest), IJclDoubleCollection, ACollection) then\r\n begin\r\n ACollection.Clear;\r\n ACollection.AddAll(Self);\r\n end;\r\nend;\r\n\r\nprocedure TJclDoubleVector.Clear;\r\nvar\r\n I: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n for I := 0 to FSize - 1 do\r\n FreeDouble(FItems[I]);\r\n FSize := 0;\r\n AutoPack;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclDoubleVector.CollectionEquals(const ACollection: IJclDoubleCollection): Boolean;\r\nvar\r\n I: Integer;\r\n It: IJclDoubleIterator;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n if FSize <> ACollection.Size then\r\n Exit;\r\n It := ACollection.First;\r\n for I := 0 to FSize - 1 do\r\n if not ItemsEqual(FItems[I], It.Next) then\r\n Exit;\r\n Result := True;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclDoubleVector.Contains(const AValue: Double): Boolean;\r\nvar\r\n I: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n for I := 0 to FSize - 1 do\r\n if ItemsEqual(FItems[I], AValue) then\r\n begin\r\n Result := True;\r\n Break;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclDoubleVector.ContainsAll(const ACollection: IJclDoubleCollection): Boolean;\r\nvar\r\n It: IJclDoubleIterator;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := True;\r\n if ACollection = nil then\r\n Exit;\r\n It := ACollection.First;\r\n while Result and It.HasNext do\r\n Result := Contains(It.Next);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclDoubleVector.Delete(Index: Integer): Double;\r\nvar\r\n Extracted: Double;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Extracted := ExtractIndex(Index);\r\n Result := FreeDouble(Extracted);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclDoubleVector.Extract(const AValue: Double): Boolean;\r\nvar\r\n I: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n for I := FSize - 1 downto 0 do\r\n if ItemsEqual(FItems[I], AValue) then\r\n begin\r\n if I < (FSize - 1) then\r\n MoveArray(FItems, I + 1, I, FSize - 1 - I)\r\n else\r\n FItems[I] := 0.0;\r\n Dec(FSize);\r\n Result := True;\r\n if FRemoveSingleElement then\r\n Break;\r\n end;\r\n AutoPack;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclDoubleVector.ExtractAll(const ACollection: IJclDoubleCollection): Boolean;\r\nvar\r\n It: IJclDoubleIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n Result := Extract(It.Next) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclDoubleVector.ExtractIndex(Index: Integer): Double;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if (Index >= 0) and (Index < FSize) then\r\n begin\r\n Result := FItems[Index];\r\n if Index < (FSize - 1) then\r\n MoveArray(FItems, Index + 1, Index, FSize - 1 - Index)\r\n else\r\n FItems[Index] := 0.0;\r\n Dec(FSize);\r\n AutoPack;\r\n end\r\n else\r\n Result := RaiseOutOfBoundsError;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclDoubleVector.First: IJclDoubleIterator;\r\nbegin\r\n Result := TJclDoubleVectorIterator.Create(Self, 0, False, isFirst);\r\nend;\r\n\r\n{$IFDEF SUPPORTS_FOR_IN}\r\nfunction TJclDoubleVector.GetEnumerator: IJclDoubleIterator;\r\nbegin\r\n Result := TJclDoubleVectorIterator.Create(Self, 0, False, isFirst);\r\nend;\r\n{$ENDIF SUPPORTS_FOR_IN}\r\n\r\nfunction TJclDoubleVector.GetValue(Index: Integer): Double;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := 0.0;\r\n if (Index >= 0) or (Index < FSize) then\r\n Result := FItems[Index]\r\n else\r\n if not FReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create(IntToStr(Index));\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclDoubleVector.IndexOf(const AValue: Double): Integer;\r\nvar\r\n I: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := -1;\r\n for I := 0 to FSize - 1 do\r\n if ItemsEqual(FItems[I], AValue) then\r\n begin\r\n Result := I;\r\n Break;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclDoubleVector.Insert(Index: Integer; const AValue: Double): Boolean;\r\nvar\r\n I: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := FAllowDefaultElements or not ItemsEqual(AValue, 0.0);\r\n if (Index < 0) or (Index > FSize) then\r\n raise EJclOutOfBoundsError.Create;\r\n if Result then\r\n begin\r\n if FDuplicates <> dupAccept then\r\n for I := 0 to FSize - 1 do\r\n if ItemsEqual(AValue, FItems[I]) then\r\n begin\r\n Result := CheckDuplicate;\r\n Break;\r\n end;\r\n if Result then\r\n begin\r\n if FSize = FCapacity then\r\n AutoGrow;\r\n Result := FSize < FCapacity;\r\n if Result then\r\n begin\r\n if Index < FSize then\r\n MoveArray(FItems, Index, Index + 1, FSize - Index);\r\n FItems[Index] := AValue;\r\n Inc(FSize);\r\n end;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclDoubleVector.InsertAll(Index: Integer; const ACollection: IJclDoubleCollection): Boolean;\r\nvar\r\n It: IJclDoubleIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if (Index < 0) or (Index > FSize) then\r\n raise EJclOutOfBoundsError.Create;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := ACollection.Last;\r\n while It.HasPrevious do\r\n Result := Insert(Index, It.Previous) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclDoubleVector.IsEmpty: Boolean;\r\nbegin\r\n Result := FSize = 0;\r\nend;\r\n\r\nfunction TJclDoubleVector.Last: IJclDoubleIterator;\r\nbegin\r\n Result := TJclDoubleVectorIterator.Create(Self, FSize - 1, False, isLast);\r\nend;\r\n\r\nfunction TJclDoubleVector.LastIndexOf(const AValue: Double): Integer;\r\nvar\r\n I: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := -1;\r\n for I := FSize - 1 downto 0 do\r\n if ItemsEqual(FItems[I], AValue) then\r\n begin\r\n Result := I;\r\n Break;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclDoubleVector.RaiseOutOfBoundsError: Double;\r\nbegin\r\n raise EJclOutOfBoundsError.Create;\r\nend;\r\n\r\nfunction TJclDoubleVector.Remove(const AValue: Double): Boolean;\r\nvar\r\n Extracted: Double;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := Extract(AValue);\r\n if Result then\r\n begin\r\n Extracted := AValue;\r\n FreeDouble(Extracted);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclDoubleVector.RemoveAll(const ACollection: IJclDoubleCollection): Boolean;\r\nvar\r\n It: IJclDoubleIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n Result := Remove(It.Next) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclDoubleVector.RetainAll(const ACollection: IJclDoubleCollection): Boolean;\r\nvar\r\n I: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n for I := FSize - 1 downto 0 do\r\n if not ACollection.Contains(FItems[I]) then\r\n Delete(I);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclDoubleVector.SetCapacity(Value: Integer);\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Value >= FSize then\r\n begin\r\n SetLength(FItems, Value);\r\n inherited SetCapacity(Value);\r\n end\r\n else\r\n raise EJclOutOfBoundsError.Create;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclDoubleVector.SetValue(Index: Integer; const AValue: Double);\r\nvar\r\n ReplaceItem: Boolean;\r\n I: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if (Index < 0) or (Index >= FSize) then\r\n raise EJclOutOfBoundsError.Create;\r\n ReplaceItem := FAllowDefaultElements or not ItemsEqual(AValue, 0.0);\r\n if ReplaceItem then\r\n begin\r\n if FDuplicates <> dupAccept then\r\n for I := 0 to FSize - 1 do\r\n if ItemsEqual(AValue, FItems[I]) then\r\n begin\r\n ReplaceItem := CheckDuplicate;\r\n Break;\r\n end;\r\n if ReplaceItem then\r\n begin\r\n FreeDouble(FItems[Index]);\r\n FItems[Index] := AValue;\r\n end;\r\n end;\r\n if not ReplaceItem then\r\n Delete(Index);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclDoubleVector.Size: Integer;\r\nbegin\r\n Result := FSize;\r\nend;\r\n\r\nfunction TJclDoubleVector.SubList(First, Count: Integer): IJclDoubleList;\r\nvar\r\n I: Integer;\r\n Last: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Last := First + Count - 1;\r\n if Last >= FSize then\r\n Last := FSize - 1;\r\n Result := CreateEmptyContainer as IJclDoubleList;\r\n for I := First to Last do\r\n Result.Add(FItems[I]);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclDoubleVector.CreateEmptyContainer: TJclAbstractContainerBase;\r\nbegin\r\n Result := TJclDoubleVector.Create(FSize);\r\n AssignPropertiesTo(Result);\r\nend;\r\n\r\n//=== { TJclDoubleVectorIterator } ===========================================================\r\n\r\nconstructor TJclDoubleVectorIterator.Create(AOwnList: TJclDoubleVector; ACursor: Integer; AValid: Boolean; AStart: TItrStart);\r\nbegin\r\n inherited Create(AValid);\r\n FOwnList := AOwnList;\r\n FStart := AStart;\r\n FCursor := ACursor;\r\nend;\r\n\r\nfunction TJclDoubleVectorIterator.Add(const AValue: Double): Boolean;\r\nbegin\r\n Result := FOwnList.Add(AValue);\r\nend;\r\n\r\nprocedure TJclDoubleVectorIterator.AssignPropertiesTo(Dest: TJclAbstractIterator);\r\nvar\r\n ADest: TJclDoubleVectorIterator;\r\nbegin\r\n inherited AssignPropertiesTo(Dest);\r\n if Dest is TJclDoubleVectorIterator then\r\n begin\r\n ADest := TJclDoubleVectorIterator(Dest);\r\n ADest.FOwnList := FOwnList;\r\n ADest.FCursor := FCursor;\r\n ADest.FStart := FStart;\r\n end;\r\nend;\r\n\r\nfunction TJclDoubleVectorIterator.CreateEmptyIterator: TJclAbstractIterator;\r\nbegin\r\n Result := TJclDoubleVectorIterator.Create(FOwnList, FCursor, Valid, FStart);\r\nend;\r\n\r\nprocedure TJclDoubleVectorIterator.Extract;\r\nbegin\r\n CheckValid;\r\n Valid := False;\r\n FOwnList.ExtractIndex(FCursor);\r\nend;\r\n\r\nfunction TJclDoubleVectorIterator.GetValue: Double;\r\nbegin\r\n CheckValid;\r\n Result := FOwnList.GetValue(FCursor);\r\nend;\r\n\r\nfunction TJclDoubleVectorIterator.HasNext: Boolean;\r\nbegin\r\n if Valid then\r\n Result := FCursor < (FOwnList.Size - 1)\r\n else\r\n Result := FCursor < FOwnList.Size;\r\nend;\r\n\r\nfunction TJclDoubleVectorIterator.HasPrevious: Boolean;\r\nbegin\r\n if Valid then\r\n Result := FCursor > 0\r\n else\r\n Result := FCursor >= 0;\r\nend;\r\n\r\nfunction TJclDoubleVectorIterator.Insert(const AValue: Double): Boolean;\r\nbegin\r\n CheckValid;\r\n Result := FOwnList.Insert(FCursor, AValue);\r\nend;\r\n\r\nfunction TJclDoubleVectorIterator.IteratorEquals(const AIterator: IJclDoubleIterator): Boolean;\r\nvar\r\n Obj: TObject;\r\n ItrObj: TJclDoubleVectorIterator;\r\nbegin\r\n Result := False;\r\n if AIterator = nil then\r\n Exit;\r\n Obj := AIterator.GetIteratorReference;\r\n if Obj is TJclDoubleVectorIterator then\r\n begin\r\n ItrObj := TJclDoubleVectorIterator(Obj);\r\n Result := (FOwnList = ItrObj.FOwnList) and (FCursor = ItrObj.FCursor) and (Valid = ItrObj.Valid);\r\n end;\r\nend;\r\n\r\n{$IFDEF SUPPORTS_FOR_IN}\r\nfunction TJclDoubleVectorIterator.MoveNext: Boolean;\r\nbegin\r\n if Valid then\r\n Inc(FCursor)\r\n else\r\n Valid := True;\r\n Result := FCursor < FOwnList.Size;\r\nend;\r\n{$ENDIF SUPPORTS_FOR_IN}\r\n\r\nfunction TJclDoubleVectorIterator.Next: Double;\r\nbegin\r\n if Valid then\r\n Inc(FCursor)\r\n else\r\n Valid := True;\r\n Result := FOwnList.GetValue(FCursor);\r\nend;\r\n\r\nfunction TJclDoubleVectorIterator.NextIndex: Integer;\r\nbegin\r\n if Valid then\r\n Result := FCursor + 1\r\n else\r\n Result := FCursor;\r\nend;\r\n\r\nfunction TJclDoubleVectorIterator.Previous: Double;\r\nbegin\r\n if Valid then\r\n Dec(FCursor)\r\n else\r\n Valid := True;\r\n Result := FOwnList.GetValue(FCursor);\r\nend;\r\n\r\nfunction TJclDoubleVectorIterator.PreviousIndex: Integer;\r\nbegin\r\n if Valid then\r\n Result := FCursor - 1\r\n else\r\n Result := FCursor;\r\nend;\r\n\r\nprocedure TJclDoubleVectorIterator.Remove;\r\nbegin\r\n CheckValid;\r\n Valid := False;\r\n FOwnList.Delete(FCursor);\r\nend;\r\n\r\nprocedure TJclDoubleVectorIterator.Reset;\r\nbegin\r\n Valid := False;\r\n case FStart of\r\n isFirst:\r\n FCursor := 0;\r\n isLast:\r\n FCursor := FOwnList.Size - 1;\r\n end;\r\nend;\r\n\r\nprocedure TJclDoubleVectorIterator.SetValue(const AValue: Double);\r\nbegin\r\n CheckValid;\r\n FOwnList.SetValue(FCursor, AValue);\r\nend;\r\n\r\n//=== { TJclExtendedVector } ======================================================\r\n\r\nconstructor TJclExtendedVector.Create(ACapacity: Integer);\r\nbegin\r\n inherited Create();\r\n SetCapacity(ACapacity);\r\nend;\r\n\r\nconstructor TJclExtendedVector.Create(const ACollection: IJclExtendedCollection);\r\nbegin\r\n inherited Create();\r\n if ACollection = nil then\r\n raise EJclNoCollectionError.Create;\r\n SetCapacity(ACollection.Size);\r\n AddAll(ACollection);\r\nend;\r\n\r\ndestructor TJclExtendedVector.Destroy;\r\nbegin\r\n FReadOnly := False;\r\n Clear;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJclExtendedVector.Add(const AValue: Extended): Boolean;\r\nvar\r\n Index: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := FAllowDefaultElements or not ItemsEqual(AValue, 0.0);\r\n if Result then\r\n begin\r\n if FDuplicates <> dupAccept then\r\n for Index := 0 to FSize - 1 do\r\n if ItemsEqual(AValue, FItems[Index]) then\r\n begin\r\n Result := CheckDuplicate;\r\n Break;\r\n end;\r\n if Result then\r\n begin\r\n if FSize = FCapacity then\r\n AutoGrow;\r\n Result := FSize < FCapacity;\r\n if Result then\r\n begin\r\n FItems[FSize] := AValue;\r\n Inc(FSize);\r\n end;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclExtendedVector.AddAll(const ACollection: IJclExtendedCollection): Boolean;\r\nvar\r\n It: IJclExtendedIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n Result := Add(It.Next) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclExtendedVector.AssignDataTo(Dest: TJclAbstractContainerBase);\r\nvar\r\n ADest: TJclExtendedVector;\r\n ACollection: IJclExtendedCollection;\r\nbegin\r\n inherited AssignDataTo(Dest);\r\n if Dest is TJclExtendedVector then\r\n begin\r\n ADest := TJclExtendedVector(Dest);\r\n ADest.Clear;\r\n ADest.AddAll(Self);\r\n end\r\n else\r\n if Supports(IInterface(Dest), IJclExtendedCollection, ACollection) then\r\n begin\r\n ACollection.Clear;\r\n ACollection.AddAll(Self);\r\n end;\r\nend;\r\n\r\nprocedure TJclExtendedVector.Clear;\r\nvar\r\n I: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n for I := 0 to FSize - 1 do\r\n FreeExtended(FItems[I]);\r\n FSize := 0;\r\n AutoPack;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclExtendedVector.CollectionEquals(const ACollection: IJclExtendedCollection): Boolean;\r\nvar\r\n I: Integer;\r\n It: IJclExtendedIterator;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n if FSize <> ACollection.Size then\r\n Exit;\r\n It := ACollection.First;\r\n for I := 0 to FSize - 1 do\r\n if not ItemsEqual(FItems[I], It.Next) then\r\n Exit;\r\n Result := True;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclExtendedVector.Contains(const AValue: Extended): Boolean;\r\nvar\r\n I: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n for I := 0 to FSize - 1 do\r\n if ItemsEqual(FItems[I], AValue) then\r\n begin\r\n Result := True;\r\n Break;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclExtendedVector.ContainsAll(const ACollection: IJclExtendedCollection): Boolean;\r\nvar\r\n It: IJclExtendedIterator;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := True;\r\n if ACollection = nil then\r\n Exit;\r\n It := ACollection.First;\r\n while Result and It.HasNext do\r\n Result := Contains(It.Next);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclExtendedVector.Delete(Index: Integer): Extended;\r\nvar\r\n Extracted: Extended;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Extracted := ExtractIndex(Index);\r\n Result := FreeExtended(Extracted);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclExtendedVector.Extract(const AValue: Extended): Boolean;\r\nvar\r\n I: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n for I := FSize - 1 downto 0 do\r\n if ItemsEqual(FItems[I], AValue) then\r\n begin\r\n if I < (FSize - 1) then\r\n MoveArray(FItems, I + 1, I, FSize - 1 - I)\r\n else\r\n FItems[I] := 0.0;\r\n Dec(FSize);\r\n Result := True;\r\n if FRemoveSingleElement then\r\n Break;\r\n end;\r\n AutoPack;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclExtendedVector.ExtractAll(const ACollection: IJclExtendedCollection): Boolean;\r\nvar\r\n It: IJclExtendedIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n Result := Extract(It.Next) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclExtendedVector.ExtractIndex(Index: Integer): Extended;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if (Index >= 0) and (Index < FSize) then\r\n begin\r\n Result := FItems[Index];\r\n if Index < (FSize - 1) then\r\n MoveArray(FItems, Index + 1, Index, FSize - 1 - Index)\r\n else\r\n FItems[Index] := 0.0;\r\n Dec(FSize);\r\n AutoPack;\r\n end\r\n else\r\n Result := RaiseOutOfBoundsError;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclExtendedVector.First: IJclExtendedIterator;\r\nbegin\r\n Result := TJclExtendedVectorIterator.Create(Self, 0, False, isFirst);\r\nend;\r\n\r\n{$IFDEF SUPPORTS_FOR_IN}\r\nfunction TJclExtendedVector.GetEnumerator: IJclExtendedIterator;\r\nbegin\r\n Result := TJclExtendedVectorIterator.Create(Self, 0, False, isFirst);\r\nend;\r\n{$ENDIF SUPPORTS_FOR_IN}\r\n\r\nfunction TJclExtendedVector.GetValue(Index: Integer): Extended;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := 0.0;\r\n if (Index >= 0) or (Index < FSize) then\r\n Result := FItems[Index]\r\n else\r\n if not FReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create(IntToStr(Index));\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclExtendedVector.IndexOf(const AValue: Extended): Integer;\r\nvar\r\n I: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := -1;\r\n for I := 0 to FSize - 1 do\r\n if ItemsEqual(FItems[I], AValue) then\r\n begin\r\n Result := I;\r\n Break;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclExtendedVector.Insert(Index: Integer; const AValue: Extended): Boolean;\r\nvar\r\n I: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := FAllowDefaultElements or not ItemsEqual(AValue, 0.0);\r\n if (Index < 0) or (Index > FSize) then\r\n raise EJclOutOfBoundsError.Create;\r\n if Result then\r\n begin\r\n if FDuplicates <> dupAccept then\r\n for I := 0 to FSize - 1 do\r\n if ItemsEqual(AValue, FItems[I]) then\r\n begin\r\n Result := CheckDuplicate;\r\n Break;\r\n end;\r\n if Result then\r\n begin\r\n if FSize = FCapacity then\r\n AutoGrow;\r\n Result := FSize < FCapacity;\r\n if Result then\r\n begin\r\n if Index < FSize then\r\n MoveArray(FItems, Index, Index + 1, FSize - Index);\r\n FItems[Index] := AValue;\r\n Inc(FSize);\r\n end;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclExtendedVector.InsertAll(Index: Integer; const ACollection: IJclExtendedCollection): Boolean;\r\nvar\r\n It: IJclExtendedIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if (Index < 0) or (Index > FSize) then\r\n raise EJclOutOfBoundsError.Create;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := ACollection.Last;\r\n while It.HasPrevious do\r\n Result := Insert(Index, It.Previous) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclExtendedVector.IsEmpty: Boolean;\r\nbegin\r\n Result := FSize = 0;\r\nend;\r\n\r\nfunction TJclExtendedVector.Last: IJclExtendedIterator;\r\nbegin\r\n Result := TJclExtendedVectorIterator.Create(Self, FSize - 1, False, isLast);\r\nend;\r\n\r\nfunction TJclExtendedVector.LastIndexOf(const AValue: Extended): Integer;\r\nvar\r\n I: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := -1;\r\n for I := FSize - 1 downto 0 do\r\n if ItemsEqual(FItems[I], AValue) then\r\n begin\r\n Result := I;\r\n Break;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclExtendedVector.RaiseOutOfBoundsError: Extended;\r\nbegin\r\n raise EJclOutOfBoundsError.Create;\r\nend;\r\n\r\nfunction TJclExtendedVector.Remove(const AValue: Extended): Boolean;\r\nvar\r\n Extracted: Extended;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := Extract(AValue);\r\n if Result then\r\n begin\r\n Extracted := AValue;\r\n FreeExtended(Extracted);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclExtendedVector.RemoveAll(const ACollection: IJclExtendedCollection): Boolean;\r\nvar\r\n It: IJclExtendedIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n Result := Remove(It.Next) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclExtendedVector.RetainAll(const ACollection: IJclExtendedCollection): Boolean;\r\nvar\r\n I: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n for I := FSize - 1 downto 0 do\r\n if not ACollection.Contains(FItems[I]) then\r\n Delete(I);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclExtendedVector.SetCapacity(Value: Integer);\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Value >= FSize then\r\n begin\r\n SetLength(FItems, Value);\r\n inherited SetCapacity(Value);\r\n end\r\n else\r\n raise EJclOutOfBoundsError.Create;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclExtendedVector.SetValue(Index: Integer; const AValue: Extended);\r\nvar\r\n ReplaceItem: Boolean;\r\n I: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if (Index < 0) or (Index >= FSize) then\r\n raise EJclOutOfBoundsError.Create;\r\n ReplaceItem := FAllowDefaultElements or not ItemsEqual(AValue, 0.0);\r\n if ReplaceItem then\r\n begin\r\n if FDuplicates <> dupAccept then\r\n for I := 0 to FSize - 1 do\r\n if ItemsEqual(AValue, FItems[I]) then\r\n begin\r\n ReplaceItem := CheckDuplicate;\r\n Break;\r\n end;\r\n if ReplaceItem then\r\n begin\r\n FreeExtended(FItems[Index]);\r\n FItems[Index] := AValue;\r\n end;\r\n end;\r\n if not ReplaceItem then\r\n Delete(Index);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclExtendedVector.Size: Integer;\r\nbegin\r\n Result := FSize;\r\nend;\r\n\r\nfunction TJclExtendedVector.SubList(First, Count: Integer): IJclExtendedList;\r\nvar\r\n I: Integer;\r\n Last: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Last := First + Count - 1;\r\n if Last >= FSize then\r\n Last := FSize - 1;\r\n Result := CreateEmptyContainer as IJclExtendedList;\r\n for I := First to Last do\r\n Result.Add(FItems[I]);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclExtendedVector.CreateEmptyContainer: TJclAbstractContainerBase;\r\nbegin\r\n Result := TJclExtendedVector.Create(FSize);\r\n AssignPropertiesTo(Result);\r\nend;\r\n\r\n//=== { TJclExtendedVectorIterator } ===========================================================\r\n\r\nconstructor TJclExtendedVectorIterator.Create(AOwnList: TJclExtendedVector; ACursor: Integer; AValid: Boolean; AStart: TItrStart);\r\nbegin\r\n inherited Create(AValid);\r\n FOwnList := AOwnList;\r\n FStart := AStart;\r\n FCursor := ACursor;\r\nend;\r\n\r\nfunction TJclExtendedVectorIterator.Add(const AValue: Extended): Boolean;\r\nbegin\r\n Result := FOwnList.Add(AValue);\r\nend;\r\n\r\nprocedure TJclExtendedVectorIterator.AssignPropertiesTo(Dest: TJclAbstractIterator);\r\nvar\r\n ADest: TJclExtendedVectorIterator;\r\nbegin\r\n inherited AssignPropertiesTo(Dest);\r\n if Dest is TJclExtendedVectorIterator then\r\n begin\r\n ADest := TJclExtendedVectorIterator(Dest);\r\n ADest.FOwnList := FOwnList;\r\n ADest.FCursor := FCursor;\r\n ADest.FStart := FStart;\r\n end;\r\nend;\r\n\r\nfunction TJclExtendedVectorIterator.CreateEmptyIterator: TJclAbstractIterator;\r\nbegin\r\n Result := TJclExtendedVectorIterator.Create(FOwnList, FCursor, Valid, FStart);\r\nend;\r\n\r\nprocedure TJclExtendedVectorIterator.Extract;\r\nbegin\r\n CheckValid;\r\n Valid := False;\r\n FOwnList.ExtractIndex(FCursor);\r\nend;\r\n\r\nfunction TJclExtendedVectorIterator.GetValue: Extended;\r\nbegin\r\n CheckValid;\r\n Result := FOwnList.GetValue(FCursor);\r\nend;\r\n\r\nfunction TJclExtendedVectorIterator.HasNext: Boolean;\r\nbegin\r\n if Valid then\r\n Result := FCursor < (FOwnList.Size - 1)\r\n else\r\n Result := FCursor < FOwnList.Size;\r\nend;\r\n\r\nfunction TJclExtendedVectorIterator.HasPrevious: Boolean;\r\nbegin\r\n if Valid then\r\n Result := FCursor > 0\r\n else\r\n Result := FCursor >= 0;\r\nend;\r\n\r\nfunction TJclExtendedVectorIterator.Insert(const AValue: Extended): Boolean;\r\nbegin\r\n CheckValid;\r\n Result := FOwnList.Insert(FCursor, AValue);\r\nend;\r\n\r\nfunction TJclExtendedVectorIterator.IteratorEquals(const AIterator: IJclExtendedIterator): Boolean;\r\nvar\r\n Obj: TObject;\r\n ItrObj: TJclExtendedVectorIterator;\r\nbegin\r\n Result := False;\r\n if AIterator = nil then\r\n Exit;\r\n Obj := AIterator.GetIteratorReference;\r\n if Obj is TJclExtendedVectorIterator then\r\n begin\r\n ItrObj := TJclExtendedVectorIterator(Obj);\r\n Result := (FOwnList = ItrObj.FOwnList) and (FCursor = ItrObj.FCursor) and (Valid = ItrObj.Valid);\r\n end;\r\nend;\r\n\r\n{$IFDEF SUPPORTS_FOR_IN}\r\nfunction TJclExtendedVectorIterator.MoveNext: Boolean;\r\nbegin\r\n if Valid then\r\n Inc(FCursor)\r\n else\r\n Valid := True;\r\n Result := FCursor < FOwnList.Size;\r\nend;\r\n{$ENDIF SUPPORTS_FOR_IN}\r\n\r\nfunction TJclExtendedVectorIterator.Next: Extended;\r\nbegin\r\n if Valid then\r\n Inc(FCursor)\r\n else\r\n Valid := True;\r\n Result := FOwnList.GetValue(FCursor);\r\nend;\r\n\r\nfunction TJclExtendedVectorIterator.NextIndex: Integer;\r\nbegin\r\n if Valid then\r\n Result := FCursor + 1\r\n else\r\n Result := FCursor;\r\nend;\r\n\r\nfunction TJclExtendedVectorIterator.Previous: Extended;\r\nbegin\r\n if Valid then\r\n Dec(FCursor)\r\n else\r\n Valid := True;\r\n Result := FOwnList.GetValue(FCursor);\r\nend;\r\n\r\nfunction TJclExtendedVectorIterator.PreviousIndex: Integer;\r\nbegin\r\n if Valid then\r\n Result := FCursor - 1\r\n else\r\n Result := FCursor;\r\nend;\r\n\r\nprocedure TJclExtendedVectorIterator.Remove;\r\nbegin\r\n CheckValid;\r\n Valid := False;\r\n FOwnList.Delete(FCursor);\r\nend;\r\n\r\nprocedure TJclExtendedVectorIterator.Reset;\r\nbegin\r\n Valid := False;\r\n case FStart of\r\n isFirst:\r\n FCursor := 0;\r\n isLast:\r\n FCursor := FOwnList.Size - 1;\r\n end;\r\nend;\r\n\r\nprocedure TJclExtendedVectorIterator.SetValue(const AValue: Extended);\r\nbegin\r\n CheckValid;\r\n FOwnList.SetValue(FCursor, AValue);\r\nend;\r\n\r\n//=== { TJclIntegerVector } ======================================================\r\n\r\nconstructor TJclIntegerVector.Create(ACapacity: Integer);\r\nbegin\r\n inherited Create();\r\n SetCapacity(ACapacity);\r\nend;\r\n\r\nconstructor TJclIntegerVector.Create(const ACollection: IJclIntegerCollection);\r\nbegin\r\n inherited Create();\r\n if ACollection = nil then\r\n raise EJclNoCollectionError.Create;\r\n SetCapacity(ACollection.Size);\r\n AddAll(ACollection);\r\nend;\r\n\r\ndestructor TJclIntegerVector.Destroy;\r\nbegin\r\n FReadOnly := False;\r\n Clear;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJclIntegerVector.Add(AValue: Integer): Boolean;\r\nvar\r\n Index: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := FAllowDefaultElements or not ItemsEqual(AValue, 0);\r\n if Result then\r\n begin\r\n if FDuplicates <> dupAccept then\r\n for Index := 0 to FSize - 1 do\r\n if ItemsEqual(AValue, FItems[Index]) then\r\n begin\r\n Result := CheckDuplicate;\r\n Break;\r\n end;\r\n if Result then\r\n begin\r\n if FSize = FCapacity then\r\n AutoGrow;\r\n Result := FSize < FCapacity;\r\n if Result then\r\n begin\r\n FItems[FSize] := AValue;\r\n Inc(FSize);\r\n end;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntegerVector.AddAll(const ACollection: IJclIntegerCollection): Boolean;\r\nvar\r\n It: IJclIntegerIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n Result := Add(It.Next) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclIntegerVector.AssignDataTo(Dest: TJclAbstractContainerBase);\r\nvar\r\n ADest: TJclIntegerVector;\r\n ACollection: IJclIntegerCollection;\r\nbegin\r\n inherited AssignDataTo(Dest);\r\n if Dest is TJclIntegerVector then\r\n begin\r\n ADest := TJclIntegerVector(Dest);\r\n ADest.Clear;\r\n ADest.AddAll(Self);\r\n end\r\n else\r\n if Supports(IInterface(Dest), IJclIntegerCollection, ACollection) then\r\n begin\r\n ACollection.Clear;\r\n ACollection.AddAll(Self);\r\n end;\r\nend;\r\n\r\nprocedure TJclIntegerVector.Clear;\r\nvar\r\n I: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n for I := 0 to FSize - 1 do\r\n FreeInteger(FItems[I]);\r\n FSize := 0;\r\n AutoPack;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntegerVector.CollectionEquals(const ACollection: IJclIntegerCollection): Boolean;\r\nvar\r\n I: Integer;\r\n It: IJclIntegerIterator;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n if FSize <> ACollection.Size then\r\n Exit;\r\n It := ACollection.First;\r\n for I := 0 to FSize - 1 do\r\n if not ItemsEqual(FItems[I], It.Next) then\r\n Exit;\r\n Result := True;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntegerVector.Contains(AValue: Integer): Boolean;\r\nvar\r\n I: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n for I := 0 to FSize - 1 do\r\n if ItemsEqual(FItems[I], AValue) then\r\n begin\r\n Result := True;\r\n Break;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntegerVector.ContainsAll(const ACollection: IJclIntegerCollection): Boolean;\r\nvar\r\n It: IJclIntegerIterator;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := True;\r\n if ACollection = nil then\r\n Exit;\r\n It := ACollection.First;\r\n while Result and It.HasNext do\r\n Result := Contains(It.Next);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntegerVector.Delete(Index: Integer): Integer;\r\nvar\r\n Extracted: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Extracted := ExtractIndex(Index);\r\n Result := FreeInteger(Extracted);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntegerVector.Extract(AValue: Integer): Boolean;\r\nvar\r\n I: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n for I := FSize - 1 downto 0 do\r\n if ItemsEqual(FItems[I], AValue) then\r\n begin\r\n if I < (FSize - 1) then\r\n MoveArray(FItems, I + 1, I, FSize - 1 - I)\r\n else\r\n FItems[I] := 0;\r\n Dec(FSize);\r\n Result := True;\r\n if FRemoveSingleElement then\r\n Break;\r\n end;\r\n AutoPack;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntegerVector.ExtractAll(const ACollection: IJclIntegerCollection): Boolean;\r\nvar\r\n It: IJclIntegerIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n Result := Extract(It.Next) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntegerVector.ExtractIndex(Index: Integer): Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if (Index >= 0) and (Index < FSize) then\r\n begin\r\n Result := FItems[Index];\r\n if Index < (FSize - 1) then\r\n MoveArray(FItems, Index + 1, Index, FSize - 1 - Index)\r\n else\r\n FItems[Index] := 0;\r\n Dec(FSize);\r\n AutoPack;\r\n end\r\n else\r\n Result := RaiseOutOfBoundsError;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntegerVector.First: IJclIntegerIterator;\r\nbegin\r\n Result := TJclIntegerVectorIterator.Create(Self, 0, False, isFirst);\r\nend;\r\n\r\n{$IFDEF SUPPORTS_FOR_IN}\r\nfunction TJclIntegerVector.GetEnumerator: IJclIntegerIterator;\r\nbegin\r\n Result := TJclIntegerVectorIterator.Create(Self, 0, False, isFirst);\r\nend;\r\n{$ENDIF SUPPORTS_FOR_IN}\r\n\r\nfunction TJclIntegerVector.GetValue(Index: Integer): Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := 0;\r\n if (Index >= 0) or (Index < FSize) then\r\n Result := FItems[Index]\r\n else\r\n if not FReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create(IntToStr(Index));\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntegerVector.IndexOf(AValue: Integer): Integer;\r\nvar\r\n I: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := -1;\r\n for I := 0 to FSize - 1 do\r\n if ItemsEqual(FItems[I], AValue) then\r\n begin\r\n Result := I;\r\n Break;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntegerVector.Insert(Index: Integer; AValue: Integer): Boolean;\r\nvar\r\n I: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := FAllowDefaultElements or not ItemsEqual(AValue, 0);\r\n if (Index < 0) or (Index > FSize) then\r\n raise EJclOutOfBoundsError.Create;\r\n if Result then\r\n begin\r\n if FDuplicates <> dupAccept then\r\n for I := 0 to FSize - 1 do\r\n if ItemsEqual(AValue, FItems[I]) then\r\n begin\r\n Result := CheckDuplicate;\r\n Break;\r\n end;\r\n if Result then\r\n begin\r\n if FSize = FCapacity then\r\n AutoGrow;\r\n Result := FSize < FCapacity;\r\n if Result then\r\n begin\r\n if Index < FSize then\r\n MoveArray(FItems, Index, Index + 1, FSize - Index);\r\n FItems[Index] := AValue;\r\n Inc(FSize);\r\n end;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntegerVector.InsertAll(Index: Integer; const ACollection: IJclIntegerCollection): Boolean;\r\nvar\r\n It: IJclIntegerIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if (Index < 0) or (Index > FSize) then\r\n raise EJclOutOfBoundsError.Create;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := ACollection.Last;\r\n while It.HasPrevious do\r\n Result := Insert(Index, It.Previous) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntegerVector.IsEmpty: Boolean;\r\nbegin\r\n Result := FSize = 0;\r\nend;\r\n\r\nfunction TJclIntegerVector.Last: IJclIntegerIterator;\r\nbegin\r\n Result := TJclIntegerVectorIterator.Create(Self, FSize - 1, False, isLast);\r\nend;\r\n\r\nfunction TJclIntegerVector.LastIndexOf(AValue: Integer): Integer;\r\nvar\r\n I: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := -1;\r\n for I := FSize - 1 downto 0 do\r\n if ItemsEqual(FItems[I], AValue) then\r\n begin\r\n Result := I;\r\n Break;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntegerVector.RaiseOutOfBoundsError: Integer;\r\nbegin\r\n raise EJclOutOfBoundsError.Create;\r\nend;\r\n\r\nfunction TJclIntegerVector.Remove(AValue: Integer): Boolean;\r\nvar\r\n Extracted: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := Extract(AValue);\r\n if Result then\r\n begin\r\n Extracted := AValue;\r\n FreeInteger(Extracted);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntegerVector.RemoveAll(const ACollection: IJclIntegerCollection): Boolean;\r\nvar\r\n It: IJclIntegerIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n Result := Remove(It.Next) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntegerVector.RetainAll(const ACollection: IJclIntegerCollection): Boolean;\r\nvar\r\n I: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n for I := FSize - 1 downto 0 do\r\n if not ACollection.Contains(FItems[I]) then\r\n Delete(I);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclIntegerVector.SetCapacity(Value: Integer);\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Value >= FSize then\r\n begin\r\n SetLength(FItems, Value);\r\n inherited SetCapacity(Value);\r\n end\r\n else\r\n raise EJclOutOfBoundsError.Create;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclIntegerVector.SetValue(Index: Integer; AValue: Integer);\r\nvar\r\n ReplaceItem: Boolean;\r\n I: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if (Index < 0) or (Index >= FSize) then\r\n raise EJclOutOfBoundsError.Create;\r\n ReplaceItem := FAllowDefaultElements or not ItemsEqual(AValue, 0);\r\n if ReplaceItem then\r\n begin\r\n if FDuplicates <> dupAccept then\r\n for I := 0 to FSize - 1 do\r\n if ItemsEqual(AValue, FItems[I]) then\r\n begin\r\n ReplaceItem := CheckDuplicate;\r\n Break;\r\n end;\r\n if ReplaceItem then\r\n begin\r\n FreeInteger(FItems[Index]);\r\n FItems[Index] := AValue;\r\n end;\r\n end;\r\n if not ReplaceItem then\r\n Delete(Index);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntegerVector.Size: Integer;\r\nbegin\r\n Result := FSize;\r\nend;\r\n\r\nfunction TJclIntegerVector.SubList(First, Count: Integer): IJclIntegerList;\r\nvar\r\n I: Integer;\r\n Last: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Last := First + Count - 1;\r\n if Last >= FSize then\r\n Last := FSize - 1;\r\n Result := CreateEmptyContainer as IJclIntegerList;\r\n for I := First to Last do\r\n Result.Add(FItems[I]);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclIntegerVector.CreateEmptyContainer: TJclAbstractContainerBase;\r\nbegin\r\n Result := TJclIntegerVector.Create(FSize);\r\n AssignPropertiesTo(Result);\r\nend;\r\n\r\n//=== { TJclIntegerVectorIterator } ===========================================================\r\n\r\nconstructor TJclIntegerVectorIterator.Create(AOwnList: TJclIntegerVector; ACursor: Integer; AValid: Boolean; AStart: TItrStart);\r\nbegin\r\n inherited Create(AValid);\r\n FOwnList := AOwnList;\r\n FStart := AStart;\r\n FCursor := ACursor;\r\nend;\r\n\r\nfunction TJclIntegerVectorIterator.Add(AValue: Integer): Boolean;\r\nbegin\r\n Result := FOwnList.Add(AValue);\r\nend;\r\n\r\nprocedure TJclIntegerVectorIterator.AssignPropertiesTo(Dest: TJclAbstractIterator);\r\nvar\r\n ADest: TJclIntegerVectorIterator;\r\nbegin\r\n inherited AssignPropertiesTo(Dest);\r\n if Dest is TJclIntegerVectorIterator then\r\n begin\r\n ADest := TJclIntegerVectorIterator(Dest);\r\n ADest.FOwnList := FOwnList;\r\n ADest.FCursor := FCursor;\r\n ADest.FStart := FStart;\r\n end;\r\nend;\r\n\r\nfunction TJclIntegerVectorIterator.CreateEmptyIterator: TJclAbstractIterator;\r\nbegin\r\n Result := TJclIntegerVectorIterator.Create(FOwnList, FCursor, Valid, FStart);\r\nend;\r\n\r\nprocedure TJclIntegerVectorIterator.Extract;\r\nbegin\r\n CheckValid;\r\n Valid := False;\r\n FOwnList.ExtractIndex(FCursor);\r\nend;\r\n\r\nfunction TJclIntegerVectorIterator.GetValue: Integer;\r\nbegin\r\n CheckValid;\r\n Result := FOwnList.GetValue(FCursor);\r\nend;\r\n\r\nfunction TJclIntegerVectorIterator.HasNext: Boolean;\r\nbegin\r\n if Valid then\r\n Result := FCursor < (FOwnList.Size - 1)\r\n else\r\n Result := FCursor < FOwnList.Size;\r\nend;\r\n\r\nfunction TJclIntegerVectorIterator.HasPrevious: Boolean;\r\nbegin\r\n if Valid then\r\n Result := FCursor > 0\r\n else\r\n Result := FCursor >= 0;\r\nend;\r\n\r\nfunction TJclIntegerVectorIterator.Insert(AValue: Integer): Boolean;\r\nbegin\r\n CheckValid;\r\n Result := FOwnList.Insert(FCursor, AValue);\r\nend;\r\n\r\nfunction TJclIntegerVectorIterator.IteratorEquals(const AIterator: IJclIntegerIterator): Boolean;\r\nvar\r\n Obj: TObject;\r\n ItrObj: TJclIntegerVectorIterator;\r\nbegin\r\n Result := False;\r\n if AIterator = nil then\r\n Exit;\r\n Obj := AIterator.GetIteratorReference;\r\n if Obj is TJclIntegerVectorIterator then\r\n begin\r\n ItrObj := TJclIntegerVectorIterator(Obj);\r\n Result := (FOwnList = ItrObj.FOwnList) and (FCursor = ItrObj.FCursor) and (Valid = ItrObj.Valid);\r\n end;\r\nend;\r\n\r\n{$IFDEF SUPPORTS_FOR_IN}\r\nfunction TJclIntegerVectorIterator.MoveNext: Boolean;\r\nbegin\r\n if Valid then\r\n Inc(FCursor)\r\n else\r\n Valid := True;\r\n Result := FCursor < FOwnList.Size;\r\nend;\r\n{$ENDIF SUPPORTS_FOR_IN}\r\n\r\nfunction TJclIntegerVectorIterator.Next: Integer;\r\nbegin\r\n if Valid then\r\n Inc(FCursor)\r\n else\r\n Valid := True;\r\n Result := FOwnList.GetValue(FCursor);\r\nend;\r\n\r\nfunction TJclIntegerVectorIterator.NextIndex: Integer;\r\nbegin\r\n if Valid then\r\n Result := FCursor + 1\r\n else\r\n Result := FCursor;\r\nend;\r\n\r\nfunction TJclIntegerVectorIterator.Previous: Integer;\r\nbegin\r\n if Valid then\r\n Dec(FCursor)\r\n else\r\n Valid := True;\r\n Result := FOwnList.GetValue(FCursor);\r\nend;\r\n\r\nfunction TJclIntegerVectorIterator.PreviousIndex: Integer;\r\nbegin\r\n if Valid then\r\n Result := FCursor - 1\r\n else\r\n Result := FCursor;\r\nend;\r\n\r\nprocedure TJclIntegerVectorIterator.Remove;\r\nbegin\r\n CheckValid;\r\n Valid := False;\r\n FOwnList.Delete(FCursor);\r\nend;\r\n\r\nprocedure TJclIntegerVectorIterator.Reset;\r\nbegin\r\n Valid := False;\r\n case FStart of\r\n isFirst:\r\n FCursor := 0;\r\n isLast:\r\n FCursor := FOwnList.Size - 1;\r\n end;\r\nend;\r\n\r\nprocedure TJclIntegerVectorIterator.SetValue(AValue: Integer);\r\nbegin\r\n CheckValid;\r\n FOwnList.SetValue(FCursor, AValue);\r\nend;\r\n\r\n//=== { TJclCardinalVector } ======================================================\r\n\r\nconstructor TJclCardinalVector.Create(ACapacity: Integer);\r\nbegin\r\n inherited Create();\r\n SetCapacity(ACapacity);\r\nend;\r\n\r\nconstructor TJclCardinalVector.Create(const ACollection: IJclCardinalCollection);\r\nbegin\r\n inherited Create();\r\n if ACollection = nil then\r\n raise EJclNoCollectionError.Create;\r\n SetCapacity(ACollection.Size);\r\n AddAll(ACollection);\r\nend;\r\n\r\ndestructor TJclCardinalVector.Destroy;\r\nbegin\r\n FReadOnly := False;\r\n Clear;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJclCardinalVector.Add(AValue: Cardinal): Boolean;\r\nvar\r\n Index: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := FAllowDefaultElements or not ItemsEqual(AValue, 0);\r\n if Result then\r\n begin\r\n if FDuplicates <> dupAccept then\r\n for Index := 0 to FSize - 1 do\r\n if ItemsEqual(AValue, FItems[Index]) then\r\n begin\r\n Result := CheckDuplicate;\r\n Break;\r\n end;\r\n if Result then\r\n begin\r\n if FSize = FCapacity then\r\n AutoGrow;\r\n Result := FSize < FCapacity;\r\n if Result then\r\n begin\r\n FItems[FSize] := AValue;\r\n Inc(FSize);\r\n end;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclCardinalVector.AddAll(const ACollection: IJclCardinalCollection): Boolean;\r\nvar\r\n It: IJclCardinalIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n Result := Add(It.Next) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclCardinalVector.AssignDataTo(Dest: TJclAbstractContainerBase);\r\nvar\r\n ADest: TJclCardinalVector;\r\n ACollection: IJclCardinalCollection;\r\nbegin\r\n inherited AssignDataTo(Dest);\r\n if Dest is TJclCardinalVector then\r\n begin\r\n ADest := TJclCardinalVector(Dest);\r\n ADest.Clear;\r\n ADest.AddAll(Self);\r\n end\r\n else\r\n if Supports(IInterface(Dest), IJclCardinalCollection, ACollection) then\r\n begin\r\n ACollection.Clear;\r\n ACollection.AddAll(Self);\r\n end;\r\nend;\r\n\r\nprocedure TJclCardinalVector.Clear;\r\nvar\r\n I: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n for I := 0 to FSize - 1 do\r\n FreeCardinal(FItems[I]);\r\n FSize := 0;\r\n AutoPack;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclCardinalVector.CollectionEquals(const ACollection: IJclCardinalCollection): Boolean;\r\nvar\r\n I: Integer;\r\n It: IJclCardinalIterator;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n if FSize <> ACollection.Size then\r\n Exit;\r\n It := ACollection.First;\r\n for I := 0 to FSize - 1 do\r\n if not ItemsEqual(FItems[I], It.Next) then\r\n Exit;\r\n Result := True;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclCardinalVector.Contains(AValue: Cardinal): Boolean;\r\nvar\r\n I: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n for I := 0 to FSize - 1 do\r\n if ItemsEqual(FItems[I], AValue) then\r\n begin\r\n Result := True;\r\n Break;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclCardinalVector.ContainsAll(const ACollection: IJclCardinalCollection): Boolean;\r\nvar\r\n It: IJclCardinalIterator;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := True;\r\n if ACollection = nil then\r\n Exit;\r\n It := ACollection.First;\r\n while Result and It.HasNext do\r\n Result := Contains(It.Next);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclCardinalVector.Delete(Index: Integer): Cardinal;\r\nvar\r\n Extracted: Cardinal;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Extracted := ExtractIndex(Index);\r\n Result := FreeCardinal(Extracted);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclCardinalVector.Extract(AValue: Cardinal): Boolean;\r\nvar\r\n I: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n for I := FSize - 1 downto 0 do\r\n if ItemsEqual(FItems[I], AValue) then\r\n begin\r\n if I < (FSize - 1) then\r\n MoveArray(FItems, I + 1, I, FSize - 1 - I)\r\n else\r\n FItems[I] := 0;\r\n Dec(FSize);\r\n Result := True;\r\n if FRemoveSingleElement then\r\n Break;\r\n end;\r\n AutoPack;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclCardinalVector.ExtractAll(const ACollection: IJclCardinalCollection): Boolean;\r\nvar\r\n It: IJclCardinalIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n Result := Extract(It.Next) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclCardinalVector.ExtractIndex(Index: Integer): Cardinal;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if (Index >= 0) and (Index < FSize) then\r\n begin\r\n Result := FItems[Index];\r\n if Index < (FSize - 1) then\r\n MoveArray(FItems, Index + 1, Index, FSize - 1 - Index)\r\n else\r\n FItems[Index] := 0;\r\n Dec(FSize);\r\n AutoPack;\r\n end\r\n else\r\n Result := RaiseOutOfBoundsError;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclCardinalVector.First: IJclCardinalIterator;\r\nbegin\r\n Result := TJclCardinalVectorIterator.Create(Self, 0, False, isFirst);\r\nend;\r\n\r\n{$IFDEF SUPPORTS_FOR_IN}\r\nfunction TJclCardinalVector.GetEnumerator: IJclCardinalIterator;\r\nbegin\r\n Result := TJclCardinalVectorIterator.Create(Self, 0, False, isFirst);\r\nend;\r\n{$ENDIF SUPPORTS_FOR_IN}\r\n\r\nfunction TJclCardinalVector.GetValue(Index: Integer): Cardinal;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := 0;\r\n if (Index >= 0) or (Index < FSize) then\r\n Result := FItems[Index]\r\n else\r\n if not FReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create(IntToStr(Index));\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclCardinalVector.IndexOf(AValue: Cardinal): Integer;\r\nvar\r\n I: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := -1;\r\n for I := 0 to FSize - 1 do\r\n if ItemsEqual(FItems[I], AValue) then\r\n begin\r\n Result := I;\r\n Break;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclCardinalVector.Insert(Index: Integer; AValue: Cardinal): Boolean;\r\nvar\r\n I: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := FAllowDefaultElements or not ItemsEqual(AValue, 0);\r\n if (Index < 0) or (Index > FSize) then\r\n raise EJclOutOfBoundsError.Create;\r\n if Result then\r\n begin\r\n if FDuplicates <> dupAccept then\r\n for I := 0 to FSize - 1 do\r\n if ItemsEqual(AValue, FItems[I]) then\r\n begin\r\n Result := CheckDuplicate;\r\n Break;\r\n end;\r\n if Result then\r\n begin\r\n if FSize = FCapacity then\r\n AutoGrow;\r\n Result := FSize < FCapacity;\r\n if Result then\r\n begin\r\n if Index < FSize then\r\n MoveArray(FItems, Index, Index + 1, FSize - Index);\r\n FItems[Index] := AValue;\r\n Inc(FSize);\r\n end;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclCardinalVector.InsertAll(Index: Integer; const ACollection: IJclCardinalCollection): Boolean;\r\nvar\r\n It: IJclCardinalIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if (Index < 0) or (Index > FSize) then\r\n raise EJclOutOfBoundsError.Create;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := ACollection.Last;\r\n while It.HasPrevious do\r\n Result := Insert(Index, It.Previous) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclCardinalVector.IsEmpty: Boolean;\r\nbegin\r\n Result := FSize = 0;\r\nend;\r\n\r\nfunction TJclCardinalVector.Last: IJclCardinalIterator;\r\nbegin\r\n Result := TJclCardinalVectorIterator.Create(Self, FSize - 1, False, isLast);\r\nend;\r\n\r\nfunction TJclCardinalVector.LastIndexOf(AValue: Cardinal): Integer;\r\nvar\r\n I: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := -1;\r\n for I := FSize - 1 downto 0 do\r\n if ItemsEqual(FItems[I], AValue) then\r\n begin\r\n Result := I;\r\n Break;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclCardinalVector.RaiseOutOfBoundsError: Cardinal;\r\nbegin\r\n raise EJclOutOfBoundsError.Create;\r\nend;\r\n\r\nfunction TJclCardinalVector.Remove(AValue: Cardinal): Boolean;\r\nvar\r\n Extracted: Cardinal;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := Extract(AValue);\r\n if Result then\r\n begin\r\n Extracted := AValue;\r\n FreeCardinal(Extracted);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclCardinalVector.RemoveAll(const ACollection: IJclCardinalCollection): Boolean;\r\nvar\r\n It: IJclCardinalIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n Result := Remove(It.Next) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclCardinalVector.RetainAll(const ACollection: IJclCardinalCollection): Boolean;\r\nvar\r\n I: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n for I := FSize - 1 downto 0 do\r\n if not ACollection.Contains(FItems[I]) then\r\n Delete(I);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclCardinalVector.SetCapacity(Value: Integer);\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Value >= FSize then\r\n begin\r\n SetLength(FItems, Value);\r\n inherited SetCapacity(Value);\r\n end\r\n else\r\n raise EJclOutOfBoundsError.Create;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclCardinalVector.SetValue(Index: Integer; AValue: Cardinal);\r\nvar\r\n ReplaceItem: Boolean;\r\n I: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if (Index < 0) or (Index >= FSize) then\r\n raise EJclOutOfBoundsError.Create;\r\n ReplaceItem := FAllowDefaultElements or not ItemsEqual(AValue, 0);\r\n if ReplaceItem then\r\n begin\r\n if FDuplicates <> dupAccept then\r\n for I := 0 to FSize - 1 do\r\n if ItemsEqual(AValue, FItems[I]) then\r\n begin\r\n ReplaceItem := CheckDuplicate;\r\n Break;\r\n end;\r\n if ReplaceItem then\r\n begin\r\n FreeCardinal(FItems[Index]);\r\n FItems[Index] := AValue;\r\n end;\r\n end;\r\n if not ReplaceItem then\r\n Delete(Index);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclCardinalVector.Size: Integer;\r\nbegin\r\n Result := FSize;\r\nend;\r\n\r\nfunction TJclCardinalVector.SubList(First, Count: Integer): IJclCardinalList;\r\nvar\r\n I: Integer;\r\n Last: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Last := First + Count - 1;\r\n if Last >= FSize then\r\n Last := FSize - 1;\r\n Result := CreateEmptyContainer as IJclCardinalList;\r\n for I := First to Last do\r\n Result.Add(FItems[I]);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclCardinalVector.CreateEmptyContainer: TJclAbstractContainerBase;\r\nbegin\r\n Result := TJclCardinalVector.Create(FSize);\r\n AssignPropertiesTo(Result);\r\nend;\r\n\r\n//=== { TJclCardinalVectorIterator } ===========================================================\r\n\r\nconstructor TJclCardinalVectorIterator.Create(AOwnList: TJclCardinalVector; ACursor: Integer; AValid: Boolean; AStart: TItrStart);\r\nbegin\r\n inherited Create(AValid);\r\n FOwnList := AOwnList;\r\n FStart := AStart;\r\n FCursor := ACursor;\r\nend;\r\n\r\nfunction TJclCardinalVectorIterator.Add(AValue: Cardinal): Boolean;\r\nbegin\r\n Result := FOwnList.Add(AValue);\r\nend;\r\n\r\nprocedure TJclCardinalVectorIterator.AssignPropertiesTo(Dest: TJclAbstractIterator);\r\nvar\r\n ADest: TJclCardinalVectorIterator;\r\nbegin\r\n inherited AssignPropertiesTo(Dest);\r\n if Dest is TJclCardinalVectorIterator then\r\n begin\r\n ADest := TJclCardinalVectorIterator(Dest);\r\n ADest.FOwnList := FOwnList;\r\n ADest.FCursor := FCursor;\r\n ADest.FStart := FStart;\r\n end;\r\nend;\r\n\r\nfunction TJclCardinalVectorIterator.CreateEmptyIterator: TJclAbstractIterator;\r\nbegin\r\n Result := TJclCardinalVectorIterator.Create(FOwnList, FCursor, Valid, FStart);\r\nend;\r\n\r\nprocedure TJclCardinalVectorIterator.Extract;\r\nbegin\r\n CheckValid;\r\n Valid := False;\r\n FOwnList.ExtractIndex(FCursor);\r\nend;\r\n\r\nfunction TJclCardinalVectorIterator.GetValue: Cardinal;\r\nbegin\r\n CheckValid;\r\n Result := FOwnList.GetValue(FCursor);\r\nend;\r\n\r\nfunction TJclCardinalVectorIterator.HasNext: Boolean;\r\nbegin\r\n if Valid then\r\n Result := FCursor < (FOwnList.Size - 1)\r\n else\r\n Result := FCursor < FOwnList.Size;\r\nend;\r\n\r\nfunction TJclCardinalVectorIterator.HasPrevious: Boolean;\r\nbegin\r\n if Valid then\r\n Result := FCursor > 0\r\n else\r\n Result := FCursor >= 0;\r\nend;\r\n\r\nfunction TJclCardinalVectorIterator.Insert(AValue: Cardinal): Boolean;\r\nbegin\r\n CheckValid;\r\n Result := FOwnList.Insert(FCursor, AValue);\r\nend;\r\n\r\nfunction TJclCardinalVectorIterator.IteratorEquals(const AIterator: IJclCardinalIterator): Boolean;\r\nvar\r\n Obj: TObject;\r\n ItrObj: TJclCardinalVectorIterator;\r\nbegin\r\n Result := False;\r\n if AIterator = nil then\r\n Exit;\r\n Obj := AIterator.GetIteratorReference;\r\n if Obj is TJclCardinalVectorIterator then\r\n begin\r\n ItrObj := TJclCardinalVectorIterator(Obj);\r\n Result := (FOwnList = ItrObj.FOwnList) and (FCursor = ItrObj.FCursor) and (Valid = ItrObj.Valid);\r\n end;\r\nend;\r\n\r\n{$IFDEF SUPPORTS_FOR_IN}\r\nfunction TJclCardinalVectorIterator.MoveNext: Boolean;\r\nbegin\r\n if Valid then\r\n Inc(FCursor)\r\n else\r\n Valid := True;\r\n Result := FCursor < FOwnList.Size;\r\nend;\r\n{$ENDIF SUPPORTS_FOR_IN}\r\n\r\nfunction TJclCardinalVectorIterator.Next: Cardinal;\r\nbegin\r\n if Valid then\r\n Inc(FCursor)\r\n else\r\n Valid := True;\r\n Result := FOwnList.GetValue(FCursor);\r\nend;\r\n\r\nfunction TJclCardinalVectorIterator.NextIndex: Integer;\r\nbegin\r\n if Valid then\r\n Result := FCursor + 1\r\n else\r\n Result := FCursor;\r\nend;\r\n\r\nfunction TJclCardinalVectorIterator.Previous: Cardinal;\r\nbegin\r\n if Valid then\r\n Dec(FCursor)\r\n else\r\n Valid := True;\r\n Result := FOwnList.GetValue(FCursor);\r\nend;\r\n\r\nfunction TJclCardinalVectorIterator.PreviousIndex: Integer;\r\nbegin\r\n if Valid then\r\n Result := FCursor - 1\r\n else\r\n Result := FCursor;\r\nend;\r\n\r\nprocedure TJclCardinalVectorIterator.Remove;\r\nbegin\r\n CheckValid;\r\n Valid := False;\r\n FOwnList.Delete(FCursor);\r\nend;\r\n\r\nprocedure TJclCardinalVectorIterator.Reset;\r\nbegin\r\n Valid := False;\r\n case FStart of\r\n isFirst:\r\n FCursor := 0;\r\n isLast:\r\n FCursor := FOwnList.Size - 1;\r\n end;\r\nend;\r\n\r\nprocedure TJclCardinalVectorIterator.SetValue(AValue: Cardinal);\r\nbegin\r\n CheckValid;\r\n FOwnList.SetValue(FCursor, AValue);\r\nend;\r\n\r\n//=== { TJclInt64Vector } ======================================================\r\n\r\nconstructor TJclInt64Vector.Create(ACapacity: Integer);\r\nbegin\r\n inherited Create();\r\n SetCapacity(ACapacity);\r\nend;\r\n\r\nconstructor TJclInt64Vector.Create(const ACollection: IJclInt64Collection);\r\nbegin\r\n inherited Create();\r\n if ACollection = nil then\r\n raise EJclNoCollectionError.Create;\r\n SetCapacity(ACollection.Size);\r\n AddAll(ACollection);\r\nend;\r\n\r\ndestructor TJclInt64Vector.Destroy;\r\nbegin\r\n FReadOnly := False;\r\n Clear;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJclInt64Vector.Add(const AValue: Int64): Boolean;\r\nvar\r\n Index: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := FAllowDefaultElements or not ItemsEqual(AValue, 0);\r\n if Result then\r\n begin\r\n if FDuplicates <> dupAccept then\r\n for Index := 0 to FSize - 1 do\r\n if ItemsEqual(AValue, FItems[Index]) then\r\n begin\r\n Result := CheckDuplicate;\r\n Break;\r\n end;\r\n if Result then\r\n begin\r\n if FSize = FCapacity then\r\n AutoGrow;\r\n Result := FSize < FCapacity;\r\n if Result then\r\n begin\r\n FItems[FSize] := AValue;\r\n Inc(FSize);\r\n end;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclInt64Vector.AddAll(const ACollection: IJclInt64Collection): Boolean;\r\nvar\r\n It: IJclInt64Iterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n Result := Add(It.Next) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclInt64Vector.AssignDataTo(Dest: TJclAbstractContainerBase);\r\nvar\r\n ADest: TJclInt64Vector;\r\n ACollection: IJclInt64Collection;\r\nbegin\r\n inherited AssignDataTo(Dest);\r\n if Dest is TJclInt64Vector then\r\n begin\r\n ADest := TJclInt64Vector(Dest);\r\n ADest.Clear;\r\n ADest.AddAll(Self);\r\n end\r\n else\r\n if Supports(IInterface(Dest), IJclInt64Collection, ACollection) then\r\n begin\r\n ACollection.Clear;\r\n ACollection.AddAll(Self);\r\n end;\r\nend;\r\n\r\nprocedure TJclInt64Vector.Clear;\r\nvar\r\n I: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n for I := 0 to FSize - 1 do\r\n FreeInt64(FItems[I]);\r\n FSize := 0;\r\n AutoPack;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclInt64Vector.CollectionEquals(const ACollection: IJclInt64Collection): Boolean;\r\nvar\r\n I: Integer;\r\n It: IJclInt64Iterator;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n if FSize <> ACollection.Size then\r\n Exit;\r\n It := ACollection.First;\r\n for I := 0 to FSize - 1 do\r\n if not ItemsEqual(FItems[I], It.Next) then\r\n Exit;\r\n Result := True;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclInt64Vector.Contains(const AValue: Int64): Boolean;\r\nvar\r\n I: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n for I := 0 to FSize - 1 do\r\n if ItemsEqual(FItems[I], AValue) then\r\n begin\r\n Result := True;\r\n Break;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclInt64Vector.ContainsAll(const ACollection: IJclInt64Collection): Boolean;\r\nvar\r\n It: IJclInt64Iterator;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := True;\r\n if ACollection = nil then\r\n Exit;\r\n It := ACollection.First;\r\n while Result and It.HasNext do\r\n Result := Contains(It.Next);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclInt64Vector.Delete(Index: Integer): Int64;\r\nvar\r\n Extracted: Int64;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Extracted := ExtractIndex(Index);\r\n Result := FreeInt64(Extracted);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclInt64Vector.Extract(const AValue: Int64): Boolean;\r\nvar\r\n I: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n for I := FSize - 1 downto 0 do\r\n if ItemsEqual(FItems[I], AValue) then\r\n begin\r\n if I < (FSize - 1) then\r\n MoveArray(FItems, I + 1, I, FSize - 1 - I)\r\n else\r\n FItems[I] := 0;\r\n Dec(FSize);\r\n Result := True;\r\n if FRemoveSingleElement then\r\n Break;\r\n end;\r\n AutoPack;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclInt64Vector.ExtractAll(const ACollection: IJclInt64Collection): Boolean;\r\nvar\r\n It: IJclInt64Iterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n Result := Extract(It.Next) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclInt64Vector.ExtractIndex(Index: Integer): Int64;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if (Index >= 0) and (Index < FSize) then\r\n begin\r\n Result := FItems[Index];\r\n if Index < (FSize - 1) then\r\n MoveArray(FItems, Index + 1, Index, FSize - 1 - Index)\r\n else\r\n FItems[Index] := 0;\r\n Dec(FSize);\r\n AutoPack;\r\n end\r\n else\r\n Result := RaiseOutOfBoundsError;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclInt64Vector.First: IJclInt64Iterator;\r\nbegin\r\n Result := TJclInt64VectorIterator.Create(Self, 0, False, isFirst);\r\nend;\r\n\r\n{$IFDEF SUPPORTS_FOR_IN}\r\nfunction TJclInt64Vector.GetEnumerator: IJclInt64Iterator;\r\nbegin\r\n Result := TJclInt64VectorIterator.Create(Self, 0, False, isFirst);\r\nend;\r\n{$ENDIF SUPPORTS_FOR_IN}\r\n\r\nfunction TJclInt64Vector.GetValue(Index: Integer): Int64;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := 0;\r\n if (Index >= 0) or (Index < FSize) then\r\n Result := FItems[Index]\r\n else\r\n if not FReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create(IntToStr(Index));\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclInt64Vector.IndexOf(const AValue: Int64): Integer;\r\nvar\r\n I: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := -1;\r\n for I := 0 to FSize - 1 do\r\n if ItemsEqual(FItems[I], AValue) then\r\n begin\r\n Result := I;\r\n Break;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclInt64Vector.Insert(Index: Integer; const AValue: Int64): Boolean;\r\nvar\r\n I: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := FAllowDefaultElements or not ItemsEqual(AValue, 0);\r\n if (Index < 0) or (Index > FSize) then\r\n raise EJclOutOfBoundsError.Create;\r\n if Result then\r\n begin\r\n if FDuplicates <> dupAccept then\r\n for I := 0 to FSize - 1 do\r\n if ItemsEqual(AValue, FItems[I]) then\r\n begin\r\n Result := CheckDuplicate;\r\n Break;\r\n end;\r\n if Result then\r\n begin\r\n if FSize = FCapacity then\r\n AutoGrow;\r\n Result := FSize < FCapacity;\r\n if Result then\r\n begin\r\n if Index < FSize then\r\n MoveArray(FItems, Index, Index + 1, FSize - Index);\r\n FItems[Index] := AValue;\r\n Inc(FSize);\r\n end;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclInt64Vector.InsertAll(Index: Integer; const ACollection: IJclInt64Collection): Boolean;\r\nvar\r\n It: IJclInt64Iterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if (Index < 0) or (Index > FSize) then\r\n raise EJclOutOfBoundsError.Create;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := ACollection.Last;\r\n while It.HasPrevious do\r\n Result := Insert(Index, It.Previous) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclInt64Vector.IsEmpty: Boolean;\r\nbegin\r\n Result := FSize = 0;\r\nend;\r\n\r\nfunction TJclInt64Vector.Last: IJclInt64Iterator;\r\nbegin\r\n Result := TJclInt64VectorIterator.Create(Self, FSize - 1, False, isLast);\r\nend;\r\n\r\nfunction TJclInt64Vector.LastIndexOf(const AValue: Int64): Integer;\r\nvar\r\n I: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := -1;\r\n for I := FSize - 1 downto 0 do\r\n if ItemsEqual(FItems[I], AValue) then\r\n begin\r\n Result := I;\r\n Break;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclInt64Vector.RaiseOutOfBoundsError: Int64;\r\nbegin\r\n raise EJclOutOfBoundsError.Create;\r\nend;\r\n\r\nfunction TJclInt64Vector.Remove(const AValue: Int64): Boolean;\r\nvar\r\n Extracted: Int64;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := Extract(AValue);\r\n if Result then\r\n begin\r\n Extracted := AValue;\r\n FreeInt64(Extracted);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclInt64Vector.RemoveAll(const ACollection: IJclInt64Collection): Boolean;\r\nvar\r\n It: IJclInt64Iterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n Result := Remove(It.Next) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclInt64Vector.RetainAll(const ACollection: IJclInt64Collection): Boolean;\r\nvar\r\n I: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n for I := FSize - 1 downto 0 do\r\n if not ACollection.Contains(FItems[I]) then\r\n Delete(I);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclInt64Vector.SetCapacity(Value: Integer);\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Value >= FSize then\r\n begin\r\n SetLength(FItems, Value);\r\n inherited SetCapacity(Value);\r\n end\r\n else\r\n raise EJclOutOfBoundsError.Create;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclInt64Vector.SetValue(Index: Integer; const AValue: Int64);\r\nvar\r\n ReplaceItem: Boolean;\r\n I: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if (Index < 0) or (Index >= FSize) then\r\n raise EJclOutOfBoundsError.Create;\r\n ReplaceItem := FAllowDefaultElements or not ItemsEqual(AValue, 0);\r\n if ReplaceItem then\r\n begin\r\n if FDuplicates <> dupAccept then\r\n for I := 0 to FSize - 1 do\r\n if ItemsEqual(AValue, FItems[I]) then\r\n begin\r\n ReplaceItem := CheckDuplicate;\r\n Break;\r\n end;\r\n if ReplaceItem then\r\n begin\r\n FreeInt64(FItems[Index]);\r\n FItems[Index] := AValue;\r\n end;\r\n end;\r\n if not ReplaceItem then\r\n Delete(Index);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclInt64Vector.Size: Integer;\r\nbegin\r\n Result := FSize;\r\nend;\r\n\r\nfunction TJclInt64Vector.SubList(First, Count: Integer): IJclInt64List;\r\nvar\r\n I: Integer;\r\n Last: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Last := First + Count - 1;\r\n if Last >= FSize then\r\n Last := FSize - 1;\r\n Result := CreateEmptyContainer as IJclInt64List;\r\n for I := First to Last do\r\n Result.Add(FItems[I]);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclInt64Vector.CreateEmptyContainer: TJclAbstractContainerBase;\r\nbegin\r\n Result := TJclInt64Vector.Create(FSize);\r\n AssignPropertiesTo(Result);\r\nend;\r\n\r\n//=== { TJclInt64VectorIterator } ===========================================================\r\n\r\nconstructor TJclInt64VectorIterator.Create(AOwnList: TJclInt64Vector; ACursor: Integer; AValid: Boolean; AStart: TItrStart);\r\nbegin\r\n inherited Create(AValid);\r\n FOwnList := AOwnList;\r\n FStart := AStart;\r\n FCursor := ACursor;\r\nend;\r\n\r\nfunction TJclInt64VectorIterator.Add(const AValue: Int64): Boolean;\r\nbegin\r\n Result := FOwnList.Add(AValue);\r\nend;\r\n\r\nprocedure TJclInt64VectorIterator.AssignPropertiesTo(Dest: TJclAbstractIterator);\r\nvar\r\n ADest: TJclInt64VectorIterator;\r\nbegin\r\n inherited AssignPropertiesTo(Dest);\r\n if Dest is TJclInt64VectorIterator then\r\n begin\r\n ADest := TJclInt64VectorIterator(Dest);\r\n ADest.FOwnList := FOwnList;\r\n ADest.FCursor := FCursor;\r\n ADest.FStart := FStart;\r\n end;\r\nend;\r\n\r\nfunction TJclInt64VectorIterator.CreateEmptyIterator: TJclAbstractIterator;\r\nbegin\r\n Result := TJclInt64VectorIterator.Create(FOwnList, FCursor, Valid, FStart);\r\nend;\r\n\r\nprocedure TJclInt64VectorIterator.Extract;\r\nbegin\r\n CheckValid;\r\n Valid := False;\r\n FOwnList.ExtractIndex(FCursor);\r\nend;\r\n\r\nfunction TJclInt64VectorIterator.GetValue: Int64;\r\nbegin\r\n CheckValid;\r\n Result := FOwnList.GetValue(FCursor);\r\nend;\r\n\r\nfunction TJclInt64VectorIterator.HasNext: Boolean;\r\nbegin\r\n if Valid then\r\n Result := FCursor < (FOwnList.Size - 1)\r\n else\r\n Result := FCursor < FOwnList.Size;\r\nend;\r\n\r\nfunction TJclInt64VectorIterator.HasPrevious: Boolean;\r\nbegin\r\n if Valid then\r\n Result := FCursor > 0\r\n else\r\n Result := FCursor >= 0;\r\nend;\r\n\r\nfunction TJclInt64VectorIterator.Insert(const AValue: Int64): Boolean;\r\nbegin\r\n CheckValid;\r\n Result := FOwnList.Insert(FCursor, AValue);\r\nend;\r\n\r\nfunction TJclInt64VectorIterator.IteratorEquals(const AIterator: IJclInt64Iterator): Boolean;\r\nvar\r\n Obj: TObject;\r\n ItrObj: TJclInt64VectorIterator;\r\nbegin\r\n Result := False;\r\n if AIterator = nil then\r\n Exit;\r\n Obj := AIterator.GetIteratorReference;\r\n if Obj is TJclInt64VectorIterator then\r\n begin\r\n ItrObj := TJclInt64VectorIterator(Obj);\r\n Result := (FOwnList = ItrObj.FOwnList) and (FCursor = ItrObj.FCursor) and (Valid = ItrObj.Valid);\r\n end;\r\nend;\r\n\r\n{$IFDEF SUPPORTS_FOR_IN}\r\nfunction TJclInt64VectorIterator.MoveNext: Boolean;\r\nbegin\r\n if Valid then\r\n Inc(FCursor)\r\n else\r\n Valid := True;\r\n Result := FCursor < FOwnList.Size;\r\nend;\r\n{$ENDIF SUPPORTS_FOR_IN}\r\n\r\nfunction TJclInt64VectorIterator.Next: Int64;\r\nbegin\r\n if Valid then\r\n Inc(FCursor)\r\n else\r\n Valid := True;\r\n Result := FOwnList.GetValue(FCursor);\r\nend;\r\n\r\nfunction TJclInt64VectorIterator.NextIndex: Integer;\r\nbegin\r\n if Valid then\r\n Result := FCursor + 1\r\n else\r\n Result := FCursor;\r\nend;\r\n\r\nfunction TJclInt64VectorIterator.Previous: Int64;\r\nbegin\r\n if Valid then\r\n Dec(FCursor)\r\n else\r\n Valid := True;\r\n Result := FOwnList.GetValue(FCursor);\r\nend;\r\n\r\nfunction TJclInt64VectorIterator.PreviousIndex: Integer;\r\nbegin\r\n if Valid then\r\n Result := FCursor - 1\r\n else\r\n Result := FCursor;\r\nend;\r\n\r\nprocedure TJclInt64VectorIterator.Remove;\r\nbegin\r\n CheckValid;\r\n Valid := False;\r\n FOwnList.Delete(FCursor);\r\nend;\r\n\r\nprocedure TJclInt64VectorIterator.Reset;\r\nbegin\r\n Valid := False;\r\n case FStart of\r\n isFirst:\r\n FCursor := 0;\r\n isLast:\r\n FCursor := FOwnList.Size - 1;\r\n end;\r\nend;\r\n\r\nprocedure TJclInt64VectorIterator.SetValue(const AValue: Int64);\r\nbegin\r\n CheckValid;\r\n FOwnList.SetValue(FCursor, AValue);\r\nend;\r\n\r\n//=== { TJclPtrVector } ======================================================\r\n\r\nconstructor TJclPtrVector.Create(ACapacity: Integer);\r\nbegin\r\n inherited Create();\r\n SetCapacity(ACapacity);\r\nend;\r\n\r\nconstructor TJclPtrVector.Create(const ACollection: IJclPtrCollection);\r\nbegin\r\n inherited Create();\r\n if ACollection = nil then\r\n raise EJclNoCollectionError.Create;\r\n SetCapacity(ACollection.Size);\r\n AddAll(ACollection);\r\nend;\r\n\r\ndestructor TJclPtrVector.Destroy;\r\nbegin\r\n FReadOnly := False;\r\n Clear;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJclPtrVector.Add(APtr: Pointer): Boolean;\r\nvar\r\n Index: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := FAllowDefaultElements or not ItemsEqual(APtr, nil);\r\n if Result then\r\n begin\r\n if FDuplicates <> dupAccept then\r\n for Index := 0 to FSize - 1 do\r\n if ItemsEqual(APtr, FItems[Index]) then\r\n begin\r\n Result := CheckDuplicate;\r\n Break;\r\n end;\r\n if Result then\r\n begin\r\n if FSize = FCapacity then\r\n AutoGrow;\r\n Result := FSize < FCapacity;\r\n if Result then\r\n begin\r\n FItems[FSize] := APtr;\r\n Inc(FSize);\r\n end;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclPtrVector.AddAll(const ACollection: IJclPtrCollection): Boolean;\r\nvar\r\n It: IJclPtrIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n Result := Add(It.Next) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclPtrVector.AssignDataTo(Dest: TJclAbstractContainerBase);\r\nvar\r\n ADest: TJclPtrVector;\r\n ACollection: IJclPtrCollection;\r\nbegin\r\n inherited AssignDataTo(Dest);\r\n if Dest is TJclPtrVector then\r\n begin\r\n ADest := TJclPtrVector(Dest);\r\n ADest.Clear;\r\n ADest.AddAll(Self);\r\n end\r\n else\r\n if Supports(IInterface(Dest), IJclPtrCollection, ACollection) then\r\n begin\r\n ACollection.Clear;\r\n ACollection.AddAll(Self);\r\n end;\r\nend;\r\n\r\nprocedure TJclPtrVector.Clear;\r\nvar\r\n I: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n for I := 0 to FSize - 1 do\r\n FreePointer(FItems[I]);\r\n FSize := 0;\r\n AutoPack;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclPtrVector.CollectionEquals(const ACollection: IJclPtrCollection): Boolean;\r\nvar\r\n I: Integer;\r\n It: IJclPtrIterator;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n if FSize <> ACollection.Size then\r\n Exit;\r\n It := ACollection.First;\r\n for I := 0 to FSize - 1 do\r\n if not ItemsEqual(FItems[I], It.Next) then\r\n Exit;\r\n Result := True;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclPtrVector.Contains(APtr: Pointer): Boolean;\r\nvar\r\n I: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n for I := 0 to FSize - 1 do\r\n if ItemsEqual(FItems[I], APtr) then\r\n begin\r\n Result := True;\r\n Break;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclPtrVector.ContainsAll(const ACollection: IJclPtrCollection): Boolean;\r\nvar\r\n It: IJclPtrIterator;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := True;\r\n if ACollection = nil then\r\n Exit;\r\n It := ACollection.First;\r\n while Result and It.HasNext do\r\n Result := Contains(It.Next);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclPtrVector.Delete(Index: Integer): Pointer;\r\nvar\r\n Extracted: Pointer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Extracted := ExtractIndex(Index);\r\n Result := FreePointer(Extracted);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclPtrVector.Extract(APtr: Pointer): Boolean;\r\nvar\r\n I: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n for I := FSize - 1 downto 0 do\r\n if ItemsEqual(FItems[I], APtr) then\r\n begin\r\n if I < (FSize - 1) then\r\n MoveArray(FItems, I + 1, I, FSize - 1 - I)\r\n else\r\n FItems[I] := nil;\r\n Dec(FSize);\r\n Result := True;\r\n if FRemoveSingleElement then\r\n Break;\r\n end;\r\n AutoPack;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclPtrVector.ExtractAll(const ACollection: IJclPtrCollection): Boolean;\r\nvar\r\n It: IJclPtrIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n Result := Extract(It.Next) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclPtrVector.ExtractIndex(Index: Integer): Pointer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if (Index >= 0) and (Index < FSize) then\r\n begin\r\n Result := FItems[Index];\r\n if Index < (FSize - 1) then\r\n MoveArray(FItems, Index + 1, Index, FSize - 1 - Index)\r\n else\r\n FItems[Index] := nil;\r\n Dec(FSize);\r\n AutoPack;\r\n end\r\n else\r\n Result := RaiseOutOfBoundsError;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclPtrVector.First: IJclPtrIterator;\r\nbegin\r\n Result := TJclPtrVectorIterator.Create(Self, 0, False, isFirst);\r\nend;\r\n\r\n{$IFDEF SUPPORTS_FOR_IN}\r\nfunction TJclPtrVector.GetEnumerator: IJclPtrIterator;\r\nbegin\r\n Result := TJclPtrVectorIterator.Create(Self, 0, False, isFirst);\r\nend;\r\n{$ENDIF SUPPORTS_FOR_IN}\r\n\r\nfunction TJclPtrVector.GetPointer(Index: Integer): Pointer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := nil;\r\n if (Index >= 0) or (Index < FSize) then\r\n Result := FItems[Index]\r\n else\r\n if not FReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create(IntToStr(Index));\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclPtrVector.IndexOf(APtr: Pointer): Integer;\r\nvar\r\n I: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := -1;\r\n for I := 0 to FSize - 1 do\r\n if ItemsEqual(FItems[I], APtr) then\r\n begin\r\n Result := I;\r\n Break;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclPtrVector.Insert(Index: Integer; APtr: Pointer): Boolean;\r\nvar\r\n I: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := FAllowDefaultElements or not ItemsEqual(APtr, nil);\r\n if (Index < 0) or (Index > FSize) then\r\n raise EJclOutOfBoundsError.Create;\r\n if Result then\r\n begin\r\n if FDuplicates <> dupAccept then\r\n for I := 0 to FSize - 1 do\r\n if ItemsEqual(APtr, FItems[I]) then\r\n begin\r\n Result := CheckDuplicate;\r\n Break;\r\n end;\r\n if Result then\r\n begin\r\n if FSize = FCapacity then\r\n AutoGrow;\r\n Result := FSize < FCapacity;\r\n if Result then\r\n begin\r\n if Index < FSize then\r\n MoveArray(FItems, Index, Index + 1, FSize - Index);\r\n FItems[Index] := APtr;\r\n Inc(FSize);\r\n end;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclPtrVector.InsertAll(Index: Integer; const ACollection: IJclPtrCollection): Boolean;\r\nvar\r\n It: IJclPtrIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if (Index < 0) or (Index > FSize) then\r\n raise EJclOutOfBoundsError.Create;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := ACollection.Last;\r\n while It.HasPrevious do\r\n Result := Insert(Index, It.Previous) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclPtrVector.IsEmpty: Boolean;\r\nbegin\r\n Result := FSize = 0;\r\nend;\r\n\r\nfunction TJclPtrVector.Last: IJclPtrIterator;\r\nbegin\r\n Result := TJclPtrVectorIterator.Create(Self, FSize - 1, False, isLast);\r\nend;\r\n\r\nfunction TJclPtrVector.LastIndexOf(APtr: Pointer): Integer;\r\nvar\r\n I: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := -1;\r\n for I := FSize - 1 downto 0 do\r\n if ItemsEqual(FItems[I], APtr) then\r\n begin\r\n Result := I;\r\n Break;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclPtrVector.RaiseOutOfBoundsError: Pointer;\r\nbegin\r\n raise EJclOutOfBoundsError.Create;\r\nend;\r\n\r\nfunction TJclPtrVector.Remove(APtr: Pointer): Boolean;\r\nvar\r\n Extracted: Pointer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := Extract(APtr);\r\n if Result then\r\n begin\r\n Extracted := APtr;\r\n FreePointer(Extracted);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclPtrVector.RemoveAll(const ACollection: IJclPtrCollection): Boolean;\r\nvar\r\n It: IJclPtrIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n Result := Remove(It.Next) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclPtrVector.RetainAll(const ACollection: IJclPtrCollection): Boolean;\r\nvar\r\n I: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n for I := FSize - 1 downto 0 do\r\n if not ACollection.Contains(FItems[I]) then\r\n Delete(I);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclPtrVector.SetCapacity(Value: Integer);\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Value >= FSize then\r\n begin\r\n SetLength(FItems, Value);\r\n inherited SetCapacity(Value);\r\n end\r\n else\r\n raise EJclOutOfBoundsError.Create;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclPtrVector.SetPointer(Index: Integer; APtr: Pointer);\r\nvar\r\n ReplaceItem: Boolean;\r\n I: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if (Index < 0) or (Index >= FSize) then\r\n raise EJclOutOfBoundsError.Create;\r\n ReplaceItem := FAllowDefaultElements or not ItemsEqual(APtr, nil);\r\n if ReplaceItem then\r\n begin\r\n if FDuplicates <> dupAccept then\r\n for I := 0 to FSize - 1 do\r\n if ItemsEqual(APtr, FItems[I]) then\r\n begin\r\n ReplaceItem := CheckDuplicate;\r\n Break;\r\n end;\r\n if ReplaceItem then\r\n begin\r\n FreePointer(FItems[Index]);\r\n FItems[Index] := APtr;\r\n end;\r\n end;\r\n if not ReplaceItem then\r\n Delete(Index);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclPtrVector.Size: Integer;\r\nbegin\r\n Result := FSize;\r\nend;\r\n\r\nfunction TJclPtrVector.SubList(First, Count: Integer): IJclPtrList;\r\nvar\r\n I: Integer;\r\n Last: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Last := First + Count - 1;\r\n if Last >= FSize then\r\n Last := FSize - 1;\r\n Result := CreateEmptyContainer as IJclPtrList;\r\n for I := First to Last do\r\n Result.Add(FItems[I]);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclPtrVector.CreateEmptyContainer: TJclAbstractContainerBase;\r\nbegin\r\n Result := TJclPtrVector.Create(FSize);\r\n AssignPropertiesTo(Result);\r\nend;\r\n\r\n//=== { TJclPtrVectorIterator } ===========================================================\r\n\r\nconstructor TJclPtrVectorIterator.Create(AOwnList: TJclPtrVector; ACursor: Integer; AValid: Boolean; AStart: TItrStart);\r\nbegin\r\n inherited Create(AValid);\r\n FOwnList := AOwnList;\r\n FStart := AStart;\r\n FCursor := ACursor;\r\nend;\r\n\r\nfunction TJclPtrVectorIterator.Add(APtr: Pointer): Boolean;\r\nbegin\r\n Result := FOwnList.Add(APtr);\r\nend;\r\n\r\nprocedure TJclPtrVectorIterator.AssignPropertiesTo(Dest: TJclAbstractIterator);\r\nvar\r\n ADest: TJclPtrVectorIterator;\r\nbegin\r\n inherited AssignPropertiesTo(Dest);\r\n if Dest is TJclPtrVectorIterator then\r\n begin\r\n ADest := TJclPtrVectorIterator(Dest);\r\n ADest.FOwnList := FOwnList;\r\n ADest.FCursor := FCursor;\r\n ADest.FStart := FStart;\r\n end;\r\nend;\r\n\r\nfunction TJclPtrVectorIterator.CreateEmptyIterator: TJclAbstractIterator;\r\nbegin\r\n Result := TJclPtrVectorIterator.Create(FOwnList, FCursor, Valid, FStart);\r\nend;\r\n\r\nprocedure TJclPtrVectorIterator.Extract;\r\nbegin\r\n CheckValid;\r\n Valid := False;\r\n FOwnList.ExtractIndex(FCursor);\r\nend;\r\n\r\nfunction TJclPtrVectorIterator.GetPointer: Pointer;\r\nbegin\r\n CheckValid;\r\n Result := FOwnList.GetPointer(FCursor);\r\nend;\r\n\r\nfunction TJclPtrVectorIterator.HasNext: Boolean;\r\nbegin\r\n if Valid then\r\n Result := FCursor < (FOwnList.Size - 1)\r\n else\r\n Result := FCursor < FOwnList.Size;\r\nend;\r\n\r\nfunction TJclPtrVectorIterator.HasPrevious: Boolean;\r\nbegin\r\n if Valid then\r\n Result := FCursor > 0\r\n else\r\n Result := FCursor >= 0;\r\nend;\r\n\r\nfunction TJclPtrVectorIterator.Insert(APtr: Pointer): Boolean;\r\nbegin\r\n CheckValid;\r\n Result := FOwnList.Insert(FCursor, APtr);\r\nend;\r\n\r\nfunction TJclPtrVectorIterator.IteratorEquals(const AIterator: IJclPtrIterator): Boolean;\r\nvar\r\n Obj: TObject;\r\n ItrObj: TJclPtrVectorIterator;\r\nbegin\r\n Result := False;\r\n if AIterator = nil then\r\n Exit;\r\n Obj := AIterator.GetIteratorReference;\r\n if Obj is TJclPtrVectorIterator then\r\n begin\r\n ItrObj := TJclPtrVectorIterator(Obj);\r\n Result := (FOwnList = ItrObj.FOwnList) and (FCursor = ItrObj.FCursor) and (Valid = ItrObj.Valid);\r\n end;\r\nend;\r\n\r\n{$IFDEF SUPPORTS_FOR_IN}\r\nfunction TJclPtrVectorIterator.MoveNext: Boolean;\r\nbegin\r\n if Valid then\r\n Inc(FCursor)\r\n else\r\n Valid := True;\r\n Result := FCursor < FOwnList.Size;\r\nend;\r\n{$ENDIF SUPPORTS_FOR_IN}\r\n\r\nfunction TJclPtrVectorIterator.Next: Pointer;\r\nbegin\r\n if Valid then\r\n Inc(FCursor)\r\n else\r\n Valid := True;\r\n Result := FOwnList.GetPointer(FCursor);\r\nend;\r\n\r\nfunction TJclPtrVectorIterator.NextIndex: Integer;\r\nbegin\r\n if Valid then\r\n Result := FCursor + 1\r\n else\r\n Result := FCursor;\r\nend;\r\n\r\nfunction TJclPtrVectorIterator.Previous: Pointer;\r\nbegin\r\n if Valid then\r\n Dec(FCursor)\r\n else\r\n Valid := True;\r\n Result := FOwnList.GetPointer(FCursor);\r\nend;\r\n\r\nfunction TJclPtrVectorIterator.PreviousIndex: Integer;\r\nbegin\r\n if Valid then\r\n Result := FCursor - 1\r\n else\r\n Result := FCursor;\r\nend;\r\n\r\nprocedure TJclPtrVectorIterator.Remove;\r\nbegin\r\n CheckValid;\r\n Valid := False;\r\n FOwnList.Delete(FCursor);\r\nend;\r\n\r\nprocedure TJclPtrVectorIterator.Reset;\r\nbegin\r\n Valid := False;\r\n case FStart of\r\n isFirst:\r\n FCursor := 0;\r\n isLast:\r\n FCursor := FOwnList.Size - 1;\r\n end;\r\nend;\r\n\r\nprocedure TJclPtrVectorIterator.SetPointer(APtr: Pointer);\r\nbegin\r\n CheckValid;\r\n FOwnList.SetPointer(FCursor, APtr);\r\nend;\r\n\r\n//=== { TJclVector } ======================================================\r\n\r\nconstructor TJclVector.Create(ACapacity: Integer; AOwnsObjects: Boolean);\r\nbegin\r\n inherited Create(AOwnsObjects);\r\n SetCapacity(ACapacity);\r\nend;\r\n\r\nconstructor TJclVector.Create(const ACollection: IJclCollection; AOwnsObjects: Boolean);\r\nbegin\r\n inherited Create(AOwnsObjects);\r\n if ACollection = nil then\r\n raise EJclNoCollectionError.Create;\r\n SetCapacity(ACollection.Size);\r\n AddAll(ACollection);\r\nend;\r\n\r\ndestructor TJclVector.Destroy;\r\nbegin\r\n FReadOnly := False;\r\n Clear;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJclVector.Add(AObject: TObject): Boolean;\r\nvar\r\n Index: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := FAllowDefaultElements or not ItemsEqual(AObject, nil);\r\n if Result then\r\n begin\r\n if FDuplicates <> dupAccept then\r\n for Index := 0 to FSize - 1 do\r\n if ItemsEqual(AObject, FItems[Index]) then\r\n begin\r\n Result := CheckDuplicate;\r\n Break;\r\n end;\r\n if Result then\r\n begin\r\n if FSize = FCapacity then\r\n AutoGrow;\r\n Result := FSize < FCapacity;\r\n if Result then\r\n begin\r\n FItems[FSize] := AObject;\r\n Inc(FSize);\r\n end;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclVector.AddAll(const ACollection: IJclCollection): Boolean;\r\nvar\r\n It: IJclIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n Result := Add(It.Next) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclVector.AssignDataTo(Dest: TJclAbstractContainerBase);\r\nvar\r\n ADest: TJclVector;\r\n ACollection: IJclCollection;\r\nbegin\r\n inherited AssignDataTo(Dest);\r\n if Dest is TJclVector then\r\n begin\r\n ADest := TJclVector(Dest);\r\n ADest.Clear;\r\n ADest.AddAll(Self);\r\n end\r\n else\r\n if Supports(IInterface(Dest), IJclCollection, ACollection) then\r\n begin\r\n ACollection.Clear;\r\n ACollection.AddAll(Self);\r\n end;\r\nend;\r\n\r\nprocedure TJclVector.Clear;\r\nvar\r\n I: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n for I := 0 to FSize - 1 do\r\n FreeObject(FItems[I]);\r\n FSize := 0;\r\n AutoPack;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclVector.CollectionEquals(const ACollection: IJclCollection): Boolean;\r\nvar\r\n I: Integer;\r\n It: IJclIterator;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n if FSize <> ACollection.Size then\r\n Exit;\r\n It := ACollection.First;\r\n for I := 0 to FSize - 1 do\r\n if not ItemsEqual(FItems[I], It.Next) then\r\n Exit;\r\n Result := True;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclVector.Contains(AObject: TObject): Boolean;\r\nvar\r\n I: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n for I := 0 to FSize - 1 do\r\n if ItemsEqual(FItems[I], AObject) then\r\n begin\r\n Result := True;\r\n Break;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclVector.ContainsAll(const ACollection: IJclCollection): Boolean;\r\nvar\r\n It: IJclIterator;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := True;\r\n if ACollection = nil then\r\n Exit;\r\n It := ACollection.First;\r\n while Result and It.HasNext do\r\n Result := Contains(It.Next);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclVector.Delete(Index: Integer): TObject;\r\nvar\r\n Extracted: TObject;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Extracted := ExtractIndex(Index);\r\n Result := FreeObject(Extracted);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclVector.Extract(AObject: TObject): Boolean;\r\nvar\r\n I: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n for I := FSize - 1 downto 0 do\r\n if ItemsEqual(FItems[I], AObject) then\r\n begin\r\n if I < (FSize - 1) then\r\n MoveArray(FItems, I + 1, I, FSize - 1 - I)\r\n else\r\n FItems[I] := nil;\r\n Dec(FSize);\r\n Result := True;\r\n if FRemoveSingleElement then\r\n Break;\r\n end;\r\n AutoPack;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclVector.ExtractAll(const ACollection: IJclCollection): Boolean;\r\nvar\r\n It: IJclIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n Result := Extract(It.Next) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclVector.ExtractIndex(Index: Integer): TObject;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if (Index >= 0) and (Index < FSize) then\r\n begin\r\n Result := FItems[Index];\r\n if Index < (FSize - 1) then\r\n MoveArray(FItems, Index + 1, Index, FSize - 1 - Index)\r\n else\r\n FItems[Index] := nil;\r\n Dec(FSize);\r\n AutoPack;\r\n end\r\n else\r\n Result := RaiseOutOfBoundsError;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclVector.First: IJclIterator;\r\nbegin\r\n Result := TJclVectorIterator.Create(Self, 0, False, isFirst);\r\nend;\r\n\r\n{$IFDEF SUPPORTS_FOR_IN}\r\nfunction TJclVector.GetEnumerator: IJclIterator;\r\nbegin\r\n Result := TJclVectorIterator.Create(Self, 0, False, isFirst);\r\nend;\r\n{$ENDIF SUPPORTS_FOR_IN}\r\n\r\nfunction TJclVector.GetObject(Index: Integer): TObject;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := nil;\r\n if (Index >= 0) or (Index < FSize) then\r\n Result := FItems[Index]\r\n else\r\n if not FReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create(IntToStr(Index));\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclVector.IndexOf(AObject: TObject): Integer;\r\nvar\r\n I: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := -1;\r\n for I := 0 to FSize - 1 do\r\n if ItemsEqual(FItems[I], AObject) then\r\n begin\r\n Result := I;\r\n Break;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclVector.Insert(Index: Integer; AObject: TObject): Boolean;\r\nvar\r\n I: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := FAllowDefaultElements or not ItemsEqual(AObject, nil);\r\n if (Index < 0) or (Index > FSize) then\r\n raise EJclOutOfBoundsError.Create;\r\n if Result then\r\n begin\r\n if FDuplicates <> dupAccept then\r\n for I := 0 to FSize - 1 do\r\n if ItemsEqual(AObject, FItems[I]) then\r\n begin\r\n Result := CheckDuplicate;\r\n Break;\r\n end;\r\n if Result then\r\n begin\r\n if FSize = FCapacity then\r\n AutoGrow;\r\n Result := FSize < FCapacity;\r\n if Result then\r\n begin\r\n if Index < FSize then\r\n MoveArray(FItems, Index, Index + 1, FSize - Index);\r\n FItems[Index] := AObject;\r\n Inc(FSize);\r\n end;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclVector.InsertAll(Index: Integer; const ACollection: IJclCollection): Boolean;\r\nvar\r\n It: IJclIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if (Index < 0) or (Index > FSize) then\r\n raise EJclOutOfBoundsError.Create;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := ACollection.Last;\r\n while It.HasPrevious do\r\n Result := Insert(Index, It.Previous) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclVector.IsEmpty: Boolean;\r\nbegin\r\n Result := FSize = 0;\r\nend;\r\n\r\nfunction TJclVector.Last: IJclIterator;\r\nbegin\r\n Result := TJclVectorIterator.Create(Self, FSize - 1, False, isLast);\r\nend;\r\n\r\nfunction TJclVector.LastIndexOf(AObject: TObject): Integer;\r\nvar\r\n I: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := -1;\r\n for I := FSize - 1 downto 0 do\r\n if ItemsEqual(FItems[I], AObject) then\r\n begin\r\n Result := I;\r\n Break;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclVector.RaiseOutOfBoundsError: TObject;\r\nbegin\r\n raise EJclOutOfBoundsError.Create;\r\nend;\r\n\r\nfunction TJclVector.Remove(AObject: TObject): Boolean;\r\nvar\r\n Extracted: TObject;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := Extract(AObject);\r\n if Result then\r\n begin\r\n Extracted := AObject;\r\n FreeObject(Extracted);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclVector.RemoveAll(const ACollection: IJclCollection): Boolean;\r\nvar\r\n It: IJclIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n Result := Remove(It.Next) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclVector.RetainAll(const ACollection: IJclCollection): Boolean;\r\nvar\r\n I: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n for I := FSize - 1 downto 0 do\r\n if not ACollection.Contains(FItems[I]) then\r\n Delete(I);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclVector.SetCapacity(Value: Integer);\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Value >= FSize then\r\n begin\r\n SetLength(FItems, Value);\r\n inherited SetCapacity(Value);\r\n end\r\n else\r\n raise EJclOutOfBoundsError.Create;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclVector.SetObject(Index: Integer; AObject: TObject);\r\nvar\r\n ReplaceItem: Boolean;\r\n I: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if (Index < 0) or (Index >= FSize) then\r\n raise EJclOutOfBoundsError.Create;\r\n ReplaceItem := FAllowDefaultElements or not ItemsEqual(AObject, nil);\r\n if ReplaceItem then\r\n begin\r\n if FDuplicates <> dupAccept then\r\n for I := 0 to FSize - 1 do\r\n if ItemsEqual(AObject, FItems[I]) then\r\n begin\r\n ReplaceItem := CheckDuplicate;\r\n Break;\r\n end;\r\n if ReplaceItem then\r\n begin\r\n FreeObject(FItems[Index]);\r\n FItems[Index] := AObject;\r\n end;\r\n end;\r\n if not ReplaceItem then\r\n Delete(Index);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclVector.Size: Integer;\r\nbegin\r\n Result := FSize;\r\nend;\r\n\r\nfunction TJclVector.SubList(First, Count: Integer): IJclList;\r\nvar\r\n I: Integer;\r\n Last: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Last := First + Count - 1;\r\n if Last >= FSize then\r\n Last := FSize - 1;\r\n Result := CreateEmptyContainer as IJclList;\r\n for I := First to Last do\r\n Result.Add(FItems[I]);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclVector.CreateEmptyContainer: TJclAbstractContainerBase;\r\nbegin\r\n Result := TJclVector.Create(FSize, False);\r\n AssignPropertiesTo(Result);\r\nend;\r\n\r\n//=== { TJclVectorIterator } ===========================================================\r\n\r\nconstructor TJclVectorIterator.Create(AOwnList: TJclVector; ACursor: Integer; AValid: Boolean; AStart: TItrStart);\r\nbegin\r\n inherited Create(AValid);\r\n FOwnList := AOwnList;\r\n FStart := AStart;\r\n FCursor := ACursor;\r\nend;\r\n\r\nfunction TJclVectorIterator.Add(AObject: TObject): Boolean;\r\nbegin\r\n Result := FOwnList.Add(AObject);\r\nend;\r\n\r\nprocedure TJclVectorIterator.AssignPropertiesTo(Dest: TJclAbstractIterator);\r\nvar\r\n ADest: TJclVectorIterator;\r\nbegin\r\n inherited AssignPropertiesTo(Dest);\r\n if Dest is TJclVectorIterator then\r\n begin\r\n ADest := TJclVectorIterator(Dest);\r\n ADest.FOwnList := FOwnList;\r\n ADest.FCursor := FCursor;\r\n ADest.FStart := FStart;\r\n end;\r\nend;\r\n\r\nfunction TJclVectorIterator.CreateEmptyIterator: TJclAbstractIterator;\r\nbegin\r\n Result := TJclVectorIterator.Create(FOwnList, FCursor, Valid, FStart);\r\nend;\r\n\r\nprocedure TJclVectorIterator.Extract;\r\nbegin\r\n CheckValid;\r\n Valid := False;\r\n FOwnList.ExtractIndex(FCursor);\r\nend;\r\n\r\nfunction TJclVectorIterator.GetObject: TObject;\r\nbegin\r\n CheckValid;\r\n Result := FOwnList.GetObject(FCursor);\r\nend;\r\n\r\nfunction TJclVectorIterator.HasNext: Boolean;\r\nbegin\r\n if Valid then\r\n Result := FCursor < (FOwnList.Size - 1)\r\n else\r\n Result := FCursor < FOwnList.Size;\r\nend;\r\n\r\nfunction TJclVectorIterator.HasPrevious: Boolean;\r\nbegin\r\n if Valid then\r\n Result := FCursor > 0\r\n else\r\n Result := FCursor >= 0;\r\nend;\r\n\r\nfunction TJclVectorIterator.Insert(AObject: TObject): Boolean;\r\nbegin\r\n CheckValid;\r\n Result := FOwnList.Insert(FCursor, AObject);\r\nend;\r\n\r\nfunction TJclVectorIterator.IteratorEquals(const AIterator: IJclIterator): Boolean;\r\nvar\r\n Obj: TObject;\r\n ItrObj: TJclVectorIterator;\r\nbegin\r\n Result := False;\r\n if AIterator = nil then\r\n Exit;\r\n Obj := AIterator.GetIteratorReference;\r\n if Obj is TJclVectorIterator then\r\n begin\r\n ItrObj := TJclVectorIterator(Obj);\r\n Result := (FOwnList = ItrObj.FOwnList) and (FCursor = ItrObj.FCursor) and (Valid = ItrObj.Valid);\r\n end;\r\nend;\r\n\r\n{$IFDEF SUPPORTS_FOR_IN}\r\nfunction TJclVectorIterator.MoveNext: Boolean;\r\nbegin\r\n if Valid then\r\n Inc(FCursor)\r\n else\r\n Valid := True;\r\n Result := FCursor < FOwnList.Size;\r\nend;\r\n{$ENDIF SUPPORTS_FOR_IN}\r\n\r\nfunction TJclVectorIterator.Next: TObject;\r\nbegin\r\n if Valid then\r\n Inc(FCursor)\r\n else\r\n Valid := True;\r\n Result := FOwnList.GetObject(FCursor);\r\nend;\r\n\r\nfunction TJclVectorIterator.NextIndex: Integer;\r\nbegin\r\n if Valid then\r\n Result := FCursor + 1\r\n else\r\n Result := FCursor;\r\nend;\r\n\r\nfunction TJclVectorIterator.Previous: TObject;\r\nbegin\r\n if Valid then\r\n Dec(FCursor)\r\n else\r\n Valid := True;\r\n Result := FOwnList.GetObject(FCursor);\r\nend;\r\n\r\nfunction TJclVectorIterator.PreviousIndex: Integer;\r\nbegin\r\n if Valid then\r\n Result := FCursor - 1\r\n else\r\n Result := FCursor;\r\nend;\r\n\r\nprocedure TJclVectorIterator.Remove;\r\nbegin\r\n CheckValid;\r\n Valid := False;\r\n FOwnList.Delete(FCursor);\r\nend;\r\n\r\nprocedure TJclVectorIterator.Reset;\r\nbegin\r\n Valid := False;\r\n case FStart of\r\n isFirst:\r\n FCursor := 0;\r\n isLast:\r\n FCursor := FOwnList.Size - 1;\r\n end;\r\nend;\r\n\r\nprocedure TJclVectorIterator.SetObject(AObject: TObject);\r\nbegin\r\n CheckValid;\r\n FOwnList.SetObject(FCursor, AObject);\r\nend;\r\n\r\n\r\n{$IFDEF SUPPORTS_GENERICS}\r\n//DOM-IGNORE-BEGIN\r\n\r\n//=== { TJclVector } ======================================================\r\n\r\nconstructor TJclVector.Create(ACapacity: Integer; AOwnsItems: Boolean);\r\nbegin\r\n inherited Create(AOwnsItems);\r\n SetCapacity(ACapacity);\r\nend;\r\n\r\nconstructor TJclVector.Create(const ACollection: IJclCollection; AOwnsItems: Boolean);\r\nbegin\r\n inherited Create(AOwnsItems);\r\n if ACollection = nil then\r\n raise EJclNoCollectionError.Create;\r\n SetCapacity(ACollection.Size);\r\n AddAll(ACollection);\r\nend;\r\n\r\ndestructor TJclVector.Destroy;\r\nbegin\r\n FReadOnly := False;\r\n Clear;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJclVector.Add(const AItem: T): Boolean;\r\nvar\r\n Index: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := FAllowDefaultElements or not ItemsEqual(AItem, Default(T));\r\n if Result then\r\n begin\r\n if FDuplicates <> dupAccept then\r\n for Index := 0 to FSize - 1 do\r\n if ItemsEqual(AItem, FItems[Index]) then\r\n begin\r\n Result := CheckDuplicate;\r\n Break;\r\n end;\r\n if Result then\r\n begin\r\n if FSize = FCapacity then\r\n AutoGrow;\r\n Result := FSize < FCapacity;\r\n if Result then\r\n begin\r\n FItems[FSize] := AItem;\r\n Inc(FSize);\r\n end;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclVector.AddAll(const ACollection: IJclCollection): Boolean;\r\nvar\r\n It: IJclIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n Result := Add(It.Next) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclVector.AssignDataTo(Dest: TJclAbstractContainerBase);\r\nvar\r\n ADest: TJclVector;\r\n ACollection: IJclCollection;\r\nbegin\r\n inherited AssignDataTo(Dest);\r\n if Dest is TJclVector then\r\n begin\r\n ADest := TJclVector(Dest);\r\n ADest.Clear;\r\n ADest.AddAll(Self);\r\n end\r\n else\r\n if Supports(IInterface(Dest), IJclCollection, ACollection) then\r\n begin\r\n ACollection.Clear;\r\n ACollection.AddAll(Self);\r\n end;\r\nend;\r\n\r\nprocedure TJclVector.Clear;\r\nvar\r\n I: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n for I := 0 to FSize - 1 do\r\n FreeItem(FItems[I]);\r\n FSize := 0;\r\n AutoPack;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclVector.CollectionEquals(const ACollection: IJclCollection): Boolean;\r\nvar\r\n I: Integer;\r\n It: IJclIterator;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n if FSize <> ACollection.Size then\r\n Exit;\r\n It := ACollection.First;\r\n for I := 0 to FSize - 1 do\r\n if not ItemsEqual(FItems[I], It.Next) then\r\n Exit;\r\n Result := True;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclVector.Contains(const AItem: T): Boolean;\r\nvar\r\n I: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n for I := 0 to FSize - 1 do\r\n if ItemsEqual(FItems[I], AItem) then\r\n begin\r\n Result := True;\r\n Break;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclVector.ContainsAll(const ACollection: IJclCollection): Boolean;\r\nvar\r\n It: IJclIterator;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := True;\r\n if ACollection = nil then\r\n Exit;\r\n It := ACollection.First;\r\n while Result and It.HasNext do\r\n Result := Contains(It.Next);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclVector.Delete(Index: Integer): T;\r\nvar\r\n Extracted: T;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Extracted := ExtractIndex(Index);\r\n Result := FreeItem(Extracted);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclVector.Extract(const AItem: T): Boolean;\r\nvar\r\n I: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n for I := FSize - 1 downto 0 do\r\n if ItemsEqual(FItems[I], AItem) then\r\n begin\r\n if I < (FSize - 1) then\r\n MoveArray(FItems, I + 1, I, FSize - 1 - I)\r\n else\r\n FItems[I] := Default(T);\r\n Dec(FSize);\r\n Result := True;\r\n if FRemoveSingleElement then\r\n Break;\r\n end;\r\n AutoPack;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclVector.ExtractAll(const ACollection: IJclCollection): Boolean;\r\nvar\r\n It: IJclIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n Result := Extract(It.Next) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclVector.ExtractIndex(Index: Integer): T;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if (Index >= 0) and (Index < FSize) then\r\n begin\r\n Result := FItems[Index];\r\n if Index < (FSize - 1) then\r\n MoveArray(FItems, Index + 1, Index, FSize - 1 - Index)\r\n else\r\n FItems[Index] := Default(T);\r\n Dec(FSize);\r\n AutoPack;\r\n end\r\n else\r\n Result := RaiseOutOfBoundsError;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclVector.First: IJclIterator;\r\nbegin\r\n Result := TVectorIterator.Create(Self, 0, False, isFirst);\r\nend;\r\n\r\n{$IFDEF SUPPORTS_FOR_IN}\r\nfunction TJclVector.GetEnumerator: IJclIterator;\r\nbegin\r\n Result := TVectorIterator.Create(Self, 0, False, isFirst);\r\nend;\r\n{$ENDIF SUPPORTS_FOR_IN}\r\n\r\nfunction TJclVector.GetItem(Index: Integer): T;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := Default(T);\r\n if (Index >= 0) or (Index < FSize) then\r\n Result := FItems[Index]\r\n else\r\n if not FReturnDefaultElements then\r\n raise EJclNoSuchElementError.Create(IntToStr(Index));\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclVector.IndexOf(const AItem: T): Integer;\r\nvar\r\n I: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := -1;\r\n for I := 0 to FSize - 1 do\r\n if ItemsEqual(FItems[I], AItem) then\r\n begin\r\n Result := I;\r\n Break;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclVector.Insert(Index: Integer; const AItem: T): Boolean;\r\nvar\r\n I: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := FAllowDefaultElements or not ItemsEqual(AItem, Default(T));\r\n if (Index < 0) or (Index > FSize) then\r\n raise EJclOutOfBoundsError.Create;\r\n if Result then\r\n begin\r\n if FDuplicates <> dupAccept then\r\n for I := 0 to FSize - 1 do\r\n if ItemsEqual(AItem, FItems[I]) then\r\n begin\r\n Result := CheckDuplicate;\r\n Break;\r\n end;\r\n if Result then\r\n begin\r\n if FSize = FCapacity then\r\n AutoGrow;\r\n Result := FSize < FCapacity;\r\n if Result then\r\n begin\r\n if Index < FSize then\r\n MoveArray(FItems, Index, Index + 1, FSize - Index);\r\n FItems[Index] := AItem;\r\n Inc(FSize);\r\n end;\r\n end;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclVector.InsertAll(Index: Integer; const ACollection: IJclCollection): Boolean;\r\nvar\r\n It: IJclIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if (Index < 0) or (Index > FSize) then\r\n raise EJclOutOfBoundsError.Create;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := ACollection.Last;\r\n while It.HasPrevious do\r\n Result := Insert(Index, It.Previous) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclVector.IsEmpty: Boolean;\r\nbegin\r\n Result := FSize = 0;\r\nend;\r\n\r\nfunction TJclVector.Last: IJclIterator;\r\nbegin\r\n Result := TVectorIterator.Create(Self, FSize - 1, False, isLast);\r\nend;\r\n\r\nfunction TJclVector.LastIndexOf(const AItem: T): Integer;\r\nvar\r\n I: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := -1;\r\n for I := FSize - 1 downto 0 do\r\n if ItemsEqual(FItems[I], AItem) then\r\n begin\r\n Result := I;\r\n Break;\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclVector.RaiseOutOfBoundsError: T;\r\nbegin\r\n raise EJclOutOfBoundsError.Create;\r\nend;\r\n\r\nfunction TJclVector.Remove(const AItem: T): Boolean;\r\nvar\r\n Extracted: T;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := Extract(AItem);\r\n if Result then\r\n begin\r\n Extracted := AItem;\r\n FreeItem(Extracted);\r\n end;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclVector.RemoveAll(const ACollection: IJclCollection): Boolean;\r\nvar\r\n It: IJclIterator;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n It := ACollection.First;\r\n while It.HasNext do\r\n Result := Remove(It.Next) and Result;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclVector.RetainAll(const ACollection: IJclCollection): Boolean;\r\nvar\r\n I: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Result := False;\r\n if ACollection = nil then\r\n Exit;\r\n Result := True;\r\n for I := FSize - 1 downto 0 do\r\n if not ACollection.Contains(FItems[I]) then\r\n Delete(I);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclVector.SetCapacity(Value: Integer);\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if Value >= FSize then\r\n begin\r\n SetLength(FItems, Value);\r\n inherited SetCapacity(Value);\r\n end\r\n else\r\n raise EJclOutOfBoundsError.Create;\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclVector.SetItem(Index: Integer; const AItem: T);\r\nvar\r\n ReplaceItem: Boolean;\r\n I: Integer;\r\nbegin\r\n if ReadOnly then\r\n raise EJclReadOnlyError.Create;\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginWrite;\r\n try\r\n {$ENDIF THREADSAFE}\r\n if (Index < 0) or (Index >= FSize) then\r\n raise EJclOutOfBoundsError.Create;\r\n ReplaceItem := FAllowDefaultElements or not ItemsEqual(AItem, Default(T));\r\n if ReplaceItem then\r\n begin\r\n if FDuplicates <> dupAccept then\r\n for I := 0 to FSize - 1 do\r\n if ItemsEqual(AItem, FItems[I]) then\r\n begin\r\n ReplaceItem := CheckDuplicate;\r\n Break;\r\n end;\r\n if ReplaceItem then\r\n begin\r\n FreeItem(FItems[Index]);\r\n FItems[Index] := AItem;\r\n end;\r\n end;\r\n if not ReplaceItem then\r\n Delete(Index);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndWrite;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nfunction TJclVector.Size: Integer;\r\nbegin\r\n Result := FSize;\r\nend;\r\n\r\nfunction TJclVector.SubList(First, Count: Integer): IJclList;\r\nvar\r\n I: Integer;\r\n Last: Integer;\r\nbegin\r\n {$IFDEF THREADSAFE}\r\n if FThreadSafe then\r\n SyncReaderWriter.BeginRead;\r\n try\r\n {$ENDIF THREADSAFE}\r\n Last := First + Count - 1;\r\n if Last >= FSize then\r\n Last := FSize - 1;\r\n Result := CreateEmptyContainer as IJclList;\r\n for I := First to Last do\r\n Result.Add(FItems[I]);\r\n {$IFDEF THREADSAFE}\r\n finally\r\n if FThreadSafe then\r\n SyncReaderWriter.EndRead;\r\n end;\r\n {$ENDIF THREADSAFE}\r\nend;\r\n\r\nprocedure TJclVector.MoveArray(var List: TDynArray; FromIndex, ToIndex, Count: SizeInt);\r\nvar\r\n I: SizeInt;\r\nbegin\r\n if FromIndex < ToIndex then\r\n begin\r\n for I := Count - 1 downto 0 do\r\n List[ToIndex + I] := List[FromIndex + I];\r\n\r\n if (ToIndex - FromIndex) < Count then\r\n // overlapped source and target\r\n for I := 0 to ToIndex - FromIndex - 1 do\r\n List[FromIndex + I] := Default(T)\r\n else\r\n // independant\r\n for I := 0 to Count - 1 do\r\n List[FromIndex + I] := Default(T);\r\n end\r\n else\r\n begin\r\n for I := 0 to Count - 1 do\r\n List[ToIndex + I] := List[FromIndex + I];\r\n\r\n if (FromIndex - ToIndex) < Count then\r\n // overlapped source and target\r\n for I := Count - FromIndex + ToIndex to Count - 1 do\r\n List[FromIndex + I] := Default(T)\r\n else\r\n // independant\r\n for I := 0 to Count - 1 do\r\n List[FromIndex + I] := Default(T);\r\n end; \r\nend;\r\n\r\n//=== { TJclVectorIterator } ===========================================================\r\n\r\nconstructor TJclVectorIterator.Create(AOwnList: IJclList; ACursor: Integer; AValid: Boolean; AStart: TItrStart);\r\nbegin\r\n inherited Create(AValid);\r\n FOwnList := AOwnList;\r\n FStart := AStart;\r\n FCursor := ACursor;\r\nend;\r\n\r\nfunction TJclVectorIterator.Add(const AItem: T): Boolean;\r\nbegin\r\n Result := FOwnList.Add(AItem);\r\nend;\r\n\r\nprocedure TJclVectorIterator.AssignPropertiesTo(Dest: TJclAbstractIterator);\r\nvar\r\n ADest: TJclVectorIterator;\r\nbegin\r\n inherited AssignPropertiesTo(Dest);\r\n if Dest is TJclVectorIterator then\r\n begin\r\n ADest := TJclVectorIterator(Dest);\r\n ADest.FOwnList := FOwnList;\r\n ADest.FCursor := FCursor;\r\n ADest.FStart := FStart;\r\n end;\r\nend;\r\n\r\nfunction TJclVectorIterator.CreateEmptyIterator: TJclAbstractIterator;\r\nbegin\r\n Result := TJclVectorIterator.Create(FOwnList, FCursor, Valid, FStart);\r\nend;\r\n\r\nprocedure TJclVectorIterator.Extract;\r\nbegin\r\n CheckValid;\r\n Valid := False;\r\n FOwnList.ExtractIndex(FCursor);\r\nend;\r\n\r\nfunction TJclVectorIterator.GetItem: T;\r\nbegin\r\n CheckValid;\r\n Result := FOwnList.GetItem(FCursor);\r\nend;\r\n\r\nfunction TJclVectorIterator.HasNext: Boolean;\r\nbegin\r\n if Valid then\r\n Result := FCursor < (FOwnList.Size - 1)\r\n else\r\n Result := FCursor < FOwnList.Size;\r\nend;\r\n\r\nfunction TJclVectorIterator.HasPrevious: Boolean;\r\nbegin\r\n if Valid then\r\n Result := FCursor > 0\r\n else\r\n Result := FCursor >= 0;\r\nend;\r\n\r\nfunction TJclVectorIterator.Insert(const AItem: T): Boolean;\r\nbegin\r\n CheckValid;\r\n Result := FOwnList.Insert(FCursor, AItem);\r\nend;\r\n\r\nfunction TJclVectorIterator.IteratorEquals(const AIterator: IJclIterator): Boolean;\r\nvar\r\n Obj: TObject;\r\n ItrObj: TJclVectorIterator;\r\nbegin\r\n Result := False;\r\n if AIterator = nil then\r\n Exit;\r\n Obj := AIterator.GetIteratorReference;\r\n if Obj is TJclVectorIterator then\r\n begin\r\n ItrObj := TJclVectorIterator(Obj);\r\n Result := (FOwnList = ItrObj.FOwnList) and (FCursor = ItrObj.FCursor) and (Valid = ItrObj.Valid);\r\n end;\r\nend;\r\n\r\n{$IFDEF SUPPORTS_FOR_IN}\r\nfunction TJclVectorIterator.MoveNext: Boolean;\r\nbegin\r\n if Valid then\r\n Inc(FCursor)\r\n else\r\n Valid := True;\r\n Result := FCursor < FOwnList.Size;\r\nend;\r\n{$ENDIF SUPPORTS_FOR_IN}\r\n\r\nfunction TJclVectorIterator.Next: T;\r\nbegin\r\n if Valid then\r\n Inc(FCursor)\r\n else\r\n Valid := True;\r\n Result := FOwnList.GetItem(FCursor);\r\nend;\r\n\r\nfunction TJclVectorIterator.NextIndex: Integer;\r\nbegin\r\n if Valid then\r\n Result := FCursor + 1\r\n else\r\n Result := FCursor;\r\nend;\r\n\r\nfunction TJclVectorIterator.Previous: T;\r\nbegin\r\n if Valid then\r\n Dec(FCursor)\r\n else\r\n Valid := True;\r\n Result := FOwnList.GetItem(FCursor);\r\nend;\r\n\r\nfunction TJclVectorIterator.PreviousIndex: Integer;\r\nbegin\r\n if Valid then\r\n Result := FCursor - 1\r\n else\r\n Result := FCursor;\r\nend;\r\n\r\nprocedure TJclVectorIterator.Remove;\r\nbegin\r\n CheckValid;\r\n Valid := False;\r\n FOwnList.Delete(FCursor);\r\nend;\r\n\r\nprocedure TJclVectorIterator.Reset;\r\nbegin\r\n Valid := False;\r\n case FStart of\r\n isFirst:\r\n FCursor := 0;\r\n isLast:\r\n FCursor := FOwnList.Size - 1;\r\n end;\r\nend;\r\n\r\nprocedure TJclVectorIterator.SetItem(const AItem: T);\r\nbegin\r\n CheckValid;\r\n FOwnList.SetItem(FCursor, AItem);\r\nend;\r\n\r\n//=== { TJclVectorE } =====================================================\r\n\r\nconstructor TJclVectorE.Create(const AEqualityComparer: IJclEqualityComparer; ACapacity: Integer;\r\n AOwnsItems: Boolean);\r\nbegin\r\n inherited Create(ACapacity, AOwnsItems);\r\n FEqualityComparer := AEqualityComparer;\r\nend;\r\n\r\nprocedure TJclVectorE.AssignPropertiesTo(Dest: TJclAbstractContainerBase);\r\nbegin\r\n inherited AssignPropertiesTo(Dest);\r\n if Dest is TJclVectorE then\r\n TJclVectorE(Dest).FEqualityComparer := FEqualityComparer;\r\nend;\r\n\r\nfunction TJclVectorE.CreateEmptyContainer: TJclAbstractContainerBase;\r\nbegin\r\n Result := TJclVectorE.Create(EqualityComparer, FSize, False);\r\n AssignPropertiesTo(Result);\r\nend;\r\n\r\nfunction TJclVectorE.ItemsEqual(const A, B: T): Boolean;\r\nbegin\r\n if EqualityComparer <> nil then\r\n Result := EqualityComparer.ItemsEqual(A, B)\r\n else\r\n Result := inherited ItemsEqual(A, B);\r\nend;\r\n\r\n//=== { TJclVectorF } =====================================================\r\n\r\nconstructor TJclVectorF.Create(const AEqualityCompare: TEqualityCompare; ACapacity: Integer;\r\n AOwnsItems: Boolean);\r\nbegin\r\n inherited Create(ACapacity, AOwnsItems);\r\n SetEqualityCompare(AEqualityCompare);\r\nend;\r\n\r\nfunction TJclVectorF.CreateEmptyContainer: TJclAbstractContainerBase;\r\nbegin\r\n Result := TJclVectorF.Create(EqualityCompare, FSize, False);\r\n AssignPropertiesTo(Result);\r\nend;\r\n\r\n//=== { TJclVectorI } =====================================================\r\n\r\nfunction TJclVectorI.CreateEmptyContainer: TJclAbstractContainerBase;\r\nbegin\r\n Result := TJclVectorI.Create(FSize, False);\r\n AssignPropertiesTo(Result);\r\nend;\r\n\r\nfunction TJclVectorI.ItemsEqual(const A, B: T): Boolean;\r\nbegin\r\n if Assigned(FEqualityCompare) then\r\n Result := FEqualityCompare(A, B)\r\n else\r\n if Assigned(FCompare) then\r\n Result := FCompare(A, B) = 0\r\n else\r\n Result := A.Equals(B);\r\nend;\r\n\r\n//DOM-IGNORE-END\r\n{$ENDIF SUPPORTS_GENERICS}\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n\r\n" }, { "path": "External/Jedi/Jcl/source/common/JclWideStrings.pas", "content": "{**************************************************************************************************}\r\n{ }\r\n{ Project JEDI Code Library (JCL) }\r\n{ }\r\n{ The contents of this file are subject to the Mozilla Public License Version 1.1 (the \"License\"); }\r\n{ you may not use this file except in compliance with the License. You may obtain a copy of the }\r\n{ License at http://www.mozilla.org/MPL/ }\r\n{ }\r\n{ Software distributed under the License is distributed on an \"AS IS\" basis, WITHOUT WARRANTY OF }\r\n{ ANY KIND, either express or implied. See the License for the specific language governing rights }\r\n{ and limitations under the License. }\r\n{ }\r\n{ The Original Code is WStrUtils.PAS, released on 2004-01-25. }\r\n{ }\r\n{ The Initial Developers of the Original Code are: }\r\n{ - Andreas Hausladen }\r\n{ - Mike Lischke (WideQuotedStr & WideExtractQuotedStr from Unicode.pas) }\r\n{ Portions created by Andreas Hausladen are Copyright (C) of Andreas Hausladen. }\r\n{ All rights reserved. }\r\n{ Portions created by Mike Lischke are Copyright (C) of Mike Lischke. All rights reserved. }\r\n{ }\r\n{ Contributor(s): }\r\n{ Robert Marquardt (marquardt) }\r\n{ Robert Rossmair (rrossmair) }\r\n{ ZENsan }\r\n{ Florent Ouchet (outchy) }\r\n{ Kiriakos Vlahos }\r\n{ }\r\n{**************************************************************************************************}\r\n{ }\r\n{ This is a lightweight Unicode unit. For more features use JclUnicode. }\r\n{ }\r\n{ }\r\n{**************************************************************************************************}\r\n{ }\r\n{ Last modified: $Date:: 2012-03-04 19:39:47 +0100 (dim. 04 mars 2012) $ }\r\n{ Revision: $Rev:: 3759 $ }\r\n{ Author: $Author:: outchy $ }\r\n{ }\r\n{**************************************************************************************************}\r\n\r\nunit JclWideStrings;\r\n\r\n{$I jcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n {$IFDEF HAS_UNITSCOPE}\r\n System.Classes, System.SysUtils,\r\n {$ELSE ~HAS_UNITSCOPE}\r\n Classes, SysUtils,\r\n {$ENDIF ~HAS_UNITSCOPE}\r\n JclBase;\r\n\r\n// Exceptions\r\ntype\r\n EJclWideStringError = class(EJclError);\r\n\r\nconst\r\n // definitions of often used characters:\r\n // Note: Use them only for tests of a certain character not to determine character\r\n // classes (like white spaces) as in Unicode are often many code points defined\r\n // being in a certain class. Hence your best option is to use the various\r\n // UnicodeIs* functions.\r\n WideNull = WideChar(#0);\r\n WideTabulator = WideChar(#9);\r\n WideSpace = WideChar(#32);\r\n\r\n // logical line breaks\r\n WideLF = WideChar(#10);\r\n WideLineFeed = WideChar(#10);\r\n WideVerticalTab = WideChar(#11);\r\n WideFormFeed = WideChar(#12);\r\n WideCR = WideChar(#13);\r\n WideCarriageReturn = WideChar(#13);\r\n WideCRLF = WideString(#13#10);\r\n WideLineSeparator = WideChar($2028);\r\n WideParagraphSeparator = WideChar($2029);\r\n\r\n {$IFDEF MSWINDOWS}\r\n WideLineBreak = WideCRLF;\r\n {$ENDIF MSWINDOWS}\r\n {$IFDEF UNIX}\r\n WideLineBreak = WideLineFeed;\r\n {$ENDIF UNIX}\r\n\r\n BOM_LSB_FIRST = WideChar($FEFF);\r\n BOM_MSB_FIRST = WideChar($FFFE);\r\n\r\ntype\r\n {$IFDEF SUPPORTS_UNICODE}\r\n TJclWideStrings = {$IFDEF HAS_UNITSCOPE}System.{$ENDIF}Classes.TStrings;\r\n TJclWideStringList = {$IFDEF HAS_UNITSCOPE}System.{$ENDIF}Classes.TStringList;\r\n {$ELSE ~SUPPORTS_UNICODE}\r\n\r\n TWideFileOptionsType =\r\n (\r\n foAnsiFile, // loads/writes an ANSI file\r\n foUnicodeLB // reads/writes BOM_LSB_FIRST/BOM_MSB_FIRST\r\n );\r\n TWideFileOptions = set of TWideFileOptionsType;\r\n\r\n TSearchFlag = (\r\n sfCaseSensitive, // match letter case\r\n sfIgnoreNonSpacing, // ignore non-spacing characters in search\r\n sfSpaceCompress, // handle several consecutive white spaces as one white space\r\n // (this applies to the pattern as well as the search text)\r\n sfWholeWordOnly // match only text at end/start and/or surrounded by white spaces\r\n );\r\n TSearchFlags = set of TSearchFlag;\r\n\r\n TJclWideStrings = class;\r\n TJclWideStringList = class;\r\n\r\n TJclWideStringListSortCompare = function(List: TJclWideStringList; Index1, Index2: Integer): Integer;\r\n\r\n TJclWideStrings = class(TPersistent)\r\n private\r\n FDelimiter: WideChar;\r\n FQuoteChar: WideChar;\r\n FNameValueSeparator: WideChar;\r\n FLineSeparator: WideString;\r\n FUpdateCount: Integer;\r\n function GetCommaText: WideString;\r\n function GetDelimitedText: WideString;\r\n function GetName(Index: Integer): WideString;\r\n function GetValue(const Name: WideString): WideString;\r\n procedure ReadData(Reader: TReader);\r\n procedure SetCommaText(const Value: WideString);\r\n procedure SetDelimitedText(const Value: WideString);\r\n procedure SetValue(const Name, Value: WideString);\r\n procedure WriteData(Writer: TWriter);\r\n function GetValueFromIndex(Index: Integer): WideString;\r\n procedure SetValueFromIndex(Index: Integer; const Value: WideString);\r\n protected\r\n procedure DefineProperties(Filer: TFiler); override;\r\n function ExtractName(const S: WideString): WideString;\r\n function GetP(Index: Integer): PWideString; virtual; abstract;\r\n function Get(Index: Integer): WideString;\r\n function GetCapacity: Integer; virtual;\r\n function GetCount: Integer; virtual; abstract;\r\n function GetObject(Index: Integer): TObject; virtual;\r\n function GetTextStr: WideString; virtual;\r\n procedure Put(Index: Integer; const S: WideString); virtual; abstract;\r\n procedure PutObject(Index: Integer; AObject: TObject); virtual; abstract;\r\n procedure SetCapacity(NewCapacity: Integer); virtual;\r\n procedure SetTextStr(const Value: WideString); virtual;\r\n procedure SetUpdateState(Updating: Boolean); virtual;\r\n property UpdateCount: Integer read FUpdateCount;\r\n function CompareStrings(const S1, S2: WideString): Integer; virtual;\r\n procedure AssignTo(Dest: TPersistent); override;\r\n public\r\n constructor Create;\r\n function Add(const S: WideString): Integer; virtual;\r\n function AddObject(const S: WideString; AObject: TObject): Integer; virtual;\r\n procedure Append(const S: WideString);\r\n procedure AddStrings(Strings: TJclWideStrings); overload; virtual;\r\n procedure AddStrings(Strings: TStrings); overload; virtual;\r\n procedure Assign(Source: TPersistent); override;\r\n function CreateAnsiStringList: TStrings;\r\n procedure AddStringsTo(Dest: TStrings); virtual;\r\n procedure BeginUpdate;\r\n procedure Clear; virtual; abstract;\r\n procedure Delete(Index: Integer); virtual; abstract;\r\n procedure EndUpdate;\r\n function Equals(Strings: TJclWideStrings): Boolean; {$IFDEF RTL200_UP}reintroduce; {$ENDIF RTL200_UP}overload;\r\n function Equals(Strings: TStrings): Boolean; {$IFDEF RTL200_UP}reintroduce; {$ENDIF RTL200_UP}overload;\r\n procedure Exchange(Index1, Index2: Integer); virtual;\r\n function GetText: PWideChar; virtual;\r\n function IndexOf(const S: WideString): Integer; virtual;\r\n function IndexOfName(const Name: WideString): Integer; virtual;\r\n function IndexOfObject(AObject: TObject): Integer; virtual;\r\n procedure Insert(Index: Integer; const S: WideString); virtual;\r\n procedure InsertObject(Index: Integer; const S: WideString;\r\n AObject: TObject); virtual;\r\n procedure LoadFromFile(const FileName: TFileName;\r\n WideFileOptions: TWideFileOptions = []); virtual;\r\n procedure LoadFromStream(Stream: TStream;\r\n WideFileOptions: TWideFileOptions = []); virtual;\r\n procedure Move(CurIndex, NewIndex: Integer); virtual;\r\n procedure SaveToFile(const FileName: TFileName;\r\n WideFileOptions: TWideFileOptions = []); virtual;\r\n procedure SaveToStream(Stream: TStream;\r\n WideFileOptions: TWideFileOptions = []); virtual;\r\n procedure SetText(Text: PWideChar); virtual;\r\n function GetDelimitedTextEx(ADelimiter, AQuoteChar: WideChar): WideString;\r\n procedure SetDelimitedTextEx(ADelimiter, AQuoteChar: WideChar; const Value: WideString);\r\n property Capacity: Integer read GetCapacity write SetCapacity;\r\n property CommaText: WideString read GetCommaText write SetCommaText;\r\n property Count: Integer read GetCount;\r\n property Delimiter: WideChar read FDelimiter write FDelimiter;\r\n property DelimitedText: WideString read GetDelimitedText write SetDelimitedText;\r\n property Names[Index: Integer]: WideString read GetName;\r\n property Objects[Index: Integer]: TObject read GetObject write PutObject;\r\n property QuoteChar: WideChar read FQuoteChar write FQuoteChar;\r\n property Values[const Name: WideString]: WideString read GetValue write SetValue;\r\n property ValueFromIndex[Index: Integer]: WideString read GetValueFromIndex write SetValueFromIndex;\r\n property NameValueSeparator: WideChar read FNameValueSeparator write FNameValueSeparator;\r\n property LineSeparator: WideString read FLineSeparator write FLineSeparator;\r\n property PStrings[Index: Integer]: PWideString read GetP;\r\n property Strings[Index: Integer]: WideString read Get write Put; default;\r\n property Text: WideString read GetTextStr write SetTextStr;\r\n end;\r\n\r\n // do not replace by JclUnicode.TWideStringList (speed and size issue)\r\n PWStringItem = ^TWStringItem;\r\n TWStringItem = record\r\n FString: WideString;\r\n FObject: TObject;\r\n end;\r\n\r\n TJclWideStringList = class(TJclWideStrings)\r\n private\r\n FList: TList;\r\n FSorted: Boolean;\r\n FDuplicates: TDuplicates;\r\n FCaseSensitive: Boolean;\r\n FOnChange: TNotifyEvent;\r\n FOnChanging: TNotifyEvent;\r\n procedure SetSorted(Value: Boolean);\r\n procedure SetCaseSensitive(const Value: Boolean);\r\n protected\r\n function GetItem(Index: Integer): PWStringItem;\r\n procedure Changed; virtual;\r\n procedure Changing; virtual;\r\n function GetP(Index: Integer): PWideString; override;\r\n function GetCapacity: Integer; override;\r\n function GetCount: Integer; override;\r\n function GetObject(Index: Integer): TObject; override;\r\n procedure Put(Index: Integer; const Value: WideString); override;\r\n procedure PutObject(Index: Integer; AObject: TObject); override;\r\n procedure SetCapacity(NewCapacity: Integer); override;\r\n procedure SetUpdateState(Updating: Boolean); override;\r\n function CompareStrings(const S1, S2: WideString): Integer; override;\r\n public\r\n constructor Create;\r\n destructor Destroy; override;\r\n function AddObject(const S: WideString; AObject: TObject): Integer; override;\r\n procedure Clear; override;\r\n procedure Delete(Index: Integer); override;\r\n procedure Exchange(Index1, Index2: Integer); override;\r\n function Find(const S: WideString; var Index: Integer): Boolean; virtual;\r\n // Find() also works with unsorted lists\r\n function IndexOf(const S: WideString): Integer; override;\r\n procedure InsertObject(Index: Integer; const S: WideString;\r\n AObject: TObject); override;\r\n procedure Sort; virtual;\r\n procedure CustomSort(Compare: TJclWideStringListSortCompare); virtual;\r\n property Duplicates: TDuplicates read FDuplicates write FDuplicates;\r\n property Sorted: Boolean read FSorted write SetSorted;\r\n property CaseSensitive: Boolean read FCaseSensitive write SetCaseSensitive;\r\n property OnChange: TNotifyEvent read FOnChange write FOnChange;\r\n property OnChanging: TNotifyEvent read FOnChanging write FOnChanging;\r\n end;\r\n {$ENDIF ~SUPPORTS_UNICODE}\r\n\r\n TWideStringList = TJclWideStringList;\r\n TWideStrings = TJclWideStrings;\r\n\r\n TJclUnicodeStringList = TJclWideStringList;\r\n TJclUnicodeStrings = TJclWideStrings;\r\n\r\n // OF deprecated?\r\n TWStringList = TJclWideStringList;\r\n TWStrings = TJclWideStrings;\r\n\r\n// WideChar functions\r\nfunction CharToWideChar(Ch: AnsiChar): WideChar;\r\nfunction WideCharToChar(Ch: WideChar): AnsiChar;\r\n\r\n// PWideChar functions\r\nprocedure MoveWideChar(const Source; var Dest; Count: SizeInt);\r\n\r\nfunction StrLenW(const Str: PWideChar): SizeInt;\r\nfunction StrEndW(const Str: PWideChar): PWideChar;\r\nfunction StrMoveW(Dest: PWideChar; const Source: PWideChar; Count: SizeInt): PWideChar;\r\nfunction StrCopyW(Dest: PWideChar; const Source: PWideChar): PWideChar;\r\nfunction StrECopyW(Dest: PWideChar; const Source: PWideChar): PWideChar;\r\nfunction StrLCopyW(Dest: PWideChar; const Source: PWideChar; MaxLen: SizeInt): PWideChar;\r\nfunction StrPCopyWW(Dest: PWideChar; const Source: WideString): PWideChar;\r\nfunction StrPCopyW(Dest: PWideChar; const Source: AnsiString): PWideChar;\r\nfunction StrPLCopyWW(Dest: PWideChar; const Source: WideString; MaxLen: SizeInt): PWideChar;\r\nfunction StrPLCopyW(Dest: PWideChar; const Source: AnsiString; MaxLen: SizeInt): PWideChar;\r\nfunction StrCatW(Dest: PWideChar; const Source: PWideChar): PWideChar;\r\nfunction StrLCatW(Dest: PWideChar; const Source: PWideChar; MaxLen: SizeInt): PWideChar;\r\nfunction StrCompW(const Str1, Str2: PWideChar): SizeInt;\r\nfunction StrICompW(const Str1, Str2: PWideChar): SizeInt;\r\nfunction StrLCompW(const Str1, Str2: PWideChar; MaxLen: SizeInt): SizeInt;\r\nfunction StrLICompW(const Str1, Str2: PWideChar; MaxLen: SizeInt): SizeInt;\r\nfunction StrLICompW2(const Str1, Str2: PWideChar; MaxLen: SizeInt): SizeInt;\r\nfunction StrNScanW(const Str1, Str2: PWideChar): SizeInt;\r\nfunction StrRNScanW(const Str1, Str2: PWideChar): SizeInt;\r\nfunction StrScanW(const Str: PWideChar; Ch: WideChar): PWideChar; overload;\r\nfunction StrScanW(Str: PWideChar; Chr: WideChar; StrLen: SizeInt): PWideChar; overload;\r\nfunction StrRScanW(const Str: PWideChar; Chr: WideChar): PWideChar;\r\nfunction StrPosW(const Str, SubStr: PWideChar): PWideChar;\r\nfunction StrAllocW(WideSize: SizeInt): PWideChar;\r\nfunction StrBufSizeW(const Str: PWideChar): SizeInt;\r\nfunction StrNewW(const Str: PWideChar): PWideChar; overload;\r\nfunction StrNewW(const Str: WideString): PWideChar; overload;\r\nprocedure StrDisposeW(Str: PWideChar);\r\nprocedure StrDisposeAndNilW(var Str: PWideChar);\r\nprocedure StrSwapByteOrder(Str: PWideChar);\r\n\r\n// WideString functions\r\nfunction WidePos(const SubStr, S: WideString): SizeInt;\r\nfunction WideQuotedStr(const S: WideString; Quote: WideChar): WideString;\r\nfunction WideExtractQuotedStr(var Src: PWideChar; Quote: WideChar): WideString;\r\nfunction WideCompareText(const S1, S2: WideString): SizeInt;\r\nfunction WideCompareStr(const S1, S2: WideString): SizeInt;\r\nfunction WideUpperCase(const S: WideString): WideString;\r\nfunction WideLowerCase(const S: WideString): WideString;\r\nfunction TrimW(const S: WideString): WideString;\r\nfunction TrimLeftW(const S: WideString): WideString;\r\nfunction TrimRightW(const S: WideString): WideString;\r\nfunction WideReverse(const AText: Widestring): Widestring;\r\nprocedure WideReverseInPlace(var S: WideString);\r\n\r\nfunction TrimLeftLengthW(const S: WideString): SizeInt;\r\nfunction TrimRightLengthW(const S: WideString): SizeInt;\r\n\r\n{$IFNDEF FPC}\r\nfunction WideStartsText(const SubStr, S: WideString): Boolean;\r\nfunction WideStartsStr(const SubStr, S: WideString): Boolean;\r\n{$ENDIF ~FPC}\r\n\r\n// MultiSz Routines\r\ntype\r\n PWideMultiSz = PWideChar;\r\n\r\nfunction StringsToMultiSz(var Dest: PWideMultiSz; const Source: TJclWideStrings): PWideMultiSz;\r\nprocedure MultiSzToStrings(const Dest: TJclWideStrings; const Source: PWideMultiSz);\r\nfunction MultiSzLength(const Source: PWideMultiSz): SizeInt;\r\nprocedure AllocateMultiSz(var Dest: PWideMultiSz; Len: SizeInt);\r\nprocedure FreeMultiSz(var Dest: PWideMultiSz);\r\nfunction MultiSzDup(const Source: PWideMultiSz): PWideMultiSz;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jcl.svn.sourceforge.net/svnroot/jcl/tags/JCL-2.4-Build4571/jcl/source/common/JclWideStrings.pas $';\r\n Revision: '$Revision: 3759 $';\r\n Date: '$Date: 2012-03-04 19:39:47 +0100 (dim. 04 mars 2012) $';\r\n LogPath: 'JCL\\source\\common';\r\n Extra: '';\r\n Data: nil\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n {$IFDEF HAS_UNITSCOPE}\r\n {$IFDEF HAS_UNIT_RTLCONSTS}\r\n System.RTLConsts,\r\n {$ENDIF HAS_UNIT_RTLCONSTS}\r\n {$IFDEF MSWINDOWS}\r\n Winapi.Windows,\r\n {$ENDIF MSWINDOWS}\r\n System.Math,\r\n {$ELSE ~HAS_UNITSCOPE}\r\n {$IFDEF HAS_UNIT_RTLCONSTS}\r\n RTLConsts,\r\n {$ENDIF HAS_UNIT_RTLCONSTS}\r\n {$IFDEF MSWINDOWS}\r\n Windows,\r\n {$ENDIF MSWINDOWS}\r\n Math,\r\n {$ENDIF ~HAS_UNITSCOPE}\r\n JclUnicode,\r\n JclResources;\r\n\r\nprocedure SwapWordByteOrder(P: PWideChar; Len: SizeInt);\r\nbegin\r\n while Len > 0 do\r\n begin\r\n Dec(Len);\r\n P^ := WideChar((Word(P^) shr 8) or (Word(P^) shl 8));\r\n Inc(P);\r\n end;\r\nend;\r\n\r\n//=== WideChar functions =====================================================\r\n\r\nfunction CharToWideChar(Ch: AnsiChar): WideChar;\r\nvar\r\n WS: WideString;\r\nbegin\r\n WS := WideChar(Ch);\r\n Result := WS[1];\r\nend;\r\n\r\nfunction WideCharToChar(Ch: WideChar): AnsiChar;\r\nvar\r\n S: WideString;\r\nbegin\r\n S := Ch;\r\n Result := AnsiChar(S[1]);\r\nend;\r\n\r\n//=== PWideChar functions ====================================================\r\n\r\nprocedure MoveWideChar(const Source; var Dest; Count: SizeInt);\r\nbegin\r\n Move(Source, Dest, Count * SizeOf(WideChar));\r\nend;\r\n\r\nfunction StrAllocW(WideSize: SizeInt): PWideChar;\r\nbegin\r\n WideSize := SizeOf(WideChar) * WideSize + SizeOf(SizeInt);\r\n Result := AllocMem(WideSize);\r\n SizeInt(Pointer(Result)^) := WideSize;\r\n Inc(Result, SizeOf(SizeInt) div SizeOf(WideChar));\r\nend;\r\n\r\nfunction StrNewW(const Str: PWideChar): PWideChar;\r\n// Duplicates the given string (if not nil) and returns the address of the new string.\r\nvar\r\n Size: SizeInt;\r\nbegin\r\n if Str = nil then\r\n Result := nil\r\n else\r\n begin\r\n Size := StrLenW(Str) + 1;\r\n Result := StrMoveW(StrAllocW(Size), Str, Size);\r\n end;\r\nend;\r\n\r\nfunction StrNewW(const Str: WideString): PWideChar;\r\nbegin\r\n Result := StrNewW(PWideChar(Str));\r\nend;\r\n\r\nprocedure StrDisposeW(Str: PWideChar);\r\n// releases a string allocated with StrNewW or StrAllocW\r\nbegin\r\n if Str <> nil then\r\n begin\r\n Dec(Str, SizeOf(SizeInt) div SizeOf(WideChar));\r\n FreeMem(Str);\r\n end;\r\nend;\r\n\r\nprocedure StrDisposeAndNilW(var Str: PWideChar);\r\nvar\r\n Buff: PWideChar;\r\nbegin\r\n Buff := Str;\r\n Str := nil;\r\n StrDisposeW(Buff);\r\nend;\r\n\r\nconst\r\n // data used to bring UTF-16 coded strings into correct UTF-32 order for correct comparation\r\n UTF16Fixup: array [0..31] of Word = (\r\n 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,\r\n 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,\r\n $2000, $F800, $F800, $F800, $F800\r\n );\r\n\r\nfunction StrCompW(const Str1, Str2: PWideChar): SizeInt;\r\n// Binary comparation of Str1 and Str2 with surrogate fix-up.\r\n// Returns < 0 if Str1 is smaller in binary order than Str2, = 0 if both strings are\r\n// equal and > 0 if Str1 is larger than Str2.\r\n//\r\n// This code is based on an idea of Markus W. Scherer (IBM).\r\n// Note: The surrogate fix-up is necessary because some single value code points have\r\n// larger values than surrogates which are in UTF-32 actually larger.\r\nvar\r\n C1, C2: Word;\r\n Run1, Run2: PWideChar;\r\nbegin\r\n Run1 := Str1;\r\n Run2 := Str2;\r\n repeat\r\n C1 := Word(Run1^);\r\n C1 := Word(C1 or UTF16Fixup[C1 shr 11]);\r\n C2 := Word(Run2^);\r\n C2 := Word(C2 or UTF16Fixup[C2 shr 11]);\r\n\r\n // now C1 and C2 are in UTF-32-compatible order\r\n Result := SizeInt(C1) - SizeInt(C2);\r\n if(Result <> 0) or (C1 = 0) or (C2 = 0) then\r\n Break;\r\n Inc(Run1);\r\n Inc(Run2);\r\n until False;\r\n\r\n // If the strings have different lengths but the comparation returned equity so far\r\n // then adjust the result so that the longer string is marked as the larger one.\r\n if Result = 0 then\r\n Result := (Run1 - Str1) - (Run2 - Str2);\r\nend;\r\n\r\nfunction StrLCompW(const Str1, Str2: PWideChar; MaxLen: SizeInt): SizeInt;\r\n// compares strings up to MaxLen code points\r\n// see also StrCompW\r\nvar\r\n S1, S2: PWideChar;\r\n C1, C2: Word;\r\nbegin\r\n if MaxLen > 0 then\r\n begin\r\n S1 := Str1;\r\n S2 := Str2;\r\n repeat\r\n C1 := Word(S1^);\r\n C1 := Word(C1 or UTF16Fixup[C1 shr 11]);\r\n C2 := Word(S2^);\r\n C2 := Word(C2 or UTF16Fixup[C2 shr 11]);\r\n\r\n // now C1 and C2 are in UTF-32-compatible order\r\n { TODO : surrogates take up 2 words and are counted twice here, count them only once }\r\n Result := SizeInt(C1) - SizeInt(C2);\r\n Dec(MaxLen);\r\n if(Result <> 0) or (C1 = 0) or (C2 = 0) or (MaxLen = 0) then\r\n Break;\r\n Inc(S1);\r\n Inc(S2);\r\n until False;\r\n end\r\n else\r\n Result := 0;\r\nend;\r\n\r\nfunction StrICompW(const Str1, Str2: PWideChar): SizeInt;\r\n// Compares Str1 to Str2 without case sensitivity.\r\n// See also comments in StrCompW, but keep in mind that case folding might result in\r\n// one-to-many mappings which must be considered here.\r\n{$IFDEF UNICODE_RTL_DATABASE}\r\nbegin\r\n Result := AnsiStrIComp(Str1, Str2)\r\nend;\r\n{$ELSE ~UNICODE_RTL_DATABASE}\r\nvar\r\n C1, C2: Word;\r\n S1, S2: PWideChar;\r\n Run1, Run2: PWideChar;\r\n Folded1, Folded2: WideString;\r\nbegin\r\n // Because of size changes of the string when doing case folding\r\n // it is unavoidable to convert both strings completely in advance.\r\n S1 := Str1;\r\n S2 := Str2;\r\n Folded1 := '';\r\n while S1^ <> #0 do\r\n begin\r\n Folded1 := Folded1 + WideCaseFolding(S1^);\r\n Inc(S1);\r\n end;\r\n\r\n Folded2 := '';\r\n while S2^ <> #0 do\r\n begin\r\n Folded2 := Folded2 + WideCaseFolding(S2^);\r\n Inc(S2);\r\n end;\r\n\r\n Run1 := PWideChar(Folded1);\r\n Run2 := PWideChar(Folded2);\r\n repeat\r\n C1 := Word(Run1^);\r\n C1 := Word(C1 or UTF16Fixup[C1 shr 11]);\r\n C2 := Word(Run2^);\r\n C2 := Word(C2 or UTF16Fixup[C2 shr 11]);\r\n\r\n // now C1 and C2 are in UTF-32-compatible order\r\n Result := SizeInt(C1) - SizeInt(C2);\r\n if(Result <> 0) or (C1 = 0) or (C2 = 0) then\r\n Break;\r\n Inc(Run1);\r\n Inc(Run2);\r\n until False;\r\n\r\n // If the strings have different lengths but the comparation returned equity so far\r\n // then adjust the result so that the longer string is marked as the larger one.\r\n if Result = 0 then\r\n Result := (Run1 - PWideChar(Folded1)) - (Run2 - PWideChar(Folded2));\r\nend;\r\n{$ENDIF ~UNICODE_RTL_DATABASE}\r\n\r\nfunction StrLICompW(const Str1, Str2: PWideChar; MaxLen: SizeInt): SizeInt;\r\n// compares strings up to MaxLen code points\r\n// see also StrICompW\r\n{$IFDEF UNICODE_RTL_DATABASE}\r\nbegin\r\n Result := AnsiStrIComp(Str1, Str2)\r\nend;\r\n{$ELSE UNICODE_RTL_DATABASE}\r\nvar\r\n S1, S2: PWideChar;\r\n C1, C2: Word;\r\n Run1, Run2: PWideChar;\r\n Folded1, Folded2: WideString;\r\nbegin\r\n if MaxLen > 0 then\r\n begin\r\n // Because of size changes of the string when doing case folding\r\n // it is unavoidable to convert both strings completely in advance.\r\n S1 := Str1;\r\n S2 := Str2;\r\n Folded1 := '';\r\n while S1^ <> #0 do\r\n begin\r\n Folded1 := Folded1 + WideCaseFolding(S1^);\r\n Inc(S1);\r\n end;\r\n\r\n Folded2 := '';\r\n while S2^ <> #0 do\r\n begin\r\n Folded2 := Folded2 + WideCaseFolding(S2^);\r\n Inc(S2);\r\n end;\r\n\r\n Run1 := PWideChar(Folded1);\r\n Run2 := PWideChar(Folded2);\r\n\r\n repeat\r\n C1 := Word(Run1^);\r\n C1 := Word(C1 or UTF16Fixup[C1 shr 11]);\r\n C2 := Word(Run2^);\r\n C2 := Word(C2 or UTF16Fixup[C2 shr 11]);\r\n\r\n // now C1 and C2 are in UTF-32-compatible order\r\n { TODO : surrogates take up 2 words and are counted twice here, count them only once }\r\n Result := SizeInt(C1) - SizeInt(C2);\r\n Dec(MaxLen);\r\n if(Result <> 0) or (C1 = 0) or (C2 = 0) or (MaxLen = 0) then\r\n Break;\r\n Inc(Run1);\r\n Inc(Run2);\r\n until False;\r\n end\r\n else\r\n Result := 0;\r\nend;\r\n{$ENDIF UNICODE_RTL_DATABASE}\r\n\r\nfunction StrLICompW2(const Str1, Str2: PWideChar; MaxLen: SizeInt): SizeInt;\r\nvar\r\n P1, P2: WideString;\r\nbegin\r\n // faster than the JclUnicode.StrLICompW function\r\n SetString(P1, Str1, Min(MaxLen, StrLenW(Str1)));\r\n SetString(P2, Str2, Min(MaxLen, StrLenW(Str2)));\r\n Result := WideCompareText(P1, P2);\r\nend;\r\n\r\nfunction StrPosW(const Str, SubStr: PWideChar): PWideChar;\r\nvar\r\n P: PWideChar;\r\n I: SizeInt;\r\nbegin\r\n Result := nil;\r\n if (Str = nil) or (SubStr = nil) or (Str^ = #0) or (SubStr^ = #0) then\r\n Exit;\r\n Result := Str;\r\n while Result^ <> #0 do\r\n begin\r\n if Result^ <> SubStr^ then\r\n Inc(Result)\r\n else\r\n begin\r\n P := Result + 1;\r\n I := 1;\r\n while (P^ <> #0) and (P^ = SubStr[I]) do\r\n begin\r\n Inc(I);\r\n Inc(P);\r\n end;\r\n if SubStr[I] = #0 then\r\n Exit\r\n else\r\n Inc(Result);\r\n end;\r\n end;\r\n Result := nil;\r\nend;\r\n\r\nfunction StrLenW(const Str: PWideChar): SizeInt;\r\nbegin\r\n Result := 0;\r\n if Str <> nil then\r\n while Str[Result] <> #0 do\r\n Inc(Result);\r\nend;\r\n\r\nfunction StrScanW(const Str: PWideChar; Ch: WideChar): PWideChar;\r\nbegin\r\n Result := Str;\r\n if Result <> nil then\r\n begin\r\n while (Result^ <> #0) and (Result^ <> Ch) do\r\n Inc(Result);\r\n if (Result^ = #0) and (Ch <> #0) then\r\n Result := nil;\r\n end;\r\nend;\r\n\r\nfunction StrEndW(const Str: PWideChar): PWideChar;\r\nbegin\r\n Result := Str;\r\n if Result <> nil then\r\n while Result^ <> #0 do\r\n Inc(Result);\r\nend;\r\n\r\nfunction StrCopyW(Dest: PWideChar; const Source: PWideChar): PWideChar;\r\nvar\r\n Src: PWideChar;\r\nbegin\r\n Result := Dest;\r\n if Dest <> nil then\r\n begin\r\n Src := Source;\r\n if Src <> nil then\r\n while Src^ <> #0 do\r\n begin\r\n Dest^ := Src^;\r\n Inc(Src);\r\n Inc(Dest);\r\n end;\r\n Dest^ := #0;\r\n end;\r\nend;\r\n\r\nfunction StrECopyW(Dest: PWideChar; const Source: PWideChar): PWideChar;\r\nvar\r\n Src: PWideChar;\r\nbegin\r\n if Dest <> nil then\r\n begin\r\n Src := Source;\r\n if Src <> nil then\r\n while Src^ <> #0 do\r\n begin\r\n Dest^ := Src^;\r\n Inc(Src);\r\n Inc(Dest);\r\n end;\r\n Dest^ := #0;\r\n end;\r\n Result := Dest;\r\nend;\r\n\r\nfunction StrLCopyW(Dest: PWideChar; const Source: PWideChar; MaxLen: SizeInt): PWideChar;\r\nvar\r\n Src: PWideChar;\r\nbegin\r\n Result := Dest;\r\n if (Dest <> nil) and (MaxLen > 0) then\r\n begin\r\n Src := Source;\r\n if Src <> nil then\r\n while (MaxLen > 0) and (Src^ <> #0) do\r\n begin\r\n Dest^ := Src^;\r\n Inc(Src);\r\n Inc(Dest);\r\n Dec(MaxLen);\r\n end;\r\n Dest^ := #0;\r\n end;\r\nend;\r\n\r\nfunction StrCatW(Dest: PWideChar; const Source: PWideChar): PWideChar;\r\nbegin\r\n Result := Dest;\r\n StrCopyW(StrEndW(Dest), Source);\r\nend;\r\n\r\nfunction StrLCatW(Dest: PWideChar; const Source: PWideChar; MaxLen: SizeInt): PWideChar;\r\nbegin\r\n Result := Dest;\r\n StrLCopyW(StrEndW(Dest), Source, MaxLen);\r\nend;\r\n\r\nfunction StrMoveW(Dest: PWideChar; const Source: PWideChar; Count: SizeInt): PWideChar;\r\nbegin\r\n Result := Dest;\r\n if Count > 0 then\r\n Move(Source^, Dest^, Count * SizeOf(WideChar));\r\nend;\r\n\r\nfunction StrPCopyWW(Dest: PWideChar; const Source: WideString): PWideChar;\r\nbegin\r\n Result := StrLCopyW(Dest, PWideChar(Source), Length(Source));\r\nend;\r\n\r\nfunction StrPLCopyWW(Dest: PWideChar; const Source: WideString; MaxLen: SizeInt): PWideChar;\r\nbegin\r\n Result := StrLCopyW(Dest, PWideChar(Source), MaxLen);\r\nend;\r\n\r\nfunction StrRScanW(const Str: PWideChar; Chr: WideChar): PWideChar;\r\nvar\r\n P: PWideChar;\r\nbegin\r\n Result := nil;\r\n if Str <> nil then\r\n begin\r\n P := Str;\r\n repeat\r\n if P^ = Chr then\r\n Result := P;\r\n Inc(P);\r\n until P^ = #0;\r\n end;\r\nend;\r\n\r\n// (rom) following functions copied from JclUnicode.pas\r\n\r\n// exchanges in each character of the given string the low order and high order\r\n// byte to go from LSB to MSB and vice versa.\r\n// EAX/RAX contains address of string\r\n// stop at the first #0 character\r\n\r\nprocedure StrSwapByteOrder(Str: PWideChar);\r\nasm\r\n {$IFDEF CPU32}\r\n // --> EAX Str\r\n PUSH ESI\r\n PUSH EDI\r\n MOV ESI, EAX\r\n MOV EDI, ESI\r\n XOR EAX, EAX // clear high order byte to be able to use 32bit operand below\r\n@@1:\r\n LODSW\r\n OR EAX, EAX\r\n JZ @@2\r\n XCHG AL, AH\r\n STOSW\r\n JMP @@1\r\n@@2:\r\n POP EDI\r\n POP ESI\r\n {$ENDIF CPU32}\r\n {$IFDEF CPU64}\r\n // --> RCX Str\r\n XOR RAX, RAX // clear high order byte to be able to use 64bit operand below\r\n@@1:\r\n MOV AX, WORD PTR [RCX]\r\n OR RAX, RAX\r\n JZ @@2\r\n XCHG AL, AH\r\n MOV WORD PTR [RCX], AX\r\n ADD ECX, 2\r\n JMP @@1\r\n@@2:\r\n {$ENDIF CPU64}\r\nend;\r\n\r\nfunction StrNScanW(const Str1, Str2: PWideChar): SizeInt;\r\n// Determines where (in Str1) the first time one of the characters of Str2 appear.\r\n// The result is the length of a string part of Str1 where none of the characters of\r\n// Str2 do appear (not counting the trailing #0 and starting with position 0 in Str1).\r\nvar\r\n Run: PWideChar;\r\nbegin\r\n Result := -1;\r\n if (Str1 <> nil) and (Str2 <> nil) then\r\n begin\r\n Run := Str1;\r\n while Run^ <> #0 do\r\n begin\r\n if StrScanW(Str2, Run^) <> nil then\r\n Break;\r\n Inc(Run);\r\n end;\r\n Result := Run - Str1;\r\n end;\r\nend;\r\n\r\nfunction StrRNScanW(const Str1, Str2: PWideChar): SizeInt;\r\n// This function does the same as StrRNScanW but uses Str1 in reverse order. This\r\n// means Str1 points to the last character of a string, is traversed reversely\r\n// and terminates with a starting #0. This is useful for parsing strings stored\r\n// in reversed macro buffers etc.\r\nvar\r\n Run: PWideChar;\r\nbegin\r\n Result := -1;\r\n if (Str1 <> nil) and (Str2 <> nil) then\r\n begin\r\n Run := Str1;\r\n while Run^ <> #0 do\r\n begin\r\n if StrScanW(Str2, Run^) <> nil then\r\n Break;\r\n Dec(Run);\r\n end;\r\n Result := Str1 - Run;\r\n end;\r\nend;\r\n\r\n// Returns a pointer to first occurrence of a specified character in a string\r\n// or nil if not found.\r\n// Note: this is just a binary search for the specified character and there's no\r\n// check for a terminating null. Instead at most StrLen characters are\r\n// searched. This makes this function extremly fast.\r\n//\r\nfunction StrScanW(Str: PWideChar; Chr: WideChar; StrLen: SizeInt): PWideChar;\r\nbegin\r\n Result := Str;\r\n while StrLen > 0 do\r\n begin\r\n if Result^ = Chr then\r\n Exit;\r\n Inc(Result);\r\n end;\r\n Result := nil;\r\nend;\r\n\r\nfunction StrBufSizeW(const Str: PWideChar): SizeInt;\r\n// Returns max number of wide characters that can be stored in a buffer\r\n// allocated by StrAllocW.\r\nvar\r\n P: PWideChar;\r\nbegin\r\n if Str <> nil then\r\n begin\r\n P := Str;\r\n Dec(P, SizeOf(SizeInt) div SizeOf(WideChar));\r\n Result := (PSizeInt(P)^ - SizeOf(SizeInt)) div SizeOf(WideChar);\r\n end\r\n else\r\n Result := 0;\r\nend;\r\n\r\nfunction StrPCopyW(Dest: PWideChar; const Source: AnsiString): PWideChar;\r\n// copies a Pascal-style string to a null-terminated wide string\r\nbegin\r\n Result := StrPLCopyW(Dest, Source, SizeInt(Length(Source)));\r\n Result[Length(Source)] := WideNull;\r\nend;\r\n\r\nfunction StrPLCopyW(Dest: PWideChar; const Source: AnsiString; MaxLen: SizeInt): PWideChar;\r\n// copies characters from a Pascal-style string into a null-terminated wide string\r\nvar\r\n P: PAnsiChar;\r\nbegin\r\n P := PAnsiChar(Pointer(Source));\r\n while MaxLen > 0 do\r\n begin\r\n Dest^ := WideChar(Ord(P^));\r\n Inc(P);\r\n Inc(Dest);\r\n Dec(MaxLen);\r\n end;\r\n Result := Dest;\r\nend;\r\n\r\n//=== WideString functions ===================================================\r\n\r\nfunction WidePos(const SubStr, S: WideString): SizeInt;\r\nvar\r\n P: PWideChar;\r\nbegin\r\n P := StrPosW(PWideChar(S), PWideChar(SubStr));\r\n if P <> nil then\r\n Result := P - PWideChar(S) + 1\r\n else\r\n Result := 0;\r\nend;\r\n\r\n// original code by Mike Lischke (extracted from JclUnicode.pas)\r\n\r\nfunction WideQuotedStr(const S: WideString; Quote: WideChar): WideString;\r\nvar\r\n P, Src,\r\n Dest: PWideChar;\r\n AddCount: SizeInt;\r\nbegin\r\n AddCount := 0;\r\n P := StrScanW(PWideChar(S), Quote);\r\n while P <> nil do\r\n begin\r\n Inc(P);\r\n Inc(AddCount);\r\n P := StrScanW(P, Quote);\r\n end;\r\n\r\n if AddCount = 0 then\r\n Result := Quote + S + Quote\r\n else\r\n begin\r\n SetLength(Result, Length(S) + AddCount + 2);\r\n Dest := PWideChar(Result);\r\n Dest^ := Quote;\r\n Inc(Dest);\r\n Src := PWideChar(S);\r\n P := StrScanW(Src, Quote);\r\n repeat\r\n Inc(P);\r\n MoveWideChar(Src^, Dest^, P - Src);\r\n Inc(Dest, P - Src);\r\n Dest^ := Quote;\r\n Inc(Dest);\r\n Src := P;\r\n P := StrScanW(Src, Quote);\r\n until P = nil;\r\n P := StrEndW(Src);\r\n MoveWideChar(Src^, Dest^, P - Src);\r\n Inc(Dest, P - Src);\r\n Dest^ := Quote;\r\n end;\r\nend;\r\n\r\n// original code by Mike Lischke (extracted from JclUnicode.pas)\r\n\r\nfunction WideExtractQuotedStr(var Src: PWideChar; Quote: WideChar): WideString;\r\nvar\r\n P, Dest: PWideChar;\r\n DropCount: SizeInt;\r\nbegin\r\n Result := '';\r\n if (Src = nil) or (Src^ <> Quote) then\r\n Exit;\r\n\r\n Inc(Src);\r\n DropCount := 1;\r\n P := Src;\r\n Src := StrScanW(Src, Quote);\r\n while Src <> nil do // count adjacent pairs of quote chars\r\n begin\r\n Inc(Src);\r\n if Src^ <> Quote then\r\n Break;\r\n Inc(Src);\r\n Inc(DropCount);\r\n Src := StrScanW(Src, Quote);\r\n end;\r\n\r\n if Src = nil then\r\n Src := StrEndW(P);\r\n if (Src - P) <= 1 then\r\n Exit;\r\n\r\n if DropCount = 1 then\r\n SetString(Result, P, Src - P - 1)\r\n else\r\n begin\r\n SetLength(Result, Src - P - DropCount);\r\n Dest := PWideChar(Result);\r\n Src := StrScanW(P, Quote);\r\n while Src <> nil do\r\n begin\r\n Inc(Src);\r\n if Src^ <> Quote then\r\n Break;\r\n MoveWideChar(P^, Dest^, Src - P);\r\n Inc(Dest, Src - P);\r\n Inc(Src);\r\n P := Src;\r\n Src := StrScanW(Src, Quote);\r\n end;\r\n if Src = nil then\r\n Src := StrEndW(P);\r\n MoveWideChar(P^, Dest^, Src - P - 1);\r\n end;\r\nend;\r\n\r\n\r\nfunction TrimW(const S: WideString): WideString;\r\n// available from Delphi 7 up\r\n{$IFDEF RTL150_UP}\r\nbegin\r\n Result := Trim(S);\r\nend;\r\n{$ELSE ~RTL150_UP}\r\nvar\r\n I, L: SizeInt;\r\nbegin\r\n L := Length(S);\r\n I := 1;\r\n while (I <= L) and (S[I] <= ' ') do\r\n Inc(I);\r\n if I > L then\r\n Result := ''\r\n else\r\n begin\r\n while S[L] <= ' ' do\r\n Dec(L);\r\n Result := Copy(S, I, L - I + 1);\r\n end;\r\nend;\r\n{$ENDIF ~RTL150_UP}\r\n\r\nfunction TrimLeftW(const S: WideString): WideString;\r\n// available from Delphi 7 up\r\n{$IFDEF RTL150_UP}\r\nbegin\r\n Result := TrimLeft(S);\r\nend;\r\n{$ELSE ~RTL150_UP}\r\nvar\r\n I, L: SizeInt;\r\nbegin\r\n L := Length(S);\r\n I := 1;\r\n while (I <= L) and (S[I] <= ' ') do\r\n Inc(I);\r\n Result := Copy(S, I, Maxint);\r\nend;\r\n{$ENDIF ~RTL150_UP}\r\n\r\nfunction TrimRightW(const S: WideString): WideString;\r\n// available from Delphi 7 up\r\n{$IFDEF RTL150_UP}\r\nbegin\r\n Result := TrimRight(S);\r\nend;\r\n{$ELSE ~RTL150_UP}\r\nvar\r\n I: SizeInt;\r\nbegin\r\n I := Length(S);\r\n while (I > 0) and (S[I] <= ' ') do\r\n Dec(I);\r\n Result := Copy(S, 1, I);\r\nend;\r\n{$ENDIF ~RTL150_UP}\r\n\r\nfunction WideReverse(const AText: Widestring): Widestring;\r\nbegin\r\n Result := AText;\r\n WideReverseInPlace(Result);\r\nend;\r\n\r\nprocedure WideReverseInPlace(var S: WideString);\r\nvar\r\n P1, P2: PWideChar;\r\n C: WideChar;\r\nbegin\r\n UniqueString(S);\r\n P1 := PWideChar(S);\r\n P2 := PWideChar(S) + Length(S) - 1;\r\n while P1 < P2 do\r\n begin\r\n C := P1^;\r\n P1^ := P2^;\r\n P2^ := C;\r\n Inc(P1);\r\n Dec(P2);\r\n end;\r\nend;\r\n\r\nfunction WideCompareText(const S1, S2: WideString): SizeInt;\r\nbegin\r\n {$IFDEF MSWINDOWS}\r\n if Win32Platform = VER_PLATFORM_WIN32_WINDOWS then\r\n Result := AnsiCompareText(string(S1), string(S2))\r\n else\r\n Result := CompareStringW(LOCALE_USER_DEFAULT, NORM_IGNORECASE,\r\n PWideChar(S1), Length(S1), PWideChar(S2), Length(S2)) - 2;\r\n {$ELSE ~MSWINDOWS}\r\n { TODO : Don't cheat here }\r\n Result := CompareText(S1, S2);\r\n {$ENDIF MSWINDOWS}\r\nend;\r\n\r\nfunction WideCompareStr(const S1, S2: WideString): SizeInt;\r\nbegin\r\n {$IFDEF MSWINDOWS}\r\n if Win32Platform = VER_PLATFORM_WIN32_WINDOWS then\r\n Result := AnsiCompareStr(string(S1), string(S2))\r\n else\r\n Result := CompareStringW(LOCALE_USER_DEFAULT, 0,\r\n PWideChar(S1), Length(S1), PWideChar(S2), Length(S2)) - 2;\r\n {$ELSE ~MSWINDOWS}\r\n {$IFDEF FPC}\r\n Result := SysUtils.WideCompareStr(S1, S2);\r\n {$ELSE ~FPC}\r\n { TODO : Don't cheat here }\r\n Result := CompareString(S1, S2);\r\n {$ENDIF ~FPC}\r\n {$ENDIF ~MSWINDOWS}\r\nend;\r\n\r\nfunction WideUpperCase(const S: WideString): WideString;\r\nbegin\r\n Result := S;\r\n if Result <> '' then\r\n {$IFDEF MSWINDOWS}\r\n CharUpperBuffW(Pointer(Result), Length(Result));\r\n {$ELSE ~MSWINDOWS}\r\n { TODO : Don't cheat here }\r\n Result := UpperCase(Result);\r\n {$ENDIF ~MSWINDOWS}\r\nend;\r\n\r\nfunction WideLowerCase(const S: WideString): WideString;\r\nbegin\r\n Result := S;\r\n if Result <> '' then\r\n {$IFDEF MSWINDOWS}\r\n CharLowerBuffW(Pointer(Result), Length(Result));\r\n {$ELSE ~MSWINDOWS}\r\n { TODO : Don't cheat here }\r\n Result := LowerCase(Result);\r\n {$ENDIF ~MSWINDOWS}\r\nend;\r\n\r\nfunction TrimLeftLengthW(const S: WideString): SizeInt;\r\nvar\r\n Len: SizeInt;\r\nbegin\r\n Len := Length(S);\r\n Result := 1;\r\n while (Result <= Len) and (S[Result] <= #32) do\r\n Inc(Result);\r\n Result := Len - Result + 1;\r\nend;\r\n\r\nfunction TrimRightLengthW(const S: WideString): SizeInt;\r\nbegin\r\n Result := Length(S);\r\n while (Result > 0) and (S[Result] <= #32) do\r\n Dec(Result);\r\nend;\r\n\r\n{$IFNDEF FPC}\r\n\r\nfunction WideStartsText(const SubStr, S: WideString): Boolean;\r\nvar\r\n Len: SizeInt;\r\nbegin\r\n Len := Length(SubStr);\r\n Result := (Len <= Length(S)) and (StrLICompW(PWideChar(SubStr), PWideChar(S), Len) = 0);\r\nend;\r\n\r\nfunction WideStartsStr(const SubStr, S: WideString): Boolean;\r\nvar\r\n Len: SizeInt;\r\nbegin\r\n Len := Length(SubStr);\r\n Result := (Len <= Length(S)) and (StrLCompW(PWideChar(SubStr), PWideChar(S), Len) = 0);\r\nend;\r\n\r\n{$ENDIF ~FPC}\r\n\r\n{$IFNDEF SUPPORTS_UNICODE}\r\n//=== { TJclWideStrings } ==========================================================\r\n\r\nconstructor TJclWideStrings.Create;\r\nbegin\r\n inherited Create;\r\n // FLineSeparator := WideChar($2028);\r\n {$IFDEF MSWINDOWS}\r\n FLineSeparator := WideChar(13) + '' + WideChar(10); // compiler wants it this way\r\n {$ENDIF MSWINDOWS}\r\n {$IFDEF UNIX}\r\n FLineSeparator := WideChar(10);\r\n {$ENDIF UNIX}\r\n FNameValueSeparator := '=';\r\n FDelimiter := ',';\r\n FQuoteChar := '\"';\r\nend;\r\n\r\nfunction TJclWideStrings.Add(const S: WideString): Integer;\r\nbegin\r\n Result := AddObject(S, nil);\r\nend;\r\n\r\nfunction TJclWideStrings.AddObject(const S: WideString; AObject: TObject): Integer;\r\nbegin\r\n Result := Count;\r\n InsertObject(Result, S, AObject);\r\nend;\r\n\r\nprocedure TJclWideStrings.AddStrings(Strings: TJclWideStrings);\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := 0 to Strings.Count - 1 do\r\n AddObject(Strings.GetP(I)^, Strings.Objects[I]);\r\nend;\r\n\r\nprocedure TJclWideStrings.AddStrings(Strings: TStrings);\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := 0 to Strings.Count - 1 do\r\n AddObject(Strings.Strings[I], Strings.Objects[I]);\r\nend;\r\n\r\nprocedure TJclWideStrings.AddStringsTo(Dest: TStrings);\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := 0 to Count - 1 do\r\n Dest.AddObject(GetP(I)^, Objects[I]);\r\nend;\r\n\r\nprocedure TJclWideStrings.Append(const S: WideString);\r\nbegin\r\n Add(S);\r\nend;\r\n\r\nprocedure TJclWideStrings.Assign(Source: TPersistent);\r\nbegin\r\n if Source is TJclWideStrings then\r\n begin\r\n BeginUpdate;\r\n try\r\n Clear;\r\n FDelimiter := TJclWideStrings(Source).FDelimiter;\r\n FNameValueSeparator := TJclWideStrings(Source).FNameValueSeparator;\r\n FQuoteChar := TJclWideStrings(Source).FQuoteChar;\r\n AddStrings(TJclWideStrings(Source));\r\n finally\r\n EndUpdate;\r\n end;\r\n end\r\n else\r\n if Source is TStrings then\r\n begin\r\n BeginUpdate;\r\n try\r\n Clear;\r\n {$IFDEF RTL190_UP}\r\n FNameValueSeparator := TStrings(Source).NameValueSeparator;\r\n FQuoteChar := TStrings(Source).QuoteChar;\r\n FDelimiter := TStrings(Source).Delimiter;\r\n {$ELSE ~RTL190_UP}\r\n {$IFDEF RTL150_UP}\r\n FNameValueSeparator := CharToWideChar(TStrings(Source).NameValueSeparator);\r\n {$ENDIF RTL150_UP}\r\n FQuoteChar := CharToWideChar(TStrings(Source).QuoteChar);\r\n FDelimiter := CharToWideChar(TStrings(Source).Delimiter);\r\n {$ENDIF ~RTL190_UP}\r\n AddStrings(TStrings(Source));\r\n finally\r\n EndUpdate;\r\n end;\r\n end\r\n else\r\n inherited Assign(Source);\r\nend;\r\n\r\nprocedure TJclWideStrings.AssignTo(Dest: TPersistent);\r\nvar\r\n I: Integer;\r\nbegin\r\n if Dest is TStrings then\r\n begin\r\n TStrings(Dest).BeginUpdate;\r\n try\r\n TStrings(Dest).Clear;\r\n {$IFDEF RTL190_UP}\r\n TStrings(Dest).NameValueSeparator := NameValueSeparator;\r\n TStrings(Dest).QuoteChar := QuoteChar;\r\n TStrings(Dest).Delimiter := Delimiter;\r\n {$ELSE ~RTL190_UP}\r\n {$IFDEF RTL150_UP}\r\n TStrings(Dest).NameValueSeparator := WideCharToChar(NameValueSeparator);\r\n {$ENDIF RTL150_UP}\r\n TStrings(Dest).QuoteChar := WideCharToChar(QuoteChar);\r\n TStrings(Dest).Delimiter := WideCharToChar(Delimiter);\r\n {$ENDIF ~RTL190_UP}\r\n for I := 0 to Count - 1 do\r\n TStrings(Dest).AddObject(GetP(I)^, Objects[I]);\r\n finally\r\n TStrings(Dest).EndUpdate;\r\n end;\r\n end\r\n else\r\n inherited AssignTo(Dest);\r\nend;\r\n\r\nprocedure TJclWideStrings.BeginUpdate;\r\nbegin\r\n if FUpdateCount = 0 then\r\n SetUpdateState(True);\r\n Inc(FUpdateCount);\r\nend;\r\n\r\nfunction TJclWideStrings.CompareStrings(const S1, S2: WideString): Integer;\r\nbegin\r\n Result := WideCompareText(S1, S2);\r\nend;\r\n\r\nfunction TJclWideStrings.CreateAnsiStringList: TStrings;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := TStringList.Create;\r\n try\r\n Result.BeginUpdate;\r\n for I := 0 to Count - 1 do\r\n Result.AddObject(GetP(I)^, Objects[I]);\r\n Result.EndUpdate;\r\n except\r\n Result.Free;\r\n raise;\r\n end;\r\nend;\r\n\r\nprocedure TJclWideStrings.DefineProperties(Filer: TFiler);\r\n\r\n function DoWrite: Boolean;\r\n begin\r\n if Filer.Ancestor <> nil then\r\n begin\r\n Result := True;\r\n if Filer.Ancestor is TJclWideStrings then\r\n Result := not Equals(TJclWideStrings(Filer.Ancestor))\r\n end\r\n else\r\n Result := Count > 0;\r\n end;\r\n\r\nbegin\r\n Filer.DefineProperty('Strings', ReadData, WriteData, DoWrite);\r\nend;\r\n\r\nprocedure TJclWideStrings.EndUpdate;\r\nbegin\r\n Dec(FUpdateCount);\r\n if FUpdateCount = 0 then\r\n SetUpdateState(False);\r\nend;\r\n\r\nfunction TJclWideStrings.Equals(Strings: TStrings): Boolean;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := False;\r\n if Strings.Count = Count then\r\n begin\r\n for I := 0 to Count - 1 do\r\n if Strings[I] <> PStrings[I]^ then\r\n Exit;\r\n Result := True;\r\n end;\r\nend;\r\n\r\nfunction TJclWideStrings.Equals(Strings: TJclWideStrings): Boolean;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := False;\r\n if Strings.Count = Count then\r\n begin\r\n for I := 0 to Count - 1 do\r\n if Strings[I] <> PStrings[I]^ then\r\n Exit;\r\n Result := True;\r\n end;\r\nend;\r\n\r\nprocedure TJclWideStrings.Exchange(Index1, Index2: Integer);\r\nvar\r\n TempObject: TObject;\r\n TempString: WideString;\r\nbegin\r\n BeginUpdate;\r\n try\r\n TempString := PStrings[Index1]^;\r\n TempObject := Objects[Index1];\r\n PStrings[Index1]^ := PStrings[Index2]^;\r\n Objects[Index1] := Objects[Index2];\r\n PStrings[Index2]^ := TempString;\r\n Objects[Index2] := TempObject;\r\n finally\r\n EndUpdate;\r\n end;\r\nend;\r\n\r\nfunction TJclWideStrings.ExtractName(const S: WideString): WideString;\r\nvar\r\n Index: Integer;\r\nbegin\r\n Result := S;\r\n Index := WidePos(NameValueSeparator, Result);\r\n if Index <> 0 then\r\n SetLength(Result, Index - 1)\r\n else\r\n SetLength(Result, 0);\r\nend;\r\n\r\nfunction TJclWideStrings.Get(Index: Integer): WideString;\r\nbegin\r\n Result := GetP(Index)^;\r\nend;\r\n\r\nfunction TJclWideStrings.GetCapacity: Integer;\r\nbegin\r\n Result := Count;\r\nend;\r\n\r\nfunction TJclWideStrings.GetCommaText: WideString;\r\nbegin\r\n Result := GetDelimitedTextEx(',', '\"');\r\nend;\r\n\r\nfunction TJclWideStrings.GetDelimitedText: WideString;\r\nbegin\r\n Result := GetDelimitedTextEx(FDelimiter, FQuoteChar);\r\nend;\r\n\r\nfunction TJclWideStrings.GetDelimitedTextEx(ADelimiter, AQuoteChar: WideChar): WideString;\r\nvar\r\n S: WideString;\r\n P: PWideChar;\r\n I, Num: Integer;\r\nbegin\r\n Num := GetCount;\r\n if (Num = 1) and (GetP(0)^ = '') then\r\n Result := AQuoteChar + '' + AQuoteChar // Compiler wants it this way\r\n else\r\n begin\r\n Result := '';\r\n for I := 0 to Count - 1 do\r\n begin\r\n S := GetP(I)^;\r\n P := PWideChar(S);\r\n while True do\r\n begin\r\n case P[0] of\r\n WideChar(0)..WideChar(32):\r\n Inc(P);\r\n else\r\n if (P[0] = AQuoteChar) or (P[0] = ADelimiter) then\r\n Inc(P)\r\n else\r\n Break;\r\n end;\r\n end;\r\n if P[0] <> WideChar(0) then\r\n S := WideQuotedStr(S, AQuoteChar);\r\n Result := Result + S + ADelimiter;\r\n end;\r\n System.Delete(Result, Length(Result), 1);\r\n end;\r\nend;\r\n\r\nfunction TJclWideStrings.GetName(Index: Integer): WideString;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := GetP(Index)^;\r\n I := WidePos(FNameValueSeparator, Result);\r\n if I > 0 then\r\n SetLength(Result, I - 1);\r\nend;\r\n\r\nfunction TJclWideStrings.GetObject(Index: Integer): TObject;\r\nbegin\r\n Result := nil;\r\nend;\r\n\r\nfunction TJclWideStrings.GetText: PWideChar;\r\nbegin\r\n Result := StrNewW(GetTextStr);\r\nend;\r\n\r\nfunction TJclWideStrings.GetTextStr: WideString;\r\nvar\r\n I: Integer;\r\n Len, LL: Integer;\r\n P: PWideChar;\r\n W: PWideString;\r\nbegin\r\n Len := 0;\r\n LL := Length(LineSeparator);\r\n for I := 0 to Count - 1 do\r\n Inc(Len, Length(GetP(I)^) + LL);\r\n SetLength(Result, Len);\r\n P := PWideChar(Result);\r\n for I := 0 to Count - 1 do\r\n begin\r\n W := GetP(I);\r\n Len := Length(W^);\r\n if Len > 0 then\r\n begin\r\n MoveWideChar(W^[1], P[0], Len);\r\n Inc(P, Len);\r\n end;\r\n if LL > 0 then\r\n begin\r\n MoveWideChar(FLineSeparator[1], P[0], LL);\r\n Inc(P, LL);\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJclWideStrings.GetValue(const Name: WideString): WideString;\r\nvar\r\n Idx: Integer;\r\nbegin\r\n Idx := IndexOfName(Name);\r\n if Idx >= 0 then\r\n Result := GetValueFromIndex(Idx)\r\n else\r\n Result := '';\r\nend;\r\n\r\nfunction TJclWideStrings.GetValueFromIndex(Index: Integer): WideString;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := GetP(Index)^;\r\n I := WidePos(FNameValueSeparator, Result);\r\n if I > 0 then\r\n System.Delete(Result, 1, I)\r\n else\r\n Result := '';\r\nend;\r\n\r\nfunction TJclWideStrings.IndexOf(const S: WideString): Integer;\r\nbegin\r\n for Result := 0 to Count - 1 do\r\n if CompareStrings(GetP(Result)^, S) = 0 then\r\n Exit;\r\n Result := -1;\r\nend;\r\n\r\nfunction TJclWideStrings.IndexOfName(const Name: WideString): Integer;\r\nbegin\r\n for Result := 0 to Count - 1 do\r\n if CompareStrings(Names[Result], Name) = 0 then\r\n Exit;\r\n Result := -1;\r\nend;\r\n\r\nfunction TJclWideStrings.IndexOfObject(AObject: TObject): Integer;\r\nbegin\r\n for Result := 0 to Count - 1 do\r\n if Objects[Result] = AObject then\r\n Exit;\r\n Result := -1;\r\nend;\r\n\r\nprocedure TJclWideStrings.Insert(Index: Integer; const S: WideString);\r\nbegin\r\n InsertObject(Index, S, nil);\r\nend;\r\n\r\nprocedure TJclWideStrings.InsertObject(Index: Integer; const S: WideString; AObject: TObject);\r\nbegin\r\nend;\r\n\r\nprocedure TJclWideStrings.LoadFromFile(const FileName: TFileName;\r\n WideFileOptions: TWideFileOptions = []);\r\nvar\r\n Stream: TFileStream;\r\nbegin\r\n Stream := TFileStream.Create(FileName, fmOpenRead or fmShareDenyWrite);\r\n try\r\n LoadFromStream(Stream, WideFileOptions);\r\n finally\r\n Stream.Free;\r\n end;\r\nend;\r\n\r\nprocedure TJclWideStrings.LoadFromStream(Stream: TStream;\r\n WideFileOptions: TWideFileOptions = []);\r\nvar\r\n AnsiS: AnsiString;\r\n WideS: WideString;\r\n WC: WideChar;\r\nbegin\r\n BeginUpdate;\r\n try\r\n Clear;\r\n WC := #0;\r\n Stream.Read(WC, SizeOf(WC));\r\n if (foAnsiFile in WideFileOptions) and (Hi(Word(WC)) <> 0) and (WC <> BOM_LSB_FIRST) and (WC <> BOM_MSB_FIRST) then\r\n begin\r\n Stream.Seek(-SizeOf(WC), soFromCurrent);\r\n SetLength(AnsiS, (Stream.Size - Stream.Position) div SizeOf(AnsiChar));\r\n Stream.Read(AnsiS[1], Length(AnsiS) * SizeOf(AnsiChar));\r\n SetTextStr(WideString(AnsiS)); // explicit Unicode conversion\r\n end\r\n else\r\n begin\r\n if (WC <> BOM_LSB_FIRST) and (WC <> BOM_MSB_FIRST) then\r\n Stream.Seek(-SizeOf(WC), soFromCurrent);\r\n SetLength(WideS, (Stream.Size - Stream.Position + 1) div SizeOf(WideChar));\r\n Stream.Read(WideS[1], Length(WideS) * SizeOf(WideChar));\r\n if WC = BOM_MSB_FIRST then\r\n SwapWordByteOrder(PWideChar(WideS), Length(WideS));\r\n SetTextStr(WideS);\r\n end;\r\n finally\r\n EndUpdate;\r\n end;\r\nend;\r\n\r\nprocedure TJclWideStrings.Move(CurIndex, NewIndex: Integer);\r\nvar\r\n TempObject: TObject;\r\n TempString: WideString;\r\nbegin\r\n if CurIndex <> NewIndex then\r\n begin\r\n BeginUpdate;\r\n try\r\n TempString := GetP(CurIndex)^;\r\n TempObject := GetObject(CurIndex);\r\n Delete(CurIndex);\r\n InsertObject(NewIndex, TempString, TempObject);\r\n finally\r\n EndUpdate;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJclWideStrings.ReadData(Reader: TReader);\r\nbegin\r\n BeginUpdate;\r\n try\r\n Clear;\r\n Reader.ReadListBegin;\r\n while not Reader.EndOfList do\r\n if Reader.NextValue in [vaLString, vaString] then\r\n Add(Reader.ReadString)\r\n else\r\n Add(Reader.ReadWideString);\r\n Reader.ReadListEnd;\r\n finally\r\n EndUpdate;\r\n end;\r\nend;\r\n\r\nprocedure TJclWideStrings.SaveToFile(const FileName: TFileName; WideFileOptions: TWideFileOptions = []);\r\nvar\r\n Stream: TFileStream;\r\nbegin\r\n Stream := TFileStream.Create(FileName, fmCreate);\r\n try\r\n SaveToStream(Stream, WideFileOptions);\r\n finally\r\n Stream.Free;\r\n end;\r\nend;\r\n\r\nprocedure TJclWideStrings.SaveToStream(Stream: TStream; WideFileOptions: TWideFileOptions = []);\r\nvar\r\n AnsiS: AnsiString;\r\n WideS: WideString;\r\n WC: WideChar;\r\nbegin\r\n if foAnsiFile in WideFileOptions then\r\n begin\r\n AnsiS := AnsiString(GetTextStr); // explicit Unicode conversion\r\n Stream.Write(AnsiS[1], Length(AnsiS) * SizeOf(AnsiChar));\r\n end\r\n else\r\n begin\r\n if foUnicodeLB in WideFileOptions then\r\n begin\r\n WC := BOM_LSB_FIRST;\r\n Stream.Write(WC, SizeOf(WC));\r\n end;\r\n WideS := GetTextStr;\r\n Stream.Write(WideS[1], Length(WideS) * SizeOf(WideChar));\r\n end;\r\nend;\r\n\r\nprocedure TJclWideStrings.SetCapacity(NewCapacity: Integer);\r\nbegin\r\nend;\r\n\r\nprocedure TJclWideStrings.SetCommaText(const Value: WideString);\r\nbegin\r\n SetDelimitedTextEx(',', '\"', Value);\r\nend;\r\n\r\nprocedure TJclWideStrings.SetDelimitedText(const Value: WideString);\r\nbegin\r\n SetDelimitedTextEx(Delimiter, QuoteChar, Value);\r\nend;\r\n\r\nprocedure TJclWideStrings.SetDelimitedTextEx(ADelimiter, AQuoteChar: WideChar;\r\n const Value: WideString);\r\nvar\r\n P, P1: PWideChar;\r\n S: WideString;\r\n\r\n procedure IgnoreWhiteSpace(var P: PWideChar);\r\n begin\r\n while True do\r\n case P^ of\r\n WideChar(1)..WideChar(32):\r\n Inc(P);\r\n else\r\n Break;\r\n end;\r\n end;\r\n\r\nbegin\r\n BeginUpdate;\r\n try\r\n Clear;\r\n P := PWideChar(Value);\r\n IgnoreWhiteSpace(P);\r\n while P[0] <> WideChar(0) do\r\n begin\r\n if P[0] = AQuoteChar then\r\n S := WideExtractQuotedStr(P, AQuoteChar)\r\n else\r\n begin\r\n P1 := P;\r\n while (P[0] > WideChar(32)) and (P[0] <> ADelimiter) do\r\n Inc(P);\r\n SetString(S, P1, P - P1);\r\n end;\r\n Add(S);\r\n\r\n IgnoreWhiteSpace(P);\r\n if P[0] = ADelimiter then\r\n begin\r\n Inc(P);\r\n IgnoreWhiteSpace(P);\r\n end;\r\n end;\r\n finally\r\n EndUpdate;\r\n end;\r\nend;\r\n\r\nprocedure TJclWideStrings.SetText(Text: PWideChar);\r\nbegin\r\n SetTextStr(Text);\r\nend;\r\n\r\nprocedure TJclWideStrings.SetTextStr(const Value: WideString);\r\nvar\r\n P, Start: PWideChar;\r\n S: WideString;\r\n Len: Integer;\r\nbegin\r\n BeginUpdate;\r\n try\r\n Clear;\r\n if Value <> '' then\r\n begin\r\n P := PWideChar(Value);\r\n if P <> nil then\r\n begin\r\n while P[0] <> WideChar(0) do\r\n begin\r\n Start := P;\r\n while True do\r\n begin\r\n case P[0] of\r\n WideChar(0), WideChar(10), WideChar(13):\r\n Break;\r\n end;\r\n Inc(P);\r\n end;\r\n Len := P - Start;\r\n if Len > 0 then\r\n begin\r\n SetString(S, Start, Len);\r\n AddObject(S, nil); // consumes most time\r\n end\r\n else\r\n AddObject('', nil);\r\n if P[0] = WideChar(13) then\r\n Inc(P);\r\n if P[0] = WideChar(10) then\r\n Inc(P);\r\n end;\r\n end;\r\n end;\r\n finally\r\n EndUpdate;\r\n end;\r\nend;\r\n\r\nprocedure TJclWideStrings.SetUpdateState(Updating: Boolean);\r\nbegin\r\nend;\r\n\r\nprocedure TJclWideStrings.SetValue(const Name, Value: WideString);\r\nvar\r\n Idx: Integer;\r\nbegin\r\n Idx := IndexOfName(Name);\r\n if Idx >= 0 then\r\n SetValueFromIndex(Idx, Value)\r\n else\r\n if Value <> '' then\r\n Add(Name + NameValueSeparator + Value);\r\nend;\r\n\r\nprocedure TJclWideStrings.SetValueFromIndex(Index: Integer; const Value: WideString);\r\nvar\r\n S: WideString;\r\n I: Integer;\r\nbegin\r\n if Value = '' then\r\n Delete(Index)\r\n else\r\n begin\r\n if Index < 0 then\r\n Index := Add('');\r\n S := GetP(Index)^;\r\n I := WidePos(NameValueSeparator, S);\r\n if I > 0 then\r\n System.Delete(S, I, MaxInt);\r\n S := S + NameValueSeparator + Value;\r\n Put(Index, S);\r\n end;\r\nend;\r\n\r\nprocedure TJclWideStrings.WriteData(Writer: TWriter);\r\nvar\r\n I: Integer;\r\nbegin\r\n Writer.WriteListBegin;\r\n for I := 0 to Count - 1 do\r\n Writer.WriteWideString(GetP(I)^);\r\n Writer.WriteListEnd;\r\nend;\r\n\r\n//=== { TJclWideStringList } =======================================================\r\n\r\nconstructor TJclWideStringList.Create;\r\nbegin\r\n inherited Create;\r\n FList := TList.Create;\r\nend;\r\n\r\ndestructor TJclWideStringList.Destroy;\r\nbegin\r\n FOnChange := nil;\r\n FOnChanging := nil;\r\n Inc(FUpdateCount); // do not call unnecessary functions\r\n Clear;\r\n FList.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJclWideStringList.AddObject(const S: WideString; AObject: TObject): Integer;\r\nbegin\r\n if not Sorted then\r\n Result := Count\r\n else\r\n if Find(S, Result) then\r\n case Duplicates of\r\n dupIgnore:\r\n Exit;\r\n dupError:\r\n raise EListError.CreateRes(@SDuplicateString);\r\n end;\r\n InsertObject(Result, S, AObject);\r\nend;\r\n\r\nprocedure TJclWideStringList.Changed;\r\nbegin\r\n if Assigned(FOnChange) then\r\n FOnChange(Self);\r\nend;\r\n\r\nprocedure TJclWideStringList.Changing;\r\nbegin\r\n if Assigned(FOnChanging) then\r\n FOnChanging(Self);\r\nend;\r\n\r\nprocedure TJclWideStringList.Clear;\r\nvar\r\n I: Integer;\r\n Item: PWStringItem;\r\nbegin\r\n if FUpdateCount = 0 then\r\n Changing;\r\n for I := 0 to Count - 1 do\r\n begin\r\n Item := PWStringItem(FList[I]);\r\n Item.FString := '';\r\n FreeMem(Item);\r\n end;\r\n FList.Clear;\r\n if FUpdateCount = 0 then\r\n Changed;\r\nend;\r\n\r\nfunction TJclWideStringList.CompareStrings(const S1, S2: WideString): Integer;\r\nbegin\r\n if CaseSensitive then\r\n Result := WideCompareStr(S1, S2)\r\n else\r\n Result := WideCompareText(S1, S2);\r\nend;\r\n\r\nthreadvar\r\n CustomSortList: TJclWideStringList;\r\n CustomSortCompare: TJclWideStringListSortCompare;\r\n\r\nfunction WStringListCustomSort(Item1, Item2: Pointer): Integer;\r\nbegin\r\n Result := CustomSortCompare(CustomSortList,\r\n CustomSortList.FList.IndexOf(Item1),\r\n CustomSortList.FList.IndexOf(Item2));\r\nend;\r\n\r\nprocedure TJclWideStringList.CustomSort(Compare: TJclWideStringListSortCompare);\r\nvar\r\n TempList: TJclWideStringList;\r\n TempCompare: TJclWideStringListSortCompare;\r\nbegin\r\n TempList := CustomSortList;\r\n TempCompare := CustomSortCompare;\r\n CustomSortList := Self;\r\n CustomSortCompare := Compare;\r\n try\r\n Changing;\r\n FList.Sort(WStringListCustomSort);\r\n Changed;\r\n finally\r\n CustomSortList := TempList;\r\n CustomSortCompare := TempCompare;\r\n end;\r\nend;\r\n\r\nprocedure TJclWideStringList.Delete(Index: Integer);\r\nvar\r\n Item: PWStringItem;\r\nbegin\r\n if FUpdateCount = 0 then\r\n Changing;\r\n Item := PWStringItem(FList[Index]);\r\n FList.Delete(Index);\r\n Item.FString := '';\r\n FreeMem(Item);\r\n if FUpdateCount = 0 then\r\n Changed;\r\nend;\r\n\r\nprocedure TJclWideStringList.Exchange(Index1, Index2: Integer);\r\nbegin\r\n if FUpdateCount = 0 then\r\n Changing;\r\n FList.Exchange(Index1, Index2);\r\n if FUpdateCount = 0 then\r\n Changed;\r\nend;\r\n\r\nfunction TJclWideStringList.Find(const S: WideString; var Index: Integer): Boolean;\r\nvar\r\n L, H, I, C: Integer;\r\nbegin\r\n Result := False;\r\n if Sorted then\r\n begin\r\n L := 0;\r\n H := Count - 1;\r\n while L <= H do\r\n begin\r\n I := (L + H) shr 1;\r\n C := CompareStrings(GetItem(I).FString, S);\r\n if C < 0 then\r\n L := I + 1\r\n else\r\n begin\r\n H := I - 1;\r\n if C = 0 then\r\n begin\r\n Result := True;\r\n if Duplicates <> dupAccept then\r\n L := I;\r\n end;\r\n end;\r\n end;\r\n Index := L;\r\n end\r\n else\r\n begin\r\n Index := IndexOf(S);\r\n Result := Index <> -1;\r\n end;\r\nend;\r\n\r\nfunction TJclWideStringList.GetCapacity: Integer;\r\nbegin\r\n Result := FList.Capacity;\r\nend;\r\n\r\nfunction TJclWideStringList.GetCount: Integer;\r\nbegin\r\n Result := FList.Count;\r\nend;\r\n\r\nfunction TJclWideStringList.GetItem(Index: Integer): PWStringItem;\r\nbegin\r\n Result := FList[Index];\r\nend;\r\n\r\nfunction TJclWideStringList.GetObject(Index: Integer): TObject;\r\nbegin\r\n Result := GetItem(Index).FObject;\r\nend;\r\n\r\nfunction TJclWideStringList.GetP(Index: Integer): PWideString;\r\nbegin\r\n Result := Addr(GetItem(Index).FString);\r\nend;\r\n\r\nfunction TJclWideStringList.IndexOf(const S: WideString): Integer;\r\nbegin\r\n if Sorted then\r\n begin\r\n Result := -1;\r\n if not Find(S, Result) then\r\n Result := -1;\r\n end\r\n else\r\n begin\r\n for Result := 0 to Count - 1 do\r\n if CompareStrings(GetItem(Result).FString, S) = 0 then\r\n Exit;\r\n Result := -1;\r\n end;\r\nend;\r\n\r\nprocedure TJclWideStringList.InsertObject(Index: Integer; const S: WideString;\r\n AObject: TObject);\r\nvar\r\n P: PWStringItem;\r\nbegin\r\n if FUpdateCount = 0 then\r\n Changing;\r\n FList.Insert(Index, nil); // error check\r\n P := AllocMem(SizeOf(TWStringItem));\r\n FList[Index] := P;\r\n\r\n Put(Index, S);\r\n if AObject <> nil then\r\n PutObject(Index, AObject);\r\n if FUpdateCount = 0 then\r\n Changed;\r\nend;\r\n\r\nprocedure TJclWideStringList.Put(Index: Integer; const Value: WideString);\r\nbegin\r\n if FUpdateCount = 0 then\r\n Changing;\r\n GetItem(Index).FString := Value;\r\n if FUpdateCount = 0 then\r\n Changed;\r\nend;\r\n\r\nprocedure TJclWideStringList.PutObject(Index: Integer; AObject: TObject);\r\nbegin\r\n if FUpdateCount = 0 then\r\n Changing;\r\n GetItem(Index).FObject := AObject;\r\n if FUpdateCount = 0 then\r\n Changed;\r\nend;\r\n\r\nprocedure TJclWideStringList.SetCapacity(NewCapacity: Integer);\r\nbegin\r\n FList.Capacity := NewCapacity;\r\nend;\r\n\r\nprocedure TJclWideStringList.SetCaseSensitive(const Value: Boolean);\r\nbegin\r\n if Value <> FCaseSensitive then\r\n begin\r\n FCaseSensitive := Value;\r\n if Sorted then\r\n begin\r\n Sorted := False;\r\n Sorted := True; // re-sort\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJclWideStringList.SetSorted(Value: Boolean);\r\nbegin\r\n if Value <> FSorted then\r\n begin\r\n FSorted := Value;\r\n if FSorted then\r\n begin\r\n FSorted := False;\r\n Sort;\r\n FSorted := True;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJclWideStringList.SetUpdateState(Updating: Boolean);\r\nbegin\r\n if Updating then\r\n Changing\r\n else\r\n Changed;\r\nend;\r\n\r\nfunction DefaultSort(List: TJclWideStringList; Index1, Index2: Integer): Integer;\r\nbegin\r\n Result := List.CompareStrings(List.GetItem(Index1).FString, List.GetItem(Index2).FString);\r\nend;\r\n\r\nprocedure TJclWideStringList.Sort;\r\nbegin\r\n if not Sorted then\r\n CustomSort(DefaultSort);\r\nend;\r\n\r\n{$ENDIF ~SUPPORTS_UNICODE}\r\n\r\nfunction StringsToMultiSz(var Dest: PWideMultiSz; const Source: TJclWideStrings): PWideMultiSz;\r\nvar\r\n I, TotalLength: Integer;\r\n P: PWideMultiSz;\r\nbegin\r\n Assert(Source <> nil);\r\n TotalLength := 1;\r\n for I := 0 to Source.Count - 1 do\r\n if Source[I] = '' then\r\n raise EJclWideStringError.CreateRes(@RsInvalidEmptyStringItem)\r\n else\r\n Inc(TotalLength, StrLenW(PWideChar(Source[I])) + 1);\r\n AllocateMultiSz(Dest, TotalLength);\r\n P := Dest;\r\n for I := 0 to Source.Count - 1 do\r\n begin\r\n P := StrECopyW(P, PWideChar(Source[I]));\r\n Inc(P);\r\n end;\r\n P^:= #0;\r\n Result := Dest;\r\nend;\r\n\r\nprocedure MultiSzToStrings(const Dest: TJclWideStrings; const Source: PWideMultiSz);\r\nvar\r\n P: PWideMultiSz;\r\nbegin\r\n Assert(Dest <> nil);\r\n Dest.BeginUpdate;\r\n try\r\n Dest.Clear;\r\n if Source <> nil then\r\n begin\r\n P := Source;\r\n while P^ <> #0 do\r\n begin\r\n Dest.Add(P);\r\n P := StrEndW(P);\r\n Inc(P);\r\n end;\r\n end;\r\n finally\r\n Dest.EndUpdate;\r\n end;\r\nend;\r\n\r\nfunction MultiSzLength(const Source: PWideMultiSz): SizeInt;\r\nvar\r\n P: PWideMultiSz;\r\nbegin\r\n Result := 0;\r\n if Source <> nil then\r\n begin\r\n P := Source;\r\n repeat\r\n Inc(Result, StrLenW(P) + 1);\r\n P := StrEndW(P);\r\n Inc(P);\r\n until P^ = #0;\r\n Inc(Result);\r\n end;\r\nend;\r\n\r\nprocedure AllocateMultiSz(var Dest: PWideMultiSz; Len: SizeInt);\r\nbegin\r\n if Len > 0 then\r\n GetMem(Dest, Len * SizeOf(WideChar))\r\n else\r\n Dest := nil;\r\nend;\r\n\r\nprocedure FreeMultiSz(var Dest: PWideMultiSz);\r\nbegin\r\n if Dest <> nil then\r\n FreeMem(Dest);\r\n Dest := nil;\r\nend;\r\n\r\nfunction MultiSzDup(const Source: PWideMultiSz): PWideMultiSz;\r\nvar\r\n Len: Integer;\r\nbegin\r\n if Source <> nil then\r\n begin\r\n Len := MultiSzLength(Source);\r\n Result := nil;\r\n AllocateMultiSz(Result, Len);\r\n Move(Source^, Result^, Len * SizeOf(WideChar));\r\n end\r\n else\r\n Result := nil;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jcl/source/common/bzip2.pas", "content": "{**************************************************************************************************}\r\n{ }\r\n{ Project JEDI Code Library (JCL) }\r\n{ }\r\n{ The contents of this file are subject to the Mozilla Public License Version 1.1 (the \"License\"); }\r\n{ you may not use this file except in compliance with the License. You may obtain a copy of the }\r\n{ License at http://www.mozilla.org/MPL/ }\r\n{ }\r\n{ Software distributed under the License is distributed on an \"AS IS\" basis, WITHOUT WARRANTY OF }\r\n{ ANY KIND, either express or implied. See the License for the specific language governing rights }\r\n{ and limitations under the License. }\r\n{ }\r\n{ The Original Code is bzip2.pas. }\r\n{ }\r\n{ The Initial Developer of the Original Code is Florent Ouchet. }\r\n{ Portions created by Florent Ouchet are Copyright (C) of Florent Ouchet. All rights reserved. }\r\n{ Portions created by Julian Seward are Copyright (C) 1996-2006 Julian Seward }\r\n{ }\r\n{ Contributor(s): }\r\n{ }\r\n{ The latest release of BZIP2 is available from http://www.bzip.org/ }\r\n{ }\r\n{**************************************************************************************************}\r\n{ }\r\n{ Header conversion of bzlib.h }\r\n{ }\r\n{**************************************************************************************************}\r\n{ }\r\n{ Last modified: $Date:: 2012-04-19 20:13:33 +0200 (jeu. 19 avr. 2012) $ }\r\n{ Revision: $Rev:: 3779 $ }\r\n{ Author: $Author:: outchy $ }\r\n{ }\r\n{**************************************************************************************************}\r\n\r\nunit bzip2;\r\n\r\n{$I jcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n JclBase,\r\n JclSysUtils;\r\n\r\n//DOM-IGNORE-BEGIN\r\n\r\n{\r\n/*-------------------------------------------------------------*/\r\n/*--- Public header file for the library. ---*/\r\n/*--- bzlib.h ---*/\r\n/*-------------------------------------------------------------*/\r\n\r\n/* ------------------------------------------------------------------\r\n This file is part of bzip2/libbzip2, a program and library for\r\n lossless, block-sorting data compression.\r\n\r\n bzip2/libbzip2 version 1.0.4 of 20 December 2006\r\n Copyright (C) 1996-2006 Julian Seward \r\n\r\n Please read the WARNING, DISCLAIMER and PATENTS sections in the\r\n README file.\r\n\r\n This program is released under the terms of the license contained\r\n in the file LICENSE.\r\n ------------------------------------------------------------------ */\r\n}\r\n\r\nconst\r\n BZ_RUN = 0;\r\n BZ_FLUSH = 1;\r\n BZ_FINISH = 2;\r\n\r\n BZ_OK = 0;\r\n BZ_RUN_OK = 1;\r\n BZ_FLUSH_OK = 2;\r\n BZ_FINISH_OK = 3;\r\n BZ_STREAM_END = 4;\r\n BZ_SEQUENCE_ERROR = -1;\r\n BZ_PARAM_ERROR = -2;\r\n BZ_MEM_ERROR = -3;\r\n BZ_DATA_ERROR = -4;\r\n BZ_DATA_ERROR_MAGIC = -5;\r\n BZ_IO_ERROR = -6;\r\n BZ_UNEXPECTED_EOF = -7;\r\n BZ_OUTBUFF_FULL = -8;\r\n BZ_CONFIG_ERROR = -9;\r\n\r\ntype\r\n bz_stream = record\r\n next_in: PByte;\r\n avail_in: Cardinal;\r\n total_in_lo32: Cardinal;\r\n total_in_hi32: Cardinal;\r\n\r\n next_out: PByte;\r\n avail_out: Cardinal;\r\n total_out_lo32: Cardinal;\r\n total_out_hi32: Cardinal;\r\n\r\n state: Pointer;\r\n\r\n bzalloc: function (opaque: Pointer; n, m: Integer): Pointer; cdecl; // returns n*m bytes\r\n bzfree: procedure (opaque, p: Pointer); cdecl; // free p\r\n opaque: Pointer;\r\n end;\r\n\r\n{$IFNDEF BZIP2_LINKONREQUEST}\r\n//-- Core (low-level) library functions --\r\n\r\nfunction BZ2_bzCompressInit(var strm: bz_stream;\r\n blockSize100k, verbosity, workFactor: Integer): Integer;\r\n {$IFDEF BZIP2_EXPORT_STDCALL}stdcall;{$ENDIF BZIP2_EXPORT_STDCALL}\r\n {$IFDEF BZIP2_EXPORT_CDECL}cdecl;{$ENDIF BZIP2_EXPORT_CDECL}\r\n\r\nfunction BZ2_bzCompress(var strm: bz_stream; action: Integer): Integer;\r\n {$IFDEF BZIP2_EXPORT_STDCALL}stdcall;{$ENDIF BZIP2_EXPORT_STDCALL}\r\n {$IFDEF BZIP2_EXPORT_CDECL}cdecl;{$ENDIF BZIP2_EXPORT_CDECL}\r\n\r\nfunction BZ2_bzCompressEnd(var strm: bz_stream): Integer;\r\n {$IFDEF BZIP2_EXPORT_STDCALL}stdcall;{$ENDIF BZIP2_EXPORT_STDCALL}\r\n {$IFDEF BZIP2_EXPORT_CDECL}cdecl;{$ENDIF BZIP2_EXPORT_CDECL}\r\n\r\nfunction BZ2_bzDecompressInit(var strm: bz_stream;\r\n verbosity, small: Integer): Integer;\r\n {$IFDEF BZIP2_EXPORT_STDCALL}stdcall;{$ENDIF BZIP2_EXPORT_STDCALL}\r\n {$IFDEF BZIP2_EXPORT_CDECL}cdecl;{$ENDIF BZIP2_EXPORT_CDECL}\r\n\r\nfunction BZ2_bzDecompress(var strm: bz_stream): Integer;\r\n {$IFDEF BZIP2_EXPORT_STDCALL}stdcall;{$ENDIF BZIP2_EXPORT_STDCALL}\r\n {$IFDEF BZIP2_EXPORT_CDECL}cdecl;{$ENDIF BZIP2_EXPORT_CDECL}\r\n\r\nfunction BZ2_bzDecompressEnd(var strm: bz_stream): Integer;\r\n {$IFDEF BZIP2_EXPORT_STDCALL}stdcall;{$ENDIF BZIP2_EXPORT_STDCALL}\r\n {$IFDEF BZIP2_EXPORT_CDECL}cdecl;{$ENDIF BZIP2_EXPORT_CDECL}\r\n\r\n//-- High(er) level library functions --\r\n\r\ntype\r\n BZFILE = Pointer;\r\n\r\n// TODO: no stdio for static link (problems while linking stdin/stdout/stderr)\r\n\r\n{#ifndef BZ_NO_STDIO\r\n#define BZ_MAX_UNUSED 5000\r\n\r\ntypedef void BZFILE;\r\n\r\nBZ_EXTERN BZFILE* BZ_API(BZ2_bzReadOpen) ( \r\n int* bzerror, \r\n FILE* f, \r\n int verbosity, \r\n int small,\r\n void* unused, \r\n int nUnused \r\n );\r\n\r\nBZ_EXTERN void BZ_API(BZ2_bzReadClose) ( \r\n int* bzerror, \r\n BZFILE* b \r\n );\r\n\r\nBZ_EXTERN void BZ_API(BZ2_bzReadGetUnused) ( \r\n int* bzerror, \r\n BZFILE* b, \r\n void** unused, \r\n int* nUnused \r\n );\r\n\r\nBZ_EXTERN int BZ_API(BZ2_bzRead) ( \r\n int* bzerror, \r\n BZFILE* b, \r\n void* buf, \r\n int len \r\n );\r\n\r\nBZ_EXTERN BZFILE* BZ_API(BZ2_bzWriteOpen) ( \r\n int* bzerror, \r\n FILE* f, \r\n int blockSize100k, \r\n int verbosity, \r\n int workFactor \r\n );\r\n\r\nBZ_EXTERN void BZ_API(BZ2_bzWrite) ( \r\n int* bzerror, \r\n BZFILE* b, \r\n void* buf, \r\n int len \r\n );\r\n\r\nBZ_EXTERN void BZ_API(BZ2_bzWriteClose) ( \r\n int* bzerror, \r\n BZFILE* b, \r\n int abandon, \r\n unsigned int* nbytes_in, \r\n unsigned int* nbytes_out \r\n );\r\n\r\nBZ_EXTERN void BZ_API(BZ2_bzWriteClose64) ( \r\n int* bzerror, \r\n BZFILE* b, \r\n int abandon, \r\n unsigned int* nbytes_in_lo32, \r\n unsigned int* nbytes_in_hi32, \r\n unsigned int* nbytes_out_lo32, \r\n unsigned int* nbytes_out_hi32\r\n );\r\n#endif}\r\n\r\n\r\n//- Utility functions --\r\n\r\nfunction BZ2_bzBuffToBuffCompress(dest: PByte; destLen: PCardinal; source: PByte;\r\n sourceLen: Cardinal; blockSize100k, verbosity, workFactor: Integer): Integer;\r\n {$IFDEF BZIP2_EXPORT_STDCALL}stdcall;{$ENDIF BZIP2_EXPORT_STDCALL}\r\n {$IFDEF BZIP2_EXPORT_CDECL}cdecl;{$ENDIF BZIP2_EXPORT_CDECL}\r\n\r\nfunction BZ2_bzBuffToBuffDecompress(dest: PByte; destLen: PCardinal; source: PByte;\r\n sourceLen: Cardinal; small, verbosity: Integer): Integer;\r\n {$IFDEF BZIP2_EXPORT_STDCALL}stdcall;{$ENDIF BZIP2_EXPORT_STDCALL}\r\n {$IFDEF BZIP2_EXPORT_CDECL}cdecl;{$ENDIF BZIP2_EXPORT_CDECL}\r\n\r\n{\r\n/*--\r\n Code contributed by Yoshioka Tsuneo (tsuneo@rr.iij4u.or.jp)\r\n to support better zlib compatibility.\r\n This code is not _officially_ part of libbzip2 (yet);\r\n I haven't tested it, documented it, or considered the\r\n threading-safeness of it.\r\n If this code breaks, please contact both Yoshioka and me.\r\n--*/\r\n}\r\n\r\nfunction BZ2_bzlibVersion: PAnsiChar;\r\n {$IFDEF BZIP2_EXPORT_STDCALL}stdcall;{$ENDIF BZIP2_EXPORT_STDCALL}\r\n {$IFDEF BZIP2_EXPORT_CDECL}cdecl;{$ENDIF BZIP2_EXPORT_CDECL}\r\n\r\n// no STDIO (see above)\r\n{\r\nfunction BZ2_bzopen(path, mode: PChar): BZFILE;\r\n\r\nfunction BZ2_bzdopen(fd: Integer; mode: PChar): BZFILE;\r\n\r\nfunction BZ2_bzread(b: BZFILE; buf: Pointer; len: Integer): Integer;\r\n\r\nfunction BZ2_bzwrite(b: BZFILE; buf: Pointer; len: Integer): Integer;\r\n\r\nfunction BZ2_bzflush(b: BZFILE): Integer;\r\n\r\nprocedure BZ2_bzclose(b: BZFILE);\r\n\r\nfunction BZ2_bzerror(b: BZFILE; errnum: PInteger): PChar;\r\n}\r\n\r\n{$ELSE BZIP2_LINKONREQUEST}\r\ntype\r\n BZ2_bzCompressInit_func = function(var strm: bz_stream;\r\n blockSize100k, verbosity, workFactor: Integer): Integer;\r\n {$IFDEF BZIP2_EXPORT_STDCALL}stdcall;{$ENDIF BZIP2_EXPORT_STDCALL}\r\n {$IFDEF BZIP2_EXPORT_CDECL}cdecl;{$ENDIF BZIP2_EXPORT_CDECL}\r\n BZ2_bzCompress_func = function(var strm: bz_stream;\r\n action: Integer): Integer;\r\n {$IFDEF BZIP2_EXPORT_STDCALL}stdcall;{$ENDIF BZIP2_EXPORT_STDCALL}\r\n {$IFDEF BZIP2_EXPORT_CDECL}cdecl;{$ENDIF BZIP2_EXPORT_CDECL}\r\n BZ2_bzCompressEnd_func = function(var strm: bz_stream): Integer;\r\n {$IFDEF BZIP2_EXPORT_STDCALL}stdcall;{$ENDIF BZIP2_EXPORT_STDCALL}\r\n {$IFDEF BZIP2_EXPORT_CDECL}cdecl;{$ENDIF BZIP2_EXPORT_CDECL}\r\n BZ2_bzDecompressInit_func = function(var strm: bz_stream;\r\n verbosity, small: Integer): Integer;\r\n {$IFDEF BZIP2_EXPORT_STDCALL}stdcall;{$ENDIF BZIP2_EXPORT_STDCALL}\r\n {$IFDEF BZIP2_EXPORT_CDECL}cdecl;{$ENDIF BZIP2_EXPORT_CDECL}\r\n BZ2_bzDecompress_func = function(var strm: bz_stream): Integer;\r\n {$IFDEF BZIP2_EXPORT_STDCALL}stdcall;{$ENDIF BZIP2_EXPORT_STDCALL}\r\n {$IFDEF BZIP2_EXPORT_CDECL}cdecl;{$ENDIF BZIP2_EXPORT_CDECL}\r\n BZ2_bzDecompressEnd_func = function(var strm: bz_stream): Integer;\r\n {$IFDEF BZIP2_EXPORT_STDCALL}stdcall;{$ENDIF BZIP2_EXPORT_STDCALL}\r\n {$IFDEF BZIP2_EXPORT_CDECL}cdecl;{$ENDIF BZIP2_EXPORT_CDECL}\r\n BZ2_bzBuffToBuffCompress_func = function(dest: PByte; destLen: PCardinal;\r\n source: PByte; sourceLen: Cardinal;\r\n blockSize100k, verbosity, workFactor: Integer): Integer;\r\n {$IFDEF BZIP2_EXPORT_STDCALL}stdcall;{$ENDIF BZIP2_EXPORT_STDCALL}\r\n {$IFDEF BZIP2_EXPORT_CDECL}cdecl;{$ENDIF BZIP2_EXPORT_CDECL}\r\n BZ2_bzBuffToBuffDecompress_func = function(dest: PByte; destLen: PCardinal;\r\n source: PByte; sourceLen: Cardinal; small, verbosity: Integer): Integer;\r\n {$IFDEF BZIP2_EXPORT_STDCALL}stdcall;{$ENDIF BZIP2_EXPORT_STDCALL}\r\n {$IFDEF BZIP2_EXPORT_CDECL}cdecl;{$ENDIF BZIP2_EXPORT_CDECL}\r\n BZ2_bzlibVersion_func = function: PAnsiChar;\r\n {$IFDEF BZIP2_EXPORT_STDCALL}stdcall;{$ENDIF BZIP2_EXPORT_STDCALL}\r\n {$IFDEF BZIP2_EXPORT_CDECL}cdecl;{$ENDIF BZIP2_EXPORT_CDECL}\r\n\r\nvar\r\n BZ2_bzCompressInit: BZ2_bzCompressInit_func = nil;\r\n BZ2_bzCompress: BZ2_bzCompress_func = nil;\r\n BZ2_bzCompressEnd: BZ2_bzCompressEnd_func = nil;\r\n BZ2_bzDecompressInit: BZ2_bzDecompressInit_func = nil;\r\n BZ2_bzDecompress: BZ2_bzDecompress_func = nil;\r\n BZ2_bzDecompressEnd: BZ2_bzDecompressEnd_func = nil;\r\n BZ2_bzBuffToBuffCompress: BZ2_bzBuffToBuffCompress_func = nil;\r\n BZ2_bzBuffToBuffDecompress: BZ2_bzBuffToBuffDecompress_func = nil;\r\n BZ2_bzlibVersion: BZ2_bzlibVersion_func = nil;\r\n{$ENDIF BZIP2_LINKONREQUEST}\r\n\r\nvar\r\n bz2_internal_error_event: procedure(errcode: Integer) of object = nil;\r\n\r\n//DOM-IGNORE-END\r\n\r\nconst\r\n {$IFDEF MSWINDOWS}\r\n BZip2DefaultLibraryName = 'bzip2.dll'; // from http://gnuwin32.sourceforge.net/\r\n {$ENDIF MSWINDOWS}\r\n {$IFDEF UNIX}\r\n BZip2DefaultLibraryName = 'libbz2.so.1';\r\n {$ENDIF UNIX}\r\n BZip2CompressInitDefaultExportName = 'BZ2_bzCompressInit';\r\n BZip2CompressDefaultExportName = 'BZ2_bzCompress';\r\n BZip2CompressEndDefaultExportName = 'BZ2_bzCompressEnd';\r\n BZip2DecompressInitDefaultExportName = 'BZ2_bzDecompressInit';\r\n BZip2DecompressDefaultExportName = 'BZ2_bzDecompress';\r\n BZip2DecompressEndDefaultExportName = 'BZ2_bzDecompressEnd';\r\n BZip2BuffToBuffCompressDefaultExportName = 'BZ2_bzBuffToBuffCompress';\r\n BZip2BuffToBuffDecompressDefaultExportName = 'BZ2_bzBuffToBuffDecompress';\r\n BZip2LibVersionDefaultExportName = 'BZ2_bzlibVersion';\r\n\r\n{$IFDEF BZIP2_LINKONREQUEST}\r\nvar\r\n BZip2LibraryName: string = BZip2DefaultLibraryName;\r\n BZip2CompressInitExportName: string = BZip2CompressInitDefaultExportName;\r\n BZip2CompressExportName: string = BZip2CompressDefaultExportName;\r\n BZip2CompressEndExportName: string = BZip2CompressEndDefaultExportName;\r\n BZip2DecompressInitExportName: string = BZip2DecompressInitDefaultExportName;\r\n BZip2DecompressExportName: string = BZip2DecompressDefaultExportName;\r\n BZip2DecompressEndExportName: string = BZip2DecompressEndDefaultExportName;\r\n BZip2BuffToBuffCompressExportName: string = BZip2BuffToBuffCompressDefaultExportName;\r\n BZip2BuffToBuffDecompressExportName: string = BZip2BuffToBuffDecompressDefaultExportName;\r\n BZip2LibVersionExportName: string = BZip2LibVersionDefaultExportName;\r\n BZip2LibraryHandle: TModuleHandle = INVALID_MODULEHANDLE_VALUE;\r\n{$ENDIF BZIP2_LINKONREQUEST}\r\n\r\nfunction LoadBZip2: Boolean;\r\nfunction IsBZip2Loaded: Boolean;\r\nprocedure UnloadBZip2;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jcl.svn.sourceforge.net/svnroot/jcl/tags/JCL-2.4-Build4571/jcl/source/common/bzip2.pas $';\r\n Revision: '$Revision: 3779 $';\r\n Date: '$Date: 2012-04-19 20:13:33 +0200 (jeu. 19 avr. 2012) $';\r\n LogPath: 'JCL\\source\\common';\r\n Extra: '';\r\n Data: nil\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n {$IFDEF HAS_UNITSCOPE}\r\n {$IFDEF BZIP2_LINKONREQUEST}\r\n {$IFDEF MSWINDOWS}\r\n Winapi.Windows,\r\n {$ENDIF MSWINDOWS}\r\n {$ENDIF BZIP2_LINKONREQUEST}\r\n System.Types,\r\n {$IFDEF HAS_UNIT_LIBC}\r\n Libc,\r\n {$ENDIF HAS_UNIT_LIBC}\r\n System.SysUtils;\r\n {$ELSE ~HAS_UNITSCOPE}\r\n {$IFDEF BZIP2_LINKONREQUEST}\r\n {$IFDEF MSWINDOWS}\r\n Windows,\r\n {$ENDIF MSWINDOWS}\r\n {$ENDIF BZIP2_LINKONREQUEST}\r\n Types,\r\n {$IFDEF HAS_UNIT_LIBC}\r\n Libc,\r\n {$ENDIF HAS_UNIT_LIBC}\r\n SysUtils;\r\n {$ENDIF ~HAS_UNITSCOPE}\r\n\r\n{$IFDEF BZIP2_STATICLINK}\r\nfunction BZ2_bzCompressInit; external;\r\nfunction BZ2_bzCompress; external;\r\nfunction BZ2_bzCompressEnd; external;\r\nfunction BZ2_bzDecompressInit; external;\r\nfunction BZ2_bzDecompress; external;\r\nfunction BZ2_bzDecompressEnd; external;\r\nfunction BZ2_bzBuffToBuffCompress; external;\r\nfunction BZ2_bzBuffToBuffDecompress; external;\r\nfunction BZ2_bzlibVersion; external;\r\n// workaround to make the compiler aware of _BZ2_indexIntoF\r\n// an external must be declared for this function in order to make the compiler considering\r\n// the corresponding PUBDEF in bzlib.obj\r\n// source: CodeGear QA team\r\n{$IFDEF CPU32}\r\nfunction _BZ2_indexIntoF: Pointer;\r\n {$IFDEF BZIP2_EXPORT_STDCALL}stdcall;{$ENDIF BZIP2_EXPORT_STDCALL}\r\n {$IFDEF BZIP2_EXPORT_CDECL}cdecl;{$ENDIF BZIP2_EXPORT_CDECL} external;\r\n{$ENDIF CPU32}\r\n{$IFDEF CPU64}\r\nfunction BZ2_indexIntoF: Pointer; external;\r\n{$ENDIF CPU64}\r\n\r\n{$IFDEF CPU32}\r\n{$LINK ..\\windows\\obj\\bzip2\\win32\\bzlib.obj}\r\n{$LINK ..\\windows\\obj\\bzip2\\win32\\randtable.obj}\r\n{$LINK ..\\windows\\obj\\bzip2\\win32\\crctable.obj}\r\n{$LINK ..\\windows\\obj\\bzip2\\win32\\compress.obj}\r\n{$LINK ..\\windows\\obj\\bzip2\\win32\\decompress.obj}\r\n{$LINK ..\\windows\\obj\\bzip2\\win32\\huffman.obj}\r\n{$LINK ..\\windows\\obj\\bzip2\\win32\\blocksort.obj}\r\n{$ENDIF CPU32}\r\n{$IFDEF CPU64}\r\n{$LINK ..\\windows\\obj\\bzip2\\win64\\bzlib.obj}\r\n{$LINK ..\\windows\\obj\\bzip2\\win64\\randtable.obj}\r\n{$LINK ..\\windows\\obj\\bzip2\\win64\\crctable.obj}\r\n{$LINK ..\\windows\\obj\\bzip2\\win64\\compress.obj}\r\n{$LINK ..\\windows\\obj\\bzip2\\win64\\decompress.obj}\r\n{$LINK ..\\windows\\obj\\bzip2\\win64\\huffman.obj}\r\n{$LINK ..\\windows\\obj\\bzip2\\win64\\blocksort.obj}\r\n{$ENDIF CPU64}\r\n\r\n{$IFDEF CPU32}\r\nfunction _malloc(size: Longint): Pointer; cdecl;\r\n{$ENDIF CPU32}\r\n{$IFDEF CPU64}\r\nfunction malloc(size: SizeInt): Pointer;\r\n{$ENDIF CPU64}\r\nbegin\r\n GetMem(Result, Size);\r\nend;\r\n\r\n{$IFDEF CPU32}\r\nprocedure _free(pBlock: Pointer); cdecl;\r\n{$ENDIF CPU32}\r\n{$IFDEF CPU64}\r\nprocedure free(pBlock: Pointer);\r\n{$ENDIF CPU64}\r\nbegin\r\n FreeMem(pBlock);\r\nend;\r\n\r\n{$IFDEF CPU32}\r\nprocedure _bz_internal_error(errcode: Integer); cdecl;\r\n{$ENDIF CPU32}\r\n{$IFDEF CPU64}\r\nprocedure bz_internal_error(errcode: Integer);\r\n{$ENDIF CPU64}\r\nbegin\r\n if Assigned(bz2_internal_error_event) then\r\n bz2_internal_error_event(errcode);\r\nend;\r\n\r\n{$ENDIF BZIP2_STATICLINK}\r\n\r\n{$IFDEF BZIP2_LINKDLL}\r\nfunction BZ2_bzCompressInit; external BZip2DefaultLibraryName name BZip2CompressInitDefaultExportName;\r\nfunction BZ2_bzCompress; external BZip2DefaultLibraryName name BZip2CompressDefaultExportName;\r\nfunction BZ2_bzCompressEnd; external BZip2DefaultLibraryName name BZip2CompressEndDefaultExportName;\r\nfunction BZ2_bzDecompressInit; external BZip2DefaultLibraryName name BZip2DecompressInitDefaultExportName;\r\nfunction BZ2_bzDecompress; external BZip2DefaultLibraryName name BZip2DecompressDefaultExportName;\r\nfunction BZ2_bzDecompressEnd; external BZip2DefaultLibraryName name BZip2DecompressEndDefaultExportName;\r\nfunction BZ2_bzBuffToBuffCompress; external BZip2DefaultLibraryName name BZip2BuffToBuffCompressDefaultExportName;\r\nfunction BZ2_bzBuffToBuffDecompress; external BZip2DefaultLibraryName name BZip2BuffToBuffDecompressDefaultExportName;\r\nfunction BZ2_bzlibVersion; external BZip2DefaultLibraryName name BZip2LibVersionDefaultExportName;\r\n{$ENDIF BZIP2_LINKDLL}\r\n\r\nfunction LoadBZip2: Boolean;\r\n{$IFDEF BZIP2_LINKONREQUEST}\r\nbegin\r\n Result := BZip2LibraryHandle <> INVALID_MODULEHANDLE_VALUE;\r\n if Result then\r\n Exit;\r\n\r\n Result := JclSysUtils.LoadModule(BZip2LibraryHandle, BZip2LibraryName);\r\n if Result then\r\n begin\r\n @BZ2_bzCompressInit := GetModuleSymbol(BZip2LibraryHandle, BZip2CompressInitExportName);\r\n @BZ2_bzCompress := GetModuleSymbol(BZip2LibraryHandle, BZip2CompressExportName);\r\n @BZ2_bzCompressEnd := GetModuleSymbol(BZip2LibraryHandle, BZip2CompressEndExportName);\r\n @BZ2_bzDecompressInit := GetModuleSymbol(BZip2LibraryHandle, BZip2DecompressInitExportName);\r\n @BZ2_bzDecompress := GetModuleSymbol(BZip2LibraryHandle, BZip2DecompressExportName);\r\n @BZ2_bzDecompressEnd := GetModuleSymbol(BZip2LibraryHandle, BZip2DecompressEndExportName);\r\n @BZ2_bzBuffToBuffCompress := GetModuleSymbol(BZip2LibraryHandle, BZip2BuffToBuffCompressExportName);\r\n @BZ2_bzBuffToBuffDecompress := GetModuleSymbol(BZip2LibraryHandle, BZip2BuffToBuffDecompressExportName);\r\n @BZ2_bzlibVersion := GetModuleSymbol(BZip2LibraryHandle, BZip2LibVersionExportName);\r\n end;\r\nend;\r\n{$ELSE ~BZIP2_LINKONREQUEST}\r\nbegin\r\n Result := True;\r\nend;\r\n{$ENDIF ~BZIP2_LINKONREQUEST}\r\n\r\nfunction IsBZip2Loaded: Boolean;\r\nbegin\r\n {$IFDEF BZIP2_LINKONREQUEST}\r\n Result := BZip2LibraryHandle <> INVALID_MODULEHANDLE_VALUE;\r\n {$ELSE ~BZIP2_LINKONREQUEST}\r\n Result := True;\r\n {$ENDIF ~BZIP2_LINKONREQUEST}\r\nend;\r\n\r\nprocedure UnloadBZip2;\r\nbegin\r\n {$IFDEF BZIP2_LINKONREQUEST}\r\n JclSysUtils.UnloadModule(BZip2LibraryHandle);\r\n {$ENDIF BZIP2_LINKONREQUEST}\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jcl/source/common/dirinfo.txt", "content": "This is the directory where cross platform code resides." }, { "path": "External/Jedi/Jcl/source/common/pcre.pas", "content": "{**************************************************************************************************}\r\n{ }\r\n{ Project JEDI Code Library (JCL) }\r\n{ }\r\n{ The contents of this file are subject to the Mozilla Public License Version 1.1 (the \"License\"); }\r\n{ you may not use this file except in compliance with the License. You may obtain a copy of the }\r\n{ License at http://www.mozilla.org/MPL/ }\r\n{ }\r\n{ Software distributed under the License is distributed on an \"AS IS\" basis, WITHOUT WARRANTY OF }\r\n{ ANY KIND, either express or implied. See the License for the specific language governing rights }\r\n{ and limitations under the License. }\r\n{ }\r\n{ The Original Code is JclPRCE.pas. }\r\n{ }\r\n{ The Initial Developer of the Original Code is Peter Thornqvist. }\r\n{ Portions created by Peter Thornqvist are Copyright (C) of Peter Thornqvist. All rights reserved. }\r\n{ Portions created by University of Cambridge are }\r\n{ Copyright (C) 1997-2001 by University of Cambridge. }\r\n{ }\r\n{ Contributor(s): }\r\n{ Robert Rossmair (rrossmair) }\r\n{ Mario R. Carro }\r\n{ Florent Ouchet (outchy) }\r\n{ }\r\n{ The latest release of PCRE is always available from }\r\n{ ftp://ftp.csx.cam.ac.uk/pub/software/programming/pcre/pcre-xxx.tar.gz }\r\n{ }\r\n{**************************************************************************************************}\r\n{ }\r\n{ Header conversion of pcre.h }\r\n{ }\r\n{ }\r\n{**************************************************************************************************}\r\n{ }\r\n{ Last modified: $Date:: 2012-09-03 00:25:26 +0200 (lun. 03 sept. 2012) $ }\r\n{ Revision: $Rev:: 3855 $ }\r\n{ Author: $Author:: outchy $ }\r\n{ }\r\n{**************************************************************************************************}\r\n\r\nunit pcre;\r\n\r\n{$I jcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n JclBase,\r\n JclSysUtils;\r\n\r\n//DOM-IGNORE-BEGIN\r\n\r\n{$IFNDEF PCRE_RTL}\r\n\r\n(*************************************************\r\n* Perl-Compatible Regular Expressions *\r\n*************************************************)\r\n\r\n{$IFDEF SUPPORTS_WEAKPACKAGEUNIT}\r\n {$IFDEF UNITVERSIONING}\r\n {$WEAKPACKAGEUNIT OFF}\r\n {$ELSE ~UNITVERSIONING}\r\n {$WEAKPACKAGEUNIT ON}\r\n {$ENDIF ~UNITVERSIONING}\r\n{$ENDIF SUPPORTS_WEAKPACKAGEUNIT}\r\n\r\n// (p3) this is the switch to change between static and dynamic linking.\r\n// It is set to dynamic by default. To disable simply insert a '.' before the '$'\r\n//\r\n// NOTE: if you enable static linking of DLL, this means that the pcre.dll *must*\r\n// be in the users path or an AV will occur at startup\r\n\r\n(*$HPPEMIT '#include \"pcre.h\"'*)\r\n\r\nconst\r\n MAX_PATTERN_LENGTH = $10003;\r\n {$EXTERNALSYM MAX_PATTERN_LENGTH}\r\n MAX_QUANTIFY_REPEAT = $10000;\r\n {$EXTERNALSYM MAX_QUANTIFY_REPEAT}\r\n MAX_CAPTURE_COUNT = $FFFF;\r\n {$EXTERNALSYM MAX_CAPTURE_COUNT}\r\n MAX_NESTING_DEPTH = 200;\r\n {$EXTERNALSYM MAX_NESTING_DEPTH}\r\n\r\nconst\r\n (* Options *)\r\n PCRE_CASELESS = $00000001;\r\n {$EXTERNALSYM PCRE_CASELESS}\r\n PCRE_MULTILINE = $00000002;\r\n {$EXTERNALSYM PCRE_MULTILINE}\r\n PCRE_DOTALL = $00000004;\r\n {$EXTERNALSYM PCRE_DOTALL}\r\n PCRE_EXTENDED = $00000008;\r\n {$EXTERNALSYM PCRE_EXTENDED}\r\n PCRE_ANCHORED = $00000010;\r\n {$EXTERNALSYM PCRE_ANCHORED}\r\n PCRE_DOLLAR_ENDONLY = $00000020;\r\n {$EXTERNALSYM PCRE_DOLLAR_ENDONLY}\r\n PCRE_EXTRA = $00000040;\r\n {$EXTERNALSYM PCRE_EXTRA}\r\n PCRE_NOTBOL = $00000080;\r\n {$EXTERNALSYM PCRE_NOTBOL}\r\n PCRE_NOTEOL = $00000100;\r\n {$EXTERNALSYM PCRE_NOTEOL}\r\n PCRE_UNGREEDY = $00000200;\r\n {$EXTERNALSYM PCRE_UNGREEDY}\r\n PCRE_NOTEMPTY = $00000400;\r\n {$EXTERNALSYM PCRE_NOTEMPTY}\r\n PCRE_UTF8 = $00000800;\r\n {$EXTERNALSYM PCRE_UTF8}\r\n PCRE_UTF16 = $00000800;\r\n {$EXTERNALSYM PCRE_UTF16}\r\n PCRE_NO_AUTO_CAPTURE = $00001000;\r\n {$EXTERNALSYM PCRE_NO_AUTO_CAPTURE}\r\n PCRE_NO_UTF8_CHECK = $00002000;\r\n {$EXTERNALSYM PCRE_NO_UTF8_CHECK}\r\n PCRE_NO_UTF16_CHECK = $00002000;\r\n {$EXTERNALSYM PCRE_NO_UTF16_CHECK}\r\n PCRE_AUTO_CALLOUT = $00004000;\r\n {$EXTERNALSYM PCRE_AUTO_CALLOUT}\r\n PCRE_PARTIAL_SOFT = $00008000;\r\n {$EXTERNALSYM PCRE_PARTIAL_SOFT}\r\n PCRE_PARTIAL = PCRE_PARTIAL_SOFT; // Backwards compatible synonym\r\n {$EXTERNALSYM PCRE_PARTIAL}\r\n PCRE_DFA_SHORTEST = $00010000;\r\n {$EXTERNALSYM PCRE_DFA_SHORTEST}\r\n PCRE_DFA_RESTART = $00020000;\r\n {$EXTERNALSYM PCRE_DFA_RESTART}\r\n PCRE_FIRSTLINE = $00040000;\r\n {$EXTERNALSYM PCRE_FIRSTLINE}\r\n PCRE_DUPNAMES = $00080000;\r\n {$EXTERNALSYM PCRE_DUPNAMES}\r\n PCRE_NEWLINE_CR = $00100000;\r\n {$EXTERNALSYM PCRE_NEWLINE_CR}\r\n PCRE_NEWLINE_LF = $00200000;\r\n {$EXTERNALSYM PCRE_NEWLINE_LF}\r\n PCRE_NEWLINE_CRLF = $00300000;\r\n {$EXTERNALSYM PCRE_NEWLINE_CRLF}\r\n PCRE_NEWLINE_ANY = $00400000;\r\n {$EXTERNALSYM PCRE_NEWLINE_ANY}\r\n PCRE_NEWLINE_ANYCRLF = $00500000;\r\n {$EXTERNALSYM PCRE_NEWLINE_ANYCRLF}\r\n PCRE_BSR_ANYCRLF = $00800000;\r\n {$EXTERNALSYM PCRE_BSR_ANYCRLF}\r\n PCRE_BSR_UNICODE = $01000000;\r\n {$EXTERNALSYM PCRE_BSR_UNICODE}\r\n PCRE_JAVASCRIPT_COMPAT = $02000000;\r\n {$EXTERNALSYM PCRE_JAVASCRIPT_COMPAT}\r\n PCRE_NO_START_OPTIMIZE = $04000000;\r\n {$EXTERNALSYM PCRE_NO_START_OPTIMIZE}\r\n PCRE_NO_START_OPTIMISE = $04000000;\r\n {$EXTERNALSYM PCRE_NO_START_OPTIMISE}\r\n PCRE_PARTIAL_HARD = $08000000;\r\n {$EXTERNALSYM PCRE_PARTIAL_HARD}\r\n PCRE_NOTEMPTY_ATSTART = $10000000;\r\n {$EXTERNALSYM PCRE_NOTEMPTY_ATSTART}\r\n PCRE_UCP = $20000000;\r\n {$EXTERNALSYM PCRE_UCP}\r\n\r\n (* Exec-time and get-time error codes *)\r\n\r\n PCRE_ERROR_NOMATCH = -1;\r\n {$EXTERNALSYM PCRE_ERROR_NOMATCH}\r\n PCRE_ERROR_NULL = -2;\r\n {$EXTERNALSYM PCRE_ERROR_NULL}\r\n PCRE_ERROR_BADOPTION = -3;\r\n {$EXTERNALSYM PCRE_ERROR_BADOPTION}\r\n PCRE_ERROR_BADMAGIC = -4;\r\n {$EXTERNALSYM PCRE_ERROR_BADMAGIC}\r\n PCRE_ERROR_UNKNOWN_NODE = -5;\r\n {$EXTERNALSYM PCRE_ERROR_UNKNOWN_NODE}\r\n PCRE_ERROR_NOMEMORY = -6;\r\n {$EXTERNALSYM PCRE_ERROR_NOMEMORY}\r\n PCRE_ERROR_NOSUBSTRING = -7;\r\n {$EXTERNALSYM PCRE_ERROR_NOSUBSTRING}\r\n PCRE_ERROR_MATCHLIMIT = -8;\r\n {$EXTERNALSYM PCRE_ERROR_MATCHLIMIT}\r\n PCRE_ERROR_CALLOUT = -9; (* Never used by PCRE itself *)\r\n {$EXTERNALSYM PCRE_ERROR_CALLOUT}\r\n PCRE_ERROR_BADUTF8 = -10;\r\n {$EXTERNALSYM PCRE_ERROR_BADUTF8}\r\n PCRE_ERROR_BADUTF16 = -10;\r\n {$EXTERNALSYM PCRE_ERROR_BADUTF16}\r\n PCRE_ERROR_BADUTF8_OFFSET = -11;\r\n {$EXTERNALSYM PCRE_ERROR_BADUTF8_OFFSET}\r\n PCRE_ERROR_BADUTF16_OFFSET = -11;\r\n {$EXTERNALSYM PCRE_ERROR_BADUTF16_OFFSET}\r\n PCRE_ERROR_PARTIAL = -12;\r\n {$EXTERNALSYM PCRE_ERROR_PARTIAL}\r\n PCRE_ERROR_BADPARTIAL = -13;\r\n {$EXTERNALSYM PCRE_ERROR_BADPARTIAL}\r\n PCRE_ERROR_INTERNAL = -14;\r\n {$EXTERNALSYM PCRE_ERROR_INTERNAL}\r\n PCRE_ERROR_BADCOUNT = -15;\r\n {$EXTERNALSYM PCRE_ERROR_BADCOUNT}\r\n PCRE_ERROR_DFA_UITEM = -16;\r\n {$EXTERNALSYM PCRE_ERROR_DFA_UITEM}\r\n PCRE_ERROR_DFA_UCOND = -17;\r\n {$EXTERNALSYM PCRE_ERROR_DFA_UCOND}\r\n PCRE_ERROR_DFA_UMLIMIT = -18;\r\n {$EXTERNALSYM PCRE_ERROR_DFA_UMLIMIT}\r\n PCRE_ERROR_DFA_WSSIZE = -19;\r\n {$EXTERNALSYM PCRE_ERROR_DFA_WSSIZE}\r\n PCRE_ERROR_DFA_RECURSE = -20;\r\n {$EXTERNALSYM PCRE_ERROR_DFA_RECURSE}\r\n PCRE_ERROR_RECURSIONLIMIT = -21;\r\n {$EXTERNALSYM PCRE_ERROR_RECURSIONLIMIT}\r\n PCRE_ERROR_NULLWSLIMIT = -22; (* No longer actually used *)\r\n {$EXTERNALSYM PCRE_ERROR_NULLWSLIMIT}\r\n PCRE_ERROR_BADNEWLINE = -23;\r\n {$EXTERNALSYM PCRE_ERROR_BADNEWLINE}\r\n PCRE_ERROR_BADOFFSET = -24;\r\n {$EXTERNALSYM PCRE_ERROR_BADOFFSET}\r\n PCRE_ERROR_SHORTUTF8 = -25;\r\n {$EXTERNALSYM PCRE_ERROR_SHORTUTF8}\r\n PCRE_ERROR_SHORTUTF16 = -25;\r\n {$EXTERNALSYM PCRE_ERROR_SHORTUTF16}\r\n PCRE_ERROR_RECURSELOOP = -26;\r\n {$EXTERNALSYM PCRE_ERROR_RECURSELOOP}\r\n PCRE_ERROR_JITSTACKLIMIT = -27;\r\n {$EXTERNALSYM PCRE_ERROR_JITSTACKLIMIT}\r\n PCRE_ERROR_BADMODE = -28;\r\n {$EXTERNALSYM PCRE_ERROR_BADMODE}\r\n PCRE_ERROR_BADENDIANNESS = -29;\r\n {$EXTERNALSYM PCRE_ERROR_BADENDIANNESS}\r\n PCRE_ERROR_DFA_BADRESTART = -30;\r\n {$EXTERNALSYM PCRE_ERROR_DFA_BADRESTART}\r\n\r\n (* Specific error codes for UTF-8 validity checks *)\r\n\r\n PCRE_UTF8_ERR0 = 0;\r\n PCRE_UTF8_ERR1 = 1;\r\n PCRE_UTF8_ERR2 = 2;\r\n PCRE_UTF8_ERR3 = 3;\r\n PCRE_UTF8_ERR4 = 4;\r\n PCRE_UTF8_ERR5 = 5;\r\n PCRE_UTF8_ERR6 = 6;\r\n PCRE_UTF8_ERR7 = 7;\r\n PCRE_UTF8_ERR8 = 8;\r\n PCRE_UTF8_ERR9 = 9;\r\n PCRE_UTF8_ERR10 = 10;\r\n PCRE_UTF8_ERR11 = 11;\r\n PCRE_UTF8_ERR12 = 12;\r\n PCRE_UTF8_ERR13 = 13;\r\n PCRE_UTF8_ERR14 = 14;\r\n PCRE_UTF8_ERR15 = 15;\r\n PCRE_UTF8_ERR16 = 16;\r\n PCRE_UTF8_ERR17 = 17;\r\n PCRE_UTF8_ERR18 = 18;\r\n PCRE_UTF8_ERR19 = 19;\r\n PCRE_UTF8_ERR20 = 20;\r\n PCRE_UTF8_ERR21 = 21;\r\n\r\n (* Specific error codes for UTF-16 validity checks *)\r\n\r\n PCRE_UTF16_ERR0 = 0;\r\n PCRE_UTF16_ERR1 = 1;\r\n PCRE_UTF16_ERR2 = 2;\r\n PCRE_UTF16_ERR3 = 3;\r\n PCRE_UTF16_ERR4 = 4;\r\n\r\n (* Request types for pcre_fullinfo() *)\r\n\r\n PCRE_INFO_OPTIONS = 0;\r\n {$EXTERNALSYM PCRE_INFO_OPTIONS}\r\n PCRE_INFO_SIZE = 1;\r\n {$EXTERNALSYM PCRE_INFO_SIZE}\r\n PCRE_INFO_CAPTURECOUNT = 2;\r\n {$EXTERNALSYM PCRE_INFO_CAPTURECOUNT}\r\n PCRE_INFO_BACKREFMAX = 3;\r\n {$EXTERNALSYM PCRE_INFO_BACKREFMAX}\r\n PCRE_INFO_FIRSTCHAR = 4;\r\n {$EXTERNALSYM PCRE_INFO_FIRSTCHAR}\r\n PCRE_INFO_FIRSTTABLE = 5;\r\n {$EXTERNALSYM PCRE_INFO_FIRSTTABLE}\r\n PCRE_INFO_LASTLITERAL = 6;\r\n {$EXTERNALSYM PCRE_INFO_LASTLITERAL}\r\n PCRE_INFO_NAMEENTRYSIZE = 7;\r\n {$EXTERNALSYM PCRE_INFO_NAMEENTRYSIZE}\r\n PCRE_INFO_NAMECOUNT = 8;\r\n {$EXTERNALSYM PCRE_INFO_NAMECOUNT}\r\n PCRE_INFO_NAMETABLE = 9;\r\n {$EXTERNALSYM PCRE_INFO_NAMETABLE}\r\n PCRE_INFO_STUDYSIZE = 10;\r\n {$EXTERNALSYM PCRE_INFO_STUDYSIZE}\r\n PCRE_INFO_DEFAULT_TABLES = 11;\r\n {$EXTERNALSYM PCRE_INFO_DEFAULT_TABLES}\r\n PCRE_INFO_OKPARTIAL = 12;\r\n {$EXTERNALSYM PCRE_INFO_OKPARTIAL}\r\n PCRE_INFO_JCHANGED = 13;\r\n {$EXTERNALSYM PCRE_INFO_JCHANGED}\r\n PCRE_INFO_HASCRORLF = 14;\r\n {$EXTERNALSYM PCRE_INFO_HASCRORLF}\r\n PCRE_INFO_MINLENGTH = 15;\r\n {$EXTERNALSYM PCRE_INFO_MINLENGTH}\r\n PCRE_INFO_JIT = 16;\r\n {$EXTERNALSYM PCRE_INFO_JIT}\r\n PCRE_INFO_JITSIZE = 17;\r\n {$EXTERNALSYM PCRE_INFO_JITSIZE}\r\n PCRE_INFO_MAXLOOKBEHIND = 18;\r\n {$EXTERNALSYM PCRE_INFO_MAXLOOKBEHIND}\r\n\r\n (* Request types for pcre_config() *)\r\n PCRE_CONFIG_UTF8 = 0;\r\n {$EXTERNALSYM PCRE_CONFIG_UTF8}\r\n PCRE_CONFIG_NEWLINE = 1;\r\n {$EXTERNALSYM PCRE_CONFIG_NEWLINE}\r\n PCRE_CONFIG_LINK_SIZE = 2;\r\n {$EXTERNALSYM PCRE_CONFIG_LINK_SIZE}\r\n PCRE_CONFIG_POSIX_MALLOC_THRESHOLD = 3;\r\n {$EXTERNALSYM PCRE_CONFIG_POSIX_MALLOC_THRESHOLD}\r\n PCRE_CONFIG_MATCH_LIMIT = 4;\r\n {$EXTERNALSYM PCRE_CONFIG_MATCH_LIMIT}\r\n PCRE_CONFIG_STACKRECURSE = 5;\r\n {$EXTERNALSYM PCRE_CONFIG_STACKRECURSE}\r\n PCRE_CONFIG_UNICODE_PROPERTIES = 6;\r\n {$EXTERNALSYM PCRE_CONFIG_UNICODE_PROPERTIES}\r\n PCRE_CONFIG_MATCH_LIMIT_RECURSION = 7;\r\n {$EXTERNALSYM PCRE_CONFIG_MATCH_LIMIT_RECURSION}\r\n PCRE_CONFIG_BSR = 8;\r\n {$EXTERNALSYM PCRE_CONFIG_BSR}\r\n PCRE_CONFIG_JIT = 9;\r\n {$EXTERNALSYM PCRE_CONFIG_JIT}\r\n PCRE_CONFIG_UTF16 = 10;\r\n {$EXTERNALSYM PCRE_CONFIG_UTF16}\r\n PCRE_CONFIG_JITTARGET = 11;\r\n {$EXTERNALSYM PCRE_CONFIG_JITTARGET}\r\n\r\n (* Request types for pcre_study() *)\r\n\r\n PCRE_STUDY_JIT_COMPILE = $0001;\r\n PCRE_STUDY_JIT_PARTIAL_SOFT_COMPILE = $0002;\r\n PCRE_STUDY_JIT_PARTIAL_HARD_COMPILE = $0004;\r\n\r\n (* Bit flags for the pcre_extra structure *)\r\n\r\n PCRE_EXTRA_STUDY_DATA = $0001;\r\n {$EXTERNALSYM PCRE_EXTRA_STUDY_DATA}\r\n PCRE_EXTRA_MATCH_LIMIT = $0002;\r\n {$EXTERNALSYM PCRE_EXTRA_MATCH_LIMIT}\r\n PCRE_EXTRA_CALLOUT_DATA = $0004;\r\n {$EXTERNALSYM PCRE_EXTRA_CALLOUT_DATA}\r\n PCRE_EXTRA_TABLES = $0008;\r\n {$EXTERNALSYM PCRE_EXTRA_TABLES}\r\n PCRE_EXTRA_MATCH_LIMIT_RECURSION = $0010;\r\n {$EXTERNALSYM PCRE_EXTRA_MATCH_LIMIT_RECURSION}\r\n PCRE_EXTRA_MARK = $0020;\r\n {$EXTERNALSYM PCRE_EXTRA_MARK}\r\n PCRE_EXTRA_EXECUTABLE_JIT = $0040;\r\n {$EXTERNALSYM PCRE_EXTRA_EXECUTABLE_JIT}\r\n\r\ntype\r\n {$IFDEF PCRE_8}\r\n real_pcre = packed record\r\n {magic_number: Longword;\r\n size: Integer;\r\n tables: PAnsiChar;\r\n options: Longword;\r\n top_bracket: Word;\r\n top_backref: word;\r\n first_char: PAnsiChar;\r\n req_char: PAnsiChar;\r\n code: array [0..0] of AnsiChar;}\r\n end;\r\n TPCRE = real_pcre;\r\n PPCRE = ^TPCRE;\r\n {$ENDIF PCRE_8}\r\n\r\n {$IFDEF PCRE_16}\r\n real_pcre16 = packed record\r\n end;\r\n TPCRE16 = real_pcre16;\r\n PPCRE16 = ^TPCRE16;\r\n {$ENDIF PCRE_16}\r\n\r\n {$IFDEF PCRE_8}\r\n real_pcre_jit_stack = packed record\r\n end;\r\n TPCREJITStack = real_pcre_jit_stack;\r\n PPCREJITStack = ^TPCREJITStack;\r\n {$ENDIF PCRE_8}\r\n\r\n {$IFDEF PCRE_16}\r\n real_pcre16_jit_stack = packed record\r\n end;\r\n TPCRE16JITStack = real_pcre16_jit_stack;\r\n PPCRE16JITStack = ^TPCRE16JITStack;\r\n {$ENDIF PCRE_16}\r\n\r\n {$IFDEF PCRE_8}\r\n real_pcre_extra = packed record\r\n flags: Cardinal; (* Bits for which fields are set *)\r\n study_data: Pointer; (* Opaque data from pcre_study() *)\r\n match_limit: Cardinal; (* Maximum number of calls to match() *)\r\n callout_data: Pointer; (* Data passed back in callouts *)\r\n tables: PAnsiChar; (* Pointer to character tables *)\r\n match_limit_recursion: Cardinal; (* Max recursive calls to match() *)\r\n mark: PPAnsiChar; (* For passing back a mark pointer *)\r\n executable_jit: Pointer; (* Contains a pointer to a compiled jit code *)\r\n end;\r\n TPCREExtra = real_pcre_extra;\r\n PPCREExtra = ^TPCREExtra;\r\n {$ENDIF PCRE_8}\r\n\r\n {$IFDEF PCRE_16}\r\n real_pcre16_extra = packed record\r\n flags: Cardinal; (* Bits for which fields are set *)\r\n study_data: Pointer; (* Opaque data from pcre_study() *)\r\n match_limit: Cardinal; (* Maximum number of calls to match() *)\r\n callout_data: Pointer; (* Data passed back in callouts *)\r\n tables: PAnsiChar; (* Pointer to character tables *)\r\n match_limit_recursion: Cardinal; (* Max recursive calls to match() *)\r\n mark: PPWideChar; (* For passing back a mark pointer *)\r\n executable_jit: Pointer; (* Contains a pointer to a compiled jit code *)\r\n end;\r\n TPCRE16Extra = real_pcre16_extra;\r\n PPCRE16Extra = ^TPCRE16Extra;\r\n {$ENDIF PCRE_16}\r\n\r\n {$IFDEF PCRE_8}\r\n pcre_callout_block = packed record\r\n version: Integer; (* Identifies version of block *)\r\n (* ------------------------ Version 0 ------------------------------- *)\r\n callout_number: Integer; (* Number compiled into pattern *)\r\n offset_vector: PInteger; (* The offset vector *)\r\n subject: PAnsiChar; (* The subject being matched *)\r\n subject_length: Integer; (* The length of the subject *)\r\n start_match: Integer; (* Offset to start of this match attempt *)\r\n current_position: Integer; (* Where we currently are in the subject *)\r\n capture_top: Integer; (* Max current capture *)\r\n capture_last: Integer; (* Most recently closed capture *)\r\n callout_data: Pointer; (* Data passed in with the call *)\r\n (* ------------------- Added for Version 1 -------------------------- *)\r\n pattern_position: Integer; (* Offset to next item in the pattern *)\r\n next_item_length: Integer; (* Length of next item in the pattern *)\r\n (* ------------------- Added for Version 2 -------------------------- *)\r\n Mark: PCardinal; (* Pointer to current mark or NULL *)\r\n (* ------------------------------------------------------------------ *)\r\n end;\r\n {$ENDIF PCRE_8}\r\n\r\n {$IFDEF PCRE_16}\r\n pcre16_callout_block = packed record\r\n version: Integer; (* Identifies version of block *)\r\n (* ------------------------ Version 0 ------------------------------- *)\r\n callout_number: Integer; (* Number compiled into pattern *)\r\n offset_vector: PInteger; (* The offset vector *)\r\n subject: PWideChar; (* The subject being matched *)\r\n subject_length: Integer; (* The length of the subject *)\r\n start_match: Integer; (* Offset to start of this match attempt *)\r\n current_position: Integer; (* Where we currently are in the subject *)\r\n capture_top: Integer; (* Max current capture *)\r\n capture_last: Integer; (* Most recently closed capture *)\r\n callout_data: Pointer; (* Data passed in with the call *)\r\n (* ------------------- Added for Version 1 -------------------------- *)\r\n pattern_position: Integer; (* Offset to next item in the pattern *)\r\n next_item_length: Integer; (* Length of next item in the pattern *)\r\n (* ------------------- Added for Version 2 -------------------------- *)\r\n Mark: PCardinal; (* Pointer to current mark or NULL *)\r\n (* ------------------------------------------------------------------ *)\r\n end;\r\n {$ENDIF PCRE_16}\r\n\r\n {$IFDEF PCRE_8}\r\n pcre_malloc_callback = function(Size: SizeInt): Pointer; {$IFDEF PCRE_EXPORT_CDECL} cdecl; {$ENDIF PCRE_EXPORT_CDECL}\r\n {$EXTERNALSYM pcre_malloc_callback}\r\n pcre_free_callback = procedure(P: Pointer); {$IFDEF PCRE_EXPORT_CDECL} cdecl; {$ENDIF PCRE_EXPORT_CDECL}\r\n {$EXTERNALSYM pcre_free_callback}\r\n pcre_stack_malloc_callback = function(Size: SizeInt): Pointer; {$IFDEF PCRE_EXPORT_CDECL} cdecl; {$ENDIF PCRE_EXPORT_CDECL}\r\n {$EXTERNALSYM pcre_stack_malloc_callback}\r\n pcre_stack_free_callback = procedure(P: Pointer); {$IFDEF PCRE_EXPORT_CDECL} cdecl; {$ENDIF PCRE_EXPORT_CDECL}\r\n {$EXTERNALSYM pcre_stack_free_callback}\r\n pcre_callout_callback = function(var callout_block: pcre_callout_block): Integer; {$IFDEF PCRE_EXPORT_CDECL} cdecl; {$ENDIF PCRE_EXPORT_CDECL}\r\n {$EXTERNALSYM pcre_callout_callback}\r\n pcre_jit_callback = function (P: Pointer): PPCREJITStack; {$IFDEF PCRE_EXPORT_CDECL} cdecl; {$ENDIF PCRE_EXPORT_CDECL}\r\n {$EXTERNALSYM pcre_jit_callback}\r\n {$ENDIF PCRE_8}\r\n\r\n {$IFDEF PCRE_16}\r\n pcre16_malloc_callback = function(Size: SizeInt): Pointer; {$IFDEF PCRE_EXPORT_CDECL} cdecl; {$ENDIF PCRE_EXPORT_CDECL}\r\n {$EXTERNALSYM pcre16_malloc_callback}\r\n pcre16_free_callback = procedure(P: Pointer); {$IFDEF PCRE_EXPORT_CDECL} cdecl; {$ENDIF PCRE_EXPORT_CDECL}\r\n {$EXTERNALSYM pcre16_free_callback}\r\n pcre16_stack_malloc_callback = function(Size: SizeInt): Pointer; {$IFDEF PCRE_EXPORT_CDECL} cdecl; {$ENDIF PCRE_EXPORT_CDECL}\r\n {$EXTERNALSYM pcre16_stack_malloc_callback}\r\n pcre16_stack_free_callback = procedure(P: Pointer); {$IFDEF PCRE_EXPORT_CDECL} cdecl; {$ENDIF PCRE_EXPORT_CDECL}\r\n {$EXTERNALSYM pcre16_stack_free_callback}\r\n pcre16_callout_callback = function(var callout_block: pcre16_callout_block): Integer; {$IFDEF PCRE_EXPORT_CDECL} cdecl; {$ENDIF PCRE_EXPORT_CDECL}\r\n {$EXTERNALSYM pcre16_callout_callback}\r\n pcre16_jit_callback = function (P: Pointer): PPCRE16JITStack; {$IFDEF PCRE_EXPORT_CDECL} cdecl; {$ENDIF PCRE_EXPORT_CDECL}\r\n {$EXTERNALSYM pcre16_jit_callback}\r\n {$ENDIF PCRE_16}\r\n\r\nvar\r\n {$IFDEF PCRE_8}\r\n // renamed from \"pcre_X\" to \"pcre_X_func\" to allow functions with name \"pcre_X\" to be\r\n // declared in implementation when static linked\r\n pcre_malloc_func: ^pcre_malloc_callback = nil;\r\n {$EXTERNALSYM pcre_malloc_func}\r\n pcre_free_func: ^pcre_free_callback = nil;\r\n {$EXTERNALSYM pcre_free_func}\r\n pcre_stack_malloc_func: ^pcre_stack_malloc_callback = nil;\r\n {$EXTERNALSYM pcre_stack_malloc_func}\r\n pcre_stack_free_func: ^pcre_stack_free_callback = nil;\r\n {$EXTERNALSYM pcre_stack_free_func}\r\n pcre_callout_func: ^pcre_callout_callback = nil;\r\n {$EXTERNALSYM pcre_callout_func}\r\n {$ENDIF PCRE_8}\r\n\r\n {$IFDEF PCRE_16}\r\n pcre16_malloc_func: ^pcre16_malloc_callback = nil;\r\n {$EXTERNALSYM pcre16_malloc_func}\r\n pcre16_free_func: ^pcre16_free_callback = nil;\r\n {$EXTERNALSYM pcre16_free_func}\r\n pcre16_stack_malloc_func: ^pcre16_stack_malloc_callback = nil;\r\n {$EXTERNALSYM pcre16_stack_malloc_func}\r\n pcre16_stack_free_func: ^pcre16_stack_free_callback = nil;\r\n {$EXTERNALSYM pcre16_stack_free_func}\r\n pcre16_callout_func: ^pcre16_callout_callback = nil;\r\n {$EXTERNALSYM pcre16_callout_func}\r\n {$ENDIF PCRE_16}\r\n\r\n{$IFDEF PCRE_8}\r\n\r\nprocedure SetPCREMallocCallback(const Value: pcre_malloc_callback);\r\n{$EXTERNALSYM SetPCREMallocCallback}\r\nfunction GetPCREMallocCallback: pcre_malloc_callback;\r\n{$EXTERNALSYM GetPCREMallocCallback}\r\nfunction CallPCREMalloc(Size: SizeInt): Pointer;\r\n{$EXTERNALSYM CallPCREMalloc}\r\n\r\nprocedure SetPCREFreeCallback(const Value: pcre_free_callback);\r\n{$EXTERNALSYM SetPCREFreeCallback}\r\nfunction GetPCREFreeCallback: pcre_free_callback;\r\n{$EXTERNALSYM GetPCREFreeCallback}\r\nprocedure CallPCREFree(P: Pointer);\r\n{$EXTERNALSYM CallPCREFree}\r\n\r\nprocedure SetPCREStackMallocCallback(const Value: pcre_stack_malloc_callback);\r\n{$EXTERNALSYM SetPCREStackMallocCallback}\r\nfunction GetPCREStackMallocCallback: pcre_stack_malloc_callback;\r\n{$EXTERNALSYM GetPCREStackMallocCallback}\r\nfunction CallPCREStackMalloc(Size: SizeInt): Pointer;\r\n{$EXTERNALSYM CallPCREStackMalloc}\r\n\r\nprocedure SetPCREStackFreeCallback(const Value: pcre_stack_free_callback);\r\n{$EXTERNALSYM SetPCREStackFreeCallback}\r\nfunction GetPCREStackFreeCallback: pcre_stack_free_callback;\r\n{$EXTERNALSYM GetPCREStackFreeCallback}\r\nprocedure CallPCREStackFree(P: Pointer);\r\n{$EXTERNALSYM CallPCREStackFree}\r\n\r\nprocedure SetPCRECalloutCallback(const Value: pcre_callout_callback);\r\n{$EXTERNALSYM SetPCRECalloutCallback}\r\nfunction GetPCRECalloutCallback: pcre_callout_callback;\r\n{$EXTERNALSYM GetPCRECalloutCallback}\r\nfunction CallPCRECallout(var callout_block: pcre_callout_block): Integer;\r\n{$EXTERNALSYM CallPCRECallout}\r\n\r\n{$ENDIF PCRE_8}\r\n\r\n{$IFDEF PCRE_16}\r\n\r\nprocedure SetPCRE16MallocCallback(const Value: pcre16_malloc_callback);\r\n{$EXTERNALSYM SetPCRE16MallocCallback}\r\nfunction GetPCRE16MallocCallback: pcre16_malloc_callback;\r\n{$EXTERNALSYM GetPCRE16MallocCallback}\r\nfunction CallPCRE16Malloc(Size: SizeInt): Pointer;\r\n{$EXTERNALSYM CallPCRE16Malloc}\r\n\r\nprocedure SetPCRE16FreeCallback(const Value: pcre16_free_callback);\r\n{$EXTERNALSYM SetPCRE16FreeCallback}\r\nfunction GetPCRE16FreeCallback: pcre16_free_callback;\r\n{$EXTERNALSYM GetPCRE16FreeCallback}\r\nprocedure CallPCRE16Free(P: Pointer);\r\n{$EXTERNALSYM CallPCRE16Free}\r\n\r\nprocedure SetPCRE16StackMallocCallback(const Value: pcre16_stack_malloc_callback);\r\n{$EXTERNALSYM SetPCRE16StackMallocCallback}\r\nfunction GetPCRE16StackMallocCallback: pcre16_stack_malloc_callback;\r\n{$EXTERNALSYM GetPCRE16StackMallocCallback}\r\nfunction CallPCRE16StackMalloc(Size: SizeInt): Pointer;\r\n{$EXTERNALSYM CallPCRE16StackMalloc}\r\n\r\nprocedure SetPCRE16StackFreeCallback(const Value: pcre16_stack_free_callback);\r\n{$EXTERNALSYM SetPCRE16StackFreeCallback}\r\nfunction GetPCRE16StackFreeCallback: pcre16_stack_free_callback;\r\n{$EXTERNALSYM GetPCRE16StackFreeCallback}\r\nprocedure CallPCRE16StackFree(P: Pointer);\r\n{$EXTERNALSYM CallPCRE16StackFree}\r\n\r\nprocedure SetPCRE16CalloutCallback(const Value: pcre16_callout_callback);\r\n{$EXTERNALSYM SetPCRE16CalloutCallback}\r\nfunction GetPCRE16CalloutCallback: pcre16_callout_callback;\r\n{$EXTERNALSYM GetPCRE16CalloutCallback}\r\nfunction CallPCRE16Callout(var callout_block: pcre16_callout_block): Integer;\r\n{$EXTERNALSYM CallPCRE16Callout}\r\n\r\n{$ENDIF PCRE_16}\r\n\r\ntype\r\n TPCRELibNotLoadedHandler = procedure; {$IFDEF PCRE_EXPORT_CDECL} cdecl; {$ENDIF PCRE_EXPORT_CDECL}\r\n PPPWideChar = ^PPWideChar;\r\n\r\nvar\r\n // Value to initialize function pointers below with, in case LoadPCRE fails\r\n // or UnloadPCRE is called. Typically the handler will raise an exception.\r\n LibNotLoadedHandler: TPCRELibNotLoadedHandler = nil;\r\n\r\n(* Functions *)\r\n\r\n{$IFNDEF PCRE_LINKONREQUEST}\r\n// static link and static dll import\r\n{$IFDEF PCRE_8}\r\nfunction pcre_compile(const pattern: PAnsiChar; options: Integer;\r\n const errptr: PPAnsiChar; erroffset: PInteger; const tableptr: PAnsiChar): PPCRE;\r\n {$IFDEF PCRE_EXPORT_CDECL} cdecl; {$ENDIF PCRE_EXPORT_CDECL}\r\n{$EXTERNALSYM pcre_compile}\r\n{$ENDIF PCRE_8}\r\n{$IFDEF PCRE_16}\r\nfunction pcre16_compile(const pattern: PWideChar; options: Integer;\r\n const errptr: PPAnsiChar; erroffset: PInteger; const tableptr: PAnsiChar): PPCRE16;\r\n {$IFDEF PCRE_EXPORT_CDECL} cdecl; {$ENDIF PCRE_EXPORT_CDECL}\r\n{$EXTERNALSYM pcre16_compile}\r\n{$ENDIF PCRE_16}\r\n{$IFDEF PCRE_8}\r\nfunction pcre_compile2(const pattern: PAnsiChar; options: Integer;\r\n const errorcodeptr: PInteger; const errorptr: PPAnsiChar; erroroffset: PInteger;\r\n const tables: PAnsiChar): PPCRE;\r\n {$IFDEF PCRE_EXPORT_CDECL} cdecl; {$ENDIF PCRE_EXPORT_CDECL}\r\n{$EXTERNALSYM pcre_compile2}\r\n{$ENDIF PCRE_8}\r\n{$IFDEF PCRE_16}\r\nfunction pcre16_compile2(const pattern: PWideChar; options: Integer;\r\n const errorcodeptr: PInteger; const errorptr: PPAnsiChar; erroroffset: PInteger;\r\n const tables: PAnsiChar): PPCRE16;\r\n {$IFDEF PCRE_EXPORT_CDECL} cdecl; {$ENDIF PCRE_EXPORT_CDECL}\r\n{$EXTERNALSYM pcre16_compile2}\r\n{$ENDIF PCRE_16}\r\n{$IFDEF PCRE_8}\r\nfunction pcre_config(what: Integer; where: Pointer): Integer;\r\n {$IFDEF PCRE_EXPORT_CDECL} cdecl; {$ENDIF PCRE_EXPORT_CDECL}\r\n{$EXTERNALSYM pcre_config}\r\n{$ENDIF PCRE_8}\r\n{$IFDEF PCRE_16}\r\nfunction pcre16_config(what: Integer; where: Pointer): Integer;\r\n {$IFDEF PCRE_EXPORT_CDECL} cdecl; {$ENDIF PCRE_EXPORT_CDECL}\r\n{$EXTERNALSYM pcre16_config}\r\n{$ENDIF PCRE_16}\r\n{$IFDEF PCRE_8}\r\nfunction pcre_copy_named_substring(const code: PPCRE; const subject: PAnsiChar;\r\n ovector: PInteger; stringcount: Integer; const stringname: PAnsiChar;\r\n buffer: PAnsiChar; size: Integer): Integer;\r\n {$IFDEF PCRE_EXPORT_CDECL} cdecl; {$ENDIF PCRE_EXPORT_CDECL}\r\n{$EXTERNALSYM pcre_copy_named_substring}\r\n{$ENDIF PCRE_8}\r\n{$IFDEF PCRE_16}\r\nfunction pcre16_copy_named_substring(const code: PPCRE16; const subject: PWideChar;\r\n ovector: PInteger; stringcount: Integer; const stringname: PWideChar;\r\n buffer: PWideChar; size: Integer): Integer;\r\n {$IFDEF PCRE_EXPORT_CDECL} cdecl; {$ENDIF PCRE_EXPORT_CDECL}\r\n{$EXTERNALSYM pcre16_copy_named_substring}\r\n{$ENDIF PCRE_16}\r\n{$IFDEF PCRE_8}\r\nfunction pcre_copy_substring(const subject: PAnsiChar; ovector: PInteger;\r\n stringcount, stringnumber: Integer; buffer: PAnsiChar; buffersize: Integer): Integer;\r\n {$IFDEF PCRE_EXPORT_CDECL} cdecl; {$ENDIF PCRE_EXPORT_CDECL}\r\n{$EXTERNALSYM pcre_copy_substring}\r\n{$ENDIF PCRE_8}\r\n{$IFDEF PCRE_16}\r\nfunction pcre16_copy_substring(const subject: PWideChar; ovector: PInteger;\r\n stringcount, stringnumber: Integer; buffer: PWideChar; buffersize: Integer): Integer;\r\n {$IFDEF PCRE_EXPORT_CDECL} cdecl; {$ENDIF PCRE_EXPORT_CDECL}\r\n{$EXTERNALSYM pcre16_copy_substring}\r\n{$ENDIF PCRE_16}\r\n{$IFDEF PCRE_8}\r\nfunction pcre_dfa_exec(const argument_re: PPCRE; const extra_data: PPCREExtra;\r\n const subject: PAnsiChar; length: Integer; start_offset: Integer;\r\n options: Integer; offsets: PInteger; offsetcount: Integer; workspace: PInteger;\r\n wscount: Integer): Integer;\r\n {$IFDEF PCRE_EXPORT_CDECL} cdecl; {$ENDIF PCRE_EXPORT_CDECL}\r\n{$EXTERNALSYM pcre_dfa_exec}\r\n{$ENDIF PCRE_8}\r\n{$IFDEF PCRE_16}\r\nfunction pcre16_dfa_exec(const argument_re: PPCRE16; const extra_data: PPCRE16Extra;\r\n const subject: PWideChar; length: Integer; start_offset: Integer;\r\n options: Integer; offsets: PInteger; offsetcount: Integer; workspace: PInteger;\r\n wscount: Integer): Integer;\r\n {$IFDEF PCRE_EXPORT_CDECL} cdecl; {$ENDIF PCRE_EXPORT_CDECL}\r\n{$EXTERNALSYM pcre16_dfa_exec}\r\n{$ENDIF PCRE_16}\r\n{$IFDEF PCRE_8}\r\nfunction pcre_exec(const code: PPCRE; const extra: PPCREExtra; const subject: PAnsiChar;\r\n length, startoffset, options: Integer; ovector: PInteger; ovecsize: Integer): Integer;\r\n {$IFDEF PCRE_EXPORT_CDECL} cdecl; {$ENDIF PCRE_EXPORT_CDECL}\r\n{$EXTERNALSYM pcre_exec}\r\n{$ENDIF PCRE_8}\r\n{$IFDEF PCRE_16}\r\nfunction pcre16_exec(const code: PPCRE16; const extra: PPCRE16Extra; const subject: PWideChar;\r\n length, startoffset, options: Integer; ovector: PInteger; ovecsize: Integer): Integer;\r\n {$IFDEF PCRE_EXPORT_CDECL} cdecl; {$ENDIF PCRE_EXPORT_CDECL}\r\n{$EXTERNALSYM pcre16_exec}\r\n{$ENDIF PCRE_16}\r\n{$IFDEF PCRE_8}\r\nprocedure pcre_free_substring(stringptr: PAnsiChar);\r\n {$IFDEF PCRE_EXPORT_CDECL} cdecl; {$ENDIF PCRE_EXPORT_CDECL}\r\n{$EXTERNALSYM pcre_free_substring}\r\n{$ENDIF PCRE_8}\r\n{$IFDEF PCRE_16}\r\nprocedure pcre16_free_substring(stringptr: PWideChar);\r\n {$IFDEF PCRE_EXPORT_CDECL} cdecl; {$ENDIF PCRE_EXPORT_CDECL}\r\n{$EXTERNALSYM pcre16_free_substring}\r\n{$ENDIF PCRE_16}\r\n{$IFDEF PCRE_8}\r\nprocedure pcre_free_substring_list(stringlistptr: PPAnsiChar);\r\n {$IFDEF PCRE_EXPORT_CDECL} cdecl; {$ENDIF PCRE_EXPORT_CDECL}\r\n{$EXTERNALSYM pcre_free_substring_list}\r\n{$ENDIF PCRE_8}\r\n{$IFDEF PCRE_16}\r\nprocedure pcre16_free_substring_list(stringlistptr: PPWideChar);\r\n {$IFDEF PCRE_EXPORT_CDECL} cdecl; {$ENDIF PCRE_EXPORT_CDECL}\r\n{$EXTERNALSYM pcre16_free_substring_list}\r\n{$ENDIF PCRE_16}\r\n{$IFDEF PCRE_8}\r\nfunction pcre_fullinfo(const code: PPCRE; const extra: PPCREExtra;\r\n what: Integer; where: Pointer): Integer;\r\n {$IFDEF PCRE_EXPORT_CDECL} cdecl; {$ENDIF PCRE_EXPORT_CDECL}\r\n{$EXTERNALSYM pcre_fullinfo}\r\n{$ENDIF PCRE_8}\r\n{$IFDEF PCRE_16}\r\nfunction pcre16_fullinfo(const code: PPCRE16; const extra: PPCRE16Extra;\r\n what: Integer; where: Pointer): Integer;\r\n {$IFDEF PCRE_EXPORT_CDECL} cdecl; {$ENDIF PCRE_EXPORT_CDECL}\r\n{$EXTERNALSYM pcre16_fullinfo}\r\n{$ENDIF PCRE_16}\r\n{$IFDEF PCRE_8}\r\nfunction pcre_get_named_substring(const code: PPCRE; const subject: PAnsiChar;\r\n ovector: PInteger; stringcount: Integer; const stringname: PAnsiChar;\r\n const stringptr: PPAnsiChar): Integer;\r\n {$IFDEF PCRE_EXPORT_CDECL} cdecl; {$ENDIF PCRE_EXPORT_CDECL}\r\n{$EXTERNALSYM pcre_get_named_substring}\r\n{$ENDIF PCRE_8}\r\n{$IFDEF PCRE_16}\r\nfunction pcre16_get_named_substring(const code: PPCRE16; const subject: PWideChar;\r\n ovector: PInteger; stringcount: Integer; const stringname: PWideChar;\r\n const stringptr: PPWideChar): Integer;\r\n {$IFDEF PCRE_EXPORT_CDECL} cdecl; {$ENDIF PCRE_EXPORT_CDECL}\r\n{$EXTERNALSYM pcre16_get_named_substring}\r\n{$ENDIF PCRE_16}\r\n{$IFDEF PCRE_8}\r\nfunction pcre_get_stringnumber(const code: PPCRE; const stringname: PAnsiChar): Integer;\r\n {$IFDEF PCRE_EXPORT_CDECL} cdecl; {$ENDIF PCRE_EXPORT_CDECL}\r\n{$EXTERNALSYM pcre_get_stringnumber}\r\n{$ENDIF PCRE_8}\r\n{$IFDEF PCRE_16}\r\nfunction pcre16_get_stringnumber(const code: PPCRE16; const stringname: PWideChar): Integer;\r\n {$IFDEF PCRE_EXPORT_CDECL} cdecl; {$ENDIF PCRE_EXPORT_CDECL}\r\n{$EXTERNALSYM pcre16_get_stringnumber}\r\n{$ENDIF PCRE_16}\r\n{$IFDEF PCRE_8}\r\nfunction pcre_get_stringtable_entries(const code: PPCRE; const stringname: PAnsiChar;\r\n firstptr: PPAnsiChar; lastptr: PPAnsiChar): Integer;\r\n {$IFDEF PCRE_EXPORT_CDECL} cdecl; {$ENDIF PCRE_EXPORT_CDECL}\r\n{$EXTERNALSYM pcre_get_stringtable_entries}\r\n{$ENDIF PCRE_8}\r\n{$IFDEF PCRE_16}\r\nfunction pcre16_get_stringtable_entries(const code: PPCRE16; const stringname: PWideChar;\r\n firstptr: PPWideChar; lastptr: PPWideChar): Integer;\r\n {$IFDEF PCRE_EXPORT_CDECL} cdecl; {$ENDIF PCRE_EXPORT_CDECL}\r\n{$EXTERNALSYM pcre16_get_stringtable_entries}\r\n{$ENDIF PCRE_16}\r\n{$IFDEF PCRE_8}\r\nfunction pcre_get_substring(const subject: PAnsiChar; ovector: PInteger;\r\n stringcount, stringnumber: Integer; const stringptr: PPAnsiChar): Integer;\r\n {$IFDEF PCRE_EXPORT_CDECL} cdecl; {$ENDIF PCRE_EXPORT_CDECL}\r\n{$EXTERNALSYM pcre_get_substring}\r\n{$ENDIF PCRE_8}\r\n{$IFDEF PCRE_16}\r\nfunction pcre16_get_substring(const subject: PWideChar; ovector: PInteger;\r\n stringcount, stringnumber: Integer; const stringptr: PPWideChar): Integer;\r\n {$IFDEF PCRE_EXPORT_CDECL} cdecl; {$ENDIF PCRE_EXPORT_CDECL}\r\n{$EXTERNALSYM pcre16_get_substring}\r\n{$ENDIF PCRE_16}\r\n{$IFDEF PCRE_8}\r\nfunction pcre_get_substring_list(const subject: PAnsiChar; ovector: PInteger;\r\n stringcount: Integer; listptr: PPPAnsiChar): Integer;\r\n {$IFDEF PCRE_EXPORT_CDECL} cdecl; {$ENDIF PCRE_EXPORT_CDECL}\r\n{$EXTERNALSYM pcre_get_substring_list}\r\n{$ENDIF PCRE_8}\r\n{$IFDEF PCRE_16}\r\nfunction pcre16_get_substring_list(const subject: PWideChar; ovector: PInteger;\r\n stringcount: Integer; listptr: PPPWideChar): Integer;\r\n {$IFDEF PCRE_EXPORT_CDECL} cdecl; {$ENDIF PCRE_EXPORT_CDECL}\r\n{$EXTERNALSYM pcre16_get_substring_list}\r\n{$ENDIF PCRE_16}\r\n{$IFDEF PCRE_8}\r\nfunction pcre_maketables: PAnsiChar;\r\n {$IFDEF PCRE_EXPORT_CDECL} cdecl; {$ENDIF PCRE_EXPORT_CDECL}\r\n{$EXTERNALSYM pcre_maketables}\r\n{$ENDIF PCRE_8}\r\n{$IFDEF PCRE_16}\r\nfunction pcre16_maketables: PAnsiChar;\r\n {$IFDEF PCRE_EXPORT_CDECL} cdecl; {$ENDIF PCRE_EXPORT_CDECL}\r\n{$EXTERNALSYM pcre16_maketables}\r\n{$ENDIF PCRE_16}\r\n{$IFDEF PCRE_8}\r\nfunction pcre_refcount(argument_re: PPCRE; adjust: Integer): Integer;\r\n {$IFDEF PCRE_EXPORT_CDECL} cdecl; {$ENDIF PCRE_EXPORT_CDECL}\r\n{$EXTERNALSYM pcre_refcount}\r\n{$ENDIF PCRE_8}\r\n{$IFDEF PCRE_16}\r\nfunction pcre16_refcount(argument_re: PPCRE16; adjust: Integer): Integer;\r\n {$IFDEF PCRE_EXPORT_CDECL} cdecl; {$ENDIF PCRE_EXPORT_CDECL}\r\n{$EXTERNALSYM pcre16_refcount}\r\n{$ENDIF PCRE_16}\r\n{$IFDEF PCRE_8}\r\nfunction pcre_study(const code: PPCRE; options: Integer; const errptr: PPAnsiChar): PPCREExtra;\r\n {$IFDEF PCRE_EXPORT_CDECL} cdecl; {$ENDIF PCRE_EXPORT_CDECL}\r\n{$EXTERNALSYM pcre_study}\r\n{$ENDIF PCRE_8}\r\n{$IFDEF PCRE_16}\r\nfunction pcre16_study(const code: PPCRE16; options: Integer; const errptr: PPAnsiChar): PPCRE16Extra;\r\n {$IFDEF PCRE_EXPORT_CDECL} cdecl; {$ENDIF PCRE_EXPORT_CDECL}\r\n{$EXTERNALSYM pcre16_study}\r\n{$ENDIF PCRE_16}\r\n{$IFDEF PCRE_8}\r\nprocedure pcre_free_study(const extra: PPCREExtra);\r\n {$IFDEF PCRE_EXPORT_CDECL} cdecl; {$ENDIF PCRE_EXPORT_CDECL}\r\n{$EXTERNALSYM pcre_free_study}\r\n{$ENDIF PCRE_8}\r\n{$IFDEF PCRE_16}\r\nprocedure pcre16_free_study(const extra: PPCRE16Extra);\r\n {$IFDEF PCRE_EXPORT_CDECL} cdecl; {$ENDIF PCRE_EXPORT_CDECL}\r\n{$EXTERNALSYM pcre16_free_study}\r\n{$ENDIF PCRE_16}\r\n{$IFDEF PCRE_8}\r\nfunction pcre_version: PAnsiChar; {$IFDEF PCRE_EXPORT_CDECL} cdecl; {$ENDIF PCRE_EXPORT_CDECL}\r\n{$EXTERNALSYM pcre_version}\r\n{$ENDIF PCRE_8}\r\n{$IFDEF PCRE_16}\r\nfunction pcre16_version: PAnsiChar; {$IFDEF PCRE_EXPORT_CDECL} cdecl; {$ENDIF PCRE_EXPORT_CDECL}\r\n{$EXTERNALSYM pcre16_version}\r\n{$ENDIF PCRE_16}\r\n{$IFDEF PCRE_8}\r\nfunction pcre_jit_stack_alloc(startsize, maxsize: Integer): PPCREJITStack; {$IFDEF PCRE_EXPORT_CDECL} cdecl; {$ENDIF PCRE_EXPORT_CDECL}\r\n{$EXTERNALSYM pcre_jit_stack_alloc}\r\n{$ENDIF PCRE_8}\r\n{$IFDEF PCRE_16}\r\nfunction pcre16_jit_stack_alloc(startsize, maxsize: Integer): PPCRE16JITStack; {$IFDEF PCRE_EXPORT_CDECL} cdecl; {$ENDIF PCRE_EXPORT_CDECL}\r\n{$EXTERNALSYM pcre16_jit_stack_alloc}\r\n{$ENDIF PCRE_16}\r\n{$IFDEF PCRE_8}\r\nprocedure pcre_jit_stack_free(stack: PPCREJITStack); {$IFDEF PCRE_EXPORT_CDECL} cdecl; {$ENDIF PCRE_EXPORT_CDECL}\r\n{$EXTERNALSYM pcre_jit_stack_free}\r\n{$ENDIF PCRE_8}\r\n{$IFDEF PCRE_16}\r\nprocedure pcre16_jit_stack_free(stack: PPCRE16JITStack); {$IFDEF PCRE_EXPORT_CDECL} cdecl; {$ENDIF PCRE_EXPORT_CDECL}\r\n{$EXTERNALSYM pcre16_jit_stack_free}\r\n{$ENDIF PCRE_16}\r\n{$IFDEF PCRE_8}\r\nprocedure pcre_assign_jit_stack(extra: PPCREExtra; callback: pcre_jit_callback; userdata: Pointer); {$IFDEF PCRE_EXPORT_CDECL} cdecl; {$ENDIF PCRE_EXPORT_CDECL}\r\n{$EXTERNALSYM pcre_assign_jit_stack}\r\n{$ENDIF PCRE_8}\r\n{$IFDEF PCRE_16}\r\nprocedure pcre16_assign_jit_stack(extra: PPCRE16Extra; callback: pcre16_jit_callback; userdata: Pointer); {$IFDEF PCRE_EXPORT_CDECL} cdecl; {$ENDIF PCRE_EXPORT_CDECL}\r\n{$EXTERNALSYM pcre16_assign_jit_stack}\r\n{$ENDIF PCRE_16}\r\n\r\n{$ELSE PCRE_LINKONREQUEST}\r\n\r\n// dynamic dll import\r\ntype\r\n {$IFDEF PCRE_8}\r\n pcre_compile_func = function(const pattern: PAnsiChar; options: Integer;\r\n const errptr: PPAnsiChar; erroffset: PInteger; const tableptr: PAnsiChar): PPCRE;\r\n {$IFDEF PCRE_EXPORT_CDECL} cdecl; {$ENDIF PCRE_EXPORT_CDECL}\r\n {$EXTERNALSYM pcre_compile_func}\r\n {$ENDIF PCRE_8}\r\n {$IFDEF PCRE_16}\r\n pcre16_compile_func = function(const pattern: PWideChar; options: Integer;\r\n const errptr: PPAnsiChar; erroffset: PInteger; const tableptr: PAnsiChar): PPCRE16;\r\n {$IFDEF PCRE_EXPORT_CDECL} cdecl; {$ENDIF PCRE_EXPORT_CDECL}\r\n {$EXTERNALSYM pcre16_compile_func}\r\n {$ENDIF PCRE_16}\r\n {$IFDEF PCRE_8}\r\n pcre_compile2_func = function(const pattern: PAnsiChar; options: Integer;\r\n const errorcodeptr: PInteger; const errorptr: PPAnsiChar; erroroffset: PInteger;\r\n const tables: PAnsiChar): PPCRE; {$IFDEF PCRE_EXPORT_CDECL} cdecl; {$ENDIF PCRE_EXPORT_CDECL}\r\n {$EXTERNALSYM pcre_compile2_func}\r\n {$ENDIF PCRE_8}\r\n {$IFDEF PCRE_16}\r\n pcre16_compile2_func = function(const pattern: PWideChar; options: Integer;\r\n const errorcodeptr: PInteger; const errorptr: PPAnsiChar; erroroffset: PInteger;\r\n const tables: PAnsiChar): PPCRE16; {$IFDEF PCRE_EXPORT_CDECL} cdecl; {$ENDIF PCRE_EXPORT_CDECL}\r\n {$EXTERNALSYM pcre16_compile2_func}\r\n {$ENDIF PCRE_16}\r\n {$IFDEF PCRE_8}\r\n pcre_config_func = function(what: Integer; where: Pointer): Integer;\r\n {$IFDEF PCRE_EXPORT_CDECL} cdecl; {$ENDIF PCRE_EXPORT_CDECL}\r\n {$EXTERNALSYM pcre_config_func}\r\n {$ENDIF PCRE_8}\r\n {$IFDEF PCRE_16}\r\n pcre16_config_func = function(what: Integer; where: Pointer): Integer;\r\n {$IFDEF PCRE_EXPORT_CDECL} cdecl; {$ENDIF PCRE_EXPORT_CDECL}\r\n {$EXTERNALSYM pcre16_config_func}\r\n {$ENDIF PCRE_16}\r\n {$IFDEF PCRE_8}\r\n pcre_copy_named_substring_func = function(const code: PPCRE; const subject: PAnsiChar;\r\n ovector: PInteger; stringcount: Integer; const stringname: PAnsiChar;\r\n buffer: PAnsiChar; size: Integer): Integer; {$IFDEF PCRE_EXPORT_CDECL} cdecl; {$ENDIF PCRE_EXPORT_CDECL}\r\n {$EXTERNALSYM pcre_copy_named_substring_func}\r\n {$ENDIF PCRE_8}\r\n {$IFDEF PCRE_16}\r\n pcre16_copy_named_substring_func = function(const code: PPCRE16; const subject: PWideChar;\r\n ovector: PInteger; stringcount: Integer; const stringname: PWideChar;\r\n buffer: PWideChar; size: Integer): Integer; {$IFDEF PCRE_EXPORT_CDECL} cdecl; {$ENDIF PCRE_EXPORT_CDECL}\r\n {$EXTERNALSYM pcre16_copy_named_substring_func}\r\n {$ENDIF PCRE_16}\r\n {$IFDEF PCRE_8}\r\n pcre_copy_substring_func = function(const subject: PAnsiChar; ovector: PInteger;\r\n stringcount, stringnumber: Integer; buffer: PAnsiChar; buffersize: Integer): Integer;\r\n {$IFDEF PCRE_EXPORT_CDECL} cdecl; {$ENDIF PCRE_EXPORT_CDECL}\r\n {$EXTERNALSYM pcre_copy_substring_func}\r\n {$ENDIF PCRE_8}\r\n {$IFDEF PCRE_16}\r\n pcre16_copy_substring_func = function(const subject: PWideChar; ovector: PInteger;\r\n stringcount, stringnumber: Integer; buffer: PWideChar; buffersize: Integer): Integer;\r\n {$IFDEF PCRE_EXPORT_CDECL} cdecl; {$ENDIF PCRE_EXPORT_CDECL}\r\n {$EXTERNALSYM pcre16_copy_substring_func}\r\n {$ENDIF PCRE_16}\r\n {$IFDEF PCRE_8}\r\n pcre_dfa_exec_func = function(const argument_re: PPCRE; const extra_data: PPCREExtra;\r\n const subject: PAnsiChar; length: Integer; start_offset: Integer;\r\n options: Integer; offsets: PInteger; offsetcount: Integer; workspace: PInteger;\r\n wscount: Integer): Integer; {$IFDEF PCRE_EXPORT_CDECL} cdecl; {$ENDIF PCRE_EXPORT_CDECL}\r\n {$EXTERNALSYM pcre_dfa_exec_func}\r\n {$ENDIF PCRE_8}\r\n {$IFDEF PCRE_16}\r\n pcre16_dfa_exec_func = function(const argument_re: PPCRE16; const extra_data: PPCRE16Extra;\r\n const subject: PWideChar; length: Integer; start_offset: Integer;\r\n options: Integer; offsets: PInteger; offsetcount: Integer; workspace: PInteger;\r\n wscount: Integer): Integer; {$IFDEF PCRE_EXPORT_CDECL} cdecl; {$ENDIF PCRE_EXPORT_CDECL}\r\n {$EXTERNALSYM pcre16_dfa_exec_func}\r\n {$ENDIF PCRE_16}\r\n {$IFDEF PCRE_8}\r\n pcre_exec_func = function(const code: PPCRE; const extra: PPCREExtra; const subject: PAnsiChar;\r\n length, startoffset, options: Integer; ovector: PInteger; ovecsize: Integer): Integer;\r\n {$IFDEF PCRE_EXPORT_CDECL} cdecl; {$ENDIF PCRE_EXPORT_CDECL}\r\n {$EXTERNALSYM pcre_exec_func}\r\n {$ENDIF PCRE_8}\r\n {$IFDEF PCRE_16}\r\n pcre16_exec_func = function(const code: PPCRE16; const extra: PPCRE16Extra; const subject: PWideChar;\r\n length, startoffset, options: Integer; ovector: PInteger; ovecsize: Integer): Integer;\r\n {$IFDEF PCRE_EXPORT_CDECL} cdecl; {$ENDIF PCRE_EXPORT_CDECL}\r\n {$EXTERNALSYM pcre16_exec_func}\r\n {$ENDIF PCRE_16}\r\n {$IFDEF PCRE_8}\r\n pcre_free_substring_func = procedure(stringptr: PAnsiChar);\r\n {$IFDEF PCRE_EXPORT_CDECL} cdecl; {$ENDIF PCRE_EXPORT_CDECL}\r\n {$EXTERNALSYM pcre_free_substring_func}\r\n {$ENDIF PCRE_8}\r\n {$IFDEF PCRE_16}\r\n pcre16_free_substring_func = procedure(stringptr: PWideChar);\r\n {$IFDEF PCRE_EXPORT_CDECL} cdecl; {$ENDIF PCRE_EXPORT_CDECL}\r\n {$EXTERNALSYM pcre16_free_substring_func}\r\n {$ENDIF PCRE_16}\r\n {$IFDEF PCRE_8}\r\n pcre_free_substring_list_func = procedure(stringptr: PPAnsiChar);\r\n {$IFDEF PCRE_EXPORT_CDECL} cdecl; {$ENDIF PCRE_EXPORT_CDECL}\r\n {$EXTERNALSYM pcre_free_substring_list_func}\r\n {$ENDIF PCRE_8}\r\n {$IFDEF PCRE_16}\r\n pcre16_free_substring_list_func = procedure(stringptr: PPWideChar);\r\n {$IFDEF PCRE_EXPORT_CDECL} cdecl; {$ENDIF PCRE_EXPORT_CDECL}\r\n {$EXTERNALSYM pcre16_free_substring_list_func}\r\n {$ENDIF PCRE_16}\r\n {$IFDEF PCRE_8}\r\n pcre_fullinfo_func = function(const code: PPCRE; const extra: PPCREExtra;\r\n what: Integer; where: Pointer): Integer;\r\n {$IFDEF PCRE_EXPORT_CDECL} cdecl; {$ENDIF PCRE_EXPORT_CDECL}\r\n {$EXTERNALSYM pcre_fullinfo_func}\r\n {$ENDIF PCRE_8}\r\n {$IFDEF PCRE_16}\r\n pcre16_fullinfo_func = function(const code: PPCRE16; const extra: PPCRE16Extra;\r\n what: Integer; where: Pointer): Integer;\r\n {$IFDEF PCRE_EXPORT_CDECL} cdecl; {$ENDIF PCRE_EXPORT_CDECL}\r\n {$EXTERNALSYM pcre16_fullinfo_func}\r\n {$ENDIF PCRE_16}\r\n {$IFDEF PCRE_8}\r\n pcre_get_named_substring_func = function(const code: PPCRE; const subject: PAnsiChar;\r\n ovector: PInteger; stringcount: Integer; const stringname: PAnsiChar;\r\n const stringptr: PPAnsiChar): Integer; {$IFDEF PCRE_EXPORT_CDECL} cdecl; {$ENDIF PCRE_EXPORT_CDECL}\r\n {$EXTERNALSYM pcre_get_named_substring_func}\r\n {$ENDIF PCRE_8}\r\n {$IFDEF PCRE_16}\r\n pcre16_get_named_substring_func = function(const code: PPCRE16; const subject: PWideChar;\r\n ovector: PInteger; stringcount: Integer; const stringname: PWideChar;\r\n const stringptr: PPWideChar): Integer; {$IFDEF PCRE_EXPORT_CDECL} cdecl; {$ENDIF PCRE_EXPORT_CDECL}\r\n {$EXTERNALSYM pcre16_get_named_substring_func}\r\n {$ENDIF PCRE_16}\r\n {$IFDEF PCRE_8}\r\n pcre_get_stringnumber_func = function(const code: PPCRE;\r\n const stringname: PAnsiChar): Integer; {$IFDEF PCRE_EXPORT_CDECL} cdecl; {$ENDIF PCRE_EXPORT_CDECL}\r\n {$EXTERNALSYM pcre_get_stringnumber_func}\r\n {$ENDIF PCRE_8}\r\n {$IFDEF PCRE_16}\r\n pcre16_get_stringnumber_func = function(const code: PPCRE16;\r\n const stringname: PWideChar): Integer; {$IFDEF PCRE_EXPORT_CDECL} cdecl; {$ENDIF PCRE_EXPORT_CDECL}\r\n {$EXTERNALSYM pcre16_get_stringnumber_func}\r\n {$ENDIF PCRE_16}\r\n {$IFDEF PCRE_8}\r\n pcre_get_stringtable_entries_func = function(const code: PPCRE; const stringname: PAnsiChar;\r\n firstptr: PPAnsiChar; lastptr: PPAnsiChar): Integer;\r\n {$IFDEF PCRE_EXPORT_CDECL} cdecl; {$ENDIF PCRE_EXPORT_CDECL}\r\n {$EXTERNALSYM pcre_get_stringtable_entries_func}\r\n {$ENDIF PCRE_8}\r\n {$IFDEF PCRE_16}\r\n pcre16_get_stringtable_entries_func = function(const code: PPCRE16; const stringname: PWideChar;\r\n firstptr: PPWideChar; lastptr: PPWideChar): Integer;\r\n {$IFDEF PCRE_EXPORT_CDECL} cdecl; {$ENDIF PCRE_EXPORT_CDECL}\r\n {$EXTERNALSYM pcre16_get_stringtable_entries_func}\r\n {$ENDIF PCRE_16}\r\n {$IFDEF PCRE_8}\r\n pcre_get_substring_func = function(const subject: PAnsiChar; ovector: PInteger;\r\n stringcount, stringnumber: Integer; const stringptr: PPAnsiChar): Integer;\r\n {$IFDEF PCRE_EXPORT_CDECL} cdecl; {$ENDIF PCRE_EXPORT_CDECL}\r\n {$EXTERNALSYM pcre_get_substring_func}\r\n {$ENDIF PCRE_8}\r\n {$IFDEF PCRE_16}\r\n pcre16_get_substring_func = function(const subject: PWideChar; ovector: PInteger;\r\n stringcount, stringnumber: Integer; const stringptr: PPWideChar): Integer;\r\n {$IFDEF PCRE_EXPORT_CDECL} cdecl; {$ENDIF PCRE_EXPORT_CDECL}\r\n {$EXTERNALSYM pcre16_get_substring_func}\r\n {$ENDIF PCRE_16}\r\n {$IFDEF PCRE_8}\r\n pcre_get_substring_list_func = function(const subject: PAnsiChar; ovector: PInteger;\r\n stringcount: Integer; listptr: PPPAnsiChar): Integer;\r\n {$IFDEF PCRE_EXPORT_CDECL} cdecl; {$ENDIF PCRE_EXPORT_CDECL}\r\n {$EXTERNALSYM pcre_get_substring_list_func}\r\n {$ENDIF PCRE_8}\r\n {$IFDEF PCRE_16}\r\n pcre16_get_substring_list_func = function(const subject: PWideChar; ovector: PInteger;\r\n stringcount: Integer; listptr: PPPWideChar): Integer;\r\n {$IFDEF PCRE_EXPORT_CDECL} cdecl; {$ENDIF PCRE_EXPORT_CDECL}\r\n {$EXTERNALSYM pcre16_get_substring_list_func}\r\n {$ENDIF PCRE_16}\r\n {$IFDEF PCRE_8}\r\n pcre_maketables_func = function: PAnsiChar; {$IFDEF PCRE_EXPORT_CDECL} cdecl; {$ENDIF PCRE_EXPORT_CDECL}\r\n {$EXTERNALSYM pcre_maketables_func}\r\n {$ENDIF PCRE_8}\r\n {$IFDEF PCRE_16}\r\n pcre16_maketables_func = function: PAnsiChar; {$IFDEF PCRE_EXPORT_CDECL} cdecl; {$ENDIF PCRE_EXPORT_CDECL}\r\n {$EXTERNALSYM pcre16_maketables_func}\r\n {$ENDIF PCRE_16}\r\n {$IFDEF PCRE_8}\r\n pcre_refcount_func = function(argument_re: PPCRE; adjust: Integer): Integer;\r\n {$IFDEF PCRE_EXPORT_CDECL} cdecl; {$ENDIF PCRE_EXPORT_CDECL}\r\n {$EXTERNALSYM pcre_refcount_func}\r\n {$ENDIF PCRE_8}\r\n {$IFDEF PCRE_16}\r\n pcre16_refcount_func = function(argument_re: PPCRE16; adjust: Integer): Integer;\r\n {$IFDEF PCRE_EXPORT_CDECL} cdecl; {$ENDIF PCRE_EXPORT_CDECL}\r\n {$EXTERNALSYM pcre16_refcount_func}\r\n {$ENDIF PCRE_16}\r\n {$IFDEF PCRE_8}\r\n pcre_study_func = function(const code: PPCRE; options: Integer; const errptr: PPAnsiChar): PPCREExtra;\r\n {$IFDEF PCRE_EXPORT_CDECL} cdecl; {$ENDIF PCRE_EXPORT_CDECL}\r\n {$EXTERNALSYM pcre_study_func}\r\n {$ENDIF PCRE_8}\r\n {$IFDEF PCRE_16}\r\n pcre16_study_func = function(const code: PPCRE16; options: Integer; const errptr: PPAnsiChar): PPCRE16Extra;\r\n {$IFDEF PCRE_EXPORT_CDECL} cdecl; {$ENDIF PCRE_EXPORT_CDECL}\r\n {$EXTERNALSYM pcre16_study_func}\r\n {$ENDIF PCRE_16}\r\n {$IFDEF PCRE_8}\r\n pcre_free_study_func = procedure (const extra: PPCREExtra);\r\n {$IFDEF PCRE_EXPORT_CDECL} cdecl; {$ENDIF PCRE_EXPORT_CDECL}\r\n {$EXTERNALSYM pcre_free_study_func}\r\n {$ENDIF PCRE_8}\r\n {$IFDEF PCRE_16}\r\n pcre16_free_study_func = procedure (const extra: PPCRE16Extra);\r\n {$IFDEF PCRE_EXPORT_CDECL} cdecl; {$ENDIF PCRE_EXPORT_CDECL}\r\n {$EXTERNALSYM pcre16_free_study_func}\r\n {$ENDIF PCRE_16}\r\n {$IFDEF PCRE_8}\r\n pcre_version_func = function: PAnsiChar; {$IFDEF PCRE_EXPORT_CDECL} cdecl; {$ENDIF PCRE_EXPORT_CDECL}\r\n {$EXTERNALSYM pcre_version_func}\r\n {$ENDIF PCRE_8}\r\n {$IFDEF PCRE_16}\r\n pcre16_version_func = function: PAnsiChar; {$IFDEF PCRE_EXPORT_CDECL} cdecl; {$ENDIF PCRE_EXPORT_CDECL}\r\n {$EXTERNALSYM pcre16_version_func}\r\n {$ENDIF PCRE_16}\r\n {$IFDEF PCRE_8}\r\n pcre_jit_stack_alloc_func = function (startsize, maxsize: Integer): PPCREJITStack;\r\n {$IFDEF PCRE_EXPORT_CDECL} cdecl; {$ENDIF PCRE_EXPORT_CDECL}\r\n {$EXTERNALSYM pcre_jit_stack_alloc_func}\r\n {$ENDIF PCRE_8}\r\n {$IFDEF PCRE_16}\r\n pcre16_jit_stack_alloc_func = function (startsize, maxsize: Integer): PPCRE16JITStack;\r\n {$IFDEF PCRE_EXPORT_CDECL} cdecl; {$ENDIF PCRE_EXPORT_CDECL}\r\n {$EXTERNALSYM pcre16_jit_stack_alloc_func}\r\n {$ENDIF PCRE_16}\r\n {$IFDEF PCRE_8}\r\n pcre_jit_stack_free_func = procedure (stack: PPCREJITStack);\r\n {$IFDEF PCRE_EXPORT_CDECL} cdecl; {$ENDIF PCRE_EXPORT_CDECL}\r\n {$EXTERNALSYM pcre_jit_stack_free_func}\r\n {$ENDIF PCRE_8}\r\n {$IFDEF PCRE_16}\r\n pcre16_jit_stack_free_func = procedure (stack: PPCRE16JITStack);\r\n {$IFDEF PCRE_EXPORT_CDECL} cdecl; {$ENDIF PCRE_EXPORT_CDECL}\r\n {$EXTERNALSYM pcre16_jit_stack_free_func}\r\n {$ENDIF PCRE_16}\r\n {$IFDEF PCRE_8}\r\n pcre_assign_jit_stack_func = procedure (extra: PPCREExtra; callback: pcre_jit_callback; userdata: Pointer);\r\n {$IFDEF PCRE_EXPORT_CDECL} cdecl; {$ENDIF PCRE_EXPORT_CDECL}\r\n {$EXTERNALSYM pcre_assign_jit_stack_func}\r\n {$ENDIF PCRE_8}\r\n {$IFDEF PCRE_16}\r\n pcre16_assign_jit_stack_func = procedure (extra: PPCRE16Extra; callback: pcre16_jit_callback; userdata: Pointer);\r\n {$IFDEF PCRE_EXPORT_CDECL} cdecl; {$ENDIF PCRE_EXPORT_CDECL}\r\n {$EXTERNALSYM pcre16_assign_jit_stack_func}\r\n {$ENDIF PCRE_16}\r\n\r\nvar\r\n {$IFDEF PCRE_8}\r\n pcre_compile: pcre_compile_func = nil;\r\n {$EXTERNALSYM pcre_compile}\r\n {$ENDIF PCRE_8}\r\n {$IFDEF PCRE_16}\r\n pcre16_compile: pcre16_compile_func = nil;\r\n {$EXTERNALSYM pcre16_compile}\r\n {$ENDIF PCRE_16}\r\n {$IFDEF PCRE_8}\r\n pcre_compile2: pcre_compile2_func = nil;\r\n {$EXTERNALSYM pcre_compile2}\r\n {$ENDIF PCRE_8}\r\n {$IFDEF PCRE_16}\r\n pcre16_compile2: pcre16_compile2_func = nil;\r\n {$EXTERNALSYM pcre16_compile2}\r\n {$ENDIF PCRE_16}\r\n {$IFDEF PCRE_8}\r\n pcre_config: pcre_config_func = nil;\r\n {$EXTERNALSYM pcre_config}\r\n {$ENDIF PCRE_8}\r\n {$IFDEF PCRE_16}\r\n pcre16_config: pcre16_config_func = nil;\r\n {$EXTERNALSYM pcre16_config}\r\n {$ENDIF PCRE_16}\r\n {$IFDEF PCRE_8}\r\n pcre_copy_named_substring: pcre_copy_named_substring_func = nil;\r\n {$EXTERNALSYM pcre_copy_named_substring}\r\n {$ENDIF PCRE_8}\r\n {$IFDEF PCRE_16}\r\n pcre16_copy_named_substring: pcre16_copy_named_substring_func = nil;\r\n {$EXTERNALSYM pcre16_copy_named_substring}\r\n {$ENDIF PCRE_16}\r\n {$IFDEF PCRE_8}\r\n pcre_copy_substring: pcre_copy_substring_func = nil;\r\n {$EXTERNALSYM pcre_copy_substring}\r\n {$ENDIF PCRE_8}\r\n {$IFDEF PCRE_16}\r\n pcre16_copy_substring: pcre16_copy_substring_func = nil;\r\n {$EXTERNALSYM pcre16_copy_substring}\r\n {$ENDIF PCRE_16}\r\n {$IFDEF PCRE_8}\r\n pcre_dfa_exec: pcre_dfa_exec_func = nil;\r\n {$EXTERNALSYM pcre_dfa_exec}\r\n {$ENDIF PCRE_8}\r\n {$IFDEF PCRE_16}\r\n pcre16_dfa_exec: pcre16_dfa_exec_func = nil;\r\n {$EXTERNALSYM pcre16_dfa_exec}\r\n {$ENDIF PCRE_16}\r\n {$IFDEF PCRE_8}\r\n pcre_exec: pcre_exec_func = nil;\r\n {$EXTERNALSYM pcre_exec}\r\n {$ENDIF PCRE_8}\r\n {$IFDEF PCRE_16}\r\n pcre16_exec: pcre16_exec_func = nil;\r\n {$EXTERNALSYM pcre16_exec}\r\n {$ENDIF PCRE_16}\r\n {$IFDEF PCRE_8}\r\n pcre_free_substring: pcre_free_substring_func = nil;\r\n {$EXTERNALSYM pcre_free_substring}\r\n {$ENDIF PCRE_8}\r\n {$IFDEF PCRE_16}\r\n pcre16_free_substring: pcre16_free_substring_func = nil;\r\n {$EXTERNALSYM pcre16_free_substring}\r\n {$ENDIF PCRE_16}\r\n {$IFDEF PCRE_8}\r\n pcre_free_substring_list: pcre_free_substring_list_func = nil;\r\n {$EXTERNALSYM pcre_free_substring_list}\r\n {$ENDIF PCRE_8}\r\n {$IFDEF PCRE_16}\r\n pcre16_free_substring_list: pcre16_free_substring_list_func = nil;\r\n {$EXTERNALSYM pcre16_free_substring_list}\r\n {$ENDIF PCRE_16}\r\n {$IFDEF PCRE_8}\r\n pcre_fullinfo: pcre_fullinfo_func = nil;\r\n {$EXTERNALSYM pcre_fullinfo}\r\n {$ENDIF PCRE_8}\r\n {$IFDEF PCRE_16}\r\n pcre16_fullinfo: pcre16_fullinfo_func = nil;\r\n {$EXTERNALSYM pcre16_fullinfo}\r\n {$ENDIF PCRE_16}\r\n {$IFDEF PCRE_8}\r\n pcre_get_named_substring: pcre_get_named_substring_func = nil;\r\n {$EXTERNALSYM pcre_get_named_substring}\r\n {$ENDIF PCRE_8}\r\n {$IFDEF PCRE_16}\r\n pcre16_get_named_substring: pcre16_get_named_substring_func = nil;\r\n {$EXTERNALSYM pcre16_get_named_substring}\r\n {$ENDIF PCRE_16}\r\n {$IFDEF PCRE_8}\r\n pcre_get_stringnumber: pcre_get_stringnumber_func = nil;\r\n {$EXTERNALSYM pcre_get_stringnumber}\r\n {$ENDIF PCRE_8}\r\n {$IFDEF PCRE_16}\r\n pcre16_get_stringnumber: pcre16_get_stringnumber_func = nil;\r\n {$EXTERNALSYM pcre16_get_stringnumber}\r\n {$ENDIF PCRE_16}\r\n {$IFDEF PCRE_8}\r\n pcre_get_stringtable_entries: pcre_get_stringtable_entries_func = nil;\r\n {$EXTERNALSYM pcre_get_stringtable_entries}\r\n {$ENDIF PCRE_8}\r\n {$IFDEF PCRE_16}\r\n pcre16_get_stringtable_entries: pcre16_get_stringtable_entries_func = nil;\r\n {$EXTERNALSYM pcre16_get_stringtable_entries}\r\n {$ENDIF PCRE_16}\r\n {$IFDEF PCRE_8}\r\n pcre_get_substring: pcre_get_substring_func = nil;\r\n {$EXTERNALSYM pcre_get_substring}\r\n {$ENDIF PCRE_8}\r\n {$IFDEF PCRE_16}\r\n pcre16_get_substring: pcre16_get_substring_func = nil;\r\n {$EXTERNALSYM pcre16_get_substring}\r\n {$ENDIF PCRE_16}\r\n {$IFDEF PCRE_8}\r\n pcre_get_substring_list: pcre_get_substring_list_func = nil;\r\n {$EXTERNALSYM pcre_get_substring_list}\r\n {$ENDIF PCRE_8}\r\n {$IFDEF PCRE_16}\r\n pcre16_get_substring_list: pcre16_get_substring_list_func = nil;\r\n {$EXTERNALSYM pcre16_get_substring_list}\r\n {$ENDIF PCRE_16}\r\n {$IFDEF PCRE_8}\r\n pcre_maketables: pcre_maketables_func = nil;\r\n {$EXTERNALSYM pcre_maketables}\r\n {$ENDIF PCRE_8}\r\n {$IFDEF PCRE_16}\r\n pcre16_maketables: pcre16_maketables_func = nil;\r\n {$EXTERNALSYM pcre16_maketables}\r\n {$ENDIF PCRE_16}\r\n {$IFDEF PCRE_8}\r\n pcre_refcount: pcre_refcount_func = nil;\r\n {$EXTERNALSYM pcre_refcount}\r\n {$ENDIF PCRE_8}\r\n {$IFDEF PCRE_16}\r\n pcre16_refcount: pcre16_refcount_func = nil;\r\n {$EXTERNALSYM pcre16_refcount}\r\n {$ENDIF PCRE_16}\r\n {$IFDEF PCRE_8}\r\n pcre_study: pcre_study_func = nil;\r\n {$EXTERNALSYM pcre_study}\r\n {$ENDIF PCRE_8}\r\n {$IFDEF PCRE_16}\r\n pcre16_study: pcre16_study_func = nil;\r\n {$EXTERNALSYM pcre16_study}\r\n {$ENDIF PCRE_16}\r\n {$IFDEF PCRE_8}\r\n pcre_free_study: pcre_free_study_func = nil;\r\n {$EXTERNALSYM pcre_free_study}\r\n {$ENDIF PCRE_8}\r\n {$IFDEF PCRE_16}\r\n pcre16_free_study: pcre16_free_study_func = nil;\r\n {$EXTERNALSYM pcre16_free_study}\r\n {$ENDIF PCRE_16}\r\n {$IFDEF PCRE_8}\r\n pcre_version: pcre_version_func = nil;\r\n {$EXTERNALSYM pcre_version}\r\n {$ENDIF PCRE_8}\r\n {$IFDEF PCRE_16}\r\n pcre16_version: pcre16_version_func = nil;\r\n {$EXTERNALSYM pcre16_version}\r\n {$ENDIF PCRE_16}\r\n {$IFDEF PCRE_8}\r\n pcre_jit_stack_alloc: pcre_jit_stack_alloc_func = nil;\r\n {$EXTERNALSYM pcre_jit_stack_alloc}\r\n {$ENDIF PCRE_8}\r\n {$IFDEF PCRE_16}\r\n pcre16_jit_stack_alloc: pcre16_jit_stack_alloc_func = nil;\r\n {$EXTERNALSYM pcre16_jit_stack_alloc}\r\n {$ENDIF PCRE_16}\r\n {$IFDEF PCRE_8}\r\n pcre_jit_stack_free: pcre_jit_stack_free_func = nil;\r\n {$EXTERNALSYM pcre_jit_stack_free}\r\n {$ENDIF PCRE_8}\r\n {$IFDEF PCRE_16}\r\n pcre16_jit_stack_free: pcre16_jit_stack_free_func = nil;\r\n {$EXTERNALSYM pcre16_jit_stack_free}\r\n {$ENDIF PCRE_16}\r\n {$IFDEF PCRE_8}\r\n pcre_assign_jit_stack: pcre_assign_jit_stack_func = nil;\r\n {$EXTERNALSYM pcre_assign_jit_stack}\r\n {$ENDIF PCRE_8}\r\n {$IFDEF PCRE_16}\r\n pcre16_assign_jit_stack: pcre16_assign_jit_stack_func = nil;\r\n {$EXTERNALSYM pcre16_assign_jit_stack}\r\n {$ENDIF PCRE_16}\r\n\r\n{$ENDIF PCRE_LINKONREQUEST}\r\n\r\n{$ENDIF ~PCRE_RTL}\r\n//DOM-IGNORE-END\r\n\r\nconst\r\n {$IFDEF MSWINDOWS}\r\n PCREDefaultLibraryName = 'pcre3.dll';\r\n {$ENDIF MSWINDOWS}\r\n {$IFDEF UNIX}\r\n PCREDefaultLibraryName = 'libpcre.so.0';\r\n {$ENDIF UNIX}\r\n {$IFDEF PCRE_8}\r\n PCRECompileDefaultExportName = 'pcre_compile';\r\n {$ENDIF PCRE_8}\r\n {$IFDEF PCRE_16}\r\n PCRE16CompileDefaultExportName = 'pcre16_compile';\r\n {$ENDIF PCRE_16}\r\n {$IFDEF PCRE_8}\r\n PCRECompile2DefaultExportName = 'pcre_compile2';\r\n {$ENDIF PCRE_8}\r\n {$IFDEF PCRE_16}\r\n PCRE16Compile2DefaultExportName = 'pcre16_compile2';\r\n {$ENDIF PCRE_16}\r\n {$IFDEF PCRE_8}\r\n PCREConfigDefaultExportName = 'pcre_config';\r\n {$ENDIF PCRE_8}\r\n {$IFDEF PCRE_16}\r\n PCRE16ConfigDefaultExportName = 'pcre16_config';\r\n {$ENDIF PCRE_16}\r\n {$IFDEF PCRE_8}\r\n PCRECopyNamedSubstringDefaultExportName = 'pcre_copy_named_substring';\r\n {$ENDIF PCRE_8}\r\n {$IFDEF PCRE_16}\r\n PCRE16CopyNamedSubstringDefaultExportName = 'pcre16_copy_named_substring';\r\n {$ENDIF PCRE_16}\r\n {$IFDEF PCRE_8}\r\n PCRECopySubStringDefaultExportName = 'pcre_copy_substring';\r\n {$ENDIF PCRE_8}\r\n {$IFDEF PCRE_16}\r\n PCRE16CopySubStringDefaultExportName = 'pcre16_copy_substring';\r\n {$ENDIF PCRE_16}\r\n {$IFDEF PCRE_8}\r\n PCREDfaExecDefaultExportName = 'pcre_dfa_exec';\r\n {$ENDIF PCRE_8}\r\n {$IFDEF PCRE_16}\r\n PCRE16DfaExecDefaultExportName = 'pcre16_dfa_exec';\r\n {$ENDIF PCRE_16}\r\n {$IFDEF PCRE_8}\r\n PCREExecDefaultExportName = 'pcre_exec';\r\n {$ENDIF PCRE_8}\r\n {$IFDEF PCRE_16}\r\n PCRE16ExecDefaultExportName = 'pcre16_exec';\r\n {$ENDIF PCRE_16}\r\n {$IFDEF PCRE_8}\r\n PCREFreeSubStringDefaultExportName = 'pcre_free_substring';\r\n {$ENDIF PCRE_8}\r\n {$IFDEF PCRE_16}\r\n PCRE16FreeSubStringDefaultExportName = 'pcre16_free_substring';\r\n {$ENDIF PCRE_16}\r\n {$IFDEF PCRE_8}\r\n PCREFreeSubStringListDefaultExportName = 'pcre_free_substring_list';\r\n {$ENDIF PCRE_8}\r\n {$IFDEF PCRE_16}\r\n PCRE16FreeSubStringListDefaultExportName = 'pcre16_free_substring_list';\r\n {$ENDIF PCRE_16}\r\n {$IFDEF PCRE_8}\r\n PCREFullInfoDefaultExportName = 'pcre_fullinfo';\r\n {$ENDIF PCRE_8}\r\n {$IFDEF PCRE_16}\r\n PCRE16FullInfoDefaultExportName = 'pcre16_fullinfo';\r\n {$ENDIF PCRE_16}\r\n {$IFDEF PCRE_8}\r\n PCREGetNamedSubstringDefaultExportName = 'pcre_get_named_substring';\r\n {$ENDIF PCRE_8}\r\n {$IFDEF PCRE_16}\r\n PCRE16GetNamedSubstringDefaultExportName = 'pcre16_get_named_substring';\r\n {$ENDIF PCRE_16}\r\n {$IFDEF PCRE_8}\r\n PCREGetStringNumberDefaultExportName = 'pcre_get_stringnumber';\r\n {$ENDIF PCRE_8}\r\n {$IFDEF PCRE_16}\r\n PCRE16GetStringNumberDefaultExportName = 'pcre16_get_stringnumber';\r\n {$ENDIF PCRE_16}\r\n {$IFDEF PCRE_8}\r\n PCREGetStringTableEntriesDefaultExportName = 'pcre_get_stringtable_entries';\r\n {$ENDIF PCRE_8}\r\n {$IFDEF PCRE_16}\r\n PCRE16GetStringTableEntriesDefaultExportName = 'pcre16_get_stringtable_entries';\r\n {$ENDIF PCRE_16}\r\n {$IFDEF PCRE_8}\r\n PCREGetSubStringDefaultExportName = 'pcre_get_substring';\r\n {$ENDIF PCRE_8}\r\n {$IFDEF PCRE_16}\r\n PCRE16GetSubStringDefaultExportName = 'pcre16_get_substring';\r\n {$ENDIF PCRE_16}\r\n {$IFDEF PCRE_8}\r\n PCREGetSubStringListDefaultExportName = 'pcre_get_substring_list';\r\n {$ENDIF PCRE_8}\r\n {$IFDEF PCRE_16}\r\n PCRE16GetSubStringListDefaultExportName = 'pcre16_get_substring_list';\r\n {$ENDIF PCRE_16}\r\n {$IFDEF PCRE_8}\r\n PCREMakeTablesDefaultExportName = 'pcre_maketables';\r\n {$ENDIF PCRE_8}\r\n {$IFDEF PCRE_16}\r\n PCRE16MakeTablesDefaultExportName = 'pcre16_maketables';\r\n {$ENDIF PCRE_16}\r\n {$IFDEF PCRE_8}\r\n PCRERefCountDefaultExportName = 'pcre_refcount';\r\n {$ENDIF PCRE_8}\r\n {$IFDEF PCRE_16}\r\n PCRE16RefCountDefaultExportName = 'pcre16_refcount';\r\n {$ENDIF PCRE_16}\r\n {$IFDEF PCRE_8}\r\n PCREStudyDefaultExportName = 'pcre_study';\r\n {$ENDIF PCRE_8}\r\n {$IFDEF PCRE_16}\r\n PCRE16StudyDefaultExportName = 'pcre16_study';\r\n {$ENDIF PCRE_16}\r\n {$IFDEF PCRE_8}\r\n PCREFreeStudyDefaultExportName = 'pcre_free_study';\r\n {$ENDIF PCRE_8}\r\n {$IFDEF PCRE_16}\r\n PCRE16FreeStudyDefaultExportName = 'pcre16_free_study';\r\n {$ENDIF PCRE_16}\r\n {$IFDEF PCRE_8}\r\n PCREVersionDefaultExportName = 'pcre_version';\r\n {$ENDIF PCRE_8}\r\n {$IFDEF PCRE_16}\r\n PCRE16VersionDefaultExportName = 'pcre16_version';\r\n {$ENDIF PCRE_16}\r\n {$IFDEF PCRE_8}\r\n PCREJITStackAllocDefaultExportName = 'pcre_jit_stack_alloc';\r\n {$ENDIF PCRE_8}\r\n {$IFDEF PCRE_16}\r\n PCRE16JITStackAllocDefaultExportName = 'pcre16_jit_stack_alloc';\r\n {$ENDIF PCRE_16}\r\n {$IFDEF PCRE_8}\r\n PCREJITStackFreeDefaultExportName = 'pcre_jit_stack_free';\r\n {$ENDIF PCRE_8}\r\n {$IFDEF PCRE_16}\r\n PCRE16JITStackFreeDefaultExportName = 'pcre16_jit_stack_free';\r\n {$ENDIF PCRE_16}\r\n {$IFDEF PCRE_8}\r\n PCREAssignJITStackDefaultExportName = 'pcre_assign_jit_stack';\r\n {$ENDIF PCRE_8}\r\n {$IFDEF PCRE_16}\r\n PCRE16AssignJITStackDefaultExportName = 'pcre16_assign_jit_stack';\r\n {$ENDIF PCRE_16}\r\n {$IFDEF PCRE_8}\r\n PCREMallocDefaultExportName = 'pcre_malloc';\r\n {$ENDIF PCRE_8}\r\n {$IFDEF PCRE_16}\r\n PCRE16MallocDefaultExportName = 'pcre16_malloc';\r\n {$ENDIF PCRE_16}\r\n {$IFDEF PCRE_8}\r\n PCREFreeDefaultExportName = 'pcre_free';\r\n {$ENDIF PCRE_8}\r\n {$IFDEF PCRE_16}\r\n PCRE16FreeDefaultExportName = 'pcre16_free';\r\n {$ENDIF PCRE_16}\r\n {$IFDEF PCRE_8}\r\n PCREStackMallocDefaultExportName = 'pcre_stack_malloc';\r\n {$ENDIF PCRE_8}\r\n {$IFDEF PCRE_16}\r\n PCRE16StackMallocDefaultExportName = 'pcre16_stack_malloc';\r\n {$ENDIF PCRE_16}\r\n {$IFDEF PCRE_8}\r\n PCREStackFreeDefaultExportName = 'pcre_stack_free';\r\n {$ENDIF PCRE_8}\r\n {$IFDEF PCRE_16}\r\n PCRE16StackFreeDefaultExportName = 'pcre16_stack_free';\r\n {$ENDIF PCRE_16}\r\n {$IFDEF PCRE_8}\r\n PCRECalloutDefaultExportName = 'pcre_callout';\r\n {$ENDIF PCRE_8}\r\n {$IFDEF PCRE_16}\r\n PCRE16CalloutDefaultExportName = 'pcre16_callout';\r\n {$ENDIF PCRE_16}\r\n\r\n{$IFDEF PCRE_LINKONREQUEST}\r\nvar\r\n PCRELibraryName: string = PCREDefaultLibraryName;\r\n\r\n {$IFDEF PCRE_8}\r\n PCRECompileExportName: string = PCRECompileDefaultExportName;\r\n {$ENDIF PCRE_8}\r\n {$IFDEF PCRE_16}\r\n PCRE16CompileExportName: string = PCRE16CompileDefaultExportName;\r\n {$ENDIF PCRE_16}\r\n {$IFDEF PCRE_8}\r\n PCRECompile2ExportName: string = PCRECompile2DefaultExportName;\r\n {$ENDIF PCRE_8}\r\n {$IFDEF PCRE_16}\r\n PCRE16Compile2ExportName: string = PCRE16Compile2DefaultExportName;\r\n {$ENDIF PCRE_16}\r\n {$IFDEF PCRE_8}\r\n PCREConfigExportName: string = PCREConfigDefaultExportName;\r\n {$ENDIF PCRE_8}\r\n {$IFDEF PCRE_16}\r\n PCRE16ConfigExportName: string = PCRE16ConfigDefaultExportName;\r\n {$ENDIF PCRE_16}\r\n {$IFDEF PCRE_8}\r\n PCRECopyNamedSubstringExportName: string = PCRECopyNamedSubstringDefaultExportName;\r\n {$ENDIF PCRE_8}\r\n {$IFDEF PCRE_16}\r\n PCRE16CopyNamedSubstringExportName: string = PCRE16CopyNamedSubstringDefaultExportName;\r\n {$ENDIF PCRE_16}\r\n {$IFDEF PCRE_8}\r\n PCRECopySubStringExportName: string = PCRECopySubStringDefaultExportName;\r\n {$ENDIF PCRE_8}\r\n {$IFDEF PCRE_16}\r\n PCRE16CopySubStringExportName: string = PCRE16CopySubStringDefaultExportName;\r\n {$ENDIF PCRE_16}\r\n {$IFDEF PCRE_8}\r\n PCREDfaExecExportName: string = PCREDfaExecDefaultExportName;\r\n {$ENDIF PCRE_8}\r\n {$IFDEF PCRE_16}\r\n PCRE16DfaExecExportName: string = PCRE16DfaExecDefaultExportName;\r\n {$ENDIF PCRE_16}\r\n {$IFDEF PCRE_8}\r\n PCREExecExportName: string = PCREExecDefaultExportName;\r\n {$ENDIF PCRE_8}\r\n {$IFDEF PCRE_16}\r\n PCRE16ExecExportName: string = PCRE16ExecDefaultExportName;\r\n {$ENDIF PCRE_16}\r\n {$IFDEF PCRE_8}\r\n PCREFreeSubStringExportName: string = PCREFreeSubStringDefaultExportName;\r\n {$ENDIF PCRE_8}\r\n {$IFDEF PCRE_16}\r\n PCRE16FreeSubStringExportName: string = PCRE16FreeSubStringDefaultExportName;\r\n {$ENDIF PCRE_16}\r\n {$IFDEF PCRE_8}\r\n PCREFreeSubStringListExportName: string = PCREFreeSubStringListDefaultExportName;\r\n {$ENDIF PCRE_8}\r\n {$IFDEF PCRE_16}\r\n PCRE16FreeSubStringListExportName: string = PCRE16FreeSubStringListDefaultExportName;\r\n {$ENDIF PCRE_16}\r\n {$IFDEF PCRE_8}\r\n PCREFullInfoExportName: string = PCREFullInfoDefaultExportName;\r\n {$ENDIF PCRE_8}\r\n {$IFDEF PCRE_16}\r\n PCRE16FullInfoExportName: string = PCRE16FullInfoDefaultExportName;\r\n {$ENDIF PCRE_16}\r\n {$IFDEF PCRE_8}\r\n PCREGetNamedSubstringExportName: string = PCREGetNamedSubstringDefaultExportName;\r\n {$ENDIF PCRE_8}\r\n {$IFDEF PCRE_16}\r\n PCRE16GetNamedSubstringExportName: string = PCRE16GetNamedSubstringDefaultExportName;\r\n {$ENDIF PCRE_16}\r\n {$IFDEF PCRE_8}\r\n PCREGetStringNumberExportName: string = PCREGetStringNumberDefaultExportName;\r\n {$ENDIF PCRE_8}\r\n {$IFDEF PCRE_16}\r\n PCRE16GetStringNumberExportName: string = PCRE16GetStringNumberDefaultExportName;\r\n {$ENDIF PCRE_16}\r\n {$IFDEF PCRE_8}\r\n PCREGetStringTableEntriesExportName: string = PCREGetStringTableEntriesDefaultExportName;\r\n {$ENDIF PCRE_8}\r\n {$IFDEF PCRE_16}\r\n PCRE16GetStringTableEntriesExportName: string = PCRE16GetStringTableEntriesDefaultExportName;\r\n {$ENDIF PCRE_16}\r\n {$IFDEF PCRE_8}\r\n PCREGetSubStringExportName: string = PCREGetSubStringDefaultExportName;\r\n {$ENDIF PCRE_8}\r\n {$IFDEF PCRE_16}\r\n PCRE16GetSubStringExportName: string = PCRE16GetSubStringDefaultExportName;\r\n {$ENDIF PCRE_16}\r\n {$IFDEF PCRE_8}\r\n PCREGetSubStringListExportName: string = PCREGetSubStringListDefaultExportName;\r\n {$ENDIF PCRE_8}\r\n {$IFDEF PCRE_16}\r\n PCRE16GetSubStringListExportName: string = PCRE16GetSubStringListDefaultExportName;\r\n {$ENDIF PCRE_16}\r\n {$IFDEF PCRE_8}\r\n PCREMakeTablesExportName: string = PCREMakeTablesDefaultExportName;\r\n {$ENDIF PCRE_8}\r\n {$IFDEF PCRE_16}\r\n PCRE16MakeTablesExportName: string = PCRE16MakeTablesDefaultExportName;\r\n {$ENDIF PCRE_16}\r\n {$IFDEF PCRE_8}\r\n PCRERefCountExportName: string = PCRERefCountDefaultExportName;\r\n {$ENDIF PCRE_8}\r\n {$IFDEF PCRE_16}\r\n PCRE16RefCountExportName: string = PCRE16RefCountDefaultExportName;\r\n {$ENDIF PCRE_16}\r\n {$IFDEF PCRE_8}\r\n PCREStudyExportName: string = PCREStudyDefaultExportName;\r\n {$ENDIF PCRE_8}\r\n {$IFDEF PCRE_16}\r\n PCRE16StudyExportName: string = PCRE16StudyDefaultExportName;\r\n {$ENDIF PCRE_16}\r\n {$IFDEF PCRE_8}\r\n PCREFreeStudyExportName: string = PCREFreeStudyDefaultExportName;\r\n {$ENDIF PCRE_8}\r\n {$IFDEF PCRE_16}\r\n PCRE16FreeStudyExportName: string = PCRE16FreeStudyDefaultExportName;\r\n {$ENDIF PCRE_16}\r\n {$IFDEF PCRE_8}\r\n PCREVersionExportName: string = PCREVersionDefaultExportName;\r\n {$ENDIF PCRE_8}\r\n {$IFDEF PCRE_16}\r\n PCRE16VersionExportName: string = PCRE16VersionDefaultExportName;\r\n {$ENDIF PCRE_16}\r\n {$IFDEF PCRE_8}\r\n PCREJITStackAllocExportName: string = PCREJITStackAllocDefaultExportName;\r\n {$ENDIF PCRE_8}\r\n {$IFDEF PCRE_16}\r\n PCRE16JITStackAllocExportName: string = PCRE16JITStackAllocDefaultExportName;\r\n {$ENDIF PCRE_16}\r\n {$IFDEF PCRE_8}\r\n PCREJITStackFreeExportName: string = PCREJITStackFreeDefaultExportName;\r\n {$ENDIF PCRE_8}\r\n {$IFDEF PCRE_16}\r\n PCRE16JITStackFreeExportName: string = PCRE16JITStackFreeDefaultExportName;\r\n {$ENDIF PCRE_16}\r\n {$IFDEF PCRE_8}\r\n PCREAssignJITStackExportName: string = PCREAssignJITStackDefaultExportName;\r\n {$ENDIF PCRE_8}\r\n {$IFDEF PCRE_16}\r\n PCRE16AssignJITStackExportName: string = PCRE16AssignJITStackDefaultExportName;\r\n {$ENDIF PCRE_16}\r\n {$IFDEF PCRE_8}\r\n PCREMallocExportName: string = PCREMallocDefaultExportName;\r\n {$ENDIF PCRE_8}\r\n {$IFDEF PCRE_16}\r\n PCRE16MallocExportName: string = PCRE16MallocDefaultExportName;\r\n {$ENDIF PCRE_16}\r\n {$IFDEF PCRE_8}\r\n PCREFreeExportName: string = PCREFreeDefaultExportName;\r\n {$ENDIF PCRE_8}\r\n {$IFDEF PCRE_16}\r\n PCRE16FreeExportName: string = PCRE16FreeDefaultExportName;\r\n {$ENDIF PCRE_16}\r\n {$IFDEF PCRE_8}\r\n PCREStackMallocExportName: string = PCREStackMallocDefaultExportName;\r\n {$ENDIF PCRE_8}\r\n {$IFDEF PCRE_16}\r\n PCRE16StackMallocExportName: string = PCRE16StackMallocDefaultExportName;\r\n {$ENDIF PCRE_16}\r\n {$IFDEF PCRE_8}\r\n PCREStackFreeExportName: string = PCREStackFreeDefaultExportName;\r\n {$ENDIF PCRE_8}\r\n {$IFDEF PCRE_16}\r\n PCRE16StackFreeExportName: string = PCRE16StackFreeDefaultExportName;\r\n {$ENDIF PCRE_16}\r\n {$IFDEF PCRE_8}\r\n PCRECalloutExportName: string = PCRECalloutDefaultExportName;\r\n {$ENDIF PCRE_8}\r\n {$IFDEF PCRE_16}\r\n PCRE16CalloutExportName: string = PCRE16CalloutDefaultExportName;\r\n {$ENDIF PCRE_16}\r\n{$ENDIF PCRE_LINKONREQUEST}\r\n\r\nvar\r\n PCRELib: TModuleHandle = INVALID_MODULEHANDLE_VALUE;\r\n\r\nfunction IsPCRELoaded: Boolean;\r\nfunction LoadPCRE: Boolean;\r\nprocedure UnloadPCRE;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jcl.svn.sourceforge.net/svnroot/jcl/tags/JCL-2.4-Build4571/jcl/source/common/pcre.pas $';\r\n Revision: '$Revision: 3855 $';\r\n Date: '$Date: 2012-09-03 00:25:26 +0200 (lun. 03 sept. 2012) $';\r\n LogPath: 'JCL\\source\\common';\r\n Extra: '';\r\n Data: nil\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n {$IFDEF HAS_UNIT_LIBC}\r\n Libc,\r\n {$ENDIF HAS_UNIT_LIBC}\r\n {$IFDEF HAS_UNITSCOPE}\r\n {$IFDEF MSWINDOWS}\r\n Winapi.Windows,\r\n {$ENDIF MSWINDOWS}\r\n System.Types, System.SysUtils;\r\n {$ELSE ~HAS_UNITSCOPE}\r\n {$IFDEF MSWINDOWS}\r\n Windows,\r\n {$ENDIF MSWINDOWS}\r\n Types, SysUtils;\r\n {$ENDIF ~HAS_UNITSCOPE}\r\n\r\n{$IFNDEF PCRE_RTL}\r\n{$IFDEF PCRE_STATICLINK}\r\n\r\n{$IFDEF PCRE_8}\r\n// make the linker happy with PCRE 8.00\r\nprocedure _pcre_find_bracket; external;\r\n// make the linker happy with PCRE 8.21\r\nprocedure _pcre_jit_compile; external;\r\nprocedure _pcre_jit_free; external;\r\n{$ENDIF PCRE_8}\r\n\r\n{$IFDEF PCRE_16}\r\n// make the linker happy with PCRE 8.30\r\nprocedure _pcre16_find_bracket; external;\r\nprocedure _pcre16_jit_compile; external;\r\nprocedure _pcre16_jit_free; external;\r\n{$ENDIF PCRE_16}\r\n\r\n{$IFDEF CPU32}\r\n\r\n{$IFDEF PCRE_8}\r\n\r\n{$LINK ..\\windows\\obj\\pcre\\win32\\pcre_compile.obj}\r\n{$LINK ..\\windows\\obj\\pcre\\win32\\pcre_config.obj}\r\n{$LINK ..\\windows\\obj\\pcre\\win32\\pcre_dfa_exec.obj}\r\n{$LINK ..\\windows\\obj\\pcre\\win32\\pcre_exec.obj}\r\n{$LINK ..\\windows\\obj\\pcre\\win32\\pcre_fullinfo.obj}\r\n{$LINK ..\\windows\\obj\\pcre\\win32\\pcre_get.obj}\r\n{$LINK ..\\windows\\obj\\pcre\\win32\\pcre_jit_compile.obj}\r\n{$LINK ..\\windows\\obj\\pcre\\win32\\pcre_maketables.obj}\r\n{$LINK ..\\windows\\obj\\pcre\\win32\\pcre_newline.obj}\r\n{$LINK ..\\windows\\obj\\pcre\\win32\\pcre_ord2utf8.obj}\r\n{$LINK ..\\windows\\obj\\pcre\\win32\\pcre_refcount.obj}\r\n{$LINK ..\\windows\\obj\\pcre\\win32\\pcre_study.obj}\r\n{$LINK ..\\windows\\obj\\pcre\\win32\\pcre_tables.obj}\r\n{$LINK ..\\windows\\obj\\pcre\\win32\\pcre_ucd.obj}\r\n{$LINK ..\\windows\\obj\\pcre\\win32\\pcre_valid_utf8.obj}\r\n{$LINK ..\\windows\\obj\\pcre\\win32\\pcre_version.obj}\r\n{$LINK ..\\windows\\obj\\pcre\\win32\\pcre_xclass.obj}\r\n{$LINK ..\\windows\\obj\\pcre\\win32\\pcre_chartables.obj}\r\n\r\n{$ENDIF PCRE_8}\r\n\r\n{$IFDEF PCRE_16}\r\n\r\n{$LINK ..\\windows\\obj\\pcre\\win32\\pcre16_compile.obj}\r\n{$LINK ..\\windows\\obj\\pcre\\win32\\pcre16_config.obj}\r\n{$LINK ..\\windows\\obj\\pcre\\win32\\pcre16_dfa_exec.obj}\r\n{$LINK ..\\windows\\obj\\pcre\\win32\\pcre16_exec.obj}\r\n{$LINK ..\\windows\\obj\\pcre\\win32\\pcre16_fullinfo.obj}\r\n{$LINK ..\\windows\\obj\\pcre\\win32\\pcre16_get.obj}\r\n{$LINK ..\\windows\\obj\\pcre\\win32\\pcre16_jit_compile.obj}\r\n{$LINK ..\\windows\\obj\\pcre\\win32\\pcre16_maketables.obj}\r\n{$LINK ..\\windows\\obj\\pcre\\win32\\pcre16_newline.obj}\r\n{$LINK ..\\windows\\obj\\pcre\\win32\\pcre16_ord2utf16.obj}\r\n{$LINK ..\\windows\\obj\\pcre\\win32\\pcre16_refcount.obj}\r\n{$LINK ..\\windows\\obj\\pcre\\win32\\pcre16_study.obj}\r\n{$LINK ..\\windows\\obj\\pcre\\win32\\pcre16_tables.obj}\r\n{$LINK ..\\windows\\obj\\pcre\\win32\\pcre16_ucd.obj}\r\n{$LINK ..\\windows\\obj\\pcre\\win32\\pcre16_valid_utf16.obj}\r\n{$LINK ..\\windows\\obj\\pcre\\win32\\pcre16_version.obj}\r\n{$LINK ..\\windows\\obj\\pcre\\win32\\pcre16_xclass.obj}\r\n{$LINK ..\\windows\\obj\\pcre\\win32\\pcre16_chartables.obj}\r\n{$LINK ..\\windows\\obj\\pcre\\win32\\pcre16_string_utils.obj}\r\n{$ENDIF PCRE_16}\r\n\r\n{$ENDIF CPU32}\r\n{$IFDEF CPU64}\r\n\r\n{$IFDEF PCRE_8}\r\n\r\n{$LINK ..\\windows\\obj\\pcre\\win64\\pcre_compile.obj}\r\n{$LINK ..\\windows\\obj\\pcre\\win64\\pcre_config.obj}\r\n{$LINK ..\\windows\\obj\\pcre\\win64\\pcre_dfa_exec.obj}\r\n{$LINK ..\\windows\\obj\\pcre\\win64\\pcre_exec.obj}\r\n{$LINK ..\\windows\\obj\\pcre\\win64\\pcre_fullinfo.obj}\r\n{$LINK ..\\windows\\obj\\pcre\\win64\\pcre_get.obj}\r\n{$LINK ..\\windows\\obj\\pcre\\win64\\pcre_jit_compile.obj}\r\n{$LINK ..\\windows\\obj\\pcre\\win64\\pcre_maketables.obj}\r\n{$LINK ..\\windows\\obj\\pcre\\win64\\pcre_newline.obj}\r\n{$LINK ..\\windows\\obj\\pcre\\win64\\pcre_ord2utf8.obj}\r\n{$LINK ..\\windows\\obj\\pcre\\win64\\pcre_refcount.obj}\r\n{$LINK ..\\windows\\obj\\pcre\\win64\\pcre_study.obj}\r\n{$LINK ..\\windows\\obj\\pcre\\win64\\pcre_tables.obj}\r\n{$LINK ..\\windows\\obj\\pcre\\win64\\pcre_ucd.obj}\r\n{$LINK ..\\windows\\obj\\pcre\\win64\\pcre_valid_utf8.obj}\r\n{$LINK ..\\windows\\obj\\pcre\\win64\\pcre_version.obj}\r\n{$LINK ..\\windows\\obj\\pcre\\win64\\pcre_xclass.obj}\r\n{$LINK ..\\windows\\obj\\pcre\\win64\\pcre_chartables.obj}\r\n\r\n{$ENDIF PCRE_8}\r\n\r\n{$IFDEF PCRE_16}\r\n\r\n{$LINK ..\\windows\\obj\\pcre\\win64\\pcre16_compile.obj}\r\n{$LINK ..\\windows\\obj\\pcre\\win64\\pcre16_config.obj}\r\n{$LINK ..\\windows\\obj\\pcre\\win64\\pcre16_dfa_exec.obj}\r\n{$LINK ..\\windows\\obj\\pcre\\win64\\pcre16_exec.obj}\r\n{$LINK ..\\windows\\obj\\pcre\\win64\\pcre16_fullinfo.obj}\r\n{$LINK ..\\windows\\obj\\pcre\\win64\\pcre16_get.obj}\r\n{$LINK ..\\windows\\obj\\pcre\\win64\\pcre16_jit_compile.obj}\r\n{$LINK ..\\windows\\obj\\pcre\\win64\\pcre16_maketables.obj}\r\n{$LINK ..\\windows\\obj\\pcre\\win64\\pcre16_newline.obj}\r\n{$LINK ..\\windows\\obj\\pcre\\win64\\pcre16_ord2utf16.obj}\r\n{$LINK ..\\windows\\obj\\pcre\\win64\\pcre16_refcount.obj}\r\n{$LINK ..\\windows\\obj\\pcre\\win64\\pcre16_study.obj}\r\n{$LINK ..\\windows\\obj\\pcre\\win64\\pcre16_tables.obj}\r\n{$LINK ..\\windows\\obj\\pcre\\win64\\pcre16_ucd.obj}\r\n{$LINK ..\\windows\\obj\\pcre\\win64\\pcre16_valid_utf16.obj}\r\n{$LINK ..\\windows\\obj\\pcre\\win64\\pcre16_version.obj}\r\n{$LINK ..\\windows\\obj\\pcre\\win64\\pcre16_xclass.obj}\r\n{$LINK ..\\windows\\obj\\pcre\\win64\\pcre16_chartables.obj}\r\n{$LINK ..\\windows\\obj\\pcre\\win64\\pcre16_string_utils.obj}\r\n\r\n{$ENDIF PCRE_16}\r\n\r\n{$ENDIF CPU64}\r\n\r\n// user's defined callbacks\r\nvar\r\n {$IFDEF PCRE_8}\r\n pcre_malloc_user: pcre_malloc_callback;\r\n pcre_free_user: pcre_free_callback;\r\n pcre_stack_malloc_user: pcre_stack_malloc_callback;\r\n pcre_stack_free_user: pcre_stack_free_callback;\r\n pcre_callout_user: pcre_callout_callback;\r\n {$ENDIF PCRE_8}\r\n {$IFDEF PCRE_16}\r\n pcre16_malloc_user: pcre16_malloc_callback;\r\n pcre16_free_user: pcre16_free_callback;\r\n pcre16_stack_malloc_user: pcre16_stack_malloc_callback;\r\n pcre16_stack_free_user: pcre16_stack_free_callback;\r\n pcre16_callout_user: pcre16_callout_callback;\r\n {$ENDIF PCRE_16}\r\n\r\n{$IFDEF PCRE_8}\r\nfunction pcre_compile; external;\r\nfunction pcre_compile2; external;\r\nfunction pcre_config; external;\r\nfunction pcre_copy_named_substring; external;\r\nfunction pcre_copy_substring; external;\r\nfunction pcre_dfa_exec; external;\r\nfunction pcre_exec; external;\r\nprocedure pcre_free_substring; external;\r\nprocedure pcre_free_substring_list; external;\r\nfunction pcre_fullinfo; external;\r\nfunction pcre_get_named_substring; external;\r\nfunction pcre_get_stringnumber; external;\r\nfunction pcre_get_stringtable_entries; external;\r\nfunction pcre_get_substring; external;\r\nfunction pcre_get_substring_list; external;\r\nfunction pcre_maketables; external;\r\nfunction pcre_refcount; external;\r\nfunction pcre_study; external;\r\nprocedure pcre_free_study; external;\r\nfunction pcre_version; external;\r\nfunction pcre_jit_stack_alloc; external;\r\nprocedure pcre_jit_stack_free; external;\r\nprocedure pcre_assign_jit_stack; external;\r\n{$ENDIF PCRE_8}\r\n{$IFDEF PCRE_16}\r\nfunction pcre16_compile; external;\r\nfunction pcre16_compile2; external;\r\nfunction pcre16_config; external;\r\nfunction pcre16_copy_named_substring; external;\r\nfunction pcre16_copy_substring; external;\r\nfunction pcre16_dfa_exec; external;\r\nfunction pcre16_exec; external;\r\nprocedure pcre16_free_substring; external;\r\nprocedure pcre16_free_substring_list; external;\r\nfunction pcre16_fullinfo; external;\r\nfunction pcre16_get_named_substring; external;\r\nfunction pcre16_get_stringnumber; external;\r\nfunction pcre16_get_stringtable_entries; external;\r\nfunction pcre16_get_substring; external;\r\nfunction pcre16_get_substring_list; external;\r\nfunction pcre16_maketables; external;\r\nfunction pcre16_refcount; external;\r\nfunction pcre16_study; external;\r\nprocedure pcre16_free_study; external;\r\nfunction pcre16_version; external;\r\nfunction pcre16_jit_stack_alloc; external;\r\nprocedure pcre16_jit_stack_free; external;\r\nprocedure pcre16_assign_jit_stack; external;\r\n{$ENDIF PCRE_16}\r\n\r\ntype\r\n size_t = Longint;\r\n\r\nconst\r\n szMSVCRT = 'MSVCRT.DLL';\r\n\r\nfunction malloc(size: size_t): Pointer; cdecl; external szMSVCRT name 'malloc';\r\n\r\n{$IFDEF CPU32}\r\nfunction _memcpy(dest, src: Pointer; count: size_t): Pointer; cdecl; external szMSVCRT name 'memcpy';\r\nfunction _memmove(dest, src: Pointer; count: size_t): Pointer; cdecl; external szMSVCRT name 'memmove';\r\nfunction _memset(dest: Pointer; val: Integer; count: size_t): Pointer; cdecl; external szMSVCRT name 'memset';\r\nfunction _strncmp(s1: PAnsiChar; s2: PAnsiChar; n: size_t): Integer; cdecl; external szMSVCRT name 'strncmp';\r\nfunction _memcmp(s1: Pointer; s2: Pointer; n: size_t): Integer; cdecl; external szMSVCRT name 'memcmp';\r\nfunction _strlen(s: PAnsiChar): size_t; cdecl; external szMSVCRT name 'strlen';\r\nfunction __ltolower(__ch: Integer): Integer; cdecl; external szMSVCRT name 'tolower';\r\nfunction __ltoupper(__ch: Integer): Integer; cdecl; external szMSVCRT name 'toupper';\r\nfunction _isalnum(__ch: Integer): Integer; cdecl; external szMSVCRT name 'isalnum';\r\nfunction _isalpha(__ch: Integer): Integer; cdecl; external szMSVCRT name 'isalpha';\r\nfunction _iscntrl(__ch: Integer): Integer; cdecl; external szMSVCRT name 'iscntrl';\r\nfunction _isdigit(__ch: Integer): Integer; cdecl; external szMSVCRT name 'isdigit';\r\nfunction _isgraph(__ch: Integer): Integer; cdecl; external szMSVCRT name 'isgraph';\r\nfunction _islower(__ch: Integer): Integer; cdecl; external szMSVCRT name 'islower';\r\nfunction _isprint(__ch: Integer): Integer; cdecl; external szMSVCRT name 'isprint';\r\nfunction _ispunct(__ch: Integer): Integer; cdecl; external szMSVCRT name 'ispunct';\r\nfunction _isspace(__ch: Integer): Integer; cdecl; external szMSVCRT name 'isspace';\r\nfunction _isupper(__ch: Integer): Integer; cdecl; external szMSVCRT name 'isupper';\r\nfunction _isxdigit(__ch: Integer): Integer; cdecl; external szMSVCRT name 'isxdigit';\r\nfunction _strchr(__s: PAnsiChar; __c: Integer): PAnsiChar; cdecl; external szMSVCRT name 'strchr';\r\n\r\nfunction ___alloca_helper(size: size_t): Pointer; cdecl;\r\nbegin\r\n Result := malloc(size);\r\nend;\r\n\r\nprocedure __llmul;\r\nasm\r\n JMP System.__llmul\r\nend;\r\n{$ENDIF CPU32}\r\n{$IFDEF CPU64}\r\nfunction memcpy(dest, src: Pointer; count: size_t): Pointer; external szMSVCRT name 'memcpy';\r\nfunction memmove(dest, src: Pointer; count: size_t): Pointer; external szMSVCRT name 'memmove';\r\nfunction memset(dest: Pointer; val: Integer; count: size_t): Pointer; external szMSVCRT name 'memset';\r\nfunction strncmp(s1: PAnsiChar; s2: PAnsiChar; n: size_t): Integer; external szMSVCRT name 'strncmp';\r\nfunction strcmp(s1: PAnsiChar; s2: PAnsiChar; n: size_t): Integer; external szMSVCRT name 'strcmp';\r\nfunction memcmp(s1: Pointer; s2: Pointer; n: size_t): Integer; external szMSVCRT name 'memcmp';\r\nfunction strlen(s: PAnsiChar): size_t; external szMSVCRT name 'strlen';\r\nfunction tolower(__ch: Integer): Integer; external szMSVCRT name 'tolower';\r\nfunction toupper(__ch: Integer): Integer; external szMSVCRT name 'toupper';\r\nfunction isalnum(__ch: Integer): Integer; external szMSVCRT name 'isalnum';\r\nfunction isalpha(__ch: Integer): Integer; external szMSVCRT name 'isalpha';\r\nfunction iscntrl(__ch: Integer): Integer; external szMSVCRT name 'iscntrl';\r\nfunction isdigit(__ch: Integer): Integer; external szMSVCRT name 'isdigit';\r\nfunction isgraph(__ch: Integer): Integer; external szMSVCRT name 'isgraph';\r\nfunction islower(__ch: Integer): Integer; external szMSVCRT name 'islower';\r\nfunction isprint(__ch: Integer): Integer; external szMSVCRT name 'isprint';\r\nfunction ispunct(__ch: Integer): Integer; external szMSVCRT name 'ispunct';\r\nfunction isspace(__ch: Integer): Integer; external szMSVCRT name 'isspace';\r\nfunction isupper(__ch: Integer): Integer; external szMSVCRT name 'isupper';\r\nfunction isxdigit(__ch: Integer): Integer; external szMSVCRT name 'isxdigit';\r\nfunction strchr(__s: PAnsiChar; __c: Integer): PAnsiChar; external szMSVCRT name 'strchr';\r\n\r\nfunction __chkstk(size: size_t): Pointer;\r\nbegin\r\n Result := malloc(size);\r\nend;\r\n{$ENDIF CPU64}\r\n\r\n{$IFDEF PCRE_8}\r\nfunction pcre_malloc_jcl(Size: SizeInt): Pointer; {$IFDEF PCRE_EXPORT_CDECL} cdecl; {$ENDIF PCRE_EXPORT_CDECL}\r\nbegin\r\n if Assigned(pcre_malloc_user) then\r\n Result := pcre_malloc_user(Size)\r\n else\r\n Result := malloc(Size);\r\nend;\r\n{$ENDIF PCRE_8}\r\n\r\n{$IFDEF PCRE_16}\r\nfunction pcre16_malloc_jcl(Size: SizeInt): Pointer; {$IFDEF PCRE_EXPORT_CDECL} cdecl; {$ENDIF PCRE_EXPORT_CDECL}\r\nbegin\r\n if Assigned(pcre16_malloc_user) then\r\n Result := pcre16_malloc_user(Size)\r\n else\r\n Result := malloc(Size);\r\nend;\r\n{$ENDIF PCRE_16}\r\n\r\n{$IFDEF PCRE_8}\r\nfunction pcre_stack_malloc_jcl(Size: SizeInt): Pointer; {$IFDEF PCRE_EXPORT_CDECL} cdecl; {$ENDIF PCRE_EXPORT_CDECL}\r\nbegin\r\n if Assigned(pcre_stack_malloc_user) then\r\n Result := pcre_stack_malloc_user(Size)\r\n else\r\n Result := malloc(Size);\r\nend;\r\n{$ENDIF PCRE_8}\r\n\r\n{$IFDEF PCRE_16}\r\nfunction pcre16_stack_malloc_jcl(Size: SizeInt): Pointer; {$IFDEF PCRE_EXPORT_CDECL} cdecl; {$ENDIF PCRE_EXPORT_CDECL}\r\nbegin\r\n if Assigned(pcre16_stack_malloc_user) then\r\n Result := pcre16_stack_malloc_user(Size)\r\n else\r\n Result := malloc(Size);\r\nend;\r\n{$ENDIF PCRE_16}\r\n\r\nfunction _malloc(size: size_t): Pointer;\r\nbegin\r\n Result := malloc(size);\r\nend;\r\n\r\nprocedure free(pBlock: Pointer); cdecl; external szMSVCRT name 'free';\r\n\r\n{$IFDEF PCRE_8}\r\nprocedure pcre_free_jcl(P: Pointer); {$IFDEF PCRE_EXPORT_CDECL} cdecl; {$ENDIF PCRE_EXPORT_CDECL}\r\nbegin\r\n if Assigned(pcre_free_user) then\r\n pcre_free_user(P)\r\n else\r\n free(P);\r\nend;\r\n{$ENDIF PCRE_8}\r\n\r\n{$IFDEF PCRE_16}\r\nprocedure pcre16_free_jcl(P: Pointer); {$IFDEF PCRE_EXPORT_CDECL} cdecl; {$ENDIF PCRE_EXPORT_CDECL}\r\nbegin\r\n if Assigned(pcre16_free_user) then\r\n pcre16_free_user(P)\r\n else\r\n free(P);\r\nend;\r\n{$ENDIF PCRE_16}\r\n\r\n{$IFDEF PCRE_8}\r\nprocedure pcre_stack_free_jcl(P: Pointer); {$IFDEF PCRE_EXPORT_CDECL} cdecl; {$ENDIF PCRE_EXPORT_CDECL}\r\nbegin\r\n if Assigned(pcre_stack_free_user) then\r\n pcre_stack_free_user(P)\r\n else\r\n free(P);\r\nend;\r\n{$ENDIF PCRE_8}\r\n\r\n{$IFDEF PCRE_16}\r\nprocedure pcre16_stack_free_jcl(P: Pointer); {$IFDEF PCRE_EXPORT_CDECL} cdecl; {$ENDIF PCRE_EXPORT_CDECL}\r\nbegin\r\n if Assigned(pcre16_stack_free_user) then\r\n pcre16_stack_free_user(P)\r\n else\r\n free(P);\r\nend;\r\n{$ENDIF PCRE_16}\r\n\r\nprocedure _free(pBlock: Pointer);\r\nbegin\r\n free(pBlock);\r\nend;\r\n\r\n{$IFDEF PCRE_8}\r\nfunction pcre_callout_jcl(var callout_block: pcre_callout_block): Integer; {$IFDEF PCRE_EXPORT_CDECL} cdecl; {$ENDIF PCRE_EXPORT_CDECL}\r\nbegin\r\n if Assigned(pcre_callout_user) then\r\n Result := pcre_callout_user(callout_block)\r\n else\r\n Result := 0;\r\nend;\r\n{$ENDIF PCRE_8}\r\n\r\n{$IFDEF PCRE_16}\r\nfunction pcre16_callout_jcl(var callout_block: pcre16_callout_block): Integer; {$IFDEF PCRE_EXPORT_CDECL} cdecl; {$ENDIF PCRE_EXPORT_CDECL}\r\nbegin\r\n if Assigned(pcre16_callout_user) then\r\n Result := pcre16_callout_user(callout_block)\r\n else\r\n Result := 0;\r\nend;\r\n{$ENDIF PCRE_16}\r\n\r\n{$IFDEF CPU32}\r\nconst\r\n {$IFDEF PCRE_8}\r\n _pcre_malloc: pcre_malloc_callback = pcre_malloc_jcl;\r\n _pcre_free: pcre_free_callback = pcre_free_jcl;\r\n _pcre_stack_malloc: pcre_stack_malloc_callback = pcre_stack_malloc_jcl;\r\n _pcre_stack_free: pcre_stack_free_callback = pcre_stack_free_jcl;\r\n _pcre_callout: pcre_callout_callback = pcre_callout_jcl;\r\n {$ENDIF PCRE_8}\r\n {$IFDEF PCRE_16}\r\n _pcre16_malloc: pcre16_malloc_callback = pcre16_malloc_jcl;\r\n _pcre16_free: pcre16_free_callback = pcre16_free_jcl;\r\n _pcre16_stack_malloc: pcre16_stack_malloc_callback = pcre16_stack_malloc_jcl;\r\n _pcre16_stack_free: pcre16_stack_free_callback = pcre16_stack_free_jcl;\r\n _pcre16_callout: pcre16_callout_callback = pcre16_callout_jcl;\r\n {$ENDIF PCRE_16}\r\n{$ENDIF CPU32}\r\n{$IFDEF CPU64}\r\nconst\r\n {$IFDEF PCRE_8}\r\n pcre_malloc: pcre_malloc_callback = pcre_malloc_jcl;\r\n pcre_free: pcre_free_callback = pcre_free_jcl;\r\n pcre_stack_malloc: pcre_stack_malloc_callback = pcre_stack_malloc_jcl;\r\n pcre_stack_free: pcre_stack_free_callback = pcre_stack_free_jcl;\r\n pcre_callout: pcre_callout_callback = pcre_callout_jcl;\r\n {$ENDIF PCRE_8}\r\n {$IFDEF PCRE_16}\r\n pcre16_malloc: pcre16_malloc_callback = pcre16_malloc_jcl;\r\n pcre16_free: pcre16_free_callback = pcre16_free_jcl;\r\n pcre16_stack_malloc: pcre16_stack_malloc_callback = pcre16_stack_malloc_jcl;\r\n pcre16_stack_free: pcre16_stack_free_callback = pcre16_stack_free_jcl;\r\n pcre16_callout: pcre16_callout_callback = pcre16_callout_jcl;\r\n {$ENDIF PCRE_16}\r\n{$ENDIF CPU64}\r\n\r\n{$ENDIF PCRE_STATICLINK}\r\n\r\n{$IFDEF PCRE_8}\r\nprocedure SetPCREMallocCallback(const Value: pcre_malloc_callback);\r\nbegin\r\n {$IFDEF PCRE_STATICLINK}\r\n pcre_malloc_user := Value;\r\n {$ELSE ~PCRE_STATICLINK}\r\n if not Assigned(pcre_malloc_func) then\r\n LoadPCRE;\r\n\r\n if Assigned(pcre_malloc_func) then\r\n pcre_malloc_func^ := Value\r\n else if Assigned(LibNotLoadedHandler) then\r\n LibNotLoadedHandler;\r\n {$ENDIF ~PCRE_STATICLINK}\r\nend;\r\n{$ENDIF PCRE_8}\r\n\r\n{$IFDEF PCRE_16}\r\nprocedure SetPCRE16MallocCallback(const Value: pcre16_malloc_callback);\r\nbegin\r\n {$IFDEF PCRE_STATICLINK}\r\n pcre16_malloc_user := Value;\r\n {$ELSE ~PCRE_STATICLINK}\r\n if not Assigned(pcre16_malloc_func) then\r\n LoadPCRE;\r\n\r\n if Assigned(pcre16_malloc_func) then\r\n pcre16_malloc_func^ := Value\r\n else if Assigned(LibNotLoadedHandler) then\r\n LibNotLoadedHandler;\r\n {$ENDIF ~PCRE_STATICLINK}\r\nend;\r\n{$ENDIF PCRE_16}\r\n\r\n{$IFDEF PCRE_8}\r\nfunction GetPCREMallocCallback: pcre_malloc_callback;\r\nbegin\r\n {$IFDEF PCRE_STATICLINK}\r\n Result := pcre_malloc_user;\r\n {$ELSE ~PCRE_STATICLINK}\r\n if not Assigned(pcre_malloc_func) then\r\n LoadPCRE;\r\n\r\n if not Assigned(pcre_malloc_func) then\r\n begin\r\n Result := nil;\r\n if Assigned(LibNotLoadedHandler) then\r\n LibNotLoadedHandler;\r\n end\r\n else\r\n Result := pcre_malloc_func^;\r\n {$ENDIF ~PCRE_STATICLINK}\r\nend;\r\n{$ENDIF PCRE_8}\r\n\r\n{$IFDEF PCRE_16}\r\nfunction GetPCRE16MallocCallback: pcre16_malloc_callback;\r\nbegin\r\n {$IFDEF PCRE_STATICLINK}\r\n Result := pcre16_malloc_user;\r\n {$ELSE ~PCRE_STATICLINK}\r\n if not Assigned(pcre16_malloc_func) then\r\n LoadPCRE;\r\n\r\n if not Assigned(pcre16_malloc_func) then\r\n begin\r\n Result := nil;\r\n if Assigned(LibNotLoadedHandler) then\r\n LibNotLoadedHandler;\r\n end\r\n else\r\n Result := pcre16_malloc_func^;\r\n {$ENDIF ~PCRE_STATICLINK}\r\nend;\r\n{$ENDIF PCRE_16}\r\n\r\n{$IFDEF PCRE_8}\r\nfunction CallPCREMalloc(Size: SizeInt): Pointer;\r\nbegin\r\n {$IFDEF PCRE_STATICLINK}\r\n Result := pcre_malloc_jcl(Size);\r\n {$ELSE ~PCRE_STATICLINK}\r\n Result := pcre_malloc_func^(Size);\r\n {$ENDIF ~PCRE_STATICLINK}\r\nend;\r\n{$ENDIF PCRE_8}\r\n\r\n{$IFDEF PCRE_16}\r\nfunction CallPCRE16Malloc(Size: SizeInt): Pointer;\r\nbegin\r\n {$IFDEF PCRE_STATICLINK}\r\n Result := pcre16_malloc_jcl(Size);\r\n {$ELSE ~PCRE_STATICLINK}\r\n Result := pcre16_malloc_func^(Size);\r\n {$ENDIF ~PCRE_STATICLINK}\r\nend;\r\n{$ENDIF PCRE_16}\r\n\r\n{$IFDEF PCRE_8}\r\nprocedure SetPCREFreeCallback(const Value: pcre_free_callback);\r\nbegin\r\n {$IFDEF PCRE_STATICLINK}\r\n pcre_free_user := Value;\r\n {$ELSE ~PCRE_STATICLINK}\r\n if not Assigned(pcre_free_func) then\r\n LoadPCRE;\r\n\r\n if Assigned(pcre_free_func) then\r\n pcre_free_func^ := Value\r\n else if Assigned(LibNotLoadedHandler) then\r\n LibNotLoadedHandler;\r\n {$ENDIF ~PCRE_STATICLINK}\r\nend;\r\n{$ENDIF PCRE_8}\r\n\r\n{$IFDEF PCRE_16}\r\nprocedure SetPCRE16FreeCallback(const Value: pcre16_free_callback);\r\nbegin\r\n {$IFDEF PCRE_STATICLINK}\r\n pcre16_free_user := Value;\r\n {$ELSE ~PCRE_STATICLINK}\r\n if not Assigned(pcre16_free_func) then\r\n LoadPCRE;\r\n\r\n if Assigned(pcre16_free_func) then\r\n pcre16_free_func^ := Value\r\n else if Assigned(LibNotLoadedHandler) then\r\n LibNotLoadedHandler;\r\n {$ENDIF ~PCRE_STATICLINK}\r\nend;\r\n{$ENDIF PCRE_16}\r\n\r\n{$IFDEF PCRE_8}\r\nfunction GetPCREFreeCallback: pcre_free_callback;\r\nbegin\r\n {$IFDEF PCRE_STATICLINK}\r\n Result := pcre_free_user;\r\n {$ELSE ~PCRE_STATICLINK}\r\n if not Assigned(pcre_free_func) then\r\n LoadPCRE;\r\n\r\n if not Assigned(pcre_free_func) then\r\n begin\r\n Result := nil;\r\n if Assigned(LibNotLoadedHandler) then\r\n LibNotLoadedHandler;\r\n end\r\n else\r\n Result := pcre_free_func^\r\n {$ENDIF ~PCRE_STATICLINK}\r\nend;\r\n{$ENDIF PCRE_8}\r\n\r\n{$IFDEF PCRE_16}\r\nfunction GetPCRE16FreeCallback: pcre16_free_callback;\r\nbegin\r\n {$IFDEF PCRE_STATICLINK}\r\n Result := pcre16_free_user;\r\n {$ELSE ~PCRE_STATICLINK}\r\n if not Assigned(pcre16_free_func) then\r\n LoadPCRE;\r\n\r\n if not Assigned(pcre16_free_func) then\r\n begin\r\n Result := nil;\r\n if Assigned(LibNotLoadedHandler) then\r\n LibNotLoadedHandler;\r\n end\r\n else\r\n Result := pcre16_free_func^\r\n {$ENDIF ~PCRE_STATICLINK}\r\nend;\r\n{$ENDIF PCRE_16}\r\n\r\n{$IFDEF PCRE_8}\r\nprocedure CallPCREFree(P: Pointer);\r\nbegin\r\n {$IFDEF PCRE_STATICLINK}\r\n pcre_free_jcl(P);\r\n {$ELSE ~PCRE_STATICLINK}\r\n pcre_free_func^(P);\r\n {$ENDIF ~PCRE_STATICLINK}\r\nend;\r\n{$ENDIF PCRE_8}\r\n\r\n{$IFDEF PCRE_16}\r\nprocedure CallPCRE16Free(P: Pointer);\r\nbegin\r\n {$IFDEF PCRE_STATICLINK}\r\n pcre16_free_jcl(P);\r\n {$ELSE ~PCRE_STATICLINK}\r\n pcre16_free_func^(P);\r\n {$ENDIF ~PCRE_STATICLINK}\r\nend;\r\n{$ENDIF PCRE_16}\r\n\r\n{$IFDEF PCRE_8}\r\nprocedure SetPCREStackMallocCallback(const Value: pcre_stack_malloc_callback);\r\nbegin\r\n {$IFDEF PCRE_STATICLINK}\r\n pcre_stack_malloc_user := Value;\r\n {$ELSE ~PCRE_STATICLINK}\r\n if not Assigned(pcre_stack_malloc_func) then\r\n LoadPCRE;\r\n\r\n if Assigned(pcre_stack_malloc_func) then\r\n pcre_stack_malloc_func^ := Value\r\n else if Assigned(LibNotLoadedHandler) then\r\n LibNotLoadedHandler;\r\n {$ENDIF ~PCRE_STATICLINK}\r\nend;\r\n{$ENDIF PCRE_8}\r\n\r\n{$IFDEF PCRE_16}\r\nprocedure SetPCRE16StackMallocCallback(const Value: pcre16_stack_malloc_callback);\r\nbegin\r\n {$IFDEF PCRE_STATICLINK}\r\n pcre16_stack_malloc_user := Value;\r\n {$ELSE ~PCRE_STATICLINK}\r\n if not Assigned(pcre16_stack_malloc_func) then\r\n LoadPCRE;\r\n\r\n if Assigned(pcre16_stack_malloc_func) then\r\n pcre16_stack_malloc_func^ := Value\r\n else if Assigned(LibNotLoadedHandler) then\r\n LibNotLoadedHandler;\r\n {$ENDIF ~PCRE_STATICLINK}\r\nend;\r\n{$ENDIF PCRE_16}\r\n\r\n{$IFDEF PCRE_8}\r\nfunction GetPCREStackMallocCallback: pcre_stack_malloc_callback;\r\nbegin\r\n {$IFDEF PCRE_STATICLINK}\r\n Result := pcre_stack_malloc_user;\r\n {$ELSE ~PCRE_STATICLINK}\r\n if not Assigned(pcre_stack_malloc_func) then\r\n LoadPCRE;\r\n\r\n if not Assigned(pcre_stack_malloc_func) then\r\n begin\r\n Result := nil;\r\n if Assigned(LibNotLoadedHandler) then\r\n LibNotLoadedHandler;\r\n end\r\n else\r\n Result := pcre_stack_malloc_func^;\r\n {$ENDIF ~PCRE_STATICLINK}\r\nend;\r\n{$ENDIF PCRE_8}\r\n\r\n{$IFDEF PCRE_16}\r\nfunction GetPCRE16StackMallocCallback: pcre16_stack_malloc_callback;\r\nbegin\r\n {$IFDEF PCRE_STATICLINK}\r\n Result := pcre16_stack_malloc_user;\r\n {$ELSE ~PCRE_STATICLINK}\r\n if not Assigned(pcre16_stack_malloc_func) then\r\n LoadPCRE;\r\n\r\n if not Assigned(pcre16_stack_malloc_func) then\r\n begin\r\n Result := nil;\r\n if Assigned(LibNotLoadedHandler) then\r\n LibNotLoadedHandler;\r\n end\r\n else\r\n Result := pcre16_stack_malloc_func^;\r\n {$ENDIF ~PCRE_STATICLINK}\r\nend;\r\n{$ENDIF PCRE_16}\r\n\r\n{$IFDEF PCRE_8}\r\nfunction CallPCREStackMalloc(Size: SizeInt): Pointer;\r\nbegin\r\n {$IFDEF PCRE_STATICLINK}\r\n Result := pcre_stack_malloc_jcl(Size);\r\n {$ELSE ~PCRE_STATICLINK}\r\n Result := pcre_stack_malloc_func^(Size);\r\n {$ENDIF ~PCRE_STATICLINK}\r\nend;\r\n{$ENDIF PCRE_8}\r\n\r\n{$IFDEF PCRE_16}\r\nfunction CallPCRE16StackMalloc(Size: SizeInt): Pointer;\r\nbegin\r\n {$IFDEF PCRE_STATICLINK}\r\n Result := pcre16_stack_malloc_jcl(Size);\r\n {$ELSE ~PCRE_STATICLINK}\r\n Result := pcre16_stack_malloc_func^(Size);\r\n {$ENDIF ~PCRE_STATICLINK}\r\nend;\r\n{$ENDIF PCRE_16}\r\n\r\n{$IFDEF PCRE_8}\r\nprocedure SetPCREStackFreeCallback(const Value: pcre_stack_free_callback);\r\nbegin\r\n {$IFDEF PCRE_STATICLINK}\r\n pcre_stack_free_user := Value;\r\n {$ELSE ~PCRE_STATICLINK}\r\n if not Assigned(pcre_stack_free_func) then\r\n LoadPCRE;\r\n\r\n if Assigned(pcre_stack_free_func) then\r\n pcre_stack_free_func^ := Value\r\n else if Assigned(LibNotLoadedHandler) then\r\n LibNotLoadedHandler;\r\n {$ENDIF ~PCRE_STATICLINK}\r\nend;\r\n{$ENDIF PCRE_8}\r\n\r\n{$IFDEF PCRE_16}\r\nprocedure SetPCRE16StackFreeCallback(const Value: pcre16_stack_free_callback);\r\nbegin\r\n {$IFDEF PCRE_STATICLINK}\r\n pcre16_stack_free_user := Value;\r\n {$ELSE ~PCRE_STATICLINK}\r\n if not Assigned(pcre16_stack_free_func) then\r\n LoadPCRE;\r\n\r\n if Assigned(pcre16_stack_free_func) then\r\n pcre16_stack_free_func^ := Value\r\n else if Assigned(LibNotLoadedHandler) then\r\n LibNotLoadedHandler;\r\n {$ENDIF ~PCRE_STATICLINK}\r\nend;\r\n{$ENDIF PCRE_16}\r\n\r\n{$IFDEF PCRE_8}\r\nfunction GetPCREStackFreeCallback: pcre_stack_free_callback;\r\nbegin\r\n {$IFDEF PCRE_STATICLINK}\r\n Result := pcre_stack_free_user;\r\n {$ELSE ~PCRE_STATICLINK}\r\n if not Assigned(pcre_stack_free_func) then\r\n LoadPCRE;\r\n\r\n if not Assigned(pcre_stack_free_func) then\r\n begin\r\n Result := nil;\r\n if Assigned(LibNotLoadedHandler) then\r\n LibNotLoadedHandler;\r\n end\r\n else\r\n Result := pcre_stack_free_func^;\r\n {$ENDIF ~PCRE_STATICLINK}\r\nend;\r\n{$ENDIF PCRE_8}\r\n\r\n{$IFDEF PCRE_16}\r\nfunction GetPCRE16StackFreeCallback: pcre16_stack_free_callback;\r\nbegin\r\n {$IFDEF PCRE_STATICLINK}\r\n Result := pcre16_stack_free_user;\r\n {$ELSE ~PCRE_STATICLINK}\r\n if not Assigned(pcre16_stack_free_func) then\r\n LoadPCRE;\r\n\r\n if not Assigned(pcre16_stack_free_func) then\r\n begin\r\n Result := nil;\r\n if Assigned(LibNotLoadedHandler) then\r\n LibNotLoadedHandler;\r\n end\r\n else\r\n Result := pcre16_stack_free_func^;\r\n {$ENDIF ~PCRE_STATICLINK}\r\nend;\r\n{$ENDIF PCRE_16}\r\n\r\n{$IFDEF PCRE_8}\r\nprocedure CallPCREStackFree(P: Pointer);\r\nbegin\r\n {$IFDEF PCRE_STATICLINK}\r\n pcre_stack_free_jcl(P);\r\n {$ELSE ~PCRE_STATICLINK}\r\n pcre_stack_free_func^(P);\r\n {$ENDIF ~PCRE_STATICLINK}\r\nend;\r\n{$ENDIF PCRE_8}\r\n\r\n{$IFDEF PCRE_16}\r\nprocedure CallPCRE16StackFree(P: Pointer);\r\nbegin\r\n {$IFDEF PCRE_STATICLINK}\r\n pcre16_stack_free_jcl(P);\r\n {$ELSE ~PCRE_STATICLINK}\r\n pcre16_stack_free_func^(P);\r\n {$ENDIF ~PCRE_STATICLINK}\r\nend;\r\n{$ENDIF PCRE_16}\r\n\r\n{$IFDEF PCRE_8}\r\nprocedure SetPCRECalloutCallback(const Value: pcre_callout_callback);\r\nbegin\r\n {$IFDEF PCRE_STATICLINK}\r\n pcre_callout_user := Value;\r\n {$ELSE ~PCRE_STATICLINK}\r\n if not Assigned(pcre_callout_func) then\r\n LoadPCRE;\r\n\r\n if Assigned(pcre_callout_func) then\r\n pcre_callout_func^ := Value\r\n else if Assigned(LibNotLoadedHandler) then\r\n LibNotLoadedHandler;\r\n {$ENDIF ~PCRE_STATICLINK}\r\nend;\r\n{$ENDIF PCRE_8}\r\n\r\n{$IFDEF PCRE_16}\r\nprocedure SetPCRE16CalloutCallback(const Value: pcre16_callout_callback);\r\nbegin\r\n {$IFDEF PCRE_STATICLINK}\r\n pcre16_callout_user := Value;\r\n {$ELSE ~PCRE_STATICLINK}\r\n if not Assigned(pcre16_callout_func) then\r\n LoadPCRE;\r\n\r\n if Assigned(pcre16_callout_func) then\r\n pcre16_callout_func^ := Value\r\n else if Assigned(LibNotLoadedHandler) then\r\n LibNotLoadedHandler;\r\n {$ENDIF ~PCRE_STATICLINK}\r\nend;\r\n{$ENDIF PCRE_16}\r\n\r\n{$IFDEF PCRE_8}\r\nfunction GetPCRECalloutCallback: pcre_callout_callback;\r\nbegin\r\n {$IFDEF PCRE_STATICLINK}\r\n Result := pcre_callout_user;\r\n {$ELSE ~PCRE_STATICLINK}\r\n if not Assigned(pcre_callout_func) then\r\n LoadPCRE;\r\n\r\n if not Assigned(pcre_callout_func) then\r\n begin\r\n Result := nil;\r\n if Assigned(LibNotLoadedHandler) then\r\n LibNotLoadedHandler;\r\n end\r\n else\r\n Result := pcre_callout_func^;\r\n {$ENDIF ~PCRE_STATICLINK}\r\nend;\r\n{$ENDIF PCRE_8}\r\n\r\n{$IFDEF PCRE_16}\r\nfunction GetPCRE16CalloutCallback: pcre16_callout_callback;\r\nbegin\r\n {$IFDEF PCRE_STATICLINK}\r\n Result := pcre16_callout_user;\r\n {$ELSE ~PCRE_STATICLINK}\r\n if not Assigned(pcre16_callout_func) then\r\n LoadPCRE;\r\n\r\n if not Assigned(pcre16_callout_func) then\r\n begin\r\n Result := nil;\r\n if Assigned(LibNotLoadedHandler) then\r\n LibNotLoadedHandler;\r\n end\r\n else\r\n Result := pcre16_callout_func^;\r\n {$ENDIF ~PCRE_STATICLINK}\r\nend;\r\n{$ENDIF PCRE_16}\r\n\r\n{$IFDEF PCRE_8}\r\nfunction CallPCRECallout(var callout_block: pcre_callout_block): Integer;\r\nbegin\r\n {$IFDEF PCRE_STATICLINK}\r\n Result := pcre_callout_jcl(callout_block);\r\n {$ELSE ~PCRE_STATICLINK}\r\n Result := pcre_callout_func^(callout_block);\r\n {$ENDIF ~PCRE_STATICLINK}\r\nend;\r\n{$ENDIF PCRE_8}\r\n\r\n{$IFDEF PCRE_16}\r\nfunction CallPCRE16Callout(var callout_block: pcre16_callout_block): Integer;\r\nbegin\r\n {$IFDEF PCRE_STATICLINK}\r\n Result := pcre16_callout_jcl(callout_block);\r\n {$ELSE ~PCRE_STATICLINK}\r\n Result := pcre16_callout_func^(callout_block);\r\n {$ENDIF ~PCRE_STATICLINK}\r\nend;\r\n{$ENDIF PCRE_16}\r\n\r\n{$IFNDEF PCRE_STATICLINK}\r\nprocedure InitPCREFuncPtrs(const Value: Pointer);\r\nbegin\r\n {$IFDEF PCRE_LINKONREQUEST}\r\n {$IFDEF PCRE_8}\r\n @pcre_compile := Value;\r\n @pcre_compile2 := Value;\r\n @pcre_config := Value;\r\n @pcre_copy_named_substring := Value;\r\n @pcre_copy_substring := Value;\r\n @pcre_dfa_exec := Value;\r\n @pcre_exec := Value;\r\n @pcre_free_substring := Value;\r\n @pcre_free_substring_list := Value;\r\n @pcre_fullinfo := Value;\r\n @pcre_get_named_substring := Value;\r\n @pcre_get_stringnumber := Value;\r\n @pcre_get_stringtable_entries := Value;\r\n @pcre_get_substring := Value;\r\n @pcre_get_substring_list := Value;\r\n @pcre_maketables := Value;\r\n @pcre_refcount := Value;\r\n @pcre_study := Value;\r\n @pcre_free_study := Value;\r\n @pcre_version := Value;\r\n @pcre_jit_stack_alloc := Value;\r\n @pcre_jit_stack_free := Value;\r\n @pcre_assign_jit_stack := Value;\r\n {$ENDIF PCRE_8}\r\n {$IFDEF PCRE_16}\r\n @pcre16_compile := Value;\r\n @pcre16_compile2 := Value;\r\n @pcre16_config := Value;\r\n @pcre16_copy_named_substring := Value;\r\n @pcre16_copy_substring := Value;\r\n @pcre16_dfa_exec := Value;\r\n @pcre16_exec := Value;\r\n @pcre16_free_substring := Value;\r\n @pcre16_free_substring_list := Value;\r\n @pcre16_fullinfo := Value;\r\n @pcre16_get_named_substring := Value;\r\n @pcre16_get_stringnumber := Value;\r\n @pcre16_get_stringtable_entries := Value;\r\n @pcre16_get_substring := Value;\r\n @pcre16_get_substring_list := Value;\r\n @pcre16_maketables := Value;\r\n @pcre16_refcount := Value;\r\n @pcre16_study := Value;\r\n @pcre16_free_study := Value;\r\n @pcre16_version := Value;\r\n @pcre16_jit_stack_alloc := Value;\r\n @pcre16_jit_stack_free := Value;\r\n @pcre16_assign_jit_stack := Value;\r\n {$ENDIF PCRE_16}\r\n {$ENDIF PCRE_LINKONREQUEST}\r\n {$IFDEF PCRE_8}\r\n pcre_malloc_func := nil;\r\n pcre_free_func := nil;\r\n pcre_stack_malloc_func := nil;\r\n pcre_stack_free_func := nil;\r\n pcre_callout_func := nil;\r\n {$ENDIF PCRE_8}\r\n {$IFDEF PCRE_16}\r\n pcre16_malloc_func := nil;\r\n pcre16_free_func := nil;\r\n pcre16_stack_malloc_func := nil;\r\n pcre16_stack_free_func := nil;\r\n pcre16_callout_func := nil;\r\n {$ENDIF PCRE_16}\r\nend;\r\n{$ENDIF ~PCRE_STATICLINK}\r\n{$ENDIF ~PCRE_RTL}\r\n\r\nfunction IsPCRELoaded: Boolean;\r\nbegin\r\n {$IFDEF PCRE_RTL}\r\n Result := True;\r\n {$ELSE ~PCRE_RTL}\r\n {$IFDEF PCRE_STATICLINK}\r\n Result := True;\r\n {$ELSE ~PCRE_STATICLINK}\r\n Result := PCRELib <> INVALID_MODULEHANDLE_VALUE;\r\n {$ENDIF ~PCRE_STATICLINK}\r\n {$ENDIF ~PCRE_RTL}\r\nend;\r\n\r\nfunction LoadPCRE: Boolean;\r\n{$IFDEF PCRE_RTL}\r\nbegin\r\n Result := True;\r\nend;\r\n{$ELSE ~PCRE_RTL}\r\n{$IFDEF PCRE_STATICLINK}\r\nbegin\r\n Result := True;\r\nend;\r\n{$ELSE ~PCRE_STATICLINK}\r\nbegin\r\n Result := PCRELib <> INVALID_MODULEHANDLE_VALUE;\r\n if Result then\r\n Exit;\r\n\r\n {$IFDEF PCRE_LINKONREQUEST}\r\n Result := JclSysUtils.LoadModule(PCRELib, PCRELibraryName);\r\n {$ELSE ~PCRE_LINKONREQUEST}\r\n Result := JclSysUtils.LoadModule(PCRELib, PCREDefaultLibraryName);\r\n {$ENDIF ~PCRE_LINKONREQUEST}\r\n if Result then\r\n begin\r\n {$IFDEF PCRE_LINKONREQUEST}\r\n {$IFDEF PCRE_8}\r\n @pcre_compile := GetModuleSymbol(PCRELib, PCRECompileExportName);\r\n @pcre_compile2 := GetModuleSymbol(PCRELib, PCRECompile2ExportName);\r\n @pcre_config := GetModuleSymbol(PCRELib, PCREConfigExportName);\r\n @pcre_copy_named_substring := GetModuleSymbol(PCRELib, PCRECopyNamedSubstringExportName);\r\n @pcre_copy_substring := GetModuleSymbol(PCRELib, PCRECopySubStringExportName);\r\n @pcre_dfa_exec := GetModuleSymbol(PCRELib, PCREDfaExecExportName);\r\n @pcre_exec := GetModuleSymbol(PCRELib, PCREExecExportName);\r\n @pcre_free_substring := GetModuleSymbol(PCRELib, PCREFreeSubStringExportName);\r\n @pcre_free_substring_list := GetModuleSymbol(PCRELib, PCREFreeSubStringListExportName);\r\n @pcre_fullinfo := GetModuleSymbol(PCRELib, PCREFullInfoExportName);\r\n @pcre_get_named_substring := GetModuleSymbol(PCRELib, PCREGetNamedSubstringExportName);\r\n @pcre_get_stringnumber := GetModuleSymbol(PCRELib, PCREGetStringNumberExportName);\r\n @pcre_get_stringtable_entries := GetModuleSymbol(PCRELib, PCREGetStringTableEntriesExportName);\r\n @pcre_get_substring := GetModuleSymbol(PCRELib, PCREGetSubStringExportName);\r\n @pcre_get_substring_list := GetModuleSymbol(PCRELib, PCREGetSubStringListExportName);\r\n @pcre_maketables := GetModuleSymbol(PCRELib, PCREMakeTablesExportName);\r\n @pcre_refcount := GetModuleSymbol(PCRELib, PCRERefCountExportName);\r\n @pcre_study := GetModuleSymbol(PCRELib, PCREStudyExportName);\r\n @pcre_free_study := GetModuleSymbol(PCRELib, PCREFreeStudyExportName);\r\n @pcre_version := GetModuleSymbol(PCRELib, PCREVersionExportName);\r\n @pcre_jit_stack_alloc := GetModuleSymbol(PCRELib, PCREJITStackAllocExportName);\r\n @pcre_jit_stack_free := GetModuleSymbol(PCRELib, PCREJITStackFreeExportName);\r\n @pcre_assign_jit_stack := GetModuleSymbol(PCRELib, PCREAssignJITStackExportName);\r\n pcre_malloc_func := GetModuleSymbol(PCRELib, PCREMallocExportName);\r\n pcre_free_func := GetModuleSymbol(PCRELib, PCREFreeExportName);\r\n pcre_stack_malloc_func := GetModuleSymbol(PCRELib, PCREStackMallocExportName);\r\n pcre_stack_free_func := GetModuleSymbol(PCRELib, PCREStackFreeExportName);\r\n pcre_callout_func := GetModuleSymbol(PCRELib, PCRECalloutExportName);\r\n {$ENDIF PCRE_8}\r\n {$IFDEF PCRE_16}\r\n @pcre16_compile := GetModuleSymbol(PCRELib, PCRE16CompileExportName);\r\n @pcre16_compile2 := GetModuleSymbol(PCRELib, PCRE16Compile2ExportName);\r\n @pcre16_config := GetModuleSymbol(PCRELib, PCRE16ConfigExportName);\r\n @pcre16_copy_named_substring := GetModuleSymbol(PCRELib, PCRE16CopyNamedSubstringExportName);\r\n @pcre16_copy_substring := GetModuleSymbol(PCRELib, PCRE16CopySubStringExportName);\r\n @pcre16_dfa_exec := GetModuleSymbol(PCRELib, PCRE16DfaExecExportName);\r\n @pcre16_exec := GetModuleSymbol(PCRELib, PCRE16ExecExportName);\r\n @pcre16_free_substring := GetModuleSymbol(PCRELib, PCRE16FreeSubStringExportName);\r\n @pcre16_free_substring_list := GetModuleSymbol(PCRELib, PCRE16FreeSubStringListExportName);\r\n @pcre16_fullinfo := GetModuleSymbol(PCRELib, PCRE16FullInfoExportName);\r\n @pcre16_get_named_substring := GetModuleSymbol(PCRELib, PCRE16GetNamedSubstringExportName);\r\n @pcre16_get_stringnumber := GetModuleSymbol(PCRELib, PCRE16GetStringNumberExportName);\r\n @pcre16_get_stringtable_entries := GetModuleSymbol(PCRELib, PCRE16GetStringTableEntriesExportName);\r\n @pcre16_get_substring := GetModuleSymbol(PCRELib, PCRE16GetSubStringExportName);\r\n @pcre16_get_substring_list := GetModuleSymbol(PCRELib, PCRE16GetSubStringListExportName);\r\n @pcre16_maketables := GetModuleSymbol(PCRELib, PCRE16MakeTablesExportName);\r\n @pcre16_refcount := GetModuleSymbol(PCRELib, PCRE16RefCountExportName);\r\n @pcre16_study := GetModuleSymbol(PCRELib, PCRE16StudyExportName);\r\n @pcre16_free_study := GetModuleSymbol(PCRELib, PCRE16FreeStudyExportName);\r\n @pcre16_version := GetModuleSymbol(PCRELib, PCRE16VersionExportName);\r\n @pcre16_jit_stack_alloc := GetModuleSymbol(PCRELib, PCRE16JITStackAllocExportName);\r\n @pcre16_jit_stack_free := GetModuleSymbol(PCRELib, PCRE16JITStackFreeExportName);\r\n @pcre16_assign_jit_stack := GetModuleSymbol(PCRELib, PCRE16AssignJITStackExportName);\r\n pcre16_malloc_func := GetModuleSymbol(PCRELib, PCRE16MallocExportName);\r\n pcre16_free_func := GetModuleSymbol(PCRELib, PCRE16FreeExportName);\r\n pcre16_stack_malloc_func := GetModuleSymbol(PCRELib, PCRE16StackMallocExportName);\r\n pcre16_stack_free_func := GetModuleSymbol(PCRELib, PCRE16StackFreeExportName);\r\n pcre16_callout_func := GetModuleSymbol(PCRELib, PCRE16CalloutExportName);\r\n {$ENDIF PCRE_16}\r\n {$ELSE ~PCRE_LINKONREQUEST}\r\n {$IFDEF PCRE_8}\r\n pcre_malloc_func := GetModuleSymbol(PCRELib, PCREMallocDefaultExportName);\r\n pcre_free_func := GetModuleSymbol(PCRELib, PCREFreeDefaultExportName);\r\n pcre_stack_malloc_func := GetModuleSymbol(PCRELib, PCREStackMallocDefaultExportName);\r\n pcre_stack_free_func := GetModuleSymbol(PCRELib, PCREStackFreeDefaultExportName);\r\n pcre_callout_func := GetModuleSymbol(PCRELib, PCRECalloutDefaultExportName);\r\n {$ENDIF PCRE_8}\r\n {$IFDEF PCRE_16}\r\n pcre16_malloc_func := GetModuleSymbol(PCRELib, PCRE16MallocDefaultExportName);\r\n pcre16_free_func := GetModuleSymbol(PCRELib, PCRE16FreeDefaultExportName);\r\n pcre16_stack_malloc_func := GetModuleSymbol(PCRELib, PCRE16StackMallocDefaultExportName);\r\n pcre16_stack_free_func := GetModuleSymbol(PCRELib, PCRE16StackFreeDefaultExportName);\r\n pcre16_callout_func := GetModuleSymbol(PCRELib, PCRE16CalloutDefaultExportName);\r\n {$ENDIF PCRE_16}\r\n {$ENDIF ~PCRE_LINKONREQUEST}\r\n end\r\n else\r\n InitPCREFuncPtrs(@LibNotLoadedHandler);\r\nend;\r\n{$ENDIF ~PCRE_STATICLINK}\r\n{$ENDIF ~PCRE_RTL}\r\n\r\nprocedure UnloadPCRE;\r\nbegin\r\n {$IFNDEF PCRE_RTL}\r\n {$IFNDEF PCRE_STATICLINK}\r\n InitPCREFuncPtrs(@LibNotLoadedHandler);\r\n JclSysUtils.UnloadModule(PCRELib);\r\n {$ENDIF ~PCRE_STATICLINK}\r\n {$ENDIF ~PCRE_RTL}\r\nend;\r\n\r\n{$IFDEF PCRE_LINKDLL}\r\n{$IFDEF PCRE_8}\r\nfunction pcre_compile; external PCREDefaultLibraryName name PCRECompileDefaultExportName;\r\nfunction pcre_compile2; external PCREDefaultLibraryName name PCRECompile2DefaultExportName;\r\nfunction pcre_config; external PCREDefaultLibraryName name PCREConfigDefaultExportName;\r\nfunction pcre_copy_named_substring; external PCREDefaultLibraryName name PCRECopyNamedSubStringDefaultExportName;\r\nfunction pcre_copy_substring; external PCREDefaultLibraryName name PCRECopySubStringDefaultExportName;\r\nfunction pcre_dfa_exec; external PCREDefaultLibraryName name PCREDfaExecDefaultExportName;\r\nfunction pcre_exec; external PCREDefaultLibraryName name PCREExecDefaultExportName;\r\nprocedure pcre_free_substring; external PCREDefaultLibraryName name PCREFreeSubStringDefaultExportName;\r\nprocedure pcre_free_substring_list; external PCREDefaultLibraryName name PCREFreeSubStringListDefaultExportName;\r\nfunction pcre_fullinfo; external PCREDefaultLibraryName name PCREFullInfoDefaultExportName;\r\nfunction pcre_get_named_substring; external PCREDefaultLibraryName name PCREGetNamedSubStringDefaultExportName;\r\nfunction pcre_get_stringnumber; external PCREDefaultLibraryName name PCREGetStringNumberDefaultExportName;\r\nfunction pcre_get_stringtable_entries; external PCREDefaultLibraryName name PCREGetStringTableEntriesDefaultExportName;\r\nfunction pcre_get_substring; external PCREDefaultLibraryName name PCREGetSubStringDefaultExportName;\r\nfunction pcre_get_substring_list; external PCREDefaultLibraryName name PCREGetSubStringListDefaultExportName;\r\nfunction pcre_maketables; external PCREDefaultLibraryName name PCREMakeTablesDefaultExportName;\r\nfunction pcre_refcount; external PCREDefaultLibraryName name PCRERefCountDefaultExportName;\r\nfunction pcre_study; external PCREDefaultLibraryName name PCREStudyDefaultExportName;\r\nprocedure pcre_free_study; external PCREDefaultLibraryName name PCREFreeStudyDefaultExportName;\r\nfunction pcre_version; external PCREDefaultLibraryName name PCREVersionDefaultExportName;\r\nfunction pcre_jit_stack_alloc; external PCREDefaultLibraryName name PCREJITStackAllocDefaultExportName;\r\nprocedure pcre_jit_stack_free; external PCREDefaultLibraryName name PCREJITStackFreeDefaultExportName;\r\nprocedure pcre_assign_jit_stack; external PCREDefaultLibraryName name PCREAssignJITStackDefaultExportName;\r\n{$ENDIF PCRE_8}\r\n{$IFDEF PCRE_16}\r\nfunction pcre16_compile; external PCREDefaultLibraryName name PCRE16CompileDefaultExportName;\r\nfunction pcre16_compile2; external PCREDefaultLibraryName name PCRE16Compile2DefaultExportName;\r\nfunction pcre16_config; external PCREDefaultLibraryName name PCRE16ConfigDefaultExportName;\r\nfunction pcre16_copy_named_substring; external PCREDefaultLibraryName name PCRE16CopyNamedSubStringDefaultExportName;\r\nfunction pcre16_copy_substring; external PCREDefaultLibraryName name PCRE16CopySubStringDefaultExportName;\r\nfunction pcre16_dfa_exec; external PCREDefaultLibraryName name PCRE16DfaExecDefaultExportName;\r\nfunction pcre16_exec; external PCREDefaultLibraryName name PCRE16ExecDefaultExportName;\r\nprocedure pcre16_free_substring; external PCREDefaultLibraryName name PCRE16FreeSubStringDefaultExportName;\r\nprocedure pcre16_free_substring_list; external PCREDefaultLibraryName name PCRE16FreeSubStringListDefaultExportName;\r\nfunction pcre16_fullinfo; external PCREDefaultLibraryName name PCRE16FullInfoDefaultExportName;\r\nfunction pcre16_get_named_substring; external PCREDefaultLibraryName name PCRE16GetNamedSubStringDefaultExportName;\r\nfunction pcre16_get_stringnumber; external PCREDefaultLibraryName name PCRE16GetStringNumberDefaultExportName;\r\nfunction pcre16_get_stringtable_entries; external PCREDefaultLibraryName name PCRE16GetStringTableEntriesDefaultExportName;\r\nfunction pcre16_get_substring; external PCREDefaultLibraryName name PCRE16GetSubStringDefaultExportName;\r\nfunction pcre16_get_substring_list; external PCREDefaultLibraryName name PCRE16GetSubStringListDefaultExportName;\r\nfunction pcre16_maketables; external PCREDefaultLibraryName name PCRE16MakeTablesDefaultExportName;\r\nfunction pcre16_refcount; external PCREDefaultLibraryName name PCRE16RefCountDefaultExportName;\r\nfunction pcre16_study; external PCREDefaultLibraryName name PCRE16StudyDefaultExportName;\r\nprocedure pcre16_free_study; external PCREDefaultLibraryName name PCRE16FreeStudyDefaultExportName;\r\nfunction pcre16_version; external PCREDefaultLibraryName name PCRE16VersionDefaultExportName;\r\nfunction pcre16_jit_stack_alloc; external PCREDefaultLibraryName name PCRE16JITStackAllocDefaultExportName;\r\nprocedure pcre16_jit_stack_free; external PCREDefaultLibraryName name PCRE16JITStackFreeDefaultExportName;\r\nprocedure pcre16_assign_jit_stack; external PCREDefaultLibraryName name PCRE16AssignJITStackDefaultExportName;\r\n{$ENDIF PCRE_16}\r\n{$ENDIF PCRE_LINKDLL}\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n\r\n" }, { "path": "External/Jedi/Jcl/source/common/zconf.h", "content": "/* zconf.h -- configuration of the zlib compression library\r\n * Copyright (C) 1995-2010 Jean-loup Gailly.\r\n * For conditions of distribution and use, see copyright notice in zlib.h\r\n */\r\n\r\n/* @(#) $Id: zconf.h 3335 2010-09-10 16:04:56Z outchy $ */\r\n\r\n#ifndef ZCONF_H\r\n#define ZCONF_H\r\n\r\n/*\r\n * If you *really* need a unique prefix for all types and library functions,\r\n * compile with -DZ_PREFIX. The \"standard\" zlib should be compiled without it.\r\n * Even better than compiling with -DZ_PREFIX would be to use configure to set\r\n * this permanently in zconf.h using \"./configure --zprefix\".\r\n */\r\n#ifdef Z_PREFIX /* may be set to #if 1 by ./configure */\r\n\r\n/* all linked symbols */\r\n# define _dist_code z__dist_code\r\n# define _length_code z__length_code\r\n# define _tr_align z__tr_align\r\n# define _tr_flush_block z__tr_flush_block\r\n# define _tr_init z__tr_init\r\n# define _tr_stored_block z__tr_stored_block\r\n# define _tr_tally z__tr_tally\r\n# define adler32 z_adler32\r\n# define adler32_combine z_adler32_combine\r\n# define adler32_combine64 z_adler32_combine64\r\n# define compress z_compress\r\n# define compress2 z_compress2\r\n# define compressBound z_compressBound\r\n# define crc32 z_crc32\r\n# define crc32_combine z_crc32_combine\r\n# define crc32_combine64 z_crc32_combine64\r\n# define deflate z_deflate\r\n# define deflateBound z_deflateBound\r\n# define deflateCopy z_deflateCopy\r\n# define deflateEnd z_deflateEnd\r\n# define deflateInit2_ z_deflateInit2_\r\n# define deflateInit_ z_deflateInit_\r\n# define deflateParams z_deflateParams\r\n# define deflatePrime z_deflatePrime\r\n# define deflateReset z_deflateReset\r\n# define deflateSetDictionary z_deflateSetDictionary\r\n# define deflateSetHeader z_deflateSetHeader\r\n# define deflateTune z_deflateTune\r\n# define deflate_copyright z_deflate_copyright\r\n# define get_crc_table z_get_crc_table\r\n# define gz_error z_gz_error\r\n# define gz_intmax z_gz_intmax\r\n# define gz_strwinerror z_gz_strwinerror\r\n# define gzbuffer z_gzbuffer\r\n# define gzclearerr z_gzclearerr\r\n# define gzclose z_gzclose\r\n# define gzclose_r z_gzclose_r\r\n# define gzclose_w z_gzclose_w\r\n# define gzdirect z_gzdirect\r\n# define gzdopen z_gzdopen\r\n# define gzeof z_gzeof\r\n# define gzerror z_gzerror\r\n# define gzflush z_gzflush\r\n# define gzgetc z_gzgetc\r\n# define gzgets z_gzgets\r\n# define gzoffset z_gzoffset\r\n# define gzoffset64 z_gzoffset64\r\n# define gzopen z_gzopen\r\n# define gzopen64 z_gzopen64\r\n# define gzprintf z_gzprintf\r\n# define gzputc z_gzputc\r\n# define gzputs z_gzputs\r\n# define gzread z_gzread\r\n# define gzrewind z_gzrewind\r\n# define gzseek z_gzseek\r\n# define gzseek64 z_gzseek64\r\n# define gzsetparams z_gzsetparams\r\n# define gztell z_gztell\r\n# define gztell64 z_gztell64\r\n# define gzungetc z_gzungetc\r\n# define gzwrite z_gzwrite\r\n# define inflate z_inflate\r\n# define inflateBack z_inflateBack\r\n# define inflateBackEnd z_inflateBackEnd\r\n# define inflateBackInit_ z_inflateBackInit_\r\n# define inflateCopy z_inflateCopy\r\n# define inflateEnd z_inflateEnd\r\n# define inflateGetHeader z_inflateGetHeader\r\n# define inflateInit2_ z_inflateInit2_\r\n# define inflateInit_ z_inflateInit_\r\n# define inflateMark z_inflateMark\r\n# define inflatePrime z_inflatePrime\r\n# define inflateReset z_inflateReset\r\n# define inflateReset2 z_inflateReset2\r\n# define inflateSetDictionary z_inflateSetDictionary\r\n# define inflateSync z_inflateSync\r\n# define inflateSyncPoint z_inflateSyncPoint\r\n# define inflateUndermine z_inflateUndermine\r\n# define inflate_copyright z_inflate_copyright\r\n# define inflate_fast z_inflate_fast\r\n# define inflate_table z_inflate_table\r\n# define uncompress z_uncompress\r\n# define zError z_zError\r\n# define zcalloc z_zcalloc\r\n# define zcfree z_zcfree\r\n# define zlibCompileFlags z_zlibCompileFlags\r\n# define zlibVersion z_zlibVersion\r\n\r\n/* all zlib typedefs in zlib.h and zconf.h */\r\n# define Byte z_Byte\r\n# define Bytef z_Bytef\r\n# define alloc_func z_alloc_func\r\n# define charf z_charf\r\n# define free_func z_free_func\r\n# define gzFile z_gzFile\r\n# define gz_header z_gz_header\r\n# define gz_headerp z_gz_headerp\r\n# define in_func z_in_func\r\n# define intf z_intf\r\n# define out_func z_out_func\r\n# define uInt z_uInt\r\n# define uIntf z_uIntf\r\n# define uLong z_uLong\r\n# define uLongf z_uLongf\r\n# define voidp z_voidp\r\n# define voidpc z_voidpc\r\n# define voidpf z_voidpf\r\n\r\n/* all zlib structs in zlib.h and zconf.h */\r\n# define gz_header_s z_gz_header_s\r\n# define internal_state z_internal_state\r\n\r\n#endif\r\n\r\n#if defined(__MSDOS__) && !defined(MSDOS)\r\n# define MSDOS\r\n#endif\r\n#if (defined(OS_2) || defined(__OS2__)) && !defined(OS2)\r\n# define OS2\r\n#endif\r\n#if defined(_WINDOWS) && !defined(WINDOWS)\r\n# define WINDOWS\r\n#endif\r\n#if defined(_WIN32) || defined(_WIN32_WCE) || defined(__WIN32__)\r\n# ifndef WIN32\r\n# define WIN32\r\n# endif\r\n#endif\r\n#if (defined(MSDOS) || defined(OS2) || defined(WINDOWS)) && !defined(WIN32)\r\n# if !defined(__GNUC__) && !defined(__FLAT__) && !defined(__386__)\r\n# ifndef SYS16BIT\r\n# define SYS16BIT\r\n# endif\r\n# endif\r\n#endif\r\n\r\n/*\r\n * Compile with -DMAXSEG_64K if the alloc function cannot allocate more\r\n * than 64k bytes at a time (needed on systems with 16-bit int).\r\n */\r\n#ifdef SYS16BIT\r\n# define MAXSEG_64K\r\n#endif\r\n#ifdef MSDOS\r\n# define UNALIGNED_OK\r\n#endif\r\n\r\n#ifdef __STDC_VERSION__\r\n# ifndef STDC\r\n# define STDC\r\n# endif\r\n# if __STDC_VERSION__ >= 199901L\r\n# ifndef STDC99\r\n# define STDC99\r\n# endif\r\n# endif\r\n#endif\r\n#if !defined(STDC) && (defined(__STDC__) || defined(__cplusplus))\r\n# define STDC\r\n#endif\r\n#if !defined(STDC) && (defined(__GNUC__) || defined(__BORLANDC__))\r\n# define STDC\r\n#endif\r\n#if !defined(STDC) && (defined(MSDOS) || defined(WINDOWS) || defined(WIN32))\r\n# define STDC\r\n#endif\r\n#if !defined(STDC) && (defined(OS2) || defined(__HOS_AIX__))\r\n# define STDC\r\n#endif\r\n\r\n#if defined(__OS400__) && !defined(STDC) /* iSeries (formerly AS/400). */\r\n# define STDC\r\n#endif\r\n\r\n#ifndef STDC\r\n# ifndef const /* cannot use !defined(STDC) && !defined(const) on Mac */\r\n# define const /* note: need a more gentle solution here */\r\n# endif\r\n#endif\r\n\r\n/* Some Mac compilers merge all .h files incorrectly: */\r\n#if defined(__MWERKS__)||defined(applec)||defined(THINK_C)||defined(__SC__)\r\n# define NO_DUMMY_DECL\r\n#endif\r\n\r\n/* Maximum value for memLevel in deflateInit2 */\r\n#ifndef MAX_MEM_LEVEL\r\n# ifdef MAXSEG_64K\r\n# define MAX_MEM_LEVEL 8\r\n# else\r\n# define MAX_MEM_LEVEL 9\r\n# endif\r\n#endif\r\n\r\n/* Maximum value for windowBits in deflateInit2 and inflateInit2.\r\n * WARNING: reducing MAX_WBITS makes minigzip unable to extract .gz files\r\n * created by gzip. (Files created by minigzip can still be extracted by\r\n * gzip.)\r\n */\r\n#ifndef MAX_WBITS\r\n# define MAX_WBITS 15 /* 32K LZ77 window */\r\n#endif\r\n\r\n/* The memory requirements for deflate are (in bytes):\r\n (1 << (windowBits+2)) + (1 << (memLevel+9))\r\n that is: 128K for windowBits=15 + 128K for memLevel = 8 (default values)\r\n plus a few kilobytes for small objects. For example, if you want to reduce\r\n the default memory requirements from 256K to 128K, compile with\r\n make CFLAGS=\"-O -DMAX_WBITS=14 -DMAX_MEM_LEVEL=7\"\r\n Of course this will generally degrade compression (there's no free lunch).\r\n\r\n The memory requirements for inflate are (in bytes) 1 << windowBits\r\n that is, 32K for windowBits=15 (default value) plus a few kilobytes\r\n for small objects.\r\n*/\r\n\r\n /* Type declarations */\r\n\r\n#ifndef OF /* function prototypes */\r\n# ifdef STDC\r\n# define OF(args) args\r\n# else\r\n# define OF(args) ()\r\n# endif\r\n#endif\r\n\r\n/* The following definitions for FAR are needed only for MSDOS mixed\r\n * model programming (small or medium model with some far allocations).\r\n * This was tested only with MSC; for other MSDOS compilers you may have\r\n * to define NO_MEMCPY in zutil.h. If you don't need the mixed model,\r\n * just define FAR to be empty.\r\n */\r\n#ifdef SYS16BIT\r\n# if defined(M_I86SM) || defined(M_I86MM)\r\n /* MSC small or medium model */\r\n# define SMALL_MEDIUM\r\n# ifdef _MSC_VER\r\n# define FAR _far\r\n# else\r\n# define FAR far\r\n# endif\r\n# endif\r\n# if (defined(__SMALL__) || defined(__MEDIUM__))\r\n /* Turbo C small or medium model */\r\n# define SMALL_MEDIUM\r\n# ifdef __BORLANDC__\r\n# define FAR _far\r\n# else\r\n# define FAR far\r\n# endif\r\n# endif\r\n#endif\r\n\r\n#if defined(WINDOWS) || defined(WIN32)\r\n /* If building or using zlib as a DLL, define ZLIB_DLL.\r\n * This is not mandatory, but it offers a little performance increase.\r\n */\r\n# ifdef ZLIB_DLL\r\n# if defined(WIN32) && (!defined(__BORLANDC__) || (__BORLANDC__ >= 0x500))\r\n# ifdef ZLIB_INTERNAL\r\n# define ZEXTERN extern __declspec(dllexport)\r\n# else\r\n# define ZEXTERN extern __declspec(dllimport)\r\n# endif\r\n# endif\r\n# endif /* ZLIB_DLL */\r\n /* If building or using zlib with the WINAPI/WINAPIV calling convention,\r\n * define ZLIB_WINAPI.\r\n * Caution: the standard ZLIB1.DLL is NOT compiled using ZLIB_WINAPI.\r\n */\r\n# ifdef ZLIB_WINAPI\r\n# ifdef FAR\r\n# undef FAR\r\n# endif\r\n# include \r\n /* No need for _export, use ZLIB.DEF instead. */\r\n /* For complete Windows compatibility, use WINAPI, not __stdcall. */\r\n# define ZEXPORT WINAPI\r\n# ifdef WIN32\r\n# define ZEXPORTVA WINAPIV\r\n# else\r\n# define ZEXPORTVA FAR CDECL\r\n# endif\r\n# endif\r\n#endif\r\n\r\n#if defined (__BEOS__)\r\n# ifdef ZLIB_DLL\r\n# ifdef ZLIB_INTERNAL\r\n# define ZEXPORT __declspec(dllexport)\r\n# define ZEXPORTVA __declspec(dllexport)\r\n# else\r\n# define ZEXPORT __declspec(dllimport)\r\n# define ZEXPORTVA __declspec(dllimport)\r\n# endif\r\n# endif\r\n#endif\r\n\r\n#ifndef ZEXTERN\r\n# define ZEXTERN extern\r\n#endif\r\n#ifndef ZEXPORT\r\n# define ZEXPORT\r\n#endif\r\n#ifndef ZEXPORTVA\r\n# define ZEXPORTVA\r\n#endif\r\n\r\n#ifndef FAR\r\n# define FAR\r\n#endif\r\n\r\n#if !defined(__MACTYPES__)\r\ntypedef unsigned char Byte; /* 8 bits */\r\n#endif\r\ntypedef unsigned int uInt; /* 16 bits or more */\r\ntypedef unsigned long uLong; /* 32 bits or more */\r\n\r\n#ifdef SMALL_MEDIUM\r\n /* Borland C/C++ and some old MSC versions ignore FAR inside typedef */\r\n# define Bytef Byte FAR\r\n#else\r\n typedef Byte FAR Bytef;\r\n#endif\r\ntypedef char FAR charf;\r\ntypedef int FAR intf;\r\ntypedef uInt FAR uIntf;\r\ntypedef uLong FAR uLongf;\r\n\r\n#ifdef STDC\r\n typedef void const *voidpc;\r\n typedef void FAR *voidpf;\r\n typedef void *voidp;\r\n#else\r\n typedef Byte const *voidpc;\r\n typedef Byte FAR *voidpf;\r\n typedef Byte *voidp;\r\n#endif\r\n\r\n#ifdef HAVE_UNISTD_H /* may be set to #if 1 by ./configure */\r\n# define Z_HAVE_UNISTD_H\r\n#endif\r\n\r\n#ifdef STDC\r\n# include /* for off_t */\r\n#endif\r\n\r\n/* a little trick to accommodate both \"#define _LARGEFILE64_SOURCE\" and\r\n * \"#define _LARGEFILE64_SOURCE 1\" as requesting 64-bit operations, (even\r\n * though the former does not conform to the LFS document), but considering\r\n * both \"#undef _LARGEFILE64_SOURCE\" and \"#define _LARGEFILE64_SOURCE 0\" as\r\n * equivalently requesting no 64-bit operations\r\n */\r\n#if -_LARGEFILE64_SOURCE - -1 == 1\r\n# undef _LARGEFILE64_SOURCE\r\n#endif\r\n\r\n#if defined(Z_HAVE_UNISTD_H) || defined(_LARGEFILE64_SOURCE)\r\n# include /* for SEEK_* and off_t */\r\n# ifdef VMS\r\n# include /* for off_t */\r\n# endif\r\n# ifndef z_off_t\r\n# define z_off_t off_t\r\n# endif\r\n#endif\r\n\r\n#ifndef SEEK_SET\r\n# define SEEK_SET 0 /* Seek from beginning of file. */\r\n# define SEEK_CUR 1 /* Seek from current position. */\r\n# define SEEK_END 2 /* Set file pointer to EOF plus \"offset\" */\r\n#endif\r\n\r\n#ifndef z_off_t\r\n# define z_off_t long\r\n#endif\r\n\r\n#if defined(_LARGEFILE64_SOURCE) && _LFS64_LARGEFILE-0\r\n# define z_off64_t off64_t\r\n#else\r\n# define z_off64_t z_off_t\r\n#endif\r\n\r\n#if defined(__OS400__)\r\n# define NO_vsnprintf\r\n#endif\r\n\r\n#if defined(__MVS__)\r\n# define NO_vsnprintf\r\n#endif\r\n\r\n/* MVS linker does not support external names larger than 8 bytes */\r\n#if defined(__MVS__)\r\n #pragma map(deflateInit_,\"DEIN\")\r\n #pragma map(deflateInit2_,\"DEIN2\")\r\n #pragma map(deflateEnd,\"DEEND\")\r\n #pragma map(deflateBound,\"DEBND\")\r\n #pragma map(inflateInit_,\"ININ\")\r\n #pragma map(inflateInit2_,\"ININ2\")\r\n #pragma map(inflateEnd,\"INEND\")\r\n #pragma map(inflateSync,\"INSY\")\r\n #pragma map(inflateSetDictionary,\"INSEDI\")\r\n #pragma map(compressBound,\"CMBND\")\r\n #pragma map(inflate_table,\"INTABL\")\r\n #pragma map(inflate_fast,\"INFA\")\r\n #pragma map(inflate_copyright,\"INCOPY\")\r\n#endif\r\n\r\n#endif /* ZCONF_H */\r\n" }, { "path": "External/Jedi/Jcl/source/common/zlib.h", "content": "/* zlib.h -- interface of the 'zlib' general purpose compression library\r\n version 1.2.5, April 19th, 2010\r\n\r\n Copyright (C) 1995-2010 Jean-loup Gailly and Mark Adler\r\n\r\n This software is provided 'as-is', without any express or implied\r\n warranty. In no event will the authors be held liable for any damages\r\n arising from the use of this software.\r\n\r\n Permission is granted to anyone to use this software for any purpose,\r\n including commercial applications, and to alter it and redistribute it\r\n freely, subject to the following restrictions:\r\n\r\n 1. The origin of this software must not be misrepresented; you must not\r\n claim that you wrote the original software. If you use this software\r\n in a product, an acknowledgment in the product documentation would be\r\n appreciated but is not required.\r\n 2. Altered source versions must be plainly marked as such, and must not be\r\n misrepresented as being the original software.\r\n 3. This notice may not be removed or altered from any source distribution.\r\n\r\n Jean-loup Gailly Mark Adler\r\n jloup@gzip.org madler@alumni.caltech.edu\r\n\r\n\r\n The data format used by the zlib library is described by RFCs (Request for\r\n Comments) 1950 to 1952 in the files http://www.ietf.org/rfc/rfc1950.txt\r\n (zlib format), rfc1951.txt (deflate format) and rfc1952.txt (gzip format).\r\n*/\r\n\r\n#ifndef ZLIB_H\r\n#define ZLIB_H\r\n\r\n#include \"zconf.h\"\r\n\r\n#ifdef __cplusplus\r\nextern \"C\" {\r\n#endif\r\n\r\n#define ZLIB_VERSION \"1.2.5\"\r\n#define ZLIB_VERNUM 0x1250\r\n#define ZLIB_VER_MAJOR 1\r\n#define ZLIB_VER_MINOR 2\r\n#define ZLIB_VER_REVISION 5\r\n#define ZLIB_VER_SUBREVISION 0\r\n\r\n/*\r\n The 'zlib' compression library provides in-memory compression and\r\n decompression functions, including integrity checks of the uncompressed data.\r\n This version of the library supports only one compression method (deflation)\r\n but other algorithms will be added later and will have the same stream\r\n interface.\r\n\r\n Compression can be done in a single step if the buffers are large enough,\r\n or can be done by repeated calls of the compression function. In the latter\r\n case, the application must provide more input and/or consume the output\r\n (providing more output space) before each call.\r\n\r\n The compressed data format used by default by the in-memory functions is\r\n the zlib format, which is a zlib wrapper documented in RFC 1950, wrapped\r\n around a deflate stream, which is itself documented in RFC 1951.\r\n\r\n The library also supports reading and writing files in gzip (.gz) format\r\n with an interface similar to that of stdio using the functions that start\r\n with \"gz\". The gzip format is different from the zlib format. gzip is a\r\n gzip wrapper, documented in RFC 1952, wrapped around a deflate stream.\r\n\r\n This library can optionally read and write gzip streams in memory as well.\r\n\r\n The zlib format was designed to be compact and fast for use in memory\r\n and on communications channels. The gzip format was designed for single-\r\n file compression on file systems, has a larger header than zlib to maintain\r\n directory information, and uses a different, slower check method than zlib.\r\n\r\n The library does not install any signal handler. The decoder checks\r\n the consistency of the compressed data, so the library should never crash\r\n even in case of corrupted input.\r\n*/\r\n\r\ntypedef voidpf (*alloc_func) OF((voidpf opaque, uInt items, uInt size));\r\ntypedef void (*free_func) OF((voidpf opaque, voidpf address));\r\n\r\nstruct internal_state;\r\n\r\ntypedef struct z_stream_s {\r\n Bytef *next_in; /* next input byte */\r\n uInt avail_in; /* number of bytes available at next_in */\r\n uLong total_in; /* total nb of input bytes read so far */\r\n\r\n Bytef *next_out; /* next output byte should be put there */\r\n uInt avail_out; /* remaining free space at next_out */\r\n uLong total_out; /* total nb of bytes output so far */\r\n\r\n char *msg; /* last error message, NULL if no error */\r\n struct internal_state FAR *state; /* not visible by applications */\r\n\r\n alloc_func zalloc; /* used to allocate the internal state */\r\n free_func zfree; /* used to free the internal state */\r\n voidpf opaque; /* private data object passed to zalloc and zfree */\r\n\r\n int data_type; /* best guess about the data type: binary or text */\r\n uLong adler; /* adler32 value of the uncompressed data */\r\n uLong reserved; /* reserved for future use */\r\n} z_stream;\r\n\r\ntypedef z_stream FAR *z_streamp;\r\n\r\n/*\r\n gzip header information passed to and from zlib routines. See RFC 1952\r\n for more details on the meanings of these fields.\r\n*/\r\ntypedef struct gz_header_s {\r\n int text; /* true if compressed data believed to be text */\r\n uLong time; /* modification time */\r\n int xflags; /* extra flags (not used when writing a gzip file) */\r\n int os; /* operating system */\r\n Bytef *extra; /* pointer to extra field or Z_NULL if none */\r\n uInt extra_len; /* extra field length (valid if extra != Z_NULL) */\r\n uInt extra_max; /* space at extra (only when reading header) */\r\n Bytef *name; /* pointer to zero-terminated file name or Z_NULL */\r\n uInt name_max; /* space at name (only when reading header) */\r\n Bytef *comment; /* pointer to zero-terminated comment or Z_NULL */\r\n uInt comm_max; /* space at comment (only when reading header) */\r\n int hcrc; /* true if there was or will be a header crc */\r\n int done; /* true when done reading gzip header (not used\r\n when writing a gzip file) */\r\n} gz_header;\r\n\r\ntypedef gz_header FAR *gz_headerp;\r\n\r\n/*\r\n The application must update next_in and avail_in when avail_in has dropped\r\n to zero. It must update next_out and avail_out when avail_out has dropped\r\n to zero. The application must initialize zalloc, zfree and opaque before\r\n calling the init function. All other fields are set by the compression\r\n library and must not be updated by the application.\r\n\r\n The opaque value provided by the application will be passed as the first\r\n parameter for calls of zalloc and zfree. This can be useful for custom\r\n memory management. The compression library attaches no meaning to the\r\n opaque value.\r\n\r\n zalloc must return Z_NULL if there is not enough memory for the object.\r\n If zlib is used in a multi-threaded application, zalloc and zfree must be\r\n thread safe.\r\n\r\n On 16-bit systems, the functions zalloc and zfree must be able to allocate\r\n exactly 65536 bytes, but will not be required to allocate more than this if\r\n the symbol MAXSEG_64K is defined (see zconf.h). WARNING: On MSDOS, pointers\r\n returned by zalloc for objects of exactly 65536 bytes *must* have their\r\n offset normalized to zero. The default allocation function provided by this\r\n library ensures this (see zutil.c). To reduce memory requirements and avoid\r\n any allocation of 64K objects, at the expense of compression ratio, compile\r\n the library with -DMAX_WBITS=14 (see zconf.h).\r\n\r\n The fields total_in and total_out can be used for statistics or progress\r\n reports. After compression, total_in holds the total size of the\r\n uncompressed data and may be saved for use in the decompressor (particularly\r\n if the decompressor wants to decompress everything in a single step).\r\n*/\r\n\r\n /* constants */\r\n\r\n#define Z_NO_FLUSH 0\r\n#define Z_PARTIAL_FLUSH 1\r\n#define Z_SYNC_FLUSH 2\r\n#define Z_FULL_FLUSH 3\r\n#define Z_FINISH 4\r\n#define Z_BLOCK 5\r\n#define Z_TREES 6\r\n/* Allowed flush values; see deflate() and inflate() below for details */\r\n\r\n#define Z_OK 0\r\n#define Z_STREAM_END 1\r\n#define Z_NEED_DICT 2\r\n#define Z_ERRNO (-1)\r\n#define Z_STREAM_ERROR (-2)\r\n#define Z_DATA_ERROR (-3)\r\n#define Z_MEM_ERROR (-4)\r\n#define Z_BUF_ERROR (-5)\r\n#define Z_VERSION_ERROR (-6)\r\n/* Return codes for the compression/decompression functions. Negative values\r\n * are errors, positive values are used for special but normal events.\r\n */\r\n\r\n#define Z_NO_COMPRESSION 0\r\n#define Z_BEST_SPEED 1\r\n#define Z_BEST_COMPRESSION 9\r\n#define Z_DEFAULT_COMPRESSION (-1)\r\n/* compression levels */\r\n\r\n#define Z_FILTERED 1\r\n#define Z_HUFFMAN_ONLY 2\r\n#define Z_RLE 3\r\n#define Z_FIXED 4\r\n#define Z_DEFAULT_STRATEGY 0\r\n/* compression strategy; see deflateInit2() below for details */\r\n\r\n#define Z_BINARY 0\r\n#define Z_TEXT 1\r\n#define Z_ASCII Z_TEXT /* for compatibility with 1.2.2 and earlier */\r\n#define Z_UNKNOWN 2\r\n/* Possible values of the data_type field (though see inflate()) */\r\n\r\n#define Z_DEFLATED 8\r\n/* The deflate compression method (the only one supported in this version) */\r\n\r\n#define Z_NULL 0 /* for initializing zalloc, zfree, opaque */\r\n\r\n#define zlib_version zlibVersion()\r\n/* for compatibility with versions < 1.0.2 */\r\n\r\n\r\n /* basic functions */\r\n\r\nZEXTERN const char * ZEXPORT zlibVersion OF((void));\r\n/* The application can compare zlibVersion and ZLIB_VERSION for consistency.\r\n If the first character differs, the library code actually used is not\r\n compatible with the zlib.h header file used by the application. This check\r\n is automatically made by deflateInit and inflateInit.\r\n */\r\n\r\n/*\r\nZEXTERN int ZEXPORT deflateInit OF((z_streamp strm, int level));\r\n\r\n Initializes the internal stream state for compression. The fields\r\n zalloc, zfree and opaque must be initialized before by the caller. If\r\n zalloc and zfree are set to Z_NULL, deflateInit updates them to use default\r\n allocation functions.\r\n\r\n The compression level must be Z_DEFAULT_COMPRESSION, or between 0 and 9:\r\n 1 gives best speed, 9 gives best compression, 0 gives no compression at all\r\n (the input data is simply copied a block at a time). Z_DEFAULT_COMPRESSION\r\n requests a default compromise between speed and compression (currently\r\n equivalent to level 6).\r\n\r\n deflateInit returns Z_OK if success, Z_MEM_ERROR if there was not enough\r\n memory, Z_STREAM_ERROR if level is not a valid compression level, or\r\n Z_VERSION_ERROR if the zlib library version (zlib_version) is incompatible\r\n with the version assumed by the caller (ZLIB_VERSION). msg is set to null\r\n if there is no error message. deflateInit does not perform any compression:\r\n this will be done by deflate().\r\n*/\r\n\r\n\r\nZEXTERN int ZEXPORT deflate OF((z_streamp strm, int flush));\r\n/*\r\n deflate compresses as much data as possible, and stops when the input\r\n buffer becomes empty or the output buffer becomes full. It may introduce\r\n some output latency (reading input without producing any output) except when\r\n forced to flush.\r\n\r\n The detailed semantics are as follows. deflate performs one or both of the\r\n following actions:\r\n\r\n - Compress more input starting at next_in and update next_in and avail_in\r\n accordingly. If not all input can be processed (because there is not\r\n enough room in the output buffer), next_in and avail_in are updated and\r\n processing will resume at this point for the next call of deflate().\r\n\r\n - Provide more output starting at next_out and update next_out and avail_out\r\n accordingly. This action is forced if the parameter flush is non zero.\r\n Forcing flush frequently degrades the compression ratio, so this parameter\r\n should be set only when necessary (in interactive applications). Some\r\n output may be provided even if flush is not set.\r\n\r\n Before the call of deflate(), the application should ensure that at least\r\n one of the actions is possible, by providing more input and/or consuming more\r\n output, and updating avail_in or avail_out accordingly; avail_out should\r\n never be zero before the call. The application can consume the compressed\r\n output when it wants, for example when the output buffer is full (avail_out\r\n == 0), or after each call of deflate(). If deflate returns Z_OK and with\r\n zero avail_out, it must be called again after making room in the output\r\n buffer because there might be more output pending.\r\n\r\n Normally the parameter flush is set to Z_NO_FLUSH, which allows deflate to\r\n decide how much data to accumulate before producing output, in order to\r\n maximize compression.\r\n\r\n If the parameter flush is set to Z_SYNC_FLUSH, all pending output is\r\n flushed to the output buffer and the output is aligned on a byte boundary, so\r\n that the decompressor can get all input data available so far. (In\r\n particular avail_in is zero after the call if enough output space has been\r\n provided before the call.) Flushing may degrade compression for some\r\n compression algorithms and so it should be used only when necessary. This\r\n completes the current deflate block and follows it with an empty stored block\r\n that is three bits plus filler bits to the next byte, followed by four bytes\r\n (00 00 ff ff).\r\n\r\n If flush is set to Z_PARTIAL_FLUSH, all pending output is flushed to the\r\n output buffer, but the output is not aligned to a byte boundary. All of the\r\n input data so far will be available to the decompressor, as for Z_SYNC_FLUSH.\r\n This completes the current deflate block and follows it with an empty fixed\r\n codes block that is 10 bits long. This assures that enough bytes are output\r\n in order for the decompressor to finish the block before the empty fixed code\r\n block.\r\n\r\n If flush is set to Z_BLOCK, a deflate block is completed and emitted, as\r\n for Z_SYNC_FLUSH, but the output is not aligned on a byte boundary, and up to\r\n seven bits of the current block are held to be written as the next byte after\r\n the next deflate block is completed. In this case, the decompressor may not\r\n be provided enough bits at this point in order to complete decompression of\r\n the data provided so far to the compressor. It may need to wait for the next\r\n block to be emitted. This is for advanced applications that need to control\r\n the emission of deflate blocks.\r\n\r\n If flush is set to Z_FULL_FLUSH, all output is flushed as with\r\n Z_SYNC_FLUSH, and the compression state is reset so that decompression can\r\n restart from this point if previous compressed data has been damaged or if\r\n random access is desired. Using Z_FULL_FLUSH too often can seriously degrade\r\n compression.\r\n\r\n If deflate returns with avail_out == 0, this function must be called again\r\n with the same value of the flush parameter and more output space (updated\r\n avail_out), until the flush is complete (deflate returns with non-zero\r\n avail_out). In the case of a Z_FULL_FLUSH or Z_SYNC_FLUSH, make sure that\r\n avail_out is greater than six to avoid repeated flush markers due to\r\n avail_out == 0 on return.\r\n\r\n If the parameter flush is set to Z_FINISH, pending input is processed,\r\n pending output is flushed and deflate returns with Z_STREAM_END if there was\r\n enough output space; if deflate returns with Z_OK, this function must be\r\n called again with Z_FINISH and more output space (updated avail_out) but no\r\n more input data, until it returns with Z_STREAM_END or an error. After\r\n deflate has returned Z_STREAM_END, the only possible operations on the stream\r\n are deflateReset or deflateEnd.\r\n\r\n Z_FINISH can be used immediately after deflateInit if all the compression\r\n is to be done in a single step. In this case, avail_out must be at least the\r\n value returned by deflateBound (see below). If deflate does not return\r\n Z_STREAM_END, then it must be called again as described above.\r\n\r\n deflate() sets strm->adler to the adler32 checksum of all input read\r\n so far (that is, total_in bytes).\r\n\r\n deflate() may update strm->data_type if it can make a good guess about\r\n the input data type (Z_BINARY or Z_TEXT). In doubt, the data is considered\r\n binary. This field is only for information purposes and does not affect the\r\n compression algorithm in any manner.\r\n\r\n deflate() returns Z_OK if some progress has been made (more input\r\n processed or more output produced), Z_STREAM_END if all input has been\r\n consumed and all output has been produced (only when flush is set to\r\n Z_FINISH), Z_STREAM_ERROR if the stream state was inconsistent (for example\r\n if next_in or next_out was Z_NULL), Z_BUF_ERROR if no progress is possible\r\n (for example avail_in or avail_out was zero). Note that Z_BUF_ERROR is not\r\n fatal, and deflate() can be called again with more input and more output\r\n space to continue compressing.\r\n*/\r\n\r\n\r\nZEXTERN int ZEXPORT deflateEnd OF((z_streamp strm));\r\n/*\r\n All dynamically allocated data structures for this stream are freed.\r\n This function discards any unprocessed input and does not flush any pending\r\n output.\r\n\r\n deflateEnd returns Z_OK if success, Z_STREAM_ERROR if the\r\n stream state was inconsistent, Z_DATA_ERROR if the stream was freed\r\n prematurely (some input or output was discarded). In the error case, msg\r\n may be set but then points to a static string (which must not be\r\n deallocated).\r\n*/\r\n\r\n\r\n/*\r\nZEXTERN int ZEXPORT inflateInit OF((z_streamp strm));\r\n\r\n Initializes the internal stream state for decompression. The fields\r\n next_in, avail_in, zalloc, zfree and opaque must be initialized before by\r\n the caller. If next_in is not Z_NULL and avail_in is large enough (the\r\n exact value depends on the compression method), inflateInit determines the\r\n compression method from the zlib header and allocates all data structures\r\n accordingly; otherwise the allocation will be deferred to the first call of\r\n inflate. If zalloc and zfree are set to Z_NULL, inflateInit updates them to\r\n use default allocation functions.\r\n\r\n inflateInit returns Z_OK if success, Z_MEM_ERROR if there was not enough\r\n memory, Z_VERSION_ERROR if the zlib library version is incompatible with the\r\n version assumed by the caller, or Z_STREAM_ERROR if the parameters are\r\n invalid, such as a null pointer to the structure. msg is set to null if\r\n there is no error message. inflateInit does not perform any decompression\r\n apart from possibly reading the zlib header if present: actual decompression\r\n will be done by inflate(). (So next_in and avail_in may be modified, but\r\n next_out and avail_out are unused and unchanged.) The current implementation\r\n of inflateInit() does not process any header information -- that is deferred\r\n until inflate() is called.\r\n*/\r\n\r\n\r\nZEXTERN int ZEXPORT inflate OF((z_streamp strm, int flush));\r\n/*\r\n inflate decompresses as much data as possible, and stops when the input\r\n buffer becomes empty or the output buffer becomes full. It may introduce\r\n some output latency (reading input without producing any output) except when\r\n forced to flush.\r\n\r\n The detailed semantics are as follows. inflate performs one or both of the\r\n following actions:\r\n\r\n - Decompress more input starting at next_in and update next_in and avail_in\r\n accordingly. If not all input can be processed (because there is not\r\n enough room in the output buffer), next_in is updated and processing will\r\n resume at this point for the next call of inflate().\r\n\r\n - Provide more output starting at next_out and update next_out and avail_out\r\n accordingly. inflate() provides as much output as possible, until there is\r\n no more input data or no more space in the output buffer (see below about\r\n the flush parameter).\r\n\r\n Before the call of inflate(), the application should ensure that at least\r\n one of the actions is possible, by providing more input and/or consuming more\r\n output, and updating the next_* and avail_* values accordingly. The\r\n application can consume the uncompressed output when it wants, for example\r\n when the output buffer is full (avail_out == 0), or after each call of\r\n inflate(). If inflate returns Z_OK and with zero avail_out, it must be\r\n called again after making room in the output buffer because there might be\r\n more output pending.\r\n\r\n The flush parameter of inflate() can be Z_NO_FLUSH, Z_SYNC_FLUSH, Z_FINISH,\r\n Z_BLOCK, or Z_TREES. Z_SYNC_FLUSH requests that inflate() flush as much\r\n output as possible to the output buffer. Z_BLOCK requests that inflate()\r\n stop if and when it gets to the next deflate block boundary. When decoding\r\n the zlib or gzip format, this will cause inflate() to return immediately\r\n after the header and before the first block. When doing a raw inflate,\r\n inflate() will go ahead and process the first block, and will return when it\r\n gets to the end of that block, or when it runs out of data.\r\n\r\n The Z_BLOCK option assists in appending to or combining deflate streams.\r\n Also to assist in this, on return inflate() will set strm->data_type to the\r\n number of unused bits in the last byte taken from strm->next_in, plus 64 if\r\n inflate() is currently decoding the last block in the deflate stream, plus\r\n 128 if inflate() returned immediately after decoding an end-of-block code or\r\n decoding the complete header up to just before the first byte of the deflate\r\n stream. The end-of-block will not be indicated until all of the uncompressed\r\n data from that block has been written to strm->next_out. The number of\r\n unused bits may in general be greater than seven, except when bit 7 of\r\n data_type is set, in which case the number of unused bits will be less than\r\n eight. data_type is set as noted here every time inflate() returns for all\r\n flush options, and so can be used to determine the amount of currently\r\n consumed input in bits.\r\n\r\n The Z_TREES option behaves as Z_BLOCK does, but it also returns when the\r\n end of each deflate block header is reached, before any actual data in that\r\n block is decoded. This allows the caller to determine the length of the\r\n deflate block header for later use in random access within a deflate block.\r\n 256 is added to the value of strm->data_type when inflate() returns\r\n immediately after reaching the end of the deflate block header.\r\n\r\n inflate() should normally be called until it returns Z_STREAM_END or an\r\n error. However if all decompression is to be performed in a single step (a\r\n single call of inflate), the parameter flush should be set to Z_FINISH. In\r\n this case all pending input is processed and all pending output is flushed;\r\n avail_out must be large enough to hold all the uncompressed data. (The size\r\n of the uncompressed data may have been saved by the compressor for this\r\n purpose.) The next operation on this stream must be inflateEnd to deallocate\r\n the decompression state. The use of Z_FINISH is never required, but can be\r\n used to inform inflate that a faster approach may be used for the single\r\n inflate() call.\r\n\r\n In this implementation, inflate() always flushes as much output as\r\n possible to the output buffer, and always uses the faster approach on the\r\n first call. So the only effect of the flush parameter in this implementation\r\n is on the return value of inflate(), as noted below, or when it returns early\r\n because Z_BLOCK or Z_TREES is used.\r\n\r\n If a preset dictionary is needed after this call (see inflateSetDictionary\r\n below), inflate sets strm->adler to the adler32 checksum of the dictionary\r\n chosen by the compressor and returns Z_NEED_DICT; otherwise it sets\r\n strm->adler to the adler32 checksum of all output produced so far (that is,\r\n total_out bytes) and returns Z_OK, Z_STREAM_END or an error code as described\r\n below. At the end of the stream, inflate() checks that its computed adler32\r\n checksum is equal to that saved by the compressor and returns Z_STREAM_END\r\n only if the checksum is correct.\r\n\r\n inflate() can decompress and check either zlib-wrapped or gzip-wrapped\r\n deflate data. The header type is detected automatically, if requested when\r\n initializing with inflateInit2(). Any information contained in the gzip\r\n header is not retained, so applications that need that information should\r\n instead use raw inflate, see inflateInit2() below, or inflateBack() and\r\n perform their own processing of the gzip header and trailer.\r\n\r\n inflate() returns Z_OK if some progress has been made (more input processed\r\n or more output produced), Z_STREAM_END if the end of the compressed data has\r\n been reached and all uncompressed output has been produced, Z_NEED_DICT if a\r\n preset dictionary is needed at this point, Z_DATA_ERROR if the input data was\r\n corrupted (input stream not conforming to the zlib format or incorrect check\r\n value), Z_STREAM_ERROR if the stream structure was inconsistent (for example\r\n next_in or next_out was Z_NULL), Z_MEM_ERROR if there was not enough memory,\r\n Z_BUF_ERROR if no progress is possible or if there was not enough room in the\r\n output buffer when Z_FINISH is used. Note that Z_BUF_ERROR is not fatal, and\r\n inflate() can be called again with more input and more output space to\r\n continue decompressing. If Z_DATA_ERROR is returned, the application may\r\n then call inflateSync() to look for a good compression block if a partial\r\n recovery of the data is desired.\r\n*/\r\n\r\n\r\nZEXTERN int ZEXPORT inflateEnd OF((z_streamp strm));\r\n/*\r\n All dynamically allocated data structures for this stream are freed.\r\n This function discards any unprocessed input and does not flush any pending\r\n output.\r\n\r\n inflateEnd returns Z_OK if success, Z_STREAM_ERROR if the stream state\r\n was inconsistent. In the error case, msg may be set but then points to a\r\n static string (which must not be deallocated).\r\n*/\r\n\r\n\r\n /* Advanced functions */\r\n\r\n/*\r\n The following functions are needed only in some special applications.\r\n*/\r\n\r\n/*\r\nZEXTERN int ZEXPORT deflateInit2 OF((z_streamp strm,\r\n int level,\r\n int method,\r\n int windowBits,\r\n int memLevel,\r\n int strategy));\r\n\r\n This is another version of deflateInit with more compression options. The\r\n fields next_in, zalloc, zfree and opaque must be initialized before by the\r\n caller.\r\n\r\n The method parameter is the compression method. It must be Z_DEFLATED in\r\n this version of the library.\r\n\r\n The windowBits parameter is the base two logarithm of the window size\r\n (the size of the history buffer). It should be in the range 8..15 for this\r\n version of the library. Larger values of this parameter result in better\r\n compression at the expense of memory usage. The default value is 15 if\r\n deflateInit is used instead.\r\n\r\n windowBits can also be -8..-15 for raw deflate. In this case, -windowBits\r\n determines the window size. deflate() will then generate raw deflate data\r\n with no zlib header or trailer, and will not compute an adler32 check value.\r\n\r\n windowBits can also be greater than 15 for optional gzip encoding. Add\r\n 16 to windowBits to write a simple gzip header and trailer around the\r\n compressed data instead of a zlib wrapper. The gzip header will have no\r\n file name, no extra data, no comment, no modification time (set to zero), no\r\n header crc, and the operating system will be set to 255 (unknown). If a\r\n gzip stream is being written, strm->adler is a crc32 instead of an adler32.\r\n\r\n The memLevel parameter specifies how much memory should be allocated\r\n for the internal compression state. memLevel=1 uses minimum memory but is\r\n slow and reduces compression ratio; memLevel=9 uses maximum memory for\r\n optimal speed. The default value is 8. See zconf.h for total memory usage\r\n as a function of windowBits and memLevel.\r\n\r\n The strategy parameter is used to tune the compression algorithm. Use the\r\n value Z_DEFAULT_STRATEGY for normal data, Z_FILTERED for data produced by a\r\n filter (or predictor), Z_HUFFMAN_ONLY to force Huffman encoding only (no\r\n string match), or Z_RLE to limit match distances to one (run-length\r\n encoding). Filtered data consists mostly of small values with a somewhat\r\n random distribution. In this case, the compression algorithm is tuned to\r\n compress them better. The effect of Z_FILTERED is to force more Huffman\r\n coding and less string matching; it is somewhat intermediate between\r\n Z_DEFAULT_STRATEGY and Z_HUFFMAN_ONLY. Z_RLE is designed to be almost as\r\n fast as Z_HUFFMAN_ONLY, but give better compression for PNG image data. The\r\n strategy parameter only affects the compression ratio but not the\r\n correctness of the compressed output even if it is not set appropriately.\r\n Z_FIXED prevents the use of dynamic Huffman codes, allowing for a simpler\r\n decoder for special applications.\r\n\r\n deflateInit2 returns Z_OK if success, Z_MEM_ERROR if there was not enough\r\n memory, Z_STREAM_ERROR if any parameter is invalid (such as an invalid\r\n method), or Z_VERSION_ERROR if the zlib library version (zlib_version) is\r\n incompatible with the version assumed by the caller (ZLIB_VERSION). msg is\r\n set to null if there is no error message. deflateInit2 does not perform any\r\n compression: this will be done by deflate().\r\n*/\r\n\r\nZEXTERN int ZEXPORT deflateSetDictionary OF((z_streamp strm,\r\n const Bytef *dictionary,\r\n uInt dictLength));\r\n/*\r\n Initializes the compression dictionary from the given byte sequence\r\n without producing any compressed output. This function must be called\r\n immediately after deflateInit, deflateInit2 or deflateReset, before any call\r\n of deflate. The compressor and decompressor must use exactly the same\r\n dictionary (see inflateSetDictionary).\r\n\r\n The dictionary should consist of strings (byte sequences) that are likely\r\n to be encountered later in the data to be compressed, with the most commonly\r\n used strings preferably put towards the end of the dictionary. Using a\r\n dictionary is most useful when the data to be compressed is short and can be\r\n predicted with good accuracy; the data can then be compressed better than\r\n with the default empty dictionary.\r\n\r\n Depending on the size of the compression data structures selected by\r\n deflateInit or deflateInit2, a part of the dictionary may in effect be\r\n discarded, for example if the dictionary is larger than the window size\r\n provided in deflateInit or deflateInit2. Thus the strings most likely to be\r\n useful should be put at the end of the dictionary, not at the front. In\r\n addition, the current implementation of deflate will use at most the window\r\n size minus 262 bytes of the provided dictionary.\r\n\r\n Upon return of this function, strm->adler is set to the adler32 value\r\n of the dictionary; the decompressor may later use this value to determine\r\n which dictionary has been used by the compressor. (The adler32 value\r\n applies to the whole dictionary even if only a subset of the dictionary is\r\n actually used by the compressor.) If a raw deflate was requested, then the\r\n adler32 value is not computed and strm->adler is not set.\r\n\r\n deflateSetDictionary returns Z_OK if success, or Z_STREAM_ERROR if a\r\n parameter is invalid (e.g. dictionary being Z_NULL) or the stream state is\r\n inconsistent (for example if deflate has already been called for this stream\r\n or if the compression method is bsort). deflateSetDictionary does not\r\n perform any compression: this will be done by deflate().\r\n*/\r\n\r\nZEXTERN int ZEXPORT deflateCopy OF((z_streamp dest,\r\n z_streamp source));\r\n/*\r\n Sets the destination stream as a complete copy of the source stream.\r\n\r\n This function can be useful when several compression strategies will be\r\n tried, for example when there are several ways of pre-processing the input\r\n data with a filter. The streams that will be discarded should then be freed\r\n by calling deflateEnd. Note that deflateCopy duplicates the internal\r\n compression state which can be quite large, so this strategy is slow and can\r\n consume lots of memory.\r\n\r\n deflateCopy returns Z_OK if success, Z_MEM_ERROR if there was not\r\n enough memory, Z_STREAM_ERROR if the source stream state was inconsistent\r\n (such as zalloc being Z_NULL). msg is left unchanged in both source and\r\n destination.\r\n*/\r\n\r\nZEXTERN int ZEXPORT deflateReset OF((z_streamp strm));\r\n/*\r\n This function is equivalent to deflateEnd followed by deflateInit,\r\n but does not free and reallocate all the internal compression state. The\r\n stream will keep the same compression level and any other attributes that\r\n may have been set by deflateInit2.\r\n\r\n deflateReset returns Z_OK if success, or Z_STREAM_ERROR if the source\r\n stream state was inconsistent (such as zalloc or state being Z_NULL).\r\n*/\r\n\r\nZEXTERN int ZEXPORT deflateParams OF((z_streamp strm,\r\n int level,\r\n int strategy));\r\n/*\r\n Dynamically update the compression level and compression strategy. The\r\n interpretation of level and strategy is as in deflateInit2. This can be\r\n used to switch between compression and straight copy of the input data, or\r\n to switch to a different kind of input data requiring a different strategy.\r\n If the compression level is changed, the input available so far is\r\n compressed with the old level (and may be flushed); the new level will take\r\n effect only at the next call of deflate().\r\n\r\n Before the call of deflateParams, the stream state must be set as for\r\n a call of deflate(), since the currently available input may have to be\r\n compressed and flushed. In particular, strm->avail_out must be non-zero.\r\n\r\n deflateParams returns Z_OK if success, Z_STREAM_ERROR if the source\r\n stream state was inconsistent or if a parameter was invalid, Z_BUF_ERROR if\r\n strm->avail_out was zero.\r\n*/\r\n\r\nZEXTERN int ZEXPORT deflateTune OF((z_streamp strm,\r\n int good_length,\r\n int max_lazy,\r\n int nice_length,\r\n int max_chain));\r\n/*\r\n Fine tune deflate's internal compression parameters. This should only be\r\n used by someone who understands the algorithm used by zlib's deflate for\r\n searching for the best matching string, and even then only by the most\r\n fanatic optimizer trying to squeeze out the last compressed bit for their\r\n specific input data. Read the deflate.c source code for the meaning of the\r\n max_lazy, good_length, nice_length, and max_chain parameters.\r\n\r\n deflateTune() can be called after deflateInit() or deflateInit2(), and\r\n returns Z_OK on success, or Z_STREAM_ERROR for an invalid deflate stream.\r\n */\r\n\r\nZEXTERN uLong ZEXPORT deflateBound OF((z_streamp strm,\r\n uLong sourceLen));\r\n/*\r\n deflateBound() returns an upper bound on the compressed size after\r\n deflation of sourceLen bytes. It must be called after deflateInit() or\r\n deflateInit2(), and after deflateSetHeader(), if used. This would be used\r\n to allocate an output buffer for deflation in a single pass, and so would be\r\n called before deflate().\r\n*/\r\n\r\nZEXTERN int ZEXPORT deflatePrime OF((z_streamp strm,\r\n int bits,\r\n int value));\r\n/*\r\n deflatePrime() inserts bits in the deflate output stream. The intent\r\n is that this function is used to start off the deflate output with the bits\r\n leftover from a previous deflate stream when appending to it. As such, this\r\n function can only be used for raw deflate, and must be used before the first\r\n deflate() call after a deflateInit2() or deflateReset(). bits must be less\r\n than or equal to 16, and that many of the least significant bits of value\r\n will be inserted in the output.\r\n\r\n deflatePrime returns Z_OK if success, or Z_STREAM_ERROR if the source\r\n stream state was inconsistent.\r\n*/\r\n\r\nZEXTERN int ZEXPORT deflateSetHeader OF((z_streamp strm,\r\n gz_headerp head));\r\n/*\r\n deflateSetHeader() provides gzip header information for when a gzip\r\n stream is requested by deflateInit2(). deflateSetHeader() may be called\r\n after deflateInit2() or deflateReset() and before the first call of\r\n deflate(). The text, time, os, extra field, name, and comment information\r\n in the provided gz_header structure are written to the gzip header (xflag is\r\n ignored -- the extra flags are set according to the compression level). The\r\n caller must assure that, if not Z_NULL, name and comment are terminated with\r\n a zero byte, and that if extra is not Z_NULL, that extra_len bytes are\r\n available there. If hcrc is true, a gzip header crc is included. Note that\r\n the current versions of the command-line version of gzip (up through version\r\n 1.3.x) do not support header crc's, and will report that it is a \"multi-part\r\n gzip file\" and give up.\r\n\r\n If deflateSetHeader is not used, the default gzip header has text false,\r\n the time set to zero, and os set to 255, with no extra, name, or comment\r\n fields. The gzip header is returned to the default state by deflateReset().\r\n\r\n deflateSetHeader returns Z_OK if success, or Z_STREAM_ERROR if the source\r\n stream state was inconsistent.\r\n*/\r\n\r\n/*\r\nZEXTERN int ZEXPORT inflateInit2 OF((z_streamp strm,\r\n int windowBits));\r\n\r\n This is another version of inflateInit with an extra parameter. The\r\n fields next_in, avail_in, zalloc, zfree and opaque must be initialized\r\n before by the caller.\r\n\r\n The windowBits parameter is the base two logarithm of the maximum window\r\n size (the size of the history buffer). It should be in the range 8..15 for\r\n this version of the library. The default value is 15 if inflateInit is used\r\n instead. windowBits must be greater than or equal to the windowBits value\r\n provided to deflateInit2() while compressing, or it must be equal to 15 if\r\n deflateInit2() was not used. If a compressed stream with a larger window\r\n size is given as input, inflate() will return with the error code\r\n Z_DATA_ERROR instead of trying to allocate a larger window.\r\n\r\n windowBits can also be zero to request that inflate use the window size in\r\n the zlib header of the compressed stream.\r\n\r\n windowBits can also be -8..-15 for raw inflate. In this case, -windowBits\r\n determines the window size. inflate() will then process raw deflate data,\r\n not looking for a zlib or gzip header, not generating a check value, and not\r\n looking for any check values for comparison at the end of the stream. This\r\n is for use with other formats that use the deflate compressed data format\r\n such as zip. Those formats provide their own check values. If a custom\r\n format is developed using the raw deflate format for compressed data, it is\r\n recommended that a check value such as an adler32 or a crc32 be applied to\r\n the uncompressed data as is done in the zlib, gzip, and zip formats. For\r\n most applications, the zlib format should be used as is. Note that comments\r\n above on the use in deflateInit2() applies to the magnitude of windowBits.\r\n\r\n windowBits can also be greater than 15 for optional gzip decoding. Add\r\n 32 to windowBits to enable zlib and gzip decoding with automatic header\r\n detection, or add 16 to decode only the gzip format (the zlib format will\r\n return a Z_DATA_ERROR). If a gzip stream is being decoded, strm->adler is a\r\n crc32 instead of an adler32.\r\n\r\n inflateInit2 returns Z_OK if success, Z_MEM_ERROR if there was not enough\r\n memory, Z_VERSION_ERROR if the zlib library version is incompatible with the\r\n version assumed by the caller, or Z_STREAM_ERROR if the parameters are\r\n invalid, such as a null pointer to the structure. msg is set to null if\r\n there is no error message. inflateInit2 does not perform any decompression\r\n apart from possibly reading the zlib header if present: actual decompression\r\n will be done by inflate(). (So next_in and avail_in may be modified, but\r\n next_out and avail_out are unused and unchanged.) The current implementation\r\n of inflateInit2() does not process any header information -- that is\r\n deferred until inflate() is called.\r\n*/\r\n\r\nZEXTERN int ZEXPORT inflateSetDictionary OF((z_streamp strm,\r\n const Bytef *dictionary,\r\n uInt dictLength));\r\n/*\r\n Initializes the decompression dictionary from the given uncompressed byte\r\n sequence. This function must be called immediately after a call of inflate,\r\n if that call returned Z_NEED_DICT. The dictionary chosen by the compressor\r\n can be determined from the adler32 value returned by that call of inflate.\r\n The compressor and decompressor must use exactly the same dictionary (see\r\n deflateSetDictionary). For raw inflate, this function can be called\r\n immediately after inflateInit2() or inflateReset() and before any call of\r\n inflate() to set the dictionary. The application must insure that the\r\n dictionary that was used for compression is provided.\r\n\r\n inflateSetDictionary returns Z_OK if success, Z_STREAM_ERROR if a\r\n parameter is invalid (e.g. dictionary being Z_NULL) or the stream state is\r\n inconsistent, Z_DATA_ERROR if the given dictionary doesn't match the\r\n expected one (incorrect adler32 value). inflateSetDictionary does not\r\n perform any decompression: this will be done by subsequent calls of\r\n inflate().\r\n*/\r\n\r\nZEXTERN int ZEXPORT inflateSync OF((z_streamp strm));\r\n/*\r\n Skips invalid compressed data until a full flush point (see above the\r\n description of deflate with Z_FULL_FLUSH) can be found, or until all\r\n available input is skipped. No output is provided.\r\n\r\n inflateSync returns Z_OK if a full flush point has been found, Z_BUF_ERROR\r\n if no more input was provided, Z_DATA_ERROR if no flush point has been\r\n found, or Z_STREAM_ERROR if the stream structure was inconsistent. In the\r\n success case, the application may save the current current value of total_in\r\n which indicates where valid compressed data was found. In the error case,\r\n the application may repeatedly call inflateSync, providing more input each\r\n time, until success or end of the input data.\r\n*/\r\n\r\nZEXTERN int ZEXPORT inflateCopy OF((z_streamp dest,\r\n z_streamp source));\r\n/*\r\n Sets the destination stream as a complete copy of the source stream.\r\n\r\n This function can be useful when randomly accessing a large stream. The\r\n first pass through the stream can periodically record the inflate state,\r\n allowing restarting inflate at those points when randomly accessing the\r\n stream.\r\n\r\n inflateCopy returns Z_OK if success, Z_MEM_ERROR if there was not\r\n enough memory, Z_STREAM_ERROR if the source stream state was inconsistent\r\n (such as zalloc being Z_NULL). msg is left unchanged in both source and\r\n destination.\r\n*/\r\n\r\nZEXTERN int ZEXPORT inflateReset OF((z_streamp strm));\r\n/*\r\n This function is equivalent to inflateEnd followed by inflateInit,\r\n but does not free and reallocate all the internal decompression state. The\r\n stream will keep attributes that may have been set by inflateInit2.\r\n\r\n inflateReset returns Z_OK if success, or Z_STREAM_ERROR if the source\r\n stream state was inconsistent (such as zalloc or state being Z_NULL).\r\n*/\r\n\r\nZEXTERN int ZEXPORT inflateReset2 OF((z_streamp strm,\r\n int windowBits));\r\n/*\r\n This function is the same as inflateReset, but it also permits changing\r\n the wrap and window size requests. The windowBits parameter is interpreted\r\n the same as it is for inflateInit2.\r\n\r\n inflateReset2 returns Z_OK if success, or Z_STREAM_ERROR if the source\r\n stream state was inconsistent (such as zalloc or state being Z_NULL), or if\r\n the windowBits parameter is invalid.\r\n*/\r\n\r\nZEXTERN int ZEXPORT inflatePrime OF((z_streamp strm,\r\n int bits,\r\n int value));\r\n/*\r\n This function inserts bits in the inflate input stream. The intent is\r\n that this function is used to start inflating at a bit position in the\r\n middle of a byte. The provided bits will be used before any bytes are used\r\n from next_in. This function should only be used with raw inflate, and\r\n should be used before the first inflate() call after inflateInit2() or\r\n inflateReset(). bits must be less than or equal to 16, and that many of the\r\n least significant bits of value will be inserted in the input.\r\n\r\n If bits is negative, then the input stream bit buffer is emptied. Then\r\n inflatePrime() can be called again to put bits in the buffer. This is used\r\n to clear out bits leftover after feeding inflate a block description prior\r\n to feeding inflate codes.\r\n\r\n inflatePrime returns Z_OK if success, or Z_STREAM_ERROR if the source\r\n stream state was inconsistent.\r\n*/\r\n\r\nZEXTERN long ZEXPORT inflateMark OF((z_streamp strm));\r\n/*\r\n This function returns two values, one in the lower 16 bits of the return\r\n value, and the other in the remaining upper bits, obtained by shifting the\r\n return value down 16 bits. If the upper value is -1 and the lower value is\r\n zero, then inflate() is currently decoding information outside of a block.\r\n If the upper value is -1 and the lower value is non-zero, then inflate is in\r\n the middle of a stored block, with the lower value equaling the number of\r\n bytes from the input remaining to copy. If the upper value is not -1, then\r\n it is the number of bits back from the current bit position in the input of\r\n the code (literal or length/distance pair) currently being processed. In\r\n that case the lower value is the number of bytes already emitted for that\r\n code.\r\n\r\n A code is being processed if inflate is waiting for more input to complete\r\n decoding of the code, or if it has completed decoding but is waiting for\r\n more output space to write the literal or match data.\r\n\r\n inflateMark() is used to mark locations in the input data for random\r\n access, which may be at bit positions, and to note those cases where the\r\n output of a code may span boundaries of random access blocks. The current\r\n location in the input stream can be determined from avail_in and data_type\r\n as noted in the description for the Z_BLOCK flush parameter for inflate.\r\n\r\n inflateMark returns the value noted above or -1 << 16 if the provided\r\n source stream state was inconsistent.\r\n*/\r\n\r\nZEXTERN int ZEXPORT inflateGetHeader OF((z_streamp strm,\r\n gz_headerp head));\r\n/*\r\n inflateGetHeader() requests that gzip header information be stored in the\r\n provided gz_header structure. inflateGetHeader() may be called after\r\n inflateInit2() or inflateReset(), and before the first call of inflate().\r\n As inflate() processes the gzip stream, head->done is zero until the header\r\n is completed, at which time head->done is set to one. If a zlib stream is\r\n being decoded, then head->done is set to -1 to indicate that there will be\r\n no gzip header information forthcoming. Note that Z_BLOCK or Z_TREES can be\r\n used to force inflate() to return immediately after header processing is\r\n complete and before any actual data is decompressed.\r\n\r\n The text, time, xflags, and os fields are filled in with the gzip header\r\n contents. hcrc is set to true if there is a header CRC. (The header CRC\r\n was valid if done is set to one.) If extra is not Z_NULL, then extra_max\r\n contains the maximum number of bytes to write to extra. Once done is true,\r\n extra_len contains the actual extra field length, and extra contains the\r\n extra field, or that field truncated if extra_max is less than extra_len.\r\n If name is not Z_NULL, then up to name_max characters are written there,\r\n terminated with a zero unless the length is greater than name_max. If\r\n comment is not Z_NULL, then up to comm_max characters are written there,\r\n terminated with a zero unless the length is greater than comm_max. When any\r\n of extra, name, or comment are not Z_NULL and the respective field is not\r\n present in the header, then that field is set to Z_NULL to signal its\r\n absence. This allows the use of deflateSetHeader() with the returned\r\n structure to duplicate the header. However if those fields are set to\r\n allocated memory, then the application will need to save those pointers\r\n elsewhere so that they can be eventually freed.\r\n\r\n If inflateGetHeader is not used, then the header information is simply\r\n discarded. The header is always checked for validity, including the header\r\n CRC if present. inflateReset() will reset the process to discard the header\r\n information. The application would need to call inflateGetHeader() again to\r\n retrieve the header from the next gzip stream.\r\n\r\n inflateGetHeader returns Z_OK if success, or Z_STREAM_ERROR if the source\r\n stream state was inconsistent.\r\n*/\r\n\r\n/*\r\nZEXTERN int ZEXPORT inflateBackInit OF((z_streamp strm, int windowBits,\r\n unsigned char FAR *window));\r\n\r\n Initialize the internal stream state for decompression using inflateBack()\r\n calls. The fields zalloc, zfree and opaque in strm must be initialized\r\n before the call. If zalloc and zfree are Z_NULL, then the default library-\r\n derived memory allocation routines are used. windowBits is the base two\r\n logarithm of the window size, in the range 8..15. window is a caller\r\n supplied buffer of that size. Except for special applications where it is\r\n assured that deflate was used with small window sizes, windowBits must be 15\r\n and a 32K byte window must be supplied to be able to decompress general\r\n deflate streams.\r\n\r\n See inflateBack() for the usage of these routines.\r\n\r\n inflateBackInit will return Z_OK on success, Z_STREAM_ERROR if any of\r\n the paramaters are invalid, Z_MEM_ERROR if the internal state could not be\r\n allocated, or Z_VERSION_ERROR if the version of the library does not match\r\n the version of the header file.\r\n*/\r\n\r\ntypedef unsigned (*in_func) OF((void FAR *, unsigned char FAR * FAR *));\r\ntypedef int (*out_func) OF((void FAR *, unsigned char FAR *, unsigned));\r\n\r\nZEXTERN int ZEXPORT inflateBack OF((z_streamp strm,\r\n in_func in, void FAR *in_desc,\r\n out_func out, void FAR *out_desc));\r\n/*\r\n inflateBack() does a raw inflate with a single call using a call-back\r\n interface for input and output. This is more efficient than inflate() for\r\n file i/o applications in that it avoids copying between the output and the\r\n sliding window by simply making the window itself the output buffer. This\r\n function trusts the application to not change the output buffer passed by\r\n the output function, at least until inflateBack() returns.\r\n\r\n inflateBackInit() must be called first to allocate the internal state\r\n and to initialize the state with the user-provided window buffer.\r\n inflateBack() may then be used multiple times to inflate a complete, raw\r\n deflate stream with each call. inflateBackEnd() is then called to free the\r\n allocated state.\r\n\r\n A raw deflate stream is one with no zlib or gzip header or trailer.\r\n This routine would normally be used in a utility that reads zip or gzip\r\n files and writes out uncompressed files. The utility would decode the\r\n header and process the trailer on its own, hence this routine expects only\r\n the raw deflate stream to decompress. This is different from the normal\r\n behavior of inflate(), which expects either a zlib or gzip header and\r\n trailer around the deflate stream.\r\n\r\n inflateBack() uses two subroutines supplied by the caller that are then\r\n called by inflateBack() for input and output. inflateBack() calls those\r\n routines until it reads a complete deflate stream and writes out all of the\r\n uncompressed data, or until it encounters an error. The function's\r\n parameters and return types are defined above in the in_func and out_func\r\n typedefs. inflateBack() will call in(in_desc, &buf) which should return the\r\n number of bytes of provided input, and a pointer to that input in buf. If\r\n there is no input available, in() must return zero--buf is ignored in that\r\n case--and inflateBack() will return a buffer error. inflateBack() will call\r\n out(out_desc, buf, len) to write the uncompressed data buf[0..len-1]. out()\r\n should return zero on success, or non-zero on failure. If out() returns\r\n non-zero, inflateBack() will return with an error. Neither in() nor out()\r\n are permitted to change the contents of the window provided to\r\n inflateBackInit(), which is also the buffer that out() uses to write from.\r\n The length written by out() will be at most the window size. Any non-zero\r\n amount of input may be provided by in().\r\n\r\n For convenience, inflateBack() can be provided input on the first call by\r\n setting strm->next_in and strm->avail_in. If that input is exhausted, then\r\n in() will be called. Therefore strm->next_in must be initialized before\r\n calling inflateBack(). If strm->next_in is Z_NULL, then in() will be called\r\n immediately for input. If strm->next_in is not Z_NULL, then strm->avail_in\r\n must also be initialized, and then if strm->avail_in is not zero, input will\r\n initially be taken from strm->next_in[0 .. strm->avail_in - 1].\r\n\r\n The in_desc and out_desc parameters of inflateBack() is passed as the\r\n first parameter of in() and out() respectively when they are called. These\r\n descriptors can be optionally used to pass any information that the caller-\r\n supplied in() and out() functions need to do their job.\r\n\r\n On return, inflateBack() will set strm->next_in and strm->avail_in to\r\n pass back any unused input that was provided by the last in() call. The\r\n return values of inflateBack() can be Z_STREAM_END on success, Z_BUF_ERROR\r\n if in() or out() returned an error, Z_DATA_ERROR if there was a format error\r\n in the deflate stream (in which case strm->msg is set to indicate the nature\r\n of the error), or Z_STREAM_ERROR if the stream was not properly initialized.\r\n In the case of Z_BUF_ERROR, an input or output error can be distinguished\r\n using strm->next_in which will be Z_NULL only if in() returned an error. If\r\n strm->next_in is not Z_NULL, then the Z_BUF_ERROR was due to out() returning\r\n non-zero. (in() will always be called before out(), so strm->next_in is\r\n assured to be defined if out() returns non-zero.) Note that inflateBack()\r\n cannot return Z_OK.\r\n*/\r\n\r\nZEXTERN int ZEXPORT inflateBackEnd OF((z_streamp strm));\r\n/*\r\n All memory allocated by inflateBackInit() is freed.\r\n\r\n inflateBackEnd() returns Z_OK on success, or Z_STREAM_ERROR if the stream\r\n state was inconsistent.\r\n*/\r\n\r\nZEXTERN uLong ZEXPORT zlibCompileFlags OF((void));\r\n/* Return flags indicating compile-time options.\r\n\r\n Type sizes, two bits each, 00 = 16 bits, 01 = 32, 10 = 64, 11 = other:\r\n 1.0: size of uInt\r\n 3.2: size of uLong\r\n 5.4: size of voidpf (pointer)\r\n 7.6: size of z_off_t\r\n\r\n Compiler, assembler, and debug options:\r\n 8: DEBUG\r\n 9: ASMV or ASMINF -- use ASM code\r\n 10: ZLIB_WINAPI -- exported functions use the WINAPI calling convention\r\n 11: 0 (reserved)\r\n\r\n One-time table building (smaller code, but not thread-safe if true):\r\n 12: BUILDFIXED -- build static block decoding tables when needed\r\n 13: DYNAMIC_CRC_TABLE -- build CRC calculation tables when needed\r\n 14,15: 0 (reserved)\r\n\r\n Library content (indicates missing functionality):\r\n 16: NO_GZCOMPRESS -- gz* functions cannot compress (to avoid linking\r\n deflate code when not needed)\r\n 17: NO_GZIP -- deflate can't write gzip streams, and inflate can't detect\r\n and decode gzip streams (to avoid linking crc code)\r\n 18-19: 0 (reserved)\r\n\r\n Operation variations (changes in library functionality):\r\n 20: PKZIP_BUG_WORKAROUND -- slightly more permissive inflate\r\n 21: FASTEST -- deflate algorithm with only one, lowest compression level\r\n 22,23: 0 (reserved)\r\n\r\n The sprintf variant used by gzprintf (zero is best):\r\n 24: 0 = vs*, 1 = s* -- 1 means limited to 20 arguments after the format\r\n 25: 0 = *nprintf, 1 = *printf -- 1 means gzprintf() not secure!\r\n 26: 0 = returns value, 1 = void -- 1 means inferred string length returned\r\n\r\n Remainder:\r\n 27-31: 0 (reserved)\r\n */\r\n\r\n\r\n /* utility functions */\r\n\r\n/*\r\n The following utility functions are implemented on top of the basic\r\n stream-oriented functions. To simplify the interface, some default options\r\n are assumed (compression level and memory usage, standard memory allocation\r\n functions). The source code of these utility functions can be modified if\r\n you need special options.\r\n*/\r\n\r\nZEXTERN int ZEXPORT compress OF((Bytef *dest, uLongf *destLen,\r\n const Bytef *source, uLong sourceLen));\r\n/*\r\n Compresses the source buffer into the destination buffer. sourceLen is\r\n the byte length of the source buffer. Upon entry, destLen is the total size\r\n of the destination buffer, which must be at least the value returned by\r\n compressBound(sourceLen). Upon exit, destLen is the actual size of the\r\n compressed buffer.\r\n\r\n compress returns Z_OK if success, Z_MEM_ERROR if there was not\r\n enough memory, Z_BUF_ERROR if there was not enough room in the output\r\n buffer.\r\n*/\r\n\r\nZEXTERN int ZEXPORT compress2 OF((Bytef *dest, uLongf *destLen,\r\n const Bytef *source, uLong sourceLen,\r\n int level));\r\n/*\r\n Compresses the source buffer into the destination buffer. The level\r\n parameter has the same meaning as in deflateInit. sourceLen is the byte\r\n length of the source buffer. Upon entry, destLen is the total size of the\r\n destination buffer, which must be at least the value returned by\r\n compressBound(sourceLen). Upon exit, destLen is the actual size of the\r\n compressed buffer.\r\n\r\n compress2 returns Z_OK if success, Z_MEM_ERROR if there was not enough\r\n memory, Z_BUF_ERROR if there was not enough room in the output buffer,\r\n Z_STREAM_ERROR if the level parameter is invalid.\r\n*/\r\n\r\nZEXTERN uLong ZEXPORT compressBound OF((uLong sourceLen));\r\n/*\r\n compressBound() returns an upper bound on the compressed size after\r\n compress() or compress2() on sourceLen bytes. It would be used before a\r\n compress() or compress2() call to allocate the destination buffer.\r\n*/\r\n\r\nZEXTERN int ZEXPORT uncompress OF((Bytef *dest, uLongf *destLen,\r\n const Bytef *source, uLong sourceLen));\r\n/*\r\n Decompresses the source buffer into the destination buffer. sourceLen is\r\n the byte length of the source buffer. Upon entry, destLen is the total size\r\n of the destination buffer, which must be large enough to hold the entire\r\n uncompressed data. (The size of the uncompressed data must have been saved\r\n previously by the compressor and transmitted to the decompressor by some\r\n mechanism outside the scope of this compression library.) Upon exit, destLen\r\n is the actual size of the uncompressed buffer.\r\n\r\n uncompress returns Z_OK if success, Z_MEM_ERROR if there was not\r\n enough memory, Z_BUF_ERROR if there was not enough room in the output\r\n buffer, or Z_DATA_ERROR if the input data was corrupted or incomplete.\r\n*/\r\n\r\n\r\n /* gzip file access functions */\r\n\r\n/*\r\n This library supports reading and writing files in gzip (.gz) format with\r\n an interface similar to that of stdio, using the functions that start with\r\n \"gz\". The gzip format is different from the zlib format. gzip is a gzip\r\n wrapper, documented in RFC 1952, wrapped around a deflate stream.\r\n*/\r\n\r\ntypedef voidp gzFile; /* opaque gzip file descriptor */\r\n\r\n/*\r\nZEXTERN gzFile ZEXPORT gzopen OF((const char *path, const char *mode));\r\n\r\n Opens a gzip (.gz) file for reading or writing. The mode parameter is as\r\n in fopen (\"rb\" or \"wb\") but can also include a compression level (\"wb9\") or\r\n a strategy: 'f' for filtered data as in \"wb6f\", 'h' for Huffman-only\r\n compression as in \"wb1h\", 'R' for run-length encoding as in \"wb1R\", or 'F'\r\n for fixed code compression as in \"wb9F\". (See the description of\r\n deflateInit2 for more information about the strategy parameter.) Also \"a\"\r\n can be used instead of \"w\" to request that the gzip stream that will be\r\n written be appended to the file. \"+\" will result in an error, since reading\r\n and writing to the same gzip file is not supported.\r\n\r\n gzopen can be used to read a file which is not in gzip format; in this\r\n case gzread will directly read from the file without decompression.\r\n\r\n gzopen returns NULL if the file could not be opened, if there was\r\n insufficient memory to allocate the gzFile state, or if an invalid mode was\r\n specified (an 'r', 'w', or 'a' was not provided, or '+' was provided).\r\n errno can be checked to determine if the reason gzopen failed was that the\r\n file could not be opened.\r\n*/\r\n\r\nZEXTERN gzFile ZEXPORT gzdopen OF((int fd, const char *mode));\r\n/*\r\n gzdopen associates a gzFile with the file descriptor fd. File descriptors\r\n are obtained from calls like open, dup, creat, pipe or fileno (if the file\r\n has been previously opened with fopen). The mode parameter is as in gzopen.\r\n\r\n The next call of gzclose on the returned gzFile will also close the file\r\n descriptor fd, just like fclose(fdopen(fd, mode)) closes the file descriptor\r\n fd. If you want to keep fd open, use fd = dup(fd_keep); gz = gzdopen(fd,\r\n mode);. The duplicated descriptor should be saved to avoid a leak, since\r\n gzdopen does not close fd if it fails.\r\n\r\n gzdopen returns NULL if there was insufficient memory to allocate the\r\n gzFile state, if an invalid mode was specified (an 'r', 'w', or 'a' was not\r\n provided, or '+' was provided), or if fd is -1. The file descriptor is not\r\n used until the next gz* read, write, seek, or close operation, so gzdopen\r\n will not detect if fd is invalid (unless fd is -1).\r\n*/\r\n\r\nZEXTERN int ZEXPORT gzbuffer OF((gzFile file, unsigned size));\r\n/*\r\n Set the internal buffer size used by this library's functions. The\r\n default buffer size is 8192 bytes. This function must be called after\r\n gzopen() or gzdopen(), and before any other calls that read or write the\r\n file. The buffer memory allocation is always deferred to the first read or\r\n write. Two buffers are allocated, either both of the specified size when\r\n writing, or one of the specified size and the other twice that size when\r\n reading. A larger buffer size of, for example, 64K or 128K bytes will\r\n noticeably increase the speed of decompression (reading).\r\n\r\n The new buffer size also affects the maximum length for gzprintf().\r\n\r\n gzbuffer() returns 0 on success, or -1 on failure, such as being called\r\n too late.\r\n*/\r\n\r\nZEXTERN int ZEXPORT gzsetparams OF((gzFile file, int level, int strategy));\r\n/*\r\n Dynamically update the compression level or strategy. See the description\r\n of deflateInit2 for the meaning of these parameters.\r\n\r\n gzsetparams returns Z_OK if success, or Z_STREAM_ERROR if the file was not\r\n opened for writing.\r\n*/\r\n\r\nZEXTERN int ZEXPORT gzread OF((gzFile file, voidp buf, unsigned len));\r\n/*\r\n Reads the given number of uncompressed bytes from the compressed file. If\r\n the input file was not in gzip format, gzread copies the given number of\r\n bytes into the buffer.\r\n\r\n After reaching the end of a gzip stream in the input, gzread will continue\r\n to read, looking for another gzip stream, or failing that, reading the rest\r\n of the input file directly without decompression. The entire input file\r\n will be read if gzread is called until it returns less than the requested\r\n len.\r\n\r\n gzread returns the number of uncompressed bytes actually read, less than\r\n len for end of file, or -1 for error.\r\n*/\r\n\r\nZEXTERN int ZEXPORT gzwrite OF((gzFile file,\r\n voidpc buf, unsigned len));\r\n/*\r\n Writes the given number of uncompressed bytes into the compressed file.\r\n gzwrite returns the number of uncompressed bytes written or 0 in case of\r\n error.\r\n*/\r\n\r\nZEXTERN int ZEXPORTVA gzprintf OF((gzFile file, const char *format, ...));\r\n/*\r\n Converts, formats, and writes the arguments to the compressed file under\r\n control of the format string, as in fprintf. gzprintf returns the number of\r\n uncompressed bytes actually written, or 0 in case of error. The number of\r\n uncompressed bytes written is limited to 8191, or one less than the buffer\r\n size given to gzbuffer(). The caller should assure that this limit is not\r\n exceeded. If it is exceeded, then gzprintf() will return an error (0) with\r\n nothing written. In this case, there may also be a buffer overflow with\r\n unpredictable consequences, which is possible only if zlib was compiled with\r\n the insecure functions sprintf() or vsprintf() because the secure snprintf()\r\n or vsnprintf() functions were not available. This can be determined using\r\n zlibCompileFlags().\r\n*/\r\n\r\nZEXTERN int ZEXPORT gzputs OF((gzFile file, const char *s));\r\n/*\r\n Writes the given null-terminated string to the compressed file, excluding\r\n the terminating null character.\r\n\r\n gzputs returns the number of characters written, or -1 in case of error.\r\n*/\r\n\r\nZEXTERN char * ZEXPORT gzgets OF((gzFile file, char *buf, int len));\r\n/*\r\n Reads bytes from the compressed file until len-1 characters are read, or a\r\n newline character is read and transferred to buf, or an end-of-file\r\n condition is encountered. If any characters are read or if len == 1, the\r\n string is terminated with a null character. If no characters are read due\r\n to an end-of-file or len < 1, then the buffer is left untouched.\r\n\r\n gzgets returns buf which is a null-terminated string, or it returns NULL\r\n for end-of-file or in case of error. If there was an error, the contents at\r\n buf are indeterminate.\r\n*/\r\n\r\nZEXTERN int ZEXPORT gzputc OF((gzFile file, int c));\r\n/*\r\n Writes c, converted to an unsigned char, into the compressed file. gzputc\r\n returns the value that was written, or -1 in case of error.\r\n*/\r\n\r\nZEXTERN int ZEXPORT gzgetc OF((gzFile file));\r\n/*\r\n Reads one byte from the compressed file. gzgetc returns this byte or -1\r\n in case of end of file or error.\r\n*/\r\n\r\nZEXTERN int ZEXPORT gzungetc OF((int c, gzFile file));\r\n/*\r\n Push one character back onto the stream to be read as the first character\r\n on the next read. At least one character of push-back is allowed.\r\n gzungetc() returns the character pushed, or -1 on failure. gzungetc() will\r\n fail if c is -1, and may fail if a character has been pushed but not read\r\n yet. If gzungetc is used immediately after gzopen or gzdopen, at least the\r\n output buffer size of pushed characters is allowed. (See gzbuffer above.)\r\n The pushed character will be discarded if the stream is repositioned with\r\n gzseek() or gzrewind().\r\n*/\r\n\r\nZEXTERN int ZEXPORT gzflush OF((gzFile file, int flush));\r\n/*\r\n Flushes all pending output into the compressed file. The parameter flush\r\n is as in the deflate() function. The return value is the zlib error number\r\n (see function gzerror below). gzflush is only permitted when writing.\r\n\r\n If the flush parameter is Z_FINISH, the remaining data is written and the\r\n gzip stream is completed in the output. If gzwrite() is called again, a new\r\n gzip stream will be started in the output. gzread() is able to read such\r\n concatented gzip streams.\r\n\r\n gzflush should be called only when strictly necessary because it will\r\n degrade compression if called too often.\r\n*/\r\n\r\n/*\r\nZEXTERN z_off_t ZEXPORT gzseek OF((gzFile file,\r\n z_off_t offset, int whence));\r\n\r\n Sets the starting position for the next gzread or gzwrite on the given\r\n compressed file. The offset represents a number of bytes in the\r\n uncompressed data stream. The whence parameter is defined as in lseek(2);\r\n the value SEEK_END is not supported.\r\n\r\n If the file is opened for reading, this function is emulated but can be\r\n extremely slow. If the file is opened for writing, only forward seeks are\r\n supported; gzseek then compresses a sequence of zeroes up to the new\r\n starting position.\r\n\r\n gzseek returns the resulting offset location as measured in bytes from\r\n the beginning of the uncompressed stream, or -1 in case of error, in\r\n particular if the file is opened for writing and the new starting position\r\n would be before the current position.\r\n*/\r\n\r\nZEXTERN int ZEXPORT gzrewind OF((gzFile file));\r\n/*\r\n Rewinds the given file. This function is supported only for reading.\r\n\r\n gzrewind(file) is equivalent to (int)gzseek(file, 0L, SEEK_SET)\r\n*/\r\n\r\n/*\r\nZEXTERN z_off_t ZEXPORT gztell OF((gzFile file));\r\n\r\n Returns the starting position for the next gzread or gzwrite on the given\r\n compressed file. This position represents a number of bytes in the\r\n uncompressed data stream, and is zero when starting, even if appending or\r\n reading a gzip stream from the middle of a file using gzdopen().\r\n\r\n gztell(file) is equivalent to gzseek(file, 0L, SEEK_CUR)\r\n*/\r\n\r\n/*\r\nZEXTERN z_off_t ZEXPORT gzoffset OF((gzFile file));\r\n\r\n Returns the current offset in the file being read or written. This offset\r\n includes the count of bytes that precede the gzip stream, for example when\r\n appending or when using gzdopen() for reading. When reading, the offset\r\n does not include as yet unused buffered input. This information can be used\r\n for a progress indicator. On error, gzoffset() returns -1.\r\n*/\r\n\r\nZEXTERN int ZEXPORT gzeof OF((gzFile file));\r\n/*\r\n Returns true (1) if the end-of-file indicator has been set while reading,\r\n false (0) otherwise. Note that the end-of-file indicator is set only if the\r\n read tried to go past the end of the input, but came up short. Therefore,\r\n just like feof(), gzeof() may return false even if there is no more data to\r\n read, in the event that the last read request was for the exact number of\r\n bytes remaining in the input file. This will happen if the input file size\r\n is an exact multiple of the buffer size.\r\n\r\n If gzeof() returns true, then the read functions will return no more data,\r\n unless the end-of-file indicator is reset by gzclearerr() and the input file\r\n has grown since the previous end of file was detected.\r\n*/\r\n\r\nZEXTERN int ZEXPORT gzdirect OF((gzFile file));\r\n/*\r\n Returns true (1) if file is being copied directly while reading, or false\r\n (0) if file is a gzip stream being decompressed. This state can change from\r\n false to true while reading the input file if the end of a gzip stream is\r\n reached, but is followed by data that is not another gzip stream.\r\n\r\n If the input file is empty, gzdirect() will return true, since the input\r\n does not contain a gzip stream.\r\n\r\n If gzdirect() is used immediately after gzopen() or gzdopen() it will\r\n cause buffers to be allocated to allow reading the file to determine if it\r\n is a gzip file. Therefore if gzbuffer() is used, it should be called before\r\n gzdirect().\r\n*/\r\n\r\nZEXTERN int ZEXPORT gzclose OF((gzFile file));\r\n/*\r\n Flushes all pending output if necessary, closes the compressed file and\r\n deallocates the (de)compression state. Note that once file is closed, you\r\n cannot call gzerror with file, since its structures have been deallocated.\r\n gzclose must not be called more than once on the same file, just as free\r\n must not be called more than once on the same allocation.\r\n\r\n gzclose will return Z_STREAM_ERROR if file is not valid, Z_ERRNO on a\r\n file operation error, or Z_OK on success.\r\n*/\r\n\r\nZEXTERN int ZEXPORT gzclose_r OF((gzFile file));\r\nZEXTERN int ZEXPORT gzclose_w OF((gzFile file));\r\n/*\r\n Same as gzclose(), but gzclose_r() is only for use when reading, and\r\n gzclose_w() is only for use when writing or appending. The advantage to\r\n using these instead of gzclose() is that they avoid linking in zlib\r\n compression or decompression code that is not used when only reading or only\r\n writing respectively. If gzclose() is used, then both compression and\r\n decompression code will be included the application when linking to a static\r\n zlib library.\r\n*/\r\n\r\nZEXTERN const char * ZEXPORT gzerror OF((gzFile file, int *errnum));\r\n/*\r\n Returns the error message for the last error which occurred on the given\r\n compressed file. errnum is set to zlib error number. If an error occurred\r\n in the file system and not in the compression library, errnum is set to\r\n Z_ERRNO and the application may consult errno to get the exact error code.\r\n\r\n The application must not modify the returned string. Future calls to\r\n this function may invalidate the previously returned string. If file is\r\n closed, then the string previously returned by gzerror will no longer be\r\n available.\r\n\r\n gzerror() should be used to distinguish errors from end-of-file for those\r\n functions above that do not distinguish those cases in their return values.\r\n*/\r\n\r\nZEXTERN void ZEXPORT gzclearerr OF((gzFile file));\r\n/*\r\n Clears the error and end-of-file flags for file. This is analogous to the\r\n clearerr() function in stdio. This is useful for continuing to read a gzip\r\n file that is being written concurrently.\r\n*/\r\n\r\n\r\n /* checksum functions */\r\n\r\n/*\r\n These functions are not related to compression but are exported\r\n anyway because they might be useful in applications using the compression\r\n library.\r\n*/\r\n\r\nZEXTERN uLong ZEXPORT adler32 OF((uLong adler, const Bytef *buf, uInt len));\r\n/*\r\n Update a running Adler-32 checksum with the bytes buf[0..len-1] and\r\n return the updated checksum. If buf is Z_NULL, this function returns the\r\n required initial value for the checksum.\r\n\r\n An Adler-32 checksum is almost as reliable as a CRC32 but can be computed\r\n much faster.\r\n\r\n Usage example:\r\n\r\n uLong adler = adler32(0L, Z_NULL, 0);\r\n\r\n while (read_buffer(buffer, length) != EOF) {\r\n adler = adler32(adler, buffer, length);\r\n }\r\n if (adler != original_adler) error();\r\n*/\r\n\r\n/*\r\nZEXTERN uLong ZEXPORT adler32_combine OF((uLong adler1, uLong adler2,\r\n z_off_t len2));\r\n\r\n Combine two Adler-32 checksums into one. For two sequences of bytes, seq1\r\n and seq2 with lengths len1 and len2, Adler-32 checksums were calculated for\r\n each, adler1 and adler2. adler32_combine() returns the Adler-32 checksum of\r\n seq1 and seq2 concatenated, requiring only adler1, adler2, and len2.\r\n*/\r\n\r\nZEXTERN uLong ZEXPORT crc32 OF((uLong crc, const Bytef *buf, uInt len));\r\n/*\r\n Update a running CRC-32 with the bytes buf[0..len-1] and return the\r\n updated CRC-32. If buf is Z_NULL, this function returns the required\r\n initial value for the for the crc. Pre- and post-conditioning (one's\r\n complement) is performed within this function so it shouldn't be done by the\r\n application.\r\n\r\n Usage example:\r\n\r\n uLong crc = crc32(0L, Z_NULL, 0);\r\n\r\n while (read_buffer(buffer, length) != EOF) {\r\n crc = crc32(crc, buffer, length);\r\n }\r\n if (crc != original_crc) error();\r\n*/\r\n\r\n/*\r\nZEXTERN uLong ZEXPORT crc32_combine OF((uLong crc1, uLong crc2, z_off_t len2));\r\n\r\n Combine two CRC-32 check values into one. For two sequences of bytes,\r\n seq1 and seq2 with lengths len1 and len2, CRC-32 check values were\r\n calculated for each, crc1 and crc2. crc32_combine() returns the CRC-32\r\n check value of seq1 and seq2 concatenated, requiring only crc1, crc2, and\r\n len2.\r\n*/\r\n\r\n\r\n /* various hacks, don't look :) */\r\n\r\n/* deflateInit and inflateInit are macros to allow checking the zlib version\r\n * and the compiler's view of z_stream:\r\n */\r\nZEXTERN int ZEXPORT deflateInit_ OF((z_streamp strm, int level,\r\n const char *version, int stream_size));\r\nZEXTERN int ZEXPORT inflateInit_ OF((z_streamp strm,\r\n const char *version, int stream_size));\r\nZEXTERN int ZEXPORT deflateInit2_ OF((z_streamp strm, int level, int method,\r\n int windowBits, int memLevel,\r\n int strategy, const char *version,\r\n int stream_size));\r\nZEXTERN int ZEXPORT inflateInit2_ OF((z_streamp strm, int windowBits,\r\n const char *version, int stream_size));\r\nZEXTERN int ZEXPORT inflateBackInit_ OF((z_streamp strm, int windowBits,\r\n unsigned char FAR *window,\r\n const char *version,\r\n int stream_size));\r\n#define deflateInit(strm, level) \\\r\n deflateInit_((strm), (level), ZLIB_VERSION, sizeof(z_stream))\r\n#define inflateInit(strm) \\\r\n inflateInit_((strm), ZLIB_VERSION, sizeof(z_stream))\r\n#define deflateInit2(strm, level, method, windowBits, memLevel, strategy) \\\r\n deflateInit2_((strm),(level),(method),(windowBits),(memLevel),\\\r\n (strategy), ZLIB_VERSION, sizeof(z_stream))\r\n#define inflateInit2(strm, windowBits) \\\r\n inflateInit2_((strm), (windowBits), ZLIB_VERSION, sizeof(z_stream))\r\n#define inflateBackInit(strm, windowBits, window) \\\r\n inflateBackInit_((strm), (windowBits), (window), \\\r\n ZLIB_VERSION, sizeof(z_stream))\r\n\r\n/* provide 64-bit offset functions if _LARGEFILE64_SOURCE defined, and/or\r\n * change the regular functions to 64 bits if _FILE_OFFSET_BITS is 64 (if\r\n * both are true, the application gets the *64 functions, and the regular\r\n * functions are changed to 64 bits) -- in case these are set on systems\r\n * without large file support, _LFS64_LARGEFILE must also be true\r\n */\r\n#if defined(_LARGEFILE64_SOURCE) && _LFS64_LARGEFILE-0\r\n ZEXTERN gzFile ZEXPORT gzopen64 OF((const char *, const char *));\r\n ZEXTERN z_off64_t ZEXPORT gzseek64 OF((gzFile, z_off64_t, int));\r\n ZEXTERN z_off64_t ZEXPORT gztell64 OF((gzFile));\r\n ZEXTERN z_off64_t ZEXPORT gzoffset64 OF((gzFile));\r\n ZEXTERN uLong ZEXPORT adler32_combine64 OF((uLong, uLong, z_off64_t));\r\n ZEXTERN uLong ZEXPORT crc32_combine64 OF((uLong, uLong, z_off64_t));\r\n#endif\r\n\r\n#if !defined(ZLIB_INTERNAL) && _FILE_OFFSET_BITS-0 == 64 && _LFS64_LARGEFILE-0\r\n# define gzopen gzopen64\r\n# define gzseek gzseek64\r\n# define gztell gztell64\r\n# define gzoffset gzoffset64\r\n# define adler32_combine adler32_combine64\r\n# define crc32_combine crc32_combine64\r\n# ifdef _LARGEFILE64_SOURCE\r\n ZEXTERN gzFile ZEXPORT gzopen64 OF((const char *, const char *));\r\n ZEXTERN z_off_t ZEXPORT gzseek64 OF((gzFile, z_off_t, int));\r\n ZEXTERN z_off_t ZEXPORT gztell64 OF((gzFile));\r\n ZEXTERN z_off_t ZEXPORT gzoffset64 OF((gzFile));\r\n ZEXTERN uLong ZEXPORT adler32_combine64 OF((uLong, uLong, z_off_t));\r\n ZEXTERN uLong ZEXPORT crc32_combine64 OF((uLong, uLong, z_off_t));\r\n# endif\r\n#else\r\n ZEXTERN gzFile ZEXPORT gzopen OF((const char *, const char *));\r\n ZEXTERN z_off_t ZEXPORT gzseek OF((gzFile, z_off_t, int));\r\n ZEXTERN z_off_t ZEXPORT gztell OF((gzFile));\r\n ZEXTERN z_off_t ZEXPORT gzoffset OF((gzFile));\r\n ZEXTERN uLong ZEXPORT adler32_combine OF((uLong, uLong, z_off_t));\r\n ZEXTERN uLong ZEXPORT crc32_combine OF((uLong, uLong, z_off_t));\r\n#endif\r\n\r\n/* hack for buggy compilers */\r\n#if !defined(ZUTIL_H) && !defined(NO_DUMMY_DECL)\r\n struct internal_state {int dummy;};\r\n#endif\r\n\r\n/* undocumented functions */\r\nZEXTERN const char * ZEXPORT zError OF((int));\r\nZEXTERN int ZEXPORT inflateSyncPoint OF((z_streamp));\r\nZEXTERN const uLongf * ZEXPORT get_crc_table OF((void));\r\nZEXTERN int ZEXPORT inflateUndermine OF((z_streamp, int));\r\n\r\n#ifdef __cplusplus\r\n}\r\n#endif\r\n\r\n#endif /* ZLIB_H */\r\n" }, { "path": "External/Jedi/Jcl/source/common/zlibh.pas", "content": "{**************************************************************************************************}\r\n{ }\r\n{ Project JEDI Code Library (JCL) }\r\n{ }\r\n{ zlib.h -- interface of the 'zlib' general purpose compression library }\r\n{ version 1.2.1, November 17th, 2003 }\r\n{ }\r\n{ Copyright (C) 1995-2003 Jean-loup Gailly and Mark Adler }\r\n{ }\r\n{ This software is provided 'as-is', without any express or implied warranty. In no event will }\r\n{ the authors be held liable for any damages arising from the use of this software. }\r\n{ }\r\n{ Permission is granted to anyone to use this software for any purpose, including commercial }\r\n{ applications, and to alter it and redistribute it freely, subject to the following restrictions: }\r\n{ }\r\n{ 1. The origin of this software must not be misrepresented; you must not claim that you wrote the }\r\n{ original software. If you use this software in a product, an acknowledgment in the product }\r\n{ documentation would be appreciated but is not required. }\r\n{ 2. Altered source versions must be plainly marked as such, and must not be misrepresented as }\r\n{ being the original software. }\r\n{ 3. This notice may not be removed or altered from any source distribution. }\r\n{ }\r\n{ Jean-loup Gailly Mark Adler }\r\n{ jloup@gzip.org madler@alumni.caltech.edu }\r\n{ }\r\n{ The data format used by the zlib library is described by RFCs (Request for }\r\n{ Comments) 1950 to 1952 in the files http://www.ietf.org/rfc/rfc1950.txt }\r\n{ (zlib format), rfc1951.txt (deflate format) and rfc1952.txt (gzip format). }\r\n{ }\r\n{**************************************************************************************************}\r\n{ }\r\n{ Last modified: $Date:: 2012-08-27 20:50:24 +0200 (lun. 27 août 2012) $ }\r\n{ Revision: $Rev:: 3845 $ }\r\n{ Author: $Author:: outchy $ }\r\n{ }\r\n{**************************************************************************************************}\r\n\r\nunit zlibh;\r\n\r\n{$I jcl.inc}\r\n\r\n{$IFDEF ZLIB_LINKDLL}\r\n{$HPPEMIT '#define ZLIB_DLL'}\r\n{$ELSE ~ZLIB_LINKDLL}\r\n{$HPPEMIT '#define ZEXPORT __fastcall'}\r\n{$ENDIF ~ZLIB_LINKDLL}\r\n\r\n{$IFDEF ZEXPORT_CDECL}\r\n{$HPPEMIT '#define ZEXPORT __cdecl'}\r\n{$ENDIF ZEXPORT_CDECL}\r\n\r\n{$HPPEMIT '#define ZEXPORTVA __cdecl'}\r\n\r\n{$HPPEMIT '#define __MACTYPES__'}\r\n{$IFDEF COMPILER10_UP}\r\n{$HPPEMIT '#include '}\r\n{$ELSE ~COMPILER10_UP}\r\n{$HPPEMIT '#include '}\r\n{$ENDIF ~COMPILER10_UP}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF MSWINDOWS}\r\n Windows,\r\n {$ENDIF MSWINDOWS}\r\n {$IFDEF HAS_UNIT_LIBC}\r\n Libc,\r\n {$ENDIF HAS_UNIT_LIBC}\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n JclBase,\r\n JclSysUtils;\r\n\r\n//DOM-IGNORE-BEGIN\r\n\r\n{$IFNDEF ZLIB_RTL}\r\n\r\n{$IFNDEF FPC}\r\ntype\r\n {$IFDEF UNIX}\r\n uLong = LongWord;\r\n {$EXTERNALSYM uLong}\r\n uInt = Cardinal;\r\n {$EXTERNALSYM uInt}\r\n {$ENDIF UNIX}\r\n uShort = Word;\r\n {$EXTERNALSYM uShort}\r\n size_t = Longint;\r\n {$EXTERNALSYM size_t}\r\n{$ENDIF ~FPC}\r\n\r\n//-----------------------------------------------------------------------------\r\n// START of the contents of the converted ZCONF.H\r\n//-----------------------------------------------------------------------------\r\n{* zconf.h -- configuration of the zlib compression library\r\n * Copyright (C) 1995-2003 Jean-loup Gailly.\r\n * For conditions of distribution and use, see copyright notice in zlib.h\r\n\r\n * If you *really* need a unique prefix for all types and library functions,\r\n * compile with -DZ_PREFIX. The \"standard\" zlib should be compiled without it.\r\n *}\r\n\r\ntype\r\n {$EXTERNALSYM Bytef}\r\n Bytef = Byte;\r\n {$EXTERNALSYM PBytef}\r\n PBytef = ^Bytef;\r\n {$EXTERNALSYM UnsignedInt}\r\n UnsignedInt = LongWord;\r\n {$EXTERNALSYM uLongf}\r\n uLongf = ULONG;\r\n {$EXTERNALSYM PuLongf}\r\n PuLongf = ^uLongf;\r\n\r\n{* Maximum value for windowBits in deflateInit2 and inflateInit2.\r\n * WARNING: reducing MAX_WBITS makes minigzip unable to extract .gz files\r\n * created by gzip. (Files created by minigzip can still be extracted by\r\n * gzip.)\r\n *}\r\n\r\nconst\r\n {$EXTERNALSYM MAX_WBITS}\r\n MAX_WBITS = 15; // 32K LZ77 window\r\n\r\n{* The memory requirements for deflate are (in bytes):\r\n (1 << (windowBits+2)) + (1 << (memLevel+9))\r\n that is: 128K for windowBits=15 + 128K for memLevel = 8 (default values)\r\n plus a few kilobytes for small objects. For example, if you want to reduce\r\n the default memory requirements from 256K to 128K, compile with\r\n make CFLAGS=\"-O -DMAX_WBITS=14 -DMAX_MEM_LEVEL=7\"\r\n Of course this will generally degrade compression (there's no free lunch).\r\n\r\n The memory requirements for inflate are (in bytes) 1 << windowBits\r\n that is, 32K for windowBits=15 (default value) plus a few kilobytes\r\n for small objects.\r\n*}\r\n\r\n {* Type declarations *}\r\n\r\n{* The following definitions for FAR are needed only for MSDOS mixed\r\n * model programming (small or medium model with some far allocations).\r\n * This was tested only with MSC; for other MSDOS compilers you may have\r\n * to define NO_MEMCPY in zutil.h. If you don't need the mixed model,\r\n * just define FAR to be empty.\r\n *}\r\n\r\n{* If building or using zlib with the WINAPI/WINAPIV calling convention,\r\n * define ZLIB_WINAPI.\r\n * Caution: the standard ZLIB1.DLL is NOT compiled using ZLIB_WINAPI.\r\n *}\r\n\r\n{ $HPPEMIT '#define ZEXPORT __stdcall'} // OS: CHECKTHIS\r\n{ $HPPEMIT '#define ZEXPORTVA __cdecl'} // OS: CHECKTHIS\r\n\r\n// type\r\n// uInt = UINT; --> already defined in Windows.pas /* 16 bits or more\r\n// uLong = ULONG; --> already defined in Windows.pas /* 32 bits or more\r\n\r\ntype\r\n {$EXTERNALSYM voidpc}\r\n voidpc = Pointer;\r\n {$EXTERNALSYM voidpf}\r\n voidpf = Pointer;\r\n {$EXTERNALSYM voidp}\r\n voidp = Pointer;\r\n {$EXTERNALSYM z_off_t}\r\n z_off_t = LongInt;\r\n\r\nconst\r\n {$EXTERNALSYM SEEK_SET}\r\n SEEK_SET = 0; // Seek from beginning of file.\r\n {$EXTERNALSYM SEEK_CUR}\r\n SEEK_CUR = 1; // Seek from current position.\r\n {$EXTERNALSYM SEEK_END}\r\n SEEK_END = 2; // Set file pointer to EOF plus \"offset\" \r\n\r\n//-----------------------------------------------------------------------------\r\n// END of the contents of the converted ZCONF.H\r\n//-----------------------------------------------------------------------------\r\n\r\nconst\r\n {$EXTERNALSYM ZLIB_VERSION}\r\n ZLIB_VERSION = '1.2.7';\r\n {$EXTERNALSYM ZLIB_VERNUM}\r\n ZLIB_VERNUM = $1250;\r\n {$EXTERNALSYM ZLIB_VER_MAJOR}\r\n ZLIB_VER_MAJOR = 1;\r\n {$EXTERNALSYM ZLIB_VER_MINOR}\r\n ZLIB_VER_MINOR = 2;\r\n {$EXTERNALSYM ZLIB_VER_REVISION}\r\n ZLIB_VER_REVISION = 7;\r\n {$EXTERNALSYM ZLIB_VER_SUBREVISION}\r\n ZLIB_VER_SUBREVISION = 0;\r\n\r\n{*\r\n The 'zlib' compression library provides in-memory compression and\r\n decompression functions, including integrity checks of the uncompressed\r\n data. This version of the library supports only one compression method\r\n (deflation) but other algorithms will be added later and will have the same\r\n stream interface.\r\n\r\n Compression can be done in a single step if the buffers are large\r\n enough (for example if an input file is mmap'ed), or can be done by\r\n repeated calls of the compression function. In the latter case, the\r\n application must provide more input and/or consume the output\r\n (providing more output space) before each call.\r\n\r\n The compressed data format used by the in-memory functions is the zlib\r\n format, which is a zlib wrapper documented in RFC 1950, wrapped around a\r\n deflate stream, which is itself documented in RFC 1951.\r\n\r\n The library also supports reading and writing files in gzip (.gz) format\r\n with an interface similar to that of stdio using the functions that start\r\n with \"gz\". The gzip format is different from the zlib format. gzip is a\r\n gzip wrapper, documented in RFC 1952, wrapped around a deflate stream.\r\n\r\n The zlib format was designed to be compact and fast for use in memory\r\n and on communications channels. The gzip format was designed for single-\r\n file compression on file systems, has a larger header than zlib to maintain\r\n directory information, and uses a different, slower check method than zlib.\r\n\r\n This library does not provide any functions to write gzip files in memory.\r\n However such functions could be easily written using zlib's deflate function,\r\n the documentation in the gzip RFC, and the examples in gzio.c.\r\n\r\n The library does not install any signal handler. The decoder checks\r\n the consistency of the compressed data, so the library should never\r\n crash even in case of corrupted input.\r\n*}\r\n\r\ntype\r\n {$EXTERNALSYM alloc_func}\r\n alloc_func = function(opaque:voidpf; items:uInt; size:uInt):voidpf;\r\n {$IFDEF ZLIB_EXPORT_CDECL} cdecl; {$ENDIF ZLIB_EXPORT_CDECL}\r\n {$EXTERNALSYM free_func}\r\n free_func = procedure(opaque:voidpf; address:voidpf);\r\n {$IFDEF ZLIB_EXPORT_CDECL} cdecl; {$ENDIF ZLIB_EXPORT_CDECL}\r\n {$EXTERNALSYM TFNAllocFunc}\r\n TFNAllocFunc = alloc_func;\r\n {$EXTERNALSYM TFNFreeFunc}\r\n TFNFreeFunc = free_func;\r\n\r\ntype\r\n {$EXTERNALSYM internal_state}\r\n internal_state = packed record end;\r\n {$EXTERNALSYM TInternalState}\r\n TInternalState = internal_state; // backward compatibility\r\n {$EXTERNALSYM PInternalState}\r\n PInternalState = ^internal_state; // backward compatibility\r\n\r\ntype\r\n {$EXTERNALSYM z_stream_s}\r\n z_stream_s = record\r\n next_in: PBytef; // next input byte\r\n avail_in: uInt; // number of bytes available at next_in\r\n total_in: uLong; // total nb of input bytes read so far\r\n\r\n next_out: PBytef; // next output byte should be put there\r\n avail_out:uInt; // remaining free space at next_out\r\n total_out:uLong; // total nb of bytes output so far\r\n\r\n msg: PAnsiChar; // last error message, NULL if no error\r\n state:PInternalState; // not visible by applications\r\n\r\n zalloc: TFNAllocFunc;// used to allocate the internal state\r\n zfree: TFNFreeFunc; // used to free the internal state\r\n opaque: voidpf; // private data object passed to zalloc and zfree\r\n\r\n data_type: Integer; // best guess about the data type: ascii or binary\r\n adler: uLong; // adler32 value of the uncompressed data\r\n reserved: uLong; // reserved for future use\r\n end;\r\n {$IFDEF COMPILER10_UP}\r\n (*$HPPEMIT 'namespace Zlibh {'*)\r\n (*$HPPEMIT 'typedef Zlib::TZStreamRec z_stream_s;'*)\r\n (*$HPPEMIT '}'*)\r\n {$ENDIF COMPILER10_UP}\r\n\r\n {$EXTERNALSYM z_stream}\r\n z_stream = z_stream_s;\r\n {$EXTERNALSYM z_streamp}\r\n z_streamp = ^z_stream_s;\r\n\r\n {$EXTERNALSYM TZStreamRec}\r\n TZStreamRec = z_stream_s;\r\n {$EXTERNALSYM PZStreamRec}\r\n PZStreamRec = ^z_stream_s;\r\n\r\n{*\r\n The application must update next_in and avail_in when avail_in has\r\n dropped to zero. It must update next_out and avail_out when avail_out\r\n has dropped to zero. The application must initialize zalloc, zfree and\r\n opaque before calling the init function. All other fields are set by the\r\n compression library and must not be updated by the application.\r\n\r\n The opaque value provided by the application will be passed as the first\r\n parameter for calls of zalloc and zfree. This can be useful for custom\r\n memory management. The compression library attaches no meaning to the\r\n opaque value.\r\n\r\n zalloc must return Z_NULL if there is not enough memory for the object.\r\n If zlib is used in a multi-threaded application, zalloc and zfree must be\r\n thread safe.\r\n\r\n On 16-bit systems, the functions zalloc and zfree must be able to allocate\r\n exactly 65536 bytes, but will not be required to allocate more than this\r\n if the symbol MAXSEG_64K is defined (see zconf.h). WARNING: On MSDOS,\r\n pointers returned by zalloc for objects of exactly 65536 bytes *must*\r\n have their offset normalized to zero. The default allocation function\r\n provided by this library ensures this (see zutil.c). To reduce memory\r\n requirements and avoid any allocation of 64K objects, at the expense of\r\n compression ratio, compile the library with -DMAX_WBITS=14 (see zconf.h).\r\n\r\n The fields total_in and total_out can be used for statistics or\r\n progress reports. After compression, total_in holds the total size of\r\n the uncompressed data and may be saved for use in the decompressor\r\n (particularly if the decompressor wants to decompress everything in\r\n a single step).\r\n*}\r\n\r\n {* constants *}\r\n\r\nconst\r\n {$EXTERNALSYM Z_NO_FLUSH}\r\n Z_NO_FLUSH = 0;\r\n {$EXTERNALSYM Z_PARTIAL_FLUSH}\r\n Z_PARTIAL_FLUSH = 1; // will be removed, use Z_SYNC_FLUSH instead\r\n {$EXTERNALSYM Z_SYNC_FLUSH}\r\n Z_SYNC_FLUSH = 2;\r\n {$EXTERNALSYM Z_FULL_FLUSH}\r\n Z_FULL_FLUSH = 3;\r\n {$EXTERNALSYM Z_FINISH}\r\n Z_FINISH = 4;\r\n {$EXTERNALSYM Z_BLOCK}\r\n Z_BLOCK = 5;\r\n {$EXTERNALSYM Z_TREES}\r\n Z_TREES = 6;\r\n\r\n{* Allowed flush values; see deflate() and inflate() below for details *}\r\n\r\n {$EXTERNALSYM Z_OK}\r\n Z_OK = 0;\r\n {$EXTERNALSYM Z_STREAM_END}\r\n Z_STREAM_END = 1;\r\n {$EXTERNALSYM Z_NEED_DICT}\r\n Z_NEED_DICT = 2;\r\n {$EXTERNALSYM Z_ERRNO}\r\n Z_ERRNO = -1;\r\n {$EXTERNALSYM Z_STREAM_ERROR}\r\n Z_STREAM_ERROR = -2;\r\n {$EXTERNALSYM Z_DATA_ERROR}\r\n Z_DATA_ERROR = -3;\r\n {$EXTERNALSYM Z_MEM_ERROR}\r\n Z_MEM_ERROR = -4;\r\n {$EXTERNALSYM Z_BUF_ERROR}\r\n Z_BUF_ERROR = -5;\r\n {$EXTERNALSYM Z_VERSION_ERROR}\r\n Z_VERSION_ERROR = -6;\r\n{* Return codes for the compression/decompression functions. Negative\r\n * values are errors, positive values are used for special but normal events.\r\n *}\r\n\r\n {$EXTERNALSYM Z_NO_COMPRESSION}\r\n Z_NO_COMPRESSION = 0;\r\n {$EXTERNALSYM Z_BEST_SPEED}\r\n Z_BEST_SPEED = 1;\r\n {$EXTERNALSYM Z_BEST_COMPRESSION}\r\n Z_BEST_COMPRESSION = 9;\r\n {$EXTERNALSYM Z_DEFAULT_COMPRESSION}\r\n Z_DEFAULT_COMPRESSION = -1;\r\n\r\n{* compression levels *}\r\n\r\n {$EXTERNALSYM Z_FILTERED}\r\n Z_FILTERED = 1;\r\n {$EXTERNALSYM Z_HUFFMAN_ONLY}\r\n Z_HUFFMAN_ONLY = 2;\r\n {$EXTERNALSYM Z_RLE}\r\n Z_RLE = 3;\r\n {$EXTERNALSYM Z_FIXED}\r\n Z_FIXED = 4;\r\n {$EXTERNALSYM Z_DEFAULT_STRATEGY}\r\n Z_DEFAULT_STRATEGY = 0;\r\n{* compression strategy; see deflateInit2() below for details *}\r\n\r\n {$EXTERNALSYM Z_BINARY}\r\n Z_BINARY = 0;\r\n {$EXTERNALSYM Z_TEXT}\r\n Z_TEXT = 1;\r\n {$EXTERNALSYM Z_ASCII}\r\n Z_ASCII = Z_TEXT;\r\n {$EXTERNALSYM Z_UNKNOWN}\r\n Z_UNKNOWN = 2;\r\n{* Possible values of the data_type field (though see inflate()) *}\r\n\r\n {$EXTERNALSYM Z_DEFLATED}\r\n Z_DEFLATED = 8;\r\n{* The deflate compression method (the only one supported in this version) *}\r\n\r\n {$EXTERNALSYM Z_NULL}\r\n Z_NULL = 0; {* for initializing zalloc, zfree, opaque *}\r\n\r\n {* basic functions *}\r\n\r\n{$IFDEF ZLIB_LINKONREQUEST}\r\n\r\ntype\r\n {$EXTERNALSYM TzlibVersion}\r\n TzlibVersion = function (): PAnsiChar;\r\n {$IFDEF ZLIB_EXPORT_CDECL} cdecl; {$ENDIF ZLIB_EXPORT_CDECL}\r\nvar\r\n {$EXTERNALSYM zlibVersion}\r\n zlibVersion: TzlibVersion = nil;\r\n\r\n{$ELSE ~ZLIB_LINKONREQUEST}\r\n\r\n{$EXTERNALSYM zlibVersion}\r\nfunction zlibVersion(): PAnsiChar;\r\n {$IFDEF ZLIB_EXPORT_CDECL} cdecl; {$ENDIF ZLIB_EXPORT_CDECL}\r\n\r\n{$ENDIF ~ZLIB_LINKONREQUEST}\r\n\r\n{* The application can compare zlibVersion and ZLIB_VERSION for consistency.\r\n If the first character differs, the library code actually used is\r\n not compatible with the zlib.h header file used by the application.\r\n This check is automatically made by deflateInit and inflateInit.\r\n *}\r\n\r\n{$IFDEF ZLIB_LINKONREQUEST}\r\n\r\ntype\r\n {$EXTERNALSYM TdeflateInit_}\r\n TdeflateInit_ = function (var strm:z_stream;\r\n level: Integer;\r\n {const} version: PAnsiChar;\r\n stream_size: Integer): Integer;\r\n {$IFDEF ZLIB_EXPORT_CDECL} cdecl; {$ENDIF ZLIB_EXPORT_CDECL}\r\nvar\r\n {$EXTERNALSYM deflateInit_}\r\n deflateInit_: TdeflateInit_ = nil;\r\n\r\n{$ELSE ~ZLIB_LINKONREQUEST}\r\n\r\n{$EXTERNALSYM deflateInit_}\r\nfunction deflateInit_(var strm:z_stream;\r\n level: Integer;\r\n {const} version: PAnsiChar;\r\n stream_size: Integer): Integer;\r\n {$IFDEF ZLIB_EXPORT_CDECL} cdecl; {$ENDIF ZLIB_EXPORT_CDECL}\r\n\r\n{$ENDIF ~ZLIB_LINKONREQUEST}\r\n\r\n{$EXTERNALSYM deflateInit}\r\nfunction deflateInit(var strm: TZStreamRec; level: Integer): Integer; // macro\r\n{*\r\n Initializes the internal stream state for compression. The fields\r\n zalloc, zfree and opaque must be initialized before by the caller.\r\n If zalloc and zfree are set to Z_NULL, deflateInit updates them to\r\n use default allocation functions.\r\n\r\n The compression level must be Z_DEFAULT_COMPRESSION, or between 0 and 9:\r\n 1 gives best speed, 9 gives best compression, 0 gives no compression at\r\n all (the input data is simply copied a block at a time).\r\n Z_DEFAULT_COMPRESSION requests a default compromise between speed and\r\n compression (currently equivalent to level 6).\r\n\r\n deflateInit returns Z_OK if success, Z_MEM_ERROR if there was not\r\n enough memory, Z_STREAM_ERROR if level is not a valid compression level,\r\n Z_VERSION_ERROR if the zlib library version (zlib_version) is incompatible\r\n with the version assumed by the caller (ZLIB_VERSION).\r\n msg is set to null if there is no error message. deflateInit does not\r\n perform any compression: this will be done by deflate().\r\n*}\r\n\r\n{$IFDEF ZLIB_LINKONREQUEST}\r\n\r\ntype\r\n {$EXTERNALSYM Tdeflate}\r\n Tdeflate = function (var strm: TZStreamRec; flush: Integer): Integer;\r\n {$IFDEF ZLIB_EXPORT_CDECL} cdecl; {$ENDIF ZLIB_EXPORT_CDECL}\r\nvar\r\n {$EXTERNALSYM deflate}\r\n deflate: Tdeflate = nil;\r\n\r\n{$ELSE ~ZLIB_LINKONREQUEST}\r\n\r\n{$EXTERNALSYM deflate}\r\nfunction deflate(var strm: TZStreamRec; flush: Integer): Integer;\r\n {$IFDEF ZLIB_EXPORT_CDECL} cdecl; {$ENDIF ZLIB_EXPORT_CDECL}\r\n\r\n{$ENDIF ~ZLIB_LINKONREQUEST}\r\n\r\n{*\r\n deflate compresses as much data as possible, and stops when the input\r\n buffer becomes empty or the output buffer becomes full. It may introduce some\r\n output latency (reading input without producing any output) except when\r\n forced to flush.\r\n\r\n The detailed semantics are as follows. deflate performs one or both of the\r\n following actions:\r\n\r\n - Compress more input starting at next_in and update next_in and avail_in\r\n accordingly. If not all input can be processed (because there is not\r\n enough room in the output buffer), next_in and avail_in are updated and\r\n processing will resume at this point for the next call of deflate().\r\n\r\n - Provide more output starting at next_out and update next_out and avail_out\r\n accordingly. This action is forced if the parameter flush is non zero.\r\n Forcing flush frequently degrades the compression ratio, so this parameter\r\n should be set only when necessary (in interactive applications).\r\n Some output may be provided even if flush is not set.\r\n\r\n Before the call of deflate(), the application should ensure that at least\r\n one of the actions is possible, by providing more input and/or consuming\r\n more output, and updating avail_in or avail_out accordingly; avail_out\r\n should never be zero before the call. The application can consume the\r\n compressed output when it wants, for example when the output buffer is full\r\n (avail_out == 0), or after each call of deflate(). If deflate returns Z_OK\r\n and with zero avail_out, it must be called again after making room in the\r\n output buffer because there might be more output pending.\r\n\r\n If the parameter flush is set to Z_SYNC_FLUSH, all pending output is\r\n flushed to the output buffer and the output is aligned on a byte boundary, so\r\n that the decompressor can get all input data available so far. (In particular\r\n avail_in is zero after the call if enough output space has been provided\r\n before the call.) Flushing may degrade compression for some compression\r\n algorithms and so it should be used only when necessary.\r\n\r\n If flush is set to Z_FULL_FLUSH, all output is flushed as with\r\n Z_SYNC_FLUSH, and the compression state is reset so that decompression can\r\n restart from this point if previous compressed data has been damaged or if\r\n random access is desired. Using Z_FULL_FLUSH too often can seriously degrade\r\n the compression.\r\n\r\n If deflate returns with avail_out == 0, this function must be called again\r\n with the same value of the flush parameter and more output space (updated\r\n avail_out), until the flush is complete (deflate returns with non-zero\r\n avail_out). In the case of a Z_FULL_FLUSH or Z_SYNC_FLUSH, make sure that\r\n avail_out is greater than six to avoid repeated flush markers due to\r\n avail_out == 0 on return.\r\n\r\n If the parameter flush is set to Z_FINISH, pending input is processed,\r\n pending output is flushed and deflate returns with Z_STREAM_END if there\r\n was enough output space; if deflate returns with Z_OK, this function must be\r\n called again with Z_FINISH and more output space (updated avail_out) but no\r\n more input data, until it returns with Z_STREAM_END or an error. After\r\n deflate has returned Z_STREAM_END, the only possible operations on the\r\n stream are deflateReset or deflateEnd.\r\n\r\n Z_FINISH can be used immediately after deflateInit if all the compression\r\n is to be done in a single step. In this case, avail_out must be at least\r\n the value returned by deflateBound (see below). If deflate does not return\r\n Z_STREAM_END, then it must be called again as described above.\r\n\r\n deflate() sets strm->adler to the adler32 checksum of all input read\r\n so far (that is, total_in bytes).\r\n\r\n deflate() may update data_type if it can make a good guess about\r\n the input data type (Z_ASCII or Z_BINARY). In doubt, the data is considered\r\n binary. This field is only for information purposes and does not affect\r\n the compression algorithm in any manner.\r\n\r\n deflate() returns Z_OK if some progress has been made (more input\r\n processed or more output produced), Z_STREAM_END if all input has been\r\n consumed and all output has been produced (only when flush is set to\r\n Z_FINISH), Z_STREAM_ERROR if the stream state was inconsistent (for example\r\n if next_in or next_out was NULL), Z_BUF_ERROR if no progress is possible\r\n (for example avail_in or avail_out was zero). Note that Z_BUF_ERROR is not\r\n fatal, and deflate() can be called again with more input and more output\r\n space to continue compressing.\r\n*}\r\n\r\n{$IFDEF ZLIB_LINKONREQUEST}\r\n\r\ntype\r\n {$EXTERNALSYM TdeflateEnd}\r\n TdeflateEnd = function (var strm: TZStreamRec): Integer;\r\n {$IFDEF ZLIB_EXPORT_CDECL} cdecl; {$ENDIF ZLIB_EXPORT_CDECL}\r\nvar\r\n {$EXTERNALSYM deflateEnd}\r\n deflateEnd: TdeflateEnd = nil;\r\n\r\n{$ELSE ~ZLIB_LINKONREQUEST}\r\n\r\n{$EXTERNALSYM deflateEnd}\r\nfunction deflateEnd(var strm: TZStreamRec): Integer;\r\n {$IFDEF ZLIB_EXPORT_CDECL} cdecl; {$ENDIF ZLIB_EXPORT_CDECL}\r\n\r\n{$ENDIF ~ZLIB_LINKONREQUEST}\r\n\r\n{*\r\n All dynamically allocated data structures for this stream are freed.\r\n This function discards any unprocessed input and does not flush any\r\n pending output.\r\n\r\n deflateEnd returns Z_OK if success, Z_STREAM_ERROR if the\r\n stream state was inconsistent, Z_DATA_ERROR if the stream was freed\r\n prematurely (some input or output was discarded). In the error case,\r\n msg may be set but then points to a static string (which must not be\r\n deallocated).\r\n*}\r\n\r\n{$IFDEF ZLIB_LINKONREQUEST}\r\n\r\ntype\r\n {$EXTERNALSYM TinflateInit_}\r\n TinflateInit_ = function (var strm:z_stream;\r\n {const} version: PAnsiChar;\r\n stream_size: Integer): Integer;\r\n {$IFDEF ZLIB_EXPORT_CDECL} cdecl; {$ENDIF ZLIB_EXPORT_CDECL}\r\nvar\r\n {$EXTERNALSYM inflateInit_}\r\n inflateInit_: TinflateInit_ = nil;\r\n\r\n{$ELSE ~ZLIB_LINKONREQUEST}\r\n\r\n{$EXTERNALSYM inflateInit_}\r\nfunction inflateInit_(var strm:z_stream;\r\n {const} version: PAnsiChar;\r\n stream_size: Integer): Integer;\r\n {$IFDEF ZLIB_EXPORT_CDECL} cdecl; {$ENDIF ZLIB_EXPORT_CDECL}\r\n\r\n{$ENDIF ~ZLIB_LINKONREQUEST}\r\n\r\n{$EXTERNALSYM inflateInit}\r\nfunction inflateInit(var strm: TZStreamRec): Integer; // macro\r\n{*\r\n\r\n Initializes the internal stream state for decompression. The fields\r\n next_in, avail_in, zalloc, zfree and opaque must be initialized before by\r\n the caller. If next_in is not Z_NULL and avail_in is large enough (the exact\r\n value depends on the compression method), inflateInit determines the\r\n compression method from the zlib header and allocates all data structures\r\n accordingly; otherwise the allocation will be deferred to the first call of\r\n inflate. If zalloc and zfree are set to Z_NULL, inflateInit updates them to\r\n use default allocation functions.\r\n\r\n inflateInit returns Z_OK if success, Z_MEM_ERROR if there was not enough\r\n memory, Z_VERSION_ERROR if the zlib library version is incompatible with the\r\n version assumed by the caller. msg is set to null if there is no error\r\n message. inflateInit does not perform any decompression apart from reading\r\n the zlib header if present: this will be done by inflate(). (So next_in and\r\n avail_in may be modified, but next_out and avail_out are unchanged.)\r\n*}\r\n\r\n{$IFDEF ZLIB_LINKONREQUEST}\r\n\r\ntype\r\n {$EXTERNALSYM Tinflate}\r\n Tinflate = function (var strm: TZStreamRec; flush: Integer): Integer;\r\n {$IFDEF ZLIB_EXPORT_CDECL} cdecl; {$ENDIF ZLIB_EXPORT_CDECL}\r\nvar\r\n {$EXTERNALSYM inflate}\r\n inflate: Tinflate = nil;\r\n\r\n{$ELSE ~ZLIB_LINKONREQUEST}\r\n\r\n{$EXTERNALSYM inflate}\r\nfunction inflate(var strm: TZStreamRec; flush: Integer): Integer;\r\n {$IFDEF ZLIB_EXPORT_CDECL} cdecl; {$ENDIF ZLIB_EXPORT_CDECL}\r\n\r\n{$ENDIF ~ZLIB_LINKONREQUEST}\r\n\r\n{*\r\n inflate decompresses as much data as possible, and stops when the input\r\n buffer becomes empty or the output buffer becomes full. It may introduce\r\n some output latency (reading input without producing any output) except when\r\n forced to flush.\r\n\r\n The detailed semantics are as follows. inflate performs one or both of the\r\n following actions:\r\n\r\n - Decompress more input starting at next_in and update next_in and avail_in\r\n accordingly. If not all input can be processed (because there is not\r\n enough room in the output buffer), next_in is updated and processing\r\n will resume at this point for the next call of inflate().\r\n\r\n - Provide more output starting at next_out and update next_out and avail_out\r\n accordingly. inflate() provides as much output as possible, until there\r\n is no more input data or no more space in the output buffer (see below\r\n about the flush parameter).\r\n\r\n Before the call of inflate(), the application should ensure that at least\r\n one of the actions is possible, by providing more input and/or consuming\r\n more output, and updating the next_* and avail_* values accordingly.\r\n The application can consume the uncompressed output when it wants, for\r\n example when the output buffer is full (avail_out == 0), or after each\r\n call of inflate(). If inflate returns Z_OK and with zero avail_out, it\r\n must be called again after making room in the output buffer because there\r\n might be more output pending.\r\n\r\n The flush parameter of inflate() can be Z_NO_FLUSH, Z_SYNC_FLUSH,\r\n Z_FINISH, or Z_BLOCK. Z_SYNC_FLUSH requests that inflate() flush as much\r\n output as possible to the output buffer. Z_BLOCK requests that inflate() stop\r\n if and when it get to the next deflate block boundary. When decoding the zlib\r\n or gzip format, this will cause inflate() to return immediately after the\r\n header and before the first block. When doing a raw inflate, inflate() will\r\n go ahead and process the first block, and will return when it gets to the end\r\n of that block, or when it runs out of data.\r\n\r\n The Z_BLOCK option assists in appending to or combining deflate streams.\r\n Also to assist in this, on return inflate() will set strm->data_type to the\r\n number of unused bits in the last byte taken from strm->next_in, plus 64\r\n if inflate() is currently decoding the last block in the deflate stream,\r\n plus 128 if inflate() returned immediately after decoding an end-of-block\r\n code or decoding the complete header up to just before the first byte of the\r\n deflate stream. The end-of-block will not be indicated until all of the\r\n uncompressed data from that block has been written to strm->next_out. The\r\n number of unused bits may in general be greater than seven, except when\r\n bit 7 of data_type is set, in which case the number of unused bits will be\r\n less than eight.\r\n\r\n inflate() should normally be called until it returns Z_STREAM_END or an\r\n error. However if all decompression is to be performed in a single step\r\n (a single call of inflate), the parameter flush should be set to\r\n Z_FINISH. In this case all pending input is processed and all pending\r\n output is flushed; avail_out must be large enough to hold all the\r\n uncompressed data. (The size of the uncompressed data may have been saved\r\n by the compressor for this purpose.) The next operation on this stream must\r\n be inflateEnd to deallocate the decompression state. The use of Z_FINISH\r\n is never required, but can be used to inform inflate that a faster approach\r\n may be used for the single inflate() call.\r\n\r\n In this implementation, inflate() always flushes as much output as\r\n possible to the output buffer, and always uses the faster approach on the\r\n first call. So the only effect of the flush parameter in this implementation\r\n is on the return value of inflate(), as noted below, or when it returns early\r\n because Z_BLOCK is used.\r\n\r\n If a preset dictionary is needed after this call (see inflateSetDictionary\r\n below), inflate sets strm-adler to the adler32 checksum of the dictionary\r\n chosen by the compressor and returns Z_NEED_DICT; otherwise it sets\r\n strm->adler to the adler32 checksum of all output produced so far (that is,\r\n total_out bytes) and returns Z_OK, Z_STREAM_END or an error code as described\r\n below. At the end of the stream, inflate() checks that its computed adler32\r\n checksum is equal to that saved by the compressor and returns Z_STREAM_END\r\n only if the checksum is correct.\r\n\r\n inflate() will decompress and check either zlib-wrapped or gzip-wrapped\r\n deflate data. The header type is detected automatically. Any information\r\n contained in the gzip header is not retained, so applications that need that\r\n information should instead use raw inflate, see inflateInit2() below, or\r\n inflateBack() and perform their own processing of the gzip header and\r\n trailer.\r\n\r\n inflate() returns Z_OK if some progress has been made (more input processed\r\n or more output produced), Z_STREAM_END if the end of the compressed data has\r\n been reached and all uncompressed output has been produced, Z_NEED_DICT if a\r\n preset dictionary is needed at this point, Z_DATA_ERROR if the input data was\r\n corrupted (input stream not conforming to the zlib format or incorrect check\r\n value), Z_STREAM_ERROR if the stream structure was inconsistent (for example\r\n if next_in or next_out was NULL), Z_MEM_ERROR if there was not enough memory,\r\n Z_BUF_ERROR if no progress is possible or if there was not enough room in the\r\n output buffer when Z_FINISH is used. Note that Z_BUF_ERROR is not fatal, and\r\n inflate() can be called again with more input and more output space to\r\n continue decompressing. If Z_DATA_ERROR is returned, the application may then\r\n call inflateSync() to look for a good compression block if a partial recovery\r\n of the data is desired.\r\n*}\r\n\r\n{$IFDEF ZLIB_LINKONREQUEST}\r\n\r\ntype\r\n {$EXTERNALSYM TinflateEnd}\r\n TinflateEnd = function (var strm: TZStreamRec): Integer;\r\n {$IFDEF ZLIB_EXPORT_CDECL} cdecl; {$ENDIF ZLIB_EXPORT_CDECL}\r\nvar\r\n {$EXTERNALSYM inflateEnd}\r\n inflateEnd: TinflateEnd = nil;\r\n\r\n{$ELSE ~ZLIB_LINKONREQUEST}\r\n\r\n{$EXTERNALSYM inflateEnd}\r\nfunction inflateEnd(var strm: TZStreamRec): Integer;\r\n {$IFDEF ZLIB_EXPORT_CDECL} cdecl; {$ENDIF ZLIB_EXPORT_CDECL}\r\n\r\n{$ENDIF ~ZLIB_LINKONREQUEST}\r\n\r\n{*\r\n All dynamically allocated data structures for this stream are freed.\r\n This function discards any unprocessed input and does not flush any\r\n pending output.\r\n\r\n inflateEnd returns Z_OK if success, Z_STREAM_ERROR if the stream state\r\n was inconsistent. In the error case, msg may be set but then points to a\r\n static string (which must not be deallocated).\r\n*}\r\n\r\n {* Advanced functions *}\r\n\r\n{*\r\n The following functions are needed only in some special applications.\r\n*}\r\n\r\n{$IFDEF ZLIB_LINKONREQUEST}\r\n\r\ntype\r\n {$EXTERNALSYM TdeflateInit2_}\r\n TdeflateInit2_ = function (var strm:z_stream;\r\n level: Integer;\r\n method: Integer;\r\n windowBits: Integer;\r\n memLevel: Integer;\r\n strategy: Integer;\r\n {const} version: PAnsiChar;\r\n stream_size: Integer): Integer;\r\n {$IFDEF ZLIB_EXPORT_CDECL} cdecl; {$ENDIF ZLIB_EXPORT_CDECL}\r\nvar\r\n {$EXTERNALSYM deflateInit2_}\r\n deflateInit2_: TdeflateInit2_ = nil;\r\n\r\n{$ELSE ~ZLIB_LINKONREQUEST}\r\n\r\n{$EXTERNALSYM deflateInit2_}\r\nfunction deflateInit2_(var strm:z_stream;\r\n level: Integer;\r\n method: Integer;\r\n windowBits: Integer;\r\n memLevel: Integer;\r\n strategy: Integer;\r\n {const} version: PAnsiChar;\r\n stream_size: Integer): Integer;\r\n {$IFDEF ZLIB_EXPORT_CDECL} cdecl; {$ENDIF ZLIB_EXPORT_CDECL}\r\n\r\n{$ENDIF ~ZLIB_LINKONREQUEST}\r\n\r\n{$EXTERNALSYM deflateInit2}\r\nfunction deflateInit2(var strm: TZStreamRec;\r\n level: Integer;\r\n method: Integer;\r\n windowBits: Integer;\r\n memLevel: Integer;\r\n strategy: Integer): Integer; // macro\r\n{*\r\n This is another version of deflateInit with more compression options. The\r\n fields next_in, zalloc, zfree and opaque must be initialized before by\r\n the caller.\r\n\r\n The method parameter is the compression method. It must be Z_DEFLATED in\r\n this version of the library.\r\n\r\n The windowBits parameter is the base two logarithm of the window size\r\n (the size of the history buffer). It should be in the range 8..15 for this\r\n version of the library. Larger values of this parameter result in better\r\n compression at the expense of memory usage. The default value is 15 if\r\n deflateInit is used instead.\r\n\r\n windowBits can also be -8..-15 for raw deflate. In this case, -windowBits\r\n determines the window size. deflate() will then generate raw deflate data\r\n with no zlib header or trailer, and will not compute an adler32 check value.\r\n\r\n windowBits can also be greater than 15 for optional gzip encoding. Add\r\n 16 to windowBits to write a simple gzip header and trailer around the\r\n compressed data instead of a zlib wrapper. The gzip header will have no\r\n file name, no extra data, no comment, no modification time (set to zero),\r\n no header crc, and the operating system will be set to 255 (unknown).\r\n\r\n The memLevel parameter specifies how much memory should be allocated\r\n for the internal compression state. memLevel=1 uses minimum memory but\r\n is slow and reduces compression ratio; memLevel=9 uses maximum memory\r\n for optimal speed. The default value is 8. See zconf.h for total memory\r\n usage as a function of windowBits and memLevel.\r\n\r\n The strategy parameter is used to tune the compression algorithm. Use the\r\n value Z_DEFAULT_STRATEGY for normal data, Z_FILTERED for data produced by a\r\n filter (or predictor), Z_HUFFMAN_ONLY to force Huffman encoding only (no\r\n string match), or Z_RLE to limit match distances to one (run-length\r\n encoding). Filtered data consists mostly of small values with a somewhat\r\n random distribution. In this case, the compression algorithm is tuned to\r\n compress them better. The effect of Z_FILTERED is to force more Huffman\r\n coding and less string matching; it is somewhat intermediate between\r\n Z_DEFAULT and Z_HUFFMAN_ONLY. Z_RLE is designed to be almost as fast as\r\n Z_HUFFMAN_ONLY, but give better compression for PNG image data. The strategy\r\n parameter only affects the compression ratio but not the correctness of the\r\n compressed output even if it is not set appropriately.\r\n\r\n deflateInit2 returns Z_OK if success, Z_MEM_ERROR if there was not enough\r\n memory, Z_STREAM_ERROR if a parameter is invalid (such as an invalid\r\n method). msg is set to null if there is no error message. deflateInit2 does\r\n not perform any compression: this will be done by deflate().\r\n*}\r\n\r\n{$IFDEF ZLIB_LINKONREQUEST}\r\n\r\ntype\r\n {$EXTERNALSYM TdeflateSetDictionary}\r\n TdeflateSetDictionary = function(var strm: TZStreamRec;\r\n {const} dictionary: PBytef;\r\n dictLength:uInt): Integer;\r\n {$IFDEF ZLIB_EXPORT_CDECL} cdecl; {$ENDIF ZLIB_EXPORT_CDECL}\r\nvar\r\n {$EXTERNALSYM deflateSetDictionary}\r\n deflateSetDictionary: TdeflateSetDictionary = nil;\r\n\r\n{$ELSE ~ZLIB_LINKONREQUEST}\r\n\r\n{$EXTERNALSYM deflateSetDictionary}\r\nfunction deflateSetDictionary(var strm: TZStreamRec;\r\n {const} dictionary: PBytef;\r\n dictLength:uInt): Integer;\r\n{$IFDEF ZLIB_EXPORT_CDECL} cdecl; {$ENDIF ZLIB_EXPORT_CDECL}\r\n\r\n{$ENDIF ~ZLIB_LINKONREQUEST}\r\n\r\n{*\r\n Initializes the compression dictionary from the given byte sequence\r\n without producing any compressed output. This function must be called\r\n immediately after deflateInit, deflateInit2 or deflateReset, before any\r\n call of deflate. The compressor and decompressor must use exactly the same\r\n dictionary (see inflateSetDictionary).\r\n\r\n The dictionary should consist of strings (byte sequences) that are likely\r\n to be encountered later in the data to be compressed, with the most commonly\r\n used strings preferably put towards the end of the dictionary. Using a\r\n dictionary is most useful when the data to be compressed is short and can be\r\n predicted with good accuracy; the data can then be compressed better than\r\n with the default empty dictionary.\r\n\r\n Depending on the size of the compression data structures selected by\r\n deflateInit or deflateInit2, a part of the dictionary may in effect be\r\n discarded, for example if the dictionary is larger than the window size in\r\n deflate or deflate2. Thus the strings most likely to be useful should be\r\n put at the end of the dictionary, not at the front.\r\n\r\n Upon return of this function, strm->adler is set to the adler32 value\r\n of the dictionary; the decompressor may later use this value to determine\r\n which dictionary has been used by the compressor. (The adler32 value\r\n applies to the whole dictionary even if only a subset of the dictionary is\r\n actually used by the compressor.) If a raw deflate was requested, then the\r\n adler32 value is not computed and strm->adler is not set.\r\n\r\n deflateSetDictionary returns Z_OK if success, or Z_STREAM_ERROR if a\r\n parameter is invalid (such as NULL dictionary) or the stream state is\r\n inconsistent (for example if deflate has already been called for this stream\r\n or if the compression method is bsort). deflateSetDictionary does not\r\n perform any compression: this will be done by deflate().\r\n*}\r\n\r\n{$IFDEF ZLIB_LINKONREQUEST}\r\n\r\ntype\r\n {$EXTERNALSYM TdeflateCopy}\r\n TdeflateCopy = function (var dest: TZStreamRec;\r\n var source: TZStreamRec): Integer;\r\n {$IFDEF ZLIB_EXPORT_CDECL} cdecl; {$ENDIF ZLIB_EXPORT_CDECL}\r\nvar\r\n {$EXTERNALSYM deflateCopy}\r\n deflateCopy: TdeflateCopy = nil;\r\n\r\n{$ELSE ~ZLIB_LINKONREQUEST}\r\n\r\n{$EXTERNALSYM deflateCopy}\r\nfunction deflateCopy(var dest: TZStreamRec;\r\n var source: TZStreamRec): Integer;\r\n {$IFDEF ZLIB_EXPORT_CDECL} cdecl; {$ENDIF ZLIB_EXPORT_CDECL}\r\n\r\n{$ENDIF ~ZLIB_LINKONREQUEST}\r\n{*\r\n Sets the destination stream as a complete copy of the source stream.\r\n\r\n This function can be useful when several compression strategies will be\r\n tried, for example when there are several ways of pre-processing the input\r\n data with a filter. The streams that will be discarded should then be freed\r\n by calling deflateEnd. Note that deflateCopy duplicates the internal\r\n compression state which can be quite large, so this strategy is slow and\r\n can consume lots of memory.\r\n\r\n deflateCopy returns Z_OK if success, Z_MEM_ERROR if there was not\r\n enough memory, Z_STREAM_ERROR if the source stream state was inconsistent\r\n (such as zalloc being NULL). msg is left unchanged in both source and\r\n destination.\r\n*}\r\n\r\n{$IFDEF ZLIB_LINKONREQUEST}\r\n\r\ntype\r\n {$EXTERNALSYM TdeflateReset}\r\n TdeflateReset = function (var strm: TZStreamRec): Integer;\r\n {$IFDEF ZLIB_EXPORT_CDECL} cdecl; {$ENDIF ZLIB_EXPORT_CDECL}\r\nvar\r\n {$EXTERNALSYM deflateReset}\r\n deflateReset: TdeflateReset = nil;\r\n\r\n{$ELSE ~ZLIB_LINKONREQUEST}\r\n\r\n{$EXTERNALSYM deflateReset}\r\nfunction deflateReset(var strm: TZStreamRec): Integer;\r\n {$IFDEF ZLIB_EXPORT_CDECL} cdecl; {$ENDIF ZLIB_EXPORT_CDECL}\r\n\r\n{$ENDIF ~ZLIB_LINKONREQUEST}\r\n\r\n{*\r\n This function is equivalent to deflateEnd followed by deflateInit,\r\n but does not free and reallocate all the internal compression state.\r\n The stream will keep the same compression level and any other attributes\r\n that may have been set by deflateInit2.\r\n\r\n deflateReset returns Z_OK if success, or Z_STREAM_ERROR if the source\r\n stream state was inconsistent (such as zalloc or state being NULL).\r\n*}\r\n\r\n{$IFDEF ZLIB_LINKONREQUEST}\r\n\r\ntype\r\n {$EXTERNALSYM TdeflateParams}\r\n TdeflateParams = function (var strm: TZStreamRec;\r\n level: Integer;\r\n strategy: Integer): Integer;\r\n {$IFDEF ZLIB_EXPORT_CDECL} cdecl; {$ENDIF ZLIB_EXPORT_CDECL}\r\nvar\r\n {$EXTERNALSYM deflateParams}\r\n deflateParams: TdeflateParams = nil;\r\n\r\n{$ELSE ~ZLIB_LINKONREQUEST}\r\n\r\n{$EXTERNALSYM deflateParams}\r\nfunction deflateParams(var strm: TZStreamRec;\r\n level: Integer;\r\n strategy: Integer): Integer;\r\n {$IFDEF ZLIB_EXPORT_CDECL} cdecl; {$ENDIF ZLIB_EXPORT_CDECL}\r\n\r\n{$ENDIF ~ZLIB_LINKONREQUEST}\r\n\r\n{*\r\n Dynamically update the compression level and compression strategy. The\r\n interpretation of level and strategy is as in deflateInit2. This can be\r\n used to switch between compression and straight copy of the input data, or\r\n to switch to a different kind of input data requiring a different\r\n strategy. If the compression level is changed, the input available so far\r\n is compressed with the old level (and may be flushed); the new level will\r\n take effect only at the next call of deflate().\r\n\r\n Before the call of deflateParams, the stream state must be set as for\r\n a call of deflate(), since the currently available input may have to\r\n be compressed and flushed. In particular, strm->avail_out must be non-zero.\r\n\r\n deflateParams returns Z_OK if success, Z_STREAM_ERROR if the source\r\n stream state was inconsistent or if a parameter was invalid, Z_BUF_ERROR\r\n if strm->avail_out was zero.\r\n*}\r\n\r\n{$IFDEF ZLIB_LINKONREQUEST}\r\n\r\ntype\r\n {$EXTERNALSYM TdeflateBound}\r\n TdeflateBound = function (var strm: TZStreamRec;\r\n sourceLen:uLong):uLong;\r\n {$IFDEF ZLIB_EXPORT_CDECL} cdecl; {$ENDIF ZLIB_EXPORT_CDECL}\r\nvar\r\n {$EXTERNALSYM deflateBound}\r\n deflateBound: TdeflateBound = nil;\r\n\r\n{$ELSE ~ZLIB_LINKONREQUEST}\r\n\r\n{$EXTERNALSYM deflateBound}\r\nfunction deflateBound(var strm: TZStreamRec;\r\n sourceLen:uLong):uLong;\r\n {$IFDEF ZLIB_EXPORT_CDECL} cdecl; {$ENDIF ZLIB_EXPORT_CDECL}\r\n\r\n{$ENDIF ~ZLIB_LINKONREQUEST}\r\n\r\n{*\r\n deflateBound() returns an upper bound on the compressed size after\r\n deflation of sourceLen bytes. It must be called after deflateInit()\r\n or deflateInit2(). This would be used to allocate an output buffer\r\n for deflation in a single pass, and so would be called before deflate().\r\n*}\r\n\r\n{$IFDEF ZLIB_LINKONREQUEST}\r\n\r\ntype\r\n {$EXTERNALSYM TdeflatePending}\r\n TdeflatePending = function (var strm: TZStreamRec;\r\n pending: PCardinal;\r\n bits: PInteger): Integer;\r\n {$IFDEF ZLIB_EXPORT_CDECL} cdecl; {$ENDIF ZLIB_EXPORT_CDECL}\r\nvar\r\n {$EXTERNALSYM deflatePending}\r\n deflatePending: TdeflatePending = nil;\r\n\r\n{$ELSE ~ZLIB_LINKONREQUEST}\r\n\r\n{$EXTERNALSYM deflatePending}\r\nfunction deflatePending(var strm: TZStreamRec;\r\n pending: PCardinal;\r\n bits: PInteger): Integer;\r\n {$IFDEF ZLIB_EXPORT_CDECL} cdecl; {$ENDIF ZLIB_EXPORT_CDECL}\r\n\r\n{$ENDIF ~ZLIB_LINKONREQUEST}\r\n\r\n(*\r\n deflatePending() returns the number of bytes and bits of output that have\r\n been generated, but not yet provided in the available output. The bytes not\r\n provided would be due to the available output space having being consumed.\r\n The number of bits of output not provided are between 0 and 7, where they\r\n await more bits to join them in order to fill out a full byte. If pending\r\n or bits are Z_NULL, then those values are not set.\r\n\r\n deflatePending returns Z_OK if success, or Z_STREAM_ERROR if the source\r\n stream state was inconsistent.\r\n*)\r\n\r\n{$IFDEF ZLIB_LINKONREQUEST}\r\n\r\ntype\r\n {$EXTERNALSYM TdeflatePrime}\r\n TdeflatePrime = function (var strm: TZStreamRec;\r\n bits: Integer;\r\n value: Integer): Integer;\r\n {$IFDEF ZLIB_EXPORT_CDECL} cdecl; {$ENDIF ZLIB_EXPORT_CDECL}\r\nvar\r\n {$EXTERNALSYM deflatePrime}\r\n deflatePrime: TdeflatePrime = nil;\r\n\r\n{$ELSE ~ZLIB_LINKONREQUEST}\r\n\r\n{$EXTERNALSYM deflatePrime}\r\nfunction deflatePrime(var strm: TZStreamRec;\r\n bits: Integer;\r\n value: Integer): Integer;\r\n {$IFDEF ZLIB_EXPORT_CDECL} cdecl; {$ENDIF ZLIB_EXPORT_CDECL}\r\n\r\n{$ENDIF ~ZLIB_LINKONREQUEST}\r\n\r\n{*\r\n deflatePrime() inserts bits in the deflate output stream. The intent\r\n is that this function is used to start off the deflate output with the\r\n bits leftover from a previous deflate stream when appending to it. As such,\r\n this function can only be used for raw deflate, and must be used before the\r\n first deflate() call after a deflateInit2() or deflateReset(). bits must be\r\n less than or equal to 16, and that many of the least significant bits of\r\n value will be inserted in the output.\r\n\r\n deflatePrime returns Z_OK if success, or Z_STREAM_ERROR if the source\r\n stream state was inconsistent.\r\n*}\r\n\r\n{$IFDEF ZLIB_LINKONREQUEST}\r\n\r\ntype\r\n {$EXTERNALSYM TinflateInit2_}\r\n TinflateInit2_ = function (var strm:z_stream;\r\n windowBits: Integer;\r\n {const} version: PAnsiChar;\r\n stream_size: Integer): Integer;\r\n {$IFDEF ZLIB_EXPORT_CDECL} cdecl; {$ENDIF ZLIB_EXPORT_CDECL}\r\nvar\r\n {$EXTERNALSYM inflateInit2_}\r\n inflateInit2_: TinflateInit2_ = nil;\r\n\r\n{$ELSE ~ZLIB_LINKONREQUEST}\r\n\r\n{$EXTERNALSYM inflateInit2_}\r\nfunction inflateInit2_(var strm:z_stream;\r\n windowBits: Integer;\r\n {const} version: PAnsiChar;\r\n stream_size: Integer): Integer;\r\n {$IFDEF ZLIB_EXPORT_CDECL} cdecl; {$ENDIF ZLIB_EXPORT_CDECL}\r\n\r\n{$ENDIF ~ZLIB_LINKONREQUEST}\r\n\r\n{$EXTERNALSYM inflateInit2}\r\nfunction inflateInit2(var strm: TZStreamRec;\r\n windowBits: Integer): Integer; // macro\r\n{*\r\n This is another version of inflateInit with an extra parameter. The\r\n fields next_in, avail_in, zalloc, zfree and opaque must be initialized\r\n before by the caller.\r\n\r\n The windowBits parameter is the base two logarithm of the maximum window\r\n size (the size of the history buffer). It should be in the range 8..15 for\r\n this version of the library. The default value is 15 if inflateInit is used\r\n instead. windowBits must be greater than or equal to the windowBits value\r\n provided to deflateInit2() while compressing, or it must be equal to 15 if\r\n deflateInit2() was not used. If a compressed stream with a larger window\r\n size is given as input, inflate() will return with the error code\r\n Z_DATA_ERROR instead of trying to allocate a larger window.\r\n\r\n windowBits can also be -8..-15 for raw inflate. In this case, -windowBits\r\n determines the window size. inflate() will then process raw deflate data,\r\n not looking for a zlib or gzip header, not generating a check value, and not\r\n looking for any check values for comparison at the end of the stream. This\r\n is for use with other formats that use the deflate compressed data format\r\n such as zip. Those formats provide their own check values. If a custom\r\n format is developed using the raw deflate format for compressed data, it is\r\n recommended that a check value such as an adler32 or a crc32 be applied to\r\n the uncompressed data as is done in the zlib, gzip, and zip formats. For\r\n most applications, the zlib format should be used as is. Note that comments\r\n above on the use in deflateInit2() applies to the magnitude of windowBits.\r\n\r\n windowBits can also be greater than 15 for optional gzip decoding. Add\r\n 32 to windowBits to enable zlib and gzip decoding with automatic header\r\n detection, or add 16 to decode only the gzip format (the zlib format will\r\n return a Z_DATA_ERROR).\r\n\r\n inflateInit2 returns Z_OK if success, Z_MEM_ERROR if there was not enough\r\n memory, Z_STREAM_ERROR if a parameter is invalid (such as a negative\r\n memLevel). msg is set to null if there is no error message. inflateInit2\r\n does not perform any decompression apart from reading the zlib header if\r\n present: this will be done by inflate(). (So next_in and avail_in may be\r\n modified, but next_out and avail_out are unchanged.)\r\n*}\r\n\r\n{$IFDEF ZLIB_LINKONREQUEST}\r\n\r\ntype\r\n {$EXTERNALSYM TinflateSetDictionary}\r\n TinflateSetDictionary = function (var strm: TZStreamRec;\r\n {const} dictionary: PBytef;\r\n dictLength:uInt): Integer;\r\n {$IFDEF ZLIB_EXPORT_CDECL} cdecl; {$ENDIF ZLIB_EXPORT_CDECL}\r\nvar\r\n {$EXTERNALSYM inflateSetDictionary}\r\n inflateSetDictionary: TinflateSetDictionary = nil;\r\n\r\n{$ELSE ~ZLIB_LINKONREQUEST}\r\n\r\n{$EXTERNALSYM inflateSetDictionary}\r\nfunction inflateSetDictionary(var strm: TZStreamRec;\r\n {const} dictionary: PBytef;\r\n dictLength:uInt): Integer;\r\n {$IFDEF ZLIB_EXPORT_CDECL} cdecl; {$ENDIF ZLIB_EXPORT_CDECL}\r\n\r\n{$ENDIF ~ZLIB_LINKONREQUEST}\r\n\r\n{*\r\n Initializes the decompression dictionary from the given uncompressed byte\r\n sequence. This function must be called immediately after a call of inflate\r\n if this call returned Z_NEED_DICT. The dictionary chosen by the compressor\r\n can be determined from the adler32 value returned by this call of\r\n inflate. The compressor and decompressor must use exactly the same\r\n dictionary (see deflateSetDictionary).\r\n\r\n inflateSetDictionary returns Z_OK if success, Z_STREAM_ERROR if a\r\n parameter is invalid (such as NULL dictionary) or the stream state is\r\n inconsistent, Z_DATA_ERROR if the given dictionary doesn't match the\r\n expected one (incorrect adler32 value). inflateSetDictionary does not\r\n perform any decompression: this will be done by subsequent calls of\r\n inflate().\r\n*}\r\n\r\n{$IFDEF ZLIB_LINKONREQUEST}\r\n\r\ntype\r\n {$EXTERNALSYM TinflateSync}\r\n TinflateSync = function (var strm: TZStreamRec): Integer;\r\n {$IFDEF ZLIB_EXPORT_CDECL} cdecl; {$ENDIF ZLIB_EXPORT_CDECL}\r\nvar\r\n {$EXTERNALSYM inflateSync}\r\n inflateSync: TinflateSync = nil;\r\n\r\n{$ELSE ~ZLIB_LINKONREQUEST}\r\n\r\n{$EXTERNALSYM inflateSync}\r\nfunction inflateSync(var strm: TZStreamRec): Integer;\r\n {$IFDEF ZLIB_EXPORT_CDECL} cdecl; {$ENDIF ZLIB_EXPORT_CDECL}\r\n\r\n{$ENDIF ~ZLIB_LINKONREQUEST}\r\n\r\n{*\r\n Skips invalid compressed data until a full flush point (see above the\r\n description of deflate with Z_FULL_FLUSH) can be found, or until all\r\n available input is skipped. No output is provided.\r\n\r\n inflateSync returns Z_OK if a full flush point has been found, Z_BUF_ERROR\r\n if no more input was provided, Z_DATA_ERROR if no flush point has been found,\r\n or Z_STREAM_ERROR if the stream structure was inconsistent. In the success\r\n case, the application may save the current current value of total_in which\r\n indicates where valid compressed data was found. In the error case, the\r\n application may repeatedly call inflateSync, providing more input each time,\r\n until success or end of the input data.\r\n*}\r\n\r\n{$IFDEF ZLIB_LINKONREQUEST}\r\n\r\ntype\r\n {$EXTERNALSYM TinflateCopy}\r\n TinflateCopy = function (var dest: TZStreamRec;\r\n var source: TZStreamRec): Integer;\r\n {$IFDEF ZLIB_EXPORT_CDECL} cdecl; {$ENDIF ZLIB_EXPORT_CDECL}\r\nvar\r\n {$EXTERNALSYM inflateCopy}\r\n inflateCopy: TinflateCopy = nil;\r\n\r\n{$ELSE ~ZLIB_LINKONREQUEST}\r\n\r\n{$EXTERNALSYM inflateCopy}\r\nfunction inflateCopy(var dest: TZStreamRec;\r\n var source: TZStreamRec): Integer;\r\n {$IFDEF ZLIB_EXPORT_CDECL} cdecl; {$ENDIF ZLIB_EXPORT_CDECL}\r\n\r\n{$ENDIF ~ZLIB_LINKONREQUEST}\r\n\r\n{*\r\n Sets the destination stream as a complete copy of the source stream.\r\n\r\n This function can be useful when randomly accessing a large stream. The\r\n first pass through the stream can periodically record the inflate state,\r\n allowing restarting inflate at those points when randomly accessing the\r\n stream.\r\n\r\n inflateCopy returns Z_OK if success, Z_MEM_ERROR if there was not\r\n enough memory, Z_STREAM_ERROR if the source stream state was inconsistent\r\n (such as zalloc being NULL). msg is left unchanged in both source and\r\n destination.\r\n*}\r\n\r\n{$IFDEF ZLIB_LINKONREQUEST}\r\n\r\ntype\r\n {$EXTERNALSYM TinflateReset}\r\n TinflateReset = function (var strm: TZStreamRec): Integer;\r\n {$IFDEF ZLIB_EXPORT_CDECL} cdecl; {$ENDIF ZLIB_EXPORT_CDECL}\r\nvar\r\n {$EXTERNALSYM inflateReset}\r\n inflateReset: TinflateReset = nil;\r\n\r\n{$ELSE ~ZLIB_LINKONREQUEST}\r\n\r\n{$EXTERNALSYM inflateReset}\r\nfunction inflateReset(var strm: TZStreamRec): Integer;\r\n {$IFDEF ZLIB_EXPORT_CDECL} cdecl; {$ENDIF ZLIB_EXPORT_CDECL}\r\n\r\n{$ENDIF ~ZLIB_LINKONREQUEST}\r\n\r\n{*\r\n This function is equivalent to inflateEnd followed by inflateInit,\r\n but does not free and reallocate all the internal decompression state.\r\n The stream will keep attributes that may have been set by inflateInit2.\r\n\r\n inflateReset returns Z_OK if success, or Z_STREAM_ERROR if the source\r\n stream state was inconsistent (such as zalloc or state being NULL).\r\n*}\r\n\r\n{$IFDEF ZLIB_LINKONREQUEST}\r\n\r\ntype\r\n {$EXTERNALSYM TinflateBackInit_}\r\n TinflateBackInit_ = function (var strm:z_stream;\r\n windowBits: Integer;\r\n window: PByte;\r\n {const} version: PAnsiChar;\r\n stream_size: Integer): Integer;\r\n {$IFDEF ZLIB_EXPORT_CDECL} cdecl; {$ENDIF ZLIB_EXPORT_CDECL}\r\nvar\r\n {$EXTERNALSYM inflateBackInit_}\r\n inflateBackInit_: TinflateBackInit_ = nil;\r\n\r\n{$ELSE ~ZLIB_LINKONREQUEST}\r\n\r\n{$EXTERNALSYM inflateBackInit_}\r\nfunction inflateBackInit_(var strm:z_stream;\r\n windowBits: Integer;\r\n window: PByte;\r\n {const} version: PAnsiChar;\r\n stream_size: Integer): Integer;\r\n {$IFDEF ZLIB_EXPORT_CDECL} cdecl; {$ENDIF ZLIB_EXPORT_CDECL}\r\n\r\n{$ENDIF ~ZLIB_LINKONREQUEST}\r\n\r\n{$EXTERNALSYM inflateBackInit}\r\nfunction inflateBackInit(var strm: TZStreamRec;\r\n windowBits: Integer;\r\n window: PByte): Integer; // macro\r\n{*\r\n Initialize the internal stream state for decompression using inflateBack()\r\n calls. The fields zalloc, zfree and opaque in strm must be initialized\r\n before the call. If zalloc and zfree are Z_NULL, then the default library-\r\n derived memory allocation routines are used. windowBits is the base two\r\n logarithm of the window size, in the range 8..15. window is a caller\r\n supplied buffer of that size. Except for special applications where it is\r\n assured that deflate was used with small window sizes, windowBits must be 15\r\n and a 32K byte window must be supplied to be able to decompress general\r\n deflate streams.\r\n\r\n See inflateBack() for the usage of these routines.\r\n\r\n inflateBackInit will return Z_OK on success, Z_STREAM_ERROR if any of\r\n the paramaters are invalid, Z_MEM_ERROR if the internal state could not\r\n be allocated, or Z_VERSION_ERROR if the version of the library does not\r\n match the version of the header file.\r\n*}\r\n\r\ntype\r\n {$EXTERNALSYM in_func}\r\n in_func = function(p1: Pointer; p2: PByte):UnsignedInt;\r\n {$EXTERNALSYM out_func}\r\n out_func = function (p1: Pointer; p2: PByte; p3:UnsignedInt): Longint;\r\n {$EXTERNALSYM TFNInFunc}\r\n TFNInFunc = in_func;\r\n {$EXTERNALSYM TFNOutFunc}\r\n TFNOutFunc = out_func;\r\n\r\n{$IFDEF ZLIB_LINKONREQUEST}\r\n\r\ntype\r\n {$EXTERNALSYM TinflateBack}\r\n TinflateBack = function (var strm: TZStreamRec;\r\n input:TFNInFunc;\r\n in_desc: Pointer;\r\n ouput:TFNOutFunc;\r\n out_desc: Pointer): Integer; // OS: CHECKTHIS - should the parameter names\r\n // be the same as in PHs translation? They\r\n // are wrong there, but in/out are reserved\r\n // words in Delphi\r\n {$IFDEF ZLIB_EXPORT_CDECL} cdecl; {$ENDIF ZLIB_EXPORT_CDECL}\r\nvar\r\n {$EXTERNALSYM inflateBack}\r\n inflateBack: TinflateBack = nil;\r\n\r\n{$ELSE ~ZLIB_LINKONREQUEST}\r\n\r\n{$EXTERNALSYM inflateBack}\r\nfunction inflateBack(var strm: TZStreamRec;\r\n input:TFNInFunc;\r\n in_desc: Pointer;\r\n ouput:TFNOutFunc;\r\n out_desc: Pointer): Integer; // OS: CHECKTHIS - should the parameter names\r\n // be the same as in PHs translation? They\r\n // are wrong there, but in/out are reserved\r\n // words in Delphi\r\n {$IFDEF ZLIB_EXPORT_CDECL} cdecl; {$ENDIF ZLIB_EXPORT_CDECL}\r\n\r\n{$ENDIF ~ZLIB_LINKONREQUEST}\r\n\r\n{*\r\n inflateBack() does a raw inflate with a single call using a call-back\r\n interface for input and output. This is more efficient than inflate() for\r\n file i/o applications in that it avoids copying between the output and the\r\n sliding window by simply making the window itself the output buffer. This\r\n function trusts the application to not change the output buffer passed by\r\n the output function, at least until inflateBack() returns.\r\n\r\n inflateBackInit() must be called first to allocate the internal state\r\n and to initialize the state with the user-provided window buffer.\r\n inflateBack() may then be used multiple times to inflate a complete, raw\r\n deflate stream with each call. inflateBackEnd() is then called to free\r\n the allocated state.\r\n\r\n A raw deflate stream is one with no zlib or gzip header or trailer.\r\n This routine would normally be used in a utility that reads zip or gzip\r\n files and writes out uncompressed files. The utility would decode the\r\n header and process the trailer on its own, hence this routine expects\r\n only the raw deflate stream to decompress. This is different from the\r\n normal behavior of inflate(), which expects either a zlib or gzip header and\r\n trailer around the deflate stream.\r\n\r\n inflateBack() uses two subroutines supplied by the caller that are then\r\n called by inflateBack() for input and output. inflateBack() calls those\r\n routines until it reads a complete deflate stream and writes out all of the\r\n uncompressed data, or until it encounters an error. The function's\r\n parameters and return types are defined above in the in_func and out_func\r\n typedefs. inflateBack() will call in(in_desc, &buf) which should return the\r\n number of bytes of provided input, and a pointer to that input in buf. If\r\n there is no input available, in() must return zero--buf is ignored in that\r\n case--and inflateBack() will return a buffer error. inflateBack() will call\r\n out(out_desc, buf, len) to write the uncompressed data buf[0..len-1]. out()\r\n should return zero on success, or non-zero on failure. If out() returns\r\n non-zero, inflateBack() will return with an error. Neither in() nor out()\r\n are permitted to change the contents of the window provided to\r\n inflateBackInit(), which is also the buffer that out() uses to write from.\r\n The length written by out() will be at most the window size. Any non-zero\r\n amount of input may be provided by in().\r\n\r\n For convenience, inflateBack() can be provided input on the first call by\r\n setting strm->next_in and strm->avail_in. If that input is exhausted, then\r\n in() will be called. Therefore strm->next_in must be initialized before\r\n calling inflateBack(). If strm->next_in is Z_NULL, then in() will be called\r\n immediately for input. If strm->next_in is not Z_NULL, then strm->avail_in\r\n must also be initialized, and then if strm->avail_in is not zero, input will\r\n initially be taken from strm->next_in[0 .. strm->avail_in - 1].\r\n\r\n The in_desc and out_desc parameters of inflateBack() is passed as the\r\n first parameter of in() and out() respectively when they are called. These\r\n descriptors can be optionally used to pass any information that the caller-\r\n supplied in() and out() functions need to do their job.\r\n\r\n On return, inflateBack() will set strm->next_in and strm->avail_in to\r\n pass back any unused input that was provided by the last in() call. The\r\n return values of inflateBack() can be Z_STREAM_END on success, Z_BUF_ERROR\r\n if in() or out() returned an error, Z_DATA_ERROR if there was a format\r\n error in the deflate stream (in which case strm->msg is set to indicate the\r\n nature of the error), or Z_STREAM_ERROR if the stream was not properly\r\n initialized. In the case of Z_BUF_ERROR, an input or output error can be\r\n distinguished using strm->next_in which will be Z_NULL only if in() returned\r\n an error. If strm->next is not Z_NULL, then the Z_BUF_ERROR was due to\r\n out() returning non-zero. (in() will always be called before out(), so\r\n strm->next_in is assured to be defined if out() returns non-zero.) Note\r\n that inflateBack() cannot return Z_OK.\r\n*}\r\n\r\n{$IFDEF ZLIB_LINKONREQUEST}\r\n\r\ntype\r\n {$EXTERNALSYM TinflateBackEnd}\r\n TinflateBackEnd = function (var strm: TZStreamRec): Integer;\r\n {$IFDEF ZLIB_EXPORT_CDECL} cdecl; {$ENDIF ZLIB_EXPORT_CDECL}\r\nvar\r\n {$EXTERNALSYM inflateBackEnd}\r\n inflateBackEnd: TinflateBackEnd = nil;\r\n\r\n{$ELSE ~ZLIB_LINKONREQUEST}\r\n\r\n{$EXTERNALSYM inflateBackEnd}\r\nfunction inflateBackEnd(var strm: TZStreamRec): Integer;\r\n {$IFDEF ZLIB_EXPORT_CDECL} cdecl; {$ENDIF ZLIB_EXPORT_CDECL}\r\n\r\n{$ENDIF ~ZLIB_LINKONREQUEST}\r\n\r\n{*\r\n All memory allocated by inflateBackInit() is freed.\r\n\r\n inflateBackEnd() returns Z_OK on success, or Z_STREAM_ERROR if the stream\r\n state was inconsistent.\r\n*}\r\n\r\n{$IFDEF ZLIB_LINKONREQUEST}\r\n\r\ntype\r\n {$EXTERNALSYM TzlibCompileFlags}\r\n TzlibCompileFlags = function ():uLong;\r\n {$IFDEF ZLIB_EXPORT_CDECL} cdecl; {$ENDIF ZLIB_EXPORT_CDECL}\r\nvar\r\n {$EXTERNALSYM zlibCompileFlags}\r\n zlibCompileFlags: TzlibCompileFlags = nil;\r\n\r\n{$ELSE ~ZLIB_LINKONREQUEST}\r\n\r\n{$EXTERNALSYM zlibCompileFlags}\r\nfunction zlibCompileFlags():uLong;\r\n {$IFDEF ZLIB_EXPORT_CDECL} cdecl; {$ENDIF ZLIB_EXPORT_CDECL}\r\n\r\n{$ENDIF ~ZLIB_LINKONREQUEST}\r\n\r\n{* Return flags indicating compile-time options.\r\n\r\n Type sizes, two bits each, 00 = 16 bits, 01 = 32, 10 = 64, 11 = other:\r\n 1.0: size of uInt\r\n 3.2: size of uLong\r\n 5.4: size of voidpf (pointer)\r\n 7.6: size of z_off_t\r\n\r\n Compiler, assembler, and debug options:\r\n 8: DEBUG\r\n 9: ASMV or ASMINF -- use ASM code\r\n 10: ZLIB_WINAPI -- exported functions use the WINAPI calling convention\r\n 11: 0 (reserved)\r\n\r\n One-time table building (smaller code, but not thread-safe if true):\r\n 12: BUILDFIXED -- build static block decoding tables when needed\r\n 13: DYNAMIC_CRC_TABLE -- build CRC calculation tables when needed\r\n 14,15: 0 (reserved)\r\n\r\n Library content (indicates missing functionality):\r\n 16: NO_GZCOMPRESS -- gz* functions cannot compress (to avoid linking\r\n deflate code when not needed)\r\n 17: NO_GZIP -- deflate can't write gzip streams, and inflate can't detect\r\n and decode gzip streams (to avoid linking crc code)\r\n 18-19: 0 (reserved)\r\n\r\n Operation variations (changes in library functionality):\r\n 20: PKZIP_BUG_WORKAROUND -- slightly more permissive inflate\r\n 21: FASTEST -- deflate algorithm with only one, lowest compression level\r\n 22,23: 0 (reserved)\r\n\r\n The sprintf variant used by gzprintf (zero is best):\r\n 24: 0 = vs*, 1 = s* -- 1 means limited to 20 arguments after the format\r\n 25: 0 = *nprintf, 1 = *printf -- 1 means gzprintf() not secure!\r\n 26: 0 = returns value, 1 = void -- 1 means inferred string length returned\r\n\r\n Remainder:\r\n 27-31: 0 (reserved)\r\n *}\r\n\r\n\r\n {* utility functions *}\r\n\r\n{*\r\n The following utility functions are implemented on top of the\r\n basic stream-oriented functions. To simplify the interface, some\r\n default options are assumed (compression level and memory usage,\r\n standard memory allocation functions). The source code of these\r\n utility functions can easily be modified if you need special options.\r\n*}\r\n\r\n{$IFDEF ZLIB_LINKONREQUEST}\r\n\r\ntype\r\n {$EXTERNALSYM Tcompress}\r\n Tcompress = function (dest: PBytef;\r\n var destLen:uLongf;\r\n {const} source: PBytef;\r\n sourceLen:uLong): Integer;\r\n {$IFDEF ZLIB_EXPORT_CDECL} cdecl; {$ENDIF ZLIB_EXPORT_CDECL}\r\nvar\r\n {$EXTERNALSYM compress}\r\n compress: Tcompress = nil;\r\n\r\n{$ELSE ~ZLIB_LINKONREQUEST}\r\n\r\n{$EXTERNALSYM compress}\r\nfunction compress(dest: PBytef;\r\n var destLen:uLongf;\r\n {const} source: PBytef;\r\n sourceLen:uLong): Integer;\r\n {$IFDEF ZLIB_EXPORT_CDECL} cdecl; {$ENDIF ZLIB_EXPORT_CDECL}\r\n\r\n{$ENDIF ~ZLIB_LINKONREQUEST}\r\n\r\n{*\r\n Compresses the source buffer into the destination buffer. sourceLen is\r\n the byte length of the source buffer. Upon entry, destLen is the total\r\n size of the destination buffer, which must be at least the value returned\r\n by compressBound(sourceLen). Upon exit, destLen is the actual size of the\r\n compressed buffer.\r\n This function can be used to compress a whole file at once if the\r\n input file is mmap'ed.\r\n compress returns Z_OK if success, Z_MEM_ERROR if there was not\r\n enough memory, Z_BUF_ERROR if there was not enough room in the output\r\n buffer.\r\n*}\r\n\r\n{$IFDEF ZLIB_LINKONREQUEST}\r\n\r\ntype\r\n {$EXTERNALSYM Tcompress2}\r\n Tcompress2 = function (dest: PBytef;\r\n var destLen:uLongf;\r\n {const} source: PBytef;\r\n sourceLen:uLong;\r\n level: Integer): Integer;\r\n {$IFDEF ZLIB_EXPORT_CDECL} cdecl; {$ENDIF ZLIB_EXPORT_CDECL}\r\nvar\r\n {$EXTERNALSYM compress2}\r\n compress2: Tcompress2 = nil;\r\n\r\n{$ELSE ~ZLIB_LINKONREQUEST}\r\n\r\n{$EXTERNALSYM compress2}\r\nfunction compress2(dest: PBytef;\r\n var destLen:uLongf;\r\n {const} source: PBytef;\r\n sourceLen:uLong;\r\n level: Integer): Integer;\r\n {$IFDEF ZLIB_EXPORT_CDECL} cdecl; {$ENDIF ZLIB_EXPORT_CDECL}\r\n\r\n{$ENDIF ~ZLIB_LINKONREQUEST}\r\n\r\n{*\r\n Compresses the source buffer into the destination buffer. The level\r\n parameter has the same meaning as in deflateInit. sourceLen is the byte\r\n length of the source buffer. Upon entry, destLen is the total size of the\r\n destination buffer, which must be at least the value returned by\r\n compressBound(sourceLen). Upon exit, destLen is the actual size of the\r\n compressed buffer.\r\n\r\n compress2 returns Z_OK if success, Z_MEM_ERROR if there was not enough\r\n memory, Z_BUF_ERROR if there was not enough room in the output buffer,\r\n Z_STREAM_ERROR if the level parameter is invalid.\r\n*}\r\n\r\n{$IFDEF ZLIB_LINKONREQUEST}\r\n\r\ntype\r\n {$EXTERNALSYM TcompressBound}\r\n TcompressBound = function (sourceLen:uLong):uLong;\r\n {$IFDEF ZLIB_EXPORT_CDECL} cdecl; {$ENDIF ZLIB_EXPORT_CDECL}\r\nvar\r\n {$EXTERNALSYM compressBound}\r\n compressBound: TcompressBound = nil;\r\n\r\n{$ELSE ~ZLIB_LINKONREQUEST}\r\n\r\n{$EXTERNALSYM compressBound}\r\nfunction compressBound(sourceLen:uLong):uLong;\r\n {$IFDEF ZLIB_EXPORT_CDECL} cdecl; {$ENDIF ZLIB_EXPORT_CDECL}\r\n\r\n{$ENDIF ~ZLIB_LINKONREQUEST}\r\n\r\n{*\r\n compressBound() returns an upper bound on the compressed size after\r\n compress() or compress2() on sourceLen bytes. It would be used before\r\n a compress() or compress2() call to allocate the destination buffer.\r\n*}\r\n\r\n{$IFDEF ZLIB_LINKONREQUEST}\r\n\r\ntype\r\n {$EXTERNALSYM Tuncompress}\r\n Tuncompress = function (dest: PBytef;\r\n var destLen:uLongf;\r\n {const} source: PBytef;\r\n sourceLen:uLong): Integer;\r\n {$IFDEF ZLIB_EXPORT_CDECL} cdecl; {$ENDIF ZLIB_EXPORT_CDECL}\r\nvar\r\n {$EXTERNALSYM uncompress}\r\n uncompress: Tuncompress = nil;\r\n\r\n{$ELSE ~ZLIB_LINKONREQUEST}\r\n\r\n{$EXTERNALSYM uncompress}\r\nfunction uncompress(dest: PBytef;\r\n var destLen:uLongf;\r\n {const} source: PBytef;\r\n sourceLen:uLong): Integer;\r\n {$IFDEF ZLIB_EXPORT_CDECL} cdecl; {$ENDIF ZLIB_EXPORT_CDECL}\r\n\r\n{$ENDIF ~ZLIB_LINKONREQUEST}\r\n\r\n{*\r\n Decompresses the source buffer into the destination buffer. sourceLen is\r\n the byte length of the source buffer. Upon entry, destLen is the total\r\n size of the destination buffer, which must be large enough to hold the\r\n entire uncompressed data. (The size of the uncompressed data must have\r\n been saved previously by the compressor and transmitted to the decompressor\r\n by some mechanism outside the scope of this compression library.)\r\n Upon exit, destLen is the actual size of the compressed buffer.\r\n This function can be used to decompress a whole file at once if the\r\n input file is mmap'ed.\r\n\r\n uncompress returns Z_OK if success, Z_MEM_ERROR if there was not\r\n enough memory, Z_BUF_ERROR if there was not enough room in the output\r\n buffer, or Z_DATA_ERROR if the input data was corrupted or incomplete.\r\n*}\r\n\r\n(*\r\ntype\r\n gzFile = voidp;\r\n\r\nfunction gzopen(path: PAnsiChar; mode: PAnsiChar):gzFile;\r\n{*\r\n Opens a gzip (.gz) file for reading or writing. The mode parameter\r\n is as in fopen (\"rb\" or \"wb\") but can also include a compression level\r\n (\"wb9\") or a strategy: 'f' for filtered data as in \"wb6f\", 'h' for\r\n Huffman only compression as in \"wb1h\", or 'R' for run-length encoding\r\n as in \"wb1R\". (See the description of deflateInit2 for more information\r\n about the strategy parameter.)\r\n\r\n gzopen can be used to read a file which is not in gzip format; in this\r\n case gzread will directly read from the file without decompression.\r\n\r\n gzopen returns NULL if the file could not be opened or if there was\r\n insufficient memory to allocate the (de)compression state; errno\r\n can be checked to distinguish the two cases (if errno is zero, the\r\n zlib error is Z_MEM_ERROR). *}\r\n\r\nfunction gzdopen(fd: Integer; mode: PAnsiChar):gzFile;\r\n{*\r\n gzdopen() associates a gzFile with the file descriptor fd. File\r\n descriptors are obtained from calls like open, dup, creat, pipe or\r\n fileno (in the file has been previously opened with fopen).\r\n The mode parameter is as in gzopen.\r\n The next call of gzclose on the returned gzFile will also close the\r\n file descriptor fd, just like fclose(fdopen(fd), mode) closes the file\r\n descriptor fd. If you want to keep fd open, use gzdopen(dup(fd), mode).\r\n gzdopen returns NULL if there was insufficient memory to allocate\r\n the (de)compression state.\r\n*}\r\n\r\nfunction gzsetparams(file_:gzFile; level: Integer; strategy: Integer): Integer;\r\n{*\r\n Dynamically update the compression level or strategy. See the description\r\n of deflateInit2 for the meaning of these parameters.\r\n gzsetparams returns Z_OK if success, or Z_STREAM_ERROR if the file was not\r\n opened for writing.\r\n*}\r\n\r\nfunction gzread(file_:gzFile; buf:voidp; len:UnsignedInt): Integer;\r\n{*\r\n Reads the given number of uncompressed bytes from the compressed file.\r\n If the input file was not in gzip format, gzread copies the given number\r\n of bytes into the buffer.\r\n gzread returns the number of uncompressed bytes actually read (0 for\r\n end of file, -1 for error). *}\r\n\r\nfunction gzwrite(file_:gzFile;\r\n buf:voidpc;\r\n len:UnsignedInt): Integer;\r\n{*\r\n Writes the given number of uncompressed bytes into the compressed file.\r\n gzwrite returns the number of uncompressed bytes actually written\r\n (0 in case of error).\r\n*}\r\n\r\n// function gzprintf(file_:gzFile; format: PAnsiChar, ...): Integer;\r\n// No ellipsis in Delphi\r\n{*\r\n Converts, formats, and writes the args to the compressed file under\r\n control of the format string, as in fprintf. gzprintf returns the number of\r\n uncompressed bytes actually written (0 in case of error). The number of\r\n uncompressed bytes written is limited to 4095. The caller should assure that\r\n this limit is not exceeded. If it is exceeded, then gzprintf() will return\r\n return an error (0) with nothing written. In this case, there may also be a\r\n buffer overflow with unpredictable consequences, which is possible only if\r\n zlib was compiled with the insecure functions sprintf() or vsprintf()\r\n because the secure snprintf() or vsnprintf() functions were not available.\r\n*}\r\n\r\nfunction gzputs(file_:gzFile; s: PAnsiChar): Integer;\r\n(*\r\n Writes the given null-terminated string to the compressed file, excluding\r\n the terminating null character.\r\n gzputs returns the number of characters written, or -1 in case of error.\r\n*}\r\n\r\nfunction gzgets(file_:gzFile; buf: PAnsiChar; len: Integer): PAnsiChar;\r\n{*\r\n Reads bytes from the compressed file until len-1 characters are read, or\r\n a newline character is read and transferred to buf, or an end-of-file\r\n condition is encountered. The string is then terminated with a null\r\n character.\r\n gzgets returns buf, or Z_NULL in case of error.\r\n*}\r\n\r\nfunction gzputc(file_:gzFile; c: Integer): Integer;\r\n{*\r\n Writes c, converted to an unsigned char, into the compressed file.\r\n gzputc returns the value that was written, or -1 in case of error.\r\n*}\r\n\r\nfunction gzgetc(file_:gzFile): Integer;\r\n{*\r\n Reads one byte from the compressed file. gzgetc returns this byte\r\n or -1 in case of end of file or error.\r\n*}\r\n\r\nfunction gzungetc(c: Integer; file_:gzFile): Integer;\r\n{*\r\n Push one character back onto the stream to be read again later.\r\n Only one character of push-back is allowed. gzungetc() returns the\r\n character pushed, or -1 on failure. gzungetc() will fail if a\r\n character has been pushed but not read yet, or if c is -1. The pushed\r\n character will be discarded if the stream is repositioned with gzseek()\r\n or gzrewind().\r\n*}\r\n\r\nfunction gzflush(file_:gzFile; flush: Integer): Integer;\r\n{*\r\n Flushes all pending output into the compressed file. The parameter\r\n flush is as in the deflate() function. The return value is the zlib\r\n error number (see function gzerror below). gzflush returns Z_OK if\r\n the flush parameter is Z_FINISH and all output could be flushed.\r\n gzflush should be called only when strictly necessary because it can\r\n degrade compression.\r\n*}\r\n\r\nfunction gzseek(file_:gzFile;\r\n offset:z_off_t;\r\n whence: Integer):z_off_t;\r\n{*\r\n Sets the starting position for the next gzread or gzwrite on the\r\n given compressed file. The offset represents a number of bytes in the\r\n uncompressed data stream. The whence parameter is defined as in lseek(2);\r\n the value SEEK_END is not supported.\r\n If the file is opened for reading, this function is emulated but can be\r\n extremely slow. If the file is opened for writing, only forward seeks are\r\n supported; gzseek then compresses a sequence of zeroes up to the new\r\n starting position.\r\n\r\n gzseek returns the resulting offset location as measured in bytes from\r\n the beginning of the uncompressed stream, or -1 in case of error, in\r\n particular if the file is opened for writing and the new starting position\r\n would be before the current position.\r\n*}\r\n\r\nfunction gzrewind(file_:gzFile): Integer;\r\n{*\r\n Rewinds the given file. This function is supported only for reading.\r\n\r\n gzrewind(file) is equivalent to (int)gzseek(file, 0L, SEEK_SET)\r\n*}\r\n\r\nfunction gztell(file_:gzFile):z_off_t;\r\n{*\r\n Returns the starting position for the next gzread or gzwrite on the\r\n given compressed file. This position represents a number of bytes in the\r\n uncompressed data stream.\r\n\r\n gztell(file) is equivalent to gzseek(file, 0L, SEEK_CUR)\r\n*}\r\n\r\nfunction gzeof(file_:gzFile): Integer;\r\n{*\r\n Returns 1 when EOF has previously been detected reading the given\r\n input stream, otherwise zero.\r\n*}\r\n\r\nfunction gzclose(file_:gzFile): Integer;\r\n{*\r\n Flushes all pending output if necessary, closes the compressed file\r\n and deallocates all the (de)compression state. The return value is the zlib\r\n error number (see function gzerror below).\r\n*}\r\n\r\nfunction gzerror(file_:gzFile; var errnum: Integer): PAnsiChar;\r\n{*\r\n Returns the error message for the last error which occurred on the\r\n given compressed file. errnum is set to zlib error number. If an\r\n error occurred in the file system and not in the compression library,\r\n errnum is set to Z_ERRNO and the application may consult errno\r\n to get the exact error code.\r\n*}\r\n\r\nprocedure gzclearerr(file_:gzFile);\r\n{*\r\n Clears the error and end-of-file flags for file. This is analogous to the\r\n clearerr() function in stdio. This is useful for continuing to read a gzip\r\n file that is being written concurrently.\r\n*}\r\n*)\r\n {* checksum functions *}\r\n\r\n{*\r\n These functions are not related to compression but are exported\r\n anyway because they might be useful in applications using the\r\n compression library.\r\n*}\r\n\r\n{$IFDEF ZLIB_LINKONREQUEST}\r\n\r\ntype\r\n {$EXTERNALSYM Tadler32}\r\n Tadler32 = function (adler:uLong; {const} buf: PBytef; len:uInt):uLong;\r\n {$IFDEF ZLIB_EXPORT_CDECL} cdecl; {$ENDIF ZLIB_EXPORT_CDECL}\r\nvar\r\n {$EXTERNALSYM adler32}\r\n adler32: Tadler32 = nil;\r\n\r\n{$ELSE ~ZLIB_LINKONREQUEST}\r\n\r\n{$EXTERNALSYM adler32}\r\nfunction adler32(adler:uLong; {const} buf: PBytef; len:uInt):uLong;\r\n {$IFDEF ZLIB_EXPORT_CDECL} cdecl; {$ENDIF ZLIB_EXPORT_CDECL}\r\n\r\n{$ENDIF ~ZLIB_LINKONREQUEST}\r\n\r\n(*\r\n Update a running Adler-32 checksum with the bytes buf[0..len-1] and\r\n return the updated checksum. If buf is NULL, this function returns\r\n the required initial value for the checksum.\r\n An Adler-32 checksum is almost as reliable as a CRC32 but can be computed\r\n much faster. Usage example:\r\n\r\n uLong adler = adler32(0L, Z_NULL, 0);\r\n\r\n while (read_buffer(buffer, length) != EOF) {\r\n adler = adler32(adler, buffer, length);\r\n }\r\n if (adler != original_adler) error();\r\n*)\r\n\r\n{$IFDEF ZLIB_LINKONREQUEST}\r\n\r\ntype\r\n {$EXTERNALSYM tcrc32}\r\n tcrc32 = function (crc:uLong; {const} buf: PBytef; len:uInt):uLong;\r\n {$IFDEF ZLIB_EXPORT_CDECL} cdecl; {$ENDIF ZLIB_EXPORT_CDECL}\r\nvar\r\n {$EXTERNALSYM crc32}\r\n crc32: tcrc32 = nil;\r\n\r\n{$ELSE ~ZLIB_LINKONREQUEST}\r\n\r\n{$EXTERNALSYM crc32}\r\nfunction crc32 (crc:uLong; {const} buf: PBytef; len:uInt):uLong;\r\n {$IFDEF ZLIB_EXPORT_CDECL} cdecl; {$ENDIF ZLIB_EXPORT_CDECL}\r\n\r\n{$ENDIF ~ZLIB_LINKONREQUEST}\r\n\r\n(*\r\n Update a running crc with the bytes buf[0..len-1] and return the updated\r\n crc. If buf is NULL, this function returns the required initial value\r\n for the crc. Pre- and post-conditioning (one's complement) is performed\r\n within this function so it shouldn't be done by the application.\r\n Usage example:\r\n\r\n uLong crc = crc32(0L, Z_NULL, 0);\r\n\r\n while (read_buffer(buffer, length) != EOF) {\r\n crc = crc32(crc, buffer, length);\r\n }\r\n if (crc != original_crc) error();\r\n*)\r\n\r\n {* various hacks, don't look :) *)\r\n\r\n{* deflateInit and inflateInit are macros to allow checking the zlib version\r\n * and the compiler's view of z_stream:\r\n *}\r\n\r\n{$IFDEF ZLIB_LINKONREQUEST}\r\n\r\ntype\r\n {$EXTERNALSYM TzError}\r\n TzError = function (err: Integer): PAnsiChar;\r\n {$IFDEF ZLIB_EXPORT_CDECL} cdecl; {$ENDIF ZLIB_EXPORT_CDECL}\r\nvar\r\n {$EXTERNALSYM zError}\r\n zError: TzError = nil;\r\n\r\n{$ELSE ~ZLIB_LINKONREQUEST}\r\n\r\n{$EXTERNALSYM zError}\r\nfunction zError(err: Integer): PAnsiChar;\r\n {$IFDEF ZLIB_EXPORT_CDECL} cdecl; {$ENDIF ZLIB_EXPORT_CDECL}\r\n\r\n{$ENDIF ~ZLIB_LINKONREQUEST}\r\n\r\n{$IFDEF ZLIB_LINKONREQUEST}\r\n\r\ntype\r\n {$EXTERNALSYM TinflateSyncPoint}\r\n TinflateSyncPoint = function (var z: TZStreamRec): Integer;\r\n {$IFDEF ZLIB_EXPORT_CDECL} cdecl; {$ENDIF ZLIB_EXPORT_CDECL}\r\nvar\r\n {$EXTERNALSYM inflateSyncPoint}\r\n inflateSyncPoint: TinflateSyncPoint = nil;\r\n\r\n{$ELSE ~ZLIB_LINKONREQUEST}\r\n\r\n{$EXTERNALSYM inflateSyncPoint}\r\nfunction inflateSyncPoint(var z: TZStreamRec): Integer;\r\n {$IFDEF ZLIB_EXPORT_CDECL} cdecl; {$ENDIF ZLIB_EXPORT_CDECL}\r\n\r\n{$ENDIF ~ZLIB_LINKONREQUEST}\r\n\r\n{$IFDEF ZLIB_LINKONREQUEST}\r\n\r\ntype\r\n {$EXTERNALSYM Tget_crc_table}\r\n Tget_crc_table = function ():PuLongf;\r\n {$IFDEF ZLIB_EXPORT_CDECL} cdecl; {$ENDIF ZLIB_EXPORT_CDECL}\r\nvar\r\n {$EXTERNALSYM get_crc_table}\r\n get_crc_table: Tget_crc_table = nil;\r\n\r\n{$ELSE ~ZLIB_LINKONREQUEST}\r\n\r\n{$EXTERNALSYM get_crc_table}\r\nfunction get_crc_table():PuLongf;\r\n {$IFDEF ZLIB_EXPORT_CDECL} cdecl; {$ENDIF ZLIB_EXPORT_CDECL}\r\n\r\n{$ENDIF ~ZLIB_LINKONREQUEST}\r\n\r\n//-----------------------------------------------------------------------------\r\n// from zutil.h\r\n//-----------------------------------------------------------------------------\r\n\r\nconst\r\n DEF_WBITS = MAX_WBITS;\r\n {$EXTERNALSYM DEF_WBITS}\r\n\r\n// default windowBits for decompression. MAX_WBITS is for compression only\r\n\r\n DEF_MEM_LEVEL = 8;\r\n {$EXTERNALSYM DEF_MEM_LEVEL}\r\n\r\n//DOM-IGNORE-END\r\n{$ENDIF ~ZLIB_RTL}\r\n\r\nconst\r\n {$IFDEF MSWINDOWS}\r\n ZLibDefaultLibraryName = 'zlib1.dll';\r\n {$ENDIF MSWINDOWS}\r\n {$IFDEF UNIX}\r\n ZLibDefaultLibraryName = 'libz.so';\r\n {$ENDIF UNIX}\r\n ZLibzlibVersionDefaultExportName = 'zlibVersion';\r\n ZLibdeflateInit_DefaultExportName = 'deflateInit_';\r\n ZLibdeflateDefaultExportName = 'deflate';\r\n ZLibdeflateEndDefaultExportName = 'deflateEnd';\r\n ZLibinflateInit_DefaultExportName = 'inflateInit_';\r\n ZLibinflateDefaultExportName = 'inflate';\r\n ZLibinflateEndDefaultExportName = 'inflateEnd';\r\n ZLibdeflateInit2_DefaultExportName = 'deflateInit2_';\r\n ZLibdeflateSetDictionaryDefaultExportName = 'deflateSetDictionary';\r\n ZLibdeflateCopyDefaultExportName = 'deflateCopy';\r\n ZLibdeflateResetDefaultExportName = 'deflateReset';\r\n ZLibdeflateParamsDefaultExportName = 'deflateParams';\r\n ZLibdeflateBoundDefaultExportName = 'deflateBound';\r\n ZLibdeflatePendingDefaultExportName = 'deflatePending';\r\n ZLibdeflatePrimeDefaultExportName = 'deflatePrime';\r\n ZLibinflateInit2_DefaultExportName = 'inflateInit2_';\r\n ZLibinflateSetDictionaryDefaultExportName = 'inflateSetDictionary';\r\n ZLibinflateSyncDefaultExportName = 'inflateSync';\r\n ZLibinflateCopyDefaultExportName = 'inflateCopy';\r\n ZLibinflateResetDefaultExportName = 'inflateReset';\r\n ZLibinflateBackInit_DefaultExportName = 'inflateBackInit_';\r\n ZLibinflateBackDefaultExportName = 'inflateBack';\r\n ZLibinflateBackEndDefaultExportName = 'inflateBackEnd';\r\n ZLibzlibCompileFlagsDefaultExportName = 'zlibCompileFlags';\r\n ZLibcompressDefaultExportName = 'compress';\r\n ZLibcompress2DefaultExportName = 'compress2';\r\n ZLibcompressBoundDefaultExportName = 'compressBound';\r\n ZLibuncompressDefaultExportName = 'uncompress';\r\n ZLibadler32DefaultExportName = 'adler32';\r\n ZLibcrc32DefaultExportName = 'crc32';\r\n ZLibzErrorDefaultExportName = 'zError';\r\n ZLibinflateSyncPointDefaultExportName = 'inflateSyncPoint';\r\n ZLibget_crc_tableDefaultExportName = 'get_crc_table';\r\n{$IFDEF ZLIB_LINKONREQUEST}\r\nvar\r\n ZLibLibraryName: string = ZLibDefaultLibraryName;\r\n ZLibzlibVersionExportName: string = ZLibzlibVersionDefaultExportName;\r\n ZLibdeflateInit_ExportName: string = ZLibdeflateInit_DefaultExportName;\r\n ZLibdeflateExportName: string = ZLibdeflateDefaultExportName;\r\n ZLibdeflateEndExportName: string = ZLibdeflateEndDefaultExportName;\r\n ZLibinflateInit_ExportName: string = ZLibinflateInit_DefaultExportName;\r\n ZLibinflateExportName: string = ZLibinflateDefaultExportName;\r\n ZLibinflateEndExportName: string = ZLibinflateEndDefaultExportName;\r\n ZLibdeflateInit2_ExportName: string = ZLibdeflateInit2_DefaultExportName;\r\n ZLibdeflateSetDictionaryExportName: string = ZLibdeflateSetDictionaryDefaultExportName;\r\n ZLibdeflateCopyExportName: string = ZLibdeflateCopyDefaultExportName;\r\n ZLibdeflateResetExportName: string = ZLibdeflateResetDefaultExportName;\r\n ZLibdeflateParamsExportName: string = ZLibdeflateParamsDefaultExportName;\r\n ZLibdeflateBoundExportName: string = ZLibdeflateBoundDefaultExportName;\r\n ZLibdeflatePendingExportName: string = ZLibdeflatePendingDefaultExportName;\r\n ZLibdeflatePrimeExportName: string = ZLibdeflatePrimeDefaultExportName;\r\n ZLibinflateInit2_ExportName: string = ZLibinflateInit2_DefaultExportName;\r\n ZLibinflateSetDictionaryExportName: string = ZLibinflateSetDictionaryDefaultExportName;\r\n ZLibinflateSyncExportName: string = ZLibinflateSyncDefaultExportName;\r\n ZLibinflateCopyExportName: string = ZLibinflateCopyDefaultExportName;\r\n ZLibinflateResetExportName: string = ZLibinflateResetDefaultExportName;\r\n ZLibinflateBackInit_ExportName: string = ZLibinflateBackInit_DefaultExportName;\r\n ZLibinflateBackExportName: string = ZLibinflateBackDefaultExportName;\r\n ZLibinflateBackEndExportName: string = ZLibinflateBackEndDefaultExportName;\r\n ZLibzlibCompileFlagsExportName: string = ZLibzlibCompileFlagsDefaultExportName;\r\n ZLibcompressExportName: string = ZLibcompressDefaultExportName;\r\n ZLibcompress2ExportName: string = ZLibcompress2DefaultExportName;\r\n ZLibcompressBoundExportName: string = ZLibcompressBoundDefaultExportName;\r\n ZLibuncompressExportName: string = ZLibuncompressDefaultExportName;\r\n ZLibadler32ExportName: string = ZLibadler32DefaultExportName;\r\n ZLibcrc32ExportName: string = ZLibcrc32DefaultExportName;\r\n ZLibzErrorExportName: string = ZLibzErrorDefaultExportName;\r\n ZLibinflateSyncPointExportName: string = ZLibinflateSyncPointDefaultExportName;\r\n ZLibget_crc_tableExportName: string = ZLibget_crc_tableDefaultExportName;\r\n{$ENDIF ZLIB_LINKONREQUEST}\r\n\r\nvar\r\n ZLibModuleHandle: TModuleHandle = INVALID_MODULEHANDLE_VALUE;\r\n\r\nfunction IsZLibLoaded: Boolean;\r\nfunction LoadZLib: Boolean;\r\nprocedure UnloadZLib;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jcl.svn.sourceforge.net/svnroot/jcl/tags/JCL-2.4-Build4571/jcl/source/common/zlibh.pas $';\r\n Revision: '$Revision: 3845 $';\r\n Date: '$Date: 2012-08-27 20:50:24 +0200 (lun. 27 août 2012) $';\r\n LogPath: 'JCL\\source\\common';\r\n Extra: '';\r\n Data: nil\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\n{$IFNDEF ZLIB_RTL}\r\n\r\nuses\r\n {$IFDEF HAS_UNITSCOPE}\r\n System.SysUtils;\r\n {$ELSE ~HAS_UNITSCOPE}\r\n SysUtils;\r\n {$ENDIF ~HAS_UNITSCOPE}\r\n\r\n//-----------------------------------------------------------------------------\r\n//\r\n// These are macros in the C version, just passing down the ZLIB version and\r\n// the size of TZStreamRec (alias z_stream)\r\n//\r\n//-----------------------------------------------------------------------------\r\n\r\nfunction deflateInit(var strm: TZStreamRec; level: Integer): Integer;\r\nbegin\r\n Result := deflateInit_(strm, level, ZLIB_VERSION, sizeof(TZStreamRec));\r\nend;\r\n\r\nfunction inflateInit(var strm: TZStreamRec): Integer;\r\nbegin\r\n Result := inflateInit_(strm, ZLIB_VERSION, sizeof(TZStreamRec));\r\nend;\r\n\r\nfunction deflateInit2(var strm: TZStreamRec; level: Integer; method: Integer; windowBits: Integer; memLevel: Integer; strategy: Integer): Integer;\r\nbegin\r\n Result := deflateInit2_(strm, level, method, windowBits, memLevel, strategy, ZLIB_VERSION, sizeof(TZStreamRec));\r\nend;\r\n\r\nfunction inflateInit2(var strm: TZStreamRec; windowBits: Integer): Integer;\r\nbegin\r\n Result := inflateInit2_(strm, windowBits, ZLIB_VERSION, sizeof(TZStreamRec));\r\nend;\r\n\r\nfunction inflateBackInit(var strm: TZStreamRec; windowBits: Integer; window: PByte): Integer;\r\nbegin\r\n Result := inflateBackInit_(strm, windowBits, window, ZLIB_VERSION, sizeof(TZStreamRec));\r\nend;\r\n\r\n{$IFDEF ZLIB_STATICLINK}\r\n\r\n{$IFDEF CPU32}\r\n{$LINK ..\\windows\\obj\\zlib\\win32\\adler32.obj} // OS: CHECKTHIS - Unix version may need forward slashes?\r\n{$LINK ..\\windows\\obj\\zlib\\win32\\compress.obj}\r\n{$LINK ..\\windows\\obj\\zlib\\win32\\crc32.obj}\r\n{$LINK ..\\windows\\obj\\zlib\\win32\\deflate.obj}\r\n{$LINK ..\\windows\\obj\\zlib\\win32\\infback.obj}\r\n{$LINK ..\\windows\\obj\\zlib\\win32\\inffast.obj}\r\n{$LINK ..\\windows\\obj\\zlib\\win32\\inflate.obj}\r\n{$LINK ..\\windows\\obj\\zlib\\win32\\inftrees.obj}\r\n{$LINK ..\\windows\\obj\\zlib\\win32\\trees.obj}\r\n{$LINK ..\\windows\\obj\\zlib\\win32\\uncompr.obj}\r\n{$LINK ..\\windows\\obj\\zlib\\win32\\zutil.obj}\r\n{$ENDIF CPU32}\r\n{$IFDEF CPU64}\r\n{$LINK ..\\windows\\obj\\zlib\\win64\\adler32.obj}\r\n{$LINK ..\\windows\\obj\\zlib\\win64\\compress.obj}\r\n{$LINK ..\\windows\\obj\\zlib\\win64\\crc32.obj}\r\n{$LINK ..\\windows\\obj\\zlib\\win64\\deflate.obj}\r\n{$LINK ..\\windows\\obj\\zlib\\win64\\infback.obj}\r\n{$LINK ..\\windows\\obj\\zlib\\win64\\inffast.obj}\r\n{$LINK ..\\windows\\obj\\zlib\\win64\\inflate.obj}\r\n{$LINK ..\\windows\\obj\\zlib\\win64\\inftrees.obj}\r\n{$LINK ..\\windows\\obj\\zlib\\win64\\trees.obj}\r\n{$LINK ..\\windows\\obj\\zlib\\win64\\uncompr.obj}\r\n{$LINK ..\\windows\\obj\\zlib\\win64\\zutil.obj}\r\n{$ENDIF CPU64}\r\n\r\n// Core functions\r\nfunction zlibVersion; external;\r\nfunction deflateInit_; external; // wrapped by deflateInit()\r\nfunction deflate; external;\r\nfunction deflateEnd; external;\r\nfunction inflateInit_; external; // wrapped by inflateInit()\r\nfunction inflate; external;\r\nfunction inflateEnd; external;\r\nfunction deflateInit2_; external; // wrapped by deflateInit2()\r\nfunction deflateSetDictionary; external;\r\nfunction deflateCopy; external;\r\nfunction deflateReset; external;\r\nfunction deflateParams; external;\r\nfunction deflateBound; external;\r\nfunction deflatePending; external;\r\nfunction deflatePrime; external;\r\nfunction inflateInit2_; external; // wrapped by inflateInit2()\r\nfunction inflateSetDictionary; external;\r\nfunction inflateSync; external;\r\nfunction inflateCopy; external;\r\nfunction inflateReset; external;\r\nfunction inflateBackInit_; external;\r\nfunction inflateBack; external;\r\nfunction inflateBackEnd; external;\r\nfunction zlibCompileFlags; external;\r\nfunction compress; external;\r\nfunction compress2; external;\r\nfunction compressBound; external;\r\nfunction uncompress; external;\r\n// Checksums\r\nfunction adler32; external;\r\nfunction crc32; external;\r\nfunction zError; external;\r\nfunction inflateSyncPoint; external;\r\nfunction get_crc_table; external;\r\n\r\n{$IFDEF LINKTO_MSVCRT_DLL}\r\n\r\n{ Win32 implementation specific!!! Imports from MSVCRT.DLL\r\n Checked availability for Windows 95B and Windows 2000 SP4\r\n\r\n _memcpy -> MSVCRT:memcpy\r\n _memset -> MSVCRT:memset\r\n _malloc -> MSVCRT:malloc\r\n _strlen -> MSVCRT:strlen\r\n ___errno -> MSVCRT:_errno\r\n _fopen -> MSVCRT:fopen\r\n _fdopen -> MSVCRT:_fdopen\r\n _fprintf -> MSVCRT:fprintf\r\n _ftell -> MSVCRT:ftell\r\n _sprintf -> MSVCRT:sprintf\r\n _fwrite -> MSVCRT:fwrite\r\n _fread -> MSVCRT:fread\r\n _free -> MSVCRT:free\r\n _fclose -> MSVCRT:fclose\r\n _vsnprintf -> MSVCRT:_vsnprintf\r\n _fflush -> MSVCRT:fflush\r\n _fseek -> MSVCRT:fseek\r\n _fputc -> MSVCRT:fputc\r\n _strcat -> MSVCRT:strcat\r\n _clearerr -> MSVCRT:clearerr\r\n}\r\n\r\n{* Just as a hint. Since these functions are already bound at the time the OBJ\r\n * file was created, it's only important that they be of CDECL calling convention.\r\n * Actually it's not even important wether the parameters or the number of\r\n * parameters is correct (especially important for variable-parameter functions).\r\n * Only the symbol names and the calling convention are important here as long\r\n * as only the OBJ use these functions\r\n *\r\n * This is just a \"dirty\" trick to get these \"missing\" imports linked\r\n *}\r\n\r\nconst\r\n szMSVCRT = 'MSVCRT.DLL';\r\n\r\nfunction _memcpy(dest, src: Pointer; count: size_t): Pointer; cdecl; external szMSVCRT name 'memcpy';\r\nfunction _memset(dest: Pointer; val: Integer; count: size_t): Pointer; cdecl; external szMSVCRT name 'memset';\r\nfunction _malloc(size: size_t): Pointer; cdecl; external szMSVCRT name 'malloc';\r\nprocedure _free(pBlock: Pointer); cdecl; external szMSVCRT name 'free';\r\nfunction ___errno(): Integer; cdecl; external szMSVCRT name '_errno';\r\nfunction _fopen(filename: PAnsiChar; mode: PAnsiChar): Pointer; cdecl; external szMSVCRT name 'fopen';\r\nfunction _fdopen(handle: Integer; mode: PAnsiChar): Pointer; cdecl; external szMSVCRT name '_fdopen';\r\nfunction _fprintf(stream: Pointer; format: PAnsiChar {, ...}): Integer; cdecl; external szMSVCRT name 'fprintf';\r\nfunction _ftell(stream: Pointer): Longint; cdecl; external szMSVCRT name 'ftell';\r\nfunction _sprintf(buffer: PAnsiChar; format: PAnsiChar {, ...}): Integer; cdecl; external szMSVCRT name 'sprintf';\r\nfunction _fwrite(buffer: Pointer; size: size_t; count: size_t; stream: Pointer): size_t; cdecl; external szMSVCRT name 'fwrite';\r\nfunction _fread(buffer: Pointer; size: size_t; count: size_t; stream: Pointer): size_t; cdecl; external szMSVCRT name 'fread';\r\nfunction _fclose(stream: Pointer): Integer; cdecl; external szMSVCRT name 'fclose';\r\nfunction _vsnprintf(buffer: PAnsiChar; count: size_t; format: PAnsiChar; argptr:array of const): Integer; cdecl; external szMSVCRT name '_vsnprintf';\r\nfunction _fflush(stream: Pointer): Integer; cdecl; external szMSVCRT name 'fflush';\r\nfunction _fseek(stream: Pointer; offset: Longint; origin: Integer): Integer; cdecl; external szMSVCRT name 'fseek';\r\nfunction _fputc(c: Integer; stream: Pointer): Integer; cdecl; external szMSVCRT name 'fputc';\r\nfunction _strcat(strDestination: PAnsiChar; strSource: PAnsiChar): PAnsiChar; cdecl; external szMSVCRT name 'strcat';\r\nfunction _strlen(str: PAnsiChar): size_t; cdecl; external szMSVCRT name 'strlen';\r\nprocedure _clearerr(stream: Pointer); cdecl; external szMSVCRT name 'clearerr';\r\n\r\n{$ELSE ~LINK_TO_MSVCRT}\r\n\r\n{$IFDEF CPU32}\r\nfunction _memcpy(dest, src: Pointer; count: size_t): Pointer; cdecl;\r\n{$ENDIF CPU32}\r\n{$IFDEF CPU64}\r\nfunction memcpy(dest, src: Pointer; count: size_t): Pointer;\r\n{$ENDIF CPU64}\r\nbegin\r\n Move(src^, dest^, count);\r\n Result := dest;\r\nend;\r\n\r\n{$IFDEF CPU32}\r\nfunction _memset(dest: Pointer; val: Integer; count: size_t): Pointer; cdecl;\r\n{$ENDIF CPU32}\r\n{$IFDEF CPU64}\r\nfunction memset(dest: Pointer; val: Integer; count: size_t): Pointer;\r\n{$ENDIF CPU64}\r\nbegin\r\n FillChar(dest^, count, val);\r\n Result := dest;\r\nend;\r\n\r\n{$IFDEF CPU32}\r\nfunction _malloc(size: size_t): Pointer; cdecl;\r\n{$ENDIF CPU32}\r\n{$IFDEF CPU64}\r\nfunction malloc(size: size_t): Pointer;\r\n{$ENDIF CPU64}\r\nbegin\r\n GetMem(Result, size);\r\nend;\r\n\r\n{$IFDEF CPU32}\r\nprocedure _free(pBlock: Pointer); cdecl;\r\n{$ENDIF CPU32}\r\n{$IFDEF CPU64}\r\nprocedure free(pBlock: Pointer);\r\n{$ENDIF CPU64}\r\nbegin\r\n FreeMem(pBlock);\r\nend;\r\n\r\n{$ENDIF ~LINK_TO_MSVCRT}\r\n\r\n{$IFDEF CPU32}\r\nprocedure __llmod; cdecl;\r\nasm\r\n jmp System.@_llmod;\r\nend;\r\n{$ENDIF CPU32}\r\n\r\n{$ENDIF ZLIB_STATICLINK}\r\n{$ENDIF ~ZLIB_RTL}\r\n\r\nfunction IsZLibLoaded: Boolean;\r\nbegin\r\n {$IFDEF ZLIB_LINKONREQUEST}\r\n Result := ZLibModuleHandle <> INVALID_MODULEHANDLE_VALUE;\r\n {$ELSE ~ZLIB_LINKONREQUEST}\r\n Result := True;\r\n {$ENDIF ~ZLIB_LINKONREQUEST}\r\nend;\r\n\r\nfunction LoadZLib: Boolean;\r\n{$IFDEF ZLIB_LINKONREQUEST}\r\nbegin\r\n Result := ZLibModuleHandle <> INVALID_MODULEHANDLE_VALUE;\r\n if Result then\r\n Exit;\r\n\r\n Result := JclSysUtils.LoadModule(ZLibModuleHandle, ZLibLibraryName);\r\n if Result then\r\n begin\r\n @zlibVersion := GetModuleSymbol(ZLibModuleHandle, ZLIBzlibVersionExportName);\r\n @deflateInit_ := GetModuleSymbol(ZLibModuleHandle, ZLIBdeflateInit_ExportName);\r\n @deflate := GetModuleSymbol(ZLibModuleHandle, ZLIBdeflateExportName);\r\n @deflateEnd := GetModuleSymbol(ZLibModuleHandle, ZLIBdeflateEndExportName);\r\n @inflateInit_ := GetModuleSymbol(ZLibModuleHandle, ZLIBinflateInit_ExportName);\r\n @inflate := GetModuleSymbol(ZLibModuleHandle, ZLIBinflateExportName);\r\n @inflateEnd := GetModuleSymbol(ZLibModuleHandle, ZLIBinflateEndExportName);\r\n @deflateInit2_ := GetModuleSymbol(ZLibModuleHandle, ZLIBdeflateInit2_ExportName);\r\n @deflateSetDictionary := GetModuleSymbol(ZLibModuleHandle, ZLIBdeflateSetDictionaryExportName);\r\n @deflateCopy := GetModuleSymbol(ZLibModuleHandle, ZLIBdeflateCopyExportName);\r\n @deflateReset := GetModuleSymbol(ZLibModuleHandle, ZLIBdeflateResetExportName);\r\n @deflateParams := GetModuleSymbol(ZLibModuleHandle, ZLIBdeflateParamsExportName);\r\n @deflateBound := GetModuleSymbol(ZLibModuleHandle, ZLIBdeflateBoundExportName);\r\n @deflatePending := GetModuleSymbol(ZLibModuleHandle, ZLIBdeflatePendingExportName);\r\n @deflatePrime := GetModuleSymbol(ZLibModuleHandle, ZLIBdeflatePrimeExportName);\r\n @inflateInit2_ := GetModuleSymbol(ZLibModuleHandle, ZLIBinflateInit2_ExportName);\r\n @inflateSetDictionary := GetModuleSymbol(ZLibModuleHandle, ZLIBinflateSetDictionaryExportName);\r\n @inflateSync := GetModuleSymbol(ZLibModuleHandle, ZLIBinflateSyncExportName);\r\n @inflateCopy := GetModuleSymbol(ZLibModuleHandle, ZLIBinflateCopyExportName);\r\n @inflateReset := GetModuleSymbol(ZLibModuleHandle, ZLIBinflateResetExportName);\r\n @inflateBackInit_ := GetModuleSymbol(ZLibModuleHandle, ZLIBinflateBackInit_ExportName);\r\n @inflateBack := GetModuleSymbol(ZLibModuleHandle, ZLIBinflateBackExportName);\r\n @inflateBackEnd := GetModuleSymbol(ZLibModuleHandle, ZLIBinflateBackEndExportName);\r\n @zlibCompileFlags := GetModuleSymbol(ZLibModuleHandle, ZLIBzlibCompileFlagsExportName);\r\n @compress := GetModuleSymbol(ZLibModuleHandle, ZLIBcompressExportName);\r\n @compress2 := GetModuleSymbol(ZLibModuleHandle, ZLIBcompress2ExportName);\r\n @compressBound := GetModuleSymbol(ZLibModuleHandle, ZLIBcompressBoundExportName);\r\n @uncompress := GetModuleSymbol(ZLibModuleHandle, ZLIBuncompressExportName);\r\n @adler32 := GetModuleSymbol(ZLibModuleHandle, ZLIBadler32ExportName);\r\n @crc32 := GetModuleSymbol(ZLibModuleHandle, ZLIBcrc32ExportName);\r\n @zError := GetModuleSymbol(ZLibModuleHandle, ZLIBzErrorExportName);\r\n @inflateSyncPoint := GetModuleSymbol(ZLibModuleHandle, ZLIBinflateSyncPointExportName);\r\n @get_crc_table := GetModuleSymbol(ZLibModuleHandle, ZLIBget_crc_tableExportName);\r\n end;\r\nend;\r\n{$ELSE ~ZLIB_LINKONREQUEST}\r\nbegin\r\n Result := True;\r\nend;\r\n{$ENDIF ~ZLIB_LINKONREQUEST}\r\n\r\nprocedure UnloadZLib;\r\nbegin\r\n {$IFDEF ZLIB_LINKONREQUEST}\r\n JclSysUtils.UnloadModule(ZLibModuleHandle);\r\n {$ENDIF ZLIB_LINKONREQUEST}\r\nend;\r\n\r\n{$IFNDEF ZLIB_RTL}\r\n{$IFDEF ZLIB_LINKDLL}\r\n// Core functions\r\nfunction zlibVersion; external ZLibDefaultLibraryName name ZLibzlibVersionDefaultExportName;\r\nfunction deflateInit_; external ZLibDefaultLibraryName name ZLibdeflateInit_DefaultExportName;\r\nfunction deflate; external ZLibDefaultLibraryName name ZLibdeflateDefaultExportName;\r\nfunction deflateEnd; external ZLibDefaultLibraryName name ZLibdeflateEndDefaultExportName;\r\nfunction inflateInit_; external ZLibDefaultLibraryName name ZLibinflateInit_DefaultExportName;\r\nfunction inflate; external ZLibDefaultLibraryName name ZLibinflateDefaultExportName;\r\nfunction inflateEnd; external ZLibDefaultLibraryName name ZLibinflateEndDefaultExportName;\r\nfunction deflateInit2_; external ZLibDefaultLibraryName name ZLibdeflateInit2_DefaultExportName;\r\nfunction deflateSetDictionary; external ZLibDefaultLibraryName name ZLibdeflateSetDictionaryDefaultExportName;\r\nfunction deflateCopy; external ZLibDefaultLibraryName name ZLibdeflateCopyDefaultExportName;\r\nfunction deflateReset; external ZLibDefaultLibraryName name ZLibdeflateResetDefaultExportName;\r\nfunction deflateParams; external ZLibDefaultLibraryName name ZLibdeflateParamsDefaultExportName;\r\nfunction deflateBound; external ZLibDefaultLibraryName name ZLibdeflateBoundDefaultExportName;\r\nfunction deflatePending; external ZLibDefaultLibraryName name ZLibdeflatePendingDefaultExportName;\r\nfunction deflatePrime; external ZLibDefaultLibraryName name ZLibdeflatePrimeDefaultExportName;\r\nfunction inflateInit2_; external ZLibDefaultLibraryName name ZLibinflateInit2_DefaultExportName;\r\nfunction inflateSetDictionary; external ZLibDefaultLibraryName name ZLibinflateSetDictionaryDefaultExportName;\r\nfunction inflateSync; external ZLibDefaultLibraryName name ZLibinflateSyncDefaultExportName;\r\nfunction inflateCopy; external ZLibDefaultLibraryName name ZLibinflateCopyDefaultExportName;\r\nfunction inflateReset; external ZLibDefaultLibraryName name ZLibinflateResetDefaultExportName;\r\n\r\nfunction inflateBackInit_; external ZLibDefaultLibraryName name ZLibinflateBackInit_DefaultExportName;\r\nfunction inflateBack; external ZLibDefaultLibraryName name ZLibinflateBackDefaultExportName;\r\nfunction inflateBackEnd; external ZLibDefaultLibraryName name ZLibinflateBackEndDefaultExportName;\r\nfunction zlibCompileFlags; external ZLibDefaultLibraryName name ZLibzlibCompileFlagsDefaultExportName;\r\nfunction compress; external ZLibDefaultLibraryName name ZLibcompressDefaultExportName;\r\nfunction compress2; external ZLibDefaultLibraryName name ZLibcompress2DefaultExportName;\r\nfunction compressBound; external ZLibDefaultLibraryName name ZLibcompressBoundDefaultExportName;\r\nfunction uncompress; external ZLibDefaultLibraryName name ZLibuncompressDefaultExportName;\r\n\r\n// Checksums\r\nfunction adler32; external ZLibDefaultLibraryName name ZLibadler32DefaultExportName;\r\nfunction crc32; external ZLibDefaultLibraryName name ZLibcrc32DefaultExportName;\r\n\r\nfunction zError; external ZLibDefaultLibraryName name ZLibzErrorDefaultExportName;\r\nfunction inflateSyncPoint; external ZLibDefaultLibraryName name ZLibinflateSyncPointDefaultExportName;\r\nfunction get_crc_table; external ZLibDefaultLibraryName name ZLibget_crc_tableDefaultExportName;\r\n{$ENDIF ZLIB_LINKDLL}\r\n\r\n{$ENDIF ~ZLIB_RTL}\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n\r\n" }, { "path": "External/Jedi/Jcl/source/include/crossplatform.inc", "content": "{**************************************************************************************************}\r\n{ }\r\n{ The contents of this file are subject to the Mozilla Public License Version 1.1 (the \"License\");}\r\n{ you may not use this file except in compliance with the License. You may obtain a copy of the }\r\n{ License at http://www.mozilla.org/MPL/ }\r\n{ }\r\n{ Software distributed under the License is distributed on an \"AS IS\" basis, WITHOUT WARRANTY OF }\r\n{ ANY KIND, either express or implied. See the License for the specific language governing rights }\r\n{ and limitations under the License. }\r\n{ }\r\n{ The Original Code is: crossplatform.inc, released on 2004-05-16. }\r\n{ }\r\n{ You may retrieve the latest version of this file at the JCL home page, }\r\n{ located at http://jcl.sourceforge.net/ }\r\n{ }\r\n{**************************************************************************************************}\r\n{ }\r\n{ Last modified: $Date:: 2008-08-16 13:55:02 +0200 (sam. 16 août 2008) $ }\r\n{ Revision: $Rev:: 2423 $ }\r\n{ Author: $Author:: outchy $ }\r\n{ }\r\n{**************************************************************************************************}\r\n\r\n// This inc file depends on jedi.inc which has to\r\n// be included first (usually indirectly through\r\n// the inclusion of jcl.inc).\r\n\r\n// Suppress platform warnings which are irrelevant\r\n// because the including unit inherently has to handle\r\n// platform specifics already.\r\n\r\n{$IFDEF SUPPORTS_PLATFORM_WARNINGS}\r\n {$WARN UNIT_PLATFORM OFF}\r\n {$WARN SYMBOL_PLATFORM OFF}\r\n{$ENDIF SUPPORTS_PLATFORM_WARNINGS}" }, { "path": "External/Jedi/Jcl/source/include/jcl.inc", "content": "{**************************************************************************************************}\r\n{ }\r\n{ The contents of this file are subject to the Mozilla Public License Version 1.1 (the \"License\");}\r\n{ you may not use this file except in compliance with the License. You may obtain a copy of the }\r\n{ License at http://www.mozilla.org/MPL/ }\r\n{ }\r\n{ Software distributed under the License is distributed on an \"AS IS\" basis, WITHOUT WARRANTY OF }\r\n{ ANY KIND, either express or implied. See the License for the specific language governing rights }\r\n{ and limitations under the License. }\r\n{ }\r\n{ The Original Code is jcl.inc }\r\n{ }\r\n{ The Initial Developer of the Original Code is Marcel van Brakel. }\r\n{ Portions created by Marcel van Brakel are Copyright (C) Marcel van Brakel. }\r\n{ }\r\n{ Contributors: }\r\n{ Marcel van Brakel }\r\n{ Matthias Thoma (mthoma) }\r\n{ Petr Vones }\r\n{ Robert Marquardt (marquardt) }\r\n{ Robert Rossmair (rrossmair) }\r\n{ }\r\n{**************************************************************************************************}\r\n{ }\r\n{ This include file defines various JCL specific defines. The more generic defines are defined in }\r\n{ the jedi.inc file which is shared with the JEDI VCL. }\r\n{ }\r\n{**************************************************************************************************}\r\n{ }\r\n{ Last modified: $Date:: 2012-09-04 16:08:04 +0200 (mar. 04 sept. 2012) $ }\r\n{ Revision: $Rev:: 3861 $ }\r\n{ Author: $Author:: outchy $ }\r\n{ }\r\n{**************************************************************************************************}\r\n\r\n{$BOOLEVAL OFF} // Boolean shortcut evaluation\r\n{$LONGSTRINGS ON} // Long strings\r\n{$WRITEABLECONST OFF} // Read-only typed constants\r\n{$TYPEDADDRESS OFF} // Type checked pointers off\r\n\r\n{$I jedi\\jedi.inc} // Pull in the JCL/J-VCL shared directives\r\n\r\n{$IFNDEF JEDI_INC}\r\nALERT_jedi_inc_incompatible\r\n// secure against old versions of jedi.inc.\r\n{$ENDIF ~JEDI_INC}\r\n\r\n{$IFNDEF JCLINSTALL}\r\n {$IFDEF CLR}\r\n {----------------------------}\r\n { BDS }\r\n {----------------------------}\r\n {$IFDEF BDS3}\r\n // This file should be located in directory jcl/source/include\r\n // It is automatically created by the JCL installer\r\n // For manual installations, copy and adjust jcl/source/include/jcl.template.inc\r\n {$I jcld9.net.inc}\r\n {$DEFINE JCL_CONFIGURED}\r\n {$ENDIF BDS3}\r\n {----------------------------}\r\n {$IFDEF BDS4}\r\n // This file should be located in directory jcl/source/include\r\n // It is automatically created by the JCL installer\r\n // For manual installations, copy and adjust jcl/source/include/jcl.template.inc\r\n {$I jcld10.net.inc}\r\n {$DEFINE JCL_CONFIGURED}\r\n {$ENDIF BDS4}\r\n {----------------------------}\r\n {$IFDEF BDS5}\r\n // This file should be located in directory jcl/source/include\r\n // It is automatically created by the JCL installer\r\n // For manual installations, copy and adjust jcl/source/include/jcl.template.inc\r\n {$I jcld11.net.inc}\r\n {$DEFINE JCL_CONFIGURED}\r\n {$ENDIF BDS5}\r\n {----------------------------}\r\n {$ELSE ~CLR}\r\n {----------------------------}\r\n { C++Builder }\r\n {----------------------------}\r\n {$IFDEF BCB5}\r\n // This file should be located in directory jcl/source/include\r\n // It is automatically created by the JCL installer\r\n // For manual installations, copy and adjust jcl/source/include/jcl.template.inc\r\n {$I jclc5.inc}\r\n {$DEFINE JCL_CONFIGURED}\r\n {$ENDIF BCB5}\r\n {----------------------------}\r\n {$IFDEF BCB6}\r\n // This file should be located in directory jcl/source/include\r\n // It is automatically created by the JCL installer\r\n // For manual installations, copy and adjust jcl/source/include/jcl.template.inc\r\n {$I jclc6.inc}\r\n {$DEFINE JCL_CONFIGURED}\r\n {$ENDIF BCB6}\r\n {----------------------------}\r\n { Delphi }\r\n {----------------------------}\r\n {$IFDEF DELPHI5}\r\n // This file should be located in directory jcl/source/include\r\n // It is automatically created by the JCL installer\r\n // For manual installations, copy and adjust jcl/source/include/jcl.template.inc\r\n {$I jcld5.inc}\r\n {$DEFINE JCL_CONFIGURED}\r\n {$ENDIF DELPIH5}\r\n {----------------------------}\r\n {$IFDEF DELPHI6}\r\n // This file should be located in directory jcl/source/include\r\n // It is automatically created by the JCL installer\r\n // For manual installations, copy and adjust jcl/source/include/jcl.template.inc\r\n {$I jcld6.inc}\r\n {$DEFINE JCL_CONFIGURED}\r\n {$ENDIF DELPIH6}\r\n {----------------------------}\r\n {$IFDEF DELPHI7}\r\n // This file should be located in directory jcl/source/include\r\n // It is automatically created by the JCL installer\r\n // For manual installations, copy and adjust jcl/source/include/jcl.template.inc\r\n {$I jcld7.inc}\r\n {$DEFINE JCL_CONFIGURED}\r\n {$ENDIF DELPIH7}\r\n {----------------------------}\r\n { BDS }\r\n {----------------------------}\r\n // BDS 1 and BDS 2 have the same version numbers for their native compilers\r\n // no compiler defines are used for BDS 1 and BDS 2\r\n {$IFDEF BDS1}\r\n // This file should be located in directory jcl/source/include\r\n // It is automatically created by the JCL installer\r\n // For manual installations, copy and adjust jcl/source/include/jcl.template.inc\r\n //{$I jclcs1.inc}\r\n {$DEFINE JCL_CONFIGURED}\r\n {$ENDIF BDS1}\r\n {----------------------------}\r\n {$IFDEF BDS2}\r\n // This file should be located in directory jcl/source/include\r\n // It is automatically created by the JCL installer\r\n // For manual installations, copy and adjust jcl/source/include/jcl.template.inc\r\n //{$I jcld8.inc}\r\n {$DEFINE JCL_CONFIGURED}\r\n {$ENDIF BDS2}\r\n {----------------------------}\r\n {$IFDEF BDS3}\r\n // This file should be located in directory jcl/source/include\r\n // It is automatically created by the JCL installer\r\n // For manual installations, copy and adjust jcl/source/include/jcl.template.inc\r\n {$I jcld9.inc}\r\n {$DEFINE JCL_CONFIGURED}\r\n {$ENDIF BDS3}\r\n {----------------------------}\r\n {$IFDEF BDS4}\r\n // This file should be located in directory jcl/source/include\r\n // It is automatically created by the JCL installer\r\n // For manual installations, copy and adjust jcl/source/include/jcl.template.inc\r\n {$I jcld10.inc}\r\n {$DEFINE JCL_CONFIGURED}\r\n {$ENDIF BDS4}\r\n {----------------------------}\r\n {$IFDEF BDS5}\r\n // This file should be located in directory jcl/source/include\r\n // It is automatically created by the JCL installer\r\n // For manual installations, copy and adjust jcl/source/include/jcl.template.inc\r\n {$I jcld11.inc}\r\n {$DEFINE JCL_CONFIGURED}\r\n {$ENDIF BDS5}\r\n {----------------------------}\r\n {$IFDEF BDS6}\r\n // This file should be located in directory jcl/source/include\r\n // It is automatically created by the JCL installer\r\n // For manual installations, copy and adjust jcl/source/include/jcl.template.inc\r\n {$I jcld12.inc}\r\n {$DEFINE JCL_CONFIGURED}\r\n {$ENDIF BDS6}\r\n {----------------------------}\r\n {$IFDEF BDS7}\r\n // This file should be located in directory jcl/source/include\r\n // It is automatically created by the JCL installer\r\n // For manual installations, copy and adjust jcl/source/include/jcl.template.inc\r\n {$I jcld14.inc}\r\n {$DEFINE JCL_CONFIGURED}\r\n {$ENDIF BDS7}\r\n {----------------------------}\r\n {$IFDEF BDS8}\r\n // This file should be located in directory jcl/source/include\r\n // It is automatically created by the JCL installer\r\n // For manual installations, copy and adjust jcl/source/include/jcl.template.inc\r\n {$I jcld15.inc}\r\n {$DEFINE JCL_CONFIGURED}\r\n {$ENDIF BDS8}\r\n {----------------------------}\r\n {$IFDEF BDS9}\r\n {$IFDEF MSWINDOWS}\r\n {$IFDEF CPUX86}\r\n // This file should be located in directory jcl/source/include\r\n // It is automatically created by the JCL installer\r\n // For manual installations, copy and adjust jcl/source/include/jcl.template.inc\r\n {$I jcld16win32.inc}\r\n {$ENDIF CPUX86}\r\n {$IFDEF CPUX64}\r\n // This file should be located in directory jcl/source/include\r\n // It is automatically created by the JCL installer\r\n // For manual installations, copy and adjust jcl/source/include/jcl.template.inc\r\n {$I jcld16win64.inc}\r\n {$ENDIF CPUX64}\r\n {$DEFINE JCL_CONFIGURED}\r\n {$ENDIF MSWINDOWS}\r\n {$ENDIF BDS9}\r\n {----------------------------}\r\n {$IFDEF BDS10}\r\n {$IFDEF MSWINDOWS}\r\n {$IFDEF CPUX86}\r\n // This file should be located in directory jcl/source/include\r\n // It is automatically created by the JCL installer\r\n // For manual installations, copy and adjust jcl/source/include/jcl.template.inc\r\n {$I jcld17win32.inc}\r\n {$ENDIF CPUX86}\r\n {$IFDEF CPUX64}\r\n // This file should be located in directory jcl/source/include\r\n // It is automatically created by the JCL installer\r\n // For manual installations, copy and adjust jcl/source/include/jcl.template.inc\r\n {$I jcld17win64.inc}\r\n {$ENDIF CPUX64}\r\n {$DEFINE JCL_CONFIGURED}\r\n {$ENDIF MSWINDOWS}\r\n {$ENDIF BDS10}\r\n {----------------------------}\r\n {$IFDEF FPC}\r\n // This file should be located in directory jcl/source/include\r\n // It is automatically created by the JCL installer\r\n // For manual installations, copy and adjust jcl/source/include/jcl.template.inc\r\n {$I jclfpc.inc}\r\n {$DEFINE JCL_CONFIGURED}\r\n {$ENDIF FPC}\r\n {----------------------------}\r\n {$ENDIF ~CLR}\r\n\r\n // check configuration\r\n {$IFNDEF JCL_CONFIGURED}\r\n {$IFDEF SUPPORTS_COMPILETIME_MESSAGES}\r\n {$MESSAGE FATAL 'Your Delphi/BCB version is not supported by this JCL version!'}\r\n {$ELSE ~SUPPORTS_COMPILETIME_MESSAGES}\r\n 'Your Delphi/BCB version is not supported by this JCL version!'\r\n {$ENDIF ~SUPPORTS_COMPILETIME_MESSAGES}\r\n {$ENDIF !JCL_CONFIGURED}\r\n\r\n{$ENDIF ~JCLINSTALL}\r\n\r\n// Math precision selection, mutually exclusive\r\n{$IFDEF MATH_EXTENDED_PRECISION}\r\n {$UNDEF MATH_SINGLE_PRECISION}\r\n {$UNDEF MATH_DOUBLE_PRECISION}\r\n{$ENDIF}\r\n{$IFDEF MATH_DOUBLE_PRECISION}\r\n {$UNDEF MATH_SINGLE_PRECISION}\r\n {$UNDEF MATH_EXTENDED_PRECISION}\r\n{$ENDIF}\r\n{$IFDEF MATH_SINGLE_PRECISION}\r\n {$UNDEF MATH_DOUBLE_PRECISION}\r\n {$UNDEF MATH_EXTENDED_PRECISION}\r\n{$ENDIF}\r\n\r\n{$IFNDEF MATH_EXTENDED_PRECISION}\r\n {$IFNDEF MATH_DOUBLE_PRECISION}\r\n {$IFNDEF MATH_SINGLE_PRECISION}\r\n {$IFDEF FPC}\r\n {$IFDEF CPU64}\r\n {$DEFINE MATH_DOUBLE_PRECISION}\r\n {$ELSE ~CPU64}\r\n {$DEFINE MATH_EXTENDED_PRECISION}\r\n {$ENDIF ~CPU64}\r\n {$ELSE ~FPC}\r\n {$DEFINE MATH_EXTENDED_PRECISION}\r\n {$ENDIF ~FPC}\r\n {$ENDIF}\r\n {$ENDIF}\r\n{$ENDIF}\r\n\r\n{$IFDEF MATH_EXTENDED_PRECISION}\r\n {$IFDEF CPU64}\r\n {$IFDEF FPC}\r\n {$MESSAGE FATAL 'FPC does not support extended floating points on x86_64!'}\r\n {$ENDIF FPC}\r\n {$ENDIF CPU64}\r\n{$ENDIF MATH_EXTENDED_PRECISION}\r\n\r\n// PCRE options, mutually exclusive\r\n{$IFDEF PCRE_STATICLINK}\r\n {$UNDEF PCRE_LINKDLL}\r\n {$UNDEF PCRE_LINKONREQUEST}\r\n {$UNDEF PCRE_RTL}\r\n{$ENDIF PCRE_STATICLINK}\r\n{$IFDEF PCRE_LINKDLL}\r\n {$UNDEF PCRE_LINKONREQUEST}\r\n {$UNDEF PCRE_RTL}\r\n{$ENDIF PCRE_LINKDLL}\r\n{$IFDEF PCRE_LINKONREQUEST}\r\n {$UNDEF PCRE_RTL}\r\n{$ENDIF PCRE_LINKONREQUEST}\r\n\r\n{$IFNDEF PCRE_STATICLINK}\r\n {$IFNDEF PCRE_LINKDLL}\r\n {$IFNDEF PCRE_LINKONREQUEST}\r\n {$IFNDEF PCRE_RTL}\r\n {$DEFINE PCRE_LINKONREQUEST}\r\n {$ENDIF ~PCRE_RTL}\r\n {$ENDIF ~PCRE_LINKONREQUEST}\r\n {$ENDIF ~PCRE_LINKDLL}\r\n{$ENDIF ~PCRE_STATICLINK}\r\n\r\n{$IFNDEF PCRE_STATICLINK}\r\n {$IFNDEF PCRE_RTL}\r\n {$DEFINE PCRE_EXPORT_CDECL}\r\n {$ENDIF ~PCRE_RTL}\r\n{$ENDIF ~PCRE_STATICLINK}\r\n\r\n{$IFNDEF PCRE_STATICLINK}\r\n {$UNDEF PCRE_16}\r\n{$ENDIF ~PCRE_STATICLINK}\r\n\r\n{$IFNDEF PCRE_8}\r\n {$IFNDEF PCRE_16}\r\n {$DEFINE PCRE_RTL}\r\n {$UNDEF PCRE_STATICLINK}\r\n {$UNDEF PCRE_LINKDLL}\r\n {$UNDEF PCRE_LINKONREQUEST}\r\n {$ENDIF ~PCRE_16}\r\n{$ENDIF ~PCRE_8}\r\n\r\n{$IFDEF PCRE_8}\r\n {$IFDEF PCRE_16}\r\n {$IFDEF PCRE_PREFER_16}\r\n {$DEFINE JCL_PCRE_16}\r\n {$ELSE ~PCRE_PREFER_16}\r\n {$DEFINE JCL_PCRE_8}\r\n {$ENDIF ~PCRE_PREFER_16}\r\n {$ELSE ~PCRE_16}\r\n {$DEFINE JCL_PCRE_8}\r\n {$ENDIF ~PCRE_16}\r\n{$ELSE ~PCRE_8}\r\n {$IFDEF PCRE_16}\r\n {$DEFINE JCL_PCRE_16}\r\n {$ENDIF PCRE_16}\r\n{$ENDIF ~PCRE_8}\r\n\r\n{$IFDEF JCL_PCRE_8}\r\n {$DEFINE JCL_PCRE}\r\n{$ENDIF JCL_PCRE_8}\r\n\r\n{$IFDEF JCL_PCRE_16}\r\n {$DEFINE JCL_PCRE}\r\n{$ENDIF JCL_PCRE_16}\r\n\r\n// BZip2 options\r\n{$IFDEF BZIP2_STATICLINK}\r\n {$UNDEF BZIP2_LINKDLL}\r\n {$UNDEF BZIP2_LINKONREQUEST}\r\n{$ENDIF BZIP2_STATICLINK}\r\n{$IFDEF BZIP2_LINKDLL}\r\n {$UNDEF BZIP2_LINKONREQUEST}\r\n{$ENDIF BZIP2_LINKDLL}\r\n\r\n{$IFNDEF BZIP2_STATICLINK}\r\n {$IFNDEF BZIP2_LINKDLL}\r\n {$IFNDEF BZIP2_LINKONREQUEST}\r\n {$DEFINE BZIP2_STATICLINK}\r\n {$ENDIF ~BZIP2_LINKONREQUEST}\r\n {$ENDIF ~BZIP2_LINKDLL}\r\n{$ENDIF ~BZIP2_STATICLINK}\r\n\r\n{$IFDEF BZIP2_STATICLINK}\r\n {$DEFINE BZIP2_EXPORT_STDCALL}\r\n{$ENDIF BZIP2_STATICLINK}\r\n\r\n{$IFDEF BZIP2_LINKDLL}\r\n {$DEFINE BZIP2_EXPORT_CDECL}\r\n{$ENDIF BZIP2_LINKDLL}\r\n\r\n{$IFDEF BZIP2_LINKONREQUEST}\r\n {$DEFINE BZIP2_EXPORT_CDECL}\r\n{$ENDIF BZIP2_LINKONREQUEST}\r\n\r\n\r\n// ZLib options\r\n{$IFDEF ZLIB_STATICLINK}\r\n {$UNDEF ZLIB_LINKDLL}\r\n {$UNDEF ZLIB_LINKONREQUEST}\r\n {$UNDEF ZLIB_RTL}\r\n{$ENDIF ZLIB_STATICLINK}\r\n{$IFDEF ZLIB_LINKDLL}\r\n {$UNDEF ZLIB_LINKONREQUEST}\r\n {$UNDEF ZLIB_RTL}\r\n{$ENDIF ZLIB_LINKDLL}\r\n{$IFDEF ZLIB_LINKONREQUEST}\r\n {$UNDEF ZLIB_RTL}\r\n{$ENDIF ZLIB_LINKONREQUEST}\r\n\r\n{$IFNDEF ZLIB_STATICLINK}\r\n {$IFNDEF ZLIB_LINKDLL}\r\n {$IFNDEF ZLIB_LINKONREQUEST}\r\n {$IFNDEF ZLIB_RTL}\r\n {$DEFINE ZLIB_STATICLINK}\r\n {$ENDIF ~ZLIB_RTL}\r\n {$ENDIF ~ZLIB_LINKONREQUEST}\r\n {$ENDIF ~ZLIB_LINKDLL}\r\n{$ENDIF ~ZLIB_STATICLINK}\r\n\r\n{$IFDEF ZLIB_LINKDLL}\r\n {$DEFINE ZLIB_EXPORT_CDECL}\r\n{$ENDIF ZLIB_LINKDLL}\r\n{$IFDEF ZLIB_LINKONREQUEST}\r\n {$DEFINE ZLIB_EXPORT_CDECL}\r\n{$ENDIF ZLIB_LINKONREQUEST}\r\n// calling convention for static link is fastcall\r\n\r\n{$IFNDEF HAS_UNIT_CHARACTER}\r\n {$UNDEF UNICODE_RTL_DATABASE}\r\n{$ENDIF ~HAS_UNIT_CHARACTER}\r\n\r\n{$IFDEF UNICODE_RAW_DATA}\r\n {$UNDEF UNICODE_ZLIB_DATA}\r\n {$UNDEF UNICODE_BZIP2_DATA}\r\n{$ENDIF UNICODE_RAW_DATA}\r\n\r\n{$IFDEF UNICODE_ZLIB_DATA}\r\n {$UNDEF UNICODE_RAW_DATA}\r\n {$UNDEF UNICODE_BZIP2_DATA}\r\n{$ENDIF UNICODE_ZLIB_DATA}\r\n\r\n{$IFNDEF UNICODE_ZLIB_DATA}\r\n {$IFNDEF UNICODE_BZIP2_DATA}\r\n {$DEFINE UNICODE_RAW_DATA}\r\n {$ENDIF ~UNICODE_BZIP2_DATA}\r\n{$ENDIF ~UNICODE_ZLIB_DATA}\r\n\r\n{$IFDEF CONTAINER_ANSISTR}\r\n {$UNDEF CONTAINER_WIDESTR}\r\n {$UNDEF CONTAINER_UNICODESTR}\r\n {$UNDEF CONTAINER_NOSTR}\r\n{$ENDIF CONTAINER_ANSISTR}\r\n\r\n{$IFDEF CONTAINER_WIDESTR}\r\n {$UNDEF CONTAINER_UNICODESTR}\r\n {$UNDEF CONTAINER_NOSTR}\r\n{$ENDIF CONTAINER_WIDESTR}\r\n\r\n{$IFDEF CONTAINER_UNICODESTR}\r\n {$UNDEF CONTAINER_NOSTR}\r\n{$ENDIF CONTAINER_UNICODESTR}\r\n\r\n{$IFNDEF CONTAINER_ANSISTR}\r\n {$IFNDEF CONTAINER_WIDESTR}\r\n {$IFNDEF CONTAINER_UNICODESTR}\r\n {$IFNDEF CONTAINER_NOSTR}\r\n {$IFDEF SUPPORTS_UNICODE_STRING}\r\n {$DEFINE CONTAINER_UNICODESTR}\r\n {$ELSE ~SUPPORTS_UNICODE_STRING}\r\n {$DEFINE CONTAINER_ANSISTR}\r\n {$ENDIF ~SUPPORTS_UNICODE_STRING}\r\n {$ENDIF ~CONTAINER_NOSTR}\r\n {$ENDIF ~CONTAINER_UNICODESTR}\r\n {$ENDIF ~CONTAINER_WIDESTR}\r\n{$ENDIF ~CONTAINER_ANSISTR}\r\n\r\n// 7zip options\r\n{$IFDEF 7ZIP_STATICLINK}\r\n {$UNDEF 7ZIP_LINKDLL}\r\n {$UNDEF 7ZIP_LINKONREQUEST}\r\n{$ENDIF 7ZIP_STATICLINK}\r\n\r\n{$IFDEF 7ZIP_LINKDLL}\r\n {$UNDEF 7ZIP_LINKONREQUEST}\r\n{$ENDIF 7ZIP_LINKDLL}\r\n\r\n{$IFNDEF 7ZIP_STATICLINK}\r\n {$IFNDEF 7ZIP_LINKDLL}\r\n {$IFNDEF 7ZIP_LINKONREQUEST}\r\n {$DEFINE 7ZIP_LINKONREQUEST}\r\n {$ENDIF ~7ZIP_LINKONREQUEST}\r\n {$ENDIF ~7ZIP_LINKDLL}\r\n{$ENDIF ~7ZIP_STATICLINK}\r\n\r\n{$IFDEF SUPPORTS_UNSAFE_WARNINGS}\r\n {$WARN UNSAFE_TYPE OFF}\r\n {$WARN UNSAFE_CODE OFF}\r\n {$WARN UNSAFE_CAST OFF}\r\n{$ENDIF}\r\n\r\n{$IFNDEF DROP_OBSOLETE_CODE}\r\n {$IFNDEF JCLINSTALL}\r\n {$DEFINE KEEP_DEPRECATED}\r\n {$ENDIF}\r\n{$ENDIF}\r\n\r\n{$IFDEF CLR}\r\n {$WARN UNSAFE_TYPE ON}\r\n {$WARN UNSAFE_CODE ON}\r\n {$WARN UNSAFE_CAST ON}\r\n {$WARN UNIT_PLATFORM OFF}\r\n\r\n {$DEFINE MSWINDOWS}\r\n {$DEFINE PIC}\r\n {$DEFINE PUREPASCAL}\r\n{$ENDIF CLR}\r\n\r\n// Delphi 2005 has a compiler internal failure when compiling the JCL with UNITVERSIONING enabled\r\n{$IFDEF DELPHI2005}\r\n {$UNDEF UNITVERSIONING}\r\n{$ENDIF DELPHI2005}\r\n\r\n{$IFDEF FPC}\r\n {$DEFINE DEBUG_NO_TD32}\r\n{$ENDIF FPC}\r\n\r\n" }, { "path": "External/Jedi/Jcl/source/include/jcl.template.inc", "content": "{**************************************************************************************************}\r\n{ }\r\n{ Project JEDI Code Library (JCL) }\r\n{ }\r\n{ The contents of this file are subject to the Mozilla Public License Version 1.1 (the \"License\"); }\r\n{ you may not use this file except in compliance with the License. You may obtain a copy of the }\r\n{ License at http://www.mozilla.org/MPL/ }\r\n{ }\r\n{ Software distributed under the License is distributed on an \"AS IS\" basis, WITHOUT WARRANTY OF }\r\n{ ANY KIND, either express or implied. See the License for the specific language governing rights }\r\n{ and limitations under the License. }\r\n{ }\r\n{ The Original Code is jcl.inc }\r\n{ }\r\n{ The Initial Developer of the Original Code is Marcel van Brakel. }\r\n{ Portions created by Marcel van Brakel are Copyright (C) Marcel van Brakel. }\r\n{ }\r\n{ Contributors: }\r\n{ Marcel van Brakel }\r\n{ Matthias Thoma (mthoma) }\r\n{ Petr Vones }\r\n{ Robert Marquardt (marquardt) }\r\n{ Robert Rossmair (rrossmair) }\r\n{ Florent Ouchet (outchy) }\r\n{ }\r\n{**************************************************************************************************}\r\n{ }\r\n{ This include file defines various JCL specific defines. }\r\n{ The more generic JCL defines are defined in jcl.inc and the generic defines in the jedi.inc file }\r\n{ which is shared with the JEDI VCL. }\r\n{ }\r\n{**************************************************************************************************}\r\n{ }\r\n{ This file is filled by the JCL installer, all the changes made in its content will be lost the }\r\n{ next time the JCL is installed. }\r\n{ }\r\n{**************************************************************************************************}\r\n\r\n// $Id: jcl.template.inc 3855 2012-09-02 22:25:26Z outchy $\r\n\r\n// Math precision selection, mutually exclusive\r\n// FPC does not support EXTENDED when targetting x86_64, MATH_DOUBLE_PRECISION is the default in this situation\r\n{.$DEFINE MATH_EXTENDED_PRECISION} // default\r\n{.$DEFINE MATH_DOUBLE_PRECISION}\r\n{.$DEFINE MATH_SINGLE_PRECISION}\r\n\r\n\r\n// Math functions takes care of infinites and NaN\r\n{.$DEFINE MATH_EXT_EXTREMEVALUES}\r\n\r\n\r\n// JclHookExcept support for hooking exceptions from DLLs\r\n{.$DEFINE HOOK_DLL_EXCEPTIONS}\r\n\r\n\r\n//Threadsafe directive\r\n{.$DEFINE THREADSAFE}\r\n\r\n\r\n// To exclude obsolete code from compilation, remove the point from the line below\r\n{.$DEFINE DROP_OBSOLETE_CODE}\r\n\r\n\r\n//Support for JclUnitVersioning.pas, not supported by Delphi 2005 (automatically disabled afterward)\r\n{.$DEFINE UNITVERSIONING}\r\n\r\n\r\n// debug sources\r\n// defining these symbols will the debug source to be automatically registered\r\n{.$DEFINE DEBUG_NO_BINARY}\r\n{.$DEFINE DEBUG_NO_TD32} // automatically defined for FPC\r\n{.$DEFINE DEBUG_NO_MAP}\r\n{.$DEFINE DEBUG_NO_EXPORTS}\r\n{.$DEFINE DEBUG_NO_SYMBOLS}\r\n\r\n\r\n// PCRE options, mutually exclusive\r\n// IMPORTANT: The static link works only for Delphi 2005 and newer\r\n// (an internal error is raised on other compilers)\r\n// Only one of the following defines can be defined at a time\r\n// static link: PCRE_STATICLINK\r\n// static dll import: PCRE_LINKDLL\r\n// dynamic dll import: PCRE_LINKONREQUEST\r\n// RTL's RegularExpressionsAPI: PCRE_RTL\r\n\r\n{.$DEFINE PCRE_STATICLINK}\r\n{.$DEFINE PCRE_LINKDLL}\r\n{.$DEFINE PCRE_LINKONREQUEST} // default\r\n{.$DEFINE PCRE_RTL} // DXE and newer\r\n\r\n// ANSI/UTF8 PCRE\r\n{$DEFINE PCRE_8}\r\n// UCS2/UTF16 enabled PCRE\r\n{$DEFINE PCRE_16} // only valid when PCRE_STATICLINK is enabled, the RTL does not support it and the DLL found over the internet are completly outdated.\r\n\r\n// use PCRE16 when available rather than good old PCRE8\r\n{$DEFINE PCRE_PREFER_16}\r\n\r\n// BZIP2 options, mutually exclusive\r\n\r\n{.$DEFINE BZIP2_STATICLINK} // default\r\n{.$DEFINE BZIP2_LINKDLL}\r\n{.$DEFINE BZIP2_LINKONREQUEST}\r\n\r\n\r\n// ZLIB options, mutually exclusive\r\n\r\n{.$DEFINE ZLIB_STATICLINK} // default\r\n{.$DEFINE ZLIB_LINKDLL}\r\n{.$DEFINE ZLIB_LINKONREQUEST}\r\n{.$DEFINE ZLIB_RTL} // DXE2 and newer only\r\n\r\n\r\n// Unicode options\r\n// use RTL Character Database rather than JCL one, less accurate but reduce executable size\r\n{.$DEFINE UNICODE_RTL_DATABASE}\r\n\r\n// insert a replacement character if sequence is corrupted rather than raising an exception\r\n{.$DEFINE UNICODE_SILENT_FAILURE}\r\n\r\n// defines resource compression (uncompressed, compressed with ZLib, compressed with BZip2), mutually exclusive\r\n{.$DEFINE UNICODE_RAW_DATA} // default\r\n{.$DEFINE UNICODE_ZLIB_DATA}\r\n{.$DEFINE UNICODE_BZIP2_DATA}\r\n\r\n\r\n// container options\r\n// define mapping of TJclStr* containers to TJclAnsiStr* or TJclWideStr* (mutually exclusive)\r\n{.$DEFINE CONTAINER_ANSISTR} // default for D2007 and older\r\n{.$DEFINE CONTAINER_WIDESTR}\r\n{.$DEFINE CONTAINER_UNICODESTR} // default for D2009 and newer, not supported for Delphi 2007 and older\r\n{.$DEFINE CONTAINER_NOSTR}\r\n\r\n\r\n// 7Zip options, mutually exclusive\r\n// IMPORTANT: The static link is not supported yet\r\n\r\n{.$DEFINE 7ZIP_STATICLINK} // not supported yet\r\n{.$DEFINE 7ZIP_LINKDLL}\r\n{.$DEFINE 7ZIP_LINKONREQUEST} // default\r\n\r\n" }, { "path": "External/Jedi/Jcl/source/include/jcld17win32.inc", "content": "{**************************************************************************************************}\r\n{ }\r\n{ Project JEDI Code Library (JCL) }\r\n{ }\r\n{ The contents of this file are subject to the Mozilla Public License Version 1.1 (the \"License\"); }\r\n{ you may not use this file except in compliance with the License. You may obtain a copy of the }\r\n{ License at http://www.mozilla.org/MPL/ }\r\n{ }\r\n{ Software distributed under the License is distributed on an \"AS IS\" basis, WITHOUT WARRANTY OF }\r\n{ ANY KIND, either express or implied. See the License for the specific language governing rights }\r\n{ and limitations under the License. }\r\n{ }\r\n{ The Original Code is jcl.inc }\r\n{ }\r\n{ The Initial Developer of the Original Code is Marcel van Brakel. }\r\n{ Portions created by Marcel van Brakel are Copyright (C) Marcel van Brakel. }\r\n{ }\r\n{ Contributors: }\r\n{ Marcel van Brakel }\r\n{ Matthias Thoma (mthoma) }\r\n{ Petr Vones }\r\n{ Robert Marquardt (marquardt) }\r\n{ Robert Rossmair (rrossmair) }\r\n{ Florent Ouchet (outchy) }\r\n{ }\r\n{**************************************************************************************************}\r\n{ }\r\n{ This include file defines various JCL specific defines. }\r\n{ The more generic JCL defines are defined in jcl.inc and the generic defines in the jedi.inc file }\r\n{ which is shared with the JEDI VCL. }\r\n{ }\r\n{**************************************************************************************************}\r\n{ }\r\n{ This file is filled by the JCL installer, all the changes made in its content will be lost the }\r\n{ next time the JCL is installed. }\r\n{ }\r\n{**************************************************************************************************}\r\n\r\n// $Id: jcl.template.inc 3855 2012-09-02 22:25:26Z outchy $\r\n\r\n// Math precision selection, mutually exclusive\r\n// FPC does not support EXTENDED when targetting x86_64, MATH_DOUBLE_PRECISION is the default in this situation\r\n{$DEFINE MATH_EXTENDED_PRECISION} // default\r\n{.$DEFINE MATH_DOUBLE_PRECISION}\r\n{.$DEFINE MATH_SINGLE_PRECISION}\r\n\r\n\r\n// Math functions takes care of infinites and NaN\r\n{$DEFINE MATH_EXT_EXTREMEVALUES}\r\n\r\n\r\n// JclHookExcept support for hooking exceptions from DLLs\r\n{.$DEFINE HOOK_DLL_EXCEPTIONS}\r\n\r\n\r\n//Threadsafe directive\r\n{$DEFINE THREADSAFE}\r\n\r\n\r\n// To exclude obsolete code from compilation, remove the point from the line below\r\n{$DEFINE DROP_OBSOLETE_CODE}\r\n\r\n\r\n//Support for JclUnitVersioning.pas, not supported by Delphi 2005 (automatically disabled afterward)\r\n{$DEFINE UNITVERSIONING}\r\n\r\n\r\n// debug sources\r\n// defining these symbols will the debug source to be automatically registered\r\n{.$DEFINE DEBUG_NO_BINARY}\r\n{.$DEFINE DEBUG_NO_TD32} // automatically defined for FPC\r\n{.$DEFINE DEBUG_NO_MAP}\r\n{.$DEFINE DEBUG_NO_EXPORTS}\r\n{.$DEFINE DEBUG_NO_SYMBOLS}\r\n\r\n\r\n// PCRE options, mutually exclusive\r\n// IMPORTANT: The static link works only for Delphi 2005 and newer\r\n// (an internal error is raised on other compilers)\r\n// Only one of the following defines can be defined at a time\r\n// static link: PCRE_STATICLINK\r\n// static dll import: PCRE_LINKDLL\r\n// dynamic dll import: PCRE_LINKONREQUEST\r\n// RTL's RegularExpressionsAPI: PCRE_RTL\r\n\r\n{$DEFINE PCRE_STATICLINK}\r\n{.$DEFINE PCRE_LINKDLL}\r\n{.$DEFINE PCRE_LINKONREQUEST} // default\r\n{.$DEFINE PCRE_RTL} // DXE and newer\r\n\r\n// ANSI/UTF8 PCRE\r\n{$DEFINE PCRE_8}\r\n// UCS2/UTF16 enabled PCRE\r\n{.$DEFINE PCRE_16} // only valid when PCRE_STATICLINK is enabled, the RTL does not support it and the DLL found over the internet are completly outdated.\r\n\r\n// use PCRE16 when available rather than good old PCRE8\r\n{.$DEFINE PCRE_PREFER_16}\r\n\r\n// BZIP2 options, mutually exclusive\r\n\r\n{$DEFINE BZIP2_STATICLINK} // default\r\n{.$DEFINE BZIP2_LINKDLL}\r\n{.$DEFINE BZIP2_LINKONREQUEST}\r\n\r\n\r\n// ZLIB options, mutually exclusive\r\n\r\n{$DEFINE ZLIB_STATICLINK} // default\r\n{.$DEFINE ZLIB_LINKDLL}\r\n{.$DEFINE ZLIB_LINKONREQUEST}\r\n{.$DEFINE ZLIB_RTL} // DXE2 and newer only\r\n\r\n\r\n// Unicode options\r\n// use RTL Character Database rather than JCL one, less accurate but reduce executable size\r\n{.$DEFINE UNICODE_RTL_DATABASE}\r\n\r\n// insert a replacement character if sequence is corrupted rather than raising an exception\r\n{$DEFINE UNICODE_SILENT_FAILURE}\r\n\r\n// defines resource compression (uncompressed, compressed with ZLib, compressed with BZip2), mutually exclusive\r\n{$DEFINE UNICODE_RAW_DATA} // default\r\n{.$DEFINE UNICODE_ZLIB_DATA}\r\n{.$DEFINE UNICODE_BZIP2_DATA}\r\n\r\n\r\n// container options\r\n// define mapping of TJclStr* containers to TJclAnsiStr* or TJclWideStr* (mutually exclusive)\r\n{.$DEFINE CONTAINER_ANSISTR} // default for D2007 and older\r\n{.$DEFINE CONTAINER_WIDESTR}\r\n{$DEFINE CONTAINER_UNICODESTR} // default for D2009 and newer, not supported for Delphi 2007 and older\r\n{.$DEFINE CONTAINER_NOSTR}\r\n\r\n\r\n// 7Zip options, mutually exclusive\r\n// IMPORTANT: The static link is not supported yet\r\n\r\n{.$DEFINE 7ZIP_STATICLINK} // not supported yet\r\n{.$DEFINE 7ZIP_LINKDLL}\r\n{$DEFINE 7ZIP_LINKONREQUEST} // default\r\n\r\n" }, { "path": "External/Jedi/Jcl/source/include/jcld17win64.inc", "content": "{**************************************************************************************************}\r\n{ }\r\n{ Project JEDI Code Library (JCL) }\r\n{ }\r\n{ The contents of this file are subject to the Mozilla Public License Version 1.1 (the \"License\"); }\r\n{ you may not use this file except in compliance with the License. You may obtain a copy of the }\r\n{ License at http://www.mozilla.org/MPL/ }\r\n{ }\r\n{ Software distributed under the License is distributed on an \"AS IS\" basis, WITHOUT WARRANTY OF }\r\n{ ANY KIND, either express or implied. See the License for the specific language governing rights }\r\n{ and limitations under the License. }\r\n{ }\r\n{ The Original Code is jcl.inc }\r\n{ }\r\n{ The Initial Developer of the Original Code is Marcel van Brakel. }\r\n{ Portions created by Marcel van Brakel are Copyright (C) Marcel van Brakel. }\r\n{ }\r\n{ Contributors: }\r\n{ Marcel van Brakel }\r\n{ Matthias Thoma (mthoma) }\r\n{ Petr Vones }\r\n{ Robert Marquardt (marquardt) }\r\n{ Robert Rossmair (rrossmair) }\r\n{ Florent Ouchet (outchy) }\r\n{ }\r\n{**************************************************************************************************}\r\n{ }\r\n{ This include file defines various JCL specific defines. }\r\n{ The more generic JCL defines are defined in jcl.inc and the generic defines in the jedi.inc file }\r\n{ which is shared with the JEDI VCL. }\r\n{ }\r\n{**************************************************************************************************}\r\n{ }\r\n{ This file is filled by the JCL installer, all the changes made in its content will be lost the }\r\n{ next time the JCL is installed. }\r\n{ }\r\n{**************************************************************************************************}\r\n\r\n// $Id: jcl.template.inc 3855 2012-09-02 22:25:26Z outchy $\r\n\r\n// Math precision selection, mutually exclusive\r\n// FPC does not support EXTENDED when targetting x86_64, MATH_DOUBLE_PRECISION is the default in this situation\r\n{$DEFINE MATH_EXTENDED_PRECISION} // default\r\n{.$DEFINE MATH_DOUBLE_PRECISION}\r\n{.$DEFINE MATH_SINGLE_PRECISION}\r\n\r\n\r\n// Math functions takes care of infinites and NaN\r\n{$DEFINE MATH_EXT_EXTREMEVALUES}\r\n\r\n\r\n// JclHookExcept support for hooking exceptions from DLLs\r\n{.$DEFINE HOOK_DLL_EXCEPTIONS}\r\n\r\n\r\n//Threadsafe directive\r\n{$DEFINE THREADSAFE}\r\n\r\n\r\n// To exclude obsolete code from compilation, remove the point from the line below\r\n{$DEFINE DROP_OBSOLETE_CODE}\r\n\r\n\r\n//Support for JclUnitVersioning.pas, not supported by Delphi 2005 (automatically disabled afterward)\r\n{$DEFINE UNITVERSIONING}\r\n\r\n\r\n// debug sources\r\n// defining these symbols will the debug source to be automatically registered\r\n{.$DEFINE DEBUG_NO_BINARY}\r\n{.$DEFINE DEBUG_NO_TD32} // automatically defined for FPC\r\n{.$DEFINE DEBUG_NO_MAP}\r\n{.$DEFINE DEBUG_NO_EXPORTS}\r\n{.$DEFINE DEBUG_NO_SYMBOLS}\r\n\r\n\r\n// PCRE options, mutually exclusive\r\n// IMPORTANT: The static link works only for Delphi 2005 and newer\r\n// (an internal error is raised on other compilers)\r\n// Only one of the following defines can be defined at a time\r\n// static link: PCRE_STATICLINK\r\n// static dll import: PCRE_LINKDLL\r\n// dynamic dll import: PCRE_LINKONREQUEST\r\n// RTL's RegularExpressionsAPI: PCRE_RTL\r\n\r\n{$DEFINE PCRE_STATICLINK}\r\n{.$DEFINE PCRE_LINKDLL}\r\n{.$DEFINE PCRE_LINKONREQUEST} // default\r\n{.$DEFINE PCRE_RTL} // DXE and newer\r\n\r\n// ANSI/UTF8 PCRE\r\n{$DEFINE PCRE_8}\r\n// UCS2/UTF16 enabled PCRE\r\n{.$DEFINE PCRE_16} // only valid when PCRE_STATICLINK is enabled, the RTL does not support it and the DLL found over the internet are completly outdated.\r\n\r\n// use PCRE16 when available rather than good old PCRE8\r\n{.$DEFINE PCRE_PREFER_16}\r\n\r\n// BZIP2 options, mutually exclusive\r\n\r\n{$DEFINE BZIP2_STATICLINK} // default\r\n{.$DEFINE BZIP2_LINKDLL}\r\n{.$DEFINE BZIP2_LINKONREQUEST}\r\n\r\n\r\n// ZLIB options, mutually exclusive\r\n\r\n{$DEFINE ZLIB_STATICLINK} // default\r\n{.$DEFINE ZLIB_LINKDLL}\r\n{.$DEFINE ZLIB_LINKONREQUEST}\r\n{.$DEFINE ZLIB_RTL} // DXE2 and newer only\r\n\r\n\r\n// Unicode options\r\n// use RTL Character Database rather than JCL one, less accurate but reduce executable size\r\n{.$DEFINE UNICODE_RTL_DATABASE}\r\n\r\n// insert a replacement character if sequence is corrupted rather than raising an exception\r\n{$DEFINE UNICODE_SILENT_FAILURE}\r\n\r\n// defines resource compression (uncompressed, compressed with ZLib, compressed with BZip2), mutually exclusive\r\n{$DEFINE UNICODE_RAW_DATA} // default\r\n{.$DEFINE UNICODE_ZLIB_DATA}\r\n{.$DEFINE UNICODE_BZIP2_DATA}\r\n\r\n\r\n// container options\r\n// define mapping of TJclStr* containers to TJclAnsiStr* or TJclWideStr* (mutually exclusive)\r\n{.$DEFINE CONTAINER_ANSISTR} // default for D2007 and older\r\n{.$DEFINE CONTAINER_WIDESTR}\r\n{$DEFINE CONTAINER_UNICODESTR} // default for D2009 and newer, not supported for Delphi 2007 and older\r\n{.$DEFINE CONTAINER_NOSTR}\r\n\r\n\r\n// 7Zip options, mutually exclusive\r\n// IMPORTANT: The static link is not supported yet\r\n\r\n{.$DEFINE 7ZIP_STATICLINK} // not supported yet\r\n{.$DEFINE 7ZIP_LINKDLL}\r\n{$DEFINE 7ZIP_LINKONREQUEST} // default\r\n\r\n" }, { "path": "External/Jedi/Jcl/source/include/jedi/jedi.inc", "content": "{$IFNDEF JEDI_INC}\r\n{$DEFINE JEDI_INC}\r\n\r\n{**************************************************************************************************}\r\n{ }\r\n{ The contents of this file are subject to the Mozilla Public License Version 1.1 (the \"License\");}\r\n{ you may not use this file except in compliance with the License. You may obtain a copy of the }\r\n{ License at http://www.mozilla.org/MPL/ }\r\n{ }\r\n{ Software distributed under the License is distributed on an \"AS IS\" basis, WITHOUT WARRANTY OF }\r\n{ ANY KIND, either express or implied. See the License for the specific language governing rights }\r\n{ and limitations under the License. }\r\n{ }\r\n{ The Original Code is: jedi.inc. }\r\n{ The Initial Developer of the Original Code is Project JEDI http://www.delphi-jedi.org }\r\n{ }\r\n{ Alternatively, the contents of this file may be used under the terms of the GNU Lesser General }\r\n{ Public License (the \"LGPL License\"), in which case the provisions of the LGPL License are }\r\n{ applicable instead of those above. If you wish to allow use of your version of this file only }\r\n{ under the terms of the LGPL License and not to allow others to use your version of this file }\r\n{ under the MPL, indicate your decision by deleting the provisions above and replace them with }\r\n{ the notice and other provisions required by the LGPL License. If you do not delete the }\r\n{ provisions above, a recipient may use your version of this file under either the MPL or the }\r\n{ LGPL License. }\r\n{ }\r\n{ For more information about the LGPL: http://www.gnu.org/copyleft/lesser.html }\r\n{ }\r\n{**************************************************************************************************}\r\n{ }\r\n{ This file defines various generic compiler directives used in different libraries, e.g. in the }\r\n{ JEDI Code Library (JCL) and JEDI Visual Component Library Library (JVCL). The directives in }\r\n{ this file are of generic nature and consist mostly of mappings from the VERXXX directives }\r\n{ defined by Delphi, C++Builder and FPC to friendly names such as DELPHI5 and }\r\n{ SUPPORTS_WIDESTRING. These friendly names are subsequently used in the libraries to test for }\r\n{ compiler versions and/or whether the compiler supports certain features (such as widestrings or }\r\n{ 64 bit integers. The libraries provide an additional, library specific, include file. For the }\r\n{ JCL e.g. this is jcl.inc. These files should be included in source files instead of this file }\r\n{ (which is pulled in automatically). }\r\n{ }\r\n{**************************************************************************************************}\r\n{ }\r\n{ Last modified: $Date:: 2012-09-04 16:01:38 +0200 (mar. 04 sept. 2012) $ }\r\n{ Revision: $Rev:: 161 $ }\r\n{ Author: $Author:: outchy $ }\r\n{ }\r\n{**************************************************************************************************}\r\n\r\n(*\r\n\r\n- Development environment directives\r\n\r\n This file defines two directives to indicate which development environment the\r\n library is being compiled with. Currently this can either be Delphi, Kylix,\r\n C++Builder or FPC.\r\n\r\n Directive Description\r\n ------------------------------------------------------------------------------\r\n DELPHI Defined if compiled with Delphi\r\n KYLIX Defined if compiled with Kylix\r\n DELPHICOMPILER Defined if compiled with Delphi or Kylix/Delphi\r\n BCB Defined if compiled with C++Builder\r\n CPPBUILDER Defined if compiled with C++Builder (alias for BCB)\r\n BCBCOMPILER Defined if compiled with C++Builder or Kylix/C++\r\n DELPHILANGUAGE Defined if compiled with Delphi, Kylix or C++Builder\r\n BORLAND Defined if compiled with Delphi, Kylix or C++Builder\r\n FPC Defined if compiled with FPC\r\n\r\n- Platform Directives\r\n\r\n Platform directives are not all explicitly defined in this file, some are\r\n defined by the compiler itself. They are listed here only for completeness.\r\n\r\n Directive Description\r\n ------------------------------------------------------------------------------\r\n WIN32 Defined when target platform is 32 bit Windows\r\n WIN64 Defined when target platform is 64 bit Windows\r\n MSWINDOWS Defined when target platform is 32 bit Windows\r\n LINUX Defined when target platform is Linux\r\n UNIX Defined when target platform is Unix-like (including Linux)\r\n CLR Defined when target platform is .NET\r\n\r\n- Architecture directives. These are auto-defined by FPC\r\n CPU32 and CPU64 are mostly for generic pointer size dependant differences rather\r\n than for a specific architecture.\r\n\r\n CPU386 Defined when target platform is native x86 (win32)\r\n CPUx86_64 Defined when target platform is native x86_64 (win64)\r\n CPU32 Defined when target is 32-bit\r\n CPU64\t Defined when target is 64-bit\r\n CPUASM Defined when target assembler is available\r\n\r\n- Visual library Directives\r\n\r\n The following directives indicate for a visual library. In a Delphi/BCB\r\n (Win32) application you need to define the VisualCLX symbol in the project\r\n options, if you want to use the VisualCLX library. Alternatively you can use\r\n the IDE expert, which is distributed with the JCL to do this automatically.\r\n\r\n Directive Description\r\n ------------------------------------------------------------------------------\r\n VCL Defined for Delphi/BCB (Win32) exactly if VisualCLX is not defined\r\n VisualCLX Defined for Kylix; needs to be defined for Delphi/BCB to\r\n use JCL with VisualCLX applications.\r\n\r\n\r\n- Other cross-platform related defines\r\n\r\n These symbols are intended to help in writing portable code.\r\n\r\n Directive Description\r\n ------------------------------------------------------------------------------\r\n PUREPASCAL Code is machine-independent (as opposed to assembler code)\r\n Win32API Code is specific for the Win32 API;\r\n use instead of \"{$IFNDEF CLR} {$IFDEF MSWINDOWS}\" constructs\r\n\r\n\r\n- Delphi Versions\r\n\r\n The following directives are direct mappings from the VERXXX directives to a\r\n friendly name of the associated compiler. These directives are only defined if\r\n the compiler is Delphi (ie DELPHI is defined).\r\n\r\n Directive Description\r\n ------------------------------------------------------------------------------\r\n DELPHI1 Defined when compiling with Delphi 1 (Codename WASABI/MANGO)\r\n DELPHI2 Defined when compiling with Delphi 2 (Codename POLARIS)\r\n DELPHI3 Defined when compiling with Delphi 3 (Codename IVORY)\r\n DELPHI4 Defined when compiling with Delphi 4 (Codename ALLEGRO)\r\n DELPHI5 Defined when compiling with Delphi 5 (Codename ARGUS)\r\n DELPHI6 Defined when compiling with Delphi 6 (Codename ILLIAD)\r\n DELPHI7 Defined when compiling with Delphi 7 (Codename AURORA)\r\n DELPHI8 Defined when compiling with Delphi 8 (Codename OCTANE)\r\n DELPHI2005 Defined when compiling with Delphi 2005 (Codename DIAMONDBACK)\r\n DELPHI9 Alias for DELPHI2005\r\n DELPHI10 Defined when compiling with Delphi 2006 (Codename DEXTER)\r\n DELPHI2006 Alias for DELPHI10\r\n DELPHI11 Defined when compiling with Delphi 2007 for Win32 (Codename SPACELY)\r\n DELPHI2007 Alias for DELPHI11\r\n DELPHI12 Defined when compiling with Delphi 2009 for Win32 (Codename TIBURON)\r\n DELPHI2009 Alias for DELPHI12\r\n DELPHI14 Defined when compiling with Delphi 2010 for Win32 (Codename WEAVER)\r\n DELPHI2010 Alias for DELPHI14\r\n DELPHI15 Defined when compiling with Delphi XE for Win32 (Codename FULCRUM)\r\n DELPHIXE Alias for DELPHI15\r\n DELPHI16 Defined when compiling with Delphi XE2 for Win32 (Codename PULSAR)\r\n DELPHIXE2 Alias for DELPHI16\r\n DELPHI17 Defined when compiling with Delphi XE3 for Win32 (Codename WATERDRAGON)\r\n DELPHIXE3 Alias for DELPHI17\r\n DELPHI1_UP Defined when compiling with Delphi 1 or higher\r\n DELPHI2_UP Defined when compiling with Delphi 2 or higher\r\n DELPHI3_UP Defined when compiling with Delphi 3 or higher\r\n DELPHI4_UP Defined when compiling with Delphi 4 or higher\r\n DELPHI5_UP Defined when compiling with Delphi 5 or higher\r\n DELPHI6_UP Defined when compiling with Delphi 6 or higher\r\n DELPHI7_UP Defined when compiling with Delphi 7 or higher\r\n DELPHI8_UP Defined when compiling with Delphi 8 or higher\r\n DELPHI2005_UP Defined when compiling with Delphi 2005 or higher\r\n DELPHI9_UP Alias for DELPHI2005_UP\r\n DELPHI10_UP Defined when compiling with Delphi 2006 or higher\r\n DELPHI2006_UP Alias for DELPHI10_UP\r\n DELPHI11_UP Defined when compiling with Delphi 2007 for Win32 or higher\r\n DELPHI2007_UP Alias for DELPHI11_UP\r\n DELPHI12_UP Defined when compiling with Delphi 2009 for Win32 or higher\r\n DELPHI2009_UP Alias for DELPHI12_UP\r\n DELPHI14_UP Defined when compiling with Delphi 2010 for Win32 or higher\r\n DELPHI2010_UP Alias for DELPHI14_UP\r\n DELPHI15_UP Defined when compiling with Delphi XE for Win32 or higher\r\n DELPHIXE_UP Alias for DELPHI15_UP\r\n DELPHI16_UP Defined when compiling with Delphi XE2 for Win32 or higher\r\n DELPHIXE2_UP Alias for DELPHI16_UP\r\n DELPHI17_UP Defined when compiling with Delphi XE3 for Win32 or higher\r\n DELPHIXE3_UP Alias for DELPHI17_UP\r\n\r\n\r\n- Kylix Versions\r\n\r\n The following directives are direct mappings from the VERXXX directives to a\r\n friendly name of the associated compiler. These directives are only defined if\r\n the compiler is Kylix (ie KYLIX is defined).\r\n\r\n Directive Description\r\n ------------------------------------------------------------------------------\r\n KYLIX1 Defined when compiling with Kylix 1\r\n KYLIX2 Defined when compiling with Kylix 2\r\n KYLIX3 Defined when compiling with Kylix 3 (Codename CORTEZ)\r\n KYLIX1_UP Defined when compiling with Kylix 1 or higher\r\n KYLIX2_UP Defined when compiling with Kylix 2 or higher\r\n KYLIX3_UP Defined when compiling with Kylix 3 or higher\r\n\r\n\r\n- Delphi Compiler Versions (Delphi / Kylix, not in BCB mode)\r\n\r\n Directive Description\r\n ------------------------------------------------------------------------------\r\n DELPHICOMPILER1 Defined when compiling with Delphi 1\r\n DELPHICOMPILER2 Defined when compiling with Delphi 2\r\n DELPHICOMPILER3 Defined when compiling with Delphi 3\r\n DELPHICOMPILER4 Defined when compiling with Delphi 4\r\n DELPHICOMPILER5 Defined when compiling with Delphi 5\r\n DELPHICOMPILER6 Defined when compiling with Delphi 6 or Kylix 1, 2 or 3\r\n DELPHICOMPILER7 Defined when compiling with Delphi 7\r\n DELPHICOMPILER8 Defined when compiling with Delphi 8\r\n DELPHICOMPILER9 Defined when compiling with Delphi 2005\r\n DELPHICOMPILER10 Defined when compiling with Delphi Personality of BDS 4.0\r\n DELPHICOMPILER11 Defined when compiling with Delphi 2007 for Win32\r\n DELPHICOMPILER12 Defined when compiling with Delphi Personality of BDS 6.0\r\n DELPHICOMPILER14 Defined when compiling with Delphi Personality of BDS 7.0\r\n DELPHICOMPILER15 Defined when compiling with Delphi Personality of BDS 8.0\r\n DELPHICOMPILER16 Defined when compiling with Delphi Personality of BDS 9.0\r\n DELPHICOMPILER17 Defined when compiling with Delphi Personality of BDS 10.0\r\n DELPHICOMPILER1_UP Defined when compiling with Delphi 1 or higher\r\n DELPHICOMPILER2_UP Defined when compiling with Delphi 2 or higher\r\n DELPHICOMPILER3_UP Defined when compiling with Delphi 3 or higher\r\n DELPHICOMPILER4_UP Defined when compiling with Delphi 4 or higher\r\n DELPHICOMPILER5_UP Defined when compiling with Delphi 5 or higher\r\n DELPHICOMPILER6_UP Defined when compiling with Delphi 6 or Kylix 1, 2 or 3 or higher\r\n DELPHICOMPILER7_UP Defined when compiling with Delphi 7 or higher\r\n DELPHICOMPILER8_UP Defined when compiling with Delphi 8 or higher\r\n DELPHICOMPILER9_UP Defined when compiling with Delphi 2005\r\n DELPHICOMPILER10_UP Defined when compiling with Delphi 2006 or higher\r\n DELPHICOMPILER11_UP Defined when compiling with Delphi 2007 for Win32 or higher\r\n DELPHICOMPILER12_UP Defined when compiling with Delphi 2009 for Win32 or higher\r\n DELPHICOMPILER14_UP Defined when compiling with Delphi 2010 for Win32 or higher\r\n DELPHICOMPILER15_UP Defined when compiling with Delphi XE for Win32 or higher\r\n DELPHICOMPILER16_UP Defined when compiling with Delphi XE2 for Win32 or higher\r\n DELPHICOMPILER17_UP Defined when compiling with Delphi XE3 for Win32 or higher\r\n\r\n\r\n- C++Builder Versions\r\n\r\n The following directives are direct mappings from the VERXXX directives to a\r\n friendly name of the associated compiler. These directives are only defined if\r\n the compiler is C++Builder (ie BCB is defined).\r\n\r\n Directive Description\r\n ------------------------------------------------------------------------------\r\n BCB1 Defined when compiling with C++Builder 1\r\n BCB3 Defined when compiling with C++Builder 3\r\n BCB4 Defined when compiling with C++Builder 4\r\n BCB5 Defined when compiling with C++Builder 5 (Codename RAMPAGE)\r\n BCB6 Defined when compiling with C++Builder 6 (Codename RIPTIDE)\r\n BCB10 Defined when compiling with C++Builder Personality of BDS 4.0 (also known as C++Builder 2006) (Codename DEXTER)\r\n BCB11 Defined when compiling with C++Builder Personality of RAD Studio 2007 (also known as C++Builder 2007) (Codename COGSWELL)\r\n BCB12 Defined when compiling with C++Builder Personality of RAD Studio 2009 (also known as C++Builder 2009) (Codename TIBURON)\r\n BCB14 Defined when compiling with C++Builder Personality of RAD Studio 2010 (also known as C++Builder 2010) (Codename WEAVER)\r\n BCB15 Defined when compiling with C++Builder Personality of RAD Studio XE (also known as C++Builder XE) (Codename FULCRUM)\r\n BCB16 Defined when compiling with C++Builder Personality of RAD Studio XE2 (also known as C++Builder XE2) (Codename PULSAR)\r\n BCB17 Defined when compiling with C++Builder Personality of RAD Studio XE3 (also known as C++Builder XE3) (Codename WATERDRAGON)\r\n BCB1_UP Defined when compiling with C++Builder 1 or higher\r\n BCB3_UP Defined when compiling with C++Builder 3 or higher\r\n BCB4_UP Defined when compiling with C++Builder 4 or higher\r\n BCB5_UP Defined when compiling with C++Builder 5 or higher\r\n BCB6_UP Defined when compiling with C++Builder 6 or higher\r\n BCB10_UP Defined when compiling with C++Builder Personality of BDS 4.0 or higher\r\n BCB11_UP Defined when compiling with C++Builder Personality of RAD Studio 2007 or higher\r\n BCB12_UP Defined when compiling with C++Builder Personality of RAD Studio 2009 or higher\r\n BCB14_UP Defined when compiling with C++Builder Personality of RAD Studio 2010 or higher\r\n BCB15_UP Defined when compiling with C++Builder Personality of RAD Studio XE or higher\r\n BCB16_UP Defined when compiling with C++Builder Personality of RAD Studio XE2 or higher\r\n BCB17_UP Defined when compiling with C++Builder Personality of RAD Studio XE3 or higher\r\n\r\n\r\n- RAD Studio / Borland Developer Studio Versions\r\n\r\n The following directives are direct mappings from the VERXXX directives to a\r\n friendly name of the associated IDE. These directives are only defined if\r\n the IDE is Borland Developer Studio Version 2 or above.\r\n\r\n Note: Borland Developer Studio 2006 is marketed as Delphi 2006 or C++Builder 2006,\r\n but those provide only different labels for identical content.\r\n\r\n Directive Description\r\n ------------------------------------------------------------------------------\r\n BDS Defined when compiling with BDS version of dcc32.exe (Codename SIDEWINDER)\r\n BDS2 Defined when compiling with BDS 2.0 (Delphi 8) (Codename OCTANE)\r\n BDS3 Defined when compiling with BDS 3.0 (Delphi 2005) (Codename DIAMONDBACK)\r\n BDS4 Defined when compiling with BDS 4.0 (Borland Developer Studio 2006) (Codename DEXTER)\r\n BDS5 Defined when compiling with BDS 5.0 (CodeGear RAD Studio 2007) (Codename HIGHLANDER)\r\n BDS6 Defined when compiling with BDS 6.0 (CodeGear RAD Studio 2009) (Codename TIBURON)\r\n BDS7 Defined when compiling with BDS 7.0 (Embarcadero RAD Studio 2010) (Codename WEAVER)\r\n BDS8 Defined when compiling with BDS 8.0 (Embarcadero RAD Studio XE) (Codename FULCRUM)\r\n BDS9 Defined when compiling with BDS 9.0 (Embarcadero RAD Studio XE2) (Codename PULSAR)\r\n BDS10 Defined when compiling with BDS 10.0 (Embarcadero RAD Studio XE3) (Codename WATERDRAGON)\r\n BDS2_UP Defined when compiling with BDS 2.0 or higher\r\n BDS3_UP Defined when compiling with BDS 3.0 or higher\r\n BDS4_UP Defined when compiling with BDS 4.0 or higher\r\n BDS5_UP Defined when compiling with BDS 5.0 or higher\r\n BDS6_UP Defined when compiling with BDS 6.0 or higher\r\n BDS7_UP Defined when compiling with BDS 7.0 or higher\r\n BDS8_UP Defined when compiling with BDS 8.0 or higher\r\n BDS9_UP Defined when compiling with BDS 9.0 or higher\r\n BDS10_UP Defined when compiling with BDS 10.0 or higher\r\n\r\n- Compiler Versions\r\n\r\n The following directives are direct mappings from the VERXXX directives to a\r\n friendly name of the associated compiler. Unlike the DELPHI_X and BCB_X\r\n directives, these directives are indepedent of the development environment.\r\n That is, they are defined regardless of whether compilation takes place using\r\n Delphi or C++Builder.\r\n\r\n Directive Description\r\n ------------------------------------------------------------------------------\r\n COMPILER1 Defined when compiling with Delphi 1\r\n COMPILER2 Defined when compiling with Delphi 2 or C++Builder 1\r\n COMPILER3 Defined when compiling with Delphi 3\r\n COMPILER35 Defined when compiling with C++Builder 3\r\n COMPILER4 Defined when compiling with Delphi 4 or C++Builder 4\r\n COMPILER5 Defined when compiling with Delphi 5 or C++Builder 5\r\n COMPILER6 Defined when compiling with Delphi 6 or C++Builder 6\r\n COMPILER7 Defined when compiling with Delphi 7\r\n COMPILER8 Defined when compiling with Delphi 8\r\n COMPILER9 Defined when compiling with Delphi 9\r\n COMPILER10 Defined when compiling with Delphi or C++Builder Personalities of BDS 4.0\r\n COMPILER11 Defined when compiling with Delphi or C++Builder Personalities of BDS 5.0\r\n COMPILER12 Defined when compiling with Delphi or C++Builder Personalities of BDS 6.0\r\n COMPILER14 Defined when compiling with Delphi or C++Builder Personalities of BDS 7.0\r\n COMPILER15 Defined when compiling with Delphi or C++Builder Personalities of BDS 8.0\r\n COMPILER16 Defined when compiling with Delphi or C++Builder Personalities of BDS 9.0\r\n COMPILER17 Defined when compiling with Delphi or C++Builder Personalities of BDS 10.0\r\n COMPILER1_UP Defined when compiling with Delphi 1 or higher\r\n COMPILER2_UP Defined when compiling with Delphi 2 or C++Builder 1 or higher\r\n COMPILER3_UP Defined when compiling with Delphi 3 or higher\r\n COMPILER35_UP Defined when compiling with C++Builder 3 or higher\r\n COMPILER4_UP Defined when compiling with Delphi 4 or C++Builder 4 or higher\r\n COMPILER5_UP Defined when compiling with Delphi 5 or C++Builder 5 or higher\r\n COMPILER6_UP Defined when compiling with Delphi 6 or C++Builder 6 or higher\r\n COMPILER7_UP Defined when compiling with Delphi 7\r\n COMPILER8_UP Defined when compiling with Delphi 8\r\n COMPILER9_UP Defined when compiling with Delphi Personalities of BDS 3.0\r\n COMPILER10_UP Defined when compiling with Delphi or C++Builder Personalities of BDS 4.0 or higher\r\n COMPILER11_UP Defined when compiling with Delphi or C++Builder Personalities of BDS 5.0 or higher\r\n COMPILER12_UP Defined when compiling with Delphi or C++Builder Personalities of BDS 6.0 or higher\r\n COMPILER14_UP Defined when compiling with Delphi or C++Builder Personalities of BDS 7.0 or higher\r\n COMPILER15_UP Defined when compiling with Delphi or C++Builder Personalities of BDS 8.0 or higher\r\n COMPILER16_UP Defined when compiling with Delphi or C++Builder Personalities of BDS 9.0 or higher\r\n COMPILER17_UP Defined when compiling with Delphi or C++Builder Personalities of BDS 10.0 or higher\r\n\r\n\r\n- RTL Versions\r\n\r\n Use e.g. following to determine the exact RTL version since version 14.0:\r\n {$IFDEF CONDITIONALEXPRESSIONS}\r\n {$IF Declared(RTLVersion) and (RTLVersion >= 14.2)}\r\n // code for Delphi 6.02 or higher, Kylix 2 or higher, C++Builder 6 or higher\r\n ...\r\n {$IFEND}\r\n {$ENDIF}\r\n\r\n Directive Description\r\n ------------------------------------------------------------------------------\r\n RTL80_UP Defined when compiling with Delphi 1 or higher\r\n RTL90_UP Defined when compiling with Delphi 2 or higher\r\n RTL93_UP Defined when compiling with C++Builder 1 or higher\r\n RTL100_UP Defined when compiling with Delphi 3 or higher\r\n RTL110_UP Defined when compiling with C++Builder 3 or higher\r\n RTL120_UP Defined when compiling with Delphi 4 or higher\r\n RTL125_UP Defined when compiling with C++Builder 4 or higher\r\n RTL130_UP Defined when compiling with Delphi 5 or C++Builder 5 or higher\r\n RTL140_UP Defined when compiling with Delphi 6, Kylix 1, 2 or 3 or C++Builder 6 or higher\r\n RTL150_UP Defined when compiling with Delphi 7 or higher\r\n RTL160_UP Defined when compiling with Delphi 8 or higher\r\n RTL170_UP Defined when compiling with Delphi Personalities of BDS 3.0 or higher\r\n RTL180_UP Defined when compiling with Delphi or C++Builder Personalities of BDS 4.0 or higher\r\n RTL185_UP Defined when compiling with Delphi or C++Builder Personalities of BDS 5.0 or higher\r\n RTL190_UP Defined when compiling with Delphi.NET of BDS 5.0 or higher\r\n RTL200_UP Defined when compiling with Delphi or C++Builder Personalities of BDS 6.0 or higher\r\n RTL210_UP Defined when compiling with Delphi or C++Builder Personalities of BDS 7.0 or higher\r\n RTL220_UP Defined when compiling with Delphi or C++Builder Personalities of BDS 8.0 or higher\r\n RTL230_UP Defined when compiling with Delphi or C++Builder Personalities of BDS 9.0 or higher\r\n RTL240_UP Defined when compiling with Delphi or C++Builder Personalities of BDS 10.0 or higher\r\n\r\n\r\n- CLR Versions\r\n\r\n Directive Description\r\n ------------------------------------------------------------------------------\r\n CLR Defined when compiling for .NET\r\n CLR10 Defined when compiling for .NET 1.0 (may be overriden by FORCE_CLR10)\r\n CLR10_UP Defined when compiling for .NET 1.0 or higher\r\n CLR11 Defined when compiling for .NET 1.1 (may be overriden by FORCE_CLR11)\r\n CLR11_UP Defined when compiling for .NET 1.1 or higher\r\n CLR20 Defined when compiling for .NET 2.0 (may be overriden by FORCE_CLR20)\r\n CLR20_UP Defined when compiling for .NET 2.0 or higher\r\n\r\n\r\n- Feature Directives\r\n\r\n The features directives are used to test if the compiler supports specific\r\n features, such as method overloading, and adjust the sources accordingly. Use\r\n of these directives is preferred over the use of the DELPHI and COMPILER\r\n directives.\r\n\r\n Directive Description\r\n ------------------------------------------------------------------------------\r\n SUPPORTS_CONSTPARAMS Compiler supports const parameters (D1+)\r\n SUPPORTS_SINGLE Compiler supports the Single type (D1+)\r\n SUPPORTS_DOUBLE Compiler supports the Double type (D1+)\r\n SUPPORTS_EXTENDED Compiler supports the Extended type (D1+)\r\n SUPPORTS_CURRENCY Compiler supports the Currency type (D2+)\r\n SUPPORTS_THREADVAR Compiler supports threadvar declarations (D2+)\r\n SUPPORTS_OUTPARAMS Compiler supports out parameters (D3+)\r\n SUPPORTS_VARIANT Compiler supports variant (D2+)\r\n SUPPORTS_WIDECHAR Compiler supports the WideChar type (D2+)\r\n SUPPORTS_WIDESTRING Compiler supports the WideString type (D3+/BCB3+)\r\n SUPPORTS_INTERFACE Compiler supports interfaces (D3+/BCB3+)\r\n SUPPORTS_DISPINTERFACE Compiler supports dispatch interfaces (D3+/BCB3+)\r\n SUPPORTS_DISPID Compiler supports dispatch ids (D3+/BCB3+/FPC)\r\n SUPPORTS_EXTSYM Compiler supports the $EXTERNALSYM directive (D4+/BCB3+)\r\n SUPPORTS_NODEFINE Compiler supports the $NODEFINE directive (D4+/BCB3+)\r\n SUPPORTS_LONGWORD Compiler supports the LongWord type (unsigned 32 bit) (D4+/BCB4+)\r\n SUPPORTS_INT64 Compiler supports the Int64 type (D4+/BCB4+)\r\n SUPPORTS_UINT64 Compiler supports the UInt64 type (D XE+ ?)\r\n SUPPORTS_DYNAMICARRAYS Compiler supports dynamic arrays (D4+/BCB4+)\r\n SUPPORTS_DEFAULTPARAMS Compiler supports default parameters (D4+/BCB4+)\r\n SUPPORTS_OVERLOAD Compiler supports overloading (D4+/BCB4+)\r\n SUPPORTS_IMPLEMENTS Compiler supports implements (D4+/BCB4+)\r\n SUPPORTS_DEPRECATED Compiler supports the deprecated directive (D6+/BCB6+)\r\n SUPPORTS_PLATFORM Compiler supports the platform directive (D6+/BCB6+)\r\n SUPPORTS_LIBRARY Compiler supports the library directive (D6+/BCB6+/FPC)\r\n SUPPORTS_LOCAL Compiler supports the local directive (D6+/BCB6+)\r\n SUPPORTS_SETPEFLAGS Compiler supports the SetPEFlags directive (D6+/BCB6+)\r\n SUPPORTS_EXPERIMENTAL_WARNINGS Compiler supports the WARN SYMBOL_EXPERIMENTAL and WARN UNIT_EXPERIMENTAL directives (D6+/BCB6+)\r\n SUPPORTS_INLINE Compiler supports the inline directive (D9+/FPC)\r\n SUPPORTS_FOR_IN Compiler supports for in loops (D9+)\r\n SUPPORTS_NESTED_CONSTANTS Compiler supports nested constants (D9+)\r\n SUPPORTS_NESTED_TYPES Compiler supports nested types (D9+)\r\n SUPPORTS_REGION Compiler supports the REGION and ENDREGION directives (D9+)\r\n SUPPORTS_ENHANCED_RECORDS Compiler supports class [operator|function|procedure] for record types (D9.NET, D10+)\r\n SUPPORTS_CLASS_FIELDS Compiler supports class fields (D9.NET, D10+)\r\n SUPPORTS_CLASS_HELPERS Compiler supports class helpers (D9.NET, D10+)\r\n SUPPORTS_CLASS_OPERATORS Compiler supports class operators (D9.NET, D10+)\r\n SUPPORTS_CLASS_CTORDTORS Compiler supports class contructors/destructors (D14+)\r\n SUPPORTS_STRICT Compiler supports strict keyword (D9.NET, D10+)\r\n SUPPORTS_STATIC Compiler supports static keyword (D9.NET, D10+)\r\n SUPPORTS_FINAL Compiler supports final keyword (D9.NET, D10+)\r\n SUPPORTS_METHODINFO Compiler supports the METHODINFO directives (D10+)\r\n SUPPORTS_GENERICS Compiler supports generic implementations (D11.NET, D12+)\r\n SUPPORTS_DEPRECATED_DETAILS Compiler supports additional text for the deprecated directive (D11.NET, D12+)\r\n ACCEPT_DEPRECATED Compiler supports or ignores the deprecated directive (D6+/BCB6+/FPC)\r\n ACCEPT_PLATFORM Compiler supports or ignores the platform directive (D6+/BCB6+/FPC)\r\n ACCEPT_LIBRARY Compiler supports or ignores the library directive (D6+/BCB6+)\r\n SUPPORTS_CUSTOMVARIANTS Compiler supports custom variants (D6+/BCB6+)\r\n SUPPORTS_VARARGS Compiler supports varargs (D6+/BCB6+)\r\n SUPPORTS_ENUMVALUE Compiler supports assigning ordinalities to values of enums (D6+/BCB6+)\r\n SUPPORTS_DEPRECATED_WARNINGS Compiler supports deprecated warnings (D6+/BCB6+)\r\n SUPPORTS_LIBRARY_WARNINGS Compiler supports library warnings (D6+/BCB6+)\r\n SUPPORTS_PLATFORM_WARNINGS Compiler supports platform warnings (D6+/BCB6+)\r\n SUPPORTS_UNSAFE_WARNINGS Compiler supports unsafe warnings (D7)\r\n SUPPORTS_WEAKPACKAGEUNIT Compiler supports the WEAKPACKAGEUNIT directive\r\n SUPPORTS_COMPILETIME_MESSAGES Compiler supports the MESSAGE directive\r\n SUPPORTS_PACKAGES Compiler supports Packages\r\n HAS_UNIT_LIBC Unit Libc exists (Kylix, FPC on Linux/x86)\r\n HAS_UNIT_RTLCONSTS Unit RTLConsts exists (D6+/BCB6+/FPC)\r\n HAS_UNIT_TYPES Unit Types exists (D6+/BCB6+/FPC)\r\n HAS_UNIT_VARIANTS Unit Variants exists (D6+/BCB6+/FPC)\r\n HAS_UNIT_STRUTILS Unit StrUtils exists (D6+/BCB6+/FPC)\r\n HAS_UNIT_DATEUTILS Unit DateUtils exists (D6+/BCB6+/FPC)\r\n HAS_UNIT_CONTNRS Unit contnrs exists (D6+/BCB6+/FPC)\r\n HAS_UNIT_HTTPPROD Unit HTTPProd exists (D9+)\r\n HAS_UNIT_GIFIMG Unit GifImg exists (D11+)\r\n HAS_UNIT_ANSISTRINGS Unit AnsiStrings exists (D12+)\r\n HAS_UNIT_PNGIMAGE Unit PngImage exists (D12+)\r\n HAS_UNIT_CHARACTER Unit Character exists (D12+)\r\n XPLATFORM_RTL The RTL supports crossplatform function names (e.g. RaiseLastOSError) (D6+/BCB6+/FPC)\r\n SUPPORTS_UNICODE string type is aliased to an unicode string (WideString or UnicodeString) (DX.NET, D12+)\r\n SUPPORTS_UNICODE_STRING Compiler supports UnicodeString (D12+)\r\n SUPPORTS_INT_ALIASES Types Int8, Int16, Int32, UInt8, UInt16 and UInt32 are defined in the unit System (D12+)\r\n HAS_UNIT_RTTI Unit RTTI is available (D14+)\r\n SUPPORTS_CAST_INTERFACE_TO_OBJ The compiler supports casts from interfaces to objects (D14+)\r\n SUPPORTS_DELAYED_LOADING The compiler generates stubs for delaying imported function loads (D14+)\r\n HAS_UNIT_REGULAREXPRESSIONSAPI Unit RegularExpressionsAPI is available (D15+)\r\n HAS_UNIT_SYSTEM_UITYPES Unit System.UITypes is available (D16+)\r\n HAS_UNIT_SYSTEM_ACTIONS Unit System.Actions is available (D17+)\r\n\r\n\r\n- Compiler Settings\r\n\r\n The compiler settings directives indicate whether a specific compiler setting\r\n is in effect. This facilitates changing compiler settings locally in a more\r\n compact and readible manner.\r\n\r\n Directive Description\r\n ------------------------------------------------------------------------------\r\n ALIGN_ON Compiling in the A+ state (no alignment)\r\n BOOLEVAL_ON Compiling in the B+ state (complete boolean evaluation)\r\n ASSERTIONS_ON Compiling in the C+ state (assertions on)\r\n DEBUGINFO_ON Compiling in the D+ state (debug info generation on)\r\n IMPORTEDDATA_ON Compiling in the G+ state (creation of imported data references)\r\n LONGSTRINGS_ON Compiling in the H+ state (string defined as AnsiString)\r\n IOCHECKS_ON Compiling in the I+ state (I/O checking enabled)\r\n WRITEABLECONST_ON Compiling in the J+ state (typed constants can be modified)\r\n LOCALSYMBOLS Compiling in the L+ state (local symbol generation)\r\n LOCALSYMBOLS_ON Alias of LOCALSYMBOLS\r\n TYPEINFO_ON Compiling in the M+ state (RTTI generation on)\r\n OPTIMIZATION_ON Compiling in the O+ state (code optimization on)\r\n OPENSTRINGS_ON Compiling in the P+ state (variable string parameters are openstrings)\r\n OVERFLOWCHECKS_ON Compiling in the Q+ state (overflow checing on)\r\n RANGECHECKS_ON Compiling in the R+ state (range checking on)\r\n TYPEDADDRESS_ON Compiling in the T+ state (pointers obtained using the @ operator are typed)\r\n SAFEDIVIDE_ON Compiling in the U+ state (save FDIV instruction through RTL emulation)\r\n VARSTRINGCHECKS_ON Compiling in the V+ state (type checking of shortstrings)\r\n STACKFRAMES_ON Compiling in the W+ state (generation of stack frames)\r\n EXTENDEDSYNTAX_ON Compiling in the X+ state (Delphi extended syntax enabled)\r\n*)\r\n\r\n{$DEFINE BORLAND}\r\n\r\n{ Set FreePascal to Delphi mode }\r\n{$IFDEF FPC}\r\n {$MODE DELPHI}\r\n {$ASMMODE Intel}\r\n {$UNDEF BORLAND}\r\n {$DEFINE CPUASM}\r\n // FPC defines CPU32, CPU64 and Unix automatically\r\n{$ENDIF}\r\n\r\n{$IFDEF BORLAND}\r\n {$IFDEF LINUX}\r\n {$DEFINE KYLIX}\r\n {$ENDIF LINUX}\r\n {$IFNDEF CLR}\r\n {$IFNDEF CPUX86}\r\n {$IFNDEF CPUX64}\r\n {$DEFINE CPU386} // For Borland compilers select the x86 compat assembler by default\r\n {$DEFINE CPU32} // Assume Borland compilers are 32-bit (rather than 64-bit)\r\n {$DEFINE CPUASM}\r\n {$ELSE ~CPUX64}\r\n {$DEFINE CPU64}\r\n {$DEFINE CPUASM}\r\n {$DEFINE DELPHI64_TEMPORARY}\r\n {$ENDIF ~CPUX64}\r\n {$ELSE ~CPUX86}\r\n {$DEFINE CPU386}\r\n {$DEFINE CPU32}\r\n {$DEFINE CPUASM}\r\n {$ENDIF ~CPUX86}\r\n {$ENDIF ~CLR}\r\n{$ENDIF BORLAND}\r\n\r\n{------------------------------------------------------------------------------}\r\n{ VERXXX to COMPILERX, DELPHIX and BCBX mappings }\r\n{------------------------------------------------------------------------------}\r\n\r\n{$IFDEF BORLAND}\r\n {$IFDEF KYLIX}\r\n {$I kylix.inc} // FPC incompatible stuff\r\n {$ELSE ~KYLIX}\r\n\r\n {$DEFINE UNKNOWN_COMPILER_VERSION}\r\n\r\n {$IFDEF VER80}\r\n {$DEFINE COMPILER1}\r\n {$DEFINE DELPHI1}\r\n {$DEFINE DELPHICOMPILER1}\r\n {$DEFINE RTL80_UP}\r\n {$UNDEF UNKNOWN_COMPILER_VERSION}\r\n {$ENDIF}\r\n\r\n {$IFDEF VER90}\r\n {$DEFINE COMPILER2}\r\n {$DEFINE DELPHI2}\r\n {$DEFINE DELPHICOMPILER2}\r\n {$DEFINE RTL90_UP}\r\n {$UNDEF UNKNOWN_COMPILER_VERSION}\r\n {$ENDIF}\r\n\r\n {$IFDEF VER93}\r\n {$DEFINE COMPILER2}\r\n {$DEFINE BCB1}\r\n {$DEFINE BCB}\r\n {$DEFINE RTL93_UP}\r\n {$UNDEF UNKNOWN_COMPILER_VERSION}\r\n {$ENDIF}\r\n\r\n {$IFDEF VER100}\r\n {$DEFINE COMPILER3}\r\n {$DEFINE DELPHI3}\r\n {$DEFINE DELPHICOMPILER3}\r\n {$DEFINE RTL100_UP}\r\n {$UNDEF UNKNOWN_COMPILER_VERSION}\r\n {$ENDIF}\r\n\r\n {$IFDEF VER110}\r\n {$DEFINE COMPILER35}\r\n {$DEFINE BCB3}\r\n {$DEFINE BCB}\r\n {$DEFINE RTL110_UP}\r\n {$UNDEF UNKNOWN_COMPILER_VERSION}\r\n {$ENDIF}\r\n\r\n {$IFDEF VER120}\r\n {$DEFINE COMPILER4}\r\n {$DEFINE DELPHI4}\r\n {$DEFINE DELPHICOMPILER4}\r\n {$DEFINE RTL120_UP}\r\n {$UNDEF UNKNOWN_COMPILER_VERSION}\r\n {$ENDIF}\r\n\r\n {$IFDEF VER125}\r\n {$DEFINE COMPILER4}\r\n {$DEFINE BCB4}\r\n {$DEFINE BCB}\r\n {$DEFINE RTL125_UP}\r\n {$UNDEF UNKNOWN_COMPILER_VERSION}\r\n {$ENDIF}\r\n\r\n {$IFDEF VER130}\r\n {$DEFINE COMPILER5}\r\n {$IFDEF BCB}\r\n {$DEFINE BCB5}\r\n {$ELSE}\r\n {$DEFINE DELPHI5}\r\n {$DEFINE DELPHICOMPILER5}\r\n {$ENDIF}\r\n {$DEFINE RTL130_UP}\r\n {$UNDEF UNKNOWN_COMPILER_VERSION}\r\n {$ENDIF}\r\n\r\n {$IFDEF VER140}\r\n {$DEFINE COMPILER6}\r\n {$IFDEF BCB}\r\n {$DEFINE BCB6}\r\n {$ELSE}\r\n {$DEFINE DELPHI6}\r\n {$DEFINE DELPHICOMPILER6}\r\n {$ENDIF}\r\n {$DEFINE RTL140_UP}\r\n {$UNDEF UNKNOWN_COMPILER_VERSION}\r\n {$ENDIF}\r\n\r\n {$IFDEF VER150}\r\n {$DEFINE COMPILER7}\r\n {$DEFINE DELPHI7}\r\n {$DEFINE DELPHICOMPILER7}\r\n {$DEFINE RTL150_UP}\r\n {$UNDEF UNKNOWN_COMPILER_VERSION}\r\n {$ENDIF}\r\n\r\n {$IFDEF VER160}\r\n {$DEFINE BDS2}\r\n {$DEFINE BDS}\r\n {$IFDEF CLR}\r\n {$DEFINE CLR10}\r\n {$ENDIF CLR}\r\n {$DEFINE COMPILER8}\r\n {$DEFINE DELPHI8}\r\n {$DEFINE DELPHICOMPILER8}\r\n {$DEFINE RTL160_UP}\r\n {$UNDEF UNKNOWN_COMPILER_VERSION}\r\n {$ENDIF}\r\n\r\n {$IFDEF VER170}\r\n {$DEFINE BDS3}\r\n {$DEFINE BDS}\r\n {$IFDEF CLR}\r\n {$DEFINE CLR11}\r\n {$ENDIF CLR}\r\n {$DEFINE COMPILER9}\r\n {$DEFINE DELPHI9}\r\n {$DEFINE DELPHI2005} // synonym to DELPHI9\r\n {$DEFINE DELPHICOMPILER9}\r\n {$DEFINE RTL170_UP}\r\n {$UNDEF UNKNOWN_COMPILER_VERSION}\r\n {$ENDIF}\r\n\r\n {$IFDEF VER180}\r\n {$DEFINE BDS}\r\n {$IFDEF CLR}\r\n {$DEFINE CLR11}\r\n {$ENDIF CLR}\r\n {$IFDEF VER185}\r\n {$DEFINE BDS5}\r\n {$DEFINE COMPILER11}\r\n {$IFDEF BCB}\r\n {$DEFINE BCB11}\r\n {$ELSE}\r\n {$DEFINE DELPHI11}\r\n {$DEFINE DELPHI2007} // synonym to DELPHI11\r\n {$DEFINE DELPHICOMPILER11}\r\n {$ENDIF}\r\n {$DEFINE RTL185_UP}\r\n {$ELSE ~~VER185}\r\n {$DEFINE BDS4}\r\n {$DEFINE COMPILER10}\r\n {$IFDEF BCB}\r\n {$DEFINE BCB10}\r\n {$ELSE}\r\n {$DEFINE DELPHI10}\r\n {$DEFINE DELPHI2006} // synonym to DELPHI10\r\n {$DEFINE DELPHICOMPILER10}\r\n {$ENDIF}\r\n {$DEFINE RTL180_UP}\r\n {$ENDIF ~VER185}\r\n {$UNDEF UNKNOWN_COMPILER_VERSION}\r\n {$ENDIF}\r\n\r\n {$IFDEF VER190} // Delphi 2007 for .NET\r\n {$DEFINE BDS}\r\n {$DEFINE BDS5}\r\n {$IFDEF CLR}\r\n {$DEFINE CLR20}\r\n {$ENDIF CLR}\r\n {$DEFINE COMPILER11}\r\n {$DEFINE DELPHI11}\r\n {$DEFINE DELPHI2007} // synonym to DELPHI11\r\n {$DEFINE DELPHICOMPILER11}\r\n {$DEFINE RTL190_UP}\r\n {$UNDEF UNKNOWN_COMPILER_VERSION}\r\n {$ENDIF VER190}\r\n\r\n {$IFDEF VER200} // RAD Studio 2009\r\n {$DEFINE BDS}\r\n {$DEFINE BDS6}\r\n {$IFDEF CLR}\r\n {$DEFINE CLR20}\r\n {$ENDIF CLR}\r\n {$DEFINE COMPILER12}\r\n {$IFDEF BCB}\r\n {$DEFINE BCB12}\r\n {$ELSE}\r\n {$DEFINE DELPHI12}\r\n {$DEFINE DELPHI2009} // synonym to DELPHI12\r\n {$DEFINE DELPHICOMPILER12}\r\n {$ENDIF BCB}\r\n {$IFDEF CLR}\r\n {$DEFINE RTL190_UP}\r\n {$ELSE}\r\n {$DEFINE RTL200_UP}\r\n {$ENDIF}\r\n {$UNDEF UNKNOWN_COMPILER_VERSION}\r\n {$ENDIF VER200}\r\n\r\n {$IFDEF VER210} // RAD Studio 2010\r\n {$DEFINE BDS}\r\n {$DEFINE BDS7}\r\n {$DEFINE COMPILER14}\r\n {$IFDEF BCB}\r\n {$DEFINE BCB14}\r\n {$ELSE}\r\n {$DEFINE DELPHI14}\r\n {$DEFINE DELPHI2010} // synonym to DELPHI14\r\n {$DEFINE DELPHICOMPILER14}\r\n {$ENDIF BCB}\r\n {$DEFINE RTL210_UP}\r\n {$UNDEF UNKNOWN_COMPILER_VERSION}\r\n {$ENDIF VER210}\r\n\r\n {$IFDEF VER220} // RAD Studio XE\r\n {$DEFINE BDS}\r\n {$DEFINE BDS8}\r\n {$DEFINE COMPILER15}\r\n {$IFDEF BCB}\r\n {$DEFINE BCB15}\r\n {$ELSE}\r\n {$DEFINE DELPHI15}\r\n {$DEFINE DELPHIXE} // synonym to DELPHI15\r\n {$DEFINE DELPHICOMPILER15}\r\n {$ENDIF BCB}\r\n {$DEFINE RTL220_UP}\r\n {$UNDEF UNKNOWN_COMPILER_VERSION}\r\n {$ENDIF VER220}\r\n\r\n {$IFDEF VER230} // RAD Studio XE2\r\n {$DEFINE BDS}\r\n {$DEFINE BDS9}\r\n {$DEFINE COMPILER16}\r\n {$IFDEF BCB}\r\n {$DEFINE BCB16}\r\n {$ELSE}\r\n {$DEFINE DELPHI16}\r\n {$DEFINE DELPHIXE2} // synonym to DELPHI16\r\n {$DEFINE DELPHICOMPILER16}\r\n {$ENDIF BCB}\r\n {$DEFINE RTL230_UP}\r\n {$UNDEF UNKNOWN_COMPILER_VERSION}\r\n {$ENDIF VER230}\r\n\r\n {$IFDEF VER240} // RAD Studio XE3\r\n {$DEFINE BDS}\r\n {$DEFINE BDS10}\r\n {$DEFINE COMPILER17}\r\n {$IFDEF BCB}\r\n {$DEFINE BCB17}\r\n {$ELSE}\r\n {$DEFINE DELPHI17}\r\n {$DEFINE DELPHIXE3} // synonym to DELPHI17\r\n {$DEFINE DELPHICOMPILER17}\r\n {$ENDIF BCB}\r\n {$DEFINE RTL240_UP}\r\n {$UNDEF UNKNOWN_COMPILER_VERSION}\r\n {$ENDIF VER240}\r\n\r\n {$IFDEF UNKNOWN_COMPILER_VERSION} // adjust for newer version (always use latest version)\r\n {$DEFINE BDS}\r\n {$DEFINE BDS10}\r\n {$DEFINE COMPILER17}\r\n {$IFDEF BCB}\r\n {$DEFINE BCB17}\r\n {$ELSE}\r\n {$DEFINE DELPHI17}\r\n {$DEFINE DELPHIXE3} // synonym to DELPHI17\r\n {$DEFINE DELPHICOMPILER17}\r\n {$ENDIF BCB}\r\n {$DEFINE RTL240_UP}\r\n {$UNDEF UNKNOWN_COMPILER_VERSION}\r\n {$ENDIF}\r\n\r\n {$ENDIF ~KYLIX}\r\n\r\n {$IFDEF BCB}\r\n {$DEFINE CPPBUILDER}\r\n {$DEFINE BCBCOMPILER}\r\n {$ELSE ~BCB}\r\n {$DEFINE DELPHI}\r\n {$DEFINE DELPHICOMPILER}\r\n {$ENDIF ~BCB}\r\n\r\n{$ENDIF BORLAND}\r\n\r\n{------------------------------------------------------------------------------}\r\n{ DELPHIX_UP from DELPHIX mappings }\r\n{------------------------------------------------------------------------------}\r\n\r\n{$IFDEF DELPHI17} {$DEFINE DELPHI17_UP} {$ENDIF}\r\n{$IFDEF DELPHI16} {$DEFINE DELPHI16_UP} {$ENDIF}\r\n{$IFDEF DELPHI15} {$DEFINE DELPHI15_UP} {$ENDIF}\r\n{$IFDEF DELPHI14} {$DEFINE DELPHI14_UP} {$ENDIF}\r\n{$IFDEF DELPHI12} {$DEFINE DELPHI12_UP} {$ENDIF}\r\n{$IFDEF DELPHI11} {$DEFINE DELPHI11_UP} {$ENDIF}\r\n{$IFDEF DELPHI10} {$DEFINE DELPHI10_UP} {$ENDIF}\r\n{$IFDEF DELPHI9} {$DEFINE DELPHI9_UP} {$ENDIF}\r\n{$IFDEF DELPHI8} {$DEFINE DELPHI8_UP} {$ENDIF}\r\n{$IFDEF DELPHI7} {$DEFINE DELPHI7_UP} {$ENDIF}\r\n{$IFDEF DELPHI6} {$DEFINE DELPHI6_UP} {$ENDIF}\r\n{$IFDEF DELPHI5} {$DEFINE DELPHI5_UP} {$ENDIF}\r\n{$IFDEF DELPHI4} {$DEFINE DELPHI4_UP} {$ENDIF}\r\n{$IFDEF DELPHI3} {$DEFINE DELPHI3_UP} {$ENDIF}\r\n{$IFDEF DELPHI2} {$DEFINE DELPHI2_UP} {$ENDIF}\r\n{$IFDEF DELPHI1} {$DEFINE DELPHI1_UP} {$ENDIF}\r\n\r\n{------------------------------------------------------------------------------}\r\n{ DELPHIX_UP from DELPHIX_UP mappings }\r\n{------------------------------------------------------------------------------}\r\n\r\n{$IFDEF DELPHI17_UP}\r\n {$DEFINE DELPHIXE3_UP} // synonym to DELPHI17_UP\r\n {$DEFINE DELPHI16_UP}\r\n{$ENDIF}\r\n\r\n{$IFDEF DELPHI16_UP}\r\n {$DEFINE DELPHIXE2_UP} // synonym to DELPHI16_UP\r\n {$DEFINE DELPHI15_UP}\r\n{$ENDIF}\r\n\r\n{$IFDEF DELPHI15_UP}\r\n {$DEFINE DELPHIXE_UP} // synonym to DELPHI15_UP\r\n {$DEFINE DELPHI14_UP}\r\n{$ENDIF}\r\n\r\n{$IFDEF DELPHI14_UP}\r\n {$DEFINE DELPHI2010_UP} // synonym to DELPHI14_UP\r\n {$DEFINE DELPHI12_UP}\r\n{$ENDIF}\r\n\r\n{$IFDEF DELPHI12_UP}\r\n {$DEFINE DELPHI2009_UP} // synonym to DELPHI12_UP\r\n {$DEFINE DELPHI11_UP}\r\n{$ENDIF}\r\n\r\n{$IFDEF DELPHI11_UP}\r\n {$DEFINE DELPHI2007_UP} // synonym to DELPHI11_UP\r\n {$DEFINE DELPHI10_UP}\r\n{$ENDIF}\r\n\r\n{$IFDEF DELPHI10_UP}\r\n {$DEFINE DELPHI2006_UP} // synonym to DELPHI10_UP\r\n {$DEFINE DELPHI9_UP}\r\n{$ENDIF}\r\n\r\n{$IFDEF DELPHI9_UP}\r\n {$DEFINE DELPHI2005_UP} // synonym to DELPHI9_UP\r\n {$DEFINE DELPHI8_UP}\r\n{$ENDIF}\r\n\r\n{$IFDEF DELPHI8_UP} {$DEFINE DELPHI7_UP} {$ENDIF}\r\n{$IFDEF DELPHI7_UP} {$DEFINE DELPHI6_UP} {$ENDIF}\r\n{$IFDEF DELPHI6_UP} {$DEFINE DELPHI5_UP} {$ENDIF}\r\n{$IFDEF DELPHI5_UP} {$DEFINE DELPHI4_UP} {$ENDIF}\r\n{$IFDEF DELPHI4_UP} {$DEFINE DELPHI3_UP} {$ENDIF}\r\n{$IFDEF DELPHI3_UP} {$DEFINE DELPHI2_UP} {$ENDIF}\r\n{$IFDEF DELPHI2_UP} {$DEFINE DELPHI1_UP} {$ENDIF}\r\n\r\n{------------------------------------------------------------------------------}\r\n{ BCBX_UP from BCBX mappings }\r\n{------------------------------------------------------------------------------}\r\n\r\n{$IFDEF BCB17} {$DEFINE BCB17_UP} {$ENDIF}\r\n{$IFDEF BCB16} {$DEFINE BCB16_UP} {$ENDIF}\r\n{$IFDEF BCB15} {$DEFINE BCB15_UP} {$ENDIF}\r\n{$IFDEF BCB14} {$DEFINE BCB14_UP} {$ENDIF}\r\n{$IFDEF BCB12} {$DEFINE BCB12_UP} {$ENDIF}\r\n{$IFDEF BCB11} {$DEFINE BCB11_UP} {$ENDIF}\r\n{$IFDEF BCB10} {$DEFINE BCB10_UP} {$ENDIF}\r\n{$IFDEF BCB6} {$DEFINE BCB6_UP} {$ENDIF}\r\n{$IFDEF BCB5} {$DEFINE BCB5_UP} {$ENDIF}\r\n{$IFDEF BCB4} {$DEFINE BCB4_UP} {$ENDIF}\r\n{$IFDEF BCB3} {$DEFINE BCB3_UP} {$ENDIF}\r\n{$IFDEF BCB1} {$DEFINE BCB1_UP} {$ENDIF}\r\n\r\n{------------------------------------------------------------------------------}\r\n{ BCBX_UP from BCBX_UP mappings }\r\n{------------------------------------------------------------------------------}\r\n\r\n{$IFDEF BCB17_UP} {$DEFINE BCB16_UP} {$ENDIF}\r\n{$IFDEF BCB16_UP} {$DEFINE BCB15_UP} {$ENDIF}\r\n{$IFDEF BCB15_UP} {$DEFINE BCB14_UP} {$ENDIF}\r\n{$IFDEF BCB14_UP} {$DEFINE BCB12_UP} {$ENDIF}\r\n{$IFDEF BCB12_UP} {$DEFINE BCB11_UP} {$ENDIF}\r\n{$IFDEF BCB11_UP} {$DEFINE BCB10_UP} {$ENDIF}\r\n{$IFDEF BCB10_UP} {$DEFINE BCB6_UP} {$ENDIF}\r\n{$IFDEF BCB6_UP} {$DEFINE BCB5_UP} {$ENDIF}\r\n{$IFDEF BCB5_UP} {$DEFINE BCB4_UP} {$ENDIF}\r\n{$IFDEF BCB4_UP} {$DEFINE BCB3_UP} {$ENDIF}\r\n{$IFDEF BCB3_UP} {$DEFINE BCB1_UP} {$ENDIF}\r\n\r\n{------------------------------------------------------------------------------}\r\n{ BDSX_UP from BDSX mappings }\r\n{------------------------------------------------------------------------------}\r\n\r\n{$IFDEF BDS10} {$DEFINE BDS10_UP} {$ENDIF}\r\n{$IFDEF BDS9} {$DEFINE BDS9_UP} {$ENDIF}\r\n{$IFDEF BDS8} {$DEFINE BDS8_UP} {$ENDIF}\r\n{$IFDEF BDS7} {$DEFINE BDS7_UP} {$ENDIF}\r\n{$IFDEF BDS6} {$DEFINE BDS6_UP} {$ENDIF}\r\n{$IFDEF BDS5} {$DEFINE BDS5_UP} {$ENDIF}\r\n{$IFDEF BDS4} {$DEFINE BDS4_UP} {$ENDIF}\r\n{$IFDEF BDS3} {$DEFINE BDS3_UP} {$ENDIF}\r\n{$IFDEF BDS2} {$DEFINE BDS2_UP} {$ENDIF}\r\n\r\n{------------------------------------------------------------------------------}\r\n{ BDSX_UP from BDSX_UP mappings }\r\n{------------------------------------------------------------------------------}\r\n\r\n{$IFDEF BDS10_UP} {$DEFINE BDS9_UP} {$ENDIF}\r\n{$IFDEF BDS9_UP} {$DEFINE BDS8_UP} {$ENDIF}\r\n{$IFDEF BDS8_UP} {$DEFINE BDS7_UP} {$ENDIF}\r\n{$IFDEF BDS7_UP} {$DEFINE BDS6_UP} {$ENDIF}\r\n{$IFDEF BDS6_UP} {$DEFINE BDS5_UP} {$ENDIF}\r\n{$IFDEF BDS5_UP} {$DEFINE BDS4_UP} {$ENDIF}\r\n{$IFDEF BDS4_UP} {$DEFINE BDS3_UP} {$ENDIF}\r\n{$IFDEF BDS3_UP} {$DEFINE BDS2_UP} {$ENDIF}\r\n\r\n{------------------------------------------------------------------------------}\r\n{ DELPHICOMPILERX_UP from DELPHICOMPILERX mappings }\r\n{------------------------------------------------------------------------------}\r\n\r\n{$IFDEF DELPHICOMPILER17} {$DEFINE DELPHICOMPILER17_UP} {$ENDIF}\r\n{$IFDEF DELPHICOMPILER16} {$DEFINE DELPHICOMPILER16_UP} {$ENDIF}\r\n{$IFDEF DELPHICOMPILER15} {$DEFINE DELPHICOMPILER15_UP} {$ENDIF}\r\n{$IFDEF DELPHICOMPILER14} {$DEFINE DELPHICOMPILER14_UP} {$ENDIF}\r\n{$IFDEF DELPHICOMPILER12} {$DEFINE DELPHICOMPILER12_UP} {$ENDIF}\r\n{$IFDEF DELPHICOMPILER11} {$DEFINE DELPHICOMPILER11_UP} {$ENDIF}\r\n{$IFDEF DELPHICOMPILER10} {$DEFINE DELPHICOMPILER10_UP} {$ENDIF}\r\n{$IFDEF DELPHICOMPILER9} {$DEFINE DELPHICOMPILER9_UP} {$ENDIF}\r\n{$IFDEF DELPHICOMPILER8} {$DEFINE DELPHICOMPILER8_UP} {$ENDIF}\r\n{$IFDEF DELPHICOMPILER7} {$DEFINE DELPHICOMPILER7_UP} {$ENDIF}\r\n{$IFDEF DELPHICOMPILER6} {$DEFINE DELPHICOMPILER6_UP} {$ENDIF}\r\n{$IFDEF DELPHICOMPILER5} {$DEFINE DELPHICOMPILER5_UP} {$ENDIF}\r\n{$IFDEF DELPHICOMPILER4} {$DEFINE DELPHICOMPILER4_UP} {$ENDIF}\r\n{$IFDEF DELPHICOMPILER3} {$DEFINE DELPHICOMPILER3_UP} {$ENDIF}\r\n{$IFDEF DELPHICOMPILER2} {$DEFINE DELPHICOMPILER2_UP} {$ENDIF}\r\n{$IFDEF DELPHICOMPILER1} {$DEFINE DELPHICOMPILER1_UP} {$ENDIF}\r\n\r\n{------------------------------------------------------------------------------}\r\n{ DELPHICOMPILERX_UP from DELPHICOMPILERX_UP mappings }\r\n{------------------------------------------------------------------------------}\r\n\r\n{$IFDEF DELPHICOMPILER17_UP} {$DEFINE DELPHICOMPILER16_UP} {$ENDIF}\r\n{$IFDEF DELPHICOMPILER16_UP} {$DEFINE DELPHICOMPILER15_UP} {$ENDIF}\r\n{$IFDEF DELPHICOMPILER15_UP} {$DEFINE DELPHICOMPILER14_UP} {$ENDIF}\r\n{$IFDEF DELPHICOMPILER14_UP} {$DEFINE DELPHICOMPILER12_UP} {$ENDIF}\r\n{$IFDEF DELPHICOMPILER12_UP} {$DEFINE DELPHICOMPILER11_UP} {$ENDIF}\r\n{$IFDEF DELPHICOMPILER11_UP} {$DEFINE DELPHICOMPILER10_UP} {$ENDIF}\r\n{$IFDEF DELPHICOMPILER10_UP} {$DEFINE DELPHICOMPILER9_UP} {$ENDIF}\r\n{$IFDEF DELPHICOMPILER9_UP} {$DEFINE DELPHICOMPILER8_UP} {$ENDIF}\r\n{$IFDEF DELPHICOMPILER8_UP} {$DEFINE DELPHICOMPILER7_UP} {$ENDIF}\r\n{$IFDEF DELPHICOMPILER8_UP} {$DEFINE DELPHICOMPILER7_UP} {$ENDIF}\r\n{$IFDEF DELPHICOMPILER7_UP} {$DEFINE DELPHICOMPILER6_UP} {$ENDIF}\r\n{$IFDEF DELPHICOMPILER6_UP} {$DEFINE DELPHICOMPILER5_UP} {$ENDIF}\r\n{$IFDEF DELPHICOMPILER5_UP} {$DEFINE DELPHICOMPILER4_UP} {$ENDIF}\r\n{$IFDEF DELPHICOMPILER4_UP} {$DEFINE DELPHICOMPILER3_UP} {$ENDIF}\r\n{$IFDEF DELPHICOMPILER3_UP} {$DEFINE DELPHICOMPILER2_UP} {$ENDIF}\r\n{$IFDEF DELPHICOMPILER2_UP} {$DEFINE DELPHICOMPILER1_UP} {$ENDIF}\r\n\r\n{------------------------------------------------------------------------------}\r\n{ COMPILERX_UP from COMPILERX mappings }\r\n{------------------------------------------------------------------------------}\r\n\r\n{$IFDEF COMPILER17} {$DEFINE COMPILER17_UP} {$ENDIF}\r\n{$IFDEF COMPILER16} {$DEFINE COMPILER16_UP} {$ENDIF}\r\n{$IFDEF COMPILER15} {$DEFINE COMPILER15_UP} {$ENDIF}\r\n{$IFDEF COMPILER14} {$DEFINE COMPILER14_UP} {$ENDIF}\r\n{$IFDEF COMPILER12} {$DEFINE COMPILER12_UP} {$ENDIF}\r\n{$IFDEF COMPILER11} {$DEFINE COMPILER11_UP} {$ENDIF}\r\n{$IFDEF COMPILER10} {$DEFINE COMPILER10_UP} {$ENDIF}\r\n{$IFDEF COMPILER9} {$DEFINE COMPILER9_UP} {$ENDIF}\r\n{$IFDEF COMPILER8} {$DEFINE COMPILER8_UP} {$ENDIF}\r\n{$IFDEF COMPILER7} {$DEFINE COMPILER7_UP} {$ENDIF}\r\n{$IFDEF COMPILER6} {$DEFINE COMPILER6_UP} {$ENDIF}\r\n{$IFDEF COMPILER5} {$DEFINE COMPILER5_UP} {$ENDIF}\r\n{$IFDEF COMPILER4} {$DEFINE COMPILER4_UP} {$ENDIF}\r\n{$IFDEF COMPILER35} {$DEFINE COMPILER35_UP} {$ENDIF}\r\n{$IFDEF COMPILER3} {$DEFINE COMPILER3_UP} {$ENDIF}\r\n{$IFDEF COMPILER2} {$DEFINE COMPILER2_UP} {$ENDIF}\r\n{$IFDEF COMPILER1} {$DEFINE COMPILER1_UP} {$ENDIF}\r\n\r\n{------------------------------------------------------------------------------}\r\n{ COMPILERX_UP from COMPILERX_UP mappings }\r\n{------------------------------------------------------------------------------}\r\n\r\n{$IFDEF COMPILER17_UP} {$DEFINE COMPILER16_UP} {$ENDIF}\r\n{$IFDEF COMPILER16_UP} {$DEFINE COMPILER15_UP} {$ENDIF}\r\n{$IFDEF COMPILER15_UP} {$DEFINE COMPILER14_UP} {$ENDIF}\r\n{$IFDEF COMPILER14_UP} {$DEFINE COMPILER12_UP} {$ENDIF}\r\n{$IFDEF COMPILER12_UP} {$DEFINE COMPILER11_UP} {$ENDIF}\r\n{$IFDEF COMPILER11_UP} {$DEFINE COMPILER10_UP} {$ENDIF}\r\n{$IFDEF COMPILER10_UP} {$DEFINE COMPILER9_UP} {$ENDIF}\r\n{$IFDEF COMPILER9_UP} {$DEFINE COMPILER8_UP} {$ENDIF}\r\n{$IFDEF COMPILER8_UP} {$DEFINE COMPILER7_UP} {$ENDIF}\r\n{$IFDEF COMPILER7_UP} {$DEFINE COMPILER6_UP} {$ENDIF}\r\n{$IFDEF COMPILER6_UP} {$DEFINE COMPILER5_UP} {$ENDIF}\r\n{$IFDEF COMPILER5_UP} {$DEFINE COMPILER4_UP} {$ENDIF}\r\n{$IFDEF COMPILER4_UP} {$DEFINE COMPILER35_UP} {$ENDIF}\r\n{$IFDEF COMPILER35_UP} {$DEFINE COMPILER3_UP} {$ENDIF}\r\n{$IFDEF COMPILER3_UP} {$DEFINE COMPILER2_UP} {$ENDIF}\r\n{$IFDEF COMPILER2_UP} {$DEFINE COMPILER1_UP} {$ENDIF}\r\n\r\n{------------------------------------------------------------------------------}\r\n{ RTLX_UP from RTLX_UP mappings }\r\n{------------------------------------------------------------------------------}\r\n\r\n{$IFDEF RTL240_UP} {$DEFINE RTL230_UP} {$ENDIF}\r\n{$IFDEF RTL230_UP} {$DEFINE RTL220_UP} {$ENDIF}\r\n{$IFDEF RTL220_UP} {$DEFINE RTL210_UP} {$ENDIF}\r\n{$IFDEF RTL210_UP} {$DEFINE RTL200_UP} {$ENDIF}\r\n{$IFDEF RTL200_UP} {$DEFINE RTL190_UP} {$ENDIF}\r\n{$IFDEF RTL190_UP} {$DEFINE RTL185_UP} {$ENDIF}\r\n{$IFDEF RTL185_UP} {$DEFINE RTL180_UP} {$ENDIF}\r\n{$IFDEF RTL180_UP} {$DEFINE RTL170_UP} {$ENDIF}\r\n{$IFDEF RTL170_UP} {$DEFINE RTL160_UP} {$ENDIF}\r\n{$IFDEF RTL160_UP} {$DEFINE RTL150_UP} {$ENDIF}\r\n{$IFDEF RTL150_UP} {$DEFINE RTL145_UP} {$ENDIF}\r\n{$IFDEF RTL145_UP} {$DEFINE RTL142_UP} {$ENDIF}\r\n{$IFDEF RTL142_UP} {$DEFINE RTL140_UP} {$ENDIF}\r\n{$IFDEF RTL140_UP} {$DEFINE RTL130_UP} {$ENDIF}\r\n{$IFDEF RTL130_UP} {$DEFINE RTL125_UP} {$ENDIF}\r\n{$IFDEF RTL125_UP} {$DEFINE RTL120_UP} {$ENDIF}\r\n{$IFDEF RTL120_UP} {$DEFINE RTL110_UP} {$ENDIF}\r\n{$IFDEF RTL110_UP} {$DEFINE RTL100_UP} {$ENDIF}\r\n{$IFDEF RTL100_UP} {$DEFINE RTL93_UP} {$ENDIF}\r\n{$IFDEF RTL93_UP} {$DEFINE RTL90_UP} {$ENDIF}\r\n{$IFDEF RTL90_UP} {$DEFINE RTL80_UP} {$ENDIF}\r\n\r\n{------------------------------------------------------------------------------}\r\n{ Check for CLR overrides of default detection }\r\n{------------------------------------------------------------------------------}\r\n\r\n{$IFDEF CLR}\r\n {$IFDEF FORCE_CLR10}\r\n {$DEFINE CLR10}\r\n {$UNDEF CLR11}\r\n {$UNDEF CLR20}\r\n {$ENDIF FORCE_CLR10}\r\n\r\n {$IFDEF FORCE_CLR11}\r\n {$UNDEF CLR10}\r\n {$DEFINE CLR11}\r\n {$UNDEF CLR20}\r\n {$ENDIF FORCE_CLR11}\r\n\r\n {$IFDEF FORCE_CLR20}\r\n {$UNDEF CLR10}\r\n {$UNDEF CLR11}\r\n {$DEFINE CLR20}\r\n {$ENDIF FORCE_CLR20}\r\n{$ENDIF CLR}\r\n\r\n{------------------------------------------------------------------------------}\r\n{ CLRX from CLRX_UP mappings }\r\n{------------------------------------------------------------------------------}\r\n\r\n{$IFDEF CLR10} {$DEFINE CLR10_UP} {$ENDIF}\r\n{$IFDEF CLR11} {$DEFINE CLR11_UP} {$ENDIF}\r\n{$IFDEF CLR20} {$DEFINE CLR20_UP} {$ENDIF}\r\n\r\n{------------------------------------------------------------------------------}\r\n{ CLRX_UP from CLRX_UP mappings }\r\n{------------------------------------------------------------------------------}\r\n\r\n{$IFDEF CLR20_UP} {$DEFINE CLR11_UP} {$ENDIF}\r\n{$IFDEF CLR11_UP} {$DEFINE CLR10_UP} {$ENDIF}\r\n\r\n{------------------------------------------------------------------------------}\r\n\r\n{$IFDEF DELPHICOMPILER}\r\n {$DEFINE DELPHILANGUAGE}\r\n{$ENDIF}\r\n\r\n{$IFDEF BCBCOMPILER}\r\n {$DEFINE DELPHILANGUAGE}\r\n{$ENDIF}\r\n\r\n{------------------------------------------------------------------------------}\r\n{ KYLIXX_UP from KYLIXX mappings }\r\n{------------------------------------------------------------------------------}\r\n\r\n{$IFDEF KYLIX3} {$DEFINE KYLIX3_UP} {$ENDIF}\r\n{$IFDEF KYLIX2} {$DEFINE KYLIX2_UP} {$ENDIF}\r\n{$IFDEF KYLIX1} {$DEFINE KYLIX1_UP} {$ENDIF}\r\n\r\n{------------------------------------------------------------------------------}\r\n{ KYLIXX_UP from KYLIXX_UP mappings }\r\n{------------------------------------------------------------------------------}\r\n\r\n{$IFDEF KYLIX3_UP} {$DEFINE KYLIX2_UP} {$ENDIF}\r\n{$IFDEF KYLIX2_UP} {$DEFINE KYLIX1_UP} {$ENDIF}\r\n\r\n{------------------------------------------------------------------------------}\r\n{ Map COMPILERX_UP to friendly feature names }\r\n{------------------------------------------------------------------------------}\r\n\r\n{$IFDEF FPC}\r\n {$IFDEF VER1_0}\r\n Please use FPC 2.0 or higher to compile this.\r\n {$ELSE}\r\n {$DEFINE SUPPORTS_OUTPARAMS}\r\n {$DEFINE SUPPORTS_WIDECHAR}\r\n {$DEFINE SUPPORTS_WIDESTRING}\r\n {$IFDEF HASINTF}\r\n {$DEFINE SUPPORTS_INTERFACE}\r\n {$ENDIF}\r\n {$IFDEF HASVARIANT}\r\n {$DEFINE SUPPORTS_VARIANT}\r\n {$ENDIF}\r\n {$IFDEF FPC_HAS_TYPE_SINGLE}\r\n {$DEFINE SUPPORTS_SINGLE}\r\n {$ENDIF}\r\n {$IFDEF FPC_HAS_TYPE_DOUBLE}\r\n {$DEFINE SUPPORTS_DOUBLE}\r\n {$ENDIF}\r\n {$IFDEF FPC_HAS_TYPE_EXTENDED}\r\n {$DEFINE SUPPORTS_EXTENDED}\r\n {$ENDIF}\r\n {$IFDEF HASCURRENCY}\r\n {$DEFINE SUPPORTS_CURRENCY}\r\n {$ENDIF}\r\n {$DEFINE SUPPORTS_THREADVAR}\r\n {$DEFINE SUPPORTS_CONSTPARAMS}\r\n {$DEFINE SUPPORTS_LONGWORD}\r\n {$DEFINE SUPPORTS_INT64}\r\n {$DEFINE SUPPORTS_DYNAMICARRAYS}\r\n {$DEFINE SUPPORTS_DEFAULTPARAMS}\r\n {$DEFINE SUPPORTS_OVERLOAD}\r\n {$DEFINE ACCEPT_DEPRECATED} // 2.2 also gives warnings\r\n {$DEFINE ACCEPT_PLATFORM} // 2.2 also gives warnings\r\n {$DEFINE ACCEPT_LIBRARY}\r\n {$DEFINE SUPPORTS_EXTSYM}\r\n {$DEFINE SUPPORTS_NODEFINE}\r\n\r\n {$DEFINE SUPPORTS_CUSTOMVARIANTS}\r\n {$DEFINE SUPPORTS_VARARGS}\r\n {$DEFINE SUPPORTS_ENUMVALUE}\r\n {$IFDEF LINUX}\r\n {$DEFINE HAS_UNIT_LIBC}\r\n {$ENDIF LINUX}\r\n {$DEFINE HAS_UNIT_CONTNRS}\r\n {$DEFINE HAS_UNIT_TYPES}\r\n {$DEFINE HAS_UNIT_VARIANTS}\r\n {$DEFINE HAS_UNIT_STRUTILS}\r\n {$DEFINE HAS_UNIT_DATEUTILS}\r\n {$DEFINE HAS_UNIT_RTLCONSTS}\r\n\r\n {$DEFINE XPLATFORM_RTL}\r\n\r\n {$IFDEF VER2_2}\r\n {$DEFINE SUPPORTS_DISPINTERFACE}\r\n {$DEFINE SUPPORTS_IMPLEMENTS}\r\n {$DEFINE SUPPORTS_DISPID}\r\n {$ELSE}\r\n {$UNDEF SUPPORTS_DISPINTERFACE}\r\n {$UNDEF SUPPORTS_IMPLEMENTS}\r\n {$endif}\r\n {$UNDEF SUPPORTS_UNSAFE_WARNINGS}\r\n {$ENDIF}\r\n{$ENDIF FPC}\r\n\r\n{$IFDEF CLR}\r\n {$DEFINE SUPPORTS_UNICODE}\r\n{$ENDIF CLR}\r\n\r\n{$IFDEF COMPILER1_UP}\r\n {$DEFINE SUPPORTS_CONSTPARAMS}\r\n {$DEFINE SUPPORTS_SINGLE}\r\n {$DEFINE SUPPORTS_DOUBLE}\r\n {$DEFINE SUPPORTS_EXTENDED}\r\n {$DEFINE SUPPORTS_PACKAGES} \r\n{$ENDIF COMPILER1_UP}\r\n\r\n{$IFDEF COMPILER2_UP}\r\n {$DEFINE SUPPORTS_CURRENCY}\r\n {$DEFINE SUPPORTS_THREADVAR}\r\n {$DEFINE SUPPORTS_VARIANT}\r\n {$DEFINE SUPPORTS_WIDECHAR}\r\n{$ENDIF COMPILER2_UP}\r\n\r\n{$IFDEF COMPILER3_UP}\r\n {$DEFINE SUPPORTS_OUTPARAMS}\r\n {$DEFINE SUPPORTS_WIDESTRING}\r\n {$DEFINE SUPPORTS_INTERFACE}\r\n {$DEFINE SUPPORTS_DISPINTERFACE}\r\n {$DEFINE SUPPORTS_DISPID}\r\n {$DEFINE SUPPORTS_WEAKPACKAGEUNIT}\r\n{$ENDIF COMPILER3_UP}\r\n\r\n{$IFDEF COMPILER35_UP}\r\n {$DEFINE SUPPORTS_EXTSYM}\r\n {$DEFINE SUPPORTS_NODEFINE}\r\n{$ENDIF COMPILER35_UP}\r\n\r\n{$IFDEF COMPILER4_UP}\r\n {$DEFINE SUPPORTS_LONGWORD}\r\n {$DEFINE SUPPORTS_INT64}\r\n {$DEFINE SUPPORTS_DYNAMICARRAYS}\r\n {$DEFINE SUPPORTS_DEFAULTPARAMS}\r\n {$DEFINE SUPPORTS_OVERLOAD}\r\n {$DEFINE SUPPORTS_IMPLEMENTS}\r\n{$ENDIF COMPILER4_UP}\r\n\r\n{$IFDEF COMPILER6_UP}\r\n {$DEFINE SUPPORTS_DEPRECATED}\r\n {$DEFINE SUPPORTS_LIBRARY}\r\n {$DEFINE SUPPORTS_PLATFORM}\r\n {$DEFINE SUPPORTS_LOCAL}\r\n {$DEFINE SUPPORTS_SETPEFLAGS}\r\n {$DEFINE SUPPORTS_EXPERIMENTAL_WARNINGS}\r\n {$DEFINE ACCEPT_DEPRECATED}\r\n {$DEFINE ACCEPT_PLATFORM}\r\n {$DEFINE ACCEPT_LIBRARY}\r\n {$DEFINE SUPPORTS_DEPRECATED_WARNINGS}\r\n {$DEFINE SUPPORTS_LIBRARY_WARNINGS}\r\n {$DEFINE SUPPORTS_PLATFORM_WARNINGS}\r\n {$DEFINE SUPPORTS_CUSTOMVARIANTS}\r\n {$DEFINE SUPPORTS_VARARGS}\r\n {$DEFINE SUPPORTS_ENUMVALUE}\r\n {$DEFINE SUPPORTS_COMPILETIME_MESSAGES}\r\n{$ENDIF COMPILER6_UP}\r\n\r\n{$IFDEF COMPILER7_UP}\r\n {$DEFINE SUPPORTS_UNSAFE_WARNINGS}\r\n{$ENDIF COMPILER7_UP}\r\n\r\n{$IFDEF COMPILER9_UP}\r\n {$DEFINE SUPPORTS_FOR_IN}\r\n {$DEFINE SUPPORTS_INLINE}\r\n {$DEFINE SUPPORTS_NESTED_CONSTANTS}\r\n {$DEFINE SUPPORTS_NESTED_TYPES}\r\n {$DEFINE SUPPORTS_REGION}\r\n {$IFDEF CLR}\r\n {$DEFINE SUPPORTS_ENHANCED_RECORDS}\r\n {$DEFINE SUPPORTS_CLASS_FIELDS}\r\n {$DEFINE SUPPORTS_CLASS_HELPERS}\r\n {$DEFINE SUPPORTS_CLASS_OPERATORS}\r\n {$DEFINE SUPPORTS_STRICT}\r\n {$DEFINE SUPPORTS_STATIC}\r\n {$DEFINE SUPPORTS_FINAL}\r\n {$ENDIF CLR}\r\n{$ENDIF COMPILER9_UP}\r\n\r\n{$IFDEF COMPILER10_UP}\r\n {$DEFINE SUPPORTS_ENHANCED_RECORDS}\r\n {$DEFINE SUPPORTS_CLASS_FIELDS}\r\n {$DEFINE SUPPORTS_CLASS_HELPERS}\r\n {$DEFINE SUPPORTS_CLASS_OPERATORS}\r\n {$DEFINE SUPPORTS_STRICT}\r\n {$DEFINE SUPPORTS_STATIC}\r\n {$DEFINE SUPPORTS_FINAL}\r\n {$DEFINE SUPPORTS_METHODINFO}\r\n{$ENDIF COMPILER10_UP}\r\n\r\n{$IFDEF COMPILER11_UP}\r\n {$IFDEF CLR}\r\n {$DEFINE SUPPORTS_GENERICS}\r\n {$DEFINE SUPPORTS_DEPRECATED_DETAILS}\r\n {$ENDIF CLR}\r\n{$ENDIF COMPILER11_UP}\r\n\r\n{$IFDEF COMPILER12_UP}\r\n {$DEFINE SUPPORTS_GENERICS}\r\n {$DEFINE SUPPORTS_DEPRECATED_DETAILS}\r\n {$DEFINE SUPPORTS_INT_ALIASES}\r\n {$IFNDEF CLR}\r\n {$DEFINE SUPPORTS_UNICODE}\r\n {$DEFINE SUPPORTS_UNICODE_STRING}\r\n {$ENDIF CLR}\r\n{$ENDIF COMPILER12_UP}\r\n\r\n{$IFDEF COMPILER14_UP}\r\n {$DEFINE SUPPORTS_CLASS_CTORDTORS}\r\n {$DEFINE HAS_UNIT_RTTI}\r\n {$DEFINE SUPPORTS_CAST_INTERFACE_TO_OBJ}\r\n {$DEFINE SUPPORTS_DELAYED_LOADING}\r\n{$ENDIF COMPILER14_UP}\r\n\r\n{$IFDEF COMPILER16_UP}\r\n {$DEFINE USE_64BIT_TYPES}\r\n{$ENDIF COMPILER16_UP}\r\n\r\n{$IFDEF RTL130_UP}\r\n {$DEFINE HAS_UNIT_CONTNRS}\r\n{$ENDIF RTL130_UP}\r\n\r\n{$IFDEF RTL140_UP}\r\n {$IFDEF LINUX}\r\n {$DEFINE HAS_UNIT_LIBC}\r\n {$ENDIF LINUX}\r\n {$DEFINE HAS_UNIT_RTLCONSTS}\r\n {$DEFINE HAS_UNIT_TYPES}\r\n {$DEFINE HAS_UNIT_VARIANTS}\r\n {$DEFINE HAS_UNIT_STRUTILS}\r\n {$DEFINE HAS_UNIT_DATEUTILS}\r\n {$DEFINE XPLATFORM_RTL}\r\n{$ENDIF RTL140_UP}\r\n\r\n{$IFDEF RTL170_UP}\r\n {$DEFINE HAS_UNIT_HTTPPROD}\r\n{$ENDIF RTL170_UP}\r\n\r\n{$IFDEF RTL185_UP}\r\n {$DEFINE HAS_UNIT_GIFIMG}\r\n{$ENDIF RTL185_UP}\r\n\r\n{$IFDEF RTL200_UP}\r\n {$DEFINE HAS_UNIT_ANSISTRINGS}\r\n {$DEFINE HAS_UNIT_PNGIMAGE}\r\n {$DEFINE HAS_UNIT_CHARACTER}\r\n{$ENDIF RTL200_UP}\r\n\r\n{$IFDEF RTL220_UP}\r\n {$DEFINE SUPPORTS_UINT64}\r\n {$DEFINE HAS_UNIT_REGULAREXPRESSIONSAPI}\r\n{$ENDIF RTL220_UP}\r\n\r\n{$IFDEF RTL230_UP}\r\n {$DEFINE HAS_UNITSCOPE}\r\n {$DEFINE HAS_UNIT_SYSTEM_UITYPES}\r\n{$ENDIF RTL230_UP}\r\n\r\n{$IFDEF RTL240_UP}\r\n {$DEFINE HAS_UNIT_SYSTEM_ACTIONS}\r\n{$ENDIF RTL240_UP}\r\n\r\n{------------------------------------------------------------------------------}\r\n{ Cross-platform related defines }\r\n{------------------------------------------------------------------------------}\r\n\r\n{$IFNDEF CPUASM}\r\n {$DEFINE PUREPASCAL}\r\n{$ENDIF ~CPUASM}\r\n\r\n{$IFDEF WIN32}\r\n {$DEFINE MSWINDOWS} // predefined for D6+/BCB6+\r\n {$DEFINE Win32API}\r\n{$ENDIF}\r\n\r\n{$IFDEF DELPHILANGUAGE}\r\n {$IFDEF LINUX}\r\n {$DEFINE UNIX}\r\n {$ENDIF}\r\n\r\n {$IFNDEF CONSOLE}\r\n {$IFDEF LINUX}\r\n {$DEFINE VisualCLX}\r\n {$ENDIF}\r\n {$IFNDEF VisualCLX}\r\n {$DEFINE VCL}\r\n {$ENDIF}\r\n {$ENDIF ~CONSOLE}\r\n{$ENDIF DELPHILANGUAGE}\r\n\r\n{------------------------------------------------------------------------------}\r\n{ Compiler settings }\r\n{------------------------------------------------------------------------------}\r\n\r\n{$IFOPT A+} {$DEFINE ALIGN_ON} {$ENDIF}\r\n{$IFOPT B+} {$DEFINE BOOLEVAL_ON} {$ENDIF}\r\n{$IFDEF COMPILER2_UP}\r\n {$IFOPT C+} {$DEFINE ASSERTIONS_ON} {$ENDIF}\r\n{$ENDIF}\r\n{$IFOPT D+} {$DEFINE DEBUGINFO_ON} {$ENDIF}\r\n{$IFOPT G+} {$DEFINE IMPORTEDDATA_ON} {$ENDIF}\r\n{$IFDEF COMPILER2_UP}\r\n {$IFOPT H+} {$DEFINE LONGSTRINGS_ON} {$ENDIF}\r\n{$ENDIF}\r\n\r\n// Hints\r\n{$IFOPT I+} {$DEFINE IOCHECKS_ON} {$ENDIF}\r\n{$IFDEF COMPILER2_UP}\r\n {$IFOPT J+} {$DEFINE WRITEABLECONST_ON} {$ENDIF}\r\n{$ENDIF}\r\n{$IFOPT L+} {$DEFINE LOCALSYMBOLS} {$DEFINE LOCALSYMBOLS_ON} {$ENDIF}\r\n{$IFOPT M+} {$DEFINE TYPEINFO_ON} {$ENDIF}\r\n{$IFOPT O+} {$DEFINE OPTIMIZATION_ON} {$ENDIF}\r\n{$IFOPT P+} {$DEFINE OPENSTRINGS_ON} {$ENDIF}\r\n{$IFOPT Q+} {$DEFINE OVERFLOWCHECKS_ON} {$ENDIF}\r\n{$IFOPT R+} {$DEFINE RANGECHECKS_ON} {$ENDIF}\r\n\r\n// Real compatibility\r\n{$IFOPT T+} {$DEFINE TYPEDADDRESS_ON} {$ENDIF}\r\n{$IFOPT U+} {$DEFINE SAFEDIVIDE_ON} {$ENDIF}\r\n{$IFOPT V+} {$DEFINE VARSTRINGCHECKS_ON} {$ENDIF}\r\n{$IFOPT W+} {$DEFINE STACKFRAMES_ON} {$ENDIF}\r\n\r\n// Warnings\r\n{$IFOPT X+} {$DEFINE EXTENDEDSYNTAX_ON} {$ENDIF}\r\n\r\n// for Delphi/BCB trial versions remove the point from the line below\r\n{.$UNDEF SUPPORTS_WEAKPACKAGEUNIT}\r\n\r\n{$ENDIF ~JEDI_INC}\r\n" }, { "path": "External/Jedi/Jcl/source/include/jedi/kylix.inc", "content": "//\r\n// This is FPC-incompatible code and was excluded from jedi.inc for this reason\r\n//\r\n// Kylix 3/C++ for some reason evaluates CompilerVersion comparisons to False,\r\n// if the constant to compare with is a floating point value - weird.\r\n// The \"+\" sign prevents Kylix/Delphi from issueing a warning about comparing\r\n// signed and unsigned values.\r\n//\r\n {$IF not Declared(CompilerVersion)}\r\n {$DEFINE KYLIX1}\r\n {$DEFINE COMPILER6}\r\n {$DEFINE DELPHICOMPILER6}\r\n {$DEFINE RTL140_UP}\r\n {$ELSEIF Declared(CompilerVersion) and (CompilerVersion > +14)}\r\n {$DEFINE KYLIX2}\r\n {$DEFINE COMPILER6}\r\n {$DEFINE DELPHICOMPILER6}\r\n {$DEFINE RTL142_UP}\r\n {$ELSEIF Declared(CompilerVersion) and (CompilerVersion < +15)}\r\n {$DEFINE KYLIX3}\r\n {$DEFINE COMPILER6}\r\n {$IFNDEF BCB}\r\n {$DEFINE DELPHICOMPILER6}\r\n {$ENDIF}\r\n {$DEFINE RTL145_UP}\r\n {$ELSE}\r\n Add new Kylix version\r\n {$IFEND}\r\n\r\n\r\n" }, { "path": "External/Jedi/Jcl/source/include/unixonly.inc", "content": "{$IFNDEF UNIXONLY_INC}\r\n{$DEFINE UNIXONLY_INC}\r\n\r\n{**************************************************************************************************}\r\n{ }\r\n{ The contents of this file are subject to the Mozilla Public License Version 1.1 (the \"License\");}\r\n{ you may not use this file except in compliance with the License. You may obtain a copy of the }\r\n{ License at http://www.mozilla.org/MPL/ }\r\n{ }\r\n{ Software distributed under the License is distributed on an \"AS IS\" basis, WITHOUT WARRANTY OF }\r\n{ ANY KIND, either express or implied. See the License for the specific language governing rights }\r\n{ and limitations under the License. }\r\n{ }\r\n{ The Original Code is: unixonly.inc, released on 2004-06-21. }\r\n{ }\r\n{ You may retrieve the latest version of this file at the JCL home page, }\r\n{ located at http://jcl.sourceforge.net/ }\r\n{ }\r\n{**************************************************************************************************}\r\n{ }\r\n{ Last modified: $Date:: 2008-08-16 13:55:02 +0200 (sam. 16 août 2008) $ }\r\n{ Revision: $Rev:: 2423 $ }\r\n{ Author: $Author:: outchy $ }\r\n{ }\r\n{**************************************************************************************************}\r\n\r\n{$IFNDEF JEDI_INC}\r\nALERT_jedi_inc_missing\r\n// This inc file depends on jedi.inc which has to\r\n// be included first (usually indirectly through\r\n// the inclusion of jcl.inc).\r\n{$ENDIF ~JEDI_INC}\r\n\r\n// Suppress platform warnings which are irrelevant\r\n// because the including unit can only be compiled\r\n// for Unix platforms anyway.\r\n\r\n{$WARN UNIT_PLATFORM OFF}\r\n{$WARN SYMBOL_PLATFORM OFF}\r\n\r\n// Cause a compilation error for non-Unix platforms.\r\n\r\n{$IFNDEF UNIX}\r\n {$IFDEF SUPPORTS_COMPILETIME_MESSAGES}\r\n {$MESSAGE FATAL 'This unit is only supported on Unix!'}\r\n {$ELSE}\r\n 'This unit is only supported on Unix!'\r\n {$ENDIF SUPPORTS_COMPILETIME_MESSAGES}\r\n{$ENDIF ~UNIX}\r\n\r\n{$ENDIF ~UNIXONLY_INC}\r\n" }, { "path": "External/Jedi/Jcl/source/include/windowsonly.inc", "content": "{$IFNDEF WINDOWSONLY_INC}\r\n{$DEFINE WINDOWSONLY_INC}\r\n\r\n{**************************************************************************************************}\r\n{ }\r\n{ The contents of this file are subject to the Mozilla Public License Version 1.1 (the \"License\");}\r\n{ you may not use this file except in compliance with the License. You may obtain a copy of the }\r\n{ License at http://www.mozilla.org/MPL/ }\r\n{ }\r\n{ Software distributed under the License is distributed on an \"AS IS\" basis, WITHOUT WARRANTY OF }\r\n{ ANY KIND, either express or implied. See the License for the specific language governing rights }\r\n{ and limitations under the License. }\r\n{ }\r\n{ The Original Code is: windowsonly.inc, released on 2002-07-04. }\r\n{ }\r\n{ You may retrieve the latest version of this file at the JCL home page, }\r\n{ located at http://jcl.sourceforge.net/ }\r\n{ }\r\n{**************************************************************************************************}\r\n{ }\r\n{ Last modified: $Date:: 2008-08-16 13:55:02 +0200 (sam. 16 août 2008) $ }\r\n{ Revision: $Rev:: 2423 $ }\r\n{ Author: $Author:: outchy $ }\r\n{ }\r\n{**************************************************************************************************}\r\n\r\n{$IFNDEF JEDI_INC}\r\nALERT_jedi_inc_missing\r\n// This inc file depends on jedi.inc which has to\r\n// be included first (usually indirectly through\r\n// the inclusion of jcl.inc).\r\n{$ENDIF ~JEDI_INC}\r\n\r\n// Suppress platform warnings which are irrelevant\r\n// because the including unit can only be compiled\r\n// for the Windows platform anyway.\r\n\r\n{$IFDEF SUPPORTS_PLATFORM_WARNINGS}\r\n {$WARN UNIT_PLATFORM OFF}\r\n {$WARN SYMBOL_PLATFORM OFF}\r\n{$ENDIF SUPPORTS_PLATFORM_WARNINGS}\r\n\r\n// Cause a compilation error for any platform except Windows.\r\n\r\n{$IFNDEF MSWINDOWS}\r\n {$IFDEF SUPPORTS_COMPILETIME_MESSAGES}\r\n {$MESSAGE FATAL 'This unit is only supported on Windows!'}\r\n {$ELSE}\r\n 'This unit is only supported on Windows!'\r\n {$ENDIF SUPPORTS_COMPILETIME_MESSAGES}\r\n{$ENDIF ~MSWINDOWS}\r\n\r\n{$ENDIF ~WINDOWSONLY_INC}\r\n\r\n" }, { "path": "External/Jedi/Jcl/source/windows/Hardlinks.pas", "content": "{**************************************************************************************************}\r\n{ WARNING: JEDI preprocessor generated unit. Do not edit. }\r\n{**************************************************************************************************}\r\n\r\n{**************************************************************************************************}\r\n{ }\r\n{ Project JEDI Code Library (JCL) }\r\n{ }\r\n{ The contents of this file are subject to the Mozilla Public License Version 1.1 (the \"License\"); }\r\n{ you may not use this file except in compliance with the License. You may obtain a copy of the }\r\n{ License at http://www.mozilla.org/MPL/ }\r\n{ }\r\n{ Software distributed under the License is distributed on an \"AS IS\" basis, WITHOUT WARRANTY OF }\r\n{ ANY KIND, either express or implied. See the License for the specific language governing rights }\r\n{ and limitations under the License. }\r\n{ }\r\n{ The Initial Developer of the Original Code is Oliver Schneider (Assarbad att gmx dott info). }\r\n{ Portions created by Oliver Schneider are Copyright (C) 1995 - 2004 Oliver Schneider. }\r\n{ All rights reserved. }\r\n{ }\r\n{ Obtained through: }\r\n{ Joint Endeavour of Delphi Innovators (Project JEDI) }\r\n{ }\r\n{ You may retrieve the latest version of the original file at the Original Developer's homepage, }\r\n{ located at [http://assarbad.net]. Note that the original file can be used with an arbitrary OSI- }\r\n{ approved license as long as you follow the additional terms given in the original file. }\r\n{ Additionally a C/C++ (MS VC++) version is available under the same terms. }\r\n{ }\r\n{ Contributor(s): }\r\n{ Oliver Schneider (assarbad) }\r\n{ Robert Marquardt (marquardt) }\r\n{ Robert Rossmair (rrossmair) }\r\n{ }\r\n{**************************************************************************************************}\r\n{ }\r\n{ Windows NT 4.0 compatible implementation of the CreateHardLink() API introduced in Windows }\r\n{ 2000. }\r\n{ }\r\n{**************************************************************************************************}\r\n{ }\r\n{ Last modified: $Date:: 2012-02-03 19:14:26 +0100 (ven. 03 févr. 2012) $ }\r\n{ Revision: $Rev:: 3711 $ }\r\n{ Author: $Author:: outchy $ }\r\n{ }\r\n{**************************************************************************************************}\r\n\r\n\r\nunit Hardlinks;\r\n\r\n{$I jcl.inc}\r\n{$I windowsonly.inc}\r\n\r\n// ALL enabled by default for Project JEDI\r\n{$DEFINE STDCALL} // Make functions STDCALL always\r\n{$DEFINE RTDL} // Use runtime dynamic linking\r\n{$DEFINE PREFERAPI} // Prefer the \"real\" Windows API on systems on which it exists\r\n // If this is defined STDCALL is automatically needed and defined!\r\n\r\n{$ALIGN ON}\r\n{$MINENUMSIZE 4}\r\n\r\ninterface\r\n\r\n//DOM-IGNORE-BEGIN\r\n\r\n(*\r\n All possible combinations of the above DEFINEs have been tested and work fine.\r\n\r\n # | A B C\r\n ---|---------\r\n 1 | 0 0 0 A = STDCALL\r\n 2 | 0 0 X B = RTDL\r\n 3 | X 0 0 C = PREFERAPI\r\n 4 | X 0 X\r\n 5 | X X 0\r\n 6 | X X X\r\n*)\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n {$IFDEF HAS_UNITSCOPE}\r\n Winapi.Windows;\r\n {$ELSE ~HAS_UNITSCOPE}\r\n Windows;\r\n {$ENDIF ~HAS_UNITSCOPE}\r\n\r\n\r\n{$EXTERNALSYM CreateHardLinkW}\r\n{$EXTERNALSYM CreateHardLinkA}\r\n\r\n\r\n// Well, we did not decide yet ;) - bind to either address, depending on whether\r\n// the API could be found.\r\ntype\r\n TFNCreateHardLinkW = function(szLinkName, szLinkTarget: PWideChar; lpSecurityAttributes: PSecurityAttributes): BOOL; stdcall; \r\n TFNCreateHardLinkA = function(szLinkName, szLinkTarget: PAnsiChar; lpSecurityAttributes: PSecurityAttributes): BOOL; stdcall; \r\nvar\r\n CreateHardLinkW: TFNCreateHardLinkW = nil;\r\n CreateHardLinkA: TFNCreateHardLinkA = nil;\r\n\r\nvar\r\n hNtDll: THandle = 0; // For runtime dynamic linking\r\n bRtdlFunctionsLoaded: Boolean = False; // To show wether the RTDL functions had been loaded\r\n\r\n//DOM-IGNORE-END\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jcl.svn.sourceforge.net/svnroot/jcl/tags/JCL-2.4-Build4571/jcl/source/windows/Hardlinks.pas $';\r\n Revision: '$Revision: 3711 $';\r\n Date: '$Date: 2012-02-03 19:14:26 +0100 (ven. 03 févr. 2012) $';\r\n LogPath: 'JCL\\source\\windows';\r\n Extra: '';\r\n Data: nil\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nconst\r\n szNtDll = 'NTDLL.DLL'; // Import native APIs from this DLL\r\n szKernel32 = 'KERNEL32.DLL';\r\n szCreateHardLinkA = 'CreateHardLinkA';\r\n szCreateHardLinkW = 'CreateHardLinkW';\r\n\r\n(******************************************************************************\r\n\r\n Note, I only include function prototypes and constants here which are needed!\r\n For other prototypes or constants check out the related books of\r\n - Gary Nebbett\r\n - Sven B. Schreiber\r\n - Rajeev Nagar\r\n\r\n Note, one my homepage I have also some Native APIs listed in Delphi translated\r\n form. Not all of them might be translated correctly with respect to the fact\r\n whether or not they are pointer and whether or not the alignment of variables\r\n or types is always correct. This might be reviewed by me somewhen in future.\r\n\r\n ******************************************************************************)\r\n\r\n// =================================================================\r\n// Type definitions\r\n// =================================================================\r\ntype\r\n NTSTATUS = Longint;\r\n\r\ntype\r\n UNICODE_STRING = record\r\n Length: WORD;\r\n MaximumLength: WORD;\r\n Buffer: PWideChar;\r\n end;\r\n PUNICODE_STRING = ^UNICODE_STRING;\r\n\r\n// type\r\n // ANSI_STRING = record\r\n // Length: WORD;\r\n // MaximumLength: WORD;\r\n // Buffer: PAnsiChar;\r\n // end;\r\n // PANSI_STRING = ^ANSI_STRING;\r\n\r\ntype\r\n OBJECT_ATTRIBUTES = record\r\n Length: ULONG;\r\n RootDirectory: THandle;\r\n ObjectName: PUNICODE_STRING;\r\n Attributes: ULONG;\r\n SecurityDescriptor: Pointer; // Points to type SECURITY_DESCRIPTOR\r\n SecurityQualityOfService: Pointer; // Points to type SECURITY_QUALITY_OF_SERVICE\r\n end;\r\n // POBJECT_ATTRIBUTES = ^OBJECT_ATTRIBUTES;\r\n\r\ntype\r\n IO_STATUS_BLOCK = record\r\n case integer of\r\n 0:\r\n (Status: NTSTATUS);\r\n 1:\r\n (Pointer: Pointer;\r\n Information: ULONG); // 'Information' does not belong to the union!\r\n end;\r\n // PIO_STATUS_BLOCK = ^IO_STATUS_BLOCK;\r\n\r\ntype\r\n _FILE_LINK_RENAME_INFORMATION = record // File Information Classes 10 and 11\r\n ReplaceIfExists: BOOL;\r\n RootDirectory: THandle;\r\n FileNameLength: ULONG;\r\n FileName: array[0..0] of WideChar;\r\n end;\r\n FILE_LINK_INFORMATION = _FILE_LINK_RENAME_INFORMATION;\r\n PFILE_LINK_INFORMATION = ^FILE_LINK_INFORMATION;\r\n // FILE_RENAME_INFORMATION = _FILE_LINK_RENAME_INFORMATION;\r\n // PFILE_RENAME_INFORMATION = ^FILE_RENAME_INFORMATION;\r\n\r\n// =================================================================\r\n// Constants\r\n// =================================================================\r\nconst\r\n FileLinkInformation = 11;\r\n FILE_SYNCHRONOUS_IO_NONALERT = $00000020; // All operations on the file are\r\n // performed synchronously. Waits\r\n // in the system to synchronize I/O\r\n // queuing and completion are not\r\n // subject to alerts. This flag\r\n // also causes the I/O system to\r\n // maintain the file position context.\r\n // If this flag is set, the\r\n // DesiredAccess SYNCHRONIZE flag also\r\n // must be set.\r\n FILE_OPEN_FOR_BACKUP_INTENT = $00004000; // The file is being opened for backup\r\n // intent, hence, the system should\r\n // check for certain access rights\r\n // and grant the caller the appropriate\r\n // accesses to the file before checking\r\n // the input DesiredAccess against the\r\n // file's security descriptor.\r\n FILE_OPEN_REPARSE_POINT = $00200000;\r\n DELETE = $00010000;\r\n SYNCHRONIZE = $00100000;\r\n STATUS_SUCCESS = NTSTATUS(0);\r\n OBJ_CASE_INSENSITIVE = $00000040;\r\n SYMBOLIC_LINK_QUERY = $00000001;\r\n\r\n // Should be defined, but isn't\r\n HEAP_ZERO_MEMORY = $00000008;\r\n\r\n // Related constant(s) for RtlDetermineDosPathNameType_U()\r\n // INVALID_PATH = 0;\r\n UNC_PATH = 1;\r\n // ABSOLUTE_DRIVE_PATH = 2;\r\n // RELATIVE_DRIVE_PATH = 3;\r\n // ABSOLUTE_PATH = 4;\r\n // RELATIVE_PATH = 5;\r\n // DEVICE_PATH = 6;\r\n // UNC_DOT_PATH = 7;\r\n\r\n// =================================================================\r\n// Function prototypes\r\n// =================================================================\r\n\r\n\r\n\r\ntype\r\n TRtlCreateUnicodeStringFromAsciiz = function(var destination: UNICODE_STRING;\r\n source: PAnsiChar): Boolean; stdcall;\r\n\r\n TZwClose = function(Handle: THandle): NTSTATUS; stdcall;\r\n\r\n TZwSetInformationFile = function(FileHandle: THandle;\r\n var IoStatusBlock: IO_STATUS_BLOCK; FileInformation: Pointer;\r\n FileInformationLength: ULONG; FileInformationClass: DWORD): NTSTATUS; stdcall;\r\n\r\n TRtlPrefixUnicodeString = function(const usPrefix: UNICODE_STRING;\r\n const usContainingString: UNICODE_STRING; ignore_case: Boolean): Boolean; stdcall;\r\n\r\n TZwOpenSymbolicLinkObject = function(var LinkHandle: THandle;\r\n DesiredAccess: DWORD; const ObjectAttributes: OBJECT_ATTRIBUTES): NTSTATUS; stdcall;\r\n\r\n TZwQuerySymbolicLinkObject = function(LinkHandle: THandle;\r\n var LinkTarget: UNICODE_STRING; ReturnedLength: PULONG): NTSTATUS; stdcall;\r\n\r\n TZwOpenFile = function(var FileHandle: THandle; DesiredAccess: DWORD;\r\n const ObjectAttributes: OBJECT_ATTRIBUTES; var IoStatusBlock: IO_STATUS_BLOCK;\r\n ShareAccess: ULONG; OpenOptions: ULONG): NTSTATUS; stdcall;\r\n\r\n TGetProcessHeap = function: Pointer; stdcall;\r\n\r\n TRtlAllocateHeap = function(HeapHandle: Pointer; Flags, Size: ULONG): Pointer; stdcall;\r\n\r\n TRtlFreeHeap = function(HeapHandle: Pointer; Flags: ULONG;\r\n MemoryPointer: Pointer): Boolean; stdcall;\r\n\r\n TRtlDosPathNameToNtPathName_U = function(DosName: PWideChar;\r\n var NtName: UNICODE_STRING; DosFilePath: PPWideChar;\r\n NtFilePath: PUNICODE_STRING): Boolean; stdcall;\r\n\r\n TRtlInitUnicodeString = function(var DestinationString: UNICODE_STRING;\r\n const SourceString: PWideChar): NTSTATUS; stdcall;\r\n\r\n TRtlDetermineDosPathNameType_U = function(wcsPathNameType: PWideChar): DWORD; stdcall;\r\n\r\n TRtlNtStatusToDosError = function(status: NTSTATUS): ULONG; stdcall;\r\n\r\n// Declare all the _global_ function pointers for RTDL\r\nvar\r\n RtlCreateUnicodeStringFromAsciiz: TRtlCreateUnicodeStringFromAsciiz = nil;\r\n ZwClose: TZwClose = nil;\r\n ZwSetInformationFile: TZwSetInformationFile = nil;\r\n RtlPrefixUnicodeString: TRtlPrefixUnicodeString = nil;\r\n ZwOpenSymbolicLinkObject: TZwOpenSymbolicLinkObject = nil;\r\n ZwQuerySymbolicLinkObject: TZwQuerySymbolicLinkObject = nil;\r\n ZwOpenFile: TZwOpenFile = nil;\r\n GetProcessHeap: TGetProcessHeap = nil;\r\n RtlAllocateHeap: TRtlAllocateHeap = nil;\r\n RtlFreeHeap: TRtlFreeHeap = nil;\r\n RtlDosPathNameToNtPathName_U: TRtlDosPathNameToNtPathName_U = nil;\r\n RtlInitUnicodeString: TRtlInitUnicodeString = nil;\r\n RtlDetermineDosPathNameType_U: TRtlDetermineDosPathNameType_U = nil;\r\n RtlNtStatusToDosError: TRtlNtStatusToDosError = nil;\r\n\r\n(******************************************************************************\r\n\r\n Syntax:\r\n -------\r\n C-Prototype! (if STDCALL enabled)\r\n\r\n BOOL WINAPI CreateHardLink(\r\n LPCTSTR lpFileName,\r\n LPCTSTR lpExistingFileName,\r\n LPSECURITY_ATTRIBUTES lpSecurityAttributes // Reserved; Must be NULL!\r\n\r\n Compatibility:\r\n --------------\r\n The function can only work on file systems that support hardlinks through the\r\n underlying FS driver layer. Currently this only includes NTFS on the NT\r\n platform (as far as I know).\r\n The function works fine on Windows NT4/2000/XP and is considered to work on\r\n future Operating System versions derived from NT (including Windows 2003).\r\n\r\n Remarks:\r\n --------\r\n This function tries to resemble the original CreateHardLinkW() call from\r\n Windows 2000/XP/2003 Kernel32.DLL as close as possible. This is why many\r\n functions used are NT Native API, whereas one could use Delphi or Win32 API\r\n functions (e.g. memory management). BUT I included much more SEH code and\r\n omitted extra code to free buffers and close handles. This all is done during\r\n the FINALLY block (so there are no memory leaks anyway ;).\r\n\r\n Note, that neither Microsoft's code nor mine ignore the Security Descriptor\r\n from the SECURITY_ATTRIBUTES structure. In both cases the security descriptor\r\n is passed on to ZwOpenFile()!\r\n\r\n The limit of 1023 hardlinks to one file is probably related to the system or\r\n NTFS respectively. At least I saw no special hint, why there would be such a\r\n limit - the original CreateHardLink() does not check the number of links!\r\n Thus I consider the limit being the same for the original and my rewrite.\r\n\r\n For the ANSI version of this function see below ...\r\n\r\n Remarks from the Platform SDK:\r\n -------------------------------\r\n Any directory entry for a file, whether created with CreateFile or\r\n CreateHardLink, is a hard link to the associated file. Additional hard links,\r\n created with the CreateHardLink function, allow you to have multiple directory\r\n entries for a file, that is, multiple hard links to the same file. These may\r\n be different names in the same directory, or they may be the same (or\r\n different) names in different directories. However, all hard links to a file\r\n must be on the same volume.\r\n Because hard links are just directory entries for a file, whenever an\r\n application modifies a file through any hard link, all applications using any\r\n other hard link to the file see the changes. Also, all of the directory\r\n entries are updated if the file changes. For example, if the file's size\r\n changes, all of the hard links to the file will show the new size.\r\n The security descriptor belongs to the file to which the hard link points.\r\n The link itself, being merely a directory entry, has no security descriptor.\r\n Thus, if you change the security descriptor of any hard link, you're actually\r\n changing the underlying file's security descriptor. All hard links that point\r\n to the file will thus allow the newly specified access. There is no way to\r\n give a file different security descriptors on a per-hard-link basis.\r\n This function does not modify the security descriptor of the file to be linked\r\n to, even if security descriptor information is passed in the\r\n lpSecurityAttributes parameter.\r\n Use DeleteFile to delete hard links. You can delete them in any order\r\n regardless of the order in which they were created.\r\n Flags, attributes, access, and sharing as specified in CreateFile operate on\r\n a per-file basis. That is, if you open a file with no sharing allowed, another\r\n application cannot share the file by creating a new hard link to the file.\r\n\r\n CreateHardLink does not work over the network redirector.\r\n\r\n Note that when you create a hard link on NTFS, the file attribute information\r\n in the directory entry is refreshed only when the file is opened or when\r\n GetFileInformationByHandle is called with the handle of the file of interest.\r\n\r\n ******************************************************************************)\r\nfunction\r\n\r\n MyCreateHardLinkW // ... otherwise this one\r\n (szLinkName, szLinkTarget: PWideChar; lpSecurityAttributes: PSecurityAttributes): BOOL;\r\nconst\r\n// Mask for any DOS style drive path in object manager notation\r\n wcsC_NtName: PWideChar = '\\??\\C:';\r\n// Prefix of a mapped path's symbolic link\r\n wcsLanMan: PWideChar = '\\Device\\LanmanRedirector\\';\r\n// Size required to hold a number of wide characters to compare drive notation\r\n cbC_NtName = $10; // 16 bytes\r\n// Access mask to use for opening - just two bits\r\n dwDesiredAccessHL = DELETE or SYNCHRONIZE;\r\n// OpenOptions for opening of the link target\r\n// The flag FILE_OPEN_REPARSE_POINT has been found by comparison. Probably it carries\r\n// some information wether the file is on the same volume?!\r\n dwOpenOptionsHL = FILE_SYNCHRONOUS_IO_NONALERT or FILE_OPEN_FOR_BACKUP_INTENT or FILE_OPEN_REPARSE_POINT;\r\n// ShareAccess flags\r\n dwShareAccessHL = FILE_SHARE_READ or FILE_SHARE_WRITE or FILE_SHARE_DELETE;\r\nvar\r\n usNtName_LinkName, usNtName_LinkTarget: UNICODE_STRING;\r\n usCheckDrive, usSymLinkDrive, usLanMan: UNICODE_STRING;\r\n wcsNtName_LinkTarget, wcsFilePart_LinkTarget: PWideChar;\r\n oaMisc: OBJECT_ATTRIBUTES;\r\n IOStats: IO_STATUS_BLOCK;\r\n hHeap: Pointer;\r\n NeededSize: DWORD;\r\n Status: NTSTATUS;\r\n hLinkTarget, hDrive: THandle;\r\n lpFileLinkInfo: PFILE_LINK_INFORMATION;\r\nbegin\r\n Result := False;\r\n if not bRtdlFunctionsLoaded then\r\n Exit;\r\n // Get process' heap\r\n hHeap := GetProcessHeap;\r\n {-------------------------------------------------------------\r\n Preliminary parameter checks which do Exit with error code set\r\n --------------------------------------------------------------}\r\n // If any is not assigned ...\r\n if (szLinkName = nil) or (szLinkTarget = nil) then\r\n begin\r\n SetLastError(ERROR_INVALID_PARAMETER);\r\n Exit;\r\n end;\r\n // Determine DOS path type for both link name and target\r\n if (RtlDetermineDosPathNameType_U(szLinkName) = UNC_PATH) or\r\n (RtlDetermineDosPathNameType_U(szLinkTarget) = UNC_PATH) then\r\n begin\r\n SetLastError(ERROR_INVALID_NAME);\r\n Exit;\r\n end;\r\n // Convert the link target into a UNICODE_STRING\r\n usNtName_LinkTarget.Length := 0;\r\n if not RtlDosPathNameToNtPathName_U(szLinkTarget, usNtName_LinkTarget, nil, nil) then\r\n begin\r\n SetLastError(ERROR_PATH_NOT_FOUND);\r\n Exit;\r\n end;\r\n {------------------------\r\n Actual main functionality\r\n -------------------------}\r\n // Initialise the length members\r\n RtlInitUnicodeString(usNtName_LinkTarget, usNtName_LinkTarget.Buffer);\r\n // Get needed buffer size (in TCHARs)\r\n NeededSize := GetFullPathNameW(szLinkTarget, 0, nil, PWideChar(nil^));\r\n if NeededSize <> 0 then\r\n begin\r\n // Calculate needed size (in TCHARs)\r\n NeededSize := NeededSize + 1; // times SizeOf(WideChar)\r\n // Freed in FINALLY\r\n wcsNtName_LinkTarget := RtlAllocateHeap(hHeap, HEAP_ZERO_MEMORY, NeededSize * SizeOf(WideChar));\r\n // If successfully allocated buffer ...\r\n if wcsNtName_LinkTarget <> nil then\r\n try\r\n {----------------------------------------------------\r\n Preparation of the checking for mapped network drives\r\n -----------------------------------------------------}\r\n // Get the full unicode path name\r\n wcsFilePart_LinkTarget := nil;\r\n if GetFullPathNameW(szLinkTarget, NeededSize, wcsNtName_LinkTarget, wcsFilePart_LinkTarget) <> 0 then\r\n begin\r\n // Allocate memory to check the drive object\r\n usCheckDrive.Buffer := RtlAllocateHeap(hHeap, HEAP_ZERO_MEMORY, cbC_NtName);\r\n // On success ...\r\n if usCheckDrive.Buffer <> nil then\r\n try\r\n // Copy to buffer and set length members\r\n lstrcpynW(usCheckDrive.Buffer, wcsC_NtName, lstrlenW(wcsC_NtName) + 1);\r\n RtlInitUnicodeString(usCheckDrive, usCheckDrive.Buffer);\r\n // Replace drive letter by the drive letter we want\r\n usCheckDrive.Buffer[4] := wcsNtName_LinkTarget[0];\r\n // Init OBJECT_ATTRIBUTES\r\n oaMisc.Length := SizeOf(oaMisc);\r\n oaMisc.RootDirectory := 0;\r\n oaMisc.ObjectName := @usCheckDrive;\r\n oaMisc.Attributes := OBJ_CASE_INSENSITIVE;\r\n oaMisc.SecurityDescriptor := nil;\r\n oaMisc.SecurityQualityOfService := nil;\r\n {--------------------------------------------\r\n Checking for (illegal!) mapped network drives\r\n ---------------------------------------------}\r\n // Open symbolic link object\r\n hDrive := 0;\r\n if ZwOpenSymbolicLinkObject(hDrive, SYMBOLIC_LINK_QUERY, oaMisc) = STATUS_SUCCESS then\r\n try\r\n usSymLinkDrive.Buffer := RtlAllocateHeap(hHeap, HEAP_ZERO_MEMORY, MAX_PATH * SizeOf(WideChar));\r\n if usSymLinkDrive.Buffer <> nil then\r\n try\r\n // Query the path the symbolic link points to ...\r\n ZwQuerySymbolicLinkObject(hDrive, usSymLinkDrive, nil);\r\n // Initialise the length members\r\n usLanMan.Length := 0;\r\n RtlInitUnicodeString(usLanMan, wcsLanMan);\r\n // The path must not be a mapped drive ... check this!\r\n if not RtlPrefixUnicodeString(usLanMan, usSymLinkDrive, True) then\r\n begin\r\n // Initialise OBJECT_ATTRIBUTES\r\n oaMisc.Length := SizeOf(oaMisc);\r\n oaMisc.RootDirectory := 0;\r\n oaMisc.ObjectName := @usNtName_LinkTarget;\r\n oaMisc.Attributes := OBJ_CASE_INSENSITIVE;\r\n // Set security descriptor in OBJECT_ATTRIBUTES if they were given\r\n if lpSecurityAttributes <> nil then\r\n oaMisc.SecurityDescriptor := lpSecurityAttributes^.lpSecurityDescriptor\r\n else\r\n oaMisc.SecurityDescriptor := nil;\r\n oaMisc.SecurityQualityOfService := nil;\r\n {----------------------\r\n Opening the target file\r\n -----------------------}\r\n IOStats.Status := 0;\r\n hLinkTarget := 0;\r\n Status := ZwOpenFile(hLinkTarget, dwDesiredAccessHL, oaMisc,\r\n IOStats, dwShareAccessHL, dwOpenOptionsHL);\r\n if Status = STATUS_SUCCESS then\r\n try\r\n // Wow ... target opened ... let's try to\r\n usNtName_LinkName.Length := 0;\r\n if RtlDosPathNameToNtPathName_U(szLinkName, usNtName_LinkName, nil, nil) then\r\n try\r\n // Initialise the length members\r\n RtlInitUnicodeString(usNtName_LinkName, usNtName_LinkName.Buffer);\r\n // Now almost everything is done to create a link!\r\n NeededSize := usNtName_LinkName.Length +\r\n SizeOf(FILE_LINK_INFORMATION) + SizeOf(WideChar);\r\n lpFileLinkInfo := RtlAllocateHeap(hHeap, HEAP_ZERO_MEMORY, NeededSize);\r\n if lpFileLinkInfo <> nil then\r\n try\r\n lpFileLinkInfo^.ReplaceIfExists := False;\r\n lpFileLinkInfo^.RootDirectory := 0;\r\n lpFileLinkInfo^.FileNameLength := usNtName_LinkName.Length;\r\n lstrcpynW(lpFileLinkInfo.FileName, usNtName_LinkName.Buffer,\r\n usNtName_LinkName.Length);\r\n {----------------------------------------------------\r\n Final creation of the link - \"center\" of the function\r\n -----------------------------------------------------}\r\n // Hard-link the file as intended\r\n Status := ZwSetInformationFile(hLinkTarget, IOStats,\r\n lpFileLinkInfo, NeededSize, FileLinkInformation);\r\n // On success return TRUE\r\n Result := Status >= 0;\r\n finally\r\n // Free the buffer\r\n RtlFreeHeap(hHeap, 0, lpFileLinkInfo);\r\n // Set last error code\r\n SetLastError(RtlNtStatusToDosError(Status));\r\n end\r\n else // if lpFileLinkInfo <> nil then\r\n SetLastError(ERROR_NOT_ENOUGH_MEMORY);\r\n finally\r\n RtlFreeHeap(hHeap, 0, usNtName_LinkName.Buffer);\r\n end\r\n else // if RtlDosPathNameToNtPathName_U(szLinkName, usNtName_LinkName...\r\n SetLastError(ERROR_INVALID_NAME);\r\n finally\r\n ZwClose(hLinkTarget);\r\n end\r\n else // if Status = STATUS_SUCCESS then\r\n SetLastError(RtlNtStatusToDosError(Status));\r\n end\r\n else // if not RtlPrefixUnicodeString(usLanMan, usSymLinkDrive, True) then\r\n SetLastError(ERROR_INVALID_NAME);\r\n finally\r\n RtlFreeHeap(hHeap, 0, usSymLinkDrive.Buffer);\r\n end\r\n else // if usSymLinkDrive.Buffer <> nil then\r\n SetLastError(ERROR_NOT_ENOUGH_MEMORY);\r\n finally\r\n ZwClose(hDrive);\r\n end;\r\n finally\r\n RtlFreeHeap(hHeap, 0, usCheckDrive.Buffer);\r\n end\r\n else // if usCheckDrive.Buffer <> nil then\r\n SetLastError(ERROR_NOT_ENOUGH_MEMORY);\r\n end\r\n else // if GetFullPathNameW(szLinkTarget, NeededSize, wcsNtName_LinkTarget...\r\n SetLastError(ERROR_INVALID_NAME);\r\n finally\r\n RtlFreeHeap(hHeap, 0, wcsNtName_LinkTarget);\r\n end\r\n else // if wcsNtName_LinkTarget <> nil then\r\n SetLastError(ERROR_NOT_ENOUGH_MEMORY);\r\n end\r\n else // if NeededSize <> 0 then\r\n SetLastError(ERROR_INVALID_NAME);\r\n // Finally free the buffer\r\n RtlFreeHeap(hHeap, 0, usNtName_LinkTarget.Buffer);\r\nend;\r\n\r\n(******************************************************************************\r\n Hint:\r\n -----\r\n For all closer information see the CreateHardLinkW function above.\r\n\r\n Specific to the ANSI-version:\r\n -----------------------------\r\n The ANSI-Version can be used as if it was used on Windows 2000. This holds\r\n for all supported systems for now.\r\n\r\n ******************************************************************************)\r\n\r\nfunction\r\n\r\n MyCreateHardLinkA // ... otherwise this one\r\n (szLinkName, szLinkTarget: PAnsiChar; lpSecurityAttributes: PSecurityAttributes): BOOL;\r\nvar\r\n usLinkName: UNICODE_STRING;\r\n usLinkTarget: UNICODE_STRING;\r\n hHeap: Pointer;\r\nbegin\r\n Result := False;\r\n if not bRtdlFunctionsLoaded then\r\n Exit;\r\n // Get the process' heap\r\n hHeap := GetProcessHeap;\r\n // Create and allocate a UNICODE_STRING from the zero-terminated parameters\r\n usLinkName.Length := 0;\r\n if RtlCreateUnicodeStringFromAsciiz(usLinkName, szLinkName) then\r\n try\r\n usLinkTarget.Length := 0;\r\n if RtlCreateUnicodeStringFromAsciiz(usLinkTarget, szLinkTarget) then\r\n try\r\n // Call the Unicode version\r\n Result := CreateHardLinkW(usLinkName.Buffer, usLinkTarget.Buffer, lpSecurityAttributes);\r\n finally\r\n // free the allocated buffer\r\n RtlFreeHeap(hHeap, 0, usLinkTarget.Buffer);\r\n end;\r\n finally\r\n // free the allocate buffer\r\n RtlFreeHeap(hHeap, 0, usLinkName.Buffer);\r\n end;\r\nend;\r\n\r\nconst\r\n// Names of the functions to import\r\n szRtlCreateUnicodeStringFromAsciiz = 'RtlCreateUnicodeStringFromAsciiz';\r\n szZwClose = 'ZwClose';\r\n szZwSetInformationFile = 'ZwSetInformationFile';\r\n szRtlPrefixUnicodeString = 'RtlPrefixUnicodeString';\r\n szZwOpenSymbolicLinkObject = 'ZwOpenSymbolicLinkObject';\r\n szZwQuerySymbolicLinkObject = 'ZwQuerySymbolicLinkObject';\r\n szZwOpenFile = 'ZwOpenFile';\r\n szGetProcessHeap = 'GetProcessHeap';\r\n szRtlAllocateHeap = 'RtlAllocateHeap';\r\n szRtlFreeHeap = 'RtlFreeHeap';\r\n szRtlDosPathNameToNtPathName_U = 'RtlDosPathNameToNtPathName_U';\r\n szRtlInitUnicodeString = 'RtlInitUnicodeString';\r\n szRtlDetermineDosPathNameType_U = 'RtlDetermineDosPathNameType_U';\r\n szRtlNtStatusToDosError = 'RtlNtStatusToDosError';\r\n\r\nvar\r\n hKernel32: THandle = 0;\r\n\r\ninitialization\r\n {$IFDEF UNITVERSIONING}\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n {$ENDIF UNITVERSIONING}\r\n\r\n // GetModuleHandle because this DLL is loaded into any Win32 subsystem process anyway\r\n // implicitly. And Delphi cannot create applications for other subsystems without\r\n // major changes in SysInit und System units.\r\n hKernel32 := GetModuleHandle(kernel32);\r\n // If we prefer the real Windows APIs try to get their addresses\r\n @CreateHardLinkA := GetProcAddress(hKernel32, szCreateHardLinkA);\r\n @CreateHardLinkW := GetProcAddress(hKernel32, szCreateHardLinkW);\r\n // If they could not be retrieved resort to our home-grown version\r\n if not (Assigned(@CreateHardLinkA) and Assigned(@CreateHardLinkW)) then\r\n begin\r\n\r\n // GetModuleHandle because this DLL is loaded into any Win32 subsystem process anyway\r\n // implicitly. And Delphi cannot create applications for other subsystems without\r\n // major changes in SysInit und System units.\r\n hNtDll := GetModuleHandle(szNtDll);\r\n if hNtDll <> 0 then\r\n begin\r\n // Get all the function addresses\r\n @RtlCreateUnicodeStringFromAsciiz := GetProcAddress(hNtDll, szRtlCreateUnicodeStringFromAsciiz);\r\n @ZwClose := GetProcAddress(hNtDll, szZwClose);\r\n @ZwSetInformationFile := GetProcAddress(hNtDll, szZwSetInformationFile);\r\n @RtlPrefixUnicodeString := GetProcAddress(hNtDll, szRtlPrefixUnicodeString);\r\n @ZwOpenSymbolicLinkObject := GetProcAddress(hNtDll, szZwOpenSymbolicLinkObject);\r\n @ZwQuerySymbolicLinkObject := GetProcAddress(hNtDll, szZwQuerySymbolicLinkObject);\r\n @ZwOpenFile := GetProcAddress(hNtDll, szZwOpenFile);\r\n @GetProcessHeap := GetProcAddress(hKernel32, szGetProcessHeap);\r\n @RtlAllocateHeap := GetProcAddress(hNtDll, szRtlAllocateHeap);\r\n @RtlFreeHeap := GetProcAddress(hNtDll, szRtlFreeHeap);\r\n @RtlDosPathNameToNtPathName_U := GetProcAddress(hNtDll, szRtlDosPathNameToNtPathName_U);\r\n @RtlInitUnicodeString := GetProcAddress(hNtDll, szRtlInitUnicodeString);\r\n @RtlDetermineDosPathNameType_U := GetProcAddress(hNtDll, szRtlDetermineDosPathNameType_U);\r\n @RtlNtStatusToDosError := GetProcAddress(hNtDll, szRtlNtStatusToDosError);\r\n // Check whether we could retrieve all of them\r\n bRtdlFunctionsLoaded := // Update the \"loaded\" status\r\n Assigned(@RtlCreateUnicodeStringFromAsciiz) and\r\n Assigned(@ZwClose) and\r\n Assigned(@ZwSetInformationFile) and\r\n Assigned(@RtlPrefixUnicodeString) and\r\n Assigned(@ZwOpenSymbolicLinkObject) and\r\n Assigned(@ZwQuerySymbolicLinkObject) and\r\n Assigned(@ZwOpenFile) and\r\n Assigned(@GetProcessHeap) and\r\n Assigned(@RtlAllocateHeap) and\r\n Assigned(@RtlFreeHeap) and\r\n Assigned(@RtlDosPathNameToNtPathName_U) and\r\n Assigned(@RtlInitUnicodeString) and\r\n Assigned(@RtlDetermineDosPathNameType_U) and\r\n Assigned(@RtlNtStatusToDosError);\r\n end;\r\n\r\n @CreateHardLinkA := @MyCreateHardLinkA;\r\n @CreateHardLinkW := @MyCreateHardLinkW;\r\n end; // if not (Assigned(@CreateHardLinkA) and Assigned(@CreateHardLinkW)) then ...\r\n\r\n {$IFDEF UNITVERSIONING}\r\n UnregisterUnitVersion(HInstance);\r\n {$ENDIF UNITVERSIONING}\r\n\r\n\r\n\r\nend.\r\n\r\n" }, { "path": "External/Jedi/Jcl/source/windows/JclAppInst.pas", "content": "{**************************************************************************************************}\r\n{ }\r\n{ Project JEDI Code Library (JCL) }\r\n{ }\r\n{ The contents of this file are subject to the Mozilla Public License Version 1.1 (the \"License\"); }\r\n{ you may not use this file except in compliance with the License. You may obtain a copy of the }\r\n{ License at http://www.mozilla.org/MPL/ }\r\n{ }\r\n{ Software distributed under the License is distributed on an \"AS IS\" basis, WITHOUT WARRANTY OF }\r\n{ ANY KIND, either express or implied. See the License for the specific language governing rights }\r\n{ and limitations under the License. }\r\n{ }\r\n{ The Original Code is JclAppInst.pas. }\r\n{ }\r\n{ The Initial Developer of the Original Code is Petr Vones. Portions created by Petr Vones are }\r\n{ Copyright (C) Petr Vones. All Rights Reserved. }\r\n{ }\r\n{ Contributor(s): }\r\n{ Marcel van Brakel }\r\n{ Robert Marquardt (marquardt) }\r\n{ Robert Rossmair (rrossmair) }\r\n{ Matthias Thoma (mthoma) }\r\n{ Petr Vones (pvones) }\r\n{ }\r\n{**************************************************************************************************}\r\n{ }\r\n{ This unit contains a class and support routines for controlling the number of concurrent }\r\n{ instances of your application that can exist at any time. In addition there is support for }\r\n{ simple interprocess communication between these instance including a notification mechanism. }\r\n{ }\r\n{**************************************************************************************************}\r\n{ }\r\n{ Last modified: $Date:: 2012-03-04 19:39:47 +0100 (dim. 04 mars 2012) $ }\r\n{ Revision: $Rev:: 3759 $ }\r\n{ Author: $Author:: outchy $ }\r\n{ }\r\n{**************************************************************************************************}\r\n\r\nunit JclAppInst;\r\n\r\n{$I jcl.inc}\r\n{$I windowsonly.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n {$IFDEF HAS_UNITSCOPE}\r\n Winapi.Windows, System.Classes, Winapi.Messages,\r\n {$ELSE ~HAS_UNITSCOPE}\r\n Windows, Classes, Messages,\r\n {$ENDIF ~HAS_UNITSCOPE}\r\n JclBase, JclFileUtils, JclSynch, JclWin32;\r\n\r\n// Message constants and types\r\ntype\r\n TJclAppInstDataKind = Integer;\r\n\r\nconst\r\n AI_INSTANCECREATED = $0001;\r\n AI_INSTANCEDESTROYED = $0002;\r\n AI_USERMSG = $0003;\r\n\r\n AppInstDataKindNoData = -1;\r\n AppInstCmdLineDataKind = 1;\r\n\r\n// Application instances manager class\r\ntype\r\n TJclAppInstances = class(TObject)\r\n private\r\n FCPID: DWORD;\r\n FAllMapping: TJclSwapFileMapping;\r\n FAllMappingView: TJclFileMappingView;\r\n FSessionMapping: TJclSwapFileMapping;\r\n FSessionMappingView: TJclFileMappingView;\r\n FUserMapping: TJclSwapFileMapping;\r\n FUserMappingView: TJclFileMappingView;\r\n FMessageID: DWORD;\r\n FOptex: TJclOptex;\r\n FUniqueAppID: string;\r\n function GetAllAppWnds(Index: Integer): THandle;\r\n function GetAllInstanceCount: Integer;\r\n function GetAllInstanceIndex(ProcessID: DWORD): Integer;\r\n function GetAllProcessIDs(Index: Integer): DWORD;\r\n function GetInstanceCount(MappingView: TJclFileMappingView): Integer;\r\n function GetInstanceIndex(MappingView: TJclFileMappingView; ProcessID: DWORD): Integer;\r\n function GetProcessIDs(MappingView: TJclFileMappingView; Index: Integer): DWORD;\r\n function GetSessionAppWnds(Index: Integer): THandle;\r\n function GetSessionInstanceCount: Integer;\r\n function GetSessionInstanceIndex(ProcessID: DWORD): Integer;\r\n function GetSessionProcessIDs(Index: Integer): DWORD;\r\n function GetUserAppWnds(Index: Integer): THandle;\r\n function GetUserInstanceCount: Integer;\r\n function GetUserInstanceIndex(ProcessID: DWORD): Integer;\r\n function GetUserProcessIDs(Index: Integer): DWORD;\r\n protected\r\n procedure InitData;\r\n procedure InitAllData;\r\n procedure InitSessionData;\r\n procedure InitUserData;\r\n procedure NotifyInstances(const W, L: Longint);\r\n procedure RemoveInstance(MappingView: TJclFileMappingView);\r\n procedure SecurityFree(UserInfo: PTokenUser; SID: PSID; ACL: PACL;\r\n SecurityDescriptor: PSecurityDescriptor; SecurityAttributes: PSecurityAttributes);\r\n procedure SecurityGetAllUsers(out UserInfo: PTokenUser; out SID: PSID; out ACL: PACL;\r\n out SecurityDescriptor: PSecurityDescriptor; out SecurityAttributes: PSecurityAttributes);\r\n procedure SecurityGetCurrentUser(out UserInfo: PTokenUser; out SID: PSID; out ACL: PACL;\r\n out SecurityDescriptor: PSecurityDescriptor; out SecurityAttributes: PSecurityAttributes);\r\n procedure SecurityGetCurrentUserInfo(out UserInfo: PTokenUser);\r\n procedure SecurityGetSecurityAttributes(OwnerSID, AccessSID: PSID; out ACL: PACL;\r\n out SecurityDescriptor: PSecurityDescriptor; out SecurityAttributes: PSecurityAttributes);\r\n public\r\n constructor Create;\r\n destructor Destroy; override;\r\n class function BringAppWindowToFront(const Wnd: THandle): Boolean;\r\n class function GetApplicationWnd(const ProcessID: DWORD): THandle;\r\n class procedure KillInstance;\r\n class function SetForegroundWindow98(const Wnd: THandle): Boolean;\r\n function CheckInstance(MaxInstances: Word; MaxSessionInstances: Word = 0;\r\n MaxUserInstances: Word = 0): Boolean;\r\n procedure CheckMultipleInstances(MaxInstances: Word; MaxSessionInstances: Word = 0;\r\n MaxUserInstances: Word = 0);\r\n procedure CheckSingleInstance;\r\n function SendCmdLineParams(const WindowClassName: string; const OriginatorWnd: THandle): Boolean;\r\n function SendData(const WindowClassName: string; const DataKind: TJclAppInstDataKind;\r\n Data: Pointer; const Size: Integer;\r\n OriginatorWnd: THandle): Boolean;\r\n function SendString(const WindowClassName: string; const DataKind: TJclAppInstDataKind;\r\n const S: string; OriginatorWnd: THandle): Boolean;\r\n function SendStrings(const WindowClassName: string; const DataKind: TJclAppInstDataKind;\r\n const Strings: TStrings; OriginatorWnd: THandle): Boolean;\r\n function SessionSwitchTo(Index: Integer): Boolean;\r\n function SwitchTo(Index: Integer): Boolean;\r\n function UserSwitchTo(Index: Integer): Boolean;\r\n procedure UserNotify(Param: Longint);\r\n property AppWnds[Index: Integer]: THandle read GetAllAppWnds;\r\n property InstanceIndex[ProcessID: DWORD]: Integer read GetAllInstanceIndex;\r\n property InstanceCount: Integer read GetAllInstanceCount;\r\n property MessageID: DWORD read FMessageID;\r\n property ProcessIDs[Index: Integer]: DWORD read GetAllProcessIDs;\r\n property SessionAppWnds[Index: Integer]: THandle read GetSessionAppWnds;\r\n property SessionInstanceIndex[ProcessID: DWORD]: Integer read GetSessionInstanceIndex;\r\n property SessionInstanceCount: Integer read GetSessionInstanceCount;\r\n property SessionProcessIDs[Index: Integer]: DWORD read GetSessionProcessIDs;\r\n property UserAppWnds[Index: Integer]: THandle read GetUserAppWnds;\r\n property UserInstanceIndex[ProcessID: DWORD]: Integer read GetUserInstanceIndex;\r\n property UserInstanceCount: Integer read GetUserInstanceCount;\r\n property UserProcessIDs[Index: Integer]: DWORD read GetUserProcessIDs;\r\n end;\r\n\r\nfunction JclAppInstances: TJclAppInstances; overload;\r\nfunction JclAppInstances(const UniqueAppIdGuidStr: string): TJclAppInstances; overload;\r\n\r\n// Interprocess communication routines\r\nfunction ReadMessageCheck(var Message: TMessage; const IgnoredOriginatorWnd: THandle): TJclAppInstDataKind;\r\nprocedure ReadMessageData(const Message: TMessage; var Data: Pointer; var Size: Integer);\r\nprocedure ReadMessageString(const Message: TMessage; out S: string);\r\nprocedure ReadMessageStrings(const Message: TMessage; const Strings: TStrings);\r\n\r\nfunction SendData(const Wnd, OriginatorWnd: HWND;\r\n const DataKind: TJclAppInstDataKind; const Data: Pointer; const Size: Integer): Boolean;\r\nfunction SendStrings(const Wnd, OriginatorWnd: HWND;\r\n const DataKind: TJclAppInstDataKind; const Strings: TStrings): Boolean;\r\nfunction SendCmdLineParams(const Wnd, OriginatorWnd: HWND): Boolean;\r\nfunction SendString(const Wnd, OriginatorWnd: HWND;\r\n const DataKind: TJclAppInstDataKind; const S: string): Boolean;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jcl.svn.sourceforge.net/svnroot/jcl/tags/JCL-2.4-Build4571/jcl/source/windows/JclAppInst.pas $';\r\n Revision: '$Revision: 3759 $';\r\n Date: '$Date: 2012-03-04 19:39:47 +0100 (dim. 04 mars 2012) $';\r\n LogPath: 'JCL\\source\\windows';\r\n Extra: '';\r\n Data: nil\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n {$IFDEF HAS_UNITSCOPE}\r\n System.SysUtils,\r\n {$ELSE ~HAS_UNITSCOPE}\r\n SysUtils,\r\n {$ENDIF ~HAS_UNITSCOPE}\r\n JclSecurity,\r\n JclStrings;\r\n\r\n{$IFDEF FPC} // missing declaration from unit Messages\r\ntype\r\n TWMCopyData = record\r\n Msg: UINT;\r\n From: THandle;\r\n CopyDataStruct: PCopyDataStruct;\r\n Result : LRESULT;\r\n End;\r\n{$ENDIF FPC}\r\n\r\nconst\r\n { strings to form a unique name for file mapping and optex objects }\r\n JclAIPrefix = 'Jcl';\r\n JclAIOptex = '_Otx';\r\n JclAIAllMapping = '_All';\r\n JclAISessionMapping = '_Session_';\r\n JclAIUserMapping = '_User_';\r\n\r\n { window message used for communication between instances }\r\n JclAIMessage = '_Msg';\r\n\r\n { maximum number of instance that may exist at any time }\r\n JclAIMaxInstances = 256;\r\n\r\n { name of the application window class }\r\n ClassNameOfTApplication = 'TApplication';\r\n\r\ntype\r\n { management data to keep track of application instances. this data is shared amongst all instances\r\n and must be appropriately protected from concurrent access at all time }\r\n\r\n PJclAISharedData = ^TJclAISharedData;\r\n TJclAISharedData = packed record\r\n MaxInst: Word;\r\n Count: Word;\r\n ProcessIDs: array [0..JclAIMaxInstances] of DWORD;\r\n end;\r\n\r\nvar\r\n { the single global TJclAppInstance instance }\r\n AppInstances: TJclAppInstances;\r\n ExplicitUniqueAppId: string;\r\n\r\n//=== { TJclAppInstances } ===================================================\r\n\r\nconstructor TJclAppInstances.Create;\r\nbegin\r\n inherited Create;\r\n FCPID := GetCurrentProcessId;\r\n InitData;\r\nend;\r\n\r\ndestructor TJclAppInstances.Destroy;\r\nbegin\r\n if FAllMapping <> nil then\r\n RemoveInstance(FAllMappingView);\r\n if FSessionMapping <> nil then\r\n RemoveInstance(FSessionMappingView);\r\n if FUserMapping <> nil then\r\n RemoveInstance(FUserMappingView);\r\n\r\n NotifyInstances(AI_INSTANCEDESTROYED, Integer(FCPID));\r\n\r\n FreeAndNil(FAllMapping);\r\n FreeAndNil(FSessionMapping);\r\n FreeAndNil(FUserMapping);\r\n FreeAndNil(FOptex);\r\n inherited Destroy;\r\nend;\r\n\r\nclass function TJclAppInstances.BringAppWindowToFront(const Wnd: THandle): Boolean;\r\nbegin\r\n if IsIconic(Wnd) then\r\n SendMessage(Wnd, WM_SYSCOMMAND, SC_RESTORE, 0);\r\n Result := SetForegroundWindow98(Wnd);\r\nend;\r\n\r\nfunction TJclAppInstances.CheckInstance(MaxInstances, MaxSessionInstances, MaxUserInstances: Word): Boolean;\r\nvar\r\n SharedData: PJclAISharedData;\r\n CurrentProcessId: DWORD;\r\nbegin\r\n CurrentProcessId := GetCurrentProcessId;\r\n FOptex.Enter;\r\n try\r\n // check all instances\r\n SharedData := PJclAISharedData(FAllMappingView.Memory);\r\n if SharedData^.MaxInst = 0 then\r\n SharedData^.MaxInst := MaxInstances;\r\n Result := (SharedData^.MaxInst = 0) or (SharedData^.Count < SharedData^.MaxInst);\r\n SharedData^.ProcessIDs[SharedData^.Count] := CurrentProcessId;\r\n Inc(SharedData^.Count);\r\n\r\n // check session instances\r\n SharedData := PJclAISharedData(FSessionMappingView.Memory);\r\n if SharedData^.MaxInst = 0 then\r\n SharedData^.MaxInst := MaxSessionInstances;\r\n Result := Result and ((SharedData^.MaxInst = 0) or (SharedData^.Count < SharedData^.MaxInst));\r\n SharedData^.ProcessIDs[SharedData^.Count] := CurrentProcessId;\r\n Inc(SharedData^.Count);\r\n\r\n // check user instances\r\n SharedData := PJclAISharedData(FUserMappingView.Memory);\r\n if SharedData^.MaxInst = 0 then\r\n SharedData^.MaxInst := MaxUserInstances;\r\n Result := Result and ((SharedData^.MaxInst = 0) or (SharedData^.Count < SharedData^.MaxInst));\r\n SharedData^.ProcessIDs[SharedData^.Count] := CurrentProcessId;\r\n Inc(SharedData^.Count);\r\n finally\r\n FOptex.Leave;\r\n end;\r\n if Result then\r\n NotifyInstances(AI_INSTANCECREATED, Integer(FCPID));\r\nend;\r\n\r\nprocedure TJclAppInstances.CheckMultipleInstances(MaxInstances, MaxSessionInstances, MaxUserInstances: Word);\r\nbegin\r\n if not CheckInstance(MaxInstances, MaxSessionInstances, MaxUserInstances) then\r\n begin\r\n SwitchTo(0);\r\n KillInstance;\r\n end;\r\nend;\r\n\r\nprocedure TJclAppInstances.CheckSingleInstance;\r\nbegin\r\n CheckMultipleInstances(1);\r\nend;\r\n\r\ntype\r\n PTopLevelWnd = ^TTopLevelWnd;\r\n TTopLevelWnd = record\r\n ProcessID: DWORD;\r\n Wnd: THandle;\r\n end;\r\n\r\nfunction EnumApplicationWinProc(Wnd: THandle; Param: PTopLevelWnd): BOOL; stdcall;\r\nvar\r\n PID: DWORD;\r\n C: array [0..Length(ClassNameOfTApplication) + 1] of Char;\r\nbegin\r\n GetWindowThreadProcessId(Wnd, @PID);\r\n if (PID = Param^.ProcessID) and (GetClassName(Wnd, C, Length(C)) > 0) and (C = ClassNameOfTApplication) then\r\n begin\r\n Result := False;\r\n Param^.Wnd := Wnd;\r\n end\r\n else\r\n begin\r\n Result := True;\r\n end;\r\nend;\r\n\r\nclass function TJclAppInstances.GetApplicationWnd(const ProcessID: DWORD): THandle;\r\nvar\r\n TopLevelWnd: TTopLevelWnd;\r\nbegin\r\n TopLevelWnd.ProcessID := ProcessID;\r\n TopLevelWnd.Wnd := 0;\r\n EnumWindows(@EnumApplicationWinProc, LPARAM(@TopLevelWnd));\r\n Result := TopLevelWnd.Wnd;\r\nend;\r\n\r\nfunction TJclAppInstances.GetAllAppWnds(Index: Integer): THandle;\r\nbegin\r\n Result := GetApplicationWnd(GetAllProcessIDs(Index));\r\nend;\r\n\r\nfunction TJclAppInstances.GetAllInstanceCount: Integer;\r\nbegin\r\n Result := GetInstanceCount(FAllMappingView);\r\nend;\r\n\r\nfunction TJclAppInstances.GetAllInstanceIndex(ProcessID: DWORD): Integer;\r\nbegin\r\n Result := GetInstanceIndex(FAllMappingView, ProcessID);\r\nend;\r\n\r\nfunction TJclAppInstances.GetAllProcessIDs(Index: Integer): DWORD;\r\nbegin\r\n Result := GetProcessIDs(FAllMappingView, Index);\r\nend;\r\n\r\nfunction TJclAppInstances.GetInstanceCount(MappingView: TJclFileMappingView): Integer;\r\nbegin\r\n FOptex.Enter;\r\n try\r\n Result := PJclAISharedData(MappingView.Memory)^.Count;\r\n finally\r\n FOptex.Leave;\r\n end;\r\nend;\r\n\r\nfunction TJclAppInstances.GetInstanceIndex(MappingView: TJclFileMappingView; ProcessID: DWORD): Integer;\r\nvar\r\n I: Integer;\r\n SharedData: PJclAISharedData;\r\nbegin\r\n Result := -1;\r\n FOptex.Enter;\r\n try\r\n SharedData := PJclAISharedData(MappingView.Memory);\r\n for I := 0 to SharedData^.Count - 1 do\r\n if SharedData^.ProcessIDs[I] = ProcessID then\r\n begin\r\n Result := I;\r\n Break;\r\n end;\r\n finally\r\n FOptex.Leave;\r\n end;\r\nend;\r\n\r\nfunction TJclAppInstances.GetProcessIDs(MappingView: TJclFileMappingView; Index: Integer): DWORD;\r\nvar\r\n SharedData: PJclAISharedData;\r\nbegin\r\n FOptex.Enter;\r\n try\r\n SharedData := PJclAISharedData(MappingView.Memory);\r\n if Index >= SharedData^.Count then\r\n Result := 0\r\n else\r\n Result := SharedData^.ProcessIDs[Index];\r\n finally\r\n FOptex.Leave;\r\n end;\r\nend;\r\n\r\nfunction TJclAppInstances.GetSessionAppWnds(Index: Integer): THandle;\r\nbegin\r\n Result := GetApplicationWnd(GetProcessIDs(FSessionMappingView, Index));\r\nend;\r\n\r\nfunction TJclAppInstances.GetSessionInstanceCount: Integer;\r\nbegin\r\n Result := GetInstanceCount(FSessionMappingView);\r\nend;\r\n\r\nfunction TJclAppInstances.GetSessionInstanceIndex(ProcessID: DWORD): Integer;\r\nbegin\r\n Result := GetInstanceIndex(FSessionMappingView, ProcessID);\r\nend;\r\n\r\nfunction TJclAppInstances.GetSessionProcessIDs(Index: Integer): DWORD;\r\nbegin\r\n Result := GetProcessIDs(FSessionMappingView, Index);\r\nend;\r\n\r\nfunction TJclAppInstances.GetUserAppWnds(Index: Integer): THandle;\r\nbegin\r\n Result := GetApplicationWnd(GetProcessIDs(FUserMappingView, Index));\r\nend;\r\n\r\nfunction TJclAppInstances.GetUserInstanceCount: Integer;\r\nbegin\r\n Result := GetInstanceCount(FUserMappingView);\r\nend;\r\n\r\nfunction TJclAppInstances.GetUserInstanceIndex(ProcessID: DWORD): Integer;\r\nbegin\r\n Result := GetInstanceIndex(FUserMappingView, ProcessID);\r\nend;\r\n\r\nfunction TJclAppInstances.GetUserProcessIDs(Index: Integer): DWORD;\r\nbegin\r\n Result := GetProcessIDs(FUserMappingView, Index);\r\nend;\r\n\r\nconst\r\n ACL_REVISION = 2;\r\n\r\ntype\r\n _ACE_HEADER = record\r\n AceType: BYTE;\r\n AceFlags: BYTE;\r\n AceSize: WORD;\r\n end;\r\n ACE_HEADER = _ACE_HEADER;\r\n PACE_HEADER = ^_ACE_HEADER;\r\n\r\n _ACCESS_ALLOWED_ACE = record\r\n Header: ACE_HEADER;\r\n Mask: ACCESS_MASK;\r\n SidStart: DWORD;\r\n end;\r\n\r\n ACCESS_ALLOWED_ACE = _ACCESS_ALLOWED_ACE;\r\n PACCESS_ALLOWED_ACE = ^_ACCESS_ALLOWED_ACE;\r\n \r\nprocedure TJclAppInstances.InitData;\r\nbegin\r\n if ExplicitUniqueAppId <> '' then\r\n FUniqueAppID := JclAIPrefix + ExplicitUniqueAppId\r\n else\r\n FUniqueAppID := AnsiUpperCase(JclAIPrefix + ParamStr(0));\r\n\r\n CharReplace(FUniqueAppID, '\\', '_');\r\n\r\n FMessageID := RegisterWindowMessage(PChar(FUniqueAppID + JclAIMessage));\r\n\r\n FOptex := TJclOptex.Create(FUniqueAppID + JclAIOptex, 4000);\r\n\r\n InitAllData;\r\n InitSessionData;\r\n InitUserData;\r\nend;\r\n\r\nprocedure TJclAppInstances.InitAllData;\r\nvar\r\n UserInfo: PTokenUser;\r\n ACL: PACL;\r\n SID: PSID;\r\n SecurityAttributes: PSecurityAttributes;\r\n SecurityDescriptor: PSecurityDescriptor;\r\nbegin\r\n UserInfo := nil;\r\n ACL := nil;\r\n SID := nil;\r\n SecurityDescriptor := nil;\r\n SecurityAttributes := nil;\r\n try\r\n SecurityGetAllUsers(UserInfo, SID, ACL, SecurityDescriptor, SecurityAttributes);\r\n\r\n FOptex.Enter;\r\n try\r\n FAllMapping := TJclSwapFileMapping.Create(FUniqueAppID + JclAIAllMapping,\r\n PAGE_READWRITE, SizeOf(TJclAISharedData), SecurityAttributes);\r\n FAllMappingView := FAllMapping.Views[FAllMapping.Add(FILE_MAP_ALL_ACCESS, SizeOf(TJclAISharedData), 0)];\r\n if not FAllMapping.Existed then\r\n FillChar(FAllMappingView.Memory^, SizeOf(TJclAISharedData), #0);\r\n finally\r\n FOptex.Leave;\r\n end;\r\n finally\r\n SecurityFree(UserInfo, SID, ACL, SecurityDescriptor, SecurityAttributes);\r\n end;\r\nend;\r\n\r\nprocedure TJclAppInstances.InitSessionData;\r\nvar\r\n UserInfo: PTokenUser;\r\n ACL: PACL;\r\n SID: PSID;\r\n SecurityAttributes: PSecurityAttributes;\r\n SecurityDescriptor: PSecurityDescriptor;\r\n SessionID: DWORD;\r\nbegin\r\n UserInfo := nil;\r\n ACL := nil;\r\n SID := nil;\r\n SecurityDescriptor := nil;\r\n SecurityAttributes := nil;\r\n try\r\n SecurityGetAllUsers(UserInfo, SID, ACL, SecurityDescriptor, SecurityAttributes);\r\n\r\n SessionID := 0;\r\n ProcessIdToSessionId(GetCurrentProcessId, SessionID); // RESULT\r\n FOptex.Enter;\r\n try\r\n FSessionMapping := TJclSwapFileMapping.Create(FUniqueAppID + JclAISessionMapping + IntToStr(SessionID),\r\n PAGE_READWRITE, SizeOf(TJclAISharedData), SecurityAttributes);\r\n FSessionMappingView := FSessionMapping.Views[FSessionMapping.Add(FILE_MAP_ALL_ACCESS, SizeOf(TJclAISharedData), 0)];\r\n if not FSessionMapping.Existed then\r\n FillChar(FSessionMappingView.Memory^, SizeOf(TJclAISharedData), #0);\r\n finally\r\n FOptex.Leave;\r\n end;\r\n finally\r\n SecurityFree(UserInfo, SID, ACL, SecurityDescriptor, SecurityAttributes);\r\n end;\r\nend;\r\n\r\nprocedure TJclAppInstances.InitUserData;\r\nvar\r\n UserInfo: PTokenUser;\r\n ACL: PACL;\r\n SID: PSID;\r\n SecurityAttributes: PSecurityAttributes;\r\n SecurityDescriptor: PSecurityDescriptor;\r\n UserName, GroupName: WideString;\r\nbegin\r\n UserInfo := nil;\r\n ACL := nil;\r\n SID := nil;\r\n SecurityDescriptor := nil;\r\n SecurityAttributes := nil;\r\n try\r\n SecurityGetCurrentUser(UserInfo, SID, ACL, SecurityDescriptor, SecurityAttributes);\r\n LookupAccountBySid(UserInfo.User.Sid, UserName, GroupName);\r\n\r\n FOptex.Enter;\r\n try\r\n FUserMapping := TJclSwapFileMapping.Create(FUniqueAppID + JclAIUserMapping + UserName + '_' + GroupName,\r\n PAGE_READWRITE, SizeOf(TJclAISharedData), SecurityAttributes);\r\n FUserMappingView := FUserMapping.Views[FUserMapping.Add(FILE_MAP_ALL_ACCESS, SizeOf(TJclAISharedData), 0)];\r\n if not FUserMapping.Existed then\r\n FillChar(FUserMappingView.Memory^, SizeOf(TJclAISharedData), #0);\r\n finally\r\n FOptex.Leave;\r\n end;\r\n finally\r\n SecurityFree(UserInfo, SID, ACL, SecurityDescriptor, SecurityAttributes);\r\n end;\r\nend;\r\n\r\nclass procedure TJclAppInstances.KillInstance;\r\nbegin\r\n Halt(0);\r\nend;\r\n\r\nfunction EnumNotifyWinProc(Wnd: THandle; Message: PMessage): BOOL; stdcall;\r\nbegin\r\n SendNotifyMessage(Wnd, Message^.Msg, Message^.WParam, Message^.LParam);\r\n Result := True;\r\nend;\r\n\r\nprocedure TJclAppInstances.NotifyInstances(const W, L: Integer);\r\nvar\r\n I: Integer;\r\n Wnd: THandle;\r\n TID: DWORD;\r\n Msg: TMessage;\r\n SharedData: PJclAISharedData;\r\nbegin\r\n FOptex.Enter;\r\n try\r\n SharedData := PJclAISharedData(FAllMappingView.Memory);\r\n for I := 0 to SharedData^.Count - 1 do\r\n begin\r\n Wnd := GetApplicationWnd(SharedData^.ProcessIDs[I]);\r\n TID := GetWindowThreadProcessId(Wnd, nil);\r\n while Wnd <> 0 do\r\n begin // Send message to TApplication queue\r\n if PostThreadMessage(TID, FMessageID, W, L) or\r\n (GetLastError = ERROR_INVALID_THREAD_ID) then\r\n Break;\r\n Sleep(1);\r\n end;\r\n Msg.Msg := FMessageID;\r\n Msg.WParam := W;\r\n Msg.LParam := L;\r\n EnumThreadWindows(TID, @EnumNotifyWinProc, LPARAM(@Msg));\r\n end;\r\n finally\r\n FOptex.Leave;\r\n end;\r\nend;\r\n\r\nprocedure TJclAppInstances.RemoveInstance(MappingView: TJclFileMappingView);\r\nvar\r\n I: Integer;\r\n SharedData: PJclAISharedData;\r\nbegin\r\n FOptex.Enter;\r\n try\r\n SharedData := PJclAISharedData(MappingView.Memory);\r\n for I := 0 to SharedData^.Count - 1 do\r\n if SharedData^.ProcessIDs[I] = FCPID then\r\n begin\r\n SharedData^.ProcessIDs[I] := 0;\r\n Move(SharedData^.ProcessIDs[I + 1], SharedData^.ProcessIDs[I], (SharedData^.Count - I) * SizeOf(DWORD));\r\n Dec(SharedData^.Count);\r\n Break;\r\n end;\r\n finally\r\n FOptex.Leave;\r\n end;\r\nend;\r\n\r\nprocedure TJclAppInstances.SecurityFree(UserInfo: PTokenUser; SID: PSID; ACL: PACL;\r\n SecurityDescriptor: PSecurityDescriptor; SecurityAttributes: PSecurityAttributes);\r\nbegin\r\n if Assigned(UserInfo) then\r\n FreeMem(UserInfo);\r\n if Assigned(SID) then\r\n FreeSID(SID);\r\n if Assigned(ACL) then\r\n FreeMem(ACL);\r\n if Assigned(SecurityDescriptor) then\r\n FreeMem(SecurityDescriptor);\r\n if Assigned(SecurityAttributes) then\r\n FreeMem(SecurityAttributes);\r\nend;\r\n\r\nprocedure TJclAppInstances.SecurityGetAllUsers(out UserInfo: PTokenUser; out SID: PSID; out ACL: PACL;\r\n out SecurityDescriptor: PSecurityDescriptor; out SecurityAttributes: PSecurityAttributes);\r\nvar\r\n WorldAuth: {$IFDEF HAS_UNITSCOPE}WinApi.{$ENDIF HAS_UNITSCOPE}Windows.SID_IDENTIFIER_AUTHORITY;\r\nbegin\r\n UserInfo := nil;\r\n ACL := nil;\r\n SID := nil;\r\n SecurityDescriptor := nil;\r\n SecurityAttributes := nil;\r\n\r\n SecurityGetCurrentUserInfo(UserInfo);\r\n\r\n // Retrieve the SID of the Everyone group.\r\n WorldAuth := JclWin32.SECURITY_WORLD_SID_AUTHORITY;\r\n AllocateAndInitializeSid(WorldAuth, 1, SECURITY_WORLD_RID, 0, 0, 0, 0, 0, 0, 0, SID); // RESULT\r\n\r\n SecurityGetSecurityAttributes(UserInfo^.User.Sid, SID, ACL, SecurityDescriptor, SecurityAttributes);\r\nend;\r\n\r\nprocedure TJclAppInstances.SecurityGetCurrentUser(out UserInfo: PTokenUser; out SID: PSID; out ACL: PACL; \r\n out SecurityDescriptor: PSecurityDescriptor; out SecurityAttributes: PSecurityAttributes);\r\nbegin\r\n UserInfo := nil;\r\n ACL := nil;\r\n SID := nil;\r\n SecurityDescriptor := nil;\r\n SecurityAttributes := nil;\r\n SecurityGetCurrentUserInfo(UserInfo);\r\n SecurityGetSecurityAttributes(UserInfo^.User.Sid, UserInfo.User.Sid, ACL, SecurityDescriptor, SecurityAttributes);\r\nend;\r\n\r\nprocedure TJclAppInstances.SecurityGetCurrentUserInfo(out UserInfo: PTokenUser);\r\nvar\r\n ProcessToken: THandle;\r\n TokenInfoSize: DWORD;\r\n HaveToken: Boolean;\r\nbegin\r\n UserInfo := nil;\r\n ProcessToken := 0;\r\n try\r\n HaveToken := OpenThreadToken(GetCurrentThread, TOKEN_QUERY, True, ProcessToken);\r\n if (not HaveToken) and (GetLastError = ERROR_NO_TOKEN) then\r\n HaveToken := OpenProcessToken(GetCurrentProcess, TOKEN_QUERY, ProcessToken);\r\n if not HaveToken then\r\n RaiseLastOSError;\r\n\r\n if GetTokenInformation(ProcessToken, TokenUser, nil, 0, TokenInfoSize) or\r\n (GetLastError <> ERROR_INSUFFICIENT_BUFFER) then\r\n RaiseLastOSError;\r\n UserInfo := PTokenUser(AllocMem(TokenInfoSize));\r\n Win32Check(GetTokenInformation(ProcessToken, TokenUser, UserInfo, TokenInfoSize, TokenInfoSize));\r\n finally\r\n if ProcessToken <> 0 then\r\n CloseHandle(ProcessToken);\r\n end;\r\nend;\r\n\r\nprocedure TJclAppInstances.SecurityGetSecurityAttributes(OwnerSID, AccessSID: PSID; out ACL: PACL;\r\n out SecurityDescriptor: PSecurityDescriptor; out SecurityAttributes: PSecurityAttributes);\r\nvar\r\n ACLSize: SizeInt;\r\nbegin\r\n // create the ACL\r\n ACLSize := SizeOf(TACL) + SizeOf(ACCESS_ALLOWED_ACE) + SizeOf(DWORD) + GetLengthSid(AccessSID);\r\n ACL := AllocMem(ACLSize);\r\n Win32Check(InitializeAcl(ACL^, ACLSize, ACL_REVISION));\r\n Win32Check(AddAccessAllowedAce(ACL{$IFDEF BORLAND}^{$ENDIF}, ACL_REVISION, FILE_MAP_ALL_ACCESS, AccessSID));\r\n Assert(IsValidAcl(ACL{$IFNDEF RTL230_UP}^{$ENDIF})); // QC #102231\r\n\r\n // create the security descriptor\r\n SecurityDescriptor := AllocMem(SECURITY_DESCRIPTOR_MIN_LENGTH);\r\n Win32Check(InitializeSecurityDescriptor(SecurityDescriptor, SECURITY_DESCRIPTOR_REVISION));\r\n Win32Check(SetSecurityDescriptorSacl(SecurityDescriptor, False, nil, True));\r\n Win32Check(SetSecurityDescriptorOwner(SecurityDescriptor, OwnerSID, False));\r\n Win32Check(SetSecurityDescriptorGroup(SecurityDescriptor, OwnerSID, False));\r\n Win32Check(SetSecurityDescriptorDacl(SecurityDescriptor, True, ACL, False));\r\n Assert(IsValidSecurityDescriptor(SecurityDescriptor));\r\n\r\n // create the security attributes\r\n SecurityAttributes := AllocMem(SizeOf(SecurityAttributes^));\r\n SecurityAttributes^.nLength := SizeOf(SecurityAttributes^);\r\n SecurityAttributes^.lpSecurityDescriptor := SecurityDescriptor;\r\n SecurityAttributes^.bInheritHandle := False;\r\nend;\r\n\r\nfunction TJclAppInstances.SendCmdLineParams(const WindowClassName: string; const OriginatorWnd: THandle): Boolean;\r\nvar\r\n TempList: TStringList;\r\n I: Integer;\r\nbegin\r\n TempList := TStringList.Create;\r\n try\r\n for I := 1 to ParamCount do\r\n TempList.Add(ParamStr(I));\r\n Result := SendStrings(WindowClassName, AppInstCmdLineDataKind, TempList, OriginatorWnd);\r\n finally\r\n TempList.Free;\r\n end;\r\nend;\r\n\r\ntype\r\n PEnumWinRec = ^TEnumWinRec;\r\n TEnumWinRec = record\r\n WindowClassName: PChar;\r\n OriginatorWnd: THandle;\r\n CopyData: TCopyDataStruct;\r\n Self: TJclAppInstances;\r\n end;\r\n\r\nfunction EnumWinProc(Wnd: THandle; Data: PEnumWinRec): BOOL; stdcall;\r\nvar\r\n ClassName: array [0..200] of Char;\r\n I: Integer;\r\n PID: DWORD;\r\n Found: Boolean;\r\n SharedData: PJclAISharedData;\r\nbegin\r\n if (GetClassName(Wnd, ClassName, Length(ClassName) - 1) > 0) and\r\n (StrComp(ClassName, Data.WindowClassName) = 0) then\r\n begin\r\n GetWindowThreadProcessId(Wnd, @PID);\r\n Found := False;\r\n Data.Self.FOptex.Enter;\r\n try\r\n SharedData := PJclAISharedData(Data.Self.FAllMappingView.Memory);\r\n for I := 0 to SharedData^.Count - 1 do\r\n if SharedData^.ProcessIDs[I] = PID then\r\n begin\r\n Found := True;\r\n Break;\r\n end;\r\n finally\r\n Data.Self.FOptex.Leave;\r\n end;\r\n if Found then\r\n SendMessage(Wnd, WM_COPYDATA, Data.OriginatorWnd, LPARAM(@Data.CopyData));\r\n end;\r\n Result := True;\r\nend;\r\n\r\nfunction TJclAppInstances.SendData(const WindowClassName: string;\r\n const DataKind: TJclAppInstDataKind;\r\n Data: Pointer; const Size: Integer;\r\n OriginatorWnd: THandle): Boolean;\r\nvar\r\n EnumWinRec: TEnumWinRec;\r\nbegin\r\n Assert(DataKind <> AppInstDataKindNoData);\r\n EnumWinRec.WindowClassName := PChar(WindowClassName);\r\n EnumWinRec.OriginatorWnd := OriginatorWnd;\r\n EnumWinRec.CopyData.dwData := DataKind;\r\n EnumWinRec.CopyData.cbData := Size;\r\n EnumWinRec.CopyData.lpData := Data;\r\n EnumWinRec.Self := Self;\r\n Result := EnumWindows(@EnumWinProc, LPARAM(@EnumWinRec));\r\nend;\r\n\r\nfunction TJclAppInstances.SendString(const WindowClassName: string;\r\n const DataKind: TJclAppInstDataKind; const S: string;\r\n OriginatorWnd: THandle): Boolean;\r\nbegin\r\n Result := SendData(WindowClassName, DataKind, PChar(S), Length(S) * SizeOf(Char), OriginatorWnd);\r\nend;\r\n\r\nfunction TJclAppInstances.SendStrings(const WindowClassName: string;\r\n const DataKind: TJclAppInstDataKind; const Strings: TStrings;\r\n OriginatorWnd: THandle): Boolean;\r\nbegin\r\n Result := SendString(WindowClassName, DataKind, Strings.Text, OriginatorWnd);\r\nend;\r\n\r\nfunction TJclAppInstances.SessionSwitchTo(Index: Integer): Boolean;\r\nbegin\r\n Result := BringAppWindowToFront(SessionAppWnds[Index]);\r\nend;\r\n\r\nclass function TJclAppInstances.SetForegroundWindow98(const Wnd: THandle): Boolean;\r\nvar\r\n ForeThreadID, NewThreadID: DWORD;\r\nbegin\r\n if GetForegroundWindow <> Wnd then\r\n begin\r\n ForeThreadID := GetWindowThreadProcessId(GetForegroundWindow, nil);\r\n NewThreadID := GetWindowThreadProcessId(Wnd, nil);\r\n if ForeThreadID <> NewThreadID then\r\n begin\r\n AttachThreadInput(ForeThreadID, NewThreadID, True);\r\n Result := SetForegroundWindow(Wnd);\r\n AttachThreadInput(ForeThreadID, NewThreadID, False);\r\n if Result then\r\n Result := SetForegroundWindow(Wnd);\r\n end\r\n else\r\n Result := SetForegroundWindow(Wnd);\r\n end\r\n else\r\n Result := True;\r\nend;\r\n\r\nfunction TJclAppInstances.SwitchTo(Index: Integer): Boolean;\r\nbegin\r\n Result := BringAppWindowToFront(AppWnds[Index]);\r\nend;\r\n\r\nprocedure TJclAppInstances.UserNotify(Param: Longint);\r\nbegin\r\n NotifyInstances(AI_USERMSG, Param);\r\nend;\r\n\r\nfunction TJclAppInstances.UserSwitchTo(Index: Integer): Boolean;\r\nbegin\r\n Result := BringAppWindowToFront(UserAppWnds[Index]);\r\nend;\r\n\r\nfunction JclAppInstances: TJclAppInstances;\r\nbegin\r\n if AppInstances = nil then\r\n AppInstances := TJclAppInstances.Create;\r\n Result := AppInstances;\r\nend;\r\n\r\nfunction JclAppInstances(const UniqueAppIdGuidStr: string): TJclAppInstances;\r\nbegin\r\n Assert(AppInstances = nil);\r\n ExplicitUniqueAppId := UniqueAppIdGuidStr;\r\n Result := JclAppInstances;\r\nend;\r\n\r\n// Interprocess communication routines\r\nfunction ReadMessageCheck(var Message: TMessage; const IgnoredOriginatorWnd: THandle): TJclAppInstDataKind;\r\nbegin\r\n if (Message.Msg = WM_COPYDATA) and (TWMCopyData(Message).From <> IgnoredOriginatorWnd) then\r\n begin\r\n Message.Result := 1;\r\n Result := TJclAppInstDataKind(TWMCopyData(Message).CopyDataStruct^.dwData);\r\n end\r\n else\r\n begin\r\n Message.Result := 0;\r\n Result := AppInstDataKindNoData;\r\n end;\r\nend;\r\n\r\nprocedure ReadMessageData(const Message: TMessage; var Data: Pointer; var Size: Integer);\r\nbegin\r\n if TWMCopyData(Message).Msg = WM_COPYDATA then\r\n begin\r\n Size := TWMCopyData(Message).CopyDataStruct^.cbData;\r\n GetMem(Data, Size);\r\n Move(TWMCopyData(Message).CopyDataStruct^.lpData^, Data^, Size);\r\n end;\r\nend;\r\n\r\nprocedure ReadMessageString(const Message: TMessage; out S: string);\r\nbegin\r\n if TWMCopyData(Message).Msg = WM_COPYDATA then\r\n SetString(S, PChar(TWMCopyData(Message).CopyDataStruct^.lpData), TWMCopyData(Message).CopyDataStruct^.cbData div SizeOf(Char));\r\nend;\r\n\r\nprocedure ReadMessageStrings(const Message: TMessage; const Strings: TStrings);\r\nvar\r\n S: string;\r\nbegin\r\n if TWMCopyData(Message).Msg = WM_COPYDATA then\r\n begin\r\n ReadMessageString(Message, S);\r\n Strings.Text := S;\r\n end;\r\nend;\r\n\r\nfunction SendData(const Wnd, OriginatorWnd: HWND;\r\n const DataKind: TJclAppInstDataKind; const Data: Pointer; const Size: Integer): Boolean;\r\nvar\r\n CopyData: TCopyDataStruct;\r\nbegin\r\n CopyData.dwData := DataKind;\r\n CopyData.cbData := Size;\r\n CopyData.lpData := Data;\r\n Result := Boolean(SendMessage(Wnd, WM_COPYDATA, OriginatorWnd, LPARAM(@CopyData)));\r\nend;\r\n\r\nfunction SendStrings(const Wnd, OriginatorWnd: HWND;\r\n const DataKind: TJclAppInstDataKind; const Strings: TStrings): Boolean;\r\nbegin\r\n Result := SendString(Wnd, OriginatorWnd, DataKind, Strings.Text);\r\nend;\r\n\r\nfunction SendCmdLineParams(const Wnd, OriginatorWnd: HWND): Boolean;\r\nvar\r\n TempList: TStringList;\r\n I: Integer;\r\nbegin\r\n TempList := TStringList.Create;\r\n try\r\n for I := 1 to ParamCount do\r\n TempList.Add(ParamStr(I));\r\n Result := SendStrings(Wnd, OriginatorWnd, AppInstCmdLineDataKind, TempList);\r\n finally\r\n TempList.Free;\r\n end;\r\nend;\r\n\r\nfunction SendString(const Wnd, OriginatorWnd: HWND;\r\n const DataKind: TJclAppInstDataKind; const S: string): Boolean;\r\nbegin\r\n Result := SendData(Wnd, OriginatorWnd, DataKind, PChar(S), Length(S) * SizeOf(Char));\r\nend;\r\n\r\ninitialization\r\n {$IFDEF UNITVERSIONING}\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n {$ENDIF UNITVERSIONING}\r\n\r\nfinalization\r\n FreeAndNil(AppInstances);\r\n {$IFDEF UNITVERSIONING}\r\n UnregisterUnitVersion(HInstance);\r\n {$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jcl/source/windows/JclCIL.pas", "content": "{**************************************************************************************************}\r\n{ }\r\n{ Project JEDI Code Library (JCL) }\r\n{ }\r\n{ The contents of this file are subject to the Mozilla Public License Version 1.1 (the \"License\"); }\r\n{ you may not use this file except in compliance with the License. You may obtain a copy of the }\r\n{ License at http://www.mozilla.org/MPL/ }\r\n{ }\r\n{ Software distributed under the License is distributed on an \"AS IS\" basis, WITHOUT WARRANTY OF }\r\n{ ANY KIND, either express or implied. See the License for the specific language governing rights }\r\n{ and limitations under the License. }\r\n{ }\r\n{ The Original Code is JclCIL.pas. }\r\n{ }\r\n{ The Initial Developer of the Original Code is Flier Lu (). }\r\n{ Portions created by Flier Lu are Copyright (C) Flier Lu. All Rights Reserved. }\r\n{ }\r\n{ Contributors: }\r\n{ Flier Lu (flier) }\r\n{ Robert Marquardt (marquardt) }\r\n{ Robert Rossmair (rrossmair) }\r\n{ Olivier Sannier (obones) }\r\n{ Petr Vones (pvones) }\r\n{ }\r\n{**************************************************************************************************}\r\n{ }\r\n{ Microsoft .Net CIL Instruction Set information support routines and classes. }\r\n{ }\r\n{**************************************************************************************************}\r\n{ }\r\n{ Last modified: $Date:: 2011-09-03 00:07:50 +0200 (sam. 03 sept. 2011) $ }\r\n{ Revision: $Rev:: 3599 $ }\r\n{ Author: $Author:: outchy $ }\r\n{ }\r\n{**************************************************************************************************}\r\n\r\nunit JclCIL;\r\n\r\ninterface\r\n\r\n{$I jcl.inc}\r\n{$I windowsonly.inc}\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n {$IFDEF HAS_UNITSCOPE}\r\n {$IFDEF MSWINDOWS}\r\n Winapi.Windows,\r\n {$ENDIF MSWINDOWS}\r\n System.Classes, System.SysUtils, System.Contnrs,\r\n {$ELSE ~HAS_UNITSCOPE}\r\n {$IFDEF MSWINDOWS}\r\n Windows,\r\n {$ENDIF MSWINDOWS}\r\n Classes, SysUtils, Contnrs,\r\n {$ENDIF ~HAS_UNITSCOPE}\r\n JclBase, JclSysUtils, JclMetadata;\r\n\r\ntype\r\n TJclOpCode =\r\n (opNop, opBreak,\r\n opLdArg_0, opLdArg_1, opLdArg_2, opLdArg_3,\r\n opLdLoc_0, opLdLoc_1, opLdLoc_2, opLdLoc_3,\r\n opStLoc_0, opStLoc_1, opStLoc_2, opStLoc_3,\r\n opldArg_s, opLdArga_s, opStArg_s,\r\n opLdLoc_s, opLdLoca_s, opStLoc_s,\r\n opLdNull, opLdc_I4_M1,\r\n opLdc_I4_0, opLdc_I4_1, opLdc_I4_2, opLdc_I4_3, opLdc_I4_4,\r\n opLdc_I4_5, opLdc_I4_6, opLdc_I4_7, opLdc_I4_8, opLdc_I4_s,\r\n opLdc_i4, opLdc_i8, opLdc_r4, opLdc_r8,\r\n opUnused49,\r\n opDup, opPop, opJmp, opCall, opCalli, opRet,\r\n opBr_s, opBrFalse_s, opBrTrue_s,\r\n opBeq_s, opBge_s, opBgt_s, opBle_s, opBlt_s,\r\n opBne_un_s, opBge_un_s, opBgt_un_s, opBle_un_s, opBlt_un_s,\r\n opBr, opBrFalse, opBrTrue,\r\n opBeq, opBge, opBgt, opBle, opBlt,\r\n opBne_un, opBge_un, opBgt_un, opBle_un, opBlt_un,\r\n opSwitch,\r\n opLdInd_i1, opLdInd_i2, opLdInd_u1, opLdInd_u2,\r\n opLdInd_i4, opLdInd_u4, opLdInd_i8, opLdInd_i,\r\n opLdInd_r4, opLdInd_r8, opLdInd_ref, opStInd_ref,\r\n opStInd_i1, opStInd_i2, opStInd_i4, opStInd_i8,\r\n opStInd_r4, opStInd_r8,\r\n opAdd, opSub, opMul, opDiv, opDiv_un, opRem, opRem_un,\r\n opAnd, opOr, opXor, opShl, opShr, opShr_un, opNeg, opNot,\r\n opConv_i1, opConv_i2, opConv_i4, opConv_i8,\r\n opConv_r4, opConv_r8, opConv_u4, opConv_u8,\r\n opCallVirt, opCpObj, opLdObj, opLdStr, opNewObj,\r\n opCastClass, opIsInst, opConv_r_un,\r\n opUnused58, opUnused1,\r\n opUnbox, opThrow,\r\n opLdFld, opLdFlda, opStFld, opLdsFld, opLdsFlda, opStsFld, opStObj,\r\n opConv_ovf_i1_un, opConv_ovf_i2_un, opConv_ovf_i4_un, opConv_ovf_i8_un,\r\n opConv_ovf_u1_un, opConv_ovf_u2_un, opConv_ovf_u4_un, opConv_ovf_u8_un,\r\n opConv_ovf_i_un, opConv_ovf_u_un,\r\n opBox, opNewArr, opLdLen,\r\n opLdElema, opLdElem_i1, opLdElem_u1, opLdElem_i2, opLdElem_u2,\r\n opLdElem_i4, opLdElem_u4, opLdElem_i8, opLdElem_i,\r\n opLdElem_r4, opLdElem_r8, opLdElem_ref,\r\n opStElem_i, opStElem_i1, opStElem_i2, opStElem_i4, opStElem_i8,\r\n opStElem_r4, opStElem_r8, opStElem_ref,\r\n opUnused2, opUnused3, opUnused4, opUnused5,\r\n opUnused6, opUnused7, opUnused8, opUnused9,\r\n opUnused10, opUnused11, opUnused12, opUnused13,\r\n opUnused14, opUnused15, opUnused16, opUnused17,\r\n opConv_ovf_i1, opConv_ovf_u1, opConv_ovf_i2, opConv_ovf_u2,\r\n opConv_ovf_i4, opConv_ovf_u4, opConv_ovf_i8, opConv_ovf_u8,\r\n opUnused50, opUnused18, opUnused19, opUnused20,\r\n opUnused21, opUnused22, opUnused23,\r\n opRefAnyVal, opCkFinite,\r\n opUnused24, opUnused25,\r\n opMkRefAny,\r\n opUnused59, opUnused60, opUnused61, opUnused62, opUnused63,\r\n opUnused64, opUnused65, opUnused66, opUnused67,\r\n opLdToken,\r\n opConv_u2, opConv_u1, opConv_i, opConv_ovf_i, opConv_ovf_u,\r\n opAdd_ovf, opAdd_ovf_un, opMul_ovf, opMul_ovf_un, opSub_ovf, opSub_ovf_un,\r\n opEndFinally, opLeave, opLeave_s, opStInd_i, opConv_u,\r\n opUnused26, opUnused27, opUnused28, opUnused29, opUnused30,\r\n opUnused31, opUnused32, opUnused33, opUnused34, opUnused35,\r\n opUnused36, opUnused37, opUnused38, opUnused39, opUnused40,\r\n opUnused41, opUnused42, opUnused43, opUnused44, opUnused45,\r\n opUnused46, opUnused47, opUnused48,\r\n opPrefix7, opPrefix6, opPrefix5, opPrefix4,\r\n opPrefix3, opPrefix2, opPrefix1, opPrefixRef,\r\n\r\n opArgLlist, opCeq, opCgt, opCgt_un, opClt, opClt_un,\r\n opLdFtn, opLdVirtFtn, optUnused56,\r\n opLdArg, opLdArga, opStArg, opLdLoc, opLdLoca, opStLoc,\r\n opLocalLoc, opUnused57, opEndFilter, opUnaligned, opVolatile,\r\n opTail, opInitObj, opUnused68, opCpBlk, opInitBlk, opUnused69,\r\n opRethrow, opUnused51, opSizeOf, opRefAnyType,\r\n opUnused52, opUnused53, opUnused54, opUnused55, opUnused70);\r\n\r\n TJclInstructionDumpILOption =\r\n (doLineNo, doRawBytes, doIL, doTokenValue, doComment);\r\n TJclInstructionDumpILOptions = set of TJclInstructionDumpILOption;\r\n\r\n TJclInstructionParamType =\r\n (ptVoid, ptI1, ptI2, ptI4, ptI8, ptU1, ptU2, ptU4, ptU8, ptR4, ptR8,\r\n ptToken, ptSOff, ptLOff, ptArray);\r\n\r\nconst\r\n InstructionDumpILAllOption =\r\n [doLineNo, doRawBytes, doIL, doTokenValue, doComment];\r\n\r\ntype\r\n TJclClrILGenerator = class;\r\n\r\n TJclInstruction = class(TObject)\r\n private\r\n FOpCode: TJclOpCode;\r\n FOffset: DWORD;\r\n FParam: Variant;\r\n FOwner: TJclClrILGenerator;\r\n function GetWideOpCode: Boolean;\r\n function GetRealOpCode: Byte;\r\n function GetName: string;\r\n function GetFullName: string;\r\n function GetDescription: string;\r\n function GetParamType: TJclInstructionParamType;\r\n function FormatLabel(Offset: Integer): string;\r\n protected\r\n function GetSize: DWORD; virtual;\r\n function DumpILOption(Option: TJclInstructionDumpILOption): string; virtual;\r\n public\r\n constructor Create(AOwner: TJclClrILGenerator; AOpCode: TJclOpCode);\r\n procedure Load(Stream: TStream); virtual;\r\n procedure Save(Stream: TStream); virtual;\r\n function DumpIL(Options: TJclInstructionDumpILOptions = [doIL]): string;\r\n property Owner: TJclClrILGenerator read FOwner;\r\n property OpCode: TJclOpCode read FOpCode;\r\n property WideOpCode: Boolean read GetWideOpCode;\r\n property RealOpCode: Byte read GetRealOpCode;\r\n property Param: Variant read FParam write FParam;\r\n property ParamType: TJclInstructionParamType read GetParamType;\r\n property Name: string read GetName;\r\n property FullName: string read GetFullName;\r\n property Description: string read GetDescription;\r\n property Size: DWORD read GetSize;\r\n property Offset: DWORD read FOffset;\r\n end;\r\n\r\n TJclUnaryInstruction = class(TJclInstruction);\r\n\r\n TJclBinaryInstruction = class(TJclInstruction);\r\n\r\n TJclClrILGenerator = class(TObject)\r\n private\r\n FMethod: TJclClrMethodBody;\r\n FInstructions: TObjectList;\r\n function GetInstructionCount: Integer;\r\n function GetInstruction(const Idx: Integer): TJclInstruction;\r\n public\r\n constructor Create(AMethod: TJclClrMethodBody = nil);\r\n destructor Destroy; override;\r\n function DumpIL(Options: TJclInstructionDumpILOptions): string;\r\n property Method: TJclClrMethodBody read FMethod;\r\n property Instructions[const Idx: Integer]: TJclInstruction read GetInstruction;\r\n property InstructionCount: Integer read GetInstructionCount;\r\n end;\r\n\r\n EJclCliInstructionError = class(EJclError);\r\n EJclCliInstructionStreamInvalid = class(EJclCliInstructionError);\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jcl.svn.sourceforge.net/svnroot/jcl/tags/JCL-2.4-Build4571/jcl/source/windows/JclCIL.pas $';\r\n Revision: '$Revision: 3599 $';\r\n Date: '$Date: 2011-09-03 00:07:50 +0200 (sam. 03 sept. 2011) $';\r\n LogPath: 'JCL\\source\\windows';\r\n Extra: '';\r\n Data: nil\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n {$IFDEF HAS_UNITSCOPE}\r\n System.Variants,\r\n {$ELSE ~HAS_UNITSCOPE}\r\n Variants,\r\n {$ENDIF ~HAS_UNITSCOPE}\r\n JclCLR,\r\n JclPeImage,\r\n JclStrings, JclResources;\r\n\r\ntype\r\n TJclOpCodeInfoType = (itName, itFullName, itDescription);\r\n\r\nconst\r\n STP1 = $FE;\r\n\r\n OpCodeInfos: array [TJclOpCode, TJclOpCodeInfoType] of PResStringRec =\r\n (\r\n (@RsCILNamenop, @RsCILCmdnop, @RsCILDescrnop),\r\n (@RsCILNamebreak, @RsCILCmdbreak, @RsCILDescrbreak),\r\n (@RsCILNameldarg0, @RsCILCmdldarg0, @RsCILDescrldarg0),\r\n (@RsCILNameldarg1, @RsCILCmdldarg1, @RsCILDescrldarg1),\r\n (@RsCILNameldarg2, @RsCILCmdldarg2, @RsCILDescrldarg2),\r\n (@RsCILNameldarg3, @RsCILCmdldarg3, @RsCILDescrldarg3),\r\n (@RsCILNameldloc0, @RsCILCmdldloc0, @RsCILDescrldloc0),\r\n (@RsCILNameldloc1, @RsCILCmdldloc1, @RsCILDescrldloc1),\r\n (@RsCILNameldloc2, @RsCILCmdldloc2, @RsCILDescrldloc2),\r\n (@RsCILNameldloc3, @RsCILCmdldloc3, @RsCILDescrldloc3),\r\n (@RsCILNamestloc0, @RsCILCmdstloc0, @RsCILDescrstloc0),\r\n (@RsCILNamestloc1, @RsCILCmdstloc1, @RsCILDescrstloc1),\r\n (@RsCILNamestloc2, @RsCILCmdstloc2, @RsCILDescrstloc2),\r\n (@RsCILNamestloc3, @RsCILCmdstloc3, @RsCILDescrstloc3),\r\n (@RsCILNameldargs, @RsCILCmdldargs, @RsCILDescrldargs),\r\n (@RsCILNameldargas, @RsCILCmdldargas, @RsCILDescrldargas),\r\n (@RsCILNamestargs, @RsCILCmdstargs, @RsCILDescrstargs),\r\n (@RsCILNameldlocs, @RsCILCmdldlocs, @RsCILDescrldlocs),\r\n (@RsCILNameldlocas, @RsCILCmdldlocas, @RsCILDescrldlocas),\r\n (@RsCILNamestlocs, @RsCILCmdstlocs, @RsCILDescrstlocs),\r\n (@RsCILNameldnull, @RsCILCmdldnull, @RsCILDescrldnull),\r\n (@RsCILNameldci4m1, @RsCILCmdldci4m1, @RsCILDescrldci4m1),\r\n (@RsCILNameldci40, @RsCILCmdldci40, @RsCILDescrldci40),\r\n (@RsCILNameldci41, @RsCILCmdldci41, @RsCILDescrldci41),\r\n (@RsCILNameldci42, @RsCILCmdldci42, @RsCILDescrldci42),\r\n (@RsCILNameldci43, @RsCILCmdldci43, @RsCILDescrldci43),\r\n (@RsCILNameldci44, @RsCILCmdldci44, @RsCILDescrldci44),\r\n (@RsCILNameldci45, @RsCILCmdldci45, @RsCILDescrldci45),\r\n (@RsCILNameldci46, @RsCILCmdldci46, @RsCILDescrldci46),\r\n (@RsCILNameldci47, @RsCILCmdldci47, @RsCILDescrldci47),\r\n (@RsCILNameldci48, @RsCILCmdldci48, @RsCILDescrldci48),\r\n (@RsCILNameldci4s, @RsCILCmdldci4s, @RsCILDescrldci4s),\r\n (@RsCILNameldci4, @RsCILCmdldci4, @RsCILDescrldci4),\r\n (@RsCILNameldci8, @RsCILCmdldci8, @RsCILDescrldci8),\r\n (@RsCILNameldcr4, @RsCILCmdldcr4, @RsCILDescrldcr4),\r\n (@RsCILNameldcr8, @RsCILCmdldcr8, @RsCILDescrldcr8),\r\n (@RsCILNameunused1, @RsCILCmdunused1, @RsCILDescrunused1),\r\n (@RsCILNamedup, @RsCILCmddup, @RsCILDescrdup),\r\n (@RsCILNamepop, @RsCILCmdpop, @RsCILDescrpop),\r\n (@RsCILNamejmp, @RsCILCmdjmp, @RsCILDescrjmp),\r\n (@RsCILNamecall, @RsCILCmdcall, @RsCILDescrcall),\r\n (@RsCILNamecalli, @RsCILCmdcalli, @RsCILDescrcalli),\r\n (@RsCILNameret, @RsCILCmdret, @RsCILDescrret),\r\n (@RsCILNamebrs, @RsCILCmdbrs, @RsCILDescrbrs),\r\n (@RsCILNamebrfalses, @RsCILCmdbrfalses, @RsCILDescrbrfalses),\r\n (@RsCILNamebrtrues, @RsCILCmdbrtrues, @RsCILDescrbrtrues),\r\n (@RsCILNamebeqs, @RsCILCmdbeqs, @RsCILDescrbeqs),\r\n (@RsCILNamebges, @RsCILCmdbges, @RsCILDescrbges),\r\n (@RsCILNamebgts, @RsCILCmdbgts, @RsCILDescrbgts),\r\n (@RsCILNamebles, @RsCILCmdbles, @RsCILDescrbles),\r\n (@RsCILNameblts, @RsCILCmdblts, @RsCILDescrblts),\r\n (@RsCILNamebneuns, @RsCILCmdbneuns, @RsCILDescrbneuns),\r\n (@RsCILNamebgeuns, @RsCILCmdbgeuns, @RsCILDescrbgeuns),\r\n (@RsCILNamebgtuns, @RsCILCmdbgtuns, @RsCILDescrbgtuns),\r\n (@RsCILNamebleuns, @RsCILCmdbleuns, @RsCILDescrbleuns),\r\n (@RsCILNamebltuns, @RsCILCmdbltuns, @RsCILDescrbltuns),\r\n (@RsCILNamebr, @RsCILCmdbr, @RsCILDescrbr),\r\n (@RsCILNamebrfalse, @RsCILCmdbrfalse, @RsCILDescrbrfalse),\r\n (@RsCILNamebrtrue, @RsCILCmdbrtrue, @RsCILDescrbrtrue),\r\n (@RsCILNamebeq, @RsCILCmdbeq, @RsCILDescrbeq),\r\n (@RsCILNamebge, @RsCILCmdbge, @RsCILDescrbge),\r\n (@RsCILNamebgt, @RsCILCmdbgt, @RsCILDescrbgt),\r\n (@RsCILNameble, @RsCILCmdble, @RsCILDescrble),\r\n (@RsCILNameblt, @RsCILCmdblt, @RsCILDescrblt),\r\n (@RsCILNamebneun, @RsCILCmdbneun, @RsCILDescrbneun),\r\n (@RsCILNamebgeun, @RsCILCmdbgeun, @RsCILDescrbgeun),\r\n (@RsCILNamebgtun, @RsCILCmdbgtun, @RsCILDescrbgtun),\r\n (@RsCILNamebleun, @RsCILCmdbleun, @RsCILDescrbleun),\r\n (@RsCILNamebltun, @RsCILCmdbltun, @RsCILDescrbltun),\r\n (@RsCILNameswitch, @RsCILCmdswitch, @RsCILDescrswitch),\r\n (@RsCILNameldindi1, @RsCILCmdldindi1, @RsCILDescrldindi1),\r\n (@RsCILNameldindu1, @RsCILCmdldindu1, @RsCILDescrldindu1),\r\n (@RsCILNameldindi2, @RsCILCmdldindi2, @RsCILDescrldindi2),\r\n (@RsCILNameldindu2, @RsCILCmdldindu2, @RsCILDescrldindu2),\r\n (@RsCILNameldindi4, @RsCILCmdldindi4, @RsCILDescrldindi4),\r\n (@RsCILNameldindu4, @RsCILCmdldindu4, @RsCILDescrldindu4),\r\n (@RsCILNameldindi8, @RsCILCmdldindi8, @RsCILDescrldindi8),\r\n (@RsCILNameldindi, @RsCILCmdldindi, @RsCILDescrldindi),\r\n (@RsCILNameldindr4, @RsCILCmdldindr4, @RsCILDescrldindr4),\r\n (@RsCILNameldindr8, @RsCILCmdldindr8, @RsCILDescrldindr8),\r\n (@RsCILNameldindref, @RsCILCmdldindref, @RsCILDescrldindref),\r\n (@RsCILNamestindref, @RsCILCmdstindref, @RsCILDescrstindref),\r\n (@RsCILNamestindi1, @RsCILCmdstindi1, @RsCILDescrstindi1),\r\n (@RsCILNamestindi2, @RsCILCmdstindi2, @RsCILDescrstindi2),\r\n (@RsCILNamestindi4, @RsCILCmdstindi4, @RsCILDescrstindi4),\r\n (@RsCILNamestindi8, @RsCILCmdstindi8, @RsCILDescrstindi8),\r\n (@RsCILNamestindr4, @RsCILCmdstindr4, @RsCILDescrstindr4),\r\n (@RsCILNamestindr8, @RsCILCmdstindr8, @RsCILDescrstindr8),\r\n (@RsCILNameadd, @RsCILCmdadd, @RsCILDescradd),\r\n (@RsCILNamesub, @RsCILCmdsub, @RsCILDescrsub),\r\n (@RsCILNamemul, @RsCILCmdmul, @RsCILDescrmul),\r\n (@RsCILNamediv, @RsCILCmddiv, @RsCILDescrdiv),\r\n (@RsCILNamedivun, @RsCILCmddivun, @RsCILDescrdivun),\r\n (@RsCILNamerem, @RsCILCmdrem, @RsCILDescrrem),\r\n (@RsCILNameremun, @RsCILCmdremun, @RsCILDescrremun),\r\n (@RsCILNameand, @RsCILCmdand, @RsCILDescrand),\r\n (@RsCILNameor, @RsCILCmdor, @RsCILDescror),\r\n (@RsCILNamexor, @RsCILCmdxor, @RsCILDescrxor),\r\n (@RsCILNameshl, @RsCILCmdshl, @RsCILDescrshl),\r\n (@RsCILNameshr, @RsCILCmdshr, @RsCILDescrshr),\r\n (@RsCILNameshrun, @RsCILCmdshrun, @RsCILDescrshrun),\r\n (@RsCILNameneg, @RsCILCmdneg, @RsCILDescrneg),\r\n (@RsCILNamenot, @RsCILCmdnot, @RsCILDescrnot),\r\n (@RsCILNameconvi1, @RsCILCmdconvi1, @RsCILDescrconvi1),\r\n (@RsCILNameconvi2, @RsCILCmdconvi2, @RsCILDescrconvi2),\r\n (@RsCILNameconvi4, @RsCILCmdconvi4, @RsCILDescrconvi4),\r\n (@RsCILNameconvi8, @RsCILCmdconvi8, @RsCILDescrconvi8),\r\n (@RsCILNameconvr4, @RsCILCmdconvr4, @RsCILDescrconvr4),\r\n (@RsCILNameconvr8, @RsCILCmdconvr8, @RsCILDescrconvr8),\r\n (@RsCILNameconvu4, @RsCILCmdconvu4, @RsCILDescrconvu4),\r\n (@RsCILNameconvu8, @RsCILCmdconvu8, @RsCILDescrconvu8),\r\n (@RsCILNamecallvirt, @RsCILCmdcallvirt, @RsCILDescrcallvirt),\r\n (@RsCILNamecpobj, @RsCILCmdcpobj, @RsCILDescrcpobj),\r\n (@RsCILNameldobj, @RsCILCmdldobj, @RsCILDescrldobj),\r\n (@RsCILNameldstr, @RsCILCmdldstr, @RsCILDescrldstr),\r\n (@RsCILNamenewobj, @RsCILCmdnewobj, @RsCILDescrnewobj),\r\n (@RsCILNamecastclass, @RsCILCmdcastclass, @RsCILDescrcastclass),\r\n (@RsCILNameisinst, @RsCILCmdisinst, @RsCILDescrisinst),\r\n (@RsCILNameconvrun, @RsCILCmdconvrun, @RsCILDescrconvrun),\r\n (@RsCILNameunused2, @RsCILCmdunused2, @RsCILDescrunused2),\r\n (@RsCILNameunused3, @RsCILCmdunused3, @RsCILDescrunused3),\r\n (@RsCILNameunbox, @RsCILCmdunbox, @RsCILDescrunbox),\r\n (@RsCILNamethrow, @RsCILCmdthrow, @RsCILDescrthrow),\r\n (@RsCILNameldfld, @RsCILCmdldfld, @RsCILDescrldfld),\r\n (@RsCILNameldflda, @RsCILCmdldflda, @RsCILDescrldflda),\r\n (@RsCILNamestfld, @RsCILCmdstfld, @RsCILDescrstfld),\r\n (@RsCILNameldsfld, @RsCILCmdldsfld, @RsCILDescrldsfld),\r\n (@RsCILNameldsflda, @RsCILCmdldsflda, @RsCILDescrldsflda),\r\n (@RsCILNamestsfld, @RsCILCmdstsfld, @RsCILDescrstsfld),\r\n (@RsCILNamestobj, @RsCILCmdstobj, @RsCILDescrstobj),\r\n (@RsCILNameconvovfi1un, @RsCILCmdconvovfi1un, @RsCILDescrconvovfi1un),\r\n (@RsCILNameconvovfi2un, @RsCILCmdconvovfi2un, @RsCILDescrconvovfi2un),\r\n (@RsCILNameconvovfi4un, @RsCILCmdconvovfi4un, @RsCILDescrconvovfi4un),\r\n (@RsCILNameconvovfi8un, @RsCILCmdconvovfi8un, @RsCILDescrconvovfi8un),\r\n (@RsCILNameconvovfu1un, @RsCILCmdconvovfu1un, @RsCILDescrconvovfu1un),\r\n (@RsCILNameconvovfu2un, @RsCILCmdconvovfu2un, @RsCILDescrconvovfu2un),\r\n (@RsCILNameconvovfu4un, @RsCILCmdconvovfu4un, @RsCILDescrconvovfu4un),\r\n (@RsCILNameconvovfu8un, @RsCILCmdconvovfu8un, @RsCILDescrconvovfu8un),\r\n (@RsCILNameconvovfiun, @RsCILCmdconvovfiun, @RsCILDescrconvovfiun),\r\n (@RsCILNameconvovfuun, @RsCILCmdconvovfuun, @RsCILDescrconvovfuun),\r\n (@RsCILNamebox, @RsCILCmdbox, @RsCILDescrbox),\r\n (@RsCILNamenewarr, @RsCILCmdnewarr, @RsCILDescrnewarr),\r\n (@RsCILNameldlen, @RsCILCmdldlen, @RsCILDescrldlen),\r\n (@RsCILNameldelema, @RsCILCmdldelema, @RsCILDescrldelema),\r\n (@RsCILNameldelemi1, @RsCILCmdldelemi1, @RsCILDescrldelemi1),\r\n (@RsCILNameldelemu1, @RsCILCmdldelemu1, @RsCILDescrldelemu1),\r\n (@RsCILNameldelemi2, @RsCILCmdldelemi2, @RsCILDescrldelemi2),\r\n (@RsCILNameldelemu2, @RsCILCmdldelemu2, @RsCILDescrldelemu2),\r\n (@RsCILNameldelemi4, @RsCILCmdldelemi4, @RsCILDescrldelemi4),\r\n (@RsCILNameldelemu4, @RsCILCmdldelemu4, @RsCILDescrldelemu4),\r\n (@RsCILNameldelemi8, @RsCILCmdldelemi8, @RsCILDescrldelemi8),\r\n (@RsCILNameldelemi, @RsCILCmdldelemi, @RsCILDescrldelemi),\r\n (@RsCILNameldelemr4, @RsCILCmdldelemr4, @RsCILDescrldelemr4),\r\n (@RsCILNameldelemr8, @RsCILCmdldelemr8, @RsCILDescrldelemr8),\r\n (@RsCILNameldelemref, @RsCILCmdldelemref, @RsCILDescrldelemref),\r\n (@RsCILNamestelemi, @RsCILCmdstelemi, @RsCILDescrstelemi),\r\n (@RsCILNamestelemi1, @RsCILCmdstelemi1, @RsCILDescrstelemi1),\r\n (@RsCILNamestelemi2, @RsCILCmdstelemi2, @RsCILDescrstelemi2),\r\n (@RsCILNamestelemi4, @RsCILCmdstelemi4, @RsCILDescrstelemi4),\r\n (@RsCILNamestelemi8, @RsCILCmdstelemi8, @RsCILDescrstelemi8),\r\n (@RsCILNamestelemr4, @RsCILCmdstelemr4, @RsCILDescrstelemr4),\r\n (@RsCILNamestelemr8, @RsCILCmdstelemr8, @RsCILDescrstelemr8),\r\n (@RsCILNamestelemref, @RsCILCmdstelemref, @RsCILDescrstelemref),\r\n (@RsCILNameunused4, @RsCILCmdunused4, @RsCILDescrunused4),\r\n (@RsCILNameunused5, @RsCILCmdunused5, @RsCILDescrunused5),\r\n (@RsCILNameunused6, @RsCILCmdunused6, @RsCILDescrunused6),\r\n (@RsCILNameunused7, @RsCILCmdunused7, @RsCILDescrunused7),\r\n (@RsCILNameunused8, @RsCILCmdunused8, @RsCILDescrunused8),\r\n (@RsCILNameunused9, @RsCILCmdunused9, @RsCILDescrunused9),\r\n (@RsCILNameunused10, @RsCILCmdunused10, @RsCILDescrunused10),\r\n (@RsCILNameunused11, @RsCILCmdunused11, @RsCILDescrunused11),\r\n (@RsCILNameunused12, @RsCILCmdunused12, @RsCILDescrunused12),\r\n (@RsCILNameunused13, @RsCILCmdunused13, @RsCILDescrunused13),\r\n (@RsCILNameunused14, @RsCILCmdunused14, @RsCILDescrunused14),\r\n (@RsCILNameunused15, @RsCILCmdunused15, @RsCILDescrunused15),\r\n (@RsCILNameunused16, @RsCILCmdunused16, @RsCILDescrunused16),\r\n (@RsCILNameunused17, @RsCILCmdunused17, @RsCILDescrunused17),\r\n (@RsCILNameunused18, @RsCILCmdunused18, @RsCILDescrunused18),\r\n (@RsCILNameunused19, @RsCILCmdunused19, @RsCILDescrunused19),\r\n (@RsCILNameconvovfi1, @RsCILCmdconvovfi1, @RsCILDescrconvovfi1),\r\n (@RsCILNameconvovfu1, @RsCILCmdconvovfu1, @RsCILDescrconvovfu1),\r\n (@RsCILNameconvovfi2, @RsCILCmdconvovfi2, @RsCILDescrconvovfi2),\r\n (@RsCILNameconvovfu2, @RsCILCmdconvovfu2, @RsCILDescrconvovfu2),\r\n (@RsCILNameconvovfi4, @RsCILCmdconvovfi4, @RsCILDescrconvovfi4),\r\n (@RsCILNameconvovfu4, @RsCILCmdconvovfu4, @RsCILDescrconvovfu4),\r\n (@RsCILNameconvovfi8, @RsCILCmdconvovfi8, @RsCILDescrconvovfi8),\r\n (@RsCILNameconvovfu8, @RsCILCmdconvovfu8, @RsCILDescrconvovfu8),\r\n (@RsCILNameunused20, @RsCILCmdunused20, @RsCILDescrunused20),\r\n (@RsCILNameunused21, @RsCILCmdunused21, @RsCILDescrunused21),\r\n (@RsCILNameunused22, @RsCILCmdunused22, @RsCILDescrunused22),\r\n (@RsCILNameunused23, @RsCILCmdunused23, @RsCILDescrunused23),\r\n (@RsCILNameunused24, @RsCILCmdunused24, @RsCILDescrunused24),\r\n (@RsCILNameunused25, @RsCILCmdunused25, @RsCILDescrunused25),\r\n (@RsCILNameunused26, @RsCILCmdunused26, @RsCILDescrunused26),\r\n (@RsCILNamerefanyval, @RsCILCmdrefanyval, @RsCILDescrrefanyval),\r\n (@RsCILNameckfinite, @RsCILCmdckfinite, @RsCILDescrckfinite),\r\n (@RsCILNameunused27, @RsCILCmdunused27, @RsCILDescrunused27),\r\n (@RsCILNameunused28, @RsCILCmdunused28, @RsCILDescrunused28),\r\n (@RsCILNamemkrefany, @RsCILCmdmkrefany, @RsCILDescrmkrefany),\r\n (@RsCILNameunused29, @RsCILCmdunused29, @RsCILDescrunused29),\r\n (@RsCILNameunused30, @RsCILCmdunused30, @RsCILDescrunused30),\r\n (@RsCILNameunused31, @RsCILCmdunused31, @RsCILDescrunused31),\r\n (@RsCILNameunused32, @RsCILCmdunused32, @RsCILDescrunused32),\r\n (@RsCILNameunused33, @RsCILCmdunused33, @RsCILDescrunused33),\r\n (@RsCILNameunused34, @RsCILCmdunused34, @RsCILDescrunused34),\r\n (@RsCILNameunused35, @RsCILCmdunused35, @RsCILDescrunused35),\r\n (@RsCILNameunused36, @RsCILCmdunused36, @RsCILDescrunused36),\r\n (@RsCILNameunused37, @RsCILCmdunused37, @RsCILDescrunused37),\r\n (@RsCILNameldtoken, @RsCILCmdldtoken, @RsCILDescrldtoken),\r\n (@RsCILNameconvu2, @RsCILCmdconvu2, @RsCILDescrconvu2),\r\n (@RsCILNameconvu1, @RsCILCmdconvu1, @RsCILDescrconvu1),\r\n (@RsCILNameconvi, @RsCILCmdconvi, @RsCILDescrconvi),\r\n (@RsCILNameconvovfi, @RsCILCmdconvovfi, @RsCILDescrconvovfi),\r\n (@RsCILNameconvovfu, @RsCILCmdconvovfu, @RsCILDescrconvovfu),\r\n (@RsCILNameaddovf, @RsCILCmdaddovf, @RsCILDescraddovf),\r\n (@RsCILNameaddovfun, @RsCILCmdaddovfun, @RsCILDescraddovfun),\r\n (@RsCILNamemulovf, @RsCILCmdmulovf, @RsCILDescrmulovf),\r\n (@RsCILNamemulovfun, @RsCILCmdmulovfun, @RsCILDescrmulovfun),\r\n (@RsCILNamesubovf, @RsCILCmdsubovf, @RsCILDescrsubovf),\r\n (@RsCILNamesubovfun, @RsCILCmdsubovfun, @RsCILDescrsubovfun),\r\n (@RsCILNameendfinally, @RsCILCmdendfinally, @RsCILDescrendfinally),\r\n (@RsCILNameleave, @RsCILCmdleave, @RsCILDescrleave),\r\n (@RsCILNameleaves, @RsCILCmdleaves, @RsCILDescrleaves),\r\n (@RsCILNamestindi, @RsCILCmdstindi, @RsCILDescrstindi),\r\n (@RsCILNameconvu, @RsCILCmdconvu, @RsCILDescrconvu),\r\n (@RsCILNameunused38, @RsCILCmdunused38, @RsCILDescrunused38),\r\n (@RsCILNameunused39, @RsCILCmdunused39, @RsCILDescrunused39),\r\n (@RsCILNameunused40, @RsCILCmdunused40, @RsCILDescrunused40),\r\n (@RsCILNameunused41, @RsCILCmdunused41, @RsCILDescrunused41),\r\n (@RsCILNameunused42, @RsCILCmdunused42, @RsCILDescrunused42),\r\n (@RsCILNameunused43, @RsCILCmdunused43, @RsCILDescrunused43),\r\n (@RsCILNameunused44, @RsCILCmdunused44, @RsCILDescrunused44),\r\n (@RsCILNameunused45, @RsCILCmdunused45, @RsCILDescrunused45),\r\n (@RsCILNameunused46, @RsCILCmdunused46, @RsCILDescrunused46),\r\n (@RsCILNameunused47, @RsCILCmdunused47, @RsCILDescrunused47),\r\n (@RsCILNameunused48, @RsCILCmdunused48, @RsCILDescrunused48),\r\n (@RsCILNameunused49, @RsCILCmdunused49, @RsCILDescrunused49),\r\n (@RsCILNameunused50, @RsCILCmdunused50, @RsCILDescrunused50),\r\n (@RsCILNameunused51, @RsCILCmdunused51, @RsCILDescrunused51),\r\n (@RsCILNameunused52, @RsCILCmdunused52, @RsCILDescrunused52),\r\n (@RsCILNameunused53, @RsCILCmdunused53, @RsCILDescrunused53),\r\n (@RsCILNameunused54, @RsCILCmdunused54, @RsCILDescrunused54),\r\n (@RsCILNameunused55, @RsCILCmdunused55, @RsCILDescrunused55),\r\n (@RsCILNameunused56, @RsCILCmdunused56, @RsCILDescrunused56),\r\n (@RsCILNameunused57, @RsCILCmdunused57, @RsCILDescrunused57),\r\n (@RsCILNameunused58, @RsCILCmdunused58, @RsCILDescrunused58),\r\n (@RsCILNameunused59, @RsCILCmdunused59, @RsCILDescrunused59),\r\n (@RsCILNameunused60, @RsCILCmdunused60, @RsCILDescrunused60),\r\n (@RsCILNameprefix7, @RsCILCmdprefix7, @RsCILDescrprefix7),\r\n (@RsCILNameprefix6, @RsCILCmdprefix6, @RsCILDescrprefix6),\r\n (@RsCILNameprefix5, @RsCILCmdprefix5, @RsCILDescrprefix5),\r\n (@RsCILNameprefix4, @RsCILCmdprefix4, @RsCILDescrprefix4),\r\n (@RsCILNameprefix3, @RsCILCmdprefix3, @RsCILDescrprefix3),\r\n (@RsCILNameprefix2, @RsCILCmdprefix2, @RsCILDescrprefix2),\r\n (@RsCILNameprefix1, @RsCILCmdprefix1, @RsCILDescrprefix1),\r\n (@RsCILNameprefixref, @RsCILCmdprefixref, @RsCILDescrprefixref),\r\n\r\n (@RsCILNamearglist, @RsCILCmdarglist, @RsCILDescrarglist),\r\n (@RsCILNameceq, @RsCILCmdceq, @RsCILDescrceq),\r\n (@RsCILNamecgt, @RsCILCmdcgt, @RsCILDescrcgt),\r\n (@RsCILNamecgtun, @RsCILCmdcgtun, @RsCILDescrcgtun),\r\n (@RsCILNameclt, @RsCILCmdclt, @RsCILDescrclt),\r\n (@RsCILNamecltun, @RsCILCmdcltun, @RsCILDescrcltun),\r\n (@RsCILNameldftn, @RsCILCmdldftn, @RsCILDescrldftn),\r\n (@RsCILNameldvirtftn, @RsCILCmdldvirtftn, @RsCILDescrldvirtftn),\r\n (@RsCILNameunused61, @RsCILCmdunused61, @RsCILDescrunused61),\r\n (@RsCILNameldarg, @RsCILCmdldarg, @RsCILDescrldarg),\r\n (@RsCILNameldarga, @RsCILCmdldarga, @RsCILDescrldarga),\r\n (@RsCILNamestarg, @RsCILCmdstarg, @RsCILDescrstarg),\r\n (@RsCILNameldloc, @RsCILCmdldloc, @RsCILDescrldloc),\r\n (@RsCILNameldloca, @RsCILCmdldloca, @RsCILDescrldloca),\r\n (@RsCILNamestloc, @RsCILCmdstloc, @RsCILDescrstloc),\r\n (@RsCILNamelocalloc, @RsCILCmdlocalloc, @RsCILDescrlocalloc),\r\n (@RsCILNameunused62, @RsCILCmdunused62, @RsCILDescrunused62),\r\n (@RsCILNameendfilter, @RsCILCmdendfilter, @RsCILDescrendfilter),\r\n (@RsCILNameunaligned, @RsCILCmdunaligned, @RsCILDescrunaligned),\r\n (@RsCILNamevolatile, @RsCILCmdvolatile, @RsCILDescrvolatile),\r\n (@RsCILNametail, @RsCILCmdtail, @RsCILDescrtail),\r\n (@RsCILNameinitobj, @RsCILCmdinitobj, @RsCILDescrinitobj),\r\n (@RsCILNameunused63, @RsCILCmdunused63, @RsCILDescrunused63),\r\n (@RsCILNamecpblk, @RsCILCmdcpblk, @RsCILDescrcpblk),\r\n (@RsCILNameinitblk, @RsCILCmdinitblk, @RsCILDescrinitblk),\r\n (@RsCILNameunused64, @RsCILCmdunused64, @RsCILDescrunused64),\r\n (@RsCILNamerethrow, @RsCILCmdrethrow, @RsCILDescrrethrow),\r\n (@RsCILNameunused65, @RsCILCmdunused65, @RsCILDescrunused65),\r\n (@RsCILNamesizeof, @RsCILCmdsizeof, @RsCILDescrsizeof),\r\n (@RsCILNamerefanytype, @RsCILCmdrefanytype, @RsCILDescrrefanytype),\r\n (@RsCILNameunused66, @RsCILCmdunused66, @RsCILDescrunused66),\r\n (@RsCILNameunused67, @RsCILCmdunused67, @RsCILDescrunused67),\r\n (@RsCILNameunused68, @RsCILCmdunused68, @RsCILDescrunused68),\r\n (@RsCILNameunused69, @RsCILCmdunused69, @RsCILDescrunused69),\r\n (@RsCILNameunused70, @RsCILCmdunused70, @RsCILDescrunused70)\r\n );\r\n\r\n OpCodeParamTypes: array [TJclOpCode] of TJclInstructionParamType =\r\n (ptVoid, ptVoid, ptVoid, ptVoid, ptVoid, ptVoid, ptVoid, ptVoid, {00}\r\n ptVoid, ptVoid, ptVoid, ptVoid, ptVoid, ptVoid, ptU1, ptU1, {08}\r\n ptU1, ptU1, ptU1, ptU1, ptVoid, ptVoid, ptVoid, ptVoid, {10}\r\n ptVoid, ptVoid, ptVoid, ptVoid, ptVoid, ptVoid, ptVoid, ptI1, {18}\r\n ptI4, ptI8, ptR4, ptR8, ptVoid, ptVoid, ptVoid, ptToken, {20}\r\n ptToken, ptVoid, ptVoid, ptSOff, ptSOff, ptSOff, ptSOff, ptSOff, {28}\r\n ptSOff, ptSOff, ptSOff, ptSOff, ptSOff, ptSOff, ptSOff, ptSOff, {30}\r\n ptLOff, ptLOff, ptLOff, ptLOff, ptLOff, ptLOff, ptLOff, ptLOff, {38}\r\n ptLOff, ptLOff, ptLOff, ptLOff, ptLOff, ptVoid, ptVoid, ptVoid, {40}\r\n ptVoid, ptVoid, ptVoid, ptVoid, ptVoid, ptVoid, ptVoid, ptVoid, {48}\r\n ptVoid, ptVoid, ptVoid, ptVoid, ptVoid, ptVoid, ptVoid, ptVoid, {50}\r\n ptVoid, ptVoid, ptVoid, ptVoid, ptVoid, ptVoid, ptVoid, ptVoid, {58}\r\n ptVoid, ptVoid, ptVoid, ptVoid, ptVoid, ptVoid, ptVoid, ptVoid, {60}\r\n ptVoid, ptVoid, ptVoid, ptVoid, ptVoid, ptVoid, ptVoid, ptToken, {68}\r\n ptToken, ptToken, ptToken, ptToken, ptToken, ptToken, ptVoid, ptVoid, {70}\r\n ptVoid, ptToken, ptVoid, ptToken, ptToken, ptToken, ptToken, ptToken, {78}\r\n ptToken, ptToken, ptVoid, ptVoid, ptVoid, ptVoid, ptVoid, ptVoid, {80}\r\n ptVoid, ptVoid, ptVoid, ptVoid, ptToken, ptToken, ptVoid, ptToken, {88}\r\n ptVoid, ptVoid, ptVoid, ptVoid, ptVoid, ptVoid, ptVoid, ptVoid, {90}\r\n ptVoid, ptVoid, ptVoid, ptVoid, ptVoid, ptVoid, ptVoid, ptVoid, {98}\r\n ptVoid, ptVoid, ptVoid, ptVoid, ptVoid, ptVoid, ptVoid, ptVoid, {A0}\r\n ptVoid, ptVoid, ptVoid, ptVoid, ptVoid, ptVoid, ptVoid, ptVoid, {A8}\r\n ptVoid, ptVoid, ptVoid, ptVoid, ptVoid, ptVoid, ptVoid, ptVoid, {B0}\r\n ptVoid, ptVoid, ptVoid, ptVoid, ptVoid, ptVoid, ptVoid, ptVoid, {B8}\r\n ptVoid, ptVoid, ptToken, ptVoid, ptVoid, ptVoid, ptToken, ptVoid, {C0}\r\n ptVoid, ptVoid, ptVoid, ptVoid, ptVoid, ptVoid, ptVoid, ptVoid, {C8}\r\n ptToken, ptVoid, ptVoid, ptVoid, ptVoid, ptVoid, ptVoid, ptVoid, {D0}\r\n ptVoid, ptVoid, ptVoid, ptVoid, ptVoid, ptI4, ptI1, ptVoid, {D8}\r\n ptVoid, ptVoid, ptVoid, ptVoid, ptVoid, ptVoid, ptVoid, ptVoid, {E0}\r\n ptVoid, ptVoid, ptVoid, ptVoid, ptVoid, ptVoid, ptVoid, ptVoid, {E8}\r\n ptVoid, ptVoid, ptVoid, ptVoid, ptVoid, ptVoid, ptVoid, ptVoid, {F0}\r\n ptVoid, ptVoid, ptVoid, ptVoid, ptVoid, ptVoid, ptVoid, ptVoid, {F8}\r\n ptVoid, ptVoid, ptVoid, ptVoid, ptVoid, ptVoid, ptToken, ptToken, {00}\r\n ptVoid, ptU2, ptU2, ptU2, ptU2, ptU2, ptU2, ptVoid, {08}\r\n ptVoid, ptVoid, ptI1, ptVoid, ptVoid, ptToken, ptVoid, ptVoid, {10}\r\n ptVoid, ptVoid, ptVoid, ptVoid, ptToken, ptVoid, ptVoid, ptVoid, {18}\r\n ptVoid, ptVoid, ptVoid); {20}\r\n\r\n//=== { TJclClrILGenerator } ================================================\r\n\r\nconstructor TJclClrILGenerator.Create(AMethod: TJclClrMethodBody = nil);\r\nvar\r\n OpCode: Byte;\r\n Stream: TMemoryStream;\r\n Instruction: TJclInstruction;\r\nbegin\r\n inherited Create;\r\n FMethod := AMethod;\r\n FInstructions := TObjectList.Create;\r\n if Assigned(AMethod) then\r\n begin\r\n Stream := TMemoryStream.Create;\r\n try\r\n Stream.Write(Method.Code^, Method.Size);\r\n Stream.Seek(0, soFromBeginning);\r\n while Stream.Position < Stream.Size do\r\n begin\r\n OpCode := PByte(PAnsiChar(Stream.Memory) + Stream.Position)^;\r\n if OpCode = STP1 then\r\n begin\r\n OpCode := PByte(PAnsiChar(Stream.Memory) + Stream.Position + 1)^;\r\n Instruction := TJclInstruction.Create(Self, TJclOpCode(MaxByte + 1 + OpCode));\r\n end\r\n else\r\n Instruction := TJclInstruction.Create(Self, TJclOpCode(OpCode));\r\n if Assigned(Instruction) then\r\n begin\r\n FInstructions.Add(Instruction);\r\n Instruction.Load(Stream);\r\n end;\r\n end;\r\n finally\r\n FreeAndNil(Stream);\r\n end;\r\n end;\r\nend;\r\n\r\ndestructor TJclClrILGenerator.Destroy;\r\nbegin\r\n FreeAndNil(FInstructions);\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJclClrILGenerator.DumpIL(Options: TJclInstructionDumpILOptions): string;\r\nvar\r\n I, J, Indent: Integer;\r\n\r\n function FlagsToName(Flags: TJclClrExceptionClauseFlags): string;\r\n begin\r\n if cfFinally in Flags then\r\n Result := 'finally'\r\n else\r\n if cfFilter in Flags then\r\n Result := 'filter'\r\n else\r\n if cfFault in Flags then\r\n Result := 'fault'\r\n else\r\n Result := 'catch';\r\n end;\r\n\r\n function IndentStr: string;\r\n begin\r\n Result := StrRepeat(' ', Indent);\r\n end;\r\n\r\nbegin\r\n Indent := 0;\r\n with TStringList.Create do\r\n try\r\n for I := 0 to InstructionCount-1 do\r\n begin\r\n for J := 0 to Method.ExceptionHandlerCount-1 do\r\n with Method.ExceptionHandlers[J] do\r\n begin\r\n if Instructions[I].Offset = TryBlock.Offset then\r\n begin\r\n Add(IndentStr + '.try');\r\n Add(IndentStr + '{');\r\n Inc(Indent);\r\n end;\r\n if Instructions[I].Offset = (TryBlock.Offset + TryBlock.Length) then\r\n begin\r\n Dec(Indent);\r\n Add(IndentStr + '} // end .try');\r\n end;\r\n if Instructions[I].Offset = HandlerBlock.Offset then\r\n begin\r\n Add(IndentStr + FlagsToName(Flags));\r\n Add(IndentStr + '{');\r\n Inc(Indent);\r\n end;\r\n if Instructions[I].Offset = (HandlerBlock.Offset + HandlerBlock.Length) then\r\n begin\r\n Dec(Indent);\r\n Add(IndentStr + '} // end ' + FlagsToName(Flags));\r\n end;\r\n end;\r\n Add(IndentStr + Instructions[I].DumpIL(Options));\r\n end;\r\n Result := Text;\r\n finally\r\n Free;\r\n end;\r\nend;\r\n\r\nfunction TJclClrILGenerator.GetInstructionCount: Integer;\r\nbegin\r\n Result := FInstructions.Count;\r\nend;\r\n\r\nfunction TJclClrILGenerator.GetInstruction(const Idx: Integer): TJclInstruction;\r\nbegin\r\n Result := TJclInstruction(FInstructions[Idx]);\r\nend;\r\n\r\n//=== { TJclInstruction } ====================================================\r\n\r\nconstructor TJclInstruction.Create(AOwner :TJclClrILGenerator; AOpCode: TJclOpCode);\r\nbegin\r\n inherited Create;\r\n FOwner := AOwner;\r\n FOpCode := AOpCode;\r\nend;\r\n\r\nfunction TJclInstruction.GetWideOpCode: Boolean;\r\nbegin\r\n Result := Integer(OpCode) > MaxByte;\r\nend;\r\n\r\nfunction TJclInstruction.GetRealOpCode: Byte;\r\nbegin\r\n if WideOpCode then\r\n Result := Integer(OpCode) mod (MaxByte + 1)\r\n else\r\n Result := Integer(OpCode);\r\nend;\r\n\r\nfunction TJclInstruction.GetParamType: TJclInstructionParamType;\r\nbegin\r\n Result := OpCodeParamTypes[OpCode];\r\nend;\r\n\r\nfunction TJclInstruction.GetName: string;\r\nbegin\r\n Result := LoadResString(OpCodeInfos[OpCode, itName]);\r\nend;\r\n\r\nfunction TJclInstruction.GetFullName: string;\r\nbegin\r\n Result := LoadResString(OpCodeInfos[OpCode, itFullName]);\r\nend;\r\n\r\nfunction TJclInstruction.GetDescription: string;\r\nbegin\r\n Result := LoadResString(OpCodeInfos[OpCode, itDescription])\r\nend;\r\n\r\nfunction TJclInstruction.GetSize: DWORD;\r\nconst\r\n OpCodeSize: array [Boolean] of DWORD = (1, 2);\r\nbegin\r\n case ParamType of\r\n ptSOff, ptI1, ptU1:\r\n Result := SizeOf(Byte);\r\n ptI2, ptU2:\r\n Result := SizeOf(Word);\r\n ptLOff, ptI4, ptToken, ptU4, ptR4:\r\n Result := SizeOf(DWORD);\r\n ptI8, ptU8, ptR8:\r\n Result := SizeOf(Int64);\r\n ptArray:\r\n Result := (VarArrayHighBound(FParam, 1) - VarArrayLowBound(FParam, 1) + 1 + 1) * SizeOf(Integer);\r\n else\r\n Result := 0;\r\n end;\r\n Inc(Result, OpCodeSize[OpCode in [opNop..opPrefixRef]]);\r\nend;\r\n\r\nprocedure TJclInstruction.Load(Stream: TStream);\r\nvar\r\n Code: Byte;\r\n I, ArraySize: DWORD; { TODO : I, ArraySize = DWORD create a serious problem }\r\n Value: Integer;\r\nbegin\r\n FOffset := Stream.Position;\r\n try\r\n Code := 0;\r\n Stream.Read(Code, SizeOf(Code));\r\n if WideOpCode then\r\n begin\r\n if Code <> STP1 then\r\n raise EJclCliInstructionStreamInvalid.CreateRes(@RsInstructionStreamInvalid);\r\n Stream.Read(Code, SizeOf(Code));\r\n end;\r\n\r\n if Code <> RealOpCode then\r\n raise EJclCliInstructionStreamInvalid.CreateRes(@RsInstructionStreamInvalid);\r\n\r\n with TVarData(FParam) do\r\n case ParamType of\r\n ptU1:\r\n begin\r\n Stream.Read(VByte, SizeOf(Byte));\r\n VType := varByte;\r\n end;\r\n ptI2:\r\n begin\r\n Stream.Read(VSmallInt, SizeOf(SmallInt));\r\n VType := varSmallInt;\r\n end;\r\n ptLOff, ptI4:\r\n begin\r\n Stream.Read(VInteger, SizeOf(Integer));\r\n VType := varInteger;\r\n end;\r\n ptR4:\r\n begin\r\n Stream.Read(VSingle, SizeOf(Single));\r\n VType := varSingle;\r\n end;\r\n ptR8: \r\n begin\r\n Stream.Read(VDouble, SizeOf(Double));\r\n VType := varDouble;\r\n end;\r\n ptArray:\r\n begin\r\n ArraySize := 0;\r\n Stream.Read(ArraySize, SizeOf(ArraySize));\r\n FParam := VarArrayCreate([0, ArraySize-1], varInteger);\r\n for I := 0 to ArraySize-1 do { TODO : ArraySize = 0 and we have a nearly endless loop }\r\n begin\r\n Value := 0;\r\n Stream.Read(Value, SizeOf(Value));\r\n FParam[I] := Value;\r\n end;\r\n end;\r\n ptSOff, ptI1:\r\n begin\r\n Stream.Read(VShortInt, SizeOf(ShortInt));\r\n VType := varShortInt;\r\n end;\r\n ptU2:\r\n begin\r\n Stream.Read(VWord, SizeOf(Word));\r\n VType := varWord;\r\n end;\r\n ptToken, ptU4:\r\n begin\r\n Stream.Read(VLongWord, SizeOf(LongWord));\r\n VType := varLongWord;\r\n end;\r\n ptI8, ptU8:\r\n begin\r\n Stream.Read(VInt64, SizeOf(Int64));\r\n VType := varInt64;\r\n end;\r\n end;\r\n except\r\n Stream.Position := FOffset;\r\n raise;\r\n end;\r\nend;\r\n\r\nprocedure TJclInstruction.Save(Stream: TStream);\r\nvar\r\n Code: Byte;\r\n ArraySize: DWORD;\r\n I, Value: Integer;\r\nbegin\r\n if WideOpCode then\r\n begin\r\n Code := STP1;\r\n Stream.Write(Code, SizeOf(Code));\r\n end;\r\n\r\n Code := RealOpCode;;\r\n Stream.Write(Code, SizeOf(Code));\r\n\r\n case ParamType of\r\n ptU1:\r\n Stream.Write(TVarData(FParam).VByte, SizeOf(Byte));\r\n ptI2:\r\n Stream.Write(TVarData(FParam).VSmallInt, SizeOf(SmallInt));\r\n ptLOff, ptI4:\r\n Stream.Write(TVarData(FParam).VInteger, SizeOf(Integer));\r\n ptR4:\r\n Stream.Write(TVarData(FParam).VSingle, SizeOf(Single));\r\n ptR8:\r\n Stream.Write(TVarData(FParam).VDouble, SizeOf(Double));\r\n ptSOff, ptI1:\r\n Stream.Write(TVarData(FParam).VShortInt, SizeOf(ShortInt));\r\n ptU2:\r\n Stream.Write(TVarData(FParam).VWord, SizeOf(Word));\r\n ptToken, ptU4:\r\n Stream.Write(TVarData(FParam).VLongWord, SizeOf(LongWord));\r\n ptI8, ptU8:\r\n Stream.Write(TVarData(FParam).VInt64, SizeOf(Int64));\r\n ptArray:\r\n begin\r\n ArraySize := VarArrayHighBound(FParam, 1) - VarArrayLowBound(FParam, 1) + 1;\r\n Stream.Write(ArraySize, SizeOf(ArraySize));\r\n { TODO : VarArrayHighBound to VarArrayLowBound very likely wrong }\r\n for I := VarArrayHighBound(FParam, 1) to VarArrayLowBound(FParam, 1) do\r\n begin\r\n Value := VarArrayGet(FParam, [I]);\r\n Stream.Write(Value, SizeOf(Value));\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJclInstruction.DumpIL(Options: TJclInstructionDumpILOptions): string;\r\nvar\r\n Opt: TJclInstructionDumpILOption;\r\nbegin\r\n if doLineNo in Options then\r\n Result := DumpILOption(doLineNo) + ': ';\r\n if doRawBytes in Options then\r\n Result := Result + Format(' /* %.24s */ ', [DumpILOption(doRawBytes)]);\r\n for Opt := doIL to doTokenValue do\r\n Result := Result + DumpILOption(Opt) + ' ';\r\n if (doComment in Options) and ((FullName <> '') or (Description <> '')) then\r\n Result := Result + ' // ' + DumpILOption(doComment);\r\nend;\r\n\r\nfunction TJclInstruction.FormatLabel(Offset: Integer): string;\r\nbegin\r\n Result := 'IL_' + IntToHex(Offset, 4);\r\nend;\r\n\r\nfunction TJclInstruction.DumpILOption(Option: TJclInstructionDumpILOption): string;\r\n\r\n function TokenToString(Token: DWORD): string;\r\n begin\r\n Result := '(' + IntToHex(Token shr 24, 2) + ')' + IntToHex(Token mod (1 shl 24), 6);\r\n end;\r\n\r\nvar\r\n I: Integer;\r\n Row: TJclClrTableRow;\r\n CodeStr, ParamStr: string;\r\nbegin\r\n case Option of\r\n doLineNo:\r\n Result := 'IL_' + IntToHex(Offset, 4);\r\n doRawBytes:\r\n begin\r\n if WideOpCode then\r\n CodeStr := IntToHex(STP1, 2);\r\n\r\n CodeStr := CodeStr + IntToHex(RealOpCode, 2);\r\n CodeStr := CodeStr + StrRepeat(' ', 4 - Length(CodeStr));\r\n\r\n case ParamType of\r\n ptSOff, ptI1, ptU1:\r\n ParamStr := IntToHex(TVarData(FParam).VByte, 2);\r\n ptArray:\r\n ParamStr := 'Array';\r\n ptI2, ptU2:\r\n ParamStr := IntToHex(TVarData(FParam).VWord, 4);\r\n ptLOff, ptI4, ptU4, ptR4:\r\n ParamStr := IntToHex(TVarData(FParam).VLongWord, 8);\r\n ptI8, ptU8, ptR8:\r\n ParamStr := IntToHex(TVarData(FParam).VInt64, 16);\r\n ptToken:\r\n ParamStr := TokenToString(TVarData(FParam).VLongWord);\r\n else\r\n ParamStr := '';\r\n end;\r\n ParamStr := ParamStr + StrRepeat(' ', 10 - Length(ParamStr));\r\n Result := CodeStr + ' | ' + ParamStr;\r\n end;\r\n doIL:\r\n begin\r\n case ParamType of\r\n ptVoid:\r\n ; // do nothing\r\n ptLOff:\r\n Result := FormatLabel(Integer(Offset) + + Integer(Size) + TVarData(Param).VInteger - 1);\r\n ptToken:\r\n begin\r\n if Byte(TJclPeMetadata.TokenTable(TVarData(Param).VLongWord)) = $70 then\r\n Result := '\"' + Owner.Method.Method.Table.Stream.Metadata.UserStringAt(TJclPeMetadata.TokenIndex(TVarData(Param).VLongWord)) + '\"'\r\n else\r\n begin\r\n Row := Owner.Method.Method.Table.Stream.Metadata.Tokens[TVarData(Param).VLongWord];\r\n if Assigned(Row) then\r\n begin\r\n if Row is TJclClrTableTypeDefRow then\r\n Result := TJclClrTableTypeDefRow(Row).FullName\r\n else\r\n if Row is TJclClrTableTypeRefRow then\r\n with TJclClrTableTypeRefRow(Row) do\r\n Result := FullName\r\n else\r\n if Row is TJclClrTableMethodDefRow then\r\n with TJclClrTableMethodDefRow(Row) do\r\n Result := ParentToken.FullName + '.' + Name\r\n else\r\n if Row is TJclClrTableMemberRefRow then\r\n with TJclClrTableMemberRefRow(Row) do\r\n Result := FullName\r\n else\r\n if Row is TJclClrTableFieldDefRow then\r\n with TJclClrTableFieldDefRow(Row) do\r\n Result := ParentToken.FullName + '.' + Name\r\n else\r\n Result := Row.DumpIL;\r\n end\r\n else\r\n Result := '';\r\n end;\r\n Result := Result + ' /* ' + IntToHex(TVarData(FParam).VLongWord, 8) + ' */';\r\n end;\r\n ptSOff:\r\n Result := FormatLabel(Integer(Offset + Size) + TVarData(Param).VShortInt - 1);\r\n ptArray:\r\n begin\r\n for I := VarArrayHighBound(FParam, 1) to VarArrayLowBound(FParam, 1) do\r\n begin\r\n Result := Result + FormatLabel(Offset + Size + VarArrayGet(FParam, [I]));\r\n if I <> VarArrayLowBound(FParam, 1) then\r\n Result := Result + ', ';\r\n end;\r\n Result := ' (' + Result + ')';\r\n end;\r\n else\r\n Result := VarToStr(Param);\r\n end;\r\n Result := GetName + StrRepeat(' ', 10 - Length(GetName)) + ' ' + Result;\r\n Result := Result + StrRepeat(' ', 20 - Length(Result));\r\n end;\r\n doTokenValue:\r\n Result := ''; // do nothing\r\n doComment:\r\n if FullName = '' then\r\n Result := Description\r\n else\r\n if Description = '' then\r\n Result := FullName\r\n else\r\n Result := FullName + ' - ' + Description;\r\n end;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jcl/source/windows/JclCLR.pas", "content": "{**************************************************************************************************}\r\n{ }\r\n{ Project JEDI Code Library (JCL) }\r\n{ }\r\n{ The contents of this file are subject to the Mozilla Public License Version 1.1 (the \"License\"); }\r\n{ you may not use this file except in compliance with the License. You may obtain a copy of the }\r\n{ License at http://www.mozilla.org/MPL/ }\r\n{ }\r\n{ Software distributed under the License is distributed on an \"AS IS\" basis, WITHOUT WARRANTY OF }\r\n{ ANY KIND, either express or implied. See the License for the specific language governing rights }\r\n{ and limitations under the License. }\r\n{ }\r\n{ The Original Code is JclCLR.pas. }\r\n{ }\r\n{ The Initial Developer of the Original Code is Flier Lu (). }\r\n{ Portions created by Flier Lu are Copyright (C) Flier Lu. All Rights Reserved. }\r\n{ }\r\n{ Contributors: }\r\n{ Flier Lu (flier) }\r\n{ Robert Marquardt (marquardt) }\r\n{ Olivier Sannier (obones) }\r\n{ Petr Vones (pvones) }\r\n{ }\r\n{**************************************************************************************************}\r\n{ }\r\n{ Microsoft .Net framework Clr information support routines and classes. }\r\n{ }\r\n{**************************************************************************************************}\r\n{ }\r\n{ Last modified: $Date:: 2011-09-03 00:07:50 +0200 (sam. 03 sept. 2011) $ }\r\n{ Revision: $Rev:: 3599 $ }\r\n{ Author: $Author:: outchy $ }\r\n{ }\r\n{**************************************************************************************************}\r\n\r\nunit JclCLR;\r\n\r\ninterface\r\n\r\n{$I jcl.inc}\r\n{$I windowsonly.inc}\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n {$IFDEF HAS_UNITSCOPE}\r\n {$IFDEF MSWINDOWS}\r\n Winapi.Windows,\r\n {$ENDIF MSWINDOWS}\r\n System.Classes, System.SysUtils, System.Contnrs,\r\n {$ELSE ~HAS_UNITSCOPE}\r\n {$IFDEF MSWINDOWS}\r\n Windows,\r\n {$ENDIF MSWINDOWS}\r\n Classes, SysUtils, Contnrs,\r\n {$ENDIF ~HAS_UNITSCOPE}\r\n JclBase, JclFileUtils, JclStrings, JclPeImage, JclSysUtils;\r\n\r\ntype\r\n _IMAGE_COR_VTABLEFIXUP = packed record\r\n RVA: DWORD; // Offset of v-table array in image.\r\n Count: Word; // How many entries at location.\r\n Kind: Word; // COR_VTABLE_xxx type of entries.\r\n end;\r\n IMAGE_COR_VTABLEFIXUP = _IMAGE_COR_VTABLEFIXUP;\r\n TImageCorVTableFixup = _IMAGE_COR_VTABLEFIXUP;\r\n PImageCorVTableFixup = ^TImageCorVTableFixup;\r\n TImageCorVTableFixupArray = array [0..MaxWord - 1] of TImageCorVTableFixup;\r\n PImageCorVTableFixupArray = ^TImageCorVTableFixupArray;\r\n\r\ntype\r\n PClrStreamHeader = ^TClrStreamHeader;\r\n TClrStreamHeader = packed record\r\n Offset: DWORD; // Memory offset to start of this stream from start of the metadata root\r\n Size: DWORD; // Size of this stream in bytes, shall be a multiple of 4.\r\n // Name of the stream as null terminated variable length\r\n // array of ASCII characters, padded with \\0 characters\r\n Name: array [0..MaxWord] of AnsiChar;\r\n end;\r\n\r\n PClrTableStreamHeader = ^TClrTableStreamHeader;\r\n TClrTableStreamHeader = packed record\r\n Reserved: DWORD; // Reserved, always 0\r\n MajorVersion: Byte; // Major version of table schemata, always 1\r\n MinorVersion: Byte; // Minor version of table schemata, always 0\r\n HeapSizes: Byte; // Bit vector for heap sizes.\r\n Reserved2: Byte; // Reserved, always 1\r\n Valid: Int64; // Bit vector of present tables, let n be the number of bits that are 1.\r\n Sorted: Int64; // Bit vector of sorted tables.\r\n // Array of n four byte unsigned integers indicating the number of rows\r\n // for each present table.\r\n Rows: array [0..MaxWord] of DWORD;\r\n //Rows: array [0..n - 1] of DWORD;\r\n //Tables: array\r\n end;\r\n\r\n PClrMetadataHeader = ^TClrMetadataHeader;\r\n TClrMetadataHeader = packed record\r\n Signature: DWORD; // Magic signature for physical metadata : $424A5342.\r\n MajorVersion: Word; // Major version, 1\r\n MinorVersion: Word; // Minor version, 0\r\n Reserved: DWORD; // Reserved, always 0\r\n Length: DWORD; // Length of version string in bytes, say m.\r\n Version: array [0..0] of AnsiChar;\r\n // UTF8-encoded version string of length m\r\n // Padding to next 4 byte boundary, say x.\r\n {\r\n Version: array [0..((m+3) and not $3) - 1] of AnsiChar;\r\n Flags, // Reserved, always 0\r\n Streams: Word; // Number of streams, say n.\r\n // Array of n StreamHdr structures.\r\n StreamHeaders: array [0..n - 1] of TClrStreamHeader;\r\n }\r\n end;\r\n\r\ntype\r\n TJclClrTableKind = (\r\n ttModule, // $00\r\n ttTypeRef, // $01\r\n ttTypeDef, // $02\r\n ttFieldPtr, // $03\r\n ttFieldDef, // $04\r\n ttMethodPtr, // $05\r\n ttMethodDef, // $06\r\n ttParamPtr, // $07\r\n ttParamDef, // $08\r\n ttInterfaceImpl, // $09\r\n ttMemberRef, // $0a\r\n ttConstant, // $0b\r\n ttCustomAttribute, // $0c\r\n ttFieldMarshal, // $0d\r\n ttDeclSecurity, // $0e\r\n ttClassLayout, // $0f\r\n ttFieldLayout, // $10\r\n ttSignature, // $11\r\n ttEventMap, // $12\r\n ttEventPtr, // $13\r\n ttEventDef, // $14\r\n ttPropertyMap, // $15\r\n ttPropertyPtr, // $16\r\n ttPropertyDef, // $17\r\n ttMethodSemantics, // $18\r\n ttMethodImpl, // $19\r\n ttModuleRef, // $1a\r\n ttTypeSpec, // $1b\r\n ttImplMap, // $1c\r\n ttFieldRVA, // $1d\r\n ttENCLog, // $1e\r\n ttENCMap, // $1f\r\n ttAssembly, // $20\r\n ttAssemblyProcessor, // $21\r\n ttAssemblyOS, // $22\r\n ttAssemblyRef, // $23\r\n ttAssemblyRefProcessor, // $24\r\n ttAssemblyRefOS, // $25\r\n ttFile, // $26\r\n ttExportedType, // $27\r\n ttManifestResource, // $28\r\n ttNestedClass, // $29\r\n ttTypeTyPar, // $2a\r\n ttMethodTyPar); // $2b\r\n\r\n TJclClrToken = DWORD;\r\n PJclClrToken = ^TJclClrToken;\r\n\r\ntype\r\n TJclClrHeaderEx = class;\r\n TJclPeMetadata = class;\r\n\r\n TJclClrStream = class(TObject)\r\n private\r\n FMetadata: TJclPeMetadata;\r\n FHeader: PClrStreamHeader;\r\n function GetName: string;\r\n function GetOffset: DWORD;\r\n function GetSize: DWORD;\r\n function GetData: Pointer;\r\n public\r\n constructor Create(const AMetadata: TJclPeMetadata;\r\n AHeader: PClrStreamHeader); virtual;\r\n property Metadata: TJclPeMetadata read FMetadata;\r\n property Header: PClrStreamHeader read FHeader;\r\n property Name: string read GetName;\r\n property Offset: DWORD read GetOffset;\r\n property Size: DWORD read GetSize;\r\n property Data: Pointer read GetData;\r\n end;\r\n\r\n TJclClrStreamClass = class of TJclClrStream;\r\n\r\n TJclClrStringsStream = class(TJclClrStream)\r\n private\r\n FStrings: TStringList;\r\n function GetString(const Idx: Integer): WideString;\r\n function GetOffset(const Idx: Integer): DWORD;\r\n function GetStringCount: Integer;\r\n public\r\n constructor Create(const AMetadata: TJclPeMetadata;\r\n AHeader: PClrStreamHeader); override;\r\n destructor Destroy; override;\r\n function At(const Offset: DWORD): WideString;\r\n property Strings[const Idx: Integer]: WideString read GetString; default;\r\n property Offsets[const Idx: Integer]: DWord read GetOffset;\r\n property StringCount: Integer read GetStringCount;\r\n end;\r\n\r\n TJclClrGuidStream = class(TJclClrStream)\r\n private\r\n FGuids: array of TGUID;\r\n function GetGuid(const Idx: Integer): TGUID;\r\n function GetGuidCount: Integer;\r\n public\r\n constructor Create(const AMetadata: TJclPeMetadata;\r\n AHeader: PClrStreamHeader); override;\r\n property Guids[const Idx: Integer]: TGUID read GetGuid; default;\r\n property GuidCount: Integer read GetGuidCount;\r\n end;\r\n\r\n TJclClrBlobRecord = class(TJclReferenceMemoryStream)\r\n private\r\n FPtr: PJclByteArray;\r\n FOffset: DWORD;\r\n function GetData: PJclByteArray;\r\n public\r\n constructor Create(const AStream: TJclClrStream; APtr: PJclByteArray);\r\n function Dump(Indent: string): string;\r\n property Ptr: PJclByteArray read FPtr;\r\n property Offset: DWORD read FOffset;\r\n property Data: PJclByteArray read GetData;\r\n end;\r\n\r\n TJclClrBlobStream = class(TJclClrStream)\r\n private\r\n FBlobs: TObjectList;\r\n function GetBlob(const Idx: Integer): TJclClrBlobRecord;\r\n function GetBlobCount: Integer;\r\n public\r\n constructor Create(const AMetadata: TJclPeMetadata;\r\n AHeader: PClrStreamHeader); override;\r\n destructor Destroy; override;\r\n function At(const Offset: DWORD): TJclClrBlobRecord;\r\n property Blobs[const Idx: Integer]: TJclClrBlobRecord read GetBlob; default;\r\n property BlobCount: Integer read GetBlobCount;\r\n end;\r\n\r\n TJclClrUserStringStream = class(TJclClrBlobStream)\r\n private\r\n function BlobToString(const ABlob: TJclClrBlobRecord): WideString;\r\n function GetString(const Idx: Integer): WideString;\r\n function GetOffset(const Idx: Integer): DWORD;\r\n function GetStringCount: Integer;\r\n public\r\n function At(const Offset: DWORD): WideString;\r\n property Strings[const Idx: Integer]: WideString read GetString; default;\r\n property Offsets[const Idx: Integer]: DWord read GetOffset;\r\n property StringCount: Integer read GetStringCount;\r\n end;\r\n\r\n TJclClrTableStream = class;\r\n\r\n TJclClrHeapKind = (hkString, hkGuid, hkBlob);\r\n TJclClrComboIndex = (ciResolutionScope);\r\n\r\n ITableCanDumpIL = interface(IUnknown)\r\n ['{C7AC787B-5DCD-411A-8674-D424A61B76D1}']\r\n end;\r\n\r\n TJclClrTable = class;\r\n\r\n TJclClrTableRow = class(TObject)\r\n private\r\n FTable: TJclClrTable;\r\n FIndex: Integer;\r\n function GetToken: TJclClrToken;\r\n protected\r\n procedure Update; virtual;\r\n function DecodeTypeDefOrRef(const Encoded: DWORD): TJclClrTableRow;\r\n function DecodeResolutionScope(const Encoded: DWORD): TJclClrTableRow;\r\n public\r\n constructor Create(const ATable: TJclClrTable); virtual;\r\n function DumpIL: string; virtual;\r\n property Table: TJclClrTable read FTable;\r\n property Index: Integer read FIndex;\r\n property Token: TJclClrToken read GetToken;\r\n end;\r\n\r\n TJclClrTableRowClass = class of TJclClrTableRow;\r\n\r\n TJclClrTable = class(TInterfacedObject)\r\n private\r\n FStream: TJclClrTableStream;\r\n FData: PAnsiChar;\r\n FPtr: PAnsiChar;\r\n FRows: TObjectList;\r\n FRowCount: Integer;\r\n FSize: DWORD;\r\n function GetOffset: DWORD;\r\n protected\r\n procedure Load; virtual;\r\n procedure SetSize(const Value: Integer);\r\n procedure Update; virtual;\r\n function DumpIL: string; virtual;\r\n function GetRow(const Idx: Integer): TJclClrTableRow;\r\n function GetRowCount: Integer;\r\n function AddRow(const ARow: TJclClrTableRow): Integer;\r\n function RealRowCount: Integer;\r\n procedure Reset;\r\n class function TableRowClass: TJclClrTableRowClass; virtual;\r\n public\r\n constructor Create(const AStream: TJclClrTableStream;\r\n const Ptr: Pointer; const ARowCount: Integer); virtual;\r\n destructor Destroy; override;\r\n function ReadCompressedValue: DWORD;\r\n function ReadByte: Byte;\r\n function ReadWord: Word;\r\n function ReadDWord: DWORD;\r\n function ReadIndex(const HeapKind: TJclClrHeapKind): DWORD; overload;\r\n function ReadIndex(const TableKinds: array of TJclClrTableKind): DWORD; overload;\r\n function IsWideIndex(const HeapKind: TJclClrHeapKind): Boolean; overload;\r\n function IsWideIndex(const TableKinds: array of TJclClrTableKind): Boolean; overload;\r\n function GetCodedIndexTag(const CodedIndex, TagWidth: DWORD;\r\n const WideIndex: Boolean): DWORD;\r\n function GetCodedIndexValue(const CodedIndex, TagWidth: DWORD;\r\n const WideIndex: Boolean): DWORD;\r\n property Stream: TJclClrTableStream read FStream;\r\n property Data: PAnsiChar read FData;\r\n property Size: DWORD read FSize;\r\n property Offset: DWORD read GetOffset;\r\n property Rows[const Idx: Integer]: TJclClrTableRow read GetRow; default;\r\n property RowCount: Integer read GetRowCount;\r\n end;\r\n\r\n TJclClrTableClass = class of TJclClrTable;\r\n\r\n TJclClrTableStream = class(TJclClrStream)\r\n private\r\n FHeader: PClrTableStreamHeader;\r\n FTables: array [TJclClrTableKind] of TJclClrTable;\r\n FTableCount: Integer;\r\n function GetVersionString: string;\r\n function GetTable(const AKind: TJclClrTableKind): TJclClrTable;\r\n function GetBigHeap(const AHeapKind: TJclClrHeapKind): Boolean;\r\n public\r\n constructor Create(const AMetadata: TJclPeMetadata;\r\n AHeader: PClrStreamHeader); override;\r\n destructor Destroy; override;\r\n procedure Update; virtual;\r\n function DumpIL: string;\r\n function FindTable(const AKind: TJclClrTableKind;\r\n out ATable: TJclClrTable): Boolean;\r\n property Header: PClrTableStreamHeader read FHeader;\r\n property VersionString: string read GetVersionString;\r\n property BigHeap[const AHeapKind: TJclClrHeapKind]: Boolean read GetBigHeap;\r\n property Tables[const AKind: TJclClrTableKind]: TJclClrTable read GetTable;\r\n property TableCount: Integer read FTableCount;\r\n end;\r\n\r\n TJclPeMetadata = class(TObject)\r\n private\r\n FImage: TJclPeImage;\r\n FHeader: PClrMetadataHeader;\r\n FStreams: TObjectList;\r\n FStringStream: TJclClrStringsStream;\r\n FGuidStream: TJclClrGuidStream;\r\n FBlobStream: TJclClrBlobStream;\r\n FUserStringStream: TJclClrUserStringStream;\r\n FTableStream: TJclClrTableStream;\r\n function GetStream(const Idx: Integer): TJclClrStream;\r\n function GetStreamCount: Integer;\r\n function GetString(const Idx: Integer): WideString;\r\n function GetStringCount: Integer;\r\n function GetGuid(const Idx: Integer): TGUID;\r\n function GetGuidCount: Integer;\r\n function GetBlob(const Idx: Integer): TJclClrBlobRecord;\r\n function GetBlobCount: Integer;\r\n function GetTable(const AKind: TJclClrTableKind): TJclClrTable;\r\n function GetTableCount: Integer;\r\n function GetToken(const AToken: TJclClrToken): TJclClrTableRow;\r\n function GetVersion: string;\r\n function GetVersionString: WideString;\r\n function GetFlags: Word;\r\n function UserGetString(const Idx: Integer): WideString;\r\n function UserGetStringCount: Integer;\r\n public\r\n constructor Create(const AImage: TJclPeImage);\r\n destructor Destroy; override;\r\n function DumpIL: string;\r\n function FindStream(const AName: string; out Stream: TJclClrStream): Boolean; overload;\r\n function FindStream(const AClass: TJclClrStreamClass; out Stream: TJclClrStream): Boolean; overload;\r\n function StringAt(const Offset: DWORD): WideString;\r\n function UserStringAt(const Offset: DWORD): WideString;\r\n function BlobAt(const Offset: DWORD): TJclClrBlobRecord;\r\n function TokenExists(const Token: TJclClrToken): Boolean;\r\n class function TokenTable(const Token: TJclClrToken): TJclClrTableKind;\r\n class function TokenIndex(const Token: TJclClrToken): Integer;\r\n class function TokenCode(const Token: TJclClrToken): Integer;\r\n class function MakeToken(const Table: TJclClrTableKind; const Idx: Integer): TJclClrToken;\r\n property Image: TJclPeImage read FImage;\r\n property Header: PClrMetadataHeader read FHeader;\r\n property Version: string read GetVersion;\r\n property VersionString: WideString read GetVersionString;\r\n property Flags: Word read GetFlags;\r\n property Streams[const Idx: Integer]: TJclClrStream read GetStream; default;\r\n property StreamCount: Integer read GetStreamCount;\r\n property Strings[const Idx: Integer]: WideString read GetString;\r\n property StringCount: Integer read GetStringCount;\r\n property UserStrings[const Idx: Integer]: WideString read UserGetString;\r\n property UserStringCount: Integer read UserGetStringCount;\r\n property Guids[const Idx: Integer]: TGUID read GetGuid;\r\n property GuidCount: Integer read GetGuidCount;\r\n property Blobs[const Idx: Integer]: TJclClrBlobRecord read GetBlob;\r\n property BlobCount: Integer read GetBlobCount;\r\n property Tables[const AKind: TJclClrTableKind]: TJclClrTable read GetTable;\r\n property TableCount: Integer read GetTableCount;\r\n property Tokens[const AToken: TJclClrToken]: TJclClrTableRow read GetToken;\r\n end;\r\n\r\n TJclClrResourceRecord = class(TJClreferenceMemoryStream)\r\n private\r\n FData: Pointer;\r\n FOffset: DWORD;\r\n FRVA: DWORD;\r\n public\r\n constructor Create(const AData: PAnsiChar; const AOffset: DWORD; const ARVA: DWORD);\r\n property Data: Pointer read FData;\r\n property Offset: DWORD read FOffset;\r\n property RVA: DWORD read FRVA;\r\n end;\r\n\r\n TJclClrVTableKind = (vtk32Bit, vtk64Bit, vtkFromUnmanaged, vtkCallMostDerived);\r\n TJclClrVTableKinds = set of TJclClrVTableKind;\r\n\r\n TJclClrVTableFixupRecord = class(TObject)\r\n private\r\n FData: PImageCorVTableFixup;\r\n function GetCount: DWORD;\r\n function GetKinds: TJclClrVTableKinds;\r\n function GetRVA: DWORD;\r\n protected\r\n class function VTableKinds(const Kinds: TJclClrVTableKinds): DWORD; overload;\r\n class function VTableKinds(const Kinds: DWORD): TJclClrVTableKinds; overload;\r\n public\r\n constructor Create(AData: PImageCorVTableFixup);\r\n property Data: PImageCorVTableFixup read FData;\r\n property RVA: DWORD read GetRVA; // RVA of Vtable\r\n property Count: DWORD read GetCount; // Number of entries in Vtable\r\n property Kinds: TJclClrVTableKinds read GetKinds; // Type of the entries\r\n end;\r\n\r\n TJclClrImageFlag = (cifILOnly, cif32BitRequired, cifStrongNameSinged, cifTrackDebugData);\r\n TJclClrImageFlags = set of TJclClrImageFlag;\r\n\r\n TJclClrHeaderEx = class(TJclPeClrHeader)\r\n private\r\n FMetadata: TJclPeMetadata;\r\n FFlags: TJclClrImageFlags;\r\n FStrongNameSignature: TCustomMemoryStream;\r\n FResources: TObjectList;\r\n FVTableFixups: TObjectList;\r\n function GetMetadata: TJclPeMetadata;\r\n function GetStrongNameSignature: TCustomMemoryStream;\r\n function GetEntryPointToken: TJclClrTableRow;\r\n function GetVTableFixup(const Idx: Integer): TJclClrVTableFixupRecord;\r\n function GetVTableFixupCount: Integer;\r\n procedure UpdateResources;\r\n function GetResource(const Idx: Integer): TJclClrResourceRecord;\r\n function GetResourceCount: Integer;\r\n public\r\n constructor Create(const AImage: TJclPeImage);\r\n destructor Destroy; override;\r\n function DumpIL: string;\r\n function HasResources: Boolean;\r\n function HasStrongNameSignature: Boolean;\r\n function HasVTableFixup: Boolean;\r\n function ResourceAt(const Offset: DWORD): TJclClrResourceRecord;\r\n class function ClrImageFlag(const Flags: DWORD): TJclClrImageFlags; overload;\r\n class function ClrImageFlag(const Flags: TJclClrImageFlags): DWORD; overload;\r\n property Metadata: TJclPeMetadata read GetMetadata;\r\n property Flags: TJclClrImageFlags read FFlags;\r\n property EntryPointToken: TJclClrTableRow read GetEntryPointToken;\r\n property StrongNameSignature: TCustomMemoryStream read GetStrongNameSignature;\r\n property Resources[const Idx: Integer]: TJclClrResourceRecord read GetResource;\r\n property ResourceCount: Integer read GetResourceCount;\r\n property VTableFixups[const Idx: Integer]: TJclClrVTableFixupRecord read GetVTableFixup;\r\n property VTableFixupCount: Integer read GetVTableFixupCount;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jcl.svn.sourceforge.net/svnroot/jcl/tags/JCL-2.4-Build4571/jcl/source/windows/JclCLR.pas $';\r\n Revision: '$Revision: 3599 $';\r\n Date: '$Date: 2011-09-03 00:07:50 +0200 (sam. 03 sept. 2011) $';\r\n LogPath: 'JCL\\source\\windows';\r\n Extra: '';\r\n Data: nil\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n {$IFDEF HAS_UNITSCOPE}\r\n System.TypInfo,\r\n {$ELSE ~HAS_UNITSCOPE}\r\n TypInfo,\r\n {$ENDIF ~HAS_UNITSCOPE}\r\n JclMetadata, JclResources, JclAnsiStrings, JclStringConversions;\r\n\r\nconst\r\n // MetadataHeaderSignature = $424A5342; // 'BSJB'\r\n\r\n GUID_NULL: TGUID = '{00000000-0000-0000-0000-000000000000}';\r\n\r\n ValidTableMapping: array [TJclClrTableKind] of TJclClrTableClass = (\r\n TJclClrTableModule, // $00 ttModule\r\n TJclClrTableTypeRef, // $01 ttTypeRef\r\n TJclClrTableTypeDef, // $02 ttTypeDef\r\n TJclClrTableFieldPtr, // $03 ttFieldPtr\r\n TJclClrTableFieldDef, // $04 ttFieldDef\r\n TJclClrTableMethodPtr, // $05 ttMethodPtr\r\n TJclClrTableMethodDef, // $06 ttMethodDef\r\n TJclClrTableParamPtr, // $07 ttParamPtr\r\n TJclClrTableParamDef, // $08 ttParamDef\r\n TJclClrTableInterfaceImpl, // $09 ttInterfaceImpl\r\n TJclClrTableMemberRef, // $0a ttMemberRef\r\n TJclClrTableConstant, // $0b ttConstant\r\n TJclClrTableCustomAttribute, // $0c ttCustomAttribute\r\n TJclClrTableFieldMarshal, // $0d ttFieldMarshal\r\n TJclClrTableDeclSecurity, // $0e ttDeclSecurity\r\n TJclClrTableClassLayout, // $0f ttClassLayout\r\n TJclClrTableFieldLayout, // $10 ttFieldLayout\r\n TJclClrTableStandAloneSig, // $11 ttSignature\r\n TJclClrTableEventMap, // $12 ttEventMap\r\n TJclClrTableEventPtr, // $13 ttEventPtr\r\n TJclClrTableEventDef, // $14 ttEventDef\r\n TJclClrTablePropertyMap, // $15 ttPropertyMap\r\n TJclClrTablePropertyPtr, // $16 ttPropertyPtr\r\n TJclClrTablePropertyDef, // $17 ttPropertyDef\r\n TJclClrTableMethodSemantics, // $18 ttMethodSemantics\r\n TJclClrTableMethodImpl, // $19 ttMethodImpl\r\n TJclClrTableModuleRef, // $1a ttModuleRef\r\n TJclClrTableTypeSpec, // $1b ttTypeSpec\r\n TJclClrTableImplMap, // $1c ttImplMap\r\n TJclClrTableFieldRVA, // $1d ttFieldRVA\r\n TJclClrTableENCLog, // $1e ttENCLog\r\n TJclClrTableENCMap, // $1f ttENCMap\r\n TJclClrTableAssembly, // $20 ttAssembly\r\n TJclClrTableAssemblyProcessor, // $21 ttAssemblyProcessor\r\n TJclClrTableAssemblyOS, // $22 ttAssemblyOS\r\n TJclClrTableAssemblyRef, // $23 ttAssemblyRef\r\n TJclClrTableAssemblyRefProcessor, // $24 ttAssemblyRefProcessor\r\n TJclClrTableAssemblyRefOS, // $25 ttAssemblyRefOS\r\n TJclClrTableFile, // $26 ttFile\r\n TJclClrTableExportedType, // $27 ttExportedType\r\n TJclClrTableManifestResource, // $28 ttManifestResource\r\n TJclClrTableNestedClass, // $29 ttNestedClass\r\n TJclClrTable, // $2A ttGenericPar\r\n TJclClrTableMethodSpec); // $2B ttMethodSpec\r\n\r\n// CLR Header entry point flags.\r\nconst\r\n COMIMAGE_FLAGS_ILONLY = $00000001; // Always 1 (see Section 23.1).\r\n COMIMAGE_FLAGS_32BITREQUIRED = $00000002;\r\n // Image may only be loaded into a 32-bit process,\r\n // for instance if there are 32-bit vtablefixups,\r\n // or casts from native integers to int32.\r\n // CLI implementations that have 64 bit native integers shall refuse\r\n // loading binaries with this flag set.\r\n COMIMAGE_FLAGS_STRONGNAMESIGNED = $00000008; // Image has a strong name signature.\r\n COMIMAGE_FLAGS_TRACKDEBUGDATA = $00010000; // Always 0 (see Section 23.1).\r\n ClrImageFlagMapping: array [TJclClrImageFlag] of DWORD =\r\n (COMIMAGE_FLAGS_ILONLY, COMIMAGE_FLAGS_32BITREQUIRED,\r\n COMIMAGE_FLAGS_STRONGNAMESIGNED, COMIMAGE_FLAGS_TRACKDEBUGDATA);\r\n\r\n// V-table constants\r\nconst\r\n COR_VTABLE_32BIT = $01; // V-table slots are 32-bits in size.\r\n COR_VTABLE_64BIT = $02; // V-table slots are 64-bits in size.\r\n COR_VTABLE_FROM_UNMANAGED = $04; // If set, transition from unmanaged.\r\n COR_VTABLE_CALL_MOST_DERIVED = $10; // Call most derived method described by\r\n\r\n ClrVTableKindMapping: array [TJclClrVTableKind] of DWORD =\r\n (COR_VTABLE_32BIT, COR_VTABLE_64BIT,\r\n COR_VTABLE_FROM_UNMANAGED, COR_VTABLE_CALL_MOST_DERIVED);\r\n\r\n//=== { TJclClrStream } ======================================================\r\n\r\nconstructor TJclClrStream.Create(const AMetadata: TJclPeMetadata;\r\n AHeader: PClrStreamHeader);\r\nbegin\r\n inherited Create;\r\n FMetadata := AMetadata;\r\n FHeader := AHeader;\r\nend;\r\n\r\nfunction TJclClrStream.GetName: string;\r\nbegin\r\n Result := string(FHeader.Name);\r\nend;\r\n\r\nfunction TJclClrStream.GetOffset: DWORD;\r\nbegin\r\n Result := TJclAddr(Data) - TJclAddr(Metadata.Image.LoadedImage.MappedAddress);\r\nend;\r\n\r\nfunction TJclClrStream.GetSize: DWORD;\r\nbegin\r\n Result := FHeader.Size;\r\nend;\r\n\r\nfunction TJclClrStream.GetData: Pointer;\r\nbegin\r\n Result := Pointer(PAnsiChar(FMetadata.Header) + FHeader.Offset);\r\nend;\r\n\r\n//=== { TJclClrStringsStream } ===============================================\r\n\r\nconstructor TJclClrStringsStream.Create(const AMetadata: TJclPeMetadata;\r\n AHeader: PClrStreamHeader);\r\nvar\r\n pch: PAnsiChar;\r\n off: DWORD;\r\nbegin\r\n inherited Create(AMetadata, AHeader);\r\n FStrings := TStringList.Create;\r\n pch := Data;\r\n off := 0;\r\n while off < Size do\r\n begin\r\n if pch^ <> #0 then\r\n FStrings.AddObject(string(TUTF8String(pch)), TObject(off));\r\n pch := pch + StrLen(pch) + 1;\r\n off := pch - PAnsiChar(Data);\r\n end;\r\nend;\r\n\r\ndestructor TJclClrStringsStream.Destroy;\r\nbegin\r\n FreeAndNil(FStrings);\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJclClrStringsStream.GetString(const Idx: Integer): WideString;\r\nbegin\r\n Result := UTF8ToWideString(TUTF8String(FStrings.Strings[Idx]));\r\nend;\r\n\r\nfunction TJclClrStringsStream.GetOffset(const Idx: Integer): DWORD;\r\nbegin\r\n Result := DWORD(FStrings.Objects[Idx]);\r\nend;\r\n\r\nfunction TJclClrStringsStream.GetStringCount: Integer;\r\nbegin\r\n Result := FStrings.Count;\r\nend;\r\n\r\nfunction TJclClrStringsStream.At(const Offset: DWORD): WideString;\r\nvar\r\n Idx: Integer;\r\nbegin\r\n Idx := FStrings.IndexOfObject(TObject(Offset));\r\n if Idx <> -1 then\r\n Result := GetString(Idx)\r\n else\r\n Result := '';\r\nend;\r\n\r\n//=== { TJclClrGuidStream } ==================================================\r\n\r\nconstructor TJclClrGuidStream.Create(const AMetadata: TJclPeMetadata;\r\n AHeader: PClrStreamHeader);\r\nvar\r\n I: Integer;\r\n pg: PGUID;\r\nbegin\r\n inherited Create(AMetadata, AHeader);\r\n SetLength(FGuids, Size div SizeOf(TGuid));\r\n pg := Data;\r\n for I := 0 to GetGuidCount - 1 do\r\n begin\r\n FGuids[I] := pg^;\r\n Inc(pg);\r\n end;\r\nend;\r\n\r\nfunction TJclClrGuidStream.GetGuid(const Idx: Integer): TGUID;\r\nbegin\r\n Assert((0 <= Idx) and (Idx < GetGuidCount));\r\n Result := FGuids[Idx];\r\nend;\r\n\r\nfunction TJclClrGuidStream.GetGuidCount: Integer;\r\nbegin\r\n Result := Length(FGuids);\r\nend;\r\n\r\n//=== { TJclClrBlobRecord } ==================================================\r\n\r\nconstructor TJclClrBlobRecord.Create(const AStream: TJclClrStream; APtr: PJclByteArray);\r\nvar\r\n b: Byte;\r\n AData: Pointer;\r\n ASize: DWORD;\r\nbegin\r\n FPtr := APtr;\r\n FOffset := TJclAddr(FPtr) - TJclAddr(AStream.Data);\r\n\r\n b := FPtr[0];\r\n if b = 0 then\r\n begin\r\n AData := @FPtr[1];\r\n ASize := 0;\r\n end\r\n else\r\n if ((b and $C0) = $C0) and ((b and $20) = 0) then // 110bs\r\n begin\r\n AData := @FPtr[4];\r\n ASize := ((b and $1F) shl 24) or (FPtr[1] shl 16) or (FPtr[2] shl 8) or FPtr[3];\r\n end\r\n else\r\n if ((b and $80) = $80) and ((b and $40) = 0) then // 10bs\r\n begin\r\n AData := @FPtr[2];\r\n ASize := ((b and $3F) shl 8) or FPtr[1];\r\n end\r\n else\r\n begin\r\n AData := @FPtr[1];\r\n ASize := b and $7F;\r\n end;\r\n Assert(not IsBadReadPtr(AData, ASize));\r\n inherited Create(AData, ASize);\r\nend;\r\n\r\nfunction TJclClrBlobRecord.Dump(Indent: string): string;\r\nconst\r\n BufSize = 16;\r\nvar\r\n I, Len: Integer;\r\n\r\n function DumpBuf(Buf: PAnsiChar; Size: Integer; IsHead, IsTail: Boolean): string;\r\n var\r\n I: Integer;\r\n HexStr, AsciiStr: string;\r\n begin\r\n HexStr := '';\r\n AsciiStr := '';\r\n for I := 0 to Size - 1 do\r\n begin\r\n HexStr := HexStr + IntToHex(Integer(Buf[I]), 2) + ' ';\r\n if JclAnsiStrings.CharIsPrintable(Buf[I]) and ((Byte(Buf[I]) and $80) <> $80) then\r\n AsciiStr := AsciiStr + Char(Buf[I])\r\n else\r\n AsciiStr := AsciiStr + '.';\r\n end;\r\n\r\n if IsTail then\r\n Result := HexStr + ')' + JclStrings.StrRepeat(' ', (BufSize-Size) * 3) + ' // ' + AsciiStr\r\n else\r\n Result := HexStr + ' ' + JclStrings.StrRepeat(' ', (BufSize-Size) * 3) + ' // ' + AsciiStr;\r\n if IsHead then\r\n Result := Indent + '( ' + Result\r\n else\r\n Result := JclStrings.StrRepeat(' ', Length(Indent) + 2) + Result;\r\n end;\r\n\r\nbegin\r\n with TStringList.Create do\r\n try\r\n Len := (Size + BufSize - 1) div BufSize;\r\n for I := 0 to Len - 1 do\r\n if I = Len - 1 then\r\n Add(DumpBuf(PAnsiChar(Memory) + I * BufSize, Size - I * BufSize, I = 0, I = Len - 1))\r\n else\r\n Add(DumpBuf(PAnsiChar(Memory) + I * BufSize, BufSize, I = 0, I = Len -1));\r\n Result := Text;\r\n finally\r\n Free;\r\n end;\r\nend;\r\n\r\nfunction TJclClrBlobRecord.GetData: PJclByteArray;\r\nbegin\r\n Result := PJclByteArray(PAnsiChar(Memory) + Position);\r\nend;\r\n\r\n//=== { TJclClrBlobStream } ==================================================\r\n\r\nconstructor TJclClrBlobStream.Create(const AMetadata: TJclPeMetadata;\r\n AHeader: PClrStreamHeader);\r\nvar\r\n ABlob: TJclClrBlobRecord;\r\nbegin\r\n inherited Create(AMetadata, AHeader);\r\n FBlobs := TObjectList.Create;\r\n ABlob := TJclClrBlobRecord.Create(Self, Data);\r\n while Assigned(ABlob) do\r\n begin\r\n if ABlob.Size > 0 then\r\n FBlobs.Add(ABlob);\r\n if (PAnsiChar(ABlob.Memory) + ABlob.Size) < (PAnsiChar(Self.Data) + Integer(Self.Size)) then\r\n ABlob := TJclClrBlobRecord.Create(Self, Pointer(PAnsiChar(ABlob.Memory) + ABlob.Size))\r\n else\r\n ABlob := nil;\r\n end;\r\nend;\r\n\r\ndestructor TJclClrBlobStream.Destroy;\r\nbegin\r\n FreeAndNil(FBlobs);\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJclClrBlobStream.At(const Offset: DWORD): TJclClrBlobRecord;\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := 0 to FBlobs.Count - 1 do\r\n begin\r\n Result := TJclClrBlobRecord(FBlobs.Items[I]);\r\n if Result.Offset = Offset then\r\n Exit;\r\n end;\r\n Result := nil;\r\nend;\r\n\r\nfunction TJclClrBlobStream.GetBlob(const Idx: Integer): TJclClrBlobRecord;\r\nbegin\r\n Result := TJclClrBlobRecord(FBlobs.Items[Idx])\r\nend;\r\n\r\nfunction TJclClrBlobStream.GetBlobCount: Integer;\r\nbegin\r\n Result := FBlobs.Count;\r\nend;\r\n\r\n//=== { TJclClrUserStringStream } ============================================\r\n\r\nfunction TJclClrUserStringStream.BlobToString(const ABlob: TJclClrBlobRecord): WideString;\r\nbegin\r\n if Assigned(ABlob) then\r\n begin\r\n SetLength(Result, ABlob.Size div 2);\r\n Move(PWideChar(ABlob.Memory)^, PWideChar(Result)^, ABlob.Size and not 1);\r\n end\r\n else\r\n Result := '';\r\nend;\r\n\r\nfunction TJclClrUserStringStream.GetString(const Idx: Integer): WideString;\r\nbegin\r\n Result := BlobToString(Blobs[Idx]);\r\nend;\r\n\r\nfunction TJclClrUserStringStream.GetOffset(const Idx: Integer): DWORD;\r\nbegin\r\n Result := Blobs[Idx].Offset;\r\nend;\r\n\r\nfunction TJclClrUserStringStream.GetStringCount: Integer;\r\nbegin\r\n Result := BlobCount;\r\nend;\r\n\r\nfunction TJclClrUserStringStream.At(const Offset: DWORD): WideString;\r\nbegin\r\n Result := BlobToString(inherited At(Offset));\r\nend;\r\n\r\n//=== { TJclClrTableRow } ====================================================\r\n\r\nconstructor TJclClrTableRow.Create(const ATable: TJclClrTable);\r\nbegin\r\n inherited Create;\r\n FTable := ATable;\r\n FIndex := Table.RealRowCount;\r\nend;\r\n\r\nfunction TJclClrTableRow.DecodeResolutionScope(const Encoded: DWORD): TJclClrTableRow;\r\nconst\r\n ResolutionScopeEncoded: array [0..3] of TJclClrTableKind =\r\n (ttModule, ttModuleRef, ttAssemblyRef, ttTypeRef);\r\nbegin\r\n Result := Table.Stream.Tables[ResolutionScopeEncoded[Encoded and 3]].Rows[Encoded shr 2 - 1];\r\nend;\r\n\r\nfunction TJclClrTableRow.DecodeTypeDefOrRef(const Encoded: DWORD): TJclClrTableRow;\r\nconst\r\n TypeDefOrRefEncoded: array [0..2] of TJclClrTableKind =\r\n (ttTypeDef, ttTypeRef, ttTypeSpec);\r\nbegin\r\n Result := Table.Stream.Tables[TypeDefOrRefEncoded[Encoded and 3]].Rows[Encoded shr 2 - 1];\r\nend;\r\n\r\nfunction TJclClrTableRow.DumpIL: string;\r\nbegin\r\n Result := '';\r\n // (rom) needs comment why empty\r\nend;\r\n\r\nfunction TJclClrTableRow.GetToken: TJclClrToken;\r\n\r\n function GetTableId: TJclClrTableKind;\r\n begin\r\n for Result := Low(TJclClrTableKind) to High(TJclClrTableKind) do\r\n if ValidTableMapping[Result] = Table.ClassType then\r\n Exit;\r\n raise EJclError.CreateResFmt(@RsUnknownTableFmt, [LoadResString(@RsUnknownTable), ClassName]);\r\n end;\r\n\r\nbegin\r\n Result := (DWORD(GetTableId) shl 24) or DWORD(Index + 1);\r\nend;\r\n\r\nprocedure TJclClrTableRow.Update;\r\nbegin\r\n // do nothing, just for override\r\nend;\r\n\r\n//=== { TJclClrTable } ======================================================\r\n\r\nconstructor TJclClrTable.Create(const AStream: TJclClrTableStream;\r\n const Ptr: Pointer; const ARowCount: Integer);\r\nbegin\r\n inherited Create;\r\n FStream := AStream;\r\n FData := Ptr;\r\n FRows := nil; // Create on demand\r\n FRowCount := ARowCount;\r\n Reset;\r\n Load;\r\n SetSize(FPtr - FData);\r\nend;\r\n\r\ndestructor TJclClrTable.Destroy;\r\nbegin\r\n FreeAndNil(FRows);\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJclClrTable.Reset;\r\nbegin\r\n FPtr := FData;\r\nend;\r\n\r\nprocedure TJclClrTable.Load;\r\nvar\r\n I: Integer;\r\nbegin\r\n Assert(RowCount > 0);\r\n\r\n if TableRowClass <> TJclClrTableRow then\r\n for I := 0 to RowCount - 1 do\r\n AddRow(TableRowClass.Create(Self));\r\nend;\r\n\r\nprocedure TJclClrTable.SetSize(const Value: Integer);\r\nbegin\r\n FSize := Value;\r\n Assert(not IsBadReadPtr(FData, FSize));\r\nend;\r\n\r\nfunction TJclClrTable.GetOffset: DWORD;\r\nbegin\r\n Result := TJclAddr(Data) - TJclAddr(Stream.Metadata.Image.LoadedImage.MappedAddress);\r\nend;\r\n\r\nfunction TJclClrTable.GetRow(const Idx: Integer): TJclClrTableRow;\r\nbegin\r\n Result := TJclClrTableRow(FRows.Items[Idx]);\r\nend;\r\n\r\nfunction TJclClrTable.GetRowCount: Integer;\r\nbegin\r\n Result := FRowCount;\r\nend;\r\n\r\nfunction TJclClrTable.AddRow(const ARow: TJclClrTableRow): Integer;\r\nbegin\r\n if not Assigned(FRows) then\r\n FRows := TObjectList.Create;\r\n Result := FRows.Add(ARow);\r\nend;\r\n\r\nfunction TJclClrTable.RealRowCount: Integer;\r\nbegin\r\n if Assigned(FRows) then\r\n Result := FRows.Count\r\n else\r\n Result := 0;\r\nend;\r\n\r\nfunction TJclClrTable.ReadIndex(const HeapKind: TJclClrHeapKind): DWORD;\r\nbegin\r\n if IsWideIndex(HeapKind) then\r\n Result := ReadDWord\r\n else\r\n Result := ReadWord;\r\nend;\r\n\r\nfunction TJclClrTable.ReadIndex(const TableKinds: array of TJclClrTableKind): DWORD;\r\nbegin\r\n if IsWideIndex(TableKinds) then\r\n Result := ReadDWord\r\n else\r\n Result := ReadWord;\r\nend;\r\n\r\nfunction TJclClrTable.IsWideIndex(const HeapKind: TJclClrHeapKind): Boolean;\r\nbegin\r\n Result := Stream.BigHeap[HeapKind];\r\nend;\r\n\r\nfunction TJclClrTable.IsWideIndex(const TableKinds: array of TJclClrTableKind): Boolean;\r\nvar\r\n I: Integer;\r\n ATable: TJclClrTable;\r\nbegin\r\n Result := False;\r\n for I := Low(TableKinds) to High(TableKinds) do\r\n if Stream.FindTable(TableKinds[I], ATable) then\r\n Result := Result or (ATable.RowCount > MAXWORD);\r\nend;\r\n\r\nfunction TJclClrTable.ReadByte: Byte;\r\nbegin\r\n Result := PByte(FPtr)^;\r\n Inc(FPtr, SizeOf(Byte));\r\nend;\r\n\r\nfunction TJclClrTable.ReadWord: Word;\r\nbegin\r\n Result := PWord(FPtr)^;\r\n Inc(FPtr, SizeOf(Word));\r\nend;\r\n\r\nfunction TJclClrTable.ReadDWord: DWORD;\r\nbegin\r\n Result := PDWORD(FPtr)^;\r\n Inc(FPtr, SizeOf(DWORD));\r\nend;\r\n\r\nfunction TJclClrTable.ReadCompressedValue: DWORD;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := ReadByte;\r\n if Result = 0 then\r\n begin\r\n Exit;\r\n end\r\n else\r\n if ((Result and $C0) = $C0) and ((Result and $20) = 0) then // 110bs\r\n begin\r\n Result := Result and $1F;\r\n for I := 0 to 2 do\r\n Result := (Result shl 8) or ReadByte;\r\n end\r\n else\r\n if ((Result and $80) = $80) and ((Result and $40) = 0) then // 10bs\r\n begin\r\n Result := ((Result and $3F) shl 8) or ReadByte;\r\n end\r\n else\r\n begin\r\n Result := Result and $7F;\r\n end;\r\nend;\r\n\r\nclass function TJclClrTable.TableRowClass: TJclClrTableRowClass;\r\nbegin\r\n Result := TJclClrTableRow;\r\nend;\r\n\r\nprocedure TJclClrTable.Update;\r\nvar\r\n I: Integer;\r\nbegin\r\n if Assigned(FRows) then\r\n for I := 0 to RowCount - 1 do\r\n Rows[I].Update;\r\nend;\r\n\r\nfunction TJclClrTable.GetCodedIndexTag(const CodedIndex, TagWidth: DWORD;\r\n const WideIndex: Boolean): DWORD;\r\nvar\r\n I, TagMask: DWORD;\r\nbegin\r\n TagMask := 0;\r\n for I := 0 to TagWidth - 1 do\r\n TagMask := TagMask or (1 shl I);\r\n Result := CodedIndex and TagMask;\r\nend;\r\n\r\nfunction TJclClrTable.GetCodedIndexValue(const CodedIndex, TagWidth: DWORD;\r\n const WideIndex: Boolean): DWORD;\r\nconst\r\n IndexBits: array [Boolean] of DWORD = (SizeOf(WORD) * 8, SizeOf(DWORD) * 8);\r\nvar\r\n I, ValueMask: DWORD;\r\nbegin\r\n ValueMask := 0;\r\n for I := TagWidth to IndexBits[WideIndex] - 1 do\r\n ValueMask := ValueMask or (1 shl I);\r\n Result := (CodedIndex and ValueMask) shr TagWidth;\r\nend;\r\n\r\nfunction TJclClrTable.DumpIL: string;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := '// Dump ' + ClassName + NativeLineBreak;\r\n if Supports(ClassType, ITableCanDumpIL) then\r\n for I := 0 to FRows.Count - 1 do\r\n Result := Result + TJclClrTableRow(FRows[I]).DumpIL;\r\nend;\r\n\r\n//=== { TJclClrTableStream } =================================================\r\n\r\nconstructor TJclClrTableStream.Create(const AMetadata: TJclPeMetadata;\r\n AHeader: PClrStreamHeader);\r\n\r\n function BitCount(const Value: Int64): Integer;\r\n var\r\n AKind: TJclClrTableKind;\r\n begin\r\n Result := 0;\r\n for AKind := Low(TJclClrTableKind) to High(TJclClrTableKind) do\r\n if (Value and (Int64(1) shl Integer(AKind))) <> 0 then\r\n Inc(Result);\r\n end;\r\n\r\n procedure EnumTables;\r\n var\r\n AKind: TJclClrTableKind;\r\n pTable: Pointer;\r\n begin\r\n pTable := @Header.Rows[BitCount(Header.Valid)];\r\n FTableCount := 0;\r\n for AKind := Low(TJclClrTableKind) to High(TJclClrTableKind) do\r\n begin\r\n if (Header.Valid and (Int64(1) shl Integer(AKind))) <> 0 then\r\n begin\r\n FTables[AKind] := ValidTableMapping[AKind].Create(Self, pTable, Header.Rows[FTableCount]);\r\n pTable := Pointer(TJclAddr(pTable) + FTables[AKind].Size);\r\n Inc(FTableCount);\r\n end\r\n else\r\n FTables[AKind] := nil;\r\n end;\r\n end;\r\n\r\nbegin\r\n inherited Create(AMetadata, AHeader);\r\n FHeader := Data;\r\n EnumTables;\r\nend;\r\n\r\ndestructor TJclClrTableStream.Destroy;\r\nbegin\r\n FreeAndNil(FTables);\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJclClrTableStream.GetVersionString: string;\r\nbegin\r\n Result := FormatVersionString(Header.MajorVersion, Header.MinorVersion);\r\nend;\r\n\r\nfunction TJclClrTableStream.GetTable(const AKind: TJclClrTableKind): TJclClrTable;\r\nbegin\r\n Result := TJclClrTable(FTables[AKind]);\r\nend;\r\n\r\nfunction TJclClrTableStream.GetBigHeap(const AHeapKind: TJclClrHeapKind): Boolean;\r\nconst\r\n HeapSizesMapping: array [TJclClrHeapKind] of DWORD = (1, 2, 4);\r\nbegin\r\n Result := (Header.HeapSizes and HeapSizesMapping[AHeapKind]) <> 0;\r\nend;\r\n\r\nfunction TJclClrTableStream.FindTable(const AKind: TJclClrTableKind;\r\n out ATable: TJclClrTable): Boolean;\r\nbegin\r\n ATable := FTables[AKind];\r\n Result := Assigned(ATable);\r\nend;\r\n\r\nprocedure TJclClrTableStream.Update;\r\nvar\r\n AKind: TJclClrTableKind;\r\nbegin\r\n for AKind := Low(TJclClrTableKind) to High(TJclClrTableKind) do\r\n if Assigned(FTables[AKind]) then\r\n FTables[AKind].Update;\r\nend;\r\n\r\nfunction TJclClrTableStream.DumpIL: string;\r\nvar\r\n AKind: TJclClrTableKind;\r\nbegin\r\n Result := '';\r\n for AKind := Low(TJclClrTableKind) to High(TJclClrTableKind) do\r\n if Assigned(FTables[AKind]) then\r\n Result := Result + FTables[AKind].DumpIL;\r\nend;\r\n\r\n//=== { TJclPeMetadata } =====================================================\r\n\r\nconstructor TJclPeMetadata.Create(const AImage: TJclPeImage);\r\n\r\n function GetStreamClass(const Name: string): TJclClrStreamClass;\r\n begin\r\n if CompareText(Name, '#Strings') = 0 then\r\n Result := TJclClrStringsStream\r\n else\r\n if CompareText(Name, '#GUID') = 0 then\r\n Result := TJclClrGuidStream\r\n else\r\n if CompareText(Name, '#Blob') = 0 then\r\n Result := TJclClrBlobStream\r\n else\r\n if CompareText(Name, '#US') = 0 then\r\n Result := TJclClrUserStringStream\r\n else\r\n if CompareText(Name, '#~') = 0 then\r\n Result := TJclClrTableStream\r\n else\r\n Result := TJclClrStream;\r\n end;\r\n\r\n procedure UpdateStreams;\r\n type\r\n PStreamPartitionHeader = ^TStreamPartitionHeader;\r\n TStreamPartitionHeader = packed record\r\n Flags,\r\n StreamCount: Word;\r\n StreamHeaders: array [0..0] of TClrStreamHeader;\r\n end;\r\n var\r\n pStreamPart: PStreamPartitionHeader;\r\n pStream: PClrStreamHeader;\r\n I: Integer;\r\n TableStream: TJclClrTableStream;\r\n begin\r\n pStreamPart := PStreamPartitionHeader(TJclAddr(@Header.Version[0]) + Header.Length);\r\n pStream := @pStreamPart.StreamHeaders[0];\r\n for I := 0 to pStreamPart.StreamCount - 1 do\r\n begin\r\n FStreams.Add(GetStreamClass(string(pStream.Name)).Create(Self, pStream));\r\n\r\n pStream := PClrStreamHeader(TJclAddr(@pStream.Name[0]) +\r\n DWORD_PTR((StrLen(PAnsiChar(@pStream.Name[0]) + 1 + 3) and not $3)));\r\n end;\r\n if FindStream(TJclClrTableStream, TJclClrStream(TableStream)) then\r\n TableStream.Update;\r\n end;\r\n\r\nbegin\r\n Assert(AImage.IsClr and AImage.ClrHeader.HasMetadata);\r\n inherited Create;\r\n FImage := AImage;\r\n with Image.ClrHeader.Header.MetaData do\r\n begin\r\n Assert(Size > SizeOf(FHeader^));\r\n FHeader := Image.RvaToVa(VirtualAddress);\r\n Assert(not IsBadReadPtr(FHeader, Size));\r\n end;\r\n\r\n FStreams := TObjectList.Create;\r\n UpdateStreams;\r\n\r\n FindStream(TJclClrStringsStream, TJclClrStream(FStringStream));\r\n FindStream(TJclClrGuidStream, TJclClrStream(FGuidStream));\r\n FindStream(TJclClrBlobStream, TJclClrStream(FBlobStream));\r\n FindStream(TJclClrUserStringStream, TJclClrStream(FUserStringStream));\r\n FindStream(TJclClrTableStream, TJclClrStream(FTableStream));\r\nend;\r\n\r\ndestructor TJclPeMetadata.Destroy;\r\nbegin\r\n FreeAndNil(FStreams);\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJclPeMetadata.GetVersionString: WideString;\r\nvar\r\n VerStr: AnsiString;\r\nbegin\r\n SetLength(VerStr, Header.Length+1);\r\n StrLCopy(PAnsiChar(VerStr), @Header.Version[0], Header.Length);\r\n SetLength(VerStr, StrLen(PAnsiChar(VerStr)));\r\n Result := UTF8ToWideString(VerStr)\r\nend;\r\n\r\nfunction TJclPeMetadata.GetVersion: string;\r\nbegin\r\n Result := FormatVersionString(Header.MajorVersion, Header.MinorVersion);\r\nend;\r\n\r\nfunction TJclPeMetadata.GetFlags: Word;\r\nbegin\r\n Result := PWord(PAnsiChar(@Header.Version[0]) + (Header.Length + 3) and (not 3))^;\r\nend;\r\n\r\nfunction TJclPeMetadata.GetStream(const Idx: Integer): TJclClrStream;\r\nbegin\r\n Result := TJclClrStream(FStreams.Items[Idx]);\r\nend;\r\n\r\nfunction TJclPeMetadata.GetStreamCount: Integer;\r\nbegin\r\n Result := FStreams.Count;\r\nend;\r\n\r\nfunction TJclPeMetadata.FindStream(const AName: string;\r\n out Stream: TJclClrStream): Boolean;\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := 0 to GetStreamCount - 1 do\r\n begin\r\n Stream := Streams[I];\r\n if CompareText(Stream.Name, AName) = 0 then\r\n begin\r\n Result := True;\r\n Exit;\r\n end;\r\n end;\r\n Result := False;\r\n Stream := nil;\r\nend;\r\n\r\nfunction TJclPeMetadata.FindStream(const AClass: TJclClrStreamClass;\r\n out Stream: TJclClrStream): Boolean;\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := 0 to GetStreamCount - 1 do\r\n begin\r\n Stream := Streams[I];\r\n if Stream.ClassType = AClass then\r\n begin\r\n Result := True;\r\n Exit;\r\n end;\r\n end;\r\n Result := False;\r\n Stream := nil;\r\nend;\r\n\r\nfunction TJclPeMetadata.GetToken(const AToken: TJclClrToken): TJclClrTableRow;\r\nbegin\r\n if AToken = 0 then\r\n Result := nil\r\n else\r\n try\r\n Result := Tables[TokenTable(AToken)].Rows[TokenIndex(AToken) - 1];\r\n except\r\n Result := nil;\r\n end;\r\nend;\r\n\r\nfunction TJclPeMetadata.GetString(const Idx: Integer): WideString;\r\nbegin\r\n if Assigned(FStringStream) or\r\n FindStream(TJclClrStringsStream, TJclClrStream(FStringStream)) then\r\n Result := FStringStream.Strings[Idx]\r\n else\r\n Result := '';\r\nend;\r\n\r\nfunction TJclPeMetadata.GetStringCount: Integer;\r\nbegin\r\n if Assigned(FStringStream) or\r\n FindStream(TJclClrStringsStream, TJclClrStream(FStringStream)) then\r\n Result := FStringStream.StringCount\r\n else\r\n Result := 0;\r\nend;\r\n\r\nfunction TJclPeMetadata.UserGetString(const Idx: Integer): WideString;\r\nbegin\r\n if Assigned(FUserStringStream) or\r\n FindStream(TJclClrUserStringStream, TJclClrStream(FUserStringStream)) then\r\n Result := FUserStringStream.Strings[Idx - 1]\r\n else\r\n Result := '';\r\nend;\r\n\r\nfunction TJclPeMetadata.UserGetStringCount: Integer;\r\nbegin\r\n if Assigned(FUserStringStream) or\r\n FindStream(TJclClrUserStringStream, TJclClrStream(FUserStringStream)) then\r\n Result := FUserStringStream.StringCount\r\n else\r\n Result := 0;\r\nend;\r\n\r\nfunction TJclPeMetadata.StringAt(const Offset: DWORD): WideString;\r\nbegin\r\n if Assigned(FStringStream) or\r\n FindStream(TJclClrStringsStream, TJclClrStream(FStringStream)) then\r\n Result := FStringStream.At(Offset)\r\n else\r\n Result := '';\r\nend;\r\n\r\nfunction TJclPeMetadata.UserStringAt(const Offset: DWORD): WideString;\r\nbegin\r\n if Assigned(FUserStringStream) or\r\n FindStream(TJclClrUserStringStream, TJclClrStream(FUserStringStream)) then\r\n Result := TJclClrUserStringStream(FUserStringStream).At(Offset)\r\n else\r\n Result := '';\r\nend;\r\n\r\nfunction TJclPeMetadata.BlobAt(const Offset: DWORD): TJclClrBlobRecord;\r\nbegin\r\n if Assigned(FBlobStream) or\r\n FindStream(TJclClrBlobStream, TJclClrStream(FBlobStream)) then\r\n Result := TJclClrBlobStream(FBlobStream).At(Offset)\r\n else\r\n Result := nil;\r\nend;\r\n\r\nfunction TJclPeMetadata.GetGuid(const Idx: Integer): TGUID;\r\nbegin\r\n if Assigned(FGuidStream) or\r\n FindStream(TJclClrGuidStream, TJclClrStream(FGuidStream)) then\r\n Result := FGuidStream.Guids[Idx]\r\n else\r\n Result := GUID_NULL;\r\nend;\r\n\r\nfunction TJclPeMetadata.GetGuidCount: Integer;\r\nbegin\r\n if Assigned(FGuidStream) or\r\n FindStream(TJclClrGuidStream, TJclClrStream(FGuidStream)) then\r\n Result := FGuidStream.GuidCount\r\n else\r\n Result := 0;\r\nend;\r\n\r\nfunction TJclPeMetadata.GetBlob(const Idx: Integer): TJclClrBlobRecord;\r\nbegin\r\n if Assigned(FBlobStream) or\r\n FindStream(TJclClrBlobStream, TJclClrStream(FBlobStream)) then\r\n Result := FBlobStream.Blobs[Idx]\r\n else\r\n Result := nil;\r\nend;\r\n\r\nfunction TJclPeMetadata.GetBlobCount: Integer;\r\nbegin\r\n if Assigned(FBlobStream) or\r\n FindStream(TJclClrBlobStream, TJclClrStream(FBlobStream)) then\r\n Result := FBlobStream.BlobCount\r\n else\r\n Result := 0;\r\nend;\r\n\r\nfunction TJclPeMetadata.GetTable(const AKind: TJclClrTableKind): TJclClrTable;\r\nbegin\r\n if Assigned(FTableStream) or\r\n FindStream(TJclClrTableStream, TJclClrStream(FTableStream)) then\r\n Result := FTableStream.Tables[AKind]\r\n else\r\n Result := nil;\r\nend;\r\n\r\nfunction TJclPeMetadata.GetTableCount: Integer;\r\nbegin\r\n if Assigned(FTableStream) or\r\n FindStream(TJclClrTableStream, TJclClrStream(FTableStream)) then\r\n Result := FTableStream.TableCount\r\n else\r\n Result := 0;\r\nend;\r\n\r\nfunction TJclPeMetadata.TokenExists(const Token: TJclClrToken): Boolean;\r\nbegin\r\n Result := TokenIndex(Token) in [1..Tables[TokenTable(Token)].RowCount];\r\nend;\r\n\r\nclass function TJclPeMetadata.TokenTable(const Token: TJclClrToken): TJclClrTableKind;\r\nbegin\r\n Result := TJclClrTableKind(Token shr 24);\r\nend;\r\n\r\nclass function TJclPeMetadata.TokenIndex(const Token: TJclClrToken): Integer;\r\nbegin\r\n Result := Token and DWORD($FFFFFF);\r\nend;\r\n\r\nclass function TJclPeMetadata.TokenCode(const Token: TJclClrToken): Integer;\r\nbegin\r\n Result := Token and $FF000000;\r\nend;\r\n\r\nclass function TJclPeMetadata.MakeToken(const Table: TJclClrTableKind;\r\n const Idx: Integer): TJclClrToken;\r\nbegin\r\n Result := (DWORD(Table) shl 24) and TokenIndex(Idx);\r\nend;\r\n\r\nfunction TJclPeMetadata.DumpIL: string;\r\nbegin\r\n with TStringList.Create do\r\n try\r\n case Image.Target of\r\n taWin32:\r\n begin\r\n Add(Format('.imagebase 0x%.8x', [Image.OptionalHeader32.ImageBase]));\r\n Add(Format('.subsystem 0x%.8x', [Image.OptionalHeader32.SubSystem]));\r\n Add(Format('.file alignment %d', [Image.OptionalHeader32.FileAlignment]));\r\n end;\r\n taWin64:\r\n begin\r\n Add(Format('.imagebase 0x%.16x', [Image.OptionalHeader64.ImageBase]));\r\n Add(Format('.subsystem 0x%.8x', [Image.OptionalHeader64.SubSystem]));\r\n Add(Format('.file alignment %d', [Image.OptionalHeader64.FileAlignment]));\r\n end;\r\n //taUnknown: ;\r\n end;\r\n\r\n if Assigned(FTableStream) then\r\n begin\r\n FTableStream.Update;\r\n Result := Text + NativeLineBreak + FTableStream.DumpIL;\r\n end;\r\n finally\r\n Free;\r\n end;\r\nend;\r\n\r\n//=== { TJclClrResourceRecord } ==============================================\r\n\r\nconstructor TJclClrResourceRecord.Create(const AData: PAnsiChar;\r\n const AOffset: DWORD; const ARVA: DWORD);\r\nbegin\r\n FData := AData;\r\n FOffset := AOffset;\r\n FRVA := ARVA;\r\n inherited Create(Pointer(TJclAddr(Data) + SizeOf(DWORD)), PDWORD(Data)^);\r\nend;\r\n\r\n//=== { TJclClrVTableFixupRecord } ===========================================\r\n\r\nconstructor TJclClrVTableFixupRecord.Create(AData: PImageCorVTableFixup);\r\nbegin\r\n inherited Create;\r\n FData := AData;\r\nend;\r\n\r\nfunction TJclClrVTableFixupRecord.GetCount: DWORD;\r\nbegin\r\n Result := Data.Count;\r\nend;\r\n\r\nfunction TJclClrVTableFixupRecord.GetKinds: TJclClrVTableKinds;\r\nbegin\r\n Result := VTableKinds(Data.Kind);\r\nend;\r\n\r\nfunction TJclClrVTableFixupRecord.GetRVA: DWORD;\r\nbegin\r\n Result := Data.RVA;\r\nend;\r\n\r\nclass function TJclClrVTableFixupRecord.VTableKinds(const Kinds: TJclClrVTableKinds): DWORD;\r\nvar\r\n AKind: TJclClrVTableKind;\r\nbegin\r\n Result := 0;\r\n for AKind := Low(TJclClrVTableKind) to High(TJclClrVTableKind) do\r\n if AKind in Kinds then\r\n Result := Result or ClrVTableKindMapping[AKind];\r\nend;\r\n\r\nclass function TJclClrVTableFixupRecord.VTableKinds(const Kinds: DWORD): TJclClrVTableKinds;\r\nvar\r\n AKind: TJclClrVTableKind;\r\nbegin\r\n Result := [];\r\n for AKind := Low(TJclClrVTableKind) to High(TJclClrVTableKind) do\r\n if (ClrVTableKindMapping[AKind] and Kinds) = ClrVTableKindMapping[AKind] then\r\n Include(Result, AKind);\r\nend;\r\n\r\n//=== { TJclClrInformation } =================================================\r\n\r\nconstructor TJclClrHeaderEx.Create(const AImage: TJclPeImage);\r\n\r\n procedure UpdateVTableFixups;\r\n begin\r\n // (rom) What is this?\r\n if Header.VTableFixups.VirtualAddress = 0 then\r\n end;\r\n\r\nbegin\r\n inherited Create(AImage);\r\n FFlags := ClrImageFlag(Header.Flags);\r\n FMetadata := nil;\r\n FResources := nil;\r\n FStrongNameSignature := nil;\r\n FVTableFixups := nil;\r\nend;\r\n\r\ndestructor TJclClrHeaderEx.Destroy;\r\nbegin\r\n FreeAndNil(FVTableFixups);\r\n FreeAndNil(FStrongNameSignature);\r\n FreeAndNil(FResources);\r\n FreeAndNil(FMetadata);\r\n inherited Destroy;\r\nend;\r\n\r\nclass function TJclClrHeaderEx.ClrImageFlag(const Flags: DWORD): TJclClrImageFlags;\r\nvar\r\n AFlag: TJclClrImageFlag;\r\nbegin\r\n Result := [];\r\n for AFlag := Low(TJclClrImageFlag) to High(TJclClrImageFlag) do\r\n if (ClrImageFlagMapping[AFlag] and Flags) = ClrImageFlagMapping[AFlag] then\r\n Include(Result, AFlag);\r\nend;\r\n\r\nclass function TJclClrHeaderEx.ClrImageFlag(const Flags: TJclClrImageFlags): DWORD;\r\nvar\r\n AFlag: TJclClrImageFlag;\r\nbegin\r\n Result := 0;\r\n for AFlag := Low(TJclClrImageFlag) to High(TJclClrImageFlag) do\r\n if AFlag in Flags then\r\n Result := Result or ClrImageFlagMapping[AFlag];\r\nend;\r\n\r\nfunction TJclClrHeaderEx.GetMetadata: TJclPeMetadata;\r\nbegin\r\n if not Assigned(FMetadata) and HasMetadata then\r\n FMetadata := TJclPeMetadata.Create(Image);\r\n Result := FMetadata;\r\nend;\r\n\r\nfunction TJclClrHeaderEx.HasStrongNameSignature: Boolean;\r\nbegin\r\n with Header.StrongNameSignature do\r\n Result := Assigned(FStrongNameSignature) or\r\n ((Size > 0) and not IsBadReadPtr(Image.RvaToVa(VirtualAddress), Size));\r\nend;\r\n\r\nfunction TJclClrHeaderEx.HasVTableFixup: Boolean;\r\nbegin\r\n with Header.VTableFixups do\r\n Result := Assigned(FVTableFixups) or\r\n ((Size > 0) and not IsBadReadPtr(Image.RvaToVa(VirtualAddress), Size));\r\nend;\r\n\r\nfunction TJclClrHeaderEx.GetStrongNameSignature: TCustomMemoryStream;\r\nbegin\r\n if not Assigned(FStrongNameSignature) and HasStrongNameSignature then\r\n with Header.StrongNameSignature do\r\n FStrongNameSignature := TJClreferenceMemoryStream.Create(Image.RvaToVa(VirtualAddress), Size);\r\n Result := FStrongNameSignature;\r\nend;\r\n\r\nfunction TJclClrHeaderEx.HasResources: Boolean;\r\nbegin\r\n with Header.Resources do\r\n Result := Assigned(FResources) or\r\n ((Size > 0) and not IsBadReadPtr(Image.RvaToVa(VirtualAddress), Size));\r\nend;\r\n\r\nprocedure TJclClrHeaderEx.UpdateResources;\r\nvar\r\n Base, Ptr, MappedBase: PAnsiChar;\r\n ARes: TJclClrResourceRecord;\r\nbegin\r\n FResources := TObjectList.Create;\r\n with Header.Resources do\r\n begin\r\n Base := Image.RvaToVa(VirtualAddress);\r\n Ptr := Base;\r\n while DWORD(Ptr - Base) < Size do\r\n begin\r\n MappedBase := PAnsiChar(Image.LoadedImage.MappedAddress);\r\n ARes := TJclClrResourceRecord.Create(Ptr, Ptr - Base, Ptr - MappedBase);\r\n FResources.Add(ARes);\r\n Ptr := PAnsiChar(ARes.Memory) + ARes.Size;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJclClrHeaderEx.GetResource(\r\n const Idx: Integer): TJclClrResourceRecord;\r\nbegin\r\n if not Assigned(FResources) and HasResources then\r\n UpdateResources;\r\n Result := TJclClrResourceRecord(FResources.Items[Idx]);\r\nend;\r\n\r\nfunction TJclClrHeaderEx.GetResourceCount: Integer;\r\nbegin\r\n if not Assigned(FResources) and HasResources then\r\n UpdateResources;\r\n if Assigned(FResources) then\r\n Result := FResources.Count\r\n else\r\n Result := 0;\r\nend;\r\n\r\nfunction TJclClrHeaderEx.GetEntryPointToken: TJclClrTableRow;\r\nbegin\r\n Result := Metadata.Tokens[Header.EntryPointToken]\r\nend;\r\n\r\nfunction TJclClrHeaderEx.GetVTableFixup(\r\n const Idx: Integer): TJclClrVTableFixupRecord;\r\nvar\r\n I: Integer;\r\n pData: PImageCorVTableFixup;\r\nbegin\r\n if not Assigned(FVTableFixups) and HasVTableFixup then\r\n begin\r\n FVTableFixups := TObjectList.Create;\r\n with Header.VTableFixups do\r\n begin\r\n pData := PImageCorVTableFixup(Image.RvaToVa(VirtualAddress));\r\n for I := 0 to GetVTableFixupCount - 1 do\r\n begin\r\n FVTableFixups.Add(TJclClrVTableFixupRecord.Create(pData));\r\n Inc(pData);\r\n end;\r\n end;\r\n end;\r\n Result := TJclClrVTableFixupRecord(FVTableFixups.Items[Idx]);\r\nend;\r\n\r\nfunction TJclClrHeaderEx.GetVTableFixupCount: Integer;\r\nbegin\r\n Result := Header.VTableFixups.Size div SizeOf(TImageCorVTableFixup);\r\nend;\r\n\r\nfunction TJclClrHeaderEx.ResourceAt(const Offset: DWORD): TJclClrResourceRecord;\r\nvar\r\n I: Integer;\r\nbegin\r\n if HasResources then\r\n for I := 0 to ResourceCount - 1 do\r\n begin\r\n Result := Resources[I];\r\n if Result.Offset = Offset then\r\n Exit;\r\n end;\r\n Result := nil;\r\nend;\r\n\r\nfunction TJclClrHeaderEx.DumpIL: string;\r\nbegin\r\n with TStringList.Create do\r\n try\r\n Add(LoadResString(@RsClrCopyright));\r\n Add(Format('.corflags 0x%.8x', [Header.Flags]));\r\n Result := Text + NativeLineBreak + Metadata.DumpIL;\r\n finally\r\n Free;\r\n end;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jcl/source/windows/JclCOM.pas", "content": "{**************************************************************************************************}\r\n{ }\r\n{ Project JEDI Code Library (JCL) }\r\n{ }\r\n{ The contents of this file are subject to the Mozilla Public License Version 1.1 (the \"License\"); }\r\n{ you may not use this file except in compliance with the License. You may obtain a copy of the }\r\n{ License at http://www.mozilla.org/MPL/ }\r\n{ }\r\n{ Software distributed under the License is distributed on an \"AS IS\" basis, WITHOUT WARRANTY OF }\r\n{ ANY KIND, either express or implied. See the License for the specific language governing rights }\r\n{ and limitations under the License. }\r\n{ }\r\n{ The Original Code is JclCOM.pas. }\r\n{ }\r\n{ The Initial Developer of the Original Code is Kevin S. Gallagher. Portions created by Kevin S. }\r\n{ Gallagher are Copyright (C) Kevin S. Gallagher. All Rights Reserved. }\r\n{ }\r\n{ Contributors: }\r\n{ Marcel van Brakel }\r\n{ Robert Marquardt (marquardt) }\r\n{ Scott Price (scottprice) }\r\n{ Robert Rossmair (rrossmair) }\r\n{ Olivier Sannier (obones) }\r\n{ Petr Vones (pvones) }\r\n{ }\r\n{**************************************************************************************************}\r\n{ }\r\n{ This unit contains Various COM (Component Object Model) utility routines. }\r\n{ }\r\n{**************************************************************************************************}\r\n{ }\r\n{ Last modified: $Date:: 2011-09-03 00:07:50 +0200 (sam. 03 sept. 2011) $ }\r\n{ Revision: $Rev:: 3599 $ }\r\n{ Author: $Author:: outchy $ }\r\n{ }\r\n{**************************************************************************************************}\r\n\r\nunit JclCOM;\r\n\r\n{$I jcl.inc}\r\n{$I windowsonly.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n {$IFDEF HAS_UNITSCOPE}\r\n Winapi.Windows, Winapi.ActiveX, System.Classes,\r\n {$ELSE ~HAS_UNITSCOPE}\r\n Windows, ActiveX, Classes,\r\n {$ENDIF ~HAS_UNITSCOPE}\r\n JclBase;\r\n\r\n// Various definitions\r\nconst\r\n { Class ID's that may be reused }\r\n CLSID_StdComponentCategoriesMgr: TGUID = '{0002E005-0000-0000-C000-000000000046}';\r\n\r\n CATID_SafeForInitializing: TGUID = '{7DD95802-9882-11CF-9FA9-00AA006C42C4}';\r\n CATID_SafeForScripting: TGUID = '{7DD95801-9882-11CF-9FA9-00AA006C42C4}';\r\n\r\n icMAX_CATEGORY_DESC_LEN = 128;\r\n\r\ntype\r\n { For use with the Internet Explorer Component Categories Routines. May be Reused. }\r\n TArrayCatID = array [0..0] of TGUID;\r\n\r\n// Exception classes\r\ntype\r\n EInvalidParam = class(EJclError);\r\n\r\n// DCOM and MDAC Related Tests and Utility Routines\r\nfunction IsDCOMInstalled: Boolean;\r\nfunction IsDCOMEnabled: Boolean;\r\nfunction GetDCOMVersion: string;\r\nfunction GetMDACVersion: string;\r\n\r\n// Other Marshalling Routines to complement \"CoMarshalInterThreadInterfaceInStream\"\r\n{ These routines will provide the ability to marshal an interface for a separate\r\n process or even for access by a separate machine. However, to make things\r\n familiar to users of the existing CoMarshal... routine, I have kept the required\r\n parameters the same, apart from the \"stm\" type now being a Var rather than just\r\n an Out - to allow a little flexibility if the developer wants the destination\r\n to be a specific stream, otherwise it creates one into the passed variable! }\r\n\r\nfunction MarshalInterThreadInterfaceInVarArray(const iid: TIID;\r\n unk: IUnknown; var VarArray: OleVariant): HRESULT;\r\nfunction MarshalInterProcessInterfaceInStream(const iid: TIID;\r\n unk: IUnknown; var stm: IStream): HRESULT;\r\nfunction MarshalInterProcessInterfaceInVarArray(const iid: TIID;\r\n unk: IUnknown; var VarArray: OleVariant): HRESULT;\r\nfunction MarshalInterMachineInterfaceInStream(const iid: TIID;\r\n unk: IUnknown; var stm: IStream): HRESULT;\r\nfunction MarshalInterMachineInterfaceInVarArray(const iid: TIID;\r\n unk: IUnknown; var VarArray: OleVariant): HRESULT;\r\n\r\n// Internet Explorer Component Categories Routines\r\n{ These routines help with the registration of:\r\n - Safe-Initialization &\r\n - Safe-for-Scripting\r\n of ActiveX controls or COM Automation Servers intended to be used in\r\n HTML pages displayed in Internet Explorer }\r\n{ Conversion of an example found in Microsoft Development Network document:\r\n MSDN Home > MSDN Library > ActiveX Controls > Overviews/Tutorials\r\n Safe Initialization and Scripting for ActiveX Controls }\r\n\r\nfunction CreateComponentCategory(const CatID: TGUID; const sDescription: string): HRESULT;\r\nfunction RegisterCLSIDInCategory(const ClassID: TGUID; const CatID: TGUID): HRESULT;\r\nfunction UnRegisterCLSIDInCategory(const ClassID: TGUID; const CatID: TGUID): HRESULT;\r\n\r\n// Stream Related Routines\r\n{ IDE ISSUE: These need to be at the bottom of the interface definition as otherwise\r\n the CTRL+SHIFT+ Up/Down arrows feature no-longer operates }\r\n\r\nfunction ResetIStreamToStart(Stream: IStream): Boolean;\r\nfunction SizeOfIStreamContents(Stream: IStream): Largeint;\r\n\r\n{ Use VarIsEmpty to determine the result of the following XStreamToVariantArray routines!\r\n VarIsEmptry will return True if VarClear was called - indicating major problem! }\r\n\r\nfunction StreamToVariantArray(Stream: TStream): OleVariant; overload;\r\nfunction StreamToVariantArray(Stream: IStream): OleVariant; overload;\r\n\r\nprocedure VariantArrayToStream(VarArray: OleVariant; var Stream: TStream); overload;\r\nprocedure VariantArrayToStream(VarArray: OleVariant; var Stream: IStream); overload;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jcl.svn.sourceforge.net/svnroot/jcl/tags/JCL-2.4-Build4571/jcl/source/windows/JclCOM.pas $';\r\n Revision: '$Revision: 3599 $';\r\n Date: '$Date: 2011-09-03 00:07:50 +0200 (sam. 03 sept. 2011) $';\r\n LogPath: 'JCL\\source\\windows';\r\n Extra: '';\r\n Data: nil\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n {$IFDEF FPC}\r\n Types,\r\n {$ENDIF FPC}\r\n {$IFDEF HAS_UNITSCOPE}\r\n System.SysUtils, System.Variants,\r\n {$ELSE ~HAS_UNITSCOPE}\r\n SysUtils, Variants,\r\n {$ENDIF ~HAS_UNITSCOPE}\r\n JclFileUtils, JclRegistry, JclResources, JclSysInfo, JclWin32;\r\n\r\n{implementation Constants - may be reused by more than one routine }\r\n\r\nconst\r\n pcOLE32 = 'OLE32.dll';\r\n\r\n { TODO : Utility routine here might need to be re-vamped with the\r\n use of JclUnicode unit in mind. }\r\n\r\nfunction StringToWideString(const Str: string): WideString;\r\nvar\r\n iLen: Integer;\r\nbegin\r\n iLen:= Length(Str) + 1;\r\n SetLength(Result, (iLen - 1));\r\n StringToWideChar(Str, PWideChar(Result), iLen);\r\nend;\r\n\r\n//=== DCOM and MDAC Related Tests and Utility Routines =======================\r\n\r\nfunction IsDCOMInstalled: Boolean;\r\nvar\r\n OLE32: HMODULE;\r\nbegin\r\n { DCOM is installed by default on all but Windows 95 }\r\n Result := not (GetWindowsVersion in [wvUnknown, wvWin95, wvWin95OSR2]);\r\n if not Result then\r\n begin\r\n OLE32 := SafeLoadLibrary(pcOLE32);\r\n if OLE32 > 0 then\r\n try\r\n Result := GetProcAddress(OLE32, PChar('CoCreateInstanceEx')) <> nil;\r\n finally\r\n FreeLibrary(OLE32);\r\n end;\r\n end;\r\nend;\r\n\r\nfunction IsDCOMEnabled: Boolean;\r\nvar\r\n RegValue: string;\r\nbegin\r\n RegValue := RegReadString(HKEY_LOCAL_MACHINE, 'SOFTWARE\\Microsoft\\OLE', 'EnableDCOM');\r\n Result := (RegValue = 'y') or (RegValue = 'Y');\r\nend;\r\n\r\nfunction GetDCOMVersion: string;\r\nconst\r\n DCOMVersionKey: PChar = 'CLSID\\{bdc67890-4fc0-11d0-a805-00aa006d2ea4}\\InstalledVersion';\r\nbegin\r\n { NOTE: This does not work on Windows NT/2000! For a list of DCOM versions:\r\n http://support.microsoft.com/support/kb/articles/Q235/6/38.ASP }\r\n Result := '';\r\n if (Win32Platform = VER_PLATFORM_WIN32_WINDOWS) and IsDCOMEnabled then\r\n Result := RegReadString(HKEY_CLASSES_ROOT, DCOMVersionKey, '')\r\n else\r\n { Possibly from DComExt.dll Product Version }\r\n Result := 'DCOM Version Unknown';\r\nend;\r\n\r\n{ NOTE: Checking whether MDAC is installed at all can be done by querying the\r\n Software\\Microsoft\\DataAccess key for the FullInstallVer or\r\n Fill32InstallVer values. Windows 2000 always installs MDAC 2.5 }\r\n\r\nfunction GetMDACVersion: string;\r\nvar\r\n Key: string;\r\n DLL: string;\r\n Version: TJclFileVersionInfo;\r\nbegin\r\n Result := '' ;\r\n Key := RegReadString(HKEY_CLASSES_ROOT, 'ADODB.Connection\\CLSID', '');\r\n DLL := RegReadString(HKEY_CLASSES_ROOT, 'CLSID\\' + Key + '\\InprocServer32', '');\r\n if VersionResourceAvailable(DLL) then\r\n begin\r\n Version := TJclFileVersionInfo.Create(DLL);\r\n try\r\n Result := Version.ProductVersion;\r\n finally\r\n FreeAndNil(Version);\r\n end;\r\n end;\r\nend;\r\n\r\n// Other Marshalling Routines to complement \"CoMarshalInterThreadInterfaceInStream\"\r\n\r\nfunction MarshalInterThreadInterfaceInVarArray(const iid: TIID; unk: IUnknown;\r\n var VarArray: OleVariant): HRESULT;\r\nvar\r\n msData: TMemoryStream;\r\n itfStream: IStream;\r\nbegin\r\n { TODO -cTest : D4, D5, D6 (CBx ??) }\r\n try\r\n { Will need a stream to obtain the data initially before creating the Variant Array }\r\n msData := TMemoryStream.Create;\r\n\r\n itfStream := (TStreamAdapter.Create(msData, soOwned) as IStream);\r\n\r\n { Probably would never get here in such a condition, but just in case }\r\n if itfStream = nil then\r\n begin\r\n Result := E_OUTOFMEMORY;\r\n Exit;\r\n end;\r\n\r\n if itfStream <> nil then\r\n begin\r\n { Different Machine }\r\n Result := CoMarshalInterThreadInterfaceInStream(iid, unk, itfStream);\r\n\r\n if Result <> S_OK then\r\n Exit;\r\n\r\n VarArray := StreamToVariantArray(itfStream);\r\n\r\n if VarIsNull(VarArray) or VarIsEmpty(VarArray) then\r\n Result := E_FAIL;\r\n end\r\n else\r\n { TODO : Most likely out of memory, though should not reach here }\r\n Result := E_POINTER;\r\n except\r\n Result := E_UNEXPECTED;\r\n end;\r\nend;\r\n\r\nfunction MarshalInterProcessInterfaceInStream(const iid: TIID; unk: IUnknown;\r\n var stm: IStream): HRESULT;\r\nvar\r\n msData: TMemoryStream;\r\nbegin\r\n { TODO -cTest : D4 (CBx ??) }\r\n try\r\n { If passed a variable which doesn't contain a valid stream, create and return }\r\n if stm = nil then\r\n begin\r\n msData := TMemoryStream.Create;\r\n\r\n stm := (TStreamAdapter.Create(msData, soOwned) as IStream);\r\n\r\n { Probably would never get here in such a condition, but just in case }\r\n if stm = nil then\r\n begin\r\n Result := E_OUTOFMEMORY;\r\n Exit;\r\n end;\r\n end\r\n else\r\n ResetIStreamToStart(stm);\r\n\r\n if stm <> nil then\r\n { Same Machine, Different Process}\r\n Result := CoMarshalInterface(stm, iid, unk, MSHCTX_LOCAL, nil, MSHLFLAGS_NORMAL)\r\n else\r\n { TODO : Most likely out of memory, though should not reach here }\r\n Result := E_POINTER;\r\n except\r\n Result := E_UNEXPECTED;\r\n end;\r\nend;\r\n\r\nfunction MarshalInterProcessInterfaceInVarArray(const iid: TIID;\r\n unk: IUnknown; var VarArray: OleVariant): HRESULT;\r\nvar\r\n itfStream: IStream;\r\nbegin\r\n { TODO -cTest : D4 (CBx ??) }\r\n itfStream := nil;\r\n Result := MarshalInterProcessInterfaceInStream(iid, unk, itfStream);\r\n\r\n if Result <> S_OK then\r\n Exit;\r\n\r\n { TODO : Add compiler support for using a VCL Stream instead of an IStream here }\r\n { Otherwise convert from IStream into Variant Array }\r\n VarArray := StreamToVariantArray(itfStream);\r\n\r\n if VarIsNull(VarArray) or VarIsEmpty(VarArray) then\r\n Result := E_FAIL;\r\nend;\r\n\r\nfunction MarshalInterMachineInterfaceInStream(const iid: TIID; unk: IUnknown;\r\n var stm: IStream): HRESULT;\r\nvar\r\n msData: TMemoryStream;\r\nbegin\r\n { TODO -cTest : D4 (CBx ??) Have no need for it myself at present. }\r\n try\r\n { If passed a variable which doesn't contain a valid stream, create and return }\r\n if stm = nil then\r\n begin\r\n msData := TMemoryStream.Create;\r\n\r\n stm := (TStreamAdapter.Create(msData, soOwned) as IStream);\r\n\r\n { Probably would never get here in such a condition, but just in case }\r\n if stm = nil then\r\n begin\r\n Result := E_OUTOFMEMORY;\r\n Exit;\r\n end;\r\n end\r\n else\r\n ResetIStreamToStart(stm);\r\n\r\n if stm <> nil then\r\n { Different Machine }\r\n Result := CoMarshalInterface(stm, iid, unk, MSHCTX_DIFFERENTMACHINE, nil, MSHLFLAGS_NORMAL)\r\n else\r\n { TODO : Most likely out of memory, though should not reach here }\r\n Result := E_POINTER;\r\n except\r\n Result := E_UNEXPECTED;\r\n end;\r\nend;\r\n\r\nfunction MarshalInterMachineInterfaceInVarArray(const iid: TIID; unk: IUnknown;\r\n var VarArray: OleVariant): HRESULT;\r\nvar\r\n itfStream: IStream;\r\nbegin\r\n { TODO -cTest : D4 (CBx ??) }\r\n itfStream := nil;\r\n Result := MarshalInterMachineInterfaceInStream(iid, unk, itfStream);\r\n\r\n if Result <> S_OK then\r\n Exit;\r\n\r\n { TODO : Add compiler support for using a VCL Stream instead of an IStream here }\r\n { Otherwise convert from IStream into Variant Array }\r\n VarArray := StreamToVariantArray(itfStream);\r\n\r\n if VarIsNull(VarArray) or VarIsEmpty(VarArray) then\r\n Result := E_FAIL;\r\nend;\r\n\r\n//=== Internet Explorer Component Categories Routines ========================\r\n\r\nfunction CreateComponentCategory(const CatID: TGUID; const sDescription: string): HRESULT;\r\nvar\r\n CatRegister: ICatRegister;\r\n hr: HRESULT;\r\n CatInfo: TCATEGORYINFO;\r\n iLen: Integer;\r\n sTemp: string;\r\n wsTemp: WideString;\r\nbegin\r\n { TODO -cTest : D4 (CBx ??) }\r\n CatRegister := nil;\r\n\r\n hr := CoCreateInstance(CLSID_StdComponentCategoriesMgr,\r\n nil, CLSCTX_INPROC_SERVER, ICatRegister, CatRegister);\r\n\r\n if Succeeded(hr) then\r\n try\r\n (* Make sure the:\r\n HKCR\\Component Categories\\{..catid...}\r\n key is registered *)\r\n CatInfo.catid := CatID;\r\n CatInfo.lcid := MAKELANGID(LANG_ENGLISH, SUBLANG_ENGLISH_US); // english\r\n\r\n { Make sure the provided description is not too long.\r\n Only copy the first 127 characters if it is. }\r\n iLen := Length(sDescription);\r\n if iLen > icMAX_CATEGORY_DESC_LEN then\r\n iLen := icMAX_CATEGORY_DESC_LEN;\r\n\r\n sTemp := Copy(sDescription, 1, iLen);\r\n wsTemp := StringToWideString(sTemp); \r\n\r\n Move(Pointer(wsTemp)^, CatInfo.szDescription, (iLen * SizeOf(WideChar)));\r\n\r\n hr := CatRegister.RegisterCategories(1, @CatInfo);\r\n finally\r\n CatRegister := nil;\r\n end;\r\n\r\n { Return the appropriate Result }\r\n Result := hr;\r\nend;\r\n\r\nfunction RegisterCLSIDInCategory(const ClassID: TGUID; const CatID: TGUID): HRESULT;\r\nvar\r\n CatRegister: ICatRegister;\r\n hr: HRESULT;\r\n arCatID: TArrayCatID;\r\nbegin\r\n { TODO -cTest : D4 (CBx ??) }\r\n { Register your component categories information }\r\n CatRegister := nil;\r\n hr := CoCreateInstance(CLSID_StdComponentCategoriesMgr,\r\n nil, CLSCTX_INPROC_SERVER, ICatRegister, CatRegister);\r\n\r\n if Succeeded(hr) then\r\n try\r\n { Register this category as being \"implemented\" by the class }\r\n arCatID[0] := CatID;\r\n hr := CatRegister.RegisterClassImplCategories(ClassID, 1, @arCatID);\r\n finally\r\n CatRegister := nil;\r\n end;\r\n\r\n { Return the appropriate Result }\r\n Result := hr;\r\nend;\r\n\r\nfunction UnRegisterCLSIDInCategory(const ClassID: TGUID; const CatID: TGUID): HRESULT;\r\nvar\r\n CatRegister: ICatRegister;\r\n hr: HRESULT;\r\n arCatID: TArrayCatID;\r\nbegin\r\n { TODO -cTest : D4 (CBx ??) }\r\n CatRegister := nil;\r\n\r\n hr := CoCreateInstance(CLSID_StdComponentCategoriesMgr,\r\n nil, CLSCTX_INPROC_SERVER, ICatRegister, CatRegister);\r\n\r\n if Succeeded(hr) then\r\n try\r\n { Unregister this category as being \"implemented\" by the class }\r\n arCatID[0] := CatID;\r\n hr := CatRegister.UnRegisterClassImplCategories(ClassID, 1, @arCatID);\r\n finally\r\n CatRegister := nil;\r\n end;\r\n\r\n { Return the appropriate Result }\r\n Result := hr;\r\nend;\r\n\r\n//=== Stream Related Routines ================================================\r\n\r\nfunction ResetIStreamToStart(Stream: IStream): Boolean;\r\nvar\r\n i64Pos: Largeint;\r\n hrSeek: HRESULT;\r\nbegin\r\n { TODO -cTest : D4 (CBx ??) }\r\n { Try to get the current stream position, and reset to start if not already there }\r\n if Succeeded(Stream.Seek(0, STREAM_SEEK_CUR, i64Pos)) then\r\n begin\r\n if i64Pos = 0 then\r\n hrSeek := S_OK\r\n else\r\n hrSeek := Stream.Seek(0, STREAM_SEEK_SET, i64Pos);\r\n { Another possible option was seen as:\r\n - Stream.Seek(0, STREAM_SEEK_SET, NULL); }\r\n\r\n Result := (hrSeek = S_OK);\r\n end\r\n else\r\n Result := False;\r\nend;\r\n\r\nfunction SizeOfIStreamContents(Stream: IStream): Largeint;\r\nvar\r\n stat: TStatStg;\r\nbegin\r\n { TODO -cTest : D4 (CBx ??) }\r\n { If we can't determine the size of the Stream, then return -1 for Unattainable }\r\n if Succeeded(Stream.Stat(stat, STATFLAG_NONAME)) then\r\n Result := stat.cbSize\r\n else\r\n Result := -1;\r\nend;\r\n\r\nfunction StreamToVariantArray(Stream: TStream): OleVariant;\r\nvar\r\n pLocked: Pointer;\r\nbegin\r\n { Use VarIsEmpty to determine the result of this method!\r\n VarIsEmptry will return True if VarClear was called - indicating major problem! }\r\n\r\n { TODO -cTest : D4 (CBx ??) }\r\n { Obviously, we must have a valid stream to perform this on }\r\n if not Assigned(Stream) then\r\n raise EInvalidParam.CreateRes(@RsComInvalidParam);\r\n\r\n if Stream.Size > 0 then\r\n begin\r\n Result := VarArrayCreate([0, Stream.Size - 1], varByte);\r\n try\r\n pLocked := VarArrayLock(Result);\r\n try\r\n Stream.Position := 0;\r\n Stream.Read(pLocked^, Stream.Size);\r\n finally\r\n VarArrayUnlock(Result);\r\n end;\r\n except\r\n { If we get an exception, clean up the Variant so as not to return incomplete data! }\r\n VarClear(Result);\r\n\r\n { Alternative: Re-Raise this Exception\r\n raise; }\r\n end;\r\n end\r\n else\r\n { Stream has no data! }\r\n Result := Null;\r\nend;\r\n\r\nfunction StreamToVariantArray(Stream: IStream): OleVariant;\r\nvar\r\n pLocked: Pointer;\r\n iSize: Largeint;\r\n iReadCount: LongInt;\r\nbegin\r\n { Use VarIsEmpty to determine the result of this method!\r\n VarIsEmptry will return True if VarClear was called - indicating major problem! }\r\n\r\n { TODO -cTest : D4 (CBx ??) }\r\n { Obviously, we must have a valid stream to perform this on }\r\n if not Assigned(Stream) then\r\n raise EInvalidParam.CreateRes(@RsComInvalidParam);\r\n\r\n iSize := SizeOfIStreamContents(Stream);\r\n if iSize > 0 then\r\n begin\r\n if ResetIStreamToStart(Stream) then\r\n begin\r\n Result := VarArrayCreate([0, iSize - 1], varByte);\r\n try\r\n pLocked := VarArrayLock(Result);\r\n try\r\n Stream.Read(pLocked, iSize, @iReadCount);\r\n\r\n if iReadCount <> iSize then\r\n { Error! Didn't read all content! }\r\n raise EInOutError.CreateRes(@RsComFailedStreamRead);\r\n finally\r\n VarArrayUnlock(Result);\r\n end;\r\n except\r\n { If we get an exception, clean up the Variant so as not to return incomplete data! }\r\n VarClear(Result);\r\n\r\n { Alternative: Re-Raise this Exception\r\n raise; }\r\n end;\r\n end\r\n else\r\n { Unable to Reset the Stream to Start! Return Null Variant }\r\n Result := Null;\r\n end\r\n else\r\n { Stream has no data! }\r\n Result := Null;\r\nend;\r\n\r\nprocedure VariantArrayToStream(VarArray: OleVariant; var Stream: TStream);\r\nvar\r\n pLocked: Pointer;\r\nbegin\r\n { TODO -cTest : D4 (CBx ??) }\r\n { Check if the Variant is Empty or Null }\r\n if VarIsEmpty(VarArray) or VarIsNull(VarArray) then\r\n raise EInvalidParam.CreateRes(@RsComInvalidParam);\r\n\r\n { TODO : Should we allow them to write to the Stream, not matter what position it is at? }\r\n if Assigned(Stream) then\r\n Stream.Position := 0\r\n else\r\n Stream := TMemoryStream.Create;\r\n\r\n Stream.Size := VarArrayHighBound(VarArray, 1) - VarArrayLowBound(VarArray, 1) + 1;\r\n pLocked := VarArrayLock(VarArray);\r\n try\r\n Stream.Write(pLocked^, Stream.Size);\r\n finally\r\n VarArrayUnlock(VarArray);\r\n Stream.Position := 0;\r\n end;\r\nend;\r\n\r\nprocedure VariantArrayToStream(VarArray: OleVariant; var Stream: IStream);\r\nvar\r\n pLocked: Pointer;\r\n bCreated: Boolean;\r\n iSize: Largeint;\r\n iWriteCount: LongInt;\r\nbegin\r\n { TODO -cTest : D4 (CBx ??) }\r\n { Check if the Variant is Empty or Null }\r\n if VarIsEmpty(VarArray) or VarIsNull(VarArray) then\r\n raise EInvalidParam.CreateRes(@RsComInvalidParam);\r\n\r\n bCreated := False;\r\n\r\n { TODO : Should we allow them to write to the Stream, not matter what position it is at? }\r\n if Assigned(Stream) then\r\n ResetIStreamToStart(Stream)\r\n else\r\n begin\r\n Stream := (TStreamAdapter.Create(TMemoryStream.Create, soOwned) as IStream);\r\n bCreated := True;\r\n end;\r\n\r\n { Check to ensure creation went well, otherwise we might have run out of memory }\r\n if Stream <> nil then\r\n begin\r\n iSize := VarArrayHighBound(VarArray, 1) - VarArrayLowBound(VarArray, 1) + 1;\r\n try\r\n Stream.SetSize(iSize);\r\n pLocked := VarArrayLock(VarArray);\r\n try\r\n Stream.Write(pLocked, iSize, @iWriteCount);\r\n\r\n if iWriteCount <> iSize then\r\n raise EInOutError.CreateRes(@RsComFailedStreamWrite);\r\n finally\r\n VarArrayUnlock(VarArray);\r\n ResetIStreamToStart(Stream);\r\n end;\r\n except\r\n if bCreated then\r\n Stream := nil;\r\n\r\n raise; { Re-Raise this Exception }\r\n end;\r\n end;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jcl/source/windows/JclCommCtrlAdmin.manifest", "content": "\r\n\r\n \r\n \r\n \r\n \r\n \r\n \r\n \r\n \r\n \r\n \r\n \r\n \r\n \r\n\r\n" }, { "path": "External/Jedi/Jcl/source/windows/JclCommCtrlAdmin.rc", "content": "/****************************************************************************************************\r\n\r\n VistaElevate.rc\r\n\r\n****************************************************************************************************/\r\n\r\nLANGUAGE 0,0 1 24 \"JclCommCtrlAdmin.manifest\"\r\n" }, { "path": "External/Jedi/Jcl/source/windows/JclCommCtrlAsInvoker.manifest", "content": "\r\n\r\n \r\n \r\n \r\n \r\n \r\n \r\n \r\n \r\n \r\n \r\n \r\n \r\n \r\n\r\n" }, { "path": "External/Jedi/Jcl/source/windows/JclCommCtrlAsInvoker.rc", "content": "/****************************************************************************************************\r\n\r\n VistaElevate.rc\r\n\r\n****************************************************************************************************/\r\n\r\nLANGUAGE 0,0 1 24 \"JclCommCtrlAsInvoker.manifest\"\r\n" }, { "path": "External/Jedi/Jcl/source/windows/JclConsole.pas", "content": "{**************************************************************************************************}\r\n{ }\r\n{ Project JEDI Code Library (JCL) }\r\n{ }\r\n{ The contents of this file are subject to the Mozilla Public License Version 1.1 (the \"License\"); }\r\n{ you may not use this file except in compliance with the License. You may obtain a copy of the }\r\n{ License at http://www.mozilla.org/MPL/ }\r\n{ }\r\n{ Software distributed under the License is distributed on an \"AS IS\" basis, WITHOUT WARRANTY OF }\r\n{ ANY KIND, either express or implied. See the License for the specific language governing rights }\r\n{ and limitations under the License. }\r\n{ }\r\n{ The Original Code is JclConsole.pas. }\r\n{ }\r\n{ The Initial Developer of the Original Code is Flier Lu. Portions created by Flier Lu are }\r\n{ Copyright (C) Flier Lu. All Rights Reserved. }\r\n{ }\r\n{ Contributors: }\r\n{ Flier Lu (flier) }\r\n{ Robert Marquardt (marquardt) }\r\n{ Robert Rossmair (rrossmair) }\r\n{ Petr Vones (pvones) }\r\n{ }\r\n{**************************************************************************************************}\r\n{ }\r\n{ This unit contains classes and routines to support windows Character-Mode Applications }\r\n{ }\r\n{**************************************************************************************************}\r\n{ }\r\n{ Last modified: $Date:: 2012-02-12 23:30:08 +0100 (dim. 12 févr. 2012) $ }\r\n{ Revision: $Rev:: 3724 $ }\r\n{ Author: $Author:: jfudickar $ }\r\n{ }\r\n{**************************************************************************************************}\r\n\r\nunit JclConsole;\r\n\r\n{$I jcl.inc}\r\n{$I windowsonly.inc}\r\n\r\n{$HPPEMIT 'namespace JclConsole'}\r\n(*$HPPEMIT '{'*)\r\n{$HPPEMIT '__interface IJclScreenTextAttribute;'}\r\n(*$HPPEMIT '}'*)\r\n{$HPPEMIT 'using namespace JclConsole;'}\r\n{$HPPEMIT ''}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n {$IFDEF HAS_UNITSCOPE}\r\n Winapi.Windows, System.Classes, System.SysUtils, System.Contnrs,\r\n {$ELSE ~HAS_UNITSCOPE}\r\n Windows, Classes, SysUtils, Contnrs,\r\n {$ENDIF ~HAS_UNITSCOPE}\r\n JclBase;\r\n\r\n// Console\r\ntype\r\n TJclScreenBuffer = class;\r\n TJclInputBuffer = class;\r\n\r\n TJclConsole = class(TObject)\r\n private\r\n FScreens: TObjectList;\r\n FActiveScreenIndex: Longword;\r\n FInput: TJclInputBuffer;\r\n FOnCtrlC: TNotifyEvent;\r\n FOnCtrlBreak: TNotifyEvent;\r\n FOnClose: TNotifyEvent;\r\n FOnLogOff: TNotifyEvent;\r\n FOnShutdown: TNotifyEvent;\r\n function GetScreen(const Idx: Longword): TJclScreenBuffer;\r\n function GetScreenCount: Longword;\r\n function GetActiveScreen: TJclScreenBuffer;\r\n procedure SetActiveScreen(const Value: TJclScreenBuffer);\r\n procedure SetActiveScreenIndex(const Value: Longword);\r\n function GetTitle: string;\r\n procedure SetTitle(const Value: string);\r\n function GetInputCodePage: DWORD;\r\n function GetOutputCodePage: DWORD;\r\n procedure SetInputCodePage(const Value: DWORD);\r\n procedure SetOutputCodePage(const Value: DWORD);\r\n public\r\n constructor Create;\r\n destructor Destroy; override;\r\n class function Default: TJclConsole;\r\n class procedure Shutdown;\r\n { TODO : Add 'Attach' and other functions for WinXP/Win.Net }\r\n class function IsConsole(const Module: HMODULE): Boolean; overload;\r\n class function IsConsole(const FileName: TFileName): Boolean; overload;\r\n class function MouseButtonCount: DWORD;\r\n class procedure Alloc;\r\n class procedure Free;\r\n function Add(AWidth: Smallint = 0; AHeight: Smallint = 0): TJclScreenBuffer;\r\n function Remove(const ScrBuf: TJclScreenBuffer): Longword;\r\n procedure Delete(const Idx: Longword);\r\n property Title: string read GetTitle write SetTitle;\r\n property InputCodePage: DWORD read GetInputCodePage write SetInputCodePage;\r\n property OutputCodePage: DWORD read GetOutputCodePage write SetOutputCodePage;\r\n property Input: TJclInputBuffer read FInput;\r\n property Screens[const Idx: Longword]: TJclScreenBuffer read GetScreen;\r\n property ScreenCount: Longword read GetScreenCount;\r\n property ActiveScreenIndex: Longword read FActiveScreenIndex write SetActiveScreenIndex;\r\n property ActiveScreen: TJclScreenBuffer read GetActiveScreen write SetActiveScreen;\r\n property OnCtrlC: TNotifyEvent read FOnCtrlC write FOnCtrlC;\r\n property OnCtrlBreak: TNotifyEvent read FOnCtrlBreak write FOnCtrlBreak;\r\n property OnClose: TNotifyEvent read FOnClose write FOnClose;\r\n property OnLogOff: TNotifyEvent read FOnLogOff write FOnLogOff;\r\n property OnShutdown: TNotifyEvent read FOnShutdown write FOnShutdown;\r\n end;\r\n\r\n TJclConsoleInputMode = (imLine, imEcho, imProcessed, imWindow, imMouse);\r\n TJclConsoleInputModes = set of TJclConsoleInputMode;\r\n TJclConsoleOutputMode = (omProcessed, omWrapAtEol);\r\n TJclConsoleOutputModes = set of TJclConsoleOutputMode;\r\n\r\n IJclScreenTextAttribute = interface;\r\n TJclScreenFont = class;\r\n TJclScreenCharacter = class;\r\n TJclScreenCursor = class;\r\n TJclScreenWindow = class;\r\n\r\n // Console screen buffer\r\n TJclScreenBufferBeforeResizeEvent = procedure(Sender: TObject; const NewSize: TCoord; var CanResize: Boolean) of object;\r\n TJclScreenBufferAfterResizeEvent = procedure(Sender: TObject) of object;\r\n\r\n TJclScreenBufferTextHorizontalAlign = (thaCurrent, thaLeft, thaCenter, thaRight);\r\n TJclScreenBufferTextVerticalAlign = (tvaCurrent, tvaTop, tvaCenter, tvaBottom);\r\n\r\n TJclScreenBuffer = class(TObject)\r\n private\r\n FHandle: THandle;\r\n FFont: TJclScreenFont;\r\n FCursor: TJclScreenCursor;\r\n FWindow: TJclScreenWindow;\r\n FCharList: TObjectList;\r\n FOnAfterResize: TJclScreenBufferAfterResizeEvent;\r\n FOnBeforeResize: TJclScreenBufferBeforeResizeEvent;\r\n function GetInfo: TConsoleScreenBufferInfo;\r\n function GetSize: TCoord;\r\n procedure SetSize(const Value: TCoord);\r\n function GetHeight: Smallint;\r\n function GetWidth: Smallint;\r\n procedure SetHeight(const Value: Smallint);\r\n procedure SetWidth(const Value: Smallint);\r\n function GetMode: TJclConsoleOutputModes;\r\n procedure SetMode(const Value: TJclConsoleOutputModes);\r\n protected\r\n procedure Init;\r\n procedure DoResize(const NewSize: TCoord); overload;\r\n procedure DoResize(const NewWidth, NewHeight: Smallint); overload;\r\n property Info: TConsoleScreenBufferInfo read GetInfo;\r\n public\r\n constructor Create; overload;\r\n constructor Create(const AHandle: THandle); overload;\r\n constructor Create(const AWidth, AHeight: Smallint); overload;\r\n destructor Destroy; override;\r\n function Write(const Text: string;\r\n const ATextAttribute: IJclScreenTextAttribute = nil): DWORD; overload;\r\n function Writeln(const Text: string = '';\r\n const ATextAttribute: IJclScreenTextAttribute = nil): DWORD; overload;\r\n function Write(const Text: string; const X: Smallint; const Y: Smallint;\r\n const ATextAttribute: IJclScreenTextAttribute = nil): DWORD; overload;\r\n function Write(const Text: string; const X: Smallint; const Y: Smallint;\r\n pAttrs: PWORD): DWORD; overload;\r\n function Write(const Text: string;\r\n const HorizontalAlign: TJclScreenBufferTextHorizontalAlign;\r\n const VerticalAlign: TJclScreenBufferTextVerticalAlign = tvaCurrent;\r\n const ATextAttribute: IJclScreenTextAttribute = nil): DWORD; overload;\r\n function Read(const Count: Integer): string; overload;\r\n function Read(X: Smallint; Y: Smallint; const Count: Integer): string; overload;\r\n function Readln: string; overload;\r\n function Readln(X: Smallint; Y: Smallint): string; overload;\r\n procedure Fill(const ch: Char; const ATextAttribute: IJclScreenTextAttribute = nil);\r\n procedure Clear;\r\n property Handle: THandle read FHandle;\r\n property Font: TJclScreenFont read FFont;\r\n property Cursor: TJclScreenCursor read FCursor;\r\n property Window: TJclScreenWindow read FWindow;\r\n property Size: TCoord read GetSize write SetSize;\r\n property Width: Smallint read GetWidth write SetWidth;\r\n property Height: Smallint read GetHeight write SetHeight;\r\n property Mode: TJclConsoleOutputModes read GetMode write SetMode;\r\n property OnBeforeResize: TJclScreenBufferBeforeResizeEvent read FOnBeforeResize write FOnBeforeResize;\r\n property OnAfterResize: TJclScreenBufferAfterResizeEvent read FOnAfterResize write FOnAfterResize;\r\n end;\r\n\r\n // Console screen text attributes\r\n TJclScreenFontColor = (fclBlack, fclBlue, fclGreen, fclRed, fclCyan, fclMagenta, fclYellow, fclWhite);\r\n TJclScreenBackColor = (bclBlack, bclBlue, bclGreen, bclRed, bclCyan, bclMagenta, bclYellow, bclWhite);\r\n TJclScreenFontStyle = (fsLeadingByte, fsTrailingByte, fsGridHorizontal, fsGridLeftVertical, fsGridRightVertical, fsReverseVideo, fsUnderscore, fsSbcsDbcs);\r\n TJclScreenFontStyles = set of TJclScreenFontStyle;\r\n\r\n IJclScreenTextAttribute = interface\r\n ['{B880B1AC-9F1A-4F42-9D44-EA482B4F3510}']\r\n function GetTextAttribute: Word;\r\n procedure SetTextAttribute(const Value: Word);\r\n\r\n property TextAttribute: Word read GetTextAttribute write SetTextAttribute;\r\n\r\n function GetColor: TJclScreenFontColor;\r\n procedure SetColor(const Value: TJclScreenFontColor);\r\n function GetBgColor: TJclScreenBackColor;\r\n procedure SetBgColor(const Value: TJclScreenBackColor);\r\n function GetHighlight: Boolean;\r\n procedure SetHighlight(const Value: Boolean);\r\n function GetBgHighlight: Boolean;\r\n procedure SetBgHighlight(const Value: Boolean);\r\n function GetStyle: TJclScreenFontStyles;\r\n procedure SetStyle(const Value: TJclScreenFontStyles);\r\n\r\n property Color: TJclScreenFontColor read GetColor write SetColor;\r\n property BgColor: TJclScreenBackColor read GetBgColor write SetBgColor;\r\n property Highlight: Boolean read GetHighlight write SetHighlight;\r\n property BgHighlight: Boolean read GetBgHighlight write SetBgHighlight;\r\n property Style: TJclScreenFontStyles read GetStyle write SetStyle;\r\n end;\r\n\r\n TJclScreenCustomTextAttribute = class(TInterfacedObject, IJclScreenTextAttribute)\r\n public\r\n constructor Create(const Attr: TJclScreenCustomTextAttribute = nil); overload;\r\n\r\n procedure Clear;\r\n\r\n { IJclScreenTextAttribute }\r\n function GetTextAttribute: Word; virtual; abstract;\r\n procedure SetTextAttribute(const Value: Word); virtual; abstract;\r\n\r\n property TextAttribute: Word read GetTextAttribute write SetTextAttribute;\r\n\r\n function GetColor: TJclScreenFontColor;\r\n procedure SetColor(const Value: TJclScreenFontColor);\r\n function GetBgColor: TJclScreenBackColor;\r\n procedure SetBgColor(const Value: TJclScreenBackColor);\r\n function GetHighlight: Boolean;\r\n procedure SetHighlight(const Value: Boolean);\r\n function GetBgHighlight: Boolean;\r\n procedure SetBgHighlight(const Value: Boolean);\r\n function GetStyle: TJclScreenFontStyles;\r\n procedure SetStyle(const Value: TJclScreenFontStyles);\r\n\r\n property Color: TJclScreenFontColor read GetColor write SetColor;\r\n property BgColor: TJclScreenBackColor read GetBgColor write SetBgColor;\r\n property Highlight: Boolean read GetHighlight write SetHighlight;\r\n property BgHighlight: Boolean read GetBgHighlight write SetBgHighlight;\r\n property Style: TJclScreenFontStyles read GetStyle write SetStyle;\r\n end;\r\n\r\n TJclScreenFont = class(TJclScreenCustomTextAttribute, IJclScreenTextAttribute)\r\n private\r\n FScreenBuffer: TJclScreenBuffer;\r\n public\r\n constructor Create(const AScrBuf: TJclScreenBuffer);\r\n property ScreenBuffer: TJclScreenBuffer read FScreenBuffer;\r\n { IJclScreenTextAttribute }\r\n function GetTextAttribute: Word; override;\r\n procedure SetTextAttribute(const Value: Word); override;\r\n end;\r\n\r\n TJclScreenTextAttribute = class(TJclScreenCustomTextAttribute, IJclScreenTextAttribute)\r\n private\r\n FAttribute: Word;\r\n public\r\n constructor Create(const Attribute: Word); overload;\r\n constructor Create(const AColor: TJclScreenFontColor = fclWhite;\r\n const ABgColor: TJclScreenBackColor = bclBlack;\r\n const AHighLight: Boolean = False;\r\n const ABgHighLight: Boolean = False;\r\n const AStyle: TJclScreenFontStyles = []); overload;\r\n { IJclScreenTextAttribute }\r\n function GetTextAttribute: Word; override;\r\n procedure SetTextAttribute(const Value: Word); override;\r\n end;\r\n\r\n TJclScreenCharacter = class(TJclScreenCustomTextAttribute, IJclScreenTextAttribute)\r\n private\r\n FCharInfo: TCharInfo;\r\n function GetCharacter: Char;\r\n procedure SetCharacter(const Value: Char);\r\n public\r\n constructor Create(const CharInfo: TCharInfo);\r\n property Info: TCharInfo read FCharInfo write FCharInfo;\r\n property Character: Char read GetCharacter write SetCharacter;\r\n { IJclScreenTextAttribute }\r\n function GetTextAttribute: Word; override;\r\n procedure SetTextAttribute(const Value: Word); override;\r\n end;\r\n\r\n TJclScreenCursorSize = 1..100;\r\n\r\n TJclScreenCursor = class(TObject)\r\n private\r\n FScreenBuffer: TJclScreenBuffer;\r\n function GetInfo: TConsoleCursorInfo;\r\n procedure SetInfo(const Value: TConsoleCursorInfo);\r\n function GetPosition: TCoord;\r\n procedure SetPosition(const Value: TCoord);\r\n function GetSize: TJclScreenCursorSize;\r\n procedure SetSize(const Value: TJclScreenCursorSize);\r\n function GetVisible: Boolean;\r\n procedure SetVisible(const Value: Boolean);\r\n protected\r\n property Info: TConsoleCursorInfo read GetInfo write SetInfo;\r\n public\r\n constructor Create(const AScrBuf: TJclScreenBuffer);\r\n property ScreenBuffer: TJclScreenBuffer read FScreenBuffer;\r\n procedure MoveTo(const DestPos: TCoord); overload;\r\n procedure MoveTo(const x, y: Smallint); overload;\r\n procedure MoveBy(const Delta: TCoord); overload;\r\n procedure MoveBy(const cx, cy: Smallint); overload;\r\n property Position: TCoord read GetPosition write SetPosition;\r\n property Size: TJclScreenCursorSize read GetSize write SetSize;\r\n property Visible: Boolean read GetVisible write SetVisible;\r\n end;\r\n\r\n // Console screen window\r\n TJclScreenWindow = class(TObject)\r\n private\r\n FScreenBuffer: TJclScreenBuffer;\r\n function GetMaxConsoleWindowSize: TCoord;\r\n function GetMaxWindow: TCoord;\r\n function GetLeft: Smallint;\r\n function GetTop: Smallint;\r\n function GetWidth: Smallint;\r\n function GetHeight: Smallint;\r\n function GetPosition: TCoord;\r\n function GetSize: TCoord;\r\n function GetBottom: Smallint;\r\n function GetRight: Smallint;\r\n procedure SetLeft(const Value: Smallint);\r\n procedure SetTop(const Value: Smallint);\r\n procedure SetWidth(const Value: Smallint);\r\n procedure SetHeight(const Value: Smallint);\r\n procedure SetPosition(const Value: TCoord);\r\n procedure SetSize(const Value: TCoord);\r\n procedure SetBottom(const Value: Smallint);\r\n procedure SetRight(const Value: Smallint);\r\n procedure InternalSetPosition(const X, Y: SmallInt);\r\n procedure InternalSetSize(const X, Y: SmallInt);\r\n protected\r\n procedure DoResize(const NewRect: TSmallRect; bAbsolute: Boolean = True);\r\n public\r\n constructor Create(const AScrBuf: TJclScreenBuffer);\r\n procedure Scroll(const cx, cy: Smallint);\r\n property ScreenBuffer: TJclScreenBuffer read FScreenBuffer;\r\n property MaxConsoleWindowSize: TCoord read GetMaxConsoleWindowSize;\r\n property MaxWindow: TCoord read GetMaxWindow;\r\n property Position: TCoord read GetPosition write SetPosition;\r\n property Size: TCoord read GetSize write SetSize;\r\n property Left: Smallint read GetLeft write SetLeft;\r\n property Right: Smallint read GetRight write SetRight;\r\n property Top: Smallint read GetTop write SetTop;\r\n property Bottom: Smallint read GetBottom write SetBottom;\r\n property Width: Smallint read GetWidth write SetWidth;\r\n property Height: Smallint read GetHeight write SetHeight;\r\n end;\r\n\r\n // Console input buffer\r\n TJclInputCtrlEvent = ( ceCtrlC, ceCtrlBreak, ceCtrlClose, ceCtrlLogOff, ceCtrlShutdown );\r\n\r\n TJclInputRecordArray = array of TInputRecord;\r\n\r\n TJclInputBuffer = class(TObject)\r\n private\r\n FConsole: TJclConsole;\r\n FHandle: THandle;\r\n function GetMode: TJclConsoleInputModes;\r\n procedure SetMode(const Value: TJclConsoleInputModes);\r\n function GetEventCount: DWORD;\r\n public\r\n constructor Create(const AConsole: TJclConsole);\r\n destructor Destroy; override;\r\n procedure Clear;\r\n procedure RaiseCtrlEvent(const AEvent: TJclInputCtrlEvent; const ProcessGroupId: DWORD = 0);\r\n function WaitEvent(const TimeOut: DWORD = INFINITE): Boolean;\r\n function GetEvents(var Events: TJclInputRecordArray): DWORD; overload;\r\n function GetEvents(const Count: Integer): TJclInputRecordArray; overload;\r\n function PeekEvents(var Events: TJclInputRecordArray): DWORD; overload;\r\n function PeekEvents(const Count: Integer): TJclInputRecordArray; overload;\r\n function PutEvents(const Events: TJclInputRecordArray): DWORD; overload;\r\n function GetEvent: TInputRecord;\r\n function PeekEvent: TInputRecord;\r\n function PutEvent(const Event: TInputRecord): Boolean;\r\n property Console: TJclConsole read FConsole;\r\n property Handle: THandle read FHandle;\r\n property Mode: TJclConsoleInputModes read GetMode write SetMode;\r\n property EventCount: DWORD read GetEventCount;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jcl.svn.sourceforge.net/svnroot/jcl/tags/JCL-2.4-Build4571/jcl/source/windows/JclConsole.pas $';\r\n Revision: '$Revision: 3724 $';\r\n Date: '$Date: 2012-02-12 23:30:08 +0100 (dim. 12 févr. 2012) $';\r\n LogPath: 'JCL\\source\\windows';\r\n Extra: '';\r\n Data: nil\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n {$IFDEF FPC}\r\n JwaWinNT,\r\n {$ENDIF FPC}\r\n {$IFDEF HAS_UNITSCOPE}\r\n System.Math, System.TypInfo,\r\n {$ELSE ~HAS_UNITSCOPE}\r\n Math, TypInfo,\r\n {$ENDIF ~HAS_UNITSCOPE}\r\n JclFileUtils, JclResources, JclSysUtils;\r\n\r\n{$IFDEF FPC}\r\n{$EXTERNALSYM CreateConsoleScreenBuffer}\r\nconst\r\n kernel32 = 'kernel32.dll';\r\n \r\nfunction CreateConsoleScreenBuffer(dwDesiredAccess, dwShareMode: DWORD;\r\n lpSecurityAttributes: PSecurityAttributes; dwFlags: DWORD; lpScreenBufferData: Pointer): THandle; stdcall;\r\n external kernel32 name 'CreateConsoleScreenBuffer';\r\nfunction SetConsoleWindowInfo(hConsoleOutput: THandle; bAbsolute: BOOL;\r\n const lpConsoleWindow: TSmallRect): BOOL; stdcall;\r\n external kernel32 name 'SetConsoleWindowInfo';\r\n{$ENDIF FPC}\r\n\r\nconst\r\n COMMON_LVB_LEADING_BYTE = $0100; // Leading Byte of DBCS\r\n COMMON_LVB_TRAILING_BYTE = $0200; // Trailing Byte of DBCS\r\n COMMON_LVB_GRID_HORIZONTAL = $0400; // DBCS: Grid attribute: top horizontal.\r\n COMMON_LVB_GRID_LVERTICAL = $0800; // DBCS: Grid attribute: left vertical.\r\n COMMON_LVB_GRID_RVERTICAL = $1000; // DBCS: Grid attribute: right vertical.\r\n COMMON_LVB_REVERSE_VIDEO = $4000; // DBCS: Reverse fore/back ground attribute.\r\n COMMON_LVB_UNDERSCORE = $8000; // DBCS: Underscore.\r\n\r\n COMMON_LVB_SBCSDBCS = $0300; // SBCS or DBCS flag.\r\n\r\nconst\r\n FontColorMask: Word = FOREGROUND_BLUE or FOREGROUND_GREEN or FOREGROUND_RED;\r\n BackColorMask: Word = BACKGROUND_BLUE or BACKGROUND_GREEN or BACKGROUND_RED;\r\n FontStyleMask: Word = COMMON_LVB_LEADING_BYTE or COMMON_LVB_TRAILING_BYTE or\r\n COMMON_LVB_GRID_HORIZONTAL or COMMON_LVB_GRID_LVERTICAL or COMMON_LVB_GRID_RVERTICAL or\r\n COMMON_LVB_REVERSE_VIDEO or COMMON_LVB_UNDERSCORE or COMMON_LVB_SBCSDBCS;\r\n\r\n FontColorMapping: array [TJclScreenFontColor] of Word =\r\n (0,\r\n FOREGROUND_BLUE,\r\n FOREGROUND_GREEN,\r\n FOREGROUND_RED,\r\n FOREGROUND_BLUE or FOREGROUND_GREEN,\r\n FOREGROUND_BLUE or FOREGROUND_RED,\r\n FOREGROUND_GREEN or FOREGROUND_RED,\r\n FOREGROUND_BLUE or FOREGROUND_GREEN or FOREGROUND_RED);\r\n\r\n BackColorMapping: array [TJclScreenBackColor] of Word =\r\n (0,\r\n BACKGROUND_BLUE,\r\n BACKGROUND_GREEN,\r\n BACKGROUND_RED,\r\n BACKGROUND_BLUE or BACKGROUND_GREEN,\r\n BACKGROUND_BLUE or BACKGROUND_RED,\r\n BACKGROUND_GREEN or BACKGROUND_RED,\r\n BACKGROUND_BLUE or BACKGROUND_GREEN or BACKGROUND_RED);\r\n\r\n FontStyleMapping: array [TJclScreenFontStyle] of Word =\r\n (COMMON_LVB_LEADING_BYTE, // Leading Byte of DBCS\r\n COMMON_LVB_TRAILING_BYTE, // Trailing Byte of DBCS\r\n COMMON_LVB_GRID_HORIZONTAL, // DBCS: Grid attribute: top horizontal.\r\n COMMON_LVB_GRID_LVERTICAL, // DBCS: Grid attribute: left vertical.\r\n COMMON_LVB_GRID_RVERTICAL, // DBCS: Grid attribute: right vertical.\r\n COMMON_LVB_REVERSE_VIDEO, // DBCS: Reverse fore/back ground attribute.\r\n COMMON_LVB_UNDERSCORE, // DBCS: Underscore.\r\n COMMON_LVB_SBCSDBCS); // SBCS or DBCS flag.\r\n\r\nconst\r\n InputModeMapping: array [TJclConsoleInputMode] of DWORD =\r\n (ENABLE_LINE_INPUT, ENABLE_ECHO_INPUT, ENABLE_PROCESSED_INPUT,\r\n ENABLE_WINDOW_INPUT, ENABLE_MOUSE_INPUT);\r\n\r\n OutputModeMapping: array [TJclConsoleOutputMode] of DWORD =\r\n (ENABLE_PROCESSED_OUTPUT, ENABLE_WRAP_AT_EOL_OUTPUT);\r\n\r\nvar\r\n g_DefaultConsole: TJclConsole = nil;\r\n\r\n// Due to changes in Vista and onwards Windows will terminate\r\n// console immidiately after executing CtrlHandler. We need put some wait in it.\r\n// These subprograms may only work if main application is console and it creates its own message pump.\r\n// On GUI one these should work always.\r\n\r\nfunction ProcessMessage(var Msg: TMsg): Boolean;\r\nbegin\r\n Result := False;\r\n if {$IFDEF HAS_UNITSCOPE}WinApi.{$ENDIF}Windows.PeekMessage(Msg, 0, 0, 0, PM_REMOVE) then\r\n begin\r\n Result := True;\r\n {$IFDEF HAS_UNITSCOPE}WinApi.{$ENDIF}Windows.TranslateMessage(Msg);\r\n {$IFDEF HAS_UNITSCOPE}WinApi.{$ENDIF}Windows.DispatchMessage(Msg);\r\n end;\r\nend;\r\n\r\nprocedure ProcessMessages;\r\nvar\r\n Msg: {$IFDEF HAS_UNITSCOPE}WinApi.{$ENDIF}Windows.TMsg;\r\nbegin\r\n while ProcessMessage(Msg) do;\r\nend;\r\n\r\nprocedure Wait(N: LongWord);\r\nvar\r\n TickCount: LongWord;\r\nbegin\r\n SleepEx(N, False);\r\n TickCount := GetTickCount + N;\r\n while GetTickCount < TickCount do\r\n ProcessMessages;\r\nend;\r\n\r\nfunction CtrlHandler(CtrlType: DWORD): BOOL; stdcall;\r\nvar\r\n Console: TJclConsole;\r\nbegin\r\n try\r\n Console := TJclConsole.Default;\r\n Result := True;\r\n case CtrlType of\r\n CTRL_C_EVENT:\r\n if Assigned(Console.OnCtrlC) then\r\n Console.OnCtrlC(Console);\r\n CTRL_BREAK_EVENT:\r\n if Assigned(Console.OnCtrlBreak) then\r\n Console.OnCtrlBreak(Console);\r\n CTRL_CLOSE_EVENT:\r\n if Assigned(Console.OnClose) then\r\n Console.OnClose(Console);\r\n CTRL_LOGOFF_EVENT:\r\n if Assigned(Console.OnLogOff) then\r\n Console.OnLogOff(Console);\r\n CTRL_SHUTDOWN_EVENT:\r\n if Assigned(Console.OnShutdown) then\r\n Console.OnShutdown(Console);\r\n else\r\n // (rom) disabled. Makes function result unpredictable.\r\n //Assert(False, 'Unknown Ctrl Event');\r\n Result := False;\r\n end;\r\n except\r\n // (rom) dubious. An exception implies that an event has been handled.\r\n Result := False;\r\n end;\r\n Wait(200);\r\nend;\r\n\r\n//=== { TJclConsole } ========================================================\r\n\r\nconstructor TJclConsole.Create;\r\nbegin\r\n inherited Create;\r\n FScreens := TObjectList.Create;\r\n FInput:= TJclInputBuffer.Create(Self);\r\n FActiveScreenIndex := FScreens.Add(TJclScreenBuffer.Create);\r\n FOnCtrlC := nil;\r\n FOnCtrlBreak := nil;\r\n FOnClose := nil;\r\n FOnLogOff := nil;\r\n FOnShutdown := nil;\r\n SetConsoleCtrlHandler(@CtrlHandler, True);\r\nend;\r\n\r\ndestructor TJclConsole.Destroy;\r\nbegin\r\n // (rom) why as first line?\r\n inherited Destroy;\r\n SetConsoleCtrlHandler(@CtrlHandler, False);\r\n FreeAndNil(FInput);\r\n FreeAndNil(FScreens);\r\nend;\r\n\r\nclass procedure TJclConsole.Alloc;\r\nbegin\r\n Win32Check(AllocConsole);\r\nend;\r\n\r\nclass procedure TJclConsole.Free;\r\nbegin\r\n Win32Check(FreeConsole);\r\nend;\r\n\r\nfunction TJclConsole.GetScreen(const Idx: Longword): TJclScreenBuffer;\r\nbegin\r\n // (rom) maybe some checks on Idx here?\r\n Result := TJclScreenBuffer(FScreens[Idx]);\r\nend;\r\n\r\nfunction TJclConsole.GetScreenCount: Longword;\r\nbegin\r\n Result := FScreens.Count;\r\nend;\r\n\r\nfunction TJclConsole.GetActiveScreen: TJclScreenBuffer;\r\nbegin\r\n Result := Screens[FActiveScreenIndex];\r\nend;\r\n\r\nprocedure TJclConsole.SetActiveScreen(const Value: TJclScreenBuffer);\r\nbegin\r\n SetActiveScreenIndex(FScreens.IndexOf(Value));\r\nend;\r\n\r\nprocedure TJclConsole.SetActiveScreenIndex(const Value: Longword);\r\nbegin\r\n if ActiveScreenIndex <> Value then\r\n begin\r\n Win32Check(SetConsoleActiveScreenBuffer(Screens[Value].Handle));\r\n FActiveScreenIndex := Value;\r\n end;\r\nend;\r\n\r\nclass function TJclConsole.Default: TJclConsole;\r\nbegin\r\n if not Assigned(g_DefaultConsole) then\r\n g_DefaultConsole := TJclConsole.Create;\r\n Result := g_DefaultConsole;\r\nend;\r\n\r\nclass procedure TJclConsole.Shutdown;\r\nbegin\r\n FreeAndNil(g_DefaultConsole);\r\nend;\r\n\r\nfunction TJclConsole.Add(AWidth, AHeight: Smallint): TJclScreenBuffer;\r\nbegin\r\n if AWidth = 0 then\r\n AWidth := ActiveScreen.Size.X;\r\n if AHeight = 0 then\r\n AHeight := ActiveScreen.Size.Y;\r\n Result := TJclScreenBuffer(FScreens[FScreens.Add(TJclScreenBuffer.Create(AWidth, AHeight))]);\r\nend;\r\n\r\nfunction TJclConsole.Remove(const ScrBuf: TJclScreenBuffer): Longword;\r\nbegin\r\n Result := FScreens.IndexOf(ScrBuf);\r\n Delete(Result);\r\nend;\r\n\r\nprocedure TJclConsole.Delete(const Idx: Longword);\r\nbegin\r\n FScreens.Delete(Idx);\r\nend;\r\n\r\nfunction TJclConsole.GetTitle: string;\r\nvar\r\n Len: Integer;\r\nbegin\r\n { TODO : max 64kByte instead of max 255 }\r\n { TODO : max 64kByte instead of max 255 }\r\n SetLength(Result, High(Byte));\r\n Len := GetConsoleTitle(PChar(Result), Length(Result));\r\n Win32Check((0 < Len) and (Len < Length(Result)));\r\n SetLength(Result, Len);\r\nend;\r\n\r\nprocedure TJclConsole.SetTitle(const Value: string);\r\nbegin\r\n Win32Check(SetConsoleTitle(PChar(Value)));\r\nend;\r\n\r\nfunction TJclConsole.GetInputCodePage: DWORD;\r\nbegin\r\n Result := GetConsoleCP;\r\nend;\r\n\r\nprocedure TJclConsole.SetInputCodePage(const Value: DWORD);\r\nbegin\r\n { TODO -cTest : SetConsoleCP under Win9x }\r\n Win32Check(SetConsoleCP(Value));\r\nend;\r\n\r\nfunction TJclConsole.GetOutputCodePage: DWORD;\r\nbegin\r\n Result := GetConsoleOutputCP;\r\nend;\r\n\r\nprocedure TJclConsole.SetOutputCodePage(const Value: DWORD);\r\nbegin\r\n { TODO -cTest : SetConsoleOutputCP under Win9x }\r\n Win32Check(SetConsoleOutputCP(Value));\r\nend;\r\n\r\nclass function TJclConsole.IsConsole(const Module: HMODULE): Boolean;\r\nvar\r\n DosHeader: PImageDosHeader;\r\n NtHeaders: PImageNtHeaders;\r\nbegin\r\n Result := False;\r\n { TODO : Documentation of this solution }\r\n DosHeader := PImageDosHeader(Module);\r\n if DosHeader^.e_magic = IMAGE_DOS_SIGNATURE then\r\n begin\r\n {$OVERFLOWCHECKS OFF}\r\n NtHeaders := PImageNtHeaders(TJclAddr(Module) + TJclAddr({$IFDEF FPC} DosHeader^.e_lfanew {$ELSE} DosHeader^._lfanew {$ENDIF}));\r\n {$IFDEF OVERFLOWCHECKS_ON}\r\n {$OVERFLOWCHECKS ON}\r\n {$ENDIF OVERFLOWCHECKS_ON}\r\n if NtHeaders^.Signature = IMAGE_NT_SIGNATURE then\r\n Result := NtHeaders^.OptionalHeader.Subsystem = IMAGE_SUBSYSTEM_WINDOWS_CUI;\r\n end;\r\nend;\r\n\r\nclass function TJclConsole.IsConsole(const FileName: TFileName): Boolean;\r\nbegin\r\n with TJclFileMappingStream.Create(FileName) do\r\n try\r\n Result := IsConsole(HMODULE(Memory));\r\n finally\r\n Free;\r\n end;\r\nend;\r\n\r\nclass function TJclConsole.MouseButtonCount: DWORD;\r\nbegin\r\n Result := 0;\r\n Win32Check(GetNumberOfConsoleMouseButtons(Result));\r\nend;\r\n\r\n//=== { TJclScreenBuffer } ===================================================\r\n\r\nconstructor TJclScreenBuffer.Create;\r\nbegin\r\n inherited Create;\r\n FHandle := CreateFile('CONOUT$', GENERIC_READ or GENERIC_WRITE,\r\n FILE_SHARE_READ or FILE_SHARE_WRITE, nil, OPEN_EXISTING, 0, 0);\r\n Win32Check(FHandle <> INVALID_HANDLE_VALUE);\r\n Init;\r\nend;\r\n\r\nconstructor TJclScreenBuffer.Create(const AHandle: THandle);\r\nbegin\r\n inherited Create;\r\n FHandle := AHandle;\r\n Assert(FHandle <> INVALID_HANDLE_VALUE);\r\n Init;\r\nend;\r\n\r\nconstructor TJclScreenBuffer.Create(const AWidth, AHeight: Smallint);\r\nbegin\r\n inherited Create;\r\n FHandle := CreateConsoleScreenBuffer(GENERIC_READ or GENERIC_WRITE,\r\n FILE_SHARE_READ or FILE_SHARE_WRITE, nil, CONSOLE_TEXTMODE_BUFFER, nil);\r\n Win32Check(FHandle <> INVALID_HANDLE_VALUE);\r\n Init;\r\n DoResize(AWidth, AHeight);\r\nend;\r\n\r\ndestructor TJclScreenBuffer.Destroy;\r\nbegin\r\n // (rom) why as first line?\r\n inherited Destroy;\r\n FreeAndNil(FFont);\r\n FreeAndNil(FCursor);\r\n FreeAndNil(FWindow);\r\n FreeAndNil(FCharList);\r\n CloseHandle(FHandle);\r\nend;\r\n\r\nprocedure TJclScreenBuffer.Init;\r\nbegin\r\n FCharList := TObjectList.Create;\r\n FOnAfterResize := nil;\r\n FOnBeforeResize := nil;\r\n FFont := TJclScreenFont.Create(Self);\r\n FCursor := TJclScreenCursor.Create(Self);\r\n FWindow := TJclScreenWindow.Create(Self);\r\nend;\r\n\r\nfunction TJclScreenBuffer.GetInfo: TConsoleScreenBufferInfo;\r\nbegin\r\n Win32Check(GetConsoleScreenBufferInfo(FHandle, Result));\r\nend;\r\n\r\nfunction TJclScreenBuffer.GetSize: TCoord;\r\nbegin\r\n Result := Info.dwSize;\r\nend;\r\n\r\nprocedure TJclScreenBuffer.SetSize(const Value: TCoord);\r\nbegin\r\n DoResize(Value);\r\nend;\r\n\r\nfunction TJclScreenBuffer.GetWidth: Smallint;\r\nbegin\r\n Result := Size.X;\r\nend;\r\n\r\nprocedure TJclScreenBuffer.SetWidth(const Value: Smallint);\r\nbegin\r\n DoResize(Value, Size.Y);\r\nend;\r\n\r\nfunction TJclScreenBuffer.GetHeight: Smallint;\r\nbegin\r\n Result := Size.Y;\r\nend;\r\n\r\nprocedure TJclScreenBuffer.SetHeight(const Value: Smallint);\r\nbegin\r\n DoResize(Size.X, Value);\r\nend;\r\n\r\nprocedure TJclScreenBuffer.DoResize(const NewSize: TCoord);\r\nvar\r\n CanResize: Boolean;\r\nbegin\r\n if (Size.X <> NewSize.X) or (Size.Y <> NewSize.Y) then\r\n begin\r\n if Assigned(FOnBeforeResize) then\r\n begin\r\n CanResize := True;\r\n FOnBeforeResize(Self, NewSize, CanResize);\r\n if not CanResize then\r\n Exit;\r\n end;\r\n Win32Check(SetConsoleScreenBufferSize(FHandle, NewSize));\r\n if Assigned(FOnAfterResize) then\r\n FOnAfterResize(Self);\r\n end;\r\nend;\r\n\r\nprocedure TJclScreenBuffer.DoResize(const NewWidth, NewHeight: Smallint);\r\nvar\r\n NewSize: TCoord;\r\nbegin\r\n NewSize.X := NewWidth;\r\n NewSize.Y := NewHeight;\r\n DoResize(NewSize);\r\nend;\r\n\r\nfunction TJclScreenBuffer.GetMode: TJclConsoleOutputModes;\r\nvar\r\n OutputMode: DWORD;\r\n AMode: TJclConsoleOutputMode;\r\nbegin\r\n Result := [];\r\n OutputMode := 0;\r\n Win32Check(GetConsoleMode(FHandle, OutputMode));\r\n for AMode := Low(TJclConsoleOutputMode) to High(TJclConsoleOutputMode) do\r\n if (OutputMode and OutputModeMapping[AMode]) = OutputModeMapping[AMode] then\r\n Include(Result, AMode);\r\nend;\r\n\r\nprocedure TJclScreenBuffer.SetMode(const Value: TJclConsoleOutputModes);\r\nvar\r\n OutputMode: DWORD;\r\n AMode: TJclConsoleOutputMode;\r\nbegin\r\n OutputMode := 0;\r\n for AMode := Low(TJclConsoleOutputMode) to High(TJclConsoleOutputMode) do\r\n if AMode in Value then\r\n OutputMode := OutputMode or OutputModeMapping[AMode];\r\n Win32Check(SetConsoleMode(FHandle, OutputMode));\r\nend;\r\n\r\nfunction TJclScreenBuffer.Write(const Text: string;\r\n const ATextAttribute: IJclScreenTextAttribute): DWORD;\r\nbegin\r\n if Assigned(ATextAttribute) then\r\n Font.TextAttribute := ATextAttribute.TextAttribute;\r\n Result := 0;\r\n Win32Check(WriteConsole(Handle, PChar(Text), Length(Text), Result, nil));\r\nend;\r\n\r\nfunction TJclScreenBuffer.Writeln(const Text: string;\r\n const ATextAttribute: IJclScreenTextAttribute): DWORD;\r\nbegin\r\n Result := Write(Text, ATextAttribute);\r\n Cursor.MoveTo(Window.Left, Cursor.Position.Y + 1);\r\nend;\r\n\r\nfunction TJclScreenBuffer.Write(const Text: string; const X, Y: Smallint;\r\n const ATextAttribute: IJclScreenTextAttribute): DWORD;\r\nvar\r\n I: Integer;\r\n Pos: TCoord;\r\n Attrs: array of Word;\r\nbegin\r\n if Length(Text) > 0 then\r\n begin\r\n if (X = -1) or (Y = -1) then\r\n begin\r\n Pos := Cursor.Position;\r\n end\r\n else\r\n begin\r\n Pos.X := X;\r\n Pos.Y := Y;\r\n end;\r\n\r\n if Assigned(ATextAttribute) then\r\n begin\r\n SetLength(Attrs, Length(Text));\r\n for I:=0 to Length(Text)-1 do\r\n Attrs[I] := ATextAttribute.TextAttribute;\r\n Result := Write(Text, X, Y, @Attrs[0]);\r\n end\r\n else\r\n Win32Check(WriteConsoleOutputCharacter(Handle, PChar(Text), Length(Text), Pos, Result));\r\n end\r\n else\r\n Result := 0;\r\nend;\r\n\r\nfunction TJclScreenBuffer.Write(const Text: string; const X, Y: Smallint;\r\n pAttrs: PWORD): DWORD;\r\nvar\r\n Pos: TCoord;\r\nbegin\r\n if (X = -1) or (Y = -1) then\r\n begin\r\n Pos := Cursor.Position;\r\n end\r\n else\r\n begin\r\n Pos.X := X;\r\n Pos.Y := Y;\r\n end;\r\n Result := 0;\r\n if pAttrs <> nil then\r\n Win32Check(WriteConsoleOutputAttribute(Handle, pAttrs, Length(Text), Pos, Result));\r\n Win32Check(WriteConsoleOutputCharacter(Handle, PChar(Text), Length(Text), Pos, Result));\r\nend;\r\n\r\nfunction TJclScreenBuffer.Write(const Text: string;\r\n const HorizontalAlign: TJclScreenBufferTextHorizontalAlign;\r\n const VerticalAlign: TJclScreenBufferTextVerticalAlign;\r\n const ATextAttribute: IJclScreenTextAttribute): DWORD;\r\nvar\r\n X, Y: Smallint;\r\nbegin\r\n case HorizontalAlign of\r\n //thaCurrent: X := Cursor.Position.X;\r\n thaLeft:\r\n X := Window.Left;\r\n thaCenter:\r\n X := Window.Left + (Window.Width - Length(Text)) div 2;\r\n thaRight:\r\n X := Window.Right - Length(Text) + 1;\r\n else\r\n X := Cursor.Position.X;\r\n end;\r\n case VerticalAlign of\r\n //tvaCurrent: Y := Cursor.Position.Y;\r\n tvaTop:\r\n Y := Window.Top;\r\n tvaCenter:\r\n Y := Window.Top + Window.Height div 2;\r\n tvaBottom:\r\n Y := Window.Bottom;\r\n else\r\n Y := Cursor.Position.Y;\r\n end;\r\n Result := Write(Text, X, Y, ATextAttribute);\r\nend;\r\n\r\nfunction TJclScreenBuffer.Read(const Count: Integer): string;\r\nvar\r\n ReadCount: DWORD;\r\nbegin\r\n SetLength(Result, Count);\r\n ReadCount := 0;\r\n Win32Check(ReadConsole(Handle, PChar(Result), Count, ReadCount, nil));\r\n SetLength(Result, Min(ReadCount, StrLen(PChar(Result))));\r\nend;\r\n\r\nfunction TJclScreenBuffer.Readln: string;\r\nbegin\r\n Result := Read(Window.Right - Cursor.Position.X + 1);\r\nend;\r\n\r\nfunction TJclScreenBuffer.Read(X, Y: Smallint; const Count: Integer): string;\r\nvar\r\n ReadPos: TCoord;\r\n ReadCount: DWORD;\r\nbegin\r\n ReadPos.X := X;\r\n ReadPos.Y := Y;\r\n SetLength(Result, Count);\r\n ReadCount := 0;\r\n Win32Check(ReadConsoleOutputCharacter(Handle, PChar(Result), Count, ReadPos, ReadCount));\r\n SetLength(Result, Min(ReadCount, StrLen(PChar(Result))));\r\nend;\r\n\r\nfunction TJclScreenBuffer.Readln(X, Y: Smallint): string;\r\nbegin\r\n Result := Read(X, Y, Window.Right - X + 1);\r\nend;\r\n\r\nprocedure TJclScreenBuffer.Fill(const ch: Char; const ATextAttribute: IJclScreenTextAttribute);\r\nvar\r\n WriteCount: DWORD;\r\nbegin\r\n Cursor.MoveTo(0, 0);\r\n WriteCount := 0;\r\n Win32Check(FillConsoleOutputCharacter(Handle, ch, Width * Height, Cursor.Position, WriteCount));\r\n if Assigned(ATextAttribute) then\r\n Win32Check(FillConsoleOutputAttribute(Handle, ATextAttribute.TextAttribute, Width * Height, Cursor.Position, WriteCount))\r\n else\r\n Win32Check(FillConsoleOutputAttribute(Handle, Font.TextAttribute, Width * Height, Cursor.Position, WriteCount));\r\nend;\r\n\r\nprocedure TJclScreenBuffer.Clear;\r\nbegin\r\n Fill(' ', TJclScreenTextAttribute.Create(fclWhite, bclBlack, False, False, []));\r\nend;\r\n\r\n//=== { TJclScreenCustomTextAttribute } ======================================\r\n\r\nconstructor TJclScreenCustomTextAttribute.Create(const Attr: TJclScreenCustomTextAttribute);\r\nbegin\r\n inherited Create;\r\n if Assigned(Attr) then\r\n SetTextAttribute(Attr.GetTextAttribute);\r\nend;\r\n\r\nfunction TJclScreenCustomTextAttribute.GetColor: TJclScreenFontColor;\r\nvar\r\n TA: Word;\r\nbegin\r\n TA := TextAttribute and FontColorMask;\r\n for Result := High(TJclScreenFontColor) downto Low(TJclScreenFontColor) do\r\n if (TA and FontColorMapping[Result]) = FontColorMapping[Result] then\r\n Break;\r\nend;\r\n\r\nfunction TJclScreenCustomTextAttribute.GetBgColor: TJclScreenBackColor;\r\nvar\r\n TA: Word;\r\nbegin\r\n TA := TextAttribute and BackColorMask;\r\n for Result := High(TJclScreenBackColor) downto Low(TJclScreenBackColor) do\r\n if (TA and BackColorMapping[Result]) = BackColorMapping[Result] then\r\n Break;\r\nend;\r\n\r\nfunction TJclScreenCustomTextAttribute.GetHighlight: Boolean;\r\nbegin\r\n Result := (TextAttribute and FOREGROUND_INTENSITY) = FOREGROUND_INTENSITY;\r\nend;\r\n\r\nfunction TJclScreenCustomTextAttribute.GetBgHighlight: Boolean;\r\nbegin\r\n Result := (TextAttribute and BACKGROUND_INTENSITY) = BACKGROUND_INTENSITY;\r\nend;\r\n\r\nprocedure TJclScreenCustomTextAttribute.SetColor(const Value: TJclScreenFontColor);\r\nbegin\r\n TextAttribute := (TextAttribute and (not FontColorMask)) or FontColorMapping[Value];\r\nend;\r\n\r\nprocedure TJclScreenCustomTextAttribute.SetBgColor(const Value: TJclScreenBackColor);\r\nbegin\r\n TextAttribute := (TextAttribute and (not BackColorMask)) or BackColorMapping[Value];\r\nend;\r\n\r\nprocedure TJclScreenCustomTextAttribute.SetHighlight(const Value: Boolean);\r\nbegin\r\n if Value then\r\n TextAttribute := TextAttribute or FOREGROUND_INTENSITY\r\n else\r\n TextAttribute := TextAttribute and (not FOREGROUND_INTENSITY);\r\nend;\r\n\r\nprocedure TJclScreenCustomTextAttribute.SetBgHighlight(const Value: Boolean);\r\nbegin\r\n if Value then\r\n TextAttribute := TextAttribute or BACKGROUND_INTENSITY\r\n else\r\n TextAttribute := TextAttribute and (not BACKGROUND_INTENSITY);\r\nend;\r\n\r\nfunction TJclScreenCustomTextAttribute.GetStyle: TJclScreenFontStyles;\r\nvar\r\n ta: Word;\r\n AStyle: TJclScreenFontStyle;\r\nbegin\r\n Result := [];\r\n ta := TextAttribute and FontStyleMask;\r\n for AStyle := Low(TJclScreenFontStyle) to High(TJclScreenFontStyle) do\r\n if (ta and FontStyleMapping[AStyle]) = FontStyleMapping[AStyle] then\r\n Include(Result, AStyle);\r\nend;\r\n\r\nprocedure TJclScreenCustomTextAttribute.SetStyle(const Value: TJclScreenFontStyles);\r\nvar\r\n ta: Word;\r\n AStyle: TJclScreenFontStyle;\r\nbegin\r\n ta := 0;\r\n for AStyle := Low(TJclScreenFontStyle) to High(TJclScreenFontStyle) do\r\n if AStyle in Value then\r\n ta := ta or FontStyleMapping[AStyle];\r\n TextAttribute := (TextAttribute and (not FontStyleMask)) or ta;\r\nend;\r\n\r\nprocedure TJclScreenCustomTextAttribute.Clear;\r\nbegin\r\n TextAttribute := FontColorMapping[fclWhite] or BackColorMapping[bclBlack];\r\nend;\r\n\r\n//=== { TJclScreenFont } =====================================================\r\n\r\nconstructor TJclScreenFont.Create(const AScrBuf: TJclScreenBuffer);\r\nbegin\r\n inherited Create;\r\n FScreenBuffer := AScrBuf;\r\nend;\r\n\r\nfunction TJclScreenFont.GetTextAttribute: Word;\r\nbegin\r\n Result := ScreenBuffer.Info.wAttributes;\r\nend;\r\n\r\nprocedure TJclScreenFont.SetTextAttribute(const Value: Word);\r\nbegin\r\n Win32Check(SetConsoleTextAttribute(ScreenBuffer.Handle, Value));\r\nend;\r\n\r\n//=== { TJclScreenTextAttribute 0 ============================================\r\n\r\nconstructor TJclScreenTextAttribute.Create(const Attribute: Word);\r\nbegin\r\n inherited Create;\r\n FAttribute := Attribute;\r\nend;\r\n\r\nconstructor TJclScreenTextAttribute.Create(const AColor: TJclScreenFontColor;\r\n const ABgColor: TJclScreenBackColor; const AHighLight, ABgHighLight: Boolean;\r\n const AStyle: TJclScreenFontStyles);\r\nbegin\r\n inherited Create;\r\n Color := AColor;\r\n BgColor := ABgColor;\r\n Highlight := AHighLight;\r\n BgHighlight := ABgHighLight;\r\n Style := AStyle;\r\nend;\r\n\r\nfunction TJclScreenTextAttribute.GetTextAttribute: Word;\r\nbegin\r\n Result := FAttribute;\r\nend;\r\n\r\nprocedure TJclScreenTextAttribute.SetTextAttribute(const Value: Word);\r\nbegin\r\n FAttribute := Value;\r\nend;\r\n\r\n//=== { TJclScreenCharacter } ================================================\r\n\r\nconstructor TJclScreenCharacter.Create(const CharInfo: TCharInfo);\r\nbegin\r\n inherited Create;\r\n FCharInfo := CharInfo;\r\nend;\r\n\r\nfunction TJclScreenCharacter.GetCharacter: Char;\r\nbegin\r\n Result := Char(FCharInfo.AsciiChar);\r\nend;\r\n\r\nprocedure TJclScreenCharacter.SetCharacter(const Value: Char);\r\nbegin\r\n FCharInfo.AsciiChar := AnsiChar(Value);\r\nend;\r\n\r\nfunction TJclScreenCharacter.GetTextAttribute: Word;\r\nbegin\r\n Result := FCharInfo.Attributes;\r\nend;\r\n\r\nprocedure TJclScreenCharacter.SetTextAttribute(const Value: Word);\r\nbegin\r\n FCharInfo.Attributes := Value;\r\nend;\r\n\r\n//=== { TJclScreenCursor } ===================================================\r\n\r\nconstructor TJclScreenCursor.Create(const AScrBuf: TJclScreenBuffer);\r\nbegin\r\n inherited Create;\r\n FScreenBuffer := AScrBuf;\r\nend;\r\n\r\nfunction TJclScreenCursor.GetInfo: TConsoleCursorInfo;\r\nbegin\r\n ResetMemory(Result, SizeOf(Result));\r\n Win32Check(GetConsoleCursorInfo(ScreenBuffer.Handle, Result));\r\nend;\r\n\r\nprocedure TJclScreenCursor.SetInfo(const Value: TConsoleCursorInfo);\r\nbegin\r\n Win32Check(SetConsoleCursorInfo(ScreenBuffer.Handle, Value));\r\nend;\r\n\r\nfunction TJclScreenCursor.GetPosition: TCoord;\r\nbegin\r\n Result := ScreenBuffer.Info.dwCursorPosition;\r\nend;\r\n\r\nprocedure TJclScreenCursor.SetPosition(const Value: TCoord);\r\nbegin\r\n Win32Check(SetConsoleCursorPosition(ScreenBuffer.Handle, Value));\r\nend;\r\n\r\nfunction TJclScreenCursor.GetSize: TJclScreenCursorSize;\r\nbegin\r\n Result := Info.dwSize;\r\nend;\r\n\r\nprocedure TJclScreenCursor.SetSize(const Value: TJclScreenCursorSize);\r\nvar\r\n NewInfo: TConsoleCursorInfo;\r\nbegin\r\n NewInfo := Info;\r\n NewInfo.dwSize := Value;\r\n Info := NewInfo;\r\nend;\r\n\r\nfunction TJclScreenCursor.GetVisible: Boolean;\r\nbegin\r\n Result := Info.bVisible;\r\nend;\r\n\r\nprocedure TJclScreenCursor.SetVisible(const Value: Boolean);\r\nvar\r\n NewInfo: TConsoleCursorInfo;\r\nbegin\r\n NewInfo := Info;\r\n NewInfo.bVisible := Value;\r\n Info := NewInfo;\r\nend;\r\n\r\nprocedure TJclScreenCursor.MoveTo(const DestPos: TCoord);\r\nbegin\r\n Position := DestPos;\r\nend;\r\n\r\nprocedure TJclScreenCursor.MoveTo(const x, y: Smallint);\r\nvar\r\n DestPos: TCoord;\r\nbegin\r\n DestPos.X := x;\r\n DestPos.Y := y;\r\n MoveTo(DestPos);\r\nend;\r\n\r\nprocedure TJclScreenCursor.MoveBy(const Delta: TCoord);\r\nvar\r\n DestPos: TCoord;\r\nbegin\r\n DestPos := Position;\r\n Inc(DestPos.X, Delta.X);\r\n Inc(DestPos.Y, Delta.Y);\r\n MoveTo(DestPos);\r\nend;\r\n\r\nprocedure TJclScreenCursor.MoveBy(const cx, cy: Smallint);\r\nvar\r\n DestPos: TCoord;\r\nbegin\r\n DestPos := Position;\r\n Inc(DestPos.X, cx);\r\n Inc(DestPos.Y, cy);\r\n MoveTo(DestPos);\r\nend;\r\n\r\n//=== { TJclScreenWindow } ===================================================\r\n\r\nconstructor TJclScreenWindow.Create(const AScrBuf: TJclScreenBuffer);\r\nbegin\r\n inherited Create;\r\n FScreenBuffer := AScrBuf;\r\nend;\r\n\r\nfunction TJclScreenWindow.GetMaxConsoleWindowSize: TCoord;\r\nbegin\r\n Result := GetLargestConsoleWindowSize(ScreenBuffer.Handle);\r\nend;\r\n\r\nfunction TJclScreenWindow.GetMaxWindow: TCoord;\r\nbegin\r\n Result := ScreenBuffer.Info.dwMaximumWindowSize;\r\nend;\r\n\r\nprocedure TJclScreenWindow.InternalSetPosition(const X, Y: SmallInt);\r\nvar\r\n NewRect: TSmallRect;\r\nbegin\r\n if (GetLeft <> X) or (GetTop <> Y) then\r\n begin\r\n NewRect.Left := X;\r\n NewRect.Top := Y;\r\n NewRect.Right:= NewRect.Left + Width - 1;\r\n NewRect.Bottom := NewRect.Top + Height - 1;\r\n DoResize(NewRect);\r\n end;\r\nend;\r\n\r\nprocedure TJclScreenWindow.InternalSetSize(const X, Y: SmallInt);\r\nvar\r\n NewRect: TSmallRect;\r\nbegin\r\n if (Width <> X) or (Height <> Y) then\r\n begin\r\n NewRect.Left := Left;\r\n NewRect.Top := Top;\r\n NewRect.Right := NewRect.Left + X - 1;\r\n NewRect.Bottom := NewRect.Top + Y - 1;\r\n DoResize(NewRect);\r\n end;\r\nend;\r\n\r\nfunction TJclScreenWindow.GetLeft: Smallint;\r\nbegin\r\n Result := ScreenBuffer.Info.srWindow.Left;\r\nend;\r\n\r\nfunction TJclScreenWindow.GetRight: Smallint;\r\nbegin\r\n Result := ScreenBuffer.Info.srWindow.Right;\r\nend;\r\n\r\nfunction TJclScreenWindow.GetTop: Smallint;\r\nbegin\r\n Result := ScreenBuffer.Info.srWindow.Top;\r\nend;\r\n\r\nfunction TJclScreenWindow.GetBottom: Smallint;\r\nbegin\r\n Result := ScreenBuffer.Info.srWindow.Bottom;\r\nend;\r\n\r\nfunction TJclScreenWindow.GetWidth: Smallint;\r\nbegin\r\n Result := ScreenBuffer.Info.srWindow.Right - ScreenBuffer.Info.srWindow.Left + 1;\r\nend;\r\n\r\nfunction TJclScreenWindow.GetHeight: Smallint;\r\nbegin\r\n Result := ScreenBuffer.Info.srWindow.Bottom - ScreenBuffer.Info.srWindow.Top + 1;\r\nend;\r\n\r\nprocedure TJclScreenWindow.SetLeft(const Value: Smallint);\r\nbegin\r\n InternalSetPosition(Value, Top);\r\nend;\r\n\r\nprocedure TJclScreenWindow.SetRight(const Value: Smallint);\r\nbegin\r\n InternalSetSize(Value - Left + 1, Height);\r\nend;\r\n\r\nprocedure TJclScreenWindow.SetTop(const Value: Smallint);\r\nbegin\r\n InternalSetPosition(Left, Value);\r\nend;\r\n\r\nprocedure TJclScreenWindow.SetBottom(const Value: Smallint);\r\nbegin\r\n InternalSetSize(Width, Value - Top + 1);\r\nend;\r\n\r\nprocedure TJclScreenWindow.SetWidth(const Value: Smallint);\r\nbegin\r\n InternalSetSize(Value, Height);\r\nend;\r\n\r\nprocedure TJclScreenWindow.SetHeight(const Value: Smallint);\r\nbegin\r\n InternalSetSize(Width, Value);\r\nend;\r\n\r\nfunction TJclScreenWindow.GetPosition: TCoord;\r\nbegin\r\n Result.X := Left;\r\n Result.Y := Top;\r\nend;\r\n\r\nfunction TJclScreenWindow.GetSize: TCoord;\r\nbegin\r\n Result.X := Width;\r\n Result.Y := Height;\r\nend;\r\n\r\nprocedure TJclScreenWindow.SetPosition(const Value: TCoord);\r\nbegin\r\n InternalSetPosition(Value.X, Value.Y);\r\nend;\r\n\r\nprocedure TJclScreenWindow.SetSize(const Value: TCoord);\r\nbegin\r\n InternalSetSize(Value.X, Value.Y);\r\nend;\r\n\r\nprocedure TJclScreenWindow.DoResize(const NewRect: TSmallRect; bAbsolute: Boolean);\r\nbegin\r\n Win32Check(SetConsoleWindowInfo(ScreenBuffer.Handle, bAbsolute, NewRect));\r\nend;\r\n\r\nprocedure TJclScreenWindow.Scroll(const cx, cy: Smallint);\r\nvar\r\n Delta: TSmallRect;\r\nbegin\r\n Delta.Left := cx;\r\n Delta.Top := cy;\r\n Delta.Right := cx;\r\n Delta.Bottom := cy;\r\n DoResize(Delta, False);\r\nend;\r\n\r\n//=== { TJclInputBuffer } ====================================================\r\n\r\nconstructor TJclInputBuffer.Create(const AConsole: TJclConsole);\r\nbegin\r\n inherited Create;\r\n FConsole := AConsole;\r\n FHandle := CreateFile('CONIN$', GENERIC_READ or GENERIC_WRITE,\r\n FILE_SHARE_READ or FILE_SHARE_WRITE, nil, OPEN_EXISTING, 0, 0);\r\n Win32Check(INVALID_HANDLE_VALUE <> FHandle);\r\nend;\r\n\r\ndestructor TJclInputBuffer.Destroy;\r\nbegin\r\n CloseHandle(FHandle);\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJclInputBuffer.Clear;\r\nbegin\r\n Win32Check(FlushConsoleInputBuffer(Handle));\r\nend;\r\n\r\nfunction TJclInputBuffer.GetMode: TJclConsoleInputModes;\r\nvar\r\n InputMode: DWORD;\r\n AMode: TJclConsoleInputMode;\r\nbegin\r\n Result := [];\r\n InputMode := 0;\r\n Win32Check(GetConsoleMode(Handle, InputMode));\r\n for AMode := Low(TJclConsoleInputMode) to High(TJclConsoleInputMode) do\r\n if (InputMode and InputModeMapping[AMode]) = InputModeMapping[AMode] then\r\n Include(Result, AMode);\r\nend;\r\n\r\nprocedure TJclInputBuffer.SetMode(const Value: TJclConsoleInputModes);\r\nvar\r\n InputMode: DWORD;\r\n AMode: TJclConsoleInputMode;\r\nbegin\r\n InputMode := 0;\r\n for AMode := Low(TJclConsoleInputMode) to High(TJclConsoleInputMode) do\r\n if AMode in Value then\r\n InputMode := InputMode or InputModeMapping[AMode];\r\n Win32Check(SetConsoleMode(Handle, InputMode));\r\nend;\r\n\r\nprocedure TJclInputBuffer.RaiseCtrlEvent(const AEvent: TJclInputCtrlEvent;\r\n const ProcessGroupId: DWORD);\r\nconst\r\n CtrlEventMapping: array [TJclInputCtrlEvent] of DWORD =\r\n (CTRL_C_EVENT, CTRL_BREAK_EVENT, CTRL_CLOSE_EVENT, CTRL_LOGOFF_EVENT, CTRL_SHUTDOWN_EVENT);\r\nbegin\r\n if AEvent in [ceCtrlC, ceCtrlBreak] then\r\n Win32Check(GenerateConsoleCtrlEvent(CtrlEventMapping[AEvent], ProcessGroupId))\r\n else\r\n raise EJclError.CreateResFmt(@RsCannotRaiseSignal,\r\n [GetEnumName(TypeInfo(TJclInputCtrlEvent), Integer(AEvent))]);\r\nend;\r\n\r\nfunction TJclInputBuffer.GetEventCount: DWORD;\r\nbegin\r\n Result := 0;\r\n Win32Check(GetNumberOfConsoleInputEvents(Handle, Result));\r\nend;\r\n\r\nfunction TJclInputBuffer.WaitEvent(const TimeOut: DWORD): Boolean;\r\nbegin\r\n Result := WaitForSingleObject(Handle, TimeOut) = WAIT_OBJECT_0;\r\nend;\r\n\r\nfunction TJclInputBuffer.GetEvents(var Events: TJclInputRecordArray): DWORD;\r\nbegin\r\n Result := 0;\r\n Win32Check(ReadConsoleInput(Handle, Events[0], Length(Events), Result));\r\nend;\r\n\r\nfunction TJclInputBuffer.PeekEvents(var Events: TJclInputRecordArray): DWORD;\r\nbegin\r\n if EventCount = 0 then\r\n Result := 0\r\n else\r\n Win32Check(PeekConsoleInput(Handle, Events[0], Length(Events), Result));\r\nend;\r\n\r\nfunction TJclInputBuffer.PutEvents(const Events: TJclInputRecordArray): DWORD;\r\nbegin\r\n Result := 0;\r\n Win32Check(WriteConsoleInput(Handle, Events[0], Length(Events), Result));\r\nend;\r\n\r\nfunction TJclInputBuffer.GetEvents(const Count: Integer): TJclInputRecordArray;\r\nbegin\r\n SetLength(Result, Count);\r\n SetLength(Result, GetEvents(Result));\r\nend;\r\n\r\nfunction TJclInputBuffer.PeekEvents(const Count: Integer): TJclInputRecordArray;\r\nbegin\r\n SetLength(Result, Count);\r\n SetLength(Result, PeekEvents(Result));\r\nend;\r\n\r\nfunction TJclInputBuffer.GetEvent: TInputRecord;\r\nbegin\r\n Result := GetEvents(1)[0];\r\nend;\r\n\r\nfunction TJclInputBuffer.PeekEvent: TInputRecord;\r\nbegin\r\n Result := PeekEvents(1)[0];\r\nend;\r\n\r\nfunction TJclInputBuffer.PutEvent(const Event: TInputRecord): Boolean;\r\nvar\r\n Evts: TJclInputRecordArray;\r\nbegin\r\n SetLength(Evts, 1);\r\n Evts[0] := Event;\r\n Result := PutEvents(Evts) = 1;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jcl/source/windows/JclCppException.pas", "content": "{**************************************************************************************************}\r\n{ }\r\n{ Project JEDI Code Library (JCL) }\r\n{ }\r\n{ The contents of this file are subject to the Mozilla Public License Version 1.1 (the \"License\"); }\r\n{ you may not use this file except in compliance with the License. You may obtain a copy of the }\r\n{ License at http://www.mozilla.org/MPL/ }\r\n{ }\r\n{ Software distributed under the License is distributed on an \"AS IS\" basis, WITHOUT WARRANTY OF }\r\n{ ANY KIND, either express or implied. See the License for the specific language governing rights }\r\n{ and limitations under the License. }\r\n{ }\r\n{ The Original Code is SystemCppException.pas. }\r\n{ }\r\n{ The Initial Developer of the Original Code is Moritz Beutel. Portions created by Moritz Beutel }\r\n{ are Copyright (C) Moritz Beutel. All Rights Reserved. }\r\n{ }\r\n{ Contributor(s): }\r\n{ Moritz Beutel }\r\n{ }\r\n{**************************************************************************************************}\r\n{ }\r\n{ Routines to enable the Delphi RTL to catch, dispatch and clean up C++ exceptions and to handle }\r\n{ exceptions derived from std::exception. }\r\n{ }\r\n{**************************************************************************************************}\r\n{ }\r\n{ Last modified: $Date:: 2012-03-04 19:12:39 +0100 (dim. 04 mars 2012) $ }\r\n{ Revision: $Rev:: 3757 $ }\r\n{ Author: $Author:: outchy $ }\r\n{ }\r\n{**************************************************************************************************}\r\n\r\nunit JclCppException;\r\n\r\ninterface\r\n\r\n{$I jcl.inc}\r\n{$I windowsonly.inc}\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n {$IFDEF HAS_UNITSCOPE}\r\n System.SysUtils;\r\n {$ELSE ~HAS_UNITSCOPE}\r\n SysUtils;\r\n {$ENDIF ~HAS_UNITSCOPE}\r\n\r\n{$IFDEF BORLAND}\r\n\r\ntype\r\n PJclCppStdException = type Pointer; { mapped to std::exception* via $HPPEMIT }\r\n {$EXTERNALSYM PJclCppStdException}\r\n\r\n { C++ exception of any type }\r\n EJclCppException = class(Exception)\r\n {$IFDEF COMPILER15_UP}\r\n private type\r\n TInaccessibleType = class end;\r\n TPointerType = record\r\n type TPointer = ^T;\r\n end;\r\n {$ENDIF COMPILER15_UP}\r\n private\r\n FTypeName: AnsiString;\r\n FExcDesc: Pointer;\r\n FAcquired: Boolean;\r\n\r\n constructor CreateTypeNamed(ATypeName: PAnsiChar; ExcDesc: Pointer); overload;\r\n function GetCppExceptionObject: Pointer;\r\n function GetThrowLine: Integer;\r\n function GetThrowFile: AnsiString;\r\n protected\r\n {$IFDEF COMPILER12_UP} // TODO: this may be supported for earlier versions of Delphi/C++Builder\r\n procedure RaisingException(P: PExceptionRecord); override;\r\n {$ENDIF COMPILER12_UP}\r\n public\r\n property CppExceptionObject: Pointer read GetCppExceptionObject;\r\n property ThrowLine: Integer read GetThrowLine;\r\n property ThrowFile: AnsiString read GetThrowFile;\r\n property TypeName: AnsiString read FTypeName;\r\n\r\n function IsCppClass: Boolean; overload;\r\n function AsCppClass(CppClassName: AnsiString): Pointer; overload;\r\n\r\n {$IFDEF COMPILER15_UP}\r\n { These are only accessible from C++ }\r\n function IsCppClass: Boolean; overload;\r\n function AsCppClass: TPointerType.TPointer; overload;\r\n {$ENDIF COMPILER15_UP}\r\n\r\n destructor Destroy; override;\r\n end;\r\n\r\n { C++ exception derived from std::exception }\r\n EJclCppStdException = class(EJclCppException)\r\n private\r\n FExcObj: PJclCppStdException;\r\n\r\n constructor Create(AExcObj: PJclCppStdException; Msg: String;\r\n ATypeName: PAnsiChar; ExcDesc: Pointer); overload;\r\n function GetStdException: PJclCppStdException;\r\n public\r\n { This property returns a pointer to the wrapped exception. }\r\n property StdException: PJclCppStdException read GetStdException;\r\n end;\r\n\r\n (*$HPPEMIT '#include '*)\r\n (*$HPPEMIT '#include '*)\r\n (*$HPPEMIT ''*)\r\n (*$HPPEMIT 'namespace Jclcppexception'*)\r\n (*$HPPEMIT '{'*)\r\n (*$HPPEMIT ''*)\r\n (*$HPPEMIT 'typedef std::exception* PJclCppStdException;'*)\r\n (*$HPPEMIT ''*)\r\n (*$HPPEMIT '} /* namespace Jclcppexception */'*)\r\n\r\n {$IFDEF COMPILER15_UP}\r\n (*$HPPEMIT END 'namespace Jclcppexception'*)\r\n (*$HPPEMIT END '{'*)\r\n (*$HPPEMIT END ''*)\r\n (*$HPPEMIT END 'template '*)\r\n (*$HPPEMIT END ' bool __fastcall EJclCppException::IsCppClass(void)'*)\r\n (*$HPPEMIT END '{'*)\r\n (*$HPPEMIT END ' return IsCppClass() && AsCppClass(typeid(TCppClass).name()) != 0;'*)\r\n (*$HPPEMIT END '}'*)\r\n (*$HPPEMIT END 'template '*)\r\n (*$HPPEMIT END ' EJclCppException::TPointerType__1::TPointer __fastcall EJclCppException::AsCppClass(void)'*)\r\n (*$HPPEMIT END '{'*)\r\n (*$HPPEMIT END ' return static_cast::TPointer>(AsCppClass(typeid(TCppClass).name()));'*)\r\n (*$HPPEMIT END '}'*)\r\n (*$HPPEMIT END ''*)\r\n (*$HPPEMIT END '} /* namespace Jclcppexception */'*)\r\n {$ENDIF COMPILER15_UP}\r\n\r\n\r\ntype\r\n TJclCppExceptionFlags = set of (cefPrependCppClassName);\r\n\r\nvar\r\n JclCppExceptionFlags: TJclCppExceptionFlags = [cefPrependCppClassName];\r\n\r\nprocedure JclInstallCppExceptionFilter;\r\nprocedure JclUninstallCppExceptionFilter;\r\nfunction JclCppExceptionFilterInstalled: Boolean;\r\n\r\n{$ENDIF BORLAND}\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jcl.svn.sourceforge.net/svnroot/jcl/tags/JCL-2.4-Build4571/jcl/source/windows/JclCppException.pas $';\r\n Revision: '$Revision: 3757 $';\r\n Date: '$Date: 2012-03-04 19:12:39 +0100 (dim. 04 mars 2012) $';\r\n LogPath: 'JCL\\source\\windows';\r\n Extra: '';\r\n Data: nil\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\n{$IFDEF BORLAND}\r\n\r\nuses\r\n JclResources, JclHookExcept;\r\n\r\n\r\ntype\r\n TExceptObjProc = function(P: PExceptionRecord): Exception;\r\n\r\n PCppTypeId = ^TCppTypeId;\r\n\r\n TCppBaseList = packed record { Delphi equivalent of struct baseList in xx.h }\r\n blType : PCppTypeId; // type of this base\r\n blOffs : Cardinal; // offset of this base\r\n blFlags : Cardinal; // flags\r\n end;\r\n\r\n TCppTypeId = packed record { incomplete Delphi equivalent of struct tpid in xx.h }\r\n tpSize : Cardinal; // size of type in bytes\r\n tpMask : Word; // attribute bits\r\n tpName : Word; // offset of start of the zero terminated name\r\n // where offset is relative from tpid base\r\n\r\n tpcVptrOffs : Cardinal; // offset of vtable pointer\r\n tpcFlags : Cardinal; // more flags\r\n\r\n { Only valid if (tpMask & TM_IS_CLASS) }\r\n tpcBaseList : Word; // offset of non-virt base list,\r\n // where offset is relative from tpid base\r\n tpcVbasList : Word; // offset of virtual base list\r\n // where offset is relative from tpid base\r\n\r\n tpcDlOpAddr : Pointer; // operator delete addr\r\n tpcDlOpMask : Word; // operator delete convention\r\n\r\n tpcDaOpMask : Word; // operator delete[] convention\r\n tpcDaOpAddr : Pointer; // operator delete[] addr\r\n\r\n { Only valid if (tpcFlags & CF_HAS_DTOR), implies also (tpMask & TM_IS_CLASS) }\r\n tpcDtorCount : Cardinal; // dtor count - total\r\n tpcNVdtCount : Cardinal; // dtor count - non-virtual\r\n\r\n tpcDtorAddr : Pointer; // destructor addr\r\n tpcDtorMask : Word; // destructor convention\r\n\r\n tpcDtMembers : Word; // offset of list of destructible members\r\n // where offset is relative from tpid base\r\n\r\n { ... }\r\n\r\n { Following is the zero terminated name, padded with zero's to\r\n the next dword boundary.\r\n\r\n Optionally (if tpMask & TM_IS_CLASS), we have next:\r\n - non-virtual base list, terminated by a null pointer\r\n - virtual base list, terminated by a null pointer\r\n\r\n Optionally (if tpcFlags & CF_HAS_DTOR), we have next:\r\n - list of destructible members, terminated by a null pointer }\r\n end;\r\n\r\nconst\r\n\r\n { Flags for TCppTypeId.tpMask }\r\n TM_IS_STRUCT = $0001;\r\n TM_IS_CLASS = $0002;\r\n TM_IS_PTR = $0010;\r\n TM_IS_REF = $0020;\r\n TM_IS_VOIDPTR = $0040;\r\n TM_LOCALTYPE = $0080;\r\n TM_IS_CONST = $0100;\r\n TM_IS_VOLATILE = $0200;\r\n TM_IS_ARRAY = $0400;\r\n\r\n { Flags for TCppTypeId.tpcFlags }\r\n CF_HAS_CTOR = $00000001;\r\n CF_HAS_DTOR = $00000002;\r\n CF_HAS_BASES = $00000004;\r\n CF_HAS_VBASES = $00000008;\r\n CF_HAS_VTABPTR = $00000010;\r\n CF_HAS_VIRTDT = $00000020;\r\n CF_HAS_RTTI = $00000040;\r\n CF_DELPHICLASS = $00000080;\r\n CF_HAS_FARVPTR = $00001000;\r\n CF_HAS_GUID = $00002000;\r\n\r\n { Flags for TCppExceptDesc.xdFlags }\r\n XDF_ISDELPHIEXCEPTION = $00000004;\r\n XDF_RETHROWN = $00000008;\r\n\r\ntype\r\n PCppExceptDesc = ^TCppExceptDesc;\r\n TCppFreeMemFP = procedure(P: PCppExceptDesc); cdecl;\r\n\r\n TCppExceptDesc = packed record { Delphi equivalent of struct _exceptDesc in xx.h }\r\n xdPrevious : Pointer; // previous exception or 0\r\n\r\n xdTypeID : PCppTypeId; // addr of type-id for thrown type\r\n xdFriendList : PCppTypeId; // friend list supplied to _ThrowExcept\r\n xdFlags : Cardinal; // flags passed to _ThrowExcept\r\n xdSize : Cardinal; // size of thrown value\r\n xdBase : PCppTypeId; // type-id of base type\r\n xdMask : Word; // type-id mask\r\n xdCflg : Word; // type-id class flags (or 0)\r\n\r\n xdFreeFunc : TCppFreeMemFP; // function to free memory\r\n\r\n xdCCaddr : Pointer; // copy-ctor addr\r\n xdCCmask : Cardinal; // copy-ctor mask\r\n\r\n xdERRaddr : Pointer; // address of matching ERR (when found)\r\n xdHtabAdr : Pointer; // address of matching handler\r\n\r\n xdContext : Cardinal; // context of 'catch' block\r\n\r\n xdThrowLine : Cardinal; // source line no. of throw statement\r\n xdThrowFile : PAnsiChar; // source file name of throw statement\r\n\r\n xdArgType : PCppTypeId; // address of arg type descriptor\r\n xdArgAddr : Pointer; // address of arg copy on stack\r\n xdArgBuff : AnsiChar; // arg stored in buffer\r\n xdArgCopy : AnsiChar; // arg copied to catch arg\r\n\r\n xdOSESP : LongWord; // esp of main OS exception handler\r\n xdOSERR : LongWord; // addr of the OS ERR on entry to _ExceptionHandler\r\n xdOSContext : {PContext} Pointer; // CPU Context for an OS exception\r\n xdValue : array[0..0] of AnsiChar; // copy of thrown value\r\n end;\r\n\r\n PCppBaseList = ^TCppBaseList;\r\n\r\n{ pre-Tiburon workaround }\r\n{$IFNDEF COMPILER12_UP}\r\n PByte = PAnsiChar;\r\n{$ENDIF ~COMPILER12_UP}\r\n\r\n\r\nprocedure ExceptionHandled(ExcDesc: PCppExceptDesc); forward;\r\nfunction CppGetBase(var Obj: Pointer; TypeDesc: PCppTypeId;\r\n BaseName: PAnsiChar): Boolean; forward;\r\n\r\n{$IFDEF COMPILER15_UP}\r\nfunction EJclCppException.AsCppClass: TPointerType.TPointer;\r\nbegin\r\n Assert(False);\r\nend;\r\nfunction EJclCppException.IsCppClass: Boolean;\r\nbegin\r\n Assert(False);\r\nend;\r\n{$ENDIF COMPILER15_UP}\r\n\r\nconstructor EJclCppException.CreateTypeNamed(ATypeName: PAnsiChar; ExcDesc: Pointer);\r\nbegin\r\n inherited CreateFmt(RsCppUnhandledExceptionMsg, [ATypeName]);\r\n FTypeName := ATypeName;\r\n FExcDesc := ExcDesc;\r\nend;\r\n\r\nconstructor EJclCppStdException.Create(AExcObj: PJclCppStdException; Msg: String;\r\n ATypeName: PAnsiChar; ExcDesc: Pointer);\r\nbegin\r\n if cefPrependCppClassName in JclCppExceptionFlags then\r\n inherited CreateFmt('[%s] %s', [ATypeName, Msg])\r\n else\r\n inherited Create(Msg);\r\n FExcObj := AExcObj;\r\n FTypeName := ATypeName;\r\n FExcDesc := ExcDesc;\r\nend;\r\n\r\nfunction EJclCppException.IsCppClass: Boolean;\r\nvar\r\n ExcDesc: PCppExceptDesc;\r\nbegin\r\n ExcDesc := PCppExceptDesc(FExcDesc);\r\n Result := (ExcDesc.xdTypeID.tpMask and TM_IS_CLASS) <> 0;\r\nend;\r\n\r\n{$IFDEF COMPILER12_UP} // TODO: this may be supported for earlier versions of Delphi/C++Builder\r\nprocedure EJclCppException.RaisingException(P: PExceptionRecord);\r\nbegin\r\n FAcquired := False; { if an acquired exception is re-raised, it is handed back to the RTL }\r\n inherited;\r\nend;\r\n{$ENDIF COMPILER12_UP}\r\n\r\nfunction EJclCppException.GetCppExceptionObject: Pointer;\r\nvar\r\n ExcDesc: PCppExceptDesc;\r\nbegin\r\n ExcDesc := PCppExceptDesc(FExcDesc);\r\n Result := @ExcDesc.xdValue;\r\nend;\r\n\r\nfunction EJclCppException.GetThrowFile: AnsiString;\r\nvar\r\n ExcDesc: PCppExceptDesc;\r\nbegin\r\n ExcDesc := PCppExceptDesc(FExcDesc);\r\n if ExcDesc.xdThrowFile <> nil then\r\n Result := ExcDesc.xdThrowFile\r\n else\r\n Result := '';\r\nend;\r\n\r\nfunction EJclCppException.GetThrowLine: Integer;\r\nvar\r\n ExcDesc: PCppExceptDesc;\r\nbegin\r\n ExcDesc := PCppExceptDesc(FExcDesc);\r\n Result := ExcDesc.xdThrowLine;\r\nend;\r\n\r\nfunction EJclCppException.AsCppClass(CppClassName: AnsiString): Pointer;\r\nvar\r\n ExcDesc: PCppExceptDesc;\r\n Obj: Pointer;\r\nbegin\r\n ExcDesc := PCppExceptDesc(FExcDesc);\r\n Obj := @ExcDesc.xdValue;\r\n if CppGetBase(Obj, ExcDesc.xdTypeID, PAnsiChar(CppClassName)) then\r\n Result := Obj\r\n else\r\n Result := nil;\r\nend;\r\n\r\nthreadvar\r\n LastCppExcDesc: PCppExceptDesc;\r\n\r\nprocedure FreeExcDesc(ExcDesc: PCppExceptDesc);\r\nbegin\r\n if ExcDesc = nil then\r\n Exit;\r\n\r\n { call the exception object's destructor and free the memory as it\r\n is done in _CatchCleanup() in xx.cpp. }\r\n ExceptionHandled(ExcDesc);\r\n\r\n { Free the memory taken up by the exception descriptor }\r\n ExcDesc.xdFreeFunc(ExcDesc);\r\nend;\r\n\r\ndestructor EJclCppException.Destroy;\r\nvar\r\n ExcDesc: PCppExceptDesc;\r\nbegin\r\n ExcDesc := PCppExceptDesc(FExcDesc);\r\n if FAcquired then\r\n FreeExcDesc(ExcDesc)\r\n else\r\n { when exceptions are being re-raised, the RTL first destroys the wrapper objects created for\r\n non-Delphi exceptions and then notifies the exception hook (by raising a cDelphiReRaise\r\n exception). Because of this, we cannot destroy the original exception info if we cannot be\r\n sure it won't be used again. }\r\n LastCppExcDesc := ExcDesc;\r\n inherited;\r\nend;\r\n\r\n{ from System.pas }\r\nconst\r\n cDelphiReRaise = $0EEDFADF;\r\n cDelphiExcept = $0EEDFAE0;\r\n cDelphiFinally = $0EEDFAE1;\r\n cDelphiTerminate = $0EEDFAE2;\r\n\r\ntype\r\n PExceptionArguments = ^TExceptionArguments;\r\n TExceptionArguments = record\r\n ExceptAddr: Pointer;\r\n ExceptObj: Exception;\r\n end;\r\n\r\n TAcquireExceptionProc = procedure(Obj: Pointer);\r\n {$IFDEF CPU32}\r\n TRaiseExceptionProc = procedure(ExceptionCode, ExceptionFlags: LongWord;\r\n NumberOfArguments: LongWord; Args: Pointer); stdcall;\r\n {$ENDIF CPU32}\r\n\r\nvar\r\n OldAcquireExceptionProc: Pointer;\r\n OldRaiseExceptionProc: TRaiseExceptionProc;\r\n\r\nprocedure ExceptionAcquiredProc(Obj: Pointer);\r\nbegin\r\n { After our exception object has been acquired, we have to take the responsibility of\r\n cleaning up the C++ exception when the user decides to destroy our object. }\r\n if TObject(Obj) is EJclCppException then\r\n EJclCppException(Obj).FAcquired := True;\r\n if Assigned(OldAcquireExceptionProc) then\r\n TAcquireExceptionProc(OldAcquireExceptionProc)(Obj);\r\nend;\r\n\r\nprocedure RaiseExceptionProc(ExceptionCode, ExceptionFlags: LongWord;\r\n NumberOfArguments: LongWord; Args: Pointer); stdcall;\r\nbegin\r\n { We make use of the fact that the RTL calls the following notifiers immediately after destroying\r\n the exception object. We should find the exception info in the thread-local variable defined\r\n above. }\r\n case ExceptionCode of\r\n cDelphiReRaise:\r\n ; { re-raising means that the C++ exception info will be reused; don't do anything }\r\n cDelphiTerminate:\r\n { the exception has been handled; now is the time to destroy the C++ exception object }\r\n FreeExcDesc(LastCppExcDesc);\r\n end;\r\n LastCppExcDesc := nil;\r\n\r\n if Assigned(OldRaiseExceptionProc) then\r\n OldRaiseExceptionProc(ExceptionCode, ExceptionFlags, NumberOfArguments, Args);\r\nend;\r\n\r\nfunction EJclCppStdException.GetStdException: PJclCppStdException;\r\nbegin\r\n Result := FExcObj;\r\nend;\r\n\r\n{ This function should basically work like destThrownValue()/callDestructor()\r\n in xx.cpp }\r\nprocedure DestroyThrownValue(Obj: Pointer; ObjType: PCppTypeId);\r\ntype\r\n TCdeclDestructor = procedure(Obj: Pointer; Flags: Integer); cdecl;\r\n TPascalDestructor = procedure(Flags: Integer; Obj: Pointer); pascal;\r\n TFastcallDestructor = procedure(Obj: Pointer; Flags: Integer);\r\n TStdcallDestructor = procedure(Obj: Pointer; Flags: Integer); stdcall;\r\nvar\r\n Flags: Integer;\r\n CdeclDestructor: TCdeclDestructor;\r\n PascalDestructor: TPascalDestructor;\r\n FastcallDestructor: TFastcallDestructor;\r\n StdcallDestructor: TStdcallDestructor;\r\nbegin\r\n // \t\tcallDestructor(objAddr, objType, 0, dtorAddr, dtorMask, 1);\r\n Flags := 2;\r\n\r\n Assert((ObjType.tpcDtorMask and $0080) = 0, 'fastthis (-po) not supported');\r\n\r\n case ObjType.tpcDtorMask and $0007 of\r\n 1: // __cdecl\r\n begin\r\n CdeclDestructor := TCdeclDestructor(ObjType.tpcDtorAddr);\r\n CdeclDestructor(Obj, Flags);\r\n end;\r\n 2: // __pascal\r\n begin\r\n PascalDestructor := TPascalDestructor(ObjType.tpcDtorAddr);\r\n PascalDestructor(Flags, Obj);\r\n end;\r\n 3: // __fastcall\r\n begin\r\n FastcallDestructor := TFastcallDestructor(ObjType.tpcDtorAddr);\r\n FastcallDestructor(Obj, Flags);\r\n end;\r\n 5: // __stdcall\r\n begin\r\n StdcallDestructor := TStdcallDestructor(ObjType.tpcDtorAddr);\r\n StdcallDestructor(Obj, Flags);\r\n end;\r\n else\r\n Assert(False, 'Unsupported calling convention!');\r\n end;\r\nend;\r\n\r\n{ This function should basically work like exceptionHandled() in xx.cpp }\r\nprocedure ExceptionHandled(ExcDesc: PCppExceptDesc);\r\nvar\r\n TypeDesc: PCppTypeId;\r\n Obj: Pointer;\r\nbegin\r\n { Is the thrown value still present in the descriptor? }\r\n if Ord(ExcDesc.xdArgBuff) <> 0 then\r\n begin\r\n\r\n { Destroy the thrown value if necessary }\r\n if (ExcDesc.xdCflg and CF_HAS_DTOR) <> 0 then\r\n begin\r\n TypeDesc := ExcDesc.xdBase;\r\n Obj := Pointer(@ExcDesc.xdValue);\r\n\r\n { All delphi class objects are thrown by pointer, sort of.\r\n However, we should not meet a Delphi class here! }\r\n if (TypeDesc.tpcFlags and CF_DELPHICLASS) <> 0 then\r\n Obj := Pointer((PCardinal(Obj))^); { dereference }\r\n\r\n { We can't do anything about the _DestructorCount variable here, but\r\n this is a legacy feature anyway. }\r\n\r\n { Don't destroy it if it's a delphi class and it's being rethrown. }\r\n if (ExcDesc.xdFlags and (XDF_ISDELPHIEXCEPTION or XDF_RETHROWN))\r\n <> (XDF_ISDELPHIEXCEPTION or XDF_RETHROWN) then\r\n DestroyThrownValue(Obj, TypeDesc);\r\n end;\r\n\r\n { Mark the fact that the arg is gone }\r\n ExcDesc.xdArgBuff := AnsiChar(0);\r\n end;\r\n\r\n { Did we make a copy of the argument? }\r\n if Ord(ExcDesc.xdArgCopy) <> 0 then\r\n begin\r\n TypeDesc := ExcDesc.xdArgType;\r\n\r\n { Destroy the thrown value if necessary }\r\n if ((TypeDesc.tpMask and TM_IS_CLASS) <> 0)\r\n and ((TypeDesc.tpcFlags and CF_HAS_DTOR) <> 0) then\r\n DestroyThrownValue(ExcDesc.xdArgAddr, TypeDesc);\r\n\r\n { Mark the fact that the arg is gone }\r\n ExcDesc.xdArgCopy := AnsiChar(0);\r\n end;\r\nend;\r\n\r\n{ It is not easy to get the C++ type description for std::exception,\r\n therefore we identify the base class by name.\r\n\r\n This function should basically work like locateBaseClass() in xxtype.cpp }\r\nfunction LocateCppBaseClass(BaseList: PCppBaseList; VBase: Boolean;\r\n BaseName: PAnsiChar; var Addr: Pointer) : Boolean;\r\nvar\r\n Ptr: Pointer;\r\n BaseBaseList: PCppBaseList;\r\n BaseType: PCppTypeId;\r\nbegin\r\n { Check for end of base list }\r\n Result := False;\r\n while BaseList.blType <> nil do\r\n begin\r\n BaseType := BaseList.blType;\r\n\r\n Ptr := Pointer(PByte(Addr) + BaseList.blOffs);\r\n Inc(BaseList);\r\n\r\n if VBase then\r\n Ptr := Pointer((PCardinal(Ptr))^); { dereference }\r\n\r\n { Is this the right base class? }\r\n if StrComp(PAnsiChar(PByte(BaseType) + BaseType.tpName), BaseName) = 0 then\r\n begin\r\n Addr := Ptr; { Match --> return the adjusted pointer to the caller }\r\n Result := True;\r\n Exit;\r\n end;\r\n\r\n { Does this base class have any base classes? }\r\n { Annotation: Would BaseType.tpcFlags & CF_HAS_BASES be a better match for this? }\r\n if (BaseType.tpMask and TM_IS_CLASS) = 0 then\r\n Continue;\r\n\r\n { Get the list of non-virtual bases for this base class }\r\n BaseBaseList := PCppBaseList(PByte(BaseType) + BaseType.tpcBaseList);\r\n\r\n { Give up on this base if it has no non-virtual bases (Ann.: why?) }\r\n if BaseBaseList = nil then\r\n Continue;\r\n\r\n { Search the base classes of this base recursively }\r\n if LocateCppBaseClass(BaseBaseList, False, BaseName, Ptr) then\r\n begin\r\n Addr := Ptr; { Match --> return the adjusted pointer to the caller }\r\n Result := True;\r\n Exit;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction CppGetBase(var Obj: Pointer; TypeDesc: PCppTypeId;\r\n BaseName: PAnsiChar): Boolean;\r\nvar\r\n BaseList, VBaseList: PCppBaseList;\r\nbegin\r\n if StrComp(PAnsiChar(PByte(TypeDesc) + TypeDesc.tpName), BaseName) = 0 then\r\n { a class can be considered its own base }\r\n Result := True\r\n else if (TypeDesc.tpMask and TM_IS_CLASS) <> 0 then\r\n begin\r\n { iterate through the base classes }\r\n BaseList := PCppBaseList(PByte(TypeDesc) + TypeDesc.tpcBaseList);\r\n VBaseList := PCppBaseList(PByte(TypeDesc) + TypeDesc.tpcVbasList);\r\n Result := LocateCppBaseClass(BaseList, False, BaseName, Obj)\r\n or LocateCppBaseClass(VBaseList, False, BaseName, Obj);\r\n end\r\n else\r\n Result := False; { Don't be surprised. C++ permits to throw every type. }\r\nend;\r\n\r\nfunction CppExceptObjProc(P: PExceptionRecord): Exception;\r\ntype\r\n { Function pointer to std::type_info::what().\r\n In the Dinkumware library, std::exception::what() always has the\r\n __cdecl calling convention. }\r\n TCppTypeInfoWhatMethod = function(This: Pointer): PAnsiChar; cdecl;\r\nvar\r\n ExcTypeName: PAnsiChar;\r\n ExcDesc: PCppExceptDesc;\r\n ExcObject: Pointer;\r\n ExcObjectVTbl: Pointer;\r\n WhatMethod: TCppTypeInfoWhatMethod;\r\nbegin\r\n Result := nil;\r\n case P.ExceptionCode of\r\n $0EEFFACE: { C++ exception }\r\n begin\r\n { When a C++ exception is thrown, the C++ compiler (indirectly) calls the\r\n tossAnException function defined in xx.cpp. The Win32 exception argument\r\n table is filled in line 1096ff as follows:\r\n\r\n argTable[0] = (unsigned long)(void __far *)__throwExceptionName;\r\n argTable[1] = (unsigned long)(void __far *)throwPC;\r\n argTable[2] = (unsigned long)(void __far *)xdp; // : PCppExceptDesc }\r\n\r\n ExcTypeName := PAnsiChar(P.ExceptionInformation[0]);\r\n ExcDesc := PCppExceptDesc(P.ExceptionInformation[2]);\r\n ExcObject := Pointer(@ExcDesc.xdValue);\r\n\r\n if CppGetBase(ExcObject, ExcDesc.xdTypeID, 'std::exception') then\r\n begin\r\n { The exception object is a std::exception subclass and implements\r\n the virtual member function what(). }\r\n ExcObjectVTbl := Pointer(PCardinal(ExcObject)^);\r\n WhatMethod := TCppTypeInfoWhatMethod(PCardinal(\r\n Cardinal(ExcObjectVTbl) + SizeOf(Pointer))^);\r\n Result := EJclCppStdException.Create(ExcObject, String(WhatMethod(ExcObject)),\r\n PAnsiChar(ExcTypeName), Pointer(ExcDesc));\r\n end\r\n else\r\n { The exception object has some other type. We cannot extract an\r\n exception message with reasonable efforts. }\r\n Result := EJclCppException.CreateTypeNamed(PAnsiChar(ExcTypeName), Pointer(ExcDesc));\r\n end;\r\n end;\r\nend;\r\n\r\nvar\r\n HookInstalled: Boolean = False;\r\n\r\nprocedure JclInstallCppExceptionFilter;\r\nbegin\r\n Assert(JclHookExcept.JclExceptionsHooked,\r\n 'Cannot install C++ exception filter: call JclHookExcept.JclHookExceptions() first!');\r\n if HookInstalled then\r\n Exit;\r\n HookInstalled := JclHookExcept.JclAddExceptFilter(@CppExceptObjProc, npFirstChain);\r\n if HookInstalled then\r\n begin\r\n {$IFDEF COMPILER12_UP} // TODO: this may be supported for earlier versions of Delphi/C++Builder\r\n OldAcquireExceptionProc := System.ExceptionAcquired;\r\n System.ExceptionAcquired := @ExceptionAcquiredProc;\r\n {$ENDIF COMPILER12_UP}\r\n\r\n OldRaiseExceptionProc := System.RaiseExceptionProc;\r\n {$IFDEF CPU32}\r\n System.RaiseExceptionProc := @RaiseExceptionProc;\r\n {$ELSE}\r\n System.RaiseExceptionProc := RaiseExceptionProc;\r\n {$ENDIF CPU32}\r\n end;\r\nend;\r\n\r\nprocedure JclUninstallCppExceptionFilter;\r\nbegin\r\n if not HookInstalled then\r\n Exit;\r\n {$IFDEF COMPILER12_UP} // TODO: this may be supported for earlier versions of Delphi/C++Builder\r\n System.ExceptionAcquired := OldAcquireExceptionProc;\r\n {$ENDIF COMPILER12_UP}\r\n {$IFDEF CPU32}\r\n System.RaiseExceptionProc := @OldRaiseExceptionProc;\r\n {$ELSE}\r\n System.RaiseExceptionProc := OldRaiseExceptionProc;\r\n {$ENDIF CPU32}\r\n JclHookExcept.JclRemoveExceptFilter(@CppExceptObjProc);\r\n HookInstalled := False;\r\nend;\r\n\r\nfunction JclCppExceptionFilterInstalled: Boolean;\r\nbegin\r\n Result := HookInstalled;\r\nend;\r\n\r\n{$ENDIF BORLAND}\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n\r\n" }, { "path": "External/Jedi/Jcl/source/windows/JclDebug.pas", "content": "{**************************************************************************************************}\r\n{ }\r\n{ Project JEDI Code Library (JCL) }\r\n{ }\r\n{ The contents of this file are subject to the Mozilla Public License Version 1.1 (the \"License\"); }\r\n{ you may not use this file except in compliance with the License. You may obtain a copy of the }\r\n{ License at http://www.mozilla.org/MPL/ }\r\n{ }\r\n{ Software distributed under the License is distributed on an \"AS IS\" basis, WITHOUT WARRANTY OF }\r\n{ ANY KIND, either express or implied. See the License for the specific language governing rights }\r\n{ and limitations under the License. }\r\n{ }\r\n{ The Original Code is JclDebug.pas. }\r\n{ }\r\n{ The Initial Developers of the Original Code are Petr Vones and Marcel van Brakel. }\r\n{ Portions created by these individuals are Copyright (C) of these individuals. }\r\n{ All Rights Reserved. }\r\n{ }\r\n{ Contributor(s): }\r\n{ Marcel van Brakel }\r\n{ Flier Lu (flier) }\r\n{ Florent Ouchet (outchy) }\r\n{ Robert Marquardt (marquardt) }\r\n{ Robert Rossmair (rrossmair) }\r\n{ Andreas Hausladen (ahuser) }\r\n{ Petr Vones (pvones) }\r\n{ Soeren Muehlbauer }\r\n{ Uwe Schuster (uschuster) }\r\n{ }\r\n{**************************************************************************************************}\r\n{ }\r\n{ Various debugging support routines and classes. This includes: Diagnostics routines, Trace }\r\n{ routines, Stack tracing and Source Locations a la the C/C++ __FILE__ and __LINE__ macros. }\r\n{ }\r\n{**************************************************************************************************}\r\n{ }\r\n{ Last modified: $Date:: 2012-09-04 16:08:04 +0200 (mar. 04 sept. 2012) $ }\r\n{ Revision: $Rev:: 3861 $ }\r\n{ Author: $Author:: outchy $ }\r\n{ }\r\n{**************************************************************************************************}\r\n\r\nunit JclDebug;\r\n\r\ninterface\r\n\r\n{$I jcl.inc}\r\n{$I windowsonly.inc}\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n {$IFDEF HAS_UNITSCOPE}\r\n {$IFDEF MSWINDOWS}\r\n Winapi.Windows,\r\n {$ENDIF MSWINDOWS}\r\n System.Classes, System.SysUtils, System.Contnrs,\r\n {$ELSE ~HAS_UNITSCOPE}\r\n {$IFDEF MSWINDOWS}\r\n Windows,\r\n {$ENDIF MSWINDOWS}\r\n Classes, SysUtils, Contnrs,\r\n {$ENDIF ~HAS_UNITSCOPE}\r\n JclBase, JclFileUtils, JclPeImage,\r\n {$IFDEF BORLAND}\r\n JclTD32,\r\n {$ENDIF BORLAND}\r\n JclSynch;\r\n\r\n// Diagnostics\r\nprocedure AssertKindOf(const ClassName: string; const Obj: TObject); overload;\r\nprocedure AssertKindOf(const ClassType: TClass; const Obj: TObject); overload;\r\n\r\n// use TraceMsg\r\n// procedure Trace(const Msg: string);\r\nprocedure TraceMsg(const Msg: string);\r\nprocedure TraceFmt(const Fmt: string; const Args: array of const);\r\nprocedure TraceLoc(const Msg: string);\r\nprocedure TraceLocFmt(const Fmt: string; const Args: array of const);\r\n\r\n// Optimized functionality of JclSysInfo functions ModuleFromAddr and IsSystemModule\r\ntype\r\n TJclModuleInfo = class(TObject)\r\n private\r\n FSize: Cardinal;\r\n FEndAddr: Pointer;\r\n FStartAddr: Pointer;\r\n FSystemModule: Boolean;\r\n public\r\n property EndAddr: Pointer read FEndAddr;\r\n property Size: Cardinal read FSize;\r\n property StartAddr: Pointer read FStartAddr;\r\n property SystemModule: Boolean read FSystemModule;\r\n end;\r\n\r\n TJclModuleInfoList = class(TObjectList)\r\n private\r\n FDynamicBuild: Boolean;\r\n FSystemModulesOnly: Boolean;\r\n function GetItems(Index: Integer): TJclModuleInfo;\r\n function GetModuleFromAddress(Addr: Pointer): TJclModuleInfo;\r\n protected\r\n procedure BuildModulesList;\r\n function CreateItemForAddress(Addr: Pointer; SystemModule: Boolean): TJclModuleInfo;\r\n public\r\n constructor Create(ADynamicBuild, ASystemModulesOnly: Boolean);\r\n function AddModule(Module: HMODULE; SystemModule: Boolean): Boolean;\r\n function IsSystemModuleAddress(Addr: Pointer): Boolean;\r\n function IsValidModuleAddress(Addr: Pointer): Boolean;\r\n property DynamicBuild: Boolean read FDynamicBuild;\r\n property Items[Index: Integer]: TJclModuleInfo read GetItems;\r\n property ModuleFromAddress[Addr: Pointer]: TJclModuleInfo read GetModuleFromAddress;\r\n end;\r\n\r\nfunction JclValidateModuleAddress(Addr: Pointer): Boolean;\r\n\r\n// MAP file abstract parser\r\ntype\r\n PJclMapAddress = ^TJclMapAddress;\r\n TJclMapAddress = packed record\r\n Segment: Word;\r\n Offset: TJclAddr;\r\n end;\r\n\r\n PJclMapString = PAnsiChar;\r\n\r\n TJclAbstractMapParser = class(TObject)\r\n private\r\n FLinkerBug: Boolean;\r\n FLinkerBugUnitName: PJclMapString;\r\n //AM FStream: TJclFileMappingStream;\r\n FStream: TCustomMemoryStream;\r\n function GetLinkerBugUnitName: string;\r\n protected\r\n FModule: HMODULE;\r\n FLastUnitName: PJclMapString;\r\n FLastUnitFileName: PJclMapString;\r\n procedure ClassTableItem(const Address: TJclMapAddress; Len: Integer; SectionName, GroupName: PJclMapString); virtual; abstract;\r\n procedure SegmentItem(const Address: TJclMapAddress; Len: Integer; GroupName, UnitName: PJclMapString); virtual; abstract;\r\n procedure PublicsByNameItem(const Address: TJclMapAddress; Name: PJclMapString); virtual; abstract;\r\n procedure PublicsByValueItem(const Address: TJclMapAddress; Name: PJclMapString); virtual; abstract;\r\n procedure LineNumberUnitItem(UnitName, UnitFileName: PJclMapString); virtual; abstract;\r\n procedure LineNumbersItem(LineNumber: Integer; const Address: TJclMapAddress); virtual; abstract;\r\n public\r\n constructor Create(const MapFileName: TFileName; Module: HMODULE); overload; virtual;\r\n constructor Create(const MapFileName: TFileName); overload;\r\n destructor Destroy; override;\r\n procedure Parse;\r\n class function MapStringToFileName(MapString: PJclMapString): string;\r\n class function MapStringToModuleName(MapString: PJclMapString): string;\r\n class function MapStringToStr(MapString: PJclMapString; IgnoreSpaces: Boolean = False): string;\r\n property LinkerBug: Boolean read FLinkerBug;\r\n property LinkerBugUnitName: string read GetLinkerBugUnitName;\r\n// AM property Stream: TJclFileMappingStream read FStream;\r\n\tproperty Stream: TCustomMemoryStream read FStream;\r\n end;\r\n\r\n // MAP file parser\r\n TJclMapClassTableEvent = procedure(Sender: TObject; const Address: TJclMapAddress; Len: Integer; const SectionName, GroupName: string) of object;\r\n TJclMapSegmentEvent = procedure(Sender: TObject; const Address: TJclMapAddress; Len: Integer; const GroupName, UnitName: string) of object;\r\n TJclMapPublicsEvent = procedure(Sender: TObject; const Address: TJclMapAddress; const Name: string) of object;\r\n TJclMapLineNumberUnitEvent = procedure(Sender: TObject; const UnitName, UnitFileName: string) of object;\r\n TJclMapLineNumbersEvent = procedure(Sender: TObject; LineNumber: Integer; const Address: TJclMapAddress) of object;\r\n\r\n TJclMapParser = class(TJclAbstractMapParser)\r\n private\r\n FOnClassTable: TJclMapClassTableEvent;\r\n FOnLineNumbers: TJclMapLineNumbersEvent;\r\n FOnLineNumberUnit: TJclMapLineNumberUnitEvent;\r\n FOnPublicsByValue: TJclMapPublicsEvent;\r\n FOnPublicsByName: TJclMapPublicsEvent;\r\n FOnSegmentItem: TJclMapSegmentEvent;\r\n protected\r\n procedure ClassTableItem(const Address: TJclMapAddress; Len: Integer; SectionName, GroupName: PJclMapString); override;\r\n procedure SegmentItem(const Address: TJclMapAddress; Len: Integer; GroupName, UnitName: PJclMapString); override;\r\n procedure PublicsByNameItem(const Address: TJclMapAddress; Name: PJclMapString); override;\r\n procedure PublicsByValueItem(const Address: TJclMapAddress; Name: PJclMapString); override;\r\n procedure LineNumberUnitItem(UnitName, UnitFileName: PJclMapString); override;\r\n procedure LineNumbersItem(LineNumber: Integer; const Address: TJclMapAddress); override;\r\n public\r\n property OnClassTable: TJclMapClassTableEvent read FOnClassTable write FOnClassTable;\r\n property OnSegment: TJclMapSegmentEvent read FOnSegmentItem write FOnSegmentItem;\r\n property OnPublicsByName: TJclMapPublicsEvent read FOnPublicsByName write FOnPublicsByName;\r\n property OnPublicsByValue: TJclMapPublicsEvent read FOnPublicsByValue write FOnPublicsByValue;\r\n property OnLineNumberUnit: TJclMapLineNumberUnitEvent read FOnLineNumberUnit write FOnLineNumberUnit;\r\n property OnLineNumbers: TJclMapLineNumbersEvent read FOnLineNumbers write FOnLineNumbers;\r\n end;\r\n\r\n TJclMapStringCache = record\r\n CachedValue: string;\r\n RawValue: PJclMapString;\r\n end;\r\n\r\n // MAP file scanner\r\n PJclMapSegmentClass = ^TJclMapSegmentClass;\r\n TJclMapSegmentClass = record\r\n Segment: Word; // segment ID\r\n Start: DWORD; // start as in the map file\r\n Addr: DWORD; // start as in process memory\r\n VA: DWORD; // position relative to module base adress\r\n Len: DWORD; // segment length\r\n SectionName: TJclMapStringCache;\r\n GroupName: TJclMapStringCache;\r\n end;\r\n\r\n PJclMapSegment = ^TJclMapSegment;\r\n TJclMapSegment = record\r\n Segment: Word;\r\n StartVA: DWORD; // VA relative to (module base address + $10000)\r\n EndVA: DWORD;\r\n UnitName: TJclMapStringCache;\r\n end;\r\n\r\n PJclMapProcName = ^TJclMapProcName;\r\n TJclMapProcName = record\r\n Segment: Word;\r\n VA: DWORD; // VA relative to (module base address + $10000)\r\n ProcName: TJclMapStringCache;\r\n end;\r\n\r\n PJclMapLineNumber = ^TJclMapLineNumber;\r\n TJclMapLineNumber = record\r\n Segment: Word;\r\n VA: DWORD; // VA relative to (module base address + $10000)\r\n LineNumber: Integer;\r\n end;\r\n\r\n TJclMapScanner = class(TJclAbstractMapParser)\r\n private\r\n FSegmentClasses: array of TJclMapSegmentClass;\r\n FLineNumbers: array of TJclMapLineNumber;\r\n FProcNames: array of TJclMapProcName;\r\n FSegments: array of TJclMapSegment;\r\n FSourceNames: array of TJclMapProcName;\r\n FLineNumbersCnt: Integer;\r\n FLineNumberErrors: Integer;\r\n FNewUnitFileName: PJclMapString;\r\n FProcNamesCnt: Integer;\r\n FSegmentCnt: Integer;\r\n protected\r\n function MAPAddrToVA(const Addr: DWORD): DWORD;\r\n procedure ClassTableItem(const Address: TJclMapAddress; Len: Integer; SectionName, GroupName: PJclMapString); override;\r\n procedure SegmentItem(const Address: TJclMapAddress; Len: Integer; GroupName, UnitName: PJclMapString); override;\r\n procedure PublicsByNameItem(const Address: TJclMapAddress; Name: PJclMapString); override;\r\n procedure PublicsByValueItem(const Address: TJclMapAddress; Name: PJclMapString); override;\r\n procedure LineNumbersItem(LineNumber: Integer; const Address: TJclMapAddress); override;\r\n procedure LineNumberUnitItem(UnitName, UnitFileName: PJclMapString); override;\r\n procedure Scan;\r\n public\r\n constructor Create(const MapFileName: TFileName; Module: HMODULE); override;\r\n\r\n class function MapStringCacheToFileName(var MapString: TJclMapStringCache): string;\r\n class function MapStringCacheToModuleName(var MapString: TJclMapStringCache): string;\r\n class function MapStringCacheToStr(var MapString: TJclMapStringCache; IgnoreSpaces: Boolean = False): string;\r\n\r\n // Addr are virtual addresses relative to (module base address + $10000)\r\n function LineNumberFromAddr(Addr: DWORD): Integer; overload;\r\n function LineNumberFromAddr(Addr: DWORD; out Offset: Integer): Integer; overload;\r\n function ModuleNameFromAddr(Addr: DWORD): string;\r\n function ModuleStartFromAddr(Addr: DWORD): DWORD;\r\n function ProcNameFromAddr(Addr: DWORD): string; overload;\r\n function ProcNameFromAddr(Addr: DWORD; out Offset: Integer): string; overload;\r\n function SourceNameFromAddr(Addr: DWORD): string;\r\n property LineNumberErrors: Integer read FLineNumberErrors;\r\n end;\r\n\r\ntype\r\n PJclDbgHeader = ^TJclDbgHeader;\r\n TJclDbgHeader = packed record\r\n Signature: DWORD;\r\n Version: Byte;\r\n Units: Integer;\r\n SourceNames: Integer;\r\n Symbols: Integer;\r\n LineNumbers: Integer;\r\n Words: Integer;\r\n ModuleName: Integer;\r\n CheckSum: Integer;\r\n CheckSumValid: Boolean;\r\n end;\r\n\r\n TJclBinDebugGenerator = class(TJclMapScanner)\r\n private\r\n FDataStream: TMemoryStream;\r\n FMapFileName: TFileName;\r\n protected\r\n procedure CreateData;\r\n public\r\n constructor Create(const MapFileName: TFileName; Module: HMODULE); override;\r\n destructor Destroy; override;\r\n function CalculateCheckSum: Boolean;\r\n property DataStream: TMemoryStream read FDataStream;\r\n end;\r\n\r\n TJclBinDbgNameCache = record\r\n Addr: DWORD;\r\n FirstWord: Integer;\r\n SecondWord: Integer;\r\n end;\r\n\r\n TJclBinDebugScanner = class(TObject)\r\n private\r\n FCacheData: Boolean;\r\n FStream: TCustomMemoryStream;\r\n FValidFormat: Boolean;\r\n FLineNumbers: array of TJclMapLineNumber;\r\n FProcNames: array of TJclBinDbgNameCache;\r\n function GetModuleName: string;\r\n protected\r\n procedure CacheLineNumbers;\r\n procedure CacheProcNames;\r\n procedure CheckFormat;\r\n function DataToStr(A: Integer): string;\r\n function MakePtr(A: Integer): Pointer;\r\n function ReadValue(var P: Pointer; var Value: Integer): Boolean;\r\n public\r\n constructor Create(AStream: TCustomMemoryStream; CacheData: Boolean);\r\n function IsModuleNameValid(const Name: TFileName): Boolean;\r\n function LineNumberFromAddr(Addr: DWORD): Integer; overload;\r\n function LineNumberFromAddr(Addr: DWORD; out Offset: Integer): Integer; overload;\r\n function ProcNameFromAddr(Addr: DWORD): string; overload;\r\n function ProcNameFromAddr(Addr: DWORD; out Offset: Integer): string; overload;\r\n function ModuleNameFromAddr(Addr: DWORD): string;\r\n function ModuleStartFromAddr(Addr: DWORD): DWORD;\r\n function SourceNameFromAddr(Addr: DWORD): string;\r\n property ModuleName: string read GetModuleName;\r\n property ValidFormat: Boolean read FValidFormat;\r\n end;\r\n\r\nfunction ConvertMapFileToJdbgFile(const MapFileName: TFileName): Boolean; overload;\r\nfunction ConvertMapFileToJdbgFile(const MapFileName: TFileName; out LinkerBugUnit: string;\r\n out LineNumberErrors: Integer): Boolean; overload;\r\nfunction ConvertMapFileToJdbgFile(const MapFileName: TFileName; out LinkerBugUnit: string;\r\n out LineNumberErrors, MapFileSize, JdbgFileSize: Integer): Boolean; overload;\r\n\r\nfunction InsertDebugDataIntoExecutableFile(const ExecutableFileName,\r\n MapFileName: TFileName; out LinkerBugUnit: string;\r\n out MapFileSize, JclDebugDataSize: Integer): Boolean; overload;\r\nfunction InsertDebugDataIntoExecutableFile(const ExecutableFileName,\r\n MapFileName: TFileName; out LinkerBugUnit: string;\r\n out MapFileSize, JclDebugDataSize, LineNumberErrors: Integer): Boolean; overload;\r\n\r\nfunction InsertDebugDataIntoExecutableFile(const ExecutableFileName: TFileName;\r\n BinDebug: TJclBinDebugGenerator; out LinkerBugUnit: string;\r\n out MapFileSize, JclDebugDataSize: Integer): Boolean; overload;\r\nfunction InsertDebugDataIntoExecutableFile(const ExecutableFileName: TFileName;\r\n BinDebug: TJclBinDebugGenerator; out LinkerBugUnit: string;\r\n out MapFileSize, JclDebugDataSize, LineNumberErrors: Integer): Boolean; overload;\r\n\r\n// Source Locations\r\ntype\r\n TJclDebugInfoSource = class;\r\n\r\n PJclLocationInfo = ^TJclLocationInfo;\r\n TJclLocationInfo = record\r\n Address: Pointer; // Error address\r\n UnitName: string; // Name of Delphi unit\r\n ProcedureName: string; // Procedure name\r\n OffsetFromProcName: Integer; // Offset from Address to ProcedureName symbol location\r\n LineNumber: Integer; // Line number\r\n OffsetFromLineNumber: Integer; // Offset from Address to LineNumber symbol location\r\n SourceName: string; // Module file name\r\n DebugInfo: TJclDebugInfoSource; // Location object\r\n BinaryFileName: string; // Name of the binary file containing the symbol\r\n end;\r\n\r\n TJclLocationInfoExValues = set of (lievLocationInfo, lievProcedureStartLocationInfo, lievUnitVersionInfo);\r\n\r\n TJclCustomLocationInfoList = class;\r\n\r\n TJclLocationInfoListOptions = set of (liloAutoGetAddressInfo, liloAutoGetLocationInfo, liloAutoGetUnitVersionInfo);\r\n\r\n TJclLocationInfoEx = class(TPersistent)\r\n private\r\n FAddress: Pointer;\r\n FBinaryFileName: string;\r\n FDebugInfo: TJclDebugInfoSource;\r\n FLineNumber: Integer;\r\n FLineNumberOffsetFromProcedureStart: Integer;\r\n FModuleName: string;\r\n FOffsetFromLineNumber: Integer;\r\n FOffsetFromProcName: Integer;\r\n FParent: TJclCustomLocationInfoList;\r\n FProcedureName: string;\r\n FSourceName: string;\r\n FSourceUnitName: string;\r\n FUnitVersionDateTime: TDateTime;\r\n FUnitVersionExtra: string;\r\n FUnitVersionLogPath: string;\r\n FUnitVersionRCSfile: string;\r\n FUnitVersionRevision: string;\r\n FVAddress: Pointer;\r\n FValues: TJclLocationInfoExValues;\r\n procedure Fill(AOptions: TJclLocationInfoListOptions);\r\n function GetAsString: string;\r\n protected\r\n procedure AssignTo(Dest: TPersistent); override;\r\n public\r\n constructor Create(AParent: TJclCustomLocationInfoList; Address: Pointer);\r\n procedure Clear; virtual;\r\n property Address: Pointer read FAddress write FAddress;\r\n property AsString: string read GetAsString;\r\n property BinaryFileName: string read FBinaryFileName write FBinaryFileName;\r\n property DebugInfo: TJclDebugInfoSource read FDebugInfo write FDebugInfo;\r\n property LineNumber: Integer read FLineNumber write FLineNumber;\r\n property LineNumberOffsetFromProcedureStart: Integer read FLineNumberOffsetFromProcedureStart write FLineNumberOffsetFromProcedureStart;\r\n property ModuleName: string read FModuleName write FModuleName;\r\n property OffsetFromLineNumber: Integer read FOffsetFromLineNumber write FOffsetFromLineNumber;\r\n property OffsetFromProcName: Integer read FOffsetFromProcName write FOffsetFromProcName;\r\n property ProcedureName: string read FProcedureName write FProcedureName;\r\n property SourceName: string read FSourceName write FSourceName;\r\n { this is equal to TJclLocationInfo.UnitName, but has been renamed because\r\n UnitName is a class function in TObject since Delphi 2009 }\r\n property SourceUnitName: string read FSourceUnitName write FSourceUnitName;\r\n property UnitVersionDateTime: TDateTime read FUnitVersionDateTime write FUnitVersionDateTime;\r\n property UnitVersionExtra: string read FUnitVersionExtra write FUnitVersionExtra;\r\n property UnitVersionLogPath: string read FUnitVersionLogPath write FUnitVersionLogPath;\r\n property UnitVersionRCSfile: string read FUnitVersionRCSfile write FUnitVersionRCSfile;\r\n property UnitVersionRevision: string read FUnitVersionRevision write FUnitVersionRevision;\r\n property VAddress: Pointer read FVAddress write FVAddress;\r\n property Values: TJclLocationInfoExValues read FValues write FValues;\r\n end;\r\n\r\n TJclLocationInfoClass = class of TJclLocationInfoEx;\r\n\r\n TJclCustomLocationInfoListClass = class of TJclCustomLocationInfoList;\r\n\r\n TJclCustomLocationInfoList = class(TPersistent)\r\n protected\r\n FItemClass: TJclLocationInfoClass;\r\n FItems: TObjectList;\r\n FOptions: TJclLocationInfoListOptions;\r\n function GetAsString: string;\r\n function GetCount: Integer;\r\n function InternalAdd(Addr: Pointer): TJclLocationInfoEx;\r\n protected\r\n procedure AssignTo(Dest: TPersistent); override;\r\n public\r\n constructor Create; virtual;\r\n destructor Destroy; override;\r\n procedure AddStackInfoList(AStackInfoList: TObject);\r\n procedure Clear;\r\n property AsString: string read GetAsString;\r\n property Count: Integer read GetCount;\r\n property Options: TJclLocationInfoListOptions read FOptions write FOptions;\r\n end;\r\n\r\n TJclLocationInfoList = class(TJclCustomLocationInfoList)\r\n private\r\n function GetItems(AIndex: Integer): TJclLocationInfoEx;\r\n public\r\n constructor Create; override;\r\n function Add(Addr: Pointer): TJclLocationInfoEx;\r\n property Items[AIndex: Integer]: TJclLocationInfoEx read GetItems; default;\r\n end;\r\n\r\n TJclDebugInfoSource = class(TObject)\r\n private\r\n FModule: HMODULE;\r\n function GetFileName: TFileName;\r\n protected\r\n function VAFromAddr(const Addr: Pointer): DWORD; virtual;\r\n public\r\n constructor Create(AModule: HMODULE); virtual;\r\n function InitializeSource: Boolean; virtual; abstract;\r\n function GetLocationInfo(const Addr: Pointer; out Info: TJclLocationInfo): Boolean; virtual; abstract;\r\n property Module: HMODULE read FModule;\r\n property FileName: TFileName read GetFileName;\r\n end;\r\n\r\n TJclDebugInfoSourceClass = class of TJclDebugInfoSource;\r\n\r\n TJclDebugInfoList = class(TObjectList)\r\n private\r\n function GetItemFromModule(const Module: HMODULE): TJclDebugInfoSource;\r\n function GetItems(Index: Integer): TJclDebugInfoSource;\r\n protected\r\n function CreateDebugInfo(const Module: HMODULE): TJclDebugInfoSource;\r\n public\r\n class procedure RegisterDebugInfoSource(\r\n const InfoSourceClass: TJclDebugInfoSourceClass);\r\n class procedure UnRegisterDebugInfoSource(\r\n const InfoSourceClass: TJclDebugInfoSourceClass);\r\n class procedure RegisterDebugInfoSourceFirst(\r\n const InfoSourceClass: TJclDebugInfoSourceClass);\r\n class procedure NeedInfoSourceClassList;\r\n function GetLocationInfo(const Addr: Pointer; out Info: TJclLocationInfo): Boolean;\r\n property ItemFromModule[const Module: HMODULE]: TJclDebugInfoSource read GetItemFromModule;\r\n property Items[Index: Integer]: TJclDebugInfoSource read GetItems;\r\n end;\r\n\r\n // Various source location implementations\r\n TJclDebugInfoMap = class(TJclDebugInfoSource)\r\n private\r\n FScanner: TJclMapScanner;\r\n public\r\n destructor Destroy; override;\r\n function InitializeSource: Boolean; override;\r\n function GetLocationInfo(const Addr: Pointer; out Info: TJclLocationInfo): Boolean; override;\r\n end;\r\n\r\n TJclDebugInfoBinary = class(TJclDebugInfoSource)\r\n private\r\n FScanner: TJclBinDebugScanner;\r\n FStream: TCustomMemoryStream;\r\n public\r\n destructor Destroy; override;\r\n function InitializeSource: Boolean; override;\r\n function GetLocationInfo(const Addr: Pointer; out Info: TJclLocationInfo): Boolean; override;\r\n end;\r\n\r\n TJclDebugInfoExports = class(TJclDebugInfoSource)\r\n private\r\n {$IFDEF BORLAND}\r\n FImage: TJclPeBorImage;\r\n {$ENDIF BORLAND}\r\n {$IFDEF FPC}\r\n FImage: TJclPeImage;\r\n {$ENDIF FPC}\r\n function IsAddressInThisExportedFunction(Addr: PByteArray; FunctionStartAddr: TJclAddr): Boolean;\r\n public\r\n destructor Destroy; override;\r\n function InitializeSource: Boolean; override;\r\n function GetLocationInfo(const Addr: Pointer; out Info: TJclLocationInfo): Boolean; override;\r\n end;\r\n\r\n {$IFDEF BORLAND}\r\n TJclDebugInfoTD32 = class(TJclDebugInfoSource)\r\n private\r\n FImage: TJclPeBorTD32Image;\r\n public\r\n destructor Destroy; override;\r\n function InitializeSource: Boolean; override;\r\n function GetLocationInfo(const Addr: Pointer; out Info: TJclLocationInfo): Boolean; override;\r\n end;\r\n {$ENDIF BORLAND}\r\n\r\n TJclDebugInfoSymbols = class(TJclDebugInfoSource)\r\n public\r\n class function LoadDebugFunctions: Boolean;\r\n class function UnloadDebugFunctions: Boolean;\r\n class function InitializeDebugSymbols: Boolean;\r\n class function CleanupDebugSymbols: Boolean;\r\n function InitializeSource: Boolean; override;\r\n function GetLocationInfo(const Addr: Pointer; out Info: TJclLocationInfo): Boolean; override;\r\n end;\r\n\r\n// Source location functions\r\nfunction Caller(Level: Integer = 0; FastStackWalk: Boolean = False): Pointer;\r\n\r\nfunction GetLocationInfo(const Addr: Pointer): TJclLocationInfo; overload;\r\nfunction GetLocationInfo(const Addr: Pointer; out Info: TJclLocationInfo): Boolean; overload;\r\nfunction GetLocationInfoStr(const Addr: Pointer; IncludeModuleName: Boolean = False;\r\n IncludeAddressOffset: Boolean = False; IncludeStartProcLineOffset: Boolean = False;\r\n IncludeVAddress: Boolean = False): string;\r\nfunction DebugInfoAvailable(const Module: HMODULE): Boolean;\r\nprocedure ClearLocationData;\r\n\r\nfunction FileByLevel(const Level: Integer = 0): string;\r\nfunction ModuleByLevel(const Level: Integer = 0): string;\r\nfunction ProcByLevel(const Level: Integer = 0; OnlyProcedureName: boolean =false): string;\r\nfunction LineByLevel(const Level: Integer = 0): Integer;\r\nfunction MapByLevel(const Level: Integer; var File_, Module_, Proc_: string; var Line_: Integer): Boolean;\r\n\r\nfunction FileOfAddr(const Addr: Pointer): string;\r\nfunction ModuleOfAddr(const Addr: Pointer): string;\r\nfunction ProcOfAddr(const Addr: Pointer): string;\r\nfunction LineOfAddr(const Addr: Pointer): Integer;\r\nfunction MapOfAddr(const Addr: Pointer; var File_, Module_, Proc_: string; var Line_: Integer): Boolean;\r\n\r\nfunction ExtractClassName(const ProcedureName: string): string;\r\nfunction ExtractMethodName(const ProcedureName: string): string;\r\n\r\n// Original function names, deprecated will be removed in V2.0; do not use!\r\n\r\nfunction __FILE__(const Level: Integer = 0): string; {$IFDEF SUPPORTS_DEPRECATED} deprecated; {$ENDIF}\r\nfunction __MODULE__(const Level: Integer = 0): string; {$IFDEF SUPPORTS_DEPRECATED} deprecated; {$ENDIF}\r\nfunction __PROC__(const Level: Integer = 0): string; {$IFDEF SUPPORTS_DEPRECATED} deprecated; {$ENDIF}\r\nfunction __LINE__(const Level: Integer = 0): Integer; {$IFDEF SUPPORTS_DEPRECATED} deprecated; {$ENDIF}\r\nfunction __MAP__(const Level: Integer; var _File, _Module, _Proc: string; var _Line: Integer): Boolean; {$IFDEF SUPPORTS_DEPRECATED} deprecated; {$ENDIF}\r\nfunction __FILE_OF_ADDR__(const Addr: Pointer): string; {$IFDEF SUPPORTS_DEPRECATED} deprecated; {$ENDIF}\r\nfunction __MODULE_OF_ADDR__(const Addr: Pointer): string; {$IFDEF SUPPORTS_DEPRECATED} deprecated; {$ENDIF}\r\nfunction __PROC_OF_ADDR__(const Addr: Pointer): string; {$IFDEF SUPPORTS_DEPRECATED} deprecated; {$ENDIF}\r\nfunction __LINE_OF_ADDR__(const Addr: Pointer): Integer; {$IFDEF SUPPORTS_DEPRECATED} deprecated; {$ENDIF}\r\nfunction __MAP_OF_ADDR__(const Addr: Pointer; var _File, _Module, _Proc: string;\r\n var _Line: Integer): Boolean; {$IFDEF SUPPORTS_DEPRECATED} deprecated; {$ENDIF}\r\n\r\n// Stack info routines base list\r\ntype\r\n TJclStackBaseList = class(TObjectList)\r\n private\r\n FThreadID: DWORD;\r\n FTimeStamp: TDateTime;\r\n protected\r\n FOnDestroy: TNotifyEvent;\r\n public\r\n constructor Create;\r\n destructor Destroy; override;\r\n property ThreadID: DWORD read FThreadID;\r\n property TimeStamp: TDateTime read FTimeStamp;\r\n end;\r\n\r\n// Stack info routines\r\ntype\r\n PDWORD_PTRArray = ^TDWORD_PTRArray;\r\n TDWORD_PTRArray = array [0..(MaxInt - $F) div SizeOf(DWORD_PTR)] of DWORD_PTR;\r\n {$IFNDEF FPC}\r\n PDWORD_PTR = ^DWORD_PTR;\r\n {$ENDIF ~FPC}\r\n\r\n PStackFrame = ^TStackFrame;\r\n TStackFrame = record\r\n CallerFrame: TJclAddr;\r\n CallerAddr: TJclAddr;\r\n end;\r\n\r\n PStackInfo = ^TStackInfo;\r\n TStackInfo = record\r\n CallerAddr: TJclAddr;\r\n Level: Integer;\r\n CallerFrame: TJclAddr;\r\n DumpSize: DWORD;\r\n ParamSize: DWORD;\r\n ParamPtr: PDWORD_PTRArray;\r\n case Integer of\r\n 0:\r\n (StackFrame: PStackFrame);\r\n 1:\r\n (DumpPtr: PJclByteArray);\r\n end;\r\n\r\n TJclStackInfoItem = class(TObject)\r\n private\r\n FStackInfo: TStackInfo;\r\n function GetCallerAddr: Pointer;\r\n function GetLogicalAddress: TJclAddr;\r\n public\r\n property CallerAddr: Pointer read GetCallerAddr;\r\n property LogicalAddress: TJclAddr read GetLogicalAddress;\r\n property StackInfo: TStackInfo read FStackInfo;\r\n end;\r\n\r\n TJclStackInfoList = class(TJclStackBaseList)\r\n private\r\n FIgnoreLevels: Integer;\r\n TopOfStack: TJclAddr;\r\n BaseOfStack: TJclAddr;\r\n FStackData: PPointer;\r\n FFramePointer: Pointer;\r\n FModuleInfoList: TJclModuleInfoList;\r\n FCorrectOnAccess: Boolean;\r\n FSkipFirstItem: Boolean;\r\n FDelayedTrace: Boolean;\r\n FInStackTracing: Boolean;\r\n FRaw: Boolean;\r\n FStackOffset: Int64;\r\n {$IFDEF CPU64}\r\n procedure CaptureBackTrace;\r\n {$ENDIF CPU64}\r\n function GetItems(Index: Integer): TJclStackInfoItem;\r\n function NextStackFrame(var StackFrame: PStackFrame; var StackInfo: TStackInfo): Boolean;\r\n procedure StoreToList(const StackInfo: TStackInfo);\r\n procedure TraceStackFrames;\r\n procedure TraceStackRaw;\r\n {$IFDEF CPU32}\r\n procedure DelayStoreStack;\r\n {$ENDIF CPU32}\r\n function ValidCallSite(CodeAddr: TJclAddr; out CallInstructionSize: Cardinal): Boolean;\r\n function ValidStackAddr(StackAddr: TJclAddr): Boolean;\r\n function GetCount: Integer;\r\n procedure CorrectOnAccess(ASkipFirstItem: Boolean);\r\n public\r\n constructor Create(ARaw: Boolean; AIgnoreLevels: Integer;\r\n AFirstCaller: Pointer); overload;\r\n constructor Create(ARaw: Boolean; AIgnoreLevels: Integer;\r\n AFirstCaller: Pointer; ADelayedTrace: Boolean); overload;\r\n constructor Create(ARaw: Boolean; AIgnoreLevels: Integer;\r\n AFirstCaller: Pointer; ADelayedTrace: Boolean; ABaseOfStack: Pointer); overload;\r\n constructor Create(ARaw: Boolean; AIgnoreLevels: Integer;\r\n AFirstCaller: Pointer; ADelayedTrace: Boolean; ABaseOfStack, ATopOfStack: Pointer); overload;\r\n destructor Destroy; override;\r\n procedure ForceStackTracing;\r\n procedure AddToStrings(Strings: TStrings; IncludeModuleName: Boolean = False;\r\n IncludeAddressOffset: Boolean = False; IncludeStartProcLineOffset: Boolean = False;\r\n IncludeVAddress: Boolean = False);\r\n property DelayedTrace: Boolean read FDelayedTrace;\r\n property Items[Index: Integer]: TJclStackInfoItem read GetItems; default;\r\n property IgnoreLevels: Integer read FIgnoreLevels;\r\n property Count: Integer read GetCount;\r\n property Raw: Boolean read FRaw;\r\n end;\r\n\r\nfunction JclCreateStackList(Raw: Boolean; AIgnoreLevels: Integer; FirstCaller: Pointer): TJclStackInfoList; overload;\r\nfunction JclCreateStackList(Raw: Boolean; AIgnoreLevels: Integer; FirstCaller: Pointer;\r\n DelayedTrace: Boolean): TJclStackInfoList; overload;\r\nfunction JclCreateStackList(Raw: Boolean; AIgnoreLevels: Integer; FirstCaller: Pointer;\r\n DelayedTrace: Boolean; BaseOfStack: Pointer): TJclStackInfoList; overload;\r\nfunction JclCreateStackList(Raw: Boolean; AIgnoreLevels: Integer; FirstCaller: Pointer;\r\n DelayedTrace: Boolean; BaseOfStack, TopOfStack: Pointer): TJclStackInfoList; overload;\r\n\r\nfunction JclCreateThreadStackTrace(Raw: Boolean; const ThreadHandle: THandle): TJclStackInfoList;\r\nfunction JclCreateThreadStackTraceFromID(Raw: Boolean; ThreadID: DWORD): TJclStackInfoList;\r\n\r\nfunction JclLastExceptStackList: TJclStackInfoList;\r\nfunction JclLastExceptStackListToStrings(Strings: TStrings; IncludeModuleName: Boolean = False;\r\n IncludeAddressOffset: Boolean = False; IncludeStartProcLineOffset: Boolean = False;\r\n IncludeVAddress: Boolean = False): Boolean;\r\n\r\nfunction JclGetExceptStackList(ThreadID: DWORD): TJclStackInfoList;\r\nfunction JclGetExceptStackListToStrings(ThreadID: DWORD; Strings: TStrings;\r\n IncludeModuleName: Boolean = False; IncludeAddressOffset: Boolean = False;\r\n IncludeStartProcLineOffset: Boolean = False; IncludeVAddress: Boolean = False): Boolean;\r\n\r\n// helper function for DUnit runtime memory leak check\r\nprocedure JclClearGlobalStackData;\r\n\r\n// Exception frame info routines\r\ntype\r\n PJmpInstruction = ^TJmpInstruction;\r\n TJmpInstruction = packed record // from System.pas\r\n OpCode: Byte;\r\n Distance: Longint;\r\n end;\r\n\r\n TExcDescEntry = record // from System.pas\r\n VTable: Pointer;\r\n Handler: Pointer;\r\n end;\r\n\r\n PExcDesc = ^TExcDesc;\r\n TExcDesc = packed record // from System.pas\r\n JMP: TJmpInstruction;\r\n case Integer of\r\n 0:\r\n (Instructions: array [0..0] of Byte);\r\n 1:\r\n (Cnt: Integer;\r\n ExcTab: array [0..0] of TExcDescEntry);\r\n end;\r\n\r\n PExcFrame = ^TExcFrame;\r\n TExcFrame = record // from System.pas\r\n Next: PExcFrame;\r\n Desc: PExcDesc;\r\n FramePointer: Pointer;\r\n case Integer of\r\n 0:\r\n ();\r\n 1:\r\n (ConstructedObject: Pointer);\r\n 2:\r\n (SelfOfMethod: Pointer);\r\n end;\r\n\r\n PJmpTable = ^TJmpTable;\r\n TJmpTable = packed record\r\n OPCode: Word; // FF 25 = JMP DWORD PTR [$xxxxxxxx], encoded as $25FF\r\n Ptr: Pointer;\r\n end;\r\n\r\n TExceptFrameKind =\r\n (efkUnknown, efkFinally, efkAnyException, efkOnException, efkAutoException);\r\n\r\n TJclExceptFrame = class(TObject)\r\n private\r\n FFrameKind: TExceptFrameKind;\r\n FFrameLocation: Pointer;\r\n FCodeLocation: Pointer;\r\n FExcTab: array of TExcDescEntry;\r\n protected\r\n procedure AnalyseExceptFrame(AExcDesc: PExcDesc);\r\n public\r\n constructor Create(AFrameLocation: Pointer; AExcDesc: PExcDesc);\r\n function Handles(ExceptObj: TObject): Boolean;\r\n function HandlerInfo(ExceptObj: TObject; out HandlerAt: Pointer): Boolean;\r\n property CodeLocation: Pointer read FCodeLocation;\r\n property FrameLocation: Pointer read FFrameLocation;\r\n property FrameKind: TExceptFrameKind read FFrameKind;\r\n end;\r\n\r\n TJclExceptFrameList = class(TJclStackBaseList)\r\n private\r\n FIgnoreLevels: Integer;\r\n function GetItems(Index: Integer): TJclExceptFrame;\r\n protected\r\n function AddFrame(AFrame: PExcFrame): TJclExceptFrame;\r\n public\r\n constructor Create(AIgnoreLevels: Integer);\r\n procedure TraceExceptionFrames;\r\n property Items[Index: Integer]: TJclExceptFrame read GetItems;\r\n property IgnoreLevels: Integer read FIgnoreLevels write FIgnoreLevels;\r\n end;\r\n\r\nfunction JclCreateExceptFrameList(AIgnoreLevels: Integer): TJclExceptFrameList;\r\nfunction JclLastExceptFrameList: TJclExceptFrameList;\r\nfunction JclGetExceptFrameList(ThreadID: DWORD): TJclExceptFrameList;\r\n\r\nfunction JclStartExceptionTracking: Boolean;\r\nfunction JclStopExceptionTracking: Boolean;\r\nfunction JclExceptionTrackingActive: Boolean;\r\n\r\nfunction JclTrackExceptionsFromLibraries: Boolean;\r\n\r\n// Thread exception tracking support\r\ntype\r\n TJclDebugThread = class(TThread)\r\n private\r\n FSyncException: TObject;\r\n FThreadName: string;\r\n procedure DoHandleException;\r\n function GetThreadInfo: string;\r\n protected\r\n procedure DoNotify;\r\n procedure DoSyncHandleException; dynamic;\r\n procedure HandleException(Sender: TObject = nil);\r\n public\r\n constructor Create(ASuspended: Boolean; const AThreadName: string = '');\r\n destructor Destroy; override;\r\n property SyncException: TObject read FSyncException;\r\n property ThreadInfo: string read GetThreadInfo;\r\n property ThreadName: string read FThreadName;\r\n end;\r\n\r\n TJclDebugThreadNotifyEvent = procedure(Thread: TJclDebugThread) of object;\r\n TJclThreadIDNotifyEvent = procedure(ThreadID: DWORD) of object;\r\n\r\n TJclDebugThreadList = class(TObject)\r\n private\r\n FList: TObjectList;\r\n FLock: TJclCriticalSection;\r\n FReadLock: TJclCriticalSection;\r\n FRegSyncThreadID: DWORD;\r\n FSaveCreationStack: Boolean;\r\n FUnregSyncThreadID: DWORD;\r\n FOnSyncException: TJclDebugThreadNotifyEvent;\r\n FOnThreadRegistered: TJclThreadIDNotifyEvent;\r\n FOnThreadUnregistered: TJclThreadIDNotifyEvent;\r\n function GetThreadClassNames(ThreadID: DWORD): string;\r\n function GetThreadInfos(ThreadID: DWORD): string;\r\n function GetThreadNames(ThreadID: DWORD): string;\r\n procedure DoSyncThreadRegistered;\r\n procedure DoSyncThreadUnregistered;\r\n function GetThreadCreationTime(ThreadID: DWORD): TDateTime;\r\n function GetThreadHandle(Index: Integer): THandle;\r\n function GetThreadID(Index: Integer): DWORD;\r\n function GetThreadIDCount: Integer;\r\n function GetThreadParentID(ThreadID: DWORD): DWORD;\r\n function GetThreadValues(ThreadID: DWORD; Index: Integer): string;\r\n function IndexOfThreadID(ThreadID: DWORD): Integer;\r\n protected\r\n procedure DoSyncException(Thread: TJclDebugThread);\r\n procedure DoThreadRegistered(Thread: TThread);\r\n procedure DoThreadUnregistered(Thread: TThread);\r\n procedure InternalRegisterThread(Thread: TThread; ThreadID: DWORD; const ThreadName: string);\r\n procedure InternalUnregisterThread(Thread: TThread; ThreadID: DWORD);\r\n public\r\n constructor Create;\r\n destructor Destroy; override;\r\n function AddStackListToLocationInfoList(ThreadID: DWORD; AList: TJclLocationInfoList): Boolean;\r\n procedure RegisterThread(Thread: TThread; const ThreadName: string);\r\n procedure RegisterThreadID(AThreadID: DWORD);\r\n procedure UnregisterThread(Thread: TThread);\r\n procedure UnregisterThreadID(AThreadID: DWORD);\r\n property Lock: TJclCriticalSection read FLock;\r\n //property ThreadClassNames[ThreadID: DWORD]: string index 1 read GetThreadValues;\r\n property SaveCreationStack: Boolean read FSaveCreationStack write FSaveCreationStack;\r\n property ThreadClassNames[ThreadID: DWORD]: string read GetThreadClassNames;\r\n property ThreadCreationTime[ThreadID: DWORD]: TDateTime read GetThreadCreationTime;\r\n property ThreadHandles[Index: Integer]: THandle read GetThreadHandle;\r\n property ThreadIDs[Index: Integer]: DWORD read GetThreadID;\r\n property ThreadIDCount: Integer read GetThreadIDCount;\r\n //property ThreadInfos[ThreadID: DWORD]: string index 2 read GetThreadValues;\r\n property ThreadInfos[ThreadID: DWORD]: string read GetThreadInfos;\r\n //property ThreadNames[ThreadID: DWORD]: string index 0 read GetThreadValues;\r\n property ThreadNames[ThreadID: DWORD]: string read GetThreadNames;\r\n property ThreadParentIDs[ThreadID: DWORD]: DWORD read GetThreadParentID;\r\n property OnSyncException: TJclDebugThreadNotifyEvent read FOnSyncException write FOnSyncException;\r\n property OnThreadRegistered: TJclThreadIDNotifyEvent read FOnThreadRegistered write FOnThreadRegistered;\r\n property OnThreadUnregistered: TJclThreadIDNotifyEvent read FOnThreadUnregistered write FOnThreadUnregistered;\r\n end;\r\n\r\n TJclDebugThreadInfo = class(TObject)\r\n private\r\n FCreationTime: TDateTime;\r\n FParentThreadID: DWORD;\r\n FStackList: TJclStackInfoList;\r\n FThreadClassName: string;\r\n FThreadID: DWORD;\r\n FThreadHandle: THandle;\r\n FThreadName: string;\r\n public\r\n constructor Create(AParentThreadID, AThreadID: DWORD; AStack: Boolean);\r\n destructor Destroy; override;\r\n property CreationTime: TDateTime read FCreationTime;\r\n property ParentThreadID: DWORD read FParentThreadID;\r\n property StackList: TJclStackInfoList read FStackList;\r\n property ThreadClassName: string read FThreadClassName write FThreadClassName;\r\n property ThreadID: DWORD read FThreadID;\r\n property ThreadHandle: THandle read FThreadHandle write FThreadHandle;\r\n property ThreadName: string read FThreadName write FThreadName;\r\n end;\r\n\r\n TJclThreadInfoOptions = set of (tioIsMainThread, tioName, tioCreationTime, tioParentThreadID, tioStack, tioCreationStack);\r\n\r\n TJclCustomThreadInfo = class(TPersistent)\r\n protected\r\n FCreationTime: TDateTime;\r\n FCreationStack: TJclCustomLocationInfoList;\r\n FName: string;\r\n FParentThreadID: DWORD;\r\n FStack: TJclCustomLocationInfoList;\r\n FThreadID: DWORD;\r\n FValues: TJclThreadInfoOptions;\r\n procedure AssignTo(Dest: TPersistent); override;\r\n function GetStackClass: TJclCustomLocationInfoListClass; virtual;\r\n public\r\n constructor Create;\r\n destructor Destroy; override;\r\n property CreationTime: TDateTime read FCreationTime write FCreationTime;\r\n property Name: string read FName write FName;\r\n property ParentThreadID: DWORD read FParentThreadID write FParentThreadID;\r\n property ThreadID: DWORD read FThreadID write FThreadID;\r\n property Values: TJclThreadInfoOptions read FValues write FValues;\r\n end;\r\n\r\n TJclThreadInfo = class(TJclCustomThreadInfo)\r\n private\r\n function GetAsString: string;\r\n procedure InternalFill(AThreadHandle: THandle; AThreadID: DWORD; AGatherOptions: TJclThreadInfoOptions; AExceptThread: Boolean);\r\n function GetStack(const AIndex: Integer): TJclLocationInfoList;\r\n protected\r\n function GetStackClass: TJclCustomLocationInfoListClass; override;\r\n public\r\n procedure Fill(AThreadHandle: THandle; AThreadID: DWORD; AGatherOptions: TJclThreadInfoOptions);\r\n procedure FillFromExceptThread(AGatherOptions: TJclThreadInfoOptions);\r\n property AsString: string read GetAsString;\r\n property CreationStack: TJclLocationInfoList index 1 read GetStack;\r\n property Stack: TJclLocationInfoList index 2 read GetStack;\r\n end;\r\n\r\n TJclThreadInfoList = class(TPersistent)\r\n private\r\n FGatherOptions: TJclThreadInfoOptions;\r\n FItems: TObjectList;\r\n function GetAsString: string;\r\n function GetCount: Integer;\r\n function GetItems(AIndex: Integer): TJclThreadInfo;\r\n procedure InternalGather(AIncludeThreadIDs, AExcludeThreadIDs: array of DWORD);\r\n protected\r\n procedure AssignTo(Dest: TPersistent); override;\r\n public\r\n constructor Create;\r\n destructor Destroy; override;\r\n function Add: TJclThreadInfo;\r\n procedure Clear;\r\n procedure Gather(AExceptThreadID: DWORD);\r\n procedure GatherExclude(AThreadIDs: array of DWORD);\r\n procedure GatherInclude(AThreadIDs: array of DWORD);\r\n property AsString: string read GetAsString;\r\n property Count: Integer read GetCount;\r\n property GatherOptions: TJclThreadInfoOptions read FGatherOptions write FGatherOptions;\r\n property Items[AIndex: Integer]: TJclThreadInfo read GetItems; default;\r\n end;\r\n\r\nfunction JclDebugThreadList: TJclDebugThreadList;\r\n\r\nfunction JclHookThreads: Boolean;\r\nfunction JclUnhookThreads: Boolean;\r\nfunction JclThreadsHooked: Boolean;\r\n\r\n// Miscellanuous\r\n{$IFDEF MSWINDOWS}\r\nfunction EnableCrashOnCtrlScroll(const Enable: Boolean): Boolean;\r\nfunction IsDebuggerAttached: Boolean;\r\nfunction IsHandleValid(Handle: THandle): Boolean;\r\n{$ENDIF MSWINDOWS}\r\n\r\n{$IFDEF SUPPORTS_EXTSYM}\r\n{$EXTERNALSYM __FILE__}\r\n{$EXTERNALSYM __LINE__}\r\n{$ENDIF SUPPORTS_EXTSYM}\r\n\r\nconst\r\n EnvironmentVarNtSymbolPath = '_NT_SYMBOL_PATH'; // do not localize\r\n EnvironmentVarAlternateNtSymbolPath = '_NT_ALTERNATE_SYMBOL_PATH'; // do not localize\r\n MaxStackTraceItems = 4096;\r\n\r\n// JCL binary debug data generator and scanner\r\nconst\r\n JclDbgDataSignature = $4742444A; // JDBG\r\n JclDbgDataResName = AnsiString('JCLDEBUG'); // do not localize\r\n JclDbgHeaderVersion = 1; // JCL 1.11 and 1.20\r\n\r\n JclDbgFileExtension = '.jdbg'; // do not localize\r\n JclMapFileExtension = '.map'; // do not localize\r\n DrcFileExtension = '.drc'; // do not localize\r\n\r\n// Global exceptional stack tracker enable routines and variables\r\ntype\r\n TJclStackTrackingOption =\r\n (stStack, stExceptFrame, stRawMode, stAllModules, stStaticModuleList,\r\n stDelayedTrace, stTraceAllExceptions, stMainThreadOnly, stDisableIfDebuggerAttached);\r\n TJclStackTrackingOptions = set of TJclStackTrackingOption;\r\n\r\n//const\r\n // replaced by RemoveIgnoredException(EAbort)\r\n // stTraceEAbort = stTraceAllExceptions;\r\n\r\nvar\r\n JclStackTrackingOptions: TJclStackTrackingOptions = [stStack];\r\n\r\n { JclDebugInfoSymbolPaths specifies a list of paths, separated by ';', in\r\n which the DebugInfoSymbol scanner should look for symbol information. }\r\n JclDebugInfoSymbolPaths: string = '';\r\n\r\n// functions to add/remove exception classes to be ignored if StTraceAllExceptions is not set\r\nprocedure AddIgnoredException(const ExceptionClass: TClass);\r\nprocedure AddIgnoredExceptionByName(const AExceptionClassName: string);\r\nprocedure RemoveIgnoredException(const ExceptionClass: TClass);\r\nprocedure RemoveIgnoredExceptionByName(const AExceptionClassName: string);\r\nfunction IsIgnoredException(const ExceptionClass: TClass): Boolean;\r\n// function to add additional system modules to be included in the stack trace\r\nprocedure AddModule(const ModuleName: string);\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jcl.svn.sourceforge.net/svnroot/jcl/tags/JCL-2.4-Build4571/jcl/source/windows/JclDebug.pas $';\r\n Revision: '$Revision: 3861 $';\r\n Date: '$Date: 2012-09-04 16:08:04 +0200 (mar. 04 sept. 2012) $';\r\n LogPath: 'JCL\\source\\windows';\r\n Extra: '';\r\n Data: nil\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n {$IFDEF HAS_UNITSCOPE}\r\n System.RTLConsts,\r\n System.Types, // for inlining TList.Remove\r\n {$IFDEF HAS_UNIT_CHARACTER}\r\n System.Character,\r\n {$ENDIF HAS_UNIT_CHARACTER}\r\n {$IFDEF SUPPORTS_GENERICS}\r\n System.Generics.Collections,\r\n {$ENDIF SUPPORTS_GENERICS}\r\n {$ELSE ~HAS_UNITSCOPE}\r\n RTLConsts,\r\n {$IFDEF HAS_UNIT_CHARACTER}\r\n Character,\r\n {$ENDIF HAS_UNIT_CHARACTER}\r\n {$IFDEF SUPPORTS_GENERICS}\r\n Generics.Collections,\r\n {$ENDIF SUPPORTS_GENERICS}\r\n {$ENDIF ~HAS_UNITSCOPE}\r\n {$IFDEF MSWINDOWS}\r\n JclRegistry,\r\n {$ENDIF MSWINDOWS}\r\n JclHookExcept, JclStrings, JclSysInfo, JclSysUtils, JclWin32,\r\n JclStringConversions, JclResources;\r\n\r\n//=== Helper assembler routines ==============================================\r\n\r\nconst\r\n ModuleCodeOffset = $1000;\r\n\r\n{$STACKFRAMES OFF}\r\n\r\nfunction GetFramePointer: Pointer;\r\nasm\r\n {$IFDEF CPU32}\r\n MOV EAX, EBP\r\n {$ENDIF CPU32}\r\n {$IFDEF CPU64}\r\n MOV RAX, RBP\r\n {$ENDIF CPU64}\r\nend;\r\n\r\nfunction GetStackPointer: Pointer;\r\nasm\r\n {$IFDEF CPU32}\r\n MOV EAX, ESP\r\n {$ENDIF CPU32}\r\n {$IFDEF CPU64}\r\n MOV RAX, RSP\r\n {$ENDIF CPU64}\r\nend;\r\n\r\nfunction GetExceptionPointer: Pointer;\r\nasm\r\n {$IFDEF CPU32}\r\n XOR EAX, EAX\r\n MOV EAX, FS:[EAX]\r\n {$ENDIF CPU32}\r\n {$IFDEF CPU64}\r\n XOR RAX, RAX\r\n MOV RAX, FS:[RAX]\r\n {$ENDIF CPU64}\r\nend;\r\n\r\n// Reference: Matt Pietrek, MSJ, Under the hood, on TIBs:\r\n// http://www.microsoft.com/MSJ/archive/S2CE.HTM\r\n\r\nfunction GetStackTop: TJclAddr;\r\nasm\r\n {$IFDEF CPU32}\r\n MOV EAX, FS:[0].NT_TIB32.StackBase\r\n {$ENDIF CPU32}\r\n {$IFDEF CPU64}\r\n {$IFDEF DELPHI64_TEMPORARY}\r\n //TODO: check if the FS version doesn't work in general in 64-bit mode\r\n MOV RAX, GS:[ABS 8]\r\n {$ELSE ~DELPHI64_TEMPORARY}\r\n MOV RAX, FS:[0].NT_TIB64.StackBase\r\n {$ENDIF ~DELPHI64_TEMPORARY}\r\n {$ENDIF CPU64}\r\nend;\r\n\r\n{$IFDEF STACKFRAMES_ON}\r\n{$STACKFRAMES ON}\r\n{$ENDIF STACKFRAMES_ON}\r\n\r\n//=== Diagnostics ===========================================================\r\n\r\nprocedure AssertKindOf(const ClassName: string; const Obj: TObject);\r\nvar\r\n C: TClass;\r\nbegin\r\n if not Obj.ClassNameIs(ClassName) then\r\n begin\r\n C := Obj.ClassParent;\r\n while (C <> nil) and (not C.ClassNameIs(ClassName)) do\r\n C := C.ClassParent;\r\n Assert(C <> nil);\r\n end;\r\nend;\r\n\r\nprocedure AssertKindOf(const ClassType: TClass; const Obj: TObject);\r\nbegin\r\n Assert(Obj.InheritsFrom(ClassType));\r\nend;\r\n\r\nprocedure TraceMsg(const Msg: string);\r\nbegin\r\n OutputDebugString(PChar(StrDoubleQuote(Msg)));\r\nend;\r\n\r\nprocedure TraceFmt(const Fmt: string; const Args: array of const);\r\nbegin\r\n OutputDebugString(PChar(Format(StrDoubleQuote(Fmt), Args)));\r\nend;\r\n\r\nprocedure TraceLoc(const Msg: string);\r\nbegin\r\n OutputDebugString(PChar(Format('%s:%u (%s) \"%s\"',\r\n [FileByLevel(1), LineByLevel(1), ProcByLevel(1), Msg])));\r\nend;\r\n\r\nprocedure TraceLocFmt(const Fmt: string; const Args: array of const);\r\nvar\r\n S: string;\r\nbegin\r\n S := Format('%s:%u (%s) ', [FileByLevel(1), LineByLevel(1), ProcByLevel(1)]) +\r\n Format(StrDoubleQuote(Fmt), Args);\r\n OutputDebugString(PChar(S));\r\nend;\r\n\r\n//=== { TJclModuleInfoList } =================================================\r\n\r\nconstructor TJclModuleInfoList.Create(ADynamicBuild, ASystemModulesOnly: Boolean);\r\nbegin\r\n inherited Create(True);\r\n FDynamicBuild := ADynamicBuild;\r\n FSystemModulesOnly := ASystemModulesOnly;\r\n if not FDynamicBuild then\r\n BuildModulesList;\r\nend;\r\n\r\nfunction TJclModuleInfoList.AddModule(Module: HMODULE; SystemModule: Boolean): Boolean;\r\nbegin\r\n Result := not IsValidModuleAddress(Pointer(Module)) and\r\n (CreateItemForAddress(Pointer(Module), SystemModule) <> nil);\r\nend;\r\n\r\n{function SortByStartAddress(Item1, Item2: Pointer): Integer;\r\nbegin\r\n Result := INT_PTR(TJclModuleInfo(Item2).StartAddr) - INT_PTR(TJclModuleInfo(Item1).StartAddr);\r\nend;}\r\n\r\nprocedure TJclModuleInfoList.BuildModulesList;\r\nvar\r\n List: TStringList;\r\n I: Integer;\r\n CurModule: PLibModule;\r\nbegin\r\n if FSystemModulesOnly then\r\n begin\r\n CurModule := LibModuleList;\r\n while CurModule <> nil do\r\n begin\r\n CreateItemForAddress(Pointer(CurModule.Instance), True);\r\n CurModule := CurModule.Next;\r\n end;\r\n end\r\n else\r\n begin\r\n List := TStringList.Create;\r\n try\r\n LoadedModulesList(List, GetCurrentProcessId, True);\r\n for I := 0 to List.Count - 1 do\r\n CreateItemForAddress(List.Objects[I], False);\r\n finally\r\n List.Free;\r\n end;\r\n end;\r\n //Sort(SortByStartAddress);\r\nend;\r\n\r\nfunction TJclModuleInfoList.CreateItemForAddress(Addr: Pointer; SystemModule: Boolean): TJclModuleInfo;\r\nvar\r\n Module: HMODULE;\r\n ModuleSize: DWORD;\r\nbegin\r\n Result := nil;\r\n Module := ModuleFromAddr(Addr);\r\n if Module > 0 then\r\n begin\r\n ModuleSize := PeMapImgSize(Pointer(Module));\r\n if ModuleSize <> 0 then\r\n begin\r\n Result := TJclModuleInfo.Create;\r\n Result.FStartAddr := Pointer(Module);\r\n Result.FSize := ModuleSize;\r\n Result.FEndAddr := Pointer(Module + ModuleSize - 1);\r\n if SystemModule then\r\n Result.FSystemModule := True\r\n else\r\n Result.FSystemModule := IsSystemModule(Module);\r\n end;\r\n end;\r\n if Result <> nil then\r\n Add(Result);\r\nend;\r\n\r\nfunction TJclModuleInfoList.GetItems(Index: Integer): TJclModuleInfo;\r\nbegin\r\n Result := TJclModuleInfo(Get(Index));\r\nend;\r\n\r\nfunction TJclModuleInfoList.GetModuleFromAddress(Addr: Pointer): TJclModuleInfo;\r\nvar\r\n I: Integer;\r\n Item: TJclModuleInfo;\r\nbegin\r\n Result := nil;\r\n for I := 0 to Count - 1 do\r\n begin\r\n Item := Items[I];\r\n if (TJclAddr(Item.StartAddr) <= TJclAddr(Addr)) and (TJclAddr(Item.EndAddr) > TJclAddr(Addr)) then\r\n begin\r\n Result := Item;\r\n Break;\r\n end;\r\n end;\r\n if DynamicBuild and (Result = nil) then\r\n Result := CreateItemForAddress(Addr, False);\r\nend;\r\n\r\nfunction TJclModuleInfoList.IsSystemModuleAddress(Addr: Pointer): Boolean;\r\nvar\r\n Item: TJclModuleInfo;\r\nbegin\r\n Item := ModuleFromAddress[Addr];\r\n Result := (Item <> nil) and Item.SystemModule;\r\nend;\r\n\r\nfunction TJclModuleInfoList.IsValidModuleAddress(Addr: Pointer): Boolean;\r\nbegin\r\n Result := ModuleFromAddress[Addr] <> nil;\r\nend;\r\n\r\n//=== { TJclAbstractMapParser } ==============================================\r\n\r\nconstructor TJclAbstractMapParser.Create(const MapFileName: TFileName; Module: HMODULE);\r\n//AM begin\r\n// inherited Create;\r\n// FModule := Module;\r\n// if FileExists(MapFileName) then\r\n// FStream := TJclFileMappingStream.Create(MapFileName, fmOpenRead or fmShareDenyWrite);\r\n//end;\r\nvar filestrm: TFileStream;\r\nbegin\r\n inherited Create;\r\n FModule := Module;\r\n if FileExists(MapFileName) then\r\n begin\r\n //FStream := TJclFileMappingStream.Create(MapFileName, fmOpenReadWrite);//or fmShareDenyWrite);\r\n FStream := TMemoryStream.Create;\r\n filestrm := TFileStream.Create(MapFileName, fmOpenRead);\r\n try\r\n filestrm.Position := 0;\r\n FStream.CopyFrom(filestrm, filestrm.Size);\r\n FStream.Position := 0;\r\n finally\r\n filestrm.Free;\r\n end;\r\n end;\r\nend;\r\n\r\nconstructor TJclAbstractMapParser.Create(const MapFileName: TFileName);\r\nbegin\r\n Create(MapFileName, 0);\r\nend;\r\n\r\ndestructor TJclAbstractMapParser.Destroy;\r\nbegin\r\n FreeAndNil(FStream);\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJclAbstractMapParser.GetLinkerBugUnitName: string;\r\nbegin\r\n Result := MapStringToStr(FLinkerBugUnitName);\r\nend;\r\n\r\nclass function TJclAbstractMapParser.MapStringToFileName(MapString: PJclMapString): string;\r\nvar\r\n PEnd: PJclMapString;\r\nbegin\r\n if MapString = nil then\r\n begin\r\n Result := '';\r\n Exit;\r\n end;\r\n PEnd := MapString;\r\n while (PEnd^ <> #0) and not (PEnd^ in ['=', #10, #13]) do\r\n Inc(PEnd);\r\n if (PEnd^ = '=') then\r\n begin\r\n while (PEnd >= MapString) and (PEnd^ <> ' ') do\r\n Dec(PEnd);\r\n while (PEnd >= MapString) and ((PEnd-1)^ = ' ') do\r\n Dec(PEnd);\r\n end;\r\n SetString(Result, MapString, PEnd - MapString);\r\nend;\r\n\r\nclass function TJclAbstractMapParser.MapStringToModuleName(MapString: PJclMapString): string;\r\nvar\r\n PStart, PEnd, PExtension: PJclMapString;\r\nbegin\r\n if MapString = nil then\r\n begin\r\n Result := '';\r\n Exit;\r\n end;\r\n PEnd := MapString;\r\n while (PEnd^ <> #0) and not (PEnd^ in ['=', #10, #13]) do\r\n Inc(PEnd);\r\n if (PEnd^ = '=') then\r\n begin\r\n while (PEnd >= MapString) and (PEnd^ <> ' ') do\r\n Dec(PEnd);\r\n while (PEnd >= MapString) and ((PEnd-1)^ = ' ') do\r\n Dec(PEnd);\r\n end;\r\n PExtension := PEnd;\r\n while (PExtension >= MapString) and (PExtension^ <> '.') and (PExtension^ <> '|') do\r\n Dec(PExtension);\r\n if (StrLIComp(PExtension, '.pas ', 5) = 0) or\r\n (StrLIComp(PExtension, '.obj ', 5) = 0) then\r\n PEnd := PExtension;\r\n PExtension := PEnd;\r\n while (PExtension >= MapString) and (PExtension^ <> '|') and (PExtension^ <> '\\') do\r\n Dec(PExtension);\r\n if PExtension >= MapString then\r\n PStart := PExtension + 1\r\n else\r\n PStart := MapString;\r\n SetString(Result, PStart, PEnd - PStart);\r\nend;\r\n\r\nclass function TJclAbstractMapParser.MapStringToStr(MapString: PJclMapString;\r\n IgnoreSpaces: Boolean): string;\r\nvar\r\n P: PJclMapString;\r\nbegin\r\n if MapString = nil then\r\n begin\r\n Result := '';\r\n Exit;\r\n end;\r\n if MapString^ = '(' then\r\n begin\r\n Inc(MapString);\r\n P := MapString;\r\n while (P^ <> #0) and not (P^ in [')', #10, #13]) do\r\n Inc(P);\r\n end\r\n else\r\n begin\r\n P := MapString;\r\n if IgnoreSpaces then\r\n while (P^ <> #0) and not (P^ in ['(', #10, #13]) do\r\n Inc(P)\r\n else\r\n while (P^ <> #0) and (P^ <> '(') and (P^ > ' ') do\r\n Inc(P);\r\n end;\r\n SetString(Result, MapString, P - MapString);\r\nend;\r\n\r\nprocedure TJclAbstractMapParser.Parse;\r\nconst\r\n TableHeader : array [0..3] of string = ('Start', 'Length', 'Name', 'Class');\r\n SegmentsHeader : array [0..3] of string = ('Detailed', 'map', 'of', 'segments');\r\n PublicsByNameHeader : array [0..3] of string = ('Address', 'Publics', 'by', 'Name');\r\n PublicsByValueHeader : array [0..3] of string = ('Address', 'Publics', 'by', 'Value');\r\n LineNumbersPrefix : string = 'Line numbers for';\r\nvar\r\n CurrPos, EndPos: PJclMapString;\r\n{$IFNDEF COMPILER9_UP}\r\n PreviousA,\r\n{$ENDIF COMPILER9_UP}\r\n A: TJclMapAddress;\r\n L: Integer;\r\n P1, P2: PJclMapString;\r\n\r\n function Eof: Boolean;\r\n begin\r\n Result := (CurrPos >= EndPos);\r\n end;\r\n\r\n procedure SkipWhiteSpace;\r\n begin\r\n while (CurrPos < EndPos) and (CurrPos^ <= ' ') do\r\n Inc(CurrPos);\r\n end;\r\n\r\n procedure SkipEndLine;\r\n begin\r\n while not Eof and not CharIsReturn(Char(CurrPos^)) do\r\n Inc(CurrPos);\r\n SkipWhiteSpace;\r\n end;\r\n\r\n function IsDecDigit: Boolean;\r\n begin\r\n Result := CharIsDigit(Char(CurrPos^));\r\n end;\r\n\r\n function ReadTextLine: string;\r\n var\r\n P: PJclMapString;\r\n begin\r\n P := CurrPos;\r\n while (CurrPos^ <> #0) and not (CurrPos^ in [#10, #13]) do\r\n Inc(CurrPos);\r\n SetString(Result, P, CurrPos - P);\r\n end;\r\n\r\n\r\n function ReadDecValue: Integer;\r\n begin\r\n Result := 0;\r\n while CurrPos^ in ['0'..'9'] do\r\n begin\r\n Result := Result * 10 + (Ord(CurrPos^) - Ord('0'));\r\n Inc(CurrPos);\r\n end;\r\n end;\r\n\r\n function ReadHexValue: DWORD;\r\n var\r\n C: AnsiChar;\r\n begin\r\n Result := 0;\r\n repeat\r\n C := CurrPos^;\r\n case C of\r\n '0'..'9':\r\n Result := (Result shl 4) or DWORD(Ord(C) - Ord('0'));\r\n 'A'..'F':\r\n Result := (Result shl 4) or DWORD(Ord(C) - Ord('A') + 10);\r\n 'a'..'f':\r\n Result := (Result shl 4) or DWORD(Ord(C) - Ord('a') + 10);\r\n 'H', 'h':\r\n begin\r\n Inc(CurrPos);\r\n Break;\r\n end;\r\n else\r\n Break;\r\n end;\r\n Inc(CurrPos);\r\n until False;\r\n end;\r\n\r\n function ReadAddress: TJclMapAddress;\r\n begin\r\n Result.Segment := ReadHexValue;\r\n if CurrPos^ = ':' then\r\n begin\r\n Inc(CurrPos);\r\n Result.Offset := ReadHexValue;\r\n end\r\n else\r\n Result.Offset := 0;\r\n end;\r\n\r\n function ReadString: PJclMapString;\r\n begin\r\n SkipWhiteSpace;\r\n Result := CurrPos;\r\n while {(CurrPos^ <> #0) and} (CurrPos^ > ' ') do\r\n Inc(CurrPos);\r\n end;\r\n\r\n procedure FindParam(Param: AnsiChar);\r\n begin\r\n while not ((CurrPos^ = Param) and ((CurrPos + 1)^ = '=')) do\r\n Inc(CurrPos);\r\n Inc(CurrPos, 2);\r\n end;\r\n\r\n function SyncToHeader(const Header: array of string): Boolean;\r\n var\r\n S: string;\r\n TokenIndex, OldPosition, CurrentPosition: Integer;\r\n begin\r\n Result := False;\r\n while not Eof do\r\n begin\r\n S := Trim(ReadTextLine);\r\n TokenIndex := Low(Header);\r\n CurrentPosition := 0;\r\n OldPosition := 0;\r\n while (TokenIndex <= High(Header)) do\r\n begin\r\n CurrentPosition := Pos(Header[TokenIndex],S);\r\n if (CurrentPosition <= OldPosition) then\r\n begin\r\n CurrentPosition := 0;\r\n Break;\r\n end;\r\n OldPosition := CurrentPosition;\r\n Inc(TokenIndex);\r\n end;\r\n Result := CurrentPosition <> 0;\r\n if Result then\r\n Break;\r\n SkipEndLine;\r\n end;\r\n if not Eof then\r\n SkipWhiteSpace;\r\n end;\r\n\r\n function SyncToPrefix(const Prefix: string): Boolean;\r\n var\r\n I: Integer;\r\n P: PJclMapString;\r\n S: string;\r\n begin\r\n if Eof then\r\n begin\r\n Result := False;\r\n Exit;\r\n end;\r\n SkipWhiteSpace;\r\n I := Length(Prefix);\r\n P := CurrPos;\r\n while not Eof and (P^ <> #13) and (P^ <> #0) and (I > 0) do\r\n begin\r\n Inc(P);\r\n Dec(I);\r\n end;\r\n SetString(S, CurrPos, Length(Prefix));\r\n Result := (S = Prefix);\r\n if Result then\r\n CurrPos := P;\r\n SkipWhiteSpace;\r\n end;\r\n\r\nbegin\r\n if FStream <> nil then\r\n begin\r\n FLinkerBug := False;\r\n{$IFNDEF COMPILER9_UP}\r\n PreviousA.Segment := 0;\r\n PreviousA.Offset := 0;\r\n{$ENDIF COMPILER9_UP}\r\n CurrPos := FStream.Memory;\r\n EndPos := CurrPos + FStream.Size;\r\n if SyncToHeader(TableHeader) then\r\n while IsDecDigit do\r\n begin\r\n A := ReadAddress;\r\n SkipWhiteSpace;\r\n L := ReadHexValue;\r\n P1 := ReadString;\r\n P2 := ReadString;\r\n SkipEndLine;\r\n ClassTableItem(A, L, P1, P2);\r\n end;\r\n if SyncToHeader(SegmentsHeader) then\r\n while IsDecDigit do\r\n begin\r\n A := ReadAddress;\r\n SkipWhiteSpace;\r\n L := ReadHexValue;\r\n FindParam('C');\r\n P1 := ReadString;\r\n FindParam('M');\r\n P2 := ReadString;\r\n SkipEndLine;\r\n SegmentItem(A, L, P1, P2);\r\n end;\r\n if SyncToHeader(PublicsByNameHeader) then\r\n while IsDecDigit do\r\n begin\r\n A := ReadAddress;\r\n P1 := ReadString;\r\n SkipEndLine; // compatibility with C++Builder MAP files\r\n PublicsByNameItem(A, P1);\r\n end;\r\n if SyncToHeader(PublicsByValueHeader) then\r\n while not Eof and IsDecDigit do\r\n begin\r\n A := ReadAddress;\r\n P1 := ReadString;\r\n SkipEndLine; // compatibility with C++Builder MAP files\r\n PublicsByValueItem(A, P1);\r\n end;\r\n while SyncToPrefix(LineNumbersPrefix) do\r\n begin\r\n FLastUnitName := CurrPos;\r\n FLastUnitFileName := CurrPos;\r\n while FLastUnitFileName^ <> '(' do\r\n Inc(FLastUnitFileName);\r\n SkipEndLine;\r\n LineNumberUnitItem(FLastUnitName, FLastUnitFileName);\r\n repeat\r\n SkipWhiteSpace;\r\n L := ReadDecValue;\r\n SkipWhiteSpace;\r\n A := ReadAddress;\r\n SkipWhiteSpace;\r\n LineNumbersItem(L, A);\r\n{$IFNDEF COMPILER9_UP}\r\n if (not FLinkerBug) and (A.Offset < PreviousA.Offset) then\r\n begin\r\n FLinkerBugUnitName := FLastUnitName;\r\n FLinkerBug := True;\r\n end;\r\n PreviousA := A;\r\n{$ENDIF COMPILER9_UP}\r\n until not IsDecDigit;\r\n end;\r\n end;\r\nend;\r\n\r\n//=== { TJclMapParser 0 ======================================================\r\n\r\nprocedure TJclMapParser.ClassTableItem(const Address: TJclMapAddress;\r\n Len: Integer; SectionName, GroupName: PJclMapString);\r\nbegin\r\n if Assigned(FOnClassTable) then\r\n FOnClassTable(Self, Address, Len, MapStringToStr(SectionName), MapStringToStr(GroupName));\r\nend;\r\n\r\nprocedure TJclMapParser.LineNumbersItem(LineNumber: Integer; const Address: TJclMapAddress);\r\nbegin\r\n if Assigned(FOnLineNumbers) then\r\n FOnLineNumbers(Self, LineNumber, Address);\r\nend;\r\n\r\nprocedure TJclMapParser.LineNumberUnitItem(UnitName, UnitFileName: PJclMapString);\r\nbegin\r\n if Assigned(FOnLineNumberUnit) then\r\n FOnLineNumberUnit(Self, MapStringToStr(UnitName), MapStringToStr(UnitFileName));\r\nend;\r\n\r\nprocedure TJclMapParser.PublicsByNameItem(const Address: TJclMapAddress;\r\n Name: PJclMapString);\r\nbegin\r\n if Assigned(FOnPublicsByName) then\r\n // MAP files generated by C++Builder have spaces in their identifier names\r\n FOnPublicsByName(Self, Address, MapStringToStr(Name, True));\r\nend;\r\n\r\nprocedure TJclMapParser.PublicsByValueItem(const Address: TJclMapAddress;\r\n Name: PJclMapString);\r\nbegin\r\n if Assigned(FOnPublicsByValue) then\r\n // MAP files generated by C++Builder have spaces in their identifier names\r\n FOnPublicsByValue(Self, Address, MapStringToStr(Name, True));\r\nend;\r\n\r\nprocedure TJclMapParser.SegmentItem(const Address: TJclMapAddress;\r\n Len: Integer; GroupName, UnitName: PJclMapString);\r\nbegin\r\n if Assigned(FOnSegmentItem) then\r\n FOnSegmentItem(Self, Address, Len, MapStringToStr(GroupName), MapStringToModuleName(UnitName));\r\nend;\r\n\r\n//=== { TJclMapScanner } =====================================================\r\n\r\nconstructor TJclMapScanner.Create(const MapFileName: TFileName; Module: HMODULE);\r\nbegin\r\n inherited Create(MapFileName, Module);\r\n Scan;\r\nend;\r\n\r\nfunction TJclMapScanner.MAPAddrToVA(const Addr: DWORD): DWORD;\r\nbegin\r\n // MAP file format was changed in Delphi 2005\r\n // before Delphi 2005: segments started at offset 0\r\n // only one segment of code\r\n // after Delphi 2005: segments started at code base address (module base address + $10000)\r\n // 2 segments of code\r\n if (Length(FSegmentClasses) > 0) and (FSegmentClasses[0].Start > 0) and (Addr >= FSegmentClasses[0].Start) then\r\n // Delphi 2005 and later\r\n // The first segment should be code starting at module base address + $10000\r\n Result := Addr - FSegmentClasses[0].Start\r\n else\r\n // before Delphi 2005\r\n Result := Addr;\r\nend;\r\n\r\nclass function TJclMapScanner.MapStringCacheToFileName(\r\n var MapString: TJclMapStringCache): string;\r\nbegin\r\n Result := MapString.CachedValue;\r\n if Result = '' then\r\n begin\r\n Result := MapStringToFileName(MapString.RawValue);\r\n MapString.CachedValue := Result;\r\n end;\r\nend;\r\n\r\nclass function TJclMapScanner.MapStringCacheToModuleName(\r\n var MapString: TJclMapStringCache): string;\r\nbegin\r\n Result := MapString.CachedValue;\r\n if Result = '' then\r\n begin\r\n Result := MapStringToModuleName(MapString.RawValue);\r\n MapString.CachedValue := Result;\r\n end;\r\nend;\r\n\r\nclass function TJclMapScanner.MapStringCacheToStr(var MapString: TJclMapStringCache;\r\n IgnoreSpaces: Boolean): string;\r\nbegin\r\n Result := MapString.CachedValue;\r\n if Result = '' then\r\n begin\r\n Result := MapStringToStr(MapString.RawValue, IgnoreSpaces);\r\n MapString.CachedValue := Result;\r\n end;\r\nend;\r\n\r\nprocedure TJclMapScanner.ClassTableItem(const Address: TJclMapAddress; Len: Integer;\r\n SectionName, GroupName: PJclMapString);\r\nvar\r\n C: Integer;\r\n SectionHeader: PImageSectionHeader;\r\nbegin\r\n C := Length(FSegmentClasses);\r\n SetLength(FSegmentClasses, C + 1);\r\n FSegmentClasses[C].Segment := Address.Segment;\r\n FSegmentClasses[C].Start := Address.Offset;\r\n FSegmentClasses[C].Addr := Address.Offset; // will be fixed below while considering module mapped address\r\n // test GroupName because SectionName = '.tls' in Delphi and '_tls' in BCB\r\n if StrLIComp(GroupName, 'TLS', 3) = 0 then\r\n FSegmentClasses[C].VA := FSegmentClasses[C].Start\r\n else\r\n FSegmentClasses[C].VA := MAPAddrToVA(FSegmentClasses[C].Start);\r\n FSegmentClasses[C].Len := Len;\r\n FSegmentClasses[C].SectionName.RawValue := SectionName;\r\n FSegmentClasses[C].GroupName.RawValue := GroupName;\r\n\r\n if FModule <> 0 then\r\n begin\r\n { Fix the section addresses }\r\n SectionHeader := PeMapImgFindSectionFromModule(Pointer(FModule), MapStringToStr(SectionName));\r\n if SectionHeader = nil then\r\n { before Delphi 2005 the class names where used for the section names }\r\n SectionHeader := PeMapImgFindSectionFromModule(Pointer(FModule), MapStringToStr(GroupName));\r\n\r\n if SectionHeader <> nil then\r\n begin\r\n FSegmentClasses[C].Addr := TJclAddr(FModule) + SectionHeader.VirtualAddress;\r\n FSegmentClasses[C].VA := SectionHeader.VirtualAddress;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJclMapScanner.LineNumberFromAddr(Addr: DWORD): Integer;\r\nvar\r\n Dummy: Integer;\r\nbegin\r\n Result := LineNumberFromAddr(Addr, Dummy);\r\nend;\r\n\r\nfunction Search_MapLineNumber(Item1, Item2: Pointer): Integer;\r\nbegin\r\n Result := Integer(PJclMapLineNumber(Item1)^.VA) - PInteger(Item2)^;\r\nend;\r\n\r\nfunction TJclMapScanner.LineNumberFromAddr(Addr: DWORD; out Offset: Integer): Integer;\r\nvar\r\n I: Integer;\r\n ModuleStartAddr: DWORD;\r\nbegin\r\n ModuleStartAddr := ModuleStartFromAddr(Addr);\r\n Result := 0;\r\n Offset := 0;\r\n I := SearchDynArray(FLineNumbers, SizeOf(FLineNumbers[0]), Search_MapLineNumber, @Addr, True);\r\n if (I <> -1) and (FLineNumbers[I].VA >= ModuleStartAddr) then\r\n begin\r\n Result := FLineNumbers[I].LineNumber;\r\n Offset := Addr - FLineNumbers[I].VA;\r\n end;\r\nend;\r\n\r\nprocedure TJclMapScanner.LineNumbersItem(LineNumber: Integer; const Address: TJclMapAddress);\r\nvar\r\n SegIndex, C: Integer;\r\n VA: DWORD;\r\n Added: Boolean;\r\nbegin\r\n Added := False;\r\n for SegIndex := Low(FSegmentClasses) to High(FSegmentClasses) do\r\n if (FSegmentClasses[SegIndex].Segment = Address.Segment)\r\n and (DWORD(Address.Offset) < FSegmentClasses[SegIndex].Len) then\r\n begin\r\n if StrLIComp(FSegmentClasses[SegIndex].GroupName.RawValue, 'TLS', 3) = 0 then\r\n Va := Address.Offset\r\n else\r\n VA := MAPAddrToVA(Address.Offset + FSegmentClasses[SegIndex].Start);\r\n { Starting with Delphi 2005, \"empty\" units are listes with the last line and\r\n the VA 0001:00000000. When we would accept 0 VAs here, System.pas functions\r\n could be mapped to other units and line numbers. Discaring such items should\r\n have no impact on the correct information, because there can't be a function\r\n that starts at VA 0. }\r\n if VA = 0 then\r\n Continue;\r\n if FLineNumbersCnt = Length(FLineNumbers) then\r\n begin\r\n if FLineNumbersCnt < 512 then\r\n SetLength(FLineNumbers, FLineNumbersCnt + 512)\r\n else\r\n SetLength(FLineNumbers, FLineNumbersCnt * 2);\r\n end;\r\n FLineNumbers[FLineNumbersCnt].Segment := FSegmentClasses[SegIndex].Segment;\r\n FLineNumbers[FLineNumbersCnt].VA := VA;\r\n FLineNumbers[FLineNumbersCnt].LineNumber := LineNumber;\r\n Inc(FLineNumbersCnt);\r\n Added := True;\r\n if FNewUnitFileName <> nil then\r\n begin\r\n C := Length(FSourceNames);\r\n SetLength(FSourceNames, C + 1);\r\n FSourceNames[C].Segment := FSegmentClasses[SegIndex].Segment;\r\n FSourceNames[C].VA := VA;\r\n FSourceNames[C].ProcName.RawValue := FNewUnitFileName;\r\n FNewUnitFileName := nil;\r\n end;\r\n Break;\r\n end;\r\n if not Added then\r\n Inc(FLineNumberErrors);\r\nend;\r\n\r\nprocedure TJclMapScanner.LineNumberUnitItem(UnitName, UnitFileName: PJclMapString);\r\nbegin\r\n FNewUnitFileName := UnitFileName;\r\nend;\r\n\r\nfunction TJclMapScanner.ModuleNameFromAddr(Addr: DWORD): string;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := '';\r\n for I := Length(FSegments) - 1 downto 0 do\r\n if (FSegments[I].StartVA <= Addr) and (Addr < FSegments[I].EndVA) then\r\n begin\r\n Result := MapStringCacheToModuleName(FSegments[I].UnitName);\r\n Break;\r\n end;\r\nend;\r\n\r\nfunction TJclMapScanner.ModuleStartFromAddr(Addr: DWORD): DWORD;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := DWORD(-1);\r\n for I := Length(FSegments) - 1 downto 0 do\r\n if (FSegments[I].StartVA <= Addr) and (Addr < FSegments[I].EndVA) then\r\n begin\r\n Result := FSegments[I].StartVA;\r\n Break;\r\n end;\r\nend;\r\n\r\nfunction TJclMapScanner.ProcNameFromAddr(Addr: DWORD): string;\r\nvar\r\n Dummy: Integer;\r\nbegin\r\n Result := ProcNameFromAddr(Addr, Dummy);\r\nend;\r\n\r\nfunction Search_MapProcName(Item1, Item2: Pointer): Integer;\r\nbegin\r\n Result := Integer(PJclMapProcName(Item1)^.VA) - PInteger(Item2)^;\r\nend;\r\n\r\nfunction TJclMapScanner.ProcNameFromAddr(Addr: DWORD; out Offset: Integer): string;\r\nvar\r\n I: Integer;\r\n ModuleStartAddr: DWORD;\r\nbegin\r\n ModuleStartAddr := ModuleStartFromAddr(Addr);\r\n Result := '';\r\n Offset := 0;\r\n I := SearchDynArray(FProcNames, SizeOf(FProcNames[0]), Search_MapProcName, @Addr, True);\r\n if (I <> -1) and (FProcNames[I].VA >= ModuleStartAddr) then\r\n begin\r\n Result := MapStringCacheToStr(FProcNames[I].ProcName, True);\r\n Offset := Addr - FProcNames[I].VA;\r\n end;\r\nend;\r\n\r\nprocedure TJclMapScanner.PublicsByNameItem(const Address: TJclMapAddress; Name: PJclMapString);\r\nbegin\r\n { TODO : What to do? }\r\nend;\r\n\r\nprocedure TJclMapScanner.PublicsByValueItem(const Address: TJclMapAddress; Name: PJclMapString);\r\nvar\r\n SegIndex: Integer;\r\nbegin\r\n for SegIndex := Low(FSegmentClasses) to High(FSegmentClasses) do\r\n if (FSegmentClasses[SegIndex].Segment = Address.Segment)\r\n and (DWORD(Address.Offset) < FSegmentClasses[SegIndex].Len) then\r\n begin\r\n if FProcNamesCnt = Length(FProcNames) then\r\n begin\r\n if FProcNamesCnt < 512 then\r\n SetLength(FProcNames, FProcNamesCnt + 512)\r\n else\r\n SetLength(FProcNames, FProcNamesCnt * 2);\r\n end;\r\n FProcNames[FProcNamesCnt].Segment := FSegmentClasses[SegIndex].Segment;\r\n if StrLIComp(FSegmentClasses[SegIndex].GroupName.RawValue, 'TLS', 3) = 0 then\r\n FProcNames[FProcNamesCnt].VA := Address.Offset\r\n else\r\n FProcNames[FProcNamesCnt].VA := MAPAddrToVA(Address.Offset + FSegmentClasses[SegIndex].Start);\r\n FProcNames[FProcNamesCnt].ProcName.RawValue := Name;\r\n Inc(FProcNamesCnt);\r\n Break;\r\n end;\r\nend;\r\n\r\nfunction Sort_MapLineNumber(Item1, Item2: Pointer): Integer;\r\nbegin\r\n Result := Integer(PJclMapLineNumber(Item1)^.VA) - Integer(PJclMapLineNumber(Item2)^.VA);\r\nend;\r\n\r\nfunction Sort_MapProcName(Item1, Item2: Pointer): Integer;\r\nbegin\r\n Result := Integer(PJclMapProcName(Item1)^.VA) - Integer(PJclMapProcName(Item2)^.VA);\r\nend;\r\n\r\nfunction Sort_MapSegment(Item1, Item2: Pointer): Integer;\r\nbegin\r\n Result := Integer(PJclMapSegment(Item1)^.StartVA) - Integer(PJclMapSegment(Item2)^.StartVA);\r\nend;\r\n\r\nprocedure TJclMapScanner.Scan;\r\nbegin\r\n FLineNumberErrors := 0;\r\n FSegmentCnt := 0;\r\n FProcNamesCnt := 0;\r\n Parse;\r\n SetLength(FLineNumbers, FLineNumbersCnt);\r\n SetLength(FProcNames, FProcNamesCnt);\r\n SetLength(FSegments, FSegmentCnt);\r\n SortDynArray(FLineNumbers, SizeOf(FLineNumbers[0]), Sort_MapLineNumber);\r\n SortDynArray(FProcNames, SizeOf(FProcNames[0]), Sort_MapProcName);\r\n SortDynArray(FSegments, SizeOf(FSegments[0]), Sort_MapSegment);\r\n SortDynArray(FSourceNames, SizeOf(FSourceNames[0]), Sort_MapProcName);\r\nend;\r\n\r\nprocedure TJclMapScanner.SegmentItem(const Address: TJclMapAddress; Len: Integer;\r\n GroupName, UnitName: PJclMapString);\r\nvar\r\n SegIndex: Integer;\r\n VA: DWORD;\r\nbegin\r\n for SegIndex := Low(FSegmentClasses) to High(FSegmentClasses) do\r\n if (FSegmentClasses[SegIndex].Segment = Address.Segment)\r\n and (DWORD(Address.Offset) < FSegmentClasses[SegIndex].Len) then\r\n begin\r\n if StrLIComp(FSegmentClasses[SegIndex].GroupName.RawValue, 'TLS', 3) = 0 then\r\n VA := Address.Offset\r\n else\r\n VA := MAPAddrToVA(Address.Offset + FSegmentClasses[SegIndex].Start);\r\n if FSegmentCnt mod 16 = 0 then\r\n SetLength(FSegments, FSegmentCnt + 16);\r\n FSegments[FSegmentCnt].Segment := FSegmentClasses[SegIndex].Segment;\r\n FSegments[FSegmentCnt].StartVA := VA;\r\n FSegments[FSegmentCnt].EndVA := VA + DWORD(Len);\r\n FSegments[FSegmentCnt].UnitName.RawValue := UnitName;\r\n Inc(FSegmentCnt);\r\n Break;\r\n end;\r\nend;\r\n\r\nfunction TJclMapScanner.SourceNameFromAddr(Addr: DWORD): string;\r\nvar\r\n I: Integer;\r\n ModuleStartVA: DWORD;\r\nbegin\r\n // try with line numbers first (Delphi compliance)\r\n ModuleStartVA := ModuleStartFromAddr(Addr);\r\n Result := '';\r\n I := SearchDynArray(FSourceNames, SizeOf(FSourceNames[0]), Search_MapProcName, @Addr, True);\r\n if (I <> -1) and (FSourceNames[I].VA >= ModuleStartVA) then\r\n Result := MapStringCacheToStr(FSourceNames[I].ProcName);\r\n if Result = '' then\r\n begin\r\n // try with module names (C++Builder compliance)\r\n for I := Length(FSegments) - 1 downto 0 do\r\n if (FSegments[I].StartVA <= Addr) and (Addr < FSegments[I].EndVA) then\r\n begin\r\n Result := MapStringCacheToFileName(FSegments[I].UnitName);\r\n Break;\r\n end;\r\n end;\r\nend;\r\n\r\n// JCL binary debug format string encoding/decoding routines\r\n{ Strings are compressed to following 6bit format (A..D represents characters) and terminated with }\r\n{ 6bit #0 char. First char = #1 indicates non compressed text, #2 indicates compressed text with }\r\n{ leading '@' character }\r\n{ }\r\n{ 7 6 5 4 3 2 1 0 | }\r\n{--------------------------------- }\r\n{ B1 B0 A5 A4 A3 A2 A1 A0 | Data byte 0 }\r\n{--------------------------------- }\r\n{ C3 C2 C1 C0 B5 B4 B3 B2 | Data byte 1 }\r\n{--------------------------------- }\r\n{ D5 D4 D3 D2 D1 D0 C5 C4 | Data byte 2 }\r\n{--------------------------------- }\r\n\r\nfunction SimpleCryptString(const S: TUTF8String): TUTF8String;\r\nvar\r\n I: Integer;\r\n C: Byte;\r\n P: PByte;\r\nbegin\r\n SetLength(Result, Length(S));\r\n P := PByte(Result);\r\n for I := 1 to Length(S) do\r\n begin\r\n C := Ord(S[I]);\r\n if C <> $AA then\r\n C := C xor $AA;\r\n P^ := C;\r\n Inc(P);\r\n end;\r\nend;\r\n\r\nfunction DecodeNameString(const S: PAnsiChar): string;\r\nvar\r\n I, B: Integer;\r\n C: Byte;\r\n P: PByte;\r\n Buffer: array [0..255] of AnsiChar;\r\nbegin\r\n Result := '';\r\n B := 0;\r\n P := PByte(S);\r\n case P^ of\r\n 1:\r\n begin\r\n Inc(P);\r\n Result := UTF8ToString(SimpleCryptString(PAnsiChar(P)));\r\n Exit;\r\n end;\r\n 2:\r\n begin\r\n Inc(P);\r\n Buffer[B] := '@';\r\n Inc(B);\r\n end;\r\n end;\r\n I := 0;\r\n C := 0;\r\n repeat\r\n case I and $03 of\r\n 0:\r\n C := P^ and $3F;\r\n 1:\r\n begin\r\n C := (P^ shr 6) and $03;\r\n Inc(P);\r\n Inc(C, (P^ and $0F) shl 2);\r\n end;\r\n 2:\r\n begin\r\n C := (P^ shr 4) and $0F;\r\n Inc(P);\r\n Inc(C, (P^ and $03) shl 4);\r\n end;\r\n 3:\r\n begin\r\n C := (P^ shr 2) and $3F;\r\n Inc(P);\r\n end;\r\n end;\r\n case C of\r\n $00:\r\n Break;\r\n $01..$0A:\r\n Inc(C, Ord('0') - $01);\r\n $0B..$24:\r\n Inc(C, Ord('A') - $0B);\r\n $25..$3E:\r\n Inc(C, Ord('a') - $25);\r\n $3F:\r\n C := Ord('_');\r\n end;\r\n Buffer[B] := AnsiChar(C);\r\n Inc(B);\r\n Inc(I);\r\n until B >= SizeOf(Buffer) - 1;\r\n Buffer[B] := #0;\r\n Result := UTF8ToString(Buffer);\r\nend;\r\n\r\nfunction EncodeNameString(const S: string): AnsiString;\r\nvar\r\n I, StartIndex, EndIndex: Integer;\r\n C: Byte;\r\n P: PByte;\r\nbegin\r\n if (Length(S) > 1) and (S[1] = '@') then\r\n StartIndex := 1\r\n else\r\n StartIndex := 0;\r\n for I := StartIndex + 1 to Length(S) do\r\n if not CharIsValidIdentifierLetter(Char(S[I])) then\r\n begin\r\n {$IFDEF SUPPORTS_UNICODE}\r\n Result := #1 + SimpleCryptString(UTF8Encode(S)) + #0; // UTF8Encode is much faster than StringToUTF8\r\n {$ELSE}\r\n Result := #1 + SimpleCryptString(StringToUTF8(S)) + #0;\r\n {$ENDIF SUPPORTS_UNICODE}\r\n Exit;\r\n end;\r\n SetLength(Result, Length(S) + StartIndex);\r\n P := Pointer(Result);\r\n if StartIndex = 1 then\r\n P^ := 2 // store '@' leading char information\r\n else\r\n Dec(P);\r\n EndIndex := Length(S) - StartIndex;\r\n for I := 0 to EndIndex do // including null char\r\n begin\r\n if I = EndIndex then\r\n C := 0\r\n else\r\n C := Byte(S[I + 1 + StartIndex]);\r\n case AnsiChar(C) of\r\n #0:\r\n C := 0;\r\n '0'..'9':\r\n Dec(C, Ord('0') - $01);\r\n 'A'..'Z':\r\n Dec(C, Ord('A') - $0B);\r\n 'a'..'z':\r\n Dec(C, Ord('a') - $25);\r\n '_':\r\n C := $3F;\r\n else\r\n C := $3F;\r\n end;\r\n case I and $03 of\r\n 0:\r\n begin\r\n Inc(P);\r\n P^ := C;\r\n end;\r\n 1:\r\n begin\r\n P^ := P^ or (C and $03) shl 6;\r\n Inc(P);\r\n P^ := (C shr 2) and $0F;\r\n end;\r\n 2:\r\n begin\r\n P^ := P^ or Byte(C shl 4);\r\n Inc(P);\r\n P^ := (C shr 4) and $03;\r\n end;\r\n 3:\r\n P^ := P^ or (C shl 2);\r\n end;\r\n end;\r\n SetLength(Result, TJclAddr(P) - TJclAddr(Pointer(Result)) + 1);\r\nend;\r\n\r\nfunction ConvertMapFileToJdbgFile(const MapFileName: TFileName): Boolean;\r\nvar\r\n Dummy1: string;\r\n Dummy2, Dummy3, Dummy4: Integer;\r\nbegin\r\n Result := ConvertMapFileToJdbgFile(MapFileName, Dummy1, Dummy2, Dummy3, Dummy4);\r\nend;\r\n\r\nfunction ConvertMapFileToJdbgFile(const MapFileName: TFileName; out LinkerBugUnit: string;\r\n out LineNumberErrors: Integer): Boolean;\r\nvar\r\n Dummy1, Dummy2: Integer;\r\nbegin\r\n Result := ConvertMapFileToJdbgFile(MapFileName, LinkerBugUnit, LineNumberErrors,\r\n Dummy1, Dummy2);\r\nend;\r\n\r\nfunction ConvertMapFileToJdbgFile(const MapFileName: TFileName; out LinkerBugUnit: string;\r\n out LineNumberErrors, MapFileSize, JdbgFileSize: Integer): Boolean;\r\nvar\r\n JDbgFileName: TFileName;\r\n Generator: TJclBinDebugGenerator;\r\nbegin\r\n JDbgFileName := ChangeFileExt(MapFileName, JclDbgFileExtension);\r\n Generator := TJclBinDebugGenerator.Create(MapFileName, 0);\r\n try\r\n MapFileSize := Generator.Stream.Size;\r\n JdbgFileSize := Generator.DataStream.Size;\r\n Result := (Generator.DataStream.Size > 0) and Generator.CalculateCheckSum;\r\n if Result then\r\n Generator.DataStream.SaveToFile(JDbgFileName);\r\n LinkerBugUnit := Generator.LinkerBugUnitName;\r\n LineNumberErrors := Generator.LineNumberErrors;\r\n finally\r\n Generator.Free;\r\n end;\r\nend;\r\n\r\nfunction InsertDebugDataIntoExecutableFile(const ExecutableFileName, MapFileName: TFileName;\r\n out LinkerBugUnit: string; out MapFileSize, JclDebugDataSize: Integer): Boolean;\r\nvar\r\n Dummy: Integer;\r\nbegin\r\n Result := InsertDebugDataIntoExecutableFile(ExecutableFileName, MapFileName, LinkerBugUnit,\r\n MapFileSize, JclDebugDataSize, Dummy);\r\nend;\r\n\r\nfunction InsertDebugDataIntoExecutableFile(const ExecutableFileName, MapFileName: TFileName;\r\n out LinkerBugUnit: string; out MapFileSize, JclDebugDataSize, LineNumberErrors: Integer): Boolean;\r\nvar\r\n BinDebug: TJclBinDebugGenerator;\r\nbegin\r\n BinDebug := TJclBinDebugGenerator.Create(MapFileName, 0);\r\n try\r\n Result := InsertDebugDataIntoExecutableFile(ExecutableFileName, BinDebug,\r\n LinkerBugUnit, MapFileSize, JclDebugDataSize, LineNumberErrors);\r\n finally\r\n BinDebug.Free;\r\n end;\r\nend;\r\n\r\nfunction InsertDebugDataIntoExecutableFile(const ExecutableFileName: TFileName;\r\n BinDebug: TJclBinDebugGenerator; out LinkerBugUnit: string;\r\n out MapFileSize, JclDebugDataSize: Integer): Boolean;\r\nvar\r\n Dummy: Integer;\r\nbegin\r\n Result := InsertDebugDataIntoExecutableFile(ExecutableFileName, BinDebug, LinkerBugUnit,\r\n MapFileSize, JclDebugDataSize, Dummy);\r\nend;\r\n\r\n// TODO 64 bit version\r\nfunction InsertDebugDataIntoExecutableFile(const ExecutableFileName: TFileName;\r\n BinDebug: TJclBinDebugGenerator; out LinkerBugUnit: string;\r\n out MapFileSize, JclDebugDataSize, LineNumberErrors: Integer): Boolean;\r\nvar\r\n ImageStream: TStream;\r\n NtHeaders32: TImageNtHeaders32;\r\n ImageSectionHeaders: TImageSectionHeaderArray;\r\n NtHeaders32Position, ImageSectionHeadersPosition, JclDebugSectionPosition: Int64;\r\n JclDebugSection: TImageSectionHeader;\r\n LastSection: PImageSectionHeader;\r\n VirtualAlignedSize: DWORD;\r\n I, X, NeedFill: Integer;\r\n\r\n procedure RoundUpToAlignment(var Value: DWORD; Alignment: DWORD);\r\n begin\r\n if (Value mod Alignment) <> 0 then\r\n Value := ((Value div Alignment) + 1) * Alignment;\r\n end;\r\n\r\nbegin\r\n MapFileSize := 0;\r\n JclDebugDataSize := 0;\r\n LineNumberErrors := 0;\r\n LinkerBugUnit := '';\r\n if BinDebug.Stream <> nil then\r\n begin\r\n Result := True;\r\n if BinDebug.LinkerBug then\r\n begin\r\n LinkerBugUnit := BinDebug.LinkerBugUnitName;\r\n LineNumberErrors := BinDebug.LineNumberErrors;\r\n end;\r\n end\r\n else\r\n Result := False;\r\n if not Result then\r\n Exit;\r\n\r\n ImageStream := TFileStream.Create(ExecutableFileName, fmOpenReadWrite or fmShareExclusive);\r\n try\r\n try\r\n if PeMapImgTarget(ImageStream, 0) = taWin32 then\r\n begin\r\n MapFileSize := BinDebug.Stream.Size;\r\n JclDebugDataSize := BinDebug.DataStream.Size;\r\n NtHeaders32Position := PeMapImgNtHeaders32(ImageStream, 0, NtHeaders32);\r\n Assert(NtHeaders32Position <> -1);\r\n ImageSectionHeadersPosition := PeMapImgSections32(ImageStream, NtHeaders32Position, NtHeaders32, ImageSectionHeaders);\r\n Assert(ImageSectionHeadersPosition <> -1);\r\n // Check whether there is not a section with the name already. If so, return True (#0000069)\r\n if PeMapImgFindSection(ImageSectionHeaders, JclDbgDataResName) <> -1 then\r\n begin\r\n Result := True;\r\n Exit;\r\n end;\r\n\r\n JclDebugSectionPosition := ImageSectionHeadersPosition + (SizeOf(ImageSectionHeaders[0]) * Length(ImageSectionHeaders));\r\n LastSection := @ImageSectionHeaders[High(ImageSectionHeaders)];\r\n \r\n // Increase the number of sections\r\n Inc(NtHeaders32.FileHeader.NumberOfSections);\r\n\r\n ResetMemory(JclDebugSection, SizeOf(JclDebugSection));\r\n // JCLDEBUG Virtual Address\r\n JclDebugSection.VirtualAddress := LastSection^.VirtualAddress + LastSection^.Misc.VirtualSize;\r\n RoundUpToAlignment(JclDebugSection.VirtualAddress, NtHeaders32.OptionalHeader.SectionAlignment);\r\n // JCLDEBUG Physical Offset\r\n JclDebugSection.PointerToRawData := LastSection^.PointerToRawData + LastSection^.SizeOfRawData;\r\n RoundUpToAlignment(JclDebugSection.PointerToRawData, NtHeaders32.OptionalHeader.FileAlignment);\r\n // JCLDEBUG Section name\r\n StrPLCopy(PAnsiChar(@JclDebugSection.Name), JclDbgDataResName, IMAGE_SIZEOF_SHORT_NAME);\r\n // JCLDEBUG Characteristics flags\r\n JclDebugSection.Characteristics := IMAGE_SCN_MEM_READ or IMAGE_SCN_CNT_INITIALIZED_DATA;\r\n\r\n // Size of virtual data area\r\n JclDebugSection.Misc.VirtualSize := JclDebugDataSize;\r\n VirtualAlignedSize := JclDebugDataSize;\r\n RoundUpToAlignment(VirtualAlignedSize, NtHeaders32.OptionalHeader.SectionAlignment);\r\n // Update Size of Image\r\n Inc(NtHeaders32.OptionalHeader.SizeOfImage, VirtualAlignedSize);\r\n // Raw data size\r\n JclDebugSection.SizeOfRawData := JclDebugDataSize;\r\n RoundUpToAlignment(JclDebugSection.SizeOfRawData, NtHeaders32.OptionalHeader.FileAlignment);\r\n // Update Initialized data size\r\n Inc(NtHeaders32.OptionalHeader.SizeOfInitializedData, JclDebugSection.SizeOfRawData);\r\n\r\n // write NT Headers 32\r\n if (ImageStream.Seek(NtHeaders32Position, soBeginning) <> NtHeaders32Position) or\r\n (ImageStream.Write(NtHeaders32, SizeOf(NtHeaders32)) <> SizeOf(NtHeaders32)) then\r\n raise EJclPeImageError.CreateRes(@SWriteError);\r\n\r\n // write section header\r\n if (ImageStream.Seek(JclDebugSectionPosition, soBeginning) <> JclDebugSectionPosition) or\r\n (ImageStream.Write(JclDebugSection, SizeOf(JclDebugSection)) <> SizeOf(JclDebugSection)) then\r\n raise EJclPeImageError.CreateRes(@SWriteError);\r\n\r\n // Fill data to alignment\r\n NeedFill := INT_PTR(JclDebugSection.SizeOfRawData) - JclDebugDataSize;\r\n\r\n // Note: Delphi linker seems to generate incorrect (unaligned) size of\r\n // the executable when adding TD32 debug data so the position could be\r\n // behind the size of the file then.\r\n ImageStream.Seek({0 +} JclDebugSection.PointerToRawData, soFromBeginning);\r\n ImageStream.CopyFrom(BinDebug.DataStream, 0);\r\n X := 0;\r\n for I := 1 to NeedFill do\r\n ImageStream.WriteBuffer(X, 1);\r\n end\r\n else\r\n Result := False;\r\n except\r\n Result := False;\r\n end;\r\n finally\r\n ImageStream.Free;\r\n end;\r\nend;\r\n\r\n//=== { TJclBinDebugGenerator } ==============================================\r\n\r\nconstructor TJclBinDebugGenerator.Create(const MapFileName: TFileName; Module: HMODULE);\r\nbegin\r\n inherited Create(MapFileName, Module);\r\n FDataStream := TMemoryStream.Create;\r\n FMapFileName := MapFileName;\r\n if FStream <> nil then\r\n CreateData;\r\nend;\r\n\r\ndestructor TJclBinDebugGenerator.Destroy;\r\nbegin\r\n FreeAndNil(FDataStream);\r\n inherited Destroy;\r\nend;\r\n\r\n{$OVERFLOWCHECKS OFF}\r\n\r\nfunction TJclBinDebugGenerator.CalculateCheckSum: Boolean;\r\nvar\r\n Header: PJclDbgHeader;\r\n P, EndData: PAnsiChar;\r\n CheckSum: Integer;\r\nbegin\r\n Result := DataStream.Size >= SizeOf(TJclDbgHeader);\r\n if Result then\r\n begin\r\n P := DataStream.Memory;\r\n EndData := P + DataStream.Size;\r\n Header := PJclDbgHeader(P);\r\n CheckSum := 0;\r\n Header^.CheckSum := 0;\r\n Header^.CheckSumValid := True;\r\n while P < EndData do\r\n begin\r\n Inc(CheckSum, PInteger(P)^);\r\n Inc(PInteger(P));\r\n end;\r\n Header^.CheckSum := CheckSum;\r\n end;\r\nend;\r\n\r\n{$IFDEF OVERFLOWCHECKS_ON}\r\n{$OVERFLOWCHECKS ON}\r\n{$ENDIF OVERFLOWCHECKS_ON}\r\n\r\nprocedure TJclBinDebugGenerator.CreateData;\r\nvar\r\n {$IFDEF SUPPORTS_GENERICS}\r\n WordList: TDictionary;\r\n {$ELSE}\r\n WordList: TStringList;\r\n {$ENDIF SUPPORTS_GENERICS}\r\n WordStream: TMemoryStream;\r\n LastSegmentID: Word;\r\n LastSegmentStored: Boolean;\r\n\r\n function AddWord(const S: string): Integer;\r\n var\r\n {$IFDEF SUPPORTS_GENERICS}\r\n LowerS: string;\r\n {$ELSE}\r\n N: Integer;\r\n {$ENDIF SUPPORTS_GENERICS}\r\n E: AnsiString;\r\n begin\r\n if S = '' then\r\n begin\r\n Result := 0;\r\n Exit;\r\n end;\r\n {$IFDEF SUPPORTS_GENERICS}\r\n LowerS := AnsiLowerCase(S);\r\n if not WordList.TryGetValue(LowerS, Result) then\r\n begin\r\n Result := WordStream.Position;\r\n E := EncodeNameString(S);\r\n WordStream.WriteBuffer(E[1], Length(E));\r\n WordList.Add(LowerS, Result);\r\n end;\r\n {$ELSE} // for large map files this is very slow\r\n N := WordList.IndexOf(S);\r\n if N = -1 then\r\n begin\r\n Result := WordStream.Position;\r\n E := EncodeNameString(S);\r\n WordStream.WriteBuffer(E[1], Length(E));\r\n WordList.AddObject(S, TObject(Result));\r\n end\r\n else\r\n Result := DWORD(WordList.Objects[N]);\r\n {$ENDIF SUPPORTS_GENERICS}\r\n Inc(Result);\r\n end;\r\n\r\n procedure WriteValue(Value: Integer);\r\n var\r\n L: Integer;\r\n D: DWORD;\r\n P: array [1..5] of Byte;\r\n begin\r\n D := Value and $FFFFFFFF;\r\n L := 0;\r\n while D > $7F do\r\n begin\r\n Inc(L);\r\n P[L] := (D and $7F) or $80;\r\n D := D shr 7;\r\n end;\r\n Inc(L);\r\n P[L] := (D and $7F);\r\n FDataStream.WriteBuffer(P, L);\r\n end;\r\n\r\n procedure WriteValueOfs(Value: Integer; var LastValue: Integer);\r\n begin\r\n WriteValue(Value - LastValue);\r\n LastValue := Value;\r\n end;\r\n\r\n function IsSegmentStored(SegID: Word): Boolean;\r\n var\r\n SegIndex: Integer;\r\n GroupName: string;\r\n begin\r\n if (SegID <> LastSegmentID) then\r\n begin\r\n LastSegmentID := $FFFF;\r\n LastSegmentStored := False;\r\n for SegIndex := Low(FSegmentClasses) to High(FSegmentClasses) do\r\n if FSegmentClasses[SegIndex].Segment = SegID then\r\n begin\r\n LastSegmentID := FSegmentClasses[SegIndex].Segment;\r\n GroupName := MapStringCacheToStr(FSegmentClasses[SegIndex].GroupName);\r\n LastSegmentStored := (GroupName = 'CODE') or (GroupName = 'ICODE');\r\n Break;\r\n end;\r\n end;\r\n Result := LastSegmentStored;\r\n end;\r\n\r\nconst\r\n AlignBytes: array[0..2] of Byte = (0, 0, 0);\r\nvar\r\n FileHeader: TJclDbgHeader;\r\n I, D: Integer;\r\n S: string;\r\n L1, L2, L3: Integer;\r\n FirstWord, SecondWord: Integer;\r\n WordStreamSize, DataStreamSize: Int64;\r\nbegin\r\n LastSegmentID := $FFFF;\r\n WordStream := TMemoryStream.Create;\r\n {$IFDEF SUPPORTS_GENERICS}\r\n WordList := TDictionary.Create(Length(FSourceNames) + Length(FProcNames));\r\n {$ELSE}\r\n WordList := TStringList.Create;\r\n {$ENDIF SUPPORTS_GENERICS}\r\n try\r\n {$IFNDEF SUPPORTS_GENERICS}\r\n WordList.Sorted := True;\r\n WordList.Duplicates := dupError;\r\n {$ENDIF ~SUPPORTS_GENERICS}\r\n WordStream.SetSize((Length(FSourceNames) + Length(FProcNames)) * 40); // take an average of 40 chars per identifier\r\n\r\n FileHeader.Signature := JclDbgDataSignature;\r\n FileHeader.Version := JclDbgHeaderVersion;\r\n FileHeader.CheckSum := 0;\r\n FileHeader.CheckSumValid := False;\r\n FileHeader.ModuleName := AddWord(PathExtractFileNameNoExt(FMapFileName));\r\n FDataStream.WriteBuffer(FileHeader, SizeOf(FileHeader));\r\n\r\n FileHeader.Units := FDataStream.Position;\r\n L1 := 0;\r\n L2 := 0;\r\n for I := 0 to Length(FSegments) - 1 do\r\n if IsSegmentStored(FSegments[I].Segment) then\r\n begin\r\n WriteValueOfs(FSegments[I].StartVA, L1);\r\n WriteValueOfs(AddWord(MapStringCacheToModuleName(FSegments[I].UnitName)), L2);\r\n end;\r\n WriteValue(MaxInt);\r\n\r\n FileHeader.SourceNames := FDataStream.Position;\r\n L1 := 0;\r\n L2 := 0;\r\n for I := 0 to Length(FSourceNames) - 1 do\r\n if IsSegmentStored(FSourceNames[I].Segment) then\r\n begin\r\n WriteValueOfs(FSourceNames[I].VA, L1);\r\n WriteValueOfs(AddWord(MapStringCacheToStr(FSourceNames[I].ProcName)), L2);\r\n end;\r\n WriteValue(MaxInt);\r\n\r\n FileHeader.Symbols := FDataStream.Position;\r\n L1 := 0;\r\n L2 := 0;\r\n L3 := 0;\r\n for I := 0 to Length(FProcNames) - 1 do\r\n if IsSegmentStored(FProcNames[I].Segment) then\r\n begin\r\n WriteValueOfs(FProcNames[I].VA, L1);\r\n // MAP files generated by C++Builder have spaces in their names\r\n S := MapStringCacheToStr(FProcNames[I].ProcName, True);\r\n D := Pos('.', S);\r\n if D = 1 then\r\n begin\r\n FirstWord := 0;\r\n SecondWord := 0;\r\n end\r\n else\r\n if D = 0 then\r\n begin\r\n FirstWord := AddWord(S);\r\n SecondWord := 0;\r\n end\r\n else\r\n begin\r\n FirstWord := AddWord(Copy(S, 1, D - 1));\r\n SecondWord := AddWord(Copy(S, D + 1, Length(S)));\r\n end;\r\n WriteValueOfs(FirstWord, L2);\r\n WriteValueOfs(SecondWord, L3);\r\n end;\r\n WriteValue(MaxInt);\r\n\r\n FileHeader.LineNumbers := FDataStream.Position;\r\n L1 := 0;\r\n L2 := 0;\r\n for I := 0 to Length(FLineNumbers) - 1 do\r\n if IsSegmentStored(FLineNumbers[I].Segment) then\r\n begin\r\n WriteValueOfs(FLineNumbers[I].VA, L1);\r\n WriteValueOfs(FLineNumbers[I].LineNumber, L2);\r\n end;\r\n WriteValue(MaxInt);\r\n\r\n FileHeader.Words := FDataStream.Position;\r\n\r\n // Calculate and allocate the required size in advance instead of reallocating on the fly.\r\n WordStreamSize := WordStream.Position;\r\n DataStreamSize := FDataStream.Position + WordStreamSize;\r\n DataStreamSize := DataStreamSize + (4 - (DataStreamSize and $3));\r\n FDataStream.Size := DataStreamSize; // set capacity\r\n\r\n WordStream.Position := 0;\r\n FDataStream.CopyFrom(WordStream, WordStreamSize);\r\n\r\n // Align to 4 bytes\r\n FDataStream.WriteBuffer(AlignBytes, 4 - (FDataStream.Position and $3));\r\n if FDataStream.Size <> FDataStream.Position then // just in case something changed without adjusting the size calculation\r\n FDataStream.Size := FDataStream.Position;\r\n\r\n // Update the file header\r\n FDataStream.Seek(0, soFromBeginning);\r\n FDataStream.WriteBuffer(FileHeader, SizeOf(FileHeader));\r\n finally\r\n WordStream.Free;\r\n WordList.Free;\r\n end;\r\nend;\r\n\r\n//=== { TJclBinDebugScanner } ================================================\r\n\r\nconstructor TJclBinDebugScanner.Create(AStream: TCustomMemoryStream; CacheData: Boolean);\r\nbegin\r\n inherited Create;\r\n FCacheData := CacheData;\r\n FStream := AStream;\r\n CheckFormat;\r\nend;\r\n\r\nprocedure TJclBinDebugScanner.CacheLineNumbers;\r\nvar\r\n P: Pointer;\r\n Value, LineNumber, C, Ln: Integer;\r\n CurrVA: DWORD;\r\nbegin\r\n if FLineNumbers = nil then\r\n begin\r\n LineNumber := 0;\r\n CurrVA := 0;\r\n C := 0;\r\n Ln := 0;\r\n P := MakePtr(PJclDbgHeader(FStream.Memory)^.LineNumbers);\r\n Value := 0;\r\n while ReadValue(P, Value) do\r\n begin\r\n Inc(CurrVA, Value);\r\n ReadValue(P, Value);\r\n Inc(LineNumber, Value);\r\n if C = Ln then\r\n begin\r\n if Ln < 64 then\r\n Ln := 64\r\n else\r\n Ln := Ln + Ln div 4;\r\n SetLength(FLineNumbers, Ln);\r\n end;\r\n FLineNumbers[C].VA := CurrVA;\r\n FLineNumbers[C].LineNumber := LineNumber;\r\n Inc(C);\r\n end;\r\n SetLength(FLineNumbers, C);\r\n end;\r\nend;\r\n\r\nprocedure TJclBinDebugScanner.CacheProcNames;\r\nvar\r\n P: Pointer;\r\n Value, FirstWord, SecondWord, C, Ln: Integer;\r\n CurrAddr: DWORD;\r\nbegin\r\n if FProcNames = nil then\r\n begin\r\n FirstWord := 0;\r\n SecondWord := 0;\r\n CurrAddr := 0;\r\n C := 0;\r\n Ln := 0;\r\n P := MakePtr(PJclDbgHeader(FStream.Memory)^.Symbols);\r\n Value := 0;\r\n while ReadValue(P, Value) do\r\n begin\r\n Inc(CurrAddr, Value);\r\n ReadValue(P, Value);\r\n Inc(FirstWord, Value);\r\n ReadValue(P, Value);\r\n Inc(SecondWord, Value);\r\n if C = Ln then\r\n begin\r\n if Ln < 64 then\r\n Ln := 64\r\n else\r\n Ln := Ln + Ln div 4;\r\n SetLength(FProcNames, Ln);\r\n end;\r\n FProcNames[C].Addr := CurrAddr;\r\n FProcNames[C].FirstWord := FirstWord;\r\n FProcNames[C].SecondWord := SecondWord;\r\n Inc(C);\r\n end;\r\n SetLength(FProcNames, C);\r\n end;\r\nend;\r\n\r\n{$OVERFLOWCHECKS OFF}\r\n\r\nprocedure TJclBinDebugScanner.CheckFormat;\r\nvar\r\n CheckSum: Integer;\r\n Data, EndData: PAnsiChar;\r\n Header: PJclDbgHeader;\r\nbegin\r\n Data := FStream.Memory;\r\n Header := PJclDbgHeader(Data);\r\n FValidFormat := (Data <> nil) and (FStream.Size > SizeOf(TJclDbgHeader)) and\r\n (FStream.Size mod 4 = 0) and\r\n (Header^.Signature = JclDbgDataSignature) and (Header^.Version = JclDbgHeaderVersion);\r\n if FValidFormat and Header^.CheckSumValid then\r\n begin\r\n CheckSum := -Header^.CheckSum;\r\n EndData := Data + FStream.Size;\r\n while Data < EndData do\r\n begin\r\n Inc(CheckSum, PInteger(Data)^);\r\n Inc(PInteger(Data));\r\n end;\r\n CheckSum := (CheckSum shr 8) or (CheckSum shl 24);\r\n FValidFormat := (CheckSum = Header^.CheckSum);\r\n end;\r\nend;\r\n\r\n{$IFDEF OVERFLOWCHECKS_ON}\r\n{$OVERFLOWCHECKS ON}\r\n{$ENDIF OVERFLOWCHECKS_ON}\r\n\r\nfunction TJclBinDebugScanner.DataToStr(A: Integer): string;\r\nvar\r\n P: PAnsiChar;\r\nbegin\r\n if A = 0 then\r\n Result := ''\r\n else\r\n begin\r\n P := PAnsiChar(TJclAddr(FStream.Memory) + TJclAddr(A) + TJclAddr(PJclDbgHeader(FStream.Memory)^.Words) - 1);\r\n Result := DecodeNameString(P);\r\n end;\r\nend;\r\n\r\nfunction TJclBinDebugScanner.GetModuleName: string;\r\nbegin\r\n Result := DataToStr(PJclDbgHeader(FStream.Memory)^.ModuleName);\r\nend;\r\n\r\nfunction TJclBinDebugScanner.IsModuleNameValid(const Name: TFileName): Boolean;\r\nbegin\r\n Result := AnsiSameText(ModuleName, PathExtractFileNameNoExt(Name));\r\nend;\r\n\r\nfunction TJclBinDebugScanner.LineNumberFromAddr(Addr: DWORD): Integer;\r\nvar\r\n Dummy: Integer;\r\nbegin\r\n Result := LineNumberFromAddr(Addr, Dummy);\r\nend;\r\n\r\nfunction TJclBinDebugScanner.LineNumberFromAddr(Addr: DWORD; out Offset: Integer): Integer;\r\nvar\r\n P: Pointer;\r\n Value, LineNumber: Integer;\r\n CurrVA, ModuleStartVA, ItemVA: DWORD;\r\nbegin\r\n ModuleStartVA := ModuleStartFromAddr(Addr);\r\n LineNumber := 0;\r\n Offset := 0;\r\n if FCacheData then\r\n begin\r\n CacheLineNumbers;\r\n for Value := Length(FLineNumbers) - 1 downto 0 do\r\n if FLineNumbers[Value].VA <= Addr then\r\n begin\r\n if FLineNumbers[Value].VA >= ModuleStartVA then\r\n begin\r\n LineNumber := FLineNumbers[Value].LineNumber;\r\n Offset := Addr - FLineNumbers[Value].VA;\r\n end;\r\n Break;\r\n end;\r\n end\r\n else\r\n begin\r\n P := MakePtr(PJclDbgHeader(FStream.Memory)^.LineNumbers);\r\n CurrVA := 0;\r\n ItemVA := 0;\r\n while ReadValue(P, Value) do\r\n begin\r\n Inc(CurrVA, Value);\r\n if Addr < CurrVA then\r\n begin\r\n if ItemVA < ModuleStartVA then\r\n begin\r\n LineNumber := 0;\r\n Offset := 0;\r\n end;\r\n Break;\r\n end\r\n else\r\n begin\r\n ItemVA := CurrVA;\r\n ReadValue(P, Value);\r\n Inc(LineNumber, Value);\r\n Offset := Addr - CurrVA;\r\n end;\r\n end;\r\n end;\r\n Result := LineNumber;\r\nend;\r\n\r\nfunction TJclBinDebugScanner.MakePtr(A: Integer): Pointer;\r\nbegin\r\n Result := Pointer(TJclAddr(FStream.Memory) + TJclAddr(A));\r\nend;\r\n\r\nfunction TJclBinDebugScanner.ModuleNameFromAddr(Addr: DWORD): string;\r\nvar\r\n Value, Name: Integer;\r\n StartAddr: DWORD;\r\n P: Pointer;\r\nbegin\r\n P := MakePtr(PJclDbgHeader(FStream.Memory)^.Units);\r\n Name := 0;\r\n StartAddr := 0;\r\n Value := 0;\r\n while ReadValue(P, Value) do\r\n begin\r\n Inc(StartAddr, Value);\r\n if Addr < StartAddr then\r\n Break\r\n else\r\n begin\r\n ReadValue(P, Value);\r\n Inc(Name, Value);\r\n end;\r\n end;\r\n Result := DataToStr(Name);\r\nend;\r\n\r\nfunction TJclBinDebugScanner.ModuleStartFromAddr(Addr: DWORD): DWORD;\r\nvar\r\n Value: Integer;\r\n StartAddr, ModuleStartAddr: DWORD;\r\n P: Pointer;\r\nbegin\r\n P := MakePtr(PJclDbgHeader(FStream.Memory)^.Units);\r\n StartAddr := 0;\r\n ModuleStartAddr := DWORD(-1);\r\n Value := 0;\r\n while ReadValue(P, Value) do\r\n begin\r\n Inc(StartAddr, Value);\r\n if Addr < StartAddr then\r\n Break\r\n else\r\n begin\r\n ReadValue(P, Value);\r\n ModuleStartAddr := StartAddr;\r\n end;\r\n end;\r\n Result := ModuleStartAddr;\r\nend;\r\n\r\nfunction TJclBinDebugScanner.ProcNameFromAddr(Addr: DWORD): string;\r\nvar\r\n Dummy: Integer;\r\nbegin\r\n Result := ProcNameFromAddr(Addr, Dummy);\r\nend;\r\n\r\nfunction TJclBinDebugScanner.ProcNameFromAddr(Addr: DWORD; out Offset: Integer): string;\r\nvar\r\n P: Pointer;\r\n Value, FirstWord, SecondWord: Integer;\r\n CurrAddr, ModuleStartAddr, ItemAddr: DWORD;\r\nbegin\r\n ModuleStartAddr := ModuleStartFromAddr(Addr);\r\n FirstWord := 0;\r\n SecondWord := 0;\r\n Offset := 0;\r\n if FCacheData then\r\n begin\r\n CacheProcNames;\r\n for Value := Length(FProcNames) - 1 downto 0 do\r\n if FProcNames[Value].Addr <= Addr then\r\n begin\r\n if FProcNames[Value].Addr >= ModuleStartAddr then\r\n begin\r\n FirstWord := FProcNames[Value].FirstWord;\r\n SecondWord := FProcNames[Value].SecondWord;\r\n Offset := Addr - FProcNames[Value].Addr;\r\n end;\r\n Break;\r\n end;\r\n end\r\n else\r\n begin\r\n P := MakePtr(PJclDbgHeader(FStream.Memory)^.Symbols);\r\n CurrAddr := 0;\r\n ItemAddr := 0;\r\n while ReadValue(P, Value) do\r\n begin\r\n Inc(CurrAddr, Value);\r\n if Addr < CurrAddr then\r\n begin\r\n if ItemAddr < ModuleStartAddr then\r\n begin\r\n FirstWord := 0;\r\n SecondWord := 0;\r\n Offset := 0;\r\n end;\r\n Break;\r\n end\r\n else\r\n begin\r\n ItemAddr := CurrAddr;\r\n ReadValue(P, Value);\r\n Inc(FirstWord, Value);\r\n ReadValue(P, Value);\r\n Inc(SecondWord, Value);\r\n Offset := Addr - CurrAddr;\r\n end;\r\n end;\r\n end;\r\n if FirstWord <> 0 then\r\n begin\r\n Result := DataToStr(FirstWord);\r\n if SecondWord <> 0 then\r\n Result := Result + '.' + DataToStr(SecondWord)\r\n end\r\n else\r\n Result := '';\r\nend;\r\n\r\nfunction TJclBinDebugScanner.ReadValue(var P: Pointer; var Value: Integer): Boolean;\r\nvar\r\n N: Integer;\r\n I: Integer;\r\n B: Byte;\r\nbegin\r\n N := 0;\r\n I := 0;\r\n repeat\r\n B := PByte(P)^;\r\n Inc(PByte(P));\r\n Inc(N, (B and $7F) shl I);\r\n Inc(I, 7);\r\n until B and $80 = 0;\r\n Value := N;\r\n Result := (Value <> MaxInt);\r\nend;\r\n\r\nfunction TJclBinDebugScanner.SourceNameFromAddr(Addr: DWORD): string;\r\nvar\r\n Value, Name: Integer;\r\n StartAddr, ModuleStartAddr, ItemAddr: DWORD;\r\n P: Pointer;\r\n Found: Boolean;\r\nbegin\r\n ModuleStartAddr := ModuleStartFromAddr(Addr);\r\n P := MakePtr(PJclDbgHeader(FStream.Memory)^.SourceNames);\r\n Name := 0;\r\n StartAddr := 0;\r\n ItemAddr := 0;\r\n Found := False;\r\n Value := 0;\r\n while ReadValue(P, Value) do\r\n begin\r\n Inc(StartAddr, Value);\r\n if Addr < StartAddr then\r\n begin\r\n if ItemAddr < ModuleStartAddr then\r\n Name := 0\r\n else\r\n Found := True;\r\n Break;\r\n end\r\n else\r\n begin\r\n ItemAddr := StartAddr;\r\n ReadValue(P, Value);\r\n Inc(Name, Value);\r\n end;\r\n end;\r\n if Found then\r\n Result := DataToStr(Name)\r\n else\r\n Result := '';\r\nend;\r\n\r\n//=== { TJclLocationInfoEx } =================================================\r\n\r\nconstructor TJclLocationInfoEx.Create(AParent: TJclCustomLocationInfoList; Address: Pointer);\r\nvar\r\n Options: TJclLocationInfoListOptions;\r\nbegin\r\n inherited Create;\r\n FAddress := Address;\r\n FParent := AParent;\r\n if Assigned(FParent) then\r\n Options := FParent.Options\r\n else\r\n Options := [];\r\n Fill(Options);\r\nend;\r\n\r\nprocedure TJclLocationInfoEx.AssignTo(Dest: TPersistent);\r\nbegin\r\n if Dest is TJclLocationInfoEx then\r\n begin\r\n TJclLocationInfoEx(Dest).FAddress := FAddress;\r\n TJclLocationInfoEx(Dest).FBinaryFileName := FBinaryFileName;\r\n TJclLocationInfoEx(Dest).FDebugInfo := FDebugInfo;\r\n TJclLocationInfoEx(Dest).FLineNumber := FLineNumber;\r\n TJclLocationInfoEx(Dest).FLineNumberOffsetFromProcedureStart := FLineNumberOffsetFromProcedureStart;\r\n TJclLocationInfoEx(Dest).FModuleName := FModuleName;\r\n TJclLocationInfoEx(Dest).FOffsetFromLineNumber := FOffsetFromLineNumber;\r\n TJclLocationInfoEx(Dest).FOffsetFromProcName := FOffsetFromProcName;\r\n TJclLocationInfoEx(Dest).FProcedureName := FProcedureName;\r\n TJclLocationInfoEx(Dest).FSourceName := FSourceName;\r\n TJclLocationInfoEx(Dest).FSourceUnitName := FSourceUnitName;\r\n TJclLocationInfoEx(Dest).FUnitVersionDateTime := FUnitVersionDateTime;\r\n TJclLocationInfoEx(Dest).FUnitVersionExtra := FUnitVersionExtra;\r\n TJclLocationInfoEx(Dest).FUnitVersionLogPath := FUnitVersionLogPath;\r\n TJclLocationInfoEx(Dest).FUnitVersionRCSfile := FUnitVersionRCSfile;\r\n TJclLocationInfoEx(Dest).FUnitVersionRevision := FUnitVersionRevision;\r\n TJclLocationInfoEx(Dest).FVAddress := FVAddress;\r\n TJclLocationInfoEx(Dest).FValues := FValues;\r\n end\r\n else\r\n inherited AssignTo(Dest);\r\nend;\r\n\r\nprocedure TJclLocationInfoEx.Clear;\r\nbegin\r\n FAddress := nil;\r\n Fill([]);\r\nend;\r\n\r\nprocedure TJclLocationInfoEx.Fill(AOptions: TJclLocationInfoListOptions);\r\nvar\r\n Info, StartProcInfo: TJclLocationInfo;\r\n FixedProcedureName: string;\r\n Module: HMODULE;\r\n {$IFDEF UNITVERSIONING}\r\n I: Integer;\r\n UnitVersion: TUnitVersion;\r\n UnitVersioning: TUnitVersioning;\r\n UnitVersioningModule: TUnitVersioningModule;\r\n {$ENDIF UNITVERSIONING}\r\nbegin\r\n FValues := [];\r\n if liloAutoGetAddressInfo in AOptions then\r\n begin\r\n Module := ModuleFromAddr(FAddress);\r\n FVAddress := Pointer(TJclAddr(FAddress) - Module - ModuleCodeOffset);\r\n FModuleName := ExtractFileName(GetModulePath(Module));\r\n end\r\n else\r\n begin\r\n {$IFDEF UNITVERSIONING}\r\n Module := 0;\r\n {$ENDIF UNITVERSIONING}\r\n FVAddress := nil;\r\n FModuleName := '';\r\n end;\r\n if (liloAutoGetLocationInfo in AOptions) and GetLocationInfo(FAddress, Info) then\r\n begin\r\n FValues := FValues + [lievLocationInfo];\r\n FOffsetFromProcName := Info.OffsetFromProcName;\r\n FSourceUnitName := Info.UnitName;\r\n FixedProcedureName := Info.ProcedureName;\r\n if Pos(Info.UnitName + '.', FixedProcedureName) = 1 then\r\n FixedProcedureName := Copy(FixedProcedureName, Length(Info.UnitName) + 2, Length(FixedProcedureName) - Length(Info.UnitName) - 1);\r\n FProcedureName := FixedProcedureName;\r\n FSourceName := Info.SourceName;\r\n FLineNumber := Info.LineNumber;\r\n if FLineNumber > 0 then\r\n FOffsetFromLineNumber := Info.OffsetFromLineNumber\r\n else\r\n FOffsetFromLineNumber := 0;\r\n if GetLocationInfo(Pointer(TJclAddr(Info.Address) -\r\n Cardinal(Info.OffsetFromProcName)), StartProcInfo) and (StartProcInfo.LineNumber > 0) then\r\n begin\r\n FLineNumberOffsetFromProcedureStart := Info.LineNumber - StartProcInfo.LineNumber;\r\n FValues := FValues + [lievProcedureStartLocationInfo];\r\n end\r\n else\r\n FLineNumberOffsetFromProcedureStart := 0;\r\n FDebugInfo := Info.DebugInfo;\r\n FBinaryFileName := Info.BinaryFileName;\r\n end\r\n else\r\n begin\r\n FOffsetFromProcName := 0;\r\n FSourceUnitName := '';\r\n FProcedureName := '';\r\n FSourceName := '';\r\n FLineNumber := 0;\r\n FOffsetFromLineNumber := 0;\r\n FLineNumberOffsetFromProcedureStart := 0;\r\n FDebugInfo := nil;\r\n FBinaryFileName := '';\r\n end;\r\n FUnitVersionDateTime := 0;\r\n FUnitVersionLogPath := '';\r\n FUnitVersionRCSfile := '';\r\n FUnitVersionRevision := '';\r\n {$IFDEF UNITVERSIONING}\r\n if (liloAutoGetUnitVersionInfo in AOptions) and (FSourceName <> '') then\r\n begin\r\n if not (liloAutoGetAddressInfo in AOptions) then\r\n Module := ModuleFromAddr(FAddress);\r\n UnitVersioning := GetUnitVersioning;\r\n for I := 0 to UnitVersioning.ModuleCount - 1 do\r\n begin\r\n UnitVersioningModule := UnitVersioning.Modules[I];\r\n if UnitVersioningModule.Instance = Module then\r\n begin\r\n UnitVersion := UnitVersioningModule.FindUnit(FSourceName);\r\n if Assigned(UnitVersion) then\r\n begin\r\n FUnitVersionDateTime := UnitVersion.DateTime;\r\n FUnitVersionLogPath := UnitVersion.LogPath;\r\n FUnitVersionRCSfile := UnitVersion.RCSfile;\r\n FUnitVersionRevision := UnitVersion.Revision;\r\n FValues := FValues + [lievUnitVersionInfo];\r\n Break;\r\n end;\r\n end;\r\n if lievUnitVersionInfo in FValues then\r\n Break;\r\n end;\r\n end;\r\n {$ENDIF UNITVERSIONING}\r\nend;\r\n\r\n{ TODO -oUSc : Include... better as function than property? }\r\nfunction TJclLocationInfoEx.GetAsString: string;\r\nconst\r\n IncludeStartProcLineOffset = True;\r\n IncludeAddressOffset = True;\r\n IncludeModuleName = True;\r\nvar\r\n IncludeVAddress: Boolean;\r\n OffsetStr, StartProcOffsetStr: string;\r\nbegin\r\n IncludeVAddress := True;\r\n OffsetStr := '';\r\n if lievLocationInfo in FValues then\r\n begin\r\n if LineNumber > 0 then\r\n begin\r\n if IncludeStartProcLineOffset and (lievProcedureStartLocationInfo in FValues) then\r\n StartProcOffsetStr := Format(' + %d', [LineNumberOffsetFromProcedureStart])\r\n else\r\n StartProcOffsetStr := '';\r\n if IncludeAddressOffset then\r\n begin\r\n if OffsetFromLineNumber >= 0 then\r\n OffsetStr := Format(' + $%x', [OffsetFromLineNumber])\r\n else\r\n OffsetStr := Format(' - $%x', [-OffsetFromLineNumber])\r\n end;\r\n Result := Format('[%p] %s.%s (Line %u, \"%s\"%s)%s', [Address, SourceUnitName, ProcedureName, LineNumber,\r\n SourceName, StartProcOffsetStr, OffsetStr]);\r\n end\r\n else\r\n begin\r\n if IncludeAddressOffset then\r\n OffsetStr := Format(' + $%x', [OffsetFromProcName]);\r\n if SourceUnitName <> '' then\r\n Result := Format('[%p] %s.%s%s', [Address, SourceUnitName, ProcedureName, OffsetStr])\r\n else\r\n Result := Format('[%p] %s%s', [Address, ProcedureName, OffsetStr]);\r\n end;\r\n end\r\n else\r\n begin\r\n Result := Format('[%p]', [Address]);\r\n IncludeVAddress := True;\r\n end;\r\n if IncludeVAddress or IncludeModuleName then\r\n begin\r\n if IncludeVAddress then\r\n begin\r\n OffsetStr := Format('(%p) ', [VAddress]);\r\n Result := OffsetStr + Result;\r\n end;\r\n if IncludeModuleName then\r\n Insert(Format('{%-12s}', [ModuleName]), Result, 11 {$IFDEF CPUX64}+ 8{$ENDIF});\r\n end;\r\nend;\r\n\r\n//=== { TJclCustomLocationInfoList } =========================================\r\n\r\nconstructor TJclCustomLocationInfoList.Create;\r\nbegin\r\n inherited Create;\r\n FItemClass := TJclLocationInfoEx;\r\n FItems := TObjectList.Create;\r\n FOptions := [];\r\nend;\r\n\r\ndestructor TJclCustomLocationInfoList.Destroy;\r\nbegin\r\n FItems.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJclCustomLocationInfoList.AddStackInfoList(AStackInfoList: TObject);\r\nvar\r\n I: Integer;\r\nbegin\r\n TJclStackInfoList(AStackInfoList).ForceStackTracing;\r\n for I := 0 to TJclStackInfoList(AStackInfoList).Count - 1 do\r\n InternalAdd(TJclStackInfoList(AStackInfoList)[I].CallerAddr);\r\nend;\r\n\r\nprocedure TJclCustomLocationInfoList.AssignTo(Dest: TPersistent);\r\nvar\r\n I: Integer;\r\nbegin\r\n if Dest is TJclCustomLocationInfoList then\r\n begin\r\n TJclCustomLocationInfoList(Dest).Clear;\r\n for I := 0 to Count - 1 do\r\n TJclCustomLocationInfoList(Dest).InternalAdd(nil).Assign(TJclLocationInfoEx(FItems[I]));\r\n end\r\n else\r\n inherited AssignTo(Dest);\r\nend;\r\n\r\nprocedure TJclCustomLocationInfoList.Clear;\r\nbegin\r\n FItems.Clear;\r\nend;\r\n\r\nfunction TJclCustomLocationInfoList.GetAsString: string;\r\nvar\r\n I: Integer;\r\n Strings: TStringList;\r\nbegin\r\n Strings := TStringList.Create;\r\n try\r\n for I := 0 to Count - 1 do\r\n Strings.Add(TJclLocationInfoEx(FItems[I]).AsString);\r\n Result := Strings.Text;\r\n finally\r\n Strings.Free;\r\n end;\r\nend;\r\n\r\nfunction TJclCustomLocationInfoList.GetCount: Integer;\r\nbegin\r\n Result := FItems.Count;\r\nend;\r\n\r\nfunction TJclCustomLocationInfoList.InternalAdd(Addr: Pointer): TJclLocationInfoEx;\r\nbegin\r\n FItems.Add(FItemClass.Create(Self, Addr));\r\n Result := TJclLocationInfoEx(FItems.Last);\r\nend;\r\n\r\n//=== { TJclLocationInfoList } ===============================================\r\n\r\nfunction TJclLocationInfoList.Add(Addr: Pointer): TJclLocationInfoEx;\r\nbegin\r\n Result := InternalAdd(Addr);\r\nend;\r\n\r\nconstructor TJclLocationInfoList.Create;\r\nbegin\r\n inherited Create;\r\n FOptions := [liloAutoGetAddressInfo, liloAutoGetLocationInfo, liloAutoGetUnitVersionInfo];\r\nend;\r\n\r\nfunction TJclLocationInfoList.GetItems(AIndex: Integer): TJclLocationInfoEx;\r\nbegin\r\n Result := TJclLocationInfoEx(FItems[AIndex]);\r\nend;\r\n\r\n//=== { TJclDebugInfoSource } ================================================\r\n\r\nconstructor TJclDebugInfoSource.Create(AModule: HMODULE);\r\nbegin\r\n FModule := AModule;\r\nend;\r\n\r\nfunction TJclDebugInfoSource.GetFileName: TFileName;\r\nbegin\r\n Result := GetModulePath(FModule);\r\nend;\r\n\r\nfunction TJclDebugInfoSource.VAFromAddr(const Addr: Pointer): DWORD;\r\nbegin\r\n Result := DWORD(TJclAddr(Addr) - FModule - ModuleCodeOffset);\r\nend;\r\n\r\n//=== { TJclDebugInfoList } ==================================================\r\n\r\nvar\r\n DebugInfoList: TJclDebugInfoList = nil;\r\n InfoSourceClassList: TList = nil;\r\n DebugInfoCritSect: TJclCriticalSection;\r\n\r\nprocedure NeedDebugInfoList;\r\nbegin\r\n if DebugInfoList = nil then\r\n DebugInfoList := TJclDebugInfoList.Create;\r\nend;\r\n\r\nfunction TJclDebugInfoList.CreateDebugInfo(const Module: HMODULE): TJclDebugInfoSource;\r\nvar\r\n I: Integer;\r\nbegin\r\n NeedInfoSourceClassList;\r\n\r\n Result := nil;\r\n for I := 0 to InfoSourceClassList.Count - 1 do\r\n begin\r\n Result := TJclDebugInfoSourceClass(InfoSourceClassList.Items[I]).Create(Module);\r\n try\r\n if Result.InitializeSource then\r\n Break\r\n else\r\n FreeAndNil(Result);\r\n except\r\n Result.Free;\r\n raise;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJclDebugInfoList.GetItemFromModule(const Module: HMODULE): TJclDebugInfoSource;\r\nvar\r\n I: Integer;\r\n TempItem: TJclDebugInfoSource;\r\nbegin\r\n Result := nil;\r\n if Module = 0 then\r\n Exit;\r\n for I := 0 to Count - 1 do\r\n begin\r\n TempItem := Items[I];\r\n if TempItem.Module = Module then\r\n begin\r\n Result := TempItem;\r\n Break;\r\n end;\r\n end;\r\n if Result = nil then\r\n begin\r\n Result := CreateDebugInfo(Module);\r\n if Result <> nil then\r\n Add(Result);\r\n end;\r\nend;\r\n\r\nfunction TJclDebugInfoList.GetItems(Index: Integer): TJclDebugInfoSource;\r\nbegin\r\n Result := TJclDebugInfoSource(Get(Index));\r\nend;\r\n\r\nfunction TJclDebugInfoList.GetLocationInfo(const Addr: Pointer; out Info: TJclLocationInfo): Boolean;\r\nvar\r\n Item: TJclDebugInfoSource;\r\nbegin\r\n ResetMemory(Info, SizeOf(Info));\r\n Item := ItemFromModule[ModuleFromAddr(Addr)];\r\n if Item <> nil then\r\n Result := Item.GetLocationInfo(Addr, Info)\r\n else\r\n Result := False;\r\nend;\r\n\r\nclass procedure TJclDebugInfoList.NeedInfoSourceClassList;\r\nbegin\r\n if not Assigned(InfoSourceClassList) then\r\n begin\r\n InfoSourceClassList := TList.Create;\r\n {$IFNDEF DEBUG_NO_BINARY}\r\n InfoSourceClassList.Add(Pointer(TJclDebugInfoBinary));\r\n {$ENDIF !DEBUG_NO_BINARY}\r\n {$IFNDEF DEBUG_NO_TD32}\r\n InfoSourceClassList.Add(Pointer(TJclDebugInfoTD32));\r\n {$ENDIF !DEBUG_NO_TD32}\r\n {$IFNDEF DEBUG_NO_MAP}\r\n InfoSourceClassList.Add(Pointer(TJclDebugInfoMap));\r\n {$ENDIF !DEBUG_NO_MAP}\r\n {$IFNDEF DEBUG_NO_SYMBOLS}\r\n InfoSourceClassList.Add(Pointer(TJclDebugInfoSymbols));\r\n {$ENDIF !DEBUG_NO_SYMBOLS}\r\n {$IFNDEF DEBUG_NO_EXPORTS}\r\n InfoSourceClassList.Add(Pointer(TJclDebugInfoExports));\r\n {$ENDIF !DEBUG_NO_EXPORTS}\r\n end;\r\nend;\r\n\r\nclass procedure TJclDebugInfoList.RegisterDebugInfoSource(\r\n const InfoSourceClass: TJclDebugInfoSourceClass);\r\nbegin\r\n NeedInfoSourceClassList;\r\n\r\n InfoSourceClassList.Add(Pointer(InfoSourceClass));\r\nend;\r\n\r\nclass procedure TJclDebugInfoList.RegisterDebugInfoSourceFirst(\r\n const InfoSourceClass: TJclDebugInfoSourceClass);\r\nbegin\r\n NeedInfoSourceClassList;\r\n\r\n InfoSourceClassList.Insert(0, Pointer(InfoSourceClass));\r\nend;\r\n\r\nclass procedure TJclDebugInfoList.UnRegisterDebugInfoSource(\r\n const InfoSourceClass: TJclDebugInfoSourceClass);\r\nbegin\r\n if Assigned(InfoSourceClassList) then\r\n InfoSourceClassList.Remove(Pointer(InfoSourceClass));\r\nend;\r\n\r\n//=== { TJclDebugInfoMap } ===================================================\r\n\r\ndestructor TJclDebugInfoMap.Destroy;\r\nbegin\r\n FreeAndNil(FScanner);\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJclDebugInfoMap.GetLocationInfo(const Addr: Pointer; out Info: TJclLocationInfo): Boolean;\r\nvar\r\n VA: DWORD;\r\nbegin\r\n VA := VAFromAddr(Addr);\r\n with FScanner do\r\n begin\r\n Info.UnitName := ModuleNameFromAddr(VA);\r\n Result := Info.UnitName <> '';\r\n if Result then\r\n begin\r\n Info.Address := Addr;\r\n Info.ProcedureName := ProcNameFromAddr(VA, Info.OffsetFromProcName);\r\n Info.LineNumber := LineNumberFromAddr(VA, Info.OffsetFromLineNumber);\r\n Info.SourceName := SourceNameFromAddr(VA);\r\n Info.DebugInfo := Self;\r\n Info.BinaryFileName := FileName;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJclDebugInfoMap.InitializeSource: Boolean;\r\nvar\r\n MapFileName: TFileName;\r\nbegin\r\n MapFileName := ChangeFileExt(FileName, JclMapFileExtension);\r\n Result := FileExists(MapFileName);\r\n if Result then\r\n FScanner := TJclMapScanner.Create(MapFileName, Module);\r\nend;\r\n\r\n//=== { TJclDebugInfoBinary } ================================================\r\n\r\ndestructor TJclDebugInfoBinary.Destroy;\r\nbegin\r\n FreeAndNil(FScanner);\r\n FreeAndNil(FStream);\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJclDebugInfoBinary.GetLocationInfo(const Addr: Pointer; out Info: TJclLocationInfo): Boolean;\r\nvar\r\n VA: DWORD;\r\nbegin\r\n VA := VAFromAddr(Addr);\r\n with FScanner do\r\n begin\r\n Info.UnitName := ModuleNameFromAddr(VA);\r\n Result := Info.UnitName <> '';\r\n if Result then\r\n begin\r\n Info.Address := Addr;\r\n Info.ProcedureName := ProcNameFromAddr(VA, Info.OffsetFromProcName);\r\n Info.LineNumber := LineNumberFromAddr(VA, Info.OffsetFromLineNumber);\r\n Info.SourceName := SourceNameFromAddr(VA);\r\n Info.DebugInfo := Self;\r\n Info.BinaryFileName := FileName;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJclDebugInfoBinary.InitializeSource: Boolean;\r\nvar\r\n JdbgFileName: TFileName;\r\n VerifyFileName: Boolean;\r\nbegin\r\n VerifyFileName := False;\r\n Result := (PeMapImgFindSectionFromModule(Pointer(Module), JclDbgDataResName) <> nil);\r\n if Result then\r\n FStream := TJclPeSectionStream.Create(Module, JclDbgDataResName)\r\n else\r\n begin\r\n JdbgFileName := ChangeFileExt(FileName, JclDbgFileExtension);\r\n Result := FileExists(JdbgFileName);\r\n if Result then\r\n begin\r\n FStream := TJclFileMappingStream.Create(JdbgFileName, fmOpenRead or fmShareDenyWrite);\r\n VerifyFileName := True;\r\n end;\r\n end;\r\n if Result then\r\n begin\r\n FScanner := TJclBinDebugScanner.Create(FStream, True);\r\n Result := FScanner.ValidFormat and\r\n (not VerifyFileName or FScanner.IsModuleNameValid(FileName));\r\n end;\r\nend;\r\n\r\n//=== { TJclDebugInfoExports } ===============================================\r\n\r\ndestructor TJclDebugInfoExports.Destroy;\r\nbegin\r\n FreeAndNil(FImage);\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJclDebugInfoExports.IsAddressInThisExportedFunction(Addr: PByteArray; FunctionStartAddr: TJclAddr): Boolean;\r\nbegin\r\n Dec(TJclAddr(Addr), 6);\r\n Result := False;\r\n\r\n while TJclAddr(Addr) > FunctionStartAddr do\r\n begin\r\n if IsBadReadPtr(Addr, 6) then\r\n Exit;\r\n\r\n if (Addr[0] = $C2) and // ret $xxxx\r\n (((Addr[3] = $90) and (Addr[4] = $90) and (Addr[5] = $90)) or // nop\r\n ((Addr[3] = $CC) and (Addr[4] = $CC) and (Addr[5] = $CC))) then // int 3\r\n Exit;\r\n\r\n if (Addr[0] = $C3) and // ret\r\n (((Addr[1] = $90) and (Addr[2] = $90) and (Addr[3] = $90)) or // nop\r\n ((Addr[1] = $CC) and (Addr[2] = $CC) and (Addr[3] = $CC))) then // int 3\r\n Exit;\r\n\r\n if (Addr[0] = $E9) and // jmp rel-far\r\n (((Addr[5] = $90) and (Addr[6] = $90) and (Addr[7] = $90)) or // nop\r\n ((Addr[5] = $CC) and (Addr[6] = $CC) and (Addr[7] = $CC))) then // int 3\r\n Exit;\r\n\r\n if (Addr[0] = $EB) and // jmp rel-near\r\n (((Addr[2] = $90) and (Addr[3] = $90) and (Addr[4] = $90)) or // nop\r\n ((Addr[2] = $CC) and (Addr[3] = $CC) and (Addr[4] = $CC))) then // int 3\r\n Exit;\r\n\r\n Dec(TJclAddr(Addr));\r\n end;\r\n Result := True;\r\nend;\r\n\r\nfunction TJclDebugInfoExports.GetLocationInfo(const Addr: Pointer; out Info: TJclLocationInfo): Boolean;\r\nvar\r\n I, BasePos: Integer;\r\n VA: DWORD;\r\n Desc: TJclBorUmDescription;\r\n Unmangled: string;\r\n RawName: Boolean;\r\nbegin\r\n Result := False;\r\n VA := DWORD(TJclAddr(Addr) - FModule);\r\n {$IFDEF BORLAND}\r\n RawName := not FImage.IsPackage;\r\n {$ENDIF BORLAND}\r\n {$IFDEF FPC}\r\n RawName := True;\r\n {$ENDIF FPC}\r\n Info.OffsetFromProcName := 0;\r\n Info.OffsetFromLineNumber := 0;\r\n Info.BinaryFileName := FileName;\r\n with FImage.ExportList do\r\n begin\r\n SortList(esAddress, False);\r\n for I := Count - 1 downto 0 do\r\n if Items[I].Address <= VA then\r\n begin\r\n if RawName then\r\n begin\r\n Info.ProcedureName := Items[I].Name;\r\n Info.OffsetFromProcName := VA - Items[I].Address;\r\n Result := True;\r\n end\r\n else\r\n begin\r\n case PeBorUnmangleName(Items[I].Name, Unmangled, Desc, BasePos) of\r\n urOk:\r\n begin\r\n Info.UnitName := Copy(Unmangled, 1, BasePos - 2);\r\n if not (Desc.Kind in [skRTTI, skVTable]) then\r\n begin\r\n Info.ProcedureName := Copy(Unmangled, BasePos, Length(Unmangled));\r\n if smLinkProc in Desc.Modifiers then\r\n Info.ProcedureName := '@' + Info.ProcedureName;\r\n Info.OffsetFromProcName := VA - Items[I].Address;\r\n end;\r\n Result := True;\r\n end;\r\n urNotMangled:\r\n begin\r\n Info.ProcedureName := Items[I].Name;\r\n Info.OffsetFromProcName := VA - Items[I].Address;\r\n Result := True;\r\n end;\r\n end;\r\n end;\r\n if Result then\r\n begin\r\n Info.Address := Addr;\r\n Info.DebugInfo := Self;\r\n\r\n { Check if we have a valid address in an exported function. }\r\n if not IsAddressInThisExportedFunction(Addr, FModule + Items[I].Address) then\r\n begin\r\n //Info.UnitName := '[' + AnsiLowerCase(ExtractFileName(GetModulePath(FModule))) + ']'\r\n Info.ProcedureName := Format(LoadResString(@RsUnknownFunctionAt), [Info.ProcedureName]);\r\n end;\r\n\r\n Break;\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJclDebugInfoExports.InitializeSource: Boolean;\r\nbegin\r\n {$IFDEF BORLAND}\r\n FImage := TJclPeBorImage.Create(True);\r\n {$ENDIF BORLAND}\r\n {$IFDEF FPC}\r\n FImage := TJclPeImage.Create(True);\r\n {$ENDIF FPC}\r\n FImage.AttachLoadedModule(FModule);\r\n Result := FImage.StatusOK and (FImage.ExportList.Count > 0);\r\nend;\r\n\r\n{$IFDEF BORLAND}\r\n\r\n//=== { TJclDebugInfoTD32 } ==================================================\r\n\r\ndestructor TJclDebugInfoTD32.Destroy;\r\nbegin\r\n FreeAndNil(FImage);\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJclDebugInfoTD32.GetLocationInfo(const Addr: Pointer; out Info: TJclLocationInfo): Boolean;\r\nvar\r\n VA: DWORD;\r\nbegin\r\n VA := VAFromAddr(Addr);\r\n Info.UnitName := FImage.TD32Scanner.ModuleNameFromAddr(VA);\r\n Result := Info.UnitName <> '';\r\n if Result then\r\n with Info do\r\n begin\r\n Address := Addr;\r\n ProcedureName := FImage.TD32Scanner.ProcNameFromAddr(VA, OffsetFromProcName);\r\n LineNumber := FImage.TD32Scanner.LineNumberFromAddr(VA, OffsetFromLineNumber);\r\n SourceName := FImage.TD32Scanner.SourceNameFromAddr(VA);\r\n DebugInfo := Self;\r\n BinaryFileName := FileName;\r\n end;\r\nend;\r\n\r\nfunction TJclDebugInfoTD32.InitializeSource: Boolean;\r\nbegin\r\n FImage := TJclPeBorTD32Image.Create(True);\r\n try\r\n FImage.AttachLoadedModule(Module);\r\n Result := FImage.IsTD32DebugPresent;\r\n except\r\n Result := False;\r\n end;\r\nend;\r\n\r\n{$ENDIF BORLAND}\r\n\r\n//=== { TJclDebugInfoSymbols } ===============================================\r\n\r\ntype\r\n TSymInitializeAFunc = function (hProcess: THandle; UserSearchPath: LPSTR;\r\n fInvadeProcess: Bool): Bool; stdcall;\r\n TSymInitializeWFunc = function (hProcess: THandle; UserSearchPath: LPWSTR;\r\n fInvadeProcess: Bool): Bool; stdcall;\r\n TSymGetOptionsFunc = function: DWORD; stdcall;\r\n TSymSetOptionsFunc = function (SymOptions: DWORD): DWORD; stdcall;\r\n TSymCleanupFunc = function (hProcess: THandle): Bool; stdcall;\r\n {$IFDEF CPU32}\r\n TSymGetSymFromAddrAFunc = function (hProcess: THandle; dwAddr: DWORD;\r\n pdwDisplacement: PDWORD; var Symbol: JclWin32.TImagehlpSymbolA): Bool; stdcall;\r\n TSymGetSymFromAddrWFunc = function (hProcess: THandle; dwAddr: DWORD;\r\n pdwDisplacement: PDWORD; var Symbol: JclWin32.TImagehlpSymbolW): Bool; stdcall;\r\n TSymGetModuleInfoAFunc = function (hProcess: THandle; dwAddr: DWORD;\r\n var ModuleInfo: JclWin32.TImagehlpModuleA): Bool; stdcall;\r\n TSymGetModuleInfoWFunc = function (hProcess: THandle; dwAddr: DWORD;\r\n var ModuleInfo: JclWin32.TImagehlpModuleW): Bool; stdcall;\r\n TSymLoadModuleFunc = function (hProcess: THandle; hFile: THandle; ImageName,\r\n ModuleName: LPSTR; BaseOfDll: DWORD; SizeOfDll: DWORD): DWORD; stdcall;\r\n TSymGetLineFromAddrAFunc = function (hProcess: THandle; dwAddr: DWORD;\r\n pdwDisplacement: PDWORD; var Line: JclWin32.TImageHlpLineA): Bool; stdcall;\r\n TSymGetLineFromAddrWFunc = function (hProcess: THandle; dwAddr: DWORD;\r\n pdwDisplacement: PDWORD; var Line: JclWin32.TImageHlpLineW): Bool; stdcall;\r\n {$ENDIF CPU32}\r\n {$IFDEF CPU64}\r\n TSymGetSymFromAddrAFunc = function (hProcess: THandle; dwAddr: DWORD64;\r\n pdwDisplacement: PDWORD64; var Symbol: JclWin32.TImagehlpSymbolA64): Bool; stdcall;\r\n TSymGetSymFromAddrWFunc = function (hProcess: THandle; dwAddr: DWORD64;\r\n pdwDisplacement: PDWORD64; var Symbol: JclWin32.TImagehlpSymbolW64): Bool; stdcall;\r\n TSymGetModuleInfoAFunc = function (hProcess: THandle; dwAddr: DWORD64;\r\n var ModuleInfo: JclWin32.TImagehlpModuleA64): Bool; stdcall;\r\n TSymGetModuleInfoWFunc = function (hProcess: THandle; dwAddr: DWORD64;\r\n var ModuleInfo: JclWin32.TImagehlpModuleW64): Bool; stdcall;\r\n TSymLoadModuleFunc = function (hProcess: THandle; hFile: THandle; ImageName,\r\n ModuleName: LPSTR; BaseOfDll: DWORD64; SizeOfDll: DWORD): DWORD; stdcall;\r\n TSymGetLineFromAddrAFunc = function (hProcess: THandle; dwAddr: DWORD64;\r\n pdwDisplacement: PDWORD; var Line: JclWin32.TImageHlpLineA64): Bool; stdcall;\r\n TSymGetLineFromAddrWFunc = function (hProcess: THandle; dwAddr: DWORD64;\r\n pdwDisplacement: PDWORD; var Line: JclWin32.TImageHlpLineW64): Bool; stdcall;\r\n {$ENDIF CPU64}\r\n\r\nvar\r\n DebugSymbolsInitialized: Boolean = False;\r\n DebugSymbolsLoadFailed: Boolean = False;\r\n ImageHlpDllHandle: THandle = 0;\r\n SymInitializeAFunc: TSymInitializeAFunc = nil;\r\n SymInitializeWFunc: TSymInitializeWFunc = nil;\r\n SymGetOptionsFunc: TSymGetOptionsFunc = nil;\r\n SymSetOptionsFunc: TSymSetOptionsFunc = nil;\r\n SymCleanupFunc: TSymCleanupFunc = nil;\r\n SymGetSymFromAddrAFunc: TSymGetSymFromAddrAFunc = nil;\r\n SymGetSymFromAddrWFunc: TSymGetSymFromAddrWFunc = nil;\r\n SymGetModuleInfoAFunc: TSymGetModuleInfoAFunc = nil;\r\n SymGetModuleInfoWFunc: TSymGetModuleInfoWFunc = nil;\r\n SymLoadModuleFunc: TSymLoadModuleFunc = nil;\r\n SymGetLineFromAddrAFunc: TSymGetLineFromAddrAFunc = nil;\r\n SymGetLineFromAddrWFunc: TSymGetLineFromAddrWFunc = nil;\r\n\r\nconst\r\n ImageHlpDllName = 'imagehlp.dll'; // do not localize\r\n SymInitializeAFuncName = 'SymInitialize'; // do not localize\r\n SymInitializeWFuncName = 'SymInitializeW'; // do not localize\r\n SymGetOptionsFuncName = 'SymGetOptions'; // do not localize\r\n SymSetOptionsFuncName = 'SymSetOptions'; // do not localize\r\n SymCleanupFuncName = 'SymCleanup'; // do not localize\r\n {$IFDEF CPU32}\r\n SymGetSymFromAddrAFuncName = 'SymGetSymFromAddr'; // do not localize\r\n SymGetSymFromAddrWFuncName = 'SymGetSymFromAddrW'; // do not localize\r\n SymGetModuleInfoAFuncName = 'SymGetModuleInfo'; // do not localize\r\n SymGetModuleInfoWFuncName = 'SymGetModuleInfoW'; // do not localize\r\n SymLoadModuleFuncName = 'SymLoadModule'; // do not localize\r\n SymGetLineFromAddrAFuncName = 'SymGetLineFromAddr'; // do not localize\r\n SymGetLineFromAddrWFuncName = 'SymGetLineFromAddrW'; // do not localize\r\n {$ENDIF CPU32}\r\n {$IFDEF CPU64}\r\n SymGetSymFromAddrAFuncName = 'SymGetSymFromAddr64'; // do not localize\r\n SymGetSymFromAddrWFuncName = 'SymGetSymFromAddrW64'; // do not localize\r\n SymGetModuleInfoAFuncName = 'SymGetModuleInfo64'; // do not localize\r\n SymGetModuleInfoWFuncName = 'SymGetModuleInfoW64'; // do not localize\r\n SymLoadModuleFuncName = 'SymLoadModule64'; // do not localize\r\n SymGetLineFromAddrAFuncName = 'SymGetLineFromAddr64'; // do not localize\r\n SymGetLineFromAddrWFuncName = 'SymGetLineFromAddrW64'; // do not localize\r\n {$ENDIF CPU64}\r\n\r\nfunction StrRemoveEmptyPaths(const Paths: string): string;\r\nvar\r\n List: TStrings;\r\n I: Integer;\r\nbegin\r\n List := TStringList.Create;\r\n try\r\n StrToStrings(Paths, DirSeparator, List, False);\r\n for I := 0 to List.Count - 1 do\r\n if Trim(List[I]) = '' then\r\n List[I] := '';\r\n Result := StringsToStr(List, DirSeparator, False);\r\n finally\r\n List.Free;\r\n end;\r\nend;\r\n\r\nclass function TJclDebugInfoSymbols.InitializeDebugSymbols: Boolean;\r\nvar\r\n EnvironmentVarValue, SearchPath: string;\r\n SymOptions: Cardinal;\r\n ProcessHandle: THandle;\r\nbegin\r\n Result := DebugSymbolsInitialized;\r\n if not DebugSymbolsLoadFailed then\r\n begin\r\n Result := LoadDebugFunctions;\r\n DebugSymbolsLoadFailed := not Result;\r\n\r\n if Result then\r\n begin\r\n if JclDebugInfoSymbolPaths <> '' then\r\n begin\r\n SearchPath := StrEnsureSuffix(DirSeparator, JclDebugInfoSymbolPaths);\r\n SearchPath := StrEnsureNoSuffix(DirSeparator, SearchPath + GetCurrentFolder);\r\n\r\n if GetEnvironmentVar(EnvironmentVarNtSymbolPath, EnvironmentVarValue) and (EnvironmentVarValue <> '') then\r\n SearchPath := StrEnsureNoSuffix(DirSeparator, StrEnsureSuffix(DirSeparator, EnvironmentVarValue) + SearchPath);\r\n if GetEnvironmentVar(EnvironmentVarAlternateNtSymbolPath, EnvironmentVarValue) and (EnvironmentVarValue <> '') then\r\n SearchPath := StrEnsureNoSuffix(DirSeparator, StrEnsureSuffix(DirSeparator, EnvironmentVarValue) + SearchPath);\r\n\r\n // DbgHelp.dll crashes when an empty path is specified.\r\n // This also means that the SearchPath must not end with a DirSeparator. }\r\n SearchPath := StrRemoveEmptyPaths(SearchPath);\r\n end\r\n else\r\n // Fix crash SymLoadModuleFunc on WinXP SP3 when SearchPath=''\r\n SearchPath := GetCurrentFolder;\r\n\r\n if IsWinNT then\r\n // in Windows NT, first argument is a process handle\r\n ProcessHandle := GetCurrentProcess\r\n else\r\n // in Windows 95, 98, ME first argument is a process identifier\r\n ProcessHandle := GetCurrentProcessId;\r\n\r\n // Debug(WinXPSP3): SymInitializeWFunc==nil\r\n if Assigned(SymInitializeWFunc) then\r\n Result := SymInitializeWFunc(ProcessHandle, PWideChar(WideString(SearchPath)), False)\r\n else\r\n if Assigned(SymInitializeAFunc) then\r\n Result := SymInitializeAFunc(ProcessHandle, PAnsiChar(AnsiString(SearchPath)), False)\r\n else\r\n Result := False;\r\n\r\n if Result then\r\n begin\r\n SymOptions := SymGetOptionsFunc or SYMOPT_DEFERRED_LOADS\r\n or SYMOPT_FAIL_CRITICAL_ERRORS or SYMOPT_INCLUDE_32BIT_MODULES or SYMOPT_LOAD_LINES;\r\n SymOptions := SymOptions and (not (SYMOPT_NO_UNQUALIFIED_LOADS or SYMOPT_UNDNAME));\r\n SymSetOptionsFunc(SymOptions);\r\n end;\r\n\r\n DebugSymbolsInitialized := Result;\r\n end\r\n else\r\n UnloadDebugFunctions;\r\n end;\r\nend;\r\n\r\nclass function TJclDebugInfoSymbols.CleanupDebugSymbols: Boolean;\r\nbegin\r\n Result := True;\r\n\r\n if DebugSymbolsInitialized then\r\n Result := SymCleanupFunc(GetCurrentProcess);\r\n\r\n UnloadDebugFunctions;\r\nend;\r\n\r\nfunction TJclDebugInfoSymbols.GetLocationInfo(const Addr: Pointer;\r\n out Info: TJclLocationInfo): Boolean;\r\nconst\r\n SymbolNameLength = 1000;\r\n {$IFDEF CPU32}\r\n SymbolSizeA = SizeOf(TImagehlpSymbolA) + SymbolNameLength * SizeOf(AnsiChar);\r\n SymbolSizeW = SizeOf(TImagehlpSymbolW) + SymbolNameLength * SizeOf(WideChar);\r\n {$ENDIF CPU32}\r\n {$IFDEF CPU64}\r\n SymbolSizeA = SizeOf(TImagehlpSymbolA64) + SymbolNameLength * SizeOf(AnsiChar);\r\n SymbolSizeW = SizeOf(TImagehlpSymbolW64) + SymbolNameLength * SizeOf(WideChar);\r\n {$ENDIF CPU64}\r\nvar\r\n Displacement: DWORD;\r\n ProcessHandle: THandle;\r\n {$IFDEF CPU32}\r\n SymbolA: PImagehlpSymbolA;\r\n SymbolW: PImagehlpSymbolW;\r\n LineA: TImageHlpLineA;\r\n LineW: TImageHlpLineW;\r\n {$ENDIF CPU32}\r\n {$IFDEF CPU64}\r\n SymbolA: PImagehlpSymbolA64;\r\n SymbolW: PImagehlpSymbolW64;\r\n LineA: TImageHlpLineA64;\r\n LineW: TImageHlpLineW64;\r\n {$ENDIF CPU64}\r\nbegin\r\n ProcessHandle := GetCurrentProcess;\r\n\r\n if Assigned(SymGetSymFromAddrWFunc) then\r\n begin\r\n GetMem(SymbolW, SymbolSizeW);\r\n try\r\n ZeroMemory(SymbolW, SymbolSizeW);\r\n SymbolW^.SizeOfStruct := SizeOf(SymbolW^);\r\n SymbolW^.MaxNameLength := SymbolNameLength;\r\n Displacement := 0;\r\n\r\n Result := SymGetSymFromAddrWFunc(ProcessHandle, TJclAddr(Addr), @Displacement, SymbolW^);\r\n if Result then\r\n begin\r\n Info.DebugInfo := Self;\r\n Info.Address := Addr;\r\n Info.BinaryFileName := FileName;\r\n Info.OffsetFromProcName := Displacement;\r\n JclPeImage.UnDecorateSymbolName(string(WideString(SymbolW^.Name)), Info.ProcedureName, UNDNAME_NAME_ONLY or UNDNAME_NO_ARGUMENTS);\r\n end;\r\n finally\r\n FreeMem(SymbolW);\r\n end;\r\n end\r\n else\r\n if Assigned(SymGetSymFromAddrAFunc) then\r\n begin\r\n GetMem(SymbolA, SymbolSizeA);\r\n try\r\n ZeroMemory(SymbolA, SymbolSizeA);\r\n SymbolA^.SizeOfStruct := SizeOf(SymbolA^);\r\n SymbolA^.MaxNameLength := SymbolNameLength;\r\n Displacement := 0;\r\n\r\n Result := SymGetSymFromAddrAFunc(ProcessHandle, TJclAddr(Addr), @Displacement, SymbolA^);\r\n if Result then\r\n begin\r\n Info.DebugInfo := Self;\r\n Info.Address := Addr;\r\n Info.BinaryFileName := FileName;\r\n Info.OffsetFromProcName := Displacement;\r\n JclPeImage.UnDecorateSymbolName(string(AnsiString(SymbolA^.Name)), Info.ProcedureName, UNDNAME_NAME_ONLY or UNDNAME_NO_ARGUMENTS);\r\n end;\r\n finally\r\n FreeMem(SymbolA);\r\n end;\r\n end\r\n else\r\n Result := False;\r\n\r\n // line number is optional\r\n if Result and Assigned(SymGetLineFromAddrWFunc) then\r\n begin\r\n ZeroMemory(@LineW, SizeOf(LineW));\r\n LineW.SizeOfStruct := SizeOf(LineW);\r\n Displacement := 0;\r\n\r\n if SymGetLineFromAddrWFunc(ProcessHandle, TJclAddr(Addr), @Displacement, LineW) then\r\n begin\r\n Info.LineNumber := LineW.LineNumber;\r\n Info.UnitName := string(LineW.FileName);\r\n Info.OffsetFromLineNumber := Displacement;\r\n end;\r\n end\r\n else\r\n if Result and Assigned(SymGetLineFromAddrAFunc) then\r\n begin\r\n ZeroMemory(@LineA, SizeOf(LineA));\r\n LineA.SizeOfStruct := SizeOf(LineA);\r\n Displacement := 0;\r\n\r\n if SymGetLineFromAddrAFunc(ProcessHandle, TJclAddr(Addr), @Displacement, LineA) then\r\n begin\r\n Info.LineNumber := LineA.LineNumber;\r\n Info.UnitName := string(LineA.FileName);\r\n Info.OffsetFromLineNumber := Displacement;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJclDebugInfoSymbols.InitializeSource: Boolean;\r\nvar\r\n ModuleFileName: TFileName;\r\n {$IFDEF CPU32}\r\n ModuleInfoA: TImagehlpModuleA;\r\n ModuleInfoW: TImagehlpModuleW;\r\n {$ENDIF CPU32}\r\n {$IFDEF CPU64}\r\n ModuleInfoA: TImagehlpModuleA64;\r\n ModuleInfoW: TImagehlpModuleW64;\r\n {$ENDIF CPU64}\r\n ProcessHandle: THandle;\r\nbegin\r\n Result := InitializeDebugSymbols;\r\n if Result then\r\n begin\r\n if IsWinNT then\r\n // in Windows NT, first argument is a process handle\r\n ProcessHandle := GetCurrentProcess\r\n else\r\n // in Windows 95, 98, ME, first argument is a process identifier\r\n ProcessHandle := GetCurrentProcessId;\r\n\r\n if Assigned(SymGetModuleInfoWFunc) then\r\n begin\r\n ZeroMemory(@ModuleInfoW, SizeOf(ModuleInfoW));\r\n ModuleInfoW.SizeOfStruct := SizeOf(ModuleInfoW);\r\n Result := SymGetModuleInfoWFunc(ProcessHandle, Module, ModuleInfoW);\r\n if not Result then\r\n begin\r\n // the symbols for this module are not loaded yet: load the module and query for the symbol again\r\n ModuleFileName := GetModulePath(Module);\r\n ZeroMemory(@ModuleInfoW, SizeOf(ModuleInfoW));\r\n ModuleInfoW.SizeOfStruct := SizeOf(ModuleInfoW);\r\n // warning: crash on WinXP SP3 when SymInitializeAFunc is called with empty SearchPath\r\n // OF: possible loss of data\r\n Result := (SymLoadModuleFunc(ProcessHandle, 0, PAnsiChar(AnsiString(ModuleFileName)), nil, 0, 0) <> 0) and\r\n SymGetModuleInfoWFunc(ProcessHandle, Module, ModuleInfoW);\r\n end;\r\n Result := Result and (ModuleInfoW.BaseOfImage <> 0) and\r\n not (ModuleInfoW.SymType in [SymNone, SymExport]);\r\n end\r\n else\r\n if Assigned(SymGetModuleInfoAFunc) then\r\n begin\r\n ZeroMemory(@ModuleInfoA, SizeOf(ModuleInfoA));\r\n ModuleInfoA.SizeOfStruct := SizeOf(ModuleInfoA);\r\n Result := SymGetModuleInfoAFunc(ProcessHandle, Module, ModuleInfoA);\r\n if not Result then\r\n begin\r\n // the symbols for this module are not loaded yet: load the module and query for the symbol again\r\n ModuleFileName := GetModulePath(Module);\r\n ZeroMemory(@ModuleInfoA, SizeOf(ModuleInfoA));\r\n ModuleInfoA.SizeOfStruct := SizeOf(ModuleInfoA);\r\n // warning: crash on WinXP SP3 when SymInitializeAFunc is called with empty SearchPath\r\n // OF: possible loss of data\r\n Result := (SymLoadModuleFunc(ProcessHandle, 0, PAnsiChar(AnsiString(ModuleFileName)), nil, 0, 0) <> 0) and\r\n SymGetModuleInfoAFunc(ProcessHandle, Module, ModuleInfoA);\r\n end;\r\n Result := Result and (ModuleInfoA.BaseOfImage <> 0) and\r\n not (ModuleInfoA.SymType in [SymNone, SymExport]);\r\n end\r\n else\r\n Result := False;\r\n end;\r\nend;\r\n\r\nclass function TJclDebugInfoSymbols.LoadDebugFunctions: Boolean;\r\nbegin\r\n ImageHlpDllHandle := SafeLoadLibrary(ImageHlpDllName);\r\n\r\n if ImageHlpDllHandle <> 0 then\r\n begin\r\n SymInitializeAFunc := GetProcAddress(ImageHlpDllHandle, SymInitializeAFuncName);\r\n SymInitializeWFunc := GetProcAddress(ImageHlpDllHandle, SymInitializeWFuncName);\r\n SymGetOptionsFunc := GetProcAddress(ImageHlpDllHandle, SymGetOptionsFuncName);\r\n SymSetOptionsFunc := GetProcAddress(ImageHlpDllHandle, SymSetOptionsFuncName);\r\n SymCleanupFunc := GetProcAddress(ImageHlpDllHandle, SymCleanupFuncName);\r\n SymGetSymFromAddrAFunc := GetProcAddress(ImageHlpDllHandle, SymGetSymFromAddrAFuncName);\r\n SymGetSymFromAddrWFunc := GetProcAddress(ImageHlpDllHandle, SymGetSymFromAddrWFuncName);\r\n SymGetModuleInfoAFunc := GetProcAddress(ImageHlpDllHandle, SymGetModuleInfoAFuncName);\r\n SymGetModuleInfoWFunc := GetProcAddress(ImageHlpDllHandle, SymGetModuleInfoWFuncName);\r\n SymLoadModuleFunc := GetProcAddress(ImageHlpDllHandle, SymLoadModuleFuncName);\r\n SymGetLineFromAddrAFunc := GetProcAddress(ImageHlpDllHandle, SymGetLineFromAddrAFuncName);\r\n SymGetLineFromAddrWFunc := GetProcAddress(ImageHlpDllHandle, SymGetLineFromAddrWFuncName);\r\n end;\r\n\r\n // SymGetLineFromAddrFunc is optional\r\n Result := (ImageHlpDllHandle <> 0) and\r\n Assigned(SymGetOptionsFunc) and Assigned(SymSetOptionsFunc) and\r\n Assigned(SymCleanupFunc) and Assigned(SymLoadModuleFunc) and\r\n (Assigned(SymInitializeAFunc) or Assigned(SymInitializeWFunc)) and\r\n (Assigned(SymGetSymFromAddrAFunc) or Assigned(SymGetSymFromAddrWFunc)) and\r\n (Assigned(SymGetModuleInfoAFunc) or Assigned(SymGetModuleInfoWFunc));\r\nend;\r\n\r\nclass function TJclDebugInfoSymbols.UnloadDebugFunctions: Boolean;\r\nbegin\r\n Result := ImageHlpDllHandle <> 0;\r\n\r\n if Result then\r\n FreeLibrary(ImageHlpDllHandle);\r\n\r\n ImageHlpDllHandle := 0;\r\n\r\n SymInitializeAFunc := nil;\r\n SymInitializeWFunc := nil;\r\n SymGetOptionsFunc := nil;\r\n SymSetOptionsFunc := nil;\r\n SymCleanupFunc := nil;\r\n SymGetSymFromAddrAFunc := nil;\r\n SymGetSymFromAddrWFunc := nil;\r\n SymGetModuleInfoAFunc := nil;\r\n SymGetModuleInfoWFunc := nil;\r\n SymLoadModuleFunc := nil;\r\n SymGetLineFromAddrAFunc := nil;\r\n SymGetLineFromAddrWFunc := nil;\r\nend;\r\n\r\n//=== Source location functions ==============================================\r\n\r\n{$STACKFRAMES ON}\r\n\r\nfunction Caller(Level: Integer; FastStackWalk: Boolean): Pointer;\r\nvar\r\n TopOfStack: TJclAddr;\r\n BaseOfStack: TJclAddr;\r\n StackFrame: PStackFrame;\r\nbegin\r\n Result := nil;\r\n try\r\n if FastStackWalk then\r\n begin\r\n StackFrame := GetFramePointer;\r\n BaseOfStack := TJclAddr(StackFrame) - 1;\r\n TopOfStack := GetStackTop;\r\n while (BaseOfStack < TJclAddr(StackFrame)) and (TJclAddr(StackFrame) < TopOfStack) do\r\n begin\r\n if Level = 0 then\r\n begin\r\n Result := Pointer(StackFrame^.CallerAddr - 1);\r\n Break;\r\n end;\r\n StackFrame := PStackFrame(StackFrame^.CallerFrame);\r\n Dec(Level);\r\n end;\r\n end\r\n else\r\n with TJclStackInfoList.Create(False, 1, nil, False, nil, nil) do\r\n try\r\n if Level < Count then\r\n Result := Items[Level].CallerAddr;\r\n finally\r\n Free;\r\n end;\r\n except\r\n Result := nil;\r\n end;\r\nend;\r\n\r\n{$IFNDEF STACKFRAMES_ON}\r\n{$STACKFRAMES OFF}\r\n{$ENDIF ~STACKFRAMES_ON}\r\n\r\nfunction GetLocationInfo(const Addr: Pointer): TJclLocationInfo;\r\nbegin\r\n try\r\n DebugInfoCritSect.Enter;\r\n try\r\n NeedDebugInfoList;\r\n DebugInfoList.GetLocationInfo(Addr, Result)\r\n finally\r\n DebugInfoCritSect.Leave;\r\n end;\r\n except\r\n Finalize(Result);\r\n ResetMemory(Result, SizeOf(Result));\r\n end;\r\nend;\r\n\r\nfunction GetLocationInfo(const Addr: Pointer; out Info: TJclLocationInfo): Boolean;\r\nbegin\r\n try\r\n DebugInfoCritSect.Enter;\r\n try\r\n NeedDebugInfoList;\r\n Result := DebugInfoList.GetLocationInfo(Addr, Info);\r\n finally\r\n DebugInfoCritSect.Leave;\r\n end;\r\n except\r\n Result := False;\r\n end;\r\nend;\r\n\r\nfunction GetLocationInfoStr(const Addr: Pointer; IncludeModuleName, IncludeAddressOffset,\r\n IncludeStartProcLineOffset: Boolean; IncludeVAddress: Boolean): string;\r\nvar\r\n Info, StartProcInfo: TJclLocationInfo;\r\n OffsetStr, StartProcOffsetStr, FixedProcedureName, UnitNameWithoutUnitscope: string;\r\n Module : HMODULE;\r\nbegin\r\n OffsetStr := '';\r\n if GetLocationInfo(Addr, Info) then\r\n with Info do\r\n begin\r\n FixedProcedureName := ProcedureName;\r\n if Pos(UnitName + '.', FixedProcedureName) = 1 then\r\n FixedProcedureName := Copy(FixedProcedureName, Length(UnitName) + 2, Length(FixedProcedureName) - Length(UnitName) - 1)\r\n else\r\n if Pos('.', UnitName) > 1 then\r\n begin\r\n UnitNameWithoutUnitscope := UnitName;\r\n Delete(UnitNameWithoutUnitscope, 1, Pos('.', UnitNameWithoutUnitscope));\r\n if Pos(UnitNameWithoutUnitscope + '.', FixedProcedureName) = 1 then\r\n FixedProcedureName := Copy(FixedProcedureName, Length(UnitNameWithoutUnitscope) + 2, Length(FixedProcedureName) - Length(UnitNameWithoutUnitscope) - 1);\r\n end;\r\n\r\n if LineNumber > 0 then\r\n begin\r\n if IncludeStartProcLineOffset and GetLocationInfo(Pointer(TJclAddr(Info.Address) -\r\n Cardinal(Info.OffsetFromProcName)), StartProcInfo) and (StartProcInfo.LineNumber > 0) then\r\n StartProcOffsetStr := Format(' + %d', [LineNumber - StartProcInfo.LineNumber])\r\n else\r\n StartProcOffsetStr := '';\r\n if IncludeAddressOffset then\r\n begin\r\n if OffsetFromLineNumber >= 0 then\r\n OffsetStr := Format(' + $%x', [OffsetFromLineNumber])\r\n else\r\n OffsetStr := Format(' - $%x', [-OffsetFromLineNumber])\r\n end;\r\n Result := Format('[%p] %s.%s (Line %u, \"%s\"%s)%s', [Addr, UnitName, FixedProcedureName, LineNumber,\r\n SourceName, StartProcOffsetStr, OffsetStr]);\r\n end\r\n else\r\n begin\r\n if IncludeAddressOffset then\r\n OffsetStr := Format(' + $%x', [OffsetFromProcName]);\r\n if UnitName <> '' then\r\n Result := Format('[%p] %s.%s%s', [Addr, UnitName, FixedProcedureName, OffsetStr])\r\n else\r\n Result := Format('[%p] %s%s', [Addr, FixedProcedureName, OffsetStr]);\r\n end;\r\n end\r\n else\r\n begin\r\n Result := Format('[%p]', [Addr]);\r\n IncludeVAddress := True;\r\n end;\r\n if IncludeVAddress or IncludeModuleName then\r\n begin\r\n Module := ModuleFromAddr(Addr);\r\n if IncludeVAddress then\r\n begin\r\n OffsetStr := Format('(%p) ', [Pointer(TJclAddr(Addr) - Module - ModuleCodeOffset)]);\r\n Result := OffsetStr + Result;\r\n end;\r\n if IncludeModuleName then\r\n Insert(Format('{%-12s}', [ExtractFileName(GetModulePath(Module))]), Result, 11 {$IFDEF CPU64}+8{$ENDIF});\r\n end;\r\nend;\r\n\r\nfunction DebugInfoAvailable(const Module: HMODULE): Boolean;\r\nbegin\r\n DebugInfoCritSect.Enter;\r\n try\r\n NeedDebugInfoList;\r\n Result := (DebugInfoList.ItemFromModule[Module] <> nil);\r\n finally\r\n DebugInfoCritSect.Leave;\r\n end;\r\nend;\r\n\r\nprocedure ClearLocationData;\r\nbegin\r\n DebugInfoCritSect.Enter;\r\n try\r\n if DebugInfoList <> nil then\r\n DebugInfoList.Clear;\r\n finally\r\n DebugInfoCritSect.Leave;\r\n end;\r\nend;\r\n\r\n{$STACKFRAMES ON}\r\n\r\nfunction FileByLevel(const Level: Integer): string;\r\nbegin\r\n Result := GetLocationInfo(Caller(Level + 1)).SourceName;\r\nend;\r\n\r\nfunction ModuleByLevel(const Level: Integer): string;\r\nbegin\r\n Result := GetLocationInfo(Caller(Level + 1)).UnitName;\r\nend;\r\n\r\nfunction ProcByLevel(const Level: Integer; OnlyProcedureName: boolean): string;\r\nbegin\r\n Result := GetLocationInfo(Caller(Level + 1)).ProcedureName;\r\n if OnlyProcedureName = true then\r\n begin\r\n if StrILastPos('.', Result) > 0 then\r\n Result :=StrRestOf(Result, StrILastPos('.', Result)+1);\r\n end;\r\nend;\r\n\r\n function LineByLevel(const Level: Integer): Integer;\r\nbegin\r\n Result := GetLocationInfo(Caller(Level + 1)).LineNumber;\r\nend;\r\n\r\nfunction MapByLevel(const Level: Integer; var File_, Module_, Proc_: string;\r\n var Line_: Integer): Boolean;\r\nbegin\r\n Result := MapOfAddr(Caller(Level + 1), File_, Module_, Proc_, Line_);\r\nend;\r\n\r\nfunction ExtractClassName(const ProcedureName: string): string;\r\nvar\r\n D: Integer;\r\nbegin\r\n D := Pos('.', ProcedureName);\r\n if D < 2 then\r\n Result := ''\r\n else\r\n Result := Copy(ProcedureName, 1, D - 1);\r\nend;\r\n\r\nfunction ExtractMethodName(const ProcedureName: string): string;\r\nbegin\r\n Result := Copy(ProcedureName, Pos('.', ProcedureName) + 1, Length(ProcedureName));\r\nend;\r\n\r\nfunction __FILE__(const Level: Integer): string;\r\nbegin\r\n Result := FileByLevel(Level + 1);\r\nend;\r\n\r\nfunction __MODULE__(const Level: Integer): string;\r\nbegin\r\n Result := ModuleByLevel(Level + 1);\r\nend;\r\n\r\nfunction __PROC__(const Level: Integer): string;\r\nbegin\r\n Result := ProcByLevel(Level + 1);\r\nend;\r\n\r\nfunction __LINE__(const Level: Integer): Integer;\r\nbegin\r\n Result := LineByLevel(Level + 1);\r\nend;\r\n\r\nfunction __MAP__(const Level: Integer; var _File, _Module, _Proc: string; var _Line: Integer): Boolean;\r\nbegin\r\n Result := MapByLevel(Level + 1, _File, _Module, _Proc, _Line);\r\nend;\r\n\r\n{$IFNDEF STACKFRAMES_ON}\r\n{$STACKFRAMES OFF}\r\n{$ENDIF ~STACKFRAMES_ON}\r\n\r\nfunction FileOfAddr(const Addr: Pointer): string;\r\nbegin\r\n Result := GetLocationInfo(Addr).SourceName;\r\nend;\r\n\r\nfunction ModuleOfAddr(const Addr: Pointer): string;\r\nbegin\r\n Result := GetLocationInfo(Addr).UnitName;\r\nend;\r\n\r\nfunction ProcOfAddr(const Addr: Pointer): string;\r\nbegin\r\n Result := GetLocationInfo(Addr).ProcedureName;\r\nend;\r\n\r\nfunction LineOfAddr(const Addr: Pointer): Integer;\r\nbegin\r\n Result := GetLocationInfo(Addr).LineNumber;\r\nend;\r\n\r\nfunction MapOfAddr(const Addr: Pointer; var File_, Module_, Proc_: string;\r\n var Line_: Integer): Boolean;\r\nvar\r\n LocInfo: TJclLocationInfo;\r\nbegin\r\n NeedDebugInfoList;\r\n Result := DebugInfoList.GetLocationInfo(Addr, LocInfo);\r\n if Result then\r\n begin\r\n File_ := LocInfo.SourceName;\r\n Module_ := LocInfo.UnitName;\r\n Proc_ := LocInfo.ProcedureName;\r\n Line_ := LocInfo.LineNumber;\r\n end;\r\nend;\r\n\r\nfunction __FILE_OF_ADDR__(const Addr: Pointer): string;\r\nbegin\r\n Result := FileOfAddr(Addr);\r\nend;\r\n\r\nfunction __MODULE_OF_ADDR__(const Addr: Pointer): string;\r\nbegin\r\n Result := ModuleOfAddr(Addr);\r\nend;\r\n\r\nfunction __PROC_OF_ADDR__(const Addr: Pointer): string;\r\nbegin\r\n Result := ProcOfAddr(Addr);\r\nend;\r\n\r\nfunction __LINE_OF_ADDR__(const Addr: Pointer): Integer;\r\nbegin\r\n Result := LineOfAddr(Addr);\r\nend;\r\n\r\nfunction __MAP_OF_ADDR__(const Addr: Pointer; var _File, _Module, _Proc: string;\r\n var _Line: Integer): Boolean;\r\nbegin\r\n Result := MapOfAddr(Addr, _File, _Module, _Proc, _Line);\r\nend;\r\n\r\n//=== { TJclStackBaseList } ==================================================\r\n\r\nconstructor TJclStackBaseList.Create;\r\nbegin\r\n inherited Create(True);\r\n FThreadID := GetCurrentThreadId;\r\n FTimeStamp := Now;\r\nend;\r\n\r\ndestructor TJclStackBaseList.Destroy;\r\nbegin\r\n if Assigned(FOnDestroy) then\r\n FOnDestroy(Self);\r\n inherited Destroy;\r\nend;\r\n\r\n//=== { TJclGlobalStackList } ================================================\r\n\r\ntype\r\n TJclStackBaseListClass = class of TJclStackBaseList;\r\n\r\n TJclGlobalStackList = class(TThreadList)\r\n private\r\n FLockedTID: DWORD;\r\n FTIDLocked: Boolean;\r\n function GetExceptStackInfo(TID: DWORD): TJclStackInfoList;\r\n function GetLastExceptFrameList(TID: DWORD): TJclExceptFrameList;\r\n procedure ItemDestroyed(Sender: TObject);\r\n public\r\n destructor Destroy; override;\r\n procedure AddObject(AObject: TJclStackBaseList);\r\n procedure Clear;\r\n procedure LockThreadID(TID: DWORD);\r\n procedure UnlockThreadID;\r\n function FindObject(TID: DWORD; AClass: TJclStackBaseListClass): TJclStackBaseList;\r\n property ExceptStackInfo[TID: DWORD]: TJclStackInfoList read GetExceptStackInfo;\r\n property LastExceptFrameList[TID: DWORD]: TJclExceptFrameList read GetLastExceptFrameList;\r\n end;\r\n\r\nvar\r\n GlobalStackList: TJclGlobalStackList;\r\n\r\ndestructor TJclGlobalStackList.Destroy;\r\nbegin\r\n with LockList do\r\n try\r\n while Count > 0 do\r\n TObject(Items[0]).Free;\r\n finally\r\n UnlockList;\r\n end;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJclGlobalStackList.AddObject(AObject: TJclStackBaseList);\r\nvar\r\n ReplacedObj: TObject;\r\nbegin\r\n AObject.FOnDestroy := ItemDestroyed;\r\n with LockList do\r\n try\r\n ReplacedObj := FindObject(AObject.ThreadID, TJclStackBaseListClass(AObject.ClassType));\r\n if ReplacedObj <> nil then\r\n begin\r\n Remove(ReplacedObj);\r\n ReplacedObj.Free;\r\n end;\r\n Add(AObject);\r\n finally\r\n UnlockList;\r\n end;\r\nend;\r\n\r\nprocedure TJclGlobalStackList.Clear;\r\nbegin\r\n with LockList do\r\n try\r\n while Count > 0 do\r\n TObject(Items[0]).Free;\r\n { The following call to Clear seems to be useless, but it deallocates memory\r\n by setting the lists capacity back to zero. For the runtime memory leak check\r\n within DUnit it is important that the allocated memory before and after the\r\n test is equal. }\r\n Clear; // do not remove\r\n finally\r\n UnlockList;\r\n end;\r\nend;\r\n\r\nfunction TJclGlobalStackList.FindObject(TID: DWORD; AClass: TJclStackBaseListClass): TJclStackBaseList;\r\nvar\r\n I: Integer;\r\n Item: TJclStackBaseList;\r\nbegin\r\n Result := nil;\r\n with LockList do\r\n try\r\n if FTIDLocked and (GetCurrentThreadId = MainThreadID) then\r\n TID := FLockedTID;\r\n for I := 0 to Count - 1 do\r\n begin\r\n Item := Items[I];\r\n if (Item.ThreadID = TID) and (Item is AClass) then\r\n begin\r\n Result := Item;\r\n Break;\r\n end;\r\n end;\r\n finally\r\n UnlockList;\r\n end;\r\nend;\r\n\r\nfunction TJclGlobalStackList.GetExceptStackInfo(TID: DWORD): TJclStackInfoList;\r\nbegin\r\n Result := TJclStackInfoList(FindObject(TID, TJclStackInfoList));\r\nend;\r\n\r\nfunction TJclGlobalStackList.GetLastExceptFrameList(TID: DWORD): TJclExceptFrameList;\r\nbegin\r\n Result := TJclExceptFrameList(FindObject(TID, TJclExceptFrameList));\r\nend;\r\n\r\nprocedure TJclGlobalStackList.ItemDestroyed(Sender: TObject);\r\nbegin\r\n with LockList do\r\n try\r\n Remove(Sender);\r\n finally\r\n UnlockList;\r\n end;\r\nend;\r\n\r\nprocedure TJclGlobalStackList.LockThreadID(TID: DWORD);\r\nbegin\r\n with LockList do\r\n try\r\n if GetCurrentThreadId = MainThreadID then\r\n begin\r\n FTIDLocked := True;\r\n FLockedTID := TID;\r\n end\r\n else\r\n FTIDLocked := False;\r\n finally\r\n UnlockList;\r\n end;\r\nend;\r\n\r\nprocedure TJclGlobalStackList.UnlockThreadID;\r\nbegin\r\n with LockList do\r\n try\r\n FTIDLocked := False;\r\n finally\r\n UnlockList;\r\n end;\r\nend;\r\n\r\n//=== { TJclGlobalModulesList } ==============================================\r\n\r\ntype\r\n TJclGlobalModulesList = class(TObject)\r\n private\r\n FAddedModules: TStringList;\r\n FHookedModules: TJclModuleArray;\r\n FLock: TJclCriticalSection;\r\n FModulesList: TJclModuleInfoList;\r\n public\r\n constructor Create;\r\n destructor Destroy; override;\r\n procedure AddModule(const ModuleName: string);\r\n function CreateModulesList: TJclModuleInfoList;\r\n procedure FreeModulesList(var ModulesList: TJclModuleInfoList);\r\n function ValidateAddress(Addr: Pointer): Boolean;\r\n end;\r\n\r\nvar\r\n GlobalModulesList: TJclGlobalModulesList;\r\n\r\nconstructor TJclGlobalModulesList.Create;\r\nbegin\r\n FLock := TJclCriticalSection.Create;\r\nend;\r\n\r\ndestructor TJclGlobalModulesList.Destroy;\r\nbegin\r\n FreeAndNil(FLock);\r\n FreeAndNil(FModulesList);\r\n FreeAndNil(FAddedModules);\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJclGlobalModulesList.AddModule(const ModuleName: string);\r\nvar\r\n IsMultiThreaded: Boolean;\r\nbegin\r\n IsMultiThreaded := IsMultiThread;\r\n if IsMultiThreaded then\r\n FLock.Enter;\r\n try\r\n if not Assigned(FAddedModules) then\r\n begin\r\n FAddedModules := TStringList.Create;\r\n FAddedModules.Sorted := True;\r\n FAddedModules.Duplicates := dupIgnore;\r\n end;\r\n FAddedModules.Add(ModuleName);\r\n finally\r\n if IsMultiThreaded then\r\n FLock.Leave;\r\n end;\r\nend;\r\n\r\nfunction TJclGlobalModulesList.CreateModulesList: TJclModuleInfoList;\r\nvar\r\n I: Integer;\r\n SystemModulesOnly: Boolean;\r\n IsMultiThreaded: Boolean;\r\n AddedModuleHandle: HMODULE;\r\nbegin\r\n IsMultiThreaded := IsMultiThread;\r\n if IsMultiThreaded then\r\n FLock.Enter;\r\n try\r\n if FModulesList = nil then\r\n begin\r\n SystemModulesOnly := not (stAllModules in JclStackTrackingOptions);\r\n Result := TJclModuleInfoList.Create(False, SystemModulesOnly);\r\n // Add known Borland modules collected by DLL exception hooking code\r\n if SystemModulesOnly and JclHookedExceptModulesList(FHookedModules) then\r\n for I := Low(FHookedModules) to High(FHookedModules) do\r\n Result.AddModule(FHookedModules[I], True);\r\n if Assigned(FAddedModules) then\r\n for I := 0 to FAddedModules.Count - 1 do\r\n begin\r\n AddedModuleHandle := GetModuleHandle(PChar(FAddedModules[I]));\r\n if (AddedModuleHandle <> 0) and\r\n not Assigned(Result.ModuleFromAddress[Pointer(AddedModuleHandle)]) then\r\n Result.AddModule(AddedModuleHandle, True);\r\n end;\r\n if stStaticModuleList in JclStackTrackingOptions then\r\n FModulesList := Result;\r\n end\r\n else\r\n Result := FModulesList;\r\n finally\r\n if IsMultiThreaded then\r\n FLock.Leave;\r\n end;\r\nend;\r\n\r\nprocedure TJclGlobalModulesList.FreeModulesList(var ModulesList: TJclModuleInfoList);\r\nvar\r\n IsMultiThreaded: Boolean;\r\nbegin\r\n if FModulesList <> ModulesList then\r\n begin\r\n IsMultiThreaded := IsMultiThread;\r\n if IsMultiThreaded then\r\n FLock.Enter;\r\n try\r\n FreeAndNil(ModulesList);\r\n finally\r\n if IsMultiThreaded then\r\n FLock.Leave;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJclGlobalModulesList.ValidateAddress(Addr: Pointer): Boolean;\r\nvar\r\n TempList: TJclModuleInfoList;\r\nbegin\r\n TempList := CreateModulesList;\r\n try\r\n Result := TempList.IsValidModuleAddress(Addr);\r\n finally\r\n FreeModulesList(TempList);\r\n end;\r\nend;\r\n\r\nfunction JclValidateModuleAddress(Addr: Pointer): Boolean;\r\nbegin\r\n Result := GlobalModulesList.ValidateAddress(Addr);\r\nend;\r\n\r\n//=== Stack info routines ====================================================\r\n\r\n{$STACKFRAMES OFF}\r\n\r\nfunction ValidCodeAddr(CodeAddr: DWORD; ModuleList: TJclModuleInfoList): Boolean;\r\nbegin\r\n if stAllModules in JclStackTrackingOptions then\r\n Result := ModuleList.IsValidModuleAddress(Pointer(CodeAddr))\r\n else\r\n Result := ModuleList.IsSystemModuleAddress(Pointer(CodeAddr));\r\nend;\r\n\r\nprocedure CorrectExceptStackListTop(List: TJclStackInfoList; SkipFirstItem: Boolean);\r\nvar\r\n TopItem, I, FoundPos: Integer;\r\nbegin\r\n FoundPos := -1;\r\n if SkipFirstItem then\r\n TopItem := 1\r\n else\r\n TopItem := 0;\r\n with List do\r\n begin\r\n for I := Count - 1 downto TopItem do\r\n if JclBelongsHookedCode(Items[I].CallerAddr) then\r\n begin\r\n FoundPos := I;\r\n Break;\r\n end;\r\n if FoundPos <> -1 then\r\n for I := FoundPos downto TopItem do\r\n Delete(I);\r\n end;\r\nend;\r\n\r\n{$STACKFRAMES ON}\r\n\r\nprocedure DoExceptionStackTrace(ExceptObj: TObject; ExceptAddr: Pointer; OSException: Boolean;\r\n BaseOfStack: Pointer);\r\nvar\r\n IgnoreLevels: Integer;\r\n FirstCaller: Pointer;\r\n RawMode: Boolean;\r\n Delayed: Boolean;\r\nbegin\r\n RawMode := stRawMode in JclStackTrackingOptions;\r\n Delayed := stDelayedTrace in JclStackTrackingOptions;\r\n if BaseOfStack = nil then\r\n begin\r\n BaseOfStack := GetFramePointer;\r\n IgnoreLevels := 1;\r\n end\r\n else\r\n IgnoreLevels := -1; // because of the \"IgnoreLevels + 1\" in TJclStackInfoList.StoreToList()\r\n if OSException then\r\n begin\r\n if IgnoreLevels = -1 then\r\n IgnoreLevels := 0\r\n else\r\n Inc(IgnoreLevels); // => HandleAnyException\r\n FirstCaller := ExceptAddr;\r\n end\r\n else\r\n FirstCaller := nil;\r\n JclCreateStackList(RawMode, IgnoreLevels, FirstCaller, Delayed, BaseOfStack).CorrectOnAccess(OSException);\r\nend;\r\n\r\nfunction JclLastExceptStackList: TJclStackInfoList;\r\nbegin\r\n Result := GlobalStackList.ExceptStackInfo[GetCurrentThreadID];\r\nend;\r\n\r\nfunction JclLastExceptStackListToStrings(Strings: TStrings; IncludeModuleName, IncludeAddressOffset,\r\n IncludeStartProcLineOffset, IncludeVAddress: Boolean): Boolean;\r\nvar\r\n List: TJclStackInfoList;\r\nbegin\r\n List := JclLastExceptStackList;\r\n Result := Assigned(List);\r\n if Result then\r\n List.AddToStrings(Strings, IncludeModuleName, IncludeAddressOffset, IncludeStartProcLineOffset,\r\n IncludeVAddress);\r\nend;\r\n\r\nfunction JclGetExceptStackList(ThreadID: DWORD): TJclStackInfoList;\r\nbegin\r\n Result := GlobalStackList.ExceptStackInfo[ThreadID];\r\nend;\r\n\r\nfunction JclGetExceptStackListToStrings(ThreadID: DWORD; Strings: TStrings;\r\n IncludeModuleName: Boolean = False; IncludeAddressOffset: Boolean = False;\r\n IncludeStartProcLineOffset: Boolean = False; IncludeVAddress: Boolean = False): Boolean;\r\nvar\r\n List: TJclStackInfoList;\r\nbegin\r\n List := JclGetExceptStackList(ThreadID);\r\n Result := Assigned(List);\r\n if Result then\r\n List.AddToStrings(Strings, IncludeModuleName, IncludeAddressOffset, IncludeStartProcLineOffset,\r\n IncludeVAddress);\r\nend;\r\n\r\nprocedure JclClearGlobalStackData;\r\nbegin\r\n GlobalStackList.Clear;\r\nend;\r\n\r\nfunction JclCreateStackList(Raw: Boolean; AIgnoreLevels: Integer; FirstCaller: Pointer): TJclStackInfoList;\r\nbegin\r\n Result := TJclStackInfoList.Create(Raw, AIgnoreLevels, FirstCaller, False, nil, nil);\r\n GlobalStackList.AddObject(Result);\r\nend;\r\n\r\nfunction JclCreateStackList(Raw: Boolean; AIgnoreLevels: Integer; FirstCaller: Pointer;\r\n DelayedTrace: Boolean): TJclStackInfoList;\r\nbegin\r\n Result := TJclStackInfoList.Create(Raw, AIgnoreLevels, FirstCaller, DelayedTrace, nil, nil);\r\n GlobalStackList.AddObject(Result);\r\nend;\r\n\r\nfunction JclCreateStackList(Raw: Boolean; AIgnoreLevels: Integer; FirstCaller: Pointer;\r\n DelayedTrace: Boolean; BaseOfStack: Pointer): TJclStackInfoList;\r\nbegin\r\n Result := TJclStackInfoList.Create(Raw, AIgnoreLevels, FirstCaller, DelayedTrace, BaseOfStack, nil);\r\n GlobalStackList.AddObject(Result);\r\nend;\r\n\r\nfunction JclCreateStackList(Raw: Boolean; AIgnoreLevels: Integer; FirstCaller: Pointer;\r\n DelayedTrace: Boolean; BaseOfStack, TopOfStack: Pointer): TJclStackInfoList;\r\nbegin\r\n Result := TJclStackInfoList.Create(Raw, AIgnoreLevels, FirstCaller, DelayedTrace, BaseOfStack, TopOfStack);\r\n GlobalStackList.AddObject(Result);\r\nend;\r\n\r\nfunction GetThreadTopOfStack(ThreadHandle: THandle): TJclAddr;\r\nvar\r\n TBI: THREAD_BASIC_INFORMATION;\r\n ReturnedLength: ULONG;\r\nbegin\r\n Result := 0;\r\n ReturnedLength := 0;\r\n if (NtQueryInformationThread(ThreadHandle, ThreadBasicInformation, @TBI, SizeOf(TBI), @ReturnedLength) < $80000000) and\r\n (ReturnedLength = SizeOf(TBI)) then\r\n {$IFDEF CPU32}\r\n Result := TJclAddr(PNT_TIB32(TBI.TebBaseAddress)^.StackBase)\r\n {$ENDIF CPU32}\r\n {$IFDEF CPU64}\r\n Result := TJclAddr(PNT_TIB64(TBI.TebBaseAddress)^.StackBase)\r\n {$ENDIF CPU64}\r\n else\r\n RaiseLastOSError;\r\nend;\r\n\r\nfunction JclCreateThreadStackTrace(Raw: Boolean; const ThreadHandle: THandle): TJclStackInfoList;\r\nvar\r\n ContextMemory: Pointer;\r\n AlignedContext: PContext;\r\nbegin\r\n Result := nil;\r\n GetMem(ContextMemory, SizeOf(TContext) + 15);\r\n try\r\n if (Cardinal(ContextMemory) and 15) <> 0 then\r\n AlignedContext := PContext((Cardinal(ContextMemory) + 16) and $FFFFFFF0)\r\n else\r\n AlignedContext := ContextMemory;\r\n ResetMemory(AlignedContext^, SizeOf(AlignedContext^));\r\n AlignedContext^.ContextFlags := CONTEXT_FULL;\r\n {$IFDEF CPU32}\r\n if GetThreadContext(ThreadHandle, AlignedContext^) then\r\n Result := JclCreateStackList(Raw, -1, Pointer(AlignedContext^.Eip), False, Pointer(AlignedContext^.Ebp),\r\n Pointer(GetThreadTopOfStack(ThreadHandle)));\r\n {$ENDIF CPU32}\r\n {$IFDEF CPU64}\r\n if GetThreadContext(ThreadHandle, AlignedContext^) then\r\n Result := JclCreateStackList(Raw, -1, Pointer(AlignedContext^.Rip), False, Pointer(AlignedContext^.Rbp),\r\n Pointer(GetThreadTopOfStack(ThreadHandle)));\r\n {$ENDIF CPU64}\r\n finally\r\n FreeMem(ContextMemory);\r\n end;\r\nend;\r\n\r\nfunction JclCreateThreadStackTraceFromID(Raw: Boolean; ThreadID: DWORD): TJclStackInfoList;\r\ntype\r\n TOpenThreadFunc = function(DesiredAccess: DWORD; InheritHandle: BOOL; ThreadID: DWORD): THandle; stdcall;\r\nconst\r\n THREAD_GET_CONTEXT = $0008;\r\n THREAD_QUERY_INFORMATION = $0040;\r\nvar\r\n Kernel32Lib, ThreadHandle: THandle;\r\n OpenThreadFunc: TOpenThreadFunc;\r\nbegin\r\n Result := nil;\r\n Kernel32Lib := GetModuleHandle(kernel32);\r\n if Kernel32Lib <> 0 then\r\n begin\r\n // OpenThread only exists since Windows ME\r\n OpenThreadFunc := GetProcAddress(Kernel32Lib, 'OpenThread');\r\n if Assigned(OpenThreadFunc) then\r\n begin\r\n ThreadHandle := OpenThreadFunc(THREAD_GET_CONTEXT or THREAD_QUERY_INFORMATION, False, ThreadID);\r\n if ThreadHandle <> 0 then\r\n try\r\n Result := JclCreateThreadStackTrace(Raw, ThreadHandle);\r\n finally\r\n CloseHandle(ThreadHandle);\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\n//=== { TJclStackInfoItem } ==================================================\r\n\r\nfunction TJclStackInfoItem.GetCallerAddr: Pointer;\r\nbegin\r\n Result := Pointer(FStackInfo.CallerAddr);\r\nend;\r\n\r\nfunction TJclStackInfoItem.GetLogicalAddress: TJclAddr;\r\nbegin\r\n Result := FStackInfo.CallerAddr - TJclAddr(ModuleFromAddr(CallerAddr));\r\nend;\r\n\r\n//=== { TJclStackInfoList } ==================================================\r\n\r\nconstructor TJclStackInfoList.Create(ARaw: Boolean; AIgnoreLevels: Integer;\r\n AFirstCaller: Pointer);\r\nbegin\r\n Create(ARaw, AIgnoreLevels, AFirstCaller, False, nil, nil);\r\nend;\r\n\r\nconstructor TJclStackInfoList.Create(ARaw: Boolean; AIgnoreLevels: Integer;\r\n AFirstCaller: Pointer; ADelayedTrace: Boolean);\r\nbegin\r\n Create(ARaw, AIgnoreLevels, AFirstCaller, ADelayedTrace, nil, nil);\r\nend;\r\n\r\nconstructor TJclStackInfoList.Create(ARaw: Boolean; AIgnoreLevels: Integer;\r\n AFirstCaller: Pointer; ADelayedTrace: Boolean; ABaseOfStack: Pointer);\r\nbegin\r\n Create(ARaw, AIgnoreLevels, AFirstCaller, ADelayedTrace, ABaseOfStack, nil);\r\nend;\r\n\r\nconstructor TJclStackInfoList.Create(ARaw: Boolean; AIgnoreLevels: Integer;\r\n AFirstCaller: Pointer; ADelayedTrace: Boolean; ABaseOfStack, ATopOfStack: Pointer);\r\nvar\r\n Item: TJclStackInfoItem;\r\nbegin\r\n inherited Create;\r\n FIgnoreLevels := AIgnoreLevels;\r\n FDelayedTrace := ADelayedTrace;\r\n FRaw := ARaw;\r\n BaseOfStack := TJclAddr(ABaseOfStack);\r\n FStackOffset := 0;\r\n FFramePointer := ABaseOfStack;\r\n\r\n if ATopOfStack = nil then\r\n TopOfStack := GetStackTop\r\n else\r\n TopOfStack := TJclAddr(ATopOfStack);\r\n\r\n FModuleInfoList := GlobalModulesList.CreateModulesList;\r\n if AFirstCaller <> nil then\r\n begin\r\n Item := TJclStackInfoItem.Create;\r\n Item.FStackInfo.CallerAddr := TJclAddr(AFirstCaller);\r\n Add(Item);\r\n end;\r\n {$IFDEF CPU32}\r\n if DelayedTrace then\r\n DelayStoreStack\r\n else\r\n if Raw then\r\n TraceStackRaw\r\n else\r\n TraceStackFrames;\r\n {$ENDIF CPU32}\r\n {$IFDEF CPU64}\r\n CaptureBackTrace;\r\n {$ENDIF CPU64}\r\nend;\r\n\r\ndestructor TJclStackInfoList.Destroy;\r\nbegin\r\n if Assigned(FStackData) then\r\n FreeMem(FStackData);\r\n GlobalModulesList.FreeModulesList(FModuleInfoList);\r\n inherited Destroy;\r\nend;\r\n\r\n{$IFDEF CPU64}\r\nprocedure TJclStackInfoList.CaptureBackTrace;\r\nvar\r\n CapturedFramesCount: Word;\r\n BackTrace: array [0..62] of Pointer;\r\n Hash: DWORD;\r\n I: Integer;\r\n StackInfo: TStackInfo;\r\nbegin\r\n ResetMemory(BackTrace, SizeOf(BackTrace));\r\n //TODO: For XP and 2003 sum of FramesToSkip and FramesToCapture must be lower\r\n // than 63, but we could use higher values for newer OS versions\r\n CapturedFramesCount := CaptureStackBackTrace(10, 52, @BackTrace, Hash);\r\n for I := 0 to CapturedFramesCount - 1 do\r\n begin\r\n ResetMemory(StackInfo, SizeOf(StackInfo));\r\n StackInfo.CallerAddr := TJclAddr(BackTrace[I]);\r\n StackInfo.Level := I;\r\n StoreToList(StackInfo);\r\n end;\r\nend;\r\n{$ENDIF CPU64}\r\n\r\nprocedure TJclStackInfoList.ForceStackTracing;\r\nbegin\r\n if DelayedTrace and Assigned(FStackData) and not FInStackTracing then\r\n begin\r\n FInStackTracing := True;\r\n try\r\n if Raw then\r\n TraceStackRaw\r\n else\r\n TraceStackFrames;\r\n if FCorrectOnAccess then\r\n CorrectExceptStackListTop(Self, FSkipFirstItem);\r\n finally\r\n FInStackTracing := False;\r\n FDelayedTrace := False;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJclStackInfoList.GetCount: Integer;\r\nbegin\r\n ForceStackTracing;\r\n Result := inherited Count;\r\nend;\r\n\r\nprocedure TJclStackInfoList.CorrectOnAccess(ASkipFirstItem: Boolean);\r\nbegin\r\n FCorrectOnAccess := True;\r\n FSkipFirstItem := ASkipFirstItem;\r\nend;\r\n\r\nprocedure TJclStackInfoList.AddToStrings(Strings: TStrings; IncludeModuleName, IncludeAddressOffset,\r\n IncludeStartProcLineOffset, IncludeVAddress: Boolean);\r\nvar\r\n I: Integer;\r\nbegin\r\n ForceStackTracing;\r\n Strings.BeginUpdate;\r\n try\r\n for I := 0 to Count - 1 do\r\n Strings.Add(GetLocationInfoStr(Items[I].CallerAddr, IncludeModuleName, IncludeAddressOffset,\r\n IncludeStartProcLineOffset, IncludeVAddress));\r\n finally\r\n Strings.EndUpdate;\r\n end;\r\nend;\r\n\r\nfunction TJclStackInfoList.GetItems(Index: Integer): TJclStackInfoItem;\r\nbegin\r\n ForceStackTracing;\r\n Result := TJclStackInfoItem(Get(Index));\r\nend;\r\n\r\nfunction TJclStackInfoList.NextStackFrame(var StackFrame: PStackFrame; var StackInfo: TStackInfo): Boolean;\r\nvar\r\n CallInstructionSize: Cardinal;\r\n StackFrameCallerFrame, NewFrame: TJclAddr;\r\n StackFrameCallerAddr: TJclAddr;\r\nbegin\r\n // Only report this stack frame into the StockInfo structure\r\n // if the StackFrame pointer, the frame pointer and the return address on the stack\r\n // are valid addresses\r\n StackFrameCallerFrame := StackInfo.CallerFrame;\r\n while ValidStackAddr(TJclAddr(StackFrame)) do\r\n begin\r\n // CallersEBP above the previous CallersEBP\r\n NewFrame := StackFrame^.CallerFrame;\r\n if NewFrame <= StackFrameCallerFrame then\r\n Break;\r\n StackFrameCallerFrame := NewFrame;\r\n\r\n // CallerAddr within current process space, code segment etc.\r\n // CallerFrame within current thread stack. Added Mar 12 2002 per Hallvard's suggestion\r\n StackFrameCallerAddr := StackFrame^.CallerAddr;\r\n if ValidCodeAddr(StackFrameCallerAddr, FModuleInfoList) and ValidStackAddr(StackFrameCallerFrame + FStackOffset) then\r\n begin\r\n Inc(StackInfo.Level);\r\n StackInfo.StackFrame := StackFrame;\r\n StackInfo.ParamPtr := PDWORD_PTRArray(TJclAddr(StackFrame) + SizeOf(TStackFrame));\r\n\r\n if StackFrameCallerFrame > StackInfo.CallerFrame then\r\n StackInfo.CallerFrame := StackFrameCallerFrame\r\n else\r\n // the frame pointer points to an address that is below\r\n // the last frame pointer, so it must be invalid\r\n Break;\r\n\r\n // Calculate the address of caller by subtracting the CALL instruction size (if possible)\r\n if ValidCallSite(StackFrameCallerAddr, CallInstructionSize) then\r\n StackInfo.CallerAddr := StackFrameCallerAddr - CallInstructionSize\r\n else\r\n StackInfo.CallerAddr := StackFrameCallerAddr;\r\n // the stack may be messed up in big projects, avoid overflow in arithmetics\r\n if StackFrameCallerFrame < TJclAddr(StackFrame) then\r\n Break;\r\n StackInfo.DumpSize := StackFrameCallerFrame - TJclAddr(StackFrame);\r\n StackInfo.ParamSize := (StackInfo.DumpSize - SizeOf(TStackFrame)) div 4;\r\n if PStackFrame(StackFrame^.CallerFrame) = StackFrame then\r\n Break;\r\n // Step to the next stack frame by following the frame pointer\r\n StackFrame := PStackFrame(StackFrameCallerFrame + FStackOffset);\r\n Result := True;\r\n Exit;\r\n end;\r\n // Step to the next stack frame by following the frame pointer\r\n StackFrame := PStackFrame(StackFrameCallerFrame + FStackOffset);\r\n end;\r\n Result := False;\r\nend;\r\n\r\nprocedure TJclStackInfoList.StoreToList(const StackInfo: TStackInfo);\r\nvar\r\n Item: TJclStackInfoItem;\r\nbegin\r\n if ((IgnoreLevels = -1) and (StackInfo.Level > 0)) or\r\n (StackInfo.Level > (IgnoreLevels + 1)) then\r\n begin\r\n Item := TJclStackInfoItem.Create;\r\n Item.FStackInfo := StackInfo;\r\n Add(Item);\r\n end;\r\nend;\r\n\r\nprocedure TJclStackInfoList.TraceStackFrames;\r\nvar\r\n StackFrame: PStackFrame;\r\n StackInfo: TStackInfo;\r\nbegin\r\n Capacity := 32; // reduce ReallocMem calls, must be > 1 because the caller's EIP register is already in the list\r\n\r\n // Start at level 0\r\n StackInfo.Level := 0;\r\n StackInfo.CallerFrame := 0;\r\n if DelayedTrace then\r\n // Get the current stack frame from the frame register\r\n StackFrame := FFramePointer\r\n else\r\n begin\r\n // We define the bottom of the valid stack to be the current ESP pointer\r\n if BaseOfStack = 0 then\r\n BaseOfStack := TJclAddr(GetFramePointer);\r\n // Get a pointer to the current bottom of the stack\r\n StackFrame := PStackFrame(BaseOfStack);\r\n end;\r\n\r\n // We define the bottom of the valid stack to be the current frame Pointer\r\n // There is a TIB field called pvStackUserBase, but this includes more of the\r\n // stack than what would define valid stack frames.\r\n BaseOfStack := TJclAddr(StackFrame) - 1;\r\n // Loop over and report all valid stackframes\r\n while NextStackFrame(StackFrame, StackInfo) and (inherited Count <> MaxStackTraceItems) do\r\n StoreToList(StackInfo);\r\nend;\r\n\r\nfunction SearchForStackPtrManipulation(StackPtr: Pointer; Proc: Pointer): Pointer;\r\n{$IFDEF SUPPORTS_INLINE}\r\ninline;\r\n{$ENDIF SUPPORTS_INLINE}\r\n{var\r\n Addr: PByteArray;}\r\nbegin\r\n{ Addr := Proc;\r\n while (Addr <> nil) and (DWORD_PTR(Addr) > DWORD_PTR(Proc) - $100) and not IsBadReadPtr(Addr, 6) do\r\n begin\r\n if (Addr[0] = $55) and // push ebp\r\n (Addr[1] = $8B) and (Addr[2] = $EC) then // mov ebp,esp\r\n begin\r\n if (Addr[3] = $83) and (Addr[4] = $C4) then // add esp,c8\r\n begin\r\n Result := Pointer(INT_PTR(StackPtr) - ShortInt(Addr[5]));\r\n Exit;\r\n end;\r\n Break;\r\n end;\r\n\r\n if (Addr[0] = $C2) and // ret $xxxx\r\n (((Addr[3] = $90) and (Addr[4] = $90) and (Addr[5] = $90)) or // nop\r\n ((Addr[3] = $CC) and (Addr[4] = $CC) and (Addr[5] = $CC))) then // int 3\r\n Break;\r\n\r\n if (Addr[0] = $C3) and // ret\r\n (((Addr[1] = $90) and (Addr[2] = $90) and (Addr[3] = $90)) or // nop\r\n ((Addr[1] = $CC) and (Addr[2] = $CC) and (Addr[3] = $CC))) then // int 3\r\n Break;\r\n\r\n if (Addr[0] = $E9) and // jmp rel-far\r\n (((Addr[5] = $90) and (Addr[6] = $90) and (Addr[7] = $90)) or // nop\r\n ((Addr[5] = $CC) and (Addr[6] = $CC) and (Addr[7] = $CC))) then // int 3\r\n Break;\r\n\r\n if (Addr[0] = $EB) and // jmp rel-near\r\n (((Addr[2] = $90) and (Addr[3] = $90) and (Addr[4] = $90)) or // nop\r\n ((Addr[2] = $CC) and (Addr[3] = $CC) and (Addr[4] = $CC))) then // int 3\r\n Break;\r\n\r\n Dec(DWORD_TR(Addr));\r\n end;}\r\n Result := StackPtr;\r\nend;\r\n\r\nprocedure TJclStackInfoList.TraceStackRaw;\r\nvar\r\n StackInfo: TStackInfo;\r\n StackPtr: PJclAddr;\r\n PrevCaller: TJclAddr;\r\n CallInstructionSize: Cardinal;\r\n StackTop: TJclAddr;\r\nbegin\r\n Capacity := 32; // reduce ReallocMem calls, must be > 1 because the caller's EIP register is already in the list\r\n\r\n if DelayedTrace then\r\n begin\r\n if not Assigned(FStackData) then\r\n Exit;\r\n StackPtr := PJclAddr(FStackData);\r\n end\r\n else\r\n begin\r\n // We define the bottom of the valid stack to be the current ESP pointer\r\n if BaseOfStack = 0 then\r\n BaseOfStack := TJclAddr(GetStackPointer);\r\n // Get a pointer to the current bottom of the stack\r\n StackPtr := PJclAddr(BaseOfStack);\r\n end;\r\n\r\n StackTop := TopOfStack;\r\n\r\n if Count > 0 then\r\n StackPtr := SearchForStackPtrManipulation(StackPtr, Pointer(Items[0].StackInfo.CallerAddr));\r\n\r\n // We will not be able to fill in all the fields in the StackInfo record,\r\n // so just blank it all out first\r\n ResetMemory(StackInfo, SizeOf(StackInfo));\r\n // Clear the previous call address\r\n PrevCaller := 0;\r\n // Loop through all of the valid stack space\r\n while (TJclAddr(StackPtr) < StackTop) and (inherited Count <> MaxStackTraceItems) do\r\n begin\r\n // If the current DWORD on the stack refers to a valid call site...\r\n if ValidCallSite(StackPtr^, CallInstructionSize) and (StackPtr^ <> PrevCaller) then\r\n begin\r\n // then pick up the callers address\r\n StackInfo.CallerAddr := StackPtr^ - CallInstructionSize;\r\n // remember to callers address so that we don't report it repeatedly\r\n PrevCaller := StackPtr^;\r\n // increase the stack level\r\n Inc(StackInfo.Level);\r\n // then report it back to our caller\r\n StoreToList(StackInfo);\r\n StackPtr := SearchForStackPtrManipulation(StackPtr, Pointer(StackInfo.CallerAddr));\r\n end;\r\n // Look at the next DWORD on the stack\r\n Inc(StackPtr);\r\n end;\r\n if Assigned(FStackData) then\r\n begin\r\n FreeMem(FStackData);\r\n FStackData := nil;\r\n end;\r\nend;\r\n\r\n{$IFDEF CPU32}\r\nprocedure TJclStackInfoList.DelayStoreStack;\r\nvar\r\n StackPtr: PJclAddr;\r\n StackDataSize: Cardinal;\r\nbegin\r\n if Assigned(FStackData) then\r\n begin\r\n FreeMem(FStackData);\r\n FStackData := nil;\r\n end;\r\n // We define the bottom of the valid stack to be the current ESP pointer\r\n if BaseOfStack = 0 then\r\n begin\r\n BaseOfStack := TJclAddr(GetStackPointer);\r\n FFramePointer := GetFramePointer;\r\n end;\r\n\r\n // Get a pointer to the current bottom of the stack\r\n StackPtr := PJclAddr(BaseOfStack);\r\n if TJclAddr(StackPtr) < TopOfStack then\r\n begin\r\n StackDataSize := TopOfStack - TJclAddr(StackPtr);\r\n GetMem(FStackData, StackDataSize);\r\n System.Move(StackPtr^, FStackData^, StackDataSize);\r\n //CopyMemory(FStackData, StackPtr, StackDataSize);\r\n end;\r\n\r\n FStackOffset := Int64(FStackData) - Int64(StackPtr);\r\n FFramePointer := Pointer(TJclAddr(FFramePointer) + FStackOffset);\r\n TopOfStack := TopOfStack + FStackOffset;\r\nend;\r\n{$ENDIF CPU32}\r\n\r\n// Validate that the code address is a valid code site\r\n//\r\n// Information from Intel Manual 24319102(2).pdf, Download the 6.5 MBs from:\r\n// http://developer.intel.com/design/pentiumii/manuals/243191.htm\r\n// Instruction format, Chapter 2 and The CALL instruction: page 3-53, 3-54\r\n\r\nfunction TJclStackInfoList.ValidCallSite(CodeAddr: TJclAddr; out CallInstructionSize: Cardinal): Boolean;\r\nvar\r\n CodeDWORD4: DWORD;\r\n CodeDWORD8: DWORD;\r\n C4P, C8P: PDWORD;\r\n RM1, RM2, RM5: Byte;\r\nbegin\r\n // todo: 64 bit version\r\n\r\n // First check that the address is within range of our code segment!\r\n Result := CodeAddr > 8;\r\n if Result then\r\n begin\r\n C8P := PDWORD(CodeAddr - 8);\r\n C4P := PDWORD(CodeAddr - 4);\r\n Result := ValidCodeAddr(TJclAddr(C8P), FModuleInfoList) and not IsBadReadPtr(C8P, 8);\r\n\r\n // Now check to see if the instruction preceding the return address\r\n // could be a valid CALL instruction\r\n if Result then\r\n begin\r\n try\r\n CodeDWORD8 := PDWORD(C8P)^;\r\n CodeDWORD4 := PDWORD(C4P)^;\r\n // CodeDWORD8 = (ReturnAddr-5):(ReturnAddr-6):(ReturnAddr-7):(ReturnAddr-8)\r\n // CodeDWORD4 = (ReturnAddr-1):(ReturnAddr-2):(ReturnAddr-3):(ReturnAddr-4)\r\n\r\n // ModR/M bytes contain the following bits:\r\n // Mod = (76)\r\n // Reg/Opcode = (543)\r\n // R/M = (210)\r\n RM1 := (CodeDWORD4 shr 24) and $7;\r\n RM2 := (CodeDWORD4 shr 16) and $7;\r\n //RM3 := (CodeDWORD4 shr 8) and $7;\r\n //RM4 := CodeDWORD4 and $7;\r\n RM5 := (CodeDWORD8 shr 24) and $7;\r\n //RM6 := (CodeDWORD8 shr 16) and $7;\r\n //RM7 := (CodeDWORD8 shr 8) and $7;\r\n\r\n // Check the instruction prior to the potential call site.\r\n // We consider it a valid call site if we find a CALL instruction there\r\n // Check the most common CALL variants first\r\n if ((CodeDWORD8 and $FF000000) = $E8000000) then\r\n // 5 bytes, \"CALL NEAR REL32\" (E8 cd)\r\n CallInstructionSize := 5\r\n else\r\n if ((CodeDWORD4 and $F8FF0000) = $10FF0000) and not (RM1 in [4, 5]) then\r\n // 2 bytes, \"CALL NEAR [EAX]\" (FF /2) where Reg = 010, Mod = 00, R/M <> 100 (1 extra byte)\r\n // and R/M <> 101 (4 extra bytes)\r\n CallInstructionSize := 2\r\n else\r\n if ((CodeDWORD4 and $F8FF0000) = $D0FF0000) then\r\n // 2 bytes, \"CALL NEAR EAX\" (FF /2) where Reg = 010 and Mod = 11\r\n CallInstructionSize := 2\r\n else\r\n if ((CodeDWORD4 and $00FFFF00) = $0014FF00) then\r\n // 3 bytes, \"CALL NEAR [EAX+EAX*i]\" (FF /2) where Reg = 010, Mod = 00 and RM = 100\r\n // SIB byte not validated\r\n CallInstructionSize := 3\r\n else\r\n if ((CodeDWORD4 and $00F8FF00) = $0050FF00) and (RM2 <> 4) then\r\n // 3 bytes, \"CALL NEAR [EAX+$12]\" (FF /2) where Reg = 010, Mod = 01 and RM <> 100 (1 extra byte)\r\n CallInstructionSize := 3\r\n else\r\n if ((CodeDWORD4 and $0000FFFF) = $000054FF) then\r\n // 4 bytes, \"CALL NEAR [EAX+EAX+$12]\" (FF /2) where Reg = 010, Mod = 01 and RM = 100\r\n // SIB byte not validated\r\n CallInstructionSize := 4\r\n else\r\n if ((CodeDWORD8 and $FFFF0000) = $15FF0000) then\r\n // 6 bytes, \"CALL NEAR [$12345678]\" (FF /2) where Reg = 010, Mod = 00 and RM = 101\r\n CallInstructionSize := 6\r\n else\r\n if ((CodeDWORD8 and $F8FF0000) = $90FF0000) and (RM5 <> 4) then\r\n // 6 bytes, \"CALL NEAR [EAX+$12345678]\" (FF /2) where Reg = 010, Mod = 10 and RM <> 100 (1 extra byte)\r\n CallInstructionSize := 6\r\n else\r\n if ((CodeDWORD8 and $00FFFF00) = $0094FF00) then\r\n // 7 bytes, \"CALL NEAR [EAX+EAX+$1234567]\" (FF /2) where Reg = 010, Mod = 10 and RM = 100\r\n CallInstructionSize := 7\r\n else\r\n if ((CodeDWORD8 and $0000FF00) = $00009A00) then\r\n // 7 bytes, \"CALL FAR $1234:12345678\" (9A ptr16:32)\r\n CallInstructionSize := 7\r\n else\r\n Result := False;\r\n // Because we're not doing a complete disassembly, we will potentially report\r\n // false positives. If there is odd code that uses the CALL 16:32 format, we\r\n // can also get false negatives.\r\n except\r\n Result := False;\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\n{$IFNDEF STACKFRAMES_ON}\r\n{$STACKFRAMES OFF}\r\n{$ENDIF ~STACKFRAMES_ON}\r\n\r\nfunction TJclStackInfoList.ValidStackAddr(StackAddr: TJclAddr): Boolean;\r\nbegin\r\n Result := (BaseOfStack < StackAddr) and (StackAddr < TopOfStack);\r\nend;\r\n\r\n//=== Exception frame info routines ==========================================\r\n\r\nfunction JclCreateExceptFrameList(AIgnoreLevels: Integer): TJclExceptFrameList;\r\nbegin\r\n Result := TJclExceptFrameList.Create(AIgnoreLevels);\r\n GlobalStackList.AddObject(Result);\r\nend;\r\n\r\nfunction JclLastExceptFrameList: TJclExceptFrameList;\r\nbegin\r\n Result := GlobalStackList.LastExceptFrameList[GetCurrentThreadID];\r\nend;\r\n\r\nfunction JclGetExceptFrameList(ThreadID: DWORD): TJclExceptFrameList;\r\nbegin\r\n Result := GlobalStackList.LastExceptFrameList[ThreadID];\r\nend;\r\n\r\nprocedure DoExceptFrameTrace;\r\nbegin\r\n // Ignore first 2 levels; the First level is an undefined frame (I haven't a\r\n // clue as to where it comes from. The second level is the try..finally block\r\n // in DoExceptNotify.\r\n JclCreateExceptFrameList(4);\r\nend;\r\n\r\n{$OVERFLOWCHECKS OFF}\r\n\r\nfunction GetJmpDest(Jmp: PJmpInstruction): Pointer;\r\nbegin\r\n // TODO : 64 bit version\r\n if Jmp^.opCode = $E9 then\r\n Result := Pointer(TJclAddr(Jmp) + TJclAddr(Jmp^.distance) + 5)\r\n else\r\n if Jmp.opCode = $EB then\r\n Result := Pointer(TJclAddr(Jmp) + TJclAddr(ShortInt(Jmp^.distance)) + 2)\r\n else\r\n Result := nil;\r\n if (Result <> nil) and (PJmpTable(Result).OPCode = $25FF) then\r\n if not IsBadReadPtr(PJmpTable(Result).Ptr, SizeOf(Pointer)) then\r\n Result := Pointer(PJclAddr(PJmpTable(Result).Ptr)^);\r\nend;\r\n\r\n{$IFDEF OVERFLOWCHECKS_ON}\r\n{$OVERFLOWCHECKS ON}\r\n{$ENDIF OVERFLOWCHECKS_ON}\r\n\r\n//=== { TJclExceptFrame } ====================================================\r\n\r\nconstructor TJclExceptFrame.Create(AFrameLocation: Pointer; AExcDesc: PExcDesc);\r\nbegin\r\n inherited Create;\r\n FFrameKind := efkUnknown;\r\n FFrameLocation := AFrameLocation;\r\n FCodeLocation := nil;\r\n AnalyseExceptFrame(AExcDesc);\r\nend;\r\n\r\n{$RANGECHECKS OFF}\r\n\r\nprocedure TJclExceptFrame.AnalyseExceptFrame(AExcDesc: PExcDesc);\r\nvar\r\n Dest: Pointer;\r\n LocInfo: TJclLocationInfo;\r\n FixedProcedureName: string;\r\n DotPos, I: Integer;\r\nbegin\r\n Dest := GetJmpDest(@AExcDesc^.Jmp);\r\n if Dest <> nil then\r\n begin\r\n // get frame kind\r\n LocInfo := GetLocationInfo(Dest);\r\n if CompareText(LocInfo.UnitName, 'system') = 0 then\r\n begin\r\n FixedProcedureName := LocInfo.ProcedureName;\r\n DotPos := Pos('.', FixedProcedureName);\r\n if DotPos > 0 then\r\n FixedProcedureName := Copy(FixedProcedureName, DotPos + 1, Length(FixedProcedureName) - DotPos);\r\n if CompareText(FixedProcedureName, '@HandleAnyException') = 0 then\r\n FFrameKind := efkAnyException\r\n else\r\n if CompareText(FixedProcedureName, '@HandleOnException') = 0 then\r\n FFrameKind := efkOnException\r\n else\r\n if CompareText(FixedProcedureName, '@HandleAutoException') = 0 then\r\n FFrameKind := efkAutoException\r\n else\r\n if CompareText(FixedProcedureName, '@HandleFinally') = 0 then\r\n FFrameKind := efkFinally;\r\n end;\r\n\r\n // get location\r\n if FFrameKind <> efkUnknown then\r\n begin\r\n FCodeLocation := GetJmpDest(PJmpInstruction(TJclAddr(@AExcDesc^.Instructions)));\r\n if FCodeLocation = nil then\r\n FCodeLocation := @AExcDesc^.Instructions;\r\n end\r\n else\r\n begin\r\n FCodeLocation := GetJmpDest(PJmpInstruction(TJclAddr(AExcDesc)));\r\n if FCodeLocation = nil then\r\n FCodeLocation := AExcDesc;\r\n end;\r\n\r\n // get on handlers\r\n if FFrameKind = efkOnException then\r\n begin\r\n SetLength(FExcTab, AExcDesc^.Cnt);\r\n for I := 0 to AExcDesc^.Cnt - 1 do\r\n begin\r\n if AExcDesc^.ExcTab[I].VTable = nil then\r\n begin\r\n SetLength(FExcTab, I);\r\n Break;\r\n end\r\n else\r\n FExcTab[I] := AExcDesc^.ExcTab[I];\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\n{$IFDEF RANGECHECKS_ON}\r\n{$RANGECHECKS ON}\r\n{$ENDIF RANGECHECKS_ON}\r\n\r\nfunction TJclExceptFrame.Handles(ExceptObj: TObject): Boolean;\r\nvar\r\n Handler: Pointer;\r\nbegin\r\n Result := HandlerInfo(ExceptObj, Handler);\r\nend;\r\n\r\n{$OVERFLOWCHECKS OFF}\r\n\r\nfunction TJclExceptFrame.HandlerInfo(ExceptObj: TObject; out HandlerAt: Pointer): Boolean;\r\nvar\r\n I: Integer;\r\n ObjVTable, VTable, ParentVTable: Pointer;\r\nbegin\r\n Result := FrameKind in [efkAnyException, efkAutoException];\r\n if not Result and (FrameKind = efkOnException) then\r\n begin\r\n HandlerAt := nil;\r\n ObjVTable := Pointer(ExceptObj.ClassType);\r\n for I := Low(FExcTab) to High(FExcTab) do\r\n begin\r\n VTable := ObjVTable;\r\n Result := FExcTab[I].VTable = nil;\r\n while (not Result) and (VTable <> nil) do\r\n begin\r\n Result := (FExcTab[I].VTable = VTable) or\r\n (PShortString(PPointer(PJclAddr(FExcTab[I].VTable)^ + TJclAddr(vmtClassName))^)^ =\r\n PShortString(PPointer(TJclAddr(VTable) + TJclAddr(vmtClassName))^)^);\r\n if Result then\r\n HandlerAt := FExcTab[I].Handler\r\n else\r\n begin\r\n ParentVTable := TClass(VTable).ClassParent;\r\n if ParentVTable = VTable then\r\n VTable := nil\r\n else\r\n VTable := ParentVTable;\r\n end;\r\n end;\r\n if Result then\r\n Break;\r\n end;\r\n end\r\n else\r\n if Result then\r\n HandlerAt := FCodeLocation\r\n else\r\n HandlerAt := nil;\r\nend;\r\n\r\n{$IFDEF OVERFLOWCHECKS_ON}\r\n{$OVERFLOWCHECKS ON}\r\n{$ENDIF OVERFLOWCHECKS_ON}\r\n\r\n//=== { TJclExceptFrameList } ================================================\r\n\r\nconstructor TJclExceptFrameList.Create(AIgnoreLevels: Integer);\r\nbegin\r\n inherited Create;\r\n FIgnoreLevels := AIgnoreLevels;\r\n TraceExceptionFrames;\r\nend;\r\n\r\nfunction TJclExceptFrameList.AddFrame(AFrame: PExcFrame): TJclExceptFrame;\r\nbegin\r\n Result := TJclExceptFrame.Create(AFrame, AFrame^.Desc);\r\n Add(Result);\r\nend;\r\n\r\nfunction TJclExceptFrameList.GetItems(Index: Integer): TJclExceptFrame;\r\nbegin\r\n Result := TJclExceptFrame(Get(Index));\r\nend;\r\n\r\nprocedure TJclExceptFrameList.TraceExceptionFrames;\r\nvar\r\n ExceptionPointer: PExcFrame;\r\n Level: Integer;\r\n ModulesList: TJclModuleInfoList;\r\nbegin\r\n Clear;\r\n ModulesList := GlobalModulesList.CreateModulesList;\r\n try\r\n Level := 0;\r\n ExceptionPointer := GetExceptionPointer;\r\n while TJclAddr(ExceptionPointer) <> High(TJclAddr) do\r\n begin\r\n if (Level >= IgnoreLevels) and ValidCodeAddr(TJclAddr(ExceptionPointer^.Desc), ModulesList) then\r\n AddFrame(ExceptionPointer);\r\n Inc(Level);\r\n ExceptionPointer := ExceptionPointer^.next;\r\n end;\r\n finally\r\n GlobalModulesList.FreeModulesList(ModulesList);\r\n end;\r\nend;\r\n\r\n//=== Exception hooking ======================================================\r\n\r\nvar\r\n TrackingActiveCount: Integer;\r\n IgnoredExceptions: TThreadList = nil;\r\n IgnoredExceptionClassNames: TStringList = nil;\r\n IgnoredExceptionClassNamesCritSect: TJclCriticalSection = nil;\r\n\r\nprocedure AddIgnoredException(const ExceptionClass: TClass);\r\nbegin\r\n if Assigned(ExceptionClass) then\r\n begin\r\n if not Assigned(IgnoredExceptions) then\r\n IgnoredExceptions := TThreadList.Create;\r\n\r\n IgnoredExceptions.Add(ExceptionClass);\r\n end;\r\nend;\r\n\r\nprocedure AddIgnoredExceptionByName(const AExceptionClassName: string);\r\nbegin\r\n if AExceptionClassName <> '' then\r\n begin\r\n if not Assigned(IgnoredExceptionClassNamesCritSect) then\r\n IgnoredExceptionClassNamesCritSect := TJclCriticalSection.Create;\r\n if not Assigned(IgnoredExceptionClassNames) then\r\n begin\r\n IgnoredExceptionClassNames := TStringList.Create;\r\n IgnoredExceptionClassNames.Duplicates := dupIgnore;\r\n IgnoredExceptionClassNames.Sorted := True;\r\n end;\r\n IgnoredExceptionClassNamesCritSect.Enter;\r\n try\r\n IgnoredExceptionClassNames.Add(AExceptionClassName);\r\n finally\r\n IgnoredExceptionClassNamesCritSect.Leave;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure RemoveIgnoredException(const ExceptionClass: TClass);\r\nvar\r\n ClassList: TList;\r\nbegin\r\n if Assigned(ExceptionClass) and Assigned(IgnoredExceptions) then\r\n begin\r\n ClassList := IgnoredExceptions.LockList;\r\n try\r\n ClassList.Remove(ExceptionClass);\r\n finally\r\n IgnoredExceptions.UnlockList;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure RemoveIgnoredExceptionByName(const AExceptionClassName: string);\r\nvar\r\n Index: Integer;\r\nbegin\r\n if Assigned(IgnoredExceptionClassNames) and (AExceptionClassName <> '') then\r\n begin\r\n IgnoredExceptionClassNamesCritSect.Enter;\r\n try\r\n Index := IgnoredExceptionClassNames.IndexOf(AExceptionClassName);\r\n if Index <> -1 then\r\n IgnoredExceptionClassNames.Delete(Index);\r\n finally\r\n IgnoredExceptionClassNamesCritSect.Leave;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction IsIgnoredException(const ExceptionClass: TClass): Boolean;\r\nvar\r\n ClassList: TList;\r\n Index: Integer;\r\nbegin\r\n Result := False;\r\n if Assigned(IgnoredExceptions) and not (stTraceAllExceptions in JclStackTrackingOptions) then\r\n begin\r\n ClassList := IgnoredExceptions.LockList;\r\n try\r\n for Index := 0 to ClassList.Count - 1 do\r\n if ExceptionClass.InheritsFrom(TClass(ClassList.Items[Index])) then\r\n begin\r\n Result := True;\r\n Break;\r\n end;\r\n finally\r\n IgnoredExceptions.UnlockList;\r\n end;\r\n end;\r\n if not Result and Assigned(IgnoredExceptionClassNames) and not (stTraceAllExceptions in JclStackTrackingOptions) then\r\n begin\r\n IgnoredExceptionClassNamesCritSect.Enter;\r\n try\r\n Result := IgnoredExceptionClassNames.IndexOf(ExceptionClass.ClassName) <> -1;\r\n if not Result then\r\n for Index := 0 to IgnoredExceptionClassNames.Count - 1 do\r\n if InheritsFromByName(ExceptionClass, IgnoredExceptionClassNames[Index]) then\r\n begin\r\n Result := True;\r\n Break;\r\n end;\r\n finally\r\n IgnoredExceptionClassNamesCritSect.Leave;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure AddModule(const ModuleName: string);\r\nbegin\r\n GlobalModulesList.AddModule(ModuleName);\r\nend;\r\n\r\nprocedure DoExceptNotify(ExceptObj: TObject; ExceptAddr: Pointer; OSException: Boolean;\r\n BaseOfStack: Pointer);\r\nbegin\r\n if (TrackingActiveCount > 0) and (not (stDisableIfDebuggerAttached in JclStackTrackingOptions) or (not IsDebuggerAttached)) and\r\n Assigned(ExceptObj) and (not IsIgnoredException(ExceptObj.ClassType)) and\r\n (not (stMainThreadOnly in JclStackTrackingOptions) or (GetCurrentThreadId = MainThreadID)) then\r\n begin\r\n if stStack in JclStackTrackingOptions then\r\n DoExceptionStackTrace(ExceptObj, ExceptAddr, OSException, BaseOfStack);\r\n if stExceptFrame in JclStackTrackingOptions then\r\n DoExceptFrameTrace;\r\n end;\r\nend;\r\n\r\nfunction JclStartExceptionTracking: Boolean;\r\nbegin\r\n {Increment the tracking count only if exceptions are already being tracked or tracking can be started\r\n successfully.}\r\n if TrackingActiveCount = 0 then\r\n begin\r\n if JclHookExceptions and JclAddExceptNotifier(DoExceptNotify, npFirstChain) then\r\n begin\r\n TrackingActiveCount := 1;\r\n Result := True;\r\n end\r\n else\r\n Result := False;\r\n end\r\n else\r\n begin\r\n Inc(TrackingActiveCount);\r\n Result := False;\r\n end;\r\nend;\r\n\r\nfunction JclStopExceptionTracking: Boolean;\r\nbegin\r\n {If the current tracking count is 1, an attempt is made to stop tracking exceptions. If successful the\r\n tracking count is set back to 0. If the current tracking count is > 1 it is simply decremented.}\r\n if TrackingActiveCount = 1 then\r\n begin\r\n Result := JclRemoveExceptNotifier(DoExceptNotify);\r\n if Result then\r\n Dec(TrackingActiveCount);\r\n end\r\n else\r\n begin\r\n if TrackingActiveCount > 0 then\r\n Dec(TrackingActiveCount);\r\n Result := False;\r\n end;\r\nend;\r\n\r\nfunction JclExceptionTrackingActive: Boolean;\r\nbegin\r\n Result := TrackingActiveCount > 0;\r\nend;\r\n\r\nfunction JclTrackExceptionsFromLibraries: Boolean;\r\nbegin\r\n Result := TrackingActiveCount > 0;\r\n if Result then\r\n JclInitializeLibrariesHookExcept;\r\nend;\r\n\r\n//=== Thread exception tracking support ======================================\r\n\r\nvar\r\n RegisteredThreadList: TJclDebugThreadList;\r\n\r\nfunction JclDebugThreadList: TJclDebugThreadList;\r\nbegin\r\n if RegisteredThreadList = nil then\r\n RegisteredThreadList := TJclDebugThreadList.Create;\r\n Result := RegisteredThreadList;\r\nend;\r\n\r\ntype\r\n TKernel32_CreateThread = function(SecurityAttributes: Pointer; StackSize: LongWord;\r\n ThreadFunc: TThreadFunc; Parameter: Pointer;\r\n CreationFlags: LongWord; var ThreadId: LongWord): Integer; stdcall;\r\n TKernel32_ExitThread = procedure(ExitCode: Integer); stdcall;\r\n\r\nvar\r\n ThreadsHooked: Boolean;\r\n Kernel32_CreateThread: TKernel32_CreateThread = nil;\r\n Kernel32_ExitThread: TKernel32_ExitThread = nil;\r\n\r\nfunction HookedCreateThread(SecurityAttributes: Pointer; StackSize: LongWord;\r\n ThreadFunc: TThreadFunc; Parameter: Pointer;\r\n CreationFlags: LongWord; var ThreadId: LongWord): Integer; stdcall;\r\nbegin\r\n Result := Kernel32_CreateThread(SecurityAttributes, StackSize, ThreadFunc, Parameter, CreationFlags, ThreadId);\r\n if Result <> 0 then\r\n JclDebugThreadList.RegisterThreadID(ThreadId);\r\nend;\r\n\r\nprocedure HookedExitThread(ExitCode: Integer); stdcall;\r\nbegin\r\n JclDebugThreadList.UnregisterThreadID(GetCurrentThreadID);\r\n Kernel32_ExitThread(ExitCode);\r\nend;\r\n\r\nfunction JclHookThreads: Boolean;\r\nvar\r\n ProcAddrCache: Pointer;\r\nbegin\r\n if not ThreadsHooked then\r\n begin\r\n ProcAddrCache := GetProcAddress(GetModuleHandle(kernel32), 'CreateThread');\r\n with TJclPeMapImgHooks do\r\n Result := ReplaceImport(SystemBase, kernel32, ProcAddrCache, @HookedCreateThread);\r\n if Result then\r\n begin\r\n @Kernel32_CreateThread := ProcAddrCache;\r\n\r\n ProcAddrCache := GetProcAddress(GetModuleHandle(kernel32), 'ExitThread');\r\n with TJclPeMapImgHooks do\r\n Result := ReplaceImport(SystemBase, kernel32, ProcAddrCache, @HookedExitThread);\r\n if Result then\r\n @Kernel32_ExitThread := ProcAddrCache\r\n else\r\n with TJclPeMapImgHooks do\r\n ReplaceImport(SystemBase, kernel32, @HookedCreateThread, @Kernel32_CreateThread);\r\n end;\r\n ThreadsHooked := Result;\r\n end\r\n else\r\n Result := True;\r\nend;\r\n\r\nfunction JclUnhookThreads: Boolean;\r\nbegin\r\n if ThreadsHooked then\r\n begin\r\n with TJclPeMapImgHooks do\r\n begin\r\n ReplaceImport(SystemBase, kernel32, @HookedCreateThread, @Kernel32_CreateThread);\r\n ReplaceImport(SystemBase, kernel32, @HookedExitThread, @Kernel32_ExitThread);\r\n end;\r\n Result := True;\r\n ThreadsHooked := False;\r\n end\r\n else\r\n Result := True;\r\nend;\r\n\r\nfunction JclThreadsHooked: Boolean;\r\nbegin\r\n Result := ThreadsHooked;\r\nend;\r\n\r\n//=== { TJclDebugThread } ====================================================\r\n\r\nconstructor TJclDebugThread.Create(ASuspended: Boolean; const AThreadName: string);\r\nbegin\r\n FThreadName := AThreadName;\r\n inherited Create(True);\r\n JclDebugThreadList.RegisterThread(Self, AThreadName);\r\n if not ASuspended then\r\n {$IFDEF RTL210_UP}\r\n Suspended := False;\r\n {$ELSE ~RTL210_UP}\r\n Resume;\r\n {$ENDIF ~RTL210_UP}\r\nend;\r\n\r\ndestructor TJclDebugThread.Destroy;\r\nbegin\r\n JclDebugThreadList.UnregisterThread(Self);\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJclDebugThread.DoHandleException;\r\nbegin\r\n GlobalStackList.LockThreadID(ThreadID);\r\n try\r\n DoSyncHandleException;\r\n finally\r\n GlobalStackList.UnlockThreadID;\r\n end;\r\nend;\r\n\r\nprocedure TJclDebugThread.DoNotify;\r\nbegin\r\n JclDebugThreadList.DoSyncException(Self);\r\nend;\r\n\r\nprocedure TJclDebugThread.DoSyncHandleException;\r\nbegin\r\n // Note: JclLastExceptStackList and JclLastExceptFrameList returns information\r\n // for this Thread ID instead of MainThread ID here to allow use a common\r\n // exception handling routine easily.\r\n // Any other call of those JclLastXXX routines from another thread at the same\r\n // time will return expected information for current Thread ID.\r\n DoNotify;\r\nend;\r\n\r\nfunction TJclDebugThread.GetThreadInfo: string;\r\nbegin\r\n Result := JclDebugThreadList.ThreadInfos[ThreadID];\r\nend;\r\n\r\nprocedure TJclDebugThread.HandleException(Sender: TObject);\r\nbegin\r\n FSyncException := Sender;\r\n try\r\n if not Assigned(FSyncException) then\r\n FSyncException := Exception(ExceptObject);\r\n if Assigned(FSyncException) and not IsIgnoredException(FSyncException.ClassType) then\r\n Synchronize(DoHandleException);\r\n finally\r\n FSyncException := nil;\r\n end;\r\nend;\r\n\r\n//=== { TJclDebugThreadList } ================================================\r\n\r\ntype\r\n TThreadAccess = class(TThread);\r\n\r\nconstructor TJclDebugThreadList.Create;\r\nbegin\r\n FLock := TJclCriticalSection.Create;\r\n FReadLock := TJclCriticalSection.Create;\r\n FList := TObjectList.Create;\r\n FSaveCreationStack := False;\r\nend;\r\n\r\ndestructor TJclDebugThreadList.Destroy;\r\nbegin\r\n FreeAndNil(FList);\r\n FreeAndNil(FLock);\r\n FreeAndNil(FReadLock);\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJclDebugThreadList.AddStackListToLocationInfoList(ThreadID: DWORD; AList: TJclLocationInfoList): Boolean;\r\nvar\r\n I: Integer;\r\n List: TJclStackInfoList;\r\nbegin\r\n Result := False;\r\n FReadLock.Enter;\r\n try\r\n I := IndexOfThreadID(ThreadID);\r\n if (I <> -1) and Assigned(TJclDebugThreadInfo(FList[I]).StackList) then\r\n begin\r\n List := TJclDebugThreadInfo(FList[I]).StackList;\r\n AList.AddStackInfoList(List);\r\n Result := True;\r\n end;\r\n finally\r\n FReadLock.Leave;\r\n end;\r\nend;\r\n\r\nprocedure TJclDebugThreadList.DoSyncException(Thread: TJclDebugThread);\r\nbegin\r\n if Assigned(FOnSyncException) then\r\n FOnSyncException(Thread);\r\nend;\r\n\r\nprocedure TJclDebugThreadList.DoSyncThreadRegistered;\r\nbegin\r\n if Assigned(FOnThreadRegistered) then\r\n FOnThreadRegistered(FRegSyncThreadID);\r\nend;\r\n\r\nprocedure TJclDebugThreadList.DoSyncThreadUnregistered;\r\nbegin\r\n if Assigned(FOnThreadUnregistered) then\r\n FOnThreadUnregistered(FUnregSyncThreadID);\r\nend;\r\n\r\nprocedure TJclDebugThreadList.DoThreadRegistered(Thread: TThread);\r\nbegin\r\n if Assigned(FOnThreadRegistered) then\r\n begin\r\n FRegSyncThreadID := Thread.ThreadID;\r\n TThreadAccess(Thread).Synchronize(DoSyncThreadRegistered);\r\n end;\r\nend;\r\n\r\nprocedure TJclDebugThreadList.DoThreadUnregistered(Thread: TThread);\r\nbegin\r\n if Assigned(FOnThreadUnregistered) then\r\n begin\r\n FUnregSyncThreadID := Thread.ThreadID;\r\n TThreadAccess(Thread).Synchronize(DoSyncThreadUnregistered);\r\n end;\r\nend;\r\n\r\nfunction TJclDebugThreadList.GetThreadClassNames(ThreadID: DWORD): string;\r\nbegin\r\n Result := GetThreadValues(ThreadID, 1);\r\nend;\r\n\r\nfunction TJclDebugThreadList.GetThreadCreationTime(ThreadID: DWORD): TDateTime;\r\nvar\r\n I: Integer;\r\nbegin\r\n FReadLock.Enter;\r\n try\r\n I := IndexOfThreadID(ThreadID);\r\n if I <> -1 then\r\n Result := TJclDebugThreadInfo(FList[I]).CreationTime\r\n else\r\n Result := 0;\r\n finally\r\n FReadLock.Leave;\r\n end;\r\nend;\r\n\r\nfunction TJclDebugThreadList.GetThreadIDCount: Integer;\r\nbegin\r\n FReadLock.Enter;\r\n try\r\n Result := FList.Count;\r\n finally\r\n FReadLock.Leave;\r\n end;\r\nend;\r\n\r\nfunction TJclDebugThreadList.GetThreadHandle(Index: Integer): THandle;\r\nbegin\r\n FReadLock.Enter;\r\n try\r\n Result := TJclDebugThreadInfo(FList[Index]).ThreadHandle;\r\n finally\r\n FReadLock.Leave;\r\n end;\r\nend;\r\n\r\nfunction TJclDebugThreadList.GetThreadID(Index: Integer): DWORD;\r\nbegin\r\n FReadLock.Enter;\r\n try\r\n Result := TJclDebugThreadInfo(FList[Index]).ThreadID;\r\n finally\r\n FReadLock.Leave;\r\n end;\r\nend;\r\n\r\nfunction TJclDebugThreadList.GetThreadInfos(ThreadID: DWORD): string;\r\nbegin\r\n Result := GetThreadValues(ThreadID, 2);\r\nend;\r\n\r\nfunction TJclDebugThreadList.GetThreadNames(ThreadID: DWORD): string;\r\nbegin\r\n Result := GetThreadValues(ThreadID, 0);\r\nend;\r\n\r\nfunction TJclDebugThreadList.GetThreadParentID(ThreadID: DWORD): DWORD;\r\nvar\r\n I: Integer;\r\nbegin\r\n FReadLock.Enter;\r\n try\r\n I := IndexOfThreadID(ThreadID);\r\n if I <> -1 then\r\n Result := TJclDebugThreadInfo(FList[I]).ParentThreadID\r\n else\r\n Result := 0;\r\n finally\r\n FReadLock.Leave;\r\n end;\r\nend;\r\n\r\nfunction TJclDebugThreadList.GetThreadValues(ThreadID: DWORD; Index: Integer): string;\r\nvar\r\n I: Integer;\r\nbegin\r\n FReadLock.Enter;\r\n try\r\n I := IndexOfThreadID(ThreadID);\r\n if I <> -1 then\r\n begin\r\n case Index of\r\n 0:\r\n Result := TJclDebugThreadInfo(FList[I]).ThreadName;\r\n 1:\r\n Result := TJclDebugThreadInfo(FList[I]).ThreadClassName;\r\n 2:\r\n Result := Format('%.8x [%s] \"%s\"', [ThreadID, TJclDebugThreadInfo(FList[I]).ThreadClassName,\r\n TJclDebugThreadInfo(FList[I]).ThreadName]);\r\n end;\r\n end\r\n else\r\n Result := '';\r\n finally\r\n FReadLock.Leave;\r\n end;\r\nend;\r\n\r\nfunction TJclDebugThreadList.IndexOfThreadID(ThreadID: DWORD): Integer;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := -1;\r\n for I := FList.Count - 1 downto 0 do\r\n if TJclDebugThreadInfo(FList[I]).ThreadID = ThreadID then\r\n begin\r\n Result := I;\r\n Break;\r\n end;\r\nend;\r\n\r\nprocedure TJclDebugThreadList.InternalRegisterThread(Thread: TThread; ThreadID: DWORD; const ThreadName: string);\r\nvar\r\n I: Integer;\r\n ThreadInfo: TJclDebugThreadInfo;\r\nbegin\r\n FLock.Enter;\r\n try\r\n I := IndexOfThreadID(ThreadID);\r\n if I = -1 then\r\n begin\r\n FReadLock.Enter;\r\n try\r\n FList.Add(TJclDebugThreadInfo.Create(GetCurrentThreadId, ThreadID, FSaveCreationStack));\r\n ThreadInfo := TJclDebugThreadInfo(FList.Last);\r\n if Assigned(Thread) then\r\n begin\r\n ThreadInfo.ThreadHandle := Thread.Handle;\r\n ThreadInfo.ThreadClassName := Thread.ClassName;\r\n end\r\n else\r\n begin\r\n ThreadInfo.ThreadHandle := 0;\r\n ThreadInfo.ThreadClassName := '';\r\n end;\r\n ThreadInfo.ThreadName := ThreadName;\r\n finally\r\n FReadLock.Leave;\r\n end;\r\n if Assigned(Thread) then\r\n DoThreadRegistered(Thread);\r\n end;\r\n finally\r\n FLock.Leave;\r\n end;\r\nend;\r\n\r\nprocedure TJclDebugThreadList.InternalUnregisterThread(Thread: TThread; ThreadID: DWORD);\r\nvar\r\n I: Integer;\r\nbegin\r\n FLock.Enter;\r\n try\r\n I := IndexOfThreadID(ThreadID);\r\n if I <> -1 then\r\n begin\r\n if Assigned(Thread) then\r\n DoThreadUnregistered(Thread);\r\n FReadLock.Enter;\r\n try\r\n FList.Delete(I);\r\n finally\r\n FReadLock.Leave;\r\n end;\r\n end;\r\n finally\r\n FLock.Leave;\r\n end;\r\nend;\r\n\r\nprocedure TJclDebugThreadList.RegisterThread(Thread: TThread; const ThreadName: string);\r\nbegin\r\n InternalRegisterThread(Thread, Thread.ThreadID, ThreadName);\r\nend;\r\n\r\nprocedure TJclDebugThreadList.RegisterThreadID(AThreadID: DWORD);\r\nbegin\r\n InternalRegisterThread(nil, AThreadID, '');\r\nend;\r\n\r\nprocedure TJclDebugThreadList.UnregisterThread(Thread: TThread);\r\nbegin\r\n InternalUnregisterThread(Thread, Thread.ThreadID);\r\nend;\r\n\r\nprocedure TJclDebugThreadList.UnregisterThreadID(AThreadID: DWORD);\r\nbegin\r\n InternalUnregisterThread(nil, AThreadID);\r\nend;\r\n\r\n//=== { TJclDebugThreadInfo } ================================================\r\n\r\nconstructor TJclDebugThreadInfo.Create(AParentThreadID, AThreadID: DWORD; AStack: Boolean);\r\nbegin\r\n FCreationTime := Now;\r\n FParentThreadID := AParentThreadID;\r\n try\r\n { TODO -oUSc : ... }\r\n// FStackList := JclCreateStackList(True, 0, nil, True);//probably IgnoreLevels = 11\r\n if AStack then\r\n FStackList := TJclStackInfoList.Create(True, 0, nil, True, nil, nil)\r\n else\r\n FStackList := nil;\r\n except\r\n FStackList := nil;\r\n end;\r\n FThreadID := AThreadID;\r\nend;\r\n\r\ndestructor TJclDebugThreadInfo.Destroy;\r\nbegin\r\n FStackList.Free;\r\n inherited Destroy;\r\nend;\r\n\r\n//=== { TJclCustomThreadInfo } ===============================================\r\n\r\nconstructor TJclCustomThreadInfo.Create;\r\nvar\r\n StackClass: TJclCustomLocationInfoListClass;\r\nbegin\r\n inherited Create;\r\n StackClass := GetStackClass;\r\n FCreationTime := 0;\r\n FCreationStack := StackClass.Create;\r\n FName := '';\r\n FParentThreadID := 0;\r\n FStack := StackClass.Create;\r\n FThreadID := 0;\r\n FValues := [];\r\nend;\r\n\r\ndestructor TJclCustomThreadInfo.Destroy;\r\nbegin\r\n FCreationStack.Free;\r\n FStack.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJclCustomThreadInfo.AssignTo(Dest: TPersistent);\r\nbegin\r\n if Dest is TJclCustomThreadInfo then\r\n begin\r\n TJclCustomThreadInfo(Dest).FCreationTime := FCreationTime;\r\n TJclCustomThreadInfo(Dest).FCreationStack.Assign(FCreationStack);\r\n TJclCustomThreadInfo(Dest).FName := FName;\r\n TJclCustomThreadInfo(Dest).FParentThreadID := FParentThreadID;\r\n TJclCustomThreadInfo(Dest).FStack.Assign(FStack);\r\n TJclCustomThreadInfo(Dest).FThreadID := FThreadID;\r\n TJclCustomThreadInfo(Dest).FValues := FValues;\r\n end\r\n else\r\n inherited AssignTo(Dest);\r\nend;\r\n\r\nfunction TJclCustomThreadInfo.GetStackClass: TJclCustomLocationInfoListClass;\r\nbegin\r\n Result := TJclLocationInfoList;\r\nend;\r\n\r\n//=== { TJclThreadInfo } =====================================================\r\n\r\nprocedure TJclThreadInfo.Fill(AThreadHandle: THandle; AThreadID: DWORD; AGatherOptions: TJclThreadInfoOptions);\r\nbegin\r\n InternalFill(AThreadHandle, AThreadID, AGatherOptions, False);\r\nend;\r\n\r\nprocedure TJclThreadInfo.FillFromExceptThread(AGatherOptions: TJclThreadInfoOptions);\r\nbegin\r\n InternalFill(0, GetCurrentThreadID, AGatherOptions, True);\r\nend;\r\n\r\nfunction TJclThreadInfo.GetAsString: string;\r\nvar\r\n ExceptInfo, ThreadName, ThreadInfoStr: string;\r\nbegin\r\n if tioIsMainThread in Values then\r\n ThreadName := ' [MainThread]'\r\n else\r\n if tioName in Values then\r\n ThreadName := Name\r\n else\r\n ThreadName := '';\r\n ThreadInfoStr := '';\r\n if tioCreationTime in Values then\r\n ThreadInfoStr := ThreadInfoStr + Format(' CreationTime: %s', [DateTimeToStr(CreationTime)]);\r\n if tioParentThreadID in Values then\r\n ThreadInfoStr := ThreadInfoStr + Format(' ParentThreadID: %d', [ParentThreadID]);\r\n ExceptInfo := Format('ThreadID: %d%s%s', [ThreadID, ThreadName, ThreadInfoStr]) + #13#10;\r\n if tioStack in Values then\r\n ExceptInfo := ExceptInfo + Stack.AsString;\r\n if tioCreationStack in Values then\r\n ExceptInfo := ExceptInfo + 'Created at:' + #13#10 + CreationStack.AsString + #13#10;\r\n Result := ExceptInfo + #13#10;\r\nend;\r\n\r\nfunction TJclThreadInfo.GetStack(const AIndex: Integer): TJclLocationInfoList;\r\nbegin\r\n case AIndex of\r\n 1: Result := TJclLocationInfoList(FCreationStack);\r\n 2: Result := TJclLocationInfoList(FStack);\r\n else\r\n Result := nil;\r\n end;\r\nend;\r\n\r\nfunction TJclThreadInfo.GetStackClass: TJclCustomLocationInfoListClass;\r\nbegin\r\n Result := TJclLocationInfoList;\r\nend;\r\n\r\nprocedure TJclThreadInfo.InternalFill(AThreadHandle: THandle; AThreadID: DWORD; AGatherOptions: TJclThreadInfoOptions; AExceptThread: Boolean);\r\nvar\r\n Idx: Integer;\r\n List: TJclStackInfoList;\r\nbegin\r\n if tioStack in AGatherOptions then\r\n begin\r\n if AExceptThread then\r\n List := JclLastExceptStackList\r\n else\r\n List := JclCreateThreadStackTrace(True, AThreadHandle);\r\n try\r\n Stack.AddStackInfoList(List);\r\n Values := Values + [tioStack];\r\n except\r\n { TODO -oUSc : ... }\r\n end;\r\n end;\r\n ThreadID := AThreadID;\r\n if tioIsMainThread in AGatherOptions then\r\n begin\r\n if MainThreadID = AThreadID then\r\n Values := Values + [tioIsMainThread];\r\n end;\r\n if AGatherOptions * [tioName, tioCreationTime, tioParentThreadID, tioCreationStack] <> [] then\r\n Idx := JclDebugThreadList.IndexOfThreadID(AThreadID)\r\n else\r\n Idx := -1;\r\n if (tioName in AGatherOptions) and (Idx <> -1) then\r\n begin\r\n Name := JclDebugThreadList.ThreadNames[AThreadID];\r\n Values := Values + [tioName];\r\n end;\r\n if (tioCreationTime in AGatherOptions) and (Idx <> -1) then\r\n begin\r\n CreationTime := JclDebugThreadList.ThreadCreationTime[AThreadID];\r\n Values := Values + [tioCreationTime];\r\n end;\r\n if (tioParentThreadID in AGatherOptions) and (Idx <> -1) then\r\n begin\r\n ParentThreadID := JclDebugThreadList.ThreadParentIDs[AThreadID];\r\n Values := Values + [tioParentThreadID];\r\n end;\r\n if (tioCreationStack in AGatherOptions) and (Idx <> -1) then\r\n begin\r\n try\r\n if JclDebugThreadList.AddStackListToLocationInfoList(AThreadID, CreationStack) then\r\n Values := Values + [tioCreationStack];\r\n except\r\n { TODO -oUSc : ... }\r\n end;\r\n end;\r\nend;\r\n\r\n//=== { TJclThreadInfoList } =================================================\r\n\r\nconstructor TJclThreadInfoList.Create;\r\nbegin\r\n inherited Create;\r\n FItems := TObjectList.Create;\r\n FGatherOptions := [tioIsMainThread, tioName, tioCreationTime, tioParentThreadID, tioStack, tioCreationStack];\r\nend;\r\n\r\ndestructor TJclThreadInfoList.Destroy;\r\nbegin\r\n FItems.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJclThreadInfoList.Add: TJclThreadInfo;\r\nbegin\r\n FItems.Add(TJclThreadInfo.Create);\r\n Result := TJclThreadInfo(FItems.Last);\r\nend;\r\n\r\nprocedure TJclThreadInfoList.AssignTo(Dest: TPersistent);\r\nvar\r\n I: Integer;\r\nbegin\r\n if Dest is TJclThreadInfoList then\r\n begin\r\n TJclThreadInfoList(Dest).Clear;\r\n for I := 0 to Count - 1 do\r\n TJclThreadInfoList(Dest).Add.Assign(Items[I]);\r\n TJclThreadInfoList(Dest).GatherOptions := FGatherOptions;\r\n end\r\n else\r\n inherited AssignTo(Dest);\r\nend;\r\n\r\nprocedure TJclThreadInfoList.Clear;\r\nbegin\r\n FItems.Clear;\r\nend;\r\n\r\nfunction TJclThreadInfoList.GetAsString: string;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := '';\r\n for I := 0 to Count - 1 do\r\n Result := Result + Items[I].AsString + #13#10;\r\nend;\r\n\r\nprocedure TJclThreadInfoList.Gather(AExceptThreadID: DWORD);\r\nbegin\r\n InternalGather([], [AExceptThreadID]);\r\nend;\r\n\r\nprocedure TJclThreadInfoList.GatherExclude(AThreadIDs: array of DWORD);\r\nbegin\r\n InternalGather([], AThreadIDs);\r\nend;\r\n\r\nprocedure TJclThreadInfoList.GatherInclude(AThreadIDs: array of DWORD);\r\nbegin\r\n InternalGather(AThreadIDs, []);\r\nend;\r\n\r\nfunction TJclThreadInfoList.GetCount: Integer;\r\nbegin\r\n Result := FItems.Count;\r\nend;\r\n\r\nfunction TJclThreadInfoList.GetItems(AIndex: Integer): TJclThreadInfo;\r\nbegin\r\n Result := TJclThreadInfo(FItems[AIndex]);\r\nend;\r\n\r\nprocedure TJclThreadInfoList.InternalGather(AIncludeThreadIDs, AExcludeThreadIDs: array of DWORD);\r\n\r\n function OpenThread(ThreadID: DWORD): THandle;\r\n type\r\n TOpenThreadFunc = function(DesiredAccess: DWORD; InheritHandle: BOOL; ThreadID: DWORD): THandle; stdcall;\r\n const\r\n THREAD_SUSPEND_RESUME = $0002;\r\n THREAD_GET_CONTEXT = $0008;\r\n THREAD_QUERY_INFORMATION = $0040;\r\n var\r\n Kernel32Lib: THandle;\r\n OpenThreadFunc: TOpenThreadFunc;\r\n begin\r\n Result := 0;\r\n Kernel32Lib := GetModuleHandle(kernel32);\r\n if Kernel32Lib <> 0 then\r\n begin\r\n // OpenThread only exists since Windows ME\r\n OpenThreadFunc := GetProcAddress(Kernel32Lib, 'OpenThread');\r\n if Assigned(OpenThreadFunc) then\r\n Result := OpenThreadFunc(THREAD_SUSPEND_RESUME or THREAD_GET_CONTEXT or THREAD_QUERY_INFORMATION, False, ThreadID);\r\n end;\r\n end;\r\n\r\n function SearchThreadInArray(AThreadIDs: array of DWORD; AThreadID: DWORD): Boolean;\r\n var\r\n I: Integer;\r\n begin\r\n Result := False;\r\n if Length(AThreadIDs) > 0 then\r\n for I := Low(AThreadIDs) to High(AThreadIDs) do\r\n if AThreadIDs[I] = AThreadID then\r\n begin\r\n Result := True;\r\n Break;\r\n end;\r\n end;\r\n\r\nvar\r\n SnapProcHandle: THandle;\r\n ThreadEntry: TThreadEntry32;\r\n NextThread: Boolean;\r\n ThreadIDList, ThreadHandleList: TList;\r\n I: Integer;\r\n PID, TID: DWORD;\r\n ThreadHandle: THandle;\r\n ThreadInfo: TJclThreadInfo;\r\nbegin\r\n ThreadIDList := TList.Create;\r\n ThreadHandleList := TList.Create;\r\n try\r\n SnapProcHandle := CreateToolhelp32Snapshot(TH32CS_SNAPTHREAD, 0);\r\n if SnapProcHandle <> INVALID_HANDLE_VALUE then\r\n try\r\n PID := GetCurrentProcessId;\r\n ThreadEntry.dwSize := SizeOf(ThreadEntry);\r\n NextThread := Thread32First(SnapProcHandle, ThreadEntry);\r\n while NextThread do\r\n begin\r\n if ThreadEntry.th32OwnerProcessID = PID then\r\n begin\r\n if SearchThreadInArray(AIncludeThreadIDs, ThreadEntry.th32ThreadID) or\r\n not SearchThreadInArray(AExcludeThreadIDs, ThreadEntry.th32ThreadID) then\r\n ThreadIDList.Add(Pointer(ThreadEntry.th32ThreadID));\r\n end;\r\n NextThread := Thread32Next(SnapProcHandle, ThreadEntry);\r\n end;\r\n finally\r\n CloseHandle(SnapProcHandle);\r\n end;\r\n for I := 0 to ThreadIDList.Count - 1 do\r\n begin\r\n ThreadHandle := OpenThread(TJclAddr(ThreadIDList[I]));\r\n ThreadHandleList.Add(Pointer(ThreadHandle));\r\n if ThreadHandle <> 0 then\r\n SuspendThread(ThreadHandle);\r\n end;\r\n try\r\n for I := 0 to ThreadIDList.Count - 1 do\r\n begin\r\n ThreadHandle := THandle(ThreadHandleList[I]);\r\n TID := TJclAddr(ThreadIDList[I]);\r\n\r\n ThreadInfo := Add;\r\n ThreadInfo.Fill(ThreadHandle, TID, FGatherOptions);\r\n end;\r\n finally\r\n for I := 0 to ThreadHandleList.Count - 1 do\r\n if ThreadHandleList[I] <> nil then\r\n begin\r\n ThreadHandle := THandle(ThreadHandleList[I]);\r\n ResumeThread(ThreadHandle);\r\n CloseHandle(ThreadHandle);\r\n end;\r\n end;\r\n finally\r\n ThreadIDList.Free;\r\n ThreadHandleList.Free;\r\n end;\r\nend;\r\n\r\n//== Miscellanuous ===========================================================\r\n\r\n{$IFDEF MSWINDOWS}\r\n\r\nfunction EnableCrashOnCtrlScroll(const Enable: Boolean): Boolean;\r\nconst\r\n CrashCtrlScrollKey = 'SYSTEM\\CurrentControlSet\\Services\\i8042prt\\Parameters';\r\n CrashCtrlScrollName = 'CrashOnCtrlScroll';\r\nvar\r\n Enabled: Integer;\r\nbegin\r\n Enabled := 0;\r\n if Enable then\r\n Enabled := 1;\r\n RegWriteInteger(HKEY_LOCAL_MACHINE, CrashCtrlScrollKey, CrashCtrlScrollName, Enabled);\r\n Result := RegReadInteger(HKEY_LOCAL_MACHINE, CrashCtrlScrollKey, CrashCtrlScrollName) = Enabled;\r\nend;\r\n\r\nfunction IsDebuggerAttached: Boolean;\r\nvar\r\n IsDebuggerPresent: function: Boolean; stdcall;\r\n KernelHandle: THandle;\r\n P: Pointer;\r\nbegin\r\n KernelHandle := GetModuleHandle(kernel32);\r\n @IsDebuggerPresent := GetProcAddress(KernelHandle, 'IsDebuggerPresent');\r\n if @IsDebuggerPresent <> nil then\r\n begin\r\n // Win98+ / NT4+\r\n Result := IsDebuggerPresent\r\n end\r\n else\r\n begin\r\n // Win9x uses thunk pointer outside the module when under a debugger\r\n P := GetProcAddress(KernelHandle, 'GetProcAddress');\r\n Result := TJclAddr(P) < KernelHandle;\r\n end;\r\nend;\r\n\r\nfunction IsHandleValid(Handle: THandle): Boolean;\r\nvar\r\n Duplicate: THandle;\r\n Flags: DWORD;\r\nbegin\r\n if IsWinNT then\r\n begin\r\n Flags := 0;\r\n Result := GetHandleInformation(Handle, Flags);\r\n end\r\n else\r\n Result := False;\r\n if not Result then\r\n begin\r\n // DuplicateHandle is used as an additional check for those object types not\r\n // supported by GetHandleInformation (e.g. according to the documentation,\r\n // GetHandleInformation doesn't support window stations and desktop although\r\n // tests show that it does). GetHandleInformation is tried first because its\r\n // much faster. Additionally GetHandleInformation is only supported on NT...\r\n Result := DuplicateHandle(GetCurrentProcess, Handle, GetCurrentProcess,\r\n @Duplicate, 0, False, DUPLICATE_SAME_ACCESS);\r\n if Result then\r\n Result := CloseHandle(Duplicate);\r\n end;\r\nend;\r\n\r\n{$ENDIF MSWINDOWS}\r\n\r\ninitialization\r\n DebugInfoCritSect := TJclCriticalSection.Create;\r\n GlobalModulesList := TJclGlobalModulesList.Create;\r\n GlobalStackList := TJclGlobalStackList.Create;\r\n AddIgnoredException(EAbort);\r\n {$IFDEF UNITVERSIONING}\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n {$ENDIF UNITVERSIONING}\r\n\r\nfinalization\r\n {$IFDEF UNITVERSIONING}\r\n UnregisterUnitVersion(HInstance);\r\n {$ENDIF UNITVERSIONING}\r\n\r\n { TODO -oPV -cInvestigate : Calling JclStopExceptionTracking causes linking of various classes to\r\n the code without a real need. Although there doesn't seem to be a way to unhook exceptions\r\n safely because we need to be covered by JclHookExcept.Notifiers critical section }\r\n JclStopExceptionTracking;\r\n\r\n FreeAndNil(RegisteredThreadList);\r\n FreeAndNil(DebugInfoList);\r\n FreeAndNil(GlobalStackList);\r\n FreeAndNil(GlobalModulesList);\r\n FreeAndNil(DebugInfoCritSect);\r\n FreeAndNil(InfoSourceClassList);\r\n FreeAndNil(IgnoredExceptions);\r\n FreeAndNil(IgnoredExceptionClassNames);\r\n FreeAndNil(IgnoredExceptionClassNamesCritSect);\r\n\r\n TJclDebugInfoSymbols.CleanupDebugSymbols;\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jcl/source/windows/JclDebugSerialization.pas", "content": "{**************************************************************************************************}\r\n{ }\r\n{ Project JEDI Code Library (JCL) }\r\n{ }\r\n{ The contents of this file are subject to the Mozilla Public License Version 1.1 (the \"License\"); }\r\n{ you may not use this file except in compliance with the License. You may obtain a copy of the }\r\n{ License at http://www.mozilla.org/MPL/ }\r\n{ }\r\n{ Software distributed under the License is distributed on an \"AS IS\" basis, WITHOUT WARRANTY OF }\r\n{ ANY KIND, either express or implied. See the License for the specific language governing rights }\r\n{ and limitations under the License. }\r\n{ }\r\n{ The Original Code is JclDebugSerialization.pas. }\r\n{ }\r\n{ The Initial Developer of the Original Code is Uwe Schuster. }\r\n{ Portions created by Uwe Schuster are Copyright (C) 2009 Uwe Schuster. All rights reserved. }\r\n{ }\r\n{ Contributor(s): }\r\n{ Uwe Schuster (uschuster) }\r\n{ }\r\n{**************************************************************************************************}\r\n{ }\r\n{ Last modified: $Date:: 2011-09-03 00:07:50 +0200 (sam. 03 sept. 2011) $ }\r\n{ Revision: $Rev:: 3599 $ }\r\n{ Author: $Author:: outchy $ }\r\n{ }\r\n{**************************************************************************************************}\r\n\r\nunit JclDebugSerialization;\r\n\r\n{$I jcl.inc}\r\n{$I windowsonly.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF HAS_UNITSCOPE}\r\n System.SysUtils, System.Classes, System.Contnrs,\r\n {$ELSE ~HAS_UNITSCOPE}\r\n SysUtils, Classes, Contnrs,\r\n {$ENDIF ~HAS_UNITSCOPE}\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n JclDebug;\r\n\r\ntype\r\n TJclCustomSimpleSerializer = class(TObject)\r\n protected\r\n FItems: TObjectList;\r\n FName: string;\r\n FValues: TStringList;\r\n function GetCount: Integer;\r\n function GetItems(AIndex: Integer): TJclCustomSimpleSerializer;\r\n public\r\n constructor Create(const AName: string);\r\n destructor Destroy; override;\r\n function AddChild(ASender: TObject; const AName: string): TJclCustomSimpleSerializer;\r\n procedure Clear;\r\n function ReadString(ASender: TObject; const AName: string): string;\r\n procedure WriteString(ASender: TObject; const AName: string; const AValue: string);\r\n property Count: Integer read GetCount;\r\n property Items[AIndex: Integer]: TJclCustomSimpleSerializer read GetItems; default;\r\n property Name: string read FName;\r\n property Values: TStringList read FValues;\r\n end;\r\n\r\n TJclSerializableLocationInfo = class(TJclLocationInfoEx)\r\n public\r\n procedure Deserialize(ASerializer: TJclCustomSimpleSerializer);\r\n procedure Serialize(ASerializer: TJclCustomSimpleSerializer);\r\n end;\r\n\r\n TJclSerializableLocationInfoList = class(TJclCustomLocationInfoList)\r\n private\r\n function GetItems(AIndex: Integer): TJclSerializableLocationInfo;\r\n public\r\n constructor Create; override;\r\n function Add(Addr: Pointer): TJclSerializableLocationInfo;\r\n procedure Deserialize(ASerializer: TJclCustomSimpleSerializer);\r\n procedure Serialize(ASerializer: TJclCustomSimpleSerializer);\r\n property Items[AIndex: Integer]: TJclSerializableLocationInfo read GetItems; default;\r\n end;\r\n\r\n TJclSerializableThreadInfo = class(TJclCustomThreadInfo)\r\n private\r\n function GetStack(const AIndex: Integer): TJclSerializableLocationInfoList;\r\n protected\r\n function GetStackClass: TJclCustomLocationInfoListClass; override;\r\n public\r\n constructor Create;\r\n destructor Destroy; override;\r\n procedure Deserialize(ASerializer: TJclCustomSimpleSerializer);\r\n procedure Serialize(ASerializer: TJclCustomSimpleSerializer);\r\n property CreationStack: TJclSerializableLocationInfoList index 1 read GetStack;\r\n property Stack: TJclSerializableLocationInfoList index 2 read GetStack;\r\n end;\r\n\r\n TJclSerializableThreadInfoList = class(TPersistent)\r\n private\r\n FItems: TObjectList;\r\n function GetItems(AIndex: Integer): TJclSerializableThreadInfo;\r\n function GetCount: Integer;\r\n public\r\n constructor Create;\r\n destructor Destroy; override;\r\n function Add: TJclSerializableThreadInfo;\r\n procedure Assign(Source: TPersistent); override;\r\n procedure Clear;\r\n procedure Deserialize(ASerializer: TJclCustomSimpleSerializer);\r\n procedure Serialize(ASerializer: TJclCustomSimpleSerializer);\r\n property Count: Integer read GetCount;\r\n property Items[AIndex: Integer]: TJclSerializableThreadInfo read GetItems; default;\r\n end;\r\n\r\n TJclSerializableException = class(TPersistent)\r\n private\r\n FExceptionClassName: string;\r\n FExceptionMessage: string;\r\n protected\r\n procedure AssignTo(Dest: TPersistent); override;\r\n public\r\n procedure Clear;\r\n procedure Deserialize(ASerializer: TJclCustomSimpleSerializer);\r\n procedure Serialize(ASerializer: TJclCustomSimpleSerializer);\r\n property ExceptionClassName: string read FExceptionClassName write FExceptionClassName;\r\n property ExceptionMessage: string read FExceptionMessage write FExceptionMessage;\r\n end;\r\n\r\n TJclSerializableModuleInfo = class(TPersistent)\r\n private\r\n FStartStr: string;\r\n FEndStr: string;\r\n FSystemModuleStr: string;\r\n FModuleName: string;\r\n FBinFileVersion: string;\r\n FFileVersion: string;\r\n FFileDescription: string;\r\n protected\r\n procedure AssignTo(Dest: TPersistent); override;\r\n public\r\n procedure Deserialize(ASerializer: TJclCustomSimpleSerializer);\r\n procedure Serialize(ASerializer: TJclCustomSimpleSerializer);\r\n property StartStr: string read FStartStr write FStartStr;\r\n property EndStr: string read FEndStr write FEndStr;\r\n property SystemModuleStr: string read FSystemModuleStr write FSystemModuleStr;\r\n property ModuleName: string read FModuleName write FModuleName;\r\n property BinFileVersion: string read FBinFileVersion write FBinFileVersion;\r\n property FileVersion: string read FFileVersion write FFileVersion;\r\n property FileDescription: string read FFileDescription write FFileDescription;\r\n end;\r\n\r\n TJclSerializableModuleInfoList = class(TPersistent)\r\n private\r\n FItems: TObjectList;\r\n function GetCount: Integer;\r\n function GetItems(AIndex: Integer): TJclSerializableModuleInfo;\r\n protected\r\n procedure AssignTo(Dest: TPersistent); override;\r\n public\r\n constructor Create;\r\n destructor Destroy; override;\r\n function Add: TJclSerializableModuleInfo;\r\n procedure Clear;\r\n procedure Deserialize(ASerializer: TJclCustomSimpleSerializer);\r\n procedure Serialize(ASerializer: TJclCustomSimpleSerializer);\r\n property Count: Integer read GetCount;\r\n property Items[AIndex: Integer]: TJclSerializableModuleInfo read GetItems; default;\r\n end;\r\n\r\n TJclSerializableExceptionInfo = class(TObject)\r\n private\r\n FException: TJclSerializableException;\r\n FThreadInfoList: TJclSerializableThreadInfoList;\r\n FModules: TJclSerializableModuleInfoList;\r\n public\r\n constructor Create;\r\n destructor Destroy; override;\r\n procedure Deserialize(ASerializer: TJclCustomSimpleSerializer);\r\n procedure Serialize(ASerializer: TJclCustomSimpleSerializer);\r\n property ThreadInfoList: TJclSerializableThreadInfoList read FThreadInfoList;\r\n property Exception: TJclSerializableException read FException;\r\n property Modules: TJclSerializableModuleInfoList read FModules;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jcl.svn.sourceforge.net/svnroot/jcl/tags/JCL-2.4-Build4571/jcl/source/windows/JclDebugSerialization.pas $';\r\n Revision: '$Revision: 3599 $';\r\n Date: '$Date: 2011-09-03 00:07:50 +0200 (sam. 03 sept. 2011) $';\r\n LogPath: 'JCL\\source\\windows';\r\n Extra: '';\r\n Data: nil\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n JclDateTime;\r\n\r\nconst\r\n MinutesPerDay = 60 * 24;\r\n\r\n{ TODO -oUSc : move to JclDateTime }\r\nfunction ISOFormatStrToDateTime(const AISOFormatTimeStampStr: string; ADefault: TDateTime): TDateTime;\r\nvar\r\n Year, Month, Day, Hour, Minute, Second: Word;\r\nbegin\r\n Result := ADefault;\r\n { TODO -oUSc : make it more generics to accept for exam. milliseconds }\r\n if (Length(AISOFormatTimeStampStr) = 25) or ((Length(AISOFormatTimeStampStr) = 20) and\r\n (AISOFormatTimeStampStr[20] = 'Z')) then\r\n begin\r\n if (AISOFormatTimeStampStr[5] = '-') and (AISOFormatTimeStampStr[8] = '-') and\r\n (AISOFormatTimeStampStr[11] = 'T') and (AISOFormatTimeStampStr[14] = ':') and\r\n (AISOFormatTimeStampStr[17] = ':') then\r\n begin\r\n Year := StrToInt(Copy(AISOFormatTimeStampStr, 1, 4));\r\n Month := StrToInt(Copy(AISOFormatTimeStampStr, 6, 2));\r\n Day := StrToInt(Copy(AISOFormatTimeStampStr, 9, 2));\r\n Hour := StrToInt(Copy(AISOFormatTimeStampStr, 12, 2));\r\n Minute := StrToInt(Copy(AISOFormatTimeStampStr, 15, 2));\r\n Second := StrToInt(Copy(AISOFormatTimeStampStr, 18, 2));\r\n Result := EncodeDate(Year, Month, Day) + EncodeTime(Hour, Minute, Second, 0);\r\n end;\r\n end;\r\nend;\r\n\r\nfunction ISOFormatStrToLocalDateTime(const AISOFormatTimeStampStr: string; ADefault: TDateTime): TDateTime;\r\nbegin\r\n Result := ISOFormatStrToDateTime(AISOFormatTimeStampStr, ADefault);\r\n Result := DateTimeToLocalDateTime(Result);\r\nend;\r\n\r\nfunction DateTimeToISOFormatStr(ATimeStamp: TDateTime; ABias: Longint): string;\r\nvar\r\n TimeZoneAsDateTime: TDateTime;\r\n S: string;\r\nbegin\r\n Result := FormatDateTime('yyyy-mm-dd\"T\"hh:nn:ss', ATimeStamp);\r\n TimeZoneAsDateTime := ABias / MinutesPerDay;\r\n S := FormatDateTime('hh:nn', Abs(TimeZoneAsDateTime));\r\n if ABias > 0 then\r\n Result := Result + '+' + S\r\n else\r\n if ABias = 0 then\r\n Result := Result + 'Z'\r\n else\r\n Result := Result + '-' + S;\r\nend;\r\n\r\nfunction LocalDateTimeToISOFormatStr(ATimeStamp: TDateTime): string;\r\nvar\r\n UTCTimeStamp, TimeZoneAsDateTime: TDateTime;\r\nbegin\r\n UTCTimeStamp := LocalDateTimeToDateTime(ATimeStamp);\r\n TimeZoneAsDateTime := ATimeStamp - UTCTimeStamp;\r\n Result := DateTimeToISOFormatStr(UTCTimeStamp, Round(TimeZoneAsDateTime * MinutesPerDay));\r\nend;\r\n\r\n//=== { TJclCustomSimpleSerializer } =========================================\r\n\r\nconstructor TJclCustomSimpleSerializer.Create(const AName: string);\r\nbegin\r\n inherited Create;\r\n FItems := TObjectList.Create;\r\n FName := AName;\r\n FValues := TStringList.Create;\r\nend;\r\n\r\ndestructor TJclCustomSimpleSerializer.Destroy;\r\nbegin\r\n FValues.Free;\r\n FItems.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJclCustomSimpleSerializer.AddChild(ASender: TObject; const AName: string): TJclCustomSimpleSerializer;\r\nbegin\r\n FItems.Add(TJclCustomSimpleSerializer.Create(AName));\r\n Result := TJclCustomSimpleSerializer(FItems.Last);\r\nend;\r\n\r\nprocedure TJclCustomSimpleSerializer.Clear;\r\nbegin\r\n FItems.Clear;\r\n FValues.Clear;\r\n FName := '';\r\nend;\r\n\r\nfunction TJclCustomSimpleSerializer.GetCount: Integer;\r\nbegin\r\n Result := FItems.Count;\r\nend;\r\n\r\nfunction TJclCustomSimpleSerializer.GetItems(AIndex: Integer): TJclCustomSimpleSerializer;\r\nbegin\r\n Result := TJclCustomSimpleSerializer(FItems[AIndex]);\r\nend;\r\n\r\nfunction TJclCustomSimpleSerializer.ReadString(ASender: TObject; const AName: string): string;\r\nbegin\r\n Result := FValues.Values[AName];\r\nend;\r\n\r\nprocedure TJclCustomSimpleSerializer.WriteString(ASender: TObject; const AName: string; const AValue: string);\r\nbegin\r\n FValues.Add(Format('%s=%s', [AName, AValue]));\r\nend;\r\n\r\n//=== { TJclSerializableThreadInfoList } =====================================\r\n\r\nconstructor TJclSerializableThreadInfoList.Create;\r\nbegin\r\n inherited Create;\r\n FItems := TObjectList.Create;\r\nend;\r\n\r\ndestructor TJclSerializableThreadInfoList.Destroy;\r\nbegin\r\n FItems.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJclSerializableThreadInfoList.Add: TJclSerializableThreadInfo;\r\nbegin\r\n FItems.Add(TJclSerializableThreadInfo.Create);\r\n Result := TJclSerializableThreadInfo(FItems.Last);\r\nend;\r\n\r\nprocedure TJclSerializableThreadInfoList.Assign(Source: TPersistent);\r\nvar\r\n I: Integer;\r\nbegin\r\n if Source is TJclThreadInfoList then\r\n begin\r\n Clear;\r\n for I := 0 to TJclThreadInfoList(Source).Count - 1 do\r\n Add.Assign(TJclThreadInfoList(Source)[I]);\r\n end\r\n else\r\n inherited Assign(Source);\r\nend;\r\n\r\nprocedure TJclSerializableThreadInfoList.Clear;\r\nbegin\r\n FItems.Clear;\r\nend;\r\n\r\nfunction TJclSerializableThreadInfoList.GetCount: Integer;\r\nbegin\r\n Result := FItems.Count;\r\nend;\r\n\r\nfunction TJclSerializableThreadInfoList.GetItems(AIndex: Integer): TJclSerializableThreadInfo;\r\nbegin\r\n Result := TJclSerializableThreadInfo(FItems[AIndex]);\r\nend;\r\n\r\nprocedure TJclSerializableThreadInfoList.Deserialize(ASerializer: TJclCustomSimpleSerializer);\r\nvar\r\n I: Integer;\r\nbegin\r\n Clear;\r\n for I := 0 to ASerializer.Count - 1 do\r\n if ASerializer[I].Name = 'ThreadInfo' then\r\n Add.Deserialize(ASerializer[I]);\r\nend;\r\n\r\nprocedure TJclSerializableThreadInfoList.Serialize(ASerializer: TJclCustomSimpleSerializer);\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := 0 to Count - 1 do\r\n Items[I].Serialize(ASerializer.AddChild(Self, 'ThreadInfo'));\r\nend;\r\n\r\n//=== { TJclSerializableLocationInfo } =======================================\r\n\r\nprocedure TJclSerializableLocationInfo.Deserialize(ASerializer: TJclCustomSimpleSerializer);\r\nvar\r\n S, SOffsetFromProcName, SLineNumberOffsetFromProcedureStart: string;\r\nbegin\r\n Values := [];\r\n SOffsetFromProcName := ASerializer.ReadString(Self, 'OffsetFromProcName');\r\n if SOffsetFromProcName <> '' then\r\n Values := Values + [lievLocationInfo];\r\n SLineNumberOffsetFromProcedureStart := ASerializer.ReadString(Self, 'LineNumberOffsetFromProcedureStart');\r\n if SLineNumberOffsetFromProcedureStart <> '' then\r\n Values := Values + [lievProcedureStartLocationInfo];\r\n S := ASerializer.ReadString(Self, 'VAddress');\r\n VAddress := Pointer(StrToIntDef('$' + S, 0));\r\n ModuleName := ASerializer.ReadString(Self, 'ModuleName');\r\n S := ASerializer.ReadString(Self, 'Address');\r\n Address := Pointer(StrToIntDef('$' + S, 0));\r\n OffsetFromProcName := StrToIntDef('$' + SOffsetFromProcName, 0);\r\n SourceUnitName := ASerializer.ReadString(Self, 'UnitName');\r\n ProcedureName := ASerializer.ReadString(Self, 'ProcedureName');\r\n SourceName := ASerializer.ReadString(Self, 'SourceName');\r\n S := ASerializer.ReadString(Self, 'LineNumber');\r\n LineNumber := StrToIntDef(S, -1);\r\n S := ASerializer.ReadString(Self, 'OffsetFromLineNumber');\r\n OffsetFromLineNumber := StrToIntDef(S, -1);\r\n LineNumberOffsetFromProcedureStart := StrToIntDef(SLineNumberOffsetFromProcedureStart, -1);\r\n UnitVersionDateTime := ISOFormatStrToDateTime(ASerializer.ReadString(Self, 'UnitVersionDateTime'), 0);\r\n UnitVersionExtra := ASerializer.ReadString(Self, 'UnitVersionExtra');\r\n UnitVersionLogPath := ASerializer.ReadString(Self, 'UnitVersionLogPath');\r\n UnitVersionRCSfile := ASerializer.ReadString(Self, 'UnitVersionRCSfile');\r\n UnitVersionRevision := ASerializer.ReadString(Self, 'UnitVersionRevision');\r\nend;\r\n\r\nprocedure TJclSerializableLocationInfo.Serialize(ASerializer: TJclCustomSimpleSerializer);\r\nvar\r\n S: string;\r\nbegin\r\n S := '';\r\n ASerializer.WriteString(Self, 'VAddress', Format('%p', [VAddress]));\r\n ASerializer.WriteString(Self, 'ModuleName', ModuleName);\r\n ASerializer.WriteString(Self, 'Address', Format('%p', [Address]));\r\n if lievLocationInfo in Values then\r\n begin\r\n ASerializer.WriteString(Self, 'OffsetFromProcName', Format('+ $%x', [OffsetFromProcName]));\r\n ASerializer.WriteString(Self, 'UnitName', SourceUnitName);\r\n ASerializer.WriteString(Self, 'ProcedureName', ProcedureName);\r\n ASerializer.WriteString(Self, 'SourceName', SourceName);\r\n if LineNumber > 0 then\r\n begin\r\n ASerializer.WriteString(Self, 'LineNumber', IntToStr(LineNumber));\r\n if OffsetFromLineNumber >= 0 then\r\n S := S + Format('+ $%x', [OffsetFromLineNumber])\r\n else\r\n S := S + Format('- $%x', [-OffsetFromLineNumber]);\r\n ASerializer.WriteString(Self, 'OffsetFromLineNumber', S);\r\n end;\r\n if lievProcedureStartLocationInfo in Values then\r\n ASerializer.WriteString(Self, 'LineNumberOffsetFromProcedureStart', IntToStr(LineNumberOffsetFromProcedureStart));\r\n end;\r\n if lievUnitVersionInfo in Values then\r\n begin\r\n ASerializer.WriteString(Self, 'UnitVersionDateTime', DateTimeToISOFormatStr(UnitVersionDateTime, 0));\r\n ASerializer.WriteString(Self, 'UnitVersionExtra', UnitVersionExtra);\r\n ASerializer.WriteString(Self, 'UnitVersionLogPath', UnitVersionLogPath);\r\n ASerializer.WriteString(Self, 'UnitVersionRCSfile', UnitVersionRCSfile);\r\n ASerializer.WriteString(Self, 'UnitVersionRevision', UnitVersionRevision);\r\n end;\r\nend;\r\n\r\n//=== { TJclSerializableLocationInfoList } ===================================\r\n\r\nfunction TJclSerializableLocationInfoList.Add(Addr: Pointer): TJclSerializableLocationInfo;\r\nbegin\r\n Result := TJclSerializableLocationInfo(InternalAdd(Addr));\r\nend;\r\n\r\nconstructor TJclSerializableLocationInfoList.Create;\r\nbegin\r\n inherited Create;\r\n FItemClass := TJclSerializableLocationInfo;\r\n FOptions := [];\r\nend;\r\n\r\nfunction TJclSerializableLocationInfoList.GetItems(AIndex: Integer): TJclSerializableLocationInfo;\r\nbegin\r\n Result := TJclSerializableLocationInfo(FItems[AIndex]);\r\nend;\r\n\r\nprocedure TJclSerializableLocationInfoList.Deserialize(ASerializer: TJclCustomSimpleSerializer);\r\nvar\r\n I: Integer;\r\nbegin\r\n Clear;\r\n for I := 0 to ASerializer.Count - 1 do\r\n if ASerializer[I].Name = 'LocationInfo' then\r\n Add(nil).Deserialize(ASerializer[I]);\r\nend;\r\n\r\nprocedure TJclSerializableLocationInfoList.Serialize(ASerializer: TJclCustomSimpleSerializer);\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := 0 to Count - 1 do\r\n Items[I].Serialize(ASerializer.AddChild(Self, 'LocationInfo'));\r\nend;\r\n\r\n//=== { TJclSerializableThreadInfo } =========================================\r\n\r\nconstructor TJclSerializableThreadInfo.Create;\r\nbegin\r\n inherited Create;\r\nend;\r\n\r\ndestructor TJclSerializableThreadInfo.Destroy;\r\nbegin\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJclSerializableThreadInfo.GetStack(const AIndex: Integer): TJclSerializableLocationInfoList;\r\nbegin\r\n case AIndex of\r\n 1: Result := TJclSerializableLocationInfoList(FCreationStack);\r\n 2: Result := TJclSerializableLocationInfoList(FStack);\r\n else\r\n Result := nil;\r\n end;\r\nend;\r\n\r\nfunction TJclSerializableThreadInfo.GetStackClass: TJclCustomLocationInfoListClass;\r\nbegin\r\n Result := TJclSerializableLocationInfoList;\r\nend;\r\n\r\nprocedure TJclSerializableThreadInfo.Deserialize(ASerializer: TJclCustomSimpleSerializer);\r\nvar\r\n S: string;\r\n I: Integer;\r\nbegin\r\n Values := [];\r\n S := ASerializer.ReadString(Self, 'ThreadID');\r\n ThreadID := StrToIntDef(S, 0);\r\n if ASerializer.ReadString(Self, 'MainThread') = '1' then\r\n Values := Values + [tioIsMainThread];\r\n S := ASerializer.ReadString(Self, 'Name');\r\n if S <> '' then\r\n begin\r\n Name := S;\r\n Values := Values + [tioName];\r\n end;\r\n S := ASerializer.ReadString(Self, 'CreationTime');\r\n if S <> '' then\r\n begin\r\n CreationTime := ISOFormatStrToLocalDateTime(S, 0);\r\n if CreationTime > 0 then\r\n Values := Values + [tioCreationTime];\r\n end;\r\n S := ASerializer.ReadString(Self, 'ParentThreadID');\r\n if S <> '' then\r\n begin\r\n ParentThreadID := StrToIntDef(S, 0);\r\n if ParentThreadID <> 0 then\r\n Values := Values + [tioParentThreadID];\r\n end;\r\n for I := 0 to ASerializer.Count - 1 do\r\n if ASerializer[I].Name = 'Stack' then\r\n begin\r\n Stack.Deserialize(ASerializer[I]);\r\n Values := Values + [tioStack];\r\n end\r\n else\r\n if ASerializer[I].Name = 'CreationStack' then\r\n begin\r\n CreationStack.Deserialize(ASerializer[I]);\r\n Values := Values + [tioCreationStack];\r\n end;\r\nend;\r\n\r\nprocedure TJclSerializableThreadInfo.Serialize(ASerializer: TJclCustomSimpleSerializer);\r\nbegin\r\n ASerializer.WriteString(Self, 'ThreadID', IntToStr(ThreadID));\r\n if tioIsMainThread in Values then\r\n ASerializer.WriteString(Self, 'MainThread', '1');\r\n if tioName in Values then\r\n ASerializer.WriteString(Self, 'Name', Name);\r\n if tioCreationTime in Values then\r\n ASerializer.WriteString(Self, 'CreationTime', LocalDateTimeToISOFormatStr(CreationTime));\r\n if tioParentThreadID in Values then\r\n ASerializer.WriteString(Self, 'ParentThreadID', IntToStr(ParentThreadID));\r\n if tioStack in Values then\r\n Stack.Serialize(ASerializer.AddChild(Self, 'Stack'));\r\n if tioCreationStack in Values then\r\n CreationStack.Serialize(ASerializer.AddChild(Self, 'CreationStack'));\r\nend;\r\n\r\n//=== { TExceptionInfo } =====================================================\r\n\r\nconstructor TJclSerializableExceptionInfo.Create;\r\nbegin\r\n inherited Create;\r\n FException := TJclSerializableException.Create;\r\n FThreadInfoList := TJclSerializableThreadInfoList.Create;\r\n FModules := TJclSerializableModuleInfoList.Create;\r\nend;\r\n\r\ndestructor TJclSerializableExceptionInfo.Destroy;\r\nbegin\r\n FModules.Free;\r\n FException.Free;\r\n FThreadInfoList.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJclSerializableExceptionInfo.Deserialize(ASerializer: TJclCustomSimpleSerializer);\r\nvar\r\n I: Integer;\r\nbegin\r\n FThreadInfoList.Clear;\r\n FException.Clear;\r\n FModules.Clear;\r\n for I := 0 to ASerializer.Count - 1 do\r\n if ASerializer[I].Name = 'ThreadInfo' then\r\n FThreadInfoList.Deserialize(ASerializer[I])\r\n else\r\n if ASerializer[I].Name = 'Exception' then\r\n FException.Deserialize(ASerializer[I])\r\n else\r\n if ASerializer[I].Name = 'Modules' then\r\n FModules.Deserialize(ASerializer[I]);\r\nend;\r\n\r\nprocedure TJclSerializableExceptionInfo.Serialize(ASerializer: TJclCustomSimpleSerializer);\r\nbegin\r\n FThreadInfoList.Serialize(ASerializer.AddChild(Self, 'ThreadInfo'));\r\n FException.Serialize(ASerializer.AddChild(Self, 'Exception'));\r\n FModules.Serialize(ASerializer.AddChild(Self, 'Modules'));\r\nend;\r\n\r\n//=== { TException } =========================================================\r\n\r\nprocedure TJclSerializableException.AssignTo(Dest: TPersistent);\r\nbegin\r\n if Dest is TJclSerializableException then\r\n begin\r\n TJclSerializableException(Dest).FExceptionClassName := FExceptionClassName;\r\n TJclSerializableException(Dest).FExceptionMessage := FExceptionMessage;\r\n end\r\n else\r\n inherited AssignTo(Dest);\r\nend;\r\n\r\nprocedure TJclSerializableException.Clear;\r\nbegin\r\n FExceptionClassName := '';\r\n FExceptionMessage := '';\r\nend;\r\n\r\nprocedure TJclSerializableException.Deserialize(ASerializer: TJclCustomSimpleSerializer);\r\nbegin\r\n Clear;\r\n FExceptionClassName := ASerializer.ReadString(Self, 'ClassName');\r\n FExceptionMessage := ASerializer.ReadString(Self, 'Message');\r\nend;\r\n\r\nprocedure TJclSerializableException.Serialize(ASerializer: TJclCustomSimpleSerializer);\r\nbegin\r\n ASerializer.WriteString(Self, 'ClassName', FExceptionClassName);\r\n ASerializer.WriteString(Self, 'Message', FExceptionMessage);\r\nend;\r\n\r\n//=== { TModule } ============================================================\r\n\r\nprocedure TJclSerializableModuleInfo.AssignTo(Dest: TPersistent);\r\nbegin\r\n if Dest is TJclSerializableModuleInfo then\r\n begin\r\n TJclSerializableModuleInfo(Dest).FStartStr := FStartStr;\r\n TJclSerializableModuleInfo(Dest).FEndStr := FEndStr;\r\n TJclSerializableModuleInfo(Dest).FSystemModuleStr := FSystemModuleStr;\r\n TJclSerializableModuleInfo(Dest).FModuleName := FModuleName;\r\n TJclSerializableModuleInfo(Dest).FBinFileVersion := FBinFileVersion;\r\n TJclSerializableModuleInfo(Dest).FFileVersion := FFileVersion;\r\n TJclSerializableModuleInfo(Dest).FFileDescription := FFileDescription;\r\n end\r\n else\r\n inherited AssignTo(Dest);\r\nend;\r\n\r\nprocedure TJclSerializableModuleInfo.Deserialize(ASerializer: TJclCustomSimpleSerializer);\r\nbegin\r\n FStartStr := ASerializer.ReadString(Self, 'StartAddr');\r\n FEndStr := ASerializer.ReadString(Self, 'EndAddr');\r\n FSystemModuleStr := ASerializer.ReadString(Self, 'SystemModule');\r\n FModuleName := ASerializer.ReadString(Self, 'FileName');\r\n FBinFileVersion := ASerializer.ReadString(Self, 'BinFileVersion');\r\n FFileVersion := ASerializer.ReadString(Self, 'FileVersion');\r\n FFileDescription := ASerializer.ReadString(Self, 'FileDescription');\r\nend;\r\n\r\nprocedure TJclSerializableModuleInfo.Serialize(ASerializer: TJclCustomSimpleSerializer);\r\nbegin\r\n ASerializer.WriteString(Self, 'StartAddr', FStartStr);\r\n ASerializer.WriteString(Self, 'EndAddr', FEndStr);\r\n ASerializer.WriteString(Self, 'SystemModule', FSystemModuleStr);\r\n ASerializer.WriteString(Self, 'FileName', FModuleName);\r\n ASerializer.WriteString(Self, 'BinFileVersion', FBinFileVersion);\r\n ASerializer.WriteString(Self, 'FileVersion', FFileVersion);\r\n ASerializer.WriteString(Self, 'FileDescription', FFileDescription);\r\nend;\r\n\r\n//=== { TModuleList } ========================================================\r\n\r\nconstructor TJclSerializableModuleInfoList.Create;\r\nbegin\r\n inherited Create;\r\n FItems := TObjectList.Create;\r\nend;\r\n\r\ndestructor TJclSerializableModuleInfoList.Destroy;\r\nbegin\r\n FItems.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJclSerializableModuleInfoList.Add: TJclSerializableModuleInfo;\r\nbegin\r\n FItems.Add(TJclSerializableModuleInfo.Create);\r\n Result := TJclSerializableModuleInfo(FItems.Last);\r\nend;\r\n\r\nprocedure TJclSerializableModuleInfoList.AssignTo(Dest: TPersistent);\r\nvar\r\n I: Integer;\r\nbegin\r\n if Dest is TJclSerializableModuleInfoList then\r\n begin\r\n TJclSerializableModuleInfoList(Dest).Clear;\r\n for I := 0 to Count - 1 do\r\n TJclSerializableModuleInfoList(Dest).Add.Assign(TJclSerializableModuleInfo(FItems[I]));\r\n end\r\n else\r\n inherited AssignTo(Dest);\r\nend;\r\n\r\nprocedure TJclSerializableModuleInfoList.Clear;\r\nbegin\r\n FItems.Clear;\r\nend;\r\n\r\nfunction TJclSerializableModuleInfoList.GetCount: Integer;\r\nbegin\r\n Result := FItems.Count;\r\nend;\r\n\r\nfunction TJclSerializableModuleInfoList.GetItems(AIndex: Integer): TJclSerializableModuleInfo;\r\nbegin\r\n Result := TJclSerializableModuleInfo(FItems[AIndex]);\r\nend;\r\n\r\nprocedure TJclSerializableModuleInfoList.Deserialize(ASerializer: TJclCustomSimpleSerializer);\r\nvar\r\n I: Integer;\r\nbegin\r\n Clear;\r\n for I := 0 to ASerializer.Count - 1 do\r\n if ASerializer[I].Name = 'Module' then\r\n Add.Deserialize(ASerializer[I]);\r\nend;\r\n\r\nprocedure TJclSerializableModuleInfoList.Serialize(ASerializer: TJclCustomSimpleSerializer);\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := 0 to Count - 1 do\r\n Items[I].Serialize(ASerializer.AddChild(Self, 'Module'));\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jcl/source/windows/JclDebugXMLDeserializer.pas", "content": "{**************************************************************************************************}\r\n{ }\r\n{ Project JEDI Code Library (JCL) }\r\n{ }\r\n{ The contents of this file are subject to the Mozilla Public License Version 1.1 (the \"License\"); }\r\n{ you may not use this file except in compliance with the License. You may obtain a copy of the }\r\n{ License at http://www.mozilla.org/MPL/ }\r\n{ }\r\n{ Software distributed under the License is distributed on an \"AS IS\" basis, WITHOUT WARRANTY OF }\r\n{ ANY KIND, either express or implied. See the License for the specific language governing rights }\r\n{ and limitations under the License. }\r\n{ }\r\n{ The Original Code is JclDebugXMLDeserializer.pas. }\r\n{ }\r\n{ The Initial Developer of the Original Code is Uwe Schuster. }\r\n{ Portions created by Uwe Schuster are Copyright (C) 2009 Uwe Schuster. All rights reserved. }\r\n{ }\r\n{ Contributor(s): }\r\n{ Uwe Schuster (uschuster) }\r\n{ }\r\n{**************************************************************************************************}\r\n{ }\r\n{ Last modified: $Date:: 2011-09-03 00:07:50 +0200 (sam. 03 sept. 2011) $ }\r\n{ Revision: $Rev:: 3599 $ }\r\n{ Author: $Author:: outchy $ }\r\n{ }\r\n{**************************************************************************************************}\r\n\r\nunit JclDebugXMLDeserializer;\r\n\r\n{$I jcl.inc}\r\n{$I windowsonly.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF HAS_UNITSCOPE}\r\n System.SysUtils,\r\n {$ELSE ~HAS_UNITSCOPE}\r\n SysUtils,\r\n {$ENDIF ~HAS_UNITSCOPE}\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n JclDebugSerialization, JclSimpleXml;\r\n\r\ntype\r\n TJclXMLDeserializer = class(TJclCustomSimpleSerializer)\r\n public\r\n procedure LoadFromString(const AValue: string);\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jcl.svn.sourceforge.net/svnroot/jcl/tags/JCL-2.4-Build4571/jcl/source/windows/JclDebugXMLDeserializer.pas $';\r\n Revision: '$Revision: 3599 $';\r\n Date: '$Date: 2011-09-03 00:07:50 +0200 (sam. 03 sept. 2011) $';\r\n LogPath: 'JCL\\source\\windows';\r\n Extra: '';\r\n Data: nil\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\n//=== { TJclXMLDeserializer } ================================================\r\n\r\nprocedure TJclXMLDeserializer.LoadFromString(const AValue: string);\r\n\r\n procedure AddItems(ASerializer: TJclCustomSimpleSerializer; AElem: TJclSimpleXMLElem);\r\n var\r\n I: Integer;\r\n begin\r\n for I := 0 to AElem.Properties.Count - 1 do\r\n ASerializer.Values.Add(Format('%s=%s', [AElem.Properties[I].Name, AElem.Properties[I].Value]));\r\n for I := 0 to AElem.Items.Count - 1 do\r\n AddItems(ASerializer.AddChild(nil, AElem.Items[I].Name), AElem.Items[I])\r\n end;\r\n\r\nvar\r\n XML: TJclSimpleXML;\r\nbegin\r\n XML := TJclSimpleXML.Create;\r\n try\r\n XML.LoadFromString(AValue);\r\n Clear;\r\n AddItems(Self, XML.Root);\r\n finally\r\n XML.Free;\r\n end;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jcl/source/windows/JclDebugXMLSerializer.pas", "content": "{**************************************************************************************************}\r\n{ }\r\n{ Project JEDI Code Library (JCL) }\r\n{ }\r\n{ The contents of this file are subject to the Mozilla Public License Version 1.1 (the \"License\"); }\r\n{ you may not use this file except in compliance with the License. You may obtain a copy of the }\r\n{ License at http://www.mozilla.org/MPL/ }\r\n{ }\r\n{ Software distributed under the License is distributed on an \"AS IS\" basis, WITHOUT WARRANTY OF }\r\n{ ANY KIND, either express or implied. See the License for the specific language governing rights }\r\n{ and limitations under the License. }\r\n{ }\r\n{ The Original Code is JclDebugXMLSerializer.pas. }\r\n{ }\r\n{ The Initial Developer of the Original Code is Uwe Schuster. }\r\n{ Portions created by Uwe Schuster are Copyright (C) 2009 Uwe Schuster. All rights reserved. }\r\n{ }\r\n{ Contributor(s): }\r\n{ Uwe Schuster (uschuster) }\r\n{ }\r\n{**************************************************************************************************}\r\n{ }\r\n{ Last modified: $Date:: 2011-09-03 00:07:50 +0200 (sam. 03 sept. 2011) $ }\r\n{ Revision: $Rev:: 3599 $ }\r\n{ Author: $Author:: outchy $ }\r\n{ }\r\n{**************************************************************************************************}\r\n\r\nunit JclDebugXMLSerializer;\r\n\r\n{$I jcl.inc}\r\n{$I windowsonly.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF HAS_UNITSCOPE}\r\n System.SysUtils, System.Classes,\r\n {$ELSE ~HAS_UNITSCOPE}\r\n SysUtils, Classes,\r\n {$ENDIF ~HAS_UNITSCOPE}\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n JclDebugSerialization;\r\n\r\ntype\r\n TJclXMLSerializer = class(TJclCustomSimpleSerializer)\r\n public\r\n function SaveToString: string;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jcl.svn.sourceforge.net/svnroot/jcl/tags/JCL-2.4-Build4571/jcl/source/windows/JclDebugXMLSerializer.pas $';\r\n Revision: '$Revision: 3599 $';\r\n Date: '$Date: 2011-09-03 00:07:50 +0200 (sam. 03 sept. 2011) $';\r\n LogPath: 'JCL\\source\\windows';\r\n Extra: '';\r\n Data: nil\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\n//=== { TJclXMLSerializer } ==================================================\r\n\r\nfunction TJclXMLSerializer.SaveToString: string;\r\n\r\n procedure AddToStrings(ASerializer: TJclCustomSimpleSerializer; AXMLStrings: TStringList; AIdent: Integer);\r\n var\r\n I, P: Integer;\r\n S, S1, S2, V: string;\r\n begin\r\n if AIdent = 0 then\r\n S := ''\r\n else\r\n S := StringOfChar(' ', AIdent);\r\n V := '';\r\n for I := 0 to ASerializer.Values.Count - 1 do\r\n begin\r\n S1 := ASerializer.Values[I];\r\n P := Pos('=', S1);\r\n if P > 0 then\r\n begin\r\n S2 := S1;\r\n Delete(S1, P, Length(S1));\r\n Delete(S2, 1, P);\r\n V := V + ' ';\r\n V := V + Format('%s=\"%s\"', [S1, S2]);\r\n end;\r\n end;\r\n if ASerializer.Count > 0 then\r\n begin\r\n AXMLStrings.Add(S + '<' + ASerializer.Name + V + '>');\r\n for I := 0 to ASerializer.Count - 1 do\r\n AddToStrings(ASerializer[I], AXMLStrings, AIdent + 2);\r\n AXMLStrings.Add(S + '');\r\n end\r\n else\r\n AXMLStrings.Add(S + '<' + ASerializer.Name + V + '/>');\r\n end;\r\n\r\n\r\nvar\r\n XMLStrings: TStringList;\r\nbegin\r\n XMLStrings := TStringList.Create;\r\n try\r\n AddToStrings(Self, XMLStrings, 0);\r\n Result := XMLStrings.Text;\r\n finally\r\n XMLStrings.Free;\r\n end;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jcl/source/windows/JclDotNet.pas", "content": "{**************************************************************************************************}\r\n{ }\r\n{ Project JEDI Code Library (JCL) }\r\n{ }\r\n{ The contents of this file are subject to the Mozilla Public License Version 1.1 (the \"License\"); }\r\n{ you may not use this file except in compliance with the License. You may obtain a copy of the }\r\n{ License at http://www.mozilla.org/MPL/ }\r\n{ }\r\n{ Software distributed under the License is distributed on an \"AS IS\" basis, WITHOUT WARRANTY OF }\r\n{ ANY KIND, either express or implied. See the License for the specific language governing rights }\r\n{ and limitations under the License. }\r\n{ }\r\n{ The Original Code is JclDotNet.pas. }\r\n{ }\r\n{ The Initial Developer of the Original Code is Flier Lu (). }\r\n{ Portions created by Flier Lu are Copyright (C) Flier Lu. All Rights Reserved. }\r\n{ }\r\n{ Contributors: }\r\n{ Flier Lu (flier) }\r\n{ Robert Marquardt (marquardt) }\r\n{ Olivier Sannier (obones) }\r\n{ Florent Ouchet (outchy) }\r\n{ }\r\n{**************************************************************************************************}\r\n{ }\r\n{ Microsoft .Net framework support routines and classes. }\r\n{ }\r\n{**************************************************************************************************}\r\n{ }\r\n{ Last modified: $Date:: 2012-09-04 16:08:04 +0200 (mar. 04 sept. 2012) $ }\r\n{ Revision: $Rev:: 3861 $ }\r\n{ Author: $Author:: outchy $ }\r\n{ }\r\n{**************************************************************************************************}\r\n\r\nunit JclDotNet;\r\n\r\n{**************************************************************************************************}\r\n{ Read this before compile! }\r\n{**************************************************************************************************}\r\n{ 1. This unit is developed in Delphi6 with MS.Net v1.0.3705, }\r\n{ you maybe need to modify it for your environment. }\r\n{ 2. Delphi's TLibImp.exe would generate error *_TLB.pas files }\r\n{ when you import mscorlib.tlb, you should modify it by hand }\r\n{ for example, change Pointer to _Pointer... }\r\n{ or use my modified edition of mscorlib_TLB.pas (mscor.zip) }\r\n{**************************************************************************************************}\r\n\r\ninterface\r\n\r\n{$I jcl.inc}\r\n{$I windowsonly.inc}\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n {$IFDEF HAS_UNITSCOPE}\r\n {$IFDEF MSWINDOWS}\r\n Winapi.Windows, Winapi.ActiveX,\r\n {$ENDIF MSWINDOWS}\r\n System.Classes, System.SysUtils, System.Contnrs,\r\n {$ELSE ~HAS_UNITSCOPE}\r\n {$IFDEF MSWINDOWS}\r\n Windows, ActiveX,\r\n {$ENDIF MSWINDOWS}\r\n Classes, SysUtils, Contnrs,\r\n {$ENDIF ~HAS_UNITSCOPE}\r\n JclBase, JclWideStrings,\r\n mscoree_TLB, mscorlib_TLB;\r\n\r\n//{$HPPEMIT '#include'}\r\n\r\n{ TODO -cDOC : Original code: \"Flier Lu\" }\r\n\r\ntype\r\n TJclClrBase = TInterfacedObject;\r\n\r\ntype\r\n TJclClrHostFlavor = (hfServer, hfWorkStation);\r\n\r\n TJclClrHostLoaderFlag =\r\n (hlOptSingleDomain,\r\n hlOptMultiDomain,\r\n hlOptMultiDomainHost,\r\n hlSafeMode,\r\n hlSetPreference);\r\n TJclClrHostLoaderFlags = set of TJclClrHostLoaderFlag;\r\n\r\ntype\r\n EJclClrException = class(EJclError);\r\n \r\n TJclClrAppDomain = class;\r\n TJclClrAppDomainSetup = class;\r\n TJclClrAssembly = class;\r\n\r\n TJclClrHost = class(TJclClrBase, ICorRuntimeHost)\r\n private\r\n FDefaultInterface: ICorRuntimeHost;\r\n FAppDomains: TObjectList;\r\n procedure EnumAppDomains;\r\n function GetAppDomain(const Idx: Integer): TJclClrAppDomain;\r\n function GetAppDomainCount: Integer;\r\n function GetDefaultAppDomain: _AppDomain;\r\n function GetCurrentAppDomain: _AppDomain;\r\n protected\r\n function AddAppDomain(const AppDomain: TJclClrAppDomain): Integer;\r\n function RemoveAppDomain(const AppDomain: TJclClrAppDomain): Integer; \r\n public\r\n constructor Create(const ClrVer: WideString = '';\r\n const Flavor: TJclClrHostFlavor = hfWorkStation;\r\n const ConcurrentGC: Boolean = True;\r\n const LoaderFlags: TJclClrHostLoaderFlags = [hlOptSingleDomain]);\r\n destructor Destroy; override;\r\n procedure Start;\r\n procedure Stop;\r\n procedure Refresh;\r\n function CreateDomainSetup: TJclClrAppDomainSetup;\r\n function CreateAppDomain(const Name: WideString;\r\n const Setup: TJclClrAppDomainSetup = nil;\r\n const Evidence: _Evidence = nil): TJclClrAppDomain;\r\n function FindAppDomain(const Intf: _AppDomain; var Ret: TJclClrAppDomain): Boolean; overload;\r\n function FindAppDomain(const Name: WideString; var Ret: TJclClrAppDomain): Boolean; overload;\r\n class function CorSystemDirectory: WideString;\r\n class function CorVersion: WideString;\r\n class function CorRequiredVersion: WideString;\r\n class procedure GetClrVersions(VersionNames: TJclWideStrings); overload;\r\n {$IFNDEF SUPPORTS_UNICODE}\r\n class procedure GetClrVersions(VersionNames: TStrings); overload;\r\n {$ENDIF ~SUPPORTS_UNICODE}\r\n property AppDomains[const Idx: Integer]: TJclClrAppDomain read GetAppDomain; default;\r\n property AppDomainCount: Integer read GetAppDomainCount;\r\n property DefaultAppDomain: _AppDomain read GetDefaultAppDomain;\r\n property CurrentAppDomain: _AppDomain read GetCurrentAppDomain;\r\n { ICorRuntimeHost }\r\n property DefaultInterface: ICorRuntimeHost read FDefaultInterface implements ICorRuntimeHost;\r\n end;\r\n\r\n TJclClrAssemblyArguments = array of WideString;\r\n\r\n TJclClrAppDomain = class(TJclClrBase, _AppDomain)\r\n private\r\n FHost: TJclClrHost;\r\n FDefaultInterface: _AppDomain;\r\n public\r\n constructor Create(const AHost: TJclClrHost; const AAppDomain: _AppDomain);\r\n function Load(const AssemblyString: WideString;\r\n const AssemblySecurity: _Evidence = nil): TJclClrAssembly; overload;\r\n function Load(const RawAssemblyStream: TStream;\r\n const RawSymbolStoreStream: TStream = nil;\r\n const AssemblySecurity: _Evidence = nil): TJclClrAssembly; overload;\r\n function Execute(const AssemblyFile: TFileName;\r\n const AssemblySecurity: _Evidence = nil): Integer; overload;\r\n function Execute(const AssemblyFile: TFileName;\r\n const Arguments: TJclClrAssemblyArguments;\r\n const AssemblySecurity: _Evidence = nil): Integer; overload;\r\n function Execute(const AssemblyFile: TFileName;\r\n const Arguments: TStrings;\r\n const AssemblySecurity: _Evidence = nil): Integer; overload;\r\n procedure Unload;\r\n property Host: TJclClrHost read FHost;\r\n property DefaultInterface: _AppDomain read FDefaultInterface implements _AppDomain;\r\n end;\r\n\r\n TJclClrAppDomainSetup = class(TJclClrBase, IAppDomainSetup)\r\n private\r\n FDefaultInterface: IAppDomainSetup;\r\n function GetApplicationBase: WideString;\r\n function GetApplicationName: WideString;\r\n function GetCachePath: WideString;\r\n function GetConfigurationFile: WideString;\r\n function GetDynamicBase: WideString;\r\n function GetLicenseFile: WideString;\r\n function GetPrivateBinPath: WideString;\r\n function GetPrivateBinPathProbe: WideString;\r\n function GetShadowCopyDirectories: WideString;\r\n function GetShadowCopyFiles: WideString;\r\n procedure SetApplicationBase(const Value: WideString);\r\n procedure SetApplicationName(const Value: WideString);\r\n procedure SetCachePath(const Value: WideString);\r\n procedure SetConfigurationFile(const Value: WideString);\r\n procedure SetDynamicBase(const Value: WideString);\r\n procedure SetLicenseFile(const Value: WideString);\r\n procedure SetPrivateBinPath(const Value: WideString);\r\n procedure SetPrivateBinPathProbe(const Value: WideString);\r\n procedure SetShadowCopyDirectories(const Value: WideString);\r\n procedure SetShadowCopyFiles(const Value: WideString);\r\n public\r\n constructor Create(Intf: IAppDomainSetup);\r\n\r\n property ApplicationBase: WideString read GetApplicationBase write SetApplicationBase;\r\n property ApplicationName: WideString read GetApplicationName write SetApplicationName;\r\n property CachePath: WideString read GetCachePath write SetCachePath;\r\n property ConfigurationFile: WideString read GetConfigurationFile write SetConfigurationFile;\r\n property DynamicBase: WideString read GetDynamicBase write SetDynamicBase;\r\n property LicenseFile: WideString read GetLicenseFile write SetLicenseFile;\r\n property PrivateBinPath: WideString read GetPrivateBinPath write SetPrivateBinPath;\r\n property PrivateBinPathProbe: WideString read GetPrivateBinPathProbe write SetPrivateBinPathProbe;\r\n property ShadowCopyDirectories: WideString read GetShadowCopyDirectories write SetShadowCopyDirectories;\r\n property ShadowCopyFiles: WideString read GetShadowCopyFiles write SetShadowCopyFiles;\r\n { IAppDomainSetup }\r\n property DefaultInterface: IAppDomainSetup read FDefaultInterface implements IAppDomainSetup;\r\n end;\r\n\r\n TJclClrAssembly = class(TJclClrBase, _Assembly)\r\n private\r\n FDefaultInterface: _Assembly;\r\n public\r\n constructor Create(Intf: _Assembly);\r\n\r\n property DefaultInterface: _Assembly read FDefaultInterface implements _Assembly;\r\n end;\r\n\r\ntype\r\n TJclClrField = class(TObject)\r\n end;\r\n\r\n TJclClrProperty = class(TObject)\r\n end;\r\n\r\n TJclClrMethod = class(TJclClrBase, _MethodInfo)\r\n private\r\n FDefaultInterface: _MethodInfo;\r\n public\r\n property DefaultInterface: _MethodInfo read FDefaultInterface implements _MethodInfo;\r\n end;\r\n\r\n TJclClrObject = class(TObject)\r\n private\r\n function GetMethod(const Name: WideString): TJclClrMethod;\r\n function GetField(const Name: WideString): TJclClrField;\r\n function GetProperty(const Name: WideString): TJclClrProperty;\r\n public\r\n constructor Create(const AssemblyName, NamespaceName, ClassName: WideString;\r\n const Parameters: array of const); overload;\r\n constructor Create(const AssemblyName, NamespaceName, ClassName: WideString;\r\n const NewInstance: Boolean = False); overload;\r\n\r\n property Fields[const Name: WideString]: TJclClrField read GetField;\r\n property Properties[const Name: WideString]: TJclClrProperty read GetProperty;\r\n property Methods[const Name: WideString]: TJclClrMethod read GetMethod;\r\n end;\r\n\r\nfunction CompareCLRVersions(const LeftVersion, RightVersion: string): Integer;\r\n\r\ntype\r\n HDOMAINENUM = Pointer;\r\n {$EXTERNALSYM HDOMAINENUM}\r\n\r\nconst\r\n STARTUP_CONCURRENT_GC = $1;\r\n STARTUP_LOADER_OPTIMIZATION_MASK = $3 shl 1;\r\n STARTUP_LOADER_OPTIMIZATION_SINGLE_DOMAIN = $1 shl 1;\r\n STARTUP_LOADER_OPTIMIZATION_MULTI_DOMAIN = $2 shl 1;\r\n STARTUP_LOADER_OPTIMIZATION_MULTI_DOMAIN_HOST = $3 shl 1;\r\n STARTUP_LOADER_SAFEMODE = $10;\r\n STARTUP_LOADER_SETPREFERENCE = $100;\r\n\r\n RUNTIME_INFO_UPGRADE_VERSION = $01;\r\n RUNTIME_INFO_REQUEST_IA64 = $02;\r\n RUNTIME_INFO_REQUEST_AMD64 = $04;\r\n RUNTIME_INFO_REQUEST_X86 = $08;\r\n RUNTIME_INFO_DONT_RETURN_DIRECTORY = $10;\r\n RUNTIME_INFO_DONT_RETURN_VERSION = $20;\r\n RUNTIME_INFO_DONT_SHOW_ERROR_DIALOG = $40;\r\n\r\nfunction GetCORSystemDirectory(pbuffer: PWideChar; const cchBuffer: DWORD;\r\n var dwLength: DWORD): HRESULT; stdcall;\r\n{$EXTERNALSYM GetCORSystemDirectory}\r\nfunction GetCORVersion(pbuffer: PWideChar; const cchBuffer: DWORD;\r\n var dwLength: DWORD): HRESULT; stdcall;\r\n{$EXTERNALSYM GetCORVersion}\r\nfunction GetFileVersion(szFileName, szBuffer: PWideChar; const cchBuffer: DWORD;\r\n var dwLength: DWORD): HRESULT; stdcall;\r\n{$EXTERNALSYM GetFileVersion}\r\nfunction GetCORRequiredVersion(pbuffer: PWideChar; const cchBuffer: DWORD;\r\n var dwLength: DWORD): HRESULT; stdcall;\r\n{$EXTERNALSYM GetCORRequiredVersion}\r\nfunction GetRequestedRuntimeInfo(pExe, pwszVersion, pConfigurationFile: PWideChar;\r\n const startupFlags, reserved: DWORD; pDirectory: PWideChar; const dwDirectory: DWORD;\r\n var dwDirectoryLength: DWORD; pVersion: PWideChar; const cchBuffer: DWORD;\r\n var dwLength: DWORD): HRESULT; stdcall;\r\n{$EXTERNALSYM GetRequestedRuntimeInfo}\r\nfunction GetRequestedRuntimeVersion(pExe, pVersion: PWideChar;\r\n const cchBuffer: DWORD; var dwLength: DWORD): HRESULT; stdcall;\r\n{$EXTERNALSYM GetRequestedRuntimeVersion}\r\nfunction CorBindToRuntimeHost(pwszVersion, pwszBuildFlavor,\r\n pwszHostConfigFile: PWideChar; const pReserved: Pointer;\r\n const startupFlags: DWORD; const rclsid: TCLSID; const riid: TIID;\r\n out pv): HRESULT; stdcall;\r\n{$EXTERNALSYM CorBindToRuntimeHost}\r\nfunction CorBindToRuntimeEx(pwszVersion, pwszBuildFlavor: PWideChar;\r\n startupFlags: DWORD; const rclsid: TCLSID; const riid: TIID;\r\n out pv): HRESULT; stdcall;\r\n{$EXTERNALSYM CorBindToRuntimeEx}\r\nfunction CorBindToRuntimeByCfg(const pCfgStream: IStream;\r\n const reserved, startupFlags: DWORD; const rclsid: TCLSID;\r\n const riid: TIID; out pv): HRESULT; stdcall;\r\n{$EXTERNALSYM CorBindToRuntimeByCfg}\r\nfunction CorBindToRuntime(pwszVersion, pwszBuildFlavor: PWideChar;\r\n const rclsid: TCLSID; const riid: TIID; out pv): HRESULT; stdcall;\r\n{$EXTERNALSYM CorBindToRuntime}\r\nfunction CorBindToCurrentRuntime(pwszFileName: PWideChar;\r\n const rclsid: TCLSID; const riid: TIID; out pv): HRESULT; stdcall;\r\n{$EXTERNALSYM CorBindToCurrentRuntime}\r\nfunction ClrCreateManagedInstance(pTypeName: PWideChar;\r\n const riid: TIID; out pv): HRESULT; stdcall;\r\n{$EXTERNALSYM ClrCreateManagedInstance}\r\nprocedure CorMarkThreadInThreadPool; stdcall;\r\n{$EXTERNALSYM CorMarkThreadInThreadPool}\r\nfunction RunDll32ShimW(const hwnd: THandle; const hinst: HMODULE;\r\n lpszCmdLine: PWideChar; const nCmdShow: Integer): HRESULT; stdcall;\r\n{$EXTERNALSYM RunDll32ShimW}\r\nfunction LoadLibraryShim(szDllName, szVersion: PWideChar;\r\n const pvReserved: Pointer; out phModDll: HMODULE): HRESULT; stdcall;\r\n{$EXTERNALSYM LoadLibraryShim}\r\nfunction CallFunctionShim(szDllName: PWideChar; const szFunctionName: PChar;\r\n const lpvArgument1, lpvArgument2: Pointer; szVersion: PWideChar;\r\n const pvReserved: Pointer): HRESULT; stdcall;\r\n{$EXTERNALSYM CallFunctionShim}\r\nfunction GetRealProcAddress(const pwszProcName: PChar;\r\n out ppv: Pointer): HRESULT; stdcall;\r\n{$EXTERNALSYM GetRealProcAddress}\r\nprocedure CorExitProcess(const exitCode: Integer); stdcall;\r\n{$EXTERNALSYM CorExitProcess}\r\n\r\ntype\r\n CLSID_RESOLUTION_FLAGS = type Byte;\r\n {$EXTERNALSYM CLSID_RESOLUTION_FLAGS}\r\n\r\nconst\r\n CLSID_RESOLUTION_DEFAULT = $0;\r\n {$EXTERNALSYM CLSID_RESOLUTION_DEFAULT}\r\n CLSID_RESOLUTION_REGISTERED = $1;\r\n {$EXTERNALSYM CLSID_RESOLUTION_REGISTERED}\r\n\r\nfunction GetRequestedRuntimeVersionForCLSID(rclsid: TGuid; pVersion: PWideChar;\r\n const cchBuffer: DWORD; var dwLength: DWORD;\r\n const dwResolutionFlags: CLSID_RESOLUTION_FLAGS): HRESULT; stdcall;\r\n{$EXTERNALSYM GetRequestedRuntimeVersionForCLSID}\r\n\r\nconst\r\n mscoree_dll = 'mscoree.dll';\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jcl.svn.sourceforge.net/svnroot/jcl/tags/JCL-2.4-Build4571/jcl/source/windows/JclDotNet.pas $';\r\n Revision: '$Revision: 3861 $';\r\n Date: '$Date: 2012-09-04 16:08:04 +0200 (mar. 04 sept. 2012) $';\r\n LogPath: 'JCL\\source\\windows';\r\n Extra: '';\r\n Data: nil\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n {$IFDEF HAS_UNITSCOPE}\r\n System.Win.ComObj,\r\n System.Variants,\r\n System.Types, // inline of TList.Remove\r\n {$ELSE ~HAS_UNITSCOPE}\r\n ComObj,\r\n Variants,\r\n {$ENDIF ~HAS_UNITSCOPE}\r\n JclSysUtils,\r\n JclResources,\r\n JclStrings;\r\n\r\nfunction CompareCLRVersions(const LeftVersion, RightVersion: string): Integer;\r\nvar\r\n LeftMajor, RightMajor, LeftMinor, RightMinor, LeftBuild, RightBuild, DotPos: Integer;\r\n LeftStr, RightStr, LeftNum, RightNum: string;\r\nbegin\r\n if (Length(LeftVersion) = 0) or (LeftVersion[1] <> 'v') then\r\n raise EJclClrException.CreateResFmt(@RsEUnknownCLRVersion, [LeftVersion]);\r\n\r\n if (Length(RightVersion) = 0) or (RightVersion[1] <> 'v') then\r\n raise EJclClrException.CreateResFmt(@RsEUnknownCLRVersion, [RightVersion]);\r\n\r\n DotPos := Pos('.', LeftVersion);\r\n if DotPos = 0 then\r\n raise EJclClrException.CreateResFmt(@RsEUnknownCLRVersion, [LeftVersion]);\r\n LeftNum := Copy(LeftVersion, 2, DotPos - 2);\r\n LeftStr := Copy(LeftVersion, DotPos + 1, Length(LeftVersion) - DotPos);\r\n LeftMajor := 0;\r\n if not TryStrToInt(LeftNum, LeftMajor) then\r\n raise EJclClrException.CreateResFmt(@RsEUnknownCLRVersion, [LeftVersion]);\r\n\r\n DotPos := Pos('.', RightVersion);\r\n if DotPos = 0 then\r\n raise EJclClrException.CreateResFmt(@RsEUnknownCLRVersion, [RightVersion]);\r\n RightNum := Copy(RightVersion, 2, DotPos - 2);\r\n RightStr := Copy(RightVersion, DotPos + 1, Length(RightVersion) - DotPos);\r\n RightMajor := 0;\r\n if not TryStrToInt(RightNum, RightMajor) then\r\n raise EJclClrException.CreateResFmt(@RsEUnknownCLRVersion, [RightVersion]);\r\n\r\n Result := -1;\r\n if LeftMajor < RightMajor then\r\n Exit;\r\n Result := 1;\r\n if LeftMajor > RightMajor then\r\n Exit;\r\n\r\n DotPos := Pos('.', LeftStr);\r\n if DotPos = 0 then\r\n raise EJclClrException.CreateResFmt(@RsEUnknownCLRVersion, [LeftVersion]);\r\n LeftNum := Copy(LeftStr, 1, DotPos - 1);\r\n LeftStr := Copy(LeftStr, DotPos + 1, Length(LeftStr) - DotPos);\r\n LeftMinor := 0;\r\n if not TryStrToInt(LeftNum, LeftMinor) then\r\n raise EJclClrException.CreateResFmt(@RsEUnknownCLRVersion, [LeftVersion]);\r\n\r\n DotPos := Pos('.', RightStr);\r\n if DotPos = 0 then\r\n raise EJclClrException.CreateResFmt(@RsEUnknownCLRVersion, [RightVersion]);\r\n RightNum := Copy(RightStr, 1, DotPos - 1);\r\n RightStr := Copy(RightStr, DotPos + 1, Length(RightStr) - DotPos);\r\n RightMinor := 0;\r\n if not TryStrToInt(RightNum, RightMinor) then\r\n raise EJclClrException.CreateResFmt(@RsEUnknownCLRVersion, [RightVersion]);\r\n\r\n Result := -1;\r\n if LeftMinor < RightMinor then\r\n Exit;\r\n Result := 1;\r\n if LeftMinor > RightMinor then\r\n Exit;\r\n\r\n LeftBuild := 0;\r\n if not TryStrToInt(LeftStr, LeftBuild) then\r\n raise EJclClrException.CreateResFmt(@RsEUnknownCLRVersion, [LeftVersion]);\r\n RightBuild := 0;\r\n if not TryStrToInt(RightStr, RightBuild) then\r\n raise EJclClrException.CreateResFmt(@RsEUnknownCLRVersion, [RightVersion]);\r\n\r\n if LeftBuild < RightBuild then\r\n Result := -1\r\n else if LeftBuild > RightBuild then\r\n Result := 1\r\n else\r\n Result := 0;\r\nend;\r\n\r\nprocedure GetProcedureAddress(var P: Pointer; const ModuleName, ProcName: string);\r\nvar\r\n ModuleHandle: HMODULE;\r\nbegin\r\n if not Assigned(P) then\r\n begin\r\n ModuleHandle := GetModuleHandle(PChar(ModuleName));\r\n if ModuleHandle = 0 then\r\n begin\r\n ModuleHandle := SafeLoadLibrary(ModuleName);\r\n if ModuleHandle = 0 then\r\n raise EJclError.CreateResFmt(@RsELibraryNotFound, [ModuleName]);\r\n end;\r\n P := GetProcAddress(ModuleHandle, PChar(ProcName));\r\n if not Assigned(P) then\r\n raise EJclError.CreateResFmt(@RsEFunctionNotFound, [ModuleName, ProcName]);\r\n end;\r\nend;\r\n\r\ntype\r\n TGetCORSystemDirectory = function (pbuffer: PWideChar; const cchBuffer: DWORD;\r\n var dwLength: DWORD): HRESULT; stdcall;\r\n\r\nvar\r\n _GetCORSystemDirectory: TGetCORSystemDirectory = nil;\r\n\r\nfunction GetCORSystemDirectory(pbuffer: PWideChar; const cchBuffer: DWORD; var dwLength: DWORD): HRESULT;\r\nbegin\r\n GetProcedureAddress(Pointer(@_GetCORSystemDirectory), mscoree_dll, 'GetCORSystemDirectory');\r\n Result := _GetCORSystemDirectory(pbuffer, cchBuffer, dwLength);\r\nend;\r\n\r\ntype\r\n TGetCORVersion = function (pbuffer: PWideChar; const cchBuffer: DWORD;\r\n var dwLength: DWORD): HRESULT; stdcall;\r\n\r\nvar\r\n _GetCORVersion: TGetCORVersion = nil;\r\n\r\nfunction GetCORVersion(pbuffer: PWideChar; const cchBuffer: DWORD;\r\n var dwLength: DWORD): HRESULT;\r\nbegin\r\n GetProcedureAddress(Pointer(@_GetCORVersion), mscoree_dll, 'GetCORVersion');\r\n Result := _GetCORVersion(pbuffer, cchBuffer, dwLength);\r\nend;\r\n\r\ntype\r\n TGetFileVersion = function (szFileName, szBuffer: PWideChar; const cchBuffer: DWORD;\r\n var dwLength: DWORD): HRESULT; stdcall;\r\n\r\nvar\r\n _GetFileVersion: TGetFileVersion = nil;\r\n\r\nfunction GetFileVersion(szFileName, szBuffer: PWideChar; const cchBuffer: DWORD;\r\n var dwLength: DWORD): HRESULT;\r\nbegin\r\n GetProcedureAddress(Pointer(@_GetFileVersion), mscoree_dll, 'GetFileVersion');\r\n Result := _GetFileVersion(szFileName, szBuffer, cchBuffer, dwLength);\r\nend;\r\n\r\ntype\r\n TGetCORRequiredVersion = function (pbuffer: PWideChar; const cchBuffer: DWORD;\r\n var dwLength: DWORD): HRESULT; stdcall;\r\n\r\nvar\r\n _GetCORRequiredVersion: TGetCORRequiredVersion = nil;\r\n\r\nfunction GetCORRequiredVersion(pbuffer: PWideChar; const cchBuffer: DWORD;\r\n var dwLength: DWORD): HRESULT;\r\nbegin\r\n GetProcedureAddress(Pointer(@_GetCORRequiredVersion), mscoree_dll, 'GetCORRequiredVersion');\r\n Result := _GetCORRequiredVersion(pbuffer, cchBuffer, dwLength);\r\nend;\r\n\r\ntype\r\n TGetRequestedRuntimeInfo = function (pExe, pwszVersion, pConfigurationFile: PWideChar;\r\n const startupFlags, reserved: DWORD; pDirectory: PWideChar; const dwDirectory: DWORD;\r\n var dwDirectoryLength: DWORD; pVersion: PWideChar; const cchBuffer: DWORD;\r\n var dwLength: DWORD): HRESULT; stdcall;\r\n\r\nvar\r\n _GetRequestedRuntimeInfo: TGetRequestedRuntimeInfo = nil;\r\n\r\nfunction GetRequestedRuntimeInfo(pExe, pwszVersion, pConfigurationFile: PWideChar;\r\n const startupFlags, reserved: DWORD; pDirectory: PWideChar; const dwDirectory: DWORD;\r\n var dwDirectoryLength: DWORD; pVersion: PWideChar; const cchBuffer: DWORD;\r\n var dwLength: DWORD): HRESULT;\r\nbegin\r\n GetProcedureAddress(Pointer(@_GetRequestedRuntimeInfo), mscoree_dll, 'GetRequestedRuntimeInfo');\r\n Result := _GetRequestedRuntimeInfo(pExe, pwszVersion, pConfigurationFile, startupFlags, reserved, pDirectory,\r\n dwDirectory, dwDirectoryLength, pVersion, cchBuffer, dwLength);\r\nend;\r\n\r\ntype\r\n TGetRequestedRuntimeVersion = function (pExe, pVersion: PWideChar;\r\n const cchBuffer: DWORD; var dwLength: DWORD): HRESULT; stdcall;\r\n\r\nvar\r\n _GetRequestedRuntimeVersion: TGetRequestedRuntimeVersion = nil;\r\n\r\nfunction GetRequestedRuntimeVersion(pExe, pVersion: PWideChar;\r\n const cchBuffer: DWORD; var dwLength: DWORD): HRESULT;\r\nbegin\r\n GetProcedureAddress(Pointer(@_GetRequestedRuntimeVersion), mscoree_dll, 'GetRequestedRuntimeVersion');\r\n Result := _GetRequestedRuntimeVersion(pExe, pVersion, cchBuffer, dwLength);\r\nend;\r\n\r\ntype\r\n TCorBindToRuntimeHost = function (pwszVersion, pwszBuildFlavor,\r\n pwszHostConfigFile: PWideChar; const pReserved: Pointer;\r\n const startupFlags: DWORD; const rclsid: TCLSID; const riid: TIID;\r\n out pv): HRESULT; stdcall;\r\n\r\nvar\r\n _CorBindToRuntimeHost: TCorBindToRuntimeHost = nil;\r\n\r\nfunction CorBindToRuntimeHost(pwszVersion, pwszBuildFlavor,\r\n pwszHostConfigFile: PWideChar; const pReserved: Pointer;\r\n const startupFlags: DWORD; const rclsid: TCLSID; const riid: TIID;\r\n out pv): HRESULT;\r\nbegin\r\n GetProcedureAddress(Pointer(@_CorBindToRuntimeHost), mscoree_dll, 'CorBindToRuntimeHost');\r\n Result := _CorBindToRuntimeHost(pwszVersion, pwszBuildFlavor, pwszHostConfigFile, pReserved,\r\n startupFlags, rclsid, riid, pv);\r\nend;\r\n\r\ntype\r\n TCorBindToRuntimeEx = function (pwszVersion, pwszBuildFlavor: PWideChar;\r\n startupFlags: DWORD; const rclsid: TCLSID; const riid: TIID;\r\n out pv): HRESULT; stdcall;\r\n\r\nvar\r\n _CorBindToRuntimeEx: TCorBindToRuntimeEx = nil;\r\n\r\nfunction CorBindToRuntimeEx(pwszVersion, pwszBuildFlavor: PWideChar;\r\n startupFlags: DWORD; const rclsid: TCLSID; const riid: TIID;\r\n out pv): HRESULT;\r\nbegin\r\n GetProcedureAddress(Pointer(@_CorBindToRuntimeEx), mscoree_dll, 'CorBindToRuntimeEx');\r\n Result := _CorBindToRuntimeEx(pwszVersion, pwszBuildFlavor, startupFlags, rclsid, riid, pv);\r\nend;\r\n\r\ntype\r\n TCorBindToRuntimeByCfg = function (const pCfgStream: IStream;\r\n const reserved, startupFlags: DWORD; const rclsid: TCLSID;\r\n const riid: TIID; out pv): HRESULT; stdcall;\r\n\r\nvar\r\n _CorBindToRuntimeByCfg: TCorBindToRuntimeByCfg = nil;\r\n\r\nfunction CorBindToRuntimeByCfg(const pCfgStream: IStream;\r\n const reserved, startupFlags: DWORD; const rclsid: TCLSID;\r\n const riid: TIID; out pv): HRESULT;\r\nbegin\r\n GetProcedureAddress(Pointer(@_CorBindToRuntimeByCfg), mscoree_dll, 'CorBindToRuntimeByCfg');\r\n Result := _CorBindToRuntimeByCfg(pCfgStream, reserved, startupFlags, rclsid, riid, pv);\r\nend;\r\n\r\ntype\r\n TCorBindToRuntime = function (pwszVersion, pwszBuildFlavor: PWideChar;\r\n const rclsid: TCLSID; const riid: TIID; out pv): HRESULT; stdcall;\r\n\r\nvar\r\n _CorBindToRuntime: TCorBindToRuntime = nil;\r\n\r\nfunction CorBindToRuntime(pwszVersion, pwszBuildFlavor: PWideChar;\r\n const rclsid: TCLSID; const riid: TIID; out pv): HRESULT;\r\nbegin\r\n GetProcedureAddress(Pointer(@_CorBindToRuntime), mscoree_dll, 'CorBindToRuntime');\r\n Result := _CorBindToRuntime(pwszVersion, pwszBuildFlavor, rclsid, riid, pv);\r\nend;\r\n\r\ntype\r\n TCorBindToCurrentRuntime = function (pwszFileName: PWideChar;\r\n const rclsid: TCLSID; const riid: TIID; out pv): HRESULT; stdcall;\r\n\r\nvar\r\n _CorBindToCurrentRuntime: TCorBindToCurrentRuntime = nil;\r\n\r\nfunction CorBindToCurrentRuntime(pwszFileName: PWideChar;\r\n const rclsid: TCLSID; const riid: TIID; out pv): HRESULT;\r\nbegin\r\n GetProcedureAddress(Pointer(@_CorBindToCurrentRuntime), mscoree_dll, 'CorBindToCurrentRuntime');\r\n Result := _CorBindToCurrentRunTime(pwszFileName, rclsid, riid, pv);\r\nend;\r\n\r\ntype\r\n TClrCreateManagedInstance = function (pTypeName: PWideChar;\r\n const riid: TIID; out pv): HRESULT; stdcall;\r\n\r\nvar\r\n _ClrCreateManagedInstance: TClrCreateManagedInstance = nil;\r\n\r\nfunction ClrCreateManagedInstance(pTypeName: PWideChar;\r\n const riid: TIID; out pv): HRESULT;\r\nbegin\r\n GetProcedureAddress(Pointer(@_ClrCreateManagedInstance), mscoree_dll, 'ClrCreateManagedInstance');\r\n Result := _ClrCreateManagedInstance(pTypeName, riid, pv);\r\nend;\r\n\r\ntype\r\n TCorMarkThreadInThreadPool = procedure; stdcall;\r\n\r\nvar\r\n _CorMarkThreadInThreadPool: TCorMarkThreadInThreadPool = nil;\r\n\r\nprocedure CorMarkThreadInThreadPool;\r\nbegin\r\n GetProcedureAddress(Pointer(@_CorMarkThreadInThreadPool), mscoree_dll, 'CorMarkThreadInThreadPool');\r\n _CorMarkThreadInThreadPool;\r\nend;\r\n\r\ntype\r\n TRunDll32ShimW = function (const hwnd: THandle; const hinst: HMODULE;\r\n lpszCmdLine: PWideChar; const nCmdShow: Integer): HRESULT; stdcall;\r\n\r\nvar\r\n _RunDll32ShimW: TRunDll32ShimW = nil;\r\n\r\nfunction RunDll32ShimW(const hwnd: THandle; const hinst: HMODULE;\r\n lpszCmdLine: PWideChar; const nCmdShow: Integer): HRESULT;\r\nbegin\r\n GetProcedureAddress(Pointer(@_RunDll32ShimW), mscoree_dll, 'RunDll32ShimW');\r\n Result := _RunDll32ShimW(hwnd, hinst, lpszCmdLine, nCmdShow);\r\nend;\r\n\r\ntype\r\n TLoadLibraryShim = function (szDllName, szVersion: PWideChar;\r\n const pvReserved: Pointer; out phModDll: HMODULE): HRESULT; stdcall;\r\n\r\nvar\r\n _LoadLibraryShim: TLoadLibraryShim = nil;\r\n\r\nfunction LoadLibraryShim(szDllName, szVersion: PWideChar;\r\n const pvReserved: Pointer; out phModDll: HMODULE): HRESULT;\r\nbegin\r\n GetProcedureAddress(Pointer(@_LoadLibraryShim), mscoree_dll, 'LoadLibraryShim');\r\n Result := _LoadLibraryShim(szDllName, szVersion, pvReserved, phModDll);\r\nend;\r\n\r\ntype\r\n TCallFunctionShim = function (szDllName: PWideChar; const szFunctionName: PChar;\r\n const lpvArgument1, lpvArgument2: Pointer; szVersion: PWideChar;\r\n const pvReserved: Pointer): HRESULT; stdcall;\r\n\r\nvar\r\n _CallFunctionShim: TCallFunctionShim = nil;\r\n\r\nfunction CallFunctionShim(szDllName: PWideChar; const szFunctionName: PChar;\r\n const lpvArgument1, lpvArgument2: Pointer; szVersion: PWideChar;\r\n const pvReserved: Pointer): HRESULT;\r\nbegin\r\n GetProcedureAddress(Pointer(@_CallFunctionShim), mscoree_dll, 'CallFunctionShim');\r\n Result := _CallFunctionShim(szDllName, szFunctionName, lpvArgument1, lpvArgument2, szVersion, pvReserved);\r\nend;\r\n\r\ntype\r\n TGetRealProcAddress = function (const pwszProcName: PChar;\r\n out ppv: Pointer): HRESULT; stdcall;\r\n\r\nvar\r\n _GetRealProcAddress: TGetRealProcAddress = nil;\r\n\r\nfunction GetRealProcAddress(const pwszProcName: PChar;\r\n out ppv: Pointer): HRESULT;\r\nbegin\r\n GetProcedureAddress(Pointer(@_GetRealProcAddress), mscoree_dll, 'GetRealProcAddress');\r\n Result := _GetRealProcAddress(pwszProcName, ppv);\r\nend;\r\n\r\ntype\r\n TCorExitProcess = procedure (const exitCode: Integer); stdcall;\r\n\r\nvar\r\n _CorExitProcess: TCorExitProcess = nil;\r\n\r\nprocedure CorExitProcess(const exitCode: Integer);\r\nbegin\r\n GetProcedureAddress(Pointer(@_CorExitProcess), mscoree_dll, 'CorExitProcess');\r\n _CorExitProcess(exitCode);\r\nend;\r\n\r\ntype\r\n TGetRequestedRuntimeVersionForCLSID = function (rclsid: TGuid; pVersion: PWideChar;\r\n const cchBuffer: DWORD; var dwLength: DWORD;\r\n const dwResolutionFlags: CLSID_RESOLUTION_FLAGS): HRESULT; stdcall;\r\n\r\nvar\r\n _GetRequestedRuntimeVersionForCLSID: TGetRequestedRuntimeVersionForCLSID = nil;\r\n\r\nfunction GetRequestedRuntimeVersionForCLSID(rclsid: TGuid; pVersion: PWideChar;\r\n const cchBuffer: DWORD; var dwLength: DWORD;\r\n const dwResolutionFlags: CLSID_RESOLUTION_FLAGS): HRESULT;\r\nbegin\r\n GetProcedureAddress(Pointer(@_GetRequestedRuntimeVersionForCLSID), mscoree_dll, 'GetRequestedRuntimeVersionForCLSID');\r\n Result := _GetRequestedRuntimeVersionForCLSID(rclsid, pVersion, cchBuffer, dwLength, dwResolutionFlags);\r\nend;\r\n\r\n//=== { TJclClrHost } ========================================================\r\n\r\nconstructor TJclClrHost.Create(const ClrVer: WideString; const Flavor: TJclClrHostFlavor;\r\n const ConcurrentGC: Boolean; const LoaderFlags: TJclClrHostLoaderFlags);\r\nconst\r\n ClrHostFlavorNames: array [TJclClrHostFlavor] of WideString = ('srv', 'wks');\r\n ClrHostLoaderFlagValues: array [TJclClrHostLoaderFlag] of DWORD =\r\n (STARTUP_LOADER_OPTIMIZATION_SINGLE_DOMAIN,\r\n STARTUP_LOADER_OPTIMIZATION_MULTI_DOMAIN,\r\n STARTUP_LOADER_OPTIMIZATION_MULTI_DOMAIN_HOST,\r\n STARTUP_LOADER_SAFEMODE,\r\n STARTUP_LOADER_SETPREFERENCE);\r\nvar\r\n Flags: DWORD;\r\n ALoaderFlag: TJclClrHostLoaderFlag;\r\nbegin\r\n inherited Create;\r\n Flags := 0;\r\n if ConcurrentGC then\r\n Flags := Flags or STARTUP_CONCURRENT_GC;\r\n for ALoaderFlag := Low(TJclClrHostLoaderFlag) to High(TJclClrHostLoaderFlag) do\r\n if ALoaderFlag in LoaderFlags then\r\n Flags := Flags or ClrHostLoaderFlagValues[ALoaderFlag];\r\n OleCheck(CorBindToRuntimeEx(PWideCharOrNil(ClrVer),\r\n PWideChar(ClrHostFlavorNames[Flavor]), Flags,\r\n CLASS_CorRuntimeHost, IID_ICorRuntimeHost, FDefaultInterface));\r\nend;\r\n\r\ndestructor TJclClrHost.Destroy;\r\nbegin\r\n FreeAndNil(FAppDomains);\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJclClrHost.EnumAppDomains;\r\nvar\r\n hEnum: Pointer;\r\n Unk: IUnknown;\r\nbegin\r\n if Assigned(FAppDomains) then\r\n FAppDomains.Clear\r\n else\r\n FAppDomains := TObjectList.Create;\r\n\r\n OleCheck(FDefaultInterface.EnumDomains(hEnum));\r\n try\r\n while FDefaultInterface.NextDomain(hEnum, Unk) <> S_FALSE do\r\n TJclClrAppDomain.Create(Self, Unk as _AppDomain);\r\n finally\r\n OleCheck(FDefaultInterface.CloseEnum(hEnum));\r\n end;\r\nend;\r\n\r\nfunction TJclClrHost.FindAppDomain(const Intf: _AppDomain;\r\n var Ret: TJclClrAppDomain): Boolean;\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := 0 to AppDomainCount-1 do\r\n begin\r\n Ret := AppDomains[I];\r\n if Ret.DefaultInterface = Intf then\r\n begin\r\n Result := True;\r\n Exit;\r\n end;\r\n end;\r\n Ret := nil;\r\n Result := False;\r\nend;\r\n\r\nfunction TJclClrHost.FindAppDomain(const Name: WideString;\r\n var Ret: TJclClrAppDomain): Boolean;\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := 0 to AppDomainCount-1 do\r\n begin\r\n Ret := AppDomains[I];\r\n if Ret.DefaultInterface.FriendlyName = Name then\r\n begin\r\n Result := True;\r\n Exit;\r\n end;\r\n end;\r\n Ret := nil;\r\n Result := False;\r\nend;\r\n\r\nfunction TJclClrHost.GetAppDomain(const Idx: Integer): TJclClrAppDomain;\r\nbegin\r\n Result := TJclClrAppDomain(FAppDomains.Items[Idx]);\r\nend;\r\n\r\nfunction TJclClrHost.GetAppDomainCount: Integer;\r\nbegin\r\n Result := FAppDomains.Count;\r\nend;\r\n\r\nfunction TJclClrHost.GetDefaultAppDomain: _AppDomain;\r\nvar\r\n Unk: IUnknown;\r\nbegin\r\n OleCheck(FDefaultInterface.GetDefaultDomain(Unk));\r\n Result := Unk as _AppDomain;\r\nend;\r\n\r\nclass procedure TJclClrHost.GetClrVersions(VersionNames: TWideStrings);\r\n function DirectoryExistsW(const DirectoryName: WideString): Boolean;\r\n var\r\n Code: DWORD;\r\n begin\r\n Code := GetFileAttributesW(PWideChar(DirectoryName));\r\n Result := (Code <> $FFFFFFFF) and ((Code and FILE_ATTRIBUTE_DIRECTORY) <> 0);\r\n end;\r\nconst\r\n WideDirDelimiter: WideChar = '\\';\r\nvar\r\n SystemDirectory: WideString;\r\n Index: Integer;\r\n PathOk: Boolean;\r\n FindData: TWin32FindDataW;\r\n SearchHandle: THandle;\r\n DirectoryBuffer, VersionBuffer: WideString;\r\n DirectoryLength, VersionLength, OldErrorMode, RuntimeInfo: DWORD;\r\nbegin\r\n SystemDirectory := CorSystemDirectory;\r\n\r\n if Pos('V1', AnsiUpperCase(CorVersion)) > 0 then\r\n RunTimeInfo := 0\r\n else\r\n RunTimeInfo := RUNTIME_INFO_DONT_SHOW_ERROR_DIALOG;\r\n\r\n if (SystemDirectory = '') or not DirectoryExistsW(SystemDirectory) then\r\n Exit;\r\n\r\n PathOk := False;\r\n for Index := Length(SystemDirectory) - 1 downto 1 do\r\n if SystemDirectory[Index] = WideDirDelimiter then\r\n begin\r\n SetLength(SystemDirectory, Index);\r\n PathOk := True;\r\n Break;\r\n end;\r\n\r\n if PathOk then\r\n begin\r\n FindData.dwFileAttributes := 0;\r\n SearchHandle := FindFirstFileW(PWideChar(SystemDirectory + '*.*'), FindData);\r\n if SearchHandle = INVALID_HANDLE_VALUE then\r\n Exit;\r\n try\r\n repeat\r\n if ((FindData.dwFileAttributes and FILE_ATTRIBUTE_DIRECTORY) <> 0)\r\n and (WideString(FindData.cFileName) <> '.') and (WideString(FindData.cFileName) <> '..') then\r\n begin\r\n OldErrorMode := SetErrorMode(SEM_FAILCRITICALERRORS);\r\n try\r\n VersionLength := 0;\r\n DirectoryLength := 0;\r\n if (GetRequestedRuntimeInfo(nil, FindData.cFileName, nil, 0, RunTimeInfo,\r\n nil, 0, DirectoryLength, nil, 0, VersionLength) and $1FFF = ERROR_INSUFFICIENT_BUFFER)\r\n and (DirectoryLength > 0) and (VersionLength > 0) then\r\n begin\r\n SetLength(DirectoryBuffer, DirectoryLength - 1);\r\n SetLength(VersionBuffer, VersionLength - 1);\r\n if GetRequestedRuntimeInfo(nil, FindData.cFileName, nil, 0, RUNTIME_INFO_DONT_SHOW_ERROR_DIALOG,\r\n PWideChar(DirectoryBuffer), DirectoryLength, DirectoryLength,\r\n PWideChar(VersionBuffer), VersionLength, VersionLength) = S_OK then\r\n VersionNames.Values[VersionBuffer] := DirectoryBuffer + VersionBuffer;\r\n end;\r\n finally\r\n SetErrorMode(OldErrorMode);\r\n end;\r\n end;\r\n until not FindNextFileW(SearchHandle, FindData);\r\n finally\r\n {$IFDEF HAS_UNITSCOPE}Winapi.{$ENDIF}Windows.FindClose(SearchHandle);\r\n end;\r\n end;\r\nend;\r\n\r\n{$IFNDEF SUPPORTS_UNICODE}\r\nclass procedure TJclClrHost.GetClrVersions(VersionNames: TStrings);\r\nvar\r\n AWideStrings: TWideStrings;\r\n Index: Integer;\r\nbegin\r\n AWideStrings := TWideStringList.Create;\r\n try\r\n GetCLRVersions(AWideStrings);\r\n for Index := 0 to AWideStrings.Count - 1 do\r\n VersionNames.Add(AWideStrings.Strings[Index]);\r\n finally\r\n AWideStrings.Free;\r\n end;\r\nend;\r\n{$ENDIF ~SUPPORTS_UNICODE}\r\n\r\nfunction TJclClrHost.GetCurrentAppDomain: _AppDomain;\r\nvar\r\n Unk: IUnknown;\r\nbegin\r\n OleCheck(FDefaultInterface.CurrentDomain(Unk));\r\n Result := Unk as _AppDomain;\r\nend;\r\n\r\nfunction TJclClrHost.AddAppDomain(const AppDomain: TJclClrAppDomain): Integer;\r\nbegin\r\n Result := FAppDomains.Add(AppDomain);\r\nend;\r\n\r\nfunction TJclClrHost.RemoveAppDomain(const AppDomain: TJclClrAppDomain): Integer;\r\nbegin\r\n Result := FAppDomains.Remove(AppDomain);\r\nend;\r\n\r\nclass function TJclClrHost.CorSystemDirectory: WideString;\r\nvar\r\n Len: DWORD;\r\nbegin\r\n SetLength(Result, MAX_PATH);\r\n Len := 0;\r\n OleCheck(GetCORSystemDirectory(PWideChar(Result), Length(Result), Len));\r\n if Len > 0 then\r\n SetLength(Result, Len - 1);\r\nend;\r\n\r\nclass function TJclClrHost.CorVersion: WideString;\r\nvar\r\n Len: DWORD;\r\nbegin\r\n SetLength(Result, 64);\r\n Len := 0;\r\n OleCheck(GetCORVersion(PWideChar(Result), Length(Result), Len));\r\n if Len > 0 then\r\n SetLength(Result, Len - 1);\r\nend;\r\n\r\nclass function TJclClrHost.CorRequiredVersion: WideString;\r\nvar\r\n Len: DWORD;\r\nbegin\r\n SetLength(Result, 64);\r\n Len := 0;\r\n OleCheck(GetCORRequiredVersion(PWideChar(Result), Length(Result), Len));\r\n if Len > 0 then\r\n SetLength(Result, Len - 1);\r\nend;\r\n\r\nfunction TJclClrHost.CreateDomainSetup: TJclClrAppDomainSetup;\r\nvar\r\n pUnk: IUnknown;\r\nbegin\r\n OleCheck(FDefaultInterface.CreateDomainSetup(pUnk));\r\n Result := TJclClrAppDomainSetup.Create(pUnk as IAppDomainSetup);\r\nend;\r\n\r\nfunction TJclClrHost.CreateAppDomain(const Name: WideString;\r\n const Setup: TJclClrAppDomainSetup;\r\n const Evidence: _Evidence): TJclClrAppDomain;\r\nvar\r\n pUnk: IUnknown;\r\nbegin\r\n OleCheck(FDefaultInterface.CreateDomainEx(PWideChar(Name), Setup as IAppDomainSetup, Evidence, pUnk));\r\n Result := TJclClrAppDomain.Create(Self, pUnk as _AppDomain);\r\nend;\r\n\r\nprocedure TJclClrHost.Start;\r\nbegin\r\n OleCheck(DefaultInterface.Start);\r\n Refresh;\r\nend;\r\n\r\nprocedure TJclClrHost.Stop;\r\nbegin\r\n OleCheck(DefaultInterface.Stop);\r\nend;\r\n\r\nprocedure TJclClrHost.Refresh;\r\nbegin\r\n EnumAppDomains;\r\nend;\r\n\r\n//=== { TJclClrAppDomain } ===================================================\r\n\r\nconstructor TJclClrAppDomain.Create(const AHost: TJclClrHost;\r\n const AAppDomain: _AppDomain);\r\nbegin\r\n Assert(Assigned(AHost));\r\n Assert(Assigned(AAppDomain));\r\n inherited Create;\r\n FHost := AHost;\r\n FDefaultInterface := AAppDomain;\r\n FHost.AddAppDomain(Self);\r\nend;\r\n\r\nfunction TJclClrAppDomain.Execute(const AssemblyFile: TFileName;\r\n const Arguments: TJclClrAssemblyArguments;\r\n const AssemblySecurity: _Evidence): Integer;\r\nvar\r\n Args: Variant;\r\nbegin\r\n Assert(FileExists(AssemblyFile));\r\n if Length(Arguments) = 0 then\r\n Result := Execute(AssemblyFile, AssemblySecurity)\r\n else\r\n begin\r\n Args := 0;\r\n DynArrayToVariant(Args, @Arguments[0], TypeInfo(TJclClrAssemblyArguments));\r\n Result := DefaultInterface.ExecuteAssembly_3(AssemblyFile, AssemblySecurity, PSafeArray(TVarData(Args).VArray));\r\n end;\r\nend;\r\n\r\nfunction TJclClrAppDomain.Execute(const AssemblyFile: TFileName;\r\n const AssemblySecurity: _Evidence): Integer;\r\nbegin\r\n Assert(FileExists(AssemblyFile));\r\n if Assigned(AssemblySecurity) then\r\n Result := DefaultInterface.ExecuteAssembly(AssemblyFile, AssemblySecurity)\r\n else\r\n Result := DefaultInterface.ExecuteAssembly_2(AssemblyFile);\r\nend;\r\n\r\nfunction TJclClrAppDomain.Execute(const AssemblyFile: TFileName;\r\n const Arguments: TStrings; const AssemblySecurity: _Evidence): Integer;\r\nvar\r\n Args: Variant;\r\n Index: Integer;\r\nbegin\r\n Assert(FileExists(AssemblyFile));\r\n if Arguments.Count = 0 then\r\n Result := Execute(AssemblyFile, AssemblySecurity)\r\n else\r\n begin\r\n Args := VarArrayCreate([0, Arguments.Count - 1], varOleStr);\r\n for Index := 0 to Arguments.Count - 1 do\r\n Args[Index] := WideString(Arguments.Strings[Index]);\r\n Result := DefaultInterface.ExecuteAssembly_3(AssemblyFile, AssemblySecurity, PSafeArray(TVarData(Args).VArray));\r\n end;\r\nend;\r\n\r\nfunction TJclClrAppDomain.Load(const AssemblyString: WideString;\r\n const AssemblySecurity: _Evidence): TJclClrAssembly;\r\nbegin\r\n if Assigned(AssemblySecurity) then\r\n Result := TJclClrAssembly.Create(DefaultInterface.Load_7(AssemblyString, AssemblySecurity))\r\n else\r\n Result := TJclClrAssembly.Create(DefaultInterface.Load_2(AssemblyString));\r\nend;\r\n\r\nfunction TJclClrAppDomain.Load(const RawAssemblyStream,\r\n RawSymbolStoreStream: TStream;\r\n const AssemblySecurity: _Evidence): TJclClrAssembly;\r\nvar\r\n RawAssembly, RawSymbolStore: Variant;\r\nbegin\r\n Assert(Assigned(RawAssemblyStream));\r\n RawAssembly := VarArrayCreate([0, RawAssemblyStream.Size-1], varByte);\r\n try\r\n try\r\n RawAssemblyStream.Read(VarArrayLock(RawAssembly)^, RawAssemblyStream.Size);\r\n finally\r\n VarArrayUnlock(RawAssembly);\r\n end;\r\n\r\n if not Assigned(RawSymbolStoreStream) then\r\n Result := TJclClrAssembly.Create(DefaultInterface.Load_3(PSafeArray(TVarData(RawAssembly).VArray)))\r\n else\r\n begin\r\n RawSymbolStore := VarArrayCreate([0, RawSymbolStoreStream.Size-1], varByte);\r\n try\r\n try\r\n RawSymbolStoreStream.Read(VarArrayLock(RawSymbolStore)^, RawSymbolStoreStream.Size);\r\n finally\r\n VarArrayUnlock(RawSymbolStore);\r\n end;\r\n\r\n if Assigned(AssemblySecurity) then\r\n Result := TJclClrAssembly.Create(DefaultInterface.Load_5(\r\n PSafeArray(TVarData(RawAssembly).VArray),\r\n PSafeArray(TVarData(RawSymbolStore).VArray),\r\n AssemblySecurity))\r\n else\r\n Result := TJclClrAssembly.Create(DefaultInterface.Load_4(\r\n PSafeArray(TVarData(RawAssembly).VArray),\r\n PSafeArray(TVarData(RawSymbolStore).VArray)));\r\n finally\r\n VarClear(RawSymbolStore);\r\n end;\r\n end;\r\n finally\r\n VarClear(RawAssembly);\r\n end;\r\nend;\r\n\r\nprocedure TJclClrAppDomain.Unload;\r\nvar\r\n AppDomain: TJclClrAppDomain;\r\nbegin\r\n OleCheck(FHost.DefaultInterface.UnloadDomain(DefaultInterface));\r\n AppDomain := nil;\r\n if FHost.FindAppDomain(DefaultInterface, AppDomain) and (AppDomain = Self) then\r\n FHost.RemoveAppDomain(Self);\r\nend;\r\n\r\n//=== { TJclClrObject } ======================================================\r\n\r\nconstructor TJclClrObject.Create(const AssemblyName, NamespaceName, ClassName: WideString;\r\n const Parameters: array of const);\r\nbegin\r\n inherited Create;\r\nend;\r\n\r\nconstructor TJclClrObject.Create(const AssemblyName, NamespaceName, ClassName: WideString;\r\n const NewInstance: Boolean);\r\nbegin\r\n Create(AssemblyName, NamespaceName, ClassName, []);\r\nend;\r\n\r\nfunction TJclClrObject.GetField(const Name: WideString): TJclClrField;\r\nbegin\r\n // (rom) added to suppress warning until implementation\r\n Result := nil;\r\nend;\r\n\r\nfunction TJclClrObject.GetProperty(const Name: WideString): TJclClrProperty;\r\nbegin\r\n // (rom) added to suppress warning until implementation\r\n Result := nil;\r\nend;\r\n\r\nfunction TJclClrObject.GetMethod(const Name: WideString): TJclClrMethod;\r\nbegin\r\n // (rom) added to suppress warning until implementation\r\n Result := nil;\r\nend;\r\n\r\n//=== { TJclClrAppDomainSetup } ==============================================\r\n\r\nconstructor TJclClrAppDomainSetup.Create(Intf: IAppDomainSetup);\r\nbegin\r\n Assert(Assigned(Intf));\r\n inherited Create;\r\n FDefaultInterface := Intf;\r\nend;\r\n\r\nfunction TJclClrAppDomainSetup.GetApplicationBase: WideString;\r\nbegin\r\n OleCheck(FDefaultInterface.Get_ApplicationBase(Result));\r\nend;\r\n\r\nfunction TJclClrAppDomainSetup.GetApplicationName: WideString;\r\nbegin\r\n OleCheck(FDefaultInterface.Get_ApplicationName(Result));\r\nend;\r\n\r\nfunction TJclClrAppDomainSetup.GetCachePath: WideString;\r\nbegin\r\n OleCheck(FDefaultInterface.Get_CachePath(Result));\r\nend;\r\n\r\nfunction TJclClrAppDomainSetup.GetConfigurationFile: WideString;\r\nbegin\r\n OleCheck(FDefaultInterface.Get_ConfigurationFile(Result));\r\nend;\r\n\r\nfunction TJclClrAppDomainSetup.GetDynamicBase: WideString;\r\nbegin\r\n OleCheck(FDefaultInterface.Get_DynamicBase(Result));\r\nend;\r\n\r\nfunction TJclClrAppDomainSetup.GetLicenseFile: WideString;\r\nbegin\r\n OleCheck(FDefaultInterface.Get_LicenseFile(Result));\r\nend;\r\n\r\nfunction TJclClrAppDomainSetup.GetPrivateBinPath: WideString;\r\nbegin\r\n OleCheck(FDefaultInterface.Get_PrivateBinPath(Result));\r\nend;\r\n\r\nfunction TJclClrAppDomainSetup.GetPrivateBinPathProbe: WideString;\r\nbegin\r\n OleCheck(FDefaultInterface.Get_PrivateBinPathProbe(Result));\r\nend;\r\n\r\nfunction TJclClrAppDomainSetup.GetShadowCopyDirectories: WideString;\r\nbegin\r\n OleCheck(FDefaultInterface.Get_ShadowCopyDirectories(Result));\r\nend;\r\n\r\nfunction TJclClrAppDomainSetup.GetShadowCopyFiles: WideString;\r\nbegin\r\n OleCheck(FDefaultInterface.Get_ShadowCopyFiles(Result));\r\nend;\r\n\r\nprocedure TJclClrAppDomainSetup.SetApplicationBase(const Value: WideString);\r\nbegin\r\n OleCheck(FDefaultInterface.Set_ApplicationBase(Value));\r\nend;\r\n\r\nprocedure TJclClrAppDomainSetup.SetApplicationName(const Value: WideString);\r\nbegin\r\n OleCheck(FDefaultInterface.Set_ApplicationName(Value));\r\nend;\r\n\r\nprocedure TJclClrAppDomainSetup.SetCachePath(const Value: WideString);\r\nbegin\r\n OleCheck(FDefaultInterface.Set_CachePath(Value));\r\nend;\r\n\r\nprocedure TJclClrAppDomainSetup.SetConfigurationFile(const Value: WideString);\r\nbegin\r\n OleCheck(FDefaultInterface.Set_ConfigurationFile(Value));\r\nend;\r\n\r\nprocedure TJclClrAppDomainSetup.SetDynamicBase(const Value: WideString);\r\nbegin\r\n OleCheck(FDefaultInterface.Set_DynamicBase(Value));\r\nend;\r\n\r\nprocedure TJclClrAppDomainSetup.SetLicenseFile(const Value: WideString);\r\nbegin\r\n OleCheck(FDefaultInterface.Set_LicenseFile(Value));\r\nend;\r\n\r\nprocedure TJclClrAppDomainSetup.SetPrivateBinPath(const Value: WideString);\r\nbegin\r\n OleCheck(FDefaultInterface.Set_PrivateBinPath(Value));\r\nend;\r\n\r\nprocedure TJclClrAppDomainSetup.SetPrivateBinPathProbe(const Value: WideString);\r\nbegin\r\n OleCheck(FDefaultInterface.Set_PrivateBinPathProbe(Value));\r\nend;\r\n\r\nprocedure TJclClrAppDomainSetup.SetShadowCopyDirectories(const Value: WideString);\r\nbegin\r\n OleCheck(FDefaultInterface.Set_ShadowCopyDirectories(Value));\r\nend;\r\n\r\nprocedure TJclClrAppDomainSetup.SetShadowCopyFiles(const Value: WideString);\r\nbegin\r\n OleCheck(FDefaultInterface.Set_ShadowCopyFiles(Value));\r\nend;\r\n\r\n//=== { TJclClrAssembly } ====================================================\r\n\r\nconstructor TJclClrAssembly.Create(Intf: _Assembly);\r\nbegin\r\n Assert(Assigned(Intf));\r\n inherited Create;\r\n FDefaultInterface := Intf;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jcl/source/windows/JclHelpUtils.pas", "content": "{**************************************************************************************************}\r\n{ }\r\n{ Project JEDI Code Library (JCL) }\r\n{ }\r\n{ The contents of this file are subject to the Mozilla Public License Version 1.1 (the \"License\"); }\r\n{ you may not use this file except in compliance with the License. You may obtain a copy of the }\r\n{ License at http://www.mozilla.org/MPL/ }\r\n{ }\r\n{ Software distributed under the License is distributed on an \"AS IS\" basis, WITHOUT WARRANTY OF }\r\n{ ANY KIND, either express or implied. See the License for the specific language governing rights }\r\n{ and limitations under the License. }\r\n{ }\r\n{ The Original Code is DelphiInstall.pas. }\r\n{ }\r\n{ The Initial Developer of the Original Code is Petr Vones. Portions created by Petr Vones are }\r\n{ Copyright (C) of Petr Vones. All Rights Reserved. }\r\n{ }\r\n{ Contributor(s): }\r\n{ Andreas Hausladen (ahuser) }\r\n{ Florent Ouchet (outchy) }\r\n{ Robert Marquardt (marquardt) }\r\n{ Robert Rossmair (rrossmair) - crossplatform & BCB support }\r\n{ Uwe Schuster (uschuster) }\r\n{ }\r\n{**************************************************************************************************}\r\n{ }\r\n{ Last modified: $Date:: 2012-09-04 16:08:04 +0200 (mar. 04 sept. 2012) $ }\r\n{ Revision: $Rev:: 3861 $ }\r\n{ Author: $Author:: outchy $ }\r\n{ }\r\n{**************************************************************************************************}\r\n\r\nunit JclHelpUtils;\r\n\r\n{$I jcl.inc}\r\n{$I crossplatform.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n MSHelpServices_TLB,\r\n {$IFDEF HAS_UNITSCOPE}\r\n System.Classes, System.SysUtils,\r\n {$ELSE ~HAS_UNITSCOPE}\r\n Classes, SysUtils,\r\n {$ENDIF ~HAS_UNITSCOPE}\r\n JclBase, JclSysUtils;\r\n\r\n// Various definitions\r\ntype\r\n EJclHelpUtilsException = class(EJclError);\r\n\r\ntype\r\n TJclBorlandOpenHelp = class\r\n private\r\n FHelpPrefix: string;\r\n FRootDirectory: string;\r\n function GetContentFileName: string;\r\n function GetIndexFileName: string;\r\n function GetLinkFileName: string;\r\n function GetGidFileName: string;\r\n function GetProjectFileName: string;\r\n function ReadFileName(const FormatName: string): string;\r\n public\r\n constructor Create(const ARootDirectory, AHelpPrefix: string);\r\n function AddHelpFile(const HelpFileName, IndexName: string): Boolean;\r\n function RemoveHelpFile(const HelpFileName, IndexName: string): Boolean;\r\n property ContentFileName: string read GetContentFileName;\r\n property GidFileName: string read GetGidFileName;\r\n property HelpPrefix: string read FHelpPrefix;\r\n property IndexFileName: string read GetIndexFileName;\r\n property LinkFileName: string read GetLinkFileName;\r\n property ProjectFileName: string read GetProjectFileName;\r\n property RootDirectory: string read FRootDirectory;\r\n end;\r\n\r\n TJclHelp2Object = (hoRegisterSession, hoRegister, hoPlugin);\r\n TJclHelp2Objects = set of TJclHelp2Object;\r\n\r\n TJclHelp2Manager = class\r\n private\r\n FHxRegisterSession: IHxRegisterSession;\r\n FHxRegister: IHxRegister;\r\n FHxPlugin: IHxPlugIn;\r\n FIdeNameSpace: WideString;\r\n function RequireObject(HelpObjects: TJclHelp2Objects): Boolean;\r\n function GetHxPlugin: IHxPlugin;\r\n function GetHxRegister: IHxRegister;\r\n function GetHxRegisterSession: IHxRegisterSession;\r\n public\r\n constructor Create(IDEVersionNumber: Integer);\r\n destructor Destroy; override;\r\n function CreateTransaction: Boolean;\r\n function CommitTransaction: Boolean;\r\n function RegisterNameSpace(const Name, Collection, Description: WideString): Boolean;\r\n function UnregisterNameSpace(const Name: WideString): Boolean;\r\n function RegisterHelpFile(const NameSpace, Identifier: WideString;\r\n const LangId: Integer; const HxSFile, HxIFile: WideString): Boolean;\r\n function UnregisterHelpFile(const NameSpace, Identifier: WideString;\r\n const LangId: Integer): Boolean;\r\n function PlugNameSpaceIn(const SourceNameSpace,\r\n TargetNameSpace: WideString): Boolean;\r\n function UnPlugNameSpace(const SourceNameSpace,\r\n TargetNameSpace: WideString): Boolean;\r\n function PlugNameSpaceInBorlandHelp(const NameSpace: WideString): Boolean;\r\n function UnPlugNameSpaceFromBorlandHelp(const NameSpace: WideString): Boolean;\r\n property HxRegisterSession: IHxRegisterSession read GetHxRegisterSession;\r\n property HxRegister: IHxRegister read GetHxRegister;\r\n property HxPlugin: IHxPlugin read GetHxPlugin;\r\n property IdeNamespace: WideString read FIdeNameSpace;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jcl.svn.sourceforge.net/svnroot/jcl/tags/JCL-2.4-Build4571/jcl/source/windows/JclHelpUtils.pas $';\r\n Revision: '$Revision: 3861 $';\r\n Date: '$Date: 2012-09-04 16:08:04 +0200 (mar. 04 sept. 2012) $';\r\n LogPath: 'JCL\\source\\windows';\r\n Extra: '';\r\n Data: nil\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n {$IFDEF HAS_UNITSCOPE}\r\n Winapi.Windows,\r\n {$ELSE ~HAS_UNITSCOPE}\r\n Windows,\r\n {$ENDIF ~HAS_UNITSCOPE}\r\n JclRegistry,\r\n {$IFDEF HAS_UNIT_LIBC}\r\n Libc,\r\n {$ENDIF HAS_UNIT_LIBC}\r\n JclFileUtils, JclDevToolsResources;\r\n\r\ntype\r\n TBDSVersionInfo = record\r\n Name: PResStringRec;\r\n VersionStr: string;\r\n Version: Integer;\r\n CoreIdeVersion: string;\r\n Supported: Boolean;\r\n end;\r\n\r\nconst\r\n MSHelpSystemKeyName = '\\SOFTWARE\\Microsoft\\Windows\\Help';\r\n\r\n HelpContentFileName = '%s\\Help\\%s.ohc';\r\n HelpIndexFileName = '%s\\Help\\%s.ohi';\r\n HelpLinkFileName = '%s\\Help\\%s.ohl';\r\n HelpProjectFileName = '%s\\Help\\%s.ohp';\r\n HelpGidFileName = '%s\\Help\\%s.gid';\r\n\r\n//=== { TJclBorlandOpenHelp } ================================================\r\n\r\nfunction TJclBorlandOpenHelp.AddHelpFile(const HelpFileName, IndexName: string): Boolean;\r\nvar\r\n CntFileName, HelpName, CntName: string;\r\n List: TStringList;\r\n\r\n procedure AddToList(const FileName, Text: string);\r\n var\r\n I, Attr: Integer;\r\n Found: Boolean;\r\n begin\r\n List.LoadFromFile(FileName);\r\n Found := False;\r\n for I := 0 to List.Count - 1 do\r\n if AnsiSameText(Trim(List[I]), Text) then\r\n begin\r\n Found := True;\r\n Break;\r\n end;\r\n if not Found then\r\n begin\r\n List.Add(Text);\r\n Attr := FileGetAttr(FileName);\r\n FileSetAttr(FileName, faArchive);\r\n List.SaveToFile(FileName);\r\n FileSetAttr(FileName, Attr);\r\n end;\r\n end;\r\n\r\nbegin\r\n CntFileName := ChangeFileExt(HelpFileName, '.cnt');\r\n Result := FileExists(HelpFileName) and FileExists(CntFileName);\r\n if Result then\r\n begin\r\n HelpName := ExtractFileName(HelpFileName);\r\n CntName := ExtractFileName(CntFileName);\r\n RegWriteString(HKLM, MSHelpSystemKeyName, HelpName, ExtractFilePath(HelpFileName));\r\n RegWriteString(HKLM, MSHelpSystemKeyName, CntName, ExtractFilePath(CntFileName));\r\n List := TStringList.Create;\r\n try\r\n AddToList(ContentFileName, Format(':Include %s', [CntName]));\r\n AddToList(LinkFileName, Format(':Link %s', [HelpName]));\r\n AddToList(IndexFileName, Format(':Index %s=%s', [IndexName, HelpName]));\r\n SetFileLastWrite(ProjectFileName, Now);\r\n FileDelete(GidFileName);\r\n finally\r\n List.Free;\r\n end;\r\n end;\r\nend;\r\n\r\nconstructor TJclBorlandOpenHelp.Create(const ARootDirectory,\r\n AHelpPrefix: string);\r\nbegin\r\n inherited Create;\r\n FHelpPrefix := AHelpPrefix;\r\n FRootDirectory := ARootDirectory;\r\nend;\r\n\r\nfunction TJclBorlandOpenHelp.GetContentFileName: string;\r\nbegin\r\n Result := ReadFileName(HelpContentFileName);\r\nend;\r\n\r\nfunction TJclBorlandOpenHelp.GetGidFileName: string;\r\nbegin\r\n Result := ReadFileName(HelpGidFileName);\r\nend;\r\n\r\nfunction TJclBorlandOpenHelp.GetIndexFileName: string;\r\nbegin\r\n Result := ReadFileName(HelpIndexFileName);\r\nend;\r\n\r\nfunction TJclBorlandOpenHelp.GetLinkFileName: string;\r\nbegin\r\n Result := ReadFileName(HelpLinkFileName);\r\nend;\r\n\r\nfunction TJclBorlandOpenHelp.GetProjectFileName: string;\r\nbegin\r\n Result := ReadFileName(HelpProjectFileName);\r\nend;\r\n\r\nfunction TJclBorlandOpenHelp.ReadFileName(const FormatName: string): string;\r\nbegin\r\n if HelpPrefix <> '' then\r\n Result := Format(FormatName, [RootDirectory, HelpPrefix])\r\n else\r\n raise EJclHelpUtilsException.CreateRes(@RsENoOpenHelp);\r\nend;\r\n\r\nfunction TJclBorlandOpenHelp.RemoveHelpFile(const HelpFileName, IndexName: string): Boolean;\r\nvar\r\n CntFileName, HelpName, CntName: string;\r\n List: TStringList;\r\n\r\n procedure RemoveFromList(const FileName, Text: string);\r\n var\r\n I, Attr: Integer;\r\n Found: Boolean;\r\n begin\r\n List.LoadFromFile(FileName);\r\n Found := False;\r\n for I := 0 to List.Count - 1 do\r\n if AnsiSameText(Trim(List[I]), Text) then\r\n begin\r\n Found := True;\r\n List.Delete(I);\r\n Break;\r\n end;\r\n if Found then\r\n begin\r\n Attr := FileGetAttr(FileName);\r\n FileSetAttr(FileName, faArchive);\r\n List.SaveToFile(FileName);\r\n FileSetAttr(FileName, Attr);\r\n end;\r\n end;\r\n\r\nbegin\r\n CntFileName := ChangeFileExt(HelpFileName, '.cnt');\r\n Result := FileExists(HelpFileName) and FileExists(CntFileName);\r\n if Result then\r\n begin\r\n HelpName := ExtractFileName(HelpFileName);\r\n CntName := ExtractFileName(CntFileName);\r\n //RegDeleteEntry(HKEY_LOCAL_MACHINE, MSHelpSystemKeyName, HelpName);\r\n //RegDeleteEntry(HKEY_LOCAL_MACHINE, MSHelpSystemKeyName, CntName);\r\n List := TStringList.Create;\r\n try\r\n RemoveFromList(ContentFileName, Format(':Include %s', [CntName]));\r\n RemoveFromList(LinkFileName, Format(':Link %s', [HelpName]));\r\n RemoveFromList(IndexFileName, Format(':Index %s=%s', [IndexName, HelpName]));\r\n SetFileLastWrite(ProjectFileName, Now);\r\n FileDelete(GidFileName);\r\n finally\r\n List.Free;\r\n end;\r\n end;\r\nend;\r\n\r\n//== { TJclHelp2Manager } ====================================================\r\n\r\nconst\r\n Help2BorlandNameSpace = 'Borland.BDS%d';\r\n Help2DefaultKeyWord = '_DEFAULT';\r\n\r\nconstructor TJclHelp2Manager.Create(IDEVersionNumber: Integer);\r\nbegin\r\n inherited Create;\r\n FHxRegisterSession := nil;\r\n FHxRegister := nil;\r\n FHxPlugin := nil;\r\n if IDEVersionNumber > 0 then\r\n begin\r\n if (IDEVersionNumber = 10) then\r\n FIdeNameSpace := 'embarcadero.rs_xe3'\r\n else\r\n if (IDEVersionNumber = 9) then\r\n FIdeNameSpace := 'embarcadero.rs_xe2'\r\n else\r\n if (IDEVersionNumber = 8) then\r\n FIdeNameSpace := 'embarcadero.rs_xe'\r\n else\r\n if (IDEVersionNumber = 7) then\r\n FIdeNameSpace := 'embarcadero.rs2010'\r\n else\r\n if (IDEVersionNumber = 6) then\r\n FIdeNameSpace := 'embarcadero.rs2009'\r\n else\r\n FIdeNameSpace := Format(Help2BorlandNameSpace, [IDEVersionNumber]);\r\n end\r\n else\r\n FIdeNameSpace := '';\r\nend;\r\n\r\ndestructor TJclHelp2Manager.Destroy;\r\nbegin\r\n FHxRegisterSession := nil;\r\n FHxRegister := nil;\r\n FHxPlugin := nil;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJclHelp2Manager.CommitTransaction: Boolean;\r\nbegin\r\n Result := RequireObject([hoRegisterSession]);\r\n if Result then\r\n begin\r\n try\r\n FHxRegisterSession.CommitTransaction;\r\n except\r\n Result := False;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJclHelp2Manager.CreateTransaction: Boolean;\r\nbegin\r\n Result := RequireObject([hoRegisterSession]);\r\n if Result then\r\n begin\r\n try\r\n FHxRegisterSession.CreateTransaction('');\r\n except\r\n Result := False;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJclHelp2Manager.GetHxPlugin: IHxPlugin;\r\nbegin\r\n RequireObject([hoPlugin]);\r\n Result := FHxPlugin;\r\nend;\r\n\r\nfunction TJclHelp2Manager.GetHxRegister: IHxRegister;\r\nbegin\r\n RequireObject([hoRegister]);\r\n Result := FHxRegister;\r\nend;\r\n\r\nfunction TJclHelp2Manager.GetHxRegisterSession: IHxRegisterSession;\r\nbegin\r\n RequireObject([hoRegisterSession]);\r\n Result := FHxRegisterSession;\r\nend;\r\n\r\nfunction TJclHelp2Manager.PlugNameSpaceIn(const SourceNameSpace, TargetNameSpace: WideString): Boolean;\r\nvar\r\n Help2Default: WideString;\r\nbegin\r\n Result := RequireObject([hoPlugin]);\r\n if Result then\r\n begin\r\n try\r\n Help2Default := Help2DefaultKeyWord;\r\n FHxPlugin.RegisterHelpPlugIn(TargetNameSpace, Help2Default,\r\n SourceNameSpace, Help2Default, '', 0);\r\n except\r\n Result := False;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJclHelp2Manager.PlugNameSpaceInBorlandHelp(\r\n const NameSpace: WideString): Boolean;\r\nbegin\r\n Result := (IdeNamespace <> '') and PlugNameSpaceIn(NameSpace, IdeNamespace);\r\nend;\r\n\r\nfunction TJclHelp2Manager.RegisterHelpFile(const NameSpace, Identifier: WideString;\r\n const LangId: Integer; const HxSFile, HxIFile: WideString): Boolean;\r\nbegin\r\n Result := RequireObject([hoRegister]);\r\n if Result then\r\n begin\r\n try\r\n FHxRegister.RegisterHelpFileSet(NameSpace, Identifier, LangId, HxSFile,\r\n HxIFile, '', '', 0, 0, 0, 0);\r\n except\r\n Result := False;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJclHelp2Manager.RegisterNameSpace(const Name, Collection, Description: WideString): Boolean;\r\nbegin\r\n Result := RequireObject([hoRegister]);\r\n if Result then\r\n begin\r\n try\r\n FHxRegister.RegisterNamespace(Name, Collection, Description);\r\n except\r\n Result := False;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJclHelp2Manager.RequireObject(HelpObjects: TJclHelp2Objects): Boolean;\r\nbegin\r\n // dependencies\r\n if (hoRegister in HelpObjects) or (hoPlugin in HelpObjects) then\r\n Include(HelpObjects, hoRegisterSession);\r\n\r\n Result := True;\r\n\r\n if (hoRegisterSession in HelpObjects) and not Assigned(FHxRegisterSession) then\r\n begin\r\n try\r\n FHxRegisterSession := CoHxRegisterSession.Create;\r\n except\r\n Result := False;\r\n end;\r\n end;\r\n\r\n if Result and (hoRegister in HelpObjects) and not Assigned(FHxRegister) then\r\n begin\r\n try\r\n Result := Supports(FHxRegisterSession.GetRegistrationObject(HxRegisterSession_IHxRegister),\r\n IHxRegister, FHxRegister);\r\n except\r\n Result := False;\r\n end;\r\n end;\r\n\r\n if Result and (hoPlugin in HelpObjects) and not Assigned(FHxPlugin) then\r\n begin\r\n try\r\n Result := Supports(FHxRegisterSession.GetRegistrationObject(HxRegisterSession_IHxPlugIn),\r\n IHxPlugin, FHxPlugin);\r\n except\r\n Result := False;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJclHelp2Manager.UnPlugNameSpace(const SourceNameSpace, TargetNameSpace: WideString): Boolean;\r\nvar\r\n Help2Default: WideString;\r\nbegin\r\n Result := RequireObject([hoPlugin]);\r\n if Result then\r\n begin\r\n try\r\n Help2Default := Help2DefaultKeyWord;\r\n FHxPlugin.RemoveHelpPlugIn(TargetNameSpace, Help2Default,\r\n SourceNameSpace, Help2Default, '');\r\n except\r\n Result := False;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJclHelp2Manager.UnPlugNameSpaceFromBorlandHelp(const NameSpace: WideString): Boolean;\r\nbegin\r\n Result := (IdeNamespace <> '') and UnPlugNameSpace(NameSpace, IdeNamespace);\r\nend;\r\n\r\nfunction TJclHelp2Manager.UnregisterHelpFile(const NameSpace, Identifier: WideString;\r\n const LangId: Integer): Boolean;\r\nbegin\r\n Result := RequireObject([hoRegister]);\r\n if Result then\r\n begin\r\n try\r\n FHxRegister.RemoveHelpFile(NameSpace, Identifier, LangId);\r\n except\r\n Result := False;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJclHelp2Manager.UnregisterNameSpace(const Name: WideString): Boolean;\r\nbegin\r\n Result := RequireObject([hoRegister]);\r\n if Result then\r\n begin\r\n try\r\n FHxRegister.RemoveNamespace(Name);\r\n except\r\n Result := False;\r\n end;\r\n end;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n\r\n" }, { "path": "External/Jedi/Jcl/source/windows/JclHookExcept.pas", "content": "{**************************************************************************************************}\r\n{ }\r\n{ Project JEDI Code Library (JCL) }\r\n{ }\r\n{ The contents of this file are subject to the Mozilla Public License Version 1.1 (the \"License\"); }\r\n{ you may not use this file except in compliance with the License. You may obtain a copy of the }\r\n{ License at http://www.mozilla.org/MPL/ }\r\n{ }\r\n{ Software distributed under the License is distributed on an \"AS IS\" basis, WITHOUT WARRANTY OF }\r\n{ ANY KIND, either express or implied. See the License for the specific language governing rights }\r\n{ and limitations under the License. }\r\n{ }\r\n{ The Original Code is JclHookExcept.pas. }\r\n{ }\r\n{ The Initial Developer of the Original Code is Petr Vones. Portions created by Petr Vones are }\r\n{ Copyright (C) Petr Vones. All Rights Reserved. }\r\n{ }\r\n{ Contributor(s): }\r\n{ Petr Vones (pvones) }\r\n{ Robert Marquardt (marquardt) }\r\n{ Andreas Hausladen (ahuser) }\r\n{ }\r\n{**************************************************************************************************}\r\n{ }\r\n{ Exception hooking routines }\r\n{ }\r\n{**************************************************************************************************}\r\n{ }\r\n{ Last modified: $Date:: 2012-09-04 16:08:04 +0200 (mar. 04 sept. 2012) $ }\r\n{ Revision: $Rev:: 3861 $ }\r\n{ Author: $Author:: outchy $ }\r\n{ }\r\n{**************************************************************************************************}\r\n\r\nunit JclHookExcept;\r\n\r\ninterface\r\n\r\n{$I jcl.inc}\r\n{$I windowsonly.inc}\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n {$IFDEF HAS_UNITSCOPE}\r\n Winapi.Windows, System.SysUtils, System.Classes;\r\n {$ELSE ~HAS_UNITSCOPE}\r\n Windows, SysUtils, Classes;\r\n {$ENDIF ~HAS_UNITSCOPE}\r\n\r\ntype\r\n // Exception hooking notifiers routines\r\n{$IFDEF BORLAND}\r\n TJclExceptFilterProc = function(ExceptRecord: PExceptionRecord): Exception;\r\n{$ENDIF BORLAND}\r\n TJclExceptNotifyProc = procedure(ExceptObj: TObject; ExceptAddr: Pointer; OSException: Boolean);\r\n TJclExceptNotifyProcEx = procedure(ExceptObj: TObject; ExceptAddr: Pointer; OSException: Boolean; StackPointer: Pointer);\r\n TJclExceptNotifyMethod = procedure(ExceptObj: TObject; ExceptAddr: Pointer; OSException: Boolean) of object;\r\n\r\n TJclExceptNotifyPriority = (npNormal, npFirstChain);\r\n\r\n{$IFDEF BORLAND}\r\nfunction JclAddExceptFilter(const FilterProc: TJclExceptFilterProc; Priority: TJclExceptNotifyPriority = npNormal): Boolean;\r\n{$ENDIF BORLAND}\r\nfunction JclAddExceptNotifier(const NotifyProc: TJclExceptNotifyProc; Priority: TJclExceptNotifyPriority = npNormal): Boolean; overload;\r\nfunction JclAddExceptNotifier(const NotifyProc: TJclExceptNotifyProcEx; Priority: TJclExceptNotifyPriority = npNormal): Boolean; overload;\r\nfunction JclAddExceptNotifier(const NotifyMethod: TJclExceptNotifyMethod; Priority: TJclExceptNotifyPriority = npNormal): Boolean; overload;\r\n\r\n{$IFDEF BORLAND}\r\nfunction JclRemoveExceptFilter(const FilterProc: TJclExceptFilterProc): Boolean;\r\n{$ENDIF BORLAND}\r\nfunction JclRemoveExceptNotifier(const NotifyProc: TJclExceptNotifyProc): Boolean; overload;\r\nfunction JclRemoveExceptNotifier(const NotifyProc: TJclExceptNotifyProcEx): Boolean; overload;\r\nfunction JclRemoveExceptNotifier(const NotifyMethod: TJclExceptNotifyMethod): Boolean; overload;\r\n\r\nprocedure JclReplaceExceptObj(NewExceptObj: Exception);\r\n\r\n// Exception hooking routines\r\nfunction JclHookExceptions: Boolean;\r\nfunction JclUnhookExceptions: Boolean;\r\nfunction JclExceptionsHooked: Boolean;\r\n\r\nfunction JclHookExceptionsInModule(Module: HMODULE): Boolean;\r\nfunction JclUnhookExceptionsInModule(Module: HMODULE): Boolean;\r\n\r\n// Exceptions hooking in libraries\r\ntype\r\n TJclModuleArray = array of HMODULE;\r\n\r\nfunction JclInitializeLibrariesHookExcept: Boolean;\r\nfunction JclHookedExceptModulesList(out ModulesList: TJclModuleArray): Boolean;\r\n\r\n// Hooking routines location info helper\r\nfunction JclBelongsHookedCode(Address: Pointer): Boolean;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jcl.svn.sourceforge.net/svnroot/jcl/tags/JCL-2.4-Build4571/jcl/source/windows/JclHookExcept.pas $';\r\n Revision: '$Revision: 3861 $';\r\n Date: '$Date: 2012-09-04 16:08:04 +0200 (mar. 04 sept. 2012) $';\r\n LogPath: 'JCL\\source\\windows';\r\n Extra: '';\r\n Data: nil\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n JclBase,\r\n JclPeImage,\r\n JclSysInfo, JclSysUtils, KOLDetours; // WORKAROUND voor UPX, //AM\r\n\r\ntype\r\n PExceptionArguments = ^TExceptionArguments;\r\n TExceptionArguments = record\r\n ExceptAddr: Pointer;\r\n ExceptObj: Exception;\r\n end;\r\n\r\n{$IFDEF BORLAND}\r\n TFilterItem = class(TObject)\r\n private\r\n FExceptFilterProc: TJclExceptFilterProc;\r\n FPriority: TJclExceptNotifyPriority;\r\n public\r\n constructor Create(const ExceptFilterProc: TJclExceptFilterProc; APriority: TJclExceptNotifyPriority);\r\n function DoFilterException(ExceptRecord: PExceptionRecord; out ExceptObj: Exception): Boolean;\r\n property Priority: TJclExceptNotifyPriority read FPriority;\r\n end;\r\n{$ENDIF BORLAND}\r\n\r\n TNotifierItem = class(TObject)\r\n private\r\n FNotifyMethod: TJclExceptNotifyMethod;\r\n FNotifyProc: TJclExceptNotifyProc;\r\n FNotifyProcEx: TJclExceptNotifyProcEx;\r\n FPriority: TJclExceptNotifyPriority;\r\n public\r\n constructor Create(const NotifyProc: TJclExceptNotifyProc; Priority: TJclExceptNotifyPriority); overload;\r\n constructor Create(const NotifyProc: TJclExceptNotifyProcEx; Priority: TJclExceptNotifyPriority); overload;\r\n constructor Create(const NotifyMethod: TJclExceptNotifyMethod; Priority: TJclExceptNotifyPriority); overload;\r\n procedure DoNotify(ExceptObj: TObject; ExceptAddr: Pointer; OSException: Boolean; StackPointer: Pointer);\r\n property Priority: TJclExceptNotifyPriority read FPriority;\r\n end;\r\n\r\nvar\r\n ExceptionsHooked: Boolean;\r\n Kernel32_RaiseException: procedure (dwExceptionCode, dwExceptionFlags,\r\n nNumberOfArguments: DWORD; lpArguments: PDWORD); stdcall;\r\n {$IFDEF BORLAND}\r\n SysUtils_ExceptObjProc: function (P: PExceptionRecord): Exception;\r\n {$ENDIF BORLAND}\r\n {$IFDEF FPC}\r\n SysUtils_ExceptProc: TExceptProc;\r\n {$ENDIF FPC}\r\n Notifiers: TThreadList;\r\n {$IFDEF BORLAND}\r\n Filters: TThreadList;\r\n {$ENDIF BORLAND}\r\n\r\n{$IFDEF HOOK_DLL_EXCEPTIONS}\r\nconst\r\n JclHookExceptDebugHookName = '__JclHookExcept';\r\n\r\ntype\r\n TJclHookExceptDebugHook = procedure(Module: HMODULE; Hook: Boolean); stdcall;\r\n\r\n TJclHookExceptModuleList = class(TObject)\r\n private\r\n FModules: TThreadList;\r\n protected\r\n procedure HookStaticModules;\r\n public\r\n constructor Create;\r\n destructor Destroy; override;\r\n class function JclHookExceptDebugHookAddr: Pointer;\r\n procedure HookModule(Module: HMODULE);\r\n procedure List(out ModulesList: TJclModuleArray);\r\n procedure UnhookModule(Module: HMODULE);\r\n end;\r\n\r\nvar\r\n HookExceptModuleList: TJclHookExceptModuleList;\r\n JclHookExceptDebugHook: Pointer;\r\n\r\nexports\r\n JclHookExceptDebugHook name JclHookExceptDebugHookName;\r\n{$ENDIF HOOK_DLL_EXCEPTIONS}\r\n\r\n{$STACKFRAMES OFF}\r\n\r\nthreadvar\r\n Recursive: Boolean;\r\n NewResultExc: Exception;\r\n\r\n//=== Helper routines ========================================================\r\n\r\nfunction RaiseExceptionAddress: Pointer;\r\nbegin\r\n Result := GetProcAddress(GetModuleHandle(kernel32), 'RaiseException');\r\n Assert(Result <> nil);\r\nend;\r\n\r\nprocedure FreeThreadObjList(var TheList: TThreadList);\r\nvar\r\n I: Integer;\r\nbegin\r\n with TheList.LockList do\r\n try\r\n for I := 0 to Count - 1 do\r\n TObject(Items[I]).Free;\r\n finally\r\n TheList.UnlockList;\r\n end;\r\n FreeAndNil(TheList);\r\nend;\r\n\r\n//=== { TFilterItem } ========================================================\r\n\r\n{$IFDEF BORLAND}\r\nconstructor TFilterItem.Create(const ExceptFilterProc: TJclExceptFilterProc; APriority: TJclExceptNotifyPriority);\r\nbegin\r\n FExceptFilterProc := ExceptFilterProc;\r\n FPriority := APriority;\r\nend;\r\n\r\nfunction TFilterItem.DoFilterException(ExceptRecord: PExceptionRecord; out ExceptObj: Exception): Boolean;\r\nbegin\r\n if Assigned(FExceptFilterProc) then\r\n begin\r\n ExceptObj := FExceptFilterProc(ExceptRecord);\r\n Result := ExceptObj <> nil;\r\n end\r\n else\r\n Result := False;\r\nend;\r\n{$ENDIF BORLAND}\r\n\r\n//=== { TNotifierItem } ======================================================\r\n\r\nconstructor TNotifierItem.Create(const NotifyProc: TJclExceptNotifyProc; Priority: TJclExceptNotifyPriority);\r\nbegin\r\n inherited Create;\r\n FNotifyProc := NotifyProc;\r\n FPriority := Priority;\r\nend;\r\n\r\nconstructor TNotifierItem.Create(const NotifyProc: TJclExceptNotifyProcEx; Priority: TJclExceptNotifyPriority);\r\nbegin\r\n inherited Create;\r\n FNotifyProcEx := NotifyProc;\r\n FPriority := Priority;\r\nend;\r\n\r\nconstructor TNotifierItem.Create(const NotifyMethod: TJclExceptNotifyMethod; Priority: TJclExceptNotifyPriority);\r\nbegin\r\n inherited Create;\r\n FNotifyMethod := NotifyMethod;\r\n FPriority := Priority;\r\nend;\r\n\r\nprocedure TNotifierItem.DoNotify(ExceptObj: TObject; ExceptAddr: Pointer;\r\n OSException: Boolean; StackPointer: Pointer);\r\nbegin\r\n if Assigned(FNotifyProc) then\r\n FNotifyProc(ExceptObj, ExceptAddr, OSException)\r\n else\r\n if Assigned(FNotifyProcEx) then\r\n FNotifyProcEx(ExceptObj, ExceptAddr, OSException, StackPointer)\r\n else\r\n if Assigned(FNotifyMethod) then\r\n FNotifyMethod(ExceptObj, ExceptAddr, OSException);\r\nend;\r\n\r\nfunction GetFramePointer: Pointer;\r\nasm\r\n {$IFDEF CPU32}\r\n MOV EAX, EBP\r\n {$ENDIF CPU32}\r\n {$IFDEF CPU64}\r\n MOV RAX, RBP\r\n {$ENDIF CPU64}\r\nend;\r\n\r\n{$STACKFRAMES ON}\r\n\r\n{$IFDEF BORLAND}\r\nfunction DoExceptFilter(ExceptRecord: PExceptionRecord): Exception;\r\nvar\r\n Priorities: TJclExceptNotifyPriority;\r\n I: Integer;\r\nbegin\r\n if Recursive then\r\n Exit;\r\n if Assigned(Filters) then\r\n begin\r\n Recursive := True;\r\n try\r\n with Filters.LockList do\r\n try\r\n for Priorities := High(Priorities) downto Low(Priorities) do\r\n for I := 0 to Count - 1 do\r\n with TFilterItem(Items[I]) do\r\n if Priority = Priorities then\r\n if DoFilterException(ExceptRecord, Result) then\r\n Exit;\r\n finally\r\n Filters.UnlockList;\r\n end;\r\n // Nobody wanted to handle the external exception. Call the default handler.\r\n Result := SysUtils_ExceptObjProc(ExceptRecord);\r\n finally\r\n Recursive := False;\r\n end;\r\n end;\r\nend;\r\n{$ENDIF BORLAND}\r\n\r\nprocedure DoExceptNotify(ExceptObj: TObject; ExceptAddr: Pointer; OSException: Boolean; StackPointer: Pointer);\r\nvar\r\n Priorities: TJclExceptNotifyPriority;\r\n I: Integer;\r\nbegin\r\n if Recursive then\r\n Exit;\r\n if Assigned(Notifiers) then\r\n begin\r\n Recursive := True;\r\n NewResultExc := nil;\r\n try\r\n with Notifiers.LockList do\r\n try\r\n if Count = 1 then\r\n begin\r\n with TNotifierItem(Items[0]) do\r\n DoNotify( ExceptObj, ExceptAddr, OSException, StackPointer);\r\n end\r\n else\r\n begin\r\n for Priorities := High(Priorities) downto Low(Priorities) do\r\n for I := 0 to Count - 1 do\r\n with TNotifierItem(Items[I]) do\r\n if Priority = Priorities then\r\n DoNotify(ExceptObj, ExceptAddr, OSException, StackPointer);\r\n end;\r\n finally\r\n Notifiers.UnlockList;\r\n end;\r\n finally\r\n Recursive := False;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure HookedRaiseException(ExceptionCode, ExceptionFlags, NumberOfArguments: DWORD;\r\n Arguments: PExceptionArguments); stdcall;\r\nconst\r\n cDelphiException = $0EEDFADE;\r\n cNonContinuable = 1; // Delphi exceptions\r\n cNonContinuableException = $C0000025; // C++Builder exceptions (sounds like a bug)\r\n DelphiNumberOfArguments = 7;\r\n CBuilderNumberOfArguments = 8;\r\nbegin\r\n if ((ExceptionFlags = cNonContinuable) or (ExceptionFlags = cNonContinuableException)) and\r\n (ExceptionCode = cDelphiException) and\r\n (NumberOfArguments in [DelphiNumberOfArguments,CBuilderNumberOfArguments])\r\n //TODO: The difference for Win64 is bigger than 100 Byte and the comment of JVCS revision 0.3 of\r\n // JclDebug.pas, where HookedRaiseException has been added by Petr, isn't very informative\r\n {$IFDEF CPU32}\r\n and (TJclAddr(Arguments) = TJclAddr(@Arguments) + SizeOf(Pointer))\r\n {$ENDIF CPU32}\r\n then\r\n begin\r\n DoExceptNotify(Arguments.ExceptObj, Arguments.ExceptAddr, False, GetFramePointer);\r\n end;\r\n Kernel32_RaiseException(ExceptionCode, ExceptionFlags, NumberOfArguments, PDWORD(Arguments));\r\nend;\r\n\r\n{$IFDEF BORLAND}\r\nfunction HookedExceptObjProc(P: PExceptionRecord): Exception;\r\nvar\r\n NewResultExcCache: Exception; // TLS optimization\r\nbegin\r\n Result := DoExceptFilter(P);\r\n DoExceptNotify(Result, P^.ExceptionAddress, True, GetFramePointer);\r\n NewResultExcCache := NewResultExc;\r\n if NewResultExcCache <> nil then\r\n Result := NewResultExcCache;\r\nend;\r\n{$ENDIF BORLAND}\r\n\r\n{$IFDEF FPC}\r\nprocedure HookedExceptProc(Obj : TObject; Addr : Pointer; FrameCount:Longint; Frame: PPointer);\r\nvar\r\n NewResultExcCache: Exception; // TLS optimization\r\nbegin\r\n DoExceptNotify(Obj, Addr, True, GetFramePointer);\r\n NewResultExcCache := NewResultExc;\r\n if NewResultExcCache <> nil then\r\n SysUtils_ExceptProc(NewResultExcCache, Addr, FrameCount, Frame)\r\n else\r\n SysUtils_ExceptProc(Obj, Addr, FrameCount, Frame)\r\nend;\r\n{$ENDIF FPC}\r\n\r\n{$IFNDEF STACKFRAMES_ON}\r\n{$STACKFRAMES OFF}\r\n{$ENDIF ~STACKFRAMES_ON}\r\n\r\n// Do not change ordering of HookedRaiseException, HookedExceptObjProc and JclBelongsHookedCode routines\r\n\r\nfunction JclBelongsHookedCode(Address: Pointer): Boolean;\r\nbegin\r\n Result := (TJclAddr(@HookedRaiseException) < TJclAddr(@JclBelongsHookedCode)) and\r\n (TJclAddr(@HookedRaiseException) <= TJclAddr(Address)) and\r\n (TJclAddr(@JclBelongsHookedCode) > TJclAddr(Address));\r\nend;\r\n\r\n{$IFDEF BORLAND}\r\nfunction JclAddExceptFilter(const FilterProc: TJclExceptFilterProc; Priority: TJclExceptNotifyPriority = npNormal): Boolean;\r\nbegin\r\n Result := Assigned(FilterProc);\r\n if Result then\r\n with Filters.LockList do\r\n try\r\n Add(TFilterItem.Create(FilterProc, Priority));\r\n finally\r\n Filters.UnlockList;\r\n end;\r\nend;\r\n{$ENDIF BORLAND}\r\n\r\nfunction JclAddExceptNotifier(const NotifyProc: TJclExceptNotifyProc; Priority: TJclExceptNotifyPriority): Boolean;\r\nbegin\r\n Result := Assigned(NotifyProc);\r\n if Result then\r\n with Notifiers.LockList do\r\n try\r\n Add(TNotifierItem.Create(NotifyProc, Priority));\r\n finally\r\n Notifiers.UnlockList;\r\n end;\r\nend;\r\n\r\nfunction JclAddExceptNotifier(const NotifyProc: TJclExceptNotifyProcEx; Priority: TJclExceptNotifyPriority): Boolean;\r\nbegin\r\n Result := Assigned(NotifyProc);\r\n if Result then\r\n with Notifiers.LockList do\r\n try\r\n Add(TNotifierItem.Create(NotifyProc, Priority));\r\n finally\r\n Notifiers.UnlockList;\r\n end;\r\nend;\r\n\r\nfunction JclAddExceptNotifier(const NotifyMethod: TJclExceptNotifyMethod; Priority: TJclExceptNotifyPriority): Boolean;\r\nbegin\r\n Result := Assigned(NotifyMethod);\r\n if Result then\r\n with Notifiers.LockList do\r\n try\r\n Add(TNotifierItem.Create(NotifyMethod, Priority));\r\n finally\r\n Notifiers.UnlockList;\r\n end;\r\nend;\r\n\r\n{$IFDEF BORLAND}\r\nfunction JclRemoveExceptFilter(const FilterProc: TJclExceptFilterProc): Boolean;\r\nvar\r\n O: TFilterItem;\r\n I: Integer;\r\nbegin\r\n Result := Assigned(FilterProc);\r\n if Result then\r\n with Filters.LockList do\r\n try\r\n for I := 0 to Count - 1 do\r\n begin\r\n O := TFilterItem(Items[I]);\r\n if @O.FExceptFilterProc = @FilterProc then\r\n begin\r\n O.Free;\r\n Items[I] := nil;\r\n end;\r\n end;\r\n Pack;\r\n finally\r\n Filters.UnlockList;\r\n end;\r\nend;\r\n{$ENDIF BORLAND}\r\n\r\nfunction JclRemoveExceptNotifier(const NotifyProc: TJclExceptNotifyProc): Boolean;\r\nvar\r\n O: TNotifierItem;\r\n I: Integer;\r\nbegin\r\n Result := Assigned(NotifyProc);\r\n if Result then\r\n with Notifiers.LockList do\r\n try\r\n for I := 0 to Count - 1 do\r\n begin\r\n O := TNotifierItem(Items[I]);\r\n if @O.FNotifyProc = @NotifyProc then\r\n begin\r\n O.Free;\r\n Items[I] := nil;\r\n end;\r\n end;\r\n Pack;\r\n finally\r\n Notifiers.UnlockList;\r\n end;\r\nend;\r\n\r\nfunction JclRemoveExceptNotifier(const NotifyProc: TJclExceptNotifyProcEx): Boolean;\r\nvar\r\n O: TNotifierItem;\r\n I: Integer;\r\nbegin\r\n Result := Assigned(NotifyProc);\r\n if Result then\r\n with Notifiers.LockList do\r\n try\r\n for I := 0 to Count - 1 do\r\n begin\r\n O := TNotifierItem(Items[I]);\r\n if @O.FNotifyProcEx = @NotifyProc then\r\n begin\r\n O.Free;\r\n Items[I] := nil;\r\n end;\r\n end;\r\n Pack;\r\n finally\r\n Notifiers.UnlockList;\r\n end;\r\nend;\r\n\r\nfunction JclRemoveExceptNotifier(const NotifyMethod: TJclExceptNotifyMethod): Boolean;\r\nvar\r\n O: TNotifierItem;\r\n I: Integer;\r\nbegin\r\n Result := Assigned(NotifyMethod);\r\n if Result then\r\n with Notifiers.LockList do\r\n try\r\n for I := 0 to Count - 1 do\r\n begin\r\n O := TNotifierItem(Items[I]);\r\n if (TMethod(O.FNotifyMethod).Code = TMethod(NotifyMethod).Code) and\r\n (TMethod(O.FNotifyMethod).Data = TMethod(NotifyMethod).Data) then\r\n begin\r\n O.Free;\r\n Items[I] := nil;\r\n end;\r\n end;\r\n Pack;\r\n finally\r\n Notifiers.UnlockList;\r\n end;\r\nend;\r\n\r\nprocedure JclReplaceExceptObj(NewExceptObj: Exception);\r\nbegin\r\n Assert(Recursive);\r\n NewResultExc := NewExceptObj;\r\nend;\r\n\r\n{$IFDEF BORLAND}\r\nfunction GetCppRtlBase: Pointer;\r\nconst\r\n {$IFDEF COMPILER6} { Delphi/C++Builder 6 }\r\n CppRtlVersion = 60;\r\n {$ELSE ~COMPILER6}\r\n {$IFDEF RTL185} { Delphi/C++Builder 2007 were aiming for\r\n binary compatibility with BDS2006, which\r\n complicates things a bit }\r\n CppRtlVersion = 80;\r\n {$ELSE ~RTL185}\r\n { Successive RTLDLL version numbers in the remaining cases: CB2006 has cc3270mt.dll,\r\n CB2009 (= CB2006 + 2 releases) has cc3290mt.dll, CB2010 has cc32100mt.dll etc. }\r\n CppRtlVersion = 70 + Trunc(RtlVersion - 18.0) * 10;\r\n {$ENDIF ~RTL185}\r\n {$ENDIF ~COMPILER6}\r\nbegin\r\n Result := Pointer(GetModuleHandle(PChar(Format('cc32%dmt.dll', [CppRtlVersion]))));\r\n { 'Result = nil' means that the C++ RTL has been linked statically or is not available at all;\r\n in this case TJclPeMapImgHooks.ReplaceImport() is a no-op. The base module is also being\r\n hooked separately, so we're covered. }\r\nend;\r\n\r\nfunction HasCppRtl: Boolean;\r\nbegin\r\n Result := GetCppRtlBase <> TJclPeMapImgHooks.SystemBase;\r\nend;\r\n{$ENDIF BORLAND}\r\n\r\nfunction JclHookExceptions: Boolean;\r\nvar\r\n RaiseExceptionAddressCache: Pointer;\r\nbegin\r\n RaiseExceptionAddressCache := RaiseExceptionAddress;\r\n { Detect C++Builder applications and C++ packages loaded into Delphi applications.\r\n Hook the C++ RTL regardless of ExceptionsHooked so that users can call JclHookException() after\r\n loading a C++ package which might pull in the C++ RTL DLL. }\r\n {$IFDEF BORLAND}\r\n if HasCppRtl then\r\n TJclPeMapImgHooks.ReplaceImport(GetCppRtlBase, kernel32, RaiseExceptionAddressCache, @HookedRaiseException);\r\n {$ENDIF BORLAND}\r\n if not ExceptionsHooked then\r\n begin\r\n Recursive := False;\r\n with TJclPeMapImgHooks do\r\n Result := ReplaceImport(SystemBase, kernel32, RaiseExceptionAddressCache, @HookedRaiseException);\r\n if not Result then\r\n begin\r\n RaiseExceptionAddressCache := KOLDetours.InterceptCreate(RaiseExceptionAddressCache, @HookedRaiseException);\r\n Result := True; // AM: workaround upx\r\n end;\r\n\r\n if Result then\r\n begin\r\n @Kernel32_RaiseException := RaiseExceptionAddressCache;\r\n {$IFDEF BORLAND}\r\n SysUtils_ExceptObjProc := System.ExceptObjProc;\r\n System.ExceptObjProc := @HookedExceptObjProc;\r\n {$ENDIF BORLAND}\r\n {$IFDEF FPC}\r\n SysUtils_ExceptProc := System.ExceptProc;\r\n System.ExceptProc := @HookedExceptProc;\r\n {$ENDIF FPC}\r\n end;\r\n ExceptionsHooked := Result;\r\n end\r\n else\r\n Result := True;\r\nend;\r\n\r\nfunction JclUnhookExceptions: Boolean;\r\nbegin\r\n {$IFDEF BORLAND}\r\n if HasCppRtl then\r\n TJclPeMapImgHooks.ReplaceImport (GetCppRtlBase, kernel32, @HookedRaiseException, @Kernel32_RaiseException);\r\n {$ENDIF BORLAND}\r\n if ExceptionsHooked then\r\n begin\r\n with TJclPeMapImgHooks do\r\n ReplaceImport(SystemBase, kernel32, @HookedRaiseException, @Kernel32_RaiseException);\r\n {$IFDEF BORLAND}\r\n System.ExceptObjProc := @SysUtils_ExceptObjProc;\r\n @SysUtils_ExceptObjProc := nil;\r\n {$ENDIF BORLAND}\r\n {$IFDEF FPC}\r\n System.ExceptProc := @SysUtils_ExceptProc;\r\n @SysUtils_ExceptProc := nil;\r\n {$ENDIF FPC}\r\n @Kernel32_RaiseException := nil;\r\n Result := True;\r\n ExceptionsHooked := False;\r\n end\r\n else\r\n Result := True;\r\nend;\r\n\r\nfunction JclExceptionsHooked: Boolean;\r\nbegin\r\n Result := ExceptionsHooked;\r\nend;\r\n\r\nfunction JclHookExceptionsInModule(Module: HMODULE): Boolean;\r\nbegin\r\n Result := ExceptionsHooked and\r\n TJclPeMapImgHooks.ReplaceImport(Pointer(Module), kernel32, RaiseExceptionAddress, @HookedRaiseException);\r\nend;\r\n\r\nfunction JclUnhookExceptionsInModule(Module: HMODULE): Boolean;\r\nbegin\r\n Result := ExceptionsHooked and\r\n TJclPeMapImgHooks.ReplaceImport(Pointer(Module), kernel32, @HookedRaiseException, @Kernel32_RaiseException);\r\nend;\r\n\r\n{$IFDEF HOOK_DLL_EXCEPTIONS}\r\n// Exceptions hooking in libraries\r\n\r\nprocedure JclHookExceptDebugHookProc(Module: HMODULE; Hook: Boolean); stdcall;\r\nbegin\r\n if Hook then\r\n HookExceptModuleList.HookModule(Module)\r\n else\r\n HookExceptModuleList.UnhookModule(Module);\r\nend;\r\n\r\nfunction CallExportedHookExceptProc(Module: HMODULE; Hook: Boolean): Boolean;\r\nvar\r\n HookExceptProcPtr: PPointer;\r\n HookExceptProc: TJclHookExceptDebugHook;\r\nbegin\r\n HookExceptProcPtr := TJclHookExceptModuleList.JclHookExceptDebugHookAddr;\r\n Result := Assigned(HookExceptProcPtr);\r\n if Result then\r\n begin\r\n @HookExceptProc := HookExceptProcPtr^;\r\n if Assigned(HookExceptProc) then\r\n HookExceptProc(Module, True);\r\n end;\r\nend;\r\n{$ENDIF HOOK_DLL_EXCEPTIONS}\r\n\r\nfunction JclInitializeLibrariesHookExcept: Boolean;\r\nbegin\r\n {$IFDEF HOOK_DLL_EXCEPTIONS}\r\n if IsLibrary then\r\n Result := CallExportedHookExceptProc(SystemTObjectInstance, True)\r\n else\r\n begin\r\n if not Assigned(HookExceptModuleList) then\r\n HookExceptModuleList := TJclHookExceptModuleList.Create;\r\n Result := True;\r\n end;\r\n {$ELSE HOOK_DLL_EXCEPTIONS}\r\n Result := True;\r\n {$ENDIF HOOK_DLL_EXCEPTIONS}\r\nend;\r\n\r\nfunction JclHookedExceptModulesList(out ModulesList: TJclModuleArray): Boolean;\r\nbegin\r\n {$IFDEF HOOK_DLL_EXCEPTIONS}\r\n Result := Assigned(HookExceptModuleList);\r\n if Result then\r\n HookExceptModuleList.List(ModulesList);\r\n {$ELSE HOOK_DLL_EXCEPTIONS}\r\n Result := False;\r\n SetLength(ModulesList, 0);\r\n {$ENDIF HOOK_DLL_EXCEPTIONS}\r\nend;\r\n\r\n{$IFDEF HOOK_DLL_EXCEPTIONS}\r\nprocedure FinalizeLibrariesHookExcept;\r\nbegin\r\n FreeAndNil(HookExceptModuleList);\r\n if IsLibrary then\r\n CallExportedHookExceptProc(SystemTObjectInstance, False);\r\nend;\r\n\r\n//=== { TJclHookExceptModuleList } ===========================================\r\n\r\nconstructor TJclHookExceptModuleList.Create;\r\nbegin\r\n inherited Create;\r\n FModules := TThreadList.Create;\r\n HookStaticModules;\r\n JclHookExceptDebugHook := @JclHookExceptDebugHookProc;\r\nend;\r\n\r\ndestructor TJclHookExceptModuleList.Destroy;\r\nbegin\r\n JclHookExceptDebugHook := nil;\r\n FreeAndNil(FModules);\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJclHookExceptModuleList.HookModule(Module: HMODULE);\r\nbegin\r\n with FModules.LockList do\r\n try\r\n if IndexOf(Pointer(Module)) = -1 then\r\n begin\r\n Add(Pointer(Module));\r\n JclHookExceptionsInModule(Module);\r\n end;\r\n finally\r\n FModules.UnlockList;\r\n end;\r\nend;\r\n\r\nprocedure TJclHookExceptModuleList.HookStaticModules;\r\nvar\r\n ModulesList: TStringList;\r\n I: Integer;\r\n Module: HMODULE;\r\nbegin\r\n ModulesList := nil;\r\n with FModules.LockList do\r\n try\r\n ModulesList := TStringList.Create;\r\n if LoadedModulesList(ModulesList, GetCurrentProcessId, True) then\r\n for I := 0 to ModulesList.Count - 1 do\r\n begin\r\n Module := HMODULE(ModulesList.Objects[I]);\r\n if GetProcAddress(Module, JclHookExceptDebugHookName) <> nil then\r\n HookModule(Module);\r\n end;\r\n finally\r\n FModules.UnlockList;\r\n ModulesList.Free;\r\n end;\r\nend;\r\n\r\nclass function TJclHookExceptModuleList.JclHookExceptDebugHookAddr: Pointer;\r\nvar\r\n HostModule: HMODULE;\r\nbegin\r\n HostModule := GetModuleHandle(nil);\r\n Result := GetProcAddress(HostModule, JclHookExceptDebugHookName);\r\nend;\r\n\r\nprocedure TJclHookExceptModuleList.List(out ModulesList: TJclModuleArray);\r\nvar\r\n I: Integer;\r\nbegin\r\n with FModules.LockList do\r\n try\r\n SetLength(ModulesList, Count);\r\n for I := 0 to Count - 1 do\r\n ModulesList[I] := HMODULE(Items[I]);\r\n finally\r\n FModules.UnlockList;\r\n end;\r\nend;\r\n\r\nprocedure TJclHookExceptModuleList.UnhookModule(Module: HMODULE);\r\nbegin\r\n with FModules.LockList do\r\n try\r\n Remove(Pointer(Module));\r\n finally\r\n FModules.UnlockList;\r\n end;\r\nend;\r\n{$ENDIF HOOK_DLL_EXCEPTIONS}\r\n\r\ninitialization\r\n Notifiers := TThreadList.Create;\r\n {$IFDEF BORLAND}\r\n Filters := TThreadList.Create;\r\n {$ENDIF BORLAND}\r\n {$IFDEF UNITVERSIONING}\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n {$ENDIF UNITVERSIONING}\r\n\r\nfinalization\r\n {$IFDEF UNITVERSIONING}\r\n UnregisterUnitVersion(HInstance);\r\n {$ENDIF UNITVERSIONING}\r\n {$IFDEF HOOK_DLL_EXCEPTIONS}\r\n FinalizeLibrariesHookExcept;\r\n {$ENDIF HOOK_DLL_EXCEPTIONS}\r\n FreeThreadObjList(Notifiers);\r\n {$IFDEF BORLAND}\r\n FreeThreadObjList(Filters);\r\n {$ENDIF BORLAND}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jcl/source/windows/JclLANMan.pas", "content": "{**************************************************************************************************}\r\n{ }\r\n{ Project JEDI Code Library (JCL) }\r\n{ }\r\n{ The contents of this file are subject to the Mozilla Public License Version 1.1 (the \"License\"); }\r\n{ you may not use this file except in compliance with the License. You may obtain a copy of the }\r\n{ License at http://www.mozilla.org/MPL/ }\r\n{ }\r\n{ Software distributed under the License is distributed on an \"AS IS\" basis, WITHOUT WARRANTY OF }\r\n{ ANY KIND, either express or implied. See the License for the specific language governing rights }\r\n{ and limitations under the License. }\r\n{ }\r\n{ The Original Code is JclLANMan.pas. }\r\n{ }\r\n{ The Initial Developer of the Original Code is Peter Friese. }\r\n{ Portions created by Peter Friese are Copyright (C) Peter Friese. All Rights Reserved. }\r\n{ }\r\n{ Contributors: }\r\n{ Peter Friese }\r\n{ Andreas Hausladen (ahuser) }\r\n{ Robert Marquardt (marquardt) }\r\n{ Matthias Thoma (mthoma) }\r\n{ Petr Vones (pvones) }\r\n{ }\r\n{**************************************************************************************************}\r\n{ }\r\n{ This unit contains routines and classes to handle user and group management tasks. As the name }\r\n{ implies, it uses the LAN Manager API. }\r\n{ }\r\n{**************************************************************************************************}\r\n{ }\r\n{ Last modified: $Date:: 2011-09-03 00:07:50 +0200 (sam. 03 sept. 2011) $ }\r\n{ Revision: $Rev:: 3599 $ }\r\n{ Author: $Author:: outchy $ }\r\n{ }\r\n{**************************************************************************************************}\r\n\r\n// Comments to Win9x compatibility of the functions used in this unit\r\n\r\n// The following function exist at last since Win95C, but return always\r\n// the error ERROR_CALL_NOT_IMPLEMENTED\r\n// AllocateAndInitializeSid, LookupAccountSID, FreeSID\r\n\r\nunit JclLANMan;\r\n\r\n{$I jcl.inc}\r\n{$I windowsonly.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n {$IFDEF HAS_UNITSCOPE}\r\n Winapi.Windows, System.SysUtils, System.Classes;\r\n {$ELSE ~HAS_UNITSCOPE}\r\n Windows, SysUtils, Classes;\r\n {$ENDIF ~HAS_UNITSCOPE}\r\n\r\n// User Management\r\ntype\r\n TNetUserFlag = (ufAccountDisable, ufHomedirRequired, ufLockout,\r\n ufPasswordNotRequired, ufPasswordCantChange, ufDontExpirePassword,\r\n ufMNSLogonAccount);\r\n TNetUserFlags = set of TNetUserFlag;\r\n TNetUserInfoFlag = (uifScript, uifTempDuplicateAccount, uifNormalAccount,\r\n uifInterdomainTrustAccount, uifWorkstationTrustAccount, uifServerTrustAccount);\r\n TNetUserInfoFlags = set of TNetUserInfoFlag;\r\n TNetUserPriv = (upUnknown, upGuest, upUser, upAdmin);\r\n TNetUserAuthFlag = (afOpPrint, afOpComm, afOpServer, afOpAccounts);\r\n TNetUserAuthFlags = set of TNetUserAuthFlag;\r\n TNetWellKnownRID = (wkrAdmins, wkrUsers, wkrGuests, wkrPowerUsers, wkrBackupOPs,\r\n wkrReplicator, wkrEveryone);\r\n\r\nfunction CreateAccount(const Server, Username, Fullname, Password, Description,\r\n Homedir, Script: string;\r\n const PasswordNeverExpires: Boolean = True): Boolean;\r\nfunction CreateLocalAccount(const Username, Fullname, Password, Description,\r\n Homedir, Script: string;\r\n const PasswordNeverExpires: Boolean = True): Boolean;\r\nfunction DeleteAccount(const Servername, Username: string): Boolean;\r\nfunction DeleteLocalAccount(Username: string): Boolean;\r\nfunction CreateLocalGroup(const Server, Groupname, Description: string): Boolean;\r\nfunction CreateGlobalGroup(const Server, Groupname, Description: string): Boolean;\r\nfunction DeleteLocalGroup(const Server, Groupname: string): Boolean;\r\n\r\nfunction GetLocalGroups(const Server: string; const Groups: TStrings): Boolean;\r\nfunction GetGlobalGroups(const Server: string; const Groups: TStrings): Boolean;\r\nfunction LocalGroupExists(const Group: string): Boolean;\r\nfunction GlobalGroupExists(const Server, Group: string): Boolean;\r\n\r\nfunction AddAccountToLocalGroup(const Accountname, Groupname: string): Boolean;\r\nfunction LookupGroupName(const Server: string; const RID: TNetWellKnownRID): string;\r\nprocedure ParseAccountName(const QualifiedName: string; out Domain, UserName: string);\r\nfunction IsLocalAccount(const AccountName: string): Boolean;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jcl.svn.sourceforge.net/svnroot/jcl/tags/JCL-2.4-Build4571/jcl/source/windows/JclLANMan.pas $';\r\n Revision: '$Revision: 3599 $';\r\n Date: '$Date: 2011-09-03 00:07:50 +0200 (sam. 03 sept. 2011) $';\r\n LogPath: 'JCL\\source\\windows';\r\n Extra: '';\r\n Data: nil\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n JclBase, JclStrings, JclSysUtils, JclSysInfo, JclWin32;\r\n\r\nfunction CreateAccount(const Server, Username, Fullname, Password, Description,\r\n Homedir, Script: string; const PasswordNeverExpires: Boolean): Boolean;\r\nvar\r\n wServer, wUsername, wFullname,\r\n wPassword, wDescription, wHomedir, wScript: WideString;\r\n Details: USER_INFO_2;\r\n Err: NET_API_STATUS;\r\n ParmErr: DWORD;\r\nbegin\r\n wServer := Server;\r\n wUsername := Username;\r\n wFullname := Fullname;\r\n wPassword := Password;\r\n wDescription := Description;\r\n wScript := Script;\r\n wHomedir := Homedir;\r\n\r\n ResetMemory(Details, SizeOf(Details));\r\n with Details do\r\n begin\r\n usri2_name := PWideChar(wUsername);\r\n usri2_full_name := PWideChar(wFullname);\r\n usri2_password := PWideChar(wPassword);\r\n usri2_comment := PWideChar(wDescription);\r\n usri2_priv := USER_PRIV_USER;\r\n usri2_flags := UF_SCRIPT;\r\n if PassWordNeverExpires then\r\n usri2_flags := usri2_flags or UF_DONT_EXPIRE_PASSWD;\r\n usri2_script_path := PWideChar(wScript);\r\n usri2_home_dir := PWideChar(wHomedir);\r\n usri2_acct_expires := TIMEQ_FOREVER;\r\n end;\r\n\r\n Err := RtdlNetUserAdd(PWideChar(wServer), 2, @Details, @ParmErr);\r\n Result := (Err = NERR_SUCCESS);\r\nend;\r\n\r\nfunction CreateLocalAccount(const Username, Fullname, Password, Description,\r\n Homedir, Script: string; const PasswordNeverExpires: Boolean): Boolean;\r\nbegin\r\n Result := CreateAccount('', Username, Fullname, Password, Description, Homedir,\r\n Script, PassWordNeverExpires);\r\nend;\r\n\r\nfunction DeleteAccount(const Servername, Username: string): Boolean;\r\nvar\r\n wServername, wUsername: WideString;\r\n Err: NET_API_STATUS;\r\nbegin\r\n wServername := Servername;\r\n wUsername := Username;\r\n Err := RtdlNetUserDel(PWideChar(wServername), PWideChar(wUsername));\r\n Result := (Err = NERR_SUCCESS);\r\nend;\r\n\r\nfunction DeleteLocalAccount(Username: string): Boolean;\r\nbegin\r\n Result := DeleteAccount('', Username);\r\nend;\r\n\r\nfunction CreateGlobalGroup(const Server, Groupname, Description: string): Boolean;\r\nvar\r\n wServer, wGroupname, wDescription: WideString;\r\n Details: GROUP_INFO_1;\r\n Err: NET_API_STATUS;\r\n ParmErr: DWORD;\r\nbegin\r\n wServer := Server;\r\n wGroupname := Groupname;\r\n wDescription := Description;\r\n\r\n ResetMemory(Details, SizeOf(Details));\r\n Details.grpi1_name := PWideChar(wGroupName);\r\n Details.grpi1_comment := PWideChar(wDescription);\r\n\r\n Err := RtdlNetGroupAdd(PWideChar(wServer), 1, @Details, @ParmErr);\r\n Result := (Err = NERR_SUCCESS);\r\nend;\r\n\r\nfunction CreateLocalGroup(const Server, Groupname, Description: string): Boolean;\r\nvar\r\n wServer, wGroupname, wDescription: WideString;\r\n Details: LOCALGROUP_INFO_1;\r\n Err: NET_API_STATUS;\r\n ParmErr: DWORD;\r\nbegin\r\n wServer := Server;\r\n wGroupname := Groupname;\r\n wDescription := Description;\r\n\r\n ResetMemory(Details, SizeOf(Details));\r\n Details.lgrpi1_name := PWideChar(wGroupName);\r\n Details.lgrpi1_comment := PWideChar(wDescription);\r\n\r\n Err := RtdlNetLocalGroupAdd(PWideChar(wServer), 1, @Details, @ParmErr);\r\n Result := (Err = NERR_SUCCESS);\r\nend;\r\n\r\nfunction DeleteLocalGroup(const Server, Groupname: string): Boolean;\r\nvar\r\n wServername, wUsername: WideString;\r\n Err: NET_API_STATUS;\r\nbegin\r\n wServername := Server;\r\n wUsername := Groupname;\r\n Err := RtdlNetLocalGroupDel(PWideChar(wServername), PWideChar(wUsername));\r\n Result := (Err = NERR_SUCCESS);\r\nend;\r\n\r\nfunction GetLocalGroups(const Server: string; const Groups: TStrings): Boolean;\r\nvar\r\n Err: NET_API_STATUS;\r\n wServername: WideString;\r\n Buffer: PByte;\r\n Details: PLocalGroupInfo0;\r\n EntriesRead, TotalEntries: Cardinal;\r\n I: Integer;\r\nbegin\r\n wServername := Server;\r\n Err := RtdlNetLocalGroupEnum(PWideChar(wServername), 0, Buffer, MAX_PREFERRED_LENGTH,\r\n EntriesRead, TotalEntries, nil);\r\n\r\n if Err = NERR_SUCCESS then\r\n begin\r\n Details := PLocalGroupInfo0(Buffer);\r\n Groups.BeginUpdate;\r\n try\r\n for I := 0 to EntriesRead - 1 do\r\n begin\r\n Groups.Add(Details^.lgrpi0_name);\r\n Inc(Details);\r\n end;\r\n finally\r\n Groups.EndUpdate;\r\n end;\r\n end;\r\n\r\n RtdlNetApiBufferFree(Buffer);\r\n Result := (Err = NERR_SUCCESS);\r\nend;\r\n\r\nfunction GetGlobalGroups(const Server: string; const Groups: TStrings): Boolean;\r\nvar\r\n Err: NET_API_STATUS;\r\n wServername: WideString;\r\n Buffer: PByte;\r\n Details: PGroupInfo0;\r\n EntriesRead, TotalEntries: Cardinal;\r\n I: Integer;\r\nbegin\r\n wServername := Server;\r\n Err := RtdlNetGroupEnum(PWideChar(wServername), 0, Buffer, MAX_PREFERRED_LENGTH,\r\n EntriesRead, TotalEntries, nil);\r\n\r\n if Err = NERR_SUCCESS then\r\n begin\r\n Details := PGroupInfo0(Buffer);\r\n // (rom) is 'None' locale independent?\r\n if (EntriesRead <> 1) or (Details^.grpi0_name <> 'None') then\r\n begin\r\n Groups.BeginUpdate;\r\n try\r\n for I := 0 to EntriesRead - 1 do\r\n begin\r\n Groups.Add(Details^.grpi0_name);\r\n Inc(Details);\r\n end;\r\n finally\r\n Groups.EndUpdate;\r\n end;\r\n end;\r\n end\r\n else\r\n RaiseLastOSError;\r\n\r\n RtdlNetApiBufferFree(Buffer);\r\n Result := (Err = NERR_SUCCESS);\r\nend;\r\n\r\nfunction LocalGroupExists(const Group: string): Boolean;\r\nvar\r\n Groups: TStringList;\r\nbegin\r\n Groups := TStringList.Create;\r\n try\r\n GetLocalGroups('', Groups);\r\n Result := (Groups.IndexOf(Group) >= 0);\r\n finally\r\n Groups.Free;\r\n end;\r\nend;\r\n\r\nfunction GlobalGroupExists(const Server, Group: string): Boolean;\r\nvar\r\n Groups: TStringList;\r\nbegin\r\n Groups := TStringList.Create;\r\n try\r\n GetGlobalGroups(Server, Groups);\r\n Result := (Groups.IndexOf(Group) >= 0);\r\n finally\r\n Groups.Free;\r\n end;\r\nend;\r\n\r\nfunction DeleteGlobalGroup(const Server, Groupname: string): Boolean;\r\nvar\r\n wServername, wUsername: WideString;\r\n Err: NET_API_STATUS;\r\nbegin\r\n wServername := Server;\r\n wUsername := Groupname;\r\n Err := RtdlNetGroupDel(PWideChar(wServername), PWideChar(wUsername));\r\n Result := (Err = NERR_SUCCESS);\r\nend;\r\n\r\nfunction AddAccountToLocalGroup(const Accountname, Groupname: string): Boolean;\r\nvar\r\n Err: NET_API_STATUS;\r\n wAccountname, wGroupname: WideString;\r\n Details: LOCALGROUP_MEMBERS_INFO_3;\r\nbegin\r\n wGroupname := Groupname;\r\n wAccountname := AccountName;\r\n\r\n Details.lgrmi3_domainandname := PWideChar(wAccountname);\r\n Err := RtdlNetLocalGroupAddMembers(nil, PWideChar(wGroupname), 3, @Details, 1);\r\n Result := (Err = NERR_SUCCESS);\r\nend;\r\n\r\nfunction RIDToDWORD(const RID: TNetWellKnownRID): DWORD;\r\nbegin\r\n case RID of\r\n wkrAdmins:\r\n Result := DOMAIN_ALIAS_RID_ADMINS;\r\n wkrUsers:\r\n Result := DOMAIN_ALIAS_RID_USERS;\r\n wkrGuests:\r\n Result := DOMAIN_ALIAS_RID_GUESTS;\r\n wkrPowerUsers:\r\n Result := DOMAIN_ALIAS_RID_POWER_USERS;\r\n wkrBackupOPs:\r\n Result := DOMAIN_ALIAS_RID_BACKUP_OPS;\r\n wkrReplicator:\r\n Result := DOMAIN_ALIAS_RID_REPLICATOR;\r\n else // (wkrEveryone)\r\n Result := SECURITY_WORLD_RID;\r\n end;\r\nend;\r\n\r\nfunction DWORDToRID(const RID: DWORD): TNetWellKnownRID;\r\nbegin\r\n case RID of\r\n DOMAIN_ALIAS_RID_ADMINS:\r\n Result := wkrAdmins;\r\n DOMAIN_ALIAS_RID_USERS:\r\n Result := wkrUsers;\r\n DOMAIN_ALIAS_RID_GUESTS:\r\n Result := wkrGuests;\r\n DOMAIN_ALIAS_RID_POWER_USERS:\r\n Result := wkrPowerUsers;\r\n DOMAIN_ALIAS_RID_BACKUP_OPS:\r\n Result := wkrBackupOPs;\r\n DOMAIN_ALIAS_RID_REPLICATOR:\r\n Result := wkrReplicator;\r\n else // (SECURITY_WORLD_RID)\r\n Result := wkrEveryone;\r\n end;\r\nend;\r\n\r\nfunction LookupGroupName(const Server: string; const RID: TNetWellKnownRID): string;\r\nvar\r\n sia: {$IFDEF HAS_UNITSCOPE}Winapi.{$ENDIF}Windows.SID_IDENTIFIER_AUTHORITY;\r\n rd1, rd2: DWORD;\r\n ridCount: Integer;\r\n sd: PSID;\r\n AccountNameLen, DomainNameLen: DWORD;\r\n SidNameUse: SID_NAME_USE;\r\n AccountName, DomainName: string;\r\nbegin\r\n Result := '';\r\n AccountName := '';\r\n DomainName := '';\r\n rd2 := 0;\r\n\r\n if RID = wkrEveryOne then\r\n begin\r\n sia := SECURITY_WORLD_SID_AUTHORITY;\r\n rd1 := RIDToDWORD(RID);\r\n ridCount := 1;\r\n end\r\n else\r\n begin\r\n sia := SECURITY_NT_AUTHORITY;\r\n rd1 := SECURITY_BUILTIN_DOMAIN_RID;\r\n rd2 := RIDToDWORD(RID);\r\n ridCount := 2;\r\n end;\r\n sd := nil;\r\n if AllocateAndInitializeSid(sia, ridCount, rd1, rd2, 0, 0, 0, 0, 0, 0, sd) then\r\n try\r\n AccountNameLen := 0;\r\n DomainNameLen := 0;\r\n SidNameUse := SidTypeUnknown;\r\n if not LookupAccountSID(PChar(Server), sd, PChar(AccountName), AccountNameLen,\r\n PChar(DomainName), DomainNameLen, SidNameUse) then\r\n begin\r\n SetLength(AccountName, AccountNamelen);\r\n SetLength(DomainName, DomainNameLen);\r\n end;\r\n\r\n if LookupAccountSID(PChar(Server), sd, PChar(AccountName), AccountNameLen,\r\n PChar(DomainName), DomainNameLen, sidNameUse) then\r\n StrResetLength(AccountName)\r\n else\r\n RaiseLastOSError;\r\n Result := AccountName;\r\n finally\r\n FreeSID(sd);\r\n end;\r\nend;\r\n\r\nprocedure ParseAccountName(const QualifiedName: string; out Domain, UserName: string);\r\nvar\r\n Parts: TStringList;\r\nbegin\r\n Parts := TStringList.Create;\r\n try\r\n StrTokenToStrings(QualifiedName, '\\', Parts);\r\n if Parts.Count = 1 then\r\n UserName := Parts[0]\r\n else\r\n begin\r\n Domain := Parts[0];\r\n UserName := Parts[1];\r\n end;\r\n finally\r\n Parts.Free;\r\n end;\r\nend;\r\n\r\nfunction IsLocalAccount(const AccountName: string): Boolean;\r\nvar\r\n Domain: string;\r\n UserName: string;\r\n LocalServerName: string;\r\nbegin\r\n LocalServerName := GetLocalComputerName;\r\n ParseAccountName(AccountName, Domain, UserName);\r\n Result := (Domain = '') or (Domain = LocalServerName);\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jcl/source/windows/JclLocales.pas", "content": "{**************************************************************************************************}\r\n{ }\r\n{ Project JEDI Code Library (JCL) }\r\n{ }\r\n{ The contents of this file are subject to the Mozilla Public License Version 1.1 (the \"License\"); }\r\n{ you may not use this file except in compliance with the License. You may obtain a copy of the }\r\n{ License at http://www.mozilla.org/MPL/ }\r\n{ }\r\n{ Software distributed under the License is distributed on an \"AS IS\" basis, WITHOUT WARRANTY OF }\r\n{ ANY KIND, either express or implied. See the License for the specific language governing rights }\r\n{ and limitations under the License. }\r\n{ }\r\n{ The Original Code is JclLocales.pas. }\r\n{ }\r\n{ The Initial Developer of the Original Code is Petr Vones. }\r\n{ Portions created by Petr Vones are Copyright (C) Petr Vones. All Rights Reserved. }\r\n{ }\r\n{ Contributors: }\r\n{ Marcel van Brakel }\r\n{ Robert Marquardt (marquardt) }\r\n{ Robert Rossmair (rrossmair) }\r\n{ Matthias Thoma (mthoma) }\r\n{ Petr Vones (pvones) }\r\n{ }\r\n{**************************************************************************************************}\r\n{ }\r\n{ This unit contains a set of classes which allow you to easily retrieve locale specific }\r\n{ information such the list of keyboard layouts, names used for dates and characters used for }\r\n{ formatting numbers and dates. }\r\n{ }\r\n{**************************************************************************************************}\r\n{ }\r\n{ Last modified: $Date:: 2011-12-30 00:12:19 +0100 (ven. 30 déc. 2011) $ }\r\n{ Revision: $Rev:: 3662 $ }\r\n{ Author: $Author:: outchy $ }\r\n{ }\r\n{**************************************************************************************************}\r\n\r\nunit JclLocales;\r\n\r\n{$I jcl.inc}\r\n{$I windowsonly.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n {$IFDEF FPC}\r\n JwaWinNLS,\r\n {$ENDIF FPC}\r\n {$IFDEF HAS_UNITSCOPE}\r\n Winapi.Windows, System.SysUtils, System.Classes, System.Contnrs,\r\n {$ELSE ~HAS_UNITSCOPE}\r\n Windows, SysUtils, Classes, Contnrs,\r\n {$ENDIF ~HAS_UNITSCOPE}\r\n JclBase, JclWin32;\r\n\r\ntype\r\n // System locales\r\n TJclLocalesDays = 1..7;\r\n TJclLocalesMonths = 1..13;\r\n TJclLocaleDateFormats = (ldShort, ldLong, ldYearMonth);\r\n\r\n TJclLocaleInfo = class(TObject)\r\n private\r\n FCalendars: TStringList;\r\n FDateFormats: array [TJclLocaleDateFormats] of TStringList;\r\n FLocaleID: LCID;\r\n FTimeFormats: TStringList;\r\n FUseSystemACP: Boolean;\r\n FValidCalendars: Boolean;\r\n FValidDateFormatLists: set of TJclLocaleDateFormats;\r\n FValidTimeFormatLists: Boolean;\r\n function GetCalendars: TStrings;\r\n function GetCalendarIntegerInfo(Calendar: CALID; InfoType: Integer): Integer;\r\n function GetCalendarStringInfo(Calendar: CALID; InfoType: Integer): string;\r\n function GetIntegerInfo(InfoType: Integer): Integer;\r\n function GetStringInfo(InfoType: Integer): string;\r\n function GetLangID: LANGID;\r\n function GetSortID: Word;\r\n function GetLangIDPrimary: Word;\r\n function GetLangIDSub: Word;\r\n function GetLongMonthNames(Month: TJclLocalesMonths): string;\r\n function GetAbbreviatedMonthNames(Month: TJclLocalesMonths): string;\r\n function GetLongDayNames(Day: TJclLocalesDays): string;\r\n function GetAbbreviatedDayNames(Day: TJclLocalesDays): string;\r\n function GetCharInfo(InfoType: Integer): Char;\r\n function GetTimeFormats: TStrings;\r\n function GetDateFormats(Format: TJclLocaleDateFormats): TStrings;\r\n function GetFontCharset: Byte;\r\n function GetCalTwoDigitYearMax(Calendar: CALID): Integer;\r\n procedure SetUseSystemACP(const Value: Boolean);\r\n procedure SetCharInfo(InfoType: Integer; const Value: Char);\r\n procedure SetIntegerInfo(InfoType: Integer; const Value: Integer);\r\n procedure SetStringInfo(InfoType: Integer; const Value: string);\r\n public\r\n constructor Create(ALocaleID: LCID = LOCALE_SYSTEM_DEFAULT);\r\n destructor Destroy; override;\r\n property CharInfo[InfoType: Integer]: Char read GetCharInfo write SetCharInfo;\r\n property IntegerInfo[InfoType: Integer]: Integer read GetIntegerInfo write SetIntegerInfo;\r\n property StringInfo[InfoType: Integer]: string read GetStringInfo write SetStringInfo; default;\r\n property UseSystemACP: Boolean read FUseSystemACP write SetUseSystemACP;\r\n property FontCharset: Byte read GetFontCharset;\r\n property LangID: LANGID read GetLangID;\r\n property LocaleID: LCID read FLocaleID;\r\n property LangIDPrimary: Word read GetLangIDPrimary;\r\n property LangIDSub: Word read GetLangIDSub;\r\n property SortID: Word read GetSortID;\r\n property DateFormats[Format: TJclLocaleDateFormats]: TStrings read GetDateFormats;\r\n property TimeFormats: TStrings read GetTimeFormats;\r\n // Languages\r\n property LanguageIndentifier: string index LOCALE_ILANGUAGE read GetStringInfo;\r\n property LocalizedLangName: string index LOCALE_SLANGUAGE read GetStringInfo;\r\n property EnglishLangName: string index LOCALE_SENGLANGUAGE read GetStringInfo;\r\n property AbbreviatedLangName: string index LOCALE_SABBREVLANGNAME read GetStringInfo;\r\n property NativeLangName: string index LOCALE_SNATIVELANGNAME read GetStringInfo;\r\n property ISOAbbreviatedLangName: string index LOCALE_SISO639LANGNAME read GetStringInfo;\r\n // Countries\r\n property CountryCode: Integer index LOCALE_ICOUNTRY read GetIntegerInfo;\r\n property LocalizedCountryName: string index LOCALE_SCOUNTRY read GetStringInfo;\r\n property EnglishCountryName: string index LOCALE_SENGCOUNTRY read GetStringInfo;\r\n property AbbreviatedCountryName: string index LOCALE_SABBREVCTRYNAME read GetStringInfo;\r\n property NativeCountryName: string index LOCALE_SNATIVECTRYNAME read GetStringInfo;\r\n property ISOAbbreviatedCountryName: string index LOCALE_SISO3166CTRYNAME read GetStringInfo;\r\n // Codepages\r\n property DefaultLanguageId: Integer index LOCALE_IDEFAULTLANGUAGE read GetIntegerInfo;\r\n property DefaultCountryCode: Integer index LOCALE_IDEFAULTCOUNTRY read GetIntegerInfo;\r\n property DefaultCodePageEBCDIC: Integer index LOCALE_IDEFAULTEBCDICCODEPAGE read GetIntegerInfo;\r\n property CodePageOEM: Integer index LOCALE_IDEFAULTCODEPAGE read GetIntegerInfo;\r\n property CodePageANSI: Integer index LOCALE_IDEFAULTANSICODEPAGE read GetIntegerInfo;\r\n property CodePageMAC: Integer index LOCALE_IDEFAULTMACCODEPAGE read GetIntegerInfo;\r\n // Digits\r\n property ListItemSeparator: Char index LOCALE_SLIST read GetCharInfo write SetCharInfo;\r\n property Measure: Integer index LOCALE_IMEASURE read GetIntegerInfo write SetIntegerInfo;\r\n property DecimalSeparator: Char index LOCALE_SDECIMAL read GetCharInfo write SetCharInfo;\r\n property ThousandSeparator: Char index LOCALE_STHOUSAND read GetCharInfo write SetCharInfo;\r\n property DigitGrouping: string index LOCALE_SGROUPING read GetStringInfo write SetStringInfo;\r\n property NumberOfFractionalDigits: Integer index LOCALE_IDIGITS read GetIntegerInfo write SetIntegerInfo;\r\n property LeadingZeros: Integer index LOCALE_ILZERO read GetIntegerInfo write SetIntegerInfo;\r\n property NegativeNumberMode: Integer index LOCALE_INEGNUMBER read GetIntegerInfo write SetIntegerInfo;\r\n property NativeDigits: string index LOCALE_SNATIVEDIGITS read GetStringInfo;\r\n property DigitSubstitution: Integer index LOCALE_IDIGITSUBSTITUTION read GetIntegerInfo;\r\n // Monetary\r\n property MonetarySymbolLocal: string index LOCALE_SCURRENCY read GetStringInfo write SetStringInfo;\r\n property MonetarySymbolIntl: string index LOCALE_SINTLSYMBOL read GetStringInfo;\r\n property MonetaryDecimalSeparator: Char index LOCALE_SMONDECIMALSEP read GetCharInfo write SetCharInfo;\r\n property MonetaryThousandsSeparator: Char index LOCALE_SMONTHOUSANDSEP read GetCharInfo write SetCharInfo;\r\n property MonetaryGrouping: string index LOCALE_SMONGROUPING read GetStringInfo write SetStringInfo;\r\n property NumberOfLocalMonetaryDigits: Integer index LOCALE_ICURRDIGITS read GetIntegerInfo write SetIntegerInfo;\r\n property NumberOfIntlMonetaryDigits: Integer index LOCALE_IINTLCURRDIGITS read GetIntegerInfo;\r\n property PositiveCurrencyMode: string index LOCALE_ICURRENCY read GetStringInfo write SetStringInfo;\r\n property NegativeCurrencyMode: string index LOCALE_INEGCURR read GetStringInfo write SetStringInfo;\r\n property EnglishCurrencyName: string index LOCALE_SENGCURRNAME read GetStringInfo;\r\n property NativeCurrencyName: string index LOCALE_SNATIVECURRNAME read GetStringInfo;\r\n // Date and time\r\n property DateSeparator: Char index LOCALE_SDATE read GetCharInfo write SetCharInfo;\r\n property TimeSeparator: Char index LOCALE_STIME read GetCharInfo write SetCharInfo;\r\n property ShortDateFormat: string index LOCALE_SSHORTDATE read GetStringInfo write SetStringInfo;\r\n property LongDateFormat: string index LOCALE_SLONGDATE read GetStringInfo write SetStringInfo;\r\n property TimeFormatString: string index LOCALE_STIMEFORMAT read GetStringInfo write SetStringInfo;\r\n property ShortDateOrdering: Integer index LOCALE_IDATE read GetIntegerInfo;\r\n property LongDateOrdering: Integer index LOCALE_ILDATE read GetIntegerInfo;\r\n property TimeFormatSpecifier: Integer index LOCALE_ITIME read GetIntegerInfo write SetIntegerInfo;\r\n property TimeMarkerPosition: Integer index LOCALE_ITIMEMARKPOSN read GetIntegerInfo;\r\n property CenturyFormatSpecifier: Integer index LOCALE_ICENTURY read GetIntegerInfo;\r\n property LeadZerosInTime: Integer index LOCALE_ITLZERO read GetIntegerInfo;\r\n property LeadZerosInDay: Integer index LOCALE_IDAYLZERO read GetIntegerInfo;\r\n property LeadZerosInMonth: Integer index LOCALE_IMONLZERO read GetIntegerInfo;\r\n property AMDesignator: string index LOCALE_S1159 read GetStringInfo write SetStringInfo;\r\n property PMDesignator: string index LOCALE_S2359 read GetStringInfo write SetStringInfo;\r\n property YearMonthFormat: string index LOCALE_SYEARMONTH read GetStringInfo write SetStringInfo;\r\n // Calendar\r\n property CalendarType: Integer index LOCALE_ICALENDARTYPE read GetIntegerInfo write SetIntegerInfo;\r\n property AdditionalCaledarTypes: Integer index LOCALE_IOPTIONALCALENDAR read GetIntegerInfo;\r\n property FirstDayOfWeek: Integer index LOCALE_IFIRSTDAYOFWEEK read GetIntegerInfo write SetIntegerInfo;\r\n property FirstWeekOfYear: Integer index LOCALE_IFIRSTWEEKOFYEAR read GetIntegerInfo write SetIntegerInfo;\r\n // Day and month names\r\n property LongDayNames[Day: TJclLocalesDays]: string read GetLongDayNames;\r\n property AbbreviatedDayNames[Day: TJclLocalesDays]: string read GetAbbreviatedDayNames;\r\n property LongMonthNames[Month: TJclLocalesMonths]: string read GetLongMonthNames;\r\n property AbbreviatedMonthNames[Month: TJclLocalesMonths]: string read GetAbbreviatedMonthNames;\r\n // Sign\r\n property PositiveSign: string index LOCALE_SPOSITIVESIGN read GetStringInfo write SetStringInfo;\r\n property NegativeSign: string index LOCALE_SNEGATIVESIGN read GetStringInfo write SetStringInfo;\r\n property PositiveSignPos: Integer index LOCALE_IPOSSIGNPOSN read GetIntegerInfo;\r\n property NegativeSignPos: Integer index LOCALE_INEGSIGNPOSN read GetIntegerInfo;\r\n property PosOfPositiveMonetarySymbol: Integer index LOCALE_IPOSSYMPRECEDES read GetIntegerInfo;\r\n property SepOfPositiveMonetarySymbol: Integer index LOCALE_IPOSSEPBYSPACE read GetIntegerInfo;\r\n property PosOfNegativeMonetarySymbol: Integer index LOCALE_INEGSYMPRECEDES read GetIntegerInfo;\r\n property SepOfNegativeMonetarySymbol: Integer index LOCALE_INEGSEPBYSPACE read GetIntegerInfo;\r\n // Misc\r\n property DefaultPaperSize: Integer index LOCALE_IPAPERSIZE read GetIntegerInfo;\r\n property FontSignature: string index LOCALE_FONTSIGNATURE read GetStringInfo;\r\n property LocalizedSortName: string index LOCALE_SSORTNAME read GetStringInfo;\r\n // Calendar Info\r\n property Calendars: TStrings read GetCalendars;\r\n property CalendarIntegerInfo[Calendar: CALID; InfoType: Integer]: Integer read GetCalendarIntegerInfo;\r\n property CalendarStringInfo[Calendar: CALID; InfoType: Integer]: string read GetCalendarStringInfo;\r\n property CalTwoDigitYearMax[Calendar: CALID]: Integer read GetCalTwoDigitYearMax;\r\n end;\r\n\r\n TJclLocalesKind = (lkInstalled, lkSupported);\r\n\r\n TJclLocalesList = class(TObjectList)\r\n private\r\n FCodePages: TStringList;\r\n FKind: TJclLocalesKind;\r\n function GetItemFromLangID(LangID: LANGID): TJclLocaleInfo;\r\n function GetItemFromLangIDPrimary(LangIDPrimary: Word): TJclLocaleInfo;\r\n function GetItemFromLocaleID(LocaleID: LCID): TJclLocaleInfo;\r\n function GetItems(Index: Integer): TJclLocaleInfo;\r\n function GetCodePages: TStrings;\r\n protected\r\n procedure CreateList;\r\n public\r\n constructor Create(AKind: TJclLocalesKind = lkInstalled);\r\n destructor Destroy; override;\r\n procedure FillStrings(AStrings: TStrings; InfoType: Integer);\r\n property CodePages: TStrings read GetCodePages;\r\n property ItemFromLangID[LangID: LANGID]: TJclLocaleInfo read GetItemFromLangID;\r\n property ItemFromLangIDPrimary[LangIDPrimary: Word]: TJclLocaleInfo read GetItemFromLangIDPrimary;\r\n property ItemFromLocaleID[LocaleID: LCID]: TJclLocaleInfo read GetItemFromLocaleID;\r\n property Items[Index: Integer]: TJclLocaleInfo read GetItems; default;\r\n property Kind: TJclLocalesKind read FKind;\r\n end;\r\n\r\n // Keyboard layouts\r\n TJclKeybLayoutFlag = (klReorder, klUnloadPrevious, klSetForProcess,\r\n klActivate, klNotEllShell, klReplaceLang, klSubstituteOK);\r\n\r\n TJclKeybLayoutFlags = set of TJclKeybLayoutFlag;\r\n\r\n TJclKeyboardLayoutList = class;\r\n\r\n TJclAvailableKeybLayout = class(TObject)\r\n private\r\n FIdentifier: DWORD;\r\n FLayoutID: Word;\r\n FLayoutFile: string;\r\n FOwner: TJclKeyboardLayoutList;\r\n FName: string;\r\n function GetIdentifierName: string;\r\n function GetLayoutFileExists: Boolean;\r\n public\r\n function Load(const LoadFlags: TJclKeybLayoutFlags): Boolean;\r\n property Identifier: DWORD read FIdentifier;\r\n property IdentifierName: string read GetIdentifierName;\r\n property LayoutID: Word read FLayoutID;\r\n property LayoutFile: string read FLayoutFile;\r\n property LayoutFileExists: Boolean read GetLayoutFileExists;\r\n property Name: string read FName;\r\n end;\r\n\r\n TJclKeyboardLayout = class(TObject)\r\n private\r\n FLayout: HKL;\r\n FLocaleInfo: TJclLocaleInfo;\r\n FOwner: TJclKeyboardLayoutList;\r\n function GetDeviceHandle: Word;\r\n function GetDisplayName: string;\r\n function GetLocaleID: Word;\r\n function GetLocaleInfo: TJclLocaleInfo;\r\n function GetVariationName: string;\r\n public\r\n constructor Create(AOwner: TJclKeyboardLayoutList; ALayout: HKL);\r\n destructor Destroy; override;\r\n function Activate(ActivateFlags: TJclKeybLayoutFlags = []): Boolean;\r\n function Unload: Boolean;\r\n property DeviceHandle: Word read GetDeviceHandle;\r\n property DisplayName: string read GetDisplayName;\r\n property Layout: HKL read FLayout;\r\n property LocaleID: Word read GetLocaleID;\r\n property LocaleInfo: TJclLocaleInfo read GetLocaleInfo;\r\n property VariationName: string read GetVariationName;\r\n end;\r\n\r\n TJclKeyboardLayoutList = class(TObject)\r\n private\r\n FAvailableLayouts: TObjectList;\r\n FList: TObjectList;\r\n FOnRefresh: TNotifyEvent;\r\n function GetCount: Integer;\r\n function GetItems(Index: Integer): TJclKeyboardLayout;\r\n function GetActiveLayout: TJclKeyboardLayout;\r\n function GetItemFromHKL(Layout: HKL): TJclKeyboardLayout;\r\n function GetLayoutFromLocaleID(LocaleID: Word): TJclKeyboardLayout;\r\n function GetAvailableLayoutCount: Integer;\r\n function GetAvailableLayouts(Index: Integer): TJclAvailableKeybLayout;\r\n protected\r\n procedure CreateAvailableLayouts;\r\n procedure DoRefresh; dynamic;\r\n public\r\n constructor Create;\r\n destructor Destroy; override;\r\n function ActivatePrevLayout(ActivateFlags: TJclKeybLayoutFlags = []): Boolean;\r\n function ActivateNextLayout(ActivateFlags: TJclKeybLayoutFlags = []): Boolean;\r\n function LoadLayout(const LayoutName: string; LoadFlags: TJclKeybLayoutFlags): Boolean;\r\n procedure Refresh;\r\n property ActiveLayout: TJclKeyboardLayout read GetActiveLayout;\r\n property AvailableLayouts[Index: Integer]: TJclAvailableKeybLayout read GetAvailableLayouts;\r\n property AvailableLayoutCount: Integer read GetAvailableLayoutCount;\r\n property Count: Integer read GetCount;\r\n property ItemFromHKL[Layout: HKL]: TJclKeyboardLayout read GetItemFromHKL;\r\n property Items[Index: Integer]: TJclKeyboardLayout read GetItems; default;\r\n property LayoutFromLocaleID[LocaleID: Word]: TJclKeyboardLayout read GetLayoutFromLocaleID;\r\n property OnRefresh: TNotifyEvent read FOnRefresh write FOnRefresh;\r\n end;\r\n\r\n// Various routines\r\nprocedure JclLocalesInfoList(const Strings: TStrings; InfoType: Integer = LOCALE_SENGCOUNTRY);\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jcl.svn.sourceforge.net/svnroot/jcl/tags/JCL-2.4-Build4571/jcl/source/windows/JclLocales.pas $';\r\n Revision: '$Revision: 3662 $';\r\n Date: '$Date: 2011-12-30 00:12:19 +0100 (ven. 30 déc. 2011) $';\r\n LogPath: 'JCL\\source\\windows';\r\n Extra: '';\r\n Data: nil\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n {$IFDEF HAS_UNITSCOPE}\r\n System.SysConst,\r\n {$ELSE ~HAS_UNITSCOPE}\r\n SysConst,\r\n {$ENDIF ~HAS_UNITSCOPE}\r\n JclFileUtils, JclRegistry, JclStrings, JclSysInfo, JclUnicode;\r\n\r\nconst\r\n JclMaxKeyboardLayouts = 16;\r\n LocaleUseAcp: array [Boolean] of DWORD = (0, LOCALE_USE_CP_ACP);\r\n\r\nfunction KeybLayoutFlagsToDWORD(const ActivateFlags: TJclKeybLayoutFlags;\r\n const LoadMode: Boolean): DWORD;\r\nbegin\r\n Result := 0;\r\n if klReorder in ActivateFlags then\r\n Inc(Result, KLF_REORDER);\r\n if (klUnloadPrevious in ActivateFlags) and IsWinNT then\r\n Inc(Result, KLF_UNLOADPREVIOUS);\r\n if (klSetForProcess in ActivateFlags) and (GetWindowsVersion >= wvWin2000) then\r\n Inc(Result, KLF_SETFORPROCESS);\r\n if LoadMode then\r\n begin\r\n if klActivate in ActivateFlags then\r\n Inc(Result, KLF_ACTIVATE);\r\n if klNotEllShell in ActivateFlags then\r\n Inc(Result, KLF_NOTELLSHELL);\r\n if (klReplaceLang in ActivateFlags) and not IsWinNT3 then\r\n Inc(Result, KLF_REPLACELANG);\r\n if klSubstituteOK in ActivateFlags then\r\n Inc(Result, KLF_SUBSTITUTE_OK);\r\n end;\r\nend;\r\n\r\n// EnumXXX functions helper thread variables\r\nthreadvar\r\n ProcessedLocaleInfoList: TStrings;\r\n ProcessedLocalesList: TJclLocalesList;\r\n\r\n//=== { TJclLocaleInfo } =====================================================\r\n\r\nconstructor TJclLocaleInfo.Create(ALocaleID: LCID);\r\nbegin\r\n inherited Create;\r\n FLocaleID := ALocaleID;\r\n FUseSystemACP := True;\r\n FValidDateFormatLists := [];\r\nend;\r\n\r\ndestructor TJclLocaleInfo.Destroy;\r\nvar\r\n DateFormat: TJclLocaleDateFormats;\r\nbegin\r\n FreeAndNil(FCalendars);\r\n for DateFormat := Low(DateFormat) to High(DateFormat) do\r\n FreeAndNil(FDateFormats[DateFormat]);\r\n FreeAndNil(FTimeFormats);\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJclLocaleInfo.GetAbbreviatedDayNames(Day: TJclLocalesDays): string;\r\nbegin\r\n Result := GetStringInfo(LOCALE_SABBREVDAYNAME1 + Day - 1);\r\nend;\r\n\r\nfunction TJclLocaleInfo.GetAbbreviatedMonthNames(Month: TJclLocalesMonths): string;\r\nvar\r\n Param: DWORD;\r\nbegin\r\n case Month of\r\n 1..12:\r\n Param := LOCALE_SABBREVMONTHNAME1 + Month - 1;\r\n 13:\r\n Param := LOCALE_SABBREVMONTHNAME13;\r\n else\r\n raise ERangeError.CreateRes(@SRangeError);\r\n end;\r\n Result := GetStringInfo(Param);\r\nend;\r\n\r\nfunction TJclLocaleInfo.GetCalendarIntegerInfo(Calendar: CALID; InfoType: Integer): Integer;\r\nvar\r\n Ret: DWORD;\r\nbegin\r\n InfoType := InfoType or Integer(LocaleUseAcp[FUseSystemACP]) or CAL_RETURN_NUMBER;\r\n Ret := JclWin32.RtdlGetCalendarInfoW(FLocaleID, Calendar, InfoType, nil, 0, @Result);\r\n if Ret = 0 then\r\n Ret := JclWin32.RtdlGetCalendarInfoA(FLocaleID, Calendar, InfoType, nil, 0, @Result);\r\n if Ret = 0 then\r\n Result := 0;\r\nend;\r\n\r\nfunction TJclLocaleInfo.GetCalTwoDigitYearMax(Calendar: CALID): Integer;\r\nbegin\r\n Result := GetCalendarIntegerInfo(Calendar, CAL_ITWODIGITYEARMAX);\r\nend;\r\n\r\nfunction EnumCalendarInfoProcEx(lpCalendarInfoString: PWideChar; Calendar: CALID): BOOL; stdcall;\r\nbegin\r\n ProcessedLocaleInfoList.AddObject(lpCalendarInfoString, Pointer(Calendar));\r\n Result := True;\r\nend;\r\n\r\nfunction EnumCalendarInfoProcName(lpCalendarInfoString: PChar): BOOL; stdcall;\r\nbegin\r\n ProcessedLocaleInfoList.Add(lpCalendarInfoString);\r\n Result := True;\r\nend;\r\n\r\nfunction TJclLocaleInfo.GetCalendars: TStrings;\r\nvar\r\n C: CALTYPE;\r\n\r\nbegin\r\n if not FValidCalendars then\r\n begin\r\n if FCalendars = nil then\r\n FCalendars := TStringList.Create\r\n else\r\n FCalendars.Clear;\r\n ProcessedLocaleInfoList := FCalendars;\r\n try\r\n C := CAL_SCALNAME or LocaleUseAcp[FUseSystemACP];\r\n if not JclWin32.RtdlEnumCalendarInfoExW(EnumCalendarInfoProcEx, FLocaleID, ENUM_ALL_CALENDARS, C) then\r\n {$IFDEF HAS_UNITSCOPE}Winapi.{$ENDIF}Windows.EnumCalendarInfo(@EnumCalendarInfoProcName, FLocaleID, ENUM_ALL_CALENDARS, C);\r\n FValidCalendars := True;\r\n finally\r\n ProcessedLocaleInfoList := nil;\r\n end;\r\n end;\r\n Result := FCalendars;\r\nend;\r\n\r\nfunction TJclLocaleInfo.GetCalendarStringInfo(Calendar: CALID; InfoType: Integer): string;\r\nvar\r\n Buffer: Pointer;\r\n BufferSize: Integer;\r\n Ret: DWORD;\r\nbegin\r\n Result := '';\r\n InfoType := InfoType or Integer(LocaleUseAcp[FUseSystemACP]);\r\n Buffer := nil;\r\n try\r\n BufferSize := 128;\r\n repeat\r\n ReallocMem(Buffer, BufferSize);\r\n Ret := RtdlGetCalendarInfoW(FLocaleID, Calendar, InfoType, Buffer, BufferSize, nil);\r\n if (Ret = 0) and (GetLastError = ERROR_INSUFFICIENT_BUFFER) then\r\n BufferSize := RtdlGetCalendarInfoW(FLocaleID, Calendar, InfoType, Buffer, 0, nil) * 2;\r\n until (Ret > 0) or (GetLastError <> ERROR_INSUFFICIENT_BUFFER);\r\n if Ret > 0 then\r\n Result := PWideChar(Buffer)\r\n else\r\n begin\r\n BufferSize := 64;\r\n repeat\r\n ReallocMem(Buffer, BufferSize);\r\n Ret := RtdlGetCalendarInfoA(FLocaleID, Calendar, InfoType, Buffer, BufferSize, nil);\r\n if (Ret = 0) and (GetLastError = ERROR_INSUFFICIENT_BUFFER) then\r\n BufferSize := RtdlGetCalendarInfoA(FLocaleID, Calendar, InfoType, Buffer, 0, nil);\r\n until (Ret > 0) or (GetLastError <> ERROR_INSUFFICIENT_BUFFER);\r\n if Ret > 0 then\r\n Result := PChar(Buffer);\r\n end;\r\n finally\r\n FreeMem(Buffer);\r\n end;\r\nend;\r\n\r\nfunction TJclLocaleInfo.GetCharInfo(InfoType: Integer): Char;\r\nvar\r\n S: string;\r\nbegin\r\n S := GetStringInfo(InfoType);\r\n if Length(S) >= 1 then\r\n Result := S[1]\r\n else\r\n Result := ' ';\r\nend;\r\n\r\nfunction EnumDateFormatsProc(lpDateFormatString: LPWSTR): BOOL; stdcall;\r\nbegin\r\n ProcessedLocaleInfoList.Add(lpDateFormatString);\r\n DWORD(Result) := 1;\r\nend;\r\n\r\nfunction TJclLocaleInfo.GetDateFormats(Format: TJclLocaleDateFormats): TStrings;\r\nconst\r\n DateFormats: array [TJclLocaleDateFormats] of DWORD =\r\n (DATE_SHORTDATE, DATE_LONGDATE, DATE_YEARMONTH);\r\nbegin\r\n if not (Format in FValidDateFormatLists) then\r\n begin\r\n if FDateFormats[Format] = nil then\r\n FDateFormats[Format] := TStringList.Create\r\n else\r\n FDateFormats[Format].Clear;\r\n ProcessedLocaleInfoList := FDateFormats[Format];\r\n try\r\n {$IFDEF HAS_UNITSCOPE}Winapi.{$ENDIF}Windows.EnumDateFormatsW(@EnumDateFormatsProc, FLocaleID, DateFormats[Format] or\r\n LocaleUseAcp[FUseSystemACP]);\r\n Include(FValidDateFormatLists, Format);\r\n finally\r\n ProcessedLocaleInfoList := nil;\r\n end;\r\n end;\r\n Result := FDateFormats[Format];\r\nend;\r\n\r\nfunction TJclLocaleInfo.GetFontCharset: Byte;\r\nbegin\r\n Result := CharSetFromLocale(FLocaleID);\r\nend;\r\n\r\nfunction TJclLocaleInfo.GetIntegerInfo(InfoType: Integer): Integer;\r\nbegin\r\n Result := StrToIntDef(GetStringInfo(InfoType), 0);\r\nend;\r\n\r\nfunction TJclLocaleInfo.GetLangID: LANGID;\r\nbegin\r\n Result := LANGIDFROMLCID(FLocaleID);\r\nend;\r\n\r\nfunction TJclLocaleInfo.GetLangIDPrimary: Word;\r\nbegin\r\n Result := PRIMARYLANGID(LangID);\r\nend;\r\n\r\nfunction TJclLocaleInfo.GetLangIDSub: Word;\r\nbegin\r\n Result := SUBLANGID(LangID);\r\nend;\r\n\r\nfunction TJclLocaleInfo.GetLongDayNames(Day: TJclLocalesDays): string;\r\nbegin\r\n Result := GetStringInfo(LOCALE_SDAYNAME1 + Day - 1);\r\nend;\r\n\r\nfunction TJclLocaleInfo.GetLongMonthNames(Month: TJclLocalesMonths): string;\r\nvar\r\n Param: DWORD;\r\nbegin\r\n if Month = 13 then\r\n Param := LOCALE_SMONTHNAME13\r\n else\r\n Param := LOCALE_SMONTHNAME1 + Month - 1;\r\n Result := GetStringInfo(Param);\r\nend;\r\n\r\nfunction TJclLocaleInfo.GetSortID: Word;\r\nbegin\r\n Result := SORTIDFROMLCID(FLocaleID);\r\nend;\r\n\r\nfunction TJclLocaleInfo.GetStringInfo(InfoType: Integer): string;\r\nvar\r\n Res: Integer;\r\n W: PWideChar;\r\nbegin\r\n InfoType := InfoType or Integer(LocaleUseAcp[FUseSystemACP]);\r\n Res := GetLocaleInfoA(FLocaleID, InfoType, nil, 0);\r\n if Res > 0 then\r\n begin\r\n SetString(Result, nil, Res);\r\n Res := {$IFDEF HAS_UNITSCOPE}Winapi.{$ENDIF}Windows.GetLocaleInfo(FLocaleID, InfoType, PChar(Result), Res);\r\n StrResetLength(Result);\r\n // Note: GetLocaleInfo returns sometimes incorrect length of string on Win95 (usually plus 1),\r\n // that's why StrResetLength is called.\r\n end\r\n else // GetLocaleInfoA failed\r\n if IsWinNT then\r\n begin\r\n Res := GetLocaleInfoW(FLocaleID, InfoType, nil, 0);\r\n if Res > 0 then\r\n begin\r\n GetMem(W, Res * SizeOf(WideChar));\r\n Res := {$IFDEF HAS_UNITSCOPE}Winapi.{$ENDIF}Windows.GetLocaleInfoW(FLocaleID, InfoType, W, Res);\r\n Result := WideCharToString(W);\r\n FreeMem(W);\r\n end;\r\n end;\r\n if Res = 0 then\r\n Result := '';\r\nend;\r\n\r\nfunction EnumTimeFormatsProc(lpTimeFormatString: LPWSTR): BOOL; stdcall;\r\nbegin\r\n ProcessedLocaleInfoList.Add(lpTimeFormatString);\r\n DWORD(Result) := 1;\r\nend;\r\n\r\nfunction TJclLocaleInfo.GetTimeFormats: TStrings;\r\nbegin\r\n if not FValidTimeFormatLists then\r\n begin\r\n if FTimeFormats = nil then\r\n FTimeFormats := TStringList.Create\r\n else\r\n FTimeFormats.Clear;\r\n ProcessedLocaleInfoList := FTimeFormats;\r\n try\r\n {$IFDEF HAS_UNITSCOPE}Winapi.{$ENDIF}Windows.EnumTimeFormatsW(@EnumTimeFormatsProc, FLocaleID, LocaleUseAcp[FUseSystemACP]);\r\n FValidTimeFormatLists := True;\r\n finally\r\n ProcessedLocaleInfoList := nil;\r\n end;\r\n end;\r\n Result := FTimeFormats;\r\nend;\r\n\r\nprocedure TJclLocaleInfo.SetCharInfo(InfoType: Integer; const Value: Char);\r\nbegin\r\n SetStringInfo(InfoType, Value);\r\nend;\r\n\r\nprocedure TJclLocaleInfo.SetIntegerInfo(InfoType: Integer; const Value: Integer);\r\nbegin\r\n SetStringInfo(InfoType, IntToStr(Value));\r\nend;\r\n\r\nprocedure TJclLocaleInfo.SetStringInfo(InfoType: Integer; const Value: string);\r\nbegin\r\n Win32Check({$IFDEF HAS_UNITSCOPE}Winapi.{$ENDIF}Windows.SetLocaleInfo(FLocaleID, InfoType, PChar(Value)));\r\nend;\r\n\r\nprocedure TJclLocaleInfo.SetUseSystemACP(const Value: Boolean);\r\nbegin\r\n if FUseSystemACP <> Value then\r\n begin\r\n FUseSystemACP := Value;\r\n FValidCalendars := False;\r\n FValidDateFormatLists := [];\r\n FValidTimeFormatLists := False;\r\n end;\r\nend;\r\n\r\n//=== { TJclLocalesList } ====================================================\r\n\r\nconstructor TJclLocalesList.Create(AKind: TJclLocalesKind);\r\nbegin\r\n inherited Create(True);\r\n FCodePages := TStringList.Create;\r\n FKind := AKind;\r\n CreateList;\r\nend;\r\n\r\ndestructor TJclLocalesList.Destroy;\r\nbegin\r\n FreeAndNil(FCodePages);\r\n inherited Destroy;\r\nend;\r\n\r\nfunction EnumLocalesProc(lpLocaleString: LPWSTR): BOOL; stdcall;\r\nvar\r\n LocaleID: LCID;\r\nbegin\r\n LocaleID := StrToIntDef('$' + Copy(lpLocaleString, 5, 4), 0);\r\n if LocaleID > 0 then\r\n ProcessedLocalesList.Add(TJclLocaleInfo.Create(LocaleID));\r\n DWORD(Result) := 1;\r\nend;\r\n\r\nfunction EnumCodePagesProc(lpCodePageString: LPWSTR): BOOL; stdcall;\r\nbegin\r\n ProcessedLocalesList.CodePages.AddObject(lpCodePageString, Pointer(StrToIntDef(lpCodePageString, 0)));\r\n DWORD(Result) := 1;\r\nend;\r\n\r\nprocedure TJclLocalesList.CreateList;\r\nconst\r\n Flags: array [TJclLocalesKind] of DWORD = (LCID_INSTALLED, LCID_SUPPORTED);\r\nbegin\r\n ProcessedLocalesList := Self;\r\n try\r\n Win32Check({$IFDEF HAS_UNITSCOPE}Winapi.{$ENDIF}Windows.EnumSystemLocalesW(@EnumLocalesProc, Flags[FKind]));\r\n Win32Check({$IFDEF HAS_UNITSCOPE}Winapi.{$ENDIF}Windows.EnumSystemCodePagesW(@EnumCodePagesProc, Flags[FKind]));\r\n finally\r\n ProcessedLocalesList := nil;\r\n end;\r\nend;\r\n\r\nprocedure TJclLocalesList.FillStrings(AStrings: TStrings; InfoType: Integer);\r\nvar\r\n I: Integer;\r\nbegin\r\n AStrings.BeginUpdate;\r\n try\r\n for I := 0 to Count - 1 do\r\n with Items[I] do\r\n AStrings.AddObject(StringInfo[InfoType], Pointer(LocaleId));\r\n finally\r\n AStrings.EndUpdate;\r\n end;\r\nend;\r\n\r\nfunction TJclLocalesList.GetCodePages: TStrings;\r\nbegin\r\n Result := FCodePages;\r\nend;\r\n\r\nfunction TJclLocalesList.GetItemFromLangID(LangID: LANGID): TJclLocaleInfo;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := nil;\r\n for I := 0 to Count - 1 do\r\n if Items[I].LangID = LangID then\r\n begin\r\n Result := Items[I];\r\n Break;\r\n end;\r\nend;\r\n\r\nfunction TJclLocalesList.GetItemFromLangIDPrimary(LangIDPrimary: Word): TJclLocaleInfo;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := nil;\r\n for I := 0 to Count - 1 do\r\n if Items[I].LangIDPrimary = LangIDPrimary then\r\n begin\r\n Result := Items[I];\r\n Break;\r\n end;\r\nend;\r\n\r\nfunction TJclLocalesList.GetItemFromLocaleID(LocaleID: LCID): TJclLocaleInfo;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := nil;\r\n for I := 0 to Count - 1 do\r\n if Items[I].LocaleID = LocaleID then\r\n begin\r\n Result := Items[I];\r\n Break;\r\n end;\r\nend;\r\n\r\nfunction TJclLocalesList.GetItems(Index: Integer): TJclLocaleInfo;\r\nbegin\r\n Result := TJclLocaleInfo(inherited Items[Index]);\r\nend;\r\n\r\n//=== { TJclAvailableKeybLayout } ============================================\r\n\r\nfunction TJclAvailableKeybLayout.GetIdentifierName: string;\r\nbegin\r\n Result := Format('%.8x', [FIdentifier]);\r\nend;\r\n\r\nfunction TJclAvailableKeybLayout.GetLayoutFileExists: Boolean;\r\nbegin\r\n Result := FileExists(PathAddSeparator(GetWindowsSystemFolder) + LayoutFile);\r\nend;\r\n\r\nfunction TJclAvailableKeybLayout.Load(const LoadFlags: TJclKeybLayoutFlags): Boolean;\r\nbegin\r\n Result := FOwner.LoadLayout(IdentifierName, LoadFlags);\r\nend;\r\n\r\n//=== { TJclKeyboardLayout } =================================================\r\n\r\nconstructor TJclKeyboardLayout.Create(AOwner: TJclKeyboardLayoutList; ALayout: HKL);\r\nbegin\r\n inherited Create;\r\n FLayout := ALayout;\r\n FOwner := AOwner;\r\nend;\r\n\r\ndestructor TJclKeyboardLayout.Destroy;\r\nbegin\r\n FreeAndNil(FLocaleInfo);\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJclKeyboardLayout.Activate(ActivateFlags: TJclKeybLayoutFlags): Boolean;\r\nbegin\r\n Result := ActivateKeyboardLayout(FLayout, KeybLayoutFlagsToDWORD(ActivateFlags, False)) {$IFNDEF FPC} <> 0 {$ENDIF};\r\nend;\r\n\r\nfunction TJclKeyboardLayout.GetDeviceHandle: Word;\r\nbegin\r\n Result := HiWord(FLayout);\r\nend;\r\n\r\nfunction TJclKeyboardLayout.GetDisplayName: string;\r\nbegin\r\n Result := LocaleInfo.LocalizedLangName;\r\n if HiWord(FLayout) <> LoWord(FLayout) then\r\n Result := Result + ' - ' + VariationName;\r\nend;\r\n\r\nfunction TJclKeyboardLayout.GetLocaleID: Word;\r\nbegin\r\n Result := LoWord(FLayout);\r\nend;\r\n\r\nfunction TJclKeyboardLayout.GetLocaleInfo: TJclLocaleInfo;\r\nbegin\r\n if FLocaleInfo = nil then\r\n FLocaleInfo := TJclLocaleInfo.Create(MAKELCID(GetLocaleID, SORT_DEFAULT));\r\n Result := FLocaleInfo;\r\nend;\r\n\r\nfunction TJclKeyboardLayout.GetVariationName: string;\r\nvar\r\n I: Integer;\r\n Ident: DWORD;\r\nbegin\r\n Result := '';\r\n if HiWord(FLayout) = LoWord(FLayout) then\r\n Ident := LoWord(FLayout)\r\n else\r\n Ident := FLayout and $0FFFFFFF;\r\n with FOwner do\r\n for I := 0 to AvailableLayoutCount - 1 do\r\n with AvailableLayouts[I] do\r\n if (LoWord(Identifier) = LoWord(Ident)) and (LayoutID = HiWord(Ident)) then\r\n begin\r\n Result := Name;\r\n Break;\r\n end;\r\nend;\r\n\r\nfunction TJclKeyboardLayout.Unload: Boolean;\r\nbegin\r\n Result := {$IFDEF HAS_UNITSCOPE}Winapi.{$ENDIF}Windows.UnloadKeyboardLayout(FLayout);\r\n if Result then\r\n FOwner.Refresh;\r\nend;\r\n\r\n//=== { TJclKeyboardLayoutList } =============================================\r\n\r\nconstructor TJclKeyboardLayoutList.Create;\r\nbegin\r\n inherited Create;\r\n FList := TObjectList.Create(True);\r\n CreateAvailableLayouts;\r\n Refresh;\r\nend;\r\n\r\ndestructor TJclKeyboardLayoutList.Destroy;\r\nbegin\r\n FreeAndNil(FAvailableLayouts);\r\n FreeAndNil(FList);\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJclKeyboardLayoutList.ActivateNextLayout(ActivateFlags: TJclKeybLayoutFlags): Boolean;\r\nbegin\r\n Result := ActivateKeyboardLayout(HKL_NEXT, KeybLayoutFlagsToDWORD(ActivateFlags, False)) {$IFNDEF FPC} <> 0 {$ENDIF};\r\nend;\r\n\r\nfunction TJclKeyboardLayoutList.ActivatePrevLayout(\r\n ActivateFlags: TJclKeybLayoutFlags): Boolean;\r\nbegin\r\n Result := ActivateKeyboardLayout(HKL_PREV, KeybLayoutFlagsToDWORD(ActivateFlags, False)) {$IFNDEF FPC} <> 0 {$ENDIF};\r\nend;\r\n\r\n// Documentation:\r\n\r\n// HOWTO: How to Find the Available Keyboard Layouts Under Windows NT\r\n// Microsoft Knowledge Base Article - 139571\r\n// http://support.microsoft.com/default.aspx?scid=kb;en-us;139571\r\n\r\n// Description of Typical Control Subkeys of the HKLM Registry Key\r\n// Microsoft Knowledge Base Article - 250447\r\n// http://support.microsoft.com/default.aspx?scid=kb;en-us;250447\r\n\r\n// http://www.microsoft.com/windows2000/techinfo/reskit/en-us/regentry/28326.asp\r\n\r\nprocedure TJclKeyboardLayoutList.CreateAvailableLayouts;\r\nconst\r\n cLayoutsKey = 'SYSTEM\\CurrentControlSet\\Control\\Keyboard Layouts';\r\nvar\r\n I: Integer;\r\n KeyNames: TStringList;\r\n Item: TJclAvailableKeybLayout;\r\n Layout: string;\r\nbegin\r\n FAvailableLayouts := TObjectList.Create(True);\r\n KeyNames := TStringList.Create;\r\n try\r\n RegGetKeyNames(HKEY_LOCAL_MACHINE, cLayoutsKey, KeyNames);\r\n for I := 0 to KeyNames.Count - 1 do\r\n begin\r\n Layout := cLayoutsKey + '\\' + KeyNames[I];\r\n Item := TJclAvailableKeybLayout.Create;\r\n Item.FOwner := Self;\r\n Item.FIdentifier := StrToIntDef('$' + KeyNames[I], 0);\r\n Item.FName := RegReadStringDef(HKEY_LOCAL_MACHINE, Layout, 'Layout Text', '');\r\n Item.FLayoutFile := RegReadStringDef(HKEY_LOCAL_MACHINE, Layout, 'Layout File', '');\r\n Item.FLayoutID := StrToIntDef('$' + RegReadStringDef(HKEY_LOCAL_MACHINE, Layout, 'Layout Id', ''), 0);\r\n FAvailableLayouts.Add(Item);\r\n end;\r\n finally\r\n KeyNames.Free;\r\n end;\r\nend;\r\n\r\nprocedure TJclKeyboardLayoutList.DoRefresh;\r\nbegin\r\n if Assigned(FOnRefresh) then\r\n FOnRefresh(Self);\r\nend;\r\n\r\nfunction TJclKeyboardLayoutList.GetActiveLayout: TJclKeyboardLayout;\r\nbegin\r\n Result := ItemFromHKL[GetKeyboardLayout(0)];\r\nend;\r\n\r\nfunction TJclKeyboardLayoutList.GetAvailableLayoutCount: Integer;\r\nbegin\r\n Result := FAvailableLayouts.Count;\r\nend;\r\n\r\nfunction TJclKeyboardLayoutList.GetAvailableLayouts(Index: Integer): TJclAvailableKeybLayout;\r\nbegin\r\n Result := TJclAvailableKeybLayout(FAvailableLayouts[Index]);\r\nend;\r\n\r\nfunction TJclKeyboardLayoutList.GetCount: Integer;\r\nbegin\r\n Result := FList.Count;\r\nend;\r\n\r\nfunction TJclKeyboardLayoutList.GetItemFromHKL(Layout: HKL): TJclKeyboardLayout;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := nil;\r\n for I := 0 to Count - 1 do\r\n if Items[I].Layout = Layout then\r\n begin\r\n Result := Items[I];\r\n Break;\r\n end;\r\nend;\r\n\r\nfunction TJclKeyboardLayoutList.GetItems(Index: Integer): TJclKeyboardLayout;\r\nbegin\r\n Result := TJclKeyboardLayout(FList[Index]);\r\nend;\r\n\r\nfunction TJclKeyboardLayoutList.GetLayoutFromLocaleID(LocaleID: Word): TJclKeyboardLayout;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := nil;\r\n for I := 0 to Count - 1 do\r\n if Items[I].LocaleID = LocaleID then\r\n begin\r\n Result := Items[I];\r\n Break;\r\n end;\r\nend;\r\n\r\nfunction TJclKeyboardLayoutList.LoadLayout(const LayoutName: string;\r\n LoadFlags: TJclKeybLayoutFlags): Boolean;\r\nbegin\r\n Result := LoadKeyboardLayout(PChar(LayoutName),\r\n KeybLayoutFlagsToDWORD(LoadFlags, True)) <> 0;\r\n if Result then\r\n Refresh;\r\nend;\r\n\r\nprocedure TJclKeyboardLayoutList.Refresh;\r\nvar\r\n Cnt, I: Integer;\r\n Layouts: array [1..JclMaxKeyboardLayouts] of HKL;\r\nbegin\r\n Layouts[1] := 0;\r\n Cnt := {$IFDEF HAS_UNITSCOPE}Winapi.{$ENDIF}Windows.GetKeyboardLayoutList(JclMaxKeyboardLayouts, Layouts);\r\n // Note: GetKeyboardLayoutList doesn't work as expected, when pass 0 to nBuff it always returns 0\r\n // on Win95.\r\n FList.Clear;\r\n for I := 1 to Cnt do\r\n FList.Add(TJclKeyboardLayout.Create(Self, Layouts[I]));\r\n DoRefresh;\r\nend;\r\n\r\n{ TODO : related MSDN entries, maybe to implement }\r\n// Enabling the Shift Lock Feature on Windows NT 4.0\r\n// Microsoft Knowledge Base Article - 174543\r\n// http://support.microsoft.com/default.aspx?scid=kb;en-us;174543\r\n\r\n//=== Various routines =======================================================\r\n\r\nprocedure JclLocalesInfoList(const Strings: TStrings; InfoType: Integer);\r\nbegin\r\n with TJclLocalesList.Create(lkInstalled) do\r\n try\r\n FillStrings(Strings, InfoType);\r\n finally\r\n Free;\r\n end;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jcl/source/windows/JclMapi.pas", "content": "{**************************************************************************************************}\r\n{ }\r\n{ Project JEDI Code Library (JCL) }\r\n{ }\r\n{ The contents of this file are subject to the Mozilla Public License Version 1.1 (the \"License\"); }\r\n{ you may not use this file except in compliance with the License. You may obtain a copy of the }\r\n{ License at http://www.mozilla.org/MPL/ }\r\n{ }\r\n{ Software distributed under the License is distributed on an \"AS IS\" basis, WITHOUT WARRANTY OF }\r\n{ ANY KIND, either express or implied. See the License for the specific language governing rights }\r\n{ and limitations under the License. }\r\n{ }\r\n{ The Original Code is JclMapi.pas. }\r\n{ }\r\n{ The Initial Developer of the Original Code is Petr Vones. }\r\n{ Portions created by Petr Vones are Copyright (C) Petr Vones. All Rights Reserved. }\r\n{ }\r\n{ Contributors: }\r\n{ Marcel van Brakel }\r\n{ Robert Marquardt (marquardt) }\r\n{ Matthias Thoma (mthoma) }\r\n{ Petr Vones (pvones) }\r\n{ Carsten Schuette (schuettecarsten) }\r\n{ }\r\n{**************************************************************************************************}\r\n{ }\r\n{ Various classes and support routines for sending e-mail through Simple MAPI }\r\n{ }\r\n{**************************************************************************************************}\r\n{ }\r\n{ Last modified: $Date:: 2012-06-05 14:22:52 +0200 (mar. 05 juin 2012) $ }\r\n{ Revision: $Rev:: 3802 $ }\r\n{ Author: $Author:: ahuser $ }\r\n{ }\r\n{**************************************************************************************************}\r\n\r\nunit JclMapi;\r\n\r\n{$I jcl.inc}\r\n{$I windowsonly.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n {$IFDEF HAS_UNITSCOPE}\r\n Winapi.Windows, System.Classes, System.Contnrs, Winapi.Mapi, System.SysUtils,\r\n {$ELSE ~HAS_UNITSCOPE}\r\n Windows, Classes, Contnrs, Mapi, SysUtils,\r\n {$ENDIF ~HAS_UNITSCOPE}\r\n JclBase, JclAnsiStrings;\r\n\r\ntype\r\n EJclMapiError = class(EJclError)\r\n private\r\n FErrorCode: DWORD;\r\n public\r\n property ErrorCode: DWORD read FErrorCode;\r\n end;\r\n\r\n // Simple MAPI interface\r\n TJclMapiClient = record\r\n ClientName: string;\r\n ClientPath: string;\r\n RegKeyName: string;\r\n Valid: Boolean;\r\n end;\r\n\r\n TJclMapiClientConnect = (ctAutomatic, ctMapi, ctDirect);\r\n\r\n TJclSimpleMapi = class(TObject)\r\n private\r\n FAnyClientInstalled: Boolean;\r\n FBeforeUnloadClient: TNotifyEvent;\r\n FClients: array of TJclMapiClient;\r\n FClientConnectKind: TJclMapiClientConnect;\r\n FClientLibHandle: THandle;\r\n FDefaultClientIndex: Integer;\r\n FDefaultProfileName: AnsiString;\r\n FFunctions: array[0..11] of ^Pointer;\r\n FMapiInstalled: Boolean;\r\n FMapiVersion: string;\r\n FProfiles: array of AnsiString;\r\n FSelectedClientIndex: Integer;\r\n FSimpleMapiInstalled: Boolean;\r\n { TODO : consider to move this to a internal single instance class with smart linking }\r\n FMapiAddress: TFNMapiAddress;\r\n FMapiDeleteMail: TFNMapiDeleteMail;\r\n FMapiDetails: TFNMapiDetails;\r\n FMapiFindNext: TFNMapiFindNext;\r\n FMapiFreeBuffer: TFNMapiFreeBuffer;\r\n FMapiLogOff: TFNMapiLogOff;\r\n FMapiLogOn: TFNMapiLogOn;\r\n FMapiReadMail: TFNMapiReadMail;\r\n FMapiResolveName: TFNMapiResolveName;\r\n FMapiSaveMail: TFNMapiSaveMail;\r\n FMapiSendDocuments: TFNMapiSendDocuments;\r\n FMapiSendMail: TFNMapiSendMail;\r\n function GetClientCount: Integer;\r\n function GetClients(Index: Integer): TJclMapiClient;\r\n function GetCurrentClientName: string;\r\n function GetProfileCount: Integer;\r\n function GetProfiles(Index: Integer): AnsiString;\r\n procedure SetSelectedClientIndex(const Value: Integer);\r\n procedure SetClientConnectKind(const Value: TJclMapiClientConnect);\r\n function UseMapi: Boolean;\r\n protected\r\n procedure BeforeUnloadClientLib; dynamic;\r\n procedure CheckListIndex(I, ArrayLength: Integer);\r\n function GetClientLibName: string;\r\n class function ProfilesRegKey: string;\r\n procedure ReadMapiSettings;\r\n public\r\n constructor Create;\r\n destructor Destroy; override;\r\n function ClientLibLoaded: Boolean;\r\n procedure LoadClientLib;\r\n procedure UnloadClientLib;\r\n property AnyClientInstalled: Boolean read FAnyClientInstalled;\r\n property ClientConnectKind: TJclMapiClientConnect read FClientConnectKind write SetClientConnectKind;\r\n property ClientCount: Integer read GetClientCount;\r\n property Clients[Index: Integer]: TJclMapiClient read GetClients; default;\r\n property CurrentClientName: string read GetCurrentClientName;\r\n property DefaultClientIndex: Integer read FDefaultClientIndex;\r\n property DefaultProfileName: AnsiString read FDefaultProfileName;\r\n property MapiInstalled: Boolean read FMapiInstalled;\r\n property MapiVersion: string read FMapiVersion;\r\n property ProfileCount: Integer read GetProfileCount;\r\n property Profiles[Index: Integer]: AnsiString read GetProfiles;\r\n property SelectedClientIndex: Integer read FSelectedClientIndex write SetSelectedClientIndex;\r\n property SimpleMapiInstalled: Boolean read FSimpleMapiInstalled;\r\n property BeforeUnloadClient: TNotifyEvent read FBeforeUnloadClient write FBeforeUnloadClient;\r\n // Simple MAPI functions\r\n property MapiAddress: TFNMapiAddress read FMapiAddress;\r\n property MapiDeleteMail: TFNMapiDeleteMail read FMapiDeleteMail;\r\n property MapiDetails: TFNMapiDetails read FMapiDetails;\r\n property MapiFindNext: TFNMapiFindNext read FMapiFindNext;\r\n property MapiFreeBuffer: TFNMapiFreeBuffer read FMapiFreeBuffer;\r\n property MapiLogOff: TFNMapiLogOff read FMapiLogOff;\r\n property MapiLogOn: TFNMapiLogOn read FMapiLogOn;\r\n property MapiReadMail: TFNMapiReadMail read FMapiReadMail;\r\n property MapiResolveName: TFNMapiResolveName read FMapiResolveName;\r\n property MapiSaveMail: TFNMapiSaveMail read FMapiSaveMail;\r\n property MapiSendDocuments: TFNMapiSendDocuments read FMapiSendDocuments;\r\n property MapiSendMail: TFNMapiSendMail read FMapiSendMail;\r\n end;\r\n\r\nconst\r\n // Simple email classes\r\n MapiAddressTypeSMTP = 'SMTP';\r\n MapiAddressTypeFAX = 'FAX';\r\n MapiAddressTypeTLX = 'TLX';\r\n\r\ntype\r\n TJclEmailRecipKind = (rkOriginator, rkTO, rkCC, rkBCC);\r\n\r\n TJclEmailRecip = class(TObject)\r\n private\r\n FAddress: AnsiString;\r\n FAddressType: AnsiString;\r\n FKind: TJclEmailRecipKind;\r\n FName: AnsiString;\r\n private\r\n procedure SetAddress(Value: AnsiString);\r\n protected\r\n function SortingName: AnsiString;\r\n public\r\n function AddressAndName: AnsiString;\r\n class function RecipKindToString(const AKind: TJclEmailRecipKind): AnsiString;\r\n property AddressType: AnsiString read FAddressType write FAddressType;\r\n property Address: AnsiString read FAddress write SetAddress;\r\n property Kind: TJclEmailRecipKind read FKind write FKind;\r\n property Name: AnsiString read FName write FName;\r\n end;\r\n\r\n TJclEmailRecips = class(TObjectList)\r\n private\r\n FAddressesType: AnsiString;\r\n function GetItems(Index: Integer): TJclEmailRecip;\r\n function GetOriginator: TJclEmailRecip;\r\n public\r\n function Add(const Address: AnsiString;\r\n const Name: AnsiString = '';\r\n const Kind: TJclEmailRecipKind = rkTO;\r\n const AddressType: AnsiString = ''): Integer;\r\n procedure SortRecips;\r\n property AddressesType: AnsiString read FAddressesType write FAddressesType;\r\n property Items[Index: Integer]: TJclEmailRecip read GetItems; default;\r\n property Originator: TJclEmailRecip read GetOriginator;\r\n end;\r\n\r\n TJclEmailFindOption = (foFifo, foUnreadOnly);\r\n TJclEmailLogonOption = (loLogonUI, loNewSession, loForceDownload);\r\n TJclEmailReadOption = (roAttachments, roHeaderOnly, roMarkAsRead);\r\n\r\n TJclEmailFindOptions = set of TJclEmailFindOption;\r\n TJclEmailLogonOptions = set of TJclEmailLogonOption;\r\n TJclEmailReadOptions = set of TJclEmailReadOption;\r\n\r\n TJclEmailReadMsg = record\r\n ConversationID: AnsiString;\r\n DateReceived: TDateTime;\r\n MessageType: AnsiString;\r\n Flags: FLAGS;\r\n end;\r\n\r\n TJclTaskWindowsList = array of THandle;\r\n\r\n TJclEmail = class(TJclSimpleMapi)\r\n private\r\n FAttachments: TJclAnsiStringList;\r\n FBody: AnsiString;\r\n FFindOptions: TJclEmailFindOptions;\r\n FHtmlBody: Boolean;\r\n FLogonOptions: TJclEmailLogonOptions;\r\n FParentWnd: THandle;\r\n FParentWndValid: Boolean;\r\n FReadMsg: TJclEmailReadMsg;\r\n FRecipients: TJclEmailRecips;\r\n FSeedMessageID: AnsiString;\r\n FSessionHandle: THandle;\r\n FSubject: AnsiString;\r\n FTaskWindowList: TJclTaskWindowsList;\r\n FAttachmentFiles: TStringList;\r\n function GetAttachments: TJclAnsiStrings;\r\n function GetAttachmentFiles: TStrings;\r\n function GetParentWnd: THandle;\r\n function GetUserLogged: Boolean;\r\n procedure SetBody(const Value: AnsiString);\r\n procedure SetParentWnd(const Value: THandle);\r\n protected\r\n procedure BeforeUnloadClientLib; override;\r\n procedure DecodeRecips(RecipDesc: PMapiRecipDesc; Count: Integer);\r\n function InternalSendOrSave(Save: Boolean; ShowDialog: Boolean): Boolean;\r\n function LogonOptionsToFlags(ShowDialog: Boolean): DWORD;\r\n public\r\n constructor Create;\r\n destructor Destroy; override;\r\n function Address(const Caption: AnsiString = ''; EditFields: Integer = 3): Boolean;\r\n procedure Clear;\r\n function Delete(const MessageID: AnsiString): Boolean;\r\n function FindFirstMessage: Boolean;\r\n function FindNextMessage: Boolean;\r\n procedure LogOff;\r\n procedure LogOn(const ProfileName: AnsiString = ''; const Password: AnsiString = '');\r\n function MessageReport(Strings: TStrings; MaxWidth: Integer = 80; IncludeAddresses: Boolean = False): Integer;\r\n function Read(const Options: TJclEmailReadOptions = []): Boolean;\r\n function ResolveName(var Name, Address: AnsiString; ShowDialog: Boolean = False): Boolean;\r\n procedure RestoreTaskWindows;\r\n function Save: Boolean;\r\n procedure SaveTaskWindows;\r\n function Send(ShowDialog: Boolean = True): Boolean;\r\n procedure SortAttachments;\r\n property Attachments: TJclAnsiStrings read GetAttachments;\r\n property AttachmentFiles: TStrings read GetAttachmentFiles;\r\n property Body: AnsiString read FBody write SetBody;\r\n property FindOptions: TJclEmailFindOptions read FFindOptions write FFindOptions;\r\n property HtmlBody: Boolean read FHtmlBody write FHtmlBody;\r\n property LogonOptions: TJclEmailLogonOptions read FLogonOptions write FLogonOptions;\r\n property ParentWnd: THandle read GetParentWnd write SetParentWnd;\r\n property ReadMsg: TJclEmailReadMsg read FReadMsg;\r\n property Recipients: TJclEmailRecips read FRecipients;\r\n property SeedMessageID: AnsiString read FSeedMessageID write FSeedMessageID;\r\n property SessionHandle: THandle read FSessionHandle;\r\n property Subject: AnsiString read FSubject write FSubject;\r\n property UserLogged: Boolean read GetUserLogged;\r\n end;\r\n\r\n// Simple email send function\r\nfunction JclSimpleSendMail(const Recipient, Name, Subject, Body: AnsiString;\r\n const Attachment: TFileName = ''; ShowDialog: Boolean = True; ParentWND: THandle = 0;\r\n const ProfileName: AnsiString = ''; const Password: AnsiString = ''): Boolean;\r\n\r\nfunction JclSimpleSendFax(const Recipient, Name, Subject, Body: AnsiString;\r\n const Attachment: TFileName = ''; ShowDialog: Boolean = True; ParentWND: THandle = 0;\r\n const ProfileName: AnsiString = ''; const Password: AnsiString = ''): Boolean;\r\n\r\nfunction JclSimpleBringUpSendMailDialog(const Subject, Body: AnsiString;\r\n const Attachment: TFileName = ''; ParentWND: THandle = 0;\r\n const ProfileName: AnsiString = ''; const Password: AnsiString = ''): Boolean;\r\n\r\n// MAPI Errors\r\nfunction MapiCheck(const Res: DWORD; IgnoreUserAbort: Boolean = True): DWORD;\r\n\r\nfunction MapiErrorMessage(const ErrorCode: DWORD): string;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jcl.svn.sourceforge.net/svnroot/jcl/tags/JCL-2.4-Build4571/jcl/source/windows/JclMapi.pas $';\r\n Revision: '$Revision: 3802 $';\r\n Date: '$Date: 2012-06-05 14:22:52 +0200 (mar. 05 juin 2012) $';\r\n LogPath: 'JCL\\source\\windows';\r\n Extra: '';\r\n Data: nil\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n {$IFDEF HAS_UNITSCOPE}\r\n {$IFDEF HAS_UNIT_ANSISTRINGS}\r\n System.AnsiStrings,\r\n {$ENDIF HAS_UNIT_ANSISTRINGS}\r\n {$ELSE ~HAS_UNITSCOPE}\r\n {$IFDEF HAS_UNIT_ANSISTRINGS}\r\n AnsiStrings,\r\n {$ENDIF HAS_UNIT_ANSISTRINGS}\r\n {$ENDIF ~HAS_UNITSCOPE}\r\n JclFileUtils, JclLogic, JclPeImage, JclRegistry, JclResources, JclSysInfo, JclSysUtils;\r\n\r\nconst\r\n MapiDll = 'mapi32.dll';\r\n MapiExportNames: array [0..11] of PChar = (\r\n 'MAPIAddress',\r\n 'MAPIDeleteMail',\r\n 'MAPIDetails',\r\n 'MAPIFindNext',\r\n 'MAPIFreeBuffer',\r\n 'MAPILogoff',\r\n 'MAPILogon',\r\n 'MAPIReadMail',\r\n 'MAPIResolveName',\r\n 'MAPISaveMail',\r\n 'MAPISendDocuments',\r\n 'MAPISendMail');\r\n AddressTypeDelimiter = AnsiChar(':');\r\n\r\n//=== MAPI Errors check ======================================================\r\n\r\nfunction MapiCheck(const Res: DWORD; IgnoreUserAbort: Boolean): DWORD;\r\nvar\r\n Error: EJclMapiError;\r\nbegin\r\n if (Res = SUCCESS_SUCCESS) or (IgnoreUserAbort and (Res = MAPI_E_USER_ABORT)) then\r\n Result := Res\r\n else\r\n begin\r\n Error := EJclMapiError.CreateResFmt(@RsMapiError, [Res, MapiErrorMessage(Res)]);\r\n Error.FErrorCode := Res;\r\n raise Error;\r\n end;\r\nend;\r\n\r\nfunction MapiErrorMessage(const ErrorCode: DWORD): string;\r\nbegin\r\n case ErrorCode of\r\n MAPI_E_USER_ABORT:\r\n Result := LoadResString(@RsMapiErrUSER_ABORT);\r\n MAPI_E_FAILURE:\r\n Result := LoadResString(@RsMapiErrFAILURE);\r\n MAPI_E_LOGIN_FAILURE:\r\n Result := LoadResString(@RsMapiErrLOGIN_FAILURE);\r\n MAPI_E_DISK_FULL:\r\n Result := LoadResString(@RsMapiErrDISK_FULL);\r\n MAPI_E_INSUFFICIENT_MEMORY:\r\n Result := LoadResString(@RsMapiErrINSUFFICIENT_MEMORY);\r\n MAPI_E_ACCESS_DENIED:\r\n Result := LoadResString(@RsMapiErrACCESS_DENIED);\r\n MAPI_E_TOO_MANY_SESSIONS:\r\n Result := LoadResString(@RsMapiErrTOO_MANY_SESSIONS);\r\n MAPI_E_TOO_MANY_FILES:\r\n Result := LoadResString(@RsMapiErrTOO_MANY_FILES);\r\n MAPI_E_TOO_MANY_RECIPIENTS:\r\n Result := LoadResString(@RsMapiErrTOO_MANY_RECIPIENTS);\r\n MAPI_E_ATTACHMENT_NOT_FOUND:\r\n Result := LoadResString(@RsMapiErrATTACHMENT_NOT_FOUND);\r\n MAPI_E_ATTACHMENT_OPEN_FAILURE:\r\n Result := LoadResString(@RsMapiErrATTACHMENT_OPEN_FAILURE);\r\n MAPI_E_ATTACHMENT_WRITE_FAILURE:\r\n Result := LoadResString(@RsMapiErrATTACHMENT_WRITE_FAILURE);\r\n MAPI_E_UNKNOWN_RECIPIENT:\r\n Result := LoadResString(@RsMapiErrUNKNOWN_RECIPIENT);\r\n MAPI_E_BAD_RECIPTYPE:\r\n Result := LoadResString(@RsMapiErrBAD_RECIPTYPE);\r\n MAPI_E_NO_MESSAGES:\r\n Result := LoadResString(@RsMapiErrNO_MESSAGES);\r\n MAPI_E_INVALID_MESSAGE:\r\n Result := LoadResString(@RsMapiErrINVALID_MESSAGE);\r\n MAPI_E_TEXT_TOO_LARGE:\r\n Result := LoadResString(@RsMapiErrTEXT_TOO_LARGE);\r\n MAPI_E_INVALID_SESSION:\r\n Result := LoadResString(@RsMapiErrINVALID_SESSION);\r\n MAPI_E_TYPE_NOT_SUPPORTED:\r\n Result := LoadResString(@RsMapiErrTYPE_NOT_SUPPORTED);\r\n MAPI_E_AMBIGUOUS_RECIPIENT:\r\n Result := LoadResString(@RsMapiErrAMBIGUOUS_RECIPIENT);\r\n MAPI_E_MESSAGE_IN_USE:\r\n Result := LoadResString(@RsMapiErrMESSAGE_IN_USE);\r\n MAPI_E_NETWORK_FAILURE:\r\n Result := LoadResString(@RsMapiErrNETWORK_FAILURE);\r\n MAPI_E_INVALID_EDITFIELDS:\r\n Result := LoadResString(@RsMapiErrINVALID_EDITFIELDS);\r\n MAPI_E_INVALID_RECIPS:\r\n Result := LoadResString(@RsMapiErrINVALID_RECIPS);\r\n MAPI_E_NOT_SUPPORTED:\r\n Result := LoadResString(@RsMapiErrNOT_SUPPORTED);\r\n else\r\n Result := '';\r\n end;\r\nend;\r\n\r\nfunction RestoreTaskWnds(Wnd: THandle; List: TJclTaskWindowsList): BOOL; stdcall;\r\nvar\r\n I: Integer;\r\n EnableIt: Boolean;\r\nbegin\r\n if IsWindowVisible(Wnd) then\r\n begin\r\n EnableIt := False;\r\n for I := 1 to Length(List) - 1 do\r\n if List[I] = Wnd then\r\n begin\r\n EnableIt := True;\r\n Break;\r\n end;\r\n EnableWindow(Wnd, EnableIt);\r\n end;\r\n Result := True;\r\nend;\r\n\r\nprocedure RestoreTaskWindowsList(const List: TJclTaskWindowsList);\r\nvar\r\n I: Integer;\r\nbegin\r\n if Length(List) > 0 then\r\n begin\r\n EnumThreadWindows(MainThreadID, @RestoreTaskWnds, LPARAM(List));\r\n for I := 0 to Length(List) - 1 do\r\n EnableWindow(List[I], True);\r\n SetFocus(List[0]);\r\n end;\r\nend;\r\n\r\nfunction SaveTaskWnds(Wnd: THandle; var Data: TJclTaskWindowsList): BOOL; stdcall;\r\nvar\r\n C: Integer;\r\nbegin\r\n if IsWindowVisible(Wnd) and IsWindowEnabled(Wnd) then\r\n begin\r\n C := Length(Data);\r\n SetLength(Data, C + 1);\r\n Data[C] := Wnd;\r\n end;\r\n Result := True;\r\nend;\r\n\r\nfunction SaveTaskWindowsList: TJclTaskWindowsList;\r\nbegin\r\n SetLength(Result, 1);\r\n Result[0] := GetFocus;\r\n EnumThreadWindows(MainThreadID, @SaveTaskWnds, LPARAM(@Result));\r\nend;\r\n\r\n//=== { TJclSimpleMapi } =====================================================\r\n\r\nconstructor TJclSimpleMapi.Create;\r\nbegin\r\n inherited Create;\r\n FFunctions[0] := @@FMapiAddress;\r\n FFunctions[1] := @@FMapiDeleteMail;\r\n FFunctions[2] := @@FMapiDetails;\r\n FFunctions[3] := @@FMapiFindNext;\r\n FFunctions[4] := @@FMapiFreeBuffer;\r\n FFunctions[5] := @@FMapiLogOff;\r\n FFunctions[6] := @@FMapiLogOn;\r\n FFunctions[7] := @@FMapiReadMail;\r\n FFunctions[8] := @@FMapiResolveName;\r\n FFunctions[9] := @@FMapiSaveMail;\r\n FFunctions[10] := @@FMapiSendDocuments;\r\n FFunctions[11] := @@FMapiSendMail;\r\n FDefaultClientIndex := -1;\r\n FClientConnectKind := ctAutomatic;\r\n FSelectedClientIndex := -1;\r\n ReadMapiSettings;\r\nend;\r\n\r\ndestructor TJclSimpleMapi.Destroy;\r\nbegin\r\n UnloadClientLib;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJclSimpleMapi.BeforeUnloadClientLib;\r\nbegin\r\n if Assigned(FBeforeUnloadClient) then\r\n FBeforeUnloadClient(Self);\r\nend;\r\n\r\nprocedure TJclSimpleMapi.CheckListIndex(I, ArrayLength: Integer);\r\nbegin\r\n if (I < 0) or (I >= ArrayLength) then\r\n raise EJclMapiError.CreateResFmt(@RsMapiInvalidIndex, [I]);\r\nend;\r\n\r\nfunction TJclSimpleMapi.ClientLibLoaded: Boolean;\r\nbegin\r\n Result := FClientLibHandle <> 0;\r\nend;\r\n\r\nfunction TJclSimpleMapi.GetClientCount: Integer;\r\nbegin\r\n Result := Length(FClients);\r\nend;\r\n\r\nfunction TJclSimpleMapi.GetClientLibName: string;\r\nbegin\r\n if UseMapi then\r\n Result := MapiDll\r\n else\r\n Result := FClients[FSelectedClientIndex].ClientPath;\r\nend;\r\n\r\nfunction TJclSimpleMapi.GetClients(Index: Integer): TJclMapiClient;\r\nbegin\r\n CheckListIndex(Index, ClientCount);\r\n Result := FClients[Index];\r\nend;\r\n\r\nfunction TJclSimpleMapi.GetCurrentClientName: string;\r\nbegin\r\n if UseMapi then\r\n Result := 'MAPI'\r\n else\r\n if ClientCount > 0 then\r\n Result := Clients[SelectedClientIndex].ClientName\r\n else\r\n Result := '';\r\nend;\r\n\r\nfunction TJclSimpleMapi.GetProfileCount: Integer;\r\nbegin\r\n Result := Length(FProfiles);\r\nend;\r\n\r\nfunction TJclSimpleMapi.GetProfiles(Index: Integer): AnsiString;\r\nbegin\r\n CheckListIndex(Index, ProfileCount);\r\n Result := FProfiles[Index];\r\nend;\r\n\r\nprocedure TJclSimpleMapi.LoadClientLib;\r\nvar\r\n I: Integer;\r\n P: Pointer;\r\nbegin\r\n if ClientLibLoaded then\r\n Exit;\r\n FClientLibHandle := SafeLoadLibrary(GetClientLibName);\r\n if FClientLibHandle = 0 then\r\n RaiseLastOSError;\r\n for I := 0 to Length(FFunctions) - 1 do\r\n begin\r\n P := GetProcAddress(FClientLibHandle, PChar(MapiExportNames[I]));\r\n if P = nil then\r\n begin\r\n UnloadClientLib;\r\n raise EJclMapiError.CreateResFmt(@RsMapiMissingExport, [MapiExportNames[I]]);\r\n end\r\n else\r\n FFunctions[I]^ := P;\r\n end;\r\nend;\r\n\r\nclass function TJclSimpleMapi.ProfilesRegKey: string;\r\nbegin\r\n if IsWinNT then\r\n Result := 'SOFTWARE\\Microsoft\\Windows NT\\CurrentVersion\\Windows Messaging Subsystem\\Profiles'\r\n else\r\n Result := 'SOFTWARE\\Microsoft\\Windows Messaging Subsystem\\Profiles';\r\nend;\r\n\r\nprocedure TJclSimpleMapi.ReadMapiSettings;\r\nconst\r\n MessageSubsytemKey = 'SOFTWARE\\Microsoft\\Windows Messaging Subsystem';\r\n MailClientsKey = 'SOFTWARE\\Clients\\Mail';\r\nvar\r\n DefaultValue, ClientKey: string;\r\n SL: TStringList;\r\n I: Integer;\r\n\r\n function CheckPeImageTarget(const ClientPath: string): Boolean;\r\n var\r\n Img: TJclPeImage;\r\n begin\r\n Img := TJclPeImage.Create(True);\r\n try\r\n Img.FileName := ClientPath;\r\n {$IFDEF CPU32}\r\n Result := Img.Target = taWin32;\r\n {$ENDIF CPU32}\r\n {$IFDEF CPU64}\r\n Result := Img.Target = taWin64;\r\n {$ENDIF CPU64}\r\n finally\r\n Img.Free;\r\n end;\r\n end;\r\n\r\n function CheckValid(var Client: TJclMapiClient): Boolean;\r\n var\r\n I: Integer;\r\n LibHandle: THandle;\r\n begin\r\n LibHandle := LoadLibraryEx(PChar(Client.ClientPath), 0, DONT_RESOLVE_DLL_REFERENCES);\r\n Result := (LibHandle <> 0);\r\n if Result then\r\n begin\r\n for I := Low(MapiExportNames) to High(MapiExportNames) do\r\n if GetProcAddress(LibHandle, PChar(MapiExportNames[I])) = nil then\r\n begin\r\n Result := False;\r\n Break;\r\n end;\r\n FreeLibrary(LibHandle);\r\n end;\r\n Client.Valid := Result;\r\n end;\r\n\r\nbegin\r\n FClients := nil;\r\n FDefaultClientIndex := -1;\r\n FProfiles := nil;\r\n FDefaultProfileName := '';\r\n SL := TStringList.Create;\r\n try\r\n if RegKeyExists(HKEY_LOCAL_MACHINE, MessageSubsytemKey) then\r\n begin\r\n FMapiInstalled := RegReadStringDef(HKEY_LOCAL_MACHINE, MessageSubsytemKey, 'MAPIX', '') = '1';\r\n FSimpleMapiInstalled := RegReadStringDef(HKEY_LOCAL_MACHINE, MessageSubsytemKey, 'MAPI', '') = '1';\r\n FMapiVersion := RegReadStringDef(HKEY_LOCAL_MACHINE, MessageSubsytemKey, 'MAPIXVER', '');\r\n end;\r\n FAnyClientInstalled := FMapiInstalled;\r\n if RegKeyExists(HKEY_CURRENT_USER, MailClientsKey) then\r\n DefaultValue := RegReadStringDef(HKEY_CURRENT_USER, MailClientsKey, '', '');\r\n if RegKeyExists(HKEY_LOCAL_MACHINE, MailClientsKey) then\r\n begin\r\n if DefaultValue = '' then\r\n DefaultValue := RegReadStringDef(HKEY_LOCAL_MACHINE, MailClientsKey, '', '');\r\n if RegGetKeyNames(HKEY_LOCAL_MACHINE, MailClientsKey, SL) then\r\n begin\r\n SetLength(FClients, SL.Count);\r\n for I := 0 to SL.Count - 1 do\r\n begin\r\n FClients[I].RegKeyName := SL[I];\r\n FClients[I].Valid := False;\r\n ClientKey := MailClientsKey + '\\' + SL[I];\r\n if RegKeyExists(HKEY_LOCAL_MACHINE, ClientKey) then\r\n begin\r\n FClients[I].ClientName := RegReadStringDef(HKEY_LOCAL_MACHINE, ClientKey, '', '');\r\n FClients[I].ClientPath := RegReadStringDef(HKEY_LOCAL_MACHINE, ClientKey, 'DLLPathEx', '');\r\n ExpandEnvironmentVar(FClients[I].ClientPath);\r\n if (FClients[I].ClientPath = '') or not CheckPeImageTarget(FClients[I].ClientPath) then\r\n begin\r\n FClients[I].ClientPath := RegReadStringDef(HKEY_LOCAL_MACHINE, ClientKey, 'DLLPath', '');\r\n ExpandEnvironmentVar(FClients[I].ClientPath);\r\n if not CheckPeImageTarget(FClients[I].ClientPath) then\r\n FClients[I].ClientPath := '';\r\n end;\r\n if CheckValid(FClients[I]) then\r\n FAnyClientInstalled := True;\r\n end;\r\n end;\r\n FDefaultClientIndex := SL.IndexOf(DefaultValue);\r\n FSelectedClientIndex := FDefaultClientIndex;\r\n end;\r\n end;\r\n if RegKeyExists(HKEY_CURRENT_USER, ProfilesRegKey) then\r\n begin\r\n FDefaultProfileName := RegReadAnsiStringDef(HKEY_CURRENT_USER, ProfilesRegKey, 'DefaultProfile', '');\r\n if RegGetKeyNames(HKEY_CURRENT_USER, ProfilesRegKey, SL) then\r\n begin\r\n SetLength(FProfiles, SL.Count);\r\n for I := 0 to SL.Count - 1 do\r\n FProfiles[I] := AnsiString(SL[I]);\r\n end;\r\n end;\r\n finally\r\n SL.Free;\r\n end;\r\nend;\r\n\r\nprocedure TJclSimpleMapi.SetClientConnectKind(const Value: TJclMapiClientConnect);\r\nbegin\r\n if FClientConnectKind <> Value then\r\n begin\r\n FClientConnectKind := Value;\r\n UnloadClientLib;\r\n end;\r\nend;\r\n\r\nprocedure TJclSimpleMapi.SetSelectedClientIndex(const Value: Integer);\r\nbegin\r\n CheckListIndex(Value, ClientCount);\r\n if FSelectedClientIndex <> Value then\r\n begin\r\n FSelectedClientIndex := Value;\r\n UnloadClientLib;\r\n end;\r\nend;\r\n\r\nprocedure TJclSimpleMapi.UnloadClientLib;\r\nvar\r\n I: Integer;\r\nbegin\r\n if ClientLibLoaded then\r\n begin\r\n BeforeUnloadClientLib;\r\n FreeLibrary(FClientLibHandle);\r\n FClientLibHandle := 0;\r\n for I := 0 to Length(FFunctions) - 1 do\r\n FFunctions[I]^ := nil;\r\n end;\r\nend;\r\n\r\nfunction TJclSimpleMapi.UseMapi: Boolean;\r\nbegin\r\n case FClientConnectKind of\r\n ctAutomatic:\r\n UseMapi := FSimpleMapiInstalled;\r\n ctMapi:\r\n UseMapi := True;\r\n ctDirect:\r\n UseMapi := False;\r\n else\r\n UseMapi := True;\r\n end;\r\nend;\r\n\r\n//=== { TJclEmailRecip } =====================================================\r\n\r\nfunction TJclEmailRecip.AddressAndName: AnsiString;\r\nvar\r\n N: AnsiString;\r\nbegin\r\n if Name = '' then\r\n N := Address\r\n else\r\n N := Name;\r\n Result := AnsiString(Format('\"%s\" <%s>', [N, Address]));\r\nend;\r\n\r\nclass function TJclEmailRecip.RecipKindToString(const AKind: TJclEmailRecipKind): AnsiString;\r\nbegin\r\n case AKind of\r\n rkOriginator:\r\n Result := AnsiString(LoadResString(@RsMapiMailORIG));\r\n rkTO:\r\n Result := AnsiString(LoadResString(@RsMapiMailTO));\r\n rkCC:\r\n Result := AnsiString(LoadResString(@RsMapiMailCC));\r\n rkBCC:\r\n Result := AnsiString(LoadResString(@RsMapiMailBCC));\r\n end;\r\nend;\r\n\r\nprocedure TJclEmailRecip.SetAddress(Value: AnsiString);\r\nvar\r\n N: Integer;\r\nbegin\r\n Value := Trim(Value);\r\n N := Pos(AddressTypeDelimiter, Value);\r\n if N = 0 then\r\n FAddress := Value\r\n else\r\n begin\r\n FAddress := Copy(Value, N + 1, Length(Value));\r\n FAddressType := Copy(Value, 1, N - 1);\r\n end;\r\nend;\r\n\r\nfunction TJclEmailRecip.SortingName: AnsiString;\r\nbegin\r\n if FName = '' then\r\n Result := FAddress\r\n else\r\n Result := FName;\r\nend;\r\n\r\n//=== { TJclEmailRecips } ====================================================\r\n\r\nfunction TJclEmailRecips.Add(const Address, Name: AnsiString;\r\n const Kind: TJclEmailRecipKind; const AddressType: AnsiString): Integer;\r\nvar\r\n Item: TJclEmailRecip;\r\nbegin\r\n Item := TJclEmailRecip.Create;\r\n try\r\n Item.Address := Address;\r\n if AddressType <> '' then\r\n Item.AddressType := AddressType;\r\n Item.Name := Name;\r\n Item.Kind := Kind;\r\n Result := inherited Add(Item);\r\n except\r\n Item.Free;\r\n raise;\r\n end;\r\nend;\r\n\r\nfunction TJclEmailRecips.GetItems(Index: Integer): TJclEmailRecip;\r\nbegin\r\n Result := TJclEmailRecip(Get(Index));\r\nend;\r\n\r\nfunction TJclEmailRecips.GetOriginator: TJclEmailRecip;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := nil;\r\n for I := 0 to Count - 1 do\r\n if Items[I].Kind = rkOriginator then\r\n begin\r\n Result := Items[I];\r\n Break;\r\n end;\r\nend;\r\n\r\nfunction EmailRecipsCompare(Item1, Item2: Pointer): Integer;\r\nvar\r\n R1, R2: TJclEmailRecip;\r\nbegin\r\n R1 := TJclEmailRecip(Item1);\r\n R2 := TJclEmailRecip(Item2);\r\n Result := Integer(R1.Kind) - Integer(R2.Kind);\r\n if Result = 0 then\r\n Result := AnsiCompareStr(R1.SortingName, R2.SortingName);\r\nend;\r\n\r\nprocedure TJclEmailRecips.SortRecips;\r\nbegin\r\n Sort(EmailRecipsCompare);\r\nend;\r\n\r\n//=== { TJclEmail } ==========================================================\r\n\r\nconstructor TJclEmail.Create;\r\nbegin\r\n inherited Create;\r\n FAttachments := TJclAnsiStringList.Create;\r\n FAttachmentFiles := TStringList.Create;\r\n FLogonOptions := [loLogonUI];\r\n FFindOptions := [foFifo];\r\n FRecipients := TJclEmailRecips.Create(True);\r\n FRecipients.AddressesType := MapiAddressTypeSMTP;\r\nend;\r\n\r\ndestructor TJclEmail.Destroy;\r\nbegin\r\n FreeAndNil(FAttachmentFiles);\r\n FreeAndNil(FAttachments);\r\n FreeAndNil(FRecipients);\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJclEmail.Address(const Caption: AnsiString; EditFields: Integer): Boolean;\r\nvar\r\n NewRecipCount: ULONG;\r\n NewRecips: PMapiRecipDesc;\r\n Recips: TMapiRecipDesc;\r\n Res: DWORD;\r\nbegin\r\n LoadClientLib;\r\n NewRecips := nil;\r\n NewRecipCount := 0;\r\n Res := MapiAddress(FSessionHandle, ParentWnd, PAnsiChar(Caption), EditFields, nil,\r\n 0, Recips, LogonOptionsToFlags(False), 0, @NewRecipCount, NewRecips);\r\n Result := (MapiCheck(Res, True) = SUCCESS_SUCCESS);\r\n if Result then\r\n try\r\n DecodeRecips(NewRecips, NewRecipCount);\r\n finally\r\n MapiFreeBuffer(NewRecips);\r\n end;\r\nend;\r\n\r\nprocedure TJclEmail.BeforeUnloadClientLib;\r\nbegin\r\n LogOff;\r\n inherited BeforeUnloadClientLib;\r\nend;\r\n\r\nprocedure TJclEmail.Clear;\r\nbegin\r\n Attachments.Clear;\r\n AttachmentFiles.Clear;\r\n Body := '';\r\n FSubject := '';\r\n Recipients.Clear;\r\n FReadMsg.MessageType := '';\r\n FReadMsg.DateReceived := 0;\r\n FReadMsg.ConversationID := '';\r\n FReadMsg.Flags := 0;\r\nend;\r\n\r\nprocedure TJclEmail.DecodeRecips(RecipDesc: PMapiRecipDesc; Count: Integer);\r\nvar\r\n S: AnsiString;\r\n N, I: Integer;\r\n Kind: TJclEmailRecipKind;\r\nbegin\r\n for I := 0 to Count - 1 do\r\n begin\r\n if RecipDesc = nil then\r\n Break;\r\n Kind := rkOriginator;\r\n with RecipDesc^ do\r\n begin\r\n case ulRecipClass of\r\n MAPI_ORIG:\r\n Kind := rkOriginator;\r\n MAPI_TO:\r\n Kind := rkTO;\r\n MAPI_CC:\r\n Kind := rkCC;\r\n MAPI_BCC:\r\n Kind := rkBCC;\r\n $FFFFFFFF: // Eudora client version 5.2.0.9 bug\r\n Kind := rkOriginator;\r\n else\r\n MapiCheck(MAPI_E_INVALID_MESSAGE, True);\r\n end;\r\n S := AnsiString(lpszAddress);\r\n N := Pos(AddressTypeDelimiter, S);\r\n if N = 0 then\r\n Recipients.Add(S, lpszName, Kind)\r\n else\r\n Recipients.Add(Copy(S, N + 1, Length(S)), AnsiString(lpszName), Kind, Copy(S, 1, N - 1));\r\n end;\r\n Inc(RecipDesc);\r\n end;\r\nend;\r\n\r\nfunction TJclEmail.Delete(const MessageID: AnsiString): Boolean;\r\nbegin\r\n LoadClientLib;\r\n Result := MapiCheck(MapiDeleteMail(FSessionHandle, 0, PAnsiChar(MessageID), 0, 0),\r\n False) = SUCCESS_SUCCESS;\r\nend;\r\n\r\nfunction TJclEmail.FindFirstMessage: Boolean;\r\nbegin\r\n SeedMessageID := '';\r\n Result := FindNextMessage;\r\nend;\r\n\r\nfunction TJclEmail.FindNextMessage: Boolean;\r\nvar\r\n MsgID: array [0..512] of AnsiChar;\r\n Flags, Res: ULONG;\r\nbegin\r\n Result := False;\r\n if not UserLogged then\r\n Exit;\r\n Flags := MAPI_LONG_MSGID;\r\n if foFifo in FFindOptions then\r\n Inc(Flags, MAPI_GUARANTEE_FIFO);\r\n if foUnreadOnly in FFindOptions then\r\n Inc(Flags, MAPI_UNREAD_ONLY);\r\n Res := MapiFindNext(FSessionHandle, 0, nil, PAnsiChar(FSeedMessageID), Flags, 0, MsgId);\r\n Result := (Res = SUCCESS_SUCCESS);\r\n if Result then\r\n SeedMessageID := MsgID\r\n else\r\n begin\r\n SeedMessageID := '';\r\n if Res <> MAPI_E_NO_MESSAGES then\r\n MapiCheck(Res, True);\r\n end;\r\nend;\r\n\r\nfunction TJclEmail.GetAttachments: TJclAnsiStrings;\r\nbegin\r\n Result := FAttachments;\r\nend;\r\n\r\nfunction TJclEmail.GetAttachmentFiles: TStrings;\r\nbegin\r\n Result := FAttachmentFiles;\r\nend;\r\n\r\nfunction TJclEmail.GetParentWnd: THandle;\r\nbegin\r\n if FParentWndValid then\r\n Result := FParentWnd\r\n else\r\n Result := GetMainAppWndFromPid(GetCurrentProcessId);\r\nend;\r\n\r\nfunction TJclEmail.GetUserLogged: Boolean;\r\nbegin\r\n Result := (FSessionHandle <> 0);\r\nend;\r\n\r\nfunction TJclEmail.InternalSendOrSave(Save, ShowDialog: Boolean): Boolean;\r\nconst\r\n RecipClasses: array [TJclEmailRecipKind] of DWORD =\r\n (MAPI_ORIG, MAPI_TO, MAPI_CC, MAPI_BCC);\r\ntype\r\n TSetDllDirectory = function(lpPathName: PChar): LONGBOOL; stdcall;\r\n TGetDllDirectory = function(nBufferLength: DWord; lpPathName: PChar): LONGBOOL; stdcall;\r\nvar\r\n AttachArray: packed array of TMapiFileDesc;\r\n RecipArray: packed array of TMapiRecipDesc;\r\n RealAddresses: array of AnsiString;\r\n RealNames: array of AnsiString;\r\n MapiMessage: TMapiMessage;\r\n Flags, Res: DWORD;\r\n I: Integer;\r\n MsgID: array [0..512] of AnsiChar;\r\n AttachmentFileNames: array of AnsiString;\r\n AttachmentPathNames: array of AnsiString;\r\n HtmlBodyFileName: TFileName;\r\n SetDllDirectory: TSetDllDirectory;\r\n GetDllDirectory: TGetDllDirectory;\r\n DllDirectoryBuffer: array[0..1024] of Char;\r\nbegin\r\n if not AnyClientInstalled then\r\n raise EJclMapiError.CreateRes(@RsMapiMailNoClient);\r\n\r\n @GetDllDirectory := GetProcAddress(GetModuleHandle(kernel32), 'GetDllDirectory' + AWSuffix);\r\n @SetDllDirectory := GetProcAddress(GetModuleHandle(kernel32), 'SetDllDirectory' + AWSuffix);\r\n\r\n if Assigned(@GetDllDirectory) and Assigned(@SetDllDirectory) then\r\n begin\r\n GetDllDirectory(Length(DllDirectoryBuffer), @DllDirectoryBuffer);\r\n SetDllDirectory(nil);\r\n end;\r\n try\r\n HtmlBodyFileName := '';\r\n try\r\n if FHtmlBody then\r\n begin\r\n HtmlBodyFileName := FindUnusedFileName(PathAddSeparator(GetWindowsTempFolder) + 'JclMapi', 'htm', 'Temp');\r\n Attachments.Insert(0, AnsiString(HtmlBodyFileName));\r\n AttachmentFiles.Insert(0, '');\r\n StringToFile(HtmlBodyFileName, Body);\r\n end;\r\n // Create attachments\r\n if Attachments.Count > 0 then\r\n begin\r\n SetLength(AttachArray, Attachments.Count);\r\n SetLength(AttachmentFileNames, Attachments.Count);\r\n SetLength(AttachmentPathNames, Attachments.Count);\r\n for I := 0 to Attachments.Count - 1 do\r\n begin\r\n ResetMemory(AttachArray[I], SizeOf(TMapiFileDesc));\r\n AttachArray[I].nPosition := DWORD(-1);\r\n if (AttachmentFiles.Count > I) and (AttachmentFiles[I] <> '') then\r\n begin\r\n AttachmentFileNames[I] := Attachments[I];\r\n AttachmentPathNames[I] := AnsiString({$IFDEF HAS_UNITSCOPE}System.{$ENDIF}SysUtils.ExpandFileName(AttachmentFiles[I]));\r\n end\r\n else\r\n begin\r\n AttachmentFileNames[I] := ExtractFileName(AnsiString(Attachments[I]));\r\n AttachmentPathNames[I] := AnsiString({$IFDEF HAS_UNITSCOPE}System.{$ENDIF}SysUtils.ExpandFileName(string(Attachments[I])));\r\n end;\r\n AttachArray[I].lpszFileName := PAnsiChar(AttachmentFileNames[I]);\r\n AttachArray[I].lpszPathName := PAnsiChar(AttachmentPathNames[I]);\r\n if not FileExists(string(AttachmentPathNames[I])) then\r\n MapiCheck(MAPI_E_ATTACHMENT_NOT_FOUND, False);\r\n end;\r\n end\r\n else\r\n AttachArray := nil;\r\n // Create recipients\r\n if Recipients.Count > 0 then\r\n begin\r\n SetLength(RecipArray, Recipients.Count);\r\n SetLength(RealAddresses, Recipients.Count);\r\n SetLength(RealNames, Recipients.Count);\r\n for I := 0 to Recipients.Count - 1 do\r\n begin\r\n ResetMemory(RecipArray[I], SizeOf(TMapiRecipDesc));\r\n with RecipArray[I], Recipients[I] do\r\n begin\r\n ulRecipClass := RecipClasses[Kind];\r\n if FName = '' then // some clients requires Name item always filled\r\n begin\r\n if FAddress = '' then\r\n MapiCheck(MAPI_E_INVALID_RECIPS, False);\r\n RealNames[I] := FAddress;\r\n end\r\n else\r\n RealNames[I] := FName;\r\n if FAddressType <> '' then\r\n RealAddresses[I] := FAddressType + AddressTypeDelimiter + FAddress\r\n else\r\n if Recipients.AddressesType <> '' then\r\n RealAddresses[I] := Recipients.AddressesType + AddressTypeDelimiter + FAddress\r\n else\r\n RealAddresses[I] := FAddress;\r\n lpszName := PAnsiChar(AnsiString(RealNames[I]));\r\n lpszAddress := PAnsiCharOrNil(AnsiString(RealAddresses[I]));\r\n end;\r\n end;\r\n end\r\n else\r\n begin\r\n if ShowDialog then\r\n RecipArray := nil\r\n else\r\n MapiCheck(MAPI_E_INVALID_RECIPS, False);\r\n end;\r\n // Load MAPI client library\r\n LoadClientLib;\r\n // Fill MapiMessage structure\r\n ResetMemory(MapiMessage, SizeOf(MapiMessage));\r\n MapiMessage.lpszSubject := PAnsiChar(FSubject);\r\n if FHtmlBody then\r\n MapiMessage.lpszNoteText := #0\r\n else\r\n MapiMessage.lpszNoteText := PAnsiChar(FBody);\r\n MapiMessage.nRecipCount := Length(RecipArray);\r\n if MapiMessage.nRecipCount > 0 then\r\n MapiMessage.lpRecips := PMapiRecipDesc(@RecipArray[0]);\r\n MapiMessage.nFileCount := Length(AttachArray);\r\n if MapiMessage.nFileCount > 0 then\r\n MapiMessage.lpFiles := PMapiFileDesc(@AttachArray[0]);\r\n Flags := LogonOptionsToFlags(ShowDialog);\r\n if Save then\r\n begin\r\n StrPLCopy(MsgID, SeedMessageID, Length(MsgID) - 1);\r\n Res := MapiSaveMail(FSessionHandle, ParentWND, MapiMessage, Flags, MAPI_LONG_MSGID, @MsgID[0]);\r\n if Res = SUCCESS_SUCCESS then\r\n SeedMessageID := MsgID;\r\n end\r\n else\r\n Res := MapiSendMail(FSessionHandle, ParentWND, MapiMessage, Flags, 0);\r\n Result := (MapiCheck(Res, True) = SUCCESS_SUCCESS);\r\n finally\r\n SetLength(AttachArray, 0);\r\n SetLength(RecipArray, 0);\r\n SetLength(RealAddresses, 0);\r\n SetLength(RealNames, 0);\r\n SetLength(AttachmentFileNames, 0);\r\n SetLength(AttachmentPathNames, 0);\r\n if HtmlBodyFileName <> '' then\r\n begin\r\n DeleteFile(HtmlBodyFileName);\r\n Attachments.Delete(0);\r\n AttachmentFiles.Delete(0);\r\n end;\r\n end;\r\n finally\r\n if Assigned(@SetDllDirectory) then\r\n SetDllDirectory(DllDirectoryBuffer);\r\n end;\r\nend;\r\n\r\nprocedure TJclEmail.LogOff;\r\nbegin\r\n if UserLogged then\r\n begin\r\n MapiCheck(MapiLogOff(FSessionHandle, ParentWND, 0, 0), True);\r\n FSessionHandle := 0;\r\n end;\r\nend;\r\n\r\nprocedure TJclEmail.LogOn(const ProfileName, Password: AnsiString);\r\nbegin\r\n if not UserLogged then\r\n begin\r\n LoadClientLib;\r\n MapiCheck(MapiLogOn(ParentWND, PAnsiChar(ProfileName), PAnsiChar(Password),\r\n LogonOptionsToFlags(False), 0, @FSessionHandle), True);\r\n end;\r\nend;\r\n\r\nfunction TJclEmail.LogonOptionsToFlags(ShowDialog: Boolean): DWORD;\r\nbegin\r\n Result := 0;\r\n if FSessionHandle = 0 then\r\n begin\r\n if loLogonUI in FLogonOptions then\r\n Inc(Result, MAPI_LOGON_UI);\r\n if loNewSession in FLogonOptions then\r\n Inc(Result, MAPI_NEW_SESSION);\r\n if loForceDownload in FLogonOptions then\r\n Inc(Result, MAPI_FORCE_DOWNLOAD);\r\n end;\r\n if ShowDialog then\r\n Inc(Result, MAPI_DIALOG);\r\nend;\r\n\r\nfunction TJclEmail.MessageReport(Strings: TStrings; MaxWidth: Integer; IncludeAddresses: Boolean): Integer;\r\nconst\r\n NameDelimiter = ', ';\r\nvar\r\n LabelsWidth: Integer;\r\n NamesList: array [TJclEmailRecipKind] of AnsiString;\r\n ReportKind: TJclEmailRecipKind;\r\n I, Cnt: Integer;\r\n MailSubject, BreakStr, S: AnsiString;\r\nbegin\r\n Cnt := Strings.Count;\r\n MailSubject := AnsiString(LoadResString(@RsMapiMailSubject));\r\n LabelsWidth := Length(MailSubject);\r\n for ReportKind := Low(ReportKind) to High(ReportKind) do\r\n begin\r\n NamesList[ReportKind] := '';\r\n LabelsWidth := Max(LabelsWidth, Length(TJclEmailRecip.RecipKindToString(ReportKind)));\r\n end;\r\n BreakStr := NativeCrLf + StringOfChar(AnsiChar(' '), LabelsWidth + 2);\r\n for I := 0 to Recipients.Count - 1 do\r\n with Recipients[I] do\r\n begin\r\n if IncludeAddresses then\r\n S := AddressAndName\r\n else\r\n S := Name;\r\n NamesList[Kind] := NamesList[Kind] + S + NameDelimiter;\r\n end;\r\n\r\n Strings.BeginUpdate;\r\n try\r\n for ReportKind := Low(ReportKind) to High(ReportKind) do\r\n if NamesList[ReportKind] <> '' then\r\n begin\r\n S := StrPadRight(TJclEmailRecip.RecipKindToString(ReportKind), LabelsWidth, AnsiSpace) + ': ' +\r\n Copy(NamesList[ReportKind], 1, Length(NamesList[ReportKind]) - Length(NameDelimiter));\r\n Strings.Add(WrapText(string(S), string(BreakStr), [AnsiTab, AnsiSpace], MaxWidth)); // OF AnsiString to TStrings\r\n end;\r\n S := MailSubject + ': ' + Subject;\r\n Strings.Add(WrapText(string(S), string(BreakStr), [AnsiTab, AnsiSpace], MaxWidth)); // OF AnsiString to TStrings\r\n Result := Strings.Count - Cnt;\r\n Strings.Add('');\r\n Strings.Add(WrapText(string(Body), NativeCrLf, [AnsiTab, AnsiSpace, '-'], MaxWidth)); // OF AnsiString to TStrings\r\n finally\r\n Strings.EndUpdate;\r\n end;\r\nend;\r\n\r\nfunction TJclEmail.Read(const Options: TJclEmailReadOptions): Boolean;\r\nvar\r\n Flags: ULONG;\r\n Msg: PMapiMessage;\r\n I: Integer;\r\n Files: PMapiFileDesc;\r\n\r\n function CopyAndStrToInt(const S: AnsiString; Index, Count: Integer): Integer;\r\n begin\r\n Result := StrToIntDef(string(Copy(S, Index, Count)), 0);\r\n end;\r\n\r\n function MessageDateToDate(const S: AnsiString): TDateTime;\r\n var\r\n T: TSystemTime;\r\n begin\r\n ResetMemory(T, SizeOf(T));\r\n with T do\r\n begin\r\n wYear := CopyAndStrToInt(S, 1, 4);\r\n wMonth := CopyAndStrToInt(S, 6, 2);\r\n wDay := CopyAndStrToInt(S, 9, 2);\r\n wHour := CopyAndStrToInt(S, 12, 2);\r\n wMinute := CopyAndStrToInt(S, 15,2);\r\n Result := EncodeDate(wYear, wMonth, wDay) + EncodeTime(wHour, wMinute, wSecond, wMilliseconds);\r\n end;\r\n end;\r\n\r\nbegin\r\n Result := False;\r\n if not UserLogged then\r\n Exit;\r\n Clear;\r\n Flags := 0;\r\n if roHeaderOnly in Options then\r\n Inc(Flags, MAPI_ENVELOPE_ONLY);\r\n if not (roMarkAsRead in Options) then\r\n Inc(Flags, MAPI_PEEK);\r\n if not (roAttachments in Options) then\r\n Inc(Flags, MAPI_SUPPRESS_ATTACH);\r\n MapiCheck(MapiReadMail(SessionHandle, 0, PAnsiChar(FSeedMessageID), Flags, 0, Msg), True);\r\n if Msg <> nil then\r\n try\r\n DecodeRecips(Msg^.lpOriginator, 1);\r\n DecodeRecips(Msg^.lpRecips, Msg^.nRecipCount);\r\n FSubject := Msg^.lpszSubject;\r\n Body := AnsiString(AdjustLineBreaks(string(AnsiString(Msg^.lpszNoteText)))); // OF AnsiString to TStrings\r\n Files := Msg^.lpFiles;\r\n if Files <> nil then\r\n for I := 0 to Msg^.nFileCount - 1 do\r\n begin\r\n if Files^.lpszPathName <> nil then\r\n Attachments.Add(AnsiString(Files^.lpszPathName))\r\n else\r\n Attachments.Add(AnsiString(Files^.lpszFileName));\r\n Inc(Files);\r\n end;\r\n FReadMsg.MessageType := Msg^.lpszMessageType;\r\n if Msg^.lpszDateReceived <> nil then\r\n FReadMsg.DateReceived := MessageDateToDate(Msg^.lpszDateReceived);\r\n FReadMsg.ConversationID := Msg^.lpszConversationID;\r\n FReadMsg.Flags := Msg^.flFlags;\r\n Result := True;\r\n finally\r\n MapiFreeBuffer(Msg);\r\n end;\r\nend;\r\n\r\nfunction TJclEmail.ResolveName(var Name, Address: AnsiString; ShowDialog: Boolean): Boolean;\r\nvar\r\n Recip: PMapiRecipDesc;\r\n Res, Flags: DWORD;\r\nbegin\r\n LoadClientLib;\r\n Flags := LogonOptionsToFlags(ShowDialog) or MAPI_AB_NOMODIFY;\r\n Recip := nil;\r\n Res := MapiResolveName(FSessionHandle, ParentWnd, PAnsiChar(Name), Flags, 0, Recip);\r\n Result := (MapiCheck(Res, True) = SUCCESS_SUCCESS) and (Recip <> nil);\r\n if Result then\r\n begin\r\n Address := Recip^.lpszAddress;\r\n Name := Recip^.lpszName;\r\n MapiFreeBuffer(Recip);\r\n end;\r\nend;\r\n\r\nprocedure TJclEmail.RestoreTaskWindows;\r\nbegin\r\n RestoreTaskWindowsList(FTaskWindowList);\r\n FTaskWindowList := nil;\r\nend;\r\n\r\nfunction TJclEmail.Save: Boolean;\r\nbegin\r\n Result := InternalSendOrSave(True, False);\r\nend;\r\n\r\nprocedure TJclEmail.SaveTaskWindows;\r\nbegin\r\n FTaskWindowList := SaveTaskWindowsList;\r\nend;\r\n\r\nfunction TJclEmail.Send(ShowDialog: Boolean): Boolean;\r\nbegin\r\n Result := InternalSendOrSave(False, ShowDialog);\r\nend;\r\n\r\nprocedure TJclEmail.SetBody(const Value: AnsiString);\r\nbegin\r\n if Value = '' then\r\n FBody := ''\r\n else\r\n FBody := StrEnsureSuffix(NativeCrLf, Value);\r\nend;\r\n\r\nprocedure TJclEmail.SetParentWnd(const Value: THandle);\r\nbegin\r\n FParentWnd := Value;\r\n FParentWndValid := True;\r\nend;\r\n\r\nprocedure TJclEmail.SortAttachments;\r\nvar\r\n S, T: TJclAnsiStringList;\r\n U: TStringList;\r\n I, Nr: Integer;\r\nbegin\r\n // This is confusing, quick and very dirty.\r\n S := TJclAnsiStringList.Create;\r\n try\r\n S.Capacity := FAttachments.Count;\r\n for I := 0 to Pred(FAttachments.Count) do\r\n S.AddObject(FAttachments[I], Pointer(I));\r\n S.Sort;\r\n T := TJclAnsiStringList.Create;\r\n U := TStringList.Create;\r\n try\r\n T.Capacity := S.Count;\r\n U.Capacity := S.Count;\r\n for I := 0 to Pred(S.Count) do\r\n begin\r\n Nr := Integer(S.Objects[I]);\r\n T.AddObject(FAttachments[Nr], FAttachments.Objects[Nr]);\r\n U.AddObject(FAttachmentFiles[Nr], FAttachmentFiles.Objects[Nr]);\r\n end;\r\n FAttachments.Assign(T);\r\n FAttachmentFiles.Assign(U);\r\n finally\r\n U.Free;\r\n T.Free;\r\n end;\r\n finally\r\n S.Free;\r\n end;\r\nend;\r\n\r\n//=== Simple email send function =============================================\r\n\r\nfunction SimpleSendHelper(const ARecipient, AName, ASubject, ABody: AnsiString; const AAttachment: TFileName;\r\n AShowDialog: Boolean; AParentWND: THandle; const AProfileName, APassword, AAddressType: AnsiString): Boolean;\r\nvar\r\n AJclEmail: TJclEmail;\r\nbegin\r\n AJclEmail := TJclEmail.Create;\r\n try\r\n if AParentWND <> 0 then\r\n AJclEmail.ParentWnd := AParentWND;\r\n if ARecipient <> '' then\r\n AJclEmail.Recipients.Add(ARecipient, AName, rkTO, AAddressType);\r\n AJclEmail.Subject := ASubject;\r\n AJclEmail.Body := ABody;\r\n if AAttachment <> '' then\r\n AJclEmail.Attachments.Add(AnsiString(AAttachment));\r\n if AProfileName <> '' then\r\n AJclEmail.LogOn(AProfileName, APassword);\r\n Result := AJclEmail.Send(AShowDialog);\r\n finally\r\n AJclEmail.Free;\r\n end;\r\nend;\r\n\r\nfunction JclSimpleSendMail(const Recipient, Name, Subject, Body: AnsiString;\r\n const Attachment: TFileName; ShowDialog: Boolean; ParentWND: THandle;\r\n const ProfileName: AnsiString; const Password: AnsiString): Boolean;\r\nbegin\r\n Result := SimpleSendHelper(Recipient, Name, Subject, Body, Attachment, ShowDialog, ParentWND,\r\n ProfileName, Password, MapiAddressTypeSMTP);\r\nend;\r\n\r\nfunction JclSimpleSendFax(const Recipient, Name, Subject, Body: AnsiString;\r\n const Attachment: TFileName; ShowDialog: Boolean; ParentWND: THandle;\r\n const ProfileName: AnsiString; const Password: AnsiString): Boolean;\r\nbegin\r\n Result := SimpleSendHelper(Recipient, Name, Subject, Body, Attachment, ShowDialog, ParentWND,\r\n ProfileName, Password, MapiAddressTypeFAX);\r\nend;\r\n\r\nfunction JclSimpleBringUpSendMailDialog(const Subject, Body: AnsiString;\r\n const Attachment: TFileName; ParentWND: THandle;\r\n const ProfileName: AnsiString; const Password: AnsiString): Boolean;\r\nbegin\r\n Result := SimpleSendHelper('', '', Subject, Body, Attachment, True, ParentWND,\r\n ProfileName, Password, MapiAddressTypeSMTP);\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jcl/source/windows/JclMetadata.pas", "content": "{**************************************************************************************************}\r\n{ }\r\n{ Project JEDI Code Library (JCL) }\r\n{ }\r\n{ The contents of this file are subject to the Mozilla Public License Version 1.1 (the \"License\"); }\r\n{ you may not use this file except in compliance with the License. You may obtain a copy of the }\r\n{ License at http://www.mozilla.org/MPL/ }\r\n{ }\r\n{ Software distributed under the License is distributed on an \"AS IS\" basis, WITHOUT WARRANTY OF }\r\n{ ANY KIND, either express or implied. See the License for the specific language governing rights }\r\n{ and limitations under the License. }\r\n{ }\r\n{ The Original Code is JclMetadata.pas. }\r\n{ }\r\n{ The Initial Developer of the Original Code is Flier Lu (). }\r\n{ Portions created by Flier Lu are Copyright (C) Flier Lu. All Rights Reserved. }\r\n{ }\r\n{ Contributors: }\r\n{ Flier Lu (flier) }\r\n{ Robert Marquardt (marquardt) }\r\n{ Olivier Sannier (obones) }\r\n{ }\r\n{**************************************************************************************************}\r\n{ }\r\n{ Microsoft .Net framework Clr information support routines and classes. }\r\n{ }\r\n{**************************************************************************************************}\r\n{ }\r\n{ Last modified: $Date:: 2011-09-03 00:07:50 +0200 (sam. 03 sept. 2011) $ }\r\n{ Revision: $Rev:: 3599 $ }\r\n{ Author: $Author:: outchy $ }\r\n{ }\r\n{**************************************************************************************************}\r\n\r\nunit JclMetadata;\r\n\r\n{$I jcl.inc}\r\n{$I windowsonly.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n {$IFDEF HAS_UNITSCOPE}\r\n {$IFDEF MSWINDOWS}\r\n Winapi.Windows,\r\n {$ENDIF MSWINDOWS}\r\n System.Classes, System.SysUtils, System.Contnrs,\r\n {$ELSE ~HAS_UNITSCOPE}\r\n {$IFDEF MSWINDOWS}\r\n Windows,\r\n {$ENDIF MSWINDOWS}\r\n Classes, SysUtils, Contnrs,\r\n {$ENDIF ~HAS_UNITSCOPE}\r\n JclBase, JclClr, JclFileUtils, JclSysUtils;\r\n\r\ntype\r\n TJclClrElementType = (etEnd, etVoid, etBoolean, etChar,\r\n etI1, etU1, etI2, etU2, etI4, etU4, etI8, etU8, etR4, etR8, etString,\r\n etPtr, etByRef, etValueType, etClass, etArray, etTypedByRef,\r\n etI, etU, etFnPtr, etObject, etSzArray, etCModReqd, etCModOpt,\r\n etInternal, etMax, etModifier, etSentinel, etPinned);\r\n\r\n TJclClrTableModuleRow = class(TJclClrTableRow)\r\n private\r\n FGeneration: Word;\r\n FNameOffset: DWORD;\r\n FMvidIdx: DWORD;\r\n FEncIdIdx: DWORD;\r\n FEncBaseIdIdx: DWORD;\r\n function GetMvid: TGUID;\r\n function GetName: WideString;\r\n function GetEncBaseId: TGUID;\r\n function GetEncId: TGUID;\r\n public\r\n constructor Create(const ATable: TJclClrTable); override;\r\n\r\n function DumpIL: string; override;\r\n\r\n function HasEncId: Boolean;\r\n function HasEncBaseId: Boolean;\r\n\r\n property Generation: Word read FGeneration;\r\n property NameOffset: DWORD read FNameOffset;\r\n property MvidIdx: DWORD read FMvidIdx;\r\n property EncIdIdx: DWORD read FEncIdIdx;\r\n property EncBaseIdIdx: DWORD read FEncBaseIdIdx;\r\n\r\n property Name: WideString read GetName;\r\n property Mvid: TGUID read GetMvid;\r\n property EncId: TGUID read GetEncId;\r\n property EncBaseId: TGUID read GetEncBaseId;\r\n end;\r\n\r\n TJclClrTableModule = class(TJclClrTable, ITableCanDumpIL)\r\n private\r\n function GetRow(const Idx: Integer): TJclClrTableModuleRow;\r\n protected\r\n class function TableRowClass: TJclClrTableRowClass; override;\r\n public\r\n property Rows[const Idx: Integer]: TJclClrTableModuleRow read GetRow; default;\r\n end;\r\n\r\n TJclClrTableModuleRefRow = class(TJclClrTableRow)\r\n private\r\n FNameOffset: DWORD;\r\n function GetName: WideString;\r\n public\r\n constructor Create(const ATable: TJclClrTable); override;\r\n function DumpIL: string; override;\r\n property NameOffset: DWORD read FNameOffset;\r\n property Name: WideString read GetName;\r\n end;\r\n\r\n TJclClrTableModuleRef = class(TJclClrTable, ITableCanDumpIL)\r\n private\r\n function GetRow(const Idx: Integer): TJclClrTableModuleRefRow;\r\n protected\r\n class function TableRowClass: TJclClrTableRowClass; override;\r\n public\r\n property Rows[const Idx: Integer]: TJclClrTableModuleRefRow read GetRow; default;\r\n end;\r\n\r\n TJclClrAssemblyFlag =\r\n (cafPublicKey, cafCompatibilityMask, cafSideBySideCompatible,\r\n cafNonSideBySideAppDomain, cafNonSideBySideProcess,\r\n cafNonSideBySideMachine, cafEnableJITcompileTracking,\r\n cafDisableJITcompileOptimizer);\r\n TJclClrAssemblyFlags = set of TJclClrAssemblyFlag;\r\n\r\n TJclClrTableAssemblyRow = class(TJclClrTableRow)\r\n private\r\n FCultureOffset: DWORD;\r\n FPublicKeyOffset: DWORD;\r\n FHashAlgId: DWORD;\r\n FNameOffset: DWORD;\r\n FMajorVersion: Word;\r\n FBuildNumber: Word;\r\n FRevisionNumber: Word;\r\n FMinorVersion: Word;\r\n FFlagMask: DWORD;\r\n function GetCulture: WideString;\r\n function GetName: WideString;\r\n function GetPublicKey: TJclClrBlobRecord;\r\n function GetVersion: string;\r\n function GetFlags: TJclClrAssemblyFlags;\r\n public\r\n constructor Create(const ATable: TJclClrTable); override;\r\n\r\n function DumpIL: string; override;\r\n\r\n class function AssemblyFlags(const Flags: TJclClrAssemblyFlags): DWORD; overload;\r\n class function AssemblyFlags(const Flags: DWORD): TJclClrAssemblyFlags; overload;\r\n\r\n property HashAlgId: DWORD read FHashAlgId;\r\n property MajorVersion: Word read FMajorVersion;\r\n property MinorVersion: Word read FMinorVersion;\r\n property BuildNumber: Word read FBuildNumber;\r\n property RevisionNumber: Word read FRevisionNumber;\r\n property FlagMask: DWORD read FFlagMask;\r\n property PublicKeyOffset: DWORD read FPublicKeyOffset;\r\n property NameOffset: DWORD read FNameOffset;\r\n property CultureOffset: DWORD read FCultureOffset;\r\n\r\n property PublicKey: TJclClrBlobRecord read GetPublicKey;\r\n property Name: WideString read GetName;\r\n property Culture: WideString read GetCulture;\r\n property Version: string read GetVersion;\r\n property Flags: TJclClrAssemblyFlags read GetFlags;\r\n end;\r\n\r\n TJclClrTableAssembly = class(TJclClrTable, ITableCanDumpIL)\r\n private\r\n function GetRow(const Idx: Integer): TJclClrTableAssemblyRow;\r\n protected\r\n class function TableRowClass: TJclClrTableRowClass; override;\r\n public\r\n property Rows[const Idx: Integer]: TJclClrTableAssemblyRow read GetRow; default;\r\n end;\r\n\r\n TJclClrTableAssemblyOSRow = class(TJclClrTableRow)\r\n private\r\n FPlatformID: DWORD;\r\n FMajorVersion: DWORD;\r\n FMinorVersion: DWORD;\r\n function GetVersion: string;\r\n public\r\n constructor Create(const ATable: TJclClrTable); override;\r\n\r\n property PlatformID: DWORD read FPlatformID;\r\n property MajorVersion: DWORD read FMajorVersion;\r\n property MinorVersion: DWORD read FMinorVersion;\r\n property Version: string read GetVersion;\r\n end;\r\n\r\n TJclClrTableAssemblyOS = class(TJclClrTable)\r\n private\r\n function GetRow(const Idx: Integer): TJclClrTableAssemblyOSRow;\r\n protected\r\n class function TableRowClass: TJclClrTableRowClass; override;\r\n public\r\n property Rows[const Idx: Integer]: TJclClrTableAssemblyOSRow read GetRow; default;\r\n end;\r\n\r\n TJclClrTableAssemblyProcessorRow = class(TJclClrTableRow)\r\n private\r\n FProcessor: DWORD;\r\n public\r\n constructor Create(const ATable: TJclClrTable); override;\r\n property Processor: DWORD read FProcessor;\r\n end;\r\n\r\n TJclClrTableAssemblyProcessor = class(TJclClrTable)\r\n private\r\n function GetRow(const Idx: Integer): TJclClrTableAssemblyProcessorRow;\r\n protected\r\n class function TableRowClass: TJclClrTableRowClass; override;\r\n public\r\n property Rows[const Idx: Integer]: TJclClrTableAssemblyProcessorRow read GetRow; default;\r\n end;\r\n\r\n TJclClrTableAssemblyRefRow = class(TJclClrTableRow)\r\n private\r\n FCultureOffset: DWORD;\r\n FNameOffset: DWORD;\r\n FPublicKeyOrTokenOffset: DWORD;\r\n FHashValueOffset: DWORD;\r\n FMajorVersion: Word;\r\n FRevisionNumber: Word;\r\n FBuildNumber: Word;\r\n FMinorVersion: Word;\r\n FFlagMask: DWORD;\r\n function GetCulture: WideString;\r\n function GetHashValue: TJclClrBlobRecord;\r\n function GetName: WideString;\r\n function GetPublicKeyOrToken: TJclClrBlobRecord;\r\n function GetVersion: string;\r\n function GetFlags: TJclClrAssemblyFlags;\r\n public\r\n constructor Create(const ATable: TJclClrTable); override;\r\n\r\n function DumpIL: string; override;\r\n\r\n property MajorVersion: Word read FMajorVersion;\r\n property MinorVersion: Word read FMinorVersion;\r\n property BuildNumber: Word read FBuildNumber;\r\n property RevisionNumber: Word read FRevisionNumber;\r\n property FlagMask: DWORD read FFlagMask;\r\n property PublicKeyOrTokenOffset: DWORD read FPublicKeyOrTokenOffset;\r\n property NameOffset: DWORD read FNameOffset;\r\n property CultureOffset: DWORD read FCultureOffset;\r\n property HashValueOffset: DWORD read FHashValueOffset;\r\n\r\n property PublicKeyOrToken: TJclClrBlobRecord read GetPublicKeyOrToken;\r\n property Name: WideString read GetName;\r\n property Culture: WideString read GetCulture;\r\n property Version: string read GetVersion;\r\n property HashValue: TJclClrBlobRecord read GetHashValue;\r\n property Flags: TJclClrAssemblyFlags read GetFlags;\r\n end;\r\n\r\n TJclClrTableAssemblyRef = class(TJclClrTable, ITableCanDumpIL)\r\n private\r\n function GetRow(const Idx: Integer): TJclClrTableAssemblyRefRow;\r\n protected\r\n class function TableRowClass: TJclClrTableRowClass; override;\r\n public\r\n property Rows[const Idx: Integer]: TJclClrTableAssemblyRefRow read GetRow; default;\r\n end;\r\n\r\n TJclClrTableAssemblyRefOSRow = class(TJclClrTableAssemblyOSRow)\r\n private\r\n FAssemblyRefIdx: DWORD;\r\n function GetAssemblyRef: TJclClrTableAssemblyRefRow;\r\n public\r\n constructor Create(const ATable: TJclClrTable); override;\r\n\r\n property AssemblyRefIdx: DWORD read FAssemblyRefIdx;\r\n property AssemblyRef: TJclClrTableAssemblyRefRow read GetAssemblyRef;\r\n end;\r\n\r\n TJclClrTableAssemblyRefOS = class(TJclClrTableAssemblyOS)\r\n private\r\n function GetRow(const Idx: Integer): TJclClrTableAssemblyRefOSRow;\r\n protected\r\n class function TableRowClass: TJclClrTableRowClass; override;\r\n public\r\n property Rows[const Idx: Integer]: TJclClrTableAssemblyRefOSRow read GetRow; default;\r\n end;\r\n\r\n TJclClrTableAssemblyRefProcessorRow = class(TJclClrTableAssemblyProcessorRow)\r\n private\r\n FAssemblyRefIdx: DWORD;\r\n function GetAssemblyRef: TJclClrTableAssemblyRefRow;\r\n public\r\n constructor Create(const ATable: TJclClrTable); override;\r\n\r\n property AssemblyRefIdx: DWORD read FAssemblyRefIdx;\r\n property AssemblyRef: TJclClrTableAssemblyRefRow read GetAssemblyRef;\r\n end;\r\n\r\n TJclClrTableAssemblyRefProcessor = class(TJclClrTableAssemblyProcessor)\r\n private\r\n function GetRow(const Idx: Integer): TJclClrTableAssemblyRefProcessorRow;\r\n protected\r\n class function TableRowClass: TJclClrTableRowClass; override;\r\n public\r\n property Rows[const Idx: Integer]: TJclClrTableAssemblyRefProcessorRow read GetRow; default;\r\n end;\r\n\r\n TJclClrTableClassLayoutRow = class(TJclClrTableRow)\r\n private\r\n FClassSize: DWORD;\r\n FParentIdx: DWORD;\r\n FPackingSize: Word;\r\n public\r\n constructor Create(const ATable: TJclClrTable); override;\r\n\r\n property PackingSize: Word read FPackingSize;\r\n property ClassSize: DWORD read FClassSize;\r\n property ParentIdx: DWORD read FParentIdx;\r\n end;\r\n\r\n TJclClrTableClassLayout = class(TJclClrTable)\r\n private\r\n function GetRow(const Idx: Integer): TJclClrTableClassLayoutRow;\r\n protected\r\n class function TableRowClass: TJclClrTableRowClass; override;\r\n public\r\n property Rows[const Idx: Integer]: TJclClrTableClassLayoutRow read GetRow; default;\r\n end;\r\n\r\n TJclClrTableConstantRow = class(TJclClrTableRow)\r\n private\r\n FKind: Byte;\r\n FParentIdx: DWORD;\r\n FValueOffset: DWORD;\r\n function GetElementType: TJclClrElementType;\r\n function GetParent: TJclClrTableRow;\r\n function GetValue: TJclClrBlobRecord;\r\n public\r\n constructor Create(const ATable: TJclClrTable); override;\r\n\r\n function DumpIL: string; override;\r\n\r\n property Kind: Byte read FKind;\r\n property ParentIdx: DWORD read FParentIdx;\r\n property ValueOffset: DWORD read FValueOffset;\r\n\r\n property ElementType: TJclClrElementType read GetElementType;\r\n property Parent: TJclClrTableRow read GetParent;\r\n property Value: TJclClrBlobRecord read GetValue;\r\n end;\r\n\r\n TJclClrTableConstant = class(TJclClrTable)\r\n private\r\n function GetRow(const Idx: Integer): TJclClrTableConstantRow;\r\n protected\r\n class function TableRowClass: TJclClrTableRowClass; override;\r\n public\r\n property Rows[const Idx: Integer]: TJclClrTableConstantRow read GetRow; default;\r\n end;\r\n\r\n TJclClrTableCustomAttributeRow = class(TJclClrTableRow)\r\n private\r\n FParentIdx: DWORD;\r\n FTypeIdx: DWORD;\r\n FValueOffset: DWORD;\r\n function GetValue: TJclClrBlobRecord;\r\n function GetParent: TJclClrTableRow;\r\n function GetMethod: TJclClrTableRow;\r\n public\r\n constructor Create(const ATable: TJclClrTable); override;\r\n\r\n function DumpIL: string; override;\r\n\r\n property ParentIdx: DWORD read FParentIdx;\r\n property TypeIdx: DWORD read FTypeIdx;\r\n property ValueOffset: DWORD read FValueOffset;\r\n\r\n property Parent: TJclClrTableRow read GetParent;\r\n property Method: TJclClrTableRow read GetMethod;\r\n property Value: TJclClrBlobRecord read GetValue;\r\n end;\r\n\r\n TJclClrTableCustomAttribute = class(TJclClrTable)\r\n private\r\n function GetRow(const Idx: Integer): TJclClrTableCustomAttributeRow;\r\n protected\r\n class function TableRowClass: TJclClrTableRowClass; override;\r\n public\r\n property Rows[const Idx: Integer]: TJclClrTableCustomAttributeRow read GetRow; default;\r\n end;\r\n\r\n TJclClrTableDeclSecurityRow = class(TJclClrTableRow)\r\n private\r\n FPermissionSetOffset: DWORD;\r\n FParentIdx: DWORD;\r\n FAction: Word;\r\n public\r\n constructor Create(const ATable: TJclClrTable); override;\r\n\r\n property Action: Word read FAction;\r\n property ParentIdx: DWORD read FParentIdx;\r\n property PermissionSetOffset: DWORD read FPermissionSetOffset;\r\n end;\r\n\r\n TJclClrTableDeclSecurity = class(TJclClrTable)\r\n private\r\n function GetRow(const Idx: Integer): TJclClrTableDeclSecurityRow;\r\n protected\r\n class function TableRowClass: TJclClrTableRowClass; override;\r\n public\r\n property Rows[const Idx: Integer]: TJclClrTableDeclSecurityRow read GetRow; default;\r\n end;\r\n\r\n TJclClrTableEventMapRow = class(TJclClrTableRow)\r\n private\r\n FEventListIdx: DWORD;\r\n FParentIdx: DWORD;\r\n public\r\n constructor Create(const ATable: TJclClrTable); override;\r\n\r\n property ParentIdx: DWORD read FParentIdx;\r\n property EventListIdx: DWORD read FEventListIdx;\r\n end;\r\n\r\n TJclClrTableEventMap = class(TJclClrTable)\r\n private\r\n function GetRow(const Idx: Integer): TJclClrTableEventMapRow;\r\n protected\r\n class function TableRowClass: TJclClrTableRowClass; override;\r\n public\r\n property Rows[const Idx: Integer]: TJclClrTableEventMapRow read GetRow; default;\r\n end;\r\n\r\n TJclClrTableEventFlag = (efSpecialName, efRTSpecialName);\r\n TJclClrTableEventFlags = set of TJclClrTableEventFlag;\r\n\r\n TJclClrTableEventDefRow = class(TJclClrTableRow)\r\n private\r\n FNameOffset: DWORD;\r\n FEventTypeIdx: DWORD;\r\n FEventFlags: Word;\r\n function GetName: WideString;\r\n public\r\n constructor Create(const ATable: TJclClrTable); override;\r\n\r\n property EventFlags: Word read FEventFlags;\r\n property NameOffset: DWORD read FNameOffset;\r\n property EventTypeIdx: DWORD read FEventTypeIdx;\r\n property Name: WideString read GetName;\r\n end;\r\n\r\n TJclClrTableEventDef = class(TJclClrTable)\r\n private\r\n function GetRow(const Idx: Integer): TJclClrTableEventDefRow;\r\n protected\r\n class function TableRowClass: TJclClrTableRowClass; override;\r\n public\r\n property Rows[const Idx: Integer]: TJclClrTableEventDefRow read GetRow; default;\r\n end;\r\n\r\n TJclClrTableExportedTypeRow = class(TJclClrTableRow)\r\n private\r\n FTypeDefIdx: DWORD;\r\n FFlags: DWORD;\r\n FImplementationIdx: DWORD;\r\n FTypeNamespaceOffset: DWORD;\r\n FTypeNameOffset: DWORD;\r\n function GetTypeName: WideString;\r\n function GetTypeNamespace: WideString;\r\n public\r\n constructor Create(const ATable: TJclClrTable); override;\r\n\r\n property Flags: DWORD read FFlags;\r\n property TypeDefIdx: DWORD read FTypeDefIdx;\r\n property TypeNameOffset: DWORD read FTypeNameOffset;\r\n property TypeNamespaceOffset: DWORD read FTypeNamespaceOffset;\r\n property ImplementationIdx: DWORD read FImplementationIdx;\r\n property TypeName: WideString read GetTypeName;\r\n property TypeNamespace: WideString read GetTypeNamespace;\r\n end;\r\n\r\n TJclClrTableEventPtrRow = class(TJclClrTableRow)\r\n private\r\n FEventIdx: DWORD;\r\n function GetEvent: TJclClrTableEventDefRow;\r\n public\r\n constructor Create(const ATable: TJclClrTable); override;\r\n\r\n property EventIdx: DWORD read FEventIdx;\r\n property Event: TJclClrTableEventDefRow read GetEvent;\r\n end;\r\n\r\n TJclClrTableEventPtr = class(TJclClrTable)\r\n private\r\n function GetRow(const Idx: Integer): TJclClrTableEventPtrRow;\r\n protected\r\n class function TableRowClass: TJclClrTableRowClass; override;\r\n public\r\n property Rows[const Idx: Integer]: TJclClrTableEventPtrRow read GetRow; default;\r\n end;\r\n\r\n TJclClrTableExportedType = class(TJclClrTable)\r\n private\r\n function GetRow(const Idx: Integer): TJclClrTableExportedTypeRow;\r\n protected\r\n class function TableRowClass: TJclClrTableRowClass; override;\r\n public\r\n property Rows[const Idx: Integer]: TJclClrTableExportedTypeRow read GetRow; default;\r\n end;\r\n\r\n TJclClrTableTypeDefRow = class;\r\n\r\n TJclClrTableFieldDefVisibility =\r\n (fvPrivateScope, fvPrivate, fvFamANDAssem,\r\n fvAssembly, fvFamily, fvFamORAssem, fvPublic);\r\n\r\n TJclClrTableFieldDefFlag =\r\n (ffStatic, ffInitOnly, ffLiteral, ffNotSerialized,\r\n ffSpecialName, ffPinvokeImpl, ffRTSpecialName,\r\n ffHasFieldMarshal, ffHasDefault, ffHasFieldRVA);\r\n TJclClrTableFieldDefFlags = set of TJclClrTableFieldDefFlag;\r\n\r\n TJclClrTableFieldDefRow = class(TJclClrTableRow)\r\n private\r\n FFlags: Word;\r\n FNameOffset: DWORD;\r\n FSignatureOffset: DWORD;\r\n FParentToken: TJclClrTableTypeDefRow;\r\n function GetName: WideString;\r\n function GetSignature: TJclClrBlobRecord;\r\n function GetFlag: TJclClrTableFieldDefFlags;\r\n function GetVisibility: TJclClrTableFieldDefVisibility;\r\n protected\r\n procedure SetParentToken(const ARow: TJclClrTableTypeDefRow);\r\n public\r\n constructor Create(const ATable: TJclClrTable); override;\r\n\r\n function DumpIL: string; override;\r\n\r\n property RawFlags: Word read FFlags;\r\n property NameOffset: DWORD read FNameOffset;\r\n property SignatureOffset: DWORD read FSignatureOffset;\r\n\r\n property Name: WideString read GetName;\r\n property Signature: TJclClrBlobRecord read GetSignature;\r\n\r\n property ParentToken: TJclClrTableTypeDefRow read FParentToken;\r\n property Visibility: TJclClrTableFieldDefVisibility read GetVisibility;\r\n property Flags: TJclClrTableFieldDefFlags read GetFlag;\r\n end;\r\n\r\n TJclClrTableFieldDef = class(TJclClrTable)\r\n private\r\n function GetRow(const Idx: Integer): TJclClrTableFieldDefRow;\r\n protected\r\n class function TableRowClass: TJclClrTableRowClass; override;\r\n public\r\n property Rows[const Idx: Integer]: TJclClrTableFieldDefRow read GetRow; default;\r\n end;\r\n\r\n TJclClrTableFieldPtrRow = class(TJclClrTableRow)\r\n private\r\n FFieldIdx: DWORD;\r\n function GetField: TJclClrTableFieldDefRow;\r\n public\r\n constructor Create(const ATable: TJclClrTable); override;\r\n\r\n property FieldIdx: DWORD read FFieldIdx;\r\n property Field: TJclClrTableFieldDefRow read GetField;\r\n end;\r\n\r\n TJclClrTableFieldPtr = class(TJclClrTable)\r\n private\r\n function GetRow(const Idx: Integer): TJclClrTableFieldPtrRow;\r\n protected\r\n class function TableRowClass: TJclClrTableRowClass; override;\r\n public\r\n property Rows[const Idx: Integer]: TJclClrTableFieldPtrRow read GetRow; default;\r\n end;\r\n\r\n TJclClrTableFieldLayoutRow = class(TJclClrTableRow)\r\n private\r\n FOffset: DWORD;\r\n FFieldIdx: DWORD;\r\n public\r\n constructor Create(const ATable: TJclClrTable); override;\r\n\r\n property Offset: DWORD read FOffset;\r\n property FieldIdx: DWORD read FFieldIdx;\r\n end;\r\n\r\n TJclClrTableFieldLayout = class(TJclClrTable)\r\n private\r\n function GetRow(const Idx: Integer): TJclClrTableFieldLayoutRow;\r\n protected\r\n class function TableRowClass: TJclClrTableRowClass; override;\r\n public\r\n property Rows[const Idx: Integer]: TJclClrTableFieldLayoutRow read GetRow; default;\r\n end;\r\n\r\n TJclClrTableFieldMarshalRow = class(TJclClrTableRow)\r\n private\r\n FParentIdx: DWORD;\r\n FNativeTypeOffset: DWORD;\r\n public\r\n constructor Create(const ATable: TJclClrTable); override;\r\n\r\n property ParentIdx: DWORD read FParentIdx;\r\n property NativeTypeOffset: DWORD read FNativeTypeOffset;\r\n end;\r\n\r\n TJclClrTableFieldMarshal = class(TJclClrTable)\r\n private\r\n function GetRow(const Idx: Integer): TJclClrTableFieldMarshalRow;\r\n protected\r\n class function TableRowClass: TJclClrTableRowClass; override;\r\n public\r\n property Rows[const Idx: Integer]: TJclClrTableFieldMarshalRow read GetRow; default;\r\n end;\r\n\r\n TJclClrTableFieldRVARow = class(TJclClrTableRow)\r\n private\r\n FRVA: DWORD;\r\n FFieldIdx: DWORD;\r\n public\r\n constructor Create(const ATable: TJclClrTable); override;\r\n\r\n property RVA: DWORD read FRVA;\r\n property FieldIdx: DWORD read FFieldIdx;\r\n end;\r\n\r\n TJclClrTableFieldRVA = class(TJclClrTable)\r\n private\r\n function GetRow(const Idx: Integer): TJclClrTableFieldRVARow;\r\n protected\r\n class function TableRowClass: TJclClrTableRowClass; override;\r\n public\r\n property Rows[const Idx: Integer]: TJclClrTableFieldRVARow read GetRow; default;\r\n end;\r\n\r\n TJclClrTableFileRow = class(TJclClrTableRow)\r\n private\r\n FHashValueOffset: DWORD;\r\n FNameOffset: DWORD;\r\n FFlags: DWORD;\r\n function GetName: WideString;\r\n function GetHashValue: TJclClrBlobRecord;\r\n function GetContainsMetadata: Boolean;\r\n public\r\n constructor Create(const ATable: TJclClrTable); override;\r\n\r\n function DumpIL: string; override;\r\n\r\n property Flags: DWORD read FFlags;\r\n property NameOffset: DWORD read FNameOffset;\r\n property HashValueOffset: DWORD read FHashValueOffset;\r\n\r\n property Name: WideString read GetName;\r\n property HashValue: TJclClrBlobRecord read GetHashValue;\r\n property ContainsMetadata: Boolean read GetContainsMetadata;\r\n end;\r\n\r\n TJclClrTableFile = class(TJclClrTable, ITableCanDumpIL)\r\n private\r\n function GetRow(const Idx: Integer): TJclClrTableFileRow;\r\n protected\r\n class function TableRowClass: TJclClrTableRowClass; override;\r\n public\r\n property Rows[const Idx: Integer]: TJclClrTableFileRow read GetRow; default;\r\n end;\r\n\r\n TJclClrTableImplMapRow = class(TJclClrTableRow)\r\n private\r\n FImportNameOffset: DWORD;\r\n FMemberForwardedIdx: DWORD;\r\n FImportScopeIdx: DWORD;\r\n FMappingFlags: Word;\r\n function GetImportName: WideString;\r\n public\r\n constructor Create(const ATable: TJclClrTable); override;\r\n\r\n property MappingFlags: Word read FMappingFlags;\r\n property MemberForwardedIdx: DWORD read FMemberForwardedIdx;\r\n property ImportNameOffset: DWORD read FImportNameOffset;\r\n property ImportScopeIdx: DWORD read FImportScopeIdx;\r\n property ImportName: WideString read GetImportName;\r\n end;\r\n\r\n TJclClrTableImplMap = class(TJclClrTable)\r\n private\r\n function GetRow(const Idx: Integer): TJclClrTableImplMapRow;\r\n protected\r\n class function TableRowClass: TJclClrTableRowClass; override;\r\n public\r\n property Rows[const Idx: Integer]: TJclClrTableImplMapRow read GetRow; default;\r\n end;\r\n\r\n TJclClrTableInterfaceImplRow = class(TJclClrTableRow)\r\n private\r\n FInterfaceIdx: DWORD;\r\n FClassIdx: DWORD;\r\n function GetImplClass: TJclClrTableRow;\r\n function GetImplInterface: TJclClrTableRow;\r\n public\r\n constructor Create(const ATable: TJclClrTable); override;\r\n\r\n function DumpIL: string; override;\r\n\r\n property ClassIdx: DWORD read FClassIdx;\r\n property InterfaceIdx: DWORD read FInterfaceIdx;\r\n\r\n property ImplClass: TJclClrTableRow read GetImplClass;\r\n property ImplInterface: TJclClrTableRow read GetImplInterface;\r\n end;\r\n\r\n TJclClrTableInterfaceImpl = class(TJclClrTable)\r\n private\r\n function GetRow(const Idx: Integer): TJclClrTableInterfaceImplRow;\r\n protected\r\n class function TableRowClass: TJclClrTableRowClass; override;\r\n public\r\n property Rows[const Idx: Integer]: TJclClrTableInterfaceImplRow read GetRow; default;\r\n end;\r\n\r\n TJclClrTableManifestResourceVisibility = (rvPublic, rvPrivate);\r\n\r\n TJclClrTableManifestResourceRow = class(TJclClrTableRow)\r\n private\r\n FOffset: DWORD;\r\n FFlags: DWORD;\r\n FImplementationIdx: DWORD;\r\n FNameOffset: DWORD;\r\n function GetName: WideString;\r\n function GetVisibility: TJclClrTableManifestResourceVisibility;\r\n function GetImplementationRow: TJclClrTableRow;\r\n public\r\n constructor Create(const ATable: TJclClrTable); override;\r\n\r\n function DumpIL: string; override;\r\n\r\n property Offset: DWORD read FOffset;\r\n property Flags: DWORD read FFlags;\r\n property NameOffset: DWORD read FNameOffset;\r\n property ImplementationIdx: DWORD read FImplementationIdx;\r\n\r\n property Name: WideString read GetName;\r\n property Visibility: TJclClrTableManifestResourceVisibility read GetVisibility;\r\n property ImplementationRow: TJclClrTableRow read GetImplementationRow;\r\n end;\r\n\r\n TJclClrTableManifestResource = class(TJclClrTable, ITableCanDumpIL)\r\n private\r\n function GetRow(const Idx: Integer): TJclClrTableManifestResourceRow;\r\n protected\r\n class function TableRowClass: TJclClrTableRowClass; override;\r\n public\r\n property Rows[const Idx: Integer]: TJclClrTableManifestResourceRow read GetRow; default;\r\n end;\r\n\r\n TJclClrTableMemberRefRow = class(TJclClrTableRow)\r\n private\r\n FClassIdx: DWORD;\r\n FNameOffset: DWORD;\r\n FSignatureOffset: DWORD;\r\n function GetName: WideString;\r\n function GetSignature: TJclClrBlobRecord;\r\n function GetParentClass: TJclClrTableRow;\r\n function GetFullName: WideString;\r\n public\r\n constructor Create(const ATable: TJclClrTable); override;\r\n\r\n property ClassIdx: DWORD read FClassIdx;\r\n property NameOffset: DWORD read FNameOffset;\r\n property SignatureOffset: DWORD read FSignatureOffset;\r\n\r\n property Name: WideString read GetName;\r\n property FullName: WideString read GetFullName;\r\n property Signature: TJclClrBlobRecord read GetSignature;\r\n property ParentClass: TJclClrTableRow read GetParentClass;\r\n end;\r\n\r\n TJclClrTableMemberRef = class(TJclClrTable)\r\n private\r\n function GetRow(const Idx: Integer): TJclClrTableMemberRefRow;\r\n protected\r\n class function TableRowClass: TJclClrTableRowClass; override;\r\n public\r\n property Rows[const Idx: Integer]: TJclClrTableMemberRefRow read GetRow; default;\r\n end;\r\n\r\n TJclClrTableMethodDefRow = class;\r\n\r\n TJclClrParamKind = (pkIn, pkOut, pkOptional, pkHasDefault, pkHasFieldMarshal);\r\n TJclClrParamKinds = set of TJclClrParamKind;\r\n\r\n TJclClrTableParamDefRow = class(TJclClrTableRow)\r\n private\r\n FFlagMask: Word;\r\n FSequence: Word;\r\n FNameOffset: DWORD;\r\n FMethod: TJclClrTableMethodDefRow;\r\n FFlags: TJclClrParamKinds;\r\n function GetName: WideString;\r\n protected\r\n procedure SetMethod(const AMethod: TJclClrTableMethodDefRow);\r\n public\r\n constructor Create(const ATable: TJclClrTable); override;\r\n\r\n function DumpIL: string; override;\r\n\r\n class function ParamFlags(const AFlags: TJclClrParamKinds): Word; overload;\r\n class function ParamFlags(const AFlags: Word): TJclClrParamKinds; overload;\r\n\r\n property FlagMask: Word read FFlagMask;\r\n property Sequence: Word read FSequence;\r\n property NameOffset: DWORD read FNameOffset;\r\n\r\n property Name: WideString read GetName;\r\n property Method: TJclClrTableMethodDefRow read FMethod;\r\n property Flags: TJclClrParamKinds read FFlags;\r\n end;\r\n\r\n TJclClrTableParamDef = class(TJclClrTable)\r\n private\r\n function GetRow(const Idx: Integer): TJclClrTableParamDefRow;\r\n protected\r\n class function TableRowClass: TJclClrTableRowClass; override;\r\n public\r\n property Rows[const Idx: Integer]: TJclClrTableParamDefRow read GetRow; default;\r\n end;\r\n\r\n TJclClrTableParamPtrRow = class(TJclClrTableRow)\r\n private\r\n FParamIdx: DWORD;\r\n function GetParam: TJclClrTableParamDefRow;\r\n public\r\n constructor Create(const ATable: TJclClrTable); override;\r\n\r\n property ParamIdx: DWORD read FParamIdx;\r\n property Param: TJclClrTableParamDefRow read GetParam;\r\n end;\r\n\r\n TJclClrTableParamPtr = class(TJclClrTable)\r\n private\r\n function GetRow(const Idx: Integer): TJclClrTableParamPtrRow;\r\n protected\r\n class function TableRowClass: TJclClrTableRowClass; override;\r\n public\r\n property Rows[const Idx: Integer]: TJclClrTableParamPtrRow read GetRow; default;\r\n end;\r\n\r\n IMAGE_COR_ILMETHOD_TINY = packed record\r\n Flags_CodeSize: Byte;\r\n end;\r\n TImageCorILMethodTiny = IMAGE_COR_ILMETHOD_TINY;\r\n PImageCorILMethodTiny = ^TImageCorILMethodTiny;\r\n\r\n IMAGE_COR_ILMETHOD_FAT = packed record\r\n Flags_Size,\r\n MaxStack: Word;\r\n CodeSize: DWORD;\r\n LocalVarSigTok: TJclClrToken;\r\n end;\r\n TImageCorILMethodFat = IMAGE_COR_ILMETHOD_FAT;\r\n PImageCorILMethodFat = ^TImageCorILMethodFat;\r\n\r\n PImageCorILMethodHeader = ^TImageCorILMethodHeader;\r\n TImageCorILMethodHeader = packed record\r\n case Boolean of\r\n True:\r\n (Tiny: TImageCorILMethodTiny);\r\n False:\r\n (Fat: TImageCorILMethodFat);\r\n end;\r\n\r\n IMAGE_COR_ILMETHOD_SECT_SMALL = packed record\r\n Kind: Byte;\r\n Datasize: Byte;\r\n Padding: Word;\r\n end;\r\n TImageCorILMethodSectSmall = IMAGE_COR_ILMETHOD_SECT_SMALL;\r\n PImageCorILMethodSectSmall = ^TImageCorILMethodSectSmall;\r\n\r\n IMAGE_COR_ILMETHOD_SECT_FAT = packed record\r\n Kind_DataSize: DWORD;\r\n end;\r\n TImageCorILMethodSectFat = IMAGE_COR_ILMETHOD_SECT_FAT;\r\n PImageCorILMethodSectFat = ^TImageCorILMethodSectFat;\r\n\r\n PImageCorILMethodSectHeader = ^TImageCorILMethodSectHeader;\r\n TImageCorILMethodSectHeader = packed record\r\n case Boolean of\r\n True:\r\n (Small: TImageCorILMethodSectSmall);\r\n False:\r\n (Fat: TImageCorILMethodSectFat);\r\n end;\r\n\r\n IMAGE_COR_ILMETHOD_SECT_EH_CLAUSE_FAT = packed record\r\n Flags: DWORD;\r\n TryOffset: DWORD;\r\n TryLength: DWORD; // relative to start of try block\r\n HandlerOffset: DWORD;\r\n HandlerLength: DWORD; // relative to start of handler\r\n case Boolean of\r\n True:\r\n (ClassToken: DWORD); // use for type-based exception handlers\r\n False:\r\n (FilterOffset: DWORD); // use for filter-based exception handlers (COR_ILEXCEPTION_FILTER is set)\r\n end;\r\n TImageCorILMethodSectEHClauseFat = IMAGE_COR_ILMETHOD_SECT_EH_CLAUSE_FAT;\r\n PImageCorILMethodSectEHClauseFat = ^TImageCorILMethodSectEHClauseFat;\r\n\r\n IMAGE_COR_ILMETHOD_SECT_EH_FAT = packed record\r\n SectFat: IMAGE_COR_ILMETHOD_SECT_FAT;\r\n Clauses: array [0..MaxWord-1] of IMAGE_COR_ILMETHOD_SECT_EH_CLAUSE_FAT; // actually variable size\r\n end;\r\n TImageCorILMethodSectEHFat = IMAGE_COR_ILMETHOD_SECT_EH_FAT;\r\n PImageCorILMethodSectEHFat = ^TImageCorILMethodSectEHFat;\r\n\r\n IMAGE_COR_ILMETHOD_SECT_EH_CLAUSE_SMALL = packed record\r\n Flags,\r\n TryOffset: Word;\r\n TryLength: Byte; // relative to start of try block\r\n HandlerOffset: Word;\r\n HandlerLength: Byte; // relative to start of handler\r\n case Boolean of\r\n True:\r\n (ClassToken: DWORD); // use for type-based exception handlers\r\n False:\r\n (FilterOffset: DWORD); // use for filter-based exception handlers (COR_ILEXCEPTION_FILTER is set)\r\n end;\r\n TImageCorILMethodSectEHClauseSmall = IMAGE_COR_ILMETHOD_SECT_EH_CLAUSE_SMALL;\r\n PImageCorILMethodSectEHClauseSmall = ^TImageCorILMethodSectEHClauseSmall;\r\n\r\n IMAGE_COR_ILMETHOD_SECT_EH_SMALL = packed record\r\n SectSmall: IMAGE_COR_ILMETHOD_SECT_SMALL;\r\n Clauses: array [0..MaxWord-1] of IMAGE_COR_ILMETHOD_SECT_EH_CLAUSE_SMALL; // actually variable size\r\n end;\r\n TImageCorILMethodSectEHSmall = IMAGE_COR_ILMETHOD_SECT_EH_SMALL;\r\n PImageCorILMethodSectEHSmall = ^TImageCorILMethodSectEHSmall;\r\n\r\n IMAGE_COR_ILMETHOD_SECT_EH = packed record\r\n case Boolean of\r\n True:\r\n (Small: IMAGE_COR_ILMETHOD_SECT_EH_SMALL);\r\n False:\r\n (Fat: IMAGE_COR_ILMETHOD_SECT_EH_FAT);\r\n end;\r\n TImageCorILMethodSectEH = IMAGE_COR_ILMETHOD_SECT_EH;\r\n PImageCorILMethodSectEH = ^TImageCorILMethodSectEH;\r\n\r\n TJclClrCodeBlock = record\r\n Offset: DWORD;\r\n Length: DWORD;\r\n end;\r\n\r\n TJclClrExceptionClauseFlag = (cfException, cfFilter, cfFinally, cfFault);\r\n TJclClrExceptionClauseFlags = set of TJclClrExceptionClauseFlag;\r\n\r\n TJclClrExceptionHandler = class(TObject)\r\n private\r\n FFlags: DWORD;\r\n FFilterOffset: DWORD;\r\n FTryBlock: TJclClrCodeBlock;\r\n FHandlerBlock: TJclClrCodeBlock;\r\n FClassToken: TJclClrToken;\r\n function GetFlags: TJclClrExceptionClauseFlags;\r\n public\r\n constructor Create(const EHClause: TImageCorILMethodSectEHClauseSmall); overload;\r\n constructor Create(const EHClause: TImageCorILMethodSectEHClauseFat); overload;\r\n\r\n property EHFlags: DWORD read FFlags;\r\n property Flags: TJclClrExceptionClauseFlags read GetFlags;\r\n\r\n property TryBlock: TJclClrCodeBlock read FTryBlock;\r\n property HandlerBlock: TJclClrCodeBlock read FHandlerBlock;\r\n\r\n property ClassToken: TJclClrToken read FClassToken;\r\n property FilterOffset: DWORD read FFilterOffset;\r\n end;\r\n\r\n TJclClrSignature = class(TObject)\r\n private\r\n FBlob: TJclClrBlobRecord;\r\n protected\r\n function IsModifierType(const AElementType: TJclClrElementType): Boolean;\r\n function IsPrimitiveType(const AElementType: TJclClrElementType): Boolean;\r\n\r\n function Inc(var DataPtr: PJclByteArray; Step: TJclAddr = 1): PByte;\r\n\r\n function UncompressedDataSize(DataPtr: PJclByteArray): Integer;\r\n function UncompressData(DataPtr: PJclByteArray; out Value: DWord): Integer;\r\n function UncompressToken(DataPtr: PJclByteArray; out Token: TJclClrToken): Integer;\r\n function UncompressCallingConv(DataPtr: PJclByteArray): Byte;\r\n function UncompressSignedInt(DataPtr: PJclByteArray; out Value: Integer): Integer;\r\n function UncompressElementType(DataPtr: PJclByteArray): TJclClrElementType;\r\n function UncompressTypeSignature(DataPtr: PJclByteArray): string;\r\n public\r\n constructor Create(const ABlob: TJclClrBlobRecord);\r\n\r\n function UncompressFieldSignature: string;\r\n\r\n function ReadValue: DWORD;\r\n function ReadByte: Byte;\r\n function ReadInteger: Integer;\r\n function ReadToken: TJclClrToken;\r\n function ReadElementType: TJclClrElementType;\r\n\r\n property Blob: TJclClrBlobRecord read FBlob;\r\n end;\r\n\r\n TJclClrArrayData = (adSize, adLowBound);\r\n\r\n TJclClrArraySignBound = array [TJclClrArrayData] of Integer;\r\n TJclClrArraySignBounds = array of TJclClrArraySignBound;\r\n\r\n TJclClrArraySign = class(TJclClrSignature)\r\n private\r\n FBounds: TJclClrArraySignBounds;\r\n public\r\n constructor Create(const ABlob: TJclClrBlobRecord);\r\n end;\r\n\r\n TJclClrLocalVarFlag = (lvfPinned, lvfByRef);\r\n TJclClrLocalVarFlags = set of TJclClrLocalVarFlag;\r\n\r\n TJclClrLocalVar = class(TObject)\r\n private\r\n FElementType: TJclClrElementType;\r\n FFlags: TJclClrLocalVarFlags;\r\n FToken: TJclClrToken;\r\n function GetName: WideString;\r\n public\r\n property ElementType: TJclClrElementType read FElementType write FElementType;\r\n\r\n property Name: WideString read GetName;\r\n property Flags: TJclClrLocalVarFlags read FFlags write FFlags;\r\n property Token: TJclClrToken read FToken write FToken;\r\n end;\r\n\r\n TJclClrLocalVarSign = class(TJclClrSignature)\r\n private\r\n FLocalVars: TObjectList;\r\n function GetLocalVar(const Idx: Integer): TJclClrLocalVar;\r\n function GetLocalVarCount: Integer;\r\n public\r\n constructor Create(const ABlob: TJclClrBlobRecord);\r\n destructor Destroy; override;\r\n\r\n property LocalVars[const Idx: Integer]: TJclClrLocalVar read GetLocalVar;\r\n property LocalVarCount: Integer read GetLocalVarCount;\r\n end;\r\n\r\n TJclClrMethodBody = class(TObject)\r\n private\r\n FMethod: TJclClrTableMethodDefRow;\r\n FSize: DWORD;\r\n FCode: Pointer;\r\n FMaxStack: DWORD;\r\n FLocalVarSignToken: TJclClrToken;\r\n FLocalVarSign: TJclClrLocalVarSign;\r\n FEHTable: TObjectList;\r\n procedure AddEHTable(EHTable: PImageCorILMethodSectEH);\r\n procedure AddOptILTable(OptILTable: Pointer; Size: Integer);\r\n\r\n procedure ParseMoreSections(SectHeader: PImageCorILMethodSectHeader);\r\n\r\n function GetExceptionHandler(const Idx: Integer): TJclClrExceptionHandler;\r\n function GetExceptionHandlerCount: Integer;\r\n function GetLocalVarSign: TJclClrLocalVarSign;\r\n function GetLocalVarSignData: TJclClrBlobRecord;\r\n public\r\n constructor Create(const AMethod: TJclClrTableMethodDefRow);\r\n destructor Destroy; override;\r\n\r\n property Method: TJclClrTableMethodDefRow read FMethod;\r\n\r\n property Size: DWORD read FSize;\r\n property Code: Pointer read FCode;\r\n\r\n property MaxStack: DWORD read FMaxStack;\r\n property LocalVarSignToken: TJclClrToken read FLocalVarSignToken;\r\n property LocalVarSignData: TJclClrBlobRecord read GetLocalVarSignData;\r\n property LocalVarSign: TJclClrLocalVarSign read GetLocalVarSign;\r\n property ExceptionHandlers[const Idx: Integer]: TJclClrExceptionHandler read GetExceptionHandler;\r\n property ExceptionHandlerCount: Integer read GetExceptionHandlerCount;\r\n end;\r\n\r\n TJclClrCustomModifierSign = class(TJclClrSignature)\r\n private\r\n FRequired: Boolean;\r\n FToken: TJclClrToken;\r\n public\r\n constructor Create(const ABlob: TJclClrBlobRecord);\r\n property Required: Boolean read FRequired;\r\n property Token: TJclClrToken read FToken;\r\n end;\r\n\r\n TJclClrMethodSign = class;\r\n\r\n TJclClrMethodParam = class(TJclClrSignature)\r\n private\r\n FCustomMods: TObjectList;\r\n FByRef: Boolean;\r\n FElementType: TJclClrElementType;\r\n FToken: TJclClrToken;\r\n FMethodSign: TJclClrMethodSign;\r\n FArraySign: TJclClrArraySign;\r\n function GetCustomModifier(const Idx: Integer): TJclClrCustomModifierSign;\r\n function GetCustomModifierCount: Integer;\r\n public\r\n constructor Create(const ABlob: TJclClrBlobRecord);\r\n destructor Destroy; override;\r\n\r\n property CustomModifiers[const Idx: Integer]: TJclClrCustomModifierSign read GetCustomModifier;\r\n property CustomModifierCount: Integer read GetCustomModifierCount;\r\n\r\n property ElementType: TJclClrElementType read FElementType;\r\n property ByRef: Boolean read FByRef;\r\n property Token: TJclClrToken read FToken;\r\n property MethodSign: TJclClrMethodSign read FMethodSign;\r\n property ArraySign: TJclClrArraySign read FArraySign;\r\n end;\r\n\r\n TJclClrMethodRetType = class(TJclClrMethodParam)\r\n end;\r\n\r\n TJclClrMethodSignFlag = (mfHasThis, mfExplicitThis, mfDefault, mfVarArg);\r\n TJclClrMethodSignFlags = set of TJclClrMethodSignFlag;\r\n\r\n TJclClrMethodSign = class(TJclClrSignature)\r\n private\r\n FFlags: TJclClrMethodSignFlags;\r\n FParams: TObjectList;\r\n FRetType: TJclClrMethodRetType;\r\n function GetParam(const Idx: Integer): TJclClrMethodParam;\r\n function GetParamCount: Integer;\r\n public\r\n constructor Create(const ABlob: TJclClrBlobRecord);\r\n destructor Destroy; override;\r\n\r\n property Flags: TJclClrMethodSignFlags read FFlags;\r\n property Params[const Idx: Integer]: TJclClrMethodParam read GetParam;\r\n property ParamCount: Integer read GetParamCount;\r\n property RetType: TJclClrMethodRetType read FRetType;\r\n end;\r\n\r\n TJclClrMemberAccess =\r\n (maCompilercontrolled, maPrivate, maFamilyAndAssembly,\r\n maAssembly, maFamily, maFamilyOrAssembly, maPublic);\r\n\r\n TJclClrMethodFlag =\r\n (mfStatic, mfFinal, mfVirtual, mfHideBySig,\r\n mfCheckAccessOnOverride, mfAbstract, mfSpecialName,\r\n mfPInvokeImpl, mfUnmanagedExport,\r\n mfRTSpcialName, mfHasSecurity, mfRequireSecObject);\r\n TJclClrMethodFlags = set of TJclClrMethodFlag;\r\n\r\n TJclClrMethodCodeType = (ctIL, ctNative, ctOptIL, ctRuntime);\r\n\r\n TJclClrMethodImplFlag =\r\n (mifForwardRef, mifPreserveSig, mifInternalCall,\r\n mifSynchronized, mifNoInlining);\r\n TJclClrMethodImplFlags = set of TJclClrMethodImplFlag;\r\n\r\n TJclClrTableMethodDefRow = class(TJclClrTableRow)\r\n private\r\n FRVA: DWORD;\r\n FImplFlags: Word;\r\n FFlags: Word;\r\n FNameOffset: DWORD;\r\n FSignatureOffset: DWORD;\r\n FParamListIdx: DWORD;\r\n FParentToken: TJclClrTableTypeDefRow;\r\n FParams: TList;\r\n FMethodBody: TJclClrMethodBody;\r\n FSignature: TJclClrMethodSign;\r\n function GetName: WideString;\r\n function GetSignatureData: TJclClrBlobRecord;\r\n function GetParam(const Idx: Integer): TJclClrTableParamDefRow;\r\n function GetParamCount: Integer;\r\n function GetHasParam: Boolean;\r\n procedure UpdateParams;\r\n function GetFullName: WideString;\r\n function GetSignature: TJclClrMethodSign;\r\n function GetMemberAccess: TJclClrMemberAccess;\r\n function GetMethodFlags: TJclClrMethodFlags;\r\n function GetNewSlot: Boolean;\r\n function GetCodeType: TJclClrMethodCodeType;\r\n function GetManaged: Boolean;\r\n function GetMethodImplFlags: TJclClrMethodImplFlags;\r\n protected\r\n procedure Update; override;\r\n procedure SetParentToken(const ARow: TJclClrTableTypeDefRow);\r\n public\r\n constructor Create(const ATable: TJclClrTable); override;\r\n\r\n function DumpIL: string; override;\r\n\r\n destructor Destroy; override;\r\n\r\n property RVA: DWORD read FRVA;\r\n property ImplFlags: Word read FImplFlags;\r\n property Flags: Word read FFlags;\r\n property NameOffset: DWORD read FNameOffset;\r\n property SignatureOffset: DWORD read FSignatureOffset;\r\n property ParamListIdx: DWORD read FParamListIdx;\r\n\r\n property Name: WideString read GetName;\r\n property FullName: WideString read GetFullName;\r\n\r\n property MethodFlags: TJclClrMethodFlags read GetMethodFlags;\r\n property MethodImplFlags: TJclClrMethodImplFlags read GetMethodImplFlags;\r\n\r\n property MemberAccess: TJclClrMemberAccess read GetMemberAccess;\r\n property NewSlot: Boolean read GetNewSlot;\r\n property CodeType: TJclClrMethodCodeType read GetCodeType;\r\n property Managed: Boolean read GetManaged;\r\n\r\n property Signature: TJclClrMethodSign read GetSignature;\r\n property SignatureData: TJclClrBlobRecord read GetSignatureData;\r\n property ParentToken: TJclClrTableTypeDefRow read FParentToken;\r\n property HasParam: Boolean read GetHasParam;\r\n property Params[const Idx: Integer]: TJclClrTableParamDefRow read GetParam;\r\n property ParamCount: Integer read GetParamCount;\r\n\r\n property MethodBody: TJclClrMethodBody read FMethodBody;\r\n end;\r\n\r\n TJclClrTableMethodDef = class(TJclClrTable)\r\n private\r\n function GetRow(const Idx: Integer): TJclClrTableMethodDefRow;\r\n protected\r\n class function TableRowClass: TJclClrTableRowClass; override;\r\n public\r\n property Rows[const Idx: Integer]: TJclClrTableMethodDefRow read GetRow; default;\r\n end;\r\n\r\n TJclClrTableMethodPtrRow = class(TJclClrTableRow)\r\n private\r\n FMethodIdx: DWORD;\r\n function GetMethod: TJclClrTableMethodDefRow;\r\n public\r\n constructor Create(const ATable: TJclClrTable); override;\r\n\r\n property MethodIdx: DWORD read FMethodIdx;\r\n property Method: TJclClrTableMethodDefRow read GetMethod;\r\n end;\r\n\r\n TJclClrTableMethodPtr = class(TJclClrTable)\r\n private\r\n function GetRow(const Idx: Integer): TJclClrTableMethodPtrRow;\r\n protected\r\n class function TableRowClass: TJclClrTableRowClass; override;\r\n public\r\n property Rows[const Idx: Integer]: TJclClrTableMethodPtrRow read GetRow; default;\r\n end;\r\n\r\n TJclClrTableMethodImplRow = class(TJclClrTableRow)\r\n private\r\n FClassIdx: DWORD;\r\n FMethodBodyIdx: DWORD;\r\n FMethodDeclarationIdx: DWORD;\r\n public\r\n constructor Create(const ATable: TJclClrTable); override;\r\n\r\n property ClassIdx: DWORD read FClassIdx;\r\n property MethodBodyIdx: DWORD read FMethodBodyIdx;\r\n property MethodDeclarationIdx: DWORD read FMethodDeclarationIdx;\r\n end;\r\n\r\n TJclClrTableMethodImpl = class(TJclClrTable)\r\n private\r\n function GetRow(const Idx: Integer): TJclClrTableMethodImplRow;\r\n protected\r\n class function TableRowClass: TJclClrTableRowClass; override;\r\n public\r\n property Rows[const Idx: Integer]: TJclClrTableMethodImplRow read GetRow; default;\r\n end;\r\n\r\n TJclClrTableMethodSemanticsRow = class(TJclClrTableRow)\r\n private\r\n FSemantics: Word;\r\n FMethodIdx: DWORD;\r\n FAssociationIdx: DWORD;\r\n public\r\n constructor Create(const ATable: TJclClrTable); override;\r\n\r\n property Semantics: Word read FSemantics;\r\n property MethodIdx: DWORD read FMethodIdx;\r\n property AssociationIdx: DWORD read FAssociationIdx;\r\n end;\r\n\r\n TJclClrTableMethodSemantics = class(TJclClrTable)\r\n private\r\n function GetRow(const Idx: Integer): TJclClrTableMethodSemanticsRow;\r\n protected\r\n class function TableRowClass: TJclClrTableRowClass; override;\r\n public\r\n property Rows[const Idx: Integer]: TJclClrTableMethodSemanticsRow read GetRow; default;\r\n end;\r\n\r\n TJclClrTableMethodSpecRow = class(TJclClrTableRow)\r\n private\r\n FMethodIdx: DWORD;\r\n FInstantiationOffset: DWORD;\r\n function GetInstantiation: TJclClrBlobRecord;\r\n function GetMethod: TJclClrTableRow;\r\n public\r\n constructor Create(const ATable: TJclClrTable); override;\r\n property MethodIdx: DWORD read FMethodIdx;\r\n property InstantiationOffset: DWORD read FInstantiationOffset;\r\n property Method: TJclClrTableRow read GetMethod;\r\n property Instantiation: TJclClrBlobRecord read GetInstantiation;\r\n end;\r\n\r\n TJclClrTableMethodSpec = class(TJclClrTable)\r\n private\r\n function GetRow(const Idx: Integer): TJclClrTableMethodSpecRow;\r\n protected\r\n class function TableRowClass: TJclClrTableRowClass; override;\r\n public\r\n property Rows[const Idx: Integer]: TJclClrTableMethodSpecRow read GetRow; default;\r\n end;\r\n\r\n TJclClrTableNestedClassRow = class(TJclClrTableRow)\r\n private\r\n FEnclosingClassIdx: DWORD;\r\n FNestedClassIdx: DWORD;\r\n public\r\n constructor Create(const ATable: TJclClrTable); override;\r\n property NestedClassIdx: DWORD read FNestedClassIdx;\r\n property EnclosingClassIdx: DWORD read FEnclosingClassIdx;\r\n end;\r\n\r\n TJclClrTableNestedClass = class(TJclClrTable)\r\n private\r\n function GetRow(const Idx: Integer): TJclClrTableNestedClassRow;\r\n protected\r\n class function TableRowClass: TJclClrTableRowClass; override;\r\n public\r\n property Rows[const Idx: Integer]: TJclClrTableNestedClassRow read GetRow; default;\r\n end;\r\n\r\n TJclClrTablePropertyFlag = (pfSpecialName, pfRTSpecialName, pfHasDefault);\r\n TJclClrTablePropertyFlags = set of TJclClrTablePropertyFlag;\r\n\r\n TJclClrTablePropertyDefRow = class(TJclClrTableRow)\r\n private\r\n FKindIdx: DWORD;\r\n FNameOffset: DWORD;\r\n FFlags: Word;\r\n function GetName: WideString;\r\n function GetFlags: TJclClrTablePropertyFlags;\r\n public\r\n constructor Create(const ATable: TJclClrTable); override;\r\n\r\n function DumpIL: string; override;\r\n\r\n property RawFlags: Word read FFlags;\r\n property NameOffset: DWORD read FNameOffset;\r\n property KindIdx: DWORD read FKindIdx;\r\n\r\n property Name: WideString read GetName;\r\n property Flags: TJclClrTablePropertyFlags read GetFlags;\r\n end;\r\n\r\n TJclClrTablePropertyDef = class(TJclClrTable)\r\n private\r\n function GetRow(const Idx: Integer): TJclClrTablePropertyDefRow;\r\n protected\r\n class function TableRowClass: TJclClrTableRowClass; override;\r\n public\r\n property Rows[const Idx: Integer]: TJclClrTablePropertyDefRow read GetRow; default;\r\n end;\r\n\r\n TJclClrTablePropertyPtrRow = class(TJclClrTableRow)\r\n private\r\n FPropertyIdx: DWORD;\r\n function GetProperty: TJclClrTablePropertyDefRow;\r\n public\r\n constructor Create(const ATable: TJclClrTable); override;\r\n property PropertyIdx: DWORD read FPropertyIdx;\r\n property _Property: TJclClrTablePropertyDefRow read GetProperty;\r\n end;\r\n\r\n TJclClrTablePropertyPtr = class(TJclClrTable)\r\n private\r\n function GetRow(const Idx: Integer): TJclClrTablePropertyPtrRow;\r\n protected\r\n class function TableRowClass: TJclClrTableRowClass; override;\r\n public\r\n property Rows[const Idx: Integer]: TJclClrTablePropertyPtrRow read GetRow; default;\r\n end;\r\n\r\n TJclClrTablePropertyMapRow = class(TJclClrTableRow)\r\n private\r\n FParentIdx: DWORD;\r\n FPropertyListIdx: DWORD;\r\n FProperties: TList;\r\n function GetParent: TJclClrTableTypeDefRow;\r\n function GetProperty(const Idx: Integer): TJclClrTablePropertyDefRow;\r\n function GetPropertyCount: Integer;\r\n protected\r\n function Add(const ARow: TJclClrTablePropertyDefRow): Integer;\r\n public\r\n constructor Create(const ATable: TJclClrTable); override;\r\n destructor Destroy; override;\r\n\r\n property ParentIdx: DWORD read FParentIdx;\r\n property PropertyListIdx: DWORD read FPropertyListIdx;\r\n\r\n property Parent: TJclClrTableTypeDefRow read GetParent;\r\n\r\n property Properties[const Idx: Integer]: TJclClrTablePropertyDefRow read GetProperty;\r\n property PropertyCount: Integer read GetPropertyCount;\r\n end;\r\n\r\n TJclClrTablePropertyMap = class(TJclClrTable)\r\n private\r\n function GetRow(const Idx: Integer): TJclClrTablePropertyMapRow;\r\n protected\r\n class function TableRowClass: TJclClrTableRowClass; override;\r\n procedure Update; override;\r\n public\r\n property Rows[const Idx: Integer]: TJclClrTablePropertyMapRow read GetRow; default;\r\n end;\r\n\r\n TJclClrTableStandAloneSigRow = class(TJclClrTableRow)\r\n private\r\n FSignatureOffset: DWORD;\r\n function GetSignature: TJclClrBlobRecord;\r\n public\r\n constructor Create(const ATable: TJclClrTable); override;\r\n property SignatureOffset: DWORD read FSignatureOffset;\r\n property Signature: TJclClrBlobRecord read GetSignature;\r\n end;\r\n\r\n TJclClrTableStandAloneSig = class(TJclClrTable)\r\n private\r\n function GetRow(const Idx: Integer): TJclClrTableStandAloneSigRow;\r\n protected\r\n class function TableRowClass: TJclClrTableRowClass; override;\r\n public\r\n property Rows[const Idx: Integer]: TJclClrTableStandAloneSigRow read GetRow; default;\r\n end;\r\n\r\n TJclClrTypeVisibility =\r\n (tvNotPublic, tvPublic, tvNestedPublic,\r\n tvNestedPrivate, tvNestedFamily, tvNestedAssembly,\r\n tvNestedFamANDAssem, tvNestedFamORAssem);\r\n TJclClrClassLayout = (clAuto, clSequential, clExplicit);\r\n TJclClrClassSemantics = (csClass, csInterface);\r\n TJclClrStringFormatting = (sfAnsi, sfUnicode, sfAutoChar);\r\n\r\n TJclClrTypeAttribute =\r\n (taAbstract, taSealed, taSpecialName, taImport,\r\n taSerializable, taBeforeFieldInit, taRTSpecialName, taHasSecurity);\r\n TJclClrTypeAttributes = set of TJclClrTypeAttribute;\r\n\r\n TJclClrTableTypeDefRow = class(TJclClrTableRow)\r\n private\r\n FNamespaceOffset: DWORD;\r\n FNameOffset: DWORD;\r\n FFlags: DWORD;\r\n FExtendsIdx: DWORD;\r\n FFieldListIdx: DWORD;\r\n FMethodListIdx: DWORD;\r\n FFields: TList;\r\n FMethods: TList;\r\n function GetName: WideString;\r\n function GetNamespace: WideString;\r\n function GetField(const Idx: Integer): TJclClrTableFieldDefRow;\r\n function GetFieldCount: Integer;\r\n function GetMethod(const Idx: Integer): TJclClrTableMethodDefRow;\r\n function GetMethodCount: Integer;\r\n procedure UpdateFields;\r\n procedure UpdateMethods;\r\n function GetFullName: WideString;\r\n function GetAttributes: TJclClrTypeAttributes;\r\n function GetClassLayout: TJclClrClassLayout;\r\n function GetClassSemantics: TJclClrClassSemantics;\r\n function GetStringFormatting: TJclClrStringFormatting;\r\n function GetVisibility: TJclClrTypeVisibility;\r\n function GetExtends: TJclClrTableRow;\r\n protected\r\n procedure Update; override;\r\n public\r\n constructor Create(const ATable: TJclClrTable); override;\r\n destructor Destroy; override;\r\n\r\n function DumpIL: string; override;\r\n\r\n function HasField: Boolean;\r\n function HasMethod: Boolean;\r\n\r\n property Flags: DWORD read FFlags;\r\n property NameOffset: DWORD read FNameOffset;\r\n property NamespaceOffset: DWORD read FNamespaceOffset;\r\n property ExtendsIdx: DWORD read FExtendsIdx;\r\n property FieldListIdx: DWORD read FFieldListIdx;\r\n property MethodListIdx: DWORD read FMethodListIdx;\r\n\r\n property Name: WideString read GetName;\r\n property Namespace: WideString read GetNamespace;\r\n property FullName: WideString read GetFullName;\r\n property Extends: TJclClrTableRow read GetExtends;\r\n\r\n property Attributes: TJclClrTypeAttributes read GetAttributes;\r\n\r\n property Visibility: TJclClrTypeVisibility read GetVisibility;\r\n property ClassLayout: TJclClrClassLayout read GetClassLayout;\r\n property ClassSemantics: TJclClrClassSemantics read GetClassSemantics;\r\n property StringFormatting: TJclClrStringFormatting read GetStringFormatting;\r\n\r\n property Fields[const Idx: Integer]: TJclClrTableFieldDefRow read GetField;\r\n property FieldCount: Integer read GetFieldCount;\r\n property Methods[const Idx: Integer]: TJclClrTableMethodDefRow read GetMethod;\r\n property MethodCount: Integer read GetMethodCount;\r\n end;\r\n\r\n TJclClrTableTypeDef = class(TJclClrTable, ITableCanDumpIL)\r\n private\r\n function GetRow(const Idx: Integer): TJclClrTableTypeDefRow;\r\n protected\r\n class function TableRowClass: TJclClrTableRowClass; override;\r\n public\r\n property Rows[const Idx: Integer]: TJclClrTableTypeDefRow read GetRow; default;\r\n end;\r\n\r\n TJclClrTableTypeRefRow = class(TJclClrTableRow)\r\n private\r\n FResolutionScopeIdx: DWORD;\r\n FNamespaceOffset: DWORD;\r\n FNameOffset: DWORD;\r\n function GetName: WideString;\r\n function GetNamespace: WideString;\r\n function GetResolutionScope: TJclClrTableRow;\r\n function GetResolutionScopeName: string;\r\n function GetFullName: WideString;\r\n public\r\n constructor Create(const ATable: TJclClrTable); override;\r\n function DumpIL: string; override;\r\n\r\n property ResolutionScopeIdx: DWORD read FResolutionScopeIdx;\r\n property NameOffset: DWORD read FNameOffset;\r\n property NamespaceOffset: DWORD read FNamespaceOffset;\r\n\r\n property ResolutionScope: TJclClrTableRow read GetResolutionScope;\r\n property ResolutionScopeName: string read GetResolutionScopeName;\r\n property Name: WideString read GetName;\r\n property Namespace: WideString read GetNamespace;\r\n property FullName: WideString read GetFullName;\r\n end;\r\n\r\n TJclClrTableTypeRef = class(TJclClrTable)\r\n private\r\n function GetRow(const Idx: Integer): TJclClrTableTypeRefRow;\r\n protected\r\n class function TableRowClass: TJclClrTableRowClass; override;\r\n public\r\n property Rows[const Idx: Integer]: TJclClrTableTypeRefRow read GetRow; default;\r\n end;\r\n\r\n TJclClrTableTypeSpecRow = class(TJclClrTableRow)\r\n private\r\n FSignatureOffset: DWORD;\r\n function GetSignature: TJclClrBlobRecord;\r\n public\r\n constructor Create(const ATable: TJclClrTable); override;\r\n property SignatureOffset: DWORD read FSignatureOffset;\r\n property Signature: TJclClrBlobRecord read GetSignature;\r\n end;\r\n\r\n TJclClrTableTypeSpec = class(TJclClrTable)\r\n private\r\n function GetRow(const Idx: Integer): TJclClrTableTypeSpecRow;\r\n protected\r\n class function TableRowClass: TJclClrTableRowClass; override;\r\n public\r\n property Rows[const Idx: Integer]: TJclClrTableTypeSpecRow read GetRow; default;\r\n end;\r\n\r\n TJclClrTableENCMapRow = class(TJclClrTableRow)\r\n private\r\n FToken: DWORD;\r\n FFuncCode: DWORD;\r\n protected\r\n property FuncCode: DWORD read FFuncCode;\r\n public\r\n constructor Create(const ATable: TJclClrTable); override;\r\n end;\r\n\r\n TJclClrTableENCMap = class(TJclClrTable)\r\n private\r\n function GetRow(const Idx: Integer): TJclClrTableENCMapRow;\r\n protected\r\n class function TableRowClass: TJclClrTableRowClass; override;\r\n public\r\n property Rows[const Idx: Integer]: TJclClrTableENCMapRow read GetRow; default;\r\n end;\r\n\r\n TJclClrTableENCLogRow = class(TJclClrTableENCMapRow)\r\n private\r\n FFuncCode: DWORD;\r\n protected\r\n property FuncCode: DWORD read FFuncCode;\r\n public\r\n constructor Create(const ATable: TJclClrTable); override;\r\n end;\r\n\r\n TJclClrTableENCLog = class(TJclClrTable)\r\n private\r\n function GetRow(const Idx: Integer): TJclClrTableENCLogRow;\r\n protected\r\n class function TableRowClass: TJclClrTableRowClass; override;\r\n public\r\n property Rows[const Idx: Integer]: TJclClrTableENCLogRow read GetRow; default;\r\n end;\r\n\r\n EJclMetadataError = class(EJclError);\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jcl.svn.sourceforge.net/svnroot/jcl/tags/JCL-2.4-Build4571/jcl/source/windows/JclMetadata.pas $';\r\n Revision: '$Revision: 3599 $';\r\n Date: '$Date: 2011-09-03 00:07:50 +0200 (sam. 03 sept. 2011) $';\r\n LogPath: 'JCL\\source\\windows';\r\n Extra: '';\r\n Data: nil\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n {$IFDEF HAS_UNITSCOPE}\r\n System.Math,\r\n {$IFDEF HAS_UNIT_CHARACTER}\r\n System.Character,\r\n {$ENDIF HAS_UNIT_CHARACTER}\r\n {$ELSE ~HAS_UNITSCOPE}\r\n Math,\r\n {$IFDEF HAS_UNIT_CHARACTER}\r\n Character,\r\n {$ENDIF HAS_UNIT_CHARACTER}\r\n {$ENDIF ~HAS_UNITSCOPE}\r\n JclCIL, JclResources, JclStrings;\r\n\r\nconst\r\n // MAX_CLASS_NAME = 1024;\r\n MAX_PATH_NAME = 260;\r\n\r\n // Assembly attr bits, used by DefineAssembly.\r\n afPublicKey = $0001; // The assembly ref holds the full (unhashed) public key.\r\n afCompatibilityMask = $0070;\r\n afSideBySideCompatible = $0000; // The assembly is side by side compatible.\r\n afNonSideBySideAppDomain = $0010; // The assembly cannot execute with other versions if\r\n // they are executing in the same application domain.\r\n afNonSideBySideProcess = $0020; // The assembly cannot execute with other versions if\r\n // they are executing in the same process.\r\n afNonSideBySideMachine = $0030; // The assembly cannot execute with other versions if\r\n // they are executing on the same machine.\r\n afEnableJITcompileTracking = $8000; // From \"DebuggableAttribute\".\r\n afDisableJITcompileOptimizer = $4000; // From \"DebuggableAttribute\".\r\n\r\n ClrAssemblyFlagMapping: array [TJclClrAssemblyFlag] of DWORD =\r\n (afPublicKey, afCompatibilityMask, afSideBySideCompatible,\r\n afNonSideBySideAppDomain, afNonSideBySideProcess,\r\n afNonSideBySideMachine, afEnableJITcompileTracking,\r\n afDisableJITcompileOptimizer);\r\n\r\n mrVisibilityMask = $0007;\r\n mrPublic = $0001; // The Resource is exported from the Assembly.\r\n mrPrivate = $0002; // The Resource is private to the Assembly.\r\n\r\n ManifestResourceVisibilityMapping: array [TJclClrTableManifestResourceVisibility] of DWORD =\r\n (mrPublic, mrPrivate);\r\n\r\n // MethodDef attr bits, Used by DefineMethod.\r\n // member access mask - Use this mask to retrieve accessibility information.\r\n mdMemberAccessMask = $0007;\r\n // mdPrivateScope = $0000; // Member not referenceable.\r\n // mdPrivate = $0001; // Accessible only by the parent type.\r\n // mdFamANDAssem = $0002; // Accessible by sub-types only in this Assembly.\r\n // mdAssem = $0003; // Accessibly by anyone in the Assembly.\r\n // mdFamily = $0004; // Accessible only by type and sub-types.\r\n // mdFamORAssem = $0005; // Accessibly by sub-types anywhere, plus anyone in assembly.\r\n // mdPublic = $0006; // Accessibly by anyone who has visibility to this scope.\r\n // end member access mask\r\n\r\n // method contract attributes.\r\n mdStatic = $0010; // Defined on type, else per instance.\r\n mdFinal = $0020; // Method may not be overridden.\r\n mdVirtual = $0040; // Method virtual.\r\n mdHideBySig = $0080; // Method hides by name+sig, else just by name.\r\n\r\n // vtable layout mask - Use this mask to retrieve vtable attributes.\r\n mdVtableLayoutMask = $0100;\r\n // mdReuseSlot = $0000; // The default.\r\n mdNewSlot = $0100; // Method always gets a new slot in the vtable.\r\n // end vtable layout mask\r\n\r\n // method implementation attributes.\r\n mdCheckAccessOnOverride = $0200; // Overridability is the same as the visibility.\r\n mdAbstract = $0400; // Method does not provide an implementation.\r\n mdSpecialName = $0800; // Method is special. Name describes how.\r\n\r\n // interop attributes\r\n mdPinvokeImpl = $2000; // Implementation is forwarded through pinvoke.\r\n mdUnmanagedExport = $0008; // Managed method exported via thunk to unmanaged code.\r\n\r\n // Reserved flags for runtime use only.\r\n // mdReservedMask = $d000;\r\n mdRTSpecialName = $1000; // Runtime should check name encoding.\r\n mdHasSecurity = $4000; // Method has security associate with it.\r\n mdRequireSecObject = $8000; // Method calls another method containing security code.\r\n\r\n // MethodImpl attr bits, used by DefineMethodImpl.\r\n // code impl mask\r\n miCodeTypeMask = $0003; // Flags about code type.\r\n // miIL = $0000; // Method impl is IL.\r\n // miNative = $0001; // Method impl is native.\r\n // miOPTIL = $0002; // Method impl is OPTIL\r\n // miRuntime = $0003; // Method impl is provided by the runtime.\r\n // end code impl mask\r\n\r\n // managed mask\r\n miManagedMask = $0004; // Flags specifying whether the code is managed or unmanaged.\r\n // miUnmanaged = $0004; // Method impl is unmanaged, otherwise managed.\r\n miManaged = $0000; // Method impl is managed.\r\n // end managed mask\r\n\r\n // implementation info and interop\r\n miForwardRef = $0010; // Indicates method is defined; used primarily in merge scenarios.\r\n miPreserveSig = $0080; // Indicates method sig is not to be mangled to do HRESULT conversion.\r\n\r\n miInternalCall = $1000; // Reserved for internal use.\r\n\r\n miSynchronized = $0020; // Method is single threaded through the body.\r\n miNoInlining = $0008; // Method may not be inlined.\r\n // miMaxMethodImplVal = $ffff; // Range check value\r\n\r\n // Calling convention flags.\r\n IMAGE_CEE_CS_CALLCONV_DEFAULT = $0;\r\n IMAGE_CEE_CS_CALLCONV_VARARG = $5;\r\n IMAGE_CEE_CS_CALLCONV_FIELD = $6;\r\n IMAGE_CEE_CS_CALLCONV_LOCAL_SIG = $7;\r\n // IMAGE_CEE_CS_CALLCONV_PROPERTY = $8;\r\n // IMAGE_CEE_CS_CALLCONV_UNMGD = $9;\r\n // IMAGE_CEE_CS_CALLCONV_MAX = $10; // first invalid calling convention\r\n // The high bits of the calling convention convey additional info\r\n IMAGE_CEE_CS_CALLCONV_MASK = $0f; // Calling convention is bottom 4 bits\r\n IMAGE_CEE_CS_CALLCONV_HASTHIS = $20; // Top bit indicates a 'this' parameter\r\n IMAGE_CEE_CS_CALLCONV_EXPLICITTHIS = $40; // This parameter is explicitly in the signature\r\n\r\n // TypeDef/ExportedType attr bits, used by DefineTypeDef.\r\n // Use this mask to retrieve the type visibility information.\r\n tdVisibilityMask = $00000007;\r\n // tdNotPublic = $00000000; // Class is not public scope.\r\n // tdPublic = $00000001; // Class is public scope.\r\n // tdNestedPublic = $00000002; // Class is nested with public visibility.\r\n // tdNestedPrivate = $00000003; // Class is nested with private visibility.\r\n // tdNestedFamily = $00000004; // Class is nested with family visibility.\r\n // tdNestedAssembly = $00000005; // Class is nested with assembly visibility.\r\n // tdNestedFamANDAssem = $00000006; // Class is nested with family and assembly visibility.\r\n // tdNestedFamORAssem = $00000007; // Class is nested with family or assembly visibility.\r\n\r\n // Use this mask to retrieve class layout information\r\n tdLayoutMask = $00000018;\r\n tdAutoLayout = $00000000; // Class fields are auto-laid out\r\n tdSequentialLayout = $00000008; // Class fields are laid out sequentially\r\n tdExplicitLayout = $00000010; // Layout is supplied explicitly\r\n // end layout mask\r\n\r\n // Use this mask to retrieve class semantics information.\r\n tdClassSemanticsMask = $00000020;\r\n // tdClass = $00000000; // Type is a class.\r\n tdInterface = $00000020; // Type is an interface.\r\n // end semantics mask\r\n\r\n // Special semantics in addition to class semantics.\r\n tdAbstract = $00000080; // Class is abstract\r\n tdSealed = $00000100; // Class is concrete and may not be extended\r\n tdSpecialName = $00000400; // Class name is special. Name describes how.\r\n\r\n // Implementation attributes.\r\n tdImport = $00001000; // Class / interface is imported\r\n tdSerializable = $00002000; // The class is Serializable.\r\n\r\n // Use tdStringFormatMask to retrieve string information for native interop\r\n tdStringFormatMask = $00030000;\r\n tdAnsiClass = $00000000; // LPTSTR is interpreted as ANSI in this class\r\n tdUnicodeClass = $00010000; // LPTSTR is interpreted as UNICODE\r\n tdAutoClass = $00020000; // LPTSTR is interpreted automatically\r\n // end string format mask\r\n\r\n tdBeforeFieldInit = $00100000; // Initialize the class any time before first static field access.\r\n\r\n // Flags reserved for runtime use.\r\n // tdReservedMask = $00040800;\r\n tdRTSpecialName = $00000800; // Runtime should check name encoding.\r\n tdHasSecurity = $00040000; // Class has security associate with it.\r\n\r\n // FieldDef attr bits, used by DefineField.\r\n // member access mask - Use this mask to retrieve accessibility information.\r\n fdFieldAccessMask = $0007;\r\n fdPrivateScope = $0000; // Member not referenceable.\r\n // fdPrivate = $0001; // Accessible only by the parent type.\r\n // fdFamANDAssem = $0002; // Accessible by sub-types only in this Assembly.\r\n // fdAssembly = $0003; // Accessibly by anyone in the Assembly.\r\n // fdFamily = $0004; // Accessible only by type and sub-types.\r\n // fdFamORAssem = $0005; // Accessibly by sub-types anywhere, plus anyone in assembly.\r\n fdPublic = $0006; // Accessibly by anyone who has visibility to this scope.\r\n // end member access mask\r\n\r\n // field contract attributes.\r\n fdStatic = $0010; // Defined on type, else per instance.\r\n fdInitOnly = $0020; // Field may only be initialized, not written to after init.\r\n fdLiteral = $0040; // Value is compile time constant.\r\n fdNotSerialized = $0080; // Field does not have to be serialized when type is remoted.\r\n\r\n fdSpecialName = $0200; // field is special. Name describes how.\r\n\r\n // interop attributes\r\n fdPinvokeImpl = $2000; // Implementation is forwarded through pinvoke.\r\n\r\n // Reserved flags for runtime use only.\r\n // fdReservedMask = $9500;\r\n fdRTSpecialName = $0400; // Runtime(metadata internal APIs) should check name encoding.\r\n fdHasFieldMarshal = $1000; // Field has marshalling information.\r\n fdHasDefault = $8000; // Field has default.\r\n fdHasFieldRVA = $0100; // Field has RVA.\r\n\r\n // Flags for Params\r\n pdIn = $0001; // Param is [In]\r\n pdOut = $0002; // Param is [out]\r\n pdOptional = $0010; // Param is optional\r\n\r\n // Reserved flags for Runtime use only.\r\n // pdReservedMask = $f000;\r\n pdHasDefault = $1000; // Param has default value.\r\n pdHasFieldMarshal = $2000; // Param has FieldMarshal.\r\n\r\n // pdUnused = $cfe0;\r\n\r\n ClrParamKindMapping: array [TJclClrParamKind] of DWORD =\r\n (pdIn, pdOut, pdOptional, pdHasDefault, pdHasFieldMarshal);\r\n\r\n // Element type for Cor signature\r\n ELEMENT_TYPE_END = $0;\r\n ELEMENT_TYPE_VOID = $1;\r\n ELEMENT_TYPE_BOOLEAN = $2;\r\n ELEMENT_TYPE_CHAR = $3;\r\n ELEMENT_TYPE_I1 = $4;\r\n ELEMENT_TYPE_U1 = $5;\r\n ELEMENT_TYPE_I2 = $6;\r\n ELEMENT_TYPE_U2 = $7;\r\n ELEMENT_TYPE_I4 = $8;\r\n ELEMENT_TYPE_U4 = $9;\r\n ELEMENT_TYPE_I8 = $a;\r\n ELEMENT_TYPE_U8 = $b;\r\n ELEMENT_TYPE_R4 = $c;\r\n ELEMENT_TYPE_R8 = $d;\r\n ELEMENT_TYPE_STRING = $e;\r\n\r\n // every type above PTR will be simple type\r\n ELEMENT_TYPE_PTR = $f; // PTR \r\n ELEMENT_TYPE_BYREF = $10; // BYREF \r\n\r\n // Please use ELEMENT_TYPE_VALUETYPE. ELEMENT_TYPE_VALUECLASS is deprecated.\r\n ELEMENT_TYPE_VALUETYPE = $11; // VALUETYPE \r\n ELEMENT_TYPE_CLASS = $12; // CLASS \r\n\r\n ELEMENT_TYPE_ARRAY = $14; // MDARRAY ... ...\r\n\r\n ELEMENT_TYPE_TYPEDBYREF = $16; // This is a simple type.\r\n\r\n ELEMENT_TYPE_I = $18; // native integer size\r\n ELEMENT_TYPE_U = $19; // native unsigned integer size\r\n ELEMENT_TYPE_FNPTR = $1B; // FNPTR \r\n ELEMENT_TYPE_OBJECT = $1C; // Shortcut for System.Object\r\n ELEMENT_TYPE_SZARRAY = $1D; // Shortcut for single dimension zero lower bound array\r\n // SZARRAY \r\n\r\n // This is only for binding\r\n ELEMENT_TYPE_CMOD_REQD = $1F; // required C modifier : E_T_CMOD_REQD \r\n ELEMENT_TYPE_CMOD_OPT = $20; // optional C modifier : E_T_CMOD_OPT \r\n\r\n // This is for signatures generated internally (which will not be persisted in any way).\r\n ELEMENT_TYPE_INTERNAL = $21; // INTERNAL \r\n\r\n // Note that this is the max of base type excluding modifiers\r\n ELEMENT_TYPE_MAX = $22; // first invalid element type\r\n\r\n\r\n ELEMENT_TYPE_MODIFIER = $40;\r\n ELEMENT_TYPE_SENTINEL = $01 or ELEMENT_TYPE_MODIFIER; // sentinel for varargs\r\n ELEMENT_TYPE_PINNED = $05 or ELEMENT_TYPE_MODIFIER;\r\n\r\n ClrElementTypeMapping: array [TJclClrElementType] of Byte =\r\n (ELEMENT_TYPE_END, ELEMENT_TYPE_VOID, ELEMENT_TYPE_BOOLEAN,\r\n ELEMENT_TYPE_CHAR, ELEMENT_TYPE_I1, ELEMENT_TYPE_U1,\r\n ELEMENT_TYPE_I2, ELEMENT_TYPE_U2, ELEMENT_TYPE_I4, ELEMENT_TYPE_U4,\r\n ELEMENT_TYPE_I8, ELEMENT_TYPE_U8, ELEMENT_TYPE_R4, ELEMENT_TYPE_R8,\r\n ELEMENT_TYPE_STRING, ELEMENT_TYPE_PTR, ELEMENT_TYPE_BYREF,\r\n ELEMENT_TYPE_VALUETYPE, ELEMENT_TYPE_CLASS, ELEMENT_TYPE_ARRAY,\r\n ELEMENT_TYPE_TYPEDBYREF, ELEMENT_TYPE_I, ELEMENT_TYPE_U,\r\n ELEMENT_TYPE_FNPTR, ELEMENT_TYPE_OBJECT, ELEMENT_TYPE_SZARRAY,\r\n ELEMENT_TYPE_CMOD_REQD, ELEMENT_TYPE_CMOD_OPT, ELEMENT_TYPE_INTERNAL,\r\n ELEMENT_TYPE_MAX, ELEMENT_TYPE_MODIFIER, ELEMENT_TYPE_SENTINEL,\r\n ELEMENT_TYPE_PINNED);\r\n\r\n ClrMethodFlagMapping: array [TJclClrMethodFlag] of Word =\r\n (mdStatic, mdFinal, mdVirtual, mdHideBySig, mdCheckAccessOnOverride,\r\n mdAbstract, mdSpecialName, mdPinvokeImpl, mdUnmanagedExport,\r\n mdRTSpecialName, mdHasSecurity, mdRequireSecObject);\r\n\r\n ClrMethodImplFlagMapping: array [TJclClrMethodImplFlag] of Word =\r\n (miForwardRef, miPreserveSig, miInternalCall, miSynchronized, miNoInlining);\r\n\r\n // Property attr bits, used by DefineProperty.\r\n prSpecialName = $0200; // property is special. Name describes how.\r\n\r\n // Reserved flags for Runtime use only.\r\n // prReservedMask = $f400;\r\n prRTSpecialName = $0400; // Runtime(metadata internal APIs) should check name encoding.\r\n prHasDefault = $1000; // Property has default\r\n\r\n // prUnused = $e9ff;\r\n\r\n ClrTablePropertyFlagMapping: array [TJclClrTablePropertyFlag] of Word =\r\n (prSpecialName, prRTSpecialName, prHasDefault);\r\n\r\n // Event attr bits, used by DefineEvent.\r\n // evSpecialName = $0200; // event is special. Name describes how.\r\n\r\n // Reserved flags for Runtime use only.\r\n // evReservedMask = $0400;\r\n // evRTSpecialName = $0400; // Runtime(metadata internal APIs) should check name encoding.\r\n\r\n // ClrTableEventFlagMapping: array [TJclClrTableEventFlag] of Word =\r\n // (evSpecialName, evRTSpecialName);\r\n\r\n // DeclSecurity attr bits, used by DefinePermissionSet\r\n // dclActionMask = $000f; // Mask allows growth of enum.\r\n // dclActionNil = $0000;\r\n // dclRequest = $0001;\r\n // dclDemand = $0002;\r\n // dclAssert = $0003;\r\n // dclDeny = $0004;\r\n // dclPermitOnly = $0005;\r\n // dclLinktimeCheck = $0006;\r\n // dclInheritanceCheck = $0007;\r\n // dclRequestMinimum = $0008;\r\n // dclRequestOptional = $0009;\r\n // dclRequestRefuse = $000a;\r\n // dclPrejitGrant = $000b; // Persisted grant set at prejit time\r\n // dclPrejitDenied = $000c; // Persisted denied set at prejit time\r\n // dclNonCasDemand = $000d; //\r\n // dclNonCasLinkDemand = $000e;\r\n // dclNonCasInheritance = $000f;\r\n // dclMaximumValue = $000f; // Maximum legal value\r\n\r\n // PinvokeMap attr bits, used by DefinePinvokeMap\r\n // pmNoMangle = $0001; // Pinvoke is to use the member name as specified.\r\n\r\n // Use this mask to retrieve the CharSet information.\r\n // pmCharSetMask = $0006;\r\n // pmCharSetNotSpec = $0000;\r\n // pmCharSetAnsi = $0002;\r\n // pmCharSetUnicode = $0004;\r\n // pmCharSetAuto = $0006;\r\n\r\n\r\n // pmBestFitUseAssem = $0000;\r\n // pmBestFitEnabled = $0010;\r\n // pmBestFitDisabled = $0020;\r\n // pmBestFitMask = $0030;\r\n\r\n // pmThrowOnUnmappableCharUseAssem = $0000;\r\n // pmThrowOnUnmappableCharEnabled = $1000;\r\n // pmThrowOnUnmappableCharDisabled = $2000;\r\n // pmThrowOnUnmappableCharMask = $3000;\r\n\r\n // pmSupportsLastError = $0040; // Information about target function. Not relevant for fields.\r\n\r\n // None of the calling convention flags is relevant for fields.\r\n // pmCallConvMask = $0700;\r\n // pmCallConvWinapi = $0100; // Pinvoke will use native callconv appropriate to target windows platform.\r\n // pmCallConvCdecl = $0200;\r\n // pmCallConvStdcall = $0300;\r\n // pmCallConvThiscall = $0400; // In M9, pinvoke will raise exception.\r\n // pmCallConvFastcall = $0500;\r\n\r\nfunction IsBitSet(const Value, Flag: DWORD): Boolean;\r\nbegin\r\n Result := (Value and Flag) = Flag;\r\nend;\r\n\r\n//=== { TJclClrSignature } ===================================================\r\n\r\nconstructor TJclClrSignature.Create(const ABlob: TJclClrBlobRecord);\r\nbegin\r\n inherited Create;\r\n FBlob := ABlob;\r\nend;\r\n\r\nfunction TJclClrSignature.IsModifierType(const AElementType: TJclClrElementType): Boolean;\r\nbegin\r\n Result := AElementType in [etPtr, etByRef, etModifier, etSentinel, etPinned];\r\nend;\r\n\r\nfunction TJclClrSignature.IsPrimitiveType(const AElementType: TJclClrElementType): Boolean;\r\nbegin\r\n Result := AElementType < etPtr;\r\nend;\r\n\r\nfunction TJclClrSignature.UncompressedDataSize(DataPtr: PJclByteArray): Integer;\r\nbegin\r\n if (DataPtr[0] and $80) = 0 then\r\n Result := 1\r\n else\r\n if (DataPtr[0] and $C0) = $80 then\r\n Result := 2\r\n else\r\n Result := 4;\r\nend;\r\n\r\nfunction TJclClrSignature.UncompressData(DataPtr: PJclByteArray; out Value: DWord): Integer;\r\nbegin\r\n if (DataPtr[0] and $80) = 0 then // 0??? ????\r\n begin\r\n Value := DataPtr[0];\r\n Result := 1;\r\n end\r\n else\r\n if (DataPtr[0] and $C0) = $80 then // 10?? ????\r\n begin\r\n Value := ((DataPtr[0] and $3F) shl 8) or DataPtr[1];\r\n Result := 2;\r\n end\r\n else\r\n if (DataPtr[0] and $E0) = $C0 then // 110? ????\r\n begin\r\n Value := ((DataPtr[0] and $1F) shl 24) or (DataPtr[1] shl 16) or (DataPtr[2] shl 8) or DataPtr[3];\r\n Result := 4;\r\n end\r\n else\r\n raise EJclMetadataError.CreateResFmt(@RsInvalidSignatureData,\r\n [DataPtr[0], DataPtr[1], DataPtr[2], DataPtr[3]]);\r\nend;\r\n\r\nfunction TJclClrSignature.UncompressToken(DataPtr: PJclByteArray; out Token: TJclClrToken): Integer;\r\nconst\r\n TableMapping: array [0..3] of TJclClrTableKind = (ttTypeDef, ttTypeRef, ttTypeSpec, TJclClrTableKind(0));\r\nbegin\r\n Result := UncompressData(DataPtr, Token);\r\n Token := (Byte(TableMapping[Token and 3]) shl 24) or (Token shr 2);\r\nend;\r\n\r\nfunction TJclClrSignature.UncompressCallingConv(DataPtr: PJclByteArray): Byte;\r\nbegin\r\n Result := DataPtr[0];\r\nend;\r\n\r\nfunction TJclClrSignature.UncompressSignedInt(DataPtr: PJclByteArray; out Value: Integer): Integer;\r\nvar\r\n Data: DWord;\r\nbegin\r\n Result := UncompressData(DataPtr, Data);\r\n\r\n if (Data and 1) <> 0 then\r\n begin\r\n case Result of\r\n 1:\r\n Value := Integer(DWord(Data shr 1) or $ffffffc0);\r\n 2:\r\n Value := Integer(DWord(Data shr 1) or $ffffe000);\r\n else\r\n Value := Integer(DWord(Data shr 1) or $f0000000);\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJclClrSignature.UncompressElementType(DataPtr: PJclByteArray): TJclClrElementType;\r\nbegin\r\n for Result := Low(TJclClrElementType) to High(TJclClrElementType) do\r\n if ClrElementTypeMapping[Result] = (DataPtr[0] and $7F) then\r\n Break;\r\nend;\r\n\r\nfunction TJclClrSignature.UncompressFieldSignature: string;\r\nvar\r\n DataPtr: PJclByteArray;\r\nbegin\r\n DataPtr := Blob.Memory;\r\n\r\n Assert(DataPtr[0] = IMAGE_CEE_CS_CALLCONV_FIELD);\r\n Inc(DataPtr);\r\n Result := UncompressTypeSignature(DataPtr);\r\nend;\r\n\r\nfunction TJclClrSignature.UncompressTypeSignature(DataPtr: PJclByteArray): string;\r\nconst\r\n SimpleTypeName: array [etVoid..etString] of PChar =\r\n ('void', 'bool', 'char',\r\n 'int8', 'unsigned int8', 'int16', 'unsigned int16',\r\n 'int32', 'unsigned int32', 'int64', 'unsigned int64',\r\n 'float32', 'float64', 'string');\r\n TypedTypeName: array [etPtr..etClass] of PChar =\r\n ('ptr', 'byref', 'valuetype', 'class');\r\nvar\r\n ElementType: TJclClrElementType;\r\n Token: TJclClrToken;\r\nbegin\r\n ElementType := UncompressElementType(DataPtr);\r\n\r\n case ElementType of\r\n etVoid, etBoolean, etChar, etI1, etU1, etI2, etU2, etI4, etU4, etI8, etU8, etR4, etR8, etString:\r\n Result := SimpleTypeName[ElementType];\r\n etI:\r\n Result := 'System.IntPtr';\r\n etU:\r\n Result := 'System.UIntPtr';\r\n etObject:\r\n Result := 'System.object';\r\n etTypedByRef:\r\n Result := 'Typed By Ref';\r\n etPtr, etByRef, etValueType, etClass:\r\n begin\r\n UncompressToken(DataPtr, Token);\r\n Result := Format('%s /*%.8x*/', [TypedTypeName[ElementType], Token]);\r\n end;\r\n etSzArray:\r\n begin\r\n end;\r\n etFnPtr:\r\n begin\r\n end;\r\n etArray:\r\n begin\r\n end;\r\n else\r\n Result := 'Unknown Type';\r\n end;\r\nend;\r\n\r\nfunction TJclClrSignature.Inc(var DataPtr: PJclByteArray; Step: TJclAddr): PByte;\r\nbegin\r\n Result := PByte(TJclAddr(DataPtr) + Step);\r\n DataPtr := PJclByteArray(Result);\r\nend;\r\n\r\nfunction TJclClrSignature.ReadValue: DWORD;\r\nbegin\r\n FBlob.Seek(UncompressData(Blob.Data, Result), soFromCurrent);\r\nend;\r\n\r\nfunction TJclClrSignature.ReadInteger: Integer;\r\nbegin\r\n FBlob.Seek(UncompressSignedInt(Blob.Data, Result), soFromCurrent);\r\nend;\r\n\r\nfunction TJclClrSignature.ReadToken: TJclClrToken;\r\nbegin\r\n FBlob.Seek(UncompressToken(Blob.Data, Result), soFromCurrent);\r\nend;\r\n\r\nfunction TJclClrSignature.ReadElementType: TJclClrElementType;\r\nbegin\r\n Result := UncompressElementType(Blob.Data);\r\n FBlob.Seek(1, soFromCurrent);\r\nend;\r\n\r\nfunction TJclClrSignature.ReadByte: Byte;\r\nbegin\r\n Result := Blob.Data[0];\r\n FBlob.Seek(1, soFromCurrent);\r\nend;\r\n\r\n//=== { TJclClrArraySign } ===================================================\r\n\r\nconstructor TJclClrArraySign.Create(const ABlob: TJclClrBlobRecord);\r\nvar\r\n I: Integer;\r\nbegin\r\n inherited Create(ABlob);\r\n\r\n SetLength(FBounds, ReadInteger);\r\n\r\n for I := 0 to Length(FBounds)-1 do\r\n begin\r\n FBounds[I][adSize] := 0;\r\n FBounds[I][adLowBound] := 0;\r\n end;\r\n for I := 0 to ReadInteger-1 do\r\n FBounds[I][adSize] := ReadInteger;\r\n for I := 0 to ReadInteger-1 do\r\n FBounds[I][adLowBound] := ReadInteger;\r\nend;\r\n\r\n//=== { TJclClrTableModuleRow } ==============================================\r\n\r\nconstructor TJclClrTableModuleRow.Create(const ATable: TJclClrTable);\r\nbegin\r\n inherited Create(ATable);\r\n FGeneration := Table.ReadWord; // Generation (reserved, shall be zero)\r\n FNameOffset := Table.ReadIndex(hkString); // Name (index into String heap)\r\n FMvidIdx := Table.ReadIndex(hkGuid); // Mvid (index into Guid heap)\r\n FEncIdIdx := Table.ReadIndex(hkGuid); // Mvid (index into Guid heap)\r\n FEncBaseIdIdx := Table.ReadIndex(hkGuid); // Mvid (index into Guid heap)\r\nend;\r\n\r\nfunction TJclClrTableModuleRow.HasEncId: Boolean;\r\nbegin\r\n Result := FEncIdIdx > 0;\r\nend;\r\n\r\nfunction TJclClrTableModuleRow.HasEncBaseId: Boolean;\r\nbegin\r\n Result := FEncBaseIdIdx > 0;\r\nend;\r\n\r\nfunction TJclClrTableModuleRow.GetName: WideString;\r\nbegin\r\n Result := Table.Stream.Metadata.StringAt(FNameOffset);\r\n Assert(Result <> ''); // Name shall index a non-null string.\r\n Assert(Length(Result) < MAX_PATH_NAME);\r\nend;\r\n\r\nfunction TJclClrTableModuleRow.GetMvid: TGUID;\r\nbegin\r\n // Mvid shall index a non-null GUID in the Guid heap\r\n Assert(FMvidIdx <= DWORD(Table.Stream.Metadata.GuidCount));\r\n Result := Table.Stream.Metadata.Guids[FMvidIdx-1];\r\nend;\r\n\r\nfunction TJclClrTableModuleRow.GetEncId: TGUID;\r\nbegin\r\n Result := Table.Stream.Metadata.Guids[FEncIdIdx-1];\r\nend;\r\n\r\nfunction TJclClrTableModuleRow.GetEncBaseId: TGUID;\r\nbegin\r\n Result := Table.Stream.Metadata.Guids[FEncBaseIdIdx-1];\r\nend;\r\n\r\nfunction TJclClrTableModuleRow.DumpIL: string;\r\nbegin\r\n Result := '.module ' + Name + ' // MVID:' + JclGUIDToString(Mvid) + NativeLineBreak;\r\nend;\r\n\r\nfunction TJclClrTableModule.GetRow(const Idx: Integer): TJclClrTableModuleRow;\r\nbegin\r\n Result := TJclClrTableModuleRow(inherited GetRow(Idx));\r\nend;\r\n\r\nclass function TJclClrTableModule.TableRowClass: TJclClrTableRowClass;\r\nbegin\r\n Result := TJclClrTableModuleRow;\r\nend;\r\n\r\n//=== { TJclClrTableModuleRefRow } ===========================================\r\n\r\nconstructor TJclClrTableModuleRefRow.Create(const ATable: TJclClrTable);\r\nbegin\r\n inherited Create(ATable);\r\n FNameOffset := Table.ReadIndex(hkString);\r\nend;\r\n\r\nfunction TJclClrTableModuleRefRow.DumpIL: string;\r\nbegin\r\n Result := '.module extern ' + Name + NativeLineBreak;\r\nend;\r\n\r\nfunction TJclClrTableModuleRefRow.GetName: WideString;\r\nbegin\r\n Result := Table.Stream.Metadata.StringAt(FNameOffset);\r\nend;\r\n\r\nfunction TJclClrTableModuleRef.GetRow(const Idx: Integer): TJclClrTableModuleRefRow;\r\nbegin\r\n Result := TJclClrTableModuleRefRow(inherited GetRow(Idx));\r\nend;\r\n\r\nclass function TJclClrTableModuleRef.TableRowClass: TJclClrTableRowClass;\r\nbegin\r\n Result := TJclClrTableModuleRefRow;\r\nend;\r\n\r\n//=== { TJclClrTableAssemblyRow } ============================================\r\n\r\nconstructor TJclClrTableAssemblyRow.Create(const ATable: TJclClrTable);\r\nbegin\r\n inherited Create(ATable);\r\n\r\n FHashAlgId := Table.ReadDWord;\r\n\r\n FMajorVersion := Table.ReadWord;\r\n FMinorVersion := Table.ReadWord;\r\n FBuildNumber := Table.ReadWord;\r\n FRevisionNumber := Table.ReadWord;\r\n\r\n FFlagMask := Table.ReadDWord;\r\n\r\n FPublicKeyOffset := Table.ReadIndex(hkBlob);\r\n FNameOffset := Table.ReadIndex(hkString);\r\n FCultureOffset := Table.ReadIndex(hkString);\r\nend;\r\n\r\nfunction TJclClrTableAssemblyRow.GetCulture: WideString;\r\nbegin\r\n Result := Table.Stream.Metadata.StringAt(FCultureOffset);\r\nend;\r\n\r\nfunction TJclClrTableAssemblyRow.GetName: WideString;\r\nbegin\r\n Result := Table.Stream.Metadata.StringAt(FNameOffset);\r\nend;\r\n\r\nfunction TJclClrTableAssemblyRow.GetPublicKey: TJclClrBlobRecord;\r\nbegin\r\n Result := Table.Stream.Metadata.BlobAt(FPublicKeyOffset);\r\nend;\r\n\r\nfunction TJclClrTableAssemblyRow.GetVersion: string;\r\nbegin\r\n Result := FormatVersionString(FMajorVersion, FMinorVersion, FBuildNumber, FRevisionNumber);\r\nend;\r\n\r\nfunction TJclClrTableAssemblyRow.GetFlags: TJclClrAssemblyFlags;\r\nbegin\r\n Result := AssemblyFlags(FFlagMask);\r\nend;\r\n\r\nclass function TJclClrTableAssemblyRow.AssemblyFlags(const Flags: DWORD): TJclClrAssemblyFlags;\r\nvar\r\n AFlag: TJclClrAssemblyFlag;\r\nbegin\r\n Result := [];\r\n for AFlag := Low(TJclClrAssemblyFlag) to High(TJclClrAssemblyFlag) do\r\n if (Flags and ClrAssemblyFlagMapping[AFlag]) = ClrAssemblyFlagMapping[AFlag] then\r\n Include(Result, AFlag);\r\nend;\r\n\r\nclass function TJclClrTableAssemblyRow.AssemblyFlags(const Flags: TJclClrAssemblyFlags): DWORD;\r\nvar\r\n AFlag: TJclClrAssemblyFlag;\r\nbegin\r\n Result := 0;\r\n for AFlag := Low(TJclClrAssemblyFlag) to High(TJclClrAssemblyFlag) do\r\n if AFlag in Flags then\r\n Result := Result or ClrAssemblyFlagMapping[AFlag];\r\nend;\r\n\r\nfunction TJclClrTableAssemblyRow.DumpIL: string;\r\nvar\r\n I: Integer;\r\n TblCustomAttribute: TJclClrTableCustomAttribute;\r\nbegin\r\n with TStringList.Create do\r\n try\r\n Add(Format('.assembly /*%.8x*/ %s', [Token, Name]));\r\n Add('{');\r\n\r\n if Table.Stream.FindTable(ttCustomAttribute, TJclClrTable(TblCustomAttribute)) then\r\n for I := 0 to TblCustomAttribute.RowCount-1 do\r\n if TblCustomAttribute.Rows[I].Parent = Self then\r\n Add(' ' + TblCustomAttribute.Rows[I].DumpIL);\r\n\r\n if FPublicKeyOffset <> 0 then\r\n Add(PublicKey.Dump(' .publickey = '));\r\n\r\n Add(' .hash algorithm 0x' + IntToHex(HashAlgId, 8));\r\n\r\n if FCultureOffset <> 0 then\r\n Add(' .culture \"' + Culture + '\"');\r\n\r\n Add(' .ver ' + Version);\r\n Add('}');\r\n Result := Text;\r\n finally\r\n Free;\r\n end;\r\nend;\r\n\r\nfunction TJclClrTableAssembly.GetRow(const Idx: Integer): TJclClrTableAssemblyRow;\r\nbegin\r\n Result := TJclClrTableAssemblyRow(inherited GetRow(Idx));\r\nend;\r\n\r\nclass function TJclClrTableAssembly.TableRowClass: TJclClrTableRowClass;\r\nbegin\r\n Result := TJclClrTableAssemblyRow;\r\nend;\r\n\r\n//=== { TJclClrTableAssemblyOSRow } ==========================================\r\n\r\nconstructor TJclClrTableAssemblyOSRow.Create(const ATable: TJclClrTable);\r\nbegin\r\n inherited Create(ATable);\r\n\r\n FPlatformID := Table.ReadDWord;\r\n FMajorVersion := Table.ReadDWord;\r\n FMinorVersion := Table.ReadDWord;\r\nend;\r\n\r\nfunction TJclClrTableAssemblyOSRow.GetVersion: string;\r\nbegin\r\n Result := FormatVersionString(FMajorVersion, FMinorVersion);\r\nend;\r\n\r\nfunction TJclClrTableAssemblyOS.GetRow(const Idx: Integer): TJclClrTableAssemblyOSRow;\r\nbegin\r\n Result := TJclClrTableAssemblyOSRow(inherited GetRow(Idx));\r\nend;\r\n\r\nclass function TJclClrTableAssemblyOS.TableRowClass: TJclClrTableRowClass;\r\nbegin\r\n Result := TJclClrTableAssemblyOSRow;\r\nend;\r\n\r\n//=== { TJclClrTableAssemblyProcessorRow } ===================================\r\n\r\nconstructor TJclClrTableAssemblyProcessorRow.Create(const ATable: TJclClrTable);\r\nbegin\r\n inherited Create(ATable);\r\n FProcessor := Table.ReadDWord;\r\nend;\r\n\r\nfunction TJclClrTableAssemblyProcessor.GetRow(const Idx: Integer): TJclClrTableAssemblyProcessorRow;\r\nbegin\r\n Result := TJclClrTableAssemblyProcessorRow(inherited GetRow(Idx));\r\nend;\r\n\r\nclass function TJclClrTableAssemblyProcessor.TableRowClass: TJclClrTableRowClass;\r\nbegin\r\n Result := TJclClrTableAssemblyProcessorRow;\r\nend;\r\n\r\n//=== { TJclClrTableAssemblyRefRow } =========================================\r\n\r\nconstructor TJclClrTableAssemblyRefRow.Create(const ATable: TJclClrTable);\r\nbegin\r\n inherited Create(ATable);\r\n\r\n FMajorVersion := Table.ReadWord;\r\n FMinorVersion := Table.ReadWord;\r\n FBuildNumber := Table.ReadWord;\r\n FRevisionNumber := Table.ReadWord;\r\n\r\n FFlagMask := Table.ReadDWord;\r\n\r\n FPublicKeyOrTokenOffset := Table.ReadIndex(hkBlob);\r\n FNameOffset := Table.ReadIndex(hkString);\r\n FCultureOffset := Table.ReadIndex(hkString);\r\n FHashValueOffset := Table.ReadIndex(hkBlob);\r\nend;\r\n\r\nfunction TJclClrTableAssemblyRefRow.DumpIL: string;\r\nvar\r\n I: Integer;\r\n TblCustomAttribute: TJclClrTableCustomAttribute;\r\n\r\n function DumpPublicKey: string;\r\n var\r\n I: Integer;\r\n Pch: PChar;\r\n HexStr, AsciiStr: string;\r\n begin\r\n Pch := PChar(PublicKeyOrToken.Memory);\r\n HexStr := '';\r\n AsciiStr := '';\r\n for I := 0 to PublicKeyOrToken.Size do\r\n begin\r\n HexStr := HexStr + IntToHex(Integer(Pch[I]), 2) + ' ';\r\n if CharIsAlphaNum(Pch[I]) then\r\n AsciiStr := AsciiStr + Pch[I]\r\n else\r\n AsciiStr := AsciiStr + '.';\r\n end;\r\n Result := '(' + HexStr + ') // ' + AsciiStr;\r\n end;\r\n\r\nbegin\r\n with TStringList.Create do\r\n try\r\n Add(Format('.assembly extern /*%.8x*/ %s', [Token, Name]));\r\n Add('{');\r\n\r\n if Table.Stream.FindTable(ttCustomAttribute, TJclClrTable(TblCustomAttribute)) then\r\n for I := 0 to TblCustomAttribute.RowCount-1 do\r\n if TblCustomAttribute.Rows[I].Parent = Self then\r\n Add(' ' + TblCustomAttribute.Rows[I].DumpIL);\r\n\r\n if Assigned(HashValue) then\r\n Add(PublicKeyOrToken.Dump(' .hash = '));\r\n\r\n if Assigned(PublicKeyOrToken) then\r\n Add(PublicKeyOrToken.Dump(' .publickeytoken = '));\r\n\r\n if FCultureOffset <> 0 then\r\n Add(' .culture \"' + Culture + '\"');\r\n\r\n Add(' .ver ' + Version);\r\n Add('}');\r\n Result := Text;\r\n finally\r\n Free;\r\n end;\r\nend;\r\n\r\nfunction TJclClrTableAssemblyRefRow.GetCulture: WideString;\r\nbegin\r\n Result := Table.Stream.Metadata.StringAt(FCultureOffset);\r\nend;\r\n\r\nfunction TJclClrTableAssemblyRefRow.GetFlags: TJclClrAssemblyFlags;\r\nbegin\r\n Result := TJclClrTableAssemblyRow.AssemblyFlags(FFlagMask);\r\nend;\r\n\r\nfunction TJclClrTableAssemblyRefRow.GetHashValue: TJclClrBlobRecord;\r\nbegin\r\n Result := Table.Stream.Metadata.BlobAt(FHashValueOffset);\r\nend;\r\n\r\nfunction TJclClrTableAssemblyRefRow.GetName: WideString;\r\nbegin\r\n Result := Table.Stream.Metadata.StringAt(FNameOffset);\r\nend;\r\n\r\nfunction TJclClrTableAssemblyRefRow.GetPublicKeyOrToken: TJclClrBlobRecord;\r\nbegin\r\n Result := Table.Stream.Metadata.BlobAt(FPublicKeyOrTokenOffset);\r\nend;\r\n\r\nfunction TJclClrTableAssemblyRefRow.GetVersion: string;\r\nbegin\r\n Result := FormatVersionString(FMajorVersion, FMinorVersion, FBuildNumber, FRevisionNumber);\r\nend;\r\n\r\nfunction TJclClrTableAssemblyRef.GetRow(const Idx: Integer): TJclClrTableAssemblyRefRow;\r\nbegin\r\n Result := TJclClrTableAssemblyRefRow(inherited GetRow(Idx));\r\nend;\r\n\r\nclass function TJclClrTableAssemblyRef.TableRowClass: TJclClrTableRowClass;\r\nbegin\r\n Result := TJclClrTableAssemblyRefRow;\r\nend;\r\n\r\n//=== { TJclClrTableAssemblyRefOSRow } =======================================\r\n\r\nconstructor TJclClrTableAssemblyRefOSRow.Create(const ATable: TJclClrTable);\r\nbegin\r\n inherited Create(ATable);\r\n FAssemblyRefIdx := Table.ReadIndex([ttAssemblyRef]);\r\nend;\r\n\r\nfunction TJclClrTableAssemblyRefOSRow.GetAssemblyRef: TJclClrTableAssemblyRefRow;\r\nvar\r\n AssemblyRefTable: TJclClrTableAssemblyRef;\r\nbegin\r\n if Table.Stream.FindTable(ttAssemblyRef, TJclClrTable(AssemblyRefTable)) then\r\n Result := AssemblyRefTable[FAssemblyRefIdx-1]\r\n else\r\n Result := nil;\r\nend;\r\n\r\nfunction TJclClrTableAssemblyRefOS.GetRow(const Idx: Integer): TJclClrTableAssemblyRefOSRow;\r\nbegin\r\n Result := TJclClrTableAssemblyRefOSRow(inherited GetRow(Idx));\r\nend;\r\n\r\nclass function TJclClrTableAssemblyRefOS.TableRowClass: TJclClrTableRowClass;\r\nbegin\r\n Result := TJclClrTableAssemblyRefOSRow;\r\nend;\r\n\r\n//=== { TJclClrTableAssemblyRefProcessorRow } ================================\r\n\r\nconstructor TJclClrTableAssemblyRefProcessorRow.Create(const ATable: TJclClrTable);\r\nbegin\r\n inherited Create(ATable);\r\n FAssemblyRefIdx := Table.ReadIndex([ttAssemblyRef]);\r\nend;\r\n\r\nfunction TJclClrTableAssemblyRefProcessorRow.GetAssemblyRef: TJclClrTableAssemblyRefRow;\r\nvar\r\n AssemblyRefTable: TJclClrTableAssemblyRef;\r\nbegin\r\n if Table.Stream.FindTable(ttAssemblyRef, TJclClrTable(AssemblyRefTable)) then\r\n Result := AssemblyRefTable[FAssemblyRefIdx-1]\r\n else\r\n Result := nil;\r\nend;\r\n\r\nfunction TJclClrTableAssemblyRefProcessor.GetRow(\r\n const Idx: Integer): TJclClrTableAssemblyRefProcessorRow;\r\nbegin\r\n Result := TJclClrTableAssemblyRefProcessorRow(inherited GetRow(Idx));\r\nend;\r\n\r\nclass function TJclClrTableAssemblyRefProcessor.TableRowClass: TJclClrTableRowClass;\r\nbegin\r\n Result := TJclClrTableAssemblyRefProcessorRow;\r\nend;\r\n\r\n//=== { TJclClrTableClassLayoutRow } =========================================\r\n\r\nconstructor TJclClrTableClassLayoutRow.Create(const ATable: TJclClrTable);\r\nbegin\r\n inherited Create(ATable);\r\n FPackingSize := Table.ReadWord;\r\n FClassSize := Table.ReadDWord;\r\n FParentIdx := Table.ReadIndex([ttTypeDef]);\r\nend;\r\n\r\nfunction TJclClrTableClassLayout.GetRow(const Idx: Integer): TJclClrTableClassLayoutRow;\r\nbegin\r\n Result := TJclClrTableClassLayoutRow(inherited GetRow(Idx));\r\nend;\r\n\r\nclass function TJclClrTableClassLayout.TableRowClass: TJclClrTableRowClass;\r\nbegin\r\n Result := TJclClrTableClassLayoutRow;\r\nend;\r\n\r\n//=== { TJclClrTableConstantRow } ============================================\r\n\r\nconstructor TJclClrTableConstantRow.Create(const ATable: TJclClrTable);\r\nbegin\r\n inherited Create(ATable);\r\n FKind := Table.ReadByte;\r\n Table.ReadByte; // padding zero\r\n FParentIdx := Table.ReadIndex([ttParamDef, ttFieldDef, ttPropertyDef]);\r\n FValueOffset := Table.ReadIndex(hkBlob);\r\nend;\r\n\r\nfunction TJclClrTableConstantRow.DumpIL: string;\r\nbegin\r\n case ElementType of\r\n etBoolean:\r\n Result := BooleanToStr(Boolean(PBoolean(Value.Memory)^));\r\n etChar:\r\n Result := PWideChar(Value.Memory)^;\r\n etI1:\r\n Result := IntToStr(PShortInt(Value.Memory)^);\r\n etU1:\r\n Result := IntToStr(PByte(Value.Memory)^);\r\n etI2:\r\n Result := IntToStr(PSmallint(Value.Memory)^);\r\n etU2:\r\n Result := IntToStr(PWord(Value.Memory)^);\r\n etI4:\r\n Result := IntToStr(PInteger(Value.Memory)^);\r\n etU4:\r\n Result := IntToStr(PDWORD(Value.Memory)^);\r\n etI8:\r\n Result := IntToStr(PInt64(Value.Memory)^);\r\n etU8:\r\n Result := IntToStr(PInt64(Value.Memory)^);\r\n etR4:\r\n Result := FloatToStr(PSingle(Value.Memory)^);\r\n etR8:\r\n Result := FloatToStr(PDouble(Value.Memory)^);\r\n etString:\r\n Result := '\"' + WideCharLenToString(PWideChar(Value.Memory), Value.Size div 2) + '\"';\r\n etClass:\r\n begin\r\n if FValueOffset = 0 then\r\n begin\r\n Result := ' nullref';\r\n Exit;\r\n end;\r\n\r\n Result := Table.Stream.Metadata.Tokens[PJclClrToken(Value.Memory)^].DumpIL;\r\n end;\r\n end;\r\n Result := ' = ' + Result;\r\nend;\r\n\r\nfunction TJclClrTableConstantRow.GetElementType: TJclClrElementType;\r\nbegin\r\n for Result := Low(TJclClrElementType) to High(TJclClrElementType) do\r\n if ClrElementTypeMapping[Result] = FKind then\r\n Exit;\r\n Result := etEnd;\r\nend;\r\n\r\nfunction TJclClrTableConstantRow.GetParent: TJclClrTableRow;\r\nconst\r\n HasConstantMapping: array [0..2] of TJclClrTableKind =\r\n (ttFieldDef, ttParamDef, ttPropertyDef);\r\nbegin\r\n Assert(FParentIdx and 3 <> 3);\r\n Result := Table.Stream.Tables[HasConstantMapping[FParentIdx and 3]].Rows[FParentIdx shr 2 - 1];\r\nend;\r\n\r\nfunction TJclClrTableConstantRow.GetValue: TJclClrBlobRecord;\r\nbegin\r\n Result := Table.Stream.Metadata.BlobAt(FValueOffset);\r\nend;\r\n\r\nfunction TJclClrTableConstant.GetRow(const Idx: Integer): TJclClrTableConstantRow;\r\nbegin\r\n Result := TJclClrTableConstantRow(inherited GetRow(Idx));\r\nend;\r\n\r\nclass function TJclClrTableConstant.TableRowClass: TJclClrTableRowClass;\r\nbegin\r\n Result := TJclClrTableConstantRow;\r\nend;\r\n\r\n//=== { TJclClrTableCustomAttributeRow } =====================================\r\n\r\nconstructor TJclClrTableCustomAttributeRow.Create(const ATable: TJclClrTable);\r\nbegin\r\n inherited Create(ATable);\r\n FParentIdx := Table.ReadIndex([ttModule, ttTypeRef, ttTypeDef, ttFieldDef,\r\n ttMethodDef, ttParamDef, ttInterfaceImpl, ttMemberRef, ttConstant,\r\n ttFieldMarshal, ttDeclSecurity, ttClassLayout, ttFieldLayout, ttSignature,\r\n ttEventMap, ttEventDef, ttPropertyMap, ttPropertyDef, ttMethodSemantics,\r\n ttMethodImpl, ttModuleRef, ttTypeSpec, ttImplMap, ttFieldRVA, ttAssembly,\r\n ttAssemblyProcessor, ttAssemblyOS, ttAssemblyRef, ttAssemblyRefProcessor,\r\n ttAssemblyRefOS, ttFile, ttExportedType, ttManifestResource, ttNestedClass]);\r\n FTypeIdx := Table.ReadIndex([ttMethodDef, ttMemberRef]);\r\n FValueOffset := Table.ReadIndex(hkBlob);\r\nend;\r\n\r\nfunction TJclClrTableCustomAttributeRow.GetParent: TJclClrTableRow;\r\nconst\r\n MapTagToTable: array [0..18] of TJclClrTableKind =\r\n (ttMethodDef, ttFieldDef, ttTypeRef, ttTypeDef, ttParamDef, ttInterfaceImpl,\r\n ttMemberRef, ttModule, ttDeclSecurity, ttPropertyDef, ttEventDef, ttSignature,\r\n ttModuleRef, ttTypeSpec, ttAssembly, ttAssemblyRef, ttFile, ttExportedType,\r\n ttManifestResource);\r\nvar\r\n WideIndex: Boolean;\r\nbegin\r\n WideIndex := Table.IsWideIndex([ttModule, ttTypeRef, ttTypeDef, ttFieldDef,\r\n ttMethodDef, ttParamDef, ttInterfaceImpl, ttMemberRef, ttConstant,\r\n ttFieldMarshal, ttDeclSecurity, ttClassLayout, ttFieldLayout, ttSignature,\r\n ttEventMap, ttEventDef, ttPropertyMap, ttPropertyDef, ttMethodSemantics,\r\n ttMethodImpl, ttModuleRef, ttTypeSpec, ttImplMap, ttFieldRVA, ttAssembly,\r\n ttAssemblyProcessor, ttAssemblyOS, ttAssemblyRef, ttAssemblyRefProcessor,\r\n ttAssemblyRefOS, ttFile, ttExportedType, ttManifestResource, ttNestedClass]);\r\n\r\n Assert(Table.GetCodedIndexTag(FParentIdx, 5, WideIndex) <= 18);\r\n Result := Table.Stream.Tables[\r\n MapTagToTable[Table.GetCodedIndexTag(FParentIdx, 5, WideIndex)]].\r\n Rows[Table.GetCodedIndexValue(FParentIdx, 5, WideIndex)-1];\r\nend;\r\n\r\nfunction TJclClrTableCustomAttributeRow.GetMethod: TJclClrTableRow;\r\nconst\r\n MapTagToTable: array [2..3] of TJclClrTableKind = (ttMethodDef, ttMemberRef);\r\nvar\r\n WideIndex: Boolean;\r\nbegin\r\n WideIndex := Table.IsWideIndex([ttMethodDef, ttMemberRef]);\r\n Assert(Table.GetCodedIndexTag(FTypeIdx, 3, WideIndex) in [2, 3]);\r\n Result := Table.Stream.Tables[\r\n MapTagToTable[Table.GetCodedIndexTag(FTypeIdx, 3, WideIndex)]].\r\n Rows[Table.GetCodedIndexValue(FTypeIdx, 3, WideIndex)-1];\r\nend;\r\n\r\nfunction TJclClrTableCustomAttributeRow.GetValue: TJclClrBlobRecord;\r\nbegin\r\n Result := Table.Stream.Metadata.BlobAt(FValueOffset);\r\nend;\r\n\r\nfunction TJclClrTableCustomAttributeRow.DumpIL: string;\r\nbegin\r\n // .custom /*0C000001:0A00000C*/ intance void [mscorlib/* 23000001 */]System.Reflection.AssemblyInformationalVersionAttribute/* 0100001C */::.ctor(string) /* 0A00000C */ = ( 01 00 0A 31 2E 30 2E 33 37 30 35 2E 30 00 00 ) // ...1.0.3705.0..\r\n Result := Value.Dump(Format('.custom /*%.8x:%.8x*/ %s = ', [Token, Method.Token, Method.DumpIL]));\r\nend;\r\n\r\nfunction TJclClrTableCustomAttribute.GetRow(const Idx: Integer): TJclClrTableCustomAttributeRow;\r\nbegin\r\n Result := TJclClrTableCustomAttributeRow(inherited GetRow(Idx));\r\nend;\r\n\r\nclass function TJclClrTableCustomAttribute.TableRowClass: TJclClrTableRowClass;\r\nbegin\r\n Result := TJclClrTableCustomAttributeRow;\r\nend;\r\n\r\n//=== { TJclClrTableDeclSecurityRow } ========================================\r\n\r\nconstructor TJclClrTableDeclSecurityRow.Create(const ATable: TJclClrTable);\r\nbegin\r\n inherited Create(ATable);\r\n FAction := Table.ReadWord;\r\n FParentIdx := Table.ReadIndex([ttTypeDef, ttMethodDef, ttAssembly]);\r\n FPermissionSetOffset := Table.ReadIndex(hkBlob);\r\nend;\r\n\r\nfunction TJclClrTableDeclSecurity.GetRow(const Idx: Integer): TJclClrTableDeclSecurityRow;\r\nbegin\r\n Result := TJclClrTableDeclSecurityRow(inherited GetRow(Idx));\r\nend;\r\n\r\nclass function TJclClrTableDeclSecurity.TableRowClass: TJclClrTableRowClass;\r\nbegin\r\n Result := TJclClrTableDeclSecurityRow;\r\nend;\r\n\r\n//=== { TJclClrTableEventMapRow } ============================================\r\n\r\nconstructor TJclClrTableEventMapRow.Create(const ATable: TJclClrTable);\r\nbegin\r\n inherited Create(ATable);\r\n FParentIdx := Table.ReadIndex([ttTypeDef]);\r\n FEventListIdx := Table.ReadIndex([ttEventDef]);\r\nend;\r\n\r\nfunction TJclClrTableEventMap.GetRow(const Idx: Integer): TJclClrTableEventMapRow;\r\nbegin\r\n Result := TJclClrTableEventMapRow(inherited GetRow(Idx));\r\nend;\r\n\r\nclass function TJclClrTableEventMap.TableRowClass: TJclClrTableRowClass;\r\nbegin\r\n Result := TJclClrTableEventMapRow;\r\nend;\r\n\r\n//=== { TJclClrTableEventDefRow } ============================================\r\n\r\nconstructor TJclClrTableEventDefRow.Create(const ATable: TJclClrTable);\r\nbegin\r\n inherited Create(ATable);\r\n FEventFlags := Table.ReadWord;\r\n FNameOffset := Table.ReadIndex(hkString);\r\n FEventTypeIdx := Table.ReadIndex([ttTypeDef, ttTypeRef, ttTypeSpec]);\r\nend;\r\n\r\nfunction TJclClrTableEventDefRow.GetName: WideString;\r\nbegin\r\n Result := Table.Stream.Metadata.StringAt(FNameOffset);\r\nend;\r\n\r\nfunction TJclClrTableEventDef.GetRow(const Idx: Integer): TJclClrTableEventDefRow;\r\nbegin\r\n Result := TJclClrTableEventDefRow(inherited GetRow(Idx));\r\nend;\r\n\r\nclass function TJclClrTableEventDef.TableRowClass: TJclClrTableRowClass;\r\nbegin\r\n Result := TJclClrTableEventDefRow;\r\nend;\r\n\r\n//=== { TJclClrTableEventPtrRow } ============================================\r\n\r\nconstructor TJclClrTableEventPtrRow.Create(const ATable: TJclClrTable);\r\nbegin\r\n inherited Create(ATable);\r\n FEventIdx := Table.ReadIndex([ttEventDef]);\r\nend;\r\n\r\nfunction TJclClrTableEventPtrRow.GetEvent: TJclClrTableEventDefRow;\r\nbegin\r\n Result := TJclClrTableEventDef(Table.Stream.Tables[ttEventDef]).Rows[FEventIdx-1];\r\nend;\r\n\r\nfunction TJclClrTableEventPtr.GetRow(const Idx: Integer): TJclClrTableEventPtrRow;\r\nbegin\r\n Result := TJclClrTableEventPtrRow(inherited GetRow(Idx));\r\nend;\r\n\r\nclass function TJclClrTableEventPtr.TableRowClass: TJclClrTableRowClass;\r\nbegin\r\n Result := TJclClrTableEventPtrRow;\r\nend;\r\n\r\n//=== { TJclClrTableExportedTypeRow } ========================================\r\n\r\nconstructor TJclClrTableExportedTypeRow.Create(const ATable: TJclClrTable);\r\nbegin\r\n inherited Create(ATable);\r\n FFlags := Table.ReadDWord;\r\n FTypeDefIdx := Table.ReadDWord;\r\n FTypeNameOffset := Table.ReadIndex(hkString);\r\n FTypeNamespaceOffset := Table.ReadIndex(hkString);\r\n FImplementationIdx := Table.ReadIndex([ttFile, ttExportedType]);\r\nend;\r\n\r\nfunction TJclClrTableExportedTypeRow.GetTypeName: WideString;\r\nbegin\r\n Result := Table.Stream.Metadata.StringAt(FTypeNameOffset);\r\nend;\r\n\r\nfunction TJclClrTableExportedTypeRow.GetTypeNamespace: WideString;\r\nbegin\r\n Result := Table.Stream.Metadata.StringAt(FTypeNamespaceOffset);\r\nend;\r\n\r\nfunction TJclClrTableExportedType.GetRow(const Idx: Integer): TJclClrTableExportedTypeRow;\r\nbegin\r\n Result := TJclClrTableExportedTypeRow(inherited GetRow(Idx));\r\nend;\r\n\r\nclass function TJclClrTableExportedType.TableRowClass: TJclClrTableRowClass;\r\nbegin\r\n Result := TJclClrTableExportedTypeRow;\r\nend;\r\n\r\n//=== { TJclClrTableFieldDefRow } ============================================\r\n\r\nconstructor TJclClrTableFieldDefRow.Create(const ATable: TJclClrTable);\r\nbegin\r\n inherited Create(ATable);\r\n FFlags := Table.ReadWord;\r\n FNameOffset := Table.ReadIndex(hkString);\r\n FSignatureOffset := Table.ReadIndex(hkBlob);\r\n FParentToken := nil;\r\nend;\r\n\r\nfunction TJclClrTableFieldDefRow.DumpIL: string;\r\nconst\r\n StaticName: array [Boolean] of PChar =\r\n ('', 'static ');\r\n VisibilityName: array [TJclClrTableFieldDefVisibility] of PChar =\r\n ('', 'private', 'famandassem', 'assembly', 'family', 'famandassem', 'public');\r\nvar\r\n I: Integer;\r\n\r\n function DumpFlags: string;\r\n const\r\n FlagName: array [ffInitOnly..ffRTSpecialName] of PChar =\r\n ('initonly', 'literal', 'notserialized', 'specialname', '', 'rtspecialname');\r\n var\r\n AFlag: TJclClrTableFieldDefFlag;\r\n begin\r\n Result := '';\r\n for AFlag := Low(FlagName) to High(FlagName) do\r\n if AFlag in Flags then\r\n Result := Result + FlagName[AFlag] + ' ';\r\n end;\r\n\r\n function DumpSignature: string;\r\n begin\r\n with TJclClrSignature.Create(Signature) do\r\n try\r\n Result := UncompressFieldSignature;\r\n finally\r\n Free;\r\n end;\r\n end;\r\n\r\nbegin\r\n Result := Format('.field /*%.8x*/ %s%s %s%s %s', [Token,\r\n StaticName[ffStatic in Flags], VisibilityName[Visibility],\r\n DumpFlags, DumpSignature, Name]);\r\n\r\n if ffHasDefault in Flags then\r\n begin\r\n with TJclClrTableConstant(Table.Stream.Tables[ttConstant]) do\r\n for I := 0 to RowCount-1 do\r\n if Rows[I].Parent = Self then\r\n begin\r\n Result := Result + Rows[I].DumpIL;\r\n Break;\r\n end;\r\n end\r\n else\r\n if ffHasFieldRVA in Flags then\r\n begin\r\n { TODO : What to do? }\r\n end;\r\nend;\r\n\r\nfunction TJclClrTableFieldDefRow.GetName: WideString;\r\nbegin\r\n Result := Table.Stream.Metadata.StringAt(FNameOffset);\r\nend;\r\n\r\nfunction TJclClrTableFieldDefRow.GetSignature: TJclClrBlobRecord;\r\nbegin\r\n Result := Table.Stream.Metadata.BlobAt(FSignatureOffset);\r\nend;\r\n\r\nfunction TJclClrTableFieldDefRow.GetVisibility: TJclClrTableFieldDefVisibility;\r\nconst\r\n FieldVisibilityMapping: array [fdPrivateScope..fdPublic] of TJclClrTableFieldDefVisibility =\r\n (fvPrivateScope, fvPrivate, fvFamANDAssem, fvAssembly, fvFamily, fvFamORAssem, fvPublic);\r\nbegin\r\n Result := FieldVisibilityMapping[FFlags and fdFieldAccessMask];\r\nend;\r\n\r\nfunction TJclClrTableFieldDefRow.GetFlag: TJclClrTableFieldDefFlags;\r\nconst\r\n FieldFlagMapping: array [TJclClrTableFieldDefFlag] of Word =\r\n (fdStatic, fdInitOnly, fdLiteral, fdNotSerialized, fdSpecialName,\r\n fdPinvokeImpl, fdRTSpecialName, fdHasFieldMarshal, fdHasDefault, fdHasFieldRVA);\r\nvar\r\n AFlag: TJclClrTableFieldDefFlag;\r\nbegin\r\n Result := [];\r\n for AFlag := Low(TJclClrTableFieldDefFlag) to High(TJclClrTableFieldDefFlag) do\r\n if FFlags and FieldFlagMapping[AFlag] <> 0 then\r\n Include(Result, AFlag);\r\nend;\r\n\r\nprocedure TJclClrTableFieldDefRow.SetParentToken(const ARow: TJclClrTableTypeDefRow);\r\nbegin\r\n FParentToken := ARow;\r\nend;\r\n\r\nfunction TJclClrTableFieldDef.GetRow(const Idx: Integer): TJclClrTableFieldDefRow;\r\nbegin\r\n Result := TJclClrTableFieldDefRow(inherited GetRow(Idx));\r\nend;\r\n\r\nclass function TJclClrTableFieldDef.TableRowClass: TJclClrTableRowClass;\r\nbegin\r\n Result := TJclClrTableFieldDefRow;\r\nend;\r\n\r\n//=== { TJclClrTableFieldPtrRow } ============================================\r\n\r\nconstructor TJclClrTableFieldPtrRow.Create(const ATable: TJclClrTable);\r\nbegin\r\n inherited Create(ATable);\r\n FFieldIdx := Table.ReadIndex([ttFieldDef]);\r\nend;\r\n\r\nfunction TJclClrTableFieldPtrRow.GetField: TJclClrTableFieldDefRow;\r\nbegin\r\n Result := TJclClrTableFieldDef(Table.Stream.Tables[ttFieldDef]).Rows[FFieldIdx-1];\r\nend;\r\n\r\nfunction TJclClrTableFieldPtr.GetRow(const Idx: Integer): TJclClrTableFieldPtrRow;\r\nbegin\r\n Result := TJclClrTableFieldPtrRow(inherited GetRow(Idx));\r\nend;\r\n\r\nclass function TJclClrTableFieldPtr.TableRowClass: TJclClrTableRowClass;\r\nbegin\r\n Result := TJclClrTableFieldPtrRow;\r\nend;\r\n\r\n//=== { TJclClrTableFieldLayoutRow } =========================================\r\n\r\nconstructor TJclClrTableFieldLayoutRow.Create(const ATable: TJclClrTable);\r\nbegin\r\n inherited Create(ATable);\r\n FOffset := Table.ReadDWord;\r\n FFieldIdx := Table.ReadIndex([ttFieldDef]);\r\nend;\r\n\r\nfunction TJclClrTableFieldLayout.GetRow(\r\n const Idx: Integer): TJclClrTableFieldLayoutRow;\r\nbegin\r\n Result := TJclClrTableFieldLayoutRow(inherited GetRow(Idx));\r\nend;\r\n\r\nclass function TJclClrTableFieldLayout.TableRowClass: TJclClrTableRowClass;\r\nbegin\r\n Result := TJclClrTableFieldLayoutRow;\r\nend;\r\n\r\n//=== { TJclClrTableFieldMarshalRow } ========================================\r\n\r\nconstructor TJclClrTableFieldMarshalRow.Create(const ATable: TJclClrTable);\r\nbegin\r\n inherited Create(ATable);\r\n FParentIdx := Table.ReadIndex([ttFieldDef, ttParamDef]);\r\n FNativeTypeOffset := Table.ReadIndex(hkBlob);\r\nend;\r\n\r\nfunction TJclClrTableFieldMarshal.GetRow(\r\n const Idx: Integer): TJclClrTableFieldMarshalRow;\r\nbegin\r\n Result := TJclClrTableFieldMarshalRow(inherited GetRow(Idx));\r\nend;\r\n\r\nclass function TJclClrTableFieldMarshal.TableRowClass: TJclClrTableRowClass;\r\nbegin\r\n Result := TJclClrTableFieldMarshalRow;\r\nend;\r\n\r\n//=== { TJclClrTableFieldRVARow } ============================================\r\n\r\nconstructor TJclClrTableFieldRVARow.Create(const ATable: TJclClrTable);\r\nbegin\r\n inherited Create(ATable);\r\n FRVA := Table.ReadDWord;\r\n FFieldIdx := Table.ReadIndex([ttFieldDef]);\r\nend;\r\n\r\nfunction TJclClrTableFieldRVA.GetRow(const Idx: Integer): TJclClrTableFieldRVARow;\r\nbegin\r\n Result := TJclClrTableFieldRVARow(inherited GetRow(Idx));\r\nend;\r\n\r\nclass function TJclClrTableFieldRVA.TableRowClass: TJclClrTableRowClass;\r\nbegin\r\n Result := TJclClrTableFieldRVARow;\r\nend;\r\n\r\n//=== { TJclClrTableFileRow } ================================================\r\n\r\nconstructor TJclClrTableFileRow.Create(const ATable: TJclClrTable);\r\nbegin\r\n inherited Create(ATable);\r\n FFlags := Table.ReadDWord;\r\n FNameOffset := Table.ReadIndex(hkString);\r\n FHashValueOffset := Table.ReadIndex(hkBlob);\r\nend;\r\n\r\nfunction TJclClrTableFileRow.GetName: WideString;\r\nbegin\r\n Result := Table.Stream.Metadata.StringAt(FNameOffset);\r\nend;\r\n\r\nfunction TJclClrTableFileRow.GetHashValue: TJclClrBlobRecord;\r\nbegin\r\n Result := Table.Stream.Metadata.BlobAt(FHashValueOffset);\r\nend;\r\n\r\nfunction TJclClrTableFileRow.GetContainsMetadata: Boolean;\r\nconst\r\n ffContainsNoMetaData = $0001;\r\nbegin\r\n Result := (FFlags and ffContainsNoMetaData) = ffContainsNoMetaData;\r\nend;\r\n\r\nfunction TJclClrTableFileRow.DumpIL: string;\r\n\r\n function GetMetadataName: string;\r\n begin\r\n if not ContainsMetadata then\r\n Result := 'nometadata '\r\n end;\r\n\r\nbegin\r\n Result := HashValue.Dump('.file ' + GetMetadataName + Name + ' .hash = ');\r\nend;\r\n\r\nfunction TJclClrTableFile.GetRow(const Idx: Integer): TJclClrTableFileRow;\r\nbegin\r\n Result := TJclClrTableFileRow(inherited GetRow(Idx));\r\nend;\r\n\r\nclass function TJclClrTableFile.TableRowClass: TJclClrTableRowClass;\r\nbegin\r\n Result := TJclClrTableFileRow;\r\nend;\r\n\r\n//=== { TJclClrTableImplMapRow } =============================================\r\n\r\nconstructor TJclClrTableImplMapRow.Create(const ATable: TJclClrTable);\r\nbegin\r\n inherited Create(ATable);\r\n FMappingFlags := Table.ReadWord;\r\n FMemberForwardedIdx := Table.ReadIndex([ttFieldDef, ttMethodDef]);\r\n FImportNameOffset := Table.ReadIndex(hkString);\r\n FImportScopeIdx := Table.ReadIndex([ttModuleRef]);\r\nend;\r\n\r\nfunction TJclClrTableImplMapRow.GetImportName: WideString;\r\nbegin\r\n Result := Table.Stream.Metadata.StringAt(FImportNameOffset);\r\nend;\r\n\r\nfunction TJclClrTableImplMap.GetRow(const Idx: Integer): TJclClrTableImplMapRow;\r\nbegin\r\n Result := TJclClrTableImplMapRow(inherited GetRow(Idx));\r\nend;\r\n\r\nclass function TJclClrTableImplMap.TableRowClass: TJclClrTableRowClass;\r\nbegin\r\n Result := TJclClrTableImplMapRow;\r\nend;\r\n\r\n//=== { TJclClrTableInterfaceImplRow } =======================================\r\n\r\nconstructor TJclClrTableInterfaceImplRow.Create(const ATable: TJclClrTable);\r\nbegin\r\n inherited Create(ATable);\r\n FClassIdx := Table.ReadIndex([ttTypeDef]);\r\n FInterfaceIdx := Table.ReadIndex([ttTypeDef, ttTypeRef, ttTypeSpec]);\r\nend;\r\n\r\nfunction TJclClrTableInterfaceImplRow.DumpIL: string;\r\nbegin\r\n if ImplInterface is TJclClrTableTypeRefRow then\r\n Result := TJclClrTableTypeRefRow(ImplInterface).DumpIL\r\n else\r\n if ImplInterface is TJclClrTableTypeDefRow then\r\n with TJclClrTableTypeDefRow(ImplInterface) do\r\n Result := Format('%s.%s/*%.8x*/', [Namespace, Name, Token])\r\n else\r\n Result := 'Unknown';\r\nend;\r\n\r\nfunction TJclClrTableInterfaceImplRow.GetImplClass: TJclClrTableRow;\r\nbegin\r\n Result := Table.Stream.Metadata.Tokens[FClassIdx];\r\nend;\r\n\r\nfunction TJclClrTableInterfaceImplRow.GetImplInterface: TJclClrTableRow;\r\nbegin\r\n Result := DecodeTypeDefOrRef(FInterfaceIdx);\r\nend;\r\n\r\nfunction TJclClrTableInterfaceImpl.GetRow(\r\n const Idx: Integer): TJclClrTableInterfaceImplRow;\r\nbegin\r\n Result := TJclClrTableInterfaceImplRow(inherited GetRow(Idx));\r\nend;\r\n\r\nclass function TJclClrTableInterfaceImpl.TableRowClass: TJclClrTableRowClass;\r\nbegin\r\n Result := TJclClrTableInterfaceImplRow;\r\nend;\r\n\r\n//=== { TJclClrTableManifestResourceRow } ====================================\r\n\r\nconstructor TJclClrTableManifestResourceRow.Create(const ATable: TJclClrTable);\r\nbegin\r\n inherited Create(ATable);\r\n FOffset := Table.ReadDWord;\r\n FFlags := Table.ReadDWord;\r\n FNameOffset := Table.ReadIndex(hkString);\r\n FImplementationIdx := Table.ReadIndex([ttFile, ttAssemblyRef]);\r\nend;\r\n\r\nfunction TJclClrTableManifestResourceRow.DumpIL: string;\r\nconst\r\n VisibilityName: array [TJclClrTableManifestResourceVisibility] of PChar =\r\n ('public', 'private');\r\nvar\r\n I: Integer;\r\n TblCustomAttribute: TJclClrTableCustomAttribute;\r\nbegin\r\n with TStringList.Create do\r\n try\r\n Add(Format('.mresource /*%.8x*/ %s %s', [Token, VisibilityName[Visibility], Name]));\r\n Add('(');\r\n\r\n if Table.Stream.FindTable(ttCustomAttribute, TJclClrTable(TblCustomAttribute)) then\r\n for I := 0 to TblCustomAttribute.RowCount-1 do\r\n if TblCustomAttribute.Rows[I].Parent = Self then\r\n Add(' ' + TblCustomAttribute.Rows[I].DumpIL);\r\n\r\n if FImplementationIdx <> 0 then\r\n if ImplementationRow is TJclClrTableAssemblyRefRow then\r\n Add(' .assembly extern ' +\r\n TJclClrTableAssemblyRefRow(ImplementationRow).Name)\r\n else\r\n Add(Format(' .file %s at %d',\r\n [TJclClrTableFileRow(ImplementationRow).Name, Offset]));\r\n Add(')');\r\n Result := Text;\r\n finally\r\n Free;\r\n end;\r\nend;\r\n\r\nfunction TJclClrTableManifestResourceRow.GetImplementationRow: TJclClrTableRow;\r\nbegin\r\n Result := Table.Stream.Metadata.Tokens[FImplementationIdx];\r\nend;\r\n\r\nfunction TJclClrTableManifestResourceRow.GetName: WideString;\r\nbegin\r\n Result := Table.Stream.Metadata.StringAt(FNameOffset);\r\nend;\r\n\r\nfunction TJclClrTableManifestResourceRow.GetVisibility: TJclClrTableManifestResourceVisibility;\r\nbegin\r\n for Result := Low(TJclClrTableManifestResourceVisibility) to High(TJclClrTableManifestResourceVisibility) do\r\n if (FFlags and mrVisibilityMask) = ManifestResourceVisibilityMapping[Result] then\r\n Exit;\r\n raise EJclMetadataError.CreateResFmt(@RsUnknownManifestResource, [FFlags and mrVisibilityMask]);\r\nend;\r\n\r\nfunction TJclClrTableManifestResource.GetRow(\r\n const Idx: Integer): TJclClrTableManifestResourceRow;\r\nbegin\r\n Result := TJclClrTableManifestResourceRow(inherited GetRow(Idx));\r\nend;\r\n\r\nclass function TJclClrTableManifestResource.TableRowClass: TJclClrTableRowClass;\r\nbegin\r\n Result := TJclClrTableManifestResourceRow;\r\nend;\r\n\r\n//=== { TJclClrTableMemberRefRow } ===========================================\r\n\r\nconstructor TJclClrTableMemberRefRow.Create(const ATable: TJclClrTable);\r\nbegin\r\n inherited Create(ATable);\r\n FClassIdx := Table.ReadIndex([ttTypeRef, ttModuleRef, ttMethodDef, ttTypeSpec, ttTypeDef]);\r\n FNameOffset := Table.ReadIndex(hkString);\r\n FSignatureOffset := Table.ReadIndex(hkBlob);\r\nend;\r\n\r\nfunction TJclClrTableMemberRefRow.GetName: WideString;\r\nbegin\r\n Result := Table.Stream.Metadata.StringAt(FNameOffset);\r\nend;\r\n\r\nfunction TJclClrTableMemberRefRow.GetSignature: TJclClrBlobRecord;\r\nbegin\r\n Result := Table.Stream.Metadata.BlobAt(FSignatureOffset);\r\nend;\r\n\r\nfunction TJclClrTableMemberRefRow.GetParentClass: TJclClrTableRow;\r\nconst\r\n MapTagToTable: array [1..5] of TJclClrTableKind =\r\n (ttTypeRef, ttModuleRef, ttMethodDef, ttTypeSpec, ttTypeDef);\r\nvar\r\n WideIndex: Boolean;\r\nbegin\r\n WideIndex := Table.IsWideIndex([ttTypeRef, ttModuleRef, ttMethodDef, ttTypeSpec, ttTypeDef]);\r\n Assert(Table.GetCodedIndexTag(FClassIdx, 3, WideIndex) in [1..5]);\r\n Result := Table.Stream.Tables[\r\n MapTagToTable[Table.GetCodedIndexTag(FClassIdx, 3, WideIndex)]].\r\n Rows[Table.GetCodedIndexValue(FClassIdx, 3, WideIndex)-1];\r\nend;\r\n\r\nfunction TJclClrTableMemberRefRow.GetFullName: WideString;\r\nvar\r\n Row: TJclClrTableRow;\r\nbegin\r\n Row := GetParentClass;\r\n\r\n if Row is TJclClrTableTypeRefRow then\r\n Result := TJclClrTableTypeRefRow(Row).FullName\r\n else\r\n if Row is TJclClrTableModuleRow then\r\n Result := TJclClrTableModuleRow(Row).Name\r\n else\r\n if Row is TJclClrTableMethodDefRow then\r\n Result := TJclClrTableMethodDefRow(Row).FullName\r\n else\r\n if Row is TJclClrTableTypeSpecRow then\r\n Result := ''\r\n else\r\n if Row is TJclClrTableTypeDefRow then\r\n Result := TJclClrTableTypeDefRow(Row).FullName;\r\n\r\n Result := Result + '.' + Name;\r\nend;\r\n\r\nfunction TJclClrTableMemberRef.GetRow(const Idx: Integer): TJclClrTableMemberRefRow;\r\nbegin\r\n Result := TJclClrTableMemberRefRow(inherited GetRow(Idx));\r\nend;\r\n\r\nclass function TJclClrTableMemberRef.TableRowClass: TJclClrTableRowClass;\r\nbegin\r\n Result := TJclClrTableMemberRefRow;\r\nend;\r\n\r\n//=== { TJclClrTableParamDefRow } ============================================\r\n\r\nconstructor TJclClrTableParamDefRow.Create(const ATable: TJclClrTable);\r\nbegin\r\n inherited Create(ATable);\r\n FFlagMask := Table.ReadWord;\r\n FSequence := Table.ReadWord;\r\n FNameOffset := Table.ReadIndex(hkString);\r\n\r\n FMethod := nil;\r\n FFlags := ParamFlags(FFlagMask);\r\nend;\r\n\r\nfunction TJclClrTableParamDefRow.GetName: WideString;\r\nbegin\r\n Result := Table.Stream.Metadata.StringAt(FNameOffset);\r\nend;\r\n\r\nprocedure TJclClrTableParamDefRow.SetMethod(const AMethod: TJclClrTableMethodDefRow);\r\nbegin\r\n FMethod := AMethod;\r\nend;\r\n\r\nclass function TJclClrTableParamDefRow.ParamFlags(const AFlags: TJclClrParamKinds): Word;\r\nvar\r\n AFlag: TJclClrParamKind;\r\nbegin\r\n Result := 0;\r\n for AFlag := Low(TJclClrParamKind) to High(TJclClrParamKind) do\r\n if AFlag in AFlags then\r\n Result := Result or ClrParamKindMapping[AFlag];\r\nend;\r\n\r\nclass function TJclClrTableParamDefRow.ParamFlags(const AFlags: Word): TJclClrParamKinds;\r\nvar\r\n AFlag: TJclClrParamKind;\r\nbegin\r\n Result := [];\r\n for AFlag := Low(TJclClrParamKind) to High(TJclClrParamKind) do\r\n if (AFlags and ClrParamKindMapping[AFlag]) = ClrParamKindMapping[AFlag] then\r\n Include(Result, AFlag);\r\nend;\r\n\r\nfunction TJclClrTableParamDefRow.DumpIL: string;\r\nbegin\r\n Result := '';\r\n { TODO : What to do? }\r\nend;\r\n\r\nfunction TJclClrTableParamDef.GetRow(const Idx: Integer): TJclClrTableParamDefRow;\r\nbegin\r\n Result := TJclClrTableParamDefRow(inherited GetRow(Idx));\r\nend;\r\n\r\nclass function TJclClrTableParamDef.TableRowClass: TJclClrTableRowClass;\r\nbegin\r\n Result := TJclClrTableParamDefRow;\r\nend;\r\n\r\n//=== { TJclClrTableParamPtrRow } ============================================\r\n\r\nconstructor TJclClrTableParamPtrRow.Create(const ATable: TJclClrTable);\r\nbegin\r\n inherited Create(ATable);\r\n FParamIdx := Table.ReadIndex([ttParamDef]);\r\nend;\r\n\r\nfunction TJclClrTableParamPtrRow.GetParam: TJclClrTableParamDefRow;\r\nbegin\r\n Result := TJclClrTableParamDef(Table.Stream.Tables[ttParamDef]).Rows[FParamIdx-1];\r\nend;\r\n\r\nfunction TJclClrTableParamPtr.GetRow(const Idx: Integer): TJclClrTableParamPtrRow;\r\nbegin\r\n Result := TJclClrTableParamPtrRow(inherited GetRow(Idx));\r\nend;\r\n\r\nclass function TJclClrTableParamPtr.TableRowClass: TJclClrTableRowClass;\r\nbegin\r\n Result := TJclClrTableParamPtrRow;\r\nend;\r\n\r\n//=== { TJclClrExceptionHandler } ============================================\r\n\r\nconst\r\n // Indicates the format for the COR_ILMETHOD header\r\n CorILMethod_FormatShift = 2;\r\n CorILMethod_FormatMask = ((1 shl CorILMethod_FormatShift) - 1);\r\n\r\n CorILMethod_TinyFormat = $0002;\r\n // CorILMethod_FatFormat = $0003;\r\n\r\n // CorILMethod_TinyFormatEven = $0002;\r\n // CorILMethod_TinyFormatOdd = $0006;\r\n\r\n // CorILMethod_InitLocals = $0010;\r\n CorILMethod_MoreSects = $0008;\r\n\r\n // CorILMethod_Sect_Reserved = 0;\r\n CorILMethod_Sect_EHTable = 1;\r\n CorILMethod_Sect_OptILTable = 2;\r\n\r\n // CorILMethod_Sect_KindMask = $3F; // The mask for decoding the type code\r\n CorILMethod_Sect_FatFormat = $40; // fat format\r\n CorILMethod_Sect_MoreSects = $80; // there is another attribute after this one\r\n\r\n COR_ILEXCEPTION_CLAUSE_NONE = $0000; // This is a typed handler\r\n // COR_ILEXCEPTION_CLAUSE_OFFSETLEN = $0000; // Deprecated\r\n // COR_ILEXCEPTION_CLAUSE_DEPRECATED = $0000; // Deprecated\r\n COR_ILEXCEPTION_CLAUSE_FILTER = $0001; // If this bit is on, then this EH entry is for a filter\r\n COR_ILEXCEPTION_CLAUSE_FINALLY = $0002; // This clause is a finally clause\r\n COR_ILEXCEPTION_CLAUSE_FAULT = $0004; // Fault clause (finally that is called on exception only)\r\n\r\n ExceptionClauseFlags: array [TJclClrExceptionClauseFlag] of DWORD =\r\n (COR_ILEXCEPTION_CLAUSE_NONE, COR_ILEXCEPTION_CLAUSE_FILTER,\r\n COR_ILEXCEPTION_CLAUSE_FINALLY, COR_ILEXCEPTION_CLAUSE_FAULT);\r\n\r\nconstructor TJclClrExceptionHandler.Create(const EHClause: TImageCorILMethodSectEHClauseSmall);\r\nbegin\r\n FFlags := EHClause.Flags;\r\n FTryBlock.Offset := EHClause.TryOffset;\r\n FTryBlock.Length := EHClause.TryLength;\r\n FHandlerBlock.Offset := EHClause.HandlerOffset;\r\n FHandlerBlock.Length := EHClause.HandlerLength;\r\n if (FFlags and COR_ILEXCEPTION_CLAUSE_FILTER) = COR_ILEXCEPTION_CLAUSE_FILTER then\r\n begin\r\n FClassToken := 0;\r\n FFilterOffset := EHClause.FilterOffset;\r\n end\r\n else\r\n begin\r\n FClassToken := EHClause.ClassToken;\r\n FFilterOffset := 0;\r\n end;\r\nend;\r\n\r\nconstructor TJclClrExceptionHandler.Create(const EHClause: TImageCorILMethodSectEHClauseFat);\r\nbegin\r\n FFlags := EHClause.Flags;\r\n FTryBlock.Offset := EHClause.TryOffset;\r\n FTryBlock.Length := EHClause.TryLength;\r\n FHandlerBlock.Offset := EHClause.HandlerOffset;\r\n FHandlerBlock.Length := EHClause.HandlerLength;\r\n if (FFlags and COR_ILEXCEPTION_CLAUSE_FILTER) = COR_ILEXCEPTION_CLAUSE_FILTER then\r\n begin\r\n FClassToken := 0;\r\n FFilterOffset := EHClause.FilterOffset;\r\n end\r\n else\r\n begin\r\n FClassToken := EHClause.ClassToken;\r\n FFilterOffset := 0;\r\n end;\r\nend;\r\n\r\nfunction TJclClrExceptionHandler.GetFlags: TJclClrExceptionClauseFlags;\r\nvar\r\n AFlag: TJclClrExceptionClauseFlag;\r\nbegin\r\n Result := [];\r\n for AFlag := Low(TJclClrExceptionClauseFlag) to High(TJclClrExceptionClauseFlag) do\r\n if (FFlags and ExceptionClauseFlags[AFlag]) = ExceptionClauseFlags[AFlag] then\r\n Include(Result, AFlag);\r\nend;\r\n\r\n//=== { TJclClrMethodBody } ==================================================\r\n\r\nconstructor TJclClrMethodBody.Create(const AMethod: TJclClrTableMethodDefRow);\r\nvar\r\n ILMethod: PImageCorILMethodHeader;\r\nbegin\r\n FMethod := AMethod;\r\n FEHTable := TObjectList.Create;\r\n\r\n FLocalVarSign := nil;\r\n\r\n ILMethod := FMethod.Table.Stream.Metadata.Image.RvaToVa(FMethod.RVA);\r\n if (ILMethod.Tiny.Flags_CodeSize and CorILMethod_FormatMask) = CorILMethod_TinyFormat then\r\n begin\r\n FSize := (ILMethod.Tiny.Flags_CodeSize shr CorILMethod_FormatShift) and ((1 shl 6) - 1);\r\n FCode := Pointer(TJclAddr(ILMethod) + 1);\r\n FMaxStack := 0;\r\n FLocalVarSignToken := 0;\r\n end\r\n else\r\n begin\r\n FSize := ILMethod.Fat.CodeSize;\r\n FCode := Pointer(TJclAddr(ILMethod) + (ILMethod.Fat.Flags_Size shr 12) * SizeOf(DWORD));\r\n FMaxStack := ILMethod.Fat.MaxStack;\r\n FLocalVarSignToken := ILMethod.Fat.LocalVarSigTok;\r\n\r\n if IsBitSet(ILMethod.Fat.Flags_Size, CorILMethod_MoreSects) then\r\n ParseMoreSections(Pointer((TJclAddr(FCode) + FSize + 1) and not 1));\r\n end;\r\nend;\r\n\r\ndestructor TJclClrMethodBody.Destroy;\r\nbegin\r\n FreeAndNil(FLocalVarSign);\r\n FreeAndNil(FEHTable);\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJclClrMethodBody.AddEHTable(EHTable: PImageCorILMethodSectEH);\r\nvar\r\n I, Count: Integer;\r\n FatFormat: Boolean;\r\nbegin\r\n FatFormat := IsBitSet( EHTable.Small.SectSmall.Kind, CorILMethod_Sect_FatFormat);\r\n if FatFormat then\r\n Count := ((EHTable.Fat.SectFat.Kind_DataSize shr 8) - SizeOf(DWORD)) div SizeOf(TImageCorILMethodSectEHClauseFat)\r\n else\r\n Count := (EHTable.Small.SectSmall.Datasize - SizeOf(DWORD)) div SizeOf(TImageCorILMethodSectEHClauseSmall);\r\n\r\n for I := 0 to Count-1 do\r\n begin\r\n if FatFormat then\r\n FEHTable.Add(TJclClrExceptionHandler.Create(EHTable.Fat.Clauses[I]))\r\n else\r\n FEHTable.Add(TJclClrExceptionHandler.Create(EHTable.Small.Clauses[I]));\r\n end;\r\nend;\r\n\r\nprocedure TJclClrMethodBody.AddOptILTable(OptILTable: Pointer; Size: Integer);\r\nbegin\r\n { TODO : What to do? }\r\nend;\r\n\r\nprocedure TJclClrMethodBody.ParseMoreSections(SectHeader: PImageCorILMethodSectHeader);\r\nvar\r\n SectSize: DWORD;\r\nbegin\r\n if IsBitSet(SectHeader.Small.Kind, CorILMethod_Sect_FatFormat) then\r\n SectSize := SectHeader.Fat.Kind_DataSize shr 8\r\n else\r\n SectSize := SectHeader.Small.Datasize;\r\n\r\n if IsBitSet(SectHeader.Small.Kind, CorILMethod_Sect_EHTable) then\r\n AddEHTable(PImageCorILMethodSectEH(SectHeader))\r\n else\r\n if IsBitSet(SectHeader.Small.Kind, CorILMethod_Sect_OptILTable) then\r\n AddOptILTable(Pointer(TJclAddr(FCode) + FSize), SectSize);\r\n\r\n if IsBitSet(SectHeader.Small.Kind, CorILMethod_Sect_MoreSects) then\r\n ParseMoreSections(Pointer(TJclAddr(SectHeader) + SectSize));\r\nend;\r\n\r\nfunction TJclClrMethodBody.GetExceptionHandler(const Idx: Integer): TJclClrExceptionHandler;\r\nbegin\r\n Result := TJclClrExceptionHandler(FEHTable.Items[Idx]);\r\nend;\r\n\r\nfunction TJclClrMethodBody.GetExceptionHandlerCount: Integer;\r\nbegin\r\n Result := FEHTable.Count;\r\nend;\r\n\r\nfunction TJclClrMethodBody.GetLocalVarSign: TJclClrLocalVarSign;\r\nbegin\r\n if not Assigned(FLocalVarSign) and (FLocalVarSignToken <> 0) then\r\n FLocalVarSign := TJclClrLocalVarSign.Create(LocalVarSignData);\r\n\r\n Result := FLocalVarSign;\r\nend;\r\n\r\nfunction TJclClrMethodBody.GetLocalVarSignData: TJclClrBlobRecord;\r\nbegin\r\n Result := TJclClrTableStandAloneSigRow(FMethod.Table.Stream.Metadata.Tokens[FLocalVarSignToken]).Signature;\r\nend;\r\n\r\n//=== { TJclClrTableMethodDefRow } ===========================================\r\n\r\nconstructor TJclClrTableMethodDefRow.Create(const ATable: TJclClrTable);\r\nbegin\r\n inherited Create(ATable);\r\n\r\n FRVA := Table.ReadDWord;\r\n FImplFlags := Table.ReadWord;\r\n FFlags := Table.ReadWord;\r\n FNameOffset := Table.ReadIndex(hkString);\r\n FSignatureOffset := Table.ReadIndex(hkBlob);\r\n FParamListIdx := Table.ReadIndex([ttParamDef]);\r\n\r\n FParentToken := nil;\r\n FParams := nil;\r\n FSignature := nil;\r\n\r\n if FRVA <> 0 then\r\n FMethodBody := TJclClrMethodBody.Create(Self)\r\n else\r\n FMethodBody := nil;\r\nend;\r\n\r\ndestructor TJclClrTableMethodDefRow.Destroy;\r\nbegin\r\n FreeAndNil(FParams);\r\n FreeAndNil(FSignature);\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJclClrTableMethodDefRow.GetName: WideString;\r\nbegin\r\n Result := Table.Stream.Metadata.StringAt(FNameOffset);\r\nend;\r\n\r\nfunction TJclClrTableMethodDefRow.GetSignatureData: TJclClrBlobRecord;\r\nbegin\r\n Result := Table.Stream.Metadata.BlobAt(FSignatureOffset);\r\nend;\r\n\r\nprocedure TJclClrTableMethodDefRow.SetParentToken(const ARow: TJclClrTableTypeDefRow);\r\nbegin\r\n FParentToken := ARow;\r\nend;\r\n\r\nprocedure TJclClrTableMethodDefRow.UpdateParams;\r\nvar\r\n ParamTable: TJclClrTableParamDef;\r\n Idx, MaxParamListIdx: DWORD;\r\nbegin\r\n with Table as TJclClrTableMethodDef do\r\n if not Assigned(FParams) and (ParamListIdx <> 0) and\r\n Stream.FindTable(ttParamDef, TJclClrTable(ParamTable)) then\r\n begin\r\n if RowCount > (Index+1) then\r\n MaxParamListIdx := Rows[Index+1].ParamListIdx-1\r\n else\r\n MaxParamListIdx := ParamTable.RowCount;\r\n if (ParamListIdx-1) < MaxParamListIdx then\r\n begin\r\n FParams := TList.Create;\r\n for Idx := ParamListIdx-1 to MaxParamListIdx-1 do\r\n begin\r\n FParams.Add(ParamTable.Rows[Idx]);\r\n ParamTable.Rows[Idx].SetMethod(Self);\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJclClrTableMethodDefRow.Update;\r\nbegin\r\n UpdateParams;\r\nend;\r\n\r\nfunction TJclClrTableMethodDefRow.GetHasParam: Boolean;\r\nbegin\r\n Result := Assigned(FParams);\r\nend;\r\n\r\nfunction TJclClrTableMethodDefRow.GetParam(const Idx: Integer): TJclClrTableParamDefRow;\r\nbegin\r\n Result := TJclClrTableParamDefRow(FParams.Items[Idx]);\r\nend;\r\n\r\nfunction TJclClrTableMethodDefRow.GetParamCount: Integer;\r\nbegin\r\n Result := FParams.Count;\r\nend;\r\n\r\nfunction TJclClrTableMethodDefRow.DumpIL: string;\r\nconst\r\n MemberAccessNames: array [TJclClrMemberAccess] of PChar =\r\n ('compilercontrolled', 'private', 'famandassem',\r\n 'assembly', 'family', 'famorassem', 'public');\r\n CodeTypeNames: array [TJclClrMethodCodeType] of PChar =\r\n ('cil', 'native', 'optil', 'runtime');\r\n ManagedNames: array [Boolean] of PChar =\r\n ('unmanaged', 'managed');\r\nvar\r\n I: Integer;\r\n\r\n function LocalVarToString(LocalVar: TJclClrLocalVar): string;\r\n var\r\n Row: TJclClrTableRow;\r\n begin\r\n case LocalVar.ElementType of\r\n etClass:\r\n if LocalVar.Token <> 0 then\r\n begin\r\n Row := Table.Stream.Metadata.Tokens[LocalVar.Token];\r\n if Row is TJclClrTableTypeDefRow then\r\n Result := TJclClrTableTypeDefRow(Row).FullName\r\n else\r\n if Row is TJclClrTableTypeRefRow then\r\n Result := TJclClrTableTypeRefRow(Row).FullName\r\n else\r\n if Row is TJclClrTableTypeSpecRow then\r\n Result := TJclClrTableTypeSpecRow(Row).Signature.Dump('')\r\n else\r\n Result := '/*' + IntToHex(Row.Token, 8) + '*/';\r\n end;\r\n else\r\n Result := LocalVar.Name;\r\n end;\r\n end;\r\n\r\n function GetMethodFlagDescription: string;\r\n const\r\n MethodFlagName: array [TJclClrMethodFlag] of PChar =\r\n ('static', 'final', 'virtual', 'hidebysig', '', 'abstract',\r\n 'specialname', 'pinvokeimpl', 'unmanagedexp', 'rtspecialname', '', '');\r\n var\r\n AFlag: TJclClrMethodFlag;\r\n begin\r\n Result := '';\r\n for AFlag := Low(TJclClrMethodFlag) to High(TJclClrMethodFlag) do\r\n if AFlag in MethodFlags then\r\n Result := Result + MethodFlagName[AFlag] + ' ';\r\n end;\r\n\r\n function GetMethodImplFlagDescription: string;\r\n const\r\n MethodImplFlagName: array [TJclClrMethodImplFlag] of PChar =\r\n ('forwardref', '', 'internalcall', 'synchronized', 'noinlining');\r\n var\r\n AFlag: TJclClrMethodImplFlag;\r\n begin\r\n Result := '';\r\n for AFlag := Low(TJclClrMethodImplFlag) to High(TJclClrMethodImplFlag) do\r\n if AFlag in MethodImplFlags then\r\n Result := Result + ' ' + MethodImplFlagName[AFlag];\r\n end;\r\n\r\n function GetParamTypeName(Param: TJclClrMethodParam): string;\r\n const\r\n BuildInTypeNames: array [etVoid..etString] of PChar =\r\n ('void', 'bool', 'char', 'sbyte', 'byte', 'short', 'ushort',\r\n 'int', 'uint', 'long', 'ulong', 'float', 'double', 'string');\r\n var\r\n Row: TJclClrTableRow;\r\n begin\r\n case Param.ElementType of\r\n etVoid, etBoolean, etChar,\r\n etI1, etU1, etI2, etU2, etI4, etU4,\r\n etI8, etU8, etR4, etR8, etString:\r\n Result := BuildInTypeNames[Param.ElementType];\r\n etI:\r\n Result := 'System.IntPtr';\r\n etU:\r\n Result := 'System.UIntPtr';\r\n etObject:\r\n Result := 'object';\r\n etClass:\r\n begin\r\n Row := Table.Stream.Metadata.Tokens[Param.Token];\r\n if Row is TJclClrTableTypeDefRow then\r\n Result := TJclClrTableTypeDefRow(Row).FullName\r\n else\r\n if Row is TJclClrTableTypeRefRow then\r\n Result := TJclClrTableTypeRefRow(Row).FullName;\r\n\r\n Result := Result + ' /* ' + IntToHex(Param.Token, 8) + ' */';\r\n end;\r\n etSzArray:\r\n Result := 'char *';\r\n end;\r\n if Param.ByRef then\r\n Result := 'ref ' + Result;\r\n end;\r\n\r\nbegin\r\n Result := Format('.method /*%.8x*/ %s %s%s %s(', [Token,\r\n MemberAccessNames[MemberAccess], GetMethodFlagDescription,\r\n GetParamTypeName(Signature.RetType), Name]);\r\n if HasParam then\r\n for I := 0 to Min(ParamCount, Signature.ParamCount)-1 do\r\n begin\r\n Result := Result + GetParamTypeName(Signature.Params[I]) + ' ' + Params[I].Name;\r\n if I <> ParamCount-1 then\r\n Result := Result + ', ';\r\n end;\r\n Result := Result + ') ' + CodeTypeNames[CodeType] + ' ' + ManagedNames[Managed] + GetMethodImplFlagDescription;\r\n\r\n if Assigned(MethodBody) then\r\n begin\r\n Result := Result + NativeLineBreak + '{' + NativeLineBreak +\r\n '.maxstack ' + IntToStr(MethodBody.MaxStack) + NativeLineBreak;\r\n\r\n if MethodBody.LocalVarSignToken <> 0 then\r\n begin\r\n Result := Result + '.locals /* ' + IntToHex(MethodBody.LocalVarSignToken, 8) + ' */ init(' + NativeLineBreak;\r\n for I := 0 to MethodBody.LocalVarSign.LocalVarCount-1 do\r\n begin\r\n Result := Format(Result+' %s V_%d', [LocalVarToString(MethodBody.LocalVarSign.LocalVars[I]), I]);\r\n if I = MethodBody.LocalVarSign.LocalVarCount-1 then\r\n Result := Result + ')' + NativeLineBreak\r\n else\r\n Result := Result + ',' + NativeLineBreak;\r\n end;\r\n end;\r\n\r\n with TJclClrILGenerator.Create(MethodBody) do\r\n try\r\n Result := Result + NativeLineBreak + DumpIL(InstructionDumpILAllOption);\r\n finally\r\n Free;\r\n end;\r\n Result := Result + '}';\r\n end;\r\nend;\r\n\r\nfunction TJclClrTableMethodDefRow.GetFullName: WideString;\r\nbegin\r\n Result := ParentToken.FullName + '.' + Name;\r\nend;\r\n\r\nfunction TJclClrTableMethodDefRow.GetSignature: TJclClrMethodSign;\r\nbegin\r\n if not Assigned(FSignature) then\r\n FSignature := TJclClrMethodSign.Create(SignatureData);\r\n Result := FSignature;\r\nend;\r\n\r\nfunction TJclClrTableMethodDefRow.GetMemberAccess: TJclClrMemberAccess;\r\nbegin\r\n Result := TJclClrMemberAccess(FFlags and mdMemberAccessMask)\r\nend;\r\n\r\nfunction TJclClrTableMethodDefRow.GetMethodFlags: TJclClrMethodFlags;\r\nvar\r\n AFlag: TJclClrMethodFlag;\r\nbegin\r\n Result := [];\r\n for AFlag := Low(TJclClrMethodFlag) to High(TJclClrMethodFlag) do\r\n if (FFlags and ClrMethodFlagMapping[AFlag]) = ClrMethodFlagMapping[AFlag] then\r\n Include(Result, AFlag);\r\nend;\r\n\r\nfunction TJclClrTableMethodDefRow.GetNewSlot: Boolean;\r\nbegin\r\n Result := (FFlags and mdVtableLayoutMask) = mdNewSlot;\r\nend;\r\n\r\nfunction TJclClrTableMethodDefRow.GetCodeType: TJclClrMethodCodeType;\r\nbegin\r\n Result := TJclClrMethodCodeType(FImplFlags and miCodeTypeMask);\r\nend;\r\n\r\nfunction TJclClrTableMethodDefRow.GetManaged: Boolean;\r\nbegin\r\n Result := (FImplFlags and miManagedMask) = miManaged;\r\nend;\r\n\r\nfunction TJclClrTableMethodDefRow.GetMethodImplFlags: TJclClrMethodImplFlags;\r\nvar\r\n AFlag: TJclClrMethodImplFlag;\r\nbegin\r\n Result := [];\r\n for AFlag := Low(TJclClrMethodImplFlag) to High(TJclClrMethodImplFlag) do\r\n if (FFlags and ClrMethodImplFlagMapping[AFlag]) = ClrMethodImplFlagMapping[AFlag] then\r\n Include(Result, AFlag);\r\nend;\r\n\r\nfunction TJclClrTableMethodDef.GetRow(const Idx: Integer): TJclClrTableMethodDefRow;\r\nbegin\r\n Result := TJclClrTableMethodDefRow(inherited GetRow(Idx));\r\nend;\r\n\r\nclass function TJclClrTableMethodDef.TableRowClass: TJclClrTableRowClass;\r\nbegin\r\n Result := TJclClrTableMethodDefRow;\r\nend;\r\n\r\n//=== { TJclClrTableMethodPtrRow } ===========================================\r\n\r\nconstructor TJclClrTableMethodPtrRow.Create(const ATable: TJclClrTable);\r\nbegin\r\n inherited Create(ATable);\r\n FMethodIdx := Table.ReadIndex([ttMethodDef]);\r\nend;\r\n\r\nfunction TJclClrTableMethodPtrRow.GetMethod: TJclClrTableMethodDefRow;\r\nbegin\r\n Result := TJclClrTableMethodDef(Table.Stream.Tables[ttMethodDef]).Rows[FMethodIdx-1];\r\nend;\r\n\r\nfunction TJclClrTableMethodPtr.GetRow(const Idx: Integer): TJclClrTableMethodPtrRow;\r\nbegin\r\n Result := TJclClrTableMethodPtrRow(inherited GetRow(Idx));\r\nend;\r\n\r\nclass function TJclClrTableMethodPtr.TableRowClass: TJclClrTableRowClass;\r\nbegin\r\n Result := TJclClrTableMethodPtrRow;\r\nend;\r\n\r\n//=== { TJclClrTableMethodImplRow } ==========================================\r\n\r\nconstructor TJclClrTableMethodImplRow.Create(const ATable: TJclClrTable);\r\nbegin\r\n inherited Create(ATable);\r\n FClassIdx := Table.ReadIndex([ttTypeDef]);\r\n FMethodBodyIdx := Table.ReadIndex([ttMethodDef, ttMemberRef]);\r\n FMethodDeclarationIdx := Table.ReadIndex([ttMethodDef, ttMemberRef]);\r\nend;\r\n\r\nfunction TJclClrTableMethodImpl.GetRow(\r\n const Idx: Integer): TJclClrTableMethodImplRow;\r\nbegin\r\n Result := TJclClrTableMethodImplRow(inherited GetRow(Idx));\r\nend;\r\n\r\nclass function TJclClrTableMethodImpl.TableRowClass: TJclClrTableRowClass;\r\nbegin\r\n Result := TJclClrTableMethodImplRow;\r\nend;\r\n\r\n//=== { TJclClrTableMethodSemanticsRow } =====================================\r\n\r\nconstructor TJclClrTableMethodSemanticsRow.Create(const ATable: TJclClrTable);\r\nbegin\r\n inherited Create(ATable);\r\n FSemantics := Table.ReadWord;\r\n FMethodIdx := Table.ReadIndex([ttMethodDef]);\r\n FAssociationIdx := Table.ReadIndex([ttEventDef, ttPropertyDef]);\r\nend;\r\n\r\nfunction TJclClrTableMethodSemantics.GetRow(const Idx: Integer): TJclClrTableMethodSemanticsRow;\r\nbegin\r\n Result := TJclClrTableMethodSemanticsRow(inherited GetRow(Idx));\r\nend;\r\n\r\nclass function TJclClrTableMethodSemantics.TableRowClass: TJclClrTableRowClass;\r\nbegin\r\n Result := TJclClrTableMethodSemanticsRow;\r\nend;\r\n\r\n//=== { TJclClrTableMethodSpecRow } ==========================================\r\n\r\nconstructor TJclClrTableMethodSpecRow.Create(const ATable: TJclClrTable);\r\nbegin\r\n inherited Create(ATable);\r\n FMethodIdx := Table.ReadIndex([ttMethodDef, ttMemberRef]);\r\n FInstantiationOffset := Table.ReadIndex(hkBlob);\r\nend;\r\n\r\nfunction TJclClrTableMethodSpecRow.GetMethod: TJclClrTableRow;\r\nconst\r\n MethodDefOrRefEncodedTag: array [0..1] of TJclClrTableKind =\r\n (ttMethodDef, ttMemberRef);\r\nbegin\r\n Result := Table.Stream.Metadata.Tables[MethodDefOrRefEncodedTag[FMethodIdx and 1]].Rows[FMethodIdx shr 1];\r\nend;\r\n\r\nfunction TJclClrTableMethodSpecRow.GetInstantiation: TJclClrBlobRecord;\r\nbegin\r\n Result := Table.Stream.Metadata.BlobAt(FInstantiationOffset);\r\nend;\r\n\r\nfunction TJclClrTableMethodSpec.GetRow(const Idx: Integer): TJclClrTableMethodSpecRow;\r\nbegin\r\n Result := TJclClrTableMethodSpecRow(inherited GetRow(Idx));\r\nend;\r\n\r\nclass function TJclClrTableMethodSpec.TableRowClass: TJclClrTableRowClass;\r\nbegin\r\n Result := TJclClrTableMethodSpecRow;\r\nend;\r\n\r\n//=== { TJclClrTableNestedClassRow } =========================================\r\n\r\nconstructor TJclClrTableNestedClassRow.Create(const ATable: TJclClrTable);\r\nbegin\r\n inherited Create(ATable);\r\n FNestedClassIdx := Table.ReadIndex([ttTypeDef]);\r\n FEnclosingClassIdx := Table.ReadIndex([ttTypeDef]);\r\nend;\r\n\r\nfunction TJclClrTableNestedClass.GetRow(const Idx: Integer): TJclClrTableNestedClassRow;\r\nbegin\r\n Result := TJclClrTableNestedClassRow(inherited GetRow(Idx));\r\nend;\r\n\r\nclass function TJclClrTableNestedClass.TableRowClass: TJclClrTableRowClass;\r\nbegin\r\n Result := TJclClrTableNestedClassRow;\r\nend;\r\n\r\n//=== { TJclClrTablePropertyDefRow } =========================================\r\n\r\nconstructor TJclClrTablePropertyDefRow.Create(const ATable: TJclClrTable);\r\nbegin\r\n inherited Create(ATable);\r\n FFlags := Table.ReadWord;\r\n FNameOffset := Table.ReadIndex(hkString);\r\n FKindIdx := Table.ReadIndex(hkBlob);\r\nend;\r\n\r\nfunction TJclClrTablePropertyDefRow.DumpIL: string;\r\n\r\n function DumpFlags: string;\r\n const\r\n SpecialName: array [Boolean] of string = ('', 'specialname ');\r\n RTSpecialName: array [Boolean] of string = ('', 'rtspecialname ');\r\n begin\r\n Result := SpecialName[pfSpecialName in Flags] +\r\n RTSpecialName[pfRTSpecialName in Flags];\r\n end;\r\n\r\nbegin\r\n Result := Format('.property /*%.8x*/ %s%s ()', [Token, DumpFlags, Name]);\r\nend;\r\n\r\nfunction TJclClrTablePropertyDefRow.GetFlags: TJclClrTablePropertyFlags;\r\nvar\r\n AFlag: TJclClrTablePropertyFlag;\r\nbegin\r\n Result := [];\r\n for AFlag := Low(TJclClrTablePropertyFlag) to High(TJclClrTablePropertyFlag) do\r\n if ClrTablePropertyFlagMapping[AFlag] and FFlags <> 0 then\r\n Include(Result, AFlag);\r\nend;\r\n\r\nfunction TJclClrTablePropertyDefRow.GetName: WideString;\r\nbegin\r\n Result := Table.Stream.Metadata.StringAt(FNameOffset);\r\nend;\r\n\r\nfunction TJclClrTablePropertyDef.GetRow(const Idx: Integer): TJclClrTablePropertyDefRow;\r\nbegin\r\n Result := TJclClrTablePropertyDefRow(inherited GetRow(Idx));\r\nend;\r\n\r\nclass function TJclClrTablePropertyDef.TableRowClass: TJclClrTableRowClass;\r\nbegin\r\n Result := TJclClrTablePropertyDefRow;\r\nend;\r\n\r\n//=== { TJclClrTablePropertyPtrRow } =========================================\r\n\r\nconstructor TJclClrTablePropertyPtrRow.Create(const ATable: TJclClrTable);\r\nbegin\r\n inherited Create(ATable);\r\n FPropertyIdx := Table.ReadIndex([ttPropertyDef]);\r\nend;\r\n\r\nfunction TJclClrTablePropertyPtrRow.GetProperty: TJclClrTablePropertyDefRow;\r\nbegin\r\n Result := TJclClrTablePropertyDef(Table.Stream.Tables[ttPropertyDef]).Rows[FPropertyIdx-1];\r\nend;\r\n\r\nfunction TJclClrTablePropertyPtr.GetRow(const Idx: Integer): TJclClrTablePropertyPtrRow;\r\nbegin\r\n Result := TJclClrTablePropertyPtrRow(inherited GetRow(Idx));\r\nend;\r\n\r\nclass function TJclClrTablePropertyPtr.TableRowClass: TJclClrTableRowClass;\r\nbegin\r\n Result := TJclClrTablePropertyPtrRow;\r\nend;\r\n\r\n//=== { TJclClrTablePropertyMapRow } =========================================\r\n\r\nconstructor TJclClrTablePropertyMapRow.Create(const ATable: TJclClrTable);\r\nbegin\r\n inherited Create(ATable);\r\n FParentIdx := Table.ReadIndex([ttTypeDef]);\r\n FPropertyListIdx := Table.ReadIndex([ttPropertyDef]);\r\n FProperties := TList.Create;\r\nend;\r\n\r\ndestructor TJclClrTablePropertyMapRow.Destroy;\r\nbegin\r\n FreeAndNil(FProperties);\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJclClrTablePropertyMapRow.GetParent: TJclClrTableTypeDefRow;\r\nbegin\r\n Result := TJclClrTableTypeDef(Table.Stream.Tables[ttTypeDef]).Rows[FParentIdx-1];\r\nend;\r\n\r\nfunction TJclClrTablePropertyMapRow.Add(const ARow: TJclClrTablePropertyDefRow): Integer;\r\nbegin\r\n Result := FProperties.Add(ARow);\r\nend;\r\n\r\nfunction TJclClrTablePropertyMapRow.GetProperty(const Idx: Integer): TJclClrTablePropertyDefRow;\r\nbegin\r\n Result := TJclClrTablePropertyDefRow(FProperties.Items[Idx]);\r\nend;\r\n\r\nfunction TJclClrTablePropertyMapRow.GetPropertyCount: Integer;\r\nbegin\r\n Result := FProperties.Count;\r\nend;\r\n\r\nfunction TJclClrTablePropertyMap.GetRow(const Idx: Integer): TJclClrTablePropertyMapRow;\r\nbegin\r\n Result := TJclClrTablePropertyMapRow(inherited GetRow(Idx));\r\nend;\r\n\r\nclass function TJclClrTablePropertyMap.TableRowClass: TJclClrTableRowClass;\r\nbegin\r\n Result := TJclClrTablePropertyMapRow;\r\nend;\r\n\r\nprocedure TJclClrTablePropertyMap.Update;\r\nvar\r\n I, J: Integer;\r\nbegin\r\n J := 0;\r\n with TJclClrTablePropertyDef(Stream.Tables[ttPropertyDef]) do\r\n for I := 0 to RowCount-1 do\r\n begin\r\n if I >= Integer(Self.Rows[J].PropertyListIdx) then\r\n Inc(J);\r\n if J >= Self.RowCount then\r\n Break;\r\n Self.Rows[J].Add(Rows[I]);\r\n end;\r\nend;\r\n\r\n//=== { TJclClrTableStandAloneSigRow } =======================================\r\n\r\nconstructor TJclClrTableStandAloneSigRow.Create(const ATable: TJclClrTable);\r\nbegin\r\n inherited Create(ATable);\r\n FSignatureOffset := Table.ReadIndex(hkBlob);\r\nend;\r\n\r\nfunction TJclClrTableStandAloneSigRow.GetSignature: TJclClrBlobRecord;\r\nbegin\r\n Result := Table.Stream.Metadata.BlobAt(FSignatureOffset);\r\nend;\r\n\r\nfunction TJclClrTableStandAloneSig.GetRow(\r\n const Idx: Integer): TJclClrTableStandAloneSigRow;\r\nbegin\r\n Result := TJclClrTableStandAloneSigRow(inherited GetRow(Idx));\r\nend;\r\n\r\nclass function TJclClrTableStandAloneSig.TableRowClass: TJclClrTableRowClass;\r\nbegin\r\n Result := TJclClrTableStandAloneSigRow;\r\nend;\r\n\r\n//=== { TJclClrTableTypeDefRow } =============================================\r\n\r\nconstructor TJclClrTableTypeDefRow.Create(const ATable: TJclClrTable);\r\nbegin\r\n inherited Create(ATable);\r\n FFlags := Table.ReadDWord;\r\n FNameOffset := Table.ReadIndex(hkString);\r\n FNamespaceOffset := Table.ReadIndex(hkString);\r\n FExtendsIdx := Table.ReadIndex([ttTypeDef, ttTypeRef, ttTypeSpec]);\r\n FFieldListIdx := Table.ReadIndex([ttFieldDef]);\r\n FMethodListIdx := Table.ReadIndex([ttMethodDef]);\r\n\r\n FFields := nil;\r\n FMethods := nil;\r\nend;\r\n\r\ndestructor TJclClrTableTypeDefRow.Destroy;\r\nbegin\r\n FreeAndNil(FFields);\r\n FreeAndNil(FMethods);\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJclClrTableTypeDefRow.GetName: WideString;\r\nbegin\r\n Result := Table.Stream.Metadata.StringAt(FNameOffset);\r\nend;\r\n\r\nfunction TJclClrTableTypeDefRow.GetNamespace: WideString;\r\nbegin\r\n Result := Table.Stream.Metadata.StringAt(FNamespaceOffset);\r\nend;\r\n\r\nfunction TJclClrTableTypeDefRow.GetField(const Idx: Integer): TJclClrTableFieldDefRow;\r\nbegin\r\n Result := TJclClrTableFieldDefRow(FFields.Items[Idx])\r\nend;\r\n\r\nfunction TJclClrTableTypeDefRow.GetFieldCount: Integer;\r\nbegin\r\n Result := FFields.Count\r\nend;\r\n\r\nfunction TJclClrTableTypeDefRow.HasField: Boolean;\r\nbegin\r\n Result := Assigned(FFields);\r\nend;\r\n\r\nfunction TJclClrTableTypeDefRow.GetMethod(const Idx: Integer): TJclClrTableMethodDefRow;\r\nbegin\r\n Result := TJclClrTableMethodDefRow(FMethods.Items[Idx])\r\nend;\r\n\r\nfunction TJclClrTableTypeDefRow.GetMethodCount: Integer;\r\nbegin\r\n Result := FMethods.Count\r\nend;\r\n\r\nfunction TJclClrTableTypeDefRow.HasMethod: Boolean;\r\nbegin\r\n Result := Assigned(FMethods);\r\nend;\r\n\r\nprocedure TJclClrTableTypeDefRow.UpdateFields;\r\nvar\r\n FieldTable: TJclClrTableFieldDef;\r\n Idx, MaxFieldListIdx: DWORD;\r\nbegin\r\n with Table as TJclClrTableTypeDef do\r\n if not Assigned(FFields) and (FieldListIdx <> 0) and\r\n Stream.FindTable(ttFieldDef, TJclClrTable(FieldTable)) then\r\n begin\r\n if RowCount > (Index+1) then\r\n MaxFieldListIdx := Rows[Index+1].FieldListIdx-1\r\n else\r\n MaxFieldListIdx := FieldTable.RowCount;\r\n if (FieldListIdx-1) < MaxFieldListIdx then\r\n begin\r\n FFields := TList.Create;\r\n for Idx := FieldListIdx-1 to MaxFieldListIdx-1 do\r\n begin\r\n FFields.Add(FieldTable.Rows[Idx]);\r\n FieldTable.Rows[Idx].SetParentToken(Self);\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJclClrTableTypeDefRow.UpdateMethods;\r\nvar\r\n MethodTable: TJclClrTableMethodDef;\r\n Idx, MaxMethodListIdx: DWORD;\r\nbegin\r\n with Table as TJclClrTableTypeDef do\r\n if not Assigned(FMethods) and (MethodListIdx <> 0) and\r\n Stream.FindTable(ttMethodDef, TJclClrTable(MethodTable)) then\r\n begin\r\n if RowCount > (Index+1) then\r\n MaxMethodListIdx := Rows[Index+1].MethodListIdx-1\r\n else\r\n MaxMethodListIdx := MethodTable.RowCount;\r\n if (MethodListIdx-1) < MaxMethodListIdx then\r\n begin\r\n FMethods := TList.Create;\r\n for Idx := MethodListIdx-1 to MaxMethodListIdx-1 do\r\n begin\r\n FMethods.Add(MethodTable.Rows[Idx]);\r\n MethodTable.Rows[Idx].SetParentToken(Self);\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJclClrTableTypeDefRow.Update;\r\nbegin\r\n inherited Update;\r\n UpdateFields;\r\n UpdateMethods;\r\nend;\r\n\r\nfunction TJclClrTableTypeDefRow.GetFullName: WideString;\r\nbegin\r\n if FNamespaceOffset <> 0 then\r\n Result := Namespace + '.' + Name\r\n else\r\n Result := Name;\r\nend;\r\n\r\nfunction TJclClrTableTypeDefRow.GetAttributes: TJclClrTypeAttributes;\r\nconst\r\n TypeAttributesMapping: array [TJclClrTypeAttribute] of DWORD =\r\n (tdAbstract, tdSealed, tdSpecialName, tdImport,\r\n tdSerializable, tdBeforeFieldInit, tdRTSpecialName, tdHasSecurity);\r\nvar\r\n Attr: TJclClrTypeAttribute;\r\nbegin\r\n Result := [];\r\n for Attr := Low(TJclClrTypeAttribute) to High(TJclClrTypeAttribute) do\r\n if (FFlags and TypeAttributesMapping[Attr]) = TypeAttributesMapping[Attr] then\r\n Include(Result, Attr);\r\nend;\r\n\r\nfunction TJclClrTableTypeDefRow.GetClassLayout: TJclClrClassLayout;\r\nbegin\r\n case FFlags and tdLayoutMask of\r\n tdAutoLayout:\r\n Result := clAuto;\r\n tdSequentialLayout:\r\n Result := clSequential;\r\n tdExplicitLayout:\r\n Result := clExplicit;\r\n else\r\n raise EJclMetadataError.CreateResFmt(@RsUnknownClassLayout, [FFlags and tdLayoutMask]);\r\n end;\r\nend;\r\n\r\nfunction TJclClrTableTypeDefRow.GetClassSemantics: TJclClrClassSemantics;\r\nconst\r\n ClassSemanticsMapping: array [Boolean] of TJclClrClassSemantics =\r\n (csClass, csInterface);\r\nbegin\r\n Result := ClassSemanticsMapping[(FFlags and tdClassSemanticsMask) = tdInterface];\r\nend;\r\n\r\nfunction TJclClrTableTypeDefRow.GetStringFormatting: TJclClrStringFormatting;\r\nbegin\r\n case FFlags and tdStringFormatMask of\r\n tdAnsiClass:\r\n Result := sfAnsi;\r\n tdUnicodeClass:\r\n Result := sfUnicode;\r\n tdAutoClass:\r\n Result := sfAutoChar;\r\n else\r\n raise EJclMetadataError.CreateResFmt(@RsUnknownStringFormatting, [FFlags and tdStringFormatMask]);\r\n end;\r\nend;\r\n\r\nfunction TJclClrTableTypeDefRow.GetVisibility: TJclClrTypeVisibility;\r\nbegin\r\n Result := TJclClrTypeVisibility(FFlags and tdVisibilityMask);\r\nend;\r\n\r\nfunction TJclClrTableTypeDefRow.GetExtends: TJclClrTableRow;\r\nbegin\r\n Result := DecodeTypeDefOrRef(FExtendsIdx);\r\nend;\r\n\r\nfunction TJclClrTableTypeDefRow.DumpIL: string;\r\nconst\r\n ClassSemanticName: array [TJclClrClassSemantics] of PChar =\r\n ('class', 'interface');\r\n VisibilityName: array [TJclClrTypeVisibility] of PChar =\r\n ('private', 'public', 'nested public', 'nested private',\r\n 'nested family', 'nested assembly', 'nested famandassem', 'nested famorassem');\r\n ClassLayoutName: array [TJclClrClassLayout] of PChar =\r\n ('auto', 'explicit', 'sequential');\r\n StringFormattingName: array [TJclClrStringFormatting] of PChar =\r\n ('ansi', 'unicode', 'autoChar');\r\n TypeAttributeName: array [TJclClrTypeAttribute] of PChar =\r\n ('abstract', 'sealed', 'specialname', '' {'import'},\r\n 'serializable', 'beforefieldinit', 'rtspecialname', '' {'hassecurity'});\r\n Indent = ' ';\r\n IntfPrefix: array [Boolean] of PChar = (' ', 'implements ');\r\nvar\r\n I, J: Integer;\r\n ListIntfs: TList;\r\n\r\n function GetTypeAttributesName: string;\r\n var\r\n Attr: TJclClrTypeAttribute;\r\n begin\r\n Result := '';\r\n for Attr := Low(TJclClrTypeAttribute) to High(TJclClrTypeAttribute) do\r\n if Attr in Attributes then\r\n Result := Result + TypeAttributeName[Attr] + ' ';\r\n end;\r\n\r\n function GetExtends(const Row: TJclClrTableTypeDefRow): string; overload;\r\n begin\r\n Result := Format('%s.%s/* %.8x */', [Row.Namespace, Row.Name, Row.Token]);\r\n end;\r\n\r\n function GetExtends(const Row: TJclClrTableRow): string; overload;\r\n begin\r\n if Row is TJclClrTableTypeDefRow then\r\n Result := GetExtends(TJclClrTableTypeDefRow(Row))\r\n else\r\n if Row is TJclClrTableTypeRefRow then\r\n Result := TJclClrTableTypeRefRow(Row).DumpIL\r\n else\r\n if Row is TJclClrTableTypeSpecRow then\r\n Result := TJclClrTableTypeSpecRow(Row).DumpIL\r\n else\r\n Result := 'Unknown Extends ' + Row.ClassName;\r\n end;\r\n\r\nbegin\r\n with TStringList.Create do\r\n try\r\n Add(Format('.%s /*%.8x*/ %s %s %s %s%s.%s',\r\n [ClassSemanticName[ClassSemantics], Token,\r\n VisibilityName[Visibility], ClassLayoutName[ClassLayout],\r\n StringFormattingName[StringFormatting], GetTypeAttributesName,\r\n Namespace, Name]));\r\n\r\n if ExtendsIdx <> 0 then\r\n Add(Indent + 'extends ' + GetExtends(Extends));\r\n\r\n ListIntfs := TList.Create;\r\n try\r\n if Assigned(Table.Stream.Tables[ttInterfaceImpl]) then\r\n with TJclClrTableInterfaceImpl(Table.Stream.Tables[ttInterfaceImpl]) do\r\n for I := 0 to RowCount-1 do\r\n if Rows[I].ClassIdx = DWORD(Index + 1) then\r\n ListIntfs.Add(Rows[I]);\r\n\r\n if ListIntfs.Count > 0 then\r\n for I := 0 to ListIntfs.Count-1 do\r\n Add(Indent + IntfPrefix[I = 0] + TJclClrTableInterfaceImplRow(ListIntfs[I]).DumpIL);\r\n finally\r\n ListIntfs.Free;\r\n end;\r\n\r\n Add('(');\r\n\r\n if HasField then\r\n for I := 0 to FieldCount-1 do\r\n Add(Indent + Fields[I].DumpIL);\r\n\r\n if HasMethod then\r\n for I := 0 to MethodCount-1 do\r\n Add(Indent + Methods[I].DumpIL);\r\n\r\n if Assigned(Table.Stream.Tables[ttPropertyMap]) then\r\n with TJclClrTablePropertyMap(Table.Stream.Tables[ttPropertyMap]) do\r\n for I := 0 to RowCount-1 do\r\n if Rows[I].Parent = Self then\r\n for J := 0 to Rows[I].PropertyCount-1 do\r\n Add(Indent + Rows[I].Properties[J].DumpIL);\r\n\r\n Add(') // end of class ' + Name);\r\n Result := Text;\r\n finally\r\n Free;\r\n end;\r\nend;\r\n\r\nclass function TJclClrTableTypeDef.TableRowClass: TJclClrTableRowClass;\r\nbegin\r\n Result := TJclClrTableTypeDefRow;\r\nend;\r\n\r\nfunction TJclClrTableTypeDef.GetRow(const Idx: Integer): TJclClrTableTypeDefRow;\r\nbegin\r\n Result := TJclClrTableTypeDefRow(inherited GetRow(Idx));\r\nend;\r\n\r\n//=== { TJclClrTableTypeRefRow } =============================================\r\n\r\nconstructor TJclClrTableTypeRefRow.Create(const ATable: TJclClrTable);\r\nbegin\r\n inherited Create(ATable);\r\n FResolutionScopeIdx := Table.ReadIndex([ttModule, ttModuleRef, ttAssemblyRef, ttTypeRef]);\r\n FNameOffset := Table.ReadIndex(hkString);\r\n FNamespaceOffset := Table.ReadIndex(hkString);\r\nend;\r\n\r\nfunction TJclClrTableTypeRefRow.DumpIL: string;\r\nbegin\r\n Result := Format('[%s/* %.8x */]%s.%s/* %.8x */',\r\n [ResolutionScopeName, ResolutionScope.Token, Namespace, Name, Token]);\r\nend;\r\n\r\nfunction TJclClrTableTypeRefRow.GetFullName: WideString;\r\nbegin\r\n Result := Namespace + '.' + Name;\r\nend;\r\n\r\nfunction TJclClrTableTypeRefRow.GetName: WideString;\r\nbegin\r\n Result := Table.Stream.Metadata.StringAt(FNameOffset);\r\nend;\r\n\r\nfunction TJclClrTableTypeRefRow.GetNamespace: WideString;\r\nbegin\r\n Result := Table.Stream.Metadata.StringAt(FNamespaceOffset);\r\nend;\r\n\r\nfunction TJclClrTableTypeRefRow.GetResolutionScope: TJclClrTableRow;\r\nbegin\r\n Result := DecodeResolutionScope(FResolutionScopeIdx);\r\nend;\r\n\r\nfunction TJclClrTableTypeRefRow.GetResolutionScopeName: string;\r\nbegin\r\n if ResolutionScope is TJclClrTableModuleRow then\r\n Result := TJclClrTableModuleRow(ResolutionScope).Name\r\n else\r\n if ResolutionScope is TJclClrTableModuleRefRow then\r\n Result := TJclClrTableModuleRefRow(ResolutionScope).Name\r\n else\r\n if ResolutionScope is TJclClrTableAssemblyRefRow then\r\n Result := TJclClrTableAssemblyRefRow(ResolutionScope).Name\r\n else\r\n if ResolutionScope is TJclClrTableTypeRefRow then\r\n Result := TJclClrTableTypeRefRow(ResolutionScope).Namespace + '.' +\r\n TJclClrTableTypeRefRow(ResolutionScope).Name\r\n else\r\n Result := 'Unknown';\r\nend;\r\n\r\nclass function TJclClrTableTypeRef.TableRowClass: TJclClrTableRowClass;\r\nbegin\r\n Result := TJclClrTableTypeRefRow;\r\nend;\r\n\r\nfunction TJclClrTableTypeRef.GetRow(const Idx: Integer): TJclClrTableTypeRefRow;\r\nbegin\r\n Result := TJclClrTableTypeRefRow(inherited GetRow(Idx));\r\nend;\r\n\r\n//=== { TJclClrTableTypeSpecRow } ============================================\r\n\r\nconstructor TJclClrTableTypeSpecRow.Create(const ATable: TJclClrTable);\r\nbegin\r\n inherited Create(ATable);\r\n FSignatureOffset := Table.ReadIndex(hkBlob);\r\nend;\r\n\r\nfunction TJclClrTableTypeSpecRow.GetSignature: TJclClrBlobRecord;\r\nbegin\r\n Result := Table.Stream.Metadata.BlobAt(FSignatureOffset);\r\nend;\r\n\r\nfunction TJclClrTableTypeSpec.GetRow(const Idx: Integer): TJclClrTableTypeSpecRow;\r\nbegin\r\n Result := TJclClrTableTypeSpecRow(inherited GetRow(Idx));\r\nend;\r\n\r\nclass function TJclClrTableTypeSpec.TableRowClass: TJclClrTableRowClass;\r\nbegin\r\n Result := TJclClrTableTypeSpecRow;\r\nend;\r\n\r\n//=== { TJclClrTableENCMapRow } ==============================================\r\n\r\nconstructor TJclClrTableENCMapRow.Create(const ATable: TJclClrTable);\r\nbegin\r\n inherited Create(ATable);\r\n FToken := Table.ReadDWord;\r\nend;\r\n\r\nfunction TJclClrTableENCMap.GetRow(const Idx: Integer): TJclClrTableENCMapRow;\r\nbegin\r\n Result := TJclClrTableENCMapRow(inherited GetRow(Idx));\r\nend;\r\n\r\nclass function TJclClrTableENCMap.TableRowClass: TJclClrTableRowClass;\r\nbegin\r\n Result := TJclClrTableENCMapRow;\r\nend;\r\n\r\n//=== { TJclClrTableENCLogRow } ==============================================\r\n\r\nconstructor TJclClrTableENCLogRow.Create(const ATable: TJclClrTable);\r\nbegin\r\n inherited Create(ATable);\r\n FFuncCode := Table.ReadDWord;\r\nend;\r\n\r\nfunction TJclClrTableENCLog.GetRow(const Idx: Integer): TJclClrTableENCLogRow;\r\nbegin\r\n Result := TJclClrTableENCLogRow(inherited GetRow(Idx));\r\nend;\r\n\r\nclass function TJclClrTableENCLog.TableRowClass: TJclClrTableRowClass;\r\nbegin\r\n Result := TJclClrTableENCLogRow;\r\nend;\r\n\r\nfunction TJclClrLocalVar.GetName: WideString;\r\nconst\r\n ClrElementTypeNameMapping: array [etVoid..etString] of PChar =\r\n ('void', 'bool',\r\n 'char', 'sbyte', 'byte',\r\n 'short', 'ushort', 'int', 'unit',\r\n 'long', 'ulong', 'float', 'Double',\r\n 'string');\r\nbegin\r\n case ElementType of\r\n etVoid, etBoolean, etChar,\r\n etI1, etU1, etI2, etU2, etI4, etU4,\r\n etI8, etU8, etR4, etR8, etString:\r\n Result := ClrElementTypeNameMapping[ElementType];\r\n etPtr, etByRef, etValueType, etClass:\r\n Result := IntToHex(Token, 8);\r\n etArray:\r\n Result := 'Array';\r\n etTypedByRef:\r\n Result := 'TypedByRef';\r\n etI:\r\n Result := 'IntPtr';\r\n etU:\r\n Result := 'UIntPtr';\r\n etFnPtr:\r\n Result := 'Function';\r\n etObject:\r\n Result := 'System.Object';\r\n etSzArray:\r\n // (rom) possible BUG! Result not assigned\r\n else\r\n Result := 'Unknown';\r\n end;\r\nend;\r\n\r\n//=== { TJclClrLocalVarSign } ================================================\r\n\r\nconstructor TJclClrLocalVarSign.Create(const ABlob: TJclClrBlobRecord);\r\nvar\r\n Sign, ElemType: Byte;\r\n T: TJclClrElementType;\r\n I, VarCount: DWORD;\r\n LocalVar: TJclClrLocalVar;\r\nbegin\r\n inherited Create(ABlob);\r\n\r\n Blob.Seek(0, soFromBeginning);\r\n\r\n Sign := ReadByte;\r\n\r\n if (Sign and IMAGE_CEE_CS_CALLCONV_MASK) <> IMAGE_CEE_CS_CALLCONV_LOCAL_SIG then\r\n raise EJclMetadataError.CreateResFmt(@RsNoLocalVarSig, [IntToHex(Sign, 2)]);\r\n\r\n VarCount := ReadValue;\r\n if (VarCount < 1) or ($FFFE < VarCount) then\r\n raise EJclMetadataError.CreateResFmt(@RsLocalVarSigOutOfRange, [VarCount]);\r\n\r\n FLocalVars := TObjectList.Create;\r\n\r\n LocalVar := TJclClrLocalVar.Create;\r\n\r\n for I := 0 to VarCount-1 do\r\n begin\r\n ElemType := ReadByte;\r\n\r\n case ElemType of\r\n ELEMENT_TYPE_PINNED:\r\n LocalVar.Flags := LocalVar.Flags + [lvfPinned];\r\n ELEMENT_TYPE_BYREF:\r\n LocalVar.Flags := LocalVar.Flags + [lvfByRef];\r\n ELEMENT_TYPE_END:\r\n Break;\r\n else\r\n for T := Low(TJclClrElementType) to High(TJclClrElementType) do\r\n if ClrElementTypeMapping[T] = ElemType then\r\n begin\r\n LocalVar.ElementType := T;\r\n Break;\r\n end;\r\n if LocalVar.ElementType in [etPtr, etByRef, etValueType, etClass] then\r\n LocalVar.Token := ReadToken\r\n else\r\n LocalVar.Token := 0;\r\n\r\n FLocalVars.Add(LocalVar);\r\n LocalVar := TJclClrLocalVar.Create;\r\n end;\r\n end;\r\n FreeAndNil(LocalVar);\r\nend;\r\n\r\ndestructor TJclClrLocalVarSign.Destroy;\r\nbegin\r\n FreeAndNil(FLocalVars);\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJclClrLocalVarSign.GetLocalVar(const Idx: Integer): TJclClrLocalVar;\r\nbegin\r\n Result := TJclClrLocalVar(FLocalVars[Idx]);\r\nend;\r\n\r\nfunction TJclClrLocalVarSign.GetLocalVarCount: Integer;\r\nbegin\r\n Result := FLocalVars.Count;\r\nend;\r\n\r\n//=== { TJclClrMethodSign } ==================================================\r\n\r\nconstructor TJclClrMethodSign.Create(const ABlob: TJclClrBlobRecord);\r\nvar\r\n Sign: Byte;\r\n I, ParamCount: Integer;\r\nbegin\r\n inherited Create(ABlob);\r\n\r\n FParams := TObjectList.Create;\r\n\r\n Sign := ReadByte;\r\n\r\n if IsBitSet(Sign, IMAGE_CEE_CS_CALLCONV_HASTHIS) then\r\n Include(FFlags, mfHasThis);\r\n\r\n if IsBitSet(Sign, IMAGE_CEE_CS_CALLCONV_EXPLICITTHIS) then\r\n Include(FFlags, mfExplicitThis);\r\n\r\n case Sign and IMAGE_CEE_CS_CALLCONV_MASK of\r\n IMAGE_CEE_CS_CALLCONV_DEFAULT:\r\n Include(FFlags, mfDefault);\r\n IMAGE_CEE_CS_CALLCONV_VARARG:\r\n Include(FFlags, mfVarArg);\r\n end;\r\n\r\n ParamCount := ReadValue;\r\n\r\n FRetType := TJclClrMethodRetType.Create(Blob);\r\n\r\n for I := 0 to ParamCount-1 do\r\n FParams.Add(TJclClrMethodParam.Create(Blob));\r\nend;\r\n\r\ndestructor TJclClrMethodSign.Destroy;\r\nbegin\r\n FreeAndNil(FParams);\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJclClrMethodSign.GetParam(const Idx: Integer): TJclClrMethodParam;\r\nbegin\r\n Result := TJclClrMethodParam(FParams.Items[Idx]);\r\nend;\r\n\r\nfunction TJclClrMethodSign.GetParamCount: Integer;\r\nbegin\r\n Result := FParams.Count;\r\nend;\r\n\r\n//=== { TJclClrCustomModifierSign } ==========================================\r\n\r\nconstructor TJclClrCustomModifierSign.Create(const ABlob: TJclClrBlobRecord);\r\nbegin\r\n inherited Create(ABlob);\r\n FRequired := ReadByte = ELEMENT_TYPE_CMOD_REQD;\r\n FToken := ReadToken;\r\nend;\r\n\r\n//=== { TJclClrMethodParam } =================================================\r\n\r\nconstructor TJclClrMethodParam.Create(const ABlob: TJclClrBlobRecord);\r\nvar\r\n By: Byte;\r\n Finished: Boolean;\r\nbegin\r\n inherited Create(ABlob);\r\n\r\n FCustomMods := TObjectList.Create;\r\n FByRef := False;\r\n FElementType := etEnd;\r\n FToken := 0;\r\n FMethodSign := nil;\r\n\r\n Finished := False;\r\n while not Finished and (Blob.Position < Blob.Size) do\r\n begin\r\n By := ReadByte;\r\n case By of\r\n ELEMENT_TYPE_CMOD_REQD, ELEMENT_TYPE_CMOD_OPT:\r\n begin\r\n Blob.Seek(-SizeOf(Byte), soFromCurrent);\r\n FCustomMods.Add(TJclClrCustomModifierSign.Create(Blob));\r\n end;\r\n ELEMENT_TYPE_BYREF:\r\n FByRef := True;\r\n else\r\n FElementType := TJclClrElementType(By);\r\n case FElementType of\r\n etPtr, etTypedByRef, etValueType, etClass:\r\n FToken := ReadToken;\r\n etFnPtr:\r\n FMethodSign := TJclClrMethodSign.Create(Blob);\r\n etArray:\r\n FArraySign := TJclClrArraySign.Create(Blob);\r\n end;\r\n Finished := True;\r\n end;\r\n end;\r\nend;\r\n\r\ndestructor TJclClrMethodParam.Destroy;\r\nbegin\r\n FreeAndNil(FCustomMods);\r\n FreeAndNil(FMethodSign);\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJclClrMethodParam.GetCustomModifier(const Idx: Integer): TJclClrCustomModifierSign;\r\nbegin\r\n Result := TJclClrCustomModifierSign(FCustomMods.Items[Idx]);\r\nend;\r\n\r\nfunction TJclClrMethodParam.GetCustomModifierCount: Integer;\r\nbegin\r\n Result := FCustomMods.Count;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jcl/source/windows/JclMiscel.pas", "content": "{**************************************************************************************************}\r\n{ }\r\n{ Project JEDI Code Library (JCL) }\r\n{ }\r\n{ The contents of this file are subject to the Mozilla Public License Version 1.1 (the \"License\"); }\r\n{ you may not use this file except in compliance with the License. You may obtain a copy of the }\r\n{ License at http://www.mozilla.org/MPL/ }\r\n{ }\r\n{ Software distributed under the License is distributed on an \"AS IS\" basis, WITHOUT WARRANTY OF }\r\n{ ANY KIND, either express or implied. See the License for the specific language governing rights }\r\n{ and limitations under the License. }\r\n{ }\r\n{ The Original Code is JclMiscel.pas. }\r\n{ }\r\n{ The Initial Developers of the Original Code are Members of Team JCL. Portions created by these }\r\n{ individuals are Copyright (C) of these individuals. All Rights Reserved }\r\n{ }\r\n{ Contributors: }\r\n{ Jeroen Speldekamp }\r\n{ Peter Friese }\r\n{ Marcel van Brakel }\r\n{ Robert Marquardt (marquardt) }\r\n{ John C Molyneux }\r\n{ Matthias Thoma (mthoma) }\r\n{ Petr Vones (pvones) }\r\n{ }\r\n{**************************************************************************************************}\r\n{ }\r\n{ Various miscellaneous routines that do not (yet) fit nicely into other units }\r\n{ }\r\n{**************************************************************************************************}\r\n{ }\r\n{ Last modified: $Date:: 2011-09-03 00:07:50 +0200 (sam. 03 sept. 2011) $ }\r\n{ Revision: $Rev:: 3599 $ }\r\n{ Author: $Author:: outchy $ }\r\n{ }\r\n{**************************************************************************************************}\r\n\r\nunit JclMiscel;\r\n\r\n{$I jcl.inc}\r\n{$I windowsonly.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n {$IFDEF MSWINDOWS}\r\n {$IFDEF HAS_UNITSCOPE}\r\n Winapi.Windows,\r\n {$ELSE ~HAS_UNITSCOPE}\r\n Windows,\r\n {$ENDIF ~HAS_UNITSCOPE}\r\n JclWin32,\r\n {$ENDIF MSWINDOWS}\r\n JclBase;\r\n\r\n// StrLstLoadSave\r\nfunction SetDisplayResolution(const XRes, YRes: DWORD): Longint;\r\n\r\nfunction CreateDOSProcessRedirected(CommandLine: string; const InputFile, OutputFile: string): Boolean;\r\nfunction WinExec32(Cmd: string; const CmdShow: Integer): Boolean;\r\nfunction WinExec32AndWait(Cmd: string; const CmdShow: Integer): Cardinal;\r\nfunction WinExec32AndRedirectOutput(const Cmd: string; var Output: string; RawOutput: Boolean = False): Cardinal;\r\n\r\ntype\r\n TJclKillLevel = (klNormal, klNoSignal, klTimeOut);\r\n\r\n// klNormal: old shutdown style: waiting all applications to respond to the signals\r\n// klNoSignal: do not send shutdown signal, all applications are killed (only Windows NT/2000/XP)\r\n// klTimeOut: kill applications that do not respond within the timeout interval (only Windows 2000 and XP)\r\n\r\nfunction ExitWindows(ExitCode: Cardinal): Boolean;\r\nfunction LogOffOS(KillLevel: TJclKillLevel = klNormal): Boolean;\r\nfunction PowerOffOS(KillLevel: TJclKillLevel = klNormal): Boolean;\r\nfunction ShutDownOS(KillLevel: TJclKillLevel = klNormal): Boolean;\r\nfunction RebootOS(KillLevel: TJclKillLevel = klNormal): Boolean;\r\nfunction HibernateOS(Force, DisableWakeEvents: Boolean): Boolean;\r\nfunction SuspendOS(Force, DisableWakeEvents: Boolean): Boolean;\r\n\r\nfunction ShutDownDialog(const DialogMessage: string; TimeOut: DWORD;\r\n Force, Reboot: Boolean): Boolean; overload;\r\nfunction ShutDownDialog(const MachineName, DialogMessage: string; TimeOut: DWORD;\r\n Force, Reboot: Boolean): Boolean; overload;\r\nfunction AbortShutDown: Boolean; overload;\r\nfunction AbortShutDown(const MachineName: string): Boolean; overload;\r\n\r\ntype\r\n TJclAllowedPowerOperation = (apoHibernate, apoShutdown, apoSuspend);\r\n TJclAllowedPowerOperations = set of TJclAllowedPowerOperation;\r\n\r\nfunction GetAllowedPowerOperations: TJclAllowedPowerOperations;\r\n\r\n// CreateProcAsUser\r\ntype\r\n EJclCreateProcessError = class(EJclWin32Error);\r\n\r\nprocedure CreateProcAsUser(const UserDomain, UserName, PassWord, CommandLine: string);\r\nprocedure CreateProcAsUserEx(const UserDomain, UserName, Password, CommandLine: string;\r\n const Environment: PChar);\r\n\r\n{$IFDEF SUPPORTS_EXTSYM}\r\n{$EXTERNALSYM ExitWindows}\r\n{$ENDIF SUPPORTS_EXTSYM}\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jcl.svn.sourceforge.net/svnroot/jcl/tags/JCL-2.4-Build4571/jcl/source/windows/JclMiscel.pas $';\r\n Revision: '$Revision: 3599 $';\r\n Date: '$Date: 2011-09-03 00:07:50 +0200 (sam. 03 sept. 2011) $';\r\n LogPath: 'JCL\\source\\windows';\r\n Extra: '';\r\n Data: nil\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n {$IFDEF HAS_UNITSCOPE}\r\n System.SysUtils,\r\n {$ELSE ~HAS_UNITSCOPE}\r\n SysUtils,\r\n {$ENDIF ~HAS_UNITSCOPE}\r\n JclResources, JclSecurity, JclStrings, JclSysUtils, JclSysInfo;\r\n\r\nfunction SetDisplayResolution(const XRes, YRes: DWORD): Longint;\r\nvar\r\n DevMode: TDeviceMode;\r\nbegin\r\n Result := DISP_CHANGE_FAILED;\r\n ResetMemory(DevMode, SizeOf(DevMode));\r\n DevMode.dmSize := SizeOf(DevMode);\r\n if EnumDisplaySettings(nil, 0, DevMode) then\r\n begin\r\n DevMode.dmFields := DM_PELSWIDTH or DM_PELSHEIGHT;\r\n DevMode.dmPelsWidth := XRes;\r\n DevMode.dmPelsHeight := YRes;\r\n Result := ChangeDisplaySettings(DevMode, 0);\r\n end;\r\nend;\r\n\r\nfunction CreateDOSProcessRedirected(CommandLine: string; const InputFile, OutputFile: string): Boolean;\r\nvar\r\n StartupInfo: TStartupInfo;\r\n ProcessInfo: TProcessInformation;\r\n SecAtrrs: TSecurityAttributes;\r\n hInputFile, hOutputFile: THandle;\r\nbegin\r\n Result := False;\r\n hInputFile := CreateFile(PChar(InputFile), GENERIC_READ, FILE_SHARE_READ,\r\n CreateInheritable(SecAtrrs), OPEN_EXISTING, FILE_ATTRIBUTE_TEMPORARY, 0);\r\n if hInputFile <> INVALID_HANDLE_VALUE then\r\n begin\r\n hOutputFile := CreateFile(PChar(OutPutFile), GENERIC_READ or GENERIC_WRITE,\r\n FILE_SHARE_READ, CreateInheritable(SecAtrrs), CREATE_ALWAYS,\r\n FILE_ATTRIBUTE_TEMPORARY, 0);\r\n if hOutputFile <> INVALID_HANDLE_VALUE then\r\n begin\r\n ResetMemory(StartupInfo, SizeOf(StartupInfo));\r\n ResetMemory(ProcessInfo, SizeOf(ProcessInfo));\r\n StartupInfo.cb := SizeOf(StartupInfo);\r\n StartupInfo.dwFlags := STARTF_USESHOWWINDOW or STARTF_USESTDHANDLES;\r\n StartupInfo.wShowWindow := SW_HIDE;\r\n StartupInfo.hStdOutput := hOutputFile;\r\n StartupInfo.hStdInput := hInputFile;\r\n UniqueString(CommandLine);//in the Unicode version the parameter lpCommandLine needs to be writable\r\n Result := CreateProcess(nil, PChar(CommandLine), nil, nil, True,\r\n CREATE_NEW_CONSOLE or NORMAL_PRIORITY_CLASS, nil, nil, StartupInfo,\r\n ProcessInfo);\r\n if Result then\r\n begin\r\n WaitForSingleObject(ProcessInfo.hProcess, INFINITE);\r\n CloseHandle(ProcessInfo.hProcess);\r\n CloseHandle(ProcessInfo.hThread);\r\n end;\r\n CloseHandle(hOutputFile);\r\n end;\r\n CloseHandle(hInputFile);\r\n end;\r\nend;\r\n\r\nfunction WinExec32(Cmd: string; const CmdShow: Integer): Boolean;\r\nvar\r\n StartupInfo: TStartupInfo;\r\n ProcessInfo: TProcessInformation;\r\nbegin\r\n ResetMemory(StartupInfo, SizeOf(TStartupInfo));\r\n ResetMemory(ProcessInfo, SizeOf(ProcessInfo));\r\n StartupInfo.cb := SizeOf(TStartupInfo);\r\n StartupInfo.dwFlags := STARTF_USESHOWWINDOW;\r\n StartupInfo.wShowWindow := CmdShow;\r\n UniqueString(Cmd);//in the Unicode version the parameter lpCommandLine needs to be writable\r\n Result := CreateProcess(nil, PChar(Cmd), nil, nil, False,\r\n NORMAL_PRIORITY_CLASS, nil, nil, StartupInfo, ProcessInfo);\r\n if Result then\r\n begin\r\n WaitForInputIdle(ProcessInfo.hProcess, INFINITE);\r\n CloseHandle(ProcessInfo.hThread);\r\n CloseHandle(ProcessInfo.hProcess);\r\n end;\r\nend;\r\n\r\nfunction WinExec32AndWait(Cmd: string; const CmdShow: Integer): Cardinal;\r\nvar\r\n StartupInfo: TStartupInfo;\r\n ProcessInfo: TProcessInformation;\r\nbegin\r\n Result := Cardinal($FFFFFFFF);\r\n ResetMemory(StartupInfo, SizeOf(TStartupInfo));\r\n ResetMemory(ProcessInfo, SizeOf(ProcessInfo));\r\n StartupInfo.cb := SizeOf(TStartupInfo);\r\n StartupInfo.dwFlags := STARTF_USESHOWWINDOW;\r\n StartupInfo.wShowWindow := CmdShow;\r\n UniqueString(Cmd);//in the Unicode version the parameter lpCommandLine needs to be writable\r\n if CreateProcess(nil, PChar(Cmd), nil, nil, False, NORMAL_PRIORITY_CLASS,\r\n nil, nil, StartupInfo, ProcessInfo) then\r\n begin\r\n WaitForInputIdle(ProcessInfo.hProcess, INFINITE);\r\n if WaitForSingleObject(ProcessInfo.hProcess, INFINITE) = WAIT_OBJECT_0 then\r\n begin\r\n if not GetExitCodeProcess(ProcessInfo.hProcess, Result) then\r\n Result := Cardinal($FFFFFFFF);\r\n end;\r\n CloseHandle(ProcessInfo.hThread);\r\n CloseHandle(ProcessInfo.hProcess);\r\n end;\r\nend;\r\n\r\nfunction WinExec32AndRedirectOutput(const Cmd: string; var Output: string; RawOutput: Boolean): Cardinal;\r\nbegin\r\n Result := Execute(Cmd, Output, RawOutput);\r\nend;\r\n\r\nfunction KillLevelToFlags(KillLevel: TJclKillLevel): Cardinal;\r\nbegin\r\n Result := 0;\r\n case KillLevel of\r\n klNoSignal:\r\n if not (GetWindowsVersion in [wvUnknown, wvWin95, wvWin95OSR2, wvWin98,\r\n wvWin98SE, wvWinME]) then\r\n Result := EWX_FORCE;\r\n klTimeOut:\r\n if not (GetWindowsVersion in [wvUnknown, wvWin95, wvWin95OSR2, wvWin98,\r\n wvWin98SE, wvWinME, wvWinNT31, wvWinNT35, wvWinNT351, wvWinNT4]) then\r\n Result := EWX_FORCEIFHUNG;\r\n end;\r\nend;\r\n\r\nfunction LogOffOS(KillLevel: TJclKillLevel): Boolean;\r\nbegin\r\n {$IFDEF MSWINDOWS}\r\n Result := JclMiscel.ExitWindows(EWX_LOGOFF or KillLevelToFlags(KillLevel));\r\n {$ENDIF MSWINDOWS}\r\n { TODO : implement at least LINUX variants throwing an exception }\r\nend;\r\n\r\nfunction PowerOffOS(KillLevel: TJclKillLevel): Boolean;\r\nbegin\r\n {$IFDEF MSWINDOWS}\r\n Result := JclMiscel.ExitWindows(EWX_POWEROFF or KillLevelToFlags(KillLevel));\r\n {$ENDIF MSWINDOWS}\r\nend;\r\n\r\nfunction ShutDownOS(KillLevel: TJclKillLevel): Boolean;\r\nbegin\r\n {$IFDEF MSWINDOWS}\r\n Result := JclMiscel.ExitWindows(EWX_SHUTDOWN or KillLevelToFlags(KillLevel));\r\n {$ENDIF MSWINDOWS}\r\nend;\r\n\r\nfunction RebootOS(KillLevel: TJclKillLevel): Boolean;\r\nbegin\r\n {$IFDEF MSWINDOWS}\r\n Result := JclMiscel.ExitWindows(EWX_REBOOT or KillLevelToFlags(KillLevel));\r\n {$ENDIF MSWINDOWS}\r\nend;\r\n\r\nfunction ExitWindows(ExitCode: Cardinal): Boolean;\r\nbegin\r\n { TODO -cTest : Check for Win9x }\r\n if (Win32Platform = VER_PLATFORM_WIN32_NT) and not EnableProcessPrivilege(True, SE_SHUTDOWN_NAME) then\r\n Result := False\r\n else\r\n Result := ExitWindowsEx(ExitCode, SHTDN_REASON_MAJOR_APPLICATION or SHTDN_REASON_MINOR_OTHER);\r\nend;\r\n\r\nfunction HibernateOS(Force, DisableWakeEvents: Boolean): Boolean;\r\nvar\r\n OldShutdownPrivilege: Boolean;\r\nbegin\r\n {$IFDEF MSWINDOWS}\r\n try\r\n OldShutdownPrivilege := IsPrivilegeEnabled(SE_SHUTDOWN_NAME);\r\n try\r\n Result := EnableProcessPrivilege(True, SE_SHUTDOWN_NAME)\r\n and SetSuspendState(True, Force, DisableWakeEvents);\r\n finally\r\n EnableProcessPrivilege(OldShutdownPrivilege, SE_SHUTDOWN_NAME);\r\n end;\r\n except\r\n Result := False;\r\n end;\r\n {$ENDIF MSWINDOWS}\r\nend;\r\n\r\nfunction SuspendOS(Force, DisableWakeEvents: Boolean): Boolean;\r\nvar\r\n OldShutdownPrivilege: Boolean;\r\nbegin\r\n {$IFDEF MSWINDOWS}\r\n try\r\n OldShutdownPrivilege := IsPrivilegeEnabled(SE_SHUTDOWN_NAME);\r\n try\r\n Result := EnableProcessPrivilege(True, SE_SHUTDOWN_NAME)\r\n and SetSuspendState(False, Force, DisableWakeEvents);\r\n finally\r\n EnableProcessPrivilege(OldShutdownPrivilege, SE_SHUTDOWN_NAME);\r\n end;\r\n except\r\n Result := False;\r\n end;\r\n {$ENDIF MSWINDOWS}\r\nend;\r\n\r\nfunction ShutDownDialog(const DialogMessage: string; TimeOut: DWORD;\r\n Force, Reboot: Boolean): Boolean;\r\nbegin\r\n Result := ShutDownDialog('', DialogMessage, TimeOut, Force, Reboot);\r\nend;\r\n\r\nfunction ShutDownDialog(const MachineName, DialogMessage: string; TimeOut: DWORD;\r\n Force, Reboot: Boolean): Boolean;\r\nvar\r\n OldShutdownPrivilege: Boolean;\r\n PrivilegeName: string;\r\nbegin\r\n {$IFDEF MSWINDOWS}\r\n if MachineName = '' then\r\n PrivilegeName := SE_SHUTDOWN_NAME\r\n else\r\n PrivilegeName := SE_REMOTE_SHUTDOWN_NAME;\r\n\r\n try\r\n OldShutdownPrivilege := IsPrivilegeEnabled(PrivilegeName);\r\n try\r\n Result := EnableProcessPrivilege(True, PrivilegeName)\r\n and InitiateSystemShutdown(PChar(MachineName), PChar(DialogMessage),\r\n TimeOut, Force, Reboot);\r\n finally\r\n EnableProcessPrivilege(OldShutdownPrivilege, PrivilegeName);\r\n end;\r\n except\r\n Result := False;\r\n end;\r\n {$ENDIF MSWINDOWS}\r\nend;\r\n\r\nfunction AbortShutDown: Boolean;\r\nbegin\r\n Result := AbortShutDown('');\r\nend;\r\n\r\nfunction AbortShutDown(const MachineName: string): Boolean;\r\nvar\r\n OldShutdownPrivilege: Boolean;\r\n PrivilegeName: string;\r\nbegin\r\n {$IFDEF MSWINDOWS}\r\n if MachineName = '' then\r\n PrivilegeName := SE_SHUTDOWN_NAME\r\n else\r\n PrivilegeName := SE_REMOTE_SHUTDOWN_NAME;\r\n\r\n try\r\n OldShutdownPrivilege := IsPrivilegeEnabled(PrivilegeName);\r\n try\r\n Result := EnableProcessPrivilege(True, PrivilegeName)\r\n and AbortSystemShutDown(PChar(MachineName));\r\n finally\r\n EnableProcessPrivilege(OldShutdownPrivilege, PrivilegeName);\r\n end;\r\n except\r\n Result := False;\r\n end;\r\n {$ENDIF MSWINDOWS}\r\nend;\r\n\r\nfunction GetAllowedPowerOperations: TJclAllowedPowerOperations;\r\nbegin\r\n {$IFDEF MSWINDOWS}\r\n Result := [];\r\n try\r\n if IsPwrSuspendAllowed then\r\n Include(Result, apoSuspend);\r\n if IsPwrHibernateAllowed then\r\n Include(Result, apoHibernate);\r\n if IsPwrShutdownAllowed then\r\n Include(Result, apoShutdown);\r\n except\r\n Result := [];\r\n end;\r\n {$ENDIF MSWINDOWS}\r\nend;\r\n\r\nprocedure CheckOSVersion;\r\nbegin\r\n if Win32Platform <> VER_PLATFORM_WIN32_NT then\r\n raise EJclError.CreateRes(@RsCreateProcNTRequiredError);\r\n if Win32BuildNumber < 1057 then\r\n raise EJclError.CreateRes(@RsCreateProcBuild1057Error);\r\nend;\r\n\r\nprocedure CreateProcAsUser(const UserDomain, UserName, PassWord, CommandLine: string);\r\nbegin\r\n CreateProcAsUserEx(UserDomain, UserName, Password, CommandLine, nil);\r\nend;\r\n\r\n{ TODO -cTest : Check for Win9x }\r\nprocedure CreateProcAsUserEx(const UserDomain, UserName, Password, CommandLine: string;\r\n const Environment: PChar);\r\nconst\r\n // default values for window stations and desktops\r\n CreateProcDEFWINSTATION = 'WinSta0';\r\n CreateProcDEFDESKTOP = 'Default';\r\n // CreateProcDOMUSERSEP = '\\';\r\nvar\r\n ConsoleTitle: string;\r\n Help: string;\r\n WinStaName: string;\r\n DesktopName: string;\r\n hUserToken: THandle;\r\n hWindowStation: HWINSTA;\r\n hDesktop: HDESK;\r\n StartUpInfo: TStartUpInfo;\r\n ProcInfo: TProcessInformation;\r\nbegin\r\n\r\n // Step 1: check for the correct OS version\r\n CheckOSVersion;\r\n\r\n // Step 2: logon as the specified user\r\n hUserToken := 0;\r\n if not LogonUser(PChar(UserName), PChar(UserDomain), PChar(Password),\r\n LOGON32_LOGON_INTERACTIVE, LOGON32_PROVIDER_DEFAULT, hUserToken) then\r\n begin\r\n case GetLastError of\r\n ERROR_PRIVILEGE_NOT_HELD:\r\n raise EJclCreateProcessError.CreateResFmt(@RsCreateProcPrivilegeMissing,\r\n [GetPrivilegeDisplayName(SE_TCB_NAME), SE_TCB_NAME]);\r\n ERROR_LOGON_FAILURE:\r\n raise EJclCreateProcessError.CreateRes(@RsCreateProcLogonUserError);\r\n ERROR_ACCESS_DENIED:\r\n raise EJclCreateProcessError.CreateRes(@RsCreateProcAccessDenied);\r\n else\r\n raise EJclCreateProcessError.CreateRes(@RsCreateProcLogonFailed);\r\n end;\r\n end;\r\n\r\n // Step 3: give the new user access to the current WindowStation and Desktop\r\n hWindowStation:= GetProcessWindowStation;\r\n WinStaName := GetUserObjectName(hWindowStation);\r\n if WinStaName = '' then\r\n WinStaName := CreateProcDEFWINSTATION;\r\n\r\n if not SetUserObjectFullAccess(hWindowStation) then\r\n begin\r\n CloseHandle(hUserToken);\r\n raise EJclCreateProcessError.CreateResFmt(@RsCreateProcSetStationSecurityError, [WinStaName]);\r\n end;\r\n\r\n hDesktop := GetThreadDesktop(GetCurrentThreadId);\r\n DesktopName := GetUserObjectName(hDesktop);\r\n if DesktopName = '' then\r\n DesktopName := CreateProcDEFDESKTOP;\r\n\r\n if not SetUserObjectFullAccess(hDesktop) then\r\n begin\r\n CloseHandle(hUserToken);\r\n raise EJclCreateProcessError.CreateResFmt(@RsCreateProcSetDesktopSecurityError, [DesktopName]);\r\n end;\r\n\r\n // Step 4: set the startup info for the new process\r\n ConsoleTitle := UserDomain + UserName;\r\n ResetMemory(StartUpInfo, SizeOf(StartUpInfo));\r\n with StartUpInfo do\r\n begin\r\n cb:= SizeOf(StartUpInfo);\r\n lpTitle:= PChar(ConsoleTitle);\r\n Help := WinStaName + '\\' + DeskTopName;\r\n lpDesktop:= PChar(Help);\r\n end;\r\n\r\n // Step 5: create the child process\r\n if not CreateProcessAsUser(hUserToken, nil, PChar(CommandLine), nil, nil,\r\n False, CREATE_NEW_CONSOLE or CREATE_NEW_PROCESS_GROUP, Environment, nil,\r\n {$IFDEF FPC}\r\n @StartUpInfo, @ProcInfo) then\r\n {$ELSE ~FPC}\r\n StartUpInfo, ProcInfo) then\r\n {$ENDIF ~FPC}\r\n begin\r\n case GetLastError of\r\n ERROR_PRIVILEGE_NOT_HELD:\r\n raise EJclCreateProcessError.CreateResFmt(@RsCreateProcPrivilegesMissing,\r\n [GetPrivilegeDisplayName(SE_ASSIGNPRIMARYTOKEN_NAME), SE_ASSIGNPRIMARYTOKEN_NAME,\r\n GetPrivilegeDisplayName(SE_INCREASE_QUOTA_NAME), SE_INCREASE_QUOTA_NAME]);\r\n ERROR_FILE_NOT_FOUND:\r\n raise EJclCreateProcessError.CreateResFmt(@RsCreateProcCommandNotFound, [CommandLine]);\r\n else\r\n raise EJclCreateProcessError.CreateRes(@RsCreateProcFailed);\r\n end;\r\n end;\r\n\r\n // clean up\r\n CloseWindowStation(hWindowStation);\r\n CloseDesktop(hDesktop);\r\n CloseHandle(hUserToken);\r\n\r\n // if this code should be called although there has\r\n // been an exception during invocation of CreateProcessAsUser,\r\n // it will quite surely fail. you should make sure this doesn't happen.\r\n // (it shouldn't happen due to the use of exceptions in the above lines)\r\n CloseHandle(ProcInfo.hThread);\r\n CloseHandle(ProcInfo.hProcess);\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jcl/source/windows/JclMsBuild.pas", "content": "{**************************************************************************************************}\r\n{ }\r\n{ Project JEDI Code Library (JCL) }\r\n{ }\r\n{ The contents of this file are subject to the Mozilla Public License Version 1.1 (the \"License\"); }\r\n{ you may not use this file except in compliance with the License. You may obtain a copy of the }\r\n{ License at http://www.mozilla.org/MPL/ }\r\n{ }\r\n{ Software distributed under the License is distributed on an \"AS IS\" basis, WITHOUT WARRANTY OF }\r\n{ ANY KIND, either express or implied. See the License for the specific language governing rights }\r\n{ and limitations under the License. }\r\n{ }\r\n{ The Original Code is JclMsBuild.pas. }\r\n{ }\r\n{ The Initial Developer of the Original Code is Florent Ouchet. }\r\n{ Portions created by Florent Ouchet are Copyright (C) of Florent Ouchet. All Rights Reserved. }\r\n{ }\r\n{ Contributor(s): }\r\n{ }\r\n{**************************************************************************************************}\r\n{ }\r\n{ Routines around MsBuild project files. }\r\n{ }\r\n{**************************************************************************************************}\r\n{ }\r\n{ Last modified: $Date:: 2012-08-30 15:49:38 +0200 (jeu. 30 août 2012) $ }\r\n{ Revision: $Rev:: 3854 $ }\r\n{ Author: $Author:: outchy $ }\r\n{ }\r\n{**************************************************************************************************}\r\n\r\nunit JclMsBuild;\r\n\r\n{$I jcl.inc}\r\n{$I windowsonly.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows,\r\n SysUtils,\r\n Classes,\r\n Contnrs,\r\n JclBase,\r\n JclFileUtils,\r\n JclRegistry,\r\n JclStreams,\r\n JclSimpleXml,\r\n JclSysInfo;\r\n\r\n(* simple test procedure: load Jcl.dproj and emit custom properties and files to be compiled\r\n\r\nprocedure Test;\r\nvar\r\n MsBuildParser: TJclMsBuildParser;\r\nbegin\r\n MsBuildParser := TJclMsBuildParser.Create('C:\\dev\\jcl\\jcl\\packages\\d11\\Jcl.dproj');\r\n try\r\n MsBuildParser.Init;\r\n MsBuildParser.Parse;\r\n WriteLn(MsBuildParser.Properties.CustomProperties.Text);\r\n WriteLn(MsBuildParser.EvaluateString('@(DCCReference->''%(FullPath)'')'));\r\n finally\r\n MsBuildParser.Free;\r\n end;\r\nend; *)\r\n\r\ntype\r\n EJclMsBuildError = class(EJclError);\r\n\r\n TJclMsBuildItem = class\r\n private\r\n FItemName: string;\r\n FItemInclude: string;\r\n FItemFullInclude: string; //full path\r\n FItemExclude: string;\r\n FItemRemove: string;\r\n FItemMetaData: TStrings;\r\n public\r\n constructor Create;\r\n destructor Destroy; override;\r\n property ItemName: string read FItemName;\r\n property ItemInclude: string read FItemInclude;\r\n property ItemFullInclude: string read FItemFullInclude;\r\n property ItemExclude: string read FItemExclude;\r\n property ItemRemove: string read FItemRemove;\r\n property ItemMetaData: TStrings read FItemMetaData;\r\n end;\r\n\r\n TJclMsBuildTaskOutput = class\r\n private\r\n FTaskParameter: string;\r\n FPropertyName: string;\r\n FItemName: string;\r\n public\r\n property TaskParameter: string read FTaskParameter;\r\n property PropertyName: string read FPropertyName;\r\n property ItemName: string read FItemName;\r\n end;\r\n\r\n TJclMsBuildParameter = class\r\n private\r\n FParameterName: string;\r\n FParameterType: string;\r\n FOutput: Boolean;\r\n FRequired: Boolean;\r\n public\r\n property ParameterName: string read FParameterName;\r\n property ParameterType: string read FParameterType;\r\n property Output: Boolean read FOutput;\r\n property Required: Boolean read FRequired;\r\n end;\r\n\r\n TJclMsBuildUsingTask = class\r\n private\r\n FAssemblyName: string;\r\n FAssemblyFile: string;\r\n FTaskFactory: string;\r\n FTaskName: string;\r\n FParameters: TObjectList;\r\n FTaskBody: string;\r\n function AddParameter(Parameter: TJclMsBuildParameter): Integer;\r\n function GetParameterCount: Integer;\r\n function GetParameter(Index: Integer): TJclMsBuildParameter;\r\n public\r\n constructor Create;\r\n destructor Destroy; override;\r\n property AssemblyName: string read FAssemblyName;\r\n property AssemblyFile: string read FAssemblyFile;\r\n property TaskFactory: string read FTaskFactory;\r\n property TaskName: string read FTaskName;\r\n property ParameterCount: Integer read GetParameterCount;\r\n property Parameters[Index: Integer]: TJclMsBuildParameter read GetParameter;\r\n property TaskBody: string read FTaskBody;\r\n end;\r\n\r\n TJclMsBuildTask = class\r\n private\r\n FTaskName: string;\r\n FContinueOnError: Boolean;\r\n FParameters: TStrings;\r\n FOutputs: TObjectList;\r\n function AddOutput(AOutput: TJclMsBuildTaskOutput): Integer;\r\n function GetOutputCount: Integer;\r\n function GetOutput(Index: Integer): TJclMsBuildTaskOutput;\r\n public\r\n constructor Create;\r\n destructor Destroy; override;\r\n property TaskName: string read FTaskName;\r\n property ContinueOnError: Boolean read FContinueOnError;\r\n property Parameters: TStrings read FParameters;\r\n property OutputCount: Integer read GetOutputCount;\r\n property Outputs[Index: Integer]: TJclMsBuildTaskOutput read GetOutput;\r\n end;\r\n\r\n TJclMsBuildTarget = class\r\n private\r\n FTargetName: string;\r\n FDepends: TStrings;\r\n FReturns: TStrings;\r\n FInputs: TStrings;\r\n FOutputs: TStrings;\r\n FBeforeTargets: TStrings;\r\n FAfterTargets: TStrings;\r\n FKeepDuplicateOutputs: Boolean;\r\n FTasks: TObjectList;\r\n FErrorTargets: TStrings;\r\n function AddTask(Task: TJclMsBuildTask): Integer;\r\n function GetTaskCount: Integer;\r\n function GetTask(Index: Integer): TJclMsBuildTask;\r\n public\r\n constructor Create;\r\n destructor Destroy; override;\r\n property TargetName: string read FTargetName;\r\n property Depends: TStrings read FDepends;\r\n property Returns: TStrings read FReturns;\r\n property Inputs: TStrings read FInputs;\r\n property Outputs: TStrings read FOutputs;\r\n property BeforeTargets: TStrings read FBeforeTargets;\r\n property AfterTargets: TStrings read FAfterTargets;\r\n property KeepDuplicateOutputs: Boolean read FKeepDuplicateOutputs;\r\n property TaskCount: Integer read GetTaskCount;\r\n property Tasks[Index: Integer]: TJclMsBuildTask read GetTask;\r\n property ErrorTargets: TStrings read FErrorTargets;\r\n end;\r\n\r\n TJclMsBuildParser = class;\r\n\r\n // TStrings wrapper for all the MsBuild properties, values are searched\r\n // in the following ordered property classes:\r\n // - reserved properties defined by MsBuild,\r\n // their value cannot be overriden or an error will be raised\r\n // - properties taken from the emulated \"command line\"\r\n // their value cannot be overriden, no error is raised\r\n // - custom properties defined by the script\r\n // - environment properties taken from the environment variables\r\n // their value can be silently overriden\r\n // - registry properties handled by event\r\n // - function properties handled by event\r\n\r\n TJclMsBuildProperties = class(TStrings)\r\n private\r\n FParser: TJclMsBuildParser;\r\n FReservedProperties: TStrings;\r\n FGlobalProperties: TStrings;\r\n FCustomProperties: TStrings;\r\n FEnvironmentProperties: TStrings;\r\n protected\r\n function Get(Index: Integer): string; override;\r\n function GetCount: Integer; override;\r\n function GetObject(Index: Integer): TObject; override;\r\n function GetRawValue(const Name: string): string;\r\n procedure Put(Index: Integer; const S: string); override;\r\n procedure PutObject(Index: Integer; AObject: TObject); override;\r\n procedure SetRawValue(const Name, Value: string);\r\n public\r\n constructor Create(AParser: TJclMsBuildParser);\r\n destructor Destroy; override;\r\n\r\n property Parser: TJclMsBuildParser read FParser;\r\n\r\n procedure Clear; override;\r\n\r\n procedure Delete(Index: Integer); override;\r\n function IndexOf(const S: string): Integer; override;\r\n procedure Insert(Index: Integer; const S: string); override;\r\n\r\n property ReservedProperties: TStrings read FReservedProperties;\r\n property EnvironmentProperties: TStrings read FEnvironmentProperties;\r\n property GlobalProperties: TStrings read FGlobalProperties;\r\n property CustomProperties: TStrings read FCustomProperties;\r\n\r\n property RawValues[const Name: string]: string read GetRawValue write SetRawValue;\r\n end;\r\n\r\n TJclMsBuildImportEvent = procedure (Sender: TJclMsBuildParser; var FileName: TFileName;\r\n var SubXml: TJclSimpleXml; var SubOwnsXml: Boolean) of object;\r\n TJclMsBuildToolsVersionEvent = procedure (Sender: TJclMsBuildParser; const ToolsVersion: string) of object;\r\n TJclMsBuildRegistryPropertyEvent = function (Sender: TJclMsBuildParser; Root: HKEY;\r\n const Path, Name: string; out Value: string): Boolean of object;\r\n TJclMsBuildFunctionPropertyEvent = function (Sender: TJclMsBuildParser; const Command: string;\r\n out Value: string): Boolean of object;\r\n\r\n TJclMsBuildParser = class\r\n private\r\n FCurrentFileName: TFileName;\r\n FProjectFileName: TFileName;\r\n FXml: TJclSimpleXml;\r\n FOwnsXml: Boolean;\r\n FProperties: TJclMsBuildProperties;\r\n FItems: TObjectList;\r\n FItemDefinitions: TObjectList;\r\n FTargets: TObjectList;\r\n FUsingTasks: TObjectList;\r\n FInitialTargets: TStrings;\r\n FDefaultTargets: TStrings;\r\n FToolsVersion: string;\r\n FDotNetVersion: string;\r\n FIgnoreFunctionProperties: Boolean;\r\n FWorkingDirectory: string;\r\n FFirstPropertyGroup: TJclSimpleXMLElem;\r\n FProjectExtensions: TJclSimpleXMLElem;\r\n FOnImport: TJclMsBuildImportEvent;\r\n FOnToolsVersion: TJclMsBuildToolsVersionEvent;\r\n FOnRegistryProperty: TJclMsBuildRegistryPropertyEvent;\r\n FOnFunctionProperty: TJclMsBuildFunctionPropertyEvent;\r\n function GetItemCount: Integer;\r\n function GetItem(Index: Integer): TJclMsBuildItem;\r\n function GetItemDefinitionCount: Integer;\r\n function GetItemDefinition(Index: Integer): TJclMsBuildItem;\r\n function GetTargetCount: Integer;\r\n function GetTarget(Index: Integer): TJclMsBuildTarget;\r\n function GetUsingTaskCount: Integer;\r\n function GetUsingTask(Index: Integer): TJclMsBuildUsingTask;\r\n procedure ParseChoose(XmlElem: TJclSimpleXmlElem);\r\n procedure ParseImport(XmlElem: TJclSimpleXmlElem);\r\n procedure ParseImportGroup(XmlElem: TJclSimpleXmlElem);\r\n procedure ParseItem(XmlElem: TJclSimpleXmlElem; Definition: Boolean);\r\n procedure ParseItemDefinitionGroup(XmlElem: TJclSimpleXmlElem);\r\n procedure ParseItemGroup(XmlElem: TJclSimpleXmlElem);\r\n procedure ParseItemMetaData(XmlElem: TJclSimpleXmlElem; ItemMetaData: TStrings);\r\n procedure ParseOnError(XmlElem: TJclSimpleXMLElem; Target: TJclMsBuildTarget);\r\n function ParseOtherwise(XmlElem: TJclSimpleXmlElem; Skip: Boolean): Boolean;\r\n procedure ParseOutput(XmlElem: TJclSimpleXMLElem; Task: TJclMsBuildTask);\r\n procedure ParseParameter(XmlElem: TJclSimpleXMLElem; UsingTask: TJclMsBuildUsingTask);\r\n procedure ParseParameterGroup(XmlElem: TJclSimpleXMLElem; UsingTask: TJclMsBuildUsingTask);\r\n procedure ParseProject(XmlElem: TJclSimpleXmlElem);\r\n procedure ParseProperty(XmlElem: TJclSimpleXmlElem);\r\n procedure ParsePropertyGroup(XmlElem: TJclSimpleXmlElem);\r\n procedure ParseTarget(XmlElem: TJclSimpleXmlElem);\r\n procedure ParseTask(XmlElem: TJclSimpleXMLElem; Target: TJclMsBuildTarget);\r\n procedure ParseTaskBody(XmlElem: TJclSimpleXMLElem; UsingTask: TJclMsBuildUsingTask);\r\n procedure ParseUsingTask(XmlElem: TJclSimpleXmlElem);\r\n function ParseWhen(XmlElem: TJclSimpleXmlElem; Skip: Boolean): Boolean;\r\n procedure ParseXml(AXml: TJclSimpleXML);\r\n protected\r\n function GetPropertyValue(const Name: string): string; virtual;\r\n procedure SetPropertyValue(const Name, Value: string); virtual;\r\n public\r\n // evaluate known MsBuild properties\r\n // http://msdn.microsoft.com/en-us/library/ms171458.aspx\r\n function EvaluateFunctionProperty(const Command: string): string;\r\n function EvaluateList(const Name: string): string;\r\n function EvaluateRegistryProperty(Root: HKEY; const Path, Name: string): string;\r\n function EvaluateString(const S: string): string;\r\n function EvaluateTransform(ItemList: TStrings; const Transform: string): string;\r\n public\r\n // this function parses MsBuild condition as described at:\r\n // http://msdn.microsoft.com/en-us/library/7szfhaft.aspx\r\n function ParseCondition(const Condition: string): Boolean;\r\n function ParseConditionLength(const Condition: string; var Position: Integer; Len: Integer): Boolean;\r\n function ParseConditionOperand(const Condition: string; var Position: Integer; Len: Integer): Boolean;\r\n function ParseConditionString(const Condition: string; var Position: Integer; Len: Integer): string;\r\n public\r\n constructor Create(const AFileName: TFileName; AXml: TJclSimpleXml; AOwnsXml: Boolean = False); overload;\r\n constructor Create(const AFileName: TFileName; Encoding: TJclStringEncoding = seAuto; CodePage: Word = CP_ACP); overload;\r\n constructor Create(const AFileName: TFileName; ExtraImportsFileName: array of string; Encoding: TJclStringEncoding = seAuto; CodePage: Word = CP_ACP); overload;\r\n destructor Destroy; override;\r\n\r\n procedure Clear;\r\n procedure ClearItems;\r\n procedure ClearItemDefinitions;\r\n procedure ClearTargets;\r\n\r\n procedure Parse;\r\n procedure Save;\r\n\r\n procedure FindItemIncludes(const ItemName: string; List: TStrings);\r\n function FindItemDefinition(const ItemName: string): TJclMsBuildItem;\r\n function FindTarget(const TargetName: string): TJclMsBuildTarget;\r\n\r\n class function SameItemName(const ItemName1, ItemName2: string): Boolean;\r\n\r\n procedure Init;\r\n procedure InitEnvironmentProperties;\r\n procedure InitReservedProperties;\r\n\r\n // encode just <, > and &\r\n procedure XMLEncodeValue(Sender: TObject; var Value: string);\r\n // decode all entities\r\n procedure XMLDecodeValue(Sender: TObject; var Value: string);\r\n\r\n property CurrentFileName: TFileName read FCurrentFileName;\r\n property ProjectFileName: TFileName read FProjectFileName;\r\n property Xml: TJclSimpleXml read FXml;\r\n property OwnsXml: Boolean read FOwnsXml write FOwnsXml;\r\n property Properties: TJclMsBuildProperties read FProperties;\r\n property ItemCount: Integer read GetItemCount;\r\n property Items[Index: Integer]: TJclMsBuildItem read GetItem;\r\n property ItemDefinitionCount: Integer read GetItemDefinitionCount;\r\n property ItemDefinitions[Index: Integer]: TJclMsBuildItem read GetItemDefinition;\r\n property TargetCount: Integer read GetTargetCount;\r\n property Targets[Index: Integer]: TJclMsBuildTarget read GetTarget;\r\n property UsingTaskCount: Integer read GetUsingTaskCount;\r\n property UsingTasks[Index: Integer]: TJclMsBuildUsingTask read GetUsingTask;\r\n property ProjectExtensions: TJclSimpleXMLElem read FProjectExtensions;\r\n property InitialTargets: TStrings read FInitialTargets;\r\n property DefaultTargets: TStrings read FDefaultTargets;\r\n property ToolsVersion: string read FToolsVersion;\r\n property DotNetVersion: string read FDotNetVersion write FDotNetVersion;\r\n property IgnoreFunctionProperties: Boolean read FIgnoreFunctionProperties write FIgnoreFunctionProperties;\r\n property WorkingDirectory: string read FWorkingDirectory write FWorkingDirectory;\r\n property OnImport: TJclMsBuildImportEvent read FOnImport write FOnImport;\r\n property OnToolsVersion: TJclMsBuildToolsVersionEvent read FOnToolsVersion write FOnToolsVersion;\r\n property OnRegistryProperty: TJclMsBuildRegistryPropertyEvent read FOnRegistryProperty write FOnRegistryProperty;\r\n property OnFunctionProperty: TJclMsBuildFunctionPropertyEvent read FOnFunctionProperty write FOnFunctionProperty;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jcl.svn.sourceforge.net/svnroot/jcl/tags/JCL-2.4-Build4571/jcl/source/windows/JclMsBuild.pas $';\r\n Revision: '$Revision: 3854 $';\r\n Date: '$Date: 2012-08-30 15:49:38 +0200 (jeu. 30 août 2012) $';\r\n LogPath: 'JCL\\source\\windows';\r\n Extra: '';\r\n Data: nil\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n SysConst,\r\n JclWin32,\r\n JclDotNet,\r\n JclShell,\r\n JclStrings,\r\n JclDevToolsResources;\r\n\r\n//=== { TJclMsBuildItem } ====================================================\r\n\r\nconstructor TJclMsBuildItem.Create;\r\nbegin\r\n inherited Create;\r\n FItemMetaData := TStringList.Create;\r\nend;\r\n\r\ndestructor TJclMsBuildItem.Destroy;\r\nbegin\r\n FItemMetaData.Free;\r\n inherited Destroy;\r\nend;\r\n\r\n//=== { TJclMsBuildUsingTask } ===============================================\r\n\r\nfunction TJclMsBuildUsingTask.AddParameter(Parameter: TJclMsBuildParameter): Integer;\r\nbegin\r\n Result := FParameters.Add(Parameter);\r\nend;\r\n\r\nconstructor TJclMsBuildUsingTask.Create;\r\nbegin\r\n inherited Create;\r\n FParameters := TObjectList.Create(True);\r\nend;\r\n\r\ndestructor TJclMsBuildUsingTask.Destroy;\r\nbegin\r\n FParameters.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJclMsBuildUsingTask.GetParameter(\r\n Index: Integer): TJclMsBuildParameter;\r\nbegin\r\n Result := TJclMsBuildParameter(FParameters.Items[Index]);\r\nend;\r\n\r\nfunction TJclMsBuildUsingTask.GetParameterCount: Integer;\r\nbegin\r\n Result := FParameters.Count;\r\nend;\r\n\r\n//=== { TJclMsBuildTask } ====================================================\r\n\r\nconstructor TJclMsBuildTask.Create;\r\nbegin\r\n inherited Create;\r\n FParameters := TStringList.Create;\r\n FOutputs := TObjectList.Create(True);\r\nend;\r\n\r\ndestructor TJclMsBuildTask.Destroy;\r\nbegin\r\n FOutputs.Free;\r\n FParameters.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJclMsBuildTask.AddOutput(AOutput: TJclMsBuildTaskOutput): Integer;\r\nbegin\r\n Result := FOutputs.Add(AOutput);\r\nend;\r\n\r\nfunction TJclMsBuildTask.GetOutput(Index: Integer): TJclMsBuildTaskOutput;\r\nbegin\r\n Result := TJclMsBuildTaskOutput(FOutputs.Items[Index]);\r\nend;\r\n\r\nfunction TJclMsBuildTask.GetOutputCount: Integer;\r\nbegin\r\n Result := FOutputs.Count;\r\nend;\r\n\r\n//=== { TJclMsBuildTarget } ==================================================\r\n\r\nconstructor TJclMsBuildTarget.Create;\r\nbegin\r\n inherited Create;\r\n FDepends := TStringList.Create;\r\n FReturns := TStringList.Create;\r\n FInputs := TStringList.Create;\r\n FOutputs := TStringList.Create;\r\n FBeforeTargets := TStringList.Create;\r\n FAfterTargets := TStringList.Create;\r\n FTasks := TObjectList.Create(True);\r\n FErrorTargets := TStringList.Create;\r\nend;\r\n\r\ndestructor TJclMsBuildTarget.Destroy;\r\nbegin\r\n FErrorTargets.Free;\r\n FTasks.Free;\r\n FAfterTargets.Free;\r\n FBeforeTargets.Free;\r\n FOutputs.Free;\r\n FInputs.Free;\r\n FReturns.Free;\r\n FDepends.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJclMsBuildTarget.AddTask(Task: TJclMsBuildTask): Integer;\r\nbegin\r\n Result := FTasks.Add(Task);\r\nend;\r\n\r\nfunction TJclMsBuildTarget.GetTask(Index: Integer): TJclMsBuildTask;\r\nbegin\r\n Result := TJclMsBuildTask(FTasks.Items[Index]);\r\nend;\r\n\r\nfunction TJclMsBuildTarget.GetTaskCount: Integer;\r\nbegin\r\n Result := FTasks.Count;\r\nend;\r\n\r\n//=== { TJclMsBuildProperties } ==============================================\r\n\r\nconstructor TJclMsBuildProperties.Create(AParser: TJclMsBuildParser);\r\nbegin\r\n inherited Create;\r\n FParser := AParser;\r\n FReservedProperties := TStringList.Create;\r\n FGlobalProperties := TStringList.Create;\r\n FCustomProperties := TStringList.Create;\r\n FEnvironmentProperties := TStringList.Create;\r\nend;\r\n\r\ndestructor TJclMsBuildProperties.Destroy;\r\nbegin\r\n FEnvironmentProperties.Free;\r\n FCustomProperties.Free;\r\n FGlobalProperties.Free;\r\n FReservedProperties.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJclMsBuildProperties.Clear;\r\nbegin\r\n ReservedProperties.Clear;\r\n CustomProperties.Clear;\r\n EnvironmentProperties.Clear;\r\n GlobalProperties.Clear;\r\nend;\r\n\r\nprocedure TJclMsBuildProperties.Delete(Index: Integer);\r\nbegin\r\n // - reserved properties defined by MsBuild,\r\n // their value cannot be overriden or an error will be raised\r\n if (Index >= 0) and (Index < FReservedProperties.Count) then\r\n raise EJclMsBuildError.CreateRes(@RsEReservedProperty);\r\n Dec(Index, FReservedProperties.Count);\r\n\r\n // - properties taken from the emulated \"command line\"\r\n // their value cannot be overriden, no error is raised\r\n if (Index >= 0) and (Index < FGlobalProperties.Count) then\r\n Exit;\r\n Dec(Index, FGlobalProperties.Count);\r\n \r\n // - custom properties defined by the script\r\n if (Index >= 0) and (Index < FCustomProperties.Count) then\r\n begin\r\n FCustomProperties.Delete(Index);\r\n Exit;\r\n end;\r\n Dec(Index, FCustomProperties.Count);\r\n\r\n // - environment properties taken from the environment variables\r\n // their value can be silently overriden\r\n if (Index >= 0) and (Index < FEnvironmentProperties.Count) then\r\n begin\r\n FEnvironmentProperties.Delete(Index);\r\n Exit;\r\n end;\r\n \r\n raise EJclMsBuildError.CreateRes(@SRangeError);\r\nend;\r\n\r\nfunction TJclMsBuildProperties.Get(Index: Integer): string;\r\nbegin\r\n // - reserved properties defined by MsBuild,\r\n if (Index >= 0) and (Index < FReservedProperties.Count) then\r\n begin\r\n Result := FReservedProperties.Strings[Index];\r\n Exit;\r\n end;\r\n Dec(Index, FReservedProperties.Count);\r\n\r\n // - properties taken from the emulated \"command line\"\r\n if (Index >= 0) and (Index < FGlobalProperties.Count) then\r\n begin\r\n Result := FGlobalProperties.Strings[Index];\r\n Exit;\r\n end;\r\n Dec(Index, FGlobalProperties.Count);\r\n\r\n // - custom properties defined by the script\r\n if (Index >= 0) and (Index < FCustomProperties.Count) then\r\n begin\r\n Result := FCustomProperties.Strings[Index];\r\n Exit;\r\n end;\r\n Dec(Index, FCustomProperties.Count);\r\n\r\n // - environment properties taken from the environment variables\r\n if (Index >= 0) and (Index < FEnvironmentProperties.Count) then\r\n begin\r\n Result := FEnvironmentProperties.Strings[Index];\r\n Exit;\r\n end;\r\n \r\n raise EJclMsBuildError.CreateRes(@SRangeError);\r\nend;\r\n\r\nfunction TJclMsBuildProperties.GetCount: Integer;\r\nbegin\r\n Result := FReservedProperties.Count + FGlobalProperties.Count +\r\n FCustomProperties.Count + FEnvironmentProperties.Count;\r\nend;\r\n\r\nfunction TJclMsBuildProperties.GetObject(Index: Integer): TObject;\r\nbegin\r\n // - reserved properties defined by MsBuild,\r\n if (Index >= 0) and (Index < FReservedProperties.Count) then\r\n begin\r\n Result := FReservedProperties.Objects[Index];\r\n Exit;\r\n end;\r\n Dec(Index, FReservedProperties.Count);\r\n\r\n // - properties taken from the emulated \"command line\"\r\n if (Index >= 0) and (Index < FGlobalProperties.Count) then\r\n begin\r\n Result := FGlobalProperties.Objects[Index];\r\n Exit;\r\n end;\r\n Dec(Index, FGlobalProperties.Count);\r\n\r\n // - custom properties defined by the script\r\n if (Index >= 0) and (Index < FCustomProperties.Count) then\r\n begin\r\n Result := FCustomProperties.Objects[Index];\r\n Exit;\r\n end;\r\n Dec(Index, FCustomProperties.Count);\r\n\r\n // - environment properties taken from the environment variables\r\n if (Index >= 0) and (Index < FEnvironmentProperties.Count) then\r\n begin\r\n Result := FEnvironmentProperties.Objects[Index];\r\n Exit;\r\n end;\r\n \r\n raise EJclMsBuildError.CreateRes(@SRangeError);\r\nend;\r\n\r\nfunction TJclMsBuildProperties.GetRawValue(const Name: string): string;\r\nvar\r\n Index: Integer;\r\n XmlElem: TJclSimpleXmlElem;\r\nbegin\r\n Index := IndexOfName(Name);\r\n XmlElem := nil;\r\n if Index >= 0 then\r\n XmlElem := TJclSimpleXMLElem(Objects[Index]);\r\n if Assigned(XmlElem) then\r\n Result := XmlElem.Value\r\n else\r\n Result := '';\r\nend;\r\n\r\nfunction TJclMsBuildProperties.IndexOf(const S: string): Integer;\r\nbegin\r\n // - reserved properties defined by MsBuild,\r\n Result := FReservedProperties.IndexOf(S);\r\n if Result >= 0 then\r\n Exit;\r\n\r\n // - properties taken from the emulated \"command line\"\r\n Result := FGlobalProperties.IndexOf(S);\r\n if Result >= 0 then\r\n begin\r\n Inc(Result, FReservedProperties.Count);\r\n Exit;\r\n end;\r\n\r\n // - custom properties defined by the script\r\n Result := FCustomProperties.IndexOf(S);\r\n if Result >= 0 then\r\n begin\r\n Inc(Result, FReservedProperties.Count);\r\n Inc(Result, FGlobalProperties.Count);\r\n Exit;\r\n end;\r\n\r\n // - environment properties taken from the environment variables\r\n Result := FEnvironmentProperties.IndexOf(S);\r\n if Result >= 0 then\r\n begin\r\n Inc(Result, FReservedProperties.Count);\r\n Inc(Result, FGlobalProperties.Count);\r\n Inc(Result, FCustomProperties.Count);\r\n Exit;\r\n end;\r\nend;\r\n\r\nprocedure TJclMsBuildProperties.Insert(Index: Integer; const S: string);\r\nbegin\r\n // - reserved properties defined by MsBuild,\r\n // their value cannot be overriden or an error will be raised\r\n if (Index >= 0) and (Index < FReservedProperties.Count) then\r\n raise EJclMsBuildError.CreateRes(@RsEReservedProperty);\r\n Dec(Index, FReservedProperties.Count);\r\n\r\n // - properties taken from the emulated \"command line\"\r\n // their value cannot be overriden, no error is raised\r\n if (Index >= 0) and (Index < FGlobalProperties.Count) then\r\n Exit;\r\n Dec(Index, FGlobalProperties.Count);\r\n\r\n // - custom properties defined by the script\r\n if (Index >= 0) and (Index < FCustomProperties.Count) then\r\n begin\r\n FCustomProperties.Insert(Index, S);\r\n Exit;\r\n end;\r\n Dec(Index, FCustomProperties.Count);\r\n\r\n // - environment properties taken from the environment variables\r\n // their value can be silently overriden\r\n if (Index >= 0) and (Index <= FEnvironmentProperties.Count) then\r\n begin\r\n FCustomProperties.Add(S);\r\n Exit;\r\n end;\r\n \r\n raise EJclMsBuildError.CreateRes(@SRangeError);\r\nend;\r\n\r\nprocedure TJclMsBuildProperties.Put(Index: Integer; const S: string);\r\nbegin\r\n // - reserved properties defined by MsBuild,\r\n // their value cannot be overriden or an error will be raised\r\n if (Index >= 0) and (Index < FReservedProperties.Count) then\r\n raise EJclMsBuildError.CreateRes(@RsEReservedProperty);\r\n Dec(Index, FReservedProperties.Count);\r\n\r\n // - properties taken from the emulated \"command line\"\r\n // their value cannot be overriden, no error is raised\r\n if (Index >= 0) and (Index < FGlobalProperties.Count) then\r\n Exit;\r\n Dec(Index, FGlobalProperties.Count);\r\n\r\n // - custom properties defined by the script\r\n if (Index >= 0) and (Index < FCustomProperties.Count) then\r\n begin\r\n FCustomProperties.Strings[Index] := S;\r\n Exit;\r\n end;\r\n Dec(Index, FCustomProperties.Count);\r\n\r\n // - environment properties taken from the environment variables\r\n // their value can be silently overriden\r\n if (Index >= 0) and (Index < FEnvironmentProperties.Count) then\r\n begin\r\n if (FCustomProperties.Count > 0) and (FCustomProperties.Strings[FCustomProperties.Count - 1] = '') then\r\n FCustomProperties.Strings[FCustomProperties.Count - 1] := S\r\n else\r\n FCustomProperties.Add(S);\r\n Exit;\r\n end;\r\n \r\n raise EJclMsBuildError.CreateRes(@SRangeError);\r\nend;\r\n\r\nprocedure TJclMsBuildProperties.PutObject(Index: Integer; AObject: TObject);\r\nbegin\r\n // - reserved properties defined by MsBuild,\r\n if (Index >= 0) and (Index < FReservedProperties.Count) then\r\n begin\r\n FReservedProperties.Objects[Index] := AObject;\r\n Exit;\r\n end;\r\n Dec(Index, FReservedProperties.Count);\r\n\r\n // - properties taken from the emulated \"command line\"\r\n if (Index >= 0) and (Index < FGlobalProperties.Count) then\r\n begin\r\n FGlobalProperties.Objects[Index] := AObject;\r\n Exit;\r\n end;\r\n Dec(Index, FGlobalProperties.Count);\r\n\r\n // - custom properties defined by the script\r\n if (Index >= 0) and (Index < FCustomProperties.Count) then\r\n begin\r\n FCustomProperties.Objects[Index] := AObject;\r\n Exit;\r\n end;\r\n Dec(Index, FCustomProperties.Count);\r\n\r\n // - environment properties taken from the environment variables\r\n if (Index >= 0) and (Index < FEnvironmentProperties.Count) then\r\n begin\r\n FEnvironmentProperties.Objects[Index] := AObject;\r\n Exit;\r\n end;\r\n \r\n raise EJclMsBuildError.CreateRes(@SRangeError);\r\nend;\r\n\r\nprocedure TJclMsBuildProperties.SetRawValue(const Name, Value: string);\r\nvar\r\n Index: Integer;\r\n XmlElem: TJclSimpleXmlElem;\r\nbegin\r\n Index := IndexOfName(Name);\r\n XmlElem := nil;\r\n if Index >= 0 then\r\n XmlElem := TJclSimpleXMLElem(Objects[Index]);\r\n if Assigned(XmlElem) then\r\n XmlElem.Value := Value\r\n else\r\n if Assigned(Parser.FFirstPropertyGroup) then\r\n Parser.FFirstPropertyGroup.Items.Add(Name, Value)\r\n else\r\n raise EJclMsBuildError.CreateResFmt(@RsELocateXmlElem, [Name]);\r\nend;\r\n\r\n//=== { TJclMsBuildParser } ==================================================\r\n\r\nconstructor TJclMsBuildParser.Create(const AFileName: TFileName; Encoding: TJclStringEncoding; CodePage: Word);\r\nvar\r\n AXml: TJclSimpleXML;\r\nbegin\r\n AXml := TJclSimpleXML.Create;\r\n try\r\n AXml.Options := AXml.Options - [sxoAutoEncodeValue,sxoAutoEncodeEntity];\r\n AXml.OnEncodeValue := XMLEncodeValue;\r\n AXml.OnDecodeValue := XMLDecodeValue;\r\n AXml.LoadFromFile(AFileName, Encoding, CodePage);\r\n except\r\n AXml.Free;\r\n raise;\r\n end;\r\n Create(AFileName, AXml, True);\r\nend;\r\n\r\nconstructor TJclMsBuildParser.Create(const AFileName: TFileName; ExtraImportsFileName: array of string; Encoding: TJclStringEncoding = seAuto; CodePage: Word = CP_ACP);\r\nvar\r\n I: Integer;\r\nbegin\r\n Create(AFileName, Encoding, CodePage);\r\n\r\n for I := Low(ExtraImportsFileName) to High(ExtraImportsFileName) do\r\n FXML.Root.Items.Insert('Import', I - Low(ExtraImportsFileName)).Properties.Add('Project', ExtraImportsFileName[I]);\r\nend;\r\n\r\nconstructor TJclMsBuildParser.Create(const AFileName: TFileName;\r\n AXml: TJclSimpleXml; AOwnsXml: Boolean);\r\nbegin\r\n inherited Create;\r\n FProjectFileName := AFileName;\r\n FXml := AXml;\r\n FOwnsXml := AOwnsXml;\r\n FProperties := TJclMsBuildProperties.Create(Self);\r\n FItems := TObjectList.Create(True);\r\n FItemDefinitions := TObjectList.Create(True);\r\n FTargets := TObjectList.Create(True);\r\n FUsingTasks := TObjectList.Create(True);\r\n FInitialTargets := TStringList.Create;\r\n FDefaultTargets := TStringList.Create;\r\n FIgnoreFunctionProperties := True;\r\nend;\r\n\r\ndestructor TJclMsBuildParser.Destroy;\r\nbegin\r\n FDefaultTargets.Free;\r\n FInitialTargets.Free;\r\n FUsingTasks.Free;\r\n FTargets.Free;\r\n FItemDefinitions.Free;\r\n FItems.Free;\r\n FProperties.Free;\r\n if FOwnsXml then\r\n FXml.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJclMsBuildParser.Clear;\r\nbegin\r\n ClearItems;\r\n ClearItemDefinitions;\r\n ClearTargets;\r\n FProperties.Clear;\r\n FInitialTargets.Clear;\r\n FDefaultTargets.Clear;\r\n FProjectExtensions := nil;\r\nend;\r\n\r\nprocedure TJclMsBuildParser.ClearItemDefinitions;\r\nbegin\r\n FItemDefinitions.Clear;\r\nend;\r\n\r\nprocedure TJclMsBuildParser.ClearItems;\r\nbegin\r\n FItems.Clear;\r\nend;\r\n\r\nprocedure TJclMsBuildParser.ClearTargets;\r\nbegin\r\n FTargets.Clear;\r\nend;\r\n\r\nfunction TJclMsBuildParser.EvaluateString(const S: string): string;\r\n\r\n function FindClosingBrace(const R: string; var Position: Integer): Boolean;\r\n var\r\n Index, Len, BraceCount: Integer;\r\n Quotes: string;\r\n begin\r\n Len := Length(R);\r\n BraceCount := 0;\r\n Quotes := '';\r\n while (Position <= Len) do\r\n begin\r\n // handle quotes first\r\n if (R[Position] = NativeSingleQuote) then\r\n begin\r\n Index := JclStrings.CharPos(Quotes, NativeSingleQuote);\r\n if Index >= 0 then\r\n SetLength(Quotes, Index - 1)\r\n else\r\n Quotes := Quotes + NativeSingleQuote;\r\n end;\r\n\r\n if (R[Position] = NativeDoubleQuote) then\r\n begin\r\n Index := JclStrings.CharPos(Quotes, NativeDoubleQuote);\r\n if Index >= 0 then\r\n SetLength(Quotes, Index - 1)\r\n else\r\n Quotes := Quotes + NativeDoubleQuote;\r\n end;\r\n\r\n if (R[Position] = '`') then\r\n begin\r\n Index := JclStrings.CharPos(Quotes, '`');\r\n if Index >= 0 then\r\n SetLength(Quotes, Index - 1)\r\n else\r\n Quotes := Quotes + '`';\r\n end;\r\n\r\n if Quotes = '' then\r\n begin\r\n if R[Position] = ')' then\r\n begin\r\n Dec(BraceCount);\r\n if BraceCount = 0 then\r\n Break;\r\n end\r\n else\r\n if R[Position] = '(' then\r\n Inc(BraceCount);\r\n end;\r\n Inc(Position);\r\n end;\r\n Result := Position <= Len;\r\n\r\n// Delphi XE's CodeGear.Delphi.Targets has a bug where the closing paran is missing\r\n// \"'$(DelphiWin32DebugDCUPath'!=''\". But it is still a valid string and not worth\r\n// an exception.\r\n//\r\n// if Position > Len then\r\n// raise EJclMsBuildError.CreateResFmt(@RsEEndOfString, [S]);\r\n end;\r\n\r\nvar\r\n Start, Position, Index: Integer;\r\n PropertyName, PropertyValue, Path, Name: string;\r\n Prop, Reg: Boolean;\r\n Root: THandle;\r\nbegin\r\n Result := S;\r\n if Result <> '' then\r\n begin\r\n repeat\r\n // start with the last match in order to convert $(some$(other))\r\n // evaluate properties\r\n Start := StrLastPos('$(', Result);\r\n if Start > 0 then\r\n begin\r\n Position := Start;\r\n if not FindClosingBrace(Result, Position) then\r\n Break;\r\n PropertyName := Copy(Result, Start + 2, Position - Start - 2);\r\n\r\n Prop := True;\r\n for Index := 1 to Length(PropertyName) do\r\n if not CharIsValidIdentifierLetter(PropertyName[Index]) then\r\n begin\r\n Prop := False;\r\n Break;\r\n end;\r\n if Prop then\r\n PropertyValue := GetPropertyValue(PropertyName)\r\n else\r\n begin\r\n Reg := Copy(PropertyName, 1, 9) = 'registry:';\r\n if Reg then\r\n begin\r\n PropertyName := Copy(PropertyName, 10, Length(PropertyName) - 9);\r\n Index := CharPos(PropertyName, '\\');\r\n Root := RootKeyValue(Copy(PropertyName, 1, Index - 1));\r\n PropertyName := Copy(PropertyName, Index + 1, Length(PropertyName) - Index);\r\n Index := CharPos(PropertyName, '@');\r\n if Index >= 0 then\r\n begin\r\n Path := Copy(PropertyName, 1, Index - 1);\r\n Name := Copy(PropertyName, Index + 1, Length(PropertyName) - Index);\r\n end\r\n else\r\n begin\r\n Path := PropertyName;\r\n Name := '';\r\n end;\r\n PropertyValue := EvaluateRegistryProperty(Root, Path, Name);\r\n end\r\n else\r\n PropertyValue := EvaluateFunctionProperty(PropertyName);\r\n end;\r\n StrReplace(Result,\r\n Copy(Result, Start, Position - Start + 1), // $(PropertyName)\r\n PropertyValue,\r\n [rfReplaceAll, rfIgnoreCase])\r\n end;\r\n if Start = 0 then\r\n begin\r\n // evaluate item list\r\n Start := StrLastPos('@(', Result);\r\n if Start > 0 then\r\n begin\r\n Position := Start;\r\n if not FindClosingBrace(Result, Position) then\r\n raise EJclMsBuildError.CreateResFmt(@RsEEndOfString, [Result]);\r\n PropertyName := Copy(Result, Start + 2, Position - Start - 2);\r\n\r\n PropertyValue := EvaluateList(PropertyName);\r\n\r\n StrReplace(Result,\r\n Copy(Result, Start, Position - Start + 1), // @(PropertyName...)\r\n PropertyValue,\r\n [rfReplaceAll, rfIgnoreCase])\r\n end;\r\n end;\r\n until Start = 0;\r\n // convert hexa to decimal\r\n if Copy(Result, 1, 2) = '0x' then\r\n Result := IntToStr(StrToInt64('$' + Copy(Result, 3, Length(Result) - 2)));\r\n end;\r\nend;\r\n\r\nfunction TJclMsBuildParser.EvaluateTransform(ItemList: TStrings; const Transform: string): string;\r\ntype\r\n TVarRecArray = array of TVarRec;\r\nconst\r\n WellKnownItemMetadataCount = 11;\r\nvar\r\n UserDefinedMetadataNames: TStrings;\r\n\r\n function GetTransformPattern(const Transform: string): string;\r\n var\r\n Index, EndIndex, Num: Integer;\r\n MetaDataName: string;\r\n begin\r\n Result := Transform;\r\n StrReplace(Result, '%(FullPath)', '%0:s', [rfReplaceAll, rfIgnoreCase]);\r\n StrReplace(Result, '%(RootDir)', '%1:s', [rfReplaceAll, rfIgnoreCase]);\r\n StrReplace(Result, '%(Filename)', '%2:s', [rfReplaceAll, rfIgnoreCase]);\r\n StrReplace(Result, '%(Extension)', '%3:s', [rfReplaceAll, rfIgnoreCase]);\r\n StrReplace(Result, '%(RelativeDir)', '%4:s', [rfReplaceAll, rfIgnoreCase]);\r\n StrReplace(Result, '%(Directory)', '%5:s', [rfReplaceAll, rfIgnoreCase]);\r\n StrReplace(Result, '%(RecursiveDir)', '%6:s', [rfReplaceAll, rfIgnoreCase]);\r\n StrReplace(Result, '%(Identity)', '%7:s', [rfReplaceAll, rfIgnoreCase]);\r\n StrReplace(Result, '%(ModifiedTime)', '%8:s', [rfReplaceAll, rfIgnoreCase]);\r\n StrReplace(Result, '%(CreatedTime)', '%9:s', [rfReplaceAll, rfIgnoreCase]);\r\n StrReplace(Result, '%(AccessedTime)', '%10:s', [rfReplaceAll, rfIgnoreCase]);\r\n\r\n // replace user defined metadata\r\n Num := WellKnownItemMetadataCount;\r\n Index := Pos('%(', Result);\r\n while Index <> 0 do\r\n begin\r\n EndIndex := StrSearch(')', Result, Index + 2);\r\n MetaDataName := Copy(Result, Index + 2, EndIndex - Index - 2);\r\n UserDefinedMetadataNames.Add(MetaDataName);\r\n StrReplace(Result, '%(' + MetaDataName + ')', '%' + IntToStr(Num) + ':s', [rfReplaceAll, rfIgnoreCase]);\r\n Inc(Num);\r\n Index := StrSearch('%(', Result, Index);\r\n end;\r\n end;\r\n\r\n procedure GetTransformParameters(Item: TJclMsBuildItem; var Storage: TDynStringArray;\r\n var Formats: TVarRecArray);\r\n const\r\n DateTimeFormat = 'yyyy-mm-dd hh:nn:ss.zzz';\r\n var\r\n Index, DotIdx: Integer;\r\n ItemFullInclude: string;\r\n LocalDateTime: TDateTime;\r\n begin\r\n if Length(Formats) <> WellKnownItemMetadataCount + UserDefinedMetadataNames.Count then\r\n begin\r\n SetLength(Formats, WellKnownItemMetadataCount + UserDefinedMetadataNames.Count);\r\n for Index := Low(Formats) to High(Formats) do\r\n begin\r\n {$IFDEF SUPPORTS_UNICODE}\r\n Formats[Index].VType := vtPWideChar;\r\n Formats[Index].VPWideChar := nil;\r\n {$ELSE ~SUPPORTS_UNICODE}\r\n Formats[Index].VType := vtPChar;\r\n Formats[Index].VPChar := nil;\r\n {$ENDIF ~SUPPORTS_UNICODE}\r\n end;\r\n end;\r\n\r\n if Length(Storage) <> WellKnownItemMetadataCount + UserDefinedMetadataNames.Count then\r\n SetLength(Storage, WellKnownItemMetadataCount + UserDefinedMetadataNames.Count);\r\n\r\n ItemFullInclude := Item.ItemFullInclude;\r\n\r\n // %(FullPath) Contains the full path of the item. For example:\r\n Storage[0] := ItemFullInclude;\r\n\r\n // %(RootDir) Contains the root directory of the item. For example:\r\n if PathIsAbsolute(ItemFullInclude) and not PathIsUNC(ItemFullInclude) and\r\n (ItemFullInclude <> '') and CharIsDriveLetter(ItemFullInclude[1]) then\r\n Storage[1] := ItemFullInclude[1] + ':\\'\r\n else\r\n Storage[1] := '';\r\n\r\n // %(Filename) Contains the file name of the item, without the extension. For example:\r\n Storage[2] := ChangeFileExt(ExtractFileName(Item.ItemInclude), '');\r\n\r\n // %(Extension) Contains the file name extension of the item. For example:\r\n Storage[3] := ExtractFileExt(Item.ItemInclude);\r\n\r\n // %(RelativeDir) Contains the path specified in the Include attribute, up to the final backslash (\\). For example:\r\n Storage[4] := PathAddSeparator(ExtractFilePath(Item.ItemInclude));\r\n\r\n // %(Directory) Contains the directory of the item, without the root directory. For example:\r\n Index := CharPos(ItemFullInclude, '\\');\r\n if Index > 0 then\r\n // skip the root\r\n Index := CharPos(ItemFullInclude, '\\', Index + 1);\r\n if Index > 0 then\r\n Storage[5] := Copy(ItemFullInclude, Index + 1, Length(ItemFullInclude) - Index)\r\n else\r\n Storage[5] := '';\r\n\r\n // %(RecursiveDir)\r\n Storage[6] := ''; // TODO: path expansion\r\n\r\n // %(Identity) The item specified in the Include attribute.. For example:\r\n Storage[7] := Item.ItemInclude;\r\n\r\n // %(ModifiedTime) Contains the timestamp from the last time the item was modified. For example:\r\n if GetFileLastWrite(ItemFullInclude, LocalDateTime) then\r\n Storage[8] := FormatDateTime(DateTimeFormat, LocalDateTime)\r\n else\r\n Storage[8] := '';\r\n\r\n // %(CreatedTime) Contains the timestamp from when the item was created. For example:\r\n if GetFileCreation(ItemFullInclude, LocalDateTime) then\r\n Storage[9] := FormatDateTime(DateTimeFormat, LocalDateTime)\r\n else\r\n Storage[9] := '';\r\n\r\n // %(AccessedTime) Contains the timestamp from the last time the time was accessed.\r\n if GetFileLastAccess(ItemFullInclude, LocalDateTime) then\r\n Storage[10] := FormatDateTime(DateTimeFormat, LocalDateTime)\r\n else\r\n Storage[10] := '';\r\n\r\n for Index := 0 to UserDefinedMetadataNames.Count - 1 do\r\n begin\r\n DotIdx := Pos('.', UserDefinedMetadataNames[Index]);\r\n if DotIdx <> 0 then // references different item => batch\r\n begin\r\n Storage[WellKnownItemMetadataCount + Index] := ''; // not implemented yet. Outer loop must iterator over this item\r\n end\r\n else\r\n Storage[WellKnownItemMetadataCount + Index] := Item.ItemMetaData.Values[UserDefinedMetadataNames[Index]];\r\n end;\r\n\r\n for Index := Low(Formats) to High(Formats) do\r\n {$IFDEF SUPPORTS_UNICODE}\r\n Formats[Index].VPWideChar := PChar(Storage[Index]);\r\n {$ELSE ~SUPPORTS_UNICODE}\r\n Formats[Index].VPChar := PChar(Storage[Index]);\r\n {$ENDIF ~SUPPORTS_UNICODE}\r\n end;\r\n\r\nvar\r\n Index: Integer;\r\n TransformPattern, TransformResult: string;\r\n TransformParameters: TVarRecArray;\r\n TransformStorage: TDynStringArray;\r\nbegin\r\n UserDefinedMetadataNames := TStringList.Create;\r\n try\r\n TransformPattern := GetTransformPattern(Transform);\r\n\r\n Result := '';\r\n for Index := 0 to ItemList.Count - 1 do\r\n begin\r\n GetTransformParameters(TJclMsBuildItem(ItemList.Objects[Index]), TransformStorage, TransformParameters);\r\n TransformResult := Format(TransformPattern, TransformParameters);\r\n if Result <> '' then\r\n Result := Result + ';' + TransformResult\r\n else\r\n Result := TransformResult;\r\n end;\r\n finally\r\n UserDefinedMetadataNames.Free;\r\n end;\r\nend;\r\n\r\nfunction TJclMsBuildParser.EvaluateFunctionProperty(const Command: string): string;\r\nbegin\r\n if (not Assigned(FOnFunctionProperty) or not FOnFunctionProperty(Self, Command, Result)) and\r\n (not IgnoreFunctionProperties) then\r\n raise EJclMsBuildError.CreateResFmt(@RsEFunctionProperty, [Command]);\r\nend;\r\n\r\nfunction TJclMsBuildParser.EvaluateList(const Name: string): string;\r\nvar\r\n Index: Integer;\r\n Transform: string;\r\n List: TStrings;\r\nbegin\r\n Index := Pos('->', Name);\r\n if Index = 0 then\r\n begin\r\n // no transformation\r\n List := TStringList.Create;\r\n try\r\n FindItemIncludes(Name, List);\r\n Result := StringsToStr(List, ';', False);\r\n finally\r\n List.Free;\r\n end;\r\n end\r\n else\r\n begin\r\n Transform := Copy(Name, Index + 2, Length(Name) - Index - 1);\r\n Transform := StrTrimCharLeft(StrTrimCharRight(Transform, NativeSingleQuote), NativeSingleQuote);\r\n List := TStringList.Create;\r\n try\r\n FindItemIncludes(Copy(Name, 1, Index - 1), List);\r\n Result := EvaluateTransform(List, Transform);\r\n finally\r\n List.Free;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJclMsBuildParser.EvaluateRegistryProperty(Root: HKEY; const Path, Name: string): string;\r\nbegin\r\n if (not Assigned(FOnRegistryProperty) or not FOnRegistryProperty(Self, Root, Path, Name, Result)) and\r\n (not RegReadStringEx(Root, Path, Name, Result, False)) then\r\n raise EJclMsBuildError.CreateResFmt(@RsERegistryProperty, [RootKeyName(Root), Path, Name]);\r\nend;\r\n\r\nfunction TJclMsBuildParser.FindItemDefinition(\r\n const ItemName: string): TJclMsBuildItem;\r\nvar\r\n Index: Integer;\r\nbegin\r\n for Index := 0 to FItemDefinitions.Count - 1 do\r\n begin\r\n Result := TJclMsBuildItem(FItemDefinitions.Items[Index]);\r\n if SameItemName(Result.ItemName, ItemName) then\r\n Exit;\r\n end;\r\n Result := nil;\r\nend;\r\n\r\nprocedure TJclMsBuildParser.FindItemIncludes(const ItemName: string; List: TStrings);\r\nvar\r\n Index: Integer;\r\n Item: TJclMsBuildItem;\r\nbegin\r\n List.Clear;\r\n List.BeginUpdate;\r\n try\r\n for Index := 0 to FItems.Count - 1 do\r\n begin\r\n Item := TJclMsBuildItem(FItems.Items[Index]);\r\n if SameItemName(Item.ItemName, ItemName) then\r\n List.AddObject(Item.ItemInclude, Item);\r\n end;\r\n finally\r\n List.EndUpdate;\r\n end;\r\nend;\r\n\r\nfunction TJclMsBuildParser.FindTarget(const TargetName: string): TJclMsBuildTarget;\r\nvar\r\n Index: Integer;\r\nbegin\r\n for Index := 0 to FTargets.Count - 1 do\r\n begin\r\n Result := TJclMsBuildTarget(FTargets.Items[Index]);\r\n if Result.TargetName = TargetName then\r\n Exit;\r\n end;\r\n Result := nil;\r\nend;\r\n\r\nclass function TJclMsBuildParser.SameItemName(const ItemName1, ItemName2: string): Boolean;\r\nbegin\r\n Result := SameText(ItemName1, ItemName2);\r\nend;\r\n\r\nfunction TJclMsBuildParser.GetItem(Index: Integer): TJclMsBuildItem;\r\nbegin\r\n Result := TJclMsBuildItem(FItems.Items[Index]);\r\nend;\r\n\r\nfunction TJclMsBuildParser.GetItemCount: Integer;\r\nbegin\r\n Result := FItems.Count;\r\nend;\r\n\r\nfunction TJclMsBuildParser.GetItemDefinition(\r\n Index: Integer): TJclMsBuildItem;\r\nbegin\r\n Result := TJclMsBuildItem(FItemDefinitions.Items[Index]);\r\nend;\r\n\r\nfunction TJclMsBuildParser.GetItemDefinitionCount: Integer;\r\nbegin\r\n Result := FItemDefinitions.Count;\r\nend;\r\n\r\nfunction TJclMsBuildParser.GetPropertyValue(const Name: string): string;\r\nbegin\r\n Result := Properties.Values[Name];\r\nend;\r\n\r\nfunction TJclMsBuildParser.GetTarget(Index: Integer): TJclMsBuildTarget;\r\nbegin\r\n Result := TJclMsBuildTarget(FTargets.Items[Index]);\r\nend;\r\n\r\nfunction TJclMsBuildParser.GetTargetCount: Integer;\r\nbegin\r\n Result := FTargets.Count;\r\nend;\r\n\r\nfunction TJclMsBuildParser.GetUsingTask(Index: Integer): TJclMsBuildUsingTask;\r\nbegin\r\n Result := TJclMsBuildUsingTask(FUsingTasks.Items[Index]);\r\nend;\r\n\r\nfunction TJclMsBuildParser.GetUsingTaskCount: Integer;\r\nbegin\r\n Result := FUsingTasks.Count;\r\nend;\r\n\r\nprocedure TJclMsBuildParser.Init;\r\nbegin\r\n InitReservedProperties;\r\n InitEnvironmentProperties;\r\nend;\r\n\r\nprocedure TJclMsBuildParser.InitEnvironmentProperties;\r\nbegin\r\n Properties.EnvironmentProperties.Clear;\r\n GetEnvironmentVars(Properties.EnvironmentProperties, True);\r\n\r\n // from http://msdn.microsoft.com/en-us/library/ms164309.aspx\r\n\r\n // MSBuildExtensionsPath\r\n // can be overriden, not used by Embarcadero's project files\r\n\r\n // MSBuildExtensionsPath32\r\n // can be overriden, not used by Embarcadero's project files\r\n\r\n // MSBuildExtensionsPath64\r\n // can be overriden, not used by Embarcadero's project files\r\nend;\r\n\r\nprocedure TJclMsBuildParser.InitReservedProperties;\r\nvar\r\n Index: Integer;\r\n Path: string;\r\n DotNetVersions: TStrings;\r\nbegin\r\n Properties.ReservedProperties.Clear;\r\n\r\n // from http://msdn.microsoft.com/en-us/library/ms164309.aspx\r\n\r\n // MSBuildProjectDirectory\r\n Properties.ReservedProperties.Values['MSBuildProjectDirectory'] := PathRemoveSeparator(ExtractFileDir(ProjectFileName));\r\n\r\n // MSBuildProjectFile\r\n Properties.ReservedProperties.Values['MSBuildProjectFile'] := ExtractFileName(ProjectFileName);\r\n\r\n // MSBuildProjectExtension\r\n Properties.ReservedProperties.Values['MSBuildProjectExtension'] := ExtractFileExt(ProjectFileName);\r\n\r\n // MSBuildProjectFullPath\r\n Properties.ReservedProperties.Values['MSBuildProjectFullPath'] := ProjectFileName;\r\n\r\n // MSBuildProjectName\r\n Properties.ReservedProperties.Values['MSBuildProjectName'] := ChangeFileExt(ExtractFileName(ProjectFileName), '');\r\n\r\n DotNetVersions := TStringList.Create;\r\n try\r\n TJclClrHost.GetClrVersions(DotNetVersions);\r\n for Index := DotNetVersions.Count - 1 downto 0 do\r\n begin\r\n Path := DotNetVersions.Values[DotNetVersions.Names[Index]];\r\n if not FileExists(PathAddSeparator(Path) + 'MSBuild.exe') then\r\n DotNetVersions.Delete(Index);\r\n end;\r\n\r\n if DotNetVersion <> '' then\r\n begin\r\n Path := DotNetVersions.Values[DotNetVersion];\r\n // MSBuildToolsVersion\r\n Properties.ReservedProperties.Values['MSBuildToolsVersion'] := DotNetVersion;\r\n end\r\n else\r\n if DotNetVersions.Count > 0 then\r\n begin\r\n Path := DotNetVersions.Values[DotNetVersions.Names[0]];\r\n // MSBuildToolsVersion\r\n Properties.ReservedProperties.Values['MSBuildToolsVersion'] := DotNetVersions.Names[0];\r\n end\r\n else\r\n Path := '';\r\n\r\n if Path <> '' then\r\n begin\r\n // MSBuildBinPath\r\n Properties.ReservedProperties.Values['MSBuildBinPath'] := Path;\r\n // MSBuildToolsPath\r\n Properties.ReservedProperties.Values['MSBuildToolsPath'] := Path;\r\n end\r\n else\r\n raise EJclMsBuildError.CreateRes(@RsEMSBuildPath);\r\n finally\r\n DotNetVersions.Free;\r\n end;\r\n\r\n // MSBuildProjectDefaultTargets\r\n // postponed to the ParseProject\r\n\r\n // MSBuildExtensionsPath\r\n // in the environment variables\r\n\r\n // MSBuildExtensionsPath32\r\n // in the environment variables\r\n\r\n // MSBuildExtensionsPath64\r\n // in the environment variables\r\n\r\n // MSBuildStartupDirectory\r\n if WorkingDirectory <> '' then\r\n Path := PathRemoveSeparator(WorkingDirectory)\r\n else\r\n Path := PathRemoveSeparator(ExtractFilePath(ProjectFileName));\r\n Properties.ReservedProperties.Values['MSBuildStartupDirectory'] := Path;\r\n\r\n // MSBuildNodeCount\r\n Properties.ReservedProperties.Values['MSBuildNodeCount'] := '1';\r\n\r\n // MSBuildLastTaskResult\r\n Properties.ReservedProperties.Values['MSBuildLastTaskResult'] := 'true';\r\n\r\n // MSBuildOverrideTasksPath\r\n // supported only in .net 4.0\r\n\r\n // MSBuildProgramFiles32\r\n Path := GetSpecialFolderLocation(CSIDL_PROGRAM_FILESX86);\r\n if Path = '' then\r\n Path := GetSpecialFolderLocation(CSIDL_PROGRAM_FILES);\r\n Properties.ReservedProperties.Values['MSBuildProgramFiles32'] := Path;\r\n\r\n // MSBuildProjectDirectoryNoRoot\r\n Path := PathRemoveSeparator(ExtractFilePath(ProjectFileName));\r\n if PathIsAbsolute(Path) and not PathIsUNC(Path) and (Path <> '') and CharIsDriveLetter(Path[1]) then\r\n Path := Copy(Path, 3, Length(Path) - 2);\r\n Properties.ReservedProperties.Values['MSBuildProjectDirectoryNoRoot'] := Path;\r\n\r\n // MSBuildThisFile\r\n Properties.ReservedProperties.Values['MSBuildProjectDirectoryNoRoot'] := CurrentFileName;\r\n\r\n // MSBuildThisFileDirectory\r\n Properties.ReservedProperties.Values['MSBuildProjectDirectoryNoRoot'] := PathRemoveSeparator(ExtractFilePath(CurrentFileName));\r\nend;\r\n\r\nprocedure TJclMsBuildParser.Parse;\r\nbegin\r\n FFirstPropertyGroup := nil;\r\n FProjectExtensions := nil;\r\n FCurrentFileName := FProjectFileName;\r\n ParseXml(FXml);\r\nend;\r\n\r\nprocedure TJclMsBuildParser.ParseChoose(XmlElem: TJclSimpleXmlElem);\r\nvar\r\n Index: Integer;\r\n Prop: TJclSimpleXmlProp;\r\n SubElem: TJclSimpleXmlElem;\r\n Executed, _Otherwise: Boolean;\r\nbegin\r\n for Index := 0 to XmlElem.PropertyCount - 1 do\r\n begin\r\n Prop := XmlElem.Properties.Item[Index];\r\n raise EJclMsBuildError.CreateResFmt(@RsEUnknownProperty, [Prop.Name]);\r\n end;\r\n\r\n Executed := False;\r\n _Otherwise := False;\r\n \r\n for Index := 0 to XmlElem.ItemCount - 1 do\r\n begin\r\n SubElem := XmlElem.Items.Item[Index];\r\n if SubElem.Name = 'When' then\r\n Executed := ParseWhen(SubElem, Executed)\r\n else\r\n if SubElem.Name = 'Otherwise' then\r\n begin\r\n if _Otherwise then\r\n raise EJclMsBuildError.CreateRes(@RsEMultipleOtherwise);\r\n _Otherwise := True;\r\n Executed := ParseOtherwise(SubElem, Executed);\r\n end\r\n else\r\n if not (SubElem is TJclSimpleXMLElemComment) then\r\n raise EJclMsBuildError.CreateResFmt(@RsEUnknownElement, [SubElem.Name]);\r\n end;\r\nend;\r\n\r\nfunction TJclMsBuildParser.ParseCondition(const Condition: string): Boolean;\r\nvar\r\n Position, Len: Integer;\r\nbegin\r\n Len := Length(Condition);\r\n Position := 1;\r\n Result := ParseConditionLength(Condition, Position, Len);\r\nend;\r\n\r\nfunction TJclMsBuildParser.ParseConditionLength(const Condition: string; var Position: Integer; Len: Integer): Boolean;\r\ntype\r\n TOperator = (opUnknown, opAnd, opOr);\r\nvar\r\n LeftOperand, RightOperand: Boolean;\r\n MiddleOperator: TOperator;\r\nbegin\r\n Result := True;\r\n if Condition <> '' then\r\n begin\r\n // read first word\r\n LeftOperand := ParseConditionOperand(Condition, Position, Len);\r\n if (Position <= Len) and (Condition[Position] = '(') then\r\n begin\r\n // skip opening parenthesis\r\n Inc(Position);\r\n LeftOperand := ParseConditionLength(Condition, Position, Len);\r\n while (Position <= Len) and CharIsWhiteSpace(Condition[Position]) do\r\n Inc(Position);\r\n if Condition[Position] <> ')' then\r\n raise EJclMsBuildError.CreateResFmt(@RsEMissingParenthesis, [Condition]);\r\n // skip closing parenthesis\r\n Inc(Position);\r\n end;\r\n while (Position <= Len) and CharIsWhiteSpace(Condition[Position]) do\r\n Inc(Position);\r\n while True do\r\n begin\r\n // read infix operator\r\n MiddleOperator := opUnknown;\r\n if ((Position + 2) <= Len) and (MiddleOperator = opUnknown) then\r\n begin\r\n if ((Condition[Position] = 'A') or (Condition[Position] = 'a')) and\r\n ((Condition[Position + 1] = 'N') or (Condition[Position + 1] = 'n')) and\r\n ((Condition[Position + 2] = 'D') or (Condition[Position + 2] = 'd')) then\r\n MiddleOperator := opAnd;\r\n if MiddleOperator <> opUnknown then\r\n Inc(Position, 3);\r\n end;\r\n if ((Position + 1) <= Len) and (MiddleOperator = opUnknown) then\r\n begin\r\n if ((Condition[Position] = 'O') or (Condition[Position] = 'o')) and\r\n ((Condition[Position + 1] = 'R') or (Condition[Position + 1] = 'r')) then\r\n MiddleOperator := opOr;\r\n if MiddleOperator <> opUnknown then\r\n Inc(Position, 2);\r\n end;\r\n if MiddleOperator <> opUnknown then\r\n begin\r\n // read right operand if any\r\n RightOperand := ParseConditionOperand(Condition, Position, Len);\r\n if (Position <= Len) and (Condition[Position] = '(') then\r\n begin\r\n // skip opening parenthesis\r\n Inc(Position);\r\n RightOperand := ParseConditionLength(Condition, Position, Len);\r\n while (Position <= Len) and CharIsWhiteSpace(Condition[Position]) do\r\n Inc(Position);\r\n if Condition[Position] <> ')' then\r\n raise EJclMsBuildError.CreateResFmt(@RsEMissingParenthesis, [Condition]);\r\n // skip closing parenthesis\r\n Inc(Position);\r\n end;\r\n while (Position <= Len) and CharIsWhiteSpace(Condition[Position]) do\r\n Inc(Position);\r\n\r\n case MiddleOperator of\r\n opUnknown:\r\n raise EJclMsBuildError.CreateResFmt(@RsEUnknownOperator, [Condition]);\r\n opAnd:\r\n LeftOperand := LeftOperand and RightOperand;\r\n opOr:\r\n LeftOperand := LeftOperand or RightOperand;\r\n end;\r\n end\r\n else\r\n Break;\r\n end;\r\n // no second word\r\n Result := LeftOperand\r\n end;\r\nend;\r\n\r\nfunction TJclMsBuildParser.ParseConditionOperand(const Condition: string; var Position: Integer; Len: Integer): Boolean;\r\ntype\r\n TOperator = (opUnknown, opEqual, opNotEqual, opLess, opLessOrEqual, opGreater, OpGreaterOrEqual);\r\nvar\r\n LeftString, RightString: string;\r\n MiddleOperator: TOperator;\r\nbegin\r\n Result := True;\r\n if Condition <> '' then\r\n begin\r\n // read first word\r\n LeftString := ParseConditionString(Condition, Position, Len);\r\n if (LeftString = '') and (Position <= Len) and (Condition[Position] = '(') then\r\n begin\r\n // skip opening parenthesis\r\n Inc(Position);\r\n LeftString := BoolToStr(ParseConditionLength(Condition, Position, Len), True);\r\n while (Position <= Len) and CharIsWhiteSpace(Condition[Position]) do\r\n Inc(Position);\r\n if Condition[Position] <> ')' then\r\n raise EJclMsBuildError.CreateResFmt(@RsEMissingParenthesis, [Condition]);\r\n // skip closing parenthesis\r\n Inc(Position);\r\n end;\r\n while (Position <= Len) and CharIsWhiteSpace(Condition[Position]) do\r\n Inc(Position);\r\n // read infix operator\r\n MiddleOperator := opUnknown;\r\n if ((Position + 1) <= Len) and (MiddleOperator = opUnknown) then\r\n begin\r\n if (Condition[Position] = '=') and (Condition[Position + 1] = '=') then\r\n MiddleOperator := opEqual\r\n else\r\n if (Condition[Position] = '!') and (Condition[Position + 1] = '=') then\r\n MiddleOperator := opNotEqual\r\n else\r\n if (Condition[Position] = '<') and (Condition[Position + 1] = '=') then\r\n MiddleOperator := opLessOrEqual\r\n else\r\n if (Condition[Position] = '>') and (Condition[Position + 1] = '=') then\r\n MiddleOperator := OpGreaterOrEqual;\r\n if MiddleOperator <> opUnknown then\r\n Inc(Position, 2);\r\n end;\r\n if (Position <= Len) and (MiddleOperator = opUnknown) then\r\n begin\r\n if Condition[Position] = '<' then\r\n MiddleOperator := opLess\r\n else\r\n if Condition[Position] = '>' then\r\n MiddleOperator := opGreater;\r\n if MiddleOperator <> opUnknown then\r\n Inc(Position);\r\n end;\r\n if MiddleOperator <> opUnknown then\r\n begin\r\n // read right operand if needed\r\n RightString := ParseConditionString(Condition, Position, Len);\r\n if (RightString = '') and (Position <= Len) and (Condition[Position] = '(') then\r\n begin\r\n // skip opening parenthesis\r\n Inc(Position);\r\n RightString := BoolToStr(ParseConditionLength(Condition, Position, Len), True);\r\n while (Position <= Len) and CharIsWhiteSpace(Condition[Position]) do\r\n Inc(Position);\r\n if Condition[Position] <> ')' then\r\n raise EJclMsBuildError.CreateResFmt(@RsEMissingParenthesis, [Condition]);\r\n // skip closing parenthesis\r\n Inc(Position);\r\n end;\r\n while (Position <= Len) and CharIsWhiteSpace(Condition[Position]) do\r\n Inc(Position);\r\n\r\n case MiddleOperator of\r\n opUnknown:\r\n raise EJclMsBuildError.CreateResFmt(@RsEUnknownOperator, [Condition]);\r\n opEqual:\r\n Result := LeftString = RightString;\r\n opNotEqual:\r\n Result := LeftString <> RightString;\r\n opLess:\r\n Result := StrToInt64(LeftString) < StrToInt64(RightString);\r\n opLessOrEqual:\r\n Result := StrToInt64(LeftString) <= StrToInt64(RightString);\r\n opGreater:\r\n Result := StrToInt64(LeftString) > StrToInt64(RightString);\r\n OpGreaterOrEqual:\r\n Result := StrToInt64(LeftString) >= StrToInt64(RightString);\r\n end;\r\n end\r\n else\r\n if LeftString = '' then\r\n Result := True\r\n else\r\n // no second word\r\n Result := StrToBool(LeftString)\r\n end;\r\nend;\r\n\r\nfunction TJclMsBuildParser.ParseConditionString(const Condition: string; var Position: Integer; Len: Integer): string;\r\nvar\r\n StartPos, EndPos: Integer;\r\n HasQuote: Boolean;\r\n FileOrDirectory: string;\r\nbegin\r\n // skip heading spaces\r\n while (Position <= Len) and CharIsWhiteSpace(Condition[Position]) do\r\n Inc(Position);\r\n StartPos := Position;\r\n HasQuote := Condition[Position] = NativeSingleQuote;\r\n if HasQuote then\r\n begin\r\n // skip heading quote\r\n Inc(StartPos);\r\n Inc(Position);\r\n // quoted string\r\n while (Position <= Len) and (Condition[Position] <> NativeSingleQuote) do\r\n Inc(Position);\r\n if Position > Len then\r\n raise EJclMsBuildError.CreateResFmt(@RsEEndOfString, [Condition]);\r\n EndPos := Position;\r\n // skip closing quote\r\n Inc(Position);\r\n end\r\n else\r\n begin\r\n // alphanumeric strings do not need to be quoted\r\n while (Position <= Len) and CharIsValidIdentifierLetter(Condition[Position]) do\r\n Inc(Position);\r\n EndPos := Position;\r\n end;\r\n Result := Copy(Condition, StartPos, EndPos - StartPos);\r\n\r\n // evaluate builtin operators and functions\r\n if (Result = '') and (Condition[StartPos] = '!') and not HasQuote then\r\n begin\r\n Inc(Position);\r\n Result := BoolToStr(not ParseConditionLength(Condition, Position, Len));\r\n end\r\n else\r\n if (CompareText(Result, 'Exists') = 0) and not HasQuote then\r\n begin\r\n while (Position <= Len) and CharIsWhiteSpace(Condition[Position]) do\r\n Inc(Position);\r\n // skip opening parenthesis\r\n if Condition[Position] <> '(' then\r\n raise EJclMsBuildError.CreateResFmt(@RsEMissingParenthesis, [Condition]);\r\n Inc(Position);\r\n FileOrDirectory := ParseConditionString(Condition, Position, Len);\r\n Result := BoolToStr(FileExists(FileOrDirectory) or DirectoryExists(FileOrDirectory), True);\r\n while (Position <= Len) and CharIsWhiteSpace(Condition[Position]) do\r\n Inc(Position);\r\n // skip closing parenthesis\r\n if Condition[Position] <> ')' then\r\n raise EJclMsBuildError.CreateResFmt(@RsEMissingParenthesis, [Condition]);\r\n Inc(Position);\r\n end\r\n else\r\n if (CompareText(Result, 'HasTrailingSlash') = 0) and not HasQuote then\r\n begin\r\n while (Position <= Len) and CharIsWhiteSpace(Condition[Position]) do\r\n Inc(Position);\r\n // skip opening parenthesis\r\n if Condition[Position] <> '(' then\r\n raise EJclMsBuildError.CreateResFmt(@RsEMissingParenthesis, [Condition]);\r\n Inc(Position);\r\n FileOrDirectory := ParseConditionString(Condition, Position, Len);\r\n Result := BoolToStr((FileOrDirectory <> '') and (FileOrDirectory[Length(FileOrDirectory)] = PathDelim), True);\r\n while (Position <= Len) and CharIsWhiteSpace(Condition[Position]) do\r\n Inc(Position);\r\n // skip closing parenthesis\r\n if Condition[Position] <> ')' then\r\n raise EJclMsBuildError.CreateResFmt(@RsEMissingParenthesis, [Condition]);\r\n Inc(Position);\r\n end\r\n else\r\n Result := EvaluateString(Result);\r\n // skip tailing spaces\r\n while (Position <= Len) and CharIsWhiteSpace(Condition[Position]) do\r\n Inc(Position);\r\nend;\r\n\r\nprocedure TJclMsBuildParser.ParseImport(XmlElem: TJclSimpleXmlElem);\r\nvar\r\n Index: Integer;\r\n Prop: TJclSimpleXMLProp;\r\n SubElem, OldProjectExtensions: TJclSimpleXmlElem;\r\n Condition: Boolean;\r\n Project: TFileName;\r\n SubXml: TJclSimpleXml;\r\n SubOwnsXml: Boolean;\r\n OldCurrentFileName: TFileName;\r\nbegin\r\n Condition := True;\r\n\r\n for Index := 0 to XmlElem.PropertyCount - 1 do\r\n begin\r\n Prop := XmlElem.Properties.Item[Index];\r\n if Prop.Name = 'Condition' then\r\n Condition := ParseCondition(Prop.Value)\r\n else\r\n if Prop.Name = 'Project' then\r\n Project := TFileName(EvaluateString(Prop.Value))\r\n else\r\n raise EJclMsBuildError.CreateResFmt(@RsEUnknownProperty, [Prop.Name]);\r\n end;\r\n\r\n for Index := 0 to XmlElem.ItemCount - 1 do\r\n begin\r\n SubElem := XmlElem.Items.Item[Index];\r\n if not (SubElem is TJclSimpleXMLElemComment) then\r\n raise EJclMsBuildError.CreateResFmt(@RsEUnknownElement, [SubElem.Name]);\r\n end;\r\n\r\n if Condition then\r\n begin\r\n SubXml := nil;\r\n SubOwnsXml := False;\r\n\r\n if not PathIsAbsolute(Project) then\r\n Project := PathCanonicalize(PathGetRelativePath(ExtractFilePath(CurrentFileName), Project));\r\n\r\n if Assigned(FOnImport) then\r\n FOnImport(Self, Project, SubXml, SubOwnsXml);\r\n\r\n if (Project <> '') or (SubXml <> nil) then // abort if both are not assigned\r\n try\r\n if not Assigned(SubXml) then\r\n begin\r\n SubXml := TJclSimpleXML.Create;\r\n SubXml.Options := SubXml.Options - [sxoAutoEncodeValue,sxoAutoEncodeEntity];\r\n SubXml.OnEncodeValue := XMLEncodeValue;\r\n SubXml.OnDecodeValue := XMLDecodeValue;\r\n SubXml.LoadFromFile(Project);\r\n SubOwnsXml := True;\r\n end;\r\n\r\n OldCurrentFileName := CurrentFileName;\r\n OldProjectExtensions := ProjectExtensions;\r\n try\r\n FCurrentFileName := Project;\r\n FProjectExtensions := nil;\r\n InitReservedProperties;\r\n ParseXml(SubXml);\r\n finally\r\n FCurrentFileName := OldCurrentFileName;\r\n FProjectExtensions := OldProjectExtensions;\r\n InitReservedProperties;\r\n end;\r\n\r\n finally\r\n if SubOwnsXml then\r\n SubXml.Free;\r\n end;\r\n \r\n end;\r\nend;\r\n\r\nprocedure TJclMsBuildParser.ParseImportGroup(XmlElem: TJclSimpleXmlElem);\r\nvar\r\n Index: Integer;\r\n Prop: TJclSimpleXMLProp;\r\n SubElem: TJclSimpleXmlElem;\r\n Condition: Boolean;\r\nbegin\r\n Condition := True;\r\n\r\n for Index := 0 to XmlElem.PropertyCount - 1 do\r\n begin\r\n Prop := XmlElem.Properties.Item[Index];\r\n if Prop.Name = 'Condition' then\r\n Condition := ParseCondition(Prop.Value)\r\n else\r\n raise EJclMsBuildError.CreateResFmt(@RsEUnknownProperty, [Prop.Name]);\r\n end;\r\n\r\n for Index := 0 to XmlElem.ItemCount - 1 do\r\n begin\r\n SubElem := XmlElem.Items.Item[Index];\r\n if SubElem.Name = 'Import' then\r\n begin\r\n if Condition then\r\n ParseImport(SubElem);\r\n end\r\n else\r\n if not (SubElem is TJclSimpleXMLElemComment) then\r\n raise EJclMsBuildError.CreateResFmt(@RsEUnknownElement, [SubElem.Name]);\r\n end;\r\nend;\r\n\r\nprocedure TJclMsBuildParser.ParseItem(XmlElem: TJclSimpleXmlElem; Definition: Boolean);\r\nvar\r\n Index: Integer;\r\n Prop: TJclSimpleXMLProp;\r\n SubElem: TJclSimpleXmlElem;\r\n Condition: Boolean;\r\n Item: TJclMsBuildItem;\r\n ItemName, ItemExclude, ItemInclude, ItemRemove: string;\r\nbegin\r\n Condition := True;\r\n\r\n ItemName := XmlElem.Name;\r\n\r\n for Index := 0 to XmlElem.PropertyCount - 1 do\r\n begin\r\n Prop := XmlElem.Properties.Item[Index];\r\n if Prop.Name = 'Condition' then\r\n Condition := ParseCondition(Prop.Value)\r\n else\r\n if Prop.Name = 'Exclude' then\r\n ItemExclude := EvaluateString(Prop.Value)\r\n else\r\n if Prop.Name = 'Include' then\r\n ItemInclude := EvaluateString(Prop.Value)\r\n else\r\n if Prop.Name = 'Remove' then\r\n ItemRemove := EvaluateString(Prop.Value)\r\n else\r\n raise EJclMsBuildError.CreateResFmt(@RsEUnknownProperty, [Prop.Name]);\r\n end;\r\n\r\n if Condition then\r\n begin\r\n Item := TJclMsBuildItem.Create;\r\n Item.FItemName := ItemName;\r\n Item.FItemInclude := ItemInclude;\r\n Item.FItemExclude := ItemExclude;\r\n Item.FItemRemove := ItemRemove;\r\n\r\n if PathIsAbsolute(ItemInclude) then\r\n Item.FItemFullInclude := ItemInclude\r\n else\r\n if PathIsAbsolute(CurrentFileName) then\r\n Item.FItemFullInclude := PathCanonicalize(PathGetRelativePath(ExtractFilePath(CurrentFileName), ItemInclude))\r\n else\r\n Item.FItemFullInclude := PathCanonicalize(PathGetRelativePath(WorkingDirectory, ItemInclude));\r\n if not FileExists(Item.FItemFullInclude) then\r\n Item.FItemFullInclude := Item.FItemInclude;\r\n\r\n if Definition then\r\n FItemDefinitions.Add(Item)\r\n else\r\n FItems.Add(Item);\r\n \r\n for Index := 0 to XmlElem.ItemCount - 1 do\r\n begin\r\n SubElem := XmlElem.Items.Item[Index];\r\n ParseItemMetaData(SubElem, Item.ItemMetaData);\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJclMsBuildParser.ParseItemDefinitionGroup(XmlElem: TJclSimpleXmlElem);\r\nvar\r\n Index: Integer;\r\n Prop: TJclSimpleXMLProp;\r\n SubElem: TJclSimpleXmlElem;\r\n Condition: Boolean;\r\nbegin\r\n Condition := True;\r\n\r\n for Index := 0 to XmlElem.PropertyCount - 1 do\r\n begin\r\n Prop := XmlElem.Properties.Item[Index];\r\n if Prop.Name = 'Condition' then\r\n Condition := ParseCondition(Prop.Value)\r\n else\r\n raise EJclMsBuildError.CreateResFmt(@RsEUnknownProperty, [Prop.Name]);\r\n end;\r\n\r\n if Condition then\r\n for Index := 0 to XmlElem.ItemCount - 1 do\r\n begin\r\n SubElem := XmlElem.Items.Item[Index];\r\n ParseItem(SubElem, True);\r\n end;\r\nend;\r\n\r\nprocedure TJclMsBuildParser.ParseItemGroup(XmlElem: TJclSimpleXmlElem);\r\nvar\r\n Index: Integer;\r\n Prop: TJclSimpleXMLProp;\r\n SubElem: TJclSimpleXmlElem;\r\n Condition: Boolean;\r\nbegin\r\n Condition := True;\r\n\r\n for Index := 0 to XmlElem.PropertyCount - 1 do\r\n begin\r\n Prop := XmlElem.Properties.Item[Index];\r\n if Prop.Name = 'Condition' then\r\n Condition := ParseCondition(Prop.Value)\r\n else\r\n raise EJclMsBuildError.CreateResFmt(@RsEUnknownProperty, [Prop.Name]);\r\n end;\r\n\r\n if Condition then\r\n for Index := 0 to XmlElem.ItemCount - 1 do\r\n begin\r\n SubElem := XmlElem.Items.Item[Index];\r\n ParseItem(SubElem, False);\r\n end;\r\nend;\r\n\r\nprocedure TJclMsBuildParser.ParseItemMetaData(XmlElem: TJclSimpleXmlElem; ItemMetaData: TStrings);\r\nvar\r\n Index: Integer;\r\n Prop: TJclSimpleXMLProp;\r\n Condition: Boolean;\r\nbegin\r\n Condition := True;\r\n\r\n for Index := 0 to XmlElem.PropertyCount - 1 do\r\n begin\r\n Prop := XmlElem.Properties.Item[Index];\r\n if Prop.Name = 'Condition' then\r\n Condition := ParseCondition(Prop.Value)\r\n else\r\n raise EJclMsBuildError.CreateResFmt(@RsEUnknownProperty, [Prop.Name]);\r\n end;\r\n\r\n if Condition then\r\n ItemMetaData.Values[XmlElem.Name] := EvaluateString(XmlElem.Value);\r\nend;\r\n\r\nprocedure TJclMsBuildParser.ParseOnError(XmlElem: TJclSimpleXMLElem; Target: TJclMsBuildTarget);\r\nvar\r\n Index: Integer;\r\n Prop: TJclSimpleXMLProp;\r\n SubElem: TJclSimpleXmlElem;\r\n Condition: Boolean;\r\n ExecuteTargets: string;\r\n TempStrings: TStrings;\r\nbegin\r\n Condition := True;\r\n\r\n for Index := 0 to XmlElem.PropertyCount - 1 do\r\n begin\r\n Prop := XmlElem.Properties.Item[Index];\r\n if Prop.Name = 'Condition' then\r\n Condition := ParseCondition(Prop.Value)\r\n else\r\n if Prop.Name = 'ExecuteTargets' then\r\n ExecuteTargets := EvaluateString(Prop.Value)\r\n else\r\n raise EJclMsBuildError.CreateResFmt(@RsEUnknownProperty, [Prop.Name]);\r\n end;\r\n\r\n for Index := 0 to XmlElem.ItemCount - 1 do\r\n begin\r\n SubElem := XmlElem.Items.Item[Index];\r\n if not (SubElem is TJclSimpleXMLElemComment) then\r\n raise EJclMsBuildError.CreateResFmt(@RsEUnknownElement, [SubElem.Name]);\r\n end;\r\n\r\n if Condition then\r\n begin\r\n TempStrings := TStringList.Create;\r\n try\r\n StrToStrings(ExecuteTargets, ';', TempStrings, False);\r\n Target.ErrorTargets.AddStrings(TempStrings);\r\n finally\r\n TempStrings.Free;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJclMsBuildParser.ParseOtherwise(XmlElem: TJclSimpleXmlElem; Skip: Boolean): Boolean;\r\nvar\r\n Index: Integer;\r\n Prop: TJclSimpleXMLProp;\r\n SubElem: TJclSimpleXmlElem;\r\nbegin\r\n for Index := 0 to XmlElem.PropertyCount - 1 do\r\n begin\r\n Prop := XmlElem.Properties.Item[Index];\r\n raise EJclMsBuildError.CreateResFmt(@RsEUnknownProperty, [Prop.Name]);\r\n end;\r\n\r\n Result := not Skip;\r\n\r\n for Index := 0 to XmlElem.ItemCount - 1 do\r\n begin\r\n SubElem := XmlElem.Items.Item[Index];\r\n if SubElem.Name = 'Choose' then\r\n begin\r\n if Result then\r\n ParseChoose(SubElem);\r\n end\r\n else\r\n if SubElem.Name = 'ItemGroup' then\r\n begin\r\n if Result then\r\n ParseItemGroup(SubElem);\r\n end\r\n else\r\n if SubElem.Name = 'PropertyGroup' then\r\n begin\r\n if Result then\r\n ParsePropertyGroup(SubElem);\r\n end\r\n else\r\n if not (SubElem is TJclSimpleXMLElemComment) then\r\n raise EJclMsBuildError.CreateResFmt(@RsEUnknownElement, [SubElem.Name]);\r\n end;\r\nend;\r\n\r\nprocedure TJclMsBuildParser.ParseOutput(XmlElem: TJclSimpleXMLElem; Task: TJclMsBuildTask);\r\nvar\r\n Index: Integer;\r\n Prop: TJclSimpleXMLProp;\r\n SubElem: TJclSimpleXmlElem;\r\n Condition: Boolean;\r\n TaskParameter, PropertyName, ItemName: string;\r\n TaskOutput: TJclMsBuildTaskOutput;\r\nbegin\r\n Condition := True;\r\n\r\n for Index := 0 to XmlElem.PropertyCount - 1 do\r\n begin\r\n Prop := XmlElem.Properties.Item[Index];\r\n if Prop.Name = 'Condition' then\r\n Condition := ParseCondition(Prop.Value)\r\n else\r\n if Prop.Name = 'TaskParameter' then\r\n TaskParameter := EvaluateString(Prop.Value)\r\n else\r\n if Prop.Name = 'PropertyName' then\r\n PropertyName := EvaluateString(Prop.Value)\r\n else\r\n if Prop.Name = 'ItemName' then\r\n ItemName := EvaluateString(Prop.Value)\r\n else\r\n raise EJclMsBuildError.CreateResFmt(@RsEUnknownProperty, [Prop.Name]);\r\n end;\r\n\r\n for Index := 0 to XmlElem.ItemCount - 1 do\r\n begin\r\n SubElem := XmlElem.Items.Item[Index];\r\n if not (SubElem is TJclSimpleXMLElemComment) then\r\n raise EJclMsBuildError.CreateResFmt(@RsEUnknownElement, [SubElem.Name]);\r\n end;\r\n\r\n if TaskParameter = '' then\r\n raise EJclMsBuildError.CreateRes(@RsEMissingTaskParameter);\r\n\r\n if (PropertyName = '') and (ItemName = '') then\r\n raise EJclMsBuildError.CreateRes(@RsEMissingOutputName);\r\n\r\n if Condition then\r\n begin\r\n TaskOutput := TJclMsBuildTaskOutput.Create;\r\n TaskOutput.FTaskParameter := TaskParameter;\r\n TaskOutput.FPropertyName := PropertyName;\r\n TaskOutput.FItemName := ItemName;\r\n Task.AddOutput(TaskOutput);\r\n end;\r\nend;\r\n\r\nprocedure TJclMsBuildParser.ParseParameter(XmlElem: TJclSimpleXMLElem; UsingTask: TJclMsBuildUsingTask);\r\nvar\r\n Index: Integer;\r\n Prop: TJclSimpleXMLProp;\r\n SubElem: TJclSimpleXmlElem;\r\n ParameterName, ParameterType: string;\r\n Output, Required: Boolean;\r\n Parameter: TJclMsBuildParameter;\r\nbegin\r\n Output := False;\r\n Required := False;\r\n\r\n ParameterName := XmlElem.Name;\r\n\r\n for Index := 0 to XmlElem.PropertyCount - 1 do\r\n begin\r\n Prop := XmlElem.Properties.Item[Index];\r\n if Prop.Name = 'ParameterType' then\r\n ParameterType := EvaluateString(Prop.Value)\r\n else\r\n if Prop.Name = 'Output' then\r\n Output := Prop.BoolValue\r\n else\r\n if Prop.Name = 'Required' then\r\n Required := Prop.BoolValue\r\n else\r\n raise EJclMsBuildError.CreateResFmt(@RsEUnknownProperty, [Prop.Name]);\r\n end;\r\n\r\n for Index := 0 to XmlElem.ItemCount - 1 do\r\n begin\r\n SubElem := XmlElem.Items.Item[Index];\r\n if not (SubElem is TJclSimpleXMLElemComment) then\r\n raise EJclMsBuildError.CreateResFmt(@RsEUnknownElement, [SubElem.Name]);\r\n end;\r\n\r\n Parameter := TJclMsBuildParameter.Create;\r\n Parameter.FParameterName := ParameterName;\r\n Parameter.FParameterType := ParameterType;\r\n Parameter.FOutput := Output;\r\n Parameter.FRequired := Required;\r\n UsingTask.AddParameter(Parameter);\r\nend;\r\n\r\nprocedure TJclMsBuildParser.ParseParameterGroup(XmlElem: TJclSimpleXMLElem; UsingTask: TJclMsBuildUsingTask);\r\nvar\r\n Index: Integer;\r\n Prop: TJclSimpleXMLProp;\r\n SubElem: TJclSimpleXmlElem;\r\nbegin\r\n for Index := 0 to XmlElem.PropertyCount - 1 do\r\n begin\r\n Prop := XmlElem.Properties.Item[Index];\r\n raise EJclMsBuildError.CreateResFmt(@RsEUnknownProperty, [Prop.Name]);\r\n end;\r\n\r\n for Index := 0 to XmlElem.ItemCount - 1 do\r\n begin\r\n SubElem := XmlElem.Items.Item[Index];\r\n ParseParameter(SubElem, UsingTask);\r\n end;\r\nend;\r\n\r\nprocedure TJclMsBuildParser.ParseProject(XmlElem: TJclSimpleXmlElem);\r\nvar\r\n Index: Integer;\r\n Prop: TJclSimpleXMLProp;\r\n SubElem: TJclSimpleXmlElem;\r\n S: string;\r\nbegin\r\n for Index := 0 to XmlElem.PropertyCount - 1 do\r\n begin\r\n Prop := XmlElem.Properties.Item[Index];\r\n if Prop.Name = 'InitialTargets' then\r\n StrToStrings(EvaluateString(Prop.Value), ';', FInitialTargets, False)\r\n else\r\n if Prop.Name = 'DefaultTargets' then\r\n begin\r\n S := EvaluateString(Prop.Value);\r\n Properties.ReservedProperties.Values['MSBuildProjectDefaultTargets'] := S;\r\n StrToStrings(S, ';', FDefaultTargets, False)\r\n end\r\n else\r\n if Prop.Name = 'ToolsVersion' then\r\n begin\r\n S := EvaluateString(Prop.Value);\r\n if Assigned(FOnToolsVersion) then\r\n FOnToolsVersion(Self, S);\r\n FToolsVersion := S;\r\n end\r\n else\r\n if Prop.Name = 'xmlns' then\r\n begin\r\n if Prop.Value <> 'http://schemas.microsoft.com/developer/msbuild/2003' then\r\n raise EJclMsBuildError.CreateResFmt(@RsEUnknownSchema, [Prop.Value]);\r\n end\r\n else\r\n raise EJclMsBuildError.CreateResFmt(@RsEUnknownProperty, [Prop.Name]);\r\n end;\r\n \r\n for Index := 0 to XmlElem.ItemCount - 1 do\r\n begin\r\n SubElem := XmlElem.Items.Item[Index];\r\n if SubElem.Name = 'Choose' then\r\n ParseChoose(SubElem)\r\n else\r\n if SubElem.Name = 'Import' then\r\n ParseImport(SubElem)\r\n else\r\n if SubElem.Name = 'ImportGroup' then\r\n ParseImportGroup(SubElem)\r\n else\r\n if SubElem.Name = 'ItemDefinitionGroup' then\r\n ParseItemDefinitionGroup(SubElem)\r\n else\r\n if SubElem.Name = 'ItemGroup' then\r\n ParseItemGroup(SubElem)\r\n else\r\n if SubElem.Name = 'ProjectExtensions' then\r\n begin\r\n if Assigned(FProjectExtensions) then\r\n raise EJclMsBuildError.CreateRes(@RsEMultipleProjectExtensions);\r\n FProjectExtensions := SubElem;\r\n end\r\n else\r\n if SubElem.Name = 'PropertyGroup' then\r\n begin\r\n if (CurrentFileName = ProjectFileName) and not Assigned(FFirstPropertyGroup) then\r\n FFirstPropertyGroup := SubElem;\r\n ParsePropertyGroup(SubElem)\r\n end\r\n else\r\n if SubElem.Name = 'Target' then\r\n ParseTarget(SubElem)\r\n else\r\n if SubElem.Name = 'UsingTask' then\r\n ParseUsingTask(SubElem)\r\n else\r\n if not (SubElem is TJclSimpleXMLElemComment) then\r\n raise EJclMsBuildError.CreateResFmt(@RsEUnknownElement, [SubElem.Name]);\r\n end;\r\nend;\r\n\r\nprocedure TJclMsBuildParser.ParseProperty(XmlElem: TJclSimpleXmlElem);\r\nvar\r\n Index: Integer;\r\n Prop: TJclSimpleXMLProp;\r\n SubElem: TJclSimpleXmlElem;\r\n Condition: Boolean;\r\nbegin\r\n Condition := True;\r\n\r\n for Index := 0 to XmlElem.PropertyCount - 1 do\r\n begin\r\n Prop := XmlElem.Properties.Item[Index];\r\n if Prop.Name = 'Condition' then\r\n Condition := ParseCondition(Prop.Value)\r\n else\r\n raise EJclMsBuildError.CreateResFmt(@RsEUnknownProperty, [Prop.Name]);\r\n end;\r\n\r\n for Index := 0 to XmlElem.ItemCount - 1 do\r\n begin\r\n SubElem := XmlElem.Items.Item[Index];\r\n if not (SubElem is TJclSimpleXMLElemComment) then\r\n raise EJclMsBuildError.CreateResFmt(@RsEUnknownElement, [SubElem.Name]);\r\n end;\r\n\r\n if Condition then\r\n begin\r\n SetPropertyValue(XmlElem.Name, EvaluateString(XmlElem.Value));\r\n // store the XML element for further modifications in the current file\r\n if CurrentFileName = ProjectFileName then\r\n begin\r\n Index := Properties.IndexOfName(XmlElem.Name);\r\n if Index >= 0 then\r\n Properties.Objects[Index] := XmlElem;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJclMsBuildParser.ParsePropertyGroup(XmlElem: TJclSimpleXmlElem);\r\nvar\r\n Index: Integer;\r\n Prop: TJclSimpleXmlProp;\r\n SubElem: TJclSimpleXmlElem;\r\n Condition: Boolean;\r\nbegin\r\n Condition := True;\r\n\r\n for Index := 0 to XmlElem.PropertyCount - 1 do\r\n begin\r\n Prop := XmlElem.Properties.Item[Index];\r\n if Prop.Name = 'Condition' then\r\n Condition := ParseCondition(Prop.Value)\r\n else\r\n raise EJclMsBuildError.CreateResFmt(@RsEUnknownProperty, [Prop.Name]);\r\n end;\r\n\r\n if Condition then\r\n for Index := 0 to XmlElem.ItemCount - 1 do\r\n begin\r\n SubElem := XmlElem.Items.Item[Index];\r\n ParseProperty(SubElem);\r\n end;\r\nend;\r\n\r\nprocedure TJclMsBuildParser.ParseTarget(XmlElem: TJclSimpleXMLElem);\r\nvar\r\n Index: Integer;\r\n Prop: TJclSimpleXMLProp;\r\n SubElem: TJclSimpleXmlElem;\r\n Condition, KeepDuplicateOutput: Boolean;\r\n TargetName, Depends, Returns, Inputs, Outputs, BeforeTargets, AfterTargets: string;\r\n Target: TJclMsBuildTarget;\r\nbegin\r\n Condition := True;\r\n KeepDuplicateOutput := False;\r\n\r\n for Index := 0 to XmlElem.PropertyCount - 1 do\r\n begin\r\n Prop := XmlElem.Properties.Item[Index];\r\n if Prop.Name = 'Condition' then\r\n Condition := ParseCondition(Prop.Value)\r\n else\r\n if Prop.Name = 'Name' then\r\n TargetName := EvaluateString(Prop.Value)\r\n else\r\n if Prop.Name = 'DependsOnTargets' then\r\n Depends := EvaluateString(Prop.Value)\r\n else\r\n if Prop.Name = 'Returns' then\r\n Returns := EvaluateString(Prop.Value)\r\n else\r\n if Prop.Name = 'Inputs' then\r\n Inputs := EvaluateString(Prop.Value)\r\n else\r\n if Prop.Name = 'Outputs' then\r\n Outputs := EvaluateString(Prop.Value)\r\n else\r\n if Prop.Name = 'BeforeTargets' then\r\n BeforeTargets := EvaluateString(Prop.Value)\r\n else\r\n if Prop.Name = 'AfterTargets' then\r\n AfterTargets := EvaluateString(Prop.Value)\r\n else\r\n if Prop.Name = 'KeepDuplicateOutputs' then\r\n KeepDuplicateOutput := Prop.BoolValue\r\n else\r\n raise EJclMsBuildError.CreateResFmt(@RsEUnknownProperty, [Prop.Name]);\r\n end;\r\n\r\n if TargetName = '' then\r\n raise EJclMsBuildError.CreateRes(@RsEMissingTargetName);\r\n\r\n Target := TJclMsBuildTarget.Create;\r\n FTargets.Add(Target);\r\n\r\n Target.FTargetName := TargetName;\r\n StrToStrings(Depends, ';', Target.FDepends, False);\r\n StrToStrings(Returns, ';', Target.FReturns, False);\r\n StrToStrings(Inputs, ';', Target.FInputs, False);\r\n StrToStrings(Outputs, ';', Target.FOutputs, False);\r\n StrToStrings(BeforeTargets, ';', Target.FBeforeTargets, False);\r\n StrToStrings(AfterTargets, ';', Target.FAfterTargets, False);\r\n Target.FKeepDuplicateOutputs := KeepDuplicateOutput;\r\n\r\n if Condition then\r\n for Index := 0 to XmlElem.ItemCount - 1 do\r\n begin\r\n SubElem := XmlElem.Items.Item[Index];\r\n if SubElem.Name = 'OnError' then\r\n ParseOnError(SubElem, Target)\r\n else\r\n if (SubElem.Name = 'PropertyGroup') or (SubElem.Name = 'ItemGroup') then\r\n // apparently targets can contain several other nodes\r\n // see comments in http://msdn.microsoft.com/en-us/library/t50z2hka.aspx\r\n // they should be ignored during the static analysis implemented in this parser\r\n else\r\n ParseTask(SubElem, Target);\r\n end;\r\nend;\r\n\r\nprocedure TJclMsBuildParser.ParseTask(XmlElem: TJclSimpleXMLElem; Target: TJclMsBuildTarget);\r\nvar\r\n Index: Integer;\r\n Prop: TJclSimpleXMLProp;\r\n SubElem: TJclSimpleXmlElem;\r\n TaskName: string;\r\n Condition, ContinueOnError: Boolean;\r\n Task: TJclMsBuildTask;\r\nbegin\r\n Condition := True;\r\n ContinueOnError := False;\r\n\r\n TaskName := XmlElem.Name;\r\n \r\n for Index := 0 to XmlElem.PropertyCount - 1 do\r\n begin\r\n Prop := XmlElem.Properties.Item[Index];\r\n if Prop.Name = 'Condition' then\r\n Condition := ParseCondition(Prop.Value)\r\n else\r\n if Prop.Name = 'ContinueOnError' then\r\n ContinueOnError := Prop.BoolValue;\r\n end;\r\n\r\n if Condition then\r\n begin\r\n Task := TJclMsBuildTask.Create;\r\n Task.FTaskName := TaskName;\r\n Task.FContinueOnError := ContinueOnError;\r\n Target.AddTask(Task);\r\n\r\n for Index := 0 to XmlElem.PropertyCount - 1 do\r\n begin\r\n Prop := XmlElem.Properties.Item[Index];\r\n if (Prop.Name <> 'Condition') and (Prop.Name <> 'ContinueOnError') then\r\n Task.Parameters.Values[Prop.Name] := EvaluateString(Prop.Value);\r\n end;\r\n\r\n for Index := 0 to XmlElem.ItemCount - 1 do\r\n begin\r\n SubElem := XmlElem.Items.Item[Index];\r\n if SubElem.Name = 'Output' then\r\n ParseOutput(SubElem, Task)\r\n else\r\n if not (SubElem is TJclSimpleXMLElemComment) then\r\n raise EJclMsBuildError.CreateResFmt(@RsEUnknownElement, [SubElem.Name]);\r\n end;\r\n\r\n end;\r\nend;\r\n\r\nprocedure TJclMsBuildParser.ParseTaskBody(XmlElem: TJclSimpleXMLElem; UsingTask: TJclMsBuildUsingTask);\r\nvar\r\n Index: Integer;\r\n Prop: TJclSimpleXMLProp;\r\n SubElem: TJclSimpleXmlElem;\r\n Evaluate: Boolean;\r\nbegin\r\n Evaluate := False;\r\n \r\n for Index := 0 to XmlElem.PropertyCount - 1 do\r\n begin\r\n Prop := XmlElem.Properties.Item[Index];\r\n if Prop.Name = 'Evaluate' then\r\n Evaluate := Prop.BoolValue\r\n else\r\n raise EJclMsBuildError.CreateResFmt(@RsEUnknownProperty, [Prop.Name]);\r\n end;\r\n\r\n for Index := 0 to XmlElem.ItemCount - 1 do\r\n begin\r\n SubElem := XmlElem.Items.Item[Index];\r\n if not (SubElem is TJclSimpleXMLElemComment) then\r\n raise EJclMsBuildError.CreateResFmt(@RsEUnknownElement, [SubElem.Name]);\r\n end;\r\n\r\n if Evaluate then\r\n UsingTask.FTaskBody := EvaluateString(XmlElem.Value)\r\n else\r\n UsingTask.FTaskBody := XmlElem.Value;\r\nend;\r\n\r\nprocedure TJclMsBuildParser.ParseUsingTask(XmlElem: TJclSimpleXmlElem);\r\nvar\r\n Index: Integer;\r\n Prop: TJclSimpleXmlProp;\r\n SubElem: TJclSimpleXmlElem;\r\n Condition: Boolean;\r\n AssemblyName, AssemblyFile, TaskFactory, TaskName: string;\r\n UsingTask: TJclMsBuildUsingTask;\r\nbegin\r\n Condition := True;\r\n\r\n for Index := 0 to XmlElem.PropertyCount - 1 do\r\n begin\r\n Prop := XmlElem.Properties.Item[Index];\r\n if Prop.Name = 'Condition' then\r\n Condition := ParseCondition(Prop.Value)\r\n else\r\n if Prop.Name = 'TaskName' then\r\n TaskName := EvaluateString(Prop.Value)\r\n else\r\n if Prop.Name = 'TaskFactory' then\r\n TaskFactory := EvaluateString(Prop.Value)\r\n else\r\n if Prop.Name = 'AssemblyName' then\r\n AssemblyName := EvaluateString(Prop.Value)\r\n else\r\n if Prop.Name = 'AssemblyFile' then\r\n AssemblyFile := EvaluateString(Prop.Value)\r\n else\r\n raise EJclMsBuildError.CreateResFmt(@RsEUnknownProperty, [Prop.Name]);\r\n end;\r\n\r\n if TaskName = '' then\r\n raise EJclMsBuildError.CreateRes(@RsEMissingTaskName);\r\n\r\n if (AssemblyName = '') and (AssemblyFile = '') then\r\n raise EJclMsBuildError.CreateRes(@RsEMissingAssembly);\r\n\r\n if Condition then\r\n begin\r\n UsingTask := TJclMsBuildUsingTask.Create;\r\n UsingTask.FAssemblyName := AssemblyName;\r\n UsingTask.FAssemblyFile := AssemblyFile;\r\n UsingTask.FTaskFactory := TaskFactory;\r\n UsingTask.FTaskName := TaskName;\r\n for Index := 0 to XmlElem.ItemCount - 1 do\r\n begin\r\n SubElem := XmlElem.Items.Item[Index];\r\n if SubElem.Name = 'ParameterGroup' then\r\n ParseParameterGroup(SubElem, UsingTask)\r\n else\r\n if SubElem.Name = 'TaskBody' then\r\n ParseTaskBody(SubElem, UsingTask)\r\n else\r\n if not (SubElem is TJclSimpleXMLElemComment) then\r\n raise EJclMsBuildError.CreateResFmt(@RsEUnknownElement, [SubElem.Name]);\r\n end;\r\n FUsingTasks.Add(UsingTask);\r\n end;\r\nend;\r\n\r\nfunction TJclMsBuildParser.ParseWhen(XmlElem: TJclSimpleXmlElem; Skip: Boolean): Boolean;\r\nvar\r\n Index: Integer;\r\n Prop: TJclSimpleXmlProp;\r\n SubElem: TJclSimpleXmlElem;\r\nbegin\r\n Result := False;\r\n\r\n for Index := 0 to XmlElem.PropertyCount - 1 do\r\n begin\r\n Prop := XmlElem.Properties.Item[Index];\r\n if Prop.Name = 'Condition' then\r\n Result := Skip or ParseCondition(Prop.Value)\r\n else\r\n raise EJclMsBuildError.CreateResFmt(@RsEUnknownProperty, [Prop.Name]);\r\n end;\r\n\r\n if XmlElem.PropertyCount <> 1 then\r\n raise EJclMsBuildError.CreateRes(@RsEConditionNotUnique);\r\n\r\n for Index := 0 to XmlElem.ItemCount - 1 do\r\n begin\r\n SubElem := XmlElem.Items.Item[Index];\r\n if SubElem.Name = 'Choose' then\r\n begin\r\n if Result then\r\n ParseChoose(SubElem);\r\n end\r\n else\r\n if SubElem.Name = 'ItemGroup' then\r\n begin\r\n if Result then\r\n ParseItemGroup(SubElem);\r\n end\r\n else\r\n if SubElem.Name = 'PropertyGroup' then\r\n begin\r\n if Result then\r\n ParsePropertyGroup(SubElem);\r\n end\r\n else\r\n if not (SubElem is TJclSimpleXMLElemComment) then\r\n raise EJclMsBuildError.CreateResFmt(@RsEUnknownElement, [SubElem.Name]);\r\n end;\r\nend;\r\n\r\nprocedure TJclMsBuildParser.ParseXml(AXml: TJclSimpleXML);\r\nbegin\r\n if AXml.Root.Name <> 'Project' then\r\n raise EJclMsBuildError.CreateResFmt(@RsENoProjectElem, [AXml.Root.Name]);\r\n ParseProject(AXml.Root);\r\nend;\r\n\r\nprocedure TJclMsBuildParser.Save;\r\nbegin\r\n Xml.SaveToFile(ProjectFileName);\r\nend;\r\n\r\nprocedure TJclMsBuildParser.SetPropertyValue(const Name, Value: string);\r\nbegin\r\n Properties.Values[Name] := Value;\r\nend;\r\n\r\nprocedure TJclMsBuildParser.XMLDecodeValue(Sender: TObject; var Value: string);\r\nbegin\r\n Value := XMLDecode(Value);\r\nend;\r\n\r\nprocedure TJclMsBuildParser.XMLEncodeValue(Sender: TObject; var Value: string);\r\nbegin\r\n StrReplace(Value, '&', '&', [rfReplaceAll]);\r\n StrReplace(Value, '<', '<', [rfReplaceAll]);\r\n StrReplace(Value, '>', '>', [rfReplaceAll]);\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jcl/source/windows/JclMsdosSys.pas", "content": "{**************************************************************************************************}\r\n{ }\r\n{ Project JEDI Code Library (JCL) }\r\n{ }\r\n{ The contents of this file are subject to the Mozilla Public License Version 1.1 (the \"License\"); }\r\n{ you may not use this file except in compliance with the License. You may obtain a copy of the }\r\n{ License at http://www.mozilla.org/MPL/ }\r\n{ }\r\n{ Software distributed under the License is distributed on an \"AS IS\" basis, WITHOUT WARRANTY OF }\r\n{ ANY KIND, either express or implied. See the License for the specific language governing rights }\r\n{ and limitations under the License. }\r\n{ }\r\n{ The Original Code is JclMsdosSys.pas. }\r\n{ }\r\n{ The Initial Developer of the Original Code is Robert Marquardt }\r\n{ Portions created by Robert Marquardt are Copyright (C) 2001 Robert Marquardt }\r\n{ All Rights Reserved. }\r\n{ }\r\n{ Contributor(s): Robert Rossmair (IJclMsdosSys interface) }\r\n{ }\r\n{ You may retrieve the latest version of this file at the Project JEDI's Code Library home page, }\r\n{ located at http://sourceforge.net/projects/jcl/ }\r\n{ }\r\n{ Known Issues: None }\r\n{ }\r\n{**************************************************************************************************}\r\n{ }\r\n{ Last modified: $Date:: 2011-09-03 00:07:50 +0200 (sam. 03 sept. 2011) $ }\r\n{ Revision: $Rev:: 3599 $ }\r\n{ Author: $Author:: outchy $ }\r\n{ }\r\n{**************************************************************************************************}\r\n\r\nunit JclMsdosSys;\r\n\r\n{$I jcl.inc}\r\n{$I windowsonly.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n {$IFDEF HAS_UNITSCOPE}\r\n System.Classes, System.SysUtils;\r\n {$ELSE ~HAS_UNITSCOPE}\r\n Classes, SysUtils;\r\n {$ENDIF ~HAS_UNITSCOPE}\r\n\r\ntype\r\n IJclMsdosSys = interface\r\n ['{3E1C7E48-49E5-408B-86D2-9924D223B5C5}']\r\n // Property access methods\r\n function GetAutoScan: Boolean;\r\n function GetBootDelay: Cardinal;\r\n function GetBootGUI: Boolean;\r\n function GetBootKeys: Boolean;\r\n function GetBootMenu: Boolean;\r\n function GetBootMenuDefault: Cardinal;\r\n function GetBootMenuDelay: Cardinal;\r\n function GetBootMulti: Boolean;\r\n function GetBootSafe: Boolean;\r\n function GetBootWarn: Boolean;\r\n function GetBootWin: Boolean;\r\n function GetDBLSpace: Boolean;\r\n function GetDoubleBuffer: Boolean;\r\n function GetDRVSpace: Boolean;\r\n function GetHostWinBootDrv: Char;\r\n function GetLoadTop: Boolean;\r\n function GetLogo: Boolean;\r\n function GetNetwork: Boolean;\r\n function GetUninstallDir: Char;\r\n function GetWinBootDir: string;\r\n function GetWinDir: string;\r\n function GetWinVer: string;\r\n procedure SetUninstallDir(AUninstallDir: Char);\r\n procedure SetWinDir(AWinDir: string);\r\n procedure SetWinBootDir(AWinBootDir: string);\r\n procedure SetHostWinBootDrv(AHostWinBootDrv: Char);\r\n procedure SetAutoScan(AAutoScan: Boolean);\r\n procedure SetBootDelay(ABootDelay: Cardinal);\r\n procedure SetBootGUI(ABootGUI: Boolean);\r\n procedure SetBootKeys(ABootKeys: Boolean);\r\n procedure SetBootMenu(ABootMenu: Boolean);\r\n procedure SetBootMenuDefault(ABootMenuDefault: Cardinal);\r\n procedure SetBootMenuDelay(ABootMenuDelay: Cardinal);\r\n procedure SetBootMulti(ABootMulti: Boolean);\r\n procedure SetBootSafe(ABootSafe: Boolean);\r\n procedure SetBootWarn(ABootWarn: Boolean);\r\n procedure SetBootWin(ABootWin: Boolean);\r\n procedure SetDBLSpace(ADBLSpace: Boolean);\r\n procedure SetDRVSpace(ADRVSpace: Boolean);\r\n procedure SetDoubleBuffer(ADoubleBuffer: Boolean);\r\n procedure SetLoadTop(ALoadTop: Boolean);\r\n procedure SetLogo(ALogo: Boolean);\r\n procedure SetNetwork(ANetwork: Boolean);\r\n procedure SetWinVer(AWinVer: string);\r\n procedure SetBool(var ANew: Boolean; AOld: Boolean);\r\n procedure SetString(var ANew: string; AOld: string);\r\n // Properties\r\n property UninstallDir: Char read GetUninstallDir write SetUninstallDir;\r\n property WinDir: string read GetWinDir write SetWinDir;\r\n property WinBootDir: string read GetWinBootDir write SetWinBootDir;\r\n property HostWinBootDrv: Char read GetHostWinBootDrv write SetHostWinBootDrv;\r\n property AutoScan: Boolean read GetAutoScan write SetAutoScan;\r\n property BootDelay: Cardinal read GetBootDelay write SetBootDelay;\r\n property BootGUI: Boolean read GetBootGUI write SetBootGUI;\r\n property BootKeys: Boolean read GetBootKeys write SetBootKeys;\r\n property BootMenu: Boolean read GetBootMenu write SetBootMenu;\r\n property BootMenuDefault: Cardinal read GetBootMenuDefault write SetBootMenuDefault;\r\n property BootMenuDelay: Cardinal read GetBootMenuDelay write SetBootMenuDelay;\r\n property BootMulti: Boolean read GetBootMulti write SetBootMulti;\r\n property BootSafe: Boolean read GetBootSafe write SetBootSafe;\r\n property BootWarn: Boolean read GetBootWarn write SetBootWarn;\r\n property BootWin: Boolean read GetBootWin write SetBootWin;\r\n property DBLSpace: Boolean read GetDBLSpace write SetDBLSpace;\r\n property DRVSpace: Boolean read GetDRVSpace write SetDRVSpace;\r\n property DoubleBuffer: Boolean read GetDoubleBuffer write SetDoubleBuffer;\r\n property LoadTop: Boolean read GetLoadTop write SetLoadTop;\r\n property Logo: Boolean read GetLogo write SetLogo;\r\n property Network: Boolean read GetNetwork write SetNetwork;\r\n property WinVer: string read GetWinVer write SetWinVer;\r\n end;\r\n\r\ntype\r\n TJclMsdosSys = class(TInterfacedObject, IJclMsdosSys)\r\n private\r\n FUninstallDir: Char;\r\n FWinDir: string;\r\n FWinBootDir: string;\r\n FHostWinBootDrv: Char;\r\n FAutoScan: Boolean;\r\n FBootDelay: Cardinal;\r\n FBootGUI: Boolean;\r\n FBootKeys: Boolean;\r\n FBootMenu: Boolean;\r\n FBootMenuDefault: Cardinal;\r\n FBootMenuDelay: Cardinal;\r\n FBootMulti: Boolean;\r\n FBootSafe: Boolean;\r\n FBootWarn: Boolean;\r\n FBootWin: Boolean;\r\n FDBLSpace: Boolean;\r\n FDRVSpace: Boolean;\r\n FDoubleBuffer: Boolean;\r\n FLoadTop: Boolean;\r\n FLogo: Boolean;\r\n FNetwork: Boolean;\r\n FWinVer: string;\r\n public\r\n constructor Create;\r\n destructor Destroy; override;\r\n { IJclMsdosSys }\r\n function GetAutoScan: Boolean;\r\n function GetBootDelay: Cardinal;\r\n function GetBootGUI: Boolean;\r\n function GetBootKeys: Boolean;\r\n function GetBootMenu: Boolean;\r\n function GetBootMenuDefault: Cardinal;\r\n function GetBootMenuDelay: Cardinal;\r\n function GetBootMulti: Boolean;\r\n function GetBootSafe: Boolean;\r\n function GetBootWarn: Boolean;\r\n function GetBootWin: Boolean;\r\n function GetDBLSpace: Boolean;\r\n function GetDoubleBuffer: Boolean;\r\n function GetDRVSpace: Boolean;\r\n function GetHostWinBootDrv: Char;\r\n function GetLoadTop: Boolean;\r\n function GetLogo: Boolean;\r\n function GetNetwork: Boolean;\r\n function GetUninstallDir: Char;\r\n function GetWinBootDir: string;\r\n function GetWinDir: string;\r\n function GetWinVer: string;\r\n procedure SetUninstallDir(AUninstallDir: Char);\r\n procedure SetWinDir(AWinDir: string);\r\n procedure SetWinBootDir(AWinBootDir: string);\r\n procedure SetHostWinBootDrv(AHostWinBootDrv: Char);\r\n procedure SetAutoScan(AAutoScan: Boolean);\r\n procedure SetBootDelay(ABootDelay: Cardinal);\r\n procedure SetBootGUI(ABootGUI: Boolean);\r\n procedure SetBootKeys(ABootKeys: Boolean);\r\n procedure SetBootMenu(ABootMenu: Boolean);\r\n procedure SetBootMenuDefault(ABootMenuDefault: Cardinal);\r\n procedure SetBootMenuDelay(ABootMenuDelay: Cardinal);\r\n procedure SetBootMulti(ABootMulti: Boolean);\r\n procedure SetBootSafe(ABootSafe: Boolean);\r\n procedure SetBootWarn(ABootWarn: Boolean);\r\n procedure SetBootWin(ABootWin: Boolean);\r\n procedure SetDBLSpace(ADBLSpace: Boolean);\r\n procedure SetDRVSpace(ADRVSpace: Boolean);\r\n procedure SetDoubleBuffer(ADoubleBuffer: Boolean);\r\n procedure SetLoadTop(ALoadTop: Boolean);\r\n procedure SetLogo(ALogo: Boolean);\r\n procedure SetNetwork(ANetwork: Boolean);\r\n procedure SetWinVer(AWinVer: string);\r\n procedure SetBool(var ANew: Boolean; AOld: Boolean);\r\n procedure SetString(var ANew: string; AOld: string);\r\n procedure ReadMsdosSys;\r\n procedure WriteMsdosSys;\r\n property UninstallDir: Char read GetUninstallDir write SetUninstallDir;\r\n property WinDir: string read GetWinDir write SetWinDir;\r\n property WinBootDir: string read GetWinBootDir write SetWinBootDir;\r\n property HostWinBootDrv: Char read GetHostWinBootDrv write SetHostWinBootDrv;\r\n property AutoScan: Boolean read GetAutoScan write SetAutoScan;\r\n property BootDelay: Cardinal read GetBootDelay write SetBootDelay;\r\n property BootGUI: Boolean read GetBootGUI write SetBootGUI;\r\n property BootKeys: Boolean read GetBootKeys write SetBootKeys;\r\n property BootMenu: Boolean read GetBootMenu write SetBootMenu;\r\n property BootMenuDefault: Cardinal read GetBootMenuDefault write SetBootMenuDefault;\r\n property BootMenuDelay: Cardinal read GetBootMenuDelay write SetBootMenuDelay;\r\n property BootMulti: Boolean read GetBootMulti write SetBootMulti;\r\n property BootSafe: Boolean read GetBootSafe write SetBootSafe;\r\n property BootWarn: Boolean read GetBootWarn write SetBootWarn;\r\n property BootWin: Boolean read GetBootWin write SetBootWin;\r\n property DBLSpace: Boolean read GetDBLSpace write SetDBLSpace;\r\n property DRVSpace: Boolean read GetDRVSpace write SetDRVSpace;\r\n property DoubleBuffer: Boolean read GetDoubleBuffer write SetDoubleBuffer;\r\n property LoadTop: Boolean read GetLoadTop write SetLoadTop;\r\n property Logo: Boolean read GetLogo write SetLogo;\r\n property Network: Boolean read GetNetwork write SetNetwork;\r\n property WinVer: string read GetWinVer write SetWinVer;\r\n end;\r\n\r\n\r\nfunction GetMsdosSys: IJclMsdosSys;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jcl.svn.sourceforge.net/svnroot/jcl/tags/JCL-2.4-Build4571/jcl/source/windows/JclMsdosSys.pas $';\r\n Revision: '$Revision: 3599 $';\r\n Date: '$Date: 2011-09-03 00:07:50 +0200 (sam. 03 sept. 2011) $';\r\n LogPath: 'JCL\\source\\windows';\r\n Extra: '';\r\n Data: nil\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nconst\r\n cMsdosSys = 'C:\\MSDOS.SYS';\r\n\r\nfunction GetMsdosSys: IJclMsdosSys;\r\nbegin\r\n Result := TJclMsdosSys.Create;\r\nend;\r\n\r\n//=== { TJclMsdosSys } =======================================================\r\n\r\nconstructor TJclMsdosSys.Create;\r\nbegin\r\n inherited Create;\r\n ReadMsdosSys;\r\nend;\r\n\r\ndestructor TJclMsdosSys.Destroy;\r\nbegin\r\n WriteMsdosSys;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJclMsdosSys.GetAutoScan: Boolean;\r\nbegin\r\n Result := FAutoScan;\r\nend;\r\n\r\nfunction TJclMsdosSys.GetBootDelay: Cardinal;\r\nbegin\r\n Result := FBootDelay;\r\nend;\r\n\r\nfunction TJclMsdosSys.GetBootGUI: Boolean;\r\nbegin\r\n Result := FBootGUI;\r\nend;\r\n\r\nfunction TJclMsdosSys.GetBootMenu: Boolean;\r\nbegin\r\n Result := FBootMenu;\r\nend;\r\n\r\nfunction TJclMsdosSys.GetBootKeys: Boolean;\r\nbegin\r\n Result := FBootKeys;\r\nend;\r\n\r\nfunction TJclMsdosSys.GetBootMenuDefault: Cardinal;\r\nbegin\r\n Result := FBootMenuDefault;\r\nend;\r\n\r\nfunction TJclMsdosSys.GetBootMenuDelay: Cardinal;\r\nbegin\r\n Result := FBootMenuDelay;\r\nend;\r\n\r\nfunction TJclMsdosSys.GetBootMulti: Boolean;\r\nbegin\r\n Result := FBootMulti;\r\nend;\r\n\r\nfunction TJclMsdosSys.GetBootSafe: Boolean;\r\nbegin\r\n Result := FBootSafe;\r\nend;\r\n\r\nfunction TJclMsdosSys.GetBootWarn: Boolean;\r\nbegin\r\n Result := FBootWarn;\r\nend;\r\n\r\nfunction TJclMsdosSys.GetBootWin: Boolean;\r\nbegin\r\n Result := FBootWin;\r\nend;\r\n\r\nfunction TJclMsdosSys.GetDBLSpace: Boolean;\r\nbegin\r\n Result := FDBLSpace;\r\nend;\r\n\r\nfunction TJclMsdosSys.GetDoubleBuffer: Boolean;\r\nbegin\r\n Result := FDoubleBuffer;\r\nend;\r\n\r\nfunction TJclMsdosSys.GetDRVSpace: Boolean;\r\nbegin\r\n Result := FDRVSpace;\r\nend;\r\n\r\nfunction TJclMsdosSys.GetHostWinBootDrv: Char;\r\nbegin\r\n Result := FHostWinBootDrv;\r\nend;\r\n\r\nfunction TJclMsdosSys.GetLoadTop: Boolean;\r\nbegin\r\n Result := FLoadTop;\r\nend;\r\n\r\nfunction TJclMsdosSys.GetLogo: Boolean;\r\nbegin\r\n Result := FLogo;\r\nend;\r\n\r\nfunction TJclMsdosSys.GetNetwork: Boolean;\r\nbegin\r\n Result := FNetWork;\r\nend;\r\n\r\nfunction TJclMsdosSys.GetUninstallDir: Char;\r\nbegin\r\n Result := FUninstallDir;\r\nend;\r\n\r\nfunction TJclMsdosSys.GetWinBootDir: string;\r\nbegin\r\n Result := FWinBootDir;\r\nend;\r\n\r\nfunction TJclMsdosSys.GetWinDir: string;\r\nbegin\r\n Result := FWinDir;\r\nend;\r\n\r\nfunction TJclMsdosSys.GetWinVer: string;\r\nbegin\r\n Result := FWinVer;\r\nend;\r\n\r\nprocedure TJclMsdosSys.SetUninstallDir(AUninstallDir: Char);\r\nbegin\r\n if UninstallDir <> AUninstallDir then\r\n begin\r\n FUninstallDir := AUninstallDir;\r\n WriteMsdosSys;\r\n end;\r\nend;\r\n\r\nprocedure TJclMsdosSys.SetWinDir(AWinDir: string);\r\nbegin\r\n SetString(FWinDir, AWinDir);\r\nend;\r\n\r\nprocedure TJclMsdosSys.SetWinBootDir(AWinBootDir: string);\r\nbegin\r\n SetString(FWinBootDir, AWinBootDir);\r\nend;\r\n\r\nprocedure TJclMsdosSys.SetHostWinBootDrv(AHostWinBootDrv: Char);\r\nbegin\r\n if HostWinBootDrv <> AHostWinBootDrv then\r\n begin\r\n FHostWinBootDrv := AHostWinBootDrv;\r\n WriteMsdosSys;\r\n end;\r\nend;\r\n\r\nprocedure TJclMsdosSys.SetAutoScan(AAutoScan: Boolean);\r\nbegin\r\n SetBool(FAutoScan, AAutoScan);\r\nend;\r\n\r\nprocedure TJclMsdosSys.SetBootDelay(ABootDelay: Cardinal);\r\nbegin\r\n if BootDelay <> ABootDelay then\r\n begin\r\n FBootDelay := ABootDelay;\r\n WriteMsdosSys;\r\n end;\r\nend;\r\n\r\nprocedure TJclMsdosSys.SetBootGUI(ABootGUI: Boolean);\r\nbegin\r\n SetBool(FBootGUI, ABootGUI);\r\nend;\r\n\r\nprocedure TJclMsdosSys.SetBootKeys(ABootKeys: Boolean);\r\nbegin\r\n SetBool(FBootKeys, ABootKeys);\r\nend;\r\n\r\nprocedure TJclMsdosSys.SetBootMenu(ABootMenu: Boolean);\r\nbegin\r\n SetBool(FBootMenu, ABootMenu);\r\nend;\r\n\r\nprocedure TJclMsdosSys.SetBootMenuDefault(ABootMenuDefault: Cardinal);\r\nbegin\r\n if BootMenuDefault <> ABootMenuDefault then\r\n begin\r\n FBootMenuDefault := ABootMenuDefault;\r\n WriteMsdosSys;\r\n end;\r\nend;\r\n\r\nprocedure TJclMsdosSys.SetBootMenuDelay(ABootMenuDelay: Cardinal);\r\nbegin\r\n if BootMenuDelay <> ABootMenuDelay then\r\n begin\r\n FBootMenuDelay := ABootMenuDelay;\r\n WriteMsdosSys;\r\n end;\r\nend;\r\n\r\nprocedure TJclMsdosSys.SetBootMulti(ABootMulti: Boolean);\r\nbegin\r\n SetBool(FBootMulti, ABootMulti);\r\nend;\r\n\r\nprocedure TJclMsdosSys.SetBootSafe(ABootSafe: Boolean);\r\nbegin\r\n SetBool(FBootSafe, ABootSafe);\r\nend;\r\n\r\nprocedure TJclMsdosSys.SetBootWarn(ABootWarn: Boolean);\r\nbegin\r\n SetBool(FBootWarn, ABootWarn);\r\nend;\r\n\r\nprocedure TJclMsdosSys.SetBootWin(ABootWin: Boolean);\r\nbegin\r\n SetBool(FBootWin, ABootWin);\r\nend;\r\n\r\nprocedure TJclMsdosSys.SetDBLSpace(ADBLSpace: Boolean);\r\nbegin\r\n SetBool(FDBLSpace, ADBLSpace);\r\nend;\r\n\r\nprocedure TJclMsdosSys.SetDRVSpace(ADRVSpace: Boolean);\r\nbegin\r\n SetBool(FDRVSpace, ADRVSpace);\r\nend;\r\n\r\nprocedure TJclMsdosSys.SetDoubleBuffer(ADoubleBuffer: Boolean);\r\nbegin\r\n SetBool(FDoubleBuffer, ADoubleBuffer);\r\nend;\r\n\r\nprocedure TJclMsdosSys.SetLoadTop(ALoadTop: Boolean);\r\nbegin\r\n SetBool(FLoadTop, ALoadTop);\r\nend;\r\n\r\nprocedure TJclMsdosSys.SetLogo(ALogo: Boolean);\r\nbegin\r\n SetBool(FLogo, ALogo);\r\nend;\r\n\r\nprocedure TJclMsdosSys.SetNetwork(ANetwork: Boolean);\r\nbegin\r\n SetBool(FNetwork, ANetwork);\r\nend;\r\n\r\nprocedure TJclMsdosSys.SetWinVer(AWinVer: string);\r\nbegin\r\n SetString(FWinVer, AWinVer);\r\nend;\r\n\r\nprocedure TJclMsdosSys.SetBool(var ANew: Boolean; AOld: Boolean);\r\nbegin\r\n if ANew <> AOld then\r\n begin\r\n ANew := AOld;\r\n WriteMsdosSys;\r\n end;\r\nend;\r\n\r\nprocedure TJclMsdosSys.SetString(var ANew: string; AOld: string);\r\nbegin\r\n if ANew <> AOld then\r\n begin\r\n ANew := AOld;\r\n WriteMsdosSys;\r\n end;\r\nend;\r\n\r\nprocedure TJclMsdosSys.ReadMsdosSys;\r\nvar\r\n List: TStringList;\r\n Value: string;\r\n\r\n function BoolVal(const Name: string; const Def: Boolean): Boolean;\r\n var\r\n Val: string;\r\n begin\r\n Result := Def;\r\n Val := Trim(List.Values[Name]);\r\n if Val <> '' then\r\n if Val[1] = '0' then\r\n Result := False\r\n else\r\n if Val[1] = '1' then\r\n Result := True;\r\n end;\r\n\r\nbegin\r\n FUninstallDir := #0;\r\n FHostWinBootDrv := #0;\r\n List := TStringList.Create;\r\n try\r\n List.LoadFromFile(cMsDosSys);\r\n Value := Trim(List.Values['UninstallDir']);\r\n if Value <> '' then\r\n FUninstallDir := Value[1];\r\n FWinDir := Trim(List.Values['WinDir']);\r\n FWinBootDir := Trim(List.Values['WinBootDir']);\r\n Value := Trim(List.Values['HostWinBootDrv']);\r\n if Value <> '' then\r\n FHostWinBootDrv := Value[1];\r\n\r\n FAutoScan := BoolVal('AutoScan', True);\r\n FBootDelay := StrToIntDef(Trim(List.Values['BootDelay']), 2);\r\n FBootGUI := BoolVal('BootGUI', True);\r\n FBootKeys := BoolVal('BootKeys', True);\r\n FBootMenu := BoolVal('BootMenu', False);\r\n FBootMenuDefault := StrToIntDef(Trim(List.Values['BootMenuDefault']), 1);\r\n FBootMenuDelay := StrToIntDef(Trim(List.Values['BootMenuDelay']), 30);\r\n FBootMulti := BoolVal('BootMulti', False);\r\n FBootSafe := BoolVal('BootSafe', False);\r\n FBootWarn := BoolVal('BootWarn', True);\r\n FBootWin := BoolVal('BootWin', True);\r\n FDBLSpace := BoolVal('DBLSpace', True);\r\n FDRVSpace := BoolVal('DRVSpace', True);\r\n FDoubleBuffer := BoolVal('DoubleBuffer', False);\r\n FLoadTop := BoolVal('LoadTop', True);\r\n FLogo := BoolVal('Logo', True);\r\n FNetwork := BoolVal('Network', False);\r\n FWinVer := Trim(List.Values['WinVer']);\r\n finally\r\n List.Free;\r\n end;\r\nend;\r\n\r\nprocedure TJclMsdosSys.WriteMsdosSys;\r\nvar\r\n Attributes: Integer;\r\n I: Char;\r\n Line: string;\r\nbegin\r\n if not FileExists(cMsDosSys) then\r\n Exit;\r\n with TStringList.Create do\r\n try\r\n Add('[Paths]');\r\n if UninstallDir <> #0 then\r\n Add('UninstallDir=' + UninstallDir);\r\n if WinDir <> '' then\r\n Add('WinDir=' + WinDir);\r\n if WinBootDir <> '' then\r\n Add('WinBootDir=' + WinBootDir);\r\n if HostWinBootDrv <> #0 then\r\n Add('HostWinBootDrv=' + HostWinBootDrv);\r\n Add('');\r\n\r\n Add('[Options]');\r\n if not AutoScan then\r\n Add('AutoScan=0');\r\n if BootDelay <> 2 then\r\n Add('BootDelay=' + IntToStr(BootDelay));\r\n if not BootGUI then\r\n Add('BootGUI=0');\r\n if not BootKeys then\r\n Add('BootKeys=0');\r\n if BootMenu then\r\n Add('BootMenu=1');\r\n if BootMenuDefault <> 1 then\r\n Add('BootMenuDefault=' + IntToStr(BootMenuDefault));\r\n if BootMenuDelay <> 30 then\r\n Add('BootMenuDelay=' + IntToStr(BootMenuDelay));\r\n if BootMulti then\r\n Add('BootMulti=1');\r\n if BootSafe then\r\n Add('BootSafe=1');\r\n if not BootWarn then\r\n Add('BootWarn=0');\r\n if not BootWin then\r\n Add('BootWin=0');\r\n if not DBLSpace then\r\n Add('DBLSpace=0');\r\n if not DRVSpace then\r\n Add('DRVSpace=0');\r\n if DoubleBuffer then\r\n Add('DoubleBuffer=1');\r\n if not LoadTop then\r\n Add('LoadTop=0');\r\n if not Logo then\r\n Add('Logo=0');\r\n if Network then\r\n Add('Network=1');\r\n if WinVer <> '' then\r\n Add('WinVer=' + WinVer);\r\n\r\n Add(';');\r\n Add(';The following lines are required for compatibility with other programs.');\r\n Add(';Do not remove them(MSDOS.SYS needs to be >1024 bytes).');\r\n Line := ';' + StringOfChar('x', 69);\r\n for I := 'a' to 's' do\r\n Add(Line+I);\r\n Attributes := FileGetAttr(cMsDosSys) and not faReadOnly;\r\n FileSetAttr(cMsDosSys, Attributes);\r\n SaveToFile(cMsDosSys);\r\n FileSetAttr(cMsDosSys, Attributes or faReadOnly);\r\n finally\r\n Free;\r\n end;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jcl/source/windows/JclMultimedia.pas", "content": "{**************************************************************************************************}\r\n{ }\r\n{ Project JEDI Code Library (JCL) }\r\n{ }\r\n{ The contents of this file are subject to the Mozilla Public License Version 1.1 (the \"License\"); }\r\n{ you may not use this file except in compliance with the License. You may obtain a copy of the }\r\n{ License at http://www.mozilla.org/MPL/ }\r\n{ }\r\n{ Software distributed under the License is distributed on an \"AS IS\" basis, WITHOUT WARRANTY OF }\r\n{ ANY KIND, either express or implied. See the License for the specific language governing rights }\r\n{ and limitations under the License. }\r\n{ }\r\n{ The Original Code is JclMultimedia.pas. }\r\n{ }\r\n{ The Initial Developers of the Original Code are Marcel van Brakel and Bernhard Berger. }\r\n{ Portions created by these individuals are Copyright (C) of these individuals. }\r\n{ All Rights Reserved. }\r\n{ }\r\n{ Contributor(s): }\r\n{ Marcel van Brakel }\r\n{ Robert Marquardt (marquardt) }\r\n{ Robert Rossmair (rrossmair) }\r\n{ Matthias Thoma (mthoma) }\r\n{ Petr Vones (pvones) }\r\n{ }\r\n{**************************************************************************************************}\r\n{ }\r\n{ Contains a high performance timer based on the MultiMedia API and a routine to open or close the }\r\n{ CD-ROM drive. }\r\n{ }\r\n{**************************************************************************************************}\r\n{ }\r\n{ Last modified: $Date:: 2012-09-04 16:08:04 +0200 (mar. 04 sept. 2012) $ }\r\n{ Revision: $Rev:: 3861 $ }\r\n{ Author: $Author:: outchy $ }\r\n{ }\r\n{**************************************************************************************************}\r\n\r\nunit JclMultimedia;\r\n\r\n{$I jcl.inc}\r\n{$I windowsonly.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n {$IFDEF HAS_UNITSCOPE}\r\n Winapi.Windows, System.Classes, Winapi.MMSystem, System.Contnrs,\r\n {$ELSE ~HAS_UNITSCOPE}\r\n Windows, Classes, MMSystem, Contnrs,\r\n {$ENDIF ~HAS_UNITSCOPE}\r\n JclBase, JclSynch, JclStrings;\r\n\r\ntype\r\n // Multimedia timer\r\n TMmTimerKind = (tkOneShot, tkPeriodic);\r\n TMmNotificationKind = (nkCallback, nkSetEvent, nkPulseEvent);\r\n\r\n TJclMultimediaTimer = class(TObject)\r\n private\r\n FEvent: TJclEvent;\r\n FKind: TMmTimerKind;\r\n FNotification: TMmNotificationKind;\r\n FOnTimer: TNotifyEvent;\r\n FPeriod: Cardinal;\r\n FStartTime: Cardinal;\r\n FTimeCaps: TTimeCaps;\r\n FTimerId: Cardinal;\r\n function GetMinMaxPeriod(Index: Integer): Cardinal;\r\n procedure SetPeriod(Value: Cardinal);\r\n protected\r\n procedure Timer(Id: Cardinal); virtual;\r\n public\r\n constructor Create(Kind: TMmTimerKind; Notification: TMmNotificationKind);\r\n destructor Destroy; override;\r\n class function GetTime: Cardinal;\r\n class function BeginPeriod(const Period: Cardinal): Boolean; { TODO -cHelp : Doc }\r\n class function EndPeriod(const Period: Cardinal): Boolean; { TODO -cHelp : Doc }\r\n procedure BeginTimer(const Delay, Resolution: Cardinal);\r\n procedure EndTimer;\r\n function Elapsed(const Update: Boolean): Cardinal;\r\n function WaitFor(const TimeOut: Cardinal): TJclWaitResult;\r\n property Event: TJclEvent read FEvent;\r\n property Kind: TMmTimerKind read FKind;\r\n property MaxPeriod: Cardinal index 0 read GetMinMaxPeriod;\r\n property MinPeriod: Cardinal index 1 read GetMinMaxPeriod;\r\n property Notification: TMmNotificationKind read FNotification;\r\n property OnTimer: TNotifyEvent read FOnTimer write FOnTimer;\r\n property Period: Cardinal read FPeriod write SetPeriod;\r\n end;\r\n\r\n EJclMmTimerError = class(EJclError);\r\n\r\n // Audio Mixer\r\n { TODO -cDoc : mixer API wrapper code. Author: Petr Vones }\r\n\r\n EJclMixerError = class(EJclError);\r\n\r\n TJclMixerDevice = class;\r\n TJclMixerLine = class;\r\n TJclMixerDestination = class;\r\n\r\n TJclMixerLineControl = class(TObject)\r\n private\r\n FControlInfo: TMixerControl;\r\n FIsList: Boolean;\r\n FIsMultiple: Boolean;\r\n FIsUniform: Boolean;\r\n FListText: TStringList;\r\n FMixerLine: TJclMixerLine;\r\n function GetIsDisabled: Boolean;\r\n function GetID: DWORD;\r\n function GetListText: TStrings;\r\n function GetName: string;\r\n function GetUniformValue: Cardinal;\r\n function GetValue: TDynCardinalArray;\r\n function GetValueString: string;\r\n procedure SetUniformValue(const Value: Cardinal);\r\n procedure SetValue(const Value: TDynCardinalArray);\r\n protected\r\n procedure PrepareControlDetailsStruc(out ControlDetails: TMixerControlDetails; AUniform, AMultiple: Boolean);\r\n public\r\n constructor Create(AMixerLine: TJclMixerLine; const AControlInfo: TMixerControl);\r\n destructor Destroy; override;\r\n function FormatValue(AValue: Cardinal): string;\r\n property ControlInfo: TMixerControl read FControlInfo;\r\n property ID: DWORD read GetID;\r\n property IsDisabled: Boolean read GetIsDisabled;\r\n property IsList: Boolean read FIsList;\r\n property IsMultiple: Boolean read FIsMultiple;\r\n property IsUniform: Boolean read FIsUniform;\r\n property ListText: TStrings read GetListText;\r\n property MixerLine: TJclMixerLine read FMixerLine;\r\n property Name: string read GetName;\r\n property UniformValue: Cardinal read GetUniformValue write SetUniformValue;\r\n property Value: TDynCardinalArray read GetValue write SetValue;\r\n property ValueString: string read GetValueString;\r\n end;\r\n\r\n TJclMixerLine = class(TObject)\r\n private\r\n FLineControls: TObjectList;\r\n FLineInfo: TMixerLine;\r\n FMixerDevice: TJclMixerDevice;\r\n function GetComponentString: string;\r\n function GetLineControlByType(ControlType: DWORD): TJclMixerLineControl;\r\n function GetLineControlCount: Integer;\r\n function GetLineControls(Index: Integer): TJclMixerLineControl;\r\n function GetHasControlType(ControlType: DWORD): Boolean;\r\n function GetID: DWORD;\r\n function GetName: string;\r\n protected\r\n procedure BuildLineControls;\r\n public\r\n constructor Create(AMixerDevice: TJclMixerDevice);\r\n destructor Destroy; override;\r\n class function ComponentTypeToString(const ComponentType: DWORD): string;\r\n property ComponentString: string read GetComponentString;\r\n property HasControlType[ControlType: DWORD]: Boolean read GetHasControlType;\r\n property ID: DWORD read GetID;\r\n property LineControlByType[ControlType: DWORD]: TJclMixerLineControl read GetLineControlByType;\r\n property LineControls[Index: Integer]: TJclMixerLineControl read GetLineControls; default;\r\n property LineControlCount: Integer read GetLineControlCount;\r\n property LineInfo: TMixerLine read FLineInfo;\r\n property Name: string read GetName;\r\n property MixerDevice: TJclMixerDevice read FMixerDevice;\r\n end;\r\n\r\n TJclMixerSource = class(TJclMixerLine)\r\n private\r\n FMixerDestination: TJclMixerDestination;\r\n public\r\n constructor Create(AMixerDestination: TJclMixerDestination; ASourceIndex: Cardinal);\r\n property MixerDestination: TJclMixerDestination read FMixerDestination;\r\n end;\r\n\r\n TJclMixerDestination = class(TJclMixerLine)\r\n private\r\n FSources: TObjectList;\r\n function GetSourceCount: Integer;\r\n function GetSources(Index: Integer): TJclMixerSource;\r\n protected\r\n procedure BuildSources;\r\n public\r\n constructor Create(AMixerDevice: TJclMixerDevice; ADestinationIndex: Cardinal);\r\n destructor Destroy; override;\r\n property Sources[Index: Integer]: TJclMixerSource read GetSources; default;\r\n property SourceCount: Integer read GetSourceCount;\r\n end;\r\n\r\n TJclMixerDevice = class(TObject)\r\n private\r\n FCapabilities: TMixerCaps;\r\n FDestinations: TObjectList;\r\n FDeviceIndex: Cardinal;\r\n FHandle: HMIXER;\r\n FLines: TList;\r\n function GetProductName: string;\r\n function GetDestinationCount: Integer;\r\n function GetDestinations(Index: Integer): TJclMixerDestination;\r\n function GetLineCount: Integer;\r\n function GetLines(Index: Integer): TJclMixerLine;\r\n function GetLineByComponentType(ComponentType: DWORD): TJclMixerLine;\r\n function GetLineByID(LineID: DWORD): TJclMixerLine;\r\n function GetLineControlByID(ControlID: DWORD): TJclMixerLineControl;\r\n function GetLineUniformValue(ComponentType, ControlType: DWORD): Cardinal;\r\n procedure SetLineUniformValue(ComponentType, ControlType: DWORD; const Value: Cardinal);\r\n protected\r\n procedure BuildDestinations;\r\n procedure BuildLines;\r\n procedure Close;\r\n procedure Open(ACallBackWnd: THandle);\r\n public\r\n constructor Create(ADeviceIndex: Cardinal; ACallBackWnd: THandle);\r\n destructor Destroy; override;\r\n function FindLineControl(ComponentType, ControlType: DWORD): TJclMixerLineControl;\r\n property Capabilities: TMixerCaps read FCapabilities;\r\n property DeviceIndex: Cardinal read FDeviceIndex;\r\n property Destinations[Index: Integer]: TJclMixerDestination read GetDestinations; default;\r\n property DestinationCount: Integer read GetDestinationCount;\r\n property Handle: HMIXER read FHandle;\r\n property LineByID[LineID: DWORD]: TJclMixerLine read GetLineByID;\r\n property LineByComponentType[ComponentType: DWORD]: TJclMixerLine read GetLineByComponentType;\r\n property Lines[Index: Integer]: TJclMixerLine read GetLines;\r\n property LineCount: Integer read GetLineCount;\r\n property LineControlByID[ControlID: DWORD]: TJclMixerLineControl read GetLineControlByID;\r\n property LineUniformValue[ComponentType, ControlType: DWORD]: Cardinal read GetLineUniformValue write SetLineUniformValue;\r\n property ProductName: string read GetProductName;\r\n end;\r\n\r\n TJclMixer = class(TObject)\r\n private\r\n FCallbackWnd: THandle;\r\n FDeviceList: TObjectList;\r\n function GetDeviceCount: Integer;\r\n function GetDevices(Index: Integer): TJclMixerDevice;\r\n function GetFirstDevice: TJclMixerDevice;\r\n function GetLineMute(ComponentType: Integer): Boolean;\r\n function GetLineVolume(ComponentType: Integer): Cardinal;\r\n function GetLineByID(MixerHandle: HMIXER; LineID: DWORD): TJclMixerLine;\r\n function GetLineControlByID(MixerHandle: HMIXER; LineID: DWORD): TJclMixerLineControl;\r\n procedure SetLineMute(ComponentType: Integer; const Value: Boolean);\r\n procedure SetLineVolume(ComponentType: Integer; const Value: Cardinal);\r\n protected\r\n procedure BuildDevices;\r\n public\r\n constructor Create(ACallBackWnd: THandle = 0);\r\n destructor Destroy; override;\r\n property CallbackWnd: THandle read FCallbackWnd;\r\n property Devices[Index: Integer]: TJclMixerDevice read GetDevices; default;\r\n property DeviceCount: Integer read GetDeviceCount;\r\n property FirstDevice: TJclMixerDevice read GetFirstDevice;\r\n property LineByID[MixerHandle: HMIXER; LineID: DWORD]: TJclMixerLine read GetLineByID;\r\n property LineControlByID[MixerHandle: HMIXER; LineID: DWORD]: TJclMixerLineControl read GetLineControlByID;\r\n property LineMute[ComponentType: Integer]: Boolean read GetLineMute write SetLineMute;\r\n property LineVolume[ComponentType: Integer]: Cardinal read GetLineVolume write SetLineVolume;\r\n property SpeakersMute: Boolean index MIXERLINE_COMPONENTTYPE_DST_SPEAKERS read GetLineMute write SetLineMute;\r\n property SpeakersVolume: Cardinal index MIXERLINE_COMPONENTTYPE_DST_SPEAKERS read GetLineVolume write SetLineVolume;\r\n end;\r\n\r\n function MixerLeftRightToArray(Left, Right: Cardinal): TDynCardinalArray;\r\n\r\nconst\r\n {$IFDEF BORLAND}\r\n INVALID_MIXER_HANDLE: HMIXER = -1;\r\n {$ENDIF BORLAND}\r\n {$IFDEF FPC}\r\n INVALID_MIXER_HANDLE: HMIXER = $FFFFFFFF;\r\n {$ENDIF FPC}\r\n\r\ntype\r\n // MCI Error checking\r\n EJclMciError = class(EJclError)\r\n private\r\n FMciErrorNo: DWORD;\r\n FMciErrorMsg: string;\r\n public\r\n constructor Create(MciErrNo: MCIERROR; const Msg: string);\r\n constructor CreateFmt(MciErrNo: MCIERROR; const Msg: string; const Args: array of const);\r\n constructor CreateRes(MciErrNo: MCIERROR; Ident: Integer; Dummy: Integer);\r\n property MciErrorNo: DWORD read FMciErrorNo;\r\n property MciErrorMsg: string read FMciErrorMsg;\r\n end;\r\n\r\nfunction MMCheck(const MciError: MCIERROR; const Msg: string = ''): MCIERROR;\r\nfunction GetMciErrorMessage(const MciErrNo: MCIERROR): string;\r\n\r\n// CD Drive MCI Routines\r\nfunction OpenCdMciDevice(out OpenParams: TMCI_Open_Parms; Drive: Char = #0): MCIERROR;\r\nfunction CloseCdMciDevice(var OpenParams: TMCI_Open_Parms): MCIERROR;\r\n\r\n// CD Drive specific routines\r\nprocedure OpenCloseCdDrive(OpenMode: Boolean; Drive: Char = #0);\r\n\r\nfunction IsMediaPresentInDrive(Drive: Char = #0): Boolean;\r\n\r\ntype\r\n TJclCdMediaInfo = (miProduct, miIdentity, miUPC);\r\n\r\n TJclCdTrackType = (ttAudio, ttOther);\r\n TJclCdTrackInfo = record\r\n Minute: Byte;\r\n Second: Byte;\r\n TrackType: TJclCdTrackType;\r\n end;\r\n TJclCdTrackInfoArray = array of TJclCdTrackInfo;\r\n\r\nfunction GetCdInfo(InfoType: TJclCdMediaInfo; Drive: Char = #0): string;\r\n\r\nfunction GetCDAudioTrackList(out TrackList: TJclCdTrackInfoArray; Drive: Char = #0): TJclCdTrackInfo; overload;\r\nfunction GetCDAudioTrackList(TrackList: TStrings; IncludeTrackType: Boolean = False; Drive: Char = #0): string; overload;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jcl.svn.sourceforge.net/svnroot/jcl/tags/JCL-2.4-Build4571/jcl/source/windows/JclMultimedia.pas $';\r\n Revision: '$Revision: 3861 $';\r\n Date: '$Date: 2012-09-04 16:08:04 +0200 (mar. 04 sept. 2012) $';\r\n LogPath: 'JCL\\source\\windows';\r\n Extra: '';\r\n Data: nil\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n {$IFDEF HAS_UNITSCOPE}\r\n System.SysUtils,\r\n {$ELSE ~HAS_UNITSCOPE}\r\n SysUtils,\r\n {$ENDIF ~HAS_UNITSCOPE}\r\n JclResources, JclSysUtils;\r\n\r\n//=== { TJclMultimediaTimer } ================================================\r\n\r\nconstructor TJclMultimediaTimer.Create(Kind: TMmTimerKind; Notification: TMmNotificationKind);\r\nbegin\r\n FKind := Kind;\r\n FNotification := Notification;\r\n FPeriod := 0;\r\n FTimerID := 0;\r\n FEvent := nil;\r\n ResetMemory(FTimeCaps, SizeOf(FTimeCaps));\r\n if timeGetDevCaps(@FTimeCaps, SizeOf(FTimeCaps)) = TIMERR_STRUCT then\r\n raise EJclMmTimerError.CreateRes(@RsMmTimerGetCaps);\r\n FPeriod := FTimeCaps.wPeriodMin;\r\n if Notification <> nkCallback then\r\n FEvent := TJclEvent.Create(nil, Notification = nkSetEvent, False, '');\r\nend;\r\n\r\ndestructor TJclMultimediaTimer.Destroy;\r\nbegin\r\n EndTimer;\r\n FreeAndNil(FEvent);\r\n FOnTimer := nil;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure MmTimerCallback(TimerId, Msg: Cardinal; User, dw1, dw2: DWORD); stdcall;\r\nbegin\r\n TJclMultimediaTimer(User).Timer(TimerId);\r\nend;\r\n\r\nclass function TJclMultimediaTimer.BeginPeriod(const Period: Cardinal): Boolean;\r\nbegin\r\n Result := timeBeginPeriod(Period) = TIMERR_NOERROR;\r\nend;\r\n\r\nprocedure TJclMultimediaTimer.BeginTimer(const Delay, Resolution: Cardinal);\r\nvar\r\n Event: Cardinal;\r\n TimerCallback: TFNTimeCallBack;\r\nbegin\r\n if FTimerId <> 0 then\r\n raise EJclMmTimerError.CreateRes(@RsMmTimerActive);\r\n Event := 0;\r\n TimerCallback := nil;\r\n case FKind of\r\n tkPeriodic:\r\n Event := TIME_PERIODIC;\r\n tkOneShot:\r\n Event := TIME_ONESHOT;\r\n end;\r\n case FNotification of\r\n nkCallback:\r\n begin\r\n Event := Event or TIME_CALLBACK_FUNCTION;\r\n TimerCallback := @MmTimerCallback;\r\n end;\r\n nkSetEvent:\r\n begin\r\n Event := Event or TIME_CALLBACK_EVENT_SET;\r\n TimerCallback := TFNTimeCallback(FEvent.Handle);\r\n end;\r\n nkPulseEvent:\r\n begin\r\n Event := Event or TIME_CALLBACK_EVENT_PULSE;\r\n TimerCallback := TFNTimeCallback(FEvent.Handle);\r\n end;\r\n end;\r\n FStartTime := GetTime;\r\n if timeBeginPeriod(FPeriod) = TIMERR_NOERROR then\r\n FTimerId := timeSetEvent(Delay, Resolution, TimerCallBack, DWORD_PTR(Self), Event);\r\n if FTimerId = 0 then\r\n raise EJclMmTimerError.CreateRes(@RsMmSetEvent);\r\nend;\r\n\r\nfunction TJclMultimediaTimer.Elapsed(const Update: Boolean): Cardinal;\r\nvar\r\n CurrentTime: Cardinal;\r\nbegin\r\n if FTimerId = 0 then\r\n Result := 0\r\n else\r\n begin\r\n CurrentTime := GetTime;\r\n if CurrentTime >= FStartTime then\r\n Result := CurrentTime - FStartTime\r\n else\r\n Result := (High(Cardinal) - FStartTime) + CurrentTime;\r\n if Update then\r\n FStartTime := CurrentTime;\r\n end;\r\nend;\r\n\r\nclass function TJclMultimediaTimer.EndPeriod(const Period: Cardinal): Boolean;\r\nbegin\r\n Result := timeEndPeriod(Period) = TIMERR_NOERROR;\r\nend;\r\n\r\nprocedure TJclMultimediaTimer.EndTimer;\r\nbegin\r\n if FTimerId <> 0 then\r\n begin\r\n if FKind = tkPeriodic then\r\n timeKillEvent(FTimerId);\r\n timeEndPeriod(FPeriod);\r\n FTimerId := 0;\r\n end;\r\nend;\r\n\r\nfunction TJclMultimediaTimer.GetMinMaxPeriod(Index: Integer): Cardinal;\r\nbegin\r\n case Index of\r\n 0:\r\n Result := FTimeCaps.wPeriodMax;\r\n 1:\r\n Result := FTimeCaps.wPeriodMin;\r\n else\r\n Result := 0;\r\n end;\r\nend;\r\n\r\nclass function TJclMultimediaTimer.GetTime: Cardinal;\r\nbegin\r\n Result := timeGetTime;\r\nend;\r\n\r\nprocedure TJclMultimediaTimer.SetPeriod(Value: Cardinal);\r\nbegin\r\n if FTimerId <> 0 then\r\n raise EJclMmTimerError.CreateRes(@RsMmTimerActive);\r\n FPeriod := Value;\r\nend;\r\n\r\n{ TODO -cHelp : Applications should not call any system-defined functions from\r\n inside a callback function, except for PostMessage, timeGetSystemTime,\r\n timeGetTime, timeSetEvent, timeKillEvent, midiOutShortMsg, midiOutLongMsg,\r\n and OutputDebugString. }\r\nprocedure TJclMultimediaTimer.Timer(Id: Cardinal);\r\nbegin\r\n { TODO : A exception in the callbacl i very likely very critically }\r\n if Id <> FTimerId then\r\n raise EJclMmTimerError.CreateRes(@RsMmInconsistentId);\r\n if Assigned(FOnTimer) then\r\n FOnTimer(Self);\r\nend;\r\n\r\nfunction TJclMultimediaTimer.WaitFor(const TimeOut: Cardinal): TJclWaitResult;\r\nbegin\r\n if FNotification = nkCallback then\r\n Result := wrError\r\n else\r\n Result := FEvent.WaitFor(TimeOut);\r\nend;\r\n\r\n//=== { TJclMixerLineControl } ===============================================\r\n\r\nfunction MixerLeftRightToArray(Left, Right: Cardinal): TDynCardinalArray;\r\nbegin\r\n SetLength(Result, 2);\r\n Result[0] := Left;\r\n Result[1] := Right;\r\nend;\r\n\r\nconstructor TJclMixerLineControl.Create(AMixerLine: TJclMixerLine; const AControlInfo: TMixerControl);\r\nbegin\r\n FControlInfo := AControlInfo;\r\n FMixerLine := AMixerLine;\r\n FIsList := (ControlInfo.dwControlType and MIXERCONTROL_CT_CLASS_MASK) = MIXERCONTROL_CT_CLASS_LIST;\r\n FIsMultiple := FControlInfo.fdwControl and MIXERCONTROL_CONTROLF_MULTIPLE <> 0;\r\n FIsUniform := FControlInfo.fdwControl and MIXERCONTROL_CONTROLF_UNIFORM <> 0;\r\nend;\r\n\r\ndestructor TJclMixerLineControl.Destroy;\r\nbegin\r\n FreeAndNil(FListText);\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJclMixerLineControl.FormatValue(AValue: Cardinal): string;\r\nbegin\r\n case FControlInfo.dwControlType and MIXERCONTROL_CT_UNITS_MASK of\r\n MIXERCONTROL_CT_UNITS_BOOLEAN:\r\n Result := BooleanToStr(Boolean(AValue));\r\n MIXERCONTROL_CT_UNITS_SIGNED:\r\n Result := Format('%d', [AValue]);\r\n MIXERCONTROL_CT_UNITS_UNSIGNED:\r\n Result := Format('%u', [AValue]);\r\n MIXERCONTROL_CT_UNITS_DECIBELS:\r\n Result := Format('%.1fdB', [AValue / 10]);\r\n MIXERCONTROL_CT_UNITS_PERCENT:\r\n Result := Format('%.1f%%', [AValue / 10]);\r\n else\r\n Result := '';\r\n end;\r\nend;\r\n\r\nfunction TJclMixerLineControl.GetID: DWORD;\r\nbegin\r\n Result := ControlInfo.dwControlID;\r\nend;\r\n\r\nfunction TJclMixerLineControl.GetIsDisabled: Boolean;\r\nbegin\r\n Result := FControlInfo.fdwControl and MIXERCONTROL_CONTROLF_DISABLED <> 0;\r\nend;\r\n\r\nfunction TJclMixerLineControl.GetListText: TStrings;\r\nvar\r\n ControlDetails: TMIXERCONTROLDETAILS;\r\n ListTexts, P: ^MIXERCONTROLDETAILS_LISTTEXT;\r\n I: Cardinal;\r\nbegin\r\n if FListText = nil then\r\n begin\r\n FListText := TStringList.Create;\r\n if IsMultiple and IsList then\r\n begin\r\n PrepareControlDetailsStruc(ControlDetails, True, IsMultiple);\r\n ControlDetails.cbDetails := SizeOf(MIXERCONTROLDETAILS_LISTTEXT);\r\n GetMem(ListTexts, SizeOf(MIXERCONTROLDETAILS_LISTTEXT) * ControlDetails.cMultipleItems);\r\n try\r\n ControlDetails.paDetails := ListTexts;\r\n if mixerGetControlDetails(MixerLine.MixerDevice.Handle, @ControlDetails, MIXER_GETCONTROLDETAILSF_LISTTEXT) = MMSYSERR_NOERROR then\r\n begin\r\n P := ListTexts;\r\n for I := 1 to ControlDetails.cMultipleItems do\r\n begin\r\n FListText.AddObject(P^.szName, Pointer(P^.dwParam1));\r\n Inc(P);\r\n end;\r\n end; \r\n finally\r\n FreeMem(ListTexts);\r\n end;\r\n end;\r\n end;\r\n Result := FListText;\r\nend;\r\n\r\nfunction TJclMixerLineControl.GetName: string;\r\nbegin\r\n Result := FControlInfo.szName;\r\nend;\r\n\r\nfunction TJclMixerLineControl.GetUniformValue: Cardinal;\r\nvar\r\n ControlDetails: TMixerControlDetails;\r\nbegin\r\n PrepareControlDetailsStruc(ControlDetails, True, False);\r\n ControlDetails.cbDetails := SizeOf(Cardinal);\r\n ControlDetails.paDetails := @Result;\r\n MMCheck(mixerGetControlDetails(MixerLine.MixerDevice.Handle, @ControlDetails, MIXER_GETCONTROLDETAILSF_VALUE));\r\nend;\r\n\r\nfunction TJclMixerLineControl.GetValue: TDynCardinalArray;\r\nvar\r\n ControlDetails: TMixerControlDetails;\r\n ItemCount: Cardinal;\r\nbegin\r\n PrepareControlDetailsStruc(ControlDetails, IsUniform, IsMultiple);\r\n if IsUniform then\r\n ItemCount := 1\r\n else\r\n ItemCount := ControlDetails.cChannels;\r\n if IsMultiple then\r\n ItemCount := ItemCount * ControlDetails.cMultipleItems;\r\n SetLength(Result, ItemCount);\r\n ControlDetails.cbDetails := SizeOf(Cardinal);\r\n ControlDetails.paDetails := @Result[0];\r\n MMCheck(mixerGetControlDetails(MixerLine.MixerDevice.Handle, @ControlDetails, MIXER_GETCONTROLDETAILSF_VALUE));\r\nend;\r\n\r\nfunction TJclMixerLineControl.GetValueString: string;\r\nvar\r\n TempValue: TDynCardinalArray;\r\n I: Integer;\r\nbegin\r\n TempValue := Value;\r\n Result := '';\r\n for I := Low(TempValue) to High(TempValue) do\r\n Result := Result + ',' + FormatValue(TempValue[I]);\r\n Delete(Result, 1, 1);\r\nend;\r\n\r\nprocedure TJclMixerLineControl.PrepareControlDetailsStruc(out ControlDetails: TMixerControlDetails;\r\n AUniform, AMultiple: Boolean);\r\nbegin\r\n ResetMemory(ControlDetails, SizeOf(ControlDetails));\r\n ControlDetails.cbStruct := SizeOf(ControlDetails);\r\n ControlDetails.dwControlID := FControlInfo.dwControlID;\r\n if AUniform then\r\n ControlDetails.cChannels := MIXERCONTROL_CONTROLF_UNIFORM\r\n else\r\n ControlDetails.cChannels := MixerLine.LineInfo.cChannels;\r\n if AMultiple then\r\n ControlDetails.cMultipleItems := FControlInfo.cMultipleItems;\r\nend;\r\n\r\nprocedure TJclMixerLineControl.SetUniformValue(const Value: Cardinal);\r\nvar\r\n ControlDetails: TMixerControlDetails;\r\nbegin\r\n PrepareControlDetailsStruc(ControlDetails, True, False);\r\n ControlDetails.cbDetails := SizeOf(Cardinal);\r\n ControlDetails.paDetails := @Value;\r\n MMCheck(mixerSetControlDetails(MixerLine.MixerDevice.Handle, @ControlDetails, MIXER_GETCONTROLDETAILSF_VALUE));\r\nend;\r\n\r\nprocedure TJclMixerLineControl.SetValue(const Value: TDynCardinalArray);\r\nvar\r\n ControlDetails: TMixerControlDetails;\r\n {$IFDEF ASSERTIONS_ON}\r\n ItemCount: Cardinal;\r\n {$ENDIF ASSERTIONS_ON}\r\nbegin\r\n PrepareControlDetailsStruc(ControlDetails, IsUniform, IsMultiple);\r\n {$IFDEF ASSERTIONS_ON}\r\n if IsUniform then\r\n ItemCount := 1\r\n else\r\n ItemCount := ControlDetails.cChannels;\r\n if IsMultiple then\r\n ItemCount := ItemCount * ControlDetails.cMultipleItems;\r\n Assert(ItemCount = Cardinal(Length(Value)));\r\n {$ENDIF ASSERTIONS_ON}\r\n ControlDetails.cbDetails := SizeOf(Cardinal);\r\n ControlDetails.paDetails := @Value[0];\r\n MMCheck(mixerSetControlDetails(MixerLine.MixerDevice.Handle, @ControlDetails, MIXER_GETCONTROLDETAILSF_VALUE));\r\nend;\r\n\r\n//=== { TJclMixerLine } ======================================================\r\n\r\nfunction MixerLineCompareID(Item1, Item2: Pointer): Integer;\r\nbegin\r\n Result := Integer(TJclMixerLine(Item1).ID) - Integer(TJclMixerLine(Item2).ID);\r\nend;\r\n\r\nfunction MixerLineSearchID(Param: Pointer; ItemIndex: Integer; const Value): Integer;\r\nbegin\r\n Result := Integer(TJclMixerDevice(Param).Lines[ItemIndex].ID) - Integer(Value);\r\nend;\r\n\r\nconstructor TJclMixerLine.Create(AMixerDevice: TJclMixerDevice);\r\nbegin\r\n FMixerDevice := AMixerDevice;\r\n FLineControls := TObjectList.Create;\r\nend;\r\n\r\ndestructor TJclMixerLine.Destroy;\r\nbegin\r\n FreeAndNil(FLineControls);\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJclMixerLine.BuildLineControls;\r\nvar\r\n MixerControls: TMixerLineControls;\r\n Controls, P: PMixerControl;\r\n I: Cardinal;\r\n Item: TJclMixerLineControl;\r\nbegin\r\n GetMem(Controls, SizeOf(TMixerControl) * FLineInfo.cControls);\r\n try\r\n MixerControls.cbStruct := SizeOf(MixerControls);\r\n MixerControls.dwLineID := FLineInfo.dwLineID;\r\n MixerControls.cControls := FLineInfo.cControls;\r\n MixerControls.cbmxctrl := SizeOf(TMixerControl);\r\n MixerControls.pamxctrl := Controls;\r\n if mixerGetLineControls(FMixerDevice.Handle, @MixerControls, MIXER_GETLINECONTROLSF_ALL) = MMSYSERR_NOERROR then\r\n begin\r\n P := Controls;\r\n for I := 1 to FLineInfo.cControls do\r\n begin\r\n Item := TJclMixerLineControl.Create(Self, P^);\r\n FLineControls.Add(Item);\r\n Inc(P);\r\n end;\r\n end; \r\n finally\r\n FreeMem(Controls);\r\n end;\r\nend;\r\n\r\nclass function TJclMixerLine.ComponentTypeToString(const ComponentType: DWORD): string;\r\nbegin\r\n case ComponentType of\r\n MIXERLINE_COMPONENTTYPE_DST_UNDEFINED:\r\n Result := LoadResString(@RsMmMixerUndefined);\r\n MIXERLINE_COMPONENTTYPE_DST_DIGITAL, MIXERLINE_COMPONENTTYPE_SRC_DIGITAL:\r\n Result := LoadResString(@RsMmMixerDigital);\r\n MIXERLINE_COMPONENTTYPE_DST_LINE, MIXERLINE_COMPONENTTYPE_SRC_LINE:\r\n Result := LoadResString(@RsMmMixerLine);\r\n MIXERLINE_COMPONENTTYPE_DST_MONITOR:\r\n Result := LoadResString(@RsMmMixerMonitor);\r\n MIXERLINE_COMPONENTTYPE_DST_SPEAKERS:\r\n Result := LoadResString(@RsMmMixerSpeakers);\r\n MIXERLINE_COMPONENTTYPE_DST_HEADPHONES:\r\n Result := LoadResString(@RsMmMixerHeadphones);\r\n MIXERLINE_COMPONENTTYPE_DST_TELEPHONE, MIXERLINE_COMPONENTTYPE_SRC_TELEPHONE:\r\n Result := LoadResString(@RsMmMixerTelephone);\r\n MIXERLINE_COMPONENTTYPE_DST_WAVEIN:\r\n Result := LoadResString(@RsMmMixerWaveIn);\r\n MIXERLINE_COMPONENTTYPE_DST_VOICEIN:\r\n Result := LoadResString(@RsMmMixerVoiceIn);\r\n MIXERLINE_COMPONENTTYPE_SRC_MICROPHONE:\r\n Result := LoadResString(@RsMmMixerMicrophone);\r\n MIXERLINE_COMPONENTTYPE_SRC_SYNTHESIZER:\r\n Result := LoadResString(@RsMmMixerSynthesizer);\r\n MIXERLINE_COMPONENTTYPE_SRC_COMPACTDISC:\r\n Result := LoadResString(@RsMmMixerCompactDisc);\r\n MIXERLINE_COMPONENTTYPE_SRC_PCSPEAKER:\r\n Result := LoadResString(@RsMmMixerPcSpeaker);\r\n MIXERLINE_COMPONENTTYPE_SRC_WAVEOUT:\r\n Result := LoadResString(@RsMmMixerWaveOut);\r\n MIXERLINE_COMPONENTTYPE_SRC_AUXILIARY:\r\n Result := LoadResString(@RsMmMixerAuxiliary);\r\n MIXERLINE_COMPONENTTYPE_SRC_ANALOG:\r\n Result := LoadResString(@RsMmMixerAnalog);\r\n else\r\n Result := '';\r\n end;\r\nend;\r\n\r\nfunction TJclMixerLine.GetComponentString: string;\r\nbegin\r\n Result := ComponentTypeToString(FLineInfo.dwComponentType);\r\nend;\r\n\r\nfunction TJclMixerLine.GetHasControlType(ControlType: DWORD): Boolean;\r\nbegin\r\n Result := LineControlByType[ControlType] <> nil;\r\nend;\r\n\r\nfunction TJclMixerLine.GetID: DWORD;\r\nbegin\r\n Result := LineInfo.dwLineID;\r\nend;\r\n\r\nfunction TJclMixerLine.GetLineControlByType(ControlType: DWORD): TJclMixerLineControl;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := nil;\r\n for I := 0 to LineControlCount - 1 do\r\n if LineControls[I].ControlInfo.dwControlType = ControlType then\r\n begin\r\n Result := LineControls[I];\r\n Break;\r\n end;\r\nend;\r\n\r\nfunction TJclMixerLine.GetLineControlCount: Integer;\r\nbegin\r\n Result := FLineControls.Count;\r\n if Result = 0 then\r\n begin\r\n BuildLineControls;\r\n Result := FLineControls.Count;\r\n end;\r\nend;\r\n\r\nfunction TJclMixerLine.GetLineControls(Index: Integer): TJclMixerLineControl;\r\nbegin\r\n Result := TJclMixerLineControl(FLineControls[Index]);\r\nend;\r\n\r\nfunction TJclMixerLine.GetName: string;\r\nbegin\r\n Result := FLineInfo.szName;\r\nend;\r\n\r\n//=== { TJclMixerSource } ====================================================\r\n\r\nconstructor TJclMixerSource.Create(AMixerDestination: TJclMixerDestination; ASourceIndex: Cardinal);\r\nbegin\r\n inherited Create(AMixerDestination.MixerDevice);\r\n FMixerDestination := AMixerDestination;\r\n FLineInfo.cbStruct := SizeOf(FLineInfo);\r\n FLineInfo.dwDestination := FMixerDestination.LineInfo.dwDestination;\r\n FLineInfo.dwSource := ASourceIndex;\r\n MMCheck(mixerGetLineInfo(FMixerDestination.MixerDevice.Handle, @FLineInfo, MIXER_GETLINEINFOF_SOURCE));\r\nend;\r\n\r\n//=== { TJclMixerDestination } ===============================================\r\n\r\nconstructor TJclMixerDestination.Create(AMixerDevice: TJclMixerDevice; ADestinationIndex: Cardinal);\r\nbegin\r\n inherited Create(AMixerDevice);\r\n FLineInfo.cbStruct := SizeOf(FLineInfo);\r\n FLineInfo.dwDestination := ADestinationIndex;\r\n MMCheck(mixerGetLineInfo(AMixerDevice.Handle, @FLineInfo, MIXER_GETLINEINFOF_DESTINATION));\r\n FSources := TObjectList.Create;\r\nend;\r\n\r\ndestructor TJclMixerDestination.Destroy;\r\nbegin\r\n FreeAndNil(FSources);\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJclMixerDestination.BuildSources;\r\nvar\r\n I: Cardinal;\r\n Item: TJclMixerSource;\r\nbegin\r\n for I := 1 to LineInfo.cConnections do\r\n begin\r\n Item := TJclMixerSource.Create(Self, I - 1);\r\n FSources.Add(Item);\r\n end;\r\nend;\r\n\r\nfunction TJclMixerDestination.GetSourceCount: Integer;\r\nbegin\r\n Result := FSources.Count;\r\n if Result = 0 then\r\n begin\r\n BuildSources;\r\n Result := FSources.Count;\r\n end;\r\nend;\r\n\r\nfunction TJclMixerDestination.GetSources(Index: Integer): TJclMixerSource;\r\nbegin\r\n Result := TJclMixerSource(FSources[Index]);\r\nend;\r\n\r\n//=== { TJclMixerDevice } ====================================================\r\n\r\nconstructor TJclMixerDevice.Create(ADeviceIndex: Cardinal; ACallBackWnd: THandle);\r\nbegin\r\n FDeviceIndex := ADeviceIndex;\r\n FHandle := INVALID_MIXER_HANDLE;\r\n FDestinations := TObjectList.Create;\r\n FLines := TList.Create;\r\n MMCheck(mixerGetDevCaps(ADeviceIndex, @FCapabilities, SizeOf(FCapabilities)));\r\n Open(ACallBackWnd);\r\n BuildDestinations;\r\nend;\r\n\r\ndestructor TJclMixerDevice.Destroy;\r\nbegin\r\n Close;\r\n FreeAndNil(FDestinations);\r\n FreeAndNil(FLines);\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJclMixerDevice.BuildDestinations;\r\nvar\r\n I: Cardinal;\r\n Item: TJclMixerDestination;\r\nbegin\r\n for I := 1 to FCapabilities.cDestinations do\r\n begin\r\n Item := TJclMixerDestination.Create(Self, I - 1);\r\n FDestinations.Add(Item);\r\n end;\r\nend;\r\n\r\nprocedure TJclMixerDevice.BuildLines;\r\nvar\r\n D, I: Integer;\r\n Dest: TJclMixerDestination;\r\nbegin\r\n for D := 0 to DestinationCount - 1 do\r\n begin\r\n Dest := Destinations[D];\r\n FLines.Add(Dest);\r\n for I := 0 to Dest.SourceCount - 1 do\r\n FLines.Add(Dest.Sources[I]);\r\n end;\r\n FLines.Sort(MixerLineCompareID);\r\nend;\r\n\r\nprocedure TJclMixerDevice.Close;\r\nbegin\r\n if FHandle <> INVALID_MIXER_HANDLE then\r\n begin\r\n mixerClose(FHandle);\r\n FHandle := INVALID_MIXER_HANDLE;\r\n end;\r\nend;\r\n\r\nfunction TJclMixerDevice.FindLineControl(ComponentType, ControlType: DWORD): TJclMixerLineControl;\r\nvar\r\n TempLine: TJclMixerLine;\r\nbegin\r\n Result := nil;\r\n TempLine := LineByComponentType[ComponentType];\r\n if TempLine <> nil then\r\n Result := TempLine.LineControlByType[ControlType];\r\nend;\r\n\r\nfunction TJclMixerDevice.GetDestinationCount: Integer;\r\nbegin\r\n Result := FDestinations.Count;\r\nend;\r\n\r\nfunction TJclMixerDevice.GetDestinations(Index: Integer): TJclMixerDestination;\r\nbegin\r\n Result := TJclMixerDestination(FDestinations[Index]);\r\nend;\r\n\r\nfunction TJclMixerDevice.GetLineByComponentType(ComponentType: DWORD): TJclMixerLine;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := nil;\r\n for I := 0 to LineCount - 1 do\r\n if Lines[I].LineInfo.dwComponentType = ComponentType then\r\n begin\r\n Result := Lines[I];\r\n Break;\r\n end;\r\nend;\r\n\r\nfunction TJclMixerDevice.GetLineByID(LineID: DWORD): TJclMixerLine;\r\nvar\r\n I: Integer;\r\nbegin\r\n I := SearchSortedUntyped(Self, LineCount, MixerLineSearchID, LineID);\r\n if I = -1 then\r\n Result := nil\r\n else\r\n Result := Lines[I];\r\nend;\r\n\r\nfunction TJclMixerDevice.GetLineControlByID(ControlID: DWORD): TJclMixerLineControl;\r\nvar\r\n L, C: Integer;\r\n TempLine: TJclMixerLine;\r\nbegin\r\n Result := nil;\r\n for L := 0 to LineCount - 1 do\r\n begin\r\n TempLine := Lines[L];\r\n for C := 0 to TempLine.LineControlCount - 1 do\r\n if TempLine.LineControls[C].ID = ControlID then\r\n begin\r\n Result := TempLine.LineControls[C];\r\n Break;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJclMixerDevice.GetLineCount: Integer;\r\nbegin\r\n Result := FLines.Count;\r\n if Result = 0 then\r\n begin\r\n BuildLines;\r\n Result := FLines.Count;\r\n end; \r\nend;\r\n\r\nfunction TJclMixerDevice.GetLines(Index: Integer): TJclMixerLine;\r\nbegin\r\n Result := TJclMixerLine(FLines[Index]);\r\nend;\r\n\r\nfunction TJclMixerDevice.GetLineUniformValue(ComponentType, ControlType: DWORD): Cardinal;\r\nvar\r\n LineControl: TJclMixerLineControl;\r\nbegin\r\n LineControl := FindLineControl(ComponentType, ControlType);\r\n if LineControl <> nil then\r\n Result := LineControl.UniformValue\r\n else\r\n Result := 0; \r\nend;\r\n\r\nfunction TJclMixerDevice.GetProductName: string;\r\nbegin\r\n Result := FCapabilities.szPname;\r\nend;\r\n\r\nprocedure TJclMixerDevice.Open(ACallBackWnd: THandle);\r\nvar\r\n Flags: DWORD;\r\nbegin\r\n if FHandle = INVALID_MIXER_HANDLE then\r\n begin\r\n Flags := MIXER_OBJECTF_HMIXER;\r\n if ACallBackWnd <> 0 then\r\n Inc(Flags, CALLBACK_WINDOW);\r\n MMCheck(mixerOpen(@FHandle, DeviceIndex, ACallBackWnd, 0, Flags));\r\n end;\r\nend;\r\n\r\nprocedure TJclMixerDevice.SetLineUniformValue(ComponentType, ControlType: DWORD; const Value: Cardinal);\r\nvar\r\n LineControl: TJclMixerLineControl;\r\nbegin\r\n LineControl := FindLineControl(ComponentType, ControlType);\r\n if LineControl <> nil then\r\n LineControl.UniformValue := Value\r\n else\r\n raise EJclMixerError.CreateResFmt(@RsMmMixerCtlNotFound,\r\n [TJclMixerLine.ComponentTypeToString(ComponentType), ControlType]);\r\nend;\r\n\r\n//=== { TJclMixer } ==========================================================\r\n\r\nconstructor TJclMixer.Create(ACallBackWnd: THandle);\r\nbegin\r\n FDeviceList := TObjectList.Create;\r\n FCallbackWnd := ACallBackWnd;\r\n BuildDevices;\r\nend;\r\n\r\ndestructor TJclMixer.Destroy;\r\nbegin\r\n FreeAndNil(FDeviceList);\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJclMixer.BuildDevices;\r\nvar\r\n I: Cardinal;\r\n Item: TJclMixerDevice;\r\nbegin\r\n for I := 1 to mixerGetNumDevs do\r\n begin\r\n Item := TJclMixerDevice.Create(I - 1, FCallbackWnd);\r\n FDeviceList.Add(Item);\r\n end;\r\nend;\r\n\r\nfunction TJclMixer.GetDeviceCount: Integer;\r\nbegin\r\n Result := FDeviceList.Count;\r\nend;\r\n\r\nfunction TJclMixer.GetDevices(Index: Integer): TJclMixerDevice;\r\nbegin\r\n Result := TJclMixerDevice(FDeviceList.Items[Index]);\r\nend;\r\n\r\nfunction TJclMixer.GetFirstDevice: TJclMixerDevice;\r\nbegin\r\n if DeviceCount = 0 then\r\n raise EJclMixerError.CreateRes(@RsMmMixerNoDevices);\r\n Result := Devices[0];\r\nend;\r\n\r\nfunction TJclMixer.GetLineByID(MixerHandle: HMIXER; LineID: DWORD): TJclMixerLine;\r\nvar\r\n I: Integer;\r\n TempDevice: TJclMixerDevice;\r\nbegin\r\n Result := nil;\r\n for I := 0 to DeviceCount - 1 do\r\n begin\r\n TempDevice := Devices[I];\r\n if TempDevice.Handle = MixerHandle then\r\n begin\r\n Result := TempDevice.LineByID[LineID];\r\n if Result <> nil then\r\n Break;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJclMixer.GetLineControlByID(MixerHandle: HMIXER; LineID: DWORD): TJclMixerLineControl;\r\nvar\r\n I: Integer;\r\n TempDevice: TJclMixerDevice;\r\nbegin\r\n Result := nil;\r\n for I := 0 to DeviceCount - 1 do\r\n begin\r\n TempDevice := Devices[I];\r\n if TempDevice.Handle = MixerHandle then\r\n begin\r\n Result := TempDevice.LineControlByID[LineID];\r\n if Result <> nil then\r\n Break;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJclMixer.GetLineMute(ComponentType: Integer): Boolean;\r\nbegin\r\n Result := Boolean(FirstDevice.LineUniformValue[Cardinal(ComponentType), MIXERCONTROL_CONTROLTYPE_MUTE]);\r\nend;\r\n\r\nfunction TJclMixer.GetLineVolume(ComponentType: Integer): Cardinal;\r\nbegin\r\n Result := FirstDevice.LineUniformValue[Cardinal(ComponentType), MIXERCONTROL_CONTROLTYPE_VOLUME];\r\nend;\r\n\r\nprocedure TJclMixer.SetLineMute(ComponentType: Integer; const Value: Boolean);\r\nbegin\r\n FirstDevice.LineUniformValue[Cardinal(ComponentType), MIXERCONTROL_CONTROLTYPE_MUTE] := Cardinal(Value);\r\nend;\r\n\r\nprocedure TJclMixer.SetLineVolume(ComponentType: Integer; const Value: Cardinal);\r\nbegin\r\n FirstDevice.LineUniformValue[Cardinal(ComponentType), MIXERCONTROL_CONTROLTYPE_VOLUME] := Value;\r\nend;\r\n\r\n//=== { EJclMciError } =======================================================\r\n\r\nconstructor EJclMciError.Create(MciErrNo: MCIERROR; const Msg: string);\r\nbegin\r\n FMciErrorNo := MciErrNo;\r\n FMciErrorMsg := GetMciErrorMessage(MciErrNo);\r\n inherited Create(Msg + NativeLineBreak + LoadResString(@RsMmMciErrorPrefix) + FMciErrorMsg);\r\nend;\r\n\r\nconstructor EJclMciError.CreateFmt(MciErrNo: MCIERROR; const Msg: string;\r\n const Args: array of const);\r\nbegin\r\n FMciErrorNo := MciErrNo;\r\n FMciErrorMsg := GetMciErrorMessage(MciErrNo);\r\n inherited CreateFmt(Msg + NativeLineBreak + LoadResString(@RsMmMciErrorPrefix) + FMciErrorMsg, Args);\r\nend;\r\n\r\nconstructor EJclMciError.CreateRes(MciErrNo: MCIERROR; Ident: Integer; Dummy: Integer);\r\nbegin\r\n FMciErrorNo := MciErrNo;\r\n FMciErrorMsg := GetMciErrorMessage(MciErrNo);\r\n inherited Create(LoadStr(Ident)+ NativeLineBreak + LoadResString(@RsMmMciErrorPrefix) + FMciErrorMsg);\r\nend;\r\n\r\nfunction GetMciErrorMessage(const MciErrNo: MCIERROR): string;\r\nvar\r\n Buffer: array [0..{$IFDEF HAS_UNITSCOPE}Winapi.{$ENDIF}MMSystem.MAXERRORLENGTH - 1] of Char;\r\nbegin\r\n if mciGetErrorString(MciErrNo, Buffer, SizeOf(Buffer)) then\r\n Result := Buffer\r\n else\r\n Result := Format(LoadResString(@RsMmUnknownError), [MciErrNo]);\r\nend;\r\n\r\nfunction MMCheck(const MciError: MCIERROR; const Msg: string): MCIERROR;\r\nbegin\r\n if MciError <> MMSYSERR_NOERROR then\r\n raise EJclMciError.Create(MciError, Msg);\r\n Result := MciError;\r\nend;\r\n\r\n//=== CD Drive MCI Routines ==================================================\r\n\r\nfunction OpenCdMciDevice(out OpenParams: TMCI_Open_Parms; Drive: Char): MCIERROR;\r\nvar\r\n OpenParam: DWORD;\r\n DriveName: array [0..2] of Char;\r\nbegin\r\n ResetMemory(OpenParams, SizeOf(OpenParams));\r\n OpenParam := MCI_OPEN_TYPE or MCI_OPEN_TYPE_ID or MCI_OPEN_SHAREABLE;\r\n OpenParams.lpstrDeviceType := PChar(MCI_DEVTYPE_CD_AUDIO);\r\n if Drive <> #0 then\r\n begin\r\n OpenParams.lpstrElementName := StrFmt(DriveName, '%s:', [UpCase(Drive)]);\r\n Inc(OpenParam, MCI_OPEN_ELEMENT);\r\n end;\r\n Result := mciSendCommand(0, MCI_OPEN, OpenParam, TJclAddr(@OpenParams));\r\nend;\r\n\r\nfunction CloseCdMciDevice(var OpenParams: TMCI_Open_Parms): MCIERROR;\r\nbegin\r\n Result := mciSendCommand(OpenParams.wDeviceID, MCI_CLOSE, MCI_WAIT, 0);\r\n if Result = MMSYSERR_NOERROR then\r\n ResetMemory(OpenParams, SizeOf(OpenParams));\r\nend;\r\n\r\n//=== CD Drive specific routines =============================================\r\n\r\nprocedure OpenCloseCdDrive(OpenMode: Boolean; Drive: Char);\r\nconst\r\n OpenCmd: array [Boolean] of DWORD =\r\n (MCI_SET_DOOR_CLOSED, MCI_SET_DOOR_OPEN);\r\nvar\r\n Mci: TMCI_Open_Parms;\r\nbegin\r\n MMCheck(OpenCdMciDevice(Mci, Drive), LoadResString(@RsMmNoCdAudio));\r\n try\r\n MMCheck(mciSendCommand(Mci.wDeviceID, MCI_SET, OpenCmd[OpenMode], 0));\r\n finally\r\n CloseCdMciDevice(Mci);\r\n end;\r\nend;\r\n\r\nfunction IsMediaPresentInDrive(Drive: Char): Boolean;\r\nvar\r\n Mci: TMCI_Open_Parms;\r\n StatusParams: TMCI_Status_Parms;\r\nbegin\r\n MMCheck(OpenCdMciDevice(Mci, Drive), LoadResString(@RsMmNoCdAudio));\r\n try\r\n ResetMemory(StatusParams, SizeOf(StatusParams));\r\n StatusParams.dwItem := MCI_STATUS_MEDIA_PRESENT;\r\n MMCheck(mciSendCommand(Mci.wDeviceID, MCI_STATUS, MCI_STATUS_ITEM or MCI_WAIT, TJclAddr(@StatusParams)));\r\n Result := Boolean(StatusParams.dwReturn);\r\n finally\r\n CloseCdMciDevice(Mci);\r\n end;\r\nend;\r\n\r\nfunction GetCdInfo(InfoType: TJclCdMediaInfo; Drive: Char): string;\r\nconst\r\n InfoConsts: array [TJclCdMediaInfo] of DWORD =\r\n (MCI_INFO_PRODUCT, MCI_INFO_MEDIA_IDENTITY, MCI_INFO_MEDIA_UPC);\r\nvar\r\n Mci: TMCI_Open_Parms;\r\n InfoParams: TMCI_Info_Parms;\r\n Buffer: array [0..255] of Char;\r\nbegin\r\n Result := '';\r\n MMCheck(OpenCdMciDevice(Mci, Drive), LoadResString(@RsMmNoCdAudio));\r\n try\r\n ResetMemory(Buffer, SizeOf(Buffer));\r\n InfoParams.dwCallback := 0;\r\n InfoParams.lpstrReturn := Buffer;\r\n InfoParams.dwRetSize := SizeOf(Buffer) - 1;\r\n if mciSendCommand(Mci.wDeviceID, MCI_INFO, InfoConsts[InfoType], TJclAddr(@InfoParams)) = MMSYSERR_NOERROR then\r\n Result := Buffer;\r\n finally\r\n CloseCdMciDevice(Mci);\r\n end;\r\nend;\r\n\r\nfunction GetCDAudioTrackList(out TrackList: TJclCdTrackInfoArray; Drive: Char): TJclCdTrackInfo;\r\nvar\r\n Mci: TMCI_Open_Parms;\r\n SetParams: TMCI_Set_Parms;\r\n TrackCnt, Ret: Cardinal;\r\n I: Integer;\r\n\r\n function GetTrackInfo(Command, Item, Track: DWORD): DWORD;\r\n var\r\n StatusParams: TMCI_Status_Parms;\r\n begin\r\n ResetMemory(StatusParams, SizeOf(StatusParams));\r\n StatusParams.dwItem := Item;\r\n StatusParams.dwTrack := Track;\r\n if mciSendCommand(Mci.wDeviceID, MCI_STATUS, Command, TJclAddr(@StatusParams)) = MMSYSERR_NOERROR then\r\n Result := StatusParams.dwReturn\r\n else\r\n Result := 0;\r\n end;\r\n\r\nbegin\r\n MMCheck(OpenCdMciDevice(Mci, Drive), LoadResString(@RsMmNoCdAudio));\r\n try\r\n ResetMemory(SetParams, SizeOf(SetParams));\r\n SetParams.dwTimeFormat := MCI_FORMAT_MSF;\r\n MMCheck(mciSendCommand(Mci.wDeviceID, MCI_SET, MCI_SET_TIME_FORMAT, TJclAddr(@SetParams)));\r\n Result.TrackType := ttOther;\r\n TrackCnt := GetTrackInfo(MCI_STATUS_ITEM, MCI_STATUS_NUMBER_OF_TRACKS, 0);\r\n SetLength(TrackList, TrackCnt);\r\n for I := 0 to TrackCnt - 1 do\r\n begin\r\n Ret := GetTrackInfo(MCI_STATUS_ITEM or MCI_TRACK, MCI_STATUS_LENGTH, I + 1);\r\n TrackList[I].Minute := mci_MSF_Minute(Ret);\r\n TrackList[I].Second := mci_MSF_Second(Ret);\r\n Ret := GetTrackInfo(MCI_STATUS_ITEM or MCI_TRACK, MCI_CDA_STATUS_TYPE_TRACK, I + 1);\r\n if Ret = MCI_CDA_TRACK_AUDIO then\r\n begin\r\n Result.TrackType := ttAudio;\r\n TrackList[I].TrackType := ttAudio;\r\n end \r\n else\r\n TrackList[I].TrackType := ttOther;\r\n end;\r\n Ret := GetTrackInfo(MCI_STATUS_ITEM, MCI_STATUS_LENGTH, 0);\r\n Result.Minute := mci_MSF_Minute(Ret);\r\n Result.Second := mci_MSF_Second(Ret);\r\n finally\r\n CloseCdMciDevice(Mci);\r\n end;\r\nend;\r\n\r\nfunction GetCDAudioTrackList(TrackList: TStrings; IncludeTrackType: Boolean; Drive: Char): string;\r\nvar\r\n Tracks: TJclCdTrackInfoArray;\r\n TotalTime: TJclCdTrackInfo;\r\n I: Integer;\r\n S: string;\r\nbegin\r\n TotalTime := GetCDAudioTrackList(Tracks, Drive);\r\n TrackList.BeginUpdate;\r\n try\r\n for I := Low(Tracks) to High(Tracks) do\r\n with Tracks[I] do\r\n begin\r\n if IncludeTrackType then\r\n begin\r\n case TrackType of\r\n ttAudio:\r\n S := LoadResString(@RsMMTrackAudio);\r\n ttOther:\r\n S := LoadResString(@RsMMTrackOther);\r\n end;\r\n S := Format('[%s]', [S]);\r\n end\r\n else\r\n S := '';\r\n S := Format(LoadResString(@RsMmCdTrackNo), [I + 1]) + ' ' + S;\r\n S := S + ' ' + Format(LoadResString(@RsMMCdTimeFormat), [I + 1, Minute, Second]);\r\n TrackList.Add(S);\r\n end;\r\n finally\r\n TrackList.EndUpdate;\r\n end;\r\n Result := Format(LoadResString(@RsMMCdTimeFormat), [TotalTime.Minute, TotalTime.Second]);\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jcl/source/windows/JclNTFS.pas", "content": "{**************************************************************************************************}\r\n{ }\r\n{ Project JEDI Code Library (JCL) }\r\n{ }\r\n{ The contents of this file are subject to the Mozilla Public License Version 1.1 (the \"License\"); }\r\n{ you may not use this file except in compliance with the License. You may obtain a copy of the }\r\n{ License at http://www.mozilla.org/MPL/ }\r\n{ }\r\n{ Software distributed under the License is distributed on an \"AS IS\" basis, WITHOUT WARRANTY OF }\r\n{ ANY KIND, either express or implied. See the License for the specific language governing rights }\r\n{ and limitations under the License. }\r\n{ }\r\n{ The Original Code is JclNTFS.pas. }\r\n{ }\r\n{ The Initial Developer of the Original Code is Marcel van Brakel. Portions created by Marcel van }\r\n{ Brakel are Copyright (C) Marcel van Brakel. All Rights Reserved. }\r\n{ }\r\n{ Contributor(s): }\r\n{ Marcel van Brakel }\r\n{ Robert Marquardt (marquardt) }\r\n{ Robert Rossmair (rrossmair) }\r\n{ Petr Vones (pvones) }\r\n{ Oliver Schneider (assarbad) }\r\n{ ZENsan }\r\n{ Florent Ouchet (outchy) }\r\n{ }\r\n{**************************************************************************************************}\r\n{ }\r\n{ Contains routines to perform filesystem related tasks available only with NTFS. These are mostly }\r\n{ relatively straightforward wrappers for various IOCTs related to compression, sparse files, }\r\n{ reparse points, volume mount points and so forth. Note that some functions require NTFS 5 or }\r\n{ higher! }\r\n{ }\r\n{**************************************************************************************************}\r\n{ }\r\n{ Last modified: $Date:: 2011-09-03 00:07:50 +0200 (sam. 03 sept. 2011) $ }\r\n{ Revision: $Rev:: 3599 $ }\r\n{ Author: $Author:: outchy $ }\r\n{ }\r\n{**************************************************************************************************}\r\n\r\n// Comments on Win9x compatibility of the functions used in this unit\r\n\r\n// These stubs exist on Windows 95B already but all of them\r\n// return ERROR_CALL_NOT_IMPLEMENTED:\r\n// BackupSeek, BackupRead, BackupWrite\r\n\r\nunit JclNTFS;\r\n\r\n{$I jcl.inc}\r\n{$I windowsonly.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n {$IFDEF HAS_UNITSCOPE}\r\n Winapi.Windows, System.SysUtils, System.Classes, Winapi.ActiveX,\r\n {$ELSE ~HAS_UNITSCOPE}\r\n Windows, SysUtils, Classes, ActiveX,\r\n {$ENDIF ~HAS_UNITSCOPE}\r\n JclBase, JclWin32;\r\n\r\n// NTFS Exception\r\ntype\r\n EJclNtfsError = class(EJclWin32Error);\r\n\r\n// NTFS - Compression\r\ntype\r\n TFileCompressionState = (fcNoCompression, fcDefaultCompression, fcLZNT1Compression);\r\n\r\nfunction NtfsGetCompression(const FileName: TFileName; out State: Short): Boolean; overload;\r\nfunction NtfsGetCompression(const FileName: TFileName): TFileCompressionState; overload;\r\nfunction NtfsSetCompression(const FileName: TFileName; const State: Short): Boolean;\r\nprocedure NtfsSetFileCompression(const FileName: TFileName; const State: TFileCompressionState);\r\nprocedure NtfsSetDirectoryTreeCompression(const Directory: string; const State: TFileCompressionState);\r\nprocedure NtfsSetDefaultFileCompression(const Directory: string; const State: TFileCompressionState);\r\nprocedure NtfsSetPathCompression(const Path: string; const State: TFileCompressionState; Recursive: Boolean);\r\n\r\n// NTFS - Sparse Files\r\ntype\r\n TNtfsAllocRanges = record\r\n Entries: Cardinal;\r\n Data: PFileAllocatedRangeBuffer;\r\n MoreData: Boolean;\r\n end;\r\n\r\nfunction NtfsSetSparse(const FileName: string): Boolean;\r\nfunction NtfsZeroDataByHandle(const Handle: THandle; const First, Last: Int64): Boolean;\r\nfunction NtfsZeroDataByName(const FileName: string; const First, Last: Int64): Boolean;\r\nfunction NtfsQueryAllocRanges(const FileName: string; Offset, Count: Int64; var Ranges: TNtfsAllocRanges): Boolean;\r\nfunction NtfsGetAllocRangeEntry(const Ranges: TNtfsAllocRanges; Index: TJclAddr): TFileAllocatedRangeBuffer;\r\nfunction NtfsSparseStreamsSupported(const Volume: string): Boolean;\r\nfunction NtfsGetSparse(const FileName: string): Boolean;\r\n\r\n// NTFS - Reparse Points\r\nfunction NtfsDeleteReparsePoint(const FileName: string; ReparseTag: DWORD): Boolean;\r\nfunction NtfsSetReparsePoint(const FileName: string; var ReparseData; Size: Longword): Boolean;\r\nfunction NtfsGetReparsePoint(const FileName: string; var ReparseData: TReparseGuidDataBuffer): Boolean;\r\nfunction NtfsGetReparseTag(const Path: string; var Tag: DWORD): Boolean;\r\nfunction NtfsReparsePointsSupported(const Volume: string): Boolean;\r\nfunction NtfsFileHasReparsePoint(const Path: string): Boolean;\r\n\r\n// NTFS - Volume Mount Points\r\nfunction NtfsIsFolderMountPoint(const Path: string): Boolean;\r\nfunction NtfsMountDeviceAsDrive(const Device: WideString; Drive: Char): Boolean;\r\nfunction NtfsMountVolume(const Volume: WideChar; const MountPoint: WideString): Boolean;\r\n\r\n// NTFS - Change Journal\r\n// NTFS - Opportunistic Locks\r\ntype\r\n TOpLock = (olExclusive, olReadOnly, olBatch, olFilter);\r\n\r\nfunction NtfsOpLockAckClosePending(Handle: THandle; Overlapped: TOverlapped): Boolean;\r\nfunction NtfsOpLockBreakAckNo2(Handle: THandle; Overlapped: TOverlapped): Boolean;\r\nfunction NtfsOpLockBreakAcknowledge(Handle: THandle; Overlapped: TOverlapped): Boolean;\r\nfunction NtfsOpLockBreakNotify(Handle: THandle; Overlapped: TOverlapped): Boolean;\r\nfunction NtfsRequestOpLock(Handle: THandle; Kind: TOpLock; Overlapped: TOverlapped): Boolean;\r\n\r\n// Junction Points\r\nfunction NtfsCreateJunctionPoint(const Source, Destination: string): Boolean;\r\nfunction NtfsDeleteJunctionPoint(const Source: string): Boolean;\r\nfunction NtfsGetJunctionPointDestination(const Source: string; var Destination: string): Boolean;\r\n\r\n// Streams\r\ntype\r\n TStreamId = (siInvalid, siStandard, siExtendedAttribute, siSecurity, siAlternate,\r\n siHardLink, siProperty, siObjectIdentifier, siReparsePoints, siSparseFile);\r\n TStreamIds = set of TStreamId;\r\n\r\n TInternalFindStreamData = record\r\n FileHandle: THandle;\r\n Context: Pointer;\r\n StreamIds: TStreamIds;\r\n end;\r\n\r\n TFindStreamData = record\r\n Internal: TInternalFindStreamData;\r\n Attributes: DWORD;\r\n StreamID: TStreamId;\r\n Name: WideString;\r\n Size: Int64;\r\n end;\r\n\r\nfunction NtfsFindFirstStream(const FileName: string; StreamIds: TStreamIds; var Data: TFindStreamData): Boolean;\r\nfunction NtfsFindNextStream(var Data: TFindStreamData): Boolean;\r\nfunction NtfsFindStreamClose(var Data: TFindStreamData): Boolean;\r\n\r\n// Hard links\r\nfunction NtfsCreateHardLink(const LinkFileName, ExistingFileName: String): Boolean;\r\n// ANSI-specific version\r\nfunction NtfsCreateHardLinkA(const LinkFileName, ExistingFileName: AnsiString): Boolean;\r\n// UNICODE-specific version\r\nfunction NtfsCreateHardLinkW(const LinkFileName, ExistingFileName: WideString): Boolean;\r\n\r\ntype\r\n TNtfsHardLinkInfo = record\r\n LinkCount: Cardinal;\r\n case Integer of\r\n 0: (\r\n FileIndexHigh: Cardinal;\r\n FileIndexLow: Cardinal);\r\n 1: (\r\n FileIndex: Int64);\r\n end;\r\n\r\nfunction NtfsGetHardLinkInfo(const FileName: string; var Info: TNtfsHardLinkInfo): Boolean;\r\n\r\nfunction NtfsFindHardLinks(const Path: string; const FileIndexHigh, FileIndexLow: Cardinal; const List: TStrings): Boolean;\r\nfunction NtfsDeleteHardLinks(const FileName: string): Boolean;\r\n\r\n// NTFS File summary\r\ntype\r\n EJclFileSummaryError = class(EJclError);\r\n\r\n TJclFileSummaryAccess = (fsaRead, fsaWrite, fsaReadWrite);\r\n TJclFileSummaryShare = (fssDenyNone, fssDenyRead, fssDenyWrite, fssDenyAll);\r\n TJclFileSummaryPropSetCallback = function(const FMTID: TGUID): Boolean of object;\r\n TJclFileSummaryPropCallback = function(const Name: WideString; ID: TPropID;\r\n Vt: TVarType): Boolean of object;\r\n\r\n TJclFileSummary = class;\r\n\r\n TJclFilePropertySet = class\r\n private\r\n FPropertyStorage: IPropertyStorage;\r\n public\r\n constructor Create(APropertyStorage: IPropertyStorage);\r\n destructor Destroy; override;\r\n\r\n class function GetFMTID: TGUID; virtual;\r\n function GetProperty(ID: TPropID): TPropVariant; overload;\r\n function GetProperty(const Name: WideString): TPropVariant; overload;\r\n procedure SetProperty(ID: TPropID; const Value: TPropVariant); overload;\r\n procedure SetProperty(const Name: WideString; const Value: TPropVariant;\r\n AllocationBase: TPropID = PID_FIRST_USABLE); overload;\r\n procedure DeleteProperty(ID: TPropID); overload;\r\n procedure DeleteProperty(const Name: WideString); overload;\r\n function EnumProperties(Proc: TJclFileSummaryPropCallback): Boolean;\r\n\r\n // casted properties\r\n // Type of ID changed to Integer to be compatible with indexed properties\r\n // VT_LPWSTR\r\n function GetWideStringProperty(const ID: Integer): WideString;\r\n procedure SetWideStringProperty(const ID: Integer; const Value: WideString);\r\n // VT_LPSTR\r\n function GetAnsiStringProperty(const ID: Integer): AnsiString;\r\n procedure SetAnsiStringProperty(const ID: Integer; const Value: AnsiString);\r\n // VT_I4\r\n function GetIntegerProperty(const ID: Integer): Integer;\r\n procedure SetIntegerProperty(const ID: Integer; const Value: Integer);\r\n // VT_UI4\r\n function GetCardinalProperty(const ID: Integer): Cardinal;\r\n procedure SetCardinalProperty(const ID: Integer; const Value: Cardinal);\r\n // VT_FILETIME\r\n function GetFileTimeProperty(const ID: Integer): TFileTime;\r\n procedure SetFileTimeProperty(const ID: Integer; const Value: TFileTime);\r\n // VT_CF\r\n function GetClipDataProperty(const ID: Integer): PClipData;\r\n procedure SetClipDataProperty(const ID: Integer; const Value: PClipData);\r\n // VT_BOOL\r\n function GetBooleanProperty(const ID: Integer): Boolean;\r\n procedure SetBooleanProperty(const ID: Integer; const Value: Boolean);\r\n // VT_VARIANT | VT_VECTOR\r\n function GetTCAPROPVARIANTProperty(const ID: Integer): TCAPROPVARIANT;\r\n procedure SetTCAPROPVARIANTProperty(const ID: Integer; const Value: TCAPROPVARIANT);\r\n // // VT_LPSTR | VT_VECTOR\r\n function GetTCALPSTRProperty(const ID: Integer): TCALPSTR;\r\n procedure SetTCALPSTRProperty(const ID: Integer; const Value: TCALPSTR);\r\n // VT_UI2\r\n function GetWordProperty(const ID: Integer): Word;\r\n procedure SetWordProperty(const ID: Integer; const Value: Word);\r\n // VT_BSTR\r\n function GetBSTRProperty(const ID: Integer): WideString;\r\n procedure SetBSTRProperty(const ID: Integer; const Value: WideString);\r\n\r\n // property names\r\n function GetPropertyName(ID: TPropID): WideString;\r\n procedure SetPropertyName(ID: TPropID; const Name: WideString);\r\n procedure DeletePropertyName(ID: TPropID);\r\n end;\r\n\r\n TJclFilePropertySetClass = class of TJclFilePropertySet;\r\n\r\n TJclFileSummary = class\r\n private\r\n FFileName: WideString;\r\n FAccessMode: TJclFileSummaryAccess;\r\n FShareMode: TJclFileSummaryShare;\r\n FStorage: IPropertySetStorage;\r\n public\r\n constructor Create(AFileName: WideString; AAccessMode: TJclFileSummaryAccess;\r\n AShareMode: TJclFileSummaryShare; AsDocument: Boolean = False;\r\n ACreate: Boolean = False);\r\n destructor Destroy; override;\r\n\r\n function CreatePropertySet(AClass: TJclFilePropertySetClass; ResetExisting: Boolean): TJclFilePropertySet;\r\n procedure GetPropertySet(AClass: TJclFilePropertySetClass; out Instance); overload;\r\n procedure GetPropertySet(const FMTID: TGUID; out Instance); overload;\r\n function GetPropertySet(const FMTID: TGUID): IPropertyStorage; overload;\r\n procedure DeletePropertySet(const FMTID: TGUID); overload;\r\n procedure DeletePropertySet(AClass: TJclFilePropertySetClass); overload;\r\n function EnumPropertySet(Proc: TJclFileSummaryPropSetCallback): Boolean;\r\n\r\n property FileName: WideString read FFileName;\r\n property AccessMode: TJclFileSummaryAccess read FAccessMode;\r\n property ShareMode: TJclFileSummaryShare read FShareMode;\r\n end;\r\n\r\n TJclFileSummaryInformation = class(TJclFilePropertySet)\r\n public\r\n class function GetFMTID: TGUID; override;\r\n\r\n property Title: AnsiString index PIDSI_TITLE read GetAnsiStringProperty\r\n write SetAnsiStringProperty;\r\n property Subject: AnsiString index PIDSI_SUBJECT read GetAnsiStringProperty\r\n write SetAnsiStringProperty;\r\n property Author: AnsiString index PIDSI_AUTHOR read GetAnsiStringProperty\r\n write SetAnsiStringProperty;\r\n property KeyWords: AnsiString index PIDSI_KEYWORDS read GetAnsiStringProperty\r\n write SetAnsiStringProperty;\r\n property Comments: AnsiString index PIDSI_COMMENTS read GetAnsiStringProperty\r\n write SetAnsiStringProperty;\r\n property Template: AnsiString index PIDSI_TEMPLATE read GetAnsiStringProperty\r\n write SetAnsiStringProperty;\r\n property LastAuthor: AnsiString index PIDSI_LASTAUTHOR read GetAnsiStringProperty\r\n write SetAnsiStringProperty;\r\n property RevNumber: AnsiString index PIDSI_REVNUMBER read GetAnsiStringProperty\r\n write SetAnsiStringProperty;\r\n property EditTime: TFileTime index PIDSI_EDITTIME read GetFileTimeProperty\r\n write SetFileTimeProperty;\r\n property LastPrintedTime: TFileTime index PIDSI_LASTPRINTED read GetFileTimeProperty\r\n write SetFileTimeProperty;\r\n property CreationTime: TFileTime index PIDSI_CREATE_DTM read GetFileTimeProperty\r\n write SetFileTimeProperty;\r\n property LastSaveTime: TFileTime index PIDSI_LASTSAVE_DTM read GetFileTimeProperty\r\n write SetFileTimeProperty;\r\n property PageCount: Integer index PIDSI_PAGECOUNT read GetIntegerProperty\r\n write SetIntegerProperty;\r\n property WordCount: Integer index PIDSI_WORDCOUNT read GetIntegerProperty\r\n write SetIntegerProperty;\r\n property CharCount: Integer index PIDSI_CHARCOUNT read GetIntegerProperty\r\n write SetIntegerProperty;\r\n property Thumnail: PClipData index PIDSI_THUMBNAIL read GetClipDataProperty\r\n write SetClipDataProperty;\r\n property AppName: AnsiString index PIDSI_APPNAME read GetAnsiStringProperty\r\n write SetAnsiStringProperty;\r\n property Security: Integer index PIDSI_DOC_SECURITY read GetIntegerProperty\r\n write SetIntegerProperty;\r\n end;\r\n\r\n TJclDocSummaryInformation = class(TJclFilePropertySet)\r\n public\r\n class function GetFMTID: TGUID; override;\r\n\r\n property Category: AnsiString index PIDDSI_CATEGORY read GetAnsiStringProperty\r\n write SetAnsiStringProperty;\r\n property PresFormat: AnsiString index PIDDSI_PRESFORMAT read GetAnsiStringProperty\r\n write SetAnsiStringProperty;\r\n property ByteCount: Integer index PIDDSI_BYTECOUNT read GetIntegerProperty\r\n write SetIntegerProperty;\r\n property LineCount: Integer index PIDDSI_LINECOUNT read GetIntegerProperty\r\n write SetIntegerProperty;\r\n property ParCount: Integer index PIDDSI_PARCOUNT read GetIntegerProperty\r\n write SetIntegerProperty;\r\n property SlideCount: Integer index PIDDSI_SLIDECOUNT read GetIntegerProperty\r\n write SetIntegerProperty;\r\n property NoteCount: Integer index PIDDSI_NOTECOUNT read GetIntegerProperty\r\n write SetIntegerProperty;\r\n property HiddenCount: Integer index PIDDSI_HIDDENCOUNT read GetIntegerProperty\r\n write SetIntegerProperty;\r\n property MMClipCount: Integer index PIDDSI_MMCLIPCOUNT read GetIntegerProperty\r\n write SetIntegerProperty;\r\n property Scale: Boolean index PIDDSI_SCALE read GetBooleanProperty\r\n write SetBooleanProperty;\r\n property HeadingPair: TCAPROPVARIANT index PIDDSI_HEADINGPAIR read GetTCAPROPVARIANTProperty\r\n write SetTCAPROPVARIANTProperty;\r\n property DocParts: TCALPSTR index PIDDSI_DOCPARTS read GetTCALPSTRProperty\r\n write SetTCALPSTRProperty;\r\n property Manager: AnsiString index PIDDSI_MANAGER read GetAnsiStringProperty\r\n write SetAnsiStringProperty;\r\n property Company: AnsiString index PIDDSI_COMPANY read GetAnsiStringProperty\r\n write SetAnsiStringProperty;\r\n property LinksDirty: Boolean index PIDDSI_LINKSDIRTY read GetBooleanProperty\r\n write SetBooleanProperty;\r\n end;\r\n\r\n TJclMediaFileSummaryInformation = class(TJclFilePropertySet)\r\n public\r\n class function GetFMTID: TGUID; override;\r\n\r\n property Editor: WideString index PIDMSI_EDITOR read GetWideStringProperty\r\n write SetWideStringProperty;\r\n property Supplier: WideString index PIDMSI_SUPPLIER read GetWideStringProperty\r\n write SetWideStringProperty;\r\n property Source: WideString index PIDMSI_SOURCE read GetWideStringProperty\r\n write SetWideStringProperty;\r\n property SequenceNo: WideString index PIDMSI_SEQUENCE_NO read GetWideStringProperty\r\n write SetWideStringProperty;\r\n property Project: WideString index PIDMSI_PROJECT read GetWideStringProperty\r\n write SetWideStringProperty;\r\n property Status: Cardinal index PIDMSI_STATUS read GetCardinalProperty\r\n write SetCardinalProperty;\r\n property Owner: WideString index PIDMSI_OWNER read GetWideStringProperty\r\n write SetWideStringProperty;\r\n property Rating: WideString index PIDMSI_RATING read GetWideStringProperty\r\n write SetWideStringProperty;\r\n property Production: TFileTime index PIDMSI_PRODUCTION read GetFileTimeProperty\r\n write SetFileTimeProperty;\r\n property Copyright: WideString index PIDMSI_COPYRIGHT read GetWideStringProperty\r\n write SetWideStringProperty;\r\n end;\r\n\r\n TJclMSISummaryInformation = class(TJclFilePropertySet)\r\n public\r\n class function GetFMTID: TGUID; override;\r\n\r\n property Version: Integer index PID_MSIVERSION read GetIntegerProperty\r\n write SetIntegerProperty; // integer, Installer version number (major*100+minor)\r\n property Source: Integer index PID_MSISOURCE read GetIntegerProperty\r\n write SetIntegerProperty; // integer, type of file image, short/long, media/tree\r\n property Restrict: Integer index PID_MSIRESTRICT read GetIntegerProperty\r\n write SetIntegerProperty; // integer, transform restrictions\r\n end;\r\n\r\n TJclShellSummaryInformation = class(TJclFilePropertySet)\r\n public\r\n class function GetFMTID: TGUID; override;\r\n\r\n {PID_FINDDATA = 0;\r\n PID_NETRESOURCE = 1;\r\n PID_DESCRIPTIONID = 2;\r\n PID_WHICHFOLDER = 3;\r\n PID_NETWORKLOCATION = 4;\r\n PID_COMPUTERNAME = 5;}\r\n end;\r\n\r\n TJclStorageSummaryInformation = class(TJclFilePropertySet)\r\n public\r\n class function GetFMTID: TGUID; override;\r\n end;\r\n\r\n TJclImageSummaryInformation = class(TJclFilePropertySet)\r\n public\r\n class function GetFMTID: TGUID; override;\r\n end;\r\n\r\n TJclDisplacedSummaryInformation = class(TJclFilePropertySet)\r\n public\r\n class function GetFMTID: TGUID; override;\r\n\r\n {PID_FINDDATA = 0;\r\n PID_NETRESOURCE = 1;\r\n PID_DESCRIPTIONID = 2;\r\n PID_WHICHFOLDER = 3;\r\n PID_NETWORKLOCATION = 4;\r\n PID_COMPUTERNAME = 5;}\r\n end;\r\n\r\n TJclBriefCaseSummaryInformation = class(TJclFilePropertySet)\r\n public\r\n class function GetFMTID: TGUID; override;\r\n\r\n {PID_SYNC_COPY_IN = 2;}\r\n end;\r\n\r\n TJclMiscSummaryInformation = class(TJclFilePropertySet)\r\n public\r\n class function GetFMTID: TGUID; override;\r\n\r\n {PID_MISC_STATUS = 2;\r\n PID_MISC_ACCESSCOUNT = 3;\r\n PID_MISC_OWNER = 4;\r\n PID_HTMLINFOTIPFILE = 5;\r\n PID_MISC_PICS = 6;}\r\n end;\r\n\r\n TJclWebViewSummaryInformation = class(TJclFilePropertySet)\r\n public\r\n class function GetFMTID: TGUID; override;\r\n\r\n {PID_DISPLAY_PROPERTIES = 0;\r\n PID_INTROTEXT = 1;}\r\n end;\r\n\r\n TJclMusicSummaryInformation = class(TJclFilePropertySet)\r\n public\r\n class function GetFMTID: TGUID; override;\r\n {PIDSI_ARTIST = 2;\r\n PIDSI_SONGTITLE = 3;\r\n PIDSI_ALBUM = 4;\r\n PIDSI_YEAR = 5;\r\n PIDSI_COMMENT = 6;\r\n PIDSI_TRACK = 7;\r\n PIDSI_GENRE = 11;\r\n PIDSI_LYRICS = 12;}\r\n end;\r\n\r\n TJclDRMSummaryInformation = class(TJclFilePropertySet)\r\n public\r\n class function GetFMTID: TGUID; override;\r\n {PIDDRSI_PROTECTED = 2;\r\n PIDDRSI_DESCRIPTION = 3;\r\n PIDDRSI_PLAYCOUNT = 4;\r\n PIDDRSI_PLAYSTARTS = 5;\r\n PIDDRSI_PLAYEXPIRES = 6;}\r\n end;\r\n\r\n TJclVideoSummaryInformation = class(TJclFilePropertySet)\r\n public\r\n class function GetFMTID: TGUID; override;\r\n\r\n property StreamName: WideString index PIDVSI_STREAM_NAME read GetWideStringProperty\r\n write SetWideStringProperty; // \"StreamName\", VT_LPWSTR\r\n property Width: Cardinal index PIDVSI_FRAME_WIDTH read GetCardinalProperty\r\n write SetCardinalProperty; // \"FrameWidth\", VT_UI4\r\n property Height: Cardinal index PIDVSI_FRAME_HEIGHT read GetCardinalProperty\r\n write SetCardinalProperty; // \"FrameHeight\", VT_UI4\r\n property TimeLength: Cardinal index PIDVSI_TIMELENGTH read GetCardinalProperty\r\n write SetCardinalProperty; // \"TimeLength\", VT_UI4, milliseconds\r\n property FrameCount: Cardinal index PIDVSI_FRAME_COUNT read GetCardinalProperty\r\n write SetCardinalProperty; // \"FrameCount\". VT_UI4\r\n property FrameRate: Cardinal index PIDVSI_FRAME_RATE read GetCardinalProperty\r\n write SetCardinalProperty; // \"FrameRate\", VT_UI4, frames/millisecond\r\n property DataRate: Cardinal index PIDVSI_DATA_RATE read GetCardinalProperty\r\n write SetCardinalProperty; // \"DataRate\", VT_UI4, bytes/second\r\n property SampleSize: Cardinal index PIDVSI_SAMPLE_SIZE read GetCardinalProperty\r\n write SetCardinalProperty; // \"SampleSize\", VT_UI4\r\n property Compression: WideString index PIDVSI_COMPRESSION read GetWideStringProperty\r\n write SetWideStringProperty; // \"Compression\", VT_LPWSTR\r\n property StreamNumber: Word index PIDVSI_STREAM_NUMBER read GetWordProperty\r\n write SetWordProperty; // \"StreamNumber\", VT_UI2}\r\n end;\r\n\r\n TJclAudioSummaryInformation = class(TJclFilePropertySet)\r\n public\r\n class function GetFMTID: TGUID; override;\r\n\r\n property Format: WideString index PIDASI_FORMAT read GetBSTRProperty\r\n write SetBSTRProperty; // VT_BSTR\r\n property TimeLength: Cardinal index PIDASI_TIMELENGTH read GetCardinalProperty\r\n write SetCardinalProperty; // VT_UI4, milliseconds\r\n property AverageDataRate: Cardinal index PIDASI_AVG_DATA_RATE read GetCardinalProperty\r\n write SetCardinalProperty; // VT_UI4, Hz\r\n property SampleRate: Cardinal index PIDASI_SAMPLE_RATE read GetCardinalProperty\r\n write SetCardinalProperty; // VT_UI4, bits\r\n property SampleSize: Cardinal index PIDASI_SAMPLE_SIZE read GetCardinalProperty\r\n write SetCardinalProperty; // VT_UI4, bits\r\n property ChannelCount: Cardinal index PIDASI_CHANNEL_COUNT read GetCardinalProperty\r\n write SetCardinalProperty; // VT_UI4\r\n property StreamNumber: Word index PIDASI_STREAM_NUMBER read GetWordProperty\r\n write SetWordProperty; // VT_UI2\r\n property StreamName: WideString index PIDASI_STREAM_NAME read GetWideStringProperty\r\n write SetWideStringProperty; // VT_LPWSTR\r\n property Compression: WideString index PIDASI_COMPRESSION read GetWideStringProperty\r\n write SetWideStringProperty; // VT_LPWSTR}\r\n end;\r\n\r\n TJclControlPanelSummaryInformation = class(TJclFilePropertySet)\r\n public\r\n class function GetFMTID: TGUID; override;\r\n {PID_CONTROLPANEL_CATEGORY = 2;}\r\n end;\r\n\r\n TJclVolumeSummaryInformation = class(TJclFilePropertySet)\r\n public\r\n class function GetFMTID: TGUID; override;\r\n {PID_VOLUME_FREE = 2;\r\n PID_VOLUME_CAPACITY = 3;\r\n PID_VOLUME_FILESYSTEM = 4;}\r\n end;\r\n\r\n TJclShareSummaryInformation = class(TJclFilePropertySet)\r\n public\r\n class function GetFMTID: TGUID; override;\r\n {PID_SHARE_CSC_STATUS = 2;}\r\n end;\r\n\r\n TJclLinkSummaryInformation = class(TJclFilePropertySet)\r\n public\r\n class function GetFMTID: TGUID; override;\r\n {PID_LINK_TARGET = 2;}\r\n end;\r\n\r\n TJclQuerySummaryInformation = class(TJclFilePropertySet)\r\n public\r\n class function GetFMTID: TGUID; override;\r\n {PID_QUERY_RANK = 2;}\r\n end;\r\n\r\n TJclImageInformation = class(TJclFilePropertySet)\r\n public\r\n class function GetFMTID: TGUID; override;\r\n {FMTID_ImageInformation}\r\n end;\r\n\r\n TJclJpegSummaryInformation = class(TJclFilePropertySet)\r\n public\r\n class function GetFMTID: TGUID; override;\r\n {FMTID_JpegAppHeaders}\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jcl.svn.sourceforge.net/svnroot/jcl/tags/JCL-2.4-Build4571/jcl/source/windows/JclNTFS.pas $';\r\n Revision: '$Revision: 3599 $';\r\n Date: '$Date: 2011-09-03 00:07:50 +0200 (sam. 03 sept. 2011) $';\r\n LogPath: 'JCL\\source\\windows';\r\n Extra: '';\r\n Data: nil\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n {$IFDEF HAS_UNITSCOPE}\r\n System.Win.ComObj,\r\n {$ELSE ~HAS_UNITSCOPE}\r\n ComObj,\r\n {$ENDIF ~HAS_UNITSCOPE}\r\n Hardlinks,\r\n JclSysUtils, JclFileUtils, JclSysInfo, JclResources;\r\n\r\n//=== NTFS - Compression =====================================================\r\n\r\n// Helper consts, helper types, helper routines\r\n\r\nconst\r\n CompressionFormat: array [TFileCompressionState] of Short =\r\n (\r\n COMPRESSION_FORMAT_NONE,\r\n COMPRESSION_FORMAT_DEFAULT,\r\n COMPRESSION_FORMAT_LZNT1\r\n );\r\n\r\n // use IsDirectory(FileName) as array index\r\n FileFlag: array [Boolean] of DWORD = (0, FILE_FLAG_BACKUP_SEMANTICS);\r\n\r\ntype\r\n TStackFrame = packed record\r\n CallersEBP: TJclAddr;\r\n CallerAddress: TJclAddr;\r\n end;\r\n\r\n EJclInvalidArgument = class(EJclError);\r\n\r\n{$STACKFRAMES OFF}\r\n\r\nfunction CallersCallerAddress: Pointer;\r\nasm\r\n {$IFDEF CPU32}\r\n MOV EAX, [EBP]\r\n MOV EAX, TStackFrame([EAX]).CallerAddress\r\n {$ENDIF CPU32}\r\n {$IFDEF CPU64}\r\n MOV RAX, [RBP]\r\n MOV RAX, TStackFrame([RAX]).CallerAddress\r\n {$ENDIF CPU64}\r\nend;\r\n\r\n{$STACKFRAMES ON}\r\n\r\nprocedure ValidateArgument(Condition: Boolean; const Routine: string;\r\n const Argument: string);\r\nbegin\r\n if not Condition then\r\n raise EJclInvalidArgument.CreateResFmt(@RsInvalidArgument, [Routine, Argument])\r\n at CallersCallerAddress;\r\nend;\r\n\r\n{$IFNDEF STACKFRAMES_ON}\r\n{$STACKFRAMES OFF}\r\n{$ENDIF ~STACKFRAMES_ON}\r\n\r\nfunction SetCompression(const FileName: string; const State: Short; FileFlag: DWORD): Boolean;\r\nvar\r\n Handle: THandle;\r\n BytesReturned: DWORD;\r\n Buffer: Short;\r\nbegin\r\n Result := False;\r\n Handle := CreateFile(PChar(FileName), GENERIC_READ or GENERIC_WRITE,\r\n FILE_SHARE_READ, nil, OPEN_EXISTING, FileFlag, 0);\r\n if Handle <> INVALID_HANDLE_VALUE then\r\n try\r\n Buffer := State;\r\n BytesReturned := 0;\r\n Result := DeviceIoControl(Handle, FSCTL_SET_COMPRESSION, @Buffer,\r\n SizeOf(Short), nil, 0, BytesReturned, nil);\r\n finally\r\n CloseHandle(Handle);\r\n end\r\nend;\r\n\r\nfunction SetPathCompression(Dir: string; const Mask: string; const State: Short;\r\n const SetDefault, Recursive: Boolean): Boolean;\r\nvar\r\n FileName: string;\r\n SearchRec: TSearchRec;\r\n R: Integer;\r\nbegin\r\n if SetDefault then\r\n Result := SetCompression(Dir, State, FILE_FLAG_BACKUP_SEMANTICS)\r\n else\r\n Result := True;\r\n if Result then\r\n begin\r\n Dir := PathAddSeparator(Dir);\r\n if FindFirst(Dir + Mask, faAnyFile, SearchRec) = 0 then\r\n try\r\n repeat\r\n if (SearchRec.Name <> '.') and (SearchRec.Name <> '..') then\r\n begin\r\n FileName := Dir + SearchRec.Name;\r\n if (SearchRec.Attr and faDirectory) = 0 then\r\n Result := SetCompression(FileName, State, 0)\r\n else\r\n if Recursive then\r\n Result := SetPathCompression(FileName, Mask, State, SetDefault, True);\r\n if not Result then\r\n Exit;\r\n end;\r\n R := FindNext(SearchRec);\r\n until R <> 0;\r\n Result := (R = ERROR_NO_MORE_FILES);\r\n finally\r\n {$IFDEF HAS_UNITSCOPE}System.{$ENDIF}SysUtils.FindClose(SearchRec);\r\n end;\r\n end;\r\nend;\r\n\r\nfunction NtfsGetCompression(const FileName: TFileName; out State: Short): Boolean;\r\nvar\r\n Handle: THandle;\r\n BytesReturned: DWORD;\r\nbegin\r\n State := 0;\r\n Result := False;\r\n Handle := CreateFile(PChar(FileName), 0, 0, nil, OPEN_EXISTING,\r\n FileFlag[IsDirectory(FileName)], 0);\r\n if Handle <> INVALID_HANDLE_VALUE then\r\n try\r\n BytesReturned := 0;\r\n Result := DeviceIoControl(Handle, FSCTL_GET_COMPRESSION, nil, 0, @State,\r\n SizeOf(Short), BytesReturned, nil);\r\n finally\r\n CloseHandle(Handle);\r\n end;\r\nend;\r\n\r\nfunction NtfsGetCompression(const FileName: TFileName): TFileCompressionState;\r\nvar\r\n State: Short;\r\nbegin\r\n if not NtfsGetCompression(FileName, State) then\r\n RaiseLastOSError;\r\n case State of\r\n COMPRESSION_FORMAT_NONE:\r\n Result := fcNoCompression;\r\n COMPRESSION_FORMAT_LZNT1:\r\n Result := fcLZNT1Compression;\r\n else\r\n // (rom) very dubious.\r\n Assert(False, 'TFileCompressionState requires expansion');\r\n Result := TFileCompressionState(State);\r\n end;\r\nend;\r\n\r\nfunction NtfsSetCompression(const FileName: TFileName; const State: Short): Boolean;\r\nbegin\r\n Result := SetCompression(FileName, State, FileFlag[IsDirectory(FileName)]);\r\nend;\r\n\r\n{$STACKFRAMES ON}\r\n\r\nprocedure NtfsSetFileCompression(const FileName: TFileName; const State: TFileCompressionState);\r\nbegin\r\n ValidateArgument(not IsDirectory(FileName), 'NtfsSetFileCompression', 'FileName');\r\n if not SetCompression(FileName, CompressionFormat[State], 0) then\r\n RaiseLastOSError;\r\nend;\r\n\r\nprocedure NtfsSetDefaultFileCompression(const Directory: string; const State: TFileCompressionState);\r\nbegin\r\n ValidateArgument(IsDirectory(Directory), 'NtfsSetDefaultFileCompression', 'Directory');\r\n if not SetCompression(Directory, CompressionFormat[State], FILE_FLAG_BACKUP_SEMANTICS) then\r\n RaiseLastOSError;\r\nend;\r\n\r\nprocedure NtfsSetDirectoryTreeCompression(const Directory: string; const State: TFileCompressionState);\r\nbegin\r\n ValidateArgument(IsDirectory(Directory), 'NtfsSetDirectoryTreeCompression', 'Directory');\r\n if not SetPathCompression(Directory, '*', CompressionFormat[State], True, True) then\r\n RaiseLastOSError;\r\nend;\r\n\r\n{$IFNDEF STACKFRAMES_ON}\r\n{$STACKFRAMES OFF}\r\n{$ENDIF ~STACKFRAMES_ON}\r\n\r\nprocedure NtfsSetPathCompression(const Path: string;\r\n const State: TFileCompressionState; Recursive: Boolean);\r\nvar\r\n Dir, Mask: string;\r\n SetDefault: Boolean;\r\nbegin\r\n SetDefault := IsDirectory(Path);\r\n if SetDefault then\r\n begin\r\n Dir := Path;\r\n Mask := '*';\r\n end\r\n else\r\n begin\r\n Dir := ExtractFilePath(Path);\r\n Mask := ExtractFileName(Path);\r\n if Mask = '' then\r\n Mask := '*';\r\n end;\r\n if not SetPathCompression(Dir, Mask, CompressionFormat[State], SetDefault, Recursive) then\r\n RaiseLastOSError;\r\nend;\r\n\r\n//=== NTFS - Sparse Files ====================================================\r\n\r\nfunction NtfsSetSparse(const FileName: string): Boolean;\r\nvar\r\n Handle: THandle;\r\n BytesReturned: DWORD;\r\nbegin\r\n Result := False;\r\n Handle := CreateFile(PChar(FileName), GENERIC_WRITE, 0, nil, OPEN_EXISTING, 0, 0);\r\n if Handle <> INVALID_HANDLE_VALUE then\r\n try\r\n BytesReturned := 0;\r\n Result := DeviceIoControl(Handle, FSCTL_SET_SPARSE, nil, 0, nil, 0, BytesReturned, nil);\r\n finally\r\n CloseHandle(Handle);\r\n end;\r\nend;\r\n\r\nfunction NtfsZeroDataByHandle(const Handle: THandle; const First, Last: Int64): Boolean;\r\nvar\r\n BytesReturned: DWORD;\r\n ZeroDataInfo: TFileZeroDataInformation;\r\n Info: TByHandleFileInformation;\r\nbegin\r\n Result := False;\r\n if Handle <> INVALID_HANDLE_VALUE then\r\n begin\r\n // Continue only if the file is a sparse file, this avoids the overhead\r\n // associated with an IOCTL when the file isn't even a sparse file.\r\n ResetMemory(Info, SizeOf(Info));\r\n GetFileInformationByHandle(Handle, Info);\r\n Result := (Info.dwFileAttributes and FILE_ATTRIBUTE_SPARSE_FILE) <> 0;\r\n if Result then\r\n begin\r\n ZeroDataInfo.FileOffset.QuadPart := First;\r\n ZeroDataInfo.BeyondFinalZero.QuadPart := Last;\r\n BytesReturned := 0;\r\n Result := DeviceIoControl(Handle, FSCTL_SET_ZERO_DATA, @ZeroDataInfo,\r\n SizeOf(ZeroDataInfo), nil, 0, BytesReturned, nil);\r\n end;\r\n end;\r\nend;\r\n\r\nfunction NtfsZeroDataByName(const FileName: string; const First, Last: Int64): Boolean;\r\nvar\r\n Handle: THandle;\r\nbegin\r\n Result := False;\r\n Handle := CreateFile(PChar(FileName), GENERIC_WRITE, 0, nil, OPEN_EXISTING, 0, 0);\r\n if Handle <> INVALID_HANDLE_VALUE then\r\n try\r\n Result := NtfsZeroDataByHandle(Handle, First, Last);\r\n finally\r\n CloseHandle(Handle);\r\n end;\r\nend;\r\n\r\nfunction NtfsGetAllocRangeEntry(const Ranges: TNtfsAllocRanges;\r\n Index: TJclAddr): TFileAllocatedRangeBuffer;\r\nvar\r\n Offset: TJclAddr;\r\nbegin\r\n Assert(Index < Ranges.Entries);\r\n Offset := TJclAddr(Ranges.Data) + Index * SizeOf(TFileAllocatedRangeBuffer);\r\n Result := PFileAllocatedRangeBuffer(Offset)^;\r\nend;\r\n\r\nfunction __QueryAllocRanges(const Handle: THandle; const Offset, Count: Int64;\r\n var Ranges: PFileAllocatedRangeBuffer; var MoreData: Boolean; var Size: Cardinal): Boolean;\r\nvar\r\n BytesReturned: DWORD;\r\n SearchRange: TFileAllocatedRangeBuffer;\r\n BufferSize: Cardinal;\r\nbegin\r\n SearchRange.FileOffset.QuadPart := Offset;\r\n SearchRange.Length.QuadPart := Count;\r\n BufferSize := 4 * 64 * SizeOf(TFileAllocatedRangeBuffer);\r\n Ranges := AllocMem(BufferSize);\r\n BytesReturned := 0;\r\n Result := DeviceIoControl(Handle, FSCTL_QUERY_ALLOCATED_RANGES, @SearchRange,\r\n SizeOf(SearchRange), Ranges, BufferSize, BytesReturned, nil);\r\n MoreData := GetLastError = ERROR_MORE_DATA;\r\n if MoreData then\r\n Result := True;\r\n Size := BytesReturned;\r\n if BytesReturned = 0 then\r\n begin\r\n FreeMem(Ranges);\r\n Ranges := nil;\r\n end;\r\nend;\r\n\r\nfunction NtfsQueryAllocRanges(const FileName: string; Offset, Count: Int64;\r\n var Ranges: TNtfsAllocRanges): Boolean;\r\nvar\r\n Handle: THandle;\r\n CurrRanges: PFileAllocatedRangeBuffer;\r\n R, MoreData: Boolean;\r\n Size: Cardinal;\r\nbegin\r\n Result := False;\r\n Handle := CreateFile(PChar(FileName), GENERIC_READ, FILE_SHARE_READ, nil, OPEN_EXISTING, 0, 0);\r\n if Handle <> INVALID_HANDLE_VALUE then\r\n try\r\n Size := 0;\r\n MoreData := False;\r\n CurrRanges := nil;\r\n R := __QueryAllocRanges(Handle, Offset, Count, CurrRanges, MoreData, Size);\r\n Ranges.MoreData := MoreData;\r\n Result := R;\r\n if R then\r\n begin\r\n Ranges.Entries := Size div SizeOf(TFileAllocatedRangeBuffer);\r\n Ranges.Data := CurrRanges;\r\n end\r\n else\r\n begin\r\n Ranges.Entries := 0;\r\n Ranges.Data := nil;\r\n end;\r\n finally\r\n CloseHandle(Handle);\r\n end;\r\nend;\r\n\r\nfunction NtfsSparseStreamsSupported(const Volume: string): Boolean;\r\nbegin\r\n Result := fsSupportsSparseFiles in GetVolumeFileSystemFlags(Volume);\r\nend;\r\n\r\nfunction NtfsGetSparse(const FileName: string): Boolean;\r\nvar\r\n Handle: THandle;\r\n Info: TByHandleFileInformation;\r\nbegin\r\n Result := False;\r\n Handle := CreateFile(PChar(FileName), 0, FILE_SHARE_READ or FILE_SHARE_WRITE,\r\n nil, OPEN_EXISTING, 0, 0);\r\n if Handle <> INVALID_HANDLE_VALUE then\r\n try\r\n ResetMemory(Info, SizeOf(Info));\r\n GetFileInformationByHandle(Handle, Info);\r\n Result := (Info.dwFileAttributes and FILE_ATTRIBUTE_SPARSE_FILE) <> 0;\r\n finally\r\n CloseHandle(Handle);\r\n end;\r\nend;\r\n\r\n//=== NTFS - Reparse Points ==================================================\r\n\r\nfunction NtfsGetReparseTag(const Path: string; var Tag: DWORD): Boolean;\r\nvar\r\n SearchRec: TSearchRec;\r\nbegin\r\n Result := NtfsFileHasReparsePoint(Path);\r\n if Result then\r\n begin\r\n Result := FindFirst(Path, faAnyFile, SearchRec) = 0;\r\n if Result then\r\n begin\r\n // Check if file has a reparse point\r\n Result := ((SearchRec.Attr and FILE_ATTRIBUTE_REPARSE_POINT) <> 0);\r\n // If so the dwReserved0 field contains the reparse tag\r\n if Result then\r\n Tag := SearchRec.FindData.dwReserved0;\r\n FindClose(SearchRec);\r\n end;\r\n end;\r\nend;\r\n\r\nfunction NtfsReparsePointsSupported(const Volume: string): Boolean;\r\nbegin\r\n Result := fsSupportsReparsePoints in GetVolumeFileSystemFlags(Volume);\r\nend;\r\n\r\nfunction NtfsFileHasReparsePoint(const Path: string): Boolean;\r\nvar\r\n Attr: DWORD;\r\nbegin\r\n Result := False;\r\n Attr := GetFileAttributes(PChar(Path));\r\n if Attr <> DWORD(-1) then\r\n Result := (Attr and FILE_ATTRIBUTE_REPARSE_POINT) <> 0;\r\nend;\r\n\r\nfunction NtfsDeleteReparsePoint(const FileName: string; ReparseTag: DWORD): Boolean;\r\nvar\r\n Handle: THandle;\r\n BytesReturned: DWORD;\r\n ReparseData: TReparseGuidDataBuffer;\r\nbegin\r\n Result := False;\r\n Handle := CreateFile(PChar(FileName), GENERIC_READ or GENERIC_WRITE, 0, nil,\r\n OPEN_EXISTING, FILE_FLAG_BACKUP_SEMANTICS or FILE_FLAG_OPEN_REPARSE_POINT, 0);\r\n if Handle <> INVALID_HANDLE_VALUE then\r\n try\r\n ResetMemory(ReparseData, SizeOf(ReparseData));\r\n ReparseData.ReparseTag := ReparseTag;\r\n BytesReturned := 0;\r\n Result := DeviceIoControl(Handle, FSCTL_DELETE_REPARSE_POINT, @ReparseData,\r\n REPARSE_GUID_DATA_BUFFER_HEADER_SIZE, nil, 0, BytesReturned, nil);\r\n finally\r\n CloseHandle(Handle);\r\n end;\r\nend;\r\n\r\nfunction NtfsSetReparsePoint(const FileName: string; var ReparseData; Size: Longword): Boolean;\r\nvar\r\n Handle: THandle;\r\n BytesReturned: DWORD;\r\nbegin\r\n Result := False;\r\n Handle := CreateFile(PChar(FileName), GENERIC_READ or GENERIC_WRITE, 0, nil,\r\n OPEN_EXISTING, FILE_FLAG_BACKUP_SEMANTICS or FILE_FLAG_OPEN_REPARSE_POINT, 0);\r\n if Handle <> INVALID_HANDLE_VALUE then\r\n try\r\n BytesReturned := 0;\r\n Result := DeviceIoControl(Handle, FSCTL_SET_REPARSE_POINT, @ReparseData,\r\n Size, nil, 0, BytesReturned, nil);\r\n finally\r\n CloseHandle(Handle);\r\n end;\r\nend;\r\n\r\nfunction NtfsGetReparsePoint(const FileName: string; var ReparseData: TReparseGuidDataBuffer): Boolean;\r\nvar\r\n Handle: THandle;\r\n BytesReturned: DWORD;\r\n LastError: DWORD;\r\nbegin\r\n Result := False;\r\n Handle := CreateFile(PChar(FileName), GENERIC_READ, FILE_SHARE_READ, nil,\r\n OPEN_EXISTING, FILE_FLAG_BACKUP_SEMANTICS or FILE_FLAG_OPEN_REPARSE_POINT, 0);\r\n LastError := GetLastError;\r\n if Handle <> INVALID_HANDLE_VALUE then\r\n try\r\n BytesReturned := 0;\r\n Result := DeviceIoControl(Handle, FSCTL_GET_REPARSE_POINT, nil, 0, @ReparseData,\r\n ReparseData.ReparseDataLength + SizeOf(ReparseData), BytesReturned, nil);\r\n if not Result then\r\n begin\r\n ReparseData.ReparseDataLength := BytesReturned;\r\n LastError := GetLastError;\r\n end;\r\n finally\r\n CloseHandle(Handle);\r\n SetLastError(LastError);\r\n end;\r\nend;\r\n\r\n//=== NTFS - Volume Mount Points =============================================\r\n\r\nfunction NtfsIsFolderMountPoint(const Path: string): Boolean;\r\nvar\r\n Tag: DWORD;\r\nbegin\r\n Tag := 0;\r\n Result := NtfsGetReparseTag(Path, Tag);\r\n if Result then\r\n Result := (Tag = IO_REPARSE_TAG_MOUNT_POINT);\r\nend;\r\n\r\nfunction NtfsMountDeviceAsDrive(const Device: WideString; Drive: Char): Boolean;\r\nconst\r\n DDD_FLAGS = DDD_RAW_TARGET_PATH or DDD_REMOVE_DEFINITION or DDD_EXACT_MATCH_ON_REMOVE;\r\nvar\r\n DriveStr: WideString;\r\n VolumeName: WideString;\r\nbegin\r\n // To create a mount point we must obtain a unique volume name first. To obtain\r\n // a unique volume name the drive must exist. Therefore we must temporarily\r\n // create a symbolic link for the drive using DefineDosDevice.\r\n DriveStr := Drive + ':';\r\n Result := DefineDosDeviceW(DDD_RAW_TARGET_PATH, PWideChar(DriveStr), PWideChar(Device));\r\n if Result then\r\n begin\r\n SetLength(VolumeName, 1024);\r\n Result := RtdlGetVolumeNameForVolumeMountPointW(PWideChar(DriveStr + '\\'), PWideChar(VolumeName), 1024);\r\n // Attempt to delete the symbolic link, if it fails then don't attempt to\r\n // set the mountpoint either but raise an exception instead, there's something\r\n // seriously wrong so let's try to control the damage done already :)\r\n if not DefineDosDeviceW(DDD_FLAGS, PWideChar(DriveStr), PWideChar(Device)) then\r\n raise EJclNtfsError.CreateRes(@RsNtfsUnableToDeleteSymbolicLink);\r\n if Result then\r\n Result := RtdlSetVolumeMountPointW(PWideChar(DriveStr + '\\'), PWideChar(VolumeName));\r\n end;\r\nend;\r\n\r\nfunction NtfsMountVolume(const Volume: WideChar; const MountPoint: WideString): Boolean;\r\nvar\r\n VolumeName: WideString;\r\n VolumeStr: WideString;\r\nbegin\r\n SetLength(VolumeName, 1024);\r\n VolumeStr := Volume + ':\\';\r\n Result := RtdlGetVolumeNameForVolumeMountPointW(PWideChar(VolumeStr), PWideChar(VolumeName), 1024);\r\n if Result then\r\n begin\r\n if not JclFileUtils.DirectoryExists(MountPoint) then\r\n JclFileUtils.ForceDirectories(MountPoint);\r\n Result := RtdlSetVolumeMountPointW(PWideChar(MountPoint), PWideChar(VolumeName));\r\n end;\r\nend;\r\n\r\n//=== NTFS - Change Journal ==================================================\r\n\r\n//=== NTFS - Opportunistic Locks =============================================\r\n\r\nfunction NtfsOpLockAckClosePending(Handle: THandle; Overlapped: TOverlapped): Boolean;\r\nvar\r\n BytesReturned: Cardinal;\r\nbegin\r\n BytesReturned := 0;\r\n Result := DeviceIoControl(Handle, FSCTL_OPBATCH_ACK_CLOSE_PENDING, nil, 0, nil,\r\n 0, BytesReturned, @Overlapped);\r\nend;\r\n\r\nfunction NtfsOpLockBreakAckNo2(Handle: THandle; Overlapped: TOverlapped): Boolean;\r\nvar\r\n BytesReturned: Cardinal;\r\nbegin\r\n BytesReturned := 0;\r\n Result := DeviceIoControl(Handle, FSCTL_OPLOCK_BREAK_ACK_NO_2, nil, 0, nil, 0,\r\n BytesReturned, @Overlapped);\r\nend;\r\n\r\nfunction NtfsOpLockBreakAcknowledge(Handle: THandle; Overlapped: TOverlapped): Boolean;\r\nvar\r\n BytesReturned: Cardinal;\r\nbegin\r\n BytesReturned := 0;\r\n Result := DeviceIoControl(Handle, FSCTL_OPLOCK_BREAK_ACKNOWLEDGE, nil, 0, nil,\r\n 0, BytesReturned, @Overlapped);\r\n Result := Result or (GetLastError = ERROR_IO_PENDING);\r\nend;\r\n\r\nfunction NtfsOpLockBreakNotify(Handle: THandle; Overlapped: TOverlapped): Boolean;\r\nvar\r\n BytesReturned: Cardinal;\r\nbegin\r\n BytesReturned := 0;\r\n Result := DeviceIoControl(Handle, FSCTL_OPLOCK_BREAK_NOTIFY, nil, 0, nil, 0,\r\n BytesReturned, @Overlapped);\r\nend;\r\n\r\nfunction NtfsRequestOpLock(Handle: THandle; Kind: TOpLock; Overlapped: TOverlapped): Boolean;\r\nconst\r\n IoCodes: array [TOpLock] of Cardinal = (\r\n FSCTL_REQUEST_OPLOCK_LEVEL_1, FSCTL_REQUEST_OPLOCK_LEVEL_2,\r\n FSCTL_REQUEST_BATCH_OPLOCK, FSCTL_REQUEST_FILTER_OPLOCK);\r\nvar\r\n BytesReturned: Cardinal;\r\nbegin\r\n BytesReturned := 0;\r\n Result := DeviceIoControl(Handle, IoCodes[Kind], nil, 0, nil, 0, BytesReturned, @Overlapped);\r\n Result := Result or (GetLastError = ERROR_IO_PENDING);\r\nend;\r\n\r\n//=== Junction Points ========================================================\r\n\r\ntype\r\n TReparseDataBufferOverlay = record\r\n case Boolean of\r\n False:\r\n (Reparse: TReparseDataBuffer;);\r\n True:\r\n (Buffer: array [0..MAXIMUM_REPARSE_DATA_BUFFER_SIZE] of Char;);\r\n end;\r\n \r\nfunction IsReparseTagValid(Tag: DWORD): Boolean;\r\nbegin\r\n Result := (Tag and (not IO_REPARSE_TAG_VALID_VALUES) = 0) and\r\n (Tag > IO_REPARSE_TAG_RESERVED_RANGE);\r\nend;\r\n\r\nfunction NtfsCreateJunctionPoint(const Source, Destination: string): Boolean;\r\nvar\r\n Dest: array [0..1024] of Char; // Writable copy of Destination\r\n DestW: WideString; // Unicode version of Dest\r\n FullDir: array [0..1024] of Char;\r\n FilePart: PChar;\r\n ReparseData: TReparseDataBufferOverlay;\r\n NameLength: Longword;\r\nbegin\r\n Result := False;\r\n // For some reason the destination string must be prefixed with \\??\\ otherwise\r\n // the IOCTL will fail, ensure it's there.\r\n if Copy(Destination, 1, 3) = '\\??' then\r\n StrPCopy(Dest, Destination)\r\n else\r\n begin\r\n // Make sure Destination is a directory or again, the IOCTL will fail.\r\n FilePart := nil;\r\n if (GetFullPathName(PChar(Destination), 1024, FullDir, FilePart) = 0) or\r\n (GetFileAttributes(FullDir) = DWORD(-1)) then\r\n begin\r\n SetLastError(ERROR_PATH_NOT_FOUND);\r\n Exit;\r\n end;\r\n StrPCopy(Dest, '\\??\\' + Destination);\r\n end;\r\n ResetMemory(ReparseData, SizeOf(ReparseData));\r\n NameLength := StrLen(Dest) * SizeOf(WideChar);\r\n ReparseData.Reparse.ReparseTag := IO_REPARSE_TAG_MOUNT_POINT;\r\n ReparseData.Reparse.ReparseDataLength := NameLength + 12;\r\n ReparseData.Reparse.SubstituteNameLength := NameLength;\r\n ReparseData.Reparse.PrintNameOffset := NameLength + 2;\r\n // Not the most elegant way to copy an AnsiString into an Unicode buffer but\r\n // let's avoid dependencies on JclUnicode.pas (adds significant resources).\r\n DestW := WideString(Dest);\r\n Move(DestW[1], ReparseData.Reparse.PathBuffer, Length(DestW) * SizeOf(WideChar));\r\n Result := NtfsSetReparsePoint(Source, ReparseData.Reparse,\r\n ReparseData.Reparse.ReparseDataLength + REPARSE_DATA_BUFFER_HEADER_SIZE);\r\nend;\r\n\r\nfunction NtfsDeleteJunctionPoint(const Source: string): Boolean;\r\nbegin\r\n Result := NtfsDeleteReparsePoint(Source, IO_REPARSE_TAG_MOUNT_POINT);\r\nend;\r\n\r\nfunction NtfsGetJunctionPointDestination(const Source: string; var Destination: string): Boolean;\r\nvar\r\n Handle: THandle;\r\n ReparseData: TReparseDataBufferOverlay;\r\n BytesReturned: DWORD;\r\n SubstituteName: WideString;\r\n SubstituteNameAddr: PWideChar;\r\nbegin\r\n Result := False;\r\n if NtfsFileHasReparsePoint(Source) then\r\n begin\r\n Handle := CreateFile(PChar(Source), GENERIC_READ, 0, nil,\r\n OPEN_EXISTING, FILE_FLAG_BACKUP_SEMANTICS or FILE_FLAG_OPEN_REPARSE_POINT, 0);\r\n if Handle <> INVALID_HANDLE_VALUE then\r\n try\r\n BytesReturned := 0;\r\n if DeviceIoControl(Handle, FSCTL_GET_REPARSE_POINT, nil, 0, @ReparseData,\r\n MAXIMUM_REPARSE_DATA_BUFFER_SIZE, BytesReturned, nil) {and\r\n IsReparseTagValid(ReparseData.Reparse.ReparseTag) then}\r\n then\r\n begin\r\n if BytesReturned >= DWORD(ReparseData.Reparse.SubstituteNameLength + SizeOf(WideChar)) then\r\n begin\r\n SetLength(Destination, ReparseData.Reparse.SubstituteNameLength div SizeOf(WideChar));\r\n SubstituteNameAddr := @ReparseData.Reparse.PathBuffer;\r\n Inc(SubstituteNameAddr, ReparseData.Reparse.SubstituteNameOffset div SizeOf(WideChar));\r\n SetString(SubstituteName, SubstituteNameAddr, Length(Destination));\r\n Destination := string(SubstituteName);\r\n\r\n Result := True;\r\n end;\r\n end;\r\n finally\r\n CloseHandle(Handle);\r\n end\r\n end;\r\nend;\r\n\r\n//=== Streams ================================================================\r\n\r\n// FindStream is an internal helper routine for NtfsFindFirstStream and\r\n// NtfsFindNextStream. It uses the backup API to enumerate the streams in an\r\n// NTFS file and returns when it either finds a stream that matches the filter\r\n// specified in the Data parameter or hits EOF. Details are returned through\r\n// the Data parameter and success/failure as the Boolean result value.\r\n\r\nfunction FindStream(var Data: TFindStreamData): Boolean;\r\nvar\r\n Header: TWin32StreamId;\r\n BytesToRead, BytesRead: DWORD;\r\n BytesToSeek: TJclULargeInteger;\r\n Hi, Lo: DWORD;\r\n FoundStream: Boolean;\r\n StreamName: PWideChar;\r\nbegin\r\n Result := False;\r\n FoundStream := False;\r\n ResetMemory(Header, SizeOf(Header));\r\n // We loop until we either found a stream or an error occurs.\r\n while not FoundStream do\r\n begin\r\n // Read stream header\r\n BytesToRead := DWORD(TJclAddr(@Header.cStreamName[0]) - TJclAddr(@Header.dwStreamId));\r\n BytesRead := 0;\r\n if not {$IFDEF HAS_UNITSCOPE}Winapi.{$ENDIF}Windows.BackupRead(Data.Internal.FileHandle, (@Header), BytesToRead, BytesRead,\r\n False, True, Data.Internal.Context) then\r\n begin\r\n SetLastError(ERROR_READ_FAULT);\r\n Exit;\r\n end;\r\n if BytesRead = 0 then // EOF\r\n begin\r\n SetLastError(ERROR_NO_MORE_FILES);\r\n Exit;\r\n end;\r\n // If stream has a name then read it\r\n if Header.dwStreamNameSize > 0 then\r\n begin\r\n StreamName := HeapAlloc(GetProcessHeap, 0, Header.dwStreamNameSize + SizeOf(WCHAR));\r\n if StreamName = nil then\r\n begin\r\n SetLastError(ERROR_OUTOFMEMORY);\r\n Exit;\r\n end;\r\n if not {$IFDEF HAS_UNITSCOPE}Winapi.{$ENDIF}Windows.BackupRead(Data.Internal.FileHandle, Pointer(StreamName),\r\n Header.dwStreamNameSize, BytesRead, False, True, Data.Internal.Context) then\r\n begin\r\n HeapFree(GetProcessHeap, 0, StreamName);\r\n SetLastError(ERROR_READ_FAULT);\r\n Exit;\r\n end;\r\n StreamName[Header.dwStreamNameSize div SizeOf(WCHAR)] := WideChar(#0);\r\n end\r\n else\r\n StreamName := nil;\r\n // Did we find any of the specified streams ([] means any stream)?\r\n if (Data.Internal.StreamIds = []) or\r\n (TStreamId(Header.dwStreamId) in Data.Internal.StreamIds) then\r\n begin\r\n FoundStream := True;\r\n {$IFDEF FPC}\r\n Data.Size := Header.Size.QuadPart;\r\n {$ELSE ~FPC}\r\n Data.Size := Header.Size;\r\n {$ENDIF ~FPC}\r\n Data.Name := StreamName;\r\n Data.Attributes := Header.dwStreamAttributes;\r\n Data.StreamId := TStreamId(Header.dwStreamId);\r\n end;\r\n // Release stream name memory if necessary\r\n if Header.dwStreamNameSize > 0 then\r\n HeapFree(GetProcessHeap, 0, StreamName);\r\n // Move past data part to beginning of next stream (or EOF)\r\n {$IFDEF FPC}\r\n BytesToSeek.QuadPart := Header.Size.QuadPart;\r\n if (Header.Size.QuadPart <> 0) and (not JclWin32.BackupSeek(Data.Internal.FileHandle, BytesToSeek.LowPart,\r\n BytesToSeek.HighPart, Lo, Hi, Data.Internal.Context)) then\r\n {$ELSE ~FPC}\r\n BytesToSeek.QuadPart := Header.Size;\r\n if (Header.Size <> 0) and (not JclWin32.BackupSeek(Data.Internal.FileHandle, BytesToSeek.LowPart,\r\n BytesToSeek.HighPart, Lo, Hi, Data.Internal.Context)) then\r\n {$ENDIF ~FPC}\r\n begin\r\n SetLastError(ERROR_READ_FAULT);\r\n Exit;\r\n end;\r\n end;\r\n // Due to the usage of Exit, we only get here if everything succeeded\r\n Result := True;\r\nend;\r\n\r\nfunction NtfsFindFirstStream(const FileName: string; StreamIds: TStreamIds;\r\n var Data: TFindStreamData): Boolean;\r\nbegin\r\n Result := False;\r\n // Open file for reading, note that the FILE_FLAG_BACKUP_SEMANTICS requires\r\n // the SE_BACKUP_NAME and SE_RESTORE_NAME privileges.\r\n Data.Internal.FileHandle := CreateFile(PChar(FileName), GENERIC_READ,\r\n FILE_SHARE_READ or FILE_SHARE_WRITE, nil, OPEN_EXISTING,\r\n FILE_FLAG_BACKUP_SEMANTICS, 0);\r\n if Data.Internal.FileHandle <> INVALID_HANDLE_VALUE then\r\n begin\r\n // Initialize private context\r\n Data.Internal.StreamIds := StreamIds;\r\n Data.Internal.Context := nil;\r\n // Call upon the Borg worker to find the next (first) stream\r\n Result := FindStream(Data);\r\n if not Result then\r\n begin\r\n // Failure, cleanup relieving the caller of having to call FindStreamClose\r\n CloseHandle(Data.Internal.FileHandle);\r\n Data.Internal.FileHandle := INVALID_HANDLE_VALUE;\r\n Data.Internal.Context := nil;\r\n if GetLastError = ERROR_NO_MORE_FILES then\r\n SetLastError(ERROR_FILE_NOT_FOUND);\r\n end;\r\n end;\r\nend;\r\n\r\nfunction NtfsFindNextStream(var Data: TFindStreamData): Boolean;\r\nbegin\r\n Result := False;\r\n if Data.Internal.FileHandle <> INVALID_HANDLE_VALUE then\r\n Result := FindStream(Data)\r\n else\r\n SetLastError(ERROR_INVALID_HANDLE);\r\nend;\r\n\r\nfunction NtfsFindStreamClose(var Data: TFindStreamData): Boolean;\r\nvar\r\n BytesRead: DWORD;\r\n LastError: DWORD;\r\nbegin\r\n Result := Data.Internal.FileHandle <> INVALID_HANDLE_VALUE;\r\n LastError := ERROR_SUCCESS;\r\n if Result then\r\n begin\r\n // Call BackupRead one last time to signal that we're done with it\r\n BytesRead := 0;\r\n Result := {$IFDEF HAS_UNITSCOPE}Winapi.{$ENDIF}Windows.BackupRead(0, nil, 0, BytesRead, True, False, Data.Internal.Context);\r\n if not Result then\r\n LastError := GetLastError;\r\n CloseHandle(Data.Internal.FileHandle);\r\n Data.Internal.FileHandle := INVALID_HANDLE_VALUE;\r\n Data.Internal.Context := nil;\r\n end\r\n else\r\n LastError := ERROR_INVALID_HANDLE;\r\n SetLastError(LastError);\r\nend;\r\n\r\n//=== Hard links =============================================================\r\n(*\r\n Implementation of CreateHardLink completely swapped to the unit Hardlink.pas\r\n\r\n As with all APIs on the NT platform this version is completely implemented in\r\n UNICODE and calling the ANSI version results in conversion of parameters and\r\n call of the underlying UNICODE version of the function.\r\n\r\n This holds both for the homegrown and the Windows API (where it exists).\r\n*)\r\n\r\n// For a description see: NtfsCreateHardLink()\r\n(* ANSI implementation of the function - calling UNICODE anyway ;-) *)\r\nfunction NtfsCreateHardLinkA(const LinkFileName, ExistingFileName: AnsiString): Boolean;\r\nbegin\r\n // Invoke either (homegrown vs. API) function and supply NIL for security attributes\r\n Result := CreateHardLinkA(PAnsiChar(LinkFileName), PAnsiChar(ExistingFileName), nil);\r\nend;\r\n\r\n// For a description see: NtfsCreateHardLink()\r\n(* UNICODE implementation of the function - we are on NT, aren't we ;-) *)\r\nfunction NtfsCreateHardLinkW(const LinkFileName, ExistingFileName: WideString): Boolean;\r\nbegin\r\n // Invoke either (homegrown vs. API) function and supply NIL for security attributes\r\n Result := CreateHardLinkW(PWideChar(LinkFileName), PWideChar(ExistingFileName), nil);\r\nend;\r\n\r\n// NtfsCreateHardLink\r\n//\r\n// Creates a hardlink on NT 4 and above.\r\n// Both, LinkFileName and ExistingFileName must reside on the same, NTFS formatted volume.\r\n//\r\n// LinkName: Name of the hard link to create\r\n// ExistingFileName: Fully qualified path of the file for which to create a hard link\r\n// Result: True if successfull,\r\n// False if failed.\r\n// In the latter case use GetLastError to obtain the reason of failure.\r\n//\r\n// Remark:\r\n// Hardlinks are the same as cross-referenced files were on DOS. With one exception\r\n// on NTFS they are allowed and are a feature of the filesystem, whereas on FAT\r\n// they were a feared kind of corruption of the filesystem.\r\n//\r\n// Hardlinks are no more than references (with different names, but not necessarily\r\n// in different directories) of the filesystem to exactly the same data!\r\n//\r\n// To test this you may create a hardlink to some file on your harddisk and then edit\r\n// it using Notepad (some editors do not work on the original file, but Notepad does).\r\n// The changes will appear in the \"linked\" and the \"original\" location.\r\n//\r\n// Why did I use quotes? Easy: hardlinks are references to the same data - and such\r\n// as with handles the object (i.e. data) is only destroyed after all references are\r\n// \"released\". To \"release\" a reference (i.e. a hardlink) simply delete it using\r\n// the well-known methods to delete files. Because:\r\n//\r\n// Files are hardlinks and hardlinks are files.\r\n//\r\n// The above holds for NTFS volumes (and those filesystems supporting hardlinks).\r\n// Why all references need to reside on the same volume should be clear from these\r\n// remarks.\r\nfunction NtfsCreateHardLink(const LinkFileName, ExistingFileName: String): Boolean;\r\nbegin\r\n {$IFDEF SUPPORTS_UNICODE}\r\n Result := CreateHardLinkW(PWideChar(LinkFileName), PWideChar(ExistingFileName), nil);\r\n {$ELSE ~SUPPORTS_UNICODE}\r\n Result := CreateHardLinkA(PAnsiChar(LinkFileName), PAnsiChar(ExistingFileName), nil);\r\n {$ENDIF ~SUPPORTS_UNICODE}\r\nend;\r\n\r\nfunction NtfsGetHardLinkInfo(const FileName: string; var Info: TNtfsHardLinkInfo): Boolean;\r\nvar\r\n F: THandle;\r\n FileInfo: TByHandleFileInformation;\r\nbegin\r\n Result := False;\r\n F := CreateFile(PChar(FileName), GENERIC_READ, FILE_SHARE_READ or FILE_SHARE_WRITE, nil, OPEN_EXISTING, 0, 0);\r\n if F <> INVALID_HANDLE_VALUE then\r\n try\r\n ResetMemory(FileInfo, SizeOf(FileInfo));\r\n if GetFileInformationByHandle(F, FileInfo) then\r\n begin\r\n Info.LinkCount := FileInfo.nNumberOfLinks;\r\n Info.FileIndexHigh := FileInfo.nFileIndexHigh;\r\n Info.FileIndexLow := FileInfo.nFileIndexLow;\r\n Result := True;\r\n end;\r\n finally\r\n CloseHandle(F);\r\n end\r\nend;\r\n\r\nfunction NtfsFindHardLinks(const Path: string; const FileIndexHigh, FileIndexLow: Cardinal; const List: TStrings): Boolean;\r\nvar\r\n SearchRec: TSearchRec;\r\n R: Integer;\r\n Info: TNtfsHardLinkInfo;\r\nbegin\r\n // start the search\r\n R := FindFirst(Path + '\\*.*', faAnyFile, SearchRec);\r\n Result := (R = 0);\r\n if Result then\r\n begin\r\n List.BeginUpdate;\r\n try\r\n while R = 0 do\r\n begin\r\n if (SearchRec.Name <> '.') and (SearchRec.Name <> '..') then\r\n begin\r\n if (SearchRec.Attr and faDirectory) = faDirectory then\r\n begin\r\n // recurse into subdirectory\r\n Result := NtfsFindHardLinks(Path + '\\' + SearchRec.Name, FileIndexHigh, FileIndexLow, List);\r\n if not Result then\r\n Break;\r\n end\r\n else\r\n begin\r\n // found a file, is it a hard link?\r\n ResetMemory(Info, SizeOf(Info));\r\n if NtfsGetHardLinkInfo(Path + '\\' + SearchRec.Name, Info) then\r\n begin\r\n if (Info.FileIndexHigh = FileIndexHigh) and (Info.FileIndexLow = FileIndexLow) then\r\n List.Add(Path + '\\' + SearchRec.Name);\r\n end;\r\n end;\r\n end;\r\n R := FindNext(SearchRec);\r\n end;\r\n Result := R = ERROR_NO_MORE_FILES;\r\n finally\r\n {$IFDEF HAS_UNITSCOPE}System.{$ENDIF}SysUtils.FindClose(SearchRec);\r\n List.EndUpdate;\r\n end;\r\n end;\r\n if R = ERROR_ACCESS_DENIED then\r\n Result := True;\r\nend;\r\n\r\nfunction NtfsDeleteHardLinks(const FileName: string): Boolean;\r\nvar\r\n FullPathName: string;\r\n FilePart: PChar;\r\n Files: TStringList;\r\n I: Integer;\r\n Info: TNtfsHardLinkInfo;\r\nbegin\r\n Result := False;\r\n // get the full pathname of the specified file\r\n SetLength(FullPathName, MAX_PATH);\r\n FilePart := nil;\r\n GetFullPathName(PChar(FileName), MAX_PATH, PChar(FullPathName), FilePart);\r\n SetLength(FullPathName, StrLen(PChar(FullPathName)));\r\n // get hard link information\r\n ResetMemory(Info, SizeOf(Info));\r\n if NtfsGetHardLinkInfo(FullPathName, Info) then\r\n begin\r\n Files := TStringList.Create;\r\n try\r\n if Info.LinkCount > 1 then\r\n begin\r\n // find all hard links for this file\r\n if not NtfsFindHardLinks(FullPathName[1] + ':', Info.FileIndexHigh, Info.FileIndexLow, Files) then\r\n Exit;\r\n // first delete the originally specified file from the list, we don't delete that one until all hard links\r\n // are succesfully deleted so we can use it to restore them if anything goes wrong. Theoretically one could\r\n // use any of the hard links but in case the restore goes wrong, at least the specified file still exists...\r\n for I := 0 to Files.Count - 1 do\r\n begin\r\n if CompareStr(FullPathName, Files[I]) = 0 then\r\n begin\r\n Files.Delete(I);\r\n Break;\r\n end;\r\n end;\r\n // delete all found hard links\r\n I := 0;\r\n while I < Files.Count do\r\n begin\r\n if not DeleteFile(Files[I]) then\r\n Break;\r\n Inc(I);\r\n end;\r\n if I = Files.Count then\r\n begin\r\n // all hard links succesfully deleted, now delete the originally specified file. if this fails we set\r\n // I to Files.Count - 1 so that the next code block will restore all hard links we just deleted.\r\n Result := DeleteFile(FullPathName);\r\n if not Result then\r\n I := Files.Count - 1;\r\n end;\r\n if I < Files.Count then\r\n begin\r\n // not all hard links could be deleted, attempt to restore the ones that were\r\n while I >= 0 do\r\n begin\r\n // ignore result, just attempt to restore...\r\n NtfsCreateHardLink(Files[I], FullPathName);\r\n Dec(I);\r\n end;\r\n end;\r\n end\r\n else\r\n // there are no hard links, just delete the file\r\n Result := DeleteFile(FullPathName);\r\n finally\r\n Files.Free;\r\n end;\r\n end;\r\nend;\r\n\r\n//=== { TJclFileSummary } ====================================================\r\n\r\nconst\r\n AccessModes: array [TJclFileSummaryAccess] of DWORD =\r\n ( STGM_READ, STGM_WRITE, STGM_READWRITE );\r\n ShareModes: array [TJclFileSummaryShare] of DWORD =\r\n ( STGM_SHARE_DENY_NONE, STGM_SHARE_DENY_READ, STGM_SHARE_DENY_WRITE,\r\n STGM_SHARE_EXCLUSIVE );\r\n \r\nconstructor TJclFileSummary.Create(AFileName: WideString; AAccessMode: TJclFileSummaryAccess;\r\n AShareMode: TJclFileSummaryShare; AsDocument: Boolean; ACreate: Boolean);\r\nvar\r\n Format: DWORD;\r\n IntfGUID: TGUID;\r\n AIntf: IInterface;\r\nbegin\r\n inherited Create;\r\n FAccessMode := AAccessMode;\r\n FShareMode := AShareMode;\r\n FFileName := AFileName;\r\n\r\n if AsDocument then\r\n Format := STGFMT_DOCFILE\r\n else\r\n if ACreate then\r\n Format := STGFMT_FILE\r\n else\r\n Format := STGFMT_ANY;\r\n IntfGUID := IPropertySetStorage;\r\n\r\n if ACreate then\r\n OleCheck(StgCreateStorageEx(PWideChar(AFileName),\r\n STGM_DIRECT or AccessModes[AAccessMode] or ShareModes[AShareMode], Format, 0,\r\n nil, nil, @IntfGUID, AIntf))\r\n else\r\n OleCheck(StgOpenStorageEx(PWideChar(AFileName),\r\n STGM_DIRECT or AccessModes[AAccessMode] or ShareModes[AShareMode], Format, 0,\r\n nil, nil, @IntfGUID, AIntf));\r\n\r\n FStorage := AIntf as IPropertySetStorage;\r\nend;\r\n\r\nfunction TJclFileSummary.CreatePropertySet(AClass: TJclFilePropertySetClass;\r\n ResetExisting: Boolean): TJclFilePropertySet;\r\nvar\r\n PropertyStorage: IPropertyStorage;\r\nbegin\r\n OleCheck(FStorage.Create(AClass.GetFMTID, AClass.GetFMTID, PROPSETFLAG_DEFAULT,\r\n STGM_CREATE or STGM_DIRECT or AccessModes[AccessMode] or ShareModes[ShareMode],\r\n PropertyStorage));\r\n if Assigned(PropertyStorage) then\r\n Result := AClass.Create(PropertyStorage)\r\n else\r\n raise EJclFileSummaryError.CreateRes(@RsEUnableToCreatePropertyStorage);\r\nend;\r\n\r\nprocedure TJclFileSummary.DeletePropertySet(AClass: TJclFilePropertySetClass);\r\nbegin\r\n DeletePropertySet(AClass.GetFMTID);\r\nend;\r\n\r\nprocedure TJclFileSummary.DeletePropertySet(const FMTID: TGUID);\r\nbegin\r\n OleCheck(FStorage.Delete(FMTID));\r\nend;\r\n\r\ndestructor TJclFileSummary.Destroy;\r\nbegin\r\n FStorage := nil;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJclFileSummary.EnumPropertySet(\r\n Proc: TJclFileSummaryPropSetCallback): Boolean;\r\nvar\r\n Enum: IEnumSTATPROPSETSTG;\r\n PropSet: STATPROPSETSTG;\r\n Returned: ULONG;\r\n Status: HRESULT;\r\nbegin\r\n OleCheck(FStorage.Enum(Enum));\r\n ZeroMemory(@PropSet, SizeOf(PropSet));\r\n\r\n OleCheck(Enum.Reset);\r\n Status := Enum.Next(1, PropSet, @Returned);\r\n Result := True;\r\n\r\n while Result and (Status = S_OK) and (Returned = 1) do\r\n begin\r\n Result := Proc(PropSet.fmtid);\r\n if Result then\r\n Status := Enum.Next(1, PropSet, @Returned);\r\n end;\r\nend;\r\n\r\nprocedure TJclFileSummary.GetPropertySet(AClass: TJclFilePropertySetClass;\r\n out Instance);\r\nvar\r\n PropertyStorage: IPropertyStorage;\r\nbegin\r\n TJclFilePropertySet(Instance) := nil;\r\n PropertyStorage := GetPropertySet(AClass.GetFMTID);\r\n if Assigned(PropertyStorage) then\r\n TJclFilePropertySet(Instance) := AClass.Create(PropertyStorage);\r\nend;\r\n\r\nprocedure TJclFileSummary.GetPropertySet(const FMTID: TGUID; out Instance);\r\nvar\r\n PropertyStorage: IPropertyStorage;\r\nbegin\r\n TJclFilePropertySet(Instance) := nil;\r\n PropertyStorage := GetPropertySet(FMTID);\r\n if Assigned(PropertyStorage) then\r\n TJclFilePropertySet(Instance) := TJclFilePropertySet.Create(PropertyStorage);\r\nend;\r\n\r\nfunction TJclFileSummary.GetPropertySet(const FMTID: TGUID): IPropertyStorage;\r\nvar\r\n Status: HRESULT;\r\nbegin\r\n Status := FStorage.Open(FMTID,\r\n STGM_DIRECT or AccessModes[AccessMode] or ShareModes[ShareMode],\r\n Result);\r\n if (Status = STG_E_FILENOTFOUND) then\r\n begin\r\n if AccessMode = fsaRead then\r\n Result := nil\r\n else\r\n OleCheck(FStorage.Create(FMTID, FMTID, PROPSETFLAG_DEFAULT,\r\n STGM_CREATE or STGM_DIRECT or AccessModes[AccessMode] or ShareModes[ShareMode],\r\n Result))\r\n end\r\n else\r\n OleCheck(Status);\r\nend;\r\n\r\n//=== { TJclFilePropertySet } ================================================\r\n\r\nconstructor TJclFilePropertySet.Create(APropertyStorage: IPropertyStorage);\r\nbegin\r\n inherited Create;\r\n FPropertyStorage := APropertyStorage;\r\nend;\r\n\r\nprocedure TJclFilePropertySet.DeleteProperty(const Name: WideString);\r\nvar\r\n Prop: TPropSpec;\r\nbegin\r\n Prop.ulKind := PRSPEC_LPWSTR;\r\n Prop.lpwstr := PWideChar(Name);\r\n OleCheck(FPropertyStorage.DeleteMultiple(1, @Prop));\r\nend;\r\n\r\nprocedure TJclFilePropertySet.DeletePropertyName(ID: TPropID);\r\nbegin\r\n OleCheck(FPropertyStorage.DeletePropertyNames(1, @ID));\r\nend;\r\n\r\nprocedure TJclFilePropertySet.DeleteProperty(ID: TPropID);\r\nvar\r\n Prop: TPropSpec;\r\nbegin\r\n Prop.ulKind := PRSPEC_PROPID;\r\n Prop.propid := ID;\r\n OleCheck(FPropertyStorage.DeleteMultiple(1, @Prop));\r\nend;\r\n\r\ndestructor TJclFilePropertySet.Destroy;\r\nbegin\r\n FPropertyStorage := nil;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJclFilePropertySet.EnumProperties(\r\n Proc: TJclFileSummaryPropCallback): Boolean;\r\nvar\r\n Enum: IEnumSTATPROPSTG;\r\n Status: HRESULT;\r\n Returned: ULONG;\r\n Prop: STATPROPSTG;\r\nbegin\r\n OleCheck(FPropertyStorage.Enum(Enum));\r\n\r\n ZeroMemory(@Prop, SizeOf(Prop));\r\n OleCheck(Enum.Reset);\r\n Status := Enum.Next(1, Prop, @Returned);\r\n Result := True;\r\n\r\n while Result and (Status = S_OK) and (Returned = 1) do\r\n begin\r\n try\r\n Result := Proc(Prop.lpwstrName, Prop.propid, Prop.vt);\r\n finally\r\n if Assigned(Prop.lpwstrName) then\r\n CoTaskMemFree(Prop.lpwstrName);\r\n end;\r\n\r\n if Result then\r\n Status := Enum.Next(1, Prop, @Returned);\r\n end;\r\nend;\r\n\r\nfunction TJclFilePropertySet.GetAnsiStringProperty(\r\n const ID: Integer): AnsiString;\r\nvar\r\n PropValue: TPropVariant;\r\nbegin\r\n Result := '';\r\n PropValue := GetProperty(ID);\r\n try\r\n case PropValue.vt of\r\n VT_EMPTY, VT_NULL: ;\r\n VT_LPSTR:\r\n Result := PropValue.pszVal;\r\n VT_LPWSTR:\r\n Result := AnsiString(WideString(PropValue.pwszVal));\r\n VT_BSTR:\r\n Result := AnsiString(WideString(PropValue.bstrVal));\r\n else\r\n raise EJclFileSummaryError.CreateRes(@RsEIncomatibleDataFormat);\r\n end;\r\n finally\r\n PropVariantClear(PropValue);\r\n end;\r\nend;\r\n\r\nfunction TJclFilePropertySet.GetBooleanProperty(const ID: Integer): Boolean;\r\nvar\r\n PropValue: TPropVariant;\r\nbegin\r\n Result := False;\r\n PropValue := GetProperty(ID);\r\n try\r\n case PropValue.vt of\r\n VT_EMPTY, VT_NULL: ;\r\n VT_BOOL:\r\n Result := PropValue.bool;\r\n else\r\n raise EJclFileSummaryError.CreateRes(@RsEIncomatibleDataFormat);\r\n end;\r\n finally\r\n PropVariantClear(PropValue);\r\n end;\r\nend;\r\n\r\nfunction TJclFilePropertySet.GetBSTRProperty(const ID: Integer): WideString;\r\nvar\r\n PropValue: TPropVariant;\r\nbegin\r\n Result := '';\r\n PropValue := GetProperty(ID);\r\n try\r\n case PropValue.vt of\r\n VT_EMPTY, VT_NULL: ;\r\n VT_LPSTR:\r\n Result := WideString(AnsiString(PropValue.pszVal));\r\n VT_LPWSTR:\r\n Result := PropValue.pwszVal;\r\n VT_BSTR:\r\n Result := PropValue.bstrVal;\r\n else\r\n raise EJclFileSummaryError.CreateRes(@RsEIncomatibleDataFormat);\r\n end;\r\n finally\r\n PropVariantClear(PropValue);\r\n end;\r\nend;\r\n\r\nfunction TJclFilePropertySet.GetCardinalProperty(const ID: Integer): Cardinal;\r\nvar\r\n PropValue: TPropVariant;\r\nbegin\r\n Result := 0;\r\n PropValue := GetProperty(ID);\r\n try\r\n case PropValue.vt of\r\n VT_EMPTY, VT_NULL: ;\r\n VT_I2:\r\n Result := PropValue.iVal;\r\n VT_I4, VT_INT:\r\n Result := PropValue.lVal;\r\n VT_I1:\r\n Result := PropValue.bVal; // no ShortInt? (cVal)\r\n VT_UI1:\r\n Result := PropValue.bVal;\r\n VT_UI2:\r\n Result := PropValue.uiVal;\r\n VT_UI4, VT_UINT:\r\n Result := PropValue.ulVal;\r\n else\r\n raise EJclFileSummaryError.CreateRes(@RsEIncomatibleDataFormat);\r\n end;\r\n finally\r\n PropVariantClear(PropValue);\r\n end;\r\nend;\r\n\r\nfunction TJclFilePropertySet.GetClipDataProperty(const ID: Integer): PClipData;\r\nvar\r\n PropValue: TPropVariant;\r\nbegin\r\n Result := nil;\r\n PropValue := GetProperty(ID);\r\n try\r\n case PropValue.vt of\r\n VT_EMPTY, VT_NULL: ;\r\n VT_CF:\r\n Result := PropValue.pclipdata\r\n else\r\n raise EJclFileSummaryError.CreateRes(@RsEIncomatibleDataFormat);\r\n end;\r\n finally\r\n PropVariantClear(PropValue);\r\n end;\r\nend;\r\n\r\nfunction TJclFilePropertySet.GetFileTimeProperty(const ID: Integer): TFileTime;\r\nvar\r\n PropValue: TPropVariant;\r\nbegin\r\n ZeroMemory(@Result, SizeOf(Result));\r\n PropValue := GetProperty(ID);\r\n try\r\n case PropValue.vt of\r\n VT_EMPTY, VT_NULL: ;\r\n VT_FILETIME:\r\n Result := PropValue.filetime;\r\n else\r\n raise EJclFileSummaryError.CreateRes(@RsEIncomatibleDataFormat);\r\n end;\r\n finally\r\n PropVariantClear(PropValue);\r\n end;\r\nend;\r\n\r\nclass function TJclFilePropertySet.GetFMTID: TGUID;\r\nbegin\r\n Result := GUID_NULL;\r\nend;\r\n\r\nfunction TJclFilePropertySet.GetIntegerProperty(const ID: Integer): Integer;\r\nvar\r\n PropValue: TPropVariant;\r\nbegin\r\n Result := 0;\r\n PropValue := GetProperty(ID);\r\n try\r\n case PropValue.vt of\r\n VT_EMPTY, VT_NULL: ;\r\n VT_I2:\r\n Result := PropValue.iVal;\r\n VT_I4, VT_INT:\r\n Result := PropValue.lVal;\r\n VT_I1:\r\n Result := PropValue.bVal; // no ShortInt? (cVal)\r\n VT_UI1:\r\n Result := PropValue.bVal;\r\n VT_UI2:\r\n Result := PropValue.uiVal;\r\n VT_UI4, VT_UINT:\r\n Result := PropValue.ulVal;\r\n else\r\n raise EJclFileSummaryError.CreateRes(@RsEIncomatibleDataFormat);\r\n end;\r\n finally\r\n PropVariantClear(PropValue);\r\n end;\r\nend;\r\n\r\nfunction TJclFilePropertySet.GetProperty(const Name: WideString): TPropVariant;\r\nvar\r\n Prop: TPropSpec;\r\nbegin\r\n Prop.ulKind := PRSPEC_LPWSTR;\r\n Prop.lpwstr := PWideChar(Name);\r\n\r\n OleCheck(FPropertyStorage.ReadMultiple(1, @Prop, @Result));\r\nend;\r\n\r\nfunction TJclFilePropertySet.GetProperty(ID: TPropID): TPropVariant;\r\nvar\r\n Prop: TPropSpec;\r\nbegin\r\n Prop.ulKind := PRSPEC_PROPID;\r\n Prop.propid := ID;\r\n\r\n OleCheck(FPropertyStorage.ReadMultiple(1, @Prop, @Result));\r\nend;\r\n\r\nfunction TJclFilePropertySet.GetPropertyName(ID: TPropID): WideString;\r\nvar\r\n AName: PWideChar;\r\nbegin\r\n AName := nil;\r\n try\r\n OleCheck(FPropertyStorage.ReadPropertyNames(1, @ID, @AName));\r\n Result := AName;\r\n finally\r\n if Assigned(AName) then\r\n CoTaskMemFree(AName);\r\n end;\r\nend;\r\n\r\nfunction TJclFilePropertySet.GetTCALPSTRProperty(const ID: Integer): TCALPSTR;\r\nvar\r\n PropValue: TPropVariant;\r\nbegin\r\n ZeroMemory(@Result, SizeOf(Result));\r\n PropValue := GetProperty(ID);\r\n try\r\n case PropValue.vt of\r\n VT_EMPTY, VT_NULL: ;\r\n VT_LPSTR or VT_VECTOR:\r\n Result := PropValue.calpstr;\r\n else\r\n raise EJclFileSummaryError.CreateRes(@RsEIncomatibleDataFormat);\r\n end;\r\n finally\r\n PropVariantClear(PropValue);\r\n end;\r\nend;\r\n\r\nfunction TJclFilePropertySet.GetTCAPROPVARIANTProperty(\r\n const ID: Integer): TCAPROPVARIANT;\r\nvar\r\n PropValue: TPropVariant;\r\nbegin\r\n ZeroMemory(@Result, SizeOf(Result));\r\n PropValue := GetProperty(ID);\r\n try\r\n case PropValue.vt of\r\n VT_EMPTY, VT_NULL: ;\r\n VT_VARIANT or VT_VECTOR:\r\n Result := PropValue.capropvar;\r\n else\r\n raise EJclFileSummaryError.CreateRes(@RsEIncomatibleDataFormat);\r\n end;\r\n finally\r\n PropVariantClear(PropValue);\r\n end;\r\nend;\r\n\r\nfunction TJclFilePropertySet.GetWideStringProperty(\r\n const ID: Integer): WideString;\r\nvar\r\n PropValue: TPropVariant;\r\nbegin\r\n Result := '';\r\n PropValue := GetProperty(ID);\r\n try\r\n case PropValue.vt of\r\n VT_EMPTY, VT_NULL: ;\r\n VT_LPSTR:\r\n Result := WideString(AnsiString(PropValue.pszVal));\r\n VT_LPWSTR:\r\n Result := PropValue.pwszVal;\r\n VT_BSTR:\r\n Result := PropValue.bstrVal;\r\n else\r\n raise EJclFileSummaryError.CreateRes(@RsEIncomatibleDataFormat);\r\n end;\r\n finally\r\n PropVariantClear(PropValue);\r\n end;\r\nend;\r\n\r\nfunction TJclFilePropertySet.GetWordProperty(const ID: Integer): Word;\r\nvar\r\n PropValue: TPropVariant;\r\nbegin\r\n Result := 0;\r\n PropValue := GetProperty(ID);\r\n try\r\n case PropValue.vt of\r\n VT_EMPTY, VT_NULL: ;\r\n VT_I2:\r\n Result := PropValue.iVal;\r\n VT_I1:\r\n Result := PropValue.bVal; // no ShortInt? (cVal)\r\n VT_UI1:\r\n Result := PropValue.bVal;\r\n VT_UI2:\r\n Result := PropValue.uiVal;\r\n else\r\n raise EJclFileSummaryError.CreateRes(@RsEIncomatibleDataFormat);\r\n end;\r\n finally\r\n PropVariantClear(PropValue);\r\n end;\r\nend;\r\n\r\nprocedure TJclFilePropertySet.SetAnsiStringProperty(const ID: Integer;\r\n const Value: AnsiString);\r\nvar\r\n PropValue: TPropVariant;\r\nbegin\r\n PropValue.vt := VT_LPSTR;\r\n PropValue.pszVal := PAnsiChar(Value);\r\n SetProperty(ID, PropValue);\r\nend;\r\n\r\nprocedure TJclFilePropertySet.SetBooleanProperty(const ID: Integer;\r\n const Value: Boolean);\r\nvar\r\n PropValue: TPropVariant;\r\nbegin\r\n PropValue.vt := VT_BOOL;\r\n PropValue.bool := Value;\r\n SetProperty(ID, PropValue);\r\nend;\r\n\r\nprocedure TJclFilePropertySet.SetBSTRProperty(const ID: Integer;\r\n const Value: WideString);\r\nvar\r\n PropValue: TPropVariant;\r\nbegin\r\n PropValue.vt := VT_BSTR;\r\n PropValue.bstrVal := SysAllocString(PWideChar(Value));\r\n SetProperty(ID, PropValue);\r\nend;\r\n\r\nprocedure TJclFilePropertySet.SetCardinalProperty(const ID: Integer;\r\n const Value: Cardinal);\r\nvar\r\n PropValue: TPropVariant;\r\nbegin\r\n PropValue.vt := VT_UI4;\r\n PropValue.ulVal := Value;\r\n SetProperty(ID, PropValue);\r\nend;\r\n\r\nprocedure TJclFilePropertySet.SetClipDataProperty(const ID: Integer;\r\n const Value: PClipData);\r\nvar\r\n PropValue: TPropVariant;\r\nbegin\r\n PropValue.vt := VT_CF;\r\n PropValue.pclipdata := Value;\r\n SetProperty(ID, PropValue);\r\nend;\r\n\r\nprocedure TJclFilePropertySet.SetFileTimeProperty(const ID: Integer;\r\n const Value: TFileTime);\r\nvar\r\n PropValue: TPropVariant;\r\nbegin\r\n PropValue.vt := VT_FILETIME;\r\n PropValue.filetime := Value;\r\n SetProperty(ID, PropValue);\r\nend;\r\n\r\nprocedure TJclFilePropertySet.SetIntegerProperty(const ID, Value: Integer);\r\nvar\r\n PropValue: TPropVariant;\r\nbegin\r\n PropValue.vt := VT_I4;\r\n PropValue.lVal := Value;\r\n SetProperty(ID, PropValue);\r\nend;\r\n\r\nprocedure TJclFilePropertySet.SetProperty(const Name: WideString;\r\n const Value: TPropVariant; AllocationBase: TPropID);\r\nvar\r\n Prop: TPropSpec;\r\nbegin\r\n Prop.ulKind := PRSPEC_LPWSTR;\r\n Prop.lpwstr := PWideChar(Name);\r\n\r\n OleCheck(FPropertyStorage.WriteMultiple(1, @Prop, @Value, AllocationBase));\r\nend;\r\n\r\nprocedure TJclFilePropertySet.SetPropertyName(ID: TPropID;\r\n const Name: WideString);\r\nvar\r\n AName: PWideChar;\r\nbegin\r\n AName := PWideChar(Name);\r\n OleCheck(FPropertyStorage.WritePropertyNames(1, @ID, @AName));\r\nend;\r\n\r\nprocedure TJclFilePropertySet.SetTCALPSTRProperty(const ID: Integer;\r\n const Value: TCALPSTR);\r\nvar\r\n PropValue: TPropVariant;\r\nbegin\r\n PropValue.vt := VT_LPSTR or VT_VECTOR;\r\n PropValue.calpstr := Value;\r\n SetProperty(ID, PropValue);\r\nend;\r\n\r\nprocedure TJclFilePropertySet.SetTCAPROPVARIANTProperty(const ID: Integer;\r\n const Value: TCAPROPVARIANT);\r\nvar\r\n PropValue: TPropVariant;\r\nbegin\r\n PropValue.vt := VT_VARIANT or VT_VECTOR;\r\n PropValue.capropvar := Value;\r\n SetProperty(ID, PropValue);\r\nend;\r\n\r\nprocedure TJclFilePropertySet.SetWideStringProperty(const ID: Integer;\r\n const Value: WideString);\r\nvar\r\n PropValue: TPropVariant;\r\nbegin\r\n PropValue.vt := VT_LPWSTR;\r\n PropValue.pwszVal := PWideChar(Value);\r\n SetProperty(ID, PropValue);\r\nend;\r\n\r\nprocedure TJclFilePropertySet.SetWordProperty(const ID: Integer;\r\n const Value: Word);\r\nvar\r\n PropValue: TPropVariant;\r\nbegin\r\n PropValue.vt := VT_UI2;\r\n PropValue.uiVal := Value;\r\n SetProperty(ID, PropValue);\r\nend;\r\n\r\nprocedure TJclFilePropertySet.SetProperty(ID: TPropID; const Value: TPropVariant);\r\nvar\r\n Prop: TPropSpec;\r\nbegin\r\n Prop.ulKind := PRSPEC_PROPID;\r\n Prop.propid := ID;\r\n\r\n OleCheck(FPropertyStorage.WriteMultiple(1, @Prop, @Value, PID_FIRST_USABLE));\r\nend;\r\n\r\n//=== { TJclFileSummaryInformation } =========================================\r\n\r\nclass function TJclFileSummaryInformation.GetFMTID: TGUID;\r\nbegin\r\n Result := FMTID_SummaryInformation;\r\nend;\r\n\r\n//=== { TJclDocSummaryInformation } ==========================================\r\n\r\nclass function TJclDocSummaryInformation.GetFMTID: TGUID;\r\nbegin\r\n Result := FMTID_DocumentSummaryInformation;\r\nend;\r\n\r\n//=== { TJclMediaSummaryInformation } ========================================\r\n\r\nclass function TJclMediaFileSummaryInformation.GetFMTID: TGUID;\r\nbegin\r\n Result := FMTID_MediaFileSummaryInformation\r\nend;\r\n\r\n//=== { TJclMSISummaryInformation } ==========================================\r\n\r\nclass function TJclMSISummaryInformation.GetFMTID: TGUID;\r\nbegin\r\n Result := FMTID_SummaryInformation;\r\nend;\r\n\r\n//=== { TJclShellSummaryInformation } ========================================\r\n\r\nclass function TJclShellSummaryInformation.GetFMTID: TGUID;\r\nbegin\r\n Result := FMTID_ShellDetails;\r\nend;\r\n\r\n//=== { TJclStorageSummaryInformation } ======================================\r\n\r\nclass function TJclStorageSummaryInformation.GetFMTID: TGUID;\r\nbegin\r\n Result := FMTID_Storage;\r\nend;\r\n\r\n//=== { TJclImageSummaryInformation } ========================================\r\n\r\nclass function TJclImageSummaryInformation.GetFMTID: TGUID;\r\nbegin\r\n Result := FMTID_ImageSummaryInformation;\r\nend;\r\n\r\n//=== { TJclDisplacedSummaryInformation } ====================================\r\n\r\nclass function TJclDisplacedSummaryInformation.GetFMTID: TGUID;\r\nbegin\r\n Result := FMTID_Displaced;\r\nend;\r\n\r\n//=== { TJclBriefCaseSummaryInformation }\r\n\r\nclass function TJclBriefCaseSummaryInformation.GetFMTID: TGUID;\r\nbegin\r\n Result := FMTID_Briefcase;\r\nend;\r\n\r\n//=== { TJclMiscSummaryInformation } =========================================\r\n\r\nclass function TJclMiscSummaryInformation.GetFMTID: TGUID;\r\nbegin\r\n Result := FMTID_Misc;\r\nend;\r\n\r\n//=== { TJclWebViewSummaryInformation } ======================================\r\n\r\nclass function TJclWebViewSummaryInformation.GetFMTID: TGUID;\r\nbegin\r\n Result := FMTID_WebView;\r\nend;\r\n\r\n//=== { TJclMusicSummaryInformation } ========================================\r\n\r\nclass function TJclMusicSummaryInformation.GetFMTID: TGUID;\r\nbegin\r\n Result := FMTID_MUSIC;\r\nend;\r\n\r\n//=== { TJclDRMSummaryInformation } ==========================================\r\n\r\nclass function TJclDRMSummaryInformation.GetFMTID: TGUID;\r\nbegin\r\n Result := FMTID_DRM;\r\nend;\r\n\r\n//=== { TJclVideoSummaryInformation } ========================================\r\n\r\nclass function TJclVideoSummaryInformation.GetFMTID: TGUID;\r\nbegin\r\n Result := FMTID_Video;\r\nend;\r\n\r\n//=== { TJclAudioSummaryInformation } ========================================\r\n\r\nclass function TJclAudioSummaryInformation.GetFMTID: TGUID;\r\nbegin\r\n Result := FMTID_Audio;\r\nend;\r\n\r\n//=== { TJclControlPanelSummaryInformation } =================================\r\n\r\nclass function TJclControlPanelSummaryInformation.GetFMTID: TGUID;\r\nbegin\r\n Result := FMTID_ControlPanel;\r\nend;\r\n\r\n//=== { TJclVolumeSummaryInformation } =======================================\r\n\r\nclass function TJclVolumeSummaryInformation.GetFMTID: TGUID;\r\nbegin\r\n Result := FMTID_Volume; \r\nend;\r\n\r\n//=== { TJclShareSummaryInformation } ========================================\r\n\r\nclass function TJclShareSummaryInformation.GetFMTID: TGUID;\r\nbegin\r\n Result := FMTID_Share;\r\nend;\r\n\r\n//=== { TJclLinkSummaryInformation } =========================================\r\n\r\nclass function TJclLinkSummaryInformation.GetFMTID: TGUID;\r\nbegin\r\n Result := FMTID_Link;\r\nend;\r\n\r\n//=== { TJclQuerySummaryInformation } ========================================\r\n\r\nclass function TJclQuerySummaryInformation.GetFMTID: TGUID;\r\nbegin\r\n Result := FMTID_Query;\r\nend;\r\n\r\n//=== { TJclImageInformation } ===============================================\r\n\r\nclass function TJclImageInformation.GetFMTID: TGUID;\r\nbegin\r\n Result := FMTID_ImageInformation;\r\nend;\r\n\r\n//=== { TJclJpegSummaryInformation } =========================================\r\n\r\nclass function TJclJpegSummaryInformation.GetFMTID: TGUID;\r\nbegin\r\n Result := FMTID_JpegAppHeaders;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jcl/source/windows/JclNoDepAdmin.manifest", "content": "\r\n\r\n \r\n \r\n \r\n \r\n \r\n \r\n \r\n \r\n\r\n" }, { "path": "External/Jedi/Jcl/source/windows/JclNoDepAdmin.rc", "content": "/****************************************************************************************************\r\n\r\n VistaElevate.rc\r\n\r\n****************************************************************************************************/\r\n\r\nLANGUAGE 0,0 1 24 \"JclNoDepAdmin.manifest\"\r\n" }, { "path": "External/Jedi/Jcl/source/windows/JclNoDepAsInvoker.manifest", "content": "\r\n\r\n \r\n \r\n \r\n \r\n \r\n \r\n \r\n \r\n\r\n" }, { "path": "External/Jedi/Jcl/source/windows/JclNoDepAsInvoker.rc", "content": "/****************************************************************************************************\r\n\r\n VistaElevate.rc\r\n\r\n****************************************************************************************************/\r\n\r\nLANGUAGE 0,0 1 24 \"JclNoDepAsInvoker.manifest\"\r\n" }, { "path": "External/Jedi/Jcl/source/windows/JclPeImage.pas", "content": "{**************************************************************************************************}\r\n{ }\r\n{ Project JEDI Code Library (JCL) }\r\n{ }\r\n{ The contents of this file are subject to the Mozilla Public License Version 1.1 (the \"License\"); }\r\n{ you may not use this file except in compliance with the License. You may obtain a copy of the }\r\n{ License at http://www.mozilla.org/MPL/ }\r\n{ }\r\n{ Software distributed under the License is distributed on an \"AS IS\" basis, WITHOUT WARRANTY OF }\r\n{ ANY KIND, either express or implied. See the License for the specific language governing rights }\r\n{ and limitations under the License. }\r\n{ }\r\n{ The Original Code is JclPeImage.pas. }\r\n{ }\r\n{ The Initial Developer of the Original Code is Petr Vones. Portions created by Petr Vones are }\r\n{ Copyright (C) Petr Vones. All Rights Reserved. }\r\n{ }\r\n{ Contributor(s): }\r\n{ Marcel van Brakel }\r\n{ Robert Marquardt (marquardt) }\r\n{ Uwe Schuster (uschuster) }\r\n{ Matthias Thoma (mthoma) }\r\n{ Petr Vones (pvones) }\r\n{ Hallvard Vassbotn }\r\n{ Jean-Fabien Connault (cycocrew) }\r\n{ }\r\n{**************************************************************************************************}\r\n{ }\r\n{ This unit contains various classes and support routines to read the contents of portable }\r\n{ executable (PE) files. You can use these classes to, for example examine the contents of the }\r\n{ imports section of an executable. In addition the unit contains support for Borland specific }\r\n{ structures and name unmangling. }\r\n{ }\r\n{**************************************************************************************************}\r\n{ }\r\n{ Last modified: $Date:: 2012-09-04 16:08:04 +0200 (mar. 04 sept. 2012) $ }\r\n{ Revision: $Rev:: 3861 $ }\r\n{ Author: $Author:: outchy $ }\r\n{ }\r\n{**************************************************************************************************}\r\n\r\nunit JclPeImage;\r\n\r\n{$I jcl.inc}\r\n{$I windowsonly.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n {$IFDEF HAS_UNITSCOPE}\r\n Winapi.Windows, System.Classes, System.SysUtils, System.TypInfo, System.Contnrs,\r\n {$ELSE ~HAS_UNITSCOPE}\r\n Windows, Classes, SysUtils, TypInfo, Contnrs,\r\n {$ENDIF ~HAS_UNITSCOPE}\r\n JclBase, JclDateTime, JclFileUtils, JclSysInfo, JclWin32;\r\n\r\ntype\r\n // Smart name compare function\r\n TJclSmartCompOption = (scSimpleCompare, scIgnoreCase);\r\n TJclSmartCompOptions = set of TJclSmartCompOption;\r\n\r\nfunction PeStripFunctionAW(const FunctionName: string): string;\r\n\r\nfunction PeSmartFunctionNameSame(const ComparedName, FunctionName: string;\r\n Options: TJclSmartCompOptions = []): Boolean;\r\n\r\ntype\r\n // Base list\r\n EJclPeImageError = class(EJclError);\r\n\r\n TJclPeImage = class;\r\n\r\n TJclPeImageClass = class of TJclPeImage;\r\n\r\n TJclPeImageBaseList = class(TObjectList)\r\n private\r\n FImage: TJclPeImage;\r\n public\r\n constructor Create(AImage: TJclPeImage);\r\n property Image: TJclPeImage read FImage;\r\n end;\r\n\r\n // Images cache\r\n TJclPeImagesCache = class(TObject)\r\n private\r\n FList: TStringList;\r\n function GetCount: Integer;\r\n function GetImages(const FileName: TFileName): TJclPeImage;\r\n protected\r\n function GetPeImageClass: TJclPeImageClass; virtual;\r\n public\r\n constructor Create;\r\n destructor Destroy; override;\r\n procedure Clear;\r\n property Images[const FileName: TFileName]: TJclPeImage read GetImages; default;\r\n property Count: Integer read GetCount;\r\n end;\r\n\r\n // Import section related classes\r\n TJclPeImportSort = (isName, isOrdinal, isHint, isLibImport);\r\n TJclPeImportLibSort = (ilName, ilIndex);\r\n TJclPeImportKind = (ikImport, ikDelayImport, ikBoundImport);\r\n TJclPeResolveCheck = (icNotChecked, icResolved, icUnresolved);\r\n TJclPeLinkerProducer = (lrBorland, lrMicrosoft);\r\n // lrBorland -> Delphi PE files\r\n // lrMicrosoft -> MSVC and BCB PE files\r\n\r\n TJclPeImportLibItem = class;\r\n\r\n // Created from a IMAGE_THUNK_DATA64 or IMAGE_THUNK_DATA32 record\r\n TJclPeImportFuncItem = class(TObject)\r\n private\r\n FOrdinal: Word; // word in 32/64\r\n FHint: Word;\r\n FImportLib: TJclPeImportLibItem;\r\n FIndirectImportName: Boolean;\r\n FName: string;\r\n FResolveCheck: TJclPeResolveCheck;\r\n function GetIsByOrdinal: Boolean;\r\n protected\r\n procedure SetName(const Value: string);\r\n procedure SetIndirectImportName(const Value: string);\r\n procedure SetResolveCheck(Value: TJclPeResolveCheck);\r\n public\r\n constructor Create(AImportLib: TJclPeImportLibItem; AOrdinal: Word;\r\n AHint: Word; const AName: string);\r\n property Ordinal: Word read FOrdinal;\r\n property Hint: Word read FHint;\r\n property ImportLib: TJclPeImportLibItem read FImportLib;\r\n property IndirectImportName: Boolean read FIndirectImportName;\r\n property IsByOrdinal: Boolean read GetIsByOrdinal;\r\n property Name: string read FName;\r\n property ResolveCheck: TJclPeResolveCheck read FResolveCheck;\r\n end;\r\n\r\n // Created from a IMAGE_IMPORT_DESCRIPTOR\r\n TJclPeImportLibItem = class(TJclPeImageBaseList)\r\n private\r\n FImportDescriptor: Pointer;\r\n FImportDirectoryIndex: Integer;\r\n FImportKind: TJclPeImportKind;\r\n FLastSortType: TJclPeImportSort;\r\n FLastSortDescending: Boolean;\r\n FName: string;\r\n FSorted: Boolean;\r\n FTotalResolveCheck: TJclPeResolveCheck;\r\n FThunk: Pointer;\r\n FThunkData: Pointer;\r\n function GetCount: Integer;\r\n function GetFileName: TFileName;\r\n function GetItems(Index: Integer): TJclPeImportFuncItem;\r\n function GetName: string;\r\n function GetThunkData32: PImageThunkData32;\r\n function GetThunkData64: PImageThunkData64;\r\n protected\r\n procedure CheckImports(ExportImage: TJclPeImage);\r\n procedure CreateList;\r\n procedure SetImportDirectoryIndex(Value: Integer);\r\n procedure SetImportKind(Value: TJclPeImportKind);\r\n procedure SetSorted(Value: Boolean);\r\n procedure SetThunk(Value: Pointer);\r\n public\r\n constructor Create(AImage: TJclPeImage; AImportDescriptor: Pointer;\r\n AImportKind: TJclPeImportKind; const AName: string; AThunk: Pointer);\r\n procedure SortList(SortType: TJclPeImportSort; Descending: Boolean = False);\r\n property Count: Integer read GetCount;\r\n property FileName: TFileName read GetFileName;\r\n property ImportDescriptor: Pointer read FImportDescriptor;\r\n property ImportDirectoryIndex: Integer read FImportDirectoryIndex;\r\n property ImportKind: TJclPeImportKind read FImportKind;\r\n property Items[Index: Integer]: TJclPeImportFuncItem read GetItems; default;\r\n property Name: string read GetName;\r\n property OriginalName: string read FName;\r\n // use the following properties\r\n // property ThunkData: PImageThunkData\r\n property ThunkData32: PImageThunkData32 read GetThunkData32;\r\n property ThunkData64: PImageThunkData64 read GetThunkData64;\r\n property TotalResolveCheck: TJclPeResolveCheck read FTotalResolveCheck;\r\n end;\r\n\r\n TJclPeImportList = class(TJclPeImageBaseList)\r\n private\r\n FAllItemsList: TList;\r\n FFilterModuleName: string;\r\n FLastAllSortType: TJclPeImportSort;\r\n FLastAllSortDescending: Boolean;\r\n FLinkerProducer: TJclPeLinkerProducer;\r\n FParallelImportTable: array of Pointer;\r\n FUniqueNamesList: TStringList;\r\n function GetAllItemCount: Integer;\r\n function GetAllItems(Index: Integer): TJclPeImportFuncItem;\r\n function GetItems(Index: Integer): TJclPeImportLibItem;\r\n function GetUniqueLibItemCount: Integer;\r\n function GetUniqueLibItems(Index: Integer): TJclPeImportLibItem;\r\n function GetUniqueLibNames(Index: Integer): string;\r\n function GetUniqueLibItemFromName(const Name: string): TJclPeImportLibItem;\r\n procedure SetFilterModuleName(const Value: string);\r\n protected\r\n procedure CreateList;\r\n procedure RefreshAllItems;\r\n public\r\n constructor Create(AImage: TJclPeImage);\r\n destructor Destroy; override;\r\n procedure CheckImports(PeImageCache: TJclPeImagesCache = nil);\r\n function MakeBorlandImportTableForMappedImage: Boolean;\r\n function SmartFindName(const CompareName, LibName: string; Options: TJclSmartCompOptions = []): TJclPeImportFuncItem;\r\n procedure SortAllItemsList(SortType: TJclPeImportSort; Descending: Boolean = False);\r\n procedure SortList(SortType: TJclPeImportLibSort);\r\n procedure TryGetNamesForOrdinalImports;\r\n property AllItems[Index: Integer]: TJclPeImportFuncItem read GetAllItems;\r\n property AllItemCount: Integer read GetAllItemCount;\r\n property FilterModuleName: string read FFilterModuleName write SetFilterModuleName;\r\n property Items[Index: Integer]: TJclPeImportLibItem read GetItems; default;\r\n property LinkerProducer: TJclPeLinkerProducer read FLinkerProducer;\r\n property UniqueLibItemCount: Integer read GetUniqueLibItemCount;\r\n property UniqueLibItemFromName[const Name: string]: TJclPeImportLibItem read GetUniqueLibItemFromName;\r\n property UniqueLibItems[Index: Integer]: TJclPeImportLibItem read GetUniqueLibItems;\r\n property UniqueLibNames[Index: Integer]: string read GetUniqueLibNames;\r\n end;\r\n\r\n // Export section related classes\r\n TJclPeExportSort = (esName, esOrdinal, esHint, esAddress, esForwarded, esAddrOrFwd, esSection);\r\n\r\n TJclPeExportFuncList = class;\r\n\r\n // Created from a IMAGE_EXPORT_DIRECTORY\r\n TJclPeExportFuncItem = class(TObject)\r\n private\r\n FAddress: DWORD;\r\n FExportList: TJclPeExportFuncList;\r\n FForwardedName: string;\r\n FForwardedDotPos: string;\r\n FHint: Word;\r\n FName: string;\r\n FOrdinal: Word;\r\n FResolveCheck: TJclPeResolveCheck;\r\n function GetAddressOrForwardStr: string;\r\n function GetForwardedFuncName: string;\r\n function GetForwardedLibName: string;\r\n function GetForwardedFuncOrdinal: DWORD;\r\n function GetIsExportedVariable: Boolean;\r\n function GetIsForwarded: Boolean;\r\n function GetSectionName: string;\r\n function GetMappedAddress: Pointer;\r\n protected\r\n procedure SetResolveCheck(Value: TJclPeResolveCheck);\r\n public\r\n constructor Create(AExportList: TJclPeExportFuncList; const AName, AForwardedName: string;\r\n AAddress: DWORD; AHint: Word; AOrdinal: Word; AResolveCheck: TJclPeResolveCheck);\r\n property Address: DWORD read FAddress;\r\n property AddressOrForwardStr: string read GetAddressOrForwardStr;\r\n property IsExportedVariable: Boolean read GetIsExportedVariable;\r\n property IsForwarded: Boolean read GetIsForwarded;\r\n property ForwardedName: string read FForwardedName;\r\n property ForwardedLibName: string read GetForwardedLibName;\r\n property ForwardedFuncOrdinal: DWORD read GetForwardedFuncOrdinal;\r\n property ForwardedFuncName: string read GetForwardedFuncName;\r\n property Hint: Word read FHint;\r\n property MappedAddress: Pointer read GetMappedAddress;\r\n property Name: string read FName;\r\n property Ordinal: Word read FOrdinal;\r\n property ResolveCheck: TJclPeResolveCheck read FResolveCheck;\r\n property SectionName: string read GetSectionName;\r\n end;\r\n\r\n TJclPeExportFuncList = class(TJclPeImageBaseList)\r\n private\r\n FAnyForwards: Boolean;\r\n FBase: DWORD;\r\n FExportDir: PImageExportDirectory;\r\n FForwardedLibsList: TStringList;\r\n FFunctionCount: DWORD;\r\n FLastSortType: TJclPeExportSort;\r\n FLastSortDescending: Boolean;\r\n FSorted: Boolean;\r\n FTotalResolveCheck: TJclPeResolveCheck;\r\n function GetForwardedLibsList: TStrings;\r\n function GetItems(Index: Integer): TJclPeExportFuncItem;\r\n function GetItemFromAddress(Address: DWORD): TJclPeExportFuncItem;\r\n function GetItemFromOrdinal(Ordinal: DWORD): TJclPeExportFuncItem;\r\n function GetItemFromName(const Name: string): TJclPeExportFuncItem;\r\n function GetName: string;\r\n protected\r\n function CanPerformFastNameSearch: Boolean;\r\n procedure CreateList;\r\n property LastSortType: TJclPeExportSort read FLastSortType;\r\n property LastSortDescending: Boolean read FLastSortDescending;\r\n property Sorted: Boolean read FSorted;\r\n public\r\n constructor Create(AImage: TJclPeImage);\r\n destructor Destroy; override;\r\n procedure CheckForwards(PeImageCache: TJclPeImagesCache = nil);\r\n class function ItemName(Item: TJclPeExportFuncItem): string;\r\n function OrdinalValid(Ordinal: DWORD): Boolean;\r\n procedure PrepareForFastNameSearch;\r\n function SmartFindName(const CompareName: string; Options: TJclSmartCompOptions = []): TJclPeExportFuncItem;\r\n procedure SortList(SortType: TJclPeExportSort; Descending: Boolean = False);\r\n property AnyForwards: Boolean read FAnyForwards;\r\n property Base: DWORD read FBase;\r\n property ExportDir: PImageExportDirectory read FExportDir;\r\n property ForwardedLibsList: TStrings read GetForwardedLibsList;\r\n property FunctionCount: DWORD read FFunctionCount;\r\n property Items[Index: Integer]: TJclPeExportFuncItem read GetItems; default;\r\n property ItemFromAddress[Address: DWORD]: TJclPeExportFuncItem read GetItemFromAddress;\r\n property ItemFromName[const Name: string]: TJclPeExportFuncItem read GetItemFromName;\r\n property ItemFromOrdinal[Ordinal: DWORD]: TJclPeExportFuncItem read GetItemFromOrdinal;\r\n property Name: string read GetName;\r\n property TotalResolveCheck: TJclPeResolveCheck read FTotalResolveCheck;\r\n end;\r\n\r\n // Resource section related classes\r\n TJclPeResourceKind = (\r\n rtUnknown0,\r\n rtCursorEntry,\r\n rtBitmap,\r\n rtIconEntry,\r\n rtMenu,\r\n rtDialog,\r\n rtString,\r\n rtFontDir,\r\n rtFont,\r\n rtAccelerators,\r\n rtRCData,\r\n rtMessageTable,\r\n rtCursor,\r\n rtUnknown13,\r\n rtIcon,\r\n rtUnknown15,\r\n rtVersion,\r\n rtDlgInclude,\r\n rtUnknown18,\r\n rtPlugPlay,\r\n rtVxd,\r\n rtAniCursor,\r\n rtAniIcon,\r\n rtHmtl,\r\n rtManifest,\r\n rtUserDefined);\r\n\r\n TJclPeResourceList = class;\r\n TJclPeResourceItem = class;\r\n\r\n TJclPeResourceRawStream = class(TCustomMemoryStream)\r\n public\r\n constructor Create(AResourceItem: TJclPeResourceItem);\r\n function Write(const Buffer; Count: Longint): Longint; override;\r\n end;\r\n\r\n TJclPeResourceItem = class(TObject)\r\n private\r\n FEntry: PImageResourceDirectoryEntry;\r\n FImage: TJclPeImage;\r\n FList: TJclPeResourceList;\r\n FLevel: Byte;\r\n FParentItem: TJclPeResourceItem;\r\n FNameCache: string;\r\n function GetDataEntry: PImageResourceDataEntry;\r\n function GetIsDirectory: Boolean;\r\n function GetIsName: Boolean;\r\n function GetLangID: LANGID;\r\n function GetList: TJclPeResourceList;\r\n function GetName: string;\r\n function GetParameterName: string;\r\n function GetRawEntryData: Pointer;\r\n function GetRawEntryDataSize: Integer;\r\n function GetResourceType: TJclPeResourceKind;\r\n function GetResourceTypeStr: string;\r\n protected\r\n function OffsetToRawData(Ofs: DWORD): TJclAddr;\r\n function Level1Item: TJclPeResourceItem;\r\n function SubDirData: PImageResourceDirectory;\r\n public\r\n constructor Create(AImage: TJclPeImage; AParentItem: TJclPeResourceItem;\r\n AEntry: PImageResourceDirectoryEntry);\r\n destructor Destroy; override;\r\n function CompareName(AName: PChar): Boolean;\r\n property DataEntry: PImageResourceDataEntry read GetDataEntry;\r\n property Entry: PImageResourceDirectoryEntry read FEntry;\r\n property Image: TJclPeImage read FImage;\r\n property IsDirectory: Boolean read GetIsDirectory;\r\n property IsName: Boolean read GetIsName;\r\n property LangID: LANGID read GetLangID;\r\n property List: TJclPeResourceList read GetList;\r\n property Level: Byte read FLevel;\r\n property Name: string read GetName;\r\n property ParameterName: string read GetParameterName;\r\n property ParentItem: TJclPeResourceItem read FParentItem;\r\n property RawEntryData: Pointer read GetRawEntryData;\r\n property RawEntryDataSize: Integer read GetRawEntryDataSize;\r\n property ResourceType: TJclPeResourceKind read GetResourceType;\r\n property ResourceTypeStr: string read GetResourceTypeStr;\r\n end;\r\n\r\n TJclPeResourceList = class(TJclPeImageBaseList)\r\n private\r\n FDirectory: PImageResourceDirectory;\r\n FParentItem: TJclPeResourceItem;\r\n function GetItems(Index: Integer): TJclPeResourceItem;\r\n protected\r\n procedure CreateList(AParentItem: TJclPeResourceItem);\r\n public\r\n constructor Create(AImage: TJclPeImage; AParentItem: TJclPeResourceItem;\r\n ADirectory: PImageResourceDirectory);\r\n function FindName(const Name: string): TJclPeResourceItem;\r\n property Directory: PImageResourceDirectory read FDirectory;\r\n property Items[Index: Integer]: TJclPeResourceItem read GetItems; default;\r\n property ParentItem: TJclPeResourceItem read FParentItem;\r\n end;\r\n\r\n TJclPeRootResourceList = class(TJclPeResourceList)\r\n private\r\n FManifestContent: TStringList;\r\n function GetManifestContent: TStrings;\r\n public\r\n destructor Destroy; override;\r\n function FindResource(ResourceType: TJclPeResourceKind;\r\n const ResourceName: string = ''): TJclPeResourceItem; overload;\r\n function FindResource(const ResourceType: PChar;\r\n const ResourceName: PChar = nil): TJclPeResourceItem; overload;\r\n function ListResourceNames(ResourceType: TJclPeResourceKind; const Strings: TStrings): Boolean;\r\n property ManifestContent: TStrings read GetManifestContent;\r\n end;\r\n\r\n // Relocation section related classes\r\n TJclPeRelocation = record\r\n Address: Word;\r\n RelocType: Byte;\r\n VirtualAddress: DWORD;\r\n end;\r\n\r\n TJclPeRelocEntry = class(TObject)\r\n private\r\n FChunk: PImageBaseRelocation;\r\n FCount: Integer;\r\n function GetRelocations(Index: Integer): TJclPeRelocation;\r\n function GetSize: DWORD;\r\n function GetVirtualAddress: DWORD;\r\n public\r\n constructor Create(AChunk: PImageBaseRelocation; ACount: Integer);\r\n property Count: Integer read FCount;\r\n property Relocations[Index: Integer]: TJclPeRelocation read GetRelocations; default;\r\n property Size: DWORD read GetSize;\r\n property VirtualAddress: DWORD read GetVirtualAddress;\r\n end;\r\n\r\n TJclPeRelocList = class(TJclPeImageBaseList)\r\n private\r\n FAllItemCount: Integer;\r\n function GetItems(Index: Integer): TJclPeRelocEntry;\r\n function GetAllItems(Index: Integer): TJclPeRelocation;\r\n protected\r\n procedure CreateList;\r\n public\r\n constructor Create(AImage: TJclPeImage);\r\n property AllItems[Index: Integer]: TJclPeRelocation read GetAllItems;\r\n property AllItemCount: Integer read FAllItemCount;\r\n property Items[Index: Integer]: TJclPeRelocEntry read GetItems; default;\r\n end;\r\n\r\n // Debug section related classes\r\n TJclPeDebugList = class(TJclPeImageBaseList)\r\n private\r\n function GetItems(Index: Integer): TImageDebugDirectory;\r\n protected\r\n procedure CreateList;\r\n public\r\n constructor Create(AImage: TJclPeImage);\r\n property Items[Index: Integer]: TImageDebugDirectory read GetItems; default;\r\n end;\r\n\r\n // Certificates section related classes\r\n TJclPeCertificate = class(TObject)\r\n private\r\n FData: Pointer;\r\n FHeader: TWinCertificate;\r\n public\r\n constructor Create(AHeader: TWinCertificate; AData: Pointer);\r\n property Data: Pointer read FData;\r\n property Header: TWinCertificate read FHeader;\r\n end;\r\n\r\n TJclPeCertificateList = class(TJclPeImageBaseList)\r\n private\r\n function GetItems(Index: Integer): TJclPeCertificate;\r\n protected\r\n procedure CreateList;\r\n public\r\n constructor Create(AImage: TJclPeImage);\r\n property Items[Index: Integer]: TJclPeCertificate read GetItems; default;\r\n end;\r\n\r\n // Common Language Runtime section related classes\r\n TJclPeCLRHeader = class(TObject)\r\n private\r\n FHeader: TImageCor20Header;\r\n FImage: TJclPeImage;\r\n function GetVersionString: string;\r\n function GetHasMetadata: Boolean;\r\n protected\r\n procedure ReadHeader;\r\n public\r\n constructor Create(AImage: TJclPeImage);\r\n property HasMetadata: Boolean read GetHasMetadata;\r\n property Header: TImageCor20Header read FHeader;\r\n property VersionString: string read GetVersionString;\r\n property Image: TJclPeImage read FImage;\r\n end;\r\n\r\n // PE Image\r\n TJclPeHeader = (\r\n JclPeHeader_Signature,\r\n JclPeHeader_Machine,\r\n JclPeHeader_NumberOfSections,\r\n JclPeHeader_TimeDateStamp,\r\n JclPeHeader_PointerToSymbolTable,\r\n JclPeHeader_NumberOfSymbols,\r\n JclPeHeader_SizeOfOptionalHeader,\r\n JclPeHeader_Characteristics,\r\n JclPeHeader_Magic,\r\n JclPeHeader_LinkerVersion,\r\n JclPeHeader_SizeOfCode,\r\n JclPeHeader_SizeOfInitializedData,\r\n JclPeHeader_SizeOfUninitializedData,\r\n JclPeHeader_AddressOfEntryPoint,\r\n JclPeHeader_BaseOfCode,\r\n JclPeHeader_BaseOfData,\r\n JclPeHeader_ImageBase,\r\n JclPeHeader_SectionAlignment,\r\n JclPeHeader_FileAlignment,\r\n JclPeHeader_OperatingSystemVersion,\r\n JclPeHeader_ImageVersion,\r\n JclPeHeader_SubsystemVersion,\r\n JclPeHeader_Win32VersionValue,\r\n JclPeHeader_SizeOfImage,\r\n JclPeHeader_SizeOfHeaders,\r\n JclPeHeader_CheckSum,\r\n JclPeHeader_Subsystem,\r\n JclPeHeader_DllCharacteristics,\r\n JclPeHeader_SizeOfStackReserve,\r\n JclPeHeader_SizeOfStackCommit,\r\n JclPeHeader_SizeOfHeapReserve,\r\n JclPeHeader_SizeOfHeapCommit,\r\n JclPeHeader_LoaderFlags,\r\n JclPeHeader_NumberOfRvaAndSizes);\r\n\r\n TJclLoadConfig = (\r\n JclLoadConfig_Characteristics, { TODO : rename to Size? }\r\n JclLoadConfig_TimeDateStamp,\r\n JclLoadConfig_Version,\r\n JclLoadConfig_GlobalFlagsClear,\r\n JclLoadConfig_GlobalFlagsSet,\r\n JclLoadConfig_CriticalSectionDefaultTimeout,\r\n JclLoadConfig_DeCommitFreeBlockThreshold,\r\n JclLoadConfig_DeCommitTotalFreeThreshold,\r\n JclLoadConfig_LockPrefixTable,\r\n JclLoadConfig_MaximumAllocationSize,\r\n JclLoadConfig_VirtualMemoryThreshold,\r\n JclLoadConfig_ProcessHeapFlags,\r\n JclLoadConfig_ProcessAffinityMask,\r\n JclLoadConfig_CSDVersion,\r\n JclLoadConfig_Reserved1,\r\n JclLoadConfig_EditList,\r\n JclLoadConfig_Reserved { TODO : extend to the new fields? }\r\n );\r\n\r\n TJclPeFileProperties = record\r\n Size: DWORD;\r\n CreationTime: TDateTime;\r\n LastAccessTime: TDateTime;\r\n LastWriteTime: TDateTime;\r\n Attributes: Integer;\r\n end;\r\n\r\n TJclPeImageStatus = (stNotLoaded, stOk, stNotPE, stNotSupported, stNotFound, stError);\r\n TJclPeTarget = (taUnknown, taWin32, taWin64);\r\n\r\n TJclPeImage = class(TObject)\r\n private\r\n FAttachedImage: Boolean;\r\n FCertificateList: TJclPeCertificateList;\r\n FCLRHeader: TJclPeCLRHeader;\r\n FDebugList: TJclPeDebugList;\r\n FFileName: TFileName;\r\n FImageSections: TStringList;\r\n FLoadedImage: TLoadedImage;\r\n FExportList: TJclPeExportFuncList;\r\n FImportList: TJclPeImportList;\r\n FNoExceptions: Boolean;\r\n FReadOnlyAccess: Boolean;\r\n FRelocationList: TJclPeRelocList;\r\n FResourceList: TJclPeRootResourceList;\r\n FResourceVA: TJclAddr;\r\n FStatus: TJclPeImageStatus;\r\n FTarget: TJclPeTarget;\r\n FVersionInfo: TJclFileVersionInfo;\r\n FStringTable: TStringList;\r\n function GetCertificateList: TJclPeCertificateList;\r\n function GetCLRHeader: TJclPeCLRHeader;\r\n function GetDebugList: TJclPeDebugList;\r\n function GetDescription: string;\r\n function GetDirectories(Directory: Word): TImageDataDirectory;\r\n function GetDirectoryExists(Directory: Word): Boolean;\r\n function GetExportList: TJclPeExportFuncList;\r\n function GetFileProperties: TJclPeFileProperties;\r\n function GetImageSectionCount: Integer;\r\n function GetImageSectionHeaders(Index: Integer): TImageSectionHeader;\r\n function GetImageSectionNames(Index: Integer): string;\r\n function GetImageSectionNameFromRva(const Rva: DWORD): string;\r\n function GetImportList: TJclPeImportList;\r\n function GetHeaderValues(Index: TJclPeHeader): string;\r\n function GetLoadConfigValues(Index: TJclLoadConfig): string;\r\n function GetMappedAddress: TJclAddr;\r\n function GetOptionalHeader32: TImageOptionalHeader32;\r\n function GetOptionalHeader64: TImageOptionalHeader64;\r\n function GetRelocationList: TJclPeRelocList;\r\n function GetResourceList: TJclPeRootResourceList;\r\n function GetUnusedHeaderBytes: TImageDataDirectory;\r\n function GetVersionInfo: TJclFileVersionInfo;\r\n function GetVersionInfoAvailable: Boolean;\r\n procedure ReadImageSections;\r\n procedure ReadStringTable;\r\n procedure SetFileName(const Value: TFileName);\r\n function GetStringTableCount: Integer;\r\n function GetStringTableItem(Index: Integer): string;\r\n function GetImageSectionFullNames(Index: Integer): string;\r\n protected\r\n procedure AfterOpen; dynamic;\r\n procedure CheckNotAttached;\r\n procedure Clear; dynamic;\r\n function ExpandModuleName(const ModuleName: string): TFileName;\r\n procedure RaiseStatusException;\r\n function ResourceItemCreate(AEntry: PImageResourceDirectoryEntry;\r\n AParentItem: TJclPeResourceItem): TJclPeResourceItem; virtual;\r\n function ResourceListCreate(ADirectory: PImageResourceDirectory;\r\n AParentItem: TJclPeResourceItem): TJclPeResourceList; virtual;\r\n property NoExceptions: Boolean read FNoExceptions;\r\n public\r\n constructor Create(ANoExceptions: Boolean = False); virtual;\r\n destructor Destroy; override;\r\n procedure AttachLoadedModule(const Handle: HMODULE);\r\n function CalculateCheckSum: DWORD;\r\n function DirectoryEntryToData(Directory: Word): Pointer;\r\n function GetSectionHeader(const SectionName: string; out Header: PImageSectionHeader): Boolean;\r\n function GetSectionName(Header: PImageSectionHeader): string;\r\n function GetNameInStringTable(Offset: ULONG): string;\r\n function IsBrokenFormat: Boolean;\r\n function IsCLR: Boolean;\r\n function IsSystemImage: Boolean;\r\n // RVA are always DWORD\r\n function RawToVa(Raw: DWORD): Pointer; overload;\r\n function RvaToSection(Rva: DWORD): PImageSectionHeader; overload;\r\n function RvaToVa(Rva: DWORD): Pointer; overload;\r\n function RvaToVaEx(Rva: DWORD): Pointer; overload;\r\n function StatusOK: Boolean;\r\n procedure TryGetNamesForOrdinalImports;\r\n function VerifyCheckSum: Boolean;\r\n class function DebugTypeNames(DebugType: DWORD): string;\r\n class function DirectoryNames(Directory: Word): string;\r\n class function ExpandBySearchPath(const ModuleName, BasePath: string): TFileName;\r\n class function HeaderNames(Index: TJclPeHeader): string;\r\n class function LoadConfigNames(Index: TJclLoadConfig): string;\r\n class function ShortSectionInfo(Characteristics: DWORD): string;\r\n class function DateTimeToStamp(const DateTime: TDateTime): DWORD;\r\n class function StampToDateTime(TimeDateStamp: DWORD): TDateTime;\r\n property AttachedImage: Boolean read FAttachedImage;\r\n property CertificateList: TJclPeCertificateList read GetCertificateList;\r\n property CLRHeader: TJclPeCLRHeader read GetCLRHeader;\r\n property DebugList: TJclPeDebugList read GetDebugList;\r\n property Description: string read GetDescription;\r\n property Directories[Directory: Word]: TImageDataDirectory read GetDirectories;\r\n property DirectoryExists[Directory: Word]: Boolean read GetDirectoryExists;\r\n property ExportList: TJclPeExportFuncList read GetExportList;\r\n property FileName: TFileName read FFileName write SetFileName;\r\n property FileProperties: TJclPeFileProperties read GetFileProperties;\r\n property HeaderValues[Index: TJclPeHeader]: string read GetHeaderValues;\r\n property ImageSectionCount: Integer read GetImageSectionCount;\r\n property ImageSectionHeaders[Index: Integer]: TImageSectionHeader read GetImageSectionHeaders;\r\n property ImageSectionNames[Index: Integer]: string read GetImageSectionNames;\r\n property ImageSectionFullNames[Index: Integer]: string read GetImageSectionFullNames;\r\n property ImageSectionNameFromRva[const Rva: DWORD]: string read GetImageSectionNameFromRva;\r\n property ImportList: TJclPeImportList read GetImportList;\r\n property LoadConfigValues[Index: TJclLoadConfig]: string read GetLoadConfigValues;\r\n property LoadedImage: TLoadedImage read FLoadedImage;\r\n property MappedAddress: TJclAddr read GetMappedAddress;\r\n property StringTableCount: Integer read GetStringTableCount;\r\n property StringTable[Index: Integer]: string read GetStringTableItem;\r\n // use the following properties\r\n // property OptionalHeader: TImageOptionalHeader\r\n property OptionalHeader32: TImageOptionalHeader32 read GetOptionalHeader32;\r\n property OptionalHeader64: TImageOptionalHeader64 read GetOptionalHeader64;\r\n property ReadOnlyAccess: Boolean read FReadOnlyAccess write FReadOnlyAccess;\r\n property RelocationList: TJclPeRelocList read GetRelocationList;\r\n property ResourceVA: TJclAddr read FResourceVA;\r\n property ResourceList: TJclPeRootResourceList read GetResourceList;\r\n property Status: TJclPeImageStatus read FStatus;\r\n property Target: TJclPeTarget read FTarget;\r\n property UnusedHeaderBytes: TImageDataDirectory read GetUnusedHeaderBytes;\r\n property VersionInfo: TJclFileVersionInfo read GetVersionInfo;\r\n property VersionInfoAvailable: Boolean read GetVersionInfoAvailable;\r\n end;\r\n\r\n {$IFDEF BORLAND}\r\n TJclPeBorImage = class;\r\n\r\n TJclPeBorImagesCache = class(TJclPeImagesCache)\r\n private\r\n function GetImages(const FileName: TFileName): TJclPeBorImage;\r\n protected\r\n function GetPeImageClass: TJclPeImageClass; override;\r\n public\r\n property Images[const FileName: TFileName]: TJclPeBorImage read GetImages; default;\r\n end;\r\n\r\n // Borland Delphi PE Image specific information\r\n TJclPePackageInfo = class(TObject)\r\n private\r\n FAvailable: Boolean;\r\n FContains: TStringList;\r\n FDcpName: string;\r\n FRequires: TStringList;\r\n FFlags: Integer;\r\n FDescription: string;\r\n FEnsureExtension: Boolean;\r\n FSorted: Boolean;\r\n function GetContains: TStrings;\r\n function GetContainsCount: Integer;\r\n function GetContainsFlags(Index: Integer): Byte;\r\n function GetContainsNames(Index: Integer): string;\r\n function GetRequires: TStrings;\r\n function GetRequiresCount: Integer;\r\n function GetRequiresNames(Index: Integer): string;\r\n protected\r\n procedure ReadPackageInfo(ALibHandle: THandle);\r\n procedure SetDcpName(const Value: string);\r\n public\r\n constructor Create(ALibHandle: THandle);\r\n destructor Destroy; override;\r\n class function PackageModuleTypeToString(Flags: Cardinal): string;\r\n class function PackageOptionsToString(Flags: Cardinal): string;\r\n class function ProducerToString(Flags: Cardinal): string;\r\n class function UnitInfoFlagsToString(UnitFlags: Byte): string;\r\n property Available: Boolean read FAvailable;\r\n property Contains: TStrings read GetContains;\r\n property ContainsCount: Integer read GetContainsCount;\r\n property ContainsNames[Index: Integer]: string read GetContainsNames;\r\n property ContainsFlags[Index: Integer]: Byte read GetContainsFlags;\r\n property Description: string read FDescription;\r\n property DcpName: string read FDcpName;\r\n property EnsureExtension: Boolean read FEnsureExtension write FEnsureExtension;\r\n property Flags: Integer read FFlags;\r\n property Requires: TStrings read GetRequires;\r\n property RequiresCount: Integer read GetRequiresCount;\r\n property RequiresNames[Index: Integer]: string read GetRequiresNames;\r\n property Sorted: Boolean read FSorted write FSorted;\r\n end;\r\n\r\n TJclPeBorForm = class(TObject)\r\n private\r\n FFormFlags: TFilerFlags;\r\n FFormClassName: string;\r\n FFormObjectName: string;\r\n FFormPosition: Integer;\r\n FResItem: TJclPeResourceItem;\r\n function GetDisplayName: string;\r\n public\r\n constructor Create(AResItem: TJclPeResourceItem; AFormFlags: TFilerFlags;\r\n AFormPosition: Integer; const AFormClassName, AFormObjectName: string);\r\n procedure ConvertFormToText(const Stream: TStream); overload;\r\n procedure ConvertFormToText(const Strings: TStrings); overload;\r\n property FormClassName: string read FFormClassName;\r\n property FormFlags: TFilerFlags read FFormFlags;\r\n property FormObjectName: string read FFormObjectName;\r\n property FormPosition: Integer read FFormPosition;\r\n property DisplayName: string read GetDisplayName;\r\n property ResItem: TJclPeResourceItem read FResItem;\r\n end;\r\n\r\n TJclPeBorImage = class(TJclPeImage)\r\n private\r\n FForms: TObjectList;\r\n FIsPackage: Boolean;\r\n FIsBorlandImage: Boolean;\r\n FLibHandle: THandle;\r\n FPackageInfo: TJclPePackageInfo;\r\n FPackageInfoSorted: Boolean;\r\n FPackageCompilerVersion: Integer;\r\n function GetFormCount: Integer;\r\n function GetForms(Index: Integer): TJclPeBorForm;\r\n function GetFormFromName(const FormClassName: string): TJclPeBorForm;\r\n function GetLibHandle: THandle;\r\n function GetPackageCompilerVersion: Integer;\r\n function GetPackageInfo: TJclPePackageInfo;\r\n protected\r\n procedure AfterOpen; override;\r\n procedure Clear; override;\r\n procedure CreateFormsList;\r\n public\r\n constructor Create(ANoExceptions: Boolean = False); override;\r\n destructor Destroy; override;\r\n function DependedPackages(List: TStrings; FullPathName, Descriptions: Boolean): Boolean;\r\n function FreeLibHandle: Boolean;\r\n property Forms[Index: Integer]: TJclPeBorForm read GetForms;\r\n property FormCount: Integer read GetFormCount;\r\n property FormFromName[const FormClassName: string]: TJclPeBorForm read GetFormFromName;\r\n property IsBorlandImage: Boolean read FIsBorlandImage;\r\n property IsPackage: Boolean read FIsPackage;\r\n property LibHandle: THandle read GetLibHandle;\r\n property PackageCompilerVersion: Integer read GetPackageCompilerVersion;\r\n property PackageInfo: TJclPePackageInfo read GetPackageInfo;\r\n property PackageInfoSorted: Boolean read FPackageInfoSorted write FPackageInfoSorted;\r\n end;\r\n {$ENDIF BORLAND}\r\n\r\n // Threaded function search\r\n TJclPeNameSearchOption = (seImports, seDelayImports, seBoundImports, seExports);\r\n TJclPeNameSearchOptions = set of TJclPeNameSearchOption;\r\n\r\n TJclPeNameSearchNotifyEvent = procedure (Sender: TObject; PeImage: TJclPeImage;\r\n var Process: Boolean) of object;\r\n TJclPeNameSearchFoundEvent = procedure (Sender: TObject; const FileName: TFileName;\r\n const FunctionName: string; Option: TJclPeNameSearchOption) of object;\r\n\r\n TJclPeNameSearch = class(TThread)\r\n private\r\n F_FileName: TFileName;\r\n F_FunctionName: string;\r\n F_Option: TJclPeNameSearchOption;\r\n F_Process: Boolean;\r\n FFunctionName: string;\r\n FOptions: TJclPeNameSearchOptions;\r\n FPath: string;\r\n FPeImage: TJclPeImage;\r\n FOnFound: TJclPeNameSearchFoundEvent;\r\n FOnProcessFile: TJclPeNameSearchNotifyEvent;\r\n protected\r\n function CompareName(const FunctionName, ComparedName: string): Boolean; virtual;\r\n procedure DoFound;\r\n procedure DoProcessFile;\r\n procedure Execute; override;\r\n public\r\n constructor Create(const FunctionName, Path: string; Options: TJclPeNameSearchOptions = [seImports, seExports]);\r\n procedure Start;\r\n property OnFound: TJclPeNameSearchFoundEvent read FOnFound write FOnFound;\r\n property OnProcessFile: TJclPeNameSearchNotifyEvent read FOnProcessFile write FOnProcessFile;\r\n end;\r\n\r\n// PE Image miscellaneous functions\r\ntype\r\n TJclRebaseImageInfo32 = record\r\n OldImageSize: DWORD;\r\n OldImageBase: TJclAddr32;\r\n NewImageSize: DWORD;\r\n NewImageBase: TJclAddr32;\r\n end;\r\n TJclRebaseImageInfo64 = record\r\n OldImageSize: DWORD;\r\n OldImageBase: TJclAddr64;\r\n NewImageSize: DWORD;\r\n NewImageBase: TJclAddr64;\r\n end;\r\n\r\n // renamed\r\n // TJclRebaseImageInfo = TJclRebaseImageInfo32;\r\n\r\n{ Image validity }\r\n\r\nfunction IsValidPeFile(const FileName: TFileName): Boolean;\r\n\r\n// use PeGetNtHeaders32 for backward compatibility\r\n// function PeGetNtHeaders(const FileName: TFileName; out NtHeaders: TImageNtHeaders): Boolean;\r\nfunction PeGetNtHeaders32(const FileName: TFileName; out NtHeaders: TImageNtHeaders32): Boolean;\r\nfunction PeGetNtHeaders64(const FileName: TFileName; out NtHeaders: TImageNtHeaders64): Boolean;\r\n\r\n{ Image modifications }\r\n\r\nfunction PeCreateNameHintTable(const FileName: TFileName): Boolean;\r\n\r\n// use PeRebaseImage32\r\n//function PeRebaseImage(const ImageName: TFileName; NewBase: DWORD = 0; TimeStamp: DWORD = 0;\r\n// MaxNewSize: DWORD = 0): TJclRebaseImageInfo;\r\nfunction PeRebaseImage32(const ImageName: TFileName; NewBase: TJclAddr32 = 0; TimeStamp: DWORD = 0;\r\n MaxNewSize: DWORD = 0): TJclRebaseImageInfo32;\r\nfunction PeRebaseImage64(const ImageName: TFileName; NewBase: TJclAddr64 = 0; TimeStamp: DWORD = 0;\r\n MaxNewSize: DWORD = 0): TJclRebaseImageInfo64;\r\n\r\nfunction PeUpdateLinkerTimeStamp(const FileName: TFileName; const Time: TDateTime): Boolean;\r\nfunction PeReadLinkerTimeStamp(const FileName: TFileName): TDateTime;\r\n\r\nfunction PeInsertSection(const FileName: TFileName; SectionStream: TStream; SectionName: string): Boolean;\r\n\r\n{ Image Checksum }\r\n\r\nfunction PeVerifyCheckSum(const FileName: TFileName): Boolean;\r\nfunction PeClearCheckSum(const FileName: TFileName): Boolean;\r\nfunction PeUpdateCheckSum(const FileName: TFileName): Boolean;\r\n\r\n// Various simple PE Image searching and listing routines\r\n{ Exports searching }\r\n\r\nfunction PeDoesExportFunction(const FileName: TFileName; const FunctionName: string;\r\n Options: TJclSmartCompOptions = []): Boolean;\r\n\r\nfunction PeIsExportFunctionForwardedEx(const FileName: TFileName; const FunctionName: string;\r\n out ForwardedName: string; Options: TJclSmartCompOptions = []): Boolean;\r\nfunction PeIsExportFunctionForwarded(const FileName: TFileName; const FunctionName: string;\r\n Options: TJclSmartCompOptions = []): Boolean;\r\n\r\n{ Imports searching }\r\n\r\nfunction PeDoesImportFunction(const FileName: TFileName; const FunctionName: string;\r\n const LibraryName: string = ''; Options: TJclSmartCompOptions = []): Boolean;\r\n\r\nfunction PeDoesImportLibrary(const FileName: TFileName; const LibraryName: string;\r\n Recursive: Boolean = False): Boolean;\r\n\r\n{ Imports listing }\r\n\r\nfunction PeImportedLibraries(const FileName: TFileName; const LibrariesList: TStrings;\r\n Recursive: Boolean = False; FullPathName: Boolean = False): Boolean;\r\n\r\nfunction PeImportedFunctions(const FileName: TFileName; const FunctionsList: TStrings;\r\n const LibraryName: string = ''; IncludeLibNames: Boolean = False): Boolean;\r\n\r\n{ Exports listing }\r\n\r\nfunction PeExportedFunctions(const FileName: TFileName; const FunctionsList: TStrings): Boolean;\r\nfunction PeExportedNames(const FileName: TFileName; const FunctionsList: TStrings): Boolean;\r\nfunction PeExportedVariables(const FileName: TFileName; const FunctionsList: TStrings): Boolean;\r\n\r\n{ Resources listing }\r\n\r\nfunction PeResourceKindNames(const FileName: TFileName; ResourceType: TJclPeResourceKind;\r\n const NamesList: TStrings): Boolean;\r\n\r\n{ Borland packages specific }\r\n\r\n{$IFDEF BORLAND}\r\nfunction PeBorFormNames(const FileName: TFileName; const NamesList: TStrings): Boolean;\r\n\r\nfunction PeBorDependedPackages(const FileName: TFileName; PackagesList: TStrings;\r\n FullPathName, Descriptions: Boolean): Boolean;\r\n{$ENDIF BORLAND}\r\n\r\n// Missing imports checking routines\r\nfunction PeFindMissingImports(const FileName: TFileName; MissingImportsList: TStrings): Boolean; overload;\r\nfunction PeFindMissingImports(RequiredImportsList, MissingImportsList: TStrings): Boolean; overload;\r\n\r\nfunction PeCreateRequiredImportList(const FileName: TFileName; RequiredImportsList: TStrings): Boolean;\r\n\r\n// Mapped or loaded image related routines\r\n// use PeMapImgNtHeaders32\r\n// function PeMapImgNtHeaders(const BaseAddress: Pointer): PImageNtHeaders;\r\nfunction PeMapImgNtHeaders32(const BaseAddress: Pointer): PImageNtHeaders32; overload;\r\nfunction PeMapImgNtHeaders32(Stream: TStream; const BasePosition: Int64; out NtHeaders32: TImageNtHeaders32): Int64; overload;\r\nfunction PeMapImgNtHeaders64(const BaseAddress: Pointer): PImageNtHeaders64; overload;\r\nfunction PeMapImgNtHeaders64(Stream: TStream; const BasePosition: Int64; out NtHeaders64: TImageNtHeaders64): Int64; overload;\r\n\r\nfunction PeMapImgLibraryName(const BaseAddress: Pointer): string;\r\nfunction PeMapImgLibraryName32(const BaseAddress: Pointer): string;\r\nfunction PeMapImgLibraryName64(const BaseAddress: Pointer): string;\r\n\r\nfunction PeMapImgSize(const BaseAddress: Pointer): DWORD; overload;\r\nfunction PeMapImgSize(Stream: TStream; const BasePosition: Int64): DWORD; overload;\r\nfunction PeMapImgSize32(const BaseAddress: Pointer): DWORD; overload;\r\nfunction PeMapImgSize32(Stream: TStream; const BasePosition: Int64): DWORD; overload;\r\nfunction PeMapImgSize64(const BaseAddress: Pointer): DWORD; overload;\r\nfunction PeMapImgSize64(Stream: TStream; const BasePosition: Int64): DWORD; overload;\r\n\r\nfunction PeMapImgTarget(const BaseAddress: Pointer): TJclPeTarget; overload;\r\nfunction PeMapImgTarget(Stream: TStream; const BasePosition: Int64): TJclPeTarget; overload;\r\n\r\ntype\r\n TImageSectionHeaderArray = array of TImageSectionHeader;\r\n\r\n// use PeMapImgSections32\r\n// function PeMapImgSections(NtHeaders: PImageNtHeaders): PImageSectionHeader;\r\nfunction PeMapImgSections32(NtHeaders: PImageNtHeaders32): PImageSectionHeader; overload;\r\nfunction PeMapImgSections32(Stream: TStream; const NtHeaders32Position: Int64; const NtHeaders32: TImageNtHeaders32;\r\n out ImageSectionHeaders: TImageSectionHeaderArray): Int64; overload;\r\nfunction PeMapImgSections64(NtHeaders: PImageNtHeaders64): PImageSectionHeader; overload;\r\nfunction PeMapImgSections64(Stream: TStream; const NtHeaders64Position: Int64; const NtHeaders64: TImageNtHeaders64;\r\n out ImageSectionHeaders: TImageSectionHeaderArray): Int64; overload;\r\n\r\n// use PeMapImgFindSection32\r\n// function PeMapImgFindSection(NtHeaders: PImageNtHeaders;\r\n// const SectionName: string): PImageSectionHeader;\r\nfunction PeMapImgFindSection32(NtHeaders: PImageNtHeaders32;\r\n const SectionName: string): PImageSectionHeader;\r\nfunction PeMapImgFindSection64(NtHeaders: PImageNtHeaders64;\r\n const SectionName: string): PImageSectionHeader;\r\nfunction PeMapImgFindSection(const ImageSectionHeaders: TImageSectionHeaderArray;\r\n const SectionName: string): SizeInt;\r\n\r\nfunction PeMapImgFindSectionFromModule(const BaseAddress: Pointer;\r\n const SectionName: string): PImageSectionHeader;\r\n\r\nfunction PeMapImgExportedVariables(const Module: HMODULE; const VariablesList: TStrings): Boolean;\r\n\r\nfunction PeMapImgResolvePackageThunk(Address: Pointer): Pointer;\r\n\r\nfunction PeMapFindResource(const Module: HMODULE; const ResourceType: PChar;\r\n const ResourceName: string): Pointer;\r\n\r\ntype\r\n TJclPeSectionStream = class(TCustomMemoryStream)\r\n private\r\n FInstance: HMODULE;\r\n FSectionHeader: TImageSectionHeader;\r\n procedure Initialize(Instance: HMODULE; const ASectionName: string);\r\n public\r\n constructor Create(Instance: HMODULE; const ASectionName: string);\r\n function Write(const Buffer; Count: Longint): Longint; override;\r\n property Instance: HMODULE read FInstance;\r\n property SectionHeader: TImageSectionHeader read FSectionHeader;\r\n end;\r\n\r\n// API hooking classes\r\ntype\r\n TJclPeMapImgHookItem = class(TObject)\r\n private\r\n FBaseAddress: Pointer;\r\n FFunctionName: string;\r\n FModuleName: string;\r\n FNewAddress: Pointer;\r\n FOriginalAddress: Pointer;\r\n FList: TObjectList;\r\n protected\r\n function InternalUnhook: Boolean;\r\n public\r\n constructor Create(AList: TObjectList; const AFunctionName: string;\r\n const AModuleName: string; ABaseAddress, ANewAddress, AOriginalAddress: Pointer);\r\n destructor Destroy; override;\r\n function Unhook: Boolean;\r\n property BaseAddress: Pointer read FBaseAddress;\r\n property FunctionName: string read FFunctionName;\r\n property ModuleName: string read FModuleName;\r\n property NewAddress: Pointer read FNewAddress;\r\n property OriginalAddress: Pointer read FOriginalAddress;\r\n end;\r\n\r\n TJclPeMapImgHooks = class(TObjectList)\r\n private\r\n function GetItems(Index: Integer): TJclPeMapImgHookItem;\r\n function GetItemFromOriginalAddress(OriginalAddress: Pointer): TJclPeMapImgHookItem;\r\n function GetItemFromNewAddress(NewAddress: Pointer): TJclPeMapImgHookItem;\r\n public\r\n function HookImport(Base: Pointer; const ModuleName: string;\r\n const FunctionName: string; NewAddress: Pointer; var OriginalAddress: Pointer): Boolean;\r\n class function IsWin9xDebugThunk(P: Pointer): Boolean;\r\n class function ReplaceImport(Base: Pointer; const ModuleName: string; FromProc, ToProc: Pointer): Boolean;\r\n class function SystemBase: Pointer;\r\n procedure UnhookAll;\r\n function UnhookByNewAddress(NewAddress: Pointer): Boolean;\r\n procedure UnhookByBaseAddress(BaseAddress: Pointer);\r\n property Items[Index: Integer]: TJclPeMapImgHookItem read GetItems; default;\r\n property ItemFromOriginalAddress[OriginalAddress: Pointer]: TJclPeMapImgHookItem read GetItemFromOriginalAddress;\r\n property ItemFromNewAddress[NewAddress: Pointer]: TJclPeMapImgHookItem read GetItemFromNewAddress;\r\n end;\r\n\r\n// Image access under a debbuger\r\nfunction PeDbgImgNtHeaders32(ProcessHandle: THandle; BaseAddress: TJclAddr32;\r\n var NtHeaders: TImageNtHeaders32): Boolean;\r\n// TODO 64 bit version\r\n//function PeDbgImgNtHeaders64(ProcessHandle: THandle; BaseAddress: TJclAddr64;\r\n// var NtHeaders: TImageNtHeaders64): Boolean;\r\n\r\nfunction PeDbgImgLibraryName32(ProcessHandle: THandle; BaseAddress: TJclAddr32;\r\n var Name: string): Boolean;\r\n//function PeDbgImgLibraryName64(ProcessHandle: THandle; BaseAddress: TJclAddr64;\r\n// var Name: string): Boolean;\r\n\r\n// Borland BPL packages name unmangling\r\ntype\r\n TJclBorUmSymbolKind = (skData, skFunction, skConstructor, skDestructor, skRTTI, skVTable);\r\n TJclBorUmSymbolModifier = (smQualified, smLinkProc);\r\n TJclBorUmSymbolModifiers = set of TJclBorUmSymbolModifier;\r\n TJclBorUmDescription = record\r\n Kind: TJclBorUmSymbolKind;\r\n Modifiers: TJclBorUmSymbolModifiers;\r\n end;\r\n TJclBorUmResult = (urOk, urNotMangled, urMicrosoft, urError);\r\n TJclPeUmResult = (umNotMangled, umBorland, umMicrosoft);\r\n\r\nfunction PeBorUnmangleName(const Name: string; out Unmangled: string;\r\n out Description: TJclBorUmDescription; out BasePos: Integer): TJclBorUmResult; overload;\r\nfunction PeBorUnmangleName(const Name: string; out Unmangled: string;\r\n out Description: TJclBorUmDescription): TJclBorUmResult; overload;\r\nfunction PeBorUnmangleName(const Name: string; out Unmangled: string): TJclBorUmResult; overload;\r\nfunction PeBorUnmangleName(const Name: string): string; overload;\r\n\r\nfunction PeIsNameMangled(const Name: string): TJclPeUmResult;\r\n\r\nfunction UndecorateSymbolName(const DecoratedName: string; out UnMangled: string; Flags: DWORD): Boolean;\r\nfunction PeUnmangleName(const Name: string; out Unmangled: string): TJclPeUmResult;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jcl.svn.sourceforge.net/svnroot/jcl/tags/JCL-2.4-Build4571/jcl/source/windows/JclPeImage.pas $';\r\n Revision: '$Revision: 3861 $';\r\n Date: '$Date: 2012-09-04 16:08:04 +0200 (mar. 04 sept. 2012) $';\r\n LogPath: 'JCL\\source\\windows';\r\n Extra: '';\r\n Data: nil\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n {$IFDEF HAS_UNITSCOPE}\r\n System.RTLConsts,\r\n System.Types, // for inlining TList.Remove\r\n {$IFDEF HAS_UNIT_CHARACTER}\r\n System.Character,\r\n {$ENDIF HAS_UNIT_CHARACTER}\r\n {$ELSE ~HAS_UNITSCOPE}\r\n RTLConsts,\r\n {$IFDEF HAS_UNIT_CHARACTER}\r\n Character,\r\n {$ENDIF HAS_UNIT_CHARACTER}\r\n {$ENDIF ~HAS_UNITSCOPE}\r\n JclLogic, JclResources, JclSysUtils, JclStrings, JclStringConversions;\r\n\r\nconst\r\n MANIFESTExtension = '.manifest';\r\n\r\n DebugSectionName = '.debug';\r\n ReadOnlySectionName = '.rdata';\r\n\r\n BinaryExtensionLibrary = '.dll';\r\n\r\n {$IFDEF BORLAND}\r\n CompilerExtensionDCP = '.dcp';\r\n BinaryExtensionPackage = '.bpl';\r\n\r\n PackageInfoResName = 'PACKAGEINFO';\r\n DescriptionResName = 'DESCRIPTION';\r\n PackageOptionsResName = 'PACKAGEOPTIONS';\r\n DVclAlResName = 'DVCLAL';\r\n {$ENDIF BORLAND}\r\n\r\n// Helper routines\r\nfunction AddFlagTextRes(var Text: string; const FlagText: PResStringRec; const Value, Mask: Cardinal): Boolean;\r\nbegin\r\n Result := (Value and Mask <> 0);\r\n if Result then\r\n begin\r\n if Length(Text) > 0 then\r\n Text := Text + ', ';\r\n Text := Text + LoadResString(FlagText);\r\n end;\r\nend;\r\n\r\nfunction CompareResourceName(T1, T2: PChar): Boolean;\r\nvar\r\n Long1, Long2: LongRec;\r\nbegin\r\n {$IFDEF CPU64}\r\n Long1 := LongRec(Int64Rec(T1).Lo);\r\n Long2 := LongRec(Int64Rec(T2).Lo);\r\n if (Int64Rec(T1).Hi = 0) and (Int64Rec(T2).Hi = 0) and (Long1.Hi = 0) and (Long2.Hi = 0) then\r\n {$ENDIF CPU64}\r\n {$IFDEF CPU32}\r\n Long1 := LongRec(T1);\r\n Long2 := LongRec(T2);\r\n if (Long1.Hi = 0) or (Long2.Hi = 0) then\r\n {$ENDIF CPU32}\r\n Result := Long1.Lo = Long2.Lo\r\n else\r\n Result := (StrIComp(T1, T2) = 0);\r\nend;\r\n\r\nfunction CreatePeImage(const FileName: TFileName): TJclPeImage;\r\nbegin\r\n Result := TJclPeImage.Create(True);\r\n Result.FileName := FileName;\r\nend;\r\n\r\nfunction InternalImportedLibraries(const FileName: TFileName;\r\n Recursive, FullPathName: Boolean; ExternalCache: TJclPeImagesCache): TStringList;\r\nvar\r\n Cache: TJclPeImagesCache;\r\n\r\n procedure ProcessLibraries(const AFileName: TFileName);\r\n var\r\n I: Integer;\r\n S: TFileName;\r\n ImportLib: TJclPeImportLibItem;\r\n begin\r\n with Cache[AFileName].ImportList do\r\n for I := 0 to Count - 1 do\r\n begin\r\n ImportLib := Items[I];\r\n if FullPathName then\r\n S := ImportLib.FileName\r\n else\r\n S := TFileName(ImportLib.Name);\r\n if Result.IndexOf(S) = -1 then\r\n begin\r\n Result.Add(S);\r\n if Recursive then\r\n ProcessLibraries(ImportLib.FileName);\r\n end;\r\n end;\r\n end;\r\n\r\nbegin\r\n if ExternalCache = nil then\r\n Cache := TJclPeImagesCache.Create\r\n else\r\n Cache := ExternalCache;\r\n try\r\n Result := TStringList.Create;\r\n try\r\n Result.Sorted := True;\r\n Result.Duplicates := dupIgnore;\r\n ProcessLibraries(FileName);\r\n except\r\n FreeAndNil(Result);\r\n raise;\r\n end;\r\n finally\r\n if ExternalCache = nil then\r\n Cache.Free;\r\n end;\r\nend;\r\n\r\n// Smart name compare function\r\nfunction PeStripFunctionAW(const FunctionName: string): string;\r\nvar\r\n L: Integer;\r\nbegin\r\n Result := FunctionName;\r\n L := Length(Result);\r\n if (L > 1) then\r\n case Result[L] of\r\n 'A', 'W':\r\n if CharIsValidIdentifierLetter(Result[L - 1]) then\r\n Delete(Result, L, 1);\r\n end;\r\nend;\r\n\r\nfunction PeSmartFunctionNameSame(const ComparedName, FunctionName: string;\r\n Options: TJclSmartCompOptions): Boolean;\r\nvar\r\n S: string;\r\nbegin\r\n if scIgnoreCase in Options then\r\n Result := CompareText(FunctionName, ComparedName) = 0\r\n else\r\n Result := (FunctionName = ComparedName);\r\n if (not Result) and not (scSimpleCompare in Options) then\r\n begin\r\n if Length(FunctionName) > 0 then\r\n begin\r\n S := PeStripFunctionAW(FunctionName);\r\n if scIgnoreCase in Options then\r\n Result := CompareText(S, ComparedName) = 0\r\n else\r\n Result := (S = ComparedName);\r\n end\r\n else\r\n Result := False;\r\n end;\r\nend;\r\n\r\n//=== { TJclPeImagesCache } ==================================================\r\n\r\nconstructor TJclPeImagesCache.Create;\r\nbegin\r\n inherited Create;\r\n FList := TStringList.Create;\r\n FList.Sorted := True;\r\n FList.Duplicates := dupIgnore;\r\nend;\r\n\r\ndestructor TJclPeImagesCache.Destroy;\r\nbegin\r\n Clear;\r\n FreeAndNil(FList);\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJclPeImagesCache.Clear;\r\nvar\r\n I: Integer;\r\nbegin\r\n with FList do\r\n for I := 0 to Count - 1 do\r\n Objects[I].Free;\r\n FList.Clear;\r\nend;\r\n\r\nfunction TJclPeImagesCache.GetCount: Integer;\r\nbegin\r\n Result := FList.Count;\r\nend;\r\n\r\nfunction TJclPeImagesCache.GetImages(const FileName: TFileName): TJclPeImage;\r\nvar\r\n I: Integer;\r\nbegin\r\n I := FList.IndexOf(FileName);\r\n if I = -1 then\r\n begin\r\n Result := GetPeImageClass.Create(True);\r\n Result.FileName := FileName;\r\n FList.AddObject(FileName, Result);\r\n end\r\n else\r\n Result := TJclPeImage(FList.Objects[I]);\r\nend;\r\n\r\nfunction TJclPeImagesCache.GetPeImageClass: TJclPeImageClass;\r\nbegin\r\n Result := TJclPeImage;\r\nend;\r\n\r\n//=== { TJclPeImageBaseList } ================================================\r\n\r\nconstructor TJclPeImageBaseList.Create(AImage: TJclPeImage);\r\nbegin\r\n inherited Create(True);\r\n FImage := AImage;\r\nend;\r\n\r\n// Import sort functions\r\n\r\nfunction ImportSortByName(Item1, Item2: Pointer): Integer;\r\nbegin\r\n Result := CompareStr(TJclPeImportFuncItem(Item1).Name, TJclPeImportFuncItem(Item2).Name);\r\n if Result = 0 then\r\n Result := CompareStr(TJclPeImportFuncItem(Item1).ImportLib.Name, TJclPeImportFuncItem(Item2).ImportLib.Name);\r\n if Result = 0 then\r\n Result := TJclPeImportFuncItem(Item1).Ordinal - TJclPeImportFuncItem(Item2).Ordinal;\r\nend;\r\n\r\nfunction ImportSortByNameDESC(Item1, Item2: Pointer): Integer;\r\nbegin\r\n Result := ImportSortByName(Item2, Item1);\r\nend;\r\n\r\nfunction ImportSortByHint(Item1, Item2: Pointer): Integer;\r\nbegin\r\n Result := TJclPeImportFuncItem(Item1).Hint - TJclPeImportFuncItem(Item2).Hint;\r\nend;\r\n\r\nfunction ImportSortByHintDESC(Item1, Item2: Pointer): Integer;\r\nbegin\r\n Result := ImportSortByHint(Item2, Item1);\r\nend;\r\n\r\nfunction ImportSortByDll(Item1, Item2: Pointer): Integer;\r\nbegin\r\n Result := CompareStr(TJclPeImportFuncItem(Item1).ImportLib.Name,\r\n TJclPeImportFuncItem(Item2).ImportLib.Name);\r\n if Result = 0 then\r\n Result := ImportSortByName(Item1, Item2);\r\nend;\r\n\r\nfunction ImportSortByDllDESC(Item1, Item2: Pointer): Integer;\r\nbegin\r\n Result := ImportSortByDll(Item2, Item1);\r\nend;\r\n\r\nfunction ImportSortByOrdinal(Item1, Item2: Pointer): Integer;\r\nbegin\r\n Result := CompareStr(TJclPeImportFuncItem(Item1).ImportLib.Name,\r\n TJclPeImportFuncItem(Item2).ImportLib.Name);\r\n if Result = 0 then\r\n Result := TJclPeImportFuncItem(Item1).Ordinal - TJclPeImportFuncItem(Item2).Ordinal;\r\nend;\r\n\r\nfunction ImportSortByOrdinalDESC(Item1, Item2: Pointer): Integer;\r\nbegin\r\n Result := ImportSortByOrdinal(Item2, Item1);\r\nend;\r\n\r\nfunction GetImportSortFunction(SortType: TJclPeImportSort; Descending: Boolean): TListSortCompare;\r\nconst\r\n SortFunctions: array [TJclPeImportSort, Boolean] of TListSortCompare =\r\n ((ImportSortByName, ImportSortByNameDESC),\r\n (ImportSortByOrdinal, ImportSortByOrdinalDESC),\r\n (ImportSortByHint, ImportSortByHintDESC),\r\n (ImportSortByDll, ImportSortByDllDESC)\r\n );\r\nbegin\r\n Result := SortFunctions[SortType, Descending];\r\nend;\r\n\r\nfunction ImportLibSortByIndex(Item1, Item2: Pointer): Integer;\r\nbegin\r\n Result := TJclPeImportLibItem(Item1).ImportDirectoryIndex -\r\n TJclPeImportLibItem(Item2).ImportDirectoryIndex;\r\nend;\r\n\r\nfunction ImportLibSortByName(Item1, Item2: Pointer): Integer;\r\nbegin\r\n Result := AnsiCompareStr(TJclPeImportLibItem(Item1).Name, TJclPeImportLibItem(Item2).Name);\r\n if Result = 0 then\r\n Result := ImportLibSortByIndex(Item1, Item2);\r\nend;\r\n\r\nfunction GetImportLibSortFunction(SortType: TJclPeImportLibSort): TListSortCompare;\r\nconst\r\n SortFunctions: array [TJclPeImportLibSort] of TListSortCompare =\r\n (ImportLibSortByName, ImportLibSortByIndex);\r\nbegin\r\n Result := SortFunctions[SortType];\r\nend;\r\n\r\n//=== { TJclPeImportFuncItem } ===============================================\r\n\r\nconstructor TJclPeImportFuncItem.Create(AImportLib: TJclPeImportLibItem;\r\n AOrdinal: Word; AHint: Word; const AName: string);\r\nbegin\r\n inherited Create;\r\n FImportLib := AImportLib;\r\n FOrdinal := AOrdinal;\r\n FHint := AHint;\r\n FName := AName;\r\n FResolveCheck := icNotChecked;\r\n FIndirectImportName := False;\r\nend;\r\n\r\nfunction TJclPeImportFuncItem.GetIsByOrdinal: Boolean;\r\nbegin\r\n Result := FOrdinal <> 0;\r\nend;\r\n\r\nprocedure TJclPeImportFuncItem.SetIndirectImportName(const Value: string);\r\nbegin\r\n FName := Value;\r\n FIndirectImportName := True;\r\nend;\r\n\r\nprocedure TJclPeImportFuncItem.SetName(const Value: string);\r\nbegin\r\n FName := Value;\r\n FIndirectImportName := False;\r\nend;\r\n\r\nprocedure TJclPeImportFuncItem.SetResolveCheck(Value: TJclPeResolveCheck);\r\nbegin\r\n FResolveCheck := Value;\r\nend;\r\n\r\n//=== { TJclPeImportLibItem } ================================================\r\n\r\nconstructor TJclPeImportLibItem.Create(AImage: TJclPeImage;\r\n AImportDescriptor: Pointer; AImportKind: TJclPeImportKind; const AName: string;\r\n AThunk: Pointer);\r\nbegin\r\n inherited Create(AImage);\r\n FTotalResolveCheck := icNotChecked;\r\n FImportDescriptor := AImportDescriptor;\r\n FImportKind := AImportKind;\r\n FName := AName;\r\n FThunk := AThunk;\r\n FThunkData := AThunk;\r\nend;\r\n\r\nprocedure TJclPeImportLibItem.CheckImports(ExportImage: TJclPeImage);\r\nvar\r\n I: Integer;\r\n ExportList: TJclPeExportFuncList;\r\nbegin\r\n if ExportImage.StatusOK then\r\n begin\r\n FTotalResolveCheck := icResolved;\r\n ExportList := ExportImage.ExportList;\r\n for I := 0 to Count - 1 do\r\n begin\r\n with Items[I] do\r\n if IsByOrdinal then\r\n begin\r\n if ExportList.OrdinalValid(Ordinal) then\r\n SetResolveCheck(icResolved)\r\n else\r\n begin\r\n SetResolveCheck(icUnresolved);\r\n Self.FTotalResolveCheck := icUnresolved;\r\n end;\r\n end\r\n else\r\n begin\r\n if ExportList.ItemFromName[Items[I].Name] <> nil then\r\n SetResolveCheck(icResolved)\r\n else\r\n begin\r\n SetResolveCheck(icUnresolved);\r\n Self.FTotalResolveCheck := icUnresolved;\r\n end;\r\n end;\r\n end;\r\n end\r\n else\r\n begin\r\n FTotalResolveCheck := icUnresolved;\r\n for I := 0 to Count - 1 do\r\n Items[I].SetResolveCheck(icUnresolved);\r\n end;\r\nend;\r\n\r\nprocedure TJclPeImportLibItem.CreateList;\r\n procedure CreateList32;\r\n var\r\n Thunk32: PImageThunkData32;\r\n OrdinalName: PImageImportByName;\r\n Ordinal, Hint: Word;\r\n Name: PAnsiChar;\r\n ImportName: string;\r\n begin\r\n Thunk32 := PImageThunkData32(FThunk);\r\n while Thunk32^.Function_ <> 0 do\r\n begin\r\n Ordinal := 0;\r\n Hint := 0;\r\n Name := nil;\r\n if Thunk32^.Ordinal and IMAGE_ORDINAL_FLAG32 = 0 then\r\n begin\r\n case ImportKind of\r\n ikImport, ikBoundImport:\r\n begin\r\n OrdinalName := PImageImportByName(Image.RvaToVa(Thunk32^.AddressOfData));\r\n Hint := OrdinalName.Hint;\r\n Name := OrdinalName.Name;\r\n end;\r\n ikDelayImport:\r\n begin\r\n OrdinalName := PImageImportByName(Image.RvaToVaEx(Thunk32^.AddressOfData));\r\n Hint := OrdinalName.Hint;\r\n Name := OrdinalName.Name;\r\n end;\r\n end;\r\n end\r\n else\r\n Ordinal := IMAGE_ORDINAL32(Thunk32^.Ordinal);\r\n if not TryUTF8ToString(Name, ImportName) then\r\n ImportName := string(Name);\r\n Add(TJclPeImportFuncItem.Create(Self, Ordinal, Hint, ImportName));\r\n Inc(Thunk32);\r\n end;\r\n end;\r\n\r\n procedure CreateList64;\r\n var\r\n Thunk64: PImageThunkData64;\r\n OrdinalName: PImageImportByName;\r\n Ordinal, Hint: Word;\r\n Name: PAnsiChar;\r\n ImportName: string;\r\n begin\r\n Thunk64 := PImageThunkData64(FThunk);\r\n while Thunk64^.Function_ <> 0 do\r\n begin\r\n Ordinal := 0;\r\n Hint := 0;\r\n Name := nil;\r\n if Thunk64^.Ordinal and IMAGE_ORDINAL_FLAG64 = 0 then\r\n begin\r\n case ImportKind of\r\n ikImport, ikBoundImport:\r\n begin\r\n OrdinalName := PImageImportByName(Image.RvaToVa(Thunk64^.AddressOfData));\r\n Hint := OrdinalName.Hint;\r\n Name := OrdinalName.Name;\r\n end;\r\n ikDelayImport:\r\n begin\r\n OrdinalName := PImageImportByName(Image.RvaToVaEx(Thunk64^.AddressOfData));\r\n Hint := OrdinalName.Hint;\r\n Name := OrdinalName.Name;\r\n end;\r\n end;\r\n end\r\n else\r\n Ordinal := IMAGE_ORDINAL64(Thunk64^.Ordinal);\r\n if not TryUTF8ToString(Name, ImportName) then\r\n ImportName := string(Name);\r\n Add(TJclPeImportFuncItem.Create(Self, Ordinal, Hint, ImportName));\r\n Inc(Thunk64);\r\n end;\r\n end;\r\nbegin\r\n if FThunk = nil then\r\n Exit;\r\n\r\n case Image.Target of\r\n taWin32:\r\n CreateList32;\r\n taWin64:\r\n CreateList64;\r\n end;\r\n\r\n FThunk := nil;\r\nend;\r\n\r\nfunction TJclPeImportLibItem.GetCount: Integer;\r\nbegin\r\n if FThunk <> nil then\r\n CreateList;\r\n Result := inherited Count;\r\nend;\r\n\r\nfunction TJclPeImportLibItem.GetFileName: TFileName;\r\nbegin\r\n Result := Image.ExpandModuleName(Name);\r\nend;\r\n\r\nfunction TJclPeImportLibItem.GetItems(Index: Integer): TJclPeImportFuncItem;\r\nbegin\r\n Result := TJclPeImportFuncItem(Get(Index));\r\nend;\r\n\r\nfunction TJclPeImportLibItem.GetName: string;\r\nbegin\r\n Result := AnsiLowerCase(OriginalName);\r\nend;\r\n\r\nfunction TJclPeImportLibItem.GetThunkData32: PImageThunkData32;\r\nbegin\r\n if Image.Target = taWin32 then\r\n Result := FThunkData\r\n else\r\n Result := nil;\r\nend;\r\n\r\nfunction TJclPeImportLibItem.GetThunkData64: PImageThunkData64;\r\nbegin\r\n if Image.Target = taWin64 then\r\n Result := FThunkData\r\n else\r\n Result := nil;\r\nend;\r\n\r\nprocedure TJclPeImportLibItem.SetImportDirectoryIndex(Value: Integer);\r\nbegin\r\n FImportDirectoryIndex := Value;\r\nend;\r\n\r\nprocedure TJclPeImportLibItem.SetImportKind(Value: TJclPeImportKind);\r\nbegin\r\n FImportKind := Value;\r\nend;\r\n\r\nprocedure TJclPeImportLibItem.SetSorted(Value: Boolean);\r\nbegin\r\n FSorted := Value;\r\nend;\r\n\r\nprocedure TJclPeImportLibItem.SetThunk(Value: Pointer);\r\nbegin\r\n FThunk := Value;\r\n FThunkData := Value;\r\nend;\r\n\r\nprocedure TJclPeImportLibItem.SortList(SortType: TJclPeImportSort; Descending: Boolean);\r\nbegin\r\n if not FSorted or (SortType <> FLastSortType) or (Descending <> FLastSortDescending) then\r\n begin\r\n GetCount; // create list if it wasn't created\r\n Sort(GetImportSortFunction(SortType, Descending));\r\n FLastSortType := SortType;\r\n FLastSortDescending := Descending;\r\n FSorted := True;\r\n end;\r\nend;\r\n\r\n//=== { TJclPeImportList } ===================================================\r\n\r\nconstructor TJclPeImportList.Create(AImage: TJclPeImage);\r\nbegin\r\n inherited Create(AImage);\r\n FAllItemsList := TList.Create;\r\n FAllItemsList.Capacity := 256;\r\n FUniqueNamesList := TStringList.Create;\r\n FUniqueNamesList.Sorted := True;\r\n FUniqueNamesList.Duplicates := dupIgnore;\r\n FLastAllSortType := isName;\r\n FLastAllSortDescending := False;\r\n CreateList;\r\nend;\r\n\r\ndestructor TJclPeImportList.Destroy;\r\nvar\r\n I: Integer;\r\nbegin\r\n FreeAndNil(FAllItemsList);\r\n FreeAndNil(FUniqueNamesList);\r\n for I := 0 to Length(FparallelImportTable) - 1 do\r\n FreeMem(FparallelImportTable[I]);\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJclPeImportList.CheckImports(PeImageCache: TJclPeImagesCache);\r\nvar\r\n I: Integer;\r\n ExportPeImage: TJclPeImage;\r\nbegin\r\n Image.CheckNotAttached;\r\n if PeImageCache <> nil then\r\n ExportPeImage := nil // to make the compiler happy\r\n else\r\n ExportPeImage := TJclPeImage.Create(True);\r\n try\r\n for I := 0 to Count - 1 do\r\n if Items[I].TotalResolveCheck = icNotChecked then\r\n begin\r\n if PeImageCache <> nil then\r\n ExportPeImage := PeImageCache[Items[I].FileName]\r\n else\r\n ExportPeImage.FileName := Items[I].FileName;\r\n ExportPeImage.ExportList.PrepareForFastNameSearch;\r\n Items[I].CheckImports(ExportPeImage);\r\n end;\r\n finally\r\n if PeImageCache = nil then\r\n ExportPeImage.Free;\r\n end;\r\nend;\r\n\r\nprocedure TJclPeImportList.CreateList;\r\n procedure CreateDelayImportList32(DelayImportDesc: PImgDelayDescrV1);\r\n var\r\n LibItem: TJclPeImportLibItem;\r\n UTF8Name: TUTF8String;\r\n LibName: string;\r\n begin\r\n while DelayImportDesc^.szName <> nil do\r\n begin\r\n UTF8Name := PAnsiChar(Image.RvaToVaEx(DWORD(DelayImportDesc^.szName)));\r\n if not TryUTF8ToString(UTF8Name, LibName) then\r\n LibName := string(UTF8Name);\r\n LibItem := TJclPeImportLibItem.Create(Image, DelayImportDesc, ikDelayImport,\r\n LibName, Image.RvaToVaEx(DWORD(DelayImportDesc^.pINT)));\r\n Add(LibItem);\r\n FUniqueNamesList.AddObject(AnsiLowerCase(LibItem.Name), LibItem);\r\n Inc(DelayImportDesc);\r\n end;\r\n end;\r\n\r\n procedure CreateDelayImportList64(DelayImportDesc: PImgDelayDescrV2);\r\n var\r\n LibItem: TJclPeImportLibItem;\r\n UTF8Name: TUTF8String;\r\n LibName: string;\r\n begin\r\n while DelayImportDesc^.rvaDLLName <> 0 do\r\n begin\r\n UTF8Name := PAnsiChar(Image.RvaToVa(DelayImportDesc^.rvaDLLName));\r\n if not TryUTF8ToString(UTF8Name, LibName) then\r\n LibName := string(UTF8Name);\r\n LibItem := TJclPeImportLibItem.Create(Image, DelayImportDesc, ikDelayImport,\r\n LibName, Image.RvaToVa(DelayImportDesc^.rvaINT));\r\n Add(LibItem);\r\n FUniqueNamesList.AddObject(AnsiLowerCase(LibItem.Name), LibItem);\r\n Inc(DelayImportDesc);\r\n end;\r\n end;\r\nvar\r\n ImportDesc: PImageImportDescriptor;\r\n LibItem: TJclPeImportLibItem;\r\n UTF8Name: TUTF8String;\r\n LibName, ModuleName: string;\r\n DelayImportDesc: Pointer;\r\n BoundImports, BoundImport: PImageBoundImportDescriptor;\r\n S: string;\r\n I: Integer;\r\n Thunk: Pointer;\r\nbegin\r\n SetCapacity(100);\r\n with Image do\r\n begin\r\n if not StatusOK then\r\n Exit;\r\n ImportDesc := DirectoryEntryToData(IMAGE_DIRECTORY_ENTRY_IMPORT);\r\n if ImportDesc <> nil then\r\n while ImportDesc^.Name <> 0 do\r\n begin\r\n if ImportDesc^.Union.Characteristics = 0 then\r\n begin\r\n if AttachedImage then // Borland images doesn't have two parallel arrays\r\n Thunk := nil // see MakeBorlandImportTableForMappedImage method\r\n else\r\n Thunk := RvaToVa(ImportDesc^.FirstThunk);\r\n FLinkerProducer := lrBorland;\r\n end\r\n else\r\n begin\r\n Thunk := RvaToVa(ImportDesc^.Union.Characteristics);\r\n FLinkerProducer := lrMicrosoft;\r\n end;\r\n UTF8Name := PAnsiChar(RvaToVa(ImportDesc^.Name));\r\n if not TryUTF8ToString(UTF8Name, LibName) then\r\n LibName := string(UTF8Name);\r\n LibItem := TJclPeImportLibItem.Create(Image, ImportDesc, ikImport, LibName, Thunk);\r\n Add(LibItem);\r\n FUniqueNamesList.AddObject(AnsiLowerCase(LibItem.Name), LibItem);\r\n Inc(ImportDesc);\r\n end;\r\n DelayImportDesc := DirectoryEntryToData(IMAGE_DIRECTORY_ENTRY_DELAY_IMPORT);\r\n if DelayImportDesc <> nil then\r\n begin\r\n case Target of\r\n taWin32:\r\n CreateDelayImportList32(DelayImportDesc);\r\n taWin64:\r\n CreateDelayImportList64(DelayImportDesc);\r\n end;\r\n end;\r\n BoundImports := DirectoryEntryToData(IMAGE_DIRECTORY_ENTRY_BOUND_IMPORT);\r\n if BoundImports <> nil then\r\n begin\r\n BoundImport := BoundImports;\r\n while BoundImport^.OffsetModuleName <> 0 do\r\n begin\r\n UTF8Name := PAnsiChar(TJclAddr(BoundImports) + BoundImport^.OffsetModuleName);\r\n if not TryUTF8ToString(UTF8Name, ModuleName) then\r\n ModuleName := string(UTF8Name);\r\n S := AnsiLowerCase(ModuleName);\r\n I := FUniqueNamesList.IndexOf(S);\r\n if I >= 0 then\r\n TJclPeImportLibItem(FUniqueNamesList.Objects[I]).SetImportKind(ikBoundImport);\r\n for I := 1 to BoundImport^.NumberOfModuleForwarderRefs do\r\n Inc(PImageBoundForwarderRef(BoundImport)); // skip forward information\r\n Inc(BoundImport);\r\n end;\r\n end;\r\n end;\r\n for I := 0 to Count - 1 do\r\n Items[I].SetImportDirectoryIndex(I);\r\nend;\r\n\r\nfunction TJclPeImportList.GetAllItemCount: Integer;\r\nbegin\r\n Result := FAllItemsList.Count;\r\n if Result = 0 then // we haven't created the list yet -> create unsorted list\r\n begin\r\n RefreshAllItems;\r\n Result := FAllItemsList.Count;\r\n end;\r\nend;\r\n\r\nfunction TJclPeImportList.GetAllItems(Index: Integer): TJclPeImportFuncItem;\r\nbegin\r\n Result := TJclPeImportFuncItem(FAllItemsList[Index]);\r\nend;\r\n\r\nfunction TJclPeImportList.GetItems(Index: Integer): TJclPeImportLibItem;\r\nbegin\r\n Result := TJclPeImportLibItem(Get(Index));\r\nend;\r\n\r\nfunction TJclPeImportList.GetUniqueLibItemCount: Integer;\r\nbegin\r\n Result := FUniqueNamesList.Count;\r\nend;\r\n\r\nfunction TJclPeImportList.GetUniqueLibItemFromName(const Name: string): TJclPeImportLibItem;\r\nvar\r\n I: Integer;\r\nbegin\r\n I := FUniqueNamesList.IndexOf(Name);\r\n if I = -1 then\r\n Result := nil\r\n else\r\n Result := TJclPeImportLibItem(FUniqueNamesList.Objects[I]);\r\nend;\r\n\r\nfunction TJclPeImportList.GetUniqueLibItems(Index: Integer): TJclPeImportLibItem;\r\nbegin\r\n Result := TJclPeImportLibItem(FUniqueNamesList.Objects[Index]);\r\nend;\r\n\r\nfunction TJclPeImportList.GetUniqueLibNames(Index: Integer): string;\r\nbegin\r\n Result := FUniqueNamesList[Index];\r\nend;\r\n\r\nfunction TJclPeImportList.MakeBorlandImportTableForMappedImage: Boolean;\r\nvar\r\n FileImage: TJclPeImage;\r\n I, TableSize: Integer;\r\nbegin\r\n if Image.AttachedImage and (LinkerProducer = lrBorland) and\r\n (Length(FParallelImportTable) = 0) then\r\n begin\r\n FileImage := TJclPeImage.Create(True);\r\n try\r\n FileImage.FileName := Image.FileName;\r\n Result := FileImage.StatusOK;\r\n if Result then\r\n begin\r\n SetLength(FParallelImportTable, FileImage.ImportList.Count);\r\n for I := 0 to FileImage.ImportList.Count - 1 do\r\n begin\r\n Assert(Items[I].ImportKind = ikImport); // Borland doesn't have Delay load or Bound imports\r\n TableSize := (FileImage.ImportList[I].Count + 1);\r\n case Image.Target of\r\n taWin32:\r\n begin\r\n TableSize := TableSize * SizeOf(TImageThunkData32);\r\n GetMem(FParallelImportTable[I], TableSize);\r\n System.Move(FileImage.ImportList[I].ThunkData32^, FParallelImportTable[I]^, TableSize);\r\n Items[I].SetThunk(FParallelImportTable[I]);\r\n end;\r\n taWin64:\r\n begin\r\n TableSize := TableSize * SizeOf(TImageThunkData64);\r\n GetMem(FParallelImportTable[I], TableSize);\r\n System.Move(FileImage.ImportList[I].ThunkData64^, FParallelImportTable[I]^, TableSize);\r\n Items[I].SetThunk(FParallelImportTable[I]);\r\n end;\r\n end;\r\n end;\r\n end;\r\n finally\r\n FileImage.Free;\r\n end;\r\n end\r\n else\r\n Result := True;\r\nend;\r\n\r\nprocedure TJclPeImportList.RefreshAllItems;\r\nvar\r\n L, I: Integer;\r\n LibItem: TJclPeImportLibItem;\r\nbegin\r\n FAllItemsList.Clear;\r\n for L := 0 to Count - 1 do\r\n begin\r\n LibItem := Items[L];\r\n if (Length(FFilterModuleName) = 0) or (AnsiCompareText(LibItem.Name, FFilterModuleName) = 0) then\r\n for I := 0 to LibItem.Count - 1 do\r\n FAllItemsList.Add(LibItem[I]);\r\n end;\r\nend;\r\n\r\nprocedure TJclPeImportList.SetFilterModuleName(const Value: string);\r\nbegin\r\n if (FFilterModuleName <> Value) or (FAllItemsList.Count = 0) then\r\n begin\r\n FFilterModuleName := Value;\r\n RefreshAllItems;\r\n FAllItemsList.Sort(GetImportSortFunction(FLastAllSortType, FLastAllSortDescending));\r\n end;\r\nend;\r\n\r\nfunction TJclPeImportList.SmartFindName(const CompareName, LibName: string;\r\n Options: TJclSmartCompOptions): TJclPeImportFuncItem;\r\nvar\r\n L, I: Integer;\r\n LibItem: TJclPeImportLibItem;\r\nbegin\r\n Result := nil;\r\n for L := 0 to Count - 1 do\r\n begin\r\n LibItem := Items[L];\r\n if (Length(LibName) = 0) or (AnsiCompareText(LibItem.Name, LibName) = 0) then\r\n for I := 0 to LibItem.Count - 1 do\r\n if PeSmartFunctionNameSame(CompareName, LibItem[I].Name, Options) then\r\n begin\r\n Result := LibItem[I];\r\n Break;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJclPeImportList.SortAllItemsList(SortType: TJclPeImportSort; Descending: Boolean);\r\nbegin\r\n GetAllItemCount; // create list if it wasn't created\r\n FAllItemsList.Sort(GetImportSortFunction(SortType, Descending));\r\n FLastAllSortType := SortType;\r\n FLastAllSortDescending := Descending;\r\nend;\r\n\r\nprocedure TJclPeImportList.SortList(SortType: TJclPeImportLibSort);\r\nbegin\r\n Sort(GetImportLibSortFunction(SortType));\r\nend;\r\n\r\nprocedure TJclPeImportList.TryGetNamesForOrdinalImports;\r\nvar\r\n LibNamesList: TStringList;\r\n L, I: Integer;\r\n LibPeDump: TJclPeImage;\r\n\r\n procedure TryGetNames(const ModuleName: string);\r\n var\r\n Item: TJclPeImportFuncItem;\r\n I, L: Integer;\r\n ImportLibItem: TJclPeImportLibItem;\r\n ExportItem: TJclPeExportFuncItem;\r\n ExportList: TJclPeExportFuncList;\r\n begin\r\n if Image.AttachedImage then\r\n LibPeDump.AttachLoadedModule(GetModuleHandle(PChar(ModuleName)))\r\n else\r\n LibPeDump.FileName := Image.ExpandModuleName(ModuleName);\r\n if not LibPeDump.StatusOK then\r\n Exit;\r\n ExportList := LibPeDump.ExportList;\r\n for L := 0 to Count - 1 do\r\n begin\r\n ImportLibItem := Items[L];\r\n if AnsiCompareText(ImportLibItem.Name, ModuleName) = 0 then\r\n begin\r\n for I := 0 to ImportLibItem.Count - 1 do\r\n begin\r\n Item := ImportLibItem[I];\r\n if Item.IsByOrdinal then\r\n begin\r\n ExportItem := ExportList.ItemFromOrdinal[Item.Ordinal];\r\n if (ExportItem <> nil) and (ExportItem.Name <> '') then\r\n Item.SetIndirectImportName(ExportItem.Name);\r\n end;\r\n end;\r\n ImportLibItem.SetSorted(False);\r\n end;\r\n end;\r\n end;\r\n\r\nbegin\r\n LibNamesList := TStringList.Create;\r\n try\r\n LibNamesList.Sorted := True;\r\n LibNamesList.Duplicates := dupIgnore;\r\n for L := 0 to Count - 1 do\r\n with Items[L] do\r\n for I := 0 to Count - 1 do\r\n if Items[I].IsByOrdinal then\r\n LibNamesList.Add(AnsiUpperCase(Name));\r\n LibPeDump := TJclPeImage.Create(True);\r\n try\r\n for I := 0 to LibNamesList.Count - 1 do\r\n TryGetNames(LibNamesList[I]);\r\n finally\r\n LibPeDump.Free;\r\n end;\r\n SortAllItemsList(FLastAllSortType, FLastAllSortDescending);\r\n finally\r\n LibNamesList.Free;\r\n end;\r\nend;\r\n\r\n//=== { TJclPeExportFuncItem } ===============================================\r\n\r\nconstructor TJclPeExportFuncItem.Create(AExportList: TJclPeExportFuncList;\r\n const AName, AForwardedName: string; AAddress: DWORD; AHint: Word;\r\n AOrdinal: Word; AResolveCheck: TJclPeResolveCheck);\r\nvar\r\n DotPos: Integer;\r\nbegin\r\n inherited Create;\r\n FExportList := AExportList;\r\n FName := AName;\r\n FForwardedName := AForwardedName;\r\n FAddress := AAddress;\r\n FHint := AHint;\r\n FOrdinal := AOrdinal;\r\n FResolveCheck := AResolveCheck;\r\n\r\n DotPos := AnsiPos('.', ForwardedName);\r\n if DotPos > 0 then\r\n FForwardedDotPos := Copy(ForwardedName, DotPos + 1, Length(ForwardedName) - DotPos)\r\n else\r\n FForwardedDotPos := '';\r\nend;\r\n\r\nfunction TJclPeExportFuncItem.GetAddressOrForwardStr: string;\r\nbegin\r\n if IsForwarded then\r\n Result := ForwardedName\r\n else\r\n FmtStr(Result, '%.8x', [Address]);\r\nend;\r\n\r\nfunction TJclPeExportFuncItem.GetForwardedFuncName: string;\r\nbegin\r\n if (Length(FForwardedDotPos) > 0) and (FForwardedDotPos[1] <> '#') then\r\n Result := FForwardedDotPos\r\n else\r\n Result := '';\r\nend;\r\n\r\nfunction TJclPeExportFuncItem.GetForwardedFuncOrdinal: DWORD;\r\nbegin\r\n if (Length(FForwardedDotPos) > 0) and (FForwardedDotPos[1] = '#') then\r\n Result := StrToIntDef(FForwardedDotPos, 0)\r\n else\r\n Result := 0;\r\nend;\r\n\r\nfunction TJclPeExportFuncItem.GetForwardedLibName: string;\r\nbegin\r\n if Length(FForwardedDotPos) = 0 then\r\n Result := ''\r\n else\r\n Result := AnsiLowerCase(Copy(FForwardedName, 1, Length(FForwardedName) - Length(FForwardedDotPos) - 1)) + BinaryExtensionLibrary;\r\nend;\r\n\r\nfunction TJclPeExportFuncItem.GetIsExportedVariable: Boolean;\r\nbegin\r\n case FExportList.Image.Target of\r\n taWin32:\r\n begin\r\n {$IFDEF DELPHI64_TEMPORARY}\r\n System.Error(rePlatformNotImplemented);//there is no BaseOfData in the 32-bit header for Win64\r\n Result := False;\r\n {$ELSE ~DELPHI64_TEMPORARY}\r\n Result := (Address >= FExportList.Image.OptionalHeader32.BaseOfData);\r\n {$ENDIF ~DELPHI64_TEMPORARY}\r\n end;\r\n taWin64:\r\n Result := False;\r\n // TODO equivalent for 64-bit modules\r\n //Result := (Address >= FExportList.Image.OptionalHeader64.BaseOfData);\r\n else\r\n Result := False;\r\n end;\r\nend;\r\n\r\nfunction TJclPeExportFuncItem.GetIsForwarded: Boolean;\r\nbegin\r\n Result := Length(FForwardedName) <> 0;\r\nend;\r\n\r\nfunction TJclPeExportFuncItem.GetMappedAddress: Pointer;\r\nbegin\r\n Result := FExportList.Image.RvaToVa(FAddress);\r\nend;\r\n\r\nfunction TJclPeExportFuncItem.GetSectionName: string;\r\nbegin\r\n if IsForwarded then\r\n Result := ''\r\n else\r\n with FExportList.Image do\r\n Result := ImageSectionNameFromRva[Address];\r\nend;\r\n\r\nprocedure TJclPeExportFuncItem.SetResolveCheck(Value: TJclPeResolveCheck);\r\nbegin\r\n FResolveCheck := Value;\r\nend;\r\n\r\n// Export sort functions\r\nfunction ExportSortByName(Item1, Item2: Pointer): Integer;\r\nbegin\r\n Result := CompareStr(TJclPeExportFuncItem(Item1).Name, TJclPeExportFuncItem(Item2).Name);\r\nend;\r\n\r\nfunction ExportSortByNameDESC(Item1, Item2: Pointer): Integer;\r\nbegin\r\n Result := ExportSortByName(Item2, Item1);\r\nend;\r\n\r\nfunction ExportSortByOrdinal(Item1, Item2: Pointer): Integer;\r\nbegin\r\n Result := TJclPeExportFuncItem(Item1).Ordinal - TJclPeExportFuncItem(Item2).Ordinal;\r\nend;\r\n\r\nfunction ExportSortByOrdinalDESC(Item1, Item2: Pointer): Integer;\r\nbegin\r\n Result := ExportSortByOrdinal(Item2, Item1);\r\nend;\r\n\r\nfunction ExportSortByHint(Item1, Item2: Pointer): Integer;\r\nbegin\r\n Result := TJclPeExportFuncItem(Item1).Hint - TJclPeExportFuncItem(Item2).Hint;\r\nend;\r\n\r\nfunction ExportSortByHintDESC(Item1, Item2: Pointer): Integer;\r\nbegin\r\n Result := ExportSortByHint(Item2, Item1);\r\nend;\r\n\r\nfunction ExportSortByAddress(Item1, Item2: Pointer): Integer;\r\nbegin\r\n Result := INT_PTR(TJclPeExportFuncItem(Item1).Address) - INT_PTR(TJclPeExportFuncItem(Item2).Address);\r\n if Result = 0 then\r\n Result := ExportSortByName(Item1, Item2);\r\nend;\r\n\r\nfunction ExportSortByAddressDESC(Item1, Item2: Pointer): Integer;\r\nbegin\r\n Result := ExportSortByAddress(Item2, Item1);\r\nend;\r\n\r\nfunction ExportSortByForwarded(Item1, Item2: Pointer): Integer;\r\nbegin\r\n Result := CompareStr(TJclPeExportFuncItem(Item1).ForwardedName, TJclPeExportFuncItem(Item2).ForwardedName);\r\n if Result = 0 then\r\n Result := ExportSortByName(Item1, Item2);\r\nend;\r\n\r\nfunction ExportSortByForwardedDESC(Item1, Item2: Pointer): Integer;\r\nbegin\r\n Result := ExportSortByForwarded(Item2, Item1);\r\nend;\r\n\r\nfunction ExportSortByAddrOrFwd(Item1, Item2: Pointer): Integer;\r\nbegin\r\n Result := CompareStr(TJclPeExportFuncItem(Item1).AddressOrForwardStr, TJclPeExportFuncItem(Item2).AddressOrForwardStr);\r\nend;\r\n\r\nfunction ExportSortByAddrOrFwdDESC(Item1, Item2: Pointer): Integer;\r\nbegin\r\n Result := ExportSortByAddrOrFwd(Item2, Item1);\r\nend;\r\n\r\nfunction ExportSortBySection(Item1, Item2: Pointer): Integer;\r\nbegin\r\n Result := CompareStr(TJclPeExportFuncItem(Item1).SectionName, TJclPeExportFuncItem(Item2).SectionName);\r\n if Result = 0 then\r\n Result := ExportSortByName(Item1, Item2);\r\nend;\r\n\r\nfunction ExportSortBySectionDESC(Item1, Item2: Pointer): Integer;\r\nbegin\r\n Result := ExportSortBySection(Item2, Item1);\r\nend;\r\n\r\n//=== { TJclPeExportFuncList } ===============================================\r\n\r\nconstructor TJclPeExportFuncList.Create(AImage: TJclPeImage);\r\nbegin\r\n inherited Create(AImage);\r\n FTotalResolveCheck := icNotChecked;\r\n CreateList;\r\nend;\r\n\r\ndestructor TJclPeExportFuncList.Destroy;\r\nbegin\r\n FreeAndNil(FForwardedLibsList);\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJclPeExportFuncList.CanPerformFastNameSearch: Boolean;\r\nbegin\r\n Result := FSorted and (FLastSortType = esName) and not FLastSortDescending;\r\nend;\r\n\r\nprocedure TJclPeExportFuncList.CheckForwards(PeImageCache: TJclPeImagesCache);\r\nvar\r\n I: Integer;\r\n FullFileName: TFileName;\r\n ForwardPeImage: TJclPeImage;\r\n ModuleResolveCheck: TJclPeResolveCheck;\r\n\r\n procedure PerformCheck(const ModuleName: string);\r\n var\r\n I: Integer;\r\n Item: TJclPeExportFuncItem;\r\n EL: TJclPeExportFuncList;\r\n begin\r\n EL := ForwardPeImage.ExportList;\r\n EL.PrepareForFastNameSearch;\r\n ModuleResolveCheck := icResolved;\r\n for I := 0 to Count - 1 do\r\n begin\r\n Item := Items[I];\r\n if (not Item.IsForwarded) or (Item.ResolveCheck <> icNotChecked) or\r\n (Item.ForwardedLibName <> ModuleName) then\r\n Continue;\r\n if EL.ItemFromName[Item.ForwardedFuncName] = nil then\r\n begin\r\n Item.SetResolveCheck(icUnresolved);\r\n ModuleResolveCheck := icUnresolved;\r\n end\r\n else\r\n Item.SetResolveCheck(icResolved);\r\n end;\r\n end;\r\n\r\nbegin\r\n if not AnyForwards then\r\n Exit;\r\n FTotalResolveCheck := icResolved;\r\n if PeImageCache <> nil then\r\n ForwardPeImage := nil // to make the compiler happy\r\n else\r\n ForwardPeImage := TJclPeImage.Create(True);\r\n try\r\n for I := 0 to ForwardedLibsList.Count - 1 do\r\n begin\r\n FullFileName := Image.ExpandModuleName(ForwardedLibsList[I]);\r\n if PeImageCache <> nil then\r\n ForwardPeImage := PeImageCache[FullFileName]\r\n else\r\n ForwardPeImage.FileName := FullFileName;\r\n if ForwardPeImage.StatusOK then\r\n PerformCheck(ForwardedLibsList[I])\r\n else\r\n ModuleResolveCheck := icUnresolved;\r\n FForwardedLibsList.Objects[I] := Pointer(ModuleResolveCheck);\r\n if ModuleResolveCheck = icUnresolved then\r\n FTotalResolveCheck := icUnresolved;\r\n end;\r\n finally\r\n if PeImageCache = nil then\r\n ForwardPeImage.Free;\r\n end;\r\nend;\r\n\r\nprocedure TJclPeExportFuncList.CreateList;\r\nvar\r\n Functions: Pointer;\r\n Address, NameCount: DWORD;\r\n NameOrdinals: PWORD;\r\n Names: PDWORD;\r\n I: Integer;\r\n ExportItem: TJclPeExportFuncItem;\r\n ExportVABegin, ExportVAEnd: DWORD;\r\n UTF8Name: TUTF8String;\r\n ForwardedName, ExportName: string;\r\nbegin\r\n with Image do\r\n begin\r\n if not StatusOK then\r\n Exit;\r\n with Directories[IMAGE_DIRECTORY_ENTRY_EXPORT] do\r\n begin\r\n ExportVABegin := VirtualAddress;\r\n ExportVAEnd := VirtualAddress + TJclAddr(Size);\r\n end;\r\n FExportDir := DirectoryEntryToData(IMAGE_DIRECTORY_ENTRY_EXPORT);\r\n if FExportDir <> nil then\r\n begin\r\n FBase := FExportDir^.Base;\r\n FFunctionCount := FExportDir^.NumberOfFunctions;\r\n Functions := RvaToVa(FExportDir^.AddressOfFunctions);\r\n NameOrdinals := RvaToVa(FExportDir^.AddressOfNameOrdinals);\r\n Names := RvaToVa(FExportDir^.AddressOfNames);\r\n NameCount := FExportDir^.NumberOfNames;\r\n Count := FExportDir^.NumberOfFunctions;\r\n\r\n for I := 0 to Count - 1 do\r\n begin\r\n Address := PDWORD(TJclAddr(Functions) + TJclAddr(I) * SizeOf(DWORD))^;\r\n if (Address >= ExportVABegin) and (Address <= ExportVAEnd) then\r\n begin\r\n FAnyForwards := True;\r\n UTF8Name := PAnsiChar(RvaToVa(Address));\r\n if not TryUTF8ToString(UTF8Name, ForwardedName) then\r\n ForwardedName := string(UTF8Name);\r\n end\r\n else\r\n ForwardedName := '';\r\n\r\n ExportItem := TJclPeExportFuncItem.Create(Self, '',\r\n ForwardedName, Address, $FFFF, TJclAddr(I) + FBase, icNotChecked);\r\n\r\n List{$IFNDEF RTL230_UP}^{$ENDIF !RTL230_UP}[I] := ExportItem;\r\n end;\r\n\r\n for I := 0 to NameCount - 1 do\r\n begin\r\n // named function\r\n UTF8Name := PAnsiChar(RvaToVa(Names^));\r\n if not TryUTF8ToString(UTF8Name, ExportName) then\r\n ExportName := string(UTF8Name);\r\n\r\n ExportItem := TJclPeExportFuncItem(List{$IFNDEF RTL230_UP}^{$ENDIF !RTL230_UP}[NameOrdinals^]);\r\n ExportItem.FName := ExportName;\r\n ExportItem.FHint := I;\r\n\r\n Inc(NameOrdinals);\r\n Inc(Names);\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJclPeExportFuncList.GetForwardedLibsList: TStrings;\r\nvar\r\n I: Integer;\r\nbegin\r\n if FForwardedLibsList = nil then\r\n begin\r\n FForwardedLibsList := TStringList.Create;\r\n FForwardedLibsList.Sorted := True;\r\n FForwardedLibsList.Duplicates := dupIgnore;\r\n if FAnyForwards then\r\n for I := 0 to Count - 1 do\r\n with Items[I] do\r\n if IsForwarded then\r\n FForwardedLibsList.AddObject(ForwardedLibName, Pointer(icNotChecked));\r\n end;\r\n Result := FForwardedLibsList;\r\nend;\r\n\r\nfunction TJclPeExportFuncList.GetItemFromAddress(Address: DWORD): TJclPeExportFuncItem;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := nil;\r\n for I := 0 to Count - 1 do\r\n if Items[I].Address = Address then\r\n begin\r\n Result := Items[I];\r\n Break;\r\n end;\r\nend;\r\n\r\nfunction TJclPeExportFuncList.GetItemFromName(const Name: string): TJclPeExportFuncItem;\r\nvar\r\n L, H, I, C: Integer;\r\n B: Boolean;\r\nbegin\r\n Result := nil;\r\n if CanPerformFastNameSearch then\r\n begin\r\n L := 0;\r\n H := Count - 1;\r\n B := False;\r\n while L <= H do\r\n begin\r\n I := (L + H) shr 1;\r\n C := CompareStr(Items[I].Name, Name);\r\n if C < 0 then\r\n L := I + 1\r\n else\r\n begin\r\n H := I - 1;\r\n if C = 0 then\r\n begin\r\n B := True;\r\n L := I;\r\n end;\r\n end;\r\n end;\r\n if B then\r\n Result := Items[L];\r\n end\r\n else\r\n for I := 0 to Count - 1 do\r\n if Items[I].Name = Name then\r\n begin\r\n Result := Items[I];\r\n Break;\r\n end;\r\nend;\r\n\r\nfunction TJclPeExportFuncList.GetItemFromOrdinal(Ordinal: DWORD): TJclPeExportFuncItem;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := nil;\r\n for I := 0 to Count - 1 do\r\n if Items[I].Ordinal = Ordinal then\r\n begin\r\n Result := Items[I];\r\n Break;\r\n end;\r\nend;\r\n\r\nfunction TJclPeExportFuncList.GetItems(Index: Integer): TJclPeExportFuncItem;\r\nbegin\r\n Result := TJclPeExportFuncItem(Get(Index));\r\nend;\r\n\r\nfunction TJclPeExportFuncList.GetName: string;\r\nvar\r\n UTF8ExportName: TUTF8String;\r\nbegin\r\n if (FExportDir = nil) or (FExportDir^.Name = 0) then\r\n Result := ''\r\n else\r\n begin\r\n UTF8ExportName := PAnsiChar(Image.RvaToVa(FExportDir^.Name));\r\n if not TryUTF8ToString(UTF8ExportName, Result) then\r\n Result := string(UTF8ExportName);\r\n end;\r\nend;\r\n\r\nclass function TJclPeExportFuncList.ItemName(Item: TJclPeExportFuncItem): string;\r\nbegin\r\n if Item = nil then\r\n Result := ''\r\n else\r\n Result := Item.Name;\r\nend;\r\n\r\nfunction TJclPeExportFuncList.OrdinalValid(Ordinal: DWORD): Boolean;\r\nbegin\r\n Result := (FExportDir <> nil) and (Ordinal >= Base) and\r\n (Ordinal < FunctionCount + Base);\r\nend;\r\n\r\nprocedure TJclPeExportFuncList.PrepareForFastNameSearch;\r\nbegin\r\n if not CanPerformFastNameSearch then\r\n SortList(esName, False);\r\nend;\r\n\r\nfunction TJclPeExportFuncList.SmartFindName(const CompareName: string;\r\n Options: TJclSmartCompOptions): TJclPeExportFuncItem;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := nil;\r\n for I := 0 to Count - 1 do\r\n begin\r\n if PeSmartFunctionNameSame(CompareName, Items[I].Name, Options) then\r\n begin\r\n Result := Items[I];\r\n Break;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJclPeExportFuncList.SortList(SortType: TJclPeExportSort; Descending: Boolean);\r\nconst\r\n SortFunctions: array [TJclPeExportSort, Boolean] of TListSortCompare =\r\n ((ExportSortByName, ExportSortByNameDESC),\r\n (ExportSortByOrdinal, ExportSortByOrdinalDESC),\r\n (ExportSortByHint, ExportSortByHintDESC),\r\n (ExportSortByAddress, ExportSortByAddressDESC),\r\n (ExportSortByForwarded, ExportSortByForwardedDESC),\r\n (ExportSortByAddrOrFwd, ExportSortByAddrOrFwdDESC),\r\n (ExportSortBySection, ExportSortBySectionDESC)\r\n );\r\nbegin\r\n if not FSorted or (SortType <> FLastSortType) or (Descending <> FLastSortDescending) then\r\n begin\r\n Sort(SortFunctions[SortType, Descending]);\r\n FLastSortType := SortType;\r\n FLastSortDescending := Descending;\r\n FSorted := True;\r\n end;\r\nend;\r\n\r\n//=== { TJclPeResourceRawStream } ============================================\r\n\r\nconstructor TJclPeResourceRawStream.Create(AResourceItem: TJclPeResourceItem);\r\nbegin\r\n Assert(not AResourceItem.IsDirectory);\r\n inherited Create;\r\n SetPointer(AResourceItem.RawEntryData, AResourceItem.RawEntryDataSize);\r\nend;\r\n\r\nfunction TJclPeResourceRawStream.Write(const Buffer; Count: Integer): Longint;\r\nbegin\r\n raise EJclPeImageError.CreateRes(@RsPeReadOnlyStream);\r\nend;\r\n\r\n//=== { TJclPeResourceItem } =================================================\r\n\r\nconstructor TJclPeResourceItem.Create(AImage: TJclPeImage;\r\n AParentItem: TJclPeResourceItem; AEntry: PImageResourceDirectoryEntry);\r\nbegin\r\n inherited Create;\r\n FImage := AImage;\r\n FEntry := AEntry;\r\n FParentItem := AParentItem;\r\n if AParentItem = nil then\r\n FLevel := 1\r\n else\r\n FLevel := AParentItem.Level + 1;\r\nend;\r\n\r\ndestructor TJclPeResourceItem.Destroy;\r\nbegin\r\n FreeAndNil(FList);\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJclPeResourceItem.CompareName(AName: PChar): Boolean;\r\nvar\r\n P: PChar;\r\nbegin\r\n if IsName then\r\n P := PChar(Name)\r\n else\r\n P := PChar(FEntry^.Name and $FFFF); // Integer encoded in a PChar\r\n Result := CompareResourceName(AName, P);\r\nend;\r\n\r\nfunction TJclPeResourceItem.GetDataEntry: PImageResourceDataEntry;\r\nbegin\r\n if GetIsDirectory then\r\n Result := nil\r\n else\r\n Result := PImageResourceDataEntry(OffsetToRawData(FEntry^.OffsetToData));\r\nend;\r\n\r\nfunction TJclPeResourceItem.GetIsDirectory: Boolean;\r\nbegin\r\n Result := FEntry^.OffsetToData and IMAGE_RESOURCE_DATA_IS_DIRECTORY <> 0;\r\nend;\r\n\r\nfunction TJclPeResourceItem.GetIsName: Boolean;\r\nbegin\r\n Result := FEntry^.Name and IMAGE_RESOURCE_NAME_IS_STRING <> 0;\r\nend;\r\n\r\nfunction TJclPeResourceItem.GetLangID: LANGID;\r\nbegin\r\n if IsDirectory then\r\n begin\r\n GetList;\r\n if FList.Count = 1 then\r\n Result := StrToIntDef(FList[0].Name, 0)\r\n else\r\n Result := 0;\r\n end\r\n else\r\n Result := StrToIntDef(Name, 0);\r\nend;\r\n\r\nfunction TJclPeResourceItem.GetList: TJclPeResourceList;\r\nbegin\r\n if not IsDirectory then\r\n begin\r\n if Image.NoExceptions then\r\n begin\r\n Result := nil;\r\n Exit;\r\n end\r\n else\r\n raise EJclPeImageError.CreateRes(@RsPeNotResDir);\r\n end;\r\n if FList = nil then\r\n FList := FImage.ResourceListCreate(SubDirData, Self);\r\n Result := FList;\r\nend;\r\n\r\nfunction TJclPeResourceItem.GetName: string;\r\nbegin\r\n if IsName then\r\n begin\r\n if FNameCache = '' then\r\n begin\r\n with PImageResourceDirStringU(OffsetToRawData(FEntry^.Name))^ do\r\n FNameCache := WideCharLenToString(NameString, Length);\r\n StrResetLength(FNameCache);\r\n end;\r\n Result := FNameCache;\r\n end\r\n else\r\n Result := IntToStr(FEntry^.Name and $FFFF);\r\nend;\r\n\r\nfunction TJclPeResourceItem.GetParameterName: string;\r\nbegin\r\n if IsName then\r\n Result := Name\r\n else\r\n Result := Format('#%d', [FEntry^.Name and $FFFF]);\r\nend;\r\n\r\nfunction TJclPeResourceItem.GetRawEntryData: Pointer;\r\nbegin\r\n if GetIsDirectory then\r\n Result := nil\r\n else\r\n Result := FImage.RvaToVa(GetDataEntry^.OffsetToData);\r\nend;\r\n\r\nfunction TJclPeResourceItem.GetRawEntryDataSize: Integer;\r\nbegin\r\n if GetIsDirectory then\r\n Result := -1\r\n else\r\n Result := PImageResourceDataEntry(OffsetToRawData(FEntry^.OffsetToData))^.Size;\r\nend;\r\n\r\nfunction TJclPeResourceItem.GetResourceType: TJclPeResourceKind;\r\nbegin\r\n with Level1Item do\r\n begin\r\n if FEntry^.Name < Cardinal(High(TJclPeResourceKind)) then\r\n Result := TJclPeResourceKind(FEntry^.Name)\r\n else\r\n Result := rtUserDefined\r\n end;\r\nend;\r\n\r\nfunction TJclPeResourceItem.GetResourceTypeStr: string;\r\nbegin\r\n with Level1Item do\r\n begin\r\n if FEntry^.Name < Cardinal(High(TJclPeResourceKind)) then\r\n Result := Copy(GetEnumName(TypeInfo(TJclPeResourceKind), Ord(FEntry^.Name)), 3, 30)\r\n else\r\n Result := Name;\r\n end;\r\nend;\r\n\r\nfunction TJclPeResourceItem.Level1Item: TJclPeResourceItem;\r\nbegin\r\n Result := Self;\r\n while Result.FParentItem <> nil do\r\n Result := Result.FParentItem;\r\nend;\r\n\r\nfunction TJclPeResourceItem.OffsetToRawData(Ofs: DWORD): TJclAddr;\r\nbegin\r\n Result := (Ofs and $7FFFFFFF) + Image.ResourceVA;\r\nend;\r\n\r\nfunction TJclPeResourceItem.SubDirData: PImageResourceDirectory;\r\nbegin\r\n Result := Pointer(OffsetToRawData(FEntry^.OffsetToData));\r\nend;\r\n\r\n//=== { TJclPeResourceList } =================================================\r\n\r\nconstructor TJclPeResourceList.Create(AImage: TJclPeImage;\r\n AParentItem: TJclPeResourceItem; ADirectory: PImageResourceDirectory);\r\nbegin\r\n inherited Create(AImage);\r\n FDirectory := ADirectory;\r\n FParentItem := AParentItem;\r\n CreateList(AParentItem);\r\nend;\r\n\r\nprocedure TJclPeResourceList.CreateList(AParentItem: TJclPeResourceItem);\r\nvar\r\n Entry: PImageResourceDirectoryEntry;\r\n DirItem: TJclPeResourceItem;\r\n I: Integer;\r\nbegin\r\n if FDirectory = nil then\r\n Exit;\r\n Entry := Pointer(TJclAddr(FDirectory) + SizeOf(TImageResourceDirectory));\r\n for I := 1 to DWORD(FDirectory^.NumberOfNamedEntries) + DWORD(FDirectory^.NumberOfIdEntries) do\r\n begin\r\n DirItem := Image.ResourceItemCreate(Entry, AParentItem);\r\n Add(DirItem);\r\n Inc(Entry);\r\n end;\r\nend;\r\n\r\nfunction TJclPeResourceList.FindName(const Name: string): TJclPeResourceItem;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := nil;\r\n for I := 0 to Count - 1 do\r\n if StrSame(Items[I].Name, Name) then\r\n begin\r\n Result := Items[I];\r\n Break;\r\n end;\r\nend;\r\n\r\nfunction TJclPeResourceList.GetItems(Index: Integer): TJclPeResourceItem;\r\nbegin\r\n Result := TJclPeResourceItem(Get(Index));\r\nend;\r\n\r\n//=== { TJclPeRootResourceList } =============================================\r\n\r\ndestructor TJclPeRootResourceList.Destroy;\r\nbegin\r\n FreeAndNil(FManifestContent);\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJclPeRootResourceList.FindResource(ResourceType: TJclPeResourceKind;\r\n const ResourceName: string): TJclPeResourceItem;\r\nvar\r\n I: Integer;\r\n TypeItem: TJclPeResourceItem;\r\nbegin\r\n Result := nil;\r\n TypeItem := nil;\r\n for I := 0 to Count - 1 do\r\n begin\r\n if Items[I].ResourceType = ResourceType then\r\n begin\r\n TypeItem := Items[I];\r\n Break;\r\n end;\r\n end;\r\n if TypeItem <> nil then\r\n if ResourceName = '' then\r\n Result := TypeItem\r\n else\r\n with TypeItem.List do\r\n for I := 0 to Count - 1 do\r\n if Items[I].Name = ResourceName then\r\n begin\r\n Result := Items[I];\r\n Break;\r\n end;\r\nend;\r\n\r\nfunction TJclPeRootResourceList.FindResource(const ResourceType: PChar;\r\n const ResourceName: PChar): TJclPeResourceItem;\r\nvar\r\n I: Integer;\r\n TypeItem: TJclPeResourceItem;\r\nbegin\r\n Result := nil;\r\n TypeItem := nil;\r\n for I := 0 to Count - 1 do\r\n if Items[I].CompareName(ResourceType) then\r\n begin\r\n TypeItem := Items[I];\r\n Break;\r\n end;\r\n if TypeItem <> nil then\r\n if ResourceName = nil then\r\n Result := TypeItem\r\n else\r\n with TypeItem.List do\r\n for I := 0 to Count - 1 do\r\n if Items[I].CompareName(ResourceName) then\r\n begin\r\n Result := Items[I];\r\n Break;\r\n end;\r\nend;\r\n\r\nfunction TJclPeRootResourceList.GetManifestContent: TStrings;\r\nvar\r\n ManifestFileName: string;\r\n ResItem: TJclPeResourceItem;\r\n ResStream: TJclPeResourceRawStream;\r\nbegin\r\n if FManifestContent = nil then\r\n begin\r\n FManifestContent := TStringList.Create;\r\n ResItem := FindResource(RT_MANIFEST, CREATEPROCESS_MANIFEST_RESOURCE_ID);\r\n if ResItem = nil then\r\n begin\r\n ManifestFileName := Image.FileName + MANIFESTExtension;\r\n if FileExists(ManifestFileName) then\r\n FManifestContent.LoadFromFile(ManifestFileName);\r\n end\r\n else\r\n begin\r\n ResStream := TJclPeResourceRawStream.Create(ResItem.List[0]);\r\n try\r\n FManifestContent.LoadFromStream(ResStream);\r\n finally\r\n ResStream.Free;\r\n end;\r\n end;\r\n end;\r\n Result := FManifestContent;\r\nend;\r\n\r\nfunction TJclPeRootResourceList.ListResourceNames(ResourceType: TJclPeResourceKind;\r\n const Strings: TStrings): Boolean;\r\nvar\r\n ResTypeItem, TempItem: TJclPeResourceItem;\r\n I: Integer;\r\nbegin\r\n ResTypeItem := FindResource(ResourceType, '');\r\n Result := (ResTypeItem <> nil);\r\n if Result then\r\n begin\r\n Strings.BeginUpdate;\r\n try\r\n with ResTypeItem.List do\r\n for I := 0 to Count - 1 do\r\n begin\r\n TempItem := Items[I];\r\n Strings.AddObject(TempItem.Name, Pointer(TempItem.IsName));\r\n end;\r\n finally\r\n Strings.EndUpdate;\r\n end;\r\n end;\r\nend;\r\n\r\n//=== { TJclPeRelocEntry } ===================================================\r\n\r\nconstructor TJclPeRelocEntry.Create(AChunk: PImageBaseRelocation; ACount: Integer);\r\nbegin\r\n inherited Create;\r\n FChunk := AChunk;\r\n FCount := ACount;\r\nend;\r\n\r\nfunction TJclPeRelocEntry.GetRelocations(Index: Integer): TJclPeRelocation;\r\nvar\r\n Temp: Word;\r\nbegin\r\n Temp := PWord(TJclAddr(FChunk) + SizeOf(TImageBaseRelocation) + DWORD(Index) * SizeOf(Word))^;\r\n Result.Address := Temp and $0FFF;\r\n Result.RelocType := (Temp and $F000) shr 12;\r\n Result.VirtualAddress := TJclAddr(Result.Address) + VirtualAddress;\r\nend;\r\n\r\nfunction TJclPeRelocEntry.GetSize: DWORD;\r\nbegin\r\n Result := FChunk^.SizeOfBlock;\r\nend;\r\n\r\nfunction TJclPeRelocEntry.GetVirtualAddress: DWORD;\r\nbegin\r\n Result := FChunk^.VirtualAddress;\r\nend;\r\n\r\n//=== { TJclPeRelocList } ====================================================\r\n\r\nconstructor TJclPeRelocList.Create(AImage: TJclPeImage);\r\nbegin\r\n inherited Create(AImage);\r\n CreateList;\r\nend;\r\n\r\nprocedure TJclPeRelocList.CreateList;\r\nvar\r\n Chunk: PImageBaseRelocation;\r\n Item: TJclPeRelocEntry;\r\n RelocCount: Integer;\r\nbegin\r\n with Image do\r\n begin\r\n if not StatusOK then\r\n Exit;\r\n Chunk := DirectoryEntryToData(IMAGE_DIRECTORY_ENTRY_BASERELOC);\r\n if Chunk = nil then\r\n Exit;\r\n FAllItemCount := 0;\r\n while Chunk^.SizeOfBlock <> 0 do\r\n begin\r\n RelocCount := (Chunk^.SizeOfBlock - SizeOf(TImageBaseRelocation)) div SizeOf(Word);\r\n Item := TJclPeRelocEntry.Create(Chunk, RelocCount);\r\n Inc(FAllItemCount, RelocCount);\r\n Add(Item);\r\n Chunk := Pointer(TJclAddr(Chunk) + Chunk^.SizeOfBlock);\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJclPeRelocList.GetAllItems(Index: Integer): TJclPeRelocation;\r\nvar\r\n I, N, C: Integer;\r\nbegin\r\n N := Index;\r\n for I := 0 to Count - 1 do\r\n begin\r\n C := Items[I].Count;\r\n Dec(N, C);\r\n if N < 0 then\r\n begin\r\n Result := Items[I][N + C];\r\n Break;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJclPeRelocList.GetItems(Index: Integer): TJclPeRelocEntry;\r\nbegin\r\n Result := TJclPeRelocEntry(Get(Index));\r\nend;\r\n\r\n//=== { TJclPeDebugList } ====================================================\r\n\r\nconstructor TJclPeDebugList.Create(AImage: TJclPeImage);\r\nbegin\r\n inherited Create(AImage);\r\n OwnsObjects := False;\r\n CreateList;\r\nend;\r\n\r\nprocedure TJclPeDebugList.CreateList;\r\nvar\r\n DebugImageDir: TImageDataDirectory;\r\n DebugDir: PImageDebugDirectory;\r\n Header: PImageSectionHeader;\r\n FormatCount, I: Integer;\r\nbegin\r\n with Image do\r\n begin\r\n if not StatusOK then\r\n Exit;\r\n DebugImageDir := Directories[IMAGE_DIRECTORY_ENTRY_DEBUG];\r\n if DebugImageDir.VirtualAddress = 0 then\r\n Exit;\r\n if GetSectionHeader(DebugSectionName, Header) and\r\n (Header^.VirtualAddress = DebugImageDir.VirtualAddress) then\r\n begin\r\n FormatCount := DebugImageDir.Size;\r\n DebugDir := RvaToVa(Header^.VirtualAddress);\r\n end\r\n else\r\n begin\r\n if not GetSectionHeader(ReadOnlySectionName, Header) then\r\n Exit;\r\n FormatCount := DebugImageDir.Size div SizeOf(TImageDebugDirectory);\r\n DebugDir := Pointer(MappedAddress + DebugImageDir.VirtualAddress -\r\n Header^.VirtualAddress + Header^.PointerToRawData);\r\n end;\r\n for I := 1 to FormatCount do\r\n begin\r\n Add(TObject(DebugDir));\r\n Inc(DebugDir);\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJclPeDebugList.GetItems(Index: Integer): TImageDebugDirectory;\r\nbegin\r\n Result := PImageDebugDirectory(Get(Index))^;\r\nend;\r\n\r\n//=== { TJclPeCertificate } ==================================================\r\n\r\nconstructor TJclPeCertificate.Create(AHeader: TWinCertificate; AData: Pointer);\r\nbegin\r\n inherited Create;\r\n FHeader := AHeader;\r\n FData := AData;\r\nend;\r\n\r\n//=== { TJclPeCertificateList } ==============================================\r\n\r\nconstructor TJclPeCertificateList.Create(AImage: TJclPeImage);\r\nbegin\r\n inherited Create(AImage);\r\n CreateList;\r\nend;\r\n\r\nprocedure TJclPeCertificateList.CreateList;\r\nvar\r\n Directory: TImageDataDirectory;\r\n CertPtr: PChar;\r\n TotalSize: Integer;\r\n Item: TJclPeCertificate;\r\nbegin\r\n Directory := Image.Directories[IMAGE_DIRECTORY_ENTRY_SECURITY];\r\n if Directory.VirtualAddress = 0 then\r\n Exit;\r\n CertPtr := Image.RawToVa(Directory.VirtualAddress); // Security directory is a raw offset\r\n TotalSize := Directory.Size;\r\n while TotalSize >= SizeOf(TWinCertificate) do\r\n begin\r\n Item := TJclPeCertificate.Create(PWinCertificate(CertPtr)^, CertPtr + SizeOf(TWinCertificate));\r\n Dec(TotalSize, Item.Header.dwLength);\r\n Add(Item);\r\n end;\r\nend;\r\n\r\nfunction TJclPeCertificateList.GetItems(Index: Integer): TJclPeCertificate;\r\nbegin\r\n Result := TJclPeCertificate(Get(Index));\r\nend;\r\n\r\n//=== { TJclPeCLRHeader } ====================================================\r\n\r\nconstructor TJclPeCLRHeader.Create(AImage: TJclPeImage);\r\nbegin\r\n FImage := AImage;\r\n ReadHeader;\r\nend;\r\n\r\nfunction TJclPeCLRHeader.GetHasMetadata: Boolean;\r\nconst\r\n METADATA_SIGNATURE = $424A5342; // Reference: Partition II Metadata.doc - 23.2.1 Metadata root\r\nbegin\r\n with Header.MetaData do\r\n Result := (VirtualAddress <> 0) and (PDWORD(FImage.RvaToVa(VirtualAddress))^ = METADATA_SIGNATURE);\r\nend;\r\n{ TODO -cDOC : \"Flier Lu\" }\r\n\r\nfunction TJclPeCLRHeader.GetVersionString: string;\r\nbegin\r\n Result := FormatVersionString(Header.MajorRuntimeVersion, Header.MinorRuntimeVersion);\r\nend;\r\n\r\nprocedure TJclPeCLRHeader.ReadHeader;\r\nvar\r\n HeaderPtr: PImageCor20Header;\r\nbegin\r\n HeaderPtr := Image.DirectoryEntryToData(IMAGE_DIRECTORY_ENTRY_COM_DESCRIPTOR);\r\n if (HeaderPtr <> nil) and (HeaderPtr^.cb >= SizeOf(TImageCor20Header)) then\r\n FHeader := HeaderPtr^;\r\nend;\r\n\r\n//=== { TJclPeImage } ========================================================\r\n\r\nconstructor TJclPeImage.Create(ANoExceptions: Boolean);\r\nbegin\r\n FNoExceptions := ANoExceptions;\r\n FReadOnlyAccess := True;\r\n FImageSections := TStringList.Create;\r\n FStringTable := TStringList.Create;\r\nend;\r\n\r\ndestructor TJclPeImage.Destroy;\r\nbegin\r\n Clear;\r\n FreeAndNil(FImageSections);\r\n FStringTable.Free;\r\n\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJclPeImage.AfterOpen;\r\nbegin\r\nend;\r\n\r\nprocedure TJclPeImage.AttachLoadedModule(const Handle: HMODULE);\r\n procedure AttachLoadedModule32;\r\n var\r\n NtHeaders: PImageNtHeaders32;\r\n begin\r\n NtHeaders := PeMapImgNtHeaders32(Pointer(Handle));\r\n if NtHeaders = nil then\r\n FStatus := stNotPE\r\n else\r\n begin\r\n FStatus := stOk;\r\n FAttachedImage := True;\r\n FFileName := GetModulePath(Handle);\r\n // OF: possible loss of data\r\n FLoadedImage.ModuleName := PAnsiChar(AnsiString(FFileName));\r\n FLoadedImage.hFile := INVALID_HANDLE_VALUE;\r\n FLoadedImage.MappedAddress := Pointer(Handle);\r\n FLoadedImage.FileHeader := PImageNtHeaders(NtHeaders);\r\n FLoadedImage.NumberOfSections := NtHeaders^.FileHeader.NumberOfSections;\r\n FLoadedImage.Sections := PeMapImgSections32(NtHeaders);\r\n FLoadedImage.LastRvaSection := FLoadedImage.Sections;\r\n FLoadedImage.Characteristics := NtHeaders^.FileHeader.Characteristics;\r\n FLoadedImage.fSystemImage := (FLoadedImage.Characteristics and IMAGE_FILE_SYSTEM <> 0);\r\n FLoadedImage.fDOSImage := False;\r\n FLoadedImage.SizeOfImage := NtHeaders^.OptionalHeader.SizeOfImage;\r\n ReadImageSections;\r\n ReadStringTable;\r\n AfterOpen;\r\n end;\r\n RaiseStatusException;\r\n end;\r\n\r\n procedure AttachLoadedModule64;\r\n var\r\n NtHeaders: PImageNtHeaders64;\r\n begin\r\n NtHeaders := PeMapImgNtHeaders64(Pointer(Handle));\r\n if NtHeaders = nil then\r\n FStatus := stNotPE\r\n else\r\n begin\r\n FStatus := stOk;\r\n FAttachedImage := True;\r\n FFileName := GetModulePath(Handle);\r\n // OF: possible loss of data\r\n FLoadedImage.ModuleName := PAnsiChar(AnsiString(FFileName));\r\n FLoadedImage.hFile := INVALID_HANDLE_VALUE;\r\n FLoadedImage.MappedAddress := Pointer(Handle);\r\n FLoadedImage.FileHeader := PImageNtHeaders(NtHeaders);\r\n FLoadedImage.NumberOfSections := NtHeaders^.FileHeader.NumberOfSections;\r\n FLoadedImage.Sections := PeMapImgSections64(NtHeaders);\r\n FLoadedImage.LastRvaSection := FLoadedImage.Sections;\r\n FLoadedImage.Characteristics := NtHeaders^.FileHeader.Characteristics;\r\n FLoadedImage.fSystemImage := (FLoadedImage.Characteristics and IMAGE_FILE_SYSTEM <> 0);\r\n FLoadedImage.fDOSImage := False;\r\n FLoadedImage.SizeOfImage := NtHeaders^.OptionalHeader.SizeOfImage;\r\n ReadImageSections;\r\n ReadStringTable;\r\n AfterOpen;\r\n end;\r\n RaiseStatusException;\r\n end;\r\nbegin\r\n Clear;\r\n if Handle = 0 then\r\n Exit;\r\n FTarget := PeMapImgTarget(Pointer(Handle));\r\n case Target of\r\n taWin32:\r\n AttachLoadedModule32;\r\n taWin64:\r\n AttachLoadedModule64;\r\n taUnknown:\r\n FStatus := stNotSupported;\r\n end;\r\nend;\r\n\r\nfunction TJclPeImage.CalculateCheckSum: DWORD;\r\nvar\r\n C: DWORD;\r\nbegin\r\n if StatusOK then\r\n begin\r\n CheckNotAttached;\r\n if CheckSumMappedFile(FLoadedImage.MappedAddress, FLoadedImage.SizeOfImage,\r\n C, Result) = nil then\r\n RaiseLastOSError;\r\n end\r\n else\r\n Result := 0;\r\nend;\r\n\r\nprocedure TJclPeImage.CheckNotAttached;\r\nbegin\r\n if FAttachedImage then\r\n raise EJclPeImageError.CreateRes(@RsPeNotAvailableForAttached);\r\nend;\r\n\r\nprocedure TJclPeImage.Clear;\r\nbegin\r\n FImageSections.Clear;\r\n FStringTable.Clear;\r\n FreeAndNil(FCertificateList);\r\n FreeAndNil(FCLRHeader);\r\n FreeAndNil(FDebugList);\r\n FreeAndNil(FImportList);\r\n FreeAndNil(FExportList);\r\n FreeAndNil(FRelocationList);\r\n FreeAndNil(FResourceList);\r\n FreeAndNil(FVersionInfo);\r\n if not FAttachedImage and StatusOK then\r\n UnMapAndLoad(FLoadedImage);\r\n ResetMemory(FLoadedImage, SizeOf(FLoadedImage));\r\n FStatus := stNotLoaded;\r\n FAttachedImage := False;\r\nend;\r\n\r\nclass function TJclPeImage.DateTimeToStamp(const DateTime: TDateTime): DWORD;\r\nbegin\r\n Result := Round((DateTime - UnixTimeStart) * SecsPerDay);\r\nend;\r\n\r\nclass function TJclPeImage.DebugTypeNames(DebugType: DWORD): string;\r\nbegin\r\n case DebugType of\r\n IMAGE_DEBUG_TYPE_UNKNOWN:\r\n Result := LoadResString(@RsPeDEBUG_UNKNOWN);\r\n IMAGE_DEBUG_TYPE_COFF:\r\n Result := LoadResString(@RsPeDEBUG_COFF);\r\n IMAGE_DEBUG_TYPE_CODEVIEW:\r\n Result := LoadResString(@RsPeDEBUG_CODEVIEW);\r\n IMAGE_DEBUG_TYPE_FPO:\r\n Result := LoadResString(@RsPeDEBUG_FPO);\r\n IMAGE_DEBUG_TYPE_MISC:\r\n Result := LoadResString(@RsPeDEBUG_MISC);\r\n IMAGE_DEBUG_TYPE_EXCEPTION:\r\n Result := LoadResString(@RsPeDEBUG_EXCEPTION);\r\n IMAGE_DEBUG_TYPE_FIXUP:\r\n Result := LoadResString(@RsPeDEBUG_FIXUP);\r\n IMAGE_DEBUG_TYPE_OMAP_TO_SRC:\r\n Result := LoadResString(@RsPeDEBUG_OMAP_TO_SRC);\r\n IMAGE_DEBUG_TYPE_OMAP_FROM_SRC:\r\n Result := LoadResString(@RsPeDEBUG_OMAP_FROM_SRC);\r\n else\r\n Result := LoadResString(@RsPeDEBUG_UNKNOWN);\r\n end;\r\nend;\r\n\r\nfunction TJclPeImage.DirectoryEntryToData(Directory: Word): Pointer;\r\nvar\r\n Size: DWORD;\r\nbegin\r\n Size := 0;\r\n Result := ImageDirectoryEntryToData(FLoadedImage.MappedAddress, FAttachedImage, Directory, Size);\r\nend;\r\n\r\nclass function TJclPeImage.DirectoryNames(Directory: Word): string;\r\nbegin\r\n case Directory of\r\n IMAGE_DIRECTORY_ENTRY_EXPORT:\r\n Result := LoadResString(@RsPeImg_00);\r\n IMAGE_DIRECTORY_ENTRY_IMPORT:\r\n Result := LoadResString(@RsPeImg_01);\r\n IMAGE_DIRECTORY_ENTRY_RESOURCE:\r\n Result := LoadResString(@RsPeImg_02);\r\n IMAGE_DIRECTORY_ENTRY_EXCEPTION:\r\n Result := LoadResString(@RsPeImg_03);\r\n IMAGE_DIRECTORY_ENTRY_SECURITY:\r\n Result := LoadResString(@RsPeImg_04);\r\n IMAGE_DIRECTORY_ENTRY_BASERELOC:\r\n Result := LoadResString(@RsPeImg_05);\r\n IMAGE_DIRECTORY_ENTRY_DEBUG:\r\n Result := LoadResString(@RsPeImg_06);\r\n IMAGE_DIRECTORY_ENTRY_COPYRIGHT:\r\n Result := LoadResString(@RsPeImg_07);\r\n IMAGE_DIRECTORY_ENTRY_GLOBALPTR:\r\n Result := LoadResString(@RsPeImg_08);\r\n IMAGE_DIRECTORY_ENTRY_TLS:\r\n Result := LoadResString(@RsPeImg_09);\r\n IMAGE_DIRECTORY_ENTRY_LOAD_CONFIG:\r\n Result := LoadResString(@RsPeImg_10);\r\n IMAGE_DIRECTORY_ENTRY_BOUND_IMPORT:\r\n Result := LoadResString(@RsPeImg_11);\r\n IMAGE_DIRECTORY_ENTRY_IAT:\r\n Result := LoadResString(@RsPeImg_12);\r\n IMAGE_DIRECTORY_ENTRY_DELAY_IMPORT:\r\n Result := LoadResString(@RsPeImg_13);\r\n IMAGE_DIRECTORY_ENTRY_COM_DESCRIPTOR:\r\n Result := LoadResString(@RsPeImg_14);\r\n else\r\n Result := Format(LoadResString(@RsPeImg_Reserved), [Directory]);\r\n end;\r\nend;\r\n\r\nclass function TJclPeImage.ExpandBySearchPath(const ModuleName, BasePath: string): TFileName;\r\nvar\r\n FullName: array [0..MAX_PATH] of Char;\r\n FilePart: PChar;\r\nbegin\r\n Result := PathAddSeparator(ExtractFilePath(BasePath)) + ModuleName;\r\n if FileExists(Result) then\r\n Exit;\r\n FilePart := nil;\r\n if SearchPath(nil, PChar(ModuleName), nil, Length(FullName), FullName, FilePart) = 0 then\r\n Result := ModuleName\r\n else\r\n Result := FullName;\r\nend;\r\n\r\nfunction TJclPeImage.ExpandModuleName(const ModuleName: string): TFileName;\r\nbegin\r\n Result := ExpandBySearchPath(ModuleName, ExtractFilePath(FFileName));\r\nend;\r\n\r\nfunction TJclPeImage.GetCertificateList: TJclPeCertificateList;\r\nbegin\r\n if FCertificateList = nil then\r\n FCertificateList := TJclPeCertificateList.Create(Self);\r\n Result := FCertificateList;\r\nend;\r\n\r\nfunction TJclPeImage.GetCLRHeader: TJclPeCLRHeader;\r\nbegin\r\n if FCLRHeader = nil then\r\n FCLRHeader := TJclPeCLRHeader.Create(Self);\r\n Result := FCLRHeader;\r\nend;\r\n\r\nfunction TJclPeImage.GetDebugList: TJclPeDebugList;\r\nbegin\r\n if FDebugList = nil then\r\n FDebugList := TJclPeDebugList.Create(Self);\r\n Result := FDebugList;\r\nend;\r\n\r\nfunction TJclPeImage.GetDescription: string;\r\nvar\r\n UTF8DescriptionName: TUTF8String;\r\nbegin\r\n if DirectoryExists[IMAGE_DIRECTORY_ENTRY_COPYRIGHT] then\r\n begin\r\n UTF8DescriptionName := PAnsiChar(DirectoryEntryToData(IMAGE_DIRECTORY_ENTRY_COPYRIGHT));\r\n if not TryUTF8ToString(UTF8DescriptionName, Result) then\r\n Result := string(UTF8DescriptionName);\r\n end\r\n else\r\n Result := '';\r\nend;\r\n\r\nfunction TJclPeImage.GetDirectories(Directory: Word): TImageDataDirectory;\r\nbegin\r\n if StatusOK then\r\n begin\r\n case Target of\r\n taWin32:\r\n Result := PImageNtHeaders32(FLoadedImage.FileHeader)^.OptionalHeader.DataDirectory[Directory];\r\n taWin64:\r\n Result := PImageNtHeaders64(FLoadedImage.FileHeader)^.OptionalHeader.DataDirectory[Directory];\r\n else\r\n Result.VirtualAddress := 0;\r\n Result.Size := 0;\r\n end\r\n end\r\n else\r\n begin\r\n Result.VirtualAddress := 0;\r\n Result.Size := 0;\r\n end;\r\nend;\r\n\r\nfunction TJclPeImage.GetDirectoryExists(Directory: Word): Boolean;\r\nbegin\r\n Result := (Directories[Directory].VirtualAddress <> 0);\r\nend;\r\n\r\nfunction TJclPeImage.GetExportList: TJclPeExportFuncList;\r\nbegin\r\n if FExportList = nil then\r\n FExportList := TJclPeExportFuncList.Create(Self);\r\n Result := FExportList;\r\nend;\r\n\r\nfunction TJclPeImage.GetFileProperties: TJclPeFileProperties;\r\nvar\r\n FileAttributesEx: WIN32_FILE_ATTRIBUTE_DATA;\r\n Size: TJclULargeInteger;\r\nbegin\r\n ResetMemory(Result, SizeOf(Result));\r\n if GetFileAttributesEx(PChar(FileName), GetFileExInfoStandard, @FileAttributesEx) then\r\n begin\r\n Size.LowPart := FileAttributesEx.nFileSizeLow;\r\n Size.HighPart := FileAttributesEx.nFileSizeHigh;\r\n Result.Size := Size.QuadPart;\r\n Result.CreationTime := FileTimeToLocalDateTime(FileAttributesEx.ftCreationTime);\r\n Result.LastAccessTime := FileTimeToLocalDateTime(FileAttributesEx.ftLastAccessTime);\r\n Result.LastWriteTime := FileTimeToLocalDateTime(FileAttributesEx.ftLastWriteTime);\r\n Result.Attributes := FileAttributesEx.dwFileAttributes;\r\n end;\r\nend;\r\n\r\nfunction TJclPeImage.GetHeaderValues(Index: TJclPeHeader): string;\r\n\r\n function GetMachineString(Value: DWORD): string;\r\n begin\r\n case Value of\r\n IMAGE_FILE_MACHINE_UNKNOWN:\r\n Result := LoadResString(@RsPeMACHINE_UNKNOWN);\r\n IMAGE_FILE_MACHINE_I386:\r\n Result := LoadResString(@RsPeMACHINE_I386);\r\n IMAGE_FILE_MACHINE_R3000:\r\n Result := LoadResString(@RsPeMACHINE_R3000);\r\n IMAGE_FILE_MACHINE_R4000:\r\n Result := LoadResString(@RsPeMACHINE_R4000);\r\n IMAGE_FILE_MACHINE_R10000:\r\n Result := LoadResString(@RsPeMACHINE_R10000);\r\n IMAGE_FILE_MACHINE_WCEMIPSV2:\r\n Result := LoadResString(@RsPeMACHINE_WCEMIPSV2);\r\n IMAGE_FILE_MACHINE_ALPHA:\r\n Result := LoadResString(@RsPeMACHINE_ALPHA);\r\n IMAGE_FILE_MACHINE_SH3:\r\n Result := LoadResString(@RsPeMACHINE_SH3); // SH3 little-endian\r\n IMAGE_FILE_MACHINE_SH3DSP:\r\n Result := LoadResString(@RsPeMACHINE_SH3DSP);\r\n IMAGE_FILE_MACHINE_SH3E:\r\n Result := LoadResString(@RsPeMACHINE_SH3E); // SH3E little-endian\r\n IMAGE_FILE_MACHINE_SH4:\r\n Result := LoadResString(@RsPeMACHINE_SH4); // SH4 little-endian\r\n IMAGE_FILE_MACHINE_SH5:\r\n Result := LoadResString(@RsPeMACHINE_SH5); // SH5\r\n IMAGE_FILE_MACHINE_ARM:\r\n Result := LoadResString(@RsPeMACHINE_ARM); // ARM Little-Endian\r\n IMAGE_FILE_MACHINE_THUMB:\r\n Result := LoadResString(@RsPeMACHINE_THUMB);\r\n IMAGE_FILE_MACHINE_AM33:\r\n Result := LoadResString(@RsPeMACHINE_AM33);\r\n IMAGE_FILE_MACHINE_POWERPC:\r\n Result := LoadResString(@RsPeMACHINE_POWERPC);\r\n IMAGE_FILE_MACHINE_POWERPCFP:\r\n Result := LoadResString(@RsPeMACHINE_POWERPCFP);\r\n IMAGE_FILE_MACHINE_IA64:\r\n Result := LoadResString(@RsPeMACHINE_IA64); // Intel 64\r\n IMAGE_FILE_MACHINE_MIPS16:\r\n Result := LoadResString(@RsPeMACHINE_MIPS16); // MIPS\r\n IMAGE_FILE_MACHINE_ALPHA64:\r\n Result := LoadResString(@RsPeMACHINE_AMPHA64); // ALPHA64\r\n //IMAGE_FILE_MACHINE_AXP64\r\n IMAGE_FILE_MACHINE_MIPSFPU:\r\n Result := LoadResString(@RsPeMACHINE_MIPSFPU); // MIPS\r\n IMAGE_FILE_MACHINE_MIPSFPU16:\r\n Result := LoadResString(@RsPeMACHINE_MIPSFPU16); // MIPS\r\n IMAGE_FILE_MACHINE_TRICORE:\r\n Result := LoadResString(@RsPeMACHINE_TRICORE); // Infineon\r\n IMAGE_FILE_MACHINE_CEF:\r\n Result := LoadResString(@RsPeMACHINE_CEF);\r\n IMAGE_FILE_MACHINE_EBC:\r\n Result := LoadResString(@RsPeMACHINE_EBC); // EFI Byte Code\r\n IMAGE_FILE_MACHINE_AMD64:\r\n Result := LoadResString(@RsPeMACHINE_AMD64); // AMD64 (K8)\r\n IMAGE_FILE_MACHINE_M32R:\r\n Result := LoadResString(@RsPeMACHINE_M32R); // M32R little-endian\r\n IMAGE_FILE_MACHINE_CEE:\r\n Result := LoadResString(@RsPeMACHINE_CEE);\r\n else\r\n Result := Format('[%.8x]', [Value]);\r\n end;\r\n end;\r\n\r\n function GetSubsystemString(Value: DWORD): string;\r\n begin\r\n case Value of\r\n IMAGE_SUBSYSTEM_UNKNOWN:\r\n Result := LoadResString(@RsPeSUBSYSTEM_UNKNOWN);\r\n IMAGE_SUBSYSTEM_NATIVE:\r\n Result := LoadResString(@RsPeSUBSYSTEM_NATIVE);\r\n IMAGE_SUBSYSTEM_WINDOWS_GUI:\r\n Result := LoadResString(@RsPeSUBSYSTEM_WINDOWS_GUI);\r\n IMAGE_SUBSYSTEM_WINDOWS_CUI:\r\n Result := LoadResString(@RsPeSUBSYSTEM_WINDOWS_CUI);\r\n IMAGE_SUBSYSTEM_OS2_CUI:\r\n Result := LoadResString(@RsPeSUBSYSTEM_OS2_CUI);\r\n IMAGE_SUBSYSTEM_POSIX_CUI:\r\n Result := LoadResString(@RsPeSUBSYSTEM_POSIX_CUI);\r\n IMAGE_SUBSYSTEM_RESERVED8:\r\n Result := LoadResString(@RsPeSUBSYSTEM_RESERVED8);\r\n else\r\n Result := Format('[%.8x]', [Value]);\r\n end;\r\n end;\r\n\r\n function GetHeaderValues32(Index: TJclPeHeader): string;\r\n var\r\n OptionalHeader: TImageOptionalHeader32;\r\n begin\r\n OptionalHeader := OptionalHeader32;\r\n case Index of\r\n JclPeHeader_Magic:\r\n Result := IntToHex(OptionalHeader.Magic, 4);\r\n JclPeHeader_LinkerVersion:\r\n Result := FormatVersionString(OptionalHeader.MajorLinkerVersion, OptionalHeader.MinorLinkerVersion);\r\n JclPeHeader_SizeOfCode:\r\n Result := IntToHex(OptionalHeader.SizeOfCode, 8);\r\n JclPeHeader_SizeOfInitializedData:\r\n Result := IntToHex(OptionalHeader.SizeOfInitializedData, 8);\r\n JclPeHeader_SizeOfUninitializedData:\r\n Result := IntToHex(OptionalHeader.SizeOfUninitializedData, 8);\r\n JclPeHeader_AddressOfEntryPoint:\r\n Result := IntToHex(OptionalHeader.AddressOfEntryPoint, 8);\r\n JclPeHeader_BaseOfCode:\r\n Result := IntToHex(OptionalHeader.BaseOfCode, 8);\r\n JclPeHeader_BaseOfData:\r\n {$IFDEF DELPHI64_TEMPORARY}\r\n System.Error(rePlatformNotImplemented);\r\n {$ELSE ~DELPHI64_TEMPORARY}\r\n Result := IntToHex(OptionalHeader.BaseOfData, 8);\r\n {$ENDIF ~DELPHI64_TEMPORARY}\r\n JclPeHeader_ImageBase:\r\n Result := IntToHex(OptionalHeader.ImageBase, 8);\r\n JclPeHeader_SectionAlignment:\r\n Result := IntToHex(OptionalHeader.SectionAlignment, 8);\r\n JclPeHeader_FileAlignment:\r\n Result := IntToHex(OptionalHeader.FileAlignment, 8);\r\n JclPeHeader_OperatingSystemVersion:\r\n Result := FormatVersionString(OptionalHeader.MajorOperatingSystemVersion, OptionalHeader.MinorOperatingSystemVersion);\r\n JclPeHeader_ImageVersion:\r\n Result := FormatVersionString(OptionalHeader.MajorImageVersion, OptionalHeader.MinorImageVersion);\r\n JclPeHeader_SubsystemVersion:\r\n Result := FormatVersionString(OptionalHeader.MajorSubsystemVersion, OptionalHeader.MinorSubsystemVersion);\r\n JclPeHeader_Win32VersionValue:\r\n Result := IntToHex(OptionalHeader.Win32VersionValue, 8);\r\n JclPeHeader_SizeOfImage:\r\n Result := IntToHex(OptionalHeader.SizeOfImage, 8);\r\n JclPeHeader_SizeOfHeaders:\r\n Result := IntToHex(OptionalHeader.SizeOfHeaders, 8);\r\n JclPeHeader_CheckSum:\r\n Result := IntToHex(OptionalHeader.CheckSum, 8);\r\n JclPeHeader_Subsystem:\r\n Result := GetSubsystemString(OptionalHeader.Subsystem);\r\n JclPeHeader_DllCharacteristics:\r\n Result := IntToHex(OptionalHeader.DllCharacteristics, 4);\r\n JclPeHeader_SizeOfStackReserve:\r\n Result := IntToHex(OptionalHeader.SizeOfStackReserve, 8);\r\n JclPeHeader_SizeOfStackCommit:\r\n Result := IntToHex(OptionalHeader.SizeOfStackCommit, 8);\r\n JclPeHeader_SizeOfHeapReserve:\r\n Result := IntToHex(OptionalHeader.SizeOfHeapReserve, 8);\r\n JclPeHeader_SizeOfHeapCommit:\r\n Result := IntToHex(OptionalHeader.SizeOfHeapCommit, 8);\r\n JclPeHeader_LoaderFlags:\r\n Result := IntToHex(OptionalHeader.LoaderFlags, 8);\r\n JclPeHeader_NumberOfRvaAndSizes:\r\n Result := IntToHex(OptionalHeader.NumberOfRvaAndSizes, 8);\r\n end;\r\n end;\r\n\r\n function GetHeaderValues64(Index: TJclPeHeader): string;\r\n var\r\n OptionalHeader: TImageOptionalHeader64;\r\n begin\r\n OptionalHeader := OptionalHeader64;\r\n case Index of\r\n JclPeHeader_Magic:\r\n Result := IntToHex(OptionalHeader.Magic, 4);\r\n JclPeHeader_LinkerVersion:\r\n Result := FormatVersionString(OptionalHeader.MajorLinkerVersion, OptionalHeader.MinorLinkerVersion);\r\n JclPeHeader_SizeOfCode:\r\n Result := IntToHex(OptionalHeader.SizeOfCode, 8);\r\n JclPeHeader_SizeOfInitializedData:\r\n Result := IntToHex(OptionalHeader.SizeOfInitializedData, 8);\r\n JclPeHeader_SizeOfUninitializedData:\r\n Result := IntToHex(OptionalHeader.SizeOfUninitializedData, 8);\r\n JclPeHeader_AddressOfEntryPoint:\r\n Result := IntToHex(OptionalHeader.AddressOfEntryPoint, 8);\r\n JclPeHeader_BaseOfCode:\r\n Result := IntToHex(OptionalHeader.BaseOfCode, 8);\r\n JclPeHeader_BaseOfData:\r\n Result := ''; // IntToHex(OptionalHeader.BaseOfData, 8);\r\n JclPeHeader_ImageBase:\r\n Result := IntToHex(OptionalHeader.ImageBase, 16);\r\n JclPeHeader_SectionAlignment:\r\n Result := IntToHex(OptionalHeader.SectionAlignment, 8);\r\n JclPeHeader_FileAlignment:\r\n Result := IntToHex(OptionalHeader.FileAlignment, 8);\r\n JclPeHeader_OperatingSystemVersion:\r\n Result := FormatVersionString(OptionalHeader.MajorOperatingSystemVersion, OptionalHeader.MinorOperatingSystemVersion);\r\n JclPeHeader_ImageVersion:\r\n Result := FormatVersionString(OptionalHeader.MajorImageVersion, OptionalHeader.MinorImageVersion);\r\n JclPeHeader_SubsystemVersion:\r\n Result := FormatVersionString(OptionalHeader.MajorSubsystemVersion, OptionalHeader.MinorSubsystemVersion);\r\n JclPeHeader_Win32VersionValue:\r\n Result := IntToHex(OptionalHeader.Win32VersionValue, 8);\r\n JclPeHeader_SizeOfImage:\r\n Result := IntToHex(OptionalHeader.SizeOfImage, 8);\r\n JclPeHeader_SizeOfHeaders:\r\n Result := IntToHex(OptionalHeader.SizeOfHeaders, 8);\r\n JclPeHeader_CheckSum:\r\n Result := IntToHex(OptionalHeader.CheckSum, 8);\r\n JclPeHeader_Subsystem:\r\n Result := GetSubsystemString(OptionalHeader.Subsystem);\r\n JclPeHeader_DllCharacteristics:\r\n Result := IntToHex(OptionalHeader.DllCharacteristics, 4);\r\n JclPeHeader_SizeOfStackReserve:\r\n Result := IntToHex(OptionalHeader.SizeOfStackReserve, 16);\r\n JclPeHeader_SizeOfStackCommit:\r\n Result := IntToHex(OptionalHeader.SizeOfStackCommit, 16);\r\n JclPeHeader_SizeOfHeapReserve:\r\n Result := IntToHex(OptionalHeader.SizeOfHeapReserve, 16);\r\n JclPeHeader_SizeOfHeapCommit:\r\n Result := IntToHex(OptionalHeader.SizeOfHeapCommit, 16);\r\n JclPeHeader_LoaderFlags:\r\n Result := IntToHex(OptionalHeader.LoaderFlags, 8);\r\n JclPeHeader_NumberOfRvaAndSizes:\r\n Result := IntToHex(OptionalHeader.NumberOfRvaAndSizes, 8);\r\n end;\r\n end;\r\n\r\nbegin\r\n if StatusOK then\r\n with FLoadedImage.FileHeader^ do\r\n case Index of\r\n JclPeHeader_Signature:\r\n Result := IntToHex(Signature, 8);\r\n JclPeHeader_Machine:\r\n Result := GetMachineString(FileHeader.Machine);\r\n JclPeHeader_NumberOfSections:\r\n Result := IntToHex(FileHeader.NumberOfSections, 4);\r\n JclPeHeader_TimeDateStamp:\r\n Result := IntToHex(FileHeader.TimeDateStamp, 8);\r\n JclPeHeader_PointerToSymbolTable:\r\n Result := IntToHex(FileHeader.PointerToSymbolTable, 8);\r\n JclPeHeader_NumberOfSymbols:\r\n Result := IntToHex(FileHeader.NumberOfSymbols, 8);\r\n JclPeHeader_SizeOfOptionalHeader:\r\n Result := IntToHex(FileHeader.SizeOfOptionalHeader, 4);\r\n JclPeHeader_Characteristics:\r\n Result := IntToHex(FileHeader.Characteristics, 4);\r\n JclPeHeader_Magic..JclPeHeader_NumberOfRvaAndSizes:\r\n case Target of\r\n taWin32:\r\n Result := GetHeaderValues32(Index);\r\n taWin64:\r\n Result := GetHeaderValues64(Index);\r\n //taUnknown:\r\n else\r\n Result := '';\r\n end;\r\n else\r\n Result := '';\r\n end\r\n else\r\n Result := '';\r\nend;\r\n\r\nfunction TJclPeImage.GetImageSectionCount: Integer;\r\nbegin\r\n Result := FImageSections.Count;\r\nend;\r\n\r\nfunction TJclPeImage.GetImageSectionFullNames(Index: Integer): string;\r\nvar\r\n Offset: Integer;\r\nbegin\r\n Result := ImageSectionNames[Index];\r\n if (Length(Result) > 0) and (Result[1] = '/') and TryStrToInt(Copy(Result, 2, MaxInt), Offset) then\r\n Result := GetNameInStringTable(Offset);\r\nend;\r\n\r\nfunction TJclPeImage.GetImageSectionHeaders(Index: Integer): TImageSectionHeader;\r\nbegin\r\n Result := PImageSectionHeader(FImageSections.Objects[Index])^;\r\nend;\r\n\r\nfunction TJclPeImage.GetImageSectionNameFromRva(const Rva: DWORD): string;\r\nbegin\r\n Result := GetSectionName(RvaToSection(Rva));\r\nend;\r\n\r\nfunction TJclPeImage.GetImageSectionNames(Index: Integer): string;\r\nbegin\r\n Result := FImageSections[Index];\r\nend;\r\n\r\nfunction TJclPeImage.GetImportList: TJclPeImportList;\r\nbegin\r\n if FImportList = nil then\r\n FImportList := TJclPeImportList.Create(Self);\r\n Result := FImportList;\r\nend;\r\n\r\nfunction TJclPeImage.GetLoadConfigValues(Index: TJclLoadConfig): string;\r\n function GetLoadConfigValues32(Index: TJclLoadConfig): string;\r\n var\r\n LoadConfig: PIMAGE_LOAD_CONFIG_DIRECTORY32;\r\n begin\r\n LoadConfig := DirectoryEntryToData(IMAGE_DIRECTORY_ENTRY_LOAD_CONFIG);\r\n if LoadConfig <> nil then\r\n with LoadConfig^ do\r\n case Index of\r\n JclLoadConfig_Characteristics:\r\n Result := IntToHex(Size, 8);\r\n JclLoadConfig_TimeDateStamp:\r\n Result := IntToHex(TimeDateStamp, 8);\r\n JclLoadConfig_Version:\r\n Result := FormatVersionString(MajorVersion, MinorVersion);\r\n JclLoadConfig_GlobalFlagsClear:\r\n Result := IntToHex(GlobalFlagsClear, 8);\r\n JclLoadConfig_GlobalFlagsSet:\r\n Result := IntToHex(GlobalFlagsSet, 8);\r\n JclLoadConfig_CriticalSectionDefaultTimeout:\r\n Result := IntToHex(CriticalSectionDefaultTimeout, 8);\r\n JclLoadConfig_DeCommitFreeBlockThreshold:\r\n Result := IntToHex(DeCommitFreeBlockThreshold, 8);\r\n JclLoadConfig_DeCommitTotalFreeThreshold:\r\n Result := IntToHex(DeCommitTotalFreeThreshold, 8);\r\n JclLoadConfig_LockPrefixTable:\r\n Result := IntToHex(LockPrefixTable, 8);\r\n JclLoadConfig_MaximumAllocationSize:\r\n Result := IntToHex(MaximumAllocationSize, 8);\r\n JclLoadConfig_VirtualMemoryThreshold:\r\n Result := IntToHex(VirtualMemoryThreshold, 8);\r\n JclLoadConfig_ProcessHeapFlags:\r\n Result := IntToHex(ProcessHeapFlags, 8);\r\n JclLoadConfig_ProcessAffinityMask:\r\n Result := IntToHex(ProcessAffinityMask, 8);\r\n JclLoadConfig_CSDVersion:\r\n Result := IntToHex(CSDVersion, 4);\r\n JclLoadConfig_Reserved1:\r\n Result := IntToHex(Reserved1, 4);\r\n JclLoadConfig_EditList:\r\n Result := IntToHex(EditList, 8);\r\n JclLoadConfig_Reserved:\r\n Result := LoadResString(@RsPeReserved);\r\n end;\r\n end;\r\n function GetLoadConfigValues64(Index: TJclLoadConfig): string;\r\n var\r\n LoadConfig: PIMAGE_LOAD_CONFIG_DIRECTORY64;\r\n begin\r\n LoadConfig := DirectoryEntryToData(IMAGE_DIRECTORY_ENTRY_LOAD_CONFIG);\r\n if LoadConfig <> nil then\r\n with LoadConfig^ do\r\n case Index of\r\n JclLoadConfig_Characteristics:\r\n Result := IntToHex(Size, 8);\r\n JclLoadConfig_TimeDateStamp:\r\n Result := IntToHex(TimeDateStamp, 8);\r\n JclLoadConfig_Version:\r\n Result := FormatVersionString(MajorVersion, MinorVersion);\r\n JclLoadConfig_GlobalFlagsClear:\r\n Result := IntToHex(GlobalFlagsClear, 8);\r\n JclLoadConfig_GlobalFlagsSet:\r\n Result := IntToHex(GlobalFlagsSet, 8);\r\n JclLoadConfig_CriticalSectionDefaultTimeout:\r\n Result := IntToHex(CriticalSectionDefaultTimeout, 8);\r\n JclLoadConfig_DeCommitFreeBlockThreshold:\r\n Result := IntToHex(DeCommitFreeBlockThreshold, 16);\r\n JclLoadConfig_DeCommitTotalFreeThreshold:\r\n Result := IntToHex(DeCommitTotalFreeThreshold, 16);\r\n JclLoadConfig_LockPrefixTable:\r\n Result := IntToHex(LockPrefixTable, 16);\r\n JclLoadConfig_MaximumAllocationSize:\r\n Result := IntToHex(MaximumAllocationSize, 16);\r\n JclLoadConfig_VirtualMemoryThreshold:\r\n Result := IntToHex(VirtualMemoryThreshold, 16);\r\n JclLoadConfig_ProcessHeapFlags:\r\n Result := IntToHex(ProcessHeapFlags, 8);\r\n JclLoadConfig_ProcessAffinityMask:\r\n Result := IntToHex(ProcessAffinityMask, 16);\r\n JclLoadConfig_CSDVersion:\r\n Result := IntToHex(CSDVersion, 4);\r\n JclLoadConfig_Reserved1:\r\n Result := IntToHex(Reserved1, 4);\r\n JclLoadConfig_EditList:\r\n Result := IntToHex(EditList, 16);\r\n JclLoadConfig_Reserved:\r\n Result := LoadResString(@RsPeReserved);\r\n end;\r\n end;\r\nbegin\r\n Result := '';\r\n case Target of\r\n taWin32:\r\n Result := GetLoadConfigValues32(Index);\r\n taWin64:\r\n Result := GetLoadConfigValues64(Index);\r\n end;\r\nend;\r\n\r\nfunction TJclPeImage.GetMappedAddress: TJclAddr;\r\nbegin\r\n if StatusOK then\r\n Result := TJclAddr(LoadedImage.MappedAddress)\r\n else\r\n Result := 0;\r\nend;\r\n\r\nfunction TJclPeImage.GetNameInStringTable(Offset: ULONG): string;\r\nvar\r\n Index: Integer;\r\nbegin\r\n Dec(Offset, SizeOf(ULONG));\r\n Index := 0;\r\n while (Offset > 0) and (Index < FStringTable.Count) do\r\n begin\r\n Dec(Offset, Length(FStringTable[Index]) + 1);\r\n if Offset > 0 then\r\n Inc(Index);\r\n end;\r\n\r\n if Offset = 0 then\r\n Result := FStringTable[Index]\r\n else\r\n Result := '';\r\nend;\r\n\r\nfunction TJclPeImage.GetOptionalHeader32: TImageOptionalHeader32;\r\nbegin\r\n if Target = taWin32 then\r\n Result := PImageNtHeaders32(FLoadedImage.FileHeader)^.OptionalHeader\r\n else\r\n ZeroMemory(@Result, SizeOf(Result));\r\nend;\r\n\r\nfunction TJclPeImage.GetOptionalHeader64: TImageOptionalHeader64;\r\nbegin\r\n if Target = taWin64 then\r\n Result := PImageNtHeaders64(FLoadedImage.FileHeader)^.OptionalHeader\r\n else\r\n ZeroMemory(@Result, SizeOf(Result));\r\nend;\r\n\r\nfunction TJclPeImage.GetRelocationList: TJclPeRelocList;\r\nbegin\r\n if FRelocationList = nil then\r\n FRelocationList := TJclPeRelocList.Create(Self);\r\n Result := FRelocationList;\r\nend;\r\n\r\nfunction TJclPeImage.GetResourceList: TJclPeRootResourceList;\r\nbegin\r\n if FResourceList = nil then\r\n begin\r\n FResourceVA := Directories[IMAGE_DIRECTORY_ENTRY_RESOURCE].VirtualAddress;\r\n if FResourceVA <> 0 then\r\n FResourceVA := TJclAddr(RvaToVa(FResourceVA));\r\n FResourceList := TJclPeRootResourceList.Create(Self, nil, PImageResourceDirectory(FResourceVA));\r\n end;\r\n Result := FResourceList;\r\nend;\r\n\r\nfunction TJclPeImage.GetSectionHeader(const SectionName: string;\r\n out Header: PImageSectionHeader): Boolean;\r\nvar\r\n I: Integer;\r\nbegin\r\n I := FImageSections.IndexOf(SectionName);\r\n if I = -1 then\r\n begin\r\n Header := nil;\r\n Result := False;\r\n end\r\n else\r\n begin\r\n Header := PImageSectionHeader(FImageSections.Objects[I]);\r\n Result := True;\r\n end;\r\nend;\r\n\r\nfunction TJclPeImage.GetSectionName(Header: PImageSectionHeader): string;\r\nvar\r\n I: Integer;\r\nbegin\r\n I := FImageSections.IndexOfObject(TObject(Header));\r\n if I = -1 then\r\n Result := ''\r\n else\r\n Result := FImageSections[I];\r\nend;\r\n\r\nfunction TJclPeImage.GetStringTableCount: Integer;\r\nbegin\r\n Result := FStringTable.Count;\r\nend;\r\n\r\nfunction TJclPeImage.GetStringTableItem(Index: Integer): string;\r\nbegin\r\n Result := FStringTable[Index];\r\nend;\r\n\r\nfunction TJclPeImage.GetUnusedHeaderBytes: TImageDataDirectory;\r\nbegin\r\n CheckNotAttached;\r\n Result.Size := 0;\r\n Result.VirtualAddress := GetImageUnusedHeaderBytes(FLoadedImage, Result.Size);\r\n if Result.VirtualAddress = 0 then\r\n RaiseLastOSError;\r\nend;\r\n\r\nfunction TJclPeImage.GetVersionInfo: TJclFileVersionInfo;\r\nvar\r\n VersionInfoResource: TJclPeResourceItem;\r\nbegin\r\n if (FVersionInfo = nil) and VersionInfoAvailable then\r\n begin\r\n VersionInfoResource := ResourceList.FindResource(rtVersion, '1').List[0];\r\n with VersionInfoResource do\r\n try\r\n FVersionInfo := TJclFileVersionInfo.Attach(RawEntryData, RawEntryDataSize);\r\n except\r\n FreeAndNil(FVersionInfo);\r\n end;\r\n end;\r\n Result := FVersionInfo;\r\nend;\r\n\r\nfunction TJclPeImage.GetVersionInfoAvailable: Boolean;\r\nbegin\r\n Result := StatusOK and (ResourceList.FindResource(rtVersion, '1') <> nil);\r\nend;\r\n\r\nclass function TJclPeImage.HeaderNames(Index: TJclPeHeader): string;\r\nbegin\r\n case Index of\r\n JclPeHeader_Signature:\r\n Result := LoadResString(@RsPeSignature);\r\n JclPeHeader_Machine:\r\n Result := LoadResString(@RsPeMachine);\r\n JclPeHeader_NumberOfSections:\r\n Result := LoadResString(@RsPeNumberOfSections);\r\n JclPeHeader_TimeDateStamp:\r\n Result := LoadResString(@RsPeTimeDateStamp);\r\n JclPeHeader_PointerToSymbolTable:\r\n Result := LoadResString(@RsPePointerToSymbolTable);\r\n JclPeHeader_NumberOfSymbols:\r\n Result := LoadResString(@RsPeNumberOfSymbols);\r\n JclPeHeader_SizeOfOptionalHeader:\r\n Result := LoadResString(@RsPeSizeOfOptionalHeader);\r\n JclPeHeader_Characteristics:\r\n Result := LoadResString(@RsPeCharacteristics);\r\n JclPeHeader_Magic:\r\n Result := LoadResString(@RsPeMagic);\r\n JclPeHeader_LinkerVersion:\r\n Result := LoadResString(@RsPeLinkerVersion);\r\n JclPeHeader_SizeOfCode:\r\n Result := LoadResString(@RsPeSizeOfCode);\r\n JclPeHeader_SizeOfInitializedData:\r\n Result := LoadResString(@RsPeSizeOfInitializedData);\r\n JclPeHeader_SizeOfUninitializedData:\r\n Result := LoadResString(@RsPeSizeOfUninitializedData);\r\n JclPeHeader_AddressOfEntryPoint:\r\n Result := LoadResString(@RsPeAddressOfEntryPoint);\r\n JclPeHeader_BaseOfCode:\r\n Result := LoadResString(@RsPeBaseOfCode);\r\n JclPeHeader_BaseOfData:\r\n Result := LoadResString(@RsPeBaseOfData);\r\n JclPeHeader_ImageBase:\r\n Result := LoadResString(@RsPeImageBase);\r\n JclPeHeader_SectionAlignment:\r\n Result := LoadResString(@RsPeSectionAlignment);\r\n JclPeHeader_FileAlignment:\r\n Result := LoadResString(@RsPeFileAlignment);\r\n JclPeHeader_OperatingSystemVersion:\r\n Result := LoadResString(@RsPeOperatingSystemVersion);\r\n JclPeHeader_ImageVersion:\r\n Result := LoadResString(@RsPeImageVersion);\r\n JclPeHeader_SubsystemVersion:\r\n Result := LoadResString(@RsPeSubsystemVersion);\r\n JclPeHeader_Win32VersionValue:\r\n Result := LoadResString(@RsPeWin32VersionValue);\r\n JclPeHeader_SizeOfImage:\r\n Result := LoadResString(@RsPeSizeOfImage);\r\n JclPeHeader_SizeOfHeaders:\r\n Result := LoadResString(@RsPeSizeOfHeaders);\r\n JclPeHeader_CheckSum:\r\n Result := LoadResString(@RsPeCheckSum);\r\n JclPeHeader_Subsystem:\r\n Result := LoadResString(@RsPeSubsystem);\r\n JclPeHeader_DllCharacteristics:\r\n Result := LoadResString(@RsPeDllCharacteristics);\r\n JclPeHeader_SizeOfStackReserve:\r\n Result := LoadResString(@RsPeSizeOfStackReserve);\r\n JclPeHeader_SizeOfStackCommit:\r\n Result := LoadResString(@RsPeSizeOfStackCommit);\r\n JclPeHeader_SizeOfHeapReserve:\r\n Result := LoadResString(@RsPeSizeOfHeapReserve);\r\n JclPeHeader_SizeOfHeapCommit:\r\n Result := LoadResString(@RsPeSizeOfHeapCommit);\r\n JclPeHeader_LoaderFlags:\r\n Result := LoadResString(@RsPeLoaderFlags);\r\n JclPeHeader_NumberOfRvaAndSizes:\r\n Result := LoadResString(@RsPeNumberOfRvaAndSizes);\r\n else\r\n Result := '';\r\n end;\r\nend;\r\n\r\nfunction TJclPeImage.IsBrokenFormat: Boolean;\r\n function IsBrokenFormat32: Boolean;\r\n var\r\n OptionalHeader: TImageOptionalHeader32;\r\n begin\r\n OptionalHeader := OptionalHeader32;\r\n Result := not ((OptionalHeader.AddressOfEntryPoint = 0) or IsCLR);\r\n if Result then\r\n begin\r\n Result := (ImageSectionCount = 0);\r\n if not Result then\r\n with ImageSectionHeaders[0] do\r\n Result := (VirtualAddress <> OptionalHeader.BaseOfCode) or (SizeOfRawData = 0) or\r\n (OptionalHeader.AddressOfEntryPoint > VirtualAddress + Misc.VirtualSize) or\r\n (Characteristics and (IMAGE_SCN_CNT_CODE or IMAGE_SCN_MEM_WRITE) <> IMAGE_SCN_CNT_CODE);\r\n end;\r\n end;\r\n function IsBrokenFormat64: Boolean;\r\n var\r\n OptionalHeader: TImageOptionalHeader64;\r\n begin\r\n OptionalHeader := OptionalHeader64;\r\n Result := not ((OptionalHeader.AddressOfEntryPoint = 0) or IsCLR);\r\n if Result then\r\n begin\r\n Result := (ImageSectionCount = 0);\r\n if not Result then\r\n with ImageSectionHeaders[0] do\r\n Result := (VirtualAddress <> OptionalHeader.BaseOfCode) or (SizeOfRawData = 0) or\r\n (OptionalHeader.AddressOfEntryPoint > VirtualAddress + Misc.VirtualSize) or\r\n (Characteristics and (IMAGE_SCN_CNT_CODE or IMAGE_SCN_MEM_WRITE) <> IMAGE_SCN_CNT_CODE);\r\n end;\r\n end;\r\nbegin\r\n case Target of\r\n taWin32:\r\n Result := IsBrokenFormat32;\r\n taWin64:\r\n Result := IsBrokenFormat64;\r\n //taUnknown:\r\n else\r\n Result := False; // don't know how to check it\r\n end;\r\nend;\r\n\r\nfunction TJclPeImage.IsCLR: Boolean;\r\nbegin\r\n Result := DirectoryExists[IMAGE_DIRECTORY_ENTRY_COM_DESCRIPTOR] and CLRHeader.HasMetadata;\r\nend;\r\n\r\nfunction TJclPeImage.IsSystemImage: Boolean;\r\nbegin\r\n Result := StatusOK and FLoadedImage.fSystemImage;\r\nend;\r\n\r\nclass function TJclPeImage.LoadConfigNames(Index: TJclLoadConfig): string;\r\nbegin\r\n case Index of\r\n JclLoadConfig_Characteristics:\r\n Result := LoadResString(@RsPeCharacteristics);\r\n JclLoadConfig_TimeDateStamp:\r\n Result := LoadResString(@RsPeTimeDateStamp);\r\n JclLoadConfig_Version:\r\n Result := LoadResString(@RsPeVersion);\r\n JclLoadConfig_GlobalFlagsClear:\r\n Result := LoadResString(@RsPeGlobalFlagsClear);\r\n JclLoadConfig_GlobalFlagsSet:\r\n Result := LoadResString(@RsPeGlobalFlagsSet);\r\n JclLoadConfig_CriticalSectionDefaultTimeout:\r\n Result := LoadResString(@RsPeCriticalSectionDefaultTimeout);\r\n JclLoadConfig_DeCommitFreeBlockThreshold:\r\n Result := LoadResString(@RsPeDeCommitFreeBlockThreshold);\r\n JclLoadConfig_DeCommitTotalFreeThreshold:\r\n Result := LoadResString(@RsPeDeCommitTotalFreeThreshold);\r\n JclLoadConfig_LockPrefixTable:\r\n Result := LoadResString(@RsPeLockPrefixTable);\r\n JclLoadConfig_MaximumAllocationSize:\r\n Result := LoadResString(@RsPeMaximumAllocationSize);\r\n JclLoadConfig_VirtualMemoryThreshold:\r\n Result := LoadResString(@RsPeVirtualMemoryThreshold);\r\n JclLoadConfig_ProcessHeapFlags:\r\n Result := LoadResString(@RsPeProcessHeapFlags);\r\n JclLoadConfig_ProcessAffinityMask:\r\n Result := LoadResString(@RsPeProcessAffinityMask);\r\n JclLoadConfig_CSDVersion:\r\n Result := LoadResString(@RsPeCSDVersion);\r\n JclLoadConfig_Reserved1:\r\n Result := LoadResString(@RsPeReserved);\r\n JclLoadConfig_EditList:\r\n Result := LoadResString(@RsPeEditList);\r\n JclLoadConfig_Reserved:\r\n Result := LoadResString(@RsPeReserved);\r\n else\r\n Result := '';\r\n end;\r\nend;\r\n\r\nprocedure TJclPeImage.RaiseStatusException;\r\nbegin\r\n if not FNoExceptions then\r\n case FStatus of\r\n stNotPE:\r\n raise EJclPeImageError.CreateRes(@RsPeNotPE);\r\n stNotFound:\r\n raise EJclPeImageError.CreateResFmt(@RsPeCantOpen, [FFileName]);\r\n stNotSupported:\r\n raise EJclPeImageError.CreateRes(@RsPeUnknownTarget);\r\n stError:\r\n RaiseLastOSError;\r\n end;\r\nend;\r\n\r\nfunction TJclPeImage.RawToVa(Raw: DWORD): Pointer;\r\nbegin\r\n Result := Pointer(TJclAddr(FLoadedImage.MappedAddress) + Raw);\r\nend;\r\n\r\nprocedure TJclPeImage.ReadImageSections;\r\nvar\r\n I: Integer;\r\n Header: PImageSectionHeader;\r\n UTF8Name: TUTF8String;\r\n SectionName: string;\r\nbegin\r\n if not StatusOK then\r\n Exit;\r\n Header := FLoadedImage.Sections;\r\n for I := 0 to FLoadedImage.NumberOfSections - 1 do\r\n begin\r\n SetLength(UTF8Name, IMAGE_SIZEOF_SHORT_NAME);\r\n Move(Header.Name[0], UTF8Name[1], IMAGE_SIZEOF_SHORT_NAME * SizeOf(AnsiChar));\r\n StrResetLength(UTF8Name);\r\n if not TryUTF8ToString(UTF8Name, SectionName) then\r\n SectionName := string(UTF8Name);\r\n FImageSections.AddObject(SectionName, Pointer(Header));\r\n Inc(Header);\r\n end;\r\nend;\r\n\r\nprocedure TJclPeImage.ReadStringTable;\r\nvar\r\n SymbolTable: DWORD;\r\n StringTablePtr: PAnsiChar;\r\n Ptr: PAnsiChar;\r\n ByteSize: ULONG;\r\n Start: PAnsiChar;\r\n StringEntry: AnsiString;\r\nbegin\r\n SymbolTable := LoadedImage.FileHeader.FileHeader.PointerToSymbolTable;\r\n if SymbolTable = 0 then\r\n Exit;\r\n\r\n StringTablePtr := PAnsiChar(LoadedImage.MappedAddress) +\r\n SymbolTable +\r\n (LoadedImage.FileHeader.FileHeader.NumberOfSymbols * SizeOf(IMAGE_SYMBOL));\r\n\r\n ByteSize := PULONG(StringTablePtr)^;\r\n Ptr := StringTablePtr + SizeOf(ByteSize);\r\n\r\n while Ptr < StringTablePtr + ByteSize do\r\n begin\r\n Start := Ptr;\r\n while (Ptr^ <> #0) and (Ptr < StringTablePtr + ByteSize) do\r\n Inc(Ptr);\r\n if Start <> Ptr then\r\n begin\r\n SetLength(StringEntry, Ptr - Start);\r\n Move(Start^, StringEntry[1], Ptr - Start);\r\n FStringTable.Add(string(StringEntry));\r\n end;\r\n Inc(Ptr); // to skip the #0 character\r\n end;\r\nend;\r\n\r\nfunction TJclPeImage.ResourceItemCreate(AEntry: PImageResourceDirectoryEntry;\r\n AParentItem: TJclPeResourceItem): TJclPeResourceItem;\r\nbegin\r\n Result := TJclPeResourceItem.Create(Self, AParentItem, AEntry);\r\nend;\r\n\r\nfunction TJclPeImage.ResourceListCreate(ADirectory: PImageResourceDirectory;\r\n AParentItem: TJclPeResourceItem): TJclPeResourceList;\r\nbegin\r\n Result := TJclPeResourceList.Create(Self, AParentItem, ADirectory);\r\nend;\r\n\r\nfunction TJclPeImage.RvaToSection(Rva: DWORD): PImageSectionHeader;\r\nvar\r\n I: Integer;\r\n SectionHeader: PImageSectionHeader;\r\n EndRVA: DWORD;\r\nbegin\r\n Result := ImageRvaToSection(FLoadedImage.FileHeader, FLoadedImage.MappedAddress, Rva);\r\n if Result = nil then\r\n for I := 0 to FImageSections.Count - 1 do\r\n begin\r\n SectionHeader := PImageSectionHeader(FImageSections.Objects[I]);\r\n if SectionHeader^.SizeOfRawData = 0 then\r\n EndRVA := SectionHeader^.Misc.VirtualSize\r\n else\r\n EndRVA := SectionHeader^.SizeOfRawData;\r\n Inc(EndRVA, SectionHeader^.VirtualAddress);\r\n if (SectionHeader^.VirtualAddress <= Rva) and (EndRVA >= Rva) then\r\n begin\r\n Result := SectionHeader;\r\n Break;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJclPeImage.RvaToVa(Rva: DWORD): Pointer;\r\nbegin\r\n if FAttachedImage then\r\n Result := Pointer(TJclAddr(FLoadedImage.MappedAddress) + Rva)\r\n else\r\n Result := ImageRvaToVa(FLoadedImage.FileHeader, FLoadedImage.MappedAddress, Rva, nil);\r\nend;\r\n\r\nfunction TJclPeImage.RvaToVaEx(Rva: DWORD): Pointer;\r\n function RvaToVaEx32(Rva: DWORD): Pointer;\r\n var\r\n OptionalHeader: TImageOptionalHeader32;\r\n begin\r\n OptionalHeader := OptionalHeader32;\r\n if (Rva >= OptionalHeader.ImageBase) and (Rva < (OptionalHeader.ImageBase + FLoadedImage.SizeOfImage)) then\r\n Dec(Rva, OptionalHeader.ImageBase);\r\n Result := RvaToVa(Rva);\r\n end;\r\n function RvaToVaEx64(Rva: DWORD): Pointer;\r\n var\r\n OptionalHeader: TImageOptionalHeader64;\r\n begin\r\n OptionalHeader := OptionalHeader64;\r\n if (Rva >= OptionalHeader.ImageBase) and (Rva < (OptionalHeader.ImageBase + FLoadedImage.SizeOfImage)) then\r\n Dec(Rva, OptionalHeader.ImageBase);\r\n Result := RvaToVa(Rva);\r\n end;\r\nbegin\r\n case Target of\r\n taWin32:\r\n Result := RvaToVaEx32(Rva);\r\n taWin64:\r\n Result := RvaToVaEx64(Rva);\r\n //taUnknown:\r\n else\r\n Result := nil;\r\n end;\r\nend;\r\n\r\nprocedure TJclPeImage.SetFileName(const Value: TFileName);\r\nbegin\r\n if FFileName <> Value then\r\n begin\r\n Clear;\r\n FFileName := Value;\r\n if FFileName = '' then\r\n Exit;\r\n // OF: possible loss of data\r\n if MapAndLoad(PAnsiChar(AnsiString(FFileName)), nil, FLoadedImage, True, FReadOnlyAccess) then\r\n begin\r\n FTarget := PeMapImgTarget(FLoadedImage.MappedAddress);\r\n if FTarget <> taUnknown then\r\n begin\r\n FStatus := stOk;\r\n ReadImageSections;\r\n ReadStringTable;\r\n AfterOpen;\r\n end\r\n else\r\n FStatus := stNotSupported;\r\n end\r\n else\r\n case GetLastError of\r\n ERROR_SUCCESS:\r\n FStatus := stNotPE;\r\n ERROR_FILE_NOT_FOUND:\r\n FStatus := stNotFound;\r\n else\r\n FStatus := stError;\r\n end;\r\n RaiseStatusException;\r\n end;\r\nend;\r\n\r\nclass function TJclPeImage.ShortSectionInfo(Characteristics: DWORD): string;\r\ntype\r\n TSectionCharacteristics = packed record\r\n Mask: DWORD;\r\n InfoChar: Char;\r\n end;\r\nconst\r\n Info: array [1..8] of TSectionCharacteristics = (\r\n (Mask: IMAGE_SCN_CNT_CODE; InfoChar: 'C'),\r\n (Mask: IMAGE_SCN_MEM_EXECUTE; InfoChar: 'E'),\r\n (Mask: IMAGE_SCN_MEM_READ; InfoChar: 'R'),\r\n (Mask: IMAGE_SCN_MEM_WRITE; InfoChar: 'W'),\r\n (Mask: IMAGE_SCN_CNT_INITIALIZED_DATA; InfoChar: 'I'),\r\n (Mask: IMAGE_SCN_CNT_UNINITIALIZED_DATA; InfoChar: 'U'),\r\n (Mask: IMAGE_SCN_MEM_SHARED; InfoChar: 'S'),\r\n (Mask: IMAGE_SCN_MEM_DISCARDABLE; InfoChar: 'D')\r\n );\r\nvar\r\n I: Integer;\r\nbegin\r\n SetLength(Result, High(Info));\r\n Result := '';\r\n for I := Low(Info) to High(Info) do\r\n with Info[I] do\r\n if (Characteristics and Mask) = Mask then\r\n Result := Result + InfoChar;\r\nend;\r\n\r\nfunction TJclPeImage.StatusOK: Boolean;\r\nbegin\r\n Result := (FStatus = stOk);\r\nend;\r\n\r\nclass function TJclPeImage.StampToDateTime(TimeDateStamp: DWORD): TDateTime;\r\nbegin\r\n Result := TimeDateStamp / SecsPerDay + UnixTimeStart\r\nend;\r\n\r\nprocedure TJclPeImage.TryGetNamesForOrdinalImports;\r\nbegin\r\n if StatusOK then\r\n begin\r\n GetImportList;\r\n FImportList.TryGetNamesForOrdinalImports;\r\n end;\r\nend;\r\n\r\nfunction TJclPeImage.VerifyCheckSum: Boolean;\r\n function VerifyCheckSum32: Boolean;\r\n var\r\n OptionalHeader: TImageOptionalHeader32;\r\n begin\r\n OptionalHeader := OptionalHeader32;\r\n Result := StatusOK and ((OptionalHeader.CheckSum = 0) or (CalculateCheckSum = OptionalHeader.CheckSum));\r\n end;\r\n function VerifyCheckSum64: Boolean;\r\n var\r\n OptionalHeader: TImageOptionalHeader64;\r\n begin\r\n OptionalHeader := OptionalHeader64;\r\n Result := StatusOK and ((OptionalHeader.CheckSum = 0) or (CalculateCheckSum = OptionalHeader.CheckSum));\r\n end;\r\nbegin\r\n CheckNotAttached;\r\n case Target of\r\n taWin32:\r\n Result := VerifyCheckSum32;\r\n taWin64:\r\n Result := VerifyCheckSum64;\r\n //taUnknown: ;\r\n else\r\n Result := True;\r\n end;\r\nend;\r\n\r\n{$IFDEF BORLAND}\r\n\r\n//=== { TJclPeBorImagesCache } ===============================================\r\n\r\nfunction TJclPeBorImagesCache.GetImages(const FileName: TFileName): TJclPeBorImage;\r\nbegin\r\n Result := TJclPeBorImage(inherited Images[FileName]);\r\nend;\r\n\r\nfunction TJclPeBorImagesCache.GetPeImageClass: TJclPeImageClass;\r\nbegin\r\n Result := TJclPeBorImage;\r\nend;\r\n\r\n//=== { TJclPePackageInfo } ==================================================\r\n\r\nconstructor TJclPePackageInfo.Create(ALibHandle: THandle);\r\nbegin\r\n FContains := TStringList.Create;\r\n FRequires := TStringList.Create;\r\n FEnsureExtension := True;\r\n FSorted := True;\r\n ReadPackageInfo(ALibHandle);\r\nend;\r\n\r\ndestructor TJclPePackageInfo.Destroy;\r\nbegin\r\n FreeAndNil(FContains);\r\n FreeAndNil(FRequires);\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJclPePackageInfo.GetContains: TStrings;\r\nbegin\r\n Result := FContains;\r\nend;\r\n\r\nfunction TJclPePackageInfo.GetContainsCount: Integer;\r\nbegin\r\n Result := Contains.Count;\r\nend;\r\n\r\nfunction TJclPePackageInfo.GetContainsFlags(Index: Integer): Byte;\r\nbegin\r\n Result := Byte(Contains.Objects[Index]);\r\nend;\r\n\r\nfunction TJclPePackageInfo.GetContainsNames(Index: Integer): string;\r\nbegin\r\n Result := Contains[Index];\r\nend;\r\n\r\nfunction TJclPePackageInfo.GetRequires: TStrings;\r\nbegin\r\n Result := FRequires;\r\nend;\r\n\r\nfunction TJclPePackageInfo.GetRequiresCount: Integer;\r\nbegin\r\n Result := Requires.Count;\r\nend;\r\n\r\nfunction TJclPePackageInfo.GetRequiresNames(Index: Integer): string;\r\nbegin\r\n Result := Requires[Index];\r\n if FEnsureExtension then\r\n StrEnsureSuffix(BinaryExtensionPackage, Result);\r\nend;\r\n\r\nclass function TJclPePackageInfo.PackageModuleTypeToString(Flags: Cardinal): string;\r\nbegin\r\n case Flags and pfModuleTypeMask of\r\n pfExeModule, pfModuleTypeMask:\r\n Result := LoadResString(@RsPePkgExecutable);\r\n pfPackageModule:\r\n Result := LoadResString(@RsPePkgPackage);\r\n pfLibraryModule:\r\n Result := LoadResString(@PsPePkgLibrary);\r\n else\r\n Result := '';\r\n end;\r\nend;\r\n\r\nclass function TJclPePackageInfo.PackageOptionsToString(Flags: Cardinal): string;\r\nbegin\r\n Result := '';\r\n AddFlagTextRes(Result, @RsPePkgNeverBuild, Flags, pfNeverBuild);\r\n AddFlagTextRes(Result, @RsPePkgDesignOnly, Flags, pfDesignOnly);\r\n AddFlagTextRes(Result, @RsPePkgRunOnly, Flags, pfRunOnly);\r\n AddFlagTextRes(Result, @RsPePkgIgnoreDupUnits, Flags, pfIgnoreDupUnits);\r\nend;\r\n\r\nclass function TJclPePackageInfo.ProducerToString(Flags: Cardinal): string;\r\nbegin\r\n case Flags and pfProducerMask of\r\n pfV3Produced:\r\n Result := LoadResString(@RsPePkgV3Produced);\r\n pfProducerUndefined:\r\n Result := LoadResString(@RsPePkgProducerUndefined);\r\n pfBCB4Produced:\r\n Result := LoadResString(@RsPePkgBCB4Produced);\r\n pfDelphi4Produced:\r\n Result := LoadResString(@RsPePkgDelphi4Produced);\r\n else\r\n Result := '';\r\n end;\r\nend;\r\n\r\nprocedure PackageInfoProc(const Name: string; NameType: TNameType; AFlags: Byte; Param: Pointer);\r\nbegin\r\n with TJclPePackageInfo(Param) do\r\n case NameType of\r\n ntContainsUnit:\r\n Contains.AddObject(Name, Pointer(AFlags));\r\n ntRequiresPackage:\r\n Requires.Add(Name);\r\n ntDcpBpiName:\r\n SetDcpName(Name);\r\n end;\r\nend;\r\n\r\nprocedure TJclPePackageInfo.ReadPackageInfo(ALibHandle: THandle);\r\nvar\r\n DescrResInfo: HRSRC;\r\n DescrResData: HGLOBAL;\r\nbegin\r\n FAvailable := FindResource(ALibHandle, PackageInfoResName, RT_RCDATA) <> 0;\r\n if FAvailable then\r\n begin\r\n GetPackageInfo(ALibHandle, Self, FFlags, PackageInfoProc);\r\n if FDcpName = '' then\r\n FDcpName := PathExtractFileNameNoExt(GetModulePath(ALibHandle)) + CompilerExtensionDCP;\r\n if FSorted then\r\n begin\r\n FContains.Sort;\r\n FRequires.Sort;\r\n end;\r\n end;\r\n DescrResInfo := FindResource(ALibHandle, DescriptionResName, RT_RCDATA);\r\n if DescrResInfo <> 0 then\r\n begin\r\n DescrResData := LoadResource(ALibHandle, DescrResInfo);\r\n if DescrResData <> 0 then\r\n begin\r\n FDescription := WideCharLenToString(LockResource(DescrResData),\r\n SizeofResource(ALibHandle, DescrResInfo));\r\n StrResetLength(FDescription);\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJclPePackageInfo.SetDcpName(const Value: string);\r\nbegin\r\n FDcpName := Value;\r\nend;\r\n\r\nclass function TJclPePackageInfo.UnitInfoFlagsToString(UnitFlags: Byte): string;\r\nbegin\r\n Result := '';\r\n AddFlagTextRes(Result, @RsPePkgMain, UnitFlags, ufMainUnit);\r\n AddFlagTextRes(Result, @RsPePkgPackage, UnitFlags, ufPackageUnit);\r\n AddFlagTextRes(Result, @RsPePkgWeak, UnitFlags, ufWeakUnit);\r\n AddFlagTextRes(Result, @RsPePkgOrgWeak, UnitFlags, ufOrgWeakUnit);\r\n AddFlagTextRes(Result, @RsPePkgImplicit, UnitFlags, ufImplicitUnit);\r\nend;\r\n\r\n//=== { TJclPeBorForm } ======================================================\r\n\r\nconstructor TJclPeBorForm.Create(AResItem: TJclPeResourceItem;\r\n AFormFlags: TFilerFlags; AFormPosition: Integer;\r\n const AFormClassName, AFormObjectName: string);\r\nbegin\r\n inherited Create;\r\n FResItem := AResItem;\r\n FFormFlags := AFormFlags;\r\n FFormPosition := AFormPosition;\r\n FFormClassName := AFormClassName;\r\n FFormObjectName := AFormObjectName;\r\nend;\r\n\r\nprocedure TJclPeBorForm.ConvertFormToText(const Stream: TStream);\r\nvar\r\n SourceStream: TJclPeResourceRawStream;\r\nbegin\r\n SourceStream := TJclPeResourceRawStream.Create(ResItem);\r\n try\r\n ObjectBinaryToText(SourceStream, Stream);\r\n finally\r\n SourceStream.Free;\r\n end;\r\nend;\r\n\r\nprocedure TJclPeBorForm.ConvertFormToText(const Strings: TStrings);\r\nvar\r\n TempStream: TMemoryStream;\r\nbegin\r\n TempStream := TMemoryStream.Create;\r\n try\r\n ConvertFormToText(TempStream);\r\n TempStream.Seek(0, soFromBeginning);\r\n Strings.LoadFromStream(TempStream);\r\n finally\r\n TempStream.Free;\r\n end;\r\nend;\r\n\r\nfunction TJclPeBorForm.GetDisplayName: string;\r\nbegin\r\n if FFormObjectName <> '' then\r\n Result := FFormObjectName + ': '\r\n else\r\n Result := '';\r\n Result := Result + FFormClassName;\r\nend;\r\n\r\n//=== { TJclPeBorImage } =====================================================\r\n\r\nconstructor TJclPeBorImage.Create(ANoExceptions: Boolean);\r\nbegin\r\n FForms := TObjectList.Create(True);\r\n FPackageInfoSorted := True;\r\n inherited Create(ANoExceptions);\r\nend;\r\n\r\ndestructor TJclPeBorImage.Destroy;\r\nbegin\r\n inherited Destroy;\r\n FreeAndNil(FForms);\r\nend;\r\n\r\nprocedure TJclPeBorImage.AfterOpen;\r\nvar\r\n HasDVCLAL, HasPACKAGEINFO, HasPACKAGEOPTIONS: Boolean;\r\nbegin\r\n inherited AfterOpen;\r\n if StatusOK then\r\n with ResourceList do\r\n begin\r\n HasDVCLAL := (FindResource(rtRCData, DVclAlResName) <> nil);\r\n HasPACKAGEINFO := (FindResource(rtRCData, PackageInfoResName) <> nil);\r\n HasPACKAGEOPTIONS := (FindResource(rtRCData, PackageOptionsResName) <> nil);\r\n FIsPackage := HasPACKAGEINFO and HasPACKAGEOPTIONS;\r\n FIsBorlandImage := HasDVCLAL or FIsPackage;\r\n end;\r\nend;\r\n\r\nprocedure TJclPeBorImage.Clear;\r\nbegin\r\n FForms.Clear;\r\n FreeAndNil(FPackageInfo);\r\n FreeLibHandle;\r\n inherited Clear;\r\n FIsBorlandImage := False;\r\n FIsPackage := False;\r\n FPackageCompilerVersion := 0;\r\nend;\r\n\r\nprocedure TJclPeBorImage.CreateFormsList;\r\nvar\r\n ResTypeItem: TJclPeResourceItem;\r\n I: Integer;\r\n\r\n procedure ProcessListItem(DfmResItem: TJclPeResourceItem);\r\n const\r\n FilerSignature: array [1..4] of AnsiChar = string('TPF0');\r\n var\r\n SourceStream: TJclPeResourceRawStream;\r\n Reader: TReader;\r\n FormFlags: TFilerFlags;\r\n FormPosition: Integer;\r\n ClassName, FormName: string;\r\n begin\r\n SourceStream := TJclPeResourceRawStream.Create(DfmResItem);\r\n try\r\n if (SourceStream.Size > SizeOf(FilerSignature)) and\r\n (PInteger(SourceStream.Memory)^ = Integer(FilerSignature)) then\r\n begin\r\n Reader := TReader.Create(SourceStream, 4096);\r\n try\r\n Reader.ReadSignature;\r\n Reader.ReadPrefix(FormFlags, FormPosition);\r\n ClassName := Reader.ReadStr;\r\n FormName := Reader.ReadStr;\r\n FForms.Add(TJclPeBorForm.Create(DfmResItem, FormFlags, FormPosition,\r\n ClassName, FormName));\r\n finally\r\n Reader.Free;\r\n end;\r\n end;\r\n finally\r\n SourceStream.Free;\r\n end;\r\n end;\r\n\r\nbegin\r\n if StatusOK then\r\n with ResourceList do\r\n begin\r\n ResTypeItem := FindResource(rtRCData, '');\r\n if ResTypeItem <> nil then\r\n with ResTypeItem.List do\r\n for I := 0 to Count - 1 do\r\n ProcessListItem(Items[I].List[0]);\r\n end;\r\nend;\r\n\r\nfunction TJclPeBorImage.DependedPackages(List: TStrings; FullPathName, Descriptions: Boolean): Boolean;\r\nvar\r\n ImportList: TStringList;\r\n I: Integer;\r\n Name: string;\r\nbegin\r\n Result := IsBorlandImage;\r\n if not Result then\r\n Exit;\r\n ImportList := InternalImportedLibraries(FileName, True, FullPathName, nil);\r\n List.BeginUpdate;\r\n try\r\n for I := 0 to ImportList.Count - 1 do\r\n begin\r\n Name := ImportList[I];\r\n if StrSame(ExtractFileExt(Name), BinaryExtensionPackage) then\r\n begin\r\n if Descriptions then\r\n List.Add(Name + '=' + GetPackageDescription(PChar(Name)))\r\n else\r\n List.Add(Name);\r\n end;\r\n end;\r\n finally\r\n ImportList.Free;\r\n List.EndUpdate;\r\n end;\r\nend;\r\n\r\nfunction TJclPeBorImage.FreeLibHandle: Boolean;\r\nbegin\r\n if FLibHandle <> 0 then\r\n begin\r\n Result := FreeLibrary(FLibHandle);\r\n FLibHandle := 0;\r\n end\r\n else\r\n Result := True;\r\nend;\r\n\r\nfunction TJclPeBorImage.GetFormCount: Integer;\r\nbegin\r\n if FForms.Count = 0 then\r\n CreateFormsList;\r\n Result := FForms.Count;\r\nend;\r\n\r\nfunction TJclPeBorImage.GetFormFromName(const FormClassName: string): TJclPeBorForm;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := nil;\r\n for I := 0 to FormCount - 1 do\r\n if StrSame(FormClassName, Forms[I].FormClassName) then\r\n begin\r\n Result := Forms[I];\r\n Break;\r\n end;\r\nend;\r\n\r\nfunction TJclPeBorImage.GetForms(Index: Integer): TJclPeBorForm;\r\nbegin\r\n Result := TJclPeBorForm(FForms[Index]);\r\nend;\r\n\r\nfunction TJclPeBorImage.GetLibHandle: THandle;\r\nbegin\r\n if StatusOK and (FLibHandle = 0) then\r\n begin\r\n FLibHandle := LoadLibraryEx(PChar(FileName), 0, LOAD_LIBRARY_AS_DATAFILE);\r\n if FLibHandle = 0 then\r\n RaiseLastOSError;\r\n end;\r\n Result := FLibHandle;\r\nend;\r\n\r\nfunction TJclPeBorImage.GetPackageCompilerVersion: Integer;\r\nvar\r\n I: Integer;\r\n ImportName: string;\r\n\r\n function CheckName: Boolean;\r\n begin\r\n Result := False;\r\n ImportName := AnsiUpperCase(ImportName);\r\n if StrSame(ExtractFileExt(ImportName), BinaryExtensionPackage) then\r\n begin\r\n ImportName := PathExtractFileNameNoExt(ImportName);\r\n if (Length(ImportName) = 5) and\r\n CharIsDigit(ImportName[4]) and CharIsDigit(ImportName[5]) and\r\n ((Pos('RTL', ImportName) = 1) or (Pos('VCL', ImportName) = 1)) then\r\n begin\r\n FPackageCompilerVersion := StrToIntDef(Copy(ImportName, 4, 2), 0);\r\n Result := True;\r\n end;\r\n end;\r\n end;\r\n\r\nbegin\r\n if (FPackageCompilerVersion = 0) and IsPackage then\r\n begin\r\n with ImportList do\r\n for I := 0 to UniqueLibItemCount - 1 do\r\n begin\r\n ImportName := UniqueLibNames[I];\r\n if CheckName then\r\n Break;\r\n end;\r\n if FPackageCompilerVersion = 0 then\r\n begin\r\n ImportName := ExtractFileName(FileName);\r\n CheckName;\r\n end;\r\n end;\r\n Result := FPackageCompilerVersion;\r\nend;\r\n\r\nfunction TJclPeBorImage.GetPackageInfo: TJclPePackageInfo;\r\nbegin\r\n if StatusOK and (FPackageInfo = nil) then\r\n begin\r\n GetLibHandle;\r\n FPackageInfo := TJclPePackageInfo.Create(FLibHandle);\r\n FPackageInfo.Sorted := FPackageInfoSorted;\r\n FreeLibHandle;\r\n end;\r\n Result := FPackageInfo;\r\nend;\r\n{$ENDIF BORLAND}\r\n\r\n//=== { TJclPeNameSearch } ===================================================\r\n\r\nconstructor TJclPeNameSearch.Create(const FunctionName, Path: string; Options: TJclPeNameSearchOptions);\r\nbegin\r\n inherited Create(True);\r\n FFunctionName := FunctionName;\r\n FOptions := Options;\r\n FPath := Path;\r\n FreeOnTerminate := True;\r\nend;\r\n\r\nfunction TJclPeNameSearch.CompareName(const FunctionName, ComparedName: string): Boolean;\r\nbegin\r\n Result := PeSmartFunctionNameSame(ComparedName, FunctionName, [scIgnoreCase]);\r\nend;\r\n\r\nprocedure TJclPeNameSearch.DoFound;\r\nbegin\r\n if Assigned(FOnFound) then\r\n FOnFound(Self, F_FileName, F_FunctionName, F_Option);\r\nend;\r\n\r\nprocedure TJclPeNameSearch.DoProcessFile;\r\nbegin\r\n if Assigned(FOnProcessFile) then\r\n FOnProcessFile(Self, FPeImage, F_Process);\r\nend;\r\n\r\nprocedure TJclPeNameSearch.Execute;\r\nvar\r\n PathList: TStringList;\r\n I: Integer;\r\n\r\n function CompareNameAndNotify(const S: string): Boolean;\r\n begin\r\n Result := CompareName(S, FFunctionName);\r\n if Result and not Terminated then\r\n begin\r\n F_FunctionName := S;\r\n Synchronize(DoFound);\r\n end;\r\n end;\r\n\r\n procedure ProcessDirectorySearch(const DirName: string);\r\n var\r\n Se: TSearchRec;\r\n SearchResult: Integer;\r\n ImportList: TJclPeImportList;\r\n ExportList: TJclPeExportFuncList;\r\n I: Integer;\r\n begin\r\n SearchResult := FindFirst(DirName, faArchive + faReadOnly, Se);\r\n try\r\n while not Terminated and (SearchResult = 0) do\r\n begin\r\n F_FileName := PathAddSeparator(ExtractFilePath(DirName)) + Se.Name;\r\n F_Process := True;\r\n FPeImage.FileName := F_FileName;\r\n if Assigned(FOnProcessFile) then\r\n Synchronize(DoProcessFile);\r\n if F_Process and FPeImage.StatusOK then\r\n begin\r\n if seExports in FOptions then\r\n begin\r\n ExportList := FPeImage.ExportList;\r\n F_Option := seExports;\r\n for I := 0 to ExportList.Count - 1 do\r\n begin\r\n if Terminated then\r\n Break;\r\n CompareNameAndNotify(ExportList[I].Name);\r\n end;\r\n end;\r\n if FOptions * [seImports, seDelayImports, seBoundImports] <> [] then\r\n begin\r\n ImportList := FPeImage.ImportList;\r\n FPeImage.TryGetNamesForOrdinalImports;\r\n for I := 0 to ImportList.AllItemCount - 1 do\r\n with ImportList.AllItems[I] do\r\n begin\r\n if Terminated then\r\n Break;\r\n case ImportLib.ImportKind of\r\n ikImport:\r\n if seImports in FOptions then\r\n begin\r\n F_Option := seImports;\r\n CompareNameAndNotify(Name);\r\n end;\r\n ikDelayImport:\r\n if seDelayImports in FOptions then\r\n begin\r\n F_Option := seDelayImports;\r\n CompareNameAndNotify(Name);\r\n end;\r\n ikBoundImport:\r\n if seDelayImports in FOptions then\r\n begin\r\n F_Option := seBoundImports;\r\n CompareNameAndNotify(Name);\r\n end;\r\n end;\r\n end;\r\n end;\r\n end;\r\n SearchResult := FindNext(Se);\r\n end;\r\n finally\r\n FindClose(Se);\r\n end;\r\n end;\r\n\r\nbegin\r\n FPeImage := TJclPeImage.Create(True);\r\n PathList := TStringList.Create;\r\n try\r\n PathList.Sorted := True;\r\n PathList.Duplicates := dupIgnore;\r\n StrToStrings(FPath, ';', PathList);\r\n for I := 0 to PathList.Count - 1 do\r\n ProcessDirectorySearch(PathAddSeparator(Trim(PathList[I])) + '*.*');\r\n finally\r\n PathList.Free;\r\n FPeImage.Free;\r\n end;\r\nend;\r\n\r\nprocedure TJclPeNameSearch.Start;\r\nbegin\r\n {$IFDEF RTL210_UP}\r\n Suspended := False;\r\n {$ELSE ~RTL210_UP}\r\n Resume;\r\n {$ENDIF ~RTL210_UP}\r\nend;\r\n\r\n//=== PE Image miscellaneous functions =======================================\r\n\r\nfunction IsValidPeFile(const FileName: TFileName): Boolean;\r\nvar\r\n NtHeaders: TImageNtHeaders32;\r\nbegin\r\n Result := PeGetNtHeaders32(FileName, NtHeaders);\r\nend;\r\n\r\nfunction InternalGetNtHeaders32(const FileName: TFileName; out NtHeaders): Boolean;\r\nvar\r\n FileHandle: THandle;\r\n Mapping: TJclFileMapping;\r\n View: TJclFileMappingView;\r\n HeadersPtr: PImageNtHeaders32;\r\nbegin\r\n Result := False;\r\n ResetMemory(NtHeaders, SizeOf(TImageNtHeaders32));\r\n FileHandle := FileOpen(FileName, fmOpenRead or fmShareDenyWrite);\r\n if FileHandle = INVALID_HANDLE_VALUE then\r\n Exit;\r\n try\r\n if GetSizeOfFile(FileHandle) >= SizeOf(TImageDosHeader) then\r\n begin\r\n Mapping := TJclFileMapping.Create(FileHandle, '', PAGE_READONLY, 0, nil);\r\n try\r\n View := TJclFileMappingView.Create(Mapping, FILE_MAP_READ, 0, 0);\r\n HeadersPtr := PeMapImgNtHeaders32(View.Memory);\r\n if HeadersPtr <> nil then\r\n begin\r\n Result := True;\r\n TImageNtHeaders32(NtHeaders) := HeadersPtr^;\r\n end;\r\n finally\r\n Mapping.Free;\r\n end;\r\n end;\r\n finally\r\n FileClose(FileHandle);\r\n end;\r\nend;\r\n\r\nfunction PeGetNtHeaders32(const FileName: TFileName; out NtHeaders: TImageNtHeaders32): Boolean;\r\nbegin\r\n Result := InternalGetNtHeaders32(FileName, NtHeaders);\r\nend;\r\n\r\nfunction PeGetNtHeaders64(const FileName: TFileName; out NtHeaders: TImageNtHeaders64): Boolean;\r\nvar\r\n FileHandle: THandle;\r\n Mapping: TJclFileMapping;\r\n View: TJclFileMappingView;\r\n HeadersPtr: PImageNtHeaders64;\r\nbegin\r\n Result := False;\r\n ResetMemory(NtHeaders, SizeOf(NtHeaders));\r\n FileHandle := FileOpen(FileName, fmOpenRead or fmShareDenyWrite);\r\n if FileHandle = INVALID_HANDLE_VALUE then\r\n Exit;\r\n try\r\n if GetSizeOfFile(FileHandle) >= SizeOf(TImageDosHeader) then\r\n begin\r\n Mapping := TJclFileMapping.Create(FileHandle, '', PAGE_READONLY, 0, nil);\r\n try\r\n View := TJclFileMappingView.Create(Mapping, FILE_MAP_READ, 0, 0);\r\n HeadersPtr := PeMapImgNtHeaders64(View.Memory);\r\n if HeadersPtr <> nil then\r\n begin\r\n Result := True;\r\n NtHeaders := HeadersPtr^;\r\n end;\r\n finally\r\n Mapping.Free;\r\n end;\r\n end;\r\n finally\r\n FileClose(FileHandle);\r\n end;\r\nend;\r\n\r\nfunction PeCreateNameHintTable(const FileName: TFileName): Boolean;\r\nvar\r\n PeImage, ExportsImage: TJclPeImage;\r\n I: Integer;\r\n ImportItem: TJclPeImportLibItem;\r\n Thunk32: PImageThunkData32;\r\n Thunk64: PImageThunkData64;\r\n OrdinalName: PImageImportByName;\r\n ExportItem: TJclPeExportFuncItem;\r\n Cache: TJclPeImagesCache;\r\n ImageBase32: TJclAddr32;\r\n ImageBase64: TJclAddr64;\r\n UTF8Name: TUTF8String;\r\n ExportName: string;\r\nbegin\r\n Cache := TJclPeImagesCache.Create;\r\n try\r\n PeImage := TJclPeImage.Create(False);\r\n try\r\n PeImage.ReadOnlyAccess := False;\r\n PeImage.FileName := FileName;\r\n Result := PeImage.ImportList.Count > 0;\r\n for I := 0 to PeImage.ImportList.Count - 1 do\r\n begin\r\n ImportItem := PeImage.ImportList[I];\r\n if ImportItem.ImportKind = ikBoundImport then\r\n Continue;\r\n ExportsImage := Cache[ImportItem.FileName];\r\n ExportsImage.ExportList.PrepareForFastNameSearch;\r\n case PEImage.Target of\r\n taWin32:\r\n begin\r\n Thunk32 := ImportItem.ThunkData32;\r\n ImageBase32 := PeImage.OptionalHeader32.ImageBase;\r\n while Thunk32^.Function_ <> 0 do\r\n begin\r\n if Thunk32^.Ordinal and IMAGE_ORDINAL_FLAG32 = 0 then\r\n begin\r\n case ImportItem.ImportKind of\r\n ikImport:\r\n OrdinalName := PImageImportByName(PeImage.RvaToVa(Thunk32^.AddressOfData));\r\n ikDelayImport:\r\n OrdinalName := PImageImportByName(PeImage.RvaToVa(Thunk32^.AddressOfData - ImageBase32));\r\n else\r\n OrdinalName := nil;\r\n end;\r\n UTF8Name := PAnsiChar(@OrdinalName.Name);\r\n if not TryUTF8ToString(UTF8Name, ExportName) then\r\n ExportName := string(UTF8Name);\r\n ExportItem := ExportsImage.ExportList.ItemFromName[ExportName];\r\n if ExportItem <> nil then\r\n OrdinalName.Hint := ExportItem.Hint\r\n else\r\n OrdinalName.Hint := 0;\r\n end;\r\n Inc(Thunk32);\r\n end;\r\n end;\r\n taWin64:\r\n begin\r\n Thunk64 := ImportItem.ThunkData64;\r\n ImageBase64 := PeImage.OptionalHeader64.ImageBase;\r\n while Thunk64^.Function_ <> 0 do\r\n begin\r\n if Thunk64^.Ordinal and IMAGE_ORDINAL_FLAG64 = 0 then\r\n begin\r\n case ImportItem.ImportKind of\r\n ikImport:\r\n OrdinalName := PImageImportByName(PeImage.RvaToVa(Thunk64^.AddressOfData));\r\n ikDelayImport:\r\n OrdinalName := PImageImportByName(PeImage.RvaToVa(Thunk64^.AddressOfData - ImageBase64));\r\n else\r\n OrdinalName := nil;\r\n end;\r\n UTF8Name := PAnsiChar(@OrdinalName.Name);\r\n if not TryUTF8ToString(UTF8Name, ExportName) then\r\n ExportName := string(UTF8Name);\r\n ExportItem := ExportsImage.ExportList.ItemFromName[ExportName];\r\n if ExportItem <> nil then\r\n OrdinalName.Hint := ExportItem.Hint\r\n else\r\n OrdinalName.Hint := 0;\r\n end;\r\n Inc(Thunk64);\r\n end;\r\n end;\r\n end;\r\n end;\r\n finally\r\n PeImage.Free;\r\n end;\r\n finally\r\n Cache.Free;\r\n end;\r\nend;\r\n\r\nfunction PeRebaseImage32(const ImageName: TFileName; NewBase: TJclAddr32;\r\n TimeStamp, MaxNewSize: DWORD): TJclRebaseImageInfo32;\r\n\r\n function CalculateBaseAddress: TJclAddr32;\r\n var\r\n FirstChar: Char;\r\n ModuleName: string;\r\n begin\r\n ModuleName := ExtractFileName(ImageName);\r\n if Length(ModuleName) > 0 then\r\n FirstChar := UpCase(ModuleName[1])\r\n else\r\n FirstChar := NativeNull;\r\n if not CharIsUpper(FirstChar) then\r\n FirstChar := 'A';\r\n Result := $60000000 + (((Ord(FirstChar) - Ord('A')) div 3) * $1000000);\r\n end;\r\n\r\n{$IFDEF CPU64}\r\n{$IFNDEF DELPHI64_TEMPORARY}\r\nvar\r\n NewIB, OldIB: QWord;\r\n{$ENDIF CPU64}\r\n{$ENDIF ~DELPHI64_TEMPORARY}\r\nbegin\r\n if NewBase = 0 then\r\n NewBase := CalculateBaseAddress;\r\n with Result do\r\n begin\r\n NewImageBase := NewBase;\r\n // OF: possible loss of data\r\n {$IFDEF CPU32}\r\n Win32Check(ReBaseImage(PAnsiChar(AnsiString(ImageName)), nil, True, False, False, MaxNewSize,\r\n OldImageSize, OldImageBase, NewImageSize, NewImageBase, TimeStamp));\r\n {$ENDIF CPU32}\r\n {$IFDEF CPU64}\r\n {$IFDEF DELPHI64_TEMPORARY}\r\n System.Error(rePlatformNotImplemented);\r\n {$ELSE ~DELPHI64_TEMPORARY}\r\n NewIB := NewImageBase;\r\n OldIB := OldImageBase;\r\n Win32Check(ReBaseImage(PAnsiChar(AnsiString(ImageName)), nil, True, False, False, MaxNewSize,\r\n OldImageSize, OldIB, NewImageSize, NewIB, TimeStamp));\r\n NewImageBase := NewIB;\r\n OldImageBase := OldIB;\r\n {$ENDIF ~DELPHI64_TEMPORARY}\r\n {$ENDIF CPU64}\r\n end;\r\nend;\r\n\r\nfunction PeRebaseImage64(const ImageName: TFileName; NewBase: TJclAddr64;\r\n TimeStamp, MaxNewSize: DWORD): TJclRebaseImageInfo64;\r\n\r\n function CalculateBaseAddress: TJclAddr64;\r\n var\r\n FirstChar: Char;\r\n ModuleName: string;\r\n begin\r\n ModuleName := ExtractFileName(ImageName);\r\n if Length(ModuleName) > 0 then\r\n FirstChar := UpCase(ModuleName[1])\r\n else\r\n FirstChar := NativeNull;\r\n if not CharIsUpper(FirstChar) then\r\n FirstChar := 'A';\r\n Result := $60000000 + (((Ord(FirstChar) - Ord('A')) div 3) * $1000000);\r\n Result := Result shl 32;\r\n end;\r\n\r\nbegin\r\n if NewBase = 0 then\r\n NewBase := CalculateBaseAddress;\r\n with Result do\r\n begin\r\n NewImageBase := NewBase;\r\n // OF: possible loss of data\r\n Win32Check(ReBaseImage64(PAnsiChar(AnsiString(ImageName)), nil, True, False, False, MaxNewSize,\r\n OldImageSize, OldImageBase, NewImageSize, NewImageBase, TimeStamp));\r\n end;\r\nend;\r\n\r\nfunction PeUpdateLinkerTimeStamp(const FileName: TFileName; const Time: TDateTime): Boolean;\r\nvar\r\n Mapping: TJclFileMapping;\r\n View: TJclFileMappingView;\r\n Headers: PImageNtHeaders32; // works with 64-bit binaries too\r\n // only the optional field differs\r\nbegin\r\n Mapping := TJclFileMapping.Create(FileName, fmOpenReadWrite, '', PAGE_READWRITE, 0, nil);\r\n try\r\n View := TJclFileMappingView.Create(Mapping, FILE_MAP_WRITE, 0, 0);\r\n Headers := PeMapImgNtHeaders32(View.Memory);\r\n Result := (Headers <> nil);\r\n if Result then\r\n Headers^.FileHeader.TimeDateStamp := TJclPeImage.DateTimeToStamp(Time);\r\n finally\r\n Mapping.Free;\r\n end;\r\nend;\r\n\r\nfunction PeReadLinkerTimeStamp(const FileName: TFileName): TDateTime;\r\nvar\r\n Mapping: TJclFileMappingStream;\r\n Headers: PImageNtHeaders32; // works with 64-bit binaries too\r\n // only the optional field differs\r\nbegin\r\n Mapping := TJclFileMappingStream.Create(FileName, fmOpenRead or fmShareDenyWrite);\r\n try\r\n Headers := PeMapImgNtHeaders32(Mapping.Memory);\r\n if Headers <> nil then\r\n Result := TJclPeImage.StampToDateTime(Headers^.FileHeader.TimeDateStamp)\r\n else\r\n Result := -1;\r\n finally\r\n Mapping.Free;\r\n end;\r\nend;\r\n\r\n{ TODO -cHelp : Author: Uwe Schuster(just a generic version of JclDebug.InsertDebugDataIntoExecutableFile) }\r\nfunction PeInsertSection(const FileName: TFileName; SectionStream: TStream; SectionName: string): Boolean;\r\n procedure RoundUpToAlignment(var Value: DWORD; Alignment: DWORD);\r\n begin\r\n if (Value mod Alignment) <> 0 then\r\n Value := ((Value div Alignment) + 1) * Alignment;\r\n end;\r\n function PeInsertSection32(ImageStream: TMemoryStream): Boolean;\r\n var\r\n NtHeaders: PImageNtHeaders32;\r\n Sections, LastSection, NewSection: PImageSectionHeader;\r\n VirtualAlignedSize: DWORD;\r\n I, X, NeedFill: Integer;\r\n SectionDataSize: Integer;\r\n UTF8Name: TUTF8String;\r\n begin\r\n Result := True;\r\n try\r\n SectionDataSize := SectionStream.Size;\r\n NtHeaders := PeMapImgNtHeaders32(ImageStream.Memory);\r\n Assert(NtHeaders <> nil);\r\n Sections := PeMapImgSections32(NtHeaders);\r\n Assert(Sections <> nil);\r\n // Check whether there is not a section with the name already. If so, return True (#0000069)\r\n if PeMapImgFindSection32(NtHeaders, SectionName) <> nil then\r\n begin\r\n Result := True;\r\n Exit;\r\n end;\r\n\r\n LastSection := Sections;\r\n Inc(LastSection, NtHeaders^.FileHeader.NumberOfSections - 1);\r\n NewSection := LastSection;\r\n Inc(NewSection);\r\n\r\n // Increase the number of sections\r\n Inc(NtHeaders^.FileHeader.NumberOfSections);\r\n ResetMemory(NewSection^, SizeOf(TImageSectionHeader));\r\n // JCLDEBUG Virtual Address\r\n NewSection^.VirtualAddress := LastSection^.VirtualAddress + LastSection^.Misc.VirtualSize;\r\n RoundUpToAlignment(NewSection^.VirtualAddress, NtHeaders^.OptionalHeader.SectionAlignment);\r\n // JCLDEBUG Physical Offset\r\n NewSection^.PointerToRawData := LastSection^.PointerToRawData + LastSection^.SizeOfRawData;\r\n RoundUpToAlignment(NewSection^.PointerToRawData, NtHeaders^.OptionalHeader.FileAlignment);\r\n // JCLDEBUG Section name\r\n if not TryStringToUTF8(SectionName, UTF8Name) then\r\n UTF8Name := TUTF8String(SectionName);\r\n StrPLCopy(PAnsiChar(@NewSection^.Name), UTF8Name, IMAGE_SIZEOF_SHORT_NAME);\r\n // JCLDEBUG Characteristics flags\r\n NewSection^.Characteristics := IMAGE_SCN_MEM_READ or IMAGE_SCN_CNT_INITIALIZED_DATA;\r\n\r\n // Size of virtual data area\r\n NewSection^.Misc.VirtualSize := SectionDataSize;\r\n VirtualAlignedSize := SectionDataSize;\r\n RoundUpToAlignment(VirtualAlignedSize, NtHeaders^.OptionalHeader.SectionAlignment);\r\n // Update Size of Image\r\n Inc(NtHeaders^.OptionalHeader.SizeOfImage, VirtualAlignedSize);\r\n // Raw data size\r\n NewSection^.SizeOfRawData := SectionDataSize;\r\n RoundUpToAlignment(NewSection^.SizeOfRawData, NtHeaders^.OptionalHeader.FileAlignment);\r\n // Update Initialized data size\r\n Inc(NtHeaders^.OptionalHeader.SizeOfInitializedData, NewSection^.SizeOfRawData);\r\n\r\n // Fill data to alignment\r\n NeedFill := INT_PTR(NewSection^.SizeOfRawData) - SectionDataSize;\r\n\r\n // Note: Delphi linker seems to generate incorrect (unaligned) size of\r\n // the executable when adding TD32 debug data so the position could be\r\n // behind the size of the file then.\r\n ImageStream.Seek(NewSection^.PointerToRawData, soFromBeginning);\r\n ImageStream.CopyFrom(SectionStream, 0);\r\n X := 0;\r\n for I := 1 to NeedFill do\r\n ImageStream.WriteBuffer(X, 1);\r\n except\r\n Result := False;\r\n end;\r\n end;\r\n function PeInsertSection64(ImageStream: TMemoryStream): Boolean;\r\n var\r\n NtHeaders: PImageNtHeaders64;\r\n Sections, LastSection, NewSection: PImageSectionHeader;\r\n VirtualAlignedSize: DWORD;\r\n I, X, NeedFill: Integer;\r\n SectionDataSize: Integer;\r\n UTF8Name: TUTF8String;\r\n begin\r\n Result := True;\r\n try\r\n SectionDataSize := SectionStream.Size;\r\n NtHeaders := PeMapImgNtHeaders64(ImageStream.Memory);\r\n Assert(NtHeaders <> nil);\r\n Sections := PeMapImgSections64(NtHeaders);\r\n Assert(Sections <> nil);\r\n // Check whether there is not a section with the name already. If so, return True (#0000069)\r\n if PeMapImgFindSection64(NtHeaders, SectionName) <> nil then\r\n begin\r\n Result := True;\r\n Exit;\r\n end;\r\n\r\n LastSection := Sections;\r\n Inc(LastSection, NtHeaders^.FileHeader.NumberOfSections - 1);\r\n NewSection := LastSection;\r\n Inc(NewSection);\r\n\r\n // Increase the number of sections\r\n Inc(NtHeaders^.FileHeader.NumberOfSections);\r\n ResetMemory(NewSection^, SizeOf(TImageSectionHeader));\r\n // JCLDEBUG Virtual Address\r\n NewSection^.VirtualAddress := LastSection^.VirtualAddress + LastSection^.Misc.VirtualSize;\r\n RoundUpToAlignment(NewSection^.VirtualAddress, NtHeaders^.OptionalHeader.SectionAlignment);\r\n // JCLDEBUG Physical Offset\r\n NewSection^.PointerToRawData := LastSection^.PointerToRawData + LastSection^.SizeOfRawData;\r\n RoundUpToAlignment(NewSection^.PointerToRawData, NtHeaders^.OptionalHeader.FileAlignment);\r\n // JCLDEBUG Section name\r\n if not TryStringToUTF8(SectionName, UTF8Name) then\r\n UTF8Name := TUTF8String(SectionName);\r\n StrPLCopy(PAnsiChar(@NewSection^.Name), UTF8Name, IMAGE_SIZEOF_SHORT_NAME);\r\n // JCLDEBUG Characteristics flags\r\n NewSection^.Characteristics := IMAGE_SCN_MEM_READ or IMAGE_SCN_CNT_INITIALIZED_DATA;\r\n\r\n // Size of virtual data area\r\n NewSection^.Misc.VirtualSize := SectionDataSize;\r\n VirtualAlignedSize := SectionDataSize;\r\n RoundUpToAlignment(VirtualAlignedSize, NtHeaders^.OptionalHeader.SectionAlignment);\r\n // Update Size of Image\r\n Inc(NtHeaders^.OptionalHeader.SizeOfImage, VirtualAlignedSize);\r\n // Raw data size\r\n NewSection^.SizeOfRawData := SectionDataSize;\r\n RoundUpToAlignment(NewSection^.SizeOfRawData, NtHeaders^.OptionalHeader.FileAlignment);\r\n // Update Initialized data size\r\n Inc(NtHeaders^.OptionalHeader.SizeOfInitializedData, NewSection^.SizeOfRawData);\r\n\r\n // Fill data to alignment\r\n NeedFill := INT_PTR(NewSection^.SizeOfRawData) - SectionDataSize;\r\n\r\n // Note: Delphi linker seems to generate incorrect (unaligned) size of\r\n // the executable when adding TD32 debug data so the position could be\r\n // behind the size of the file then.\r\n ImageStream.Seek(NewSection^.PointerToRawData, soFromBeginning);\r\n ImageStream.CopyFrom(SectionStream, 0);\r\n X := 0;\r\n for I := 1 to NeedFill do\r\n ImageStream.WriteBuffer(X, 1);\r\n except\r\n Result := False;\r\n end;\r\n end;\r\n\r\nvar\r\n ImageStream: TMemoryStream;\r\nbegin\r\n Result := Assigned(SectionStream) and (SectionName <> '');\r\n if not Result then\r\n Exit;\r\n ImageStream := TMemoryStream.Create;\r\n try\r\n ImageStream.LoadFromFile(FileName);\r\n case PeMapImgTarget(ImageStream.Memory) of\r\n taWin32:\r\n Result := PeInsertSection32(ImageStream);\r\n taWin64:\r\n Result := PeInsertSection64(ImageStream);\r\n //taUnknown:\r\n else\r\n Result := False;\r\n end;\r\n\r\n if Result then\r\n ImageStream.SaveToFile(FileName);\r\n finally\r\n ImageStream.Free;\r\n end;\r\nend;\r\n\r\nfunction PeVerifyCheckSum(const FileName: TFileName): Boolean;\r\nbegin\r\n with CreatePeImage(FileName) do\r\n try\r\n Result := VerifyCheckSum;\r\n finally\r\n Free;\r\n end;\r\nend;\r\n\r\nfunction PeClearCheckSum(const FileName: TFileName): Boolean;\r\n function PeClearCheckSum32(ModuleAddress: Pointer): Boolean;\r\n var\r\n Headers: PImageNtHeaders32;\r\n begin\r\n Headers := PeMapImgNtHeaders32(ModuleAddress);\r\n Result := (Headers <> nil);\r\n if Result then\r\n Headers^.OptionalHeader.CheckSum := 0;\r\n end;\r\n function PeClearCheckSum64(ModuleAddress: Pointer): Boolean;\r\n var\r\n Headers: PImageNtHeaders64;\r\n begin\r\n Headers := PeMapImgNtHeaders64(ModuleAddress);\r\n Result := (Headers <> nil);\r\n if Result then\r\n Headers^.OptionalHeader.CheckSum := 0;\r\n end;\r\nvar\r\n Mapping: TJclFileMapping;\r\n View: TJclFileMappingView;\r\nbegin\r\n Mapping := TJclFileMapping.Create(FileName, fmOpenReadWrite, '', PAGE_READWRITE, 0, nil);\r\n try\r\n View := TJclFileMappingView.Create(Mapping, FILE_MAP_WRITE, 0, 0);\r\n case PeMapImgTarget(View.Memory) of\r\n taWin32:\r\n Result := PeClearCheckSum32(View.Memory);\r\n taWin64:\r\n Result := PeClearCheckSum64(View.Memory);\r\n //taUnknown:\r\n else\r\n Result := False;\r\n end;\r\n finally\r\n Mapping.Free;\r\n end;\r\nend;\r\n\r\nfunction PeUpdateCheckSum(const FileName: TFileName): Boolean;\r\nvar\r\n LI: TLoadedImage;\r\nbegin\r\n LI.ModuleName := nil;\r\n // OF: possible loss of data\r\n Result := MapAndLoad(PAnsiChar(AnsiString(FileName)), nil, LI, True, False);\r\n if Result then\r\n Result := UnMapAndLoad(LI);\r\nend;\r\n\r\n// Various simple PE Image searching and listing routines\r\n\r\nfunction PeDoesExportFunction(const FileName: TFileName; const FunctionName: string;\r\n Options: TJclSmartCompOptions): Boolean;\r\nbegin\r\n with CreatePeImage(FileName) do\r\n try\r\n Result := StatusOK and Assigned(ExportList.SmartFindName(FunctionName, Options));\r\n finally\r\n Free;\r\n end;\r\nend;\r\n\r\nfunction PeIsExportFunctionForwardedEx(const FileName: TFileName; const FunctionName: string;\r\n out ForwardedName: string; Options: TJclSmartCompOptions): Boolean;\r\nvar\r\n ExportItem: TJclPeExportFuncItem;\r\nbegin\r\n with CreatePeImage(FileName) do\r\n try\r\n Result := StatusOK;\r\n if Result then\r\n begin\r\n ExportItem := ExportList.SmartFindName(FunctionName, Options);\r\n if ExportItem <> nil then\r\n begin\r\n Result := ExportItem.IsForwarded;\r\n ForwardedName := ExportItem.ForwardedName;\r\n end\r\n else\r\n begin\r\n Result := False;\r\n ForwardedName := '';\r\n end;\r\n end;\r\n finally\r\n Free;\r\n end;\r\nend;\r\n\r\nfunction PeIsExportFunctionForwarded(const FileName: TFileName; const FunctionName: string;\r\n Options: TJclSmartCompOptions): Boolean;\r\nvar\r\n Dummy: string;\r\nbegin\r\n Result := PeIsExportFunctionForwardedEx(FileName, FunctionName, Dummy, Options);\r\nend;\r\n\r\nfunction PeDoesImportFunction(const FileName: TFileName; const FunctionName: string;\r\n const LibraryName: string; Options: TJclSmartCompOptions): Boolean;\r\nbegin\r\n with CreatePeImage(FileName) do\r\n try\r\n Result := StatusOK;\r\n if Result then\r\n with ImportList do\r\n begin\r\n TryGetNamesForOrdinalImports;\r\n Result := SmartFindName(FunctionName, LibraryName, Options) <> nil;\r\n end;\r\n finally\r\n Free;\r\n end;\r\nend;\r\n\r\nfunction PeDoesImportLibrary(const FileName: TFileName; const LibraryName: string;\r\n Recursive: Boolean): Boolean;\r\nvar\r\n SL: TStringList;\r\nbegin\r\n with CreatePeImage(FileName) do\r\n try\r\n Result := StatusOK;\r\n if Result then\r\n begin\r\n SL := InternalImportedLibraries(FileName, Recursive, False, nil);\r\n try\r\n Result := SL.IndexOf(LibraryName) > -1;\r\n finally\r\n SL.Free;\r\n end;\r\n end;\r\n finally\r\n Free;\r\n end;\r\nend;\r\n\r\nfunction PeImportedLibraries(const FileName: TFileName; const LibrariesList: TStrings;\r\n Recursive, FullPathName: Boolean): Boolean;\r\nvar\r\n SL: TStringList;\r\nbegin\r\n with CreatePeImage(FileName) do\r\n try\r\n Result := StatusOK;\r\n if Result then\r\n begin\r\n SL := InternalImportedLibraries(FileName, Recursive, FullPathName, nil);\r\n try\r\n LibrariesList.Assign(SL);\r\n finally\r\n SL.Free;\r\n end;\r\n end;\r\n finally\r\n Free;\r\n end;\r\nend;\r\n\r\nfunction PeImportedFunctions(const FileName: TFileName; const FunctionsList: TStrings;\r\n const LibraryName: string; IncludeLibNames: Boolean): Boolean;\r\nvar\r\n I: Integer;\r\nbegin\r\n with CreatePeImage(FileName) do\r\n try\r\n Result := StatusOK;\r\n if Result then\r\n with ImportList do\r\n begin\r\n TryGetNamesForOrdinalImports;\r\n FunctionsList.BeginUpdate;\r\n try\r\n for I := 0 to AllItemCount - 1 do\r\n with AllItems[I] do\r\n if ((Length(LibraryName) = 0) or StrSame(ImportLib.Name, LibraryName)) and\r\n (Name <> '') then\r\n begin\r\n if IncludeLibNames then\r\n FunctionsList.Add(ImportLib.Name + '=' + Name)\r\n else\r\n FunctionsList.Add(Name);\r\n end;\r\n finally\r\n FunctionsList.EndUpdate;\r\n end;\r\n end;\r\n finally\r\n Free;\r\n end;\r\nend;\r\n\r\nfunction PeExportedFunctions(const FileName: TFileName; const FunctionsList: TStrings): Boolean;\r\nvar\r\n I: Integer;\r\nbegin\r\n with CreatePeImage(FileName) do\r\n try\r\n Result := StatusOK;\r\n if Result then\r\n begin\r\n FunctionsList.BeginUpdate;\r\n try\r\n with ExportList do\r\n for I := 0 to Count - 1 do\r\n with Items[I] do\r\n if not IsExportedVariable then\r\n FunctionsList.Add(Name);\r\n finally\r\n FunctionsList.EndUpdate;\r\n end;\r\n end;\r\n finally\r\n Free;\r\n end;\r\nend;\r\n\r\nfunction PeExportedNames(const FileName: TFileName; const FunctionsList: TStrings): Boolean;\r\nvar\r\n I: Integer;\r\nbegin\r\n with CreatePeImage(FileName) do\r\n try\r\n Result := StatusOK;\r\n if Result then\r\n begin\r\n FunctionsList.BeginUpdate;\r\n try\r\n with ExportList do\r\n for I := 0 to Count - 1 do\r\n FunctionsList.Add(Items[I].Name);\r\n finally\r\n FunctionsList.EndUpdate;\r\n end;\r\n end;\r\n finally\r\n Free;\r\n end;\r\nend;\r\n\r\nfunction PeExportedVariables(const FileName: TFileName; const FunctionsList: TStrings): Boolean;\r\nvar\r\n I: Integer;\r\nbegin\r\n with CreatePeImage(FileName) do\r\n try\r\n Result := StatusOK;\r\n if Result then\r\n begin\r\n FunctionsList.BeginUpdate;\r\n try\r\n with ExportList do\r\n for I := 0 to Count - 1 do\r\n with Items[I] do\r\n if IsExportedVariable then\r\n FunctionsList.AddObject(Name, Pointer(Address));\r\n finally\r\n FunctionsList.EndUpdate;\r\n end;\r\n end;\r\n finally\r\n Free;\r\n end;\r\nend;\r\n\r\nfunction PeResourceKindNames(const FileName: TFileName; ResourceType: TJclPeResourceKind;\r\n const NamesList: TStrings): Boolean;\r\nbegin\r\n with CreatePeImage(FileName) do\r\n try\r\n Result := StatusOK and ResourceList.ListResourceNames(ResourceType, NamesList);\r\n finally\r\n Free;\r\n end;\r\nend;\r\n\r\n{$IFDEF BORLAND}\r\n\r\nfunction PeBorFormNames(const FileName: TFileName; const NamesList: TStrings): Boolean;\r\nvar\r\n I: Integer;\r\n BorImage: TJclPeBorImage;\r\n BorForm: TJclPeBorForm;\r\nbegin\r\n BorImage := TJclPeBorImage.Create(True);\r\n try\r\n BorImage.FileName := FileName;\r\n Result := BorImage.IsBorlandImage;\r\n if Result then\r\n begin\r\n NamesList.BeginUpdate;\r\n try\r\n for I := 0 to BorImage.FormCount - 1 do\r\n begin\r\n BorForm := BorImage.Forms[I];\r\n NamesList.AddObject(BorForm.DisplayName, Pointer(BorForm.ResItem.RawEntryDataSize));\r\n end;\r\n finally\r\n NamesList.EndUpdate;\r\n end;\r\n end;\r\n finally\r\n BorImage.Free;\r\n end;\r\nend;\r\n\r\nfunction PeBorDependedPackages(const FileName: TFileName; PackagesList: TStrings;\r\n FullPathName, Descriptions: Boolean): Boolean;\r\nvar\r\n BorImage: TJclPeBorImage;\r\nbegin\r\n BorImage := TJclPeBorImage.Create(True);\r\n try\r\n BorImage.FileName := FileName;\r\n Result := BorImage.DependedPackages(PackagesList, FullPathName, Descriptions);\r\n finally\r\n BorImage.Free;\r\n end;\r\nend;\r\n\r\n{$ENDIF BORLAND}\r\n\r\n// Missing imports checking routines\r\n\r\nfunction PeFindMissingImports(const FileName: TFileName; MissingImportsList: TStrings): Boolean;\r\nvar\r\n Cache: TJclPeImagesCache;\r\n FileImage, LibImage: TJclPeImage;\r\n L, I: Integer;\r\n LibItem: TJclPeImportLibItem;\r\n List: TStringList;\r\nbegin\r\n Result := False;\r\n List := nil;\r\n Cache := TJclPeImagesCache.Create;\r\n try\r\n List := TStringList.Create;\r\n List.Duplicates := dupIgnore;\r\n List.Sorted := True;\r\n FileImage := Cache[FileName];\r\n if FileImage.StatusOK then\r\n begin\r\n for L := 0 to FileImage.ImportList.Count - 1 do\r\n begin\r\n LibItem := FileImage.ImportList[L];\r\n LibImage := Cache[LibItem.FileName];\r\n if LibImage.StatusOK then\r\n begin\r\n LibImage.ExportList.PrepareForFastNameSearch;\r\n for I := 0 to LibItem.Count - 1 do\r\n if LibImage.ExportList.ItemFromName[LibItem[I].Name] = nil then\r\n List.Add(LibItem.Name + '=' + LibItem[I].Name);\r\n end\r\n else\r\n List.Add(LibItem.Name + '=');\r\n end;\r\n MissingImportsList.Assign(List);\r\n Result := List.Count > 0;\r\n end;\r\n finally\r\n List.Free;\r\n Cache.Free;\r\n end;\r\nend;\r\n\r\nfunction PeFindMissingImports(RequiredImportsList, MissingImportsList: TStrings): Boolean;\r\nvar\r\n Cache: TJclPeImagesCache;\r\n LibImage: TJclPeImage;\r\n I, SepPos: Integer;\r\n List: TStringList;\r\n S, LibName, ImportName: string;\r\nbegin\r\n List := nil;\r\n Cache := TJclPeImagesCache.Create;\r\n try\r\n List := TStringList.Create;\r\n List.Duplicates := dupIgnore;\r\n List.Sorted := True;\r\n for I := 0 to RequiredImportsList.Count - 1 do\r\n begin\r\n S := RequiredImportsList[I];\r\n SepPos := Pos('=', S);\r\n if SepPos = 0 then\r\n Continue;\r\n LibName := StrLeft(S, SepPos - 1);\r\n LibImage := Cache[LibName];\r\n if LibImage.StatusOK then\r\n begin\r\n LibImage.ExportList.PrepareForFastNameSearch;\r\n ImportName := StrRestOf(S, SepPos + 1);\r\n if LibImage.ExportList.ItemFromName[ImportName] = nil then\r\n List.Add(LibName + '=' + ImportName);\r\n end\r\n else\r\n List.Add(LibName + '=');\r\n end;\r\n MissingImportsList.Assign(List);\r\n Result := List.Count > 0;\r\n finally\r\n List.Free;\r\n Cache.Free;\r\n end;\r\nend;\r\n\r\nfunction PeCreateRequiredImportList(const FileName: TFileName; RequiredImportsList: TStrings): Boolean;\r\nbegin\r\n Result := PeImportedFunctions(FileName, RequiredImportsList, '', True);\r\nend;\r\n\r\n// Mapped or loaded image related functions\r\n\r\nfunction PeMapImgNtHeaders32(const BaseAddress: Pointer): PImageNtHeaders32;\r\nbegin\r\n Result := nil;\r\n if IsBadReadPtr(BaseAddress, SizeOf(TImageDosHeader)) then\r\n Exit;\r\n if (PImageDosHeader(BaseAddress)^.e_magic <> IMAGE_DOS_SIGNATURE) or\r\n (PImageDosHeader(BaseAddress)^._lfanew = 0) then\r\n Exit;\r\n Result := PImageNtHeaders32(TJclAddr(BaseAddress) + DWORD(PImageDosHeader(BaseAddress)^._lfanew));\r\n if IsBadReadPtr(Result, SizeOf(TImageNtHeaders32)) or\r\n (Result^.Signature <> IMAGE_NT_SIGNATURE) then\r\n Result := nil\r\nend;\r\n\r\nfunction PeMapImgNtHeaders32(Stream: TStream; const BasePosition: Int64; out NtHeaders32: TImageNtHeaders32): Int64;\r\nvar\r\n ImageDosHeader: TImageDosHeader;\r\nbegin\r\n ResetMemory(NtHeaders32, SizeOf(NtHeaders32));\r\n Result := -1;\r\n\r\n if (Stream.Seek(BasePosition, soBeginning) <> BasePosition) or\r\n (Stream.Read(ImageDosHeader, SizeOf(ImageDosHeader)) <> SizeOf(ImageDosHeader)) then\r\n raise EJclPeImageError.CreateRes(@SReadError);\r\n\r\n if (ImageDosHeader.e_magic <> IMAGE_DOS_SIGNATURE) or\r\n (ImageDosHeader._lfanew = 0) then\r\n Exit;\r\n\r\n Result := BasePosition + DWORD(ImageDosHeader._lfanew);\r\n\r\n if (Stream.Seek(Result, soBeginning) <> Result) or\r\n (Stream.Read(NtHeaders32, SizeOf(NtHeaders32)) <> SizeOf(NtHeaders32)) then\r\n raise EJclPeImageError.CreateRes(@SReadError);\r\n\r\n if NtHeaders32.Signature <> IMAGE_NT_SIGNATURE then\r\n Result := -1;\r\nend;\r\n\r\nfunction PeMapImgNtHeaders64(const BaseAddress: Pointer): PImageNtHeaders64;\r\nbegin\r\n Result := nil;\r\n if IsBadReadPtr(BaseAddress, SizeOf(TImageDosHeader)) then\r\n Exit;\r\n if (PImageDosHeader(BaseAddress)^.e_magic <> IMAGE_DOS_SIGNATURE) or\r\n (PImageDosHeader(BaseAddress)^._lfanew = 0) then\r\n Exit;\r\n Result := PImageNtHeaders64(TJclAddr(BaseAddress) + DWORD(PImageDosHeader(BaseAddress)^._lfanew));\r\n if IsBadReadPtr(Result, SizeOf(TImageNtHeaders64)) or\r\n (Result^.Signature <> IMAGE_NT_SIGNATURE) then\r\n Result := nil\r\nend;\r\n\r\nfunction PeMapImgNtHeaders64(Stream: TStream; const BasePosition: Int64; out NtHeaders64: TImageNtHeaders64): Int64;\r\nvar\r\n ImageDosHeader: TImageDosHeader;\r\nbegin\r\n ResetMemory(NtHeaders64, SizeOf(NtHeaders64));\r\n Result := -1;\r\n\r\n if (Stream.Seek(BasePosition, soBeginning) <> BasePosition) or\r\n (Stream.Read(ImageDosHeader, SizeOf(ImageDosHeader)) <> SizeOf(ImageDosHeader)) then\r\n raise EJclPeImageError.CreateRes(@SReadError);\r\n\r\n if (ImageDosHeader.e_magic <> IMAGE_DOS_SIGNATURE) or\r\n (ImageDosHeader._lfanew = 0) then\r\n Exit;\r\n\r\n Result := BasePosition + DWORD(ImageDosHeader._lfanew);\r\n\r\n if (Stream.Seek(Result, soBeginning) <> Result) or\r\n (Stream.Read(NtHeaders64, SizeOf(NtHeaders64)) <> SizeOf(NtHeaders64)) then\r\n raise EJclPeImageError.CreateRes(@SReadError);\r\n\r\n if NtHeaders64.Signature <> IMAGE_NT_SIGNATURE then\r\n Result := -1;\r\nend;\r\n\r\nfunction PeMapImgSize(const BaseAddress: Pointer): DWORD;\r\nbegin\r\n case PeMapImgTarget(BaseAddress) of\r\n taWin32:\r\n Result := PeMapImgSize32(BaseAddress);\r\n taWin64:\r\n Result := PeMapImgSize64(BaseAddress);\r\n //taUnknown:\r\n else\r\n Result := 0;\r\n end;\r\nend;\r\n\r\nfunction PeMapImgSize(Stream: TStream; const BasePosition: Int64): DWORD;\r\nbegin\r\n case PeMapImgTarget(Stream, BasePosition) of\r\n taWin32:\r\n Result := PeMapImgSize32(Stream, BasePosition);\r\n taWin64:\r\n Result := PeMapImgSize64(Stream, BasePosition);\r\n //taUnknown:\r\n else\r\n Result := 0;\r\n end;\r\nend;\r\n\r\nfunction PeMapImgSize32(const BaseAddress: Pointer): DWORD;\r\nvar\r\n NtHeaders32: PImageNtHeaders32;\r\nbegin\r\n Result := 0;\r\n NtHeaders32 := PeMapImgNtHeaders32(BaseAddress);\r\n if Assigned(NtHeaders32) then\r\n Result := NtHeaders32^.OptionalHeader.SizeOfImage;\r\nend;\r\n\r\nfunction PeMapImgSize32(Stream: TStream; const BasePosition: Int64): DWORD;\r\nvar\r\n NtHeaders32: TImageNtHeaders32;\r\nbegin\r\n Result := 0;\r\n if PeMapImgNtHeaders32(Stream, BasePosition, NtHeaders32) <> -1 then\r\n Result := NtHeaders32.OptionalHeader.SizeOfImage;\r\nend;\r\n\r\nfunction PeMapImgSize64(const BaseAddress: Pointer): DWORD;\r\nvar\r\n NtHeaders64: PImageNtHeaders64;\r\nbegin\r\n Result := 0;\r\n NtHeaders64 := PeMapImgNtHeaders64(BaseAddress);\r\n if Assigned(NtHeaders64) then\r\n Result := NtHeaders64^.OptionalHeader.SizeOfImage;\r\nend;\r\n\r\nfunction PeMapImgSize64(Stream: TStream; const BasePosition: Int64): DWORD;\r\nvar\r\n NtHeaders64: TImageNtHeaders64;\r\nbegin\r\n Result := 0;\r\n if PeMapImgNtHeaders64(Stream, BasePosition, NtHeaders64) <> -1 then\r\n Result := NtHeaders64.OptionalHeader.SizeOfImage;\r\nend;\r\n\r\nfunction PeMapImgLibraryName(const BaseAddress: Pointer): string;\r\nbegin\r\n case PeMapImgTarget(BaseAddress) of\r\n taWin32:\r\n Result := PeMapImgLibraryName32(BaseAddress);\r\n taWin64:\r\n Result := PeMapImgLibraryName64(BaseAddress);\r\n //taUnknown:\r\n else\r\n Result := '';\r\n end;\r\nend;\r\n\r\nfunction PeMapImgLibraryName32(const BaseAddress: Pointer): string;\r\nvar\r\n NtHeaders: PImageNtHeaders32;\r\n DataDir: TImageDataDirectory;\r\n ExportDir: PImageExportDirectory;\r\n UTF8Name: TUTF8String;\r\nbegin\r\n Result := '';\r\n NtHeaders := PeMapImgNtHeaders32(BaseAddress);\r\n if NtHeaders = nil then\r\n Exit;\r\n DataDir := NtHeaders^.OptionalHeader.DataDirectory[IMAGE_DIRECTORY_ENTRY_EXPORT];\r\n if DataDir.Size = 0 then\r\n Exit;\r\n ExportDir := PImageExportDirectory(TJclAddr(BaseAddress) + DataDir.VirtualAddress);\r\n if IsBadReadPtr(ExportDir, SizeOf(TImageExportDirectory)) or (ExportDir^.Name = 0) then\r\n Exit;\r\n UTF8Name := PAnsiChar(TJclAddr(BaseAddress) + ExportDir^.Name);\r\n if not TryUTF8ToString(UTF8Name, Result) then\r\n Result := string(UTF8Name);\r\nend;\r\n\r\nfunction PeMapImgLibraryName64(const BaseAddress: Pointer): string;\r\nvar\r\n NtHeaders: PImageNtHeaders64;\r\n DataDir: TImageDataDirectory;\r\n ExportDir: PImageExportDirectory;\r\n UTF8Name: TUTF8String;\r\nbegin\r\n Result := '';\r\n NtHeaders := PeMapImgNtHeaders64(BaseAddress);\r\n if NtHeaders = nil then\r\n Exit;\r\n DataDir := NtHeaders^.OptionalHeader.DataDirectory[IMAGE_DIRECTORY_ENTRY_EXPORT];\r\n if DataDir.Size = 0 then\r\n Exit;\r\n ExportDir := PImageExportDirectory(TJclAddr(BaseAddress) + DataDir.VirtualAddress);\r\n if IsBadReadPtr(ExportDir, SizeOf(TImageExportDirectory)) or (ExportDir^.Name = 0) then\r\n Exit;\r\n UTF8Name := PAnsiChar(TJclAddr(BaseAddress) + ExportDir^.Name);\r\n if not TryUTF8ToString(UTF8Name, Result) then\r\n Result := string(UTF8Name);\r\nend;\r\n\r\nfunction PeMapImgTarget(const BaseAddress: Pointer): TJclPeTarget;\r\nvar\r\n ImageNtHeaders: PImageNtHeaders32;\r\nbegin\r\n Result := taUnknown;\r\n\r\n ImageNtHeaders := PeMapImgNtHeaders32(BaseAddress);\r\n if Assigned(ImageNtHeaders) then\r\n case ImageNtHeaders.FileHeader.Machine of\r\n IMAGE_FILE_MACHINE_I386:\r\n Result := taWin32;\r\n IMAGE_FILE_MACHINE_AMD64:\r\n Result := taWin64;\r\n end;\r\nend;\r\n\r\nfunction PeMapImgTarget(Stream: TStream; const BasePosition: Int64): TJclPeTarget;\r\nvar\r\n ImageNtHeaders: TImageNtHeaders32;\r\nbegin\r\n Result := taUnknown;\r\n\r\n if PeMapImgNtHeaders32(Stream, BasePosition, ImageNtHeaders) <> -1 then\r\n begin\r\n case ImageNtHeaders.FileHeader.Machine of\r\n IMAGE_FILE_MACHINE_I386:\r\n Result := taWin32;\r\n IMAGE_FILE_MACHINE_AMD64:\r\n Result := taWin64;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction PeMapImgSections32(NtHeaders: PImageNtHeaders32): PImageSectionHeader;\r\nbegin\r\n if NtHeaders = nil then\r\n Result := nil\r\n else\r\n Result := PImageSectionHeader(TJclAddr(@NtHeaders^.OptionalHeader) +\r\n NtHeaders^.FileHeader.SizeOfOptionalHeader);\r\nend;\r\n\r\nfunction PeMapImgSections32(Stream: TStream; const NtHeaders32Position: Int64; const NtHeaders32: TImageNtHeaders32;\r\n out ImageSectionHeaders: TImageSectionHeaderArray): Int64;\r\nvar\r\n SectionSize: Integer;\r\nbegin\r\n if NtHeaders32Position = -1 then\r\n begin\r\n SetLength(ImageSectionHeaders, 0);\r\n Result := -1;\r\n end\r\n else\r\n begin\r\n SetLength(ImageSectionHeaders, NtHeaders32.FileHeader.NumberOfSections);\r\n Result := NtHeaders32Position + SizeOf(NtHeaders32.Signature) + SizeOf(NtHeaders32.FileHeader) + NtHeaders32.FileHeader.SizeOfOptionalHeader;\r\n\r\n SectionSize := SizeOf(ImageSectionHeaders[0]) * Length(ImageSectionHeaders);\r\n if (Stream.Seek(Result, soBeginning) <> Result) or\r\n (Stream.Read(ImageSectionHeaders[0], SectionSize) <> SectionSize) then\r\n raise EJclPeImageError.CreateRes(@SReadError);\r\n end;\r\nend;\r\n\r\nfunction PeMapImgSections64(NtHeaders: PImageNtHeaders64): PImageSectionHeader;\r\nbegin\r\n if NtHeaders = nil then\r\n Result := nil\r\n else\r\n Result := PImageSectionHeader(TJclAddr(@NtHeaders^.OptionalHeader) +\r\n NtHeaders^.FileHeader.SizeOfOptionalHeader);\r\nend;\r\n\r\nfunction PeMapImgSections64(Stream: TStream; const NtHeaders64Position: Int64; const NtHeaders64: TImageNtHeaders64;\r\n out ImageSectionHeaders: TImageSectionHeaderArray): Int64;\r\nvar\r\n SectionSize: Integer;\r\nbegin\r\n if NtHeaders64Position = -1 then\r\n begin\r\n SetLength(ImageSectionHeaders, 0);\r\n Result := -1;\r\n end\r\n else\r\n begin\r\n SetLength(ImageSectionHeaders, NtHeaders64.FileHeader.NumberOfSections);\r\n Result := NtHeaders64Position + SizeOf(NtHeaders64.Signature) + SizeOf(NtHeaders64.FileHeader) + NtHeaders64.FileHeader.SizeOfOptionalHeader;\r\n\r\n SectionSize := SizeOf(ImageSectionHeaders[0]) * Length(ImageSectionHeaders);\r\n if (Stream.Seek(Result, soBeginning) <> Result) or\r\n (Stream.Read(ImageSectionHeaders[0], SectionSize) <> SectionSize) then\r\n raise EJclPeImageError.CreateRes(@SReadError);\r\n end;\r\nend;\r\n\r\nfunction PeMapImgFindSection32(NtHeaders: PImageNtHeaders32;\r\n const SectionName: string): PImageSectionHeader;\r\nvar\r\n Header: PImageSectionHeader;\r\n I: Integer;\r\n P: PAnsiChar;\r\n UTF8Name: TUTF8String;\r\nbegin\r\n Result := nil;\r\n if NtHeaders <> nil then\r\n begin\r\n if not TryStringToUTF8(SectionName, UTF8Name) then\r\n UTF8Name := TUTF8String(SectionName);\r\n P := PAnsiChar(UTF8Name);\r\n Header := PeMapImgSections32(NtHeaders);\r\n for I := 1 to NtHeaders^.FileHeader.NumberOfSections do\r\n if StrLComp(PAnsiChar(@Header^.Name), P, IMAGE_SIZEOF_SHORT_NAME) = 0 then\r\n begin\r\n Result := Header;\r\n Break;\r\n end\r\n else\r\n Inc(Header);\r\n end;\r\nend;\r\n\r\nfunction PeMapImgFindSection64(NtHeaders: PImageNtHeaders64;\r\n const SectionName: string): PImageSectionHeader;\r\nvar\r\n Header: PImageSectionHeader;\r\n I: Integer;\r\n P: PAnsiChar;\r\n UTF8Name: TUTF8String;\r\nbegin\r\n Result := nil;\r\n if NtHeaders <> nil then\r\n begin\r\n if not TryStringToUTF8(SectionName, UTF8Name) then\r\n UTF8Name := TUTF8String(SectionName);\r\n P := PAnsiChar(UTF8Name);\r\n Header := PeMapImgSections64(NtHeaders);\r\n for I := 1 to NtHeaders^.FileHeader.NumberOfSections do\r\n if StrLComp(PAnsiChar(@Header^.Name), P, IMAGE_SIZEOF_SHORT_NAME) = 0 then\r\n begin\r\n Result := Header;\r\n Break;\r\n end\r\n else\r\n Inc(Header);\r\n end;\r\nend;\r\n\r\nfunction PeMapImgFindSection(const ImageSectionHeaders: TImageSectionHeaderArray;\r\n const SectionName: string): SizeInt;\r\nvar\r\n P: PAnsiChar;\r\n UTF8Name: TUTF8String;\r\nbegin\r\n if Length(ImageSectionHeaders) > 0 then\r\n begin\r\n if not TryStringToUTF8(SectionName, UTF8Name) then\r\n UTF8Name := TUTF8String(SectionName);\r\n P := PAnsiChar(UTF8Name);\r\n for Result := Low(ImageSectionHeaders) to High(ImageSectionHeaders) do\r\n if StrLComp(PAnsiChar(@ImageSectionHeaders[Result].Name), P, IMAGE_SIZEOF_SHORT_NAME) = 0 then\r\n Exit;\r\n end;\r\n Result := -1;\r\nend;\r\n\r\nfunction PeMapImgFindSectionFromModule(const BaseAddress: Pointer;\r\n const SectionName: string): PImageSectionHeader;\r\n function PeMapImgFindSectionFromModule32(const BaseAddress: Pointer;\r\n const SectionName: string): PImageSectionHeader;\r\n var\r\n NtHeaders32: PImageNtHeaders32;\r\n begin\r\n Result := nil;\r\n NtHeaders32 := PeMapImgNtHeaders32(BaseAddress);\r\n if Assigned(NtHeaders32) then\r\n Result := PeMapImgFindSection32(NtHeaders32, SectionName);\r\n end;\r\n function PeMapImgFindSectionFromModule64(const BaseAddress: Pointer;\r\n const SectionName: string): PImageSectionHeader;\r\n var\r\n NtHeaders64: PImageNtHeaders64;\r\n begin\r\n Result := nil;\r\n NtHeaders64 := PeMapImgNtHeaders64(BaseAddress);\r\n if Assigned(NtHeaders64) then\r\n Result := PeMapImgFindSection64(NtHeaders64, SectionName);\r\n end;\r\nbegin\r\n case PeMapImgTarget(BaseAddress) of\r\n taWin32:\r\n Result := PeMapImgFindSectionFromModule32(BaseAddress, SectionName);\r\n taWin64:\r\n Result := PeMapImgFindSectionFromModule64(BaseAddress, SectionName);\r\n //taUnknown:\r\n else\r\n Result := nil;\r\n end;\r\nend;\r\n\r\nfunction PeMapImgExportedVariables(const Module: HMODULE; const VariablesList: TStrings): Boolean;\r\nvar\r\n I: Integer;\r\nbegin\r\n with TJclPeImage.Create(True) do\r\n try\r\n AttachLoadedModule(Module);\r\n Result := StatusOK;\r\n if Result then\r\n begin\r\n VariablesList.BeginUpdate;\r\n try\r\n with ExportList do\r\n for I := 0 to Count - 1 do\r\n with Items[I] do\r\n if IsExportedVariable then\r\n VariablesList.AddObject(Name, MappedAddress);\r\n finally\r\n VariablesList.EndUpdate;\r\n end;\r\n end;\r\n finally\r\n Free;\r\n end;\r\nend;\r\n\r\nfunction PeMapImgResolvePackageThunk(Address: Pointer): Pointer;\r\n{$IFDEF BORLAND}\r\nconst\r\n JmpInstructionCode = $25FF;\r\ntype\r\n PPackageThunk = ^TPackageThunk;\r\n TPackageThunk = packed record\r\n JmpInstruction: Word;\r\n JmpAddress: PPointer;\r\n end;\r\nbegin\r\n if not IsCompiledWithPackages then\r\n Result := Address\r\n else\r\n if not IsBadReadPtr(Address, SizeOf(TPackageThunk)) and\r\n (PPackageThunk(Address)^.JmpInstruction = JmpInstructionCode) then\r\n Result := PPackageThunk(Address)^.JmpAddress^\r\n else\r\n Result := nil;\r\nend;\r\n{$ENDIF BORLAND}\r\n{$IFDEF FPC}\r\nbegin\r\n Result := Address;\r\nend;\r\n{$ENDIF FPC}\r\n\r\nfunction PeMapFindResource(const Module: HMODULE; const ResourceType: PChar;\r\n const ResourceName: string): Pointer;\r\nvar\r\n ResItem: TJclPeResourceItem;\r\nbegin\r\n Result := nil;\r\n with TJclPeImage.Create(True) do\r\n try\r\n AttachLoadedModule(Module);\r\n if StatusOK then\r\n begin\r\n ResItem := ResourceList.FindResource(ResourceType, PChar(ResourceName));\r\n if (ResItem <> nil) and ResItem.IsDirectory then\r\n Result := ResItem.List[0].RawEntryData;\r\n end;\r\n finally\r\n Free;\r\n end;\r\nend;\r\n\r\n//=== { TJclPeSectionStream } ================================================\r\n\r\nconstructor TJclPeSectionStream.Create(Instance: HMODULE; const ASectionName: string);\r\nbegin\r\n inherited Create;\r\n Initialize(Instance, ASectionName);\r\nend;\r\n\r\nprocedure TJclPeSectionStream.Initialize(Instance: HMODULE; const ASectionName: string);\r\nvar\r\n Header: PImageSectionHeader;\r\n NtHeaders32: PImageNtHeaders32;\r\n NtHeaders64: PImageNtHeaders64;\r\n DataSize: Integer;\r\nbegin\r\n FInstance := Instance;\r\n case PeMapImgTarget(Pointer(Instance)) of\r\n taWin32:\r\n begin\r\n NtHeaders32 := PeMapImgNtHeaders32(Pointer(Instance));\r\n if NtHeaders32 = nil then\r\n raise EJclPeImageError.CreateRes(@RsPeNotPE);\r\n Header := PeMapImgFindSection32(NtHeaders32, ASectionName);\r\n end;\r\n taWin64:\r\n begin\r\n NtHeaders64 := PeMapImgNtHeaders64(Pointer(Instance));\r\n if NtHeaders64 = nil then\r\n raise EJclPeImageError.CreateRes(@RsPeNotPE);\r\n Header := PeMapImgFindSection64(NtHeaders64, ASectionName);\r\n end;\r\n //toUnknown:\r\n else\r\n raise EJclPeImageError.CreateRes(@RsPeUnknownTarget);\r\n end;\r\n if Header = nil then\r\n raise EJclPeImageError.CreateResFmt(@RsPeSectionNotFound, [ASectionName]);\r\n // Borland and Microsoft seems to have swapped the meaning of this items.\r\n DataSize := Min(Header^.SizeOfRawData, Header^.Misc.VirtualSize);\r\n SetPointer(Pointer(FInstance + Header^.VirtualAddress), DataSize);\r\n FSectionHeader := Header^;\r\nend;\r\n\r\nfunction TJclPeSectionStream.Write(const Buffer; Count: Integer): Longint;\r\nbegin\r\n raise EJclPeImageError.CreateRes(@RsPeReadOnlyStream);\r\nend;\r\n\r\n//=== { TJclPeMapImgHookItem } ===============================================\r\n\r\nconstructor TJclPeMapImgHookItem.Create(AList: TObjectList;\r\n const AFunctionName: string; const AModuleName: string;\r\n ABaseAddress, ANewAddress, AOriginalAddress: Pointer);\r\nbegin\r\n inherited Create;\r\n FList := AList;\r\n FFunctionName := AFunctionName;\r\n FModuleName := AModuleName;\r\n FBaseAddress := ABaseAddress;\r\n FNewAddress := ANewAddress;\r\n FOriginalAddress := AOriginalAddress;\r\nend;\r\n\r\ndestructor TJclPeMapImgHookItem.Destroy;\r\nbegin\r\n if FBaseAddress <> nil then\r\n InternalUnhook;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJclPeMapImgHookItem.InternalUnhook: Boolean;\r\nvar\r\n Buf: TMemoryBasicInformation;\r\nbegin\r\n Buf.AllocationBase := nil;\r\n if (VirtualQuery(FBaseAddress, Buf, SizeOf(Buf)) = SizeOf(Buf)) and (Buf.State and MEM_FREE = 0) then\r\n Result := TJclPeMapImgHooks.ReplaceImport(FBaseAddress, ModuleName, NewAddress, OriginalAddress)\r\n else\r\n Result := True; // PE image is not available anymore (DLL got unloaded)\r\n if Result then\r\n FBaseAddress := nil;\r\nend;\r\n\r\nfunction TJclPeMapImgHookItem.Unhook: Boolean;\r\nbegin\r\n Result := InternalUnhook;\r\n if Result then\r\n FList.Remove(Self);\r\nend;\r\n\r\n//=== { TJclPeMapImgHooks } ==================================================\r\n\r\ntype\r\n PWin9xDebugThunk32 = ^TWin9xDebugThunk32;\r\n TWin9xDebugThunk32 = packed record\r\n PUSH: Byte; // PUSH instruction opcode ($68)\r\n Addr: DWORD; // The actual address of the DLL routine\r\n JMP: Byte; // JMP instruction opcode ($E9)\r\n Rel: DWORD; // Relative displacement (a Kernel32 address)\r\n end;\r\n\r\nfunction TJclPeMapImgHooks.GetItemFromNewAddress(NewAddress: Pointer): TJclPeMapImgHookItem;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := nil;\r\n for I := 0 to Count - 1 do\r\n if Items[I].NewAddress = NewAddress then\r\n begin\r\n Result := Items[I];\r\n Break;\r\n end;\r\nend;\r\n\r\nfunction TJclPeMapImgHooks.GetItemFromOriginalAddress(OriginalAddress: Pointer): TJclPeMapImgHookItem;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := nil;\r\n for I := 0 to Count - 1 do\r\n if Items[I].OriginalAddress = OriginalAddress then\r\n begin\r\n Result := Items[I];\r\n Break;\r\n end;\r\nend;\r\n\r\nfunction TJclPeMapImgHooks.GetItems(Index: Integer): TJclPeMapImgHookItem;\r\nbegin\r\n Result := TJclPeMapImgHookItem(Get(Index));\r\nend;\r\n\r\nfunction TJclPeMapImgHooks.HookImport(Base: Pointer; const ModuleName: string;\r\n const FunctionName: string; NewAddress: Pointer; var OriginalAddress: Pointer): Boolean;\r\nvar\r\n ModuleHandle: THandle;\r\n OriginalItem: TJclPeMapImgHookItem;\r\n UTF8Name: TUTF8String;\r\nbegin\r\n ModuleHandle := GetModuleHandle(PChar(ModuleName));\r\n Result := (ModuleHandle <> 0);\r\n if not Result then\r\n begin\r\n SetLastError(ERROR_MOD_NOT_FOUND);\r\n Exit;\r\n end;\r\n if not TryStringToUTF8(FunctionName, UTF8Name) then\r\n UTF8Name := TUTF8String(FunctionName);\r\n OriginalAddress := GetProcAddress(ModuleHandle, PAnsiChar(UTF8Name));\r\n Result := (OriginalAddress <> nil);\r\n if not Result then\r\n begin\r\n SetLastError(ERROR_PROC_NOT_FOUND);\r\n Exit;\r\n end;\r\n OriginalItem := ItemFromOriginalAddress[OriginalAddress];\r\n Result := ((OriginalItem = nil) or (OriginalItem.ModuleName = ModuleName)) and\r\n (NewAddress <> nil) and (OriginalAddress <> NewAddress);\r\n if not Result then\r\n begin\r\n SetLastError(ERROR_ALREADY_EXISTS);\r\n Exit;\r\n end;\r\n if Result then\r\n Result := ReplaceImport(Base, ModuleName, OriginalAddress, NewAddress);\r\n if Result then\r\n begin\r\n Add(TJclPeMapImgHookItem.Create(Self, FunctionName, ModuleName, Base,\r\n NewAddress, OriginalAddress));\r\n end\r\n else\r\n SetLastError(ERROR_INVALID_PARAMETER);\r\nend;\r\n\r\nclass function TJclPeMapImgHooks.IsWin9xDebugThunk(P: Pointer): Boolean;\r\nbegin\r\n with PWin9xDebugThunk32(P)^ do\r\n Result := (PUSH = $68) and (JMP = $E9);\r\nend;\r\n\r\nclass function TJclPeMapImgHooks.ReplaceImport(Base: Pointer; const ModuleName: string;\r\n FromProc, ToProc: Pointer): Boolean;\r\nvar\r\n {$IFDEF CPU32}\r\n FromProcDebugThunk32, ImportThunk32: PWin9xDebugThunk32;\r\n IsThunked: Boolean;\r\n {$ENDIF CPU32}\r\n NtHeader32: PImageNtHeaders32;\r\n ImportDir: TImageDataDirectory;\r\n ImportDesc: PImageImportDescriptor;\r\n CurrName, RefName: PAnsiChar;\r\n {$IFDEF CPU32}\r\n ImportEntry32: PImageThunkData32;\r\n {$ENDIF CPU32}\r\n {$IFDEF CPU64}\r\n ImportEntry64: PImageThunkData64;\r\n {$ENDIF CPU64}\r\n FoundProc: Boolean;\r\n WrittenBytes: Cardinal;\r\n UTF8Name: TUTF8String;\r\nbegin\r\n Result := False;\r\n {$IFDEF CPU32}\r\n FromProcDebugThunk32 := PWin9xDebugThunk32(FromProc);\r\n IsThunked := not IsWinNT and IsWin9xDebugThunk(FromProcDebugThunk32);\r\n {$ENDIF CPU32}\r\n NtHeader32 := PeMapImgNtHeaders32(Base);\r\n if NtHeader32 = nil then\r\n Exit;\r\n ImportDir := NtHeader32.OptionalHeader.DataDirectory[IMAGE_DIRECTORY_ENTRY_IMPORT];\r\n if ImportDir.VirtualAddress = 0 then\r\n Exit;\r\n ImportDesc := PImageImportDescriptor(TJclAddr(Base) + ImportDir.VirtualAddress);\r\n if not TryStringToUTF8(ModuleName, UTF8Name) then\r\n UTF8Name := TUTF8String(ModuleName);\r\n RefName := PAnsiChar(UTF8Name);\r\n while ImportDesc^.Name <> 0 do\r\n begin\r\n CurrName := PAnsiChar(Base) + ImportDesc^.Name;\r\n if StrIComp(CurrName, RefName) = 0 then\r\n begin\r\n {$IFDEF CPU32}\r\n ImportEntry32 := PImageThunkData32(TJclAddr(Base) + ImportDesc^.FirstThunk);\r\n while ImportEntry32^.Function_ <> 0 do\r\n begin\r\n if IsThunked then\r\n begin\r\n ImportThunk32 := PWin9xDebugThunk32(ImportEntry32^.Function_);\r\n FoundProc := IsWin9xDebugThunk(ImportThunk32) and (ImportThunk32^.Addr = FromProcDebugThunk32^.Addr);\r\n end\r\n else\r\n FoundProc := Pointer(ImportEntry32^.Function_) = FromProc;\r\n if FoundProc then\r\n Result := WriteProtectedMemory(@ImportEntry32^.Function_, @ToProc, SizeOf(ToProc), WrittenBytes);\r\n Inc(ImportEntry32);\r\n end;\r\n {$ENDIF CPU32}\r\n {$IFDEF CPU64}\r\n ImportEntry64 := PImageThunkData64(TJclAddr(Base) + ImportDesc^.FirstThunk);\r\n while ImportEntry64^.Function_ <> 0 do\r\n begin\r\n FoundProc := Pointer(ImportEntry64^.Function_) = FromProc;\r\n if FoundProc then\r\n Result := WriteProtectedMemory(@ImportEntry64^.Function_, @ToProc, SizeOf(ToProc), WrittenBytes);\r\n Inc(ImportEntry64);\r\n end;\r\n {$ENDIF CPU64}\r\n end;\r\n Inc(ImportDesc);\r\n end;\r\nend;\r\n\r\nclass function TJclPeMapImgHooks.SystemBase: Pointer;\r\nbegin\r\n Result := Pointer(SystemTObjectInstance);\r\nend;\r\n\r\nprocedure TJclPeMapImgHooks.UnhookAll;\r\nvar\r\n I: Integer;\r\nbegin\r\n I := 0;\r\n while I < Count do\r\n if not Items[I].Unhook then\r\n Inc(I);\r\nend;\r\n\r\nfunction TJclPeMapImgHooks.UnhookByNewAddress(NewAddress: Pointer): Boolean;\r\nvar\r\n Item: TJclPeMapImgHookItem;\r\nbegin\r\n Item := ItemFromNewAddress[NewAddress];\r\n Result := (Item <> nil) and Item.Unhook;\r\nend;\r\n\r\nprocedure TJclPeMapImgHooks.UnhookByBaseAddress(BaseAddress: Pointer);\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := Count - 1 downto 0 do\r\n if Items[I].BaseAddress = BaseAddress then\r\n Items[I].Unhook;\r\nend;\r\n\r\n// Image access under a debbuger\r\n{$IFDEF USE_64BIT_TYPES}\r\nfunction InternalReadProcMem(ProcessHandle: THandle; Address: DWORD;\r\n Buffer: Pointer; Size: SIZE_T): Boolean;\r\nvar\r\n BR: SIZE_T;\r\n{$ELSE}\r\nfunction InternalReadProcMem(ProcessHandle: THandle; Address: DWORD;\r\n Buffer: Pointer; Size: Integer): Boolean;\r\nvar\r\n BR: DWORD;\r\n{$ENDIF}\r\nbegin\r\n BR := 0;\r\n Result := ReadProcessMemory(ProcessHandle, Pointer(Address), Buffer, Size, BR);\r\nend;\r\n\r\n// TODO: 64 bit version\r\nfunction PeDbgImgNtHeaders32(ProcessHandle: THandle; BaseAddress: TJclAddr32;\r\n var NtHeaders: TImageNtHeaders32): Boolean;\r\nvar\r\n DosHeader: TImageDosHeader;\r\nbegin\r\n Result := False;\r\n ResetMemory(NtHeaders, SizeOf(NtHeaders));\r\n ResetMemory(DosHeader, SizeOf(DosHeader));\r\n if not InternalReadProcMem(ProcessHandle, TJclAddr32(BaseAddress), @DosHeader, SizeOf(DosHeader)) then\r\n Exit;\r\n if DosHeader.e_magic <> IMAGE_DOS_SIGNATURE then\r\n Exit;\r\n Result := InternalReadProcMem(ProcessHandle, TJclAddr32(BaseAddress) + TJclAddr32(DosHeader._lfanew),\r\n @NtHeaders, SizeOf(TImageNtHeaders32));\r\nend;\r\n\r\n// TODO: 64 bit version\r\nfunction PeDbgImgLibraryName32(ProcessHandle: THandle; BaseAddress: TJclAddr32;\r\n var Name: string): Boolean;\r\nvar\r\n NtHeaders32: TImageNtHeaders32;\r\n DataDir: TImageDataDirectory;\r\n ExportDir: TImageExportDirectory;\r\n UTF8Name: TUTF8String;\r\nbegin\r\n Name := '';\r\n\r\n NtHeaders32.Signature := 0;\r\n Result := PeDbgImgNtHeaders32(ProcessHandle, BaseAddress, NtHeaders32);\r\n if not Result then\r\n Exit;\r\n DataDir := NtHeaders32.OptionalHeader.DataDirectory[IMAGE_DIRECTORY_ENTRY_EXPORT];\r\n if DataDir.Size = 0 then\r\n Exit;\r\n if not InternalReadProcMem(ProcessHandle, TJclAddr(BaseAddress) + DataDir.VirtualAddress,\r\n @ExportDir, SizeOf(ExportDir)) then\r\n Exit;\r\n if ExportDir.Name = 0 then\r\n Exit;\r\n SetLength(UTF8Name, MAX_PATH);\r\n if InternalReadProcMem(ProcessHandle, TJclAddr(BaseAddress) + ExportDir.Name, PAnsiChar(UTF8Name), MAX_PATH) then\r\n begin\r\n StrResetLength(UTF8Name);\r\n if not TryUTF8ToString(UTF8Name, Name) then\r\n Name := string(UTF8Name);\r\n end\r\n else\r\n Name := '';\r\nend;\r\n\r\n// Borland BPL packages name unmangling\r\n\r\nfunction PeBorUnmangleName(const Name: string; out Unmangled: string;\r\n out Description: TJclBorUmDescription; out BasePos: Integer): TJclBorUmResult;\r\nvar\r\n NameP, NameU, NameUFirst: PAnsiChar;\r\n QualifierFound, LinkProcFound: Boolean;\r\n UTF8Unmangled, UTF8Name: TUTF8String;\r\n\r\n procedure MarkQualifier;\r\n begin\r\n if not QualifierFound then\r\n begin\r\n QualifierFound := True;\r\n BasePos := NameU - NameUFirst + 2;\r\n end;\r\n end;\r\n\r\n procedure ReadSpecialSymbol;\r\n var\r\n SymbolLength: Integer;\r\n begin\r\n SymbolLength := 0;\r\n while CharIsDigit(Char(NameP^)) do\r\n begin\r\n SymbolLength := SymbolLength * 10 + Ord(NameP^) - 48;\r\n Inc(NameP);\r\n end;\r\n while (SymbolLength > 0) and (NameP^ <> #0) do\r\n begin\r\n if NameP^ = '@' then\r\n begin\r\n MarkQualifier;\r\n NameU^ := '.';\r\n end\r\n else\r\n NameU^ := NameP^;\r\n Inc(NameP);\r\n Inc(NameU);\r\n Dec(SymbolLength);\r\n end;\r\n end;\r\n\r\n procedure ReadRTTI;\r\n begin\r\n if StrLComp(NameP, '$xp$', 4) = 0 then\r\n begin\r\n Inc(NameP, 4);\r\n Description.Kind := skRTTI;\r\n QualifierFound := False;\r\n ReadSpecialSymbol;\r\n if QualifierFound then\r\n Include(Description.Modifiers, smQualified);\r\n end\r\n else\r\n Result := urError;\r\n end;\r\n\r\n procedure ReadNameSymbol;\r\n begin\r\n if NameP^ = '@' then\r\n begin\r\n LinkProcFound := True;\r\n Inc(NameP);\r\n end;\r\n while CharIsValidIdentifierLetter(Char(NameP^)) do\r\n begin\r\n NameU^ := NameP^;\r\n Inc(NameP);\r\n Inc(NameU);\r\n end;\r\n end;\r\n\r\n procedure ReadName;\r\n begin\r\n Description.Kind := skData;\r\n QualifierFound := False;\r\n LinkProcFound := False;\r\n repeat\r\n ReadNameSymbol;\r\n if LinkProcFound and not QualifierFound then\r\n LinkProcFound := False;\r\n case NameP^ of\r\n '@':\r\n case (NameP + 1)^ of\r\n #0:\r\n begin\r\n Description.Kind := skVTable;\r\n Break;\r\n end;\r\n '$':\r\n begin\r\n if (NameP + 2)^ = 'b' then\r\n begin\r\n case (NameP + 3)^ of\r\n 'c':\r\n Description.Kind := skConstructor;\r\n 'd':\r\n Description.Kind := skDestructor;\r\n end;\r\n Inc(NameP, 6);\r\n end\r\n else\r\n Description.Kind := skFunction;\r\n Break; // no parameters unmangling yet\r\n end;\r\n else\r\n MarkQualifier;\r\n NameU^ := '.';\r\n Inc(NameU);\r\n Inc(NameP);\r\n end;\r\n '$':\r\n begin\r\n Description.Kind := skFunction;\r\n Break; // no parameters unmangling yet\r\n end;\r\n else\r\n Break;\r\n end;\r\n until False;\r\n if QualifierFound then\r\n Include(Description.Modifiers, smQualified);\r\n if LinkProcFound then\r\n Include(Description.Modifiers, smLinkProc);\r\n end;\r\n\r\nbegin\r\n if not TryStringToUTF8(Name, UTF8Name) then\r\n UTF8Name := TUTF8String(Name);\r\n NameP := PAnsiChar(UTF8Name);\r\n Result := urError;\r\n case NameP^ of\r\n '@':\r\n Result := urOk;\r\n '?':\r\n Result := urMicrosoft;\r\n '_', 'A'..'Z', 'a'..'z':\r\n Result := urNotMangled;\r\n end;\r\n if Result <> urOk then\r\n Exit;\r\n Inc(NameP);\r\n SetLength(UTF8UnMangled, 1024);\r\n NameU := PAnsiChar(UTF8UnMangled);\r\n NameUFirst := NameU;\r\n Description.Modifiers := [];\r\n BasePos := 1;\r\n case NameP^ of\r\n '$':\r\n ReadRTTI;\r\n '_', 'A'..'Z', 'a'..'z':\r\n ReadName;\r\n else\r\n Result := urError;\r\n end;\r\n NameU^ := #0;\r\n SetLength(UTF8Unmangled, {$IFDEF HAS_UNITSCOPE}System.{$ENDIF}SysUtils.StrLen(PAnsiChar(UTF8Unmangled))); // SysUtils prefix due to compiler bug\r\n if not TryUTF8ToString(UTF8Unmangled, Unmangled) then\r\n Unmangled := string(UTF8Unmangled);\r\nend;\r\n\r\nfunction PeBorUnmangleName(const Name: string; out Unmangled: string;\r\n out Description: TJclBorUmDescription): TJclBorUmResult;\r\nvar\r\n BasePos: Integer;\r\nbegin\r\n Result := PeBorUnmangleName(Name, Unmangled, Description, BasePos);\r\nend;\r\n\r\nfunction PeBorUnmangleName(const Name: string; out Unmangled: string): TJclBorUmResult;\r\nvar\r\n Description: TJclBorUmDescription;\r\n BasePos: Integer;\r\nbegin\r\n Result := PeBorUnmangleName(Name, Unmangled, Description, BasePos);\r\nend;\r\n\r\nfunction PeBorUnmangleName(const Name: string): string;\r\nvar\r\n Unmangled: string;\r\n Description: TJclBorUmDescription;\r\n BasePos: Integer;\r\nbegin\r\n if PeBorUnmangleName(Name, Unmangled, Description, BasePos) = urOk then\r\n Result := Unmangled\r\n else\r\n Result := '';\r\nend;\r\n\r\nfunction PeIsNameMangled(const Name: string): TJclPeUmResult;\r\nbegin\r\n Result := umNotMangled;\r\n if Length(Name) > 0 then\r\n case Name[1] of\r\n '@':\r\n Result := umBorland;\r\n '?':\r\n Result := umMicrosoft;\r\n end;\r\nend;\r\n\r\ntype\r\n TUndecorateSymbolNameA = function (DecoratedName: PAnsiChar;\r\n UnDecoratedName: PAnsiChar; UndecoratedLength: DWORD; Flags: DWORD): DWORD; stdcall;\r\n// 'imagehlp.dll' 'UnDecorateSymbolName'\r\n\r\n TUndecorateSymbolNameW = function (DecoratedName: PWideChar;\r\n UnDecoratedName: PWideChar; UndecoratedLength: DWORD; Flags: DWORD): DWORD; stdcall;\r\n// 'imagehlp.dll' 'UnDecorateSymbolNameW'\r\n\r\nvar\r\n UndecorateSymbolNameA: TUndecorateSymbolNameA = nil;\r\n UndecorateSymbolNameAFailed: Boolean = False;\r\n UndecorateSymbolNameW: TUndecorateSymbolNameW = nil;\r\n UndecorateSymbolNameWFailed: Boolean = False;\r\n\r\nfunction UndecorateSymbolName(const DecoratedName: string; out UnMangled: string; Flags: DWORD): Boolean;\r\nconst\r\n ModuleName = 'imagehlp.dll';\r\n BufferSize = 512;\r\nvar\r\n ModuleHandle: HMODULE;\r\n WideBuffer: WideString;\r\n AnsiBuffer: AnsiString;\r\n Res: DWORD;\r\nbegin\r\n Result := False;\r\n if ((not Assigned(UndecorateSymbolNameA)) and (not UndecorateSymbolNameAFailed)) or\r\n ((not Assigned(UndecorateSymbolNameW)) and (not UndecorateSymbolNameWFailed)) then\r\n begin\r\n ModuleHandle := GetModuleHandle(ModuleName);\r\n if ModuleHandle = 0 then\r\n begin\r\n ModuleHandle := SafeLoadLibrary(ModuleName);\r\n if ModuleHandle = 0 then\r\n Exit;\r\n end;\r\n UndecorateSymbolNameA := GetProcAddress(ModuleHandle, 'UnDecorateSymbolName');\r\n UndecorateSymbolNameAFailed := not Assigned(UndecorateSymbolNameA);\r\n UndecorateSymbolNameW := GetProcAddress(ModuleHandle, 'UnDecorateSymbolNameW');\r\n UndecorateSymbolNameWFailed := not Assigned(UndecorateSymbolNameW);\r\n end;\r\n if Assigned(UndecorateSymbolNameW) then\r\n begin\r\n SetLength(WideBuffer, BufferSize);\r\n Res := UnDecorateSymbolNameW(PWideChar(WideString(DecoratedName)), PWideChar(WideBuffer), BufferSize, Flags);\r\n if Res > 0 then\r\n begin\r\n StrResetLength(WideBuffer);\r\n UnMangled := string(WideBuffer);\r\n Result := True;\r\n end;\r\n end\r\n else\r\n if Assigned(UndecorateSymbolNameA) then\r\n begin\r\n SetLength(AnsiBuffer, BufferSize);\r\n Res := UnDecorateSymbolNameA(PAnsiChar(AnsiString(DecoratedName)), PAnsiChar(AnsiBuffer), BufferSize, Flags);\r\n if Res > 0 then\r\n begin\r\n StrResetLength(AnsiBuffer);\r\n UnMangled := string(AnsiBuffer);\r\n Result := True;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction PeUnmangleName(const Name: string; out Unmangled: string): TJclPeUmResult;\r\nbegin\r\n Result := umNotMangled;\r\n case PeBorUnmangleName(Name, Unmangled) of\r\n urOk:\r\n Result := umBorland;\r\n urMicrosoft:\r\n if UndecorateSymbolName(Name, Unmangled, UNDNAME_NAME_ONLY) then\r\n Result := umMicrosoft;\r\n end;\r\n if Result = umNotMangled then\r\n Unmangled := Name;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jcl/source/windows/JclRegistry.pas", "content": "{**************************************************************************************************}\r\n{ }\r\n{ Project JEDI Code Library (JCL) }\r\n{ }\r\n{ The contents of this file are subject to the Mozilla Public License Version 1.1 (the \"License\"); }\r\n{ you may not use this file except in compliance with the License. You may obtain a copy of the }\r\n{ License at http://www.mozilla.org/MPL/ }\r\n{ }\r\n{ Software distributed under the License is distributed on an \"AS IS\" basis, WITHOUT WARRANTY OF }\r\n{ ANY KIND, either express or implied. See the License for the specific language governing rights }\r\n{ and limitations under the License. }\r\n{ }\r\n{ The Original Code is JclRegistry.pas. }\r\n{ }\r\n{ The Initial Developers of the Original Code are John C Molyneux, Marcel van Brakel and }\r\n{ Charlie Calvert. Portions created by these individuals are Copyright (C) of these individuals. }\r\n{ All Rights Reserved. }\r\n{ }\r\n{ Contributors: }\r\n{ Marcel van Brakel }\r\n{ Stephane Fillon }\r\n{ Eric S.Fisher }\r\n{ Peter Friese }\r\n{ Andreas Hausladen (ahuser) }\r\n{ Manlio Laschena (manlio) }\r\n{ Robert Marquardt (marquardt) }\r\n{ Robert Rossmair (rrossmair) }\r\n{ Olivier Sannier (obones) }\r\n{ Petr Vones (pvones) }\r\n{ kogerbnz }\r\n{ }\r\n{**************************************************************************************************}\r\n{ }\r\n{ Contains various utility routines to read and write registry values. Using these routines }\r\n{ prevents you from having to instantiate temporary TRegistry objects and since the routines }\r\n{ directly call the registry API they do not suffer from the resource overhead as TRegistry does. }\r\n{ }\r\n{**************************************************************************************************}\r\n{ }\r\n{ Last modified: $Date:: 2012-09-04 16:08:04 +0200 (mar. 04 sept. 2012) $ }\r\n{ Revision: $Rev:: 3861 $ }\r\n{ Author: $Author:: outchy $ }\r\n{ }\r\n{**************************************************************************************************}\r\n\r\nunit JclRegistry;\r\n\r\n{$I jcl.inc}\r\n{$I windowsonly.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n {$IFDEF HAS_UNITSCOPE}\r\n Winapi.Windows, System.Classes,\r\n {$ELSE ~HAS_UNITSCOPE}\r\n Windows, Classes,\r\n {$ENDIF ~HAS_UNITSCOPE}\r\n JclBase, JclStrings;\r\n\r\ntype\r\n DelphiHKEY = {$IFDEF CPUX64}type Winapi.Windows.HKEY{$ELSE}Longword{$ENDIF CPUX64};\r\n {$HPPEMIT '// BCB users must typecast the HKEY values to DelphiHKEY or use the HK-values below.'}\r\n\r\n TExecKind = (ekMachineRun, ekMachineRunOnce, ekUserRun, ekUserRunOnce,\r\n ekServiceRun, ekServiceRunOnce);\r\n\r\n EJclRegistryError = class(EJclError);\r\n\r\n{$IFDEF FPC}\r\nconst\r\n HKCR = DelphiHKEY($80000000);\r\n HKCU = DelphiHKEY($80000001);\r\n HKLM = DelphiHKEY($80000002);\r\n HKUS = DelphiHKEY($80000003);\r\n HKPD = DelphiHKEY($80000004);\r\n HKCC = DelphiHKEY($80000005);\r\n HKDD = DelphiHKEY($80000006);\r\n{$ELSE ~FPC}\r\nconst\r\n HKCR = DelphiHKEY(HKEY_CLASSES_ROOT);\r\n HKCU = DelphiHKEY(HKEY_CURRENT_USER);\r\n HKLM = DelphiHKEY(HKEY_LOCAL_MACHINE);\r\n HKUS = DelphiHKEY(HKEY_USERS);\r\n HKPD = DelphiHKEY(HKEY_PERFORMANCE_DATA);\r\n HKCC = DelphiHKEY(HKEY_CURRENT_CONFIG);\r\n HKDD = DelphiHKEY(HKEY_DYN_DATA);\r\n{$IFDEF CPU64}\r\n{$NODEFINE DelphiHKEY}\r\n{$NODEFINE HKCR}\r\n{$NODEFINE HKCU}\r\n{$NODEFINE HKLM}\r\n{$NODEFINE HKUS}\r\n{$NODEFINE HKPD}\r\n{$NODEFINE HKCC}\r\n{$NODEFINE HKDD}\r\n{$HPPEMIT 'typedef HKEY DelphiHKEY;'}\r\n{$HPPEMIT 'static const DelphiHKEY HKCR = HKEY_CLASSES_ROOT;'}\r\n{$HPPEMIT 'static const DelphiHKEY HKCU = HKEY_CURRENT_USER;'}\r\n{$HPPEMIT 'static const DelphiHKEY HKLM = HKEY_LOCAL_MACHINE;'}\r\n{$HPPEMIT 'static const DelphiHKEY HKUS = HKEY_USERS;'}\r\n{$HPPEMIT 'static const DelphiHKEY HKPD = HKEY_PERFORMANCE_DATA;'}\r\n{$HPPEMIT 'static const DelphiHKEY HKCC = HKEY_CURRENT_CONFIG;'}\r\n{$HPPEMIT 'static const DelphiHKEY HKDD = HKEY_DYN_DATA;'}\r\n{$ENDIF CPU64}\r\n{$ENDIF FPC}\r\n\r\nfunction RootKeyName(const RootKey: THandle): string;\r\nfunction RootKeyValue(const Name: string): THandle;\r\n\r\nconst\r\n RegKeyDelimiter = '\\';\r\n\r\nfunction RegCreateKey(const RootKey: DelphiHKEY; const Key: string): Longint; overload;\r\nfunction RegCreateKey(const RootKey: DelphiHKEY; const Key, Value: string): Longint; overload;\r\nfunction RegDeleteEntry(const RootKey: DelphiHKEY; const Key, Name: string): Boolean;\r\nfunction RegDeleteKeyTree(const RootKey: DelphiHKEY; const Key: string): Boolean;\r\n\r\nfunction RegGetDataSize(const RootKey: DelphiHKEY; const Key, Name: string;\r\n out DataSize: Cardinal): Boolean;\r\nfunction RegGetDataType(const RootKey: DelphiHKEY; const Key, Name: string;\r\n out DataType: Cardinal): Boolean;\r\nfunction RegReadBool(const RootKey: DelphiHKEY; const Key, Name: string): Boolean;\r\nfunction RegReadBoolDef(const RootKey: DelphiHKEY; const Key, Name: string; Def: Boolean): Boolean;\r\nfunction RegReadIntegerEx(const RootKey: DelphiHKEY; const Key, Name: string;\r\n out RetValue: Integer; RaiseException: Boolean = False): Boolean;\r\nfunction RegReadInteger(const RootKey: DelphiHKEY; const Key, Name: string): Integer;\r\nfunction RegReadIntegerDef(const RootKey: DelphiHKEY; const Key, Name: string; Def: Integer): Integer;\r\nfunction RegReadCardinalEx(const RootKey: DelphiHKEY; const Key, Name: string;\r\n out RetValue: Cardinal; RaiseException: Boolean = False): Boolean;\r\nfunction RegReadCardinal(const RootKey: DelphiHKEY; const Key, Name: string): Cardinal;\r\nfunction RegReadCardinalDef(const RootKey: DelphiHKEY; const Key, Name: string; Def: Cardinal): Cardinal;\r\nfunction RegReadDWORDEx(const RootKey: DelphiHKEY; const Key, Name: string;\r\n out RetValue: DWORD; RaiseException: Boolean = False): Boolean;\r\nfunction RegReadDWORD(const RootKey: DelphiHKEY; const Key, Name: string): DWORD;\r\nfunction RegReadDWORDDef(const RootKey: DelphiHKEY; const Key, Name: string; Def: DWORD): DWORD;\r\nfunction RegReadInt64Ex(const RootKey: DelphiHKEY; const Key, Name: string;\r\n out RetValue: Int64; RaiseException: Boolean = False): Boolean;\r\nfunction RegReadInt64(const RootKey: DelphiHKEY; const Key, Name: string): Int64;\r\nfunction RegReadInt64Def(const RootKey: DelphiHKEY; const Key, Name: string; Def: Int64): Int64;\r\nfunction RegReadUInt64Ex(const RootKey: DelphiHKEY; const Key, Name: string;\r\n out RetValue: UInt64; RaiseException: Boolean = False): Boolean;\r\nfunction RegReadUInt64(const RootKey: DelphiHKEY; const Key, Name: string): UInt64;\r\nfunction RegReadUInt64Def(const RootKey: DelphiHKEY; const Key, Name: string; Def: UInt64): UInt64;\r\nfunction RegReadSingleEx(const RootKey: DelphiHKEY; const Key, Name: string;\r\n out RetValue: Single; RaiseException: Boolean = False): Boolean;\r\nfunction RegReadSingle(const RootKey: DelphiHKEY; const Key, Name: string): Single;\r\nfunction RegReadSingleDef(const RootKey: DelphiHKEY; const Key, Name: string; Def: Single): Single;\r\nfunction RegReadDoubleEx(const RootKey: DelphiHKEY; const Key, Name: string;\r\n out RetValue: Double; RaiseException: Boolean = False): Boolean;\r\nfunction RegReadDouble(const RootKey: DelphiHKEY; const Key, Name: string): Double;\r\nfunction RegReadDoubleDef(const RootKey: DelphiHKEY; const Key, Name: string; Def: Double): Double;\r\nfunction RegReadExtendedEx(const RootKey: DelphiHKEY; const Key, Name: string;\r\n out RetValue: Extended; RaiseException: Boolean = False): Boolean;\r\nfunction RegReadExtended(const RootKey: DelphiHKEY; const Key, Name: string): Extended;\r\nfunction RegReadExtendedDef(const RootKey: DelphiHKEY; const Key, Name: string; Def: Extended): Extended;\r\n\r\nfunction RegReadStringEx(const RootKey: DelphiHKEY; const Key, Name: string;\r\n out RetValue: string; RaiseException: Boolean = False): Boolean;\r\nfunction RegReadString(const RootKey: DelphiHKEY; const Key, Name: string): string;\r\nfunction RegReadStringDef(const RootKey: DelphiHKEY; const Key, Name: string; Def: string): string;\r\nfunction RegReadAnsiStringEx(const RootKey: DelphiHKEY; const Key, Name: string;\r\n out RetValue: AnsiString; RaiseException: Boolean = False): Boolean;\r\nfunction RegReadAnsiString(const RootKey: DelphiHKEY; const Key, Name: string): AnsiString;\r\nfunction RegReadAnsiStringDef(const RootKey: DelphiHKEY; const Key, Name: string; Def: AnsiString): AnsiString;\r\nfunction RegReadWideStringEx(const RootKey: DelphiHKEY; const Key, Name: string;\r\n out RetValue: WideString; RaiseException: Boolean = False): Boolean;\r\nfunction RegReadWideString(const RootKey: DelphiHKEY; const Key, Name: string): WideString;\r\nfunction RegReadWideStringDef(const RootKey: DelphiHKEY; const Key, Name: string; Def: WideString): WideString;\r\n\r\nfunction RegReadMultiSzEx(const RootKey: DelphiHKEY; const Key, Name: string; Value: TStrings;\r\n RaiseException: Boolean = False): Boolean; overload;\r\nfunction RegReadMultiSzEx(const RootKey: DelphiHKEY; const Key, Name: string; out RetValue: PMultiSz;\r\n RaiseException: Boolean = False): Boolean; overload;\r\nprocedure RegReadMultiSz(const RootKey: DelphiHKEY; const Key, Name: string; Value: TStrings); overload;\r\nfunction RegReadMultiSz(const RootKey: DelphiHKEY; const Key, Name: string): PMultiSz; overload;\r\nprocedure RegReadMultiSzDef(const RootKey: DelphiHKEY; const Key, Name: string; Value, Def: TStrings); overload;\r\nfunction RegReadMultiSzDef(const RootKey: DelphiHKEY; const Key, Name: string; Def: PMultiSz): PMultiSz; overload;\r\n\r\nfunction RegReadAnsiMultiSzEx(const RootKey: DelphiHKEY; const Key, Name: string; Value: TAnsiStrings;\r\n RaiseException: Boolean = False): Boolean; overload;\r\nfunction RegReadAnsiMultiSzEx(const RootKey: DelphiHKEY; const Key, Name: string; out RetValue: PAnsiMultiSz;\r\n RaiseException: Boolean = False): Boolean; overload;\r\nprocedure RegReadAnsiMultiSz(const RootKey: DelphiHKEY; const Key, Name: string; Value: TAnsiStrings); overload;\r\nfunction RegReadAnsiMultiSz(const RootKey: DelphiHKEY; const Key, Name: string): PAnsiMultiSz; overload;\r\nprocedure RegReadAnsiMultiSzDef(const RootKey: DelphiHKEY; const Key, Name: string;\r\n Value, Def: TAnsiStrings); overload;\r\nfunction RegReadAnsiMultiSzDef(const RootKey: DelphiHKEY; const Key, Name: string;\r\n Def: PAnsiMultiSz): PAnsiMultiSz; overload;\r\n\r\nfunction RegReadWideMultiSzEx(const RootKey: DelphiHKEY; const Key, Name: string; Value: TWideStrings;\r\n RaiseException: Boolean = False): Boolean; overload;\r\nfunction RegReadWideMultiSzEx(const RootKey: DelphiHKEY; const Key, Name: string; out RetValue: PWideMultiSz;\r\n RaiseException: Boolean = False): Boolean; overload;\r\nprocedure RegReadWideMultiSz(const RootKey: DelphiHKEY; const Key, Name: string; Value: TWideStrings); overload;\r\nfunction RegReadWideMultiSz(const RootKey: DelphiHKEY; const Key, Name: string): PWideMultiSz; overload;\r\nprocedure RegReadWideMultiSzDef(const RootKey: DelphiHKEY; const Key, Name: string;\r\n Value, Def: TWideStrings); overload;\r\nfunction RegReadWideMultiSzDef(const RootKey: DelphiHKEY; const Key, Name: string;\r\n Def: PWideMultiSz): PWideMultiSz; overload;\r\n\r\nfunction RegReadBinaryEx(const RootKey: DelphiHKEY; const Key, Name: string; var Value; const ValueSize: Cardinal;\r\n out DataSize: Cardinal; RaiseException: Boolean = False): Boolean;\r\nfunction RegReadBinary(const RootKey: DelphiHKEY; const Key, Name: string;\r\n var Value; const ValueSize: Cardinal): Cardinal;\r\nfunction RegReadBinaryDef(const RootKey: DelphiHKEY; const Key, Name: string;\r\n var Value; const ValueSize: Cardinal; const Def: Byte): Cardinal;\r\n\r\nprocedure RegWriteBool(const RootKey: DelphiHKEY; const Key, Name: string; Value: Boolean); overload;\r\nprocedure RegWriteBool(const RootKey: DelphiHKEY; const Key, Name: string; DataType: Cardinal;\r\n Value: Boolean); overload;\r\nprocedure RegWriteInteger(const RootKey: DelphiHKEY; const Key, Name: string; Value: Integer); overload;\r\nprocedure RegWriteInteger(const RootKey: DelphiHKEY; const Key, Name: string; DataType: Cardinal;\r\n Value: Integer); overload;\r\nprocedure RegWriteCardinal(const RootKey: DelphiHKEY; const Key, Name: string; Value: Cardinal); overload;\r\nprocedure RegWriteCardinal(const RootKey: DelphiHKEY; const Key, Name: string; DataType: Cardinal;\r\n Value: Cardinal); overload;\r\nprocedure RegWriteDWORD(const RootKey: DelphiHKEY; const Key, Name: string; Value: DWORD); overload;\r\nprocedure RegWriteDWORD(const RootKey: DelphiHKEY; const Key, Name: string; DataType: Cardinal;\r\n Value: DWORD); overload;\r\nprocedure RegWriteInt64(const RootKey: DelphiHKEY; const Key, Name: string; Value: Int64); overload;\r\nprocedure RegWriteInt64(const RootKey: DelphiHKEY; const Key, Name: string; DataType: Cardinal;\r\n Value: Int64); overload;\r\nprocedure RegWriteUInt64(const RootKey: DelphiHKEY; const Key, Name: string; Value: UInt64); overload;\r\nprocedure RegWriteUInt64(const RootKey: DelphiHKEY; const Key, Name: string; DataType: Cardinal;\r\n Value: UInt64); overload;\r\nprocedure RegWriteSingle(const RootKey: DelphiHKEY; const Key, Name: string; Value: Single); overload;\r\nprocedure RegWriteSingle(const RootKey: DelphiHKEY; const Key, Name: string; DataType: Cardinal;\r\n Value: Single); overload;\r\nprocedure RegWriteDouble(const RootKey: DelphiHKEY; const Key, Name: string; Value: Double); overload;\r\nprocedure RegWriteDouble(const RootKey: DelphiHKEY; const Key, Name: string; DataType: Cardinal;\r\n Value: Double); overload;\r\nprocedure RegWriteExtended(const RootKey: DelphiHKEY; const Key, Name: string; Value: Extended); overload;\r\nprocedure RegWriteExtended(const RootKey: DelphiHKEY; const Key, Name: string; DataType: Cardinal;\r\n Value: Extended); overload;\r\n\r\nprocedure RegWriteString(const RootKey: DelphiHKEY; const Key, Name, Value: string); overload;\r\nprocedure RegWriteString(const RootKey: DelphiHKEY; const Key, Name: string; DataType: Cardinal;\r\n const Value: string); overload;\r\nprocedure RegWriteAnsiString(const RootKey: DelphiHKEY; const Key, Name: string; const Value: AnsiString); overload;\r\nprocedure RegWriteAnsiString(const RootKey: DelphiHKEY; const Key, Name: string; DataType: Cardinal;\r\n const Value: AnsiString); overload;\r\nprocedure RegWriteWideString(const RootKey: DelphiHKEY; const Key, Name: string; const Value: WideString); overload;\r\nprocedure RegWriteWideString(const RootKey: DelphiHKEY; const Key, Name: string; DataType: Cardinal;\r\n const Value: WideString); overload;\r\n\r\nprocedure RegWriteMultiSz(const RootKey: DelphiHKEY; const Key, Name: string; Value: PMultiSz); overload;\r\nprocedure RegWriteMultiSz(const RootKey: DelphiHKEY; const Key, Name: string; const Value: TStrings); overload;\r\nprocedure RegWriteMultiSz(const RootKey: DelphiHKEY; const Key, Name: string; DataType: Cardinal;\r\n Value: PMultiSz); overload;\r\nprocedure RegWriteMultiSz(const RootKey: DelphiHKEY; const Key, Name: string; DataType: Cardinal;\r\n const Value: TStrings); overload;\r\n\r\nprocedure RegWriteAnsiMultiSz(const RootKey: DelphiHKEY; const Key, Name: string; Value: PAnsiMultiSz); overload;\r\nprocedure RegWriteAnsiMultiSz(const RootKey: DelphiHKEY; const Key, Name: string;\r\n const Value: TAnsiStrings); overload;\r\nprocedure RegWriteAnsiMultiSz(const RootKey: DelphiHKEY; const Key, Name: string; DataType: Cardinal;\r\n Value: PAnsiMultiSz); overload;\r\nprocedure RegWriteAnsiMultiSz(const RootKey: DelphiHKEY; const Key, Name: string; DataType: Cardinal;\r\n const Value: TAnsiStrings); overload;\r\n\r\nprocedure RegWriteWideMultiSz(const RootKey: DelphiHKEY; const Key, Name: string; Value: PWideMultiSz); overload;\r\nprocedure RegWriteWideMultiSz(const RootKey: DelphiHKEY; const Key, Name: string;\r\n const Value: TWideStrings); overload;\r\nprocedure RegWriteWideMultiSz(const RootKey: DelphiHKEY; const Key, Name: string; DataType: Cardinal;\r\n Value: PWideMultiSz); overload;\r\nprocedure RegWriteWideMultiSz(const RootKey: DelphiHKEY; const Key, Name: string; DataType: Cardinal;\r\n const Value: TWideStrings); overload;\r\n\r\nprocedure RegWriteBinary(const RootKey: DelphiHKEY; const Key, Name: string; const Value; const ValueSize: Cardinal);\r\n\r\nfunction RegGetValueNames(const RootKey: DelphiHKEY; const Key: string; const List: TStrings): Boolean;\r\nfunction RegGetKeyNames(const RootKey: DelphiHKEY; const Key: string; const List: TStrings): Boolean;\r\nfunction RegGetValueNamesAndValues(const RootKey: HKEY; const Key: string; const List: TStrings): Boolean;\r\nfunction RegHasSubKeys(const RootKey: DelphiHKEY; const Key: string): Boolean;\r\n\r\nfunction AllowRegKeyForEveryone(const RootKey: DelphiHKEY; Path: string): Boolean;\r\n\r\nfunction RegAutoExecEnabled(const ExecKind: TExecKind; const Name: string; out CmdLine: string): Boolean;\r\n\r\n{\r\nFrom: Jean-Fabien Connault [cycocrew att worldnet dott fr]\r\nDescr: Test whether a registry key exists as a subkey of RootKey\r\nUsed test cases:\r\nprocedure TForm1.Button1Click(Sender: TObject);\r\nvar\r\n RegKey: HKEY;\r\nbegin\r\n if RegOpenKeyEx(HKEY_CURRENT_USER, 'Software', 0, KEY_READ, RegKey) = ERROR_SUCCESS then\r\n begin\r\n Assert(not RegKeyExists(RegKey, 'Microsoft\\_Windows'));\r\n RegCloseKey(RegKey);\r\n end;\r\n if RegOpenKeyEx(HKEY_CURRENT_USER, 'Software', 0, KEY_READ, RegKey) = ERROR_SUCCESS then\r\n begin\r\n Assert(RegKeyExists(RegKey, 'Microsoft\\Windows'));;\r\n RegCloseKey(RegKey);\r\n end;\r\n Assert(RegKeyExists(HKEY_CURRENT_USER, ''));\r\n Assert(RegKeyExists(HKEY_CURRENT_USER, 'Software'));\r\n Assert(RegKeyExists(HKEY_CURRENT_USER, 'Software\\Microsoft'));\r\n Assert(RegKeyExists(HKEY_CURRENT_USER, 'Software\\Microsoft\\Windows'));\r\n Assert(RegKeyExists(HKEY_CURRENT_USER, '\\Software\\Microsoft\\Windows'));\r\n Assert(not RegKeyExists(HKEY_CURRENT_USER, '\\Software\\Microsoft2\\Windows'));\r\nend;\r\n}\r\nfunction RegKeyExists(const RootKey: DelphiHKEY; const Key: string): Boolean;\r\nfunction RegValueExists(const RootKey: DelphiHKEY; const Key, Name: string): Boolean;\r\n\r\nfunction UnregisterAutoExec(ExecKind: TExecKind; const Name: string): Boolean;\r\nfunction RegisterAutoExec(ExecKind: TExecKind; const Name, Cmdline: string): Boolean;\r\n\r\nfunction RegSaveList(const RootKey: DelphiHKEY; const Key: string; const ListName: string;\r\n const Items: TStrings): Boolean;\r\nfunction RegLoadList(const RootKey: DelphiHKEY; const Key: string; const ListName: string;\r\n const SaveTo: TStrings): Boolean;\r\nfunction RegDelList(const RootKey: DelphiHKEY; const Key: string; const ListName: string): Boolean;\r\n\r\nconst\r\n HKCRLongName = 'HKEY_CLASSES_ROOT';\r\n HKCULongName = 'HKEY_CURRENT_USER';\r\n HKLMLongName = 'HKEY_LOCAL_MACHINE';\r\n HKUSLongName = 'HKEY_USERS';\r\n HKPDLongName = 'HKEY_PERFORMANCE_DATA';\r\n HKCCLongName = 'HKEY_CURRENT_CONFIG';\r\n HKDDLongName = 'HKEY_DYN_DATA';\r\n HKCRShortName = 'HKCR';\r\n HKCUShortName = 'HKCU';\r\n HKLMShortName = 'HKLM';\r\n HKUSShortName = 'HKUS';\r\n HKPDShortName = 'HKPD';\r\n HKCCShortName = 'HKCC';\r\n HKDDShortName = 'HKDD';\r\n\r\ntype\r\n TRootKey = record\r\n Key: DelphiHKEY;\r\n AnsiName: AnsiString;\r\n WideName: WideString;\r\n end;\r\n\r\nconst\r\n RootKeys: array [0..13] of TRootKey =\r\n (\r\n (Key: HKCR; AnsiName: HKCRLongName; WideName: HKCRLongName),\r\n (Key: HKCU; AnsiName: HKCULongName; WideName: HKCULongName),\r\n (Key: HKLM; AnsiName: HKLMLongName; WideName: HKLMLongName),\r\n (Key: HKUS; AnsiName: HKUSLongName; WideName: HKUSLongName),\r\n (Key: HKPD; AnsiName: HKPDLongName; WideName: HKPDLongName),\r\n (Key: HKCC; AnsiName: HKCCLongName; WideName: HKCCLongName),\r\n (Key: HKDD; AnsiName: HKDDLongName; WideName: HKDDLongName),\r\n (Key: HKCR; AnsiName: HKCRShortName; WideName: HKCRShortName),\r\n (Key: HKCU; AnsiName: HKCUShortName; WideName: HKCUShortName),\r\n (Key: HKLM; AnsiName: HKLMShortName; WideName: HKLMShortName),\r\n (Key: HKUS; AnsiName: HKUSShortName; WideName: HKUSShortName),\r\n (Key: HKPD; AnsiName: HKPDShortName; WideName: HKPDShortName),\r\n (Key: HKCC; AnsiName: HKCCShortName; WideName: HKCCShortName),\r\n (Key: HKDD; AnsiName: HKDDShortName; WideName: HKDDShortName)\r\n );\r\n\r\ntype\r\n { clRegWOW64Access allows the user to switch all registry functions to the 64 bit registry\r\n key on a 64bit system.\r\n\r\n OS/Application 32bit/32bit 64bit/32bit 64bit/64bit\r\n raDefault Software Wow6432Node Software\r\n raNative Software Software Software\r\n ra32Key Software Wow6432Node Wow6432Node\r\n ra64Key Software Software Software\r\n }\r\n TJclRegWOW64Access = (raDefault, raNative, ra32Key, ra64Key);\r\n\r\n// cannot access variable JclRegWOW64Access from outside package\r\n// so these helper functions can be used.\r\nfunction RegGetWOW64AccessMode: TJclRegWOW64Access;\r\nprocedure RegSetWOW64AccessMode(Access: TJclRegWOW64Access);\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jcl.svn.sourceforge.net/svnroot/jcl/tags/JCL-2.4-Build4571/jcl/source/windows/JclRegistry.pas $';\r\n Revision: '$Revision: 3861 $';\r\n Date: '$Date: 2012-09-04 16:08:04 +0200 (mar. 04 sept. 2012) $';\r\n LogPath: 'JCL\\source\\windows';\r\n Extra: '';\r\n Data: nil\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n {$IFDEF HAS_UNITSCOPE}\r\n System.SysUtils,\r\n {$ELSE ~HAS_UNITSCOPE}\r\n SysUtils,\r\n {$ENDIF ~HAS_UNITSCOPE}\r\n {$IFDEF FPC}\r\n// JwaAccCtrl,\r\n {$ELSE ~FPC}\r\n AccCtrl,\r\n JclSysUtils,\r\n {$ENDIF ~FPC}\r\n JclResources, JclWin32, JclSysInfo,\r\n JclAnsiStrings, JclWideStrings;\r\n\r\ntype\r\n TRegKind = REG_NONE..REG_QWORD;\r\n TRegKinds = set of TRegKind;\r\n\r\nconst\r\n cItems = 'Items';\r\n cRegBinKinds = [REG_SZ..REG_QWORD]; // all types\r\n\r\nvar\r\n CachedIsWindows64: Integer = -1;\r\n\r\nthreadvar\r\n JclRegWOW64Access: TJclRegWOW64Access {= raDefault};\r\n\r\nfunction RegGetWOW64AccessMode: TJclRegWOW64Access;\r\nbegin\r\n Result := JclRegWOW64Access;\r\nend;\r\n\r\nprocedure RegSetWOW64AccessMode(Access: TJclRegWOW64Access);\r\nbegin\r\n JclRegWOW64Access := Access;\r\nend;\r\n\r\n//=== Internal helper routines ===============================================\r\n\r\nfunction GetWOW64AccessMode(samDesired: REGSAM): REGSAM;\r\nconst\r\n KEY_WOW64_32KEY = $0200;\r\n KEY_WOW64_64KEY = $0100;\r\n KEY_WOW64_RES = $0300;\r\n RegWOW64Accesses: array[Boolean, TJclRegWOW64Access] of HKEY = (\r\n (HKEY(0), HKEY(0), HKEY(0), HKEY(0)),\r\n (HKEY(0), KEY_WOW64_64KEY, KEY_WOW64_32KEY, KEY_WOW64_64KEY)\r\n );\r\nbegin\r\n Result := samDesired;\r\n if (Win32Platform = VER_PLATFORM_WIN32_NT) and (samDesired and KEY_WOW64_RES = 0) then\r\n begin\r\n if CachedIsWindows64 = -1 then\r\n if IsWindows64 then\r\n CachedIsWindows64 := 1\r\n else\r\n CachedIsWindows64 := 0;\r\n\r\n Result := Result or RegWOW64Accesses[CachedIsWindows64 = 1, JclRegWOW64Access];\r\n end;\r\nend;\r\n\r\nfunction RootKeyName(const RootKey: THandle): string;\r\nbegin\r\n case RootKey of\r\n {$IFDEF DELPHI64_TEMPORARY}\r\n Integer(HKCR) : Result := HKCRLongName;\r\n Integer(HKCU) : Result := HKCULongName;\r\n Integer(HKLM) : Result := HKLMLongName;\r\n Integer(HKUS) : Result := HKUSLongName;\r\n Integer(HKPD) : Result := HKPDLongName;\r\n Integer(HKCC) : Result := HKCCLongName;\r\n Integer(HKDD) : Result := HKDDLongName;\r\n {$ELSE ~DELPHI64_TEMPORARY}\r\n HKCR : Result := HKCRLongName;\r\n HKCU : Result := HKCULongName;\r\n HKLM : Result := HKLMLongName;\r\n HKUS : Result := HKUSLongName;\r\n HKPD : Result := HKPDLongName;\r\n HKCC : Result := HKCCLongName;\r\n HKDD : Result := HKDDLongName;\r\n {$ENDIF ~DELPHI64_TEMPORARY}\r\n else\r\n Result := Format(HexFmt, [RootKey]);\r\n end;\r\nend;\r\n\r\nfunction RootKeyValue(const Name: string): THandle;\r\nvar\r\n Index: Integer;\r\nbegin\r\n for Index := Low(RootKeys) to High(RootKeys) do\r\n if string(RootKeys[Index].AnsiName) = Name then\r\n begin\r\n Result := RootKeys[Index].Key;\r\n Exit;\r\n end;\r\n raise EJclRegistryError.CreateResFmt(@RsInconsistentPath, [Name]);\r\nend;\r\n\r\nprocedure ReadError(const RootKey: THandle; const Key: string);\r\nbegin\r\n raise EJclRegistryError.CreateResFmt(@RsUnableToOpenKeyRead, [RootKeyName(RootKey), Key]);\r\nend;\r\n\r\nprocedure WriteError(const RootKey: THandle; const Key: string);\r\nbegin\r\n raise EJclRegistryError.CreateResFmt(@RsUnableToOpenKeyWrite, [RootKeyName(RootKey), Key]);\r\nend;\r\n\r\nprocedure ValueError(const RootKey: THandle; const Key, Name: string);\r\nbegin\r\n raise EJclRegistryError.CreateResFmt(@RsUnableToAccessValue, [RootKeyName(RootKey), Key, Name]);\r\nend;\r\n\r\nprocedure DataError(const RootKey: THandle; const Key, Name: string);\r\nbegin\r\n raise EJclRegistryError.CreateResFmt(@RsWrongDataType, [RootKeyName(RootKey), Key, Name]);\r\nend;\r\n\r\nfunction GetKeyAndPath(ExecKind: TExecKind; out Key: HKEY; out RegPath: string): Boolean;\r\nbegin\r\n Result := False;\r\n if (ExecKind in [ekServiceRun, ekServiceRunOnce]) and (Win32Platform = VER_PLATFORM_WIN32_NT) then\r\n Exit;\r\n if ExecKind in [ekMachineRun, ekMachineRunOnce, ekServiceRun, ekServiceRunOnce] then\r\n Key := HKEY_LOCAL_MACHINE\r\n else\r\n Key := HKEY_CURRENT_USER;\r\n RegPath := 'Software\\Microsoft\\Windows\\CurrentVersion\\';\r\n case ExecKind of\r\n ekMachineRun, ekUserRun:\r\n RegPath := RegPath + 'Run';\r\n ekMachineRunOnce, ekUserRunOnce:\r\n RegPath := RegPath + 'RunOnce';\r\n ekServiceRun:\r\n RegPath := RegPath + 'RunServices';\r\n ekServiceRunOnce:\r\n RegPath := RegPath + 'RunServicesOnce';\r\n end;\r\n Result := True;\r\nend;\r\n\r\nfunction RelativeKey(const RootKey: DelphiHKEY; Key: PAnsiChar): PAnsiChar; overload;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := Key;\r\n if Result^ = RegKeyDelimiter then\r\n Inc(Result);\r\n for I := Low(RootKeys) to High(RootKeys) do\r\n if StrPos(Key, PAnsiChar(RootKeys[I].AnsiName + RegKeyDelimiter)) = Result then\r\n begin\r\n if RootKey <> RootKeys[I].Key then\r\n raise EJclRegistryError.CreateResFmt(@RsInconsistentPath, [Key])\r\n else\r\n Inc(Result, Length(RootKeys[I].AnsiName));\r\n Break;\r\n end;\r\nend;\r\n\r\nfunction RelativeKey(const RootKey: DelphiHKEY; Key: PWideChar): PWideChar; overload;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := Key;\r\n if Result^ = RegKeyDelimiter then\r\n Inc(Result);\r\n for I := Low(RootKeys) to High(RootKeys) do\r\n if StrPosW(Key, PWideChar(RootKeys[I].WideName + RegKeyDelimiter)) = Result then\r\n begin\r\n if RootKey <> RootKeys[I].Key then\r\n raise EJclRegistryError.CreateResFmt(@RsInconsistentPath, [Key])\r\n else\r\n Inc(Result, Length(RootKeys[I].WideName));\r\n Break;\r\n end;\r\nend;\r\n\r\nfunction InternalRegOpenKeyEx(Key: HKEY; SubKey: PWideChar;\r\n ulOptions: DWORD; samDesired: REGSAM; var RegKey: HKEY): Longint; overload;\r\nvar\r\n RelKey: AnsiString;\r\nbegin\r\n if Win32Platform = VER_PLATFORM_WIN32_NT then\r\n Result := RegOpenKeyExW(Key, RelativeKey(Key, SubKey), ulOptions, GetWOW64AccessMode(samDesired), RegKey)\r\n else\r\n begin\r\n RelKey := AnsiString(WideString(RelativeKey(Key, SubKey)));\r\n Result := RegOpenKeyExA(Key, PAnsiChar(RelKey), ulOptions, samDesired, RegKey);\r\n end;\r\nend;\r\n\r\nfunction InternalRegOpenKeyEx(Key: HKEY; SubKey: PAnsiChar;\r\n ulOptions: DWORD; samDesired: REGSAM; var RegKey: HKEY): Longint; overload;\r\nbegin\r\n if Win32Platform = VER_PLATFORM_WIN32_NT then\r\n Result := RegOpenKeyExA(Key, RelativeKey(Key, SubKey), ulOptions, GetWOW64AccessMode(samDesired), RegKey)\r\n else\r\n Result := RegOpenKeyExA(Key, RelativeKey(Key, SubKey), ulOptions, samDesired, RegKey);\r\nend;\r\n\r\nfunction InternalRegQueryValueEx(Key: HKEY; ValueName: PWideChar;\r\n lpReserved: Pointer; lpType: PDWORD; lpData: Pointer; lpcbData: PDWORD): Longint;\r\nvar\r\n ValName: AnsiString;\r\nbegin\r\n if Win32Platform = VER_PLATFORM_WIN32_NT then\r\n Result := RegQueryValueExW(Key, ValueName, lpReserved, lpType, lpData, lpcbData)\r\n else\r\n begin\r\n ValName := AnsiString(WideString(ValueName));\r\n Result := RegQueryValueExA(Key, PAnsiChar(ValName), lpReserved, lpType, lpData, lpcbData);\r\n end;\r\nend;\r\n\r\nfunction InternalRegSetValueEx(Key: HKEY; ValueName: PWideChar;\r\n Reserved: DWORD; dwType: DWORD; lpData: Pointer; cbData: DWORD): Longint; stdcall;\r\nvar\r\n ValName: AnsiString;\r\nbegin\r\n if Win32Platform = VER_PLATFORM_WIN32_NT then\r\n Result := RegSetValueExW(Key, ValueName, Reserved, dwType, lpData, cbData)\r\n else\r\n begin\r\n ValName := AnsiString(WideString(ValueName));\r\n Result := RegSetValueExA(Key, PAnsiChar(ValName), Reserved, dwType, lpData, cbData);\r\n end;\r\nend;\r\n\r\nfunction InternalGetData(const RootKey: DelphiHKEY; const Key, Name: WideString;\r\n RegKinds: TRegKinds; ExpectedSize: DWORD;\r\n out DataType: DWORD; Data: Pointer; out DataSize: DWORD; RaiseException: Boolean): Boolean;\r\nvar\r\n RegKey: HKEY;\r\nbegin\r\n Result := True;\r\n DataType := REG_NONE;\r\n DataSize := 0;\r\n RegKey := 0;\r\n if InternalRegOpenKeyEx(RootKey, PWideChar(Key), 0, KEY_READ, RegKey) = ERROR_SUCCESS then\r\n try\r\n if InternalRegQueryValueEx(RegKey, PWideChar(Name), nil, @DataType, nil, @DataSize) = ERROR_SUCCESS then\r\n begin\r\n if not (DataType in RegKinds) or (DataSize > ExpectedSize) then\r\n if RaiseException then\r\n DataError(RootKey, Key, Name)\r\n else\r\n Result := False;\r\n if InternalRegQueryValueEx(RegKey, PWideChar(Name), nil, nil, Data, @DataSize) <> ERROR_SUCCESS then\r\n if RaiseException then\r\n ValueError(RootKey, Key, Name)\r\n else\r\n Result := False;\r\n end\r\n else\r\n if RaiseException then\r\n ValueError(RootKey, Key, Name)\r\n else\r\n Result := False;\r\n finally\r\n RegCloseKey(RegKey);\r\n end\r\n else\r\n if RaiseException then\r\n ReadError(RootKey, Key)\r\n else\r\n Result := False;\r\nend;\r\n\r\nfunction InternalGetAnsiString(const RootKey: DelphiHKEY; const Key, Name: WideString; MultiFlag: Boolean;\r\n out RetValue: AnsiString; RaiseException: Boolean): Boolean;\r\nvar\r\n RegKey: HKEY;\r\n DataType, DataSize: DWORD;\r\n TmpRet: WideString;\r\n DataLength: Integer;\r\n RegKinds: TRegKinds;\r\nbegin\r\n Result := True;\r\n DataType := REG_NONE;\r\n DataSize := 0;\r\n RetValue := '';\r\n RegKey := 0;\r\n if InternalRegOpenKeyEx(RootKey, PWideChar(Key), 0, KEY_READ, RegKey) = ERROR_SUCCESS then\r\n try\r\n if InternalRegQueryValueEx(RegKey, PWideChar(Name), nil, @DataType, nil, @DataSize) = ERROR_SUCCESS then\r\n begin\r\n if MultiFlag then\r\n RegKinds := [REG_BINARY, REG_SZ, REG_EXPAND_SZ, REG_MULTI_SZ]\r\n else\r\n RegKinds := [REG_BINARY, REG_SZ, REG_EXPAND_SZ];\r\n if DataType in RegKinds then\r\n begin\r\n if Win32Platform = VER_PLATFORM_WIN32_NT then\r\n begin\r\n DataLength := DataSize div SizeOf(WideChar);\r\n SetLength(TmpRet, DataLength);\r\n Result := InternalRegQueryValueEx(RegKey, PWideChar(Name), nil, nil, PWideChar(TmpRet), @DataSize) = ERROR_SUCCESS;\r\n if Result then\r\n RetValue := AnsiString(Copy(TmpRet, 1, DataLength - 1));\r\n end\r\n else\r\n begin\r\n DataLength := DataSize div SizeOf(AnsiChar);\r\n SetLength(RetValue, DataLength);\r\n Result := InternalRegQueryValueEx(RegKey, PWideChar(Name), nil, nil, PAnsiChar(RetValue), @DataSize) = ERROR_SUCCESS;\r\n if Result then\r\n SetLength(RetValue, DataLength - 1);\r\n end;\r\n if not Result then\r\n begin\r\n RetValue := '';\r\n if RaiseException then\r\n ValueError(RootKey, Key, Name)\r\n else\r\n Result := False;\r\n end;\r\n end\r\n else\r\n begin\r\n RetValue := '';\r\n if RaiseException then\r\n DataError(RootKey, Key, Name)\r\n else\r\n Result := False;\r\n end;\r\n end\r\n else\r\n if RaiseException then\r\n ValueError(RootKey, Key, Name)\r\n else\r\n Result := False;\r\n finally\r\n RegCloseKey(RegKey);\r\n end\r\n else\r\n if RaiseException then\r\n ReadError(RootKey, Key)\r\n else\r\n Result := False;\r\nend;\r\n\r\nfunction InternalGetWideString(const RootKey: DelphiHKEY; const Key, Name: WideString; MultiFlag: Boolean;\r\n out RetValue: WideString; RaiseException: Boolean): Boolean;\r\nvar\r\n RegKey: HKEY;\r\n DataType, DataSize: DWORD;\r\n RegKinds: TRegKinds;\r\n DataLength: Integer;\r\nbegin\r\n Result := True;\r\n DataType := REG_NONE;\r\n DataSize := 0;\r\n RetValue := '';\r\n RegKey := 0;\r\n if InternalRegOpenKeyEx(RootKey, PWideChar(Key), 0, KEY_READ, RegKey) = ERROR_SUCCESS then\r\n try\r\n if InternalRegQueryValueEx(RegKey, PWideChar(Name), nil, @DataType, nil, @DataSize) = ERROR_SUCCESS then\r\n begin\r\n if Win32Platform = VER_PLATFORM_WIN32_WINDOWS then\r\n RegKinds := [REG_BINARY]\r\n else\r\n if MultiFlag then\r\n RegKinds := [REG_BINARY, REG_SZ, REG_EXPAND_SZ, REG_MULTI_SZ]\r\n else\r\n RegKinds := [REG_BINARY, REG_SZ, REG_EXPAND_SZ];\r\n if DataType in RegKinds then\r\n begin\r\n DataLength := DataSize div SizeOf(WideChar);\r\n SetLength(RetValue, DataLength);\r\n if InternalRegQueryValueEx(RegKey, PWideChar(Name), nil, nil, PWideChar(RetValue), @DataSize) = ERROR_SUCCESS then\r\n SetLength(RetValue, DataLength - 1)\r\n else\r\n begin\r\n RetValue := '';\r\n if RaiseException then\r\n ValueError(RootKey, Key, Name)\r\n else\r\n Result := False;\r\n end;\r\n end\r\n else\r\n begin\r\n RetValue := '';\r\n if RaiseException then\r\n DataError(RootKey, Key, Name)\r\n else\r\n Result := False;\r\n end;\r\n end\r\n else\r\n if RaiseException then\r\n ValueError(RootKey, Key, Name)\r\n else\r\n Result := False;\r\n finally\r\n RegCloseKey(RegKey);\r\n end\r\n else\r\n if RaiseException then\r\n ReadError(RootKey, Key)\r\n else\r\n Result := False;\r\nend;\r\n\r\nfunction InternalStrToFloat(const RootKey: DelphiHKEY; const Key, Name: string; out Success: Boolean;\r\n RaiseException: Boolean): Extended;\r\nvar\r\n {$IFDEF RTL150_UP}\r\n FS: TFormatSettings;\r\n {$ELSE ~RTL150_UP}\r\n OldSep: Char;\r\n {$ENDIF ~RTL150_UP}\r\nbegin\r\n {$IFDEF RTL150_UP}\r\n FS.ThousandSeparator := ',';\r\n FS.DecimalSeparator := '.';\r\n {$ELSE ~RTL150_UP}\r\n OldSep := DecimalSeparator;\r\n try\r\n DecimalSeparator := '.';\r\n {$ENDIF ~RTL150_UP}\r\n if RaiseException then\r\n begin\r\n Result := StrToFloat(RegReadString(RootKey, Key, Name){$IFDEF RTL150_UP}, FS{$ENDIF});\r\n Success := True;\r\n end\r\n else\r\n Success := TryStrToFloat(RegReadString(RootKey, Key, Name), Result{$IFDEF RTL150_UP}, FS{$ENDIF});\r\n {$IFNDEF RTL150_UP}\r\n finally\r\n DecimalSeparator := OldSep;\r\n end;\r\n {$ENDIF ~RTL150_UP}\r\nend;\r\n\r\nprocedure InternalSetData(const RootKey: DelphiHKEY; const Key, Name: WideString;\r\n RegKind: TRegKind; Value: Pointer; ValueSize: Cardinal);\r\nvar\r\n RegKey: HKEY;\r\nbegin\r\n if not RegKeyExists(RootKey, Key) then\r\n RegCreateKey(RootKey, Key);\r\n RegKey := 0;\r\n if InternalRegOpenKeyEx(RootKey, RelativeKey(RootKey, PWideChar(Key)), 0, KEY_WRITE, RegKey) = ERROR_SUCCESS then\r\n try\r\n if InternalRegSetValueEx(RegKey, PWideChar(Name), 0, RegKind, Value, ValueSize) <> ERROR_SUCCESS then\r\n WriteError(RootKey, Key);\r\n finally\r\n RegCloseKey(RegKey);\r\n end\r\n else\r\n WriteError(RootKey, Key);\r\nend;\r\n\r\nprocedure InternalSetAnsiData(const RootKey: DelphiHKEY; const Key, Name: WideString;\r\n RegKind: TRegKind; Value: Pointer; ValueSize: Cardinal);\r\nvar\r\n Source: AnsiString;\r\n Dest: WideString;\r\nbegin\r\n if Win32Platform = VER_PLATFORM_WIN32_NT then\r\n begin\r\n // destination must be wide data\r\n SetLength(Source, ValueSize div SizeOf(AnsiChar));\r\n Move(Value^,Source[1],ValueSize * SizeOf(AnsiChar));\r\n Dest := WideString(Source);\r\n InternalSetData(RootKey, Key, Name, RegKind, PWideChar(Dest), SizeOf(WideChar) * ValueSize);\r\n end\r\n else\r\n InternalSetData(RootKey, Key, Name, RegKind, Value, ValueSize);\r\nend;\r\n\r\nprocedure InternalSetWideData(const RootKey: DelphiHKEY; const Key, Name: string;\r\n RegKind: TRegKind; Value: Pointer; ValueSize: Cardinal);\r\nbegin\r\n if (Win32Platform = VER_PLATFORM_WIN32_WINDOWS) and (RegKind in [REG_SZ, REG_MULTI_SZ, REG_EXPAND_SZ]) then\r\n RegKind := REG_BINARY;\r\n InternalSetData(RootKey, Key, Name, RegKind, Value, ValueSize);\r\nend;\r\n\r\n//=== Registry ===============================================================\r\n\r\nfunction RegCreateKey(const RootKey: DelphiHKEY; const Key: string): Longint;\r\nvar\r\n RegKey: HKEY;\r\nbegin\r\n RegKey := 0;\r\n Result := {$IFDEF HAS_UNITSCOPE}Winapi.{$ENDIF}Windows.RegCreateKeyEx(RootKey, RelativeKey(RootKey, PChar(Key)), 0, nil, 0,\r\n GetWOW64AccessMode(KEY_ALL_ACCESS), nil, RegKey, nil);\r\n if Result = ERROR_SUCCESS then\r\n RegCloseKey(RegKey);\r\nend;\r\n\r\nfunction RegCreateKey(const RootKey: DelphiHKEY; const Key, Value: string): Longint;\r\nbegin\r\n Result := RegSetValue(RootKey, RelativeKey(RootKey, PChar(Key)), REG_SZ, PChar(Value), Length(Value));\r\nend;\r\n\r\nfunction RegDeleteEntry(const RootKey: DelphiHKEY; const Key, Name: string): Boolean;\r\nvar\r\n RegKey: HKEY;\r\nbegin\r\n Result := False;\r\n RegKey := 0;\r\n if InternalRegOpenKeyEx(RootKey, RelativeKey(RootKey, PChar(Key)), 0, KEY_SET_VALUE, RegKey) = ERROR_SUCCESS then\r\n begin\r\n Result := RegDeleteValue(RegKey, PChar(Name)) = ERROR_SUCCESS;\r\n RegCloseKey(RegKey);\r\n if not Result then\r\n ValueError(RootKey, Key, Name);\r\n end\r\n else\r\n WriteError(RootKey, Key);\r\nend;\r\n\r\nfunction RegDeleteKeyTree(const RootKey: DelphiHKEY; const Key: string): Boolean;\r\nvar\r\n RegKey: HKEY;\r\n I: DWORD;\r\n Size: DWORD;\r\n NumSubKeys: DWORD;\r\n MaxSubKeyLen: DWORD;\r\n KeyName: string;\r\nbegin\r\n RegKey := 0;\r\n Result := InternalRegOpenKeyEx(RootKey, RelativeKey(RootKey, PChar(Key)), 0, KEY_ALL_ACCESS, RegKey) = ERROR_SUCCESS;\r\n if Result then\r\n begin\r\n RegQueryInfoKey(RegKey, nil, nil, nil, @NumSubKeys, @MaxSubKeyLen, nil, nil, nil, nil, nil, nil);\r\n if NumSubKeys <> 0 then\r\n for I := NumSubKeys - 1 downto 0 do\r\n begin\r\n Size := MaxSubKeyLen+1;\r\n SetLength(KeyName, Size);\r\n RegEnumKeyEx(RegKey, I, PChar(KeyName), Size, nil, nil, nil, nil);\r\n SetLength(KeyName, StrLen(PChar(KeyName)));\r\n Result := RegDeleteKeyTree(RootKey, Key + RegKeyDelimiter + KeyName);\r\n if not Result then\r\n Break;\r\n end;\r\n RegCloseKey(RegKey);\r\n if Result then\r\n Result := {$IFDEF HAS_UNITSCOPE}Winapi.{$ENDIF}Windows.RegDeleteKey(RootKey, RelativeKey(RootKey, PChar(Key))) = ERROR_SUCCESS;\r\n end\r\n else\r\n WriteError(RootKey, Key);\r\nend;\r\n\r\nfunction RegGetDataSize(const RootKey: DelphiHKEY; const Key, Name: string;\r\n out DataSize: Cardinal): Boolean;\r\nvar\r\n RegKey: HKEY;\r\nbegin\r\n DataSize := 0;\r\n RegKey := 0;\r\n Result := InternalRegOpenKeyEx(RootKey, RelativeKey(RootKey, PChar(Key)), 0, KEY_READ, RegKey) = ERROR_SUCCESS;\r\n if Result then\r\n begin\r\n Result := RegQueryValueEx(RegKey, PChar(Name), nil, nil, nil, @DataSize) = ERROR_SUCCESS;\r\n RegCloseKey(RegKey);\r\n end;\r\nend;\r\n\r\nfunction RegGetDataType(const RootKey: DelphiHKEY; const Key, Name: string;\r\n out DataType: DWORD): Boolean;\r\nvar\r\n RegKey: HKEY;\r\nbegin\r\n DataType := REG_NONE;\r\n RegKey := 0;\r\n Result := InternalRegOpenKeyEx(RootKey, RelativeKey(RootKey, PChar(Key)), 0, KEY_READ, RegKey) = ERROR_SUCCESS;\r\n if Result then\r\n begin\r\n Result := RegQueryValueEx(RegKey, PChar(Name), nil, @DataType, nil, nil) = ERROR_SUCCESS;\r\n RegCloseKey(RegKey);\r\n end;\r\nend;\r\n\r\nfunction RegReadBool(const RootKey: DelphiHKEY; const Key, Name: string): Boolean;\r\nbegin\r\n Result := RegReadInteger(RootKey, Key, Name) <> 0;\r\nend;\r\n\r\nfunction RegReadBoolDef(const RootKey: DelphiHKEY; const Key, Name: string; Def: Boolean): Boolean;\r\nbegin\r\n Result := RegReadIntegerDef(RootKey, Key, Name, Ord(Def)) <> 0;\r\nend;\r\n\r\nfunction RegReadIntegerEx(const RootKey: DelphiHKEY; const Key, Name: string;\r\n out RetValue: Integer; RaiseException: Boolean): Boolean;\r\nvar\r\n DataType, DataSize: DWORD;\r\n Ret: Int64;\r\nbegin\r\n Ret := 0;\r\n RegGetDataType(RootKey, Key, Name, DataType);\r\n if DataType in [REG_SZ, REG_EXPAND_SZ] then\r\n if RaiseException then\r\n begin\r\n Ret := StrToInt64(RegReadString(RootKey, Key, Name));\r\n Result := True;\r\n end\r\n else\r\n Result := TryStrToInt64(RegReadString(RootKey, Key, Name), Ret)\r\n else\r\n Result := InternalGetData(RootKey, Key, Name, [REG_BINARY, REG_DWORD, REG_QWORD],\r\n SizeOf(Ret), DataType, @Ret, DataSize, RaiseException);\r\n RetValue := Integer(Ret and $FFFFFFFF);\r\nend;\r\n\r\nfunction RegReadInteger(const RootKey: DelphiHKEY; const Key, Name: string): Integer;\r\nbegin\r\n RegReadIntegerEx(RootKey, Key, Name, Result, True);\r\nend;\r\n\r\nfunction RegReadIntegerDef(const RootKey: DelphiHKEY; const Key, Name: string; Def: Integer): Integer;\r\nbegin\r\n try\r\n if not RegReadIntegerEx(RootKey, Key, Name, Result, False) then\r\n Result := Def;\r\n except\r\n Result := Def;\r\n end;\r\nend;\r\n\r\nfunction RegReadCardinalEx(const RootKey: DelphiHKEY; const Key, Name: string;\r\n out RetValue: Cardinal; RaiseException: Boolean): Boolean;\r\nvar\r\n DataType, DataSize: DWORD;\r\n Ret: Int64;\r\nbegin\r\n Ret := 0;\r\n RegGetDataType(RootKey, Key, Name, DataType);\r\n if DataType in [REG_SZ, REG_EXPAND_SZ] then\r\n if RaiseException then\r\n begin\r\n Ret := StrToInt64(RegReadString(RootKey, Key, Name));\r\n Result := True;\r\n end\r\n else\r\n Result := TryStrToInt64(RegReadString(RootKey, Key, Name), Ret)\r\n else\r\n Result := InternalGetData(RootKey, Key, Name, [REG_BINARY, REG_DWORD, REG_QWORD],\r\n SizeOf(Ret), DataType, @Ret, DataSize, RaiseException);\r\n RetValue := Cardinal(Ret) and $FFFFFFFF;\r\nend;\r\n\r\nfunction RegReadCardinal(const RootKey: DelphiHKEY; const Key, Name: string): Cardinal;\r\nbegin\r\n RegReadCardinalEx(RootKey, Key, Name, Result, True);\r\nend;\r\n\r\nfunction RegReadCardinalDef(const RootKey: DelphiHKEY; const Key, Name: string; Def: Cardinal): Cardinal;\r\nbegin\r\n try\r\n if not RegReadCardinalEx(RootKey, Key, Name, Result, False) then\r\n Result := Def;\r\n except\r\n Result := Def;\r\n end;\r\nend;\r\n\r\nfunction RegReadDWORDEx(const RootKey: DelphiHKEY; const Key, Name: string;\r\n out RetValue: DWORD; RaiseException: Boolean): Boolean;\r\nbegin\r\n Result := RegReadCardinalEx(RootKey, Key, Name, RetValue, RaiseException);\r\nend;\r\n\r\nfunction RegReadDWORD(const RootKey: DelphiHKEY; const Key, Name: string): DWORD;\r\nbegin\r\n Result := RegReadCardinal(RootKey, Key, Name);\r\nend;\r\n\r\nfunction RegReadDWORDDef(const RootKey: DelphiHKEY; const Key, Name: string; Def: DWORD): DWORD;\r\nbegin\r\n Result := RegReadCardinalDef(RootKey, Key, Name, Def);\r\nend;\r\n\r\nfunction RegReadInt64Ex(const RootKey: DelphiHKEY; const Key, Name: string;\r\n out RetValue: Int64; RaiseException: Boolean): Boolean;\r\nvar\r\n DataType, DataSize: DWORD;\r\n Data: array [0..1] of Integer;\r\n Ret: Int64;\r\nbegin\r\n RegGetDataType(RootKey, Key, Name, DataType);\r\n if DataType in [REG_SZ, REG_EXPAND_SZ] then\r\n begin\r\n // (rom) circumvents internal compiler error for D6\r\n if RaiseException then\r\n begin\r\n Ret := StrToInt64(RegReadString(RootKey, Key, Name));\r\n Result := True;\r\n end\r\n else\r\n Result := TryStrToInt64(RegReadString(RootKey, Key, Name), Ret);\r\n RetValue := Ret;\r\n end\r\n else\r\n begin\r\n Data[0] := 0;\r\n Data[1] := 0;\r\n Result := InternalGetData(RootKey, Key, Name, [REG_BINARY, REG_DWORD, REG_QWORD],\r\n SizeOf(Data), DataType, @Data, DataSize, RaiseException);\r\n // REG_BINARY is implicitly unsigned if DataSize < 8\r\n if DataType = REG_DWORD then\r\n // DWORDs get sign extended\r\n RetValue := Data[0]\r\n else\r\n Move(Data[0], RetValue, SizeOf(Data));\r\n end;\r\nend;\r\n\r\nfunction RegReadInt64(const RootKey: DelphiHKEY; const Key, Name: string): Int64;\r\nbegin\r\n RegReadInt64Ex(RootKey, Key, Name, Result, True);\r\nend;\r\n\r\nfunction RegReadInt64Def(const RootKey: DelphiHKEY; const Key, Name: string; Def: Int64): Int64;\r\nbegin\r\n try\r\n if not RegReadInt64Ex(RootKey, Key, Name, Result, False) then\r\n Result := Def;\r\n except\r\n Result := Def;\r\n end;\r\nend;\r\n\r\nfunction RegReadUInt64Ex(const RootKey: DelphiHKEY; const Key, Name: string;\r\n out RetValue: UInt64; RaiseException: Boolean): Boolean;\r\nvar\r\n DataType, DataSize: DWORD;\r\n Ret: Int64;\r\nbegin\r\n RegGetDataType(RootKey, Key, Name, DataType);\r\n if DataType in [REG_SZ, REG_EXPAND_SZ] then\r\n begin\r\n // (rom) circumvents internal compiler error for D6\r\n if RaiseException then\r\n begin\r\n Ret := StrToInt64(RegReadString(RootKey, Key, Name));\r\n Result := True;\r\n end\r\n else\r\n Result := TryStrToInt64(RegReadString(RootKey, Key, Name), Ret);\r\n RetValue := UInt64(Ret);\r\n end\r\n else\r\n begin\r\n // type cast required to circumvent internal error in D7\r\n RetValue := UInt64(0);\r\n Result := InternalGetData(RootKey, Key, Name, [REG_BINARY, REG_DWORD, REG_QWORD],\r\n SizeOf(RetValue), DataType, @RetValue, DataSize, RaiseException);\r\n end;\r\nend;\r\n\r\nfunction RegReadUInt64(const RootKey: DelphiHKEY; const Key, Name: string): UInt64;\r\nbegin\r\n RegReadUInt64Ex(RootKey, Key, Name, Result, True);\r\nend;\r\n\r\nfunction RegReadUInt64Def(const RootKey: DelphiHKEY; const Key, Name: string; Def: UInt64): UInt64;\r\nbegin\r\n try\r\n if not RegReadUInt64Ex(RootKey, Key, Name, Result, False) then\r\n Result := Def;\r\n except\r\n Result := Def;\r\n end;\r\nend;\r\n\r\nfunction RegReadSingleEx(const RootKey: DelphiHKEY; const Key, Name: string;\r\n out RetValue: Single; RaiseException: Boolean): Boolean;\r\nvar\r\n DataType, DataSize: DWORD;\r\nbegin\r\n RegGetDataType(RootKey, Key, Name, DataType);\r\n if DataType in [REG_SZ, REG_EXPAND_SZ] then\r\n RetValue := InternalStrToFloat(RootKey, Key, Name, Result, RaiseException)\r\n else\r\n Result := InternalGetData(RootKey, Key, Name, [REG_BINARY],\r\n SizeOf(RetValue), DataType, @RetValue, DataSize, RaiseException);\r\nend;\r\n\r\nfunction RegReadSingle(const RootKey: DelphiHKEY; const Key, Name: string): Single;\r\nbegin\r\n RegReadSingleEx(RootKey, KEy, Name, Result, True);\r\nend;\r\n\r\nfunction RegReadSingleDef(const RootKey: DelphiHKEY; const Key, Name: string; Def: Single): Single;\r\nbegin\r\n try\r\n if not RegReadSingleEx(RootKey, KEy, Name, Result, False) then\r\n Result := Def;\r\n except\r\n Result := Def;\r\n end;\r\nend;\r\n\r\nfunction RegReadDoubleEx(const RootKey: DelphiHKEY; const Key, Name: string;\r\n out RetValue: Double; RaiseException: Boolean): Boolean;\r\nvar\r\n DataType, DataSize: DWORD;\r\nbegin\r\n RegGetDataType(RootKey, Key, Name, DataType);\r\n if DataType in [REG_SZ, REG_EXPAND_SZ] then\r\n RetValue := InternalStrToFloat(RootKey, Key, Name, Result, RaiseException)\r\n else\r\n Result := InternalGetData(RootKey, Key, Name, [REG_BINARY],\r\n SizeOf(RetValue), DataType, @RetValue, DataSize, RaiseException);\r\nend;\r\n\r\nfunction RegReadDouble(const RootKey: DelphiHKEY; const Key, Name: string): Double;\r\nbegin\r\n RegReadDoubleEx(RootKey, Key, Name, Result, True);\r\nend;\r\n\r\nfunction RegReadDoubleDef(const RootKey: DelphiHKEY; const Key, Name: string; Def: Double): Double;\r\nbegin\r\n try\r\n if not RegReadDoubleEx(RootKey, Key, Name, Result, False) then\r\n Result := Def;\r\n except\r\n Result := Def;\r\n end;\r\nend;\r\n\r\nfunction RegReadExtendedEx(const RootKey: DelphiHKEY; const Key, Name: string;\r\n out RetValue: Extended; RaiseException: Boolean): Boolean;\r\nvar\r\n DataType, DataSize: DWORD;\r\nbegin\r\n RegGetDataType(RootKey, Key, Name, DataType);\r\n if DataType in [REG_SZ, REG_EXPAND_SZ] then\r\n RetValue := InternalStrToFloat(RootKey, Key, Name, Result, RaiseException)\r\n else\r\n Result := InternalGetData(RootKey, Key, Name, [REG_BINARY],\r\n SizeOf(RetValue), DataType, @RetValue, DataSize, RaiseException);\r\nend;\r\n\r\nfunction RegReadExtended(const RootKey: DelphiHKEY; const Key, Name: string): Extended;\r\nbegin\r\n RegReadExtendedEx(RootKey, Key, Name, Result, True);\r\nend;\r\n\r\nfunction RegReadExtendedDef(const RootKey: DelphiHKEY; const Key, Name: string; Def: Extended): Extended;\r\nbegin\r\n try\r\n if not RegReadExtendedEx(RootKey, Key, Name, Result, False) then\r\n Result := Def;\r\n except\r\n Result := Def;\r\n end;\r\nend;\r\n\r\nfunction RegReadStringEx(const RootKey: DelphiHKEY; const Key, Name: string;\r\n out RetValue: string; RaiseException: Boolean): Boolean;\r\n{$IFDEF SUPPORTS_UNICODE}\r\nvar\r\n TmpRet: WideString;\r\nbegin\r\n Result := InternalGetWideString(RootKey, Key, Name, False, TmpRet, RaiseException);\r\n RetValue := string(TmpRet);\r\nend;\r\n{$ELSE ~SUPPORTS_UNICODE}\r\nvar\r\n TmpRet: AnsiString;\r\nbegin\r\n Result := InternalGetAnsiString(RootKey, Key, Name, False, TmpRet, RaiseException);\r\n RetValue := string(TmpRet);\r\nend;\r\n{$ENDIF ~SUPPORTS_UNICODE}\r\n\r\nfunction RegReadString(const RootKey: DelphiHKEY; const Key, Name: string): string;\r\nbegin\r\n RegReadStringEx(RootKey, Key, Name, Result, True);\r\nend;\r\n\r\nfunction RegReadStringDef(const RootKey: DelphiHKEY; const Key, Name: string; Def: string): string;\r\nbegin\r\n try\r\n if not RegReadStringEx(RootKey, Key, Name, Result, False) then\r\n Result := Def;\r\n except\r\n Result := Def;\r\n end;\r\nend;\r\n\r\nfunction RegReadAnsiStringEx(const RootKey: DelphiHKEY; const Key, Name: string;\r\n out RetValue: AnsiString; RaiseException: Boolean): Boolean;\r\nbegin\r\n Result := InternalGetAnsiString(RootKey, Key, Name, False, RetValue, RaiseException);\r\nend;\r\n\r\nfunction RegReadAnsiString(const RootKey: DelphiHKEY; const Key, Name: string): AnsiString;\r\nbegin\r\n RegReadAnsiStringEx(RootKey, Key, Name, Result, True);\r\nend;\r\n\r\nfunction RegReadAnsiStringDef(const RootKey: DelphiHKEY; const Key, Name: string; Def: AnsiString): AnsiString;\r\nbegin\r\n try\r\n if not RegReadAnsiStringEx(RootKey, Key, Name, Result, False) then\r\n Result := Def;\r\n except\r\n Result := Def;\r\n end;\r\nend;\r\n\r\nfunction RegReadWideStringEx(const RootKey: DelphiHKEY; const Key, Name: string;\r\n out RetValue: WideString; RaiseException: Boolean): Boolean;\r\nbegin\r\n Result := InternalGetWideString(RootKey, Key, Name, False, RetValue, RaiseException);\r\nend;\r\n\r\nfunction RegReadWideString(const RootKey: DelphiHKEY; const Key, Name: string): WideString;\r\nbegin\r\n RegReadWideStringEx(RootKey, Key, Name, Result, True);\r\nend;\r\n\r\nfunction RegReadWideStringDef(const RootKey: DelphiHKEY; const Key, Name: string; Def: WideString): WideString;\r\nbegin\r\n try\r\n if not RegReadWideStringEx(RootKey, Key, Name, Result, False) then\r\n Result := Def;\r\n except\r\n Result := Def;\r\n end;\r\nend;\r\n\r\nfunction RegReadMultiSzEx(const RootKey: DelphiHKEY; const Key, Name: string; Value: TStrings;\r\n RaiseException: Boolean): Boolean;\r\n{$IFDEF SUPPORTS_UNICODE}\r\nvar\r\n S: WideString;\r\nbegin\r\n Result := InternalGetWideString(RootKey, Key, Name, True, S, RaiseException);\r\n if Result then\r\n WideMultiSzToWideStrings(Value, PWideMultiSz(PChar(S)));\r\nend;\r\n{$ELSE ~SUPPORTS_UNICODE}\r\nvar\r\n S: AnsiString;\r\nbegin\r\n Result := InternalGetAnsiString(RootKey, Key, Name, True, S, RaiseException);\r\n if Result then\r\n JclStrings.MultiSzToStrings(Value, PAnsiMultiSz(PChar(S)));\r\nend;\r\n{$ENDIF ~SUPPORTS_UNICODE}\r\n\r\nprocedure RegReadMultiSz(const RootKey: DelphiHKEY; const Key, Name: string; Value: TStrings);\r\nbegin\r\n RegReadMultiSzEx(RootKey, Key, Name, Value, True);\r\nend;\r\n\r\nprocedure RegReadMultiSzDef(const RootKey: DelphiHKEY; const Key, Name: string; Value, Def: TStrings);\r\nbegin\r\n try\r\n if not RegReadMultiSzEx(RootKey, Key, Name, Value, False) then\r\n Value.Assign(Def);\r\n except\r\n Value.Assign(Def);\r\n end;\r\nend;\r\n\r\nfunction RegReadMultiSzEx(const RootKey: DelphiHKEY; const Key, Name: string;\r\n out RetValue: PMultiSz; RaiseException: Boolean): Boolean;\r\n{$IFDEF SUPPORTS_UNICODE}\r\nvar\r\n S: WideString;\r\nbegin\r\n Result := InternalGetWideString(RootKey, Key, Name, True, S, RaiseException);\r\n if Result then\r\n // always returns a newly allocated PMultiSz\r\n RetValue := WideMultiSzDup(PWideMultiSz(S))\r\n else\r\n RetValue := nil;\r\nend;\r\n{$ELSE ~SUPPORTS_UNICODE}\r\nvar\r\n S: AnsiString;\r\nbegin\r\n Result := InternalGetAnsiString(RootKey, Key, Name, True, S, RaiseException);\r\n if Result then\r\n // always returns a newly allocated PMultiSz\r\n RetValue := JclAnsiStrings.MultiSzDup(PAnsiMultiSz(S))\r\n else\r\n RetValue := nil;\r\nend;\r\n{$ENDIF ~SUPPORTS_UNICODE}\r\n\r\nfunction RegReadMultiSz(const RootKey: DelphiHKEY; const Key, Name: string): JclStrings.PMultiSz;\r\nbegin\r\n RegReadMultiSzEx(RootKey, Key, Name, Result, True);\r\nend;\r\n\r\nfunction RegReadMultiSzDef(const RootKey: DelphiHKEY; const Key, Name: string; Def: JclStrings.PMultiSz): JclStrings.PMultiSz;\r\nbegin\r\n try\r\n if not RegReadMultiSzEx(RootKey, Key, Name, Result, False) then\r\n // always returns a newly allocated PMultiSz\r\n Result := JclStrings.MultiSzDup(Def);\r\n except\r\n // always returns a newly allocated PMultiSz\r\n Result := JclStrings.MultiSzDup(Def);\r\n end;\r\nend;\r\n\r\nfunction RegReadAnsiMultiSzEx(const RootKey: DelphiHKEY; const Key, Name: string; Value: TAnsiStrings;\r\n RaiseException: Boolean): Boolean;\r\nvar\r\n S: AnsiString;\r\nbegin\r\n Result := InternalGetAnsiString(RootKey, Key, Name, True, S, RaiseException);\r\n if Result then\r\n JclAnsiStrings.MultiSzToStrings(Value, PAnsiMultiSz(S));\r\nend;\r\n\r\nprocedure RegReadAnsiMultiSz(const RootKey: DelphiHKEY; const Key, Name: string; Value: TAnsiStrings);\r\nbegin\r\n RegReadAnsiMultiSzEx(RootKey, Key, Name, Value, True);\r\nend;\r\n\r\nprocedure RegReadAnsiMultiSzDef(const RootKey: DelphiHKEY; const Key, Name: string; Value, Def: TAnsiStrings);\r\nbegin\r\n try\r\n if not RegReadAnsiMultiSzEx(RootKey, Key, Name, Value, False) then\r\n Value.Assign(Def);\r\n except\r\n Value.Assign(Def);\r\n end;\r\nend;\r\n\r\nfunction RegReadAnsiMultiSzEx(const RootKey: DelphiHKEY; const Key, Name: string;\r\n out RetValue: PAnsiMultiSz; RaiseException: Boolean): Boolean; overload;\r\nvar\r\n S: AnsiString;\r\nbegin\r\n RetValue := nil;\r\n Result := InternalGetAnsiString(RootKey, Key, Name, True, S, RaiseException);\r\n if Result then\r\n // always returns a newly allocated PMultiAnsiSz\r\n RetValue := JclAnsiStrings.MultiSzDup(PAnsiMultiSz(S));\r\nend;\r\n\r\nfunction RegReadAnsiMultiSz(const RootKey: DelphiHKEY; const Key, Name: string): PAnsiMultiSz;\r\nbegin\r\n RegReadAnsiMultiSzEx(RootKey, Key, Name, Result, True);\r\nend;\r\n\r\nfunction RegReadAnsiMultiSzDef(const RootKey: DelphiHKEY; const Key, Name: string; Def: PAnsiMultiSz): PAnsiMultiSz;\r\nbegin\r\n try\r\n if RegReadAnsiMultiSzEx(RootKey, Key, Name, Result, False) then\r\n // always returns a newly allocated PAnsiMultiSz\r\n Result := JclAnsiStrings.MultiSzDup(Def);\r\n except\r\n // always returns a newly allocated PAnsiMultiSz\r\n Result := JclAnsiStrings.MultiSzDup(Def);\r\n end;\r\nend;\r\n\r\nfunction RegReadWideMultiSzEx(const RootKey: DelphiHKEY; const Key, Name: string; Value: TWideStrings;\r\n RaiseException: Boolean): Boolean;\r\nvar\r\n S: WideString;\r\nbegin\r\n Result := InternalGetWideString(RootKey, Key, Name, True, S, RaiseException);\r\n if Result then\r\n JclWideStrings.MultiSzToStrings(Value, PWideMultiSz(S));\r\nend;\r\n\r\nprocedure RegReadWideMultiSz(const RootKey: DelphiHKEY; const Key, Name: string; Value: TWideStrings);\r\nbegin\r\n RegReadWideMultiSzEx(RootKey, Key, Name, Value, True);\r\nend;\r\n\r\nprocedure RegReadWideMultiSzDef(const RootKey: DelphiHKEY; const Key, Name: string; Value, Def: TWideStrings);\r\nbegin\r\n try\r\n if not RegReadWideMultiSzEx(RootKey, Key, Name, Value, False) then\r\n Value.Assign(Def);\r\n except\r\n Value.Assign(Def);\r\n end;\r\nend;\r\n\r\nfunction RegReadWideMultiSzEx(const RootKey: DelphiHKEY; const Key, Name: string;\r\n out RetValue: PWideMultiSz; RaiseException: Boolean): Boolean; overload;\r\nvar\r\n S: WideString;\r\nbegin\r\n RetValue := nil;\r\n Result := InternalGetWideString(RootKey, Key, Name, True, S, RaiseException);\r\n if Result then\r\n // always returns a newly allocated PMultiWideSz\r\n RetValue := JclWideStrings.MultiSzDup(PWideMultiSz(S));\r\nend;\r\n\r\nfunction RegReadWideMultiSz(const RootKey: DelphiHKEY; const Key, Name: string): PWideMultiSz;\r\nbegin\r\n RegReadWideMultiSzEx(RootKey, Key, Name, Result, True);\r\nend;\r\n\r\nfunction RegReadWideMultiSzDef(const RootKey: DelphiHKEY; const Key, Name: string; Def: PWideMultiSz): PWideMultiSz;\r\nbegin\r\n try\r\n if RegReadWideMultiSzEx(RootKey, Key, Name, Result, False) then\r\n // always returns a newly allocated PWideMultiSz\r\n Result := JclWideStrings.MultiSzDup(Def);\r\n except\r\n // always returns a newly allocated PWideMultiSz\r\n Result := JclWideStrings.MultiSzDup(Def);\r\n end;\r\nend;\r\n\r\nfunction RegReadBinaryEx(const RootKey: DelphiHKEY; const Key, Name: string; var Value;\r\n const ValueSize: Cardinal; out DataSize: Cardinal; RaiseException: Boolean): Boolean;\r\nvar\r\n DataType: DWORD;\r\nbegin\r\n Result := InternalGetData(RootKey, Key, Name, cRegBinKinds, ValueSize, DataType, @Value, DataSize, RaiseException);\r\nend;\r\n\r\nfunction RegReadBinary(const RootKey: DelphiHKEY; const Key, Name: string; var Value;\r\n const ValueSize: Cardinal): Cardinal;\r\nbegin\r\n RegReadBinaryEx(RootKey, Key, Name, Value, ValueSize, Result, True);\r\nend;\r\n\r\nfunction RegReadBinaryDef(const RootKey: DelphiHKEY; const Key, Name: string;\r\n var Value; const ValueSize: Cardinal; const Def: Byte): Cardinal;\r\nbegin\r\n try\r\n if not RegReadBinaryEx(RootKey, Key, Name, Value, ValueSize, Result, False) then\r\n begin\r\n FillChar(Value, ValueSize, Def);\r\n Result := ValueSize;\r\n end;\r\n except\r\n FillChar(Value, ValueSize, Def);\r\n Result := ValueSize;\r\n end;\r\nend;\r\n\r\nprocedure RegWriteBool(const RootKey: DelphiHKEY; const Key, Name: string; Value: Boolean);\r\nbegin\r\n RegWriteCardinal(RootKey, Key, Name, REG_DWORD, Cardinal(Ord(Value)));\r\nend;\r\n\r\nprocedure RegWriteBool(const RootKey: DelphiHKEY; const Key, Name: string; DataType: Cardinal; Value: Boolean);\r\nbegin\r\n RegWriteCardinal(RootKey, Key, Name, DataType, Cardinal(Ord(Value)));\r\nend;\r\n\r\nprocedure RegWriteInteger(const RootKey: DelphiHKEY; const Key, Name: string; Value: Integer);\r\nbegin\r\n RegWriteInteger(RootKey, Key, Name, REG_DWORD, Value);\r\nend;\r\n\r\nprocedure RegWriteInteger(const RootKey: DelphiHKEY; const Key, Name: string; DataType: Cardinal; Value: Integer);\r\nvar\r\n Val: Int64;\r\n Size: Integer;\r\nbegin\r\n if DataType in [REG_SZ, REG_EXPAND_SZ] then\r\n RegWriteString(RootKey, Key, Name, DataType, Format('%d', [Value]))\r\n else\r\n if DataType in [REG_DWORD, REG_QWORD, REG_BINARY] then\r\n begin\r\n // sign extension\r\n Val := Value;\r\n if DataType = REG_QWORD then\r\n Size := SizeOf(Int64)\r\n else\r\n Size := SizeOf(Value);\r\n InternalSetData(RootKey, Key, Name, DataType, @Val, Size);\r\n end\r\n else\r\n DataError(RootKey, Key, Name);\r\nend;\r\n\r\nprocedure RegWriteCardinal(const RootKey: DelphiHKEY; const Key, Name: string; Value: Cardinal);\r\nbegin\r\n RegWriteCardinal(RootKey, Key, Name, REG_DWORD, Cardinal(Value));\r\nend;\r\n\r\nprocedure RegWriteCardinal(const RootKey: DelphiHKEY; const Key, Name: string; DataType: Cardinal; Value: Cardinal);\r\nvar\r\n Val: Int64;\r\n Size: Integer;\r\nbegin\r\n if DataType in [REG_SZ, REG_EXPAND_SZ] then\r\n RegWriteString(RootKey, Key, Name, DataType, Format('%u', [Value]))\r\n else\r\n if DataType in [REG_DWORD, REG_QWORD, REG_BINARY] then\r\n begin\r\n // no sign extension\r\n Val := Value and $FFFFFFFF;\r\n if DataType = REG_QWORD then\r\n Size := SizeOf(Int64)\r\n else\r\n Size := SizeOf(Value);\r\n InternalSetData(RootKey, Key, Name, DataType, @Val, Size);\r\n end\r\n else\r\n DataError(RootKey, Key, Name);\r\nend;\r\n\r\nprocedure RegWriteDWORD(const RootKey: DelphiHKEY; const Key, Name: string; Value: DWORD);\r\nbegin\r\n RegWriteCardinal(RootKey, Key, Name, REG_DWORD, Cardinal(Value));\r\nend;\r\n\r\nprocedure RegWriteDWORD(const RootKey: DelphiHKEY; const Key, Name: string; DataType: Cardinal; Value: DWORD);\r\nbegin\r\n RegWriteCardinal(RootKey, Key, Name, DataType, Cardinal(Value));\r\nend;\r\n\r\nprocedure RegWriteInt64(const RootKey: DelphiHKEY; const Key, Name: string; Value: Int64);\r\nbegin\r\n RegWriteInt64(RootKey, Key, Name, REG_QWORD, Value);\r\nend;\r\n\r\nprocedure RegWriteInt64(const RootKey: DelphiHKEY; const Key, Name: string; DataType: Cardinal; Value: Int64);\r\nbegin\r\n if DataType in [REG_SZ, REG_EXPAND_SZ] then\r\n RegWriteString(RootKey, Key, Name, DataType, Format('%d', [Value]))\r\n else\r\n RegWriteUInt64(RootKey, Key, Name, DataType, UInt64(Value));\r\nend;\r\n\r\nprocedure RegWriteUInt64(const RootKey: DelphiHKEY; const Key, Name: string; Value: UInt64);\r\nbegin\r\n RegWriteUInt64(RootKey, Key, Name, REG_QWORD, Value);\r\nend;\r\n\r\nprocedure RegWriteUInt64(const RootKey: DelphiHKEY; const Key, Name: string; DataType: Cardinal; Value: UInt64);\r\nbegin\r\n if DataType in [REG_SZ, REG_EXPAND_SZ] then\r\n RegWriteString(RootKey, Key, Name, DataType, Format('%u', [Value]))\r\n else\r\n if DataType in [REG_QWORD, REG_BINARY] then\r\n InternalSetData(RootKey, Key, Name, DataType, @Value, SizeOf(Value))\r\n else\r\n DataError(RootKey, Key, Name);\r\nend;\r\n\r\nprocedure RegWriteSingle(const RootKey: DelphiHKEY; const Key, Name: string; Value: Single);\r\nbegin\r\n RegWriteSingle(RootKey, Key, Name, REG_BINARY, Value);\r\nend;\r\n\r\nprocedure RegWriteSingle(const RootKey: DelphiHKEY; const Key, Name: string; DataType: Cardinal; Value: Single);\r\nbegin\r\n if DataType in [REG_SZ, REG_EXPAND_SZ] then\r\n RegWriteString(RootKey, Key, Name, DataType, Format('%g', [Value]))\r\n else\r\n if DataType in [REG_BINARY] then\r\n InternalSetData(RootKey, Key, Name, DataType, @Value, SizeOf(Value))\r\n else\r\n DataError(RootKey, Key, Name);\r\nend;\r\n\r\nprocedure RegWriteDouble(const RootKey: DelphiHKEY; const Key, Name: string; Value: Double);\r\nbegin\r\n RegWriteDouble(RootKey, Key, Name, REG_BINARY, Value);\r\nend;\r\n\r\nprocedure RegWriteDouble(const RootKey: DelphiHKEY; const Key, Name: string; DataType: Cardinal; Value: Double);\r\nbegin\r\n if DataType in [REG_SZ, REG_EXPAND_SZ] then\r\n RegWriteString(RootKey, Key, Name, DataType, Format('%g', [Value]))\r\n else\r\n if DataType in [REG_BINARY] then\r\n InternalSetData(RootKey, Key, Name, DataType, @Value, SizeOf(Value))\r\n else\r\n DataError(RootKey, Key, Name);\r\nend;\r\n\r\nprocedure RegWriteExtended(const RootKey: DelphiHKEY; const Key, Name: string; Value: Extended);\r\nbegin\r\n RegWriteExtended(RootKey, Key, Name, REG_BINARY, Value);\r\nend;\r\n\r\nprocedure RegWriteExtended(const RootKey: DelphiHKEY; const Key, Name: string; DataType: Cardinal; Value: Extended);\r\nbegin\r\n if DataType in [REG_SZ, REG_EXPAND_SZ] then\r\n RegWriteString(RootKey, Key, Name, DataType, Format('%g', [Value]))\r\n else\r\n if DataType in [REG_BINARY] then\r\n InternalSetData(RootKey, Key, Name, DataType, @Value, SizeOf(Value))\r\n else\r\n DataError(RootKey, Key, Name);\r\nend;\r\n\r\nprocedure RegWriteString(const RootKey: DelphiHKEY; const Key, Name, Value: string);\r\nbegin\r\n RegWriteString(RootKey, Key, Name, REG_SZ, Value);\r\nend;\r\n\r\nprocedure RegWriteString(const RootKey: DelphiHKEY; const Key, Name: string; DataType: Cardinal; const Value: string);\r\nbegin\r\n if DataType in [REG_BINARY, REG_SZ, REG_EXPAND_SZ] then\r\n {$IFDEF SUPPORTS_UNICODE}\r\n InternalSetWideData(RootKey, Key, Name, DataType, PChar(Value),\r\n (Length(Value) + 1) * SizeOf(Char))\r\n {$ELSE ~SUPPORTS_UNICODE}\r\n InternalSetAnsiData(RootKey, Key, Name, DataType, PChar(Value),\r\n (Length(Value) + 1) * SizeOf(Char))\r\n {$ENDIF ~SUPPORTS_UNICODE}\r\n else\r\n DataError(RootKey, Key, Name);\r\nend;\r\n\r\nprocedure RegWriteAnsiString(const RootKey: DelphiHKEY; const Key, Name: string; const Value: AnsiString);\r\nbegin\r\n RegWriteAnsiString(RootKey, Key, Name, REG_SZ, Value);\r\nend;\r\n\r\nprocedure RegWriteAnsiString(const RootKey: DelphiHKEY; const Key, Name: string; DataType: Cardinal;\r\n const Value: AnsiString);\r\nbegin\r\n if DataType in [REG_BINARY, REG_SZ, REG_EXPAND_SZ] then\r\n InternalSetAnsiData(RootKey, Key, Name, DataType, PAnsiChar(Value),\r\n (Length(Value) + 1) * SizeOf(AnsiChar))\r\n else\r\n DataError(RootKey, Key, Name);\r\nend;\r\n\r\nprocedure RegWriteWideString(const RootKey: DelphiHKEY; const Key, Name: string; const Value: WideString);\r\nbegin\r\n RegWriteWideString(RootKey, Key, Name, REG_SZ, Value);\r\nend;\r\n\r\nprocedure RegWriteWideString(const RootKey: DelphiHKEY; const Key, Name: string; DataType: Cardinal;\r\n const Value: WideString);\r\nbegin\r\n if DataType in [REG_BINARY, REG_SZ, REG_EXPAND_SZ] then\r\n InternalSetWideData(RootKey, Key, Name, DataType, PWideChar(Value),\r\n (Length(Value) + 1) * SizeOf(WideChar))\r\n else\r\n DataError(RootKey, Key, Name);\r\nend;\r\n\r\nprocedure RegWriteMultiSz(const RootKey: DelphiHKEY; const Key, Name: string; Value: JclStrings.PMultiSz);\r\nbegin\r\n RegWriteMultiSz(RootKey, Key, Name, REG_MULTI_SZ, Value);\r\nend;\r\n\r\nprocedure RegWriteMultiSz(const RootKey: DelphiHKEY; const Key, Name: string; DataType: Cardinal; Value: JclStrings.PMultiSz);\r\nbegin\r\n if DataType in [REG_BINARY, REG_MULTI_SZ] then\r\n {$IFDEF SUPPORTS_UNICODE}\r\n InternalSetWideData(RootKey, Key, Name, DataType, Value,\r\n MultiSzLength(Value) * SizeOf(Char))\r\n {$ELSE ~SUPPORTS_UNICODE}\r\n InternalSetAnsiData(RootKey, Key, Name, DataType, Value,\r\n JclStrings.MultiSzLength(Value) * SizeOf(Char))\r\n {$ENDIF ~SUPPORTS_UNICODE}\r\n else\r\n DataError(RootKey, Key, Name);\r\nend;\r\n\r\nprocedure RegWriteMultiSz(const RootKey: DelphiHKEY; const Key, Name: string; const Value: TStrings);\r\nbegin\r\n RegWriteMultiSz(RootKey, Key, Name, REG_MULTI_SZ, Value);\r\nend;\r\n\r\nprocedure RegWriteMultiSz(const RootKey: DelphiHKEY; const Key, Name: string; DataType: Cardinal;\r\n const Value: TStrings);\r\nvar\r\n Dest: JclStrings.PMultiSz;\r\nbegin\r\n if DataType in [REG_BINARY, REG_MULTI_SZ] then\r\n begin\r\n Dest := nil;\r\n JclStrings.StringsToMultiSz(Dest, Value);\r\n try\r\n RegWriteMultiSz(RootKey, Key, Name, DataType, Dest);\r\n finally\r\n JclStrings.FreeMultiSz(Dest);\r\n end;\r\n end\r\n else\r\n DataError(RootKey, Key, Name);\r\nend;\r\n\r\nprocedure RegWriteAnsiMultiSz(const RootKey: DelphiHKEY; const Key, Name: string; Value: PAnsiMultiSz);\r\nbegin\r\n RegWriteAnsiMultiSz(RootKey, Key, Name, REG_MULTI_SZ, Value);\r\nend;\r\n\r\nprocedure RegWriteAnsiMultiSz(const RootKey: DelphiHKEY; const Key, Name: string; DataType: Cardinal;\r\n Value: PAnsiMultiSz);\r\nbegin\r\n if DataType in [REG_BINARY, REG_MULTI_SZ] then\r\n InternalSetAnsiData(RootKey, Key, Name, DataType, Value,\r\n JclAnsiStrings.MultiSzLength(Value) * SizeOf(AnsiChar))\r\n else\r\n DataError(RootKey, Key, Name);\r\nend;\r\n\r\nprocedure RegWriteAnsiMultiSz(const RootKey: DelphiHKEY; const Key, Name: string; const Value: TAnsiStrings);\r\nbegin\r\n RegWriteAnsiMultiSz(RootKey, Key, Name, REG_MULTI_SZ, Value);\r\nend;\r\n\r\nprocedure RegWriteAnsiMultiSz(const RootKey: DelphiHKEY; const Key, Name: string; DataType: Cardinal;\r\n const Value: TAnsiStrings);\r\nvar\r\n Dest: PAnsiMultiSz;\r\nbegin\r\n if DataType in [REG_BINARY, REG_MULTI_SZ] then\r\n begin\r\n Dest := nil;\r\n JclAnsiStrings.StringsToMultiSz(Dest, Value);\r\n try\r\n RegWriteAnsiMultiSz(RootKey, Key, Name, DataType, Dest);\r\n finally\r\n JclAnsiStrings.FreeMultiSz(Dest);\r\n end;\r\n end\r\n else\r\n DataError(RootKey, Key, Name);\r\nend;\r\n\r\nprocedure RegWriteWideMultiSz(const RootKey: DelphiHKEY; const Key, Name: string; Value: PWideMultiSz);\r\nbegin\r\n RegWriteWideMultiSz(RootKey, Key, Name, REG_MULTI_SZ, Value);\r\nend;\r\n\r\nprocedure RegWriteWideMultiSz(const RootKey: DelphiHKEY; const Key, Name: string; DataType: Cardinal;\r\n Value: PWideMultiSz);\r\nbegin\r\n if DataType in [REG_BINARY, REG_MULTI_SZ] then\r\n InternalSetWideData(RootKey, Key, Name, DataType, Value,\r\n JclWideStrings.MultiSzLength(Value) * SizeOf(WideChar))\r\n else\r\n DataError(RootKey, Key, Name);\r\nend;\r\n\r\nprocedure RegWriteWideMultiSz(const RootKey: DelphiHKEY; const Key, Name: string; const Value: TWideStrings);\r\nbegin\r\n RegWriteWideMultiSz(RootKey, Key, Name, REG_MULTI_SZ, Value);\r\nend;\r\n\r\nprocedure RegWriteWideMultiSz(const RootKey: DelphiHKEY; const Key, Name: string; DataType: Cardinal;\r\n const Value: TWideStrings);\r\nvar\r\n Dest: PWideMultiSz;\r\nbegin\r\n if DataType in [REG_BINARY, REG_MULTI_SZ] then\r\n begin\r\n Dest := nil;\r\n JclWideStrings.StringsToMultiSz(Dest, Value);\r\n try\r\n RegWriteWideMultiSz(RootKey, Key, Name, DataType, Dest);\r\n finally\r\n JclWideStrings.FreeMultiSz(Dest);\r\n end;\r\n end\r\n else\r\n DataError(RootKey, Key, Name);\r\nend;\r\n\r\nprocedure RegWriteBinary(const RootKey: DelphiHKEY; const Key, Name: string; const Value; const ValueSize: Cardinal);\r\nbegin\r\n InternalSetData(RootKey, Key, Name, REG_BINARY, @Value, ValueSize);\r\nend;\r\n\r\nfunction UnregisterAutoExec(ExecKind: TExecKind; const Name: string): Boolean;\r\nvar\r\n Key: HKEY;\r\n RegPath: string;\r\nbegin\r\n Result := GetKeyAndPath(ExecKind, Key, RegPath);\r\n if Result then\r\n Result := RegDeleteEntry(Key, RegPath, Name);\r\nend;\r\n\r\nfunction RegisterAutoExec(ExecKind: TExecKind; const Name, Cmdline: string): Boolean;\r\nvar\r\n Key: HKEY;\r\n RegPath: string;\r\nbegin\r\n Result := GetKeyAndPath(ExecKind, Key, RegPath);\r\n if Result then\r\n RegWriteString(Key, RegPath, Name, Cmdline);\r\nend;\r\n\r\nfunction RegGetValueNames(const RootKey: DelphiHKEY; const Key: string; const List: TStrings): Boolean;\r\nvar\r\n RegKey: HKEY;\r\n I: DWORD;\r\n Size: DWORD;\r\n NumSubKeys: DWORD;\r\n NumSubValues: DWORD;\r\n MaxSubValueLen: DWORD;\r\n ValueName: string;\r\nbegin\r\n Result := False;\r\n List.BeginUpdate;\r\n try\r\n List.Clear;\r\n RegKey := 0;\r\n if InternalRegOpenKeyEx(RootKey, RelativeKey(RootKey, PChar(Key)), 0, KEY_READ, RegKey) = ERROR_SUCCESS then\r\n begin\r\n if RegQueryInfoKey(RegKey, nil, nil, nil, @NumSubKeys, nil, nil,\r\n @NumSubValues, @MaxSubValueLen, nil, nil, nil) = ERROR_SUCCESS then\r\n begin\r\n SetLength(ValueName, MaxSubValueLen + 1);\r\n if NumSubValues <> 0 then\r\n for I := 0 to NumSubValues - 1 do\r\n begin\r\n Size := MaxSubValueLen + 1;\r\n RegEnumValue(RegKey, I, PChar(ValueName), Size, nil, nil, nil, nil);\r\n List.Add(PChar(ValueName));\r\n end;\r\n Result := True;\r\n end;\r\n RegCloseKey(RegKey);\r\n end\r\n else\r\n ReadError(RootKey, Key);\r\n finally\r\n List.EndUpdate;\r\n end;\r\nend;\r\n\r\nfunction RegGetKeyNames(const RootKey: DelphiHKEY; const Key: string; const List: TStrings): Boolean;\r\nvar\r\n RegKey: HKEY;\r\n I: DWORD;\r\n Size: DWORD;\r\n NumSubKeys: DWORD;\r\n MaxSubKeyLen: DWORD;\r\n KeyName: string;\r\nbegin\r\n Result := False;\r\n List.BeginUpdate;\r\n try\r\n List.Clear;\r\n RegKey := 0;\r\n if InternalRegOpenKeyEx(RootKey, RelativeKey(RootKey, PChar(Key)), 0, KEY_READ, RegKey) = ERROR_SUCCESS then\r\n begin\r\n if RegQueryInfoKey(RegKey, nil, nil, nil,\r\n @NumSubKeys, @MaxSubKeyLen, nil, nil, nil, nil, nil, nil) = ERROR_SUCCESS then\r\n begin\r\n SetLength(KeyName, MaxSubKeyLen+1);\r\n if NumSubKeys <> 0 then\r\n for I := 0 to NumSubKeys-1 do\r\n begin\r\n Size := MaxSubKeyLen+1;\r\n RegEnumKeyEx(RegKey, I, PChar(KeyName), Size, nil, nil, nil, nil);\r\n List.Add(PChar(KeyName));\r\n end;\r\n Result := True;\r\n end;\r\n RegCloseKey(RegKey);\r\n end\r\n else\r\n ReadError(RootKey, Key);\r\n finally\r\n List.EndUpdate;\r\n end;\r\nend;\r\n\r\nfunction RegGetValueNamesAndValues(const RootKey: HKEY; const Key: string; const List: TStrings): Boolean;\r\nvar\r\n I: Integer;\r\n TempList: TStringList;\r\n Name: string;\r\n DataType: DWORD;\r\nbegin\r\n List.BeginUpdate;\r\n TempList := TStringList.Create;\r\n try\r\n List.Clear;\r\n Result := RegKeyExists(RootKey, Key) and RegGetValueNames(RootKey, Key, TempList);\r\n if Result then\r\n begin\r\n for I := 0 to TempList.Count - 1 do\r\n begin\r\n Name := TempList[I];\r\n if RegGetDataType(RootKey, Key, Name, DataType) and\r\n ((DataType = REG_SZ) or (DataType = REG_EXPAND_SZ) or (DataType = REG_BINARY)) then\r\n List.Values[Name] := RegReadStringDef(RootKey, Key, Name, '');\r\n end;\r\n end;\r\n finally\r\n List.EndUpdate;\r\n TempList.Free;\r\n end;\r\nend;\r\n\r\nfunction RegHasSubKeys(const RootKey: DelphiHKEY; const Key: string): Boolean;\r\nvar\r\n RegKey: HKEY;\r\n NumSubKeys: Integer;\r\nbegin\r\n Result := False;\r\n RegKey := 0;\r\n if InternalRegOpenKeyEx(RootKey, RelativeKey(RootKey, PChar(Key)), 0, KEY_READ, RegKey) = ERROR_SUCCESS then\r\n begin\r\n RegQueryInfoKey(RegKey, nil, nil, nil, @NumSubKeys, nil, nil, nil, nil, nil, nil, nil);\r\n Result := NumSubKeys <> 0;\r\n RegCloseKey(RegKey);\r\n end\r\n else\r\n ReadError(RootKey, Key);\r\nend;\r\n\r\nfunction RegKeyExists(const RootKey: DelphiHKEY; const Key: string): Boolean;\r\nvar\r\n RegKey: HKEY;\r\nbegin\r\n RegKey := 0;\r\n Result := (InternalRegOpenKeyEx(RootKey, RelativeKey(RootKey, PChar(Key)), 0, KEY_READ, RegKey) = ERROR_SUCCESS);\r\n if Result then\r\n RegCloseKey(RegKey);\r\nend;\r\n\r\nfunction RegValueExists(const RootKey: DelphiHKEY; const Key, Name: string): Boolean;\r\nvar\r\n RegKey: HKEY;\r\nbegin\r\n RegKey := 0;\r\n Result := (InternalRegOpenKeyEx(RootKey, RelativeKey(RootKey, PChar(Key)), 0, KEY_READ, RegKey) = ERROR_SUCCESS);\r\n if Result then\r\n begin\r\n Result := RegQueryValueEx(RegKey, PChar(Name), nil, nil, nil, nil) = ERROR_SUCCESS;\r\n RegCloseKey(RegKey);\r\n end;\r\nend;\r\n\r\nfunction RegSaveList(const RootKey: DelphiHKEY; const Key: string;\r\n const ListName: string; const Items: TStrings): Boolean;\r\nvar\r\n I: Integer;\r\n SubKey: string;\r\nbegin\r\n Result := False;\r\n SubKey := Key + RegKeyDelimiter + ListName;\r\n if RegCreateKey(RootKey, SubKey) = ERROR_SUCCESS then\r\n begin\r\n // Save Number of strings\r\n RegWriteInteger(RootKey, SubKey, cItems, Items.Count);\r\n for I := 1 to Items.Count do\r\n RegWriteString(RootKey, SubKey, IntToStr(I), Items[I-1]);\r\n Result := True;\r\n end;\r\nend;\r\n\r\nfunction RegLoadList(const RootKey: DelphiHKEY; const Key: string;\r\n const ListName: string; const SaveTo: TStrings): Boolean;\r\nvar\r\n I, N: Integer;\r\n SubKey: string;\r\nbegin\r\n SaveTo.BeginUpdate;\r\n try\r\n SaveTo.Clear;\r\n SubKey := Key + RegKeyDelimiter + ListName;\r\n N := RegReadIntegerDef(RootKey, SubKey, cItems, -1);\r\n for I := 1 to N do\r\n SaveTo.Add(RegReadString(RootKey, SubKey, IntToStr(I)));\r\n Result := N > 0;\r\n finally\r\n SaveTo.EndUpdate;\r\n end;\r\nend;\r\n\r\nfunction RegDelList(const RootKey: DelphiHKEY; const Key: string; const ListName: string): Boolean;\r\nvar\r\n I, N: Integer;\r\n SubKey: string;\r\nbegin\r\n Result := False;\r\n SubKey := Key + RegKeyDelimiter + ListName;\r\n N := RegReadIntegerDef(RootKey, SubKey, cItems, -1);\r\n if (N > 0) and RegDeleteEntry(RootKey, SubKey, cItems) then\r\n for I := 1 to N do\r\n begin\r\n Result := RegDeleteEntry(RootKey, SubKey, IntToStr(I));\r\n if not Result then\r\n Break;\r\n end;\r\nend;\r\n\r\nfunction AllowRegKeyForEveryone(const RootKey: DelphiHKEY; Path: string): Boolean;\r\nvar\r\n WidePath: PWideChar;\r\n Len: Integer;\r\n\r\n// This is an ugly kludge until the x64 compiler allows 64bit constants in case statements\r\n// http://qc.embarcadero.com/wc/qcmain.aspx?d=95499\r\nconst\r\n HKLM2 = Cardinal(HKLM);\r\n HKCU2 = Cardinal(HKCU);\r\n HKCR2 = Cardinal(HKCR);\r\n HKUS2 = Cardinal(HKUS);\r\n\r\nbegin\r\n Result := Win32Platform <> VER_PLATFORM_WIN32_NT;\r\n if not Result then // Win 2000/XP\r\n begin\r\n case Cardinal(RootKey) of\r\n HKLM2:\r\n Path := HKLMLongName + RegKeyDelimiter + RelativeKey(RootKey, PChar(Path));\r\n HKCU2:\r\n Path := HKCULongName + RegKeyDelimiter + RelativeKey(RootKey, PChar(Path));\r\n HKCR2:\r\n Path := HKCRLongName + RegKeyDelimiter + RelativeKey(RootKey, PChar(Path));\r\n HKUS2:\r\n Path := HKUSLongName + RegKeyDelimiter + RelativeKey(RootKey, PChar(Path));\r\n end;\r\n Len := (Length(Path) + 1) * SizeOf(WideChar);\r\n GetMem(WidePath, Len);\r\n MultiByteToWideChar(CP_ACP, MB_PRECOMPOSED, PAnsiChar(AnsiString(Path)), -1, WidePath, Len);\r\n Result := RtdlSetNamedSecurityInfoW(WidePath, SE_REGISTRY_KEY,\r\n DACL_SECURITY_INFORMATION, nil, nil, nil, nil) = ERROR_SUCCESS;\r\n FreeMem(WidePath);\r\n end;\r\nend;\r\n\r\nfunction RegAutoExecEnabled(const ExecKind: TExecKind; const Name: string; out CmdLine: string): Boolean;\r\nvar\r\n Key: HKEY;\r\n RegPath: string;\r\nbegin\r\n CmdLine := '';\r\n\r\n Result := GetKeyAndPath(ExecKind, Key, RegPath);\r\n if Result then\r\n begin\r\n try\r\n CmdLine := RegReadString(Key, RegPath, Name);\r\n except\r\n Result := False;\r\n CmdLine := '';\r\n end;\r\n end\r\n else\r\n CmdLine := '';\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n\r\n" }, { "path": "External/Jedi/Jcl/source/windows/JclSecurity.pas", "content": "{**************************************************************************************************}\r\n{ }\r\n{ Project JEDI Code Library (JCL) }\r\n{ }\r\n{ The contents of this file are subject to the Mozilla Public License Version 1.1 (the \"License\"); }\r\n{ you may not use this file except in compliance with the License. You may obtain a copy of the }\r\n{ License at http://www.mozilla.org/MPL/ }\r\n{ }\r\n{ Software distributed under the License is distributed on an \"AS IS\" basis, WITHOUT WARRANTY OF }\r\n{ ANY KIND, either express or implied. See the License for the specific language governing rights }\r\n{ and limitations under the License. }\r\n{ }\r\n{ The Original Code is JclSecurity.pas. }\r\n{ }\r\n{ The Initial Developer of the Original Code is Marcel van Brakel. }\r\n{ Portions created by Marcel van Brakel are Copyright (C) Marcel van Brakel. All Rights Reserved. }\r\n{ }\r\n{ Contributor(s): }\r\n{ Marcel van Brakel }\r\n{ Peter Friese }\r\n{ Robert Marquardt (marquardt) }\r\n{ John C Molyneux }\r\n{ Robert Rossmair (rrossmair) }\r\n{ Matthias Thoma (mthoma) }\r\n{ Petr Vones (pvones) }\r\n{ Christoph Lindeman }\r\n{ }\r\n{**************************************************************************************************}\r\n{ }\r\n{ Various NT security related routines to perform commen asks such as enabling and disabling }\r\n{ privileges. }\r\n{ }\r\n{**************************************************************************************************}\r\n{ }\r\n{ Last modified: $Date:: 2011-09-03 00:07:50 +0200 (sam. 03 sept. 2011) $ }\r\n{ Revision: $Rev:: 3599 $ }\r\n{ Author: $Author:: outchy $ }\r\n{ }\r\n{**************************************************************************************************}\r\n\r\nunit JclSecurity;\r\n\r\n{$I jcl.inc}\r\n{$I windowsonly.inc}\r\n\r\n{$HPPEMIT '#define TTokenInformationClass TOKEN_INFORMATION_CLASS'}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n {$IFDEF HAS_UNITSCOPE}\r\n Winapi.Windows, System.SysUtils,\r\n {$ELSE ~HAS_UNITSCOPE}\r\n Windows, SysUtils,\r\n {$ENDIF ~HAS_UNITSCOPE}\r\n JclBase;\r\n\r\ntype\r\n EJclSecurityError = class(EJclError);\r\n\r\n// Access Control\r\nfunction CreateNullDacl(out Sa: TSecurityAttributes; const Inheritable: Boolean): PSecurityAttributes;\r\nfunction CreateInheritable(out Sa: TSecurityAttributes): PSecurityAttributes;\r\n\r\n// Privileges\r\nfunction IsGroupMember(RelativeGroupID: DWORD): Boolean;\r\nfunction IsAdministrator: Boolean;\r\nfunction IsUser: Boolean;\r\nfunction IsGuest: Boolean;\r\nfunction IsPowerUser: Boolean;\r\nfunction IsAccountOperator: Boolean;\r\nfunction IsSystemOperator: Boolean;\r\nfunction IsPrintOperator: Boolean;\r\nfunction IsBackupOperator: Boolean;\r\nfunction IsReplicator: Boolean;\r\nfunction IsRASServer: Boolean;\r\nfunction IsPreWin2000CompAccess: Boolean;\r\nfunction IsRemoteDesktopUser: Boolean;\r\nfunction IsNetworkConfigurationOperator: Boolean;\r\nfunction IsIncomingForestTrustBuilder: Boolean;\r\nfunction IsMonitoringUser: Boolean;\r\nfunction IsLoggingUser: Boolean;\r\nfunction IsAuthorizationAccess: Boolean;\r\nfunction IsTSLicenseServer: Boolean;\r\n\r\nfunction EnableProcessPrivilege(const Enable: Boolean; const Privilege: string): Boolean;\r\nfunction EnableThreadPrivilege(const Enable: Boolean; const Privilege: string): Boolean;\r\nfunction IsPrivilegeEnabled(const Privilege: string): Boolean;\r\n\r\nfunction GetPrivilegeDisplayName(const PrivilegeName: string): string;\r\nfunction SetUserObjectFullAccess(hUserObject: THandle): Boolean;\r\nfunction GetUserObjectName(hUserObject: THandle): string;\r\n\r\n// Account Information\r\nprocedure LookupAccountBySid(Sid: PSID; out Name, Domain: AnsiString; Silent: Boolean = False); overload;\r\nprocedure LookupAccountBySid(Sid: PSID; out Name, Domain: WideString; Silent: Boolean = False); overload;\r\nprocedure QueryTokenInformation(Token: THandle; InformationClass: TTokenInformationClass; var Buffer: Pointer);\r\nprocedure FreeTokenInformation(var Buffer: Pointer);\r\nfunction GetInteractiveUserName: string;\r\n\r\n// SID utilities\r\nfunction SIDToString(ASID: PSID): string;\r\nprocedure StringToSID(const SIDString: String; SID: PSID; cbSID: DWORD);\r\n\r\n// Computer Information\r\nfunction GetComputerSID(SID: PSID; cbSID: DWORD): Boolean;\r\n\r\n// Windows Vista/Server 2008 UAC (User Account Control)\r\nfunction IsUACEnabled: Boolean;\r\nfunction IsElevated: Boolean;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jcl.svn.sourceforge.net/svnroot/jcl/tags/JCL-2.4-Build4571/jcl/source/windows/JclSecurity.pas $';\r\n Revision: '$Revision: 3599 $';\r\n Date: '$Date: 2011-09-03 00:07:50 +0200 (sam. 03 sept. 2011) $';\r\n LogPath: 'JCL\\source\\windows';\r\n Extra: '';\r\n Data: nil\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n {$IFDEF HAS_UNITSCOPE}\r\n System.Classes,\r\n {$ELSE ~HAS_UNITSCOPE}\r\n Classes,\r\n {$ENDIF ~HAS_UNITSCOPE}\r\n {$IFDEF BORLAND}\r\n AccCtrl,\r\n {$ENDIF BORLAND}\r\n JclRegistry, JclResources, JclStrings, JclSysInfo, JclWin32;\r\n\r\n//=== Access Control =========================================================\r\n\r\nfunction CreateNullDacl(out Sa: TSecurityAttributes; const Inheritable: Boolean): PSecurityAttributes;\r\nbegin\r\n if IsWinNT then\r\n begin\r\n Sa.lpSecurityDescriptor := AllocMem(SizeOf(TSecurityDescriptor));\r\n try\r\n Sa.nLength := SizeOf(Sa);\r\n Sa.bInheritHandle := Inheritable;\r\n Win32Check(InitializeSecurityDescriptor(Sa.lpSecurityDescriptor, SECURITY_DESCRIPTOR_REVISION));\r\n Win32Check(SetSecurityDescriptorDacl(Sa.lpSecurityDescriptor, True, nil, False));\r\n Result := @Sa;\r\n except\r\n FreeMem(Sa.lpSecurityDescriptor);\r\n Sa.lpSecurityDescriptor := nil;\r\n raise;\r\n end;\r\n end\r\n else\r\n begin\r\n Sa.lpSecurityDescriptor := nil;\r\n Result := nil;\r\n end;\r\nend;\r\n\r\nfunction CreateInheritable(out Sa: TSecurityAttributes): PSecurityAttributes;\r\nbegin\r\n Sa.nLength := SizeOf(Sa);\r\n Sa.lpSecurityDescriptor := nil;\r\n Sa.bInheritHandle := True;\r\n if IsWinNT then\r\n Result := @Sa\r\n else\r\n Result := nil;\r\nend;\r\n\r\n//=== Privileges =============================================================\r\n\r\nfunction IsGroupMember(RelativeGroupID: DWORD): Boolean;\r\nvar\r\n psidAdmin: Pointer;\r\n Token: THandle;\r\n Count: DWORD;\r\n TokenInfo: PTokenGroups;\r\n HaveToken: Boolean;\r\n I: Integer;\r\nconst\r\n SE_GROUP_USE_FOR_DENY_ONLY = $00000010;\r\nbegin\r\n Result := not IsWinNT;\r\n if Result then // Win9x and ME don't have user groups\r\n Exit;\r\n psidAdmin := nil;\r\n TokenInfo := nil;\r\n HaveToken := False;\r\n try\r\n Token := 0;\r\n HaveToken := OpenThreadToken(GetCurrentThread, TOKEN_QUERY, True, Token);\r\n if (not HaveToken) and (GetLastError = ERROR_NO_TOKEN) then\r\n HaveToken := OpenProcessToken(GetCurrentProcess, TOKEN_QUERY, Token);\r\n if HaveToken then\r\n begin\r\n {$IFDEF FPC}\r\n Win32Check(AllocateAndInitializeSid(SECURITY_NT_AUTHORITY, 2,\r\n SECURITY_BUILTIN_DOMAIN_RID, RelativeGroupID, 0, 0, 0, 0, 0, 0,\r\n psidAdmin));\r\n if GetTokenInformation(Token, TokenGroups, nil, 0, @Count) or\r\n (GetLastError <> ERROR_INSUFFICIENT_BUFFER) then\r\n RaiseLastOSError;\r\n TokenInfo := PTokenGroups(AllocMem(Count));\r\n Win32Check(GetTokenInformation(Token, TokenGroups, TokenInfo, Count, @Count));\r\n {$ELSE FPC}\r\n Win32Check(AllocateAndInitializeSid(SECURITY_NT_AUTHORITY, 2,\r\n SECURITY_BUILTIN_DOMAIN_RID, RelativeGroupID, 0, 0, 0, 0, 0, 0,\r\n psidAdmin));\r\n if GetTokenInformation(Token, TokenGroups, nil, 0, Count) or\r\n (GetLastError <> ERROR_INSUFFICIENT_BUFFER) then\r\n RaiseLastOSError;\r\n TokenInfo := PTokenGroups(AllocMem(Count));\r\n Win32Check(GetTokenInformation(Token, TokenGroups, TokenInfo, Count, Count));\r\n {$ENDIF FPC}\r\n for I := 0 to TokenInfo^.GroupCount - 1 do\r\n begin\r\n {$RANGECHECKS OFF} // Groups is an array [0..0] of TSIDAndAttributes, ignore ERangeError\r\n Result := EqualSid(psidAdmin, TokenInfo^.Groups[I].Sid);\r\n if Result then\r\n begin\r\n //consider denied ACE with Administrator SID\r\n Result := TokenInfo^.Groups[I].Attributes and SE_GROUP_USE_FOR_DENY_ONLY\r\n <> SE_GROUP_USE_FOR_DENY_ONLY;\r\n Break;\r\n end;\r\n {$IFDEF RANGECHECKS_ON}\r\n {$RANGECHECKS ON}\r\n {$ENDIF RANGECHECKS_ON}\r\n end;\r\n end;\r\n finally\r\n if TokenInfo <> nil then\r\n FreeMem(TokenInfo);\r\n if HaveToken then\r\n CloseHandle(Token);\r\n if psidAdmin <> nil then\r\n FreeSid(psidAdmin);\r\n end;\r\nend;\r\n\r\nfunction IsAdministrator: Boolean;\r\nbegin\r\n Result := IsGroupMember(DOMAIN_ALIAS_RID_ADMINS);\r\nend;\r\n\r\nfunction IsUser: Boolean;\r\nbegin\r\n Result := IsGroupMember(DOMAIN_ALIAS_RID_USERS);\r\nend;\r\n\r\nfunction IsGuest: Boolean;\r\nbegin\r\n Result := IsGroupMember(DOMAIN_ALIAS_RID_GUESTS);\r\nend;\r\n\r\nfunction IsPowerUser: Boolean;\r\nbegin\r\n Result := IsGroupMember(DOMAIN_ALIAS_RID_POWER_USERS);\r\nend;\r\n\r\nfunction IsAccountOperator: Boolean;\r\nbegin\r\n Result := IsGroupMember(DOMAIN_ALIAS_RID_ACCOUNT_OPS);\r\nend;\r\n\r\nfunction IsSystemOperator: Boolean;\r\nbegin\r\n Result := IsGroupMember(DOMAIN_ALIAS_RID_SYSTEM_OPS);\r\nend;\r\n\r\nfunction IsPrintOperator: Boolean;\r\nbegin\r\n Result := IsGroupMember(DOMAIN_ALIAS_RID_PRINT_OPS);\r\nend;\r\n\r\nfunction IsBackupOperator: Boolean;\r\nbegin\r\n Result := IsGroupMember(DOMAIN_ALIAS_RID_BACKUP_OPS);\r\nend;\r\n\r\nfunction IsReplicator: Boolean;\r\nbegin\r\n Result := IsGroupMember(DOMAIN_ALIAS_RID_REPLICATOR);\r\nend;\r\n\r\nfunction IsRASServer: Boolean;\r\nbegin\r\n Result := IsGroupMember(DOMAIN_ALIAS_RID_RAS_SERVERS);\r\nend;\r\n\r\nfunction IsPreWin2000CompAccess: Boolean;\r\nbegin\r\n Result := IsGroupMember(DOMAIN_ALIAS_RID_PREW2KCOMPACCESS);\r\nend;\r\n\r\nfunction IsRemoteDesktopUser: Boolean;\r\nbegin\r\n Result := IsGroupMember(DOMAIN_ALIAS_RID_REMOTE_DESKTOP_USERS);\r\nend;\r\n\r\nfunction IsNetworkConfigurationOperator: Boolean;\r\nbegin\r\n Result := IsGroupMember(DOMAIN_ALIAS_RID_NETWORK_CONFIGURATION_OPS);\r\nend;\r\n\r\nfunction IsIncomingForestTrustBuilder: Boolean;\r\nbegin\r\n Result := IsGroupMember(DOMAIN_ALIAS_RID_INCOMING_FOREST_TRUST_BUILDERS);\r\nend;\r\n\r\nfunction IsMonitoringUser: Boolean;\r\nbegin\r\n Result := IsGroupMember(DOMAIN_ALIAS_RID_MONITORING_USERS);\r\nend;\r\n\r\nfunction IsLoggingUser: Boolean;\r\nbegin\r\n Result := IsGroupMember(DOMAIN_ALIAS_RID_LOGGING_USERS);\r\nend;\r\n\r\nfunction IsAuthorizationAccess: Boolean;\r\nbegin\r\n Result := IsGroupMember(DOMAIN_ALIAS_RID_AUTHORIZATIONACCESS);\r\nend;\r\n\r\nfunction IsTSLicenseServer: Boolean;\r\nbegin\r\n Result := IsGroupMember(DOMAIN_ALIAS_RID_TS_LICENSE_SERVERS);\r\nend;\r\n\r\nfunction EnableProcessPrivilege(const Enable: Boolean; const Privilege: string): Boolean;\r\nconst\r\n PrivAttrs: array [Boolean] of DWORD = (0, SE_PRIVILEGE_ENABLED);\r\nvar\r\n Token: THandle;\r\n TokenPriv: TTokenPrivileges;\r\nbegin\r\n Result := not IsWinNT;\r\n if Result then // if Win9x, then function return True\r\n Exit;\r\n Token := 0;\r\n if OpenProcessToken(GetCurrentProcess, TOKEN_ADJUST_PRIVILEGES, Token) then\r\n begin\r\n TokenPriv.PrivilegeCount := 1;\r\n LookupPrivilegeValue(nil, PChar(Privilege), TokenPriv.Privileges[0].Luid);\r\n TokenPriv.Privileges[0].Attributes := PrivAttrs[Enable];\r\n JclWin32.AdjustTokenPrivileges(Token, False, TokenPriv, SizeOf(TokenPriv), nil, nil);\r\n Result := GetLastError = ERROR_SUCCESS;\r\n CloseHandle(Token);\r\n end;\r\nend;\r\n\r\nfunction EnableThreadPrivilege(const Enable: Boolean; const Privilege: string): Boolean;\r\nconst\r\n PrivAttrs: array [Boolean] of DWORD = (0, SE_PRIVILEGE_ENABLED);\r\nvar\r\n Token: THandle;\r\n TokenPriv: TTokenPrivileges;\r\n HaveToken: Boolean;\r\nbegin\r\n Result := not IsWinNT;\r\n if Result then // Win9x/ME\r\n Exit;\r\n Token := 0;\r\n HaveToken := OpenThreadToken(GetCurrentThread, TOKEN_ADJUST_PRIVILEGES,\r\n False, Token);\r\n if (not HaveToken) and (GetLastError = ERROR_NO_TOKEN) then\r\n HaveToken := OpenProcessToken(GetCurrentProcess, TOKEN_ADJUST_PRIVILEGES, Token);\r\n if HaveToken then\r\n begin\r\n TokenPriv.PrivilegeCount := 1;\r\n LookupPrivilegeValue(nil, PChar(Privilege), TokenPriv.Privileges[0].Luid);\r\n TokenPriv.Privileges[0].Attributes := PrivAttrs[Enable];\r\n JclWin32.AdjustTokenPrivileges(Token, False, TokenPriv, SizeOf(TokenPriv), nil, nil);\r\n Result := GetLastError = ERROR_SUCCESS;\r\n CloseHandle(Token);\r\n end;\r\nend;\r\n\r\nfunction IsPrivilegeEnabled(const Privilege: string): Boolean;\r\nvar\r\n Token: THandle;\r\n TokenPriv: TPrivilegeSet;\r\n Res: LongBool;\r\n HaveToken: Boolean;\r\nbegin\r\n Result := not IsWinNT;\r\n if Result then // Win9x/ME\r\n Exit;\r\n Token := 0;\r\n HaveToken := OpenThreadToken(GetCurrentThread, TOKEN_QUERY, False, Token);\r\n if (not HaveToken) and (GetLastError = ERROR_NO_TOKEN) then\r\n HaveToken := OpenProcessToken(GetCurrentProcess, TOKEN_QUERY, Token);\r\n if HaveToken then\r\n begin\r\n TokenPriv.PrivilegeCount := 1;\r\n TokenPriv.Control := 0;\r\n LookupPrivilegeValue(nil, PChar(Privilege), TokenPriv.Privilege[0].Luid);\r\n Res := False;\r\n Result := PrivilegeCheck(Token, TokenPriv, Res) and Res;\r\n CloseHandle(Token);\r\n end;\r\nend;\r\n\r\nfunction GetPrivilegeDisplayName(const PrivilegeName: string): string;\r\nvar\r\n Count: DWORD;\r\n LangID: DWORD;\r\nbegin\r\n if IsWinNT then\r\n begin\r\n Count := 0;\r\n LangID := LANG_USER_DEFAULT;\r\n\r\n // have the the API function determine the required string length\r\n Result := '';\r\n if not LookupPrivilegeDisplayName(nil, PChar(PrivilegeName), PChar(Result), Count, LangID) then\r\n Count := 256;\r\n SetLength(Result, Count + 1);\r\n\r\n if LookupPrivilegeDisplayName(nil, PChar(PrivilegeName), PChar(Result), Count, LangID) then\r\n StrResetLength(Result)\r\n else\r\n Result := '';\r\n end\r\n else\r\n Result := ''; // Win9x/ME\r\nend;\r\n\r\nfunction SetUserObjectFullAccess(hUserObject: THandle): Boolean;\r\nvar\r\n Sd: PSecurity_Descriptor;\r\n Si: Security_Information;\r\nbegin\r\n Result := not IsWinNT;\r\n if Result then // Win9x/ME\r\n Exit;\r\n { TODO : Check the success of called functions }\r\n Sd := PSecurity_Descriptor(LocalAlloc(LPTR, SECURITY_DESCRIPTOR_MIN_LENGTH));\r\n InitializeSecurityDescriptor(Sd, SECURITY_DESCRIPTOR_REVISION);\r\n SetSecurityDescriptorDacl(Sd, True, nil, False);\r\n\r\n Si := DACL_SECURITY_INFORMATION;\r\n Result := SetUserObjectSecurity(hUserObject, Si, Sd);\r\n\r\n LocalFree(HLOCAL(Sd));\r\nend;\r\n\r\nfunction GetUserObjectName(hUserObject: THandle): string;\r\nvar\r\n Count: DWORD;\r\nbegin\r\n if IsWinNT then\r\n begin\r\n // have the API function determine the required string length\r\n Count := 0;\r\n Result := '';\r\n GetUserObjectInformation(hUserObject, UOI_NAME, PChar(Result), 0, Count);\r\n SetLength(Result, Count + 1);\r\n\r\n if GetUserObjectInformation(hUserObject, UOI_NAME, PChar(Result), Count, Count) then\r\n StrResetLength(Result)\r\n else\r\n Result := '';\r\n end\r\n else\r\n Result := '';\r\nend;\r\n\r\n//=== Account Information ====================================================\r\n\r\nprocedure LookupAccountBySid(Sid: PSID; out Name, Domain: AnsiString; Silent: Boolean);\r\nvar\r\n NameSize, DomainSize: DWORD;\r\n Use: SID_NAME_USE;\r\n Success: Boolean;\r\nbegin\r\n if IsWinNT then\r\n begin\r\n NameSize := 0;\r\n DomainSize := 0;\r\n Use := SidTypeUnknown;\r\n LookupAccountSidA(nil, Sid, nil, NameSize, nil, DomainSize, Use);\r\n if NameSize > 0 then\r\n SetLength(Name, NameSize - 1);\r\n if DomainSize > 0 then\r\n SetLength(Domain, DomainSize - 1);\r\n Success := LookupAccountSidA(nil, Sid, PAnsiChar(Name), NameSize, PAnsiChar(Domain), DomainSize, Use);\r\n if Silent and not Success then\r\n begin\r\n Name := AnsiString(SIDToString(Sid));\r\n Domain := '';\r\n end\r\n else\r\n Win32Check(Success);\r\n end\r\n else\r\n begin // if Win9x, then function return ''\r\n Name := '';\r\n Domain := '';\r\n end;\r\nend;\r\n\r\nprocedure LookupAccountBySid(Sid: PSID; out Name, Domain: WideString; Silent: Boolean);\r\nvar\r\n NameSize, DomainSize: DWORD;\r\n Use: SID_NAME_USE;\r\n Success: Boolean;\r\nbegin\r\n if IsWinNT then\r\n begin\r\n NameSize := 0;\r\n DomainSize := 0;\r\n Use := SidTypeUnknown;\r\n LookupAccountSidW(nil, Sid, nil, NameSize, nil, DomainSize, Use);\r\n if NameSize > 0 then\r\n SetLength(Name, NameSize - 1);\r\n if DomainSize > 0 then\r\n SetLength(Domain, DomainSize - 1);\r\n Success := LookupAccountSidW(nil, Sid, PWideChar(Name), NameSize, PWideChar(Domain), DomainSize, Use);\r\n if Silent and not Success then\r\n begin\r\n Name := WideString(SIDToString(Sid));\r\n Domain := '';\r\n end\r\n else\r\n Win32Check(Success);\r\n end\r\n else\r\n begin\r\n Name := '';\r\n Domain := '';\r\n end;\r\nend;\r\n\r\nprocedure QueryTokenInformation(Token: THandle;\r\n InformationClass: TTokenInformationClass; var Buffer: Pointer);\r\nvar\r\n Ret: BOOL;\r\n Length, LastError: DWORD;\r\nbegin\r\n Buffer := nil;\r\n if not IsWinNT then // Win9x/ME\r\n Exit;\r\n Length := 0;\r\n {$IFDEF FPC}\r\n Ret := GetTokenInformation(Token, InformationClass, Buffer, Length, @Length);\r\n {$ELSE ~FPC}\r\n Ret := GetTokenInformation(Token, InformationClass, Buffer, Length, Length);\r\n {$ENDIF ~FPC}\r\n if (not Ret) and (GetLastError = ERROR_INSUFFICIENT_BUFFER) then\r\n begin\r\n GetMem(Buffer, Length);\r\n {$IFDEF FPC}\r\n Ret := GetTokenInformation(Token, InformationClass, Buffer, Length, @Length);\r\n {$ELSE ~FPC}\r\n Ret := GetTokenInformation(Token, InformationClass, Buffer, Length, Length);\r\n {$ENDIF ~FPC}\r\n if not Ret then\r\n begin\r\n LastError := GetLastError;\r\n FreeTokenInformation(Buffer);\r\n SetLastError(LastError);\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure FreeTokenInformation(var Buffer: Pointer);\r\nbegin\r\n if Buffer <> nil then\r\n FreeMem(Buffer);\r\n Buffer := nil;\r\nend;\r\n\r\nfunction GetInteractiveUserName: string;\r\nvar\r\n Handle: THandle;\r\n Token: THandle;\r\n User: PTokenUser;\r\n {$IFDEF SUPPORTS_UNICODE}\r\n Name, Domain: WideString;\r\n {$ELSE ~SUPPORTS_UNICODE}\r\n Name, Domain: AnsiString;\r\n {$ENDIF ~SUPPORTS_UNICODE}\r\nbegin\r\n Result := '';\r\n if not IsWinNT then // if Win9x, then function return ''\r\n Exit;\r\n Handle := GetShellProcessHandle;\r\n try\r\n Token := 0;\r\n Win32Check(OpenProcessToken(Handle, TOKEN_QUERY, Token));\r\n try\r\n User := nil;\r\n QueryTokenInformation(Token, TokenUser, Pointer(User));\r\n try\r\n LookupAccountBySid(User.User.Sid, Name, Domain);\r\n Result := Domain + '\\' + Name;\r\n finally\r\n FreeMem(User);\r\n end;\r\n finally\r\n CloseHandle(Token);\r\n end;\r\n finally\r\n CloseHandle(Handle);\r\n end;\r\nend;\r\n\r\n//=== SID utilities ==========================================================\r\n\r\nfunction SIDToString(ASID: PSID): string;\r\nvar\r\n SidIdAuthority: PSIDIdentifierAuthority;\r\n SubAuthorities, SidRev, SidSize: DWORD;\r\n Counter: Integer;\r\nbegin\r\n SidRev := SID_REVISION;\r\n\r\n // Validate the binary SID.\r\n if not IsValidSid(ASid) then\r\n Raise EJclSecurityError.CreateRes(@RsInvalidSID);\r\n\r\n // Get the identifier authority value from the SID.\r\n SidIdAuthority := GetSidIdentifierAuthority(ASid);\r\n\r\n // Get the number of subauthorities in the SID.\r\n SubAuthorities := GetSidSubAuthorityCount(ASid)^;\r\n\r\n //Compute the buffer length.\r\n // S-SID_REVISION- + IdentifierAuthority- + subauthorities- + NULL\r\n SidSize := (15 + 12 + (12 * SubAuthorities) + 1) * SizeOf(CHAR);\r\n\r\n SetLength(Result, SidSize+1);\r\n\r\n // Add 'S' prefix and revision number to the string.\r\n Result := Format('S-%u-',[SidRev]);\r\n\r\n // Add SID identifier authority to the string.\r\n if (SidIdAuthority^.Value[0] <> 0) or (SidIdAuthority^.Value[1] <> 0) then\r\n Result := Result + AnsiLowerCase(Format('0x%2.2x%2.2x%2.2x%2.2x%2.2x%2.2x',\r\n [USHORT(SidIdAuthority^.Value[0]),\r\n USHORT(SidIdAuthority^.Value[1]),\r\n USHORT(SidIdAuthority^.Value[2]),\r\n USHORT(SidIdAuthority^.Value[3]),\r\n USHORT(SidIdAuthority^.Value[4]),\r\n USHORT(SidIdAuthority^.Value[5])]))\r\n else\r\n Result := Result + Format('%u',\r\n [ULONG(SidIdAuthority^.Value[5])+\r\n ULONG(SidIdAuthority^.Value[4] shl 8)+\r\n ULONG(SidIdAuthority^.Value[3] shl 16)+\r\n ULONG(SidIdAuthority^.Value[2] shl 24)]);\r\n\r\n // Add SID subauthorities to the string.\r\n for Counter := 0 to SubAuthorities-1 do\r\n Result := Result + Format('-%u',[GetSidSubAuthority(ASid, Counter)^]);\r\nend;\r\n\r\nprocedure StringToSID(const SIDString: String; SID: PSID; cbSID: DWORD);\r\nvar\r\n {$IFDEF FPC} ASID: PSID; {$ELSE} ASID : ^_SID; {$ENDIF}\r\n CurrentPos, TempPos: Integer;\r\n AuthorityValue, RequiredSize: DWORD;\r\n Authority: string;\r\nbegin\r\n if (Length (SIDString) <= 3) or (SIDString [1] <> 'S') or (SIDString [2] <> '-') then\r\n raise EJclSecurityError.CreateRes(@RsInvalidSID);\r\n\r\n RequiredSize := SizeOf(_SID) - SizeOf(DWORD); // _SID.Revision + _SID.SubAuthorityCount + _SID.IdentifierAuthority\r\n if cbSID < RequiredSize then\r\n raise EJclSecurityError.CreateRes(@RsSIDBufferTooSmall);\r\n\r\n ASID := SID; // typecast from opaque structure\r\n\r\n CurrentPos := StrFind('-', SIDString, 3);\r\n if CurrentPos <= 0 then\r\n raise EJclSecurityError.CreateRes(@RsInvalidSID);\r\n ASID^.Revision := StrToInt(Copy(SIDString, 3, CurrentPos - 3));\r\n\r\n Inc(CurrentPos);\r\n TempPos := StrFind('-', SIDString, CurrentPos);\r\n if TempPos = 0 then\r\n Authority := Copy(SIDString, CurrentPos, Length(SIDString) - CurrentPos + 1)\r\n else\r\n Authority := Copy(SIDString, CurrentPos, TempPos - CurrentPos);\r\n\r\n if Length(Authority) < 1 then\r\n raise EJclSecurityError.CreateRes(@RsInvalidSID);\r\n if (Length(Authority) = 14) and (Authority[1] = '0') and (Authority[2] = 'x') then\r\n begin\r\n ASID^.IdentifierAuthority.Value[0] := StrToInt(HexPrefix + Authority[3] + Authority[4]);\r\n ASID^.IdentifierAuthority.Value[1] := StrToInt(HexPrefix + Authority[5] + Authority[6]);\r\n ASID^.IdentifierAuthority.Value[2] := StrToInt(HexPrefix + Authority[7] + Authority[8]);\r\n ASID^.IdentifierAuthority.Value[3] := StrToInt(HexPrefix + Authority[9] + Authority[10]);\r\n ASID^.IdentifierAuthority.Value[4] := StrToInt(HexPrefix + Authority[11] + Authority[12]);\r\n ASID^.IdentifierAuthority.Value[5] := StrToInt(HexPrefix + Authority[13] + Authority[14]);\r\n end\r\n else\r\n begin\r\n ASID^.IdentifierAuthority.Value[0] := 0;\r\n ASID^.IdentifierAuthority.Value[1] := 0;\r\n AuthorityValue := StrToInt(Authority);\r\n ASID^.IdentifierAuthority.Value[2] := (AuthorityValue and $FF000000) shr 24;\r\n ASID^.IdentifierAuthority.Value[3] := (AuthorityValue and $00FF0000) shr 16;\r\n ASID^.IdentifierAuthority.Value[4] := (AuthorityValue and $0000FF00) shr 8;\r\n ASID^.IdentifierAuthority.Value[5] := AuthorityValue and $000000FF;\r\n end;\r\n\r\n CurrentPos := TempPos + 1;\r\n ASID^.SubAuthorityCount := 0;\r\n\r\n while CurrentPos > 1 do\r\n begin\r\n TempPos := StrFind('-', SIDString, CurrentPos);\r\n\r\n Inc(RequiredSize, SizeOf(DWORD)); // _SID.SubAuthority[x]\r\n if cbSID < RequiredSize then\r\n raise EJclSecurityError.CreateRes(@RsSIDBufferTooSmall);\r\n\r\n if TempPos = 0 then\r\n Authority := Copy(SIDString, CurrentPos, Length(SIDString) - CurrentPos + 1)\r\n else\r\n Authority := Copy(SIDString, CurrentPos, TempPos - CurrentPos);\r\n\r\n {$RANGECHECKS OFF}\r\n ASID^.SubAuthority[ASID^.SubAuthorityCount] := StrToInt64(Authority);\r\n {$IFDEF RANGECHECKS_ON}\r\n {$RANGECHECKS ON}\r\n {$ENDIF RANGECHECKS_ON}\r\n Inc(ASID^.SubAuthorityCount);\r\n\r\n CurrentPos := TempPos + 1;\r\n end;\r\nend;\r\n\r\n//=== Computer Information ===================================================\r\n\r\nfunction LsaNTCheck(NTResult: Cardinal) : Cardinal;\r\nvar\r\n WinError: Cardinal;\r\nbegin\r\n Result := NTResult;\r\n if ($C0000000 and Cardinal(NTResult)) = $C0000000 then\r\n begin\r\n WinError := LsaNtStatusToWinError(NTResult);\r\n if WinError <> ERROR_SUCCESS then\r\n raise EJclSecurityError.CreateResFmt(@RsLsaError, [NTResult, SysErrorMessage(WinError)]);\r\n end;\r\nend;\r\n\r\nfunction GetComputerSID(SID: PSID; cbSID: DWORD): Boolean;\r\nvar\r\n ObjectAttributes: TLsaObjectAttributes;\r\n PolicyHandle: TLsaHandle;\r\n Info: PPolicyAccountDomainInfo;\r\nbegin\r\n if IsWinNT then\r\n begin\r\n ZeroMemory(@ObjectAttributes,SizeOf(ObjectAttributes));\r\n\r\n {$IFDEF FPC}\r\n PolicyHandle := 0;\r\n {$ENDIF FPC}\r\n LsaNTCheck(LsaOpenPolicy(nil, // Use local system\r\n ObjectAttributes, //Object attributes.\r\n POLICY_VIEW_LOCAL_INFORMATION, // We're just looking\r\n PolicyHandle)); //Receives the policy handle.\r\n try\r\n Info := nil;\r\n LsaNTCheck(LsaQueryInformationPolicy(PolicyHandle, PolicyAccountDomainInformation,\r\n Pointer(Info)));\r\n try\r\n Result := CopySid(cbSID,SID,Info^.DomainSid);\r\n finally\r\n LsaFreeMemory(Info);\r\n end;\r\n finally\r\n LsaClose(PolicyHandle);\r\n end;\r\n end\r\n else\r\n Result := False; // Win9x\r\nend;\r\n\r\n//=== Windows Vista/Server 2008 UAC (User Account Control) ===================\r\n\r\nfunction IsUACEnabled: Boolean;\r\nbegin\r\n Result := (IsWinVista or IsWinServer2008 or IsWin7 or IsWinServer2008R2) and\r\n RegReadBoolDef(HKLM, '\\Software\\Microsoft\\Windows\\CurrentVersion\\Policies\\System', 'EnableLUA', False);\r\nend;\r\n\r\n// source: Vista elevator from the Code Project\r\nfunction IsElevated: Boolean;\r\nconst\r\n TokenElevation = TTokenInformationClass(20);\r\ntype\r\n TOKEN_ELEVATION = record\r\n TokenIsElevated: DWORD;\r\n end;\r\nvar\r\n TokenHandle: THandle;\r\n ResultLength: Cardinal;\r\n ATokenElevation: TOKEN_ELEVATION;\r\nbegin\r\n if (IsWinVista or IsWinServer2008 or IsWin7 or IsWinServer2008R2) then\r\n begin\r\n TokenHandle := 0;\r\n if OpenProcessToken(GetCurrentProcess, TOKEN_QUERY, TokenHandle) then\r\n begin\r\n try\r\n ResultLength := 0;\r\n if GetTokenInformation(TokenHandle, TokenElevation, @ATokenElevation, SizeOf(ATokenElevation), ResultLength) then\r\n Result := ATokenElevation.TokenIsElevated <> 0\r\n else\r\n Result := False;\r\n finally\r\n CloseHandle(TokenHandle);\r\n end;\r\n end\r\n else\r\n Result := False;\r\n end\r\n else\r\n Result := IsAdministrator;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jcl/source/windows/JclShell.pas", "content": "{**************************************************************************************************}\r\n{ }\r\n{ Project JEDI Code Library (JCL) }\r\n{ }\r\n{ The contents of this file are subject to the Mozilla Public License Version 1.1 (the \"License\"); }\r\n{ you may not use this file except in compliance with the License. You may obtain a copy of the }\r\n{ License at http://www.mozilla.org/MPL/ }\r\n{ }\r\n{ Software distributed under the License is distributed on an \"AS IS\" basis, WITHOUT WARRANTY OF }\r\n{ ANY KIND, either express or implied. See the License for the specific language governing rights }\r\n{ and limitations under the License. }\r\n{ }\r\n{ The Original Code is JclShell.pas. }\r\n{ }\r\n{ The Initial Developers of the Original Code are Marcel van Brakel and Petr Vones. }\r\n{ Portions created by these individuals are Copyright (C) of these individuals. }\r\n{ All Rights Reserved. }\r\n{ }\r\n{ Contributor(s): }\r\n{ Rik Barker (rikbarker) }\r\n{ Marcel van Brakel }\r\n{ Jean-Fabien Connault (cycocrew) }\r\n{ Aleksej Kudinov }\r\n{ Robert Marquardt (marquardt) }\r\n{ Robert Rossmair (rrossmair) }\r\n{ Olivier Sannier (obones) }\r\n{ Matthias Thoma (mthoma) }\r\n{ Petr Vones (pvones) }\r\n{ kogerbnz }\r\n{ Florent Ouchet (outchy) }\r\n{ }\r\n{**************************************************************************************************}\r\n{ }\r\n{ This unit contains routines and classes which makes working with the Windows Shell a bit easier. }\r\n{ Included are routines for working with PIDL's, special folder's, file and folder manipulation }\r\n{ through shell interfaces, shortcut's and program execution. }\r\n{ }\r\n{**************************************************************************************************}\r\n{ }\r\n{ Last modified: $Date:: 2011-09-03 00:07:50 +0200 (sam. 03 sept. 2011) $ }\r\n{ Revision: $Rev:: 3599 $ }\r\n{ Author: $Author:: outchy $ }\r\n{ }\r\n{**************************************************************************************************}\r\n\r\nunit JclShell;\r\n\r\n{$I jcl.inc}\r\n{$I windowsonly.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n {$IFDEF HAS_UNITSCOPE}\r\n Winapi.Windows, System.SysUtils, Winapi.ShlObj,\r\n {$ELSE ~HAS_UNITSCOPE}\r\n Windows, SysUtils, ShlObj,\r\n {$ENDIF ~HAS_UNITSCOPE}\r\n JclBase, JclWin32, JclSysUtils;\r\n\r\n// Files and Folders\r\ntype\r\n TSHDeleteOption = (doSilent, doAllowUndo, doFilesOnly);\r\n TSHDeleteOptions = set of TSHDeleteOption;\r\n TSHRenameOption = (roSilent, roRenameOnCollision);\r\n TSHRenameOptions = set of TSHRenameOption;\r\n TSHCopyOption = (coSilent, coAllowUndo, coFilesOnly, coNoConfirmation);\r\n TSHCopyOptions = set of TSHCopyOption;\r\n TSHMoveOption = (moSilent, moAllowUndo, moFilesOnly, moNoConfirmation);\r\n TSHMoveOptions = set of TSHMoveOption;\r\n\r\nfunction SHDeleteFiles(Parent: THandle; const Files: string; Options: TSHDeleteOptions): Boolean;\r\nfunction SHDeleteFolder(Parent: THandle; const Folder: string; Options: TSHDeleteOptions): Boolean;\r\nfunction SHRenameFile(const Src, Dest: string; Options: TSHRenameOptions): Boolean;\r\nfunction SHCopy(Parent: THandle; const Src, Dest: string; Options: TSHCopyOptions): Boolean;\r\nfunction SHMove(Parent: THandle; const Src, Dest: string; Options: TSHMoveOptions): Boolean;\r\n\r\ntype\r\n TEnumFolderFlag = (efFolders, efNonFolders, efIncludeHidden);\r\n TEnumFolderFlags = set of TEnumFolderFlag;\r\n\r\n TEnumFolderRec = record\r\n DisplayName: string;\r\n Attributes: DWORD;\r\n IconLarge: HICON;\r\n IconSmall: HICON;\r\n Item: PItemIdList;\r\n EnumIdList: IEnumIdList;\r\n Folder: IShellFolder;\r\n end;\r\n\r\nfunction SHEnumFolderFirst(const Folder: string; Flags: TEnumFolderFlags;\r\n var F: TEnumFolderRec): Boolean;\r\nfunction SHEnumSpecialFolderFirst(SpecialFolder: DWORD; Flags: TEnumFolderFlags;\r\n var F: TEnumFolderRec): Boolean;\r\nprocedure SHEnumFolderClose(var F: TEnumFolderRec);\r\nfunction SHEnumFolderNext(var F: TEnumFolderRec): Boolean;\r\n\r\nfunction GetSpecialFolderLocation(const FolderID: Integer): string;\r\n\r\nfunction DisplayPropDialog(const Handle: THandle; const FileName: string): Boolean; overload;\r\nfunction DisplayPropDialog(const Handle: THandle; Item: PItemIdList): Boolean; overload;\r\n\r\nfunction DisplayContextMenuPidl(const Handle: THandle; const Folder: IShellFolder;\r\n Item: PItemIdList; Pos: TPoint): Boolean;\r\nfunction DisplayContextMenu(const Handle: THandle; const FileName: string;\r\n Pos: TPoint): Boolean;\r\n\r\nfunction OpenFolder(const Path: string; Parent: THandle = 0; Explore: Boolean = False): Boolean;\r\nfunction OpenSpecialFolder(FolderID: Integer; Parent: THandle = 0; Explore: Boolean = False): Boolean;\r\n\r\n// Memory Management\r\nfunction SHReallocMem(var P: Pointer; Count: Integer): Boolean;\r\nfunction SHAllocMem(out P: Pointer; Count: Integer): Boolean;\r\nfunction SHGetMem(var P: Pointer; Count: Integer): Boolean;\r\nfunction SHFreeMem(var P: Pointer): Boolean;\r\n\r\n// Paths and PIDLs\r\nfunction DriveToPidlBind(const DriveName: string; out Folder: IShellFolder): PItemIdList;\r\nfunction PathToPidl(const Path: string; Folder: IShellFolder): PItemIdList;\r\nfunction PathToPidlBind(const FileName: string; out Folder: IShellFolder): PItemIdList;\r\nfunction PidlBindToParent(IdList: PItemIdList; out Folder: IShellFolder; out Last: PItemIdList): Boolean;\r\nfunction PidlCompare(Pidl1, Pidl2: PItemIdList): Boolean;\r\nfunction PidlCopy(Source: PItemIdList; out Dest: PItemIdList): Boolean;\r\nfunction PidlFree(var IdList: PItemIdList): Boolean;\r\nfunction PidlGetDepth(Pidl: PItemIdList): Integer;\r\nfunction PidlGetLength(Pidl: PItemIdList): Integer;\r\nfunction PidlGetNext(Pidl: PItemIdList): PItemIdList;\r\nfunction PidlToPath(IdList: PItemIdList): string;\r\n\r\nfunction StrRetFreeMem(StrRet: TStrRet): Boolean;\r\nfunction StrRetToString(IdList: PItemIdList; StrRet: TStrRet; Free: Boolean): string;\r\n\r\n// Shortcuts / Shell link\r\ntype\r\n PShellLink = ^TShellLink;\r\n TShellLink = record\r\n Arguments: string;\r\n ShowCmd: Integer;\r\n WorkingDirectory: string;\r\n IdList: PItemIDList;\r\n Target: string;\r\n Description: string;\r\n IconLocation: string;\r\n IconIndex: Integer;\r\n HotKey: Word;\r\n end;\r\n\r\nprocedure ShellLinkFree(var Link: TShellLink);\r\nfunction ShellLinkResolve(const FileName: string; out Link: TShellLink): HRESULT; overload;\r\nfunction ShellLinkResolve(const FileName: string; out Link: TShellLink;\r\n const ResolveFlags: Cardinal): HRESULT; overload;\r\nfunction ShellLinkCreate(const Link: TShellLink; const FileName: string): HRESULT;\r\nfunction ShellLinkCreateSystem(const Link: TShellLink; const Folder: Integer; const FileName: string): HRESULT;\r\nfunction ShellLinkIcon(const Link: TShellLink): HICON; overload;\r\nfunction ShellLinkIcon(const FileName: string): HICON; overload;\r\n\r\n// Miscellaneous\r\nfunction SHDllGetVersion(const FileName: string; var Version: TDllVersionInfo): Boolean;\r\n\r\nfunction GetSystemIcon(IconIndex: Integer; Flags: Cardinal): HICON;\r\nfunction OverlayIcon(var Icon: HICON; Overlay: HICON; Large: Boolean): Boolean;\r\nfunction OverlayIconShortCut(var Large, Small: HICON): Boolean;\r\nfunction OverlayIconShared(var Large, Small: HICON): Boolean;\r\nfunction SHGetItemInfoTip(const Folder: IShellFolder; Item: PItemIdList): string;\r\n\r\nfunction ShellExecEx(const FileName: string; const Parameters: string = ''; const Verb: string = '';\r\n CmdShow: Integer = SW_SHOWNORMAL): Boolean;\r\nfunction ShellExec(Wnd: Integer; const Operation, FileName, Parameters, Directory: string; ShowCommand: Integer): Boolean;\r\nfunction ShellExecAndWait(const FileName: string; const Parameters: string = ''; const Verb: string = '';\r\n CmdShow: Integer = SW_SHOWNORMAL; const Directory: string = ''): Boolean;\r\n\r\nfunction ShellOpenAs(const FileName: string): Boolean;\r\nfunction ShellRasDial(const EntryName: string): Boolean;\r\nfunction ShellRunControlPanel(const NameOrFileName: string; AppletNumber: Integer = 0): Boolean;\r\n\r\nfunction RunAsAdmin(const FileName: string; const Parameters: string = ''; const Parent: THandle = 0): Boolean;\r\n\r\nfunction GetFileNameIcon(const FileName: string; Flags: Cardinal = 0): HICON;\r\n\r\ntype\r\n TJclFileExeType = (etError, etMsDos, etWin16, etWin32Gui, etWin32Con);\r\n\r\nfunction GetFileExeType(const FileName: TFileName): TJclFileExeType;\r\n\r\nfunction ShellFindExecutable(const FileName, DefaultDir: string): string;\r\n\r\n//MSI functions and types used in ShellLinkResolve - copied from JwaMsi.pas\r\ntype\r\n INSTALLSTATE = Longint;\r\nconst\r\n MSILIB = 'msi.dll';\r\n GetShortcutTargetName = 'MsiGetShortcutTarget' + AWSuffix;\r\n GetComponentPathName = 'MsiGetComponentPath' + AWSuffix;\r\nvar\r\n // MSI.DLL functions can''t be converted to Unicode due to an internal compiler bug (F2084 Internal Error: URW1021)\r\n RtdlMsiLibHandle: TModuleHandle = INVALID_MODULEHANDLE_VALUE;\r\n RtdlMsiGetShortcutTarget: function(szShortcutPath: LPCTSTR; szProductCode: LPTSTR;\r\n szFeatureId: LPTSTR; szComponentCode: LPTSTR): UINT stdcall = nil;\r\n\r\n RtdlMsiGetComponentPath: function(szProduct: LPCTSTR; szComponent: LPCTSTR;\r\n lpPathBuf: LPTSTR; pcchBuf: LPDWORD): INSTALLSTATE stdcall = nil;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jcl.svn.sourceforge.net/svnroot/jcl/tags/JCL-2.4-Build4571/jcl/source/windows/JclShell.pas $';\r\n Revision: '$Revision: 3599 $';\r\n Date: '$Date: 2011-09-03 00:07:50 +0200 (sam. 03 sept. 2011) $';\r\n LogPath: 'JCL\\source\\windows';\r\n Extra: '';\r\n Data: nil\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n {$IFDEF HAS_UNITSCOPE}\r\n Winapi.ActiveX, Winapi.CommCtrl, Winapi.Messages, Winapi.ShellAPI,\r\n {$ELSE ~HAS_UNITSCOPE}\r\n ActiveX, CommCtrl, Messages, ShellAPI,\r\n {$ENDIF ~HAS_UNITSCOPE}\r\n JclFileUtils, JclStrings, JclSysInfo;\r\n\r\ntype\r\n TWidePath = array [0..MAX_PATH-1] of WideChar;\r\n {$IFDEF SUPPORTS_UNICODE}\r\n TWidePathPtr = PWideChar;\r\n {$ELSE ~SUPPORTS_UNICODE}\r\n TWidePathPtr = TWidePath;\r\n {$ENDIF ~SUPPORTS_UNICODE}\r\n\r\nconst\r\n cVerbProperties = 'properties';\r\n cVerbOpen = 'open';\r\n cVerbExplore = 'explore';\r\n cVerbRunas = 'runas';\r\n\r\n//=== Files and Folders ======================================================\r\n\r\n// Helper function and constant to map a TSHDeleteOptions set to a Cardinal\r\n\r\nconst\r\n FOF_COMPLETELYSILENT = FOF_SILENT or FOF_NOCONFIRMATION or FOF_NOERRORUI or FOF_NOCONFIRMMKDIR;\r\n\r\nfunction DeleteOptionsToCardinal(Options: TSHDeleteOptions): Cardinal;\r\nbegin\r\n Result := 0;\r\n if doSilent in Options then\r\n Result := Result or FOF_COMPLETELYSILENT;\r\n if doAllowUndo in Options then\r\n Result := Result or FOF_ALLOWUNDO;\r\n if doFilesOnly in Options then\r\n Result := Result or FOF_FILESONLY;\r\nend;\r\n\r\nfunction SHDeleteFiles(Parent: THandle; const Files: string;\r\n Options: TSHDeleteOptions): Boolean;\r\nvar\r\n FileOp: TSHFileOpStruct;\r\n Source: string;\r\nbegin\r\n ResetMemory(FileOp, SizeOf(FileOp));\r\n with FileOp do\r\n begin\r\n Wnd := Parent;\r\n wFunc := FO_DELETE;\r\n Source := Files + #0#0;\r\n pFrom := PChar(Source);\r\n fFlags := DeleteOptionsToCardinal(Options);\r\n end;\r\n Result := SHFileOperation(FileOp) = 0;\r\nend;\r\n\r\nfunction SHDeleteFolder(Parent: THandle; const Folder: string;\r\n Options: TSHDeleteOptions): Boolean;\r\nbegin\r\n Exclude(Options, doFilesOnly);\r\n Result := SHDeleteFiles(Parent, PathAddSeparator(Folder) + '*.*', Options);\r\n if Result then\r\n Result := SHDeleteFiles(Parent, PathRemoveSeparator(Folder), Options);\r\nend;\r\n\r\n// Helper function to map a TSHRenameOptions set to a cardinal\r\n\r\nfunction RenameOptionsToCardinal(Options: TSHRenameOptions): Cardinal;\r\nbegin\r\n Result := 0;\r\n if roRenameOnCollision in Options then\r\n Result := Result or FOF_RENAMEONCOLLISION;\r\n if roSilent in Options then\r\n Result := Result or FOF_COMPLETELYSILENT;\r\nend;\r\n\r\nfunction SHRenameFile(const Src, Dest: string; Options: TSHRenameOptions): Boolean;\r\nvar\r\n FileOp: TSHFileOpStruct;\r\n Source, Destination: string;\r\nbegin\r\n ResetMemory(FileOp, SizeOf(FileOp));\r\n with FileOp do\r\n begin\r\n Wnd := GetDesktopWindow;\r\n wFunc := FO_RENAME;\r\n Source := Src + #0#0;\r\n Destination := Dest + #0#0;\r\n pFrom := PChar(Source);\r\n pTo := PChar(Destination);\r\n fFlags := RenameOptionsToCardinal(Options);\r\n end;\r\n Result := SHFileOperation(FileOp) = 0;\r\nend;\r\n\r\nfunction CopyOptionsToCardinal(Options: TSHCopyOptions): Cardinal;\r\nbegin\r\n Result := 0;\r\n if coSilent in Options then\r\n Result := Result or FOF_SILENT;\r\n if coAllowUndo in Options then\r\n Result := Result or FOF_ALLOWUNDO;\r\n if coFilesOnly in Options then\r\n Result := Result or FOF_FILESONLY;\r\n if coNoConfirmation in Options then\r\n Result := Result or FOF_NOCONFIRMATION or FOF_NOCONFIRMMKDIR;\r\nend;\r\n\r\nfunction SHCopy(Parent: THandle; const Src, Dest: string; Options: TSHCopyOptions): Boolean;\r\nvar\r\n FileOp: TSHFileOpStruct;\r\n Source, Destination: string;\r\nbegin\r\n ResetMemory(FileOp, SizeOf(FileOp));\r\n FileOp.Wnd := Parent;\r\n FileOp.wFunc := FO_COPY;\r\n Source := Src + #0#0;\r\n Destination := Dest + #0#0;\r\n FileOp.pFrom := PChar(Source);\r\n FileOp.pTo := PChar(Destination);\r\n FileOp.fFlags := CopyOptionsToCardinal(Options);\r\n Result := SHFileOperation(FileOp) = 0;\r\nend;\r\n\r\nfunction MoveOptionsToCardinal(Options: TSHMoveOptions): Cardinal;\r\nbegin\r\n Result := 0;\r\n if moSilent in Options then\r\n Result := Result or FOF_SILENT;\r\n if moAllowUndo in Options then\r\n Result := Result or FOF_ALLOWUNDO;\r\n if moFilesOnly in Options then\r\n Result := Result or FOF_FILESONLY;\r\n if moNoConfirmation in Options then\r\n Result := Result or FOF_NOCONFIRMATION;\r\nend;\r\n\r\nfunction SHMove(Parent: THandle; const Src, Dest: string; Options: TSHMoveOptions): Boolean;\r\nvar\r\n FileOp: TSHFileOpStruct;\r\n Source, Destination: string;\r\nbegin\r\n ResetMemory(FileOp, SizeOf(FileOp));\r\n FileOp.Wnd := Parent;\r\n FileOp.wFunc := FO_MOVE;\r\n Source := Src + #0#0;\r\n Destination := Dest + #0#0;\r\n FileOp.pFrom := PChar(Source);\r\n FileOp.pTo := PChar(Destination);\r\n FileOp.fFlags := MoveOptionsToCardinal(Options);\r\n Result := SHFileOperation(FileOp) = 0;\r\nend;\r\n\r\nfunction EnumFolderFlagsToCardinal(Flags: TEnumFolderFlags): Cardinal;\r\nbegin\r\n Result := 0;\r\n if efFolders in Flags then\r\n Result := Result or SHCONTF_FOLDERS;\r\n if efNonFolders in Flags then\r\n Result := Result or SHCONTF_NONFOLDERS;\r\n if efIncludeHidden in Flags then\r\n Result := Result or SHCONTF_INCLUDEHIDDEN;\r\nend;\r\n\r\nprocedure ClearEnumFolderRec(var F: TEnumFolderRec; const Free, Release: Boolean);\r\nbegin\r\n if Release then\r\n begin\r\n F.EnumIdList := nil;\r\n F.Folder := nil;\r\n end;\r\n if Free then\r\n begin\r\n PidlFree(F.Item);\r\n DestroyIcon(F.IconLarge);\r\n DestroyIcon(F.IconSmall);\r\n end;\r\n F.Attributes := 0;\r\n F.Item := nil;\r\n F.IconLarge := 0;\r\n F.IconSmall := 0;\r\nend;\r\n\r\nprocedure SHEnumFolderClose(var F: TEnumFolderRec);\r\nbegin\r\n ClearEnumFolderRec(F, True, True);\r\nend;\r\n\r\nfunction SHEnumFolderNext(var F: TEnumFolderRec): Boolean;\r\nconst\r\n Attr = Cardinal(SFGAO_CAPABILITYMASK or SFGAO_DISPLAYATTRMASK or SFGAO_CONTENTSMASK);\r\nvar\r\n DisplayNameRet: TStrRet;\r\n ItemsFetched: ULONG;\r\n ExtractIcon: IExtractIcon;\r\n IconFile: TWidePath;\r\n IconIndex: Integer;\r\n Flags: DWORD;\r\nbegin\r\n Result := False;\r\n ClearEnumFolderRec(F, True, False);\r\n if (F.EnumIdList = nil) or (F.Folder = nil) then\r\n Exit;\r\n ItemsFetched := 0;\r\n if F.EnumIdList.Next(1, F.Item, ItemsFetched) = NO_ERROR then\r\n begin\r\n DisplayNameRet.utype := 0;\r\n F.Folder.GetDisplayNameOf(F.Item, SHGDN_INFOLDER, DisplayNameRet);\r\n F.DisplayName := StrRetToString(F.Item, DisplayNameRet, True);\r\n F.Attributes := Attr;\r\n F.Folder.GetAttributesOf(1, F.Item, F.Attributes);\r\n F.Folder.GetUIObjectOf(0, 1, F.Item, IID_IExtractIconW, nil,\r\n Pointer(ExtractIcon));\r\n Flags := 0;\r\n F.IconLarge := 0;\r\n F.IconSmall := 0;\r\n \r\n if Assigned(ExtractIcon) then\r\n begin\r\n IconIndex := 0;\r\n ExtractIcon.GetIconLocation(0, @IconFile, MAX_PATH, IconIndex, Flags);\r\n if (IconIndex < 0) or ((Flags and GIL_NOTFILENAME) = 0) then\r\n ExtractIconEx(@IconFile, IconIndex, F.IconLarge, F.IconSmall, 1)\r\n else\r\n ExtractIcon.Extract(@IconFile, IconIndex, F.IconLarge, F.IconSmall,\r\n MakeLong(32, 16));\r\n end;\r\n \r\n Result := True;\r\n end;\r\nend;\r\n\r\nfunction SHEnumSpecialFolderFirst(SpecialFolder: DWORD; Flags: TEnumFolderFlags;\r\n var F: TEnumFolderRec): Boolean;\r\nvar\r\n DesktopFolder: IShellFolder;\r\n FolderPidl: PItemIdList;\r\nbegin\r\n ClearEnumFolderRec(F, False, False);\r\n Result := Succeeded(SHGetDesktopFolder(DesktopFolder));\r\n if Result then\r\n begin\r\n if SpecialFolder = CSIDL_DESKTOP then\r\n F.Folder := DesktopFolder\r\n else\r\n begin\r\n Result := Succeeded(SHGetSpecialFolderLocation(0, SpecialFolder, FolderPidl));\r\n if Result then\r\n begin\r\n try\r\n Result := Succeeded(DesktopFolder.BindToObject(FolderPidl, nil, IID_IShellFolder, Pointer(F.Folder)));\r\n finally\r\n CoTaskMemFree(FolderPidl);\r\n end;\r\n end;\r\n end;\r\n end;\r\n if Result then\r\n begin\r\n F.Folder.EnumObjects(0, EnumFolderFlagsToCardinal(Flags), F.EnumIdList);\r\n Result := SHEnumFolderNext(F);\r\n if not Result then\r\n SHEnumFolderClose(F);\r\n end;\r\nend;\r\n\r\nfunction SHEnumFolderFirst(const Folder: string; Flags: TEnumFolderFlags;\r\n var F: TEnumFolderRec): Boolean;\r\nvar\r\n DesktopFolder: IShellFolder;\r\n FolderPidl: PItemIdList;\r\nbegin\r\n ClearEnumFolderRec(F, False, False);\r\n SHGetDesktopFolder(DesktopFolder);\r\n FolderPidl := PathToPidl(PathAddSeparator(Folder), DesktopFolder);\r\n try\r\n DesktopFolder.BindToObject(FolderPidl, nil, IID_IShellFolder, Pointer(F.Folder));\r\n F.Folder.EnumObjects(0, EnumFolderFlagsToCardinal(Flags), F.EnumIdList);\r\n Result := SHEnumFolderNext(F);\r\n if not Result then\r\n SHEnumFolderClose(F);\r\n finally\r\n PidlFree(FolderPidl);\r\n end;\r\nend;\r\n\r\nfunction GetSpecialFolderLocation(const FolderID: Integer): string;\r\nvar\r\n FolderPidl: PItemIdList;\r\nbegin\r\n if Succeeded(SHGetSpecialFolderLocation(0, FolderID, FolderPidl)) then\r\n begin\r\n Result := PidlToPath(FolderPidl);\r\n CoTaskMemFree(FolderPidl);\r\n end\r\n else\r\n Result := '';\r\nend;\r\n\r\nfunction DisplayPropDialog(const Handle: THandle; const FileName: string): Boolean;\r\nvar\r\n Info: TShellExecuteInfo;\r\nbegin\r\n ResetMemory(Info, SizeOf(Info));\r\n with Info do\r\n begin\r\n cbSize := SizeOf(Info);\r\n lpFile := PChar(FileName);\r\n nShow := SW_SHOW;\r\n fMask := SEE_MASK_INVOKEIDLIST;\r\n Wnd := Handle;\r\n lpVerb := cVerbProperties;\r\n end;\r\n {$TYPEDADDRESS ON} // need this because ShellExecuteEx is overloaded in FPC -A -W\r\n Result := ShellExecuteEx(@Info);\r\n {$IFNDEF TYPEDADDRESS_ON}\r\n {$TYPEDADDRESS OFF}\r\n {$ENDIF ~TYPEDADDRESS_ON}\r\nend;\r\n\r\nfunction DisplayPropDialog(const Handle: THandle; Item: PItemIdList): Boolean;\r\nvar\r\n Info: TShellExecuteInfo;\r\nbegin\r\n ResetMemory(Info, SizeOf(Info));\r\n with Info do\r\n begin\r\n cbSize := SizeOf(Info);\r\n nShow := SW_SHOW;\r\n lpIDList := Item;\r\n fMask := SEE_MASK_INVOKEIDLIST or SEE_MASK_IDLIST;\r\n Wnd := Handle;\r\n lpVerb := cVerbProperties;\r\n end;\r\n {$TYPEDADDRESS ON}\r\n Result := ShellExecuteEx(@Info);\r\n {$IFNDEF TYPEDADDRESS_ON}\r\n {$TYPEDADDRESS OFF}\r\n {$ENDIF ~TYPEDADDRESS_ON}\r\nend;\r\n\r\n// Window procedure for the callback window created by DisplayContextMenu.\r\n// It simply forwards messages to the folder. If you don't do this then the\r\n// system created submenu's will be empty (except for 1 stub item!)\r\n// note: storing the IContextMenu2 pointer in the window's user data was\r\n// 'inspired' by (read: copied from) code by Brad Stowers.\r\n\r\nfunction MenuCallback(Wnd: THandle; Msg: UINT; wParam: WPARAM; lParam: LPARAM): LRESULT; stdcall;\r\nvar\r\n ContextMenu2: IContextMenu2;\r\nbegin\r\n case Msg of\r\n WM_CREATE:\r\n begin\r\n ContextMenu2 := IContextMenu2(PCreateStruct(lParam).lpCreateParams);\r\n SetWindowLongPtr(Wnd, GWLP_USERDATA, LONG_PTR(ContextMenu2));\r\n Result := DefWindowProc(Wnd, Msg, wParam, lParam);\r\n end;\r\n WM_INITMENUPOPUP:\r\n begin\r\n ContextMenu2 := IContextMenu2(GetWindowLongPtr(Wnd, GWLP_USERDATA));\r\n ContextMenu2.HandleMenuMsg(Msg, wParam, lParam);\r\n Result := 0;\r\n end;\r\n WM_DRAWITEM, WM_MEASUREITEM:\r\n begin\r\n ContextMenu2 := IContextMenu2(GetWindowLongPtr(Wnd, GWLP_USERDATA));\r\n ContextMenu2.HandleMenuMsg(Msg, wParam, lParam);\r\n Result := 1;\r\n end;\r\n else\r\n Result := DefWindowProc(Wnd, Msg, wParam, lParam);\r\n end;\r\nend;\r\n\r\n// Helper function for DisplayContextMenu, creates the callback window.\r\n\r\nfunction CreateMenuCallbackWnd(const ContextMenu: IContextMenu2): THandle;\r\nconst\r\n IcmCallbackWnd = 'ICMCALLBACKWND';\r\nvar\r\n WndClass: TWndClass;\r\nbegin\r\n ResetMemory(WndClass, SizeOf(WndClass));\r\n WndClass.lpszClassName := PChar(IcmCallbackWnd);\r\n WndClass.lpfnWndProc := @MenuCallback;\r\n WndClass.hInstance := HInstance;\r\n {$IFDEF HAS_UNITSCOPE}Winapi.{$ENDIF}Windows.RegisterClass(WndClass);\r\n Result := CreateWindow(IcmCallbackWnd, IcmCallbackWnd, WS_POPUPWINDOW, 0,\r\n 0, 0, 0, 0, 0, HInstance, Pointer(ContextMenu));\r\nend;\r\n\r\nfunction DisplayContextMenuPidl(const Handle: THandle; const Folder: IShellFolder;\r\n Item: PItemIdList; Pos: TPoint): Boolean;\r\nvar\r\n Cmd: Cardinal;\r\n ContextMenu: IContextMenu;\r\n ContextMenu2: IContextMenu2;\r\n Menu: HMENU;\r\n CommandInfo: TCMInvokeCommandInfo;\r\n CallbackWindow: THandle;\r\nbegin\r\n Result := False;\r\n if (Item = nil) or (Folder = nil) then\r\n Exit;\r\n Folder.GetUIObjectOf(Handle, 1, Item, IID_IContextMenu, nil,\r\n Pointer(ContextMenu));\r\n if ContextMenu <> nil then\r\n begin\r\n Menu := CreatePopupMenu;\r\n if Menu <> 0 then\r\n begin\r\n if Succeeded(ContextMenu.QueryContextMenu(Menu, 0, 1, $7FFF, CMF_EXPLORE)) then\r\n begin\r\n CallbackWindow := 0;\r\n if Succeeded(ContextMenu.QueryInterface(IContextMenu2, ContextMenu2)) then\r\n begin\r\n CallbackWindow := CreateMenuCallbackWnd(ContextMenu2);\r\n end;\r\n ClientToScreen(Handle, Pos);\r\n Cmd := Cardinal(TrackPopupMenu(Menu, TPM_LEFTALIGN or TPM_LEFTBUTTON or\r\n TPM_RIGHTBUTTON or TPM_RETURNCMD, Pos.X, Pos.Y, 0, CallbackWindow, nil));\r\n if Cmd <> 0 then\r\n begin\r\n ResetMemory(CommandInfo, SizeOf(CommandInfo));\r\n CommandInfo.cbSize := SizeOf(TCMInvokeCommandInfo);\r\n CommandInfo.hwnd := Handle;\r\n CommandInfo.lpVerb := MakeIntResourceA(Cmd - 1);\r\n CommandInfo.nShow := SW_SHOWNORMAL;\r\n Result := Succeeded(ContextMenu.InvokeCommand(CommandInfo));\r\n end;\r\n if CallbackWindow <> 0 then\r\n DestroyWindow(CallbackWindow);\r\n end;\r\n DestroyMenu(Menu);\r\n end;\r\n end;\r\nend;\r\n\r\nfunction DisplayContextMenu(const Handle: THandle; const FileName: string;\r\n Pos: TPoint): Boolean;\r\nvar\r\n ItemIdList: PItemIdList;\r\n Folder: IShellFolder;\r\nbegin\r\n Result := False;\r\n ItemIdList := PathToPidlBind(FileName, Folder);\r\n if ItemIdList <> nil then\r\n begin\r\n Result := DisplayContextMenuPidl(Handle, Folder, ItemIdList, Pos);\r\n PidlFree(ItemIdList);\r\n end;\r\nend;\r\n\r\nfunction OpenFolder(const Path: string; Parent: THandle; Explore: Boolean): Boolean;\r\nvar\r\n Sei: TShellExecuteInfo;\r\nbegin\r\n Result := False;\r\n if IsDirectory(Path) then\r\n begin\r\n ResetMemory(Sei, SizeOf(Sei));\r\n with Sei do\r\n begin\r\n cbSize := SizeOf(Sei);\r\n Wnd := Parent;\r\n if Explore then\r\n lpVerb := cVerbExplore\r\n else\r\n lpVerb := cVerbOpen;\r\n lpFile := PChar(Path);\r\n nShow := SW_SHOWNORMAL;\r\n end;\r\n {$TYPEDADDRESS ON}\r\n Result := ShellExecuteEx(@Sei);\r\n {$IFNDEF TYPEDADDRESS_ON}\r\n {$TYPEDADDRESS OFF}\r\n {$ENDIF ~TYPEDADDRESS_ON}\r\n end;\r\nend;\r\n\r\nfunction OpenSpecialFolder(FolderID: Integer; Parent: THandle; Explore: Boolean): Boolean;\r\nvar\r\n Pidl: PItemIDList;\r\n Sei: TShellExecuteInfo;\r\nbegin\r\n Result := False;\r\n if Succeeded(SHGetSpecialFolderLocation(Parent, FolderID, Pidl)) then\r\n begin\r\n ResetMemory(Sei, SizeOf(Sei));\r\n with Sei do\r\n begin\r\n cbSize := SizeOf(Sei);\r\n Wnd := Parent;\r\n fMask := SEE_MASK_INVOKEIDLIST;\r\n if Explore then\r\n lpVerb := cVerbExplore\r\n else\r\n lpVerb := cVerbOpen;\r\n lpIDList := Pidl;\r\n nShow := SW_SHOWNORMAL;\r\n if PidlToPath(Pidl) = '' then\r\n begin\r\n fMask := SEE_MASK_INVOKEIDLIST;\r\n lpIDList := Pidl;\r\n end\r\n else\r\n lpFile := PChar(PidlToPath(Pidl));\r\n end;\r\n {$TYPEDADDRESS ON}\r\n Result := ShellExecuteEx(@Sei);\r\n {$IFNDEF TYPEDADDRESS_ON}\r\n {$TYPEDADDRESS OFF}\r\n {$ENDIF ~TYPEDADDRESS_ON}\r\n CoTaskMemFree(Pidl);\r\n end;\r\nend;\r\n\r\n//=== Memory Management ======================================================\r\n\r\nfunction SHAllocMem(out P: Pointer; Count: Integer): Boolean;\r\nvar\r\n Malloc: IMalloc;\r\nbegin\r\n Result := False;\r\n P := nil;\r\n if Succeeded(SHGetMalloc(Malloc)) then\r\n begin\r\n P := Malloc.Alloc(Count);\r\n if P <> nil then\r\n begin\r\n ResetMemory(P^, Count);\r\n Result := True;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction SHFreeMem(var P: Pointer): Boolean;\r\nvar\r\n Malloc: IMalloc;\r\nbegin\r\n Result := False;\r\n if P <> nil then\r\n begin\r\n if Succeeded(SHGetMalloc(Malloc)) and (Malloc.DidAlloc(P) > 0) then\r\n begin\r\n Malloc.Free(P);\r\n P := nil;\r\n Result := True;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction SHGetMem(var P: Pointer; Count: Integer): Boolean;\r\nvar\r\n Malloc: IMalloc;\r\nbegin\r\n Result := False;\r\n if Succeeded(SHGetMalloc(Malloc)) then\r\n begin\r\n P := Malloc.Alloc(Count);\r\n if P <> nil then\r\n Result := True;\r\n end;\r\nend;\r\n\r\nfunction SHReallocMem(var P: Pointer; Count: Integer): Boolean;\r\nvar\r\n Malloc: IMalloc;\r\nbegin\r\n Result := False;\r\n if Succeeded(SHGetMalloc(Malloc)) then\r\n begin\r\n if (P <> nil) and (Malloc.DidAlloc(P) <= 0) then\r\n Exit;\r\n P := Malloc.ReAlloc(P, Count);\r\n Result := (P <> nil) or (Count = 0);\r\n end;\r\nend;\r\n\r\n//=== Paths and PIDLs ========================================================\r\n\r\nfunction DriveToPidlBind(const DriveName: string; out Folder: IShellFolder): PItemIdList;\r\nvar\r\n Attr: ULONG;\r\n Eaten: ULONG;\r\n DesktopFolder: IShellFolder;\r\n Drives: PItemIdList;\r\n Path: TWidePathPtr;\r\nbegin\r\n Result := nil;\r\n if Succeeded(SHGetDesktopFolder(DesktopFolder)) then\r\n begin\r\n if Succeeded(SHGetSpecialFolderLocation(0, CSIDL_DRIVES, Drives)) then\r\n begin\r\n if Succeeded(DesktopFolder.BindToObject(Drives, nil, IID_IShellFolder,\r\n Pointer(Folder))) then\r\n begin\r\n {$IFDEF SUPPORTS_UNICODE}\r\n Path := PChar(PathAddSeparator(DriveName));\r\n {$ELSE ~SUPPORTS_UNICODE}\r\n MultiByteToWideChar(CP_ACP, MB_PRECOMPOSED, PAnsiChar(PathAddSeparator(DriveName)), -1, Path, MAX_PATH);\r\n {$ENDIF ~SUPPORTS_UNICODE}\r\n Attr := 0;\r\n if Failed(Folder.ParseDisplayName(0, nil, Path, Eaten, Result, Attr)) then\r\n begin\r\n Folder := nil;\r\n // Failure probably means that this is not a drive. However, do not\r\n // call PathToPidlBind() because it may cause infinite recursion.\r\n end;\r\n end;\r\n end;\r\n CoTaskMemFree(Drives);\r\n end;\r\nend;\r\n\r\nfunction PathToPidl(const Path: string; Folder: IShellFolder): PItemIdList;\r\nvar\r\n DesktopFolder: IShellFolder;\r\n CharsParsed, Attr: ULONG;\r\n WidePath: TWidePathPtr;\r\nbegin\r\n Result := nil;\r\n {$IFDEF SUPPORTS_UNICODE}\r\n WidePath := PChar(Path);\r\n {$ELSE ~SUPPORTS_UNICODE}\r\n MultiByteToWideChar(CP_ACP, MB_PRECOMPOSED, PAnsiChar(Path), -1, WidePath, MAX_PATH);\r\n {$ENDIF ~SUPPORTS_UNICODE}\r\n Attr := 0;\r\n if Folder <> nil then\r\n Folder.ParseDisplayName(0, nil, WidePath, CharsParsed, Result, Attr)\r\n else\r\n if Succeeded(SHGetDesktopFolder(DesktopFolder)) then\r\n DesktopFolder.ParseDisplayName(0, nil, WidePath, CharsParsed, Result, Attr);\r\nend;\r\n\r\nfunction PathToPidlBind(const FileName: string; out Folder: IShellFolder): PItemIdList;\r\nvar\r\n Attr, Eaten: ULONG;\r\n PathIdList: PItemIdList;\r\n DesktopFolder: IShellFolder;\r\n Path, ItemName: TWidePathPtr;\r\nbegin\r\n Result := nil;\r\n {$IFDEF SUPPORTS_UNICODE}\r\n Path := PChar(ExtractFilePath(FileName));\r\n ItemName := PChar(ExtractFileName(FileName));\r\n {$ELSE ~SUPPORTS_UNICODE}\r\n MultiByteToWideChar(CP_ACP, MB_PRECOMPOSED, PAnsiChar(ExtractFilePath(FileName)), -1, Path, MAX_PATH);\r\n MultiByteToWideChar(CP_ACP, MB_PRECOMPOSED, PAnsiChar(ExtractFileName(FileName)), -1, ItemName, MAX_PATH);\r\n {$ENDIF ~SUPPORTS_UNICODE}\r\n if Succeeded(SHGetDesktopFolder(DesktopFolder)) then\r\n begin\r\n Attr := 0;\r\n if Succeeded(DesktopFolder.ParseDisplayName(0, nil, Path, Eaten, PathIdList,\r\n Attr)) then\r\n begin\r\n if Succeeded(DesktopFolder.BindToObject(PathIdList, nil, IID_IShellFolder,\r\n Pointer(Folder))) then\r\n begin\r\n if Failed(Folder.ParseDisplayName(0, nil, ItemName, Eaten, Result, Attr)) then\r\n begin\r\n Folder := nil;\r\n Result := DriveToPidlBind(FileName, Folder);\r\n end;\r\n end;\r\n PidlFree(PathIdList);\r\n end\r\n else\r\n Result := DriveToPidlBind(FileName, Folder);\r\n end;\r\nend;\r\n\r\nfunction PidlBindToParent(IdList: PItemIdList; out Folder: IShellFolder; out Last: PItemIdList): Boolean;\r\nvar\r\n Path: string;\r\nbegin\r\n Last := nil;\r\n Path := PidlToPath(IdList);\r\n Last := PathToPidlBind(Path, Folder);\r\n Result := Last <> nil;\r\n if Last = nil then\r\n Folder := nil;\r\nend;\r\n\r\nfunction PidlCompare(Pidl1, Pidl2: PItemIdList): Boolean;\r\nvar\r\n L: Integer;\r\nbegin\r\n Result := False;\r\n L := PidlGetLength(Pidl1);\r\n if L = PidlGetLength(Pidl2) then\r\n Result := CompareMem(Pidl1, Pidl2, L);\r\nend;\r\n\r\nfunction PidlCopy(Source: PItemIdList; out Dest: PItemIdList): Boolean;\r\nvar\r\n L: Integer;\r\nbegin\r\n Result := False;\r\n Dest := Source;\r\n if Source <> nil then\r\n begin\r\n L := PidlGetLength(Source) + 2;\r\n if SHAllocMem(Pointer(Dest), L) then\r\n begin\r\n Move(Source^, Dest^, L);\r\n Result := True;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction PidlFree(var IdList: PItemIdList): Boolean;\r\nvar\r\n Malloc: IMalloc;\r\nbegin\r\n Result := False;\r\n if IdList = nil then\r\n Result := True\r\n else\r\n begin\r\n Malloc := nil;\r\n if Succeeded(SHGetMalloc(Malloc)) and (Malloc.DidAlloc(IdList) > 0) then\r\n begin\r\n Malloc.Free(IdList);\r\n IdList := nil;\r\n Result := True;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction PidlGetDepth(Pidl: PItemIdList): Integer;\r\nvar\r\n P: PItemIdList;\r\nbegin\r\n Result := 0;\r\n if Pidl <> nil then\r\n begin\r\n P := Pidl;\r\n while (P^.mkId.cb <> 0) and (Result < MAX_PATH) do\r\n begin\r\n Inc(Result);\r\n P := PItemIdList(@P^.mkId.abID[P^.mkId.cb - 2]);\r\n end;\r\n end;\r\n if Result = MAX_PATH then\r\n Result := -1;\r\nend;\r\n\r\nfunction PidlGetLength(Pidl: PItemIdList): Integer;\r\nvar\r\n P: PItemIdList;\r\n I: Integer;\r\nbegin\r\n Result := 0;\r\n if Pidl <> nil then\r\n begin\r\n I := 0;\r\n P := Pidl;\r\n while (P^.mkId.cb <> 0) and (I < MAX_PATH) do\r\n begin\r\n Inc(I);\r\n Inc(Result, P^.mkId.cb);\r\n P := PItemIdList(@P^.mkId.abID[P^.mkId.cb - 2]);\r\n end;\r\n if I = MAX_PATH then\r\n Result := -1;\r\n end;\r\nend;\r\n\r\nfunction PidlGetNext(Pidl: PItemIdList): PItemIdList;\r\nbegin\r\n Result := nil;\r\n if (Pidl <> nil) and (Pidl^.mkid.cb <> 0) then\r\n begin\r\n Result := PItemIdList(@Pidl^.mkId.abID[Pidl^.mkId.cb - 2]);\r\n if Result^.mkid.cb = 0 then\r\n Result := nil;\r\n end;\r\nend;\r\n\r\nfunction PidlToPath(IdList: PItemIdList): string;\r\nbegin\r\n SetLength(Result, MAX_PATH);\r\n if SHGetPathFromIdList(IdList, PChar(Result)) then\r\n StrResetLength(Result)\r\n else\r\n Result := '';\r\nend;\r\n\r\nfunction StrRetFreeMem(StrRet: TStrRet): Boolean;\r\nbegin\r\n Result := False;\r\n if StrRet.uType = STRRET_WSTR then\r\n Result := SHFreeMem(Pointer(StrRet.pOleStr));\r\nend;\r\n\r\nfunction StrRetToString(IdList: PItemIdList; StrRet: TStrRet; Free: Boolean): string;\r\nbegin\r\n case StrRet.uType of\r\n STRRET_WSTR:\r\n begin\r\n Result := WideCharToString(StrRet.pOleStr);\r\n if Free then\r\n SHFreeMem(Pointer(StrRet.pOleStr));\r\n end;\r\n STRRET_OFFSET:\r\n if IdList <> nil then\r\n Result := PChar(IdList) + StrRet.uOffset\r\n else\r\n Result := '';\r\n STRRET_CSTR:\r\n Result := string(AnsiString(StrRet.cStr));\r\n else\r\n Result := '';\r\n end;\r\nend;\r\n\r\n//=== ShortCuts / Shell link =================================================\r\n\r\nprocedure ShellLinkFree(var Link: TShellLink);\r\nbegin\r\n PidlFree(Link.IdList);\r\nend;\r\n\r\nconst\r\n {$IFDEF SUPPORTS_UNICODE}\r\n IID_IShellLink: TGUID = { IID_IShellLinkW }\r\n (D1:$000214F9; D2:$0000; D3:$0000; D4:($C0,$00,$00,$00,$00,$00,$00,$46));\r\n {$ELSE ~SUPPORTS_UNICODE}\r\n IID_IShellLink: TGUID = { IID_IShellLinkA }\r\n (D1:$000214EE; D2:$0000; D3:$0000; D4:($C0,$00,$00,$00,$00,$00,$00,$46));\r\n {$ENDIF ~SUPPORTS_UNICODE}\r\n\r\nfunction ShellLinkCreateSystem(const Link: TShellLink; const Folder: Integer;\r\n const FileName: string): HRESULT;\r\nvar\r\n Path: string;\r\n Pidl: PItemIDList;\r\nbegin\r\n Result := E_INVALIDARG;\r\n SetLength(Path, MAX_PATH);\r\n if Succeeded(SHGetSpecialFolderLocation(0, Folder, Pidl)) then\r\n begin\r\n try\r\n Path := PidltoPath(Pidl);\r\n if Path <> '' then\r\n begin\r\n StrResetLength(Path);\r\n Result := ShellLinkCreate(Link, PathAddSeparator(Path) + FileName);\r\n end;\r\n finally\r\n CoTaskMemFree(Pidl);\r\n end;\r\n end;\r\nend;\r\n\r\nfunction ShellLinkCreate(const Link: TShellLink; const FileName: string): HRESULT;\r\nvar\r\n ShellLink: IShellLink;\r\n PersistFile: IPersistFile;\r\n LinkName: TWidePathPtr;\r\nbegin\r\n Result := CoCreateInstance(CLSID_ShellLink, nil, CLSCTX_INPROC_SERVER,\r\n IID_IShellLink, ShellLink);\r\n if Succeeded(Result) then\r\n begin\r\n ShellLink.SetArguments(PChar(Link.Arguments));\r\n ShellLink.SetShowCmd(Link.ShowCmd);\r\n ShellLink.SetWorkingDirectory(PChar(Link.WorkingDirectory));\r\n ShellLink.SetPath(PChar(Link.Target));\r\n ShellLink.SetDescription(PChar(Link.Description));\r\n ShellLink.SetHotkey(Link.HotKey);\r\n ShellLink.SetIconLocation(PChar(Link.IconLocation), Link.IconIndex);\r\n PersistFile := ShellLink as IPersistFile;\r\n {$IFDEF SUPPORTS_UNICODE}\r\n LinkName := PChar(FileName);\r\n {$ELSE ~SUPPORTS_UNICODE}\r\n MultiByteToWideChar(CP_ACP, MB_PRECOMPOSED, PAnsiChar(FileName), -1,\r\n LinkName, MAX_PATH);\r\n {$ENDIF ~SUPPORTS_UNICODE}\r\n Result := PersistFile.Save(LinkName, True);\r\n end;\r\nend;\r\n\r\nfunction RtdlLoadMsiFuncs:Boolean;\r\nbegin\r\n Result:=False;\r\n if LoadModule(rtdlMsiLibHandle,MSILIB) then\r\n begin\r\n if not Assigned(RtdlMsiGetShortcutTarget) then\r\n RtdlMsiGetShortcutTarget := GetModuleSymbol(rtdlMsiLibHandle,GetShortcutTargetName);\r\n\r\n if not Assigned(RtdlMsiGetComponentPath) then\r\n RtdlMsiGetComponentPath := GetModuleSymbol(rtdlMsiLibHandle,GetComponentPathName);\r\n\r\n Result:=(Assigned(RtdlMsiGetShortcutTarget)) and (Assigned(RtdlMsiGetComponentPath));\r\n end;\r\nend;\r\n\r\nfunction ShellLinkResolve(const FileName: string; out Link: TShellLink): HRESULT;\r\nbegin\r\n Result := ShellLinkResolve(FileName, Link, SLR_ANY_MATCH);\r\nend;\r\n\r\nfunction ShellLinkResolve(const FileName: string; out Link: TShellLink;\r\n const ResolveFlags: Cardinal): HRESULT;\r\nconst\r\n MAX_FEATURE_CHARS = 38; // maximum chars in MSI feature name\r\nvar\r\n ShellLink: IShellLink;\r\n PersistFile: IPersistFile;\r\n LinkName: TWidePathPtr;\r\n Buffer: string;\r\n Win32FindData: TWin32FindData;\r\n FullPath: string;\r\n ProductGuid: array [0..38] of Char;\r\n FeatureID: array [0..MAX_FEATURE_CHARS] of Char;\r\n ComponentGUID: array [0..38] of Char;\r\n TargetFile: array [0..MAX_PATH] of Char;\r\n PathSize: DWORD;\r\n TargetResolved: Boolean;\r\nbegin\r\n Result := CoCreateInstance(CLSID_ShellLink, nil, CLSCTX_INPROC_SERVER,\r\n IID_IShellLink, ShellLink);\r\n\r\n if Succeeded(Result) then\r\n begin\r\n TargetResolved := False;\r\n\r\n // Handle MSI style shortcuts without invoking the Windows installer if\r\n // the feature was set to \"Install on first use\"\r\n if RtdlLoadMsiFuncs then\r\n begin\r\n ResetMemory(ProductGuid, SizeOf(ProductGuid));\r\n ResetMemory(FeatureID, SizeOf(FeatureID));\r\n ResetMemory(ComponentGuid, SizeOf(ComponentGuid));\r\n ResetMemory(TargetFile, SizeOf(TargetFile));\r\n\r\n if RtdlMsiGetShortcutTarget(PChar(FileName), ProductGuid, FeatureID, ComponentGuid) = ERROR_SUCCESS then\r\n begin\r\n PathSize := MAX_PATH + 1;\r\n RtdlMsiGetComponentPath(ProductGuid, ComponentGuid, TargetFile, @PathSize);\r\n\r\n if TargetFile <> '' then\r\n begin\r\n Link.Target := TargetFile;\r\n TargetResolved := True;\r\n end;\r\n end;\r\n end;\r\n\r\n PersistFile := ShellLink as IPersistFile;\r\n // PersistFile.Load fails if the filename is not fully qualified\r\n FullPath := ExpandFileName(FileName);\r\n {$IFDEF SUPPORTS_UNICODE}\r\n LinkName := PWideChar(FullPath);\r\n {$ELSE ~SUPPORTS_UNICODE}\r\n MultiByteToWideChar(CP_ACP, MB_PRECOMPOSED, PAnsiChar(FullPath), -1, LinkName, MAX_PATH);\r\n {$ENDIF ~SUPPORTS_UNICODE}\r\n Result := PersistFile.Load(LinkName, STGM_READ);\r\n\r\n if Succeeded(Result) then\r\n begin\r\n Result := ShellLink.Resolve(0, ResolveFlags);\r\n\r\n if Succeeded(Result) then\r\n begin\r\n SetLength(Buffer, MAX_PATH);\r\n\r\n if not TargetResolved then\r\n begin\r\n Win32FindData.dwFileAttributes := 0;\r\n ShellLink.GetPath(PChar(Buffer), MAX_PATH, Win32FindData, SLGP_SHORTPATH);\r\n Link.Target := PChar(Buffer);\r\n end;\r\n\r\n ShellLink.GetArguments(PChar(Buffer), MAX_PATH);\r\n Link.Arguments := PChar(Buffer);\r\n ShellLink.GetShowCmd(Link.ShowCmd);\r\n ShellLink.GetWorkingDirectory(PChar(Buffer), MAX_PATH);\r\n Link.WorkingDirectory := PChar(Buffer);\r\n ShellLink.GetDescription(PChar(Buffer), MAX_PATH);\r\n Link.Description := PChar(Buffer);\r\n ShellLink.GetIconLocation(PChar(Buffer), MAX_PATH, Link.IconIndex);\r\n Link.IconLocation := PChar(Buffer);\r\n ShellLink.GetHotkey(Link.HotKey);\r\n ShellLink.GetIDList(Link.IdList);\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction ShellLinkIcon(const Link: TShellLink): HICON; overload;\r\nvar\r\n LocExt: string;\r\n Info: TSHFileInfo;\r\nbegin\r\n Result := 0;\r\n LocExt := LowerCase(ExtractFileExt(Link.IconLocation));\r\n // 1. See if IconLocation specifies a valid icon file\r\n if (LocExt = '.ico') and (FileExists(Link.IconLocation)) then\r\n begin\r\n { TODO : Implement loading from an .ico file }\r\n end;\r\n // 2. See if IconLocation specifies an executable\r\n if Result = 0 then\r\n begin\r\n if (LocExt = '.dll') or (LocExt = '.exe') then\r\n Result := ExtractIcon(0, PChar(Link.IconLocation), Link.IconIndex);\r\n end;\r\n // 3. See if target specifies a file\r\n if Result = 0 then\r\n begin\r\n if FileExists(Link.Target) then\r\n Result := ExtractIcon(0, PChar(Link.Target), Link.IconIndex);\r\n end;\r\n // 4. See if the target is an object\r\n if Result = 0 then\r\n begin\r\n if Link.IdList <> nil then\r\n begin\r\n ResetMemory(Info, SizeOf(Info));\r\n if SHGetFileInfo(PChar(Link.IdList), 0, Info, SizeOf(Info), SHGFI_PIDL or SHGFI_ICON) <> 0 then\r\n Result := Info.hIcon;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction ShellLinkIcon(const FileName: string): HICON; overload;\r\nvar\r\n Link: TShellLink;\r\nbegin\r\n if Succeeded(ShellLinkResolve(FileName, Link)) then\r\n begin\r\n Result := ShellLinkIcon(Link);\r\n ShellLinkFree(Link);\r\n end\r\n else\r\n Result := 0;\r\nend;\r\n\r\n//=== Miscellaneous ==========================================================\r\n\r\nfunction SHGetItemInfoTip(const Folder: IShellFolder; Item: PItemIdList): string;\r\nvar\r\n QueryInfo: IQueryInfo;\r\n InfoTip: PWideChar;\r\nbegin\r\n Result := '';\r\n if (Item = nil) or (Folder = nil) then\r\n Exit;\r\n if Succeeded(Folder.GetUIObjectOf(0, 1, Item, IQueryInfo, nil,\r\n Pointer(QueryInfo))) then\r\n begin\r\n InfoTip := nil;\r\n if Succeeded(QueryInfo.GetInfoTip(0, InfoTip)) then\r\n begin\r\n Result := WideCharToString(InfoTip);\r\n SHFreeMem(Pointer(InfoTip));\r\n end;\r\n end;\r\nend;\r\n\r\nfunction SHDllGetVersion(const FileName: string; var Version: TDllVersionInfo): Boolean;\r\ntype\r\n TDllGetVersionProc = function (var pdvi: TDllVersionInfo): HRESULT; stdcall;\r\nvar\r\n _DllGetVersion: TDllGetVersionProc;\r\n LibHandle: HINST;\r\nbegin\r\n Result := False;\r\n LibHandle := SafeLoadLibrary(FileName);\r\n if LibHandle <> 0 then\r\n begin\r\n @_DllGetVersion := GetProcAddress(LibHandle, PChar('DllGetVersion'));\r\n if @_DllGetVersion <> nil then\r\n begin\r\n Version.cbSize := SizeOf(TDllVersionInfo);\r\n Result := Succeeded(_DllGetVersion(Version));\r\n end;\r\n FreeLibrary(LibHandle);\r\n end;\r\nend;\r\n\r\nfunction OverlayIcon(var Icon: HICON; Overlay: HICON; Large: Boolean): Boolean;\r\nvar\r\n Source, Dest: HIMAGELIST;\r\n Width, Height: Integer;\r\nbegin\r\n Result := False;\r\n if Large then\r\n begin\r\n Width := GetSystemMetrics(SM_CXICON);\r\n Height := GetSystemMetrics(SM_CYICON);\r\n Source := ImageList_Create(Width, Height, ILC_MASK or ILC_COLOR32, 1, 0);\r\n end\r\n else\r\n begin\r\n Width := GetSystemMetrics(SM_CXSMICON);\r\n Height := GetSystemMetrics(SM_CYSMICON);\r\n Source := ImageList_Create(Width, Height, ILC_MASK or ILC_COLOR32, 1, 0);\r\n end;\r\n if Source <> 0 then\r\n begin\r\n if (ImageList_AddIcon(Source, Icon) <> -1) and\r\n (ImageList_AddIcon(Source, Overlay) <> -1) then\r\n begin\r\n Dest := HIMAGELIST(ImageList_Merge(Source, 0, Source, 1, 0, 0));\r\n if Dest <> 0 then\r\n begin\r\n DestroyIcon(Icon);\r\n Icon := ImageList_ExtractIcon(0, Dest, 0);\r\n ImageList_Destroy(Dest);\r\n Result := True;\r\n end;\r\n end;\r\n ImageList_Destroy(Source);\r\n end;\r\nend;\r\n\r\nfunction OverlayIconShortCut(var Large, Small: HICON): Boolean;\r\nvar\r\n OvlLarge, OvlSmall: HICON;\r\nbegin\r\n Result := False;\r\n OvlLarge := 0;\r\n OvlSmall := 0;\r\n if ExtractIconEx(PChar('shell32.dll'), 29, OvlLarge, OvlSmall, 1) = 2 then\r\n begin\r\n OverlayIcon(Large, OvlLarge, True);\r\n OverlayIcon(Small, OvlSmall, False);\r\n end;\r\nend;\r\n\r\nfunction OverlayIconShared(var Large, Small: HICON): Boolean;\r\nvar\r\n OvlLarge, OvlSmall: HICON;\r\nbegin\r\n Result := False;\r\n OvlLarge := 0;\r\n OvlSmall := 0;\r\n if ExtractIconEx(PChar('shell32.dll'), 28, OvlLarge, OvlSmall, 1) = 2 then\r\n begin\r\n OverlayIcon(Large, OvlLarge, True);\r\n OverlayIcon(Small, OvlSmall, False);\r\n end;\r\nend;\r\n\r\nfunction GetSystemIcon(IconIndex: Integer; Flags: Cardinal): HICON;\r\nvar\r\n FileInfo: TSHFileInfo;\r\n ImageList: HIMAGELIST;\r\nbegin\r\n ResetMemory(FileInfo, SizeOf(FileInfo));\r\n if Flags = 0 then\r\n Flags := SHGFI_SHELLICONSIZE;\r\n ImageList := SHGetFileInfo('', 0, FileInfo, SizeOf(FileInfo),\r\n Flags or SHGFI_SYSICONINDEX);\r\n Result := ImageList_ExtractIcon(0, ImageList, IconIndex);\r\nend;\r\n\r\nfunction ShellExecEx(const FileName: string; const Parameters: string;\r\n const Verb: string; CmdShow: Integer): Boolean;\r\nvar\r\n Sei: TShellExecuteInfo;\r\nbegin\r\n ResetMemory(Sei, SizeOf(Sei));\r\n Sei.cbSize := SizeOf(Sei);\r\n Sei.fMask := SEE_MASK_DOENVSUBST or SEE_MASK_FLAG_NO_UI;\r\n Sei.lpFile := PChar(FileName);\r\n Sei.lpParameters := PCharOrNil(Parameters);\r\n Sei.lpVerb := PCharOrNil(Verb);\r\n Sei.nShow := CmdShow;\r\n {$TYPEDADDRESS ON}\r\n Result := ShellExecuteEx(@Sei);\r\n {$IFNDEF TYPEDADDRESS_ON}\r\n {$TYPEDADDRESS OFF}\r\n {$ENDIF ~TYPEDADDRESS_ON}\r\nend;\r\n\r\n{ TODO -cHelp : author Jean-Fabien Connault note, ShellExecEx() above used to be ShellExec()... }\r\n\r\nfunction ShellExec(Wnd: Integer; const Operation, FileName, Parameters, Directory: string; ShowCommand: Integer): Boolean;\r\nbegin\r\n Result := ShellExecute(Wnd, PChar(Operation), PChar(FileName), PChar(Parameters),\r\n PChar(Directory), ShowCommand) > 32;\r\nend;\r\n\r\nfunction ShellExecAndWait(const FileName: string; const Parameters: string;\r\n const Verb: string; CmdShow: Integer; const Directory: string): Boolean;\r\nvar\r\n Sei: TShellExecuteInfo;\r\n Res: LongBool;\r\n Msg: tagMSG;\r\nbegin\r\n ResetMemory(Sei, SizeOf(Sei));\r\n Sei.cbSize := SizeOf(Sei);\r\n Sei.fMask := SEE_MASK_DOENVSUBST or SEE_MASK_FLAG_NO_UI or SEE_MASK_NOCLOSEPROCESS or\r\n SEE_MASK_FLAG_DDEWAIT;\r\n Sei.lpFile := PChar(FileName);\r\n Sei.lpParameters := PCharOrNil(Parameters);\r\n Sei.lpVerb := PCharOrNil(Verb);\r\n Sei.nShow := CmdShow;\r\n Sei.lpDirectory := PCharOrNil(Directory);\r\n {$TYPEDADDRESS ON}\r\n Result := ShellExecuteEx(@Sei);\r\n {$IFNDEF TYPEDADDRESS_ON}\r\n {$TYPEDADDRESS OFF}\r\n {$ENDIF ~TYPEDADDRESS_ON}\r\n if Result then\r\n begin\r\n WaitForInputIdle(Sei.hProcess, INFINITE);\r\n while WaitForSingleObject(Sei.hProcess, 10) = WAIT_TIMEOUT do\r\n repeat\r\n Msg.hwnd := 0;\r\n Res := PeekMessage(Msg, Sei.Wnd, 0, 0, PM_REMOVE);\r\n if Res then\r\n begin\r\n TranslateMessage(Msg);\r\n DispatchMessage(Msg);\r\n end;\r\n until not Res;\r\n CloseHandle(Sei.hProcess);\r\n end;\r\nend;\r\n\r\nfunction ShellOpenAs(const FileName: string): Boolean;\r\nbegin\r\n Result := ShellExecEx('rundll32', Format('shell32.dll,OpenAs_RunDLL \"%s\"', [FileName]), '', SW_SHOWNORMAL);\r\nend;\r\n\r\n{ TODO: Dynamic linking - move TRasDialDlgA to JclWin32}\r\ntype\r\n TRasDialDlgFunc = function(lpszPhonebook, lpszEntry, lpszPhoneNumber: PChar; lpInfo: PRasDialDlg): BOOL; stdcall;\r\n\r\nfunction ShellRasDial(const EntryName: string): Boolean;\r\nvar\r\n Info: TRasDialDlg;\r\n RasDlg: HModule;\r\n RasDialDlg: TRasDialDlgFunc;\r\nbegin\r\n if IsWinNT then\r\n begin\r\n Result := False;\r\n RasDlg := SafeLoadLibrary('rasdlg.dll');\r\n if RasDlg <> 0 then\r\n try\r\n @RasDialDlg := GetProcAddress(RasDlg, PChar('RasDialDlg' + AWSuffix));\r\n if @RasDialDlg <> nil then\r\n begin\r\n ResetMemory(Info, SizeOf(Info));\r\n Info.dwSize := SizeOf(Info);\r\n Result := RasDialDlg(nil, PChar(EntryName), nil, @Info);\r\n end;\r\n finally\r\n FreeLibrary(RasDlg);\r\n end;\r\n end\r\n else\r\n Result := ShellExecEx('rundll32', Format('rnaui.dll,RnaDial \"%s\"', [EntryName]), '', SW_SHOWNORMAL);\r\nend;\r\n\r\n// You can pass simple name of standard system control panel (e.g. 'timedate')\r\n// or full qualified file name (Window 95 only? doesn't work on Win2K!)\r\n// MT: Added support for Windows 98..XP. Have no win95 anymore so I have to\r\n// trust that the original version works on Windows 95 and Windows 95OSR2.\r\n\r\nfunction ShellRunControlPanel(const NameOrFileName: string; AppletNumber: Integer): Boolean;\r\nvar\r\n FileName: TFileName;\r\nbegin\r\n if ExtractFilePath(NameOrFileName) = '' then\r\n FileName := ChangeFileExt(PathAddSeparator(GetWindowsSystemFolder) + NameOrFileName, '.cpl')\r\n else\r\n FileName := NameOrFileName;\r\n if FileExists(FileName) then\r\n begin\r\n if (IsWin95 or IsWin95OSR2) then\r\n Result := ShellExecEx('rundll32', Format('shell32.dll,Control_RunDLL \"%s\", @%d',\r\n [FileName, AppletNumber]), '', SW_SHOWNORMAL)\r\n else\r\n Result := ShellExecEx('rundll32', Format('shell32.dll,Control_RunDLL \"%s\",,%d',\r\n [FileName, AppletNumber]), '', SW_SHOWNORMAL)\r\n end\r\n else\r\n begin\r\n Result := False;\r\n SetLastError(ERROR_FILE_NOT_FOUND);\r\n end;\r\nend;\r\n\r\n// Compare http://msdn.microsoft.com/en-us/library/bb756922.aspx\r\n\r\nfunction RunAsAdmin(const FileName: string; const Parameters: string = ''; const Parent: THandle = 0): Boolean;\r\nvar\r\n Sei: TShellExecuteInfo;\r\nbegin\r\n ResetMemory(Sei, SizeOf(Sei));\r\n Sei.cbSize := SizeOf(TShellExecuteInfo);\r\n Sei.Wnd := Parent;\r\n Sei.fMask := SEE_MASK_FLAG_DDEWAIT or SEE_MASK_FLAG_NO_UI;\r\n Sei.lpVerb := PChar(cVerbRunas);\r\n Sei.lpFile := PChar(FileName);\r\n Sei.lpParameters := PCharOrNil(Parameters);\r\n Sei.nShow := SW_SHOWNORMAL;\r\n\r\n {$TYPEDADDRESS ON}\r\n Result := ShellExecuteEx(@Sei);\r\n {$IFNDEF TYPEDADDRESS_ON}\r\n {$TYPEDADDRESS OFF}\r\n {$ENDIF ~TYPEDADDRESS_ON}\r\nend;\r\n\r\nfunction GetFileExeType(const FileName: TFileName): TJclFileExeType;\r\nvar\r\n FileInfo: TSHFileInfo;\r\n R: DWORD;\r\nbegin\r\n FileInfo.dwAttributes := 0;\r\n R := SHGetFileInfo(PChar(FileName), 0, FileInfo, SizeOf(FileInfo), SHGFI_EXETYPE);\r\n case LoWord(R) of\r\n IMAGE_DOS_SIGNATURE:\r\n Result := etMsDos;\r\n IMAGE_OS2_SIGNATURE:\r\n Result := etWin16;\r\n Word(IMAGE_NT_SIGNATURE):\r\n if HiWord(R) = 0 then\r\n Result := etWin32Con\r\n else\r\n Result := etWin32Gui;\r\n else\r\n Result := etError;\r\n end;\r\nend;\r\n\r\nfunction ShellFindExecutable(const FileName, DefaultDir: string): string;\r\nvar\r\n Res: HINST;\r\n Buffer: array [0..MAX_PATH-1] of Char;\r\n I: Integer;\r\nbegin\r\n ResetMemory(Buffer, SizeOf(Buffer));\r\n Res := FindExecutable(PChar(FileName), PCharOrNil(DefaultDir), Buffer);\r\n if Res > 32 then\r\n begin\r\n // FindExecutable replaces #32 with #0\r\n for I := Low(Buffer) to High(Buffer) - 1 do\r\n if Buffer[I] = #0 then\r\n Buffer[I] := #32;\r\n Buffer[High(Buffer)] := #0;\r\n Result := Trim(Buffer);\r\n end\r\n else\r\n Result := '';\r\nend;\r\n\r\nfunction GetFileNameIcon(const FileName: string; Flags: Cardinal = 0): HICON;\r\nvar\r\n FileInfo: TSHFileInfo;\r\n ImageList: HIMAGELIST;\r\nbegin\r\n ResetMemory(FileInfo, SizeOf(FileInfo));\r\n if Flags = 0 then\r\n Flags := SHGFI_SHELLICONSIZE;\r\n ImageList := SHGetFileInfo(PChar(FileName), 0, FileInfo, SizeOf(FileInfo),\r\n Flags or SHGFI_SYSICONINDEX);\r\n if ImageList <> 0 then\r\n Result := ImageList_ExtractIcon(0, ImageList, FileInfo.iIcon)\r\n else\r\n Result := 0;\r\nend;\r\n\r\ninitialization\r\n //We don't load the msi functions until the first attempt to resolve an MSI link\r\n\r\n {$IFDEF UNITVERSIONING}\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n {$ENDIF UNITVERSIONING}\r\n\r\nfinalization\r\n {$IFDEF UNITVERSIONING}\r\n UnregisterUnitVersion(HInstance);\r\n {$ENDIF UNITVERSIONING}\r\n UnloadModule(rtdlMsiLibHandle);\r\n\r\nend.\r\n\r\n\r\n" }, { "path": "External/Jedi/Jcl/source/windows/JclStructStorage.pas", "content": "{**************************************************************************************************}\r\n{ }\r\n{ Project JEDI Code Library (JCL) }\r\n{ }\r\n{ The contents of this file are subject to the Mozilla Public License Version 1.1 (the \"License\"); }\r\n{ you may not use this file except in compliance with the License. You may obtain a copy of the }\r\n{ License at http://www.mozilla.org/MPL/ }\r\n{ }\r\n{ Software distributed under the License is distributed on an \"AS IS\" basis, WITHOUT WARRANTY OF }\r\n{ ANY KIND, either express or implied. See the License for the specific language governing rights }\r\n{ and limitations under the License. }\r\n{ }\r\n{ The Original Code is JclStructStore.pas. }\r\n{ }\r\n{ The Initial Developer of the Original Code is Peter Thornqvist. }\r\n{ Portions created by Peter Thornqvist are Copyright (C) Peter Thornqvist. All Rights Reserved. }\r\n{ }\r\n{ Contributor(s): }\r\n{ A. Schmidt (shmia (at) bizerba.de) }\r\n{ }\r\n{**************************************************************************************************}\r\n{ }\r\n{ MS Structured storage class wrapper }\r\n{ }\r\n{**************************************************************************************************}\r\n{ }\r\n{ Last modified: $Date:: 2011-09-03 00:07:50 +0200 (sam. 03 sept. 2011) $ }\r\n{ Revision: $Rev:: 3599 $ }\r\n{ Author: $Author:: outchy $ }\r\n{ }\r\n{**************************************************************************************************}\r\n\r\n{\r\nDescription:\r\n\r\nWrapper around MS structured storage library to simplify handling compound files\r\n(the filetype used in Word, Excel, newer versions of Access, Project et al).\r\n\r\nNote that MS documentation uses the terms \"Storage\" and \"Streams\". I've decided to use the\r\nnames Folders (for Storages) and Files (for Streams) since that more closely\r\nresembles how the content of a compound file is percieved and used.\r\n\r\nVery briefly, a compound (or structured) file is a disk file that contains data organized\r\nin an internal structure. The structure is similar to a normal file system\r\nin that the file can contain folders (storages) and subfiles (streams). Folders\r\ncan contain subfolders and files but no data of it's own, files can contain data but no subitems.\r\n\r\nThis implementation is simplified in a number of ways compared to what can actually be\r\ndone with the IStorage implementation in Windows:\r\n\r\n* creating a new file with the same name as an existing will silently overwrite\r\n the existing file, even if it's not a compound file\r\n* SetClassID has not been implemented / surfaced\r\n* STGM_SIMPLE, STGM_PRIORITY, STGM_NOSCRATCH, STGM_FAILIFTHERE and a few other esoteric flags are not supported\r\n\r\nBTW, what's the difference between \"compound\" and \"structured\"? MS seems a bit confused\r\nthemselves on this topic, but it looks like the term \"compound file\" is used to\r\ndescribe the actual Microsoft OLE/COM implementation of the theoretical idea\r\nof \"structured storage\"...\r\n\r\n-----------------------------------------------------------------------------}\r\n\r\nunit JclStructStorage;\r\n\r\n{$I jcl.inc}\r\n{$I windowsonly.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n {$IFDEF HAS_UNITSCOPE}\r\n Winapi.Windows, System.Classes, System.SysUtils, Winapi.ActiveX,\r\n {$ELSE ~HAS_UNITSCOPE}\r\n Windows, Classes, SysUtils, ActiveX,\r\n {$ENDIF ~HAS_UNITSCOPE}\r\n JclBase;\r\n\r\ntype\r\n EJclStructStorageError = class(EJclError);\r\n TJclStructStorageAccessMode = (smOpenRead, smOpenWrite, smCreate, smShareDenyRead, smShareDenyWrite, smTransacted);\r\n TJclStructStorageAccessModes = set of TJclStructStorageAccessMode;\r\n\r\n TJclStructStorageFolder = class(TPersistent)\r\n private\r\n function GetName: string;\r\n protected\r\n FStorage: IStorage;\r\n FLastError: HRESULT;\r\n FFileName: string;\r\n FAccessMode: TJclStructStorageAccessModes;\r\n FConvertedMode: UINT;\r\n procedure Check;\r\n function CheckResult(HR: HRESULT): Boolean;\r\n // Calls to Dest.Assign will eventually end up here.\r\n // AssignTo is implemented as a call to IStorage.CopyTo(Dest)\r\n // This method merges elements contained in the source storage object with\r\n // those already present in the destination. The layout of the destination\r\n // storage object may differ from the source storage object.\r\n // The copy process is recursive, invoking IStorage::CopyTo and IStream::CopyTo\r\n // on the elements nested inside the source.\r\n // When copying a stream on top of an existing stream with the same name,\r\n // the existing stream is first removed and then replaced with the source stream.\r\n // When copying a storage on top of an existing storage with the same name,\r\n // the existing storage is not removed. As a result, after the copy operation,\r\n // the destination IStorage contains older elements, unless they were replaced by\r\n // newer ones with the same names.\r\n procedure AssignTo(Dest: TPersistent); override;\r\n public\r\n // Returns S_OK if FileName is a compound file\r\n class function IsStructured(const FileName: string): HRESULT;\r\n // Converts FileName to a structured file and puts the existing content of the file\r\n // into a root file stream called 'CONTENTS'\r\n // Returns S_OK or STG_S_CONVERTED if the file could be converted or if it was already a structured file\r\n class function Convert(const FileName: string): HRESULT;\r\n // Copies a sub storage or stream to another storage\r\n // Before calling this method, the element to be copied must be closed,\r\n // and the destination storage must be open. Also, the destination object\r\n // and element cannot be the same storage object/element name as the source\r\n // of the copy. That is, you cannot copy an element to itself.\r\n function CopyTo(const OldName, NewName: string; Dest: TJclStructStorageFolder): Boolean;\r\n // Moves a sub storage or stream to another storage\r\n // Before calling this method, the element to be moved must be closed,\r\n // and the destination storage must be open. Also, the destination object\r\n // and element cannot be the same storage object/element name as the source\r\n // of the move. That is, you cannot move an element to itself.\r\n function MoveTo(const OldName, NewName: string; Dest: TJclStructStorageFolder): Boolean;\r\n // Commits any changes when smTransacted is true\r\n // When smTransacted is false, changes are comitted immediately and thus cannot be comitted\r\n function Commit: Boolean;\r\n // Reverts any changes when smTransacted is true\r\n // When smTransacted is false, changes are comitted immediately and thus cannot be reverted\r\n function Revert: Boolean;\r\n // Create a new or open an existing structured file (or subfolder) depending on AccessMode.\r\n // NOTE that the file will not actually be opened or created until you call\r\n // one of the methods in this class (except for Destroy). To force a direct open of the file, set OpenDirect to true\r\n constructor Create(const FileName: string; AccessMode: TJclStructStorageAccessModes;\r\n OpenDirect: Boolean = False); virtual;\r\n // Destroys the class instance and releases the compound file (or subfolder)\r\n destructor Destroy; override;\r\n // Returns statistics for this storage. The returned structure contains\r\n // various information about the storage. NOTE that some items may not always be valid or set\r\n // (f ex the GUID or the date values)\r\n //\r\n // NOTE: if you call this function with IncludeName = true, you *must*\r\n // free the returned Stat by calling FreeStats;\r\n function GetStats(out Stat: TStatStg; IncludeName: Boolean): Boolean;\r\n procedure FreeStats(var Stat: TStatStg);\r\n // Gets the names of all subitems (files or folders depending on the Folders flag) of this storage\r\n // and puts it in Strings. Strings is cleared before adding the items\r\n function GetSubItems(Strings: TStrings; Folders: Boolean): Boolean;\r\n // Adds a new file or folder to this folder. If the file/folder already exists, it is overwritten.\r\n // NB: Name must be < 31 characters\r\n function Add(const Name: string; IsFolder: Boolean): Boolean;\r\n // Deletes a file /folder\r\n function Delete(const Name: string): Boolean;\r\n // Renames a file/folder. The element must be closed before calling this method\r\n // NB: NewName must be < 31 characters\r\n function Rename(const OldName, NewName: string): Boolean;\r\n // Returns an existing folder by name. The folder is opened using the same AccessMode\r\n // as passed into the constructor, except for any smCreate and with sharing set to [smShareDenyRead,smShareDenyWrite]\r\n // because the MS implementation doesn't support opening the same storage more than once\r\n // from the same parent storage\r\n function GetFolder(const Name: string; out Storage: TJclStructStorageFolder): Boolean;\r\n // Returns an existing file stream by name. The stream is opened using the same AccessMode\r\n // as passed into the constructor, except for any smCreate and with sharing set to [smShareDenyRead,smShareDenyWrite]\r\n // because the MS implementation doesn't support opening the same stream more than once\r\n // from the same parent storage\r\n function GetFileStream(const Name: string; out Stream: TStream): Boolean;\r\n // Set the various time fields -a(ccess)time, c(reation)time, m(odified)time - for\r\n // a stream or storage as specified by Name. Values in Stat that are set to 0 are left\r\n // unmodified.\r\n // To set these values for the root storage, pass an empty string in Name.\r\n // To get the current values, call GetStats on the specific storage or stream\r\n function SetElementTimes(const Name: string; Stat: TStatStg): Boolean;\r\n\r\n // The name of the storage, either a (sub)folder name or the fully qualified name of the disk file (for the root object)\r\n property Name: string read GetName;\r\n // pointer to the IStorage\r\n property Intf: IStorage read FStorage;\r\n // last error for this object (can be S_OK)\r\n property LastError: HRESULT read FLastError;\r\n end;\r\n\r\n // NOTE: you should not create instances of this class: an instance is created by\r\n // TJclStructStorageFolder when you call GetFileStream\r\n TJclStructStorageStream = class(TStream)\r\n private\r\n function GetName: string;\r\n protected\r\n FStream: IStream;\r\n FName: string;\r\n FLastError: HRESULT;\r\n procedure Check;\r\n function CheckResult(HR: HRESULT): Boolean;\r\n procedure SetSize(NewSize: Longint); override;\r\n public\r\n destructor Destroy; override;\r\n\r\n // Returns the TStatStg for this stream. This structure contains\r\n // the name, size and various date/time values for the stream in addition to\r\n // several other values\r\n //\r\n // NOTE: if you call this function with IncludeName = true, you *must*\r\n // free the returned Stat by calling FreStats or using this type of code:\r\n // CoGetMalloc(1,AMalloc);\r\n // AMalloc.Free(Stat.pwcsName)\r\n // where AMalloc is declared as an IMalloc type\r\n // see also example in TJclStructStorageFolder.GetSubItems above\r\n function GetStats(out Stat: TStatStg; IncludeName: Boolean): Boolean;\r\n procedure FreeStats(var Stat: TStatStg);\r\n // Create a new stream that points to this stream.\r\n // Returns nil on failure\r\n // NB! Caller is responsible for freeing this object!\r\n // To create a copy of a stream, call CopyTo instead\r\n function Clone: TJclStructStorageStream;\r\n function CopyTo(Stream: TJclStructStorageStream; Size: Int64): Boolean;\r\n function Read(var Buffer; Count: Longint): Longint; override;\r\n function Write(const Buffer; Count: Longint): Longint; override;\r\n function Seek(Offset: Longint; Origin: Word): Longint; override;\r\n // name of the stream\r\n property Name: string read GetName;\r\n // pointer to the IStream interface\r\n property Intf: IStream read FStream;\r\n // the last error for this object (can be S_OK)\r\n property LastError: HRESULT read FLastError;\r\n end;\r\n\r\nprocedure CoMallocFree(P: Pointer);\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jcl.svn.sourceforge.net/svnroot/jcl/tags/JCL-2.4-Build4571/jcl/source/windows/JclStructStorage.pas $';\r\n Revision: '$Revision: 3599 $';\r\n Date: '$Date: 2011-09-03 00:07:50 +0200 (sam. 03 sept. 2011) $';\r\n LogPath: 'JCL\\source\\windows';\r\n Extra: '';\r\n Data: nil\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n {$IFDEF HAS_UNITSCOPE}\r\n System.Win.ComObj,\r\n {$ELSE ~HAS_UNITSCOPE}\r\n ComObj,\r\n {$ENDIF ~HAS_UNITSCOPE}\r\n JclResources;\r\n\r\nvar\r\n FMalloc: IMalloc = nil;\r\n\r\n// type\r\n // PStgOptions = ^TStgOptions;\r\n // tagSTGOPTIONS = record\r\n // usVersion: Byte;\r\n // reserved: Byte;\r\n // ulSectorSize: DWORD;\r\n // pwcsTemplateFile: POleStr;\r\n // end;\r\n // {$EXTERNALSYM tagSTGOPTIONS}\r\n // TStgOptions = tagSTGOPTIONS;\r\n\r\n // TStgCreateStorageExFunc = function(pwcsName: POleStr; grfMode: Longint; StgFmt: Longint; grfAttrs: DWORD; pStgOptions:\r\n // PStgOptions;\r\n // reserved2: Pointer; riid: TIID; out ppObjectOpen: IUnknown): HRESULT; stdcall;\r\n // TStgOpenStorageExFunc = function(pwcsName: POleStr; grfMode: Longint; StgFmt: Longint; grfAttrs: DWORD; pStgOptions:\r\n // PStgOptions;\r\n // reserved2: Pointer; riid: TIID; out ppObjectOpen: IUnknown): HRESULT; stdcall;\r\n\r\n//var\r\n // replacements for StgCreateDocFile and StgOpenStorage on Win2k and XP - not currently used\r\n // StgCreateStorageEx: TStgCreateStorageExFunc = nil;\r\n // {$EXTERNALSYM StgCreateStorageEx}\r\n // StgOpenStorageEx: TStgOpenStorageExFunc = nil;\r\n // {$EXTERNALSYM StgOpenStorageEx}\r\n\r\nprocedure CoMallocFree(P: Pointer);\r\nbegin\r\n if FMalloc = nil then\r\n OleCheck(CoGetMalloc(1, FMalloc));\r\n FMalloc.Free(P);\r\nend;\r\n\r\nfunction AccessToMode(AccessMode: TJclStructStorageAccessModes): UINT;\r\nbegin\r\n { NOTE:\r\n MS has some very specific restrictions when combining the different\r\n Mode flags and certain combinations will lead to errors. I have mostly resisted the\r\n temptation to try to consolidate the restrictions here, so you might have to\r\n read up on the valid combinations on MSDN. Generally, the following rules apply\r\n when opening a file in non-transacted mode:\r\n\r\n * To create a new file, you must use [smCreate,smRead,smWrite,smShareDenyRead,smShareDenyWrite]\r\n = STGM_CREATE or STGM_READWRITE or STGM_SHARE_EXCLUSIVE\r\n * When opening as read-only, you must use [smRead,smShareDenyWrite]\r\n = STGM_READ or STGM_SHARE_DENY_WRITE\r\n * when opening for reading and writing, you must use [smRead,smWrite,smShareDenyRead,smShareDenyWrite]\r\n = STGM_READWRITE or STGM_SHARE_EXCLUSIVE\r\n\r\n These restrictions pretty much exist for transacted files as well with the difference that most\r\n errors are not reported until a call is made to Commit...\r\n }\r\n\r\n // creation:\r\n if smCreate in AccessMode then\r\n begin\r\n // only one valid combination, so set up and jump out:\r\n Result := STGM_CREATE or STGM_READWRITE or STGM_SHARE_EXCLUSIVE;\r\n Exit;\r\n end;\r\n\r\n // transactions:\r\n if smTransacted in AccessMode then\r\n Result := STGM_TRANSACTED\r\n else\r\n Result := STGM_DIRECT;\r\n\r\n // access:\r\n if AccessMode * [smOpenRead, smOpenWrite] = [smOpenRead, smOpenWrite] then\r\n Result := Result or STGM_READWRITE // this is *not* the same as (STGM_READ or STGM_WRITE)\r\n else\r\n if smOpenWrite in AccessMode then\r\n Result := Result or STGM_WRITE\r\n else\r\n if smOpenRead in AccessMode then // not strictly necessary, since STGM_READ = 0, but makes it more self-documenting\r\n Result := Result or STGM_READ;\r\n\r\n // sharing:\r\n if AccessMode * [smShareDenyRead, smShareDenyWrite] = [smShareDenyRead, smShareDenyWrite] then\r\n Result := Result or STGM_SHARE_EXCLUSIVE // *not* the same as (STGM_SHARE_READ or STGM_SHARE_WRITE)!\r\n else\r\n if smShareDenyRead in AccessMode then\r\n Result := Result or STGM_SHARE_DENY_READ\r\n else\r\n if smShareDenyWrite in AccessMode then\r\n Result := Result or STGM_SHARE_DENY_WRITE\r\n else\r\n Result := Result or STGM_SHARE_DENY_NONE;\r\n // not strictly necessary, since STGM_SHARE_DENY_NONE = 0, but makes it more self-documenting\r\nend;\r\n\r\n// simpler and less convoluted than using StringToWideChar\r\n\r\nfunction StrToWChar(const S: string): PWideChar;\r\nbegin\r\n if S = '' then\r\n Result := nil\r\n else\r\n begin\r\n {$IFDEF SUPPORTS_UNICODE}\r\n Result := PWideChar(S);\r\n {$ELSE ~SUPPORTS_UNICODE}\r\n Result := AllocMem((Length(S)+1) * SizeOf(WideChar));\r\n MultiByteToWideChar(CP_ACP, 0, PChar(S), Length(S), Result, Length(S));\r\n // (outchy) length(S) is the number of characters, not the size in bytes\r\n // (rom) fixed output buffer size (see Win32 help)\r\n //MultiByteToWideChar(CP_ACP, 0, PChar(S), Length(S), Result, Length(S) div 2);\r\n {$ENDIF ~SUPPORTS_UNICODE}\r\n end;\r\nend;\r\n\r\nprocedure FreeWChar(W: PWideChar);\r\nbegin\r\n {$IFNDEF SUPPORTS_UNICODE}\r\n if Assigned(W) then\r\n FreeMem(W);\r\n {$ENDIF ~SUPPORTS_UNICODE}\r\nend;\r\n\r\n//=== { TJclStructStorageFolder } ============================================\r\n\r\nconstructor TJclStructStorageFolder.Create(const FileName: string; AccessMode: TJclStructStorageAccessModes;\r\n OpenDirect: Boolean = False);\r\nbegin\r\n inherited Create;\r\n FFileName := FileName;\r\n FAccessMode := AccessMode;\r\n FConvertedMode := AccessToMode(FAccessMode);\r\n if FFileName = '' then\r\n FConvertedMode := FConvertedMode or STGM_DELETEONRELEASE;\r\n if OpenDirect then\r\n Check;\r\nend;\r\n\r\ndestructor TJclStructStorageFolder.Destroy;\r\nbegin\r\n FStorage := nil;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJclStructStorageFolder.Add(const Name: string;\r\n IsFolder: Boolean): Boolean;\r\nvar\r\n AName: PWideChar;\r\n Strg: IStorage;\r\n Stm: IStream;\r\nbegin\r\n Check;\r\n AName := StrToWChar(Name);\r\n try\r\n // always overwrite existing (fails if storage/stream exists and is open)\r\n if IsFolder then\r\n Result := CheckResult(FStorage.CreateStorage(AName, STGM_CREATE or STGM_SHARE_EXCLUSIVE, 0, 0, Strg))\r\n else\r\n Result := CheckResult(FStorage.CreateStream(AName, STGM_CREATE or STGM_SHARE_EXCLUSIVE, 0, 0, Stm));\r\n finally\r\n FreeWChar(AName);\r\n end;\r\nend;\r\n\r\nfunction TJclStructStorageFolder.Delete(const Name: string): Boolean;\r\nvar\r\n AName: PWideChar;\r\nbegin\r\n Check;\r\n AName := StrToWChar(Name);\r\n try\r\n Result := CheckResult(FStorage.DestroyElement(AName));\r\n finally\r\n FreeWChar(AName);\r\n end;\r\nend;\r\n\r\nprocedure TJclStructStorageFolder.Check;\r\nvar\r\n AName: PWideChar;\r\n HR: HRESULT;\r\nbegin\r\n if FStorage = nil then\r\n begin\r\n AName := StrToWChar(FFileName);\r\n try\r\n if FConvertedMode and STGM_CREATE = STGM_CREATE then\r\n HR := StgCreateDocfile(AName, FConvertedMode, 0, FStorage)\r\n else\r\n HR := StgOpenStorage(AName, nil, FConvertedMode, nil, 0, FStorage);\r\n finally\r\n FreeWChar(AName);\r\n end;\r\n if not Succeeded(HR) then\r\n raise EJclStructStorageError.Create(SysErrorMessage(HR));\r\n end;\r\nend;\r\n\r\nfunction TJclStructStorageFolder.CheckResult(HR: HRESULT): Boolean;\r\nbegin\r\n Result := Succeeded(HR);\r\n FLastError := HR;\r\nend;\r\n\r\nfunction TJclStructStorageFolder.GetFileStream(const Name: string; out Stream: TStream): Boolean;\r\nvar\r\n AName: PWideChar;\r\n Stm: IStream;\r\nbegin\r\n Check;\r\n AName := StrToWChar(Name);\r\n try\r\n // Streams don't support transactions, so always create in direct mode\r\n // Streams only support STGM_SHARE_EXCLUSIVE so add this explicitly\r\n if Succeeded(FStorage.OpenStream(AName, nil,\r\n AccessToMode(FAccessMode - [smCreate] + [smShareDenyRead, smShareDenyWrite]), 0, Stm)) then\r\n begin\r\n Stream := TJclStructStorageStream.Create;\r\n TJclStructStorageStream(Stream).FStream := Stm;\r\n TJclStructStorageStream(Stream).FName := Name;\r\n Result := True;\r\n end\r\n else\r\n begin\r\n Result := False;\r\n Stream := nil;\r\n end;\r\n finally\r\n FreeWChar(AName);\r\n end;\r\nend;\r\n\r\nfunction TJclStructStorageFolder.GetFolder(const Name: string; out Storage: TJclStructStorageFolder): Boolean;\r\nvar\r\n AName: PWideChar;\r\n AMode: UINT;\r\n Strg: IStorage;\r\nbegin\r\n Check;\r\n AName := StrToWChar(Name);\r\n try\r\n // Sub storages only supports STGM_SHARE_EXCLUSIVE, so add explicitly\r\n AMode := AccessToMode(FAccessMode - [smCreate] + [smShareDenyRead, smShareDenyWrite]);\r\n if Succeeded(FStorage.OpenStorage(AName, nil,\r\n AMode, nil, 0, Strg)) then\r\n begin\r\n // The parameters here has no real meaning since we set up the private fields directly\r\n Storage := TJclStructStorageFolder.Create(Name, FAccessMode);\r\n TJclStructStorageFolder(Storage).FConvertedMode := AMode;\r\n TJclStructStorageFolder(Storage).FStorage := Strg;\r\n TJclStructStorageFolder(Storage).FFileName := Name;\r\n Result := True;\r\n end\r\n else\r\n begin\r\n Storage := nil;\r\n Result := False;\r\n end;\r\n finally\r\n FreeWChar(AName);\r\n end;\r\nend;\r\n\r\nfunction TJclStructStorageFolder.GetSubItems(Strings: TStrings;\r\n Folders: Boolean): Boolean;\r\nvar\r\n Enum: IEnumSTATSTG;\r\n Stat: TStatStg;\r\n NumFetch: Longint;\r\nbegin\r\n Check;\r\n Strings.BeginUpdate;\r\n try\r\n Strings.Clear;\r\n Result := CheckResult(FStorage.EnumElements(0, nil, 0, Enum));\r\n if not Result then\r\n Exit;\r\n while Succeeded(Enum.Next(1, Stat, @NumFetch)) and (NumFetch = 1) do\r\n try\r\n if Folders and (Stat.dwType = STGTY_STORAGE) then\r\n Strings.Add(WideCharToString(Stat.pwcsName))\r\n else\r\n if not Folders and (Stat.dwType = STGTY_STREAM) then\r\n Strings.Add(WideCharToString(Stat.pwcsName));\r\n finally\r\n CoMallocFree(Stat.pwcsName);\r\n end;\r\n finally\r\n Strings.EndUpdate;\r\n end;\r\nend;\r\n\r\nfunction TJclStructStorageFolder.Rename(const OldName, NewName: string): Boolean;\r\nvar\r\n PWO, PWN: PWideChar;\r\nbegin\r\n Check;\r\n PWO := StrToWChar(OldName);\r\n PWN := StrToWChar(NewName);\r\n try\r\n // this will fail if the subelement is open\r\n Result := CheckResult(FStorage.RenameElement(PWO, PWN));\r\n finally\r\n FreeWChar(PWO);\r\n FreeWChar(PWN);\r\n end;\r\nend;\r\n\r\nclass function TJclStructStorageFolder.IsStructured(const FileName: string): HRESULT;\r\nvar\r\n AName: PWideChar;\r\nbegin\r\n AName := StrToWChar(FileName);\r\n try\r\n Result := StgIsStorageFile(AName);\r\n finally\r\n FreeWChar(AName);\r\n end;\r\nend;\r\n\r\nclass function TJclStructStorageFolder.Convert(const FileName: string): HRESULT;\r\nvar\r\n Strg: IStorage;\r\n AName: PWideChar;\r\nbegin\r\n Result := IsStructured(FileName);\r\n if Succeeded(Result) then\r\n begin\r\n AName := StrToWChar(FileName);\r\n try\r\n Result := StgCreateDocFile(AName, STGM_READWRITE or STGM_SHARE_EXCLUSIVE or STGM_CONVERT, 0, Strg);\r\n// Result := (HR = S_OK) or (HR = STG_S_CONVERTED);\r\n finally\r\n FreeWChar(AName);\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJclStructStorageFolder.GetStats(out Stat: TStatStg; IncludeName: Boolean): Boolean;\r\nconst\r\n Flags: array [Boolean] of Longint =\r\n (STATFLAG_NONAME, STATFLAG_DEFAULT);\r\nbegin\r\n Check;\r\n Result := CheckResult(FStorage.Stat(Stat, Flags[IncludeName]));\r\nend;\r\n\r\nfunction TJclStructStorageFolder.SetElementTimes(const Name: string; Stat: TStatStg): Boolean;\r\nvar\r\n AName: PWideChar;\r\nbegin\r\n Check;\r\n AName := StrToWChar(Name);\r\n try\r\n with Stat do\r\n Result := CheckResult(FStorage.SetElementTimes(AName, ctime, atime, mtime));\r\n finally\r\n FreeWChar(AName);\r\n end;\r\nend;\r\n\r\nfunction TJclStructStorageFolder.Commit: Boolean;\r\nbegin\r\n Check;\r\n Result := CheckResult(FStorage.Commit(STGC_DEFAULT)) or\r\n CheckResult(FStorage.Commit(STGC_OVERWRITE));\r\nend;\r\n\r\nfunction TJclStructStorageFolder.Revert: Boolean;\r\nbegin\r\n Check;\r\n Result := CheckResult(FStorage.Revert);\r\nend;\r\n\r\nfunction TJclStructStorageFolder.CopyTo(const OldName, NewName: string; Dest: TJclStructStorageFolder): Boolean;\r\nvar\r\n PWO, PWN: PWideChar;\r\nbegin\r\n Result := False;\r\n if Dest = nil then\r\n Exit;\r\n Check;\r\n Dest.Check;\r\n PWO := StrToWChar(OldName);\r\n PWN := StrToWChar(NewName);\r\n try\r\n Result := CheckResult(FStorage.MoveElementTo(PWO, Dest.FStorage, PWN, STGMOVE_COPY));\r\n finally\r\n FreeWChar(PWO);\r\n FreeWChar(PWN);\r\n end;\r\nend;\r\n\r\nprocedure TJclStructStorageFolder.AssignTo(Dest: TPersistent);\r\nbegin\r\n if Dest is TJclStructStorageFolder then\r\n begin\r\n Check;\r\n TJclStructStorageFolder(Dest).Check;\r\n CheckResult(FStorage.CopyTo(0, nil, nil, TJclStructStorageFolder(Dest).FStorage));\r\n end\r\n else\r\n inherited AssignTo(Dest);\r\nend;\r\n\r\nfunction TJclStructStorageFolder.MoveTo(const OldName, NewName: string;\r\n Dest: TJclStructStorageFolder): Boolean;\r\nvar\r\n PWO, PWN: PWideChar;\r\nbegin\r\n Result := False;\r\n if Dest = nil then\r\n Exit;\r\n Check;\r\n Dest.Check;\r\n PWO := StrToWChar(OldName);\r\n PWN := StrToWChar(NewName);\r\n try\r\n Result := CheckResult(FStorage.MoveElementTo(PWO, Dest.FStorage, PWN, STGMOVE_MOVE));\r\n finally\r\n FreeWChar(PWO);\r\n FreeWChar(PWN);\r\n end;\r\nend;\r\n\r\nfunction TJclStructStorageFolder.GetName: string;\r\nvar\r\n Stat: StatStg;\r\nbegin\r\n if (FStorage <> nil) and CheckResult(FStorage.Stat(Stat, STATFLAG_DEFAULT)) then\r\n begin\r\n Result := WideCharToString(Stat.pwcsName);\r\n CoMallocFree(Stat.pwcsName);\r\n end\r\n else\r\n Result := FFileName;\r\nend;\r\n\r\nprocedure TJclStructStorageFolder.FreeStats(var Stat: TStatStg);\r\nbegin\r\n if Stat.pwcsName <> nil then\r\n CoMallocFree(Stat.pwcsName);\r\nend;\r\n\r\n//=== { TJclStructStorageStream } ============================================\r\n\r\ndestructor TJclStructStorageStream.Destroy;\r\nbegin\r\n FStream := nil;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJclStructStorageStream.Check;\r\nbegin\r\n if FStream = nil then\r\n raise EJclStructStorageError.CreateRes(@RsIStreamNil);\r\nend;\r\n\r\nfunction TJclStructStorageStream.CheckResult(HR: HRESULT): Boolean;\r\nbegin\r\n Result := Succeeded(HR);\r\n FlastError := HR;\r\nend;\r\n\r\nfunction TJclStructStorageStream.Clone: TJclStructStorageStream;\r\nvar\r\n Stm: IStream;\r\nbegin\r\n if Succeeded(FStream.Clone(Stm)) then\r\n begin\r\n Result := TJclStructStorageStream.Create;\r\n Result.FStream := Stm;\r\n end\r\n else\r\n Result := nil;\r\nend;\r\n\r\nfunction TJclStructStorageStream.CopyTo(Stream: TJclStructStorageStream;\r\n Size: Int64): Boolean;\r\nvar\r\n DidRead, DidWrite: Int64;\r\nbegin\r\n DidRead := 0;\r\n DidWrite := 0;\r\n Result := Succeeded(FStream.CopyTo(Stream.FStream, Size, DidRead, DidWrite));\r\nend;\r\n\r\nprocedure TJclStructStorageStream.FreeStats(var Stat: TStatStg);\r\nbegin\r\n if Stat.pwcsName <> nil then\r\n CoMallocFree(Stat.pwcsName);\r\nend;\r\n\r\nfunction TJclStructStorageStream.GetName: string;\r\nvar\r\n Stat: StatStg;\r\nbegin\r\n if (FStream <> nil) and CheckResult(FStream.Stat(Stat, STATFLAG_DEFAULT)) then\r\n begin\r\n Result := WideCharToString(Stat.pwcsName);\r\n CoMallocFree(Stat.pwcsName);\r\n end\r\n else\r\n Result := Fname;\r\nend;\r\n\r\nfunction TJclStructStorageStream.GetStats(out Stat: TStatStg; IncludeName: Boolean): Boolean;\r\nconst\r\n Flags: array [Boolean] of Longint =\r\n (STATFLAG_NONAME, STATFLAG_DEFAULT);\r\nbegin\r\n Check;\r\n Result := CheckResult(FStream.Stat(Stat, Flags[IncludeName]));\r\nend;\r\n\r\nfunction TJclStructStorageStream.Read(var Buffer; Count: Longint): Longint;\r\nbegin\r\n Check;\r\n if not Succeeded(FStream.Read(@Buffer, Count, @Result)) then\r\n Result := 0;\r\nend;\r\n\r\nfunction TJclStructStorageStream.Seek(Offset: Integer; Origin: Word): Longint;\r\nvar\r\n N: Int64;\r\nbegin\r\n Check;\r\n if not Succeeded(FStream.Seek(Offset, Ord(Origin), N)) then\r\n Result := -1\r\n else\r\n Result := N;\r\nend;\r\n\r\nprocedure TJclStructStorageStream.SetSize(NewSize: Longint);\r\nbegin\r\n Check;\r\n FStream.SetSize(NewSize);\r\nend;\r\n\r\nfunction TJclStructStorageStream.Write(const Buffer; Count: Longint): Longint;\r\nbegin\r\n Check;\r\n if not Succeeded(FStream.Write(@Buffer, Count, @Result)) then\r\n Result := 0;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n\r\n" }, { "path": "External/Jedi/Jcl/source/windows/JclSvcCtrl.pas", "content": "{**************************************************************************************************}\r\n{ }\r\n{ Project JEDI Code Library (JCL) }\r\n{ }\r\n{ The contents of this file are subject to the Mozilla Public License Version 1.1 (the \"License\"); }\r\n{ you may not use this file except in compliance with the License. You may obtain a copy of the }\r\n{ License at http://www.mozilla.org/MPL/ }\r\n{ }\r\n{ Software distributed under the License is distributed on an \"AS IS\" basis, WITHOUT WARRANTY OF }\r\n{ ANY KIND, either express or implied. See the License for the specific language governing rights }\r\n{ and limitations under the License. }\r\n{ }\r\n{ The Original Code is JclSvcCtrl.pas. }\r\n{ }\r\n{ The Initial Developer of the Original Code is Flier Lu (). }\r\n{ Portions created by Flier Lu are Copyright (C) Flier Lu. All Rights Reserved. }\r\n{ }\r\n{ Contributors: }\r\n{ Flier Lu (flier) }\r\n{ Matthias Thoma (mthoma) }\r\n{ Olivier Sannier (obones) }\r\n{ Petr Vones (pvones) }\r\n{ Rik Barker (rikbarker) }\r\n{ Robert Rossmair (rrossmair) }\r\n{ Warren Postma }\r\n{ Terry Yapt }\r\n{ }\r\n{**************************************************************************************************}\r\n{ }\r\n{ This unit contains routines and classes to control NT service }\r\n{ }\r\n{**************************************************************************************************}\r\n{ }\r\n{ Last modified: $Date:: 2012-09-04 16:08:04 +0200 (mar. 04 sept. 2012) $ }\r\n{ Revision: $Rev:: 3861 $ }\r\n{ Author: $Author:: outchy $ }\r\n{ }\r\n{**************************************************************************************************}\r\n\r\nunit JclSvcCtrl;\r\n\r\n{$I jcl.inc}\r\n{$I windowsonly.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n {$IFDEF HAS_UNITSCOPE}\r\n Winapi.Windows, System.Classes, System.SysUtils, System.Contnrs,\r\n {$ELSE ~HAS_UNITSCOPE}\r\n Windows, Classes, SysUtils, Contnrs,\r\n {$ENDIF ~HAS_UNITSCOPE}\r\n {$IFDEF FPC}\r\n JwaWinNT, JwaWinSvc,\r\n {$ELSE ~FPC}\r\n {$IFDEF HAS_UNITSCOPE}\r\n Winapi.WinSvc,\r\n {$ELSE ~HAS_UNITSCOPE}\r\n WinSvc,\r\n {$ENDIF ~HAS_UNITSCOPE}\r\n {$ENDIF ~FPC}\r\n JclBase, JclSysUtils;\r\n\r\n// Service Types\r\ntype\r\n TJclServiceType =\r\n (stKernelDriver, // SERVICE_KERNEL_DRIVER\r\n stFileSystemDriver, // SERVICE_FILE_SYSTEM_DRIVER\r\n stAdapter, // SERVICE_ADAPTER\r\n stRecognizerDriver, // SERVICE_RECOGNIZER_DRIVER\r\n stWin32OwnProcess, // SERVICE_WIN32_OWN_PROCESS\r\n stWin32ShareProcess, // SERVICE_WIN32_SHARE_PROCESS\r\n stInteractiveProcess); // SERVICE_INTERACTIVE_PROCESS\r\n\r\n TJclServiceTypes = set of TJclServiceType;\r\n\r\nconst\r\n stDriverService = [stKernelDriver, stFileSystemDriver, stRecognizerDriver];\r\n stWin32Service = [stWin32OwnProcess, stWin32ShareProcess];\r\n stAllTypeService = stDriverService + stWin32Service + [stAdapter, stInteractiveProcess];\r\n\r\n// Service State\r\ntype\r\n TJclServiceState =\r\n (ssUnknown, // Just fill the value 0\r\n ssStopped, // SERVICE_STOPPED\r\n ssStartPending, // SERVICE_START_PENDING\r\n ssStopPending, // SERVICE_STOP_PENDING\r\n ssRunning, // SERVICE_RUNNING\r\n ssContinuePending, // SERVICE_CONTINUE_PENDING\r\n ssPausePending, // SERVICE_PAUSE_PENDING\r\n ssPaused); // SERVICE_PAUSED\r\n\r\n TJclServiceStates = set of TJclServiceState;\r\n\r\nconst\r\n ssPendingStates = [ssStartPending, ssStopPending, ssContinuePending, ssPausePending];\r\n\r\n// Start Type\r\ntype\r\n TJclServiceStartType =\r\n (sstBoot, // SERVICE_BOOT_START\r\n sstSystem, // SERVICE_SYSTEM_START\r\n sstAuto, // SERVICE_AUTO_START\r\n sstDemand, // SERVICE_DEMAND_START\r\n sstDisabled); // SERVICE_DISABLED\r\n\r\n// Error control type\r\ntype\r\n TJclServiceErrorControlType =\r\n (ectIgnore, // SSERVICE_ERROR_IGNORE\r\n ectNormal, // SSERVICE_ERROR_NORMAL\r\n ectSevere, // SSERVICE_ERROR_SEVERE\r\n ectCritical); // SERVICE_ERROR_CRITICAL\r\n\r\n\r\n// Controls Accepted\r\ntype\r\n TJclServiceControlAccepted =\r\n (caStop, // SERVICE_ACCEPT_STOP\r\n caPauseContinue, // SERVICE_ACCEPT_PAUSE_CONTINUE\r\n caShutdown); // SERVICE_ACCEPT_SHUTDOWN\r\n\r\n TJclServiceControlAccepteds = set of TJclServiceControlAccepted;\r\n\r\n// Service sort type\r\ntype\r\n TJclServiceSortOrderType =\r\n (sotServiceName,\r\n sotDisplayName,\r\n sotDescription,\r\n sotFileName,\r\n sotServiceState,\r\n sotStartType,\r\n sotErrorControlType,\r\n sotLoadOrderGroup,\r\n sotWin32ExitCode);\r\n\r\nconst\r\n // Everyone in WinNT/2K or Authenticated users in WinXP\r\n EveryoneSCMDesiredAccess =\r\n SC_MANAGER_CONNECT or\r\n SC_MANAGER_ENUMERATE_SERVICE or\r\n SC_MANAGER_QUERY_LOCK_STATUS or\r\n STANDARD_RIGHTS_READ;\r\n\r\n LocalSystemSCMDesiredAccess =\r\n SC_MANAGER_CONNECT or\r\n SC_MANAGER_ENUMERATE_SERVICE or\r\n SC_MANAGER_MODIFY_BOOT_CONFIG or\r\n SC_MANAGER_QUERY_LOCK_STATUS or\r\n STANDARD_RIGHTS_READ;\r\n\r\n AdministratorsSCMDesiredAccess = SC_MANAGER_ALL_ACCESS;\r\n DefaultSCMDesiredAccess = EveryoneSCMDesiredAccess;\r\n DefaultSvcDesiredAccess = SERVICE_ALL_ACCESS;\r\n\r\n// Service description\r\nconst\r\n SERVICE_CONFIG_DESCRIPTION = 1;\r\n {$EXTERNALSYM SERVICE_CONFIG_DESCRIPTION}\r\n SERVICE_CONFIG_FAILURE_ACTIONS = 2;\r\n {$EXTERNALSYM SERVICE_CONFIG_FAILURE_ACTIONS}\r\n\r\n{$IFNDEF FPC}\r\ntype\r\n LPSERVICE_DESCRIPTIONA = ^SERVICE_DESCRIPTIONA;\r\n {$EXTERNALSYM LPSERVICE_DESCRIPTIONA}\r\n SERVICE_DESCRIPTIONA = record\r\n lpDescription: LPSTR;\r\n end;\r\n {$EXTERNALSYM SERVICE_DESCRIPTIONA}\r\n TServiceDescriptionA = SERVICE_DESCRIPTIONA;\r\n PServiceDescriptionA = LPSERVICE_DESCRIPTIONA;\r\n{$ENDIF ~FPC}\r\n\r\ntype\r\n TQueryServiceConfig2A = function(hService: SC_HANDLE; dwInfoLevel: DWORD;\r\n lpBuffer: PByte; cbBufSize: DWORD; var pcbBytesNeeded: DWORD): BOOL; stdcall;\r\n\r\n// Service related classes\r\ntype\r\n TJclServiceGroup = class;\r\n TJclSCManager = class;\r\n\r\n TJclNtService = class(TObject)\r\n private\r\n FSCManager: TJclSCManager;\r\n FHandle: SC_HANDLE;\r\n FDesiredAccess: DWORD;\r\n FServiceName: string;\r\n FDisplayName: string;\r\n FDescription: string;\r\n FFileName: TFileName;\r\n FServiceStartName: string;\r\n FDependentServices: TList;\r\n FDependentGroups: TList;\r\n FDependentByServices: TList;\r\n FServiceTypes: TJclServiceTypes;\r\n FServiceState: TJclServiceState;\r\n FStartType: TJclServiceStartType;\r\n FErrorControlType: TJclServiceErrorControlType;\r\n FWin32ExitCode: DWORD;\r\n FGroup: TJclServiceGroup;\r\n FControlsAccepted: TJclServiceControlAccepteds;\r\n FCommitNeeded:Boolean;\r\n function GetActive: Boolean;\r\n procedure SetActive(const Value: Boolean);\r\n function GetDependentService(const Idx: Integer): TJclNtService;\r\n function GetDependentServiceCount: Integer;\r\n function GetDependentGroup(const Idx: Integer): TJclServiceGroup;\r\n function GetDependentGroupCount: Integer;\r\n function GetDependentByService(const Idx: Integer): TJclNtService;\r\n function GetDependentByServiceCount: Integer;\r\n protected\r\n procedure Open(const ADesiredAccess: DWORD = DefaultSvcDesiredAccess);\r\n procedure Close;\r\n function GetServiceStatus: TServiceStatus;\r\n procedure UpdateDescription;\r\n procedure UpdateDependents;\r\n procedure UpdateStatus(const SvcStatus: TServiceStatus);\r\n procedure UpdateConfig(const SvcConfig: TQueryServiceConfig);\r\n procedure CommitConfig(var SvcConfig: TQueryServiceConfig);\r\n procedure SetStartType(AStartType: TJclServiceStartType);\r\n public\r\n constructor Create(const ASCManager: TJclSCManager; const SvcStatus: TEnumServiceStatus);\r\n destructor Destroy; override;\r\n procedure Refresh;\r\n procedure Commit;\r\n procedure Delete;\r\n function Controls(const ControlType: DWORD; const ADesiredAccess: DWORD = DefaultSvcDesiredAccess): TServiceStatus;\r\n procedure Start(const Args: array of string; const Sync: Boolean = True); overload;\r\n procedure Start(const Sync: Boolean = True); overload;\r\n procedure Stop(const Sync: Boolean = True);\r\n procedure Pause(const Sync: Boolean = True);\r\n procedure Continue(const Sync: Boolean = True);\r\n function WaitFor(const State: TJclServiceState; const TimeOut: DWORD = INFINITE): Boolean;\r\n property SCManager: TJclSCManager read FSCManager;\r\n property Active: Boolean read GetActive write SetActive;\r\n property Handle: SC_HANDLE read FHandle;\r\n property ServiceName: string read FServiceName;\r\n property DisplayName: string read FDisplayName;\r\n property DesiredAccess: DWORD read FDesiredAccess;\r\n property Description: string read FDescription; // Win2K or later\r\n property FileName: TFileName read FFileName;\r\n property ServiceStartName: string read FServiceStartName;\r\n property DependentServices[const Idx: Integer]: TJclNtService read GetDependentService;\r\n property DependentServiceCount: Integer read GetDependentServiceCount;\r\n property DependentGroups[const Idx: Integer]: TJclServiceGroup read GetDependentGroup;\r\n property DependentGroupCount: Integer read GetDependentGroupCount;\r\n property DependentByServices[const Idx: Integer]: TJclNtService read GetDependentByService;\r\n property DependentByServiceCount: Integer read GetDependentByServiceCount;\r\n property ServiceTypes: TJclServiceTypes read FServiceTypes;\r\n property ServiceState: TJclServiceState read FServiceState;\r\n property StartType: TJclServiceStartType read FStartType write SetStartType;\r\n property ErrorControlType: TJclServiceErrorControlType read FErrorControlType;\r\n property Win32ExitCode: DWORD read FWin32ExitCode;\r\n property Group: TJclServiceGroup read FGroup;\r\n property ControlsAccepted: TJclServiceControlAccepteds read FControlsAccepted;\r\n end;\r\n\r\n TJclServiceGroup = class(TObject)\r\n private\r\n FSCManager: TJclSCManager;\r\n FName: string;\r\n FOrder: Integer;\r\n FServices: TList;\r\n function GetService(const Idx: Integer): TJclNtService;\r\n function GetServiceCount: Integer;\r\n protected\r\n function Add(const AService: TJclNtService): Integer;\r\n function Remove(const AService: TJclNtService): Integer;\r\n public\r\n constructor Create(const ASCManager: TJclSCManager; const AName: string; const AOrder: Integer);\r\n destructor Destroy; override;\r\n property SCManager: TJclSCManager read FSCManager;\r\n property Name: string read FName;\r\n property Order: Integer read FOrder;\r\n property Services[const Idx: Integer]: TJclNtService read GetService;\r\n property ServiceCount: Integer read GetServiceCount;\r\n end;\r\n\r\n TJclSCManager = class(TObject)\r\n private\r\n FMachineName: string;\r\n FDatabaseName: string;\r\n FDesiredAccess: DWORD;\r\n FHandle: SC_HANDLE;\r\n FLock: SC_LOCK;\r\n FServices: TObjectList;\r\n FGroups: TObjectList;\r\n FAdvApi32Handle: TModuleHandle;\r\n FQueryServiceConfig2A: TQueryServiceConfig2A;\r\n function GetActive: Boolean;\r\n procedure SetActive(const Value: Boolean);\r\n function GetService(const Idx: Integer): TJclNtService;\r\n function GetServiceCount: Integer;\r\n function GetGroup(const Idx: Integer): TJclServiceGroup;\r\n function GetGroupCount: Integer;\r\n procedure SetOrderAsc(const Value: Boolean);\r\n procedure SetOrderType(const Value: TJclServiceSortOrderType);\r\n function GetAdvApi32Handle: TModuleHandle;\r\n function GetQueryServiceConfig2A: TQueryServiceConfig2A;\r\n protected\r\n FOrderType: TJclServiceSortOrderType;\r\n FOrderAsc: Boolean;\r\n procedure Open;\r\n procedure Close;\r\n function AddService(const AService: TJclNtService): Integer;\r\n function AddGroup(const AGroup: TJclServiceGroup): Integer;\r\n function GetServiceLockStatus: PQueryServiceLockStatus;\r\n property AdvApi32Handle: TModuleHandle read GetAdvApi32Handle;\r\n property QueryServiceConfig2A: TQueryServiceConfig2A read GetQueryServiceConfig2A;\r\n public\r\n constructor Create(const AMachineName: string = '';\r\n const ADesiredAccess: DWORD = DefaultSCMDesiredAccess;\r\n const ADatabaseName: string = SERVICES_ACTIVE_DATABASE);\r\n destructor Destroy; override;\r\n procedure Clear;\r\n procedure Refresh(const RefreshAll: Boolean = False);\r\n function Install(const ServiceName, DisplayName, ImageName: string;\r\n const Description: string = '';\r\n ServiceTypes: TJclServiceTypes = [stWin32OwnProcess];\r\n StartType: TJclServiceStartType = sstDemand;\r\n ErrorControlType: TJclServiceErrorControlType = ectNormal;\r\n DesiredAccess: DWORD = DefaultSvcDesiredAccess;\r\n const LoadOrderGroup: TJclServiceGroup = nil; const Dependencies: PChar = nil;\r\n const Account: PChar = nil; const Password: PChar = nil): TJclNtService;\r\n procedure Sort(const AOrderType: TJclServiceSortOrderType; const AOrderAsc: Boolean = True);\r\n function FindService(const SvcName: string; out NtSvc: TJclNtService): Boolean;\r\n function FindGroup(const GrpName: string; out SvcGrp: TJclServiceGroup;\r\n const AutoAdd: Boolean = True): Boolean;\r\n procedure Lock;\r\n procedure Unlock;\r\n function IsLocked: Boolean;\r\n function LockOwner: string;\r\n function LockDuration: DWORD;\r\n class function ServiceType(const SvcType: TJclServiceTypes): DWORD; overload;\r\n class function ServiceType(const SvcType: DWORD): TJclServiceTypes; overload;\r\n class function ControlAccepted(const CtrlAccepted: TJclServiceControlAccepteds): DWORD; overload;\r\n class function ControlAccepted(const CtrlAccepted: DWORD): TJclServiceControlAccepteds; overload;\r\n property MachineName: string read FMachineName;\r\n property DatabaseName: string read FDatabaseName;\r\n property DesiredAccess: DWORD read FDesiredAccess;\r\n property Active: Boolean read GetActive write SetActive;\r\n property Handle: SC_HANDLE read FHandle;\r\n property Services[const Idx: Integer]: TJclNtService read GetService;\r\n property ServiceCount: Integer read GetServiceCount;\r\n property Groups[const Idx: Integer]: TJclServiceGroup read GetGroup;\r\n property GroupCount: Integer read GetGroupCount;\r\n property OrderType: TJclServiceSortOrderType read FOrderType write SetOrderType;\r\n property OrderAsc: Boolean read FOrderAsc write SetOrderAsc;\r\n end;\r\n\r\n// helper functions\r\nfunction GetServiceStatus(ServiceHandle: SC_HANDLE): DWORD;\r\nfunction GetServiceStatusWaitingIfPending(ServiceHandle: SC_HANDLE): DWORD;\r\n\r\nfunction GetServiceStatusByName(const AServer,AServiceName:string):TJclServiceState;\r\nfunction StopServiceByName(const AServer, AServiceName: String):Boolean;\r\nfunction StartServiceByName(const AServer,AServiceName: String):Boolean;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jcl.svn.sourceforge.net/svnroot/jcl/tags/JCL-2.4-Build4571/jcl/source/windows/JclSvcCtrl.pas $';\r\n Revision: '$Revision: 3861 $';\r\n Date: '$Date: 2012-09-04 16:08:04 +0200 (mar. 04 sept. 2012) $';\r\n LogPath: 'JCL\\source\\windows';\r\n Extra: '';\r\n Data: nil\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n {$IFDEF FPC}\r\n JwaRegStr,\r\n {$ELSE ~FPC}\r\n {$IFDEF HAS_UNITSCOPE}\r\n Winapi.RegStr,\r\n System.Types, // inlining of TList.Remove\r\n {$ELSE ~HAS_UNITSCOPE}\r\n RegStr,\r\n {$ENDIF ~HAS_UNITSCOPE}\r\n {$ENDIF ~FPC}\r\n {$IFDEF HAS_UNITSCOPE}\r\n System.Math,\r\n {$ELSE ~HAS_UNITSCOPE}\r\n Math,\r\n {$ENDIF ~HAS_UNITSCOPE}\r\n JclRegistry, JclStrings, JclSysInfo;\r\n\r\nconst\r\n INVALID_SCM_HANDLE = 0;\r\n\r\n ServiceTypeMapping: array [TJclServiceType] of DWORD =\r\n (SERVICE_KERNEL_DRIVER, SERVICE_FILE_SYSTEM_DRIVER, SERVICE_ADAPTER,\r\n SERVICE_RECOGNIZER_DRIVER, SERVICE_WIN32_OWN_PROCESS,\r\n SERVICE_WIN32_SHARE_PROCESS, SERVICE_INTERACTIVE_PROCESS);\r\n\r\n ServiceControlAcceptedMapping: array [TJclServiceControlAccepted] of DWORD =\r\n (SERVICE_ACCEPT_STOP, SERVICE_ACCEPT_PAUSE_CONTINUE, SERVICE_ACCEPT_SHUTDOWN);\r\n\r\n//=== { TJclNtService } ======================================================\r\n\r\nconstructor TJclNtService.Create(const ASCManager: TJclSCManager; const SvcStatus: TEnumServiceStatus);\r\nbegin\r\n Assert(Assigned(ASCManager));\r\n inherited Create;\r\n FSCManager := ASCManager;\r\n FHandle := INVALID_SCM_HANDLE;\r\n FServiceName := SvcStatus.lpServiceName;\r\n FDisplayName := SvcStatus.lpDisplayName;\r\n FDescription := '';\r\n FGroup := nil;\r\n FDependentServices := TList.Create;\r\n FDependentGroups := TList.Create;\r\n FDependentByServices := nil; // Create on demand\r\n FSCManager.AddService(Self);\r\nend;\r\n\r\ndestructor TJclNtService.Destroy;\r\nbegin\r\n FreeAndNil(FDependentServices);\r\n FreeAndNil(FDependentGroups);\r\n FreeAndNil(FDependentByServices);\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJclNtService.UpdateDescription;\r\nvar\r\n Ret: BOOL;\r\n BytesNeeded: DWORD;\r\n PSvcDesc: PServiceDescriptionA;\r\nbegin\r\n if Assigned(SCManager.QueryServiceConfig2A) then\r\n try\r\n PSvcDesc := nil;\r\n BytesNeeded := 4096;\r\n repeat\r\n ReallocMem(PSvcDesc, BytesNeeded);\r\n Ret := SCManager.QueryServiceConfig2A(FHandle, SERVICE_CONFIG_DESCRIPTION,\r\n PByte(PSvcDesc), BytesNeeded, BytesNeeded);\r\n until Ret or (GetLastError <> ERROR_INSUFFICIENT_BUFFER);\r\n Win32Check(Ret);\r\n\r\n FDescription := string(PSvcDesc.lpDescription);\r\n finally\r\n FreeMem(PSvcDesc);\r\n end;\r\nend;\r\n\r\nfunction TJclNtService.GetActive: Boolean;\r\nbegin\r\n Result := FHandle <> INVALID_SCM_HANDLE;\r\nend;\r\n\r\nprocedure TJclNtService.SetActive(const Value: Boolean);\r\nbegin\r\n if Value <> GetActive then\r\n begin\r\n if Value then\r\n Open\r\n else\r\n Close;\r\n Assert(Value = GetActive);\r\n end;\r\nend;\r\n\r\nprocedure TJclNtService.SetStartType(AStartType: TJclServiceStartType);\r\nbegin\r\n if AStartType <> FStartType then\r\n begin\r\n FStartType := AStartType;\r\n FCommitNeeded := True;\r\n end;\r\nend;\r\n\r\nprocedure TJclNtService.UpdateDependents;\r\nvar\r\n I: Integer;\r\n Ret: BOOL;\r\n PBuf: Pointer;\r\n PEss: PEnumServiceStatus;\r\n NtSvc: TJclNtService;\r\n BytesNeeded, ServicesReturned: DWORD;\r\nbegin\r\n Open(SERVICE_ENUMERATE_DEPENDENTS);\r\n try\r\n if Assigned(FDependentByServices) then\r\n FDependentByServices.Clear\r\n else\r\n FDependentByServices := TList.Create;\r\n\r\n try\r\n PBuf := nil;\r\n BytesNeeded := 40960;\r\n repeat\r\n ReallocMem(PBuf, BytesNeeded);\r\n ServicesReturned := 0;\r\n Ret := EnumDependentServices(FHandle, SERVICE_STATE_ALL,\r\n PEnumServiceStatus(PBuf){$IFNDEF FPC}^{$ENDIF}, BytesNeeded, BytesNeeded, ServicesReturned);\r\n until Ret or (GetLastError <> ERROR_INSUFFICIENT_BUFFER);\r\n Win32Check(Ret);\r\n\r\n PEss := PBuf;\r\n if ServicesReturned > 0 then\r\n for I := 0 to ServicesReturned - 1 do\r\n begin\r\n if (PEss.lpServiceName[1] <> SC_GROUP_IDENTIFIER) and\r\n (SCManager.FindService(PEss.lpServiceName, NtSvc)) then\r\n FDependentByServices.Add(NtSvc);\r\n Inc(PEss);\r\n end;\r\n finally\r\n FreeMem(PBuf);\r\n end;\r\n finally\r\n Close;\r\n end;\r\nend;\r\n\r\nfunction TJclNtService.GetDependentService(const Idx: Integer): TJclNtService;\r\nbegin\r\n Result := TJclNtService(FDependentServices.Items[Idx]);\r\nend;\r\n\r\nfunction TJclNtService.GetDependentServiceCount: Integer;\r\nbegin\r\n Result := FDependentServices.Count;\r\nend;\r\n\r\nfunction TJclNtService.GetDependentGroup(const Idx: Integer): TJclServiceGroup;\r\nbegin\r\n Result := TJclServiceGroup(FDependentGroups.Items[Idx]);\r\nend;\r\n\r\nfunction TJclNtService.GetDependentGroupCount: Integer;\r\nbegin\r\n Result := FDependentGroups.Count;\r\nend;\r\n\r\nfunction TJclNtService.GetDependentByService(const Idx: Integer): TJclNtService;\r\nbegin\r\n if not Assigned(FDependentByServices) then\r\n UpdateDependents;\r\n Result := TJclNtService(FDependentByServices.Items[Idx])\r\nend;\r\n\r\nfunction TJclNtService.GetDependentByServiceCount: Integer;\r\nbegin\r\n if not Assigned(FDependentByServices) then\r\n UpdateDependents;\r\n Result := FDependentByServices.Count;\r\nend;\r\n\r\nfunction TJclNtService.GetServiceStatus: TServiceStatus;\r\nbegin\r\n Assert(Active);\r\n Assert((DesiredAccess and SERVICE_QUERY_STATUS) <> 0);\r\n Win32Check(QueryServiceStatus(FHandle, Result));\r\nend;\r\n\r\n\r\nprocedure TJclNtService.UpdateStatus(const SvcStatus: TServiceStatus);\r\nbegin\r\n with SvcStatus do\r\n begin\r\n FServiceTypes := TJclSCManager.ServiceType(dwServiceType);\r\n FServiceState := TJclServiceState(dwCurrentState);\r\n FControlsAccepted := TJclSCManager.ControlAccepted(dwControlsAccepted);\r\n FWin32ExitCode := dwWin32ExitCode;\r\n end;\r\nend;\r\n\r\nprocedure TJclNtService.UpdateConfig(const SvcConfig: TQueryServiceConfig);\r\n\r\n procedure UpdateLoadOrderGroup;\r\n begin\r\n if not Assigned(FGroup) then\r\n SCManager.FindGroup(SvcConfig.lpLoadOrderGroup, FGroup)\r\n else\r\n if CompareText(Group.Name, SvcConfig.lpLoadOrderGroup) = 0 then\r\n begin\r\n FGroup.Remove(Self);\r\n SCManager.FindGroup(SvcConfig.lpLoadOrderGroup, FGroup);\r\n FGroup.Add(Self);\r\n end;\r\n end;\r\n\r\n procedure UpdateDependencies;\r\n var\r\n P: PChar;\r\n NtSvc: TJclNtService;\r\n SvcGrp: TJclServiceGroup;\r\n begin\r\n P := SvcConfig.lpDependencies;\r\n FDependentServices.Clear;\r\n FDependentGroups.Clear;\r\n if Assigned(P) then\r\n while P^ <> #0 do\r\n begin\r\n if P^ = SC_GROUP_IDENTIFIER then\r\n begin\r\n SCManager.FindGroup(P + 1, SvcGrp);\r\n FDependentGroups.Add(SvcGrp);\r\n end\r\n else\r\n if SCManager.FindService(P, NtSvc) then\r\n FDependentServices.Add(NtSvc);\r\n Inc(P, StrLen(P) + 1);\r\n end;\r\n end;\r\n\r\nbegin\r\n with SvcConfig do\r\n begin\r\n FFileName := lpBinaryPathName;\r\n FStartType := TJclServiceStartType(dwStartType);\r\n FServiceStartName := lpServiceStartName;\r\n FErrorControlType := TJclServiceErrorControlType(dwErrorControl);\r\n UpdateLoadOrderGroup;\r\n UpdateDependencies;\r\n end;\r\nend;\r\n\r\nprocedure TJclNtService.CommitConfig(var SvcConfig: TQueryServiceConfig);\r\nbegin\r\n with SvcConfig do\r\n begin\r\n StrCopy(lpBinaryPathName, PChar(FileName));\r\n dwStartType := Ord(StartType); {TJclServiceStartType}\r\n dwErrorControl := Ord(ErrorControlType); {TJclServiceErrorControlType}\r\n //UpdateLoadOrderGroup;\r\n //UpdateDependencies;\r\n end;\r\nend;\r\n\r\nprocedure TJclNtService.Open(const ADesiredAccess: DWORD);\r\nbegin\r\n Assert((ADesiredAccess and (not SERVICE_ALL_ACCESS)) = 0);\r\n Active := False;\r\n FDesiredAccess := ADesiredAccess;\r\n FHandle := OpenService(SCManager.Handle, PChar(ServiceName), DesiredAccess);\r\n Win32Check(FHandle <> INVALID_SCM_HANDLE);\r\nend;\r\n\r\nprocedure TJclNtService.Close;\r\nbegin\r\n Assert(Active);\r\n Win32Check(CloseServiceHandle(FHandle));\r\n FHandle := INVALID_SCM_HANDLE;\r\nend;\r\n\r\nprocedure TJclNtService.Refresh;\r\nvar\r\n Ret: BOOL;\r\n BytesNeeded: DWORD;\r\n PQrySvcCnfg: {$IFDEF RTL230_UP}LPQUERY_SERVICE_CONFIG{$ELSE}PQueryServiceConfig{$ENDIF RTL230_UP};\r\nbegin\r\n Open(SERVICE_QUERY_STATUS or SERVICE_QUERY_CONFIG);\r\n try\r\n UpdateDescription;\r\n UpdateStatus(GetServiceStatus);\r\n try\r\n PQrySvcCnfg := nil;\r\n BytesNeeded := 4096;\r\n repeat\r\n ReallocMem(PQrySvcCnfg, BytesNeeded);\r\n Ret := QueryServiceConfig(FHandle, PQrySvcCnfg, BytesNeeded, BytesNeeded);\r\n until Ret or (GetLastError <> ERROR_INSUFFICIENT_BUFFER);\r\n Win32Check(Ret);\r\n\r\n UpdateConfig(PQrySvcCnfg^);\r\n finally\r\n FreeMem(PQrySvcCnfg);\r\n end;\r\n finally\r\n Close;\r\n end;\r\nend;\r\n\r\n// Commit is reverse of Refresh.\r\nprocedure TJclNtService.Commit;\r\nvar\r\n Ret: BOOL;\r\n BytesNeeded: DWORD;\r\n PQrySvcCnfg: {$IFDEF RTL230_UP}LPQUERY_SERVICE_CONFIG{$ELSE}PQueryServiceConfig{$ENDIF RTL230_UP};\r\nbegin\r\n if not FCommitNeeded then\r\n Exit;\r\n FCommitNeeded := False;\r\n\r\n Open(SERVICE_CHANGE_CONFIG or SERVICE_QUERY_STATUS or SERVICE_QUERY_CONFIG);\r\n try\r\n //UpdateDescription;\r\n //UpdateStatus(GetServiceStatus);\r\n try\r\n PQrySvcCnfg := nil;\r\n BytesNeeded := 4096;\r\n repeat\r\n ReallocMem(PQrySvcCnfg, BytesNeeded);\r\n Ret := QueryServiceConfig(FHandle, PQrySvcCnfg, BytesNeeded, BytesNeeded);\r\n until Ret or (GetLastError <> ERROR_INSUFFICIENT_BUFFER);\r\n Win32Check(Ret);\r\n\r\n CommitConfig(PQrySvcCnfg^);\r\n Win32Check(ChangeServiceConfig(Handle,\r\n PQrySvcCnfg^.dwServiceType,\r\n PQrySvcCnfg^.dwStartType,\r\n PQrySvcCnfg^.dwErrorControl,\r\n nil, {PQrySvcCnfg^.lpBinaryPathName,}\r\n nil, {PQrySvcCnfg^.lpLoadOrderGroup,}\r\n nil, {PQrySvcCnfg^.dwTagId,}\r\n nil, {PQrySvcCnfg^.lpDependencies,}\r\n nil, {PQrySvcCnfg^.lpServiceStartName,}\r\n nil, {password-write only-not readable}\r\n PQrySvcCnfg^.lpDisplayName));\r\n finally\r\n FreeMem(PQrySvcCnfg);\r\n end;\r\n finally\r\n Close;\r\n end;\r\nend;\r\n\r\nprocedure TJclNtService.Delete;\r\n{$IFDEF FPC}\r\nconst\r\n _DELETE = $00010000; { Renamed from DELETE }\r\n{$ENDIF FPC}\r\nbegin\r\n Open(_DELETE);\r\n try\r\n Win32Check(DeleteService(FHandle));\r\n finally\r\n Close;\r\n end;\r\nend;\r\n\r\nprocedure TJclNtService.Start(const Args: array of string; const Sync: Boolean);\r\ntype\r\n PStrArray = ^TStrArray;\r\n TStrArray = array [0..32767] of PChar;\r\nvar\r\n I: Integer;\r\n PServiceArgVectors: PChar;\r\nbegin\r\n Open(SERVICE_START);\r\n try\r\n try\r\n if Length(Args) = 0 then\r\n PServiceArgVectors := nil\r\n else\r\n begin\r\n GetMem(PServiceArgVectors, SizeOf(PChar)*Length(Args));\r\n for I := 0 to Length(Args) - 1 do\r\n PStrArray(PServiceArgVectors)^[I] := PChar(Args[I]);\r\n end;\r\n Win32Check(StartService(FHandle, Length(Args), PServiceArgVectors));\r\n finally\r\n FreeMem(PServiceArgVectors);\r\n end;\r\n finally\r\n Close;\r\n end;\r\n if Sync then\r\n WaitFor(ssRunning);\r\nend;\r\n\r\nprocedure TJclNtService.Start(const Sync: Boolean = True);\r\nbegin\r\n Start([], Sync);\r\nend;\r\n\r\nfunction TJclNtService.Controls(const ControlType: DWORD; const ADesiredAccess: DWORD): TServiceStatus;\r\nbegin\r\n Open(ADesiredAccess);\r\n try\r\n Win32Check(ControlService(FHandle, ControlType, Result));\r\n finally\r\n Close;\r\n end;\r\nend;\r\n\r\nprocedure TJclNtService.Stop(const Sync: Boolean);\r\nbegin\r\n Controls(SERVICE_CONTROL_STOP, SERVICE_STOP);\r\n if Sync then\r\n WaitFor(ssStopped);\r\nend;\r\n\r\nprocedure TJclNtService.Pause(const Sync: Boolean);\r\nbegin\r\n Controls(SERVICE_CONTROL_PAUSE, SERVICE_PAUSE_CONTINUE);\r\n if Sync then\r\n WaitFor(ssPaused);\r\nend;\r\n\r\nprocedure TJclNtService.Continue(const Sync: Boolean);\r\nbegin\r\n Controls(SERVICE_CONTROL_CONTINUE, SERVICE_PAUSE_CONTINUE);\r\n if Sync then\r\n WaitFor(ssRunning);\r\nend;\r\n\r\nfunction TJclNtService.WaitFor(const State: TJclServiceState; const TimeOut: DWORD): Boolean;\r\nvar\r\n SvcStatus: TServiceStatus;\r\n WaitedState, StartTickCount, OldCheckPoint, WaitTime: DWORD;\r\nbegin\r\n WaitedState := DWORD(State);\r\n Open(SERVICE_QUERY_STATUS);\r\n try\r\n StartTickCount := GetTickCount;\r\n OldCheckPoint := 0;\r\n while True do\r\n begin\r\n SvcStatus := GetServiceStatus;\r\n if SvcStatus.dwCurrentState = WaitedState then\r\n Break;\r\n if SvcStatus.dwCheckPoint > OldCheckPoint then\r\n begin\r\n StartTickCount := GetTickCount;\r\n OldCheckPoint := SvcStatus.dwCheckPoint;\r\n end\r\n else\r\n begin\r\n if TimeOut <> INFINITE then\r\n { TODO : Do we need to disable RangeCheck? }\r\n if (GetTickCount - StartTickCount) > Max(SvcStatus.dwWaitHint, TimeOut) then\r\n Break;\r\n end;\r\n WaitTime := SvcStatus.dwWaitHint div 10;\r\n if WaitTime < 1000 then\r\n WaitTime := 1000\r\n else\r\n if WaitTime > 10000 then\r\n WaitTime := 10000;\r\n Sleep(WaitTime);\r\n end;\r\n Result := SvcStatus.dwCurrentState = WaitedState;\r\n finally\r\n Close;\r\n end;\r\nend;\r\n\r\n//=== { TJclServiceGroup } ===================================================\r\n\r\nconstructor TJclServiceGroup.Create(const ASCManager: TJclSCManager;\r\n const AName: string; const AOrder: Integer);\r\nbegin\r\n Assert(Assigned(ASCManager));\r\n inherited Create;\r\n FSCManager := ASCManager;\r\n FName := AName;\r\n if FName <> '' then\r\n FOrder := AOrder\r\n else\r\n FOrder := MaxInt;\r\n FServices := TList.Create;\r\nend;\r\n\r\ndestructor TJclServiceGroup.Destroy;\r\nbegin\r\n FreeAndNil(FServices);\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJclServiceGroup.Add(const AService: TJclNtService): Integer;\r\nbegin\r\n Result := FServices.Add(AService);\r\nend;\r\n\r\nfunction TJclServiceGroup.Remove(const AService: TJclNtService): Integer;\r\nbegin\r\n Result := FServices.Remove(AService);\r\nend;\r\n\r\nfunction TJclServiceGroup.GetService(const Idx: Integer): TJclNtService;\r\nbegin\r\n Result := TJclNtService(FServices.Items[Idx]);\r\nend;\r\n\r\nfunction TJclServiceGroup.GetServiceCount: Integer;\r\nbegin\r\n Result := FServices.Count;\r\nend;\r\n\r\n//=== { TJclSCManager } ======================================================\r\n\r\nconstructor TJclSCManager.Create(const AMachineName: string;\r\n const ADesiredAccess: DWORD; const ADatabaseName: string);\r\nbegin\r\n Assert((ADesiredAccess and (not SC_MANAGER_ALL_ACCESS)) = 0);\r\n inherited Create;\r\n FMachineName := AMachineName;\r\n FDatabaseName := ADatabaseName;\r\n FDesiredAccess := ADesiredAccess;\r\n FHandle := INVALID_SCM_HANDLE;\r\n FServices := TObjectList.Create;\r\n FGroups := TObjectList.Create;\r\n FOrderType := sotServiceName;\r\n FOrderAsc := True;\r\n FAdvApi32Handle := INVALID_MODULEHANDLE_VALUE;\r\n FQueryServiceConfig2A := nil;\r\nend;\r\n\r\ndestructor TJclSCManager.Destroy;\r\nbegin\r\n FreeAndNil(FGroups);\r\n FreeAndNil(FServices);\r\n Close;\r\n UnloadModule(FAdvApi32Handle);\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJclSCManager.AddService(const AService: TJclNtService): Integer;\r\nbegin\r\n Result := FServices.Add(AService);\r\nend;\r\n\r\nfunction TJclSCManager.GetService(const Idx: Integer): TJclNtService;\r\nbegin\r\n Result := TJclNtService(FServices.Items[Idx]);\r\nend;\r\n\r\nfunction TJclSCManager.GetServiceCount: Integer;\r\nbegin\r\n Result := FServices.Count;\r\nend;\r\n\r\nfunction TJclSCManager.AddGroup(const AGroup: TJclServiceGroup): Integer;\r\nbegin\r\n Result := FGroups.Add(AGroup);\r\nend;\r\n\r\nfunction TJclSCManager.GetGroup(const Idx: Integer): TJclServiceGroup;\r\nbegin\r\n Result := TJclServiceGroup(FGroups.Items[Idx]);\r\nend;\r\n\r\nfunction TJclSCManager.GetGroupCount: Integer;\r\nbegin\r\n Result := FGroups.Count;\r\nend;\r\n\r\nprocedure TJclSCManager.SetOrderAsc(const Value: Boolean);\r\nbegin\r\n if FOrderAsc <> Value then\r\n Sort(OrderType, Value);\r\nend;\r\n\r\nprocedure TJclSCManager.SetOrderType(const Value: TJclServiceSortOrderType);\r\nbegin\r\n if FOrderType <> Value then\r\n Sort(Value, FOrderAsc);\r\nend;\r\n\r\nfunction TJclSCManager.GetActive: Boolean;\r\nbegin\r\n Result := FHandle <> INVALID_SCM_HANDLE;\r\nend;\r\n\r\nprocedure TJclSCManager.SetActive(const Value: Boolean);\r\nbegin\r\n if Value <> GetActive then\r\n begin\r\n if Value then\r\n Open\r\n else\r\n Close;\r\n Assert(Value = GetActive);\r\n end;\r\nend;\r\n\r\nprocedure TJclSCManager.Open;\r\nbegin\r\n if not Active then\r\n begin\r\n FHandle := OpenSCManager(Pointer(FMachineName), Pointer(FDatabaseName), FDesiredAccess);\r\n Win32Check(FHandle <> INVALID_SCM_HANDLE);\r\n end;\r\nend;\r\n\r\nprocedure TJclSCManager.Close;\r\nbegin\r\n if Active then\r\n Win32Check(CloseServiceHandle(FHandle));\r\n FHandle := INVALID_SCM_HANDLE;\r\nend;\r\n\r\nprocedure TJclSCManager.Lock;\r\nbegin\r\n Assert((DesiredAccess and SC_MANAGER_LOCK) <> 0);\r\n Active := True;\r\n FLock := LockServiceDatabase(FHandle);\r\n Win32Check(FLock <> nil);\r\nend;\r\n\r\nprocedure TJclSCManager.Unlock;\r\nbegin\r\n Assert(Active);\r\n Assert((DesiredAccess and SC_MANAGER_LOCK) <> 0);\r\n Assert(FLock <> nil);\r\n Win32Check(UnlockServiceDatabase(FLock));\r\nend;\r\n\r\nprocedure TJclSCManager.Clear;\r\nbegin\r\n FServices.Clear;\r\n FGroups.Clear;\r\nend;\r\n\r\nprocedure TJclSCManager.Refresh(const RefreshAll: Boolean);\r\n\r\n procedure EnumServices;\r\n var\r\n I: Integer;\r\n Ret: BOOL;\r\n PBuf: Pointer;\r\n PEss: PEnumServiceStatus;\r\n NtSvc: TJclNtService;\r\n BytesNeeded, ServicesReturned, ResumeHandle: DWORD;\r\n LastError: Cardinal;\r\n begin\r\n Assert((DesiredAccess and SC_MANAGER_ENUMERATE_SERVICE) <> 0);\r\n // Enum the services\r\n ResumeHandle := 0; // Must set this value to zero !!!\r\n try\r\n PBuf := nil;\r\n BytesNeeded := 0;\r\n //from MSDN:\r\n //The maximum size of this array is 256K bytes. To determine the required\r\n //size, specify NULL for this parameter and 0 for the cbBufSize parameter.\r\n //The function will fail and GetLastError will return\r\n //ERROR_INSUFFICIENT_BUFFER. The pcbBytesNeeded parameter will receive the\r\n //required size.\r\n\r\n //(it doesn't actually return ERROR_INSUFFICIENT_BUFFER apparently)\r\n\r\n repeat\r\n ReallocMem(PBuf, BytesNeeded);\r\n ServicesReturned := 0;\r\n Ret := EnumServicesStatus(FHandle, SERVICE_TYPE_ALL, SERVICE_STATE_ALL,\r\n PEnumServiceStatus(PBuf){$IFNDEF FPC}^{$ENDIF},\r\n BytesNeeded, BytesNeeded, ServicesReturned, ResumeHandle);\r\n LastError := GetLastError;\r\n\r\n if (ServicesReturned > 0) and (Ret or (LastError = ERROR_MORE_DATA)) then\r\n begin\r\n PEss := PBuf;\r\n for I := 0 to ServicesReturned - 1 do\r\n begin\r\n NtSvc := TJclNtService.Create(Self, PEss^);\r\n try\r\n NtSvc.Refresh;\r\n except\r\n // trap invalid services\r\n end;\r\n Inc(PEss);\r\n end;\r\n end;\r\n until Ret or (LastError <> ERROR_MORE_DATA);\r\n Win32Check(Ret);\r\n\r\n finally\r\n FreeMem(PBuf);\r\n end;\r\n end;\r\n\r\n { TODO : Delete after Test }\r\n {procedure EnumServiceGroups;\r\n const\r\n cKeyServiceGroupOrder = 'SYSTEM\\CurrentControlSet\\Control\\ServiceGroupOrder';\r\n cValList = 'List';\r\n var\r\n Buf: array of Char;\r\n P: PChar;\r\n DataSize: DWORD;\r\n begin\r\n // Get the service groups\r\n DataSize := RegReadBinary(HKEY_LOCAL_MACHINE, cKeyServiceGroupOrder, cValList, PChar(nil)^, 0);\r\n SetLength(Buf, DataSize);\r\n if DataSize > 0 then\r\n begin\r\n DataSize := RegReadBinary(HKEY_LOCAL_MACHINE, cKeyServiceGroupOrder, cValList, Buf[0], DataSize);\r\n\r\n P := @Buf[0];\r\n while P^ <> #0 do\r\n begin\r\n AddGroup(TJclServiceGroup.Create(Self, P, GetGroupCount));\r\n Inc(P, StrLen(P) + 1);\r\n end;\r\n end;\r\n end;}\r\n\r\n { TODO -cTest : Test, if OK delete function above }\r\n { TODO -cHelp : }\r\n procedure EnumServiceGroups;\r\n const\r\n cKeyServiceGroupOrder = 'SYSTEM\\CurrentControlSet\\Control\\ServiceGroupOrder';\r\n cValList = 'List';\r\n var\r\n List: TStringList;\r\n I: Integer;\r\n begin\r\n // Get the service groups\r\n List := TStringList.Create;\r\n try\r\n RegReadMultiSz(HKEY_LOCAL_MACHINE, cKeyServiceGroupOrder, cValList, List);\r\n for I := 0 to List.Count - 1 do\r\n AddGroup(TJclServiceGroup.Create(Self, List[I], GetGroupCount));\r\n finally\r\n List.Free;\r\n end;\r\n end;\r\n\r\n procedure RefreshAllServices;\r\n var\r\n I: Integer;\r\n begin\r\n for I := 0 to GetServiceCount - 1 do\r\n try\r\n GetService(I).Refresh;\r\n except\r\n // trap invalid services\r\n end;\r\n end;\r\n\r\nbegin\r\n Active := True;\r\n if RefreshAll then\r\n begin\r\n Clear;\r\n EnumServiceGroups;\r\n EnumServices;\r\n end;\r\n RefreshAllServices;\r\nend;\r\n\r\nfunction ServiceSortFunc(Item1, Item2: Pointer): Integer;\r\nvar\r\n Svc1, Svc2: TJclNtService;\r\nbegin\r\n Svc1 := Item1;\r\n Svc2 := Item2;\r\n case Svc1.SCManager.FOrderType of\r\n sotServiceName:\r\n Result := AnsiCompareStr(Svc1.ServiceName, Svc2.ServiceName);\r\n sotDisplayName:\r\n Result := AnsiCompareStr(Svc1.DisplayName, Svc2.DisplayName);\r\n sotDescription:\r\n Result := AnsiCompareStr(Svc1.Description, Svc2.Description);\r\n sotFileName:\r\n Result := AnsiCompareStr(Svc1.FileName, Svc2.FileName);\r\n sotServiceState:\r\n Result := Integer(Svc1.ServiceState) - Integer(Svc2.ServiceState);\r\n sotStartType:\r\n Result := Integer(Svc1.StartType) - Integer(Svc2.StartType);\r\n sotErrorControlType:\r\n Result := Integer(Svc1.ErrorControlType) - Integer(Svc2.ErrorControlType);\r\n sotLoadOrderGroup:\r\n Result := Svc1.Group.Order - Svc2.Group.Order;\r\n sotWin32ExitCode:\r\n Result := Svc1.Win32ExitCode - Svc2.Win32ExitCode;\r\n else\r\n Result := 0;\r\n end;\r\n if not Svc1.SCManager.FOrderAsc then\r\n Result := -Result;\r\nend;\r\n\r\nprocedure TJclSCManager.Sort(const AOrderType: TJclServiceSortOrderType; const AOrderAsc: Boolean);\r\nbegin\r\n FOrderType := AOrderType;\r\n FOrderAsc := AOrderAsc;\r\n FServices.Sort(ServiceSortFunc);\r\nend;\r\n\r\nfunction TJclSCManager.FindService(const SvcName: string; out NtSvc: TJclNtService): Boolean;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := False;\r\n for I := 0 to GetServiceCount - 1 do\r\n begin\r\n NtSvc := GetService(I);\r\n if CompareText(NtSvc.ServiceName, SvcName) = 0 then\r\n begin\r\n Result := True;\r\n Exit;\r\n end;\r\n end;\r\n NtSvc := nil;\r\nend;\r\n\r\nfunction TJclSCManager.FindGroup(const GrpName: string; out SvcGrp: TJclServiceGroup;\r\n const AutoAdd: Boolean): Boolean;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := False;\r\n for I := 0 to GetGroupCount - 1 do\r\n begin\r\n if CompareText(GetGroup(I).Name, GrpName) = 0 then\r\n begin\r\n SvcGrp := GetGroup(I);\r\n Result := True;\r\n Exit;\r\n end;\r\n end;\r\n if AutoAdd then\r\n begin\r\n SvcGrp := TJclServiceGroup.Create(Self, GrpName, GetGroupCount);\r\n AddGroup(SvcGrp);\r\n end\r\n else\r\n SvcGrp := nil;\r\nend;\r\n\r\nfunction TJclSCManager.GetServiceLockStatus: PQueryServiceLockStatus;\r\nvar\r\n Ret: BOOL;\r\n BytesNeeded: DWORD;\r\nbegin\r\n Assert((DesiredAccess and SC_MANAGER_QUERY_LOCK_STATUS) <> 0);\r\n Active := True;\r\n\r\n try\r\n Result := nil;\r\n BytesNeeded := 10240;\r\n repeat\r\n ReallocMem(Result, BytesNeeded);\r\n Ret := QueryServiceLockStatus(FHandle, Result{$IFNDEF FPC}^{$ENDIF FPC}, BytesNeeded, BytesNeeded);\r\n until Ret or (GetLastError <> ERROR_INSUFFICIENT_BUFFER);\r\n Win32Check(Ret);\r\n except\r\n FreeMem(Result);\r\n raise;\r\n end;\r\nend;\r\n\r\nfunction TJclSCManager.IsLocked: Boolean;\r\nvar\r\n PQsls: PQueryServiceLockStatus;\r\nbegin\r\n PQsls := GetServiceLockStatus;\r\n Result := Assigned(PQsls) and (PQsls.fIsLocked <> 0);\r\n FreeMem(PQsls);\r\nend;\r\n\r\nfunction TJclSCManager.LockOwner: string;\r\nvar\r\n PQsls: PQueryServiceLockStatus;\r\nbegin\r\n PQsls := GetServiceLockStatus;\r\n if Assigned(PQsls) then\r\n Result := PQsls.lpLockOwner\r\n else\r\n Result := '';\r\n FreeMem(PQsls);\r\nend;\r\n\r\nfunction TJclSCManager.LockDuration: DWORD;\r\nvar\r\n PQsls: PQueryServiceLockStatus;\r\nbegin\r\n PQsls := GetServiceLockStatus;\r\n if Assigned(PQsls) then\r\n Result := PQsls.dwLockDuration\r\n else\r\n Result := INFINITE;\r\n FreeMem(PQsls);\r\nend;\r\n\r\nfunction TJclSCManager.GetAdvApi32Handle: TModuleHandle;\r\nconst\r\n cAdvApi32 = 'advapi32.dll'; // don't localize\r\nbegin\r\n if FAdvApi32Handle = INVALID_MODULEHANDLE_VALUE then\r\n LoadModule(FAdvApi32Handle, cAdvApi32);\r\n Result := FAdvApi32Handle;\r\nend;\r\n\r\n{ TODO : Standard Rtdl }\r\nfunction TJclSCManager.GetQueryServiceConfig2A: TQueryServiceConfig2A;\r\nconst\r\n cQueryServiceConfig2 = 'QueryServiceConfig2A'; // don't localize\r\nbegin\r\n // Win2K or later\r\n if (Win32Platform = VER_PLATFORM_WIN32_NT) and (Win32MajorVersion >= 5) then\r\n FQueryServiceConfig2A := GetModuleSymbol(AdvApi32Handle, cQueryServiceConfig2);\r\n\r\n Result := FQueryServiceConfig2A;\r\nend;\r\n\r\nfunction TJclSCManager.Install(const ServiceName, DisplayName, ImageName, Description: string;\r\n ServiceTypes: TJclServiceTypes; StartType: TJclServiceStartType;\r\n ErrorControlType: TJclServiceErrorControlType; DesiredAccess: DWORD;\r\n const LoadOrderGroup: TJclServiceGroup;\r\n const Dependencies, Account, Password: PChar): TJclNtService;\r\nvar\r\n LoadOrderGroupName: string;\r\n LoadOrderGroupNamePtr: PChar;\r\n EnumServiceStatus: TEnumServiceStatus;\r\n Svc: THandle;\r\nbegin\r\n if Assigned(LoadOrderGroup) then\r\n begin\r\n LoadOrderGroupName := LoadOrderGroup.Name;\r\n LoadOrderGroupNamePtr := PChar(LoadOrderGroupName);\r\n end\r\n else\r\n begin\r\n LoadOrderGroupName := '';\r\n LoadOrderGroupNamePtr := nil;\r\n end;\r\n\r\n Svc := CreateService(FHandle, PChar(ServiceName), PChar(DisplayName),\r\n DesiredAccess, TJclSCManager.ServiceType(ServiceTypes), DWORD(StartType),\r\n DWORD(ErrorControlType), PChar(ImageName), LoadOrderGroupNamePtr, nil,\r\n Dependencies, Account, Password);\r\n if Svc = 0 then\r\n RaiseLastOsError;\r\n CloseServiceHandle(Svc);\r\n\r\n if (Description <> '') and (GetWindowsVersion >= wvWin2000) then\r\n RegWriteString(HKEY_LOCAL_MACHINE, '\\' + REGSTR_PATH_SERVICES + '\\' + ServiceName,\r\n 'Description', Description);\r\n\r\n EnumServiceStatus.lpServiceName := PChar(ServiceName);\r\n EnumServiceStatus.lpDisplayName := PChar(DisplayName);\r\n\r\n Result := TJclNtService.Create(Self, EnumServiceStatus);\r\n Result.Refresh;\r\nend;\r\n\r\nclass function TJclSCManager.ServiceType(const SvcType: TJclServiceTypes): DWORD;\r\nvar\r\n AType: TJclServiceType;\r\nbegin\r\n Result := 0;\r\n for AType := Low(TJclServiceType) to High(TJclServiceType) do\r\n if AType in SvcType then\r\n Result := Result or ServiceTypeMapping[AType];\r\nend;\r\n\r\nclass function TJclSCManager.ServiceType(const SvcType: DWORD): TJclServiceTypes;\r\nvar\r\n AType: TJclServiceType;\r\nbegin\r\n Result := [];\r\n for AType := Low(TJclServiceType) to High(TJclServiceType) do\r\n if (SvcType and ServiceTypeMapping[AType]) <> 0 then\r\n Include(Result, AType);\r\nend;\r\n\r\nclass function TJclSCManager.ControlAccepted(const CtrlAccepted: TJclServiceControlAccepteds): DWORD;\r\nvar\r\n ACtrl: TJclServiceControlAccepted;\r\nbegin\r\n Result := 0;\r\n for ACtrl := Low(TJclServiceControlAccepted) to High(TJclServiceControlAccepted) do\r\n if ACtrl in CtrlAccepted then\r\n Result := Result or ServiceControlAcceptedMapping[ACtrl];\r\nend;\r\n\r\nclass function TJclSCManager.ControlAccepted(const CtrlAccepted: DWORD): TJclServiceControlAccepteds;\r\nvar\r\n ACtrl: TJclServiceControlAccepted;\r\nbegin\r\n Result := [];\r\n for ACtrl := Low(TJclServiceControlAccepted) to High(TJclServiceControlAccepted) do\r\n if (CtrlAccepted and ServiceControlAcceptedMapping[ACtrl]) <> 0 then\r\n Include(Result, ACtrl);\r\nend;\r\n\r\nfunction GetServiceStatusByName(const AServer,AServiceName:string):TJclServiceState;\r\nvar\r\n ServiceHandle,\r\n SCMHandle: DWORD;\r\n SCMAccess,Access:DWORD;\r\n ServiceStatus: TServiceStatus;\r\nbegin\r\n Result:=ssUnknown;\r\n\r\n SCMAccess:=SC_MANAGER_CONNECT or SC_MANAGER_ENUMERATE_SERVICE or SC_MANAGER_QUERY_LOCK_STATUS;\r\n Access:=SERVICE_INTERROGATE or GENERIC_READ;\r\n\r\n SCMHandle:= OpenSCManager(PChar(AServer), Nil, SCMAccess);\r\n if SCMHandle <> 0 then\r\n try\r\n ServiceHandle:=OpenService(SCMHandle,PChar(AServiceName),Access);\r\n if ServiceHandle <> 0 then\r\n try\r\n ResetMemory(ServiceStatus, SizeOf(ServiceStatus));\r\n if QueryServiceStatus(ServiceHandle,ServiceStatus) then\r\n Result:=TJclServiceState(ServiceStatus.dwCurrentState);\r\n finally\r\n CloseServiceHandle(ServiceHandle);\r\n end;\r\n finally\r\n CloseServiceHandle(SCMHandle);\r\n end;\r\nend;\r\n\r\nfunction StartServiceByName(const AServer,AServiceName: String):Boolean;\r\nvar\r\n ServiceHandle,\r\n SCMHandle: DWORD;\r\n p: PChar;\r\nbegin\r\n p:=nil;\r\n Result:=False;\r\n\r\n SCMHandle:= OpenSCManager(PChar(AServer), nil, SC_MANAGER_ALL_ACCESS);\r\n if SCMHandle <> 0 then\r\n try\r\n ServiceHandle:=OpenService(SCMHandle,PChar(AServiceName),SERVICE_ALL_ACCESS);\r\n if ServiceHandle <> 0 then\r\n Result:=StartService(ServiceHandle,0,p);\r\n\r\n CloseServiceHandle(ServiceHandle);\r\n finally\r\n CloseServiceHandle(SCMHandle);\r\n end;\r\nend;\r\n\r\nfunction StopServiceByName(const AServer, AServiceName: String):Boolean;\r\nvar\r\n ServiceHandle,\r\n SCMHandle: DWORD;\r\n SS: _Service_Status;\r\nbegin\r\n Result := False;\r\n\r\n SCMHandle := OpenSCManager(PChar(AServer), nil, SC_MANAGER_ALL_ACCESS);\r\n if SCMHandle <> 0 then\r\n try\r\n ServiceHandle := OpenService(SCMHandle, PChar(AServiceName), SERVICE_ALL_ACCESS);\r\n if ServiceHandle <> 0 then\r\n begin\r\n ResetMemory(SS, SizeOf(SS));\r\n Result := ControlService(ServiceHandle, SERVICE_CONTROL_STOP, SS);\r\n end;\r\n\r\n CloseServiceHandle(ServiceHandle);\r\n finally\r\n CloseServiceHandle(SCMHandle);\r\n end;\r\nend;\r\n\r\nfunction GetServiceStatus(ServiceHandle: SC_HANDLE): DWORD;\r\nvar\r\n ServiceStatus: TServiceStatus;\r\nbegin\r\n ResetMemory(ServiceStatus, SizeOf(ServiceStatus));\r\n if not QueryServiceStatus(ServiceHandle, ServiceStatus) then\r\n RaiseLastOSError;\r\n\r\n Result := ServiceStatus.dwCurrentState;\r\nend;\r\n\r\nfunction GetServiceStatusWaitingIfPending(ServiceHandle: SC_HANDLE): DWORD;\r\nvar\r\n ServiceStatus: TServiceStatus;\r\n WaitDuration: DWORD;\r\n LastCheckPoint: DWORD;\r\nbegin\r\n ResetMemory(ServiceStatus, SizeOf(ServiceStatus));\r\n if not QueryServiceStatus(ServiceHandle, ServiceStatus) then\r\n RaiseLastOSError;\r\n\r\n Result := ServiceStatus.dwCurrentState;\r\n\r\n while TJclServiceState(Result) in ssPendingStates do\r\n begin\r\n LastCheckPoint := ServiceStatus.dwCheckPoint;\r\n\r\n // Multiple operations might alter the expected wait duration, so check inside the loop\r\n WaitDuration := ServiceStatus.dwWaitHint;\r\n if WaitDuration < 1000 then\r\n WaitDuration := 1000\r\n else\r\n if WaitDuration > 10000 then\r\n WaitDuration := 10000;\r\n\r\n Sleep(WaitDuration);\r\n\r\n // Get the new status\r\n if not QueryServiceStatus(ServiceHandle, ServiceStatus) then\r\n RaiseLastOSError;\r\n\r\n Result := ServiceStatus.dwCurrentState;\r\n\r\n if ServiceStatus.dwCheckPoint = LastCheckPoint then // No progress made\r\n Break;\r\n end;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jcl/source/windows/JclTD32.pas", "content": "{**************************************************************************************************}\r\n{ }\r\n{ Project JEDI Code Library (JCL) }\r\n{ }\r\n{ The contents of this file are subject to the Mozilla Public License Version 1.1 (the \"License\"); }\r\n{ you may not use this file except in compliance with the License. You may obtain a copy of the }\r\n{ License at http://www.mozilla.org/MPL/ }\r\n{ }\r\n{ Software distributed under the License is distributed on an \"AS IS\" basis, WITHOUT WARRANTY OF }\r\n{ ANY KIND, either express or implied. See the License for the specific language governing rights }\r\n{ and limitations under the License. }\r\n{ }\r\n{ The Original Code is JclTD32.pas. }\r\n{ }\r\n{ The Initial Developer of the Original Code is Flier Lu (). }\r\n{ Portions created by Flier Lu are Copyright (C) Flier Lu. All Rights Reserved. }\r\n{ }\r\n{ Contributors: }\r\n{ Flier Lu (flier) }\r\n{ Olivier Sannier (obones) }\r\n{ Petr Vones (pvones) }\r\n{ Heinz Zastrau (heinzz) }\r\n{ Andreas Hausladen (ahuser) }\r\n{ }\r\n{**************************************************************************************************}\r\n{ }\r\n{ Borland TD32 symbolic debugging information support routines and classes. }\r\n{ }\r\n{**************************************************************************************************}\r\n{ }\r\n{ Last modified: $Date:: 2011-09-03 00:07:50 +0200 (sam. 03 sept. 2011) $ }\r\n{ Revision: $Rev:: 3599 $ }\r\n{ Author: $Author:: outchy $ }\r\n{ }\r\n{**************************************************************************************************}\r\n\r\nunit JclTD32;\r\n\r\ninterface\r\n\r\n{$I jcl.inc}\r\n{$I windowsonly.inc}\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n {$IFDEF HAS_UNITSCOPE}\r\n {$IFDEF MSWINDOWS}\r\n Winapi.Windows,\r\n {$ENDIF MSWINDOWS}\r\n System.Classes, System.SysUtils, System.Contnrs,\r\n {$ELSE ~HAS_UNITSCOPE}\r\n {$IFDEF MSWINDOWS}\r\n Windows,\r\n {$ENDIF MSWINDOWS}\r\n Classes, SysUtils, Contnrs,\r\n {$ENDIF ~HAS_UNITSCOPE}\r\n JclBase,\r\n {$IFDEF BORLAND}\r\n JclPeImage,\r\n {$ENDIF BORLAND}\r\n JclFileUtils;\r\n\r\n{ TODO -cDOC : Original code: \"Flier Lu\" }\r\n\r\n// TD32 constants and structures\r\n{*******************************************************************************\r\n\r\n [-----------------------------------------------------------------------]\r\n [ Symbol and Type OMF Format Borland Executable Files ]\r\n [-----------------------------------------------------------------------]\r\n\r\n Introduction\r\n\r\n This section describes the format used to embed debugging information into\r\n the executable file.\r\n\r\n Debug Information Format\r\n\r\n The format encompasses a block of data which goes at the end of the .EXE\r\n file, i.e., after the header plus load image, overlays, and\r\n Windows/Presentation Manager resource compiler information. The lower\r\n portion of the file is unaffected by the additional data.\r\n\r\n The last eight bytes of the file contain a signature and a long file offset\r\n from the end of the file (lfoBase). The signature is FBxx, where xx is the\r\n version number. The long offset indicates the position in the file\r\n (relative to the end of the file) of the base address. For the LX format\r\n executables, the base address is determined by looking at the executable\r\n header.\r\n\r\n The signatures have the following meanings:\r\n\r\n FB09 The signature for a Borland 32 bit symbol file.\r\n\r\n The value\r\n\r\n lfaBase=length of the file - lfoBase\r\n\r\n gives the base address of the start of the Symbol and Type OMF information\r\n relative to the beginning of the file. All other file offsets in the\r\n Symbol and Type OMF are relative to the lfaBase. At the base address the\r\n signature is repeated, followed by the long displacement to the subsection\r\n directory (lfoDir). All subsections start on a long word boundary and are\r\n designed to maintain natural alignment internally in each subsection and\r\n within the subsection directory.\r\n\r\n Subsection Directory\r\n\r\n The subsection directory has the format\r\n\r\n Directory header\r\n\r\n Directory entry 0\r\n\r\n Directory entry 1\r\n\r\n .\r\n .\r\n .\r\n\r\n Directory entry n\r\n\r\n There is no requirement for a particular subsection of a particular module to exist.\r\n\r\n The following is the layout of the FB09 debug information in the image:\r\n\r\n FB09 Header\r\n\r\n sstModule [1]\r\n .\r\n .\r\n .\r\n sstModule [n]\r\n\r\n sstAlignSym [1]\r\n sstSrcModule [1]\r\n .\r\n .\r\n .\r\n sstAlignSym [n]\r\n sstSrcModule [n]\r\n\r\n sstGlobalSym\r\n sstGlobalTypes\r\n sstNames\r\n\r\n SubSection Directory\r\n\r\n FB09 Trailer\r\n\r\n*******************************************************************************}\r\n\r\nconst\r\n Borland32BitSymbolFileSignatureForDelphi = $39304246; // 'FB09'\r\n Borland32BitSymbolFileSignatureForBCB = $41304246; // 'FB0A'\r\n\r\ntype\r\n { Signature structure }\r\n PJclTD32FileSignature = ^TJclTD32FileSignature;\r\n TJclTD32FileSignature = packed record\r\n Signature: DWORD;\r\n Offset: DWORD;\r\n end;\r\n\r\nconst\r\n { Subsection Types }\r\n SUBSECTION_TYPE_MODULE = $120;\r\n SUBSECTION_TYPE_TYPES = $121;\r\n SUBSECTION_TYPE_SYMBOLS = $124;\r\n SUBSECTION_TYPE_ALIGN_SYMBOLS = $125;\r\n SUBSECTION_TYPE_SOURCE_MODULE = $127;\r\n SUBSECTION_TYPE_GLOBAL_SYMBOLS = $129;\r\n SUBSECTION_TYPE_GLOBAL_TYPES = $12B;\r\n SUBSECTION_TYPE_NAMES = $130;\r\n\r\ntype\r\n { Subsection directory header structure }\r\n { The directory header structure is followed by the directory entries\r\n which specify the subsection type, module index, file offset, and size.\r\n The subsection directory gives the location (LFO) and size of each subsection,\r\n as well as its type and module number if applicable. }\r\n PDirectoryEntry = ^TDirectoryEntry;\r\n TDirectoryEntry = packed record\r\n SubsectionType: Word; // Subdirectory type\r\n ModuleIndex: Word; // Module index\r\n Offset: DWORD; // Offset from the base offset lfoBase\r\n Size: DWORD; // Number of bytes in subsection\r\n end;\r\n\r\n { The subsection directory is prefixed with a directory header structure\r\n indicating size and number of subsection directory entries that follow. }\r\n PDirectoryHeader = ^TDirectoryHeader;\r\n TDirectoryHeader = packed record\r\n Size: Word; // Length of this structure\r\n DirEntrySize: Word; // Length of each directory entry\r\n DirEntryCount: DWORD; // Number of directory entries\r\n lfoNextDir: DWORD; // Offset from lfoBase of next directory.\r\n Flags: DWORD; // Flags describing directory and subsection tables.\r\n DirEntries: array [0..0] of TDirectoryEntry;\r\n end;\r\n\r\n\r\n{*******************************************************************************\r\n\r\n SUBSECTION_TYPE_MODULE $120\r\n\r\n This describes the basic information about an object module including code\r\n segments, module name, and the number of segments for the modules that\r\n follow. Directory entries for sstModules precede all other subsection\r\n directory entries.\r\n\r\n*******************************************************************************}\r\n\r\ntype\r\n PSegmentInfo = ^TSegmentInfo;\r\n TSegmentInfo = packed record\r\n Segment: Word; // Segment that this structure describes\r\n Flags: Word; // Attributes for the logical segment.\r\n // The following attributes are defined:\r\n // $0000 Data segment\r\n // $0001 Code segment\r\n Offset: DWORD; // Offset in segment where the code starts\r\n Size: DWORD; // Count of the number of bytes of code in the segment\r\n end;\r\n PSegmentInfoArray = ^TSegmentInfoArray;\r\n TSegmentInfoArray = array [0..32767] of TSegmentInfo;\r\n\r\n PModuleInfo = ^TModuleInfo;\r\n TModuleInfo = packed record\r\n OverlayNumber: Word; // Overlay number\r\n LibraryIndex: Word; // Index into sstLibraries subsection\r\n // if this module was linked from a library\r\n SegmentCount: Word; // Count of the number of code segments\r\n // this module contributes to\r\n DebuggingStyle: Word; // Debugging style for this module.\r\n NameIndex: DWORD; // Name index of module.\r\n TimeStamp: DWORD; // Time stamp from the OBJ file.\r\n Reserved: array [0..2] of DWORD; // Set to 0.\r\n Segments: array [0..0] of TSegmentInfo;\r\n // Detailed information about each segment\r\n // that code is contributed to.\r\n // This is an array of cSeg count segment\r\n // information descriptor structures.\r\n end;\r\n\r\n{*******************************************************************************\r\n\r\n SUBSECTION_TYPE_SOURCE_MODULE $0127\r\n\r\n This table describes the source line number to addressing mapping\r\n information for a module. The table permits the description of a module\r\n containing multiple source files with each source file contributing code to\r\n one or more code segments. The base addresses of the tables described\r\n below are all relative to the beginning of the sstSrcModule table.\r\n\r\n\r\n Module header\r\n\r\n Information for source file 1\r\n\r\n Information for segment 1\r\n .\r\n .\r\n .\r\n Information for segment n\r\n\r\n .\r\n .\r\n .\r\n\r\n Information for source file n\r\n\r\n Information for segment 1\r\n .\r\n .\r\n .\r\n Information for segment n\r\n\r\n*******************************************************************************}\r\ntype\r\n { The line number to address mapping information is contained in a table with\r\n the following format: }\r\n PLineMappingEntry = ^TLineMappingEntry;\r\n TLineMappingEntry = packed record\r\n SegmentIndex: Word; // Segment index for this table\r\n PairCount: Word; // Count of the number of source line pairs to follow\r\n Offsets: array [0..0] of DWORD;\r\n // An array of 32-bit offsets for the offset\r\n // within the code segment ofthe start of ine contained\r\n // in the parallel array linenumber.\r\n (*\r\n { This is an array of 16-bit line numbers of the lines in the source file\r\n that cause code to be emitted to the code segment.\r\n This array is parallel to the offset array.\r\n If cPair is not even, then a zero word is emitted to\r\n maintain natural alignment in the sstSrcModule table. }\r\n LineNumbers: array [0..PairCount - 1] of Word;\r\n *)\r\n end;\r\n\r\n TOffsetPair = packed record\r\n StartOffset: DWORD;\r\n EndOffset: DWORD;\r\n end;\r\n POffsetPairArray = ^TOffsetPairArray;\r\n TOffsetPairArray = array [0..32767] of TOffsetPair;\r\n\r\n { The file table describes the code segments that receive code from this\r\n source file. Source file entries have the following format: }\r\n PSourceFileEntry = ^TSourceFileEntry;\r\n TSourceFileEntry = packed record\r\n SegmentCount: Word; // Number of segments that receive code from this source file.\r\n NameIndex: DWORD; // Name index of Source file name.\r\n\r\n BaseSrcLines: array [0..0] of DWORD;\r\n // An array of offsets for the line/address mapping\r\n // tables for each of the segments that receive code\r\n // from this source file.\r\n (*\r\n { An array of two 32-bit offsets per segment that\r\n receives code from this module. The first offset\r\n is the offset within the segment of the first byte\r\n of code from this module. The second offset is the\r\n ending address of the code from this module. The\r\n order of these pairs corresponds to the ordering of\r\n the segments in the seg array. Zeros in these\r\n entries means that the information is not known and\r\n the file and line tables described below need to be\r\n examined to determine if an address of interest is\r\n contained within the code from this module. }\r\n SegmentAddress: array [0..SegmentCount - 1] of TOffsetPair;\r\n\r\n Name: ShortString; // Count of the number of bytes in source file name\r\n *)\r\n end;\r\n\r\n { The module header structure describes the source file and code segment\r\n organization of the module. Each module header has the following format: }\r\n PSourceModuleInfo = ^TSourceModuleInfo;\r\n TSourceModuleInfo = packed record\r\n FileCount: Word; // The number of source file scontributing code to segments\r\n SegmentCount: Word; // The number of code segments receiving code from this module\r\n\r\n BaseSrcFiles: array [0..0] of DWORD;\r\n (*\r\n // This is an array of base offsets from the beginning of the sstSrcModule table\r\n BaseSrcFiles: array [0..FileCount - 1] of DWORD;\r\n\r\n { An array of two 32-bit offsets per segment that\r\n receives code from this module. The first offset\r\n is the offset within the segment of the first byte\r\n of code from this module. The second offset is the\r\n ending address of the code from this module. The\r\n order of these pairs corresponds to the ordering of\r\n the segments in the seg array. Zeros in these\r\n entries means that the information is not known and\r\n the file and line tables described below need to be\r\n examined to determine if an address of interest is\r\n contained within the code from this module. }\r\n SegmentAddress: array [0..SegmentCount - 1] of TOffsetPair;\r\n\r\n { An array of segment indices that receive code from\r\n this module. If the number of segments is not\r\n even, a pad word is inserted to maintain natural\r\n alignment. }\r\n SegmentIndexes: array [0..SegmentCount - 1] of Word;\r\n *)\r\n end;\r\n\r\n{*******************************************************************************\r\n\r\n SUBSECTION_TYPE_GLOBAL_TYPES $12b\r\n\r\n This subsection contains the packed type records for the executable file.\r\n The first long word of the subsection contains the number of types in the\r\n table. This count is followed by a count-sized array of long offsets to\r\n the corresponding type record. As the sstGlobalTypes subsection is\r\n written, each type record is forced to start on a long word boundary.\r\n However, the length of the type string is NOT adjusted by the pad count.\r\n The remainder of the subsection contains the type records.\r\n\r\n*******************************************************************************}\r\n\r\ntype\r\n PGlobalTypeInfo = ^TGlobalTypeInfo;\r\n TGlobalTypeInfo = packed record\r\n Count: DWORD; // count of the number of types\r\n // offset of each type string from the beginning of table\r\n Offsets: array [0..0] of DWORD;\r\n end;\r\n\r\nconst\r\n { Symbol type defines }\r\n SYMBOL_TYPE_COMPILE = $0001; // Compile flags symbol\r\n SYMBOL_TYPE_REGISTER = $0002; // Register variable\r\n SYMBOL_TYPE_CONST = $0003; // Constant symbol\r\n SYMBOL_TYPE_UDT = $0004; // User-defined Type\r\n SYMBOL_TYPE_SSEARCH = $0005; // Start search\r\n SYMBOL_TYPE_END = $0006; // End block, procedure, with, or thunk\r\n SYMBOL_TYPE_SKIP = $0007; // Skip - Reserve symbol space\r\n SYMBOL_TYPE_CVRESERVE = $0008; // Reserved for Code View internal use\r\n SYMBOL_TYPE_OBJNAME = $0009; // Specify name of object file\r\n\r\n SYMBOL_TYPE_BPREL16 = $0100; // BP relative 16:16\r\n SYMBOL_TYPE_LDATA16 = $0101; // Local data 16:16\r\n SYMBOL_TYPE_GDATA16 = $0102; // Global data 16:16\r\n SYMBOL_TYPE_PUB16 = $0103; // Public symbol 16:16\r\n SYMBOL_TYPE_LPROC16 = $0104; // Local procedure start 16:16\r\n SYMBOL_TYPE_GPROC16 = $0105; // Global procedure start 16:16\r\n SYMBOL_TYPE_THUNK16 = $0106; // Thunk start 16:16\r\n SYMBOL_TYPE_BLOCK16 = $0107; // Block start 16:16\r\n SYMBOL_TYPE_WITH16 = $0108; // With start 16:16\r\n SYMBOL_TYPE_LABEL16 = $0109; // Code label 16:16\r\n SYMBOL_TYPE_CEXMODEL16 = $010A; // Change execution model 16:16\r\n SYMBOL_TYPE_VFTPATH16 = $010B; // Virtual function table path descriptor 16:16\r\n\r\n SYMBOL_TYPE_BPREL32 = $0200; // BP relative 16:32\r\n SYMBOL_TYPE_LDATA32 = $0201; // Local data 16:32\r\n SYMBOL_TYPE_GDATA32 = $0202; // Global data 16:32\r\n SYMBOL_TYPE_PUB32 = $0203; // Public symbol 16:32\r\n SYMBOL_TYPE_LPROC32 = $0204; // Local procedure start 16:32\r\n SYMBOL_TYPE_GPROC32 = $0205; // Global procedure start 16:32\r\n SYMBOL_TYPE_THUNK32 = $0206; // Thunk start 16:32\r\n SYMBOL_TYPE_BLOCK32 = $0207; // Block start 16:32\r\n SYMBOL_TYPE_WITH32 = $0208; // With start 16:32\r\n SYMBOL_TYPE_LABEL32 = $0209; // Label 16:32\r\n SYMBOL_TYPE_CEXMODEL32 = $020A; // Change execution model 16:32\r\n SYMBOL_TYPE_VFTPATH32 = $020B; // Virtual function table path descriptor 16:32\r\n\r\n{*******************************************************************************\r\n\r\n Global and Local Procedure Start 16:32\r\n\r\n SYMBOL_TYPE_LPROC32 $0204\r\n SYMBOL_TYPE_GPROC32 $0205\r\n\r\n The symbol records define local (file static) and global procedure\r\n definition. For C/C++, functions that are declared static to a module are\r\n emitted as Local Procedure symbols. Functions not specifically declared\r\n static are emitted as Global Procedures.\r\n For each SYMBOL_TYPE_GPROC32 emitted, an SYMBOL_TYPE_GPROCREF symbol\r\n must be fabricated and emitted to the SUBSECTION_TYPE_GLOBAL_SYMBOLS section.\r\n\r\n*******************************************************************************}\r\n\r\ntype\r\n TSymbolProcInfo = packed record\r\n pParent: DWORD;\r\n pEnd: DWORD;\r\n pNext: DWORD;\r\n Size: DWORD; // Length in bytes of this procedure\r\n DebugStart: DWORD; // Offset in bytes from the start of the procedure to\r\n // the point where the stack frame has been set up.\r\n DebugEnd: DWORD; // Offset in bytes from the start of the procedure to\r\n // the point where the procedure is ready to return\r\n // and has calculated its return value, if any.\r\n // Frame and register variables an still be viewed.\r\n Offset: DWORD; // Offset portion of the segmented address of\r\n // the start of the procedure in the code segment\r\n Segment: Word; // Segment portion of the segmented address of\r\n // the start of the procedure in the code segment\r\n ProcType: DWORD; // Type of the procedure type record\r\n NearFar: Byte; // Type of return the procedure makes:\r\n // 0 near\r\n // 4 far\r\n Reserved: Byte;\r\n NameIndex: DWORD; // Name index of procedure\r\n end;\r\n\r\n TSymbolObjNameInfo = packed record\r\n Signature: DWORD; // Signature for the CodeView information contained in\r\n // this module\r\n NameIndex: DWORD; // Name index of the object file\r\n end;\r\n\r\n TSymbolDataInfo = packed record\r\n Offset: DWORD; // Offset portion of the segmented address of\r\n // the start of the data in the code segment\r\n Segment: Word; // Segment portion of the segmented address of\r\n // the start of the data in the code segment\r\n Reserved: Word;\r\n TypeIndex: DWORD; // Type index of the symbol\r\n NameIndex: DWORD; // Name index of the symbol\r\n end;\r\n\r\n TSymbolWithInfo = packed record\r\n pParent: DWORD;\r\n pEnd: DWORD;\r\n Size: DWORD; // Length in bytes of this \"with\"\r\n Offset: DWORD; // Offset portion of the segmented address of\r\n // the start of the \"with\" in the code segment\r\n Segment: Word; // Segment portion of the segmented address of\r\n // the start of the \"with\" in the code segment\r\n Reserved: Word;\r\n NameIndex: DWORD; // Name index of the \"with\"\r\n end;\r\n\r\n TSymbolLabelInfo = packed record\r\n Offset: DWORD; // Offset portion of the segmented address of\r\n // the start of the label in the code segment\r\n Segment: Word; // Segment portion of the segmented address of\r\n // the start of the label in the code segment\r\n NearFar: Byte; // Address mode of the label:\r\n // 0 near\r\n // 4 far\r\n Reserved: Byte;\r\n NameIndex: DWORD; // Name index of the label\r\n end;\r\n\r\n TSymbolConstantInfo = packed record\r\n TypeIndex: DWORD; // Type index of the constant (for enums)\r\n NameIndex: DWORD; // Name index of the constant\r\n Reserved: DWORD;\r\n Value: DWORD; // value of the constant\r\n end;\r\n\r\n TSymbolUdtInfo = packed record\r\n TypeIndex: DWORD; // Type index of the type\r\n Properties: Word; // isTag:1 True if this is a tag (not a typedef)\r\n // isNest:1 True if the type is a nested type (its name\r\n // will be 'class_name::type_name' in that case)\r\n NameIndex: DWORD; // Name index of the type\r\n Reserved: DWORD;\r\n end;\r\n\r\n TSymbolVftPathInfo = packed record\r\n Offset: DWORD; // Offset portion of start of the virtual function table\r\n Segment: Word; // Segment portion of the virtual function table\r\n Reserved: Word;\r\n RootIndex: DWORD; // The type index of the class at the root of the path\r\n PathIndex: DWORD; // Type index of the record describing the base class\r\n // path from the root to the leaf class for the virtual\r\n // function table\r\n end;\r\n\r\ntype\r\n { Symbol Information Records }\r\n PSymbolInfo = ^TSymbolInfo;\r\n TSymbolInfo = packed record\r\n Size: Word;\r\n SymbolType: Word;\r\n case Word of\r\n SYMBOL_TYPE_LPROC32, SYMBOL_TYPE_GPROC32:\r\n (Proc: TSymbolProcInfo);\r\n SYMBOL_TYPE_OBJNAME:\r\n (ObjName: TSymbolObjNameInfo);\r\n SYMBOL_TYPE_LDATA32, SYMBOL_TYPE_GDATA32, SYMBOL_TYPE_PUB32:\r\n (Data: TSymbolDataInfo);\r\n SYMBOL_TYPE_WITH32:\r\n (With32: TSymbolWithInfo);\r\n SYMBOL_TYPE_LABEL32:\r\n (Label32: TSymbolLabelInfo);\r\n SYMBOL_TYPE_CONST:\r\n (Constant: TSymbolConstantInfo);\r\n SYMBOL_TYPE_UDT:\r\n (Udt: TSymbolUdtInfo);\r\n SYMBOL_TYPE_VFTPATH32:\r\n (VftPath: TSymbolVftPathInfo);\r\n end;\r\n\r\n PSymbolInfos = ^TSymbolInfos;\r\n TSymbolInfos = packed record\r\n Signature: DWORD;\r\n Symbols: array [0..0] of TSymbolInfo;\r\n end;\r\n\r\n{$IFDEF SUPPORTS_EXTSYM}\r\n\r\n{$EXTERNALSYM Borland32BitSymbolFileSignatureForDelphi}\r\n{$EXTERNALSYM Borland32BitSymbolFileSignatureForBCB}\r\n\r\n{$EXTERNALSYM SUBSECTION_TYPE_MODULE}\r\n{$EXTERNALSYM SUBSECTION_TYPE_TYPES}\r\n{$EXTERNALSYM SUBSECTION_TYPE_SYMBOLS}\r\n{$EXTERNALSYM SUBSECTION_TYPE_ALIGN_SYMBOLS}\r\n{$EXTERNALSYM SUBSECTION_TYPE_SOURCE_MODULE}\r\n{$EXTERNALSYM SUBSECTION_TYPE_GLOBAL_SYMBOLS}\r\n{$EXTERNALSYM SUBSECTION_TYPE_GLOBAL_TYPES}\r\n{$EXTERNALSYM SUBSECTION_TYPE_NAMES}\r\n\r\n{$EXTERNALSYM SYMBOL_TYPE_COMPILE}\r\n{$EXTERNALSYM SYMBOL_TYPE_REGISTER}\r\n{$EXTERNALSYM SYMBOL_TYPE_CONST}\r\n{$EXTERNALSYM SYMBOL_TYPE_UDT}\r\n{$EXTERNALSYM SYMBOL_TYPE_SSEARCH}\r\n{$EXTERNALSYM SYMBOL_TYPE_END}\r\n{$EXTERNALSYM SYMBOL_TYPE_SKIP}\r\n{$EXTERNALSYM SYMBOL_TYPE_CVRESERVE}\r\n{$EXTERNALSYM SYMBOL_TYPE_OBJNAME}\r\n\r\n{$EXTERNALSYM SYMBOL_TYPE_BPREL16}\r\n{$EXTERNALSYM SYMBOL_TYPE_LDATA16}\r\n{$EXTERNALSYM SYMBOL_TYPE_GDATA16}\r\n{$EXTERNALSYM SYMBOL_TYPE_PUB16}\r\n{$EXTERNALSYM SYMBOL_TYPE_LPROC16}\r\n{$EXTERNALSYM SYMBOL_TYPE_GPROC16}\r\n{$EXTERNALSYM SYMBOL_TYPE_THUNK16}\r\n{$EXTERNALSYM SYMBOL_TYPE_BLOCK16}\r\n{$EXTERNALSYM SYMBOL_TYPE_WITH16}\r\n{$EXTERNALSYM SYMBOL_TYPE_LABEL16}\r\n{$EXTERNALSYM SYMBOL_TYPE_CEXMODEL16}\r\n{$EXTERNALSYM SYMBOL_TYPE_VFTPATH16}\r\n\r\n{$EXTERNALSYM SYMBOL_TYPE_BPREL32}\r\n{$EXTERNALSYM SYMBOL_TYPE_LDATA32}\r\n{$EXTERNALSYM SYMBOL_TYPE_GDATA32}\r\n{$EXTERNALSYM SYMBOL_TYPE_PUB32}\r\n{$EXTERNALSYM SYMBOL_TYPE_LPROC32}\r\n{$EXTERNALSYM SYMBOL_TYPE_GPROC32}\r\n{$EXTERNALSYM SYMBOL_TYPE_THUNK32}\r\n{$EXTERNALSYM SYMBOL_TYPE_BLOCK32}\r\n{$EXTERNALSYM SYMBOL_TYPE_WITH32}\r\n{$EXTERNALSYM SYMBOL_TYPE_LABEL32}\r\n{$EXTERNALSYM SYMBOL_TYPE_CEXMODEL32}\r\n{$EXTERNALSYM SYMBOL_TYPE_VFTPATH32}\r\n\r\n{$ENDIF SUPPORTS_EXTSYM}\r\n\r\n// TD32 information related classes\r\ntype\r\n TJclTD32ModuleInfo = class(TObject)\r\n private\r\n FNameIndex: DWORD;\r\n FSegments: PSegmentInfoArray;\r\n FSegmentCount: Integer;\r\n function GetSegment(const Idx: Integer): TSegmentInfo;\r\n public\r\n constructor Create(pModInfo: PModuleInfo);\r\n property NameIndex: DWORD read FNameIndex;\r\n property SegmentCount: Integer read FSegmentCount; //GetSegmentCount;\r\n property Segment[const Idx: Integer]: TSegmentInfo read GetSegment; default;\r\n end;\r\n\r\n TJclTD32LineInfo = class(TObject)\r\n private\r\n FLineNo: DWORD;\r\n FOffset: DWORD;\r\n public\r\n constructor Create(ALineNo, AOffset: DWORD);\r\n property LineNo: DWORD read FLineNo;\r\n property Offset: DWORD read FOffset;\r\n end;\r\n\r\n TJclTD32SourceModuleInfo = class(TObject)\r\n private\r\n FLines: TObjectList;\r\n FSegments: POffsetPairArray;\r\n FSegmentCount: Integer;\r\n FNameIndex: DWORD;\r\n function GetLine(const Idx: Integer): TJclTD32LineInfo;\r\n function GetLineCount: Integer;\r\n function GetSegment(const Idx: Integer): TOffsetPair;\r\n public\r\n constructor Create(pSrcFile: PSourceFileEntry; Base: TJclAddr);\r\n destructor Destroy; override;\r\n function FindLine(const AAddr: DWORD; out ALine: TJclTD32LineInfo): Boolean;\r\n property NameIndex: DWORD read FNameIndex;\r\n property LineCount: Integer read GetLineCount;\r\n property Line[const Idx: Integer]: TJclTD32LineInfo read GetLine; default;\r\n property SegmentCount: Integer read FSegmentCount; //GetSegmentCount;\r\n property Segment[const Idx: Integer]: TOffsetPair read GetSegment;\r\n end;\r\n\r\n TJclTD32SymbolInfo = class(TObject)\r\n private\r\n FSymbolType: Word;\r\n public\r\n constructor Create(pSymInfo: PSymbolInfo); virtual;\r\n property SymbolType: Word read FSymbolType;\r\n end;\r\n\r\n TJclTD32ProcSymbolInfo = class(TJclTD32SymbolInfo)\r\n private\r\n FNameIndex: DWORD;\r\n FOffset: DWORD;\r\n FSize: DWORD;\r\n public\r\n constructor Create(pSymInfo: PSymbolInfo); override;\r\n property NameIndex: DWORD read FNameIndex;\r\n property Offset: DWORD read FOffset;\r\n property Size: DWORD read FSize;\r\n end;\r\n\r\n TJclTD32LocalProcSymbolInfo = class(TJclTD32ProcSymbolInfo);\r\n TJclTD32GlobalProcSymbolInfo = class(TJclTD32ProcSymbolInfo);\r\n\r\n { not used by Delphi }\r\n TJclTD32ObjNameSymbolInfo = class(TJclTD32SymbolInfo)\r\n private\r\n FSignature: DWORD;\r\n FNameIndex: DWORD;\r\n public\r\n constructor Create(pSymInfo: PSymbolInfo); override;\r\n property NameIndex: DWORD read FNameIndex;\r\n property Signature: DWORD read FSignature;\r\n end;\r\n\r\n TJclTD32DataSymbolInfo = class(TJclTD32SymbolInfo)\r\n private\r\n FOffset: DWORD;\r\n FTypeIndex: DWORD;\r\n FNameIndex: DWORD;\r\n public\r\n constructor Create(pSymInfo: PSymbolInfo); override;\r\n property NameIndex: DWORD read FNameIndex;\r\n property TypeIndex: DWORD read FTypeIndex;\r\n property Offset: DWORD read FOffset;\r\n end;\r\n\r\n TJclTD32LDataSymbolInfo = class(TJclTD32DataSymbolInfo);\r\n TJclTD32GDataSymbolInfo = class(TJclTD32DataSymbolInfo);\r\n TJclTD32PublicSymbolInfo = class(TJclTD32DataSymbolInfo);\r\n\r\n TJclTD32WithSymbolInfo = class(TJclTD32SymbolInfo)\r\n private\r\n FOffset: DWORD;\r\n FSize: DWORD;\r\n FNameIndex: DWORD;\r\n public\r\n constructor Create(pSymInfo: PSymbolInfo); override;\r\n property NameIndex: DWORD read FNameIndex;\r\n property Offset: DWORD read FOffset;\r\n property Size: DWORD read FSize;\r\n end;\r\n\r\n { not used by Delphi }\r\n TJclTD32LabelSymbolInfo = class(TJclTD32SymbolInfo)\r\n private\r\n FOffset: DWORD;\r\n FNameIndex: DWORD;\r\n public\r\n constructor Create(pSymInfo: PSymbolInfo); override;\r\n property NameIndex: DWORD read FNameIndex;\r\n property Offset: DWORD read FOffset;\r\n end;\r\n\r\n { not used by Delphi }\r\n TJclTD32ConstantSymbolInfo = class(TJclTD32SymbolInfo)\r\n private\r\n FValue: DWORD;\r\n FTypeIndex: DWORD;\r\n FNameIndex: DWORD;\r\n public\r\n constructor Create(pSymInfo: PSymbolInfo); override;\r\n property NameIndex: DWORD read FNameIndex;\r\n property TypeIndex: DWORD read FTypeIndex; // for enums\r\n property Value: DWORD read FValue;\r\n end;\r\n\r\n TJclTD32UdtSymbolInfo = class(TJclTD32SymbolInfo)\r\n private\r\n FTypeIndex: DWORD;\r\n FNameIndex: DWORD;\r\n FProperties: Word;\r\n public\r\n constructor Create(pSymInfo: PSymbolInfo); override;\r\n property NameIndex: DWORD read FNameIndex;\r\n property TypeIndex: DWORD read FTypeIndex;\r\n property Properties: Word read FProperties;\r\n end;\r\n\r\n { not used by Delphi }\r\n TJclTD32VftPathSymbolInfo = class(TJclTD32SymbolInfo)\r\n private\r\n FRootIndex: DWORD;\r\n FPathIndex: DWORD;\r\n FOffset: DWORD;\r\n public\r\n constructor Create(pSymInfo: PSymbolInfo); override;\r\n property RootIndex: DWORD read FRootIndex;\r\n property PathIndex: DWORD read FPathIndex;\r\n property Offset: DWORD read FOffset;\r\n end;\r\n\r\n // TD32 parser\r\n TJclTD32InfoParser = class(TObject)\r\n private\r\n FBase: Pointer;\r\n FData: TCustomMemoryStream;\r\n FNames: TList;\r\n FModules: TObjectList;\r\n FSourceModules: TObjectList;\r\n FSymbols: TObjectList;\r\n FProcSymbols: TList;\r\n FValidData: Boolean;\r\n function GetName(const Idx: Integer): string;\r\n function GetNameCount: Integer;\r\n function GetSymbol(const Idx: Integer): TJclTD32SymbolInfo;\r\n function GetSymbolCount: Integer;\r\n function GetProcSymbol(const Idx: Integer): TJclTD32ProcSymbolInfo;\r\n function GetProcSymbolCount: Integer;\r\n function GetModule(const Idx: Integer): TJclTD32ModuleInfo;\r\n function GetModuleCount: Integer;\r\n function GetSourceModule(const Idx: Integer): TJclTD32SourceModuleInfo;\r\n function GetSourceModuleCount: Integer;\r\n protected\r\n procedure Analyse;\r\n procedure AnalyseNames(const pSubsection: Pointer; const Size: DWORD); virtual;\r\n procedure AnalyseGlobalTypes(const pTypes: Pointer; const Size: DWORD); virtual;\r\n procedure AnalyseAlignSymbols(pSymbols: PSymbolInfos; const Size: DWORD); virtual;\r\n procedure AnalyseModules(pModInfo: PModuleInfo; const Size: DWORD); virtual;\r\n procedure AnalyseSourceModules(pSrcModInfo: PSourceModuleInfo; const Size: DWORD); virtual;\r\n procedure AnalyseUnknownSubSection(const pSubsection: Pointer; const Size: DWORD); virtual;\r\n function LfaToVa(Lfa: DWORD): Pointer;\r\n public\r\n constructor Create(const ATD32Data: TCustomMemoryStream); // Data mustn't be freed before the class is destroyed\r\n destructor Destroy; override;\r\n function FindModule(const AAddr: DWORD; out AMod: TJclTD32ModuleInfo): Boolean;\r\n function FindSourceModule(const AAddr: DWORD; out ASrcMod: TJclTD32SourceModuleInfo): Boolean;\r\n function FindProc(const AAddr: DWORD; out AProc: TJclTD32ProcSymbolInfo): Boolean;\r\n class function IsTD32Sign(const Sign: TJclTD32FileSignature): Boolean;\r\n class function IsTD32DebugInfoValid(const DebugData: Pointer; const DebugDataSize: LongWord): Boolean;\r\n property Data: TCustomMemoryStream read FData;\r\n property Names[const Idx: Integer]: string read GetName;\r\n property NameCount: Integer read GetNameCount;\r\n property Symbols[const Idx: Integer]: TJclTD32SymbolInfo read GetSymbol;\r\n property SymbolCount: Integer read GetSymbolCount;\r\n property ProcSymbols[const Idx: Integer]: TJclTD32ProcSymbolInfo read GetProcSymbol;\r\n property ProcSymbolCount: Integer read GetProcSymbolCount;\r\n property Modules[const Idx: Integer]: TJclTD32ModuleInfo read GetModule;\r\n property ModuleCount: Integer read GetModuleCount;\r\n property SourceModules[const Idx: Integer]: TJclTD32SourceModuleInfo read GetSourceModule;\r\n property SourceModuleCount: Integer read GetSourceModuleCount;\r\n property ValidData: Boolean read FValidData;\r\n end;\r\n\r\n // TD32 scanner with source location methods\r\n TJclTD32InfoScanner = class(TJclTD32InfoParser)\r\n public\r\n function LineNumberFromAddr(AAddr: DWORD; out Offset: Integer): Integer; overload;\r\n function LineNumberFromAddr(AAddr: DWORD): Integer; overload;\r\n function ProcNameFromAddr(AAddr: DWORD): string; overload;\r\n function ProcNameFromAddr(AAddr: DWORD; out Offset: Integer): string; overload;\r\n function ModuleNameFromAddr(AAddr: DWORD): string;\r\n function SourceNameFromAddr(AAddr: DWORD): string;\r\n end;\r\n\r\n {$IFDEF BORLAND}\r\n // PE Image with TD32 information and source location support \r\n TJclPeBorTD32Image = class(TJclPeBorImage)\r\n private\r\n FIsTD32DebugPresent: Boolean;\r\n FTD32DebugData: TCustomMemoryStream;\r\n FTD32Scanner: TJclTD32InfoScanner;\r\n protected\r\n procedure AfterOpen; override;\r\n procedure Clear; override;\r\n procedure ClearDebugData;\r\n procedure CheckDebugData;\r\n function IsDebugInfoInImage(var DataStream: TCustomMemoryStream): Boolean;\r\n function IsDebugInfoInTds(var DataStream: TCustomMemoryStream): Boolean;\r\n public\r\n property IsTD32DebugPresent: Boolean read FIsTD32DebugPresent;\r\n property TD32DebugData: TCustomMemoryStream read FTD32DebugData;\r\n property TD32Scanner: TJclTD32InfoScanner read FTD32Scanner;\r\n end;\r\n {$ENDIF BORLAND}\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jcl.svn.sourceforge.net/svnroot/jcl/tags/JCL-2.4-Build4571/jcl/source/windows/JclTD32.pas $';\r\n Revision: '$Revision: 3599 $';\r\n Date: '$Date: 2011-09-03 00:07:50 +0200 (sam. 03 sept. 2011) $';\r\n LogPath: 'JCL\\source\\windows';\r\n Extra: '';\r\n Data: nil\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n JclResources, JclSysUtils, JclStringConversions;\r\n\r\n{$IFDEF BORLAND}\r\nconst\r\n TurboDebuggerSymbolExt = '.tds';\r\n{$ENDIF BORLAND}\r\n\r\n//=== { TJclModuleInfo } =====================================================\r\n\r\nconstructor TJclTD32ModuleInfo.Create(pModInfo: PModuleInfo);\r\nbegin\r\n Assert(Assigned(pModInfo));\r\n inherited Create;\r\n FNameIndex := pModInfo.NameIndex;\r\n FSegments := @pModInfo.Segments[0];\r\n FSegmentCount := pModInfo.SegmentCount;\r\nend;\r\n\r\nfunction TJclTD32ModuleInfo.GetSegment(const Idx: Integer): TSegmentInfo;\r\nbegin\r\n Assert((0 <= Idx) and (Idx < FSegmentCount));\r\n Result := FSegments[Idx];\r\nend;\r\n\r\n//=== { TJclLineInfo } =======================================================\r\n\r\nconstructor TJclTD32LineInfo.Create(ALineNo, AOffset: DWORD);\r\nbegin\r\n inherited Create;\r\n FLineNo := ALineNo;\r\n FOffset := AOffset;\r\nend;\r\n\r\n//=== { TJclSourceModuleInfo } ===============================================\r\n\r\nconstructor TJclTD32SourceModuleInfo.Create(pSrcFile: PSourceFileEntry; Base: TJclAddr);\r\ntype\r\n PArrayOfWord = ^TArrayOfWord;\r\n TArrayOfWord = array [0..0] of Word;\r\nvar\r\n I, J: Integer;\r\n pLineEntry: PLineMappingEntry;\r\nbegin\r\n Assert(Assigned(pSrcFile));\r\n inherited Create;\r\n FNameIndex := pSrcFile.NameIndex;\r\n FLines := TObjectList.Create;\r\n {$RANGECHECKS OFF}\r\n for I := 0 to pSrcFile.SegmentCount - 1 do\r\n begin\r\n pLineEntry := PLineMappingEntry(Base + pSrcFile.BaseSrcLines[I]);\r\n for J := 0 to pLineEntry.PairCount - 1 do\r\n FLines.Add(TJclTD32LineInfo.Create(\r\n PArrayOfWord(@pLineEntry.Offsets[pLineEntry.PairCount])^[J],\r\n pLineEntry.Offsets[J]));\r\n end;\r\n\r\n FSegments := @pSrcFile.BaseSrcLines[pSrcFile.SegmentCount];\r\n FSegmentCount := pSrcFile.SegmentCount;\r\n {$IFDEF RANGECHECKS_ON}\r\n {$RANGECHECKS ON}\r\n {$ENDIF RANGECHECKS_ON}\r\nend;\r\n\r\ndestructor TJclTD32SourceModuleInfo.Destroy;\r\nbegin\r\n FreeAndNil(FLines);\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJclTD32SourceModuleInfo.GetLine(const Idx: Integer): TJclTD32LineInfo;\r\nbegin\r\n Result := TJclTD32LineInfo(FLines.Items[Idx]);\r\nend;\r\n\r\nfunction TJclTD32SourceModuleInfo.GetLineCount: Integer;\r\nbegin\r\n Result := FLines.Count;\r\nend;\r\n\r\nfunction TJclTD32SourceModuleInfo.GetSegment(const Idx: Integer): TOffsetPair;\r\nbegin\r\n Assert((0 <= Idx) and (Idx < FSegmentCount));\r\n Result := FSegments[Idx];\r\nend;\r\n\r\nfunction TJclTD32SourceModuleInfo.FindLine(const AAddr: DWORD; out ALine: TJclTD32LineInfo): Boolean;\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := 0 to LineCount - 1 do\r\n with Line[I] do\r\n begin\r\n if AAddr = Offset then\r\n begin\r\n Result := True;\r\n ALine := Line[I];\r\n Exit;\r\n end\r\n else\r\n if (I > 1) and (Line[I - 1].Offset < AAddr) and (AAddr < Offset) then\r\n begin\r\n Result := True;\r\n ALine := Line[I-1];\r\n Exit;\r\n end;\r\n end;\r\n Result := False;\r\n ALine := nil;\r\nend;\r\n\r\n//=== { TJclSymbolInfo } =====================================================\r\n\r\nconstructor TJclTD32SymbolInfo.Create(pSymInfo: PSymbolInfo);\r\nbegin\r\n Assert(Assigned(pSymInfo));\r\n inherited Create;\r\n FSymbolType := pSymInfo.SymbolType;\r\nend;\r\n\r\n//=== { TJclProcSymbolInfo } =================================================\r\n\r\nconstructor TJclTD32ProcSymbolInfo.Create(pSymInfo: PSymbolInfo);\r\nbegin\r\n Assert(Assigned(pSymInfo));\r\n inherited Create(pSymInfo);\r\n with pSymInfo^ do\r\n begin\r\n FNameIndex := Proc.NameIndex;\r\n FOffset := Proc.Offset;\r\n FSize := Proc.Size;\r\n end;\r\nend;\r\n\r\n//=== { TJclObjNameSymbolInfo } ==============================================\r\n\r\nconstructor TJclTD32ObjNameSymbolInfo.Create(pSymInfo: PSymbolInfo);\r\nbegin\r\n Assert(Assigned(pSymInfo));\r\n inherited Create(pSymInfo);\r\n with pSymInfo^ do\r\n begin\r\n FNameIndex := ObjName.NameIndex;\r\n FSignature := ObjName.Signature;\r\n end;\r\nend;\r\n\r\n//=== { TJclDataSymbolInfo } =================================================\r\n\r\nconstructor TJclTD32DataSymbolInfo.Create(pSymInfo: PSymbolInfo);\r\nbegin\r\n Assert(Assigned(pSymInfo));\r\n inherited Create(pSymInfo);\r\n with pSymInfo^ do\r\n begin\r\n FTypeIndex := Data.TypeIndex;\r\n FNameIndex := Data.NameIndex;\r\n FOffset := Data.Offset;\r\n end;\r\nend;\r\n\r\n//=== { TJclWithSymbolInfo } =================================================\r\n\r\nconstructor TJclTD32WithSymbolInfo.Create(pSymInfo: PSymbolInfo);\r\nbegin\r\n Assert(Assigned(pSymInfo));\r\n inherited Create(pSymInfo);\r\n with pSymInfo^ do\r\n begin\r\n FNameIndex := With32.NameIndex;\r\n FOffset := With32.Offset;\r\n FSize := With32.Size;\r\n end;\r\nend;\r\n\r\n//=== { TJclLabelSymbolInfo } ================================================\r\n\r\nconstructor TJclTD32LabelSymbolInfo.Create(pSymInfo: PSymbolInfo);\r\nbegin\r\n Assert(Assigned(pSymInfo));\r\n inherited Create(pSymInfo);\r\n with pSymInfo^ do\r\n begin\r\n FNameIndex := Label32.NameIndex;\r\n FOffset := Label32.Offset;\r\n end;\r\nend;\r\n\r\n//=== { TJclConstantSymbolInfo } =============================================\r\n\r\nconstructor TJclTD32ConstantSymbolInfo.Create(pSymInfo: PSymbolInfo);\r\nbegin\r\n Assert(Assigned(pSymInfo));\r\n inherited Create(pSymInfo);\r\n with pSymInfo^ do\r\n begin\r\n FNameIndex := Constant.NameIndex;\r\n FTypeIndex := Constant.TypeIndex;\r\n FValue := Constant.Value;\r\n end;\r\nend;\r\n\r\n//=== { TJclUdtSymbolInfo } ==================================================\r\n\r\nconstructor TJclTD32UdtSymbolInfo.Create(pSymInfo: PSymbolInfo);\r\nbegin\r\n Assert(Assigned(pSymInfo));\r\n inherited Create(pSymInfo);\r\n with pSymInfo^ do\r\n begin\r\n FNameIndex := Udt.NameIndex;\r\n FTypeIndex := Udt.TypeIndex;\r\n FProperties := Udt.Properties;\r\n end;\r\nend;\r\n\r\n//=== { TJclVftPathSymbolInfo } ==============================================\r\n\r\nconstructor TJclTD32VftPathSymbolInfo.Create(pSymInfo: PSymbolInfo);\r\nbegin\r\n Assert(Assigned(pSymInfo));\r\n inherited Create(pSymInfo);\r\n with pSymInfo^ do\r\n begin\r\n FRootIndex := VftPath.RootIndex;\r\n FPathIndex := VftPath.PathIndex;\r\n FOffset := VftPath.Offset;\r\n end;\r\nend;\r\n\r\n//=== { TJclTD32InfoParser } =================================================\r\n\r\nconstructor TJclTD32InfoParser.Create(const ATD32Data: TCustomMemoryStream);\r\nbegin\r\n Assert(Assigned(ATD32Data));\r\n inherited Create;\r\n FNames := TList.Create;\r\n FModules := TObjectList.Create;\r\n FSourceModules := TObjectList.Create;\r\n FSymbols := TObjectList.Create;\r\n FProcSymbols := TList.Create;\r\n FNames.Add(nil);\r\n FData := ATD32Data;\r\n FBase := FData.Memory;\r\n FValidData := IsTD32DebugInfoValid(FBase, FData.Size);\r\n if FValidData then\r\n Analyse;\r\nend;\r\n\r\ndestructor TJclTD32InfoParser.Destroy;\r\nbegin\r\n FreeAndNil(FProcSymbols);\r\n FreeAndNil(FSymbols);\r\n FreeAndNil(FSourceModules);\r\n FreeAndNil(FModules);\r\n FreeAndNil(FNames);\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJclTD32InfoParser.Analyse;\r\nvar\r\n I: Integer;\r\n pDirHeader: PDirectoryHeader;\r\n pSubsection: Pointer;\r\nbegin\r\n pDirHeader := PDirectoryHeader(LfaToVa(PJclTD32FileSignature(LfaToVa(0)).Offset));\r\n while True do\r\n begin\r\n Assert(pDirHeader.DirEntrySize = SizeOf(TDirectoryEntry));\r\n {$RANGECHECKS OFF}\r\n for I := 0 to pDirHeader.DirEntryCount - 1 do\r\n with pDirHeader.DirEntries[I] do\r\n begin\r\n pSubsection := LfaToVa(Offset);\r\n case SubsectionType of\r\n SUBSECTION_TYPE_MODULE:\r\n AnalyseModules(pSubsection, Size);\r\n SUBSECTION_TYPE_ALIGN_SYMBOLS:\r\n AnalyseAlignSymbols(pSubsection, Size);\r\n SUBSECTION_TYPE_SOURCE_MODULE:\r\n AnalyseSourceModules(pSubsection, Size);\r\n SUBSECTION_TYPE_NAMES:\r\n AnalyseNames(pSubsection, Size);\r\n SUBSECTION_TYPE_GLOBAL_TYPES:\r\n AnalyseGlobalTypes(pSubsection, Size);\r\n else\r\n AnalyseUnknownSubSection(pSubsection, Size);\r\n end;\r\n end;\r\n {$IFDEF RANGECHECKS_ON}\r\n {$RANGECHECKS ON}\r\n {$ENDIF RANGECHECKS_ON}\r\n if pDirHeader.lfoNextDir <> 0 then\r\n pDirHeader := PDirectoryHeader(LfaToVa(pDirHeader.lfoNextDir))\r\n else\r\n Break;\r\n end;\r\nend;\r\n\r\nprocedure TJclTD32InfoParser.AnalyseNames(const pSubsection: Pointer; const Size: DWORD);\r\nvar\r\n I, Count, Len: Integer;\r\n pszName: PAnsiChar;\r\nbegin\r\n Count := PDWORD(pSubsection)^;\r\n pszName := PAnsiChar(TJclAddr(pSubsection) + SizeOf(DWORD));\r\n if Count > 0 then\r\n begin\r\n FNames.Capacity := FNames.Capacity + Count;\r\n for I := 0 to Count - 1 do\r\n begin\r\n // Get the length of the name\r\n Len := Ord(pszName^);\r\n Inc(pszName);\r\n // Get the name\r\n FNames.Add(pszName);\r\n // first, skip the length of name\r\n Inc(pszName, Len);\r\n // the length is only correct modulo 256 because it is stored on a single byte,\r\n // so we have to iterate until we find the real end of the string\r\n while PszName^ <> #0 do\r\n Inc(pszName, 256);\r\n // then, skip a NULL at the end\r\n Inc(pszName, 1);\r\n end;\r\n end;\r\nend;\r\n\r\n{ // unused\r\nconst\r\n // Leaf indices for type records that can be referenced from symbols\r\n LF_MODIFIER = $0001;\r\n LF_POINTER = $0002;\r\n LF_ARRAY = $0003;\r\n LF_CLASS = $0004;\r\n LF_STRUCTURE = $0005;\r\n LF_UNION = $0006;\r\n LF_ENUM = $0007;\r\n LF_PROCEDURE = $0008;\r\n LF_MFUNCTION = $0009;\r\n LF_VTSHAPE = $000a;\r\n LF_COBOL0 = $000b;\r\n LF_COBOL1 = $000c;\r\n LF_BARRAY = $000d;\r\n LF_LABEL = $000e;\r\n LF_NULL = $000f;\r\n LF_NOTTRAN = $0010;\r\n LF_DIMARRAY = $0011;\r\n LF_VFTPATH = $0012;\r\n\r\n // Leaf indices for type records that can be referenced from other type records\r\n LF_SKIP = $0200;\r\n LF_ARGLIST = $0201;\r\n LF_DEFARG = $0202;\r\n LF_LIST = $0203;\r\n LF_FIELDLIST = $0204;\r\n LF_DERIVED = $0205;\r\n LF_BITFIELD = $0206;\r\n LF_METHODLIST = $0207;\r\n LF_DIMCONU = $0208;\r\n LF_DIMCONLU = $0209;\r\n LF_DIMVARU = $020a;\r\n LF_DIMVARLU = $020b;\r\n LF_REFSYM = $020c;\r\n\r\n // Leaf indices for fields of complex lists:\r\n LF_BCLASS = $0400;\r\n LF_VBCLASS = $0401;\r\n LF_IVBCLASS = $0402;\r\n LF_ENUMERATE = $0403;\r\n LF_FRIENDFCN = $0404;\r\n LF_INDEX = $0405;\r\n LF_MEMBER = $0406;\r\n LF_STMEMBER = $0407;\r\n LF_METHOD = $0408;\r\n LF_NESTTYPE = $0409;\r\n LF_VFUNCTAB = $040a;\r\n LF_FRIENDCLS = $040b;\r\n\r\n // Leaf indices for numeric fields of symbols and type records:\r\n LF_NUMERIC = $8000;\r\n LF_CHAR = $8001;\r\n LF_SHORT = $8002;\r\n LF_USHORT = $8003;\r\n LF_LONG = $8004;\r\n LF_ULONG = $8005;\r\n LF_REAL32 = $8006;\r\n LF_REAL64 = $8007;\r\n LF_REAL80 = $8008;\r\n LF_REAL128 = $8009;\r\n LF_QUADWORD = $800a;\r\n LF_UQUADWORD = $800b;\r\n LF_REAL48 = $800c;\r\n\r\n LF_PAD0 = $f0;\r\n LF_PAD1 = $f1;\r\n LF_PAD2 = $f2;\r\n LF_PAD3 = $f3;\r\n LF_PAD4 = $f4;\r\n LF_PAD5 = $f5;\r\n LF_PAD6 = $f6;\r\n LF_PAD7 = $f7;\r\n LF_PAD8 = $f8;\r\n LF_PAD9 = $f9;\r\n LF_PAD10 = $fa;\r\n LF_PAD11 = $fb;\r\n LF_PAD12 = $fc;\r\n LF_PAD13 = $fd;\r\n LF_PAD14 = $fe;\r\n LF_PAD15 = $ff;\r\n}\r\n\r\ntype\r\n PSymbolTypeInfo = ^TSymbolTypeInfo;\r\n TSymbolTypeInfo = packed record\r\n TypeId: DWORD;\r\n NameIndex: DWORD; // 0 if unnamed\r\n Size: Word; // size in bytes of the object\r\n MaxSize: Byte;\r\n ParentIndex: DWORD;\r\n end;\r\n\r\n{ unused\r\nconst\r\n TID_VOID = $00; // Unknown or no type\r\n TID_LSTR = $01; // Basic Literal string\r\n TID_DSTR = $02; // Basic Dynamic string\r\n TID_PSTR = $03; // Pascal style string\r\n}\r\n\r\nprocedure TJclTD32InfoParser.AnalyseGlobalTypes(const pTypes: Pointer; const Size: DWORD);\r\nvar\r\n pTyp: PSymbolTypeInfo;\r\nbegin\r\n pTyp := PSymbolTypeInfo(pTypes);\r\n repeat\r\n {case pTyp.TypeId of\r\n TID_VOID: ;\r\n end;}\r\n pTyp := PSymbolTypeInfo(TJclAddr(pTyp) + pTyp.Size + SizeOf(pTyp^));\r\n until TJclAddr(pTyp) >= TJclAddr(pTypes) + Size;\r\nend;\r\n\r\nprocedure TJclTD32InfoParser.AnalyseAlignSymbols(pSymbols: PSymbolInfos; const Size: DWORD);\r\nvar\r\n Offset: TJclAddr;\r\n pInfo: PSymbolInfo;\r\n Symbol: TJclTD32SymbolInfo;\r\nbegin\r\n Offset := TJclAddr(@pSymbols.Symbols[0]) - TJclAddr(pSymbols);\r\n while Offset < Size do\r\n begin\r\n pInfo := PSymbolInfo(TJclAddr(pSymbols) + Offset);\r\n case pInfo.SymbolType of\r\n SYMBOL_TYPE_LPROC32:\r\n begin\r\n Symbol := TJclTD32LocalProcSymbolInfo.Create(pInfo);\r\n FProcSymbols.Add(Symbol);\r\n end;\r\n SYMBOL_TYPE_GPROC32:\r\n begin\r\n Symbol := TJclTD32GlobalProcSymbolInfo.Create(pInfo);\r\n FProcSymbols.Add(Symbol);\r\n end;\r\n SYMBOL_TYPE_OBJNAME:\r\n Symbol := TJclTD32ObjNameSymbolInfo.Create(pInfo);\r\n SYMBOL_TYPE_LDATA32:\r\n Symbol := TJclTD32LDataSymbolInfo.Create(pInfo);\r\n SYMBOL_TYPE_GDATA32:\r\n Symbol := TJclTD32GDataSymbolInfo.Create(pInfo);\r\n SYMBOL_TYPE_PUB32:\r\n Symbol := TJclTD32PublicSymbolInfo.Create(pInfo);\r\n SYMBOL_TYPE_WITH32:\r\n Symbol := TJclTD32WithSymbolInfo.Create(pInfo);\r\n SYMBOL_TYPE_LABEL32:\r\n Symbol := TJclTD32LabelSymbolInfo.Create(pInfo);\r\n SYMBOL_TYPE_CONST:\r\n Symbol := TJclTD32ConstantSymbolInfo.Create(pInfo);\r\n SYMBOL_TYPE_UDT:\r\n Symbol := TJclTD32UdtSymbolInfo.Create(pInfo);\r\n SYMBOL_TYPE_VFTPATH32:\r\n Symbol := TJclTD32VftPathSymbolInfo.Create(pInfo);\r\n else\r\n Symbol := nil;\r\n end;\r\n if Assigned(Symbol) then\r\n FSymbols.Add(Symbol);\r\n Inc(Offset, pInfo.Size + SizeOf(pInfo.Size));\r\n end;\r\nend;\r\n\r\nprocedure TJclTD32InfoParser.AnalyseModules(pModInfo: PModuleInfo; const Size: DWORD);\r\nbegin\r\n FModules.Add(TJclTD32ModuleInfo.Create(pModInfo));\r\nend;\r\n\r\nprocedure TJclTD32InfoParser.AnalyseSourceModules(pSrcModInfo: PSourceModuleInfo; const Size: DWORD);\r\nvar\r\n I: Integer;\r\n pSrcFile: PSourceFileEntry;\r\nbegin\r\n {$RANGECHECKS OFF}\r\n for I := 0 to pSrcModInfo.FileCount - 1 do\r\n begin\r\n pSrcFile := PSourceFileEntry(TJclAddr(pSrcModInfo) + pSrcModInfo.BaseSrcFiles[I]);\r\n if pSrcFile.NameIndex > 0 then\r\n FSourceModules.Add(TJclTD32SourceModuleInfo.Create(pSrcFile, TJclAddr(pSrcModInfo)));\r\n end;\r\n {$IFDEF RANGECHECKS_ON}\r\n {$RANGECHECKS ON}\r\n {$ENDIF RANGECHECKS_ON}\r\nend;\r\n\r\nprocedure TJclTD32InfoParser.AnalyseUnknownSubSection(const pSubsection: Pointer; const Size: DWORD);\r\nbegin\r\n // do nothing\r\nend;\r\n\r\nfunction TJclTD32InfoParser.GetModule(const Idx: Integer): TJclTD32ModuleInfo;\r\nbegin\r\n Result := TJclTD32ModuleInfo(FModules.Items[Idx]);\r\nend;\r\n\r\nfunction TJclTD32InfoParser.GetModuleCount: Integer;\r\nbegin\r\n Result := FModules.Count;\r\nend;\r\n\r\nfunction TJclTD32InfoParser.GetName(const Idx: Integer): string;\r\nbegin\r\n Result := UTF8ToString(PAnsiChar(FNames.Items[Idx]));\r\nend;\r\n\r\nfunction TJclTD32InfoParser.GetNameCount: Integer;\r\nbegin\r\n Result := FNames.Count;\r\nend;\r\n\r\nfunction TJclTD32InfoParser.GetSourceModule(const Idx: Integer): TJclTD32SourceModuleInfo;\r\nbegin\r\n Result := TJclTD32SourceModuleInfo(FSourceModules.Items[Idx]);\r\nend;\r\n\r\nfunction TJclTD32InfoParser.GetSourceModuleCount: Integer;\r\nbegin\r\n Result := FSourceModules.Count;\r\nend;\r\n\r\nfunction TJclTD32InfoParser.GetSymbol(const Idx: Integer): TJclTD32SymbolInfo;\r\nbegin\r\n Result := TJclTD32SymbolInfo(FSymbols.Items[Idx]);\r\nend;\r\n\r\nfunction TJclTD32InfoParser.GetSymbolCount: Integer;\r\nbegin\r\n Result := FSymbols.Count;\r\nend;\r\n\r\nfunction TJclTD32InfoParser.GetProcSymbol(const Idx: Integer): TJclTD32ProcSymbolInfo;\r\nbegin\r\n Result := TJclTD32ProcSymbolInfo(FProcSymbols.Items[Idx]);\r\nend;\r\n\r\nfunction TJclTD32InfoParser.GetProcSymbolCount: Integer;\r\nbegin\r\n Result := FProcSymbols.Count;\r\nend;\r\n\r\nfunction TJclTD32InfoParser.FindModule(const AAddr: DWORD; out AMod: TJclTD32ModuleInfo): Boolean;\r\nvar\r\n I, J: Integer;\r\nbegin\r\n if ValidData then\r\n for I := 0 to ModuleCount - 1 do\r\n with Modules[I] do\r\n for J := 0 to SegmentCount - 1 do\r\n begin\r\n if (FSegments[J].Flags = 1) and (AAddr >= FSegments[J].Offset) and (AAddr - FSegments[J].Offset <= Segment[J].Size) then\r\n begin\r\n Result := True;\r\n AMod := Modules[I];\r\n Exit;\r\n end;\r\n end;\r\n Result := False;\r\n AMod := nil;\r\nend;\r\n\r\nfunction TJclTD32InfoParser.FindSourceModule(const AAddr: DWORD; out ASrcMod: TJclTD32SourceModuleInfo): Boolean;\r\nvar\r\n I, J: Integer;\r\nbegin\r\n if ValidData then\r\n for I := 0 to SourceModuleCount - 1 do\r\n with SourceModules[I] do\r\n for J := 0 to SegmentCount - 1 do\r\n with Segment[J] do\r\n if (StartOffset <= AAddr) and (AAddr < EndOffset) then\r\n begin\r\n Result := True;\r\n ASrcMod := SourceModules[I];\r\n Exit;\r\n end;\r\n ASrcMod := nil;\r\n Result := False;\r\nend;\r\n\r\nfunction TJclTD32InfoParser.FindProc(const AAddr: DWORD; out AProc: TJclTD32ProcSymbolInfo): Boolean;\r\nvar\r\n I: Integer;\r\nbegin\r\n if ValidData then\r\n for I := 0 to ProcSymbolCount - 1 do\r\n begin\r\n AProc := ProcSymbols[I];\r\n with AProc do\r\n if (Offset <= AAddr) and (AAddr < Offset + Size) then\r\n begin\r\n Result := True;\r\n Exit;\r\n end;\r\n end;\r\n AProc := nil;\r\n Result := False;\r\nend;\r\n\r\nclass function TJclTD32InfoParser.IsTD32DebugInfoValid(\r\n const DebugData: Pointer; const DebugDataSize: LongWord): Boolean;\r\nvar\r\n Sign: TJclTD32FileSignature;\r\n EndOfDebugData: TJclAddr;\r\nbegin\r\n Assert(not IsBadReadPtr(DebugData, DebugDataSize));\r\n Result := False;\r\n EndOfDebugData := TJclAddr(DebugData) + DebugDataSize;\r\n if DebugDataSize > SizeOf(Sign) then\r\n begin\r\n Sign := PJclTD32FileSignature(EndOfDebugData - SizeOf(Sign))^;\r\n if IsTD32Sign(Sign) and (Sign.Offset <= DebugDataSize) then\r\n begin\r\n Sign := PJclTD32FileSignature(EndOfDebugData - Sign.Offset)^;\r\n Result := IsTD32Sign(Sign);\r\n end;\r\n end;\r\nend;\r\n\r\nclass function TJclTD32InfoParser.IsTD32Sign(const Sign: TJclTD32FileSignature): Boolean;\r\nbegin\r\n Result := (Sign.Signature = Borland32BitSymbolFileSignatureForDelphi) or\r\n (Sign.Signature = Borland32BitSymbolFileSignatureForBCB);\r\nend;\r\n\r\nfunction TJclTD32InfoParser.LfaToVa(Lfa: DWORD): Pointer;\r\nbegin\r\n Result := Pointer(TJclAddr(FBase) + Lfa)\r\nend;\r\n\r\n//=== { TJclTD32InfoScanner } ================================================\r\n\r\nfunction TJclTD32InfoScanner.LineNumberFromAddr(AAddr: DWORD): Integer;\r\nvar\r\n Dummy: Integer;\r\nbegin\r\n Result := LineNumberFromAddr(AAddr, Dummy);\r\nend;\r\n\r\nfunction TJclTD32InfoScanner.LineNumberFromAddr(AAddr: DWORD; out Offset: Integer): Integer;\r\nvar\r\n ASrcMod: TJclTD32SourceModuleInfo;\r\n ALine: TJclTD32LineInfo;\r\nbegin\r\n if FindSourceModule(AAddr, ASrcMod) and ASrcMod.FindLine(AAddr, ALine) then\r\n begin\r\n Result := ALine.LineNo;\r\n Offset := AAddr - ALine.Offset;\r\n end\r\n else\r\n begin\r\n Result := 0;\r\n Offset := 0;\r\n end;\r\nend;\r\n\r\nfunction TJclTD32InfoScanner.ModuleNameFromAddr(AAddr: DWORD): string;\r\nvar\r\n AMod: TJclTD32ModuleInfo;\r\nbegin\r\n if FindModule(AAddr, AMod) then\r\n Result := Names[AMod.NameIndex]\r\n else\r\n Result := '';\r\nend;\r\n\r\nfunction TJclTD32InfoScanner.ProcNameFromAddr(AAddr: DWORD): string;\r\nvar\r\n Dummy: Integer;\r\nbegin\r\n Result := ProcNameFromAddr(AAddr, Dummy);\r\nend;\r\n\r\nfunction TJclTD32InfoScanner.ProcNameFromAddr(AAddr: DWORD; out Offset: Integer): string;\r\nvar\r\n AProc: TJclTD32ProcSymbolInfo;\r\n\r\n function FormatProcName(const ProcName: string): string;\r\n var\r\n pchSecondAt, P: PChar;\r\n begin\r\n Result := ProcName;\r\n if (Length(ProcName) > 0) and (ProcName[1] = '@') then\r\n begin\r\n pchSecondAt := StrScan(PChar(Copy(ProcName, 2, Length(ProcName) - 1)), '@');\r\n if pchSecondAt <> nil then\r\n begin\r\n Inc(pchSecondAt);\r\n Result := pchSecondAt;\r\n P := PChar(Result);\r\n while P^ <> #0 do\r\n begin\r\n if (pchSecondAt^ = '@') and ((pchSecondAt - 1)^ <> '@') then\r\n P^ := '.';\r\n Inc(P);\r\n Inc(pchSecondAt);\r\n end;\r\n end;\r\n end;\r\n end;\r\n\r\nbegin\r\n if FindProc(AAddr, AProc) then\r\n begin\r\n Result := FormatProcName(Names[AProc.NameIndex]);\r\n Offset := AAddr - AProc.Offset;\r\n end\r\n else\r\n begin\r\n Result := '';\r\n Offset := 0;\r\n end;\r\nend;\r\n\r\nfunction TJclTD32InfoScanner.SourceNameFromAddr(AAddr: DWORD): string;\r\nvar\r\n ASrcMod: TJclTD32SourceModuleInfo;\r\nbegin\r\n if FindSourceModule(AAddr, ASrcMod) then\r\n Result := Names[ASrcMod.NameIndex];\r\nend;\r\n\r\n{$IFDEF BORLAND}\r\n\r\n//=== { TJclPeBorTD32Image } =================================================\r\n\r\nprocedure TJclPeBorTD32Image.AfterOpen;\r\nbegin\r\n inherited AfterOpen;\r\n CheckDebugData;\r\nend;\r\n\r\nprocedure TJclPeBorTD32Image.CheckDebugData;\r\nbegin\r\n FIsTD32DebugPresent := IsDebugInfoInImage(FTD32DebugData);\r\n if not FIsTD32DebugPresent then\r\n FIsTD32DebugPresent := IsDebugInfoInTds(FTD32DebugData);\r\n if FIsTD32DebugPresent then\r\n begin\r\n FTD32Scanner := TJclTD32InfoScanner.Create(FTD32DebugData);\r\n if not FTD32Scanner.ValidData then\r\n begin\r\n ClearDebugData;\r\n if not NoExceptions then\r\n raise EJclError.CreateResFmt(@RsHasNotTD32Info, [FileName]);\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJclPeBorTD32Image.Clear;\r\nbegin\r\n ClearDebugData;\r\n inherited Clear;\r\nend;\r\n\r\nprocedure TJclPeBorTD32Image.ClearDebugData;\r\nbegin\r\n FIsTD32DebugPresent := False;\r\n FreeAndNil(FTD32Scanner);\r\n FreeAndNil(FTD32DebugData);\r\nend;\r\n\r\nfunction TJclPeBorTD32Image.IsDebugInfoInImage(var DataStream: TCustomMemoryStream): Boolean;\r\nvar\r\n DebugDir: TImageDebugDirectory;\r\n BugDataStart: Pointer;\r\n DebugDataSize: Integer;\r\nbegin\r\n Result := False;\r\n DataStream := nil;\r\n if IsBorlandImage and (DebugList.Count = 1) then\r\n begin\r\n DebugDir := DebugList[0];\r\n if DebugDir._Type = IMAGE_DEBUG_TYPE_UNKNOWN then\r\n begin\r\n BugDataStart := RvaToVa(DebugDir.AddressOfRawData);\r\n DebugDataSize := DebugDir.SizeOfData;\r\n Result := TJclTD32InfoParser.IsTD32DebugInfoValid(BugDataStart, DebugDataSize);\r\n if Result then\r\n DataStream := TJclReferenceMemoryStream.Create(BugDataStart, DebugDataSize);\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJclPeBorTD32Image.IsDebugInfoInTds(var DataStream: TCustomMemoryStream): Boolean;\r\nvar\r\n TdsFileName: TFileName;\r\n TempStream: TCustomMemoryStream;\r\nbegin\r\n Result := False;\r\n DataStream := nil;\r\n TdsFileName := ChangeFileExt(FileName, TurboDebuggerSymbolExt);\r\n if FileExists(TdsFileName) then\r\n begin\r\n TempStream := TJclFileMappingStream.Create(TdsFileName, fmOpenRead or fmShareDenyNone);\r\n try\r\n Result := TJclTD32InfoParser.IsTD32DebugInfoValid(TempStream.Memory, TempStream.Size);\r\n if Result then\r\n DataStream := TempStream\r\n else\r\n TempStream.Free;\r\n except\r\n TempStream.Free;\r\n raise;\r\n end;\r\n end;\r\nend;\r\n\r\n{$ENDIF BORLAND}\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jcl/source/windows/JclTask.pas", "content": "{**************************************************************************************************}\r\n{ }\r\n{ Project JEDI Code Library (JCL) }\r\n{ }\r\n{ The contents of this file are subject to the Mozilla Public License Version 1.1 (the \"License\"); }\r\n{ you may not use this file except in compliance with the License. You may obtain a copy of the }\r\n{ License at http://www.mozilla.org/MPL/ }\r\n{ }\r\n{ Software distributed under the License is distributed on an \"AS IS\" basis, WITHOUT WARRANTY OF }\r\n{ ANY KIND, either express or implied. See the License for the specific language governing rights }\r\n{ and limitations under the License. }\r\n{ }\r\n{ The Original Code is JclSvcCtrl.pas. }\r\n{ }\r\n{ The Initial Developer of the Original Code is Flier Lu (). }\r\n{ Portions created by Flier Lu are Copyright (C) Flier Lu. All Rights Reserved. }\r\n{ }\r\n{ Contributors: }\r\n{ Flier Lu (flier) }\r\n{ Robert Rossmair (rrossmair) }\r\n{ Petr Vones (pvones) }\r\n{ }\r\n{**************************************************************************************************}\r\n{ }\r\n{ This unit contains routines and classes to control Microsoft task schedule service }\r\n{ }\r\n{**************************************************************************************************}\r\n{ }\r\n{ Last modified: $Date:: 2011-11-03 20:21:05 +0100 (jeu. 03 nov. 2011) $ }\r\n{ Revision: $Rev:: 3621 $ }\r\n{ Author: $Author:: outchy $ }\r\n{ }\r\n{**************************************************************************************************}\r\n\r\nunit JclTask;\r\n\r\ninterface\r\n\r\n{$I jcl.inc}\r\n{$I windowsonly.inc}\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n {$IFDEF HAS_UNITSCOPE}\r\n Winapi.Windows, System.Classes, System.SysUtils, System.Contnrs,\r\n {$ELSE ~HAS_UNITSCOPE}\r\n Windows, Classes, SysUtils, Contnrs,\r\n {$ENDIF ~HAS_UNITSCOPE}\r\n MSTask,\r\n JclBase, JclSysUtils, JclSysInfo, JclWideStrings, JclWin32;\r\n\r\ntype\r\n TDateTimeArray = array of TDateTime;\r\n\r\n TJclScheduledTaskStatus = (tsUnknown, tsReady, tsRunning, tsNotScheduled, tsHasNotRun);\r\n\r\n TJclScheduledTaskFlag =\r\n (tfInteractive, tfDeleteWhenDone, tfDisabled, tfStartOnlyIfIdle,\r\n tfKillOnIdleEndl, tfDontStartIfOnBatteries, tfKillIfGoingOnBatteries,\r\n tfRunOnlyIfDocked, tfHidden, tfRunIfConnectedToInternet,\r\n tfRestartOnIdleResume, tfSystemRequired, tfRunOnlyIfLoggedOn);\r\n TJclScheduledTaskFlags = set of TJclScheduledTaskFlag;\r\n\r\n TJclScheduleTaskPropertyPage = (ppTask, ppSchedule, ppSettings);\r\n TJclScheduleTaskPropertyPages = set of TJclScheduleTaskPropertyPage;\r\n\r\nconst\r\n JclScheduleTaskAllPages = [ppTask, ppSchedule, ppSettings];\r\n\r\n LocalSystemAccount = 'SYSTEM'; // Local system account name\r\n InfiniteTime = 0.0;\r\n\r\ntype\r\n TJclScheduledTask = class;\r\n\r\n{$HPPEMIT '#define _di_ITaskScheduler ITaskScheduler*'}\r\n{$HPPEMIT '#define _di_ITask ITask*'}\r\n\r\n TJclTaskSchedule = class(TObject)\r\n private\r\n FTaskScheduler: ITaskScheduler;\r\n FTasks: TObjectList;\r\n function GetTargetComputer: WideString;\r\n procedure SetTargetComputer(const Value: WideString);\r\n function GetTask(const Idx: Integer): TJclScheduledTask;\r\n function GetTaskCount: Integer;\r\n public\r\n constructor Create(const ComputerName: WideString = '');\r\n destructor Destroy; override;\r\n procedure Refresh;\r\n function Add(const TaskName: WideString): TJclScheduledTask;\r\n procedure Delete(const Idx: Integer);\r\n function Remove(const TaskName: WideString): Integer; overload;\r\n function Remove(const TaskIntf: ITask): Integer; overload;\r\n function Remove(const ATask: TJclScheduledTask): Integer; overload;\r\n property TaskScheduler: ITaskScheduler read FTaskScheduler;\r\n property TargetComputer: WideString read GetTargetComputer write SetTargetComputer;\r\n property Tasks[const Idx: Integer]: TJclScheduledTask read GetTask; default;\r\n property TaskCount: Integer read GetTaskCount;\r\n public\r\n class function IsRunning: Boolean;\r\n class procedure Start;\r\n class procedure Stop;\r\n end;\r\n\r\n{$HPPEMIT '#define _di_ITaskTrigger ITaskTrigger*'}\r\n\r\n TJclTaskTrigger = class(TCollectionItem)\r\n private\r\n FTaskTrigger: ITaskTrigger;\r\n procedure SetTaskTrigger(const Value: ITaskTrigger);\r\n function GetTrigger: TTaskTrigger;\r\n procedure SetTrigger(const Value: TTaskTrigger);\r\n function GetTriggerString: WideString;\r\n public\r\n property TaskTrigger: ITaskTrigger read FTaskTrigger;\r\n property Trigger: TTaskTrigger read GetTrigger write SetTrigger;\r\n property TriggerString: WideString read GetTriggerString;\r\n end;\r\n\r\n TJclScheduledWorkItem = class;\r\n\r\n TJclTaskTriggers = class(TCollection)\r\n public\r\n FWorkItem: TJclScheduledWorkItem;\r\n function GetItem(Index: Integer): TJclTaskTrigger;\r\n procedure SetItem(Index: Integer; Value: TJclTaskTrigger);\r\n protected\r\n function GetOwner: TPersistent; override;\r\n public\r\n constructor Create(AWorkItem: TJclScheduledWorkItem);\r\n function Add(ATrigger: ITaskTrigger): TJclTaskTrigger; overload;\r\n function Add: TJclTaskTrigger; overload;\r\n function AddItem(Item: TJclTaskTrigger; Index: Integer): TJclTaskTrigger;\r\n function Insert(Index: Integer): TJclTaskTrigger;\r\n property Items[Index: Integer]: TJclTaskTrigger read GetItem write SetItem; default;\r\n end;\r\n\r\n{$HPPEMIT '#define _di_IScheduledWorkItem IScheduledWorkItem*'}\r\n\r\n TJclScheduledWorkItem = class(TPersistent)\r\n private\r\n FScheduledWorkItem: IScheduledWorkItem;\r\n FTaskName: WideString;\r\n FData: TMemoryStream;\r\n FTriggers: TJclTaskTriggers;\r\n function GetAccountName: WideString;\r\n procedure SetAccountName(const Value: WideString);\r\n procedure SetPassword(const Value: WideString);\r\n function GetComment: WideString;\r\n procedure SetComment(const Value: WideString);\r\n function GetCreator: WideString;\r\n procedure SetCreator(const Value: WideString);\r\n function GetExitCode: DWORD;\r\n function GetDeadlineMinutes: Word;\r\n function GetIdleMinutes: Word;\r\n function GetMostRecentRunTime: {$IFDEF HAS_UNITSCOPE}Winapi.{$ENDIF}Windows.TSystemTime;\r\n function GetNextRunTime: {$IFDEF HAS_UNITSCOPE}Winapi.{$ENDIF}Windows.TSystemTime;\r\n function GetStatus: TJclScheduledTaskStatus;\r\n function GetErrorRetryCount: Word;\r\n procedure SetErrorRetryCount(const Value: Word);\r\n function GetErrorRetryInterval: Word;\r\n procedure SetErrorRetryInterval(const Value: Word);\r\n function GetFlags: TJclScheduledTaskFlags;\r\n procedure SetFlags(const Value: TJclScheduledTaskFlags);\r\n function GetData: TStream; { TODO : stream is owned by instance }\r\n procedure SetData(const Value: TStream); { TODO : stream is owned by caller (copy) }\r\n function GetTrigger(const Idx: Integer): TJclTaskTrigger;\r\n function GetTriggerCount: Integer;\r\n public\r\n constructor Create(const ATaskName: WideString; const AScheduledWorkItem: IScheduledWorkItem);\r\n destructor Destroy; override;\r\n procedure Save;\r\n procedure Refresh;\r\n procedure Run;\r\n procedure Terminate;\r\n function AddTrigger: TJclTaskTrigger;\r\n procedure SetAccountInformation(const Name, Password: WideString);\r\n function GetRunTimes(const BeginTime: TDateTime; const EndTime: TDateTime = InfiniteTime): TDateTimeArray;\r\n property ScheduledWorkItem: IScheduledWorkItem read FScheduledWorkItem;\r\n property TaskName: WideString read FTaskName write FTaskName;\r\n property AccountName: WideString read GetAccountName write SetAccountName;\r\n property Password: WideString write SetPassword;\r\n property Comment: WideString read GetComment write SetComment;\r\n property Creator: WideString read GetCreator write SetCreator;\r\n property ErrorRetryCount: Word read GetErrorRetryCount write SetErrorRetryCount;\r\n property ErrorRetryInterval: Word read GetErrorRetryInterval write SetErrorRetryInterval;\r\n property ExitCode: DWORD read GetExitCode;\r\n property OwnerData: TStream read GetData write SetData; { TODO : wrong design, get: stream is owned by instance, set stream is owned by caller }\r\n property IdleMinutes: Word read GetIdleMinutes;\r\n property DeadlineMinutes: Word read GetDeadlineMinutes;\r\n property MostRecentRunTime: {$IFDEF HAS_UNITSCOPE}Winapi.{$ENDIF}Windows.TSystemTime read GetMostRecentRunTime;\r\n property NextRunTime: {$IFDEF HAS_UNITSCOPE}Winapi.{$ENDIF}Windows.TSystemTime read GetNextRunTime;\r\n property Status: TJclScheduledTaskStatus read GetStatus;\r\n property Flags: TJclScheduledTaskFlags read GetFlags write SetFlags;\r\n property Triggers[const Idx: Integer]: TJclTaskTrigger read GetTrigger; default;\r\n property TriggerCount: Integer read GetTriggerCount;\r\n end;\r\n\r\n TJclScheduledTask = class(TJclScheduledWorkItem)\r\n private\r\n function GetApplicationName: WideString;\r\n procedure SetApplicationName(const Value: WideString);\r\n function GetMaxRunTime: DWORD;\r\n procedure SetMaxRunTime(const Value: DWORD);\r\n function GetParameters: WideString;\r\n procedure SetParameters(const Value: WideString);\r\n function GetPriority: DWORD;\r\n procedure SetPriority(const Value: DWORD);\r\n function GetTaskFlags: DWORD;\r\n procedure SetTaskFlags(const Value: DWORD);\r\n function GetWorkingDirectory: WideString;\r\n procedure SetWorkingDirectory(const Value: WideString);\r\n function GetTask: ITask;\r\n public\r\n function ShowPage(Pages: TJclScheduleTaskPropertyPages = JclScheduleTaskAllPages): Boolean;\r\n property Task: ITask read GetTask;\r\n property ApplicationName: WideString read GetApplicationName write SetApplicationName;\r\n property WorkingDirectory: WideString read GetWorkingDirectory write SetWorkingDirectory;\r\n property MaxRunTime: DWORD read GetMaxRunTime write SetMaxRunTime;\r\n property Parameters: WideString read GetParameters write SetParameters;\r\n property Priority: DWORD read GetPriority write SetPriority;\r\n property TaskFlags: DWORD read GetTaskFlags write SetTaskFlags;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jcl.svn.sourceforge.net/svnroot/jcl/tags/JCL-2.4-Build4571/jcl/source/windows/JclTask.pas $';\r\n Revision: '$Revision: 3621 $';\r\n Date: '$Date: 2011-11-03 20:21:05 +0100 (jeu. 03 nov. 2011) $';\r\n LogPath: 'JCL\\source\\windows';\r\n Extra: '';\r\n Data: nil\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n {$IFDEF HAS_UNITSCOPE}\r\n Winapi.ActiveX, System.Win.ComObj,\r\n {$IFDEF BORLAND}\r\n Winapi.CommCtrl,\r\n {$ENDIF BORLAND}\r\n {$ELSE ~HAS_UNITSCOPE}\r\n ActiveX, ComObj,\r\n {$IFDEF BORLAND}\r\n CommCtrl,\r\n {$ENDIF BORLAND}\r\n {$ENDIF ~HAS_UNITSCOPE}\r\n JclSvcCtrl;\r\n\r\nconst\r\n TaskFlagMapping: array [TJclScheduledTaskFlag] of DWORD =\r\n (TASK_FLAG_INTERACTIVE, TASK_FLAG_DELETE_WHEN_DONE, TASK_FLAG_DISABLED,\r\n TASK_FLAG_START_ONLY_IF_IDLE, TASK_FLAG_KILL_ON_IDLE_END,\r\n TASK_FLAG_DONT_START_IF_ON_BATTERIES, TASK_FLAG_KILL_IF_GOING_ON_BATTERIES,\r\n TASK_FLAG_RUN_ONLY_IF_DOCKED, TASK_FLAG_HIDDEN,\r\n TASK_FLAG_RUN_IF_CONNECTED_TO_INTERNET, TASK_FLAG_RESTART_ON_IDLE_RESUME,\r\n TASK_FLAG_SYSTEM_REQUIRED, TASK_FLAG_RUN_ONLY_IF_LOGGED_ON);\r\n\r\n//== { TJclTaskSchedule } ====================================================\r\n\r\nconstructor TJclTaskSchedule.Create(const ComputerName: WideString = '');\r\nbegin\r\n inherited Create;\r\n FTaskScheduler := CreateComObject(CLSID_CTaskScheduler) as ITaskScheduler;\r\n FTasks := TObjectList.Create;\r\n if ComputerName <> '' then\r\n SetTargetComputer(ComputerName);\r\nend;\r\n\r\ndestructor TJclTaskSchedule.Destroy;\r\nbegin\r\n FreeAndNil(FTasks);\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJclTaskSchedule.GetTargetComputer: WideString;\r\nvar\r\n ComputerName: PWideChar;\r\nbegin\r\n OleCheck(FTaskScheduler.GetTargetComputer(ComputerName));\r\n Result := ComputerName;\r\n CoTaskMemFree(ComputerName);\r\nend;\r\n\r\nprocedure TJclTaskSchedule.SetTargetComputer(const Value: WideString);\r\nbegin\r\n OleCheck(FTaskScheduler.SetTargetComputer(PWideCharOrNil(Value)));\r\nend;\r\n\r\nclass function TJclTaskSchedule.IsRunning: Boolean;\r\n\r\n function IsRunning9x: Boolean;\r\n begin\r\n Result := FindWindow('SAGEWINDOWCLASS', 'SYSTEM AGENT COM WINDOW') <> 0;\r\n end;\r\n\r\n function IsRunningNt: Boolean;\r\n var\r\n NtSvc: TJclNtService;\r\n begin\r\n with TJclSCManager.Create do\r\n try\r\n Refresh(True);\r\n Result := FindService('Schedule', NtSvc) and (NtSvc.ServiceState = ssRunning);\r\n finally\r\n Free;\r\n end;\r\n end;\r\n\r\nbegin\r\n if IsWinNT then\r\n Result := IsRunningNt\r\n else\r\n Result := IsRunning9x;\r\nend;\r\n\r\nclass procedure TJclTaskSchedule.Start;\r\n\r\n procedure Start9x;\r\n var\r\n AppName: array [0..MAX_PATH] of Char;\r\n FilePart: PChar;\r\n si: TStartupInfo;\r\n pi: TProcessInformation;\r\n begin\r\n FilePart := nil;\r\n Win32Check(SearchPath(nil, 'mstask.exe', nil, MAX_PATH, AppName, FilePart) > 0);\r\n\r\n ResetMemory(si, SizeOf(si));\r\n si.cb := SizeOf(si);\r\n ResetMemory(pi, SizeOf(pi));\r\n Win32Check(CreateProcess(AppName, nil, nil, nil, False,\r\n CREATE_NEW_CONSOLE or CREATE_NEW_PROCESS_GROUP, nil, nil, si, pi));\r\n\r\n CloseHandle(pi.hProcess);\r\n CloseHandle(pi.hThread);\r\n end;\r\n\r\n procedure StartNt;\r\n var\r\n NtSvc: TJclNtService;\r\n begin\r\n with TJclSCManager.Create do\r\n try\r\n Refresh;\r\n if FindService('Schedule', NtSvc) then\r\n NtSvc.Start;\r\n finally\r\n Free;\r\n end;\r\n end;\r\n\r\nbegin\r\n if IsWinNT then\r\n StartNt\r\n else\r\n Start9x;\r\nend;\r\n\r\nclass procedure TJclTaskSchedule.Stop;\r\n\r\n procedure Stop9x;\r\n var\r\n hProcess: THandle;\r\n begin\r\n if IsRunning then\r\n begin\r\n hProcess := OpenProcess(PROCESS_TERMINATE, False,\r\n GetWindowThreadProcessId(\r\n FindWindow('SAGEWINDOWCLASS', 'SYSTEM AGENT COM WINDOW'), nil));\r\n Win32Check(hProcess <> 0);\r\n Win32Check(TerminateProcess(hProcess, ERROR_PROCESS_ABORTED));\r\n Win32Check(CloseHandle(hProcess));\r\n end;\r\n end;\r\n\r\n procedure StopNt;\r\n var\r\n NtSvc: TJclNtService;\r\n begin\r\n with TJclSCManager.Create do\r\n try\r\n if FindService('Schedule', NtSvc) then\r\n NtSvc.Stop;\r\n finally\r\n Free;\r\n end;\r\n end;\r\n\r\nbegin\r\n if Win32Platform = VER_PLATFORM_WIN32_NT then\r\n StopNt\r\n else\r\n Stop9x;\r\nend;\r\n\r\nfunction TJclTaskSchedule.GetTask(const Idx: Integer): TJclScheduledTask;\r\nbegin\r\n Result := TJclScheduledTask(FTasks.Items[Idx]);\r\nend;\r\n\r\nfunction TJclTaskSchedule.GetTaskCount: Integer;\r\nbegin\r\n Result := FTasks.Count;\r\nend;\r\n\r\nprocedure TJclTaskSchedule.Refresh;\r\nvar\r\n EnumWorkItems: IEnumWorkItems;\r\n ItemName: PLPWSTR;\r\n RealItemName: PWideChar;\r\n FetchedCount: DWORD;\r\n TaskIid: TIID;\r\n spUnk: IUnknown;\r\n ATask: TJclScheduledTask;\r\nbegin\r\n OleCheck(TaskScheduler.Enum(EnumWorkItems));\r\n TaskIid := IID_ITask;\r\n ItemName := nil;\r\n FTasks.Clear;\r\n while SUCCEEDED(EnumWorkItems.Next(1, ItemName, FetchedCount)) and (FetchedCount > 0) do\r\n begin\r\n RealItemName := ItemName^;\r\n OleCheck(TaskScheduler.Activate(RealItemName, TaskIid, spUnk));\r\n ATask := TJclScheduledTask.Create(RealItemName, spUnk as ITask);\r\n ATask.Refresh;\r\n FTasks.Add(ATask);\r\n end;\r\nend;\r\n\r\nfunction TJclTaskSchedule.Add(const TaskName: WideString): TJclScheduledTask;\r\nvar\r\n TaskClsId: TCLSID;\r\n TaskIid: TIID;\r\n spUnk: IUnknown;\r\nbegin\r\n TaskClsId := CLSID_CTask;\r\n TaskIid := IID_ITask;\r\n OleCheck(TaskScheduler.NewWorkItem(PWideChar(TaskName), TaskClsId, TaskIid, spUnk));\r\n Result := TJclScheduledTask.Create(TaskName, spUnk as ITask);\r\n Result.SetAccountInformation(LocalSystemAccount, '');\r\n Result.Save;\r\n Result.Refresh;\r\n FTasks.Add(Result);\r\nend;\r\n\r\nprocedure TJclTaskSchedule.Delete(const Idx: Integer);\r\nbegin\r\n Remove(Tasks[Idx]);\r\nend;\r\n\r\nfunction TJclTaskSchedule.Remove(const TaskName: WideString): Integer;\r\nbegin\r\n for Result := 0 to TaskCount-1 do\r\n if WideCompareText(Tasks[Result].TaskName, TaskName) = 0 then\r\n begin\r\n Delete(Result);\r\n Exit;\r\n end;\r\n Result := -1;\r\nend;\r\n\r\nfunction TJclTaskSchedule.Remove(const TaskIntf: ITask): Integer;\r\nbegin\r\n for Result := 0 to TaskCount-1 do\r\n if Tasks[Result].Task = TaskIntf then\r\n begin\r\n Delete(Result);\r\n Exit;\r\n end;\r\n Result := -1;\r\nend;\r\n\r\nfunction TJclTaskSchedule.Remove(const ATask: TJclScheduledTask): Integer;\r\nbegin\r\n Result := FTasks.IndexOf(ATask);\r\n if Result <> -1 then\r\n begin\r\n FTaskScheduler.Delete(PWideChar(Tasks[Result].TaskName));\r\n FTasks.Delete(Result);\r\n Exit;\r\n end;\r\nend;\r\n\r\n//=== { TJclTaskTrigger } ====================================================\r\n\r\nprocedure TJclTaskTrigger.SetTaskTrigger(const Value: ITaskTrigger);\r\nbegin\r\n FTaskTrigger := Value;\r\nend;\r\n\r\nfunction TJclTaskTrigger.GetTrigger: TTaskTrigger;\r\nbegin\r\n Result.cbTriggerSize := SizeOf(Result);\r\n OleCheck(TaskTrigger.GetTrigger(Result));\r\nend;\r\n\r\nprocedure TJclTaskTrigger.SetTrigger(const Value: TTaskTrigger);\r\nbegin\r\n OleCheck(TaskTrigger.SetTrigger(Value));\r\nend;\r\n\r\nfunction TJclTaskTrigger.GetTriggerString: WideString;\r\nvar\r\n Trigger: PWideChar;\r\nbegin\r\n OleCheck(TaskTrigger.GetTriggerString(Trigger));\r\n Result := Trigger;\r\n CoTaskMemFree(Trigger);\r\nend;\r\n\r\n//=== { TJclTaskTriggers } ===================================================\r\n\r\nconstructor TJclTaskTriggers.Create(AWorkItem: TJclScheduledWorkItem);\r\nbegin\r\n inherited Create(TJclTaskTrigger);\r\n FWorkItem := AWorkItem;\r\nend;\r\n\r\nfunction TJclTaskTriggers.GetItem(Index: Integer): TJclTaskTrigger;\r\nbegin\r\n Result := TJclTaskTrigger(inherited GetItem(Index));\r\nend;\r\n\r\nprocedure TJclTaskTriggers.SetItem(Index: Integer; Value: TJclTaskTrigger);\r\nbegin\r\n inherited SetItem(Index, Value);\r\nend;\r\n\r\nfunction TJclTaskTriggers.GetOwner: TPersistent;\r\nbegin\r\n Result := FWorkItem;\r\nend;\r\n\r\nfunction TJclTaskTriggers.Add(ATrigger: ITaskTrigger): TJclTaskTrigger;\r\nbegin\r\n Result := Add;\r\n Result.SetTaskTrigger(ATrigger);\r\nend;\r\n\r\nfunction TJclTaskTriggers.Add: TJclTaskTrigger;\r\nbegin\r\n Result := TJclTaskTrigger(inherited Add);\r\nend;\r\n\r\nfunction TJclTaskTriggers.AddItem(Item: TJclTaskTrigger; Index: Integer): TJclTaskTrigger;\r\nbegin\r\n if Item = nil then\r\n Result := Add\r\n else\r\n Result := Item;\r\n\r\n if Assigned(Result) then\r\n begin\r\n Result.Collection := Self;\r\n if Index < 0 then\r\n Index := Count - 1;\r\n Result.Index := Index;\r\n end;\r\nend;\r\n\r\nfunction TJclTaskTriggers.Insert(Index: Integer): TJclTaskTrigger;\r\nbegin\r\n Result := AddItem(nil, Index);\r\nend;\r\n\r\n//=== { TJclScheduledWorkItem } ==============================================\r\n\r\nconstructor TJclScheduledWorkItem.Create(const ATaskName: WideString;\r\n const AScheduledWorkItem: IScheduledWorkItem);\r\nbegin\r\n inherited Create;\r\n FScheduledWorkItem := AScheduledWorkItem;\r\n FTaskName := ATaskName;\r\n FData := TMemoryStream.Create;\r\n FTriggers := TJclTaskTriggers.Create(Self);\r\nend;\r\n\r\ndestructor TJclScheduledWorkItem.Destroy;\r\nbegin\r\n FreeAndNil(FTriggers);\r\n FreeAndNil(FData);\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJclScheduledWorkItem.AddTrigger: TJclTaskTrigger;\r\nvar\r\n TaskTrigger: ITaskTrigger;\r\n Dummy: Word;\r\nbegin\r\n Result := FTriggers.Add;\r\n OleCheck(ScheduledWorkItem.CreateTrigger(Dummy, TaskTrigger));\r\n Result.SetTaskTrigger(TaskTrigger);\r\nend;\r\n\r\nprocedure TJclScheduledWorkItem.Save;\r\nbegin\r\n OleCheck((FScheduledWorkItem as IPersistFile).Save(nil, True));\r\nend;\r\n\r\nprocedure TJclScheduledWorkItem.Run;\r\nbegin\r\n OleCheck(FScheduledWorkItem.Run);\r\nend;\r\n\r\nprocedure TJclScheduledWorkItem.Terminate;\r\nbegin\r\n OleCheck(FScheduledWorkItem.Terminate);\r\nend;\r\n\r\nfunction TJclScheduledWorkItem.GetAccountName: WideString;\r\nvar\r\n AccountName: PWideChar;\r\nbegin\r\n Result := '';\r\n if IsWinNT then // ignore this method in Win9x/ME\r\n try\r\n OleCheck(FScheduledWorkItem.GetAccountInformation(AccountName));\r\n Result := AccountName;\r\n CoTaskMemFree(AccountName);\r\n\r\n if Result = '' then\r\n Result := GetLocalComputerName + '\\' + LocalSystemAccount;\r\n except\r\n Result := '';\r\n end;\r\nend;\r\n\r\nprocedure TJclScheduledWorkItem.SetAccountInformation(const Name, Password: WideString);\r\nbegin\r\n if IsWinNT then // ignore this method in Win9x/ME\r\n if (Name = LocalSystemAccount) or (Name = '') then\r\n OleCheck(FScheduledWorkItem.SetAccountInformation('', nil))\r\n else\r\n OleCheck(FScheduledWorkItem.SetAccountInformation(PWideChar(Name), PWideChar(Password)));\r\nend;\r\n\r\nprocedure TJclScheduledWorkItem.SetAccountName(const Value: WideString);\r\nbegin\r\n SetAccountInformation(Value, '');\r\nend;\r\n\r\nprocedure TJclScheduledWorkItem.SetPassword(const Value: WideString);\r\nbegin\r\n SetAccountInformation(GetAccountName, Value);\r\nend;\r\n\r\nfunction TJclScheduledWorkItem.GetComment: WideString;\r\nvar\r\n Comment: PWideChar;\r\nbegin\r\n OleCheck(FScheduledWorkItem.GetComment(Comment));\r\n Result := Comment;\r\n CoTaskMemFree(Comment);\r\nend;\r\n\r\nprocedure TJclScheduledWorkItem.SetComment(const Value: WideString);\r\nbegin\r\n OleCheck(FScheduledWorkItem.SetComment(PWideChar(Value)));\r\nend;\r\n\r\nfunction TJclScheduledWorkItem.GetCreator: WideString;\r\nvar\r\n Creator: PWideChar;\r\nbegin\r\n OleCheck(FScheduledWorkItem.GetCreator(Creator));\r\n Result := Creator;\r\n CoTaskMemFree(Creator);\r\nend;\r\n\r\nprocedure TJclScheduledWorkItem.SetCreator(const Value: WideString);\r\nbegin\r\n OleCheck(FScheduledWorkItem.SetCreator(PWideChar(Value)));\r\nend;\r\n\r\nfunction TJclScheduledWorkItem.GetExitCode: DWORD;\r\nbegin\r\n OleCheck(FScheduledWorkItem.GetExitCode(Result));\r\nend;\r\n\r\nfunction TJclScheduledWorkItem.GetDeadlineMinutes: Word;\r\nvar\r\n Dummy: Word;\r\nbegin\r\n OleCheck(FScheduledWorkItem.GetIdleWait(Result, Dummy));\r\nend;\r\n\r\nfunction TJclScheduledWorkItem.GetIdleMinutes: Word;\r\nvar\r\n Dummy: Word;\r\nbegin\r\n OleCheck(FScheduledWorkItem.GetIdleWait(Dummy, Result));\r\nend;\r\n\r\nfunction TJclScheduledWorkItem.GetMostRecentRunTime: TSystemTime;\r\nbegin\r\n OleCheck(FScheduledWorkItem.GetMostRecentRunTime(Result));\r\nend;\r\n\r\nfunction TJclScheduledWorkItem.GetNextRunTime: TSystemTime;\r\nbegin\r\n OleCheck(FScheduledWorkItem.GetNextRunTime(Result));\r\nend;\r\n\r\nfunction TJclScheduledWorkItem.GetRunTimes(const BeginTime, EndTime: TDateTime): TDateTimeArray;\r\nvar\r\n BeginSysTime, EndSysTime: TSystemTime;\r\n I, Count: Word;\r\n TaskTimes: PSystemTime;\r\nbegin\r\n DateTimeToSystemTime(BeginTime, BeginSysTime);\r\n DateTimeToSystemTime(EndTime, EndSysTime);\r\n\r\n Count := 0;\r\n if EndTime = InfiniteTime then\r\n OleCheck(FScheduledWorkItem.GetRunTimes(@BeginSysTime, nil, Count, TaskTimes))\r\n else\r\n OleCheck(FScheduledWorkItem.GetRunTimes(@BeginSysTime, @EndSysTime, Count, TaskTimes));\r\n try\r\n SetLength(Result, Count);\r\n for I := 0 to Count-1 do\r\n begin\r\n Result[I] := SystemTimeToDateTime({$IFDEF HAS_UNITSCOPE}Winapi.{$ENDIF}Windows.PSystemTime(TaskTimes)^);\r\n Inc(TaskTimes);\r\n end;\r\n finally\r\n CoTaskMemFree(TaskTimes);\r\n end;\r\nend;\r\n\r\nfunction TJclScheduledWorkItem.GetStatus: TJclScheduledTaskStatus;\r\nvar\r\n Status: HRESULT;\r\nbegin\r\n OleCheck(FScheduledWorkItem.GetStatus(Status));\r\n case Status of\r\n SCHED_S_TASK_READY:\r\n Result := tsReady;\r\n SCHED_S_TASK_RUNNING:\r\n Result := tsRunning;\r\n SCHED_S_TASK_NOT_SCHEDULED:\r\n Result := tsNotScheduled;\r\n SCHED_S_TASK_HAS_NOT_RUN:\r\n Result := tsHasNotRun;\r\n else\r\n Result := tsUnknown;\r\n end;\r\nend;\r\n\r\nfunction TJclScheduledWorkItem.GetErrorRetryCount: Word;\r\nbegin\r\n OleCheck(FScheduledWorkItem.GetErrorRetryCount(Result));\r\nend;\r\n\r\nprocedure TJclScheduledWorkItem.SetErrorRetryCount(const Value: Word);\r\nbegin\r\n OleCheck(FScheduledWorkItem.SetErrorRetryCount(Value));\r\nend;\r\n\r\nfunction TJclScheduledWorkItem.GetErrorRetryInterval: Word;\r\nbegin\r\n OleCheck(FScheduledWorkItem.GetErrorRetryInterval(Result));\r\nend;\r\n\r\nprocedure TJclScheduledWorkItem.SetErrorRetryInterval(const Value: Word);\r\nbegin\r\n OleCheck(FScheduledWorkItem.SetErrorRetryInterval(Value));\r\nend;\r\n\r\nfunction TJclScheduledWorkItem.GetFlags: TJclScheduledTaskFlags;\r\nvar\r\n AFlags: DWORD;\r\n AFlag: TJclScheduledTaskFlag;\r\nbegin\r\n OleCheck(FScheduledWorkItem.GetFlags(AFlags));\r\n Result := [];\r\n for AFlag:=Low(TJclScheduledTaskFlag) to High(TJclScheduledTaskFlag) do\r\n if (AFlags and TaskFlagMapping[AFlag]) = TaskFlagMapping[AFlag] then\r\n Include(Result, AFlag);\r\nend;\r\n\r\nprocedure TJclScheduledWorkItem.SetFlags(const Value: TJclScheduledTaskFlags);\r\nvar\r\n AFlags: DWORD;\r\n AFlag: TJclScheduledTaskFlag;\r\nbegin\r\n AFlags := 0;\r\n for AFlag:=Low(TJclScheduledTaskFlag) to High(TJclScheduledTaskFlag) do\r\n if AFlag in Value then\r\n AFlags := AFlags or TaskFlagMapping[AFlag];\r\n OleCheck(FScheduledWorkItem.SetFlags(AFlags));\r\nend;\r\n\r\nfunction TJclScheduledWorkItem.GetData: TStream;\r\nvar\r\n Count: Word;\r\n Buf: PByte;\r\nbegin\r\n FData.Clear;\r\n Buf := nil;\r\n OleCheck(FScheduledWorkItem.GetWorkItemData(Count, Buf));\r\n try\r\n FData.Write(Buf^, Count);\r\n FData.Seek(0, soFromBeginning);\r\n finally\r\n CoTaskMemFree(Buf);\r\n end;\r\n Result := FData;\r\nend;\r\n\r\nprocedure TJclScheduledWorkItem.SetData(const Value: TStream);\r\nbegin\r\n FData.Clear;\r\n FData.CopyFrom(Value, 0);\r\n OleCheck(FScheduledWorkItem.SetWorkItemData(FData.Size, PByte(FData.Memory)));\r\nend;\r\n\r\nprocedure TJclScheduledWorkItem.Refresh;\r\nvar\r\n I, Count: Word;\r\n ATrigger: ITaskTrigger;\r\nbegin\r\n OleCheck(FScheduledWorkItem.GetTriggerCount(Count));\r\n\r\n FTriggers.Clear;\r\n if Count > 0 then\r\n for I:=0 to Count-1 do\r\n begin\r\n OleCheck(FScheduledWorkItem.GetTrigger(I, ATrigger));\r\n FTriggers.Add(ATrigger);\r\n end;\r\nend;\r\n\r\nfunction TJclScheduledWorkItem.GetTriggerCount: Integer;\r\nbegin\r\n Result := FTriggers.Count;\r\nend;\r\n\r\nfunction TJclScheduledWorkItem.GetTrigger(const Idx: Integer): TJclTaskTrigger;\r\nbegin\r\n Result := TJclTaskTrigger(FTriggers.Items[Idx]);\r\nend;\r\n\r\n//=== { TJclScheduledTask } ==================================================\r\n\r\nfunction TJclScheduledTask.GetApplicationName: WideString;\r\nvar\r\n AppName: PWideChar;\r\nbegin\r\n OleCheck(Task.GetApplicationName(AppName));\r\n Result := AppName;\r\n CoTaskMemFree(AppName);\r\nend;\r\n\r\nprocedure TJclScheduledTask.SetApplicationName(const Value: WideString);\r\nbegin\r\n OleCheck(Task.SetApplicationName(PWideChar(Value)));\r\nend;\r\n\r\nfunction TJclScheduledTask.GetMaxRunTime: DWORD;\r\nbegin\r\n OleCheck(Task.GetMaxRunTime(Result));\r\nend;\r\n\r\nprocedure TJclScheduledTask.SetMaxRunTime(const Value: DWORD);\r\nbegin\r\n OleCheck(Task.SetMaxRunTime(Value));\r\nend;\r\n\r\nfunction TJclScheduledTask.GetParameters: WideString;\r\nvar\r\n Parameters: PWideChar;\r\nbegin\r\n OleCheck(Task.GetParameters(Parameters));\r\n Result := Parameters;\r\n CoTaskMemFree(Parameters);\r\nend;\r\n\r\nprocedure TJclScheduledTask.SetParameters(const Value: WideString);\r\nbegin\r\n OleCheck(Task.SetParameters(PWideChar(Value)));\r\nend;\r\n\r\nfunction TJclScheduledTask.GetPriority: DWORD;\r\nbegin\r\n OleCheck(Task.GetPriority(Result));\r\nend;\r\n\r\nprocedure TJclScheduledTask.SetPriority(const Value: DWORD);\r\nbegin\r\n OleCheck(Task.SetPriority(Value));\r\nend;\r\n\r\nfunction TJclScheduledTask.GetTaskFlags: DWORD;\r\nbegin\r\n OleCheck(Task.GetTaskFlags(Result));\r\nend;\r\n\r\nprocedure TJclScheduledTask.SetTaskFlags(const Value: DWORD);\r\nbegin\r\n OleCheck(Task.SetTaskFlags(Value));\r\nend;\r\n\r\nfunction TJclScheduledTask.GetWorkingDirectory: WideString;\r\nvar\r\n WorkingDir: PWideChar;\r\nbegin\r\n OleCheck(Task.GetWorkingDirectory(WorkingDir));\r\n Result := WorkingDir;\r\n CoTaskMemFree(WorkingDir);\r\nend;\r\n\r\nprocedure TJclScheduledTask.SetWorkingDirectory(const Value: WideString);\r\nbegin\r\n OleCheck(Task.SetWorkingDirectory(PWideChar(Value)));\r\nend;\r\n\r\n{$IFDEF FPC}\r\n// strange issue ther, PropertySheet is declared in commctrl but FPC cannot resolve it\r\nfunction PropertySheet(const lppsph:PROPSHEETHEADER):longint; external 'commctrl.dll' name 'PropertySheetW';\r\n{$ENDIF FPC}\r\n\r\nfunction TJclScheduledTask.ShowPage(Pages: TJclScheduleTaskPropertyPages): Boolean;\r\nvar\r\n PageCount: Integer;\r\n PropPages: array [0..2] of {$IFDEF BORLAND}MSTask.{$ENDIF}HPropSheetPage;\r\n PropHeader: TPropSheetHeader;\r\nbegin\r\n PageCount := 0;\r\n if ppTask in Pages then\r\n begin\r\n OleCheck((FScheduledWorkItem as IProvideTaskPage).GetPage(TASKPAGE_TASK, True, PropPages[PageCount]));\r\n Inc(PageCount);\r\n end;\r\n if ppSchedule in Pages then\r\n begin\r\n OleCheck((FScheduledWorkItem as IProvideTaskPage).GetPage(TASKPAGE_SCHEDULE, True, PropPages[PageCount]));\r\n Inc(PageCount);\r\n end;\r\n if ppSettings in Pages then\r\n begin\r\n OleCheck((FScheduledWorkItem as IProvideTaskPage).GetPage(TASKPAGE_SETTINGS, True, PropPages[PageCount]));\r\n Inc(PageCount);\r\n end;\r\n\r\n ResetMemory(PropHeader, SizeOf(PropHeader));\r\n PropHeader.dwSize := SizeOf(PropHeader);\r\n PropHeader.dwFlags := PSH_DEFAULT or PSH_NOAPPLYNOW;\r\n PropHeader.phpage := @PropPages;\r\n PropHeader.nPages := PageCount;\r\n Result := PropertySheet(PropHeader) > 0;\r\nend;\r\n\r\nfunction TJclScheduledTask.GetTask: ITask;\r\nbegin\r\n Result := ScheduledWorkItem as ITask;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jcl/source/windows/JclTimeZones.pas", "content": "{**************************************************************************************************}\r\n{ }\r\n{ Project JEDI Code Library (JCL) }\r\n{ }\r\n{ The contents of this file are subject to the Mozilla Public License Version 1.1 (the \"License\"); }\r\n{ you may not use this file except in compliance with the License. You may obtain a copy of the }\r\n{ License at http://www.mozilla.org/MPL/ }\r\n{ }\r\n{ Software distributed under the License is distributed on an \"AS IS\" basis, WITHOUT WARRANTY OF }\r\n{ ANY KIND, either express or implied. See the License for the specific language governing rights }\r\n{ and limitations under the License. }\r\n{ }\r\n{ The Original Code is TimeZones.pas. }\r\n{ }\r\n{ The Initial Developer of the Original Code is Rik Barker }\r\n{ . }\r\n{ Portions created by Rik Barker are Copyright (C) Rik Barker. All Rights Reserved. }\r\n{ }\r\n{ Contributors: }\r\n{ }\r\n{**************************************************************************************************}\r\n{ }\r\n{ Routines and classes for working with Timezones and UTC dates. }\r\n{ }\r\n{**************************************************************************************************}\r\n{ }\r\n{ Last modified: $Date:: 2011-09-03 00:07:50 +0200 (sam. 03 sept. 2011) $ }\r\n{ Revision: $Rev:: 3599 $ }\r\n{ Author: $Author:: outchy $ }\r\n{ }\r\n{**************************************************************************************************}\r\n\r\n\r\n{**************************************************************************************************}\r\n{ Important: }\r\n{ Information on Timezones is pretty sparse and often vague. }\r\n{ According to MSDN GetTimeZoneInformation will return TIME_ZONE_ID_DAYLIGHT if }\r\n{ }\r\n{ \"the system is operating in the range covered by the DaylightDate }\r\n{ member of the TIME_ZONE_INFORMATION structure.\" }\r\n{ }\r\n{ What it fails to mention is that it will take liberties with the TIME_ZONE_INFORMATION structure.}\r\n{ Unless \"Automatically Adjust clock for Daylight savings changes\" is enabled, DayLightDate }\r\n{ will contain StandardDate and DayLightName will contain StandardName. }\r\n{ So you know you're supposed to be in daylight savings, but you can't find out when it started or }\r\n{ what the Daylight Name is. }\r\n{ }\r\n{ Where possible use the functions/classes that read the data direct from the registry, }\r\n{ these will always return the correct daylight savings date and name }\r\n{**************************************************************************************************}\r\n\r\nunit JclTimeZones;\r\n\r\n{$I jcl.inc}\r\n{$I windowsonly.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n {$IFDEF HAS_UNITSCOPE}\r\n Winapi.Windows, System.SysUtils, System.Contnrs, System.Classes,\r\n {$ELSE ~HAS_UNITSCOPE}\r\n Windows, SysUtils, Contnrs, Classes,\r\n {$ENDIF ~HAS_UNITSCOPE}\r\n JclBase;\r\n\r\ntype\r\n // Contents of the TZI value in the Time Zones section of the registry\r\n TJclTZIValueInfo = record\r\n Bias: Longint;\r\n StandardBias: Integer;\r\n DaylightBias: Integer;\r\n StandardDate: TSystemTime;\r\n DaylightDate: TSystemTime;\r\n end;\r\n\r\n // All other Time Zone values in the registry\r\n PJclTimeZoneRegInfo = ^TJclTimeZoneRegInfo;\r\n TJclTimeZoneRegInfo = record\r\n DisplayDesc: string;\r\n StandardName: string;\r\n DaylightName: string;\r\n SortIndex: Integer;\r\n MapID: string;\r\n TZI: TJclTZIValueInfo;\r\n end;\r\n\r\ntype\r\n // Callback prototype for EnumTimeZones\r\n TJclTimeZoneCallBackFunc = function(const TimeZoneRec: TJclTimeZoneRegInfo): Boolean of object;\r\n\r\ntype\r\n TJclTimeZoneInfo = class(TObject)\r\n private\r\n FStandardName: string;\r\n FDaylightName: string;\r\n FTZDescription: string;\r\n FSortIndex: Integer; // Order to sort the timezones into\r\n FMapID: string; // Coordinates for the Date/Time properties map\r\n FBiasInfo: TJclTZIValueInfo; // Bias information from the registry\r\n function GetActiveBias: Integer;\r\n function GetCurrentDateTime: TDateTime;\r\n function GetDaylightSavingsStartDate: TDateTime;\r\n function GetGMTOffset: string;\r\n function GetStandardStartDate: TDateTime;\r\n function GetSupportsDaylightSavings: Boolean;\r\n function GetTimeZoneType(TZI: TJclTZIValueInfo): Cardinal;\r\n public\r\n procedure Assign(Source: TJclTimeZoneRegInfo);\r\n procedure ApplyTimeZone;\r\n function DayLightSavingsPeriod: string;\r\n function DateTimeIsInDaylightSavings(ADateTime: TDateTime):Boolean;\r\n function StandardStartDateInYear(const AYear: Integer): TDateTime;\r\n function DaylightStartDateInYear(const AYear: Integer): TDateTime;\r\n // These are all the values we want to be able to stream\r\n property ActiveBias: Integer read GetActiveBias;\r\n property CurrentDateTime: TDateTime read GetCurrentDateTime;\r\n property DaylightName: string read FDaylightName;\r\n property DaylightSavingsStartDate: TDateTime read GetDaylightSavingsStartDate;\r\n property DisplayDescription: string read FTZDescription;\r\n property GMTOffset: string read GetGMTOffset;\r\n property MapID: string read FMapID;\r\n property SortIndex: Integer read FSortIndex;\r\n property StandardName: string read FStandardName;\r\n property StandardStartDate: TDateTime read GetStandardStartDate;\r\n property SupportsDaylightSavings: Boolean read GetSupportsDaylightSavings;\r\n end;\r\n\r\n TJclTimeZones = class(TObject)\r\n private\r\n FActiveTimeZoneIndex: Integer;\r\n FTimeZones: TObjectList;\r\n FAutoAdjustEnabled: Boolean;\r\n function GetAutoAdjustEnabled: Boolean;\r\n function GetActiveTimeZoneInfo: TJclTimeZoneInfo;\r\n function GetCount: Integer;\r\n function GetItem(Index: Integer): TJclTimeZoneInfo;\r\n procedure LoadTimeZones;\r\n function TimeZoneCallback(const TimeZoneRec: TJclTimeZoneRegInfo): Boolean;\r\n public\r\n constructor Create;\r\n destructor Destroy; override;\r\n function SetDateTime(DateTime: TDateTime): Boolean;\r\n procedure SetAutoAdjustEnabled(Value: Boolean);\r\n property Count: Integer read GetCount;\r\n property Items[Index: Integer]: TJclTimeZoneInfo read GetItem; default;\r\n property ActiveTimeZone: TJclTimeZoneInfo read GetActiveTimeZoneInfo;\r\n property AutoAdjustEnabled: Boolean read FAutoAdjustEnabled write FAutoAdjustEnabled;\r\n end;\r\n\r\ntype\r\n EDaylightSavingsNotSupported = class(EJclError);\r\n EAutoAdjustNotEnabled = class(EJclError);\r\n\r\n// Enumerate all time zones from the registry\r\nfunction EnumTimeZones(CallBackFunc: TJclTimeZoneCallBackFunc): Boolean;\r\n\r\n// Functions that read from the current time zone\r\nfunction IsAutoAdjustEnabled: Boolean;\r\nfunction CurrentTimeZoneSupportsDaylightSavings: Boolean;\r\nfunction DateCurrentTimeZoneClocksChangeToStandard: TDateTime;\r\nfunction DateCurrentTimeZoneClocksChangeToDaylightSavings: TDateTime;\r\nfunction GetCurrentTimeZoneDescription: string;\r\nfunction GetCurrentTimeZoneDaylightSavingsPeriod: string;\r\nfunction GetCurrentTimeZoneGMTOffset: string;\r\nfunction GetCurrentTimeZoneUTCBias: Integer;\r\n\r\n// Misc UTC related functions\r\nfunction GetWMIScheduledJobUTCTime(Time: TDateTime): string;\r\nfunction UTCNow: TDateTime;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jcl.svn.sourceforge.net/svnroot/jcl/tags/JCL-2.4-Build4571/jcl/source/windows/JclTimeZones.pas $';\r\n Revision: '$Revision: 3599 $';\r\n Date: '$Date: 2011-09-03 00:07:50 +0200 (sam. 03 sept. 2011) $';\r\n LogPath: 'JCL\\source\\windows';\r\n Extra: '';\r\n Data: nil\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n {$IFDEF HAS_UNITSCOPE}\r\n Winapi.Messages,\r\n {$ELSE ~HAS_UNITSCOPE}\r\n Messages,\r\n {$ENDIF ~HAS_UNITSCOPE}\r\n JclResources,\r\n JclDateTime, JclRegistry;\r\n\r\nconst\r\n cAutoAdjustKey = '\\System\\CurrentControlSet\\Control\\TimeZoneInformation';\r\n cAutoAdjustValue = 'DisableAutoDaylightTimeSet';\r\n\r\nconst\r\n UTCDays: array [0..6] of PChar =\r\n ('Sunday', 'Monday', 'Tuesday', 'Wednesday', 'Thursday', 'Friday', 'Saturday');\r\n UTCDaysOffset: array [1..5] of PChar =\r\n ('first', 'second', 'third', 'fourth', 'last');\r\n UTCMonths: array [1..12] of string =\r\n ('January', 'February', 'March', 'April', 'May', 'June',\r\n 'July', 'August', 'September', 'October', 'November', 'December');\r\n\r\n//--------------------------------------------------------------------------------------------------\r\n// Callback enumerator of timezone information. Return false to stop enumeration\r\n\r\nfunction EnumTimeZones(CallBackFunc: TJclTimeZoneCallBackFunc): Boolean;\r\nvar\r\n TimeZoneRootName: string;\r\n TimeZones: TStringList;\r\n I: Integer;\r\n TimeZoneRegInfo: TJclTimeZoneRegInfo;\r\nbegin\r\n Result := True;\r\n\r\n if not Assigned(CallBackFunc) then\r\n raise Exception.Create(RsENoCallbackFunc);\r\n\r\n TimeZones := TStringList.Create;\r\n try\r\n if Win32Platform = VER_PLATFORM_WIN32_WINDOWS then\r\n TimeZoneRootName := '\\Software\\Microsoft\\Windows\\CurrentVersion\\Time Zones\\'\r\n else\r\n TimeZoneRootName := '\\Software\\Microsoft\\Windows NT\\CurrentVersion\\Time Zones\\';\r\n\r\n if not RegGetKeyNames(HKEY_LOCAL_MACHINE, TimeZoneRootName, TimeZones) then\r\n Exit;\r\n\r\n for I := 0 to TimeZones.Count - 1 do\r\n begin\r\n FillChar(TimeZoneRegInfo, SizeOf(TJclTimeZoneRegInfo), #0);\r\n\r\n TimeZoneRegInfo.DisplayDesc := RegReadString(HKEY_LOCAL_MACHINE, TimeZoneRootName + TimeZones[I], 'Display');\r\n TimeZoneRegInfo.StandardName := RegReadString(HKEY_LOCAL_MACHINE, TimeZoneRootName + TimeZones[I], 'Std');\r\n TimeZoneRegInfo.DaylightName := RegReadString(HKEY_LOCAL_MACHINE, TimeZoneRootName + TimeZones[I], 'Dlt');\r\n TimeZoneRegInfo.SortIndex := RegReadIntegerDef(HKEY_LOCAL_MACHINE, TimeZoneRootName + TimeZones[I], 'Index', -1);\r\n TimeZoneRegInfo.MapID := RegReadStringDef(HKEY_LOCAL_MACHINE, TimeZoneRootName + TimeZones[I], 'MapID', '');\r\n RegReadBinary(HKEY_LOCAL_MACHINE, TimeZoneRootName + TimeZones[I], 'TZI', TimeZoneRegInfo.TZI,\r\n SizeOf(TJclTZIValueInfo));\r\n\r\n // Allow the callback function to stop the enumeration\r\n if not CallBackFunc(TimeZoneRegInfo) then\r\n Break;\r\n end;\r\n finally\r\n TimeZones.Free;\r\n end;\r\nend;\r\n\r\n//--------------------------------------------------------------------------------------------------\r\n// Translates dates like \"the third thursday in March\" into the actual date\r\n\r\nfunction CalculateTransitionDate(TransitionInfo: TSystemTime; CalculateForYear: Integer= -1): TDateTime;\r\nvar\r\n CheckDate, FirstOfMonth: TDateTime;\r\n MonthStartDOW: Integer;\r\n TransitionDOW: Word;\r\n TransitionDay: Word;\r\n PartialDays: Integer;\r\n I, MonthDays: Integer;\r\n Year, Month, Day: Word;\r\n ActiveYear: Integer;\r\nbegin\r\n if CalculateForYear= -1 then\r\n ActiveYear:=YearOfDate(Now)\r\n else\r\n ActiveYear:=CalculateForYear;\r\n\r\n // If the date is empty, we've been passed a system date for a timezone that has no daylight support\r\n if (TransitionInfo.wYear = 0) and (TransitionInfo.wMonth = 0) and (TransitionInfo.wDay = 0) then\r\n begin\r\n Result := 0;\r\n Exit;\r\n end;\r\n\r\n // Work out what day the first of the month is\r\n FirstOfMonth := EncodeDate(ActiveYear, TransitionInfo.wMonth, 1);\r\n\r\n // System time is 0 based, Day of Week is 1 based\r\n MonthStartDOW := DayOfWeek(FirstOfMonth);\r\n TransitionDOW := TransitionInfo.wDayOfWeek + 1;\r\n\r\n if MonthStartDOW > TransitionDOW then\r\n PartialDays := 7 - (MonthStartDOW - TransitionDOW) + 1\r\n else\r\n PartialDays := (TransitionDOW - MonthStartDOW) + 1;\r\n\r\n // According to MSDN, wDay member is a value in the range 1 through 5.\r\n // Using this notation, the first Sunday in April can be specified,\r\n // as can the last Thursday in October (5 is equal to \"the last\").\r\n TransitionDay := 1;\r\n case TransitionInfo.wDay of\r\n 1:\r\n TransitionDay := PartialDays;\r\n 2, 3, 4:\r\n TransitionDay := (7 * (TransitionInfo.wDay - 1)) + PartialDays;\r\n 5:\r\n begin\r\n // Work out the date of the last X day in the month\r\n MonthDays := DaysInMonth(FirstOfMonth);\r\n DecodeDate(FirstOfMonth, Year, Month, Day);\r\n\r\n for I := MonthDays downto MonthDays - 7 do\r\n begin\r\n CheckDate := EncodeDate(Year, Month, I);\r\n if DayOfWeek(CheckDate) = TransitionDOW then\r\n begin\r\n TransitionDay := I;\r\n Break;\r\n end;\r\n end;\r\n end;\r\n end;\r\n\r\n Result := EncodeDate(ActiveYear, TransitionInfo.wMonth, TransitionDay);\r\nend;\r\n\r\n//--------------------------------------------------------------------------------------------------\r\n//Returns the date range in friendly format \"From the 1st sunday in March to the last Sunday in October\"\r\n\r\nfunction GetDayLightSavingsPeriod(StandardDate, DayLightDate: TSystemTime): string;\r\nbegin\r\n if (DaylightDate.wMonth = 0) and (StandardDate.wMonth = 0) then\r\n Result := '' // There is no daylight savings period for this timezone\r\n else\r\n begin\r\n if (DaylightDate.wMonth = StandardDate.wMonth) and (DaylightDate.wDay = StandardDate.wDay) then\r\n Result := '' // AutoAdjust for Daylight savings is not enabled, so Windows returns the entire year\r\n else\r\n begin\r\n Result := 'From the ' + UTCDaysOffset[DaylightDate.wDay] + ' ' + UTCDays[DaylightDate.wDayOfWeek] + ' of ' +\r\n UTCMonths[DaylightDate.wMonth] +\r\n ' to the ' + UTCDaysOffset[StandardDate.wDay] + ' ' + UTCDays[StandardDate.wDayOfWeek] + ' of ' +\r\n UTCMonths[StandardDate.wMonth];\r\n end;\r\n end;\r\nend;\r\n\r\n//--------------------------------------------------------------------------------------------------\r\n// Functions relating to the current time zone\r\n//--------------------------------------------------------------------------------------------------\r\n\r\n//--------------------------------------------------------------------------------------------------\r\n// Returns true if the current timezone supports daylight savings - regardless of whether\r\n// AutoAdjust is enabled or not\r\n\r\nfunction CurrentTimeZoneSupportsDaylightSavings: Boolean;\r\nvar\r\n TimeZoneInfo: TTimeZoneInformation;\r\nbegin\r\n Result := False;\r\n\r\n FillChar(TimeZoneInfo, SizeOf(TimeZoneInfo), #0);\r\n case GetTimeZoneInformation(TimeZoneInfo) of\r\n TIME_ZONE_ID_STANDARD:\r\n Result := TimeZoneInfo.StandardDate.wMonth <> 0;\r\n TIME_ZONE_ID_DAYLIGHT:\r\n Result := True;\r\n end;\r\nend;\r\n\r\n//-----------------------------------------------------------------------------\r\n// Returns the exact date that clocks switch to daylight savings in the current\r\n// year for the current time zone\r\n\r\nfunction DateCurrentTimeZoneClocksChangeToDaylightSavings: TDateTime;\r\nvar\r\n TimeZoneInfo: TTimeZoneInformation;\r\nbegin\r\n // The daylight savings time is only returned if AutoAdjust is enabled and the\r\n // timezone supports Daylight savings.\r\n if not CurrentTimeZoneSupportsDaylightSavings then\r\n raise EDaylightSavingsNotSupported.Create(RsEDaylightSavingsNotSupported);\r\n\r\n if not IsAutoAdjustEnabled then\r\n raise EAutoAdjustNotEnabled.Create(RsEAutoAdjustNotEnabled);\r\n\r\n Result := 0;\r\n FillChar(TimeZoneInfo, SizeOf(TimeZoneInfo), #0);\r\n if GetTimeZoneInformation(TimeZoneInfo) in [TIME_ZONE_ID_DAYLIGHT, TIME_ZONE_ID_STANDARD] then\r\n Result := CalculateTransitionDate(TimeZoneInfo.DaylightDate);\r\nend;\r\n\r\n//-----------------------------------------------------------------------------\r\n// Returns the exact date that clocks switch to standard time in the current year\r\n// for the current time zone\r\n\r\nfunction DateCurrentTimeZoneClocksChangeToStandard: TDateTime;\r\nvar\r\n TimeZoneInfo: TTimeZoneInformation;\r\nbegin\r\n if not CurrentTimeZoneSupportsDaylightSavings then\r\n raise EDaylightSavingsNotSupported.Create(RsEDaylightSavingsNotSupported);\r\n\r\n Result := 0;\r\n FillChar(TimeZoneInfo, SizeOf(TimeZoneInfo), #0);\r\n if GetTimeZoneInformation(TimeZoneInfo) in [TIME_ZONE_ID_DAYLIGHT, TIME_ZONE_ID_STANDARD] then\r\n Result := CalculateTransitionDate(TimeZoneInfo.StandardDate);\r\nend;\r\n\r\n//----------------------------------------------------------------------------\r\n// Returns the name of the current time zone\r\n\r\nfunction GetCurrentTimeZoneDescription: string;\r\nvar\r\n TimeZoneInfo: TTimeZoneInformation;\r\nbegin\r\n FillChar(TimeZoneInfo, SizeOf(TimeZoneInfo), #0);\r\n case GetTimeZoneInformation(TimeZoneInfo) of\r\n TIME_ZONE_ID_INVALID:\r\n Result := '';\r\n TIME_ZONE_ID_STANDARD:\r\n Result := TimeZoneInfo.StandardName;\r\n TIME_ZONE_ID_UNKNOWN:\r\n Result := TimeZoneInfo.StandardName;\r\n TIME_ZONE_ID_DAYLIGHT:\r\n Result := TimeZoneInfo.DaylightName;\r\n end;\r\nend;\r\n\r\n//-----------------------------------------------------------------------------\r\n// Returns the date range in friendly format for the current timezone\r\n\r\nfunction GetCurrentTimeZoneDaylightSavingsPeriod: string;\r\nvar\r\n TimeZoneInfo: TTimeZoneInformation;\r\nbegin\r\n Result := '';\r\n if not IsAutoAdjustEnabled then\r\n Exit;\r\n\r\n FillChar(TimeZoneInfo, SizeOf(TimeZoneInfo), #0);\r\n if GetTimeZoneInformation(TimeZoneInfo) = TIME_ZONE_ID_INVALID then\r\n Exit;\r\n\r\n Result := GetDaylightSavingsPeriod(TimeZoneInfo.StandardDate, TimeZoneInfo.DaylightDate);\r\nend;\r\n\r\n//-----------------------------------------------------------------------------\r\n// Returns the current offset from GMT as a string \"GMT+03:00\"\r\n\r\nfunction GetCurrentTimeZoneGMTOffset: string;\r\nvar\r\n Bias: Integer;\r\n Hours, Minutes: Integer;\r\nbegin\r\n Bias := GetCurrentTimeZoneUTCBias;\r\n\r\n Hours := Bias div 60;\r\n Minutes := Abs(Bias) mod 60;\r\n if Bias >= 0 then\r\n Result := Format('GMT+%.2d:%.2d', [Hours, Minutes])\r\n else\r\n // (rom) not GMT- here?\r\n Result := Format('GMT%.2d:%.2d', [Hours, Minutes]);\r\nend;\r\n\r\n//-----------------------------------------------------------------------------\r\n// Returns the Current Time Zone UTC Bias from GMT in minutes\r\n\r\nfunction GetCurrentTimeZoneUTCBias: Integer;\r\nvar\r\n TimeZoneInfo: TTimeZoneInformation;\r\nbegin\r\n Result := 0;\r\n FillChar(TimeZoneInfo, SizeOf(TimeZoneInfo), #0);\r\n case GetTimeZoneInformation(TimeZoneInfo) of\r\n TIME_ZONE_ID_STANDARD:\r\n Result := -(TimeZoneInfo.Bias + TimeZoneInfo.StandardBias);\r\n TIME_ZONE_ID_UNKNOWN:\r\n Result := -(TimeZoneInfo.Bias + TimeZoneInfo.StandardBias);\r\n TIME_ZONE_ID_DAYLIGHT:\r\n Result := -(TimeZoneInfo.Bias + TimeZoneInfo.DaylightBias);\r\n end;\r\nend;\r\n\r\n//-----------------------------------------------------------------------------\r\n// Miscellaneous UTC functions\r\n//-----------------------------------------------------------------------------\r\n\r\n//-----------------------------------------------------------------------------\r\n// Returns the current UTC time\r\n\r\nfunction UTCNow: TDateTime;\r\nvar\r\n SystemTime: TSystemTime;\r\nbegin\r\n GetSystemTime(SystemTime);\r\n Result := EncodeDate(SystemTime.wYear, SystemTime.wMonth, SystemTime.wDay) +\r\n EncodeTime(SystemTime.wHour, SystemTime.wMinute, SystemTime.wSecond, SystemTime.wMilliseconds);\r\nend;\r\n\r\n//-----------------------------------------------------------------------------\r\n// Returns Time in the UTC string format expected by root\\cimv2\\Win32_ScheduledJob\r\n// TODO: This works for scheduling local jobs, but fails on remote jobs - looks\r\n// like Windows does something a bit odd with remote scheduled jobs, it's not\r\n// handling the time correctly at all. So much for UTC.\r\n\r\nfunction GetWMIScheduledJobUTCTime(Time: TDateTime): string;\r\nvar\r\n TimeBias: Integer;\r\n Hour, Min, Sec, MSec: Word;\r\nbegin\r\n Result := '';\r\n\r\n TimeBias := GetCurrentTimeZoneUTCBias;\r\n\r\n DecodeTime(Time, Hour, Min, Sec, MSec);\r\n\r\n Result := '********' + Format('%.2d%.2d%.2d.000000', [Hour, Min, Sec]);\r\n\r\n if TimeBias >= 0 then\r\n Result := Result + Format('+%.3d', [TimeBias])\r\n else\r\n Result := Result + Format('%.3d', [TimeBias]);\r\nend;\r\n\r\n//-----------------------------------------------------------------------------\r\n// Returns true if \"Automatically Adjust clock for daylight saving changes\" is checked\r\n\r\nfunction IsAutoAdjustEnabled: Boolean;\r\nbegin\r\n Result := RegReadIntegerDef(HKEY_LOCAL_MACHINE, cAutoAdjustKey, cAutoAdjustValue, 0) = 0;\r\nend;\r\n\r\n//=== { TJclTimeZoneInfo } ====================================================\r\n\r\nprocedure TJclTimeZoneInfo.ApplyTimeZone;\r\nvar\r\n TimeZoneInfo: TTimeZoneInformation;\r\nbegin\r\n TimeZoneInfo.Bias := FBiasInfo.Bias;\r\n\r\n StringToWideChar(FStandardName, TimeZoneInfo.StandardName, 32);\r\n TimeZoneInfo.StandardDate := FBiasInfo.StandardDate;\r\n TimeZoneInfo.StandardBias := FBiasInfo.StandardBias;\r\n StringToWideChar(FDaylightName, TimeZoneInfo.DaylightName, 32);\r\n TimeZoneInfo.DaylightDate := FBiasInfo.DaylightDate;\r\n TimeZoneInfo.DaylightBias := FBiasInfo.DaylightBias;\r\n\r\n if not SetTimeZoneInformation({$IFDEF FPC}@{$ENDIF FPC}TimeZoneInfo) then\r\n RaiseLastOSError;\r\n\r\n SendMessage(HWND_BROADCAST, WM_SETTINGCHANGE, 0, 0);\r\nend;\r\n\r\nprocedure TJclTimeZoneInfo.Assign(Source: TJclTimeZoneRegInfo);\r\nbegin\r\n FStandardName := Source.StandardName;\r\n FDaylightName := Source.DaylightName;\r\n FTZDescription := Source.DisplayDesc;\r\n FSortIndex := Source.SortIndex;\r\n FMapID := Source.MapID;\r\n FBiasInfo := Source.TZI;\r\nend;\r\n\r\nfunction TJclTimeZoneInfo.GetActiveBias: Integer;\r\nbegin\r\n // Return the active bias (including any skew derived from auto-adjust being enabled)\r\n Result := 0;\r\n\r\n case GetTimeZoneType(FBiasInfo) of\r\n TIME_ZONE_ID_STANDARD:\r\n Result := -(FBiasInfo.Bias + FBiasInfo.StandardBias);\r\n TIME_ZONE_ID_UNKNOWN:\r\n Result := -(FBiasInfo.Bias + FBiasInfo.StandardBias);\r\n TIME_ZONE_ID_DAYLIGHT:\r\n // the bias is different if autoadjust is turned off\r\n if IsAutoAdjustEnabled then\r\n Result := -(FBiasInfo.Bias + FBiasInfo.DaylightBias)\r\n else\r\n Result := -(FBiasInfo.Bias + FBiasInfo.StandardBias);\r\n end;\r\nend;\r\n\r\n//-----------------------------------------------------------------------------\r\n// Returns the exact date that clocks switch to daylight savings in the current\r\n// year for the specified standard date\r\n\r\nfunction TJclTimeZoneInfo.DayLightSavingsPeriod: string;\r\nbegin\r\n Result := GetDayLightSavingsPeriod(FBiasInfo.StandardDate, FBiasInfo.DayLightDate);\r\nend;\r\n\r\nfunction TJclTimeZoneInfo.GetDaylightSavingsStartDate: TDateTime;\r\nbegin\r\n Result := CalculateTransitionDate(FBiasInfo.DaylightDate);\r\nend;\r\n\r\n//-----------------------------------------------------------------------------\r\n// Returns the offset from GMT as a string \"GMT+03:00\"\r\n\r\nfunction TJclTimeZoneInfo.GetGMTOffset: string;\r\nvar\r\n Hours, Minutes: Integer;\r\nbegin\r\n Hours := -FBiasInfo.Bias div 60;\r\n Minutes := Abs(FBiasInfo.Bias) mod 60;\r\n if Hours >= 0 then\r\n Result := Format('GMT+%.2d:%.2d', [Hours, Minutes])\r\n else\r\n // (rom) No GMT- here?\r\n Result := Format('GMT%.2d:%.2d', [Hours, Minutes]);\r\nend;\r\n\r\nfunction TJclTimeZoneInfo.GetStandardStartDate: TDateTime;\r\nbegin\r\n Result := CalculateTransitionDate(FBiasInfo.StandardDate);\r\nend;\r\n\r\nfunction TJclTimeZoneInfo.GetSupportsDaylightSavings: Boolean;\r\nbegin\r\n Result := False;\r\n\r\n // TODO: Check this is correct on 9x\r\n case GetTimeZoneType(FBiasInfo) of\r\n TIME_ZONE_ID_STANDARD:\r\n Result := FBiasInfo.StandardDate.wMonth <> 0;\r\n TIME_ZONE_ID_DAYLIGHT:\r\n Result := True;\r\n end;\r\nend;\r\n\r\nfunction TJclTimeZoneInfo.GetCurrentDateTime: TDateTime;\r\nbegin\r\n // Return the current date time in this time zone\r\n Result := UTCNow + (GetActiveBias / 1440);\r\nend;\r\n\r\n// Returns the TimeZone type based on StandardDate and DaylightDate\r\n\r\nfunction TJclTimeZoneInfo.GetTimeZoneType(TZI: TJclTZIValueInfo): Cardinal;\r\nvar\r\n StandardDate: TDateTime;\r\n DaylightSavingsDate: TDateTime;\r\nbegin\r\n StandardDate := CalculateTransitionDate(TZI.StandardDate);\r\n DaylightSavingsDate := CalculateTransitionDate(TZI.DaylightDate);\r\n\r\n if (StandardDate = 0) and (DayLightSavingsDate = 0) then\r\n Result := TIME_ZONE_ID_UNKNOWN\r\n else\r\n begin\r\n // In places like Australia, Daylight savings is after Standard, in the UK it's the other way round\r\n if DayLightSavingsDate > StandardDate then\r\n begin\r\n if (Now >= StandardDate) and (Now < DaylightSavingsDate) then\r\n Result := TIME_ZONE_ID_STANDARD\r\n else\r\n Result := TIME_ZONE_ID_DAYLIGHT;\r\n end\r\n else\r\n begin\r\n if (Now >= DaylightSavingsDate) and (Now < StandardDate) then\r\n Result := TIME_ZONE_ID_DAYLIGHT\r\n else\r\n Result := TIME_ZONE_ID_STANDARD;\r\n end;\r\n end;\r\nend;\r\n\r\n//=== { TJclTimeZones } =======================================================\r\n\r\nfunction TimeZoneSort(Item1, Item2: Pointer): Integer;\r\nbegin\r\n Result := TJclTimeZoneInfo(Item1).SortIndex - TJclTimeZoneInfo(Item2).SortIndex;\r\n if (Result = 0) or (TJclTimeZoneInfo(Item1).SortIndex = -1) or (TJclTimeZoneInfo(Item2).SortIndex = -1) then\r\n Result := CompareText(TJclTimeZoneInfo(Item1).DisplayDescription, TJclTimeZoneInfo(Item2).DisplayDescription);\r\nend;\r\n\r\nconstructor TJclTimeZones.Create;\r\nbegin\r\n inherited Create;\r\n FAutoAdjustEnabled := GetAutoAdjustEnabled;\r\n FTimeZones := TObjectList.Create(True);\r\n LoadTimeZones;\r\nend;\r\n\r\ndestructor TJclTimeZones.Destroy;\r\nbegin\r\n FreeAndNil(FTimeZones);\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJclTimeZones.GetAutoAdjustEnabled: Boolean;\r\nbegin\r\n Result := IsAutoAdjustEnabled;\r\nend;\r\n\r\nfunction TJclTimeZones.GetActiveTimeZoneInfo: TJclTimeZoneInfo;\r\nbegin\r\n Result := GetItem(FActiveTimeZoneIndex);\r\nend;\r\n\r\nfunction TJclTimeZones.GetCount: Integer;\r\nbegin\r\n Result := FTimeZones.Count;\r\nend;\r\n\r\nfunction TJclTimeZones.GetItem(Index: Integer): TJclTimeZoneInfo;\r\nbegin\r\n if (Index >= 0) or (Index < FTimeZones.Count) then\r\n Result := TJclTimeZoneInfo(FTimeZones[Index])\r\n else\r\n Result := nil;\r\nend;\r\n\r\nprocedure TJclTimeZones.LoadTimeZones;\r\nvar\r\n CurrentTimeZoneDesc: string;\r\n I: Integer;\r\nbegin\r\n EnumTimeZones(TimeZoneCallback);\r\n FTimeZones.Sort(@TimeZoneSort);\r\n\r\n CurrentTimeZoneDesc := GetCurrentTimeZoneDescription;\r\n\r\n FActiveTimeZoneIndex := -1;\r\n for I := 0 to FTimeZones.Count - 1 do\r\n if (TJclTimeZoneInfo(FTimeZones[I]).StandardName = CurrentTimeZoneDesc) or\r\n (TJclTimeZoneInfo(FTimeZones[I]).DayLightName = CurrentTimeZoneDesc) then\r\n begin\r\n FActiveTimeZoneIndex := I;\r\n Break;\r\n end;\r\nend;\r\n\r\nprocedure TJclTimeZones.SetAutoAdjustEnabled(Value: Boolean);\r\nbegin\r\n // TODO: PC isn't being notified correctly of the change\r\n if FAutoAdjustEnabled <> Value then\r\n begin\r\n if not Value then\r\n RegWriteInteger(HKEY_LOCAL_MACHINE, cAutoAdjustKey, cAutoAdjustValue, 1)\r\n else\r\n RegDeleteEntry(HKEY_LOCAL_MACHINE, cAutoAdjustKey, cAutoAdjustValue);\r\n\r\n FAutoAdjustEnabled := Value;\r\n SendMessage(HWND_BROADCAST, WM_SETTINGCHANGE, 0, LPARAM(PChar('intl')));\r\n SendMessage(HWND_TOPMOST, WM_TIMECHANGE, 0, 0);\r\n end;\r\nend;\r\n\r\nfunction TJclTimeZones.TimeZoneCallback(const TimeZoneRec: TJclTimeZoneRegInfo): Boolean;\r\nvar\r\n TimeZone: TJclTimeZoneInfo;\r\nbegin\r\n Result := True;\r\n TimeZone := TJclTimeZoneInfo.Create;\r\n TimeZone.Assign(TimeZoneRec);\r\n FTimeZones.Add(TimeZone)\r\nend;\r\n\r\nfunction TJclTimeZones.SetDateTime(DateTime: TDateTime): Boolean;\r\nvar\r\n SystemTime: TSystemTime;\r\nbegin\r\n // The date time we have is local. Convert it to UTC\r\n DateTime := LocalDateTimeToDateTime(DateTime);\r\n\r\n DecodeDate(DateTime, SystemTime.wYear, SystemTime.wMonth, SystemTime.wDay);\r\n DecodeTime(DateTime, SystemTime.wHour, SystemTime.wMinute, SystemTime.wSecond, SystemTime.wMilliSeconds);\r\n\r\n Result := SetSystemTime(SystemTime);\r\n\r\n if not Result then\r\n RaiseLastOSError;\r\n\r\n SendMessage(HWND_TOPMOST, WM_TIMECHANGE, 0, 0);\r\nend;\r\n\r\nfunction TJclTimeZoneInfo.DateTimeIsInDaylightSavings(ADateTime: TDateTime): Boolean;\r\nvar\r\n dsStartDate: TDateTime;\r\n stdStartDate: TDateTime;\r\n Year: Integer;\r\nbegin\r\n //Return whether the specified date time is DaylightSavings or not\r\n Result:=False;\r\n\r\n if not SupportsDaylightSavings then\r\n Exit;\r\n\r\n Year:=YearOfDate(ADateTime);\r\n dsStartDate := CalculateTransitionDate(FBiasInfo.DaylightDate, Year);\r\n stdStartDate:= CalculateTransitionDate(FBiasInfo.StandardDate, Year);\r\n\r\n // In places like Australia, Daylight savings is after Standard, in the UK it's the other way round\r\n if dsStartDate > stdStartDate then\r\n begin\r\n if (ADateTime >= stdStartDate) and (ADateTime < dsStartDate) then\r\n Result := False\r\n else\r\n Result := True;\r\n end\r\n else\r\n begin\r\n if (ADateTime >= dsStartDate) and (ADateTime < stdStartDate) then\r\n Result := True\r\n else\r\n Result := False;\r\n end;\r\nend;\r\n\r\nfunction TJclTimeZoneInfo.DaylightStartDateInYear(\r\n const AYear: Integer): TDateTime;\r\nbegin\r\n Result:= CalculateTransitionDate(FBiasInfo.DaylightDate, AYear);\r\nend;\r\n\r\nfunction TJclTimeZoneInfo.StandardStartDateInYear(\r\n const AYear: Integer): TDateTime;\r\nbegin\r\n Result:= CalculateTransitionDate(FBiasInfo.StandardDate, AYear);\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n\r\n" }, { "path": "External/Jedi/Jcl/source/windows/JclWin32.pas", "content": "{**************************************************************************************************}\r\n{ WARNING: JEDI preprocessor generated unit. Do not edit. }\r\n{**************************************************************************************************}\r\n\r\n{**************************************************************************************************}\r\n{ }\r\n{ Project JEDI Code Library (JCL) }\r\n{ }\r\n{ The contents of this file are subject to the Mozilla Public License Version 1.1 (the \"License\"); }\r\n{ you may not use this file except in compliance with the License. You may obtain a copy of the }\r\n{ License at http://www.mozilla.org/MPL/ }\r\n{ }\r\n{ Software distributed under the License is distributed on an \"AS IS\" basis, WITHOUT WARRANTY OF }\r\n{ ANY KIND, either express or implied. See the License for the specific language governing rights }\r\n{ and limitations under the License. }\r\n{ }\r\n{ Portions of this code are translated from DelayImp.h. }\r\n{ The Initial Developer of DelayImp.h is Inprise Corporation. Portions created by Inprise }\r\n{ Corporation are Copyright (C) 1999, 2000 by Inprise Corporation. All Rights Reserved. }\r\n{ }\r\n{ The Original Code is JclWin32.pas. }\r\n{ }\r\n{ The Initial Developer of the Original Code is Marcel van Brakel. Portions created by Marcel van }\r\n{ Brakel are Copyright (C) Marcel van Brakel. All Rights Reserved. }\r\n{ }\r\n{ Contributors: }\r\n{ Marcel van Brakel }\r\n{ Peter Friese }\r\n{ Andreas Hausladen (ahuser) }\r\n{ Flier Lu (flier) }\r\n{ Robert Marquardt (marquardt) }\r\n{ Robert Rossmair (rrossmair) }\r\n{ Olivier Sannier (obones) }\r\n{ Matthias Thoma (mthoma) }\r\n{ Petr Vones (pvones) }\r\n{ Florent Ouchet (outchy) }\r\n{ }\r\n{**************************************************************************************************}\r\n{ }\r\n{ This unit defines various Win32 API declarations which are either missing or incorrect in one or }\r\n{ more of the supported Delphi versions. This unit is not intended for regular code, only API }\r\n{ declarations. }\r\n{ }\r\n{**************************************************************************************************}\r\n{ }\r\n{ Last modified: $Date:: 2012-05-23 15:57:30 +0200 (mer. 23 mai 2012) $ }\r\n{ Revision: $Rev:: 3796 $ }\r\n{ Author: $Author:: obones $ }\r\n{ }\r\n{**************************************************************************************************}\r\n\r\nunit JclWin32;\r\n\r\n{$I jcl.inc}\r\n{$I windowsonly.inc}\r\n\r\n{$MINENUMSIZE 4}\r\n{$ALIGN ON}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n {$IFDEF HAS_UNITSCOPE}\r\n Winapi.Windows, System.SysUtils,\r\n {$IFNDEF FPC}\r\n Winapi.AccCtrl, Winapi.ActiveX,\r\n {$ENDIF ~FPC}\r\n {$ELSE ~HAS_UNITSCOPE}\r\n Windows, SysUtils,\r\n {$IFNDEF FPC}\r\n AccCtrl,\r\n {$ENDIF ~FPC}\r\n ActiveX,\r\n {$ENDIF ~HAS_UNITSCOPE}\r\n JclBase;\r\n\r\n{$HPPEMIT '#include '}\r\n{$HPPEMIT '#include '}\r\n{$HPPEMIT '#include '}\r\n{$HPPEMIT '#include '}\r\n{$HPPEMIT '#include '}\r\n{$HPPEMIT '#include '}\r\n{$HPPEMIT '#include '}\r\n{$HPPEMIT '#include '}\r\n{$HPPEMIT '#include '}\r\n{$HPPEMIT '#include '}\r\n{$HPPEMIT '#include '}\r\n{$HPPEMIT '#include '}\r\n{$HPPEMIT '#include '}\r\n//{$HPPEMIT '#include '}\r\n{$HPPEMIT '#include '}\r\n{$HPPEMIT '#include '}\r\n{$HPPEMIT '#include '}\r\n{$HPPEMIT '#include '}\r\n{$IFNDEF COMPILER14_UP}\r\n{$HPPEMIT '#include '}\r\n{$ENDIF ~COMPILER14_UP}\r\n{$HPPEMIT '#include '}\r\n{$HPPEMIT '#include '}\r\n{$HPPEMIT ''}\r\n{$IFDEF RTL230_UP}\r\n{$HPPEMIT '// To avoid ambiguity between IMAGE_LOAD_CONFIG_DIRECTORY32 and Winapi::Windows::IMAGE_LOAD_CONFIG_DIRECTORY32'}\r\n{$HPPEMIT '#define IMAGE_LOAD_CONFIG_DIRECTORY32 ::IMAGE_LOAD_CONFIG_DIRECTORY32'}\r\n{$HPPEMIT ''}\r\n{$HPPEMIT '// To avoid ambiguity between IMAGE_LOAD_CONFIG_DIRECTORY64 and Winapi::Windows::IMAGE_LOAD_CONFIG_DIRECTORY64'}\r\n{$HPPEMIT '#define IMAGE_LOAD_CONFIG_DIRECTORY64 ::IMAGE_LOAD_CONFIG_DIRECTORY64'}\r\n{$HPPEMIT ''}\r\n{$ENDIF RTL230_UP}\r\n\r\n// EJclWin32Error\r\ntype\r\n EJclWin32Error = class(EJclError)\r\n private\r\n FLastError: DWORD;\r\n FLastErrorMsg: string;\r\n public\r\n constructor Create(const Msg: string);\r\n constructor CreateFmt(const Msg: string; const Args: array of const);\r\n constructor CreateRes(Ident: Integer); overload;\r\n constructor CreateRes(ResStringRec: PResStringRec); overload;\r\n property LastError: DWORD read FLastError;\r\n property LastErrorMsg: string read FLastErrorMsg;\r\n end;\r\n\r\n//DOM-IGNORE-BEGIN\r\n\r\n{$IFNDEF FPC}\r\n\r\n//\r\n// Unsigned Basics\r\n//\r\n\r\ntype\r\n USHORT = Word;\r\n {$EXTERNALSYM USHORT}\r\n\r\n{$ENDIF ~FPC}\r\n//==================================================================================================\r\n// presumable from any older WinNT.h or from WinIfs.h\r\n//==================================================================================================\r\n\r\n//--------------------------------------------------------------------------------------------------\r\n// NTFS Reparse Points\r\n//--------------------------------------------------------------------------------------------------\r\n\r\n// The reparse structure is used by layered drivers to store data in a\r\n// reparse point. The constraints on reparse tags are defined below.\r\n// This version of the reparse data buffer is only for Microsoft tags.\r\n\r\n(*$HPPEMIT 'typedef struct _REPARSE_DATA_BUFFER {'*)\r\n(*$HPPEMIT ''*)\r\n(*$HPPEMIT ' DWORD ReparseTag;'*)\r\n(*$HPPEMIT ' WORD ReparseDataLength;'*)\r\n(*$HPPEMIT ' WORD Reserved;'*)\r\n(*$HPPEMIT ''*)\r\n(*$HPPEMIT ' union {'*)\r\n(*$HPPEMIT ''*)\r\n(*$HPPEMIT ' struct {'*)\r\n(*$HPPEMIT ' WORD SubstituteNameOffset;'*)\r\n(*$HPPEMIT ' WORD SubstituteNameLength;'*)\r\n(*$HPPEMIT ' WORD PrintNameOffset;'*)\r\n(*$HPPEMIT ' WORD PrintNameLength;'*)\r\n(*$HPPEMIT ' WCHAR PathBuffer[1];'*)\r\n(*$HPPEMIT ' } SymbolicLinkReparseBuffer;'*)\r\n(*$HPPEMIT ''*)\r\n(*$HPPEMIT ' struct {'*)\r\n(*$HPPEMIT ' WORD SubstituteNameOffset;'*)\r\n(*$HPPEMIT ' WORD SubstituteNameLength;'*)\r\n(*$HPPEMIT ' WORD PrintNameOffset;'*)\r\n(*$HPPEMIT ' WORD PrintNameLength;'*)\r\n(*$HPPEMIT ' WCHAR PathBuffer[1];'*)\r\n(*$HPPEMIT ' } MountPointReparseBuffer;'*)\r\n(*$HPPEMIT ''*)\r\n(*$HPPEMIT ' struct {'*)\r\n(*$HPPEMIT ' UCHAR DataBuffer[1];'*)\r\n(*$HPPEMIT ' } GenericReparseBuffer;'*)\r\n(*$HPPEMIT ' };'*)\r\n(*$HPPEMIT ''*)\r\n(*$HPPEMIT '} REPARSE_DATA_BUFFER, *PREPARSE_DATA_BUFFER;'*)\r\n(*$HPPEMIT ''*)\r\n(*$HPPEMIT '#ifndef REPARSE_DATA_BUFFER_HEADER_SIZE'*)\r\n(*$HPPEMIT '#define REPARSE_DATA_BUFFER_HEADER_SIZE 8'*)\r\n(*$HPPEMIT '#endif'*)\r\n(*$HPPEMIT ''*)\r\n(*$HPPEMIT 'typedef struct _REPARSE_POINT_INFORMATION {'*)\r\n(*$HPPEMIT ' WORD ReparseDataLength;'*)\r\n(*$HPPEMIT ' WORD UnparsedNameLength;'*)\r\n(*$HPPEMIT '} REPARSE_POINT_INFORMATION, *PREPARSE_POINT_INFORMATION;'*)\r\n(*$HPPEMIT ''*)\r\n(*$HPPEMIT '#ifndef IO_REPARSE_TAG_VALID_VALUES'*)\r\n(*$HPPEMIT '#define IO_REPARSE_TAG_VALID_VALUES 0x0E000FFFF'*)\r\n(*$HPPEMIT '#endif'*)\r\n(*$HPPEMIT ''*)\r\n\r\ntype\r\n {$EXTERNALSYM _REPARSE_DATA_BUFFER}\r\n _REPARSE_DATA_BUFFER = record\r\n ReparseTag: DWORD;\r\n ReparseDataLength: Word;\r\n Reserved: Word;\r\n case Integer of\r\n 0: ( // SymbolicLinkReparseBuffer and MountPointReparseBuffer\r\n SubstituteNameOffset: Word;\r\n SubstituteNameLength: Word;\r\n PrintNameOffset: Word;\r\n PrintNameLength: Word;\r\n PathBuffer: array [0..0] of WCHAR);\r\n 1: ( // GenericReparseBuffer\r\n DataBuffer: array [0..0] of Byte);\r\n end;\r\n {$EXTERNALSYM REPARSE_DATA_BUFFER}\r\n REPARSE_DATA_BUFFER = _REPARSE_DATA_BUFFER;\r\n {$EXTERNALSYM PREPARSE_DATA_BUFFER}\r\n PREPARSE_DATA_BUFFER = ^_REPARSE_DATA_BUFFER;\r\n TReparseDataBuffer = _REPARSE_DATA_BUFFER;\r\n PReparseDataBuffer = PREPARSE_DATA_BUFFER;\r\n\r\nconst\r\n {$EXTERNALSYM REPARSE_DATA_BUFFER_HEADER_SIZE}\r\n REPARSE_DATA_BUFFER_HEADER_SIZE = 8;\r\n\r\ntype\r\n {$EXTERNALSYM _REPARSE_POINT_INFORMATION}\r\n _REPARSE_POINT_INFORMATION = record\r\n ReparseDataLength: Word;\r\n UnparsedNameLength: Word;\r\n end;\r\n {$EXTERNALSYM REPARSE_POINT_INFORMATION}\r\n REPARSE_POINT_INFORMATION = _REPARSE_POINT_INFORMATION;\r\n {$EXTERNALSYM PREPARSE_POINT_INFORMATION}\r\n PREPARSE_POINT_INFORMATION = ^_REPARSE_POINT_INFORMATION;\r\n TReparsePointInformation = _REPARSE_POINT_INFORMATION;\r\n PReparsePointInformation = PREPARSE_POINT_INFORMATION;\r\n\r\nconst\r\n {$EXTERNALSYM IO_REPARSE_TAG_VALID_VALUES}\r\n IO_REPARSE_TAG_VALID_VALUES = DWORD($E000FFFF);\r\n\r\n//==================================================================================================\r\n\r\n// from JwaWinNT.pas (few declarations from JwaWinType)\r\n\r\nconst\r\n MAXLONGLONG = $7fffffffffffffff;\r\n {$EXTERNALSYM MAXLONGLONG}\r\n\r\n{$IFNDEF FPC}\r\ntype\r\n ULONGLONG = Int64;\r\n {$EXTERNALSYM ULONGLONG}\r\n PLONGLONG = ^LONGLONG;\r\n {$EXTERNALSYM PLONGLONG}\r\n PULONGLONG = ^ULONGLONG;\r\n {$EXTERNALSYM PULONGLONG}\r\n{$ENDIF ~FPC}\r\n\r\nconst\r\n ANYSIZE_ARRAY = 1;\r\n {$EXTERNALSYM ANYSIZE_ARRAY}\r\n\r\n MAX_NATURAL_ALIGNMENT = SizeOf(ULONG);\r\n {$EXTERNALSYM MAX_NATURAL_ALIGNMENT}\r\n\r\n// line 72\r\n\r\nconst\r\n VER_SERVER_NT = DWORD($80000000);\r\n {$EXTERNALSYM VER_SERVER_NT}\r\n VER_WORKSTATION_NT = $40000000;\r\n {$EXTERNALSYM VER_WORKSTATION_NT}\r\n VER_SUITE_SMALLBUSINESS = $00000001;\r\n {$EXTERNALSYM VER_SUITE_SMALLBUSINESS}\r\n VER_SUITE_ENTERPRISE = $00000002;\r\n {$EXTERNALSYM VER_SUITE_ENTERPRISE}\r\n VER_SUITE_BACKOFFICE = $00000004;\r\n {$EXTERNALSYM VER_SUITE_BACKOFFICE}\r\n VER_SUITE_COMMUNICATIONS = $00000008;\r\n {$EXTERNALSYM VER_SUITE_COMMUNICATIONS}\r\n VER_SUITE_TERMINAL = $00000010;\r\n {$EXTERNALSYM VER_SUITE_TERMINAL}\r\n VER_SUITE_SMALLBUSINESS_RESTRICTED = $00000020;\r\n {$EXTERNALSYM VER_SUITE_SMALLBUSINESS_RESTRICTED}\r\n VER_SUITE_EMBEDDEDNT = $00000040;\r\n {$EXTERNALSYM VER_SUITE_EMBEDDEDNT}\r\n VER_SUITE_DATACENTER = $00000080;\r\n {$EXTERNALSYM VER_SUITE_DATACENTER}\r\n VER_SUITE_SINGLEUSERTS = $00000100;\r\n {$EXTERNALSYM VER_SUITE_SINGLEUSERTS}\r\n VER_SUITE_PERSONAL = $00000200;\r\n {$EXTERNALSYM VER_SUITE_PERSONAL}\r\n VER_SUITE_BLADE = $00000400;\r\n {$EXTERNALSYM VER_SUITE_BLADE}\r\n VER_SUITE_EMBEDDED_RESTRICTED = $00000800;\r\n {$EXTERNALSYM VER_SUITE_EMBEDDED_RESTRICTED}\r\n VER_SUITE_SECURITY_APPLIANCE = $00001000;\r\n {$EXTERNALSYM VER_SUITE_SECURITY_APPLIANCE}\r\n VER_SUITE_STORAGE_SERVER = $00002000;\r\n {$EXTERNALSYM VER_SUITE_STORAGE_SERVER}\r\n VER_SUITE_COMPUTE_SERVER = $00004000;\r\n {$EXTERNALSYM VER_SUITE_COMPUTE_SERVER}\r\n\r\n// line 515\r\n\r\n//\r\n// A language ID is a 16 bit value which is the combination of a\r\n// primary language ID and a secondary language ID. The bits are\r\n// allocated as follows:\r\n//\r\n// +-----------------------+-------------------------+\r\n// | Sublanguage ID | Primary Language ID |\r\n// +-----------------------+-------------------------+\r\n// 15 10 9 0 bit\r\n//\r\n//\r\n// Language ID creation/extraction macros:\r\n//\r\n// MAKELANGID - construct language id from a primary language id and\r\n// a sublanguage id.\r\n// PRIMARYLANGID - extract primary language id from a language id.\r\n// SUBLANGID - extract sublanguage id from a language id.\r\n//\r\n\r\nfunction MAKELANGID(PrimaryLang, SubLang: USHORT): WORD;\r\n{$EXTERNALSYM MAKELANGID}\r\nfunction PRIMARYLANGID(LangId: WORD): WORD;\r\n{$EXTERNALSYM PRIMARYLANGID}\r\nfunction SUBLANGID(LangId: WORD): WORD;\r\n{$EXTERNALSYM SUBLANGID}\r\n\r\n//\r\n// A locale ID is a 32 bit value which is the combination of a\r\n// language ID, a sort ID, and a reserved area. The bits are\r\n// allocated as follows:\r\n//\r\n// +-------------+---------+-------------------------+\r\n// | Reserved | Sort ID | Language ID |\r\n// +-------------+---------+-------------------------+\r\n// 31 20 19 16 15 0 bit\r\n//\r\n//\r\n// Locale ID creation/extraction macros:\r\n//\r\n// MAKELCID - construct the locale id from a language id and a sort id.\r\n// MAKESORTLCID - construct the locale id from a language id, sort id, and sort version.\r\n// LANGIDFROMLCID - extract the language id from a locale id.\r\n// SORTIDFROMLCID - extract the sort id from a locale id.\r\n// SORTVERSIONFROMLCID - extract the sort version from a locale id.\r\n//\r\n\r\nconst\r\n NLS_VALID_LOCALE_MASK = $000fffff;\r\n {$EXTERNALSYM NLS_VALID_LOCALE_MASK}\r\n\r\nfunction MAKELCID(LangId, SortId: WORD): DWORD;\r\n{$EXTERNALSYM MAKELCID}\r\nfunction MAKESORTLCID(LangId, SortId, SortVersion: WORD): DWORD;\r\n{$EXTERNALSYM MAKESORTLCID}\r\nfunction LANGIDFROMLCID(LocaleId: LCID): WORD;\r\n{$EXTERNALSYM LANGIDFROMLCID}\r\nfunction SORTIDFROMLCID(LocaleId: LCID): WORD;\r\n{$EXTERNALSYM SORTIDFROMLCID}\r\nfunction SORTVERSIONFROMLCID(LocaleId: LCID): WORD;\r\n{$EXTERNALSYM SORTVERSIONFROMLCID}\r\n\r\n// line 1154\r\n\r\n////////////////////////////////////////////////////////////////////////\r\n// //\r\n// Security Id (SID) //\r\n// //\r\n////////////////////////////////////////////////////////////////////////\r\n//\r\n//\r\n// Pictorially the structure of an SID is as follows:\r\n//\r\n// 1 1 1 1 1 1\r\n// 5 4 3 2 1 0 9 8 7 6 5 4 3 2 1 0\r\n// +---------------------------------------------------------------+\r\n// | SubAuthorityCount |Reserved1 (SBZ)| Revision |\r\n// +---------------------------------------------------------------+\r\n// | IdentifierAuthority[0] |\r\n// +---------------------------------------------------------------+\r\n// | IdentifierAuthority[1] |\r\n// +---------------------------------------------------------------+\r\n// | IdentifierAuthority[2] |\r\n// +---------------------------------------------------------------+\r\n// | |\r\n// +- - - - - - - - SubAuthority[] - - - - - - - - -+\r\n// | |\r\n// +---------------------------------------------------------------+\r\n//\r\n//\r\n\r\n{$IFNDEF FPC}\r\ntype\r\n _SID_IDENTIFIER_AUTHORITY = record\r\n Value: array [0..5] of Byte;\r\n end;\r\n {$EXTERNALSYM _SID_IDENTIFIER_AUTHORITY}\r\n SID_IDENTIFIER_AUTHORITY = _SID_IDENTIFIER_AUTHORITY;\r\n {$EXTERNALSYM SID_IDENTIFIER_AUTHORITY}\r\n PSID_IDENTIFIER_AUTHORITY = ^_SID_IDENTIFIER_AUTHORITY;\r\n {$EXTERNALSYM PSID_IDENTIFIER_AUTHORITY}\r\n\r\n // PSid = ^SID;\r\n _SID = record\r\n Revision: Byte;\r\n SubAuthorityCount: Byte;\r\n IdentifierAuthority: SID_IDENTIFIER_AUTHORITY;\r\n SubAuthority: array [0..ANYSIZE_ARRAY - 1] of DWORD;\r\n end;\r\n {$EXTERNALSYM _SID}\r\n SID = _SID;\r\n {$EXTERNALSYM SID}\r\n PPSID = ^PSID;\r\n {$NODEFINE PPSID}\r\n TSid = SID;\r\n{$ENDIF ~FPC}\r\n\r\nconst\r\n SID_REVISION = (1); // Current revision level\r\n {$EXTERNALSYM SID_REVISION}\r\n SID_MAX_SUB_AUTHORITIES = (15);\r\n {$EXTERNALSYM SID_MAX_SUB_AUTHORITIES}\r\n SID_RECOMMENDED_SUB_AUTHORITIES = (1); // Will change to around 6 in a future release.\r\n {$EXTERNALSYM SID_RECOMMENDED_SUB_AUTHORITIES}\r\n\r\n SECURITY_MAX_SID_SIZE = SizeOf(SID) - SizeOf(DWORD) + (SID_MAX_SUB_AUTHORITIES * SizeOf(DWORD));\r\n {$EXTERNALSYM SECURITY_MAX_SID_SIZE}\r\n\r\n{$IFNDEF FPC}\r\n SidTypeUser = 1;\r\n {$EXTERNALSYM SidTypeUser}\r\n SidTypeGroup = 2;\r\n {$EXTERNALSYM SidTypeGroup}\r\n SidTypeDomain = 3;\r\n {$EXTERNALSYM SidTypeDomain}\r\n SidTypeAlias = 4;\r\n {$EXTERNALSYM SidTypeAlias}\r\n SidTypeWellKnownGroup = 5;\r\n {$EXTERNALSYM SidTypeWellKnownGroup}\r\n SidTypeDeletedAccount = 6;\r\n {$EXTERNALSYM SidTypeDeletedAccount}\r\n SidTypeInvalid = 7;\r\n {$EXTERNALSYM SidTypeInvalid}\r\n SidTypeUnknown = 8;\r\n {$EXTERNALSYM SidTypeUnknown}\r\n SidTypeComputer = 9;\r\n {$EXTERNALSYM SidTypeComputer}\r\n\r\ntype\r\n _SID_NAME_USE = DWORD;\r\n {$EXTERNALSYM _SID_NAME_USE}\r\n// SID_NAME_USE = _SID_NAME_USE;\r\n// {$EXTERNALSYM SID_NAME_USE}\r\n PSID_NAME_USE = ^SID_NAME_USE;\r\n {$EXTERNALSYM PSID_NAME_USE}\r\n TSidNameUse = SID_NAME_USE;\r\n PSidNameUSe = PSID_NAME_USE;\r\n\r\n PSID_AND_ATTRIBUTES = ^SID_AND_ATTRIBUTES;\r\n {$EXTERNALSYM PSID_AND_ATTRIBUTES}\r\n _SID_AND_ATTRIBUTES = record\r\n Sid: PSID;\r\n Attributes: DWORD;\r\n end;\r\n {$EXTERNALSYM _SID_AND_ATTRIBUTES}\r\n SID_AND_ATTRIBUTES = _SID_AND_ATTRIBUTES;\r\n {$EXTERNALSYM SID_AND_ATTRIBUTES}\r\n TSidAndAttributes = SID_AND_ATTRIBUTES;\r\n PSidAndAttributes = PSID_AND_ATTRIBUTES;\r\n\r\n SID_AND_ATTRIBUTES_ARRAY = array [0..ANYSIZE_ARRAY - 1] of SID_AND_ATTRIBUTES;\r\n {$EXTERNALSYM SID_AND_ATTRIBUTES_ARRAY}\r\n PSID_AND_ATTRIBUTES_ARRAY = ^SID_AND_ATTRIBUTES_ARRAY;\r\n {$EXTERNALSYM PSID_AND_ATTRIBUTES_ARRAY}\r\n PSidAndAttributesArray = ^TSidAndAttributesArray;\r\n TSidAndAttributesArray = SID_AND_ATTRIBUTES_ARRAY;\r\n{$ENDIF ~FPC}\r\n\r\n/////////////////////////////////////////////////////////////////////////////\r\n// //\r\n// Universal well-known SIDs //\r\n// //\r\n// Null SID S-1-0-0 //\r\n// World S-1-1-0 //\r\n// Local S-1-2-0 //\r\n// Creator Owner ID S-1-3-0 //\r\n// Creator Group ID S-1-3-1 //\r\n// Creator Owner Server ID S-1-3-2 //\r\n// Creator Group Server ID S-1-3-3 //\r\n// //\r\n// (Non-unique IDs) S-1-4 //\r\n// //\r\n/////////////////////////////////////////////////////////////////////////////\r\n\r\nconst\r\n SECURITY_NULL_SID_AUTHORITY: TSidIdentifierAuthority = (Value: (0, 0, 0, 0, 0, 0));\r\n {$EXTERNALSYM SECURITY_NULL_SID_AUTHORITY}\r\n SECURITY_WORLD_SID_AUTHORITY: TSidIdentifierAuthority = (Value: (0, 0, 0, 0, 0, 1));\r\n {$EXTERNALSYM SECURITY_WORLD_SID_AUTHORITY}\r\n SECURITY_LOCAL_SID_AUTHORITY: TSidIdentifierAuthority = (Value: (0, 0, 0, 0, 0, 2));\r\n {$EXTERNALSYM SECURITY_LOCAL_SID_AUTHORITY}\r\n SECURITY_CREATOR_SID_AUTHORITY: TSidIdentifierAuthority = (Value: (0, 0, 0, 0, 0, 3));\r\n {$EXTERNALSYM SECURITY_CREATOR_SID_AUTHORITY}\r\n SECURITY_NON_UNIQUE_AUTHORITY: TSidIdentifierAuthority = (Value: (0, 0, 0, 0, 0, 4));\r\n {$EXTERNALSYM SECURITY_NON_UNIQUE_AUTHORITY}\r\n SECURITY_RESOURCE_MANAGER_AUTHORITY: TSidIdentifierAuthority = (Value: (0, 0, 0, 0, 0, 9));\r\n {$EXTERNALSYM SECURITY_RESOURCE_MANAGER_AUTHORITY}\r\n\r\n SECURITY_NULL_RID = ($00000000);\r\n {$EXTERNALSYM SECURITY_NULL_RID}\r\n SECURITY_WORLD_RID = ($00000000);\r\n {$EXTERNALSYM SECURITY_WORLD_RID}\r\n SECURITY_LOCAL_RID = ($00000000);\r\n {$EXTERNALSYM SECURITY_LOCAL_RID}\r\n\r\n SECURITY_CREATOR_OWNER_RID = ($00000000);\r\n {$EXTERNALSYM SECURITY_CREATOR_OWNER_RID}\r\n SECURITY_CREATOR_GROUP_RID = ($00000001);\r\n {$EXTERNALSYM SECURITY_CREATOR_GROUP_RID}\r\n\r\n SECURITY_CREATOR_OWNER_SERVER_RID = ($00000002);\r\n {$EXTERNALSYM SECURITY_CREATOR_OWNER_SERVER_RID}\r\n SECURITY_CREATOR_GROUP_SERVER_RID = ($00000003);\r\n {$EXTERNALSYM SECURITY_CREATOR_GROUP_SERVER_RID}\r\n\r\n/////////////////////////////////////////////////////////////////////////////\r\n// //\r\n// NT well-known SIDs //\r\n// //\r\n// NT Authority S-1-5 //\r\n// Dialup S-1-5-1 //\r\n// //\r\n// Network S-1-5-2 //\r\n// Batch S-1-5-3 //\r\n// Interactive S-1-5-4 //\r\n// (Logon IDs) S-1-5-5-X-Y //\r\n// Service S-1-5-6 //\r\n// AnonymousLogon S-1-5-7 (aka null logon session) //\r\n// Proxy S-1-5-8 //\r\n// Enterprise DC (EDC) S-1-5-9 (aka domain controller account) //\r\n// Self S-1-5-10 (self RID) //\r\n// Authenticated User S-1-5-11 (Authenticated user somewhere) //\r\n// Restricted Code S-1-5-12 (Running restricted code) //\r\n// Terminal Server S-1-5-13 (Running on Terminal Server) //\r\n// Remote Logon S-1-5-14 (Remote Interactive Logon) //\r\n// This Organization S-1-5-15 //\r\n// //\r\n// Local System S-1-5-18 //\r\n// Local Service S-1-5-19 //\r\n// Network Service S-1-5-20 //\r\n// //\r\n// (NT non-unique IDs) S-1-5-0x15-... (NT Domain Sids) //\r\n// //\r\n// (Built-in domain) S-1-5-0x20 //\r\n// //\r\n// (Security Package IDs) S-1-5-0x40 //\r\n// NTLM Authentication S-1-5-0x40-10 //\r\n// SChannel Authentication S-1-5-0x40-14 //\r\n// Digest Authentication S-1-5-0x40-21 //\r\n// //\r\n// Other Organization S-1-5-1000 (>=1000 can not be filtered) //\r\n// //\r\n// //\r\n// NOTE: the relative identifier values (RIDs) determine which security //\r\n// boundaries the SID is allowed to cross. Before adding new RIDs, //\r\n// a determination needs to be made regarding which range they should //\r\n// be added to in order to ensure proper \"SID filtering\" //\r\n// //\r\n/////////////////////////////////////////////////////////////////////////////\r\n\r\nconst\r\n SECURITY_NT_AUTHORITY: TSidIdentifierAuthority = (Value: (0, 0, 0, 0, 0, 5));\r\n {$EXTERNALSYM SECURITY_NT_AUTHORITY}\r\n\r\n SECURITY_DIALUP_RID = ($00000001);\r\n {$EXTERNALSYM SECURITY_DIALUP_RID}\r\n SECURITY_NETWORK_RID = ($00000002);\r\n {$EXTERNALSYM SECURITY_NETWORK_RID}\r\n SECURITY_BATCH_RID = ($00000003);\r\n {$EXTERNALSYM SECURITY_BATCH_RID}\r\n SECURITY_INTERACTIVE_RID = ($00000004);\r\n {$EXTERNALSYM SECURITY_INTERACTIVE_RID}\r\n SECURITY_LOGON_IDS_RID = ($00000005);\r\n {$EXTERNALSYM SECURITY_LOGON_IDS_RID}\r\n SECURITY_LOGON_IDS_RID_COUNT = (3);\r\n {$EXTERNALSYM SECURITY_LOGON_IDS_RID_COUNT}\r\n SECURITY_SERVICE_RID = ($00000006);\r\n {$EXTERNALSYM SECURITY_SERVICE_RID}\r\n SECURITY_ANONYMOUS_LOGON_RID = ($00000007);\r\n {$EXTERNALSYM SECURITY_ANONYMOUS_LOGON_RID}\r\n SECURITY_PROXY_RID = ($00000008);\r\n {$EXTERNALSYM SECURITY_PROXY_RID}\r\n SECURITY_ENTERPRISE_CONTROLLERS_RID = ($00000009);\r\n {$EXTERNALSYM SECURITY_ENTERPRISE_CONTROLLERS_RID}\r\n SECURITY_SERVER_LOGON_RID = SECURITY_ENTERPRISE_CONTROLLERS_RID;\r\n {$EXTERNALSYM SECURITY_SERVER_LOGON_RID}\r\n SECURITY_PRINCIPAL_SELF_RID = ($0000000A);\r\n {$EXTERNALSYM SECURITY_PRINCIPAL_SELF_RID}\r\n SECURITY_AUTHENTICATED_USER_RID = ($0000000B);\r\n {$EXTERNALSYM SECURITY_AUTHENTICATED_USER_RID}\r\n SECURITY_RESTRICTED_CODE_RID = ($0000000C);\r\n {$EXTERNALSYM SECURITY_RESTRICTED_CODE_RID}\r\n SECURITY_TERMINAL_SERVER_RID = ($0000000D);\r\n {$EXTERNALSYM SECURITY_TERMINAL_SERVER_RID}\r\n SECURITY_REMOTE_LOGON_RID = ($0000000E);\r\n {$EXTERNALSYM SECURITY_REMOTE_LOGON_RID}\r\n SECURITY_THIS_ORGANIZATION_RID = ($0000000F);\r\n {$EXTERNALSYM SECURITY_THIS_ORGANIZATION_RID}\r\n\r\n SECURITY_LOCAL_SYSTEM_RID = ($00000012);\r\n {$EXTERNALSYM SECURITY_LOCAL_SYSTEM_RID}\r\n SECURITY_LOCAL_SERVICE_RID = ($00000013);\r\n {$EXTERNALSYM SECURITY_LOCAL_SERVICE_RID}\r\n SECURITY_NETWORK_SERVICE_RID = ($00000014);\r\n {$EXTERNALSYM SECURITY_NETWORK_SERVICE_RID}\r\n\r\n SECURITY_NT_NON_UNIQUE = ($00000015);\r\n {$EXTERNALSYM SECURITY_NT_NON_UNIQUE}\r\n SECURITY_NT_NON_UNIQUE_SUB_AUTH_COUNT = (3);\r\n {$EXTERNALSYM SECURITY_NT_NON_UNIQUE_SUB_AUTH_COUNT}\r\n\r\n SECURITY_BUILTIN_DOMAIN_RID = ($00000020);\r\n {$EXTERNALSYM SECURITY_BUILTIN_DOMAIN_RID}\r\n\r\n SECURITY_PACKAGE_BASE_RID = ($00000040);\r\n {$EXTERNALSYM SECURITY_PACKAGE_BASE_RID}\r\n SECURITY_PACKAGE_RID_COUNT = (2);\r\n {$EXTERNALSYM SECURITY_PACKAGE_RID_COUNT}\r\n SECURITY_PACKAGE_NTLM_RID = ($0000000A);\r\n {$EXTERNALSYM SECURITY_PACKAGE_NTLM_RID}\r\n SECURITY_PACKAGE_SCHANNEL_RID = ($0000000E);\r\n {$EXTERNALSYM SECURITY_PACKAGE_SCHANNEL_RID}\r\n SECURITY_PACKAGE_DIGEST_RID = ($00000015);\r\n {$EXTERNALSYM SECURITY_PACKAGE_DIGEST_RID}\r\n\r\n SECURITY_MAX_ALWAYS_FILTERED = ($000003E7);\r\n {$EXTERNALSYM SECURITY_MAX_ALWAYS_FILTERED}\r\n SECURITY_MIN_NEVER_FILTERED = ($000003E8);\r\n {$EXTERNALSYM SECURITY_MIN_NEVER_FILTERED}\r\n\r\n SECURITY_OTHER_ORGANIZATION_RID = ($000003E8);\r\n {$EXTERNALSYM SECURITY_OTHER_ORGANIZATION_RID}\r\n\r\n/////////////////////////////////////////////////////////////////////////////\r\n// //\r\n// well-known domain relative sub-authority values (RIDs)... //\r\n// //\r\n/////////////////////////////////////////////////////////////////////////////\r\n\r\n// Well-known users ...\r\n\r\n FOREST_USER_RID_MAX = ($000001F3);\r\n {$EXTERNALSYM FOREST_USER_RID_MAX}\r\n\r\n DOMAIN_USER_RID_ADMIN = ($000001F4);\r\n {$EXTERNALSYM DOMAIN_USER_RID_ADMIN}\r\n DOMAIN_USER_RID_GUEST = ($000001F5);\r\n {$EXTERNALSYM DOMAIN_USER_RID_GUEST}\r\n DOMAIN_USER_RID_KRBTGT = ($000001F6);\r\n {$EXTERNALSYM DOMAIN_USER_RID_KRBTGT}\r\n\r\n DOMAIN_USER_RID_MAX = ($000003E7);\r\n {$EXTERNALSYM DOMAIN_USER_RID_MAX}\r\n\r\n// well-known groups ...\r\n\r\n DOMAIN_GROUP_RID_ADMINS = ($00000200);\r\n {$EXTERNALSYM DOMAIN_GROUP_RID_ADMINS}\r\n DOMAIN_GROUP_RID_USERS = ($00000201);\r\n {$EXTERNALSYM DOMAIN_GROUP_RID_USERS}\r\n DOMAIN_GROUP_RID_GUESTS = ($00000202);\r\n {$EXTERNALSYM DOMAIN_GROUP_RID_GUESTS}\r\n DOMAIN_GROUP_RID_COMPUTERS = ($00000203);\r\n {$EXTERNALSYM DOMAIN_GROUP_RID_COMPUTERS}\r\n DOMAIN_GROUP_RID_CONTROLLERS = ($00000204);\r\n {$EXTERNALSYM DOMAIN_GROUP_RID_CONTROLLERS}\r\n DOMAIN_GROUP_RID_CERT_ADMINS = ($00000205);\r\n {$EXTERNALSYM DOMAIN_GROUP_RID_CERT_ADMINS}\r\n DOMAIN_GROUP_RID_SCHEMA_ADMINS = ($00000206);\r\n {$EXTERNALSYM DOMAIN_GROUP_RID_SCHEMA_ADMINS}\r\n DOMAIN_GROUP_RID_ENTERPRISE_ADMINS = ($00000207);\r\n {$EXTERNALSYM DOMAIN_GROUP_RID_ENTERPRISE_ADMINS}\r\n DOMAIN_GROUP_RID_POLICY_ADMINS = ($00000208);\r\n {$EXTERNALSYM DOMAIN_GROUP_RID_POLICY_ADMINS}\r\n\r\n// well-known aliases ...\r\n\r\n DOMAIN_ALIAS_RID_ADMINS = ($00000220);\r\n {$EXTERNALSYM DOMAIN_ALIAS_RID_ADMINS}\r\n DOMAIN_ALIAS_RID_USERS = ($00000221);\r\n {$EXTERNALSYM DOMAIN_ALIAS_RID_USERS}\r\n DOMAIN_ALIAS_RID_GUESTS = ($00000222);\r\n {$EXTERNALSYM DOMAIN_ALIAS_RID_GUESTS}\r\n DOMAIN_ALIAS_RID_POWER_USERS = ($00000223);\r\n {$EXTERNALSYM DOMAIN_ALIAS_RID_POWER_USERS}\r\n\r\n DOMAIN_ALIAS_RID_ACCOUNT_OPS = ($00000224);\r\n {$EXTERNALSYM DOMAIN_ALIAS_RID_ACCOUNT_OPS}\r\n DOMAIN_ALIAS_RID_SYSTEM_OPS = ($00000225);\r\n {$EXTERNALSYM DOMAIN_ALIAS_RID_SYSTEM_OPS}\r\n DOMAIN_ALIAS_RID_PRINT_OPS = ($00000226);\r\n {$EXTERNALSYM DOMAIN_ALIAS_RID_PRINT_OPS}\r\n DOMAIN_ALIAS_RID_BACKUP_OPS = ($00000227);\r\n {$EXTERNALSYM DOMAIN_ALIAS_RID_BACKUP_OPS}\r\n\r\n DOMAIN_ALIAS_RID_REPLICATOR = ($00000228);\r\n {$EXTERNALSYM DOMAIN_ALIAS_RID_REPLICATOR}\r\n DOMAIN_ALIAS_RID_RAS_SERVERS = ($00000229);\r\n {$EXTERNALSYM DOMAIN_ALIAS_RID_RAS_SERVERS}\r\n DOMAIN_ALIAS_RID_PREW2KCOMPACCESS = ($0000022A);\r\n {$EXTERNALSYM DOMAIN_ALIAS_RID_PREW2KCOMPACCESS}\r\n DOMAIN_ALIAS_RID_REMOTE_DESKTOP_USERS = ($0000022B);\r\n {$EXTERNALSYM DOMAIN_ALIAS_RID_REMOTE_DESKTOP_USERS}\r\n DOMAIN_ALIAS_RID_NETWORK_CONFIGURATION_OPS = ($0000022C);\r\n {$EXTERNALSYM DOMAIN_ALIAS_RID_NETWORK_CONFIGURATION_OPS}\r\n DOMAIN_ALIAS_RID_INCOMING_FOREST_TRUST_BUILDERS = ($0000022D);\r\n {$EXTERNALSYM DOMAIN_ALIAS_RID_INCOMING_FOREST_TRUST_BUILDERS}\r\n\r\n DOMAIN_ALIAS_RID_MONITORING_USERS = ($0000022E);\r\n {$EXTERNALSYM DOMAIN_ALIAS_RID_MONITORING_USERS}\r\n DOMAIN_ALIAS_RID_LOGGING_USERS = ($0000022F);\r\n {$EXTERNALSYM DOMAIN_ALIAS_RID_LOGGING_USERS}\r\n DOMAIN_ALIAS_RID_AUTHORIZATIONACCESS = ($00000230);\r\n {$EXTERNALSYM DOMAIN_ALIAS_RID_AUTHORIZATIONACCESS}\r\n DOMAIN_ALIAS_RID_TS_LICENSE_SERVERS = ($00000231);\r\n {$EXTERNALSYM DOMAIN_ALIAS_RID_TS_LICENSE_SERVERS}\r\n\r\n// line 2495\r\n\r\n////////////////////////////////////////////////////////////////////////\r\n// //\r\n// NT Defined Privileges //\r\n// //\r\n////////////////////////////////////////////////////////////////////////\r\n\r\nconst\r\n SE_CREATE_TOKEN_NAME = 'SeCreateTokenPrivilege';\r\n {$EXTERNALSYM SE_CREATE_TOKEN_NAME}\r\n SE_ASSIGNPRIMARYTOKEN_NAME = 'SeAssignPrimaryTokenPrivilege';\r\n {$EXTERNALSYM SE_ASSIGNPRIMARYTOKEN_NAME}\r\n SE_LOCK_MEMORY_NAME = 'SeLockMemoryPrivilege';\r\n {$EXTERNALSYM SE_LOCK_MEMORY_NAME}\r\n SE_INCREASE_QUOTA_NAME = 'SeIncreaseQuotaPrivilege';\r\n {$EXTERNALSYM SE_INCREASE_QUOTA_NAME}\r\n SE_UNSOLICITED_INPUT_NAME = 'SeUnsolicitedInputPrivilege';\r\n {$EXTERNALSYM SE_UNSOLICITED_INPUT_NAME}\r\n SE_MACHINE_ACCOUNT_NAME = 'SeMachineAccountPrivilege';\r\n {$EXTERNALSYM SE_MACHINE_ACCOUNT_NAME}\r\n SE_TCB_NAME = 'SeTcbPrivilege';\r\n {$EXTERNALSYM SE_TCB_NAME}\r\n SE_SECURITY_NAME = 'SeSecurityPrivilege';\r\n {$EXTERNALSYM SE_SECURITY_NAME}\r\n SE_TAKE_OWNERSHIP_NAME = 'SeTakeOwnershipPrivilege';\r\n {$EXTERNALSYM SE_TAKE_OWNERSHIP_NAME}\r\n SE_LOAD_DRIVER_NAME = 'SeLoadDriverPrivilege';\r\n {$EXTERNALSYM SE_LOAD_DRIVER_NAME}\r\n SE_SYSTEM_PROFILE_NAME = 'SeSystemProfilePrivilege';\r\n {$EXTERNALSYM SE_SYSTEM_PROFILE_NAME}\r\n SE_SYSTEMTIME_NAME = 'SeSystemtimePrivilege';\r\n {$EXTERNALSYM SE_SYSTEMTIME_NAME}\r\n SE_PROF_SINGLE_PROCESS_NAME = 'SeProfileSingleProcessPrivilege';\r\n {$EXTERNALSYM SE_PROF_SINGLE_PROCESS_NAME}\r\n SE_INC_BASE_PRIORITY_NAME = 'SeIncreaseBasePriorityPrivilege';\r\n {$EXTERNALSYM SE_INC_BASE_PRIORITY_NAME}\r\n SE_CREATE_PAGEFILE_NAME = 'SeCreatePagefilePrivilege';\r\n {$EXTERNALSYM SE_CREATE_PAGEFILE_NAME}\r\n SE_CREATE_PERMANENT_NAME = 'SeCreatePermanentPrivilege';\r\n {$EXTERNALSYM SE_CREATE_PERMANENT_NAME}\r\n SE_BACKUP_NAME = 'SeBackupPrivilege';\r\n {$EXTERNALSYM SE_BACKUP_NAME}\r\n SE_RESTORE_NAME = 'SeRestorePrivilege';\r\n {$EXTERNALSYM SE_RESTORE_NAME}\r\n SE_SHUTDOWN_NAME = 'SeShutdownPrivilege';\r\n {$EXTERNALSYM SE_SHUTDOWN_NAME}\r\n SE_DEBUG_NAME = 'SeDebugPrivilege';\r\n {$EXTERNALSYM SE_DEBUG_NAME}\r\n SE_AUDIT_NAME = 'SeAuditPrivilege';\r\n {$EXTERNALSYM SE_AUDIT_NAME}\r\n SE_SYSTEM_ENVIRONMENT_NAME = 'SeSystemEnvironmentPrivilege';\r\n {$EXTERNALSYM SE_SYSTEM_ENVIRONMENT_NAME}\r\n SE_CHANGE_NOTIFY_NAME = 'SeChangeNotifyPrivilege';\r\n {$EXTERNALSYM SE_CHANGE_NOTIFY_NAME}\r\n SE_REMOTE_SHUTDOWN_NAME = 'SeRemoteShutdownPrivilege';\r\n {$EXTERNALSYM SE_REMOTE_SHUTDOWN_NAME}\r\n SE_UNDOCK_NAME = 'SeUndockPrivilege';\r\n {$EXTERNALSYM SE_UNDOCK_NAME}\r\n SE_SYNC_AGENT_NAME = 'SeSyncAgentPrivilege';\r\n {$EXTERNALSYM SE_SYNC_AGENT_NAME}\r\n SE_ENABLE_DELEGATION_NAME = 'SeEnableDelegationPrivilege';\r\n {$EXTERNALSYM SE_ENABLE_DELEGATION_NAME}\r\n SE_MANAGE_VOLUME_NAME = 'SeManageVolumePrivilege';\r\n {$EXTERNALSYM SE_MANAGE_VOLUME_NAME}\r\n SE_IMPERSONATE_NAME = 'SeImpersonatePrivilege';\r\n {$EXTERNALSYM SE_IMPERSONATE_NAME}\r\n SE_CREATE_GLOBAL_NAME = 'SeCreateGlobalPrivilege';\r\n {$EXTERNALSYM SE_CREATE_GLOBAL_NAME}\r\n\r\n//\r\n// Thread Information Block (TIB)\r\n//\r\n\r\ntype\r\n NT_TIB32 = packed record\r\n ExceptionList: DWORD;\r\n StackBase: DWORD;\r\n StackLimit: DWORD;\r\n SubSystemTib: DWORD;\r\n case Integer of\r\n 0 : (\r\n FiberData: DWORD;\r\n ArbitraryUserPointer: DWORD;\r\n Self: DWORD;\r\n );\r\n 1 : (\r\n Version: DWORD;\r\n );\r\n end;\r\n {$EXTERNALSYM NT_TIB32}\r\n PNT_TIB32 = ^NT_TIB32;\r\n {$EXTERNALSYM PNT_TIB32}\r\n\r\n NT_TIB64 = packed record\r\n ExceptionList: TJclAddr64;\r\n StackBase: TJclAddr64;\r\n StackLimit: TJclAddr64;\r\n SubSystemTib: TJclAddr64;\r\n case Integer of\r\n 0 : (\r\n FiberData: TJclAddr64;\r\n ArbitraryUserPointer: TJclAddr64;\r\n Self: TJclAddr64;\r\n );\r\n 1 : (\r\n Version: DWORD;\r\n );\r\n end;\r\n {$EXTERNALSYM NT_TIB64}\r\n PNT_TIB64 = ^NT_TIB64;\r\n {$EXTERNALSYM PNT_TIB64}\r\n\r\n// line 2686\r\n\r\n//\r\n// Token information class structures\r\n//\r\n\r\n{$IFNDEF FPC}\r\ntype\r\n PTOKEN_USER = ^TOKEN_USER;\r\n {$EXTERNALSYM PTOKEN_USER}\r\n _TOKEN_USER = record\r\n User: SID_AND_ATTRIBUTES;\r\n end;\r\n {$EXTERNALSYM _TOKEN_USER}\r\n TOKEN_USER = _TOKEN_USER;\r\n {$EXTERNALSYM TOKEN_USER}\r\n TTokenUser = TOKEN_USER;\r\n PTokenUser = PTOKEN_USER;\r\n{$ENDIF ~FPC}\r\n\r\nfunction CaptureStackBackTrace(FramesToSkip, FramesToCapture: DWORD;\r\n BackTrace: Pointer; out BackTraceHash: DWORD): Word; stdcall;\r\n{$EXTERNALSYM CaptureStackBackTrace}\r\n\r\n// line 3858\r\n\r\n//\r\n// Define access rights to files and directories\r\n//\r\n\r\n//\r\n// The FILE_READ_DATA and FILE_WRITE_DATA constants are also defined in\r\n// devioctl.h as FILE_READ_ACCESS and FILE_WRITE_ACCESS. The values for these\r\n// constants *MUST* always be in sync.\r\n// The values are redefined in devioctl.h because they must be available to\r\n// both DOS and NT.\r\n//\r\n\r\nconst\r\n FILE_READ_DATA = ($0001); // file & pipe\r\n {$EXTERNALSYM FILE_READ_DATA}\r\n FILE_LIST_DIRECTORY = ($0001); // directory\r\n {$EXTERNALSYM FILE_LIST_DIRECTORY}\r\n\r\n FILE_WRITE_DATA = ($0002); // file & pipe\r\n {$EXTERNALSYM FILE_WRITE_DATA}\r\n FILE_ADD_FILE = ($0002); // directory\r\n {$EXTERNALSYM FILE_ADD_FILE}\r\n\r\n FILE_APPEND_DATA = ($0004); // file\r\n {$EXTERNALSYM FILE_APPEND_DATA}\r\n FILE_ADD_SUBDIRECTORY = ($0004); // directory\r\n {$EXTERNALSYM FILE_ADD_SUBDIRECTORY}\r\n FILE_CREATE_PIPE_INSTANCE = ($0004); // named pipe\r\n {$EXTERNALSYM FILE_CREATE_PIPE_INSTANCE}\r\n\r\n FILE_READ_EA = ($0008); // file & directory\r\n {$EXTERNALSYM FILE_READ_EA}\r\n\r\n FILE_WRITE_EA = ($0010); // file & directory\r\n {$EXTERNALSYM FILE_WRITE_EA}\r\n\r\n FILE_EXECUTE = ($0020); // file\r\n {$EXTERNALSYM FILE_EXECUTE}\r\n FILE_TRAVERSE = ($0020); // directory\r\n {$EXTERNALSYM FILE_TRAVERSE}\r\n\r\n FILE_DELETE_CHILD = ($0040); // directory\r\n {$EXTERNALSYM FILE_DELETE_CHILD}\r\n\r\n FILE_READ_ATTRIBUTES = ($0080); // all\r\n {$EXTERNALSYM FILE_READ_ATTRIBUTES}\r\n\r\n FILE_WRITE_ATTRIBUTES = ($0100); // all\r\n {$EXTERNALSYM FILE_WRITE_ATTRIBUTES}\r\n\r\n FILE_ALL_ACCESS = (STANDARD_RIGHTS_REQUIRED or SYNCHRONIZE or $1FF);\r\n {$EXTERNALSYM FILE_ALL_ACCESS}\r\n\r\n FILE_GENERIC_READ = (STANDARD_RIGHTS_READ or FILE_READ_DATA or\r\n FILE_READ_ATTRIBUTES or FILE_READ_EA or SYNCHRONIZE);\r\n {$EXTERNALSYM FILE_GENERIC_READ}\r\n\r\n FILE_GENERIC_WRITE = (STANDARD_RIGHTS_WRITE or FILE_WRITE_DATA or\r\n FILE_WRITE_ATTRIBUTES or FILE_WRITE_EA or FILE_APPEND_DATA or SYNCHRONIZE);\r\n {$EXTERNALSYM FILE_GENERIC_WRITE}\r\n\r\n FILE_GENERIC_EXECUTE = (STANDARD_RIGHTS_EXECUTE or FILE_READ_ATTRIBUTES or\r\n FILE_EXECUTE or SYNCHRONIZE);\r\n {$EXTERNALSYM FILE_GENERIC_EXECUTE}\r\n\r\n FILE_SHARE_READ = $00000001;\r\n {$EXTERNALSYM FILE_SHARE_READ}\r\n FILE_SHARE_WRITE = $00000002;\r\n {$EXTERNALSYM FILE_SHARE_WRITE}\r\n FILE_SHARE_DELETE = $00000004;\r\n {$EXTERNALSYM FILE_SHARE_DELETE}\r\n FILE_ATTRIBUTE_READONLY = $00000001;\r\n {$EXTERNALSYM FILE_ATTRIBUTE_READONLY}\r\n FILE_ATTRIBUTE_HIDDEN = $00000002;\r\n {$EXTERNALSYM FILE_ATTRIBUTE_HIDDEN}\r\n FILE_ATTRIBUTE_SYSTEM = $00000004;\r\n {$EXTERNALSYM FILE_ATTRIBUTE_SYSTEM}\r\n FILE_ATTRIBUTE_DIRECTORY = $00000010;\r\n {$EXTERNALSYM FILE_ATTRIBUTE_DIRECTORY}\r\n FILE_ATTRIBUTE_ARCHIVE = $00000020;\r\n {$EXTERNALSYM FILE_ATTRIBUTE_ARCHIVE}\r\n FILE_ATTRIBUTE_DEVICE = $00000040;\r\n {$EXTERNALSYM FILE_ATTRIBUTE_DEVICE}\r\n FILE_ATTRIBUTE_NORMAL = $00000080;\r\n {$EXTERNALSYM FILE_ATTRIBUTE_NORMAL}\r\n FILE_ATTRIBUTE_TEMPORARY = $00000100;\r\n {$EXTERNALSYM FILE_ATTRIBUTE_TEMPORARY}\r\n FILE_ATTRIBUTE_SPARSE_FILE = $00000200;\r\n {$EXTERNALSYM FILE_ATTRIBUTE_SPARSE_FILE}\r\n FILE_ATTRIBUTE_REPARSE_POINT = $00000400;\r\n {$EXTERNALSYM FILE_ATTRIBUTE_REPARSE_POINT}\r\n FILE_ATTRIBUTE_COMPRESSED = $00000800;\r\n {$EXTERNALSYM FILE_ATTRIBUTE_COMPRESSED}\r\n FILE_ATTRIBUTE_OFFLINE = $00001000;\r\n {$EXTERNALSYM FILE_ATTRIBUTE_OFFLINE}\r\n FILE_ATTRIBUTE_NOT_CONTENT_INDEXED = $00002000;\r\n {$EXTERNALSYM FILE_ATTRIBUTE_NOT_CONTENT_INDEXED}\r\n FILE_ATTRIBUTE_ENCRYPTED = $00004000;\r\n {$EXTERNALSYM FILE_ATTRIBUTE_ENCRYPTED}\r\n FILE_NOTIFY_CHANGE_FILE_NAME = $00000001;\r\n {$EXTERNALSYM FILE_NOTIFY_CHANGE_FILE_NAME}\r\n FILE_NOTIFY_CHANGE_DIR_NAME = $00000002;\r\n {$EXTERNALSYM FILE_NOTIFY_CHANGE_DIR_NAME}\r\n FILE_NOTIFY_CHANGE_ATTRIBUTES = $00000004;\r\n {$EXTERNALSYM FILE_NOTIFY_CHANGE_ATTRIBUTES}\r\n FILE_NOTIFY_CHANGE_SIZE = $00000008;\r\n {$EXTERNALSYM FILE_NOTIFY_CHANGE_SIZE}\r\n FILE_NOTIFY_CHANGE_LAST_WRITE = $00000010;\r\n {$EXTERNALSYM FILE_NOTIFY_CHANGE_LAST_WRITE}\r\n FILE_NOTIFY_CHANGE_LAST_ACCESS = $00000020;\r\n {$EXTERNALSYM FILE_NOTIFY_CHANGE_LAST_ACCESS}\r\n FILE_NOTIFY_CHANGE_CREATION = $00000040;\r\n {$EXTERNALSYM FILE_NOTIFY_CHANGE_CREATION}\r\n FILE_NOTIFY_CHANGE_SECURITY = $00000100;\r\n {$EXTERNALSYM FILE_NOTIFY_CHANGE_SECURITY}\r\n FILE_ACTION_ADDED = $00000001;\r\n {$EXTERNALSYM FILE_ACTION_ADDED}\r\n FILE_ACTION_REMOVED = $00000002;\r\n {$EXTERNALSYM FILE_ACTION_REMOVED}\r\n FILE_ACTION_MODIFIED = $00000003;\r\n {$EXTERNALSYM FILE_ACTION_MODIFIED}\r\n FILE_ACTION_RENAMED_OLD_NAME = $00000004;\r\n {$EXTERNALSYM FILE_ACTION_RENAMED_OLD_NAME}\r\n FILE_ACTION_RENAMED_NEW_NAME = $00000005;\r\n {$EXTERNALSYM FILE_ACTION_RENAMED_NEW_NAME}\r\n MAILSLOT_NO_MESSAGE = DWORD(-1);\r\n {$EXTERNALSYM MAILSLOT_NO_MESSAGE}\r\n MAILSLOT_WAIT_FOREVER = DWORD(-1);\r\n {$EXTERNALSYM MAILSLOT_WAIT_FOREVER}\r\n FILE_CASE_SENSITIVE_SEARCH = $00000001;\r\n {$EXTERNALSYM FILE_CASE_SENSITIVE_SEARCH}\r\n FILE_CASE_PRESERVED_NAMES = $00000002;\r\n {$EXTERNALSYM FILE_CASE_PRESERVED_NAMES}\r\n FILE_UNICODE_ON_DISK = $00000004;\r\n {$EXTERNALSYM FILE_UNICODE_ON_DISK}\r\n FILE_PERSISTENT_ACLS = $00000008;\r\n {$EXTERNALSYM FILE_PERSISTENT_ACLS}\r\n FILE_FILE_COMPRESSION = $00000010;\r\n {$EXTERNALSYM FILE_FILE_COMPRESSION}\r\n FILE_VOLUME_QUOTAS = $00000020;\r\n {$EXTERNALSYM FILE_VOLUME_QUOTAS}\r\n FILE_SUPPORTS_SPARSE_FILES = $00000040;\r\n {$EXTERNALSYM FILE_SUPPORTS_SPARSE_FILES}\r\n FILE_SUPPORTS_REPARSE_POINTS = $00000080;\r\n {$EXTERNALSYM FILE_SUPPORTS_REPARSE_POINTS}\r\n FILE_SUPPORTS_REMOTE_STORAGE = $00000100;\r\n {$EXTERNALSYM FILE_SUPPORTS_REMOTE_STORAGE}\r\n FILE_VOLUME_IS_COMPRESSED = $00008000;\r\n {$EXTERNALSYM FILE_VOLUME_IS_COMPRESSED}\r\n FILE_SUPPORTS_OBJECT_IDS = $00010000;\r\n {$EXTERNALSYM FILE_SUPPORTS_OBJECT_IDS}\r\n FILE_SUPPORTS_ENCRYPTION = $00020000;\r\n {$EXTERNALSYM FILE_SUPPORTS_ENCRYPTION}\r\n FILE_NAMED_STREAMS = $00040000;\r\n {$EXTERNALSYM FILE_NAMED_STREAMS}\r\n FILE_READ_ONLY_VOLUME = $00080000;\r\n {$EXTERNALSYM FILE_READ_ONLY_VOLUME}\r\n\r\n// line 4052\r\n\r\n//\r\n// The reparse GUID structure is used by all 3rd party layered drivers to\r\n// store data in a reparse point. For non-Microsoft tags, The GUID field\r\n// cannot be GUID_NULL.\r\n// The constraints on reparse tags are defined below.\r\n// Microsoft tags can also be used with this format of the reparse point buffer.\r\n//\r\n\r\ntype\r\n TGenericReparseBuffer = record\r\n DataBuffer: array [0..0] of BYTE;\r\n end;\r\n\r\n PREPARSE_GUID_DATA_BUFFER = ^REPARSE_GUID_DATA_BUFFER;\r\n {$EXTERNALSYM PREPARSE_GUID_DATA_BUFFER}\r\n _REPARSE_GUID_DATA_BUFFER = record\r\n ReparseTag: DWORD;\r\n ReparseDataLength: WORD;\r\n Reserved: WORD;\r\n ReparseGuid: TGUID;\r\n GenericReparseBuffer: TGenericReparseBuffer;\r\n end;\r\n {$EXTERNALSYM _REPARSE_GUID_DATA_BUFFER}\r\n REPARSE_GUID_DATA_BUFFER = _REPARSE_GUID_DATA_BUFFER;\r\n {$EXTERNALSYM REPARSE_GUID_DATA_BUFFER}\r\n TReparseGuidDataBuffer = REPARSE_GUID_DATA_BUFFER;\r\n PReparseGuidDataBuffer = PREPARSE_GUID_DATA_BUFFER;\r\n\r\nconst\r\n REPARSE_GUID_DATA_BUFFER_HEADER_SIZE = 24;\r\n {$EXTERNALSYM REPARSE_GUID_DATA_BUFFER_HEADER_SIZE}\r\n//\r\n// Maximum allowed size of the reparse data.\r\n//\r\n\r\nconst\r\n MAXIMUM_REPARSE_DATA_BUFFER_SIZE = 16 * 1024;\r\n {$EXTERNALSYM MAXIMUM_REPARSE_DATA_BUFFER_SIZE}\r\n\r\n//\r\n// Predefined reparse tags.\r\n// These tags need to avoid conflicting with IO_REMOUNT defined in ntos\\inc\\io.h\r\n//\r\n\r\n IO_REPARSE_TAG_RESERVED_ZERO = (0);\r\n {$EXTERNALSYM IO_REPARSE_TAG_RESERVED_ZERO}\r\n IO_REPARSE_TAG_RESERVED_ONE = (1);\r\n {$EXTERNALSYM IO_REPARSE_TAG_RESERVED_ONE}\r\n\r\n//\r\n// The value of the following constant needs to satisfy the following conditions:\r\n// (1) Be at least as large as the largest of the reserved tags.\r\n// (2) Be strictly smaller than all the tags in use.\r\n//\r\n\r\n IO_REPARSE_TAG_RESERVED_RANGE = IO_REPARSE_TAG_RESERVED_ONE;\r\n {$EXTERNALSYM IO_REPARSE_TAG_RESERVED_RANGE}\r\n\r\n//\r\n// The reparse tags are a DWORD. The 32 bits are laid out as follows:\r\n//\r\n// 3 3 2 2 2 2 2 2 2 2 2 2 1 1 1 1 1 1 1 1 1 1\r\n// 1 0 9 8 7 6 5 4 3 2 1 0 9 8 7 6 5 4 3 2 1 0 9 8 7 6 5 4 3 2 1 0\r\n// +-+-+-+-+-----------------------+-------------------------------+\r\n// |M|R|N|R| Reserved bits | Reparse Tag Value |\r\n// +-+-+-+-+-----------------------+-------------------------------+\r\n//\r\n// M is the Microsoft bit. When set to 1, it denotes a tag owned by Microsoft.\r\n// All ISVs must use a tag with a 0 in this position.\r\n// Note: If a Microsoft tag is used by non-Microsoft software, the\r\n// behavior is not defined.\r\n//\r\n// R is reserved. Must be zero for non-Microsoft tags.\r\n//\r\n// N is name surrogate. When set to 1, the file represents another named\r\n// entity in the system.\r\n//\r\n// The M and N bits are OR-able.\r\n// The following macros check for the M and N bit values:\r\n//\r\n\r\n//\r\n// Macro to determine whether a reparse point tag corresponds to a tag\r\n// owned by Microsoft.\r\n//\r\n\r\nfunction IsReparseTagMicrosoft(Tag: ULONG): Boolean;\r\n{$EXTERNALSYM IsReparseTagMicrosoft}\r\n\r\n//\r\n// Macro to determine whether a reparse point tag corresponds to a file\r\n// that is to be displayed with the slow icon overlay.\r\n//\r\n\r\nfunction IsReparseTagHighLatency(Tag: ULONG): Boolean;\r\n{$EXTERNALSYM IsReparseTagHighLatency}\r\n\r\n//\r\n// Macro to determine whether a reparse point tag is a name surrogate\r\n//\r\n\r\nfunction IsReparseTagNameSurrogate(Tag: ULONG): Boolean;\r\n{$EXTERNALSYM IsReparseTagNameSurrogate}\r\n\r\nconst\r\n IO_REPARSE_TAG_MOUNT_POINT = DWORD($A0000003);\r\n {$EXTERNALSYM IO_REPARSE_TAG_MOUNT_POINT}\r\n IO_REPARSE_TAG_HSM = DWORD($C0000004);\r\n {$EXTERNALSYM IO_REPARSE_TAG_HSM}\r\n IO_REPARSE_TAG_SIS = DWORD($80000007);\r\n {$EXTERNALSYM IO_REPARSE_TAG_SIS}\r\n IO_REPARSE_TAG_DFS = DWORD($8000000A);\r\n {$EXTERNALSYM IO_REPARSE_TAG_DFS}\r\n IO_REPARSE_TAG_FILTER_MANAGER = DWORD($8000000B);\r\n {$EXTERNALSYM IO_REPARSE_TAG_FILTER_MANAGER}\r\n IO_COMPLETION_MODIFY_STATE = $0002;\r\n {$EXTERNALSYM IO_COMPLETION_MODIFY_STATE}\r\n IO_COMPLETION_ALL_ACCESS = DWORD(STANDARD_RIGHTS_REQUIRED or SYNCHRONIZE or $3);\r\n {$EXTERNALSYM IO_COMPLETION_ALL_ACCESS}\r\n DUPLICATE_CLOSE_SOURCE = $00000001;\r\n {$EXTERNALSYM DUPLICATE_CLOSE_SOURCE}\r\n DUPLICATE_SAME_ACCESS = $00000002;\r\n {$EXTERNALSYM DUPLICATE_SAME_ACCESS}\r\n\r\n// line 4763\r\n\r\n//\r\n// File header format.\r\n//\r\n\r\n{$IFNDEF FPC}\r\ntype\r\n PIMAGE_FILE_HEADER = ^IMAGE_FILE_HEADER;\r\n {$EXTERNALSYM PIMAGE_FILE_HEADER}\r\n _IMAGE_FILE_HEADER = record\r\n Machine: WORD;\r\n NumberOfSections: WORD;\r\n TimeDateStamp: DWORD;\r\n PointerToSymbolTable: DWORD;\r\n NumberOfSymbols: DWORD;\r\n SizeOfOptionalHeader: WORD;\r\n Characteristics: WORD;\r\n end;\r\n {$EXTERNALSYM _IMAGE_FILE_HEADER}\r\n IMAGE_FILE_HEADER = _IMAGE_FILE_HEADER;\r\n {$EXTERNALSYM IMAGE_FILE_HEADER}\r\n TImageFileHeader = IMAGE_FILE_HEADER;\r\n PImageFileHeader = PIMAGE_FILE_HEADER;\r\n{$ENDIF ~FPC}\r\n\r\nconst\r\n IMAGE_SIZEOF_FILE_HEADER = 20;\r\n {$EXTERNALSYM IMAGE_SIZEOF_FILE_HEADER}\r\n\r\n IMAGE_FILE_RELOCS_STRIPPED = $0001; // Relocation info stripped from file.\r\n {$EXTERNALSYM IMAGE_FILE_RELOCS_STRIPPED}\r\n IMAGE_FILE_EXECUTABLE_IMAGE = $0002; // File is executable (i.e. no unresolved externel references).\r\n {$EXTERNALSYM IMAGE_FILE_EXECUTABLE_IMAGE}\r\n IMAGE_FILE_LINE_NUMS_STRIPPED = $0004; // Line nunbers stripped from file.\r\n {$EXTERNALSYM IMAGE_FILE_LINE_NUMS_STRIPPED}\r\n IMAGE_FILE_LOCAL_SYMS_STRIPPED = $0008; // Local symbols stripped from file.\r\n {$EXTERNALSYM IMAGE_FILE_LOCAL_SYMS_STRIPPED}\r\n IMAGE_FILE_AGGRESIVE_WS_TRIM = $0010; // Agressively trim working set\r\n {$EXTERNALSYM IMAGE_FILE_AGGRESIVE_WS_TRIM}\r\n IMAGE_FILE_LARGE_ADDRESS_AWARE = $0020; // App can handle >2gb addresses\r\n {$EXTERNALSYM IMAGE_FILE_LARGE_ADDRESS_AWARE}\r\n IMAGE_FILE_BYTES_REVERSED_LO = $0080; // Bytes of machine word are reversed.\r\n {$EXTERNALSYM IMAGE_FILE_BYTES_REVERSED_LO}\r\n IMAGE_FILE_32BIT_MACHINE = $0100; // 32 bit word machine.\r\n {$EXTERNALSYM IMAGE_FILE_32BIT_MACHINE}\r\n IMAGE_FILE_DEBUG_STRIPPED = $0200; // Debugging info stripped from file in .DBG file\r\n {$EXTERNALSYM IMAGE_FILE_DEBUG_STRIPPED}\r\n IMAGE_FILE_REMOVABLE_RUN_FROM_SWAP = $0400; // If Image is on removable media, copy and run from the swap file.\r\n {$EXTERNALSYM IMAGE_FILE_REMOVABLE_RUN_FROM_SWAP}\r\n IMAGE_FILE_NET_RUN_FROM_SWAP = $0800; // If Image is on Net, copy and run from the swap file.\r\n {$EXTERNALSYM IMAGE_FILE_NET_RUN_FROM_SWAP}\r\n IMAGE_FILE_SYSTEM = $1000; // System File.\r\n {$EXTERNALSYM IMAGE_FILE_SYSTEM}\r\n IMAGE_FILE_DLL = $2000; // File is a DLL.\r\n {$EXTERNALSYM IMAGE_FILE_DLL}\r\n IMAGE_FILE_UP_SYSTEM_ONLY = $4000; // File should only be run on a UP machine\r\n {$EXTERNALSYM IMAGE_FILE_UP_SYSTEM_ONLY}\r\n IMAGE_FILE_BYTES_REVERSED_HI = $8000; // Bytes of machine word are reversed.\r\n {$EXTERNALSYM IMAGE_FILE_BYTES_REVERSED_HI}\r\n\r\n IMAGE_FILE_MACHINE_UNKNOWN = 0;\r\n {$EXTERNALSYM IMAGE_FILE_MACHINE_UNKNOWN}\r\n IMAGE_FILE_MACHINE_I386 = $014c; // Intel 386.\r\n {$EXTERNALSYM IMAGE_FILE_MACHINE_I386}\r\n IMAGE_FILE_MACHINE_R3000 = $0162; // MIPS little-endian, 0x160 big-endian\r\n {$EXTERNALSYM IMAGE_FILE_MACHINE_R3000}\r\n IMAGE_FILE_MACHINE_R4000 = $0166; // MIPS little-endian\r\n {$EXTERNALSYM IMAGE_FILE_MACHINE_R4000}\r\n IMAGE_FILE_MACHINE_R10000 = $0168; // MIPS little-endian\r\n {$EXTERNALSYM IMAGE_FILE_MACHINE_R10000}\r\n IMAGE_FILE_MACHINE_WCEMIPSV2 = $0169; // MIPS little-endian WCE v2\r\n {$EXTERNALSYM IMAGE_FILE_MACHINE_WCEMIPSV2}\r\n IMAGE_FILE_MACHINE_ALPHA = $0184; // Alpha_AXP\r\n {$EXTERNALSYM IMAGE_FILE_MACHINE_ALPHA}\r\n IMAGE_FILE_MACHINE_SH3 = $01a2; // SH3 little-endian\r\n {$EXTERNALSYM IMAGE_FILE_MACHINE_SH3}\r\n IMAGE_FILE_MACHINE_SH3DSP = $01a3;\r\n {$EXTERNALSYM IMAGE_FILE_MACHINE_SH3DSP}\r\n IMAGE_FILE_MACHINE_SH3E = $01a4; // SH3E little-endian\r\n {$EXTERNALSYM IMAGE_FILE_MACHINE_SH3E}\r\n IMAGE_FILE_MACHINE_SH4 = $01a6; // SH4 little-endian\r\n {$EXTERNALSYM IMAGE_FILE_MACHINE_SH4}\r\n IMAGE_FILE_MACHINE_SH5 = $01a8; // SH5\r\n {$EXTERNALSYM IMAGE_FILE_MACHINE_SH5}\r\n IMAGE_FILE_MACHINE_ARM = $01c0; // ARM Little-Endian\r\n {$EXTERNALSYM IMAGE_FILE_MACHINE_ARM}\r\n IMAGE_FILE_MACHINE_THUMB = $01c2;\r\n {$EXTERNALSYM IMAGE_FILE_MACHINE_THUMB}\r\n IMAGE_FILE_MACHINE_AM33 = $01d3;\r\n {$EXTERNALSYM IMAGE_FILE_MACHINE_AM33}\r\n IMAGE_FILE_MACHINE_POWERPC = $01F0; // IBM PowerPC Little-Endian\r\n {$EXTERNALSYM IMAGE_FILE_MACHINE_POWERPC}\r\n IMAGE_FILE_MACHINE_POWERPCFP = $01f1;\r\n {$EXTERNALSYM IMAGE_FILE_MACHINE_POWERPCFP}\r\n IMAGE_FILE_MACHINE_IA64 = $0200; // Intel 64\r\n {$EXTERNALSYM IMAGE_FILE_MACHINE_IA64}\r\n IMAGE_FILE_MACHINE_MIPS16 = $0266; // MIPS\r\n {$EXTERNALSYM IMAGE_FILE_MACHINE_MIPS16}\r\n IMAGE_FILE_MACHINE_ALPHA64 = $0284; // ALPHA64\r\n {$EXTERNALSYM IMAGE_FILE_MACHINE_ALPHA64}\r\n IMAGE_FILE_MACHINE_MIPSFPU = $0366; // MIPS\r\n {$EXTERNALSYM IMAGE_FILE_MACHINE_MIPSFPU}\r\n IMAGE_FILE_MACHINE_MIPSFPU16 = $0466; // MIPS\r\n {$EXTERNALSYM IMAGE_FILE_MACHINE_MIPSFPU16}\r\n IMAGE_FILE_MACHINE_AXP64 = IMAGE_FILE_MACHINE_ALPHA64;\r\n {$EXTERNALSYM IMAGE_FILE_MACHINE_AXP64}\r\n IMAGE_FILE_MACHINE_TRICORE = $0520; // Infineon\r\n {$EXTERNALSYM IMAGE_FILE_MACHINE_TRICORE}\r\n IMAGE_FILE_MACHINE_CEF = $0CEF;\r\n {$EXTERNALSYM IMAGE_FILE_MACHINE_CEF}\r\n IMAGE_FILE_MACHINE_EBC = $0EBC; // EFI Byte Code\r\n {$EXTERNALSYM IMAGE_FILE_MACHINE_EBC}\r\n IMAGE_FILE_MACHINE_AMD64 = $8664; // AMD64 (K8)\r\n {$EXTERNALSYM IMAGE_FILE_MACHINE_AMD64}\r\n IMAGE_FILE_MACHINE_M32R = $9041; // M32R little-endian\r\n {$EXTERNALSYM IMAGE_FILE_MACHINE_M32R}\r\n IMAGE_FILE_MACHINE_CEE = $C0EE;\r\n {$EXTERNALSYM IMAGE_FILE_MACHINE_CEE}\r\n\r\n//\r\n// Directory format.\r\n//\r\n\r\nconst\r\n IMAGE_NUMBEROF_DIRECTORY_ENTRIES = 16;\r\n {$EXTERNALSYM IMAGE_NUMBEROF_DIRECTORY_ENTRIES}\r\n\r\n//\r\n// Optional header format.\r\n//\r\n\r\n{$IFNDEF FPC}\r\ntype\r\n PIMAGE_OPTIONAL_HEADER32 = ^IMAGE_OPTIONAL_HEADER32;\r\n {$EXTERNALSYM PIMAGE_OPTIONAL_HEADER32}\r\n\r\n IMAGE_OPTIONAL_HEADER32 = _IMAGE_OPTIONAL_HEADER;\r\n {$EXTERNALSYM IMAGE_OPTIONAL_HEADER32}\r\n TImageOptionalHeader32 = IMAGE_OPTIONAL_HEADER32;\r\n PImageOptionalHeader32 = PIMAGE_OPTIONAL_HEADER32;\r\n\r\n PIMAGE_ROM_OPTIONAL_HEADER = ^IMAGE_ROM_OPTIONAL_HEADER;\r\n {$EXTERNALSYM PIMAGE_ROM_OPTIONAL_HEADER}\r\n _IMAGE_ROM_OPTIONAL_HEADER = record\r\n Magic: Word;\r\n MajorLinkerVersion: Byte;\r\n MinorLinkerVersion: Byte;\r\n SizeOfCode: DWORD;\r\n SizeOfInitializedData: DWORD;\r\n SizeOfUninitializedData: DWORD;\r\n AddressOfEntryPoint: DWORD;\r\n BaseOfCode: DWORD;\r\n BaseOfData: DWORD;\r\n BaseOfBss: DWORD;\r\n GprMask: DWORD;\r\n CprMask: array [0..3] of DWORD;\r\n GpValue: DWORD;\r\n end;\r\n {$EXTERNALSYM _IMAGE_ROM_OPTIONAL_HEADER}\r\n IMAGE_ROM_OPTIONAL_HEADER = _IMAGE_ROM_OPTIONAL_HEADER;\r\n {$EXTERNALSYM IMAGE_ROM_OPTIONAL_HEADER}\r\n TImageRomOptionalHeader = IMAGE_ROM_OPTIONAL_HEADER;\r\n PImageRomOptionalHeader = PIMAGE_ROM_OPTIONAL_HEADER;\r\n\r\n PIMAGE_OPTIONAL_HEADER64 = ^IMAGE_OPTIONAL_HEADER64;\r\n {$EXTERNALSYM PIMAGE_OPTIONAL_HEADER64}\r\n _IMAGE_OPTIONAL_HEADER64 = record\r\n Magic: Word;\r\n MajorLinkerVersion: Byte;\r\n MinorLinkerVersion: Byte;\r\n SizeOfCode: DWORD;\r\n SizeOfInitializedData: DWORD;\r\n SizeOfUninitializedData: DWORD;\r\n AddressOfEntryPoint: DWORD;\r\n BaseOfCode: DWORD;\r\n ImageBase: Int64;\r\n SectionAlignment: DWORD;\r\n FileAlignment: DWORD;\r\n MajorOperatingSystemVersion: Word;\r\n MinorOperatingSystemVersion: Word;\r\n MajorImageVersion: Word;\r\n MinorImageVersion: Word;\r\n MajorSubsystemVersion: Word;\r\n MinorSubsystemVersion: Word;\r\n Win32VersionValue: DWORD;\r\n SizeOfImage: DWORD;\r\n SizeOfHeaders: DWORD;\r\n CheckSum: DWORD;\r\n Subsystem: Word;\r\n DllCharacteristics: Word;\r\n SizeOfStackReserve: Int64;\r\n SizeOfStackCommit: Int64;\r\n SizeOfHeapReserve: Int64;\r\n SizeOfHeapCommit: Int64;\r\n LoaderFlags: DWORD;\r\n NumberOfRvaAndSizes: DWORD;\r\n DataDirectory: array [0..IMAGE_NUMBEROF_DIRECTORY_ENTRIES - 1] of IMAGE_DATA_DIRECTORY;\r\n end;\r\n {$EXTERNALSYM _IMAGE_OPTIONAL_HEADER64}\r\n IMAGE_OPTIONAL_HEADER64 = _IMAGE_OPTIONAL_HEADER64;\r\n {$EXTERNALSYM IMAGE_OPTIONAL_HEADER64}\r\n TImageOptionalHeader64 = IMAGE_OPTIONAL_HEADER64;\r\n PImageOptionalHeader64 = PIMAGE_OPTIONAL_HEADER64;\r\n{$ENDIF ~FPC}\r\n\r\nconst\r\n IMAGE_SIZEOF_ROM_OPTIONAL_HEADER = 56;\r\n {$EXTERNALSYM IMAGE_SIZEOF_ROM_OPTIONAL_HEADER}\r\n IMAGE_SIZEOF_STD_OPTIONAL_HEADER = 28;\r\n {$EXTERNALSYM IMAGE_SIZEOF_STD_OPTIONAL_HEADER}\r\n IMAGE_SIZEOF_NT_OPTIONAL32_HEADER = 224;\r\n {$EXTERNALSYM IMAGE_SIZEOF_NT_OPTIONAL32_HEADER}\r\n IMAGE_SIZEOF_NT_OPTIONAL64_HEADER = 240;\r\n {$EXTERNALSYM IMAGE_SIZEOF_NT_OPTIONAL64_HEADER}\r\n\r\n IMAGE_NT_OPTIONAL_HDR32_MAGIC = $10b;\r\n {$EXTERNALSYM IMAGE_NT_OPTIONAL_HDR32_MAGIC}\r\n IMAGE_NT_OPTIONAL_HDR64_MAGIC = $20b;\r\n {$EXTERNALSYM IMAGE_NT_OPTIONAL_HDR64_MAGIC}\r\n IMAGE_ROM_OPTIONAL_HDR_MAGIC = $107;\r\n {$EXTERNALSYM IMAGE_ROM_OPTIONAL_HDR_MAGIC}\r\n\r\n(*\r\ntype\r\n IMAGE_OPTIONAL_HEADER = IMAGE_OPTIONAL_HEADER32;\r\n {$EXTERNALSYM IMAGE_OPTIONAL_HEADER}\r\n PIMAGE_OPTIONAL_HEADER = PIMAGE_OPTIONAL_HEADER32;\r\n {$EXTERNALSYM PIMAGE_OPTIONAL_HEADER}\r\n*)\r\n\r\nconst\r\n IMAGE_SIZEOF_NT_OPTIONAL_HEADER = IMAGE_SIZEOF_NT_OPTIONAL32_HEADER;\r\n {$EXTERNALSYM IMAGE_SIZEOF_NT_OPTIONAL_HEADER}\r\n IMAGE_NT_OPTIONAL_HDR_MAGIC = IMAGE_NT_OPTIONAL_HDR32_MAGIC;\r\n {$EXTERNALSYM IMAGE_NT_OPTIONAL_HDR_MAGIC}\r\n\r\n{$IFNDEF FPC}\r\ntype\r\n PIMAGE_NT_HEADERS64 = ^IMAGE_NT_HEADERS64;\r\n {$EXTERNALSYM PIMAGE_NT_HEADERS64}\r\n _IMAGE_NT_HEADERS64 = record\r\n Signature: DWORD;\r\n FileHeader: IMAGE_FILE_HEADER;\r\n OptionalHeader: IMAGE_OPTIONAL_HEADER64;\r\n end;\r\n {$EXTERNALSYM _IMAGE_NT_HEADERS64}\r\n IMAGE_NT_HEADERS64 = _IMAGE_NT_HEADERS64;\r\n {$EXTERNALSYM IMAGE_NT_HEADERS64}\r\n TImageNtHeaders64 = IMAGE_NT_HEADERS64;\r\n PImageNtHeaders64 = PIMAGE_NT_HEADERS64;\r\n\r\n PIMAGE_NT_HEADERS32 = ^IMAGE_NT_HEADERS32;\r\n {$EXTERNALSYM PIMAGE_NT_HEADERS32}\r\n _IMAGE_NT_HEADERS = record\r\n Signature: DWORD;\r\n FileHeader: IMAGE_FILE_HEADER;\r\n OptionalHeader: IMAGE_OPTIONAL_HEADER32;\r\n end;\r\n {$EXTERNALSYM _IMAGE_NT_HEADERS}\r\n IMAGE_NT_HEADERS32 = _IMAGE_NT_HEADERS;\r\n {$EXTERNALSYM IMAGE_NT_HEADERS32}\r\n TImageNtHeaders32 = IMAGE_NT_HEADERS32;\r\n PImageNtHeaders32 = PIMAGE_NT_HEADERS32;\r\n{$ENDIF ~FPC}\r\n\r\n// Subsystem Values\r\n\r\nconst\r\n IMAGE_SUBSYSTEM_UNKNOWN = 0; // Unknown subsystem.\r\n {$EXTERNALSYM IMAGE_SUBSYSTEM_UNKNOWN}\r\n IMAGE_SUBSYSTEM_NATIVE = 1; // Image doesn't require a subsystem.\r\n {$EXTERNALSYM IMAGE_SUBSYSTEM_NATIVE}\r\n IMAGE_SUBSYSTEM_WINDOWS_GUI = 2; // Image runs in the Windows GUI subsystem.\r\n {$EXTERNALSYM IMAGE_SUBSYSTEM_WINDOWS_GUI}\r\n IMAGE_SUBSYSTEM_WINDOWS_CUI = 3; // Image runs in the Windows character subsystem.\r\n {$EXTERNALSYM IMAGE_SUBSYSTEM_WINDOWS_CUI}\r\n IMAGE_SUBSYSTEM_OS2_CUI = 5; // image runs in the OS/2 character subsystem.\r\n {$EXTERNALSYM IMAGE_SUBSYSTEM_OS2_CUI}\r\n IMAGE_SUBSYSTEM_POSIX_CUI = 7; // image runs in the Posix character subsystem.\r\n {$EXTERNALSYM IMAGE_SUBSYSTEM_POSIX_CUI}\r\n IMAGE_SUBSYSTEM_NATIVE_WINDOWS = 8; // image is a native Win9x driver.\r\n {$EXTERNALSYM IMAGE_SUBSYSTEM_NATIVE_WINDOWS}\r\n IMAGE_SUBSYSTEM_WINDOWS_CE_GUI = 9; // Image runs in the Windows CE subsystem.\r\n {$EXTERNALSYM IMAGE_SUBSYSTEM_WINDOWS_CE_GUI}\r\n IMAGE_SUBSYSTEM_EFI_APPLICATION = 10;\r\n {$EXTERNALSYM IMAGE_SUBSYSTEM_EFI_APPLICATION}\r\n IMAGE_SUBSYSTEM_EFI_BOOT_SERVICE_DRIVER = 11;\r\n {$EXTERNALSYM IMAGE_SUBSYSTEM_EFI_BOOT_SERVICE_DRIVER}\r\n IMAGE_SUBSYSTEM_EFI_RUNTIME_DRIVER = 12;\r\n {$EXTERNALSYM IMAGE_SUBSYSTEM_EFI_RUNTIME_DRIVER}\r\n IMAGE_SUBSYSTEM_EFI_ROM = 13;\r\n {$EXTERNALSYM IMAGE_SUBSYSTEM_EFI_ROM}\r\n IMAGE_SUBSYSTEM_XBOX = 14;\r\n {$EXTERNALSYM IMAGE_SUBSYSTEM_XBOX}\r\n\r\n// DllCharacteristics Entries\r\n\r\n// IMAGE_LIBRARY_PROCESS_INIT 0x0001 // Reserved.\r\n// IMAGE_LIBRARY_PROCESS_TERM 0x0002 // Reserved.\r\n// IMAGE_LIBRARY_THREAD_INIT 0x0004 // Reserved.\r\n// IMAGE_LIBRARY_THREAD_TERM 0x0008 // Reserved.\r\n IMAGE_DLLCHARACTERISTICS_NO_ISOLATION = $0200; // Image understands isolation and doesn't want it\r\n {$EXTERNALSYM IMAGE_DLLCHARACTERISTICS_NO_ISOLATION}\r\n IMAGE_DLLCHARACTERISTICS_NO_SEH = $0400; // Image does not use SEH. No SE handler may reside in this image\r\n {$EXTERNALSYM IMAGE_DLLCHARACTERISTICS_NO_SEH}\r\n IMAGE_DLLCHARACTERISTICS_NO_BIND = $0800; // Do not bind this image.\r\n {$EXTERNALSYM IMAGE_DLLCHARACTERISTICS_NO_BIND}\r\n\r\n// 0x1000 // Reserved.\r\n\r\n IMAGE_DLLCHARACTERISTICS_WDM_DRIVER = $2000; // Driver uses WDM model\r\n {$EXTERNALSYM IMAGE_DLLCHARACTERISTICS_WDM_DRIVER}\r\n\r\n// 0x4000 // Reserved.\r\n\r\n IMAGE_DLLCHARACTERISTICS_TERMINAL_SERVER_AWARE = $8000;\r\n {$EXTERNALSYM IMAGE_DLLCHARACTERISTICS_TERMINAL_SERVER_AWARE}\r\n\r\n// Directory Entries\r\n\r\n IMAGE_DIRECTORY_ENTRY_EXPORT = 0; // Export Directory\r\n {$EXTERNALSYM IMAGE_DIRECTORY_ENTRY_EXPORT}\r\n IMAGE_DIRECTORY_ENTRY_IMPORT = 1; // Import Directory\r\n {$EXTERNALSYM IMAGE_DIRECTORY_ENTRY_IMPORT}\r\n IMAGE_DIRECTORY_ENTRY_RESOURCE = 2; // Resource Directory\r\n {$EXTERNALSYM IMAGE_DIRECTORY_ENTRY_RESOURCE}\r\n IMAGE_DIRECTORY_ENTRY_EXCEPTION = 3; // Exception Directory\r\n {$EXTERNALSYM IMAGE_DIRECTORY_ENTRY_EXCEPTION}\r\n IMAGE_DIRECTORY_ENTRY_SECURITY = 4; // Security Directory\r\n {$EXTERNALSYM IMAGE_DIRECTORY_ENTRY_SECURITY}\r\n IMAGE_DIRECTORY_ENTRY_BASERELOC = 5; // Base Relocation Table\r\n {$EXTERNALSYM IMAGE_DIRECTORY_ENTRY_BASERELOC}\r\n IMAGE_DIRECTORY_ENTRY_DEBUG = 6; // Debug Directory\r\n {$EXTERNALSYM IMAGE_DIRECTORY_ENTRY_DEBUG}\r\n\r\n// IMAGE_DIRECTORY_ENTRY_COPYRIGHT 7 // (X86 usage)\r\n\r\n IMAGE_DIRECTORY_ENTRY_ARCHITECTURE = 7; // Architecture Specific Data\r\n {$EXTERNALSYM IMAGE_DIRECTORY_ENTRY_ARCHITECTURE}\r\n IMAGE_DIRECTORY_ENTRY_GLOBALPTR = 8; // RVA of GP\r\n {$EXTERNALSYM IMAGE_DIRECTORY_ENTRY_GLOBALPTR}\r\n IMAGE_DIRECTORY_ENTRY_TLS = 9; // TLS Directory\r\n {$EXTERNALSYM IMAGE_DIRECTORY_ENTRY_TLS}\r\n IMAGE_DIRECTORY_ENTRY_LOAD_CONFIG = 10; // Load Configuration Directory\r\n {$EXTERNALSYM IMAGE_DIRECTORY_ENTRY_LOAD_CONFIG}\r\n IMAGE_DIRECTORY_ENTRY_BOUND_IMPORT = 11; // Bound Import Directory in headers\r\n {$EXTERNALSYM IMAGE_DIRECTORY_ENTRY_BOUND_IMPORT}\r\n IMAGE_DIRECTORY_ENTRY_IAT = 12; // Import Address Table\r\n {$EXTERNALSYM IMAGE_DIRECTORY_ENTRY_IAT}\r\n IMAGE_DIRECTORY_ENTRY_DELAY_IMPORT = 13; // Delay Load Import Descriptors\r\n {$EXTERNALSYM IMAGE_DIRECTORY_ENTRY_DELAY_IMPORT}\r\n IMAGE_DIRECTORY_ENTRY_COM_DESCRIPTOR = 14; // COM Runtime descriptor\r\n {$EXTERNALSYM IMAGE_DIRECTORY_ENTRY_COM_DESCRIPTOR}\r\n\r\n//\r\n// Non-COFF Object file header\r\n//\r\n\r\ntype\r\n PAnonObjectHeader = ^ANON_OBJECT_HEADER;\r\n ANON_OBJECT_HEADER = record\r\n Sig1: Word; // Must be IMAGE_FILE_MACHINE_UNKNOWN\r\n Sig2: Word; // Must be 0xffff\r\n Version: Word; // >= 1 (implies the CLSID field is present)\r\n Machine: Word;\r\n TimeDateStamp: DWORD;\r\n ClassID: TCLSID; // Used to invoke CoCreateInstance\r\n SizeOfData: DWORD; // Size of data that follows the header\r\n end;\r\n {$EXTERNALSYM ANON_OBJECT_HEADER}\r\n TAnonObjectHeader = ANON_OBJECT_HEADER;\r\n\r\n//\r\n// Section header format.\r\n//\r\n\r\nconst\r\n IMAGE_SIZEOF_SHORT_NAME = 8;\r\n {$EXTERNALSYM IMAGE_SIZEOF_SHORT_NAME}\r\n\r\ntype\r\n PPImageSectionHeader = ^PImageSectionHeader;\r\n\r\n// IMAGE_FIRST_SECTION doesn't need 32/64 versions since the file header is the same either way.\r\n\r\nfunction IMAGE_FIRST_SECTION(NtHeader: PImageNtHeaders): PImageSectionHeader;\r\n{$EXTERNALSYM IMAGE_FIRST_SECTION}\r\n\r\nconst\r\n IMAGE_SIZEOF_SECTION_HEADER = 40;\r\n {$EXTERNALSYM IMAGE_SIZEOF_SECTION_HEADER}\r\n\r\n//\r\n// Section characteristics.\r\n//\r\n// IMAGE_SCN_TYPE_REG 0x00000000 // Reserved.\r\n// IMAGE_SCN_TYPE_DSECT 0x00000001 // Reserved.\r\n// IMAGE_SCN_TYPE_NOLOAD 0x00000002 // Reserved.\r\n// IMAGE_SCN_TYPE_GROUP 0x00000004 // Reserved.\r\n\r\n IMAGE_SCN_TYPE_NO_PAD = $00000008; // Reserved.\r\n {$EXTERNALSYM IMAGE_SCN_TYPE_NO_PAD}\r\n\r\n// IMAGE_SCN_TYPE_COPY 0x00000010 // Reserved.\r\n\r\n IMAGE_SCN_CNT_CODE = $00000020; // Section contains code.\r\n {$EXTERNALSYM IMAGE_SCN_CNT_CODE}\r\n IMAGE_SCN_CNT_INITIALIZED_DATA = $00000040; // Section contains initialized data.\r\n {$EXTERNALSYM IMAGE_SCN_CNT_INITIALIZED_DATA}\r\n IMAGE_SCN_CNT_UNINITIALIZED_DATA = $00000080; // Section contains uninitialized data.\r\n {$EXTERNALSYM IMAGE_SCN_CNT_UNINITIALIZED_DATA}\r\n\r\n IMAGE_SCN_LNK_OTHER = $00000100; // Reserved.\r\n {$EXTERNALSYM IMAGE_SCN_LNK_OTHER}\r\n IMAGE_SCN_LNK_INFO = $00000200; // Section contains comments or some other type of information.\r\n {$EXTERNALSYM IMAGE_SCN_LNK_INFO}\r\n\r\n// IMAGE_SCN_TYPE_OVER 0x00000400 // Reserved.\r\n\r\n IMAGE_SCN_LNK_REMOVE = $00000800; // Section contents will not become part of image.\r\n {$EXTERNALSYM IMAGE_SCN_LNK_REMOVE}\r\n IMAGE_SCN_LNK_COMDAT = $00001000; // Section contents comdat.\r\n {$EXTERNALSYM IMAGE_SCN_LNK_COMDAT}\r\n\r\n// 0x00002000 // Reserved.\r\n// IMAGE_SCN_MEM_PROTECTED - Obsolete 0x00004000\r\n\r\n IMAGE_SCN_NO_DEFER_SPEC_EXC = $00004000; // Reset speculative exceptions handling bits in the TLB entries for this section.\r\n {$EXTERNALSYM IMAGE_SCN_NO_DEFER_SPEC_EXC}\r\n IMAGE_SCN_GPREL = $00008000; // Section content can be accessed relative to GP\r\n {$EXTERNALSYM IMAGE_SCN_GPREL}\r\n IMAGE_SCN_MEM_FARDATA = $00008000;\r\n {$EXTERNALSYM IMAGE_SCN_MEM_FARDATA}\r\n\r\n// IMAGE_SCN_MEM_SYSHEAP - Obsolete 0x00010000\r\n\r\n IMAGE_SCN_MEM_PURGEABLE = $00020000;\r\n {$EXTERNALSYM IMAGE_SCN_MEM_PURGEABLE}\r\n IMAGE_SCN_MEM_16BIT = $00020000;\r\n {$EXTERNALSYM IMAGE_SCN_MEM_16BIT}\r\n IMAGE_SCN_MEM_LOCKED = $00040000;\r\n {$EXTERNALSYM IMAGE_SCN_MEM_LOCKED}\r\n IMAGE_SCN_MEM_PRELOAD = $00080000;\r\n {$EXTERNALSYM IMAGE_SCN_MEM_PRELOAD}\r\n\r\n IMAGE_SCN_ALIGN_1BYTES = $00100000;\r\n {$EXTERNALSYM IMAGE_SCN_ALIGN_1BYTES}\r\n IMAGE_SCN_ALIGN_2BYTES = $00200000;\r\n {$EXTERNALSYM IMAGE_SCN_ALIGN_2BYTES}\r\n IMAGE_SCN_ALIGN_4BYTES = $00300000;\r\n {$EXTERNALSYM IMAGE_SCN_ALIGN_4BYTES}\r\n IMAGE_SCN_ALIGN_8BYTES = $00400000;\r\n {$EXTERNALSYM IMAGE_SCN_ALIGN_8BYTES}\r\n IMAGE_SCN_ALIGN_16BYTES = $00500000; // Default alignment if no others are specified.\r\n {$EXTERNALSYM IMAGE_SCN_ALIGN_16BYTES}\r\n IMAGE_SCN_ALIGN_32BYTES = $00600000;\r\n {$EXTERNALSYM IMAGE_SCN_ALIGN_32BYTES}\r\n IMAGE_SCN_ALIGN_64BYTES = $00700000;\r\n {$EXTERNALSYM IMAGE_SCN_ALIGN_64BYTES}\r\n IMAGE_SCN_ALIGN_128BYTES = $00800000;\r\n {$EXTERNALSYM IMAGE_SCN_ALIGN_128BYTES}\r\n IMAGE_SCN_ALIGN_256BYTES = $00900000;\r\n {$EXTERNALSYM IMAGE_SCN_ALIGN_256BYTES}\r\n IMAGE_SCN_ALIGN_512BYTES = $00A00000;\r\n {$EXTERNALSYM IMAGE_SCN_ALIGN_512BYTES}\r\n IMAGE_SCN_ALIGN_1024BYTES = $00B00000;\r\n {$EXTERNALSYM IMAGE_SCN_ALIGN_1024BYTES}\r\n IMAGE_SCN_ALIGN_2048BYTES = $00C00000;\r\n {$EXTERNALSYM IMAGE_SCN_ALIGN_2048BYTES}\r\n IMAGE_SCN_ALIGN_4096BYTES = $00D00000;\r\n {$EXTERNALSYM IMAGE_SCN_ALIGN_4096BYTES}\r\n IMAGE_SCN_ALIGN_8192BYTES = $00E00000;\r\n {$EXTERNALSYM IMAGE_SCN_ALIGN_8192BYTES}\r\n\r\n// Unused 0x00F00000\r\n\r\n IMAGE_SCN_ALIGN_MASK = $00F00000;\r\n {$EXTERNALSYM IMAGE_SCN_ALIGN_MASK}\r\n\r\n IMAGE_SCN_LNK_NRELOC_OVFL = $01000000; // Section contains extended relocations.\r\n {$EXTERNALSYM IMAGE_SCN_LNK_NRELOC_OVFL}\r\n IMAGE_SCN_MEM_DISCARDABLE = $02000000; // Section can be discarded.\r\n {$EXTERNALSYM IMAGE_SCN_MEM_DISCARDABLE}\r\n IMAGE_SCN_MEM_NOT_CACHED = $04000000; // Section is not cachable.\r\n {$EXTERNALSYM IMAGE_SCN_MEM_NOT_CACHED}\r\n IMAGE_SCN_MEM_NOT_PAGED = $08000000; // Section is not pageable.\r\n {$EXTERNALSYM IMAGE_SCN_MEM_NOT_PAGED}\r\n IMAGE_SCN_MEM_SHARED = $10000000; // Section is shareable.\r\n {$EXTERNALSYM IMAGE_SCN_MEM_SHARED}\r\n IMAGE_SCN_MEM_EXECUTE = $20000000; // Section is executable.\r\n {$EXTERNALSYM IMAGE_SCN_MEM_EXECUTE}\r\n IMAGE_SCN_MEM_READ = $40000000; // Section is readable.\r\n {$EXTERNALSYM IMAGE_SCN_MEM_READ}\r\n IMAGE_SCN_MEM_WRITE = DWORD($80000000); // Section is writeable.\r\n {$EXTERNALSYM IMAGE_SCN_MEM_WRITE}\r\n\r\n// line 6232\r\n\r\n//\r\n// Line number format.\r\n//\r\n\r\ntype\r\n TImgLineNoType = record\r\n case Integer of\r\n 0: (SymbolTableIndex: DWORD); // Symbol table index of function name if Linenumber is 0.\r\n 1: (VirtualAddress: DWORD); // Virtual address of line number.\r\n end;\r\n\r\n PIMAGE_LINENUMBER = ^IMAGE_LINENUMBER;\r\n {$EXTERNALSYM PIMAGE_LINENUMBER}\r\n _IMAGE_LINENUMBER = record\r\n Type_: TImgLineNoType;\r\n Linenumber: WORD; // Line number.\r\n end;\r\n {$EXTERNALSYM _IMAGE_LINENUMBER}\r\n IMAGE_LINENUMBER = _IMAGE_LINENUMBER;\r\n {$EXTERNALSYM IMAGE_LINENUMBER}\r\n TImageLineNumber = IMAGE_LINENUMBER;\r\n PImageLineNumber = PIMAGE_LINENUMBER;\r\n\r\nconst\r\n IMAGE_SIZEOF_LINENUMBER = 6;\r\n {$EXTERNALSYM IMAGE_SIZEOF_LINENUMBER}\r\n\r\n// #include \"poppack.h\" // Back to 4 byte packing\r\n\r\n//\r\n// Based relocation format.\r\n//\r\n\r\ntype\r\n PIMAGE_BASE_RELOCATION = ^IMAGE_BASE_RELOCATION;\r\n {$EXTERNALSYM PIMAGE_BASE_RELOCATION}\r\n _IMAGE_BASE_RELOCATION = record\r\n VirtualAddress: DWORD;\r\n SizeOfBlock: DWORD;\r\n // WORD TypeOffset[1];\r\n end;\r\n {$EXTERNALSYM _IMAGE_BASE_RELOCATION}\r\n IMAGE_BASE_RELOCATION = _IMAGE_BASE_RELOCATION;\r\n {$EXTERNALSYM IMAGE_BASE_RELOCATION}\r\n TImageBaseRelocation = IMAGE_BASE_RELOCATION;\r\n PImageBaseRelocation = PIMAGE_BASE_RELOCATION;\r\n\r\nconst\r\n IMAGE_SIZEOF_BASE_RELOCATION = 8;\r\n {$EXTERNALSYM IMAGE_SIZEOF_BASE_RELOCATION}\r\n\r\n//\r\n// Based relocation types.\r\n//\r\n\r\n IMAGE_REL_BASED_ABSOLUTE = 0;\r\n {$EXTERNALSYM IMAGE_REL_BASED_ABSOLUTE}\r\n IMAGE_REL_BASED_HIGH = 1;\r\n {$EXTERNALSYM IMAGE_REL_BASED_HIGH}\r\n IMAGE_REL_BASED_LOW = 2;\r\n {$EXTERNALSYM IMAGE_REL_BASED_LOW}\r\n IMAGE_REL_BASED_HIGHLOW = 3;\r\n {$EXTERNALSYM IMAGE_REL_BASED_HIGHLOW}\r\n IMAGE_REL_BASED_HIGHADJ = 4;\r\n {$EXTERNALSYM IMAGE_REL_BASED_HIGHADJ}\r\n IMAGE_REL_BASED_MIPS_JMPADDR = 5;\r\n {$EXTERNALSYM IMAGE_REL_BASED_MIPS_JMPADDR}\r\n\r\n IMAGE_REL_BASED_MIPS_JMPADDR16 = 9;\r\n {$EXTERNALSYM IMAGE_REL_BASED_MIPS_JMPADDR16}\r\n IMAGE_REL_BASED_IA64_IMM64 = 9;\r\n {$EXTERNALSYM IMAGE_REL_BASED_IA64_IMM64}\r\n IMAGE_REL_BASED_DIR64 = 10;\r\n {$EXTERNALSYM IMAGE_REL_BASED_DIR64}\r\n\r\n//\r\n// Archive format.\r\n//\r\n\r\n IMAGE_ARCHIVE_START_SIZE = 8;\r\n {$EXTERNALSYM IMAGE_ARCHIVE_START_SIZE}\r\n IMAGE_ARCHIVE_START = '!'#10;\r\n {$EXTERNALSYM IMAGE_ARCHIVE_START}\r\n IMAGE_ARCHIVE_END = '`'#10;\r\n {$EXTERNALSYM IMAGE_ARCHIVE_END}\r\n IMAGE_ARCHIVE_PAD = #10;\r\n {$EXTERNALSYM IMAGE_ARCHIVE_PAD}\r\n IMAGE_ARCHIVE_LINKER_MEMBER = '/ ';\r\n {$EXTERNALSYM IMAGE_ARCHIVE_LINKER_MEMBER}\r\n IMAGE_ARCHIVE_LONGNAMES_MEMBER = '// ';\r\n {$EXTERNALSYM IMAGE_ARCHIVE_LONGNAMES_MEMBER}\r\n\r\ntype\r\n PIMAGE_ARCHIVE_MEMBER_HEADER = ^IMAGE_ARCHIVE_MEMBER_HEADER;\r\n {$EXTERNALSYM PIMAGE_ARCHIVE_MEMBER_HEADER}\r\n _IMAGE_ARCHIVE_MEMBER_HEADER = record\r\n Name: array [0..15] of Byte; // File member name - `/' terminated.\r\n Date: array [0..11] of Byte; // File member date - decimal.\r\n UserID: array [0..5] of Byte; // File member user id - decimal.\r\n GroupID: array [0..5] of Byte; // File member group id - decimal.\r\n Mode: array [0..7] of Byte; // File member mode - octal.\r\n Size: array [0..9] of Byte; // File member size - decimal.\r\n EndHeader: array [0..1] of Byte; // String to end header.\r\n end;\r\n {$EXTERNALSYM _IMAGE_ARCHIVE_MEMBER_HEADER}\r\n IMAGE_ARCHIVE_MEMBER_HEADER = _IMAGE_ARCHIVE_MEMBER_HEADER;\r\n {$EXTERNALSYM IMAGE_ARCHIVE_MEMBER_HEADER}\r\n TImageArchiveMemberHeader = IMAGE_ARCHIVE_MEMBER_HEADER;\r\n PImageArchiveMemberHeader = PIMAGE_ARCHIVE_MEMBER_HEADER;\r\n\r\nconst\r\n IMAGE_SIZEOF_ARCHIVE_MEMBER_HDR = 60;\r\n {$EXTERNALSYM IMAGE_SIZEOF_ARCHIVE_MEMBER_HDR}\r\n\r\n// line 6346\r\n\r\n//\r\n// DLL support.\r\n//\r\n\r\n//\r\n// Export Format\r\n//\r\n\r\ntype\r\n PIMAGE_EXPORT_DIRECTORY = ^IMAGE_EXPORT_DIRECTORY;\r\n {$EXTERNALSYM PIMAGE_EXPORT_DIRECTORY}\r\n _IMAGE_EXPORT_DIRECTORY = record\r\n Characteristics: DWORD;\r\n TimeDateStamp: DWORD;\r\n MajorVersion: Word;\r\n MinorVersion: Word;\r\n Name: DWORD;\r\n Base: DWORD;\r\n NumberOfFunctions: DWORD;\r\n NumberOfNames: DWORD;\r\n AddressOfFunctions: DWORD; // RVA from base of image\r\n AddressOfNames: DWORD; // RVA from base of image\r\n AddressOfNameOrdinals: DWORD; // RVA from base of image\r\n end;\r\n {$EXTERNALSYM _IMAGE_EXPORT_DIRECTORY}\r\n IMAGE_EXPORT_DIRECTORY = _IMAGE_EXPORT_DIRECTORY;\r\n {$EXTERNALSYM IMAGE_EXPORT_DIRECTORY}\r\n TImageExportDirectory = IMAGE_EXPORT_DIRECTORY;\r\n PImageExportDirectory = PIMAGE_EXPORT_DIRECTORY;\r\n\r\n//\r\n// Import Format\r\n//\r\n\r\n PIMAGE_IMPORT_BY_NAME = ^IMAGE_IMPORT_BY_NAME;\r\n {$EXTERNALSYM PIMAGE_IMPORT_BY_NAME}\r\n _IMAGE_IMPORT_BY_NAME = record\r\n Hint: Word;\r\n Name: array [0..0] of AnsiChar;\r\n end;\r\n {$EXTERNALSYM _IMAGE_IMPORT_BY_NAME}\r\n IMAGE_IMPORT_BY_NAME = _IMAGE_IMPORT_BY_NAME;\r\n {$EXTERNALSYM IMAGE_IMPORT_BY_NAME}\r\n TImageImportByName = IMAGE_IMPORT_BY_NAME;\r\n PImageImportByName = PIMAGE_IMPORT_BY_NAME;\r\n\r\n// #include \"pshpack8.h\" // Use align 8 for the 64-bit IAT.\r\n\r\n PIMAGE_THUNK_DATA64 = ^IMAGE_THUNK_DATA64;\r\n {$EXTERNALSYM PIMAGE_THUNK_DATA64}\r\n _IMAGE_THUNK_DATA64 = record\r\n case Integer of\r\n 0: (ForwarderString: ULONGLONG); // PBYTE\r\n 1: (Function_: ULONGLONG); // PDWORD\r\n 2: (Ordinal: ULONGLONG);\r\n 3: (AddressOfData: ULONGLONG); // PIMAGE_IMPORT_BY_NAME\r\n end;\r\n {$EXTERNALSYM _IMAGE_THUNK_DATA64}\r\n IMAGE_THUNK_DATA64 = _IMAGE_THUNK_DATA64;\r\n {$EXTERNALSYM IMAGE_THUNK_DATA64}\r\n TImageThunkData64 = IMAGE_THUNK_DATA64;\r\n PImageThunkData64 = PIMAGE_THUNK_DATA64;\r\n\r\n// #include \"poppack.h\" // Back to 4 byte packing\r\n\r\n PIMAGE_THUNK_DATA32 = ^IMAGE_THUNK_DATA32;\r\n {$EXTERNALSYM PIMAGE_THUNK_DATA32}\r\n _IMAGE_THUNK_DATA32 = record\r\n case Integer of\r\n 0: (ForwarderString: DWORD); // PBYTE\r\n 1: (Function_: DWORD); // PDWORD\r\n 2: (Ordinal: DWORD);\r\n 3: (AddressOfData: DWORD); // PIMAGE_IMPORT_BY_NAME\r\n end;\r\n {$EXTERNALSYM _IMAGE_THUNK_DATA32}\r\n IMAGE_THUNK_DATA32 = _IMAGE_THUNK_DATA32;\r\n {$EXTERNALSYM IMAGE_THUNK_DATA32}\r\n TImageThunkData32 = IMAGE_THUNK_DATA32;\r\n PImageThunkData32 = PIMAGE_THUNK_DATA32;\r\n\r\nconst\r\n IMAGE_ORDINAL_FLAG64 = ULONGLONG($8000000000000000);\r\n {$EXTERNALSYM IMAGE_ORDINAL_FLAG64}\r\n IMAGE_ORDINAL_FLAG32 = DWORD($80000000);\r\n {$EXTERNALSYM IMAGE_ORDINAL_FLAG32}\r\n\r\nfunction IMAGE_ORDINAL64(Ordinal: ULONGLONG): ULONGLONG;\r\n{$EXTERNALSYM IMAGE_ORDINAL64}\r\nfunction IMAGE_ORDINAL32(Ordinal: DWORD): DWORD;\r\n{$EXTERNALSYM IMAGE_ORDINAL32}\r\nfunction IMAGE_SNAP_BY_ORDINAL64(Ordinal: ULONGLONG): Boolean;\r\n{$EXTERNALSYM IMAGE_SNAP_BY_ORDINAL64}\r\nfunction IMAGE_SNAP_BY_ORDINAL32(Ordinal: DWORD): Boolean;\r\n{$EXTERNALSYM IMAGE_SNAP_BY_ORDINAL32}\r\n\r\n//\r\n// Thread Local Storage\r\n//\r\n\r\ntype\r\n PIMAGE_TLS_CALLBACK = procedure (DllHandle: Pointer; Reason: DWORD; Reserved: Pointer); stdcall;\r\n {$EXTERNALSYM PIMAGE_TLS_CALLBACK}\r\n TImageTlsCallback = PIMAGE_TLS_CALLBACK;\r\n\r\n PIMAGE_TLS_DIRECTORY64 = ^IMAGE_TLS_DIRECTORY64;\r\n {$EXTERNALSYM PIMAGE_TLS_DIRECTORY64}\r\n _IMAGE_TLS_DIRECTORY64 = record\r\n StartAddressOfRawData: ULONGLONG;\r\n EndAddressOfRawData: ULONGLONG;\r\n AddressOfIndex: ULONGLONG; // PDWORD\r\n AddressOfCallBacks: ULONGLONG; // PIMAGE_TLS_CALLBACK *;\r\n SizeOfZeroFill: DWORD;\r\n Characteristics: DWORD;\r\n end;\r\n {$EXTERNALSYM _IMAGE_TLS_DIRECTORY64}\r\n IMAGE_TLS_DIRECTORY64 = _IMAGE_TLS_DIRECTORY64;\r\n {$EXTERNALSYM IMAGE_TLS_DIRECTORY64}\r\n TImageTlsDirectory64 = IMAGE_TLS_DIRECTORY64;\r\n {$EXTERNALSYM TImageTlsDirectory64}\r\n PImageTlsDirectory64 = PIMAGE_TLS_DIRECTORY64;\r\n {$EXTERNALSYM PImageTlsDirectory64}\r\n\r\n PIMAGE_TLS_DIRECTORY32 = ^IMAGE_TLS_DIRECTORY32;\r\n {$EXTERNALSYM PIMAGE_TLS_DIRECTORY32}\r\n _IMAGE_TLS_DIRECTORY32 = record\r\n StartAddressOfRawData: DWORD;\r\n EndAddressOfRawData: DWORD;\r\n AddressOfIndex: DWORD; // PDWORD\r\n AddressOfCallBacks: DWORD; // PIMAGE_TLS_CALLBACK *\r\n SizeOfZeroFill: DWORD;\r\n Characteristics: DWORD;\r\n end;\r\n {$EXTERNALSYM _IMAGE_TLS_DIRECTORY32}\r\n IMAGE_TLS_DIRECTORY32 = _IMAGE_TLS_DIRECTORY32;\r\n {$EXTERNALSYM IMAGE_TLS_DIRECTORY32}\r\n TImageTlsDirectory32 = IMAGE_TLS_DIRECTORY32;\r\n {$EXTERNALSYM TImageTlsDirectory32}\r\n PImageTlsDirectory32 = PIMAGE_TLS_DIRECTORY32;\r\n {$EXTERNALSYM PImageTlsDirectory32}\r\n \r\nconst\r\n IMAGE_ORDINAL_FLAG = IMAGE_ORDINAL_FLAG32;\r\n {$EXTERNALSYM IMAGE_ORDINAL_FLAG}\r\n\r\nfunction IMAGE_ORDINAL(Ordinal: DWORD): DWORD;\r\n{$EXTERNALSYM IMAGE_ORDINAL}\r\n\r\ntype\r\n IMAGE_THUNK_DATA = IMAGE_THUNK_DATA32;\r\n {$EXTERNALSYM IMAGE_THUNK_DATA}\r\n PIMAGE_THUNK_DATA = PIMAGE_THUNK_DATA32;\r\n {$EXTERNALSYM PIMAGE_THUNK_DATA}\r\n TImageThunkData = TImageThunkData32;\r\n PImageThunkData = PImageThunkData32;\r\n\r\nfunction IMAGE_SNAP_BY_ORDINAL(Ordinal: DWORD): Boolean;\r\n{$EXTERNALSYM IMAGE_SNAP_BY_ORDINAL}\r\n\r\ntype\r\n IMAGE_TLS_DIRECTORY = IMAGE_TLS_DIRECTORY32;\r\n {$EXTERNALSYM IMAGE_TLS_DIRECTORY}\r\n PIMAGE_TLS_DIRECTORY = PIMAGE_TLS_DIRECTORY32;\r\n {$EXTERNALSYM PIMAGE_TLS_DIRECTORY}\r\n TImageTlsDirectory = TImageTlsDirectory32;\r\n {$EXTERNALSYM TImageTlsDirectory}\r\n PImageTlsDirectory = PImageTlsDirectory32;\r\n {$EXTERNALSYM PImageTlsDirectory}\r\n\r\n TIIDUnion = record\r\n case Integer of\r\n 0: (Characteristics: DWORD); // 0 for terminating null import descriptor\r\n 1: (OriginalFirstThunk: DWORD); // RVA to original unbound IAT (PIMAGE_THUNK_DATA)\r\n end;\r\n\r\n PIMAGE_IMPORT_DESCRIPTOR = ^IMAGE_IMPORT_DESCRIPTOR;\r\n {$EXTERNALSYM PIMAGE_IMPORT_DESCRIPTOR}\r\n _IMAGE_IMPORT_DESCRIPTOR = record\r\n Union: TIIDUnion;\r\n TimeDateStamp: DWORD; // 0 if not bound,\r\n // -1 if bound, and real date\\time stamp\r\n // in IMAGE_DIRECTORY_ENTRY_BOUND_IMPORT (new BIND)\r\n // O.W. date/time stamp of DLL bound to (Old BIND)\r\n\r\n ForwarderChain: DWORD; // -1 if no forwarders\r\n Name: DWORD;\r\n FirstThunk: DWORD; // RVA to IAT (if bound this IAT has actual addresses)\r\n end;\r\n {$EXTERNALSYM _IMAGE_IMPORT_DESCRIPTOR}\r\n IMAGE_IMPORT_DESCRIPTOR = _IMAGE_IMPORT_DESCRIPTOR;\r\n {$EXTERNALSYM IMAGE_IMPORT_DESCRIPTOR}\r\n TImageImportDescriptor = IMAGE_IMPORT_DESCRIPTOR;\r\n PImageImportDescriptor = PIMAGE_IMPORT_DESCRIPTOR;\r\n\r\n//\r\n// New format import descriptors pointed to by DataDirectory[ IMAGE_DIRECTORY_ENTRY_BOUND_IMPORT ]\r\n//\r\n\r\ntype\r\n PIMAGE_BOUND_IMPORT_DESCRIPTOR = ^IMAGE_BOUND_IMPORT_DESCRIPTOR;\r\n {$EXTERNALSYM PIMAGE_BOUND_IMPORT_DESCRIPTOR}\r\n _IMAGE_BOUND_IMPORT_DESCRIPTOR = record\r\n TimeDateStamp: DWORD;\r\n OffsetModuleName: Word;\r\n NumberOfModuleForwarderRefs: Word;\r\n // Array of zero or more IMAGE_BOUND_FORWARDER_REF follows\r\n end;\r\n {$EXTERNALSYM _IMAGE_BOUND_IMPORT_DESCRIPTOR}\r\n IMAGE_BOUND_IMPORT_DESCRIPTOR = _IMAGE_BOUND_IMPORT_DESCRIPTOR;\r\n {$EXTERNALSYM IMAGE_BOUND_IMPORT_DESCRIPTOR}\r\n TImageBoundImportDescriptor = IMAGE_BOUND_IMPORT_DESCRIPTOR;\r\n PImageBoundImportDescriptor = PIMAGE_BOUND_IMPORT_DESCRIPTOR;\r\n\r\n PIMAGE_BOUND_FORWARDER_REF = ^IMAGE_BOUND_FORWARDER_REF;\r\n {$EXTERNALSYM PIMAGE_BOUND_FORWARDER_REF}\r\n _IMAGE_BOUND_FORWARDER_REF = record\r\n TimeDateStamp: DWORD;\r\n OffsetModuleName: Word;\r\n Reserved: Word;\r\n end;\r\n {$EXTERNALSYM _IMAGE_BOUND_FORWARDER_REF}\r\n IMAGE_BOUND_FORWARDER_REF = _IMAGE_BOUND_FORWARDER_REF;\r\n {$EXTERNALSYM IMAGE_BOUND_FORWARDER_REF}\r\n TImageBoundForwarderRef = IMAGE_BOUND_FORWARDER_REF;\r\n PImageBoundForwarderRef = PIMAGE_BOUND_FORWARDER_REF;\r\n\r\n//\r\n// Resource Format.\r\n//\r\n\r\n//\r\n// Resource directory consists of two counts, following by a variable length\r\n// array of directory entries. The first count is the number of entries at\r\n// beginning of the array that have actual names associated with each entry.\r\n// The entries are in ascending order, case insensitive strings. The second\r\n// count is the number of entries that immediately follow the named entries.\r\n// This second count identifies the number of entries that have 16-bit integer\r\n// Ids as their name. These entries are also sorted in ascending order.\r\n//\r\n// This structure allows fast lookup by either name or number, but for any\r\n// given resource entry only one form of lookup is supported, not both.\r\n// This is consistant with the syntax of the .RC file and the .RES file.\r\n//\r\n\r\n PIMAGE_RESOURCE_DIRECTORY = ^IMAGE_RESOURCE_DIRECTORY;\r\n {$EXTERNALSYM PIMAGE_RESOURCE_DIRECTORY}\r\n _IMAGE_RESOURCE_DIRECTORY = record\r\n Characteristics: DWORD;\r\n TimeDateStamp: DWORD;\r\n MajorVersion: Word;\r\n MinorVersion: Word;\r\n NumberOfNamedEntries: Word;\r\n NumberOfIdEntries: Word;\r\n // IMAGE_RESOURCE_DIRECTORY_ENTRY DirectoryEntries[];\r\n end;\r\n {$EXTERNALSYM _IMAGE_RESOURCE_DIRECTORY}\r\n IMAGE_RESOURCE_DIRECTORY = _IMAGE_RESOURCE_DIRECTORY;\r\n {$EXTERNALSYM IMAGE_RESOURCE_DIRECTORY}\r\n TImageResourceDirectory = IMAGE_RESOURCE_DIRECTORY;\r\n PImageResourceDirectory = PIMAGE_RESOURCE_DIRECTORY;\r\n\r\nconst\r\n IMAGE_RESOURCE_NAME_IS_STRING = DWORD($80000000);\r\n {$EXTERNALSYM IMAGE_RESOURCE_NAME_IS_STRING}\r\n IMAGE_RESOURCE_DATA_IS_DIRECTORY = DWORD($80000000);\r\n {$EXTERNALSYM IMAGE_RESOURCE_DATA_IS_DIRECTORY}\r\n\r\n//\r\n// Each directory contains the 32-bit Name of the entry and an offset,\r\n// relative to the beginning of the resource directory of the data associated\r\n// with this directory entry. If the name of the entry is an actual text\r\n// string instead of an integer Id, then the high order bit of the name field\r\n// is set to one and the low order 31-bits are an offset, relative to the\r\n// beginning of the resource directory of the string, which is of type\r\n// IMAGE_RESOURCE_DIRECTORY_STRING. Otherwise the high bit is clear and the\r\n// low-order 16-bits are the integer Id that identify this resource directory\r\n// entry. If the directory entry is yet another resource directory (i.e. a\r\n// subdirectory), then the high order bit of the offset field will be\r\n// set to indicate this. Otherwise the high bit is clear and the offset\r\n// field points to a resource data entry.\r\n//\r\n\r\ntype\r\n PIMAGE_RESOURCE_DIRECTORY_ENTRY = ^IMAGE_RESOURCE_DIRECTORY_ENTRY;\r\n {$EXTERNALSYM PIMAGE_RESOURCE_DIRECTORY_ENTRY}\r\n _IMAGE_RESOURCE_DIRECTORY_ENTRY = record\r\n case Integer of\r\n 0: (\r\n // DWORD NameOffset:31;\r\n // DWORD NameIsString:1;\r\n NameOffset: DWORD;\r\n OffsetToData: DWORD\r\n );\r\n 1: (\r\n Name: DWORD;\r\n // DWORD OffsetToDirectory:31;\r\n // DWORD DataIsDirectory:1;\r\n OffsetToDirectory: DWORD;\r\n );\r\n 2: (\r\n Id: WORD;\r\n );\r\n end;\r\n {$EXTERNALSYM _IMAGE_RESOURCE_DIRECTORY_ENTRY}\r\n IMAGE_RESOURCE_DIRECTORY_ENTRY = _IMAGE_RESOURCE_DIRECTORY_ENTRY;\r\n {$EXTERNALSYM IMAGE_RESOURCE_DIRECTORY_ENTRY}\r\n TImageResourceDirectoryEntry = IMAGE_RESOURCE_DIRECTORY_ENTRY;\r\n PImageResourceDirectoryEntry = PIMAGE_RESOURCE_DIRECTORY_ENTRY;\r\n\r\n//\r\n// For resource directory entries that have actual string names, the Name\r\n// field of the directory entry points to an object of the following type.\r\n// All of these string objects are stored together after the last resource\r\n// directory entry and before the first resource data object. This minimizes\r\n// the impact of these variable length objects on the alignment of the fixed\r\n// size directory entry objects.\r\n//\r\n\r\ntype\r\n PIMAGE_RESOURCE_DIRECTORY_STRING = ^IMAGE_RESOURCE_DIRECTORY_STRING;\r\n {$EXTERNALSYM PIMAGE_RESOURCE_DIRECTORY_STRING}\r\n _IMAGE_RESOURCE_DIRECTORY_STRING = record\r\n Length: Word;\r\n NameString: array [0..0] of AnsiCHAR;\r\n end;\r\n {$EXTERNALSYM _IMAGE_RESOURCE_DIRECTORY_STRING}\r\n IMAGE_RESOURCE_DIRECTORY_STRING = _IMAGE_RESOURCE_DIRECTORY_STRING;\r\n {$EXTERNALSYM IMAGE_RESOURCE_DIRECTORY_STRING}\r\n TImageResourceDirectoryString = IMAGE_RESOURCE_DIRECTORY_STRING;\r\n PImageResourceDirectoryString = PIMAGE_RESOURCE_DIRECTORY_STRING;\r\n\r\n PIMAGE_RESOURCE_DIR_STRING_U = ^IMAGE_RESOURCE_DIR_STRING_U;\r\n {$EXTERNALSYM PIMAGE_RESOURCE_DIR_STRING_U}\r\n _IMAGE_RESOURCE_DIR_STRING_U = record\r\n Length: Word;\r\n NameString: array [0..0] of WCHAR;\r\n end;\r\n {$EXTERNALSYM _IMAGE_RESOURCE_DIR_STRING_U}\r\n IMAGE_RESOURCE_DIR_STRING_U = _IMAGE_RESOURCE_DIR_STRING_U;\r\n {$EXTERNALSYM IMAGE_RESOURCE_DIR_STRING_U}\r\n TImageResourceDirStringU = IMAGE_RESOURCE_DIR_STRING_U;\r\n PImageResourceDirStringU = PIMAGE_RESOURCE_DIR_STRING_U;\r\n\r\n//\r\n// Each resource data entry describes a leaf node in the resource directory\r\n// tree. It contains an offset, relative to the beginning of the resource\r\n// directory of the data for the resource, a size field that gives the number\r\n// of bytes of data at that offset, a CodePage that should be used when\r\n// decoding code point values within the resource data. Typically for new\r\n// applications the code page would be the unicode code page.\r\n//\r\n\r\n PIMAGE_RESOURCE_DATA_ENTRY = ^IMAGE_RESOURCE_DATA_ENTRY;\r\n {$EXTERNALSYM PIMAGE_RESOURCE_DATA_ENTRY}\r\n _IMAGE_RESOURCE_DATA_ENTRY = record\r\n OffsetToData: DWORD;\r\n Size: DWORD;\r\n CodePage: DWORD;\r\n Reserved: DWORD;\r\n end;\r\n {$EXTERNALSYM _IMAGE_RESOURCE_DATA_ENTRY}\r\n IMAGE_RESOURCE_DATA_ENTRY = _IMAGE_RESOURCE_DATA_ENTRY;\r\n {$EXTERNALSYM IMAGE_RESOURCE_DATA_ENTRY}\r\n TImageResourceDataEntry = IMAGE_RESOURCE_DATA_ENTRY;\r\n PImageResourceDataEntry = PIMAGE_RESOURCE_DATA_ENTRY;\r\n \r\n//\r\n// Load Configuration Directory Entry\r\n//\r\n\r\n{$IFNDEF FPC}\r\ntype\r\n PIMAGE_LOAD_CONFIG_DIRECTORY32 = ^IMAGE_LOAD_CONFIG_DIRECTORY32;\r\n {$EXTERNALSYM PIMAGE_LOAD_CONFIG_DIRECTORY32}\r\n IMAGE_LOAD_CONFIG_DIRECTORY32 = record\r\n Size: DWORD;\r\n TimeDateStamp: DWORD;\r\n MajorVersion: WORD;\r\n MinorVersion: WORD;\r\n GlobalFlagsClear: DWORD;\r\n GlobalFlagsSet: DWORD;\r\n CriticalSectionDefaultTimeout: DWORD;\r\n DeCommitFreeBlockThreshold: DWORD;\r\n DeCommitTotalFreeThreshold: DWORD;\r\n LockPrefixTable: DWORD; // VA\r\n MaximumAllocationSize: DWORD;\r\n VirtualMemoryThreshold: DWORD;\r\n ProcessHeapFlags: DWORD;\r\n ProcessAffinityMask: DWORD;\r\n CSDVersion: WORD;\r\n Reserved1: WORD;\r\n EditList: DWORD; // VA\r\n SecurityCookie: DWORD; // VA\r\n SEHandlerTable: DWORD; // VA\r\n SEHandlerCount: DWORD;\r\n end;\r\n {$EXTERNALSYM IMAGE_LOAD_CONFIG_DIRECTORY32}\r\n TImageLoadConfigDirectory32 = IMAGE_LOAD_CONFIG_DIRECTORY32;\r\n PImageLoadConfigDirectory32 = PIMAGE_LOAD_CONFIG_DIRECTORY32;\r\n\r\n PIMAGE_LOAD_CONFIG_DIRECTORY64 = ^IMAGE_LOAD_CONFIG_DIRECTORY64;\r\n {$EXTERNALSYM PIMAGE_LOAD_CONFIG_DIRECTORY64}\r\n IMAGE_LOAD_CONFIG_DIRECTORY64 = record\r\n Size: DWORD;\r\n TimeDateStamp: DWORD;\r\n MajorVersion: WORD;\r\n MinorVersion: WORD;\r\n GlobalFlagsClear: DWORD;\r\n GlobalFlagsSet: DWORD;\r\n CriticalSectionDefaultTimeout: DWORD;\r\n DeCommitFreeBlockThreshold: ULONGLONG;\r\n DeCommitTotalFreeThreshold: ULONGLONG;\r\n LockPrefixTable: ULONGLONG; // VA\r\n MaximumAllocationSize: ULONGLONG;\r\n VirtualMemoryThreshold: ULONGLONG;\r\n ProcessAffinityMask: ULONGLONG;\r\n ProcessHeapFlags: DWORD;\r\n CSDVersion: WORD;\r\n Reserved1: WORD;\r\n EditList: ULONGLONG; // VA\r\n SecurityCookie: ULONGLONG; // VA\r\n SEHandlerTable: ULONGLONG; // VA\r\n SEHandlerCount: ULONGLONG;\r\n end;\r\n {$EXTERNALSYM IMAGE_LOAD_CONFIG_DIRECTORY64}\r\n TImageLoadConfigDirectory64 = IMAGE_LOAD_CONFIG_DIRECTORY64;\r\n PImageLoadConfigDirectory64 = PIMAGE_LOAD_CONFIG_DIRECTORY64;\r\n\r\n IMAGE_LOAD_CONFIG_DIRECTORY = IMAGE_LOAD_CONFIG_DIRECTORY32;\r\n {$EXTERNALSYM IMAGE_LOAD_CONFIG_DIRECTORY}\r\n PIMAGE_LOAD_CONFIG_DIRECTORY = PIMAGE_LOAD_CONFIG_DIRECTORY32;\r\n {$EXTERNALSYM PIMAGE_LOAD_CONFIG_DIRECTORY}\r\n TImageLoadConfigDirectory = TImageLoadConfigDirectory32;\r\n PImageLoadConfigDirectory = PImageLoadConfigDirectory32;\r\n{$ENDIF ~FPC}\r\n\r\n// line 6802\r\n\r\n//\r\n// Debug Format\r\n//\r\n(*\r\ntype\r\n PIMAGE_DEBUG_DIRECTORY = ^IMAGE_DEBUG_DIRECTORY;\r\n {$EXTERNALSYM PIMAGE_DEBUG_DIRECTORY}\r\n _IMAGE_DEBUG_DIRECTORY = record\r\n Characteristics: DWORD;\r\n TimeDateStamp: DWORD;\r\n MajorVersion: Word;\r\n MinorVersion: Word;\r\n Type_: DWORD;\r\n SizeOfData: DWORD;\r\n AddressOfRawData: DWORD;\r\n PointerToRawData: DWORD;\r\n end;\r\n {$EXTERNALSYM _IMAGE_DEBUG_DIRECTORY}\r\n IMAGE_DEBUG_DIRECTORY = _IMAGE_DEBUG_DIRECTORY;\r\n {$EXTERNALSYM IMAGE_DEBUG_DIRECTORY}\r\n TImageDebugDirectory = IMAGE_DEBUG_DIRECTORY;\r\n PImageDebugDirectory = PIMAGE_DEBUG_DIRECTORY;\r\n\r\nconst\r\n IMAGE_DEBUG_TYPE_UNKNOWN = 0;\r\n {$EXTERNALSYM IMAGE_DEBUG_TYPE_UNKNOWN}\r\n IMAGE_DEBUG_TYPE_COFF = 1;\r\n {$EXTERNALSYM IMAGE_DEBUG_TYPE_COFF}\r\n IMAGE_DEBUG_TYPE_CODEVIEW = 2;\r\n {$EXTERNALSYM IMAGE_DEBUG_TYPE_CODEVIEW}\r\n IMAGE_DEBUG_TYPE_FPO = 3;\r\n {$EXTERNALSYM IMAGE_DEBUG_TYPE_FPO}\r\n IMAGE_DEBUG_TYPE_MISC = 4;\r\n {$EXTERNALSYM IMAGE_DEBUG_TYPE_MISC}\r\n IMAGE_DEBUG_TYPE_EXCEPTION = 5;\r\n {$EXTERNALSYM IMAGE_DEBUG_TYPE_EXCEPTION}\r\n IMAGE_DEBUG_TYPE_FIXUP = 6;\r\n {$EXTERNALSYM IMAGE_DEBUG_TYPE_FIXUP}\r\n IMAGE_DEBUG_TYPE_OMAP_TO_SRC = 7;\r\n {$EXTERNALSYM IMAGE_DEBUG_TYPE_OMAP_TO_SRC}\r\n IMAGE_DEBUG_TYPE_OMAP_FROM_SRC = 8;\r\n {$EXTERNALSYM IMAGE_DEBUG_TYPE_OMAP_FROM_SRC}\r\n IMAGE_DEBUG_TYPE_BORLAND = 9;\r\n {$EXTERNALSYM IMAGE_DEBUG_TYPE_BORLAND}\r\n IMAGE_DEBUG_TYPE_RESERVED10 = 10;\r\n {$EXTERNALSYM IMAGE_DEBUG_TYPE_RESERVED10}\r\n IMAGE_DEBUG_TYPE_CLSID = 11;\r\n {$EXTERNALSYM IMAGE_DEBUG_TYPE_CLSID}\r\n*)\r\n\r\n{$IFNDEF FPC}\r\ntype\r\n PIMAGE_COFF_SYMBOLS_HEADER = ^IMAGE_COFF_SYMBOLS_HEADER;\r\n {$EXTERNALSYM PIMAGE_COFF_SYMBOLS_HEADER}\r\n _IMAGE_COFF_SYMBOLS_HEADER = record\r\n NumberOfSymbols: DWORD;\r\n LvaToFirstSymbol: DWORD;\r\n NumberOfLinenumbers: DWORD;\r\n LvaToFirstLinenumber: DWORD;\r\n RvaToFirstByteOfCode: DWORD;\r\n RvaToLastByteOfCode: DWORD;\r\n RvaToFirstByteOfData: DWORD;\r\n RvaToLastByteOfData: DWORD;\r\n end;\r\n {$EXTERNALSYM _IMAGE_COFF_SYMBOLS_HEADER}\r\n IMAGE_COFF_SYMBOLS_HEADER = _IMAGE_COFF_SYMBOLS_HEADER;\r\n {$EXTERNALSYM IMAGE_COFF_SYMBOLS_HEADER}\r\n TImageCoffSymbolsHeader = IMAGE_COFF_SYMBOLS_HEADER;\r\n PImageCoffSymbolsHeader = PIMAGE_COFF_SYMBOLS_HEADER;\r\n{$ENDIF ~FPC}\r\n\r\nconst\r\n FRAME_FPO = 0;\r\n {$EXTERNALSYM FRAME_FPO}\r\n FRAME_TRAP = 1;\r\n {$EXTERNALSYM FRAME_TRAP}\r\n FRAME_TSS = 2;\r\n {$EXTERNALSYM FRAME_TSS}\r\n FRAME_NONFPO = 3;\r\n {$EXTERNALSYM FRAME_NONFPO}\r\n\r\n FPOFLAGS_PROLOG = $00FF; // # bytes in prolog\r\n FPOFLAGS_REGS = $0700; // # regs saved\r\n FPOFLAGS_HAS_SEH = $0800; // TRUE if SEH in func\r\n FPOFLAGS_USE_BP = $1000; // TRUE if EBP has been allocated\r\n FPOFLAGS_RESERVED = $2000; // reserved for future use\r\n FPOFLAGS_FRAME = $C000; // frame type\r\n\r\n{$IFNDEF FPC}\r\ntype\r\n PFPO_DATA = ^FPO_DATA;\r\n {$EXTERNALSYM PFPO_DATA}\r\n _FPO_DATA = record\r\n ulOffStart: DWORD; // offset 1st byte of function code\r\n cbProcSize: DWORD; // # bytes in function\r\n cdwLocals: DWORD; // # bytes in locals/4\r\n cdwParams: WORD; // # bytes in params/4\r\n Flags: WORD;\r\n end;\r\n {$EXTERNALSYM _FPO_DATA}\r\n FPO_DATA = _FPO_DATA;\r\n {$EXTERNALSYM FPO_DATA}\r\n TFpoData = FPO_DATA;\r\n PFpoData = PFPO_DATA;\r\n{$ENDIF ~FPC}\r\n\r\nconst\r\n SIZEOF_RFPO_DATA = 16;\r\n {$EXTERNALSYM SIZEOF_RFPO_DATA}\r\n\r\n IMAGE_DEBUG_MISC_EXENAME = 1;\r\n {$EXTERNALSYM IMAGE_DEBUG_MISC_EXENAME}\r\n\r\ntype\r\n PIMAGE_DEBUG_MISC = ^IMAGE_DEBUG_MISC;\r\n {$EXTERNALSYM PIMAGE_DEBUG_MISC}\r\n _IMAGE_DEBUG_MISC = record\r\n DataType: DWORD; // type of misc data, see defines\r\n Length: DWORD; // total length of record, rounded to four byte multiple.\r\n Unicode: ByteBool; // TRUE if data is unicode string\r\n Reserved: array [0..2] of Byte;\r\n Data: array [0..0] of Byte; // Actual data\r\n end;\r\n {$EXTERNALSYM _IMAGE_DEBUG_MISC}\r\n IMAGE_DEBUG_MISC = _IMAGE_DEBUG_MISC;\r\n {$EXTERNALSYM IMAGE_DEBUG_MISC}\r\n TImageDebugMisc = IMAGE_DEBUG_MISC;\r\n PImageDebugMisc = PIMAGE_DEBUG_MISC;\r\n\r\n//\r\n// Function table extracted from MIPS/ALPHA/IA64 images. Does not contain\r\n// information needed only for runtime support. Just those fields for\r\n// each entry needed by a debugger.\r\n//\r\n\r\n{$IFNDEF FPC}\r\n PIMAGE_FUNCTION_ENTRY = ^IMAGE_FUNCTION_ENTRY;\r\n {$EXTERNALSYM PIMAGE_FUNCTION_ENTRY}\r\n _IMAGE_FUNCTION_ENTRY = record\r\n StartingAddress: DWORD;\r\n EndingAddress: DWORD;\r\n EndOfPrologue: DWORD;\r\n end;\r\n {$EXTERNALSYM _IMAGE_FUNCTION_ENTRY}\r\n IMAGE_FUNCTION_ENTRY = _IMAGE_FUNCTION_ENTRY;\r\n {$EXTERNALSYM IMAGE_FUNCTION_ENTRY}\r\n TImageFunctionEntry = IMAGE_FUNCTION_ENTRY;\r\n PImageFunctionEntry = PIMAGE_FUNCTION_ENTRY;\r\n\r\n PIMAGE_FUNCTION_ENTRY64 = ^IMAGE_FUNCTION_ENTRY64;\r\n {$EXTERNALSYM PIMAGE_FUNCTION_ENTRY64}\r\n _IMAGE_FUNCTION_ENTRY64 = record\r\n StartingAddress: ULONGLONG;\r\n EndingAddress: ULONGLONG;\r\n case Integer of\r\n 0: (EndOfPrologue: ULONGLONG);\r\n 1: (UnwindInfoAddress: ULONGLONG);\r\n end;\r\n {$EXTERNALSYM _IMAGE_FUNCTION_ENTRY64}\r\n IMAGE_FUNCTION_ENTRY64 = _IMAGE_FUNCTION_ENTRY64;\r\n {$EXTERNALSYM IMAGE_FUNCTION_ENTRY64}\r\n TImageFunctionEntry64 = IMAGE_FUNCTION_ENTRY64;\r\n PImageFunctionEntry64 = PIMAGE_FUNCTION_ENTRY64;\r\n\r\n{$ENDIF ~FPC}\r\n\r\n//\r\n// Debugging information can be stripped from an image file and placed\r\n// in a separate .DBG file, whose file name part is the same as the\r\n// image file name part (e.g. symbols for CMD.EXE could be stripped\r\n// and placed in CMD.DBG). This is indicated by the IMAGE_FILE_DEBUG_STRIPPED\r\n// flag in the Characteristics field of the file header. The beginning of\r\n// the .DBG file contains the following structure which captures certain\r\n// information from the image file. This allows a debug to proceed even if\r\n// the original image file is not accessable. This header is followed by\r\n// zero of more IMAGE_SECTION_HEADER structures, followed by zero or more\r\n// IMAGE_DEBUG_DIRECTORY structures. The latter structures and those in\r\n// the image file contain file offsets relative to the beginning of the\r\n// .DBG file.\r\n//\r\n// If symbols have been stripped from an image, the IMAGE_DEBUG_MISC structure\r\n// is left in the image file, but not mapped. This allows a debugger to\r\n// compute the name of the .DBG file, from the name of the image in the\r\n// IMAGE_DEBUG_MISC structure.\r\n//\r\n\r\n PIMAGE_SEPARATE_DEBUG_HEADER = ^IMAGE_SEPARATE_DEBUG_HEADER;\r\n {$EXTERNALSYM PIMAGE_SEPARATE_DEBUG_HEADER}\r\n _IMAGE_SEPARATE_DEBUG_HEADER = record\r\n Signature: Word;\r\n Flags: Word;\r\n Machine: Word;\r\n Characteristics: Word;\r\n TimeDateStamp: DWORD;\r\n CheckSum: DWORD;\r\n ImageBase: DWORD;\r\n SizeOfImage: DWORD;\r\n NumberOfSections: DWORD;\r\n ExportedNamesSize: DWORD;\r\n DebugDirectorySize: DWORD;\r\n SectionAlignment: DWORD;\r\n Reserved: array [0..1] of DWORD;\r\n end;\r\n {$EXTERNALSYM _IMAGE_SEPARATE_DEBUG_HEADER}\r\n IMAGE_SEPARATE_DEBUG_HEADER = _IMAGE_SEPARATE_DEBUG_HEADER;\r\n {$EXTERNALSYM IMAGE_SEPARATE_DEBUG_HEADER}\r\n TImageSeparateDebugHeader = IMAGE_SEPARATE_DEBUG_HEADER;\r\n PImageSeparateDebugHeader = PIMAGE_SEPARATE_DEBUG_HEADER;\r\n\r\n _NON_PAGED_DEBUG_INFO = record\r\n Signature: WORD;\r\n Flags: WORD;\r\n Size: DWORD;\r\n Machine: WORD;\r\n Characteristics: WORD;\r\n TimeDateStamp: DWORD;\r\n CheckSum: DWORD;\r\n SizeOfImage: DWORD;\r\n ImageBase: ULONGLONG;\r\n //DebugDirectorySize\r\n //IMAGE_DEBUG_DIRECTORY\r\n end;\r\n {$EXTERNALSYM _NON_PAGED_DEBUG_INFO}\r\n NON_PAGED_DEBUG_INFO = _NON_PAGED_DEBUG_INFO;\r\n {$EXTERNALSYM NON_PAGED_DEBUG_INFO}\r\n PNON_PAGED_DEBUG_INFO = ^NON_PAGED_DEBUG_INFO;\r\n {$EXTERNALSYM PNON_PAGED_DEBUG_INFO}\r\n\r\nconst\r\n IMAGE_SEPARATE_DEBUG_SIGNATURE = $4944;\r\n {$EXTERNALSYM IMAGE_SEPARATE_DEBUG_SIGNATURE}\r\n NON_PAGED_DEBUG_SIGNATURE = $494E;\r\n {$EXTERNALSYM NON_PAGED_DEBUG_SIGNATURE}\r\n\r\n IMAGE_SEPARATE_DEBUG_FLAGS_MASK = $8000;\r\n {$EXTERNALSYM IMAGE_SEPARATE_DEBUG_FLAGS_MASK}\r\n IMAGE_SEPARATE_DEBUG_MISMATCH = $8000; // when DBG was updated, the old checksum didn't match.\r\n {$EXTERNALSYM IMAGE_SEPARATE_DEBUG_MISMATCH}\r\n\r\n//\r\n// The .arch section is made up of headers, each describing an amask position/value\r\n// pointing to an array of IMAGE_ARCHITECTURE_ENTRY's. Each \"array\" (both the header\r\n// and entry arrays) are terminiated by a quadword of 0xffffffffL.\r\n//\r\n// NOTE: There may be quadwords of 0 sprinkled around and must be skipped.\r\n//\r\n\r\nconst\r\n IAHMASK_VALUE = $00000001; // 1 -> code section depends on mask bit\r\n // 0 -> new instruction depends on mask bit\r\n IAHMASK_MBZ7 = $000000FE; // MBZ\r\n IAHMASK_SHIFT = $0000FF00; // Amask bit in question for this fixup\r\n IAHMASK_MBZ16 = DWORD($FFFF0000); // MBZ\r\n\r\ntype\r\n PIMAGE_ARCHITECTURE_HEADER = ^IMAGE_ARCHITECTURE_HEADER;\r\n {$EXTERNALSYM PIMAGE_ARCHITECTURE_HEADER}\r\n _ImageArchitectureHeader = record\r\n Mask: DWORD;\r\n FirstEntryRVA: DWORD; // RVA into .arch section to array of ARCHITECTURE_ENTRY's\r\n end;\r\n {$EXTERNALSYM _ImageArchitectureHeader}\r\n IMAGE_ARCHITECTURE_HEADER = _ImageArchitectureHeader;\r\n {$EXTERNALSYM IMAGE_ARCHITECTURE_HEADER}\r\n TImageArchitectureHeader = IMAGE_ARCHITECTURE_HEADER;\r\n PImageArchitectureHeader = PIMAGE_ARCHITECTURE_HEADER;\r\n\r\n PIMAGE_ARCHITECTURE_ENTRY = ^IMAGE_ARCHITECTURE_ENTRY;\r\n {$EXTERNALSYM PIMAGE_ARCHITECTURE_ENTRY}\r\n _ImageArchitectureEntry = record\r\n FixupInstRVA: DWORD; // RVA of instruction to fixup\r\n NewInst: DWORD; // fixup instruction (see alphaops.h)\r\n end;\r\n {$EXTERNALSYM _ImageArchitectureEntry}\r\n IMAGE_ARCHITECTURE_ENTRY = _ImageArchitectureEntry;\r\n {$EXTERNALSYM IMAGE_ARCHITECTURE_ENTRY}\r\n TImageArchitectureEntry = IMAGE_ARCHITECTURE_ENTRY;\r\n PImageArchitectureEntry = PIMAGE_ARCHITECTURE_ENTRY;\r\n\r\n// #include \"poppack.h\" // Back to the initial value\r\n\r\n// The following structure defines the new import object. Note the values of the first two fields,\r\n// which must be set as stated in order to differentiate old and new import members.\r\n// Following this structure, the linker emits two null-terminated strings used to recreate the\r\n// import at the time of use. The first string is the import's name, the second is the dll's name.\r\n\r\nconst\r\n IMPORT_OBJECT_HDR_SIG2 = $ffff;\r\n {$EXTERNALSYM IMPORT_OBJECT_HDR_SIG2}\r\n\r\nconst\r\n IOHFLAGS_TYPE = $0003; // IMPORT_TYPE\r\n IAHFLAGS_NAMETYPE = $001C; // IMPORT_NAME_TYPE\r\n IAHFLAGS_RESERVED = $FFE0; // Reserved. Must be zero.\r\n\r\ntype\r\n PImportObjectHeader = ^IMPORT_OBJECT_HEADER;\r\n IMPORT_OBJECT_HEADER = record\r\n Sig1: WORD; // Must be IMAGE_FILE_MACHINE_UNKNOWN\r\n Sig2: WORD; // Must be IMPORT_OBJECT_HDR_SIG2.\r\n Version: WORD;\r\n Machine: WORD;\r\n TimeDateStamp: DWORD; // Time/date stamp\r\n SizeOfData: DWORD; // particularly useful for incremental links\r\n OrdinalOrHint: record\r\n case Integer of\r\n 0: (Ordinal: WORD); // if grf & IMPORT_OBJECT_ORDINAL\r\n 1: (Flags: DWORD);\r\n end;\r\n Flags: WORD;\r\n //WORD Type : 2; // IMPORT_TYPE\r\n //WORD NameType : 3; // IMPORT_NAME_TYPE\r\n //WORD Reserved : 11; // Reserved. Must be zero.\r\n end;\r\n {$EXTERNALSYM IMPORT_OBJECT_HEADER}\r\n TImportObjectHeader = IMPORT_OBJECT_HEADER;\r\n\r\n IMPORT_OBJECT_TYPE = (IMPORT_OBJECT_CODE, IMPORT_OBJECT_DATA, IMPORT_OBJECT_CONST);\r\n {$EXTERNALSYM IMPORT_OBJECT_TYPE}\r\n TImportObjectType = IMPORT_OBJECT_TYPE;\r\n\r\n IMPORT_OBJECT_NAME_TYPE = (\r\n IMPORT_OBJECT_ORDINAL, // Import by ordinal\r\n IMPORT_OBJECT_NAME, // Import name == public symbol name.\r\n IMPORT_OBJECT_NAME_NO_PREFIX, // Import name == public symbol name skipping leading ?, @, or optionally _.\r\n IMPORT_OBJECT_NAME_UNDECORATE); // Import name == public symbol name skipping leading ?, @, or optionally _\r\n // and truncating at first @\r\n {$EXTERNALSYM IMPORT_OBJECT_NAME_TYPE}\r\n TImportObjectNameType = IMPORT_OBJECT_NAME_TYPE;\r\n\r\n ReplacesCorHdrNumericDefines = DWORD;\r\n {$EXTERNALSYM ReplacesCorHdrNumericDefines}\r\n\r\nconst\r\n\r\n// COM+ Header entry point flags.\r\n\r\n COMIMAGE_FLAGS_ILONLY = $00000001;\r\n {$EXTERNALSYM COMIMAGE_FLAGS_ILONLY}\r\n COMIMAGE_FLAGS_32BITREQUIRED = $00000002;\r\n {$EXTERNALSYM COMIMAGE_FLAGS_32BITREQUIRED}\r\n COMIMAGE_FLAGS_IL_LIBRARY = $00000004;\r\n {$EXTERNALSYM COMIMAGE_FLAGS_IL_LIBRARY}\r\n COMIMAGE_FLAGS_STRONGNAMESIGNED = $00000008;\r\n {$EXTERNALSYM COMIMAGE_FLAGS_STRONGNAMESIGNED}\r\n COMIMAGE_FLAGS_TRACKDEBUGDATA = $00010000;\r\n {$EXTERNALSYM COMIMAGE_FLAGS_TRACKDEBUGDATA}\r\n\r\n// Version flags for image.\r\n\r\n COR_VERSION_MAJOR_V2 = 2;\r\n {$EXTERNALSYM COR_VERSION_MAJOR_V2}\r\n COR_VERSION_MAJOR = COR_VERSION_MAJOR_V2;\r\n {$EXTERNALSYM COR_VERSION_MAJOR}\r\n COR_VERSION_MINOR = 0;\r\n {$EXTERNALSYM COR_VERSION_MINOR}\r\n COR_DELETED_NAME_LENGTH = 8;\r\n {$EXTERNALSYM COR_DELETED_NAME_LENGTH}\r\n COR_VTABLEGAP_NAME_LENGTH = 8;\r\n {$EXTERNALSYM COR_VTABLEGAP_NAME_LENGTH}\r\n\r\n// Maximum size of a NativeType descriptor.\r\n\r\n NATIVE_TYPE_MAX_CB = 1;\r\n {$EXTERNALSYM NATIVE_TYPE_MAX_CB}\r\n COR_ILMETHOD_SECT_SMALL_MAX_DATASIZE= $FF;\r\n {$EXTERNALSYM COR_ILMETHOD_SECT_SMALL_MAX_DATASIZE}\r\n\r\n// #defines for the MIH FLAGS\r\n\r\n IMAGE_COR_MIH_METHODRVA = $01;\r\n {$EXTERNALSYM IMAGE_COR_MIH_METHODRVA}\r\n IMAGE_COR_MIH_EHRVA = $02;\r\n {$EXTERNALSYM IMAGE_COR_MIH_EHRVA}\r\n IMAGE_COR_MIH_BASICBLOCK = $08;\r\n {$EXTERNALSYM IMAGE_COR_MIH_BASICBLOCK}\r\n\r\n// V-table constants\r\n\r\n COR_VTABLE_32BIT = $01; // V-table slots are 32-bits in size.\r\n {$EXTERNALSYM COR_VTABLE_32BIT}\r\n COR_VTABLE_64BIT = $02; // V-table slots are 64-bits in size.\r\n {$EXTERNALSYM COR_VTABLE_64BIT}\r\n COR_VTABLE_FROM_UNMANAGED = $04; // If set, transition from unmanaged.\r\n {$EXTERNALSYM COR_VTABLE_FROM_UNMANAGED}\r\n COR_VTABLE_CALL_MOST_DERIVED = $10; // Call most derived method described by\r\n {$EXTERNALSYM COR_VTABLE_CALL_MOST_DERIVED}\r\n\r\n// EATJ constants\r\n\r\n IMAGE_COR_EATJ_THUNK_SIZE = 32; // Size of a jump thunk reserved range.\r\n {$EXTERNALSYM IMAGE_COR_EATJ_THUNK_SIZE}\r\n\r\n// Max name lengths\r\n// Change to unlimited name lengths.\r\n\r\n MAX_CLASS_NAME = 1024;\r\n {$EXTERNALSYM MAX_CLASS_NAME}\r\n MAX_PACKAGE_NAME = 1024;\r\n {$EXTERNALSYM MAX_PACKAGE_NAME}\r\n\r\n// COM+ 2.0 header structure.\r\n\r\ntype\r\n IMAGE_COR20_HEADER = record\r\n\r\n // Header versioning\r\n\r\n cb: DWORD;\r\n MajorRuntimeVersion: WORD;\r\n MinorRuntimeVersion: WORD;\r\n\r\n // Symbol table and startup information\r\n\r\n MetaData: IMAGE_DATA_DIRECTORY;\r\n Flags: DWORD;\r\n EntryPointToken: DWORD;\r\n\r\n // Binding information\r\n\r\n Resources: IMAGE_DATA_DIRECTORY;\r\n StrongNameSignature: IMAGE_DATA_DIRECTORY;\r\n\r\n // Regular fixup and binding information\r\n\r\n CodeManagerTable: IMAGE_DATA_DIRECTORY;\r\n VTableFixups: IMAGE_DATA_DIRECTORY;\r\n ExportAddressTableJumps: IMAGE_DATA_DIRECTORY;\r\n\r\n // Precompiled image info (internal use only - set to zero)\r\n\r\n ManagedNativeHeader: IMAGE_DATA_DIRECTORY;\r\n end;\r\n PIMAGE_COR20_HEADER = ^IMAGE_COR20_HEADER;\r\n TImageCor20Header = IMAGE_COR20_HEADER;\r\n PImageCor20Header = PIMAGE_COR20_HEADER;\r\n\r\n// line 7351\r\n\r\nconst\r\n COMPRESSION_FORMAT_NONE = ($0000);\r\n {$EXTERNALSYM COMPRESSION_FORMAT_NONE}\r\n COMPRESSION_FORMAT_DEFAULT = ($0001);\r\n {$EXTERNALSYM COMPRESSION_FORMAT_DEFAULT}\r\n COMPRESSION_FORMAT_LZNT1 = ($0002);\r\n {$EXTERNALSYM COMPRESSION_FORMAT_LZNT1}\r\n COMPRESSION_ENGINE_STANDARD = ($0000);\r\n {$EXTERNALSYM COMPRESSION_ENGINE_STANDARD}\r\n COMPRESSION_ENGINE_MAXIMUM = ($0100);\r\n {$EXTERNALSYM COMPRESSION_ENGINE_MAXIMUM}\r\n COMPRESSION_ENGINE_HIBER = ($0200);\r\n {$EXTERNALSYM COMPRESSION_ENGINE_HIBER}\r\n\r\n// line 7462\r\n\r\ntype\r\n POSVERSIONINFOEXA = ^OSVERSIONINFOEXA;\r\n {$EXTERNALSYM POSVERSIONINFOEXA}\r\n _OSVERSIONINFOEXA = record\r\n dwOSVersionInfoSize: DWORD;\r\n dwMajorVersion: DWORD;\r\n dwMinorVersion: DWORD;\r\n dwBuildNumber: DWORD;\r\n dwPlatformId: DWORD;\r\n szCSDVersion: array [0..127] of ANSICHAR; // Maintenance string for PSS usage\r\n wServicePackMajor: WORD;\r\n wServicePackMinor: WORD;\r\n wSuiteMask: WORD;\r\n wProductType: BYTE;\r\n wReserved: BYTE;\r\n end;\r\n {$EXTERNALSYM _OSVERSIONINFOEXA}\r\n OSVERSIONINFOEXA = _OSVERSIONINFOEXA;\r\n {$EXTERNALSYM OSVERSIONINFOEXA}\r\n LPOSVERSIONINFOEXA = ^OSVERSIONINFOEXA;\r\n {$EXTERNALSYM LPOSVERSIONINFOEXA}\r\n TOSVersionInfoExA = _OSVERSIONINFOEXA;\r\n\r\n POSVERSIONINFOEXW = ^OSVERSIONINFOEXW;\r\n {$EXTERNALSYM POSVERSIONINFOEXW}\r\n _OSVERSIONINFOEXW = record\r\n dwOSVersionInfoSize: DWORD;\r\n dwMajorVersion: DWORD;\r\n dwMinorVersion: DWORD;\r\n dwBuildNumber: DWORD;\r\n dwPlatformId: DWORD;\r\n szCSDVersion: array [0..127] of WCHAR; // Maintenance string for PSS usage\r\n wServicePackMajor: WORD;\r\n wServicePackMinor: WORD;\r\n wSuiteMask: WORD;\r\n wProductType: BYTE;\r\n wReserved: BYTE;\r\n end;\r\n {$EXTERNALSYM _OSVERSIONINFOEXW}\r\n OSVERSIONINFOEXW = _OSVERSIONINFOEXW;\r\n {$EXTERNALSYM OSVERSIONINFOEXW}\r\n LPOSVERSIONINFOEXW = ^OSVERSIONINFOEXW;\r\n {$EXTERNALSYM LPOSVERSIONINFOEXW}\r\n RTL_OSVERSIONINFOEXW = _OSVERSIONINFOEXW;\r\n {$EXTERNALSYM RTL_OSVERSIONINFOEXW}\r\n PRTL_OSVERSIONINFOEXW = ^RTL_OSVERSIONINFOEXW;\r\n {$EXTERNALSYM PRTL_OSVERSIONINFOEXW}\r\n TOSVersionInfoExW = _OSVERSIONINFOEXW;\r\n\r\n{$IFDEF SUPPORTS_UNICODE}\r\n\r\n OSVERSIONINFOEX = OSVERSIONINFOEXW;\r\n {$EXTERNALSYM OSVERSIONINFOEX}\r\n POSVERSIONINFOEX = POSVERSIONINFOEXW;\r\n {$EXTERNALSYM POSVERSIONINFOEX}\r\n LPOSVERSIONINFOEX = LPOSVERSIONINFOEXW;\r\n {$EXTERNALSYM LPOSVERSIONINFOEX}\r\n TOSVersionInfoEx = TOSVersionInfoExW;\r\n\r\n{$ELSE ~SUPPORTS_UNICODE}\r\n\r\n OSVERSIONINFOEX = OSVERSIONINFOEXA;\r\n {$EXTERNALSYM OSVERSIONINFOEX}\r\n POSVERSIONINFOEX = POSVERSIONINFOEXA;\r\n {$EXTERNALSYM POSVERSIONINFOEX}\r\n LPOSVERSIONINFOEX = LPOSVERSIONINFOEXA;\r\n {$EXTERNALSYM LPOSVERSIONINFOEX}\r\n TOSVersionInfoEx = TOSVersionInfoExA; \r\n\r\n{$ENDIF ~SUPPORTS_UNICODE}\r\n\r\n//\r\n// RtlVerifyVersionInfo() conditions\r\n//\r\n\r\nconst\r\n VER_EQUAL = 1;\r\n {$EXTERNALSYM VER_EQUAL}\r\n VER_GREATER = 2;\r\n {$EXTERNALSYM VER_GREATER}\r\n VER_GREATER_EQUAL = 3;\r\n {$EXTERNALSYM VER_GREATER_EQUAL}\r\n VER_LESS = 4;\r\n {$EXTERNALSYM VER_LESS}\r\n VER_LESS_EQUAL = 5;\r\n {$EXTERNALSYM VER_LESS_EQUAL}\r\n VER_AND = 6;\r\n {$EXTERNALSYM VER_AND}\r\n VER_OR = 7;\r\n {$EXTERNALSYM VER_OR}\r\n\r\n VER_CONDITION_MASK = 7;\r\n {$EXTERNALSYM VER_CONDITION_MASK}\r\n VER_NUM_BITS_PER_CONDITION_MASK = 3;\r\n {$EXTERNALSYM VER_NUM_BITS_PER_CONDITION_MASK}\r\n\r\n//\r\n// RtlVerifyVersionInfo() type mask bits\r\n//\r\n\r\n VER_MINORVERSION = $0000001;\r\n {$EXTERNALSYM VER_MINORVERSION}\r\n VER_MAJORVERSION = $0000002;\r\n {$EXTERNALSYM VER_MAJORVERSION}\r\n VER_BUILDNUMBER = $0000004;\r\n {$EXTERNALSYM VER_BUILDNUMBER}\r\n VER_PLATFORMID = $0000008;\r\n {$EXTERNALSYM VER_PLATFORMID}\r\n VER_SERVICEPACKMINOR = $0000010;\r\n {$EXTERNALSYM VER_SERVICEPACKMINOR}\r\n VER_SERVICEPACKMAJOR = $0000020;\r\n {$EXTERNALSYM VER_SERVICEPACKMAJOR}\r\n VER_SUITENAME = $0000040;\r\n {$EXTERNALSYM VER_SUITENAME}\r\n VER_PRODUCT_TYPE = $0000080;\r\n {$EXTERNALSYM VER_PRODUCT_TYPE}\r\n\r\n//\r\n// RtlVerifyVersionInfo() os product type values\r\n//\r\n\r\n VER_NT_WORKSTATION = $0000001;\r\n {$EXTERNALSYM VER_NT_WORKSTATION}\r\n VER_NT_DOMAIN_CONTROLLER = $0000002;\r\n {$EXTERNALSYM VER_NT_DOMAIN_CONTROLLER}\r\n VER_NT_SERVER = $0000003;\r\n {$EXTERNALSYM VER_NT_SERVER}\r\n\r\n//\r\n// dwPlatformId defines:\r\n//\r\n\r\n VER_PLATFORM_WIN32s = 0;\r\n {$EXTERNALSYM VER_PLATFORM_WIN32s}\r\n VER_PLATFORM_WIN32_WINDOWS = 1;\r\n {$EXTERNALSYM VER_PLATFORM_WIN32_WINDOWS}\r\n VER_PLATFORM_WIN32_NT = 2;\r\n {$EXTERNALSYM VER_PLATFORM_WIN32_NT}\r\n\r\nconst\r\n//\r\n//\r\n// Predefined Value Types.\r\n//\r\n\r\n REG_NONE = ( 0 ); // No value type\r\n {$EXTERNALSYM REG_NONE}\r\n REG_SZ = ( 1 ); // Unicode nul terminated string\r\n {$EXTERNALSYM REG_SZ}\r\n REG_EXPAND_SZ = ( 2 ); // Unicode nul terminated string\r\n {$EXTERNALSYM REG_EXPAND_SZ}\r\n // (with environment variable references)\r\n REG_BINARY = ( 3 ); // Free form binary\r\n {$EXTERNALSYM REG_BINARY}\r\n REG_DWORD = ( 4 ); // 32-bit number\r\n {$EXTERNALSYM REG_DWORD}\r\n REG_DWORD_LITTLE_ENDIAN = ( 4 ); // 32-bit number (same as REG_DWORD)\r\n {$EXTERNALSYM REG_DWORD_LITTLE_ENDIAN}\r\n REG_DWORD_BIG_ENDIAN = ( 5 ); // 32-bit number\r\n {$EXTERNALSYM REG_DWORD_BIG_ENDIAN}\r\n REG_LINK = ( 6 ); // Symbolic Link (unicode)\r\n {$EXTERNALSYM REG_LINK}\r\n REG_MULTI_SZ = ( 7 ); // Multiple Unicode strings\r\n {$EXTERNALSYM REG_MULTI_SZ}\r\n REG_RESOURCE_LIST = ( 8 ); // Resource list in the resource map\r\n {$EXTERNALSYM REG_RESOURCE_LIST}\r\n REG_FULL_RESOURCE_DESCRIPTOR = ( 9 ); // Resource list in the hardware description\r\n {$EXTERNALSYM REG_FULL_RESOURCE_DESCRIPTOR}\r\n REG_RESOURCE_REQUIREMENTS_LIST = ( 10 );\r\n {$EXTERNALSYM REG_RESOURCE_REQUIREMENTS_LIST}\r\n REG_QWORD = ( 11 ); // 64-bit number\r\n {$EXTERNALSYM REG_QWORD}\r\n REG_QWORD_LITTLE_ENDIAN = ( 11 ); // 64-bit number (same as REG_QWORD)\r\n {$EXTERNALSYM REG_QWORD_LITTLE_ENDIAN}\r\n\r\n // Windows 7 debugging types\r\n\r\ntype\r\n _CONTEXT_CHUNK = packed record\r\n Offset: Integer;\r\n Length: DWORD;\r\n end;\r\n {$EXTERNALSYM _CONTEXT_CHUNK}\r\n CONTEXT_CHUNK = _CONTEXT_CHUNK;\r\n {$EXTERNALSYM CONTEXT_CHUNK}\r\n PCONTEXT_CHUNK = ^_CONTEXT_CHUNK;\r\n {$EXTERNALSYM PCONTEXT_CHUNK}\r\n\r\ntype\r\n _CONTEXT_EX = packed record\r\n //\r\n // The total length of the structure starting from the chunk with\r\n // the smallest offset. N.B. that the offset may be negative.\r\n //\r\n All: CONTEXT_CHUNK;\r\n\r\n //\r\n // Wrapper for the traditional CONTEXT structure. N.B. the size of\r\n // the chunk may be less than sizeof(CONTEXT) is some cases (when\r\n // CONTEXT_EXTENDED_REGISTERS is not set on x86 for instance).\r\n //\r\n\r\n Legacy: CONTEXT_CHUNK;\r\n\r\n //\r\n // CONTEXT_XSTATE: Extended processor state chunk. The state is\r\n // stored in the same format XSAVE operation strores it with\r\n // exception of the first 512 bytes, i.e. staring from\r\n // XSAVE_AREA_HEADER. The lower two bits corresponding FP and\r\n // SSE state must be zero.\r\n //\r\n\r\n XState: CONTEXT_CHUNK;\r\n end;\r\n {$EXTERNALSYM _CONTEXT_EX}\r\n CONTEXT_EX = _CONTEXT_EX;\r\n {$EXTERNALSYM CONTEXT_EX}\r\n PCONTEXT_EX = ^_CONTEXT_EX;\r\n {$EXTERNALSYM PCONTEXT_EX}\r\n\r\n//\r\n// Known extended CPU state feature IDs\r\n//\r\n\r\nconst\r\n XSTATE_LEGACY_FLOATING_POINT = 0;\r\n {$EXTERNALSYM XSTATE_LEGACY_FLOATING_POINT}\r\n XSTATE_LEGACY_SSE = 1;\r\n {$EXTERNALSYM XSTATE_LEGACY_SSE}\r\n XSTATE_GSSE = 2;\r\n {$EXTERNALSYM XSTATE_GSSE}\r\n\r\n XSTATE_MASK_LEGACY_FLOATING_POINT = Int64(1) shl XSTATE_LEGACY_FLOATING_POINT;\r\n {$EXTERNALSYM XSTATE_MASK_LEGACY_FLOATING_POINT}\r\n XSTATE_MASK_LEGACY_SSE = Int64(1) shl XSTATE_LEGACY_SSE;\r\n {$EXTERNALSYM XSTATE_MASK_LEGACY_SSE}\r\n XSTATE_MASK_LEGACY = XSTATE_MASK_LEGACY_FLOATING_POINT or XSTATE_MASK_LEGACY_SSE;\r\n {$EXTERNALSYM XSTATE_MASK_LEGACY}\r\n XSTATE_MASK_GSSE = Int64(1) shl XSTATE_GSSE;\r\n {$EXTERNALSYM XSTATE_MASK_GSSE}\r\n\r\n MAXIMUM_XSTATE_FEATURES = 64;\r\n {$EXTERNALSYM MAXIMUM_XSTATE_FEATURES}\r\n\r\n//\r\n// The following flags control the contents of the CONTEXT structure.\r\n//\r\nconst\r\n CONTEXT_i386 = $00010000; // this assumes that i386 and\r\n {$EXTERNALSYM CONTEXT_i386}\r\n CONTEXT_i486 = $00010000; // i486 have identical context records\r\n {$EXTERNALSYM CONTEXT_i486}\r\n\r\n CONTEXT_CONTROL = CONTEXT_i386 or $00000001; // SS:SP, CS:IP, FLAGS, BP\r\n {$EXTERNALSYM CONTEXT_CONTROL}\r\n CONTEXT_INTEGER = CONTEXT_i386 or $00000002; // AX, BX, CX, DX, SI, DI\r\n {$EXTERNALSYM CONTEXT_INTEGER}\r\n CONTEXT_SEGMENTS = CONTEXT_i386 or $00000004; // DS, ES, FS, GS\r\n {$EXTERNALSYM CONTEXT_SEGMENTS}\r\n CONTEXT_FLOATING_POINT = CONTEXT_i386 or $00000008; // 387 state\r\n {$EXTERNALSYM CONTEXT_FLOATING_POINT}\r\n CONTEXT_DEBUG_REGISTERS = CONTEXT_i386 or $00000010; // DB 0-3,6,7\r\n {$EXTERNALSYM CONTEXT_DEBUG_REGISTERS}\r\n CONTEXT_EXTENDED_REGISTERS = CONTEXT_i386 or $00000020; // cpu specific extensions\r\n {$EXTERNALSYM CONTEXT_EXTENDED_REGISTERS}\r\n\r\n CONTEXT_FULL = CONTEXT_CONTROL or CONTEXT_INTEGER or CONTEXT_SEGMENTS;\r\n {$EXTERNALSYM CONTEXT_FULL}\r\n\r\n CONTEXT_ALL = CONTEXT_CONTROL or CONTEXT_INTEGER or CONTEXT_SEGMENTS or CONTEXT_FLOATING_POINT or\r\n CONTEXT_DEBUG_REGISTERS or CONTEXT_EXTENDED_REGISTERS;\r\n {$EXTERNALSYM CONTEXT_ALL}\r\n\r\n CONTEXT_XSTATE = CONTEXT_i386 or $00000040;\r\n {$EXTERNALSYM CONTEXT_XSTATE}\r\n\r\n// line 160\r\n\r\n//\r\n// File creation flags must start at the high end since they\r\n// are combined with the attributes\r\n//\r\n\r\nconst\r\n FILE_FLAG_WRITE_THROUGH = DWORD($80000000);\r\n {$EXTERNALSYM FILE_FLAG_WRITE_THROUGH}\r\n FILE_FLAG_OVERLAPPED = $40000000;\r\n {$EXTERNALSYM FILE_FLAG_OVERLAPPED}\r\n FILE_FLAG_NO_BUFFERING = $20000000;\r\n {$EXTERNALSYM FILE_FLAG_NO_BUFFERING}\r\n FILE_FLAG_RANDOM_ACCESS = $10000000;\r\n {$EXTERNALSYM FILE_FLAG_RANDOM_ACCESS}\r\n FILE_FLAG_SEQUENTIAL_SCAN = $08000000;\r\n {$EXTERNALSYM FILE_FLAG_SEQUENTIAL_SCAN}\r\n FILE_FLAG_DELETE_ON_CLOSE = $04000000;\r\n {$EXTERNALSYM FILE_FLAG_DELETE_ON_CLOSE}\r\n FILE_FLAG_BACKUP_SEMANTICS = $02000000;\r\n {$EXTERNALSYM FILE_FLAG_BACKUP_SEMANTICS}\r\n FILE_FLAG_POSIX_SEMANTICS = $01000000;\r\n {$EXTERNALSYM FILE_FLAG_POSIX_SEMANTICS}\r\n FILE_FLAG_OPEN_REPARSE_POINT = $00200000;\r\n {$EXTERNALSYM FILE_FLAG_OPEN_REPARSE_POINT}\r\n FILE_FLAG_OPEN_NO_RECALL = $00100000;\r\n {$EXTERNALSYM FILE_FLAG_OPEN_NO_RECALL}\r\n FILE_FLAG_FIRST_PIPE_INSTANCE = $00080000;\r\n {$EXTERNALSYM FILE_FLAG_FIRST_PIPE_INSTANCE}\r\n\r\n// line 2727\r\ntype\r\n _MEMORYSTATUSEX = packed record\r\n dwLength: DWORD;\r\n dwMemoryLoad: DWORD;\r\n ullTotalPhys: Int64;\r\n ullAvailPhys: Int64;\r\n ullTotalPageFile: Int64;\r\n ullAvailPageFile: Int64;\r\n ullTotalVirtual: Int64;\r\n ullAvailVirtual: Int64;\r\n ullAvailExtendedVirtual: Int64;\r\n end;\r\n {$EXTERNALSYM _MEMORYSTATUSEX}\r\n\r\n MEMORYSTATUSEX = _MEMORYSTATUSEX;\r\n {$EXTERNALSYM MEMORYSTATUSEX}\r\n LPMEMORYSTATUSEX = ^_MEMORYSTATUSEX;\r\n {$EXTERNALSYM LPMEMORYSTATUSEX}\r\n\r\n TMemoryStatusEx = _MEMORYSTATUSEX;\r\n\r\nfunction GlobalMemoryStatusEx(out lpBuffer: TMemoryStatusEx): BOOL; stdcall;\r\n\r\n// line 3189\r\n \r\n\r\nfunction BackupSeek(hFile: THandle; dwLowBytesToSeek, dwHighBytesToSeek: DWORD;\r\n out lpdwLowByteSeeked, lpdwHighByteSeeked: DWORD;\r\n var lpContext: Pointer): BOOL; stdcall;\r\n{$EXTERNALSYM BackupSeek}\r\n\r\n// line 5454\r\n\r\nfunction AdjustTokenPrivileges(TokenHandle: THandle; DisableAllPrivileges: BOOL;\r\n const NewState: TTokenPrivileges; BufferLength: DWORD;\r\n PreviousState: PTokenPrivileges;\r\n ReturnLength: PDWORD\r\n ): BOOL; stdcall;\r\n{$EXTERNALSYM AdjustTokenPrivileges}\r\n\r\n{\r\nFrom: Ray Lischner \r\nSubject: CreateMutex bug\r\nDate: 1999/12/10\r\nMessage-ID: #1/1\r\nContent-Transfer-Encoding: 7bit\r\nOrganization: Tempest Software, Inc., Corvallis, Oregon\r\nContent-Type: text/plain; charset=us-ascii\r\nMime-Version: 1.0\r\nNewsgroups: borland.public.delphi.winapi\r\n\r\n\r\nWindows NT 4 has a bug in CreateMutex. The second argument is documented\r\nto be a BOOL, but in truth, the CreateMutex interprets 1 as True and all\r\nother values as False. (Do I detect an \"if (bInitialOwner == TRUE)\" in\r\nthe implementation of CreateMutex?)\r\n\r\nThe problem is that Delphi declares CreateMutex according to the\r\ndocumentation, so bInitialOwner is declared as LongBool. Delphi maps\r\nTrue values to $FFFFFFFF, which should work, but doesn't in this case.\r\n\r\nMy workaround is to declare CreateMutex with a LongInt as the second\r\nargument, and pass the value 1 for True.\r\n\r\nI have not had this problem on Windows 98.\r\n--\r\nRay Lischner, author of Delphi in a Nutshell (coming later this year)\r\nhttp://www.bardware.com and http://www.tempest-sw.com\r\n}\r\nfunction CreateMutex(lpMutexAttributes: PSecurityAttributes; bInitialOwner: DWORD; lpName: PChar): THandle; stdcall;\r\n{$EXTERNALSYM CreateMutex}\r\n\r\n// alternative conversion for WinNT 4.0 SP6 and later (OSVersionInfoEx instead of OSVersionInfo)\r\n{$EXTERNALSYM GetVersionEx}\r\nfunction GetVersionEx(var lpVersionInformation: TOSVersionInfoEx): BOOL; stdcall; overload;\r\n{$EXTERNALSYM GetVersionEx}\r\nfunction GetVersionEx(lpVersionInformation: POSVERSIONINFOEX): BOOL; stdcall; overload;\r\n {$IFDEF SUPPORTS_DEPRECATED} deprecated; {$ENDIF}\r\n\r\n// line 3585\r\n\r\nfunction SetWaitableTimer(hTimer: THandle; var lpDueTime: TLargeInteger;\r\n lPeriod: Longint; pfnCompletionRoutine: TFNTimerAPCRoutine;\r\n lpArgToCompletionRoutine: Pointer; fResume: BOOL): BOOL; stdcall;\r\n {$EXTERNALSYM SetWaitableTimer}\r\n\r\n// WinBase.h line 8839\r\n\r\nfunction SetFileSecurityA(lpFileName: LPCSTR; SecurityInformation: SECURITY_INFORMATION;\r\n pSecurityDescriptor: PSECURITY_DESCRIPTOR): BOOL; stdcall;\r\n{$EXTERNALSYM SetFileSecurityA}\r\nfunction SetFileSecurityW(lpFileName: LPCWSTR; SecurityInformation: SECURITY_INFORMATION;\r\n pSecurityDescriptor: PSECURITY_DESCRIPTOR): BOOL; stdcall;\r\n{$EXTERNALSYM SetFileSecurityW}\r\nfunction SetFileSecurity(lpFileName: LPCTSTR; SecurityInformation: SECURITY_INFORMATION;\r\n pSecurityDescriptor: PSECURITY_DESCRIPTOR): BOOL; stdcall;\r\n{$EXTERNALSYM SetFileSecurity}\r\n\r\nfunction GetFileSecurityA(lpFileName: LPCSTR; RequestedInformation: SECURITY_INFORMATION;\r\n pSecurityDescriptor: PSECURITY_DESCRIPTOR; nLength: DWORD;\r\n var lpnLengthNeeded: DWORD): BOOL; stdcall;\r\n{$EXTERNALSYM GetFileSecurityA}\r\nfunction GetFileSecurityW(lpFileName: LPCWSTR; RequestedInformation: SECURITY_INFORMATION;\r\n pSecurityDescriptor: PSECURITY_DESCRIPTOR; nLength: DWORD;\r\n var lpnLengthNeeded: DWORD): BOOL; stdcall;\r\n{$EXTERNALSYM GetFileSecurityW}\r\nfunction GetFileSecurity(lpFileName: LPCTSTR; RequestedInformation: SECURITY_INFORMATION;\r\n pSecurityDescriptor: PSECURITY_DESCRIPTOR; nLength: DWORD;\r\n var lpnLengthNeeded: DWORD): BOOL; stdcall;\r\n{$EXTERNALSYM GetFileSecurity}\r\n\r\n// WinBase.h line 10251\r\n\r\nfunction SetVolumeMountPointW(lpszVolumeMountPoint, lpszVolumeName: LPCWSTR): BOOL; stdcall;\r\n{$EXTERNALSYM SetVolumeMountPointW}\r\n\r\nfunction DeleteVolumeMountPointW(lpszVolumeMountPoint: LPCWSTR): BOOL; stdcall;\r\n{$EXTERNALSYM DeleteVolumeMountPointW}\r\n\r\nfunction GetVolumeNameForVolumeMountPointW(lpszVolumeMountPoint: LPCWSTR;\r\n lpszVolumeName: LPWSTR; cchBufferLength: DWORD): BOOL; stdcall;\r\n{$EXTERNALSYM GetVolumeNameForVolumeMountPointW}\r\n\r\n// new Windows 7 debugging API\r\nfunction CopyExtendedContext(Destination: PCONTEXT_EX; ContextFlags: DWORD; Source: PCONTEXT_EX): BOOL; stdcall;\r\n{$EXTERNALSYM CopyExtendedContext}\r\n\r\nfunction InitializeExtendedContext(Context: Pointer; ContextFlags: DWORD; out ContextEx: PCONTEXT_EX): BOOL; stdcall;\r\n{$EXTERNALSYM InitializeExtendedContext}\r\n\r\nfunction GetEnabledExtendedFeatures(const FeatureMask: Int64): Int64; stdcall;\r\n{$EXTERNALSYM GetEnabledExtendedFeatures}\r\n\r\nfunction GetExtendedContextLength(ContextFlags: DWORD; ContextLength: PDWORD): BOOL; stdcall;\r\n{$EXTERNALSYM GetExtendedContextLength}\r\n\r\nfunction GetExtendedFeaturesMask(ContextEx: PCONTEXT_EX): Int64; stdcall;\r\n{$EXTERNALSYM GetExtendedFeaturesMask}\r\n\r\nfunction LocateExtendedFeature(ContextEx: PCONTEXT_EX; FeatureId: DWORD; Length: PDWORD): Pointer; stdcall;\r\n{$EXTERNALSYM LocateExtendedFeature}\r\n\r\nfunction LocateLegacyContext(ContextEx: PCONTEXT_EX; Length: PDWORD): PCONTEXT; stdcall;\r\n{$EXTERNALSYM LocateLegacyContext}\r\n\r\nprocedure SetExtendedFeaturesMask(ContextEx: PCONTEXT_EX; const FeatureMask: Int64); stdcall;\r\n{$EXTERNALSYM SetExtendedFeaturesMask}\r\n\r\nfunction ProcessIdToSessionId(dwProcessId: DWORD; out dwSessionId: DWORD): BOOL; stdcall;\r\n{$EXTERNALSYM ProcessIdToSessionId}\r\n\r\n\r\n// From JwaAclApi\r\n\r\n// line 185\r\n\r\nfunction SetNamedSecurityInfoW(pObjectName: LPWSTR; ObjectType: SE_OBJECT_TYPE;\r\n SecurityInfo: SECURITY_INFORMATION; psidOwner, psidGroup: PSID;\r\n pDacl, pSacl: PACL): DWORD; stdcall;\r\n{$EXTERNALSYM SetNamedSecurityInfoW}\r\nconst\r\n IMAGE_SEPARATION = (64*1024);\r\n {$EXTERNALSYM IMAGE_SEPARATION}\r\n\r\ntype\r\n PLOADED_IMAGE = ^LOADED_IMAGE;\r\n {$EXTERNALSYM PLOADED_IMAGE}\r\n _LOADED_IMAGE = record\r\n ModuleName: PAnsiChar;\r\n hFile: THandle;\r\n MappedAddress: PUCHAR;\r\n FileHeader: PImageNtHeaders;\r\n LastRvaSection: PImageSectionHeader;\r\n NumberOfSections: ULONG;\r\n Sections: PImageSectionHeader;\r\n Characteristics: ULONG;\r\n fSystemImage: ByteBool;\r\n fDOSImage: ByteBool;\r\n Links: LIST_ENTRY;\r\n SizeOfImage: ULONG;\r\n end;\r\n {$EXTERNALSYM _LOADED_IMAGE}\r\n LOADED_IMAGE = _LOADED_IMAGE;\r\n {$EXTERNALSYM LOADED_IMAGE}\r\n TLoadedImage = LOADED_IMAGE;\r\n PLoadedImage = PLOADED_IMAGE;\r\n\r\n PIMAGE_SYMBOL = ^IMAGE_SYMBOL;\r\n {$EXTERNALSYM PIMAGE_SYMBOL}\r\n _IMAGE_SYMBOL = packed record // MUST pack to obtain the right size\r\n Name: array [0..7] of AnsiChar;\r\n Value: ULONG;\r\n SectionNumber: USHORT;\r\n _Type: USHORT;\r\n StorageClass: BYTE;\r\n NumberOfAuxSymbols: BYTE;\r\n end;\r\n {$EXTERNALSYM _IMAGE_SYMBOL}\r\n IMAGE_SYMBOL = _IMAGE_SYMBOL;\r\n {$EXTERNALSYM IMAGE_SYMBOL}\r\n TImageSymbol = IMAGE_SYMBOL;\r\n PImageSymbol = PIMAGE_SYMBOL;\r\n\r\n// line 152\r\n\r\n\r\nfunction ReBaseImage(CurrentImageName: PAnsiChar; SymbolPath: PAnsiChar; fReBase: BOOL;\r\n fRebaseSysfileOk: BOOL; fGoingDown: BOOL; CheckImageSize: ULONG;\r\n var OldImageSize: TJclAddr32; var OldImageBase: TJclAddr;\r\n var NewImageSize: TJclAddr32; var NewImageBase: TJclAddr; TimeStamp: ULONG): BOOL; stdcall;\r\n{$EXTERNALSYM ReBaseImage}\r\n\r\nfunction ReBaseImage64(CurrentImageName: PAnsiChar; SymbolPath: PAnsiChar; fReBase: BOOL;\r\n fRebaseSysfileOk: BOOL; fGoingDown: BOOL; CheckImageSize: ULONG;\r\n var OldImageSize: TJclAddr32; var OldImageBase: TJclAddr64;\r\n var NewImageSize: TJclAddr32; var NewImageBase: TJclAddr64; TimeStamp: ULONG): BOOL; stdcall;\r\n{$EXTERNALSYM ReBaseImage64}\r\n\r\n// line 199\r\n\r\n//\r\n// Define checksum function prototypes.\r\n//\r\n\r\nfunction CheckSumMappedFile(BaseAddress: Pointer; FileLength: DWORD;\r\n out HeaderSum, CheckSum: DWORD): PImageNtHeaders; stdcall;\r\n{$EXTERNALSYM CheckSumMappedFile}\r\n\r\n// line 227\r\n\r\nfunction GetImageUnusedHeaderBytes(const LoadedImage: LOADED_IMAGE;\r\n var SizeUnusedHeaderBytes: DWORD): DWORD; stdcall;\r\n{$EXTERNALSYM GetImageUnusedHeaderBytes}\r\n\r\n// line 285\r\n\r\nfunction MapAndLoad(ImageName, DllPath: PAnsiChar; var LoadedImage: LOADED_IMAGE;\r\n DotDll: BOOL; ReadOnly: BOOL): BOOL; stdcall;\r\n{$EXTERNALSYM MapAndLoad}\r\n\r\nfunction UnMapAndLoad(const LoadedImage: LOADED_IMAGE): BOOL; stdcall;\r\n{$EXTERNALSYM UnMapAndLoad}\r\n\r\nfunction TouchFileTimes(const FileHandle: THandle; const pSystemTime: TSystemTime): BOOL; stdcall;\r\n{$EXTERNALSYM TouchFileTimes}\r\n\r\n// line 347\r\n\r\nfunction ImageDirectoryEntryToData(Base: Pointer; MappedAsImage: ByteBool;\r\n DirectoryEntry: USHORT; var Size: ULONG): Pointer; stdcall;\r\n{$EXTERNALSYM ImageDirectoryEntryToData}\r\n\r\nfunction ImageRvaToSection(NtHeaders: PImageNtHeaders; Base: Pointer; Rva: ULONG): PImageSectionHeader; stdcall;\r\n{$EXTERNALSYM ImageRvaToSection}\r\n\r\nfunction ImageRvaToVa(NtHeaders: PImageNtHeaders; Base: Pointer; Rva: ULONG;\r\n LastRvaSection: PPImageSectionHeader): Pointer; stdcall;\r\n{$EXTERNALSYM ImageRvaToVa}\r\n\r\n\r\n// line 461\r\n\r\n//\r\n// UnDecorateSymbolName Flags\r\n//\r\n\r\nconst\r\n UNDNAME_COMPLETE = ($0000); // Enable full undecoration\r\n {$EXTERNALSYM UNDNAME_COMPLETE}\r\n UNDNAME_NO_LEADING_UNDERSCORES = ($0001); // Remove leading underscores from MS extended keywords\r\n {$EXTERNALSYM UNDNAME_NO_LEADING_UNDERSCORES}\r\n UNDNAME_NO_MS_KEYWORDS = ($0002); // Disable expansion of MS extended keywords\r\n {$EXTERNALSYM UNDNAME_NO_MS_KEYWORDS}\r\n UNDNAME_NO_FUNCTION_RETURNS = ($0004); // Disable expansion of return type for primary declaration\r\n {$EXTERNALSYM UNDNAME_NO_FUNCTION_RETURNS}\r\n UNDNAME_NO_ALLOCATION_MODEL = ($0008); // Disable expansion of the declaration model\r\n {$EXTERNALSYM UNDNAME_NO_ALLOCATION_MODEL}\r\n UNDNAME_NO_ALLOCATION_LANGUAGE = ($0010); // Disable expansion of the declaration language specifier\r\n {$EXTERNALSYM UNDNAME_NO_ALLOCATION_LANGUAGE}\r\n UNDNAME_NO_MS_THISTYPE = ($0020); // NYI Disable expansion of MS keywords on the 'this' type for primary declaration\r\n {$EXTERNALSYM UNDNAME_NO_MS_THISTYPE}\r\n UNDNAME_NO_CV_THISTYPE = ($0040); // NYI Disable expansion of CV modifiers on the 'this' type for primary declaration\r\n {$EXTERNALSYM UNDNAME_NO_CV_THISTYPE}\r\n UNDNAME_NO_THISTYPE = ($0060); // Disable all modifiers on the 'this' type\r\n {$EXTERNALSYM UNDNAME_NO_THISTYPE}\r\n UNDNAME_NO_ACCESS_SPECIFIERS = ($0080); // Disable expansion of access specifiers for members\r\n {$EXTERNALSYM UNDNAME_NO_ACCESS_SPECIFIERS}\r\n UNDNAME_NO_THROW_SIGNATURES = ($0100); // Disable expansion of 'throw-signatures' for functions and pointers to functions\r\n {$EXTERNALSYM UNDNAME_NO_THROW_SIGNATURES}\r\n UNDNAME_NO_MEMBER_TYPE = ($0200); // Disable expansion of 'static' or 'virtual'ness of members\r\n {$EXTERNALSYM UNDNAME_NO_MEMBER_TYPE}\r\n UNDNAME_NO_RETURN_UDT_MODEL = ($0400); // Disable expansion of MS model for UDT returns\r\n {$EXTERNALSYM UNDNAME_NO_RETURN_UDT_MODEL}\r\n UNDNAME_32_BIT_DECODE = ($0800); // Undecorate 32-bit decorated names\r\n {$EXTERNALSYM UNDNAME_32_BIT_DECODE}\r\n UNDNAME_NAME_ONLY = ($1000); // Crack only the name for primary declaration;\r\n {$EXTERNALSYM UNDNAME_NAME_ONLY}\r\n // return just [scope::]name. Does expand template params\r\n UNDNAME_NO_ARGUMENTS = ($2000); // Don't undecorate arguments to function\r\n {$EXTERNALSYM UNDNAME_NO_ARGUMENTS}\r\n UNDNAME_NO_SPECIAL_SYMS = ($4000); // Don't undecorate special names (v-table, vcall, vector xxx, metatype, etc)\r\n {$EXTERNALSYM UNDNAME_NO_SPECIAL_SYMS}\r\n\r\n// line 1342\r\n\r\ntype\r\n {$EXTERNALSYM SYM_TYPE}\r\n SYM_TYPE = (\r\n SymNone,\r\n SymCoff,\r\n SymCv,\r\n SymPdb,\r\n SymExport,\r\n SymDeferred,\r\n SymSym { .sym file }\r\n );\r\n TSymType = SYM_TYPE;\r\n\r\n { symbol data structure }\r\n {$EXTERNALSYM PImagehlpSymbolA}\r\n PImagehlpSymbolA = ^TImagehlpSymbolA;\r\n {$EXTERNALSYM _IMAGEHLP_SYMBOLA}\r\n _IMAGEHLP_SYMBOLA = packed record\r\n SizeOfStruct: DWORD; { set to sizeof(IMAGEHLP_SYMBOL) }\r\n Address: DWORD; { virtual address including dll base address }\r\n Size: DWORD; { estimated size of symbol, can be zero }\r\n Flags: DWORD; { info about the symbols, see the SYMF defines }\r\n MaxNameLength: DWORD; { maximum size of symbol name in 'Name' }\r\n Name: packed array[0..0] of AnsiChar; { symbol name (null terminated string) }\r\n end;\r\n {$EXTERNALSYM IMAGEHLP_SYMBOLA}\r\n IMAGEHLP_SYMBOLA = _IMAGEHLP_SYMBOLA;\r\n {$EXTERNALSYM TImagehlpSymbolA}\r\n TImagehlpSymbolA = _IMAGEHLP_SYMBOLA;\r\n\r\n { symbol data structure }\r\n {$EXTERNALSYM PImagehlpSymbolA64}\r\n PImagehlpSymbolA64 = ^TImagehlpSymbolA64;\r\n {$EXTERNALSYM _IMAGEHLP_SYMBOLA64}\r\n _IMAGEHLP_SYMBOLA64 = packed record\r\n SizeOfStruct: DWORD; { set to sizeof(IMAGEHLP_SYMBOL) }\r\n Address: TJclAddr64; { virtual address including dll base address }\r\n Size: DWORD; { estimated size of symbol, can be zero }\r\n Flags: DWORD; { info about the symbols, see the SYMF defines }\r\n MaxNameLength: DWORD; { maximum size of symbol name in 'Name' }\r\n Name: packed array[0..0] of AnsiChar; { symbol name (null terminated string) }\r\n end;\r\n {$EXTERNALSYM IMAGEHLP_SYMBOLA64}\r\n IMAGEHLP_SYMBOLA64 = _IMAGEHLP_SYMBOLA64;\r\n {$EXTERNALSYM TImagehlpSymbolA64}\r\n TImagehlpSymbolA64 = _IMAGEHLP_SYMBOLA64;\r\n\r\n { symbol data structure }\r\n {$EXTERNALSYM PImagehlpSymbolW}\r\n PImagehlpSymbolW = ^TImagehlpSymbolW;\r\n {$EXTERNALSYM _IMAGEHLP_SYMBOLW}\r\n _IMAGEHLP_SYMBOLW = packed record\r\n SizeOfStruct: DWORD; { set to sizeof(IMAGEHLP_SYMBOL) }\r\n Address: DWORD; { virtual address including dll base address }\r\n Size: DWORD; { estimated size of symbol, can be zero }\r\n Flags: DWORD; { info about the symbols, see the SYMF defines }\r\n MaxNameLength: DWORD; { maximum size of symbol name in 'Name' }\r\n Name: packed array[0..0] of WideChar; { symbol name (null terminated string) }\r\n end;\r\n {$EXTERNALSYM IMAGEHLP_SYMBOLW}\r\n IMAGEHLP_SYMBOLW = _IMAGEHLP_SYMBOLW;\r\n {$EXTERNALSYM TImagehlpSymbolW}\r\n TImagehlpSymbolW = _IMAGEHLP_SYMBOLW;\r\n\r\n { symbol data structure }\r\n {$EXTERNALSYM PImagehlpSymbolW64}\r\n PImagehlpSymbolW64 = ^TImagehlpSymbolW64;\r\n {$EXTERNALSYM _IMAGEHLP_SYMBOLW64}\r\n _IMAGEHLP_SYMBOLW64 = packed record\r\n SizeOfStruct: DWORD; { set to sizeof(IMAGEHLP_SYMBOL) }\r\n Address: TJclAddr64; { virtual address including dll base address }\r\n Size: DWORD; { estimated size of symbol, can be zero }\r\n Flags: DWORD; { info about the symbols, see the SYMF defines }\r\n MaxNameLength: DWORD; { maximum size of symbol name in 'Name' }\r\n Name: packed array[0..0] of WideChar; { symbol name (null terminated string) }\r\n end;\r\n {$EXTERNALSYM IMAGEHLP_SYMBOLW64}\r\n IMAGEHLP_SYMBOLW64 = _IMAGEHLP_SYMBOLW64;\r\n {$EXTERNALSYM TImagehlpSymbolW64}\r\n TImagehlpSymbolW64 = _IMAGEHLP_SYMBOLW64;\r\n\r\n { module data structure }\r\n {$EXTERNALSYM PImagehlpModuleA}\r\n PImagehlpModuleA = ^TImagehlpModuleA;\r\n {$EXTERNALSYM _IMAGEHLP_MODULEA}\r\n _IMAGEHLP_MODULEA = record\r\n SizeOfStruct: DWORD; { set to sizeof(IMAGEHLP_MODULE) }\r\n BaseOfImage: DWORD; { base load address of module }\r\n ImageSize: DWORD; { virtual size of the loaded module }\r\n TimeDateStamp: DWORD; { date/time stamp from pe header }\r\n CheckSum: DWORD; { checksum from the pe header }\r\n NumSyms: DWORD; { number of symbols in the symbol table }\r\n SymType: TSymType; { type of symbols loaded }\r\n ModuleName: packed array[0..31] of AnsiChar; { module name }\r\n ImageName: packed array[0..255] of AnsiChar; { image name }\r\n LoadedImageName: packed array[0..255] of AnsiChar; { symbol file name }\r\n end;\r\n {$EXTERNALSYM IMAGEHLP_MODULEA}\r\n IMAGEHLP_MODULEA = _IMAGEHLP_MODULEA;\r\n {$EXTERNALSYM TImagehlpModuleA}\r\n TImagehlpModuleA = _IMAGEHLP_MODULEA;\r\n\r\n { module data structure }\r\n {$EXTERNALSYM PImagehlpModuleA64}\r\n PImagehlpModuleA64 = ^TImagehlpModuleA64;\r\n {$EXTERNALSYM _IMAGEHLP_MODULEA64}\r\n _IMAGEHLP_MODULEA64 = record\r\n SizeOfStruct: DWORD; { set to sizeof(IMAGEHLP_MODULE) }\r\n BaseOfImage: TJclAddr64; { base load address of module }\r\n ImageSize: DWORD; { virtual size of the loaded module }\r\n TimeDateStamp: DWORD; { date/time stamp from pe header }\r\n CheckSum: DWORD; { checksum from the pe header }\r\n NumSyms: DWORD; { number of symbols in the symbol table }\r\n SymType: TSymType; { type of symbols loaded }\r\n ModuleName: packed array[0..31] of AnsiChar; { module name }\r\n ImageName: packed array[0..255] of AnsiChar; { image name }\r\n LoadedImageName: packed array[0..255] of AnsiChar; { symbol file name }\r\n end;\r\n {$EXTERNALSYM IMAGEHLP_MODULEA64}\r\n IMAGEHLP_MODULEA64 = _IMAGEHLP_MODULEA64;\r\n {$EXTERNALSYM TImagehlpModuleA64}\r\n TImagehlpModuleA64 = _IMAGEHLP_MODULEA64;\r\n\r\n { module data structure }\r\n {$EXTERNALSYM PImagehlpModuleW}\r\n PImagehlpModuleW = ^TImagehlpModuleW;\r\n {$EXTERNALSYM _IMAGEHLP_MODULEW}\r\n _IMAGEHLP_MODULEW = record\r\n SizeOfStruct: DWORD; { set to sizeof(IMAGEHLP_MODULE) }\r\n BaseOfImage: DWORD; { base load address of module }\r\n ImageSize: DWORD; { virtual size of the loaded module }\r\n TimeDateStamp: DWORD; { date/time stamp from pe header }\r\n CheckSum: DWORD; { checksum from the pe header }\r\n NumSyms: DWORD; { number of symbols in the symbol table }\r\n SymType: TSymType; { type of symbols loaded }\r\n ModuleName: packed array[0..31] of WideChar; { module name }\r\n ImageName: packed array[0..255] of WideChar; { image name }\r\n LoadedImageName: packed array[0..255] of WideChar; { symbol file name }\r\n end;\r\n {$EXTERNALSYM IMAGEHLP_MODULEW}\r\n IMAGEHLP_MODULEW = _IMAGEHLP_MODULEW;\r\n {$EXTERNALSYM TImagehlpModuleW}\r\n TImagehlpModuleW = _IMAGEHLP_MODULEW;\r\n\r\n { module data structure }\r\n {$EXTERNALSYM PImagehlpModuleW64}\r\n PImagehlpModuleW64 = ^TImagehlpModuleW64;\r\n {$EXTERNALSYM _IMAGEHLP_MODULEW64}\r\n _IMAGEHLP_MODULEW64 = record\r\n SizeOfStruct: DWORD; { set to sizeof(IMAGEHLP_MODULE) }\r\n BaseOfImage: TJclAddr64; { base load address of module }\r\n ImageSize: DWORD; { virtual size of the loaded module }\r\n TimeDateStamp: DWORD; { date/time stamp from pe header }\r\n CheckSum: DWORD; { checksum from the pe header }\r\n NumSyms: DWORD; { number of symbols in the symbol table }\r\n SymType: TSymType; { type of symbols loaded }\r\n ModuleName: packed array[0..31] of WideChar; { module name }\r\n ImageName: packed array[0..255] of WideChar; { image name }\r\n LoadedImageName: packed array[0..255] of WideChar; { symbol file name }\r\n end;\r\n {$EXTERNALSYM IMAGEHLP_MODULEW64}\r\n IMAGEHLP_MODULEW64 = _IMAGEHLP_MODULEW64;\r\n {$EXTERNALSYM TImagehlpModuleW64}\r\n TImagehlpModuleW64 = _IMAGEHLP_MODULEW64;\r\n\r\n _IMAGEHLP_LINEA = packed record\r\n SizeOfStruct: DWORD; // set to sizeof(IMAGEHLP_LINE)\r\n Key: Pointer; // internal\r\n LineNumber: DWORD; // line number in file\r\n FileName: PAnsiChar; // full filename\r\n Address: DWORD; // first instruction of line\r\n end;\r\n IMAGEHLP_LINEA = _IMAGEHLP_LINEA;\r\n PIMAGEHLP_LINEA = ^_IMAGEHLP_LINEA;\r\n TImageHlpLineA = _IMAGEHLP_LINEA;\r\n PImageHlpLineA = PIMAGEHLP_LINEA;\r\n\r\n _IMAGEHLP_LINEA64 = packed record\r\n SizeOfStruct: DWORD; // set to sizeof(IMAGEHLP_LINE)\r\n Key: Pointer; // internal\r\n LineNumber: DWORD; // line number in file\r\n FileName: PAnsiChar; // full filename\r\n Address: TJclAddr64; // first instruction of line\r\n end;\r\n IMAGEHLP_LINEA64 = _IMAGEHLP_LINEA64;\r\n PIMAGEHLP_LINEA64 = ^_IMAGEHLP_LINEA64;\r\n TImageHlpLineA64 = _IMAGEHLP_LINEA64;\r\n PImageHlpLineA64 = PIMAGEHLP_LINEA64;\r\n\r\n _IMAGEHLP_LINEW = packed record\r\n SizeOfStruct: DWORD; // set to sizeof(IMAGEHLP_LINE)\r\n Key: Pointer; // internal\r\n LineNumber: DWORD; // line number in file\r\n FileName: PWideChar; // full filename\r\n Address: DWORD; // first instruction of line\r\n end;\r\n IMAGEHLP_LINEW = _IMAGEHLP_LINEW;\r\n PIMAGEHLP_LINEW = ^_IMAGEHLP_LINEW;\r\n TImageHlpLineW = _IMAGEHLP_LINEW;\r\n PImageHlpLineW = PIMAGEHLP_LINEW;\r\n\r\n _IMAGEHLP_LINEW64 = packed record\r\n SizeOfStruct: DWORD; // set to sizeof(IMAGEHLP_LINE)\r\n Key: Pointer; // internal\r\n LineNumber: DWORD; // line number in file\r\n FileName: PWideChar; // full filename\r\n Address: TJclAddr64; // first instruction of line\r\n end;\r\n IMAGEHLP_LINEW64 = _IMAGEHLP_LINEW64;\r\n PIMAGEHLP_LINEW64 = ^_IMAGEHLP_LINEW64;\r\n TImageHlpLineW64 = _IMAGEHLP_LINEW64;\r\n PImageHlpLineW64 = PIMAGEHLP_LINEW64;\r\n\r\n// line 1475\r\n\r\n//\r\n// options that are set/returned by SymSetOptions() & SymGetOptions()\r\n// these are used as a mask\r\n//\r\n\r\nconst\r\n SYMOPT_CASE_INSENSITIVE = $00000001;\r\n {$EXTERNALSYM SYMOPT_CASE_INSENSITIVE}\r\n SYMOPT_UNDNAME = $00000002;\r\n {$EXTERNALSYM SYMOPT_UNDNAME}\r\n SYMOPT_DEFERRED_LOADS = $00000004;\r\n {$EXTERNALSYM SYMOPT_DEFERRED_LOADS}\r\n SYMOPT_NO_CPP = $00000008;\r\n {$EXTERNALSYM SYMOPT_NO_CPP}\r\n SYMOPT_LOAD_LINES = $00000010;\r\n {$EXTERNALSYM SYMOPT_LOAD_LINES}\r\n SYMOPT_OMAP_FIND_NEAREST = $00000020;\r\n {$EXTERNALSYM SYMOPT_OMAP_FIND_NEAREST}\r\n SYMOPT_LOAD_ANYTHING = $00000040;\r\n {$EXTERNALSYM SYMOPT_LOAD_ANYTHING}\r\n SYMOPT_IGNORE_CVREC = $00000080;\r\n {$EXTERNALSYM SYMOPT_IGNORE_CVREC}\r\n SYMOPT_NO_UNQUALIFIED_LOADS = $00000100;\r\n {$EXTERNALSYM SYMOPT_NO_UNQUALIFIED_LOADS}\r\n SYMOPT_FAIL_CRITICAL_ERRORS = $00000200;\r\n {$EXTERNALSYM SYMOPT_FAIL_CRITICAL_ERRORS}\r\n SYMOPT_EXACT_SYMBOLS = $00000400;\r\n {$EXTERNALSYM SYMOPT_EXACT_SYMBOLS}\r\n SYMOPT_ALLOW_ABSOLUTE_SYMBOLS = $00000800;\r\n {$EXTERNALSYM SYMOPT_ALLOW_ABSOLUTE_SYMBOLS}\r\n SYMOPT_IGNORE_NT_SYMPATH = $00001000;\r\n {$EXTERNALSYM SYMOPT_IGNORE_NT_SYMPATH}\r\n SYMOPT_INCLUDE_32BIT_MODULES = $00002000;\r\n {$EXTERNALSYM SYMOPT_INCLUDE_32BIT_MODULES}\r\n SYMOPT_PUBLICS_ONLY = $00004000;\r\n {$EXTERNALSYM SYMOPT_PUBLICS_ONLY}\r\n SYMOPT_NO_PUBLICS = $00008000;\r\n {$EXTERNALSYM SYMOPT_NO_PUBLICS}\r\n SYMOPT_AUTO_PUBLICS = $00010000;\r\n {$EXTERNALSYM SYMOPT_AUTO_PUBLICS}\r\n SYMOPT_NO_IMAGE_SEARCH = $00020000;\r\n {$EXTERNALSYM SYMOPT_NO_IMAGE_SEARCH}\r\n SYMOPT_SECURE = $00040000;\r\n {$EXTERNALSYM SYMOPT_SECURE}\r\n SYMOPT_NO_PROMPTS = $00080000;\r\n {$EXTERNALSYM SYMOPT_NO_PROMPTS}\r\n\r\n SYMOPT_DEBUG = $80000000;\r\n {$EXTERNALSYM SYMOPT_DEBUG}\r\n\r\n// IoAPI.h\r\n\r\n\r\nfunction CancelIo(hFile: THandle): BOOL; stdcall;\r\n{$EXTERNALSYM CancelIo}\r\n\r\n\r\nconst\r\n NERR_Success = 0; // Success\r\n {$EXTERNALSYM NERR_Success}\r\n\r\n// ERROR_ equates can be intermixed with NERR_ equates.\r\n\r\n// NERR_BASE is the base of error codes from network utilities,\r\n// chosen to avoid conflict with system and redirector error codes.\r\n// 2100 is a value that has been assigned to us by system.\r\n\r\n NERR_BASE = 2100;\r\n {$EXTERNALSYM NERR_BASE}\r\n\r\n\r\n//*INTERNAL_ONLY*\r\n\r\n{**********WARNING *****************\r\n *See the comment in lmcons.h for *\r\n *info on the allocation of errors *\r\n ***********************************}\r\n\r\n{**********WARNING *****************\r\n *The range 2750-2799 has been *\r\n *allocated to the IBM LAN Server *\r\n ***********************************}\r\n\r\n{**********WARNING *****************\r\n *The range 2900-2999 has been *\r\n *reserved for Microsoft OEMs *\r\n ***********************************}\r\n\r\n// UNUSED BASE+0\r\n// UNUSED BASE+1\r\n NERR_NetNotStarted = (NERR_BASE+2); // The workstation driver is not installed.\r\n {$EXTERNALSYM NERR_NetNotStarted}\r\n NERR_UnknownServer = (NERR_BASE+3); // The server could not be located.\r\n {$EXTERNALSYM NERR_UnknownServer}\r\n NERR_ShareMem = (NERR_BASE+4); // An internal error occurred. The network cannot access a shared memory segment.\r\n {$EXTERNALSYM NERR_ShareMem}\r\n\r\n NERR_NoNetworkResource = (NERR_BASE+5); // A network resource shortage occurred .\r\n {$EXTERNALSYM NERR_NoNetworkResource}\r\n NERR_RemoteOnly = (NERR_BASE+6); // This operation is not supported on workstations.\r\n {$EXTERNALSYM NERR_RemoteOnly}\r\n NERR_DevNotRedirected = (NERR_BASE+7); // The device is not connected.\r\n {$EXTERNALSYM NERR_DevNotRedirected}\r\n// NERR_BASE+8 is used for ERROR_CONNECTED_OTHER_PASSWORD\r\n// NERR_BASE+9 is used for ERROR_CONNECTED_OTHER_PASSWORD_DEFAULT\r\n// UNUSED BASE+10\r\n// UNUSED BASE+11\r\n// UNUSED BASE+12\r\n// UNUSED BASE+13\r\n NERR_ServerNotStarted = (NERR_BASE+14); // The Server service is not started.\r\n {$EXTERNALSYM NERR_ServerNotStarted}\r\n NERR_ItemNotFound = (NERR_BASE+15); // The queue is empty.\r\n {$EXTERNALSYM NERR_ItemNotFound}\r\n NERR_UnknownDevDir = (NERR_BASE+16); // The device or directory does not exist.\r\n {$EXTERNALSYM NERR_UnknownDevDir}\r\n NERR_RedirectedPath = (NERR_BASE+17); // The operation is invalid on a redirected resource.\r\n {$EXTERNALSYM NERR_RedirectedPath}\r\n NERR_DuplicateShare = (NERR_BASE+18); // The name has already been shared.\r\n {$EXTERNALSYM NERR_DuplicateShare}\r\n NERR_NoRoom = (NERR_BASE+19); // The server is currently out of the requested resource.\r\n {$EXTERNALSYM NERR_NoRoom}\r\n// UNUSED BASE+20\r\n NERR_TooManyItems = (NERR_BASE+21); // Requested addition of items exceeds the maximum allowed.\r\n {$EXTERNALSYM NERR_TooManyItems}\r\n NERR_InvalidMaxUsers = (NERR_BASE+22); // The Peer service supports only two simultaneous users.\r\n {$EXTERNALSYM NERR_InvalidMaxUsers}\r\n NERR_BufTooSmall = (NERR_BASE+23); // The API return buffer is too small.\r\n {$EXTERNALSYM NERR_BufTooSmall}\r\n// UNUSED BASE+24\r\n// UNUSED BASE+25\r\n// UNUSED BASE+26\r\n NERR_RemoteErr = (NERR_BASE+27); // A remote API error occurred.\r\n {$EXTERNALSYM NERR_RemoteErr}\r\n// UNUSED BASE+28\r\n// UNUSED BASE+29\r\n// UNUSED BASE+30\r\n NERR_LanmanIniError = (NERR_BASE+31); // An error occurred when opening or reading the configuration file.\r\n {$EXTERNALSYM NERR_LanmanIniError}\r\n// UNUSED BASE+32\r\n// UNUSED BASE+33\r\n// UNUSED BASE+34\r\n// UNUSED BASE+35\r\n NERR_NetworkError = (NERR_BASE+36); // A general network error occurred.\r\n {$EXTERNALSYM NERR_NetworkError}\r\n NERR_WkstaInconsistentState = (NERR_BASE+37);\r\n {$EXTERNALSYM NERR_WkstaInconsistentState}\r\n // The Workstation service is in an inconsistent state. Restart the computer before restarting the Workstation service.\r\n NERR_WkstaNotStarted = (NERR_BASE+38); // The Workstation service has not been started.\r\n {$EXTERNALSYM NERR_WkstaNotStarted}\r\n NERR_BrowserNotStarted = (NERR_BASE+39); // The requested information is not available.\r\n {$EXTERNALSYM NERR_BrowserNotStarted}\r\n NERR_InternalError = (NERR_BASE+40); // An internal Windows 2000 error occurred.\r\n {$EXTERNALSYM NERR_InternalError}\r\n NERR_BadTransactConfig = (NERR_BASE+41); // The server is not configured for transactions.\r\n {$EXTERNALSYM NERR_BadTransactConfig}\r\n NERR_InvalidAPI = (NERR_BASE+42); // The requested API is not supported on the remote server.\r\n {$EXTERNALSYM NERR_InvalidAPI}\r\n NERR_BadEventName = (NERR_BASE+43); // The event name is invalid.\r\n {$EXTERNALSYM NERR_BadEventName}\r\n NERR_DupNameReboot = (NERR_BASE+44); // The computer name already exists on the network. Change it and restart the computer.\r\n {$EXTERNALSYM NERR_DupNameReboot}\r\n\r\n//\r\n// Config API related\r\n// Error codes from BASE+45 to BASE+49\r\n\r\n\r\n// UNUSED BASE+45\r\n NERR_CfgCompNotFound = (NERR_BASE+46); // The specified component could not be found in the configuration information.\r\n {$EXTERNALSYM NERR_CfgCompNotFound}\r\n NERR_CfgParamNotFound = (NERR_BASE+47); // The specified parameter could not be found in the configuration information.\r\n {$EXTERNALSYM NERR_CfgParamNotFound}\r\n NERR_LineTooLong = (NERR_BASE+49); // A line in the configuration file is too long.\r\n {$EXTERNALSYM NERR_LineTooLong}\r\n\r\n//\r\n// Spooler API related\r\n// Error codes from BASE+50 to BASE+79\r\n\r\n\r\n NERR_QNotFound = (NERR_BASE+50); // The printer does not exist.\r\n {$EXTERNALSYM NERR_QNotFound}\r\n NERR_JobNotFound = (NERR_BASE+51); // The print job does not exist.\r\n {$EXTERNALSYM NERR_JobNotFound}\r\n NERR_DestNotFound = (NERR_BASE+52); // The printer destination cannot be found.\r\n {$EXTERNALSYM NERR_DestNotFound}\r\n NERR_DestExists = (NERR_BASE+53); // The printer destination already exists.\r\n {$EXTERNALSYM NERR_DestExists}\r\n NERR_QExists = (NERR_BASE+54); // The printer queue already exists.\r\n {$EXTERNALSYM NERR_QExists}\r\n NERR_QNoRoom = (NERR_BASE+55); // No more printers can be added.\r\n {$EXTERNALSYM NERR_QNoRoom}\r\n NERR_JobNoRoom = (NERR_BASE+56); // No more print jobs can be added.\r\n {$EXTERNALSYM NERR_JobNoRoom}\r\n NERR_DestNoRoom = (NERR_BASE+57); // No more printer destinations can be added.\r\n {$EXTERNALSYM NERR_DestNoRoom}\r\n NERR_DestIdle = (NERR_BASE+58); // This printer destination is idle and cannot accept control operations.\r\n {$EXTERNALSYM NERR_DestIdle}\r\n NERR_DestInvalidOp = (NERR_BASE+59); // This printer destination request contains an invalid control function.\r\n {$EXTERNALSYM NERR_DestInvalidOp}\r\n NERR_ProcNoRespond = (NERR_BASE+60); // The print processor is not responding.\r\n {$EXTERNALSYM NERR_ProcNoRespond}\r\n NERR_SpoolerNotLoaded = (NERR_BASE+61); // The spooler is not running.\r\n {$EXTERNALSYM NERR_SpoolerNotLoaded}\r\n NERR_DestInvalidState = (NERR_BASE+62); // This operation cannot be performed on the print destination in its current state.\r\n {$EXTERNALSYM NERR_DestInvalidState}\r\n NERR_QInvalidState = (NERR_BASE+63); // This operation cannot be performed on the printer queue in its current state.\r\n {$EXTERNALSYM NERR_QInvalidState}\r\n NERR_JobInvalidState = (NERR_BASE+64); // This operation cannot be performed on the print job in its current state.\r\n {$EXTERNALSYM NERR_JobInvalidState}\r\n NERR_SpoolNoMemory = (NERR_BASE+65); // A spooler memory allocation failure occurred.\r\n {$EXTERNALSYM NERR_SpoolNoMemory}\r\n NERR_DriverNotFound = (NERR_BASE+66); // The device driver does not exist.\r\n {$EXTERNALSYM NERR_DriverNotFound}\r\n NERR_DataTypeInvalid = (NERR_BASE+67); // The data type is not supported by the print processor.\r\n {$EXTERNALSYM NERR_DataTypeInvalid}\r\n NERR_ProcNotFound = (NERR_BASE+68); // The print processor is not installed.\r\n {$EXTERNALSYM NERR_ProcNotFound}\r\n\r\n//\r\n// Service API related\r\n// Error codes from BASE+80 to BASE+99\r\n\r\n\r\n NERR_ServiceTableLocked = (NERR_BASE+80); // The service database is locked.\r\n {$EXTERNALSYM NERR_ServiceTableLocked}\r\n NERR_ServiceTableFull = (NERR_BASE+81); // The service table is full.\r\n {$EXTERNALSYM NERR_ServiceTableFull}\r\n NERR_ServiceInstalled = (NERR_BASE+82); // The requested service has already been started.\r\n {$EXTERNALSYM NERR_ServiceInstalled}\r\n NERR_ServiceEntryLocked = (NERR_BASE+83); // The service does not respond to control actions.\r\n {$EXTERNALSYM NERR_ServiceEntryLocked}\r\n NERR_ServiceNotInstalled = (NERR_BASE+84); // The service has not been started.\r\n {$EXTERNALSYM NERR_ServiceNotInstalled}\r\n NERR_BadServiceName = (NERR_BASE+85); // The service name is invalid.\r\n {$EXTERNALSYM NERR_BadServiceName}\r\n NERR_ServiceCtlTimeout = (NERR_BASE+86); // The service is not responding to the control function.\r\n {$EXTERNALSYM NERR_ServiceCtlTimeout}\r\n NERR_ServiceCtlBusy = (NERR_BASE+87); // The service control is busy.\r\n {$EXTERNALSYM NERR_ServiceCtlBusy}\r\n NERR_BadServiceProgName = (NERR_BASE+88); // The configuration file contains an invalid service program name.\r\n {$EXTERNALSYM NERR_BadServiceProgName}\r\n NERR_ServiceNotCtrl = (NERR_BASE+89); // The service could not be controlled in its present state.\r\n {$EXTERNALSYM NERR_ServiceNotCtrl}\r\n NERR_ServiceKillProc = (NERR_BASE+90); // The service ended abnormally.\r\n {$EXTERNALSYM NERR_ServiceKillProc}\r\n NERR_ServiceCtlNotValid = (NERR_BASE+91); // The requested pause,continue, or stop is not valid for this service.\r\n {$EXTERNALSYM NERR_ServiceCtlNotValid}\r\n NERR_NotInDispatchTbl = (NERR_BASE+92); // The service control dispatcher could not find the service name in the dispatch table.\r\n {$EXTERNALSYM NERR_NotInDispatchTbl}\r\n NERR_BadControlRecv = (NERR_BASE+93); // The service control dispatcher pipe read failed.\r\n {$EXTERNALSYM NERR_BadControlRecv}\r\n NERR_ServiceNotStarting = (NERR_BASE+94); // A thread for the new service could not be created.\r\n {$EXTERNALSYM NERR_ServiceNotStarting}\r\n\r\n//\r\n// Wksta and Logon API related\r\n// Error codes from BASE+100 to BASE+118\r\n\r\n\r\n NERR_AlreadyLoggedOn = (NERR_BASE+100); // This workstation is already logged on to the local-area network.\r\n {$EXTERNALSYM NERR_AlreadyLoggedOn}\r\n NERR_NotLoggedOn = (NERR_BASE+101); // The workstation is not logged on to the local-area network.\r\n {$EXTERNALSYM NERR_NotLoggedOn}\r\n NERR_BadUsername = (NERR_BASE+102); // The user name or group name parameter is invalid.\r\n {$EXTERNALSYM NERR_BadUsername}\r\n NERR_BadPassword = (NERR_BASE+103); // The password parameter is invalid.\r\n {$EXTERNALSYM NERR_BadPassword}\r\n NERR_UnableToAddName_W = (NERR_BASE+104); // @W The logon processor did not add the message alias.\r\n {$EXTERNALSYM NERR_UnableToAddName_W}\r\n NERR_UnableToAddName_F = (NERR_BASE+105); // The logon processor did not add the message alias.\r\n {$EXTERNALSYM NERR_UnableToAddName_F}\r\n NERR_UnableToDelName_W = (NERR_BASE+106); // @W The logoff processor did not delete the message alias.\r\n {$EXTERNALSYM NERR_UnableToDelName_W}\r\n NERR_UnableToDelName_F = (NERR_BASE+107); // The logoff processor did not delete the message alias.\r\n {$EXTERNALSYM NERR_UnableToDelName_F}\r\n// UNUSED BASE+108\r\n NERR_LogonsPaused = (NERR_BASE+109); // Network logons are paused.\r\n {$EXTERNALSYM NERR_LogonsPaused}\r\n NERR_LogonServerConflict = (NERR_BASE+110); // A centralized logon-server conflict occurred.\r\n {$EXTERNALSYM NERR_LogonServerConflict}\r\n NERR_LogonNoUserPath = (NERR_BASE+111); // The server is configured without a valid user path.\r\n {$EXTERNALSYM NERR_LogonNoUserPath}\r\n NERR_LogonScriptError = (NERR_BASE+112); // An error occurred while loading or running the logon script.\r\n {$EXTERNALSYM NERR_LogonScriptError}\r\n// UNUSED BASE+113\r\n NERR_StandaloneLogon = (NERR_BASE+114); // The logon server was not specified. Your computer will be logged on as STANDALONE.\r\n {$EXTERNALSYM NERR_StandaloneLogon}\r\n NERR_LogonServerNotFound = (NERR_BASE+115); // The logon server could not be found.\r\n {$EXTERNALSYM NERR_LogonServerNotFound}\r\n NERR_LogonDomainExists = (NERR_BASE+116); // There is already a logon domain for this computer.\r\n {$EXTERNALSYM NERR_LogonDomainExists}\r\n NERR_NonValidatedLogon = (NERR_BASE+117); // The logon server could not validate the logon.\r\n {$EXTERNALSYM NERR_NonValidatedLogon}\r\n\r\n//\r\n// ACF API related (access, user, group)\r\n// Error codes from BASE+119 to BASE+149\r\n\r\n\r\n NERR_ACFNotFound = (NERR_BASE+119); // The security database could not be found.\r\n {$EXTERNALSYM NERR_ACFNotFound}\r\n NERR_GroupNotFound = (NERR_BASE+120); // The group name could not be found.\r\n {$EXTERNALSYM NERR_GroupNotFound}\r\n NERR_UserNotFound = (NERR_BASE+121); // The user name could not be found.\r\n {$EXTERNALSYM NERR_UserNotFound}\r\n NERR_ResourceNotFound = (NERR_BASE+122); // The resource name could not be found.\r\n {$EXTERNALSYM NERR_ResourceNotFound}\r\n NERR_GroupExists = (NERR_BASE+123); // The group already exists.\r\n {$EXTERNALSYM NERR_GroupExists}\r\n NERR_UserExists = (NERR_BASE+124); // The account already exists.\r\n {$EXTERNALSYM NERR_UserExists}\r\n NERR_ResourceExists = (NERR_BASE+125); // The resource permission list already exists.\r\n {$EXTERNALSYM NERR_ResourceExists}\r\n NERR_NotPrimary = (NERR_BASE+126); // This operation is only allowed on the primary domain controller of the domain.\r\n {$EXTERNALSYM NERR_NotPrimary}\r\n NERR_ACFNotLoaded = (NERR_BASE+127); // The security database has not been started.\r\n {$EXTERNALSYM NERR_ACFNotLoaded}\r\n NERR_ACFNoRoom = (NERR_BASE+128); // There are too many names in the user accounts database.\r\n {$EXTERNALSYM NERR_ACFNoRoom}\r\n NERR_ACFFileIOFail = (NERR_BASE+129); // A disk I/O failure occurred.\r\n {$EXTERNALSYM NERR_ACFFileIOFail}\r\n NERR_ACFTooManyLists = (NERR_BASE+130); // The limit of 64 entries per resource was exceeded.\r\n {$EXTERNALSYM NERR_ACFTooManyLists}\r\n NERR_UserLogon = (NERR_BASE+131); // Deleting a user with a session is not allowed.\r\n {$EXTERNALSYM NERR_UserLogon}\r\n NERR_ACFNoParent = (NERR_BASE+132); // The parent directory could not be located.\r\n {$EXTERNALSYM NERR_ACFNoParent}\r\n NERR_CanNotGrowSegment = (NERR_BASE+133); // Unable to add to the security database session cache segment.\r\n {$EXTERNALSYM NERR_CanNotGrowSegment}\r\n NERR_SpeGroupOp = (NERR_BASE+134); // This operation is not allowed on this special group.\r\n {$EXTERNALSYM NERR_SpeGroupOp}\r\n NERR_NotInCache = (NERR_BASE+135); // This user is not cached in user accounts database session cache.\r\n {$EXTERNALSYM NERR_NotInCache}\r\n NERR_UserInGroup = (NERR_BASE+136); // The user already belongs to this group.\r\n {$EXTERNALSYM NERR_UserInGroup}\r\n NERR_UserNotInGroup = (NERR_BASE+137); // The user does not belong to this group.\r\n {$EXTERNALSYM NERR_UserNotInGroup}\r\n NERR_AccountUndefined = (NERR_BASE+138); // This user account is undefined.\r\n {$EXTERNALSYM NERR_AccountUndefined}\r\n NERR_AccountExpired = (NERR_BASE+139); // This user account has expired.\r\n {$EXTERNALSYM NERR_AccountExpired}\r\n NERR_InvalidWorkstation = (NERR_BASE+140); // The user is not allowed to log on from this workstation.\r\n {$EXTERNALSYM NERR_InvalidWorkstation}\r\n NERR_InvalidLogonHours = (NERR_BASE+141); // The user is not allowed to log on at this time.\r\n {$EXTERNALSYM NERR_InvalidLogonHours}\r\n NERR_PasswordExpired = (NERR_BASE+142); // The password of this user has expired.\r\n {$EXTERNALSYM NERR_PasswordExpired}\r\n NERR_PasswordCantChange = (NERR_BASE+143); // The password of this user cannot change.\r\n {$EXTERNALSYM NERR_PasswordCantChange}\r\n NERR_PasswordHistConflict = (NERR_BASE+144); // This password cannot be used now.\r\n {$EXTERNALSYM NERR_PasswordHistConflict}\r\n NERR_PasswordTooShort = (NERR_BASE+145); // The password does not meet the password policy requirements. Check the minimum password length, password complexity and password history requirements.\r\n {$EXTERNALSYM NERR_PasswordTooShort}\r\n NERR_PasswordTooRecent = (NERR_BASE+146); // The password of this user is too recent to change.\r\n {$EXTERNALSYM NERR_PasswordTooRecent}\r\n NERR_InvalidDatabase = (NERR_BASE+147); // The security database is corrupted.\r\n {$EXTERNALSYM NERR_InvalidDatabase}\r\n NERR_DatabaseUpToDate = (NERR_BASE+148); // No updates are necessary to this replicant network/local security database.\r\n {$EXTERNALSYM NERR_DatabaseUpToDate}\r\n NERR_SyncRequired = (NERR_BASE+149); // This replicant database is outdated; synchronization is required.\r\n {$EXTERNALSYM NERR_SyncRequired}\r\n\r\n//\r\n// Use API related\r\n// Error codes from BASE+150 to BASE+169\r\n\r\n\r\n NERR_UseNotFound = (NERR_BASE+150); // The network connection could not be found.\r\n {$EXTERNALSYM NERR_UseNotFound}\r\n NERR_BadAsgType = (NERR_BASE+151); // This asg_type is invalid.\r\n {$EXTERNALSYM NERR_BadAsgType}\r\n NERR_DeviceIsShared = (NERR_BASE+152); // This device is currently being shared.\r\n {$EXTERNALSYM NERR_DeviceIsShared}\r\n\r\n//\r\n// Message Server related\r\n// Error codes BASE+170 to BASE+209\r\n\r\n\r\n NERR_NoComputerName = (NERR_BASE+170); // The computer name could not be added as a message alias. The name may already exist on the network.\r\n {$EXTERNALSYM NERR_NoComputerName}\r\n NERR_MsgAlreadyStarted = (NERR_BASE+171); // The Messenger service is already started.\r\n {$EXTERNALSYM NERR_MsgAlreadyStarted}\r\n NERR_MsgInitFailed = (NERR_BASE+172); // The Messenger service failed to start.\r\n {$EXTERNALSYM NERR_MsgInitFailed}\r\n NERR_NameNotFound = (NERR_BASE+173); // The message alias could not be found on the network.\r\n {$EXTERNALSYM NERR_NameNotFound}\r\n NERR_AlreadyForwarded = (NERR_BASE+174); // This message alias has already been forwarded.\r\n {$EXTERNALSYM NERR_AlreadyForwarded}\r\n NERR_AddForwarded = (NERR_BASE+175); // This message alias has been added but is still forwarded.\r\n {$EXTERNALSYM NERR_AddForwarded}\r\n NERR_AlreadyExists = (NERR_BASE+176); // This message alias already exists locally.\r\n {$EXTERNALSYM NERR_AlreadyExists}\r\n NERR_TooManyNames = (NERR_BASE+177); // The maximum number of added message aliases has been exceeded.\r\n {$EXTERNALSYM NERR_TooManyNames}\r\n NERR_DelComputerName = (NERR_BASE+178); // The computer name could not be deleted.\r\n {$EXTERNALSYM NERR_DelComputerName}\r\n NERR_LocalForward = (NERR_BASE+179); // Messages cannot be forwarded back to the same workstation.\r\n {$EXTERNALSYM NERR_LocalForward}\r\n NERR_GrpMsgProcessor = (NERR_BASE+180); // An error occurred in the domain message processor.\r\n {$EXTERNALSYM NERR_GrpMsgProcessor}\r\n NERR_PausedRemote = (NERR_BASE+181); // The message was sent, but the recipient has paused the Messenger service.\r\n {$EXTERNALSYM NERR_PausedRemote}\r\n NERR_BadReceive = (NERR_BASE+182); // The message was sent but not received.\r\n {$EXTERNALSYM NERR_BadReceive}\r\n NERR_NameInUse = (NERR_BASE+183); // The message alias is currently in use. Try again later.\r\n {$EXTERNALSYM NERR_NameInUse}\r\n NERR_MsgNotStarted = (NERR_BASE+184); // The Messenger service has not been started.\r\n {$EXTERNALSYM NERR_MsgNotStarted}\r\n NERR_NotLocalName = (NERR_BASE+185); // The name is not on the local computer.\r\n {$EXTERNALSYM NERR_NotLocalName}\r\n NERR_NoForwardName = (NERR_BASE+186); // The forwarded message alias could not be found on the network.\r\n {$EXTERNALSYM NERR_NoForwardName}\r\n NERR_RemoteFull = (NERR_BASE+187); // The message alias table on the remote station is full.\r\n {$EXTERNALSYM NERR_RemoteFull}\r\n NERR_NameNotForwarded = (NERR_BASE+188); // Messages for this alias are not currently being forwarded.\r\n {$EXTERNALSYM NERR_NameNotForwarded}\r\n NERR_TruncatedBroadcast = (NERR_BASE+189); // The broadcast message was truncated.\r\n {$EXTERNALSYM NERR_TruncatedBroadcast}\r\n NERR_InvalidDevice = (NERR_BASE+194); // This is an invalid device name.\r\n {$EXTERNALSYM NERR_InvalidDevice}\r\n NERR_WriteFault = (NERR_BASE+195); // A write fault occurred.\r\n {$EXTERNALSYM NERR_WriteFault}\r\n// UNUSED BASE+196\r\n NERR_DuplicateName = (NERR_BASE+197); // A duplicate message alias exists on the network.\r\n {$EXTERNALSYM NERR_DuplicateName}\r\n NERR_DeleteLater = (NERR_BASE+198); // @W This message alias will be deleted later.\r\n {$EXTERNALSYM NERR_DeleteLater}\r\n NERR_IncompleteDel = (NERR_BASE+199); // The message alias was not successfully deleted from all networks.\r\n {$EXTERNALSYM NERR_IncompleteDel}\r\n NERR_MultipleNets = (NERR_BASE+200); // This operation is not supported on computers with multiple networks.\r\n {$EXTERNALSYM NERR_MultipleNets}\r\n\r\n//\r\n// Server API related\r\n// Error codes BASE+210 to BASE+229\r\n\r\n\r\n NERR_NetNameNotFound = (NERR_BASE+210); // This shared resource does not exist.\r\n {$EXTERNALSYM NERR_NetNameNotFound}\r\n NERR_DeviceNotShared = (NERR_BASE+211); // This device is not shared.\r\n {$EXTERNALSYM NERR_DeviceNotShared}\r\n NERR_ClientNameNotFound = (NERR_BASE+212); // A session does not exist with that computer name.\r\n {$EXTERNALSYM NERR_ClientNameNotFound}\r\n NERR_FileIdNotFound = (NERR_BASE+214); // There is not an open file with that identification number.\r\n {$EXTERNALSYM NERR_FileIdNotFound}\r\n NERR_ExecFailure = (NERR_BASE+215); // A failure occurred when executing a remote administration command.\r\n {$EXTERNALSYM NERR_ExecFailure}\r\n NERR_TmpFile = (NERR_BASE+216); // A failure occurred when opening a remote temporary file.\r\n {$EXTERNALSYM NERR_TmpFile}\r\n NERR_TooMuchData = (NERR_BASE+217); // The data returned from a remote administration command has been truncated to 64K.\r\n {$EXTERNALSYM NERR_TooMuchData}\r\n NERR_DeviceShareConflict = (NERR_BASE+218); // This device cannot be shared as both a spooled and a non-spooled resource.\r\n {$EXTERNALSYM NERR_DeviceShareConflict}\r\n NERR_BrowserTableIncomplete = (NERR_BASE+219); // The information in the list of servers may be incorrect.\r\n {$EXTERNALSYM NERR_BrowserTableIncomplete}\r\n NERR_NotLocalDomain = (NERR_BASE+220); // The computer is not active in this domain.\r\n {$EXTERNALSYM NERR_NotLocalDomain}\r\n NERR_IsDfsShare = (NERR_BASE+221); // The share must be removed from the Distributed File System before it can be deleted.\r\n {$EXTERNALSYM NERR_IsDfsShare}\r\n\r\n//\r\n// CharDev API related\r\n// Error codes BASE+230 to BASE+249\r\n\r\n\r\n// UNUSED BASE+230\r\n NERR_DevInvalidOpCode = (NERR_BASE+231); // The operation is invalid for this device.\r\n {$EXTERNALSYM NERR_DevInvalidOpCode}\r\n NERR_DevNotFound = (NERR_BASE+232); // This device cannot be shared.\r\n {$EXTERNALSYM NERR_DevNotFound}\r\n NERR_DevNotOpen = (NERR_BASE+233); // This device was not open.\r\n {$EXTERNALSYM NERR_DevNotOpen}\r\n NERR_BadQueueDevString = (NERR_BASE+234); // This device name list is invalid.\r\n {$EXTERNALSYM NERR_BadQueueDevString}\r\n NERR_BadQueuePriority = (NERR_BASE+235); // The queue priority is invalid.\r\n {$EXTERNALSYM NERR_BadQueuePriority}\r\n NERR_NoCommDevs = (NERR_BASE+237); // There are no shared communication devices.\r\n {$EXTERNALSYM NERR_NoCommDevs}\r\n NERR_QueueNotFound = (NERR_BASE+238); // The queue you specified does not exist.\r\n {$EXTERNALSYM NERR_QueueNotFound}\r\n NERR_BadDevString = (NERR_BASE+240); // This list of devices is invalid.\r\n {$EXTERNALSYM NERR_BadDevString}\r\n NERR_BadDev = (NERR_BASE+241); // The requested device is invalid.\r\n {$EXTERNALSYM NERR_BadDev}\r\n NERR_InUseBySpooler = (NERR_BASE+242); // This device is already in use by the spooler.\r\n {$EXTERNALSYM NERR_InUseBySpooler}\r\n NERR_CommDevInUse = (NERR_BASE+243); // This device is already in use as a communication device.\r\n {$EXTERNALSYM NERR_CommDevInUse}\r\n\r\n//\r\n// NetICanonicalize and NetIType and NetIMakeLMFileName\r\n// NetIListCanon and NetINameCheck\r\n// Error codes BASE+250 to BASE+269\r\n\r\n\r\n NERR_InvalidComputer = (NERR_BASE+251); // This computer name is invalid.\r\n {$EXTERNALSYM NERR_InvalidComputer}\r\n// UNUSED BASE+252\r\n// UNUSED BASE+253\r\n NERR_MaxLenExceeded = (NERR_BASE+254); // The string and prefix specified are too long.\r\n {$EXTERNALSYM NERR_MaxLenExceeded}\r\n// UNUSED BASE+255\r\n NERR_BadComponent = (NERR_BASE+256); // This path component is invalid.\r\n {$EXTERNALSYM NERR_BadComponent}\r\n NERR_CantType = (NERR_BASE+257); // Could not determine the type of input.\r\n {$EXTERNALSYM NERR_CantType}\r\n// UNUSED BASE+258\r\n// UNUSED BASE+259\r\n NERR_TooManyEntries = (NERR_BASE+262); // The buffer for types is not big enough.\r\n {$EXTERNALSYM NERR_TooManyEntries}\r\n\r\n//\r\n// NetProfile\r\n// Error codes BASE+270 to BASE+276\r\n\r\n\r\n NERR_ProfileFileTooBig = (NERR_BASE+270); // Profile files cannot exceed 64K.\r\n {$EXTERNALSYM NERR_ProfileFileTooBig}\r\n NERR_ProfileOffset = (NERR_BASE+271); // The start offset is out of range.\r\n {$EXTERNALSYM NERR_ProfileOffset}\r\n NERR_ProfileCleanup = (NERR_BASE+272); // The system cannot delete current connections to network resources.\r\n {$EXTERNALSYM NERR_ProfileCleanup}\r\n NERR_ProfileUnknownCmd = (NERR_BASE+273); // The system was unable to parse the command line in this file.\r\n {$EXTERNALSYM NERR_ProfileUnknownCmd}\r\n NERR_ProfileLoadErr = (NERR_BASE+274); // An error occurred while loading the profile file.\r\n {$EXTERNALSYM NERR_ProfileLoadErr}\r\n NERR_ProfileSaveErr = (NERR_BASE+275); // @W Errors occurred while saving the profile file. The profile was partially saved.\r\n {$EXTERNALSYM NERR_ProfileSaveErr}\r\n\r\n\r\n//\r\n// NetAudit and NetErrorLog\r\n// Error codes BASE+277 to BASE+279\r\n\r\n\r\n NERR_LogOverflow = (NERR_BASE+277); // Log file %1 is full.\r\n {$EXTERNALSYM NERR_LogOverflow}\r\n NERR_LogFileChanged = (NERR_BASE+278); // This log file has changed between reads.\r\n {$EXTERNALSYM NERR_LogFileChanged}\r\n NERR_LogFileCorrupt = (NERR_BASE+279); // Log file %1 is corrupt.\r\n {$EXTERNALSYM NERR_LogFileCorrupt}\r\n\r\n\r\n//\r\n// NetRemote\r\n// Error codes BASE+280 to BASE+299\r\n\r\n NERR_SourceIsDir = (NERR_BASE+280); // The source path cannot be a directory.\r\n {$EXTERNALSYM NERR_SourceIsDir}\r\n NERR_BadSource = (NERR_BASE+281); // The source path is illegal.\r\n {$EXTERNALSYM NERR_BadSource}\r\n NERR_BadDest = (NERR_BASE+282); // The destination path is illegal.\r\n {$EXTERNALSYM NERR_BadDest}\r\n NERR_DifferentServers = (NERR_BASE+283); // The source and destination paths are on different servers.\r\n {$EXTERNALSYM NERR_DifferentServers}\r\n// UNUSED BASE+284\r\n NERR_RunSrvPaused = (NERR_BASE+285); // The Run server you requested is paused.\r\n {$EXTERNALSYM NERR_RunSrvPaused}\r\n// UNUSED BASE+286\r\n// UNUSED BASE+287\r\n// UNUSED BASE+288\r\n NERR_ErrCommRunSrv = (NERR_BASE+289); // An error occurred when communicating with a Run server.\r\n {$EXTERNALSYM NERR_ErrCommRunSrv}\r\n// UNUSED BASE+290\r\n NERR_ErrorExecingGhost = (NERR_BASE+291); // An error occurred when starting a background process.\r\n {$EXTERNALSYM NERR_ErrorExecingGhost}\r\n NERR_ShareNotFound = (NERR_BASE+292); // The shared resource you are connected to could not be found.\r\n {$EXTERNALSYM NERR_ShareNotFound}\r\n// UNUSED BASE+293\r\n// UNUSED BASE+294\r\n\r\n\r\n//\r\n// NetWksta.sys (redir) returned error codes.\r\n//\r\n// NERR_BASE + (300-329)\r\n\r\n\r\n NERR_InvalidLana = (NERR_BASE+300); // The LAN adapter number is invalid.\r\n {$EXTERNALSYM NERR_InvalidLana}\r\n NERR_OpenFiles = (NERR_BASE+301); // There are open files on the connection.\r\n {$EXTERNALSYM NERR_OpenFiles}\r\n NERR_ActiveConns = (NERR_BASE+302); // Active connections still exist.\r\n {$EXTERNALSYM NERR_ActiveConns}\r\n NERR_BadPasswordCore = (NERR_BASE+303); // This share name or password is invalid.\r\n {$EXTERNALSYM NERR_BadPasswordCore}\r\n NERR_DevInUse = (NERR_BASE+304); // The device is being accessed by an active process.\r\n {$EXTERNALSYM NERR_DevInUse}\r\n NERR_LocalDrive = (NERR_BASE+305); // The drive letter is in use locally.\r\n {$EXTERNALSYM NERR_LocalDrive}\r\n\r\n//\r\n// Alert error codes.\r\n//\r\n// NERR_BASE + (330-339)\r\n\r\n NERR_AlertExists = (NERR_BASE+330); // The specified client is already registered for the specified event.\r\n {$EXTERNALSYM NERR_AlertExists}\r\n NERR_TooManyAlerts = (NERR_BASE+331); // The alert table is full.\r\n {$EXTERNALSYM NERR_TooManyAlerts}\r\n NERR_NoSuchAlert = (NERR_BASE+332); // An invalid or nonexistent alert name was raised.\r\n {$EXTERNALSYM NERR_NoSuchAlert}\r\n NERR_BadRecipient = (NERR_BASE+333); // The alert recipient is invalid.\r\n {$EXTERNALSYM NERR_BadRecipient}\r\n NERR_AcctLimitExceeded = (NERR_BASE+334); // A user's session with this server has been deleted\r\n {$EXTERNALSYM NERR_AcctLimitExceeded}\r\n // because the user's logon hours are no longer valid.\r\n\r\n//\r\n// Additional Error and Audit log codes.\r\n//\r\n// NERR_BASE +(340-343)\r\n\r\n NERR_InvalidLogSeek = (NERR_BASE+340); // The log file does not contain the requested record number.\r\n {$EXTERNALSYM NERR_InvalidLogSeek}\r\n// UNUSED BASE+341\r\n// UNUSED BASE+342\r\n// UNUSED BASE+343\r\n\r\n//\r\n// Additional UAS and NETLOGON codes\r\n//\r\n// NERR_BASE +(350-359)\r\n\r\n NERR_BadUasConfig = (NERR_BASE+350); // The user accounts database is not configured correctly.\r\n {$EXTERNALSYM NERR_BadUasConfig}\r\n NERR_InvalidUASOp = (NERR_BASE+351); // This operation is not permitted when the Netlogon service is running.\r\n {$EXTERNALSYM NERR_InvalidUASOp}\r\n NERR_LastAdmin = (NERR_BASE+352); // This operation is not allowed on the last administrative account.\r\n {$EXTERNALSYM NERR_LastAdmin}\r\n NERR_DCNotFound = (NERR_BASE+353); // Could not find domain controller for this domain.\r\n {$EXTERNALSYM NERR_DCNotFound}\r\n NERR_LogonTrackingError = (NERR_BASE+354); // Could not set logon information for this user.\r\n {$EXTERNALSYM NERR_LogonTrackingError}\r\n NERR_NetlogonNotStarted = (NERR_BASE+355); // The Netlogon service has not been started.\r\n {$EXTERNALSYM NERR_NetlogonNotStarted}\r\n NERR_CanNotGrowUASFile = (NERR_BASE+356); // Unable to add to the user accounts database.\r\n {$EXTERNALSYM NERR_CanNotGrowUASFile}\r\n NERR_TimeDiffAtDC = (NERR_BASE+357); // This server's clock is not synchronized with the primary domain controller's clock.\r\n {$EXTERNALSYM NERR_TimeDiffAtDC}\r\n NERR_PasswordMismatch = (NERR_BASE+358); // A password mismatch has been detected.\r\n {$EXTERNALSYM NERR_PasswordMismatch}\r\n\r\n\r\n//\r\n// Server Integration error codes.\r\n//\r\n// NERR_BASE +(360-369)\r\n\r\n NERR_NoSuchServer = (NERR_BASE+360); // The server identification does not specify a valid server.\r\n {$EXTERNALSYM NERR_NoSuchServer}\r\n NERR_NoSuchSession = (NERR_BASE+361); // The session identification does not specify a valid session.\r\n {$EXTERNALSYM NERR_NoSuchSession}\r\n NERR_NoSuchConnection = (NERR_BASE+362); // The connection identification does not specify a valid connection.\r\n {$EXTERNALSYM NERR_NoSuchConnection}\r\n NERR_TooManyServers = (NERR_BASE+363); // There is no space for another entry in the table of available servers.\r\n {$EXTERNALSYM NERR_TooManyServers}\r\n NERR_TooManySessions = (NERR_BASE+364); // The server has reached the maximum number of sessions it supports.\r\n {$EXTERNALSYM NERR_TooManySessions}\r\n NERR_TooManyConnections = (NERR_BASE+365); // The server has reached the maximum number of connections it supports.\r\n {$EXTERNALSYM NERR_TooManyConnections}\r\n NERR_TooManyFiles = (NERR_BASE+366); // The server cannot open more files because it has reached its maximum number.\r\n {$EXTERNALSYM NERR_TooManyFiles}\r\n NERR_NoAlternateServers = (NERR_BASE+367); // There are no alternate servers registered on this server.\r\n {$EXTERNALSYM NERR_NoAlternateServers}\r\n// UNUSED BASE+368\r\n// UNUSED BASE+369\r\n\r\n NERR_TryDownLevel = (NERR_BASE+370); // Try down-level (remote admin protocol) version of API instead.\r\n {$EXTERNALSYM NERR_TryDownLevel}\r\n\r\n//\r\n// UPS error codes.\r\n//\r\n// NERR_BASE + (380-384)\r\n\r\n NERR_UPSDriverNotStarted = (NERR_BASE+380); // The UPS driver could not be accessed by the UPS service.\r\n {$EXTERNALSYM NERR_UPSDriverNotStarted}\r\n NERR_UPSInvalidConfig = (NERR_BASE+381); // The UPS service is not configured correctly.\r\n {$EXTERNALSYM NERR_UPSInvalidConfig}\r\n NERR_UPSInvalidCommPort = (NERR_BASE+382); // The UPS service could not access the specified Comm Port.\r\n {$EXTERNALSYM NERR_UPSInvalidCommPort}\r\n NERR_UPSSignalAsserted = (NERR_BASE+383); // The UPS indicated a line fail or low battery situation. Service not started.\r\n {$EXTERNALSYM NERR_UPSSignalAsserted}\r\n NERR_UPSShutdownFailed = (NERR_BASE+384); // The UPS service failed to perform a system shut down.\r\n {$EXTERNALSYM NERR_UPSShutdownFailed}\r\n\r\n//\r\n// Remoteboot error codes.\r\n//\r\n// NERR_BASE + (400-419)\r\n// Error codes 400 - 405 are used by RPLBOOT.SYS.\r\n// Error codes 403, 407 - 416 are used by RPLLOADR.COM,\r\n// Error code 417 is the alerter message of REMOTEBOOT (RPLSERVR.EXE).\r\n// Error code 418 is for when REMOTEBOOT can't start\r\n// Error code 419 is for a disallowed 2nd rpl connection\r\n//\r\n\r\n NERR_BadDosRetCode = (NERR_BASE+400); // The program below returned an MS-DOS error code:\r\n {$EXTERNALSYM NERR_BadDosRetCode}\r\n NERR_ProgNeedsExtraMem = (NERR_BASE+401); // The program below needs more memory:\r\n {$EXTERNALSYM NERR_ProgNeedsExtraMem}\r\n NERR_BadDosFunction = (NERR_BASE+402); // The program below called an unsupported MS-DOS function:\r\n {$EXTERNALSYM NERR_BadDosFunction}\r\n NERR_RemoteBootFailed = (NERR_BASE+403); // The workstation failed to boot.\r\n {$EXTERNALSYM NERR_RemoteBootFailed}\r\n NERR_BadFileCheckSum = (NERR_BASE+404); // The file below is corrupt.\r\n {$EXTERNALSYM NERR_BadFileCheckSum}\r\n NERR_NoRplBootSystem = (NERR_BASE+405); // No loader is specified in the boot-block definition file.\r\n {$EXTERNALSYM NERR_NoRplBootSystem}\r\n NERR_RplLoadrNetBiosErr = (NERR_BASE+406); // NetBIOS returned an error: The NCB and SMB are dumped above.\r\n {$EXTERNALSYM NERR_RplLoadrNetBiosErr}\r\n NERR_RplLoadrDiskErr = (NERR_BASE+407); // A disk I/O error occurred.\r\n {$EXTERNALSYM NERR_RplLoadrDiskErr}\r\n NERR_ImageParamErr = (NERR_BASE+408); // Image parameter substitution failed.\r\n {$EXTERNALSYM NERR_ImageParamErr}\r\n NERR_TooManyImageParams = (NERR_BASE+409); // Too many image parameters cross disk sector boundaries.\r\n {$EXTERNALSYM NERR_TooManyImageParams}\r\n NERR_NonDosFloppyUsed = (NERR_BASE+410); // The image was not generated from an MS-DOS diskette formatted with /S.\r\n {$EXTERNALSYM NERR_NonDosFloppyUsed}\r\n NERR_RplBootRestart = (NERR_BASE+411); // Remote boot will be restarted later.\r\n {$EXTERNALSYM NERR_RplBootRestart}\r\n NERR_RplSrvrCallFailed = (NERR_BASE+412); // The call to the Remoteboot server failed.\r\n {$EXTERNALSYM NERR_RplSrvrCallFailed}\r\n NERR_CantConnectRplSrvr = (NERR_BASE+413); // Cannot connect to the Remoteboot server.\r\n {$EXTERNALSYM NERR_CantConnectRplSrvr}\r\n NERR_CantOpenImageFile = (NERR_BASE+414); // Cannot open image file on the Remoteboot server.\r\n {$EXTERNALSYM NERR_CantOpenImageFile}\r\n NERR_CallingRplSrvr = (NERR_BASE+415); // Connecting to the Remoteboot server...\r\n {$EXTERNALSYM NERR_CallingRplSrvr}\r\n NERR_StartingRplBoot = (NERR_BASE+416); // Connecting to the Remoteboot server...\r\n {$EXTERNALSYM NERR_StartingRplBoot}\r\n NERR_RplBootServiceTerm = (NERR_BASE+417); // Remote boot service was stopped; check the error log for the cause of the problem.\r\n {$EXTERNALSYM NERR_RplBootServiceTerm}\r\n NERR_RplBootStartFailed = (NERR_BASE+418); // Remote boot startup failed; check the error log for the cause of the problem.\r\n {$EXTERNALSYM NERR_RplBootStartFailed}\r\n NERR_RPL_CONNECTED = (NERR_BASE+419); // A second connection to a Remoteboot resource is not allowed.\r\n {$EXTERNALSYM NERR_RPL_CONNECTED}\r\n\r\n//\r\n// FTADMIN API error codes\r\n//\r\n// NERR_BASE + (425-434)\r\n//\r\n// (Currently not used in NT)\r\n//\r\n\r\n\r\n//\r\n// Browser service API error codes\r\n//\r\n// NERR_BASE + (450-475)\r\n//\r\n\r\n NERR_BrowserConfiguredToNotRun = (NERR_BASE+450); // The browser service was configured with MaintainServerList=No.\r\n {$EXTERNALSYM NERR_BrowserConfiguredToNotRun}\r\n\r\n//\r\n// Additional Remoteboot error codes.\r\n//\r\n// NERR_BASE + (510-550)\r\n\r\n NERR_RplNoAdaptersStarted = (NERR_BASE+510); // Service failed to start since none of the network adapters started with this service.\r\n {$EXTERNALSYM NERR_RplNoAdaptersStarted}\r\n NERR_RplBadRegistry = (NERR_BASE+511); // Service failed to start due to bad startup information in the registry.\r\n {$EXTERNALSYM NERR_RplBadRegistry}\r\n NERR_RplBadDatabase = (NERR_BASE+512); // Service failed to start because its database is absent or corrupt.\r\n {$EXTERNALSYM NERR_RplBadDatabase}\r\n NERR_RplRplfilesShare = (NERR_BASE+513); // Service failed to start because RPLFILES share is absent.\r\n {$EXTERNALSYM NERR_RplRplfilesShare}\r\n NERR_RplNotRplServer = (NERR_BASE+514); // Service failed to start because RPLUSER group is absent.\r\n {$EXTERNALSYM NERR_RplNotRplServer}\r\n NERR_RplCannotEnum = (NERR_BASE+515); // Cannot enumerate service records.\r\n {$EXTERNALSYM NERR_RplCannotEnum}\r\n NERR_RplWkstaInfoCorrupted = (NERR_BASE+516); // Workstation record information has been corrupted.\r\n {$EXTERNALSYM NERR_RplWkstaInfoCorrupted}\r\n NERR_RplWkstaNotFound = (NERR_BASE+517); // Workstation record was not found.\r\n {$EXTERNALSYM NERR_RplWkstaNotFound}\r\n NERR_RplWkstaNameUnavailable = (NERR_BASE+518); // Workstation name is in use by some other workstation.\r\n {$EXTERNALSYM NERR_RplWkstaNameUnavailable}\r\n NERR_RplProfileInfoCorrupted = (NERR_BASE+519); // Profile record information has been corrupted.\r\n {$EXTERNALSYM NERR_RplProfileInfoCorrupted}\r\n NERR_RplProfileNotFound = (NERR_BASE+520); // Profile record was not found.\r\n {$EXTERNALSYM NERR_RplProfileNotFound}\r\n NERR_RplProfileNameUnavailable = (NERR_BASE+521); // Profile name is in use by some other profile.\r\n {$EXTERNALSYM NERR_RplProfileNameUnavailable}\r\n NERR_RplProfileNotEmpty = (NERR_BASE+522); // There are workstations using this profile.\r\n {$EXTERNALSYM NERR_RplProfileNotEmpty}\r\n NERR_RplConfigInfoCorrupted = (NERR_BASE+523); // Configuration record information has been corrupted.\r\n {$EXTERNALSYM NERR_RplConfigInfoCorrupted}\r\n NERR_RplConfigNotFound = (NERR_BASE+524); // Configuration record was not found.\r\n {$EXTERNALSYM NERR_RplConfigNotFound}\r\n NERR_RplAdapterInfoCorrupted = (NERR_BASE+525); // Adapter id record information has been corrupted.\r\n {$EXTERNALSYM NERR_RplAdapterInfoCorrupted}\r\n NERR_RplInternal = (NERR_BASE+526); // An internal service error has occurred.\r\n {$EXTERNALSYM NERR_RplInternal}\r\n NERR_RplVendorInfoCorrupted = (NERR_BASE+527); // Vendor id record information has been corrupted.\r\n {$EXTERNALSYM NERR_RplVendorInfoCorrupted}\r\n NERR_RplBootInfoCorrupted = (NERR_BASE+528); // Boot block record information has been corrupted.\r\n {$EXTERNALSYM NERR_RplBootInfoCorrupted}\r\n NERR_RplWkstaNeedsUserAcct = (NERR_BASE+529); // The user account for this workstation record is missing.\r\n {$EXTERNALSYM NERR_RplWkstaNeedsUserAcct}\r\n NERR_RplNeedsRPLUSERAcct = (NERR_BASE+530); // The RPLUSER local group could not be found.\r\n {$EXTERNALSYM NERR_RplNeedsRPLUSERAcct}\r\n NERR_RplBootNotFound = (NERR_BASE+531); // Boot block record was not found.\r\n {$EXTERNALSYM NERR_RplBootNotFound}\r\n NERR_RplIncompatibleProfile = (NERR_BASE+532); // Chosen profile is incompatible with this workstation.\r\n {$EXTERNALSYM NERR_RplIncompatibleProfile}\r\n NERR_RplAdapterNameUnavailable = (NERR_BASE+533); // Chosen network adapter id is in use by some other workstation.\r\n {$EXTERNALSYM NERR_RplAdapterNameUnavailable}\r\n NERR_RplConfigNotEmpty = (NERR_BASE+534); // There are profiles using this configuration.\r\n {$EXTERNALSYM NERR_RplConfigNotEmpty}\r\n NERR_RplBootInUse = (NERR_BASE+535); // There are workstations, profiles or configurations using this boot block.\r\n {$EXTERNALSYM NERR_RplBootInUse}\r\n NERR_RplBackupDatabase = (NERR_BASE+536); // Service failed to backup Remoteboot database.\r\n {$EXTERNALSYM NERR_RplBackupDatabase}\r\n NERR_RplAdapterNotFound = (NERR_BASE+537); // Adapter record was not found.\r\n {$EXTERNALSYM NERR_RplAdapterNotFound}\r\n NERR_RplVendorNotFound = (NERR_BASE+538); // Vendor record was not found.\r\n {$EXTERNALSYM NERR_RplVendorNotFound}\r\n NERR_RplVendorNameUnavailable = (NERR_BASE+539); // Vendor name is in use by some other vendor record.\r\n {$EXTERNALSYM NERR_RplVendorNameUnavailable}\r\n NERR_RplBootNameUnavailable = (NERR_BASE+540); // (boot name, vendor id) is in use by some other boot block record.\r\n {$EXTERNALSYM NERR_RplBootNameUnavailable}\r\n NERR_RplConfigNameUnavailable = (NERR_BASE+541); // Configuration name is in use by some other configuration.\r\n {$EXTERNALSYM NERR_RplConfigNameUnavailable}\r\n\r\n//*INTERNAL_ONLY*\r\n\r\n//\r\n// Dfs API error codes.\r\n//\r\n// NERR_BASE + (560-590)\r\n\r\n\r\n NERR_DfsInternalCorruption = (NERR_BASE+560); // The internal database maintained by the DFS service is corrupt\r\n {$EXTERNALSYM NERR_DfsInternalCorruption}\r\n NERR_DfsVolumeDataCorrupt = (NERR_BASE+561); // One of the records in the internal DFS database is corrupt\r\n {$EXTERNALSYM NERR_DfsVolumeDataCorrupt}\r\n NERR_DfsNoSuchVolume = (NERR_BASE+562); // There is no DFS name whose entry path matches the input Entry Path\r\n {$EXTERNALSYM NERR_DfsNoSuchVolume}\r\n NERR_DfsVolumeAlreadyExists = (NERR_BASE+563); // A root or link with the given name already exists\r\n {$EXTERNALSYM NERR_DfsVolumeAlreadyExists}\r\n NERR_DfsAlreadyShared = (NERR_BASE+564); // The server share specified is already shared in the DFS\r\n {$EXTERNALSYM NERR_DfsAlreadyShared}\r\n NERR_DfsNoSuchShare = (NERR_BASE+565); // The indicated server share does not support the indicated DFS namespace\r\n {$EXTERNALSYM NERR_DfsNoSuchShare}\r\n NERR_DfsNotALeafVolume = (NERR_BASE+566); // The operation is not valid on this portion of the namespace\r\n {$EXTERNALSYM NERR_DfsNotALeafVolume}\r\n NERR_DfsLeafVolume = (NERR_BASE+567); // The operation is not valid on this portion of the namespace\r\n {$EXTERNALSYM NERR_DfsLeafVolume}\r\n NERR_DfsVolumeHasMultipleServers = (NERR_BASE+568); // The operation is ambiguous because the link has multiple servers\r\n {$EXTERNALSYM NERR_DfsVolumeHasMultipleServers}\r\n NERR_DfsCantCreateJunctionPoint = (NERR_BASE+569); // Unable to create a link\r\n {$EXTERNALSYM NERR_DfsCantCreateJunctionPoint}\r\n NERR_DfsServerNotDfsAware = (NERR_BASE+570); // The server is not DFS Aware\r\n {$EXTERNALSYM NERR_DfsServerNotDfsAware}\r\n NERR_DfsBadRenamePath = (NERR_BASE+571); // The specified rename target path is invalid\r\n {$EXTERNALSYM NERR_DfsBadRenamePath}\r\n NERR_DfsVolumeIsOffline = (NERR_BASE+572); // The specified DFS link is offline\r\n {$EXTERNALSYM NERR_DfsVolumeIsOffline}\r\n NERR_DfsNoSuchServer = (NERR_BASE+573); // The specified server is not a server for this link\r\n {$EXTERNALSYM NERR_DfsNoSuchServer}\r\n NERR_DfsCyclicalName = (NERR_BASE+574); // A cycle in the DFS name was detected\r\n {$EXTERNALSYM NERR_DfsCyclicalName}\r\n NERR_DfsNotSupportedInServerDfs = (NERR_BASE+575); // The operation is not supported on a server-based DFS\r\n {$EXTERNALSYM NERR_DfsNotSupportedInServerDfs}\r\n NERR_DfsDuplicateService = (NERR_BASE+576); // This link is already supported by the specified server-share\r\n {$EXTERNALSYM NERR_DfsDuplicateService}\r\n NERR_DfsCantRemoveLastServerShare = (NERR_BASE+577); // Can't remove the last server-share supporting this root or link\r\n {$EXTERNALSYM NERR_DfsCantRemoveLastServerShare}\r\n NERR_DfsVolumeIsInterDfs = (NERR_BASE+578); // The operation is not supported for an Inter-DFS link\r\n {$EXTERNALSYM NERR_DfsVolumeIsInterDfs}\r\n NERR_DfsInconsistent = (NERR_BASE+579); // The internal state of the DFS Service has become inconsistent\r\n {$EXTERNALSYM NERR_DfsInconsistent}\r\n NERR_DfsServerUpgraded = (NERR_BASE+580); // The DFS Service has been installed on the specified server\r\n {$EXTERNALSYM NERR_DfsServerUpgraded}\r\n NERR_DfsDataIsIdentical = (NERR_BASE+581); // The DFS data being reconciled is identical\r\n {$EXTERNALSYM NERR_DfsDataIsIdentical}\r\n NERR_DfsCantRemoveDfsRoot = (NERR_BASE+582); // The DFS root cannot be deleted - Uninstall DFS if required\r\n {$EXTERNALSYM NERR_DfsCantRemoveDfsRoot}\r\n NERR_DfsChildOrParentInDfs = (NERR_BASE+583); // A child or parent directory of the share is already in a DFS\r\n {$EXTERNALSYM NERR_DfsChildOrParentInDfs}\r\n NERR_DfsInternalError = (NERR_BASE+590); // DFS internal error\r\n {$EXTERNALSYM NERR_DfsInternalError}\r\n\r\n//\r\n// Net setup error codes.\r\n//\r\n// NERR_BASE + (591-600)\r\n\r\n NERR_SetupAlreadyJoined = (NERR_BASE+591); // This machine is already joined to a domain.\r\n {$EXTERNALSYM NERR_SetupAlreadyJoined}\r\n NERR_SetupNotJoined = (NERR_BASE+592); // This machine is not currently joined to a domain.\r\n {$EXTERNALSYM NERR_SetupNotJoined}\r\n NERR_SetupDomainController = (NERR_BASE+593); // This machine is a domain controller and cannot be unjoined from a domain.\r\n {$EXTERNALSYM NERR_SetupDomainController}\r\n NERR_DefaultJoinRequired = (NERR_BASE+594); // The destination domain controller does not support creating machine accounts in OUs.\r\n {$EXTERNALSYM NERR_DefaultJoinRequired}\r\n NERR_InvalidWorkgroupName = (NERR_BASE+595); // The specified workgroup name is invalid.\r\n {$EXTERNALSYM NERR_InvalidWorkgroupName}\r\n NERR_NameUsesIncompatibleCodePage = (NERR_BASE+596); // The specified computer name is incompatible with the default language used on the domain controller.\r\n {$EXTERNALSYM NERR_NameUsesIncompatibleCodePage}\r\n NERR_ComputerAccountNotFound = (NERR_BASE+597); // The specified computer account could not be found.\r\n {$EXTERNALSYM NERR_ComputerAccountNotFound}\r\n NERR_PersonalSku = (NERR_BASE+598); // This version of Windows cannot be joined to a domain.\r\n {$EXTERNALSYM NERR_PersonalSku}\r\n\r\n//\r\n// Some Password and account error results\r\n//\r\n// NERR_BASE + (601 - 608)\r\n//\r\n\r\n NERR_PasswordMustChange = (NERR_BASE + 601); // Password must change at next logon\r\n {$EXTERNALSYM NERR_PasswordMustChange}\r\n NERR_AccountLockedOut = (NERR_BASE + 602); // Account is locked out\r\n {$EXTERNALSYM NERR_AccountLockedOut}\r\n NERR_PasswordTooLong = (NERR_BASE + 603); // Password is too long\r\n {$EXTERNALSYM NERR_PasswordTooLong}\r\n NERR_PasswordNotComplexEnough = (NERR_BASE + 604); // Password doesn't meet the complexity policy\r\n {$EXTERNALSYM NERR_PasswordNotComplexEnough}\r\n NERR_PasswordFilterError = (NERR_BASE + 605); // Password doesn't meet the requirements of the filter dll's\r\n {$EXTERNALSYM NERR_PasswordFilterError}\r\n\r\n//**********WARNING ****************\r\n//The range 2750-2799 has been *\r\n//allocated to the IBM LAN Server *\r\n//*********************************\r\n\r\n//**********WARNING ****************\r\n//The range 2900-2999 has been *\r\n//reserved for Microsoft OEMs *\r\n//*********************************\r\n\r\n//*END_INTERNAL*\r\n\r\n MAX_NERR = (NERR_BASE+899); // This is the last error in NERR range.\r\n {$EXTERNALSYM MAX_NERR}\r\n\r\n//\r\n// end of list\r\n//\r\n// WARNING: Do not exceed MAX_NERR; values above this are used by\r\n// other error code ranges (errlog.h, service.h, apperr.h).\r\n\r\n// JwaLmCons, complete\r\n// LAN Manager common definitions\r\n\r\nconst\r\n NetApi32 = 'netapi32.dll';\r\n\r\n//\r\n// NOTE: Lengths of strings are given as the maximum lengths of the\r\n// string in characters (not bytes). This does not include space for the\r\n// terminating 0-characters. When allocating space for such an item,\r\n// use the form:\r\n//\r\n// TCHAR username[UNLEN+1];\r\n//\r\n// Definitions of the form LN20_* define those values in effect for\r\n// LanMan 2.0.\r\n//\r\n\r\n//\r\n// String Lengths for various LanMan names\r\n//\r\n\r\nconst\r\n CNLEN = 15; // Computer name length\r\n {$EXTERNALSYM CNLEN}\r\n LM20_CNLEN = 15; // LM 2.0 Computer name length\r\n {$EXTERNALSYM LM20_CNLEN}\r\n DNLEN = CNLEN; // Maximum domain name length\r\n {$EXTERNALSYM DNLEN}\r\n LM20_DNLEN = LM20_CNLEN; // LM 2.0 Maximum domain name length\r\n {$EXTERNALSYM LM20_DNLEN}\r\n\r\n//#if (CNLEN != DNLEN)\r\n//#error CNLEN and DNLEN are not equal\r\n//#endif\r\n\r\n UNCLEN = (CNLEN+2); // UNC computer name length\r\n {$EXTERNALSYM UNCLEN}\r\n LM20_UNCLEN = (LM20_CNLEN+2); // LM 2.0 UNC computer name length\r\n {$EXTERNALSYM LM20_UNCLEN}\r\n\r\n NNLEN = 80; // Net name length (share name)\r\n {$EXTERNALSYM NNLEN}\r\n LM20_NNLEN = 12; // LM 2.0 Net name length\r\n {$EXTERNALSYM LM20_NNLEN}\r\n\r\n RMLEN = (UNCLEN+1+NNLEN); // Max remote name length\r\n {$EXTERNALSYM RMLEN}\r\n LM20_RMLEN = (LM20_UNCLEN+1+LM20_NNLEN); // LM 2.0 Max remote name length\r\n {$EXTERNALSYM LM20_RMLEN}\r\n\r\n SNLEN = 80; // Service name length\r\n {$EXTERNALSYM SNLEN}\r\n LM20_SNLEN = 15; // LM 2.0 Service name length\r\n {$EXTERNALSYM LM20_SNLEN}\r\n STXTLEN = 256; // Service text length\r\n {$EXTERNALSYM STXTLEN}\r\n LM20_STXTLEN = 63; // LM 2.0 Service text length\r\n {$EXTERNALSYM LM20_STXTLEN}\r\n\r\n PATHLEN = 256; // Max. path (not including drive name)\r\n {$EXTERNALSYM PATHLEN}\r\n LM20_PATHLEN = 256; // LM 2.0 Max. path\r\n {$EXTERNALSYM LM20_PATHLEN}\r\n\r\n DEVLEN = 80; // Device name length\r\n {$EXTERNALSYM DEVLEN}\r\n LM20_DEVLEN = 8; // LM 2.0 Device name length\r\n {$EXTERNALSYM LM20_DEVLEN}\r\n\r\n EVLEN = 16; // Event name length\r\n {$EXTERNALSYM EVLEN}\r\n\r\n//\r\n// User, Group and Password lengths\r\n//\r\n\r\n UNLEN = 256; // Maximum user name length\r\n {$EXTERNALSYM UNLEN}\r\n LM20_UNLEN = 20; // LM 2.0 Maximum user name length\r\n {$EXTERNALSYM LM20_UNLEN}\r\n\r\n GNLEN = UNLEN; // Group name\r\n {$EXTERNALSYM GNLEN}\r\n LM20_GNLEN = LM20_UNLEN; // LM 2.0 Group name\r\n {$EXTERNALSYM LM20_GNLEN}\r\n\r\n PWLEN = 256; // Maximum password length\r\n {$EXTERNALSYM PWLEN}\r\n LM20_PWLEN = 14; // LM 2.0 Maximum password length\r\n {$EXTERNALSYM LM20_PWLEN}\r\n\r\n SHPWLEN = 8; // Share password length (bytes)\r\n {$EXTERNALSYM SHPWLEN}\r\n\r\n CLTYPE_LEN = 12; // Length of client type string\r\n {$EXTERNALSYM CLTYPE_LEN}\r\n\r\n MAXCOMMENTSZ = 256; // Multipurpose comment length\r\n {$EXTERNALSYM MAXCOMMENTSZ}\r\n LM20_MAXCOMMENTSZ = 48; // LM 2.0 Multipurpose comment length\r\n {$EXTERNALSYM LM20_MAXCOMMENTSZ}\r\n\r\n QNLEN = NNLEN; // Queue name maximum length\r\n {$EXTERNALSYM QNLEN}\r\n LM20_QNLEN = LM20_NNLEN; // LM 2.0 Queue name maximum length\r\n {$EXTERNALSYM LM20_QNLEN}\r\n\r\n//#if (QNLEN != NNLEN)\r\n//# error QNLEN and NNLEN are not equal\r\n//#endif\r\n\r\n//\r\n// The ALERTSZ and MAXDEVENTRIES defines have not yet been NT'ized.\r\n// Whoever ports these components should change these values appropriately.\r\n//\r\n\r\n ALERTSZ = 128; // size of alert string in server\r\n {$EXTERNALSYM ALERTSZ}\r\n MAXDEVENTRIES = (SizeOf(Integer)*8); // Max number of device entries\r\n {$EXTERNALSYM MAXDEVENTRIES}\r\n\r\n //\r\n // We use int bitmap to represent\r\n //\r\n\r\n NETBIOS_NAME_LEN = 16; // NetBIOS net name (bytes)\r\n {$EXTERNALSYM NETBIOS_NAME_LEN}\r\n\r\n//\r\n// Value to be used with APIs which have a \"preferred maximum length\"\r\n// parameter. This value indicates that the API should just allocate\r\n// \"as much as it takes.\"\r\n//\r\n\r\n MAX_PREFERRED_LENGTH = DWORD(-1);\r\n {$EXTERNALSYM MAX_PREFERRED_LENGTH}\r\n\r\n//\r\n// Constants used with encryption\r\n//\r\n\r\n CRYPT_KEY_LEN = 7;\r\n {$EXTERNALSYM CRYPT_KEY_LEN}\r\n CRYPT_TXT_LEN = 8;\r\n {$EXTERNALSYM CRYPT_TXT_LEN}\r\n ENCRYPTED_PWLEN = 16;\r\n {$EXTERNALSYM ENCRYPTED_PWLEN}\r\n SESSION_PWLEN = 24;\r\n {$EXTERNALSYM SESSION_PWLEN}\r\n SESSION_CRYPT_KLEN = 21;\r\n {$EXTERNALSYM SESSION_CRYPT_KLEN}\r\n\r\n//\r\n// Value to be used with SetInfo calls to allow setting of all\r\n// settable parameters (parmnum zero option)\r\n//\r\n\r\n PARMNUM_ALL = 0;\r\n {$EXTERNALSYM PARMNUM_ALL}\r\n\r\n PARM_ERROR_UNKNOWN = DWORD(-1);\r\n {$EXTERNALSYM PARM_ERROR_UNKNOWN}\r\n PARM_ERROR_NONE = 0;\r\n {$EXTERNALSYM PARM_ERROR_NONE}\r\n PARMNUM_BASE_INFOLEVEL = 1000;\r\n {$EXTERNALSYM PARMNUM_BASE_INFOLEVEL}\r\n\r\n//\r\n// Only the UNICODE version of the LM APIs are available on NT.\r\n// Non-UNICODE version on other platforms\r\n//\r\n\r\n//#if defined( _WIN32_WINNT ) || defined( WINNT ) || defined( FORCE_UNICODE )\r\n\r\n{$IFDEF _WIN32_WINNT}\r\n{$DEFINE LM_USE_UNICODE}\r\n{$ENDIF}\r\n\r\n{$IFDEF FORCE_UNICODE}\r\n{$DEFINE LM_USE_UNICODE}\r\n{$ENDIF}\r\n\r\n{$IFDEF LM_USE_UNICODE}\r\n\r\ntype\r\n LMSTR = LPWSTR;\r\n {$EXTERNALSYM LMSTR}\r\n LMCSTR = LPCWSTR;\r\n {$EXTERNALSYM LMCSTR}\r\n PLMSTR = ^LMSTR;\r\n {$NODEFINE PLMSTR}\r\n\r\n{$ELSE ~LM_USE_UNICODE}\r\n\r\ntype\r\n LMSTR = LPSTR;\r\n {$EXTERNALSYM LMSTR}\r\n LMCSTR = LPCSTR;\r\n {$EXTERNALSYM LMCSTR}\r\n\r\n{$ENDIF ~LM_USE_UNICODE}\r\n\r\n//\r\n// Message File Names\r\n//\r\n\r\nconst\r\n MESSAGE_FILENAME = 'NETMSG';\r\n {$EXTERNALSYM MESSAGE_FILENAME}\r\n OS2MSG_FILENAME = 'BASE';\r\n {$EXTERNALSYM OS2MSG_FILENAME}\r\n HELP_MSG_FILENAME = 'NETH';\r\n {$EXTERNALSYM HELP_MSG_FILENAME}\r\n\r\n// ** INTERNAL_ONLY **\r\n\r\n// The backup message file named here is a duplicate of net.msg. It\r\n// is not shipped with the product, but is used at buildtime to\r\n// msgbind certain messages to netapi.dll and some of the services.\r\n// This allows for OEMs to modify the message text in net.msg and\r\n// have those changes show up. Only in case there is an error in\r\n// retrieving the messages from net.msg do we then get the bound\r\n// messages out of bak.msg (really out of the message segment).\r\n\r\n BACKUP_MSG_FILENAME = 'BAK.MSG';\r\n {$EXTERNALSYM BACKUP_MSG_FILENAME}\r\n\r\n// ** END_INTERNAL **\r\n\r\n//\r\n// Keywords used in Function Prototypes\r\n//\r\n\r\ntype\r\n NET_API_STATUS = DWORD;\r\n {$EXTERNALSYM NET_API_STATUS}\r\n TNetApiStatus = NET_API_STATUS;\r\n\r\n//\r\n// The platform ID indicates the levels to use for platform-specific\r\n// information.\r\n//\r\n\r\nconst\r\n PLATFORM_ID_DOS = 300;\r\n {$EXTERNALSYM PLATFORM_ID_DOS}\r\n PLATFORM_ID_OS2 = 400;\r\n {$EXTERNALSYM PLATFORM_ID_OS2}\r\n PLATFORM_ID_NT = 500;\r\n {$EXTERNALSYM PLATFORM_ID_NT}\r\n PLATFORM_ID_OSF = 600;\r\n {$EXTERNALSYM PLATFORM_ID_OSF}\r\n PLATFORM_ID_VMS = 700;\r\n {$EXTERNALSYM PLATFORM_ID_VMS}\r\n\r\n//\r\n// There message numbers assigned to different LANMAN components\r\n// are as defined below.\r\n//\r\n// lmerr.h: 2100 - 2999 NERR_BASE\r\n// alertmsg.h: 3000 - 3049 ALERT_BASE\r\n// lmsvc.h: 3050 - 3099 SERVICE_BASE\r\n// lmerrlog.h: 3100 - 3299 ERRLOG_BASE\r\n// msgtext.h: 3300 - 3499 MTXT_BASE\r\n// apperr.h: 3500 - 3999 APPERR_BASE\r\n// apperrfs.h: 4000 - 4299 APPERRFS_BASE\r\n// apperr2.h: 4300 - 5299 APPERR2_BASE\r\n// ncberr.h: 5300 - 5499 NRCERR_BASE\r\n// alertmsg.h: 5500 - 5599 ALERT2_BASE\r\n// lmsvc.h: 5600 - 5699 SERVICE2_BASE\r\n// lmerrlog.h 5700 - 5899 ERRLOG2_BASE\r\n//\r\n\r\n MIN_LANMAN_MESSAGE_ID = NERR_BASE;\r\n {$EXTERNALSYM MIN_LANMAN_MESSAGE_ID}\r\n MAX_LANMAN_MESSAGE_ID = 5899;\r\n {$EXTERNALSYM MAX_LANMAN_MESSAGE_ID}\r\n\r\n// line 59\r\n\r\n//\r\n// Function Prototypes - User\r\n//\r\n\r\n\r\nfunction NetUserAdd(servername: LPCWSTR; level: DWORD; buf: PByte; parm_err: LPDWORD): NET_API_STATUS; stdcall;\r\n{$EXTERNALSYM NetUserAdd}\r\n\r\nfunction NetUserEnum(servername: LPCWSTR; level, filter: DWORD; var bufptr: PByte; prefmaxlen: DWORD; entriesread, totalentries, resume_handle: LPDWORD): NET_API_STATUS; stdcall;\r\n{$EXTERNALSYM NetUserEnum}\r\n\r\nfunction NetUserGetInfo(servername, username: LPCWSTR; level: DWORD; var bufptr: PByte): NET_API_STATUS; stdcall;\r\n{$EXTERNALSYM NetUserGetInfo}\r\n\r\nfunction NetUserSetInfo(servername, username: LPCWSTR; level: DWORD; buf: PByte; parm_err: LPDWORD): NET_API_STATUS; stdcall;\r\n{$EXTERNALSYM NetUserSetInfo}\r\n\r\nfunction NetUserDel(servername: LPCWSTR; username: LPCWSTR): NET_API_STATUS; stdcall;\r\n{$EXTERNALSYM NetUserDel}\r\n\r\nfunction NetUserGetGroups(servername, username: LPCWSTR; level: DWORD; var bufptr: PByte; prefmaxlen: DWORD; entriesread, totalentries: LPDWORD): NET_API_STATUS; stdcall;\r\n{$EXTERNALSYM NetUserGetGroups}\r\n\r\nfunction NetUserSetGroups(servername, username: LPCWSTR; level: DWORD; buf: PByte; num_entries: DWORD): NET_API_STATUS; stdcall;\r\n{$EXTERNALSYM NetUserSetGroups}\r\n\r\nfunction NetUserGetLocalGroups(servername, username: LPCWSTR; level, flags: DWORD; var bufptr: PByte; prefmaxlen: DWORD; entriesread, totalentries: LPDWORD): NET_API_STATUS; stdcall;\r\n{$EXTERNALSYM NetUserGetLocalGroups}\r\n\r\nfunction NetUserModalsGet(servername: LPCWSTR; level: DWORD; var bufptr: PByte): NET_API_STATUS; stdcall;\r\n{$EXTERNALSYM NetUserModalsGet}\r\n\r\nfunction NetUserModalsSet(servername: LPCWSTR; level: DWORD; buf: PByte; parm_err: LPDWORD): NET_API_STATUS; stdcall;\r\n{$EXTERNALSYM NetUserModalsSet}\r\n\r\nfunction NetUserChangePassword(domainname, username, oldpassword, newpassword: LPCWSTR): NET_API_STATUS; stdcall;\r\n{$EXTERNALSYM NetUserChangePassword}\r\n\r\n\r\n//\r\n// Data Structures - User\r\n//\r\n\r\ntype\r\n {$IFNDEF FPC}\r\n LPUSER_INFO_0 = ^USER_INFO_0;\r\n {$EXTERNALSYM LPUSER_INFO_0}\r\n PUSER_INFO_0 = ^USER_INFO_0;\r\n {$EXTERNALSYM PUSER_INFO_0}\r\n _USER_INFO_0 = record\r\n usri0_name: LPWSTR;\r\n end;\r\n {$EXTERNALSYM _USER_INFO_0}\r\n USER_INFO_0 = _USER_INFO_0;\r\n {$EXTERNALSYM USER_INFO_0}\r\n TUserInfo0 = USER_INFO_0;\r\n PUserInfo0 = PUSER_INFO_0;\r\n {$ENDIF ~FPC}\r\n\r\n LPUSER_INFO_1 = ^USER_INFO_1;\r\n {$EXTERNALSYM LPUSER_INFO_1}\r\n PUSER_INFO_1 = ^USER_INFO_1;\r\n {$EXTERNALSYM PUSER_INFO_1}\r\n _USER_INFO_1 = record\r\n usri1_name: LPWSTR;\r\n usri1_password: LPWSTR;\r\n usri1_password_age: DWORD;\r\n usri1_priv: DWORD;\r\n usri1_home_dir: LPWSTR;\r\n usri1_comment: LPWSTR;\r\n usri1_flags: DWORD;\r\n usri1_script_path: LPWSTR;\r\n end;\r\n {$EXTERNALSYM _USER_INFO_1}\r\n USER_INFO_1 = _USER_INFO_1;\r\n {$EXTERNALSYM USER_INFO_1}\r\n TUserInfo1 = USER_INFO_1;\r\n PUserInfo1 = PUSER_INFO_1;\r\n\r\n {$IFNDEF FPC}\r\n LPUSER_INFO_2 = ^USER_INFO_2;\r\n {$EXTERNALSYM LPUSER_INFO_2}\r\n PUSER_INFO_2 = ^USER_INFO_2;\r\n {$EXTERNALSYM PUSER_INFO_2}\r\n _USER_INFO_2 = record\r\n usri2_name: LPWSTR;\r\n usri2_password: LPWSTR;\r\n usri2_password_age: DWORD;\r\n usri2_priv: DWORD;\r\n usri2_home_dir: LPWSTR;\r\n usri2_comment: LPWSTR;\r\n usri2_flags: DWORD;\r\n usri2_script_path: LPWSTR;\r\n usri2_auth_flags: DWORD;\r\n usri2_full_name: LPWSTR;\r\n usri2_usr_comment: LPWSTR;\r\n usri2_parms: LPWSTR;\r\n usri2_workstations: LPWSTR;\r\n usri2_last_logon: DWORD;\r\n usri2_last_logoff: DWORD;\r\n usri2_acct_expires: DWORD;\r\n usri2_max_storage: DWORD;\r\n usri2_units_per_week: DWORD;\r\n usri2_logon_hours: PBYTE;\r\n usri2_bad_pw_count: DWORD;\r\n usri2_num_logons: DWORD;\r\n usri2_logon_server: LPWSTR;\r\n usri2_country_code: DWORD;\r\n usri2_code_page: DWORD;\r\n end;\r\n {$EXTERNALSYM _USER_INFO_2}\r\n USER_INFO_2 = _USER_INFO_2;\r\n {$EXTERNALSYM USER_INFO_2}\r\n TUserInfo2 = USER_INFO_2;\r\n PUserInfo2 = puser_info_2;\r\n {$ENDIF ~FPC}\r\n\r\n// line 799\r\n\r\n//\r\n// Special Values and Constants - User\r\n//\r\n\r\n//\r\n// Bit masks for field usriX_flags of USER_INFO_X (X = 0/1).\r\n//\r\n\r\nconst\r\n UF_SCRIPT = $0001;\r\n {$EXTERNALSYM UF_SCRIPT}\r\n UF_ACCOUNTDISABLE = $0002;\r\n {$EXTERNALSYM UF_ACCOUNTDISABLE}\r\n UF_HOMEDIR_REQUIRED = $0008;\r\n {$EXTERNALSYM UF_HOMEDIR_REQUIRED}\r\n UF_LOCKOUT = $0010;\r\n {$EXTERNALSYM UF_LOCKOUT}\r\n UF_PASSWD_NOTREQD = $0020;\r\n {$EXTERNALSYM UF_PASSWD_NOTREQD}\r\n UF_PASSWD_CANT_CHANGE = $0040;\r\n {$EXTERNALSYM UF_PASSWD_CANT_CHANGE}\r\n UF_ENCRYPTED_TEXT_PASSWORD_ALLOWED = $0080;\r\n {$EXTERNALSYM UF_ENCRYPTED_TEXT_PASSWORD_ALLOWED}\r\n\r\n//\r\n// Account type bits as part of usri_flags.\r\n//\r\n\r\n UF_TEMP_DUPLICATE_ACCOUNT = $0100;\r\n {$EXTERNALSYM UF_TEMP_DUPLICATE_ACCOUNT}\r\n UF_NORMAL_ACCOUNT = $0200;\r\n {$EXTERNALSYM UF_NORMAL_ACCOUNT}\r\n UF_INTERDOMAIN_TRUST_ACCOUNT = $0800;\r\n {$EXTERNALSYM UF_INTERDOMAIN_TRUST_ACCOUNT}\r\n UF_WORKSTATION_TRUST_ACCOUNT = $1000;\r\n {$EXTERNALSYM UF_WORKSTATION_TRUST_ACCOUNT}\r\n UF_SERVER_TRUST_ACCOUNT = $2000;\r\n {$EXTERNALSYM UF_SERVER_TRUST_ACCOUNT}\r\n\r\n UF_MACHINE_ACCOUNT_MASK = UF_INTERDOMAIN_TRUST_ACCOUNT or UF_WORKSTATION_TRUST_ACCOUNT or UF_SERVER_TRUST_ACCOUNT;\r\n {$EXTERNALSYM UF_MACHINE_ACCOUNT_MASK}\r\n\r\n UF_ACCOUNT_TYPE_MASK = UF_TEMP_DUPLICATE_ACCOUNT or UF_NORMAL_ACCOUNT or\r\n UF_INTERDOMAIN_TRUST_ACCOUNT or UF_WORKSTATION_TRUST_ACCOUNT or UF_SERVER_TRUST_ACCOUNT;\r\n {$EXTERNALSYM UF_ACCOUNT_TYPE_MASK}\r\n\r\n UF_DONT_EXPIRE_PASSWD = $10000;\r\n {$EXTERNALSYM UF_DONT_EXPIRE_PASSWD}\r\n UF_MNS_LOGON_ACCOUNT = $20000;\r\n {$EXTERNALSYM UF_MNS_LOGON_ACCOUNT}\r\n UF_SMARTCARD_REQUIRED = $40000;\r\n {$EXTERNALSYM UF_SMARTCARD_REQUIRED}\r\n UF_TRUSTED_FOR_DELEGATION = $80000;\r\n {$EXTERNALSYM UF_TRUSTED_FOR_DELEGATION}\r\n UF_NOT_DELEGATED = $100000;\r\n {$EXTERNALSYM UF_NOT_DELEGATED}\r\n UF_USE_DES_KEY_ONLY = $200000;\r\n {$EXTERNALSYM UF_USE_DES_KEY_ONLY}\r\n UF_DONT_REQUIRE_PREAUTH = $400000;\r\n {$EXTERNALSYM UF_DONT_REQUIRE_PREAUTH}\r\n UF_PASSWORD_EXPIRED = DWORD($800000);\r\n {$EXTERNALSYM UF_PASSWORD_EXPIRED}\r\n UF_TRUSTED_TO_AUTHENTICATE_FOR_DELEGATION = $1000000;\r\n {$EXTERNALSYM UF_TRUSTED_TO_AUTHENTICATE_FOR_DELEGATION}\r\n\r\n\r\n UF_SETTABLE_BITS =\r\n UF_SCRIPT or\r\n UF_ACCOUNTDISABLE or\r\n UF_LOCKOUT or\r\n UF_HOMEDIR_REQUIRED or\r\n UF_PASSWD_NOTREQD or\r\n UF_PASSWD_CANT_CHANGE or\r\n UF_ACCOUNT_TYPE_MASK or\r\n UF_DONT_EXPIRE_PASSWD or\r\n UF_MNS_LOGON_ACCOUNT or\r\n UF_ENCRYPTED_TEXT_PASSWORD_ALLOWED or\r\n UF_SMARTCARD_REQUIRED or\r\n UF_TRUSTED_FOR_DELEGATION or\r\n UF_NOT_DELEGATED or\r\n UF_USE_DES_KEY_ONLY or\r\n UF_DONT_REQUIRE_PREAUTH or\r\n UF_PASSWORD_EXPIRED or\r\n UF_TRUSTED_TO_AUTHENTICATE_FOR_DELEGATION;\r\n {$EXTERNALSYM UF_SETTABLE_BITS}\r\n\r\n// line 1056\r\n\r\n//\r\n// For SetInfo call (parmnum 0) when password change not required\r\n//\r\n\r\n NULL_USERSETINFO_PASSWD = ' ';\r\n {$EXTERNALSYM NULL_USERSETINFO_PASSWD}\r\n\r\n TIMEQ_FOREVER = ULONG(-1);\r\n {$EXTERNALSYM TIMEQ_FOREVER}\r\n USER_MAXSTORAGE_UNLIMITED = ULONG(-1);\r\n {$EXTERNALSYM USER_MAXSTORAGE_UNLIMITED}\r\n USER_NO_LOGOFF = ULONG(-1);\r\n {$EXTERNALSYM USER_NO_LOGOFF}\r\n UNITS_PER_DAY = 24;\r\n {$EXTERNALSYM UNITS_PER_DAY}\r\n UNITS_PER_WEEK = UNITS_PER_DAY * 7;\r\n {$EXTERNALSYM UNITS_PER_WEEK}\r\n\r\n//\r\n// Privilege levels (USER_INFO_X field usriX_priv (X = 0/1)).\r\n//\r\n\r\n USER_PRIV_MASK = $3;\r\n {$EXTERNALSYM USER_PRIV_MASK}\r\n USER_PRIV_GUEST = 0;\r\n {$EXTERNALSYM USER_PRIV_GUEST}\r\n USER_PRIV_USER = 1;\r\n {$EXTERNALSYM USER_PRIV_USER}\r\n USER_PRIV_ADMIN = 2;\r\n {$EXTERNALSYM USER_PRIV_ADMIN}\r\n\r\n// line 1177\r\n \r\n//\r\n// Group Class\r\n//\r\n\r\n//\r\n// Function Prototypes\r\n//\r\n\r\n\r\nfunction NetGroupAdd(servername: LPCWSTR; level: DWORD; buf: PByte; parm_err: LPDWORD): NET_API_STATUS; stdcall;\r\n{$EXTERNALSYM NetGroupAdd}\r\n\r\nfunction NetGroupAddUser(servername, GroupName, username: LPCWSTR): NET_API_STATUS; stdcall;\r\n{$EXTERNALSYM NetGroupAddUser}\r\n\r\nfunction NetGroupEnum(servername: LPCWSTR; level: DWORD; out bufptr: PByte;\r\n prefmaxlen: DWORD; out entriesread, totalentries: DWORD; resume_handle: PDWORD_PTR): NET_API_STATUS; stdcall;\r\n{$EXTERNALSYM NetGroupEnum}\r\n\r\nfunction NetGroupGetInfo(servername, groupname: LPCWSTR; level: DWORD; bufptr: PByte): NET_API_STATUS; stdcall;\r\n{$EXTERNALSYM NetGroupGetInfo}\r\n\r\nfunction NetGroupSetInfo(servername, groupname: LPCWSTR; level: DWORD; buf: PByte; parm_err: LPDWORD): NET_API_STATUS; stdcall;\r\n{$EXTERNALSYM NetGroupSetInfo}\r\n\r\nfunction NetGroupDel(servername: LPCWSTR; groupname: LPCWSTR): NET_API_STATUS; stdcall;\r\n{$EXTERNALSYM NetGroupDel}\r\n\r\nfunction NetGroupDelUser(servername: LPCWSTR; GroupName: LPCWSTR; Username: LPCWSTR): NET_API_STATUS; stdcall;\r\n{$EXTERNALSYM NetGroupDelUser}\r\n\r\nfunction NetGroupGetUsers(servername, groupname: LPCWSTR; level: DWORD; var bufptr: PByte; prefmaxlen: DWORD; entriesread, totalentries: LPDWORD; ResumeHandle: PDWORD_PTR): NET_API_STATUS; stdcall;\r\n{$EXTERNALSYM NetGroupGetUsers}\r\n\r\nfunction NetGroupSetUsers(servername, groupname: LPCWSTR; level: DWORD; buf: PByte; totalentries: DWORD): NET_API_STATUS; stdcall;\r\n{$EXTERNALSYM NetGroupSetUsers}\r\n\r\n\r\n//\r\n// Data Structures - Group\r\n//\r\n\r\ntype\r\n LPGROUP_INFO_0 = ^GROUP_INFO_0;\r\n {$EXTERNALSYM LPGROUP_INFO_0}\r\n PGROUP_INFO_0 = ^GROUP_INFO_0;\r\n {$EXTERNALSYM PGROUP_INFO_0}\r\n _GROUP_INFO_0 = record\r\n grpi0_name: LPWSTR;\r\n end;\r\n {$EXTERNALSYM _GROUP_INFO_0}\r\n GROUP_INFO_0 = _GROUP_INFO_0;\r\n {$EXTERNALSYM GROUP_INFO_0}\r\n TGroupInfo0 = GROUP_INFO_0;\r\n PGroupInfo0 = PGROUP_INFO_0;\r\n\r\n LPGROUP_INFO_1 = ^GROUP_INFO_1;\r\n {$EXTERNALSYM LPGROUP_INFO_1}\r\n PGROUP_INFO_1 = ^GROUP_INFO_1;\r\n {$EXTERNALSYM PGROUP_INFO_1}\r\n _GROUP_INFO_1 = record\r\n grpi1_name: LPWSTR;\r\n grpi1_comment: LPWSTR;\r\n end;\r\n {$EXTERNALSYM _GROUP_INFO_1}\r\n GROUP_INFO_1 = _GROUP_INFO_1;\r\n {$EXTERNALSYM GROUP_INFO_1}\r\n TGroupInfo1 = GROUP_INFO_1;\r\n PGroupInfo1 = PGROUP_INFO_1;\r\n\r\n// line 1380\r\n\r\n//\r\n// LocalGroup Class\r\n//\r\n\r\n//\r\n// Function Prototypes\r\n//\r\n\r\n\r\nfunction NetLocalGroupAdd(servername: LPCWSTR; level: DWORD; buf: PByte; parm_err: LPDWORD): NET_API_STATUS; stdcall;\r\n{$EXTERNALSYM NetLocalGroupAdd}\r\n\r\nfunction NetLocalGroupAddMember(servername, groupname: LPCWSTR; membersid: PSID): NET_API_STATUS; stdcall;\r\n{$EXTERNALSYM NetLocalGroupAddMember}\r\n\r\nfunction NetLocalGroupEnum(servername: LPCWSTR; level: DWORD; out bufptr: PByte;\r\n prefmaxlen: DWORD; out entriesread, totalentries: DWORD; resumehandle: PDWORD_PTR): NET_API_STATUS; stdcall;\r\n{$EXTERNALSYM NetLocalGroupEnum}\r\n\r\nfunction NetLocalGroupGetInfo(servername, groupname: LPCWSTR; level: DWORD; var bufptr: PByte): NET_API_STATUS; stdcall;\r\n{$EXTERNALSYM NetLocalGroupGetInfo}\r\n\r\nfunction NetLocalGroupSetInfo(servername, groupname: LPCWSTR; level: DWORD; buf: PByte; parm_err: LPDWORD): NET_API_STATUS; stdcall;\r\n{$EXTERNALSYM NetLocalGroupSetInfo}\r\n\r\nfunction NetLocalGroupDel(servername: LPCWSTR; groupname: LPCWSTR): NET_API_STATUS; stdcall;\r\n{$EXTERNALSYM NetLocalGroupDel}\r\n\r\nfunction NetLocalGroupDelMember(servername: LPCWSTR; groupname: LPCWSTR; membersid: PSID): NET_API_STATUS; stdcall;\r\n{$EXTERNALSYM NetLocalGroupDelMember}\r\n\r\nfunction NetLocalGroupGetMembers(servername, localgroupname: LPCWSTR; level: DWORD; var bufptr: PByte; prefmaxlen: DWORD; entriesread, totalentries: LPDWORD; resumehandle: PDWORD_PTR): NET_API_STATUS; stdcall;\r\n{$EXTERNALSYM NetLocalGroupGetMembers}\r\n\r\nfunction NetLocalGroupSetMembers(servername, groupname: LPCWSTR; level: DWORD; buf: PByte; totalentries: DWORD): NET_API_STATUS; stdcall;\r\n{$EXTERNALSYM NetLocalGroupSetMembers}\r\n\r\nfunction NetLocalGroupAddMembers(servername, groupname: LPCWSTR; level: DWORD; buf: PByte; totalentries: DWORD): NET_API_STATUS; stdcall;\r\n{$EXTERNALSYM NetLocalGroupAddMembers}\r\n\r\nfunction NetLocalGroupDelMembers(servername, groupname: LPCWSTR; level: DWORD; buf: PByte; totalentries: DWORD): NET_API_STATUS; stdcall;\r\n{$EXTERNALSYM NetLocalGroupDelMembers}\r\n\r\n\r\n//\r\n// Data Structures - LocalGroup\r\n//\r\n\r\ntype\r\n {$IFNDEF FPC}\r\n LPLOCALGROUP_INFO_0 = ^LOCALGROUP_INFO_0;\r\n {$EXTERNALSYM LPLOCALGROUP_INFO_0}\r\n PLOCALGROUP_INFO_0 = ^LOCALGROUP_INFO_0;\r\n {$EXTERNALSYM PLOCALGROUP_INFO_0}\r\n _LOCALGROUP_INFO_0 = record\r\n lgrpi0_name: LPWSTR;\r\n end;\r\n {$EXTERNALSYM _LOCALGROUP_INFO_0}\r\n LOCALGROUP_INFO_0 = _LOCALGROUP_INFO_0;\r\n {$EXTERNALSYM LOCALGROUP_INFO_0}\r\n TLocalGroupInfo0 = LOCALGROUP_INFO_0;\r\n PLocalGroupInfo0 = PLOCALGROUP_INFO_0;\r\n {$ENDIF ~FPC}\r\n\r\n LPLOCALGROUP_INFO_1 = ^LOCALGROUP_INFO_1;\r\n {$EXTERNALSYM LPLOCALGROUP_INFO_1}\r\n PLOCALGROUP_INFO_1 = ^LOCALGROUP_INFO_1;\r\n {$EXTERNALSYM PLOCALGROUP_INFO_1}\r\n _LOCALGROUP_INFO_1 = record\r\n lgrpi1_name: LPWSTR;\r\n lgrpi1_comment: LPWSTR;\r\n end;\r\n {$EXTERNALSYM _LOCALGROUP_INFO_1}\r\n LOCALGROUP_INFO_1 = _LOCALGROUP_INFO_1;\r\n {$EXTERNALSYM LOCALGROUP_INFO_1}\r\n TLocalGroupInfo1 = LOCALGROUP_INFO_1;\r\n PLocalGroupInfo1 = PLOCALGROUP_INFO_1;\r\n\r\n LPLOCALGROUP_INFO_1002 = ^LOCALGROUP_INFO_1002;\r\n {$EXTERNALSYM LPLOCALGROUP_INFO_1002}\r\n PLOCALGROUP_INFO_1002 = ^LOCALGROUP_INFO_1002;\r\n {$EXTERNALSYM PLOCALGROUP_INFO_1002}\r\n _LOCALGROUP_INFO_1002 = record\r\n lgrpi1002_comment: LPWSTR;\r\n end;\r\n {$EXTERNALSYM _LOCALGROUP_INFO_1002}\r\n LOCALGROUP_INFO_1002 = _LOCALGROUP_INFO_1002;\r\n {$EXTERNALSYM LOCALGROUP_INFO_1002}\r\n TLocalGroupInfo1002 = LOCALGROUP_INFO_1002;\r\n PLocalGroupInfo1002 = PLOCALGROUP_INFO_1002;\r\n\r\n {$IFNDEF FPC}\r\n LPLOCALGROUP_MEMBERS_INFO_0 = ^LOCALGROUP_MEMBERS_INFO_0;\r\n {$EXTERNALSYM LPLOCALGROUP_MEMBERS_INFO_0}\r\n PLOCALGROUP_MEMBERS_INFO_0 = ^LOCALGROUP_MEMBERS_INFO_0;\r\n {$EXTERNALSYM PLOCALGROUP_MEMBERS_INFO_0}\r\n _LOCALGROUP_MEMBERS_INFO_0 = record\r\n lgrmi0_sid: PSID;\r\n end;\r\n {$EXTERNALSYM _LOCALGROUP_MEMBERS_INFO_0}\r\n LOCALGROUP_MEMBERS_INFO_0 = _LOCALGROUP_MEMBERS_INFO_0;\r\n {$EXTERNALSYM LOCALGROUP_MEMBERS_INFO_0}\r\n TLocalGroupMembersInfo0 = LOCALGROUP_MEMBERS_INFO_0;\r\n PLocalGroupMembersInfo0 = PLOCALGROUP_MEMBERS_INFO_0;\r\n {$ENDIF ~FPC}\r\n\r\n LPLOCALGROUP_MEMBERS_INFO_1 = ^LOCALGROUP_MEMBERS_INFO_1;\r\n {$EXTERNALSYM LPLOCALGROUP_MEMBERS_INFO_1}\r\n PLOCALGROUP_MEMBERS_INFO_1 = ^LOCALGROUP_MEMBERS_INFO_1;\r\n {$EXTERNALSYM PLOCALGROUP_MEMBERS_INFO_1}\r\n _LOCALGROUP_MEMBERS_INFO_1 = record\r\n lgrmi1_sid: PSID;\r\n lgrmi1_sidusage: SID_NAME_USE;\r\n lgrmi1_name: LPWSTR;\r\n end;\r\n {$EXTERNALSYM _LOCALGROUP_MEMBERS_INFO_1}\r\n LOCALGROUP_MEMBERS_INFO_1 = _LOCALGROUP_MEMBERS_INFO_1;\r\n {$EXTERNALSYM LOCALGROUP_MEMBERS_INFO_1}\r\n TLocalGroupMembersInfo1 = LOCALGROUP_MEMBERS_INFO_1;\r\n PLocalGroupMembersInfo1 = PLOCALGROUP_MEMBERS_INFO_1;\r\n\r\n LPLOCALGROUP_MEMBERS_INFO_2 = ^LOCALGROUP_MEMBERS_INFO_2;\r\n {$EXTERNALSYM LPLOCALGROUP_MEMBERS_INFO_2}\r\n PLOCALGROUP_MEMBERS_INFO_2 = ^LOCALGROUP_MEMBERS_INFO_2;\r\n {$EXTERNALSYM PLOCALGROUP_MEMBERS_INFO_2}\r\n _LOCALGROUP_MEMBERS_INFO_2 = record\r\n lgrmi2_sid: PSID;\r\n lgrmi2_sidusage: SID_NAME_USE;\r\n lgrmi2_domainandname: LPWSTR;\r\n end;\r\n {$EXTERNALSYM _LOCALGROUP_MEMBERS_INFO_2}\r\n LOCALGROUP_MEMBERS_INFO_2 = _LOCALGROUP_MEMBERS_INFO_2;\r\n {$EXTERNALSYM LOCALGROUP_MEMBERS_INFO_2}\r\n TLocalGroupMembersInfo2 = LOCALGROUP_MEMBERS_INFO_2;\r\n PLocalGroupMembersInfo2 = PLOCALGROUP_MEMBERS_INFO_2;\r\n\r\n {$IFNDEF FPC}\r\n LPLOCALGROUP_MEMBERS_INFO_3 = ^LOCALGROUP_MEMBERS_INFO_3;\r\n {$EXTERNALSYM LPLOCALGROUP_MEMBERS_INFO_3}\r\n PLOCALGROUP_MEMBERS_INFO_3 = ^LOCALGROUP_MEMBERS_INFO_3;\r\n {$EXTERNALSYM PLOCALGROUP_MEMBERS_INFO_3}\r\n _LOCALGROUP_MEMBERS_INFO_3 = record\r\n lgrmi3_domainandname: LPWSTR;\r\n end;\r\n {$EXTERNALSYM _LOCALGROUP_MEMBERS_INFO_3}\r\n LOCALGROUP_MEMBERS_INFO_3 = _LOCALGROUP_MEMBERS_INFO_3;\r\n {$EXTERNALSYM LOCALGROUP_MEMBERS_INFO_3}\r\n TLocalGroupMembersInfo3 = LOCALGROUP_MEMBERS_INFO_3;\r\n PLocalGroupMembersInfo3 = PLOCALGROUP_MEMBERS_INFO_3;\r\n {$ENDIF ~FPC}\r\n\r\nfunction NetApiBufferFree(Buffer: Pointer): NET_API_STATUS; stdcall;\r\n{$EXTERNALSYM NetApiBufferFree}\r\n\r\ntype\r\n _WKSTA_INFO_100 = record\r\n wki100_platform_id: DWORD;\r\n wki100_computername: LMSTR;\r\n wki100_langroup: LMSTR;\r\n wki100_ver_major: DWORD;\r\n wki100_ver_minor: DWORD;\r\n end;\r\n {$EXTERNALSYM _WKSTA_INFO_100}\r\n WKSTA_INFO_100 = _WKSTA_INFO_100;\r\n {$EXTERNALSYM WKSTA_INFO_100}\r\n PWKSTA_INFO_100 = ^_WKSTA_INFO_100;\r\n {$EXTERNALSYM PWKSTA_INFO_100}\r\n LPWKSTA_INFO_100 = ^_WKSTA_INFO_100;\r\n {$EXTERNALSYM LPWKSTA_INFO_100}\r\n\r\nfunction NetWkstaGetInfo(servername: PWideChar; level: DWORD; out bufptr: PByte): NET_API_STATUS; stdcall;\r\n{$EXTERNALSYM NetWkstaGetInfo}\r\n\r\n(****************************************************************\r\n * *\r\n * Data structure templates *\r\n * *\r\n ****************************************************************)\r\n\r\nconst\r\n NCBNAMSZ = 16; // absolute length of a net name\r\n {$EXTERNALSYM NCBNAMSZ}\r\n MAX_LANA = 254; // lana's in range 0 to MAX_LANA inclusive\r\n {$EXTERNALSYM MAX_LANA}\r\n\r\n//\r\n// Network Control Block\r\n//\r\n\r\ntype\r\n {$IFNDEF FPC}\r\n PNCB = ^NCB;\r\n {$ENDIF ~FPC}\r\n\r\n TNcbPost = procedure (P: PNCB); stdcall;\r\n\r\n {$IFNDEF FPC}\r\n _NCB = record\r\n ncb_command: UCHAR; // command code\r\n ncb_retcode: UCHAR; // return code\r\n ncb_lsn: UCHAR; // local session number\r\n ncb_num: UCHAR; // number of our network name\r\n ncb_buffer: PUCHAR; // address of message buffer\r\n ncb_length: Word; // size of message buffer\r\n ncb_callname: array [0..NCBNAMSZ - 1] of UCHAR; // blank-padded name of remote\r\n ncb_name: array [0..NCBNAMSZ - 1] of UCHAR; // our blank-padded netname\r\n ncb_rto: UCHAR; // rcv timeout/retry count\r\n ncb_sto: UCHAR; // send timeout/sys timeout\r\n ncb_post: TNcbPost; // POST routine address\r\n ncb_lana_num: UCHAR; // lana (adapter) number\r\n ncb_cmd_cplt: UCHAR; // 0xff => commmand pending\r\n {$IFDEF _WIN64}\r\n ncb_reserve: array [0..17] of UCHAR; // reserved, used by BIOS\r\n {$ELSE ~_WIN64}\r\n ncb_reserve: array [0..9] of UCHAR; // reserved, used by BIOS\r\n {$ENDIF ~_WIN64}\r\n ncb_event: THandle; // HANDLE to Win32 event which\r\n // will be set to the signalled\r\n // state when an ASYNCH command\r\n // completes\r\n end;\r\n {$EXTERNALSYM _NCB}\r\n NCB = _NCB;\r\n {$EXTERNALSYM NCB}\r\n TNcb = NCB;\r\n {$ENDIF ~FPC}\r\n\r\n//\r\n// Structure returned to the NCB command NCBASTAT is ADAPTER_STATUS followed\r\n// by an array of NAME_BUFFER structures.\r\n//\r\n{$IFNDEF FPC}\r\ntype\r\n _ADAPTER_STATUS = record\r\n adapter_address: array [0..5] of UCHAR;\r\n rev_major: UCHAR;\r\n reserved0: UCHAR;\r\n adapter_type: UCHAR;\r\n rev_minor: UCHAR;\r\n duration: WORD;\r\n frmr_recv: WORD;\r\n frmr_xmit: WORD;\r\n iframe_recv_err: WORD;\r\n xmit_aborts: WORD;\r\n xmit_success: DWORD;\r\n recv_success: DWORD;\r\n iframe_xmit_err: WORD;\r\n recv_buff_unavail: WORD;\r\n t1_timeouts: WORD;\r\n ti_timeouts: WORD;\r\n reserved1: DWORD;\r\n free_ncbs: WORD;\r\n max_cfg_ncbs: WORD;\r\n max_ncbs: WORD;\r\n xmit_buf_unavail: WORD;\r\n max_dgram_size: WORD;\r\n pending_sess: WORD;\r\n max_cfg_sess: WORD;\r\n max_sess: WORD;\r\n max_sess_pkt_size: WORD;\r\n name_count: WORD;\r\n end;\r\n {$EXTERNALSYM _ADAPTER_STATUS}\r\n ADAPTER_STATUS = _ADAPTER_STATUS;\r\n {$EXTERNALSYM ADAPTER_STATUS}\r\n PADAPTER_STATUS = ^ADAPTER_STATUS;\r\n {$EXTERNALSYM PADAPTER_STATUS}\r\n TAdapterStatus = ADAPTER_STATUS;\r\n PAdapterStatus = PADAPTER_STATUS;\r\n\r\n _NAME_BUFFER = record\r\n name: array [0..NCBNAMSZ - 1] of UCHAR;\r\n name_num: UCHAR;\r\n name_flags: UCHAR;\r\n end;\r\n {$EXTERNALSYM _NAME_BUFFER}\r\n NAME_BUFFER = _NAME_BUFFER;\r\n {$EXTERNALSYM NAME_BUFFER}\r\n PNAME_BUFFER = ^NAME_BUFFER;\r\n {$EXTERNALSYM PNAME_BUFFER}\r\n TNameBuffer = NAME_BUFFER;\r\n PNameBuffer = PNAME_BUFFER;\r\n{$ENDIF ~FPC}\r\n\r\n// values for name_flags bits.\r\n\r\nconst\r\n NAME_FLAGS_MASK = $87;\r\n {$EXTERNALSYM NAME_FLAGS_MASK}\r\n\r\n GROUP_NAME = $80;\r\n {$EXTERNALSYM GROUP_NAME}\r\n UNIQUE_NAME = $00;\r\n {$EXTERNALSYM UNIQUE_NAME}\r\n\r\n REGISTERING = $00;\r\n {$EXTERNALSYM REGISTERING}\r\n REGISTERED = $04;\r\n {$EXTERNALSYM REGISTERED}\r\n DEREGISTERED = $05;\r\n {$EXTERNALSYM DEREGISTERED}\r\n DUPLICATE = $06;\r\n {$EXTERNALSYM DUPLICATE}\r\n DUPLICATE_DEREG = $07;\r\n {$EXTERNALSYM DUPLICATE_DEREG}\r\n\r\n//\r\n// Structure returned to the NCB command NCBSSTAT is SESSION_HEADER followed\r\n// by an array of SESSION_BUFFER structures. If the NCB_NAME starts with an\r\n// asterisk then an array of these structures is returned containing the\r\n// status for all names.\r\n//\r\n\r\n{$IFNDEF FPC}\r\ntype\r\n _SESSION_HEADER = record\r\n sess_name: UCHAR;\r\n num_sess: UCHAR;\r\n rcv_dg_outstanding: UCHAR;\r\n rcv_any_outstanding: UCHAR;\r\n end;\r\n {$EXTERNALSYM _SESSION_HEADER}\r\n SESSION_HEADER = _SESSION_HEADER;\r\n {$EXTERNALSYM SESSION_HEADER}\r\n PSESSION_HEADER = ^SESSION_HEADER;\r\n {$EXTERNALSYM PSESSION_HEADER}\r\n TSessionHeader = SESSION_HEADER;\r\n PSessionHeader = PSESSION_HEADER;\r\n\r\n _SESSION_BUFFER = record\r\n lsn: UCHAR;\r\n state: UCHAR;\r\n local_name: array [0..NCBNAMSZ - 1] of UCHAR;\r\n remote_name: array [0..NCBNAMSZ - 1] of UCHAR;\r\n rcvs_outstanding: UCHAR;\r\n sends_outstanding: UCHAR;\r\n end;\r\n {$EXTERNALSYM _SESSION_BUFFER}\r\n SESSION_BUFFER = _SESSION_BUFFER;\r\n {$EXTERNALSYM SESSION_BUFFER}\r\n PSESSION_BUFFER = ^SESSION_BUFFER;\r\n {$EXTERNALSYM PSESSION_BUFFER}\r\n TSessionBuffer = SESSION_BUFFER;\r\n PSessionBuffer = PSESSION_BUFFER;\r\n{$ENDIF ~FPC}\r\n\r\n// Values for state\r\n\r\nconst\r\n LISTEN_OUTSTANDING = $01;\r\n {$EXTERNALSYM LISTEN_OUTSTANDING}\r\n CALL_PENDING = $02;\r\n {$EXTERNALSYM CALL_PENDING}\r\n SESSION_ESTABLISHED = $03;\r\n {$EXTERNALSYM SESSION_ESTABLISHED}\r\n HANGUP_PENDING = $04;\r\n {$EXTERNALSYM HANGUP_PENDING}\r\n HANGUP_COMPLETE = $05;\r\n {$EXTERNALSYM HANGUP_COMPLETE}\r\n SESSION_ABORTED = $06;\r\n {$EXTERNALSYM SESSION_ABORTED}\r\n\r\n//\r\n// Structure returned to the NCB command NCBENUM.\r\n//\r\n// On a system containing lana's 0, 2 and 3, a structure with\r\n// length =3, lana[0]=0, lana[1]=2 and lana[2]=3 will be returned.\r\n//\r\n\r\n{$IFNDEF FPC}\r\ntype\r\n _LANA_ENUM = record\r\n length: UCHAR; // Number of valid entries in lana[]\r\n lana: array [0..MAX_LANA] of UCHAR;\r\n end;\r\n {$EXTERNALSYM _LANA_ENUM}\r\n LANA_ENUM = _LANA_ENUM;\r\n {$EXTERNALSYM LANA_ENUM}\r\n PLANA_ENUM = ^LANA_ENUM;\r\n {$EXTERNALSYM PLANA_ENUM}\r\n TLanaEnum = LANA_ENUM;\r\n PLanaEnum = PLANA_ENUM;\r\n{$ENDIF ~FPC}\r\n\r\n//\r\n// Structure returned to the NCB command NCBFINDNAME is FIND_NAME_HEADER followed\r\n// by an array of FIND_NAME_BUFFER structures.\r\n//\r\n\r\n{$IFNDEF FPC}\r\ntype\r\n _FIND_NAME_HEADER = record\r\n node_count: WORD;\r\n reserved: UCHAR;\r\n unique_group: UCHAR;\r\n end;\r\n {$EXTERNALSYM _FIND_NAME_HEADER}\r\n FIND_NAME_HEADER = _FIND_NAME_HEADER;\r\n {$EXTERNALSYM FIND_NAME_HEADER}\r\n PFIND_NAME_HEADER = ^FIND_NAME_HEADER;\r\n {$EXTERNALSYM PFIND_NAME_HEADER}\r\n TFindNameHeader = FIND_NAME_HEADER;\r\n PFindNameHeader = PFIND_NAME_HEADER;\r\n\r\n _FIND_NAME_BUFFER = record\r\n length: UCHAR;\r\n access_control: UCHAR;\r\n frame_control: UCHAR;\r\n destination_addr: array [0..5] of UCHAR;\r\n source_addr: array [0..5] of UCHAR;\r\n routing_info: array [0..17] of UCHAR;\r\n end;\r\n {$EXTERNALSYM _FIND_NAME_BUFFER}\r\n FIND_NAME_BUFFER = _FIND_NAME_BUFFER;\r\n {$EXTERNALSYM FIND_NAME_BUFFER}\r\n PFIND_NAME_BUFFER = ^FIND_NAME_BUFFER;\r\n {$EXTERNALSYM PFIND_NAME_BUFFER}\r\n TFindNameBuffer = FIND_NAME_BUFFER;\r\n PFindNameBuffer = PFIND_NAME_BUFFER;\r\n\r\n//\r\n// Structure provided with NCBACTION. The purpose of NCBACTION is to provide\r\n// transport specific extensions to netbios.\r\n//\r\n\r\n _ACTION_HEADER = record\r\n transport_id: ULONG;\r\n action_code: USHORT;\r\n reserved: USHORT;\r\n end;\r\n {$EXTERNALSYM _ACTION_HEADER}\r\n ACTION_HEADER = _ACTION_HEADER;\r\n {$EXTERNALSYM ACTION_HEADER}\r\n PACTION_HEADER = ^ACTION_HEADER;\r\n {$EXTERNALSYM PACTION_HEADER}\r\n TActionHeader = ACTION_HEADER;\r\n PActionHeader = PACTION_HEADER;\r\n{$ENDIF ~FPC}\r\n\r\n// Values for transport_id\r\n\r\nconst\r\n ALL_TRANSPORTS = 'M'#0#0#0;\r\n {$EXTERNALSYM ALL_TRANSPORTS}\r\n MS_NBF = 'MNBF';\r\n {$EXTERNALSYM MS_NBF}\r\n\r\n(****************************************************************\r\n * *\r\n * Special values and constants *\r\n * *\r\n ****************************************************************)\r\n\r\n//\r\n// NCB Command codes\r\n//\r\n\r\nconst\r\n NCBCALL = $10; // NCB CALL\r\n {$EXTERNALSYM NCBCALL}\r\n NCBLISTEN = $11; // NCB LISTEN\r\n {$EXTERNALSYM NCBLISTEN}\r\n NCBHANGUP = $12; // NCB HANG UP\r\n {$EXTERNALSYM NCBHANGUP}\r\n NCBSEND = $14; // NCB SEND\r\n {$EXTERNALSYM NCBSEND}\r\n NCBRECV = $15; // NCB RECEIVE\r\n {$EXTERNALSYM NCBRECV}\r\n NCBRECVANY = $16; // NCB RECEIVE ANY\r\n {$EXTERNALSYM NCBRECVANY}\r\n NCBCHAINSEND = $17; // NCB CHAIN SEND\r\n {$EXTERNALSYM NCBCHAINSEND}\r\n NCBDGSEND = $20; // NCB SEND DATAGRAM\r\n {$EXTERNALSYM NCBDGSEND}\r\n NCBDGRECV = $21; // NCB RECEIVE DATAGRAM\r\n {$EXTERNALSYM NCBDGRECV}\r\n NCBDGSENDBC = $22; // NCB SEND BROADCAST DATAGRAM\r\n {$EXTERNALSYM NCBDGSENDBC}\r\n NCBDGRECVBC = $23; // NCB RECEIVE BROADCAST DATAGRAM\r\n {$EXTERNALSYM NCBDGRECVBC}\r\n NCBADDNAME = $30; // NCB ADD NAME\r\n {$EXTERNALSYM NCBADDNAME}\r\n NCBDELNAME = $31; // NCB DELETE NAME\r\n {$EXTERNALSYM NCBDELNAME}\r\n NCBRESET = $32; // NCB RESET\r\n {$EXTERNALSYM NCBRESET}\r\n NCBASTAT = $33; // NCB ADAPTER STATUS\r\n {$EXTERNALSYM NCBASTAT}\r\n NCBSSTAT = $34; // NCB SESSION STATUS\r\n {$EXTERNALSYM NCBSSTAT}\r\n NCBCANCEL = $35; // NCB CANCEL\r\n {$EXTERNALSYM NCBCANCEL}\r\n NCBADDGRNAME = $36; // NCB ADD GROUP NAME\r\n {$EXTERNALSYM NCBADDGRNAME}\r\n NCBENUM = $37; // NCB ENUMERATE LANA NUMBERS\r\n {$EXTERNALSYM NCBENUM}\r\n NCBUNLINK = $70; // NCB UNLINK\r\n {$EXTERNALSYM NCBUNLINK}\r\n NCBSENDNA = $71; // NCB SEND NO ACK\r\n {$EXTERNALSYM NCBSENDNA}\r\n NCBCHAINSENDNA = $72; // NCB CHAIN SEND NO ACK\r\n {$EXTERNALSYM NCBCHAINSENDNA}\r\n NCBLANSTALERT = $73; // NCB LAN STATUS ALERT\r\n {$EXTERNALSYM NCBLANSTALERT}\r\n NCBACTION = $77; // NCB ACTION\r\n {$EXTERNALSYM NCBACTION}\r\n NCBFINDNAME = $78; // NCB FIND NAME\r\n {$EXTERNALSYM NCBFINDNAME}\r\n NCBTRACE = $79; // NCB TRACE\r\n {$EXTERNALSYM NCBTRACE}\r\n\r\n ASYNCH = $80; // high bit set == asynchronous\r\n {$EXTERNALSYM ASYNCH}\r\n\r\n//\r\n// NCB Return codes\r\n//\r\n\r\n NRC_GOODRET = $00; // good return also returned when ASYNCH request accepted\r\n {$EXTERNALSYM NRC_GOODRET}\r\n NRC_BUFLEN = $01; // illegal buffer length\r\n {$EXTERNALSYM NRC_BUFLEN}\r\n NRC_ILLCMD = $03; // illegal command\r\n {$EXTERNALSYM NRC_ILLCMD}\r\n NRC_CMDTMO = $05; // command timed out\r\n {$EXTERNALSYM NRC_CMDTMO}\r\n NRC_INCOMP = $06; // message incomplete, issue another command\r\n {$EXTERNALSYM NRC_INCOMP}\r\n NRC_BADDR = $07; // illegal buffer address\r\n {$EXTERNALSYM NRC_BADDR}\r\n NRC_SNUMOUT = $08; // session number out of range\r\n {$EXTERNALSYM NRC_SNUMOUT}\r\n NRC_NORES = $09; // no resource available\r\n {$EXTERNALSYM NRC_NORES}\r\n NRC_SCLOSED = $0a; // session closed\r\n {$EXTERNALSYM NRC_SCLOSED}\r\n NRC_CMDCAN = $0b; // command cancelled\r\n {$EXTERNALSYM NRC_CMDCAN}\r\n NRC_DUPNAME = $0d; // duplicate name\r\n {$EXTERNALSYM NRC_DUPNAME}\r\n NRC_NAMTFUL = $0e; // name table full\r\n {$EXTERNALSYM NRC_NAMTFUL}\r\n NRC_ACTSES = $0f; // no deletions, name has active sessions\r\n {$EXTERNALSYM NRC_ACTSES}\r\n NRC_LOCTFUL = $11; // local session table full\r\n {$EXTERNALSYM NRC_LOCTFUL}\r\n NRC_REMTFUL = $12; // remote session table full\r\n {$EXTERNALSYM NRC_REMTFUL}\r\n NRC_ILLNN = $13; // illegal name number\r\n {$EXTERNALSYM NRC_ILLNN}\r\n NRC_NOCALL = $14; // no callname\r\n {$EXTERNALSYM NRC_NOCALL}\r\n NRC_NOWILD = $15; // cannot put * in NCB_NAME\r\n {$EXTERNALSYM NRC_NOWILD}\r\n NRC_INUSE = $16; // name in use on remote adapter\r\n {$EXTERNALSYM NRC_INUSE}\r\n NRC_NAMERR = $17; // name deleted\r\n {$EXTERNALSYM NRC_NAMERR}\r\n NRC_SABORT = $18; // session ended abnormally\r\n {$EXTERNALSYM NRC_SABORT}\r\n NRC_NAMCONF = $19; // name conflict detected\r\n {$EXTERNALSYM NRC_NAMCONF}\r\n NRC_IFBUSY = $21; // interface busy, IRET before retrying\r\n {$EXTERNALSYM NRC_IFBUSY}\r\n NRC_TOOMANY = $22; // too many commands outstanding, retry later\r\n {$EXTERNALSYM NRC_TOOMANY}\r\n NRC_BRIDGE = $23; // ncb_lana_num field invalid\r\n {$EXTERNALSYM NRC_BRIDGE}\r\n NRC_CANOCCR = $24; // command completed while cancel occurring\r\n {$EXTERNALSYM NRC_CANOCCR}\r\n NRC_CANCEL = $26; // command not valid to cancel\r\n {$EXTERNALSYM NRC_CANCEL}\r\n NRC_DUPENV = $30; // name defined by anther local process\r\n {$EXTERNALSYM NRC_DUPENV}\r\n NRC_ENVNOTDEF = $34; // environment undefined. RESET required\r\n {$EXTERNALSYM NRC_ENVNOTDEF}\r\n NRC_OSRESNOTAV = $35; // required OS resources exhausted\r\n {$EXTERNALSYM NRC_OSRESNOTAV}\r\n NRC_MAXAPPS = $36; // max number of applications exceeded\r\n {$EXTERNALSYM NRC_MAXAPPS}\r\n NRC_NOSAPS = $37; // no saps available for netbios\r\n {$EXTERNALSYM NRC_NOSAPS}\r\n NRC_NORESOURCES = $38; // requested resources are not available\r\n {$EXTERNALSYM NRC_NORESOURCES}\r\n NRC_INVADDRESS = $39; // invalid ncb address or length > segment\r\n {$EXTERNALSYM NRC_INVADDRESS}\r\n NRC_INVDDID = $3B; // invalid NCB DDID\r\n {$EXTERNALSYM NRC_INVDDID}\r\n NRC_LOCKFAIL = $3C; // lock of user area failed\r\n {$EXTERNALSYM NRC_LOCKFAIL}\r\n NRC_OPENERR = $3f; // NETBIOS not loaded\r\n {$EXTERNALSYM NRC_OPENERR}\r\n NRC_SYSTEM = $40; // system error\r\n {$EXTERNALSYM NRC_SYSTEM}\r\n\r\n NRC_PENDING = $ff; // asynchronous command is not yet finished\r\n {$EXTERNALSYM NRC_PENDING}\r\n\r\n(****************************************************************\r\n * *\r\n * main user entry point for NetBIOS 3.0 *\r\n * *\r\n * Usage: result = Netbios( pncb ); *\r\n ****************************************************************)\r\n\r\nfunction Netbios(pncb: PNCB): UCHAR; stdcall;\r\n{$EXTERNALSYM Netbios}\r\n\r\ntype\r\n PRasDialDlg = ^TRasDialDlg;\r\n tagRASDIALDLG = packed record\r\n dwSize: DWORD;\r\n hwndOwner: HWND;\r\n dwFlags: DWORD;\r\n xDlg: Longint;\r\n yDlg: Longint;\r\n dwSubEntry: DWORD;\r\n dwError: DWORD;\r\n reserved: Longword;\r\n reserved2: Longword;\r\n end;\r\n {$EXTERNALSYM tagRASDIALDLG}\r\n RASDIALDLG = tagRASDIALDLG;\r\n {$EXTERNALSYM RASDIALDLG}\r\n TRasDialDlg = tagRASDIALDLG;\r\n\r\n\r\n// Reason flags\r\n\r\n// Flags used by the various UIs.\r\n\r\nconst\r\n SHTDN_REASON_FLAG_COMMENT_REQUIRED = $01000000;\r\n {$EXTERNALSYM SHTDN_REASON_FLAG_COMMENT_REQUIRED}\r\n SHTDN_REASON_FLAG_DIRTY_PROBLEM_ID_REQUIRED = $02000000;\r\n {$EXTERNALSYM SHTDN_REASON_FLAG_DIRTY_PROBLEM_ID_REQUIRED}\r\n SHTDN_REASON_FLAG_CLEAN_UI = $04000000;\r\n {$EXTERNALSYM SHTDN_REASON_FLAG_CLEAN_UI}\r\n SHTDN_REASON_FLAG_DIRTY_UI = $08000000;\r\n {$EXTERNALSYM SHTDN_REASON_FLAG_DIRTY_UI}\r\n\r\n// Flags that end up in the event log code.\r\n\r\n SHTDN_REASON_FLAG_USER_DEFINED = $40000000;\r\n {$EXTERNALSYM SHTDN_REASON_FLAG_USER_DEFINED}\r\n SHTDN_REASON_FLAG_PLANNED = DWORD($80000000);\r\n {$EXTERNALSYM SHTDN_REASON_FLAG_PLANNED}\r\n\r\n// Microsoft major reasons.\r\n\r\n SHTDN_REASON_MAJOR_OTHER = $00000000;\r\n {$EXTERNALSYM SHTDN_REASON_MAJOR_OTHER}\r\n SHTDN_REASON_MAJOR_NONE = $00000000;\r\n {$EXTERNALSYM SHTDN_REASON_MAJOR_NONE}\r\n SHTDN_REASON_MAJOR_HARDWARE = $00010000;\r\n {$EXTERNALSYM SHTDN_REASON_MAJOR_HARDWARE}\r\n SHTDN_REASON_MAJOR_OPERATINGSYSTEM = $00020000;\r\n {$EXTERNALSYM SHTDN_REASON_MAJOR_OPERATINGSYSTEM}\r\n SHTDN_REASON_MAJOR_SOFTWARE = $00030000;\r\n {$EXTERNALSYM SHTDN_REASON_MAJOR_SOFTWARE}\r\n SHTDN_REASON_MAJOR_APPLICATION = $00040000;\r\n {$EXTERNALSYM SHTDN_REASON_MAJOR_APPLICATION}\r\n SHTDN_REASON_MAJOR_SYSTEM = $00050000;\r\n {$EXTERNALSYM SHTDN_REASON_MAJOR_SYSTEM}\r\n SHTDN_REASON_MAJOR_POWER = $00060000;\r\n {$EXTERNALSYM SHTDN_REASON_MAJOR_POWER}\r\n SHTDN_REASON_MAJOR_LEGACY_API = $00070000;\r\n {$EXTERNALSYM SHTDN_REASON_MAJOR_LEGACY_API}\r\n\r\n// Microsoft minor reasons.\r\n\r\n SHTDN_REASON_MINOR_OTHER = $00000000;\r\n {$EXTERNALSYM SHTDN_REASON_MINOR_OTHER}\r\n SHTDN_REASON_MINOR_NONE = $000000ff;\r\n {$EXTERNALSYM SHTDN_REASON_MINOR_NONE}\r\n SHTDN_REASON_MINOR_MAINTENANCE = $00000001;\r\n {$EXTERNALSYM SHTDN_REASON_MINOR_MAINTENANCE}\r\n SHTDN_REASON_MINOR_INSTALLATION = $00000002;\r\n {$EXTERNALSYM SHTDN_REASON_MINOR_INSTALLATION}\r\n SHTDN_REASON_MINOR_UPGRADE = $00000003;\r\n {$EXTERNALSYM SHTDN_REASON_MINOR_UPGRADE}\r\n SHTDN_REASON_MINOR_RECONFIG = $00000004;\r\n {$EXTERNALSYM SHTDN_REASON_MINOR_RECONFIG}\r\n SHTDN_REASON_MINOR_HUNG = $00000005;\r\n {$EXTERNALSYM SHTDN_REASON_MINOR_HUNG}\r\n SHTDN_REASON_MINOR_UNSTABLE = $00000006;\r\n {$EXTERNALSYM SHTDN_REASON_MINOR_UNSTABLE}\r\n SHTDN_REASON_MINOR_DISK = $00000007;\r\n {$EXTERNALSYM SHTDN_REASON_MINOR_DISK}\r\n SHTDN_REASON_MINOR_PROCESSOR = $00000008;\r\n {$EXTERNALSYM SHTDN_REASON_MINOR_PROCESSOR}\r\n SHTDN_REASON_MINOR_NETWORKCARD = $00000009;\r\n {$EXTERNALSYM SHTDN_REASON_MINOR_NETWORKCARD}\r\n SHTDN_REASON_MINOR_POWER_SUPPLY = $0000000a;\r\n {$EXTERNALSYM SHTDN_REASON_MINOR_POWER_SUPPLY}\r\n SHTDN_REASON_MINOR_CORDUNPLUGGED = $0000000b;\r\n {$EXTERNALSYM SHTDN_REASON_MINOR_CORDUNPLUGGED}\r\n SHTDN_REASON_MINOR_ENVIRONMENT = $0000000c;\r\n {$EXTERNALSYM SHTDN_REASON_MINOR_ENVIRONMENT}\r\n SHTDN_REASON_MINOR_HARDWARE_DRIVER = $0000000d;\r\n {$EXTERNALSYM SHTDN_REASON_MINOR_HARDWARE_DRIVER}\r\n SHTDN_REASON_MINOR_OTHERDRIVER = $0000000e;\r\n {$EXTERNALSYM SHTDN_REASON_MINOR_OTHERDRIVER}\r\n SHTDN_REASON_MINOR_BLUESCREEN = $0000000F;\r\n {$EXTERNALSYM SHTDN_REASON_MINOR_BLUESCREEN}\r\n SHTDN_REASON_MINOR_SERVICEPACK = $00000010;\r\n {$EXTERNALSYM SHTDN_REASON_MINOR_SERVICEPACK}\r\n SHTDN_REASON_MINOR_HOTFIX = $00000011;\r\n {$EXTERNALSYM SHTDN_REASON_MINOR_HOTFIX}\r\n SHTDN_REASON_MINOR_SECURITYFIX = $00000012;\r\n {$EXTERNALSYM SHTDN_REASON_MINOR_SECURITYFIX}\r\n SHTDN_REASON_MINOR_SECURITY = $00000013;\r\n {$EXTERNALSYM SHTDN_REASON_MINOR_SECURITY}\r\n SHTDN_REASON_MINOR_NETWORK_CONNECTIVITY = $00000014;\r\n {$EXTERNALSYM SHTDN_REASON_MINOR_NETWORK_CONNECTIVITY}\r\n SHTDN_REASON_MINOR_WMI = $00000015;\r\n {$EXTERNALSYM SHTDN_REASON_MINOR_WMI}\r\n SHTDN_REASON_MINOR_SERVICEPACK_UNINSTALL = $00000016;\r\n {$EXTERNALSYM SHTDN_REASON_MINOR_SERVICEPACK_UNINSTALL}\r\n SHTDN_REASON_MINOR_HOTFIX_UNINSTALL = $00000017;\r\n {$EXTERNALSYM SHTDN_REASON_MINOR_HOTFIX_UNINSTALL}\r\n SHTDN_REASON_MINOR_SECURITYFIX_UNINSTALL = $00000018;\r\n {$EXTERNALSYM SHTDN_REASON_MINOR_SECURITYFIX_UNINSTALL}\r\n SHTDN_REASON_MINOR_MMC = $00000019;\r\n {$EXTERNALSYM SHTDN_REASON_MINOR_MMC}\r\n SHTDN_REASON_MINOR_TERMSRV = $00000020;\r\n {$EXTERNALSYM SHTDN_REASON_MINOR_TERMSRV}\r\n SHTDN_REASON_MINOR_DC_PROMOTION = $00000021;\r\n {$EXTERNALSYM SHTDN_REASON_MINOR_DC_PROMOTION}\r\n SHTDN_REASON_MINOR_DC_DEMOTION = $00000022;\r\n {$EXTERNALSYM SHTDN_REASON_MINOR_DC_DEMOTION}\r\n\r\n SHTDN_REASON_UNKNOWN = SHTDN_REASON_MINOR_NONE;\r\n {$EXTERNALSYM SHTDN_REASON_UNKNOWN}\r\n SHTDN_REASON_LEGACY_API = (SHTDN_REASON_MAJOR_LEGACY_API or SHTDN_REASON_FLAG_PLANNED);\r\n {$EXTERNALSYM SHTDN_REASON_LEGACY_API}\r\n\r\n// This mask cuts out UI flags.\r\n\r\n SHTDN_REASON_VALID_BIT_MASK = DWORD($c0ffffff);\r\n {$EXTERNALSYM SHTDN_REASON_VALID_BIT_MASK}\r\n\r\n// Convenience flags.\r\n\r\n PCLEANUI = (SHTDN_REASON_FLAG_PLANNED or SHTDN_REASON_FLAG_CLEAN_UI);\r\n {$EXTERNALSYM PCLEANUI}\r\n UCLEANUI = (SHTDN_REASON_FLAG_CLEAN_UI);\r\n {$EXTERNALSYM UCLEANUI}\r\n PDIRTYUI = (SHTDN_REASON_FLAG_PLANNED or SHTDN_REASON_FLAG_DIRTY_UI);\r\n {$EXTERNALSYM PDIRTYUI}\r\n UDIRTYUI = (SHTDN_REASON_FLAG_DIRTY_UI);\r\n {$EXTERNALSYM UDIRTYUI}\r\n\r\nconst\r\n CSIDL_LOCAL_APPDATA = $001C; { \\Local Settings\\Application Data (non roaming) }\r\n CSIDL_COMMON_APPDATA = $0023; { All Users\\Application Data }\r\n CSIDL_WINDOWS = $0024; { GetWindowsDirectory() }\r\n CSIDL_SYSTEM = $0025; { GetSystemDirectory() }\r\n CSIDL_PROGRAM_FILES = $0026; { C:\\Program Files }\r\n CSIDL_MYPICTURES = $0027; { C:\\Program Files\\My Pictures }\r\n CSIDL_PROFILE = $0028; { USERPROFILE }\r\n CSIDL_PROGRAM_FILESX86 = $002A; { C:\\Program Files (x86)\\My Pictures }\r\n CSIDL_PROGRAM_FILES_COMMON = $002B; { C:\\Program Files\\Common }\r\n CSIDL_COMMON_TEMPLATES = $002D; { All Users\\Templates }\r\n CSIDL_COMMON_DOCUMENTS = $002E; { All Users\\Documents }\r\n CSIDL_COMMON_ADMINTOOLS = $002F; { All Users\\Start Menu\\Programs\\Administrative Tools }\r\n CSIDL_ADMINTOOLS = $0030; { \\Start Menu\\Programs\\Administrative Tools }\r\n CSIDL_CONNECTIONS = $0031; { Network and Dial-up Connections }\r\n CSIDL_COMMON_MUSIC = $0035; { All Users\\My Music }\r\n CSIDL_COMMON_PICTURES = $0036; { All Users\\My Pictures }\r\n CSIDL_COMMON_VIDEO = $0037; { All Users\\My Video }\r\n CSIDL_RESOURCES = $0038; { Resource Direcotry }\r\n CSIDL_RESOURCES_LOCALIZED = $0039; { Localized Resource Direcotry }\r\n CSIDL_COMMON_OEM_LINKS = $003A; { Links to All Users OEM specific apps }\r\n CSIDL_CDBURN_AREA = $003B; { USERPROFILE\\Local Settings\\Application Data\\Microsoft\\CD Burning }\r\n CSIDL_COMPUTERSNEARME = $003D; { Computers Near Me (computered from Workgroup membership) }\r\n\r\n {$EXTERNALSYM CSIDL_LOCAL_APPDATA}\r\n {$EXTERNALSYM CSIDL_COMMON_APPDATA}\r\n {$EXTERNALSYM CSIDL_WINDOWS}\r\n {$EXTERNALSYM CSIDL_SYSTEM}\r\n {$EXTERNALSYM CSIDL_PROGRAM_FILES}\r\n {$EXTERNALSYM CSIDL_MYPICTURES}\r\n {$EXTERNALSYM CSIDL_PROFILE}\r\n {$EXTERNALSYM CSIDL_PROGRAM_FILES_COMMON}\r\n {$EXTERNALSYM CSIDL_COMMON_TEMPLATES}\r\n {$EXTERNALSYM CSIDL_COMMON_DOCUMENTS}\r\n {$EXTERNALSYM CSIDL_COMMON_ADMINTOOLS}\r\n {$EXTERNALSYM CSIDL_ADMINTOOLS}\r\n {$EXTERNALSYM CSIDL_CONNECTIONS}\r\n {$EXTERNALSYM CSIDL_COMMON_MUSIC}\r\n {$EXTERNALSYM CSIDL_COMMON_PICTURES}\r\n {$EXTERNALSYM CSIDL_COMMON_VIDEO}\r\n {$EXTERNALSYM CSIDL_RESOURCES}\r\n {$EXTERNALSYM CSIDL_RESOURCES_LOCALIZED}\r\n {$EXTERNALSYM CSIDL_COMMON_OEM_LINKS}\r\n {$EXTERNALSYM CSIDL_CDBURN_AREA}\r\n {$EXTERNALSYM CSIDL_COMPUTERSNEARME}\r\n\r\n\r\n{ TODO BCB-compatibility}\r\n\r\nconst\r\n DLLVER_PLATFORM_WINDOWS = $00000001;\r\n {$EXTERNALSYM DLLVER_PLATFORM_WINDOWS}\r\n DLLVER_PLATFORM_NT = $00000002;\r\n {$EXTERNALSYM DLLVER_PLATFORM_NT}\r\n\r\ntype\r\n PDllVersionInfo = ^TDllVersionInfo;\r\n _DLLVERSIONINFO = packed record\r\n cbSize: DWORD;\r\n dwMajorVersion: DWORD;\r\n dwMinorVersion: DWORD;\r\n dwBuildNumber: DWORD;\r\n dwPlatformId: DWORD;\r\n end;\r\n {$EXTERNALSYM _DLLVERSIONINFO}\r\n TDllVersionInfo = _DLLVERSIONINFO;\r\n DLLVERSIONINFO = _DLLVERSIONINFO;\r\n {$EXTERNALSYM DLLVERSIONINFO}\r\n\r\n\r\n// JwaWinError\r\n// line 22146\r\n\r\nconst\r\n\r\n//\r\n// Task Scheduler errors\r\n//\r\n//\r\n// MessageId: SCHED_S_TASK_READY\r\n//\r\n// MessageText:\r\n//\r\n// The task is ready to run at its next scheduled time.\r\n//\r\n SCHED_S_TASK_READY = HRESULT($00041300);\r\n {$EXTERNALSYM SCHED_S_TASK_READY}\r\n\r\n//\r\n// MessageId: SCHED_S_TASK_RUNNING\r\n//\r\n// MessageText:\r\n//\r\n// The task is currently running.\r\n//\r\n SCHED_S_TASK_RUNNING = HRESULT($00041301);\r\n {$EXTERNALSYM SCHED_S_TASK_RUNNING}\r\n\r\n//\r\n// MessageId: SCHED_S_TASK_DISABLED\r\n//\r\n// MessageText:\r\n//\r\n// The task will not run at the scheduled times because it has been disabled.\r\n//\r\n SCHED_S_TASK_DISABLED = HRESULT($00041302);\r\n {$EXTERNALSYM SCHED_S_TASK_DISABLED}\r\n\r\n//\r\n// MessageId: SCHED_S_TASK_HAS_NOT_RUN\r\n//\r\n// MessageText:\r\n//\r\n// The task has not yet run.\r\n//\r\n SCHED_S_TASK_HAS_NOT_RUN = HRESULT($00041303);\r\n {$EXTERNALSYM SCHED_S_TASK_HAS_NOT_RUN}\r\n\r\n//\r\n// MessageId: SCHED_S_TASK_NO_MORE_RUNS\r\n//\r\n// MessageText:\r\n//\r\n// There are no more runs scheduled for this task.\r\n//\r\n SCHED_S_TASK_NO_MORE_RUNS = HRESULT($00041304);\r\n {$EXTERNALSYM SCHED_S_TASK_NO_MORE_RUNS}\r\n\r\n//\r\n// MessageId: SCHED_S_TASK_NOT_SCHEDULED\r\n//\r\n// MessageText:\r\n//\r\n// One or more of the properties that are needed to run this task on a schedule have not been set.\r\n//\r\n SCHED_S_TASK_NOT_SCHEDULED = HRESULT($00041305);\r\n {$EXTERNALSYM SCHED_S_TASK_NOT_SCHEDULED}\r\n\r\n//\r\n// MessageId: SCHED_S_TASK_TERMINATED\r\n//\r\n// MessageText:\r\n//\r\n// The last run of the task was terminated by the user.\r\n//\r\n SCHED_S_TASK_TERMINATED = HRESULT($00041306);\r\n {$EXTERNALSYM SCHED_S_TASK_TERMINATED}\r\n\r\n//\r\n// MessageId: SCHED_S_TASK_NO_VALID_TRIGGERS\r\n//\r\n// MessageText:\r\n//\r\n// Either the task has no triggers or the existing triggers are disabled or not set.\r\n//\r\n SCHED_S_TASK_NO_VALID_TRIGGERS = HRESULT($00041307);\r\n {$EXTERNALSYM SCHED_S_TASK_NO_VALID_TRIGGERS}\r\n\r\n//\r\n// MessageId: SCHED_S_EVENT_TRIGGER\r\n//\r\n// MessageText:\r\n//\r\n// Event triggers don't have set run times.\r\n//\r\n SCHED_S_EVENT_TRIGGER = HRESULT($00041308);\r\n {$EXTERNALSYM SCHED_S_EVENT_TRIGGER}\r\n\r\n//\r\n// MessageId: SCHED_E_TRIGGER_NOT_FOUND\r\n//\r\n// MessageText:\r\n//\r\n// Trigger not found.\r\n//\r\n SCHED_E_TRIGGER_NOT_FOUND = HRESULT($80041309);\r\n {$EXTERNALSYM SCHED_E_TRIGGER_NOT_FOUND}\r\n\r\n//\r\n// MessageId: SCHED_E_TASK_NOT_READY\r\n//\r\n// MessageText:\r\n//\r\n// One or more of the properties that are needed to run this task have not been set.\r\n//\r\n SCHED_E_TASK_NOT_READY = HRESULT($8004130A);\r\n {$EXTERNALSYM SCHED_E_TASK_NOT_READY}\r\n\r\n//\r\n// MessageId: SCHED_E_TASK_NOT_RUNNING\r\n//\r\n// MessageText:\r\n//\r\n// There is no running instance of the task to terminate.\r\n//\r\n SCHED_E_TASK_NOT_RUNNING = HRESULT($8004130B);\r\n {$EXTERNALSYM SCHED_E_TASK_NOT_RUNNING}\r\n\r\n//\r\n// MessageId: SCHED_E_SERVICE_NOT_INSTALLED\r\n//\r\n// MessageText:\r\n//\r\n// The Task Scheduler Service is not installed on this computer.\r\n//\r\n SCHED_E_SERVICE_NOT_INSTALLED = HRESULT($8004130C);\r\n {$EXTERNALSYM SCHED_E_SERVICE_NOT_INSTALLED}\r\n\r\n//\r\n// MessageId: SCHED_E_CANNOT_OPEN_TASK\r\n//\r\n// MessageText:\r\n//\r\n// The task object could not be opened.\r\n//\r\n SCHED_E_CANNOT_OPEN_TASK = HRESULT($8004130D);\r\n {$EXTERNALSYM SCHED_E_CANNOT_OPEN_TASK}\r\n\r\n//\r\n// MessageId: SCHED_E_INVALID_TASK\r\n//\r\n// MessageText:\r\n//\r\n// The object is either an invalid task object or is not a task object.\r\n//\r\n SCHED_E_INVALID_TASK = HRESULT($8004130E);\r\n {$EXTERNALSYM SCHED_E_INVALID_TASK}\r\n\r\n//\r\n// MessageId: SCHED_E_ACCOUNT_INFORMATION_NOT_SET\r\n//\r\n// MessageText:\r\n//\r\n// No account information could be found in the Task Scheduler security database for the task indicated.\r\n//\r\n SCHED_E_ACCOUNT_INFORMATION_NOT_SET = HRESULT($8004130F);\r\n {$EXTERNALSYM SCHED_E_ACCOUNT_INFORMATION_NOT_SET}\r\n\r\n//\r\n// MessageId: SCHED_E_ACCOUNT_NAME_NOT_FOUND\r\n//\r\n// MessageText:\r\n//\r\n// Unable to establish existence of the account specified.\r\n//\r\n SCHED_E_ACCOUNT_NAME_NOT_FOUND = HRESULT($80041310);\r\n {$EXTERNALSYM SCHED_E_ACCOUNT_NAME_NOT_FOUND}\r\n\r\n//\r\n// MessageId: SCHED_E_ACCOUNT_DBASE_CORRUPT\r\n//\r\n// MessageText:\r\n//\r\n// Corruption was detected in the Task Scheduler security database; the database has been reset.\r\n//\r\n SCHED_E_ACCOUNT_DBASE_CORRUPT = HRESULT($80041311);\r\n {$EXTERNALSYM SCHED_E_ACCOUNT_DBASE_CORRUPT}\r\n\r\n//\r\n// MessageId: SCHED_E_NO_SECURITY_SERVICES\r\n//\r\n// MessageText:\r\n//\r\n// Task Scheduler security services are available only on Windows NT.\r\n//\r\n SCHED_E_NO_SECURITY_SERVICES = HRESULT($80041312);\r\n {$EXTERNALSYM SCHED_E_NO_SECURITY_SERVICES}\r\n\r\n//\r\n// MessageId: SCHED_E_UNKNOWN_OBJECT_VERSION\r\n//\r\n// MessageText:\r\n//\r\n// The task object version is either unsupported or invalid.\r\n//\r\n SCHED_E_UNKNOWN_OBJECT_VERSION = HRESULT($80041313);\r\n {$EXTERNALSYM SCHED_E_UNKNOWN_OBJECT_VERSION}\r\n\r\n//\r\n// MessageId: SCHED_E_UNSUPPORTED_ACCOUNT_OPTION\r\n//\r\n// MessageText:\r\n//\r\n// The task has been configured with an unsupported combination of account settings and run time options.\r\n//\r\n SCHED_E_UNSUPPORTED_ACCOUNT_OPTION = HRESULT($80041314);\r\n {$EXTERNALSYM SCHED_E_UNSUPPORTED_ACCOUNT_OPTION}\r\n\r\n//\r\n// MessageId: SCHED_E_SERVICE_NOT_RUNNING\r\n//\r\n// MessageText:\r\n//\r\n// The Task Scheduler Service is not running.\r\n//\r\n SCHED_E_SERVICE_NOT_RUNNING = HRESULT($80041315);\r\n {$EXTERNALSYM SCHED_E_SERVICE_NOT_RUNNING}\r\n\r\n\r\n// line 151\r\n\r\n//\r\n// Define the various device type values. Note that values used by Microsoft\r\n// Corporation are in the range 0-32767, and 32768-65535 are reserved for use\r\n// by customers.\r\n//\r\n\r\ntype\r\n DEVICE_TYPE = DWORD;\r\n {$EXTERNALSYM DEVICE_TYPE}\r\n\r\nconst\r\n FILE_DEVICE_BEEP = $00000001;\r\n {$EXTERNALSYM FILE_DEVICE_BEEP}\r\n FILE_DEVICE_CD_ROM = $00000002;\r\n {$EXTERNALSYM FILE_DEVICE_CD_ROM}\r\n FILE_DEVICE_CD_ROM_FILE_SYSTEM = $00000003;\r\n {$EXTERNALSYM FILE_DEVICE_CD_ROM_FILE_SYSTEM}\r\n FILE_DEVICE_CONTROLLER = $00000004;\r\n {$EXTERNALSYM FILE_DEVICE_CONTROLLER}\r\n FILE_DEVICE_DATALINK = $00000005;\r\n {$EXTERNALSYM FILE_DEVICE_DATALINK}\r\n FILE_DEVICE_DFS = $00000006;\r\n {$EXTERNALSYM FILE_DEVICE_DFS}\r\n FILE_DEVICE_DISK = $00000007;\r\n {$EXTERNALSYM FILE_DEVICE_DISK}\r\n FILE_DEVICE_DISK_FILE_SYSTEM = $00000008;\r\n {$EXTERNALSYM FILE_DEVICE_DISK_FILE_SYSTEM}\r\n FILE_DEVICE_FILE_SYSTEM = $00000009;\r\n {$EXTERNALSYM FILE_DEVICE_FILE_SYSTEM}\r\n FILE_DEVICE_INPORT_PORT = $0000000a;\r\n {$EXTERNALSYM FILE_DEVICE_INPORT_PORT}\r\n FILE_DEVICE_KEYBOARD = $0000000b;\r\n {$EXTERNALSYM FILE_DEVICE_KEYBOARD}\r\n FILE_DEVICE_MAILSLOT = $0000000c;\r\n {$EXTERNALSYM FILE_DEVICE_MAILSLOT}\r\n FILE_DEVICE_MIDI_IN = $0000000d;\r\n {$EXTERNALSYM FILE_DEVICE_MIDI_IN}\r\n FILE_DEVICE_MIDI_OUT = $0000000e;\r\n {$EXTERNALSYM FILE_DEVICE_MIDI_OUT}\r\n FILE_DEVICE_MOUSE = $0000000f;\r\n {$EXTERNALSYM FILE_DEVICE_MOUSE}\r\n FILE_DEVICE_MULTI_UNC_PROVIDER = $00000010;\r\n {$EXTERNALSYM FILE_DEVICE_MULTI_UNC_PROVIDER}\r\n FILE_DEVICE_NAMED_PIPE = $00000011;\r\n {$EXTERNALSYM FILE_DEVICE_NAMED_PIPE}\r\n FILE_DEVICE_NETWORK = $00000012;\r\n {$EXTERNALSYM FILE_DEVICE_NETWORK}\r\n FILE_DEVICE_NETWORK_BROWSER = $00000013;\r\n {$EXTERNALSYM FILE_DEVICE_NETWORK_BROWSER}\r\n FILE_DEVICE_NETWORK_FILE_SYSTEM = $00000014;\r\n {$EXTERNALSYM FILE_DEVICE_NETWORK_FILE_SYSTEM}\r\n FILE_DEVICE_NULL = $00000015;\r\n {$EXTERNALSYM FILE_DEVICE_NULL}\r\n FILE_DEVICE_PARALLEL_PORT = $00000016;\r\n {$EXTERNALSYM FILE_DEVICE_PARALLEL_PORT}\r\n FILE_DEVICE_PHYSICAL_NETCARD = $00000017;\r\n {$EXTERNALSYM FILE_DEVICE_PHYSICAL_NETCARD}\r\n FILE_DEVICE_PRINTER = $00000018;\r\n {$EXTERNALSYM FILE_DEVICE_PRINTER}\r\n FILE_DEVICE_SCANNER = $00000019;\r\n {$EXTERNALSYM FILE_DEVICE_SCANNER}\r\n FILE_DEVICE_SERIAL_MOUSE_PORT = $0000001a;\r\n {$EXTERNALSYM FILE_DEVICE_SERIAL_MOUSE_PORT}\r\n FILE_DEVICE_SERIAL_PORT = $0000001b;\r\n {$EXTERNALSYM FILE_DEVICE_SERIAL_PORT}\r\n FILE_DEVICE_SCREEN = $0000001c;\r\n {$EXTERNALSYM FILE_DEVICE_SCREEN}\r\n FILE_DEVICE_SOUND = $0000001d;\r\n {$EXTERNALSYM FILE_DEVICE_SOUND}\r\n FILE_DEVICE_STREAMS = $0000001e;\r\n {$EXTERNALSYM FILE_DEVICE_STREAMS}\r\n FILE_DEVICE_TAPE = $0000001f;\r\n {$EXTERNALSYM FILE_DEVICE_TAPE}\r\n FILE_DEVICE_TAPE_FILE_SYSTEM = $00000020;\r\n {$EXTERNALSYM FILE_DEVICE_TAPE_FILE_SYSTEM}\r\n FILE_DEVICE_TRANSPORT = $00000021;\r\n {$EXTERNALSYM FILE_DEVICE_TRANSPORT}\r\n FILE_DEVICE_UNKNOWN = $00000022;\r\n {$EXTERNALSYM FILE_DEVICE_UNKNOWN}\r\n FILE_DEVICE_VIDEO = $00000023;\r\n {$EXTERNALSYM FILE_DEVICE_VIDEO}\r\n FILE_DEVICE_VIRTUAL_DISK = $00000024;\r\n {$EXTERNALSYM FILE_DEVICE_VIRTUAL_DISK}\r\n FILE_DEVICE_WAVE_IN = $00000025;\r\n {$EXTERNALSYM FILE_DEVICE_WAVE_IN}\r\n FILE_DEVICE_WAVE_OUT = $00000026;\r\n {$EXTERNALSYM FILE_DEVICE_WAVE_OUT}\r\n FILE_DEVICE_8042_PORT = $00000027;\r\n {$EXTERNALSYM FILE_DEVICE_8042_PORT}\r\n FILE_DEVICE_NETWORK_REDIRECTOR = $00000028;\r\n {$EXTERNALSYM FILE_DEVICE_NETWORK_REDIRECTOR}\r\n FILE_DEVICE_BATTERY = $00000029;\r\n {$EXTERNALSYM FILE_DEVICE_BATTERY}\r\n FILE_DEVICE_BUS_EXTENDER = $0000002a;\r\n {$EXTERNALSYM FILE_DEVICE_BUS_EXTENDER}\r\n FILE_DEVICE_MODEM = $0000002b;\r\n {$EXTERNALSYM FILE_DEVICE_MODEM}\r\n FILE_DEVICE_VDM = $0000002c;\r\n {$EXTERNALSYM FILE_DEVICE_VDM}\r\n FILE_DEVICE_MASS_STORAGE = $0000002d;\r\n {$EXTERNALSYM FILE_DEVICE_MASS_STORAGE}\r\n FILE_DEVICE_SMB = $0000002e;\r\n {$EXTERNALSYM FILE_DEVICE_SMB}\r\n FILE_DEVICE_KS = $0000002f;\r\n {$EXTERNALSYM FILE_DEVICE_KS}\r\n FILE_DEVICE_CHANGER = $00000030;\r\n {$EXTERNALSYM FILE_DEVICE_CHANGER}\r\n FILE_DEVICE_SMARTCARD = $00000031;\r\n {$EXTERNALSYM FILE_DEVICE_SMARTCARD}\r\n FILE_DEVICE_ACPI = $00000032;\r\n {$EXTERNALSYM FILE_DEVICE_ACPI}\r\n FILE_DEVICE_DVD = $00000033;\r\n {$EXTERNALSYM FILE_DEVICE_DVD}\r\n FILE_DEVICE_FULLSCREEN_VIDEO = $00000034;\r\n {$EXTERNALSYM FILE_DEVICE_FULLSCREEN_VIDEO}\r\n FILE_DEVICE_DFS_FILE_SYSTEM = $00000035;\r\n {$EXTERNALSYM FILE_DEVICE_DFS_FILE_SYSTEM}\r\n FILE_DEVICE_DFS_VOLUME = $00000036;\r\n {$EXTERNALSYM FILE_DEVICE_DFS_VOLUME}\r\n FILE_DEVICE_SERENUM = $00000037;\r\n {$EXTERNALSYM FILE_DEVICE_SERENUM}\r\n FILE_DEVICE_TERMSRV = $00000038;\r\n {$EXTERNALSYM FILE_DEVICE_TERMSRV}\r\n FILE_DEVICE_KSEC = $00000039;\r\n {$EXTERNALSYM FILE_DEVICE_KSEC}\r\n FILE_DEVICE_FIPS = $0000003A;\r\n {$EXTERNALSYM FILE_DEVICE_FIPS}\r\n FILE_DEVICE_INFINIBAND = $0000003B;\r\n {$EXTERNALSYM FILE_DEVICE_INFINIBAND}\r\n\r\n// line 297\r\n\r\n//\r\n// Define the method codes for how buffers are passed for I/O and FS controls\r\n//\r\n\r\nconst\r\n METHOD_BUFFERED = 0;\r\n {$EXTERNALSYM METHOD_BUFFERED}\r\n METHOD_IN_DIRECT = 1;\r\n {$EXTERNALSYM METHOD_IN_DIRECT}\r\n METHOD_OUT_DIRECT = 2;\r\n {$EXTERNALSYM METHOD_OUT_DIRECT}\r\n METHOD_NEITHER = 3;\r\n {$EXTERNALSYM METHOD_NEITHER}\r\n\r\n//\r\n// Define some easier to comprehend aliases:\r\n// METHOD_DIRECT_TO_HARDWARE (writes, aka METHOD_IN_DIRECT)\r\n// METHOD_DIRECT_FROM_HARDWARE (reads, aka METHOD_OUT_DIRECT)\r\n//\r\n\r\n METHOD_DIRECT_TO_HARDWARE = METHOD_IN_DIRECT;\r\n {$EXTERNALSYM METHOD_DIRECT_TO_HARDWARE}\r\n METHOD_DIRECT_FROM_HARDWARE = METHOD_OUT_DIRECT;\r\n {$EXTERNALSYM METHOD_DIRECT_FROM_HARDWARE}\r\n\r\n//\r\n// Define the access check value for any access\r\n//\r\n//\r\n// The FILE_READ_ACCESS and FILE_WRITE_ACCESS constants are also defined in\r\n// ntioapi.h as FILE_READ_DATA and FILE_WRITE_DATA. The values for these\r\n// constants *MUST* always be in sync.\r\n//\r\n//\r\n// FILE_SPECIAL_ACCESS is checked by the NT I/O system the same as FILE_ANY_ACCESS.\r\n// The file systems, however, may add additional access checks for I/O and FS controls\r\n// that use this value.\r\n//\r\n\r\nconst\r\n FILE_ANY_ACCESS = 0;\r\n {$EXTERNALSYM FILE_ANY_ACCESS}\r\n FILE_SPECIAL_ACCESS = FILE_ANY_ACCESS;\r\n {$EXTERNALSYM FILE_SPECIAL_ACCESS}\r\n FILE_READ_ACCESS = $0001; // file & pipe\r\n {$EXTERNALSYM FILE_READ_ACCESS}\r\n FILE_WRITE_ACCESS = $0002; // file & pipe\r\n {$EXTERNALSYM FILE_WRITE_ACCESS}\r\n\r\n// line 3425\r\n\r\n//\r\n// The following is a list of the native file system fsctls followed by\r\n// additional network file system fsctls. Some values have been\r\n// decommissioned.\r\n//\r\n\r\nconst\r\n\r\n FSCTL_REQUEST_OPLOCK_LEVEL_1 = (\r\n (FILE_DEVICE_FILE_SYSTEM shl 16) or (FILE_ANY_ACCESS shl 14) or\r\n (0 shl 2) or METHOD_BUFFERED);\r\n {$EXTERNALSYM FSCTL_REQUEST_OPLOCK_LEVEL_1}\r\n\r\n FSCTL_REQUEST_OPLOCK_LEVEL_2 = (\r\n (FILE_DEVICE_FILE_SYSTEM shl 16) or (FILE_ANY_ACCESS shl 14) or\r\n (1 shl 2) or METHOD_BUFFERED);\r\n {$EXTERNALSYM FSCTL_REQUEST_OPLOCK_LEVEL_2}\r\n\r\n FSCTL_REQUEST_BATCH_OPLOCK = (\r\n (FILE_DEVICE_FILE_SYSTEM shl 16) or (FILE_ANY_ACCESS shl 14) or\r\n (2 shl 2) or METHOD_BUFFERED);\r\n {$EXTERNALSYM FSCTL_REQUEST_BATCH_OPLOCK}\r\n\r\n FSCTL_OPLOCK_BREAK_ACKNOWLEDGE = (\r\n (FILE_DEVICE_FILE_SYSTEM shl 16) or (FILE_ANY_ACCESS shl 14) or\r\n (3 shl 2) or METHOD_BUFFERED);\r\n {$EXTERNALSYM FSCTL_OPLOCK_BREAK_ACKNOWLEDGE}\r\n\r\n FSCTL_OPBATCH_ACK_CLOSE_PENDING = (\r\n (FILE_DEVICE_FILE_SYSTEM shl 16) or (FILE_ANY_ACCESS shl 14) or\r\n (4 shl 2) or METHOD_BUFFERED);\r\n {$EXTERNALSYM FSCTL_OPBATCH_ACK_CLOSE_PENDING}\r\n\r\n FSCTL_OPLOCK_BREAK_NOTIFY = (\r\n (FILE_DEVICE_FILE_SYSTEM shl 16) or (FILE_ANY_ACCESS shl 14) or\r\n (5 shl 2) or METHOD_BUFFERED);\r\n {$EXTERNALSYM FSCTL_OPLOCK_BREAK_NOTIFY}\r\n\r\n FSCTL_LOCK_VOLUME = ((FILE_DEVICE_FILE_SYSTEM shl 16) or (FILE_ANY_ACCESS shl 14) or (6 shl 2) or METHOD_BUFFERED);\r\n {$EXTERNALSYM FSCTL_LOCK_VOLUME}\r\n\r\n FSCTL_UNLOCK_VOLUME = (\r\n (FILE_DEVICE_FILE_SYSTEM shl 16) or (FILE_ANY_ACCESS shl 14) or\r\n (7 shl 2) or METHOD_BUFFERED);\r\n {$EXTERNALSYM FSCTL_UNLOCK_VOLUME}\r\n\r\n FSCTL_DISMOUNT_VOLUME = (\r\n (FILE_DEVICE_FILE_SYSTEM shl 16) or (FILE_ANY_ACCESS shl 14) or\r\n (8 shl 2) or METHOD_BUFFERED);\r\n {$EXTERNALSYM FSCTL_DISMOUNT_VOLUME}\r\n\r\n// decommissioned fsctl value 9\r\n\r\n FSCTL_IS_VOLUME_MOUNTED = (\r\n (FILE_DEVICE_FILE_SYSTEM shl 16) or (FILE_ANY_ACCESS shl 14) or\r\n (10 shl 2) or METHOD_BUFFERED);\r\n {$EXTERNALSYM FSCTL_IS_VOLUME_MOUNTED}\r\n\r\n FSCTL_IS_PATHNAME_VALID = (\r\n (FILE_DEVICE_FILE_SYSTEM shl 16) or (FILE_ANY_ACCESS shl 14) or\r\n (11 shl 2) or METHOD_BUFFERED); // PATHNAME_BUFFER,\r\n {$EXTERNALSYM FSCTL_IS_PATHNAME_VALID}\r\n\r\n FSCTL_MARK_VOLUME_DIRTY = (\r\n (FILE_DEVICE_FILE_SYSTEM shl 16) or (FILE_ANY_ACCESS shl 14) or\r\n (12 shl 2) or METHOD_BUFFERED);\r\n {$EXTERNALSYM FSCTL_MARK_VOLUME_DIRTY}\r\n\r\n// decommissioned fsctl value 13\r\n\r\n FSCTL_QUERY_RETRIEVAL_POINTERS = (\r\n (FILE_DEVICE_FILE_SYSTEM shl 16) or (FILE_ANY_ACCESS shl 14) or\r\n (14 shl 2) or METHOD_NEITHER);\r\n {$EXTERNALSYM FSCTL_QUERY_RETRIEVAL_POINTERS}\r\n\r\n FSCTL_GET_COMPRESSION = (\r\n (FILE_DEVICE_FILE_SYSTEM shl 16) or (FILE_ANY_ACCESS shl 14) or\r\n (15 shl 2) or METHOD_BUFFERED);\r\n {$EXTERNALSYM FSCTL_GET_COMPRESSION}\r\n\r\n FSCTL_SET_COMPRESSION = (\r\n (FILE_DEVICE_FILE_SYSTEM shl 16) or ((FILE_READ_DATA or FILE_WRITE_DATA) shl 14) or\r\n (16 shl 2) or METHOD_BUFFERED);\r\n {$EXTERNALSYM FSCTL_SET_COMPRESSION}\r\n\r\n// decommissioned fsctl value 17\r\n// decommissioned fsctl value 18\r\n\r\n FSCTL_MARK_AS_SYSTEM_HIVE = (\r\n (FILE_DEVICE_FILE_SYSTEM shl 16) or (FILE_ANY_ACCESS shl 14) or\r\n (19 shl 2) or METHOD_NEITHER);\r\n {$EXTERNALSYM FSCTL_MARK_AS_SYSTEM_HIVE}\r\n\r\n FSCTL_OPLOCK_BREAK_ACK_NO_2 = (\r\n (FILE_DEVICE_FILE_SYSTEM shl 16) or (FILE_ANY_ACCESS shl 14) or\r\n (20 shl 2) or METHOD_BUFFERED);\r\n {$EXTERNALSYM FSCTL_OPLOCK_BREAK_ACK_NO_2}\r\n\r\n FSCTL_INVALIDATE_VOLUMES = (\r\n (FILE_DEVICE_FILE_SYSTEM shl 16) or (FILE_ANY_ACCESS shl 14) or\r\n (21 shl 2) or METHOD_BUFFERED);\r\n {$EXTERNALSYM FSCTL_INVALIDATE_VOLUMES}\r\n\r\n FSCTL_QUERY_FAT_BPB = (\r\n (FILE_DEVICE_FILE_SYSTEM shl 16) or (FILE_ANY_ACCESS shl 14) or\r\n (22 shl 2) or METHOD_BUFFERED); // FSCTL_QUERY_FAT_BPB_BUFFER\r\n {$EXTERNALSYM FSCTL_QUERY_FAT_BPB}\r\n\r\n FSCTL_REQUEST_FILTER_OPLOCK = (\r\n (FILE_DEVICE_FILE_SYSTEM shl 16) or (FILE_ANY_ACCESS shl 14) or\r\n (23 shl 2) or METHOD_BUFFERED);\r\n {$EXTERNALSYM FSCTL_REQUEST_FILTER_OPLOCK}\r\n\r\n FSCTL_FILESYSTEM_GET_STATISTICS = (\r\n (FILE_DEVICE_FILE_SYSTEM shl 16) or (FILE_ANY_ACCESS shl 14) or\r\n (24 shl 2) or METHOD_BUFFERED); // FILESYSTEM_STATISTICS\r\n {$EXTERNALSYM FSCTL_FILESYSTEM_GET_STATISTICS}\r\n\r\n FSCTL_GET_NTFS_VOLUME_DATA = (\r\n (FILE_DEVICE_FILE_SYSTEM shl 16) or (FILE_ANY_ACCESS shl 14) or\r\n (25 shl 2) or METHOD_BUFFERED);\r\n {$EXTERNALSYM FSCTL_GET_NTFS_VOLUME_DATA}\r\n\r\n FSCTL_GET_NTFS_FILE_RECORD = (\r\n (FILE_DEVICE_FILE_SYSTEM shl 16) or (FILE_ANY_ACCESS shl 14) or\r\n (26 shl 2) or METHOD_BUFFERED);\r\n {$EXTERNALSYM FSCTL_GET_NTFS_FILE_RECORD}\r\n\r\n FSCTL_GET_VOLUME_BITMAP = (\r\n (FILE_DEVICE_FILE_SYSTEM shl 16) or (FILE_ANY_ACCESS shl 14) or\r\n (27 shl 2) or METHOD_NEITHER);\r\n {$EXTERNALSYM FSCTL_GET_VOLUME_BITMAP}\r\n\r\n FSCTL_GET_RETRIEVAL_POINTERS = (\r\n (FILE_DEVICE_FILE_SYSTEM shl 16) or (FILE_ANY_ACCESS shl 14) or\r\n (28 shl 2) or METHOD_NEITHER);\r\n {$EXTERNALSYM FSCTL_GET_RETRIEVAL_POINTERS}\r\n\r\n FSCTL_MOVE_FILE = (\r\n (FILE_DEVICE_FILE_SYSTEM shl 16) or (FILE_SPECIAL_ACCESS shl 14) or\r\n (29 shl 2) or METHOD_BUFFERED);\r\n {$EXTERNALSYM FSCTL_MOVE_FILE}\r\n\r\n FSCTL_IS_VOLUME_DIRTY = (\r\n (FILE_DEVICE_FILE_SYSTEM shl 16) or (FILE_ANY_ACCESS shl 14) or\r\n (30 shl 2) or METHOD_BUFFERED);\r\n {$EXTERNALSYM FSCTL_IS_VOLUME_DIRTY}\r\n\r\n// decomissioned fsctl value 31\r\n(* FSCTL_GET_HFS_INFORMATION = (\r\n (FILE_DEVICE_FILE_SYSTEM shl 16) or (FILE_ANY_ACCESS shl 14) or\r\n (31 shl 2) or METHOD_BUFFERED);\r\n {$EXTERNALSYM FSCTL_GET_HFS_INFORMATION}\r\n*)\r\n\r\n FSCTL_ALLOW_EXTENDED_DASD_IO = (\r\n (FILE_DEVICE_FILE_SYSTEM shl 16) or (FILE_ANY_ACCESS shl 14) or\r\n (32 shl 2) or METHOD_NEITHER);\r\n {$EXTERNALSYM FSCTL_ALLOW_EXTENDED_DASD_IO}\r\n\r\n// decommissioned fsctl value 33\r\n// decommissioned fsctl value 34\r\n\r\n(*\r\n FSCTL_READ_PROPERTY_DATA = (\r\n (FILE_DEVICE_FILE_SYSTEM shl 16) or (FILE_ANY_ACCESS shl 14) or\r\n (33 shl 2) or METHOD_NEITHER);\r\n {$EXTERNALSYM FSCTL_READ_PROPERTY_DATA}\r\n\r\n FSCTL_WRITE_PROPERTY_DATA = (\r\n (FILE_DEVICE_FILE_SYSTEM shl 16) or (FILE_ANY_ACCESS shl 14) or\r\n (34 shl 2) or METHOD_NEITHER);\r\n {$EXTERNALSYM FSCTL_WRITE_PROPERTY_DATA}\r\n*)\r\n\r\n FSCTL_FIND_FILES_BY_SID = (\r\n (FILE_DEVICE_FILE_SYSTEM shl 16) or (FILE_ANY_ACCESS shl 14) or\r\n (35 shl 2) or METHOD_NEITHER); \r\n {$EXTERNALSYM FSCTL_FIND_FILES_BY_SID}\r\n\r\n// decommissioned fsctl value 36\r\n// decommissioned fsctl value 37\r\n\r\n(* FSCTL_DUMP_PROPERTY_DATA = (\r\n (FILE_DEVICE_FILE_SYSTEM shl 16) or (FILE_ANY_ACCESS shl 14) or\r\n (37 shl 2) or METHOD_NEITHER);\r\n {$EXTERNALSYM FSCTL_DUMP_PROPERTY_DATA}\r\n*)\r\n\r\n FSCTL_SET_OBJECT_ID = (\r\n (FILE_DEVICE_FILE_SYSTEM shl 16) or (FILE_SPECIAL_ACCESS shl 14) or\r\n (38 shl 2) or METHOD_BUFFERED);\r\n {$EXTERNALSYM FSCTL_SET_OBJECT_ID}\r\n\r\n FSCTL_GET_OBJECT_ID = (\r\n (FILE_DEVICE_FILE_SYSTEM shl 16) or (FILE_ANY_ACCESS shl 14) or\r\n (39 shl 2) or METHOD_BUFFERED);\r\n {$EXTERNALSYM FSCTL_GET_OBJECT_ID}\r\n\r\n FSCTL_DELETE_OBJECT_ID = (\r\n (FILE_DEVICE_FILE_SYSTEM shl 16) or (FILE_SPECIAL_ACCESS shl 14) or\r\n (40 shl 2) or METHOD_BUFFERED);\r\n {$EXTERNALSYM FSCTL_DELETE_OBJECT_ID}\r\n\r\n FSCTL_SET_REPARSE_POINT = (\r\n (FILE_DEVICE_FILE_SYSTEM shl 16) or (FILE_SPECIAL_ACCESS shl 14) or\r\n (41 shl 2) or METHOD_BUFFERED);\r\n {$EXTERNALSYM FSCTL_SET_REPARSE_POINT}\r\n\r\n FSCTL_GET_REPARSE_POINT = (\r\n (FILE_DEVICE_FILE_SYSTEM shl 16) or (FILE_ANY_ACCESS shl 14) or\r\n (42 shl 2) or METHOD_BUFFERED);\r\n {$EXTERNALSYM FSCTL_GET_REPARSE_POINT}\r\n\r\n FSCTL_DELETE_REPARSE_POINT = (\r\n (FILE_DEVICE_FILE_SYSTEM shl 16) or (FILE_SPECIAL_ACCESS shl 14) or\r\n (43 shl 2) or METHOD_BUFFERED);\r\n {$EXTERNALSYM FSCTL_DELETE_REPARSE_POINT}\r\n\r\n FSCTL_ENUM_USN_DATA = (\r\n (FILE_DEVICE_FILE_SYSTEM shl 16) or (FILE_ANY_ACCESS shl 14) or\r\n (44 shl 2) or METHOD_NEITHER);\r\n {$EXTERNALSYM FSCTL_ENUM_USN_DATA}\r\n\r\n FSCTL_SECURITY_ID_CHECK = (\r\n (FILE_DEVICE_FILE_SYSTEM shl 16) or (FILE_READ_DATA shl 14) or\r\n (45 shl 2) or METHOD_NEITHER);\r\n {$EXTERNALSYM FSCTL_SECURITY_ID_CHECK}\r\n\r\n FSCTL_READ_USN_JOURNAL = (\r\n (FILE_DEVICE_FILE_SYSTEM shl 16) or (FILE_ANY_ACCESS shl 14) or\r\n (46 shl 2) or METHOD_NEITHER);\r\n {$EXTERNALSYM FSCTL_READ_USN_JOURNAL}\r\n\r\n FSCTL_SET_OBJECT_ID_EXTENDED = (\r\n (FILE_DEVICE_FILE_SYSTEM shl 16) or (FILE_SPECIAL_ACCESS shl 14) or\r\n (47 shl 2) or METHOD_BUFFERED);\r\n {$EXTERNALSYM FSCTL_SET_OBJECT_ID_EXTENDED}\r\n\r\n FSCTL_CREATE_OR_GET_OBJECT_ID = (\r\n (FILE_DEVICE_FILE_SYSTEM shl 16) or (FILE_ANY_ACCESS shl 14) or\r\n (48 shl 2) or METHOD_BUFFERED);\r\n {$EXTERNALSYM FSCTL_CREATE_OR_GET_OBJECT_ID}\r\n\r\n FSCTL_SET_SPARSE = (\r\n (FILE_DEVICE_FILE_SYSTEM shl 16) or (FILE_SPECIAL_ACCESS shl 14) or\r\n (49 shl 2) or METHOD_BUFFERED);\r\n {$EXTERNALSYM FSCTL_SET_SPARSE}\r\n\r\n FSCTL_SET_ZERO_DATA = (\r\n (FILE_DEVICE_FILE_SYSTEM shl 16) or (FILE_WRITE_DATA shl 14) or\r\n (50 shl 2) or METHOD_BUFFERED);\r\n {$EXTERNALSYM FSCTL_SET_ZERO_DATA}\r\n\r\n FSCTL_QUERY_ALLOCATED_RANGES = (\r\n (FILE_DEVICE_FILE_SYSTEM shl 16) or (FILE_READ_DATA shl 14) or\r\n (51 shl 2) or METHOD_NEITHER);\r\n {$EXTERNALSYM FSCTL_QUERY_ALLOCATED_RANGES}\r\n\r\n// decommissioned fsctl value 52\r\n(*\r\n FSCTL_ENABLE_UPGRADE = (\r\n (FILE_DEVICE_FILE_SYSTEM shl 16) or (FILE_WRITE_DATA shl 14) or\r\n (52 shl 2) or METHOD_BUFFERED);\r\n {$EXTERNALSYM FSCTL_ENABLE_UPGRADE}\r\n*)\r\n\r\n FSCTL_SET_ENCRYPTION = (\r\n (FILE_DEVICE_FILE_SYSTEM shl 16) or (FILE_ANY_ACCESS shl 14) or\r\n (53 shl 2) or METHOD_NEITHER);\r\n {$EXTERNALSYM FSCTL_SET_ENCRYPTION}\r\n\r\n FSCTL_ENCRYPTION_FSCTL_IO = (\r\n (FILE_DEVICE_FILE_SYSTEM shl 16) or (FILE_ANY_ACCESS shl 14) or\r\n (54 shl 2) or METHOD_NEITHER);\r\n {$EXTERNALSYM FSCTL_ENCRYPTION_FSCTL_IO}\r\n\r\n FSCTL_WRITE_RAW_ENCRYPTED = (\r\n (FILE_DEVICE_FILE_SYSTEM shl 16) or (FILE_SPECIAL_ACCESS shl 14) or\r\n (55 shl 2) or METHOD_NEITHER);\r\n {$EXTERNALSYM FSCTL_WRITE_RAW_ENCRYPTED}\r\n\r\n FSCTL_READ_RAW_ENCRYPTED = (\r\n (FILE_DEVICE_FILE_SYSTEM shl 16) or (FILE_SPECIAL_ACCESS shl 14) or\r\n (56 shl 2) or METHOD_NEITHER);\r\n {$EXTERNALSYM FSCTL_READ_RAW_ENCRYPTED}\r\n\r\n FSCTL_CREATE_USN_JOURNAL = (\r\n (FILE_DEVICE_FILE_SYSTEM shl 16) or (FILE_ANY_ACCESS shl 14) or\r\n (57 shl 2) or METHOD_NEITHER);\r\n {$EXTERNALSYM FSCTL_CREATE_USN_JOURNAL}\r\n\r\n FSCTL_READ_FILE_USN_DATA = (\r\n (FILE_DEVICE_FILE_SYSTEM shl 16) or (FILE_ANY_ACCESS shl 14) or\r\n (58 shl 2) or METHOD_NEITHER);\r\n {$EXTERNALSYM FSCTL_READ_FILE_USN_DATA}\r\n\r\n FSCTL_WRITE_USN_CLOSE_RECORD = (\r\n (FILE_DEVICE_FILE_SYSTEM shl 16) or (FILE_ANY_ACCESS shl 14) or\r\n (59 shl 2) or METHOD_NEITHER);\r\n {$EXTERNALSYM FSCTL_WRITE_USN_CLOSE_RECORD}\r\n\r\n FSCTL_EXTEND_VOLUME = (\r\n (FILE_DEVICE_FILE_SYSTEM shl 16) or (FILE_ANY_ACCESS shl 14) or\r\n (60 shl 2) or METHOD_BUFFERED);\r\n {$EXTERNALSYM FSCTL_EXTEND_VOLUME}\r\n\r\n FSCTL_QUERY_USN_JOURNAL = (\r\n (FILE_DEVICE_FILE_SYSTEM shl 16) or (FILE_ANY_ACCESS shl 14) or\r\n (61 shl 2) or METHOD_BUFFERED);\r\n {$EXTERNALSYM FSCTL_QUERY_USN_JOURNAL}\r\n\r\n FSCTL_DELETE_USN_JOURNAL = (\r\n (FILE_DEVICE_FILE_SYSTEM shl 16) or (FILE_ANY_ACCESS shl 14) or\r\n (62 shl 2) or METHOD_BUFFERED);\r\n {$EXTERNALSYM FSCTL_DELETE_USN_JOURNAL}\r\n\r\n FSCTL_MARK_HANDLE = (\r\n (FILE_DEVICE_FILE_SYSTEM shl 16) or (FILE_ANY_ACCESS shl 14) or\r\n (63 shl 2) or METHOD_BUFFERED);\r\n {$EXTERNALSYM FSCTL_MARK_HANDLE}\r\n\r\n FSCTL_SIS_COPYFILE = (\r\n (FILE_DEVICE_FILE_SYSTEM shl 16) or (FILE_ANY_ACCESS shl 14) or\r\n (64 shl 2) or METHOD_BUFFERED);\r\n {$EXTERNALSYM FSCTL_SIS_COPYFILE}\r\n\r\n FSCTL_SIS_LINK_FILES = (\r\n (FILE_DEVICE_FILE_SYSTEM shl 16) or ((FILE_READ_DATA or FILE_WRITE_DATA) shl 14) or\r\n (65 shl 2) or METHOD_BUFFERED);\r\n {$EXTERNALSYM FSCTL_SIS_LINK_FILES}\r\n\r\n FSCTL_HSM_MSG = (\r\n (FILE_DEVICE_FILE_SYSTEM shl 16) or ((FILE_READ_DATA or FILE_WRITE_DATA) shl 14) or\r\n (66 shl 2) or METHOD_BUFFERED);\r\n {$EXTERNALSYM FSCTL_HSM_MSG}\r\n\r\n// decommissioned fsctl value 67\r\n(*\r\n FSCTL_NSS_CONTROL = (\r\n (FILE_DEVICE_FILE_SYSTEM shl 16) or (FILE_WRITE_DATA shl 14) or\r\n (67 shl 2) or METHOD_BUFFERED);\r\n {$EXTERNALSYM FSCTL_NSS_CONTROL}\r\n*)\r\n\r\n FSCTL_HSM_DATA = (\r\n (FILE_DEVICE_FILE_SYSTEM shl 16) or ((FILE_READ_DATA or FILE_WRITE_DATA) shl 14) or\r\n (68 shl 2) or METHOD_NEITHER);\r\n {$EXTERNALSYM FSCTL_HSM_DATA}\r\n\r\n FSCTL_RECALL_FILE = (\r\n (FILE_DEVICE_FILE_SYSTEM shl 16) or (FILE_ANY_ACCESS shl 14) or\r\n (69 shl 2) or METHOD_NEITHER);\r\n {$EXTERNALSYM FSCTL_RECALL_FILE}\r\n\r\n// decommissioned fsctl value 70\r\n(*\r\n FSCTL_NSS_RCONTROL = (\r\n (FILE_DEVICE_FILE_SYSTEM shl 16) or (FILE_READ_DATA shl 14) or\r\n (70 shl 2) or METHOD_BUFFERED);\r\n {$EXTERNALSYM FSCTL_NSS_RCONTROL}\r\n*)\r\n\r\n FSCTL_READ_FROM_PLEX = (\r\n (FILE_DEVICE_FILE_SYSTEM shl 16) or (FILE_READ_DATA shl 14) or\r\n (71 shl 2) or METHOD_OUT_DIRECT);\r\n {$EXTERNALSYM FSCTL_READ_FROM_PLEX}\r\n\r\n FSCTL_FILE_PREFETCH = (\r\n (FILE_DEVICE_FILE_SYSTEM shl 16) or (FILE_SPECIAL_ACCESS shl 14) or\r\n (72 shl 2) or METHOD_BUFFERED);\r\n {$EXTERNALSYM FSCTL_FILE_PREFETCH}\r\n\r\n// line 4553\r\n\r\n//\r\n// Structure for FSCTL_SET_ZERO_DATA\r\n//\r\n\r\ntype\r\n\r\n PFILE_ZERO_DATA_INFORMATION = ^FILE_ZERO_DATA_INFORMATION;\r\n {$EXTERNALSYM PFILE_ZERO_DATA_INFORMATION}\r\n _FILE_ZERO_DATA_INFORMATION = record\r\n FileOffset: LARGE_INTEGER;\r\n BeyondFinalZero: LARGE_INTEGER;\r\n end;\r\n {$EXTERNALSYM _FILE_ZERO_DATA_INFORMATION}\r\n FILE_ZERO_DATA_INFORMATION = _FILE_ZERO_DATA_INFORMATION;\r\n {$EXTERNALSYM FILE_ZERO_DATA_INFORMATION}\r\n TFileZeroDataInformation = FILE_ZERO_DATA_INFORMATION;\r\n PFileZeroDataInformation = PFILE_ZERO_DATA_INFORMATION;\r\n\r\n//\r\n// Structure for FSCTL_QUERY_ALLOCATED_RANGES\r\n//\r\n\r\n//\r\n// Querying the allocated ranges requires an output buffer to store the\r\n// allocated ranges and an input buffer to specify the range to query.\r\n// The input buffer contains a single entry, the output buffer is an\r\n// array of the following structure.\r\n//\r\n\r\n PFILE_ALLOCATED_RANGE_BUFFER = ^FILE_ALLOCATED_RANGE_BUFFER;\r\n {$EXTERNALSYM PFILE_ALLOCATED_RANGE_BUFFER}\r\n _FILE_ALLOCATED_RANGE_BUFFER = record\r\n FileOffset: LARGE_INTEGER;\r\n Length: LARGE_INTEGER;\r\n end;\r\n {$EXTERNALSYM _FILE_ALLOCATED_RANGE_BUFFER}\r\n FILE_ALLOCATED_RANGE_BUFFER = _FILE_ALLOCATED_RANGE_BUFFER;\r\n {$EXTERNALSYM FILE_ALLOCATED_RANGE_BUFFER}\r\n TFileAllocatedRangeBuffer = FILE_ALLOCATED_RANGE_BUFFER;\r\n PFileAllocatedRangeBuffer = PFILE_ALLOCATED_RANGE_BUFFER;\r\n\r\n\r\n// line 340\r\n\r\n//\r\n// Code Page Default Values.\r\n//\r\n\r\nconst\r\n CP_ACP = 0; // default to ANSI code page\r\n {$EXTERNALSYM CP_ACP}\r\n CP_OEMCP = 1; // default to OEM code page\r\n {$EXTERNALSYM CP_OEMCP}\r\n CP_MACCP = 2; // default to MAC code page\r\n {$EXTERNALSYM CP_MACCP}\r\n CP_THREAD_ACP = 3; // current thread's ANSI code page\r\n {$EXTERNALSYM CP_THREAD_ACP}\r\n CP_SYMBOL = 42; // SYMBOL translations\r\n {$EXTERNALSYM CP_SYMBOL}\r\n\r\n CP_UTF7 = 65000; // UTF-7 translation\r\n {$EXTERNALSYM CP_UTF7}\r\n CP_UTF8 = 65001; // UTF-8 translation\r\n {$EXTERNALSYM CP_UTF8}\r\n\r\n// line 597\r\n\r\nconst\r\n\r\n//\r\n// The following LCTypes may be used in combination with any other LCTypes.\r\n//\r\n// LOCALE_NOUSEROVERRIDE is also used in GetTimeFormat and\r\n// GetDateFormat.\r\n//\r\n// LOCALE_USE_CP_ACP is used in many of the A (Ansi) apis that need\r\n// to do string translation.\r\n//\r\n// LOCALE_RETURN_NUMBER will return the result from GetLocaleInfo as a\r\n// number instead of a string. This flag is only valid for the LCTypes\r\n// beginning with LOCALE_I.\r\n//\r\n\r\n LOCALE_NOUSEROVERRIDE = DWORD($80000000); // do not use user overrides\r\n {$EXTERNALSYM LOCALE_NOUSEROVERRIDE}\r\n LOCALE_USE_CP_ACP = $40000000; // use the system ACP\r\n {$EXTERNALSYM LOCALE_USE_CP_ACP}\r\n\r\n LOCALE_RETURN_NUMBER = $20000000; // return number instead of string\r\n {$EXTERNALSYM LOCALE_RETURN_NUMBER}\r\n\r\n// line 841\r\n\r\nconst\r\n LOCALE_IDEFAULTEBCDICCODEPAGE = $00001012; // default ebcdic code page\r\n {$EXTERNALSYM LOCALE_IDEFAULTEBCDICCODEPAGE}\r\n LOCALE_IPAPERSIZE = $0000100A; // 1 = letter, 5 = legal, 8 = a3, 9 = a4\r\n {$EXTERNALSYM LOCALE_IPAPERSIZE}\r\n LOCALE_SENGCURRNAME = $00001007; // english name of currency\r\n {$EXTERNALSYM LOCALE_SENGCURRNAME}\r\n LOCALE_SNATIVECURRNAME = $00001008; // native name of currency\r\n {$EXTERNALSYM LOCALE_SNATIVECURRNAME}\r\n LOCALE_SYEARMONTH = $00001006; // year month format string\r\n {$EXTERNALSYM LOCALE_SYEARMONTH}\r\n LOCALE_SSORTNAME = $00001013; // sort name\r\n {$EXTERNALSYM LOCALE_SSORTNAME}\r\n LOCALE_IDIGITSUBSTITUTION = $00001014; // 0 = context, 1 = none, 2 = national\r\n {$EXTERNALSYM LOCALE_IDIGITSUBSTITUTION}\r\n\r\n// line 880\r\n\r\n DATE_YEARMONTH = $00000008; // use year month picture\r\n {$EXTERNALSYM DATE_YEARMONTH}\r\n DATE_LTRREADING = $00000010; // add marks for left to right reading order layout\r\n {$EXTERNALSYM DATE_LTRREADING}\r\n DATE_RTLREADING = $00000020; // add marks for right to left reading order layout\r\n {$EXTERNALSYM DATE_RTLREADING}\r\n\r\n//\r\n// Calendar Types.\r\n//\r\n// These types are used for the EnumCalendarInfo and GetCalendarInfo\r\n// NLS API routines.\r\n// Some of these types are also used for the SetCalendarInfo NLS API\r\n// routine.\r\n//\r\n\r\n//\r\n// The following CalTypes may be used in combination with any other CalTypes.\r\n//\r\n// CAL_NOUSEROVERRIDE\r\n//\r\n// CAL_USE_CP_ACP is used in the A (Ansi) apis that need to do string\r\n// translation.\r\n//\r\n// CAL_RETURN_NUMBER will return the result from GetCalendarInfo as a\r\n// number instead of a string. This flag is only valid for the CalTypes\r\n// beginning with CAL_I.\r\n//\r\n\r\n CAL_NOUSEROVERRIDE = LOCALE_NOUSEROVERRIDE; // do not use user overrides\r\n {$EXTERNALSYM CAL_NOUSEROVERRIDE}\r\n CAL_USE_CP_ACP = LOCALE_USE_CP_ACP; // use the system ACP\r\n {$EXTERNALSYM CAL_USE_CP_ACP}\r\n CAL_RETURN_NUMBER = LOCALE_RETURN_NUMBER; // return number instead of string\r\n {$EXTERNALSYM CAL_RETURN_NUMBER}\r\n\r\n// line 1014\r\n\r\n CAL_SYEARMONTH = $0000002f; // year month format string\r\n {$EXTERNALSYM CAL_SYEARMONTH}\r\n CAL_ITWODIGITYEARMAX = $00000030; // two digit year max\r\n {$EXTERNALSYM CAL_ITWODIGITYEARMAX}\r\n\r\n// line 1424\r\n\r\ntype\r\n CALINFO_ENUMPROCEXW = function (lpCalendarInfoString: LPWSTR; Calendar: CALID): BOOL; stdcall;\r\n {$EXTERNALSYM CALINFO_ENUMPROCEXW}\r\n TCalInfoEnumProcExW = CALINFO_ENUMPROCEXW;\r\n\r\n// line 1635\r\n\r\n\r\nfunction GetCalendarInfoA(Locale: LCID; Calendar: CALID; CalType: CALTYPE;\r\n lpCalData: LPSTR; cchData: Integer; lpValue: LPDWORD): Integer; stdcall;\r\n{$EXTERNALSYM GetCalendarInfoA}\r\nfunction GetCalendarInfoW(Locale: LCID; Calendar: CALID; CalType: CALTYPE;\r\n lpCalData: LPWSTR; cchData: Integer; lpValue: LPDWORD): Integer; stdcall;\r\n{$EXTERNALSYM GetCalendarInfoW}\r\n\r\n// line 1754\r\n\r\nfunction EnumCalendarInfoExW(lpCalInfoEnumProcEx: CALINFO_ENUMPROCEXW;\r\n Locale: LCID; Calendar: CALID; CalType: CALTYPE): BOOL; stdcall;\r\n{$EXTERNALSYM EnumCalendarInfoExW}\r\n\r\n\r\n{$IFNDEF FPC}\r\ntype\r\n MAKEINTRESOURCEA = LPSTR;\r\n {$EXTERNALSYM MAKEINTRESOURCEA}\r\n MAKEINTRESOURCEW = LPWSTR;\r\n {$EXTERNALSYM MAKEINTRESOURCEW}\r\n{$IFDEF SUPPORTS_UNICODE}\r\n MAKEINTRESOURCE = MAKEINTRESOURCEW;\r\n {$EXTERNALSYM MAKEINTRESOURCE}\r\n{$ELSE ~SUPPORTS_UNICODE}\r\n MAKEINTRESOURCE = MAKEINTRESOURCEA;\r\n {$EXTERNALSYM MAKEINTRESOURCE}\r\n{$ENDIF ~SUPPORTS_UNICODE}\r\n{$ENDIF ~FPC}\r\n\r\n//\r\n// Predefined Resource Types\r\n//\r\n\r\nconst\r\n RT_CURSOR = MAKEINTRESOURCE(1);\r\n {$EXTERNALSYM RT_CURSOR}\r\n RT_BITMAP = MAKEINTRESOURCE(2);\r\n {$EXTERNALSYM RT_BITMAP}\r\n RT_ICON = MAKEINTRESOURCE(3);\r\n {$EXTERNALSYM RT_ICON}\r\n RT_MENU = MAKEINTRESOURCE(4);\r\n {$EXTERNALSYM RT_MENU}\r\n RT_DIALOG = MAKEINTRESOURCE(5);\r\n {$EXTERNALSYM RT_DIALOG}\r\n RT_STRING = MAKEINTRESOURCE(6);\r\n {$EXTERNALSYM RT_STRING}\r\n RT_FONTDIR = MAKEINTRESOURCE(7);\r\n {$EXTERNALSYM RT_FONTDIR}\r\n RT_FONT = MAKEINTRESOURCE(8);\r\n {$EXTERNALSYM RT_FONT}\r\n RT_ACCELERATOR = MAKEINTRESOURCE(9);\r\n {$EXTERNALSYM RT_ACCELERATOR}\r\n RT_RCDATA = MAKEINTRESOURCE(10);\r\n {$EXTERNALSYM RT_RCDATA}\r\n RT_MESSAGETABLE = MAKEINTRESOURCE(11);\r\n {$EXTERNALSYM RT_MESSAGETABLE}\r\n\r\n DIFFERENCE = 11;\r\n {$EXTERNALSYM DIFFERENCE}\r\n\r\n RT_GROUP_CURSOR = MAKEINTRESOURCE(ULONG_PTR(RT_CURSOR) + DIFFERENCE);\r\n {$EXTERNALSYM RT_GROUP_CURSOR}\r\n RT_GROUP_ICON = MAKEINTRESOURCE(ULONG_PTR(RT_ICON) + DIFFERENCE);\r\n {$EXTERNALSYM RT_GROUP_ICON}\r\n RT_VERSION = MAKEINTRESOURCE(16);\r\n {$EXTERNALSYM RT_VERSION}\r\n RT_DLGINCLUDE = MAKEINTRESOURCE(17);\r\n {$EXTERNALSYM RT_DLGINCLUDE}\r\n RT_PLUGPLAY = MAKEINTRESOURCE(19);\r\n {$EXTERNALSYM RT_PLUGPLAY}\r\n RT_VXD = MAKEINTRESOURCE(20);\r\n {$EXTERNALSYM RT_VXD}\r\n RT_ANICURSOR = MAKEINTRESOURCE(21);\r\n {$EXTERNALSYM RT_ANICURSOR}\r\n RT_ANIICON = MAKEINTRESOURCE(22);\r\n {$EXTERNALSYM RT_ANIICON}\r\n RT_HTML = MAKEINTRESOURCE(23);\r\n {$EXTERNALSYM RT_HTML}\r\n RT_MANIFEST = MAKEINTRESOURCE(24);\r\n CREATEPROCESS_MANIFEST_RESOURCE_ID = MAKEINTRESOURCE(1);\r\n {$EXTERNALSYM CREATEPROCESS_MANIFEST_RESOURCE_ID}\r\n ISOLATIONAWARE_MANIFEST_RESOURCE_ID = MAKEINTRESOURCE(2);\r\n {$EXTERNALSYM ISOLATIONAWARE_MANIFEST_RESOURCE_ID}\r\n ISOLATIONAWARE_NOSTATICIMPORT_MANIFEST_RESOURCE_ID = MAKEINTRESOURCE(3);\r\n {$EXTERNALSYM ISOLATIONAWARE_NOSTATICIMPORT_MANIFEST_RESOURCE_ID}\r\n MINIMUM_RESERVED_MANIFEST_RESOURCE_ID = MAKEINTRESOURCE(1{inclusive});\r\n {$EXTERNALSYM MINIMUM_RESERVED_MANIFEST_RESOURCE_ID}\r\n MAXIMUM_RESERVED_MANIFEST_RESOURCE_ID = MAKEINTRESOURCE(16{inclusive});\r\n {$EXTERNALSYM MAXIMUM_RESERVED_MANIFEST_RESOURCE_ID}\r\n\r\n// line 1451 \r\n\r\n KLF_SETFORPROCESS = $00000100;\r\n {$EXTERNALSYM KLF_SETFORPROCESS}\r\n KLF_SHIFTLOCK = $00010000;\r\n {$EXTERNALSYM KLF_SHIFTLOCK}\r\n KLF_RESET = $40000000;\r\n {$EXTERNALSYM KLF_RESET}\r\n\r\n// 64 compatible version of GetWindowLong and SetWindowLong\r\n\r\nconst\r\n GWLP_WNDPROC = -4;\r\n {$EXTERNALSYM GWLP_WNDPROC}\r\n GWLP_HINSTANCE = -6;\r\n {$EXTERNALSYM GWLP_HINSTANCE}\r\n GWLP_HWNDPARENT = -8;\r\n {$EXTERNALSYM GWLP_HWNDPARENT}\r\n GWLP_USERDATA = -21;\r\n {$EXTERNALSYM GWLP_USERDATA}\r\n GWLP_ID = -12;\r\n {$EXTERNALSYM GWLP_ID}\r\n\r\n{$EXTERNALSYM GetWindowLongPtr}\r\nfunction GetWindowLongPtr(hWnd: HWND; nIndex: Integer): TJclAddr; stdcall;\r\n{$EXTERNALSYM SetWindowLongPtr}\r\nfunction SetWindowLongPtr(hWnd: HWND; nIndex: Integer; dwNewLong: TJclAddr): Longint; stdcall;\r\n\r\nfunction IsPwrSuspendAllowed: BOOL; stdcall;\r\nfunction IsPwrHibernateAllowed: BOOL; stdcall;\r\nfunction IsPwrShutdownAllowed: BOOL; stdcall;\r\nfunction SetSuspendState(Hibernate, ForceCritical, DisableWakeEvent: BOOL): BOOL; stdcall;\r\n\r\ntype\r\n // Microsoft version (64 bit SDK)\r\n {$EXTERNALSYM RVA}\r\n RVA = DWORD;\r\n\r\n // 64-bit PE\r\n {$EXTERNALSYM ImgDelayDescrV2}\r\n ImgDelayDescrV2 = packed record\r\n grAttrs: DWORD; // attributes\r\n rvaDLLName: RVA; // RVA to dll name\r\n rvaHmod: RVA; // RVA of module handle\r\n rvaIAT: RVA; // RVA of the IAT\r\n rvaINT: RVA; // RVA of the INT\r\n rvaBoundIAT: RVA; // RVA of the optional bound IAT\r\n rvaUnloadIAT: RVA; // RVA of optional copy of original IAT\r\n dwTimeStamp: DWORD; // 0 if not bound,\r\n // O.W. date/time stamp of DLL bound to (Old BIND)\r\n end;\r\n {$EXTERNALSYM TImgDelayDescrV2}\r\n TImgDelayDescrV2 = ImgDelayDescrV2;\r\n {$EXTERNALSYM PImgDelayDescrV2}\r\n PImgDelayDescrV2 = ^ImgDelayDescrV2;\r\n\r\n {$EXTERNALSYM PHMODULE}\r\n PHMODULE = ^HMODULE;\r\n\r\n // 32-bit PE\r\n {$EXTERNALSYM ImgDelayDescrV1}\r\n ImgDelayDescrV1 = packed record\r\n grAttrs: DWORD; // attributes\r\n szName: LPCSTR; // pointer to dll name\r\n phmod: PHMODULE; // address of module handle\r\n pIAT: PImageThunkData32; // address of the IAT\r\n pINT: PImageThunkData32; // address of the INT\r\n pBoundIAT: PImageThunkData32; // address of the optional bound IAT\r\n pUnloadIAT: PImageThunkData32; // address of optional copy of original IAT\r\n dwTimeStamp: DWORD; // 0 if not bound,\r\n // O.W. date/time stamp of DLL bound to (Old BIND)\r\n end;\r\n {$EXTERNALSYM TImgDelayDescrV1}\r\n TImgDelayDescrV1 = ImgDelayDescrV1;\r\n {$EXTERNALSYM PImgDelayDescrV1}\r\n PImgDelayDescrV1 = ^ImgDelayDescrV1;\r\n\r\n //{$EXTERNALSYM PImgDelayDescr}\r\n //PImgDelayDescr = ImgDelayDescr;\r\n //TImgDelayDescr = ImgDelayDescr;\r\n\r\n// msidefs.h line 349\r\n\r\n// PIDs given specific meanings for Installer\r\n\r\nconst\r\n PID_MSIVERSION = $0000000E; // integer, Installer version number (major*100+minor)\r\n {$EXTERNALSYM PID_MSIVERSION}\r\n PID_MSISOURCE = $0000000F; // integer, type of file image, short/long, media/tree\r\n {$EXTERNALSYM PID_MSISOURCE}\r\n PID_MSIRESTRICT = $00000010; // integer, transform restrictions\r\n {$EXTERNALSYM PID_MSIRESTRICT}\r\n\r\n\r\n// shlguid.h line 404\r\n\r\nconst\r\n FMTID_ShellDetails: TGUID = '{28636aa6-953d-11d2-b5d6-00c04fd918d0}';\r\n {$EXTERNALSYM FMTID_ShellDetails}\r\n\r\n PID_FINDDATA = 0;\r\n {$EXTERNALSYM PID_FINDDATA}\r\n PID_NETRESOURCE = 1;\r\n {$EXTERNALSYM PID_NETRESOURCE}\r\n PID_DESCRIPTIONID = 2;\r\n {$EXTERNALSYM PID_DESCRIPTIONID}\r\n PID_WHICHFOLDER = 3;\r\n {$EXTERNALSYM PID_WHICHFOLDER}\r\n PID_NETWORKLOCATION = 4;\r\n {$EXTERNALSYM PID_NETWORKLOCATION}\r\n PID_COMPUTERNAME = 5;\r\n {$EXTERNALSYM PID_COMPUTERNAME}\r\n\r\n// PSGUID_STORAGE comes from ntquery.h\r\nconst\r\n FMTID_Storage: TGUID = '{b725f130-47ef-101a-a5f1-02608c9eebac}';\r\n {$EXTERNALSYM FMTID_Storage}\r\n\r\n// Image properties\r\nconst\r\n FMTID_ImageProperties: TGUID = '{14b81da1-0135-4d31-96d9-6cbfc9671a99}';\r\n {$EXTERNALSYM FMTID_ImageProperties}\r\n\r\n// The GUIDs used to identify shell item attributes (columns). See IShellFolder2::GetDetailsEx implementations...\r\n\r\nconst\r\n FMTID_Displaced: TGUID = '{9B174B33-40FF-11d2-A27E-00C04FC30871}';\r\n {$EXTERNALSYM FMTID_Displaced}\r\n PID_DISPLACED_FROM = 2;\r\n {$EXTERNALSYM PID_DISPLACED_FROM}\r\n PID_DISPLACED_DATE = 3;\r\n {$EXTERNALSYM PID_DISPLACED_DATE}\r\n\r\nconst\r\n FMTID_Briefcase: TGUID = '{328D8B21-7729-4bfc-954C-902B329D56B0}';\r\n {$EXTERNALSYM FMTID_Briefcase}\r\n PID_SYNC_COPY_IN = 2;\r\n {$EXTERNALSYM PID_SYNC_COPY_IN}\r\n\r\nconst\r\n FMTID_Misc: TGUID = '{9B174B34-40FF-11d2-A27E-00C04FC30871}';\r\n {$EXTERNALSYM FMTID_Misc}\r\n PID_MISC_STATUS = 2;\r\n {$EXTERNALSYM PID_MISC_STATUS}\r\n PID_MISC_ACCESSCOUNT = 3;\r\n {$EXTERNALSYM PID_MISC_ACCESSCOUNT}\r\n PID_MISC_OWNER = 4;\r\n {$EXTERNALSYM PID_MISC_OWNER}\r\n PID_HTMLINFOTIPFILE = 5;\r\n {$EXTERNALSYM PID_HTMLINFOTIPFILE}\r\n PID_MISC_PICS = 6;\r\n {$EXTERNALSYM PID_MISC_PICS}\r\n\r\nconst\r\n FMTID_WebView: TGUID = '{F2275480-F782-4291-BD94-F13693513AEC}';\r\n {$EXTERNALSYM FMTID_WebView}\r\n PID_DISPLAY_PROPERTIES = 0;\r\n {$EXTERNALSYM PID_DISPLAY_PROPERTIES}\r\n PID_INTROTEXT = 1;\r\n {$EXTERNALSYM PID_INTROTEXT}\r\n\r\nconst\r\n FMTID_MUSIC: TGUID = '{56A3372E-CE9C-11d2-9F0E-006097C686F6}';\r\n {$EXTERNALSYM FMTID_MUSIC}\r\n PIDSI_ARTIST = 2;\r\n {$EXTERNALSYM PIDSI_ARTIST}\r\n PIDSI_SONGTITLE = 3;\r\n {$EXTERNALSYM PIDSI_SONGTITLE}\r\n PIDSI_ALBUM = 4;\r\n {$EXTERNALSYM PIDSI_ALBUM}\r\n PIDSI_YEAR = 5;\r\n {$EXTERNALSYM PIDSI_YEAR}\r\n PIDSI_COMMENT = 6;\r\n {$EXTERNALSYM PIDSI_COMMENT}\r\n PIDSI_TRACK = 7;\r\n {$EXTERNALSYM PIDSI_TRACK}\r\n PIDSI_GENRE = 11;\r\n {$EXTERNALSYM PIDSI_GENRE}\r\n PIDSI_LYRICS = 12;\r\n {$EXTERNALSYM PIDSI_LYRICS}\r\n\r\nconst\r\n FMTID_DRM: TGUID = '{AEAC19E4-89AE-4508-B9B7-BB867ABEE2ED}';\r\n {$EXTERNALSYM FMTID_DRM}\r\n PIDDRSI_PROTECTED = 2;\r\n {$EXTERNALSYM PIDDRSI_PROTECTED}\r\n PIDDRSI_DESCRIPTION = 3;\r\n {$EXTERNALSYM PIDDRSI_DESCRIPTION}\r\n PIDDRSI_PLAYCOUNT = 4;\r\n {$EXTERNALSYM PIDDRSI_PLAYCOUNT}\r\n PIDDRSI_PLAYSTARTS = 5;\r\n {$EXTERNALSYM PIDDRSI_PLAYSTARTS}\r\n PIDDRSI_PLAYEXPIRES = 6;\r\n {$EXTERNALSYM PIDDRSI_PLAYEXPIRES}\r\n\r\n// FMTID_VideoSummaryInformation property identifiers\r\nconst\r\n FMTID_Video: TGUID = '{64440491-4c8b-11d1-8b70-080036b11a03}';\r\n {$EXTERNALSYM FMTID_Video}\r\n PIDVSI_STREAM_NAME = $00000002; // \"StreamName\", VT_LPWSTR\r\n {$EXTERNALSYM PIDVSI_STREAM_NAME}\r\n PIDVSI_FRAME_WIDTH = $00000003; // \"FrameWidth\", VT_UI4\r\n {$EXTERNALSYM PIDVSI_FRAME_WIDTH}\r\n PIDVSI_FRAME_HEIGHT = $00000004; // \"FrameHeight\", VT_UI4\r\n {$EXTERNALSYM PIDVSI_FRAME_HEIGHT}\r\n PIDVSI_TIMELENGTH = $00000007; // \"TimeLength\", VT_UI4, milliseconds\r\n {$EXTERNALSYM PIDVSI_TIMELENGTH}\r\n PIDVSI_FRAME_COUNT = $00000005; // \"FrameCount\". VT_UI4\r\n {$EXTERNALSYM PIDVSI_FRAME_COUNT}\r\n PIDVSI_FRAME_RATE = $00000006; // \"FrameRate\", VT_UI4, frames/millisecond\r\n {$EXTERNALSYM PIDVSI_FRAME_RATE}\r\n PIDVSI_DATA_RATE = $00000008; // \"DataRate\", VT_UI4, bytes/second\r\n {$EXTERNALSYM PIDVSI_DATA_RATE}\r\n PIDVSI_SAMPLE_SIZE = $00000009; // \"SampleSize\", VT_UI4\r\n {$EXTERNALSYM PIDVSI_SAMPLE_SIZE}\r\n PIDVSI_COMPRESSION = $0000000A; // \"Compression\", VT_LPWSTR\r\n {$EXTERNALSYM PIDVSI_COMPRESSION}\r\n PIDVSI_STREAM_NUMBER = $0000000B; // \"StreamNumber\", VT_UI2\r\n {$EXTERNALSYM PIDVSI_STREAM_NUMBER}\r\n\r\n// FMTID_AudioSummaryInformation property identifiers\r\nconst\r\n FMTID_Audio: TGUID = '{64440490-4c8b-11d1-8b70-080036b11a03}';\r\n {$EXTERNALSYM FMTID_Audio}\r\n PIDASI_FORMAT = $00000002; // VT_BSTR\r\n {$EXTERNALSYM PIDASI_FORMAT}\r\n PIDASI_TIMELENGTH = $00000003; // VT_UI4, milliseconds\r\n {$EXTERNALSYM PIDASI_TIMELENGTH}\r\n PIDASI_AVG_DATA_RATE = $00000004; // VT_UI4, Hz\r\n {$EXTERNALSYM PIDASI_AVG_DATA_RATE}\r\n PIDASI_SAMPLE_RATE = $00000005; // VT_UI4, bits\r\n {$EXTERNALSYM PIDASI_SAMPLE_RATE}\r\n PIDASI_SAMPLE_SIZE = $00000006; // VT_UI4, bits\r\n {$EXTERNALSYM PIDASI_SAMPLE_SIZE}\r\n PIDASI_CHANNEL_COUNT = $00000007; // VT_UI4\r\n {$EXTERNALSYM PIDASI_CHANNEL_COUNT}\r\n PIDASI_STREAM_NUMBER = $00000008; // VT_UI2\r\n {$EXTERNALSYM PIDASI_STREAM_NUMBER}\r\n PIDASI_STREAM_NAME = $00000009; // VT_LPWSTR\r\n {$EXTERNALSYM PIDASI_STREAM_NAME}\r\n PIDASI_COMPRESSION = $0000000A; // VT_LPWSTR\r\n {$EXTERNALSYM PIDASI_COMPRESSION}\r\n\r\nconst\r\n FMTID_ControlPanel: TGUID = '{305CA226-D286-468e-B848-2B2E8E697B74}';\r\n {$EXTERNALSYM FMTID_ControlPanel}\r\n PID_CONTROLPANEL_CATEGORY = 2;\r\n {$EXTERNALSYM PID_CONTROLPANEL_CATEGORY}\r\n\r\nconst\r\n FMTID_Volume: TGUID = '{9B174B35-40FF-11d2-A27E-00C04FC30871}';\r\n {$EXTERNALSYM FMTID_Volume}\r\n PID_VOLUME_FREE = 2;\r\n {$EXTERNALSYM PID_VOLUME_FREE}\r\n PID_VOLUME_CAPACITY = 3;\r\n {$EXTERNALSYM PID_VOLUME_CAPACITY}\r\n PID_VOLUME_FILESYSTEM = 4;\r\n {$EXTERNALSYM PID_VOLUME_FILESYSTEM}\r\n\r\nconst\r\n FMTID_Share: TGUID = '{D8C3986F-813B-449c-845D-87B95D674ADE}';\r\n {$EXTERNALSYM FMTID_Share}\r\n PID_SHARE_CSC_STATUS = 2;\r\n {$EXTERNALSYM PID_SHARE_CSC_STATUS}\r\n\r\nconst\r\n FMTID_Link: TGUID = '{B9B4B3FC-2B51-4a42-B5D8-324146AFCF25}';\r\n {$EXTERNALSYM FMTID_Link}\r\n PID_LINK_TARGET = 2;\r\n {$EXTERNALSYM PID_LINK_TARGET}\r\n\r\nconst\r\n FMTID_Query: TGUID = '{49691c90-7e17-101a-a91c-08002b2ecda9}';\r\n {$EXTERNALSYM FMTID_Query}\r\n PID_QUERY_RANK = 2;\r\n {$EXTERNALSYM PID_QUERY_RANK}\r\n\r\nconst\r\n FMTID_SummaryInformation: TGUID = '{f29f85e0-4ff9-1068-ab91-08002b27b3d9}';\r\n {$EXTERNALSYM FMTID_SummaryInformation}\r\n FMTID_DocumentSummaryInformation: TGUID = '{d5cdd502-2e9c-101b-9397-08002b2cf9ae}';\r\n {$EXTERNALSYM FMTID_DocumentSummaryInformation}\r\n FMTID_MediaFileSummaryInformation: TGUID = '{64440492-4c8b-11d1-8b70-080036b11a03}';\r\n {$EXTERNALSYM FMTID_MediaFileSummaryInformation}\r\n FMTID_ImageSummaryInformation: TGUID = '{6444048f-4c8b-11d1-8b70-080036b11a03}';\r\n {$EXTERNALSYM FMTID_ImageSummaryInformation}\r\n\r\n// imgguids.h line 75\r\n\r\n// Property sets\r\nconst\r\n FMTID_ImageInformation: TGUID = '{e5836cbe-5eef-4f1d-acde-ae4c43b608ce}';\r\n {$EXTERNALSYM FMTID_ImageInformation}\r\n FMTID_JpegAppHeaders: TGUID = '{1c4afdcd-6177-43cf-abc7-5f51af39ee85}';\r\n {$EXTERNALSYM FMTID_JpegAppHeaders}\r\n\r\n\r\n\r\n// objbase.h line 390\r\nconst\r\n STGFMT_STORAGE = 0;\r\n {$EXTERNALSYM STGFMT_STORAGE}\r\n STGFMT_NATIVE = 1;\r\n {$EXTERNALSYM STGFMT_NATIVE}\r\n STGFMT_FILE = 3;\r\n {$EXTERNALSYM STGFMT_FILE}\r\n STGFMT_ANY = 4;\r\n {$EXTERNALSYM STGFMT_ANY}\r\n STGFMT_DOCFILE = 5;\r\n {$EXTERNALSYM STGFMT_DOCFILE}\r\n// This is a legacy define to allow old component to builds\r\n STGFMT_DOCUMENT = 0;\r\n {$EXTERNALSYM STGFMT_DOCUMENT}\r\n\r\n// objbase.h line 913\r\n\r\ntype\r\n tagSTGOPTIONS = record\r\n usVersion: Word; // Versions 1 and 2 supported\r\n reserved: Word; // must be 0 for padding\r\n ulSectorSize: Cardinal; // docfile header sector size (512)\r\n pwcsTemplateFile: PWideChar; // version 2 or above\r\n end;\r\n {$EXTERNALSYM tagSTGOPTIONS}\r\n STGOPTIONS = tagSTGOPTIONS;\r\n {$EXTERNALSYM STGOPTIONS}\r\n PSTGOPTIONS = ^STGOPTIONS;\r\n {$EXTERNALSYM PSTGOPTIONS}\r\n\r\nfunction StgCreateStorageEx(const pwcsName: PWideChar; grfMode: DWORD;\r\n stgfmt: DWORD; grfAttrs: DWORD; pStgOptions: PSTGOPTIONS; reserved2: Pointer;\r\n riid: PGUID; out stgOpen: IInterface): HResult; stdcall;\r\n{$EXTERNALSYM StgCreateStorageEx}\r\n\r\nfunction StgOpenStorageEx(const pwcsName: PWideChar; grfMode: DWORD;\r\n stgfmt: DWORD; grfAttrs: DWORD; pStgOptions: PSTGOPTIONS; reserved2: Pointer;\r\n riid: PGUID; out stgOpen: IInterface): HResult; stdcall;\r\n{$EXTERNALSYM StgOpenStorageEx}\r\n\r\n\r\n// propidl.h line 386\r\n\r\n// Reserved global Property IDs\r\nconst\r\n PID_DICTIONARY = $00000000; // integer count + array of entries\r\n {$EXTERNALSYM PID_DICTIONARY}\r\n PID_CODEPAGE = $00000001; // short integer\r\n {$EXTERNALSYM PID_CODEPAGE}\r\n PID_FIRST_USABLE = $00000002;\r\n {$EXTERNALSYM PID_FIRST_USABLE}\r\n PID_FIRST_NAME_DEFAULT = $00000FFF;\r\n {$EXTERNALSYM PID_FIRST_NAME_DEFAULT}\r\n PID_LOCALE = $80000000;\r\n {$EXTERNALSYM PID_LOCALE}\r\n PID_MODIFY_TIME = $80000001;\r\n {$EXTERNALSYM PID_MODIFY_TIME}\r\n PID_SECURITY = $80000002;\r\n {$EXTERNALSYM PID_SECURITY}\r\n PID_BEHAVIOR = $80000003;\r\n {$EXTERNALSYM PID_BEHAVIOR}\r\n PID_ILLEGAL = $FFFFFFFF;\r\n {$EXTERNALSYM PID_ILLEGAL}\r\n\r\n// Range which is read-only to downlevel implementations\r\n\r\nconst\r\n PID_MIN_READONLY = $80000000;\r\n {$EXTERNALSYM PID_MIN_READONLY}\r\n PID_MAX_READONLY = $BFFFFFFF;\r\n {$EXTERNALSYM PID_MAX_READONLY}\r\n\r\n// Property IDs for the DiscardableInformation Property Set\r\n\r\nconst\r\n PIDDI_THUMBNAIL = $00000002; // VT_BLOB\r\n {$EXTERNALSYM PIDDI_THUMBNAIL}\r\n\r\n// Property IDs for the SummaryInformation Property Set\r\n\r\nconst\r\n PIDSI_TITLE = $00000002; // VT_LPSTR\r\n {$EXTERNALSYM PIDSI_TITLE}\r\n PIDSI_SUBJECT = $00000003; // VT_LPSTR\r\n {$EXTERNALSYM PIDSI_SUBJECT}\r\n PIDSI_AUTHOR = $00000004; // VT_LPSTR\r\n {$EXTERNALSYM PIDSI_AUTHOR}\r\n PIDSI_KEYWORDS = $00000005; // VT_LPSTR\r\n {$EXTERNALSYM PIDSI_KEYWORDS}\r\n PIDSI_COMMENTS = $00000006; // VT_LPSTR\r\n {$EXTERNALSYM PIDSI_COMMENTS}\r\n PIDSI_TEMPLATE = $00000007; // VT_LPSTR\r\n {$EXTERNALSYM PIDSI_TEMPLATE}\r\n PIDSI_LASTAUTHOR = $00000008; // VT_LPSTR\r\n {$EXTERNALSYM PIDSI_LASTAUTHOR}\r\n PIDSI_REVNUMBER = $00000009; // VT_LPSTR\r\n {$EXTERNALSYM PIDSI_REVNUMBER}\r\n PIDSI_EDITTIME = $0000000A; // VT_FILETIME (UTC)\r\n {$EXTERNALSYM PIDSI_EDITTIME}\r\n PIDSI_LASTPRINTED = $0000000B; // VT_FILETIME (UTC)\r\n {$EXTERNALSYM PIDSI_LASTPRINTED}\r\n PIDSI_CREATE_DTM = $0000000C; // VT_FILETIME (UTC)\r\n {$EXTERNALSYM PIDSI_CREATE_DTM}\r\n PIDSI_LASTSAVE_DTM = $0000000D; // VT_FILETIME (UTC)\r\n {$EXTERNALSYM PIDSI_LASTSAVE_DTM}\r\n PIDSI_PAGECOUNT = $0000000E; // VT_I4\r\n {$EXTERNALSYM PIDSI_PAGECOUNT}\r\n PIDSI_WORDCOUNT = $0000000F; // VT_I4\r\n {$EXTERNALSYM PIDSI_WORDCOUNT}\r\n PIDSI_CHARCOUNT = $00000010; // VT_I4\r\n {$EXTERNALSYM PIDSI_CHARCOUNT}\r\n PIDSI_THUMBNAIL = $00000011; // VT_CF\r\n {$EXTERNALSYM PIDSI_THUMBNAIL}\r\n PIDSI_APPNAME = $00000012; // VT_LPSTR\r\n {$EXTERNALSYM PIDSI_APPNAME}\r\n PIDSI_DOC_SECURITY = $00000013; // VT_I4\r\n {$EXTERNALSYM PIDSI_DOC_SECURITY}\r\n\r\n// Property IDs for the DocSummaryInformation Property Set\r\n\r\nconst\r\n PIDDSI_CATEGORY = $00000002; // VT_LPSTR\r\n {$EXTERNALSYM PIDDSI_CATEGORY}\r\n PIDDSI_PRESFORMAT = $00000003; // VT_LPSTR\r\n {$EXTERNALSYM PIDDSI_PRESFORMAT}\r\n PIDDSI_BYTECOUNT = $00000004; // VT_I4\r\n {$EXTERNALSYM PIDDSI_BYTECOUNT}\r\n PIDDSI_LINECOUNT = $00000005; // VT_I4\r\n {$EXTERNALSYM PIDDSI_LINECOUNT}\r\n PIDDSI_PARCOUNT = $00000006; // VT_I4\r\n {$EXTERNALSYM PIDDSI_PARCOUNT}\r\n PIDDSI_SLIDECOUNT = $00000007; // VT_I4\r\n {$EXTERNALSYM PIDDSI_SLIDECOUNT}\r\n PIDDSI_NOTECOUNT = $00000008; // VT_I4\r\n {$EXTERNALSYM PIDDSI_NOTECOUNT}\r\n PIDDSI_HIDDENCOUNT = $00000009; // VT_I4\r\n {$EXTERNALSYM PIDDSI_HIDDENCOUNT}\r\n PIDDSI_MMCLIPCOUNT = $0000000A; // VT_I4\r\n {$EXTERNALSYM PIDDSI_MMCLIPCOUNT}\r\n PIDDSI_SCALE = $0000000B; // VT_BOOL\r\n {$EXTERNALSYM PIDDSI_SCALE}\r\n PIDDSI_HEADINGPAIR = $0000000C; // VT_VARIANT | VT_VECTOR\r\n {$EXTERNALSYM PIDDSI_HEADINGPAIR}\r\n PIDDSI_DOCPARTS = $0000000D; // VT_LPSTR | VT_VECTOR\r\n {$EXTERNALSYM PIDDSI_DOCPARTS}\r\n PIDDSI_MANAGER = $0000000E; // VT_LPSTR\r\n {$EXTERNALSYM PIDDSI_MANAGER}\r\n PIDDSI_COMPANY = $0000000F; // VT_LPSTR\r\n {$EXTERNALSYM PIDDSI_COMPANY}\r\n PIDDSI_LINKSDIRTY = $00000010; // VT_BOOL\r\n {$EXTERNALSYM PIDDSI_LINKSDIRTY}\r\n\r\n// FMTID_MediaFileSummaryInfo - Property IDs\r\n\r\nconst\r\n PIDMSI_EDITOR = $00000002; // VT_LPWSTR\r\n {$EXTERNALSYM PIDMSI_EDITOR}\r\n PIDMSI_SUPPLIER = $00000003; // VT_LPWSTR\r\n {$EXTERNALSYM PIDMSI_SUPPLIER}\r\n PIDMSI_SOURCE = $00000004; // VT_LPWSTR\r\n {$EXTERNALSYM PIDMSI_SOURCE}\r\n PIDMSI_SEQUENCE_NO = $00000005; // VT_LPWSTR\r\n {$EXTERNALSYM PIDMSI_SEQUENCE_NO}\r\n PIDMSI_PROJECT = $00000006; // VT_LPWSTR\r\n {$EXTERNALSYM PIDMSI_PROJECT}\r\n PIDMSI_STATUS = $00000007; // VT_UI4\r\n {$EXTERNALSYM PIDMSI_STATUS}\r\n PIDMSI_OWNER = $00000008; // VT_LPWSTR\r\n {$EXTERNALSYM PIDMSI_OWNER}\r\n PIDMSI_RATING = $00000009; // VT_LPWSTR\r\n {$EXTERNALSYM PIDMSI_RATING}\r\n PIDMSI_PRODUCTION = $0000000A; // VT_FILETIME (UTC)\r\n {$EXTERNALSYM PIDMSI_PRODUCTION}\r\n PIDMSI_COPYRIGHT = $0000000B; // VT_LPWSTR\r\n {$EXTERNALSYM PIDMSI_COPYRIGHT}\r\n\r\nfunction PropVariantClear(var Prop: TPropVariant): HResult; stdcall;\r\n{$EXTERNALSYM PropVariantClear}\r\n\r\n\r\n// NtSecApi.h line 566\r\ntype\r\n PLSA_UNICODE_STRING = ^LSA_UNICODE_STRING;\r\n _LSA_UNICODE_STRING = record\r\n Length: USHORT;\r\n MaximumLength: USHORT;\r\n Buffer: {$IFDEF HAS_UNITSCOPE}Winapi.{$ENDIF}Windows.LPWSTR;\r\n end;\r\n LSA_UNICODE_STRING = _LSA_UNICODE_STRING;\r\n TLsaUnicodeString = LSA_UNICODE_STRING;\r\n PLsaUnicodeString = PLSA_UNICODE_STRING;\r\n\r\n PLSA_STRING = ^LSA_STRING;\r\n _LSA_STRING = record\r\n Length: USHORT;\r\n MaximumLength: USHORT;\r\n Buffer: PANSICHAR;\r\n end;\r\n LSA_STRING = _LSA_STRING;\r\n TLsaString = LSA_STRING;\r\n PLsaString = PLSA_STRING;\r\n\r\n PLSA_OBJECT_ATTRIBUTES = ^LSA_OBJECT_ATTRIBUTES;\r\n _LSA_OBJECT_ATTRIBUTES = record\r\n Length: ULONG;\r\n RootDirectory: {$IFDEF HAS_UNITSCOPE}Winapi.{$ENDIF}Windows.THandle;\r\n ObjectName: PLSA_UNICODE_STRING;\r\n Attributes: ULONG;\r\n SecurityDescriptor: Pointer; // Points to type SECURITY_DESCRIPTOR\r\n SecurityQualityOfService: Pointer; // Points to type SECURITY_QUALITY_OF_SERVICE\r\n end;\r\n LSA_OBJECT_ATTRIBUTES = _LSA_OBJECT_ATTRIBUTES;\r\n TLsaObjectAttributes = _LSA_OBJECT_ATTRIBUTES;\r\n PLsaObjectAttributes = PLSA_OBJECT_ATTRIBUTES;\r\n\r\n// NtSecApi.h line 680\r\n\r\n////////////////////////////////////////////////////////////////////////////\r\n// //\r\n// Local Security Policy Administration API datatypes and defines //\r\n// //\r\n////////////////////////////////////////////////////////////////////////////\r\n\r\n//\r\n// Access types for the Policy object\r\n//\r\n\r\nconst\r\n POLICY_VIEW_LOCAL_INFORMATION = $00000001;\r\n {$EXTERNALSYM POLICY_VIEW_LOCAL_INFORMATION}\r\n POLICY_VIEW_AUDIT_INFORMATION = $00000002;\r\n {$EXTERNALSYM POLICY_VIEW_AUDIT_INFORMATION}\r\n POLICY_GET_PRIVATE_INFORMATION = $00000004;\r\n {$EXTERNALSYM POLICY_GET_PRIVATE_INFORMATION}\r\n POLICY_TRUST_ADMIN = $00000008;\r\n {$EXTERNALSYM POLICY_TRUST_ADMIN}\r\n POLICY_CREATE_ACCOUNT = $00000010;\r\n {$EXTERNALSYM POLICY_CREATE_ACCOUNT}\r\n POLICY_CREATE_SECRET = $00000020;\r\n {$EXTERNALSYM POLICY_CREATE_SECRET}\r\n POLICY_CREATE_PRIVILEGE = $00000040;\r\n {$EXTERNALSYM POLICY_CREATE_PRIVILEGE}\r\n POLICY_SET_DEFAULT_QUOTA_LIMITS = $00000080;\r\n {$EXTERNALSYM POLICY_SET_DEFAULT_QUOTA_LIMITS}\r\n POLICY_SET_AUDIT_REQUIREMENTS = $00000100;\r\n {$EXTERNALSYM POLICY_SET_AUDIT_REQUIREMENTS}\r\n POLICY_AUDIT_LOG_ADMIN = $00000200;\r\n {$EXTERNALSYM POLICY_AUDIT_LOG_ADMIN}\r\n POLICY_SERVER_ADMIN = $00000400;\r\n {$EXTERNALSYM POLICY_SERVER_ADMIN}\r\n POLICY_LOOKUP_NAMES = $00000800;\r\n {$EXTERNALSYM POLICY_LOOKUP_NAMES}\r\n POLICY_NOTIFICATION = $00001000;\r\n {$EXTERNALSYM POLICY_NOTIFICATION}\r\n\r\n POLICY_ALL_ACCESS = (STANDARD_RIGHTS_REQUIRED or\r\n POLICY_VIEW_LOCAL_INFORMATION or\r\n POLICY_VIEW_AUDIT_INFORMATION or\r\n POLICY_GET_PRIVATE_INFORMATION or\r\n POLICY_TRUST_ADMIN or\r\n POLICY_CREATE_ACCOUNT or\r\n POLICY_CREATE_SECRET or\r\n POLICY_CREATE_PRIVILEGE or\r\n POLICY_SET_DEFAULT_QUOTA_LIMITS or\r\n POLICY_SET_AUDIT_REQUIREMENTS or\r\n POLICY_AUDIT_LOG_ADMIN or\r\n POLICY_SERVER_ADMIN or\r\n POLICY_LOOKUP_NAMES);\r\n {$EXTERNALSYM POLICY_ALL_ACCESS}\r\n\r\n POLICY_READ = (STANDARD_RIGHTS_READ or\r\n POLICY_VIEW_AUDIT_INFORMATION or\r\n POLICY_GET_PRIVATE_INFORMATION);\r\n {$EXTERNALSYM POLICY_READ}\r\n\r\n POLICY_WRITE = (STANDARD_RIGHTS_WRITE or\r\n POLICY_TRUST_ADMIN or\r\n POLICY_CREATE_ACCOUNT or\r\n POLICY_CREATE_SECRET or\r\n POLICY_CREATE_PRIVILEGE or\r\n POLICY_SET_DEFAULT_QUOTA_LIMITS or\r\n POLICY_SET_AUDIT_REQUIREMENTS or\r\n POLICY_AUDIT_LOG_ADMIN or\r\n POLICY_SERVER_ADMIN);\r\n {$EXTERNALSYM POLICY_WRITE}\r\n\r\n POLICY_EXECUTE = (STANDARD_RIGHTS_EXECUTE or\r\n POLICY_VIEW_LOCAL_INFORMATION or\r\n POLICY_LOOKUP_NAMES);\r\n {$EXTERNALSYM POLICY_EXECUTE}\r\n\r\n// NtSecApi.h line 914\r\ntype\r\n _POLICY_INFORMATION_CLASS = (\r\n picFill0,\r\n PolicyAuditLogInformation,\r\n PolicyAuditEventsInformation,\r\n PolicyPrimaryDomainInformation,\r\n PolicyPdAccountInformation,\r\n PolicyAccountDomainInformation,\r\n PolicyLsaServerRoleInformation,\r\n PolicyReplicaSourceInformation,\r\n PolicyDefaultQuotaInformation,\r\n PolicyModificationInformation,\r\n PolicyAuditFullSetInformation,\r\n PolicyAuditFullQueryInformation,\r\n PolicyDnsDomainInformation,\r\n PolicyDnsDomainInformationInt);\r\n {$EXTERNALSYM _POLICY_INFORMATION_CLASS}\r\n POLICY_INFORMATION_CLASS = _POLICY_INFORMATION_CLASS;\r\n {$EXTERNALSYM POLICY_INFORMATION_CLASS}\r\n PPOLICY_INFORMATION_CLASS = ^POLICY_INFORMATION_CLASS;\r\n {$EXTERNALSYM PPOLICY_INFORMATION_CLASS}\r\n TPolicyInformationClass = POLICY_INFORMATION_CLASS;\r\n {$EXTERNALSYM TPolicyInformationClass}\r\n PPolicyInformationClass = PPOLICY_INFORMATION_CLASS;\r\n {$EXTERNALSYM PPolicyInformationClass}\r\n\r\n// NtSecApi.h line 1031\r\n//\r\n// The following structure corresponds to the PolicyAccountDomainInformation\r\n// information class.\r\n//\r\ntype\r\n PPOLICY_ACCOUNT_DOMAIN_INFO = ^POLICY_ACCOUNT_DOMAIN_INFO;\r\n _POLICY_ACCOUNT_DOMAIN_INFO = record\r\n DomainName: LSA_UNICODE_STRING;\r\n DomainSid: {$IFDEF HAS_UNITSCOPE}Winapi.{$ENDIF}Windows.PSID;\r\n end;\r\n POLICY_ACCOUNT_DOMAIN_INFO = _POLICY_ACCOUNT_DOMAIN_INFO;\r\n TPolicyAccountDomainInfo = POLICY_ACCOUNT_DOMAIN_INFO;\r\n PPolicyAccountDomainInfo = PPOLICY_ACCOUNT_DOMAIN_INFO;\r\n\r\n// NtSecApi.h line 1298\r\ntype\r\n LSA_HANDLE = Pointer;\r\n PLSA_HANDLE = ^LSA_HANDLE;\r\n TLsaHandle = LSA_HANDLE;\r\n\r\n// NtSecApi.h line 1714\r\ntype\r\n NTSTATUS = DWORD;\r\n\r\nfunction LsaOpenPolicy(SystemName: PLSA_UNICODE_STRING;\r\n var ObjectAttributes: LSA_OBJECT_ATTRIBUTES; DesiredAccess: ACCESS_MASK;\r\n var PolicyHandle: LSA_HANDLE): NTSTATUS; stdcall;\r\nfunction LsaQueryInformationPolicy(PolicyHandle: LSA_HANDLE;\r\n InformationClass: POLICY_INFORMATION_CLASS; var Buffer: Pointer): NTSTATUS; stdcall;\r\nfunction LsaFreeMemory(Buffer: Pointer): NTSTATUS; stdcall;\r\nfunction LsaFreeReturnBuffer(Buffer: Pointer): NTSTATUS; stdcall;\r\nfunction LsaClose(ObjectHandle: LSA_HANDLE): NTSTATUS; stdcall;\r\nfunction LsaNtStatusToWinError(Status: NTSTATUS): ULONG; stdcall;\r\n\r\n\r\n// Snapshot function\r\n\r\nfunction CreateToolhelp32Snapshot(dwFlags, th32ProcessID: DWORD): THandle; stdcall;\r\n{$EXTERNALSYM CreateToolhelp32Snapshot}\r\n\r\n//\r\n// The th32ProcessID argument is only used if TH32CS_SNAPHEAPLIST or\r\n// TH32CS_SNAPMODULE is specified. th32ProcessID == 0 means the current\r\n// process.\r\n//\r\n// NOTE that all of the snapshots are global except for the heap and module\r\n// lists which are process specific. To enumerate the heap or module\r\n// state for all WIN32 processes call with TH32CS_SNAPALL and the\r\n// current process. Then for each process in the TH32CS_SNAPPROCESS\r\n// list that isn't the current process, do a call with just\r\n// TH32CS_SNAPHEAPLIST and/or TH32CS_SNAPMODULE.\r\n//\r\n// dwFlags\r\n//\r\n\r\nconst\r\n TH32CS_SNAPHEAPLIST = $00000001;\r\n {$EXTERNALSYM TH32CS_SNAPHEAPLIST}\r\n TH32CS_SNAPPROCESS = $00000002;\r\n {$EXTERNALSYM TH32CS_SNAPPROCESS}\r\n TH32CS_SNAPTHREAD = $00000004;\r\n {$EXTERNALSYM TH32CS_SNAPTHREAD}\r\n TH32CS_SNAPMODULE = $00000008;\r\n {$EXTERNALSYM TH32CS_SNAPMODULE}\r\n TH32CS_SNAPMODULE32 = $00000010;\r\n {$EXTERNALSYM TH32CS_SNAPMODULE32}\r\n TH32CS_SNAPALL = TH32CS_SNAPHEAPLIST or TH32CS_SNAPPROCESS or\r\n TH32CS_SNAPTHREAD or TH32CS_SNAPMODULE;\r\n {$EXTERNALSYM TH32CS_SNAPALL}\r\n TH32CS_INHERIT = $80000000;\r\n {$EXTERNALSYM TH32CS_INHERIT}\r\n\r\n//\r\n// Use CloseHandle to destroy the snapshot\r\n//\r\n\r\n// Thread walking\r\n\r\ntype\r\n PTHREADENTRY32 = ^THREADENTRY32;\r\n {$EXTERNALSYM PTHREADENTRY32}\r\n tagTHREADENTRY32 = record\r\n dwSize: DWORD;\r\n cntUsage: DWORD;\r\n th32ThreadID: DWORD; // this thread\r\n th32OwnerProcessID: DWORD; // Process this thread is associated with\r\n tpBasePri: Longint;\r\n tpDeltaPri: Longint;\r\n dwFlags: DWORD;\r\n end;\r\n {$EXTERNALSYM tagTHREADENTRY32}\r\n THREADENTRY32 = tagTHREADENTRY32;\r\n {$EXTERNALSYM THREADENTRY32}\r\n LPTHREADENTRY32 = ^THREADENTRY32;\r\n {$EXTERNALSYM LPTHREADENTRY32}\r\n TThreadEntry32 = THREADENTRY32;\r\n {$EXTERNALSYM TThreadEntry32}\r\n\r\nfunction Thread32First(hSnapshot: THandle; var lpte: THREADENTRY32): BOOL; stdcall;\r\n{$EXTERNALSYM Thread32First}\r\nfunction Thread32Next(hSnapshot: THandle; var lpte: THREADENTRY32): BOOL; stdcall;\r\n{$EXTERNALSYM Thread32Next}\r\n\r\n\r\n\r\ntype\r\n _THREAD_INFORMATION_CLASS = type Cardinal;\r\n {$EXTERNALSYM _THREAD_INFORMATION_CLASS}\r\n THREAD_INFORMATION_CLASS = _THREAD_INFORMATION_CLASS;\r\n {$EXTERNALSYM THREAD_INFORMATION_CLASS}\r\n PTHREAD_INFORMATION_CLASS = ^_THREAD_INFORMATION_CLASS;\r\n {$EXTERNALSYM PTHREAD_INFORMATION_CLASS}\r\n\r\nconst\r\n ThreadBasicInformation = 0;\r\n {$EXTERNALSYM ThreadBasicInformation}\r\n ThreadTimes = 1;\r\n {$EXTERNALSYM ThreadTimes}\r\n ThreadPriority = 2;\r\n {$EXTERNALSYM ThreadPriority}\r\n ThreadBasePriority = 3;\r\n {$EXTERNALSYM ThreadBasePriority}\r\n ThreadAffinityMask = 4;\r\n {$EXTERNALSYM ThreadAffinityMask}\r\n ThreadImpersonationToken = 5;\r\n {$EXTERNALSYM ThreadImpersonationToken}\r\n ThreadDescriptorTableEntry = 6;\r\n {$EXTERNALSYM ThreadDescriptorTableEntry}\r\n ThreadEnableAlignmentFaultFixup = 7;\r\n {$EXTERNALSYM ThreadEnableAlignmentFaultFixup}\r\n ThreadEventPair = 8;\r\n {$EXTERNALSYM ThreadEventPair}\r\n ThreadQuerySetWin32StartAddress = 9;\r\n {$EXTERNALSYM ThreadQuerySetWin32StartAddress}\r\n ThreadZeroTlsCell = 10;\r\n {$EXTERNALSYM ThreadZeroTlsCell}\r\n ThreadPerformanceCount = 11;\r\n {$EXTERNALSYM ThreadPerformanceCount}\r\n ThreadAmILastThread = 12;\r\n {$EXTERNALSYM ThreadAmILastThread}\r\n ThreadIdealProcessor = 13;\r\n {$EXTERNALSYM ThreadIdealProcessor}\r\n ThreadPriorityBoost = 14;\r\n {$EXTERNALSYM ThreadPriorityBoost}\r\n ThreadSetTlsArrayAddress = 15;\r\n {$EXTERNALSYM ThreadSetTlsArrayAddress}\r\n ThreadIsIoPending = 16;\r\n {$EXTERNALSYM ThreadIsIoPending}\r\n ThreadHideFromDebugger = 17;\r\n {$EXTERNALSYM ThreadHideFromDebugger}\r\n\r\ntype\r\n _CLIENT_ID = record\r\n UniqueProcess: THandle;\r\n UniqueThread: THandle;\r\n end;\r\n {$EXTERNALSYM _CLIENT_ID}\r\n CLIENT_ID = _CLIENT_ID;\r\n {$EXTERNALSYM CLIENT_ID}\r\n PCLIENT_ID = ^CLIENT_ID;\r\n {$EXTERNALSYM PCLIENT_ID}\r\n\r\n KAFFINITY = ULONG;\r\n {$EXTERNALSYM KAFFINITY}\r\n\r\n KPRIORITY = LongInt;\r\n {$EXTERNALSYM KPRIORITY}\r\n\r\n _THREAD_BASIC_INFORMATION = record\r\n ExitStatus: NTSTATUS;\r\n TebBaseAddress: Pointer;\r\n ClientId: CLIENT_ID;\r\n AffinityMask: KAFFINITY;\r\n Priority: KPRIORITY;\r\n BasePriority: KPRIORITY;\r\n end;\r\n {$EXTERNALSYM _THREAD_BASIC_INFORMATION}\r\n THREAD_BASIC_INFORMATION = _THREAD_BASIC_INFORMATION;\r\n {$EXTERNALSYM THREAD_BASIC_INFORMATION}\r\n PTHREAD_BASIC_INFORMATION = ^_THREAD_BASIC_INFORMATION;\r\n {$EXTERNALSYM PTHREAD_BASIC_INFORMATION}\r\n\r\nfunction NtQueryInformationThread(ThreadHandle: THandle; ThreadInformationClass: THREAD_INFORMATION_CLASS;\r\n ThreadInformation: Pointer; ThreadInformationLength: ULONG; ReturnLength: PULONG): NTSTATUS; stdcall;\r\n{$EXTERNALSYM NtQueryInformationThread}\r\n\r\n\r\n\r\n//DOM-IGNORE-END\r\n\r\n\r\nconst\r\n RtdlSetNamedSecurityInfoW: function(pObjectName: LPWSTR; ObjectType: SE_OBJECT_TYPE;\r\n SecurityInfo: SECURITY_INFORMATION; psidOwner, psidGroup: PSID;\r\n pDacl, pSacl: PACL): DWORD stdcall = SetNamedSecurityInfoW;\r\n\r\n RtdlSetWaitableTimer: function(hTimer: THandle; var lpDueTime: TLargeInteger;\r\n lPeriod: Longint; pfnCompletionRoutine: TFNTimerAPCRoutine;\r\n lpArgToCompletionRoutine: Pointer; fResume: BOOL): BOOL stdcall = SetWaitableTimer;\r\n\r\n RtdlNetUserAdd: function(servername: LPCWSTR; level: DWORD;\r\n buf: PByte; parm_err: PDWord): NET_API_STATUS stdcall = NetUserAdd;\r\n\r\n RtdlNetUserDel: function(servername: LPCWSTR;\r\n username: LPCWSTR): NET_API_STATUS stdcall = NetUserDel;\r\n\r\n RtdlNetGroupAdd: function(servername: LPCWSTR; level: DWORD; buf: PByte;\r\n parm_err: PDWord): NET_API_STATUS stdcall = NetGroupAdd;\r\n\r\n RtdlNetGroupEnum: function(servername: LPCWSTR; level: DWORD;\r\n out bufptr: PByte; prefmaxlen: DWORD; out entriesread, totalentries: DWORD;\r\n resume_handle: PDWORD_PTR): NET_API_STATUS stdcall = NetGroupEnum;\r\n\r\n RtdlNetGroupDel: function(servername: LPCWSTR;\r\n groupname: LPCWSTR): NET_API_STATUS stdcall = NetGroupDel;\r\n\r\n RtdlNetLocalGroupAdd: function(servername: LPCWSTR; level: DWORD;\r\n buf: PByte; parm_err: PDWord): NET_API_STATUS stdcall = NetLocalGroupAdd;\r\n\r\n RtdlNetLocalGroupEnum: function(servername: LPCWSTR; level: DWORD;\r\n out bufptr: PByte; prefmaxlen: DWORD; out entriesread, totalentries: DWORD;\r\n resumehandle: PDWORD_PTR): NET_API_STATUS stdcall = NetLocalGroupEnum;\r\n\r\n RtdlNetLocalGroupDel: function(servername: LPCWSTR;\r\n groupname: LPCWSTR): NET_API_STATUS stdcall = NetLocalGroupDel;\r\n\r\n RtdlNetLocalGroupAddMembers: function(servername: LPCWSTR; groupname: LPCWSTR;\r\n level: DWORD; buf: PByte;\r\n totalentries: DWORD): NET_API_STATUS stdcall = NetLocalGroupAddMembers;\r\n\r\n RtdlNetApiBufferFree: function(Buffer: Pointer): NET_API_STATUS stdcall = NetApiBufferFree;\r\n\r\n RtdlGetCalendarInfoA: function(Locale: LCID; Calendar: CALID; CalType: CALTYPE;\r\n lpCalData: PAnsiChar; cchData: Integer;\r\n lpValue: PDWORD): Integer stdcall = GetCalendarInfoA;\r\n\r\n RtdlGetCalendarInfoW: function(Locale: LCID; Calendar: CALID; CalType: CALTYPE;\r\n lpCalData: PWideChar; cchData: Integer;\r\n lpValue: PDWORD): Integer stdcall = GetCalendarInfoW;\r\n\r\n RtdlEnumCalendarInfoExW: function(lpCalInfoEnumProc: TCalInfoEnumProcExW;\r\n Locale: LCID; Calendar: CALID; CalType: CALTYPE): BOOL stdcall = EnumCalendarInfoExW;\r\n\r\n RtdlGetVolumeNameForVolumeMountPointW: function(lpszVolumeMountPoint: LPCWSTR;\r\n lpszVolumeName: LPWSTR; cchBufferLength: DWORD): BOOL stdcall = GetVolumeNameForVolumeMountPointW;\r\n\r\n RtdlSetVolumeMountPointW: function(lpszVolumeMountPoint: LPCWSTR;\r\n lpszVolumeName: LPCWSTR): BOOL stdcall = SetVolumeMountPointW;\r\n\r\n RtdlDeleteVolumeMountPointW: function(lpszVolumeMountPoint: LPCWSTR): BOOL\r\n stdcall = DeleteVolumeMountPointW;\r\n\r\n RtdlNetBios: function(P: PNCB): UCHAR stdcall = NetBios;\r\n\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jcl.svn.sourceforge.net/svnroot/jcl/tags/JCL-2.4-Build4571/jcl/source/windows/JclWin32.pas $';\r\n Revision: '$Revision: 3796 $';\r\n Date: '$Date: 2012-05-23 15:57:30 +0200 (mer. 23 mai 2012) $';\r\n LogPath: 'JCL\\source\\windows'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n JclResources;\r\n\r\nprocedure GetProcedureAddress(var P: Pointer; const ModuleName, ProcName: string);\r\nvar\r\n ModuleHandle: HMODULE;\r\nbegin\r\n if not Assigned(P) then\r\n begin\r\n ModuleHandle := GetModuleHandle(PChar(ModuleName));\r\n if ModuleHandle = 0 then\r\n begin\r\n ModuleHandle := SafeLoadLibrary(PChar(ModuleName));\r\n if ModuleHandle = 0 then\r\n raise EJclError.CreateResFmt(@RsELibraryNotFound, [ModuleName]);\r\n end;\r\n P := GetProcAddress(ModuleHandle, PChar(ProcName));\r\n if not Assigned(P) then\r\n raise EJclError.CreateResFmt(@RsEFunctionNotFound, [ModuleName, ProcName]);\r\n end;\r\nend;\r\n\r\n//== { EJclWin32Error } ======================================================\r\n\r\n\r\nconstructor EJclWin32Error.Create(const Msg: string);\r\nbegin\r\n FLastError := GetLastError;\r\n FLastErrorMsg := SysErrorMessage(FLastError);\r\n inherited CreateResFmt(@RsWin32Error, [FLastErrorMsg, FLastError, NativeLineBreak, Msg]);\r\nend;\r\n\r\nconstructor EJclWin32Error.CreateFmt(const Msg: string; const Args: array of const);\r\nbegin\r\n FLastError := GetLastError;\r\n FLastErrorMsg := SysErrorMessage(FLastError);\r\n inherited CreateResFmt(@RsWin32Error, [FLastErrorMsg, FLastError, NativeLineBreak, Format(Msg, Args)]);\r\nend;\r\n\r\nconstructor EJclWin32Error.CreateRes(Ident: Integer);\r\nbegin\r\n FLastError := GetLastError;\r\n FLastErrorMsg := SysErrorMessage(FLastError);\r\n inherited CreateResFmt(@RsWin32Error, [FLastErrorMsg, FLastError, NativeLineBreak, LoadStr(Ident)]);\r\nend;\r\n\r\nconstructor EJclWin32Error.CreateRes(ResStringRec: PResStringRec);\r\nbegin\r\n FLastError := GetLastError;\r\n FLastErrorMsg := SysErrorMessage(FLastError);\r\n inherited CreateResFmt(@RsWin32Error, [FLastErrorMsg, FLastError, NativeLineBreak, LoadResString(ResStringRec)]);\r\nend;\r\n\r\n\r\n\r\nconst\r\n aclapilib = 'advapi32.dll';\r\n\r\ntype\r\n TSetNamedSecurityInfoW = function (pObjectName: LPWSTR; ObjectType: SE_OBJECT_TYPE;\r\n SecurityInfo: SECURITY_INFORMATION; psidOwner, psidGroup: PSID;\r\n pDacl, pSacl: PACL): DWORD; stdcall;\r\n\r\nvar\r\n _SetNamedSecurityInfoW: TSetNamedSecurityInfoW = nil;\r\n\r\nfunction SetNamedSecurityInfoW(pObjectName: LPWSTR; ObjectType: SE_OBJECT_TYPE;\r\n SecurityInfo: SECURITY_INFORMATION; psidOwner, psidGroup: PSID;\r\n pDacl, pSacl: PACL): DWORD;\r\nbegin\r\n GetProcedureAddress(Pointer(@_SetNamedSecurityInfoW), aclapilib, 'SetNamedSecurityInfoW');\r\n Result := _SetNamedSecurityInfoW(pObjectName, ObjectType, SecurityInfo, psidOwner, psidGroup, pDacl, pSacl);\r\nend;\r\n\r\n\r\n\r\nconst\r\n ImageHlpLib = 'imagehlp.dll';\r\n\r\ntype\r\n TReBaseImage = function (CurrentImageName: PAnsiChar; SymbolPath: PAnsiChar; fReBase: BOOL;\r\n fRebaseSysfileOk: BOOL; fGoingDown: BOOL; CheckImageSize: ULONG;\r\n var OldImageSize: TJclAddr32; var OldImageBase: TJclAddr;\r\n var NewImageSize: TJclAddr32; var NewImageBase: TJclAddr; TimeStamp: ULONG): BOOL; stdcall;\r\n\r\nvar\r\n _ReBaseImage: TReBaseImage = nil;\r\n\r\nfunction ReBaseImage(CurrentImageName: PAnsiChar; SymbolPath: PAnsiChar; fReBase: BOOL;\r\n fRebaseSysfileOk: BOOL; fGoingDown: BOOL; CheckImageSize: ULONG;\r\n var OldImageSize: TJclAddr32; var OldImageBase: TJclAddr;\r\n var NewImageSize: TJclAddr32; var NewImageBase: TJclAddr; TimeStamp: ULONG): BOOL;\r\nbegin\r\n GetProcedureAddress(Pointer(@_ReBaseImage), ImageHlpLib, 'ReBaseImage');\r\n Result := _ReBaseImage(CurrentImageName, SymbolPath, fReBase, fRebaseSysfileOk, fGoingDown, CheckImageSize, OldImageSize, OldImageBase, NewImageSize, NewImageBase, TimeStamp);\r\nend;\r\n\r\ntype\r\n TReBaseImage64 = function (CurrentImageName: PAnsiChar; SymbolPath: PAnsiChar; fReBase: BOOL;\r\n fRebaseSysfileOk: BOOL; fGoingDown: BOOL; CheckImageSize: ULONG;\r\n var OldImageSize: TJclAddr32; var OldImageBase: TJclAddr64;\r\n var NewImageSize: TJclAddr32; var NewImageBase: TJclAddr64; TimeStamp: ULONG): BOOL; stdcall;\r\n\r\nvar\r\n _ReBaseImage64: TReBaseImage64 = nil;\r\n\r\nfunction ReBaseImage64(CurrentImageName: PAnsiChar; SymbolPath: PAnsiChar; fReBase: BOOL;\r\n fRebaseSysfileOk: BOOL; fGoingDown: BOOL; CheckImageSize: ULONG;\r\n var OldImageSize: TJclAddr32; var OldImageBase: TJclAddr64;\r\n var NewImageSize: TJclAddr32; var NewImageBase: TJclAddr64; TimeStamp: ULONG): BOOL;\r\nbegin\r\n GetProcedureAddress(Pointer(@_ReBaseImage64), ImageHlpLib, 'ReBaseImage64');\r\n Result := _ReBaseImage64(CurrentImageName, SymbolPath, fReBase, fRebaseSysfileOk, fGoingDown, CheckImageSize, OldImageSize, OldImageBase, NewImageSize, NewImageBase, TimeStamp);\r\nend;\r\n\r\ntype\r\n TCheckSumMappedFile = function (BaseAddress: Pointer; FileLength: DWORD;\r\n out HeaderSum, CheckSum: DWORD): PImageNtHeaders; stdcall;\r\n\r\nvar\r\n _CheckSumMappedFile: TCheckSumMappedFile = nil;\r\n\r\nfunction CheckSumMappedFile(BaseAddress: Pointer; FileLength: DWORD;\r\n out HeaderSum, CheckSum: DWORD): PImageNtHeaders;\r\nbegin\r\n GetProcedureAddress(Pointer(@_CheckSumMappedFile), ImageHlpLib, 'CheckSumMappedFile');\r\n Result := _CheckSumMappedFile(BaseAddress, FileLength, HeaderSum, CheckSum);\r\nend;\r\n\r\ntype\r\n TGetImageUnusedHeaderBytes = function (const LoadedImage: LOADED_IMAGE;\r\n var SizeUnusedHeaderBytes: DWORD): DWORD; stdcall;\r\n\r\nvar\r\n _GetImageUnusedHeaderBytes: TGetImageUnusedHeaderBytes = nil;\r\n\r\nfunction GetImageUnusedHeaderBytes(const LoadedImage: LOADED_IMAGE;\r\n var SizeUnusedHeaderBytes: DWORD): DWORD;\r\nbegin\r\n GetProcedureAddress(Pointer(@_GetImageUnusedHeaderBytes), ImageHlpLib, 'GetImageUnusedHeaderBytes');\r\n Result := _GetImageUnusedHeaderBytes(LoadedImage, SizeUnusedHeaderBytes);\r\nend;\r\n\r\ntype\r\n TMapAndLoad = function (ImageName, DllPath: PAnsiChar; var LoadedImage: LOADED_IMAGE;\r\n DotDll: BOOL; ReadOnly: BOOL): BOOL; stdcall;\r\n\r\nvar\r\n _MapAndLoad: TMapAndLoad = nil;\r\n\r\nfunction MapAndLoad(ImageName, DllPath: PAnsiChar; var LoadedImage: LOADED_IMAGE;\r\n DotDll: BOOL; ReadOnly: BOOL): BOOL;\r\nbegin\r\n GetProcedureAddress(Pointer(@_MapAndLoad), ImageHlpLib, 'MapAndLoad');\r\n Result := _MapAndLoad(ImageName, DllPath, LoadedImage, DotDll, ReadOnly);\r\nend;\r\n\r\ntype\r\n TUnMapAndLoad = function (const LoadedImage: LOADED_IMAGE): BOOL; stdcall;\r\n\r\nvar\r\n _UnMapAndLoad: TUnMapAndLoad = nil;\r\n\r\nfunction UnMapAndLoad(const LoadedImage: LOADED_IMAGE): BOOL;\r\nbegin\r\n GetProcedureAddress(Pointer(@_UnMapAndLoad), ImageHlpLib, 'UnMapAndLoad');\r\n Result := _UnMapAndLoad(LoadedImage);\r\nend;\r\n\r\ntype\r\n TTouchFileTimes = function (const FileHandle: THandle; const pSystemTime: TSystemTime): BOOL; stdcall;\r\n\r\nvar\r\n _TouchFileTimes: TTouchFileTimes = nil;\r\n\r\nfunction TouchFileTimes(const FileHandle: THandle; const pSystemTime: TSystemTime): BOOL;\r\nbegin\r\n GetProcedureAddress(Pointer(@_TouchFileTimes), ImageHlpLib, 'TouchFileTimes');\r\n Result := _TouchFileTimes(FileHandle, pSystemTime);\r\nend;\r\n\r\ntype\r\n TImageDirectoryEntryToData = function (Base: Pointer; MappedAsImage: ByteBool;\r\n DirectoryEntry: USHORT; var Size: ULONG): Pointer; stdcall;\r\n\r\nvar\r\n _ImageDirectoryEntryToData: TImageDirectoryEntryToData = nil;\r\n\r\nfunction ImageDirectoryEntryToData(Base: Pointer; MappedAsImage: ByteBool;\r\n DirectoryEntry: USHORT; var Size: ULONG): Pointer;\r\nbegin\r\n GetProcedureAddress(Pointer(@_ImageDirectoryEntryToData), ImageHlpLib, 'ImageDirectoryEntryToData');\r\n Result := _ImageDirectoryEntryToData(Base, MappedAsImage, DirectoryEntry, Size);\r\nend;\r\n\r\ntype\r\n TImageRvaToSection = function (NtHeaders: PImageNtHeaders; Base: Pointer; Rva: ULONG): PImageSectionHeader; stdcall;\r\n\r\nvar\r\n _ImageRvaToSection: TImageRvaToSection = nil;\r\n\r\nfunction ImageRvaToSection(NtHeaders: PImageNtHeaders; Base: Pointer; Rva: ULONG): PImageSectionHeader;\r\nbegin\r\n GetProcedureAddress(Pointer(@_ImageRvaToSection), ImageHlpLib, 'ImageRvaToSection');\r\n Result := _ImageRvaToSection(NtHeaders, Base, Rva);\r\nend;\r\n\r\ntype\r\n TImageRvaToVa = function (NtHeaders: PImageNtHeaders; Base: Pointer; Rva: ULONG;\r\n LastRvaSection: PPImageSectionHeader): Pointer; stdcall;\r\n\r\nvar\r\n _ImageRvaToVa: TImageRvaToVa = nil;\r\n\r\nfunction ImageRvaToVa(NtHeaders: PImageNtHeaders; Base: Pointer; Rva: ULONG;\r\n LastRvaSection: PPImageSectionHeader): Pointer;\r\nbegin\r\n GetProcedureAddress(Pointer(@_ImageRvaToVa), ImageHlpLib, 'ImageRvaToVa');\r\n Result := _ImageRvaToVa(NtHeaders, Base, Rva, LastRvaSection);\r\nend;\r\n\r\n\r\n\r\n\r\ntype\r\n TCancelIo = function (hFile: THandle): BOOL; stdcall;\r\nvar\r\n _CancelIo: TCancelIo = nil;\r\n\r\nfunction CancelIo(hFile: THandle): BOOL;\r\nbegin\r\n GetProcedureAddress(Pointer(@_CancelIo), kernel32, 'CancelIo');\r\n Result := _CancelIo(hFile);\r\nend;\r\n\r\n\r\ntype\r\n TNetUserAdd = function (servername: LPCWSTR; level: DWORD; buf: PByte; parm_err: LPDWORD): NET_API_STATUS; stdcall;\r\nvar\r\n _NetUserAdd: TNetUserAdd = nil;\r\n\r\nfunction NetUserAdd(servername: LPCWSTR; level: DWORD; buf: PByte; parm_err: LPDWORD): NET_API_STATUS;\r\nbegin\r\n GetProcedureAddress(Pointer(@_NetUserAdd), netapi32, 'NetUserAdd');\r\n Result := _NetUserAdd(servername, level, buf, parm_err);\r\nend;\r\n\r\ntype\r\n TNetUserEnum = function (servername: LPCWSTR; level, filter: DWORD; var bufptr: PByte; prefmaxlen: DWORD; entriesread, totalentries, resume_handle: LPDWORD): NET_API_STATUS; stdcall;\r\n\r\nvar\r\n _NetUserEnum: TNetUserEnum = nil;\r\n\r\nfunction NetUserEnum(servername: LPCWSTR; level, filter: DWORD; var bufptr: PByte; prefmaxlen: DWORD; entriesread, totalentries, resume_handle: LPDWORD): NET_API_STATUS;\r\nbegin\r\n GetProcedureAddress(Pointer(@_NetUserEnum), netapi32, 'NetUserEnum');\r\n Result := _NetUserEnum(servername, level, filter, bufptr, prefmaxlen, entriesread, totalentries, resume_handle);\r\nend;\r\n\r\ntype\r\n TNetUserGetInfo = function (servername, username: LPCWSTR; level: DWORD; var bufptr: PByte): NET_API_STATUS; stdcall;\r\n\r\nvar\r\n _NetUserGetInfo: TNetUserGetInfo = nil;\r\n\r\nfunction NetUserGetInfo(servername, username: LPCWSTR; level: DWORD; var bufptr: PByte): NET_API_STATUS;\r\nbegin\r\n GetProcedureAddress(Pointer(@_NetUserGetInfo), netapi32, 'NetUserGetInfo');\r\n Result := _NetUserGetInfo(servername, username, level, bufptr);\r\nend;\r\n\r\ntype\r\n TNetUserSetInfo = function (servername, username: LPCWSTR; level: DWORD; buf: PByte; parm_err: LPDWORD): NET_API_STATUS; stdcall;\r\n\r\nvar\r\n _NetUserSetInfo: TNetUserSetInfo = nil;\r\n\r\nfunction NetUserSetInfo(servername, username: LPCWSTR; level: DWORD; buf: PByte; parm_err: LPDWORD): NET_API_STATUS;\r\nbegin\r\n GetProcedureAddress(Pointer(@_NetUserSetInfo), netapi32, 'NetUserSetInfo');\r\n Result := _NetUserSetInfo(servername, username, level, buf, parm_err);\r\nend;\r\n\r\ntype\r\n TNetUserDel = function (servername: LPCWSTR; username: LPCWSTR): NET_API_STATUS; stdcall;\r\n\r\nvar\r\n _NetUserDel: TNetUserDel = nil;\r\n\r\nfunction NetUserDel(servername: LPCWSTR; username: LPCWSTR): NET_API_STATUS;\r\nbegin\r\n GetProcedureAddress(Pointer(@_NetUserDel), netapi32, 'NetUserDel');\r\n Result := _NetUserDel(servername, username);\r\nend;\r\n\r\ntype\r\n TNetUserGetGroups = function (servername, username: LPCWSTR; level: DWORD; var bufptr: PByte; prefmaxlen: DWORD; entriesread, totalentries: LPDWORD): NET_API_STATUS; stdcall;\r\n\r\nvar\r\n _NetUserGetGroups: TNetUserGetGroups = nil;\r\n\r\nfunction NetUserGetGroups(servername, username: LPCWSTR; level: DWORD; var bufptr: PByte; prefmaxlen: DWORD; entriesread, totalentries: LPDWORD): NET_API_STATUS;\r\nbegin\r\n GetProcedureAddress(Pointer(@_NetUserGetGroups), netapi32, 'NetUserGetGroups');\r\n Result := _NetUserGetGroups(servername, username, level, bufptr, prefmaxlen, entriesread, totalentries);\r\nend;\r\n\r\ntype\r\n TNetUserSetGroups = function (servername, username: LPCWSTR; level: DWORD; buf: PByte; num_entries: DWORD): NET_API_STATUS; stdcall;\r\n\r\nvar\r\n _NetUserSetGroups: TNetUserSetGroups = nil;\r\n\r\nfunction NetUserSetGroups(servername, username: LPCWSTR; level: DWORD; buf: PByte; num_entries: DWORD): NET_API_STATUS;\r\nbegin\r\n GetProcedureAddress(Pointer(@_NetUserSetGroups), netapi32, 'NetUserSetGroups');\r\n Result := _NetUserSetGroups(servername, username, level, buf, num_entries);\r\nend;\r\n\r\ntype\r\n TNetUserGetLocalGroups = function (servername, username: LPCWSTR; level, flags: DWORD; var bufptr: PByte; prefmaxlen: DWORD; entriesread, totalentries: LPDWORD): NET_API_STATUS; stdcall;\r\n\r\nvar\r\n _NetUserGetLocalGroups: TNetUserGetLocalGroups = nil;\r\n\r\nfunction NetUserGetLocalGroups(servername, username: LPCWSTR; level, flags: DWORD; var bufptr: PByte; prefmaxlen: DWORD; entriesread, totalentries: LPDWORD): NET_API_STATUS;\r\nbegin\r\n GetProcedureAddress(Pointer(@_NetUserGetLocalGroups), netapi32, 'NetUserGetLocalGroups');\r\n Result := _NetUserGetLocalGroups(servername, username, level, flags, bufptr, prefmaxlen, entriesread, totalentries);\r\nend;\r\n\r\ntype\r\n TNetUserModalsGet = function (servername: LPCWSTR; level: DWORD; var bufptr: PByte): NET_API_STATUS; stdcall;\r\n\r\nvar\r\n _NetUserModalsGet: TNetUserModalsGet = nil;\r\n\r\nfunction NetUserModalsGet(servername: LPCWSTR; level: DWORD; var bufptr: PByte): NET_API_STATUS;\r\nbegin\r\n GetProcedureAddress(Pointer(@_NetUserModalsGet), netapi32, 'NetUserModalsGet');\r\n Result := _NetUserModalsGet(servername, level, bufptr);\r\nend;\r\n\r\ntype\r\n TNetUserModalsSet = function (servername: LPCWSTR; level: DWORD; buf: PByte; parm_err: LPDWORD): NET_API_STATUS; stdcall;\r\n\r\nvar\r\n _NetUserModalsSet: TNetUserModalsSet = nil;\r\n\r\nfunction NetUserModalsSet(servername: LPCWSTR; level: DWORD; buf: PByte; parm_err: LPDWORD): NET_API_STATUS;\r\nbegin\r\n GetProcedureAddress(Pointer(@_NetUserModalsSet), netapi32, 'NetUserModalsSet');\r\n Result := _NetUserModalsSet(servername, level, buf, parm_err);\r\nend;\r\n\r\ntype\r\n TNetUserChangePassword = function (domainname, username, oldpassword, newpassword: LPCWSTR): NET_API_STATUS; stdcall;\r\n\r\nvar\r\n _NetUserChangePassword: TNetUserChangePassword = nil;\r\n\r\nfunction NetUserChangePassword(domainname, username, oldpassword, newpassword: LPCWSTR): NET_API_STATUS;\r\nbegin\r\n GetProcedureAddress(Pointer(@_NetUserChangePassword), netapi32, 'NetUserChangePassword');\r\n Result := _NetUserChangePassword(domainname, username, oldpassword, newpassword);\r\nend;\r\n\r\ntype\r\n TNetGroupAdd = function (servername: LPCWSTR; level: DWORD; buf: PByte; parm_err: LPDWORD): NET_API_STATUS; stdcall;\r\n\r\nvar\r\n _NetGroupAdd: TNetGroupAdd = nil;\r\n\r\nfunction NetGroupAdd(servername: LPCWSTR; level: DWORD; buf: PByte; parm_err: LPDWORD): NET_API_STATUS;\r\nbegin\r\n GetProcedureAddress(Pointer(@_NetGroupAdd), netapi32, 'NetGroupAdd');\r\n Result := _NetGroupAdd(servername, level, buf, parm_err);\r\nend;\r\n\r\ntype\r\n TNetGroupAddUser = function (servername, GroupName, username: LPCWSTR): NET_API_STATUS; stdcall;\r\n\r\nvar\r\n _NetGroupAddUser: TNetGroupAddUser = nil;\r\n\r\nfunction NetGroupAddUser(servername, GroupName, username: LPCWSTR): NET_API_STATUS;\r\nbegin\r\n GetProcedureAddress(Pointer(@_NetGroupAddUser), netapi32, 'NetGroupAddUser');\r\n Result := _NetGroupAddUser(servername, GroupName, username);\r\nend;\r\n\r\ntype\r\n TNetGroupEnum = function (servername: LPCWSTR; level: DWORD; out bufptr: PByte;\r\n prefmaxlen: DWORD; out entriesread, totalentries: DWORD; resume_handle: PDWORD_PTR): NET_API_STATUS; stdcall;\r\n\r\nvar\r\n _NetGroupEnum: TNetGroupEnum = nil;\r\n\r\nfunction NetGroupEnum(servername: LPCWSTR; level: DWORD; out bufptr: PByte;\r\n prefmaxlen: DWORD; out entriesread, totalentries: DWORD; resume_handle: PDWORD_PTR): NET_API_STATUS;\r\nbegin\r\n GetProcedureAddress(Pointer(@_NetGroupEnum), netapi32, 'NetGroupEnum');\r\n Result := _NetGroupEnum(servername, level, bufptr, prefmaxlen, entriesread, totalentries, resume_handle);\r\nend;\r\n\r\ntype\r\n TNetGroupGetInfo = function (servername, groupname: LPCWSTR; level: DWORD; bufptr: PByte): NET_API_STATUS; stdcall;\r\n\r\nvar\r\n _NetGroupGetInfo: TNetGroupGetInfo = nil;\r\n\r\nfunction NetGroupGetInfo(servername, groupname: LPCWSTR; level: DWORD; bufptr: PByte): NET_API_STATUS;\r\nbegin\r\n GetProcedureAddress(Pointer(@_NetGroupGetInfo), netapi32, 'NetGroupGetInfo');\r\n Result := _NetGroupGetInfo(servername, groupname, level, bufptr);\r\nend;\r\n\r\ntype\r\n TNetGroupSetInfo = function (servername, groupname: LPCWSTR; level: DWORD; buf: PByte; parm_err: LPDWORD): NET_API_STATUS; stdcall;\r\n\r\nvar\r\n _NetGroupSetInfo: TNetGroupSetInfo = nil;\r\n\r\nfunction NetGroupSetInfo(servername, groupname: LPCWSTR; level: DWORD; buf: PByte; parm_err: LPDWORD): NET_API_STATUS;\r\nbegin\r\n GetProcedureAddress(Pointer(@_NetGroupSetInfo), netapi32, 'NetGroupSetInfo');\r\n Result := _NetGroupSetInfo(servername, groupname, level, buf, parm_err);\r\nend;\r\n\r\ntype\r\n TNetGroupDel = function (servername: LPCWSTR; groupname: LPCWSTR): NET_API_STATUS; stdcall;\r\n\r\nvar\r\n _NetGroupDel: TNetGroupDel = nil;\r\n\r\nfunction NetGroupDel(servername: LPCWSTR; groupname: LPCWSTR): NET_API_STATUS;\r\nbegin\r\n GetProcedureAddress(Pointer(@_NetGroupDel), netapi32, 'NetGroupDel');\r\n Result := _NetGroupDel(servername, groupname);\r\nend;\r\n\r\ntype\r\n TNetGroupDelUser = function (servername: LPCWSTR; GroupName: LPCWSTR; Username: LPCWSTR): NET_API_STATUS; stdcall;\r\n\r\nvar\r\n _NetGroupDelUser: TNetGroupDelUser = nil;\r\n\r\nfunction NetGroupDelUser(servername: LPCWSTR; GroupName: LPCWSTR; Username: LPCWSTR): NET_API_STATUS;\r\nbegin\r\n GetProcedureAddress(Pointer(@_NetGroupDelUser), netapi32, 'NetGroupDelUser');\r\n Result := _NetGroupDelUser(servername, GroupName, Username);\r\nend;\r\n\r\ntype\r\n TNetGroupGetUsers = function (servername, groupname: LPCWSTR; level: DWORD; var bufptr: PByte; prefmaxlen: DWORD; entriesread, totalentries: LPDWORD; ResumeHandle: PDWORD_PTR): NET_API_STATUS; stdcall;\r\n\r\nvar\r\n _NetGroupGetUsers: TNetGroupGetUsers = nil;\r\n\r\nfunction NetGroupGetUsers(servername, groupname: LPCWSTR; level: DWORD; var bufptr: PByte; prefmaxlen: DWORD; entriesread, totalentries: LPDWORD; ResumeHandle: PDWORD_PTR): NET_API_STATUS;\r\nbegin\r\n GetProcedureAddress(Pointer(@_NetGroupGetUsers), netapi32, 'NetGroupGetUsers');\r\n Result := _NetGroupGetUsers(servername, groupname, level, bufptr, prefmaxlen, entriesread, totalentries, ResumeHandle);\r\nend;\r\n\r\ntype\r\n TNetGroupSetUsers = function (servername, groupname: LPCWSTR; level: DWORD; buf: PByte; totalentries: DWORD): NET_API_STATUS; stdcall;\r\n\r\nvar\r\n _NetGroupSetUsers: TNetGroupSetUsers = nil;\r\n\r\nfunction NetGroupSetUsers(servername, groupname: LPCWSTR; level: DWORD; buf: PByte; totalentries: DWORD): NET_API_STATUS;\r\nbegin\r\n GetProcedureAddress(Pointer(@_NetGroupSetUsers), netapi32, 'NetGroupSetUsers');\r\n Result := _NetGroupSetUsers(servername, groupname, level, buf, totalentries);\r\nend;\r\n\r\ntype\r\n TNetLocalGroupAdd = function (servername: LPCWSTR; level: DWORD; buf: PByte; parm_err: LPDWORD): NET_API_STATUS; stdcall;\r\n\r\nvar\r\n _NetLocalGroupAdd: TNetLocalGroupAdd = nil;\r\n\r\nfunction NetLocalGroupAdd(servername: LPCWSTR; level: DWORD; buf: PByte; parm_err: LPDWORD): NET_API_STATUS;\r\nbegin\r\n GetProcedureAddress(Pointer(@_NetLocalGroupAdd), netapi32, 'NetLocalGroupAdd');\r\n Result := _NetLocalGroupAdd(servername, level, buf, parm_err);\r\nend;\r\n\r\ntype\r\n TNetLocalGroupAddMember = function (servername, groupname: LPCWSTR; membersid: PSID): NET_API_STATUS; stdcall;\r\n\r\nvar\r\n _NetLocalGroupAddMember: TNetLocalGroupAddMember = nil;\r\n\r\nfunction NetLocalGroupAddMember(servername, groupname: LPCWSTR; membersid: PSID): NET_API_STATUS;\r\nbegin\r\n GetProcedureAddress(Pointer(@_NetLocalGroupAddMember), netapi32, 'NetLocalGroupAddMember');\r\n Result := _NetLocalGroupAddMember(servername, groupname, membersid);\r\nend;\r\n\r\ntype\r\n TNetLocalGroupEnum = function (servername: LPCWSTR; level: DWORD; out bufptr: PByte;\r\n prefmaxlen: DWORD; out entriesread, totalentries: DWORD; resumehandle: PDWORD_PTR): NET_API_STATUS; stdcall;\r\n\r\nvar\r\n _NetLocalGroupEnum: TNetLocalGroupEnum = nil;\r\n\r\nfunction NetLocalGroupEnum(servername: LPCWSTR; level: DWORD; out bufptr: PByte;\r\n prefmaxlen: DWORD; out entriesread, totalentries: DWORD; resumehandle: PDWORD_PTR): NET_API_STATUS;\r\nbegin\r\n GetProcedureAddress(Pointer(@_NetLocalGroupEnum), netapi32, 'NetLocalGroupEnum');\r\n Result := _NetLocalGroupEnum(servername, level, bufptr, prefmaxlen, entriesread, totalentries, resumehandle);\r\nend;\r\n\r\ntype\r\n TNetLocalGroupGetInfo = function (servername, groupname: LPCWSTR; level: DWORD; var bufptr: PByte): NET_API_STATUS; stdcall;\r\n\r\nvar\r\n _NetLocalGroupGetInfo: TNetLocalGroupGetInfo = nil;\r\n\r\nfunction NetLocalGroupGetInfo(servername, groupname: LPCWSTR; level: DWORD; var bufptr: PByte): NET_API_STATUS;\r\nbegin\r\n GetProcedureAddress(Pointer(@_NetLocalGroupGetInfo), netapi32, 'NetLocalGroupGetInfo');\r\n Result := _NetLocalGroupGetInfo(servername, groupname, level, bufptr);\r\nend;\r\n\r\ntype\r\n TNetLocalGroupSetInfo = function (servername, groupname: LPCWSTR; level: DWORD; buf: PByte; parm_err: LPDWORD): NET_API_STATUS; stdcall;\r\n\r\nvar\r\n _NetLocalGroupSetInfo: TNetLocalGroupSetInfo = nil;\r\n\r\nfunction NetLocalGroupSetInfo(servername, groupname: LPCWSTR; level: DWORD; buf: PByte; parm_err: LPDWORD): NET_API_STATUS;\r\nbegin\r\n GetProcedureAddress(Pointer(@_NetLocalGroupSetInfo), netapi32, 'NetLocalGroupSetInfo');\r\n Result := _NetLocalGroupSetInfo(servername, groupname, level, buf, parm_err);\r\nend;\r\n\r\ntype\r\n TNetLocalGroupDel = function (servername: LPCWSTR; groupname: LPCWSTR): NET_API_STATUS; stdcall;\r\n\r\nvar\r\n _NetLocalGroupDel: TNetLocalGroupDel = nil;\r\n\r\nfunction NetLocalGroupDel(servername: LPCWSTR; groupname: LPCWSTR): NET_API_STATUS;\r\nbegin\r\n GetProcedureAddress(Pointer(@_NetLocalGroupDel), netapi32, 'NetLocalGroupDel');\r\n Result := _NetLocalGroupDel(servername, groupname);\r\nend;\r\n\r\ntype\r\n TNetLocalGroupDelMember = function (servername: LPCWSTR; groupname: LPCWSTR; membersid: PSID): NET_API_STATUS; stdcall;\r\n\r\nvar\r\n _NetLocalGroupDelMember: TNetLocalGroupDelMember = nil;\r\n\r\nfunction NetLocalGroupDelMember(servername: LPCWSTR; groupname: LPCWSTR; membersid: PSID): NET_API_STATUS;\r\nbegin\r\n GetProcedureAddress(Pointer(@_NetLocalGroupDelMember), netapi32, 'NetLocalGroupDelMember');\r\n Result := _NetLocalGroupDelMember(servername, groupname, membersid);\r\nend;\r\n\r\ntype\r\n TNetLocalGroupGetMembers = function (servername, localgroupname: LPCWSTR; level: DWORD; var bufptr: PByte; prefmaxlen: DWORD; entriesread, totalentries: LPDWORD; resumehandle: PDWORD_PTR): NET_API_STATUS; stdcall;\r\n\r\nvar\r\n _NetLocalGroupGetMembers: TNetLocalGroupGetMembers = nil;\r\n\r\nfunction NetLocalGroupGetMembers(servername, localgroupname: LPCWSTR; level: DWORD; var bufptr: PByte; prefmaxlen: DWORD; entriesread, totalentries: LPDWORD; resumehandle: PDWORD_PTR): NET_API_STATUS;\r\nbegin\r\n GetProcedureAddress(Pointer(@_NetLocalGroupGetMembers), netapi32, 'NetLocalGroupGetMembers');\r\n Result := _NetLocalGroupGetMembers(servername, localgroupname, level, bufptr, prefmaxlen, entriesread, totalentries, resumehandle);\r\nend;\r\n\r\ntype\r\n TNetLocalGroupSetMembers = function (servername, groupname: LPCWSTR; level: DWORD; buf: PByte; totalentries: DWORD): NET_API_STATUS; stdcall;\r\n\r\nvar\r\n _NetLocalGroupSetMembers: TNetLocalGroupSetMembers = nil;\r\n\r\nfunction NetLocalGroupSetMembers(servername, groupname: LPCWSTR; level: DWORD; buf: PByte; totalentries: DWORD): NET_API_STATUS;\r\nbegin\r\n GetProcedureAddress(Pointer(@_NetLocalGroupSetMembers), netapi32, 'NetLocalGroupSetMembers');\r\n Result := _NetLocalGroupSetMembers(servername, groupname, level, buf, totalentries);\r\nend;\r\n\r\ntype\r\n TNetLocalGroupAddMembers = function (servername, groupname: LPCWSTR; level: DWORD; buf: PByte; totalentries: DWORD): NET_API_STATUS; stdcall;\r\n\r\nvar\r\n _NetLocalGroupAddMembers: TNetLocalGroupAddMembers = nil;\r\n\r\nfunction NetLocalGroupAddMembers(servername, groupname: LPCWSTR; level: DWORD; buf: PByte; totalentries: DWORD): NET_API_STATUS;\r\nbegin\r\n GetProcedureAddress(Pointer(@_NetLocalGroupAddMembers), netapi32, 'NetLocalGroupAddMembers');\r\n Result := _NetLocalGroupAddMembers(servername, groupname, level, buf, totalentries);\r\nend;\r\n\r\ntype\r\n TNetLocalGroupDelMembers = function (servername, groupname: LPCWSTR; level: DWORD; buf: PByte; totalentries: DWORD): NET_API_STATUS; stdcall;\r\n\r\nvar\r\n _NetLocalGroupDelMembers: TNetLocalGroupDelMembers = nil;\r\n\r\nfunction NetLocalGroupDelMembers(servername, groupname: LPCWSTR; level: DWORD; buf: PByte; totalentries: DWORD): NET_API_STATUS;\r\nbegin\r\n GetProcedureAddress(Pointer(@_NetLocalGroupDelMembers), netapi32, 'NetLocalGroupDelMembers');\r\n Result := _NetLocalGroupDelMembers(servername, groupname, level, buf, totalentries);\r\nend;\r\n\r\n\r\n\r\ntype\r\n TNetApiBufferFree = function (Buffer: Pointer): NET_API_STATUS; stdcall;\r\n\r\nvar\r\n _NetApiBufferFree: TNetApiBufferFree = nil;\r\n\r\nfunction NetApiBufferFree(Buffer: Pointer): NET_API_STATUS;\r\nbegin\r\n GetProcedureAddress(Pointer(@_NetApiBufferFree), netapi32, 'NetApiBufferFree');\r\n Result := _NetApiBufferFree(Buffer);\r\nend;\r\n\r\n\r\n\r\ntype\r\n TNetWkstaGetInfo = function (servername: PWideChar; level: DWORD; out bufptr: PByte): NET_API_STATUS; stdcall;\r\n\r\nvar\r\n _NetWkstaGetInfo: TNetWkstaGetInfo = nil;\r\n\r\nfunction NetWkstaGetInfo(servername: PWideChar; level: DWORD; out bufptr: PByte): NET_API_STATUS; stdcall;\r\nbegin\r\n GetProcedureAddress(Pointer(@_NetWkstaGetInfo), netapi32, 'NetWkstaGetInfo');\r\n Result := _NetWkstaGetInfo(servername, level, bufptr);\r\nend;\r\n\r\n\r\n\r\ntype\r\n TNetbios = function (pncb: PNCB): UCHAR; stdcall;\r\nvar\r\n _Netbios: TNetbios = nil;\r\n\r\nfunction Netbios(pncb: PNCB): UCHAR;\r\nbegin\r\n GetProcedureAddress(Pointer(@_Netbios), 'netapi32.dll', 'Netbios');\r\n Result := _Netbios(pncb);\r\nend;\r\n\r\n\r\n\r\ntype\r\n TGlobalMemoryStatusEx = function (out lpBuffer: TMemoryStatusEx): BOOL; stdcall;\r\n\r\nvar\r\n _GlobalMemoryStatusEx: TGlobalMemoryStatusEx = nil;\r\n\r\nfunction GlobalMemoryStatusEx(out lpBuffer: TMemoryStatusEx): BOOL; stdcall;\r\nbegin\r\n GetProcedureAddress(Pointer(@_GlobalMemoryStatusEx), kernel32, 'GlobalMemoryStatusEx');\r\n Result := _GlobalMemoryStatusEx(lpBuffer);\r\nend;\r\n\r\ntype\r\n TBackupSeek = function (hFile: THandle; dwLowBytesToSeek, dwHighBytesToSeek: DWORD;\r\n out lpdwLowByteSeeked, lpdwHighByteSeeked: DWORD;\r\n var lpContext: Pointer): BOOL; stdcall;\r\n\r\nvar\r\n _BackupSeek: TBackupSeek = nil;\r\n\r\nfunction BackupSeek(hFile: THandle; dwLowBytesToSeek, dwHighBytesToSeek: DWORD;\r\n out lpdwLowByteSeeked, lpdwHighByteSeeked: DWORD;\r\n var lpContext: Pointer): BOOL;\r\nbegin\r\n GetProcedureAddress(Pointer(@_BackupSeek), kernel32, 'BackupSeek');\r\n Result := _BackupSeek(hFile, dwLowBytesToSeek, dwHighBytesToSeek, lpdwLowByteSeeked, lpdwHighByteSeeked, lpContext);\r\nend;\r\n\r\ntype\r\n TAdjustTokenPrivileges = function (TokenHandle: THandle; DisableAllPrivileges: BOOL;\r\n const NewState: TTokenPrivileges; BufferLength: DWORD;\r\n PreviousState: PTokenPrivileges;\r\n ReturnLength: PDWORD\r\n ): BOOL; stdcall;\r\n\r\nvar\r\n _AdjustTokenPrivileges: TAdjustTokenPrivileges = nil;\r\n\r\nfunction AdjustTokenPrivileges(TokenHandle: THandle; DisableAllPrivileges: BOOL;\r\n const NewState: TTokenPrivileges; BufferLength: DWORD;\r\n PreviousState: PTokenPrivileges;\r\n ReturnLength: PDWORD\r\n ): BOOL;\r\nbegin\r\n GetProcedureAddress(Pointer(@_AdjustTokenPrivileges), advapi32, 'AdjustTokenPrivileges');\r\n Result := _AdjustTokenPrivileges(TokenHandle, DisableAllPrivileges, NewState, BufferLength, PreviousState, ReturnLength);\r\nend;\r\n\r\nfunction CreateMutex(lpMutexAttributes: PSecurityAttributes; bInitialOwner: DWORD; lpName: PChar): THandle; stdcall;\r\n external kernel32 name 'CreateMutex' + AWSuffix;\r\n\r\nfunction GetVersionEx(var lpVersionInformation: TOSVersionInfoEx): BOOL; stdcall;\r\n external kernel32 name 'GetVersionEx' + AWSuffix;\r\nfunction GetVersionEx(lpVersionInformation: POSVersionInfoEx): BOOL; stdcall;\r\n external kernel32 name 'GetVersionEx' + AWSuffix;\r\n\r\ntype\r\n TSetWaitableTimer = function (hTimer: THandle; var lpDueTime: TLargeInteger;\r\n lPeriod: Longint; pfnCompletionRoutine: TFNTimerAPCRoutine;\r\n lpArgToCompletionRoutine: Pointer; fResume: BOOL): BOOL; stdcall;\r\n\r\nvar\r\n _SetWaitableTimer: TSetWaitableTimer = nil;\r\n\r\nfunction SetWaitableTimer(hTimer: THandle; var lpDueTime: TLargeInteger;\r\n lPeriod: Longint; pfnCompletionRoutine: TFNTimerAPCRoutine;\r\n lpArgToCompletionRoutine: Pointer; fResume: BOOL): BOOL;\r\nbegin\r\n GetProcedureAddress(Pointer(@_SetWaitableTimer), kernel32, 'SetWaitableTimer');\r\n Result := _SetWaitableTimer(hTimer, lpDueTime, lPeriod, pfnCompletionRoutine, lpArgToCompletionRoutine, fResume);\r\nend;\r\n\r\ntype\r\n TSetFileSecurityA = function (lpFileName: LPCSTR; SecurityInformation: SECURITY_INFORMATION;\r\n pSecurityDescriptor: PSECURITY_DESCRIPTOR): BOOL; stdcall;\r\nvar\r\n _SetFileSecurityA: TSetFileSecurityA = nil;\r\n\r\nfunction SetFileSecurityA(lpFileName: LPCSTR; SecurityInformation: SECURITY_INFORMATION;\r\n pSecurityDescriptor: PSECURITY_DESCRIPTOR): BOOL;\r\nbegin\r\n GetProcedureAddress(Pointer(@_SetFileSecurityA), advapi32, 'SetFileSecurityA');\r\n Result := _SetFileSecurityA(lpFileName, SecurityInformation, pSecurityDescriptor);\r\nend;\r\n\r\ntype\r\n TSetFileSecurityW = function (lpFileName: LPCWSTR; SecurityInformation: SECURITY_INFORMATION;\r\n pSecurityDescriptor: PSECURITY_DESCRIPTOR): BOOL; stdcall;\r\n\r\nvar\r\n _SetFileSecurityW: TSetFileSecurityW = nil;\r\n\r\nfunction SetFileSecurityW(lpFileName: LPCWSTR; SecurityInformation: SECURITY_INFORMATION;\r\n pSecurityDescriptor: PSECURITY_DESCRIPTOR): BOOL;\r\nbegin\r\n GetProcedureAddress(Pointer(@_SetFileSecurityW), advapi32, 'SetFileSecurityW');\r\n Result := _SetFileSecurityW(lpFileName, SecurityInformation, pSecurityDescriptor);\r\nend;\r\n\r\ntype\r\n TSetFileSecurity = function (lpFileName: LPCTSTR; SecurityInformation: SECURITY_INFORMATION;\r\n pSecurityDescriptor: PSECURITY_DESCRIPTOR): BOOL; stdcall;\r\n\r\nvar\r\n _SetFileSecurity: TSetFileSecurity = nil;\r\n\r\nfunction SetFileSecurity(lpFileName: LPCTSTR; SecurityInformation: SECURITY_INFORMATION;\r\n pSecurityDescriptor: PSECURITY_DESCRIPTOR): BOOL;\r\nbegin\r\n GetProcedureAddress(Pointer(@_SetFileSecurity), advapi32, 'SetFileSecurity' + AWSuffix);\r\n Result := _SetFileSecurity(lpFileName, SecurityInformation, pSecurityDescriptor);\r\nend;\r\n\r\ntype\r\n TGetFileSecurityA = function (lpFileName: LPCSTR; RequestedInformation: SECURITY_INFORMATION;\r\n pSecurityDescriptor: PSECURITY_DESCRIPTOR; nLength: DWORD;\r\n var lpnLengthNeeded: DWORD): BOOL; stdcall;\r\n\r\nvar\r\n _GetFileSecurityA: TGetFileSecurityA = nil;\r\n\r\nfunction GetFileSecurityA(lpFileName: LPCSTR; RequestedInformation: SECURITY_INFORMATION;\r\n pSecurityDescriptor: PSECURITY_DESCRIPTOR; nLength: DWORD;\r\n var lpnLengthNeeded: DWORD): BOOL;\r\nbegin\r\n GetProcedureAddress(Pointer(@_GetFileSecurityA), advapi32, 'GetFileSecurityA');\r\n Result := _GetFileSecurityA(lpFileName, RequestedInformation, pSecurityDescriptor, nLength, lpnLengthNeeded);\r\nend;\r\n\r\ntype\r\n TGetFileSecurityW = function (lpFileName: LPCWSTR; RequestedInformation: SECURITY_INFORMATION;\r\n pSecurityDescriptor: PSECURITY_DESCRIPTOR; nLength: DWORD;\r\n var lpnLengthNeeded: DWORD): BOOL; stdcall;\r\n\r\nvar\r\n _GetFileSecurityW: TGetFileSecurityW = nil;\r\n\r\nfunction GetFileSecurityW(lpFileName: LPCWSTR; RequestedInformation: SECURITY_INFORMATION;\r\n pSecurityDescriptor: PSECURITY_DESCRIPTOR; nLength: DWORD;\r\n var lpnLengthNeeded: DWORD): BOOL;\r\nbegin\r\n GetProcedureAddress(Pointer(@_GetFileSecurityW), advapi32, 'GetFileSecurityW');\r\n Result := _GetFileSecurityW(lpFileName, RequestedInformation, pSecurityDescriptor, nLength, lpnLengthNeeded);\r\nend;\r\n\r\ntype\r\n TGetFileSecurity = function (lpFileName: LPCTSTR; RequestedInformation: SECURITY_INFORMATION;\r\n pSecurityDescriptor: PSECURITY_DESCRIPTOR; nLength: DWORD;\r\n var lpnLengthNeeded: DWORD): BOOL; stdcall;\r\n\r\nvar\r\n _GetFileSecurity: TGetFileSecurity = nil;\r\n\r\nfunction GetFileSecurity(lpFileName: LPCTSTR; RequestedInformation: SECURITY_INFORMATION;\r\n pSecurityDescriptor: PSECURITY_DESCRIPTOR; nLength: DWORD;\r\n var lpnLengthNeeded: DWORD): BOOL;\r\nbegin\r\n GetProcedureAddress(Pointer(@_GetFileSecurity), advapi32, 'GetFileSecurity' + AWSuffix);\r\n Result := _GetFileSecurity(lpFileName, RequestedInformation, pSecurityDescriptor, nLength, lpnLengthNeeded);\r\nend;\r\n\r\ntype\r\n TSetVolumeMountPointW = function (lpszVolumeMountPoint, lpszVolumeName: LPCWSTR): BOOL; stdcall;\r\n\r\nvar\r\n _SetVolumeMountPointW: TSetVolumeMountPointW = nil;\r\n\r\nfunction SetVolumeMountPointW(lpszVolumeMountPoint, lpszVolumeName: LPCWSTR): BOOL;\r\nbegin\r\n GetProcedureAddress(Pointer(@_SetVolumeMountPointW), kernel32, 'SetVolumeMountPointW');\r\n Result := _SetVolumeMountPointW(lpszVolumeMountPoint, lpszVolumeName);\r\nend;\r\n\r\ntype\r\n TDeleteVolumeMountPointW = function (lpszVolumeMountPoint: LPCWSTR): BOOL; stdcall;\r\n\r\nvar\r\n _DeleteVolumeMountPointW: TDeleteVolumeMountPointW = nil;\r\n\r\nfunction DeleteVolumeMountPointW(lpszVolumeMountPoint: LPCWSTR): BOOL;\r\nbegin\r\n GetProcedureAddress(Pointer(@_DeleteVolumeMountPointW), kernel32, 'DeleteVolumeMountPointW');\r\n Result := _DeleteVolumeMountPointW(lpszVolumeMountPoint);\r\nend;\r\n\r\ntype\r\n TGetVolumeNameForVolumeMountPointW = function (lpszVolumeMountPoint: LPCWSTR;\r\n lpszVolumeName: LPWSTR; cchBufferLength: DWORD): BOOL; stdcall;\r\n\r\nvar\r\n _GetVolumeNameForVolMountPointW: TGetVolumeNameForVolumeMountPointW = nil;\r\n\r\nfunction GetVolumeNameForVolumeMountPointW(lpszVolumeMountPoint: LPCWSTR;\r\n lpszVolumeName: LPWSTR; cchBufferLength: DWORD): BOOL;\r\nbegin\r\n GetProcedureAddress(Pointer(@_GetVolumeNameForVolMountPointW), kernel32, 'GetVolumeNameForVolumeMountPointW');\r\n Result := _GetVolumeNameForVolMountPointW(lpszVolumeMountPoint, lpszVolumeName, cchBufferLength);\r\nend;\r\n\r\ntype\r\n TCopyExtendedContext = function (Destination: PCONTEXT_EX; ContextFlags: DWORD; Source: PCONTEXT_EX): BOOL; stdcall;\r\n\r\nvar\r\n _CopyExtendedContext: TCopyExtendedContext = nil;\r\n\r\nfunction CopyExtendedContext(Destination: PCONTEXT_EX; ContextFlags: DWORD; Source: PCONTEXT_EX): BOOL;\r\nbegin\r\n GetProcedureAddress(Pointer(@_CopyExtendedContext), kernel32, 'CopyExtendedContext');\r\n Result := _CopyExtendedContext(Destination, ContextFlags, Source);\r\nend;\r\n\r\ntype\r\n TInitializeExtendedContext = function (Context: Pointer; ContextFlags: DWORD; out ContextEx: PCONTEXT_EX): BOOL; stdcall;\r\n\r\nvar\r\n _InitializeExtendedContext: TInitializeExtendedContext = nil;\r\n\r\nfunction InitializeExtendedContext(Context: Pointer; ContextFlags: DWORD; out ContextEx: PCONTEXT_EX): BOOL;\r\nbegin\r\n GetProcedureAddress(Pointer(@_InitializeExtendedContext), kernel32, 'InitializeExtendedContext');\r\n Result := _InitializeExtendedContext(Context, ContextFlags, ContextEx);\r\nend;\r\n\r\ntype\r\n TGetEnabledExtendedFeatures = function (const FeatureMask: Int64): Int64; stdcall;\r\nvar\r\n _GetEnabledExtendedFeatures: TGetEnabledExtendedFeatures = nil;\r\n\r\nfunction GetEnabledExtendedFeatures(const FeatureMask: Int64): Int64;\r\nbegin\r\n GetProcedureAddress(Pointer(@_GetEnabledExtendedFeatures), kernel32, 'GetEnabledExtendedFeatures');\r\n Result := _GetEnabledExtendedFeatures(FeatureMask);\r\nend;\r\n\r\ntype\r\n TGetExtendedContextLength = function (ContextFlags: DWORD; ContextLength: PDWORD): BOOL; stdcall;\r\n\r\nvar\r\n _GetExtendedContextLength: TGetExtendedContextLength = nil;\r\n\r\nfunction GetExtendedContextLength(ContextFlags: DWORD; ContextLength: PDWORD): BOOL;\r\nbegin\r\n GetProcedureAddress(Pointer(@_GetExtendedContextLength), kernel32, 'GetExtendedContextLength');\r\n Result := _GetExtendedContextLength(ContextFlags, ContextLength);\r\nend;\r\n\r\ntype\r\n TGetExtendedFeaturesMask = function (ContextEx: PCONTEXT_EX): Int64; stdcall;\r\n\r\nvar\r\n _GetExtendedFeaturesMask: TGetExtendedFeaturesMask = nil;\r\n\r\nfunction GetExtendedFeaturesMask(ContextEx: PCONTEXT_EX): Int64;\r\nbegin\r\n GetProcedureAddress(Pointer(@_GetExtendedFeaturesMask), kernel32, 'GetExtendedFeaturesMask');\r\n Result := _GetExtendedFeaturesMask(ContextEx);\r\nend;\r\n\r\ntype\r\n TLocateExtendedFeature = function (ContextEx: PCONTEXT_EX; FeatureId: DWORD; Length: PDWORD): Pointer; stdcall;\r\n\r\nvar\r\n _LocateExtendedFeature: TLocateExtendedFeature = nil;\r\n\r\nfunction LocateExtendedFeature(ContextEx: PCONTEXT_EX; FeatureId: DWORD; Length: PDWORD): Pointer;\r\nbegin\r\n GetProcedureAddress(Pointer(@_LocateExtendedFeature), kernel32, 'LocateExtendedFeature');\r\n Result := _LocateExtendedFeature(ContextEx, FeatureId, Length);\r\nend;\r\n\r\ntype\r\n TLocateLegacyContext = function (ContextEx: PCONTEXT_EX; Length: PDWORD): PCONTEXT; stdcall;\r\n\r\nvar\r\n _LocateLegacyContext: TLocateLegacyContext = nil;\r\n\r\nfunction LocateLegacyContext(ContextEx: PCONTEXT_EX; Length: PDWORD): PCONTEXT;\r\nbegin\r\n GetProcedureAddress(Pointer(@_LocateLegacyContext), kernel32, 'LocateLegacyContext');\r\n Result := _LocateLegacyContext(ContextEx, Length);\r\nend;\r\n\r\ntype\r\n TSetExtendedFeaturesMask = procedure (ContextEx: PCONTEXT_EX; const FeatureMask: Int64); stdcall;\r\n\r\nvar\r\n _SetExtendedFeaturesMask: TSetExtendedFeaturesMask = nil;\r\n\r\nprocedure SetExtendedFeaturesMask(ContextEx: PCONTEXT_EX; const FeatureMask: Int64);\r\nbegin\r\n GetProcedureAddress(Pointer(@_SetExtendedFeaturesMask), kernel32, 'SetExtendedFeaturesMask');\r\n _SetExtendedFeaturesMask(ContextEx, FeatureMask);\r\nend;\r\n\r\ntype\r\n TProcessIdToSessionId = function (dwProcessId: DWORD; out dwSessionId: DWORD): BOOL; stdcall;\r\n\r\nvar\r\n _ProcessIdToSessionId: TProcessIdToSessionId = nil;\r\n\r\nfunction ProcessIdToSessionId(dwProcessId: DWORD; out dwSessionId: DWORD): BOOL;\r\nbegin\r\n GetProcedureAddress(Pointer(@_ProcessIdToSessionId), kernel32, 'ProcessIdToSessionId');\r\n Result := _ProcessIdToSessionId(dwProcessId, dwSessionId);\r\nend;\r\n\r\n\r\n\r\ntype\r\n TGetCalendarInfoA = function (Locale: LCID; Calendar: CALID; CalType: CALTYPE;\r\n lpCalData: LPSTR; cchData: Integer; lpValue: LPDWORD): Integer; stdcall;\r\n\r\nvar\r\n _GetCalendarInfoA: TGetCalendarInfoA = nil;\r\n\r\nfunction GetCalendarInfoA(Locale: LCID; Calendar: CALID; CalType: CALTYPE;\r\n lpCalData: LPSTR; cchData: Integer; lpValue: LPDWORD): Integer;\r\nbegin\r\n GetProcedureAddress(Pointer(@_GetCalendarInfoA), kernel32, 'GetCalendarInfoA');\r\n Result := _GetCalendarInfoA(Locale, Calendar, CalType, lpCalData, cchData, lpValue);\r\nend;\r\n\r\ntype\r\n TGetCalendarInfoW = function (Locale: LCID; Calendar: CALID; CalType: CALTYPE;\r\n lpCalData: LPWSTR; cchData: Integer; lpValue: LPDWORD): Integer; stdcall;\r\n\r\nvar\r\n _GetCalendarInfoW: TGetCalendarInfoW = nil;\r\n\r\nfunction GetCalendarInfoW(Locale: LCID; Calendar: CALID; CalType: CALTYPE;\r\n lpCalData: LPWSTR; cchData: Integer; lpValue: LPDWORD): Integer;\r\nbegin\r\n GetProcedureAddress(Pointer(@_GetCalendarInfoW), kernel32, 'GetCalendarInfoW');\r\n Result := _GetCalendarInfoW(Locale, Calendar, CalType, lpCalData, cchData, lpValue);\r\nend;\r\n\r\ntype\r\n TEnumCalendarInfoExW = function (lpCalInfoEnumProcEx: CALINFO_ENUMPROCEXW;\r\n Locale: LCID; Calendar: CALID; CalType: CALTYPE): BOOL; stdcall;\r\n\r\nvar\r\n _EnumCalendarInfoExW: TEnumCalendarInfoExW = nil;\r\n\r\nfunction EnumCalendarInfoExW(lpCalInfoEnumProcEx: CALINFO_ENUMPROCEXW;\r\n Locale: LCID; Calendar: CALID; CalType: CALTYPE): BOOL;\r\nbegin\r\n GetProcedureAddress(Pointer(@_EnumCalendarInfoExW), kernel32, 'EnumCalendarInfoExW');\r\n Result := _EnumCalendarInfoExW(lpCalInfoEnumProcEx, Locale, Calendar, CalType);\r\nend;\r\n\r\n\r\ntype\r\n TGetWindowLongPtr = function (hWnd: HWND; nIndex: Integer): TJclAddr; stdcall;\r\n\r\nvar\r\n _GetWindowLongPtr: TGetWindowLongPtr = nil;\r\n\r\nfunction GetWindowLongPtr(hWnd: HWND; nIndex: Integer): TJclAddr;\r\nbegin\r\n GetProcedureAddress(Pointer(@_GetWindowLongPtr), user32, 'GetWindowLong' + AWSuffix);\r\n Result := _GetWindowLongPtr(hWnd, nIndex);\r\nend;\r\n\r\ntype\r\n TSetWindowLongPtr = function (hWnd: HWND; nIndex: Integer; dwNewLong: TJclAddr): Longint; stdcall;\r\n\r\nvar\r\n _SetWindowLongPtr: TSetWindowLongPtr = nil;\r\n\r\nfunction SetWindowLongPtr(hWnd: HWND; nIndex: Integer; dwNewLong: TJclAddr): Longint;\r\nbegin\r\n GetProcedureAddress(Pointer(@_SetWindowLongPtr), user32, 'SetWindowLong' + AWSuffix);\r\n Result := _SetWindowLongPtr(hWnd, nIndex, dwNewLong);\r\nend;\r\n\r\n\r\n// line 9078\r\n\r\nfunction MAKELANGID(PrimaryLang, SubLang: USHORT): WORD;\r\nbegin\r\n Result := (SubLang shl 10) or PrimaryLang;\r\nend;\r\n\r\nfunction PRIMARYLANGID(LangId: WORD): WORD;\r\nbegin\r\n Result := LangId and $03FF;\r\nend;\r\n\r\nfunction SUBLANGID(LangId: WORD): WORD;\r\nbegin\r\n Result := LangId shr 10;\r\nend;\r\n\r\nfunction MAKELCID(LangId, SortId: WORD): DWORD;\r\nbegin\r\n Result := (DWORD(SortId) shl 16) or DWORD(LangId);\r\nend;\r\n\r\nfunction MAKESORTLCID(LangId, SortId, SortVersion: WORD): DWORD;\r\nbegin\r\n Result := MAKELCID(LangId, SortId) or (SortVersion shl 20);\r\nend;\r\n\r\nfunction LANGIDFROMLCID(LocaleId: LCID): WORD;\r\nbegin\r\n Result := WORD(LocaleId);\r\nend;\r\n\r\nfunction SORTIDFROMLCID(LocaleId: LCID): WORD;\r\nbegin\r\n Result := WORD((DWORD(LocaleId) shr 16) and $000F);\r\nend;\r\n\r\nfunction SORTVERSIONFROMLCID(LocaleId: LCID): WORD;\r\nbegin\r\n Result := WORD((DWORD(LocaleId) shr 20) and $000F);\r\nend;\r\n\r\ntype\r\n TCaptureStackBackTrace = function(FramesToSkip, FramesToCapture: DWORD;\r\n BackTrace: Pointer; out BackTraceHash: DWORD): Word; stdcall;\r\n\r\nvar\r\n _CaptureStackBackTrace: TCaptureStackBackTrace = nil;\r\n\r\nfunction CaptureStackBackTrace(FramesToSkip, FramesToCapture: DWORD;\r\n BackTrace: Pointer; out BackTraceHash: DWORD): Word; stdcall;\r\nbegin\r\n GetProcedureAddress(Pointer(@_CaptureStackBackTrace), kernel32, 'RtlCaptureStackBackTrace');\r\n Result := _CaptureStackBackTrace(FramesToSkip, FramesToCapture, BackTrace, BackTraceHash);\r\nend;\r\n\r\n// line 9149\r\n\r\nfunction IsReparseTagMicrosoft(Tag: ULONG): Boolean;\r\nbegin\r\n Result := (Tag and ULONG($80000000)) <> 0;\r\nend;\r\n\r\nfunction IsReparseTagHighLatency(Tag: ULONG): Boolean;\r\nbegin\r\n Result := (Tag and ULONG($40000000)) <> 0;\r\nend;\r\n\r\nfunction IsReparseTagNameSurrogate(Tag: ULONG): Boolean;\r\nbegin\r\n Result := (Tag and ULONG($20000000)) <> 0;\r\nend;\r\n\r\n// IMAGE_FIRST_SECTION by Nico Bendlin - supplied by Markus Fuchs\r\n\r\nfunction IMAGE_FIRST_SECTION(NtHeader: PImageNtHeaders): PImageSectionHeader;\r\nvar\r\n OptionalHeaderAddr: PByte;\r\nbegin\r\n OptionalHeaderAddr := @NtHeader^.OptionalHeader;\r\n Inc(OptionalHeaderAddr, NtHeader^.FileHeader.SizeOfOptionalHeader);\r\n Result := PImageSectionHeader(OptionalHeaderAddr);\r\nend;\r\n\r\n// line 9204\r\n\r\nfunction IMAGE_ORDINAL64(Ordinal: ULONGLONG): ULONGLONG;\r\nbegin\r\n Result := (Ordinal and $FFFF);\r\nend;\r\n\r\nfunction IMAGE_ORDINAL32(Ordinal: DWORD): DWORD;\r\nbegin\r\n Result := (Ordinal and $0000FFFF);\r\nend;\r\n\r\nfunction IMAGE_ORDINAL(Ordinal: DWORD): DWORD;\r\nbegin\r\n Result := (Ordinal and $0000FFFF);\r\nend;\r\n\r\nfunction IMAGE_SNAP_BY_ORDINAL64(Ordinal: ULONGLONG): Boolean;\r\nbegin\r\n Result := ((Ordinal and IMAGE_ORDINAL_FLAG64) <> 0);\r\nend;\r\n\r\nfunction IMAGE_SNAP_BY_ORDINAL32(Ordinal: DWORD): Boolean;\r\nbegin\r\n Result := ((Ordinal and IMAGE_ORDINAL_FLAG32) <> 0);\r\nend;\r\n\r\nfunction IMAGE_SNAP_BY_ORDINAL(Ordinal: DWORD): Boolean;\r\nbegin\r\n Result := ((Ordinal and IMAGE_ORDINAL_FLAG32) <> 0);\r\nend;\r\n\r\nconst\r\n PowrprofLib = 'PowrProf.dll';\r\n \r\ntype\r\n TIsPwrSuspendAllowed = function : BOOL; stdcall;\r\n\r\nvar\r\n _IsPwrSuspendAllowed: TIsPwrSuspendAllowed = nil;\r\n\r\nfunction IsPwrSuspendAllowed: BOOL;\r\nbegin\r\n GetProcedureAddress(Pointer(@_IsPwrSuspendAllowed), PowrprofLib, 'IsPwrSuspendAllowed');\r\n Result := _IsPwrSuspendAllowed;\r\nend;\r\n\r\ntype\r\n TIsPwrHibernateAllowed = function : BOOL; stdcall;\r\n\r\nvar\r\n _IsPwrHibernateAllowed: TIsPwrHibernateAllowed = nil;\r\n\r\nfunction IsPwrHibernateAllowed: BOOL;\r\nbegin\r\n GetProcedureAddress(Pointer(@_IsPwrHibernateAllowed), PowrprofLib, 'IsPwrHibernateAllowed');\r\n Result := _IsPwrHibernateAllowed;\r\nend;\r\n\r\ntype\r\n TIsPwrShutdownAllowed = function : BOOL; stdcall;\r\n\r\nvar\r\n _IsPwrShutdownAllowed: TIsPwrShutdownAllowed = nil;\r\n\r\nfunction IsPwrShutdownAllowed: BOOL;\r\nbegin\r\n GetProcedureAddress(Pointer(@_IsPwrShutdownAllowed), PowrprofLib, 'IsPwrShutdownAllowed');\r\n Result := _IsPwrShutdownAllowed;\r\nend;\r\n\r\ntype\r\n TSetSuspendState = function (Hibernate, ForceCritical, DisableWakeEvent: BOOL): BOOL; stdcall;\r\n\r\nvar\r\n _SetSuspendState: TSetSuspendState = nil;\r\n\r\nfunction SetSuspendState(Hibernate, ForceCritical, DisableWakeEvent: BOOL): BOOL;\r\nbegin\r\n GetProcedureAddress(Pointer(@_SetSuspendState), PowrprofLib, 'SetSuspendState');\r\n Result := _SetSuspendState(Hibernate, ForceCritical, DisableWakeEvent);\r\nend;\r\n\r\n\r\nconst\r\n Ole32Lib = 'ole32.dll';\r\n\r\ntype\r\n TStgCreateStorageEx = function (const pwcsName: PWideChar; grfMode: DWORD;\r\n stgfmt: DWORD; grfAttrs: DWORD; pStgOptions: PSTGOPTIONS; reserved2: Pointer;\r\n riid: PGUID; out stgOpen: IInterface): HResult; stdcall;\r\n \r\nvar\r\n _StgCreateStorageEx: TStgCreateStorageEx = nil;\r\n\r\nfunction StgCreateStorageEx(const pwcsName: PWideChar; grfMode: DWORD;\r\n stgfmt: DWORD; grfAttrs: DWORD; pStgOptions: PSTGOPTIONS; reserved2: Pointer;\r\n riid: PGUID; out stgOpen: IInterface): HResult;\r\nbegin\r\n GetProcedureAddress(Pointer(@_StgCreateStorageEx), Ole32Lib, 'StgCreateStorageEx');\r\n Result := _StgCreateStorageEx(pwcsName, grfMode, stgfmt, grfAttrs, pStgOptions, reserved2, riid, stgOpen);\r\nend;\r\n\r\ntype\r\n TStgOpenStorageEx = function (const pwcsName: PWideChar; grfMode: DWORD;\r\n stgfmt: DWORD; grfAttrs: DWORD; pStgOptions: PSTGOPTIONS; reserved2: Pointer;\r\n riid: PGUID; out stgOpen: IInterface): HResult; stdcall;\r\n\r\nvar\r\n _StgOpenStorageEx: TStgOpenStorageEx = nil;\r\n\r\nfunction StgOpenStorageEx(const pwcsName: PWideChar; grfMode: DWORD;\r\n stgfmt: DWORD; grfAttrs: DWORD; pStgOptions: PSTGOPTIONS; reserved2: Pointer;\r\n riid: PGUID; out stgOpen: IInterface): HResult;\r\nbegin\r\n GetProcedureAddress(Pointer(@_StgOpenStorageEx), Ole32Lib, 'StgOpenStorageEx');\r\n Result := _StgOpenStorageEx(pwcsName, grfMode, stgfmt, grfAttrs, pStgOptions, reserved2, riid, stgOpen);\r\nend;\r\n\r\n\r\ntype\r\n TPropVariantClear = function (var Prop: TPropVariant): HResult; stdcall;\r\n\r\nvar\r\n _PropVariantClear: TPropVariantClear = nil;\r\n\r\nfunction PropVariantClear(var Prop: TPropVariant): HResult;\r\nbegin\r\n GetProcedureAddress(Pointer(@_PropVariantClear), Ole32Lib, 'PropVariantClear');\r\n Result := _PropVariantClear(Prop);\r\nend;\r\n\r\n\r\ntype\r\n TLsaOpenPolicy = function (SystemName: PLSA_UNICODE_STRING;\r\n var ObjectAttributes: LSA_OBJECT_ATTRIBUTES; DesiredAccess: ACCESS_MASK;\r\n var PolicyHandle: LSA_HANDLE): NTSTATUS; stdcall;\r\n\r\nvar\r\n _LsaOpenPolicy: TLsaOpenPolicy = nil;\r\n\r\nfunction LsaOpenPolicy(SystemName: PLSA_UNICODE_STRING;\r\n var ObjectAttributes: LSA_OBJECT_ATTRIBUTES; DesiredAccess: ACCESS_MASK;\r\n var PolicyHandle: LSA_HANDLE): NTSTATUS;\r\nbegin\r\n GetProcedureAddress(Pointer(@_LsaOpenPolicy), advapi32, 'LsaOpenPolicy');\r\n Result := _LsaOpenPolicy(SystemName, ObjectAttributes, DesiredAccess, PolicyHandle);\r\nend;\r\n\r\ntype\r\n TLsaQueryInformationPolicy = function (PolicyHandle: LSA_HANDLE;\r\n InformationClass: POLICY_INFORMATION_CLASS; var Buffer: Pointer): NTSTATUS; stdcall;\r\n\r\nvar\r\n _LsaQueryInformationPolicy: TLsaQueryInformationPolicy = nil;\r\n\r\nfunction LsaQueryInformationPolicy(PolicyHandle: LSA_HANDLE;\r\n InformationClass: POLICY_INFORMATION_CLASS; var Buffer: Pointer): NTSTATUS;\r\nbegin\r\n GetProcedureAddress(Pointer(@_LsaQueryInformationPolicy), advapi32, 'LsaQueryInformationPolicy');\r\n Result := _LsaQueryInformationPolicy(PolicyHandle, InformationClass, Buffer);\r\nend;\r\n\r\ntype\r\n TLsaFreeMemory = function (Buffer: Pointer): NTSTATUS; stdcall;\r\n\r\nvar\r\n _LsaFreeMemory: TLsaFreeMemory = nil;\r\n\r\nfunction LsaFreeMemory(Buffer: Pointer): NTSTATUS;\r\nbegin\r\n GetProcedureAddress(Pointer(@_LsaFreeMemory), advapi32, 'LsaFreeMemory');\r\n Result := _LsaFreeMemory(Buffer);\r\nend;\r\n\r\ntype\r\n TLsaFreeReturnBuffer = function (Buffer: Pointer): NTSTATUS; stdcall;\r\n\r\nvar\r\n _LsaFreeReturnBuffer: TLsaFreeReturnBuffer = nil;\r\n\r\nfunction LsaFreeReturnBuffer(Buffer: Pointer): NTSTATUS;\r\nbegin\r\n GetProcedureAddress(Pointer(@_LsaFreeReturnBuffer), advapi32, 'LsaFreeReturnBuffer');\r\n Result := _LsaFreeReturnBuffer(Buffer);\r\nend;\r\n\r\ntype\r\n TLsaClose = function (ObjectHandle: LSA_HANDLE): NTSTATUS; stdcall;\r\n\r\nvar\r\n _LsaClose: TLsaClose = nil;\r\n\r\nfunction LsaClose(ObjectHandle: LSA_HANDLE): NTSTATUS;\r\nbegin\r\n GetProcedureAddress(Pointer(@_LsaClose), advapi32, 'LsaClose');\r\n Result := _LsaClose(ObjectHandle);\r\nend;\r\n\r\ntype\r\n TLsaNtStatusToWinError = function (Status: NTSTATUS): ULONG; stdcall;\r\n\r\nvar\r\n _LsaNtStatusToWinError: TLsaNtStatusToWinError = nil;\r\n\r\nfunction LsaNtStatusToWinError(Status: NTSTATUS): ULONG;\r\nbegin\r\n GetProcedureAddress(Pointer(@_LsaNtStatusToWinError), advapi32, 'LsaNtStatusToWinError');\r\n Result := _LsaNtStatusToWinError(Status);\r\nend;\r\n\r\n\r\ntype\r\n TCreateToolhelp32Snapshot = function (dwFlags, th32ProcessID: DWORD): THandle; stdcall;\r\n\r\nvar\r\n _CreateToolhelp32Snapshot: TCreateToolhelp32Snapshot = nil;\r\n\r\nfunction CreateToolhelp32Snapshot(dwFlags, th32ProcessID: DWORD): THandle;\r\nbegin\r\n GetProcedureAddress(Pointer(@_CreateToolhelp32Snapshot), kernel32, 'CreateToolhelp32Snapshot');\r\n Result := _CreateToolhelp32Snapshot(dwFlags, th32ProcessID);\r\nend;\r\n\r\ntype\r\n TThread32First = function (hSnapshot: THandle; var lpte: THREADENTRY32): BOOL; stdcall;\r\n\r\nvar\r\n _Thread32First: TThread32First = nil;\r\n\r\nfunction Thread32First(hSnapshot: THandle; var lpte: THREADENTRY32): BOOL;\r\nbegin\r\n GetProcedureAddress(Pointer(@_Thread32First), kernel32, 'Thread32First');\r\n Result := _Thread32First(hSnapshot, lpte);\r\nend;\r\n\r\ntype\r\n TThread32Next = function (hSnapshot: THandle; var lpte: THREADENTRY32): BOOL; stdcall;\r\n\r\nvar\r\n _Thread32Next: TThread32Next = nil;\r\n\r\nfunction Thread32Next(hSnapshot: THandle; var lpte: THREADENTRY32): BOOL;\r\nbegin\r\n GetProcedureAddress(Pointer(@_Thread32Next), kernel32, 'Thread32Next');\r\n Result := _Thread32Next(hSnapshot, lpte);\r\nend;\r\n\r\n\r\nconst\r\n ntdll = 'ntdll.dll';\r\n\r\ntype\r\n TNtQueryInformationThread = function (ThreadHandle: THandle; ThreadInformationClass: THREAD_INFORMATION_CLASS;\r\n ThreadInformation: Pointer; ThreadInformationLength: ULONG; ReturnLength: PULONG): NTSTATUS; stdcall;\r\n\r\nvar\r\n _NtQueryInformationThread: TNtQueryInformationThread = nil;\r\n\r\nfunction NtQueryInformationThread(ThreadHandle: THandle; ThreadInformationClass: THREAD_INFORMATION_CLASS;\r\n ThreadInformation: Pointer; ThreadInformationLength: ULONG; ReturnLength: PULONG): NTSTATUS;\r\nbegin\r\n GetProcedureAddress(Pointer(@_NtQueryInformationThread), ntdll, 'NtQueryInformationThread');\r\n Result := _NtQueryInformationThread(ThreadHandle, ThreadInformationClass, ThreadInformation, ThreadInformationLength, ReturnLength);\r\nend;\r\n\r\n\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n\r\n\r\n\r\n" }, { "path": "External/Jedi/Jcl/source/windows/JclWin32Ex.pas", "content": "{**************************************************************************************************}\r\n{ }\r\n{ Project JEDI Code Library (JCL) }\r\n{ }\r\n{ The contents of this file are subject to the Mozilla Public License Version 1.1 (the \"License\"); }\r\n{ you may not use this file except in compliance with the License. You may obtain a copy of the }\r\n{ License at http://www.mozilla.org/MPL/ }\r\n{ }\r\n{ Software distributed under the License is distributed on an \"AS IS\" basis, WITHOUT WARRANTY OF }\r\n{ ANY KIND, either express or implied. See the License for the specific language governing rights }\r\n{ and limitations under the License. }\r\n{ }\r\n{ The Original Code is JclWin32Ex.pas. }\r\n{ }\r\n{ The Initial Developer of the Original Code is Virgo Prna (virgo dott parna att mail dott ee). }\r\n{ Portions created by Virgo Prna are Copyright (C) 2006 Virgo Prna. All Rights Reserved. }\r\n{ }\r\n{ Contributor(s): }\r\n{ }\r\n{**************************************************************************************************}\r\n{ }\r\n{ Last modified: $Date:: 2011-09-03 00:07:50 +0200 (sam. 03 sept. 2011) $ }\r\n{ Revision: $Rev:: 3599 $ }\r\n{ Author: $Author:: outchy $ }\r\n{ }\r\n{**************************************************************************************************}\r\n\r\nunit JclWin32Ex;\r\n\r\n{$I jcl.inc}\r\n{$I windowsonly.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n {$IFDEF HAS_UNITSCOPE}\r\n Winapi.Windows, System.SysUtils;\r\n {$ELSE ~HAS_UNITSCOPE}\r\n Windows, SysUtils;\r\n {$ENDIF ~HAS_UNITSCOPE}\r\n\r\ntype\r\n TJclWin32ExFunction = (jwfTryEnterCriticalSection, jwfSignalObjectAndWait,\r\n jwfSetCriticalSectionSpinCount, jwfOpenWaitableTimer,\r\n jwfInitializeCriticalSectionAndSpinCount, jwfGetFileAttributesEx,\r\n jwfCreateWaitableTimer, jwfCancelWaitableTimer, jwfglGetString,\r\n jwfglGetError, jwfwglCreateContext, jwfwglDeleteContext, jwfwglMakeCurrent,\r\n jwfgluErrorString);\r\n TJclWin32ExFunctions = set of TJclWin32ExFunction;\r\n\r\nfunction JclTryEnterCriticalSection(lpCriticalSection: TRTLCriticalSection): Boolean;\r\nfunction JclSignalObjectAndWait(hObjectToSignal: THandle;\r\n hObjectToWaitOn: THandle; dwMilliseconds: Cardinal;\r\n bAlertable: Boolean): Cardinal;\r\nfunction JclSetCriticalSectionSpinCount(lpCriticalSection: TRTLCriticalSection;\r\n dwSpinCount: Cardinal): Cardinal;\r\nfunction JclOpenWaitableTimer(dwDesiredAccess: Cardinal;\r\n bInheritHandle: Boolean; const lpTimerName: string): THandle;\r\nfunction JclInitializeCriticalSectionAndSpinCount(lpCriticalSection: TRTLCriticalSection;\r\n dwSpinCount: Cardinal): Boolean;\r\nfunction JclGetFileAttributesEx(const lpFileName: string;\r\n fInfoLevelId: TGetFileExInfoLevels; lpFileInformation: Pointer): Boolean;\r\nfunction JclCreateWaitableTimer(lpTimerAttributes: PSecurityAttributes;\r\n bManualReset: Boolean; const lpTimerName: AnsiString): THandle;\r\nfunction JclCancelWaitableTimer(hTimer: THandle): Boolean;\r\n\r\nfunction JclglGetString(name: Cardinal): PChar;\r\nfunction JclglGetError: Cardinal;\r\n\r\nfunction JclwglCreateContext(hdc: HDC): HGLRC;\r\nfunction JclwglDeleteContext(hglrc: HGLRC): BOOL;\r\nfunction JclwglMakeCurrent(hdc: HDC; hglrc: HGLRC): BOOL;\r\n\r\nfunction JclgluErrorString(errCode: Cardinal): PChar;\r\n\r\nfunction JclWin32ExFunctions: TJclWin32ExFunctions;\r\n\r\nprocedure JclCheckAndInitializeOpenGL;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jcl.svn.sourceforge.net/svnroot/jcl/tags/JCL-2.4-Build4571/jcl/source/windows/JclWin32Ex.pas $';\r\n Revision: '$Revision: 3599 $';\r\n Date: '$Date: 2011-09-03 00:07:50 +0200 (sam. 03 sept. 2011) $';\r\n LogPath: 'JCL\\source\\windows';\r\n Extra: '';\r\n Data: nil\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n JclBase, JclResources;\r\n\r\ntype\r\n TTryEnterCriticalSectionProc = function(lpCriticalSection: TRTLCriticalSection): BOOL; stdcall;\r\n TSignalObjectAndWaitProc = function(hObjectToSignal: THandle;\r\n hObjectToWaitOn: THandle; dwMilliseconds: DWORD; bAlertable: BOOL): DWORD; stdcall;\r\n TSetCriticalSectionSpinCountProc = function(lpCriticalSection: TRTLCriticalSection;\r\n dwSpincCount: DWORD): DWORD; stdcall;\r\n TInitializeCriticalSectionAndSpinCountProc = function(lpCriticalSection: TRTLCriticalSection;\r\n dwSpinCount: DWORD): BOOL; stdcall;\r\n\r\n TOpenWaitableTimerAProc = function(dwDesiredAccess: DWORD;\r\n bInheritHandle: BOOL; lpTimerName: LPCTSTR): THandle; stdcall;\r\n TCreateWaitableTimerAProc = function(lpTimerAttributes: PSecurityAttributes;\r\n bManualReset: BOOL; lpTimerName: PAnsiChar): THandle; stdcall;\r\n TCancelWaitableTimerProc = function(hTimer: THandle): BOOL; stdcall;\r\n\r\n TGetFileAttributesExAProc = function(lpFileName: PChar;\r\n fInfoLevelId: TGetFileExInfoLevels; lpFileInformation: Pointer): BOOL; stdcall;\r\n\r\n TglGetStringProc = function(name: Cardinal): PChar; stdcall;\r\n TglGetErrorProc = function: Cardinal; stdcall;\r\n\r\n TwglCreateContextProc = function (hdc: HDC): HGLRC; stdcall;\r\n TwglDeleteContextProc = function (hglrc: HGLRC): BOOL; stdcall;\r\n TwglMakeCurrentProc = function (hdc: HDC; hglrc: HGLRC): BOOL; stdcall;\r\n\r\n TgluErrorStringProc = function(errCode: Cardinal): PChar; stdcall;\r\n\r\nvar\r\n Kernel32DllHandle: HMODULE = 0;\r\n OpenGl32DllHandle: HMODULE = 0;\r\n Glu32DllHandle: HMODULE = 0;\r\n\r\ntype\r\n TDllFunctionRec = record\r\n FunctionName: string;\r\n FunctionAddr: Pointer;\r\n DllName: string;\r\n DllHandle: ^HModule;\r\n end;\r\n\r\nconst\r\n Glu32 = 'glu32.dll';\r\n\r\nvar\r\n Win32ExFunctions: array [TJclWin32ExFunction] of TDllFunctionRec =\r\n ( // jwfTryEnterCriticalSection\r\n (FunctionName: 'TryEnterCriticalSection'; FunctionAddr: nil;\r\n DllName: kernel32; DllHandle: @Kernel32DllHandle),\r\n // jwfSignalObjectAndWait\r\n (FunctionName: 'SignalObjectAndWait'; FunctionAddr: nil;\r\n DllName: kernel32; DllHandle: @Kernel32DllHandle),\r\n // jwfSetCriticalSectionSpinCount\r\n (FunctionName: 'SetCriticalSectionSpinCount'; FunctionAddr: nil;\r\n DllName: kernel32; DllHandle: @Kernel32DllHandle),\r\n // jwfOpenWaitableTimer\r\n (FunctionName: 'OpenWaitableTimerA'; FunctionAddr: nil;\r\n DllName: kernel32; DllHandle: @Kernel32DllHandle),\r\n // jwfInitializeCriticalSectionAndSpinCount\r\n (FunctionName: 'InitializeCriticalSectionAndSpinCount'; FunctionAddr: nil;\r\n DllName: kernel32; DllHandle: @Kernel32DllHandle),\r\n // jwfGetFileAttributesEx\r\n (FunctionName: 'GetFileAttributesExA'; FunctionAddr: nil;\r\n DllName: kernel32; DllHandle: @Kernel32DllHandle),\r\n // jwfCreateWaitableTimer\r\n (FunctionName: 'CreateWaitableTimerA'; FunctionAddr: nil;\r\n DllName: kernel32; DllHandle: @Kernel32DllHandle),\r\n // jwfCancelWaitableTimer\r\n (FunctionName: 'CancelWaitableTimer'; FunctionAddr: nil;\r\n DllName: kernel32; DllHandle: @Kernel32DllHandle),\r\n // jwfglGetString\r\n (FunctionName: 'glGetString'; FunctionAddr: nil;\r\n DllName: opengl32; DllHandle: @OpenGl32DllHandle),\r\n // jwfglGetError\r\n (FunctionName: 'glGetError'; FunctionAddr: nil;\r\n DllName: opengl32; DllHandle: @OpenGl32DllHandle),\r\n // jwfwglCreateContext\r\n (FunctionName: 'wglCreateContext'; FunctionAddr: nil;\r\n DllName: opengl32; DllHandle: @OpenGl32DllHandle),\r\n // jwfwglDeleteContext\r\n (FunctionName: 'wglDeleteContext'; FunctionAddr: nil;\r\n DllName: opengl32; DllHandle: @OpenGl32DllHandle),\r\n // jwfwglMakeCurrent\r\n (FunctionName: 'wglMakeCurrent'; FunctionAddr: nil;\r\n DllName: opengl32; DllHandle: @OpenGl32DllHandle),\r\n // jwfgluErrorString\r\n (FunctionName: 'gluErrorString'; FunctionAddr: nil;\r\n DllName: Glu32; DllHandle: @Glu32DllHandle)\r\n );\r\n\r\nfunction LoadWin32ExFunction(const Win32ExFunction: TJclWin32ExFunction): Pointer;\r\nbegin\r\n with Win32ExFunctions[Win32ExFunction] do\r\n begin\r\n if not Assigned(FunctionAddr) then\r\n begin\r\n if DllHandle^ = 0 then\r\n DllHandle^ := SafeLoadLibrary(DllName);\r\n if DllHandle^ = 0 then\r\n raise EJclError.CreateResFmt(@RsELibraryNotFound, [DllName])\r\n else\r\n FunctionAddr := GetProcAddress(DllHandle^, PChar(FunctionName));\r\n if not Assigned(FunctionAddr) then\r\n raise EJclError.CreateResFmt(@RsEFunctionNotFound, [DllName, FunctionName]);\r\n end;\r\n Result := FunctionAddr;\r\n end;\r\nend;\r\n\r\nfunction JclTryEnterCriticalSection(lpCriticalSection: TRTLCriticalSection): Boolean;\r\nvar\r\n FunctionAddr: Pointer;\r\nbegin\r\n FunctionAddr := Win32ExFunctions[jwfTryEnterCriticalSection].FunctionAddr;\r\n if not Assigned(FunctionAddr) then\r\n FunctionAddr := LoadWin32ExFunction(jwfTryEnterCriticalSection);\r\n\r\n Result := TTryEnterCriticalSectionProc(FunctionAddr)(lpCriticalSection);\r\nend;\r\n\r\nfunction JclSignalObjectAndWait(hObjectToSignal: THandle; hObjectToWaitOn: THandle; dwMilliseconds: Cardinal; bAlertable: Boolean): Cardinal;\r\nvar\r\n FunctionAddr: Pointer;\r\nbegin\r\n FunctionAddr := Win32ExFunctions[jwfSignalObjectAndWait].FunctionAddr;\r\n if not Assigned(FunctionAddr) then\r\n FunctionAddr := LoadWin32ExFunction(jwfSignalObjectAndWait);\r\n\r\n Result := TSignalObjectAndWaitProc(FunctionAddr)(hObjectToSignal, hObjectToWaitOn, dwMilliseconds, bAlertable);\r\nend;\r\n\r\nfunction JclSetCriticalSectionSpinCount(lpCriticalSection: TRTLCriticalSection; dwSpinCount: Cardinal): Cardinal;\r\nvar\r\n FunctionAddr: Pointer;\r\nbegin\r\n FunctionAddr := Win32ExFunctions[jwfSetCriticalSectionSpinCount].FunctionAddr;\r\n if not Assigned(FunctionAddr) then\r\n FunctionAddr := LoadWin32ExFunction(jwfSetCriticalSectionSpinCount);\r\n\r\n Result := TSetCriticalSectionSpinCountProc(FunctionAddr)(lpCriticalSection, dwSpinCount);\r\nend;\r\n\r\nfunction JclOpenWaitableTimer(dwDesiredAccess: Cardinal; bInheritHandle: Boolean; const lpTimerName: string): THandle;\r\nvar\r\n FunctionAddr: Pointer;\r\nbegin\r\n FunctionAddr := Win32ExFunctions[jwfOpenWaitableTimer].FunctionAddr;\r\n if not Assigned(FunctionAddr) then\r\n FunctionAddr := LoadWin32ExFunction(jwfOpenWaitableTimer);\r\n\r\n Result := TOpenWaitableTimerAProc(FunctionAddr)(dwDesiredAccess, bInheritHandle, PChar(lpTimerName));\r\nend;\r\n\r\nfunction JclInitializeCriticalSectionAndSpinCount(lpCriticalSection: TRTLCriticalSection; dwSpinCount: Cardinal): Boolean;\r\nvar\r\n FunctionAddr: Pointer;\r\nbegin\r\n FunctionAddr := Win32ExFunctions[jwfInitializeCriticalSectionAndSpinCount].FunctionAddr;\r\n if not Assigned(FunctionAddr) then\r\n FunctionAddr := LoadWin32ExFunction(jwfInitializeCriticalSectionAndSpinCount);\r\n\r\n Result := TInitializeCriticalSectionAndSpinCountProc(FunctionAddr)(lpCriticalSection, dwSpinCount);\r\nend;\r\n\r\nfunction JclGetFileAttributesEx(const lpFileName: string; fInfoLevelId: TGetFileExInfoLevels; lpFileInformation: Pointer): Boolean;\r\nvar\r\n FunctionAddr: Pointer;\r\nbegin\r\n FunctionAddr := Win32ExFunctions[jwfGetFileAttributesEx].FunctionAddr;\r\n if not Assigned(FunctionAddr) then\r\n FunctionAddr := LoadWin32ExFunction(jwfGetFileAttributesEx);\r\n\r\n Result := TGetFileAttributesExAProc(FunctionAddr)(PChar(lpFileName), fInfoLevelId, lpFileInformation);\r\nend;\r\n\r\nfunction JclCreateWaitableTimer(lpTimerAttributes: PSecurityAttributes; bManualReset: Boolean; const lpTimerName: AnsiString): THandle;\r\nvar\r\n FunctionAddr: Pointer;\r\nbegin\r\n FunctionAddr := Win32ExFunctions[jwfCreateWaitableTimer].FunctionAddr;\r\n if not Assigned(FunctionAddr) then\r\n FunctionAddr := LoadWin32ExFunction(jwfCreateWaitableTimer);\r\n\r\n Result := TCreateWaitableTimerAProc(FunctionAddr)(lpTimerAttributes, bManualReset, PAnsiChar(lpTimerName));\r\nend;\r\n\r\nfunction JclCancelWaitableTimer(hTimer: THandle): Boolean;\r\nvar\r\n FunctionAddr: Pointer;\r\nbegin\r\n FunctionAddr := Win32ExFunctions[jwfCancelWaitableTimer].FunctionAddr;\r\n if not Assigned(FunctionAddr) then\r\n FunctionAddr := LoadWin32ExFunction(jwfCancelWaitableTimer);\r\n\r\n Result := TCancelWaitableTimerProc(FunctionAddr)(hTimer);\r\nend;\r\n\r\nfunction JclglGetString(name: Cardinal): PChar;\r\nvar\r\n FunctionAddr: Pointer;\r\nbegin\r\n FunctionAddr := Win32ExFunctions[jwfglGetString].FunctionAddr;\r\n if not Assigned(FunctionAddr) then\r\n FunctionAddr := LoadWin32ExFunction(jwfglGetString);\r\n\r\n Result := TglGetStringProc(FunctionAddr)(name);\r\nend;\r\n\r\nfunction JclglGetError: Cardinal;\r\nvar\r\n FunctionAddr: Pointer;\r\nbegin\r\n FunctionAddr := Win32ExFunctions[jwfglGetError].FunctionAddr;\r\n if not Assigned(FunctionAddr) then\r\n FunctionAddr := LoadWin32ExFunction(jwfglGetError);\r\n\r\n Result := TglGetErrorProc(FunctionAddr);\r\nend;\r\n\r\nfunction JclwglCreateContext(hdc: HDC): HGLRC;\r\nvar\r\n FunctionAddr: Pointer;\r\nbegin\r\n FunctionAddr := Win32ExFunctions[jwfwglCreateContext].FunctionAddr;\r\n if not Assigned(FunctionAddr) then\r\n FunctionAddr := LoadWin32ExFunction(jwfwglCreateContext);\r\n\r\n Result := TwglCreateContextProc(FunctionAddr)(hdc);\r\nend;\r\n\r\nfunction JclwglDeleteContext(hglrc: HGLRC): BOOL;\r\nvar\r\n FunctionAddr: Pointer;\r\nbegin\r\n FunctionAddr := Win32ExFunctions[jwfwglDeleteContext].FunctionAddr;\r\n if not Assigned(FunctionAddr) then\r\n FunctionAddr := LoadWin32ExFunction(jwfwglDeleteContext);\r\n\r\n Result := TwglDeleteContextProc(FunctionAddr)(hglrc);\r\nend;\r\n\r\nfunction JclwglMakeCurrent(hdc: HDC; hglrc: HGLRC): BOOL;\r\nvar\r\n FunctionAddr: Pointer;\r\nbegin\r\n FunctionAddr := Win32ExFunctions[jwfwglMakeCurrent].FunctionAddr;\r\n if not Assigned(FunctionAddr) then\r\n FunctionAddr := LoadWin32ExFunction(jwfwglMakeCurrent);\r\n\r\n Result := TwglMakeCurrentProc(FunctionAddr)(hdc, hglrc);\r\nend;\r\n\r\nfunction JclgluErrorString(errCode: Cardinal): PChar;\r\nvar\r\n FunctionAddr: Pointer;\r\nbegin\r\n FunctionAddr := Win32ExFunctions[jwfgluErrorString].FunctionAddr;\r\n if not Assigned(FunctionAddr) then\r\n FunctionAddr := LoadWin32ExFunction(jwfgluErrorString);\r\n\r\n Result := TgluErrorStringProc(FunctionAddr)(errCode);\r\nend;\r\n\r\nfunction JclWin32ExFunctions: TJclWin32ExFunctions;\r\nvar\r\n Index: TJclWin32ExFunction;\r\nbegin\r\n Result := [];\r\n for Index := Low(TJclWin32ExFunction) to High(TJclWin32ExFunction) do\r\n if Assigned(Win32ExFunctions[Index].FunctionAddr)\r\n or (LoadWin32ExFunction(Index) <> nil) then\r\n Include(Result, Index);\r\nend;\r\n\r\nprocedure UnloadLibraries;\r\nvar\r\n Index: TJclWin32ExFunction;\r\nbegin\r\n for Index := Low(TJclWin32ExFunction) to High(TJclWin32ExFunction) do\r\n with Win32ExFunctions[Index] do\r\n begin\r\n FunctionAddr := nil;\r\n if DllHandle^ <> 0 then\r\n begin\r\n FreeLibrary(DllHandle^);\r\n DllHandle^ := 0;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure JclCheckAndInitializeOpenGL;\r\nbegin\r\n if OpenGl32DllHandle = 0 then\r\n OpenGl32DllHandle := SafeLoadLibrary(opengl32);\r\n if OpenGl32DllHandle = 0 then\r\n raise EJclError.CreateResFmt(@RsELibraryNotFound, [opengl32]);\r\nend;\r\n\r\ninitialization\r\n {$IFDEF UNITVERSIONING}\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n {$ENDIF UNITVERSIONING}\r\n\r\nfinalization\r\n {$IFDEF UNITVERSIONING}\r\n UnregisterUnitVersion(HInstance);\r\n {$ENDIF UNITVERSIONING}\r\n UnloadLibraries;\r\n\r\nend.\r\n\r\n" }, { "path": "External/Jedi/Jcl/source/windows/JclWinMIDI.pas", "content": "{**************************************************************************************************}\r\n{ }\r\n{ Project JEDI Code Library (JCL) }\r\n{ }\r\n{ The contents of this file are subject to the Mozilla Public License Version 1.1 (the \"License\"); }\r\n{ you may not use this file except in compliance with the License. You may obtain a copy of the }\r\n{ License at http://www.mozilla.org/MPL/ }\r\n{ }\r\n{ Software distributed under the License is distributed on an \"AS IS\" basis, WITHOUT WARRANTY OF }\r\n{ ANY KIND, either express or implied. See the License for the specific language governing rights }\r\n{ and limitations under the License. }\r\n{ }\r\n{ The Original Code is JclWinMidi.pas. }\r\n{ }\r\n{ The Initial Developer of the Original Code is Robert Rossmair }\r\n{ Portions created by Robert Rossmair are Copyright (C) Robert Rossmair. All Rights Reserved. }\r\n{ }\r\n{ Contributor(s): }\r\n{ Robert Rossmair }\r\n{ }\r\n{**************************************************************************************************}\r\n{ }\r\n{ MIDI functions for MS Windows platform }\r\n{ }\r\n{**************************************************************************************************}\r\n{ }\r\n{ Last modified: $Date:: 2011-09-03 00:07:50 +0200 (sam. 03 sept. 2011) $ }\r\n{ Revision: $Rev:: 3599 $ }\r\n{ Author: $Author:: outchy $ }\r\n{ }\r\n{**************************************************************************************************}\r\n\r\nunit JclWinMidi;\r\n\r\n{$I jcl.inc}\r\n{$I windowsonly.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n {$IFDEF HAS_UNITSCOPE}\r\n System.SysUtils, System.Classes, Winapi.Windows, Winapi.MMSystem,\r\n {$ELSE ~HAS_UNITSCOPE}\r\n SysUtils, Classes, Windows, MMSystem,\r\n {$ENDIF ~HAS_UNITSCOPE}\r\n JclMIDI;\r\n\r\ntype\r\n TStereoChannel = (scLeft, scRight);\r\n \r\n // MIDI Out\r\n IJclWinMidiOut = interface(IJclMidiOut)\r\n ['{F3FCE71C-B924-462C-BA0D-8C2DC118DADB}']\r\n // property access methods\r\n function GetChannelVolume(Channel: TStereoChannel): Word;\r\n procedure SetChannelVolume(Channel: TStereoChannel; const Value: Word);\r\n function GetVolume: Word;\r\n procedure SetVolume(const Value: Word);\r\n // properties\r\n property ChannelVolume[Channel: TStereoChannel]: Word read GetChannelVolume write SetChannelVolume;\r\n property Volume: Word read GetVolume write SetVolume;\r\n end;\r\n\r\ntype\r\n TJclWinMidiOut = class(TJclMidiOut, IJclWinMidiOut)\r\n private\r\n FHandle: HMIDIOUT;\r\n FDeviceID: Cardinal;\r\n FDeviceCaps: MIDIOUTCAPS;\r\n FVolume: DWORD;\r\n procedure SetLRVolume(const LeftValue, RightValue: Word);\r\n protected\r\n procedure LongMessage(const Data: array of Byte);\r\n procedure DoSendMessage(const Data: array of Byte); override;\r\n public\r\n constructor Create(ADeviceID: Cardinal);\r\n destructor Destroy; override;\r\n property DeviceID: Cardinal read FDeviceID;\r\n function GetName: string; override;\r\n property Name: string read GetName;\r\n { IJclWinMidiOut }\r\n function GetChannelVolume(Channel: TStereoChannel): Word;\r\n procedure SetChannelVolume(Channel: TStereoChannel; const Value: Word);\r\n function GetVolume: Word;\r\n procedure SetVolume(const Value: Word);\r\n property ChannelVolume[Channel: TStereoChannel]: Word read GetChannelVolume write SetChannelVolume;\r\n property Volume: Word read GetVolume write SetVolume;\r\n end;\r\n\r\nfunction MidiOut(DeviceID: Cardinal): IJclWinMidiOut;\r\nprocedure GetMidiOutputs(const List: TStrings);\r\nprocedure MidiOutCheck(Code: MMResult);\r\n\r\n// MIDI In\r\nprocedure MidiInCheck(Code: MMResult);\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jcl.svn.sourceforge.net/svnroot/jcl/tags/JCL-2.4-Build4571/jcl/source/windows/JclWinMIDI.pas $';\r\n Revision: '$Revision: 3599 $';\r\n Date: '$Date: 2011-09-03 00:07:50 +0200 (sam. 03 sept. 2011) $';\r\n LogPath: 'JCL\\source\\windows';\r\n Extra: '';\r\n Data: nil\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n JclResources, JclStrings, JclSysUtils;\r\n\r\nvar\r\n FMidiOutputs: TStringList = nil;\r\n\r\nfunction MidiOutputs: TStrings;\r\nvar\r\n I: Integer;\r\n Caps: MIDIOUTCAPS;\r\nbegin\r\n if FMidiOutputs = nil then\r\n begin\r\n FMidiOutputs := TStringList.Create;\r\n for I := 0 to midiOutGetNumDevs - 1 do\r\n if (midiOutGetDevCaps(I, @Caps, SizeOf(Caps)) = MMSYSERR_NOERROR) then\r\n FMidiOutputs.Add(Caps.szPName);\r\n end;\r\n Result := FMidiOutputs;\r\nend;\r\n\r\nprocedure GetMidiOutputs(const List: TStrings);\r\nbegin\r\n List.Assign(MidiOutputs);\r\nend;\r\n\r\nfunction GetMidiInErrorMessage(const ErrorCode: MMRESULT): string;\r\nbegin\r\n SetLength(Result, MAXERRORLENGTH-1);\r\n if midiInGetErrorText(ErrorCode, @Result[1], MAXERRORLENGTH) = MMSYSERR_NOERROR then\r\n StrResetLength(Result)\r\n else\r\n Result := Format(RsMidiInUnknownError, [ErrorCode]);\r\nend;\r\n\r\nfunction GetMidiOutErrorMessage(const ErrorCode: MMRESULT): string;\r\nbegin\r\n SetLength(Result, MAXERRORLENGTH-1);\r\n if midiOutGetErrorText(ErrorCode, @Result[1], MAXERRORLENGTH) = MMSYSERR_NOERROR then\r\n StrResetLength(Result)\r\n else\r\n Result := Format(RsMidiOutUnknownError, [ErrorCode]);\r\nend;\r\n\r\nprocedure MidiInCheck(Code: MMResult);\r\nbegin\r\n if Code <> MMSYSERR_NOERROR then\r\n raise EJclMidiError.Create(GetMidiInErrorMessage(Code));\r\nend;\r\n\r\nprocedure MidiOutCheck(Code: MMResult);\r\nbegin\r\n if Code <> MMSYSERR_NOERROR then\r\n raise EJclMidiError.Create(GetMidiOutErrorMessage(Code));\r\nend;\r\n\r\n//=== { TJclWinMidiOut } =====================================================\r\n\r\nvar\r\n MidiMapperDeviceID: Cardinal = MIDI_MAPPER;\r\n\r\nfunction MidiOut(DeviceID: Cardinal): IJclWinMidiOut;\r\nvar\r\n Device: TJclWinMidiOut;\r\nbegin\r\n if DeviceID = MIDI_MAPPER then\r\n DeviceID := MidiMapperDeviceID;\r\n Device := nil;\r\n if DeviceID <> MIDI_MAPPER then\r\n Device := TJclWinMidiOut(MidiOutputs.Objects[DeviceID]);\r\n // make instance a singleton for a given device ID\r\n if not Assigned(Device) then\r\n begin\r\n Device := TJclWinMidiOut.Create(DeviceID);\r\n if DeviceID = MIDI_MAPPER then\r\n MidiMapperDeviceID := Device.DeviceID;\r\n // cannot use DeviceID argument as index here, since it might be MIDI_MAPPER\r\n MidiOutputs.Objects[Device.DeviceID] := Device;\r\n end;\r\n Result := Device;\r\nend;\r\n\r\nconstructor TJclWinMidiOut.Create(ADeviceID: Cardinal);\r\nbegin\r\n inherited Create;\r\n FVolume := $FFFFFFFF; // max. volume, in case Get/SetChannelVolume not supported\r\n MidiOutCheck(midiOutGetDevCaps(ADeviceID, @FDeviceCaps, SizeOf(FDeviceCaps)));\r\n MidiOutCheck(midiOutOpen(@FHandle, ADeviceID, 0, 0, 0));\r\n MidiOutCheck(midiOutGetID(FHandle, @FDeviceID));\r\nend;\r\n\r\ndestructor TJclWinMidiOut.Destroy;\r\nbegin\r\n inherited Destroy;\r\n midiOutClose(FHandle);\r\n MidiOutputs.Objects[FDeviceID] := nil;\r\nend;\r\n\r\nfunction TJclWinMidiOut.GetName: string;\r\nbegin\r\n Result := FDeviceCaps.szPName;\r\nend;\r\n\r\nprocedure TJclWinMidiOut.LongMessage(const Data: array of Byte);\r\nvar\r\n Hdr: MIDIHDR;\r\nbegin\r\n ResetMemory(Hdr, SizeOf(Hdr));\r\n Hdr.dwBufferLength := High(Data) - Low(Data) + 1;;\r\n Hdr.dwBytesRecorded := Hdr.dwBufferLength;\r\n Hdr.lpData := @Data;\r\n Hdr.dwFlags := 0;\r\n MidiOutCheck(midiOutPrepareHeader(FHandle, @Hdr, SizeOf(Hdr)));\r\n MidiOutCheck(midiOutLongMsg(FHandle, @Hdr, SizeOf(Hdr)));\r\n repeat\r\n until (Hdr.dwFlags and MHDR_DONE) <> 0;\r\nend;\r\n\r\nprocedure TJclWinMidiOut.DoSendMessage(const Data: array of Byte);\r\nvar\r\n I: Integer;\r\n Msg: packed record\r\n case Integer of\r\n 0:\r\n (Bytes: array [0..2] of Byte);\r\n 1:\r\n (DWord: LongWord);\r\n end;\r\nbegin\r\n if High(Data) < 3 then\r\n begin\r\n for I := 0 to High(Data) do\r\n Msg.Bytes[I] := Data[I];\r\n MidiOutCheck(midiOutShortMsg(FHandle, Msg.DWord));\r\n end\r\n else\r\n LongMessage(Data);\r\nend;\r\n\r\nfunction TJclWinMidiOut.GetChannelVolume(Channel: TStereoChannel): Word;\r\nbegin\r\n midiOutGetVolume(FHandle, @FVolume);\r\n Result := FVolume;\r\nend;\r\n\r\nprocedure TJclWinMidiOut.SetChannelVolume(Channel: TStereoChannel; const Value: Word);\r\nbegin\r\n if Channel = scLeft then\r\n SetLRVolume(Value, ChannelVolume[scRight])\r\n else\r\n SetLRVolume(ChannelVolume[scLeft], Value);\r\nend;\r\n\r\nfunction TJclWinMidiOut.GetVolume: Word;\r\nbegin\r\n Result := GetChannelVolume(scLeft);\r\nend;\r\n\r\nprocedure TJclWinMidiOut.SetVolume(const Value: Word);\r\nbegin\r\n SetLRVolume(Value, Value);\r\nend;\r\n\r\nprocedure TJclWinMidiOut.SetLRVolume(const LeftValue, RightValue: Word);\r\nvar\r\n Value: DWORD;\r\nbegin\r\n with LongRec(Value) do\r\n begin\r\n Lo := LeftValue;\r\n Hi := RightValue;\r\n end;\r\n if Value <> FVolume then\r\n begin\r\n if (MIDICAPS_VOLUME and FDeviceCaps.dwSupport) <> 0 then\r\n MidiOutCheck(midiOutSetVolume(FHandle, Value));\r\n FVolume := Value;\r\n end;\r\nend;\r\n\r\ninitialization\r\n {$IFDEF UNITVERSIONING}\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n {$ENDIF UNITVERSIONING}\r\n\r\nfinalization\r\n {$IFDEF UNITVERSIONING}\r\n UnregisterUnitVersion(HInstance);\r\n {$ENDIF UNITVERSIONING}\r\n FreeAndNil(FMidiOutputs);\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jcl/source/windows/MSHelpServices_TLB.pas", "content": "{**************************************************************************************************}\r\n{ }\r\n{ Last modified: $Date:: 2011-09-03 00:07:50 +0200 (sam. 03 sept. 2011) $ }\r\n{ Revision: $Rev:: 3599 $ }\r\n{ Author: $Author:: outchy $ }\r\n{ }\r\n{**************************************************************************************************}\r\n\r\nunit MSHelpServices_TLB;\r\n\r\n// ************************************************************************ //\r\n// WARNING \r\n// ------- \r\n// The types declared in this file were generated from data read from a \r\n// Type Library. If this type library is explicitly or indirectly (via \r\n// another type library referring to this type library) re-imported, or the \r\n// 'Refresh' command of the Type Library Editor activated while editing the \r\n// Type Library, the contents of this file will be regenerated and all \r\n// manual modifications will be lost. \r\n// ************************************************************************ //\r\n\r\n// PASTLWTR : 1.2\r\n// File generated on 25/02/2006 20:01:26 from Type Library described below.\r\n\r\n// ************************************************************************ //\r\n// Type Lib: C:\\Program Files\\Fichiers communs\\Microsoft Shared\\Help\\hxds.dll (1)\r\n// LIBID: {31411197-A502-11D2-BBCA-00C04F8EC294}\r\n// LCID: 0\r\n// Helpfile: \r\n// HelpString: Microsoft Help Data Services 1.0 Type Library\r\n// DepndLst: \r\n// (1) v2.0 stdole, (C:\\WINNT\\system32\\stdole2.tlb)\r\n// Parent TypeLibrary:\r\n// (0) v1.0 MSHelpControls, (C:\\Program Files\\Fichiers communs\\Microsoft Shared\\Help\\hxvz.dll)\r\n// Errors:\r\n// Hint: Parameter 'var' of IHxTopic.SetProperty changed to 'var_'\r\n// Hint: Parameter 'var' of IHxAttribute.SetProperty changed to 'var_'\r\n// Hint: Parameter 'var' of IHxCollection.SetProperty changed to 'var_'\r\n// Hint: Parameter 'var' of IHxAttrName.SetProperty changed to 'var_'\r\n// Hint: Parameter 'var' of IHxAttrValue.SetProperty changed to 'var_'\r\n// Hint: Parameter 'type' of IHxRegisterSession.GetRegistrationObject changed to 'type_'\r\n// ************************************************************************ //\r\n// *************************************************************************//\r\n// NOTE: \r\n// Items guarded by $IFDEF_LIVE_SERVER_AT_DESIGN_TIME are used by properties \r\n// which return objects that may need to be explicitly created via a function \r\n// call prior to any access via the property. These items have been disabled \r\n// in order to prevent accidental use from within the object inspector. You \r\n// may enable them by defining LIVE_SERVER_AT_DESIGN_TIME or by selectively \r\n// removing them from the $IFDEF blocks. However, such items must still be \r\n// programmatically created via a method of the appropriate CoClass before \r\n// they can be used. \r\n{ $TYPEDADDRESS OFF} // Unit must be compiled without type-checked pointers. \r\n\r\n{$I jcl.inc}\r\n{$I windowsonly.inc}\r\n\r\n{$IFDEF SUPPORTS_WEAKPACKAGEUNIT}\r\n {$IFDEF UNITVERSIONING}\r\n {$WEAKPACKAGEUNIT OFF}\r\n {$ELSE ~UNITVERSIONING}\r\n {$WEAKPACKAGEUNIT ON}\r\n {$ENDIF ~UNITVERSIONING} \r\n{$ENDIF SUPPORTS_WEAKPACKAGEUNIT}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n {$IFDEF HAS_UNITSCOPE}\r\n Winapi.ActiveX, System.Classes;\r\n {$ELSE ~HAS_UNITSCOPE}\r\n ActiveX, Classes;\r\n {$ENDIF ~HAS_UNITSCOPE}\r\n\r\n//DOM-IGNORE-BEGIN\r\n\r\n// *********************************************************************//\r\n// GUIDS declared in the TypeLibrary. Following prefixes are used: \r\n// Type Libraries : LIBID_xxxx \r\n// CoClasses : CLASS_xxxx \r\n// DISPInterfaces : DIID_xxxx \r\n// Non-DISP interfaces: IID_xxxx \r\n// *********************************************************************//\r\nconst\r\n // TypeLibrary Major and minor versions\r\n MSHelpServicesMajorVersion = 1;\r\n MSHelpServicesMinorVersion = 0;\r\n\r\n LIBID_MSHelpServices: TGUID = '{31411197-A502-11D2-BBCA-00C04F8EC294}';\r\n\r\n IID_IHxHierarchy: TGUID = '{314111B2-A502-11D2-BBCA-00C04F8EC294}';\r\n IID_IHxTopic: TGUID = '{31411196-A502-11D2-BBCA-00C04F8EC294}';\r\n IID_IHxAttributeList: TGUID = '{314111AB-A502-11D2-BBCA-00C04F8EC294}';\r\n IID_IHxAttribute: TGUID = '{314111A9-A502-11D2-BBCA-00C04F8EC294}';\r\n IID_IEnumHxAttribute: TGUID = '{314111AD-A502-11D2-BBCA-00C04F8EC294}';\r\n IID_IHxRegister: TGUID = '{314111BC-A502-11D2-BBCA-00C04F8EC294}';\r\n IID_IHxIndex: TGUID = '{314111CC-A502-11D2-BBCA-00C04F8EC294}';\r\n IID_IHxSession: TGUID = '{31411192-A502-11D2-BBCA-00C04F8EC294}';\r\n IID_IHxTopicList: TGUID = '{31411194-A502-11D2-BBCA-00C04F8EC294}';\r\n IID_IEnumHxTopic: TGUID = '{31411195-A502-11D2-BBCA-00C04F8EC294}';\r\n IID_IHxQuery: TGUID = '{31411193-A502-11D2-BBCA-00C04F8EC294}';\r\n IID_IHxCollection: TGUID = '{314111A1-A502-11D2-BBCA-00C04F8EC294}';\r\n IID_IHxAttrNameList: TGUID = '{314111CE-A502-11D2-BBCA-00C04F8EC294}';\r\n IID_IHxAttrName: TGUID = '{314111D2-A502-11D2-BBCA-00C04F8EC294}';\r\n IID_IHxAttrValueList: TGUID = '{314111D4-A502-11D2-BBCA-00C04F8EC294}';\r\n IID_IHxAttrValue: TGUID = '{314111D8-A502-11D2-BBCA-00C04F8EC294}';\r\n IID_IEnumHxAttrValue: TGUID = '{314111D6-A502-11D2-BBCA-00C04F8EC294}';\r\n IID_IEnumHxAttrName: TGUID = '{314111D0-A502-11D2-BBCA-00C04F8EC294}';\r\n IID_IHxFilters: TGUID = '{314111E3-A502-11D2-BBCA-00C04F8EC294}';\r\n IID_IHxRegFilterList: TGUID = '{31411212-A502-11D2-BBCA-00C04F8EC294}';\r\n IID_IHxRegFilter: TGUID = '{31411221-A502-11D2-BBCA-00C04F8EC294}';\r\n IID_IEnumHxRegFilter: TGUID = '{3141121C-A502-11D2-BBCA-00C04F8EC294}';\r\n IID_IHxSampleCollection: TGUID = '{314111E6-A502-11D2-BBCA-00C04F8EC294}';\r\n IID_IHxSample: TGUID = '{314111E8-A502-11D2-BBCA-00C04F8EC294}';\r\n IID_IHxRegistryWalker: TGUID = '{314111EF-A502-11D2-BBCA-00C04F8EC294}';\r\n IID_IHxRegNamespaceList: TGUID = '{314111F3-A502-11D2-BBCA-00C04F8EC294}';\r\n IID_IHxRegNamespace: TGUID = '{314111F1-A502-11D2-BBCA-00C04F8EC294}';\r\n IID_IEnumHxRegNamespace: TGUID = '{314111F5-A502-11D2-BBCA-00C04F8EC294}';\r\n IID_IHxRegTitle: TGUID = '{31411202-A502-11D2-BBCA-00C04F8EC294}';\r\n IID_IHxRegTitleList: TGUID = '{31411203-A502-11D2-BBCA-00C04F8EC294}';\r\n IID_IEnumHxRegTitle: TGUID = '{31411204-A502-11D2-BBCA-00C04F8EC294}';\r\n IID_IHxRegPlugIn: TGUID = '{3141120A-A502-11D2-BBCA-00C04F8EC294}';\r\n IID_IHxRegPlugInList: TGUID = '{3141120B-A502-11D2-BBCA-00C04F8EC294}';\r\n IID_IEnumHxRegPlugIn: TGUID = '{3141120C-A502-11D2-BBCA-00C04F8EC294}';\r\n IID_IHxRegisterSession: TGUID = '{31411218-A502-11D2-BBCA-00C04F8EC294}';\r\n IID_IHxPlugIn: TGUID = '{314111DA-A502-11D2-BBCA-00C04F8EC294}';\r\n IID_IHxInitialize: TGUID = '{314111AE-A502-11D2-BBCA-00C04F8EC294}';\r\n IID_IHxCancel: TGUID = '{31411225-A502-11D2-BBCA-00C04F8EC294}';\r\n DIID_IHxSessionEvents: TGUID = '{314111ED-A502-11D2-BBCA-00C04F8EC294}';\r\n DIID_IHxRegisterSessionEvents: TGUID = '{31411223-A502-11D2-BBCA-00C04F8EC294}';\r\n CLASS_HxSession: TGUID = '{31411198-A502-11D2-BBCA-00C04F8EC294}';\r\n CLASS_HxRegistryWalker: TGUID = '{314111F0-A502-11D2-BBCA-00C04F8EC294}';\r\n CLASS_HxRegisterSession: TGUID = '{31411219-A502-11D2-BBCA-00C04F8EC294}';\r\n IID_IHxRegisterProtocol: TGUID = '{31411227-A502-11D2-BBCA-00C04F8EC294}';\r\n CLASS_HxRegisterProtocol: TGUID = '{31411228-A502-11D2-BBCA-00C04F8EC294}';\r\n\r\n// *********************************************************************//\r\n// Declaration of Enumerations defined in Type Library \r\n// *********************************************************************//\r\n// Constants for enum HxHierarchyNodeType\r\ntype\r\n HxHierarchyNodeType = TOleEnum;\r\nconst\r\n HxHierarchy_Book = $00000003;\r\n HxHierarchy_BookPage = $00000004;\r\n HxHierarchy_Page = $00000005;\r\n HxHierarchy_Unknown = $00000008;\r\n\r\n// Constants for enum HxHierarchyPropId\r\ntype\r\n HxHierarchyPropId = TOleEnum;\r\nconst\r\n HxHierarchyTocFont = $00000000;\r\n HxHierarchyTocFontSize = $00000001;\r\n HxHierarchyTocLangId = $00000002;\r\n HxHierarchyTocCharSet = $00000003;\r\n HxHierarchyTocId = $00000004;\r\n HxHierarchyTocFileVer = $00000005;\r\n HxHierarchyTocIconFile = $00000006;\r\n HxHierarchyTocParentNodeIcon = $00000007;\r\n HxHierarchyTocIcon = $00000008;\r\n\r\n// Constants for enum HxTopicGetTitleType\r\ntype\r\n HxTopicGetTitleType = TOleEnum;\r\nconst\r\n HxTopicGetTOCTitle = $00000000;\r\n HxTopicGetRLTitle = $00000001;\r\n HxTopicGetHTMTitle = $00000002;\r\n\r\n// Constants for enum HxTopicGetTitleDefVal\r\ntype\r\n HxTopicGetTitleDefVal = TOleEnum;\r\nconst\r\n HxTopicGetTitleFullURL = $00000000;\r\n HxTopicGetTitleFileName = $00000001;\r\n HxTopicGetTitleNoDefault = $00000002;\r\n\r\n// Constants for enum HxQueryPropId\r\ntype\r\n HxQueryPropId = TOleEnum;\r\nconst\r\n HxPropIdQueryFirst = $00000000;\r\n\r\n// Constants for enum HxTopicPropId\r\ntype\r\n HxTopicPropId = TOleEnum;\r\nconst\r\n HxTopicPropIdFirst = $00000000;\r\n\r\n// Constants for enum HxHierarchy_PrintNode_Options\r\ntype\r\n HxHierarchy_PrintNode_Options = TOleEnum;\r\nconst\r\n HxHierarchy_PrintNode_Option_Node = $00000000;\r\n HxHierarchy_PrintNode_Option_Children = $00000001;\r\n\r\n// Constants for enum HxQuery_Options\r\ntype\r\n HxQuery_Options = TOleEnum;\r\nconst\r\n HxQuery_No_Option = $00000000;\r\n HxQuery_FullTextSearch_Title_Only = $00000001;\r\n HxQuery_FullTextSearch_Enable_Stemming = $00000002;\r\n HxQuery_FullTextSearch_SearchPrevious = $00000004;\r\n HxQuery_KeywordSearch_CaseSensitive = $0000000A;\r\n\r\n// Constants for enum HxCollectionPropId\r\ntype\r\n HxCollectionPropId = TOleEnum;\r\nconst\r\n HxCollectionProp_NamespaceName = $00000001;\r\n HxCollectionProp_Font = $00000002;\r\n HxCollectionProp_FontSize = $00000003;\r\n HxCollectionProp_LangId = $00000004;\r\n HxCollectionProp_CharSet = $00000005;\r\n HxCollectionProp_Id = $00000006;\r\n HxCollectionProp_FileVer = $00000007;\r\n HxCollectionProp_CopyRight = $00000008;\r\n\r\n// Constants for enum HxRegFilterPropId\r\ntype\r\n HxRegFilterPropId = TOleEnum;\r\nconst\r\n HxRegFilterName = $00000000;\r\n HxRegFilterQuery = $00000001;\r\n\r\n// Constants for enum HxIndexPropId\r\ntype\r\n HxIndexPropId = TOleEnum;\r\nconst\r\n HxIndexFont = $00000000;\r\n HxIndexFontSize = $00000001;\r\n HxIndexLangId = $00000002;\r\n HxIndexCharSet = $00000003;\r\n HxIndexTitleStr = $00000004;\r\n HxIndexIsVisible = $00000005;\r\n HxIndexId = $00000006;\r\n\r\n// Constants for enum HxSampleFileCopyOption\r\ntype\r\n HxSampleFileCopyOption = TOleEnum;\r\nconst\r\n HxSampleFileCopyNoOption = $00000000;\r\n HxSampleFileCopyOverwrite = $00000001;\r\n HxSampleFileCopyFileOnly = $00000002;\r\n\r\n// Constants for enum HxRegNamespacePropId\r\ntype\r\n HxRegNamespacePropId = TOleEnum;\r\nconst\r\n HxRegNamespaceTitleList = $00000000;\r\n HxRegNamespacePlugInList = $00000001;\r\n HxRegNamespaceName = $00000002;\r\n HxRegNamespaceCollection = $00000003;\r\n HxRegNamespaceDescription = $00000004;\r\n HxRegNamespaceFilterList = $00000008;\r\n\r\n// Constants for enum HxRegTitlePropId\r\ntype\r\n HxRegTitlePropId = TOleEnum;\r\nconst\r\n HxRegTitleFileName = $00000000;\r\n HxRegTitleIndexName = $00000001;\r\n HxRegTitleQueryName = $00000002;\r\n HxRegTitleId = $00000003;\r\n HxRegTitleLangId = $00000004;\r\n HxRegAttrQueryName = $00000005;\r\n HxRegTitleHxsMediaLoc = $00000006;\r\n HxRegTitleHxqMediaLoc = $00000007;\r\n HxRegTitleHxrMediaLoc = $00000008;\r\n HxRegTitleSampleMediaLoc = $00000009;\r\n\r\n// Constants for enum HxRegPlugInPropId\r\ntype\r\n HxRegPlugInPropId = TOleEnum;\r\nconst\r\n HxRegPlugInName = $00000000;\r\n\r\n// Constants for enum HxRegisterSession_InterfaceType\r\ntype\r\n HxRegisterSession_InterfaceType = TOleEnum;\r\nconst\r\n HxRegisterSession_IHxRegister = $00000000;\r\n HxRegisterSession_IHxFilters = $00000001;\r\n HxRegisterSession_IHxPlugIn = $00000002;\r\n\r\n// Constants for enum HxCancelStatus\r\ntype\r\n HxCancelStatus = TOleEnum;\r\nconst\r\n HxCancelStatus_Continue = $00000000;\r\n HxCancelStatus_Cancel = $00000001;\r\n\r\ntype\r\n\r\n// *********************************************************************//\r\n// Forward declaration of types defined in TypeLibrary \r\n// *********************************************************************//\r\n IHxHierarchy = interface;\r\n IHxHierarchyDisp = dispinterface;\r\n IHxTopic = interface;\r\n IHxTopicDisp = dispinterface;\r\n IHxAttributeList = interface;\r\n IHxAttributeListDisp = dispinterface;\r\n IHxAttribute = interface;\r\n IHxAttributeDisp = dispinterface;\r\n IEnumHxAttribute = interface;\r\n IHxRegister = interface;\r\n IHxRegisterDisp = dispinterface;\r\n IHxIndex = interface;\r\n IHxIndexDisp = dispinterface;\r\n IHxSession = interface;\r\n IHxSessionDisp = dispinterface;\r\n IHxTopicList = interface;\r\n IHxTopicListDisp = dispinterface;\r\n IEnumHxTopic = interface;\r\n IHxQuery = interface;\r\n IHxQueryDisp = dispinterface;\r\n IHxCollection = interface;\r\n IHxCollectionDisp = dispinterface;\r\n IHxAttrNameList = interface;\r\n IHxAttrNameListDisp = dispinterface;\r\n IHxAttrName = interface;\r\n IHxAttrNameDisp = dispinterface;\r\n IHxAttrValueList = interface;\r\n IHxAttrValueListDisp = dispinterface;\r\n IHxAttrValue = interface;\r\n IHxAttrValueDisp = dispinterface;\r\n IEnumHxAttrValue = interface;\r\n IEnumHxAttrName = interface;\r\n IHxFilters = interface;\r\n IHxFiltersDisp = dispinterface;\r\n IHxRegFilterList = interface;\r\n IHxRegFilterListDisp = dispinterface;\r\n IHxRegFilter = interface;\r\n IHxRegFilterDisp = dispinterface;\r\n IEnumHxRegFilter = interface;\r\n IHxSampleCollection = interface;\r\n IHxSampleCollectionDisp = dispinterface;\r\n IHxSample = interface;\r\n IHxSampleDisp = dispinterface;\r\n IHxRegistryWalker = interface;\r\n IHxRegistryWalkerDisp = dispinterface;\r\n IHxRegNamespaceList = interface;\r\n IHxRegNamespaceListDisp = dispinterface;\r\n IHxRegNamespace = interface;\r\n IHxRegNamespaceDisp = dispinterface;\r\n IEnumHxRegNamespace = interface;\r\n IHxRegTitle = interface;\r\n IHxRegTitleDisp = dispinterface;\r\n IHxRegTitleList = interface;\r\n IHxRegTitleListDisp = dispinterface;\r\n IEnumHxRegTitle = interface;\r\n IHxRegPlugIn = interface;\r\n IHxRegPlugInDisp = dispinterface;\r\n IHxRegPlugInList = interface;\r\n IHxRegPlugInListDisp = dispinterface;\r\n IEnumHxRegPlugIn = interface;\r\n IHxRegisterSession = interface;\r\n IHxRegisterSessionDisp = dispinterface;\r\n IHxPlugIn = interface;\r\n IHxPlugInDisp = dispinterface;\r\n IHxInitialize = interface;\r\n IHxInitializeDisp = dispinterface;\r\n IHxCancel = interface;\r\n IHxCancelDisp = dispinterface;\r\n IHxSessionEvents = dispinterface;\r\n IHxRegisterSessionEvents = dispinterface;\r\n IHxRegisterProtocol = interface;\r\n IHxRegisterProtocolDisp = dispinterface;\r\n\r\n// *********************************************************************//\r\n// Declaration of CoClasses defined in Type Library \r\n// (NOTE: Here we map each CoClass to its Default Interface) \r\n// *********************************************************************//\r\n HxSession = IHxSession;\r\n HxRegistryWalker = IHxRegistryWalker;\r\n HxRegisterSession = IHxRegisterSession;\r\n HxRegisterProtocol = IHxRegisterProtocol;\r\n\r\n\r\n// *********************************************************************//\r\n// Declaration of structures, unions and aliases. \r\n// *********************************************************************//\r\n PUserType1 = ^TGUID; {*}\r\n POleVariant1 = ^OleVariant; {*}\r\n\r\n\r\n// *********************************************************************//\r\n// Interface: IHxHierarchy\r\n// Flags: (4544) Dual NonExtensible OleAutomation Dispatchable\r\n// GUID: {314111B2-A502-11D2-BBCA-00C04F8EC294}\r\n// *********************************************************************//\r\n IHxHierarchy = interface(IDispatch)\r\n ['{314111B2-A502-11D2-BBCA-00C04F8EC294}']\r\n function GetRoot: Integer; safecall;\r\n function GetParent(hNode: Integer): Integer; safecall;\r\n function GetSibling(hNode: Integer): Integer; safecall;\r\n function GetFirstChild(hNode: Integer): Integer; safecall;\r\n function GetNextFromUrl(const pURL: WideString): Integer; safecall;\r\n function GetPrevFromUrl(const pURL: WideString): Integer; safecall;\r\n function GetType(hNode: Integer): HxHierarchyNodeType; safecall;\r\n function IsNew(hNode: Integer): WordBool; safecall;\r\n function HasChild(hNode: Integer): WordBool; safecall;\r\n function GetSyncInfo(const pURL: WideString): PSafeArray; safecall;\r\n function GetTitle(hNode: Integer): WideString; safecall;\r\n function GetImageIndexes(hNode: Integer; out pOpen: Integer): Integer; safecall;\r\n function GetURL(hNode: Integer): WideString; safecall;\r\n function OnNavigation(const pbstrURL: WideString): WordBool; safecall;\r\n procedure OnHierarchyNavigation(hNode: Integer); safecall;\r\n function GetProperty(propid: HxHierarchyPropId; hNode: Integer): OleVariant; safecall;\r\n function GetNextFromNode(hNode: Integer): Integer; safecall;\r\n function GetPrevFromNode(hNode: Integer): Integer; safecall;\r\n function GetTopic(hNode: Integer): IHxTopic; safecall;\r\n function GetOpenImageIndex(hNode: Integer): Integer; safecall;\r\n function GetClosedImageIndex(hNode: Integer): Integer; safecall;\r\n procedure PrintNode(hwnd: Integer; hNode: Integer; options: HxHierarchy_PrintNode_Options); safecall;\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: IHxHierarchyDisp\r\n// Flags: (4544) Dual NonExtensible OleAutomation Dispatchable\r\n// GUID: {314111B2-A502-11D2-BBCA-00C04F8EC294}\r\n// *********************************************************************//\r\n IHxHierarchyDisp = dispinterface\r\n ['{314111B2-A502-11D2-BBCA-00C04F8EC294}']\r\n function GetRoot: Integer; dispid 66561;\r\n function GetParent(hNode: Integer): Integer; dispid 66562;\r\n function GetSibling(hNode: Integer): Integer; dispid 66563;\r\n function GetFirstChild(hNode: Integer): Integer; dispid 66564;\r\n function GetNextFromUrl(const pURL: WideString): Integer; dispid 66565;\r\n function GetPrevFromUrl(const pURL: WideString): Integer; dispid 66566;\r\n function GetType(hNode: Integer): HxHierarchyNodeType; dispid 66567;\r\n function IsNew(hNode: Integer): WordBool; dispid 66568;\r\n function HasChild(hNode: Integer): WordBool; dispid 66569;\r\n function GetSyncInfo(const pURL: WideString): {??PSafeArray}OleVariant; dispid 66570;\r\n function GetTitle(hNode: Integer): WideString; dispid 66571;\r\n function GetImageIndexes(hNode: Integer; out pOpen: Integer): Integer; dispid 66572;\r\n function GetURL(hNode: Integer): WideString; dispid 66573;\r\n function OnNavigation(const pbstrURL: WideString): WordBool; dispid 66574;\r\n procedure OnHierarchyNavigation(hNode: Integer); dispid 66575;\r\n function GetProperty(propid: HxHierarchyPropId; hNode: Integer): OleVariant; dispid 66576;\r\n function GetNextFromNode(hNode: Integer): Integer; dispid 66577;\r\n function GetPrevFromNode(hNode: Integer): Integer; dispid 66578;\r\n function GetTopic(hNode: Integer): IHxTopic; dispid 66579;\r\n function GetOpenImageIndex(hNode: Integer): Integer; dispid 66580;\r\n function GetClosedImageIndex(hNode: Integer): Integer; dispid 66581;\r\n procedure PrintNode(hwnd: Integer; hNode: Integer; options: HxHierarchy_PrintNode_Options); dispid 66582;\r\n end;\r\n {$EXTERNALSYM IHxHierarchyDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: IHxTopic\r\n// Flags: (4544) Dual NonExtensible OleAutomation Dispatchable\r\n// GUID: {31411196-A502-11D2-BBCA-00C04F8EC294}\r\n// *********************************************************************//\r\n IHxTopic = interface(IDispatch)\r\n ['{31411196-A502-11D2-BBCA-00C04F8EC294}']\r\n function Get_Title(optType: HxTopicGetTitleType; optDef: HxTopicGetTitleDefVal): WideString; safecall;\r\n function Get_URL: WideString; safecall;\r\n function Get_Location: WideString; safecall;\r\n function Get_Rank: Integer; safecall;\r\n function Get_Attributes: IHxAttributeList; safecall;\r\n procedure GetInfo(out pTitle: WideString; out pURL: WideString; out pLocation: WideString; \r\n out pRank: Integer); safecall;\r\n function GetProperty(propid: HxTopicPropId): OleVariant; safecall;\r\n procedure SetProperty(propid: HxTopicPropId; var_: OleVariant); safecall;\r\n function HasAttribute(const Name: WideString; const Value: WideString): WordBool; safecall;\r\n function HasAttrName(const Name: WideString): WordBool; safecall;\r\n procedure HighlightDocument(const pIDispatch: IDispatch); safecall;\r\n property Title[optType: HxTopicGetTitleType; optDef: HxTopicGetTitleDefVal]: WideString read Get_Title;\r\n property URL: WideString read Get_URL;\r\n property Location: WideString read Get_Location;\r\n property Rank: Integer read Get_Rank;\r\n property Attributes: IHxAttributeList read Get_Attributes;\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: IHxTopicDisp\r\n// Flags: (4544) Dual NonExtensible OleAutomation Dispatchable\r\n// GUID: {31411196-A502-11D2-BBCA-00C04F8EC294}\r\n// *********************************************************************//\r\n IHxTopicDisp = dispinterface\r\n ['{31411196-A502-11D2-BBCA-00C04F8EC294}']\r\n property Title[optType: HxTopicGetTitleType; optDef: HxTopicGetTitleDefVal]: WideString readonly dispid 68097;\r\n property URL: WideString readonly dispid 68098;\r\n property Location: WideString readonly dispid 68099;\r\n property Rank: Integer readonly dispid 68100;\r\n property Attributes: IHxAttributeList readonly dispid 68101;\r\n procedure GetInfo(out pTitle: WideString; out pURL: WideString; out pLocation: WideString; \r\n out pRank: Integer); dispid 68102;\r\n function GetProperty(propid: HxTopicPropId): OleVariant; dispid 68103;\r\n procedure SetProperty(propid: HxTopicPropId; var_: OleVariant); dispid 68104;\r\n function HasAttribute(const Name: WideString; const Value: WideString): WordBool; dispid 68105;\r\n function HasAttrName(const Name: WideString): WordBool; dispid 68106;\r\n procedure HighlightDocument(const pIDispatch: IDispatch); dispid 68107;\r\n end;\r\n {$EXTERNALSYM IHxTopicDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: IHxAttributeList\r\n// Flags: (4544) Dual NonExtensible OleAutomation Dispatchable\r\n// GUID: {314111AB-A502-11D2-BBCA-00C04F8EC294}\r\n// *********************************************************************//\r\n IHxAttributeList = interface(IDispatch)\r\n ['{314111AB-A502-11D2-BBCA-00C04F8EC294}']\r\n function Get_Count: Integer; safecall;\r\n function ItemAt(index: Integer): IHxAttribute; safecall;\r\n function EnumAttribute(filter: Integer; options: Integer): IEnumHxAttribute; safecall;\r\n function Get__NewEnum: IUnknown; safecall;\r\n function Item(index: OleVariant): IHxAttribute; safecall;\r\n property Count: Integer read Get_Count;\r\n property _NewEnum: IUnknown read Get__NewEnum;\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: IHxAttributeListDisp\r\n// Flags: (4544) Dual NonExtensible OleAutomation Dispatchable\r\n// GUID: {314111AB-A502-11D2-BBCA-00C04F8EC294}\r\n// *********************************************************************//\r\n IHxAttributeListDisp = dispinterface\r\n ['{314111AB-A502-11D2-BBCA-00C04F8EC294}']\r\n property Count: Integer readonly dispid 70400;\r\n function ItemAt(index: Integer): IHxAttribute; dispid 70401;\r\n function EnumAttribute(filter: Integer; options: Integer): IEnumHxAttribute; dispid 70402;\r\n property _NewEnum: IUnknown readonly dispid -4;\r\n function Item(index: OleVariant): IHxAttribute; dispid 70403;\r\n end;\r\n {$EXTERNALSYM IHxAttributeListDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: IHxAttribute\r\n// Flags: (4544) Dual NonExtensible OleAutomation Dispatchable\r\n// GUID: {314111A9-A502-11D2-BBCA-00C04F8EC294}\r\n// *********************************************************************//\r\n IHxAttribute = interface(IDispatch)\r\n ['{314111A9-A502-11D2-BBCA-00C04F8EC294}']\r\n function GetProperty(propid: HxQueryPropId): OleVariant; safecall;\r\n procedure SetProperty(propid: HxQueryPropId; var_: OleVariant); safecall;\r\n function Get_Name: WideString; safecall;\r\n function Get_Value: WideString; safecall;\r\n function Get_DisplayName: WideString; safecall;\r\n function Get_DisplayValue: WideString; safecall;\r\n property Name: WideString read Get_Name;\r\n property Value: WideString read Get_Value;\r\n property DisplayName: WideString read Get_DisplayName;\r\n property DisplayValue: WideString read Get_DisplayValue;\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: IHxAttributeDisp\r\n// Flags: (4544) Dual NonExtensible OleAutomation Dispatchable\r\n// GUID: {314111A9-A502-11D2-BBCA-00C04F8EC294}\r\n// *********************************************************************//\r\n IHxAttributeDisp = dispinterface\r\n ['{314111A9-A502-11D2-BBCA-00C04F8EC294}']\r\n function GetProperty(propid: HxQueryPropId): OleVariant; dispid 69888;\r\n procedure SetProperty(propid: HxQueryPropId; var_: OleVariant); dispid 69889;\r\n property Name: WideString readonly dispid 69890;\r\n property Value: WideString readonly dispid 69891;\r\n property DisplayName: WideString readonly dispid 69892;\r\n property DisplayValue: WideString readonly dispid 69893;\r\n end;\r\n {$EXTERNALSYM IHxAttributeDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: IEnumHxAttribute\r\n// Flags: (16) Hidden\r\n// GUID: {314111AD-A502-11D2-BBCA-00C04F8EC294}\r\n// *********************************************************************//\r\n IEnumHxAttribute = interface(IUnknown)\r\n ['{314111AD-A502-11D2-BBCA-00C04F8EC294}']\r\n function Next(celt: LongWord; out ppIHxAttribute: IHxAttribute; out pceltFetched: LongWord): HResult; stdcall;\r\n function Reset: HResult; stdcall;\r\n function Skip(celt: LongWord): HResult; stdcall;\r\n function Clone(out ppEnum: IEnumHxAttribute): HResult; stdcall;\r\n end;\r\n\r\n// *********************************************************************//\r\n// Interface: IHxRegister\r\n// Flags: (4544) Dual NonExtensible OleAutomation Dispatchable\r\n// GUID: {314111BC-A502-11D2-BBCA-00C04F8EC294}\r\n// *********************************************************************//\r\n IHxRegister = interface(IDispatch)\r\n ['{314111BC-A502-11D2-BBCA-00C04F8EC294}']\r\n procedure RegisterNamespace(const bstrNamespace: WideString; const bstrCollection: WideString; \r\n const bstrDescription: WideString); safecall;\r\n function IsNamespace(const bstrNamespace: WideString): WordBool; safecall;\r\n function GetCollection(const bstrNamespace: WideString): WideString; safecall;\r\n function GetDescription(const bstrNamespace: WideString): WideString; safecall;\r\n procedure RemoveNamespace(const bstrNamespace: WideString); safecall;\r\n procedure RegisterHelpFile(const bstrNamespace: WideString; const bstrId: WideString; \r\n LangId: Integer; const bstrHelpFile: WideString); safecall;\r\n function RegisterMedia(const bstrNamespace: WideString; const bstrFriendly: WideString; \r\n const bstrPath: WideString): Integer; safecall;\r\n procedure RemoveHelpFile(const bstrNamespace: WideString; const bstrId: WideString; \r\n LangId: Integer); safecall;\r\n procedure RegisterHelpFileSet(const bstrNamespace: WideString; const bstrId: WideString; \r\n LangId: Integer; const bstrHxs: WideString; \r\n const bstrHxi: WideString; const bstrHxq: WideString; \r\n const bstrHxr: WideString; lHxsMediaId: Integer; \r\n lHxqMediaId: Integer; lHxrMediaId: Integer; \r\n lSampleMediaId: Integer); safecall;\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: IHxRegisterDisp\r\n// Flags: (4544) Dual NonExtensible OleAutomation Dispatchable\r\n// GUID: {314111BC-A502-11D2-BBCA-00C04F8EC294}\r\n// *********************************************************************//\r\n IHxRegisterDisp = dispinterface\r\n ['{314111BC-A502-11D2-BBCA-00C04F8EC294}']\r\n procedure RegisterNamespace(const bstrNamespace: WideString; const bstrCollection: WideString; \r\n const bstrDescription: WideString); dispid 66817;\r\n function IsNamespace(const bstrNamespace: WideString): WordBool; dispid 66818;\r\n function GetCollection(const bstrNamespace: WideString): WideString; dispid 66830;\r\n function GetDescription(const bstrNamespace: WideString): WideString; dispid 66829;\r\n procedure RemoveNamespace(const bstrNamespace: WideString); dispid 66819;\r\n procedure RegisterHelpFile(const bstrNamespace: WideString; const bstrId: WideString; \r\n LangId: Integer; const bstrHelpFile: WideString); dispid 66822;\r\n function RegisterMedia(const bstrNamespace: WideString; const bstrFriendly: WideString; \r\n const bstrPath: WideString): Integer; dispid 66823;\r\n procedure RemoveHelpFile(const bstrNamespace: WideString; const bstrId: WideString; \r\n LangId: Integer); dispid 66825;\r\n procedure RegisterHelpFileSet(const bstrNamespace: WideString; const bstrId: WideString; \r\n LangId: Integer; const bstrHxs: WideString; \r\n const bstrHxi: WideString; const bstrHxq: WideString; \r\n const bstrHxr: WideString; lHxsMediaId: Integer; \r\n lHxqMediaId: Integer; lHxrMediaId: Integer; \r\n lSampleMediaId: Integer); dispid 66831;\r\n end;\r\n {$EXTERNALSYM IHxRegisterDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: IHxIndex\r\n// Flags: (4544) Dual NonExtensible OleAutomation Dispatchable\r\n// GUID: {314111CC-A502-11D2-BBCA-00C04F8EC294}\r\n// *********************************************************************//\r\n IHxIndex = interface(IDispatch)\r\n ['{314111CC-A502-11D2-BBCA-00C04F8EC294}']\r\n function GetSession: IHxSession; safecall;\r\n function Get_Count: Integer; safecall;\r\n function GetStringFromSlot(iSlot: Integer): WideString; safecall;\r\n function GetLevelFromSlot(iSlot: Integer): Integer; safecall;\r\n function GetSlotFromString(const bszLink: WideString): Integer; safecall;\r\n function GetTopicsFromSlot(uiSlot: Integer): IHxTopicList; safecall;\r\n function GetTopicsFromString(const bszLink: WideString; options: Integer): IHxTopicList; safecall;\r\n function GetInfoFromSlot(iSlot: Integer; out piLevel: Integer): WideString; safecall;\r\n function GetProperty(propid: HxIndexPropId): OleVariant; safecall;\r\n function GetCrossRef(iSlot: Integer): WideString; safecall;\r\n function GetFullStringFromSlot(iSlot: Integer; const sep: WideString): WideString; safecall;\r\n function GetCrossRefSlot(iSlot: Integer): Integer; safecall;\r\n property Count: Integer read Get_Count;\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: IHxIndexDisp\r\n// Flags: (4544) Dual NonExtensible OleAutomation Dispatchable\r\n// GUID: {314111CC-A502-11D2-BBCA-00C04F8EC294}\r\n// *********************************************************************//\r\n IHxIndexDisp = dispinterface\r\n ['{314111CC-A502-11D2-BBCA-00C04F8EC294}']\r\n function GetSession: IHxSession; dispid 67072;\r\n property Count: Integer readonly dispid 67073;\r\n function GetStringFromSlot(iSlot: Integer): WideString; dispid 67074;\r\n function GetLevelFromSlot(iSlot: Integer): Integer; dispid 67078;\r\n function GetSlotFromString(const bszLink: WideString): Integer; dispid 67075;\r\n function GetTopicsFromSlot(uiSlot: Integer): IHxTopicList; dispid 67076;\r\n function GetTopicsFromString(const bszLink: WideString; options: Integer): IHxTopicList; dispid 67077;\r\n function GetInfoFromSlot(iSlot: Integer; out piLevel: Integer): WideString; dispid 67079;\r\n function GetProperty(propid: HxIndexPropId): OleVariant; dispid 67080;\r\n function GetCrossRef(iSlot: Integer): WideString; dispid 67081;\r\n function GetFullStringFromSlot(iSlot: Integer; const sep: WideString): WideString; dispid 67082;\r\n function GetCrossRefSlot(iSlot: Integer): Integer; dispid 67083;\r\n end;\r\n {$EXTERNALSYM IHxIndexDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: IHxSession\r\n// Flags: (4560) Hidden Dual NonExtensible OleAutomation Dispatchable\r\n// GUID: {31411192-A502-11D2-BBCA-00C04F8EC294}\r\n// *********************************************************************//\r\n IHxSession = interface(IDispatch)\r\n ['{31411192-A502-11D2-BBCA-00C04F8EC294}']\r\n procedure Initialize(const NameSpace: WideString; options: Integer); safecall;\r\n function Query(const keywords: WideString; const NavDataMoniker: WideString; options: Integer; \r\n const FilterMoniker: WideString): IHxTopicList; safecall;\r\n function QueryForTopic(const keywords: WideString; const NavDataMoniker: WideString; \r\n options: Integer; const FilterMoniker: WideString): IHxTopic; safecall;\r\n function QueryForUrl(const keywords: WideString; const NavDataMoniker: WideString; \r\n options: Integer; const FilterMoniker: WideString): WideString; safecall;\r\n function GetNavigationInterface(const NavDataMoniker: WideString; \r\n const FilterMoniker: WideString; var refiid: TGUID): IDispatch; safecall;\r\n function GetNavigationObject(const NavDataMoniker: WideString; const FilterMoniker: WideString): IDispatch; safecall;\r\n function GetQueryObject(const NavDataMoniker: WideString; const FilterMoniker: WideString): IHxQuery; safecall;\r\n function Get_Collection: IHxCollection; safecall;\r\n function Get_LangId: Smallint; safecall;\r\n procedure Set_LangId(piHelpLangId: Smallint); safecall;\r\n function GetFilterList: IHxRegFilterList; safecall;\r\n property Collection: IHxCollection read Get_Collection;\r\n property LangId: Smallint read Get_LangId write Set_LangId;\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: IHxSessionDisp\r\n// Flags: (4560) Hidden Dual NonExtensible OleAutomation Dispatchable\r\n// GUID: {31411192-A502-11D2-BBCA-00C04F8EC294}\r\n// *********************************************************************//\r\n IHxSessionDisp = dispinterface\r\n ['{31411192-A502-11D2-BBCA-00C04F8EC294}']\r\n procedure Initialize(const NameSpace: WideString; options: Integer); dispid 65792;\r\n function Query(const keywords: WideString; const NavDataMoniker: WideString; options: Integer; \r\n const FilterMoniker: WideString): IHxTopicList; dispid 65793;\r\n function QueryForTopic(const keywords: WideString; const NavDataMoniker: WideString; \r\n options: Integer; const FilterMoniker: WideString): IHxTopic; dispid 65794;\r\n function QueryForUrl(const keywords: WideString; const NavDataMoniker: WideString; \r\n options: Integer; const FilterMoniker: WideString): WideString; dispid 65795;\r\n function GetNavigationInterface(const NavDataMoniker: WideString; \r\n const FilterMoniker: WideString; var refiid: {??TGUID}OleVariant): IDispatch; dispid 65796;\r\n function GetNavigationObject(const NavDataMoniker: WideString; const FilterMoniker: WideString): IDispatch; dispid 65797;\r\n function GetQueryObject(const NavDataMoniker: WideString; const FilterMoniker: WideString): IHxQuery; dispid 65798;\r\n property Collection: IHxCollection readonly dispid 65799;\r\n property LangId: Smallint dispid 65803;\r\n function GetFilterList: IHxRegFilterList; dispid 65805;\r\n end;\r\n {$EXTERNALSYM IHxSessionDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: IHxTopicList\r\n// Flags: (4544) Dual NonExtensible OleAutomation Dispatchable\r\n// GUID: {31411194-A502-11D2-BBCA-00C04F8EC294}\r\n// *********************************************************************//\r\n IHxTopicList = interface(IDispatch)\r\n ['{31411194-A502-11D2-BBCA-00C04F8EC294}']\r\n function Item(index: OleVariant): IHxTopic; safecall;\r\n function ItemAt(index: Integer): IHxTopic; safecall;\r\n function EnumTopics(filter: Integer; options: Integer): IEnumHxTopic; safecall;\r\n function Get__NewEnum: IUnknown; safecall;\r\n function Get_Count: Integer; safecall;\r\n property _NewEnum: IUnknown read Get__NewEnum;\r\n property Count: Integer read Get_Count;\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: IHxTopicListDisp\r\n// Flags: (4544) Dual NonExtensible OleAutomation Dispatchable\r\n// GUID: {31411194-A502-11D2-BBCA-00C04F8EC294}\r\n// *********************************************************************//\r\n IHxTopicListDisp = dispinterface\r\n ['{31411194-A502-11D2-BBCA-00C04F8EC294}']\r\n function Item(index: OleVariant): IHxTopic; dispid 0;\r\n function ItemAt(index: Integer): IHxTopic; dispid 67584;\r\n function EnumTopics(filter: Integer; options: Integer): IEnumHxTopic; dispid 67585;\r\n property _NewEnum: IUnknown readonly dispid -4;\r\n property Count: Integer readonly dispid 67586;\r\n end;\r\n {$EXTERNALSYM IHxTopicListDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: IEnumHxTopic\r\n// Flags: (16) Hidden\r\n// GUID: {31411195-A502-11D2-BBCA-00C04F8EC294}\r\n// *********************************************************************//\r\n IEnumHxTopic = interface(IUnknown)\r\n ['{31411195-A502-11D2-BBCA-00C04F8EC294}']\r\n function Next(celt: LongWord; out ppIHxTopic: IHxTopic; out pceltFetched: LongWord): HResult; stdcall;\r\n function Reset: HResult; stdcall;\r\n function Skip(celt: LongWord): HResult; stdcall;\r\n function Clone(out ppEnum: IEnumHxTopic): HResult; stdcall;\r\n end;\r\n\r\n// *********************************************************************//\r\n// Interface: IHxQuery\r\n// Flags: (4544) Dual NonExtensible OleAutomation Dispatchable\r\n// GUID: {31411193-A502-11D2-BBCA-00C04F8EC294}\r\n// *********************************************************************//\r\n IHxQuery = interface(IDispatch)\r\n ['{31411193-A502-11D2-BBCA-00C04F8EC294}']\r\n function Query(const keywords: WideString; options: HxQuery_Options): IHxTopicList; safecall;\r\n function QueryForTopic(const keywords: WideString; options: HxQuery_Options): IHxTopic; safecall;\r\n function QueryForUrl(const keywords: WideString; options: HxQuery_Options): WideString; safecall;\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: IHxQueryDisp\r\n// Flags: (4544) Dual NonExtensible OleAutomation Dispatchable\r\n// GUID: {31411193-A502-11D2-BBCA-00C04F8EC294}\r\n// *********************************************************************//\r\n IHxQueryDisp = dispinterface\r\n ['{31411193-A502-11D2-BBCA-00C04F8EC294}']\r\n function Query(const keywords: WideString; options: HxQuery_Options): IHxTopicList; dispid 67328;\r\n function QueryForTopic(const keywords: WideString; options: HxQuery_Options): IHxTopic; dispid 67329;\r\n function QueryForUrl(const keywords: WideString; options: HxQuery_Options): WideString; dispid 67330;\r\n end;\r\n {$EXTERNALSYM IHxQueryDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: IHxCollection\r\n// Flags: (4544) Dual NonExtensible OleAutomation Dispatchable\r\n// GUID: {314111A1-A502-11D2-BBCA-00C04F8EC294}\r\n// *********************************************************************//\r\n IHxCollection = interface(IDispatch)\r\n ['{314111A1-A502-11D2-BBCA-00C04F8EC294}']\r\n function GetProperty(propid: HxCollectionPropId): OleVariant; safecall;\r\n procedure SetProperty(propid: HxCollectionPropId; var_: OleVariant); safecall;\r\n function Get_URL: WideString; safecall;\r\n function Get_AttributeNames: IHxAttrNameList; safecall;\r\n function Get_Filters: IHxFilters; safecall;\r\n function Get_Title: WideString; safecall;\r\n procedure MergeIndex; safecall;\r\n function GetFilterTopicCount(const bstrQuery: WideString): Integer; safecall;\r\n property URL: WideString read Get_URL;\r\n property AttributeNames: IHxAttrNameList read Get_AttributeNames;\r\n property Filters: IHxFilters read Get_Filters;\r\n property Title: WideString read Get_Title;\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: IHxCollectionDisp\r\n// Flags: (4544) Dual NonExtensible OleAutomation Dispatchable\r\n// GUID: {314111A1-A502-11D2-BBCA-00C04F8EC294}\r\n// *********************************************************************//\r\n IHxCollectionDisp = dispinterface\r\n ['{314111A1-A502-11D2-BBCA-00C04F8EC294}']\r\n function GetProperty(propid: HxCollectionPropId): OleVariant; dispid 68352;\r\n procedure SetProperty(propid: HxCollectionPropId; var_: OleVariant); dispid 68353;\r\n property URL: WideString readonly dispid 68354;\r\n property AttributeNames: IHxAttrNameList readonly dispid 68357;\r\n property Filters: IHxFilters readonly dispid 68358;\r\n property Title: WideString readonly dispid 68359;\r\n procedure MergeIndex; dispid 68360;\r\n function GetFilterTopicCount(const bstrQuery: WideString): Integer; dispid 68361;\r\n end;\r\n {$EXTERNALSYM IHxCollectionDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: IHxAttrNameList\r\n// Flags: (4544) Dual NonExtensible OleAutomation Dispatchable\r\n// GUID: {314111CE-A502-11D2-BBCA-00C04F8EC294}\r\n// *********************************************************************//\r\n IHxAttrNameList = interface(IDispatch)\r\n ['{314111CE-A502-11D2-BBCA-00C04F8EC294}']\r\n function Get_Count: Integer; safecall;\r\n function ItemAt(index: Integer): IHxAttrName; safecall;\r\n function EnumAttrName(filter: Integer; options: Integer): IEnumHxAttrName; safecall;\r\n function Get__NewEnum: IUnknown; safecall;\r\n function Item(index: OleVariant): IHxAttrName; safecall;\r\n property Count: Integer read Get_Count;\r\n property _NewEnum: IUnknown read Get__NewEnum;\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: IHxAttrNameListDisp\r\n// Flags: (4544) Dual NonExtensible OleAutomation Dispatchable\r\n// GUID: {314111CE-A502-11D2-BBCA-00C04F8EC294}\r\n// *********************************************************************//\r\n IHxAttrNameListDisp = dispinterface\r\n ['{314111CE-A502-11D2-BBCA-00C04F8EC294}']\r\n property Count: Integer readonly dispid 71168;\r\n function ItemAt(index: Integer): IHxAttrName; dispid 71169;\r\n function EnumAttrName(filter: Integer; options: Integer): IEnumHxAttrName; dispid 71170;\r\n property _NewEnum: IUnknown readonly dispid -4;\r\n function Item(index: OleVariant): IHxAttrName; dispid 71171;\r\n end;\r\n {$EXTERNALSYM IHxAttrNameListDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: IHxAttrName\r\n// Flags: (4544) Dual NonExtensible OleAutomation Dispatchable\r\n// GUID: {314111D2-A502-11D2-BBCA-00C04F8EC294}\r\n// *********************************************************************//\r\n IHxAttrName = interface(IDispatch)\r\n ['{314111D2-A502-11D2-BBCA-00C04F8EC294}']\r\n function GetProperty(propid: HxQueryPropId): OleVariant; safecall;\r\n procedure SetProperty(propid: HxQueryPropId; var_: OleVariant); safecall;\r\n function Get_Name: WideString; safecall;\r\n function Get_DisplayName: WideString; safecall;\r\n function Get_Flag: Integer; safecall;\r\n function Get_AttributeValues: IHxAttrValueList; safecall;\r\n property Name: WideString read Get_Name;\r\n property DisplayName: WideString read Get_DisplayName;\r\n property Flag: Integer read Get_Flag;\r\n property AttributeValues: IHxAttrValueList read Get_AttributeValues;\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: IHxAttrNameDisp\r\n// Flags: (4544) Dual NonExtensible OleAutomation Dispatchable\r\n// GUID: {314111D2-A502-11D2-BBCA-00C04F8EC294}\r\n// *********************************************************************//\r\n IHxAttrNameDisp = dispinterface\r\n ['{314111D2-A502-11D2-BBCA-00C04F8EC294}']\r\n function GetProperty(propid: HxQueryPropId): OleVariant; dispid 70656;\r\n procedure SetProperty(propid: HxQueryPropId; var_: OleVariant); dispid 70657;\r\n property Name: WideString readonly dispid 70658;\r\n property DisplayName: WideString readonly dispid 70659;\r\n property Flag: Integer readonly dispid 70660;\r\n property AttributeValues: IHxAttrValueList readonly dispid 70661;\r\n end;\r\n {$EXTERNALSYM IHxAttrNameDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: IHxAttrValueList\r\n// Flags: (4544) Dual NonExtensible OleAutomation Dispatchable\r\n// GUID: {314111D4-A502-11D2-BBCA-00C04F8EC294}\r\n// *********************************************************************//\r\n IHxAttrValueList = interface(IDispatch)\r\n ['{314111D4-A502-11D2-BBCA-00C04F8EC294}']\r\n function Get_Count: Integer; safecall;\r\n function ItemAt(index: Integer): IHxAttrValue; safecall;\r\n function EnumAttrValue(filter: Integer; options: Integer): IEnumHxAttrValue; safecall;\r\n function Get__NewEnum: IUnknown; safecall;\r\n function Item(index: OleVariant): IHxAttrValue; safecall;\r\n property Count: Integer read Get_Count;\r\n property _NewEnum: IUnknown read Get__NewEnum;\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: IHxAttrValueListDisp\r\n// Flags: (4544) Dual NonExtensible OleAutomation Dispatchable\r\n// GUID: {314111D4-A502-11D2-BBCA-00C04F8EC294}\r\n// *********************************************************************//\r\n IHxAttrValueListDisp = dispinterface\r\n ['{314111D4-A502-11D2-BBCA-00C04F8EC294}']\r\n property Count: Integer readonly dispid 71936;\r\n function ItemAt(index: Integer): IHxAttrValue; dispid 71937;\r\n function EnumAttrValue(filter: Integer; options: Integer): IEnumHxAttrValue; dispid 71938;\r\n property _NewEnum: IUnknown readonly dispid -4;\r\n function Item(index: OleVariant): IHxAttrValue; dispid 71939;\r\n end;\r\n {$EXTERNALSYM IHxAttrValueListDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: IHxAttrValue\r\n// Flags: (4544) Dual NonExtensible OleAutomation Dispatchable\r\n// GUID: {314111D8-A502-11D2-BBCA-00C04F8EC294}\r\n// *********************************************************************//\r\n IHxAttrValue = interface(IDispatch)\r\n ['{314111D8-A502-11D2-BBCA-00C04F8EC294}']\r\n function GetProperty(propid: HxQueryPropId): OleVariant; safecall;\r\n procedure SetProperty(propid: HxQueryPropId; var_: OleVariant); safecall;\r\n function Get_Value: WideString; safecall;\r\n function Get_DisplayValue: WideString; safecall;\r\n function Get_Flag: Integer; safecall;\r\n property Value: WideString read Get_Value;\r\n property DisplayValue: WideString read Get_DisplayValue;\r\n property Flag: Integer read Get_Flag;\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: IHxAttrValueDisp\r\n// Flags: (4544) Dual NonExtensible OleAutomation Dispatchable\r\n// GUID: {314111D8-A502-11D2-BBCA-00C04F8EC294}\r\n// *********************************************************************//\r\n IHxAttrValueDisp = dispinterface\r\n ['{314111D8-A502-11D2-BBCA-00C04F8EC294}']\r\n function GetProperty(propid: HxQueryPropId): OleVariant; dispid 71424;\r\n procedure SetProperty(propid: HxQueryPropId; var_: OleVariant); dispid 71425;\r\n property Value: WideString readonly dispid 71426;\r\n property DisplayValue: WideString readonly dispid 71427;\r\n property Flag: Integer readonly dispid 71428;\r\n end;\r\n {$EXTERNALSYM IHxAttrValueDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: IEnumHxAttrValue\r\n// Flags: (16) Hidden\r\n// GUID: {314111D6-A502-11D2-BBCA-00C04F8EC294}\r\n// *********************************************************************//\r\n IEnumHxAttrValue = interface(IUnknown)\r\n ['{314111D6-A502-11D2-BBCA-00C04F8EC294}']\r\n function Next(celt: LongWord; out ppIHxAttrValue: IHxAttrValue; out pceltFetched: LongWord): HResult; stdcall;\r\n function Reset: HResult; stdcall;\r\n function Skip(celt: LongWord): HResult; stdcall;\r\n function Clone(out ppEnum: IEnumHxAttrValue): HResult; stdcall;\r\n end;\r\n\r\n// *********************************************************************//\r\n// Interface: IEnumHxAttrName\r\n// Flags: (16) Hidden\r\n// GUID: {314111D0-A502-11D2-BBCA-00C04F8EC294}\r\n// *********************************************************************//\r\n IEnumHxAttrName = interface(IUnknown)\r\n ['{314111D0-A502-11D2-BBCA-00C04F8EC294}']\r\n function Next(celt: LongWord; out ppIHxAttrName: IHxAttrName; out pceltFetched: LongWord): HResult; stdcall;\r\n function Reset: HResult; stdcall;\r\n function Skip(celt: LongWord): HResult; stdcall;\r\n function Clone(out ppEnum: IEnumHxAttrName): HResult; stdcall;\r\n end;\r\n\r\n// *********************************************************************//\r\n// Interface: IHxFilters\r\n// Flags: (4544) Dual NonExtensible OleAutomation Dispatchable\r\n// GUID: {314111E3-A502-11D2-BBCA-00C04F8EC294}\r\n// *********************************************************************//\r\n IHxFilters = interface(IDispatch)\r\n ['{314111E3-A502-11D2-BBCA-00C04F8EC294}']\r\n function Count: Integer; safecall;\r\n function GetFilter(iIndex: Integer; out pbstrName: WideString): WideString; safecall;\r\n function GetFilterName(iIndex: Integer): WideString; safecall;\r\n function GetFilterQuery(iIndex: Integer): WideString; safecall;\r\n procedure RegisterFilter(const bstrName: WideString; const bstrQuery: WideString); safecall;\r\n procedure RemoveFilter(const bstrName: WideString); safecall;\r\n function FindFilter(const bstrName: WideString): WideString; safecall;\r\n procedure SetNamespace(const bstrName: WideString); safecall;\r\n procedure SetCollectionFiltersFlag(vb: WordBool); safecall;\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: IHxFiltersDisp\r\n// Flags: (4544) Dual NonExtensible OleAutomation Dispatchable\r\n// GUID: {314111E3-A502-11D2-BBCA-00C04F8EC294}\r\n// *********************************************************************//\r\n IHxFiltersDisp = dispinterface\r\n ['{314111E3-A502-11D2-BBCA-00C04F8EC294}']\r\n function Count: Integer; dispid 66048;\r\n function GetFilter(iIndex: Integer; out pbstrName: WideString): WideString; dispid 66049;\r\n function GetFilterName(iIndex: Integer): WideString; dispid 66054;\r\n function GetFilterQuery(iIndex: Integer): WideString; dispid 66055;\r\n procedure RegisterFilter(const bstrName: WideString; const bstrQuery: WideString); dispid 66050;\r\n procedure RemoveFilter(const bstrName: WideString); dispid 66051;\r\n function FindFilter(const bstrName: WideString): WideString; dispid 66052;\r\n procedure SetNamespace(const bstrName: WideString); dispid 66053;\r\n procedure SetCollectionFiltersFlag(vb: WordBool); dispid 66057;\r\n end;\r\n {$EXTERNALSYM IHxFiltersDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: IHxRegFilterList\r\n// Flags: (4544) Dual NonExtensible OleAutomation Dispatchable\r\n// GUID: {31411212-A502-11D2-BBCA-00C04F8EC294}\r\n// *********************************************************************//\r\n IHxRegFilterList = interface(IDispatch)\r\n ['{31411212-A502-11D2-BBCA-00C04F8EC294}']\r\n function Item(index: OleVariant): IHxRegFilter; safecall;\r\n function ItemAt(index: Integer): IHxRegFilter; safecall;\r\n function EnumRegFilter(filter: Integer; options: Integer): IEnumHxRegFilter; safecall;\r\n function Get__NewEnum: IUnknown; safecall;\r\n function Get_Count: Integer; safecall;\r\n function FindFilter(const bstrFilterName: WideString): IHxRegFilter; safecall;\r\n property _NewEnum: IUnknown read Get__NewEnum;\r\n property Count: Integer read Get_Count;\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: IHxRegFilterListDisp\r\n// Flags: (4544) Dual NonExtensible OleAutomation Dispatchable\r\n// GUID: {31411212-A502-11D2-BBCA-00C04F8EC294}\r\n// *********************************************************************//\r\n IHxRegFilterListDisp = dispinterface\r\n ['{31411212-A502-11D2-BBCA-00C04F8EC294}']\r\n function Item(index: OleVariant): IHxRegFilter; dispid 0;\r\n function ItemAt(index: Integer): IHxRegFilter; dispid 75776;\r\n function EnumRegFilter(filter: Integer; options: Integer): IEnumHxRegFilter; dispid 75777;\r\n property _NewEnum: IUnknown readonly dispid -4;\r\n property Count: Integer readonly dispid 75778;\r\n function FindFilter(const bstrFilterName: WideString): IHxRegFilter; dispid 75779;\r\n end;\r\n {$EXTERNALSYM IHxRegFilterListDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: IHxRegFilter\r\n// Flags: (4544) Dual NonExtensible OleAutomation Dispatchable\r\n// GUID: {31411221-A502-11D2-BBCA-00C04F8EC294}\r\n// *********************************************************************//\r\n IHxRegFilter = interface(IDispatch)\r\n ['{31411221-A502-11D2-BBCA-00C04F8EC294}']\r\n function GetProperty(propid: HxRegFilterPropId): OleVariant; safecall;\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: IHxRegFilterDisp\r\n// Flags: (4544) Dual NonExtensible OleAutomation Dispatchable\r\n// GUID: {31411221-A502-11D2-BBCA-00C04F8EC294}\r\n// *********************************************************************//\r\n IHxRegFilterDisp = dispinterface\r\n ['{31411221-A502-11D2-BBCA-00C04F8EC294}']\r\n function GetProperty(propid: HxRegFilterPropId): OleVariant; dispid 75520;\r\n end;\r\n {$EXTERNALSYM IHxRegFilterDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: IEnumHxRegFilter\r\n// Flags: (16) Hidden\r\n// GUID: {3141121C-A502-11D2-BBCA-00C04F8EC294}\r\n// *********************************************************************//\r\n IEnumHxRegFilter = interface(IUnknown)\r\n ['{3141121C-A502-11D2-BBCA-00C04F8EC294}']\r\n function Next(celt: LongWord; out ppIHxRegFilter: IHxRegFilter; out pceltFetched: LongWord): HResult; stdcall;\r\n function Reset: HResult; stdcall;\r\n function Skip(celt: LongWord): HResult; stdcall;\r\n function Clone(out ppEnum: IEnumHxRegFilter): HResult; stdcall;\r\n end;\r\n\r\n// *********************************************************************//\r\n// Interface: IHxSampleCollection\r\n// Flags: (4544) Dual NonExtensible OleAutomation Dispatchable\r\n// GUID: {314111E6-A502-11D2-BBCA-00C04F8EC294}\r\n// *********************************************************************//\r\n IHxSampleCollection = interface(IDispatch)\r\n ['{314111E6-A502-11D2-BBCA-00C04F8EC294}']\r\n function GetSampleFromId(const bstrTopicUrl: WideString; const bstrId: WideString; \r\n const bstrSFLName: WideString): IHxSample; safecall;\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: IHxSampleCollectionDisp\r\n// Flags: (4544) Dual NonExtensible OleAutomation Dispatchable\r\n// GUID: {314111E6-A502-11D2-BBCA-00C04F8EC294}\r\n// *********************************************************************//\r\n IHxSampleCollectionDisp = dispinterface\r\n ['{314111E6-A502-11D2-BBCA-00C04F8EC294}']\r\n function GetSampleFromId(const bstrTopicUrl: WideString; const bstrId: WideString; \r\n const bstrSFLName: WideString): IHxSample; dispid 72448;\r\n end;\r\n {$EXTERNALSYM IHxSampleCollectionDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: IHxSample\r\n// Flags: (4544) Dual NonExtensible OleAutomation Dispatchable\r\n// GUID: {314111E8-A502-11D2-BBCA-00C04F8EC294}\r\n// *********************************************************************//\r\n IHxSample = interface(IDispatch)\r\n ['{314111E8-A502-11D2-BBCA-00C04F8EC294}']\r\n function Get_SampleId: WideString; safecall;\r\n function Get_LoadString: WideString; safecall;\r\n function Get_DestinationDir: WideString; safecall;\r\n function Get_ProjectFileExt: WideString; safecall;\r\n function Get_FileCount: Integer; safecall;\r\n function GetFileNameAtIndex(index: Integer): WideString; safecall;\r\n procedure CopyFileAtIndex(index: Integer; const bstrDest: WideString; \r\n option: HxSampleFileCopyOption); safecall;\r\n function ChooseDirectory(const bstrDefaultDir: WideString; const bstrTitle: WideString): WideString; safecall;\r\n function GetFileTextAtIndex(index: Integer): WideString; safecall;\r\n property SampleId: WideString read Get_SampleId;\r\n property LoadString: WideString read Get_LoadString;\r\n property DestinationDir: WideString read Get_DestinationDir;\r\n property ProjectFileExt: WideString read Get_ProjectFileExt;\r\n property FileCount: Integer read Get_FileCount;\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: IHxSampleDisp\r\n// Flags: (4544) Dual NonExtensible OleAutomation Dispatchable\r\n// GUID: {314111E8-A502-11D2-BBCA-00C04F8EC294}\r\n// *********************************************************************//\r\n IHxSampleDisp = dispinterface\r\n ['{314111E8-A502-11D2-BBCA-00C04F8EC294}']\r\n property SampleId: WideString readonly dispid 72704;\r\n property LoadString: WideString readonly dispid 72705;\r\n property DestinationDir: WideString readonly dispid 72706;\r\n property ProjectFileExt: WideString readonly dispid 72707;\r\n property FileCount: Integer readonly dispid 72709;\r\n function GetFileNameAtIndex(index: Integer): WideString; dispid 72710;\r\n procedure CopyFileAtIndex(index: Integer; const bstrDest: WideString; \r\n option: HxSampleFileCopyOption); dispid 72711;\r\n function ChooseDirectory(const bstrDefaultDir: WideString; const bstrTitle: WideString): WideString; dispid 72713;\r\n function GetFileTextAtIndex(index: Integer): WideString; dispid 72714;\r\n end;\r\n {$EXTERNALSYM IHxSampleDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: IHxRegistryWalker\r\n// Flags: (4544) Dual NonExtensible OleAutomation Dispatchable\r\n// GUID: {314111EF-A502-11D2-BBCA-00C04F8EC294}\r\n// *********************************************************************//\r\n IHxRegistryWalker = interface(IDispatch)\r\n ['{314111EF-A502-11D2-BBCA-00C04F8EC294}']\r\n function Get_RegisteredNamespaceList(const bstrStart: WideString): IHxRegNamespaceList; safecall;\r\n property RegisteredNamespaceList[const bstrStart: WideString]: IHxRegNamespaceList read Get_RegisteredNamespaceList;\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: IHxRegistryWalkerDisp\r\n// Flags: (4544) Dual NonExtensible OleAutomation Dispatchable\r\n// GUID: {314111EF-A502-11D2-BBCA-00C04F8EC294}\r\n// *********************************************************************//\r\n IHxRegistryWalkerDisp = dispinterface\r\n ['{314111EF-A502-11D2-BBCA-00C04F8EC294}']\r\n property RegisteredNamespaceList[const bstrStart: WideString]: IHxRegNamespaceList readonly dispid 72960;\r\n end;\r\n {$EXTERNALSYM IHxRegistryWalkerDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: IHxRegNamespaceList\r\n// Flags: (4544) Dual NonExtensible OleAutomation Dispatchable\r\n// GUID: {314111F3-A502-11D2-BBCA-00C04F8EC294}\r\n// *********************************************************************//\r\n IHxRegNamespaceList = interface(IDispatch)\r\n ['{314111F3-A502-11D2-BBCA-00C04F8EC294}']\r\n function Item(index: OleVariant): IHxRegNamespace; safecall;\r\n function ItemAt(index: Integer): IHxRegNamespace; safecall;\r\n function EnumRegNamespace(filter: Integer; options: Integer): IEnumHxRegNamespace; safecall;\r\n function Get__NewEnum: IUnknown; safecall;\r\n function Get_Count: Integer; safecall;\r\n property _NewEnum: IUnknown read Get__NewEnum;\r\n property Count: Integer read Get_Count;\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: IHxRegNamespaceListDisp\r\n// Flags: (4544) Dual NonExtensible OleAutomation Dispatchable\r\n// GUID: {314111F3-A502-11D2-BBCA-00C04F8EC294}\r\n// *********************************************************************//\r\n IHxRegNamespaceListDisp = dispinterface\r\n ['{314111F3-A502-11D2-BBCA-00C04F8EC294}']\r\n function Item(index: OleVariant): IHxRegNamespace; dispid 0;\r\n function ItemAt(index: Integer): IHxRegNamespace; dispid 73472;\r\n function EnumRegNamespace(filter: Integer; options: Integer): IEnumHxRegNamespace; dispid 73473;\r\n property _NewEnum: IUnknown readonly dispid -4;\r\n property Count: Integer readonly dispid 73474;\r\n end;\r\n {$EXTERNALSYM IHxRegNamespaceListDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: IHxRegNamespace\r\n// Flags: (4544) Dual NonExtensible OleAutomation Dispatchable\r\n// GUID: {314111F1-A502-11D2-BBCA-00C04F8EC294}\r\n// *********************************************************************//\r\n IHxRegNamespace = interface(IDispatch)\r\n ['{314111F1-A502-11D2-BBCA-00C04F8EC294}']\r\n function Get_Name: WideString; safecall;\r\n function GetProperty(propid: HxRegNamespacePropId): OleVariant; safecall;\r\n function IsTitle(const bstrTitle: WideString): WordBool; safecall;\r\n property Name: WideString read Get_Name;\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: IHxRegNamespaceDisp\r\n// Flags: (4544) Dual NonExtensible OleAutomation Dispatchable\r\n// GUID: {314111F1-A502-11D2-BBCA-00C04F8EC294}\r\n// *********************************************************************//\r\n IHxRegNamespaceDisp = dispinterface\r\n ['{314111F1-A502-11D2-BBCA-00C04F8EC294}']\r\n property Name: WideString readonly dispid 73216;\r\n function GetProperty(propid: HxRegNamespacePropId): OleVariant; dispid 73217;\r\n function IsTitle(const bstrTitle: WideString): WordBool; dispid 73218;\r\n end;\r\n {$EXTERNALSYM IHxRegNamespaceDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: IEnumHxRegNamespace\r\n// Flags: (16) Hidden\r\n// GUID: {314111F5-A502-11D2-BBCA-00C04F8EC294}\r\n// *********************************************************************//\r\n IEnumHxRegNamespace = interface(IUnknown)\r\n ['{314111F5-A502-11D2-BBCA-00C04F8EC294}']\r\n function Next(celt: LongWord; out ppIHxRegNamespace: IHxRegNamespace; out pceltFetched: LongWord): HResult; stdcall;\r\n function Reset: HResult; stdcall;\r\n function Skip(celt: LongWord): HResult; stdcall;\r\n function Clone(out ppEnum: IEnumHxRegNamespace): HResult; stdcall;\r\n end;\r\n\r\n// *********************************************************************//\r\n// Interface: IHxRegTitle\r\n// Flags: (4544) Dual NonExtensible OleAutomation Dispatchable\r\n// GUID: {31411202-A502-11D2-BBCA-00C04F8EC294}\r\n// *********************************************************************//\r\n IHxRegTitle = interface(IDispatch)\r\n ['{31411202-A502-11D2-BBCA-00C04F8EC294}']\r\n function GetProperty(propid: HxRegTitlePropId): OleVariant; safecall;\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: IHxRegTitleDisp\r\n// Flags: (4544) Dual NonExtensible OleAutomation Dispatchable\r\n// GUID: {31411202-A502-11D2-BBCA-00C04F8EC294}\r\n// *********************************************************************//\r\n IHxRegTitleDisp = dispinterface\r\n ['{31411202-A502-11D2-BBCA-00C04F8EC294}']\r\n function GetProperty(propid: HxRegTitlePropId): OleVariant; dispid 73984;\r\n end;\r\n {$EXTERNALSYM IHxRegTitleDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: IHxRegTitleList\r\n// Flags: (4544) Dual NonExtensible OleAutomation Dispatchable\r\n// GUID: {31411203-A502-11D2-BBCA-00C04F8EC294}\r\n// *********************************************************************//\r\n IHxRegTitleList = interface(IDispatch)\r\n ['{31411203-A502-11D2-BBCA-00C04F8EC294}']\r\n function Item(index: OleVariant): IHxRegTitle; safecall;\r\n function ItemAt(index: Integer): IHxRegTitle; safecall;\r\n function EnumRegTitle(filter: Integer; options: Integer): IEnumHxRegTitle; safecall;\r\n function Get__NewEnum: IUnknown; safecall;\r\n function Get_Count: Integer; safecall;\r\n property _NewEnum: IUnknown read Get__NewEnum;\r\n property Count: Integer read Get_Count;\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: IHxRegTitleListDisp\r\n// Flags: (4544) Dual NonExtensible OleAutomation Dispatchable\r\n// GUID: {31411203-A502-11D2-BBCA-00C04F8EC294}\r\n// *********************************************************************//\r\n IHxRegTitleListDisp = dispinterface\r\n ['{31411203-A502-11D2-BBCA-00C04F8EC294}']\r\n function Item(index: OleVariant): IHxRegTitle; dispid 0;\r\n function ItemAt(index: Integer): IHxRegTitle; dispid 74240;\r\n function EnumRegTitle(filter: Integer; options: Integer): IEnumHxRegTitle; dispid 74241;\r\n property _NewEnum: IUnknown readonly dispid -4;\r\n property Count: Integer readonly dispid 74242;\r\n end;\r\n {$EXTERNALSYM IHxRegTitleListDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: IEnumHxRegTitle\r\n// Flags: (16) Hidden\r\n// GUID: {31411204-A502-11D2-BBCA-00C04F8EC294}\r\n// *********************************************************************//\r\n IEnumHxRegTitle = interface(IUnknown)\r\n ['{31411204-A502-11D2-BBCA-00C04F8EC294}']\r\n function Next(celt: LongWord; out ppIHxRegTitle: IHxRegTitle; out pceltFetched: LongWord): HResult; stdcall;\r\n function Reset: HResult; stdcall;\r\n function Skip(celt: LongWord): HResult; stdcall;\r\n function Clone(out ppEnum: IEnumHxRegTitle): HResult; stdcall;\r\n end;\r\n\r\n// *********************************************************************//\r\n// Interface: IHxRegPlugIn\r\n// Flags: (4544) Dual NonExtensible OleAutomation Dispatchable\r\n// GUID: {3141120A-A502-11D2-BBCA-00C04F8EC294}\r\n// *********************************************************************//\r\n IHxRegPlugIn = interface(IDispatch)\r\n ['{3141120A-A502-11D2-BBCA-00C04F8EC294}']\r\n function GetProperty(propid: HxRegPlugInPropId): OleVariant; safecall;\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: IHxRegPlugInDisp\r\n// Flags: (4544) Dual NonExtensible OleAutomation Dispatchable\r\n// GUID: {3141120A-A502-11D2-BBCA-00C04F8EC294}\r\n// *********************************************************************//\r\n IHxRegPlugInDisp = dispinterface\r\n ['{3141120A-A502-11D2-BBCA-00C04F8EC294}']\r\n function GetProperty(propid: HxRegPlugInPropId): OleVariant; dispid 74752;\r\n end;\r\n {$EXTERNALSYM IHxRegPluginDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: IHxRegPlugInList\r\n// Flags: (4544) Dual NonExtensible OleAutomation Dispatchable\r\n// GUID: {3141120B-A502-11D2-BBCA-00C04F8EC294}\r\n// *********************************************************************//\r\n IHxRegPlugInList = interface(IDispatch)\r\n ['{3141120B-A502-11D2-BBCA-00C04F8EC294}']\r\n function Item(index: OleVariant): IHxRegPlugIn; safecall;\r\n function ItemAt(index: Integer): IHxRegPlugIn; safecall;\r\n function EnumRegPlugIn(filter: Integer; options: Integer): IEnumHxRegPlugIn; safecall;\r\n function Get__NewEnum: IUnknown; safecall;\r\n function Get_Count: Integer; safecall;\r\n property _NewEnum: IUnknown read Get__NewEnum;\r\n property Count: Integer read Get_Count;\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: IHxRegPlugInListDisp\r\n// Flags: (4544) Dual NonExtensible OleAutomation Dispatchable\r\n// GUID: {3141120B-A502-11D2-BBCA-00C04F8EC294}\r\n// *********************************************************************//\r\n IHxRegPlugInListDisp = dispinterface\r\n ['{3141120B-A502-11D2-BBCA-00C04F8EC294}']\r\n function Item(index: OleVariant): IHxRegPlugIn; dispid 0;\r\n function ItemAt(index: Integer): IHxRegPlugIn; dispid 75008;\r\n function EnumRegPlugIn(filter: Integer; options: Integer): IEnumHxRegPlugIn; dispid 75009;\r\n property _NewEnum: IUnknown readonly dispid -4;\r\n property Count: Integer readonly dispid 75010;\r\n end;\r\n {$EXTERNALSYM IHxRegPluginListDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: IEnumHxRegPlugIn\r\n// Flags: (16) Hidden\r\n// GUID: {3141120C-A502-11D2-BBCA-00C04F8EC294}\r\n// *********************************************************************//\r\n IEnumHxRegPlugIn = interface(IUnknown)\r\n ['{3141120C-A502-11D2-BBCA-00C04F8EC294}']\r\n function Next(celt: LongWord; out ppIHxRegPlugIn: IHxRegPlugIn; out pceltFetched: LongWord): HResult; stdcall;\r\n function Reset: HResult; stdcall;\r\n function Skip(celt: LongWord): HResult; stdcall;\r\n function Clone(out ppEnum: IEnumHxRegPlugIn): HResult; stdcall;\r\n end;\r\n\r\n// *********************************************************************//\r\n// Interface: IHxRegisterSession\r\n// Flags: (4544) Dual NonExtensible OleAutomation Dispatchable\r\n// GUID: {31411218-A502-11D2-BBCA-00C04F8EC294}\r\n// *********************************************************************//\r\n IHxRegisterSession = interface(IDispatch)\r\n ['{31411218-A502-11D2-BBCA-00C04F8EC294}']\r\n function CreateTransaction(const bstrInToken: WideString): WideString; safecall;\r\n function PostponeTransaction: WideString; safecall;\r\n procedure ContinueTransaction(const bstrToken: WideString); safecall;\r\n procedure CommitTransaction; safecall;\r\n procedure RevertTransaction; safecall;\r\n function GetRegistrationObject(type_: HxRegisterSession_InterfaceType): IDispatch; safecall;\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: IHxRegisterSessionDisp\r\n// Flags: (4544) Dual NonExtensible OleAutomation Dispatchable\r\n// GUID: {31411218-A502-11D2-BBCA-00C04F8EC294}\r\n// *********************************************************************//\r\n IHxRegisterSessionDisp = dispinterface\r\n ['{31411218-A502-11D2-BBCA-00C04F8EC294}']\r\n function CreateTransaction(const bstrInToken: WideString): WideString; dispid 75265;\r\n function PostponeTransaction: WideString; dispid 75268;\r\n procedure ContinueTransaction(const bstrToken: WideString); dispid 75269;\r\n procedure CommitTransaction; dispid 75266;\r\n procedure RevertTransaction; dispid 75267;\r\n function GetRegistrationObject(type_: HxRegisterSession_InterfaceType): IDispatch; dispid 75270;\r\n end;\r\n {$EXTERNALSYM IHxRegisterSessionDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: IHxPlugIn\r\n// Flags: (4416) Dual OleAutomation Dispatchable\r\n// GUID: {314111DA-A502-11D2-BBCA-00C04F8EC294}\r\n// *********************************************************************//\r\n IHxPlugIn = interface(IDispatch)\r\n ['{314111DA-A502-11D2-BBCA-00C04F8EC294}']\r\n procedure RegisterHelpPlugIn(const bstrProductNamespace: WideString; \r\n const bstrProductHxt: WideString; const bstrNamespace: WideString; \r\n const bstrHxt: WideString; const bstrHxa: WideString; \r\n options: Integer); safecall;\r\n procedure RemoveHelpPlugIn(const bstrProductNamespace: WideString; \r\n const bstrProductHxt: WideString; const bstrNamespace: WideString; \r\n const bstrHxt: WideString; const bstrHxa: WideString); safecall;\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: IHxPlugInDisp\r\n// Flags: (4416) Dual OleAutomation Dispatchable\r\n// GUID: {314111DA-A502-11D2-BBCA-00C04F8EC294}\r\n// *********************************************************************//\r\n IHxPlugInDisp = dispinterface\r\n ['{314111DA-A502-11D2-BBCA-00C04F8EC294}']\r\n procedure RegisterHelpPlugIn(const bstrProductNamespace: WideString; \r\n const bstrProductHxt: WideString; const bstrNamespace: WideString; \r\n const bstrHxt: WideString; const bstrHxa: WideString; \r\n options: Integer); dispid 66304;\r\n procedure RemoveHelpPlugIn(const bstrProductNamespace: WideString; \r\n const bstrProductHxt: WideString; const bstrNamespace: WideString; \r\n const bstrHxt: WideString; const bstrHxa: WideString); dispid 66305;\r\n end;\r\n {$EXTERNALSYM IHxPlugInDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: IHxInitialize\r\n// Flags: (4544) Dual NonExtensible OleAutomation Dispatchable\r\n// GUID: {314111AE-A502-11D2-BBCA-00C04F8EC294}\r\n// *********************************************************************//\r\n IHxInitialize = interface(IDispatch)\r\n ['{314111AE-A502-11D2-BBCA-00C04F8EC294}']\r\n procedure Initialize(const InitString: WideString; options: Integer); safecall;\r\n function Get_filter: WideString; safecall;\r\n procedure Set_filter(const pFilterMoniker: WideString); safecall;\r\n property filter: WideString read Get_filter write Set_filter;\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: IHxInitializeDisp\r\n// Flags: (4544) Dual NonExtensible OleAutomation Dispatchable\r\n// GUID: {314111AE-A502-11D2-BBCA-00C04F8EC294}\r\n// *********************************************************************//\r\n IHxInitializeDisp = dispinterface\r\n ['{314111AE-A502-11D2-BBCA-00C04F8EC294}']\r\n procedure Initialize(const InitString: WideString; options: Integer); dispid 72192;\r\n property filter: WideString dispid 72193;\r\n end;\r\n {$EXTERNALSYM IHxInitializeDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: IHxCancel\r\n// Flags: (4544) Dual NonExtensible OleAutomation Dispatchable\r\n// GUID: {31411225-A502-11D2-BBCA-00C04F8EC294}\r\n// *********************************************************************//\r\n IHxCancel = interface(IDispatch)\r\n ['{31411225-A502-11D2-BBCA-00C04F8EC294}']\r\n function Get_Cancel: HxCancelStatus; safecall;\r\n procedure Set_Cancel(pbCancel: HxCancelStatus); safecall;\r\n property Cancel: HxCancelStatus read Get_Cancel write Set_Cancel;\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: IHxCancelDisp\r\n// Flags: (4544) Dual NonExtensible OleAutomation Dispatchable\r\n// GUID: {31411225-A502-11D2-BBCA-00C04F8EC294}\r\n// *********************************************************************//\r\n IHxCancelDisp = dispinterface\r\n ['{31411225-A502-11D2-BBCA-00C04F8EC294}']\r\n property Cancel: HxCancelStatus dispid 76032;\r\n end;\r\n {$EXTERNALSYM IHxCancelDisp}\r\n\r\n// *********************************************************************//\r\n// DispIntf: IHxSessionEvents\r\n// Flags: (4096) Dispatchable\r\n// GUID: {314111ED-A502-11D2-BBCA-00C04F8EC294}\r\n// *********************************************************************//\r\n IHxSessionEvents = dispinterface\r\n ['{314111ED-A502-11D2-BBCA-00C04F8EC294}']\r\n procedure QueryCancel(const pSession: IDispatch; const pCancel: IDispatch; status: Integer); dispid 65800;\r\n procedure IndexMergeStatus(const pSession: IDispatch; const pCancel: IDispatch; status: Integer); dispid 65801;\r\n procedure PrintMergeStatus(const pSession: IDispatch; const pCancel: IDispatch; status: Integer); dispid 65802;\r\n procedure MergeIndexFileName(const pDisp: IDispatch; const bstrFile: WideString); dispid 65804;\r\n end;\r\n {$EXTERNALSYM IHxSessionEvents}\r\n\r\n// *********************************************************************//\r\n// DispIntf: IHxRegisterSessionEvents\r\n// Flags: (4096) Dispatchable\r\n// GUID: {31411223-A502-11D2-BBCA-00C04F8EC294}\r\n// *********************************************************************//\r\n IHxRegisterSessionEvents = dispinterface\r\n ['{31411223-A502-11D2-BBCA-00C04F8EC294}']\r\n procedure FiltersChanged(const pDisp: IDispatch; var pvar: OleVariant); dispid 75271;\r\n end;\r\n {$EXTERNALSYM IHxRegisterSessionEvents}\r\n\r\n// *********************************************************************//\r\n// Interface: IHxRegisterProtocol\r\n// Flags: (4544) Dual NonExtensible OleAutomation Dispatchable\r\n// GUID: {31411227-A502-11D2-BBCA-00C04F8EC294}\r\n// *********************************************************************//\r\n IHxRegisterProtocol = interface(IDispatch)\r\n ['{31411227-A502-11D2-BBCA-00C04F8EC294}']\r\n procedure Register; safecall;\r\n procedure Unregister; safecall;\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: IHxRegisterProtocolDisp\r\n// Flags: (4544) Dual NonExtensible OleAutomation Dispatchable\r\n// GUID: {31411227-A502-11D2-BBCA-00C04F8EC294}\r\n// *********************************************************************//\r\n IHxRegisterProtocolDisp = dispinterface\r\n ['{31411227-A502-11D2-BBCA-00C04F8EC294}']\r\n procedure Register; dispid 1610743808;\r\n procedure Unregister; dispid 1610743809;\r\n end;\r\n {$EXTERNALSYM IHxRegisterProtocolDisp}\r\n\r\n// *********************************************************************//\r\n// The Class CoHxSession provides a Create and CreateRemote method to \r\n// create instances of the default interface IHxSession exposed by \r\n// the CoClass HxSession. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoHxSession = class\r\n class function Create: IHxSession;\r\n class function CreateRemote(const MachineName: string): IHxSession;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoHxRegistryWalker provides a Create and CreateRemote method to \r\n// create instances of the default interface IHxRegistryWalker exposed by \r\n// the CoClass HxRegistryWalker. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoHxRegistryWalker = class\r\n class function Create: IHxRegistryWalker;\r\n class function CreateRemote(const MachineName: string): IHxRegistryWalker;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoHxRegisterSession provides a Create and CreateRemote method to \r\n// create instances of the default interface IHxRegisterSession exposed by \r\n// the CoClass HxRegisterSession. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoHxRegisterSession = class\r\n class function Create: IHxRegisterSession;\r\n class function CreateRemote(const MachineName: string): IHxRegisterSession;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoHxRegisterProtocol provides a Create and CreateRemote method to \r\n// create instances of the default interface IHxRegisterProtocol exposed by \r\n// the CoClass HxRegisterProtocol. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoHxRegisterProtocol = class\r\n class function Create: IHxRegisterProtocol;\r\n class function CreateRemote(const MachineName: string): IHxRegisterProtocol;\r\n end;\r\n\r\n//DOM-IGNORE-END\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jcl.svn.sourceforge.net/svnroot/jcl/tags/JCL-2.4-Build4571/jcl/source/windows/MSHelpServices_TLB.pas $';\r\n Revision: '$Revision: 3599 $';\r\n Date: '$Date: 2011-09-03 00:07:50 +0200 (sam. 03 sept. 2011) $';\r\n LogPath: 'JCL\\source\\windows';\r\n Extra: '';\r\n Data: nil\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses \r\n {$IFDEF HAS_UNITSCOPE}\r\n System.Win.ComObj;\r\n {$ELSE ~HAS_UNITSCOPE}\r\n ComObj;\r\n {$ENDIF ~HAS_UNITSCOPE}\r\n\r\nclass function CoHxSession.Create: IHxSession;\r\nbegin\r\n Result := CreateComObject(CLASS_HxSession) as IHxSession;\r\nend;\r\n\r\nclass function CoHxSession.CreateRemote(const MachineName: string): IHxSession;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_HxSession) as IHxSession;\r\nend;\r\n\r\nclass function CoHxRegistryWalker.Create: IHxRegistryWalker;\r\nbegin\r\n Result := CreateComObject(CLASS_HxRegistryWalker) as IHxRegistryWalker;\r\nend;\r\n\r\nclass function CoHxRegistryWalker.CreateRemote(const MachineName: string): IHxRegistryWalker;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_HxRegistryWalker) as IHxRegistryWalker;\r\nend;\r\n\r\nclass function CoHxRegisterSession.Create: IHxRegisterSession;\r\nbegin\r\n Result := CreateComObject(CLASS_HxRegisterSession) as IHxRegisterSession;\r\nend;\r\n\r\nclass function CoHxRegisterSession.CreateRemote(const MachineName: string): IHxRegisterSession;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_HxRegisterSession) as IHxRegisterSession;\r\nend;\r\n\r\nclass function CoHxRegisterProtocol.Create: IHxRegisterProtocol;\r\nbegin\r\n Result := CreateComObject(CLASS_HxRegisterProtocol) as IHxRegisterProtocol;\r\nend;\r\n\r\nclass function CoHxRegisterProtocol.CreateRemote(const MachineName: string): IHxRegisterProtocol;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_HxRegisterProtocol) as IHxRegisterProtocol;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jcl/source/windows/MSTask.pas", "content": "{**************************************************************************************************}\r\n{ }\r\n{ Last modified: $Date:: 2011-09-03 00:07:50 +0200 (sam. 03 sept. 2011) $ }\r\n{ Revision: $Rev:: 3599 $ }\r\n{ Author: $Author:: outchy $ }\r\n{ }\r\n{**************************************************************************************************}\r\n\r\n(*****************************************************************************\r\n This IDL-file has been converted by \"the fIDLer\".\r\n [written by -=Assarbad=- Sept-2004] under MPL\r\n Visit the fIDLer homepage at: http://assarbad.net/en/stuff/\r\n {The 3 above lines should be retained}\r\n\r\n ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~\r\n NOTE:\r\n\r\n There's no guarantee for correct case of parameter or variable types.\r\n If you have a type like BLA_YADDA in IDL then fIDLer will have converted it\r\n to 'TBlaYadda' already. But if the type identifier was BLAYADDA and both\r\n BLA and YADDA being distinct words the result will not be correctly\r\n capitalized!\r\n ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~\r\n\r\n The original file was 'MSTask.Idl'\r\n File converted: 2004-10-08@18:38:57\r\n\r\n Cosmetics and review by:\r\n 2004-10-08 - Oliver Schneider \r\n Changes:\r\n 2004-11-15 - Scott Price \r\n *****************************************************************************)\r\n\r\nunit MSTask;\r\n\r\n{$I jcl.inc}\r\n{$I windowsonly.inc}\r\n\r\n{$IFDEF SUPPORTS_WEAKPACKAGEUNIT}\r\n {$IFDEF UNITVERSIONING}\r\n {$WEAKPACKAGEUNIT OFF}\r\n {$ELSE ~UNITVERSIONING}\r\n {$WEAKPACKAGEUNIT ON}\r\n {$ENDIF ~UNITVERSIONING}\r\n{$ENDIF SUPPORTS_WEAKPACKAGEUNIT}\r\n\r\n{$ALIGN ON}\r\n{$MINENUMSIZE 4}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n {$IFDEF HAS_UNITSCOPE}\r\n Winapi.ActiveX, Winapi.Windows;\r\n {$ELSE ~HAS_UNITSCOPE}\r\n ActiveX, Windows;\r\n {$ENDIF ~HAS_UNITSCOPE}\r\n\r\n//DOM-IGNORE-BEGIN\r\n\r\n(*$HPPEMIT '#include ' *)\r\n\r\n//+----------------------------------------------------------------------------\r\n//\r\n// Task Scheduler\r\n//\r\n// Microsoft Windows\r\n// Copyright (C) Microsoft Corporation, 1992 - 1999.\r\n//\r\n// File: mstask.idl\r\n//\r\n// Contents: ITaskTrigger, ITask, ITaskScheduler, IEnumWorkItems\r\n// interfaces and related definitions\r\n//\r\n// History: 06-Sep-95 EricB created\r\n//\r\n//-----------------------------------------------------------------------------\r\n\r\n\r\n// import \"oaidl.idl\";\r\n\r\n// import \"oleidl.idl\";\r\n\r\n// 148BD520-A2AB-11CE-B11F-00AA00530503 - Task object class ID\r\n// 148BD52A-A2AB-11CE-B11F-00AA00530503 - Task Scheduler class ID\r\n// A6B952F0-A4B1-11D0-997D-00AA006887EC - IScheduledWorkItem interface ID\r\n// 148BD524-A2AB-11CE-B11F-00AA00530503 - ITask interface ID\r\n// 148BD527-A2AB-11CE-B11F-00AA00530503 - ITaskScheduler interface ID\r\n// 148BD528-A2AB-11CE-B11F-00AA00530503 - IEnumWorkItems interface ID\r\n// 148BD52B-A2AB-11CE-B11F-00AA00530503 - ITaskTrigger interface ID\r\n\r\n//+----------------------------------------------------------------------------\r\n//\r\n// Datatypes\r\n//\r\n//-----------------------------------------------------------------------------\r\n\r\nconst\r\n{$EXTERNALSYM TASK_SUNDAY}\r\n TASK_SUNDAY = $1;\r\nconst\r\n{$EXTERNALSYM TASK_MONDAY}\r\n TASK_MONDAY = $2;\r\nconst\r\n{$EXTERNALSYM TASK_TUESDAY}\r\n TASK_TUESDAY = $4;\r\nconst\r\n{$EXTERNALSYM TASK_WEDNESDAY}\r\n TASK_WEDNESDAY = $8;\r\nconst\r\n{$EXTERNALSYM TASK_THURSDAY}\r\n TASK_THURSDAY = $10;\r\nconst\r\n{$EXTERNALSYM TASK_FRIDAY}\r\n TASK_FRIDAY = $20;\r\nconst\r\n{$EXTERNALSYM TASK_SATURDAY}\r\n TASK_SATURDAY = $40;\r\nconst\r\n{$EXTERNALSYM TASK_FIRST_WEEK}\r\n TASK_FIRST_WEEK = 1;\r\nconst\r\n{$EXTERNALSYM TASK_SECOND_WEEK}\r\n TASK_SECOND_WEEK = 2;\r\nconst\r\n{$EXTERNALSYM TASK_THIRD_WEEK}\r\n TASK_THIRD_WEEK = 3;\r\nconst\r\n{$EXTERNALSYM TASK_FOURTH_WEEK}\r\n TASK_FOURTH_WEEK = 4;\r\nconst\r\n{$EXTERNALSYM TASK_LAST_WEEK}\r\n TASK_LAST_WEEK = 5;\r\nconst\r\n{$EXTERNALSYM TASK_JANUARY}\r\n TASK_JANUARY = $1;\r\nconst\r\n{$EXTERNALSYM TASK_FEBRUARY}\r\n TASK_FEBRUARY = $2;\r\nconst\r\n{$EXTERNALSYM TASK_MARCH}\r\n TASK_MARCH = $4;\r\nconst\r\n{$EXTERNALSYM TASK_APRIL}\r\n TASK_APRIL = $8;\r\nconst\r\n{$EXTERNALSYM TASK_MAY}\r\n TASK_MAY = $10;\r\nconst\r\n{$EXTERNALSYM TASK_JUNE}\r\n TASK_JUNE = $20;\r\nconst\r\n{$EXTERNALSYM TASK_JULY}\r\n TASK_JULY = $40;\r\nconst\r\n{$EXTERNALSYM TASK_AUGUST}\r\n TASK_AUGUST = $80;\r\nconst\r\n{$EXTERNALSYM TASK_SEPTEMBER}\r\n TASK_SEPTEMBER = $100;\r\nconst\r\n{$EXTERNALSYM TASK_OCTOBER}\r\n TASK_OCTOBER = $200;\r\nconst\r\n{$EXTERNALSYM TASK_NOVEMBER}\r\n TASK_NOVEMBER = $400;\r\nconst\r\n{$EXTERNALSYM TASK_DECEMBER}\r\n TASK_DECEMBER = $800;\r\n\r\nconst\r\n{$EXTERNALSYM TASK_FLAG_INTERACTIVE}\r\n TASK_FLAG_INTERACTIVE = $1;\r\nconst\r\n{$EXTERNALSYM TASK_FLAG_DELETE_WHEN_DONE}\r\n TASK_FLAG_DELETE_WHEN_DONE = $2;\r\nconst\r\n{$EXTERNALSYM TASK_FLAG_DISABLED}\r\n TASK_FLAG_DISABLED = $4;\r\nconst\r\n{$EXTERNALSYM TASK_FLAG_START_ONLY_IF_IDLE}\r\n TASK_FLAG_START_ONLY_IF_IDLE = $10;\r\nconst\r\n{$EXTERNALSYM TASK_FLAG_KILL_ON_IDLE_END}\r\n TASK_FLAG_KILL_ON_IDLE_END = $20;\r\nconst\r\n{$EXTERNALSYM TASK_FLAG_DONT_START_IF_ON_BATTERIES}\r\n TASK_FLAG_DONT_START_IF_ON_BATTERIES = $40;\r\nconst\r\n{$EXTERNALSYM TASK_FLAG_KILL_IF_GOING_ON_BATTERIES}\r\n TASK_FLAG_KILL_IF_GOING_ON_BATTERIES = $80;\r\nconst\r\n{$EXTERNALSYM TASK_FLAG_RUN_ONLY_IF_DOCKED}\r\n TASK_FLAG_RUN_ONLY_IF_DOCKED = $100;\r\nconst\r\n{$EXTERNALSYM TASK_FLAG_HIDDEN}\r\n TASK_FLAG_HIDDEN = $200;\r\nconst\r\n{$EXTERNALSYM TASK_FLAG_RUN_IF_CONNECTED_TO_INTERNET}\r\n TASK_FLAG_RUN_IF_CONNECTED_TO_INTERNET = $400;\r\nconst\r\n{$EXTERNALSYM TASK_FLAG_RESTART_ON_IDLE_RESUME}\r\n TASK_FLAG_RESTART_ON_IDLE_RESUME = $800;\r\nconst\r\n{$EXTERNALSYM TASK_FLAG_SYSTEM_REQUIRED}\r\n TASK_FLAG_SYSTEM_REQUIRED = $1000;\r\nconst\r\n{$EXTERNALSYM TASK_FLAG_RUN_ONLY_IF_LOGGED_ON}\r\n TASK_FLAG_RUN_ONLY_IF_LOGGED_ON = $2000;\r\n\r\nconst\r\n{$EXTERNALSYM TASK_TRIGGER_FLAG_HAS_END_DATE}\r\n TASK_TRIGGER_FLAG_HAS_END_DATE = $1;\r\nconst\r\n{$EXTERNALSYM TASK_TRIGGER_FLAG_KILL_AT_DURATION_END}\r\n TASK_TRIGGER_FLAG_KILL_AT_DURATION_END = $2;\r\nconst\r\n{$EXTERNALSYM TASK_TRIGGER_FLAG_DISABLED}\r\n TASK_TRIGGER_FLAG_DISABLED = $4;\r\n\r\n//\r\n// 1440 = 60 mins/hour * 24 hrs/day since a trigger/TASK could run all day at\r\n// one minute intervals.\r\n//\r\n\r\nconst\r\n{$EXTERNALSYM TASK_MAX_RUN_TIMES}\r\n TASK_MAX_RUN_TIMES: Integer = 1440;\r\n\r\n//\r\n// The TASK_TRIGGER_TYPE field of the TASK_TRIGGER structure determines\r\n// which member of the TRIGGER_TYPE_UNION field to use.\r\n//\r\ntype\r\n{$EXTERNALSYM _TASK_TRIGGER_TYPE}\r\n _TASK_TRIGGER_TYPE = (\r\n{$EXTERNALSYM TASK_TIME_TRIGGER_ONCE}\r\n TASK_TIME_TRIGGER_ONCE, // 0 // Ignore the Type field.\r\n{$EXTERNALSYM TASK_TIME_TRIGGER_DAILY}\r\n TASK_TIME_TRIGGER_DAILY, // 1 // Use DAILY\r\n{$EXTERNALSYM TASK_TIME_TRIGGER_WEEKLY}\r\n TASK_TIME_TRIGGER_WEEKLY, // 2 // Use WEEKLY\r\n{$EXTERNALSYM TASK_TIME_TRIGGER_MONTHLYDATE}\r\n TASK_TIME_TRIGGER_MONTHLYDATE, // 3 // Use MONTHLYDATE\r\n{$EXTERNALSYM TASK_TIME_TRIGGER_MONTHLYDOW}\r\n TASK_TIME_TRIGGER_MONTHLYDOW, // 4 // Use MONTHLYDOW\r\n{$EXTERNALSYM TASK_EVENT_TRIGGER_ON_IDLE}\r\n TASK_EVENT_TRIGGER_ON_IDLE, // 5 // Ignore the Type field.\r\n{$EXTERNALSYM TASK_EVENT_TRIGGER_AT_SYSTEMSTART}\r\n TASK_EVENT_TRIGGER_AT_SYSTEMSTART, // 6 // Ignore the Type field.\r\n{$EXTERNALSYM TASK_EVENT_TRIGGER_AT_LOGON}\r\n TASK_EVENT_TRIGGER_AT_LOGON // 7 // Ignore the Type field.\r\n );\r\n{$EXTERNALSYM TASK_TRIGGER_TYPE}\r\n TASK_TRIGGER_TYPE = _TASK_TRIGGER_TYPE;\r\n TTaskTriggerType = _TASK_TRIGGER_TYPE;\r\n\r\n{$EXTERNALSYM PTASK_TRIGGER_TYPE}\r\n PTASK_TRIGGER_TYPE = ^_TASK_TRIGGER_TYPE;\r\n PTaskTriggerType = ^_TASK_TRIGGER_TYPE;\r\n\r\n\r\ntype\r\n{$EXTERNALSYM _DAILY}\r\n _DAILY = packed record\r\n DaysInterval: WORD;\r\n end;\r\n{$EXTERNALSYM DAILY}\r\n DAILY = _DAILY;\r\n TDaily = _DAILY;\r\n\r\n\r\ntype\r\n{$EXTERNALSYM _WEEKLY}\r\n _WEEKLY = packed record\r\n WeeksInterval: WORD;\r\n rgfDaysOfTheWeek: WORD;\r\n end;\r\n{$EXTERNALSYM WEEKLY}\r\n WEEKLY = _WEEKLY;\r\n TWeekly = _WEEKLY;\r\n\r\n\r\ntype\r\n{$EXTERNALSYM _MONTHLYDATE}\r\n _MONTHLYDATE = packed record\r\n rgfDays: DWORD;\r\n rgfMonths: WORD;\r\n end;\r\n{$EXTERNALSYM MONTHLYDATE}\r\n MONTHLYDATE = _MONTHLYDATE;\r\n TMonthlyDate = _MONTHLYDATE; // OS: Changed capitalization\r\n\r\n\r\ntype\r\n{$EXTERNALSYM _MONTHLYDOW}\r\n _MONTHLYDOW = packed record\r\n wWhichWeek: WORD;\r\n rgfDaysOfTheWeek: WORD;\r\n rgfMonths: WORD;\r\n end;\r\n{$EXTERNALSYM MONTHLYDOW}\r\n MONTHLYDOW = _MONTHLYDOW;\r\n TMonthlyDOW = _MONTHLYDOW; // OS: Changed capitalization\r\n\r\n\r\ntype\r\n{$EXTERNALSYM _TRIGGER_TYPE_UNION}\r\n _TRIGGER_TYPE_UNION = packed record\r\n case Integer of\r\n 0: (Daily: DAILY);\r\n 1: (Weekly: WEEKLY);\r\n 2: (MonthlyDate: MONTHLYDATE);\r\n 3: (MonthlyDOW: MONTHLYDOW);\r\n end;\r\n{$EXTERNALSYM TRIGGER_TYPE_UNION}\r\n TRIGGER_TYPE_UNION = _TRIGGER_TYPE_UNION;\r\n TTriggerTypeUnion = _TRIGGER_TYPE_UNION;\r\n\r\n\r\ntype\r\n{$EXTERNALSYM _TASK_TRIGGER}\r\n _TASK_TRIGGER = record // SP: removed packed record statement as seemed to affect SetTrigger\r\n cbTriggerSize: WORD; // Structure size.\r\n Reserved1: WORD; // Reserved. Must be zero.\r\n wBeginYear: WORD; // Trigger beginning date year.\r\n wBeginMonth: WORD; // Trigger beginning date month.\r\n wBeginDay: WORD; // Trigger beginning date day.\r\n wEndYear: WORD; // Optional trigger ending date year.\r\n wEndMonth: WORD; // Optional trigger ending date month.\r\n wEndDay: WORD; // Optional trigger ending date day.\r\n wStartHour: WORD; // Run bracket start time hour.\r\n wStartMinute: WORD; // Run bracket start time minute.\r\n MinutesDuration: DWORD; // Duration of run bracket.\r\n MinutesInterval: DWORD; // Run bracket repetition interval.\r\n rgFlags: DWORD; // Trigger flags.\r\n TriggerType: TASK_TRIGGER_TYPE; // Trigger type.\r\n Type_: TRIGGER_TYPE_UNION; // Trigger data.\r\n Reserved2: WORD; // Reserved. Must be zero.\r\n wRandomMinutesInterval: WORD; // Maximum number of random minutes\r\n // after start time.\r\n\r\n end;\r\n{$EXTERNALSYM TASK_TRIGGER}\r\n\r\n TASK_TRIGGER = _TASK_TRIGGER;\r\n TTaskTrigger = _TASK_TRIGGER;\r\n\r\n{$EXTERNALSYM PTASK_TRIGGER}\r\n PTASK_TRIGGER = ^_TASK_TRIGGER;\r\n PTaskTrigger = ^_TASK_TRIGGER;\r\n\r\n\r\n//+----------------------------------------------------------------------------\r\n//\r\n// Interfaces\r\n//\r\n//-----------------------------------------------------------------------------\r\n\r\n//+----------------------------------------------------------------------------\r\n//\r\n// Interface: ITaskTrigger\r\n//\r\n// Synopsis: Trigger object interface. A Task object may contain several\r\n// of these.\r\n//\r\n//-----------------------------------------------------------------------------\r\n// {148BD52B-A2AB-11CE-B11F-00AA00530503}\r\nconst\r\n{$EXTERNALSYM IID_ITaskTrigger}\r\n IID_ITaskTrigger: TIID = (D1: $148BD52B; D2: $A2AB; D3: $11CE; D4: ($B1, $1F, $00, $AA, $00, $53, $05, $03));\r\n\r\n\r\n// interface ITaskTrigger;\r\ntype\r\n{$EXTERNALSYM ITaskTrigger}\r\n ITaskTrigger = interface(IUnknown)\r\n ['{148BD52B-A2AB-11CE-B11F-00AA00530503}']\r\n// Methods:\r\n function SetTrigger(const pTrigger: TTaskTrigger): HRESULT; stdcall;\r\n (*| Parameter(s) was/were [CPP]: {in} const PTASK_TRIGGER pTrigger |*)\r\n function GetTrigger(out pTrigger: TTaskTrigger): HRESULT; stdcall;\r\n (*| Parameter(s) was/were [CPP]: {out} PTASK_TRIGGER pTrigger |*)\r\n function GetTriggerString(out ppwszTrigger: LPWSTR): HRESULT; stdcall;\r\n (*| Parameter(s) was/were [CPP]: {out} LPWSTR * ppwszTrigger |*)\r\n end;\r\n\r\n//+----------------------------------------------------------------------------\r\n//\r\n// Interface: IScheduledWorkItem\r\n//\r\n// Synopsis: Abstract base class for any runnable work item that can be\r\n// scheduled by the task scheduler.\r\n//\r\n//-----------------------------------------------------------------------------\r\n// {a6b952f0-a4b1-11d0-997d-00aa006887ec}\r\nconst\r\n{$EXTERNALSYM IID_IScheduledWorkItem}\r\n IID_IScheduledWorkItem: TIID = (D1: $A6B952F0; D2: $A4B1; D3: $11D0; D4: ($99, $7D, $00, $AA, $00, $68, $87, $EC));\r\n\r\n\r\n// interface IScheduledWorkItem;\r\ntype\r\n{$EXTERNALSYM IScheduledWorkItem}\r\n IScheduledWorkItem = interface(IUnknown)\r\n ['{A6B952F0-A4B1-11D0-997D-00AA006887EC}']\r\n// Methods concerning scheduling:\r\n function CreateTrigger(out piNewTrigger: WORD; out ppTrigger: ITaskTrigger): HRESULT; stdcall;\r\n (*| Parameter(s) was/were [CPP]: {out} WORD * piNewTrigger, {out} ITaskTrigger ** ppTrigger |*)\r\n function DeleteTrigger(iTrigger: WORD): HRESULT; stdcall;\r\n (*| Parameter(s) was/were [CPP]: {in} WORD iTrigger |*)\r\n function GetTriggerCount(out pwCount: WORD): HRESULT; stdcall;\r\n (*| Parameter(s) was/were [CPP]: {out} WORD * pwCount |*)\r\n function GetTrigger(iTrigger: WORD; out ppTrigger: ITaskTrigger): HRESULT; stdcall;\r\n (*| Parameter(s) was/were [CPP]: {in} WORD iTrigger, {out} ITaskTrigger ** ppTrigger |*)\r\n function GetTriggerString(iTrigger: WORD; out ppwszTrigger: LPWSTR): HRESULT; stdcall;\r\n (*| Parameter(s) was/were [CPP]: {in} WORD iTrigger, {out} LPWSTR * ppwszTrigger |*)\r\n function GetRunTimes(pstBegin: PSystemTime; pstEnd: PSystemTime; var pCount: WORD; out rgstTaskTimes: PSystemTime): HRESULT; stdcall;\r\n (*| Parameter(s) was/were [CPP]: {in} const LPSYSTEMTIME pstBegin, {in} const LPSYSTEMTIME pstEnd, {in; out} WORD * pCount, {out} LPSYSTEMTIME * rgstTaskTimes |*)\r\n function GetNextRunTime(var pstNextRun: SYSTEMTIME): HRESULT; stdcall;\r\n (*| Parameter(s) was/were [CPP]: {in; out} SYSTEMTIME * pstNextRun |*)\r\n function SetIdleWait(wIdleMinutes: WORD; wDeadlineMinutes: WORD): HRESULT; stdcall;\r\n (*| Parameter(s) was/were [CPP]: {in} WORD wIdleMinutes, {in} WORD wDeadlineMinutes |*)\r\n function GetIdleWait(out pwIdleMinutes: WORD; out pwDeadlineMinutes: WORD): HRESULT; stdcall;\r\n (*| Parameter(s) was/were [CPP]: {out} WORD * pwIdleMinutes, {out} WORD * pwDeadlineMinutes |*)\r\n// Other methods:\r\n function Run(): HRESULT; stdcall;\r\n function Terminate(): HRESULT; stdcall;\r\n function EditWorkItem(hParent: HWND; dwReserved: DWORD): HRESULT; stdcall;\r\n (*| Parameter(s) was/were [CPP]: {in} HWND hParent, {in} DWORD dwReserved |*)\r\n function GetMostRecentRunTime(out pstLastRun: SYSTEMTIME): HRESULT; stdcall;\r\n (*| Parameter(s) was/were [CPP]: {out} SYSTEMTIME * pstLastRun |*)\r\n function GetStatus(out phrStatus: HRESULT): HRESULT; stdcall;\r\n (*| Parameter(s) was/were [CPP]: {out} HRESULT * phrStatus |*)\r\n function GetExitCode(out pdwExitCode: DWORD): HRESULT; stdcall;\r\n (*| Parameter(s) was/were [CPP]: {out} DWORD * pdwExitCode |*)\r\n// Properties:\r\n function SetComment(pwszComment: LPCWSTR): HRESULT; stdcall;\r\n (*| Parameter(s) was/were [CPP]: {in} LPCWSTR pwszComment |*)\r\n function GetComment(out ppwszComment: LPWSTR): HRESULT; stdcall;\r\n (*| Parameter(s) was/were [CPP]: {out} LPWSTR * ppwszComment |*)\r\n function SetCreator(pwszCreator: LPCWSTR): HRESULT; stdcall;\r\n (*| Parameter(s) was/were [CPP]: {in} LPCWSTR pwszCreator |*)\r\n function GetCreator(out ppwszCreator: LPWSTR): HRESULT; stdcall;\r\n (*| Parameter(s) was/were [CPP]: {out} LPWSTR * ppwszCreator |*)\r\n function SetWorkItemData(cbData: WORD; rgbData: PByte): HRESULT; stdcall;\r\n (*| Parameter(s) was/were [CPP]: {in} WORD cbData, {in} BYTE rgbData[] |*)\r\n function GetWorkItemData(out pcbData: WORD; out prgbData: PByte): HRESULT; stdcall;\r\n (*| Parameter(s) was/were [CPP]: {out} WORD * pcbData, {out} BYTE ** prgbData |*)\r\n function SetErrorRetryCount(wRetryCount: WORD): HRESULT; stdcall;\r\n (*| Parameter(s) was/were [CPP]: {in} WORD wRetryCount |*)\r\n function GetErrorRetryCount(out pwRetryCount: WORD): HRESULT; stdcall;\r\n (*| Parameter(s) was/were [CPP]: {out} WORD * pwRetryCount |*)\r\n function SetErrorRetryInterval(wRetryInterval: WORD): HRESULT; stdcall;\r\n (*| Parameter(s) was/were [CPP]: {in} WORD wRetryInterval |*)\r\n function GetErrorRetryInterval(out pwRetryInterval: WORD): HRESULT; stdcall;\r\n (*| Parameter(s) was/were [CPP]: {out} WORD * pwRetryInterval |*)\r\n function SetFlags(dwFlags: DWORD): HRESULT; stdcall;\r\n (*| Parameter(s) was/were [CPP]: {in} DWORD dwFlags |*)\r\n function GetFlags(out pdwFlags: DWORD): HRESULT; stdcall;\r\n (*| Parameter(s) was/were [CPP]: {out} DWORD * pdwFlags |*)\r\n function SetAccountInformation(pwszAccountName: LPCWSTR; pwszPassword: LPCWSTR): HRESULT; stdcall;\r\n (*| Parameter(s) was/were [CPP]: {in} LPCWSTR pwszAccountName, {in} LPCWSTR pwszPassword |*)\r\n function GetAccountInformation(out ppwszAccountName: LPWSTR): HRESULT; stdcall;\r\n (*| Parameter(s) was/were [CPP]: {out} LPWSTR * ppwszAccountName |*)\r\n end;\r\n\r\n//+----------------------------------------------------------------------------\r\n//\r\n// Interface: ITask\r\n//\r\n// Synopsis: Task object interface. The primary means of task object\r\n// manipulation.\r\n//\r\n//-----------------------------------------------------------------------------\r\n// {148BD524-A2AB-11CE-B11F-00AA00530503}\r\nconst\r\n{$EXTERNALSYM IID_ITask}\r\n IID_ITask: TIID = (D1: $148BD524; D2: $A2AB; D3: $11CE; D4: ($B1, $1F, $00, $AA, $00, $53, $05, $03));\r\n\r\n\r\n// interface ITask;\r\ntype\r\n{$EXTERNALSYM ITask}\r\n ITask = interface(IScheduledWorkItem)\r\n ['{148BD524-A2AB-11CE-B11F-00AA00530503}']\r\n// Properties that correspond to parameters of CreateProcess:\r\n function SetApplicationName(pwszApplicationName: LPCWSTR): HRESULT; stdcall;\r\n (*| Parameter(s) was/were [CPP]: {in} LPCWSTR pwszApplicationName |*)\r\n function GetApplicationName(out ppwszApplicationName: LPWSTR): HRESULT; stdcall;\r\n (*| Parameter(s) was/were [CPP]: {out} LPWSTR * ppwszApplicationName |*)\r\n function SetParameters(pwszParameters: LPCWSTR): HRESULT; stdcall;\r\n (*| Parameter(s) was/were [CPP]: {in} LPCWSTR pwszParameters |*)\r\n function GetParameters(out ppwszParameters: LPWSTR): HRESULT; stdcall;\r\n (*| Parameter(s) was/were [CPP]: {out} LPWSTR * ppwszParameters |*)\r\n function SetWorkingDirectory(pwszWorkingDirectory: LPCWSTR): HRESULT; stdcall;\r\n (*| Parameter(s) was/were [CPP]: {in} LPCWSTR pwszWorkingDirectory |*)\r\n function GetWorkingDirectory(out ppwszWorkingDirectory: LPWSTR): HRESULT; stdcall;\r\n (*| Parameter(s) was/were [CPP]: {out} LPWSTR * ppwszWorkingDirectory |*)\r\n function SetPriority(dwPriority: DWORD): HRESULT; stdcall;\r\n (*| Parameter(s) was/were [CPP]: {in} DWORD dwPriority |*)\r\n function GetPriority(out pdwPriority: DWORD): HRESULT; stdcall;\r\n (*| Parameter(s) was/were [CPP]: {out} DWORD * pdwPriority |*)\r\n// Other properties:\r\n function SetTaskFlags(dwFlags: DWORD): HRESULT; stdcall;\r\n (*| Parameter(s) was/were [CPP]: {in} DWORD dwFlags |*)\r\n function GetTaskFlags(out pdwFlags: DWORD): HRESULT; stdcall;\r\n (*| Parameter(s) was/were [CPP]: {out} DWORD * pdwFlags |*)\r\n function SetMaxRunTime(dwMaxRunTimeMS: DWORD): HRESULT; stdcall;\r\n (*| Parameter(s) was/were [CPP]: {in} DWORD dwMaxRunTimeMS |*)\r\n function GetMaxRunTime(out pdwMaxRunTimeMS: DWORD): HRESULT; stdcall;\r\n (*| Parameter(s) was/were [CPP]: {out} DWORD * pdwMaxRunTimeMS |*)\r\n end;\r\n\r\n//+----------------------------------------------------------------------------\r\n//\r\n// Interface: IEnumWorkItems\r\n//\r\n// Synopsis: Work item object enumerator. Enumerates the work item objects\r\n// within the Tasks folder.\r\n//\r\n//-----------------------------------------------------------------------------\r\n// {148BD528-A2AB-11CE-B11F-00AA00530503}\r\nconst\r\n{$EXTERNALSYM IID_IEnumWorkItems}\r\n IID_IEnumWorkItems: TIID = (D1: $148BD528; D2: $A2AB; D3: $11CE; D4: ($B1, $1F, $00, $AA, $00, $53, $05, $03));\r\n\r\n\r\n// interface IEnumWorkItems;\r\ntype\r\n{$EXTERNALSYM IEnumWorkItems}\r\n IEnumWorkItems = interface(IUnknown)\r\n ['{148BD528-A2AB-11CE-B11F-00AA00530503}']\r\n// Methods:\r\n function Next(celt: ULONG; out rgpwszNames: PLPWSTR; out pceltFetched: ULONG): HRESULT; stdcall;\r\n (*| Parameter(s) was/were [CPP]: {in} ULONG celt, {out} LPWSTR ** rgpwszNames, {out} ULONG * pceltFetched |*)\r\n function Skip(celt: ULONG): HRESULT; stdcall;\r\n (*| Parameter(s) was/were [CPP]: {in} ULONG celt |*)\r\n function Reset(): HRESULT; stdcall;\r\n function Clone(out ppEnumWorkItems: IEnumWorkItems): HRESULT; stdcall;\r\n (*| Parameter(s) was/were [CPP]: {out} IEnumWorkItems ** ppEnumWorkItems |*)\r\n end;\r\n\r\n//+----------------------------------------------------------------------------\r\n//\r\n// Interface: ITaskScheduler\r\n//\r\n// Synopsis: Task Scheduler interface. Provides location transparent\r\n// manipulation of task and/or queue objects within the Tasks\r\n// folder.\r\n//\r\n//-----------------------------------------------------------------------------\r\n// {148BD527-A2AB-11CE-B11F-00AA00530503}\r\nconst\r\n{$EXTERNALSYM IID_ITaskScheduler}\r\n IID_ITaskScheduler: TIID = (D1: $148BD527; D2: $A2AB; D3: $11CE; D4: ($B1, $1F, $00, $AA, $00, $53, $05, $03));\r\n\r\n\r\n// interface ITaskScheduler;\r\ntype\r\n{$EXTERNALSYM ITaskScheduler}\r\n ITaskScheduler = interface(IUnknown)\r\n ['{148BD527-A2AB-11CE-B11F-00AA00530503}']\r\n// Methods:\r\n function SetTargetComputer(pwszComputer: LPCWSTR): HRESULT; stdcall;\r\n (*| Parameter(s) was/were [CPP]: {in} LPCWSTR pwszComputer |*)\r\n function GetTargetComputer(out ppwszComputer: LPWSTR): HRESULT; stdcall;\r\n (*| Parameter(s) was/were [CPP]: {out} LPWSTR * ppwszComputer |*)\r\n function Enum(out ppEnumWorkItems: IEnumWorkItems): HRESULT; stdcall;\r\n (*| Parameter(s) was/were [CPP]: {out} IEnumWorkItems ** ppEnumWorkItems |*)\r\n function Activate(pwszName: LPCWSTR; const riid: TIID; out ppUnk: IUnknown): HRESULT; stdcall;\r\n (*| Parameter(s) was/were [CPP]: {in} LPCWSTR pwszName, {in} REFIID riid, {out} IUnknown ** ppUnk |*)\r\n function Delete(pwszName: LPCWSTR): HRESULT; stdcall;\r\n (*| Parameter(s) was/were [CPP]: {in} LPCWSTR pwszName |*)\r\n function NewWorkItem(pwszTaskName: LPCWSTR; const rclsid: TCLSID; const riid: TIID; out ppUnk: IUnknown): HRESULT; stdcall;\r\n (*| Parameter(s) was/were [CPP]: {in} LPCWSTR pwszTaskName, {in} REFCLSID rclsid, {in} REFIID riid, {out} IUnknown ** ppUnk |*)\r\n function AddWorkItem(pwszTaskName: LPCWSTR; const pWorkItem: IScheduledWorkItem): HRESULT; stdcall;\r\n (*| Parameter(s) was/were [CPP]: {in} LPCWSTR pwszTaskName, {in} IScheduledWorkItem * pWorkItem |*)\r\n function IsOfType(pwszName: LPCWSTR; const riid: TIID): HRESULT; stdcall;\r\n (*| Parameter(s) was/were [CPP]: {in} LPCWSTR pwszName, {in} REFIID riid |*)\r\n end;\r\n\r\n// EXTERN_C const CLSID CLSID_CTask;\r\n// EXTERN_C const CLSID CLSID_CTaskScheduler;\r\n\r\n// {148BD520-A2AB-11CE-B11F-00AA00530503}\r\nconst\r\n{$EXTERNALSYM CLSID_CTask}\r\n CLSID_CTask: TCLSID = (D1: $148BD520; D2: $A2AB; D3: $11CE; D4: ($B1, $1F, $00, $AA, $00, $53, $05, $03));\r\n\r\n// {148BD52A-A2AB-11CE-B11F-00AA00530503}\r\nconst\r\n{$EXTERNALSYM CLSID_CTaskScheduler}\r\n CLSID_CTaskScheduler: TCLSID = (D1: $148BD52A; D2: $A2AB; D3: $11CE; D4: ($B1, $1F, $00, $AA, $00, $53, $05, $03));\r\n\r\n\r\n\r\n//\r\n// NOTE: Definition of HPROPSHEETPAGE is from sdk\\inc\\prsht.h\r\n// Including this header file causes numerous redefinition errors.\r\n//\r\n\r\ntype\r\n{$EXTERNALSYM _PSP}\r\n _PSP = record end;\r\n\r\n{$IFNDEF FPC}\r\ntype\r\n{$EXTERNALSYM HPROPSHEETPAGE}\r\n HPROPSHEETPAGE = ^_PSP;\r\n{$ENDIF ~FPC}\r\n\r\ntype\r\n{$EXTERNALSYM _TASKPAGE}\r\n _TASKPAGE = (\r\n{$EXTERNALSYM TASKPAGE_TASK}\r\n TASKPAGE_TASK, // 0\r\n{$EXTERNALSYM TASKPAGE_SCHEDULE}\r\n TASKPAGE_SCHEDULE, // 1\r\n{$EXTERNALSYM TASKPAGE_SETTINGS}\r\n TASKPAGE_SETTINGS // 2\r\n );\r\n{$EXTERNALSYM TASKPAGE}\r\n TASKPAGE = _TASKPAGE;\r\n TTaskPage = _TASKPAGE; // OS: Changed capitalization\r\n\r\n\r\n//+----------------------------------------------------------------------------\r\n//\r\n// Interface: IProvideTaskPage\r\n//\r\n// Synopsis: Task property page retrieval interface. With this interface,\r\n// it is possible to retrieve one or more property pages\r\n// associated with a task object. Task objects inherit this\r\n// interface.\r\n//\r\n//-----------------------------------------------------------------------------\r\n// {4086658a-cbbb-11cf-b604-00c04fd8d565}\r\nconst\r\n{$EXTERNALSYM IID_IProvideTaskPage}\r\n IID_IProvideTaskPage: TIID = (D1: $4086658A; D2: $CBBB; D3: $11CF; D4: ($B6, $04, $00, $C0, $4F, $D8, $D5, $65));\r\n\r\n\r\n// interface IProvideTaskPage;\r\ntype\r\n{$EXTERNALSYM IProvideTaskPage}\r\n IProvideTaskPage = interface(IUnknown)\r\n ['{4086658A-CBBB-11CF-B604-00C04FD8D565}']\r\n// Methods:\r\n function GetPage(tpType: TTaskPage; fPersistChanges: BOOL; out phPage: HPROPSHEETPAGE): HRESULT; stdcall; // OS: Changed TASKPAGE to TTaskPage\r\n (*| Parameter(s) was/were [CPP]: {in} TASKPAGE tpType, {in} BOOL fPersistChanges, {out} HPROPSHEETPAGE * phPage |*)\r\n end;\r\n\r\n\r\ntype\r\n{$EXTERNALSYM ISchedulingAgent}\r\n ISchedulingAgent = ITaskScheduler;\r\n\r\ntype\r\n{$EXTERNALSYM IEnumTasks}\r\n IEnumTasks = IEnumWorkItems;\r\n\r\nconst\r\n{$EXTERNALSYM IID_ISchedulingAgent}\r\n IID_ISchedulingAgent: TIID = (D1: $148BD527; D2: $A2AB; D3: $11CE; D4: ($B1, $1F, $00, $AA, $00, $53, $05, $03));\r\n\r\nconst\r\n{$EXTERNALSYM CLSID_CSchedulingAgent}\r\n CLSID_CSchedulingAgent: TCLSID = (D1: $148BD52A; D2: $A2AB; D3: $11CE; D4: ($B1, $1F, $00, $AA, $00, $53, $05, $03));\r\n\r\n//DOM-IGNORE-END\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jcl.svn.sourceforge.net/svnroot/jcl/tags/JCL-2.4-Build4571/jcl/source/windows/MSTask.pas $';\r\n Revision: '$Revision: 3599 $';\r\n Date: '$Date: 2011-09-03 00:07:50 +0200 (sam. 03 sept. 2011) $';\r\n LogPath: 'JCL\\source\\windows';\r\n Extra: '';\r\n Data: nil\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n\r\n" }, { "path": "External/Jedi/Jcl/source/windows/Snmp.pas", "content": "{**************************************************************************************************}\r\n{ }\r\n{ Delphi Runtime Library }\r\n{ SNMP functions interface unit }\r\n{ }\r\n{ The contents of this file are subject to the Mozilla Public License Version 1.1 (the \"License\") }\r\n{ you may not use this file except in compliance with the License. You may obtain a copy of the }\r\n{ License at http://www.mozilla.org/MPL/ }\r\n{ }\r\n{ Software distributed under the License is distributed on an \"AS IS\" basis, WITHOUT WARRANTY OF }\r\n{ ANY KIND, either express or implied. See the License for the specific language governing rights }\r\n{ and limitations under the License. }\r\n{ }\r\n{ The Original Code is: snmp.h. }\r\n{ The Initial Developer of the Original Code is Microsoft. Portions created by Microsoft are }\r\n{ Copyright (C) 1992-1999 Microsoft Corporation. All Rights Reserved. }\r\n{ }\r\n{ The Original Pascal code is: Snmp.pas, released 2001-10-05. }\r\n{ The Initial Developer of the Original Pascal code is Petr Vones }\r\n{ (petrdott v att mujmail dott cz). Portions created by Petr Vones are Copyright (C) 2001 Petr }\r\n{ Vones. All Rights Reserved. }\r\n{ }\r\n{ Obtained through: }\r\n{ Joint Endeavour of Delphi Innovators (Project JEDI) }\r\n{ }\r\n{ You may retrieve the latest version of this file at the Project JEDI homepage, located at }\r\n{ http://delphi-jedi.org }\r\n{ }\r\n{ Contributor(s): }\r\n{ }\r\n{**************************************************************************************************}\r\n{ }\r\n{ Last modified: $Date:: 2011-09-03 00:07:50 +0200 (sam. 03 sept. 2011) $ }\r\n{ Revision: $Rev:: 3599 $ }\r\n{ Author: $Author:: outchy $ }\r\n{ }\r\n{**************************************************************************************************}\r\n\r\nunit Snmp;\r\n\r\ninterface\r\n\r\n{$I jcl.inc}\r\n{$I windowsonly.inc}\r\n\r\n{$DEFINE SNMP_DYNAMIC_LINK}\r\n{$DEFINE SNMP_DYNAMIC_LINK_EXPLICIT}\r\n{$DEFINE SNMPSTRICT}\r\n\r\n{$ALIGN ON}\r\n{$MINENUMSIZE 4}\r\n\r\n{$IFNDEF SNMP_DYNAMIC_LINK}\r\n{$IFDEF SUPPORTS_WEAKPACKAGEUNIT}\r\n {$WEAKPACKAGEUNIT ON}\r\n{$ENDIF SUPPORTS_WEAKPACKAGEUNIT}\r\n{$ENDIF ~SNMP_DYNAMIC_LINK}\r\n\r\n{$IFDEF UNICODE}\r\n{$A4} // MANTIS 4931 - GetMacAddress crash in Delphi 2009. record alignment fix.\r\n{$ENDIF}\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n {$IFDEF HAS_UNITSCOPE}\r\n Winapi.Windows, System.SysUtils;\r\n {$ELSE ~HAS_UNITSCOPE}\r\n Windows, SysUtils;\r\n {$ENDIF ~HAS_UNITSCOPE}\r\n\r\n//DOM-IGNORE-BEGIN\r\n\r\n(*$HPPEMIT '#include '*)\r\n\r\ntype\r\n PAsnOctetString = ^TAsnOctetString;\r\n TAsnOctetString = record\r\n stream: PAnsiChar;\r\n length: UINT;\r\n dynamic_: Boolean;\r\n end;\r\n\r\n PAsnObjectIdentifier = ^TAsnObjectIdentifier;\r\n TAsnObjectIdentifier = record\r\n idLength: UINT;\r\n ids: PUINT;\r\n end;\r\n\r\n TAsnInteger32 = LongInt;\r\n {$EXTERNALSYM TAsnInteger32}\r\n TAsnUnsigned32 = ULONG;\r\n {$EXTERNALSYM TAsnUnsigned32}\r\n TAsnCounter64 = ULARGE_INTEGER;\r\n {$EXTERNALSYM TAsnCounter64}\r\n TAsnCounter32 = TAsnUnsigned32;\r\n {$EXTERNALSYM TAsnCounter32}\r\n TAsnGauge32 = TAsnUnsigned32;\r\n {$EXTERNALSYM TAsnGauge32}\r\n TAsnTimeticks = TAsnUnsigned32;\r\n {$EXTERNALSYM TAsnTimeticks}\r\n TAsnBits = TAsnOctetString;\r\n {$EXTERNALSYM TAsnBits}\r\n TAsnSequence = TAsnOctetString;\r\n {$EXTERNALSYM TAsnSequence}\r\n TAsnImplicitSequence = TAsnOctetString;\r\n {$EXTERNALSYM TAsnImplicitSequence}\r\n TAsnIPAddress = TAsnOctetString;\r\n {$EXTERNALSYM TAsnIPAddress}\r\n TAsnNetworkAddress = TAsnOctetString;\r\n {$EXTERNALSYM TAsnNetworkAddress}\r\n TAsnDisplayString = TAsnOctetString;\r\n {$EXTERNALSYM TAsnDisplayString}\r\n TAsnOpaque = TAsnOctetString;\r\n {$EXTERNALSYM TAsnOpaque}\r\n\r\n PAsnAny = ^TAsnAny;\r\n TAsnAny = record\r\n asnType: Byte;\r\n case Integer of\r\n 0: (number: TAsnInteger32); // ASN_INTEGER, ASN_INTEGER32\r\n 1: (unsigned32: TAsnUnsigned32); // ASN_UNSIGNED32\r\n 2: (counter64: TAsnCounter64); // ASN_COUNTER64\r\n 3: (string_: TAsnOctetString); // ASN_OCTETSTRING\r\n 4: (bits: TAsnBits); // ASN_BITS\r\n 5: (object_: TAsnObjectIdentifier); // ASN_OBJECTIDENTIFIER\r\n 6: (sequence: TAsnSequence); // ASN_SEQUENCE\r\n 7: (address: TAsnIPAddress); // ASN_IPADDRESS\r\n 8: (counter: TAsnCounter32); // ASN_COUNTER32\r\n 9: (gauge: TAsnGauge32); // ASN_GAUGE32\r\n 10: (ticks: TAsnTimeticks); // ASN_TIMETICKS\r\n 11: (arbitrary: TAsnOpaque); // ASN_OPAQUE\r\n end;\r\n\r\n TAsnObjectName = TAsnObjectIdentifier;\r\n TAsnObjectSyntax = TAsnAny;\r\n\r\n PSnmpVarBind = ^TSnmpVarBind;\r\n TSnmpVarBind = record\r\n name: TAsnObjectName;\r\n value: TAsnObjectSyntax;\r\n end;\r\n\r\n PSnmpVarBindList = ^TSnmpVarBindList;\r\n TSnmpVarBindList = record\r\n list: PSnmpVarBind;\r\n len: UINT;\r\n end;\r\n\r\nconst\r\n\r\n{ ASN/BER Base Types }\r\n\r\n ASN_UNIVERSAL = $00;\r\n {$EXTERNALSYM ASN_UNIVERSAL}\r\n ASN_APPLICATION = $40;\r\n {$EXTERNALSYM ASN_APPLICATION}\r\n ASN_CONTEXT = $80;\r\n {$EXTERNALSYM ASN_CONTEXT}\r\n ASN_PRIVATE = $C0;\r\n {$EXTERNALSYM ASN_PRIVATE}\r\n\r\n ASN_PRIMITIVE = $00;\r\n {$EXTERNALSYM ASN_PRIMITIVE}\r\n ASN_CONSTRUCTOR = $20;\r\n {$EXTERNALSYM ASN_CONSTRUCTOR}\r\n\r\n{ PDU Type Values }\r\n\r\n SNMP_PDU_GET = (ASN_CONTEXT or ASN_CONSTRUCTOR or $0);\r\n {$EXTERNALSYM SNMP_PDU_GET}\r\n SNMP_PDU_GETNEXT = (ASN_CONTEXT or ASN_CONSTRUCTOR or $1);\r\n {$EXTERNALSYM SNMP_PDU_GETNEXT}\r\n SNMP_PDU_RESPONSE = (ASN_CONTEXT or ASN_CONSTRUCTOR or $2);\r\n {$EXTERNALSYM SNMP_PDU_RESPONSE}\r\n SNMP_PDU_SET = (ASN_CONTEXT or ASN_CONSTRUCTOR or $3);\r\n {$EXTERNALSYM SNMP_PDU_SET}\r\n SNMP_PDU_V1TRAP = (ASN_CONTEXT or ASN_CONSTRUCTOR or $4);\r\n {$EXTERNALSYM SNMP_PDU_V1TRAP}\r\n SNMP_PDU_GETBULK = (ASN_CONTEXT or ASN_CONSTRUCTOR or $5);\r\n {$EXTERNALSYM SNMP_PDU_GETBULK}\r\n SNMP_PDU_INFORM = (ASN_CONTEXT or ASN_CONSTRUCTOR or $6);\r\n {$EXTERNALSYM SNMP_PDU_INFORM}\r\n SNMP_PDU_TRAP = (ASN_CONTEXT or ASN_CONSTRUCTOR or $7);\r\n {$EXTERNALSYM SNMP_PDU_TRAP}\r\n\r\n{ SNMP Simple Syntax Values }\r\n\r\n ASN_INTEGER = (ASN_UNIVERSAL or ASN_PRIMITIVE or $02);\r\n {$EXTERNALSYM ASN_INTEGER}\r\n ASN_BITS = (ASN_UNIVERSAL or ASN_PRIMITIVE or $03);\r\n {$EXTERNALSYM ASN_BITS}\r\n ASN_OCTETSTRING = (ASN_UNIVERSAL or ASN_PRIMITIVE or $04);\r\n {$EXTERNALSYM ASN_OCTETSTRING}\r\n ASN_NULL = (ASN_UNIVERSAL or ASN_PRIMITIVE or $05);\r\n {$EXTERNALSYM ASN_NULL}\r\n ASN_OBJECTIDENTIFIER = (ASN_UNIVERSAL or ASN_PRIMITIVE or $06);\r\n {$EXTERNALSYM ASN_OBJECTIDENTIFIER}\r\n ASN_INTEGER32 = ASN_INTEGER;\r\n {$EXTERNALSYM ASN_INTEGER32}\r\n\r\n{ SNMP Constructor Syntax Values }\r\n\r\n ASN_SEQUENCE = (ASN_UNIVERSAL or ASN_CONSTRUCTOR or $10);\r\n {$EXTERNALSYM ASN_SEQUENCE}\r\n ASN_SEQUENCEOF = ASN_SEQUENCE;\r\n {$EXTERNALSYM ASN_SEQUENCEOF}\r\n\r\n{ SNMP Application Syntax Values }\r\n\r\n ASN_IPADDRESS = (ASN_APPLICATION or ASN_PRIMITIVE or $00);\r\n {$EXTERNALSYM ASN_IPADDRESS}\r\n ASN_COUNTER32 = (ASN_APPLICATION or ASN_PRIMITIVE or $01);\r\n {$EXTERNALSYM ASN_COUNTER32}\r\n ASN_GAUGE32 = (ASN_APPLICATION or ASN_PRIMITIVE or $02);\r\n {$EXTERNALSYM ASN_GAUGE32}\r\n ASN_TIMETICKS = (ASN_APPLICATION or ASN_PRIMITIVE or $03);\r\n {$EXTERNALSYM ASN_TIMETICKS}\r\n ASN_OPAQUE = (ASN_APPLICATION or ASN_PRIMITIVE or $04);\r\n {$EXTERNALSYM ASN_OPAQUE}\r\n ASN_COUNTER64 = (ASN_APPLICATION or ASN_PRIMITIVE or $06);\r\n {$EXTERNALSYM ASN_COUNTER64}\r\n ASN_UNSIGNED32 = (ASN_APPLICATION or ASN_PRIMITIVE or $07);\r\n {$EXTERNALSYM ASN_UNSIGNED32}\r\n\r\n{ SNMP Exception Conditions }\r\n\r\n SNMP_EXCEPTION_NOSUCHOBJECT = (ASN_CONTEXT or ASN_PRIMITIVE or $00);\r\n {$EXTERNALSYM SNMP_EXCEPTION_NOSUCHOBJECT}\r\n SNMP_EXCEPTION_NOSUCHINSTANCE = (ASN_CONTEXT or ASN_PRIMITIVE or $01);\r\n {$EXTERNALSYM SNMP_EXCEPTION_NOSUCHINSTANCE}\r\n SNMP_EXCEPTION_ENDOFMIBVIEW = (ASN_CONTEXT or ASN_PRIMITIVE or $02);\r\n {$EXTERNALSYM SNMP_EXCEPTION_ENDOFMIBVIEW}\r\n\r\n{ SNMP Request Types (used in SnmpExtensionQueryEx) }\r\n\r\n SNMP_EXTENSION_GET = SNMP_PDU_GET;\r\n {$EXTERNALSYM SNMP_EXTENSION_GET}\r\n SNMP_EXTENSION_GET_NEXT = SNMP_PDU_GETNEXT;\r\n {$EXTERNALSYM SNMP_EXTENSION_GET_NEXT}\r\n SNMP_EXTENSION_GET_BULK = SNMP_PDU_GETBULK;\r\n {$EXTERNALSYM SNMP_EXTENSION_GET_BULK}\r\n SNMP_EXTENSION_SET_TEST = (ASN_PRIVATE or ASN_CONSTRUCTOR or $0);\r\n {$EXTERNALSYM SNMP_EXTENSION_SET_TEST}\r\n SNMP_EXTENSION_SET_COMMIT = SNMP_PDU_SET;\r\n {$EXTERNALSYM SNMP_EXTENSION_SET_COMMIT}\r\n SNMP_EXTENSION_SET_UNDO = (ASN_PRIVATE or ASN_CONSTRUCTOR or $1);\r\n {$EXTERNALSYM SNMP_EXTENSION_SET_UNDO}\r\n SNMP_EXTENSION_SET_CLEANUP = (ASN_PRIVATE or ASN_CONSTRUCTOR or $2);\r\n {$EXTERNALSYM SNMP_EXTENSION_SET_CLEANUP}\r\n\r\n{ SNMP Error Codes }\r\n\r\n SNMP_ERRORSTATUS_NOERROR = 0;\r\n {$EXTERNALSYM SNMP_ERRORSTATUS_NOERROR}\r\n SNMP_ERRORSTATUS_TOOBIG = 1;\r\n {$EXTERNALSYM SNMP_ERRORSTATUS_TOOBIG}\r\n SNMP_ERRORSTATUS_NOSUCHNAME = 2;\r\n {$EXTERNALSYM SNMP_ERRORSTATUS_NOSUCHNAME}\r\n SNMP_ERRORSTATUS_BADVALUE = 3;\r\n {$EXTERNALSYM SNMP_ERRORSTATUS_BADVALUE}\r\n SNMP_ERRORSTATUS_READONLY = 4;\r\n {$EXTERNALSYM SNMP_ERRORSTATUS_READONLY}\r\n SNMP_ERRORSTATUS_GENERR = 5;\r\n {$EXTERNALSYM SNMP_ERRORSTATUS_GENERR}\r\n SNMP_ERRORSTATUS_NOACCESS = 6;\r\n {$EXTERNALSYM SNMP_ERRORSTATUS_NOACCESS}\r\n SNMP_ERRORSTATUS_WRONGTYPE = 7;\r\n {$EXTERNALSYM SNMP_ERRORSTATUS_WRONGTYPE}\r\n SNMP_ERRORSTATUS_WRONGLENGTH = 8;\r\n {$EXTERNALSYM SNMP_ERRORSTATUS_WRONGLENGTH}\r\n SNMP_ERRORSTATUS_WRONGENCODING = 9;\r\n {$EXTERNALSYM SNMP_ERRORSTATUS_WRONGENCODING}\r\n SNMP_ERRORSTATUS_WRONGVALUE = 10;\r\n {$EXTERNALSYM SNMP_ERRORSTATUS_WRONGVALUE}\r\n SNMP_ERRORSTATUS_NOCREATION = 11;\r\n {$EXTERNALSYM SNMP_ERRORSTATUS_NOCREATION}\r\n SNMP_ERRORSTATUS_INCONSISTENTVALUE = 12;\r\n {$EXTERNALSYM SNMP_ERRORSTATUS_INCONSISTENTVALUE}\r\n SNMP_ERRORSTATUS_RESOURCEUNAVAILABLE = 13;\r\n {$EXTERNALSYM SNMP_ERRORSTATUS_RESOURCEUNAVAILABLE}\r\n SNMP_ERRORSTATUS_COMMITFAILED = 14;\r\n {$EXTERNALSYM SNMP_ERRORSTATUS_COMMITFAILED}\r\n SNMP_ERRORSTATUS_UNDOFAILED = 15;\r\n {$EXTERNALSYM SNMP_ERRORSTATUS_UNDOFAILED}\r\n SNMP_ERRORSTATUS_AUTHORIZATIONERROR = 16;\r\n {$EXTERNALSYM SNMP_ERRORSTATUS_AUTHORIZATIONERROR}\r\n SNMP_ERRORSTATUS_NOTWRITABLE = 17;\r\n {$EXTERNALSYM SNMP_ERRORSTATUS_NOTWRITABLE}\r\n SNMP_ERRORSTATUS_INCONSISTENTNAME = 18;\r\n {$EXTERNALSYM SNMP_ERRORSTATUS_INCONSISTENTNAME}\r\n\r\n{ SNMPv1 Trap Types }\r\n\r\n SNMP_GENERICTRAP_COLDSTART = 0;\r\n {$EXTERNALSYM SNMP_GENERICTRAP_COLDSTART}\r\n SNMP_GENERICTRAP_WARMSTART = 1;\r\n {$EXTERNALSYM SNMP_GENERICTRAP_WARMSTART}\r\n SNMP_GENERICTRAP_LINKDOWN = 2;\r\n {$EXTERNALSYM SNMP_GENERICTRAP_LINKDOWN}\r\n SNMP_GENERICTRAP_LINKUP = 3;\r\n {$EXTERNALSYM SNMP_GENERICTRAP_LINKUP}\r\n SNMP_GENERICTRAP_AUTHFAILURE = 4;\r\n {$EXTERNALSYM SNMP_GENERICTRAP_AUTHFAILURE}\r\n SNMP_GENERICTRAP_EGPNEIGHLOSS = 5;\r\n {$EXTERNALSYM SNMP_GENERICTRAP_EGPNEIGHLOSS}\r\n SNMP_GENERICTRAP_ENTERSPECIFIC = 6;\r\n {$EXTERNALSYM SNMP_GENERICTRAP_ENTERSPECIFIC}\r\n\r\n{ SNMP Access Types }\r\n\r\n SNMP_ACCESS_NONE = 0;\r\n {$EXTERNALSYM SNMP_ACCESS_NONE}\r\n SNMP_ACCESS_NOTIFY = 1;\r\n {$EXTERNALSYM SNMP_ACCESS_NOTIFY}\r\n SNMP_ACCESS_READ_ONLY = 2;\r\n {$EXTERNALSYM SNMP_ACCESS_READ_ONLY}\r\n SNMP_ACCESS_READ_WRITE = 3;\r\n {$EXTERNALSYM SNMP_ACCESS_READ_WRITE}\r\n SNMP_ACCESS_READ_CREATE = 4;\r\n {$EXTERNALSYM SNMP_ACCESS_READ_CREATE}\r\n\r\n{ SNMP API Return Code Definitions }\r\n\r\ntype\r\n SNMPAPI = Integer;\r\n {$EXTERNALSYM SNMPAPI}\r\nconst\r\n SNMPAPI_NOERROR = True;\r\n {$EXTERNALSYM SNMPAPI_NOERROR}\r\n SNMPAPI_ERROR = False;\r\n {$EXTERNALSYM SNMPAPI_ERROR}\r\n\r\n{ SNMP Extension API Type Definitions }\r\n\r\ntype\r\n TSnmpExtensionInit = function (dwUptimeReference: DWORD; var phSubagentTrapEvent: THandle;\r\n var pFirstSupportedRegion: PAsnObjectIdentifier): Boolean; stdcall;\r\n\r\n TSnmpExtensionInitEx = function (var pNextSupportedRegion: PAsnObjectIdentifier): Boolean; stdcall;\r\n\r\n TSnmpExtensionMonitor = function (pAgentMgmtData: Pointer): Boolean; stdcall;\r\n\r\n TSnmpExtensionQuery = function (bPduType: Byte; var pVarBindList: TSnmpVarBindList;\r\n var pErrorStatus: TAsnInteger32; var pErrorIndex: TAsnInteger32): Boolean; stdcall;\r\n\r\n TSnmpExtensionQueryEx = function (nRequestType: UINT; nTransactionId: UINT; var pVarBindList: PSnmpVarBindList;\r\n var pContextInfo: PAsnOctetString; var pErrorStatus: TAsnInteger32; var pErrorIndex: TAsnInteger32): Boolean; stdcall;\r\n\r\n TSnmpExtensionTrap = function (pEnterpriseOid: PAsnObjectIdentifier; var pGenericTrapId: TAsnInteger32;\r\n var pSpecificTrapId: TAsnInteger32; var pTimeStamp: TAsnTimeticks; var pVarBindList: PSnmpVarBindList): Boolean; stdcall;\r\n\r\n TSnmpExtensionClose = procedure; stdcall;\r\n\r\n{ SNMP API Prototypes }\r\n\r\n{$IFDEF SNMP_DYNAMIC_LINK}\r\n\r\nvar\r\n SnmpUtilOidCpy: function(pOidDst: PAsnObjectIdentifier; pOidSrc: PAsnObjectIdentifier): SNMPAPI; stdcall;\r\n SnmpUtilOidAppend: function(pOidDst: PAsnObjectIdentifier; pOidSrc: PAsnObjectIdentifier): SNMPAPI; stdcall;\r\n SnmpUtilOidNCmp: function(pOid1, pOid2: PAsnObjectIdentifier; nSubIds: UINT): SNMPAPI; stdcall;\r\n SnmpUtilOidCmp: function(pOid1, pOid2: PAsnObjectIdentifier): SNMPAPI; stdcall;\r\n SnmpUtilOidFree: procedure(pOid: TAsnObjectIdentifier); stdcall;\r\n SnmpUtilOctetsCmp: function(pOctets1, pOctets2: PAsnOctetString): SNMPAPI; stdcall;\r\n SnmpUtilOctetsNCmp: function(pOctets1, pOctets2: PAsnOctetString; nChars: UINT): SNMPAPI; stdcall;\r\n SnmpUtilOctetsCpy: function(pOctetsDst, pOctetsSrc: PAsnOctetString): SNMPAPI; stdcall;\r\n SnmpUtilOctetsFree: procedure(pOctets: PAsnOctetString); stdcall;\r\n SnmpUtilAsnAnyCpy: function(pAnyDst, pAnySrc: PAsnAny): SNMPAPI; stdcall;\r\n SnmpUtilAsnAnyFree: procedure(pAny: PAsnAny); stdcall;\r\n SnmpUtilVarBindCpy: function(pVbDst: PSnmpVarBind; pVbSrc: PSnmpVarBind): SNMPAPI; stdcall;\r\n SnmpUtilVarBindFree: procedure(pVb: PSnmpVarBind); stdcall;\r\n SnmpUtilVarBindListCpy: function(pVblDst: PSnmpVarBindList; pVblSrc: PSnmpVarBindList): SNMPAPI; stdcall;\r\n SnmpUtilVarBindListFree: procedure(pVbl: PSnmpVarBindList); stdcall;\r\n SnmpUtilMemFree: procedure(pMem: Pointer); stdcall;\r\n SnmpUtilMemAlloc: function(nBytes: UINT): Pointer; stdcall;\r\n SnmpUtilMemReAlloc: function(pMem: Pointer; nBytes: UINT): Pointer; stdcall;\r\n SnmpUtilOidToA: function(Oid: PAsnObjectIdentifier): PAnsiChar; stdcall;\r\n SnmpUtilIdsToA: function(Ids: PUINT; IdLength: UINT): PAnsiChar; stdcall;\r\n SnmpUtilPrintOid: procedure(Oid: PAsnObjectIdentifier); stdcall;\r\n SnmpUtilPrintAsnAny: procedure(pAny: PAsnAny); stdcall;\r\n SnmpSvcGetUptime: function: DWORD; stdcall;\r\n SnmpSvcSetLogLevel: procedure(nLogLevel: Integer); stdcall;\r\n SnmpSvcSetLogType: procedure(nLogType: Integer); stdcall;\r\n\r\n{$ELSE ~SNMP_DYNAMIC_LINK}\r\n\r\nfunction SnmpUtilOidCpy(pOidDst: PAsnObjectIdentifier; pOidSrc: PAsnObjectIdentifier): SNMPAPI; stdcall;\r\nfunction SnmpUtilOidAppend(pOidDst: PAsnObjectIdentifier; pOidSrc: PAsnObjectIdentifier): SNMPAPI; stdcall;\r\nfunction SnmpUtilOidNCmp(pOid1, pOid2: PAsnObjectIdentifier; nSubIds: UINT): SNMPAPI; stdcall;\r\nfunction SnmpUtilOidCmp(pOid1, pOid2: PAsnObjectIdentifier): SNMPAPI; stdcall;\r\nprocedure SnmpUtilOidFree(pOid: TAsnObjectIdentifier); stdcall;\r\nfunction SnmpUtilOctetsCmp(pOctets1, pOctets2: PAsnOctetString): SNMPAPI; stdcall;\r\nfunction SnmpUtilOctetsNCmp(pOctets1, pOctets2: PAsnOctetString; nChars: UINT): SNMPAPI; stdcall;\r\nfunction SnmpUtilOctetsCpy(pOctetsDst, pOctetsSrc: PAsnOctetString): SNMPAPI; stdcall;\r\nprocedure SnmpUtilOctetsFree(pOctets: PAsnOctetString); stdcall;\r\nfunction SnmpUtilAsnAnyCpy(pAnyDst, pAnySrc: PAsnAny): SNMPAPI; stdcall;\r\nprocedure SnmpUtilAsnAnyFree(pAny: PAsnAny); stdcall;\r\nfunction SnmpUtilVarBindCpy(pVbDst: PSnmpVarBind; pVbSrc: PSnmpVarBind): SNMPAPI; stdcall;\r\nprocedure SnmpUtilVarBindFree(pVb: PSnmpVarBind); stdcall;\r\nfunction SnmpUtilVarBindListCpy(pVblDst: PSnmpVarBindList; pVblSrc: PSnmpVarBindList): SNMPAPI; stdcall;\r\nprocedure SnmpUtilVarBindListFree(pVbl: PSnmpVarBindList); stdcall;\r\nprocedure SnmpUtilMemFree(pMem: Pointer); stdcall;\r\nfunction SnmpUtilMemAlloc(nBytes: UINT): Pointer; stdcall;\r\nfunction SnmpUtilMemReAlloc(pMem: Pointer; nBytes: UINT): Pointer; stdcall;\r\nfunction SnmpUtilOidToA(Oid: PAsnObjectIdentifier): PAnsiChar; stdcall;\r\nfunction SnmpUtilIdsToA(Ids: PUINT; IdLength: UINT): PAnsiChar; stdcall;\r\nprocedure SnmpUtilPrintOid(Oid: PAsnObjectIdentifier); stdcall;\r\nprocedure SnmpUtilPrintAsnAny(pAny: PAsnAny); stdcall;\r\nfunction SnmpSvcGetUptime: DWORD; stdcall;\r\nprocedure SnmpSvcSetLogLevel(nLogLevel: Integer); stdcall;\r\nprocedure SnmpSvcSetLogType(nLogType: Integer); stdcall;\r\n\r\n{$ENDIF ~SNMP_DYNAMIC_LINK}\r\n\r\n{$EXTERNALSYM SnmpUtilOidCpy}\r\n{$EXTERNALSYM SnmpUtilOidAppend}\r\n{$EXTERNALSYM SnmpUtilOidNCmp}\r\n{$EXTERNALSYM SnmpUtilOidCmp}\r\n{$EXTERNALSYM SnmpUtilOidFree}\r\n{$EXTERNALSYM SnmpUtilOctetsCmp}\r\n{$EXTERNALSYM SnmpUtilOctetsNCmp}\r\n{$EXTERNALSYM SnmpUtilOctetsCpy}\r\n{$EXTERNALSYM SnmpUtilOctetsFree}\r\n{$EXTERNALSYM SnmpUtilAsnAnyCpy}\r\n{$EXTERNALSYM SnmpUtilAsnAnyFree}\r\n{$EXTERNALSYM SnmpUtilVarBindCpy}\r\n{$EXTERNALSYM SnmpUtilVarBindFree}\r\n{$EXTERNALSYM SnmpUtilVarBindListCpy}\r\n{$EXTERNALSYM SnmpUtilVarBindListFree}\r\n{$EXTERNALSYM SnmpUtilMemFree}\r\n{$EXTERNALSYM SnmpUtilMemAlloc}\r\n{$EXTERNALSYM SnmpUtilMemReAlloc}\r\n{$EXTERNALSYM SnmpUtilOidToA}\r\n{$EXTERNALSYM SnmpUtilIdsToA}\r\n{$EXTERNALSYM SnmpUtilPrintOid}\r\n{$EXTERNALSYM SnmpUtilPrintAsnAny}\r\n{$EXTERNALSYM SnmpSvcGetUptime}\r\n{$EXTERNALSYM SnmpSvcSetLogLevel}\r\n{$EXTERNALSYM SnmpSvcSetLogType}\r\n\r\n{ SNMP Debugging Definitions }\r\n\r\nconst\r\n SNMP_LOG_SILENT = $0;\r\n {$EXTERNALSYM SNMP_LOG_SILENT}\r\n SNMP_LOG_FATAL = $1;\r\n {$EXTERNALSYM SNMP_LOG_FATAL}\r\n SNMP_LOG_ERROR = $2;\r\n {$EXTERNALSYM SNMP_LOG_ERROR}\r\n SNMP_LOG_WARNING = $3;\r\n {$EXTERNALSYM SNMP_LOG_WARNING}\r\n SNMP_LOG_TRACE = $4;\r\n {$EXTERNALSYM SNMP_LOG_TRACE}\r\n SNMP_LOG_VERBOSE = $5;\r\n {$EXTERNALSYM SNMP_LOG_VERBOSE}\r\n\r\n SNMP_OUTPUT_TO_CONSOLE = $1;\r\n {$EXTERNALSYM SNMP_OUTPUT_TO_CONSOLE}\r\n SNMP_OUTPUT_TO_LOGFILE = $2;\r\n {$EXTERNALSYM SNMP_OUTPUT_TO_LOGFILE}\r\n SNMP_OUTPUT_TO_EVENTLOG = $4; // no longer supported\r\n {$EXTERNALSYM SNMP_OUTPUT_TO_EVENTLOG}\r\n SNMP_OUTPUT_TO_DEBUGGER = $8;\r\n {$EXTERNALSYM SNMP_OUTPUT_TO_DEBUGGER}\r\n\r\n{ SNMP Debugging Prototypes }\r\n\r\n{$IFNDEF SNMP_DYNAMIC_LINK}\r\n\r\nprocedure SnmpUtilDbgPrint(nLogLevel: Integer; szFormat: PAnsiChar); stdcall;\r\n\r\n{$ELSE SNMP_DYNAMIC_LINK}\r\n\r\nvar\r\n SnmpUtilDbgPrint: procedure (nLogLevel: Integer; szFormat: PAnsiChar); stdcall;\r\n\r\n{$ENDIF ~SNMP_DYNAMIC_LINK}\r\n\r\n{$EXTERNALSYM SnmpUtilDbgPrint}\r\n\r\n{ Miscellaneous definitions }\r\n\r\nconst\r\n DEFINE_NULLOID: TAsnObjectIdentifier = (idLength: 0; ids: nil);\r\n {$EXTERNALSYM DEFINE_NULLOID}\r\n DEFINE_NULLOCTETS: TAsnOctetString = (stream: nil; length: 0; dynamic_: False);\r\n {$EXTERNALSYM DEFINE_NULLOCTETS}\r\n\r\n DEFAULT_SNMP_PORT_UDP = 161;\r\n {$EXTERNALSYM DEFAULT_SNMP_PORT_UDP}\r\n DEFAULT_SNMP_PORT_IPX = 36879;\r\n {$EXTERNALSYM DEFAULT_SNMP_PORT_IPX}\r\n DEFAULT_SNMPTRAP_PORT_UDP = 162;\r\n {$EXTERNALSYM DEFAULT_SNMPTRAP_PORT_UDP}\r\n DEFAULT_SNMPTRAP_PORT_IPX = 36880;\r\n {$EXTERNALSYM DEFAULT_SNMPTRAP_PORT_IPX}\r\n SNMP_MAX_OID_LEN = 128;\r\n {$EXTERNALSYM SNMP_MAX_OID_LEN}\r\n\r\n{ API Error Code Definitions }\r\n\r\n SNMP_MEM_ALLOC_ERROR = 1;\r\n {$EXTERNALSYM SNMP_MEM_ALLOC_ERROR}\r\n SNMP_BERAPI_INVALID_LENGTH = 10;\r\n {$EXTERNALSYM SNMP_BERAPI_INVALID_LENGTH}\r\n SNMP_BERAPI_INVALID_TAG = 11;\r\n {$EXTERNALSYM SNMP_BERAPI_INVALID_TAG}\r\n SNMP_BERAPI_OVERFLOW = 12;\r\n {$EXTERNALSYM SNMP_BERAPI_OVERFLOW}\r\n SNMP_BERAPI_SHORT_BUFFER = 13;\r\n {$EXTERNALSYM SNMP_BERAPI_SHORT_BUFFER}\r\n SNMP_BERAPI_INVALID_OBJELEM = 14;\r\n {$EXTERNALSYM SNMP_BERAPI_INVALID_OBJELEM}\r\n SNMP_PDUAPI_UNRECOGNIZED_PDU = 20;\r\n {$EXTERNALSYM SNMP_PDUAPI_UNRECOGNIZED_PDU}\r\n SNMP_PDUAPI_INVALID_ES = 21;\r\n {$EXTERNALSYM SNMP_PDUAPI_INVALID_ES}\r\n SNMP_PDUAPI_INVALID_GT = 22;\r\n {$EXTERNALSYM SNMP_PDUAPI_INVALID_GT}\r\n SNMP_AUTHAPI_INVALID_VERSION = 30;\r\n {$EXTERNALSYM SNMP_AUTHAPI_INVALID_VERSION}\r\n SNMP_AUTHAPI_INVALID_MSG_TYPE = 31;\r\n {$EXTERNALSYM SNMP_AUTHAPI_INVALID_MSG_TYPE}\r\n SNMP_AUTHAPI_TRIV_AUTH_FAILED = 32;\r\n {$EXTERNALSYM SNMP_AUTHAPI_TRIV_AUTH_FAILED}\r\n\r\n{ Support for old definitions (support disabled via SNMPSTRICT) }\r\n\r\n{$IFNDEF SNMPSTRICT}\r\n\r\n{$IFNDEF SNMP_DYNAMIC_LINK}\r\n\r\nvar\r\n SNMP_oidcpy: function (pOidDst: PAsnObjectIdentifier; pOidSrc: PAsnObjectIdentifier): SNMPAPI; stdcall;\r\n SNMP_oidappend: function (pOidDst: PAsnObjectIdentifier; pOidSrc: PAsnObjectIdentifier): SNMPAPI; stdcall;\r\n SNMP_oidncmp: function (pOid1, pOid2: PAsnObjectIdentifier; nSubIds: UINT): SNMPAPI; stdcall;\r\n SNMP_oidcmp: function (pOid1, pOid2: PAsnObjectIdentifier): SNMPAPI; stdcall;\r\n SNMP_oidfree: procedure (pOid: TAsnObjectIdentifier); stdcall;\r\n\r\n SNMP_CopyVarBind: function (pVbDst: PSnmpVarBind; pVbSrc: PSnmpVarBind): SNMPAPI; stdcall;\r\n SNMP_FreeVarBind: procedure (pVb: PSnmpVarBind); stdcall;\r\n SNMP_CopyVarBindList: function (pVblDst: PSnmpVarBindList; pVblSrc: PSnmpVarBindList): SNMPAPI; stdcall;\r\n SNMP_FreeVarBindList: procedure (pVbl: PSnmpVarBindList); stdcall;\r\n\r\n SNMP_printany: procedure (pAny: PAsnAny); stdcall;\r\n\r\n SNMP_free: procedure (pMem: Pointer); stdcall;\r\n SNMP_malloc: function (nBytes: UINT): Pointer; stdcall;\r\n SNMP_realloc: function (pMem: Pointer; nBytes: UINT): Pointer; stdcall;\r\n\r\n SNMP_DBG_free: procedure (pMem: Pointer); stdcall;\r\n SNMP_DBG_malloc: function (nBytes: UINT): Pointer; stdcall;\r\n SNMP_DBG_realloc: function (pMem: Pointer; nBytes: UINT): Pointer; stdcall;\r\n\r\n{$ELSE SNMP_DYNAMIC_LINK}\r\n\r\nfunction SNMP_oidcpy(pOidDst: PAsnObjectIdentifier; pOidSrc: PAsnObjectIdentifier): SNMPAPI; stdcall;\r\nfunction SNMP_oidappend(pOidDst: PAsnObjectIdentifier; pOidSrc: PAsnObjectIdentifier): SNMPAPI; stdcall;\r\nfunction SNMP_oidncmp(pOid1, pOid2: PAsnObjectIdentifier; nSubIds: UINT): SNMPAPI; stdcall;\r\nfunction SNMP_oidcmp(pOid1, pOid2: PAsnObjectIdentifier): SNMPAPI; stdcall;\r\nprocedure SNMP_oidfree(pOid: TAsnObjectIdentifier); stdcall;\r\n\r\nfunction SNMP_CopyVarBind(pVbDst: PSnmpVarBind; pVbSrc: PSnmpVarBind): SNMPAPI; stdcall;\r\nprocedure SNMP_FreeVarBind(pVb: PSnmpVarBind); stdcall;\r\nfunction SNMP_CopyVarBindList(pVblDst: PSnmpVarBindList; pVblSrc: PSnmpVarBindList): SNMPAPI; stdcall;\r\nprocedure SNMP_FreeVarBindList(pVbl: PSnmpVarBindList); stdcall;\r\n\r\nprocedure SNMP_printany(pAny: PAsnAny); stdcall;\r\n\r\nprocedure SNMP_free(pMem: Pointer); stdcall;\r\nfunction SNMP_malloc(nBytes: UINT): Pointer; stdcall;\r\nfunction SNMP_realloc(pMem: Pointer; nBytes: UINT): Pointer; stdcall;\r\n\r\nprocedure SNMP_DBG_free(pMem: Pointer); stdcall;\r\nfunction SNMP_DBG_malloc(nBytes: UINT): Pointer; stdcall;\r\nfunction SNMP_DBG_realloc(pMem: Pointer; nBytes: UINT): Pointer; stdcall;\r\n\r\n{$ENDIF SNMP_DYNAMIC_LINK}\r\n\r\n{$EXTERNALSYM SNMP_oidcpy}\r\n{$EXTERNALSYM SNMP_oidappend}\r\n{$EXTERNALSYM SNMP_oidncmp}\r\n{$EXTERNALSYM SNMP_oidcmp}\r\n{$EXTERNALSYM SNMP_oidfree}\r\n\r\n{$EXTERNALSYM SNMP_CopyVarBind}\r\n{$EXTERNALSYM SNMP_FreeVarBind}\r\n{$EXTERNALSYM SNMP_CopyVarBindList}\r\n{$EXTERNALSYM SNMP_FreeVarBindList}\r\n\r\n{$EXTERNALSYM SNMP_printany}\r\n\r\n{$EXTERNALSYM SNMP_free}\r\n{$EXTERNALSYM SNMP_malloc}\r\n{$EXTERNALSYM SNMP_realloc}\r\n\r\n{$EXTERNALSYM SNMP_DBG_free}\r\n{$EXTERNALSYM SNMP_DBG_malloc}\r\n{$EXTERNALSYM SNMP_DBG_realloc}\r\n\r\nconst\r\n ASN_RFC1155_IPADDRESS = ASN_IPADDRESS;\r\n {$EXTERNALSYM ASN_RFC1155_IPADDRESS}\r\n ASN_RFC1155_COUNTER = ASN_COUNTER32;\r\n {$EXTERNALSYM ASN_RFC1155_COUNTER}\r\n ASN_RFC1155_GAUGE = ASN_GAUGE32;\r\n {$EXTERNALSYM ASN_RFC1155_GAUGE}\r\n ASN_RFC1155_TIMETICKS = ASN_TIMETICKS;\r\n {$EXTERNALSYM ASN_RFC1155_TIMETICKS}\r\n ASN_RFC1155_OPAQUE = ASN_OPAQUE;\r\n {$EXTERNALSYM ASN_RFC1155_OPAQUE}\r\n ASN_RFC1213_DISPSTRING = ASN_OCTETSTRING;\r\n {$EXTERNALSYM ASN_RFC1213_DISPSTRING}\r\n\r\n ASN_RFC1157_GETREQUEST = SNMP_PDU_GET;\r\n {$EXTERNALSYM ASN_RFC1157_GETREQUEST}\r\n ASN_RFC1157_GETNEXTREQUEST = SNMP_PDU_GETNEXT;\r\n {$EXTERNALSYM ASN_RFC1157_GETNEXTREQUEST}\r\n ASN_RFC1157_GETRESPONSE = SNMP_PDU_RESPONSE;\r\n {$EXTERNALSYM ASN_RFC1157_GETRESPONSE}\r\n ASN_RFC1157_SETREQUEST = SNMP_PDU_SET;\r\n {$EXTERNALSYM ASN_RFC1157_SETREQUEST}\r\n ASN_RFC1157_TRAP = SNMP_PDU_V1TRAP;\r\n {$EXTERNALSYM ASN_RFC1157_TRAP}\r\n\r\n ASN_CONTEXTSPECIFIC = ASN_CONTEXT;\r\n {$EXTERNALSYM ASN_CONTEXTSPECIFIC}\r\n ASN_PRIMATIVE = ASN_PRIMITIVE;\r\n {$EXTERNALSYM ASN_PRIMATIVE}\r\n\r\ntype\r\n RFC1157VarBindList = TSnmpVarBindList;\r\n {$EXTERNALSYM RFC1157VarBindList}\r\n RFC1157VarBind = TSnmpVarBind;\r\n {$EXTERNALSYM RFC1157VarBind}\r\n TAsnInteger = TAsnInteger32;\r\n {$EXTERNALSYM TAsnInteger}\r\n TAsnCounter = TAsnCounter32;\r\n {$EXTERNALSYM TAsnCounter}\r\n TAsnGauge = TAsnGauge32;\r\n {$EXTERNALSYM TAsnGauge}\r\n\r\n{$ENDIF ~SNMPSTRICT}\r\n\r\n{ SNMP Extension API Prototypes }\r\n\r\nvar\r\n SnmpExtensionInit: TSnmpExtensionInit;\r\n {$EXTERNALSYM SnmpExtensionInit}\r\n SnmpExtensionInitEx: TSnmpExtensionInitEx;\r\n {$EXTERNALSYM SnmpExtensionInitEx}\r\n SnmpExtensionMonitor: TSnmpExtensionMonitor;\r\n {$EXTERNALSYM SnmpExtensionMonitor}\r\n SnmpExtensionQuery: TSnmpExtensionQuery;\r\n {$EXTERNALSYM SnmpExtensionQuery}\r\n SnmpExtensionQueryEx: TSnmpExtensionQueryEx;\r\n {$EXTERNALSYM SnmpExtensionQueryEx}\r\n SnmpExtensionTrap: TSnmpExtensionTrap;\r\n {$EXTERNALSYM SnmpExtensionTrap}\r\n SnmpExtensionClose: TSnmpExtensionClose;\r\n {$EXTERNALSYM SnmpExtensionClose}\r\n\r\n//DOM-IGNORE-END\r\n\r\nfunction SnmpExtensionLoaded: Boolean;\r\nfunction LoadSnmpExtension(const LibName: string): Boolean;\r\nfunction UnloadSnmpExtension: Boolean;\r\n\r\n{$IFDEF SNMP_DYNAMIC_LINK}\r\nfunction SnmpLoaded: Boolean;\r\n{$IFDEF SNMP_DYNAMIC_LINK_EXPLICIT}\r\nfunction LoadSnmp: Boolean;\r\nfunction UnloadSnmp: Boolean;\r\n{$ENDIF SNMP_DYNAMIC_LINK_EXPLICIT}\r\n{$ENDIF SNMP_DYNAMIC_LINK}\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jcl.svn.sourceforge.net/svnroot/jcl/tags/JCL-2.4-Build4571/jcl/source/windows/Snmp.pas $';\r\n Revision: '$Revision: 3599 $';\r\n Date: '$Date: 2011-09-03 00:07:50 +0200 (sam. 03 sept. 2011) $';\r\n LogPath: 'JCL\\source\\windows';\r\n Extra: '';\r\n Data: nil\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nconst\r\n snmpapilib = 'snmpapi.dll';\r\n\r\nvar\r\n ExtensionLibHandle: THandle;\r\n\r\nfunction SnmpExtensionLoaded: Boolean;\r\nbegin\r\n Result := ExtensionLibHandle <> 0;\r\nend;\r\n\r\nfunction LoadSnmpExtension(const LibName: string): Boolean;\r\nbegin\r\n Result := UnloadSnmpExtension;\r\n if Result then\r\n begin\r\n ExtensionLibHandle := SafeLoadLibrary(LibName);\r\n Result := SnmpExtensionLoaded;\r\n if Result then\r\n begin\r\n @SnmpExtensionInit := GetProcAddress(ExtensionLibHandle, 'SnmpExtensionInit');\r\n @SnmpExtensionInitEx := GetProcAddress(ExtensionLibHandle, 'SnmpExtensionInitEx');\r\n @SnmpExtensionMonitor := GetProcAddress(ExtensionLibHandle, 'SnmpExtensionMonitor');\r\n @SnmpExtensionQuery := GetProcAddress(ExtensionLibHandle, 'SnmpExtensionQuery');\r\n @SnmpExtensionQueryEx := GetProcAddress(ExtensionLibHandle, 'SnmpExtensionQueryEx');\r\n @SnmpExtensionTrap := GetProcAddress(ExtensionLibHandle, 'SnmpExtensionTrap');\r\n @SnmpExtensionClose := GetProcAddress(ExtensionLibHandle, 'SnmpExtensionClose');\r\n Result := Assigned(SnmpExtensionInit);\r\n if not Result then\r\n UnloadSnmpExtension;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction UnloadSnmpExtension: Boolean;\r\nbegin\r\n if SnmpExtensionLoaded then\r\n begin\r\n Result := FreeLibrary(ExtensionLibHandle);\r\n ExtensionLibHandle := 0;\r\n @SnmpExtensionInit := nil;\r\n @SnmpExtensionInitEx := nil;\r\n @SnmpExtensionMonitor := nil;\r\n @SnmpExtensionQuery := nil;\r\n @SnmpExtensionQueryEx := nil;\r\n @SnmpExtensionTrap := nil;\r\n @SnmpExtensionClose := nil;\r\n end\r\n else\r\n Result := True;\r\nend;\r\n\r\n{$IFDEF SNMP_DYNAMIC_LINK}\r\n\r\nvar\r\n SnmpLibHandle: THandle;\r\n\r\nfunction SnmpLoaded: Boolean;\r\nbegin\r\n Result := SnmpLibHandle <> 0;\r\nend;\r\n\r\nfunction UnloadSnmp: Boolean;\r\nbegin\r\n Result := True;\r\n if SnmpLoaded then\r\n begin\r\n Result := FreeLibrary(SnmpLibHandle);\r\n SnmpLibHandle := 0;\r\n @SnmpUtilOidCpy := nil;\r\n @SnmpUtilOidAppend := nil;\r\n @SnmpUtilOidNCmp := nil;\r\n @SnmpUtilOidCmp := nil;\r\n @SnmpUtilOidFree := nil;\r\n @SnmpUtilOctetsCmp := nil;\r\n @SnmpUtilOctetsNCmp := nil;\r\n @SnmpUtilOctetsCpy := nil;\r\n @SnmpUtilOctetsFree := nil;\r\n @SnmpUtilAsnAnyCpy := nil;\r\n @SnmpUtilAsnAnyFree := nil;\r\n @SnmpUtilVarBindCpy := nil;\r\n @SnmpUtilVarBindFree := nil;\r\n @SnmpUtilVarBindListCpy := nil;\r\n @SnmpUtilVarBindListFree := nil;\r\n @SnmpUtilMemFree := nil;\r\n @SnmpUtilMemAlloc := nil;\r\n @SnmpUtilMemReAlloc := nil;\r\n @SnmpUtilOidToA := nil;\r\n @SnmpUtilIdsToA := nil;\r\n @SnmpUtilPrintOid := nil;\r\n @SnmpUtilPrintAsnAny := nil;\r\n @SnmpSvcGetUptime := nil;\r\n @SnmpSvcSetLogLevel := nil;\r\n @SnmpSvcSetLogType := nil;\r\n @SnmpUtilDbgPrint := nil;\r\n {$IFNDEF SNMPSTRICT}\r\n @SNMP_oidcpy := nil;\r\n @SNMP_oidappend := nil;\r\n @SNMP_oidncmp := nil;\r\n @SNMP_oidcmp := nil;\r\n @SNMP_oidfree := nil;\r\n @SNMP_CopyVarBind := nil;\r\n @SNMP_FreeVarBind := nil;\r\n @SNMP_CopyVarBindList := nil;\r\n @SNMP_FreeVarBindList := nil;\r\n @SNMP_printany := nil;\r\n @SNMP_free := nil;\r\n @SNMP_malloc := nil;\r\n @SNMP_realloc := nil;\r\n @SNMP_DBG_free := nil;\r\n @SNMP_DBG_malloc := nil;\r\n @SNMP_DBG_realloc := nil;\r\n {$ENDIF ~SNMPSTRICT}\r\n end;\r\nend;\r\n\r\nfunction LoadSnmp: Boolean;\r\nbegin\r\n Result := SnmpLoaded;\r\n if not Result then\r\n begin\r\n SnmpLibHandle := SafeLoadLibrary(snmpapilib);\r\n if SnmpLoaded then\r\n begin\r\n @SnmpUtilOidCpy := GetProcAddress(SnmpLibHandle, 'SnmpUtilOidCpy');\r\n @SnmpUtilOidAppend := GetProcAddress(SnmpLibHandle, 'SnmpUtilOidAppend');\r\n @SnmpUtilOidNCmp := GetProcAddress(SnmpLibHandle, 'SnmpUtilOidNCmp');\r\n @SnmpUtilOidCmp := GetProcAddress(SnmpLibHandle, 'SnmpUtilOidCmp');\r\n @SnmpUtilOidFree := GetProcAddress(SnmpLibHandle, 'SnmpUtilOidFree');\r\n @SnmpUtilOctetsCmp := GetProcAddress(SnmpLibHandle, 'SnmpUtilOctetsCmp');\r\n @SnmpUtilOctetsNCmp := GetProcAddress(SnmpLibHandle, 'SnmpUtilOctetsNCmp');\r\n @SnmpUtilOctetsCpy := GetProcAddress(SnmpLibHandle, 'SnmpUtilOctetsCpy');\r\n @SnmpUtilOctetsFree := GetProcAddress(SnmpLibHandle, 'SnmpUtilOctetsFree');\r\n @SnmpUtilAsnAnyCpy := GetProcAddress(SnmpLibHandle, 'SnmpUtilAsnAnyCpy');\r\n @SnmpUtilAsnAnyFree := GetProcAddress(SnmpLibHandle, 'SnmpUtilAsnAnyFree');\r\n @SnmpUtilVarBindCpy := GetProcAddress(SnmpLibHandle, 'SnmpUtilVarBindCpy');\r\n @SnmpUtilVarBindFree := GetProcAddress(SnmpLibHandle, 'SnmpUtilVarBindFree');\r\n @SnmpUtilVarBindListCpy := GetProcAddress(SnmpLibHandle, 'SnmpUtilVarBindListCpy');\r\n @SnmpUtilVarBindListFree := GetProcAddress(SnmpLibHandle, 'SnmpUtilVarBindListFree');\r\n @SnmpUtilMemFree := GetProcAddress(SnmpLibHandle, 'SnmpUtilMemFree');\r\n @SnmpUtilMemAlloc := GetProcAddress(SnmpLibHandle, 'SnmpUtilMemAlloc');\r\n @SnmpUtilMemReAlloc := GetProcAddress(SnmpLibHandle, 'SnmpUtilMemReAlloc');\r\n @SnmpUtilOidToA := GetProcAddress(SnmpLibHandle, 'SnmpUtilOidToA');\r\n @SnmpUtilIdsToA := GetProcAddress(SnmpLibHandle, 'SnmpUtilIdsToA');\r\n @SnmpUtilPrintOid := GetProcAddress(SnmpLibHandle, 'SnmpUtilPrintOid');\r\n @SnmpUtilPrintAsnAny := GetProcAddress(SnmpLibHandle, 'SnmpUtilPrintAsnAny');\r\n @SnmpSvcGetUptime := GetProcAddress(SnmpLibHandle, 'SnmpSvcGetUptime');\r\n @SnmpSvcSetLogLevel := GetProcAddress(SnmpLibHandle, 'SnmpSvcSetLogLevel');\r\n @SnmpSvcSetLogType := GetProcAddress(SnmpLibHandle, 'SnmpSvcSetLogType');\r\n @SnmpUtilDbgPrint := GetProcAddress(SnmpLibHandle, 'SnmpUtilDbgPrint');\r\n {$IFNDEF SNMPSTRICT}\r\n @SNMP_oidcpy := GetProcAddress(SnmpLibHandle, 'SnmpUtilOidCpy');\r\n @SNMP_oidappend := GetProcAddress(SnmpLibHandle, 'SnmpUtilOidAppend');\r\n @SNMP_oidncmp := GetProcAddress(SnmpLibHandle, 'SnmpUtilOidNCmp');\r\n @SNMP_oidcmp := GetProcAddress(SnmpLibHandle, 'SnmpUtilOidCmp');\r\n @SNMP_oidfree := GetProcAddress(SnmpLibHandle, 'SnmpUtilOidFree');\r\n @SNMP_CopyVarBind := GetProcAddress(SnmpLibHandle, 'SnmpUtilVarBindCpy');\r\n @SNMP_FreeVarBind := GetProcAddress(SnmpLibHandle, 'SnmpUtilVarBindFree');\r\n @SNMP_CopyVarBindList := GetProcAddress(SnmpLibHandle, 'SnmpUtilVarBindListCpy');\r\n @SNMP_FreeVarBindList := GetProcAddress(SnmpLibHandle, 'SnmpUtilVarBindListFree');\r\n @SNMP_printany := GetProcAddress(SnmpLibHandle, 'SnmpUtilPrintAsnAny');\r\n @SNMP_free := GetProcAddress(SnmpLibHandle, 'SnmpUtilMemFree');\r\n @SNMP_malloc := GetProcAddress(SnmpLibHandle, 'SnmpUtilMemAlloc');\r\n @SNMP_realloc := GetProcAddress(SnmpLibHandle, 'SnmpUtilMemReAlloc');\r\n @SNMP_DBG_free := GetProcAddress(SnmpLibHandle, 'SnmpUtilMemFree');\r\n @SNMP_DBG_malloc := GetProcAddress(SnmpLibHandle, 'SnmpUtilMemAlloc');\r\n @SNMP_DBG_realloc := GetProcAddress(SnmpLibHandle, 'SnmpUtilMemReAlloc');\r\n {$ENDIF ~SNMPSTRICT}\r\n Result := True;\r\n end;\r\n end;\r\nend;\r\n\r\n{$ELSE ~SNMP_DYNAMIC_LINK}\r\n\r\nfunction SnmpUtilOidCpy; external snmpapilib name 'SnmpUtilOidCpy';\r\nfunction SnmpUtilOidAppend; external snmpapilib name 'SnmpUtilOidAppend';\r\nfunction SnmpUtilOidNCmp; external snmpapilib name 'SnmpUtilOidNCmp';\r\nfunction SnmpUtilOidCmp; external snmpapilib name 'SnmpUtilOidCmp';\r\nprocedure SnmpUtilOidFree; external snmpapilib name 'SnmpUtilOidFree';\r\nfunction SnmpUtilOctetsCmp; external snmpapilib name 'SnmpUtilOctetsCmp';\r\nfunction SnmpUtilOctetsNCmp; external snmpapilib name 'SnmpUtilOctetsNCmp';\r\nfunction SnmpUtilOctetsCpy; external snmpapilib name 'SnmpUtilOctetsCpy';\r\nprocedure SnmpUtilOctetsFree; external snmpapilib name 'SnmpUtilOctetsFree';\r\nfunction SnmpUtilAsnAnyCpy; external snmpapilib name 'SnmpUtilAsnAnyCpy';\r\nprocedure SnmpUtilAsnAnyFree; external snmpapilib name 'SnmpUtilAsnAnyFree';\r\nfunction SnmpUtilVarBindCpy; external snmpapilib name 'SnmpUtilVarBindCpy';\r\nprocedure SnmpUtilVarBindFree; external snmpapilib name 'SnmpUtilVarBindFree';\r\nfunction SnmpUtilVarBindListCpy; external snmpapilib name 'SnmpUtilVarBindListCpy';\r\nprocedure SnmpUtilVarBindListFree; external snmpapilib name 'SnmpUtilVarBindListFree';\r\nprocedure SnmpUtilMemFree; external snmpapilib name 'SnmpUtilMemFree';\r\nfunction SnmpUtilMemAlloc; external snmpapilib name 'SnmpUtilMemAlloc';\r\nfunction SnmpUtilMemReAlloc; external snmpapilib name 'SnmpUtilMemReAlloc';\r\nfunction SnmpUtilOidToA; external snmpapilib name 'SnmpUtilOidToA';\r\nfunction SnmpUtilIdsToA; external snmpapilib name 'SnmpUtilIdsToA';\r\nprocedure SnmpUtilPrintOid; external snmpapilib name 'SnmpUtilPrintOid';\r\nprocedure SnmpUtilPrintAsnAny; external snmpapilib name 'SnmpUtilPrintAsnAny';\r\nfunction SnmpSvcGetUptime; external snmpapilib name 'SnmpSvcGetUptime';\r\nprocedure SnmpSvcSetLogLevel; external snmpapilib name 'SnmpSvcSetLogLevel';\r\nprocedure SnmpSvcSetLogType; external snmpapilib name 'SnmpSvcSetLogType';\r\nprocedure SnmpUtilDbgPrint; external snmpapilib name 'SnmpUtilDbgPrint';\r\n\r\n{$IFNDEF SNMPSTRICT}\r\nfunction SNMP_oidcpy; external snmpapilib name 'SnmpUtilOidCpy';\r\nfunction SNMP_oidappend; external snmpapilib name 'SnmpUtilOidAppend';\r\nfunction SNMP_oidncmp; external snmpapilib name 'SnmpUtilOidNCmp';\r\nfunction SNMP_oidcmp; external snmpapilib name 'SnmpUtilOidCmp';\r\nprocedure SNMP_oidfree; external snmpapilib name 'SnmpUtilOidFree';\r\nfunction SNMP_CopyVarBind; external snmpapilib name 'SnmpUtilVarBindCpy';\r\nprocedure SNMP_FreeVarBind; external snmpapilib name 'SnmpUtilVarBindFree';\r\nfunction SNMP_CopyVarBindList; external snmpapilib name 'SnmpUtilVarBindListCpy';\r\nprocedure SNMP_FreeVarBindList; external snmpapilib name 'SnmpUtilVarBindListFree';\r\nprocedure SNMP_printany; external snmpapilib name 'SnmpUtilPrintAsnAny';\r\nprocedure SNMP_free; external snmpapilib name 'SnmpUtilMemFree';\r\nfunction SNMP_malloc; external snmpapilib name 'SnmpUtilMemAlloc';\r\nfunction SNMP_realloc; external snmpapilib name 'SnmpUtilMemReAlloc';\r\nprocedure SNMP_DBG_free; external snmpapilib name 'SnmpUtilMemFree';\r\nfunction SNMP_DBG_malloc; external snmpapilib name 'SnmpUtilMemAlloc';\r\nfunction SNMP_DBG_realloc; external snmpapilib name 'SnmpUtilMemReAlloc';\r\n{$ENDIF ~SNMPSTRICT}\r\n\r\n{$ENDIF ~SNMP_DYNAMIC_LINK}\r\n\r\nprocedure InitializeSnmp;\r\nbegin\r\n {$IFDEF SNMP_DYNAMIC_LINK}\r\n {$IFNDEF SNMP_DYNAMIC_LINK_EXPLICIT}\r\n LoadSnmp;\r\n {$ENDIF ~SNMP_DYNAMIC_LINK_EXPLICIT}\r\n {$ENDIF SNMP_DYNAMIC_LINK}\r\nend;\r\n\r\nprocedure FinalizeSnmp;\r\nbegin\r\n {$IFDEF SNMP_DYNAMIC_LINK}\r\n {$IFNDEF SNMP_DYNAMIC_LINK_EXPLICIT}\r\n UnloadSnmp;\r\n {$ENDIF ~SNMP_DYNAMIC_LINK_EXPLICIT}\r\n {$ENDIF SNMP_DYNAMIC_LINK}\r\nend;\r\n\r\ninitialization\r\n InitializeSnmp;\r\n {$IFDEF UNITVERSIONING}\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n {$ENDIF UNITVERSIONING}\r\n\r\nfinalization\r\n FinalizeSnmp;\r\n {$IFDEF UNITVERSIONING}\r\n UnregisterUnitVersion(HInstance);\r\n {$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jcl/source/windows/dirinfo.txt", "content": "This is the directory where Win32-specific units reside." }, { "path": "External/Jedi/Jcl/source/windows/mscoree_TLB.pas", "content": "{**************************************************************************************************}\r\n{ }\r\n{ Last modified: $Date:: 2011-09-03 00:07:50 +0200 (sam. 03 sept. 2011) $ }\r\n{ Revision: $Rev:: 3599 $ }\r\n{ Author: $Author:: outchy $ }\r\n{ }\r\n{**************************************************************************************************}\r\n\r\nunit mscoree_TLB;\r\n\r\n// ************************************************************************ //\r\n// WARNING \r\n// ------- \r\n// The types declared in this file were generated from data read from a \r\n// Type Library. If this type library is explicitly or indirectly (via \r\n// another type library referring to this type library) re-imported, or the \r\n// 'Refresh' command of the Type Library Editor activated while editing the \r\n// Type Library, the contents of this file will be regenerated and all \r\n// manual modifications will be lost. \r\n// ************************************************************************ //\r\n\r\n// PASTLWTR : $Revision: 3599 $\r\n// File generated on 14.12.2003 01:39:55 from Type Library described below.\r\n\r\n// ************************************************************************ //\r\n// Type Lib: F:\\WINNT\\Microsoft.NET\\Framework\\v1.1.4322\\mscoree.tlb (1)\r\n// LIBID: {5477469E-83B1-11D2-8B49-00A0C9B7C9C4}\r\n// LCID: 0\r\n// Helpfile: \r\n// DepndLst: \r\n// (1) v2.0 stdole, (F:\\WINNT\\system32\\STDOLE2.TLB)\r\n// (2) v4.0 StdVCL, (F:\\WINNT\\system32\\STDVCL40.DLL)\r\n// Errors:\r\n// Hint: Member 'type' of 'tagSTATSTG' changed to 'type_'\r\n// ************************************************************************ //\r\n{$TYPEDADDRESS OFF} // Unit must be compiled without type-checked pointers. \r\n\r\n{$I jcl.inc}\r\n{$I windowsonly.inc}\r\n\r\n{$IFDEF SUPPORTS_WEAKPACKAGEUNIT}\r\n {$IFDEF UNITVERSIONING}\r\n {$WEAKPACKAGEUNIT OFF}\r\n {$ELSE ~UNITVERSIONING}\r\n {$WEAKPACKAGEUNIT ON}\r\n {$ENDIF ~UNITVERSIONING}\r\n{$ENDIF SUPPORTS_WEAKPACKAGEUNIT}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n {$IFDEF HAS_UNITSCOPE}\r\n Winapi.ActiveX, System.Classes;\r\n {$ELSE ~HAS_UNITSCOPE}\r\n ActiveX, Classes;\r\n {$ENDIF ~HAS_UNITSCOPE}\r\n\r\n//DOM-IGNORE-BEGIN\r\n\r\n{$HPPEMIT '#include '}\r\n\r\n// *********************************************************************//\r\n// GUIDS declared in the TypeLibrary. Following prefixes are used: \r\n// Type Libraries : LIBID_xxxx \r\n// CoClasses : CLASS_xxxx \r\n// DISPInterfaces : DIID_xxxx \r\n// Non-DISP interfaces: IID_xxxx \r\n// *********************************************************************//\r\nconst\r\n // TypeLibrary Major and minor versions\r\n mscoreeMajorVersion = 1;\r\n mscoreeMinorVersion = 1;\r\n\r\n LIBID_mscoree: TGUID = '{5477469E-83B1-11D2-8B49-00A0C9B7C9C4}';\r\n\r\n IID_IApartmentCallback: TGUID = '{178E5337-1528-4591-B1C9-1C6E484686D8}';\r\n IID_IManagedObject: TGUID = '{C3FCC19E-A970-11D2-8B5A-00A0C9B7C9C4}';\r\n IID_ICatalogServices: TGUID = '{04C6BE1E-1DB1-4058-AB7A-700CCCFBF254}';\r\n IID_IMarshal: TGUID = '{00000003-0000-0000-C000-000000000046}';\r\n CLASS_ComCallUnmarshal: TGUID = '{3F281000-E95A-11D2-886B-00C04F869F04}';\r\n IID_ISequentialStream: TGUID = '{0C733A30-2A1C-11CE-ADE5-00AA0044773D}';\r\n IID_IStream: TGUID = '{0000000C-0000-0000-C000-000000000046}';\r\n IID_ICorRuntimeHost: TGUID = '{CB2F6722-AB3A-11D2-9C40-00C04FA30A3E}';\r\n IID_IGCHost: TGUID = '{FAC34F6E-0DCD-47B5-8021-531BC5ECCA63}';\r\n IID_ICorConfiguration: TGUID = '{5C2B07A5-1E98-11D3-872F-00C04F79ED0D}';\r\n IID_IGCThreadControl: TGUID = '{F31D1788-C397-4725-87A5-6AF3472C2791}';\r\n IID_IGCHostControl: TGUID = '{5513D564-8374-4CB9-AED9-0083F4160A1D}';\r\n IID_IDebuggerThreadControl: TGUID = '{23D86786-0BB5-4774-8FB5-E3522ADD6246}';\r\n IID_IValidator: TGUID = '{63DF8730-DC81-4062-84A2-1FF943F59FAC}';\r\n IID_IDebuggerInfo: TGUID = '{BF24142D-A47D-4D24-A66D-8C2141944E44}';\r\n IID_IVEHandler: TGUID = '{856CA1B2-7DAB-11D3-ACEC-00C04F86C309}';\r\n CLASS_CorRuntimeHost: TGUID = '{CB2F6723-AB3A-11D2-9C40-00C04FA30A3E}';\r\ntype\r\n\r\n// *********************************************************************//\r\n// Forward declaration of types defined in TypeLibrary \r\n// *********************************************************************//\r\n IApartmentCallback = interface;\r\n IManagedObject = interface;\r\n ICatalogServices = interface;\r\n {$IFNDEF FPC}\r\n IMarshal = interface;\r\n ISequentialStream = interface;\r\n IStream = interface;\r\n {$ENDIF ~FPC}\r\n ICorRuntimeHost = interface;\r\n IGCHost = interface;\r\n ICorConfiguration = interface;\r\n IGCThreadControl = interface;\r\n IGCHostControl = interface;\r\n IDebuggerThreadControl = interface;\r\n IValidator = interface;\r\n IDebuggerInfo = interface;\r\n IVEHandler = interface;\r\n\r\n// *********************************************************************//\r\n// Declaration of CoClasses defined in Type Library \r\n// (NOTE: Here we map each CoClass to its Default Interface) \r\n// *********************************************************************//\r\n ComCallUnmarshal = IMarshal;\r\n CorRuntimeHost = ICorRuntimeHost;\r\n\r\n\r\n// *********************************************************************//\r\n// Declaration of structures, unions and aliases. \r\n// *********************************************************************//\r\n PUserType1 = ^TGUID; {*}\r\n PPUserType1 = ^ISequentialStream; {*}\r\n PByte1 = ^Byte; {*}\r\n PUINT1 = ^LongWord; {*}\r\n\r\n {$IFNDEF FPC}\r\n ULONG_PTR = LongWord;\r\n {$EXTERNALSYM ULONG_PTR}\r\n {$ENDIF ~FPC}\r\n\r\n _LARGE_INTEGER = packed record\r\n QuadPart: Int64;\r\n end;\r\n\r\n _ULARGE_INTEGER = packed record\r\n QuadPart: Largeuint;\r\n end;\r\n\r\n _FILETIME = packed record\r\n dwLowDateTime: LongWord;\r\n dwHighDateTime: LongWord;\r\n end;\r\n {$EXTERNALSYM _FILETIME}\r\n\r\n {$IFNDEF FPC}\r\n tagSTATSTG = packed record\r\n pwcsName: PWideChar;\r\n type_: LongWord;\r\n cbSize: _ULARGE_INTEGER;\r\n mtime: _FILETIME;\r\n ctime: _FILETIME;\r\n atime: _FILETIME;\r\n grfMode: LongWord;\r\n grfLocksSupported: LongWord;\r\n clsid: TGUID;\r\n grfStateBits: LongWord;\r\n reserved: LongWord;\r\n end;\r\n {$EXTERNALSYM tagSTATSTG}\r\n {$ENDIF ~FPC}\r\n\r\n _COR_GC_STATS = packed record\r\n Flags: LongWord;\r\n ExplicitGCCount: ULONG_PTR;\r\n GenCollectionsTaken: array[0..2] of ULONG_PTR;\r\n CommittedKBytes: ULONG_PTR;\r\n ReservedKBytes: ULONG_PTR;\r\n Gen0HeapSizeKBytes: ULONG_PTR;\r\n Gen1HeapSizeKBytes: ULONG_PTR;\r\n Gen2HeapSizeKBytes: ULONG_PTR;\r\n LargeObjectHeapSizeKBytes: ULONG_PTR;\r\n KBytesPromotedFromGen0: ULONG_PTR;\r\n KBytesPromotedFromGen1: ULONG_PTR;\r\n end;\r\n\r\n _COR_GC_THREAD_STATS = packed record\r\n PerThreadAllocation: Largeuint;\r\n Flags: LongWord;\r\n end;\r\n\r\n tag_VerError = packed record\r\n Flags: LongWord;\r\n opcode: LongWord;\r\n uOffset: LongWord;\r\n Token: LongWord;\r\n item1_flags: LongWord;\r\n item1_data: ^SYSINT;\r\n item2_flags: LongWord;\r\n item2_data: ^SYSINT;\r\n end;\r\n\r\n\r\n// *********************************************************************//\r\n// Interface: IApartmentCallback\r\n// Flags: (256) OleAutomation\r\n// GUID: {178E5337-1528-4591-B1C9-1C6E484686D8}\r\n// *********************************************************************//\r\n IApartmentCallback = interface(IUnknown)\r\n ['{178E5337-1528-4591-B1C9-1C6E484686D8}']\r\n function DoCallback(pFunc: ULONG_PTR; pData: ULONG_PTR): HResult; stdcall;\r\n end;\r\n\r\n// *********************************************************************//\r\n// Interface: IManagedObject\r\n// Flags: (256) OleAutomation\r\n// GUID: {C3FCC19E-A970-11D2-8B5A-00A0C9B7C9C4}\r\n// *********************************************************************//\r\n IManagedObject = interface(IUnknown)\r\n ['{C3FCC19E-A970-11D2-8B5A-00A0C9B7C9C4}']\r\n function GetSerializedBuffer(out pBSTR: WideString): HResult; stdcall;\r\n function GetObjectIdentity(out pBSTRGUID: WideString; out AppDomainID: SYSINT; out pCCW: SYSINT): HResult; stdcall;\r\n end;\r\n\r\n// *********************************************************************//\r\n// Interface: ICatalogServices\r\n// Flags: (256) OleAutomation\r\n// GUID: {04C6BE1E-1DB1-4058-AB7A-700CCCFBF254}\r\n// *********************************************************************//\r\n ICatalogServices = interface(IUnknown)\r\n ['{04C6BE1E-1DB1-4058-AB7A-700CCCFBF254}']\r\n function Autodone: HResult; stdcall;\r\n function NotAutodone: HResult; stdcall;\r\n end;\r\n\r\n {$IFNDEF FPC}\r\n// *********************************************************************//\r\n// Interface: IMarshal\r\n// Flags: (0)\r\n// GUID: {00000003-0000-0000-C000-000000000046}\r\n// *********************************************************************//\r\n IMarshal = interface(IUnknown)\r\n ['{00000003-0000-0000-C000-000000000046}']\r\n function GetUnmarshalClass(var riid: TGUID; var pv: Pointer; dwDestContext: LongWord; \r\n var pvDestContext: Pointer; mshlflags: LongWord; out pCid: TGUID): HResult; stdcall;\r\n function GetMarshalSizeMax(var riid: TGUID; var pv: Pointer; dwDestContext: LongWord; \r\n var pvDestContext: Pointer; mshlflags: LongWord; out pSize: LongWord): HResult; stdcall;\r\n function MarshalInterface(var pstm: ISequentialStream; var riid: TGUID; var pv: Pointer; \r\n dwDestContext: LongWord; var pvDestContext: Pointer; \r\n mshlflags: LongWord): HResult; stdcall;\r\n function UnmarshalInterface(const pstm: ISequentialStream; var riid: TGUID; out ppv: Pointer): HResult; stdcall;\r\n function ReleaseMarshalData(const pstm: ISequentialStream): HResult; stdcall;\r\n function DisconnectObject(dwReserved: LongWord): HResult; stdcall;\r\n end;\r\n\r\n// *********************************************************************//\r\n// Interface: ISequentialStream\r\n// Flags: (0)\r\n// GUID: {0C733A30-2A1C-11CE-ADE5-00AA0044773D}\r\n// *********************************************************************//\r\n ISequentialStream = interface(IUnknown)\r\n ['{0C733A30-2A1C-11CE-ADE5-00AA0044773D}']\r\n function Read(out pv: Pointer; cb: LongWord; out pcbRead: LongWord): HResult; stdcall;\r\n function RemoteRead(out pv: Byte; cb: LongWord; out pcbRead: LongWord): HResult; stdcall;\r\n function Write(var pv: Pointer; cb: LongWord; out pcbWritten: LongWord): HResult; stdcall;\r\n function RemoteWrite(var pv: Byte; cb: LongWord; out pcbWritten: LongWord): HResult; stdcall;\r\n end;\r\n\r\n// *********************************************************************//\r\n// Interface: IStream\r\n// Flags: (0)\r\n// GUID: {0000000C-0000-0000-C000-000000000046}\r\n// *********************************************************************//\r\n IStream = interface(ISequentialStream)\r\n ['{0000000C-0000-0000-C000-000000000046}']\r\n function Seek(dlibMove: _LARGE_INTEGER; dwOrigin: LongWord; out plibNewPosition: _ULARGE_INTEGER): HResult; stdcall;\r\n function RemoteSeek(dlibMove: _LARGE_INTEGER; dwOrigin: LongWord; \r\n out plibNewPosition: _ULARGE_INTEGER): HResult; stdcall;\r\n function SetSize(libNewSize: _ULARGE_INTEGER): HResult; stdcall;\r\n function CopyTo(const pstm: ISequentialStream; cb: _ULARGE_INTEGER; \r\n out pcbRead: _ULARGE_INTEGER; out pcbWritten: _ULARGE_INTEGER): HResult; stdcall;\r\n function RemoteCopyTo(const pstm: ISequentialStream; cb: _ULARGE_INTEGER; \r\n out pcbRead: _ULARGE_INTEGER; out pcbWritten: _ULARGE_INTEGER): HResult; stdcall;\r\n function Commit(grfCommitFlags: LongWord): HResult; stdcall;\r\n function Revert: HResult; stdcall;\r\n function LockRegion(libOffset: _ULARGE_INTEGER; cb: _ULARGE_INTEGER; dwLockType: LongWord): HResult; stdcall;\r\n function UnlockRegion(libOffset: _ULARGE_INTEGER; cb: _ULARGE_INTEGER; dwLockType: LongWord): HResult; stdcall;\r\n function Stat(out pstatstg: tagSTATSTG; grfStatFlag: LongWord): HResult; stdcall;\r\n function Clone(out ppstm: ISequentialStream): HResult; stdcall;\r\n end;\r\n {$EXTERNALSYM IStream}\r\n {$ENDIF ~FPC}\r\n\r\n// *********************************************************************//\r\n// Interface: ICorRuntimeHost\r\n// Flags: (0)\r\n// GUID: {CB2F6722-AB3A-11D2-9C40-00C04FA30A3E}\r\n// *********************************************************************//\r\n ICorRuntimeHost = interface(IUnknown)\r\n ['{CB2F6722-AB3A-11D2-9C40-00C04FA30A3E}']\r\n function CreateLogicalThreadState: HResult; stdcall;\r\n function DeleteLogicalThreadState: HResult; stdcall;\r\n function SwitchInLogicalThreadState(var pFiberCookie: LongWord): HResult; stdcall;\r\n function SwitchOutLogicalThreadState(out pFiberCookie: PUINT1): HResult; stdcall;\r\n function LocksHeldByLogicalThread(out pCount: LongWord): HResult; stdcall;\r\n function MapFile(var hFile: Pointer; out hMapAddress: Pointer): HResult; stdcall;\r\n function GetConfiguration(out pConfiguration: ICorConfiguration): HResult; stdcall;\r\n function Start: HResult; stdcall;\r\n function Stop: HResult; stdcall;\r\n function CreateDomain(pwzFriendlyName: PWideChar; const pIdentityArray: IUnknown; \r\n out pAppDomain: IUnknown): HResult; stdcall;\r\n function GetDefaultDomain(out pAppDomain: IUnknown): HResult; stdcall;\r\n function EnumDomains(out hEnum: Pointer): HResult; stdcall;\r\n function NextDomain(hEnum: Pointer; out pAppDomain: IUnknown): HResult; stdcall;\r\n function CloseEnum(hEnum: Pointer): HResult; stdcall;\r\n function CreateDomainEx(pwzFriendlyName: PWideChar; const pSetup: IUnknown; \r\n const pEvidence: IUnknown; out pAppDomain: IUnknown): HResult; stdcall;\r\n function CreateDomainSetup(out pAppDomainSetup: IUnknown): HResult; stdcall;\r\n function CreateEvidence(out pEvidence: IUnknown): HResult; stdcall;\r\n function UnloadDomain(const pAppDomain: IUnknown): HResult; stdcall;\r\n function CurrentDomain(out pAppDomain: IUnknown): HResult; stdcall;\r\n end;\r\n\r\n// *********************************************************************//\r\n// Interface: IGCHost\r\n// Flags: (0)\r\n// GUID: {FAC34F6E-0DCD-47B5-8021-531BC5ECCA63}\r\n// *********************************************************************//\r\n IGCHost = interface(IUnknown)\r\n ['{FAC34F6E-0DCD-47B5-8021-531BC5ECCA63}']\r\n function SetGCStartupLimits(SegmentSize: LongWord; MaxGen0Size: LongWord): HResult; stdcall;\r\n function Collect(Generation: Integer): HResult; stdcall;\r\n function GetStats(var pStats: _COR_GC_STATS): HResult; stdcall;\r\n function GetThreadStats(var pFiberCookie: LongWord; var pStats: _COR_GC_THREAD_STATS): HResult; stdcall;\r\n function SetVirtualMemLimit(sztMaxVirtualMemMB: ULONG_PTR): HResult; stdcall;\r\n end;\r\n\r\n// *********************************************************************//\r\n// Interface: ICorConfiguration\r\n// Flags: (0)\r\n// GUID: {5C2B07A5-1E98-11D3-872F-00C04F79ED0D}\r\n// *********************************************************************//\r\n ICorConfiguration = interface(IUnknown)\r\n ['{5C2B07A5-1E98-11D3-872F-00C04F79ED0D}']\r\n function SetGCThreadControl(const pGCThreadControl: IGCThreadControl): HResult; stdcall;\r\n function SetGCHostControl(const pGCHostControl: IGCHostControl): HResult; stdcall;\r\n function SetDebuggerThreadControl(const pDebuggerThreadControl: IDebuggerThreadControl): HResult; stdcall;\r\n function AddDebuggerSpecialThread(dwSpecialThreadId: LongWord): HResult; stdcall;\r\n end;\r\n\r\n// *********************************************************************//\r\n// Interface: IGCThreadControl\r\n// Flags: (0)\r\n// GUID: {F31D1788-C397-4725-87A5-6AF3472C2791}\r\n// *********************************************************************//\r\n IGCThreadControl = interface(IUnknown)\r\n ['{F31D1788-C397-4725-87A5-6AF3472C2791}']\r\n function ThreadIsBlockingForSuspension: HResult; stdcall;\r\n function SuspensionStarting: HResult; stdcall;\r\n function SuspensionEnding(Generation: LongWord): HResult; stdcall;\r\n end;\r\n\r\n// *********************************************************************//\r\n// Interface: IGCHostControl\r\n// Flags: (0)\r\n// GUID: {5513D564-8374-4CB9-AED9-0083F4160A1D}\r\n// *********************************************************************//\r\n IGCHostControl = interface(IUnknown)\r\n ['{5513D564-8374-4CB9-AED9-0083F4160A1D}']\r\n function RequestVirtualMemLimit(sztMaxVirtualMemMB: ULONG_PTR; \r\n var psztNewMaxVirtualMemMB: ULONG_PTR): HResult; stdcall;\r\n end;\r\n\r\n// *********************************************************************//\r\n// Interface: IDebuggerThreadControl\r\n// Flags: (0)\r\n// GUID: {23D86786-0BB5-4774-8FB5-E3522ADD6246}\r\n// *********************************************************************//\r\n IDebuggerThreadControl = interface(IUnknown)\r\n ['{23D86786-0BB5-4774-8FB5-E3522ADD6246}']\r\n function ThreadIsBlockingForDebugger: HResult; stdcall;\r\n function ReleaseAllRuntimeThreads: HResult; stdcall;\r\n function StartBlockingForDebugger(dwUnused: LongWord): HResult; stdcall;\r\n end;\r\n\r\n// *********************************************************************//\r\n// Interface: IValidator\r\n// Flags: (0)\r\n// GUID: {63DF8730-DC81-4062-84A2-1FF943F59FAC}\r\n// *********************************************************************//\r\n IValidator = interface(IUnknown)\r\n ['{63DF8730-DC81-4062-84A2-1FF943F59FAC}']\r\n function Validate(const veh: IVEHandler; const pAppDomain: IUnknown; ulFlags: LongWord; \r\n ulMaxError: LongWord; Token: LongWord; fileName: PWideChar; var pe: Byte; \r\n ulSize: LongWord): HResult; stdcall;\r\n function FormatEventInfo(hVECode: HResult; Context: tag_VerError; msg: PWideChar; \r\n ulMaxLength: LongWord; psa: PSafeArray): HResult; stdcall;\r\n end;\r\n\r\n// *********************************************************************//\r\n// Interface: IDebuggerInfo\r\n// Flags: (0)\r\n// GUID: {BF24142D-A47D-4D24-A66D-8C2141944E44}\r\n// *********************************************************************//\r\n IDebuggerInfo = interface(IUnknown)\r\n ['{BF24142D-A47D-4D24-A66D-8C2141944E44}']\r\n function IsDebuggerAttached(out pbAttached: Integer): HResult; stdcall;\r\n end;\r\n\r\n// *********************************************************************//\r\n// Interface: IVEHandler\r\n// Flags: (0)\r\n// GUID: {856CA1B2-7DAB-11D3-ACEC-00C04F86C309}\r\n// *********************************************************************//\r\n IVEHandler = interface(IUnknown)\r\n ['{856CA1B2-7DAB-11D3-ACEC-00C04F86C309}']\r\n function VEHandler(VECode: HResult; Context: tag_VerError; psa: PSafeArray): HResult; stdcall;\r\n function SetReporterFtn(lFnPtr: Int64): HResult; stdcall;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoComCallUnmarshal provides a Create and CreateRemote method to \r\n// create instances of the default interface IMarshal exposed by \r\n// the CoClass ComCallUnmarshal. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoComCallUnmarshal = class\r\n class function Create: IMarshal;\r\n class function CreateRemote(const MachineName: string): IMarshal;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoCorRuntimeHost provides a Create and CreateRemote method to \r\n// create instances of the default interface ICorRuntimeHost exposed by \r\n// the CoClass CorRuntimeHost. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoCorRuntimeHost = class\r\n class function Create: ICorRuntimeHost;\r\n class function CreateRemote(const MachineName: string): ICorRuntimeHost;\r\n end;\r\n\r\n//DOM-IGNORE-END\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jcl.svn.sourceforge.net/svnroot/jcl/tags/JCL-2.4-Build4571/jcl/source/windows/mscoree_TLB.pas $';\r\n Revision: '$Revision: 3599 $';\r\n Date: '$Date: 2011-09-03 00:07:50 +0200 (sam. 03 sept. 2011) $';\r\n LogPath: 'JCL\\source\\windows';\r\n Extra: '';\r\n Data: nil\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses \r\n {$IFDEF HAS_UNITSCOPE}\r\n System.Win.ComObj;\r\n {$ELSE ~HAS_UNITSCOPE}\r\n ComObj;\r\n {$ENDIF ~HAS_UNITSCOPE}\r\n\r\nclass function CoComCallUnmarshal.Create: IMarshal;\r\nbegin\r\n Result := CreateComObject(CLASS_ComCallUnmarshal) as IMarshal;\r\nend;\r\n\r\nclass function CoComCallUnmarshal.CreateRemote(const MachineName: string): IMarshal;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_ComCallUnmarshal) as IMarshal;\r\nend;\r\n\r\nclass function CoCorRuntimeHost.Create: ICorRuntimeHost;\r\nbegin\r\n Result := CreateComObject(CLASS_CorRuntimeHost) as ICorRuntimeHost;\r\nend;\r\n\r\nclass function CoCorRuntimeHost.CreateRemote(const MachineName: string): ICorRuntimeHost;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_CorRuntimeHost) as ICorRuntimeHost;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jcl/source/windows/mscorlib_TLB.pas", "content": "{**************************************************************************************************}\r\n{ }\r\n{ Last modified: $Date:: 2011-09-03 00:07:50 +0200 (sam. 03 sept. 2011) $ }\r\n{ Revision: $Rev:: 3599 $ }\r\n{ Author: $Author:: outchy $ }\r\n{ }\r\n{**************************************************************************************************}\r\n\r\nunit mscorlib_TLB;\r\n\r\n// ************************************************************************ //\r\n// WARNING \r\n// ------- \r\n// The types declared in this file were generated from data read from a \r\n// Type Library. If this type library is explicitly or indirectly (via \r\n// another type library referring to this type library) re-imported, or the \r\n// 'Refresh' command of the Type Library Editor activated while editing the \r\n// Type Library, the contents of this file will be regenerated and all \r\n// manual modifications will be lost. \r\n// ************************************************************************ //\r\n\r\n// PASTLWTR : $Revision: 3599 $\r\n// File generated on 14.12.2003 01:40:37 from Type Library described below.\r\n\r\n// ************************************************************************ //\r\n// Type Lib: F:\\WINNT\\Microsoft.NET\\Framework\\v1.1.4322\\mscorlib.tlb (1)\r\n// LIBID: {BED7F4EA-1A96-11D2-8F08-00A0C9A6186D}\r\n// LCID: 0\r\n// Helpfile: \r\n// DepndLst: \r\n// (1) v2.0 stdole, (F:\\WINNT\\system32\\STDOLE2.TLB)\r\n// (2) v4.0 StdVCL, (F:\\WINNT\\system32\\STDVCL40.DLL)\r\n// Errors:\r\n// Hint: TypeInfo 'Object' changed to 'Object_'\r\n// Hint: TypeInfo 'Array' changed to 'Array_'\r\n// Hint: TypeInfo 'String' changed to 'String_'\r\n// Hint: TypeInfo 'Type' changed to 'Type_'\r\n// Hint: TypeInfo 'File' changed to 'File_'\r\n// Hint: TypeInfo 'Label' changed to 'Label_'\r\n// Hint: Parameter 'Array' of ICollection.CopyTo changed to 'Array_'\r\n// Hint: Member 'Type' of 'TypedReference' changed to 'Type_'\r\n// Hint: Parameter 'Type' of IFormatterConverter.Convert changed to 'Type_'\r\n// Hint: Parameter 'Type' of ISurrogateSelector.GetSurrogate changed to 'Type_'\r\n// Hint: Parameter 'Type' of IRegistrationServices.GetProgIdForType changed to 'Type_'\r\n// Hint: Parameter 'Type' of IRegistrationServices.RegisterTypeForComClients changed to 'Type_'\r\n// Hint: Parameter 'Type' of IRegistrationServices.TypeRequiresRegistration changed to 'Type_'\r\n// Hint: Parameter 'Type' of IRegistrationServices.TypeRepresentsComType changed to 'Type_'\r\n// Hint: Parameter 'or' of ITrackingHandler.MarshaledObject changed to 'or_'\r\n// Hint: Parameter 'or' of ITrackingHandler.UnmarshaledObject changed to 'or_'\r\n// Hint: Parameter 'Type' of _Binder.ChangeType changed to 'Type_'\r\n// Hint: Parameter 'Type' of _Type.GetMember changed to 'Type_'\r\n// Hint: Parameter 'Type' of _Assembly.GetManifestResourceStream changed to 'Type_'\r\n// ************************************************************************ //\r\n{$TYPEDADDRESS OFF} // Unit must be compiled without type-checked pointers. \r\n\r\n{$I jcl.inc}\r\n{$I windowsonly.inc}\r\n\r\n{$IFDEF SUPPORTS_WEAKPACKAGEUNIT}\r\n {$IFDEF UNITVERSIONING}\r\n {$WEAKPACKAGEUNIT OFF}\r\n {$ELSE ~UNITVERSIONING}\r\n {$WEAKPACKAGEUNIT ON}\r\n {$ENDIF ~UNITVERSIONING} \r\n{$ENDIF SUPPORTS_WEAKPACKAGEUNIT}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n {$IFDEF HAS_UNITSCOPE}\r\n Winapi.ActiveX, System.Classes;\r\n {$ELSE ~HAS_UNITSCOPE}\r\n ActiveX, Classes;\r\n {$ENDIF ~HAS_UNITSCOPE}\r\n\r\n//DOM-IGNORE-BEGIN\r\n\r\n// *********************************************************************//\r\n// GUIDS declared in the TypeLibrary. Following prefixes are used: \r\n// Type Libraries : LIBID_xxxx \r\n// CoClasses : CLASS_xxxx \r\n// DISPInterfaces : DIID_xxxx \r\n// Non-DISP interfaces: IID_xxxx \r\n// *********************************************************************//\r\nconst\r\n // TypeLibrary Major and minor versions\r\n mscorlibMajorVersion = 1;\r\n mscorlibMinorVersion = 10;\r\n\r\n LIBID_mscorlib: TGUID = '{BED7F4EA-1A96-11D2-8F08-00A0C9A6186D}';\r\n\r\n IID__Object: TGUID = '{65074F7F-63C0-304E-AF0A-D51741CB4A8D}';\r\n IID_ICloneable: TGUID = '{0CB251A7-3AB3-3B5C-A0B8-9DDF88824B85}';\r\n IID_IEnumerable: TGUID = '{496B0ABE-CDEE-11D3-88E8-00902754C43A}';\r\n IID_ICollection: TGUID = '{DE8DB6F8-D101-3A92-8D1C-E72E5F10E992}';\r\n IID_IList: TGUID = '{7BCFA00F-F764-3113-9140-3BBD127A96BB}';\r\n IID__Array: TGUID = '{2B67CECE-71C3-36A9-A136-925CCC1935A8}';\r\n IID_IEnumerator: TGUID = '{496B0ABF-CDEE-11D3-88E8-00902754C43A}';\r\n IID_IComparable: TGUID = '{DEB0E770-91FD-3CF6-9A6C-E6A3656F3965}';\r\n IID_IConvertible: TGUID = '{805E3B62-B5E9-393D-8941-377D8BF4556B}';\r\n IID__String: TGUID = '{36936699-FC79-324D-AB43-E33C1F94E263}';\r\n IID__StringBuilder: TGUID = '{9FB09782-8D39-3B0C-B79E-F7A37A65B3DA}';\r\n IID_ISerializable: TGUID = '{D0EEAA62-3D30-3EE2-B896-A2F34DDA47D8}';\r\n IID__Exception: TGUID = '{B36B5C63-42EF-38BC-A07E-0B34C98F164A}';\r\n IID__ValueType: TGUID = '{139E041D-0E41-39F5-A302-C4387E9D0A6C}';\r\n IID_IFormattable: TGUID = '{9A604EE7-E630-3DED-9444-BAAE247075AB}';\r\n IID__SystemException: TGUID = '{4C482CC2-68E9-37C6-8353-9A94BD2D7F0B}';\r\n IID__OutOfMemoryException: TGUID = '{CF3EDB7E-0574-3383-A44F-292F7C145DB4}';\r\n IID__StackOverflowException: TGUID = '{9CF4339A-2911-3B8A-8F30-E5C6B5BE9A29}';\r\n IID__ExecutionEngineException: TGUID = '{CCF0139C-79F7-3D0A-AFFE-2B0762C65B07}';\r\n IID__Delegate: TGUID = '{FB6AB00F-5096-3AF8-A33D-D7885A5FA829}';\r\n IID__MulticastDelegate: TGUID = '{16FE0885-9129-3884-A232-90B58C5B2AA9}';\r\n IID__Enum: TGUID = '{D09D1E04-D590-39A3-B517-B734A49A9277}';\r\n IID__MemberAccessException: TGUID = '{7EABA4E2-1259-3CF2-B084-9854278E5897}';\r\n IID__Activator: TGUID = '{03973551-57A1-3900-A2B5-9083E3FF2943}';\r\n IID__ApplicationException: TGUID = '{D81130BF-D627-3B91-A7C7-CEA597093464}';\r\n IID__EventArgs: TGUID = '{1F9EC719-343A-3CB3-8040-3927626777C1}';\r\n IID__ResolveEventArgs: TGUID = '{98947CF0-77E7-328E-B709-5DD1AA1C9C96}';\r\n IID__AssemblyLoadEventArgs: TGUID = '{7A0325F0-22C2-31F9-8823-9B8AEE9456B1}';\r\n IID__ResolveEventHandler: TGUID = '{8E54A9CC-7AA4-34CA-985B-BD7D7527B110}';\r\n IID__AssemblyLoadEventHandler: TGUID = '{DEECE11F-A893-3E35-A4C3-DAB7FA0911EB}';\r\n IID__MarshalByRefObject: TGUID = '{2C358E27-8C1A-3C03-B086-A40465625557}';\r\n IID__AppDomain: TGUID = '{05F696DC-2B29-3663-AD8B-C4389CF2A713}';\r\n IID_IEvidenceFactory: TGUID = '{35A8F3AC-FE28-360F-A0C0-9A4D50C4682A}';\r\n CLASS_AppDomain: TGUID = '{5FE0A145-A82B-3D96-94E3-FD214C9D6EB9}';\r\n IID__CrossAppDomainDelegate: TGUID = '{AF93163F-C2F4-3FAB-9FF1-728A7AAAD1CB}';\r\n IID_IAppDomainSetup: TGUID = '{27FFF232-A7A8-40DD-8D4A-734AD59FCD41}';\r\n IID__Attribute: TGUID = '{917B14D0-2D9E-38B8-92A9-381ACF52F7C0}';\r\n IID__LoaderOptimizationAttribute: TGUID = '{CE59D7AD-05CA-33B4-A1DD-06028D46E9D2}';\r\n IID__AppDomainUnloadedException: TGUID = '{6E96AA70-9FFB-399D-96BF-A68436095C54}';\r\n IID__ArgumentException: TGUID = '{4DB2C2B7-CBC2-3185-B966-875D4625B1A8}';\r\n IID__ArgumentNullException: TGUID = '{C991949B-E623-3F24-885C-BBB01FF43564}';\r\n IID__ArgumentOutOfRangeException: TGUID = '{77DA3028-BC45-3E82-BF76-2C123EE2C021}';\r\n IID__ArithmeticException: TGUID = '{9B012CF1-ACF6-3389-A336-C023040C62A2}';\r\n IID__ArrayTypeMismatchException: TGUID = '{DD7488A6-1B3F-3823-9556-C2772B15150F}';\r\n IID__AsyncCallback: TGUID = '{3612706E-0239-35FD-B900-0819D16D442D}';\r\n IID__AttributeUsageAttribute: TGUID = '{A902A192-49BA-3EC8-B444-AF5F7743F61A}';\r\n IID__BadImageFormatException: TGUID = '{F98BCE04-4A4B-398C-A512-FD8348D51E3B}';\r\n IID__BitConverter: TGUID = '{5CD861E8-CA91-301B-9E24-141E3D85BD5D}';\r\n IID__Buffer: TGUID = '{F036BCA4-F8DF-3682-8290-75285CE7456C}';\r\n IID__CannotUnloadAppDomainException: TGUID = '{6D4B6ADB-B9FA-3809-B5EA-FA57B56C546F}';\r\n IID__CharEnumerator: TGUID = '{1DD627FC-89E3-384F-BB9D-58CB4EFB9456}';\r\n IID__CLSCompliantAttribute: TGUID = '{BF1AF177-94CA-3E6D-9D91-55CF9E859D22}';\r\n IID__TypeUnloadedException: TGUID = '{C2A10F3A-356A-3C77-AAB9-8991D73A2561}';\r\n IID__Console: TGUID = '{88592805-9549-3E00-8308-03CFA6B93882}';\r\n IID__ContextMarshalException: TGUID = '{7386F4D7-7C11-389F-BB75-895714B12BB5}';\r\n IID__Convert: TGUID = '{9E1348D4-3FAC-3704-840D-20D91E4AD542}';\r\n IID__ContextBoundObject: TGUID = '{3EB1D909-E8BF-3C6B-ADA5-0E86E31E186E}';\r\n IID__ContextStaticAttribute: TGUID = '{160D517F-F175-3B61-8264-6D2305B8246C}';\r\n IID__TimeZone: TGUID = '{3025F666-7891-33D7-AACD-23D169EF354E}';\r\n IID__DBNull: TGUID = '{0D9F1B65-6D27-3E9F-BAF3-0597837E0F33}';\r\n IID__Binder: TGUID = '{3169AB11-7109-3808-9A61-EF4BA0534FD9}';\r\n IID_IObjectReference: TGUID = '{6E70ED5F-0439-38CE-83BB-860F1421F29F}';\r\n IID__DivideByZeroException: TGUID = '{BDEEA460-8241-3B41-9ED3-6E3E9977AC7F}';\r\n IID__DuplicateWaitObjectException: TGUID = '{D345A42B-CFE0-3EEE-861C-F3322812B388}';\r\n IID__TypeLoadException: TGUID = '{82D6B3BF-A633-3B3B-A09E-2363E4B24A41}';\r\n IID__EntryPointNotFoundException: TGUID = '{67388F3F-B600-3BCF-84AA-BB2B88DD9EE2}';\r\n IID__DllNotFoundException: TGUID = '{24AE6464-2834-32CD-83D6-FA06953DE62A}';\r\n IID__Environment: TGUID = '{29DC56CF-B981-3432-97C8-3680AB6D862D}';\r\n IID__EventHandler: TGUID = '{7CEFC46E-16E0-3E65-9C38-55B4342BA7F0}';\r\n IID__FieldAccessException: TGUID = '{8D5F5811-FFA1-3306-93E3-8AFC572B9B82}';\r\n IID__FlagsAttribute: TGUID = '{EBE3746D-DDEC-3D23-8E8D-9361BA87BAC6}';\r\n IID__FormatException: TGUID = '{07F92156-398A-3548-90B7-2E58026353D0}';\r\n IID__GC: TGUID = '{679ED106-5DC1-38FE-8B5C-2ADCA3552298}';\r\n IID_IAsyncResult: TGUID = '{11AB34E7-0176-3C9E-9EFE-197858400A3D}';\r\n IID_ICustomFormatter: TGUID = '{2B130940-CA5E-3406-8385-E259E68AB039}';\r\n IID_IDisposable: TGUID = '{805D7A98-D4AF-3F0F-967F-E5CF45312D2C}';\r\n IID_IFormatProvider: TGUID = '{C8CB1DED-2814-396A-9CC0-473CA49779CC}';\r\n IID__IndexOutOfRangeException: TGUID = '{E5A5F1E4-82C1-391F-A1C6-F39EAE9DC72F}';\r\n IID__InvalidCastException: TGUID = '{FA047CBD-9BA5-3A13-9B1F-6694D622CD76}';\r\n IID__InvalidOperationException: TGUID = '{8D520D10-0B8A-3553-8874-D30A4AD2FF4C}';\r\n IID__InvalidProgramException: TGUID = '{3410E0FB-636F-3CD1-8045-3993CA113F25}';\r\n IID__LocalDataStoreSlot: TGUID = '{DC77F976-318D-3A1A-9B60-ABB9DD9406D6}';\r\n IID__Math: TGUID = '{A19F91C8-7D23-3DFB-A988-CEE05B039121}';\r\n IID__MethodAccessException: TGUID = '{FF0BF77D-8F81-3D31-A3BB-6F54440FA7E5}';\r\n IID__MissingMemberException: TGUID = '{8897D14B-7FB3-3D8B-9EE4-221C3DBAD6FE}';\r\n IID__MissingFieldException: TGUID = '{9717176D-1179-3487-8849-CF5F63DE356E}';\r\n IID__MissingMethodException: TGUID = '{E5C659F6-92C8-3887-A07E-74D0D9C6267A}';\r\n IID__MulticastNotSupportedException: TGUID = '{D2BA71CC-1B3D-3966-A0D7-C61E957AD325}';\r\n IID__NonSerializedAttribute: TGUID = '{665C9669-B9C6-3ADD-9213-099F0127C893}';\r\n IID__NotFiniteNumberException: TGUID = '{8E21CE22-4F17-347B-B3B5-6A6DF3E0E58A}';\r\n IID__NotImplementedException: TGUID = '{1E4D31A2-63EA-397A-A77E-B20AD87A9614}';\r\n IID__NotSupportedException: TGUID = '{40E5451F-B237-33F8-945B-0230DB700BBB}';\r\n IID__NullReferenceException: TGUID = '{ECBE2313-CF41-34B4-9FD0-B6CD602B023F}';\r\n IID__ObjectDisposedException: TGUID = '{17B730BA-45EF-3DDF-9F8D-A490BAC731F4}';\r\n IID__ObsoleteAttribute: TGUID = '{E84307BE-3036-307A-ACC2-5D5DE8A006A8}';\r\n IID__OperatingSystem: TGUID = '{9E230640-A5D0-30E1-B217-9D2B6CC0FC40}';\r\n IID__OverflowException: TGUID = '{37C69A5D-7619-3A0F-A96B-9C9578AE00EF}';\r\n IID__ParamArrayAttribute: TGUID = '{D54500AE-8CF4-3092-9054-90DC91AC65C9}';\r\n IID__PlatformNotSupportedException: TGUID = '{1EB8340B-8190-3D9D-92F8-51244B9804C5}';\r\n IID__Random: TGUID = '{0F240708-629A-31AB-94A5-2BB476FE1783}';\r\n IID__RankException: TGUID = '{871DDC46-B68E-3FEE-A09A-C808B0F827E6}';\r\n IID_ICustomAttributeProvider: TGUID = '{B9B91146-D6C2-3A62-8159-C2D1794CDEB0}';\r\n IID__MemberInfo: TGUID = '{F7102FA9-CABB-3A74-A6DA-B4567EF1B079}';\r\n IID_IReflect: TGUID = '{AFBF15E5-C37C-11D2-B88E-00A0C9B471B8}';\r\n IID__Type: TGUID = '{BCA8B44D-AAD6-3A86-8AB7-03349F4F2DA2}';\r\n IID__SerializableAttribute: TGUID = '{1B96E53C-4028-38BC-9DC3-8D7A9555C311}';\r\n IID__TypeInitializationException: TGUID = '{FEB0323D-8CE4-36A4-A41E-0BA0C32E1A6A}';\r\n IID__UnauthorizedAccessException: TGUID = '{6193C5F6-6807-3561-A7F3-B64C80B5F00F}';\r\n IID__UnhandledExceptionEventArgs: TGUID = '{A218E20A-0905-3741-B0B3-9E3193162E50}';\r\n IID__UnhandledExceptionEventHandler: TGUID = '{84199E64-439C-3011-B249-3C9065735ADB}';\r\n IID__Version: TGUID = '{011A90C5-4910-3C29-BBB7-50D05CCBAA4A}';\r\n IID__WeakReference: TGUID = '{C5DF3568-C251-3C58-AFB4-32E79E8261F0}';\r\n IID__WaitHandle: TGUID = '{40DFC50A-E93A-3C08-B9EF-E2B4F28B5676}';\r\n IID__AutoResetEvent: TGUID = '{3F243EBD-612F-3DB8-9E03-BD92343A8371}';\r\n IID__CompressedStack: TGUID = '{4BCBC4D6-98EB-381A-A8A6-08B2378738ED}';\r\n IID__Interlocked: TGUID = '{DF20F518-8ED1-35E3-950E-020214FDB9B2}';\r\n IID_IObjectHandle: TGUID = '{C460E2B4-E199-412A-8456-84DC3E4838C3}';\r\n IID__ManualResetEvent: TGUID = '{C0BB9361-268F-3E72-BF6F-4120175A1500}';\r\n IID__Monitor: TGUID = '{EE22485E-4C45-3C9D-9027-A8D61C5F53F2}';\r\n IID__Mutex: TGUID = '{36CB559B-87C6-3AD2-9225-62A7ED499B37}';\r\n IID__Overlapped: TGUID = '{DD846FCC-8D04-3665-81B6-AACBE99C19C3}';\r\n IID__ReaderWriterLock: TGUID = '{AD89B568-4FD4-3F8D-8327-B396B20A460E}';\r\n IID__SynchronizationLockException: TGUID = '{87F55344-17E0-30FD-8EB9-38EAF6A19B3F}';\r\n IID__Thread: TGUID = '{C281C7F1-4AA9-3517-961A-463CFED57E75}';\r\n IID__ThreadAbortException: TGUID = '{95B525DB-6B81-3CDC-8FE7-713F7FC793C0}';\r\n IID__STAThreadAttribute: TGUID = '{85D72F83-BE91-3CB1-B4F0-76B56FF04033}';\r\n IID__MTAThreadAttribute: TGUID = '{C02468D1-8713-3225-BDA3-49B2FE37DDBB}';\r\n IID__ThreadInterruptedException: TGUID = '{B9E07599-7C44-33BE-A70E-EFA16F51F54A}';\r\n IID__RegisteredWaitHandle: TGUID = '{64409425-F8C9-370E-809E-3241CE804541}';\r\n IID__WaitCallback: TGUID = '{CE949142-4D4C-358D-89A9-E69A531AA363}';\r\n IID__WaitOrTimerCallback: TGUID = '{F078F795-F452-3D2D-8CC8-16D66AE46C67}';\r\n IID__IOCompletionCallback: TGUID = '{BBAE942D-BFF4-36E2-A3BC-508BB3801F4F}';\r\n IID__ThreadPool: TGUID = '{F5E02ADE-E724-3001-B498-3305B2A93D72}';\r\n IID__ThreadStart: TGUID = '{B45BBD7E-A977-3F56-A626-7A693E5DBBC5}';\r\n IID__ThreadStateException: TGUID = '{A13A41CF-E066-3B90-82F4-73109104E348}';\r\n IID__ThreadStaticAttribute: TGUID = '{A6B94B6D-854E-3172-A4EC-A17EDD16F85E}';\r\n IID__Timeout: TGUID = '{81456E86-22AF-31D1-A91A-9C370C0E2530}';\r\n IID__TimerCallback: TGUID = '{3741BC6F-101B-36D7-A9D5-03FCC0ECDA35}';\r\n IID__Timer: TGUID = '{B49A029B-406B-3B1E-88E4-F86690D20364}';\r\n IID__ArrayList: TGUID = '{401F89CB-C127-3041-82FD-B67035395C56}';\r\n IID__BitArray: TGUID = '{F145C46A-D170-3170-B52F-4678DFCA0300}';\r\n IID_IComparer: TGUID = '{C20FD3EB-7022-3D14-8477-760FAB54E50D}';\r\n IID__CaseInsensitiveComparer: TGUID = '{EA6795AC-97D6-3377-BE64-829ABD67607B}';\r\n IID_IHashCodeProvider: TGUID = '{5D573036-3435-3C5A-AEFF-2B8191082C71}';\r\n IID__CaseInsensitiveHashCodeProvider: TGUID = '{0422B845-B636-3688-8F61-9B6D93096336}';\r\n IID__CollectionBase: TGUID = '{B7D29E26-7798-3FA4-90F4-E6A22D2099F9}';\r\n IID__Comparer: TGUID = '{8064A157-B5C8-3A4A-AD3D-02DC1A39C417}';\r\n IID_IDictionary: TGUID = '{6A6841DF-3287-3D87-8060-CE0B4C77D2A1}';\r\n IID__DictionaryBase: TGUID = '{DDD44DA2-BC6B-3620-9317-C0372968C741}';\r\n IID_IDeserializationCallback: TGUID = '{AB3F47E4-C227-3B05-BF9F-94649BEF9888}';\r\n IID__Hashtable: TGUID = '{D25A197E-3E69-3271-A989-23D85E97F920}';\r\n IID_IDictionaryEnumerator: TGUID = '{35D574BF-7A4F-3588-8C19-12212A0FE4DC}';\r\n IID__Queue: TGUID = '{3A7D3CA4-B7D1-3A2A-800C-8FC2ACFCBDA4}';\r\n IID__ReadOnlyCollectionBase: TGUID = '{BD32D878-A59B-3E5C-BFE0-A96B1A1E9D6F}';\r\n IID__SortedList: TGUID = '{56421139-A143-3AE9-9852-1DBDFE3D6BFA}';\r\n IID__Stack: TGUID = '{AB538809-3C2F-35D9-80E6-7BAD540484A1}';\r\n IID__ConditionalAttribute: TGUID = '{E40A025C-645B-3C8E-A1AC-9C5CCA279625}';\r\n IID__Debugger: TGUID = '{A9B4786C-08E3-344F-A651-2F9926DEAC5E}';\r\n IID__DebuggerStepThroughAttribute: TGUID = '{3344E8B4-A5C3-3882-8D30-63792485ECCF}';\r\n IID__DebuggerHiddenAttribute: TGUID = '{55B6903B-55FE-35E0-804F-E42A096D2EB0}';\r\n IID__DebuggableAttribute: TGUID = '{428E3627-2B1F-302C-A7E6-6388CD535E75}';\r\n IID__StackTrace: TGUID = '{9A2669EC-FF84-3726-89A0-663A3EF3B5CD}';\r\n IID__StackFrame: TGUID = '{0E9B8E47-CA67-38B6-B9DB-2C42EE757B08}';\r\n IID_ISymbolBinder: TGUID = '{20808ADC-CC01-3F3A-8F09-ED12940FC212}';\r\n IID_ISymbolDocument: TGUID = '{1C32F012-2684-3EFE-8D50-9C2973ACC00B}';\r\n IID_ISymbolDocumentWriter: TGUID = '{FA682F24-3A3C-390D-B8A2-96F1106F4B37}';\r\n IID_ISymbolMethod: TGUID = '{25C72EB0-E437-3F17-946D-3B72A3ACFF37}';\r\n IID_ISymbolNamespace: TGUID = '{23ED2454-6899-3C28-BAB7-6EC86683964A}';\r\n IID_ISymbolReader: TGUID = '{E809A5F1-D3D7-3144-9BEF-FE8AC0364699}';\r\n IID_ISymbolScope: TGUID = '{1CEE3A11-01AE-3244-A939-4972FC9703EF}';\r\n IID_ISymbolVariable: TGUID = '{4042BD4D-B5AB-30E8-919B-14910687BAAE}';\r\n IID_ISymbolWriter: TGUID = '{DA295A1B-C5BD-3B34-8ACD-1D7D334FFB7F}';\r\n IID__SymDocumentType: TGUID = '{5141D79C-7B01-37DA-B7E9-53E5A271BAF8}';\r\n IID__SymLanguageType: TGUID = '{22BB8891-FD21-313D-92E4-8A892DC0B39C}';\r\n IID__SymLanguageVendor: TGUID = '{01364E7B-C983-3651-B7D8-FD1B64FC0E00}';\r\n IID__AmbiguousMatchException: TGUID = '{81AA0D59-C3B1-36A3-B2E7-054928FBFC1A}';\r\n IID__ModuleResolveEventHandler: TGUID = '{05532E88-E0F2-3263-9B57-805AC6B6BB72}';\r\n IID__Assembly: TGUID = '{17156360-2F1A-384A-BC52-FDE93C215C5B}';\r\n IID__AssemblyCultureAttribute: TGUID = '{177C4E63-9E0B-354D-838B-B52AA8683EF6}';\r\n IID__AssemblyVersionAttribute: TGUID = '{A1693C5C-101F-3557-94DB-C480CEB4C16B}';\r\n IID__AssemblyKeyFileAttribute: TGUID = '{A9FCDA18-C237-3C6F-A6EF-749BE22BA2BF}';\r\n IID__AssemblyKeyNameAttribute: TGUID = '{322A304D-11AC-3814-A905-A019F6E3DAE9}';\r\n IID__AssemblyDelaySignAttribute: TGUID = '{6CF1C077-C974-38E1-90A4-976E4835E165}';\r\n IID__AssemblyAlgorithmIdAttribute: TGUID = '{57B849AA-D8EF-3EA6-9538-C5B4D498C2F7}';\r\n IID__AssemblyFlagsAttribute: TGUID = '{0ECD8635-F5EB-3E4A-8989-4D684D67C48A}';\r\n IID__AssemblyFileVersionAttribute: TGUID = '{B101FE3C-4479-311A-A945-1225EE1731E8}';\r\n IID__AssemblyName: TGUID = '{B42B6AAC-317E-34D5-9FA9-093BB4160C50}';\r\n IID__AssemblyNameProxy: TGUID = '{FE52F19A-8AA8-309C-BF99-9D0A566FB76A}';\r\n IID__AssemblyCopyrightAttribute: TGUID = '{6163F792-3CD6-38F1-B5F7-000B96A5082B}';\r\n IID__AssemblyTrademarkAttribute: TGUID = '{64C26BF9-C9E5-3F66-AD74-BEBAADE36214}';\r\n IID__AssemblyProductAttribute: TGUID = '{DE10D587-A188-3DCB-8000-92DFDB9B8021}';\r\n IID__AssemblyCompanyAttribute: TGUID = '{C6802233-EF82-3C91-AD72-B3A5D7230ED5}';\r\n IID__AssemblyDescriptionAttribute: TGUID = '{6B2C0BC4-DDB7-38EA-8A86-F0B59E192816}';\r\n IID__AssemblyTitleAttribute: TGUID = '{DF44CAD3-CEF2-36A9-B013-383CC03177D7}';\r\n IID__AssemblyConfigurationAttribute: TGUID = '{746D1D1E-EE37-393B-B6FA-E387D37553AA}';\r\n IID__AssemblyDefaultAliasAttribute: TGUID = '{04311D35-75EC-347B-BEDF-969487CE4014}';\r\n IID__AssemblyInformationalVersionAttribute: TGUID = '{C6F5946C-143A-3747-A7C0-ABFADA6BDEB7}';\r\n IID__CustomAttributeFormatException: TGUID = '{1660EB67-EE41-363E-BEB0-C2DE09214ABF}';\r\n IID__MethodBase: TGUID = '{6240837A-707F-3181-8E98-A36AE086766B}';\r\n IID__ConstructorInfo: TGUID = '{E9A19478-9646-3679-9B10-8411AE1FD57D}';\r\n IID__DefaultMemberAttribute: TGUID = '{C462B072-FE6E-3BDC-9FAB-4CDBFCBCD124}';\r\n IID__EventInfo: TGUID = '{9DE59C64-D889-35A1-B897-587D74469E5B}';\r\n IID__FieldInfo: TGUID = '{8A7C1442-A9FB-366B-80D8-4939FFA6DBE0}';\r\n IID__InvalidFilterCriteriaException: TGUID = '{E6DF0AE7-BA15-3F80-8AFA-27773AE414FC}';\r\n IID__ManifestResourceInfo: TGUID = '{3188878C-DEB3-3558-80E8-84E9ED95F92C}';\r\n IID__MemberFilter: TGUID = '{FAE5D9B7-40C1-3DE1-BE06-A91C9DA1BA9F}';\r\n IID__MethodInfo: TGUID = '{FFCC1B5D-ECB8-38DD-9B01-3DC8ABC2AA5F}';\r\n IID__Missing: TGUID = '{0C48F55D-5240-30C7-A8F1-AF87A640CEFE}';\r\n IID__Module: TGUID = '{D002E9BA-D9E3-3749-B1D3-D565A08B13E7}';\r\n IID__ParameterInfo: TGUID = '{993634C4-E47A-32CC-BE08-85F567DC27D6}';\r\n IID__Pointer: TGUID = '{F0DEAFE9-5EBA-3737-9950-C1795739CDCD}';\r\n IID__PropertyInfo: TGUID = '{F59ED4E4-E68F-3218-BD77-061AA82824BF}';\r\n IID__ReflectionTypeLoadException: TGUID = '{22C26A41-5FA3-34E3-A76F-BA480252D8EC}';\r\n IID__StrongNameKeyPair: TGUID = '{FC4963CB-E52B-32D8-A418-D058FA51A1FA}';\r\n IID__TargetException: TGUID = '{98B1524D-DA12-3C4B-8A69-7539A6DEC4FA}';\r\n IID__TargetInvocationException: TGUID = '{A90106ED-9099-3329-8A5A-2044B3D8552B}';\r\n IID__TargetParameterCountException: TGUID = '{6032B3CD-9BED-351C-A145-9D500B0F636F}';\r\n IID__TypeDelegator: TGUID = '{34E00EF9-83E2-3BBC-B6AF-4CAE703838BD}';\r\n IID__TypeFilter: TGUID = '{E1817846-3745-3C97-B4A6-EE20A1641B29}';\r\n IID__UnmanagedMarshal: TGUID = '{FD302D86-240A-3694-A31F-9EF59E6E41BC}';\r\n IID_IFormatter: TGUID = '{93D7A8C5-D2EB-319B-A374-A65D321F2AA9}';\r\n IID__Formatter: TGUID = '{D9BD3C8D-9395-3657-B6EE-D1B509C38B70}';\r\n IID_IFormatterConverter: TGUID = '{F4F5C303-FAD3-3D0C-A4DF-BB82B5EE308F}';\r\n IID__FormatterConverter: TGUID = '{3FAA35EE-C867-3E2E-BF48-2DA271F88303}';\r\n IID__FormatterServices: TGUID = '{F859954A-78CF-3D00-86AB-EF661E6A4B8D}';\r\n IID_ISerializationSurrogate: TGUID = '{62339172-DBFA-337B-8AC8-053B241E06AB}';\r\n IID_ISurrogateSelector: TGUID = '{7C66FF18-A1A5-3E19-857B-0E7B6A9E3F38}';\r\n IID__ObjectIDGenerator: TGUID = '{A30646CC-F710-3BFA-A356-B4C858D4ED8E}';\r\n IID__ObjectManager: TGUID = '{F28E7D04-3319-3968-8201-C6E55BECD3D4}';\r\n IID__SerializationBinder: TGUID = '{450222D0-87CA-3699-A7B4-D8A0FDB72357}';\r\n IID__SerializationInfo: TGUID = '{B58D62CF-B03A-3A14-B0B6-B1E5AD4E4AD5}';\r\n IID__SerializationInfoEnumerator: TGUID = '{607056C6-1BCA-36C8-AB87-33B202EBF0D8}';\r\n IID__SerializationException: TGUID = '{245FE7FD-E020-3053-B5F6-7467FD2C6883}';\r\n IID__SurrogateSelector: TGUID = '{6DE1230E-1F52-3779-9619-F5184103466C}';\r\n IID__Calendar: TGUID = '{4CCA29E4-584B-3CD0-AD25-855DC5799C16}';\r\n IID__CompareInfo: TGUID = '{505DEFE5-AEFA-3E23-82B0-D5EB085BB840}';\r\n IID__CultureInfo: TGUID = '{152722C2-F0B1-3D19-ADA8-F40CA5CAECB8}';\r\n IID__DateTimeFormatInfo: TGUID = '{015E9F67-337C-398A-A0C1-DA4AF1905571}';\r\n IID__DaylightTime: TGUID = '{EFEA8FEB-EE7F-3E48-8A36-6206A6ACBF73}';\r\n IID__GregorianCalendar: TGUID = '{677AD8B5-8A0E-3C39-92FB-72FB817CF694}';\r\n IID__HebrewCalendar: TGUID = '{96A62D6C-72A9-387A-81FA-E6DD5998CAEE}';\r\n IID__HijriCalendar: TGUID = '{28DDC187-56B2-34CF-A078-48BD1E113D1E}';\r\n IID__JapaneseCalendar: TGUID = '{D662AE3F-CEF9-38B4-BB8E-5D8DD1DBF806}';\r\n IID__JulianCalendar: TGUID = '{36E2DE92-1FB3-3D7D-BA26-9CAD5B98DD52}';\r\n IID__KoreanCalendar: TGUID = '{48BEA6C4-752E-3974-8CA8-CFB6274E2379}';\r\n IID__RegionInfo: TGUID = '{F9E97E04-4E1E-368F-B6C6-5E96CE4362D6}';\r\n IID__SortKey: TGUID = '{F4C70E15-2CA6-3E90-96ED-92E28491F538}';\r\n IID__StringInfo: TGUID = '{0A25141F-51B3-3121-AA30-0AF4556A52D9}';\r\n IID__TaiwanCalendar: TGUID = '{0C08ED74-0ACF-32A9-99DF-09A9DC4786DD}';\r\n IID__TextElementEnumerator: TGUID = '{8C248251-3E6C-3151-9F8E-A255FB8D2B12}';\r\n IID__TextInfo: TGUID = '{DB8DE23F-F264-39AC-B61C-CC1E7EB4A5E6}';\r\n IID__ThaiBuddhistCalendar: TGUID = '{C70C8AE8-925B-37CE-8944-34F15FF94307}';\r\n IID__NumberFormatInfo: TGUID = '{25E47D71-20DD-31BE-B261-7AE76497D6B9}';\r\n IID__Encoding: TGUID = '{DDEDB94D-4F3F-35C1-97C9-3F1D87628D9E}';\r\n IID__System_Text_Decoder: TGUID = '{2ADB0D4A-5976-38E4-852B-C131797430F5}';\r\n IID__System_Text_Encoder: TGUID = '{8FD56502-8724-3DF0-A1B5-9D0E8D4E4F78}';\r\n IID__ASCIIEncoding: TGUID = '{0CBE0204-12A1-3D40-9D9E-195DE6AAA534}';\r\n IID__UnicodeEncoding: TGUID = '{F7DD3B7F-2B05-3894-8EDA-59CDF9395B6A}';\r\n IID__UTF7Encoding: TGUID = '{89B9F00B-AA2A-3A49-91B4-E8D1F1C00E58}';\r\n IID__UTF8Encoding: TGUID = '{010FC1D0-3EF9-3F3B-AA0A-B78A1FF83A37}';\r\n IID_IResourceReader: TGUID = '{8965A22F-FBA8-36AD-8132-70BBD0DA457D}';\r\n IID_IResourceWriter: TGUID = '{E97AA6E5-595E-31C3-82F0-688FB91954C6}';\r\n IID__MissingManifestResourceException: TGUID = '{1A4E1878-FE8C-3F59-B6A9-21AB82BE57E9}';\r\n IID__NeutralResourcesLanguageAttribute: TGUID = '{F48DF808-8B7D-3F4E-9159-1DFD60F298D6}';\r\n IID__ResourceManager: TGUID = '{4DE671B7-7C85-37E9-AFF8-1222ABE4883E}';\r\n IID__ResourceReader: TGUID = '{7FBCFDC7-5CEC-3945-8095-DAED61BE5FB1}';\r\n IID__ResourceSet: TGUID = '{44D5F81A-727C-35AE-8DF8-9FF6722F1C6C}';\r\n IID__ResourceWriter: TGUID = '{AF170258-AAC6-3A86-BD34-303E62CED10E}';\r\n IID__SatelliteContractVersionAttribute: TGUID = '{5CBB1F47-FBA5-33B9-9D4A-57D6E3D133D2}';\r\n IID__Registry: TGUID = '{23BAE0C0-3A36-32F0-9DAD-0E95ADD67D23}';\r\n IID__RegistryKey: TGUID = '{2EAC6733-8D92-31D9-BE04-DC467EFC3EB1}';\r\n IID__X509Certificate: TGUID = '{68FD6F14-A7B2-36C8-A724-D01F90D73477}';\r\n IID__AsymmetricAlgorithm: TGUID = '{09343AC0-D19A-3E62-BC16-0F600F10180A}';\r\n IID__AsymmetricKeyExchangeDeformatter: TGUID = '{B6685CCA-7A49-37D1-A805-3DE829CB8DEB}';\r\n IID__AsymmetricKeyExchangeFormatter: TGUID = '{1365B84B-6477-3C40-BE6A-089DC01ECED9}';\r\n IID__AsymmetricSignatureDeformatter: TGUID = '{7CA5FE57-D1AC-3064-BB0B-F450BE40F194}';\r\n IID__AsymmetricSignatureFormatter: TGUID = '{5363D066-6295-3618-BE33-3F0B070B7976}';\r\n IID_ICryptoTransform: TGUID = '{8ABAD867-F515-3CF6-BB62-5F0C88B3BB11}';\r\n IID__ToBase64Transform: TGUID = '{23DED1E1-7D5F-3936-AA4E-18BBCC39B155}';\r\n IID__FromBase64Transform: TGUID = '{FC0717A6-2E86-372F-81F4-B35ED4BDF0DE}';\r\n IID__KeySizes: TGUID = '{8978B0BE-A89E-3FF9-9834-77862CEBFF3D}';\r\n IID__CryptographicException: TGUID = '{4311E8F5-B249-3F81-8FF4-CF853D85306D}';\r\n IID__CryptographicUnexpectedOperationException: TGUID = '{7FB08423-038F-3ACC-B600-E6D072BAE160}';\r\n IID__CryptoAPITransform: TGUID = '{983B8639-2ED7-364C-9899-682ABB2CE850}';\r\n IID__CspParameters: TGUID = '{D5331D95-FFF2-358F-AFD5-588F469FF2E4}';\r\n IID__CryptoConfig: TGUID = '{AB00F3F8-7DDE-3FF5-B805-6C5DBB200549}';\r\n IID__Stream: TGUID = '{2752364A-924F-3603-8F6F-6586DF98B292}';\r\n IID__CryptoStream: TGUID = '{4134F762-D0EC-3210-93C0-DE4F443D5669}';\r\n IID__SymmetricAlgorithm: TGUID = '{05BC0E38-7136-3825-9E34-26C1CF2142C9}';\r\n IID__DES: TGUID = '{C7EF0214-B91C-3799-98DD-C994AABFC741}';\r\n IID__DESCryptoServiceProvider: TGUID = '{65E8495E-5207-3248-9250-0FC849B4F096}';\r\n IID__DeriveBytes: TGUID = '{140EE78F-067F-3765-9258-C3BC72FE976B}';\r\n IID__DSA: TGUID = '{0EB5B5E0-1BE6-3A5F-87B3-E3323342F44E}';\r\n IID__DSACryptoServiceProvider: TGUID = '{1F38AAFE-7502-332F-971F-C2FC700A1D55}';\r\n IID__DSASignatureDeformatter: TGUID = '{0E774498-ADE6-3820-B1D5-426B06397BE7}';\r\n IID__DSASignatureFormatter: TGUID = '{4B5FC561-5983-31E4-903B-1404231B2C89}';\r\n IID__HashAlgorithm: TGUID = '{69D3BABA-1C3D-354C-ACFE-F19109EC3896}';\r\n IID__KeyedHashAlgorithm: TGUID = '{D182CF91-628C-3FF6-87F0-41BA51CC7433}';\r\n IID__HMACSHA1: TGUID = '{63AC7C37-C51A-3D82-8FDD-2A567039E46D}';\r\n IID__MACTripleDES: TGUID = '{1CAC0BDA-AC58-31BC-B624-63F77D0C3D2F}';\r\n IID__MD5: TGUID = '{9AA8765E-69A0-30E3-9CDE-EBC70662AE37}';\r\n IID__MD5CryptoServiceProvider: TGUID = '{D3F5C812-5867-33C9-8CEE-CB170E8D844A}';\r\n IID__MaskGenerationMethod: TGUID = '{85601FEE-A79D-3710-AF21-099089EDC0BF}';\r\n IID__PasswordDeriveBytes: TGUID = '{3CD62D67-586F-309E-A6D8-1F4BAAC5AC28}';\r\n IID__PKCS1MaskGenerationMethod: TGUID = '{425BFF0D-59E4-36A8-B1FF-1F5D39D698F4}';\r\n IID__RC2: TGUID = '{F7C0C4CC-0D49-31EE-A3D3-B8B551E4928C}';\r\n IID__RC2CryptoServiceProvider: TGUID = '{875715C5-CB64-3920-8156-0EE9CB0E07EA}';\r\n IID__RandomNumberGenerator: TGUID = '{7AE4B03C-414A-36E0-BA68-F9603004C925}';\r\n IID__RNGCryptoServiceProvider: TGUID = '{2C65D4C0-584C-3E4E-8E6D-1AFB112BFF69}';\r\n IID__RSA: TGUID = '{0B3FB710-A25C-3310-8774-1CF117F95BD4}';\r\n IID__RSACryptoServiceProvider: TGUID = '{BD9DF856-2300-3254-BCF0-679BA03C7A13}';\r\n IID__RSAOAEPKeyExchangeDeformatter: TGUID = '{37625095-7BAA-377D-A0DC-7F465C0167AA}';\r\n IID__RSAOAEPKeyExchangeFormatter: TGUID = '{77A416E7-2AC6-3D0E-98FF-3BA0F586F56F}';\r\n IID__RSAPKCS1KeyExchangeDeformatter: TGUID = '{8034AAF4-3666-3B6F-85CF-463F9BFD31A9}';\r\n IID__RSAPKCS1KeyExchangeFormatter: TGUID = '{9FF67F8E-A7AA-3BA6-90EE-9D44AF6E2F8C}';\r\n IID__RSAPKCS1SignatureDeformatter: TGUID = '{FC38507E-06A4-3300-8652-8D7B54341F65}';\r\n IID__RSAPKCS1SignatureFormatter: TGUID = '{FB7A5FF4-CFA8-3F24-AD5F-D5EB39359707}';\r\n IID__Rijndael: TGUID = '{21B52A91-856F-373C-AD42-4CF3F1021F5A}';\r\n IID__RijndaelManaged: TGUID = '{427EA9D3-11D8-3E38-9E05-A4F7FA684183}';\r\n IID__SHA1: TGUID = '{48600DD2-0099-337F-92D6-961D1E5010D4}';\r\n IID__SHA1CryptoServiceProvider: TGUID = '{A16537BC-1EDF-3516-B75E-CC65CAF873AB}';\r\n IID__SHA1Managed: TGUID = '{C27990BB-3CFD-3D29-8DC0-BBE5FBADEAFD}';\r\n IID__SHA256: TGUID = '{3B274703-DFAE-3F9C-A1B5-9990DF9D7FA3}';\r\n IID__SHA256Managed: TGUID = '{3D077954-7BCC-325B-9DDA-3B17A03378E0}';\r\n IID__SHA384: TGUID = '{B60AD5D7-2C2E-35B7-8D77-7946156CFE8E}';\r\n IID__SHA384Managed: TGUID = '{DE541460-F838-3698-B2DA-510B09070118}';\r\n IID__SHA512: TGUID = '{49DD9E4B-84F3-3D6D-91FB-3FEDCEF634C7}';\r\n IID__SHA512Managed: TGUID = '{DC8CE439-7954-36ED-803C-674F72F27249}';\r\n IID__SignatureDescription: TGUID = '{8017B414-4886-33DA-80A3-7865C1350D43}';\r\n IID__TripleDES: TGUID = '{C040B889-5278-3132-AFF9-AFA61707A81D}';\r\n IID__TripleDESCryptoServiceProvider: TGUID = '{EC69D083-3CD0-3C0C-998C-3B738DB535D5}';\r\n IID_ISecurityEncodable: TGUID = '{FD46BDE5-ACDF-3CA5-B189-F0678387077F}';\r\n IID_ISecurityPolicyEncodable: TGUID = '{E6C21BA7-21BB-34E9-8E57-DB66D8CE4A70}';\r\n IID_IMembershipCondition: TGUID = '{6844EFF4-4F86-3CA1-A1EA-AAF583A6395E}';\r\n IID__AllMembershipCondition: TGUID = '{99F01720-3CC2-366D-9AB9-50E36647617F}';\r\n IID__ApplicationDirectory: TGUID = '{9CCC831B-1BA7-34BE-A966-56D5A6DB5AAD}';\r\n IID__ApplicationDirectoryMembershipCondition: TGUID = '{A02A2B22-1DBA-3F92-9F84-5563182851BB}';\r\n IID__CodeGroup: TGUID = '{D7093F61-ED6B-343F-B1E9-02472FCC710E}';\r\n IID__Evidence: TGUID = '{A505EDBC-380E-3B23-9E1A-0974D4EF02EF}';\r\n IID__FileCodeGroup: TGUID = '{DFAD74DC-8390-32F6-9612-1BD293B233F4}';\r\n IID__FirstMatchCodeGroup: TGUID = '{54B0AFB1-E7D3-3770-BB0E-75A95E8D2656}';\r\n IID__Hash: TGUID = '{7574E121-74A6-3626-B578-0783BADB19D2}';\r\n IID__HashMembershipCondition: TGUID = '{6BA6EA7A-C9FC-3E73-82EC-18F29D83EEFD}';\r\n IID_IIdentityPermissionFactory: TGUID = '{4E95244E-C6FC-3A86-8DB7-1712454DE3B6}';\r\n IID__NetCodeGroup: TGUID = '{A8F69ECA-8C48-3B5E-92A1-654925058059}';\r\n IID__PermissionRequestEvidence: TGUID = '{34B0417E-E71D-304C-9FAC-689350A1B41C}';\r\n IID__PolicyException: TGUID = '{A9C9F3D9-E153-39B8-A533-B8DF4664407B}';\r\n IID__PolicyLevel: TGUID = '{44494E35-C370-3014-BC78-0F2ECBF83F53}';\r\n IID__PolicyStatement: TGUID = '{3EEFD1FC-4D8D-3177-99F6-6C19D9E088D3}';\r\n IID__Publisher: TGUID = '{77CCA693-ABF6-3773-BF58-C0B02701A744}';\r\n IID__PublisherMembershipCondition: TGUID = '{3515CF63-9863-3044-B3E1-210E98EFC702}';\r\n IID__Site: TGUID = '{90C40B4C-B0D0-30F5-B520-FDBA97BC31A0}';\r\n IID__SiteMembershipCondition: TGUID = '{0A7C3542-8031-3593-872C-78D85D7CC273}';\r\n IID__StrongName: TGUID = '{2A75C1FD-06B0-3CBB-B467-2545D4D6C865}';\r\n IID__StrongNameMembershipCondition: TGUID = '{579E93BC-FFAB-3B8D-9181-CE9C22B51915}';\r\n IID__UnionCodeGroup: TGUID = '{D9D822DE-44E5-33CE-A43F-173E475CECB1}';\r\n IID__Url: TGUID = '{D94ED9BF-C065-3703-81A2-2F76EA8E312F}';\r\n IID__UrlMembershipCondition: TGUID = '{BB7A158D-DBD9-3E13-B137-8E61E87E1128}';\r\n IID__Zone: TGUID = '{742E0C26-0E23-3D20-968C-D221094909AA}';\r\n IID__ZoneMembershipCondition: TGUID = '{ADBC3463-0101-3429-A06C-DB2F1DD6B724}';\r\n IID_IIdentity: TGUID = '{F4205A87-4D46-303D-B1D9-5A99F7C90D30}';\r\n IID__GenericIdentity: TGUID = '{9A37D8B2-2256-3FE3-8BF0-4FC421A1244F}';\r\n IID_IPrincipal: TGUID = '{4283CA6C-D291-3481-83C9-9554481FE888}';\r\n IID__GenericPrincipal: TGUID = '{B4701C26-1509-3726-B2E1-409A636C9B4F}';\r\n IID__WindowsIdentity: TGUID = '{D8CF3F23-1A66-3344-8230-07EB53970B85}';\r\n IID__WindowsImpersonationContext: TGUID = '{60ECFDDA-650A-324C-B4B3-F4D75B563BB1}';\r\n IID__WindowsPrincipal: TGUID = '{6C42BAF9-1893-34FC-B3AF-06931E9B34A3}';\r\n IID__DispIdAttribute: TGUID = '{BBE41AC5-8692-3427-9AE1-C1058A38D492}';\r\n IID__InterfaceTypeAttribute: TGUID = '{A2145F38-CAC1-33DD-A318-21948AF6825D}';\r\n IID__ClassInterfaceAttribute: TGUID = '{6B6391EE-842F-3E9A-8EEE-F13325E10996}';\r\n IID__ComVisibleAttribute: TGUID = '{1E7FFFE2-AAD9-34EE-8A9F-3C016B880FF0}';\r\n IID__LCIDConversionAttribute: TGUID = '{4AB67927-3C86-328A-8186-F85357DD5527}';\r\n IID__ComRegisterFunctionAttribute: TGUID = '{51BA926F-AAB5-3945-B8A6-C8F0F4A7D12B}';\r\n IID__ComUnregisterFunctionAttribute: TGUID = '{9F164188-34EB-3F86-9F74-0BBE4155E65E}';\r\n IID__ProgIdAttribute: TGUID = '{2B9F01DF-5A12-3688-98D6-C34BF5ED1865}';\r\n IID__ImportedFromTypeLibAttribute: TGUID = '{3F3311CE-6BAF-3FB0-B855-489AFF740B6E}';\r\n IID__IDispatchImplAttribute: TGUID = '{5778E7C7-2040-330E-B47A-92974DFFCFD4}';\r\n IID__ComSourceInterfacesAttribute: TGUID = '{E1984175-55F5-3065-82D8-A683FDFCF0AC}';\r\n IID__ComConversionLossAttribute: TGUID = '{FD5B6AAC-FF8C-3472-B894-CD6DFADB6939}';\r\n IID__TypeLibTypeAttribute: TGUID = '{B5A1729E-B721-3121-A838-FDE43AF13468}';\r\n IID__TypeLibFuncAttribute: TGUID = '{3D18A8E2-EEDE-3139-B29D-8CAC057955DF}';\r\n IID__TypeLibVarAttribute: TGUID = '{7B89862A-02A4-3279-8B42-4095FA3A778E}';\r\n IID__MarshalAsAttribute: TGUID = '{D858399F-E19E-3423-A720-AC12ABE2E5E8}';\r\n IID__ComImportAttribute: TGUID = '{1B093056-5454-386F-8971-BBCBC4E9A8F3}';\r\n IID__GuidAttribute: TGUID = '{74435DAD-EC55-354B-8F5B-FA70D13B6293}';\r\n IID__PreserveSigAttribute: TGUID = '{FDF2A2EE-C882-3198-A48B-E37F0E574DFA}';\r\n IID__InAttribute: TGUID = '{8474B65C-C39A-3D05-893D-577B9A314615}';\r\n IID__OutAttribute: TGUID = '{0697FC8C-9B04-3783-95C7-45ECCAC1CA27}';\r\n IID__OptionalAttribute: TGUID = '{0D6BD9AD-198E-3904-AD99-F6F82A2787C4}';\r\n IID__DllImportAttribute: TGUID = '{A1A26181-D55E-3EE2-96E6-70B354EF9371}';\r\n IID__StructLayoutAttribute: TGUID = '{23753322-C7B3-3F9A-AC96-52672C1B1CA9}';\r\n IID__FieldOffsetAttribute: TGUID = '{C14342B8-BAFD-322A-BB71-62C672DA284E}';\r\n IID__ComAliasNameAttribute: TGUID = '{E78785C4-3A73-3C15-9390-618BF3A14719}';\r\n IID__AutomationProxyAttribute: TGUID = '{57B908A8-C082-3581-8A47-6B41B86E8FDC}';\r\n IID__PrimaryInteropAssemblyAttribute: TGUID = '{C69E96B2-6161-3621-B165-5805198C6B8D}';\r\n IID__CoClassAttribute: TGUID = '{15D54C00-7C95-38D7-B859-E19346677DCD}';\r\n IID__ComEventInterfaceAttribute: TGUID = '{76CC0491-9A10-35C0-8A66-7931EC345B7F}';\r\n IID__TypeLibVersionAttribute: TGUID = '{A03B61A4-CA61-3460-8232-2F4EC96AA88F}';\r\n IID__ComCompatibleVersionAttribute: TGUID = '{AD419379-2AC8-3588-AB1E-0115413277C4}';\r\n IID__BestFitMappingAttribute: TGUID = '{ED47ABE7-C84B-39F9-BE1B-828CFB925AFE}';\r\n IID__ExternalException: TGUID = '{A83F04E9-FD28-384A-9DFF-410688AC23AB}';\r\n IID__COMException: TGUID = '{A28C19DF-B488-34AE-BECC-7DE744D17F7B}';\r\n IID__CurrencyWrapper: TGUID = '{7DF6F279-DA62-3C9F-8944-4DD3C0F08170}';\r\n IID__DispatchWrapper: TGUID = '{72103C67-D511-329C-B19A-DD5EC3F1206C}';\r\n IID__ErrorWrapper: TGUID = '{F79DB336-06BE-3959-A5AB-58B2AB6C5FD1}';\r\n IID__ExtensibleClassFactory: TGUID = '{519EB857-7A2D-3A95-A2A3-8BB8ED63D41B}';\r\n IID_ICustomAdapter: TGUID = '{3CC86595-FEB5-3CE9-BA14-D05C8DC3321C}';\r\n IID_ICustomMarshaler: TGUID = '{601CD486-04BF-3213-9EA9-06EBE4351D74}';\r\n IID_ICustomFactory: TGUID = '{0CA9008E-EE90-356E-9F6D-B59E6006B9A4}';\r\n IID__InvalidComObjectException: TGUID = '{DE9156B5-5E7A-3041-BF45-A29A6C2CF48A}';\r\n IID__InvalidOleVariantTypeException: TGUID = '{76E5DBD6-F960-3C65-8EA6-FC8AD6A67022}';\r\n IID_IRegistrationServices: TGUID = '{CCBD682C-73A5-4568-B8B0-C7007E11ABA2}';\r\n IID_ITypeLibImporterNotifySink: TGUID = '{F1C3BF76-C3E4-11D3-88E7-00902754C43A}';\r\n IID_ITypeLibExporterNotifySink: TGUID = '{F1C3BF77-C3E4-11D3-88E7-00902754C43A}';\r\n IID_ITypeLibConverter: TGUID = '{F1C3BF78-C3E4-11D3-88E7-00902754C43A}';\r\n IID_ITypeLibExporterNameProvider: TGUID = '{FA1F3615-ACB9-486D-9EAC-1BEF87E36B09}';\r\n IID__Marshal: TGUID = '{5F06D2F8-F3D4-3585-814C-2E886C465F25}';\r\n IID__MarshalDirectiveException: TGUID = '{523F42A5-1FD2-355D-82BF-0D67C4A0A0E7}';\r\n IID__ObjectCreationDelegate: TGUID = '{E4A369D3-6CF0-3B05-9C0C-1A91E331641A}';\r\n CLASS_RegistrationServices: TGUID = '{475E398F-8AFA-43A7-A3BE-F4EF8D6787C9}';\r\n IID__RuntimeEnvironment: TGUID = '{EDCEE21A-3E3A-331E-A86D-274028BE6716}';\r\n IID__SafeArrayRankMismatchException: TGUID = '{8608FE7B-2FDC-318A-B711-6F7B2FEDED06}';\r\n IID__SafeArrayTypeMismatchException: TGUID = '{E093FB32-E43B-3B3F-A163-742C920C2AF3}';\r\n IID__SEHException: TGUID = '{3E72E067-4C5E-36C8-BBEF-1E2978C7780D}';\r\n CLASS_TypeLibConverter: TGUID = '{F1C3BF79-C3E4-11D3-88E7-00902754C43A}';\r\n IID__UnknownWrapper: TGUID = '{1C8D8B14-4589-3DCA-8E0F-A30E80FBD1A8}';\r\n IID_IExpando: TGUID = '{AFBF15E6-C37C-11D2-B88E-00A0C9B471B8}';\r\n IID__BinaryReader: TGUID = '{442E3C03-A205-3F21-AA4D-31768BB8EA28}';\r\n IID__BinaryWriter: TGUID = '{4CA8147E-BAA3-3A7F-92CE-A4FD7F17D8DA}';\r\n IID__BufferedStream: TGUID = '{4B7571C3-1275-3457-8FEE-9976FD3937E3}';\r\n IID__Directory: TGUID = '{8CE58FF5-F26D-38A4-9195-0E2ECB3B56B9}';\r\n IID__FileSystemInfo: TGUID = '{A5D29A57-36A8-3E36-A099-7458B1FABAA2}';\r\n IID__DirectoryInfo: TGUID = '{487E52F1-2BB9-3BD0-A0CA-6728B3A1D051}';\r\n IID__IOException: TGUID = '{C5BFC9BF-27A7-3A59-A986-44C85F3521BF}';\r\n IID__DirectoryNotFoundException: TGUID = '{C8A200E4-9735-30E4-B168-ED861A3020F2}';\r\n IID__EndOfStreamException: TGUID = '{D625AFD0-8FD9-3113-A900-43912A54C421}';\r\n IID__File: TGUID = '{5D59051F-E19D-329A-9962-FD00D552E13D}';\r\n IID__FileInfo: TGUID = '{C3C429F9-8590-3A01-B2B2-434837F3D16D}';\r\n IID__FileLoadException: TGUID = '{51D2C393-9B70-3551-84B5-FF5409FB3ADA}';\r\n IID__FileNotFoundException: TGUID = '{A15A976B-81E3-3EF4-8FF1-D75DDBE20AEF}';\r\n IID__FileStream: TGUID = '{74265195-4A46-3D6F-A9DD-69C367EA39C8}';\r\n IID__MemoryStream: TGUID = '{2DBC46FE-B3DD-3858-AFC2-D3A2D492A588}';\r\n IID__Path: TGUID = '{6DF93530-D276-31D9-8573-346778C650AF}';\r\n IID__PathTooLongException: TGUID = '{468B8EB4-89AC-381B-8F86-5E47EC0648B4}';\r\n IID__TextReader: TGUID = '{897471F2-9450-3F03-A41F-D2E1F1397854}';\r\n IID__StreamReader: TGUID = '{E645B470-DC3F-3CE0-8104-5837FEDA04B3}';\r\n IID__TextWriter: TGUID = '{556137EA-8825-30BC-9D49-E47A9DB034EE}';\r\n IID__StreamWriter: TGUID = '{1F124E1C-D05D-3643-A59F-C3DE6051994F}';\r\n IID__StringReader: TGUID = '{59733B03-0EA5-358C-95B5-659FCD9AA0B4}';\r\n IID__StringWriter: TGUID = '{CB9F94C0-D691-3B62-B0B2-3CE5309CFA62}';\r\n IID__AccessedThroughPropertyAttribute: TGUID = '{998DCF16-F603-355D-8C89-3B675947997F}';\r\n IID__CallConvCdecl: TGUID = '{A6C2239B-08E6-3822-9769-E3D4B0431B82}';\r\n IID__CallConvStdcall: TGUID = '{8E17A5CD-1160-32DC-8548-407E7C3827C9}';\r\n IID__CallConvThiscall: TGUID = '{FA73DD3D-A472-35ED-B8BE-F99A13581F72}';\r\n IID__CallConvFastcall: TGUID = '{3B452D17-3C5E-36C4-A12D-5E9276036CF8}';\r\n IID__RuntimeHelpers: TGUID = '{028A39F4-2061-3C98-897C-2F6B29370B9B}';\r\n IID__CustomConstantAttribute: TGUID = '{62CAF4A2-6A78-3FC7-AF81-A6BBF930761F}';\r\n IID__DateTimeConstantAttribute: TGUID = '{EF387020-B664-3ACD-A1D2-806345845953}';\r\n IID__DiscardableAttribute: TGUID = '{3C3A8C69-7417-32FA-AA20-762D85E1B594}';\r\n IID__DecimalConstantAttribute: TGUID = '{7E133967-CCEC-3E89-8BD2-6CFCA649ECBF}';\r\n IID__CompilationRelaxationsAttribute: TGUID = '{C5C4F625-2329-3382-8994-AAF561E5DFE9}';\r\n IID__CompilerGlobalScopeAttribute: TGUID = '{1EED213E-656A-3A73-A4B9-0D3B26FD942B}';\r\n IID__IDispatchConstantAttribute: TGUID = '{97D0B28A-6932-3D74-B67F-6BCD3C921E7D}';\r\n IID__IndexerNameAttribute: TGUID = '{243368F5-67C9-3510-9424-335A8A67772F}';\r\n IID__IsVolatile: TGUID = '{0278C819-0C06-3756-B053-601A3E566D9B}';\r\n IID__IUnknownConstantAttribute: TGUID = '{54542649-CE64-3F96-BCE5-FDE3BB22F242}';\r\n IID__MethodImplAttribute: TGUID = '{98966503-5D80-3242-83EF-79E136F6B954}';\r\n IID__RequiredAttributeAttribute: TGUID = '{DB2C11D9-3870-35E7-A10C-A3DDC3DC79B1}';\r\n IID_IStackWalk: TGUID = '{60FC57B0-4A46-32A0-A5B4-B05B0DE8E781}';\r\n IID__PermissionSet: TGUID = '{C2AF4970-4FB6-319C-A8AA-0614D27F2B2C}';\r\n IID__NamedPermissionSet: TGUID = '{BA3E053F-ADE3-3233-874A-16E624C9A49B}';\r\n IID__SecurityElement: TGUID = '{8D597C42-2CFD-32B6-B6D6-86C9E2CFF00A}';\r\n IID__XmlSyntaxException: TGUID = '{D9FCAD88-D869-3788-A802-1B1E007C7A22}';\r\n IID_IPermission: TGUID = '{A19B3FC6-D680-3DD4-A17A-F58A7D481494}';\r\n IID__CodeAccessPermission: TGUID = '{4803CE39-2F30-31FC-B84B-5A0141385269}';\r\n IID_IUnrestrictedPermission: TGUID = '{0F1284E6-4399-3963-8DDD-A6A4904F66C8}';\r\n IID__EnvironmentPermission: TGUID = '{0720590D-5218-352A-A337-5449E6BD19DA}';\r\n IID__FileDialogPermission: TGUID = '{A8B7138C-8932-3D78-A585-A91569C743AC}';\r\n IID__FileIOPermission: TGUID = '{A2ED7EFC-8E59-3CCC-AE92-EA2377F4D5EF}';\r\n IID__IsolatedStoragePermission: TGUID = '{7FEE7903-F97C-3350-AD42-196B00AD2564}';\r\n IID__IsolatedStorageFilePermission: TGUID = '{0D0C83E8-BDE1-3BA5-B1EF-A8FC686D8BC9}';\r\n IID__SecurityAttribute: TGUID = '{48815668-6C27-3312-803E-2757F55CE96A}';\r\n IID__CodeAccessSecurityAttribute: TGUID = '{9C5149CB-D3C6-32FD-A0D5-95350DE7B813}';\r\n IID__EnvironmentPermissionAttribute: TGUID = '{4164071A-ED12-3BDD-AF40-FDABCAA77D5F}';\r\n IID__FileDialogPermissionAttribute: TGUID = '{0CCCA629-440F-313E-96CD-BA1B4B4997F7}';\r\n IID__FileIOPermissionAttribute: TGUID = '{0DCA817D-F21A-3943-B54C-5E800CE5BC50}';\r\n IID__PrincipalPermissionAttribute: TGUID = '{68AB69E4-5D68-3B51-B74D-1BEAB9F37F2B}';\r\n IID__ReflectionPermissionAttribute: TGUID = '{D31EED10-A5F0-308F-A951-E557961EC568}';\r\n IID__RegistryPermissionAttribute: TGUID = '{38B6068C-1E94-3119-8841-1ECA35ED8578}';\r\n IID__SecurityPermissionAttribute: TGUID = '{3A5B876C-CDE4-32D2-9C7E-020A14ACA332}';\r\n IID__UIPermissionAttribute: TGUID = '{1D5C0F70-AF29-38A3-9436-3070A310C73B}';\r\n IID__ZoneIdentityPermissionAttribute: TGUID = '{2E3BE3ED-2F22-3B20-9F92-BD29B79D6F42}';\r\n IID__StrongNameIdentityPermissionAttribute: TGUID = '{C9A740F4-26E9-39A8-8885-8CA26BD79B21}';\r\n IID__SiteIdentityPermissionAttribute: TGUID = '{6FE6894A-2A53-3FB6-A06E-348F9BDAD23B}';\r\n IID__UrlIdentityPermissionAttribute: TGUID = '{CA4A2073-48C5-3E61-8349-11701A90DD9B}';\r\n IID__PublisherIdentityPermissionAttribute: TGUID = '{6722C730-1239-3784-AC94-C285AE5B901A}';\r\n IID__IsolatedStoragePermissionAttribute: TGUID = '{5C4C522F-DE4E-3595-9AA9-9319C86A5283}';\r\n IID__IsolatedStorageFilePermissionAttribute: TGUID = '{6F1F8AAE-D667-39CC-98FA-722BEBBBEAC3}';\r\n IID__PermissionSetAttribute: TGUID = '{947A1995-BC16-3E7C-B65A-99E71F39C091}';\r\n IID__PublisherIdentityPermission: TGUID = '{E86CC74A-1233-3DF3-B13F-8B27EEAAC1F6}';\r\n IID__ReflectionPermission: TGUID = '{AEB3727F-5C3A-34C4-BF18-A38F088AC8C7}';\r\n IID__RegistryPermission: TGUID = '{C3FB5510-3454-3B31-B64F-DE6AAD6BE820}';\r\n IID__PrincipalPermission: TGUID = '{7C6B06D1-63AD-35EF-A938-149B4AD9A71F}';\r\n IID__SecurityPermission: TGUID = '{33C54A2D-02BD-3848-80B6-742D537085E5}';\r\n IID__SiteIdentityPermission: TGUID = '{790B3EE9-7E06-3CD0-8243-5848486D6A78}';\r\n IID__StrongNameIdentityPermission: TGUID = '{5F1562FB-0160-3655-BAEA-B15BEF609161}';\r\n IID__StrongNamePublicKeyBlob: TGUID = '{AF53D21A-D6AF-3406-B399-7DF9D2AAD48A}';\r\n IID__UIPermission: TGUID = '{47698389-F182-3A67-87DF-AED490E14DC6}';\r\n IID__UrlIdentityPermission: TGUID = '{EC7CAC31-08A2-393B-BDF2-D052EB53AF2C}';\r\n IID__ZoneIdentityPermission: TGUID = '{38B2F8D7-8CF4-323B-9C17-9C55EE287A63}';\r\n IID__SuppressUnmanagedCodeSecurityAttribute: TGUID = '{8000E51A-541C-3B20-A8EC-C8A8B41116C4}';\r\n IID__UnverifiableCodeAttribute: TGUID = '{41F41C1B-7B8D-39A3-A28F-AAE20787F469}';\r\n IID__AllowPartiallyTrustedCallersAttribute: TGUID = '{F1C930C4-2233-3924-9840-231D008259B4}';\r\n IID__SecurityException: TGUID = '{F174290F-E4CF-3976-88AA-4F8E32EB03DB}';\r\n IID__SecurityManager: TGUID = '{ABC04B16-5539-3C7E-92EC-0905A4A24464}';\r\n IID__VerificationException: TGUID = '{F65070DF-57AF-3AE3-B951-D2AD7D513347}';\r\n IID_IContextAttribute: TGUID = '{4A68BAA3-27AA-314A-BDBB-6AE9BDFC0420}';\r\n IID_IContextProperty: TGUID = '{F01D896D-8D5F-3235-BE59-20E1E10DC22A}';\r\n IID__ContextAttribute: TGUID = '{F042505B-7AAC-313B-A8C7-3F1AC949C311}';\r\n IID_IActivator: TGUID = '{C02BBB79-5AA8-390D-927F-717B7BFF06A1}';\r\n IID_IMessageSink: TGUID = '{941F8AAA-A353-3B1D-A019-12E44377F1CD}';\r\n IID__AsyncResult: TGUID = '{3936ABE1-B29E-3593-83F1-793D1A7F3898}';\r\n IID__CallContext: TGUID = '{53BCE4D4-6209-396D-BD4A-0B0A0A177DF9}';\r\n IID_ILogicalThreadAffinative: TGUID = '{4D125449-BA27-3927-8589-3E1B34B622E5}';\r\n IID__LogicalCallContext: TGUID = '{9AFF21F5-1C9C-35E7-AEA4-C3AA0BEB3B77}';\r\n IID__ChannelServices: TGUID = '{FFB2E16E-E5C7-367C-B326-965ABF510F24}';\r\n IID_IClientResponseChannelSinkStack: TGUID = '{3AFAB213-F5A2-3241-93BA-329EA4BA8016}';\r\n IID_IClientChannelSinkStack: TGUID = '{3A5FDE6B-DB46-34E8-BACD-16EA5A440540}';\r\n IID__ClientChannelSinkStack: TGUID = '{E1796120-C324-30D8-86F4-20086711463B}';\r\n IID_IServerResponseChannelSinkStack: TGUID = '{9BE679A6-61FD-38FC-A7B2-89982D33338B}';\r\n IID_IServerChannelSinkStack: TGUID = '{E694A733-768D-314D-B317-DCEAD136B11D}';\r\n IID__ServerChannelSinkStack: TGUID = '{52DA9F90-89B3-35AB-907B-3562642967DE}';\r\n IID__InternalMessageWrapper: TGUID = '{EF926E1F-3EE7-32BC-8B01-C6E98C24BC19}';\r\n IID_IMessage: TGUID = '{1A8B0DE6-B825-38C5-B744-8F93075FD6FA}';\r\n IID_IMethodMessage: TGUID = '{8E5E0B95-750E-310D-892C-8CA7231CF75B}';\r\n IID_IMethodCallMessage: TGUID = '{B90EFAA6-25E4-33D2-ACA3-94BF74DC4AB9}';\r\n IID__MethodCallMessageWrapper: TGUID = '{C9614D78-10EA-3310-87EA-821B70632898}';\r\n IID_ISponsor: TGUID = '{675591AF-0508-3131-A7CC-287D265CA7D6}';\r\n IID__ClientSponsor: TGUID = '{FF19D114-3BDA-30AC-8E89-36CA64A87120}';\r\n IID__CrossContextDelegate: TGUID = '{EE949B7B-439F-363E-B9FC-34DB1FB781D7}';\r\n IID__Context: TGUID = '{11A2EA7A-D600-307B-A606-511A6C7950D1}';\r\n IID__ContextProperty: TGUID = '{4ACB3495-05DB-381B-890A-D12F5340DCA3}';\r\n IID_IContextPropertyActivator: TGUID = '{7197B56B-5FA1-31EF-B38B-62FEE737277F}';\r\n IID_IChannel: TGUID = '{563581E8-C86D-39E2-B2E8-6C23F7987A4B}';\r\n IID_IChannelSender: TGUID = '{10F1D605-E201-3145-B7AE-3AD746701986}';\r\n IID_IChannelReceiver: TGUID = '{48AD41DA-0872-31DA-9887-F81F213527E6}';\r\n IID_IServerChannelSinkProvider: TGUID = '{7DD6E975-24EA-323C-A98C-0FDE96F9C4E6}';\r\n IID_IChannelSinkBase: TGUID = '{308DE042-ACC8-32F8-B632-7CB9799D9AA6}';\r\n IID_IServerChannelSink: TGUID = '{21B5F37B-BEF3-354C-8F84-0F9F0863F5C5}';\r\n IID__EnterpriseServicesHelper: TGUID = '{77C9BCEB-9958-33C0-A858-599F66697DA7}';\r\n IID__Header: TGUID = '{0D296515-AD19-3602-B415-D8EC77066081}';\r\n IID__HeaderHandler: TGUID = '{5DBBAF39-A3DF-30B7-AAEA-9FD11394123F}';\r\n IID_IConstructionCallMessage: TGUID = '{FA28E3AF-7D09-31D5-BEEB-7F2626497CDE}';\r\n IID_IMethodReturnMessage: TGUID = '{F617690A-55F4-36AF-9149-D199831F8594}';\r\n IID_IConstructionReturnMessage: TGUID = '{CA0AB564-F5E9-3A7F-A80B-EB0AEEFA44E9}';\r\n IID_IChannelReceiverHook: TGUID = '{3A02D3F7-3F40-3022-853D-CFDA765182FE}';\r\n IID_IClientChannelSinkProvider: TGUID = '{3F8742C2-AC57-3440-A283-FE5FF4C75025}';\r\n IID_IClientFormatterSinkProvider: TGUID = '{6D94B6F3-DA91-3C2F-B876-083769667468}';\r\n IID_IServerFormatterSinkProvider: TGUID = '{042B5200-4317-3E4D-B653-7E9A08F1A5F2}';\r\n IID_IClientChannelSink: TGUID = '{FF726320-6B92-3E6C-AAAC-F97063D0B142}';\r\n IID_IClientFormatterSink: TGUID = '{46527C03-B144-3CF0-86B3-B8776148A6E9}';\r\n IID_IChannelDataStore: TGUID = '{1E250CCD-DC30-3217-A7E4-148F375A0088}';\r\n IID__ChannelDataStore: TGUID = '{AA6DA581-F972-36DE-A53B-7585428A68AB}';\r\n IID_ITransportHeaders: TGUID = '{1AC82FBE-4FF0-383C-BBFD-FE40ECB3628D}';\r\n IID__TransportHeaders: TGUID = '{65887F70-C646-3A66-8697-8A3F7D8FE94D}';\r\n IID__SinkProviderData: TGUID = '{A18545B7-E5EE-31EE-9B9B-41199B11C995}';\r\n IID__BaseChannelObjectWithProperties: TGUID = '{A1329EC9-E567-369F-8258-18366D89EAF8}';\r\n IID__BaseChannelSinkWithProperties: TGUID = '{8AF3451E-154D-3D86-80D8-F8478B9733ED}';\r\n IID__BaseChannelWithProperties: TGUID = '{94BB98ED-18BB-3843-A7FE-642824AB4E01}';\r\n IID_IContributeClientContextSink: TGUID = '{4DB956B7-69D0-312A-AA75-44FB55FD5D4B}';\r\n IID_IContributeDynamicSink: TGUID = '{A0FE9B86-0C06-32CE-85FA-2FF1B58697FB}';\r\n IID_IContributeEnvoySink: TGUID = '{124777B6-0308-3569-97E5-E6FE88EAE4EB}';\r\n IID_IContributeObjectSink: TGUID = '{6A5D38BC-2789-3546-81A1-F10C0FB59366}';\r\n IID_IContributeServerContextSink: TGUID = '{0CAA23EC-F78C-39C9-8D25-B7A9CE4097A7}';\r\n IID_IDynamicProperty: TGUID = '{00A358D4-4D58-3B9D-8FB6-FB7F6BC1713B}';\r\n IID_IDynamicMessageSink: TGUID = '{C74076BB-8A2D-3C20-A542-625329E9AF04}';\r\n IID_ILease: TGUID = '{53A561F2-CBBF-3748-BFFE-2180002DB3DF}';\r\n IID_IMessageCtrl: TGUID = '{3677CBB0-784D-3C15-BBC8-75CD7DC3901E}';\r\n IID_IRemotingFormatter: TGUID = '{AE1850FD-3596-3727-A242-2FC31C5A0312}';\r\n IID__LifetimeServices: TGUID = '{B0AD9A21-5439-3D88-8975-4018B828D74C}';\r\n IID__ReturnMessage: TGUID = '{0EEFF4C2-84BF-3E4E-BF22-B7BDBB5DF899}';\r\n IID__MethodCall: TGUID = '{95E01216-5467-371B-8597-4074402CCB06}';\r\n IID__ConstructionCall: TGUID = '{A2246AE7-EB81-3A20-8E70-C9FA341C7E10}';\r\n IID__MethodResponse: TGUID = '{9E9EA93A-D000-3AB9-BFCA-DDEB398A55B9}';\r\n IID_IFieldInfo: TGUID = '{CC18FD4D-AA2D-3AB4-9848-584BBAE4AB44}';\r\n IID__ConstructionResponse: TGUID = '{BE457280-6FFA-3E76-9822-83DE63C0C4E0}';\r\n IID__MethodReturnMessageWrapper: TGUID = '{89304439-A24F-30F6-9A8F-89CE472D85DA}';\r\n IID__ObjectHandle: TGUID = '{EA675B47-64E0-3B5F-9BE7-F7DC2990730D}';\r\n IID_IRemotingTypeInfo: TGUID = '{C09EFFA9-1FFE-3A52-A733-6236CBC45E7B}';\r\n IID_IChannelInfo: TGUID = '{855E6566-014A-3FE8-AA70-1EAC771E3A88}';\r\n IID_IEnvoyInfo: TGUID = '{2A6E91B9-A874-38E4-99C2-C5D83D78140D}';\r\n IID__ObjRef: TGUID = '{1DD3CF3D-DF8E-32FF-91EC-E19AA10B63FB}';\r\n IID__OneWayAttribute: TGUID = '{8FFEDC68-5233-3FA8-813D-405AABB33ECB}';\r\n IID__ProxyAttribute: TGUID = '{D80FF312-2930-3680-A5E9-B48296C7415F}';\r\n IID__RealProxy: TGUID = '{E0CF3F77-C7C3-33DA-BEB4-46147FC905DE}';\r\n IID__SoapAttribute: TGUID = '{725692A5-9E12-37F6-911C-E3DA77E5FACA}';\r\n IID__SoapTypeAttribute: TGUID = '{EBCDCD84-8C74-39FD-821C-F5EB3A2704D7}';\r\n IID__SoapMethodAttribute: TGUID = '{C58145B5-BD5A-3896-95D9-B358F54FBC44}';\r\n IID__SoapFieldAttribute: TGUID = '{46A3F9FF-F73C-33C7-BCC3-1BEF4B25E4AE}';\r\n IID__SoapParameterAttribute: TGUID = '{C32ABFC9-3917-30BF-A7BC-44250BDFC5D8}';\r\n IID__RemotingConfiguration: TGUID = '{4B10971E-D61D-373F-BC8D-2CCF31126215}';\r\n IID__System_Runtime_Remoting_TypeEntry: TGUID = '{8359F3AB-643F-3BCF-91E8-16E779EDEBE1}';\r\n IID__ActivatedClientTypeEntry: TGUID = '{BAC12781-6865-3558-A8D1-F1CADD2806DD}';\r\n IID__ActivatedServiceTypeEntry: TGUID = '{94855A3B-5CA2-32CF-B1AB-48FD3915822C}';\r\n IID__WellKnownClientTypeEntry: TGUID = '{4D0BC339-E3F9-3E9E-8F68-92168E6F6981}';\r\n IID__WellKnownServiceTypeEntry: TGUID = '{60B8B604-0AED-3093-AC05-EB98FB29FC47}';\r\n IID__RemotingException: TGUID = '{7264843F-F60C-39A9-99E1-029126AA0815}';\r\n IID__ServerException: TGUID = '{19373C44-55B4-3487-9AD8-4C621AAE85EA}';\r\n IID__RemotingTimeoutException: TGUID = '{44DB8E15-ACB1-34EE-81F9-56ED7AE37A5C}';\r\n IID__RemotingServices: TGUID = '{7B91368D-A50A-3D36-BE8E-5B8836A419AD}';\r\n IID__InternalRemotingServices: TGUID = '{F4EFB305-CDC4-31C5-8102-33C9B91774F3}';\r\n IID__MessageSurrogateFilter: TGUID = '{04A35D22-0B08-34E7-A573-88EF2374375E}';\r\n IID__RemotingSurrogateSelector: TGUID = '{551F7A57-8651-37DB-A94A-6A3CA09C0ED7}';\r\n IID__SoapServices: TGUID = '{7416B6EE-82E8-3A16-966B-018A40E7B1AA}';\r\n IID_ISoapXsd: TGUID = '{80031D2A-AD59-3FB4-97F3-B864D71DA86B}';\r\n IID__SoapDateTime: TGUID = '{1738ADBC-156E-3897-844F-C3147C528DEA}';\r\n IID__SoapDuration: TGUID = '{7EF50DDB-32A5-30A1-B412-47FAB911404A}';\r\n IID__SoapTime: TGUID = '{A3BF0BCD-EC32-38E6-92F2-5F37BAD8030D}';\r\n IID__SoapDate: TGUID = '{CFA6E9D2-B3DE-39A6-94D1-CC691DE193F8}';\r\n IID__SoapYearMonth: TGUID = '{103C7EF9-A9EE-35FB-84C5-3086C9725A20}';\r\n IID__SoapYear: TGUID = '{C20769F3-858D-316A-BE6D-C347A47948AD}';\r\n IID__SoapMonthDay: TGUID = '{F9EAD0AA-4156-368F-AE05-FD59D70F758D}';\r\n IID__SoapDay: TGUID = '{D9E8314D-5053-3497-8A33-97D3DCFE33E2}';\r\n IID__SoapMonth: TGUID = '{B4E32423-E473-3562-AA12-62FDE5A7D4A2}';\r\n IID__SoapHexBinary: TGUID = '{63B9DA95-FB91-358A-B7B7-90C34AA34AB7}';\r\n IID__SoapBase64Binary: TGUID = '{8ED115A1-5E7B-34DC-AB85-90316F28015D}';\r\n IID__SoapInteger: TGUID = '{30C65C40-4E54-3051-9D8F-4709B6AB214C}';\r\n IID__SoapPositiveInteger: TGUID = '{4979EC29-C2B7-3AD6-986D-5AAF7344CC4E}';\r\n IID__SoapNonPositiveInteger: TGUID = '{AAF5401E-F71C-3FE3-8A73-A25074B20D3A}';\r\n IID__SoapNonNegativeInteger: TGUID = '{BC261FC6-7132-3FB5-9AAC-224845D3AA99}';\r\n IID__SoapNegativeInteger: TGUID = '{E384AA10-A70C-3943-97CF-0F7C282C3BDC}';\r\n IID__SoapAnyUri: TGUID = '{818EC118-BE7E-3CDE-92C8-44B99160920E}';\r\n IID__SoapQName: TGUID = '{3AC646B6-6B84-382F-9AED-22C2433244E6}';\r\n IID__SoapNotation: TGUID = '{974F01F4-6086-3137-9448-6A31FC9BEF08}';\r\n IID__SoapNormalizedString: TGUID = '{F4926B50-3F23-37E0-9AFA-AA91FF89A7BD}';\r\n IID__SoapToken: TGUID = '{AB4E97B9-651D-36F4-AABA-28ACF5746624}';\r\n IID__SoapLanguage: TGUID = '{14AED851-A168-3462-B877-8F9A01126653}';\r\n IID__SoapName: TGUID = '{5EB06BEF-4ADF-3CC1-A6F2-62F76886B13A}';\r\n IID__SoapIdrefs: TGUID = '{7947A829-ADB5-34D0-9CC8-6C172742C803}';\r\n IID__SoapEntities: TGUID = '{ACA96DA3-96ED-397E-8A72-EE1BE1025F5E}';\r\n IID__SoapNmtoken: TGUID = '{E941FA15-E6C8-3DD4-B060-C0DDFBC0240A}';\r\n IID__SoapNmtokens: TGUID = '{A5E385AE-27FB-3708-BAF7-0BF1F3955747}';\r\n IID__SoapNcName: TGUID = '{725CDAF7-B739-35C1-8463-E2A923E1F618}';\r\n IID__SoapId: TGUID = '{6A46B6A2-2D2C-3C67-AF67-AAE0175F17AE}';\r\n IID__SoapIdref: TGUID = '{7DB7FD83-DE89-38E1-9645-D4CABDE694C0}';\r\n IID__SoapEntity: TGUID = '{37171746-B784-3586-A7D5-692A7604A66B}';\r\n IID__SynchronizationAttribute: TGUID = '{2D985674-231C-33D4-B14D-F3A6BD2EBE19}';\r\n IID_ITrackingHandler: TGUID = '{03EC7D10-17A5-3585-9A2E-0596FCAC3870}';\r\n IID__TrackingServices: TGUID = '{F51728F2-2DEF-308C-874A-CBB1BAA9CF9E}';\r\n IID__UrlAttribute: TGUID = '{717105A3-739B-3BC3-A2B7-AD215903FAD2}';\r\n IID__IsolatedStorage: TGUID = '{34EC3BD7-F2F6-3C20-A639-804BFF89DF65}';\r\n IID__IsolatedStorageFile: TGUID = '{6BBB7DEE-186F-3D51-9486-BE0A71E915CE}';\r\n IID__IsolatedStorageFileStream: TGUID = '{68D5592B-47C8-381A-8D51-3925C16CF025}';\r\n IID__IsolatedStorageException: TGUID = '{AEC2B0DE-9898-3607-B845-63E2E307CB5F}';\r\n IID_INormalizeForIsolatedStorage: TGUID = '{F5006531-D4D7-319E-9EDA-9B4B65AD8D4F}';\r\n IID_ISoapMessage: TGUID = '{E699146C-7793-3455-9BEF-964C90D8F995}';\r\n IID__InternalRM: TGUID = '{361A5049-1BC8-35A9-946A-53A877902F25}';\r\n IID__InternalST: TGUID = '{A864FB13-F945-3DC0-A01C-B903F944FC97}';\r\n IID__SoapMessage: TGUID = '{BC0847B2-BD5C-37B3-BA67-7D2D54B17238}';\r\n IID__SoapFault: TGUID = '{A1C392FC-314C-39D5-8DE6-1F8EBCA0A1E2}';\r\n IID__ServerFault: TGUID = '{02D1BD78-3BB6-37AD-A9F8-F7D5DA273E4E}';\r\n IID__BinaryFormatter: TGUID = '{3BCF0CB2-A849-375E-8189-1BA5F1F4A9B0}';\r\n IID__AssemblyBuilder: TGUID = '{BEBB2505-8B54-3443-AEAD-142A16DD9CC7}';\r\n IID__ConstructorBuilder: TGUID = '{ED3E4384-D7E2-3FA7-8FFD-8940D330519A}';\r\n IID__EventBuilder: TGUID = '{AADABA99-895D-3D65-9760-B1F12621FAE8}';\r\n IID__FieldBuilder: TGUID = '{CE1A3BF5-975E-30CC-97C9-1EF70F8F3993}';\r\n IID__ILGenerator: TGUID = '{A4924B27-6E3B-37F7-9B83-A4501955E6A7}';\r\n IID__LocalBuilder: TGUID = '{4E6350D1-A08B-3DEC-9A3E-C465F9AEEC0C}';\r\n IID__MethodBuilder: TGUID = '{007D8A14-FDF3-363E-9A0B-FEC0618260A2}';\r\n IID__CustomAttributeBuilder: TGUID = '{BE9ACCE8-AAFF-3B91-81AE-8211663F5CAD}';\r\n IID__MethodRental: TGUID = '{C2323C25-F57F-3880-8A4D-12EBEA7A5852}';\r\n IID__ModuleBuilder: TGUID = '{D05FFA9A-04AF-3519-8EE1-8D93AD73430B}';\r\n IID__OpCodes: TGUID = '{1DB1CC2A-DA73-389E-828B-5C616F4FAC49}';\r\n IID__ParameterBuilder: TGUID = '{36329EBA-F97A-3565-BC07-0ED5C6EF19FC}';\r\n IID__PropertyBuilder: TGUID = '{15F9A479-9397-3A63-ACBD-F51977FB0F02}';\r\n IID__SignatureHelper: TGUID = '{7D13DD37-5A04-393C-BBCA-A5FEA802893D}';\r\n IID__TypeBuilder: TGUID = '{7E5678EE-48B3-3F83-B076-C58543498A58}';\r\n IID__EnumBuilder: TGUID = '{C7BD73DE-9F85-3290-88EE-090B8BDFE2DF}';\r\n CLASS_AppDomainSetup: TGUID = '{3E8E0F03-D3FD-3A93-BAE0-C74A6494DBCA}';\r\n CLASS_Object_: TGUID = '{81C5FE01-027C-3E1C-98D5-DA9C9862AA21}';\r\n CLASS_Array_: TGUID = '{200FB91C-815D-39E0-9E07-0E1BDB2ED47B}';\r\n CLASS_String_: TGUID = '{296AFBFF-1B0B-3FF5-9D6C-4E7E599F8B57}';\r\n CLASS_StringBuilder: TGUID = '{E724B749-18D6-36AB-9F6D-09C36D9C6016}';\r\n CLASS_Exception: TGUID = '{A1C0A095-DF97-3441-BFC1-C9F194E494DB}';\r\n CLASS_ValueType: TGUID = '{CE8AD32F-B6DB-31EA-9F1E-C2424E0F5EEE}';\r\n CLASS_SystemException: TGUID = '{4224AC84-9B11-3561-8923-C893CA77ACBE}';\r\n CLASS_OutOfMemoryException: TGUID = '{CCF306AE-33BD-3003-9CCE-DAF5BEFEF611}';\r\n CLASS_StackOverflowException: TGUID = '{9C125A6F-EAE2-3FC1-97A1-C0DCEAB0B5DF}';\r\n CLASS_ExecutionEngineException: TGUID = '{E786FB32-B659-3D96-94C4-E1A9FC037868}';\r\n CLASS_Delegate: TGUID = '{03CE85F6-37CB-3588-B3DB-D5628BB1335B}';\r\n CLASS_MulticastDelegate: TGUID = '{198FFBDE-A6DB-3CC3-AB15-FBBB7250D624}';\r\n CLASS_Enum: TGUID = '{C43345B9-7FED-3FC7-8FC2-7B1B82BC109E}';\r\n CLASS_MemberAccessException: TGUID = '{0FF66430-C796-3EE7-902B-166C402CA288}';\r\n CLASS_Activator: TGUID = '{9BA4FD4E-2BC2-31A0-B721-D17ABA5B12C3}';\r\n CLASS_ApplicationException: TGUID = '{682D63B8-1692-31BE-88CD-5CB1F79EDB7B}';\r\n CLASS_EventArgs: TGUID = '{3FB717AF-9D21-3016-871A-DF817ABDDD51}';\r\n CLASS_ResolveEventArgs: TGUID = '{1C1D34A9-3F45-3B51-A9AF-0354975BF8CC}';\r\n CLASS_AssemblyLoadEventArgs: TGUID = '{81548590-3849-32A8-AA6F-F2B3137CF4A3}';\r\n CLASS_ResolveEventHandler: TGUID = '{A4B8C851-941A-3DEE-BD08-D9E2EED101C5}';\r\n CLASS_AssemblyLoadEventHandler: TGUID = '{2E130DC8-564E-397F-A628-397709DA52E9}';\r\n CLASS_MarshalByRefObject: TGUID = '{14B542C6-1C5A-3869-B8F8-FEEFD7B29D09}';\r\n CLASS_CrossAppDomainDelegate: TGUID = '{496219C1-3FB7-3DCF-8AF7-D56032F7891F}';\r\n CLASS_Attribute: TGUID = '{1765714B-E628-34C3-B66F-7686FAF462DA}';\r\n CLASS_LoaderOptimizationAttribute: TGUID = '{B39742FD-1A55-3810-9EA5-F6E86EBEB472}';\r\n CLASS_AppDomainUnloadedException: TGUID = '{61B3E12B-3586-3A58-A497-7ED7C4C794B9}';\r\n CLASS_ArgumentException: TGUID = '{3FDCEEC6-B14B-37E2-BB69-ABC7CA0DA22F}';\r\n CLASS_ArgumentNullException: TGUID = '{3BD1F243-9BC4-305D-9B1C-0D10C80329FC}';\r\n CLASS_ArgumentOutOfRangeException: TGUID = '{74BDD0B9-38D7-3FDA-A67E-D404EE684F24}';\r\n CLASS_ArithmeticException: TGUID = '{647053C3-1879-34D7-AE57-67015C91FC70}';\r\n CLASS_ArrayTypeMismatchException: TGUID = '{676E1164-752C-3A74-8D3F-BCD32A2026D6}';\r\n CLASS_AsyncCallback: TGUID = '{B2A87DDB-5DAB-395F-B7BE-AD83058FB516}';\r\n CLASS_AttributeUsageAttribute: TGUID = '{53A62BB1-75B9-3B52-AE98-92AFD573CDB1}';\r\n CLASS_BadImageFormatException: TGUID = '{E9148312-A9BF-3A45-BBCA-350967FD78F5}';\r\n CLASS_BitConverter: TGUID = '{450AD484-5D18-3A7A-8B24-A228680FD885}';\r\n CLASS_Buffer: TGUID = '{830FE109-4566-3AF2-9B57-5602724FCACE}';\r\n CLASS_CannotUnloadAppDomainException: TGUID = '{29C69707-875F-3678-8F01-283094A2DFB1}';\r\n CLASS_CharEnumerator: TGUID = '{277EABD6-F03A-3C52-8B42-B8E326D9C0CC}';\r\n CLASS_CLSCompliantAttribute: TGUID = '{15DBEC24-0E2D-3DB2-AF66-932203215895}';\r\n CLASS_TypeUnloadedException: TGUID = '{D6D2034D-5F67-30D7-9CC5-452F2C46694F}';\r\n CLASS_Console: TGUID = '{1929386A-E10F-3B73-84A1-F50E745332F0}';\r\n CLASS_ContextMarshalException: TGUID = '{CBEAA915-4D2C-3F77-98E8-A258B0FD3CEF}';\r\n CLASS_Convert: TGUID = '{5CB28930-956D-3ED0-B569-AC70F15470F9}';\r\n CLASS_ContextBoundObject: TGUID = '{7916CBEF-050E-3E39-B83A-5AB9558E72F1}';\r\n CLASS_ContextStaticAttribute: TGUID = '{96705EE3-F7AB-3E9A-9FB2-AD1D536E901A}';\r\n CLASS_TimeZone: TGUID = '{543C0DD8-A713-3777-B01A-AEB801DAC001}';\r\n CLASS_DBNull: TGUID = '{8C1A4524-3CEB-3436-B449-CAC456ECAB09}';\r\n CLASS_Binder: TGUID = '{74A6B90C-8710-32DA-BBF7-9D4445E071E9}';\r\n CLASS_DivideByZeroException: TGUID = '{F6914A11-D95D-324F-BA0F-39A374625290}';\r\n CLASS_DuplicateWaitObjectException: TGUID = '{CC20C6DF-A054-3F09-A5F5-A3B5A25F4CE6}';\r\n CLASS_TypeLoadException: TGUID = '{112BC2E7-9EF9-3648-AF9E-45C0D4B89929}';\r\n CLASS_EntryPointNotFoundException: TGUID = '{AD326409-BF80-3E0C-BA6F-EE2C33B675A5}';\r\n CLASS_DllNotFoundException: TGUID = '{46E97093-B2EC-3787-A9A5-470D1A27417C}';\r\n CLASS_Environment: TGUID = '{DF81B4FF-7226-30FA-84DF-80795BA1A642}';\r\n CLASS_EventHandler: TGUID = '{DCA836DE-C23D-334C-86B7-8385BE47030D}';\r\n CLASS_FieldAccessException: TGUID = '{BDA7BEE5-85F1-3B66-B610-DDF1D5898006}';\r\n CLASS_FlagsAttribute: TGUID = '{66CE75D4-0334-3CA6-BCA8-CE9AF28A4396}';\r\n CLASS_FormatException: TGUID = '{964AA3BD-4B12-3E23-9D7F-99342AFAE812}';\r\n CLASS_GC: TGUID = '{F87CDD00-CBF2-365C-BC2D-78CECD0CBF49}';\r\n CLASS_IndexOutOfRangeException: TGUID = '{5CA9971B-2DC3-3BC8-847A-5E6D15CBB16E}';\r\n CLASS_InvalidCastException: TGUID = '{7F6BCBE5-EB30-370B-9F1B-92A6265AFEDD}';\r\n CLASS_InvalidOperationException: TGUID = '{9546306B-1B68-33AF-80DB-3A9206501515}';\r\n CLASS_InvalidProgramException: TGUID = '{91591469-EFEF-3D63-90F9-88520F0AA1EF}';\r\n CLASS_LocalDataStoreSlot: TGUID = '{E95E800A-CBA4-3613-821D-6D6EF3BCBF6B}';\r\n CLASS_Math: TGUID = '{40CE262D-D951-3EB6-9B05-48A1EB4D0EBC}';\r\n CLASS_MethodAccessException: TGUID = '{92E76A74-2622-3AA9-A3CA-1AE8BD7BC4A8}';\r\n CLASS_MissingMemberException: TGUID = '{CDC70043-D56B-3799-B7BD-6113BBCA160A}';\r\n CLASS_MissingFieldException: TGUID = '{8D36569B-14D6-3C3D-B55C-9D02A45BFC3D}';\r\n CLASS_MissingMethodException: TGUID = '{58897D76-EF6C-327A-93F7-6CD66C424E11}';\r\n CLASS_MulticastNotSupportedException: TGUID = '{9DA2F8B8-59F0-3852-B509-0663E3BF643B}';\r\n CLASS_NonSerializedAttribute: TGUID = '{CC77F5F3-222D-3586-88C3-410477A3B65D}';\r\n CLASS_NotFiniteNumberException: TGUID = '{7E34AB89-0684-3B86-8A0F-E638EB4E6252}';\r\n CLASS_NotImplementedException: TGUID = '{F8BE2AD5-4E99-3E00-B10E-7C54D31C1C1D}';\r\n CLASS_NotSupportedException: TGUID = '{DAFB2462-2A5B-3818-B17E-602984FE1BB0}';\r\n CLASS_NullReferenceException: TGUID = '{7F71DB2D-1EA0-3CAE-8087-26095F5215E6}';\r\n CLASS_ObjectDisposedException: TGUID = '{F17BAAF6-D35C-3C6E-ACD3-D0D49A5022C4}';\r\n CLASS_ObsoleteAttribute: TGUID = '{08295C62-7462-3633-B35E-7AE68ACA3948}';\r\n CLASS_OperatingSystem: TGUID = '{D7CA3B25-A57B-354C-8758-9FE3A905C1AC}';\r\n CLASS_OverflowException: TGUID = '{4286FA72-A2FA-3245-8751-D4206070A191}';\r\n CLASS_ParamArrayAttribute: TGUID = '{3495E5FA-2A90-3CA7-B3B5-58736C4441DD}';\r\n CLASS_PlatformNotSupportedException: TGUID = '{A36738B5-FA8F-3316-A929-68099A32B43B}';\r\n CLASS_Random: TGUID = '{4E77EC8F-51D8-386C-85FE-7DC931B7A8E7}';\r\n CLASS_RankException: TGUID = '{C9F61CBD-287F-3D24-9FEB-2C3F347CF570}';\r\n CLASS_MemberInfo: TGUID = '{5AE028B5-9A3A-32A9-899C-1DEEFB85CC50}';\r\n CLASS_Type_: TGUID = '{6C9863DC-7207-327F-A048-C3BB63474BFC}';\r\n CLASS_SerializableAttribute: TGUID = '{89BCC804-53A5-3EB2-A342-6282CC410260}';\r\n CLASS_TypeInitializationException: TGUID = '{811FB5F2-9BFE-3557-83DE-1279F0B3EB55}';\r\n CLASS_UnauthorizedAccessException: TGUID = '{75215200-A2FE-30F6-A34B-8F1A1830358E}';\r\n CLASS_UnhandledExceptionEventArgs: TGUID = '{B55DAE2E-C8E8-3C48-B404-D991979A9D9D}';\r\n CLASS_UnhandledExceptionEventHandler: TGUID = '{DB4D2D94-3FA3-36F5-B22E-A00FF22F08BD}';\r\n CLASS_Version: TGUID = '{43CD41AD-3B78-3531-9031-3059E0AA64EB}';\r\n CLASS_WeakReference: TGUID = '{D3F54E92-A0C7-3BF4-A114-F1F384CE3EFF}';\r\n CLASS_WaitHandle: TGUID = '{4D0E564A-78C8-31E0-BA03-73AF7BDFF5A9}';\r\n CLASS_AutoResetEvent: TGUID = '{E35AF4DD-EB37-39FC-9071-4CE39B1A54BE}';\r\n CLASS_CompressedStack: TGUID = '{F3CE7312-70AE-37FF-98F6-CF1DCB22B9E4}';\r\n CLASS_Interlocked: TGUID = '{6AFBF244-9AB3-37D7-B4D4-357A72B76DE1}';\r\n CLASS_ManualResetEvent: TGUID = '{17A355C3-C65E-3F26-8A80-236890EBC997}';\r\n CLASS_Monitor: TGUID = '{9E97213A-0B49-3C05-A0BF-D203C4FC8487}';\r\n CLASS_Mutex: TGUID = '{D74D613D-F27F-311B-A9A3-27EBC63A1A5D}';\r\n CLASS_Overlapped: TGUID = '{7FE87A55-1321-3D9F-8FEF-CD2F5E8AB2E9}';\r\n CLASS_ReaderWriterLock: TGUID = '{9173D971-B142-38A5-8488-D10A9DCF71B0}';\r\n CLASS_SynchronizationLockException: TGUID = '{48A75519-CB7A-3D18-B91E-BE62EE842A3E}';\r\n CLASS_Thread: TGUID = '{A5889AAD-36A6-3B3E-89F9-118CE3A77D7C}';\r\n CLASS_ThreadAbortException: TGUID = '{EA1CF67D-7904-36A3-BD5B-DD028985861C}';\r\n CLASS_STAThreadAttribute: TGUID = '{50AAD4C2-61FA-3B1F-8157-5BA3B27AEE61}';\r\n CLASS_MTAThreadAttribute: TGUID = '{B406AC70-4D7E-3D24-B241-AEAEAC343BD9}';\r\n CLASS_ThreadInterruptedException: TGUID = '{27E986E1-BAEC-3D48-82E4-14169CA8CECF}';\r\n CLASS_RegisteredWaitHandle: TGUID = '{50F8AE2B-69F0-37EF-954B-D2618E3E8267}';\r\n CLASS_WaitCallback: TGUID = '{D8E04CC2-F4F5-367D-A23F-F71AFF4F14F3}';\r\n CLASS_WaitOrTimerCallback: TGUID = '{3C8C9F02-2C23-39FF-AC7B-CD0EE1D14A79}';\r\n CLASS_IOCompletionCallback: TGUID = '{8A937E3B-9C07-3D4D-B50A-4F4F3C85317C}';\r\n CLASS_ThreadPool: TGUID = '{F18C1BBB-EFA1-3789-8CDF-2D89E83834E5}';\r\n CLASS_ThreadStart: TGUID = '{E7AC1E4D-35DB-3432-A032-E94C012B2D39}';\r\n CLASS_ThreadStateException: TGUID = '{3E5509F0-1FB9-304D-8174-75D6C9AFE5DA}';\r\n CLASS_ThreadStaticAttribute: TGUID = '{FFC9F9AE-E87A-3252-8E25-B22423A40065}';\r\n CLASS_Timeout: TGUID = '{5A49B766-B474-3501-901E-5BDAC8B48A3D}';\r\n CLASS_TimerCallback: TGUID = '{DDF7BA7F-4B7C-378D-A153-6285B84C6593}';\r\n CLASS_Timer: TGUID = '{490CA7A8-D03F-3459-8208-D428EA010DA0}';\r\n CLASS_ArrayList: TGUID = '{6896B49D-7AFB-34DC-934E-5ADD38EEEE39}';\r\n CLASS_BitArray: TGUID = '{5D2FB755-C658-3F51-86F2-881F4A1A2A55}';\r\n CLASS_CaseInsensitiveComparer: TGUID = '{35E946E4-7CDA-3824-8B24-D799A96309AD}';\r\n CLASS_CaseInsensitiveHashCodeProvider: TGUID = '{47D3C68D-7D85-3227-A9E7-88451D6BADFC}';\r\n CLASS_CollectionBase: TGUID = '{87259279-9F5D-3C0A-BB58-723A2A6E4DBA}';\r\n CLASS_Comparer: TGUID = '{8A63140F-7EB8-3F4E-BA59-19B8C747843F}';\r\n CLASS_DictionaryBase: TGUID = '{9840C5C3-21D3-3B8A-94C1-3FC542B0227E}';\r\n CLASS_Hashtable: TGUID = '{146855FA-309F-3D0E-BB3E-DF525F30A715}';\r\n CLASS_Queue: TGUID = '{7F976B72-4B71-3858-BEE8-8E3A3189A651}';\r\n CLASS_ReadOnlyCollectionBase: TGUID = '{B66406BD-746D-3D10-98A1-41D097CF42B7}';\r\n CLASS_SortedList: TGUID = '{026CC6D7-34B2-33D5-B551-CA31EB6CE345}';\r\n CLASS_Stack: TGUID = '{4599202D-460F-3FB7-8A1C-C2CC6ED6C7C8}';\r\n CLASS_ConditionalAttribute: TGUID = '{75B3810E-F2D5-36E2-8D27-514EBCAD4511}';\r\n CLASS_Debugger: TGUID = '{91F672A3-6B82-3E04-B2D7-BAC5D6676609}';\r\n CLASS_DebuggerStepThroughAttribute: TGUID = '{93F551D6-2F9E-301B-BE63-85AEF508CAE0}';\r\n CLASS_DebuggerHiddenAttribute: TGUID = '{41970D73-92F6-36D9-874D-3BD0762A0D6F}';\r\n CLASS_DebuggableAttribute: TGUID = '{DF1F67B4-74F7-30AF-922D-29F0B91ABC25}';\r\n CLASS_StackTrace: TGUID = '{405C2D81-315B-3CB0-8442-EF5A38D4C3B8}';\r\n CLASS_StackFrame: TGUID = '{14910622-09D4-3B4A-8C1E-9991DBDCC553}';\r\n CLASS_SymDocumentType: TGUID = '{40AE2088-CE00-33AD-9320-5D201CB46FC9}';\r\n CLASS_SymLanguageType: TGUID = '{5A18D43E-115B-3B8B-8245-9A06B204B717}';\r\n CLASS_SymLanguageVendor: TGUID = '{DFD888A7-A6B0-3B1B-985E-4CDAB0E4C17D}';\r\n CLASS_AmbiguousMatchException: TGUID = '{2846AE5E-A9FA-36CF-B2D1-6E95596DBDE7}';\r\n CLASS_ModuleResolveEventHandler: TGUID = '{AAAA10C6-9902-3DBB-B173-EBA1EBA2CD5E}';\r\n CLASS_Assembly: TGUID = '{28E89A9F-E67D-3028-AA1B-E5EBCDE6F3C8}';\r\n CLASS_AssemblyCultureAttribute: TGUID = '{4265AB21-A68F-38A9-98D8-5D62B8035EA0}';\r\n CLASS_AssemblyVersionAttribute: TGUID = '{2D0FA06F-88FD-3643-8DBC-1F428A2B1A3B}';\r\n CLASS_AssemblyKeyFileAttribute: TGUID = '{FF408450-1DB9-3203-84EC-B70A01F48A06}';\r\n CLASS_AssemblyKeyNameAttribute: TGUID = '{3DACE301-6C51-3BF7-B975-E4A05F00FD4D}';\r\n CLASS_AssemblyDelaySignAttribute: TGUID = '{4804184F-4741-396B-AF5B-71134937F21A}';\r\n CLASS_AssemblyAlgorithmIdAttribute: TGUID = '{0D052B0A-23D1-3BAC-85EE-4E764B814CEE}';\r\n CLASS_AssemblyFlagsAttribute: TGUID = '{4554ED74-4243-3E7C-9B33-E9A89379C4F1}';\r\n CLASS_AssemblyFileVersionAttribute: TGUID = '{14152CB5-DC51-3C42-8A43-09854DEA1B8F}';\r\n CLASS_AssemblyName: TGUID = '{F12FDE6A-9394-3C32-8E4D-F3D470947284}';\r\n CLASS_AssemblyNameProxy: TGUID = '{3F4A4283-6A08-3E90-A976-2C2D3BE4EB0B}';\r\n CLASS_AssemblyCopyrightAttribute: TGUID = '{8687959F-D86D-3217-8D58-BE9A0427BB84}';\r\n CLASS_AssemblyTrademarkAttribute: TGUID = '{E64C95DF-EADC-3D08-9C6F-80F29D92CB4E}';\r\n CLASS_AssemblyProductAttribute: TGUID = '{CFE2BCF1-683C-39B5-83CE-4B186A521513}';\r\n CLASS_AssemblyCompanyAttribute: TGUID = '{62342FB2-16BF-30A9-88AD-6BC781EEC94F}';\r\n CLASS_AssemblyDescriptionAttribute: TGUID = '{432E5E9F-03BA-37B2-8EDF-7FAC14B03B4F}';\r\n CLASS_AssemblyTitleAttribute: TGUID = '{51B4F67C-2FCB-391D-A381-D040100D6717}';\r\n CLASS_AssemblyConfigurationAttribute: TGUID = '{09DD9840-5E39-317A-AAB3-0A467998DE25}';\r\n CLASS_AssemblyDefaultAliasAttribute: TGUID = '{8BEB1256-5D9B-3262-BF85-BEB6287E4EEA}';\r\n CLASS_AssemblyInformationalVersionAttribute: TGUID = '{894593B9-99E5-3B61-A592-EE44B9396277}';\r\n CLASS_CustomAttributeFormatException: TGUID = '{D5CB383D-99F4-3C7E-A9C3-85B53661448F}';\r\n CLASS_MethodBase: TGUID = '{CA308C9F-3B97-3152-ACFA-8AB23C17DF73}';\r\n CLASS_ConstructorInfo: TGUID = '{0A541F87-EBD7-36A0-9A7D-9BBF86188766}';\r\n CLASS_DefaultMemberAttribute: TGUID = '{CF452B26-6040-3ACB-9C72-CE5BB86E5046}';\r\n CLASS_EventInfo: TGUID = '{15762CA5-BC5C-3B86-A450-ACF32FC98AA5}';\r\n CLASS_FieldInfo: TGUID = '{98BA57DC-4CF2-3ED1-B4A2-890C21BBBF4B}';\r\n CLASS_InvalidFilterCriteriaException: TGUID = '{7B938A6F-77BF-351C-A712-69483C91115D}';\r\n CLASS_ManifestResourceInfo: TGUID = '{F695C021-DCF5-397B-A300-EDAA51DA5A5B}';\r\n CLASS_MemberFilter: TGUID = '{F52FD74C-ADA6-38CC-AE0F-693AFB9B9A8F}';\r\n CLASS_MethodInfo: TGUID = '{0E22CC27-CA1E-3138-9640-BE831F721659}';\r\n CLASS_Missing: TGUID = '{D5FAAC26-DB25-34E7-ADBD-AD5ED51F9433}';\r\n CLASS_Module: TGUID = '{128191C5-B188-3054-81B7-E4F588EACF0E}';\r\n CLASS_ParameterInfo: TGUID = '{E5CE8078-0CA7-3578-80DB-F20FCA8786A6}';\r\n CLASS_Pointer: TGUID = '{0517463E-1139-3970-BFA9-DCC997B23E7C}';\r\n CLASS_PropertyInfo: TGUID = '{BFDF1F57-230D-394A-B773-D9EC58CBEF9A}';\r\n CLASS_ReflectionTypeLoadException: TGUID = '{843B19AD-A02B-3852-AC56-FDC798935630}';\r\n CLASS_StrongNameKeyPair: TGUID = '{D633F013-0563-312A-B9D6-D067A7D59231}';\r\n CLASS_TargetException: TGUID = '{0D23F8B4-F2A6-3EFF-9D37-BDF79AC6B440}';\r\n CLASS_TargetInvocationException: TGUID = '{03D016E3-CAE1-3068-880E-AF8D08D517F0}';\r\n CLASS_TargetParameterCountException: TGUID = '{DA317BE2-1A0D-37B3-83F2-A0F32787FC67}';\r\n CLASS_TypeDelegator: TGUID = '{19E2E2F7-B53C-366B-8840-ABA2F8CB98B5}';\r\n CLASS_TypeFilter: TGUID = '{37E24F25-5EF0-366F-9D0F-F7B9E3EDFFD9}';\r\n CLASS_UnmanagedMarshal: TGUID = '{E3C3A258-E508-3704-B9EB-264601956FE5}';\r\n CLASS_Formatter: TGUID = '{E6854C08-0666-3939-BDF1-E1555A2C49FA}';\r\n CLASS_FormatterConverter: TGUID = '{D23D2F41-1D69-3E03-A275-32AE381223AC}';\r\n CLASS_FormatterServices: TGUID = '{688C32EA-1E9C-3A4B-90E0-A4D2A1D73F3F}';\r\n CLASS_ObjectIDGenerator: TGUID = '{4F272C37-F0A8-350C-867B-2C03B2B16B80}';\r\n CLASS_ObjectManager: TGUID = '{C3A27C9A-5F79-3B7A-963D-39B1E5202B55}';\r\n CLASS_SerializationBinder: TGUID = '{25D97DB7-BDC3-3205-B86B-956B852ECE76}';\r\n CLASS_SerializationInfo: TGUID = '{D69398C1-7541-33E7-B544-A803F380FFB6}';\r\n CLASS_SerializationInfoEnumerator: TGUID = '{341BA870-B7FE-3CBC-9A72-B7894C6EC171}';\r\n CLASS_SerializationException: TGUID = '{57154C7C-EDB2-3BFD-A8BA-924C60913EBF}';\r\n CLASS_SurrogateSelector: TGUID = '{88C8A919-EB24-3CCA-84F7-2EA82BB3F3ED}';\r\n CLASS_Calendar: TGUID = '{8A93390F-4331-317F-B450-1E0E4914E335}';\r\n CLASS_CompareInfo: TGUID = '{6747FF61-F8DA-3689-BB01-47F2266AE261}';\r\n CLASS_CultureInfo: TGUID = '{348A8C6D-464A-3F21-856B-061370D54599}';\r\n CLASS_DateTimeFormatInfo: TGUID = '{70A738D1-1BC5-3175-BD42-603E2B82C08B}';\r\n CLASS_DaylightTime: TGUID = '{5050FE97-72A6-3BC6-92F2-9DD0413041E3}';\r\n CLASS_GregorianCalendar: TGUID = '{68F8AEA9-1968-35B9-8A0E-6FDC637A4F8E}';\r\n CLASS_HebrewCalendar: TGUID = '{2206D773-CA1C-3258-9456-CEB7706C3710}';\r\n CLASS_HijriCalendar: TGUID = '{EE832CE3-06CA-33EF-8F01-61C7C218BD7E}';\r\n CLASS_JapaneseCalendar: TGUID = '{374050DD-6190-3257-8812-8230BF095147}';\r\n CLASS_JulianCalendar: TGUID = '{5C3E6CE8-B218-3762-883C-91BC987CDC2D}';\r\n CLASS_KoreanCalendar: TGUID = '{1A06A4DC-E239-3717-89E1-D0683F3A5320}';\r\n CLASS_RegionInfo: TGUID = '{0C630393-7583-333C-AB5D-CB10B910F69B}';\r\n CLASS_SortKey: TGUID = '{F34B5293-82D0-32A5-9165-AE789FD3CF15}';\r\n CLASS_StringInfo: TGUID = '{31C967B5-2F8A-3957-9C6D-34A0731DB36C}';\r\n CLASS_TaiwanCalendar: TGUID = '{769B8B68-64F7-3B61-B744-160A9FCC3216}';\r\n CLASS_TextElementEnumerator: TGUID = '{4C96DA7C-8858-3C24-A973-CB50F2860A91}';\r\n CLASS_TextInfo: TGUID = '{BCA1528C-6369-37AD-8CC1-DB24A92CC6B1}';\r\n CLASS_ThaiBuddhistCalendar: TGUID = '{EC3DAC94-DF80-3017-B381-B13DCED6C4D8}';\r\n CLASS_NumberFormatInfo: TGUID = '{146A47AB-A2CF-3587-BB25-2B286D7566B4}';\r\n CLASS_Encoding: TGUID = '{EAECC459-5CE4-35A2-A085-5AFC0451C03A}';\r\n CLASS_System_Text_Decoder: TGUID = '{A924269D-5DF2-33AF-B72A-3250C4105EBE}';\r\n CLASS_System_Text_Encoder: TGUID = '{CC9D4538-57E8-3A82-886A-5FE65A127A5A}';\r\n CLASS_ASCIIEncoding: TGUID = '{9E28EF95-9C6F-3A00-B525-36A76178CC9C}';\r\n CLASS_UnicodeEncoding: TGUID = '{A0F5F5DC-337B-38D7-B1A3-FB1B95666BBF}';\r\n CLASS_UTF7Encoding: TGUID = '{3C9DCA8B-4410-3143-B801-559553EB6725}';\r\n CLASS_UTF8Encoding: TGUID = '{8C40D44A-4EDE-3760-9B61-50255056D3C7}';\r\n CLASS_MissingManifestResourceException: TGUID = '{726BBDF4-6C6D-30F4-B3A0-F14D6AEC08C7}';\r\n CLASS_NeutralResourcesLanguageAttribute: TGUID = '{87797538-6BAE-366A-A9BC-012C8F62EA44}';\r\n CLASS_ResourceManager: TGUID = '{9AFB3B93-E6DA-35D6-B9FE-44815E2BFD45}';\r\n CLASS_ResourceReader: TGUID = '{DD78B5ED-AA52-3B2B-A1B4-6CE3CE3155EA}';\r\n CLASS_ResourceSet: TGUID = '{A907F7CD-8C99-31EA-AC00-80FA4D94780A}';\r\n CLASS_ResourceWriter: TGUID = '{9187A0D6-508C-36CC-A79F-F90B89A0E154}';\r\n CLASS_SatelliteContractVersionAttribute: TGUID = '{F4AE34F8-6CE4-32DC-96BA-9C7A0A9C6D06}';\r\n CLASS_Registry: TGUID = '{9B4EF4FA-742E-3878-953A-474999711087}';\r\n CLASS_RegistryKey: TGUID = '{2C8FA9BD-CBE4-3223-B592-41B5A22FB820}';\r\n CLASS_X509Certificate: TGUID = '{4C69C54F-9824-38CC-8387-A22DC67E0BAB}';\r\n CLASS_AsymmetricAlgorithm: TGUID = '{4B135D8E-7B1B-3EA8-8D06-10E34F157E9D}';\r\n CLASS_AsymmetricKeyExchangeDeformatter: TGUID = '{0202CE16-1F18-3BFB-807D-760B157AB260}';\r\n CLASS_AsymmetricKeyExchangeFormatter: TGUID = '{CE38DC2D-EB2D-3B6A-AFAC-8537BD0B9BF7}';\r\n CLASS_AsymmetricSignatureDeformatter: TGUID = '{BEE4E9FD-DE7A-3512-93D8-0C5E006B167A}';\r\n CLASS_AsymmetricSignatureFormatter: TGUID = '{5B475A84-5310-3C64-B625-E2BF00476F53}';\r\n CLASS_ToBase64Transform: TGUID = '{5F3A0F8D-5EF9-3AD5-94E0-53AFF8BCE960}';\r\n CLASS_FromBase64Transform: TGUID = '{C1ABB475-F198-39D5-BF8D-330BC7189661}';\r\n CLASS_KeySizes: TGUID = '{D7A12132-100F-37AE-A277-268A2656E476}';\r\n CLASS_CryptographicException: TGUID = '{7F8C7DC5-D8B4-3758-981F-02AF6B42461A}';\r\n CLASS_CryptographicUnexpectedOperationException: TGUID = '{C41FA05C-8A7A-3157-8166-4104BB4925BA}';\r\n CLASS_CryptoAPITransform: TGUID = '{AE746923-16BB-3D31-9D08-CE50EF6F7B1A}';\r\n CLASS_CspParameters: TGUID = '{AF60343F-6C7B-3761-839F-0C44E3CA06DA}';\r\n CLASS_CryptoConfig: TGUID = '{9EA60ECA-3DCD-340F-8E95-67845D185999}';\r\n CLASS_Stream: TGUID = '{E331083B-C22D-3046-8EC7-D222D6BE031F}';\r\n CLASS_CryptoStream: TGUID = '{B5C4E3CA-476A-3961-BCA5-A6C0AD73E7B1}';\r\n CLASS_SymmetricAlgorithm: TGUID = '{5B67EA6B-D85D-3F48-86D2-8581DB230C43}';\r\n CLASS_DES: TGUID = '{F30D404C-A350-36FA-A6FC-054C3F583420}';\r\n CLASS_DESCryptoServiceProvider: TGUID = '{B6EB52D5-BB1C-3380-8BCA-345FF43F4B04}';\r\n CLASS_DeriveBytes: TGUID = '{7D62DB2D-86E3-3ADE-90C4-215950643D10}';\r\n CLASS_DSA: TGUID = '{C13E7301-9B3F-3530-B60A-7F141D6DDE83}';\r\n CLASS_DSACryptoServiceProvider: TGUID = '{673DFE75-9F93-304F-ABA8-D2A86BA87D7C}';\r\n CLASS_DSASignatureDeformatter: TGUID = '{1F17C39C-99D5-37E0-8E98-8F27044BD50A}';\r\n CLASS_DSASignatureFormatter: TGUID = '{8F6D198C-E66F-3A87-AA3F-F885DD09EA13}';\r\n CLASS_HashAlgorithm: TGUID = '{68549FC3-F82C-3387-8578-E5FB09833740}';\r\n CLASS_KeyedHashAlgorithm: TGUID = '{BF1B2D6A-E41E-3645-8257-A08D7483BD41}';\r\n CLASS_HMACSHA1: TGUID = '{00B01B2E-B1FE-33A6-AD40-57DE8358DC7D}';\r\n CLASS_MACTripleDES: TGUID = '{39B68485-6773-3C46-82E9-56D8F0B4570C}';\r\n CLASS_MD5: TGUID = '{668515A6-213D-377A-8FE4-5A1E59A10AC9}';\r\n CLASS_MD5CryptoServiceProvider: TGUID = '{D2548BF2-801A-36AF-8800-1F11FBF54361}';\r\n CLASS_MaskGenerationMethod: TGUID = '{BE1E426E-676B-3524-9CED-21E306E9B827}';\r\n CLASS_PasswordDeriveBytes: TGUID = '{EED31DD9-AA11-3993-80E0-0088C1F5FEBA}';\r\n CLASS_PKCS1MaskGenerationMethod: TGUID = '{7AE844F0-ECA8-3F15-AE27-AFA21A2AA6F8}';\r\n CLASS_RC2: TGUID = '{1C6DC255-62D6-3366-BB25-01C509085473}';\r\n CLASS_RC2CryptoServiceProvider: TGUID = '{62E92675-CB77-3FC9-8597-1A81A5F18013}';\r\n CLASS_RandomNumberGenerator: TGUID = '{3E04DC56-84CE-3893-8BEF-6C9B95F9CCF4}';\r\n CLASS_RNGCryptoServiceProvider: TGUID = '{40031115-09D2-3851-A13F-56930BE48038}';\r\n CLASS_RSA: TGUID = '{3E39CA4F-CD6F-3CFE-8659-7FDC8D1C9F0B}';\r\n CLASS_RSACryptoServiceProvider: TGUID = '{D9035152-6B1F-33E3-86F4-411CD21CDE0E}';\r\n CLASS_RSAOAEPKeyExchangeDeformatter: TGUID = '{4D187AC2-D815-3B7E-BCEA-8E0BBC702F7C}';\r\n CLASS_RSAOAEPKeyExchangeFormatter: TGUID = '{A0E2E749-63CE-3651-8F4F-F5F996344C32}';\r\n CLASS_RSAPKCS1KeyExchangeDeformatter: TGUID = '{EE96F4E1-377E-315C-AEF5-874DC8C7A2AA}';\r\n CLASS_RSAPKCS1KeyExchangeFormatter: TGUID = '{92755472-2059-3F96-8938-8AC767B5187B}';\r\n CLASS_RSAPKCS1SignatureDeformatter: TGUID = '{6F674828-9081-3B45-BC39-791BD84CCF8F}';\r\n CLASS_RSAPKCS1SignatureFormatter: TGUID = '{7BC115CD-1EE2-3068-894D-E3D3F7632F40}';\r\n CLASS_Rijndael: TGUID = '{48CBEB8F-DB77-3103-899C-CD24A832B5CC}';\r\n CLASS_RijndaelManaged: TGUID = '{1F9F18A3-EFC0-3913-84A5-90678A4A9A80}';\r\n CLASS_SHA1: TGUID = '{EB52B161-AFB3-3DEA-BFAF-C183AEB57E56}';\r\n CLASS_SHA1CryptoServiceProvider: TGUID = '{FC13A7D5-E2B3-37BA-B807-7FA6238284D5}';\r\n CLASS_SHA1Managed: TGUID = '{FDF9C30D-CCAB-3E2D-B584-9E24CE8038E3}';\r\n CLASS_SHA256: TGUID = '{E29B25FC-9402-3A80-AAA5-EB07D9EF5488}';\r\n CLASS_SHA256Managed: TGUID = '{44181B13-AE94-3CFB-81D1-37DB59145030}';\r\n CLASS_SHA384: TGUID = '{0C00C2E9-7BBE-359E-8261-FD9B9C882A15}';\r\n CLASS_SHA384Managed: TGUID = '{7FD3958D-0A14-3001-8074-0D15EAD7F05C}';\r\n CLASS_SHA512: TGUID = '{8DE638D4-0575-3083-9CD7-41619EF9AC75}';\r\n CLASS_SHA512Managed: TGUID = '{A6673C32-3943-3BBB-B476-C09A0EC0BCD6}';\r\n CLASS_SignatureDescription: TGUID = '{3FA7A1C5-812C-3B56-B957-CB14AF670C09}';\r\n CLASS_TripleDES: TGUID = '{3D79AE1A-A949-3601-978F-02BEA1E70A98}';\r\n CLASS_TripleDESCryptoServiceProvider: TGUID = '{DAA132BF-1170-3D8B-A0EF-E2F55A68A91D}';\r\n CLASS_AllMembershipCondition: TGUID = '{06B81C12-A5DA-340D-AFF7-FA1453FBC29A}';\r\n CLASS_ApplicationDirectory: TGUID = '{720BF501-75AA-39F3-B6C2-EABE2F47CEE5}';\r\n CLASS_ApplicationDirectoryMembershipCondition: TGUID = '{3DDB2114-9285-30A6-906D-B117640CA927}';\r\n CLASS_CodeGroup: TGUID = '{05C4D71E-FB7D-30BE-B6B4-1DF8999CEEE1}';\r\n CLASS_Evidence: TGUID = '{62545937-20A9-3D0F-B04B-322E854EACB0}';\r\n CLASS_FileCodeGroup: TGUID = '{3F8D7E3A-24E7-3F7C-9DC5-4CA22EE7C782}';\r\n CLASS_FirstMatchCodeGroup: TGUID = '{28635CC7-4C39-3779-8C31-839101001F78}';\r\n CLASS_Hash: TGUID = '{260356E2-BAFA-3349-8BF7-86EEB460A2C7}';\r\n CLASS_HashMembershipCondition: TGUID = '{769EDEAD-E3B2-3C89-B9A6-948CD7288587}';\r\n CLASS_NetCodeGroup: TGUID = '{A601B6B7-422D-3B21-A61C-A77C5512F36A}';\r\n CLASS_PermissionRequestEvidence: TGUID = '{E1C3E338-B088-3C69-9989-A0E59E96FEA8}';\r\n CLASS_PolicyException: TGUID = '{89D26277-8408-3FC8-BD44-CF5F0E614C82}';\r\n CLASS_PolicyLevel: TGUID = '{64E304C1-D80D-3388-94EF-002F45D5AC05}';\r\n CLASS_PolicyStatement: TGUID = '{ABCC3DF5-7E59-3780-A3CC-4F412008A5EA}';\r\n CLASS_Publisher: TGUID = '{649546A7-965F-366F-A735-0FB522917B5A}';\r\n CLASS_PublisherMembershipCondition: TGUID = '{05BF00F9-44B8-39A7-AF36-7E11C9B502DD}';\r\n CLASS_Site: TGUID = '{0F71B36D-4006-35B5-9F42-4C468514AF70}';\r\n CLASS_SiteMembershipCondition: TGUID = '{7F5E4FD8-9575-3691-BF0C-2D30A21E4376}';\r\n CLASS_StrongName: TGUID = '{F1566AAF-63FE-3F4B-B121-DCD17999119B}';\r\n CLASS_StrongNameMembershipCondition: TGUID = '{7CFFAC1C-7370-30F9-AA72-E30FE39257D9}';\r\n CLASS_UnionCodeGroup: TGUID = '{F424D0BE-F3CB-3D09-9B18-C523A739EBFE}';\r\n CLASS_Url: TGUID = '{7A2AE0C8-EF79-334E-BACF-D7BA452CAF7C}';\r\n CLASS_UrlMembershipCondition: TGUID = '{93E33D56-812D-3112-BEEB-276A67D1172E}';\r\n CLASS_Zone: TGUID = '{6FCF98FF-B4D6-37A4-9DAB-4DE11A5FE5F2}';\r\n CLASS_ZoneMembershipCondition: TGUID = '{D72F9AEB-23F8-3B88-B6FD-8A143E3245A1}';\r\n CLASS_GenericIdentity: TGUID = '{4C534A8E-3C46-3745-BDAE-5119C40F98E7}';\r\n CLASS_GenericPrincipal: TGUID = '{2EACB710-FE48-3C13-8145-E810792C58A2}';\r\n CLASS_WindowsIdentity: TGUID = '{70C7CEC2-5BB2-3770-A26E-FC180C81F4FE}';\r\n CLASS_WindowsImpersonationContext: TGUID = '{FC1ABB5C-D107-3145-908A-3EA107D53748}';\r\n CLASS_WindowsPrincipal: TGUID = '{138887DB-C015-3254-B05A-D15616BF9AEE}';\r\n CLASS_DispIdAttribute: TGUID = '{B36860B2-BAC3-3C25-81EE-1F62CB91FC76}';\r\n CLASS_InterfaceTypeAttribute: TGUID = '{C8A36B3C-BC72-31E7-8BA2-EF949A54BD0C}';\r\n CLASS_ClassInterfaceAttribute: TGUID = '{5819DB84-163F-3FA2-853B-43A0269626B1}';\r\n CLASS_ComVisibleAttribute: TGUID = '{1F4BCC99-E9D8-3AAB-99AF-4D1EC26E3376}';\r\n CLASS_LCIDConversionAttribute: TGUID = '{F912451B-8766-32CD-917F-3B9FEE4421A8}';\r\n CLASS_ComRegisterFunctionAttribute: TGUID = '{630A3EF1-23C6-31FE-9D25-294E3B3E7486}';\r\n CLASS_ComUnregisterFunctionAttribute: TGUID = '{8F45C7FF-1E6E-34C1-A7CC-260985392A05}';\r\n CLASS_ProgIdAttribute: TGUID = '{47854AE8-F71C-3459-A943-1E91EDC951A7}';\r\n CLASS_ImportedFromTypeLibAttribute: TGUID = '{8AFEAA55-757F-3DDB-A750-B2CAA6A0B80B}';\r\n CLASS_IDispatchImplAttribute: TGUID = '{3AB97590-3A62-36FB-903F-BB70B015F156}';\r\n CLASS_ComSourceInterfacesAttribute: TGUID = '{AC0C43B1-6CA0-3E6C-B088-B11E96FA0CE3}';\r\n CLASS_ComConversionLossAttribute: TGUID = '{8A3FD229-B2A9-347F-93D2-87F3B7F92753}';\r\n CLASS_TypeLibTypeAttribute: TGUID = '{2F53C69E-F1F0-3E98-AD3B-EEAA89A88906}';\r\n CLASS_TypeLibFuncAttribute: TGUID = '{05074A9C-0B30-3A78-AAEF-99356E49DF45}';\r\n CLASS_TypeLibVarAttribute: TGUID = '{36BDD1DA-2B15-3428-B055-BDABF4667C3F}';\r\n CLASS_MarshalAsAttribute: TGUID = '{AAFFEF00-519D-3EE0-8763-D4B650611E0D}';\r\n CLASS_ComImportAttribute: TGUID = '{F1EBA909-6621-346D-9CE2-39F266C9D011}';\r\n CLASS_GuidAttribute: TGUID = '{FDE6D643-768A-3C91-A169-2C8FB7C1CD1F}';\r\n CLASS_PreserveSigAttribute: TGUID = '{204D5A28-46A0-3F04-BD7C-B5672631E57F}';\r\n CLASS_InAttribute: TGUID = '{96A058CD-FAF7-386C-85BF-E47F00C81795}';\r\n CLASS_OutAttribute: TGUID = '{FDB2DC94-B5A0-3702-AE84-BBFA752ACB36}';\r\n CLASS_OptionalAttribute: TGUID = '{B81CB5ED-E654-399F-9698-C83C50665786}';\r\n CLASS_DllImportAttribute: TGUID = '{3C52777E-F51C-300A-8122-479A19164325}';\r\n CLASS_StructLayoutAttribute: TGUID = '{A0FFF774-26BD-3DE7-95CE-DBCEA6088F96}';\r\n CLASS_FieldOffsetAttribute: TGUID = '{3BA14C59-4C61-3D7C-8161-9962D7A89292}';\r\n CLASS_ComAliasNameAttribute: TGUID = '{E1AA0B69-CA47-3749-AEB1-133DCE4C705F}';\r\n CLASS_AutomationProxyAttribute: TGUID = '{0E67C08B-D921-33D0-82FE-B6FD28BBAEFF}';\r\n CLASS_PrimaryInteropAssemblyAttribute: TGUID = '{6DD18F5D-7A5C-3868-B1C2-7E19DA873386}';\r\n CLASS_CoClassAttribute: TGUID = '{03E4C7F5-974C-3253-9BE0-41470697BBAD}';\r\n CLASS_ComEventInterfaceAttribute: TGUID = '{830AC1F5-98EE-39A3-9212-FA5626CA855A}';\r\n CLASS_TypeLibVersionAttribute: TGUID = '{5F8DC45F-A2D8-3E34-8C86-586ED6A74984}';\r\n CLASS_ComCompatibleVersionAttribute: TGUID = '{7F962EBF-2220-30F0-8B92-24A73B7CD268}';\r\n CLASS_BestFitMappingAttribute: TGUID = '{84FEE617-858B-364B-A662-8BF7ED5330CA}';\r\n CLASS_ExternalException: TGUID = '{AFC681CF-E82F-361A-8280-CF4E1F844C3E}';\r\n CLASS_COMException: TGUID = '{07F94112-A42E-328B-B508-702EF62BCC29}';\r\n CLASS_CurrencyWrapper: TGUID = '{D540A482-8FB8-3720-B52E-08C7A2C1B9DF}';\r\n CLASS_DispatchWrapper: TGUID = '{DA7109D3-BCD8-3D4C-B172-DFC2E585562A}';\r\n CLASS_ErrorWrapper: TGUID = '{D7900EBD-FF28-3AE6-B517-7E32714F578B}';\r\n CLASS_ExtensibleClassFactory: TGUID = '{58734403-8382-3110-B729-14C7855982F9}';\r\n CLASS_InvalidComObjectException: TGUID = '{A7248EC6-A8A5-3D07-890E-6107F8C247E5}';\r\n CLASS_InvalidOleVariantTypeException: TGUID = '{9A944885-EDAF-3A81-A2FF-6A9D5D1ABFC7}';\r\n CLASS_Marshal: TGUID = '{F6B3BABB-CE60-38B7-9822-6C65F003A73C}';\r\n CLASS_MarshalDirectiveException: TGUID = '{742AD1FB-B2F0-3681-B4AA-E736A3BCE4E1}';\r\n CLASS_ObjectCreationDelegate: TGUID = '{8A21DF64-F31A-306F-9DB8-0DFA164ED9EE}';\r\n CLASS_RuntimeEnvironment: TGUID = '{78D22140-40CF-303E-BE96-B3AC0407A34D}';\r\n CLASS_SafeArrayRankMismatchException: TGUID = '{4BE89AC3-603D-36B2-AB9B-9C38866F56D5}';\r\n CLASS_SafeArrayTypeMismatchException: TGUID = '{2D5EC63C-1B3E-3EE4-9052-EB0D0303549C}';\r\n CLASS_SEHException: TGUID = '{CA805B13-468C-3A22-BF9A-818E97EFA6B7}';\r\n CLASS_UnknownWrapper: TGUID = '{887D4D94-31D1-37F3-9938-643ED2A46155}';\r\n CLASS_BinaryReader: TGUID = '{2484AFDA-7B47-3CD7-97B5-951F5C6AB5B6}';\r\n CLASS_BinaryWriter: TGUID = '{D92CCD03-5C88-3339-8011-46E8B01A2BA8}';\r\n CLASS_BufferedStream: TGUID = '{1500ABC0-1DD4-37DD-985F-82430314C798}';\r\n CLASS_Directory: TGUID = '{0EBD869E-64BF-3682-80BB-690A70114BE0}';\r\n CLASS_FileSystemInfo: TGUID = '{1F0E8DB5-8F52-3360-8A47-9D3DC3A5ACAF}';\r\n CLASS_DirectoryInfo: TGUID = '{40A8B2FA-E055-3F59-8BA6-54C4E35649B5}';\r\n CLASS_IOException: TGUID = '{A164C0BF-67AE-3C7E-BC05-BFE24A8CDB62}';\r\n CLASS_DirectoryNotFoundException: TGUID = '{8833BC41-DC6B-34B9-A799-682D2554F02F}';\r\n CLASS_EndOfStreamException: TGUID = '{58D052BC-A3DF-3508-AC95-FF297BDC9F0C}';\r\n CLASS_File_: TGUID = '{2A96793E-4CF3-3976-A893-B66886D89A03}';\r\n CLASS_FileInfo: TGUID = '{D6DFFEAD-0B46-3DED-83DE-1943413B94D5}';\r\n CLASS_FileLoadException: TGUID = '{AF8C5F8A-9999-3E92-BB41-C5F4955174CD}';\r\n CLASS_FileNotFoundException: TGUID = '{48C6E96F-A2F3-33E7-BA7F-C8F74866760B}';\r\n CLASS_FileStream: TGUID = '{7F25E491-33BE-31E2-A334-CB506D4EE471}';\r\n CLASS_MemoryStream: TGUID = '{F5E692D9-8A87-349D-9657-F96E5799D2F4}';\r\n CLASS_Path: TGUID = '{B7AE0CAE-979E-3EBF-B33F-8F121DAFD78E}';\r\n CLASS_PathTooLongException: TGUID = '{C016A313-9606-36D3-A823-33EBF5006189}';\r\n CLASS_TextReader: TGUID = '{7457D481-248A-3C89-B7E0-FCEB8FD827E5}';\r\n CLASS_StreamReader: TGUID = '{405FB68B-360D-382C-8A64-1DA3C853D161}';\r\n CLASS_TextWriter: TGUID = '{08416C5B-A003-327C-9F0F-93942467E6E0}';\r\n CLASS_StreamWriter: TGUID = '{EF1AB726-0B87-3E09-AEF4-3A87C5DCDDA0}';\r\n CLASS_StringReader: TGUID = '{0247D5AF-D61D-341C-8615-0FF28865B7CB}';\r\n CLASS_StringWriter: TGUID = '{27F31D55-D6C6-3676-9D42-C40F3A918636}';\r\n CLASS_AccessedThroughPropertyAttribute: TGUID = '{5EFB687D-2B50-3216-BD74-52D06C8D3CD1}';\r\n CLASS_CallConvCdecl: TGUID = '{A3A1F076-1FA7-3A26-886D-8841CB45382F}';\r\n CLASS_CallConvStdcall: TGUID = '{BCB67D4D-2096-36BE-974C-A003FC95041B}';\r\n CLASS_CallConvThiscall: TGUID = '{46080CA7-7CB8-3A55-A72E-8E50ECA4D4FC}';\r\n CLASS_CallConvFastcall: TGUID = '{ED0BC45C-2438-31A9-BBB6-E2A3B5916419}';\r\n CLASS_RuntimeHelpers: TGUID = '{8D360300-B535-3B0F-8C16-BFE8BB46D369}';\r\n CLASS_CustomConstantAttribute: TGUID = '{6F7A3516-EFD9-31C3-BC9A-A89DF19F64E7}';\r\n CLASS_DateTimeConstantAttribute: TGUID = '{3178FD5D-2A5B-30B9-9C5C-7593802F9C1A}';\r\n CLASS_DiscardableAttribute: TGUID = '{837A6733-1675-3BC9-BBF8-13889F84DAF4}';\r\n CLASS_DecimalConstantAttribute: TGUID = '{AC8DE863-B115-3179-810F-162B43ABD2B5}';\r\n CLASS_CompilationRelaxationsAttribute: TGUID = '{76CEC05B-C55E-3ADF-92A2-0698F1CF2017}';\r\n CLASS_CompilerGlobalScopeAttribute: TGUID = '{4B601364-A04B-38BC-BD38-A18E981324CF}';\r\n CLASS_IDispatchConstantAttribute: TGUID = '{E947A0B0-D47F-3AA3-9B77-4624E0F3ACA4}';\r\n CLASS_IndexerNameAttribute: TGUID = '{9599C078-DC94-3EA2-8761-408295BD1155}';\r\n CLASS_IsVolatile: TGUID = '{86527C04-536A-33C6-8C84-3D5A5B458DB3}';\r\n CLASS_IUnknownConstantAttribute: TGUID = '{590E4A07-DAFC-3BE7-A178-DA349BBA980B}';\r\n CLASS_MethodImplAttribute: TGUID = '{48D0CFE7-3128-3D2C-A5B5-8C7B82B4AB4F}';\r\n CLASS_RequiredAttributeAttribute: TGUID = '{D49C12A2-C401-3894-8005-716C2F692D38}';\r\n CLASS_PermissionSet: TGUID = '{AFAFD122-DAC4-3FF9-9646-DC032A4A8806}';\r\n CLASS_NamedPermissionSet: TGUID = '{C23E56CE-0A9A-3733-8189-46B43C9E4FB3}';\r\n CLASS_SecurityElement: TGUID = '{B9033CD1-C905-3059-9D29-562ECB13B0B3}';\r\n CLASS_XmlSyntaxException: TGUID = '{E38DA416-8050-3786-8201-46F187C15213}';\r\n CLASS_CodeAccessPermission: TGUID = '{AF6550FA-7C4B-3477-86DD-235F8286EAAC}';\r\n CLASS_EnvironmentPermission: TGUID = '{801F6E40-B384-3D27-B75F-DE2DF38F1192}';\r\n CLASS_FileDialogPermission: TGUID = '{9E1239B4-493A-3D2D-8F91-6636EC9ECA21}';\r\n CLASS_FileIOPermission: TGUID = '{DC50CD5A-0CAD-3B47-BF0D-79E85F3C2FC7}';\r\n CLASS_IsolatedStoragePermission: TGUID = '{F458ABF2-2B5E-3158-B0E4-228E8CDCF759}';\r\n CLASS_IsolatedStorageFilePermission: TGUID = '{AE588447-D98E-3E39-96F7-073433DB8D35}';\r\n CLASS_SecurityAttribute: TGUID = '{47DCD758-DF63-3226-A3A9-B0B88872A311}';\r\n CLASS_CodeAccessSecurityAttribute: TGUID = '{21858390-FE95-33A9-A103-F322C64D85AE}';\r\n CLASS_EnvironmentPermissionAttribute: TGUID = '{6161DF0C-CD78-33E1-B3E1-978B27025E40}';\r\n CLASS_FileDialogPermissionAttribute: TGUID = '{A141F926-E6B5-3903-8EFA-1014D4970F1C}';\r\n CLASS_FileIOPermissionAttribute: TGUID = '{DE440C06-7EC3-3E59-83C8-3829090198F7}';\r\n CLASS_PrincipalPermissionAttribute: TGUID = '{6D0AE73B-ED58-32E2-973C-765897783971}';\r\n CLASS_ReflectionPermissionAttribute: TGUID = '{64578750-937F-3B27-B631-C57E0BFFF97F}';\r\n CLASS_RegistryPermissionAttribute: TGUID = '{F69CF20D-F85B-3436-9E0E-DD3CB3E8B2CD}';\r\n CLASS_SecurityPermissionAttribute: TGUID = '{5E77314C-043D-3D8C-9C9D-D18F09FB3500}';\r\n CLASS_UIPermissionAttribute: TGUID = '{5F4ED054-C453-3D2B-A0FE-64E89871D364}';\r\n CLASS_ZoneIdentityPermissionAttribute: TGUID = '{C386115F-2B99-356B-B4A1-2CF57CE52988}';\r\n CLASS_StrongNameIdentityPermissionAttribute: TGUID = '{EF2C9DE4-BCDA-3322-AE75-16CC3EC2665C}';\r\n CLASS_SiteIdentityPermissionAttribute: TGUID = '{23F73179-6349-3183-A55C-BCFB1A2446E8}';\r\n CLASS_UrlIdentityPermissionAttribute: TGUID = '{6852BE7D-8C00-3F66-BEE3-463F74838491}';\r\n CLASS_PublisherIdentityPermissionAttribute: TGUID = '{2335C1DA-CD60-3208-AB5E-447F16A087E5}';\r\n CLASS_IsolatedStoragePermissionAttribute: TGUID = '{A56859A3-98ED-39A9-BD33-5807F0D6291F}';\r\n CLASS_IsolatedStorageFilePermissionAttribute: TGUID = '{F6610DF3-8D62-38BD-BF6B-2A4BA839EB3B}';\r\n CLASS_PermissionSetAttribute: TGUID = '{24151BA6-6D79-3EC4-8C77-014FFBE735AE}';\r\n CLASS_PublisherIdentityPermission: TGUID = '{73CF786B-CD2C-37E4-9835-824E4A019F11}';\r\n CLASS_ReflectionPermission: TGUID = '{E71CDC85-7FE7-3F51-BCDB-02459770DB87}';\r\n CLASS_RegistryPermission: TGUID = '{B35E31F2-9E50-3D43-8EAF-EC111F6B3295}';\r\n CLASS_PrincipalPermission: TGUID = '{67100ADE-60CF-33F1-8D95-F6FE1174458A}';\r\n CLASS_SecurityPermission: TGUID = '{D5F5125A-3D46-3C57-8393-0E4EE9D8016B}';\r\n CLASS_SiteIdentityPermission: TGUID = '{3BCFC458-07DC-3BA7-8404-97EB76641080}';\r\n CLASS_StrongNameIdentityPermission: TGUID = '{2B00B9EC-B4F4-3243-90AB-532E64FEE941}';\r\n CLASS_StrongNamePublicKeyBlob: TGUID = '{A463394F-7BA6-3721-8AD8-842748612B4C}';\r\n CLASS_UIPermission: TGUID = '{05B46A2D-7C6B-3EFF-A09A-1490A36811C2}';\r\n CLASS_UrlIdentityPermission: TGUID = '{AB7D1AB9-D192-3A95-B34C-A3996837C6A7}';\r\n CLASS_ZoneIdentityPermission: TGUID = '{CAEB199E-CEB9-388A-B240-E29C9F55199B}';\r\n CLASS_SuppressUnmanagedCodeSecurityAttribute: TGUID = '{7AE01D6C-BEE7-38F6-9A86-329D8A917803}';\r\n CLASS_UnverifiableCodeAttribute: TGUID = '{7E3393AB-2AB2-320B-8F6F-EAB6F5CF2CAF}';\r\n CLASS_AllowPartiallyTrustedCallersAttribute: TGUID = '{5610F042-FF1D-36D0-996C-68F7A207D1F0}';\r\n CLASS_SecurityException: TGUID = '{EEF05C76-5C98-3685-A69C-6E1A26A7F846}';\r\n CLASS_SecurityManager: TGUID = '{DF4E1BB0-8CDC-3C4B-A1C9-FEE64BBEF8C5}';\r\n CLASS_VerificationException: TGUID = '{EBAA029C-01C0-32B6-AAE6-FE21ADFC3E5D}';\r\n CLASS_ContextAttribute: TGUID = '{1764148E-73C1-320A-83FC-337DE81A68B4}';\r\n CLASS_AsyncResult: TGUID = '{614E973A-B737-38F5-9DDF-5825AC923135}';\r\n CLASS_CallContext: TGUID = '{9D0DF3B9-107C-3392-88C8-FE629CA21DAB}';\r\n CLASS_LogicalCallContext: TGUID = '{5DB435A0-0DB3-3F4A-BF49-191A69D451BB}';\r\n CLASS_ChannelServices: TGUID = '{D625BA4C-7C4C-3B86-99EA-780204EDE5CD}';\r\n CLASS_ClientChannelSinkStack: TGUID = '{DD5856E5-8151-3334-B8E9-07CB152B20A4}';\r\n CLASS_ServerChannelSinkStack: TGUID = '{5C35F099-165E-3225-A3A5-564150EA17F5}';\r\n CLASS_InternalMessageWrapper: TGUID = '{30C4CD02-66A2-3ABE-BC6C-638E6730E534}';\r\n CLASS_MethodCallMessageWrapper: TGUID = '{40133645-FFAF-3A9C-B408-997E049D5C11}';\r\n CLASS_ClientSponsor: TGUID = '{FD8C8FCE-4F85-36B2-B8E8-F5A183654539}';\r\n CLASS_CrossContextDelegate: TGUID = '{8DE7F105-07F6-31A8-8469-BAFCDC5024B8}';\r\n CLASS_Context: TGUID = '{A36E4EAF-EA3F-30A6-906D-374BBF7903B1}';\r\n CLASS_ContextProperty: TGUID = '{6134805F-E8FF-3FD8-931E-4D847BCA7551}';\r\n CLASS_EnterpriseServicesHelper: TGUID = '{BC5062B6-79E8-3F19-A87E-F9DAF826960C}';\r\n CLASS_Header: TGUID = '{14309FAB-EACD-3C64-877E-07EB01B89C91}';\r\n CLASS_HeaderHandler: TGUID = '{CC4C81B2-365E-3BA5-B374-A949B727E929}';\r\n CLASS_ChannelDataStore: TGUID = '{F3E38CEA-40E4-33C1-9DF7-BD103BE2D68B}';\r\n CLASS_TransportHeaders: TGUID = '{48728B3F-F7D9-36C1-B3E7-8BF2E63CE1B3}';\r\n CLASS_SinkProviderData: TGUID = '{B8BE8D68-5FE6-38C5-838E-67CE2FCA9D70}';\r\n CLASS_BaseChannelObjectWithProperties: TGUID = '{F369A73E-78D8-3BCC-AE36-522D116E19F9}';\r\n CLASS_BaseChannelSinkWithProperties: TGUID = '{0E9EB6E5-D899-3132-90C5-7376970C4FB5}';\r\n CLASS_BaseChannelWithProperties: TGUID = '{22282340-9E30-3591-BD1E-6571930E8582}';\r\n CLASS_LifetimeServices: TGUID = '{8FD730C1-DD1B-3694-84A1-8CE7159E266B}';\r\n CLASS_ReturnMessage: TGUID = '{7B3BBD13-C870-3105-B123-FFCA166CDC04}';\r\n CLASS_MethodCall: TGUID = '{4F592B1F-4A0C-3FC0-9914-3677F64FC5A8}';\r\n CLASS_ConstructionCall: TGUID = '{54DAC96D-ECAF-38DB-A27B-3DDB102130C4}';\r\n CLASS_MethodResponse: TGUID = '{7E7BF3C0-B07B-3209-A424-7BC35D76EA7D}';\r\n CLASS_ConstructionResponse: TGUID = '{25E8547A-6B49-3F00-B963-D45FDCEF4F11}';\r\n CLASS_MethodReturnMessageWrapper: TGUID = '{2EC528FB-B987-3B3B-A444-9F94C3A257C1}';\r\n CLASS_ObjectHandle: TGUID = '{ABEB0459-03B9-35AF-96E1-66BB7BC923F7}';\r\n CLASS_ObjRef: TGUID = '{21F5A790-53EA-3D73-86C3-A5BA6CF65FE9}';\r\n CLASS_OneWayAttribute: TGUID = '{C30ABD41-7B5A-3D10-A6EF-56862E2979B6}';\r\n CLASS_ProxyAttribute: TGUID = '{1163D0CA-2A02-37C1-BF3F-A9B9E9D49245}';\r\n CLASS_RealProxy: TGUID = '{531D00A5-2CFF-30D7-8245-97E18CD4D037}';\r\n CLASS_SoapAttribute: TGUID = '{9B924EC5-BF13-3A98-8AC0-80877995D403}';\r\n CLASS_SoapTypeAttribute: TGUID = '{9C67F424-22DC-3D05-AB36-17EAF95881F2}';\r\n CLASS_SoapMethodAttribute: TGUID = '{01FF4E4B-8AD0-3171-8C82-5C2F48B87E3D}';\r\n CLASS_SoapFieldAttribute: TGUID = '{5B76534C-3ACC-3D52-AA61-D788B134ABE2}';\r\n CLASS_SoapParameterAttribute: TGUID = '{C76B435D-86C2-30FD-9329-E2603246095C}';\r\n CLASS_RemotingConfiguration: TGUID = '{3DB6F309-9DAB-36EC-8036-D901172C994C}';\r\n CLASS_System_Runtime_Remoting_TypeEntry: TGUID = '{4E52D7D6-9FDF-3B59-B318-778E0F40F37C}';\r\n CLASS_ActivatedClientTypeEntry: TGUID = '{3ED0F148-E447-3EFE-8488-3C834082CC96}';\r\n CLASS_ActivatedServiceTypeEntry: TGUID = '{6CD360CD-D53D-3775-87EF-00D72E6645F5}';\r\n CLASS_WellKnownClientTypeEntry: TGUID = '{6B3B6647-B39D-3ED4-992F-DF6C49ACE82E}';\r\n CLASS_WellKnownServiceTypeEntry: TGUID = '{2CE0DA26-18EF-3CF4-ABAC-BE90965F5F90}';\r\n CLASS_RemotingException: TGUID = '{24540EBC-316E-35D2-80DB-8A535CAF6A35}';\r\n CLASS_ServerException: TGUID = '{DB13821E-9835-3958-8539-1E021399AB6C}';\r\n CLASS_RemotingTimeoutException: TGUID = '{3CDED51A-86B4-39F0-A12A-5D1FDCED6546}';\r\n CLASS_RemotingServices: TGUID = '{8DF4C38A-8492-3C47-8332-D9D04FAF3C59}';\r\n CLASS_InternalRemotingServices: TGUID = '{53A3C917-BB24-3908-B58B-09ECDA99265F}';\r\n CLASS_MessageSurrogateFilter: TGUID = '{C48CA9BC-BBDB-3059-AEC8-763CF7E9A88C}';\r\n CLASS_RemotingSurrogateSelector: TGUID = '{24EEC005-3938-3C71-821D-7F68FD850B2D}';\r\n CLASS_SoapServices: TGUID = '{DA5681DA-7C21-3A2D-AFAC-69E3A4D11F4D}';\r\n CLASS_SoapDateTime: TGUID = '{48AD62E8-BD40-37F4-8FD7-F7A17478A8E6}';\r\n CLASS_SoapDuration: TGUID = '{DE47D9CF-0107-3D66-93E9-A8ACB06B4583}';\r\n CLASS_SoapTime: TGUID = '{D049DC2B-82C3-3350-A1CC-BF69FEE3825E}';\r\n CLASS_SoapDate: TGUID = '{2DECBCB7-BAC0-316D-9131-43035C5CB480}';\r\n CLASS_SoapYearMonth: TGUID = '{A7136BDF-B141-3913-9D1C-9BC5AFF21470}';\r\n CLASS_SoapYear: TGUID = '{75999EBA-0679-3D43-BDC4-02E4D637F1B1}';\r\n CLASS_SoapMonthDay: TGUID = '{463AE13F-C7E5-357E-A41C-DF8762FFF85C}';\r\n CLASS_SoapDay: TGUID = '{C9F0A842-3CE1-338F-A1D4-6D7BB397BDAA}';\r\n CLASS_SoapMonth: TGUID = '{CAEC7D4F-0B02-3579-943F-821738EE78CC}';\r\n CLASS_SoapHexBinary: TGUID = '{8C1425C9-A7D3-35CD-8248-928CA52AD49B}';\r\n CLASS_SoapBase64Binary: TGUID = '{F59D514C-F200-319F-BF3F-9E4E23B2848C}';\r\n CLASS_SoapInteger: TGUID = '{09A60795-31C0-3A79-9250-8D93C74FE540}';\r\n CLASS_SoapPositiveInteger: TGUID = '{7B769B29-35F0-3BDC-AAE9-E99937F6CDEC}';\r\n CLASS_SoapNonPositiveInteger: TGUID = '{2BB6C5E0-C2B9-3608-8868-21CFD6DDB91E}';\r\n CLASS_SoapNonNegativeInteger: TGUID = '{6850404F-D7FB-32BD-8328-C94F66E8C1C7}';\r\n CLASS_SoapNegativeInteger: TGUID = '{C41D0B30-A518-3093-A18F-364AF9E71EB7}';\r\n CLASS_SoapAnyUri: TGUID = '{CDFA7117-B2A4-3A3F-B393-BC19D44F9749}';\r\n CLASS_SoapQName: TGUID = '{D8A4F3EB-E7EC-3620-831A-B052A67C9944}';\r\n CLASS_SoapNotation: TGUID = '{B54E38F8-17FF-3D0A-9FF3-5E662DE2055F}';\r\n CLASS_SoapNormalizedString: TGUID = '{0E71F9BD-C109-3352-BD60-14F96D56B6F3}';\r\n CLASS_SoapToken: TGUID = '{777F668E-3272-39CD-A8B5-860935A35181}';\r\n CLASS_SoapLanguage: TGUID = '{84F70B6C-D59E-394A-B879-FFCC30DDCAA2}';\r\n CLASS_SoapName: TGUID = '{4E515531-7A71-3CDD-8078-0A01C85C8F9D}';\r\n CLASS_SoapIdrefs: TGUID = '{2763BE6B-F8CF-39D9-A2E8-9E9815C0815E}';\r\n CLASS_SoapEntities: TGUID = '{9A3A64F4-8BA5-3DCF-880C-8D3EE06C5538}';\r\n CLASS_SoapNmtoken: TGUID = '{C498F2D9-A77C-3D4B-A1A5-12CC7B99115D}';\r\n CLASS_SoapNmtokens: TGUID = '{14BE6B21-C682-3A3A-8B24-FEE75B4FF8C5}';\r\n CLASS_SoapNcName: TGUID = '{D13B741D-051F-322F-93AA-1367A3C8AAFB}';\r\n CLASS_SoapId: TGUID = '{FA0B54D5-F221-3648-A20C-F67A96F4A207}';\r\n CLASS_SoapIdref: TGUID = '{433CA926-9887-3541-89CC-5D74D0259144}';\r\n CLASS_SoapEntity: TGUID = '{F00CA7A7-4B8D-3F2F-A5F2-CE4A4478B39C}';\r\n CLASS_SynchronizationAttribute: TGUID = '{5520B6D3-6EC6-3CE7-958B-E69FAF6EFF99}';\r\n CLASS_TrackingServices: TGUID = '{E822F35C-DDC2-3FB2-9768-A2AEBCED7C40}';\r\n CLASS_UrlAttribute: TGUID = '{79C14066-E37E-3643-A449-D166FA0E8EC2}';\r\n CLASS_IsolatedStorage: TGUID = '{70541B17-BF7E-399B-8D33-2AFA4F5AF395}';\r\n CLASS_IsolatedStorageFile: TGUID = '{5E45C68A-E894-3B38-AEEE-634540BD0D57}';\r\n CLASS_IsolatedStorageFileStream: TGUID = '{E5CFDFFC-AEB5-3489-B12C-640F7B031B57}';\r\n CLASS_IsolatedStorageException: TGUID = '{4479C009-4CC3-39A2-8F92-DFCDF034F748}';\r\n CLASS_InternalRM: TGUID = '{CF8F7FCF-94FE-3516-90E9-C103156DD2D5}';\r\n CLASS_InternalST: TGUID = '{CBBAF6EC-251A-3480-8A3D-4D56BC7320D0}';\r\n CLASS_SoapMessage: TGUID = '{E772BBE6-CB52-3C19-876A-D1BFA2305F4E}';\r\n CLASS_SoapFault: TGUID = '{A8D058C4-D923-3859-9490-D3888FC90439}';\r\n CLASS_ServerFault: TGUID = '{817ACCB7-35D8-3C18-BAF2-0A5CE2157B74}';\r\n CLASS_BinaryFormatter: TGUID = '{50369004-DB9A-3A75-BE7A-1D0EF017B9D3}';\r\n CLASS_AssemblyBuilder: TGUID = '{0814BE2A-48E5-3D61-90F3-EF3D05DF9D5E}';\r\n CLASS_ConstructorBuilder: TGUID = '{93C24CDB-4014-3EFD-B564-E836BA48C765}';\r\n CLASS_EventBuilder: TGUID = '{DC18B7EC-91E4-3999-910A-188D7AFA0A68}';\r\n CLASS_FieldBuilder: TGUID = '{36D63E48-1646-345F-A3D4-B34E4C42C3C5}';\r\n CLASS_ILGenerator: TGUID = '{5A3DCD44-5855-3D89-A0EC-CE50A3B144A9}';\r\n CLASS_LocalBuilder: TGUID = '{A6BCAA25-D357-3F79-A716-AD1434E4D832}';\r\n CLASS_MethodBuilder: TGUID = '{53DF4FB3-A164-37D3-8310-F0D15730AB32}';\r\n CLASS_CustomAttributeBuilder: TGUID = '{71BC3E08-0082-320A-8BA5-EFA8D2B9798A}';\r\n CLASS_MethodRental: TGUID = '{726D83B0-9A52-36B0-919C-60E625F03211}';\r\n CLASS_ModuleBuilder: TGUID = '{FB2ED445-2862-3A63-9F5A-BBF6C2195DCE}';\r\n CLASS_OpCodes: TGUID = '{2A59A0E6-11B2-3025-92DE-E036A6DDBC00}';\r\n CLASS_ParameterBuilder: TGUID = '{027AD5C3-D619-3506-B8E6-CA67A33B9C8F}';\r\n CLASS_PropertyBuilder: TGUID = '{22D4C021-1B3C-3EE3-93B6-4C9D810CE077}';\r\n CLASS_SignatureHelper: TGUID = '{798B57A2-064A-3098-9A80-E12DA70E0085}';\r\n CLASS_TypeBuilder: TGUID = '{0F445332-E34C-3F8C-90ED-AB7F0724ADAB}';\r\n CLASS_EnumBuilder: TGUID = '{70F855DA-4948-38AB-A727-431C386AB9F5}';\r\n\r\n// *********************************************************************//\r\n// Declaration of Enumerations defined in Type Library \r\n// *********************************************************************//\r\n// Constants for enum LoaderOptimization\r\ntype\r\n LoaderOptimization = TOleEnum;\r\nconst\r\n LoaderOptimization_NotSpecified = $00000000;\r\n LoaderOptimization_SingleDomain = $00000001;\r\n LoaderOptimization_MultiDomain = $00000002;\r\n LoaderOptimization_MultiDomainHost = $00000003;\r\n LoaderOptimization_DomainMask = $00000003;\r\n LoaderOptimization_DisallowBindings = $00000004;\r\n\r\n// Constants for enum AttributeTargets\r\ntype\r\n AttributeTargets = TOleEnum;\r\nconst\r\n AttributeTargets_Assembly = $00000001;\r\n AttributeTargets_Module = $00000002;\r\n AttributeTargets_Class = $00000004;\r\n AttributeTargets_Struct = $00000008;\r\n AttributeTargets_Enum = $00000010;\r\n AttributeTargets_Constructor = $00000020;\r\n AttributeTargets_Method = $00000040;\r\n AttributeTargets_Property = $00000080;\r\n AttributeTargets_Field = $00000100;\r\n AttributeTargets_Event = $00000200;\r\n AttributeTargets_Interface = $00000400;\r\n AttributeTargets_Parameter = $00000800;\r\n AttributeTargets_Delegate = $00001000;\r\n AttributeTargets_ReturnValue = $00002000;\r\n AttributeTargets_All = $00003FFF;\r\n\r\n// Constants for enum DayOfWeek\r\ntype\r\n DayOfWeek = TOleEnum;\r\nconst\r\n DayOfWeek_Sunday = $00000000;\r\n DayOfWeek_Monday = $00000001;\r\n DayOfWeek_Tuesday = $00000002;\r\n DayOfWeek_Wednesday = $00000003;\r\n DayOfWeek_Thursday = $00000004;\r\n DayOfWeek_Friday = $00000005;\r\n DayOfWeek_Saturday = $00000006;\r\n\r\n// Constants for enum SpecialFolder\r\ntype\r\n SpecialFolder = TOleEnum;\r\nconst\r\n SpecialFolder_ApplicationData = $0000001A;\r\n SpecialFolder_CommonApplicationData = $00000023;\r\n SpecialFolder_LocalApplicationData = $0000001C;\r\n SpecialFolder_Cookies = $00000021;\r\n SpecialFolder_Desktop = $00000000;\r\n SpecialFolder_Favorites = $00000006;\r\n SpecialFolder_History = $00000022;\r\n SpecialFolder_InternetCache = $00000020;\r\n SpecialFolder_Programs = $00000002;\r\n SpecialFolder_MyComputer = $00000011;\r\n SpecialFolder_MyMusic = $0000000D;\r\n SpecialFolder_MyPictures = $00000027;\r\n SpecialFolder_Recent = $00000008;\r\n SpecialFolder_SendTo = $00000009;\r\n SpecialFolder_StartMenu = $0000000B;\r\n SpecialFolder_Startup = $00000007;\r\n SpecialFolder_System = $00000025;\r\n SpecialFolder_Templates = $00000015;\r\n SpecialFolder_DesktopDirectory = $00000010;\r\n SpecialFolder_Personal = $00000005;\r\n SpecialFolder_ProgramFiles = $00000026;\r\n SpecialFolder_CommonProgramFiles = $0000002B;\r\n\r\n// Constants for enum PlatformID\r\ntype\r\n PlatformID = TOleEnum;\r\nconst\r\n PlatformID_Win32S = $00000000;\r\n PlatformID_Win32Windows = $00000001;\r\n PlatformID_Win32NT = $00000002;\r\n PlatformID_WinCE = $00000003;\r\n\r\n// Constants for enum TypeCode\r\ntype\r\n TypeCode = TOleEnum;\r\nconst\r\n TypeCode_Empty = $00000000;\r\n TypeCode_Object = $00000001;\r\n TypeCode_DBNull = $00000002;\r\n TypeCode_Boolean = $00000003;\r\n TypeCode_Char = $00000004;\r\n TypeCode_SByte = $00000005;\r\n TypeCode_Byte = $00000006;\r\n TypeCode_Int16 = $00000007;\r\n TypeCode_UInt16 = $00000008;\r\n TypeCode_Int32 = $00000009;\r\n TypeCode_UInt32 = $0000000A;\r\n TypeCode_Int64 = $0000000B;\r\n TypeCode_UInt64 = $0000000C;\r\n TypeCode_Single = $0000000D;\r\n TypeCode_Double = $0000000E;\r\n TypeCode_Decimal = $0000000F;\r\n TypeCode_DateTime = $00000010;\r\n TypeCode_String = $00000012;\r\n\r\n// Constants for enum ApartmentState\r\ntype\r\n ApartmentState = TOleEnum;\r\nconst\r\n ApartmentState_STA = $00000000;\r\n ApartmentState_MTA = $00000001;\r\n ApartmentState_Unknown = $00000002;\r\n\r\n// Constants for enum ThreadPriority\r\ntype\r\n ThreadPriority = TOleEnum;\r\nconst\r\n ThreadPriority_Lowest = $00000000;\r\n ThreadPriority_BelowNormal = $00000001;\r\n ThreadPriority_Normal = $00000002;\r\n ThreadPriority_AboveNormal = $00000003;\r\n ThreadPriority_Highest = $00000004;\r\n\r\n// Constants for enum ThreadState\r\ntype\r\n ThreadState = TOleEnum;\r\nconst\r\n ThreadState_Running = $00000000;\r\n ThreadState_StopRequested = $00000001;\r\n ThreadState_SuspendRequested = $00000002;\r\n ThreadState_Background = $00000004;\r\n ThreadState_Unstarted = $00000008;\r\n ThreadState_Stopped = $00000010;\r\n ThreadState_WaitSleepJoin = $00000020;\r\n ThreadState_Suspended = $00000040;\r\n ThreadState_AbortRequested = $00000080;\r\n ThreadState_Aborted = $00000100;\r\n\r\n// Constants for enum SymAddressKind\r\ntype\r\n SymAddressKind = TOleEnum;\r\nconst\r\n SymAddressKind_ILOffset = $00000001;\r\n SymAddressKind_NativeRVA = $00000002;\r\n SymAddressKind_NativeRegister = $00000003;\r\n SymAddressKind_NativeRegisterRelative = $00000004;\r\n SymAddressKind_NativeOffset = $00000005;\r\n SymAddressKind_NativeRegisterRegister = $00000006;\r\n SymAddressKind_NativeRegisterStack = $00000007;\r\n SymAddressKind_NativeStackRegister = $00000008;\r\n SymAddressKind_BitField = $00000009;\r\n\r\n// Constants for enum AssemblyNameFlags\r\ntype\r\n AssemblyNameFlags = TOleEnum;\r\nconst\r\n AssemblyNameFlags_None = $00000000;\r\n AssemblyNameFlags_PublicKey = $00000001;\r\n AssemblyNameFlags_Retargetable = $00000100;\r\n\r\n// Constants for enum BindingFlags\r\ntype\r\n BindingFlags = TOleEnum;\r\nconst\r\n BindingFlags_Default = $00000000;\r\n BindingFlags_IgnoreCase = $00000001;\r\n BindingFlags_DeclaredOnly = $00000002;\r\n BindingFlags_Instance = $00000004;\r\n BindingFlags_Static = $00000008;\r\n BindingFlags_Public = $00000010;\r\n BindingFlags_NonPublic = $00000020;\r\n BindingFlags_FlattenHierarchy = $00000040;\r\n BindingFlags_InvokeMethod = $00000100;\r\n BindingFlags_CreateInstance = $00000200;\r\n BindingFlags_GetField = $00000400;\r\n BindingFlags_SetField = $00000800;\r\n BindingFlags_GetProperty = $00001000;\r\n BindingFlags_SetProperty = $00002000;\r\n BindingFlags_PutDispProperty = $00004000;\r\n BindingFlags_PutRefDispProperty = $00008000;\r\n BindingFlags_ExactBinding = $00010000;\r\n BindingFlags_SuppressChangeType = $00020000;\r\n BindingFlags_OptionalParamBinding = $00040000;\r\n BindingFlags_IgnoreReturn = $01000000;\r\n\r\n// Constants for enum CallingConventions\r\ntype\r\n CallingConventions = TOleEnum;\r\nconst\r\n CallingConventions_Standard = $00000001;\r\n CallingConventions_VarArgs = $00000002;\r\n CallingConventions_Any = $00000003;\r\n CallingConventions_HasThis = $00000020;\r\n CallingConventions_ExplicitThis = $00000040;\r\n\r\n// Constants for enum EventAttributes\r\ntype\r\n EventAttributes = TOleEnum;\r\nconst\r\n EventAttributes_None = $00000000;\r\n EventAttributes_SpecialName = $00000200;\r\n EventAttributes_ReservedMask = $00000400;\r\n EventAttributes_RTSpecialName = $00000400;\r\n\r\n// Constants for enum FieldAttributes\r\ntype\r\n FieldAttributes = TOleEnum;\r\nconst\r\n FieldAttributes_FieldAccessMask = $00000007;\r\n FieldAttributes_PrivateScope = $00000000;\r\n FieldAttributes_Private = $00000001;\r\n FieldAttributes_FamANDAssem = $00000002;\r\n FieldAttributes_Assembly = $00000003;\r\n FieldAttributes_Family = $00000004;\r\n FieldAttributes_FamORAssem = $00000005;\r\n FieldAttributes_Public = $00000006;\r\n FieldAttributes_Static = $00000010;\r\n FieldAttributes_InitOnly = $00000020;\r\n FieldAttributes_Literal = $00000040;\r\n FieldAttributes_NotSerialized = $00000080;\r\n FieldAttributes_SpecialName = $00000200;\r\n FieldAttributes_PinvokeImpl = $00002000;\r\n FieldAttributes_ReservedMask = $00009500;\r\n FieldAttributes_RTSpecialName = $00000400;\r\n FieldAttributes_HasFieldMarshal = $00001000;\r\n FieldAttributes_HasDefault = $00008000;\r\n FieldAttributes_HasFieldRVA = $00000100;\r\n\r\n// Constants for enum ResourceLocation\r\ntype\r\n ResourceLocation = TOleEnum;\r\nconst\r\n ResourceLocation_Embedded = $00000001;\r\n ResourceLocation_ContainedInAnotherAssembly = $00000002;\r\n ResourceLocation_ContainedInManifestFile = $00000004;\r\n\r\n// Constants for enum MemberTypes\r\ntype\r\n MemberTypes = TOleEnum;\r\nconst\r\n MemberTypes_Constructor = $00000001;\r\n MemberTypes_Event = $00000002;\r\n MemberTypes_Field = $00000004;\r\n MemberTypes_Method = $00000008;\r\n MemberTypes_Property = $00000010;\r\n MemberTypes_TypeInfo = $00000020;\r\n MemberTypes_Custom = $00000040;\r\n MemberTypes_NestedType = $00000080;\r\n MemberTypes_All = $000000BF;\r\n\r\n// Constants for enum MethodAttributes\r\ntype\r\n MethodAttributes = TOleEnum;\r\nconst\r\n MethodAttributes_MemberAccessMask = $00000007;\r\n MethodAttributes_PrivateScope = $00000000;\r\n MethodAttributes_Private = $00000001;\r\n MethodAttributes_FamANDAssem = $00000002;\r\n MethodAttributes_Assembly = $00000003;\r\n MethodAttributes_Family = $00000004;\r\n MethodAttributes_FamORAssem = $00000005;\r\n MethodAttributes_Public = $00000006;\r\n MethodAttributes_Static = $00000010;\r\n MethodAttributes_Final = $00000020;\r\n MethodAttributes_Virtual = $00000040;\r\n MethodAttributes_HideBySig = $00000080;\r\n MethodAttributes_CheckAccessOnOverride = $00000200;\r\n MethodAttributes_VtableLayoutMask = $00000100;\r\n MethodAttributes_ReuseSlot = $00000000;\r\n MethodAttributes_NewSlot = $00000100;\r\n MethodAttributes_Abstract = $00000400;\r\n MethodAttributes_SpecialName = $00000800;\r\n MethodAttributes_PinvokeImpl = $00002000;\r\n MethodAttributes_UnmanagedExport = $00000008;\r\n MethodAttributes_RTSpecialName = $00001000;\r\n MethodAttributes_ReservedMask = $0000D000;\r\n MethodAttributes_HasSecurity = $00004000;\r\n MethodAttributes_RequireSecObject = $00008000;\r\n\r\n// Constants for enum MethodImplAttributes\r\ntype\r\n MethodImplAttributes = TOleEnum;\r\nconst\r\n MethodImplAttributes_CodeTypeMask = $00000003;\r\n MethodImplAttributes_IL = $00000000;\r\n MethodImplAttributes_Native = $00000001;\r\n MethodImplAttributes_OPTIL = $00000002;\r\n MethodImplAttributes_Runtime = $00000003;\r\n MethodImplAttributes_ManagedMask = $00000004;\r\n MethodImplAttributes_Unmanaged = $00000004;\r\n MethodImplAttributes_Managed = $00000000;\r\n MethodImplAttributes_ForwardRef = $00000010;\r\n MethodImplAttributes_PreserveSig = $00000080;\r\n MethodImplAttributes_InternalCall = $00001000;\r\n MethodImplAttributes_Synchronized = $00000020;\r\n MethodImplAttributes_NoInlining = $00000008;\r\n MethodImplAttributes_MaxMethodImplVal = $0000FFFF;\r\n\r\n// Constants for enum ParameterAttributes\r\ntype\r\n ParameterAttributes = TOleEnum;\r\nconst\r\n ParameterAttributes_None = $00000000;\r\n ParameterAttributes_In = $00000001;\r\n ParameterAttributes_Out = $00000002;\r\n ParameterAttributes_Lcid = $00000004;\r\n ParameterAttributes_Retval = $00000008;\r\n ParameterAttributes_Optional = $00000010;\r\n ParameterAttributes_ReservedMask = $0000F000;\r\n ParameterAttributes_HasDefault = $00001000;\r\n ParameterAttributes_HasFieldMarshal = $00002000;\r\n ParameterAttributes_Reserved3 = $00004000;\r\n ParameterAttributes_Reserved4 = $00008000;\r\n\r\n// Constants for enum PropertyAttributes\r\ntype\r\n PropertyAttributes = TOleEnum;\r\nconst\r\n PropertyAttributes_None = $00000000;\r\n PropertyAttributes_SpecialName = $00000200;\r\n PropertyAttributes_ReservedMask = $0000F400;\r\n PropertyAttributes_RTSpecialName = $00000400;\r\n PropertyAttributes_HasDefault = $00001000;\r\n PropertyAttributes_Reserved2 = $00002000;\r\n PropertyAttributes_Reserved3 = $00004000;\r\n PropertyAttributes_Reserved4 = $00008000;\r\n\r\n// Constants for enum ResourceAttributes\r\ntype\r\n ResourceAttributes = TOleEnum;\r\nconst\r\n ResourceAttributes_Public = $00000001;\r\n ResourceAttributes_Private = $00000002;\r\n\r\n// Constants for enum TypeAttributes\r\ntype\r\n TypeAttributes = TOleEnum;\r\nconst\r\n TypeAttributes_VisibilityMask = $00000007;\r\n TypeAttributes_NotPublic = $00000000;\r\n TypeAttributes_Public = $00000001;\r\n TypeAttributes_NestedPublic = $00000002;\r\n TypeAttributes_NestedPrivate = $00000003;\r\n TypeAttributes_NestedFamily = $00000004;\r\n TypeAttributes_NestedAssembly = $00000005;\r\n TypeAttributes_NestedFamANDAssem = $00000006;\r\n TypeAttributes_NestedFamORAssem = $00000007;\r\n TypeAttributes_LayoutMask = $00000018;\r\n TypeAttributes_AutoLayout = $00000000;\r\n TypeAttributes_SequentialLayout = $00000008;\r\n TypeAttributes_ExplicitLayout = $00000010;\r\n TypeAttributes_ClassSemanticsMask = $00000020;\r\n TypeAttributes_Class = $00000000;\r\n TypeAttributes_Interface = $00000020;\r\n TypeAttributes_Abstract = $00000080;\r\n TypeAttributes_Sealed = $00000100;\r\n TypeAttributes_SpecialName = $00000400;\r\n TypeAttributes_Import = $00001000;\r\n TypeAttributes_Serializable = $00002000;\r\n TypeAttributes_StringFormatMask = $00030000;\r\n TypeAttributes_AnsiClass = $00000000;\r\n TypeAttributes_UnicodeClass = $00010000;\r\n TypeAttributes_AutoClass = $00020000;\r\n TypeAttributes_BeforeFieldInit = $00100000;\r\n TypeAttributes_ReservedMask = $00040800;\r\n TypeAttributes_RTSpecialName = $00000800;\r\n TypeAttributes_HasSecurity = $00040000;\r\n\r\n// Constants for enum StreamingContextStates\r\ntype\r\n StreamingContextStates = TOleEnum;\r\nconst\r\n StreamingContextStates_CrossProcess = $00000001;\r\n StreamingContextStates_CrossMachine = $00000002;\r\n StreamingContextStates_File = $00000004;\r\n StreamingContextStates_Persistence = $00000008;\r\n StreamingContextStates_Remoting = $00000010;\r\n StreamingContextStates_Other = $00000020;\r\n StreamingContextStates_Clone = $00000040;\r\n StreamingContextStates_CrossAppDomain = $00000080;\r\n StreamingContextStates_All = $000000FF;\r\n\r\n// Constants for enum CalendarWeekRule\r\ntype\r\n CalendarWeekRule = TOleEnum;\r\nconst\r\n CalendarWeekRule_FirstDay = $00000000;\r\n CalendarWeekRule_FirstFullWeek = $00000001;\r\n CalendarWeekRule_FirstFourDayWeek = $00000002;\r\n\r\n// Constants for enum CompareOptions\r\ntype\r\n CompareOptions = TOleEnum;\r\nconst\r\n CompareOptions_None = $00000000;\r\n CompareOptions_IgnoreCase = $00000001;\r\n CompareOptions_IgnoreNonSpace = $00000002;\r\n CompareOptions_IgnoreSymbols = $00000004;\r\n CompareOptions_IgnoreKanaType = $00000008;\r\n CompareOptions_IgnoreWidth = $00000010;\r\n CompareOptions_StringSort = $20000000;\r\n CompareOptions_Ordinal = $40000000;\r\n\r\n// Constants for enum CultureTypes\r\ntype\r\n CultureTypes = TOleEnum;\r\nconst\r\n CultureTypes_NeutralCultures = $00000001;\r\n CultureTypes_SpecificCultures = $00000002;\r\n CultureTypes_InstalledWin32Cultures = $00000004;\r\n CultureTypes_AllCultures = $00000007;\r\n\r\n// Constants for enum DateTimeStyles\r\ntype\r\n DateTimeStyles = TOleEnum;\r\nconst\r\n DateTimeStyles_None = $00000000;\r\n DateTimeStyles_AllowLeadingWhite = $00000001;\r\n DateTimeStyles_AllowTrailingWhite = $00000002;\r\n DateTimeStyles_AllowInnerWhite = $00000004;\r\n DateTimeStyles_AllowWhiteSpaces = $00000007;\r\n DateTimeStyles_NoCurrentDateDefault = $00000008;\r\n DateTimeStyles_AdjustToUniversal = $00000010;\r\n\r\n// Constants for enum GregorianCalendarTypes\r\ntype\r\n GregorianCalendarTypes = TOleEnum;\r\nconst\r\n GregorianCalendarTypes_Localized = $00000001;\r\n GregorianCalendarTypes_USEnglish = $00000002;\r\n GregorianCalendarTypes_MiddleEastFrench = $00000009;\r\n GregorianCalendarTypes_Arabic = $0000000A;\r\n GregorianCalendarTypes_TransliteratedEnglish = $0000000B;\r\n GregorianCalendarTypes_TransliteratedFrench = $0000000C;\r\n\r\n// Constants for enum NumberStyles\r\ntype\r\n NumberStyles = TOleEnum;\r\nconst\r\n NumberStyles_None = $00000000;\r\n NumberStyles_AllowLeadingWhite = $00000001;\r\n NumberStyles_AllowTrailingWhite = $00000002;\r\n NumberStyles_AllowLeadingSign = $00000004;\r\n NumberStyles_AllowTrailingSign = $00000008;\r\n NumberStyles_AllowParentheses = $00000010;\r\n NumberStyles_AllowDecimalPoint = $00000020;\r\n NumberStyles_AllowThousands = $00000040;\r\n NumberStyles_AllowExponent = $00000080;\r\n NumberStyles_AllowCurrencySymbol = $00000100;\r\n NumberStyles_AllowHexSpecifier = $00000200;\r\n NumberStyles_Integer = $00000007;\r\n NumberStyles_HexNumber = $00000203;\r\n NumberStyles_Number = $0000006F;\r\n NumberStyles_Float = $000000A7;\r\n NumberStyles_Currency = $0000017F;\r\n NumberStyles_Any = $000001FF;\r\n\r\n// Constants for enum UnicodeCategory\r\ntype\r\n UnicodeCategory = TOleEnum;\r\nconst\r\n UnicodeCategory_UppercaseLetter = $00000000;\r\n UnicodeCategory_LowercaseLetter = $00000001;\r\n UnicodeCategory_TitlecaseLetter = $00000002;\r\n UnicodeCategory_ModifierLetter = $00000003;\r\n UnicodeCategory_OtherLetter = $00000004;\r\n UnicodeCategory_NonSpacingMark = $00000005;\r\n UnicodeCategory_SpacingCombiningMark = $00000006;\r\n UnicodeCategory_EnclosingMark = $00000007;\r\n UnicodeCategory_DecimalDigitNumber = $00000008;\r\n UnicodeCategory_LetterNumber = $00000009;\r\n UnicodeCategory_OtherNumber = $0000000A;\r\n UnicodeCategory_SpaceSeparator = $0000000B;\r\n UnicodeCategory_LineSeparator = $0000000C;\r\n UnicodeCategory_ParagraphSeparator = $0000000D;\r\n UnicodeCategory_Control = $0000000E;\r\n UnicodeCategory_Format = $0000000F;\r\n UnicodeCategory_Surrogate = $00000010;\r\n UnicodeCategory_PrivateUse = $00000011;\r\n UnicodeCategory_ConnectorPunctuation = $00000012;\r\n UnicodeCategory_DashPunctuation = $00000013;\r\n UnicodeCategory_OpenPunctuation = $00000014;\r\n UnicodeCategory_ClosePunctuation = $00000015;\r\n UnicodeCategory_InitialQuotePunctuation = $00000016;\r\n UnicodeCategory_FinalQuotePunctuation = $00000017;\r\n UnicodeCategory_OtherPunctuation = $00000018;\r\n UnicodeCategory_MathSymbol = $00000019;\r\n UnicodeCategory_CurrencySymbol = $0000001A;\r\n UnicodeCategory_ModifierSymbol = $0000001B;\r\n UnicodeCategory_OtherSymbol = $0000001C;\r\n UnicodeCategory_OtherNotAssigned = $0000001D;\r\n\r\n// Constants for enum RegistryHive\r\ntype\r\n RegistryHive = TOleEnum;\r\nconst\r\n RegistryHive_ClassesRoot = $80000000;\r\n RegistryHive_CurrentUser = $80000001;\r\n RegistryHive_LocalMachine = $80000002;\r\n RegistryHive_Users = $80000003;\r\n RegistryHive_PerformanceData = $80000004;\r\n RegistryHive_CurrentConfig = $80000005;\r\n RegistryHive_DynData = $80000006;\r\n\r\n// Constants for enum FromBase64TransformMode\r\ntype\r\n FromBase64TransformMode = TOleEnum;\r\nconst\r\n FromBase64TransformMode_IgnoreWhiteSpaces = $00000000;\r\n FromBase64TransformMode_DoNotIgnoreWhiteSpaces = $00000001;\r\n\r\n// Constants for enum CipherMode\r\ntype\r\n CipherMode = TOleEnum;\r\nconst\r\n CipherMode_CBC = $00000001;\r\n CipherMode_ECB = $00000002;\r\n CipherMode_OFB = $00000003;\r\n CipherMode_CFB = $00000004;\r\n CipherMode_CTS = $00000005;\r\n\r\n// Constants for enum PaddingMode\r\ntype\r\n PaddingMode = TOleEnum;\r\nconst\r\n PaddingMode_None = $00000001;\r\n PaddingMode_PKCS7 = $00000002;\r\n PaddingMode_Zeros = $00000003;\r\n\r\n// Constants for enum CspProviderFlags\r\ntype\r\n CspProviderFlags = TOleEnum;\r\nconst\r\n CspProviderFlags_UseMachineKeyStore = $00000001;\r\n CspProviderFlags_UseDefaultKeyContainer = $00000002;\r\n\r\n// Constants for enum CryptoStreamMode\r\ntype\r\n CryptoStreamMode = TOleEnum;\r\nconst\r\n CryptoStreamMode_Read = $00000000;\r\n CryptoStreamMode_Write = $00000001;\r\n\r\n// Constants for enum PolicyStatementAttribute\r\ntype\r\n PolicyStatementAttribute = TOleEnum;\r\nconst\r\n PolicyStatementAttribute_Nothing = $00000000;\r\n PolicyStatementAttribute_Exclusive = $00000001;\r\n PolicyStatementAttribute_LevelFinal = $00000002;\r\n PolicyStatementAttribute_All = $00000003;\r\n\r\n// Constants for enum PrincipalPolicy\r\ntype\r\n PrincipalPolicy = TOleEnum;\r\nconst\r\n PrincipalPolicy_UnauthenticatedPrincipal = $00000000;\r\n PrincipalPolicy_NoPrincipal = $00000001;\r\n PrincipalPolicy_WindowsPrincipal = $00000002;\r\n\r\n// Constants for enum WindowsAccountType\r\ntype\r\n WindowsAccountType = TOleEnum;\r\nconst\r\n WindowsAccountType_Normal = $00000000;\r\n WindowsAccountType_Guest = $00000001;\r\n WindowsAccountType_System = $00000002;\r\n WindowsAccountType_Anonymous = $00000003;\r\n\r\n// Constants for enum WindowsBuiltInRole\r\ntype\r\n WindowsBuiltInRole = TOleEnum;\r\nconst\r\n WindowsBuiltInRole_Administrator = $00000220;\r\n WindowsBuiltInRole_User = $00000221;\r\n WindowsBuiltInRole_Guest = $00000222;\r\n WindowsBuiltInRole_PowerUser = $00000223;\r\n WindowsBuiltInRole_AccountOperator = $00000224;\r\n WindowsBuiltInRole_SystemOperator = $00000225;\r\n WindowsBuiltInRole_PrintOperator = $00000226;\r\n WindowsBuiltInRole_BackupOperator = $00000227;\r\n WindowsBuiltInRole_Replicator = $00000228;\r\n\r\n// Constants for enum ComInterfaceType\r\ntype\r\n ComInterfaceType = TOleEnum;\r\nconst\r\n ComInterfaceType_InterfaceIsDual = $00000000;\r\n ComInterfaceType_InterfaceIsIUnknown = $00000001;\r\n ComInterfaceType_InterfaceIsIDispatch = $00000002;\r\n\r\n// Constants for enum ClassInterfaceType\r\ntype\r\n ClassInterfaceType = TOleEnum;\r\nconst\r\n ClassInterfaceType_None = $00000000;\r\n ClassInterfaceType_AutoDispatch = $00000001;\r\n ClassInterfaceType_AutoDual = $00000002;\r\n\r\n// Constants for enum IDispatchImplType\r\ntype\r\n IDispatchImplType = TOleEnum;\r\nconst\r\n IDispatchImplType_SystemDefinedImpl = $00000000;\r\n IDispatchImplType_InternalImpl = $00000001;\r\n IDispatchImplType_CompatibleImpl = $00000002;\r\n\r\n// Constants for enum TypeLibTypeFlags\r\ntype\r\n TypeLibTypeFlags = TOleEnum;\r\nconst\r\n TypeLibTypeFlags_FAppObject = $00000001;\r\n TypeLibTypeFlags_FCanCreate = $00000002;\r\n TypeLibTypeFlags_FLicensed = $00000004;\r\n TypeLibTypeFlags_FPreDeclId = $00000008;\r\n TypeLibTypeFlags_FHidden = $00000010;\r\n TypeLibTypeFlags_FControl = $00000020;\r\n TypeLibTypeFlags_FDual = $00000040;\r\n TypeLibTypeFlags_FNonExtensible = $00000080;\r\n TypeLibTypeFlags_FOleAutomation = $00000100;\r\n TypeLibTypeFlags_FRestricted = $00000200;\r\n TypeLibTypeFlags_FAggregatable = $00000400;\r\n TypeLibTypeFlags_FReplaceable = $00000800;\r\n TypeLibTypeFlags_FDispatchable = $00001000;\r\n TypeLibTypeFlags_FReverseBind = $00002000;\r\n\r\n// Constants for enum TypeLibFuncFlags\r\ntype\r\n TypeLibFuncFlags = TOleEnum;\r\nconst\r\n TypeLibFuncFlags_FRestricted = $00000001;\r\n TypeLibFuncFlags_FSource = $00000002;\r\n TypeLibFuncFlags_FBindable = $00000004;\r\n TypeLibFuncFlags_FRequestEdit = $00000008;\r\n TypeLibFuncFlags_FDisplayBind = $00000010;\r\n TypeLibFuncFlags_FDefaultBind = $00000020;\r\n TypeLibFuncFlags_FHidden = $00000040;\r\n TypeLibFuncFlags_FUsesGetLastError = $00000080;\r\n TypeLibFuncFlags_FDefaultCollelem = $00000100;\r\n TypeLibFuncFlags_FUiDefault = $00000200;\r\n TypeLibFuncFlags_FNonBrowsable = $00000400;\r\n TypeLibFuncFlags_FReplaceable = $00000800;\r\n TypeLibFuncFlags_FImmediateBind = $00001000;\r\n\r\n// Constants for enum TypeLibVarFlags\r\ntype\r\n TypeLibVarFlags = TOleEnum;\r\nconst\r\n TypeLibVarFlags_FReadOnly = $00000001;\r\n TypeLibVarFlags_FSource = $00000002;\r\n TypeLibVarFlags_FBindable = $00000004;\r\n TypeLibVarFlags_FRequestEdit = $00000008;\r\n TypeLibVarFlags_FDisplayBind = $00000010;\r\n TypeLibVarFlags_FDefaultBind = $00000020;\r\n TypeLibVarFlags_FHidden = $00000040;\r\n TypeLibVarFlags_FRestricted = $00000080;\r\n TypeLibVarFlags_FDefaultCollelem = $00000100;\r\n TypeLibVarFlags_FUiDefault = $00000200;\r\n TypeLibVarFlags_FNonBrowsable = $00000400;\r\n TypeLibVarFlags_FReplaceable = $00000800;\r\n TypeLibVarFlags_FImmediateBind = $00001000;\r\n\r\n// Constants for enum VarEnum\r\ntype\r\n VarEnum = TOleEnum;\r\nconst\r\n VarEnum_VT_EMPTY = $00000000;\r\n VarEnum_VT_NULL = $00000001;\r\n VarEnum_VT_I2 = $00000002;\r\n VarEnum_VT_I4 = $00000003;\r\n VarEnum_VT_R4 = $00000004;\r\n VarEnum_VT_R8 = $00000005;\r\n VarEnum_VT_CY = $00000006;\r\n VarEnum_VT_DATE = $00000007;\r\n VarEnum_VT_BSTR = $00000008;\r\n VarEnum_VT_DISPATCH = $00000009;\r\n VarEnum_VT_ERROR = $0000000A;\r\n VarEnum_VT_BOOL = $0000000B;\r\n VarEnum_VT_VARIANT = $0000000C;\r\n VarEnum_VT_UNKNOWN = $0000000D;\r\n VarEnum_VT_DECIMAL = $0000000E;\r\n VarEnum_VT_I1 = $00000010;\r\n VarEnum_VT_UI1 = $00000011;\r\n VarEnum_VT_UI2 = $00000012;\r\n VarEnum_VT_UI4 = $00000013;\r\n VarEnum_VT_I8 = $00000014;\r\n VarEnum_VT_UI8 = $00000015;\r\n VarEnum_VT_INT = $00000016;\r\n VarEnum_VT_UINT = $00000017;\r\n VarEnum_VT_VOID = $00000018;\r\n VarEnum_VT_HRESULT = $00000019;\r\n VarEnum_VT_PTR = $0000001A;\r\n VarEnum_VT_SAFEARRAY = $0000001B;\r\n VarEnum_VT_CARRAY = $0000001C;\r\n VarEnum_VT_USERDEFINED = $0000001D;\r\n VarEnum_VT_LPSTR = $0000001E;\r\n VarEnum_VT_LPWSTR = $0000001F;\r\n VarEnum_VT_RECORD = $00000024;\r\n VarEnum_VT_FILETIME = $00000040;\r\n VarEnum_VT_BLOB = $00000041;\r\n VarEnum_VT_STREAM = $00000042;\r\n VarEnum_VT_STORAGE = $00000043;\r\n VarEnum_VT_STREAMED_OBJECT = $00000044;\r\n VarEnum_VT_STORED_OBJECT = $00000045;\r\n VarEnum_VT_BLOB_OBJECT = $00000046;\r\n VarEnum_VT_CF = $00000047;\r\n VarEnum_VT_CLSID = $00000048;\r\n VarEnum_VT_VECTOR = $00001000;\r\n VarEnum_VT_ARRAY = $00002000;\r\n VarEnum_VT_BYREF = $00004000;\r\n\r\n// Constants for enum UnmanagedType\r\ntype\r\n UnmanagedType = TOleEnum;\r\nconst\r\n UnmanagedType_Bool = $00000002;\r\n UnmanagedType_I1 = $00000003;\r\n UnmanagedType_U1 = $00000004;\r\n UnmanagedType_I2 = $00000005;\r\n UnmanagedType_U2 = $00000006;\r\n UnmanagedType_I4 = $00000007;\r\n UnmanagedType_U4 = $00000008;\r\n UnmanagedType_I8 = $00000009;\r\n UnmanagedType_U8 = $0000000A;\r\n UnmanagedType_R4 = $0000000B;\r\n UnmanagedType_R8 = $0000000C;\r\n UnmanagedType_Currency = $0000000F;\r\n UnmanagedType_BStr = $00000013;\r\n UnmanagedType_LPStr = $00000014;\r\n UnmanagedType_LPWStr = $00000015;\r\n UnmanagedType_LPTStr = $00000016;\r\n UnmanagedType_ByValTStr = $00000017;\r\n UnmanagedType_IUnknown = $00000019;\r\n UnmanagedType_IDispatch = $0000001A;\r\n UnmanagedType_Struct = $0000001B;\r\n UnmanagedType_Interface = $0000001C;\r\n UnmanagedType_SafeArray = $0000001D;\r\n UnmanagedType_ByValArray = $0000001E;\r\n UnmanagedType_SysInt = $0000001F;\r\n UnmanagedType_SysUInt = $00000020;\r\n UnmanagedType_VBByRefStr = $00000022;\r\n UnmanagedType_AnsiBStr = $00000023;\r\n UnmanagedType_TBStr = $00000024;\r\n UnmanagedType_VariantBool = $00000025;\r\n UnmanagedType_FunctionPtr = $00000026;\r\n UnmanagedType_AsAny = $00000028;\r\n UnmanagedType_LPArray = $0000002A;\r\n UnmanagedType_LPStruct = $0000002B;\r\n UnmanagedType_CustomMarshaler = $0000002C;\r\n UnmanagedType_Error = $0000002D;\r\n\r\n// Constants for enum CallingConvention\r\ntype\r\n CallingConvention = TOleEnum;\r\nconst\r\n CallingConvention_Winapi = $00000001;\r\n CallingConvention_Cdecl = $00000002;\r\n CallingConvention_StdCall = $00000003;\r\n CallingConvention_ThisCall = $00000004;\r\n CallingConvention_FastCall = $00000005;\r\n\r\n// Constants for enum CharSet\r\ntype\r\n CharSet = TOleEnum;\r\nconst\r\n CharSet_None = $00000001;\r\n CharSet_Ansi = $00000002;\r\n CharSet_Unicode = $00000003;\r\n CharSet_Auto = $00000004;\r\n\r\n// Constants for enum ComMemberType\r\ntype\r\n ComMemberType = TOleEnum;\r\nconst\r\n ComMemberType_Method = $00000000;\r\n ComMemberType_PropGet = $00000001;\r\n ComMemberType_PropSet = $00000002;\r\n\r\n// Constants for enum GCHandleType\r\ntype\r\n GCHandleType = TOleEnum;\r\nconst\r\n GCHandleType_Weak = $00000000;\r\n GCHandleType_WeakTrackResurrection = $00000001;\r\n GCHandleType_Normal = $00000002;\r\n GCHandleType_Pinned = $00000003;\r\n\r\n// Constants for enum AssemblyRegistrationFlags\r\ntype\r\n AssemblyRegistrationFlags = TOleEnum;\r\nconst\r\n AssemblyRegistrationFlags_None = $00000000;\r\n AssemblyRegistrationFlags_SetCodeBase = $00000001;\r\n\r\n// Constants for enum TypeLibImporterFlags\r\ntype\r\n TypeLibImporterFlags = TOleEnum;\r\nconst\r\n TypeLibImporterFlags_PrimaryInteropAssembly = $00000001;\r\n TypeLibImporterFlags_UnsafeInterfaces = $00000002;\r\n TypeLibImporterFlags_SafeArrayAsSystemArray = $00000004;\r\n TypeLibImporterFlags_TransformDispRetVals = $00000008;\r\n\r\n// Constants for enum TypeLibExporterFlags\r\ntype\r\n TypeLibExporterFlags = TOleEnum;\r\nconst\r\n TypeLibExporterFlags_OnlyReferenceRegistered = $00000001;\r\n\r\n// Constants for enum ImporterEventKind\r\ntype\r\n ImporterEventKind = TOleEnum;\r\nconst\r\n ImporterEventKind_NOTIF_TYPECONVERTED = $00000000;\r\n ImporterEventKind_NOTIF_CONVERTWARNING = $00000001;\r\n ImporterEventKind_ERROR_REFTOINVALIDTYPELIB = $00000002;\r\n\r\n// Constants for enum ExporterEventKind\r\ntype\r\n ExporterEventKind = TOleEnum;\r\nconst\r\n ExporterEventKind_NOTIF_TYPECONVERTED = $00000000;\r\n ExporterEventKind_NOTIF_CONVERTWARNING = $00000001;\r\n ExporterEventKind_ERROR_REFTOINVALIDASSEMBLY = $00000002;\r\n\r\n// Constants for enum LayoutKind\r\ntype\r\n LayoutKind = TOleEnum;\r\nconst\r\n LayoutKind_Sequential = $00000000;\r\n LayoutKind_Explicit = $00000002;\r\n LayoutKind_Auto = $00000003;\r\n\r\n// Constants for enum FileAccess\r\ntype\r\n FileAccess = TOleEnum;\r\nconst\r\n FileAccess_Read = $00000001;\r\n FileAccess_Write = $00000002;\r\n FileAccess_ReadWrite = $00000003;\r\n\r\n// Constants for enum FileMode\r\ntype\r\n FileMode = TOleEnum;\r\nconst\r\n FileMode_CreateNew = $00000001;\r\n FileMode_Create = $00000002;\r\n FileMode_Open = $00000003;\r\n FileMode_OpenOrCreate = $00000004;\r\n FileMode_Truncate = $00000005;\r\n FileMode_Append = $00000006;\r\n\r\n// Constants for enum FileShare\r\ntype\r\n FileShare = TOleEnum;\r\nconst\r\n FileShare_None = $00000000;\r\n FileShare_Read = $00000001;\r\n FileShare_Write = $00000002;\r\n FileShare_ReadWrite = $00000003;\r\n FileShare_Inheritable = $00000010;\r\n\r\n// Constants for enum FileAttributes\r\ntype\r\n FileAttributes = TOleEnum;\r\nconst\r\n FileAttributes_ReadOnly = $00000001;\r\n FileAttributes_Hidden = $00000002;\r\n FileAttributes_System = $00000004;\r\n FileAttributes_Directory = $00000010;\r\n FileAttributes_Archive = $00000020;\r\n FileAttributes_Device = $00000040;\r\n FileAttributes_Normal = $00000080;\r\n FileAttributes_Temporary = $00000100;\r\n FileAttributes_SparseFile = $00000200;\r\n FileAttributes_ReparsePoint = $00000400;\r\n FileAttributes_Compressed = $00000800;\r\n FileAttributes_Offline = $00001000;\r\n FileAttributes_NotContentIndexed = $00002000;\r\n FileAttributes_Encrypted = $00004000;\r\n\r\n// Constants for enum SeekOrigin\r\ntype\r\n SeekOrigin = TOleEnum;\r\nconst\r\n SeekOrigin_Begin = $00000000;\r\n SeekOrigin_Current = $00000001;\r\n SeekOrigin_End = $00000002;\r\n\r\n// Constants for enum MethodImplOptions\r\ntype\r\n MethodImplOptions = TOleEnum;\r\nconst\r\n MethodImplOptions_Unmanaged = $00000004;\r\n MethodImplOptions_ForwardRef = $00000010;\r\n MethodImplOptions_PreserveSig = $00000080;\r\n MethodImplOptions_InternalCall = $00001000;\r\n MethodImplOptions_Synchronized = $00000020;\r\n MethodImplOptions_NoInlining = $00000008;\r\n\r\n// Constants for enum MethodCodeType\r\ntype\r\n MethodCodeType = TOleEnum;\r\nconst\r\n MethodCodeType_IL = $00000000;\r\n MethodCodeType_Native = $00000001;\r\n MethodCodeType_OPTIL = $00000002;\r\n MethodCodeType_Runtime = $00000003;\r\n\r\n// Constants for enum EnvironmentPermissionAccess\r\ntype\r\n EnvironmentPermissionAccess = TOleEnum;\r\nconst\r\n EnvironmentPermissionAccess_NoAccess = $00000000;\r\n EnvironmentPermissionAccess_Read = $00000001;\r\n EnvironmentPermissionAccess_Write = $00000002;\r\n EnvironmentPermissionAccess_AllAccess = $00000003;\r\n\r\n// Constants for enum FileDialogPermissionAccess\r\ntype\r\n FileDialogPermissionAccess = TOleEnum;\r\nconst\r\n FileDialogPermissionAccess_None = $00000000;\r\n FileDialogPermissionAccess_Open = $00000001;\r\n FileDialogPermissionAccess_Save = $00000002;\r\n FileDialogPermissionAccess_OpenSave = $00000003;\r\n\r\n// Constants for enum FileIOPermissionAccess\r\ntype\r\n FileIOPermissionAccess = TOleEnum;\r\nconst\r\n FileIOPermissionAccess_NoAccess = $00000000;\r\n FileIOPermissionAccess_Read = $00000001;\r\n FileIOPermissionAccess_Write = $00000002;\r\n FileIOPermissionAccess_Append = $00000004;\r\n FileIOPermissionAccess_PathDiscovery = $00000008;\r\n FileIOPermissionAccess_AllAccess = $0000000F;\r\n\r\n// Constants for enum IsolatedStorageContainment\r\ntype\r\n IsolatedStorageContainment = TOleEnum;\r\nconst\r\n IsolatedStorageContainment_None = $00000000;\r\n IsolatedStorageContainment_DomainIsolationByUser = $00000010;\r\n IsolatedStorageContainment_AssemblyIsolationByUser = $00000020;\r\n IsolatedStorageContainment_DomainIsolationByRoamingUser = $00000050;\r\n IsolatedStorageContainment_AssemblyIsolationByRoamingUser = $00000060;\r\n IsolatedStorageContainment_AdministerIsolatedStorageByUser = $00000070;\r\n IsolatedStorageContainment_UnrestrictedIsolatedStorage = $000000F0;\r\n\r\n// Constants for enum PermissionState\r\ntype\r\n PermissionState = TOleEnum;\r\nconst\r\n PermissionState_Unrestricted = $00000001;\r\n PermissionState_None = $00000000;\r\n\r\n// Constants for enum SecurityAction\r\ntype\r\n SecurityAction = TOleEnum;\r\nconst\r\n SecurityAction_Demand = $00000002;\r\n SecurityAction_Assert = $00000003;\r\n SecurityAction_Deny = $00000004;\r\n SecurityAction_PermitOnly = $00000005;\r\n SecurityAction_LinkDemand = $00000006;\r\n SecurityAction_InheritanceDemand = $00000007;\r\n SecurityAction_RequestMinimum = $00000008;\r\n SecurityAction_RequestOptional = $00000009;\r\n SecurityAction_RequestRefuse = $0000000A;\r\n\r\n// Constants for enum ReflectionPermissionFlag\r\ntype\r\n ReflectionPermissionFlag = TOleEnum;\r\nconst\r\n ReflectionPermissionFlag_NoFlags = $00000000;\r\n ReflectionPermissionFlag_TypeInformation = $00000001;\r\n ReflectionPermissionFlag_MemberAccess = $00000002;\r\n ReflectionPermissionFlag_ReflectionEmit = $00000004;\r\n ReflectionPermissionFlag_AllFlags = $00000007;\r\n\r\n// Constants for enum RegistryPermissionAccess\r\ntype\r\n RegistryPermissionAccess = TOleEnum;\r\nconst\r\n RegistryPermissionAccess_NoAccess = $00000000;\r\n RegistryPermissionAccess_Read = $00000001;\r\n RegistryPermissionAccess_Write = $00000002;\r\n RegistryPermissionAccess_Create = $00000004;\r\n RegistryPermissionAccess_AllAccess = $00000007;\r\n\r\n// Constants for enum SecurityPermissionFlag\r\ntype\r\n SecurityPermissionFlag = TOleEnum;\r\nconst\r\n SecurityPermissionFlag_NoFlags = $00000000;\r\n SecurityPermissionFlag_Assertion = $00000001;\r\n SecurityPermissionFlag_UnmanagedCode = $00000002;\r\n SecurityPermissionFlag_SkipVerification = $00000004;\r\n SecurityPermissionFlag_Execution = $00000008;\r\n SecurityPermissionFlag_ControlThread = $00000010;\r\n SecurityPermissionFlag_ControlEvidence = $00000020;\r\n SecurityPermissionFlag_ControlPolicy = $00000040;\r\n SecurityPermissionFlag_SerializationFormatter = $00000080;\r\n SecurityPermissionFlag_ControlDomainPolicy = $00000100;\r\n SecurityPermissionFlag_ControlPrincipal = $00000200;\r\n SecurityPermissionFlag_ControlAppDomain = $00000400;\r\n SecurityPermissionFlag_RemotingConfiguration = $00000800;\r\n SecurityPermissionFlag_Infrastructure = $00001000;\r\n SecurityPermissionFlag_BindingRedirects = $00002000;\r\n SecurityPermissionFlag_AllFlags = $00003FFF;\r\n\r\n// Constants for enum UIPermissionWindow\r\ntype\r\n UIPermissionWindow = TOleEnum;\r\nconst\r\n UIPermissionWindow_NoWindows = $00000000;\r\n UIPermissionWindow_SafeSubWindows = $00000001;\r\n UIPermissionWindow_SafeTopLevelWindows = $00000002;\r\n UIPermissionWindow_AllWindows = $00000003;\r\n\r\n// Constants for enum UIPermissionClipboard\r\ntype\r\n UIPermissionClipboard = TOleEnum;\r\nconst\r\n UIPermissionClipboard_NoClipboard = $00000000;\r\n UIPermissionClipboard_OwnClipboard = $00000001;\r\n UIPermissionClipboard_AllClipboard = $00000002;\r\n\r\n// Constants for enum PolicyLevelType\r\ntype\r\n PolicyLevelType = TOleEnum;\r\nconst\r\n PolicyLevelType_User = $00000000;\r\n PolicyLevelType_Machine = $00000001;\r\n PolicyLevelType_Enterprise = $00000002;\r\n PolicyLevelType_AppDomain = $00000003;\r\n\r\n// Constants for enum SecurityZone\r\ntype\r\n SecurityZone = TOleEnum;\r\nconst\r\n SecurityZone_MyComputer = $00000000;\r\n SecurityZone_Intranet = $00000001;\r\n SecurityZone_Trusted = $00000002;\r\n SecurityZone_Internet = $00000003;\r\n SecurityZone_Untrusted = $00000004;\r\n SecurityZone_NoZone = $FFFFFFFF;\r\n\r\n// Constants for enum WellKnownObjectMode\r\ntype\r\n WellKnownObjectMode = TOleEnum;\r\nconst\r\n WellKnownObjectMode_Singleton = $00000001;\r\n WellKnownObjectMode_SingleCall = $00000002;\r\n\r\n// Constants for enum ActivatorLevel\r\ntype\r\n ActivatorLevel = TOleEnum;\r\nconst\r\n ActivatorLevel_Construction = $00000004;\r\n ActivatorLevel_Context = $00000008;\r\n ActivatorLevel_AppDomain = $0000000C;\r\n ActivatorLevel_Process = $00000010;\r\n ActivatorLevel_Machine = $00000014;\r\n\r\n// Constants for enum ServerProcessing\r\ntype\r\n ServerProcessing = TOleEnum;\r\nconst\r\n ServerProcessing_Complete = $00000000;\r\n ServerProcessing_OneWay = $00000001;\r\n ServerProcessing_Async = $00000002;\r\n\r\n// Constants for enum LeaseState\r\ntype\r\n LeaseState = TOleEnum;\r\nconst\r\n LeaseState_Null = $00000000;\r\n LeaseState_Initial = $00000001;\r\n LeaseState_Active = $00000002;\r\n LeaseState_Renewing = $00000003;\r\n LeaseState_Expired = $00000004;\r\n\r\n// Constants for enum SoapOption\r\ntype\r\n SoapOption = TOleEnum;\r\nconst\r\n SoapOption_None = $00000000;\r\n SoapOption_AlwaysIncludeTypes = $00000001;\r\n SoapOption_XsdString = $00000002;\r\n SoapOption_EmbedAll = $00000004;\r\n SoapOption_Option1 = $00000008;\r\n SoapOption_Option2 = $00000010;\r\n\r\n// Constants for enum XmlFieldOrderOption\r\ntype\r\n XmlFieldOrderOption = TOleEnum;\r\nconst\r\n XmlFieldOrderOption_All = $00000000;\r\n XmlFieldOrderOption_Sequence = $00000001;\r\n XmlFieldOrderOption_Choice = $00000002;\r\n\r\n// Constants for enum IsolatedStorageScope\r\ntype\r\n IsolatedStorageScope = TOleEnum;\r\nconst\r\n IsolatedStorageScope_None = $00000000;\r\n IsolatedStorageScope_User = $00000001;\r\n IsolatedStorageScope_Domain = $00000002;\r\n IsolatedStorageScope_Assembly = $00000004;\r\n IsolatedStorageScope_Roaming = $00000008;\r\n\r\n// Constants for enum FormatterTypeStyle\r\ntype\r\n FormatterTypeStyle = TOleEnum;\r\nconst\r\n FormatterTypeStyle_TypesWhenNeeded = $00000000;\r\n FormatterTypeStyle_TypesAlways = $00000001;\r\n FormatterTypeStyle_XsdString = $00000002;\r\n\r\n// Constants for enum FormatterAssemblyStyle\r\ntype\r\n FormatterAssemblyStyle = TOleEnum;\r\nconst\r\n FormatterAssemblyStyle_Simple = $00000000;\r\n FormatterAssemblyStyle_Full = $00000001;\r\n\r\n// Constants for enum TypeFilterLevel\r\ntype\r\n TypeFilterLevel = TOleEnum;\r\nconst\r\n TypeFilterLevel_Low = $00000002;\r\n TypeFilterLevel_Full = $00000003;\r\n\r\n// Constants for enum AssemblyBuilderAccess\r\ntype\r\n AssemblyBuilderAccess = TOleEnum;\r\nconst\r\n AssemblyBuilderAccess_Run = $00000001;\r\n AssemblyBuilderAccess_Save = $00000002;\r\n AssemblyBuilderAccess_RunAndSave = $00000003;\r\n\r\n// Constants for enum PEFileKinds\r\ntype\r\n PEFileKinds = TOleEnum;\r\nconst\r\n PEFileKinds_Dll = $00000001;\r\n PEFileKinds_ConsoleApplication = $00000002;\r\n PEFileKinds_WindowApplication = $00000003;\r\n\r\n// Constants for enum OpCodeType\r\ntype\r\n OpCodeType = TOleEnum;\r\nconst\r\n OpCodeType_Annotation = $00000000;\r\n OpCodeType_Macro = $00000001;\r\n OpCodeType_Nternal = $00000002;\r\n OpCodeType_Objmodel = $00000003;\r\n OpCodeType_Prefix = $00000004;\r\n OpCodeType_Primitive = $00000005;\r\n\r\n// Constants for enum StackBehaviour\r\ntype\r\n StackBehaviour = TOleEnum;\r\nconst\r\n StackBehaviour_Pop0 = $00000000;\r\n StackBehaviour_Pop1 = $00000001;\r\n StackBehaviour_Pop1_pop1 = $00000002;\r\n StackBehaviour_Popi = $00000003;\r\n StackBehaviour_Popi_pop1 = $00000004;\r\n StackBehaviour_Popi_popi = $00000005;\r\n StackBehaviour_Popi_popi8 = $00000006;\r\n StackBehaviour_Popi_popi_popi = $00000007;\r\n StackBehaviour_Popi_popr4 = $00000008;\r\n StackBehaviour_Popi_popr8 = $00000009;\r\n StackBehaviour_Popref = $0000000A;\r\n StackBehaviour_Popref_pop1 = $0000000B;\r\n StackBehaviour_Popref_popi = $0000000C;\r\n StackBehaviour_Popref_popi_popi = $0000000D;\r\n StackBehaviour_Popref_popi_popi8 = $0000000E;\r\n StackBehaviour_Popref_popi_popr4 = $0000000F;\r\n StackBehaviour_Popref_popi_popr8 = $00000010;\r\n StackBehaviour_Popref_popi_popref = $00000011;\r\n StackBehaviour_Push0 = $00000012;\r\n StackBehaviour_Push1 = $00000013;\r\n StackBehaviour_Push1_push1 = $00000014;\r\n StackBehaviour_Pushi = $00000015;\r\n StackBehaviour_Pushi8 = $00000016;\r\n StackBehaviour_Pushr4 = $00000017;\r\n StackBehaviour_Pushr8 = $00000018;\r\n StackBehaviour_Pushref = $00000019;\r\n StackBehaviour_Varpop = $0000001A;\r\n StackBehaviour_Varpush = $0000001B;\r\n\r\n// Constants for enum OperandType\r\ntype\r\n OperandType = TOleEnum;\r\nconst\r\n OperandType_InlineBrTarget = $00000000;\r\n OperandType_InlineField = $00000001;\r\n OperandType_InlineI = $00000002;\r\n OperandType_InlineI8 = $00000003;\r\n OperandType_InlineMethod = $00000004;\r\n OperandType_InlineNone = $00000005;\r\n OperandType_InlinePhi = $00000006;\r\n OperandType_InlineR = $00000007;\r\n OperandType_InlineSig = $00000009;\r\n OperandType_InlineString = $0000000A;\r\n OperandType_InlineSwitch = $0000000B;\r\n OperandType_InlineTok = $0000000C;\r\n OperandType_InlineType = $0000000D;\r\n OperandType_InlineVar = $0000000E;\r\n OperandType_ShortInlineBrTarget = $0000000F;\r\n OperandType_ShortInlineI = $00000010;\r\n OperandType_ShortInlineR = $00000011;\r\n OperandType_ShortInlineVar = $00000012;\r\n\r\n// Constants for enum FlowControl\r\ntype\r\n FlowControl = TOleEnum;\r\nconst\r\n FlowControl_Branch = $00000000;\r\n FlowControl_Break = $00000001;\r\n FlowControl_Call = $00000002;\r\n FlowControl_Cond_Branch = $00000003;\r\n FlowControl_Meta = $00000004;\r\n FlowControl_Next = $00000005;\r\n FlowControl_Phi = $00000006;\r\n FlowControl_Return = $00000007;\r\n FlowControl_Throw = $00000008;\r\n\r\n// Constants for enum PackingSize\r\ntype\r\n PackingSize = TOleEnum;\r\nconst\r\n PackingSize_Unspecified = $00000000;\r\n PackingSize_Size1 = $00000001;\r\n PackingSize_Size2 = $00000002;\r\n PackingSize_Size4 = $00000004;\r\n PackingSize_Size8 = $00000008;\r\n PackingSize_Size16 = $00000010;\r\n\r\n// Constants for enum AssemblyHashAlgorithm\r\ntype\r\n AssemblyHashAlgorithm = TOleEnum;\r\nconst\r\n AssemblyHashAlgorithm_None = $00000000;\r\n AssemblyHashAlgorithm_MD5 = $00008003;\r\n AssemblyHashAlgorithm_SHA1 = $00008004;\r\n\r\n// Constants for enum AssemblyVersionCompatibility\r\ntype\r\n AssemblyVersionCompatibility = TOleEnum;\r\nconst\r\n AssemblyVersionCompatibility_SameMachine = $00000001;\r\n AssemblyVersionCompatibility_SameProcess = $00000002;\r\n AssemblyVersionCompatibility_SameDomain = $00000003;\r\n\r\ntype\r\n\r\n// *********************************************************************//\r\n// Forward declaration of types defined in TypeLibrary \r\n// *********************************************************************//\r\n _Object = interface;\r\n _ObjectDisp = dispinterface;\r\n ICloneable = interface;\r\n ICloneableDisp = dispinterface;\r\n IEnumerable = interface;\r\n IEnumerableDisp = dispinterface;\r\n ICollection = interface;\r\n ICollectionDisp = dispinterface;\r\n IList = interface;\r\n IListDisp = dispinterface;\r\n _Array = interface;\r\n _ArrayDisp = dispinterface;\r\n IEnumerator = interface;\r\n IEnumeratorDisp = dispinterface;\r\n IComparable = interface;\r\n IComparableDisp = dispinterface;\r\n IConvertible = interface;\r\n IConvertibleDisp = dispinterface;\r\n _String = interface;\r\n _StringDisp = dispinterface;\r\n _StringBuilder = interface;\r\n _StringBuilderDisp = dispinterface;\r\n ISerializable = interface;\r\n ISerializableDisp = dispinterface;\r\n _Exception = interface;\r\n _ExceptionDisp = dispinterface;\r\n _ValueType = interface;\r\n _ValueTypeDisp = dispinterface;\r\n IFormattable = interface;\r\n IFormattableDisp = dispinterface;\r\n _SystemException = interface;\r\n _SystemExceptionDisp = dispinterface;\r\n _OutOfMemoryException = interface;\r\n _OutOfMemoryExceptionDisp = dispinterface;\r\n _StackOverflowException = interface;\r\n _StackOverflowExceptionDisp = dispinterface;\r\n _ExecutionEngineException = interface;\r\n _ExecutionEngineExceptionDisp = dispinterface;\r\n _Delegate = interface;\r\n _DelegateDisp = dispinterface;\r\n _MulticastDelegate = interface;\r\n _MulticastDelegateDisp = dispinterface;\r\n _Enum = interface;\r\n _EnumDisp = dispinterface;\r\n _MemberAccessException = interface;\r\n _MemberAccessExceptionDisp = dispinterface;\r\n _Activator = interface;\r\n _ActivatorDisp = dispinterface;\r\n _ApplicationException = interface;\r\n _ApplicationExceptionDisp = dispinterface;\r\n _EventArgs = interface;\r\n _EventArgsDisp = dispinterface;\r\n _ResolveEventArgs = interface;\r\n _ResolveEventArgsDisp = dispinterface;\r\n _AssemblyLoadEventArgs = interface;\r\n _AssemblyLoadEventArgsDisp = dispinterface;\r\n _ResolveEventHandler = interface;\r\n _ResolveEventHandlerDisp = dispinterface;\r\n _AssemblyLoadEventHandler = interface;\r\n _AssemblyLoadEventHandlerDisp = dispinterface;\r\n _MarshalByRefObject = interface;\r\n _MarshalByRefObjectDisp = dispinterface;\r\n _AppDomain = interface;\r\n _AppDomainDisp = dispinterface;\r\n IEvidenceFactory = interface;\r\n IEvidenceFactoryDisp = dispinterface;\r\n _CrossAppDomainDelegate = interface;\r\n _CrossAppDomainDelegateDisp = dispinterface;\r\n IAppDomainSetup = interface;\r\n _Attribute = interface;\r\n _AttributeDisp = dispinterface;\r\n _LoaderOptimizationAttribute = interface;\r\n _LoaderOptimizationAttributeDisp = dispinterface;\r\n _AppDomainUnloadedException = interface;\r\n _AppDomainUnloadedExceptionDisp = dispinterface;\r\n _ArgumentException = interface;\r\n _ArgumentExceptionDisp = dispinterface;\r\n _ArgumentNullException = interface;\r\n _ArgumentNullExceptionDisp = dispinterface;\r\n _ArgumentOutOfRangeException = interface;\r\n _ArgumentOutOfRangeExceptionDisp = dispinterface;\r\n _ArithmeticException = interface;\r\n _ArithmeticExceptionDisp = dispinterface;\r\n _ArrayTypeMismatchException = interface;\r\n _ArrayTypeMismatchExceptionDisp = dispinterface;\r\n _AsyncCallback = interface;\r\n _AsyncCallbackDisp = dispinterface;\r\n _AttributeUsageAttribute = interface;\r\n _AttributeUsageAttributeDisp = dispinterface;\r\n _BadImageFormatException = interface;\r\n _BadImageFormatExceptionDisp = dispinterface;\r\n _BitConverter = interface;\r\n _BitConverterDisp = dispinterface;\r\n _Buffer = interface;\r\n _BufferDisp = dispinterface;\r\n _CannotUnloadAppDomainException = interface;\r\n _CannotUnloadAppDomainExceptionDisp = dispinterface;\r\n _CharEnumerator = interface;\r\n _CharEnumeratorDisp = dispinterface;\r\n _CLSCompliantAttribute = interface;\r\n _CLSCompliantAttributeDisp = dispinterface;\r\n _TypeUnloadedException = interface;\r\n _TypeUnloadedExceptionDisp = dispinterface;\r\n _Console = interface;\r\n _ConsoleDisp = dispinterface;\r\n _ContextMarshalException = interface;\r\n _ContextMarshalExceptionDisp = dispinterface;\r\n _Convert = interface;\r\n _ConvertDisp = dispinterface;\r\n _ContextBoundObject = interface;\r\n _ContextBoundObjectDisp = dispinterface;\r\n _ContextStaticAttribute = interface;\r\n _ContextStaticAttributeDisp = dispinterface;\r\n _TimeZone = interface;\r\n _TimeZoneDisp = dispinterface;\r\n _DBNull = interface;\r\n _DBNullDisp = dispinterface;\r\n _Binder = interface;\r\n _BinderDisp = dispinterface;\r\n IObjectReference = interface;\r\n IObjectReferenceDisp = dispinterface;\r\n _DivideByZeroException = interface;\r\n _DivideByZeroExceptionDisp = dispinterface;\r\n _DuplicateWaitObjectException = interface;\r\n _DuplicateWaitObjectExceptionDisp = dispinterface;\r\n _TypeLoadException = interface;\r\n _TypeLoadExceptionDisp = dispinterface;\r\n _EntryPointNotFoundException = interface;\r\n _EntryPointNotFoundExceptionDisp = dispinterface;\r\n _DllNotFoundException = interface;\r\n _DllNotFoundExceptionDisp = dispinterface;\r\n _Environment = interface;\r\n _EnvironmentDisp = dispinterface;\r\n _EventHandler = interface;\r\n _EventHandlerDisp = dispinterface;\r\n _FieldAccessException = interface;\r\n _FieldAccessExceptionDisp = dispinterface;\r\n _FlagsAttribute = interface;\r\n _FlagsAttributeDisp = dispinterface;\r\n _FormatException = interface;\r\n _FormatExceptionDisp = dispinterface;\r\n _GC = interface;\r\n _GCDisp = dispinterface;\r\n IAsyncResult = interface;\r\n IAsyncResultDisp = dispinterface;\r\n ICustomFormatter = interface;\r\n ICustomFormatterDisp = dispinterface;\r\n IDisposable = interface;\r\n IDisposableDisp = dispinterface;\r\n IFormatProvider = interface;\r\n IFormatProviderDisp = dispinterface;\r\n _IndexOutOfRangeException = interface;\r\n _IndexOutOfRangeExceptionDisp = dispinterface;\r\n _InvalidCastException = interface;\r\n _InvalidCastExceptionDisp = dispinterface;\r\n _InvalidOperationException = interface;\r\n _InvalidOperationExceptionDisp = dispinterface;\r\n _InvalidProgramException = interface;\r\n _InvalidProgramExceptionDisp = dispinterface;\r\n _LocalDataStoreSlot = interface;\r\n _LocalDataStoreSlotDisp = dispinterface;\r\n _Math = interface;\r\n _MathDisp = dispinterface;\r\n _MethodAccessException = interface;\r\n _MethodAccessExceptionDisp = dispinterface;\r\n _MissingMemberException = interface;\r\n _MissingMemberExceptionDisp = dispinterface;\r\n _MissingFieldException = interface;\r\n _MissingFieldExceptionDisp = dispinterface;\r\n _MissingMethodException = interface;\r\n _MissingMethodExceptionDisp = dispinterface;\r\n _MulticastNotSupportedException = interface;\r\n _MulticastNotSupportedExceptionDisp = dispinterface;\r\n _NonSerializedAttribute = interface;\r\n _NonSerializedAttributeDisp = dispinterface;\r\n _NotFiniteNumberException = interface;\r\n _NotFiniteNumberExceptionDisp = dispinterface;\r\n _NotImplementedException = interface;\r\n _NotImplementedExceptionDisp = dispinterface;\r\n _NotSupportedException = interface;\r\n _NotSupportedExceptionDisp = dispinterface;\r\n _NullReferenceException = interface;\r\n _NullReferenceExceptionDisp = dispinterface;\r\n _ObjectDisposedException = interface;\r\n _ObjectDisposedExceptionDisp = dispinterface;\r\n _ObsoleteAttribute = interface;\r\n _ObsoleteAttributeDisp = dispinterface;\r\n _OperatingSystem = interface;\r\n _OperatingSystemDisp = dispinterface;\r\n _OverflowException = interface;\r\n _OverflowExceptionDisp = dispinterface;\r\n _ParamArrayAttribute = interface;\r\n _ParamArrayAttributeDisp = dispinterface;\r\n _PlatformNotSupportedException = interface;\r\n _PlatformNotSupportedExceptionDisp = dispinterface;\r\n _Random = interface;\r\n _RandomDisp = dispinterface;\r\n _RankException = interface;\r\n _RankExceptionDisp = dispinterface;\r\n ICustomAttributeProvider = interface;\r\n ICustomAttributeProviderDisp = dispinterface;\r\n _MemberInfo = interface;\r\n _MemberInfoDisp = dispinterface;\r\n IReflect = interface;\r\n IReflectDisp = dispinterface;\r\n _Type = interface;\r\n _TypeDisp = dispinterface;\r\n _SerializableAttribute = interface;\r\n _SerializableAttributeDisp = dispinterface;\r\n _TypeInitializationException = interface;\r\n _TypeInitializationExceptionDisp = dispinterface;\r\n _UnauthorizedAccessException = interface;\r\n _UnauthorizedAccessExceptionDisp = dispinterface;\r\n _UnhandledExceptionEventArgs = interface;\r\n _UnhandledExceptionEventArgsDisp = dispinterface;\r\n _UnhandledExceptionEventHandler = interface;\r\n _UnhandledExceptionEventHandlerDisp = dispinterface;\r\n _Version = interface;\r\n _VersionDisp = dispinterface;\r\n _WeakReference = interface;\r\n _WeakReferenceDisp = dispinterface;\r\n _WaitHandle = interface;\r\n _WaitHandleDisp = dispinterface;\r\n _AutoResetEvent = interface;\r\n _AutoResetEventDisp = dispinterface;\r\n _CompressedStack = interface;\r\n _CompressedStackDisp = dispinterface;\r\n _Interlocked = interface;\r\n _InterlockedDisp = dispinterface;\r\n IObjectHandle = interface;\r\n _ManualResetEvent = interface;\r\n _ManualResetEventDisp = dispinterface;\r\n _Monitor = interface;\r\n _MonitorDisp = dispinterface;\r\n _Mutex = interface;\r\n _MutexDisp = dispinterface;\r\n _Overlapped = interface;\r\n _OverlappedDisp = dispinterface;\r\n _ReaderWriterLock = interface;\r\n _ReaderWriterLockDisp = dispinterface;\r\n _SynchronizationLockException = interface;\r\n _SynchronizationLockExceptionDisp = dispinterface;\r\n _Thread = interface;\r\n _ThreadDisp = dispinterface;\r\n _ThreadAbortException = interface;\r\n _ThreadAbortExceptionDisp = dispinterface;\r\n _STAThreadAttribute = interface;\r\n _STAThreadAttributeDisp = dispinterface;\r\n _MTAThreadAttribute = interface;\r\n _MTAThreadAttributeDisp = dispinterface;\r\n _ThreadInterruptedException = interface;\r\n _ThreadInterruptedExceptionDisp = dispinterface;\r\n _RegisteredWaitHandle = interface;\r\n _RegisteredWaitHandleDisp = dispinterface;\r\n _WaitCallback = interface;\r\n _WaitCallbackDisp = dispinterface;\r\n _WaitOrTimerCallback = interface;\r\n _WaitOrTimerCallbackDisp = dispinterface;\r\n _IOCompletionCallback = interface;\r\n _IOCompletionCallbackDisp = dispinterface;\r\n _ThreadPool = interface;\r\n _ThreadPoolDisp = dispinterface;\r\n _ThreadStart = interface;\r\n _ThreadStartDisp = dispinterface;\r\n _ThreadStateException = interface;\r\n _ThreadStateExceptionDisp = dispinterface;\r\n _ThreadStaticAttribute = interface;\r\n _ThreadStaticAttributeDisp = dispinterface;\r\n _Timeout = interface;\r\n _TimeoutDisp = dispinterface;\r\n _TimerCallback = interface;\r\n _TimerCallbackDisp = dispinterface;\r\n _Timer = interface;\r\n _TimerDisp = dispinterface;\r\n _ArrayList = interface;\r\n _ArrayListDisp = dispinterface;\r\n _BitArray = interface;\r\n _BitArrayDisp = dispinterface;\r\n IComparer = interface;\r\n IComparerDisp = dispinterface;\r\n _CaseInsensitiveComparer = interface;\r\n _CaseInsensitiveComparerDisp = dispinterface;\r\n IHashCodeProvider = interface;\r\n IHashCodeProviderDisp = dispinterface;\r\n _CaseInsensitiveHashCodeProvider = interface;\r\n _CaseInsensitiveHashCodeProviderDisp = dispinterface;\r\n _CollectionBase = interface;\r\n _CollectionBaseDisp = dispinterface;\r\n _Comparer = interface;\r\n _ComparerDisp = dispinterface;\r\n IDictionary = interface;\r\n IDictionaryDisp = dispinterface;\r\n _DictionaryBase = interface;\r\n _DictionaryBaseDisp = dispinterface;\r\n IDeserializationCallback = interface;\r\n IDeserializationCallbackDisp = dispinterface;\r\n _Hashtable = interface;\r\n _HashtableDisp = dispinterface;\r\n IDictionaryEnumerator = interface;\r\n IDictionaryEnumeratorDisp = dispinterface;\r\n _Queue = interface;\r\n _QueueDisp = dispinterface;\r\n _ReadOnlyCollectionBase = interface;\r\n _ReadOnlyCollectionBaseDisp = dispinterface;\r\n _SortedList = interface;\r\n _SortedListDisp = dispinterface;\r\n _Stack = interface;\r\n _StackDisp = dispinterface;\r\n _ConditionalAttribute = interface;\r\n _ConditionalAttributeDisp = dispinterface;\r\n _Debugger = interface;\r\n _DebuggerDisp = dispinterface;\r\n _DebuggerStepThroughAttribute = interface;\r\n _DebuggerStepThroughAttributeDisp = dispinterface;\r\n _DebuggerHiddenAttribute = interface;\r\n _DebuggerHiddenAttributeDisp = dispinterface;\r\n _DebuggableAttribute = interface;\r\n _DebuggableAttributeDisp = dispinterface;\r\n _StackTrace = interface;\r\n _StackTraceDisp = dispinterface;\r\n _StackFrame = interface;\r\n _StackFrameDisp = dispinterface;\r\n ISymbolBinder = interface;\r\n ISymbolBinderDisp = dispinterface;\r\n ISymbolDocument = interface;\r\n ISymbolDocumentDisp = dispinterface;\r\n ISymbolDocumentWriter = interface;\r\n ISymbolDocumentWriterDisp = dispinterface;\r\n ISymbolMethod = interface;\r\n ISymbolMethodDisp = dispinterface;\r\n ISymbolNamespace = interface;\r\n ISymbolNamespaceDisp = dispinterface;\r\n ISymbolReader = interface;\r\n ISymbolReaderDisp = dispinterface;\r\n ISymbolScope = interface;\r\n ISymbolScopeDisp = dispinterface;\r\n ISymbolVariable = interface;\r\n ISymbolVariableDisp = dispinterface;\r\n ISymbolWriter = interface;\r\n ISymbolWriterDisp = dispinterface;\r\n _SymDocumentType = interface;\r\n _SymDocumentTypeDisp = dispinterface;\r\n _SymLanguageType = interface;\r\n _SymLanguageTypeDisp = dispinterface;\r\n _SymLanguageVendor = interface;\r\n _SymLanguageVendorDisp = dispinterface;\r\n _AmbiguousMatchException = interface;\r\n _AmbiguousMatchExceptionDisp = dispinterface;\r\n _ModuleResolveEventHandler = interface;\r\n _ModuleResolveEventHandlerDisp = dispinterface;\r\n _Assembly = interface;\r\n _AssemblyDisp = dispinterface;\r\n _AssemblyCultureAttribute = interface;\r\n _AssemblyCultureAttributeDisp = dispinterface;\r\n _AssemblyVersionAttribute = interface;\r\n _AssemblyVersionAttributeDisp = dispinterface;\r\n _AssemblyKeyFileAttribute = interface;\r\n _AssemblyKeyFileAttributeDisp = dispinterface;\r\n _AssemblyKeyNameAttribute = interface;\r\n _AssemblyKeyNameAttributeDisp = dispinterface;\r\n _AssemblyDelaySignAttribute = interface;\r\n _AssemblyDelaySignAttributeDisp = dispinterface;\r\n _AssemblyAlgorithmIdAttribute = interface;\r\n _AssemblyAlgorithmIdAttributeDisp = dispinterface;\r\n _AssemblyFlagsAttribute = interface;\r\n _AssemblyFlagsAttributeDisp = dispinterface;\r\n _AssemblyFileVersionAttribute = interface;\r\n _AssemblyFileVersionAttributeDisp = dispinterface;\r\n _AssemblyName = interface;\r\n _AssemblyNameDisp = dispinterface;\r\n _AssemblyNameProxy = interface;\r\n _AssemblyNameProxyDisp = dispinterface;\r\n _AssemblyCopyrightAttribute = interface;\r\n _AssemblyCopyrightAttributeDisp = dispinterface;\r\n _AssemblyTrademarkAttribute = interface;\r\n _AssemblyTrademarkAttributeDisp = dispinterface;\r\n _AssemblyProductAttribute = interface;\r\n _AssemblyProductAttributeDisp = dispinterface;\r\n _AssemblyCompanyAttribute = interface;\r\n _AssemblyCompanyAttributeDisp = dispinterface;\r\n _AssemblyDescriptionAttribute = interface;\r\n _AssemblyDescriptionAttributeDisp = dispinterface;\r\n _AssemblyTitleAttribute = interface;\r\n _AssemblyTitleAttributeDisp = dispinterface;\r\n _AssemblyConfigurationAttribute = interface;\r\n _AssemblyConfigurationAttributeDisp = dispinterface;\r\n _AssemblyDefaultAliasAttribute = interface;\r\n _AssemblyDefaultAliasAttributeDisp = dispinterface;\r\n _AssemblyInformationalVersionAttribute = interface;\r\n _AssemblyInformationalVersionAttributeDisp = dispinterface;\r\n _CustomAttributeFormatException = interface;\r\n _CustomAttributeFormatExceptionDisp = dispinterface;\r\n _MethodBase = interface;\r\n _MethodBaseDisp = dispinterface;\r\n _ConstructorInfo = interface;\r\n _ConstructorInfoDisp = dispinterface;\r\n _DefaultMemberAttribute = interface;\r\n _DefaultMemberAttributeDisp = dispinterface;\r\n _EventInfo = interface;\r\n _EventInfoDisp = dispinterface;\r\n _FieldInfo = interface;\r\n _FieldInfoDisp = dispinterface;\r\n _InvalidFilterCriteriaException = interface;\r\n _InvalidFilterCriteriaExceptionDisp = dispinterface;\r\n _ManifestResourceInfo = interface;\r\n _ManifestResourceInfoDisp = dispinterface;\r\n _MemberFilter = interface;\r\n _MemberFilterDisp = dispinterface;\r\n _MethodInfo = interface;\r\n _MethodInfoDisp = dispinterface;\r\n _Missing = interface;\r\n _MissingDisp = dispinterface;\r\n _Module = interface;\r\n _ModuleDisp = dispinterface;\r\n _ParameterInfo = interface;\r\n _ParameterInfoDisp = dispinterface;\r\n _Pointer = interface;\r\n _PointerDisp = dispinterface;\r\n _PropertyInfo = interface;\r\n _PropertyInfoDisp = dispinterface;\r\n _ReflectionTypeLoadException = interface;\r\n _ReflectionTypeLoadExceptionDisp = dispinterface;\r\n _StrongNameKeyPair = interface;\r\n _StrongNameKeyPairDisp = dispinterface;\r\n _TargetException = interface;\r\n _TargetExceptionDisp = dispinterface;\r\n _TargetInvocationException = interface;\r\n _TargetInvocationExceptionDisp = dispinterface;\r\n _TargetParameterCountException = interface;\r\n _TargetParameterCountExceptionDisp = dispinterface;\r\n _TypeDelegator = interface;\r\n _TypeDelegatorDisp = dispinterface;\r\n _TypeFilter = interface;\r\n _TypeFilterDisp = dispinterface;\r\n _UnmanagedMarshal = interface;\r\n _UnmanagedMarshalDisp = dispinterface;\r\n IFormatter = interface;\r\n IFormatterDisp = dispinterface;\r\n _Formatter = interface;\r\n _FormatterDisp = dispinterface;\r\n IFormatterConverter = interface;\r\n IFormatterConverterDisp = dispinterface;\r\n _FormatterConverter = interface;\r\n _FormatterConverterDisp = dispinterface;\r\n _FormatterServices = interface;\r\n _FormatterServicesDisp = dispinterface;\r\n ISerializationSurrogate = interface;\r\n ISerializationSurrogateDisp = dispinterface;\r\n ISurrogateSelector = interface;\r\n ISurrogateSelectorDisp = dispinterface;\r\n _ObjectIDGenerator = interface;\r\n _ObjectIDGeneratorDisp = dispinterface;\r\n _ObjectManager = interface;\r\n _ObjectManagerDisp = dispinterface;\r\n _SerializationBinder = interface;\r\n _SerializationBinderDisp = dispinterface;\r\n _SerializationInfo = interface;\r\n _SerializationInfoDisp = dispinterface;\r\n _SerializationInfoEnumerator = interface;\r\n _SerializationInfoEnumeratorDisp = dispinterface;\r\n _SerializationException = interface;\r\n _SerializationExceptionDisp = dispinterface;\r\n _SurrogateSelector = interface;\r\n _SurrogateSelectorDisp = dispinterface;\r\n _Calendar = interface;\r\n _CalendarDisp = dispinterface;\r\n _CompareInfo = interface;\r\n _CompareInfoDisp = dispinterface;\r\n _CultureInfo = interface;\r\n _CultureInfoDisp = dispinterface;\r\n _DateTimeFormatInfo = interface;\r\n _DateTimeFormatInfoDisp = dispinterface;\r\n _DaylightTime = interface;\r\n _DaylightTimeDisp = dispinterface;\r\n _GregorianCalendar = interface;\r\n _GregorianCalendarDisp = dispinterface;\r\n _HebrewCalendar = interface;\r\n _HebrewCalendarDisp = dispinterface;\r\n _HijriCalendar = interface;\r\n _HijriCalendarDisp = dispinterface;\r\n _JapaneseCalendar = interface;\r\n _JapaneseCalendarDisp = dispinterface;\r\n _JulianCalendar = interface;\r\n _JulianCalendarDisp = dispinterface;\r\n _KoreanCalendar = interface;\r\n _KoreanCalendarDisp = dispinterface;\r\n _RegionInfo = interface;\r\n _RegionInfoDisp = dispinterface;\r\n _SortKey = interface;\r\n _SortKeyDisp = dispinterface;\r\n _StringInfo = interface;\r\n _StringInfoDisp = dispinterface;\r\n _TaiwanCalendar = interface;\r\n _TaiwanCalendarDisp = dispinterface;\r\n _TextElementEnumerator = interface;\r\n _TextElementEnumeratorDisp = dispinterface;\r\n _TextInfo = interface;\r\n _TextInfoDisp = dispinterface;\r\n _ThaiBuddhistCalendar = interface;\r\n _ThaiBuddhistCalendarDisp = dispinterface;\r\n _NumberFormatInfo = interface;\r\n _NumberFormatInfoDisp = dispinterface;\r\n _Encoding = interface;\r\n _EncodingDisp = dispinterface;\r\n _System_Text_Decoder = interface;\r\n _System_Text_DecoderDisp = dispinterface;\r\n _System_Text_Encoder = interface;\r\n _System_Text_EncoderDisp = dispinterface;\r\n _ASCIIEncoding = interface;\r\n _ASCIIEncodingDisp = dispinterface;\r\n _UnicodeEncoding = interface;\r\n _UnicodeEncodingDisp = dispinterface;\r\n _UTF7Encoding = interface;\r\n _UTF7EncodingDisp = dispinterface;\r\n _UTF8Encoding = interface;\r\n _UTF8EncodingDisp = dispinterface;\r\n IResourceReader = interface;\r\n IResourceReaderDisp = dispinterface;\r\n IResourceWriter = interface;\r\n IResourceWriterDisp = dispinterface;\r\n _MissingManifestResourceException = interface;\r\n _MissingManifestResourceExceptionDisp = dispinterface;\r\n _NeutralResourcesLanguageAttribute = interface;\r\n _NeutralResourcesLanguageAttributeDisp = dispinterface;\r\n _ResourceManager = interface;\r\n _ResourceManagerDisp = dispinterface;\r\n _ResourceReader = interface;\r\n _ResourceReaderDisp = dispinterface;\r\n _ResourceSet = interface;\r\n _ResourceSetDisp = dispinterface;\r\n _ResourceWriter = interface;\r\n _ResourceWriterDisp = dispinterface;\r\n _SatelliteContractVersionAttribute = interface;\r\n _SatelliteContractVersionAttributeDisp = dispinterface;\r\n _Registry = interface;\r\n _RegistryDisp = dispinterface;\r\n _RegistryKey = interface;\r\n _RegistryKeyDisp = dispinterface;\r\n _X509Certificate = interface;\r\n _X509CertificateDisp = dispinterface;\r\n _AsymmetricAlgorithm = interface;\r\n _AsymmetricAlgorithmDisp = dispinterface;\r\n _AsymmetricKeyExchangeDeformatter = interface;\r\n _AsymmetricKeyExchangeDeformatterDisp = dispinterface;\r\n _AsymmetricKeyExchangeFormatter = interface;\r\n _AsymmetricKeyExchangeFormatterDisp = dispinterface;\r\n _AsymmetricSignatureDeformatter = interface;\r\n _AsymmetricSignatureDeformatterDisp = dispinterface;\r\n _AsymmetricSignatureFormatter = interface;\r\n _AsymmetricSignatureFormatterDisp = dispinterface;\r\n ICryptoTransform = interface;\r\n ICryptoTransformDisp = dispinterface;\r\n _ToBase64Transform = interface;\r\n _ToBase64TransformDisp = dispinterface;\r\n _FromBase64Transform = interface;\r\n _FromBase64TransformDisp = dispinterface;\r\n _KeySizes = interface;\r\n _KeySizesDisp = dispinterface;\r\n _CryptographicException = interface;\r\n _CryptographicExceptionDisp = dispinterface;\r\n _CryptographicUnexpectedOperationException = interface;\r\n _CryptographicUnexpectedOperationExceptionDisp = dispinterface;\r\n _CryptoAPITransform = interface;\r\n _CryptoAPITransformDisp = dispinterface;\r\n _CspParameters = interface;\r\n _CspParametersDisp = dispinterface;\r\n _CryptoConfig = interface;\r\n _CryptoConfigDisp = dispinterface;\r\n _Stream = interface;\r\n _StreamDisp = dispinterface;\r\n _CryptoStream = interface;\r\n _CryptoStreamDisp = dispinterface;\r\n _SymmetricAlgorithm = interface;\r\n _SymmetricAlgorithmDisp = dispinterface;\r\n _DES = interface;\r\n _DESDisp = dispinterface;\r\n _DESCryptoServiceProvider = interface;\r\n _DESCryptoServiceProviderDisp = dispinterface;\r\n _DeriveBytes = interface;\r\n _DeriveBytesDisp = dispinterface;\r\n _DSA = interface;\r\n _DSADisp = dispinterface;\r\n _DSACryptoServiceProvider = interface;\r\n _DSACryptoServiceProviderDisp = dispinterface;\r\n _DSASignatureDeformatter = interface;\r\n _DSASignatureDeformatterDisp = dispinterface;\r\n _DSASignatureFormatter = interface;\r\n _DSASignatureFormatterDisp = dispinterface;\r\n _HashAlgorithm = interface;\r\n _HashAlgorithmDisp = dispinterface;\r\n _KeyedHashAlgorithm = interface;\r\n _KeyedHashAlgorithmDisp = dispinterface;\r\n _HMACSHA1 = interface;\r\n _HMACSHA1Disp = dispinterface;\r\n _MACTripleDES = interface;\r\n _MACTripleDESDisp = dispinterface;\r\n _MD5 = interface;\r\n _MD5Disp = dispinterface;\r\n _MD5CryptoServiceProvider = interface;\r\n _MD5CryptoServiceProviderDisp = dispinterface;\r\n _MaskGenerationMethod = interface;\r\n _MaskGenerationMethodDisp = dispinterface;\r\n _PasswordDeriveBytes = interface;\r\n _PasswordDeriveBytesDisp = dispinterface;\r\n _PKCS1MaskGenerationMethod = interface;\r\n _PKCS1MaskGenerationMethodDisp = dispinterface;\r\n _RC2 = interface;\r\n _RC2Disp = dispinterface;\r\n _RC2CryptoServiceProvider = interface;\r\n _RC2CryptoServiceProviderDisp = dispinterface;\r\n _RandomNumberGenerator = interface;\r\n _RandomNumberGeneratorDisp = dispinterface;\r\n _RNGCryptoServiceProvider = interface;\r\n _RNGCryptoServiceProviderDisp = dispinterface;\r\n _RSA = interface;\r\n _RSADisp = dispinterface;\r\n _RSACryptoServiceProvider = interface;\r\n _RSACryptoServiceProviderDisp = dispinterface;\r\n _RSAOAEPKeyExchangeDeformatter = interface;\r\n _RSAOAEPKeyExchangeDeformatterDisp = dispinterface;\r\n _RSAOAEPKeyExchangeFormatter = interface;\r\n _RSAOAEPKeyExchangeFormatterDisp = dispinterface;\r\n _RSAPKCS1KeyExchangeDeformatter = interface;\r\n _RSAPKCS1KeyExchangeDeformatterDisp = dispinterface;\r\n _RSAPKCS1KeyExchangeFormatter = interface;\r\n _RSAPKCS1KeyExchangeFormatterDisp = dispinterface;\r\n _RSAPKCS1SignatureDeformatter = interface;\r\n _RSAPKCS1SignatureDeformatterDisp = dispinterface;\r\n _RSAPKCS1SignatureFormatter = interface;\r\n _RSAPKCS1SignatureFormatterDisp = dispinterface;\r\n _Rijndael = interface;\r\n _RijndaelDisp = dispinterface;\r\n _RijndaelManaged = interface;\r\n _RijndaelManagedDisp = dispinterface;\r\n _SHA1 = interface;\r\n _SHA1Disp = dispinterface;\r\n _SHA1CryptoServiceProvider = interface;\r\n _SHA1CryptoServiceProviderDisp = dispinterface;\r\n _SHA1Managed = interface;\r\n _SHA1ManagedDisp = dispinterface;\r\n _SHA256 = interface;\r\n _SHA256Disp = dispinterface;\r\n _SHA256Managed = interface;\r\n _SHA256ManagedDisp = dispinterface;\r\n _SHA384 = interface;\r\n _SHA384Disp = dispinterface;\r\n _SHA384Managed = interface;\r\n _SHA384ManagedDisp = dispinterface;\r\n _SHA512 = interface;\r\n _SHA512Disp = dispinterface;\r\n _SHA512Managed = interface;\r\n _SHA512ManagedDisp = dispinterface;\r\n _SignatureDescription = interface;\r\n _SignatureDescriptionDisp = dispinterface;\r\n _TripleDES = interface;\r\n _TripleDESDisp = dispinterface;\r\n _TripleDESCryptoServiceProvider = interface;\r\n _TripleDESCryptoServiceProviderDisp = dispinterface;\r\n ISecurityEncodable = interface;\r\n ISecurityEncodableDisp = dispinterface;\r\n ISecurityPolicyEncodable = interface;\r\n ISecurityPolicyEncodableDisp = dispinterface;\r\n IMembershipCondition = interface;\r\n IMembershipConditionDisp = dispinterface;\r\n _AllMembershipCondition = interface;\r\n _AllMembershipConditionDisp = dispinterface;\r\n _ApplicationDirectory = interface;\r\n _ApplicationDirectoryDisp = dispinterface;\r\n _ApplicationDirectoryMembershipCondition = interface;\r\n _ApplicationDirectoryMembershipConditionDisp = dispinterface;\r\n _CodeGroup = interface;\r\n _CodeGroupDisp = dispinterface;\r\n _Evidence = interface;\r\n _EvidenceDisp = dispinterface;\r\n _FileCodeGroup = interface;\r\n _FileCodeGroupDisp = dispinterface;\r\n _FirstMatchCodeGroup = interface;\r\n _FirstMatchCodeGroupDisp = dispinterface;\r\n _Hash = interface;\r\n _HashDisp = dispinterface;\r\n _HashMembershipCondition = interface;\r\n _HashMembershipConditionDisp = dispinterface;\r\n IIdentityPermissionFactory = interface;\r\n IIdentityPermissionFactoryDisp = dispinterface;\r\n _NetCodeGroup = interface;\r\n _NetCodeGroupDisp = dispinterface;\r\n _PermissionRequestEvidence = interface;\r\n _PermissionRequestEvidenceDisp = dispinterface;\r\n _PolicyException = interface;\r\n _PolicyExceptionDisp = dispinterface;\r\n _PolicyLevel = interface;\r\n _PolicyLevelDisp = dispinterface;\r\n _PolicyStatement = interface;\r\n _PolicyStatementDisp = dispinterface;\r\n _Publisher = interface;\r\n _PublisherDisp = dispinterface;\r\n _PublisherMembershipCondition = interface;\r\n _PublisherMembershipConditionDisp = dispinterface;\r\n _Site = interface;\r\n _SiteDisp = dispinterface;\r\n _SiteMembershipCondition = interface;\r\n _SiteMembershipConditionDisp = dispinterface;\r\n _StrongName = interface;\r\n _StrongNameDisp = dispinterface;\r\n _StrongNameMembershipCondition = interface;\r\n _StrongNameMembershipConditionDisp = dispinterface;\r\n _UnionCodeGroup = interface;\r\n _UnionCodeGroupDisp = dispinterface;\r\n _Url = interface;\r\n _UrlDisp = dispinterface;\r\n _UrlMembershipCondition = interface;\r\n _UrlMembershipConditionDisp = dispinterface;\r\n _Zone = interface;\r\n _ZoneDisp = dispinterface;\r\n _ZoneMembershipCondition = interface;\r\n _ZoneMembershipConditionDisp = dispinterface;\r\n IIdentity = interface;\r\n IIdentityDisp = dispinterface;\r\n _GenericIdentity = interface;\r\n _GenericIdentityDisp = dispinterface;\r\n IPrincipal = interface;\r\n IPrincipalDisp = dispinterface;\r\n _GenericPrincipal = interface;\r\n _GenericPrincipalDisp = dispinterface;\r\n _WindowsIdentity = interface;\r\n _WindowsIdentityDisp = dispinterface;\r\n _WindowsImpersonationContext = interface;\r\n _WindowsImpersonationContextDisp = dispinterface;\r\n _WindowsPrincipal = interface;\r\n _WindowsPrincipalDisp = dispinterface;\r\n _DispIdAttribute = interface;\r\n _DispIdAttributeDisp = dispinterface;\r\n _InterfaceTypeAttribute = interface;\r\n _InterfaceTypeAttributeDisp = dispinterface;\r\n _ClassInterfaceAttribute = interface;\r\n _ClassInterfaceAttributeDisp = dispinterface;\r\n _ComVisibleAttribute = interface;\r\n _ComVisibleAttributeDisp = dispinterface;\r\n _LCIDConversionAttribute = interface;\r\n _LCIDConversionAttributeDisp = dispinterface;\r\n _ComRegisterFunctionAttribute = interface;\r\n _ComRegisterFunctionAttributeDisp = dispinterface;\r\n _ComUnregisterFunctionAttribute = interface;\r\n _ComUnregisterFunctionAttributeDisp = dispinterface;\r\n _ProgIdAttribute = interface;\r\n _ProgIdAttributeDisp = dispinterface;\r\n _ImportedFromTypeLibAttribute = interface;\r\n _ImportedFromTypeLibAttributeDisp = dispinterface;\r\n _IDispatchImplAttribute = interface;\r\n _IDispatchImplAttributeDisp = dispinterface;\r\n _ComSourceInterfacesAttribute = interface;\r\n _ComSourceInterfacesAttributeDisp = dispinterface;\r\n _ComConversionLossAttribute = interface;\r\n _ComConversionLossAttributeDisp = dispinterface;\r\n _TypeLibTypeAttribute = interface;\r\n _TypeLibTypeAttributeDisp = dispinterface;\r\n _TypeLibFuncAttribute = interface;\r\n _TypeLibFuncAttributeDisp = dispinterface;\r\n _TypeLibVarAttribute = interface;\r\n _TypeLibVarAttributeDisp = dispinterface;\r\n _MarshalAsAttribute = interface;\r\n _MarshalAsAttributeDisp = dispinterface;\r\n _ComImportAttribute = interface;\r\n _ComImportAttributeDisp = dispinterface;\r\n _GuidAttribute = interface;\r\n _GuidAttributeDisp = dispinterface;\r\n _PreserveSigAttribute = interface;\r\n _PreserveSigAttributeDisp = dispinterface;\r\n _InAttribute = interface;\r\n _InAttributeDisp = dispinterface;\r\n _OutAttribute = interface;\r\n _OutAttributeDisp = dispinterface;\r\n _OptionalAttribute = interface;\r\n _OptionalAttributeDisp = dispinterface;\r\n _DllImportAttribute = interface;\r\n _DllImportAttributeDisp = dispinterface;\r\n _StructLayoutAttribute = interface;\r\n _StructLayoutAttributeDisp = dispinterface;\r\n _FieldOffsetAttribute = interface;\r\n _FieldOffsetAttributeDisp = dispinterface;\r\n _ComAliasNameAttribute = interface;\r\n _ComAliasNameAttributeDisp = dispinterface;\r\n _AutomationProxyAttribute = interface;\r\n _AutomationProxyAttributeDisp = dispinterface;\r\n _PrimaryInteropAssemblyAttribute = interface;\r\n _PrimaryInteropAssemblyAttributeDisp = dispinterface;\r\n _CoClassAttribute = interface;\r\n _CoClassAttributeDisp = dispinterface;\r\n _ComEventInterfaceAttribute = interface;\r\n _ComEventInterfaceAttributeDisp = dispinterface;\r\n _TypeLibVersionAttribute = interface;\r\n _TypeLibVersionAttributeDisp = dispinterface;\r\n _ComCompatibleVersionAttribute = interface;\r\n _ComCompatibleVersionAttributeDisp = dispinterface;\r\n _BestFitMappingAttribute = interface;\r\n _BestFitMappingAttributeDisp = dispinterface;\r\n _ExternalException = interface;\r\n _ExternalExceptionDisp = dispinterface;\r\n _COMException = interface;\r\n _COMExceptionDisp = dispinterface;\r\n _CurrencyWrapper = interface;\r\n _CurrencyWrapperDisp = dispinterface;\r\n _DispatchWrapper = interface;\r\n _DispatchWrapperDisp = dispinterface;\r\n _ErrorWrapper = interface;\r\n _ErrorWrapperDisp = dispinterface;\r\n _ExtensibleClassFactory = interface;\r\n _ExtensibleClassFactoryDisp = dispinterface;\r\n ICustomAdapter = interface;\r\n ICustomAdapterDisp = dispinterface;\r\n ICustomMarshaler = interface;\r\n ICustomMarshalerDisp = dispinterface;\r\n ICustomFactory = interface;\r\n ICustomFactoryDisp = dispinterface;\r\n _InvalidComObjectException = interface;\r\n _InvalidComObjectExceptionDisp = dispinterface;\r\n _InvalidOleVariantTypeException = interface;\r\n _InvalidOleVariantTypeExceptionDisp = dispinterface;\r\n IRegistrationServices = interface;\r\n IRegistrationServicesDisp = dispinterface;\r\n ITypeLibImporterNotifySink = interface;\r\n ITypeLibExporterNotifySink = interface;\r\n ITypeLibConverter = interface;\r\n ITypeLibExporterNameProvider = interface;\r\n _Marshal = interface;\r\n _MarshalDisp = dispinterface;\r\n _MarshalDirectiveException = interface;\r\n _MarshalDirectiveExceptionDisp = dispinterface;\r\n _ObjectCreationDelegate = interface;\r\n _ObjectCreationDelegateDisp = dispinterface;\r\n _RuntimeEnvironment = interface;\r\n _RuntimeEnvironmentDisp = dispinterface;\r\n _SafeArrayRankMismatchException = interface;\r\n _SafeArrayRankMismatchExceptionDisp = dispinterface;\r\n _SafeArrayTypeMismatchException = interface;\r\n _SafeArrayTypeMismatchExceptionDisp = dispinterface;\r\n _SEHException = interface;\r\n _SEHExceptionDisp = dispinterface;\r\n _UnknownWrapper = interface;\r\n _UnknownWrapperDisp = dispinterface;\r\n IExpando = interface;\r\n IExpandoDisp = dispinterface;\r\n _BinaryReader = interface;\r\n _BinaryReaderDisp = dispinterface;\r\n _BinaryWriter = interface;\r\n _BinaryWriterDisp = dispinterface;\r\n _BufferedStream = interface;\r\n _BufferedStreamDisp = dispinterface;\r\n _Directory = interface;\r\n _DirectoryDisp = dispinterface;\r\n _FileSystemInfo = interface;\r\n _FileSystemInfoDisp = dispinterface;\r\n _DirectoryInfo = interface;\r\n _DirectoryInfoDisp = dispinterface;\r\n _IOException = interface;\r\n _IOExceptionDisp = dispinterface;\r\n _DirectoryNotFoundException = interface;\r\n _DirectoryNotFoundExceptionDisp = dispinterface;\r\n _EndOfStreamException = interface;\r\n _EndOfStreamExceptionDisp = dispinterface;\r\n _File = interface;\r\n _FileDisp = dispinterface;\r\n _FileInfo = interface;\r\n _FileInfoDisp = dispinterface;\r\n _FileLoadException = interface;\r\n _FileLoadExceptionDisp = dispinterface;\r\n _FileNotFoundException = interface;\r\n _FileNotFoundExceptionDisp = dispinterface;\r\n _FileStream = interface;\r\n _FileStreamDisp = dispinterface;\r\n _MemoryStream = interface;\r\n _MemoryStreamDisp = dispinterface;\r\n _Path = interface;\r\n _PathDisp = dispinterface;\r\n _PathTooLongException = interface;\r\n _PathTooLongExceptionDisp = dispinterface;\r\n _TextReader = interface;\r\n _TextReaderDisp = dispinterface;\r\n _StreamReader = interface;\r\n _StreamReaderDisp = dispinterface;\r\n _TextWriter = interface;\r\n _TextWriterDisp = dispinterface;\r\n _StreamWriter = interface;\r\n _StreamWriterDisp = dispinterface;\r\n _StringReader = interface;\r\n _StringReaderDisp = dispinterface;\r\n _StringWriter = interface;\r\n _StringWriterDisp = dispinterface;\r\n _AccessedThroughPropertyAttribute = interface;\r\n _AccessedThroughPropertyAttributeDisp = dispinterface;\r\n _CallConvCdecl = interface;\r\n _CallConvCdeclDisp = dispinterface;\r\n _CallConvStdcall = interface;\r\n _CallConvStdcallDisp = dispinterface;\r\n _CallConvThiscall = interface;\r\n _CallConvThiscallDisp = dispinterface;\r\n _CallConvFastcall = interface;\r\n _CallConvFastcallDisp = dispinterface;\r\n _RuntimeHelpers = interface;\r\n _RuntimeHelpersDisp = dispinterface;\r\n _CustomConstantAttribute = interface;\r\n _CustomConstantAttributeDisp = dispinterface;\r\n _DateTimeConstantAttribute = interface;\r\n _DateTimeConstantAttributeDisp = dispinterface;\r\n _DiscardableAttribute = interface;\r\n _DiscardableAttributeDisp = dispinterface;\r\n _DecimalConstantAttribute = interface;\r\n _DecimalConstantAttributeDisp = dispinterface;\r\n _CompilationRelaxationsAttribute = interface;\r\n _CompilationRelaxationsAttributeDisp = dispinterface;\r\n _CompilerGlobalScopeAttribute = interface;\r\n _CompilerGlobalScopeAttributeDisp = dispinterface;\r\n _IDispatchConstantAttribute = interface;\r\n _IDispatchConstantAttributeDisp = dispinterface;\r\n _IndexerNameAttribute = interface;\r\n _IndexerNameAttributeDisp = dispinterface;\r\n _IsVolatile = interface;\r\n _IsVolatileDisp = dispinterface;\r\n _IUnknownConstantAttribute = interface;\r\n _IUnknownConstantAttributeDisp = dispinterface;\r\n _MethodImplAttribute = interface;\r\n _MethodImplAttributeDisp = dispinterface;\r\n _RequiredAttributeAttribute = interface;\r\n _RequiredAttributeAttributeDisp = dispinterface;\r\n IStackWalk = interface;\r\n IStackWalkDisp = dispinterface;\r\n _PermissionSet = interface;\r\n _PermissionSetDisp = dispinterface;\r\n _NamedPermissionSet = interface;\r\n _NamedPermissionSetDisp = dispinterface;\r\n _SecurityElement = interface;\r\n _SecurityElementDisp = dispinterface;\r\n _XmlSyntaxException = interface;\r\n _XmlSyntaxExceptionDisp = dispinterface;\r\n IPermission = interface;\r\n IPermissionDisp = dispinterface;\r\n _CodeAccessPermission = interface;\r\n _CodeAccessPermissionDisp = dispinterface;\r\n IUnrestrictedPermission = interface;\r\n IUnrestrictedPermissionDisp = dispinterface;\r\n _EnvironmentPermission = interface;\r\n _EnvironmentPermissionDisp = dispinterface;\r\n _FileDialogPermission = interface;\r\n _FileDialogPermissionDisp = dispinterface;\r\n _FileIOPermission = interface;\r\n _FileIOPermissionDisp = dispinterface;\r\n _IsolatedStoragePermission = interface;\r\n _IsolatedStoragePermissionDisp = dispinterface;\r\n _IsolatedStorageFilePermission = interface;\r\n _IsolatedStorageFilePermissionDisp = dispinterface;\r\n _SecurityAttribute = interface;\r\n _SecurityAttributeDisp = dispinterface;\r\n _CodeAccessSecurityAttribute = interface;\r\n _CodeAccessSecurityAttributeDisp = dispinterface;\r\n _EnvironmentPermissionAttribute = interface;\r\n _EnvironmentPermissionAttributeDisp = dispinterface;\r\n _FileDialogPermissionAttribute = interface;\r\n _FileDialogPermissionAttributeDisp = dispinterface;\r\n _FileIOPermissionAttribute = interface;\r\n _FileIOPermissionAttributeDisp = dispinterface;\r\n _PrincipalPermissionAttribute = interface;\r\n _PrincipalPermissionAttributeDisp = dispinterface;\r\n _ReflectionPermissionAttribute = interface;\r\n _ReflectionPermissionAttributeDisp = dispinterface;\r\n _RegistryPermissionAttribute = interface;\r\n _RegistryPermissionAttributeDisp = dispinterface;\r\n _SecurityPermissionAttribute = interface;\r\n _SecurityPermissionAttributeDisp = dispinterface;\r\n _UIPermissionAttribute = interface;\r\n _UIPermissionAttributeDisp = dispinterface;\r\n _ZoneIdentityPermissionAttribute = interface;\r\n _ZoneIdentityPermissionAttributeDisp = dispinterface;\r\n _StrongNameIdentityPermissionAttribute = interface;\r\n _StrongNameIdentityPermissionAttributeDisp = dispinterface;\r\n _SiteIdentityPermissionAttribute = interface;\r\n _SiteIdentityPermissionAttributeDisp = dispinterface;\r\n _UrlIdentityPermissionAttribute = interface;\r\n _UrlIdentityPermissionAttributeDisp = dispinterface;\r\n _PublisherIdentityPermissionAttribute = interface;\r\n _PublisherIdentityPermissionAttributeDisp = dispinterface;\r\n _IsolatedStoragePermissionAttribute = interface;\r\n _IsolatedStoragePermissionAttributeDisp = dispinterface;\r\n _IsolatedStorageFilePermissionAttribute = interface;\r\n _IsolatedStorageFilePermissionAttributeDisp = dispinterface;\r\n _PermissionSetAttribute = interface;\r\n _PermissionSetAttributeDisp = dispinterface;\r\n _PublisherIdentityPermission = interface;\r\n _PublisherIdentityPermissionDisp = dispinterface;\r\n _ReflectionPermission = interface;\r\n _ReflectionPermissionDisp = dispinterface;\r\n _RegistryPermission = interface;\r\n _RegistryPermissionDisp = dispinterface;\r\n _PrincipalPermission = interface;\r\n _PrincipalPermissionDisp = dispinterface;\r\n _SecurityPermission = interface;\r\n _SecurityPermissionDisp = dispinterface;\r\n _SiteIdentityPermission = interface;\r\n _SiteIdentityPermissionDisp = dispinterface;\r\n _StrongNameIdentityPermission = interface;\r\n _StrongNameIdentityPermissionDisp = dispinterface;\r\n _StrongNamePublicKeyBlob = interface;\r\n _StrongNamePublicKeyBlobDisp = dispinterface;\r\n _UIPermission = interface;\r\n _UIPermissionDisp = dispinterface;\r\n _UrlIdentityPermission = interface;\r\n _UrlIdentityPermissionDisp = dispinterface;\r\n _ZoneIdentityPermission = interface;\r\n _ZoneIdentityPermissionDisp = dispinterface;\r\n _SuppressUnmanagedCodeSecurityAttribute = interface;\r\n _SuppressUnmanagedCodeSecurityAttributeDisp = dispinterface;\r\n _UnverifiableCodeAttribute = interface;\r\n _UnverifiableCodeAttributeDisp = dispinterface;\r\n _AllowPartiallyTrustedCallersAttribute = interface;\r\n _AllowPartiallyTrustedCallersAttributeDisp = dispinterface;\r\n _SecurityException = interface;\r\n _SecurityExceptionDisp = dispinterface;\r\n _SecurityManager = interface;\r\n _SecurityManagerDisp = dispinterface;\r\n _VerificationException = interface;\r\n _VerificationExceptionDisp = dispinterface;\r\n IContextAttribute = interface;\r\n IContextAttributeDisp = dispinterface;\r\n IContextProperty = interface;\r\n IContextPropertyDisp = dispinterface;\r\n _ContextAttribute = interface;\r\n _ContextAttributeDisp = dispinterface;\r\n IActivator = interface;\r\n IActivatorDisp = dispinterface;\r\n IMessageSink = interface;\r\n IMessageSinkDisp = dispinterface;\r\n _AsyncResult = interface;\r\n _AsyncResultDisp = dispinterface;\r\n _CallContext = interface;\r\n _CallContextDisp = dispinterface;\r\n ILogicalThreadAffinative = interface;\r\n ILogicalThreadAffinativeDisp = dispinterface;\r\n _LogicalCallContext = interface;\r\n _LogicalCallContextDisp = dispinterface;\r\n _ChannelServices = interface;\r\n _ChannelServicesDisp = dispinterface;\r\n IClientResponseChannelSinkStack = interface;\r\n IClientResponseChannelSinkStackDisp = dispinterface;\r\n IClientChannelSinkStack = interface;\r\n IClientChannelSinkStackDisp = dispinterface;\r\n _ClientChannelSinkStack = interface;\r\n _ClientChannelSinkStackDisp = dispinterface;\r\n IServerResponseChannelSinkStack = interface;\r\n IServerResponseChannelSinkStackDisp = dispinterface;\r\n IServerChannelSinkStack = interface;\r\n IServerChannelSinkStackDisp = dispinterface;\r\n _ServerChannelSinkStack = interface;\r\n _ServerChannelSinkStackDisp = dispinterface;\r\n _InternalMessageWrapper = interface;\r\n _InternalMessageWrapperDisp = dispinterface;\r\n IMessage = interface;\r\n IMessageDisp = dispinterface;\r\n IMethodMessage = interface;\r\n IMethodMessageDisp = dispinterface;\r\n IMethodCallMessage = interface;\r\n IMethodCallMessageDisp = dispinterface;\r\n _MethodCallMessageWrapper = interface;\r\n _MethodCallMessageWrapperDisp = dispinterface;\r\n ISponsor = interface;\r\n ISponsorDisp = dispinterface;\r\n _ClientSponsor = interface;\r\n _ClientSponsorDisp = dispinterface;\r\n _CrossContextDelegate = interface;\r\n _CrossContextDelegateDisp = dispinterface;\r\n _Context = interface;\r\n _ContextDisp = dispinterface;\r\n _ContextProperty = interface;\r\n _ContextPropertyDisp = dispinterface;\r\n IContextPropertyActivator = interface;\r\n IContextPropertyActivatorDisp = dispinterface;\r\n IChannel = interface;\r\n IChannelDisp = dispinterface;\r\n IChannelSender = interface;\r\n IChannelSenderDisp = dispinterface;\r\n IChannelReceiver = interface;\r\n IChannelReceiverDisp = dispinterface;\r\n IServerChannelSinkProvider = interface;\r\n IServerChannelSinkProviderDisp = dispinterface;\r\n IChannelSinkBase = interface;\r\n IChannelSinkBaseDisp = dispinterface;\r\n IServerChannelSink = interface;\r\n IServerChannelSinkDisp = dispinterface;\r\n _EnterpriseServicesHelper = interface;\r\n _EnterpriseServicesHelperDisp = dispinterface;\r\n _Header = interface;\r\n _HeaderDisp = dispinterface;\r\n _HeaderHandler = interface;\r\n _HeaderHandlerDisp = dispinterface;\r\n IConstructionCallMessage = interface;\r\n IConstructionCallMessageDisp = dispinterface;\r\n IMethodReturnMessage = interface;\r\n IMethodReturnMessageDisp = dispinterface;\r\n IConstructionReturnMessage = interface;\r\n IConstructionReturnMessageDisp = dispinterface;\r\n IChannelReceiverHook = interface;\r\n IChannelReceiverHookDisp = dispinterface;\r\n IClientChannelSinkProvider = interface;\r\n IClientChannelSinkProviderDisp = dispinterface;\r\n IClientFormatterSinkProvider = interface;\r\n IClientFormatterSinkProviderDisp = dispinterface;\r\n IServerFormatterSinkProvider = interface;\r\n IServerFormatterSinkProviderDisp = dispinterface;\r\n IClientChannelSink = interface;\r\n IClientChannelSinkDisp = dispinterface;\r\n IClientFormatterSink = interface;\r\n IClientFormatterSinkDisp = dispinterface;\r\n IChannelDataStore = interface;\r\n IChannelDataStoreDisp = dispinterface;\r\n _ChannelDataStore = interface;\r\n _ChannelDataStoreDisp = dispinterface;\r\n ITransportHeaders = interface;\r\n ITransportHeadersDisp = dispinterface;\r\n _TransportHeaders = interface;\r\n _TransportHeadersDisp = dispinterface;\r\n _SinkProviderData = interface;\r\n _SinkProviderDataDisp = dispinterface;\r\n _BaseChannelObjectWithProperties = interface;\r\n _BaseChannelObjectWithPropertiesDisp = dispinterface;\r\n _BaseChannelSinkWithProperties = interface;\r\n _BaseChannelSinkWithPropertiesDisp = dispinterface;\r\n _BaseChannelWithProperties = interface;\r\n _BaseChannelWithPropertiesDisp = dispinterface;\r\n IContributeClientContextSink = interface;\r\n IContributeClientContextSinkDisp = dispinterface;\r\n IContributeDynamicSink = interface;\r\n IContributeDynamicSinkDisp = dispinterface;\r\n IContributeEnvoySink = interface;\r\n IContributeEnvoySinkDisp = dispinterface;\r\n IContributeObjectSink = interface;\r\n IContributeObjectSinkDisp = dispinterface;\r\n IContributeServerContextSink = interface;\r\n IContributeServerContextSinkDisp = dispinterface;\r\n IDynamicProperty = interface;\r\n IDynamicPropertyDisp = dispinterface;\r\n IDynamicMessageSink = interface;\r\n IDynamicMessageSinkDisp = dispinterface;\r\n ILease = interface;\r\n ILeaseDisp = dispinterface;\r\n IMessageCtrl = interface;\r\n IMessageCtrlDisp = dispinterface;\r\n IRemotingFormatter = interface;\r\n IRemotingFormatterDisp = dispinterface;\r\n _LifetimeServices = interface;\r\n _LifetimeServicesDisp = dispinterface;\r\n _ReturnMessage = interface;\r\n _ReturnMessageDisp = dispinterface;\r\n _MethodCall = interface;\r\n _MethodCallDisp = dispinterface;\r\n _ConstructionCall = interface;\r\n _ConstructionCallDisp = dispinterface;\r\n _MethodResponse = interface;\r\n _MethodResponseDisp = dispinterface;\r\n IFieldInfo = interface;\r\n IFieldInfoDisp = dispinterface;\r\n _ConstructionResponse = interface;\r\n _ConstructionResponseDisp = dispinterface;\r\n _MethodReturnMessageWrapper = interface;\r\n _MethodReturnMessageWrapperDisp = dispinterface;\r\n _ObjectHandle = interface;\r\n _ObjectHandleDisp = dispinterface;\r\n IRemotingTypeInfo = interface;\r\n IRemotingTypeInfoDisp = dispinterface;\r\n IChannelInfo = interface;\r\n IChannelInfoDisp = dispinterface;\r\n IEnvoyInfo = interface;\r\n IEnvoyInfoDisp = dispinterface;\r\n _ObjRef = interface;\r\n _ObjRefDisp = dispinterface;\r\n _OneWayAttribute = interface;\r\n _OneWayAttributeDisp = dispinterface;\r\n _ProxyAttribute = interface;\r\n _ProxyAttributeDisp = dispinterface;\r\n _RealProxy = interface;\r\n _RealProxyDisp = dispinterface;\r\n _SoapAttribute = interface;\r\n _SoapAttributeDisp = dispinterface;\r\n _SoapTypeAttribute = interface;\r\n _SoapTypeAttributeDisp = dispinterface;\r\n _SoapMethodAttribute = interface;\r\n _SoapMethodAttributeDisp = dispinterface;\r\n _SoapFieldAttribute = interface;\r\n _SoapFieldAttributeDisp = dispinterface;\r\n _SoapParameterAttribute = interface;\r\n _SoapParameterAttributeDisp = dispinterface;\r\n _RemotingConfiguration = interface;\r\n _RemotingConfigurationDisp = dispinterface;\r\n _System_Runtime_Remoting_TypeEntry = interface;\r\n _System_Runtime_Remoting_TypeEntryDisp = dispinterface;\r\n _ActivatedClientTypeEntry = interface;\r\n _ActivatedClientTypeEntryDisp = dispinterface;\r\n _ActivatedServiceTypeEntry = interface;\r\n _ActivatedServiceTypeEntryDisp = dispinterface;\r\n _WellKnownClientTypeEntry = interface;\r\n _WellKnownClientTypeEntryDisp = dispinterface;\r\n _WellKnownServiceTypeEntry = interface;\r\n _WellKnownServiceTypeEntryDisp = dispinterface;\r\n _RemotingException = interface;\r\n _RemotingExceptionDisp = dispinterface;\r\n _ServerException = interface;\r\n _ServerExceptionDisp = dispinterface;\r\n _RemotingTimeoutException = interface;\r\n _RemotingTimeoutExceptionDisp = dispinterface;\r\n _RemotingServices = interface;\r\n _RemotingServicesDisp = dispinterface;\r\n _InternalRemotingServices = interface;\r\n _InternalRemotingServicesDisp = dispinterface;\r\n _MessageSurrogateFilter = interface;\r\n _MessageSurrogateFilterDisp = dispinterface;\r\n _RemotingSurrogateSelector = interface;\r\n _RemotingSurrogateSelectorDisp = dispinterface;\r\n _SoapServices = interface;\r\n _SoapServicesDisp = dispinterface;\r\n ISoapXsd = interface;\r\n ISoapXsdDisp = dispinterface;\r\n _SoapDateTime = interface;\r\n _SoapDateTimeDisp = dispinterface;\r\n _SoapDuration = interface;\r\n _SoapDurationDisp = dispinterface;\r\n _SoapTime = interface;\r\n _SoapTimeDisp = dispinterface;\r\n _SoapDate = interface;\r\n _SoapDateDisp = dispinterface;\r\n _SoapYearMonth = interface;\r\n _SoapYearMonthDisp = dispinterface;\r\n _SoapYear = interface;\r\n _SoapYearDisp = dispinterface;\r\n _SoapMonthDay = interface;\r\n _SoapMonthDayDisp = dispinterface;\r\n _SoapDay = interface;\r\n _SoapDayDisp = dispinterface;\r\n _SoapMonth = interface;\r\n _SoapMonthDisp = dispinterface;\r\n _SoapHexBinary = interface;\r\n _SoapHexBinaryDisp = dispinterface;\r\n _SoapBase64Binary = interface;\r\n _SoapBase64BinaryDisp = dispinterface;\r\n _SoapInteger = interface;\r\n _SoapIntegerDisp = dispinterface;\r\n _SoapPositiveInteger = interface;\r\n _SoapPositiveIntegerDisp = dispinterface;\r\n _SoapNonPositiveInteger = interface;\r\n _SoapNonPositiveIntegerDisp = dispinterface;\r\n _SoapNonNegativeInteger = interface;\r\n _SoapNonNegativeIntegerDisp = dispinterface;\r\n _SoapNegativeInteger = interface;\r\n _SoapNegativeIntegerDisp = dispinterface;\r\n _SoapAnyUri = interface;\r\n _SoapAnyUriDisp = dispinterface;\r\n _SoapQName = interface;\r\n _SoapQNameDisp = dispinterface;\r\n _SoapNotation = interface;\r\n _SoapNotationDisp = dispinterface;\r\n _SoapNormalizedString = interface;\r\n _SoapNormalizedStringDisp = dispinterface;\r\n _SoapToken = interface;\r\n _SoapTokenDisp = dispinterface;\r\n _SoapLanguage = interface;\r\n _SoapLanguageDisp = dispinterface;\r\n _SoapName = interface;\r\n _SoapNameDisp = dispinterface;\r\n _SoapIdrefs = interface;\r\n _SoapIdrefsDisp = dispinterface;\r\n _SoapEntities = interface;\r\n _SoapEntitiesDisp = dispinterface;\r\n _SoapNmtoken = interface;\r\n _SoapNmtokenDisp = dispinterface;\r\n _SoapNmtokens = interface;\r\n _SoapNmtokensDisp = dispinterface;\r\n _SoapNcName = interface;\r\n _SoapNcNameDisp = dispinterface;\r\n _SoapId = interface;\r\n _SoapIdDisp = dispinterface;\r\n _SoapIdref = interface;\r\n _SoapIdrefDisp = dispinterface;\r\n _SoapEntity = interface;\r\n _SoapEntityDisp = dispinterface;\r\n _SynchronizationAttribute = interface;\r\n _SynchronizationAttributeDisp = dispinterface;\r\n ITrackingHandler = interface;\r\n ITrackingHandlerDisp = dispinterface;\r\n _TrackingServices = interface;\r\n _TrackingServicesDisp = dispinterface;\r\n _UrlAttribute = interface;\r\n _UrlAttributeDisp = dispinterface;\r\n _IsolatedStorage = interface;\r\n _IsolatedStorageDisp = dispinterface;\r\n _IsolatedStorageFile = interface;\r\n _IsolatedStorageFileDisp = dispinterface;\r\n _IsolatedStorageFileStream = interface;\r\n _IsolatedStorageFileStreamDisp = dispinterface;\r\n _IsolatedStorageException = interface;\r\n _IsolatedStorageExceptionDisp = dispinterface;\r\n INormalizeForIsolatedStorage = interface;\r\n INormalizeForIsolatedStorageDisp = dispinterface;\r\n ISoapMessage = interface;\r\n ISoapMessageDisp = dispinterface;\r\n _InternalRM = interface;\r\n _InternalRMDisp = dispinterface;\r\n _InternalST = interface;\r\n _InternalSTDisp = dispinterface;\r\n _SoapMessage = interface;\r\n _SoapMessageDisp = dispinterface;\r\n _SoapFault = interface;\r\n _SoapFaultDisp = dispinterface;\r\n _ServerFault = interface;\r\n _ServerFaultDisp = dispinterface;\r\n _BinaryFormatter = interface;\r\n _BinaryFormatterDisp = dispinterface;\r\n _AssemblyBuilder = interface;\r\n _AssemblyBuilderDisp = dispinterface;\r\n _ConstructorBuilder = interface;\r\n _ConstructorBuilderDisp = dispinterface;\r\n _EventBuilder = interface;\r\n _EventBuilderDisp = dispinterface;\r\n _FieldBuilder = interface;\r\n _FieldBuilderDisp = dispinterface;\r\n _ILGenerator = interface;\r\n _ILGeneratorDisp = dispinterface;\r\n _LocalBuilder = interface;\r\n _LocalBuilderDisp = dispinterface;\r\n _MethodBuilder = interface;\r\n _MethodBuilderDisp = dispinterface;\r\n _CustomAttributeBuilder = interface;\r\n _CustomAttributeBuilderDisp = dispinterface;\r\n _MethodRental = interface;\r\n _MethodRentalDisp = dispinterface;\r\n _ModuleBuilder = interface;\r\n _ModuleBuilderDisp = dispinterface;\r\n _OpCodes = interface;\r\n _OpCodesDisp = dispinterface;\r\n _ParameterBuilder = interface;\r\n _ParameterBuilderDisp = dispinterface;\r\n _PropertyBuilder = interface;\r\n _PropertyBuilderDisp = dispinterface;\r\n _SignatureHelper = interface;\r\n _SignatureHelperDisp = dispinterface;\r\n _TypeBuilder = interface;\r\n _TypeBuilderDisp = dispinterface;\r\n _EnumBuilder = interface;\r\n _EnumBuilderDisp = dispinterface;\r\n\r\n// *********************************************************************//\r\n// Declaration of CoClasses defined in Type Library \r\n// (NOTE: Here we map each CoClass to its Default Interface) \r\n// *********************************************************************//\r\n AppDomain = _AppDomain;\r\n RegistrationServices = IRegistrationServices;\r\n TypeLibConverter = ITypeLibConverter;\r\n AppDomainSetup = IAppDomainSetup;\r\n Object_ = _Object;\r\n Array_ = _Array;\r\n String_ = _String;\r\n StringBuilder = _StringBuilder;\r\n Exception = _Exception;\r\n ValueType = _ValueType;\r\n SystemException = _SystemException;\r\n OutOfMemoryException = _OutOfMemoryException;\r\n StackOverflowException = _StackOverflowException;\r\n ExecutionEngineException = _ExecutionEngineException;\r\n Delegate = _Delegate;\r\n MulticastDelegate = _MulticastDelegate;\r\n Enum = _Enum;\r\n MemberAccessException = _MemberAccessException;\r\n Activator = _Activator;\r\n ApplicationException = _ApplicationException;\r\n EventArgs = _EventArgs;\r\n ResolveEventArgs = _ResolveEventArgs;\r\n AssemblyLoadEventArgs = _AssemblyLoadEventArgs;\r\n ResolveEventHandler = _ResolveEventHandler;\r\n AssemblyLoadEventHandler = _AssemblyLoadEventHandler;\r\n MarshalByRefObject = _MarshalByRefObject;\r\n CrossAppDomainDelegate = _CrossAppDomainDelegate;\r\n Attribute = _Attribute;\r\n LoaderOptimizationAttribute = _LoaderOptimizationAttribute;\r\n AppDomainUnloadedException = _AppDomainUnloadedException;\r\n ArgumentException = _ArgumentException;\r\n ArgumentNullException = _ArgumentNullException;\r\n ArgumentOutOfRangeException = _ArgumentOutOfRangeException;\r\n ArithmeticException = _ArithmeticException;\r\n ArrayTypeMismatchException = _ArrayTypeMismatchException;\r\n AsyncCallback = _AsyncCallback;\r\n AttributeUsageAttribute = _AttributeUsageAttribute;\r\n BadImageFormatException = _BadImageFormatException;\r\n BitConverter = _BitConverter;\r\n Buffer = _Buffer;\r\n CannotUnloadAppDomainException = _CannotUnloadAppDomainException;\r\n CharEnumerator = _CharEnumerator;\r\n CLSCompliantAttribute = _CLSCompliantAttribute;\r\n TypeUnloadedException = _TypeUnloadedException;\r\n Console = _Console;\r\n ContextMarshalException = _ContextMarshalException;\r\n Convert = _Convert;\r\n ContextBoundObject = _ContextBoundObject;\r\n ContextStaticAttribute = _ContextStaticAttribute;\r\n TimeZone = _TimeZone;\r\n DBNull = _DBNull;\r\n Binder = _Binder;\r\n DivideByZeroException = _DivideByZeroException;\r\n DuplicateWaitObjectException = _DuplicateWaitObjectException;\r\n TypeLoadException = _TypeLoadException;\r\n EntryPointNotFoundException = _EntryPointNotFoundException;\r\n DllNotFoundException = _DllNotFoundException;\r\n Environment = _Environment;\r\n EventHandler = _EventHandler;\r\n FieldAccessException = _FieldAccessException;\r\n FlagsAttribute = _FlagsAttribute;\r\n FormatException = _FormatException;\r\n GC = _GC;\r\n IndexOutOfRangeException = _IndexOutOfRangeException;\r\n InvalidCastException = _InvalidCastException;\r\n InvalidOperationException = _InvalidOperationException;\r\n InvalidProgramException = _InvalidProgramException;\r\n LocalDataStoreSlot = _LocalDataStoreSlot;\r\n Math = _Math;\r\n MethodAccessException = _MethodAccessException;\r\n MissingMemberException = _MissingMemberException;\r\n MissingFieldException = _MissingFieldException;\r\n MissingMethodException = _MissingMethodException;\r\n MulticastNotSupportedException = _MulticastNotSupportedException;\r\n NonSerializedAttribute = _NonSerializedAttribute;\r\n NotFiniteNumberException = _NotFiniteNumberException;\r\n NotImplementedException = _NotImplementedException;\r\n NotSupportedException = _NotSupportedException;\r\n NullReferenceException = _NullReferenceException;\r\n ObjectDisposedException = _ObjectDisposedException;\r\n ObsoleteAttribute = _ObsoleteAttribute;\r\n OperatingSystem = _OperatingSystem;\r\n OverflowException = _OverflowException;\r\n ParamArrayAttribute = _ParamArrayAttribute;\r\n PlatformNotSupportedException = _PlatformNotSupportedException;\r\n Random = _Random;\r\n RankException = _RankException;\r\n MemberInfo = _MemberInfo;\r\n Type_ = _Type;\r\n SerializableAttribute = _SerializableAttribute;\r\n TypeInitializationException = _TypeInitializationException;\r\n UnauthorizedAccessException = _UnauthorizedAccessException;\r\n UnhandledExceptionEventArgs = _UnhandledExceptionEventArgs;\r\n UnhandledExceptionEventHandler = _UnhandledExceptionEventHandler;\r\n Version = _Version;\r\n WeakReference = _WeakReference;\r\n WaitHandle = _WaitHandle;\r\n AutoResetEvent = _AutoResetEvent;\r\n CompressedStack = _CompressedStack;\r\n Interlocked = _Interlocked;\r\n ManualResetEvent = _ManualResetEvent;\r\n Monitor = _Monitor;\r\n Mutex = _Mutex;\r\n Overlapped = _Overlapped;\r\n ReaderWriterLock = _ReaderWriterLock;\r\n SynchronizationLockException = _SynchronizationLockException;\r\n Thread = _Thread;\r\n ThreadAbortException = _ThreadAbortException;\r\n STAThreadAttribute = _STAThreadAttribute;\r\n MTAThreadAttribute = _MTAThreadAttribute;\r\n ThreadInterruptedException = _ThreadInterruptedException;\r\n RegisteredWaitHandle = _RegisteredWaitHandle;\r\n WaitCallback = _WaitCallback;\r\n WaitOrTimerCallback = _WaitOrTimerCallback;\r\n IOCompletionCallback = _IOCompletionCallback;\r\n ThreadPool = _ThreadPool;\r\n ThreadStart = _ThreadStart;\r\n ThreadStateException = _ThreadStateException;\r\n ThreadStaticAttribute = _ThreadStaticAttribute;\r\n Timeout = _Timeout;\r\n TimerCallback = _TimerCallback;\r\n Timer = _Timer;\r\n ArrayList = _ArrayList;\r\n BitArray = _BitArray;\r\n CaseInsensitiveComparer = _CaseInsensitiveComparer;\r\n CaseInsensitiveHashCodeProvider = _CaseInsensitiveHashCodeProvider;\r\n CollectionBase = _CollectionBase;\r\n Comparer = _Comparer;\r\n DictionaryBase = _DictionaryBase;\r\n Hashtable = _Hashtable;\r\n Queue = _Queue;\r\n ReadOnlyCollectionBase = _ReadOnlyCollectionBase;\r\n SortedList = _SortedList;\r\n Stack = _Stack;\r\n ConditionalAttribute = _ConditionalAttribute;\r\n Debugger = _Debugger;\r\n DebuggerStepThroughAttribute = _DebuggerStepThroughAttribute;\r\n DebuggerHiddenAttribute = _DebuggerHiddenAttribute;\r\n DebuggableAttribute = _DebuggableAttribute;\r\n StackTrace = _StackTrace;\r\n StackFrame = _StackFrame;\r\n SymDocumentType = _SymDocumentType;\r\n SymLanguageType = _SymLanguageType;\r\n SymLanguageVendor = _SymLanguageVendor;\r\n AmbiguousMatchException = _AmbiguousMatchException;\r\n ModuleResolveEventHandler = _ModuleResolveEventHandler;\r\n Assembly = _Assembly;\r\n AssemblyCultureAttribute = _AssemblyCultureAttribute;\r\n AssemblyVersionAttribute = _AssemblyVersionAttribute;\r\n AssemblyKeyFileAttribute = _AssemblyKeyFileAttribute;\r\n AssemblyKeyNameAttribute = _AssemblyKeyNameAttribute;\r\n AssemblyDelaySignAttribute = _AssemblyDelaySignAttribute;\r\n AssemblyAlgorithmIdAttribute = _AssemblyAlgorithmIdAttribute;\r\n AssemblyFlagsAttribute = _AssemblyFlagsAttribute;\r\n AssemblyFileVersionAttribute = _AssemblyFileVersionAttribute;\r\n AssemblyName = _AssemblyName;\r\n AssemblyNameProxy = _AssemblyNameProxy;\r\n AssemblyCopyrightAttribute = _AssemblyCopyrightAttribute;\r\n AssemblyTrademarkAttribute = _AssemblyTrademarkAttribute;\r\n AssemblyProductAttribute = _AssemblyProductAttribute;\r\n AssemblyCompanyAttribute = _AssemblyCompanyAttribute;\r\n AssemblyDescriptionAttribute = _AssemblyDescriptionAttribute;\r\n AssemblyTitleAttribute = _AssemblyTitleAttribute;\r\n AssemblyConfigurationAttribute = _AssemblyConfigurationAttribute;\r\n AssemblyDefaultAliasAttribute = _AssemblyDefaultAliasAttribute;\r\n AssemblyInformationalVersionAttribute = _AssemblyInformationalVersionAttribute;\r\n CustomAttributeFormatException = _CustomAttributeFormatException;\r\n MethodBase = _MethodBase;\r\n ConstructorInfo = _ConstructorInfo;\r\n DefaultMemberAttribute = _DefaultMemberAttribute;\r\n EventInfo = _EventInfo;\r\n FieldInfo = _FieldInfo;\r\n InvalidFilterCriteriaException = _InvalidFilterCriteriaException;\r\n ManifestResourceInfo = _ManifestResourceInfo;\r\n MemberFilter = _MemberFilter;\r\n MethodInfo = _MethodInfo;\r\n Missing = _Missing;\r\n Module = _Module;\r\n ParameterInfo = _ParameterInfo;\r\n __Pointer = _Pointer;\r\n PropertyInfo = _PropertyInfo;\r\n ReflectionTypeLoadException = _ReflectionTypeLoadException;\r\n StrongNameKeyPair = _StrongNameKeyPair;\r\n TargetException = _TargetException;\r\n TargetInvocationException = _TargetInvocationException;\r\n TargetParameterCountException = _TargetParameterCountException;\r\n TypeDelegator = _TypeDelegator;\r\n TypeFilter = _TypeFilter;\r\n UnmanagedMarshal = _UnmanagedMarshal;\r\n Formatter = _Formatter;\r\n FormatterConverter = _FormatterConverter;\r\n FormatterServices = _FormatterServices;\r\n ObjectIDGenerator = _ObjectIDGenerator;\r\n ObjectManager = _ObjectManager;\r\n SerializationBinder = _SerializationBinder;\r\n SerializationInfo = _SerializationInfo;\r\n SerializationInfoEnumerator = _SerializationInfoEnumerator;\r\n SerializationException = _SerializationException;\r\n SurrogateSelector = _SurrogateSelector;\r\n Calendar = _Calendar;\r\n CompareInfo = _CompareInfo;\r\n CultureInfo = _CultureInfo;\r\n DateTimeFormatInfo = _DateTimeFormatInfo;\r\n DaylightTime = _DaylightTime;\r\n GregorianCalendar = _GregorianCalendar;\r\n HebrewCalendar = _HebrewCalendar;\r\n HijriCalendar = _HijriCalendar;\r\n JapaneseCalendar = _JapaneseCalendar;\r\n JulianCalendar = _JulianCalendar;\r\n KoreanCalendar = _KoreanCalendar;\r\n RegionInfo = _RegionInfo;\r\n SortKey = _SortKey;\r\n StringInfo = _StringInfo;\r\n TaiwanCalendar = _TaiwanCalendar;\r\n TextElementEnumerator = _TextElementEnumerator;\r\n TextInfo = _TextInfo;\r\n ThaiBuddhistCalendar = _ThaiBuddhistCalendar;\r\n NumberFormatInfo = _NumberFormatInfo;\r\n Encoding = _Encoding;\r\n System_Text_Decoder = _System_Text_Decoder;\r\n System_Text_Encoder = _System_Text_Encoder;\r\n ASCIIEncoding = _ASCIIEncoding;\r\n UnicodeEncoding = _UnicodeEncoding;\r\n UTF7Encoding = _UTF7Encoding;\r\n UTF8Encoding = _UTF8Encoding;\r\n MissingManifestResourceException = _MissingManifestResourceException;\r\n NeutralResourcesLanguageAttribute = _NeutralResourcesLanguageAttribute;\r\n ResourceManager = _ResourceManager;\r\n ResourceReader = _ResourceReader;\r\n ResourceSet = _ResourceSet;\r\n ResourceWriter = _ResourceWriter;\r\n SatelliteContractVersionAttribute = _SatelliteContractVersionAttribute;\r\n Registry = _Registry;\r\n RegistryKey = _RegistryKey;\r\n X509Certificate = _X509Certificate;\r\n AsymmetricAlgorithm = _AsymmetricAlgorithm;\r\n AsymmetricKeyExchangeDeformatter = _AsymmetricKeyExchangeDeformatter;\r\n AsymmetricKeyExchangeFormatter = _AsymmetricKeyExchangeFormatter;\r\n AsymmetricSignatureDeformatter = _AsymmetricSignatureDeformatter;\r\n AsymmetricSignatureFormatter = _AsymmetricSignatureFormatter;\r\n ToBase64Transform = _ToBase64Transform;\r\n FromBase64Transform = _FromBase64Transform;\r\n KeySizes = _KeySizes;\r\n CryptographicException = _CryptographicException;\r\n CryptographicUnexpectedOperationException = _CryptographicUnexpectedOperationException;\r\n CryptoAPITransform = _CryptoAPITransform;\r\n CspParameters = _CspParameters;\r\n CryptoConfig = _CryptoConfig;\r\n Stream = _Stream;\r\n CryptoStream = _CryptoStream;\r\n SymmetricAlgorithm = _SymmetricAlgorithm;\r\n DES = _DES;\r\n DESCryptoServiceProvider = _DESCryptoServiceProvider;\r\n DeriveBytes = _DeriveBytes;\r\n DSA = _DSA;\r\n DSACryptoServiceProvider = _DSACryptoServiceProvider;\r\n DSASignatureDeformatter = _DSASignatureDeformatter;\r\n DSASignatureFormatter = _DSASignatureFormatter;\r\n HashAlgorithm = _HashAlgorithm;\r\n KeyedHashAlgorithm = _KeyedHashAlgorithm;\r\n HMACSHA1 = _HMACSHA1;\r\n MACTripleDES = _MACTripleDES;\r\n MD5 = _MD5;\r\n MD5CryptoServiceProvider = _MD5CryptoServiceProvider;\r\n MaskGenerationMethod = _MaskGenerationMethod;\r\n PasswordDeriveBytes = _PasswordDeriveBytes;\r\n PKCS1MaskGenerationMethod = _PKCS1MaskGenerationMethod;\r\n RC2 = _RC2;\r\n RC2CryptoServiceProvider = _RC2CryptoServiceProvider;\r\n RandomNumberGenerator = _RandomNumberGenerator;\r\n RNGCryptoServiceProvider = _RNGCryptoServiceProvider;\r\n RSA = _RSA;\r\n RSACryptoServiceProvider = _RSACryptoServiceProvider;\r\n RSAOAEPKeyExchangeDeformatter = _RSAOAEPKeyExchangeDeformatter;\r\n RSAOAEPKeyExchangeFormatter = _RSAOAEPKeyExchangeFormatter;\r\n RSAPKCS1KeyExchangeDeformatter = _RSAPKCS1KeyExchangeDeformatter;\r\n RSAPKCS1KeyExchangeFormatter = _RSAPKCS1KeyExchangeFormatter;\r\n RSAPKCS1SignatureDeformatter = _RSAPKCS1SignatureDeformatter;\r\n RSAPKCS1SignatureFormatter = _RSAPKCS1SignatureFormatter;\r\n Rijndael = _Rijndael;\r\n RijndaelManaged = _RijndaelManaged;\r\n SHA1 = _SHA1;\r\n SHA1CryptoServiceProvider = _SHA1CryptoServiceProvider;\r\n SHA1Managed = _SHA1Managed;\r\n SHA256 = _SHA256;\r\n SHA256Managed = _SHA256Managed;\r\n SHA384 = _SHA384;\r\n SHA384Managed = _SHA384Managed;\r\n SHA512 = _SHA512;\r\n SHA512Managed = _SHA512Managed;\r\n SignatureDescription = _SignatureDescription;\r\n TripleDES = _TripleDES;\r\n TripleDESCryptoServiceProvider = _TripleDESCryptoServiceProvider;\r\n AllMembershipCondition = _AllMembershipCondition;\r\n ApplicationDirectory = _ApplicationDirectory;\r\n ApplicationDirectoryMembershipCondition = _ApplicationDirectoryMembershipCondition;\r\n CodeGroup = _CodeGroup;\r\n Evidence = _Evidence;\r\n FileCodeGroup = _FileCodeGroup;\r\n FirstMatchCodeGroup = _FirstMatchCodeGroup;\r\n Hash = _Hash;\r\n HashMembershipCondition = _HashMembershipCondition;\r\n NetCodeGroup = _NetCodeGroup;\r\n PermissionRequestEvidence = _PermissionRequestEvidence;\r\n PolicyException = _PolicyException;\r\n PolicyLevel = _PolicyLevel;\r\n PolicyStatement = _PolicyStatement;\r\n Publisher = _Publisher;\r\n PublisherMembershipCondition = _PublisherMembershipCondition;\r\n Site = _Site;\r\n SiteMembershipCondition = _SiteMembershipCondition;\r\n StrongName = _StrongName;\r\n StrongNameMembershipCondition = _StrongNameMembershipCondition;\r\n UnionCodeGroup = _UnionCodeGroup;\r\n Url = _Url;\r\n UrlMembershipCondition = _UrlMembershipCondition;\r\n Zone = _Zone;\r\n ZoneMembershipCondition = _ZoneMembershipCondition;\r\n GenericIdentity = _GenericIdentity;\r\n GenericPrincipal = _GenericPrincipal;\r\n WindowsIdentity = _WindowsIdentity;\r\n WindowsImpersonationContext = _WindowsImpersonationContext;\r\n WindowsPrincipal = _WindowsPrincipal;\r\n DispIdAttribute = _DispIdAttribute;\r\n InterfaceTypeAttribute = _InterfaceTypeAttribute;\r\n ClassInterfaceAttribute = _ClassInterfaceAttribute;\r\n ComVisibleAttribute = _ComVisibleAttribute;\r\n LCIDConversionAttribute = _LCIDConversionAttribute;\r\n ComRegisterFunctionAttribute = _ComRegisterFunctionAttribute;\r\n ComUnregisterFunctionAttribute = _ComUnregisterFunctionAttribute;\r\n ProgIdAttribute = _ProgIdAttribute;\r\n ImportedFromTypeLibAttribute = _ImportedFromTypeLibAttribute;\r\n IDispatchImplAttribute = _IDispatchImplAttribute;\r\n ComSourceInterfacesAttribute = _ComSourceInterfacesAttribute;\r\n ComConversionLossAttribute = _ComConversionLossAttribute;\r\n TypeLibTypeAttribute = _TypeLibTypeAttribute;\r\n TypeLibFuncAttribute = _TypeLibFuncAttribute;\r\n TypeLibVarAttribute = _TypeLibVarAttribute;\r\n MarshalAsAttribute = _MarshalAsAttribute;\r\n ComImportAttribute = _ComImportAttribute;\r\n GuidAttribute = _GuidAttribute;\r\n PreserveSigAttribute = _PreserveSigAttribute;\r\n InAttribute = _InAttribute;\r\n OutAttribute = _OutAttribute;\r\n OptionalAttribute = _OptionalAttribute;\r\n DllImportAttribute = _DllImportAttribute;\r\n StructLayoutAttribute = _StructLayoutAttribute;\r\n FieldOffsetAttribute = _FieldOffsetAttribute;\r\n ComAliasNameAttribute = _ComAliasNameAttribute;\r\n AutomationProxyAttribute = _AutomationProxyAttribute;\r\n PrimaryInteropAssemblyAttribute = _PrimaryInteropAssemblyAttribute;\r\n CoClassAttribute = _CoClassAttribute;\r\n ComEventInterfaceAttribute = _ComEventInterfaceAttribute;\r\n TypeLibVersionAttribute = _TypeLibVersionAttribute;\r\n ComCompatibleVersionAttribute = _ComCompatibleVersionAttribute;\r\n BestFitMappingAttribute = _BestFitMappingAttribute;\r\n ExternalException = _ExternalException;\r\n COMException = _COMException;\r\n CurrencyWrapper = _CurrencyWrapper;\r\n DispatchWrapper = _DispatchWrapper;\r\n ErrorWrapper = _ErrorWrapper;\r\n ExtensibleClassFactory = _ExtensibleClassFactory;\r\n InvalidComObjectException = _InvalidComObjectException;\r\n InvalidOleVariantTypeException = _InvalidOleVariantTypeException;\r\n Marshal = _Marshal;\r\n MarshalDirectiveException = _MarshalDirectiveException;\r\n ObjectCreationDelegate = _ObjectCreationDelegate;\r\n RuntimeEnvironment = _RuntimeEnvironment;\r\n SafeArrayRankMismatchException = _SafeArrayRankMismatchException;\r\n SafeArrayTypeMismatchException = _SafeArrayTypeMismatchException;\r\n SEHException = _SEHException;\r\n UnknownWrapper = _UnknownWrapper;\r\n BinaryReader = _BinaryReader;\r\n BinaryWriter = _BinaryWriter;\r\n BufferedStream = _BufferedStream;\r\n Directory = _Directory;\r\n FileSystemInfo = _FileSystemInfo;\r\n DirectoryInfo = _DirectoryInfo;\r\n IOException = _IOException;\r\n DirectoryNotFoundException = _DirectoryNotFoundException;\r\n EndOfStreamException = _EndOfStreamException;\r\n File_ = _File;\r\n FileInfo = _FileInfo;\r\n FileLoadException = _FileLoadException;\r\n FileNotFoundException = _FileNotFoundException;\r\n FileStream = _FileStream;\r\n MemoryStream = _MemoryStream;\r\n Path = _Path;\r\n PathTooLongException = _PathTooLongException;\r\n TextReader = _TextReader;\r\n StreamReader = _StreamReader;\r\n TextWriter = _TextWriter;\r\n StreamWriter = _StreamWriter;\r\n StringReader = _StringReader;\r\n StringWriter = _StringWriter;\r\n AccessedThroughPropertyAttribute = _AccessedThroughPropertyAttribute;\r\n CallConvCdecl = _CallConvCdecl;\r\n CallConvStdcall = _CallConvStdcall;\r\n CallConvThiscall = _CallConvThiscall;\r\n CallConvFastcall = _CallConvFastcall;\r\n RuntimeHelpers = _RuntimeHelpers;\r\n CustomConstantAttribute = _CustomConstantAttribute;\r\n DateTimeConstantAttribute = _DateTimeConstantAttribute;\r\n DiscardableAttribute = _DiscardableAttribute;\r\n DecimalConstantAttribute = _DecimalConstantAttribute;\r\n CompilationRelaxationsAttribute = _CompilationRelaxationsAttribute;\r\n CompilerGlobalScopeAttribute = _CompilerGlobalScopeAttribute;\r\n IDispatchConstantAttribute = _IDispatchConstantAttribute;\r\n IndexerNameAttribute = _IndexerNameAttribute;\r\n IsVolatile = _IsVolatile;\r\n IUnknownConstantAttribute = _IUnknownConstantAttribute;\r\n MethodImplAttribute = _MethodImplAttribute;\r\n RequiredAttributeAttribute = _RequiredAttributeAttribute;\r\n PermissionSet = _PermissionSet;\r\n NamedPermissionSet = _NamedPermissionSet;\r\n SecurityElement = _SecurityElement;\r\n XmlSyntaxException = _XmlSyntaxException;\r\n CodeAccessPermission = _CodeAccessPermission;\r\n EnvironmentPermission = _EnvironmentPermission;\r\n FileDialogPermission = _FileDialogPermission;\r\n FileIOPermission = _FileIOPermission;\r\n IsolatedStoragePermission = _IsolatedStoragePermission;\r\n IsolatedStorageFilePermission = _IsolatedStorageFilePermission;\r\n SecurityAttribute = _SecurityAttribute;\r\n CodeAccessSecurityAttribute = _CodeAccessSecurityAttribute;\r\n EnvironmentPermissionAttribute = _EnvironmentPermissionAttribute;\r\n FileDialogPermissionAttribute = _FileDialogPermissionAttribute;\r\n FileIOPermissionAttribute = _FileIOPermissionAttribute;\r\n PrincipalPermissionAttribute = _PrincipalPermissionAttribute;\r\n ReflectionPermissionAttribute = _ReflectionPermissionAttribute;\r\n RegistryPermissionAttribute = _RegistryPermissionAttribute;\r\n SecurityPermissionAttribute = _SecurityPermissionAttribute;\r\n UIPermissionAttribute = _UIPermissionAttribute;\r\n ZoneIdentityPermissionAttribute = _ZoneIdentityPermissionAttribute;\r\n StrongNameIdentityPermissionAttribute = _StrongNameIdentityPermissionAttribute;\r\n SiteIdentityPermissionAttribute = _SiteIdentityPermissionAttribute;\r\n UrlIdentityPermissionAttribute = _UrlIdentityPermissionAttribute;\r\n PublisherIdentityPermissionAttribute = _PublisherIdentityPermissionAttribute;\r\n IsolatedStoragePermissionAttribute = _IsolatedStoragePermissionAttribute;\r\n IsolatedStorageFilePermissionAttribute = _IsolatedStorageFilePermissionAttribute;\r\n PermissionSetAttribute = _PermissionSetAttribute;\r\n PublisherIdentityPermission = _PublisherIdentityPermission;\r\n ReflectionPermission = _ReflectionPermission;\r\n RegistryPermission = _RegistryPermission;\r\n PrincipalPermission = _PrincipalPermission;\r\n SecurityPermission = _SecurityPermission;\r\n SiteIdentityPermission = _SiteIdentityPermission;\r\n StrongNameIdentityPermission = _StrongNameIdentityPermission;\r\n StrongNamePublicKeyBlob = _StrongNamePublicKeyBlob;\r\n UIPermission = _UIPermission;\r\n UrlIdentityPermission = _UrlIdentityPermission;\r\n ZoneIdentityPermission = _ZoneIdentityPermission;\r\n SuppressUnmanagedCodeSecurityAttribute = _SuppressUnmanagedCodeSecurityAttribute;\r\n UnverifiableCodeAttribute = _UnverifiableCodeAttribute;\r\n AllowPartiallyTrustedCallersAttribute = _AllowPartiallyTrustedCallersAttribute;\r\n SecurityException = _SecurityException;\r\n SecurityManager = _SecurityManager;\r\n VerificationException = _VerificationException;\r\n ContextAttribute = _ContextAttribute;\r\n AsyncResult = _AsyncResult;\r\n CallContext = _CallContext;\r\n LogicalCallContext = _LogicalCallContext;\r\n ChannelServices = _ChannelServices;\r\n ClientChannelSinkStack = _ClientChannelSinkStack;\r\n ServerChannelSinkStack = _ServerChannelSinkStack;\r\n InternalMessageWrapper = _InternalMessageWrapper;\r\n MethodCallMessageWrapper = _MethodCallMessageWrapper;\r\n ClientSponsor = _ClientSponsor;\r\n CrossContextDelegate = _CrossContextDelegate;\r\n Context = _Context;\r\n ContextProperty = _ContextProperty;\r\n EnterpriseServicesHelper = _EnterpriseServicesHelper;\r\n Header = _Header;\r\n HeaderHandler = _HeaderHandler;\r\n ChannelDataStore = _ChannelDataStore;\r\n TransportHeaders = _TransportHeaders;\r\n SinkProviderData = _SinkProviderData;\r\n BaseChannelObjectWithProperties = _BaseChannelObjectWithProperties;\r\n BaseChannelSinkWithProperties = _BaseChannelSinkWithProperties;\r\n BaseChannelWithProperties = _BaseChannelWithProperties;\r\n LifetimeServices = _LifetimeServices;\r\n ReturnMessage = _ReturnMessage;\r\n MethodCall = _MethodCall;\r\n ConstructionCall = _ConstructionCall;\r\n MethodResponse = _MethodResponse;\r\n ConstructionResponse = _ConstructionResponse;\r\n MethodReturnMessageWrapper = _MethodReturnMessageWrapper;\r\n ObjectHandle = _ObjectHandle;\r\n ObjRef = _ObjRef;\r\n OneWayAttribute = _OneWayAttribute;\r\n ProxyAttribute = _ProxyAttribute;\r\n RealProxy = _RealProxy;\r\n SoapAttribute = _SoapAttribute;\r\n SoapTypeAttribute = _SoapTypeAttribute;\r\n SoapMethodAttribute = _SoapMethodAttribute;\r\n SoapFieldAttribute = _SoapFieldAttribute;\r\n SoapParameterAttribute = _SoapParameterAttribute;\r\n RemotingConfiguration = _RemotingConfiguration;\r\n System_Runtime_Remoting_TypeEntry = _System_Runtime_Remoting_TypeEntry;\r\n ActivatedClientTypeEntry = _ActivatedClientTypeEntry;\r\n ActivatedServiceTypeEntry = _ActivatedServiceTypeEntry;\r\n WellKnownClientTypeEntry = _WellKnownClientTypeEntry;\r\n WellKnownServiceTypeEntry = _WellKnownServiceTypeEntry;\r\n RemotingException = _RemotingException;\r\n ServerException = _ServerException;\r\n RemotingTimeoutException = _RemotingTimeoutException;\r\n RemotingServices = _RemotingServices;\r\n InternalRemotingServices = _InternalRemotingServices;\r\n MessageSurrogateFilter = _MessageSurrogateFilter;\r\n RemotingSurrogateSelector = _RemotingSurrogateSelector;\r\n SoapServices = _SoapServices;\r\n SoapDateTime = _SoapDateTime;\r\n SoapDuration = _SoapDuration;\r\n SoapTime = _SoapTime;\r\n SoapDate = _SoapDate;\r\n SoapYearMonth = _SoapYearMonth;\r\n SoapYear = _SoapYear;\r\n SoapMonthDay = _SoapMonthDay;\r\n SoapDay = _SoapDay;\r\n SoapMonth = _SoapMonth;\r\n SoapHexBinary = _SoapHexBinary;\r\n SoapBase64Binary = _SoapBase64Binary;\r\n SoapInteger = _SoapInteger;\r\n SoapPositiveInteger = _SoapPositiveInteger;\r\n SoapNonPositiveInteger = _SoapNonPositiveInteger;\r\n SoapNonNegativeInteger = _SoapNonNegativeInteger;\r\n SoapNegativeInteger = _SoapNegativeInteger;\r\n SoapAnyUri = _SoapAnyUri;\r\n SoapQName = _SoapQName;\r\n SoapNotation = _SoapNotation;\r\n SoapNormalizedString = _SoapNormalizedString;\r\n SoapToken = _SoapToken;\r\n SoapLanguage = _SoapLanguage;\r\n SoapName = _SoapName;\r\n SoapIdrefs = _SoapIdrefs;\r\n SoapEntities = _SoapEntities;\r\n SoapNmtoken = _SoapNmtoken;\r\n SoapNmtokens = _SoapNmtokens;\r\n SoapNcName = _SoapNcName;\r\n SoapId = _SoapId;\r\n SoapIdref = _SoapIdref;\r\n SoapEntity = _SoapEntity;\r\n SynchronizationAttribute = _SynchronizationAttribute;\r\n TrackingServices = _TrackingServices;\r\n UrlAttribute = _UrlAttribute;\r\n IsolatedStorage = _IsolatedStorage;\r\n IsolatedStorageFile = _IsolatedStorageFile;\r\n IsolatedStorageFileStream = _IsolatedStorageFileStream;\r\n IsolatedStorageException = _IsolatedStorageException;\r\n InternalRM = _InternalRM;\r\n InternalST = _InternalST;\r\n SoapMessage = _SoapMessage;\r\n SoapFault = _SoapFault;\r\n ServerFault = _ServerFault;\r\n BinaryFormatter = _BinaryFormatter;\r\n AssemblyBuilder = _AssemblyBuilder;\r\n ConstructorBuilder = _ConstructorBuilder;\r\n EventBuilder = _EventBuilder;\r\n FieldBuilder = _FieldBuilder;\r\n ILGenerator = _ILGenerator;\r\n LocalBuilder = _LocalBuilder;\r\n MethodBuilder = _MethodBuilder;\r\n CustomAttributeBuilder = _CustomAttributeBuilder;\r\n MethodRental = _MethodRental;\r\n ModuleBuilder = _ModuleBuilder;\r\n OpCodes = _OpCodes;\r\n ParameterBuilder = _ParameterBuilder;\r\n PropertyBuilder = _PropertyBuilder;\r\n SignatureHelper = _SignatureHelper;\r\n TypeBuilder = _TypeBuilder;\r\n EnumBuilder = _EnumBuilder;\r\n\r\n\r\n// *********************************************************************//\r\n// Declaration of structures, unions and aliases. \r\n// *********************************************************************//\r\n DateTime = packed record\r\n ticks: Int64;\r\n end;\r\n\r\n ArgIterator = packed record\r\n ArgCookie: Integer;\r\n SigPtr: Integer;\r\n ArgPtr: Integer;\r\n RemainingArgs: Integer;\r\n end;\r\n\r\n _Boolean = packed record\r\n m_value: Integer;\r\n end;\r\n\r\n _Byte = packed record\r\n m_value: Byte;\r\n end;\r\n\r\n _Char = packed record\r\n m_value: Byte;\r\n end;\r\n\r\n Decimal = packed record\r\n flags: Integer;\r\n hi: Integer;\r\n lo: Integer;\r\n mid: Integer;\r\n end;\r\n\r\n _Double = packed record\r\n m_value: Double;\r\n end;\r\n\r\n Guid = packed record\r\n _a: Integer;\r\n _b: Smallint;\r\n _c: Smallint;\r\n _d: Byte;\r\n _e: Byte;\r\n _f: Byte;\r\n _g: Byte;\r\n _h: Byte;\r\n _i: Byte;\r\n _j: Byte;\r\n _k: Byte;\r\n end;\r\n\r\n Int16 = packed record\r\n m_value: Smallint;\r\n end;\r\n\r\n Int32 = packed record\r\n m_value: Integer;\r\n end;\r\n\r\n _Int64 = packed record\r\n m_value: Int64;\r\n end;\r\n\r\n IntPtr = packed record\r\n m_value: Pointer;\r\n end;\r\n\r\n RuntimeArgumentHandle = packed record\r\n m_ptr: Integer;\r\n end;\r\n\r\n RuntimeFieldHandle = packed record\r\n m_ptr: Integer;\r\n end;\r\n\r\n RuntimeMethodHandle = packed record\r\n m_ptr: Integer;\r\n end;\r\n\r\n RuntimeTypeHandle = packed record\r\n m_ptr: Integer;\r\n end;\r\n\r\n SByte = packed record\r\n m_value: Shortint;\r\n end;\r\n\r\n _Single = packed record\r\n m_value: Single;\r\n end;\r\n\r\n TimeSpan = packed record\r\n _ticks: Int64;\r\n end;\r\n\r\n TypedReference = packed record\r\n value: Integer;\r\n Type_: Integer;\r\n end;\r\n\r\n UInt16 = packed record\r\n m_value: Word;\r\n end;\r\n\r\n UInt32 = packed record\r\n m_value: LongWord;\r\n end;\r\n\r\n {$IFNDEF FPC}\r\n UInt64 = packed record\r\n m_value: Largeuint;\r\n end;\r\n {$ENDIF ~FPC}\r\n\r\n UIntPtr = packed record\r\n m_value: Pointer;\r\n end;\r\n\r\n Void = packed record\r\n end;\r\n\r\n LockCookie = packed record\r\n _dwFlags: Integer;\r\n _dwWriterSeqNum: Integer;\r\n _wReaderAndWriterLevel: Integer;\r\n _dwThreadID: Integer;\r\n end;\r\n\r\n GCHandle = packed record\r\n m_handle: Integer;\r\n end;\r\n\r\n DictionaryEntry = packed record\r\n _key: IUnknown;\r\n _value: IUnknown;\r\n end;\r\n\r\n SymbolToken = packed record\r\n m_token: Integer;\r\n end;\r\n\r\n InterfaceMapping = packed record\r\n TargetType: _Type;\r\n interfaceType: _Type;\r\n TargetMethods: PSafeArray;\r\n InterfaceMethods: PSafeArray;\r\n end;\r\n\r\n ParameterModifier = packed record\r\n _byRef: PSafeArray;\r\n end;\r\n\r\n SerializationEntry = packed record\r\n m_type: _Type;\r\n m_value: IUnknown;\r\n m_name: PChar;\r\n end;\r\n\r\n StreamingContext = packed record\r\n m_additionalContext: IUnknown;\r\n m_state: StreamingContextStates;\r\n end;\r\n\r\n DSAParameters = packed record\r\n P: PSafeArray;\r\n Q: PSafeArray;\r\n G: PSafeArray;\r\n y: PSafeArray;\r\n J: PSafeArray;\r\n x: PSafeArray;\r\n Seed: PSafeArray;\r\n Counter: Integer;\r\n end;\r\n\r\n RSAParameters = packed record\r\n Exponent: PSafeArray;\r\n Modulus: PSafeArray;\r\n P: PSafeArray;\r\n Q: PSafeArray;\r\n DP: PSafeArray;\r\n DQ: PSafeArray;\r\n InverseQ: PSafeArray;\r\n D: PSafeArray;\r\n end;\r\n\r\n ArrayWithOffset = packed record\r\n m_array: IUnknown;\r\n m_offset: Integer;\r\n m_count: Integer;\r\n end;\r\n\r\n NativeOverlapped = packed record\r\n InternalLow: Integer;\r\n InternalHigh: Integer;\r\n OffsetLow: Integer;\r\n OffsetHigh: Integer;\r\n EventHandle: Integer;\r\n ReservedCOR1: Integer;\r\n ReservedCOR2: GCHandle;\r\n ReservedCOR3: Integer;\r\n ReservedClasslib: GCHandle;\r\n end;\r\n\r\n HandleRef = packed record\r\n m_wrapper: IUnknown;\r\n m_handle: Integer;\r\n end;\r\n\r\n EventToken = packed record\r\n m_event: Integer;\r\n end;\r\n\r\n FieldToken = packed record\r\n m_fieldTok: Integer;\r\n m_class: IUnknown;\r\n end;\r\n\r\n Label_ = packed record\r\n m_label: Integer;\r\n end;\r\n\r\n MethodToken = packed record\r\n m_method: Integer;\r\n end;\r\n\r\n OpCode = packed record\r\n m_stringname: PChar;\r\n m_pop: StackBehaviour;\r\n m_push: StackBehaviour;\r\n m_operand: OperandType;\r\n m_type: OpCodeType;\r\n m_size: Integer;\r\n m_s1: Byte;\r\n m_s2: Byte;\r\n m_ctrl: FlowControl;\r\n m_endsUncondJmpBlk: Integer;\r\n m_stackChange: Integer;\r\n end;\r\n\r\n ParameterToken = packed record\r\n m_tkParameter: Integer;\r\n end;\r\n\r\n PropertyToken = packed record\r\n m_property: Integer;\r\n end;\r\n\r\n SignatureToken = packed record\r\n m_signature: Integer;\r\n m_moduleBuilder: _ModuleBuilder;\r\n end;\r\n\r\n StringToken = packed record\r\n m_string: Integer;\r\n end;\r\n\r\n TypeToken = packed record\r\n m_class: Integer;\r\n end;\r\n\r\n AssemblyHash = packed record\r\n _Algorithm: AssemblyHashAlgorithm;\r\n _value: PSafeArray;\r\n end;\r\n\r\n\r\n// *********************************************************************//\r\n// Interface: _Object\r\n// Flags: (4560) Hidden Dual NonExtensible OleAutomation Dispatchable\r\n// GUID: {65074F7F-63C0-304E-AF0A-D51741CB4A8D}\r\n// *********************************************************************//\r\n _Object = interface(IDispatch)\r\n ['{65074F7F-63C0-304E-AF0A-D51741CB4A8D}']\r\n function Get_ToString: WideString; safecall;\r\n function Equals(obj: OleVariant): WordBool; safecall;\r\n function GetHashCode: Integer; safecall;\r\n function GetType: _Type; safecall;\r\n property ToString: WideString read Get_ToString;\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _ObjectDisp\r\n// Flags: (4560) Hidden Dual NonExtensible OleAutomation Dispatchable\r\n// GUID: {65074F7F-63C0-304E-AF0A-D51741CB4A8D}\r\n// *********************************************************************//\r\n _ObjectDisp = dispinterface\r\n ['{65074F7F-63C0-304E-AF0A-D51741CB4A8D}']\r\n property ToString: WideString readonly dispid 0;\r\n function Equals(obj: OleVariant): WordBool; dispid 1610743809;\r\n function GetHashCode: Integer; dispid 1610743810;\r\n function GetType: _Type; dispid 1610743811;\r\n end;\r\n {$EXTERNALSYM _ObjectDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: ICloneable\r\n// Flags: (4416) Dual OleAutomation Dispatchable\r\n// GUID: {0CB251A7-3AB3-3B5C-A0B8-9DDF88824B85}\r\n// *********************************************************************//\r\n ICloneable = interface(IDispatch)\r\n ['{0CB251A7-3AB3-3B5C-A0B8-9DDF88824B85}']\r\n function Clone: OleVariant; safecall;\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: ICloneableDisp\r\n// Flags: (4416) Dual OleAutomation Dispatchable\r\n// GUID: {0CB251A7-3AB3-3B5C-A0B8-9DDF88824B85}\r\n// *********************************************************************//\r\n ICloneableDisp = dispinterface\r\n ['{0CB251A7-3AB3-3B5C-A0B8-9DDF88824B85}']\r\n function Clone: OleVariant; dispid 1610743808;\r\n end;\r\n {$EXTERNALSYM ICloneableDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: IEnumerable\r\n// Flags: (4416) Dual OleAutomation Dispatchable\r\n// GUID: {496B0ABE-CDEE-11D3-88E8-00902754C43A}\r\n// *********************************************************************//\r\n IEnumerable = interface(IDispatch)\r\n ['{496B0ABE-CDEE-11D3-88E8-00902754C43A}']\r\n function GetEnumerator: IEnumVARIANT; safecall;\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: IEnumerableDisp\r\n// Flags: (4416) Dual OleAutomation Dispatchable\r\n// GUID: {496B0ABE-CDEE-11D3-88E8-00902754C43A}\r\n// *********************************************************************//\r\n IEnumerableDisp = dispinterface\r\n ['{496B0ABE-CDEE-11D3-88E8-00902754C43A}']\r\n function GetEnumerator: IEnumVARIANT; dispid -4;\r\n end;\r\n {$EXTERNALSYM IEnumerableDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: ICollection\r\n// Flags: (4416) Dual OleAutomation Dispatchable\r\n// GUID: {DE8DB6F8-D101-3A92-8D1C-E72E5F10E992}\r\n// *********************************************************************//\r\n ICollection = interface(IDispatch)\r\n ['{DE8DB6F8-D101-3A92-8D1C-E72E5F10E992}']\r\n procedure CopyTo(const Array_: _Array; index: Integer); safecall;\r\n function Get_Count: Integer; safecall;\r\n function Get_SyncRoot: OleVariant; safecall;\r\n function Get_IsSynchronized: WordBool; safecall;\r\n property Count: Integer read Get_Count;\r\n property SyncRoot: OleVariant read Get_SyncRoot;\r\n property IsSynchronized: WordBool read Get_IsSynchronized;\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: ICollectionDisp\r\n// Flags: (4416) Dual OleAutomation Dispatchable\r\n// GUID: {DE8DB6F8-D101-3A92-8D1C-E72E5F10E992}\r\n// *********************************************************************//\r\n ICollectionDisp = dispinterface\r\n ['{DE8DB6F8-D101-3A92-8D1C-E72E5F10E992}']\r\n procedure CopyTo(const Array_: _Array; index: Integer); dispid 1610743808;\r\n property Count: Integer readonly dispid 1610743809;\r\n property SyncRoot: OleVariant readonly dispid 1610743810;\r\n property IsSynchronized: WordBool readonly dispid 1610743811;\r\n end;\r\n {$EXTERNALSYM ICollectionDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: IList\r\n// Flags: (4416) Dual OleAutomation Dispatchable\r\n// GUID: {7BCFA00F-F764-3113-9140-3BBD127A96BB}\r\n// *********************************************************************//\r\n IList = interface(IDispatch)\r\n ['{7BCFA00F-F764-3113-9140-3BBD127A96BB}']\r\n function Get_Item(index: Integer): OleVariant; safecall;\r\n procedure _Set_Item(index: Integer; pRetVal: OleVariant); safecall;\r\n function Add(value: OleVariant): Integer; safecall;\r\n function Contains(value: OleVariant): WordBool; safecall;\r\n procedure Clear; safecall;\r\n function Get_IsReadOnly: WordBool; safecall;\r\n function Get_IsFixedSize: WordBool; safecall;\r\n function IndexOf(value: OleVariant): Integer; safecall;\r\n procedure Insert(index: Integer; value: OleVariant); safecall;\r\n procedure Remove(value: OleVariant); safecall;\r\n procedure RemoveAt(index: Integer); safecall;\r\n property Item[index: Integer]: OleVariant read Get_Item write _Set_Item; default;\r\n property IsReadOnly: WordBool read Get_IsReadOnly;\r\n property IsFixedSize: WordBool read Get_IsFixedSize;\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: IListDisp\r\n// Flags: (4416) Dual OleAutomation Dispatchable\r\n// GUID: {7BCFA00F-F764-3113-9140-3BBD127A96BB}\r\n// *********************************************************************//\r\n IListDisp = dispinterface\r\n ['{7BCFA00F-F764-3113-9140-3BBD127A96BB}']\r\n property Item[index: Integer]: OleVariant dispid 0; default;\r\n function Add(value: OleVariant): Integer; dispid 1610743810;\r\n function Contains(value: OleVariant): WordBool; dispid 1610743811;\r\n procedure Clear; dispid 1610743812;\r\n property IsReadOnly: WordBool readonly dispid 1610743813;\r\n property IsFixedSize: WordBool readonly dispid 1610743814;\r\n function IndexOf(value: OleVariant): Integer; dispid 1610743815;\r\n procedure Insert(index: Integer; value: OleVariant); dispid 1610743816;\r\n procedure Remove(value: OleVariant); dispid 1610743817;\r\n procedure RemoveAt(index: Integer); dispid 1610743818;\r\n end;\r\n {$EXTERNALSYM IListDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _Array\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {2B67CECE-71C3-36A9-A136-925CCC1935A8}\r\n// *********************************************************************//\r\n _Array = interface(IDispatch)\r\n ['{2B67CECE-71C3-36A9-A136-925CCC1935A8}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _ArrayDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {2B67CECE-71C3-36A9-A136-925CCC1935A8}\r\n// *********************************************************************//\r\n _ArrayDisp = dispinterface\r\n ['{2B67CECE-71C3-36A9-A136-925CCC1935A8}']\r\n end;\r\n {$EXTERNALSYM _ArrayDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: IEnumerator\r\n// Flags: (4416) Dual OleAutomation Dispatchable\r\n// GUID: {496B0ABF-CDEE-11D3-88E8-00902754C43A}\r\n// *********************************************************************//\r\n IEnumerator = interface(IDispatch)\r\n ['{496B0ABF-CDEE-11D3-88E8-00902754C43A}']\r\n function MoveNext: WordBool; safecall;\r\n function Get_Current: OleVariant; safecall;\r\n procedure Reset; safecall;\r\n property Current: OleVariant read Get_Current;\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: IEnumeratorDisp\r\n// Flags: (4416) Dual OleAutomation Dispatchable\r\n// GUID: {496B0ABF-CDEE-11D3-88E8-00902754C43A}\r\n// *********************************************************************//\r\n IEnumeratorDisp = dispinterface\r\n ['{496B0ABF-CDEE-11D3-88E8-00902754C43A}']\r\n function MoveNext: WordBool; dispid 1610743808;\r\n property Current: OleVariant readonly dispid 1610743809;\r\n procedure Reset; dispid 1610743810;\r\n end;\r\n {$EXTERNALSYM IEnumeratorDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: IComparable\r\n// Flags: (4416) Dual OleAutomation Dispatchable\r\n// GUID: {DEB0E770-91FD-3CF6-9A6C-E6A3656F3965}\r\n// *********************************************************************//\r\n IComparable = interface(IDispatch)\r\n ['{DEB0E770-91FD-3CF6-9A6C-E6A3656F3965}']\r\n function CompareTo(obj: OleVariant): Integer; safecall;\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: IComparableDisp\r\n// Flags: (4416) Dual OleAutomation Dispatchable\r\n// GUID: {DEB0E770-91FD-3CF6-9A6C-E6A3656F3965}\r\n// *********************************************************************//\r\n IComparableDisp = dispinterface\r\n ['{DEB0E770-91FD-3CF6-9A6C-E6A3656F3965}']\r\n function CompareTo(obj: OleVariant): Integer; dispid 1610743808;\r\n end;\r\n {$EXTERNALSYM IComparableDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: IConvertible\r\n// Flags: (4416) Dual OleAutomation Dispatchable\r\n// GUID: {805E3B62-B5E9-393D-8941-377D8BF4556B}\r\n// *********************************************************************//\r\n IConvertible = interface(IDispatch)\r\n ['{805E3B62-B5E9-393D-8941-377D8BF4556B}']\r\n function GetTypeCode: TypeCode; safecall;\r\n function ToBoolean(const provider: IFormatProvider): WordBool; safecall;\r\n function ToChar(const provider: IFormatProvider): Word; safecall;\r\n function ToSByte(const provider: IFormatProvider): Shortint; safecall;\r\n function ToByte(const provider: IFormatProvider): Byte; safecall;\r\n function ToInt16(const provider: IFormatProvider): Smallint; safecall;\r\n function ToUInt16(const provider: IFormatProvider): Word; safecall;\r\n function ToInt32(const provider: IFormatProvider): Integer; safecall;\r\n function ToUInt32(const provider: IFormatProvider): LongWord; safecall;\r\n function ToInt64(const provider: IFormatProvider): Int64; safecall;\r\n function ToUInt64(const provider: IFormatProvider): Largeuint; safecall;\r\n function ToSingle(const provider: IFormatProvider): Single; safecall;\r\n function ToDouble(const provider: IFormatProvider): Double; safecall;\r\n function ToDecimal(const provider: IFormatProvider): TDecimal; safecall;\r\n function ToDateTime(const provider: IFormatProvider): TDateTime; safecall;\r\n function Get_ToString(const provider: IFormatProvider): WideString; safecall;\r\n function ToType(const conversionType: _Type; const provider: IFormatProvider): OleVariant; safecall;\r\n property ToString[const provider: IFormatProvider]: WideString read Get_ToString;\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: IConvertibleDisp\r\n// Flags: (4416) Dual OleAutomation Dispatchable\r\n// GUID: {805E3B62-B5E9-393D-8941-377D8BF4556B}\r\n// *********************************************************************//\r\n IConvertibleDisp = dispinterface\r\n ['{805E3B62-B5E9-393D-8941-377D8BF4556B}']\r\n function GetTypeCode: TypeCode; dispid 1610743808;\r\n function ToBoolean(const provider: IFormatProvider): WordBool; dispid 1610743809;\r\n function ToChar(const provider: IFormatProvider): {??Word}OleVariant; dispid 1610743810;\r\n function ToSByte(const provider: IFormatProvider): {??Shortint}OleVariant; dispid 1610743811;\r\n function ToByte(const provider: IFormatProvider): Byte; dispid 1610743812;\r\n function ToInt16(const provider: IFormatProvider): Smallint; dispid 1610743813;\r\n function ToUInt16(const provider: IFormatProvider): {??Word}OleVariant; dispid 1610743814;\r\n function ToInt32(const provider: IFormatProvider): Integer; dispid 1610743815;\r\n function ToUInt32(const provider: IFormatProvider): LongWord; dispid 1610743816;\r\n function ToInt64(const provider: IFormatProvider): {??Int64}OleVariant; dispid 1610743817;\r\n function ToUInt64(const provider: IFormatProvider): {??Largeuint}OleVariant; dispid 1610743818;\r\n function ToSingle(const provider: IFormatProvider): Single; dispid 1610743819;\r\n function ToDouble(const provider: IFormatProvider): Double; dispid 1610743820;\r\n function ToDecimal(const provider: IFormatProvider): {??TDecimal}OleVariant; dispid 1610743821;\r\n function ToDateTime(const provider: IFormatProvider): TDateTime; dispid 1610743822;\r\n property ToString[const provider: IFormatProvider]: WideString readonly dispid 1610743823;\r\n function ToType(const conversionType: _Type; const provider: IFormatProvider): OleVariant; dispid 1610743824;\r\n end;\r\n {$EXTERNALSYM IConvertibleDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _String\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {36936699-FC79-324D-AB43-E33C1F94E263}\r\n// *********************************************************************//\r\n _String = interface(IDispatch)\r\n ['{36936699-FC79-324D-AB43-E33C1F94E263}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _StringDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {36936699-FC79-324D-AB43-E33C1F94E263}\r\n// *********************************************************************//\r\n _StringDisp = dispinterface\r\n ['{36936699-FC79-324D-AB43-E33C1F94E263}']\r\n end;\r\n {$EXTERNALSYM _StringDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _StringBuilder\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {9FB09782-8D39-3B0C-B79E-F7A37A65B3DA}\r\n// *********************************************************************//\r\n _StringBuilder = interface(IDispatch)\r\n ['{9FB09782-8D39-3B0C-B79E-F7A37A65B3DA}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _StringBuilderDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {9FB09782-8D39-3B0C-B79E-F7A37A65B3DA}\r\n// *********************************************************************//\r\n _StringBuilderDisp = dispinterface\r\n ['{9FB09782-8D39-3B0C-B79E-F7A37A65B3DA}']\r\n end;\r\n {$EXTERNALSYM _StringBuilderDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: ISerializable\r\n// Flags: (4416) Dual OleAutomation Dispatchable\r\n// GUID: {D0EEAA62-3D30-3EE2-B896-A2F34DDA47D8}\r\n// *********************************************************************//\r\n ISerializable = interface(IDispatch)\r\n ['{D0EEAA62-3D30-3EE2-B896-A2F34DDA47D8}']\r\n procedure GetObjectData(const info: _SerializationInfo; Context: StreamingContext); safecall;\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: ISerializableDisp\r\n// Flags: (4416) Dual OleAutomation Dispatchable\r\n// GUID: {D0EEAA62-3D30-3EE2-B896-A2F34DDA47D8}\r\n// *********************************************************************//\r\n ISerializableDisp = dispinterface\r\n ['{D0EEAA62-3D30-3EE2-B896-A2F34DDA47D8}']\r\n procedure GetObjectData(const info: _SerializationInfo; Context: {??StreamingContext}OleVariant); dispid 1610743808;\r\n end;\r\n {$EXTERNALSYM ISerializableDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _Exception\r\n// Flags: (4560) Hidden Dual NonExtensible OleAutomation Dispatchable\r\n// GUID: {B36B5C63-42EF-38BC-A07E-0B34C98F164A}\r\n// *********************************************************************//\r\n _Exception = interface(IDispatch)\r\n ['{B36B5C63-42EF-38BC-A07E-0B34C98F164A}']\r\n function Get_ToString: WideString; safecall;\r\n function Equals(obj: OleVariant): WordBool; safecall;\r\n function GetHashCode: Integer; safecall;\r\n function GetType: _Type; safecall;\r\n function Get_Message: WideString; safecall;\r\n function GetBaseException: _Exception; safecall;\r\n function Get_StackTrace: WideString; safecall;\r\n function Get_HelpLink: WideString; safecall;\r\n procedure Set_HelpLink(const pRetVal: WideString); safecall;\r\n function Get_Source: WideString; safecall;\r\n procedure Set_Source(const pRetVal: WideString); safecall;\r\n procedure GetObjectData(const info: _SerializationInfo; Context: StreamingContext); safecall;\r\n function Get_InnerException: _Exception; safecall;\r\n function Get_TargetSite: _MethodBase; safecall;\r\n property ToString: WideString read Get_ToString;\r\n property Message: WideString read Get_Message;\r\n property StackTrace: WideString read Get_StackTrace;\r\n property HelpLink: WideString read Get_HelpLink;\r\n property Source: WideString read Get_Source;\r\n property InnerException: _Exception read Get_InnerException;\r\n property TargetSite: _MethodBase read Get_TargetSite;\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _ExceptionDisp\r\n// Flags: (4560) Hidden Dual NonExtensible OleAutomation Dispatchable\r\n// GUID: {B36B5C63-42EF-38BC-A07E-0B34C98F164A}\r\n// *********************************************************************//\r\n _ExceptionDisp = dispinterface\r\n ['{B36B5C63-42EF-38BC-A07E-0B34C98F164A}']\r\n property ToString: WideString readonly dispid 0;\r\n function Equals(obj: OleVariant): WordBool; dispid 1610743809;\r\n function GetHashCode: Integer; dispid 1610743810;\r\n function GetType: _Type; dispid 1610743811;\r\n property Message: WideString readonly dispid 1610743812;\r\n function GetBaseException: _Exception; dispid 1610743813;\r\n property StackTrace: WideString readonly dispid 1610743814;\r\n property HelpLink: WideString readonly dispid 1610743815;\r\n property Source: WideString readonly dispid 1610743817;\r\n procedure GetObjectData(const info: _SerializationInfo; Context: {??StreamingContext}OleVariant); dispid 1610743819;\r\n property InnerException: _Exception readonly dispid 1610743820;\r\n property TargetSite: _MethodBase readonly dispid 1610743821;\r\n end;\r\n {$EXTERNALSYM _ExceptionDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _ValueType\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {139E041D-0E41-39F5-A302-C4387E9D0A6C}\r\n// *********************************************************************//\r\n _ValueType = interface(IDispatch)\r\n ['{139E041D-0E41-39F5-A302-C4387E9D0A6C}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _ValueTypeDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {139E041D-0E41-39F5-A302-C4387E9D0A6C}\r\n// *********************************************************************//\r\n _ValueTypeDisp = dispinterface\r\n ['{139E041D-0E41-39F5-A302-C4387E9D0A6C}']\r\n end;\r\n {$EXTERNALSYM _ValueTypeDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: IFormattable\r\n// Flags: (4416) Dual OleAutomation Dispatchable\r\n// GUID: {9A604EE7-E630-3DED-9444-BAAE247075AB}\r\n// *********************************************************************//\r\n IFormattable = interface(IDispatch)\r\n ['{9A604EE7-E630-3DED-9444-BAAE247075AB}']\r\n function Get_ToString(const format: WideString; const formatProvider: IFormatProvider): WideString; safecall;\r\n property ToString[const format: WideString; const formatProvider: IFormatProvider]: WideString read Get_ToString;\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: IFormattableDisp\r\n// Flags: (4416) Dual OleAutomation Dispatchable\r\n// GUID: {9A604EE7-E630-3DED-9444-BAAE247075AB}\r\n// *********************************************************************//\r\n IFormattableDisp = dispinterface\r\n ['{9A604EE7-E630-3DED-9444-BAAE247075AB}']\r\n property ToString[const format: WideString; const formatProvider: IFormatProvider]: WideString readonly dispid 1610743808;\r\n end;\r\n {$EXTERNALSYM IFormattableDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _SystemException\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {4C482CC2-68E9-37C6-8353-9A94BD2D7F0B}\r\n// *********************************************************************//\r\n _SystemException = interface(IDispatch)\r\n ['{4C482CC2-68E9-37C6-8353-9A94BD2D7F0B}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _SystemExceptionDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {4C482CC2-68E9-37C6-8353-9A94BD2D7F0B}\r\n// *********************************************************************//\r\n _SystemExceptionDisp = dispinterface\r\n ['{4C482CC2-68E9-37C6-8353-9A94BD2D7F0B}']\r\n end;\r\n {$EXTERNALSYM _SystemExceptionDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _OutOfMemoryException\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {CF3EDB7E-0574-3383-A44F-292F7C145DB4}\r\n// *********************************************************************//\r\n _OutOfMemoryException = interface(IDispatch)\r\n ['{CF3EDB7E-0574-3383-A44F-292F7C145DB4}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _OutOfMemoryExceptionDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {CF3EDB7E-0574-3383-A44F-292F7C145DB4}\r\n// *********************************************************************//\r\n _OutOfMemoryExceptionDisp = dispinterface\r\n ['{CF3EDB7E-0574-3383-A44F-292F7C145DB4}']\r\n end;\r\n {$EXTERNALSYM _OutOfMemoryExceptionDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _StackOverflowException\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {9CF4339A-2911-3B8A-8F30-E5C6B5BE9A29}\r\n// *********************************************************************//\r\n _StackOverflowException = interface(IDispatch)\r\n ['{9CF4339A-2911-3B8A-8F30-E5C6B5BE9A29}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _StackOverflowExceptionDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {9CF4339A-2911-3B8A-8F30-E5C6B5BE9A29}\r\n// *********************************************************************//\r\n _StackOverflowExceptionDisp = dispinterface\r\n ['{9CF4339A-2911-3B8A-8F30-E5C6B5BE9A29}']\r\n end;\r\n {$EXTERNALSYM _StackOverflowExceptionDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _ExecutionEngineException\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {CCF0139C-79F7-3D0A-AFFE-2B0762C65B07}\r\n// *********************************************************************//\r\n _ExecutionEngineException = interface(IDispatch)\r\n ['{CCF0139C-79F7-3D0A-AFFE-2B0762C65B07}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _ExecutionEngineExceptionDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {CCF0139C-79F7-3D0A-AFFE-2B0762C65B07}\r\n// *********************************************************************//\r\n _ExecutionEngineExceptionDisp = dispinterface\r\n ['{CCF0139C-79F7-3D0A-AFFE-2B0762C65B07}']\r\n end;\r\n {$EXTERNALSYM _ExecutionEngineExceptionDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _Delegate\r\n// Flags: (4560) Hidden Dual NonExtensible OleAutomation Dispatchable\r\n// GUID: {FB6AB00F-5096-3AF8-A33D-D7885A5FA829}\r\n// *********************************************************************//\r\n _Delegate = interface(IDispatch)\r\n ['{FB6AB00F-5096-3AF8-A33D-D7885A5FA829}']\r\n function Get_ToString: WideString; safecall;\r\n function Equals(obj: OleVariant): WordBool; safecall;\r\n function GetHashCode: Integer; safecall;\r\n function GetType: _Type; safecall;\r\n function GetInvocationList: PSafeArray; safecall;\r\n function Clone: OleVariant; safecall;\r\n procedure GetObjectData(const info: _SerializationInfo; Context: StreamingContext); safecall;\r\n function DynamicInvoke(args: PSafeArray): OleVariant; safecall;\r\n function Get_Method: _MethodInfo; safecall;\r\n function Get_Target: OleVariant; safecall;\r\n property ToString: WideString read Get_ToString;\r\n property Method: _MethodInfo read Get_Method;\r\n property Target: OleVariant read Get_Target;\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _DelegateDisp\r\n// Flags: (4560) Hidden Dual NonExtensible OleAutomation Dispatchable\r\n// GUID: {FB6AB00F-5096-3AF8-A33D-D7885A5FA829}\r\n// *********************************************************************//\r\n _DelegateDisp = dispinterface\r\n ['{FB6AB00F-5096-3AF8-A33D-D7885A5FA829}']\r\n property ToString: WideString readonly dispid 0;\r\n function Equals(obj: OleVariant): WordBool; dispid 1610743809;\r\n function GetHashCode: Integer; dispid 1610743810;\r\n function GetType: _Type; dispid 1610743811;\r\n function GetInvocationList: {??PSafeArray}OleVariant; dispid 1610743812;\r\n function Clone: OleVariant; dispid 1610743813;\r\n procedure GetObjectData(const info: _SerializationInfo; Context: {??StreamingContext}OleVariant); dispid 1610743814;\r\n function DynamicInvoke(args: {??PSafeArray}OleVariant): OleVariant; dispid 1610743815;\r\n property Method: _MethodInfo readonly dispid 1610743816;\r\n property Target: OleVariant readonly dispid 1610743817;\r\n end;\r\n {$EXTERNALSYM _DelegateDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _MulticastDelegate\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {16FE0885-9129-3884-A232-90B58C5B2AA9}\r\n// *********************************************************************//\r\n _MulticastDelegate = interface(IDispatch)\r\n ['{16FE0885-9129-3884-A232-90B58C5B2AA9}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _MulticastDelegateDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {16FE0885-9129-3884-A232-90B58C5B2AA9}\r\n// *********************************************************************//\r\n _MulticastDelegateDisp = dispinterface\r\n ['{16FE0885-9129-3884-A232-90B58C5B2AA9}']\r\n end;\r\n {$EXTERNALSYM _MulticastDelegateDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _Enum\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {D09D1E04-D590-39A3-B517-B734A49A9277}\r\n// *********************************************************************//\r\n _Enum = interface(IDispatch)\r\n ['{D09D1E04-D590-39A3-B517-B734A49A9277}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _EnumDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {D09D1E04-D590-39A3-B517-B734A49A9277}\r\n// *********************************************************************//\r\n _EnumDisp = dispinterface\r\n ['{D09D1E04-D590-39A3-B517-B734A49A9277}']\r\n end;\r\n {$EXTERNALSYM _EnumDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _MemberAccessException\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {7EABA4E2-1259-3CF2-B084-9854278E5897}\r\n// *********************************************************************//\r\n _MemberAccessException = interface(IDispatch)\r\n ['{7EABA4E2-1259-3CF2-B084-9854278E5897}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _MemberAccessExceptionDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {7EABA4E2-1259-3CF2-B084-9854278E5897}\r\n// *********************************************************************//\r\n _MemberAccessExceptionDisp = dispinterface\r\n ['{7EABA4E2-1259-3CF2-B084-9854278E5897}']\r\n end;\r\n {$EXTERNALSYM _MemberAccessExceptionDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _Activator\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {03973551-57A1-3900-A2B5-9083E3FF2943}\r\n// *********************************************************************//\r\n _Activator = interface(IDispatch)\r\n ['{03973551-57A1-3900-A2B5-9083E3FF2943}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _ActivatorDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {03973551-57A1-3900-A2B5-9083E3FF2943}\r\n// *********************************************************************//\r\n _ActivatorDisp = dispinterface\r\n ['{03973551-57A1-3900-A2B5-9083E3FF2943}']\r\n end;\r\n {$EXTERNALSYM _ActivatorDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _ApplicationException\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {D81130BF-D627-3B91-A7C7-CEA597093464}\r\n// *********************************************************************//\r\n _ApplicationException = interface(IDispatch)\r\n ['{D81130BF-D627-3B91-A7C7-CEA597093464}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _ApplicationExceptionDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {D81130BF-D627-3B91-A7C7-CEA597093464}\r\n// *********************************************************************//\r\n _ApplicationExceptionDisp = dispinterface\r\n ['{D81130BF-D627-3B91-A7C7-CEA597093464}']\r\n end;\r\n {$EXTERNALSYM _ApplicationExceptionDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _EventArgs\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {1F9EC719-343A-3CB3-8040-3927626777C1}\r\n// *********************************************************************//\r\n _EventArgs = interface(IDispatch)\r\n ['{1F9EC719-343A-3CB3-8040-3927626777C1}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _EventArgsDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {1F9EC719-343A-3CB3-8040-3927626777C1}\r\n// *********************************************************************//\r\n _EventArgsDisp = dispinterface\r\n ['{1F9EC719-343A-3CB3-8040-3927626777C1}']\r\n end;\r\n {$EXTERNALSYM _EventArgsDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _ResolveEventArgs\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {98947CF0-77E7-328E-B709-5DD1AA1C9C96}\r\n// *********************************************************************//\r\n _ResolveEventArgs = interface(IDispatch)\r\n ['{98947CF0-77E7-328E-B709-5DD1AA1C9C96}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _ResolveEventArgsDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {98947CF0-77E7-328E-B709-5DD1AA1C9C96}\r\n// *********************************************************************//\r\n _ResolveEventArgsDisp = dispinterface\r\n ['{98947CF0-77E7-328E-B709-5DD1AA1C9C96}']\r\n end;\r\n {$EXTERNALSYM _ResolveEventArgsDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _AssemblyLoadEventArgs\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {7A0325F0-22C2-31F9-8823-9B8AEE9456B1}\r\n// *********************************************************************//\r\n _AssemblyLoadEventArgs = interface(IDispatch)\r\n ['{7A0325F0-22C2-31F9-8823-9B8AEE9456B1}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _AssemblyLoadEventArgsDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {7A0325F0-22C2-31F9-8823-9B8AEE9456B1}\r\n// *********************************************************************//\r\n _AssemblyLoadEventArgsDisp = dispinterface\r\n ['{7A0325F0-22C2-31F9-8823-9B8AEE9456B1}']\r\n end;\r\n {$EXTERNALSYM _AssemblyLoadEventArgsDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _ResolveEventHandler\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {8E54A9CC-7AA4-34CA-985B-BD7D7527B110}\r\n// *********************************************************************//\r\n _ResolveEventHandler = interface(IDispatch)\r\n ['{8E54A9CC-7AA4-34CA-985B-BD7D7527B110}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _ResolveEventHandlerDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {8E54A9CC-7AA4-34CA-985B-BD7D7527B110}\r\n// *********************************************************************//\r\n _ResolveEventHandlerDisp = dispinterface\r\n ['{8E54A9CC-7AA4-34CA-985B-BD7D7527B110}']\r\n end;\r\n {$EXTERNALSYM _ResolveEventHandlerDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _AssemblyLoadEventHandler\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {DEECE11F-A893-3E35-A4C3-DAB7FA0911EB}\r\n// *********************************************************************//\r\n _AssemblyLoadEventHandler = interface(IDispatch)\r\n ['{DEECE11F-A893-3E35-A4C3-DAB7FA0911EB}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _AssemblyLoadEventHandlerDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {DEECE11F-A893-3E35-A4C3-DAB7FA0911EB}\r\n// *********************************************************************//\r\n _AssemblyLoadEventHandlerDisp = dispinterface\r\n ['{DEECE11F-A893-3E35-A4C3-DAB7FA0911EB}']\r\n end;\r\n {$EXTERNALSYM _AssemblyLoadEventHandlerDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _MarshalByRefObject\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {2C358E27-8C1A-3C03-B086-A40465625557}\r\n// *********************************************************************//\r\n _MarshalByRefObject = interface(IDispatch)\r\n ['{2C358E27-8C1A-3C03-B086-A40465625557}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _MarshalByRefObjectDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {2C358E27-8C1A-3C03-B086-A40465625557}\r\n// *********************************************************************//\r\n _MarshalByRefObjectDisp = dispinterface\r\n ['{2C358E27-8C1A-3C03-B086-A40465625557}']\r\n end;\r\n {$EXTERNALSYM _MarshalByRefObjectDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _AppDomain\r\n// Flags: (4416) Dual OleAutomation Dispatchable\r\n// GUID: {05F696DC-2B29-3663-AD8B-C4389CF2A713}\r\n// *********************************************************************//\r\n _AppDomain = interface(IDispatch)\r\n ['{05F696DC-2B29-3663-AD8B-C4389CF2A713}']\r\n function Get_ToString: WideString; safecall;\r\n function Equals(other: OleVariant): WordBool; safecall;\r\n function GetHashCode: Integer; safecall;\r\n function GetType: _Type; safecall;\r\n function InitializeLifetimeService: OleVariant; safecall;\r\n function GetLifetimeService: OleVariant; safecall;\r\n function Get_Evidence: _Evidence; safecall;\r\n procedure add_DomainUnload(const value: _EventHandler); safecall;\r\n procedure remove_DomainUnload(const value: _EventHandler); safecall;\r\n procedure add_AssemblyLoad(const value: _AssemblyLoadEventHandler); safecall;\r\n procedure remove_AssemblyLoad(const value: _AssemblyLoadEventHandler); safecall;\r\n procedure add_ProcessExit(const value: _EventHandler); safecall;\r\n procedure remove_ProcessExit(const value: _EventHandler); safecall;\r\n procedure add_TypeResolve(const value: _ResolveEventHandler); safecall;\r\n procedure remove_TypeResolve(const value: _ResolveEventHandler); safecall;\r\n procedure add_ResourceResolve(const value: _ResolveEventHandler); safecall;\r\n procedure remove_ResourceResolve(const value: _ResolveEventHandler); safecall;\r\n procedure add_AssemblyResolve(const value: _ResolveEventHandler); safecall;\r\n procedure remove_AssemblyResolve(const value: _ResolveEventHandler); safecall;\r\n procedure add_UnhandledException(const value: _UnhandledExceptionEventHandler); safecall;\r\n procedure remove_UnhandledException(const value: _UnhandledExceptionEventHandler); safecall;\r\n function DefineDynamicAssembly(const name: _AssemblyName; access: AssemblyBuilderAccess): _AssemblyBuilder; safecall;\r\n function DefineDynamicAssembly_2(const name: _AssemblyName; access: AssemblyBuilderAccess; \r\n const dir: WideString): _AssemblyBuilder; safecall;\r\n function DefineDynamicAssembly_3(const name: _AssemblyName; access: AssemblyBuilderAccess; \r\n const Evidence: _Evidence): _AssemblyBuilder; safecall;\r\n function DefineDynamicAssembly_4(const name: _AssemblyName; access: AssemblyBuilderAccess; \r\n const requiredPermissions: _PermissionSet; \r\n const optionalPermissions: _PermissionSet; \r\n const refusedPermissions: _PermissionSet): _AssemblyBuilder; safecall;\r\n function DefineDynamicAssembly_5(const name: _AssemblyName; access: AssemblyBuilderAccess; \r\n const dir: WideString; const Evidence: _Evidence): _AssemblyBuilder; safecall;\r\n function DefineDynamicAssembly_6(const name: _AssemblyName; access: AssemblyBuilderAccess; \r\n const dir: WideString; \r\n const requiredPermissions: _PermissionSet; \r\n const optionalPermissions: _PermissionSet; \r\n const refusedPermissions: _PermissionSet): _AssemblyBuilder; safecall;\r\n function DefineDynamicAssembly_7(const name: _AssemblyName; access: AssemblyBuilderAccess; \r\n const Evidence: _Evidence; \r\n const requiredPermissions: _PermissionSet; \r\n const optionalPermissions: _PermissionSet; \r\n const refusedPermissions: _PermissionSet): _AssemblyBuilder; safecall;\r\n function DefineDynamicAssembly_8(const name: _AssemblyName; access: AssemblyBuilderAccess; \r\n const dir: WideString; const Evidence: _Evidence; \r\n const requiredPermissions: _PermissionSet; \r\n const optionalPermissions: _PermissionSet; \r\n const refusedPermissions: _PermissionSet): _AssemblyBuilder; safecall;\r\n function DefineDynamicAssembly_9(const name: _AssemblyName; access: AssemblyBuilderAccess; \r\n const dir: WideString; const Evidence: _Evidence; \r\n const requiredPermissions: _PermissionSet; \r\n const optionalPermissions: _PermissionSet; \r\n const refusedPermissions: _PermissionSet; \r\n IsSynchronized: WordBool): _AssemblyBuilder; safecall;\r\n function CreateInstance(const AssemblyName: WideString; const typeName: WideString): _ObjectHandle; safecall;\r\n function CreateInstanceFrom(const assemblyFile: WideString; const typeName: WideString): _ObjectHandle; safecall;\r\n function CreateInstance_2(const AssemblyName: WideString; const typeName: WideString; \r\n activationAttributes: PSafeArray): _ObjectHandle; safecall;\r\n function CreateInstanceFrom_2(const assemblyFile: WideString; const typeName: WideString; \r\n activationAttributes: PSafeArray): _ObjectHandle; safecall;\r\n function CreateInstance_3(const AssemblyName: WideString; const typeName: WideString; \r\n ignoreCase: WordBool; bindingAttr: BindingFlags; \r\n const Binder: _Binder; args: PSafeArray; const culture: _CultureInfo; \r\n activationAttributes: PSafeArray; const securityAttributes: _Evidence): _ObjectHandle; safecall;\r\n function CreateInstanceFrom_3(const assemblyFile: WideString; const typeName: WideString; \r\n ignoreCase: WordBool; bindingAttr: BindingFlags; \r\n const Binder: _Binder; args: PSafeArray; \r\n const culture: _CultureInfo; activationAttributes: PSafeArray; \r\n const securityAttributes: _Evidence): _ObjectHandle; safecall;\r\n function Load(const assemblyRef: _AssemblyName): _Assembly; safecall;\r\n function Load_2(const assemblyString: WideString): _Assembly; safecall;\r\n function Load_3(rawAssembly: PSafeArray): _Assembly; safecall;\r\n function Load_4(rawAssembly: PSafeArray; rawSymbolStore: PSafeArray): _Assembly; safecall;\r\n function Load_5(rawAssembly: PSafeArray; rawSymbolStore: PSafeArray; \r\n const securityEvidence: _Evidence): _Assembly; safecall;\r\n function Load_6(const assemblyRef: _AssemblyName; const assemblySecurity: _Evidence): _Assembly; safecall;\r\n function Load_7(const assemblyString: WideString; const assemblySecurity: _Evidence): _Assembly; safecall;\r\n function ExecuteAssembly(const assemblyFile: WideString; const assemblySecurity: _Evidence): Integer; safecall;\r\n function ExecuteAssembly_2(const assemblyFile: WideString): Integer; safecall;\r\n function ExecuteAssembly_3(const assemblyFile: WideString; const assemblySecurity: _Evidence; \r\n args: PSafeArray): Integer; safecall;\r\n function Get_FriendlyName: WideString; safecall;\r\n function Get_BaseDirectory: WideString; safecall;\r\n function Get_RelativeSearchPath: WideString; safecall;\r\n function Get_ShadowCopyFiles: WordBool; safecall;\r\n function GetAssemblies: PSafeArray; safecall;\r\n procedure AppendPrivatePath(const Path: WideString); safecall;\r\n procedure ClearPrivatePath; safecall;\r\n procedure SetShadowCopyPath(const s: WideString); safecall;\r\n procedure ClearShadowCopyPath; safecall;\r\n procedure SetCachePath(const s: WideString); safecall;\r\n procedure SetData(const name: WideString; data: OleVariant); safecall;\r\n function GetData(const name: WideString): OleVariant; safecall;\r\n procedure SetAppDomainPolicy(const domainPolicy: _PolicyLevel); safecall;\r\n procedure SetThreadPrincipal(const principal: IPrincipal); safecall;\r\n procedure SetPrincipalPolicy(policy: PrincipalPolicy); safecall;\r\n procedure DoCallBack(const theDelegate: _CrossAppDomainDelegate); safecall;\r\n function Get_DynamicDirectory: WideString; safecall;\r\n property ToString: WideString read Get_ToString;\r\n property Evidence: _Evidence read Get_Evidence;\r\n property FriendlyName: WideString read Get_FriendlyName;\r\n property BaseDirectory: WideString read Get_BaseDirectory;\r\n property RelativeSearchPath: WideString read Get_RelativeSearchPath;\r\n property ShadowCopyFiles: WordBool read Get_ShadowCopyFiles;\r\n property DynamicDirectory: WideString read Get_DynamicDirectory;\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _AppDomainDisp\r\n// Flags: (4416) Dual OleAutomation Dispatchable\r\n// GUID: {05F696DC-2B29-3663-AD8B-C4389CF2A713}\r\n// *********************************************************************//\r\n _AppDomainDisp = dispinterface\r\n ['{05F696DC-2B29-3663-AD8B-C4389CF2A713}']\r\n property ToString: WideString readonly dispid 0;\r\n function Equals(other: OleVariant): WordBool; dispid 1610743809;\r\n function GetHashCode: Integer; dispid 1610743810;\r\n function GetType: _Type; dispid 1610743811;\r\n function InitializeLifetimeService: OleVariant; dispid 1610743812;\r\n function GetLifetimeService: OleVariant; dispid 1610743813;\r\n property Evidence: _Evidence readonly dispid 1610743814;\r\n procedure add_DomainUnload(const value: _EventHandler); dispid 1610743815;\r\n procedure remove_DomainUnload(const value: _EventHandler); dispid 1610743816;\r\n procedure add_AssemblyLoad(const value: _AssemblyLoadEventHandler); dispid 1610743817;\r\n procedure remove_AssemblyLoad(const value: _AssemblyLoadEventHandler); dispid 1610743818;\r\n procedure add_ProcessExit(const value: _EventHandler); dispid 1610743819;\r\n procedure remove_ProcessExit(const value: _EventHandler); dispid 1610743820;\r\n procedure add_TypeResolve(const value: _ResolveEventHandler); dispid 1610743821;\r\n procedure remove_TypeResolve(const value: _ResolveEventHandler); dispid 1610743822;\r\n procedure add_ResourceResolve(const value: _ResolveEventHandler); dispid 1610743823;\r\n procedure remove_ResourceResolve(const value: _ResolveEventHandler); dispid 1610743824;\r\n procedure add_AssemblyResolve(const value: _ResolveEventHandler); dispid 1610743825;\r\n procedure remove_AssemblyResolve(const value: _ResolveEventHandler); dispid 1610743826;\r\n procedure add_UnhandledException(const value: _UnhandledExceptionEventHandler); dispid 1610743827;\r\n procedure remove_UnhandledException(const value: _UnhandledExceptionEventHandler); dispid 1610743828;\r\n function DefineDynamicAssembly(const name: _AssemblyName; access: AssemblyBuilderAccess): _AssemblyBuilder; dispid 1610743829;\r\n function DefineDynamicAssembly_2(const name: _AssemblyName; access: AssemblyBuilderAccess; \r\n const dir: WideString): _AssemblyBuilder; dispid 1610743830;\r\n function DefineDynamicAssembly_3(const name: _AssemblyName; access: AssemblyBuilderAccess; \r\n const Evidence: _Evidence): _AssemblyBuilder; dispid 1610743831;\r\n function DefineDynamicAssembly_4(const name: _AssemblyName; access: AssemblyBuilderAccess; \r\n const requiredPermissions: _PermissionSet; \r\n const optionalPermissions: _PermissionSet; \r\n const refusedPermissions: _PermissionSet): _AssemblyBuilder; dispid 1610743832;\r\n function DefineDynamicAssembly_5(const name: _AssemblyName; access: AssemblyBuilderAccess; \r\n const dir: WideString; const Evidence: _Evidence): _AssemblyBuilder; dispid 1610743833;\r\n function DefineDynamicAssembly_6(const name: _AssemblyName; access: AssemblyBuilderAccess; \r\n const dir: WideString; \r\n const requiredPermissions: _PermissionSet; \r\n const optionalPermissions: _PermissionSet; \r\n const refusedPermissions: _PermissionSet): _AssemblyBuilder; dispid 1610743834;\r\n function DefineDynamicAssembly_7(const name: _AssemblyName; access: AssemblyBuilderAccess; \r\n const Evidence: _Evidence; \r\n const requiredPermissions: _PermissionSet; \r\n const optionalPermissions: _PermissionSet; \r\n const refusedPermissions: _PermissionSet): _AssemblyBuilder; dispid 1610743835;\r\n function DefineDynamicAssembly_8(const name: _AssemblyName; access: AssemblyBuilderAccess; \r\n const dir: WideString; const Evidence: _Evidence; \r\n const requiredPermissions: _PermissionSet; \r\n const optionalPermissions: _PermissionSet; \r\n const refusedPermissions: _PermissionSet): _AssemblyBuilder; dispid 1610743836;\r\n function DefineDynamicAssembly_9(const name: _AssemblyName; access: AssemblyBuilderAccess; \r\n const dir: WideString; const Evidence: _Evidence; \r\n const requiredPermissions: _PermissionSet; \r\n const optionalPermissions: _PermissionSet; \r\n const refusedPermissions: _PermissionSet; \r\n IsSynchronized: WordBool): _AssemblyBuilder; dispid 1610743837;\r\n function CreateInstance(const AssemblyName: WideString; const typeName: WideString): _ObjectHandle; dispid 1610743838;\r\n function CreateInstanceFrom(const assemblyFile: WideString; const typeName: WideString): _ObjectHandle; dispid 1610743839;\r\n function CreateInstance_2(const AssemblyName: WideString; const typeName: WideString; \r\n activationAttributes: {??PSafeArray}OleVariant): _ObjectHandle; dispid 1610743840;\r\n function CreateInstanceFrom_2(const assemblyFile: WideString; const typeName: WideString; \r\n activationAttributes: {??PSafeArray}OleVariant): _ObjectHandle; dispid 1610743841;\r\n function CreateInstance_3(const AssemblyName: WideString; const typeName: WideString; \r\n ignoreCase: WordBool; bindingAttr: BindingFlags; \r\n const Binder: _Binder; args: {??PSafeArray}OleVariant; \r\n const culture: _CultureInfo; \r\n activationAttributes: {??PSafeArray}OleVariant; \r\n const securityAttributes: _Evidence): _ObjectHandle; dispid 1610743842;\r\n function CreateInstanceFrom_3(const assemblyFile: WideString; const typeName: WideString; \r\n ignoreCase: WordBool; bindingAttr: BindingFlags; \r\n const Binder: _Binder; args: {??PSafeArray}OleVariant; \r\n const culture: _CultureInfo; \r\n activationAttributes: {??PSafeArray}OleVariant; \r\n const securityAttributes: _Evidence): _ObjectHandle; dispid 1610743843;\r\n function Load(const assemblyRef: _AssemblyName): _Assembly; dispid 1610743844;\r\n function Load_2(const assemblyString: WideString): _Assembly; dispid 1610743845;\r\n function Load_3(rawAssembly: {??PSafeArray}OleVariant): _Assembly; dispid 1610743846;\r\n function Load_4(rawAssembly: {??PSafeArray}OleVariant; rawSymbolStore: {??PSafeArray}OleVariant): _Assembly; dispid 1610743847;\r\n function Load_5(rawAssembly: {??PSafeArray}OleVariant; \r\n rawSymbolStore: {??PSafeArray}OleVariant; const securityEvidence: _Evidence): _Assembly; dispid 1610743848;\r\n function Load_6(const assemblyRef: _AssemblyName; const assemblySecurity: _Evidence): _Assembly; dispid 1610743849;\r\n function Load_7(const assemblyString: WideString; const assemblySecurity: _Evidence): _Assembly; dispid 1610743850;\r\n function ExecuteAssembly(const assemblyFile: WideString; const assemblySecurity: _Evidence): Integer; dispid 1610743851;\r\n function ExecuteAssembly_2(const assemblyFile: WideString): Integer; dispid 1610743852;\r\n function ExecuteAssembly_3(const assemblyFile: WideString; const assemblySecurity: _Evidence; \r\n args: {??PSafeArray}OleVariant): Integer; dispid 1610743853;\r\n property FriendlyName: WideString readonly dispid 1610743854;\r\n property BaseDirectory: WideString readonly dispid 1610743855;\r\n property RelativeSearchPath: WideString readonly dispid 1610743856;\r\n property ShadowCopyFiles: WordBool readonly dispid 1610743857;\r\n function GetAssemblies: {??PSafeArray}OleVariant; dispid 1610743858;\r\n procedure AppendPrivatePath(const Path: WideString); dispid 1610743859;\r\n procedure ClearPrivatePath; dispid 1610743860;\r\n procedure SetShadowCopyPath(const s: WideString); dispid 1610743861;\r\n procedure ClearShadowCopyPath; dispid 1610743862;\r\n procedure SetCachePath(const s: WideString); dispid 1610743863;\r\n procedure SetData(const name: WideString; data: OleVariant); dispid 1610743864;\r\n function GetData(const name: WideString): OleVariant; dispid 1610743865;\r\n procedure SetAppDomainPolicy(const domainPolicy: _PolicyLevel); dispid 1610743866;\r\n procedure SetThreadPrincipal(const principal: IPrincipal); dispid 1610743867;\r\n procedure SetPrincipalPolicy(policy: PrincipalPolicy); dispid 1610743868;\r\n procedure DoCallBack(const theDelegate: _CrossAppDomainDelegate); dispid 1610743869;\r\n property DynamicDirectory: WideString readonly dispid 1610743870;\r\n end;\r\n {$EXTERNALSYM _AppDomainDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: IEvidenceFactory\r\n// Flags: (4416) Dual OleAutomation Dispatchable\r\n// GUID: {35A8F3AC-FE28-360F-A0C0-9A4D50C4682A}\r\n// *********************************************************************//\r\n IEvidenceFactory = interface(IDispatch)\r\n ['{35A8F3AC-FE28-360F-A0C0-9A4D50C4682A}']\r\n function Get_Evidence: _Evidence; safecall;\r\n property Evidence: _Evidence read Get_Evidence;\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: IEvidenceFactoryDisp\r\n// Flags: (4416) Dual OleAutomation Dispatchable\r\n// GUID: {35A8F3AC-FE28-360F-A0C0-9A4D50C4682A}\r\n// *********************************************************************//\r\n IEvidenceFactoryDisp = dispinterface\r\n ['{35A8F3AC-FE28-360F-A0C0-9A4D50C4682A}']\r\n property Evidence: _Evidence readonly dispid 1610743808;\r\n end;\r\n {$EXTERNALSYM IEvidenceFactoryDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _CrossAppDomainDelegate\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {AF93163F-C2F4-3FAB-9FF1-728A7AAAD1CB}\r\n// *********************************************************************//\r\n _CrossAppDomainDelegate = interface(IDispatch)\r\n ['{AF93163F-C2F4-3FAB-9FF1-728A7AAAD1CB}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _CrossAppDomainDelegateDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {AF93163F-C2F4-3FAB-9FF1-728A7AAAD1CB}\r\n// *********************************************************************//\r\n _CrossAppDomainDelegateDisp = dispinterface\r\n ['{AF93163F-C2F4-3FAB-9FF1-728A7AAAD1CB}']\r\n end;\r\n {$EXTERNALSYM _CrossAppDomainDelegateDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: IAppDomainSetup\r\n// Flags: (256) OleAutomation\r\n// GUID: {27FFF232-A7A8-40DD-8D4A-734AD59FCD41}\r\n// *********************************************************************//\r\n IAppDomainSetup = interface(IUnknown)\r\n ['{27FFF232-A7A8-40DD-8D4A-734AD59FCD41}']\r\n function Get_ApplicationBase(out pRetVal: WideString): HResult; stdcall;\r\n function Set_ApplicationBase(const pRetVal: WideString): HResult; stdcall;\r\n function Get_ApplicationName(out pRetVal: WideString): HResult; stdcall;\r\n function Set_ApplicationName(const pRetVal: WideString): HResult; stdcall;\r\n function Get_CachePath(out pRetVal: WideString): HResult; stdcall;\r\n function Set_CachePath(const pRetVal: WideString): HResult; stdcall;\r\n function Get_ConfigurationFile(out pRetVal: WideString): HResult; stdcall;\r\n function Set_ConfigurationFile(const pRetVal: WideString): HResult; stdcall;\r\n function Get_DynamicBase(out pRetVal: WideString): HResult; stdcall;\r\n function Set_DynamicBase(const pRetVal: WideString): HResult; stdcall;\r\n function Get_LicenseFile(out pRetVal: WideString): HResult; stdcall;\r\n function Set_LicenseFile(const pRetVal: WideString): HResult; stdcall;\r\n function Get_PrivateBinPath(out pRetVal: WideString): HResult; stdcall;\r\n function Set_PrivateBinPath(const pRetVal: WideString): HResult; stdcall;\r\n function Get_PrivateBinPathProbe(out pRetVal: WideString): HResult; stdcall;\r\n function Set_PrivateBinPathProbe(const pRetVal: WideString): HResult; stdcall;\r\n function Get_ShadowCopyDirectories(out pRetVal: WideString): HResult; stdcall;\r\n function Set_ShadowCopyDirectories(const pRetVal: WideString): HResult; stdcall;\r\n function Get_ShadowCopyFiles(out pRetVal: WideString): HResult; stdcall;\r\n function Set_ShadowCopyFiles(const pRetVal: WideString): HResult; stdcall;\r\n end;\r\n\r\n// *********************************************************************//\r\n// Interface: _Attribute\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {917B14D0-2D9E-38B8-92A9-381ACF52F7C0}\r\n// *********************************************************************//\r\n _Attribute = interface(IDispatch)\r\n ['{917B14D0-2D9E-38B8-92A9-381ACF52F7C0}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _AttributeDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {917B14D0-2D9E-38B8-92A9-381ACF52F7C0}\r\n// *********************************************************************//\r\n _AttributeDisp = dispinterface\r\n ['{917B14D0-2D9E-38B8-92A9-381ACF52F7C0}']\r\n end;\r\n {$EXTERNALSYM _AttributeDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _LoaderOptimizationAttribute\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {CE59D7AD-05CA-33B4-A1DD-06028D46E9D2}\r\n// *********************************************************************//\r\n _LoaderOptimizationAttribute = interface(IDispatch)\r\n ['{CE59D7AD-05CA-33B4-A1DD-06028D46E9D2}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _LoaderOptimizationAttributeDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {CE59D7AD-05CA-33B4-A1DD-06028D46E9D2}\r\n// *********************************************************************//\r\n _LoaderOptimizationAttributeDisp = dispinterface\r\n ['{CE59D7AD-05CA-33B4-A1DD-06028D46E9D2}']\r\n end;\r\n {$EXTERNALSYM _LoaderOptimizationAttributeDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _AppDomainUnloadedException\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {6E96AA70-9FFB-399D-96BF-A68436095C54}\r\n// *********************************************************************//\r\n _AppDomainUnloadedException = interface(IDispatch)\r\n ['{6E96AA70-9FFB-399D-96BF-A68436095C54}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _AppDomainUnloadedExceptionDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {6E96AA70-9FFB-399D-96BF-A68436095C54}\r\n// *********************************************************************//\r\n _AppDomainUnloadedExceptionDisp = dispinterface\r\n ['{6E96AA70-9FFB-399D-96BF-A68436095C54}']\r\n end;\r\n {$EXTERNALSYM _AppDomainUnloadedExceptionDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _ArgumentException\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {4DB2C2B7-CBC2-3185-B966-875D4625B1A8}\r\n// *********************************************************************//\r\n _ArgumentException = interface(IDispatch)\r\n ['{4DB2C2B7-CBC2-3185-B966-875D4625B1A8}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _ArgumentExceptionDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {4DB2C2B7-CBC2-3185-B966-875D4625B1A8}\r\n// *********************************************************************//\r\n _ArgumentExceptionDisp = dispinterface\r\n ['{4DB2C2B7-CBC2-3185-B966-875D4625B1A8}']\r\n end;\r\n {$EXTERNALSYM _ArgumentExceptionDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _ArgumentNullException\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {C991949B-E623-3F24-885C-BBB01FF43564}\r\n// *********************************************************************//\r\n _ArgumentNullException = interface(IDispatch)\r\n ['{C991949B-E623-3F24-885C-BBB01FF43564}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _ArgumentNullExceptionDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {C991949B-E623-3F24-885C-BBB01FF43564}\r\n// *********************************************************************//\r\n _ArgumentNullExceptionDisp = dispinterface\r\n ['{C991949B-E623-3F24-885C-BBB01FF43564}']\r\n end;\r\n {$EXTERNALSYM _ArgumentNullExceptionDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _ArgumentOutOfRangeException\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {77DA3028-BC45-3E82-BF76-2C123EE2C021}\r\n// *********************************************************************//\r\n _ArgumentOutOfRangeException = interface(IDispatch)\r\n ['{77DA3028-BC45-3E82-BF76-2C123EE2C021}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _ArgumentOutOfRangeExceptionDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {77DA3028-BC45-3E82-BF76-2C123EE2C021}\r\n// *********************************************************************//\r\n _ArgumentOutOfRangeExceptionDisp = dispinterface\r\n ['{77DA3028-BC45-3E82-BF76-2C123EE2C021}']\r\n end;\r\n {$EXTERNALSYM _ArgumentOutOfRangeExceptionDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _ArithmeticException\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {9B012CF1-ACF6-3389-A336-C023040C62A2}\r\n// *********************************************************************//\r\n _ArithmeticException = interface(IDispatch)\r\n ['{9B012CF1-ACF6-3389-A336-C023040C62A2}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _ArithmeticExceptionDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {9B012CF1-ACF6-3389-A336-C023040C62A2}\r\n// *********************************************************************//\r\n _ArithmeticExceptionDisp = dispinterface\r\n ['{9B012CF1-ACF6-3389-A336-C023040C62A2}']\r\n end;\r\n {$EXTERNALSYM _ArithmeticExceptionDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _ArrayTypeMismatchException\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {DD7488A6-1B3F-3823-9556-C2772B15150F}\r\n// *********************************************************************//\r\n _ArrayTypeMismatchException = interface(IDispatch)\r\n ['{DD7488A6-1B3F-3823-9556-C2772B15150F}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _ArrayTypeMismatchExceptionDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {DD7488A6-1B3F-3823-9556-C2772B15150F}\r\n// *********************************************************************//\r\n _ArrayTypeMismatchExceptionDisp = dispinterface\r\n ['{DD7488A6-1B3F-3823-9556-C2772B15150F}']\r\n end;\r\n {$EXTERNALSYM _ArrayTypeMismatchExceptionDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _AsyncCallback\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {3612706E-0239-35FD-B900-0819D16D442D}\r\n// *********************************************************************//\r\n _AsyncCallback = interface(IDispatch)\r\n ['{3612706E-0239-35FD-B900-0819D16D442D}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _AsyncCallbackDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {3612706E-0239-35FD-B900-0819D16D442D}\r\n// *********************************************************************//\r\n _AsyncCallbackDisp = dispinterface\r\n ['{3612706E-0239-35FD-B900-0819D16D442D}']\r\n end;\r\n {$EXTERNALSYM _AsyncCallbackDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _AttributeUsageAttribute\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {A902A192-49BA-3EC8-B444-AF5F7743F61A}\r\n// *********************************************************************//\r\n _AttributeUsageAttribute = interface(IDispatch)\r\n ['{A902A192-49BA-3EC8-B444-AF5F7743F61A}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _AttributeUsageAttributeDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {A902A192-49BA-3EC8-B444-AF5F7743F61A}\r\n// *********************************************************************//\r\n _AttributeUsageAttributeDisp = dispinterface\r\n ['{A902A192-49BA-3EC8-B444-AF5F7743F61A}']\r\n end;\r\n {$EXTERNALSYM _AttributeUsageAttributeDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _BadImageFormatException\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {F98BCE04-4A4B-398C-A512-FD8348D51E3B}\r\n// *********************************************************************//\r\n _BadImageFormatException = interface(IDispatch)\r\n ['{F98BCE04-4A4B-398C-A512-FD8348D51E3B}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _BadImageFormatExceptionDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {F98BCE04-4A4B-398C-A512-FD8348D51E3B}\r\n// *********************************************************************//\r\n _BadImageFormatExceptionDisp = dispinterface\r\n ['{F98BCE04-4A4B-398C-A512-FD8348D51E3B}']\r\n end;\r\n {$EXTERNALSYM _BadImageFormatExceptionDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _BitConverter\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {5CD861E8-CA91-301B-9E24-141E3D85BD5D}\r\n// *********************************************************************//\r\n _BitConverter = interface(IDispatch)\r\n ['{5CD861E8-CA91-301B-9E24-141E3D85BD5D}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _BitConverterDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {5CD861E8-CA91-301B-9E24-141E3D85BD5D}\r\n// *********************************************************************//\r\n _BitConverterDisp = dispinterface\r\n ['{5CD861E8-CA91-301B-9E24-141E3D85BD5D}']\r\n end;\r\n {$EXTERNALSYM _BitConverterDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _Buffer\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {F036BCA4-F8DF-3682-8290-75285CE7456C}\r\n// *********************************************************************//\r\n _Buffer = interface(IDispatch)\r\n ['{F036BCA4-F8DF-3682-8290-75285CE7456C}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _BufferDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {F036BCA4-F8DF-3682-8290-75285CE7456C}\r\n// *********************************************************************//\r\n _BufferDisp = dispinterface\r\n ['{F036BCA4-F8DF-3682-8290-75285CE7456C}']\r\n end;\r\n {$EXTERNALSYM _BufferDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _CannotUnloadAppDomainException\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {6D4B6ADB-B9FA-3809-B5EA-FA57B56C546F}\r\n// *********************************************************************//\r\n _CannotUnloadAppDomainException = interface(IDispatch)\r\n ['{6D4B6ADB-B9FA-3809-B5EA-FA57B56C546F}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _CannotUnloadAppDomainExceptionDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {6D4B6ADB-B9FA-3809-B5EA-FA57B56C546F}\r\n// *********************************************************************//\r\n _CannotUnloadAppDomainExceptionDisp = dispinterface\r\n ['{6D4B6ADB-B9FA-3809-B5EA-FA57B56C546F}']\r\n end;\r\n {$EXTERNALSYM _CannotUnloadAppDomainExceptionDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _CharEnumerator\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {1DD627FC-89E3-384F-BB9D-58CB4EFB9456}\r\n// *********************************************************************//\r\n _CharEnumerator = interface(IDispatch)\r\n ['{1DD627FC-89E3-384F-BB9D-58CB4EFB9456}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _CharEnumeratorDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {1DD627FC-89E3-384F-BB9D-58CB4EFB9456}\r\n// *********************************************************************//\r\n _CharEnumeratorDisp = dispinterface\r\n ['{1DD627FC-89E3-384F-BB9D-58CB4EFB9456}']\r\n end;\r\n {$EXTERNALSYM _CharEnumeratorDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _CLSCompliantAttribute\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {BF1AF177-94CA-3E6D-9D91-55CF9E859D22}\r\n// *********************************************************************//\r\n _CLSCompliantAttribute = interface(IDispatch)\r\n ['{BF1AF177-94CA-3E6D-9D91-55CF9E859D22}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _CLSCompliantAttributeDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {BF1AF177-94CA-3E6D-9D91-55CF9E859D22}\r\n// *********************************************************************//\r\n _CLSCompliantAttributeDisp = dispinterface\r\n ['{BF1AF177-94CA-3E6D-9D91-55CF9E859D22}']\r\n end;\r\n {$EXTERNALSYM _CLSCompliantAttributeDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _TypeUnloadedException\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {C2A10F3A-356A-3C77-AAB9-8991D73A2561}\r\n// *********************************************************************//\r\n _TypeUnloadedException = interface(IDispatch)\r\n ['{C2A10F3A-356A-3C77-AAB9-8991D73A2561}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _TypeUnloadedExceptionDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {C2A10F3A-356A-3C77-AAB9-8991D73A2561}\r\n// *********************************************************************//\r\n _TypeUnloadedExceptionDisp = dispinterface\r\n ['{C2A10F3A-356A-3C77-AAB9-8991D73A2561}']\r\n end;\r\n {$EXTERNALSYM _TypeUnloadedExceptionDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _Console\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {88592805-9549-3E00-8308-03CFA6B93882}\r\n// *********************************************************************//\r\n _Console = interface(IDispatch)\r\n ['{88592805-9549-3E00-8308-03CFA6B93882}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _ConsoleDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {88592805-9549-3E00-8308-03CFA6B93882}\r\n// *********************************************************************//\r\n _ConsoleDisp = dispinterface\r\n ['{88592805-9549-3E00-8308-03CFA6B93882}']\r\n end;\r\n {$EXTERNALSYM _ConsoleDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _ContextMarshalException\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {7386F4D7-7C11-389F-BB75-895714B12BB5}\r\n// *********************************************************************//\r\n _ContextMarshalException = interface(IDispatch)\r\n ['{7386F4D7-7C11-389F-BB75-895714B12BB5}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _ContextMarshalExceptionDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {7386F4D7-7C11-389F-BB75-895714B12BB5}\r\n// *********************************************************************//\r\n _ContextMarshalExceptionDisp = dispinterface\r\n ['{7386F4D7-7C11-389F-BB75-895714B12BB5}']\r\n end;\r\n {$EXTERNALSYM _ContextMarshalExceptionDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _Convert\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {9E1348D4-3FAC-3704-840D-20D91E4AD542}\r\n// *********************************************************************//\r\n _Convert = interface(IDispatch)\r\n ['{9E1348D4-3FAC-3704-840D-20D91E4AD542}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _ConvertDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {9E1348D4-3FAC-3704-840D-20D91E4AD542}\r\n// *********************************************************************//\r\n _ConvertDisp = dispinterface\r\n ['{9E1348D4-3FAC-3704-840D-20D91E4AD542}']\r\n end;\r\n {$EXTERNALSYM _ConvertDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _ContextBoundObject\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {3EB1D909-E8BF-3C6B-ADA5-0E86E31E186E}\r\n// *********************************************************************//\r\n _ContextBoundObject = interface(IDispatch)\r\n ['{3EB1D909-E8BF-3C6B-ADA5-0E86E31E186E}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _ContextBoundObjectDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {3EB1D909-E8BF-3C6B-ADA5-0E86E31E186E}\r\n// *********************************************************************//\r\n _ContextBoundObjectDisp = dispinterface\r\n ['{3EB1D909-E8BF-3C6B-ADA5-0E86E31E186E}']\r\n end;\r\n {$EXTERNALSYM _ContextBoundObjectDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _ContextStaticAttribute\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {160D517F-F175-3B61-8264-6D2305B8246C}\r\n// *********************************************************************//\r\n _ContextStaticAttribute = interface(IDispatch)\r\n ['{160D517F-F175-3B61-8264-6D2305B8246C}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _ContextStaticAttributeDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {160D517F-F175-3B61-8264-6D2305B8246C}\r\n// *********************************************************************//\r\n _ContextStaticAttributeDisp = dispinterface\r\n ['{160D517F-F175-3B61-8264-6D2305B8246C}']\r\n end;\r\n {$EXTERNALSYM _ContextStaticAttributeDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _TimeZone\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {3025F666-7891-33D7-AACD-23D169EF354E}\r\n// *********************************************************************//\r\n _TimeZone = interface(IDispatch)\r\n ['{3025F666-7891-33D7-AACD-23D169EF354E}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _TimeZoneDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {3025F666-7891-33D7-AACD-23D169EF354E}\r\n// *********************************************************************//\r\n _TimeZoneDisp = dispinterface\r\n ['{3025F666-7891-33D7-AACD-23D169EF354E}']\r\n end;\r\n {$EXTERNALSYM _TimeZoneDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _DBNull\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {0D9F1B65-6D27-3E9F-BAF3-0597837E0F33}\r\n// *********************************************************************//\r\n _DBNull = interface(IDispatch)\r\n ['{0D9F1B65-6D27-3E9F-BAF3-0597837E0F33}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _DBNullDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {0D9F1B65-6D27-3E9F-BAF3-0597837E0F33}\r\n// *********************************************************************//\r\n _DBNullDisp = dispinterface\r\n ['{0D9F1B65-6D27-3E9F-BAF3-0597837E0F33}']\r\n end;\r\n {$EXTERNALSYM _DBNullDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _Binder\r\n// Flags: (4560) Hidden Dual NonExtensible OleAutomation Dispatchable\r\n// GUID: {3169AB11-7109-3808-9A61-EF4BA0534FD9}\r\n// *********************************************************************//\r\n _Binder = interface(IDispatch)\r\n ['{3169AB11-7109-3808-9A61-EF4BA0534FD9}']\r\n function Get_ToString: WideString; safecall;\r\n function Equals(obj: OleVariant): WordBool; safecall;\r\n function GetHashCode: Integer; safecall;\r\n function GetType: _Type; safecall;\r\n function BindToMethod(bindingAttr: BindingFlags; match: PSafeArray; var args: PSafeArray; \r\n modifiers: PSafeArray; const culture: _CultureInfo; names: PSafeArray; \r\n out state: OleVariant): _MethodBase; safecall;\r\n function BindToField(bindingAttr: BindingFlags; match: PSafeArray; value: OleVariant; \r\n const culture: _CultureInfo): _FieldInfo; safecall;\r\n function SelectMethod(bindingAttr: BindingFlags; match: PSafeArray; types: PSafeArray; \r\n modifiers: PSafeArray): _MethodBase; safecall;\r\n function SelectProperty(bindingAttr: BindingFlags; match: PSafeArray; const returnType: _Type; \r\n indexes: PSafeArray; modifiers: PSafeArray): _PropertyInfo; safecall;\r\n function ChangeType(value: OleVariant; const Type_: _Type; const culture: _CultureInfo): OleVariant; safecall;\r\n procedure ReorderArgumentArray(var args: PSafeArray; state: OleVariant); safecall;\r\n property ToString: WideString read Get_ToString;\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _BinderDisp\r\n// Flags: (4560) Hidden Dual NonExtensible OleAutomation Dispatchable\r\n// GUID: {3169AB11-7109-3808-9A61-EF4BA0534FD9}\r\n// *********************************************************************//\r\n _BinderDisp = dispinterface\r\n ['{3169AB11-7109-3808-9A61-EF4BA0534FD9}']\r\n property ToString: WideString readonly dispid 0;\r\n function Equals(obj: OleVariant): WordBool; dispid 1610743809;\r\n function GetHashCode: Integer; dispid 1610743810;\r\n function GetType: _Type; dispid 1610743811;\r\n function BindToMethod(bindingAttr: BindingFlags; match: {??PSafeArray}OleVariant; \r\n var args: {??PSafeArray}OleVariant; modifiers: {??PSafeArray}OleVariant; \r\n const culture: _CultureInfo; names: {??PSafeArray}OleVariant; \r\n out state: OleVariant): _MethodBase; dispid 1610743812;\r\n function BindToField(bindingAttr: BindingFlags; match: {??PSafeArray}OleVariant; \r\n value: OleVariant; const culture: _CultureInfo): _FieldInfo; dispid 1610743813;\r\n function SelectMethod(bindingAttr: BindingFlags; match: {??PSafeArray}OleVariant; \r\n types: {??PSafeArray}OleVariant; modifiers: {??PSafeArray}OleVariant): _MethodBase; dispid 1610743814;\r\n function SelectProperty(bindingAttr: BindingFlags; match: {??PSafeArray}OleVariant; \r\n const returnType: _Type; indexes: {??PSafeArray}OleVariant; \r\n modifiers: {??PSafeArray}OleVariant): _PropertyInfo; dispid 1610743815;\r\n function ChangeType(value: OleVariant; const Type_: _Type; const culture: _CultureInfo): OleVariant; dispid 1610743816;\r\n procedure ReorderArgumentArray(var args: {??PSafeArray}OleVariant; state: OleVariant); dispid 1610743817;\r\n end;\r\n {$EXTERNALSYM _BinderDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: IObjectReference\r\n// Flags: (4416) Dual OleAutomation Dispatchable\r\n// GUID: {6E70ED5F-0439-38CE-83BB-860F1421F29F}\r\n// *********************************************************************//\r\n IObjectReference = interface(IDispatch)\r\n ['{6E70ED5F-0439-38CE-83BB-860F1421F29F}']\r\n function GetRealObject(Context: StreamingContext): OleVariant; safecall;\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: IObjectReferenceDisp\r\n// Flags: (4416) Dual OleAutomation Dispatchable\r\n// GUID: {6E70ED5F-0439-38CE-83BB-860F1421F29F}\r\n// *********************************************************************//\r\n IObjectReferenceDisp = dispinterface\r\n ['{6E70ED5F-0439-38CE-83BB-860F1421F29F}']\r\n function GetRealObject(Context: {??StreamingContext}OleVariant): OleVariant; dispid 1610743808;\r\n end;\r\n {$EXTERNALSYM IObjectReferenceDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _DivideByZeroException\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {BDEEA460-8241-3B41-9ED3-6E3E9977AC7F}\r\n// *********************************************************************//\r\n _DivideByZeroException = interface(IDispatch)\r\n ['{BDEEA460-8241-3B41-9ED3-6E3E9977AC7F}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _DivideByZeroExceptionDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {BDEEA460-8241-3B41-9ED3-6E3E9977AC7F}\r\n// *********************************************************************//\r\n _DivideByZeroExceptionDisp = dispinterface\r\n ['{BDEEA460-8241-3B41-9ED3-6E3E9977AC7F}']\r\n end;\r\n {$EXTERNALSYM _DivideByZeroExceptionDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _DuplicateWaitObjectException\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {D345A42B-CFE0-3EEE-861C-F3322812B388}\r\n// *********************************************************************//\r\n _DuplicateWaitObjectException = interface(IDispatch)\r\n ['{D345A42B-CFE0-3EEE-861C-F3322812B388}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _DuplicateWaitObjectExceptionDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {D345A42B-CFE0-3EEE-861C-F3322812B388}\r\n// *********************************************************************//\r\n _DuplicateWaitObjectExceptionDisp = dispinterface\r\n ['{D345A42B-CFE0-3EEE-861C-F3322812B388}']\r\n end;\r\n {$EXTERNALSYM _DuplicateWaitObjectExceptionDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _TypeLoadException\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {82D6B3BF-A633-3B3B-A09E-2363E4B24A41}\r\n// *********************************************************************//\r\n _TypeLoadException = interface(IDispatch)\r\n ['{82D6B3BF-A633-3B3B-A09E-2363E4B24A41}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _TypeLoadExceptionDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {82D6B3BF-A633-3B3B-A09E-2363E4B24A41}\r\n// *********************************************************************//\r\n _TypeLoadExceptionDisp = dispinterface\r\n ['{82D6B3BF-A633-3B3B-A09E-2363E4B24A41}']\r\n end;\r\n {$EXTERNALSYM _TypeLoadExceptionDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _EntryPointNotFoundException\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {67388F3F-B600-3BCF-84AA-BB2B88DD9EE2}\r\n// *********************************************************************//\r\n _EntryPointNotFoundException = interface(IDispatch)\r\n ['{67388F3F-B600-3BCF-84AA-BB2B88DD9EE2}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _EntryPointNotFoundExceptionDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {67388F3F-B600-3BCF-84AA-BB2B88DD9EE2}\r\n// *********************************************************************//\r\n _EntryPointNotFoundExceptionDisp = dispinterface\r\n ['{67388F3F-B600-3BCF-84AA-BB2B88DD9EE2}']\r\n end;\r\n {$EXTERNALSYM _EntryPointNotFoundExceptionDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _DllNotFoundException\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {24AE6464-2834-32CD-83D6-FA06953DE62A}\r\n// *********************************************************************//\r\n _DllNotFoundException = interface(IDispatch)\r\n ['{24AE6464-2834-32CD-83D6-FA06953DE62A}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _DllNotFoundExceptionDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {24AE6464-2834-32CD-83D6-FA06953DE62A}\r\n// *********************************************************************//\r\n _DllNotFoundExceptionDisp = dispinterface\r\n ['{24AE6464-2834-32CD-83D6-FA06953DE62A}']\r\n end;\r\n {$EXTERNALSYM _DllNotFoundExceptionDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _Environment\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {29DC56CF-B981-3432-97C8-3680AB6D862D}\r\n// *********************************************************************//\r\n _Environment = interface(IDispatch)\r\n ['{29DC56CF-B981-3432-97C8-3680AB6D862D}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _EnvironmentDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {29DC56CF-B981-3432-97C8-3680AB6D862D}\r\n// *********************************************************************//\r\n _EnvironmentDisp = dispinterface\r\n ['{29DC56CF-B981-3432-97C8-3680AB6D862D}']\r\n end;\r\n {$EXTERNALSYM _EnvironmentDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _EventHandler\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {7CEFC46E-16E0-3E65-9C38-55B4342BA7F0}\r\n// *********************************************************************//\r\n _EventHandler = interface(IDispatch)\r\n ['{7CEFC46E-16E0-3E65-9C38-55B4342BA7F0}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _EventHandlerDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {7CEFC46E-16E0-3E65-9C38-55B4342BA7F0}\r\n// *********************************************************************//\r\n _EventHandlerDisp = dispinterface\r\n ['{7CEFC46E-16E0-3E65-9C38-55B4342BA7F0}']\r\n end;\r\n {$EXTERNALSYM _EventHandlerDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _FieldAccessException\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {8D5F5811-FFA1-3306-93E3-8AFC572B9B82}\r\n// *********************************************************************//\r\n _FieldAccessException = interface(IDispatch)\r\n ['{8D5F5811-FFA1-3306-93E3-8AFC572B9B82}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _FieldAccessExceptionDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {8D5F5811-FFA1-3306-93E3-8AFC572B9B82}\r\n// *********************************************************************//\r\n _FieldAccessExceptionDisp = dispinterface\r\n ['{8D5F5811-FFA1-3306-93E3-8AFC572B9B82}']\r\n end;\r\n {$EXTERNALSYM _FieldAccessExceptionDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _FlagsAttribute\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {EBE3746D-DDEC-3D23-8E8D-9361BA87BAC6}\r\n// *********************************************************************//\r\n _FlagsAttribute = interface(IDispatch)\r\n ['{EBE3746D-DDEC-3D23-8E8D-9361BA87BAC6}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _FlagsAttributeDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {EBE3746D-DDEC-3D23-8E8D-9361BA87BAC6}\r\n// *********************************************************************//\r\n _FlagsAttributeDisp = dispinterface\r\n ['{EBE3746D-DDEC-3D23-8E8D-9361BA87BAC6}']\r\n end;\r\n {$EXTERNALSYM _FlagsAttributeDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _FormatException\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {07F92156-398A-3548-90B7-2E58026353D0}\r\n// *********************************************************************//\r\n _FormatException = interface(IDispatch)\r\n ['{07F92156-398A-3548-90B7-2E58026353D0}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _FormatExceptionDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {07F92156-398A-3548-90B7-2E58026353D0}\r\n// *********************************************************************//\r\n _FormatExceptionDisp = dispinterface\r\n ['{07F92156-398A-3548-90B7-2E58026353D0}']\r\n end;\r\n {$EXTERNALSYM _FormatExceptionDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _GC\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {679ED106-5DC1-38FE-8B5C-2ADCA3552298}\r\n// *********************************************************************//\r\n _GC = interface(IDispatch)\r\n ['{679ED106-5DC1-38FE-8B5C-2ADCA3552298}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _GCDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {679ED106-5DC1-38FE-8B5C-2ADCA3552298}\r\n// *********************************************************************//\r\n _GCDisp = dispinterface\r\n ['{679ED106-5DC1-38FE-8B5C-2ADCA3552298}']\r\n end;\r\n {$EXTERNALSYM _GCDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: IAsyncResult\r\n// Flags: (4416) Dual OleAutomation Dispatchable\r\n// GUID: {11AB34E7-0176-3C9E-9EFE-197858400A3D}\r\n// *********************************************************************//\r\n IAsyncResult = interface(IDispatch)\r\n ['{11AB34E7-0176-3C9E-9EFE-197858400A3D}']\r\n function Get_IsCompleted: WordBool; safecall;\r\n function Get_AsyncWaitHandle: _WaitHandle; safecall;\r\n function Get_AsyncState: OleVariant; safecall;\r\n function Get_CompletedSynchronously: WordBool; safecall;\r\n property IsCompleted: WordBool read Get_IsCompleted;\r\n property AsyncWaitHandle: _WaitHandle read Get_AsyncWaitHandle;\r\n property AsyncState: OleVariant read Get_AsyncState;\r\n property CompletedSynchronously: WordBool read Get_CompletedSynchronously;\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: IAsyncResultDisp\r\n// Flags: (4416) Dual OleAutomation Dispatchable\r\n// GUID: {11AB34E7-0176-3C9E-9EFE-197858400A3D}\r\n// *********************************************************************//\r\n IAsyncResultDisp = dispinterface\r\n ['{11AB34E7-0176-3C9E-9EFE-197858400A3D}']\r\n property IsCompleted: WordBool readonly dispid 1610743808;\r\n property AsyncWaitHandle: _WaitHandle readonly dispid 1610743809;\r\n property AsyncState: OleVariant readonly dispid 1610743810;\r\n property CompletedSynchronously: WordBool readonly dispid 1610743811;\r\n end;\r\n {$EXTERNALSYM IAsyncResultDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: ICustomFormatter\r\n// Flags: (4416) Dual OleAutomation Dispatchable\r\n// GUID: {2B130940-CA5E-3406-8385-E259E68AB039}\r\n// *********************************************************************//\r\n ICustomFormatter = interface(IDispatch)\r\n ['{2B130940-CA5E-3406-8385-E259E68AB039}']\r\n function format(const format: WideString; arg: OleVariant; const formatProvider: IFormatProvider): WideString; safecall;\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: ICustomFormatterDisp\r\n// Flags: (4416) Dual OleAutomation Dispatchable\r\n// GUID: {2B130940-CA5E-3406-8385-E259E68AB039}\r\n// *********************************************************************//\r\n ICustomFormatterDisp = dispinterface\r\n ['{2B130940-CA5E-3406-8385-E259E68AB039}']\r\n function format(const format: WideString; arg: OleVariant; const formatProvider: IFormatProvider): WideString; dispid 1610743808;\r\n end;\r\n {$EXTERNALSYM ICustomFormatterDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: IDisposable\r\n// Flags: (4416) Dual OleAutomation Dispatchable\r\n// GUID: {805D7A98-D4AF-3F0F-967F-E5CF45312D2C}\r\n// *********************************************************************//\r\n IDisposable = interface(IDispatch)\r\n ['{805D7A98-D4AF-3F0F-967F-E5CF45312D2C}']\r\n procedure Dispose; safecall;\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: IDisposableDisp\r\n// Flags: (4416) Dual OleAutomation Dispatchable\r\n// GUID: {805D7A98-D4AF-3F0F-967F-E5CF45312D2C}\r\n// *********************************************************************//\r\n IDisposableDisp = dispinterface\r\n ['{805D7A98-D4AF-3F0F-967F-E5CF45312D2C}']\r\n procedure Dispose; dispid 1610743808;\r\n end;\r\n {$EXTERNALSYM IDisposableDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: IFormatProvider\r\n// Flags: (4416) Dual OleAutomation Dispatchable\r\n// GUID: {C8CB1DED-2814-396A-9CC0-473CA49779CC}\r\n// *********************************************************************//\r\n IFormatProvider = interface(IDispatch)\r\n ['{C8CB1DED-2814-396A-9CC0-473CA49779CC}']\r\n function GetFormat(const formatType: _Type): OleVariant; safecall;\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: IFormatProviderDisp\r\n// Flags: (4416) Dual OleAutomation Dispatchable\r\n// GUID: {C8CB1DED-2814-396A-9CC0-473CA49779CC}\r\n// *********************************************************************//\r\n IFormatProviderDisp = dispinterface\r\n ['{C8CB1DED-2814-396A-9CC0-473CA49779CC}']\r\n function GetFormat(const formatType: _Type): OleVariant; dispid 1610743808;\r\n end;\r\n {$EXTERNALSYM IFormatProviderDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _IndexOutOfRangeException\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {E5A5F1E4-82C1-391F-A1C6-F39EAE9DC72F}\r\n// *********************************************************************//\r\n _IndexOutOfRangeException = interface(IDispatch)\r\n ['{E5A5F1E4-82C1-391F-A1C6-F39EAE9DC72F}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _IndexOutOfRangeExceptionDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {E5A5F1E4-82C1-391F-A1C6-F39EAE9DC72F}\r\n// *********************************************************************//\r\n _IndexOutOfRangeExceptionDisp = dispinterface\r\n ['{E5A5F1E4-82C1-391F-A1C6-F39EAE9DC72F}']\r\n end;\r\n {$EXTERNALSYM _IndexOutOfRangeExceptionDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _InvalidCastException\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {FA047CBD-9BA5-3A13-9B1F-6694D622CD76}\r\n// *********************************************************************//\r\n _InvalidCastException = interface(IDispatch)\r\n ['{FA047CBD-9BA5-3A13-9B1F-6694D622CD76}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _InvalidCastExceptionDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {FA047CBD-9BA5-3A13-9B1F-6694D622CD76}\r\n// *********************************************************************//\r\n _InvalidCastExceptionDisp = dispinterface\r\n ['{FA047CBD-9BA5-3A13-9B1F-6694D622CD76}']\r\n end;\r\n {$EXTERNALSYM _InvalidCastExceptionDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _InvalidOperationException\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {8D520D10-0B8A-3553-8874-D30A4AD2FF4C}\r\n// *********************************************************************//\r\n _InvalidOperationException = interface(IDispatch)\r\n ['{8D520D10-0B8A-3553-8874-D30A4AD2FF4C}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _InvalidOperationExceptionDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {8D520D10-0B8A-3553-8874-D30A4AD2FF4C}\r\n// *********************************************************************//\r\n _InvalidOperationExceptionDisp = dispinterface\r\n ['{8D520D10-0B8A-3553-8874-D30A4AD2FF4C}']\r\n end;\r\n {$EXTERNALSYM _InvalidOperationExceptionDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _InvalidProgramException\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {3410E0FB-636F-3CD1-8045-3993CA113F25}\r\n// *********************************************************************//\r\n _InvalidProgramException = interface(IDispatch)\r\n ['{3410E0FB-636F-3CD1-8045-3993CA113F25}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _InvalidProgramExceptionDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {3410E0FB-636F-3CD1-8045-3993CA113F25}\r\n// *********************************************************************//\r\n _InvalidProgramExceptionDisp = dispinterface\r\n ['{3410E0FB-636F-3CD1-8045-3993CA113F25}']\r\n end;\r\n {$EXTERNALSYM _InvalidProgramExceptionDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _LocalDataStoreSlot\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {DC77F976-318D-3A1A-9B60-ABB9DD9406D6}\r\n// *********************************************************************//\r\n _LocalDataStoreSlot = interface(IDispatch)\r\n ['{DC77F976-318D-3A1A-9B60-ABB9DD9406D6}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _LocalDataStoreSlotDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {DC77F976-318D-3A1A-9B60-ABB9DD9406D6}\r\n// *********************************************************************//\r\n _LocalDataStoreSlotDisp = dispinterface\r\n ['{DC77F976-318D-3A1A-9B60-ABB9DD9406D6}']\r\n end;\r\n {$EXTERNALSYM _LocalDataStoreSlotDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _Math\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {A19F91C8-7D23-3DFB-A988-CEE05B039121}\r\n// *********************************************************************//\r\n _Math = interface(IDispatch)\r\n ['{A19F91C8-7D23-3DFB-A988-CEE05B039121}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _MathDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {A19F91C8-7D23-3DFB-A988-CEE05B039121}\r\n// *********************************************************************//\r\n _MathDisp = dispinterface\r\n ['{A19F91C8-7D23-3DFB-A988-CEE05B039121}']\r\n end;\r\n {$EXTERNALSYM _MathDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _MethodAccessException\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {FF0BF77D-8F81-3D31-A3BB-6F54440FA7E5}\r\n// *********************************************************************//\r\n _MethodAccessException = interface(IDispatch)\r\n ['{FF0BF77D-8F81-3D31-A3BB-6F54440FA7E5}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _MethodAccessExceptionDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {FF0BF77D-8F81-3D31-A3BB-6F54440FA7E5}\r\n// *********************************************************************//\r\n _MethodAccessExceptionDisp = dispinterface\r\n ['{FF0BF77D-8F81-3D31-A3BB-6F54440FA7E5}']\r\n end;\r\n {$EXTERNALSYM _MethodAccessExceptionDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _MissingMemberException\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {8897D14B-7FB3-3D8B-9EE4-221C3DBAD6FE}\r\n// *********************************************************************//\r\n _MissingMemberException = interface(IDispatch)\r\n ['{8897D14B-7FB3-3D8B-9EE4-221C3DBAD6FE}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _MissingMemberExceptionDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {8897D14B-7FB3-3D8B-9EE4-221C3DBAD6FE}\r\n// *********************************************************************//\r\n _MissingMemberExceptionDisp = dispinterface\r\n ['{8897D14B-7FB3-3D8B-9EE4-221C3DBAD6FE}']\r\n end;\r\n {$EXTERNALSYM _MissingMemberExceptionDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _MissingFieldException\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {9717176D-1179-3487-8849-CF5F63DE356E}\r\n// *********************************************************************//\r\n _MissingFieldException = interface(IDispatch)\r\n ['{9717176D-1179-3487-8849-CF5F63DE356E}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _MissingFieldExceptionDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {9717176D-1179-3487-8849-CF5F63DE356E}\r\n// *********************************************************************//\r\n _MissingFieldExceptionDisp = dispinterface\r\n ['{9717176D-1179-3487-8849-CF5F63DE356E}']\r\n end;\r\n {$EXTERNALSYM _MissingFieldExceptionDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _MissingMethodException\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {E5C659F6-92C8-3887-A07E-74D0D9C6267A}\r\n// *********************************************************************//\r\n _MissingMethodException = interface(IDispatch)\r\n ['{E5C659F6-92C8-3887-A07E-74D0D9C6267A}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _MissingMethodExceptionDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {E5C659F6-92C8-3887-A07E-74D0D9C6267A}\r\n// *********************************************************************//\r\n _MissingMethodExceptionDisp = dispinterface\r\n ['{E5C659F6-92C8-3887-A07E-74D0D9C6267A}']\r\n end;\r\n {$EXTERNALSYM _MissingMethodExceptionDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _MulticastNotSupportedException\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {D2BA71CC-1B3D-3966-A0D7-C61E957AD325}\r\n// *********************************************************************//\r\n _MulticastNotSupportedException = interface(IDispatch)\r\n ['{D2BA71CC-1B3D-3966-A0D7-C61E957AD325}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _MulticastNotSupportedExceptionDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {D2BA71CC-1B3D-3966-A0D7-C61E957AD325}\r\n// *********************************************************************//\r\n _MulticastNotSupportedExceptionDisp = dispinterface\r\n ['{D2BA71CC-1B3D-3966-A0D7-C61E957AD325}']\r\n end;\r\n {$EXTERNALSYM _MulticastNotSupportedExceptionDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _NonSerializedAttribute\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {665C9669-B9C6-3ADD-9213-099F0127C893}\r\n// *********************************************************************//\r\n _NonSerializedAttribute = interface(IDispatch)\r\n ['{665C9669-B9C6-3ADD-9213-099F0127C893}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _NonSerializedAttributeDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {665C9669-B9C6-3ADD-9213-099F0127C893}\r\n// *********************************************************************//\r\n _NonSerializedAttributeDisp = dispinterface\r\n ['{665C9669-B9C6-3ADD-9213-099F0127C893}']\r\n end;\r\n {$EXTERNALSYM _NonSerializedAttributeDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _NotFiniteNumberException\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {8E21CE22-4F17-347B-B3B5-6A6DF3E0E58A}\r\n// *********************************************************************//\r\n _NotFiniteNumberException = interface(IDispatch)\r\n ['{8E21CE22-4F17-347B-B3B5-6A6DF3E0E58A}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _NotFiniteNumberExceptionDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {8E21CE22-4F17-347B-B3B5-6A6DF3E0E58A}\r\n// *********************************************************************//\r\n _NotFiniteNumberExceptionDisp = dispinterface\r\n ['{8E21CE22-4F17-347B-B3B5-6A6DF3E0E58A}']\r\n end;\r\n {$EXTERNALSYM _NotFiniteNumberExceptionDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _NotImplementedException\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {1E4D31A2-63EA-397A-A77E-B20AD87A9614}\r\n// *********************************************************************//\r\n _NotImplementedException = interface(IDispatch)\r\n ['{1E4D31A2-63EA-397A-A77E-B20AD87A9614}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _NotImplementedExceptionDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {1E4D31A2-63EA-397A-A77E-B20AD87A9614}\r\n// *********************************************************************//\r\n _NotImplementedExceptionDisp = dispinterface\r\n ['{1E4D31A2-63EA-397A-A77E-B20AD87A9614}']\r\n end;\r\n {$EXTERNALSYM _NotImplementedExceptionDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _NotSupportedException\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {40E5451F-B237-33F8-945B-0230DB700BBB}\r\n// *********************************************************************//\r\n _NotSupportedException = interface(IDispatch)\r\n ['{40E5451F-B237-33F8-945B-0230DB700BBB}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _NotSupportedExceptionDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {40E5451F-B237-33F8-945B-0230DB700BBB}\r\n// *********************************************************************//\r\n _NotSupportedExceptionDisp = dispinterface\r\n ['{40E5451F-B237-33F8-945B-0230DB700BBB}']\r\n end;\r\n {$EXTERNALSYM _NotSupportedExceptionDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _NullReferenceException\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {ECBE2313-CF41-34B4-9FD0-B6CD602B023F}\r\n// *********************************************************************//\r\n _NullReferenceException = interface(IDispatch)\r\n ['{ECBE2313-CF41-34B4-9FD0-B6CD602B023F}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _NullReferenceExceptionDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {ECBE2313-CF41-34B4-9FD0-B6CD602B023F}\r\n// *********************************************************************//\r\n _NullReferenceExceptionDisp = dispinterface\r\n ['{ECBE2313-CF41-34B4-9FD0-B6CD602B023F}']\r\n end;\r\n {$EXTERNALSYM _NullReferenceExceptionDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _ObjectDisposedException\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {17B730BA-45EF-3DDF-9F8D-A490BAC731F4}\r\n// *********************************************************************//\r\n _ObjectDisposedException = interface(IDispatch)\r\n ['{17B730BA-45EF-3DDF-9F8D-A490BAC731F4}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _ObjectDisposedExceptionDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {17B730BA-45EF-3DDF-9F8D-A490BAC731F4}\r\n// *********************************************************************//\r\n _ObjectDisposedExceptionDisp = dispinterface\r\n ['{17B730BA-45EF-3DDF-9F8D-A490BAC731F4}']\r\n end;\r\n {$EXTERNALSYM _ObjectDisposedExceptionDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _ObsoleteAttribute\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {E84307BE-3036-307A-ACC2-5D5DE8A006A8}\r\n// *********************************************************************//\r\n _ObsoleteAttribute = interface(IDispatch)\r\n ['{E84307BE-3036-307A-ACC2-5D5DE8A006A8}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _ObsoleteAttributeDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {E84307BE-3036-307A-ACC2-5D5DE8A006A8}\r\n// *********************************************************************//\r\n _ObsoleteAttributeDisp = dispinterface\r\n ['{E84307BE-3036-307A-ACC2-5D5DE8A006A8}']\r\n end;\r\n {$EXTERNALSYM _ObsoleteAttributeDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _OperatingSystem\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {9E230640-A5D0-30E1-B217-9D2B6CC0FC40}\r\n// *********************************************************************//\r\n _OperatingSystem = interface(IDispatch)\r\n ['{9E230640-A5D0-30E1-B217-9D2B6CC0FC40}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _OperatingSystemDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {9E230640-A5D0-30E1-B217-9D2B6CC0FC40}\r\n// *********************************************************************//\r\n _OperatingSystemDisp = dispinterface\r\n ['{9E230640-A5D0-30E1-B217-9D2B6CC0FC40}']\r\n end;\r\n {$EXTERNALSYM _OperatingSystemDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _OverflowException\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {37C69A5D-7619-3A0F-A96B-9C9578AE00EF}\r\n// *********************************************************************//\r\n _OverflowException = interface(IDispatch)\r\n ['{37C69A5D-7619-3A0F-A96B-9C9578AE00EF}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _OverflowExceptionDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {37C69A5D-7619-3A0F-A96B-9C9578AE00EF}\r\n// *********************************************************************//\r\n _OverflowExceptionDisp = dispinterface\r\n ['{37C69A5D-7619-3A0F-A96B-9C9578AE00EF}']\r\n end;\r\n {$EXTERNALSYM _OverflowExceptionDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _ParamArrayAttribute\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {D54500AE-8CF4-3092-9054-90DC91AC65C9}\r\n// *********************************************************************//\r\n _ParamArrayAttribute = interface(IDispatch)\r\n ['{D54500AE-8CF4-3092-9054-90DC91AC65C9}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _ParamArrayAttributeDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {D54500AE-8CF4-3092-9054-90DC91AC65C9}\r\n// *********************************************************************//\r\n _ParamArrayAttributeDisp = dispinterface\r\n ['{D54500AE-8CF4-3092-9054-90DC91AC65C9}']\r\n end;\r\n {$EXTERNALSYM _ParamArrayAttributeDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _PlatformNotSupportedException\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {1EB8340B-8190-3D9D-92F8-51244B9804C5}\r\n// *********************************************************************//\r\n _PlatformNotSupportedException = interface(IDispatch)\r\n ['{1EB8340B-8190-3D9D-92F8-51244B9804C5}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _PlatformNotSupportedExceptionDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {1EB8340B-8190-3D9D-92F8-51244B9804C5}\r\n// *********************************************************************//\r\n _PlatformNotSupportedExceptionDisp = dispinterface\r\n ['{1EB8340B-8190-3D9D-92F8-51244B9804C5}']\r\n end;\r\n {$EXTERNALSYM _PlatformNotSupportedExceptionDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _Random\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {0F240708-629A-31AB-94A5-2BB476FE1783}\r\n// *********************************************************************//\r\n _Random = interface(IDispatch)\r\n ['{0F240708-629A-31AB-94A5-2BB476FE1783}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _RandomDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {0F240708-629A-31AB-94A5-2BB476FE1783}\r\n// *********************************************************************//\r\n _RandomDisp = dispinterface\r\n ['{0F240708-629A-31AB-94A5-2BB476FE1783}']\r\n end;\r\n {$EXTERNALSYM _RandomDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _RankException\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {871DDC46-B68E-3FEE-A09A-C808B0F827E6}\r\n// *********************************************************************//\r\n _RankException = interface(IDispatch)\r\n ['{871DDC46-B68E-3FEE-A09A-C808B0F827E6}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _RankExceptionDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {871DDC46-B68E-3FEE-A09A-C808B0F827E6}\r\n// *********************************************************************//\r\n _RankExceptionDisp = dispinterface\r\n ['{871DDC46-B68E-3FEE-A09A-C808B0F827E6}']\r\n end;\r\n {$EXTERNALSYM _RankExceptionDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: ICustomAttributeProvider\r\n// Flags: (4416) Dual OleAutomation Dispatchable\r\n// GUID: {B9B91146-D6C2-3A62-8159-C2D1794CDEB0}\r\n// *********************************************************************//\r\n ICustomAttributeProvider = interface(IDispatch)\r\n ['{B9B91146-D6C2-3A62-8159-C2D1794CDEB0}']\r\n function GetCustomAttributes(const attributeType: _Type; inherit: WordBool): PSafeArray; safecall;\r\n function GetCustomAttributes_2(inherit: WordBool): PSafeArray; safecall;\r\n function IsDefined(const attributeType: _Type; inherit: WordBool): WordBool; safecall;\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: ICustomAttributeProviderDisp\r\n// Flags: (4416) Dual OleAutomation Dispatchable\r\n// GUID: {B9B91146-D6C2-3A62-8159-C2D1794CDEB0}\r\n// *********************************************************************//\r\n ICustomAttributeProviderDisp = dispinterface\r\n ['{B9B91146-D6C2-3A62-8159-C2D1794CDEB0}']\r\n function GetCustomAttributes(const attributeType: _Type; inherit: WordBool): {??PSafeArray}OleVariant; dispid 1610743808;\r\n function GetCustomAttributes_2(inherit: WordBool): {??PSafeArray}OleVariant; dispid 1610743809;\r\n function IsDefined(const attributeType: _Type; inherit: WordBool): WordBool; dispid 1610743810;\r\n end;\r\n {$EXTERNALSYM ICustomAttributeProviderDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _MemberInfo\r\n// Flags: (4560) Hidden Dual NonExtensible OleAutomation Dispatchable\r\n// GUID: {F7102FA9-CABB-3A74-A6DA-B4567EF1B079}\r\n// *********************************************************************//\r\n _MemberInfo = interface(IDispatch)\r\n ['{F7102FA9-CABB-3A74-A6DA-B4567EF1B079}']\r\n function Get_ToString: WideString; safecall;\r\n function Equals(obj: OleVariant): WordBool; safecall;\r\n function GetHashCode: Integer; safecall;\r\n function GetType: _Type; safecall;\r\n function Get_MemberType: MemberTypes; safecall;\r\n function Get_name: WideString; safecall;\r\n function Get_DeclaringType: _Type; safecall;\r\n function Get_ReflectedType: _Type; safecall;\r\n function GetCustomAttributes(const attributeType: _Type; inherit: WordBool): PSafeArray; safecall;\r\n function GetCustomAttributes_2(inherit: WordBool): PSafeArray; safecall;\r\n function IsDefined(const attributeType: _Type; inherit: WordBool): WordBool; safecall;\r\n property ToString: WideString read Get_ToString;\r\n property MemberType: MemberTypes read Get_MemberType;\r\n property name: WideString read Get_name;\r\n property DeclaringType: _Type read Get_DeclaringType;\r\n property ReflectedType: _Type read Get_ReflectedType;\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _MemberInfoDisp\r\n// Flags: (4560) Hidden Dual NonExtensible OleAutomation Dispatchable\r\n// GUID: {F7102FA9-CABB-3A74-A6DA-B4567EF1B079}\r\n// *********************************************************************//\r\n _MemberInfoDisp = dispinterface\r\n ['{F7102FA9-CABB-3A74-A6DA-B4567EF1B079}']\r\n property ToString: WideString readonly dispid 0;\r\n function Equals(obj: OleVariant): WordBool; dispid 1610743809;\r\n function GetHashCode: Integer; dispid 1610743810;\r\n function GetType: _Type; dispid 1610743811;\r\n property MemberType: MemberTypes readonly dispid 1610743812;\r\n property name: WideString readonly dispid 1610743813;\r\n property DeclaringType: _Type readonly dispid 1610743814;\r\n property ReflectedType: _Type readonly dispid 1610743815;\r\n function GetCustomAttributes(const attributeType: _Type; inherit: WordBool): {??PSafeArray}OleVariant; dispid 1610743816;\r\n function GetCustomAttributes_2(inherit: WordBool): {??PSafeArray}OleVariant; dispid 1610743817;\r\n function IsDefined(const attributeType: _Type; inherit: WordBool): WordBool; dispid 1610743818;\r\n end;\r\n {$EXTERNALSYM _MemberInfoDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: IReflect\r\n// Flags: (4416) Dual OleAutomation Dispatchable\r\n// GUID: {AFBF15E5-C37C-11D2-B88E-00A0C9B471B8}\r\n// *********************************************************************//\r\n IReflect = interface(IDispatch)\r\n ['{AFBF15E5-C37C-11D2-B88E-00A0C9B471B8}']\r\n function GetMethod(const name: WideString; bindingAttr: BindingFlags; const Binder: _Binder; \r\n types: PSafeArray; modifiers: PSafeArray): _MethodInfo; safecall;\r\n function GetMethod_2(const name: WideString; bindingAttr: BindingFlags): _MethodInfo; safecall;\r\n function GetMethods(bindingAttr: BindingFlags): PSafeArray; safecall;\r\n function GetField(const name: WideString; bindingAttr: BindingFlags): _FieldInfo; safecall;\r\n function GetFields(bindingAttr: BindingFlags): PSafeArray; safecall;\r\n function GetProperty(const name: WideString; bindingAttr: BindingFlags): _PropertyInfo; safecall;\r\n function GetProperty_2(const name: WideString; bindingAttr: BindingFlags; \r\n const Binder: _Binder; const returnType: _Type; types: PSafeArray; \r\n modifiers: PSafeArray): _PropertyInfo; safecall;\r\n function GetProperties(bindingAttr: BindingFlags): PSafeArray; safecall;\r\n function GetMember(const name: WideString; bindingAttr: BindingFlags): PSafeArray; safecall;\r\n function GetMembers(bindingAttr: BindingFlags): PSafeArray; safecall;\r\n function InvokeMember(const name: WideString; invokeAttr: BindingFlags; const Binder: _Binder; \r\n Target: OleVariant; args: PSafeArray; modifiers: PSafeArray; \r\n const culture: _CultureInfo; namedParameters: PSafeArray): OleVariant; safecall;\r\n function Get_UnderlyingSystemType: _Type; safecall;\r\n property UnderlyingSystemType: _Type read Get_UnderlyingSystemType;\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: IReflectDisp\r\n// Flags: (4416) Dual OleAutomation Dispatchable\r\n// GUID: {AFBF15E5-C37C-11D2-B88E-00A0C9B471B8}\r\n// *********************************************************************//\r\n IReflectDisp = dispinterface\r\n ['{AFBF15E5-C37C-11D2-B88E-00A0C9B471B8}']\r\n function GetMethod(const name: WideString; bindingAttr: BindingFlags; const Binder: _Binder; \r\n types: {??PSafeArray}OleVariant; modifiers: {??PSafeArray}OleVariant): _MethodInfo; dispid 1610743808;\r\n function GetMethod_2(const name: WideString; bindingAttr: BindingFlags): _MethodInfo; dispid 1610743809;\r\n function GetMethods(bindingAttr: BindingFlags): {??PSafeArray}OleVariant; dispid 1610743810;\r\n function GetField(const name: WideString; bindingAttr: BindingFlags): _FieldInfo; dispid 1610743811;\r\n function GetFields(bindingAttr: BindingFlags): {??PSafeArray}OleVariant; dispid 1610743812;\r\n function GetProperty(const name: WideString; bindingAttr: BindingFlags): _PropertyInfo; dispid 1610743813;\r\n function GetProperty_2(const name: WideString; bindingAttr: BindingFlags; \r\n const Binder: _Binder; const returnType: _Type; \r\n types: {??PSafeArray}OleVariant; modifiers: {??PSafeArray}OleVariant): _PropertyInfo; dispid 1610743814;\r\n function GetProperties(bindingAttr: BindingFlags): {??PSafeArray}OleVariant; dispid 1610743815;\r\n function GetMember(const name: WideString; bindingAttr: BindingFlags): {??PSafeArray}OleVariant; dispid 1610743816;\r\n function GetMembers(bindingAttr: BindingFlags): {??PSafeArray}OleVariant; dispid 1610743817;\r\n function InvokeMember(const name: WideString; invokeAttr: BindingFlags; const Binder: _Binder; \r\n Target: OleVariant; args: {??PSafeArray}OleVariant; \r\n modifiers: {??PSafeArray}OleVariant; const culture: _CultureInfo; \r\n namedParameters: {??PSafeArray}OleVariant): OleVariant; dispid 1610743818;\r\n property UnderlyingSystemType: _Type readonly dispid 1610743819;\r\n end;\r\n {$EXTERNALSYM IReflectDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _Type\r\n// Flags: (4560) Hidden Dual NonExtensible OleAutomation Dispatchable\r\n// GUID: {BCA8B44D-AAD6-3A86-8AB7-03349F4F2DA2}\r\n// *********************************************************************//\r\n _Type = interface(IDispatch)\r\n ['{BCA8B44D-AAD6-3A86-8AB7-03349F4F2DA2}']\r\n function Get_ToString: WideString; safecall;\r\n function Equals(o: OleVariant): WordBool; safecall;\r\n function GetHashCode: Integer; safecall;\r\n function GetType: _Type; safecall;\r\n function Get_MemberType: MemberTypes; safecall;\r\n function Get_name: WideString; safecall;\r\n function Get_DeclaringType: _Type; safecall;\r\n function Get_ReflectedType: _Type; safecall;\r\n function GetCustomAttributes(const attributeType: _Type; inherit: WordBool): PSafeArray; safecall;\r\n function GetCustomAttributes_2(inherit: WordBool): PSafeArray; safecall;\r\n function IsDefined(const attributeType: _Type; inherit: WordBool): WordBool; safecall;\r\n function Get_Guid: TGUID; safecall;\r\n function Get_Module: _Module; safecall;\r\n function Get_Assembly: _Assembly; safecall;\r\n function Get_TypeHandle: RuntimeTypeHandle; safecall;\r\n function Get_FullName: WideString; safecall;\r\n function Get_Namespace: WideString; safecall;\r\n function Get_AssemblyQualifiedName: WideString; safecall;\r\n function GetArrayRank: Integer; safecall;\r\n function Get_BaseType: _Type; safecall;\r\n function GetConstructors(bindingAttr: BindingFlags): PSafeArray; safecall;\r\n function GetInterface(const name: WideString; ignoreCase: WordBool): _Type; safecall;\r\n function GetInterfaces: PSafeArray; safecall;\r\n function FindInterfaces(const filter: _TypeFilter; filterCriteria: OleVariant): PSafeArray; safecall;\r\n function GetEvent(const name: WideString; bindingAttr: BindingFlags): _EventInfo; safecall;\r\n function GetEvents: PSafeArray; safecall;\r\n function GetEvents_2(bindingAttr: BindingFlags): PSafeArray; safecall;\r\n function GetNestedTypes(bindingAttr: BindingFlags): PSafeArray; safecall;\r\n function GetNestedType(const name: WideString; bindingAttr: BindingFlags): _Type; safecall;\r\n function GetMember(const name: WideString; Type_: MemberTypes; bindingAttr: BindingFlags): PSafeArray; safecall;\r\n function GetDefaultMembers: PSafeArray; safecall;\r\n function FindMembers(MemberType: MemberTypes; bindingAttr: BindingFlags; \r\n const filter: _MemberFilter; filterCriteria: OleVariant): PSafeArray; safecall;\r\n function GetElementType: _Type; safecall;\r\n function IsSubclassOf(const c: _Type): WordBool; safecall;\r\n function IsInstanceOfType(o: OleVariant): WordBool; safecall;\r\n function IsAssignableFrom(const c: _Type): WordBool; safecall;\r\n function GetInterfaceMap(const interfaceType: _Type): InterfaceMapping; safecall;\r\n function GetMethod(const name: WideString; bindingAttr: BindingFlags; const Binder: _Binder; \r\n types: PSafeArray; modifiers: PSafeArray): _MethodInfo; safecall;\r\n function GetMethod_2(const name: WideString; bindingAttr: BindingFlags): _MethodInfo; safecall;\r\n function GetMethods(bindingAttr: BindingFlags): PSafeArray; safecall;\r\n function GetField(const name: WideString; bindingAttr: BindingFlags): _FieldInfo; safecall;\r\n function GetFields(bindingAttr: BindingFlags): PSafeArray; safecall;\r\n function GetProperty(const name: WideString; bindingAttr: BindingFlags): _PropertyInfo; safecall;\r\n function GetProperty_2(const name: WideString; bindingAttr: BindingFlags; \r\n const Binder: _Binder; const returnType: _Type; types: PSafeArray; \r\n modifiers: PSafeArray): _PropertyInfo; safecall;\r\n function GetProperties(bindingAttr: BindingFlags): PSafeArray; safecall;\r\n function GetMember_2(const name: WideString; bindingAttr: BindingFlags): PSafeArray; safecall;\r\n function GetMembers(bindingAttr: BindingFlags): PSafeArray; safecall;\r\n function InvokeMember(const name: WideString; invokeAttr: BindingFlags; const Binder: _Binder; \r\n Target: OleVariant; args: PSafeArray; modifiers: PSafeArray; \r\n const culture: _CultureInfo; namedParameters: PSafeArray): OleVariant; safecall;\r\n function Get_UnderlyingSystemType: _Type; safecall;\r\n function InvokeMember_2(const name: WideString; invokeAttr: BindingFlags; \r\n const Binder: _Binder; Target: OleVariant; args: PSafeArray; \r\n const culture: _CultureInfo): OleVariant; safecall;\r\n function InvokeMember_3(const name: WideString; invokeAttr: BindingFlags; \r\n const Binder: _Binder; Target: OleVariant; args: PSafeArray): OleVariant; safecall;\r\n function GetConstructor(bindingAttr: BindingFlags; const Binder: _Binder; \r\n callConvention: CallingConventions; types: PSafeArray; \r\n modifiers: PSafeArray): _ConstructorInfo; safecall;\r\n function GetConstructor_2(bindingAttr: BindingFlags; const Binder: _Binder; types: PSafeArray; \r\n modifiers: PSafeArray): _ConstructorInfo; safecall;\r\n function GetConstructor_3(types: PSafeArray): _ConstructorInfo; safecall;\r\n function GetConstructors_2: PSafeArray; safecall;\r\n function Get_TypeInitializer: _ConstructorInfo; safecall;\r\n function GetMethod_3(const name: WideString; bindingAttr: BindingFlags; const Binder: _Binder; \r\n callConvention: CallingConventions; types: PSafeArray; \r\n modifiers: PSafeArray): _MethodInfo; safecall;\r\n function GetMethod_4(const name: WideString; types: PSafeArray; modifiers: PSafeArray): _MethodInfo; safecall;\r\n function GetMethod_5(const name: WideString; types: PSafeArray): _MethodInfo; safecall;\r\n function GetMethod_6(const name: WideString): _MethodInfo; safecall;\r\n function GetMethods_2: PSafeArray; safecall;\r\n function GetField_2(const name: WideString): _FieldInfo; safecall;\r\n function GetFields_2: PSafeArray; safecall;\r\n function GetInterface_2(const name: WideString): _Type; safecall;\r\n function GetEvent_2(const name: WideString): _EventInfo; safecall;\r\n function GetProperty_3(const name: WideString; const returnType: _Type; types: PSafeArray; \r\n modifiers: PSafeArray): _PropertyInfo; safecall;\r\n function GetProperty_4(const name: WideString; const returnType: _Type; types: PSafeArray): _PropertyInfo; safecall;\r\n function GetProperty_5(const name: WideString; types: PSafeArray): _PropertyInfo; safecall;\r\n function GetProperty_6(const name: WideString; const returnType: _Type): _PropertyInfo; safecall;\r\n function GetProperty_7(const name: WideString): _PropertyInfo; safecall;\r\n function GetProperties_2: PSafeArray; safecall;\r\n function GetNestedTypes_2: PSafeArray; safecall;\r\n function GetNestedType_2(const name: WideString): _Type; safecall;\r\n function GetMember_3(const name: WideString): PSafeArray; safecall;\r\n function GetMembers_2: PSafeArray; safecall;\r\n function Get_Attributes: TypeAttributes; safecall;\r\n function Get_IsNotPublic: WordBool; safecall;\r\n function Get_IsPublic: WordBool; safecall;\r\n function Get_IsNestedPublic: WordBool; safecall;\r\n function Get_IsNestedPrivate: WordBool; safecall;\r\n function Get_IsNestedFamily: WordBool; safecall;\r\n function Get_IsNestedAssembly: WordBool; safecall;\r\n function Get_IsNestedFamANDAssem: WordBool; safecall;\r\n function Get_IsNestedFamORAssem: WordBool; safecall;\r\n function Get_IsAutoLayout: WordBool; safecall;\r\n function Get_IsLayoutSequential: WordBool; safecall;\r\n function Get_IsExplicitLayout: WordBool; safecall;\r\n function Get_IsClass: WordBool; safecall;\r\n function Get_IsInterface: WordBool; safecall;\r\n function Get_IsValueType: WordBool; safecall;\r\n function Get_IsAbstract: WordBool; safecall;\r\n function Get_IsSealed: WordBool; safecall;\r\n function Get_IsEnum: WordBool; safecall;\r\n function Get_IsSpecialName: WordBool; safecall;\r\n function Get_IsImport: WordBool; safecall;\r\n function Get_IsSerializable: WordBool; safecall;\r\n function Get_IsAnsiClass: WordBool; safecall;\r\n function Get_IsUnicodeClass: WordBool; safecall;\r\n function Get_IsAutoClass: WordBool; safecall;\r\n function Get_IsArray: WordBool; safecall;\r\n function Get_IsByRef: WordBool; safecall;\r\n function Get_IsPointer: WordBool; safecall;\r\n function Get_IsPrimitive: WordBool; safecall;\r\n function Get_IsCOMObject: WordBool; safecall;\r\n function Get_HasElementType: WordBool; safecall;\r\n function Get_IsContextful: WordBool; safecall;\r\n function Get_IsMarshalByRef: WordBool; safecall;\r\n function Equals_2(const o: _Type): WordBool; safecall;\r\n property ToString: WideString read Get_ToString;\r\n property MemberType: MemberTypes read Get_MemberType;\r\n property name: WideString read Get_name;\r\n property DeclaringType: _Type read Get_DeclaringType;\r\n property ReflectedType: _Type read Get_ReflectedType;\r\n property Guid: TGUID read Get_Guid;\r\n property Module: _Module read Get_Module;\r\n property Assembly: _Assembly read Get_Assembly;\r\n property TypeHandle: RuntimeTypeHandle read Get_TypeHandle;\r\n property FullName: WideString read Get_FullName;\r\n property Namespace: WideString read Get_Namespace;\r\n property AssemblyQualifiedName: WideString read Get_AssemblyQualifiedName;\r\n property BaseType: _Type read Get_BaseType;\r\n property UnderlyingSystemType: _Type read Get_UnderlyingSystemType;\r\n property TypeInitializer: _ConstructorInfo read Get_TypeInitializer;\r\n property Attributes: TypeAttributes read Get_Attributes;\r\n property IsNotPublic: WordBool read Get_IsNotPublic;\r\n property IsPublic: WordBool read Get_IsPublic;\r\n property IsNestedPublic: WordBool read Get_IsNestedPublic;\r\n property IsNestedPrivate: WordBool read Get_IsNestedPrivate;\r\n property IsNestedFamily: WordBool read Get_IsNestedFamily;\r\n property IsNestedAssembly: WordBool read Get_IsNestedAssembly;\r\n property IsNestedFamANDAssem: WordBool read Get_IsNestedFamANDAssem;\r\n property IsNestedFamORAssem: WordBool read Get_IsNestedFamORAssem;\r\n property IsAutoLayout: WordBool read Get_IsAutoLayout;\r\n property IsLayoutSequential: WordBool read Get_IsLayoutSequential;\r\n property IsExplicitLayout: WordBool read Get_IsExplicitLayout;\r\n property IsClass: WordBool read Get_IsClass;\r\n property IsInterface: WordBool read Get_IsInterface;\r\n property IsValueType: WordBool read Get_IsValueType;\r\n property IsAbstract: WordBool read Get_IsAbstract;\r\n property IsSealed: WordBool read Get_IsSealed;\r\n property IsEnum: WordBool read Get_IsEnum;\r\n property IsSpecialName: WordBool read Get_IsSpecialName;\r\n property IsImport: WordBool read Get_IsImport;\r\n property IsSerializable: WordBool read Get_IsSerializable;\r\n property IsAnsiClass: WordBool read Get_IsAnsiClass;\r\n property IsUnicodeClass: WordBool read Get_IsUnicodeClass;\r\n property IsAutoClass: WordBool read Get_IsAutoClass;\r\n property IsArray: WordBool read Get_IsArray;\r\n property IsByRef: WordBool read Get_IsByRef;\r\n property IsPointer: WordBool read Get_IsPointer;\r\n property IsPrimitive: WordBool read Get_IsPrimitive;\r\n property IsCOMObject: WordBool read Get_IsCOMObject;\r\n property HasElementType: WordBool read Get_HasElementType;\r\n property IsContextful: WordBool read Get_IsContextful;\r\n property IsMarshalByRef: WordBool read Get_IsMarshalByRef;\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _TypeDisp\r\n// Flags: (4560) Hidden Dual NonExtensible OleAutomation Dispatchable\r\n// GUID: {BCA8B44D-AAD6-3A86-8AB7-03349F4F2DA2}\r\n// *********************************************************************//\r\n _TypeDisp = dispinterface\r\n ['{BCA8B44D-AAD6-3A86-8AB7-03349F4F2DA2}']\r\n property ToString: WideString readonly dispid 0;\r\n function Equals(o: OleVariant): WordBool; dispid 1610743809;\r\n function GetHashCode: Integer; dispid 1610743810;\r\n function GetType: _Type; dispid 1610743811;\r\n property MemberType: MemberTypes readonly dispid 1610743812;\r\n property name: WideString readonly dispid 1610743813;\r\n property DeclaringType: _Type readonly dispid 1610743814;\r\n property ReflectedType: _Type readonly dispid 1610743815;\r\n function GetCustomAttributes(const attributeType: _Type; inherit: WordBool): {??PSafeArray}OleVariant; dispid 1610743816;\r\n function GetCustomAttributes_2(inherit: WordBool): {??PSafeArray}OleVariant; dispid 1610743817;\r\n function IsDefined(const attributeType: _Type; inherit: WordBool): WordBool; dispid 1610743818;\r\n property Guid: {??TGUID}OleVariant readonly dispid 1610743819;\r\n property Module: _Module readonly dispid 1610743820;\r\n property Assembly: _Assembly readonly dispid 1610743821;\r\n property TypeHandle: {??RuntimeTypeHandle}OleVariant readonly dispid 1610743822;\r\n property FullName: WideString readonly dispid 1610743823;\r\n property Namespace: WideString readonly dispid 1610743824;\r\n property AssemblyQualifiedName: WideString readonly dispid 1610743825;\r\n function GetArrayRank: Integer; dispid 1610743826;\r\n property BaseType: _Type readonly dispid 1610743827;\r\n function GetConstructors(bindingAttr: BindingFlags): {??PSafeArray}OleVariant; dispid 1610743828;\r\n function GetInterface(const name: WideString; ignoreCase: WordBool): _Type; dispid 1610743829;\r\n function GetInterfaces: {??PSafeArray}OleVariant; dispid 1610743830;\r\n function FindInterfaces(const filter: _TypeFilter; filterCriteria: OleVariant): {??PSafeArray}OleVariant; dispid 1610743831;\r\n function GetEvent(const name: WideString; bindingAttr: BindingFlags): _EventInfo; dispid 1610743832;\r\n function GetEvents: {??PSafeArray}OleVariant; dispid 1610743833;\r\n function GetEvents_2(bindingAttr: BindingFlags): {??PSafeArray}OleVariant; dispid 1610743834;\r\n function GetNestedTypes(bindingAttr: BindingFlags): {??PSafeArray}OleVariant; dispid 1610743835;\r\n function GetNestedType(const name: WideString; bindingAttr: BindingFlags): _Type; dispid 1610743836;\r\n function GetMember(const name: WideString; Type_: MemberTypes; bindingAttr: BindingFlags): {??PSafeArray}OleVariant; dispid 1610743837;\r\n function GetDefaultMembers: {??PSafeArray}OleVariant; dispid 1610743838;\r\n function FindMembers(MemberType: MemberTypes; bindingAttr: BindingFlags; \r\n const filter: _MemberFilter; filterCriteria: OleVariant): {??PSafeArray}OleVariant; dispid 1610743839;\r\n function GetElementType: _Type; dispid 1610743840;\r\n function IsSubclassOf(const c: _Type): WordBool; dispid 1610743841;\r\n function IsInstanceOfType(o: OleVariant): WordBool; dispid 1610743842;\r\n function IsAssignableFrom(const c: _Type): WordBool; dispid 1610743843;\r\n function GetInterfaceMap(const interfaceType: _Type): {??InterfaceMapping}OleVariant; dispid 1610743844;\r\n function GetMethod(const name: WideString; bindingAttr: BindingFlags; const Binder: _Binder; \r\n types: {??PSafeArray}OleVariant; modifiers: {??PSafeArray}OleVariant): _MethodInfo; dispid 1610743845;\r\n function GetMethod_2(const name: WideString; bindingAttr: BindingFlags): _MethodInfo; dispid 1610743846;\r\n function GetMethods(bindingAttr: BindingFlags): {??PSafeArray}OleVariant; dispid 1610743847;\r\n function GetField(const name: WideString; bindingAttr: BindingFlags): _FieldInfo; dispid 1610743848;\r\n function GetFields(bindingAttr: BindingFlags): {??PSafeArray}OleVariant; dispid 1610743849;\r\n function GetProperty(const name: WideString; bindingAttr: BindingFlags): _PropertyInfo; dispid 1610743850;\r\n function GetProperty_2(const name: WideString; bindingAttr: BindingFlags; \r\n const Binder: _Binder; const returnType: _Type; \r\n types: {??PSafeArray}OleVariant; modifiers: {??PSafeArray}OleVariant): _PropertyInfo; dispid 1610743851;\r\n function GetProperties(bindingAttr: BindingFlags): {??PSafeArray}OleVariant; dispid 1610743852;\r\n function GetMember_2(const name: WideString; bindingAttr: BindingFlags): {??PSafeArray}OleVariant; dispid 1610743853;\r\n function GetMembers(bindingAttr: BindingFlags): {??PSafeArray}OleVariant; dispid 1610743854;\r\n function InvokeMember(const name: WideString; invokeAttr: BindingFlags; const Binder: _Binder; \r\n Target: OleVariant; args: {??PSafeArray}OleVariant; \r\n modifiers: {??PSafeArray}OleVariant; const culture: _CultureInfo; \r\n namedParameters: {??PSafeArray}OleVariant): OleVariant; dispid 1610743855;\r\n property UnderlyingSystemType: _Type readonly dispid 1610743856;\r\n function InvokeMember_2(const name: WideString; invokeAttr: BindingFlags; \r\n const Binder: _Binder; Target: OleVariant; \r\n args: {??PSafeArray}OleVariant; const culture: _CultureInfo): OleVariant; dispid 1610743857;\r\n function InvokeMember_3(const name: WideString; invokeAttr: BindingFlags; \r\n const Binder: _Binder; Target: OleVariant; \r\n args: {??PSafeArray}OleVariant): OleVariant; dispid 1610743858;\r\n function GetConstructor(bindingAttr: BindingFlags; const Binder: _Binder; \r\n callConvention: CallingConventions; types: {??PSafeArray}OleVariant; \r\n modifiers: {??PSafeArray}OleVariant): _ConstructorInfo; dispid 1610743859;\r\n function GetConstructor_2(bindingAttr: BindingFlags; const Binder: _Binder; \r\n types: {??PSafeArray}OleVariant; modifiers: {??PSafeArray}OleVariant): _ConstructorInfo; dispid 1610743860;\r\n function GetConstructor_3(types: {??PSafeArray}OleVariant): _ConstructorInfo; dispid 1610743861;\r\n function GetConstructors_2: {??PSafeArray}OleVariant; dispid 1610743862;\r\n property TypeInitializer: _ConstructorInfo readonly dispid 1610743863;\r\n function GetMethod_3(const name: WideString; bindingAttr: BindingFlags; const Binder: _Binder; \r\n callConvention: CallingConventions; types: {??PSafeArray}OleVariant; \r\n modifiers: {??PSafeArray}OleVariant): _MethodInfo; dispid 1610743864;\r\n function GetMethod_4(const name: WideString; types: {??PSafeArray}OleVariant; \r\n modifiers: {??PSafeArray}OleVariant): _MethodInfo; dispid 1610743865;\r\n function GetMethod_5(const name: WideString; types: {??PSafeArray}OleVariant): _MethodInfo; dispid 1610743866;\r\n function GetMethod_6(const name: WideString): _MethodInfo; dispid 1610743867;\r\n function GetMethods_2: {??PSafeArray}OleVariant; dispid 1610743868;\r\n function GetField_2(const name: WideString): _FieldInfo; dispid 1610743869;\r\n function GetFields_2: {??PSafeArray}OleVariant; dispid 1610743870;\r\n function GetInterface_2(const name: WideString): _Type; dispid 1610743871;\r\n function GetEvent_2(const name: WideString): _EventInfo; dispid 1610743872;\r\n function GetProperty_3(const name: WideString; const returnType: _Type; \r\n types: {??PSafeArray}OleVariant; modifiers: {??PSafeArray}OleVariant): _PropertyInfo; dispid 1610743873;\r\n function GetProperty_4(const name: WideString; const returnType: _Type; \r\n types: {??PSafeArray}OleVariant): _PropertyInfo; dispid 1610743874;\r\n function GetProperty_5(const name: WideString; types: {??PSafeArray}OleVariant): _PropertyInfo; dispid 1610743875;\r\n function GetProperty_6(const name: WideString; const returnType: _Type): _PropertyInfo; dispid 1610743876;\r\n function GetProperty_7(const name: WideString): _PropertyInfo; dispid 1610743877;\r\n function GetProperties_2: {??PSafeArray}OleVariant; dispid 1610743878;\r\n function GetNestedTypes_2: {??PSafeArray}OleVariant; dispid 1610743879;\r\n function GetNestedType_2(const name: WideString): _Type; dispid 1610743880;\r\n function GetMember_3(const name: WideString): {??PSafeArray}OleVariant; dispid 1610743881;\r\n function GetMembers_2: {??PSafeArray}OleVariant; dispid 1610743882;\r\n property Attributes: TypeAttributes readonly dispid 1610743883;\r\n property IsNotPublic: WordBool readonly dispid 1610743884;\r\n property IsPublic: WordBool readonly dispid 1610743885;\r\n property IsNestedPublic: WordBool readonly dispid 1610743886;\r\n property IsNestedPrivate: WordBool readonly dispid 1610743887;\r\n property IsNestedFamily: WordBool readonly dispid 1610743888;\r\n property IsNestedAssembly: WordBool readonly dispid 1610743889;\r\n property IsNestedFamANDAssem: WordBool readonly dispid 1610743890;\r\n property IsNestedFamORAssem: WordBool readonly dispid 1610743891;\r\n property IsAutoLayout: WordBool readonly dispid 1610743892;\r\n property IsLayoutSequential: WordBool readonly dispid 1610743893;\r\n property IsExplicitLayout: WordBool readonly dispid 1610743894;\r\n property IsClass: WordBool readonly dispid 1610743895;\r\n property IsInterface: WordBool readonly dispid 1610743896;\r\n property IsValueType: WordBool readonly dispid 1610743897;\r\n property IsAbstract: WordBool readonly dispid 1610743898;\r\n property IsSealed: WordBool readonly dispid 1610743899;\r\n property IsEnum: WordBool readonly dispid 1610743900;\r\n property IsSpecialName: WordBool readonly dispid 1610743901;\r\n property IsImport: WordBool readonly dispid 1610743902;\r\n property IsSerializable: WordBool readonly dispid 1610743903;\r\n property IsAnsiClass: WordBool readonly dispid 1610743904;\r\n property IsUnicodeClass: WordBool readonly dispid 1610743905;\r\n property IsAutoClass: WordBool readonly dispid 1610743906;\r\n property IsArray: WordBool readonly dispid 1610743907;\r\n property IsByRef: WordBool readonly dispid 1610743908;\r\n property IsPointer: WordBool readonly dispid 1610743909;\r\n property IsPrimitive: WordBool readonly dispid 1610743910;\r\n property IsCOMObject: WordBool readonly dispid 1610743911;\r\n property HasElementType: WordBool readonly dispid 1610743912;\r\n property IsContextful: WordBool readonly dispid 1610743913;\r\n property IsMarshalByRef: WordBool readonly dispid 1610743914;\r\n function Equals_2(const o: _Type): WordBool; dispid 1610743915;\r\n end;\r\n {$EXTERNALSYM _TypeDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _SerializableAttribute\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {1B96E53C-4028-38BC-9DC3-8D7A9555C311}\r\n// *********************************************************************//\r\n _SerializableAttribute = interface(IDispatch)\r\n ['{1B96E53C-4028-38BC-9DC3-8D7A9555C311}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _SerializableAttributeDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {1B96E53C-4028-38BC-9DC3-8D7A9555C311}\r\n// *********************************************************************//\r\n _SerializableAttributeDisp = dispinterface\r\n ['{1B96E53C-4028-38BC-9DC3-8D7A9555C311}']\r\n end;\r\n {$EXTERNALSYM _SerializableAttributeDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _TypeInitializationException\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {FEB0323D-8CE4-36A4-A41E-0BA0C32E1A6A}\r\n// *********************************************************************//\r\n _TypeInitializationException = interface(IDispatch)\r\n ['{FEB0323D-8CE4-36A4-A41E-0BA0C32E1A6A}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _TypeInitializationExceptionDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {FEB0323D-8CE4-36A4-A41E-0BA0C32E1A6A}\r\n// *********************************************************************//\r\n _TypeInitializationExceptionDisp = dispinterface\r\n ['{FEB0323D-8CE4-36A4-A41E-0BA0C32E1A6A}']\r\n end;\r\n {$EXTERNALSYM _TypeInitializationExceptionDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _UnauthorizedAccessException\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {6193C5F6-6807-3561-A7F3-B64C80B5F00F}\r\n// *********************************************************************//\r\n _UnauthorizedAccessException = interface(IDispatch)\r\n ['{6193C5F6-6807-3561-A7F3-B64C80B5F00F}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _UnauthorizedAccessExceptionDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {6193C5F6-6807-3561-A7F3-B64C80B5F00F}\r\n// *********************************************************************//\r\n _UnauthorizedAccessExceptionDisp = dispinterface\r\n ['{6193C5F6-6807-3561-A7F3-B64C80B5F00F}']\r\n end;\r\n {$EXTERNALSYM _UnauthorizedAccessExceptionDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _UnhandledExceptionEventArgs\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {A218E20A-0905-3741-B0B3-9E3193162E50}\r\n// *********************************************************************//\r\n _UnhandledExceptionEventArgs = interface(IDispatch)\r\n ['{A218E20A-0905-3741-B0B3-9E3193162E50}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _UnhandledExceptionEventArgsDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {A218E20A-0905-3741-B0B3-9E3193162E50}\r\n// *********************************************************************//\r\n _UnhandledExceptionEventArgsDisp = dispinterface\r\n ['{A218E20A-0905-3741-B0B3-9E3193162E50}']\r\n end;\r\n {$EXTERNALSYM _UnhandledExceptionEventArgsDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _UnhandledExceptionEventHandler\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {84199E64-439C-3011-B249-3C9065735ADB}\r\n// *********************************************************************//\r\n _UnhandledExceptionEventHandler = interface(IDispatch)\r\n ['{84199E64-439C-3011-B249-3C9065735ADB}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _UnhandledExceptionEventHandlerDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {84199E64-439C-3011-B249-3C9065735ADB}\r\n// *********************************************************************//\r\n _UnhandledExceptionEventHandlerDisp = dispinterface\r\n ['{84199E64-439C-3011-B249-3C9065735ADB}']\r\n end;\r\n {$EXTERNALSYM _UnhandledExceptionEventHandlerDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _Version\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {011A90C5-4910-3C29-BBB7-50D05CCBAA4A}\r\n// *********************************************************************//\r\n _Version = interface(IDispatch)\r\n ['{011A90C5-4910-3C29-BBB7-50D05CCBAA4A}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _VersionDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {011A90C5-4910-3C29-BBB7-50D05CCBAA4A}\r\n// *********************************************************************//\r\n _VersionDisp = dispinterface\r\n ['{011A90C5-4910-3C29-BBB7-50D05CCBAA4A}']\r\n end;\r\n {$EXTERNALSYM _VersionDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _WeakReference\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {C5DF3568-C251-3C58-AFB4-32E79E8261F0}\r\n// *********************************************************************//\r\n _WeakReference = interface(IDispatch)\r\n ['{C5DF3568-C251-3C58-AFB4-32E79E8261F0}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _WeakReferenceDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {C5DF3568-C251-3C58-AFB4-32E79E8261F0}\r\n// *********************************************************************//\r\n _WeakReferenceDisp = dispinterface\r\n ['{C5DF3568-C251-3C58-AFB4-32E79E8261F0}']\r\n end;\r\n {$EXTERNALSYM _WeakReferenceDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _WaitHandle\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {40DFC50A-E93A-3C08-B9EF-E2B4F28B5676}\r\n// *********************************************************************//\r\n _WaitHandle = interface(IDispatch)\r\n ['{40DFC50A-E93A-3C08-B9EF-E2B4F28B5676}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _WaitHandleDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {40DFC50A-E93A-3C08-B9EF-E2B4F28B5676}\r\n// *********************************************************************//\r\n _WaitHandleDisp = dispinterface\r\n ['{40DFC50A-E93A-3C08-B9EF-E2B4F28B5676}']\r\n end;\r\n {$EXTERNALSYM _WaitHandleDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _AutoResetEvent\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {3F243EBD-612F-3DB8-9E03-BD92343A8371}\r\n// *********************************************************************//\r\n _AutoResetEvent = interface(IDispatch)\r\n ['{3F243EBD-612F-3DB8-9E03-BD92343A8371}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _AutoResetEventDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {3F243EBD-612F-3DB8-9E03-BD92343A8371}\r\n// *********************************************************************//\r\n _AutoResetEventDisp = dispinterface\r\n ['{3F243EBD-612F-3DB8-9E03-BD92343A8371}']\r\n end;\r\n {$EXTERNALSYM _AutoResetEventDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _CompressedStack\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {4BCBC4D6-98EB-381A-A8A6-08B2378738ED}\r\n// *********************************************************************//\r\n _CompressedStack = interface(IDispatch)\r\n ['{4BCBC4D6-98EB-381A-A8A6-08B2378738ED}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _CompressedStackDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {4BCBC4D6-98EB-381A-A8A6-08B2378738ED}\r\n// *********************************************************************//\r\n _CompressedStackDisp = dispinterface\r\n ['{4BCBC4D6-98EB-381A-A8A6-08B2378738ED}']\r\n end;\r\n {$EXTERNALSYM _CompressedStackDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _Interlocked\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {DF20F518-8ED1-35E3-950E-020214FDB9B2}\r\n// *********************************************************************//\r\n _Interlocked = interface(IDispatch)\r\n ['{DF20F518-8ED1-35E3-950E-020214FDB9B2}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _InterlockedDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {DF20F518-8ED1-35E3-950E-020214FDB9B2}\r\n// *********************************************************************//\r\n _InterlockedDisp = dispinterface\r\n ['{DF20F518-8ED1-35E3-950E-020214FDB9B2}']\r\n end;\r\n {$EXTERNALSYM _InterlockedDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: IObjectHandle\r\n// Flags: (256) OleAutomation\r\n// GUID: {C460E2B4-E199-412A-8456-84DC3E4838C3}\r\n// *********************************************************************//\r\n IObjectHandle = interface(IUnknown)\r\n ['{C460E2B4-E199-412A-8456-84DC3E4838C3}']\r\n function Unwrap(out pRetVal: OleVariant): HResult; stdcall;\r\n end;\r\n\r\n// *********************************************************************//\r\n// Interface: _ManualResetEvent\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {C0BB9361-268F-3E72-BF6F-4120175A1500}\r\n// *********************************************************************//\r\n _ManualResetEvent = interface(IDispatch)\r\n ['{C0BB9361-268F-3E72-BF6F-4120175A1500}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _ManualResetEventDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {C0BB9361-268F-3E72-BF6F-4120175A1500}\r\n// *********************************************************************//\r\n _ManualResetEventDisp = dispinterface\r\n ['{C0BB9361-268F-3E72-BF6F-4120175A1500}']\r\n end;\r\n {$EXTERNALSYM _ManualResetEventDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _Monitor\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {EE22485E-4C45-3C9D-9027-A8D61C5F53F2}\r\n// *********************************************************************//\r\n _Monitor = interface(IDispatch)\r\n ['{EE22485E-4C45-3C9D-9027-A8D61C5F53F2}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _MonitorDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {EE22485E-4C45-3C9D-9027-A8D61C5F53F2}\r\n// *********************************************************************//\r\n _MonitorDisp = dispinterface\r\n ['{EE22485E-4C45-3C9D-9027-A8D61C5F53F2}']\r\n end;\r\n {$EXTERNALSYM _MonitorDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _Mutex\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {36CB559B-87C6-3AD2-9225-62A7ED499B37}\r\n// *********************************************************************//\r\n _Mutex = interface(IDispatch)\r\n ['{36CB559B-87C6-3AD2-9225-62A7ED499B37}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _MutexDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {36CB559B-87C6-3AD2-9225-62A7ED499B37}\r\n// *********************************************************************//\r\n _MutexDisp = dispinterface\r\n ['{36CB559B-87C6-3AD2-9225-62A7ED499B37}']\r\n end;\r\n {$EXTERNALSYM _MutexDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _Overlapped\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {DD846FCC-8D04-3665-81B6-AACBE99C19C3}\r\n// *********************************************************************//\r\n _Overlapped = interface(IDispatch)\r\n ['{DD846FCC-8D04-3665-81B6-AACBE99C19C3}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _OverlappedDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {DD846FCC-8D04-3665-81B6-AACBE99C19C3}\r\n// *********************************************************************//\r\n _OverlappedDisp = dispinterface\r\n ['{DD846FCC-8D04-3665-81B6-AACBE99C19C3}']\r\n end;\r\n {$EXTERNALSYM _OverlappedDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _ReaderWriterLock\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {AD89B568-4FD4-3F8D-8327-B396B20A460E}\r\n// *********************************************************************//\r\n _ReaderWriterLock = interface(IDispatch)\r\n ['{AD89B568-4FD4-3F8D-8327-B396B20A460E}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _ReaderWriterLockDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {AD89B568-4FD4-3F8D-8327-B396B20A460E}\r\n// *********************************************************************//\r\n _ReaderWriterLockDisp = dispinterface\r\n ['{AD89B568-4FD4-3F8D-8327-B396B20A460E}']\r\n end;\r\n {$EXTERNALSYM _ReaderWriterLockDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _SynchronizationLockException\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {87F55344-17E0-30FD-8EB9-38EAF6A19B3F}\r\n// *********************************************************************//\r\n _SynchronizationLockException = interface(IDispatch)\r\n ['{87F55344-17E0-30FD-8EB9-38EAF6A19B3F}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _SynchronizationLockExceptionDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {87F55344-17E0-30FD-8EB9-38EAF6A19B3F}\r\n// *********************************************************************//\r\n _SynchronizationLockExceptionDisp = dispinterface\r\n ['{87F55344-17E0-30FD-8EB9-38EAF6A19B3F}']\r\n end;\r\n {$EXTERNALSYM _SynchronizationLockExceptionDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _Thread\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {C281C7F1-4AA9-3517-961A-463CFED57E75}\r\n// *********************************************************************//\r\n _Thread = interface(IDispatch)\r\n ['{C281C7F1-4AA9-3517-961A-463CFED57E75}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _ThreadDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {C281C7F1-4AA9-3517-961A-463CFED57E75}\r\n// *********************************************************************//\r\n _ThreadDisp = dispinterface\r\n ['{C281C7F1-4AA9-3517-961A-463CFED57E75}']\r\n end;\r\n {$EXTERNALSYM _ThreadDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _ThreadAbortException\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {95B525DB-6B81-3CDC-8FE7-713F7FC793C0}\r\n// *********************************************************************//\r\n _ThreadAbortException = interface(IDispatch)\r\n ['{95B525DB-6B81-3CDC-8FE7-713F7FC793C0}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _ThreadAbortExceptionDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {95B525DB-6B81-3CDC-8FE7-713F7FC793C0}\r\n// *********************************************************************//\r\n _ThreadAbortExceptionDisp = dispinterface\r\n ['{95B525DB-6B81-3CDC-8FE7-713F7FC793C0}']\r\n end;\r\n {$EXTERNALSYM _ThreadAbortExceptionDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _STAThreadAttribute\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {85D72F83-BE91-3CB1-B4F0-76B56FF04033}\r\n// *********************************************************************//\r\n _STAThreadAttribute = interface(IDispatch)\r\n ['{85D72F83-BE91-3CB1-B4F0-76B56FF04033}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _STAThreadAttributeDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {85D72F83-BE91-3CB1-B4F0-76B56FF04033}\r\n// *********************************************************************//\r\n _STAThreadAttributeDisp = dispinterface\r\n ['{85D72F83-BE91-3CB1-B4F0-76B56FF04033}']\r\n end;\r\n {$EXTERNALSYM _STAThreadAttributeDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _MTAThreadAttribute\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {C02468D1-8713-3225-BDA3-49B2FE37DDBB}\r\n// *********************************************************************//\r\n _MTAThreadAttribute = interface(IDispatch)\r\n ['{C02468D1-8713-3225-BDA3-49B2FE37DDBB}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _MTAThreadAttributeDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {C02468D1-8713-3225-BDA3-49B2FE37DDBB}\r\n// *********************************************************************//\r\n _MTAThreadAttributeDisp = dispinterface\r\n ['{C02468D1-8713-3225-BDA3-49B2FE37DDBB}']\r\n end;\r\n {$EXTERNALSYM _MTAThreadAttributeDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _ThreadInterruptedException\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {B9E07599-7C44-33BE-A70E-EFA16F51F54A}\r\n// *********************************************************************//\r\n _ThreadInterruptedException = interface(IDispatch)\r\n ['{B9E07599-7C44-33BE-A70E-EFA16F51F54A}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _ThreadInterruptedExceptionDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {B9E07599-7C44-33BE-A70E-EFA16F51F54A}\r\n// *********************************************************************//\r\n _ThreadInterruptedExceptionDisp = dispinterface\r\n ['{B9E07599-7C44-33BE-A70E-EFA16F51F54A}']\r\n end;\r\n {$EXTERNALSYM _ThreadInterruptedExceptionDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _RegisteredWaitHandle\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {64409425-F8C9-370E-809E-3241CE804541}\r\n// *********************************************************************//\r\n _RegisteredWaitHandle = interface(IDispatch)\r\n ['{64409425-F8C9-370E-809E-3241CE804541}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _RegisteredWaitHandleDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {64409425-F8C9-370E-809E-3241CE804541}\r\n// *********************************************************************//\r\n _RegisteredWaitHandleDisp = dispinterface\r\n ['{64409425-F8C9-370E-809E-3241CE804541}']\r\n end;\r\n {$EXTERNALSYM _RegisteredWaitHandleDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _WaitCallback\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {CE949142-4D4C-358D-89A9-E69A531AA363}\r\n// *********************************************************************//\r\n _WaitCallback = interface(IDispatch)\r\n ['{CE949142-4D4C-358D-89A9-E69A531AA363}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _WaitCallbackDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {CE949142-4D4C-358D-89A9-E69A531AA363}\r\n// *********************************************************************//\r\n _WaitCallbackDisp = dispinterface\r\n ['{CE949142-4D4C-358D-89A9-E69A531AA363}']\r\n end;\r\n {$EXTERNALSYM _WaitCallbackDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _WaitOrTimerCallback\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {F078F795-F452-3D2D-8CC8-16D66AE46C67}\r\n// *********************************************************************//\r\n _WaitOrTimerCallback = interface(IDispatch)\r\n ['{F078F795-F452-3D2D-8CC8-16D66AE46C67}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _WaitOrTimerCallbackDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {F078F795-F452-3D2D-8CC8-16D66AE46C67}\r\n// *********************************************************************//\r\n _WaitOrTimerCallbackDisp = dispinterface\r\n ['{F078F795-F452-3D2D-8CC8-16D66AE46C67}']\r\n end;\r\n {$EXTERNALSYM _WaitOrTimerCallbackDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _IOCompletionCallback\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {BBAE942D-BFF4-36E2-A3BC-508BB3801F4F}\r\n// *********************************************************************//\r\n _IOCompletionCallback = interface(IDispatch)\r\n ['{BBAE942D-BFF4-36E2-A3BC-508BB3801F4F}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _IOCompletionCallbackDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {BBAE942D-BFF4-36E2-A3BC-508BB3801F4F}\r\n// *********************************************************************//\r\n _IOCompletionCallbackDisp = dispinterface\r\n ['{BBAE942D-BFF4-36E2-A3BC-508BB3801F4F}']\r\n end;\r\n {$EXTERNALSYM _IOCompletionCallbackDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _ThreadPool\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {F5E02ADE-E724-3001-B498-3305B2A93D72}\r\n// *********************************************************************//\r\n _ThreadPool = interface(IDispatch)\r\n ['{F5E02ADE-E724-3001-B498-3305B2A93D72}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _ThreadPoolDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {F5E02ADE-E724-3001-B498-3305B2A93D72}\r\n// *********************************************************************//\r\n _ThreadPoolDisp = dispinterface\r\n ['{F5E02ADE-E724-3001-B498-3305B2A93D72}']\r\n end;\r\n {$EXTERNALSYM _ThreadPoolDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _ThreadStart\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {B45BBD7E-A977-3F56-A626-7A693E5DBBC5}\r\n// *********************************************************************//\r\n _ThreadStart = interface(IDispatch)\r\n ['{B45BBD7E-A977-3F56-A626-7A693E5DBBC5}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _ThreadStartDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {B45BBD7E-A977-3F56-A626-7A693E5DBBC5}\r\n// *********************************************************************//\r\n _ThreadStartDisp = dispinterface\r\n ['{B45BBD7E-A977-3F56-A626-7A693E5DBBC5}']\r\n end;\r\n {$EXTERNALSYM _ThreadStartDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _ThreadStateException\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {A13A41CF-E066-3B90-82F4-73109104E348}\r\n// *********************************************************************//\r\n _ThreadStateException = interface(IDispatch)\r\n ['{A13A41CF-E066-3B90-82F4-73109104E348}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _ThreadStateExceptionDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {A13A41CF-E066-3B90-82F4-73109104E348}\r\n// *********************************************************************//\r\n _ThreadStateExceptionDisp = dispinterface\r\n ['{A13A41CF-E066-3B90-82F4-73109104E348}']\r\n end;\r\n {$EXTERNALSYM _ThreadStateExceptionDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _ThreadStaticAttribute\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {A6B94B6D-854E-3172-A4EC-A17EDD16F85E}\r\n// *********************************************************************//\r\n _ThreadStaticAttribute = interface(IDispatch)\r\n ['{A6B94B6D-854E-3172-A4EC-A17EDD16F85E}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _ThreadStaticAttributeDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {A6B94B6D-854E-3172-A4EC-A17EDD16F85E}\r\n// *********************************************************************//\r\n _ThreadStaticAttributeDisp = dispinterface\r\n ['{A6B94B6D-854E-3172-A4EC-A17EDD16F85E}']\r\n end;\r\n {$EXTERNALSYM _ThreadStaticAttributeDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _Timeout\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {81456E86-22AF-31D1-A91A-9C370C0E2530}\r\n// *********************************************************************//\r\n _Timeout = interface(IDispatch)\r\n ['{81456E86-22AF-31D1-A91A-9C370C0E2530}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _TimeoutDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {81456E86-22AF-31D1-A91A-9C370C0E2530}\r\n// *********************************************************************//\r\n _TimeoutDisp = dispinterface\r\n ['{81456E86-22AF-31D1-A91A-9C370C0E2530}']\r\n end;\r\n {$EXTERNALSYM _TimeoutDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _TimerCallback\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {3741BC6F-101B-36D7-A9D5-03FCC0ECDA35}\r\n// *********************************************************************//\r\n _TimerCallback = interface(IDispatch)\r\n ['{3741BC6F-101B-36D7-A9D5-03FCC0ECDA35}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _TimerCallbackDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {3741BC6F-101B-36D7-A9D5-03FCC0ECDA35}\r\n// *********************************************************************//\r\n _TimerCallbackDisp = dispinterface\r\n ['{3741BC6F-101B-36D7-A9D5-03FCC0ECDA35}']\r\n end;\r\n {$EXTERNALSYM _TimerCallbackDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _Timer\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {B49A029B-406B-3B1E-88E4-F86690D20364}\r\n// *********************************************************************//\r\n _Timer = interface(IDispatch)\r\n ['{B49A029B-406B-3B1E-88E4-F86690D20364}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _TimerDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {B49A029B-406B-3B1E-88E4-F86690D20364}\r\n// *********************************************************************//\r\n _TimerDisp = dispinterface\r\n ['{B49A029B-406B-3B1E-88E4-F86690D20364}']\r\n end;\r\n {$EXTERNALSYM _TimerDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _ArrayList\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {401F89CB-C127-3041-82FD-B67035395C56}\r\n// *********************************************************************//\r\n _ArrayList = interface(IDispatch)\r\n ['{401F89CB-C127-3041-82FD-B67035395C56}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _ArrayListDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {401F89CB-C127-3041-82FD-B67035395C56}\r\n// *********************************************************************//\r\n _ArrayListDisp = dispinterface\r\n ['{401F89CB-C127-3041-82FD-B67035395C56}']\r\n end;\r\n {$EXTERNALSYM _ArrayListDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _BitArray\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {F145C46A-D170-3170-B52F-4678DFCA0300}\r\n// *********************************************************************//\r\n _BitArray = interface(IDispatch)\r\n ['{F145C46A-D170-3170-B52F-4678DFCA0300}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _BitArrayDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {F145C46A-D170-3170-B52F-4678DFCA0300}\r\n// *********************************************************************//\r\n _BitArrayDisp = dispinterface\r\n ['{F145C46A-D170-3170-B52F-4678DFCA0300}']\r\n end;\r\n {$EXTERNALSYM _BitArrayDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: IComparer\r\n// Flags: (4416) Dual OleAutomation Dispatchable\r\n// GUID: {C20FD3EB-7022-3D14-8477-760FAB54E50D}\r\n// *********************************************************************//\r\n IComparer = interface(IDispatch)\r\n ['{C20FD3EB-7022-3D14-8477-760FAB54E50D}']\r\n function Compare(x: OleVariant; y: OleVariant): Integer; safecall;\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: IComparerDisp\r\n// Flags: (4416) Dual OleAutomation Dispatchable\r\n// GUID: {C20FD3EB-7022-3D14-8477-760FAB54E50D}\r\n// *********************************************************************//\r\n IComparerDisp = dispinterface\r\n ['{C20FD3EB-7022-3D14-8477-760FAB54E50D}']\r\n function Compare(x: OleVariant; y: OleVariant): Integer; dispid 1610743808;\r\n end;\r\n {$EXTERNALSYM IComparerDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _CaseInsensitiveComparer\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {EA6795AC-97D6-3377-BE64-829ABD67607B}\r\n// *********************************************************************//\r\n _CaseInsensitiveComparer = interface(IDispatch)\r\n ['{EA6795AC-97D6-3377-BE64-829ABD67607B}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _CaseInsensitiveComparerDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {EA6795AC-97D6-3377-BE64-829ABD67607B}\r\n// *********************************************************************//\r\n _CaseInsensitiveComparerDisp = dispinterface\r\n ['{EA6795AC-97D6-3377-BE64-829ABD67607B}']\r\n end;\r\n {$EXTERNALSYM _CaseInsensitiveComparerDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: IHashCodeProvider\r\n// Flags: (4416) Dual OleAutomation Dispatchable\r\n// GUID: {5D573036-3435-3C5A-AEFF-2B8191082C71}\r\n// *********************************************************************//\r\n IHashCodeProvider = interface(IDispatch)\r\n ['{5D573036-3435-3C5A-AEFF-2B8191082C71}']\r\n function GetHashCode(obj: OleVariant): Integer; safecall;\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: IHashCodeProviderDisp\r\n// Flags: (4416) Dual OleAutomation Dispatchable\r\n// GUID: {5D573036-3435-3C5A-AEFF-2B8191082C71}\r\n// *********************************************************************//\r\n IHashCodeProviderDisp = dispinterface\r\n ['{5D573036-3435-3C5A-AEFF-2B8191082C71}']\r\n function GetHashCode(obj: OleVariant): Integer; dispid 1610743808;\r\n end;\r\n {$EXTERNALSYM IHashCodeProviderDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _CaseInsensitiveHashCodeProvider\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {0422B845-B636-3688-8F61-9B6D93096336}\r\n// *********************************************************************//\r\n _CaseInsensitiveHashCodeProvider = interface(IDispatch)\r\n ['{0422B845-B636-3688-8F61-9B6D93096336}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _CaseInsensitiveHashCodeProviderDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {0422B845-B636-3688-8F61-9B6D93096336}\r\n// *********************************************************************//\r\n _CaseInsensitiveHashCodeProviderDisp = dispinterface\r\n ['{0422B845-B636-3688-8F61-9B6D93096336}']\r\n end;\r\n {$EXTERNALSYM _CaseInsensitiveHashCodeProviderDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _CollectionBase\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {B7D29E26-7798-3FA4-90F4-E6A22D2099F9}\r\n// *********************************************************************//\r\n _CollectionBase = interface(IDispatch)\r\n ['{B7D29E26-7798-3FA4-90F4-E6A22D2099F9}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _CollectionBaseDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {B7D29E26-7798-3FA4-90F4-E6A22D2099F9}\r\n// *********************************************************************//\r\n _CollectionBaseDisp = dispinterface\r\n ['{B7D29E26-7798-3FA4-90F4-E6A22D2099F9}']\r\n end;\r\n {$EXTERNALSYM _CollectionBaseDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _Comparer\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {8064A157-B5C8-3A4A-AD3D-02DC1A39C417}\r\n// *********************************************************************//\r\n _Comparer = interface(IDispatch)\r\n ['{8064A157-B5C8-3A4A-AD3D-02DC1A39C417}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _ComparerDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {8064A157-B5C8-3A4A-AD3D-02DC1A39C417}\r\n// *********************************************************************//\r\n _ComparerDisp = dispinterface\r\n ['{8064A157-B5C8-3A4A-AD3D-02DC1A39C417}']\r\n end;\r\n {$EXTERNALSYM _ComparerDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: IDictionary\r\n// Flags: (4416) Dual OleAutomation Dispatchable\r\n// GUID: {6A6841DF-3287-3D87-8060-CE0B4C77D2A1}\r\n// *********************************************************************//\r\n IDictionary = interface(IDispatch)\r\n ['{6A6841DF-3287-3D87-8060-CE0B4C77D2A1}']\r\n function Get_Item(key: OleVariant): OleVariant; safecall;\r\n procedure _Set_Item(key: OleVariant; pRetVal: OleVariant); safecall;\r\n function Get_Keys: ICollection; safecall;\r\n function Get_Values: ICollection; safecall;\r\n function Contains(key: OleVariant): WordBool; safecall;\r\n procedure Add(key: OleVariant; value: OleVariant); safecall;\r\n procedure Clear; safecall;\r\n function Get_IsReadOnly: WordBool; safecall;\r\n function Get_IsFixedSize: WordBool; safecall;\r\n function GetEnumerator: IDictionaryEnumerator; safecall;\r\n procedure Remove(key: OleVariant); safecall;\r\n property Item[key: OleVariant]: OleVariant read Get_Item write _Set_Item; default;\r\n property Keys: ICollection read Get_Keys;\r\n property Values: ICollection read Get_Values;\r\n property IsReadOnly: WordBool read Get_IsReadOnly;\r\n property IsFixedSize: WordBool read Get_IsFixedSize;\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: IDictionaryDisp\r\n// Flags: (4416) Dual OleAutomation Dispatchable\r\n// GUID: {6A6841DF-3287-3D87-8060-CE0B4C77D2A1}\r\n// *********************************************************************//\r\n IDictionaryDisp = dispinterface\r\n ['{6A6841DF-3287-3D87-8060-CE0B4C77D2A1}']\r\n property Item[key: OleVariant]: OleVariant dispid 0; default;\r\n property Keys: ICollection readonly dispid 1610743810;\r\n property Values: ICollection readonly dispid 1610743811;\r\n function Contains(key: OleVariant): WordBool; dispid 1610743812;\r\n procedure Add(key: OleVariant; value: OleVariant); dispid 1610743813;\r\n procedure Clear; dispid 1610743814;\r\n property IsReadOnly: WordBool readonly dispid 1610743815;\r\n property IsFixedSize: WordBool readonly dispid 1610743816;\r\n function GetEnumerator: IDictionaryEnumerator; dispid 1610743817;\r\n procedure Remove(key: OleVariant); dispid 1610743818;\r\n end;\r\n {$EXTERNALSYM IDictionaryDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _DictionaryBase\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {DDD44DA2-BC6B-3620-9317-C0372968C741}\r\n// *********************************************************************//\r\n _DictionaryBase = interface(IDispatch)\r\n ['{DDD44DA2-BC6B-3620-9317-C0372968C741}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _DictionaryBaseDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {DDD44DA2-BC6B-3620-9317-C0372968C741}\r\n// *********************************************************************//\r\n _DictionaryBaseDisp = dispinterface\r\n ['{DDD44DA2-BC6B-3620-9317-C0372968C741}']\r\n end;\r\n {$EXTERNALSYM _DictionaryBaseDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: IDeserializationCallback\r\n// Flags: (4416) Dual OleAutomation Dispatchable\r\n// GUID: {AB3F47E4-C227-3B05-BF9F-94649BEF9888}\r\n// *********************************************************************//\r\n IDeserializationCallback = interface(IDispatch)\r\n ['{AB3F47E4-C227-3B05-BF9F-94649BEF9888}']\r\n procedure OnDeserialization(sender: OleVariant); safecall;\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: IDeserializationCallbackDisp\r\n// Flags: (4416) Dual OleAutomation Dispatchable\r\n// GUID: {AB3F47E4-C227-3B05-BF9F-94649BEF9888}\r\n// *********************************************************************//\r\n IDeserializationCallbackDisp = dispinterface\r\n ['{AB3F47E4-C227-3B05-BF9F-94649BEF9888}']\r\n procedure OnDeserialization(sender: OleVariant); dispid 1610743808;\r\n end;\r\n {$EXTERNALSYM IDeserializationCallbackDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _Hashtable\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {D25A197E-3E69-3271-A989-23D85E97F920}\r\n// *********************************************************************//\r\n _Hashtable = interface(IDispatch)\r\n ['{D25A197E-3E69-3271-A989-23D85E97F920}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _HashtableDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {D25A197E-3E69-3271-A989-23D85E97F920}\r\n// *********************************************************************//\r\n _HashtableDisp = dispinterface\r\n ['{D25A197E-3E69-3271-A989-23D85E97F920}']\r\n end;\r\n {$EXTERNALSYM _HashtableDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: IDictionaryEnumerator\r\n// Flags: (4416) Dual OleAutomation Dispatchable\r\n// GUID: {35D574BF-7A4F-3588-8C19-12212A0FE4DC}\r\n// *********************************************************************//\r\n IDictionaryEnumerator = interface(IDispatch)\r\n ['{35D574BF-7A4F-3588-8C19-12212A0FE4DC}']\r\n function Get_key: OleVariant; safecall;\r\n function Get_value: OleVariant; safecall;\r\n function Get_Entry: DictionaryEntry; safecall;\r\n property key: OleVariant read Get_key;\r\n property value: OleVariant read Get_value;\r\n property Entry: DictionaryEntry read Get_Entry;\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: IDictionaryEnumeratorDisp\r\n// Flags: (4416) Dual OleAutomation Dispatchable\r\n// GUID: {35D574BF-7A4F-3588-8C19-12212A0FE4DC}\r\n// *********************************************************************//\r\n IDictionaryEnumeratorDisp = dispinterface\r\n ['{35D574BF-7A4F-3588-8C19-12212A0FE4DC}']\r\n property key: OleVariant readonly dispid 1610743808;\r\n property value: OleVariant readonly dispid 0;\r\n property Entry: {??DictionaryEntry}OleVariant readonly dispid 1610743810;\r\n end;\r\n {$EXTERNALSYM IDictionaryEnumeratorDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _Queue\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {3A7D3CA4-B7D1-3A2A-800C-8FC2ACFCBDA4}\r\n// *********************************************************************//\r\n _Queue = interface(IDispatch)\r\n ['{3A7D3CA4-B7D1-3A2A-800C-8FC2ACFCBDA4}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _QueueDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {3A7D3CA4-B7D1-3A2A-800C-8FC2ACFCBDA4}\r\n// *********************************************************************//\r\n _QueueDisp = dispinterface\r\n ['{3A7D3CA4-B7D1-3A2A-800C-8FC2ACFCBDA4}']\r\n end;\r\n {$EXTERNALSYM _QueueDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _ReadOnlyCollectionBase\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {BD32D878-A59B-3E5C-BFE0-A96B1A1E9D6F}\r\n// *********************************************************************//\r\n _ReadOnlyCollectionBase = interface(IDispatch)\r\n ['{BD32D878-A59B-3E5C-BFE0-A96B1A1E9D6F}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _ReadOnlyCollectionBaseDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {BD32D878-A59B-3E5C-BFE0-A96B1A1E9D6F}\r\n// *********************************************************************//\r\n _ReadOnlyCollectionBaseDisp = dispinterface\r\n ['{BD32D878-A59B-3E5C-BFE0-A96B1A1E9D6F}']\r\n end;\r\n {$EXTERNALSYM _ReadOnlyCollectionBaseDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _SortedList\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {56421139-A143-3AE9-9852-1DBDFE3D6BFA}\r\n// *********************************************************************//\r\n _SortedList = interface(IDispatch)\r\n ['{56421139-A143-3AE9-9852-1DBDFE3D6BFA}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _SortedListDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {56421139-A143-3AE9-9852-1DBDFE3D6BFA}\r\n// *********************************************************************//\r\n _SortedListDisp = dispinterface\r\n ['{56421139-A143-3AE9-9852-1DBDFE3D6BFA}']\r\n end;\r\n {$EXTERNALSYM _SortedListDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _Stack\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {AB538809-3C2F-35D9-80E6-7BAD540484A1}\r\n// *********************************************************************//\r\n _Stack = interface(IDispatch)\r\n ['{AB538809-3C2F-35D9-80E6-7BAD540484A1}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _StackDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {AB538809-3C2F-35D9-80E6-7BAD540484A1}\r\n// *********************************************************************//\r\n _StackDisp = dispinterface\r\n ['{AB538809-3C2F-35D9-80E6-7BAD540484A1}']\r\n end;\r\n {$EXTERNALSYM _StackDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _ConditionalAttribute\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {E40A025C-645B-3C8E-A1AC-9C5CCA279625}\r\n// *********************************************************************//\r\n _ConditionalAttribute = interface(IDispatch)\r\n ['{E40A025C-645B-3C8E-A1AC-9C5CCA279625}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _ConditionalAttributeDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {E40A025C-645B-3C8E-A1AC-9C5CCA279625}\r\n// *********************************************************************//\r\n _ConditionalAttributeDisp = dispinterface\r\n ['{E40A025C-645B-3C8E-A1AC-9C5CCA279625}']\r\n end;\r\n {$EXTERNALSYM _ConditionalAttributeDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _Debugger\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {A9B4786C-08E3-344F-A651-2F9926DEAC5E}\r\n// *********************************************************************//\r\n _Debugger = interface(IDispatch)\r\n ['{A9B4786C-08E3-344F-A651-2F9926DEAC5E}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _DebuggerDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {A9B4786C-08E3-344F-A651-2F9926DEAC5E}\r\n// *********************************************************************//\r\n _DebuggerDisp = dispinterface\r\n ['{A9B4786C-08E3-344F-A651-2F9926DEAC5E}']\r\n end;\r\n {$EXTERNALSYM _DebuggerDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _DebuggerStepThroughAttribute\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {3344E8B4-A5C3-3882-8D30-63792485ECCF}\r\n// *********************************************************************//\r\n _DebuggerStepThroughAttribute = interface(IDispatch)\r\n ['{3344E8B4-A5C3-3882-8D30-63792485ECCF}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _DebuggerStepThroughAttributeDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {3344E8B4-A5C3-3882-8D30-63792485ECCF}\r\n// *********************************************************************//\r\n _DebuggerStepThroughAttributeDisp = dispinterface\r\n ['{3344E8B4-A5C3-3882-8D30-63792485ECCF}']\r\n end;\r\n {$EXTERNALSYM _DebuggerStepThroughAttributeDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _DebuggerHiddenAttribute\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {55B6903B-55FE-35E0-804F-E42A096D2EB0}\r\n// *********************************************************************//\r\n _DebuggerHiddenAttribute = interface(IDispatch)\r\n ['{55B6903B-55FE-35E0-804F-E42A096D2EB0}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _DebuggerHiddenAttributeDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {55B6903B-55FE-35E0-804F-E42A096D2EB0}\r\n// *********************************************************************//\r\n _DebuggerHiddenAttributeDisp = dispinterface\r\n ['{55B6903B-55FE-35E0-804F-E42A096D2EB0}']\r\n end;\r\n {$EXTERNALSYM _DebuggerHiddenAttributeDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _DebuggableAttribute\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {428E3627-2B1F-302C-A7E6-6388CD535E75}\r\n// *********************************************************************//\r\n _DebuggableAttribute = interface(IDispatch)\r\n ['{428E3627-2B1F-302C-A7E6-6388CD535E75}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _DebuggableAttributeDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {428E3627-2B1F-302C-A7E6-6388CD535E75}\r\n// *********************************************************************//\r\n _DebuggableAttributeDisp = dispinterface\r\n ['{428E3627-2B1F-302C-A7E6-6388CD535E75}']\r\n end;\r\n {$EXTERNALSYM _DebuggableAttributeDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _StackTrace\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {9A2669EC-FF84-3726-89A0-663A3EF3B5CD}\r\n// *********************************************************************//\r\n _StackTrace = interface(IDispatch)\r\n ['{9A2669EC-FF84-3726-89A0-663A3EF3B5CD}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _StackTraceDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {9A2669EC-FF84-3726-89A0-663A3EF3B5CD}\r\n// *********************************************************************//\r\n _StackTraceDisp = dispinterface\r\n ['{9A2669EC-FF84-3726-89A0-663A3EF3B5CD}']\r\n end;\r\n {$EXTERNALSYM _StackTraceDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _StackFrame\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {0E9B8E47-CA67-38B6-B9DB-2C42EE757B08}\r\n// *********************************************************************//\r\n _StackFrame = interface(IDispatch)\r\n ['{0E9B8E47-CA67-38B6-B9DB-2C42EE757B08}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _StackFrameDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {0E9B8E47-CA67-38B6-B9DB-2C42EE757B08}\r\n// *********************************************************************//\r\n _StackFrameDisp = dispinterface\r\n ['{0E9B8E47-CA67-38B6-B9DB-2C42EE757B08}']\r\n end;\r\n {$EXTERNALSYM _StackFrameDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: ISymbolBinder\r\n// Flags: (4416) Dual OleAutomation Dispatchable\r\n// GUID: {20808ADC-CC01-3F3A-8F09-ED12940FC212}\r\n// *********************************************************************//\r\n ISymbolBinder = interface(IDispatch)\r\n ['{20808ADC-CC01-3F3A-8F09-ED12940FC212}']\r\n function GetReader(importer: Integer; const filename: WideString; const searchPath: WideString): ISymbolReader; safecall;\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: ISymbolBinderDisp\r\n// Flags: (4416) Dual OleAutomation Dispatchable\r\n// GUID: {20808ADC-CC01-3F3A-8F09-ED12940FC212}\r\n// *********************************************************************//\r\n ISymbolBinderDisp = dispinterface\r\n ['{20808ADC-CC01-3F3A-8F09-ED12940FC212}']\r\n function GetReader(importer: Integer; const filename: WideString; const searchPath: WideString): ISymbolReader; dispid 1610743808;\r\n end;\r\n {$EXTERNALSYM ISymbolBinderDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: ISymbolDocument\r\n// Flags: (4416) Dual OleAutomation Dispatchable\r\n// GUID: {1C32F012-2684-3EFE-8D50-9C2973ACC00B}\r\n// *********************************************************************//\r\n ISymbolDocument = interface(IDispatch)\r\n ['{1C32F012-2684-3EFE-8D50-9C2973ACC00B}']\r\n function Get_Url: WideString; safecall;\r\n function Get_DocumentType: TGUID; safecall;\r\n function Get_Language: TGUID; safecall;\r\n function Get_LanguageVendor: TGUID; safecall;\r\n function Get_CheckSumAlgorithmId: TGUID; safecall;\r\n function GetCheckSum: PSafeArray; safecall;\r\n function FindClosestLine(line: Integer): Integer; safecall;\r\n function Get_HasEmbeddedSource: WordBool; safecall;\r\n function Get_SourceLength: Integer; safecall;\r\n function GetSourceRange(startLine: Integer; startColumn: Integer; endLine: Integer; \r\n endColumn: Integer): PSafeArray; safecall;\r\n property Url: WideString read Get_Url;\r\n property DocumentType: TGUID read Get_DocumentType;\r\n property Language: TGUID read Get_Language;\r\n property LanguageVendor: TGUID read Get_LanguageVendor;\r\n property CheckSumAlgorithmId: TGUID read Get_CheckSumAlgorithmId;\r\n property HasEmbeddedSource: WordBool read Get_HasEmbeddedSource;\r\n property SourceLength: Integer read Get_SourceLength;\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: ISymbolDocumentDisp\r\n// Flags: (4416) Dual OleAutomation Dispatchable\r\n// GUID: {1C32F012-2684-3EFE-8D50-9C2973ACC00B}\r\n// *********************************************************************//\r\n ISymbolDocumentDisp = dispinterface\r\n ['{1C32F012-2684-3EFE-8D50-9C2973ACC00B}']\r\n property Url: WideString readonly dispid 1610743808;\r\n property DocumentType: {??TGUID}OleVariant readonly dispid 1610743809;\r\n property Language: {??TGUID}OleVariant readonly dispid 1610743810;\r\n property LanguageVendor: {??TGUID}OleVariant readonly dispid 1610743811;\r\n property CheckSumAlgorithmId: {??TGUID}OleVariant readonly dispid 1610743812;\r\n function GetCheckSum: {??PSafeArray}OleVariant; dispid 1610743813;\r\n function FindClosestLine(line: Integer): Integer; dispid 1610743814;\r\n property HasEmbeddedSource: WordBool readonly dispid 1610743815;\r\n property SourceLength: Integer readonly dispid 1610743816;\r\n function GetSourceRange(startLine: Integer; startColumn: Integer; endLine: Integer; \r\n endColumn: Integer): {??PSafeArray}OleVariant; dispid 1610743817;\r\n end;\r\n {$EXTERNALSYM ISymbolDocumentDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: ISymbolDocumentWriter\r\n// Flags: (4416) Dual OleAutomation Dispatchable\r\n// GUID: {FA682F24-3A3C-390D-B8A2-96F1106F4B37}\r\n// *********************************************************************//\r\n ISymbolDocumentWriter = interface(IDispatch)\r\n ['{FA682F24-3A3C-390D-B8A2-96F1106F4B37}']\r\n procedure SetSource(Source: PSafeArray); safecall;\r\n procedure SetCheckSum(algorithmId: TGUID; checkSum: PSafeArray); safecall;\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: ISymbolDocumentWriterDisp\r\n// Flags: (4416) Dual OleAutomation Dispatchable\r\n// GUID: {FA682F24-3A3C-390D-B8A2-96F1106F4B37}\r\n// *********************************************************************//\r\n ISymbolDocumentWriterDisp = dispinterface\r\n ['{FA682F24-3A3C-390D-B8A2-96F1106F4B37}']\r\n procedure SetSource(Source: {??PSafeArray}OleVariant); dispid 1610743808;\r\n procedure SetCheckSum(algorithmId: {??TGUID}OleVariant; checkSum: {??PSafeArray}OleVariant); dispid 1610743809;\r\n end;\r\n {$EXTERNALSYM ISymbolDocumentWriterDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: ISymbolMethod\r\n// Flags: (4416) Dual OleAutomation Dispatchable\r\n// GUID: {25C72EB0-E437-3F17-946D-3B72A3ACFF37}\r\n// *********************************************************************//\r\n ISymbolMethod = interface(IDispatch)\r\n ['{25C72EB0-E437-3F17-946D-3B72A3ACFF37}']\r\n function Get_Token: SymbolToken; safecall;\r\n function Get_SequencePointCount: Integer; safecall;\r\n procedure GetSequencePoints(offsets: PSafeArray; documents: PSafeArray; lines: PSafeArray; \r\n columns: PSafeArray; endLines: PSafeArray; endColumns: PSafeArray); safecall;\r\n function Get_RootScope: ISymbolScope; safecall;\r\n function GetScope(offset: Integer): ISymbolScope; safecall;\r\n function GetOffset(const document: ISymbolDocument; line: Integer; column: Integer): Integer; safecall;\r\n function GetRanges(const document: ISymbolDocument; line: Integer; column: Integer): PSafeArray; safecall;\r\n function GetParameters: PSafeArray; safecall;\r\n function GetNamespace: ISymbolNamespace; safecall;\r\n function GetSourceStartEnd(docs: PSafeArray; lines: PSafeArray; columns: PSafeArray): WordBool; safecall;\r\n property Token: SymbolToken read Get_Token;\r\n property SequencePointCount: Integer read Get_SequencePointCount;\r\n property RootScope: ISymbolScope read Get_RootScope;\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: ISymbolMethodDisp\r\n// Flags: (4416) Dual OleAutomation Dispatchable\r\n// GUID: {25C72EB0-E437-3F17-946D-3B72A3ACFF37}\r\n// *********************************************************************//\r\n ISymbolMethodDisp = dispinterface\r\n ['{25C72EB0-E437-3F17-946D-3B72A3ACFF37}']\r\n property Token: {??SymbolToken}OleVariant readonly dispid 1610743808;\r\n property SequencePointCount: Integer readonly dispid 1610743809;\r\n procedure GetSequencePoints(offsets: {??PSafeArray}OleVariant; \r\n documents: {??PSafeArray}OleVariant; \r\n lines: {??PSafeArray}OleVariant; columns: {??PSafeArray}OleVariant; \r\n endLines: {??PSafeArray}OleVariant; \r\n endColumns: {??PSafeArray}OleVariant); dispid 1610743810;\r\n property RootScope: ISymbolScope readonly dispid 1610743811;\r\n function GetScope(offset: Integer): ISymbolScope; dispid 1610743812;\r\n function GetOffset(const document: ISymbolDocument; line: Integer; column: Integer): Integer; dispid 1610743813;\r\n function GetRanges(const document: ISymbolDocument; line: Integer; column: Integer): {??PSafeArray}OleVariant; dispid 1610743814;\r\n function GetParameters: {??PSafeArray}OleVariant; dispid 1610743815;\r\n function GetNamespace: ISymbolNamespace; dispid 1610743816;\r\n function GetSourceStartEnd(docs: {??PSafeArray}OleVariant; lines: {??PSafeArray}OleVariant; \r\n columns: {??PSafeArray}OleVariant): WordBool; dispid 1610743817;\r\n end;\r\n {$EXTERNALSYM ISymbolMethodDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: ISymbolNamespace\r\n// Flags: (4416) Dual OleAutomation Dispatchable\r\n// GUID: {23ED2454-6899-3C28-BAB7-6EC86683964A}\r\n// *********************************************************************//\r\n ISymbolNamespace = interface(IDispatch)\r\n ['{23ED2454-6899-3C28-BAB7-6EC86683964A}']\r\n function Get_name: WideString; safecall;\r\n function GetNamespaces: PSafeArray; safecall;\r\n function GetVariables: PSafeArray; safecall;\r\n property name: WideString read Get_name;\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: ISymbolNamespaceDisp\r\n// Flags: (4416) Dual OleAutomation Dispatchable\r\n// GUID: {23ED2454-6899-3C28-BAB7-6EC86683964A}\r\n// *********************************************************************//\r\n ISymbolNamespaceDisp = dispinterface\r\n ['{23ED2454-6899-3C28-BAB7-6EC86683964A}']\r\n property name: WideString readonly dispid 1610743808;\r\n function GetNamespaces: {??PSafeArray}OleVariant; dispid 1610743809;\r\n function GetVariables: {??PSafeArray}OleVariant; dispid 1610743810;\r\n end;\r\n {$EXTERNALSYM ISymbolNamespaceDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: ISymbolReader\r\n// Flags: (4416) Dual OleAutomation Dispatchable\r\n// GUID: {E809A5F1-D3D7-3144-9BEF-FE8AC0364699}\r\n// *********************************************************************//\r\n ISymbolReader = interface(IDispatch)\r\n ['{E809A5F1-D3D7-3144-9BEF-FE8AC0364699}']\r\n function GetDocument(const Url: WideString; Language: TGUID; LanguageVendor: TGUID; \r\n DocumentType: TGUID): ISymbolDocument; safecall;\r\n function GetDocuments: PSafeArray; safecall;\r\n function Get_UserEntryPoint: SymbolToken; safecall;\r\n function GetMethod(Method: SymbolToken): ISymbolMethod; safecall;\r\n function GetMethod_2(Method: SymbolToken; Version: Integer): ISymbolMethod; safecall;\r\n function GetVariables(parent: SymbolToken): PSafeArray; safecall;\r\n function GetGlobalVariables: PSafeArray; safecall;\r\n function GetMethodFromDocumentPosition(const document: ISymbolDocument; line: Integer; \r\n column: Integer): ISymbolMethod; safecall;\r\n function GetSymAttribute(parent: SymbolToken; const name: WideString): PSafeArray; safecall;\r\n function GetNamespaces: PSafeArray; safecall;\r\n property UserEntryPoint: SymbolToken read Get_UserEntryPoint;\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: ISymbolReaderDisp\r\n// Flags: (4416) Dual OleAutomation Dispatchable\r\n// GUID: {E809A5F1-D3D7-3144-9BEF-FE8AC0364699}\r\n// *********************************************************************//\r\n ISymbolReaderDisp = dispinterface\r\n ['{E809A5F1-D3D7-3144-9BEF-FE8AC0364699}']\r\n function GetDocument(const Url: WideString; Language: {??TGUID}OleVariant; \r\n LanguageVendor: {??TGUID}OleVariant; DocumentType: {??TGUID}OleVariant): ISymbolDocument; dispid 1610743808;\r\n function GetDocuments: {??PSafeArray}OleVariant; dispid 1610743809;\r\n property UserEntryPoint: {??SymbolToken}OleVariant readonly dispid 1610743810;\r\n function GetMethod(Method: {??SymbolToken}OleVariant): ISymbolMethod; dispid 1610743811;\r\n function GetMethod_2(Method: {??SymbolToken}OleVariant; Version: Integer): ISymbolMethod; dispid 1610743812;\r\n function GetVariables(parent: {??SymbolToken}OleVariant): {??PSafeArray}OleVariant; dispid 1610743813;\r\n function GetGlobalVariables: {??PSafeArray}OleVariant; dispid 1610743814;\r\n function GetMethodFromDocumentPosition(const document: ISymbolDocument; line: Integer; \r\n column: Integer): ISymbolMethod; dispid 1610743815;\r\n function GetSymAttribute(parent: {??SymbolToken}OleVariant; const name: WideString): {??PSafeArray}OleVariant; dispid 1610743816;\r\n function GetNamespaces: {??PSafeArray}OleVariant; dispid 1610743817;\r\n end;\r\n {$EXTERNALSYM ISymbolReaderDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: ISymbolScope\r\n// Flags: (4416) Dual OleAutomation Dispatchable\r\n// GUID: {1CEE3A11-01AE-3244-A939-4972FC9703EF}\r\n// *********************************************************************//\r\n ISymbolScope = interface(IDispatch)\r\n ['{1CEE3A11-01AE-3244-A939-4972FC9703EF}']\r\n function Get_Method: ISymbolMethod; safecall;\r\n function Get_parent: ISymbolScope; safecall;\r\n function GetChildren: PSafeArray; safecall;\r\n function Get_StartOffset: Integer; safecall;\r\n function Get_EndOffset: Integer; safecall;\r\n function GetLocals: PSafeArray; safecall;\r\n function GetNamespaces: PSafeArray; safecall;\r\n property Method: ISymbolMethod read Get_Method;\r\n property parent: ISymbolScope read Get_parent;\r\n property StartOffset: Integer read Get_StartOffset;\r\n property EndOffset: Integer read Get_EndOffset;\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: ISymbolScopeDisp\r\n// Flags: (4416) Dual OleAutomation Dispatchable\r\n// GUID: {1CEE3A11-01AE-3244-A939-4972FC9703EF}\r\n// *********************************************************************//\r\n ISymbolScopeDisp = dispinterface\r\n ['{1CEE3A11-01AE-3244-A939-4972FC9703EF}']\r\n property Method: ISymbolMethod readonly dispid 1610743808;\r\n property parent: ISymbolScope readonly dispid 1610743809;\r\n function GetChildren: {??PSafeArray}OleVariant; dispid 1610743810;\r\n property StartOffset: Integer readonly dispid 1610743811;\r\n property EndOffset: Integer readonly dispid 1610743812;\r\n function GetLocals: {??PSafeArray}OleVariant; dispid 1610743813;\r\n function GetNamespaces: {??PSafeArray}OleVariant; dispid 1610743814;\r\n end;\r\n {$EXTERNALSYM ISymbolScopeDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: ISymbolVariable\r\n// Flags: (4416) Dual OleAutomation Dispatchable\r\n// GUID: {4042BD4D-B5AB-30E8-919B-14910687BAAE}\r\n// *********************************************************************//\r\n ISymbolVariable = interface(IDispatch)\r\n ['{4042BD4D-B5AB-30E8-919B-14910687BAAE}']\r\n function Get_name: WideString; safecall;\r\n function Get_Attributes: OleVariant; safecall;\r\n function GetSignature: PSafeArray; safecall;\r\n function Get_AddressKind: SymAddressKind; safecall;\r\n function Get_AddressField1: Integer; safecall;\r\n function Get_AddressField2: Integer; safecall;\r\n function Get_AddressField3: Integer; safecall;\r\n function Get_StartOffset: Integer; safecall;\r\n function Get_EndOffset: Integer; safecall;\r\n property name: WideString read Get_name;\r\n property Attributes: OleVariant read Get_Attributes;\r\n property AddressKind: SymAddressKind read Get_AddressKind;\r\n property AddressField1: Integer read Get_AddressField1;\r\n property AddressField2: Integer read Get_AddressField2;\r\n property AddressField3: Integer read Get_AddressField3;\r\n property StartOffset: Integer read Get_StartOffset;\r\n property EndOffset: Integer read Get_EndOffset;\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: ISymbolVariableDisp\r\n// Flags: (4416) Dual OleAutomation Dispatchable\r\n// GUID: {4042BD4D-B5AB-30E8-919B-14910687BAAE}\r\n// *********************************************************************//\r\n ISymbolVariableDisp = dispinterface\r\n ['{4042BD4D-B5AB-30E8-919B-14910687BAAE}']\r\n property name: WideString readonly dispid 1610743808;\r\n property Attributes: OleVariant readonly dispid 1610743809;\r\n function GetSignature: {??PSafeArray}OleVariant; dispid 1610743810;\r\n property AddressKind: SymAddressKind readonly dispid 1610743811;\r\n property AddressField1: Integer readonly dispid 1610743812;\r\n property AddressField2: Integer readonly dispid 1610743813;\r\n property AddressField3: Integer readonly dispid 1610743814;\r\n property StartOffset: Integer readonly dispid 1610743815;\r\n property EndOffset: Integer readonly dispid 1610743816;\r\n end;\r\n {$EXTERNALSYM ISymbolVariableDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: ISymbolWriter\r\n// Flags: (4416) Dual OleAutomation Dispatchable\r\n// GUID: {DA295A1B-C5BD-3B34-8ACD-1D7D334FFB7F}\r\n// *********************************************************************//\r\n ISymbolWriter = interface(IDispatch)\r\n ['{DA295A1B-C5BD-3B34-8ACD-1D7D334FFB7F}']\r\n procedure Initialize(emitter: Integer; const filename: WideString; fFullBuild: WordBool); safecall;\r\n function DefineDocument(const Url: WideString; Language: TGUID; LanguageVendor: TGUID; \r\n DocumentType: TGUID): ISymbolDocumentWriter; safecall;\r\n procedure SetUserEntryPoint(entryMethod: SymbolToken); safecall;\r\n procedure OpenMethod(Method: SymbolToken); safecall;\r\n procedure CloseMethod; safecall;\r\n procedure DefineSequencePoints(const document: ISymbolDocumentWriter; offsets: PSafeArray; \r\n lines: PSafeArray; columns: PSafeArray; endLines: PSafeArray; \r\n endColumns: PSafeArray); safecall;\r\n function OpenScope(StartOffset: Integer): Integer; safecall;\r\n procedure CloseScope(EndOffset: Integer); safecall;\r\n procedure SetScopeRange(scopeID: Integer; StartOffset: Integer; EndOffset: Integer); safecall;\r\n procedure DefineLocalVariable(const name: WideString; Attributes: FieldAttributes; \r\n signature: PSafeArray; addrKind: SymAddressKind; addr1: Integer; \r\n addr2: Integer; addr3: Integer; StartOffset: Integer; \r\n EndOffset: Integer); safecall;\r\n procedure DefineParameter(const name: WideString; Attributes: ParameterAttributes; \r\n sequence: Integer; addrKind: SymAddressKind; addr1: Integer; \r\n addr2: Integer; addr3: Integer); safecall;\r\n procedure DefineField(parent: SymbolToken; const name: WideString; Attributes: FieldAttributes; \r\n signature: PSafeArray; addrKind: SymAddressKind; addr1: Integer; \r\n addr2: Integer; addr3: Integer); safecall;\r\n procedure DefineGlobalVariable(const name: WideString; Attributes: FieldAttributes; \r\n signature: PSafeArray; addrKind: SymAddressKind; addr1: Integer; \r\n addr2: Integer; addr3: Integer); safecall;\r\n procedure Close; safecall;\r\n procedure SetSymAttribute(parent: SymbolToken; const name: WideString; data: PSafeArray); safecall;\r\n procedure OpenNamespace(const name: WideString); safecall;\r\n procedure CloseNamespace; safecall;\r\n procedure UsingNamespace(const FullName: WideString); safecall;\r\n procedure SetMethodSourceRange(const startDoc: ISymbolDocumentWriter; startLine: Integer; \r\n startColumn: Integer; const endDoc: ISymbolDocumentWriter; \r\n endLine: Integer; endColumn: Integer); safecall;\r\n procedure SetUnderlyingWriter(underlyingWriter: Integer); safecall;\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: ISymbolWriterDisp\r\n// Flags: (4416) Dual OleAutomation Dispatchable\r\n// GUID: {DA295A1B-C5BD-3B34-8ACD-1D7D334FFB7F}\r\n// *********************************************************************//\r\n ISymbolWriterDisp = dispinterface\r\n ['{DA295A1B-C5BD-3B34-8ACD-1D7D334FFB7F}']\r\n procedure Initialize(emitter: Integer; const filename: WideString; fFullBuild: WordBool); dispid 1610743808;\r\n function DefineDocument(const Url: WideString; Language: {??TGUID}OleVariant; \r\n LanguageVendor: {??TGUID}OleVariant; DocumentType: {??TGUID}OleVariant): ISymbolDocumentWriter; dispid 1610743809;\r\n procedure SetUserEntryPoint(entryMethod: {??SymbolToken}OleVariant); dispid 1610743810;\r\n procedure OpenMethod(Method: {??SymbolToken}OleVariant); dispid 1610743811;\r\n procedure CloseMethod; dispid 1610743812;\r\n procedure DefineSequencePoints(const document: ISymbolDocumentWriter; \r\n offsets: {??PSafeArray}OleVariant; \r\n lines: {??PSafeArray}OleVariant; \r\n columns: {??PSafeArray}OleVariant; \r\n endLines: {??PSafeArray}OleVariant; \r\n endColumns: {??PSafeArray}OleVariant); dispid 1610743813;\r\n function OpenScope(StartOffset: Integer): Integer; dispid 1610743814;\r\n procedure CloseScope(EndOffset: Integer); dispid 1610743815;\r\n procedure SetScopeRange(scopeID: Integer; StartOffset: Integer; EndOffset: Integer); dispid 1610743816;\r\n procedure DefineLocalVariable(const name: WideString; Attributes: FieldAttributes; \r\n signature: {??PSafeArray}OleVariant; addrKind: SymAddressKind; \r\n addr1: Integer; addr2: Integer; addr3: Integer; \r\n StartOffset: Integer; EndOffset: Integer); dispid 1610743817;\r\n procedure DefineParameter(const name: WideString; Attributes: ParameterAttributes; \r\n sequence: Integer; addrKind: SymAddressKind; addr1: Integer; \r\n addr2: Integer; addr3: Integer); dispid 1610743818;\r\n procedure DefineField(parent: {??SymbolToken}OleVariant; const name: WideString; \r\n Attributes: FieldAttributes; signature: {??PSafeArray}OleVariant; \r\n addrKind: SymAddressKind; addr1: Integer; addr2: Integer; addr3: Integer); dispid 1610743819;\r\n procedure DefineGlobalVariable(const name: WideString; Attributes: FieldAttributes; \r\n signature: {??PSafeArray}OleVariant; addrKind: SymAddressKind; \r\n addr1: Integer; addr2: Integer; addr3: Integer); dispid 1610743820;\r\n procedure Close; dispid 1610743821;\r\n procedure SetSymAttribute(parent: {??SymbolToken}OleVariant; const name: WideString; \r\n data: {??PSafeArray}OleVariant); dispid 1610743822;\r\n procedure OpenNamespace(const name: WideString); dispid 1610743823;\r\n procedure CloseNamespace; dispid 1610743824;\r\n procedure UsingNamespace(const FullName: WideString); dispid 1610743825;\r\n procedure SetMethodSourceRange(const startDoc: ISymbolDocumentWriter; startLine: Integer; \r\n startColumn: Integer; const endDoc: ISymbolDocumentWriter; \r\n endLine: Integer; endColumn: Integer); dispid 1610743826;\r\n procedure SetUnderlyingWriter(underlyingWriter: Integer); dispid 1610743827;\r\n end;\r\n {$EXTERNALSYM ISymbolWriterDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _SymDocumentType\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {5141D79C-7B01-37DA-B7E9-53E5A271BAF8}\r\n// *********************************************************************//\r\n _SymDocumentType = interface(IDispatch)\r\n ['{5141D79C-7B01-37DA-B7E9-53E5A271BAF8}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _SymDocumentTypeDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {5141D79C-7B01-37DA-B7E9-53E5A271BAF8}\r\n// *********************************************************************//\r\n _SymDocumentTypeDisp = dispinterface\r\n ['{5141D79C-7B01-37DA-B7E9-53E5A271BAF8}']\r\n end;\r\n {$EXTERNALSYM _SymDocumentTypeDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _SymLanguageType\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {22BB8891-FD21-313D-92E4-8A892DC0B39C}\r\n// *********************************************************************//\r\n _SymLanguageType = interface(IDispatch)\r\n ['{22BB8891-FD21-313D-92E4-8A892DC0B39C}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _SymLanguageTypeDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {22BB8891-FD21-313D-92E4-8A892DC0B39C}\r\n// *********************************************************************//\r\n _SymLanguageTypeDisp = dispinterface\r\n ['{22BB8891-FD21-313D-92E4-8A892DC0B39C}']\r\n end;\r\n {$EXTERNALSYM _SymLanguageTypeDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _SymLanguageVendor\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {01364E7B-C983-3651-B7D8-FD1B64FC0E00}\r\n// *********************************************************************//\r\n _SymLanguageVendor = interface(IDispatch)\r\n ['{01364E7B-C983-3651-B7D8-FD1B64FC0E00}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _SymLanguageVendorDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {01364E7B-C983-3651-B7D8-FD1B64FC0E00}\r\n// *********************************************************************//\r\n _SymLanguageVendorDisp = dispinterface\r\n ['{01364E7B-C983-3651-B7D8-FD1B64FC0E00}']\r\n end;\r\n {$EXTERNALSYM _SymLanguageVendorDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _AmbiguousMatchException\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {81AA0D59-C3B1-36A3-B2E7-054928FBFC1A}\r\n// *********************************************************************//\r\n _AmbiguousMatchException = interface(IDispatch)\r\n ['{81AA0D59-C3B1-36A3-B2E7-054928FBFC1A}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _AmbiguousMatchExceptionDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {81AA0D59-C3B1-36A3-B2E7-054928FBFC1A}\r\n// *********************************************************************//\r\n _AmbiguousMatchExceptionDisp = dispinterface\r\n ['{81AA0D59-C3B1-36A3-B2E7-054928FBFC1A}']\r\n end;\r\n {$EXTERNALSYM _AmbiguousMatchExceptionDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _ModuleResolveEventHandler\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {05532E88-E0F2-3263-9B57-805AC6B6BB72}\r\n// *********************************************************************//\r\n _ModuleResolveEventHandler = interface(IDispatch)\r\n ['{05532E88-E0F2-3263-9B57-805AC6B6BB72}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _ModuleResolveEventHandlerDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {05532E88-E0F2-3263-9B57-805AC6B6BB72}\r\n// *********************************************************************//\r\n _ModuleResolveEventHandlerDisp = dispinterface\r\n ['{05532E88-E0F2-3263-9B57-805AC6B6BB72}']\r\n end;\r\n {$EXTERNALSYM _ModuleResolveEventHandlerDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _Assembly\r\n// Flags: (4560) Hidden Dual NonExtensible OleAutomation Dispatchable\r\n// GUID: {17156360-2F1A-384A-BC52-FDE93C215C5B}\r\n// *********************************************************************//\r\n _Assembly = interface(IDispatch)\r\n ['{17156360-2F1A-384A-BC52-FDE93C215C5B}']\r\n function Get_ToString: WideString; safecall;\r\n function Equals(obj: OleVariant): WordBool; safecall;\r\n function GetHashCode: Integer; safecall;\r\n function GetType: _Type; safecall;\r\n function Get_CodeBase: WideString; safecall;\r\n function Get_EscapedCodeBase: WideString; safecall;\r\n function GetName: _AssemblyName; safecall;\r\n function GetName_2(copiedName: WordBool): _AssemblyName; safecall;\r\n function Get_FullName: WideString; safecall;\r\n function Get_EntryPoint: _MethodInfo; safecall;\r\n function GetType_2(const name: WideString): _Type; safecall;\r\n function GetType_3(const name: WideString; throwOnError: WordBool): _Type; safecall;\r\n function GetExportedTypes: PSafeArray; safecall;\r\n function GetTypes: PSafeArray; safecall;\r\n function GetManifestResourceStream(const Type_: _Type; const name: WideString): _Stream; safecall;\r\n function GetManifestResourceStream_2(const name: WideString): _Stream; safecall;\r\n function GetFile(const name: WideString): _FileStream; safecall;\r\n function GetFiles: PSafeArray; safecall;\r\n function GetFiles_2(getResourceModules: WordBool): PSafeArray; safecall;\r\n function GetManifestResourceNames: PSafeArray; safecall;\r\n function GetManifestResourceInfo(const resourceName: WideString): _ManifestResourceInfo; safecall;\r\n function Get_Location: WideString; safecall;\r\n function Get_Evidence: _Evidence; safecall;\r\n function GetCustomAttributes(const attributeType: _Type; inherit: WordBool): PSafeArray; safecall;\r\n function GetCustomAttributes_2(inherit: WordBool): PSafeArray; safecall;\r\n function IsDefined(const attributeType: _Type; inherit: WordBool): WordBool; safecall;\r\n procedure GetObjectData(const info: _SerializationInfo; Context: StreamingContext); safecall;\r\n procedure add_ModuleResolve(const value: _ModuleResolveEventHandler); safecall;\r\n procedure remove_ModuleResolve(const value: _ModuleResolveEventHandler); safecall;\r\n function GetType_4(const name: WideString; throwOnError: WordBool; ignoreCase: WordBool): _Type; safecall;\r\n function GetSatelliteAssembly(const culture: _CultureInfo): _Assembly; safecall;\r\n function GetSatelliteAssembly_2(const culture: _CultureInfo; const Version: _Version): _Assembly; safecall;\r\n function LoadModule(const moduleName: WideString; rawModule: PSafeArray): _Module; safecall;\r\n function LoadModule_2(const moduleName: WideString; rawModule: PSafeArray; \r\n rawSymbolStore: PSafeArray): _Module; safecall;\r\n function CreateInstance(const typeName: WideString): OleVariant; safecall;\r\n function CreateInstance_2(const typeName: WideString; ignoreCase: WordBool): OleVariant; safecall;\r\n function CreateInstance_3(const typeName: WideString; ignoreCase: WordBool; \r\n bindingAttr: BindingFlags; const Binder: _Binder; args: PSafeArray; \r\n const culture: _CultureInfo; activationAttributes: PSafeArray): OleVariant; safecall;\r\n function GetLoadedModules: PSafeArray; safecall;\r\n function GetLoadedModules_2(getResourceModules: WordBool): PSafeArray; safecall;\r\n function GetModules: PSafeArray; safecall;\r\n function GetModules_2(getResourceModules: WordBool): PSafeArray; safecall;\r\n function GetModule(const name: WideString): _Module; safecall;\r\n function GetReferencedAssemblies: PSafeArray; safecall;\r\n function Get_GlobalAssemblyCache: WordBool; safecall;\r\n property ToString: WideString read Get_ToString;\r\n property CodeBase: WideString read Get_CodeBase;\r\n property EscapedCodeBase: WideString read Get_EscapedCodeBase;\r\n property FullName: WideString read Get_FullName;\r\n property EntryPoint: _MethodInfo read Get_EntryPoint;\r\n property Location: WideString read Get_Location;\r\n property Evidence: _Evidence read Get_Evidence;\r\n property GlobalAssemblyCache: WordBool read Get_GlobalAssemblyCache;\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _AssemblyDisp\r\n// Flags: (4560) Hidden Dual NonExtensible OleAutomation Dispatchable\r\n// GUID: {17156360-2F1A-384A-BC52-FDE93C215C5B}\r\n// *********************************************************************//\r\n _AssemblyDisp = dispinterface\r\n ['{17156360-2F1A-384A-BC52-FDE93C215C5B}']\r\n property ToString: WideString readonly dispid 0;\r\n function Equals(obj: OleVariant): WordBool; dispid 1610743809;\r\n function GetHashCode: Integer; dispid 1610743810;\r\n function GetType: _Type; dispid 1610743811;\r\n property CodeBase: WideString readonly dispid 1610743812;\r\n property EscapedCodeBase: WideString readonly dispid 1610743813;\r\n function GetName: _AssemblyName; dispid 1610743814;\r\n function GetName_2(copiedName: WordBool): _AssemblyName; dispid 1610743815;\r\n property FullName: WideString readonly dispid 1610743816;\r\n property EntryPoint: _MethodInfo readonly dispid 1610743817;\r\n function GetType_2(const name: WideString): _Type; dispid 1610743818;\r\n function GetType_3(const name: WideString; throwOnError: WordBool): _Type; dispid 1610743819;\r\n function GetExportedTypes: {??PSafeArray}OleVariant; dispid 1610743820;\r\n function GetTypes: {??PSafeArray}OleVariant; dispid 1610743821;\r\n function GetManifestResourceStream(const Type_: _Type; const name: WideString): _Stream; dispid 1610743822;\r\n function GetManifestResourceStream_2(const name: WideString): _Stream; dispid 1610743823;\r\n function GetFile(const name: WideString): _FileStream; dispid 1610743824;\r\n function GetFiles: {??PSafeArray}OleVariant; dispid 1610743825;\r\n function GetFiles_2(getResourceModules: WordBool): {??PSafeArray}OleVariant; dispid 1610743826;\r\n function GetManifestResourceNames: {??PSafeArray}OleVariant; dispid 1610743827;\r\n function GetManifestResourceInfo(const resourceName: WideString): _ManifestResourceInfo; dispid 1610743828;\r\n property Location: WideString readonly dispid 1610743829;\r\n property Evidence: _Evidence readonly dispid 1610743830;\r\n function GetCustomAttributes(const attributeType: _Type; inherit: WordBool): {??PSafeArray}OleVariant; dispid 1610743831;\r\n function GetCustomAttributes_2(inherit: WordBool): {??PSafeArray}OleVariant; dispid 1610743832;\r\n function IsDefined(const attributeType: _Type; inherit: WordBool): WordBool; dispid 1610743833;\r\n procedure GetObjectData(const info: _SerializationInfo; Context: {??StreamingContext}OleVariant); dispid 1610743834;\r\n procedure add_ModuleResolve(const value: _ModuleResolveEventHandler); dispid 1610743835;\r\n procedure remove_ModuleResolve(const value: _ModuleResolveEventHandler); dispid 1610743836;\r\n function GetType_4(const name: WideString; throwOnError: WordBool; ignoreCase: WordBool): _Type; dispid 1610743837;\r\n function GetSatelliteAssembly(const culture: _CultureInfo): _Assembly; dispid 1610743838;\r\n function GetSatelliteAssembly_2(const culture: _CultureInfo; const Version: _Version): _Assembly; dispid 1610743839;\r\n function LoadModule(const moduleName: WideString; rawModule: {??PSafeArray}OleVariant): _Module; dispid 1610743840;\r\n function LoadModule_2(const moduleName: WideString; rawModule: {??PSafeArray}OleVariant; \r\n rawSymbolStore: {??PSafeArray}OleVariant): _Module; dispid 1610743841;\r\n function CreateInstance(const typeName: WideString): OleVariant; dispid 1610743842;\r\n function CreateInstance_2(const typeName: WideString; ignoreCase: WordBool): OleVariant; dispid 1610743843;\r\n function CreateInstance_3(const typeName: WideString; ignoreCase: WordBool; \r\n bindingAttr: BindingFlags; const Binder: _Binder; \r\n args: {??PSafeArray}OleVariant; const culture: _CultureInfo; \r\n activationAttributes: {??PSafeArray}OleVariant): OleVariant; dispid 1610743844;\r\n function GetLoadedModules: {??PSafeArray}OleVariant; dispid 1610743845;\r\n function GetLoadedModules_2(getResourceModules: WordBool): {??PSafeArray}OleVariant; dispid 1610743846;\r\n function GetModules: {??PSafeArray}OleVariant; dispid 1610743847;\r\n function GetModules_2(getResourceModules: WordBool): {??PSafeArray}OleVariant; dispid 1610743848;\r\n function GetModule(const name: WideString): _Module; dispid 1610743849;\r\n function GetReferencedAssemblies: {??PSafeArray}OleVariant; dispid 1610743850;\r\n property GlobalAssemblyCache: WordBool readonly dispid 1610743851;\r\n end;\r\n {$EXTERNALSYM _AssemblyDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _AssemblyCultureAttribute\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {177C4E63-9E0B-354D-838B-B52AA8683EF6}\r\n// *********************************************************************//\r\n _AssemblyCultureAttribute = interface(IDispatch)\r\n ['{177C4E63-9E0B-354D-838B-B52AA8683EF6}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _AssemblyCultureAttributeDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {177C4E63-9E0B-354D-838B-B52AA8683EF6}\r\n// *********************************************************************//\r\n _AssemblyCultureAttributeDisp = dispinterface\r\n ['{177C4E63-9E0B-354D-838B-B52AA8683EF6}']\r\n end;\r\n {$EXTERNALSYM _AssemblyCultureAttributeDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _AssemblyVersionAttribute\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {A1693C5C-101F-3557-94DB-C480CEB4C16B}\r\n// *********************************************************************//\r\n _AssemblyVersionAttribute = interface(IDispatch)\r\n ['{A1693C5C-101F-3557-94DB-C480CEB4C16B}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _AssemblyVersionAttributeDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {A1693C5C-101F-3557-94DB-C480CEB4C16B}\r\n// *********************************************************************//\r\n _AssemblyVersionAttributeDisp = dispinterface\r\n ['{A1693C5C-101F-3557-94DB-C480CEB4C16B}']\r\n end;\r\n {$EXTERNALSYM _AssemblyVersionAttributeDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _AssemblyKeyFileAttribute\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {A9FCDA18-C237-3C6F-A6EF-749BE22BA2BF}\r\n// *********************************************************************//\r\n _AssemblyKeyFileAttribute = interface(IDispatch)\r\n ['{A9FCDA18-C237-3C6F-A6EF-749BE22BA2BF}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _AssemblyKeyFileAttributeDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {A9FCDA18-C237-3C6F-A6EF-749BE22BA2BF}\r\n// *********************************************************************//\r\n _AssemblyKeyFileAttributeDisp = dispinterface\r\n ['{A9FCDA18-C237-3C6F-A6EF-749BE22BA2BF}']\r\n end;\r\n {$EXTERNALSYM _AssemblyKeyFileAttributeDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _AssemblyKeyNameAttribute\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {322A304D-11AC-3814-A905-A019F6E3DAE9}\r\n// *********************************************************************//\r\n _AssemblyKeyNameAttribute = interface(IDispatch)\r\n ['{322A304D-11AC-3814-A905-A019F6E3DAE9}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _AssemblyKeyNameAttributeDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {322A304D-11AC-3814-A905-A019F6E3DAE9}\r\n// *********************************************************************//\r\n _AssemblyKeyNameAttributeDisp = dispinterface\r\n ['{322A304D-11AC-3814-A905-A019F6E3DAE9}']\r\n end;\r\n {$EXTERNALSYM _AssemblyKeyNameAttributeDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _AssemblyDelaySignAttribute\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {6CF1C077-C974-38E1-90A4-976E4835E165}\r\n// *********************************************************************//\r\n _AssemblyDelaySignAttribute = interface(IDispatch)\r\n ['{6CF1C077-C974-38E1-90A4-976E4835E165}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _AssemblyDelaySignAttributeDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {6CF1C077-C974-38E1-90A4-976E4835E165}\r\n// *********************************************************************//\r\n _AssemblyDelaySignAttributeDisp = dispinterface\r\n ['{6CF1C077-C974-38E1-90A4-976E4835E165}']\r\n end;\r\n {$EXTERNALSYM _AssemblyDelaySignAttributeDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _AssemblyAlgorithmIdAttribute\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {57B849AA-D8EF-3EA6-9538-C5B4D498C2F7}\r\n// *********************************************************************//\r\n _AssemblyAlgorithmIdAttribute = interface(IDispatch)\r\n ['{57B849AA-D8EF-3EA6-9538-C5B4D498C2F7}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _AssemblyAlgorithmIdAttributeDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {57B849AA-D8EF-3EA6-9538-C5B4D498C2F7}\r\n// *********************************************************************//\r\n _AssemblyAlgorithmIdAttributeDisp = dispinterface\r\n ['{57B849AA-D8EF-3EA6-9538-C5B4D498C2F7}']\r\n end;\r\n {$EXTERNALSYM _AssemblyAlgorithmIdAttributeDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _AssemblyFlagsAttribute\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {0ECD8635-F5EB-3E4A-8989-4D684D67C48A}\r\n// *********************************************************************//\r\n _AssemblyFlagsAttribute = interface(IDispatch)\r\n ['{0ECD8635-F5EB-3E4A-8989-4D684D67C48A}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _AssemblyFlagsAttributeDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {0ECD8635-F5EB-3E4A-8989-4D684D67C48A}\r\n// *********************************************************************//\r\n _AssemblyFlagsAttributeDisp = dispinterface\r\n ['{0ECD8635-F5EB-3E4A-8989-4D684D67C48A}']\r\n end;\r\n {$EXTERNALSYM _AssemblyFlagsAttributeDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _AssemblyFileVersionAttribute\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {B101FE3C-4479-311A-A945-1225EE1731E8}\r\n// *********************************************************************//\r\n _AssemblyFileVersionAttribute = interface(IDispatch)\r\n ['{B101FE3C-4479-311A-A945-1225EE1731E8}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _AssemblyFileVersionAttributeDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {B101FE3C-4479-311A-A945-1225EE1731E8}\r\n// *********************************************************************//\r\n _AssemblyFileVersionAttributeDisp = dispinterface\r\n ['{B101FE3C-4479-311A-A945-1225EE1731E8}']\r\n end;\r\n {$EXTERNALSYM _AssemblyFileVersionAttributeDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _AssemblyName\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {B42B6AAC-317E-34D5-9FA9-093BB4160C50}\r\n// *********************************************************************//\r\n _AssemblyName = interface(IDispatch)\r\n ['{B42B6AAC-317E-34D5-9FA9-093BB4160C50}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _AssemblyNameDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {B42B6AAC-317E-34D5-9FA9-093BB4160C50}\r\n// *********************************************************************//\r\n _AssemblyNameDisp = dispinterface\r\n ['{B42B6AAC-317E-34D5-9FA9-093BB4160C50}']\r\n end;\r\n {$EXTERNALSYM _AssemblyNameDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _AssemblyNameProxy\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {FE52F19A-8AA8-309C-BF99-9D0A566FB76A}\r\n// *********************************************************************//\r\n _AssemblyNameProxy = interface(IDispatch)\r\n ['{FE52F19A-8AA8-309C-BF99-9D0A566FB76A}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _AssemblyNameProxyDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {FE52F19A-8AA8-309C-BF99-9D0A566FB76A}\r\n// *********************************************************************//\r\n _AssemblyNameProxyDisp = dispinterface\r\n ['{FE52F19A-8AA8-309C-BF99-9D0A566FB76A}']\r\n end;\r\n {$EXTERNALSYM _AssemblyNameProxyDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _AssemblyCopyrightAttribute\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {6163F792-3CD6-38F1-B5F7-000B96A5082B}\r\n// *********************************************************************//\r\n _AssemblyCopyrightAttribute = interface(IDispatch)\r\n ['{6163F792-3CD6-38F1-B5F7-000B96A5082B}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _AssemblyCopyrightAttributeDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {6163F792-3CD6-38F1-B5F7-000B96A5082B}\r\n// *********************************************************************//\r\n _AssemblyCopyrightAttributeDisp = dispinterface\r\n ['{6163F792-3CD6-38F1-B5F7-000B96A5082B}']\r\n end;\r\n {$EXTERNALSYM _AssemblyCopyrightAttributeDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _AssemblyTrademarkAttribute\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {64C26BF9-C9E5-3F66-AD74-BEBAADE36214}\r\n// *********************************************************************//\r\n _AssemblyTrademarkAttribute = interface(IDispatch)\r\n ['{64C26BF9-C9E5-3F66-AD74-BEBAADE36214}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _AssemblyTrademarkAttributeDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {64C26BF9-C9E5-3F66-AD74-BEBAADE36214}\r\n// *********************************************************************//\r\n _AssemblyTrademarkAttributeDisp = dispinterface\r\n ['{64C26BF9-C9E5-3F66-AD74-BEBAADE36214}']\r\n end;\r\n {$EXTERNALSYM _AssemblyTrademarkAttributeDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _AssemblyProductAttribute\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {DE10D587-A188-3DCB-8000-92DFDB9B8021}\r\n// *********************************************************************//\r\n _AssemblyProductAttribute = interface(IDispatch)\r\n ['{DE10D587-A188-3DCB-8000-92DFDB9B8021}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _AssemblyProductAttributeDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {DE10D587-A188-3DCB-8000-92DFDB9B8021}\r\n// *********************************************************************//\r\n _AssemblyProductAttributeDisp = dispinterface\r\n ['{DE10D587-A188-3DCB-8000-92DFDB9B8021}']\r\n end;\r\n {$EXTERNALSYM _AssemblyProductAttributeDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _AssemblyCompanyAttribute\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {C6802233-EF82-3C91-AD72-B3A5D7230ED5}\r\n// *********************************************************************//\r\n _AssemblyCompanyAttribute = interface(IDispatch)\r\n ['{C6802233-EF82-3C91-AD72-B3A5D7230ED5}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _AssemblyCompanyAttributeDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {C6802233-EF82-3C91-AD72-B3A5D7230ED5}\r\n// *********************************************************************//\r\n _AssemblyCompanyAttributeDisp = dispinterface\r\n ['{C6802233-EF82-3C91-AD72-B3A5D7230ED5}']\r\n end;\r\n {$EXTERNALSYM _AssemblyCompanyAttributeDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _AssemblyDescriptionAttribute\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {6B2C0BC4-DDB7-38EA-8A86-F0B59E192816}\r\n// *********************************************************************//\r\n _AssemblyDescriptionAttribute = interface(IDispatch)\r\n ['{6B2C0BC4-DDB7-38EA-8A86-F0B59E192816}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _AssemblyDescriptionAttributeDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {6B2C0BC4-DDB7-38EA-8A86-F0B59E192816}\r\n// *********************************************************************//\r\n _AssemblyDescriptionAttributeDisp = dispinterface\r\n ['{6B2C0BC4-DDB7-38EA-8A86-F0B59E192816}']\r\n end;\r\n {$EXTERNALSYM _AssemblyDescriptionAttributeDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _AssemblyTitleAttribute\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {DF44CAD3-CEF2-36A9-B013-383CC03177D7}\r\n// *********************************************************************//\r\n _AssemblyTitleAttribute = interface(IDispatch)\r\n ['{DF44CAD3-CEF2-36A9-B013-383CC03177D7}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _AssemblyTitleAttributeDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {DF44CAD3-CEF2-36A9-B013-383CC03177D7}\r\n// *********************************************************************//\r\n _AssemblyTitleAttributeDisp = dispinterface\r\n ['{DF44CAD3-CEF2-36A9-B013-383CC03177D7}']\r\n end;\r\n {$EXTERNALSYM _AssemblyTitleAttributeDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _AssemblyConfigurationAttribute\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {746D1D1E-EE37-393B-B6FA-E387D37553AA}\r\n// *********************************************************************//\r\n _AssemblyConfigurationAttribute = interface(IDispatch)\r\n ['{746D1D1E-EE37-393B-B6FA-E387D37553AA}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _AssemblyConfigurationAttributeDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {746D1D1E-EE37-393B-B6FA-E387D37553AA}\r\n// *********************************************************************//\r\n _AssemblyConfigurationAttributeDisp = dispinterface\r\n ['{746D1D1E-EE37-393B-B6FA-E387D37553AA}']\r\n end;\r\n {$EXTERNALSYM _AssemblyConfigurationAttributeDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _AssemblyDefaultAliasAttribute\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {04311D35-75EC-347B-BEDF-969487CE4014}\r\n// *********************************************************************//\r\n _AssemblyDefaultAliasAttribute = interface(IDispatch)\r\n ['{04311D35-75EC-347B-BEDF-969487CE4014}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _AssemblyDefaultAliasAttributeDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {04311D35-75EC-347B-BEDF-969487CE4014}\r\n// *********************************************************************//\r\n _AssemblyDefaultAliasAttributeDisp = dispinterface\r\n ['{04311D35-75EC-347B-BEDF-969487CE4014}']\r\n end;\r\n {$EXTERNALSYM _AssemblyDefaultAliasAttributeDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _AssemblyInformationalVersionAttribute\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {C6F5946C-143A-3747-A7C0-ABFADA6BDEB7}\r\n// *********************************************************************//\r\n _AssemblyInformationalVersionAttribute = interface(IDispatch)\r\n ['{C6F5946C-143A-3747-A7C0-ABFADA6BDEB7}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _AssemblyInformationalVersionAttributeDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {C6F5946C-143A-3747-A7C0-ABFADA6BDEB7}\r\n// *********************************************************************//\r\n _AssemblyInformationalVersionAttributeDisp = dispinterface\r\n ['{C6F5946C-143A-3747-A7C0-ABFADA6BDEB7}']\r\n end;\r\n {$EXTERNALSYM _AssemblyInformationalVersionAttributeDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _CustomAttributeFormatException\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {1660EB67-EE41-363E-BEB0-C2DE09214ABF}\r\n// *********************************************************************//\r\n _CustomAttributeFormatException = interface(IDispatch)\r\n ['{1660EB67-EE41-363E-BEB0-C2DE09214ABF}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _CustomAttributeFormatExceptionDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {1660EB67-EE41-363E-BEB0-C2DE09214ABF}\r\n// *********************************************************************//\r\n _CustomAttributeFormatExceptionDisp = dispinterface\r\n ['{1660EB67-EE41-363E-BEB0-C2DE09214ABF}']\r\n end;\r\n {$EXTERNALSYM _CustomAttributeFormatExceptionDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _MethodBase\r\n// Flags: (4560) Hidden Dual NonExtensible OleAutomation Dispatchable\r\n// GUID: {6240837A-707F-3181-8E98-A36AE086766B}\r\n// *********************************************************************//\r\n _MethodBase = interface(IDispatch)\r\n ['{6240837A-707F-3181-8E98-A36AE086766B}']\r\n function Get_ToString: WideString; safecall;\r\n function Equals(obj: OleVariant): WordBool; safecall;\r\n function GetHashCode: Integer; safecall;\r\n function GetType: _Type; safecall;\r\n function Get_MemberType: MemberTypes; safecall;\r\n function Get_name: WideString; safecall;\r\n function Get_DeclaringType: _Type; safecall;\r\n function Get_ReflectedType: _Type; safecall;\r\n function GetCustomAttributes(const attributeType: _Type; inherit: WordBool): PSafeArray; safecall;\r\n function GetCustomAttributes_2(inherit: WordBool): PSafeArray; safecall;\r\n function IsDefined(const attributeType: _Type; inherit: WordBool): WordBool; safecall;\r\n function GetParameters: PSafeArray; safecall;\r\n function GetMethodImplementationFlags: MethodImplAttributes; safecall;\r\n function Get_MethodHandle: RuntimeMethodHandle; safecall;\r\n function Get_Attributes: MethodAttributes; safecall;\r\n function Get_CallingConvention: CallingConventions; safecall;\r\n function Invoke_2(obj: OleVariant; invokeAttr: BindingFlags; const Binder: _Binder; \r\n parameters: PSafeArray; const culture: _CultureInfo): OleVariant; safecall;\r\n function Get_IsPublic: WordBool; safecall;\r\n function Get_IsPrivate: WordBool; safecall;\r\n function Get_IsFamily: WordBool; safecall;\r\n function Get_IsAssembly: WordBool; safecall;\r\n function Get_IsFamilyAndAssembly: WordBool; safecall;\r\n function Get_IsFamilyOrAssembly: WordBool; safecall;\r\n function Get_IsStatic: WordBool; safecall;\r\n function Get_IsFinal: WordBool; safecall;\r\n function Get_IsVirtual: WordBool; safecall;\r\n function Get_IsHideBySig: WordBool; safecall;\r\n function Get_IsAbstract: WordBool; safecall;\r\n function Get_IsSpecialName: WordBool; safecall;\r\n function Get_IsConstructor: WordBool; safecall;\r\n function Invoke_3(obj: OleVariant; parameters: PSafeArray): OleVariant; safecall;\r\n property ToString: WideString read Get_ToString;\r\n property MemberType: MemberTypes read Get_MemberType;\r\n property name: WideString read Get_name;\r\n property DeclaringType: _Type read Get_DeclaringType;\r\n property ReflectedType: _Type read Get_ReflectedType;\r\n property MethodHandle: RuntimeMethodHandle read Get_MethodHandle;\r\n property Attributes: MethodAttributes read Get_Attributes;\r\n property CallingConvention: CallingConventions read Get_CallingConvention;\r\n property IsPublic: WordBool read Get_IsPublic;\r\n property IsPrivate: WordBool read Get_IsPrivate;\r\n property IsFamily: WordBool read Get_IsFamily;\r\n property IsAssembly: WordBool read Get_IsAssembly;\r\n property IsFamilyAndAssembly: WordBool read Get_IsFamilyAndAssembly;\r\n property IsFamilyOrAssembly: WordBool read Get_IsFamilyOrAssembly;\r\n property IsStatic: WordBool read Get_IsStatic;\r\n property IsFinal: WordBool read Get_IsFinal;\r\n property IsVirtual: WordBool read Get_IsVirtual;\r\n property IsHideBySig: WordBool read Get_IsHideBySig;\r\n property IsAbstract: WordBool read Get_IsAbstract;\r\n property IsSpecialName: WordBool read Get_IsSpecialName;\r\n property IsConstructor: WordBool read Get_IsConstructor;\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _MethodBaseDisp\r\n// Flags: (4560) Hidden Dual NonExtensible OleAutomation Dispatchable\r\n// GUID: {6240837A-707F-3181-8E98-A36AE086766B}\r\n// *********************************************************************//\r\n _MethodBaseDisp = dispinterface\r\n ['{6240837A-707F-3181-8E98-A36AE086766B}']\r\n property ToString: WideString readonly dispid 0;\r\n function Equals(obj: OleVariant): WordBool; dispid 1610743809;\r\n function GetHashCode: Integer; dispid 1610743810;\r\n function GetType: _Type; dispid 1610743811;\r\n property MemberType: MemberTypes readonly dispid 1610743812;\r\n property name: WideString readonly dispid 1610743813;\r\n property DeclaringType: _Type readonly dispid 1610743814;\r\n property ReflectedType: _Type readonly dispid 1610743815;\r\n function GetCustomAttributes(const attributeType: _Type; inherit: WordBool): {??PSafeArray}OleVariant; dispid 1610743816;\r\n function GetCustomAttributes_2(inherit: WordBool): {??PSafeArray}OleVariant; dispid 1610743817;\r\n function IsDefined(const attributeType: _Type; inherit: WordBool): WordBool; dispid 1610743818;\r\n function GetParameters: {??PSafeArray}OleVariant; dispid 1610743819;\r\n function GetMethodImplementationFlags: MethodImplAttributes; dispid 1610743820;\r\n property MethodHandle: {??RuntimeMethodHandle}OleVariant readonly dispid 1610743821;\r\n property Attributes: MethodAttributes readonly dispid 1610743822;\r\n property CallingConvention: CallingConventions readonly dispid 1610743823;\r\n function Invoke_2(obj: OleVariant; invokeAttr: BindingFlags; const Binder: _Binder; \r\n parameters: {??PSafeArray}OleVariant; const culture: _CultureInfo): OleVariant; dispid 1610743824;\r\n property IsPublic: WordBool readonly dispid 1610743825;\r\n property IsPrivate: WordBool readonly dispid 1610743826;\r\n property IsFamily: WordBool readonly dispid 1610743827;\r\n property IsAssembly: WordBool readonly dispid 1610743828;\r\n property IsFamilyAndAssembly: WordBool readonly dispid 1610743829;\r\n property IsFamilyOrAssembly: WordBool readonly dispid 1610743830;\r\n property IsStatic: WordBool readonly dispid 1610743831;\r\n property IsFinal: WordBool readonly dispid 1610743832;\r\n property IsVirtual: WordBool readonly dispid 1610743833;\r\n property IsHideBySig: WordBool readonly dispid 1610743834;\r\n property IsAbstract: WordBool readonly dispid 1610743835;\r\n property IsSpecialName: WordBool readonly dispid 1610743836;\r\n property IsConstructor: WordBool readonly dispid 1610743837;\r\n function Invoke_3(obj: OleVariant; parameters: {??PSafeArray}OleVariant): OleVariant; dispid 1610743838;\r\n end;\r\n {$EXTERNALSYM _MethodBaseDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _ConstructorInfo\r\n// Flags: (4560) Hidden Dual NonExtensible OleAutomation Dispatchable\r\n// GUID: {E9A19478-9646-3679-9B10-8411AE1FD57D}\r\n// *********************************************************************//\r\n _ConstructorInfo = interface(IDispatch)\r\n ['{E9A19478-9646-3679-9B10-8411AE1FD57D}']\r\n function Get_ToString: WideString; safecall;\r\n function Equals(obj: OleVariant): WordBool; safecall;\r\n function GetHashCode: Integer; safecall;\r\n function GetType: _Type; safecall;\r\n function Get_MemberType: MemberTypes; safecall;\r\n function Get_name: WideString; safecall;\r\n function Get_DeclaringType: _Type; safecall;\r\n function Get_ReflectedType: _Type; safecall;\r\n function GetCustomAttributes(const attributeType: _Type; inherit: WordBool): PSafeArray; safecall;\r\n function GetCustomAttributes_2(inherit: WordBool): PSafeArray; safecall;\r\n function IsDefined(const attributeType: _Type; inherit: WordBool): WordBool; safecall;\r\n function GetParameters: PSafeArray; safecall;\r\n function GetMethodImplementationFlags: MethodImplAttributes; safecall;\r\n function Get_MethodHandle: RuntimeMethodHandle; safecall;\r\n function Get_Attributes: MethodAttributes; safecall;\r\n function Get_CallingConvention: CallingConventions; safecall;\r\n function Invoke_2(obj: OleVariant; invokeAttr: BindingFlags; const Binder: _Binder; \r\n parameters: PSafeArray; const culture: _CultureInfo): OleVariant; safecall;\r\n function Get_IsPublic: WordBool; safecall;\r\n function Get_IsPrivate: WordBool; safecall;\r\n function Get_IsFamily: WordBool; safecall;\r\n function Get_IsAssembly: WordBool; safecall;\r\n function Get_IsFamilyAndAssembly: WordBool; safecall;\r\n function Get_IsFamilyOrAssembly: WordBool; safecall;\r\n function Get_IsStatic: WordBool; safecall;\r\n function Get_IsFinal: WordBool; safecall;\r\n function Get_IsVirtual: WordBool; safecall;\r\n function Get_IsHideBySig: WordBool; safecall;\r\n function Get_IsAbstract: WordBool; safecall;\r\n function Get_IsSpecialName: WordBool; safecall;\r\n function Get_IsConstructor: WordBool; safecall;\r\n function Invoke_3(obj: OleVariant; parameters: PSafeArray): OleVariant; safecall;\r\n function Invoke_4(invokeAttr: BindingFlags; const Binder: _Binder; parameters: PSafeArray; \r\n const culture: _CultureInfo): OleVariant; safecall;\r\n function Invoke_5(parameters: PSafeArray): OleVariant; safecall;\r\n property ToString: WideString read Get_ToString;\r\n property MemberType: MemberTypes read Get_MemberType;\r\n property name: WideString read Get_name;\r\n property DeclaringType: _Type read Get_DeclaringType;\r\n property ReflectedType: _Type read Get_ReflectedType;\r\n property MethodHandle: RuntimeMethodHandle read Get_MethodHandle;\r\n property Attributes: MethodAttributes read Get_Attributes;\r\n property CallingConvention: CallingConventions read Get_CallingConvention;\r\n property IsPublic: WordBool read Get_IsPublic;\r\n property IsPrivate: WordBool read Get_IsPrivate;\r\n property IsFamily: WordBool read Get_IsFamily;\r\n property IsAssembly: WordBool read Get_IsAssembly;\r\n property IsFamilyAndAssembly: WordBool read Get_IsFamilyAndAssembly;\r\n property IsFamilyOrAssembly: WordBool read Get_IsFamilyOrAssembly;\r\n property IsStatic: WordBool read Get_IsStatic;\r\n property IsFinal: WordBool read Get_IsFinal;\r\n property IsVirtual: WordBool read Get_IsVirtual;\r\n property IsHideBySig: WordBool read Get_IsHideBySig;\r\n property IsAbstract: WordBool read Get_IsAbstract;\r\n property IsSpecialName: WordBool read Get_IsSpecialName;\r\n property IsConstructor: WordBool read Get_IsConstructor;\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _ConstructorInfoDisp\r\n// Flags: (4560) Hidden Dual NonExtensible OleAutomation Dispatchable\r\n// GUID: {E9A19478-9646-3679-9B10-8411AE1FD57D}\r\n// *********************************************************************//\r\n _ConstructorInfoDisp = dispinterface\r\n ['{E9A19478-9646-3679-9B10-8411AE1FD57D}']\r\n property ToString: WideString readonly dispid 0;\r\n function Equals(obj: OleVariant): WordBool; dispid 1610743809;\r\n function GetHashCode: Integer; dispid 1610743810;\r\n function GetType: _Type; dispid 1610743811;\r\n property MemberType: MemberTypes readonly dispid 1610743812;\r\n property name: WideString readonly dispid 1610743813;\r\n property DeclaringType: _Type readonly dispid 1610743814;\r\n property ReflectedType: _Type readonly dispid 1610743815;\r\n function GetCustomAttributes(const attributeType: _Type; inherit: WordBool): {??PSafeArray}OleVariant; dispid 1610743816;\r\n function GetCustomAttributes_2(inherit: WordBool): {??PSafeArray}OleVariant; dispid 1610743817;\r\n function IsDefined(const attributeType: _Type; inherit: WordBool): WordBool; dispid 1610743818;\r\n function GetParameters: {??PSafeArray}OleVariant; dispid 1610743819;\r\n function GetMethodImplementationFlags: MethodImplAttributes; dispid 1610743820;\r\n property MethodHandle: {??RuntimeMethodHandle}OleVariant readonly dispid 1610743821;\r\n property Attributes: MethodAttributes readonly dispid 1610743822;\r\n property CallingConvention: CallingConventions readonly dispid 1610743823;\r\n function Invoke_2(obj: OleVariant; invokeAttr: BindingFlags; const Binder: _Binder; \r\n parameters: {??PSafeArray}OleVariant; const culture: _CultureInfo): OleVariant; dispid 1610743824;\r\n property IsPublic: WordBool readonly dispid 1610743825;\r\n property IsPrivate: WordBool readonly dispid 1610743826;\r\n property IsFamily: WordBool readonly dispid 1610743827;\r\n property IsAssembly: WordBool readonly dispid 1610743828;\r\n property IsFamilyAndAssembly: WordBool readonly dispid 1610743829;\r\n property IsFamilyOrAssembly: WordBool readonly dispid 1610743830;\r\n property IsStatic: WordBool readonly dispid 1610743831;\r\n property IsFinal: WordBool readonly dispid 1610743832;\r\n property IsVirtual: WordBool readonly dispid 1610743833;\r\n property IsHideBySig: WordBool readonly dispid 1610743834;\r\n property IsAbstract: WordBool readonly dispid 1610743835;\r\n property IsSpecialName: WordBool readonly dispid 1610743836;\r\n property IsConstructor: WordBool readonly dispid 1610743837;\r\n function Invoke_3(obj: OleVariant; parameters: {??PSafeArray}OleVariant): OleVariant; dispid 1610743838;\r\n function Invoke_4(invokeAttr: BindingFlags; const Binder: _Binder; \r\n parameters: {??PSafeArray}OleVariant; const culture: _CultureInfo): OleVariant; dispid 1610743839;\r\n function Invoke_5(parameters: {??PSafeArray}OleVariant): OleVariant; dispid 1610743840;\r\n end;\r\n {$EXTERNALSYM _ConstructorInfoDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _DefaultMemberAttribute\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {C462B072-FE6E-3BDC-9FAB-4CDBFCBCD124}\r\n// *********************************************************************//\r\n _DefaultMemberAttribute = interface(IDispatch)\r\n ['{C462B072-FE6E-3BDC-9FAB-4CDBFCBCD124}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _DefaultMemberAttributeDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {C462B072-FE6E-3BDC-9FAB-4CDBFCBCD124}\r\n// *********************************************************************//\r\n _DefaultMemberAttributeDisp = dispinterface\r\n ['{C462B072-FE6E-3BDC-9FAB-4CDBFCBCD124}']\r\n end;\r\n {$EXTERNALSYM _DefaultMemberAttributeDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _EventInfo\r\n// Flags: (4560) Hidden Dual NonExtensible OleAutomation Dispatchable\r\n// GUID: {9DE59C64-D889-35A1-B897-587D74469E5B}\r\n// *********************************************************************//\r\n _EventInfo = interface(IDispatch)\r\n ['{9DE59C64-D889-35A1-B897-587D74469E5B}']\r\n function Get_ToString: WideString; safecall;\r\n function Equals(obj: OleVariant): WordBool; safecall;\r\n function GetHashCode: Integer; safecall;\r\n function GetType: _Type; safecall;\r\n function Get_MemberType: MemberTypes; safecall;\r\n function Get_name: WideString; safecall;\r\n function Get_DeclaringType: _Type; safecall;\r\n function Get_ReflectedType: _Type; safecall;\r\n function GetCustomAttributes(const attributeType: _Type; inherit: WordBool): PSafeArray; safecall;\r\n function GetCustomAttributes_2(inherit: WordBool): PSafeArray; safecall;\r\n function IsDefined(const attributeType: _Type; inherit: WordBool): WordBool; safecall;\r\n function GetAddMethod(nonPublic: WordBool): _MethodInfo; safecall;\r\n function GetRemoveMethod(nonPublic: WordBool): _MethodInfo; safecall;\r\n function GetRaiseMethod(nonPublic: WordBool): _MethodInfo; safecall;\r\n function Get_Attributes: EventAttributes; safecall;\r\n function GetAddMethod_2: _MethodInfo; safecall;\r\n function GetRemoveMethod_2: _MethodInfo; safecall;\r\n function GetRaiseMethod_2: _MethodInfo; safecall;\r\n procedure AddEventHandler(Target: OleVariant; const handler: _Delegate); safecall;\r\n procedure RemoveEventHandler(Target: OleVariant; const handler: _Delegate); safecall;\r\n function Get_EventHandlerType: _Type; safecall;\r\n function Get_IsSpecialName: WordBool; safecall;\r\n function Get_IsMulticast: WordBool; safecall;\r\n property ToString: WideString read Get_ToString;\r\n property MemberType: MemberTypes read Get_MemberType;\r\n property name: WideString read Get_name;\r\n property DeclaringType: _Type read Get_DeclaringType;\r\n property ReflectedType: _Type read Get_ReflectedType;\r\n property Attributes: EventAttributes read Get_Attributes;\r\n property EventHandlerType: _Type read Get_EventHandlerType;\r\n property IsSpecialName: WordBool read Get_IsSpecialName;\r\n property IsMulticast: WordBool read Get_IsMulticast;\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _EventInfoDisp\r\n// Flags: (4560) Hidden Dual NonExtensible OleAutomation Dispatchable\r\n// GUID: {9DE59C64-D889-35A1-B897-587D74469E5B}\r\n// *********************************************************************//\r\n _EventInfoDisp = dispinterface\r\n ['{9DE59C64-D889-35A1-B897-587D74469E5B}']\r\n property ToString: WideString readonly dispid 0;\r\n function Equals(obj: OleVariant): WordBool; dispid 1610743809;\r\n function GetHashCode: Integer; dispid 1610743810;\r\n function GetType: _Type; dispid 1610743811;\r\n property MemberType: MemberTypes readonly dispid 1610743812;\r\n property name: WideString readonly dispid 1610743813;\r\n property DeclaringType: _Type readonly dispid 1610743814;\r\n property ReflectedType: _Type readonly dispid 1610743815;\r\n function GetCustomAttributes(const attributeType: _Type; inherit: WordBool): {??PSafeArray}OleVariant; dispid 1610743816;\r\n function GetCustomAttributes_2(inherit: WordBool): {??PSafeArray}OleVariant; dispid 1610743817;\r\n function IsDefined(const attributeType: _Type; inherit: WordBool): WordBool; dispid 1610743818;\r\n function GetAddMethod(nonPublic: WordBool): _MethodInfo; dispid 1610743819;\r\n function GetRemoveMethod(nonPublic: WordBool): _MethodInfo; dispid 1610743820;\r\n function GetRaiseMethod(nonPublic: WordBool): _MethodInfo; dispid 1610743821;\r\n property Attributes: EventAttributes readonly dispid 1610743822;\r\n function GetAddMethod_2: _MethodInfo; dispid 1610743823;\r\n function GetRemoveMethod_2: _MethodInfo; dispid 1610743824;\r\n function GetRaiseMethod_2: _MethodInfo; dispid 1610743825;\r\n procedure AddEventHandler(Target: OleVariant; const handler: _Delegate); dispid 1610743826;\r\n procedure RemoveEventHandler(Target: OleVariant; const handler: _Delegate); dispid 1610743827;\r\n property EventHandlerType: _Type readonly dispid 1610743828;\r\n property IsSpecialName: WordBool readonly dispid 1610743829;\r\n property IsMulticast: WordBool readonly dispid 1610743830;\r\n end;\r\n {$EXTERNALSYM _EventInfoDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _FieldInfo\r\n// Flags: (4560) Hidden Dual NonExtensible OleAutomation Dispatchable\r\n// GUID: {8A7C1442-A9FB-366B-80D8-4939FFA6DBE0}\r\n// *********************************************************************//\r\n _FieldInfo = interface(IDispatch)\r\n ['{8A7C1442-A9FB-366B-80D8-4939FFA6DBE0}']\r\n function Get_ToString: WideString; safecall;\r\n function Equals(obj: OleVariant): WordBool; safecall;\r\n function GetHashCode: Integer; safecall;\r\n function GetType: _Type; safecall;\r\n function Get_MemberType: MemberTypes; safecall;\r\n function Get_name: WideString; safecall;\r\n function Get_DeclaringType: _Type; safecall;\r\n function Get_ReflectedType: _Type; safecall;\r\n function GetCustomAttributes(const attributeType: _Type; inherit: WordBool): PSafeArray; safecall;\r\n function GetCustomAttributes_2(inherit: WordBool): PSafeArray; safecall;\r\n function IsDefined(const attributeType: _Type; inherit: WordBool): WordBool; safecall;\r\n function Get_FieldType: _Type; safecall;\r\n function GetValue(obj: OleVariant): OleVariant; safecall;\r\n function GetValueDirect(obj: OleVariant): OleVariant; safecall;\r\n procedure SetValue(obj: OleVariant; value: OleVariant; invokeAttr: BindingFlags; \r\n const Binder: _Binder; const culture: _CultureInfo); safecall;\r\n procedure SetValueDirect(obj: OleVariant; value: OleVariant); safecall;\r\n function Get_FieldHandle: RuntimeFieldHandle; safecall;\r\n function Get_Attributes: FieldAttributes; safecall;\r\n procedure SetValue_2(obj: OleVariant; value: OleVariant); safecall;\r\n function Get_IsPublic: WordBool; safecall;\r\n function Get_IsPrivate: WordBool; safecall;\r\n function Get_IsFamily: WordBool; safecall;\r\n function Get_IsAssembly: WordBool; safecall;\r\n function Get_IsFamilyAndAssembly: WordBool; safecall;\r\n function Get_IsFamilyOrAssembly: WordBool; safecall;\r\n function Get_IsStatic: WordBool; safecall;\r\n function Get_IsInitOnly: WordBool; safecall;\r\n function Get_IsLiteral: WordBool; safecall;\r\n function Get_IsNotSerialized: WordBool; safecall;\r\n function Get_IsSpecialName: WordBool; safecall;\r\n function Get_IsPinvokeImpl: WordBool; safecall;\r\n property ToString: WideString read Get_ToString;\r\n property MemberType: MemberTypes read Get_MemberType;\r\n property name: WideString read Get_name;\r\n property DeclaringType: _Type read Get_DeclaringType;\r\n property ReflectedType: _Type read Get_ReflectedType;\r\n property FieldType: _Type read Get_FieldType;\r\n property FieldHandle: RuntimeFieldHandle read Get_FieldHandle;\r\n property Attributes: FieldAttributes read Get_Attributes;\r\n property IsPublic: WordBool read Get_IsPublic;\r\n property IsPrivate: WordBool read Get_IsPrivate;\r\n property IsFamily: WordBool read Get_IsFamily;\r\n property IsAssembly: WordBool read Get_IsAssembly;\r\n property IsFamilyAndAssembly: WordBool read Get_IsFamilyAndAssembly;\r\n property IsFamilyOrAssembly: WordBool read Get_IsFamilyOrAssembly;\r\n property IsStatic: WordBool read Get_IsStatic;\r\n property IsInitOnly: WordBool read Get_IsInitOnly;\r\n property IsLiteral: WordBool read Get_IsLiteral;\r\n property IsNotSerialized: WordBool read Get_IsNotSerialized;\r\n property IsSpecialName: WordBool read Get_IsSpecialName;\r\n property IsPinvokeImpl: WordBool read Get_IsPinvokeImpl;\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _FieldInfoDisp\r\n// Flags: (4560) Hidden Dual NonExtensible OleAutomation Dispatchable\r\n// GUID: {8A7C1442-A9FB-366B-80D8-4939FFA6DBE0}\r\n// *********************************************************************//\r\n _FieldInfoDisp = dispinterface\r\n ['{8A7C1442-A9FB-366B-80D8-4939FFA6DBE0}']\r\n property ToString: WideString readonly dispid 0;\r\n function Equals(obj: OleVariant): WordBool; dispid 1610743809;\r\n function GetHashCode: Integer; dispid 1610743810;\r\n function GetType: _Type; dispid 1610743811;\r\n property MemberType: MemberTypes readonly dispid 1610743812;\r\n property name: WideString readonly dispid 1610743813;\r\n property DeclaringType: _Type readonly dispid 1610743814;\r\n property ReflectedType: _Type readonly dispid 1610743815;\r\n function GetCustomAttributes(const attributeType: _Type; inherit: WordBool): {??PSafeArray}OleVariant; dispid 1610743816;\r\n function GetCustomAttributes_2(inherit: WordBool): {??PSafeArray}OleVariant; dispid 1610743817;\r\n function IsDefined(const attributeType: _Type; inherit: WordBool): WordBool; dispid 1610743818;\r\n property FieldType: _Type readonly dispid 1610743819;\r\n function GetValue(obj: OleVariant): OleVariant; dispid 1610743820;\r\n function GetValueDirect(obj: OleVariant): OleVariant; dispid 1610743821;\r\n procedure SetValue(obj: OleVariant; value: OleVariant; invokeAttr: BindingFlags; \r\n const Binder: _Binder; const culture: _CultureInfo); dispid 1610743822;\r\n procedure SetValueDirect(obj: OleVariant; value: OleVariant); dispid 1610743823;\r\n property FieldHandle: {??RuntimeFieldHandle}OleVariant readonly dispid 1610743824;\r\n property Attributes: FieldAttributes readonly dispid 1610743825;\r\n procedure SetValue_2(obj: OleVariant; value: OleVariant); dispid 1610743826;\r\n property IsPublic: WordBool readonly dispid 1610743827;\r\n property IsPrivate: WordBool readonly dispid 1610743828;\r\n property IsFamily: WordBool readonly dispid 1610743829;\r\n property IsAssembly: WordBool readonly dispid 1610743830;\r\n property IsFamilyAndAssembly: WordBool readonly dispid 1610743831;\r\n property IsFamilyOrAssembly: WordBool readonly dispid 1610743832;\r\n property IsStatic: WordBool readonly dispid 1610743833;\r\n property IsInitOnly: WordBool readonly dispid 1610743834;\r\n property IsLiteral: WordBool readonly dispid 1610743835;\r\n property IsNotSerialized: WordBool readonly dispid 1610743836;\r\n property IsSpecialName: WordBool readonly dispid 1610743837;\r\n property IsPinvokeImpl: WordBool readonly dispid 1610743838;\r\n end;\r\n {$EXTERNALSYM _FieldInfoDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _InvalidFilterCriteriaException\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {E6DF0AE7-BA15-3F80-8AFA-27773AE414FC}\r\n// *********************************************************************//\r\n _InvalidFilterCriteriaException = interface(IDispatch)\r\n ['{E6DF0AE7-BA15-3F80-8AFA-27773AE414FC}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _InvalidFilterCriteriaExceptionDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {E6DF0AE7-BA15-3F80-8AFA-27773AE414FC}\r\n// *********************************************************************//\r\n _InvalidFilterCriteriaExceptionDisp = dispinterface\r\n ['{E6DF0AE7-BA15-3F80-8AFA-27773AE414FC}']\r\n end;\r\n {$EXTERNALSYM _InvalidFilterCriteriaExceptionDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _ManifestResourceInfo\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {3188878C-DEB3-3558-80E8-84E9ED95F92C}\r\n// *********************************************************************//\r\n _ManifestResourceInfo = interface(IDispatch)\r\n ['{3188878C-DEB3-3558-80E8-84E9ED95F92C}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _ManifestResourceInfoDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {3188878C-DEB3-3558-80E8-84E9ED95F92C}\r\n// *********************************************************************//\r\n _ManifestResourceInfoDisp = dispinterface\r\n ['{3188878C-DEB3-3558-80E8-84E9ED95F92C}']\r\n end;\r\n {$EXTERNALSYM _ManifestResourceInfoDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _MemberFilter\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {FAE5D9B7-40C1-3DE1-BE06-A91C9DA1BA9F}\r\n// *********************************************************************//\r\n _MemberFilter = interface(IDispatch)\r\n ['{FAE5D9B7-40C1-3DE1-BE06-A91C9DA1BA9F}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _MemberFilterDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {FAE5D9B7-40C1-3DE1-BE06-A91C9DA1BA9F}\r\n// *********************************************************************//\r\n _MemberFilterDisp = dispinterface\r\n ['{FAE5D9B7-40C1-3DE1-BE06-A91C9DA1BA9F}']\r\n end;\r\n {$EXTERNALSYM _MemberFilterDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _MethodInfo\r\n// Flags: (4560) Hidden Dual NonExtensible OleAutomation Dispatchable\r\n// GUID: {FFCC1B5D-ECB8-38DD-9B01-3DC8ABC2AA5F}\r\n// *********************************************************************//\r\n _MethodInfo = interface(IDispatch)\r\n ['{FFCC1B5D-ECB8-38DD-9B01-3DC8ABC2AA5F}']\r\n function Get_ToString: WideString; safecall;\r\n function Equals(obj: OleVariant): WordBool; safecall;\r\n function GetHashCode: Integer; safecall;\r\n function GetType: _Type; safecall;\r\n function Get_MemberType: MemberTypes; safecall;\r\n function Get_name: WideString; safecall;\r\n function Get_DeclaringType: _Type; safecall;\r\n function Get_ReflectedType: _Type; safecall;\r\n function GetCustomAttributes(const attributeType: _Type; inherit: WordBool): PSafeArray; safecall;\r\n function GetCustomAttributes_2(inherit: WordBool): PSafeArray; safecall;\r\n function IsDefined(const attributeType: _Type; inherit: WordBool): WordBool; safecall;\r\n function GetParameters: PSafeArray; safecall;\r\n function GetMethodImplementationFlags: MethodImplAttributes; safecall;\r\n function Get_MethodHandle: RuntimeMethodHandle; safecall;\r\n function Get_Attributes: MethodAttributes; safecall;\r\n function Get_CallingConvention: CallingConventions; safecall;\r\n function Invoke_2(obj: OleVariant; invokeAttr: BindingFlags; const Binder: _Binder; \r\n parameters: PSafeArray; const culture: _CultureInfo): OleVariant; safecall;\r\n function Get_IsPublic: WordBool; safecall;\r\n function Get_IsPrivate: WordBool; safecall;\r\n function Get_IsFamily: WordBool; safecall;\r\n function Get_IsAssembly: WordBool; safecall;\r\n function Get_IsFamilyAndAssembly: WordBool; safecall;\r\n function Get_IsFamilyOrAssembly: WordBool; safecall;\r\n function Get_IsStatic: WordBool; safecall;\r\n function Get_IsFinal: WordBool; safecall;\r\n function Get_IsVirtual: WordBool; safecall;\r\n function Get_IsHideBySig: WordBool; safecall;\r\n function Get_IsAbstract: WordBool; safecall;\r\n function Get_IsSpecialName: WordBool; safecall;\r\n function Get_IsConstructor: WordBool; safecall;\r\n function Invoke_3(obj: OleVariant; parameters: PSafeArray): OleVariant; safecall;\r\n function Get_returnType: _Type; safecall;\r\n function Get_ReturnTypeCustomAttributes: ICustomAttributeProvider; safecall;\r\n function GetBaseDefinition: _MethodInfo; safecall;\r\n property ToString: WideString read Get_ToString;\r\n property MemberType: MemberTypes read Get_MemberType;\r\n property name: WideString read Get_name;\r\n property DeclaringType: _Type read Get_DeclaringType;\r\n property ReflectedType: _Type read Get_ReflectedType;\r\n property MethodHandle: RuntimeMethodHandle read Get_MethodHandle;\r\n property Attributes: MethodAttributes read Get_Attributes;\r\n property CallingConvention: CallingConventions read Get_CallingConvention;\r\n property IsPublic: WordBool read Get_IsPublic;\r\n property IsPrivate: WordBool read Get_IsPrivate;\r\n property IsFamily: WordBool read Get_IsFamily;\r\n property IsAssembly: WordBool read Get_IsAssembly;\r\n property IsFamilyAndAssembly: WordBool read Get_IsFamilyAndAssembly;\r\n property IsFamilyOrAssembly: WordBool read Get_IsFamilyOrAssembly;\r\n property IsStatic: WordBool read Get_IsStatic;\r\n property IsFinal: WordBool read Get_IsFinal;\r\n property IsVirtual: WordBool read Get_IsVirtual;\r\n property IsHideBySig: WordBool read Get_IsHideBySig;\r\n property IsAbstract: WordBool read Get_IsAbstract;\r\n property IsSpecialName: WordBool read Get_IsSpecialName;\r\n property IsConstructor: WordBool read Get_IsConstructor;\r\n property returnType: _Type read Get_returnType;\r\n property ReturnTypeCustomAttributes: ICustomAttributeProvider read Get_ReturnTypeCustomAttributes;\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _MethodInfoDisp\r\n// Flags: (4560) Hidden Dual NonExtensible OleAutomation Dispatchable\r\n// GUID: {FFCC1B5D-ECB8-38DD-9B01-3DC8ABC2AA5F}\r\n// *********************************************************************//\r\n _MethodInfoDisp = dispinterface\r\n ['{FFCC1B5D-ECB8-38DD-9B01-3DC8ABC2AA5F}']\r\n property ToString: WideString readonly dispid 0;\r\n function Equals(obj: OleVariant): WordBool; dispid 1610743809;\r\n function GetHashCode: Integer; dispid 1610743810;\r\n function GetType: _Type; dispid 1610743811;\r\n property MemberType: MemberTypes readonly dispid 1610743812;\r\n property name: WideString readonly dispid 1610743813;\r\n property DeclaringType: _Type readonly dispid 1610743814;\r\n property ReflectedType: _Type readonly dispid 1610743815;\r\n function GetCustomAttributes(const attributeType: _Type; inherit: WordBool): {??PSafeArray}OleVariant; dispid 1610743816;\r\n function GetCustomAttributes_2(inherit: WordBool): {??PSafeArray}OleVariant; dispid 1610743817;\r\n function IsDefined(const attributeType: _Type; inherit: WordBool): WordBool; dispid 1610743818;\r\n function GetParameters: {??PSafeArray}OleVariant; dispid 1610743819;\r\n function GetMethodImplementationFlags: MethodImplAttributes; dispid 1610743820;\r\n property MethodHandle: {??RuntimeMethodHandle}OleVariant readonly dispid 1610743821;\r\n property Attributes: MethodAttributes readonly dispid 1610743822;\r\n property CallingConvention: CallingConventions readonly dispid 1610743823;\r\n function Invoke_2(obj: OleVariant; invokeAttr: BindingFlags; const Binder: _Binder; \r\n parameters: {??PSafeArray}OleVariant; const culture: _CultureInfo): OleVariant; dispid 1610743824;\r\n property IsPublic: WordBool readonly dispid 1610743825;\r\n property IsPrivate: WordBool readonly dispid 1610743826;\r\n property IsFamily: WordBool readonly dispid 1610743827;\r\n property IsAssembly: WordBool readonly dispid 1610743828;\r\n property IsFamilyAndAssembly: WordBool readonly dispid 1610743829;\r\n property IsFamilyOrAssembly: WordBool readonly dispid 1610743830;\r\n property IsStatic: WordBool readonly dispid 1610743831;\r\n property IsFinal: WordBool readonly dispid 1610743832;\r\n property IsVirtual: WordBool readonly dispid 1610743833;\r\n property IsHideBySig: WordBool readonly dispid 1610743834;\r\n property IsAbstract: WordBool readonly dispid 1610743835;\r\n property IsSpecialName: WordBool readonly dispid 1610743836;\r\n property IsConstructor: WordBool readonly dispid 1610743837;\r\n function Invoke_3(obj: OleVariant; parameters: {??PSafeArray}OleVariant): OleVariant; dispid 1610743838;\r\n property returnType: _Type readonly dispid 1610743839;\r\n property ReturnTypeCustomAttributes: ICustomAttributeProvider readonly dispid 1610743840;\r\n function GetBaseDefinition: _MethodInfo; dispid 1610743841;\r\n end;\r\n {$EXTERNALSYM _MethodInfoDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _Missing\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {0C48F55D-5240-30C7-A8F1-AF87A640CEFE}\r\n// *********************************************************************//\r\n _Missing = interface(IDispatch)\r\n ['{0C48F55D-5240-30C7-A8F1-AF87A640CEFE}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _MissingDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {0C48F55D-5240-30C7-A8F1-AF87A640CEFE}\r\n// *********************************************************************//\r\n _MissingDisp = dispinterface\r\n ['{0C48F55D-5240-30C7-A8F1-AF87A640CEFE}']\r\n end;\r\n {$EXTERNALSYM _MissingDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _Module\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {D002E9BA-D9E3-3749-B1D3-D565A08B13E7}\r\n// *********************************************************************//\r\n _Module = interface(IDispatch)\r\n ['{D002E9BA-D9E3-3749-B1D3-D565A08B13E7}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _ModuleDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {D002E9BA-D9E3-3749-B1D3-D565A08B13E7}\r\n// *********************************************************************//\r\n _ModuleDisp = dispinterface\r\n ['{D002E9BA-D9E3-3749-B1D3-D565A08B13E7}']\r\n end;\r\n {$EXTERNALSYM _ModuleDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _ParameterInfo\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {993634C4-E47A-32CC-BE08-85F567DC27D6}\r\n// *********************************************************************//\r\n _ParameterInfo = interface(IDispatch)\r\n ['{993634C4-E47A-32CC-BE08-85F567DC27D6}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _ParameterInfoDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {993634C4-E47A-32CC-BE08-85F567DC27D6}\r\n// *********************************************************************//\r\n _ParameterInfoDisp = dispinterface\r\n ['{993634C4-E47A-32CC-BE08-85F567DC27D6}']\r\n end;\r\n {$EXTERNALSYM _ParameterInfoDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _Pointer\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {F0DEAFE9-5EBA-3737-9950-C1795739CDCD}\r\n// *********************************************************************//\r\n _Pointer = interface(IDispatch)\r\n ['{F0DEAFE9-5EBA-3737-9950-C1795739CDCD}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _PointerDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {F0DEAFE9-5EBA-3737-9950-C1795739CDCD}\r\n// *********************************************************************//\r\n _PointerDisp = dispinterface\r\n ['{F0DEAFE9-5EBA-3737-9950-C1795739CDCD}']\r\n end;\r\n {$EXTERNALSYM _PointerDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _PropertyInfo\r\n// Flags: (4560) Hidden Dual NonExtensible OleAutomation Dispatchable\r\n// GUID: {F59ED4E4-E68F-3218-BD77-061AA82824BF}\r\n// *********************************************************************//\r\n _PropertyInfo = interface(IDispatch)\r\n ['{F59ED4E4-E68F-3218-BD77-061AA82824BF}']\r\n function Get_ToString: WideString; safecall;\r\n function Equals(obj: OleVariant): WordBool; safecall;\r\n function GetHashCode: Integer; safecall;\r\n function GetType: _Type; safecall;\r\n function Get_MemberType: MemberTypes; safecall;\r\n function Get_name: WideString; safecall;\r\n function Get_DeclaringType: _Type; safecall;\r\n function Get_ReflectedType: _Type; safecall;\r\n function GetCustomAttributes(const attributeType: _Type; inherit: WordBool): PSafeArray; safecall;\r\n function GetCustomAttributes_2(inherit: WordBool): PSafeArray; safecall;\r\n function IsDefined(const attributeType: _Type; inherit: WordBool): WordBool; safecall;\r\n function Get_PropertyType: _Type; safecall;\r\n function GetValue(obj: OleVariant; index: PSafeArray): OleVariant; safecall;\r\n function GetValue_2(obj: OleVariant; invokeAttr: BindingFlags; const Binder: _Binder; \r\n index: PSafeArray; const culture: _CultureInfo): OleVariant; safecall;\r\n procedure SetValue(obj: OleVariant; value: OleVariant; index: PSafeArray); safecall;\r\n procedure SetValue_2(obj: OleVariant; value: OleVariant; invokeAttr: BindingFlags; \r\n const Binder: _Binder; index: PSafeArray; const culture: _CultureInfo); safecall;\r\n function GetAccessors(nonPublic: WordBool): PSafeArray; safecall;\r\n function GetGetMethod(nonPublic: WordBool): _MethodInfo; safecall;\r\n function GetSetMethod(nonPublic: WordBool): _MethodInfo; safecall;\r\n function GetIndexParameters: PSafeArray; safecall;\r\n function Get_Attributes: PropertyAttributes; safecall;\r\n function Get_CanRead: WordBool; safecall;\r\n function Get_CanWrite: WordBool; safecall;\r\n function GetAccessors_2: PSafeArray; safecall;\r\n function GetGetMethod_2: _MethodInfo; safecall;\r\n function GetSetMethod_2: _MethodInfo; safecall;\r\n function Get_IsSpecialName: WordBool; safecall;\r\n property ToString: WideString read Get_ToString;\r\n property MemberType: MemberTypes read Get_MemberType;\r\n property name: WideString read Get_name;\r\n property DeclaringType: _Type read Get_DeclaringType;\r\n property ReflectedType: _Type read Get_ReflectedType;\r\n property PropertyType: _Type read Get_PropertyType;\r\n property Attributes: PropertyAttributes read Get_Attributes;\r\n property CanRead: WordBool read Get_CanRead;\r\n property CanWrite: WordBool read Get_CanWrite;\r\n property IsSpecialName: WordBool read Get_IsSpecialName;\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _PropertyInfoDisp\r\n// Flags: (4560) Hidden Dual NonExtensible OleAutomation Dispatchable\r\n// GUID: {F59ED4E4-E68F-3218-BD77-061AA82824BF}\r\n// *********************************************************************//\r\n _PropertyInfoDisp = dispinterface\r\n ['{F59ED4E4-E68F-3218-BD77-061AA82824BF}']\r\n property ToString: WideString readonly dispid 0;\r\n function Equals(obj: OleVariant): WordBool; dispid 1610743809;\r\n function GetHashCode: Integer; dispid 1610743810;\r\n function GetType: _Type; dispid 1610743811;\r\n property MemberType: MemberTypes readonly dispid 1610743812;\r\n property name: WideString readonly dispid 1610743813;\r\n property DeclaringType: _Type readonly dispid 1610743814;\r\n property ReflectedType: _Type readonly dispid 1610743815;\r\n function GetCustomAttributes(const attributeType: _Type; inherit: WordBool): {??PSafeArray}OleVariant; dispid 1610743816;\r\n function GetCustomAttributes_2(inherit: WordBool): {??PSafeArray}OleVariant; dispid 1610743817;\r\n function IsDefined(const attributeType: _Type; inherit: WordBool): WordBool; dispid 1610743818;\r\n property PropertyType: _Type readonly dispid 1610743819;\r\n function GetValue(obj: OleVariant; index: {??PSafeArray}OleVariant): OleVariant; dispid 1610743820;\r\n function GetValue_2(obj: OleVariant; invokeAttr: BindingFlags; const Binder: _Binder; \r\n index: {??PSafeArray}OleVariant; const culture: _CultureInfo): OleVariant; dispid 1610743821;\r\n procedure SetValue(obj: OleVariant; value: OleVariant; index: {??PSafeArray}OleVariant); dispid 1610743822;\r\n procedure SetValue_2(obj: OleVariant; value: OleVariant; invokeAttr: BindingFlags; \r\n const Binder: _Binder; index: {??PSafeArray}OleVariant; \r\n const culture: _CultureInfo); dispid 1610743823;\r\n function GetAccessors(nonPublic: WordBool): {??PSafeArray}OleVariant; dispid 1610743824;\r\n function GetGetMethod(nonPublic: WordBool): _MethodInfo; dispid 1610743825;\r\n function GetSetMethod(nonPublic: WordBool): _MethodInfo; dispid 1610743826;\r\n function GetIndexParameters: {??PSafeArray}OleVariant; dispid 1610743827;\r\n property Attributes: PropertyAttributes readonly dispid 1610743828;\r\n property CanRead: WordBool readonly dispid 1610743829;\r\n property CanWrite: WordBool readonly dispid 1610743830;\r\n function GetAccessors_2: {??PSafeArray}OleVariant; dispid 1610743831;\r\n function GetGetMethod_2: _MethodInfo; dispid 1610743832;\r\n function GetSetMethod_2: _MethodInfo; dispid 1610743833;\r\n property IsSpecialName: WordBool readonly dispid 1610743834;\r\n end;\r\n {$EXTERNALSYM _PropertyInfoDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _ReflectionTypeLoadException\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {22C26A41-5FA3-34E3-A76F-BA480252D8EC}\r\n// *********************************************************************//\r\n _ReflectionTypeLoadException = interface(IDispatch)\r\n ['{22C26A41-5FA3-34E3-A76F-BA480252D8EC}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _ReflectionTypeLoadExceptionDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {22C26A41-5FA3-34E3-A76F-BA480252D8EC}\r\n// *********************************************************************//\r\n _ReflectionTypeLoadExceptionDisp = dispinterface\r\n ['{22C26A41-5FA3-34E3-A76F-BA480252D8EC}']\r\n end;\r\n {$EXTERNALSYM _ReflectionTypeLoadExceptionDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _StrongNameKeyPair\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {FC4963CB-E52B-32D8-A418-D058FA51A1FA}\r\n// *********************************************************************//\r\n _StrongNameKeyPair = interface(IDispatch)\r\n ['{FC4963CB-E52B-32D8-A418-D058FA51A1FA}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _StrongNameKeyPairDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {FC4963CB-E52B-32D8-A418-D058FA51A1FA}\r\n// *********************************************************************//\r\n _StrongNameKeyPairDisp = dispinterface\r\n ['{FC4963CB-E52B-32D8-A418-D058FA51A1FA}']\r\n end;\r\n {$EXTERNALSYM _StrongNameKeyPairDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _TargetException\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {98B1524D-DA12-3C4B-8A69-7539A6DEC4FA}\r\n// *********************************************************************//\r\n _TargetException = interface(IDispatch)\r\n ['{98B1524D-DA12-3C4B-8A69-7539A6DEC4FA}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _TargetExceptionDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {98B1524D-DA12-3C4B-8A69-7539A6DEC4FA}\r\n// *********************************************************************//\r\n _TargetExceptionDisp = dispinterface\r\n ['{98B1524D-DA12-3C4B-8A69-7539A6DEC4FA}']\r\n end;\r\n {$EXTERNALSYM _TargetExceptionDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _TargetInvocationException\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {A90106ED-9099-3329-8A5A-2044B3D8552B}\r\n// *********************************************************************//\r\n _TargetInvocationException = interface(IDispatch)\r\n ['{A90106ED-9099-3329-8A5A-2044B3D8552B}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _TargetInvocationExceptionDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {A90106ED-9099-3329-8A5A-2044B3D8552B}\r\n// *********************************************************************//\r\n _TargetInvocationExceptionDisp = dispinterface\r\n ['{A90106ED-9099-3329-8A5A-2044B3D8552B}']\r\n end;\r\n {$EXTERNALSYM _TargetInvocationExceptionDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _TargetParameterCountException\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {6032B3CD-9BED-351C-A145-9D500B0F636F}\r\n// *********************************************************************//\r\n _TargetParameterCountException = interface(IDispatch)\r\n ['{6032B3CD-9BED-351C-A145-9D500B0F636F}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _TargetParameterCountExceptionDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {6032B3CD-9BED-351C-A145-9D500B0F636F}\r\n// *********************************************************************//\r\n _TargetParameterCountExceptionDisp = dispinterface\r\n ['{6032B3CD-9BED-351C-A145-9D500B0F636F}']\r\n end;\r\n {$EXTERNALSYM _TargetParameterCountExceptionDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _TypeDelegator\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {34E00EF9-83E2-3BBC-B6AF-4CAE703838BD}\r\n// *********************************************************************//\r\n _TypeDelegator = interface(IDispatch)\r\n ['{34E00EF9-83E2-3BBC-B6AF-4CAE703838BD}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _TypeDelegatorDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {34E00EF9-83E2-3BBC-B6AF-4CAE703838BD}\r\n// *********************************************************************//\r\n _TypeDelegatorDisp = dispinterface\r\n ['{34E00EF9-83E2-3BBC-B6AF-4CAE703838BD}']\r\n end;\r\n {$EXTERNALSYM _TypeDelegatorDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _TypeFilter\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {E1817846-3745-3C97-B4A6-EE20A1641B29}\r\n// *********************************************************************//\r\n _TypeFilter = interface(IDispatch)\r\n ['{E1817846-3745-3C97-B4A6-EE20A1641B29}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _TypeFilterDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {E1817846-3745-3C97-B4A6-EE20A1641B29}\r\n// *********************************************************************//\r\n _TypeFilterDisp = dispinterface\r\n ['{E1817846-3745-3C97-B4A6-EE20A1641B29}']\r\n end;\r\n {$EXTERNALSYM _TypeFilterDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _UnmanagedMarshal\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {FD302D86-240A-3694-A31F-9EF59E6E41BC}\r\n// *********************************************************************//\r\n _UnmanagedMarshal = interface(IDispatch)\r\n ['{FD302D86-240A-3694-A31F-9EF59E6E41BC}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _UnmanagedMarshalDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {FD302D86-240A-3694-A31F-9EF59E6E41BC}\r\n// *********************************************************************//\r\n _UnmanagedMarshalDisp = dispinterface\r\n ['{FD302D86-240A-3694-A31F-9EF59E6E41BC}']\r\n end;\r\n {$EXTERNALSYM _UnmanagedMarshalDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: IFormatter\r\n// Flags: (4416) Dual OleAutomation Dispatchable\r\n// GUID: {93D7A8C5-D2EB-319B-A374-A65D321F2AA9}\r\n// *********************************************************************//\r\n IFormatter = interface(IDispatch)\r\n ['{93D7A8C5-D2EB-319B-A374-A65D321F2AA9}']\r\n function Deserialize(const serializationStream: _Stream): OleVariant; safecall;\r\n procedure Serialize(const serializationStream: _Stream; graph: OleVariant); safecall;\r\n function Get_SurrogateSelector: ISurrogateSelector; safecall;\r\n procedure _Set_SurrogateSelector(const pRetVal: ISurrogateSelector); safecall;\r\n function Get_Binder: _SerializationBinder; safecall;\r\n procedure _Set_Binder(const pRetVal: _SerializationBinder); safecall;\r\n function Get_Context: StreamingContext; safecall;\r\n procedure Set_Context(pRetVal: StreamingContext); safecall;\r\n property SurrogateSelector: ISurrogateSelector read Get_SurrogateSelector;\r\n property Binder: _SerializationBinder read Get_Binder;\r\n property Context: StreamingContext read Get_Context;\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: IFormatterDisp\r\n// Flags: (4416) Dual OleAutomation Dispatchable\r\n// GUID: {93D7A8C5-D2EB-319B-A374-A65D321F2AA9}\r\n// *********************************************************************//\r\n IFormatterDisp = dispinterface\r\n ['{93D7A8C5-D2EB-319B-A374-A65D321F2AA9}']\r\n function Deserialize(const serializationStream: _Stream): OleVariant; dispid 1610743808;\r\n procedure Serialize(const serializationStream: _Stream; graph: OleVariant); dispid 1610743809;\r\n property SurrogateSelector: ISurrogateSelector readonly dispid 1610743810;\r\n property Binder: _SerializationBinder readonly dispid 1610743812;\r\n property Context: {??StreamingContext}OleVariant readonly dispid 1610743814;\r\n end;\r\n {$EXTERNALSYM IFormatterDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _Formatter\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {D9BD3C8D-9395-3657-B6EE-D1B509C38B70}\r\n// *********************************************************************//\r\n _Formatter = interface(IDispatch)\r\n ['{D9BD3C8D-9395-3657-B6EE-D1B509C38B70}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _FormatterDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {D9BD3C8D-9395-3657-B6EE-D1B509C38B70}\r\n// *********************************************************************//\r\n _FormatterDisp = dispinterface\r\n ['{D9BD3C8D-9395-3657-B6EE-D1B509C38B70}']\r\n end;\r\n {$EXTERNALSYM _FormatterDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: IFormatterConverter\r\n// Flags: (4416) Dual OleAutomation Dispatchable\r\n// GUID: {F4F5C303-FAD3-3D0C-A4DF-BB82B5EE308F}\r\n// *********************************************************************//\r\n IFormatterConverter = interface(IDispatch)\r\n ['{F4F5C303-FAD3-3D0C-A4DF-BB82B5EE308F}']\r\n function Convert(value: OleVariant; const Type_: _Type): OleVariant; safecall;\r\n function Convert_2(value: OleVariant; TypeCode: TypeCode): OleVariant; safecall;\r\n function ToBoolean(value: OleVariant): WordBool; safecall;\r\n function ToChar(value: OleVariant): Word; safecall;\r\n function ToSByte(value: OleVariant): Shortint; safecall;\r\n function ToByte(value: OleVariant): Byte; safecall;\r\n function ToInt16(value: OleVariant): Smallint; safecall;\r\n function ToUInt16(value: OleVariant): Word; safecall;\r\n function ToInt32(value: OleVariant): Integer; safecall;\r\n function ToUInt32(value: OleVariant): LongWord; safecall;\r\n function ToInt64(value: OleVariant): Int64; safecall;\r\n function ToUInt64(value: OleVariant): Largeuint; safecall;\r\n function ToSingle(value: OleVariant): Single; safecall;\r\n function ToDouble(value: OleVariant): Double; safecall;\r\n function ToDecimal(value: OleVariant): TDecimal; safecall;\r\n function ToDateTime(value: OleVariant): TDateTime; safecall;\r\n function Get_ToString(value: OleVariant): WideString; safecall;\r\n property ToString[value: OleVariant]: WideString read Get_ToString;\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: IFormatterConverterDisp\r\n// Flags: (4416) Dual OleAutomation Dispatchable\r\n// GUID: {F4F5C303-FAD3-3D0C-A4DF-BB82B5EE308F}\r\n// *********************************************************************//\r\n IFormatterConverterDisp = dispinterface\r\n ['{F4F5C303-FAD3-3D0C-A4DF-BB82B5EE308F}']\r\n function Convert(value: OleVariant; const Type_: _Type): OleVariant; dispid 1610743808;\r\n function Convert_2(value: OleVariant; TypeCode: TypeCode): OleVariant; dispid 1610743809;\r\n function ToBoolean(value: OleVariant): WordBool; dispid 1610743810;\r\n function ToChar(value: OleVariant): {??Word}OleVariant; dispid 1610743811;\r\n function ToSByte(value: OleVariant): {??Shortint}OleVariant; dispid 1610743812;\r\n function ToByte(value: OleVariant): Byte; dispid 1610743813;\r\n function ToInt16(value: OleVariant): Smallint; dispid 1610743814;\r\n function ToUInt16(value: OleVariant): {??Word}OleVariant; dispid 1610743815;\r\n function ToInt32(value: OleVariant): Integer; dispid 1610743816;\r\n function ToUInt32(value: OleVariant): LongWord; dispid 1610743817;\r\n function ToInt64(value: OleVariant): {??Int64}OleVariant; dispid 1610743818;\r\n function ToUInt64(value: OleVariant): {??Largeuint}OleVariant; dispid 1610743819;\r\n function ToSingle(value: OleVariant): Single; dispid 1610743820;\r\n function ToDouble(value: OleVariant): Double; dispid 1610743821;\r\n function ToDecimal(value: OleVariant): {??TDecimal}OleVariant; dispid 1610743822;\r\n function ToDateTime(value: OleVariant): TDateTime; dispid 1610743823;\r\n property ToString[value: OleVariant]: WideString readonly dispid 1610743824;\r\n end;\r\n {$EXTERNALSYM IFormatterConverterDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _FormatterConverter\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {3FAA35EE-C867-3E2E-BF48-2DA271F88303}\r\n// *********************************************************************//\r\n _FormatterConverter = interface(IDispatch)\r\n ['{3FAA35EE-C867-3E2E-BF48-2DA271F88303}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _FormatterConverterDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {3FAA35EE-C867-3E2E-BF48-2DA271F88303}\r\n// *********************************************************************//\r\n _FormatterConverterDisp = dispinterface\r\n ['{3FAA35EE-C867-3E2E-BF48-2DA271F88303}']\r\n end;\r\n {$EXTERNALSYM _FormatterConverterDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _FormatterServices\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {F859954A-78CF-3D00-86AB-EF661E6A4B8D}\r\n// *********************************************************************//\r\n _FormatterServices = interface(IDispatch)\r\n ['{F859954A-78CF-3D00-86AB-EF661E6A4B8D}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _FormatterServicesDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {F859954A-78CF-3D00-86AB-EF661E6A4B8D}\r\n// *********************************************************************//\r\n _FormatterServicesDisp = dispinterface\r\n ['{F859954A-78CF-3D00-86AB-EF661E6A4B8D}']\r\n end;\r\n {$EXTERNALSYM _FormatterServicesDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: ISerializationSurrogate\r\n// Flags: (4416) Dual OleAutomation Dispatchable\r\n// GUID: {62339172-DBFA-337B-8AC8-053B241E06AB}\r\n// *********************************************************************//\r\n ISerializationSurrogate = interface(IDispatch)\r\n ['{62339172-DBFA-337B-8AC8-053B241E06AB}']\r\n procedure GetObjectData(obj: OleVariant; const info: _SerializationInfo; \r\n Context: StreamingContext); safecall;\r\n function SetObjectData(obj: OleVariant; const info: _SerializationInfo; \r\n Context: StreamingContext; const selector: ISurrogateSelector): OleVariant; safecall;\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: ISerializationSurrogateDisp\r\n// Flags: (4416) Dual OleAutomation Dispatchable\r\n// GUID: {62339172-DBFA-337B-8AC8-053B241E06AB}\r\n// *********************************************************************//\r\n ISerializationSurrogateDisp = dispinterface\r\n ['{62339172-DBFA-337B-8AC8-053B241E06AB}']\r\n procedure GetObjectData(obj: OleVariant; const info: _SerializationInfo; \r\n Context: {??StreamingContext}OleVariant); dispid 1610743808;\r\n function SetObjectData(obj: OleVariant; const info: _SerializationInfo; \r\n Context: {??StreamingContext}OleVariant; \r\n const selector: ISurrogateSelector): OleVariant; dispid 1610743809;\r\n end;\r\n {$EXTERNALSYM ISerializationSurrogateDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: ISurrogateSelector\r\n// Flags: (4416) Dual OleAutomation Dispatchable\r\n// GUID: {7C66FF18-A1A5-3E19-857B-0E7B6A9E3F38}\r\n// *********************************************************************//\r\n ISurrogateSelector = interface(IDispatch)\r\n ['{7C66FF18-A1A5-3E19-857B-0E7B6A9E3F38}']\r\n procedure ChainSelector(const selector: ISurrogateSelector); safecall;\r\n function GetSurrogate(const Type_: _Type; Context: StreamingContext; \r\n out selector: ISurrogateSelector): ISerializationSurrogate; safecall;\r\n function GetNextSelector: ISurrogateSelector; safecall;\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: ISurrogateSelectorDisp\r\n// Flags: (4416) Dual OleAutomation Dispatchable\r\n// GUID: {7C66FF18-A1A5-3E19-857B-0E7B6A9E3F38}\r\n// *********************************************************************//\r\n ISurrogateSelectorDisp = dispinterface\r\n ['{7C66FF18-A1A5-3E19-857B-0E7B6A9E3F38}']\r\n procedure ChainSelector(const selector: ISurrogateSelector); dispid 1610743808;\r\n function GetSurrogate(const Type_: _Type; Context: {??StreamingContext}OleVariant; \r\n out selector: ISurrogateSelector): ISerializationSurrogate; dispid 1610743809;\r\n function GetNextSelector: ISurrogateSelector; dispid 1610743810;\r\n end;\r\n {$EXTERNALSYM ISurrogateSelectorDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _ObjectIDGenerator\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {A30646CC-F710-3BFA-A356-B4C858D4ED8E}\r\n// *********************************************************************//\r\n _ObjectIDGenerator = interface(IDispatch)\r\n ['{A30646CC-F710-3BFA-A356-B4C858D4ED8E}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _ObjectIDGeneratorDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {A30646CC-F710-3BFA-A356-B4C858D4ED8E}\r\n// *********************************************************************//\r\n _ObjectIDGeneratorDisp = dispinterface\r\n ['{A30646CC-F710-3BFA-A356-B4C858D4ED8E}']\r\n end;\r\n {$EXTERNALSYM _ObjectIDGeneratorDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _ObjectManager\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {F28E7D04-3319-3968-8201-C6E55BECD3D4}\r\n// *********************************************************************//\r\n _ObjectManager = interface(IDispatch)\r\n ['{F28E7D04-3319-3968-8201-C6E55BECD3D4}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _ObjectManagerDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {F28E7D04-3319-3968-8201-C6E55BECD3D4}\r\n// *********************************************************************//\r\n _ObjectManagerDisp = dispinterface\r\n ['{F28E7D04-3319-3968-8201-C6E55BECD3D4}']\r\n end;\r\n {$EXTERNALSYM _ObjectManagerDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _SerializationBinder\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {450222D0-87CA-3699-A7B4-D8A0FDB72357}\r\n// *********************************************************************//\r\n _SerializationBinder = interface(IDispatch)\r\n ['{450222D0-87CA-3699-A7B4-D8A0FDB72357}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _SerializationBinderDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {450222D0-87CA-3699-A7B4-D8A0FDB72357}\r\n// *********************************************************************//\r\n _SerializationBinderDisp = dispinterface\r\n ['{450222D0-87CA-3699-A7B4-D8A0FDB72357}']\r\n end;\r\n {$EXTERNALSYM _SerializationBinderDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _SerializationInfo\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {B58D62CF-B03A-3A14-B0B6-B1E5AD4E4AD5}\r\n// *********************************************************************//\r\n _SerializationInfo = interface(IDispatch)\r\n ['{B58D62CF-B03A-3A14-B0B6-B1E5AD4E4AD5}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _SerializationInfoDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {B58D62CF-B03A-3A14-B0B6-B1E5AD4E4AD5}\r\n// *********************************************************************//\r\n _SerializationInfoDisp = dispinterface\r\n ['{B58D62CF-B03A-3A14-B0B6-B1E5AD4E4AD5}']\r\n end;\r\n {$EXTERNALSYM _SerializationInfoDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _SerializationInfoEnumerator\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {607056C6-1BCA-36C8-AB87-33B202EBF0D8}\r\n// *********************************************************************//\r\n _SerializationInfoEnumerator = interface(IDispatch)\r\n ['{607056C6-1BCA-36C8-AB87-33B202EBF0D8}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _SerializationInfoEnumeratorDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {607056C6-1BCA-36C8-AB87-33B202EBF0D8}\r\n// *********************************************************************//\r\n _SerializationInfoEnumeratorDisp = dispinterface\r\n ['{607056C6-1BCA-36C8-AB87-33B202EBF0D8}']\r\n end;\r\n {$EXTERNALSYM _SerializationInfoEnumeratorDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _SerializationException\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {245FE7FD-E020-3053-B5F6-7467FD2C6883}\r\n// *********************************************************************//\r\n _SerializationException = interface(IDispatch)\r\n ['{245FE7FD-E020-3053-B5F6-7467FD2C6883}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _SerializationExceptionDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {245FE7FD-E020-3053-B5F6-7467FD2C6883}\r\n// *********************************************************************//\r\n _SerializationExceptionDisp = dispinterface\r\n ['{245FE7FD-E020-3053-B5F6-7467FD2C6883}']\r\n end;\r\n {$EXTERNALSYM _SerializationExceptionDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _SurrogateSelector\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {6DE1230E-1F52-3779-9619-F5184103466C}\r\n// *********************************************************************//\r\n _SurrogateSelector = interface(IDispatch)\r\n ['{6DE1230E-1F52-3779-9619-F5184103466C}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _SurrogateSelectorDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {6DE1230E-1F52-3779-9619-F5184103466C}\r\n// *********************************************************************//\r\n _SurrogateSelectorDisp = dispinterface\r\n ['{6DE1230E-1F52-3779-9619-F5184103466C}']\r\n end;\r\n {$EXTERNALSYM _SurrogateSelectorDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _Calendar\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {4CCA29E4-584B-3CD0-AD25-855DC5799C16}\r\n// *********************************************************************//\r\n _Calendar = interface(IDispatch)\r\n ['{4CCA29E4-584B-3CD0-AD25-855DC5799C16}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _CalendarDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {4CCA29E4-584B-3CD0-AD25-855DC5799C16}\r\n// *********************************************************************//\r\n _CalendarDisp = dispinterface\r\n ['{4CCA29E4-584B-3CD0-AD25-855DC5799C16}']\r\n end;\r\n {$EXTERNALSYM _CalendarDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _CompareInfo\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {505DEFE5-AEFA-3E23-82B0-D5EB085BB840}\r\n// *********************************************************************//\r\n _CompareInfo = interface(IDispatch)\r\n ['{505DEFE5-AEFA-3E23-82B0-D5EB085BB840}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _CompareInfoDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {505DEFE5-AEFA-3E23-82B0-D5EB085BB840}\r\n// *********************************************************************//\r\n _CompareInfoDisp = dispinterface\r\n ['{505DEFE5-AEFA-3E23-82B0-D5EB085BB840}']\r\n end;\r\n {$EXTERNALSYM _CompareInfoDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _CultureInfo\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {152722C2-F0B1-3D19-ADA8-F40CA5CAECB8}\r\n// *********************************************************************//\r\n _CultureInfo = interface(IDispatch)\r\n ['{152722C2-F0B1-3D19-ADA8-F40CA5CAECB8}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _CultureInfoDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {152722C2-F0B1-3D19-ADA8-F40CA5CAECB8}\r\n// *********************************************************************//\r\n _CultureInfoDisp = dispinterface\r\n ['{152722C2-F0B1-3D19-ADA8-F40CA5CAECB8}']\r\n end;\r\n {$EXTERNALSYM _CultureInfoDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _DateTimeFormatInfo\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {015E9F67-337C-398A-A0C1-DA4AF1905571}\r\n// *********************************************************************//\r\n _DateTimeFormatInfo = interface(IDispatch)\r\n ['{015E9F67-337C-398A-A0C1-DA4AF1905571}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _DateTimeFormatInfoDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {015E9F67-337C-398A-A0C1-DA4AF1905571}\r\n// *********************************************************************//\r\n _DateTimeFormatInfoDisp = dispinterface\r\n ['{015E9F67-337C-398A-A0C1-DA4AF1905571}']\r\n end;\r\n {$EXTERNALSYM _DateTimeFormatInfoDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _DaylightTime\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {EFEA8FEB-EE7F-3E48-8A36-6206A6ACBF73}\r\n// *********************************************************************//\r\n _DaylightTime = interface(IDispatch)\r\n ['{EFEA8FEB-EE7F-3E48-8A36-6206A6ACBF73}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _DaylightTimeDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {EFEA8FEB-EE7F-3E48-8A36-6206A6ACBF73}\r\n// *********************************************************************//\r\n _DaylightTimeDisp = dispinterface\r\n ['{EFEA8FEB-EE7F-3E48-8A36-6206A6ACBF73}']\r\n end;\r\n {$EXTERNALSYM _DaylightTimeDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _GregorianCalendar\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {677AD8B5-8A0E-3C39-92FB-72FB817CF694}\r\n// *********************************************************************//\r\n _GregorianCalendar = interface(IDispatch)\r\n ['{677AD8B5-8A0E-3C39-92FB-72FB817CF694}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _GregorianCalendarDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {677AD8B5-8A0E-3C39-92FB-72FB817CF694}\r\n// *********************************************************************//\r\n _GregorianCalendarDisp = dispinterface\r\n ['{677AD8B5-8A0E-3C39-92FB-72FB817CF694}']\r\n end;\r\n {$EXTERNALSYM _GregorianCalendarDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _HebrewCalendar\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {96A62D6C-72A9-387A-81FA-E6DD5998CAEE}\r\n// *********************************************************************//\r\n _HebrewCalendar = interface(IDispatch)\r\n ['{96A62D6C-72A9-387A-81FA-E6DD5998CAEE}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _HebrewCalendarDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {96A62D6C-72A9-387A-81FA-E6DD5998CAEE}\r\n// *********************************************************************//\r\n _HebrewCalendarDisp = dispinterface\r\n ['{96A62D6C-72A9-387A-81FA-E6DD5998CAEE}']\r\n end;\r\n {$EXTERNALSYM _HebrewCalendarDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _HijriCalendar\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {28DDC187-56B2-34CF-A078-48BD1E113D1E}\r\n// *********************************************************************//\r\n _HijriCalendar = interface(IDispatch)\r\n ['{28DDC187-56B2-34CF-A078-48BD1E113D1E}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _HijriCalendarDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {28DDC187-56B2-34CF-A078-48BD1E113D1E}\r\n// *********************************************************************//\r\n _HijriCalendarDisp = dispinterface\r\n ['{28DDC187-56B2-34CF-A078-48BD1E113D1E}']\r\n end;\r\n {$EXTERNALSYM _HijriCalendarDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _JapaneseCalendar\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {D662AE3F-CEF9-38B4-BB8E-5D8DD1DBF806}\r\n// *********************************************************************//\r\n _JapaneseCalendar = interface(IDispatch)\r\n ['{D662AE3F-CEF9-38B4-BB8E-5D8DD1DBF806}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _JapaneseCalendarDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {D662AE3F-CEF9-38B4-BB8E-5D8DD1DBF806}\r\n// *********************************************************************//\r\n _JapaneseCalendarDisp = dispinterface\r\n ['{D662AE3F-CEF9-38B4-BB8E-5D8DD1DBF806}']\r\n end;\r\n {$EXTERNALSYM _JapaneseCalendarDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _JulianCalendar\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {36E2DE92-1FB3-3D7D-BA26-9CAD5B98DD52}\r\n// *********************************************************************//\r\n _JulianCalendar = interface(IDispatch)\r\n ['{36E2DE92-1FB3-3D7D-BA26-9CAD5B98DD52}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _JulianCalendarDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {36E2DE92-1FB3-3D7D-BA26-9CAD5B98DD52}\r\n// *********************************************************************//\r\n _JulianCalendarDisp = dispinterface\r\n ['{36E2DE92-1FB3-3D7D-BA26-9CAD5B98DD52}']\r\n end;\r\n {$EXTERNALSYM _JulianCalendarDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _KoreanCalendar\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {48BEA6C4-752E-3974-8CA8-CFB6274E2379}\r\n// *********************************************************************//\r\n _KoreanCalendar = interface(IDispatch)\r\n ['{48BEA6C4-752E-3974-8CA8-CFB6274E2379}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _KoreanCalendarDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {48BEA6C4-752E-3974-8CA8-CFB6274E2379}\r\n// *********************************************************************//\r\n _KoreanCalendarDisp = dispinterface\r\n ['{48BEA6C4-752E-3974-8CA8-CFB6274E2379}']\r\n end;\r\n {$EXTERNALSYM _KoreanCalendarDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _RegionInfo\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {F9E97E04-4E1E-368F-B6C6-5E96CE4362D6}\r\n// *********************************************************************//\r\n _RegionInfo = interface(IDispatch)\r\n ['{F9E97E04-4E1E-368F-B6C6-5E96CE4362D6}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _RegionInfoDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {F9E97E04-4E1E-368F-B6C6-5E96CE4362D6}\r\n// *********************************************************************//\r\n _RegionInfoDisp = dispinterface\r\n ['{F9E97E04-4E1E-368F-B6C6-5E96CE4362D6}']\r\n end;\r\n {$EXTERNALSYM _RegionInfoDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _SortKey\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {F4C70E15-2CA6-3E90-96ED-92E28491F538}\r\n// *********************************************************************//\r\n _SortKey = interface(IDispatch)\r\n ['{F4C70E15-2CA6-3E90-96ED-92E28491F538}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _SortKeyDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {F4C70E15-2CA6-3E90-96ED-92E28491F538}\r\n// *********************************************************************//\r\n _SortKeyDisp = dispinterface\r\n ['{F4C70E15-2CA6-3E90-96ED-92E28491F538}']\r\n end;\r\n {$EXTERNALSYM _SortKeyDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _StringInfo\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {0A25141F-51B3-3121-AA30-0AF4556A52D9}\r\n// *********************************************************************//\r\n _StringInfo = interface(IDispatch)\r\n ['{0A25141F-51B3-3121-AA30-0AF4556A52D9}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _StringInfoDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {0A25141F-51B3-3121-AA30-0AF4556A52D9}\r\n// *********************************************************************//\r\n _StringInfoDisp = dispinterface\r\n ['{0A25141F-51B3-3121-AA30-0AF4556A52D9}']\r\n end;\r\n {$EXTERNALSYM _StringInfoDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _TaiwanCalendar\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {0C08ED74-0ACF-32A9-99DF-09A9DC4786DD}\r\n// *********************************************************************//\r\n _TaiwanCalendar = interface(IDispatch)\r\n ['{0C08ED74-0ACF-32A9-99DF-09A9DC4786DD}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _TaiwanCalendarDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {0C08ED74-0ACF-32A9-99DF-09A9DC4786DD}\r\n// *********************************************************************//\r\n _TaiwanCalendarDisp = dispinterface\r\n ['{0C08ED74-0ACF-32A9-99DF-09A9DC4786DD}']\r\n end;\r\n {$EXTERNALSYM _TaiwanCalendarDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _TextElementEnumerator\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {8C248251-3E6C-3151-9F8E-A255FB8D2B12}\r\n// *********************************************************************//\r\n _TextElementEnumerator = interface(IDispatch)\r\n ['{8C248251-3E6C-3151-9F8E-A255FB8D2B12}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _TextElementEnumeratorDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {8C248251-3E6C-3151-9F8E-A255FB8D2B12}\r\n// *********************************************************************//\r\n _TextElementEnumeratorDisp = dispinterface\r\n ['{8C248251-3E6C-3151-9F8E-A255FB8D2B12}']\r\n end;\r\n {$EXTERNALSYM _TextElementEnumeratorDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _TextInfo\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {DB8DE23F-F264-39AC-B61C-CC1E7EB4A5E6}\r\n// *********************************************************************//\r\n _TextInfo = interface(IDispatch)\r\n ['{DB8DE23F-F264-39AC-B61C-CC1E7EB4A5E6}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _TextInfoDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {DB8DE23F-F264-39AC-B61C-CC1E7EB4A5E6}\r\n// *********************************************************************//\r\n _TextInfoDisp = dispinterface\r\n ['{DB8DE23F-F264-39AC-B61C-CC1E7EB4A5E6}']\r\n end;\r\n {$EXTERNALSYM _TextInfoDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _ThaiBuddhistCalendar\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {C70C8AE8-925B-37CE-8944-34F15FF94307}\r\n// *********************************************************************//\r\n _ThaiBuddhistCalendar = interface(IDispatch)\r\n ['{C70C8AE8-925B-37CE-8944-34F15FF94307}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _ThaiBuddhistCalendarDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {C70C8AE8-925B-37CE-8944-34F15FF94307}\r\n// *********************************************************************//\r\n _ThaiBuddhistCalendarDisp = dispinterface\r\n ['{C70C8AE8-925B-37CE-8944-34F15FF94307}']\r\n end;\r\n {$EXTERNALSYM _ThaiBuddhistCalendarDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _NumberFormatInfo\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {25E47D71-20DD-31BE-B261-7AE76497D6B9}\r\n// *********************************************************************//\r\n _NumberFormatInfo = interface(IDispatch)\r\n ['{25E47D71-20DD-31BE-B261-7AE76497D6B9}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _NumberFormatInfoDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {25E47D71-20DD-31BE-B261-7AE76497D6B9}\r\n// *********************************************************************//\r\n _NumberFormatInfoDisp = dispinterface\r\n ['{25E47D71-20DD-31BE-B261-7AE76497D6B9}']\r\n end;\r\n {$EXTERNALSYM _NumberFormatInfoDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _Encoding\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {DDEDB94D-4F3F-35C1-97C9-3F1D87628D9E}\r\n// *********************************************************************//\r\n _Encoding = interface(IDispatch)\r\n ['{DDEDB94D-4F3F-35C1-97C9-3F1D87628D9E}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _EncodingDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {DDEDB94D-4F3F-35C1-97C9-3F1D87628D9E}\r\n// *********************************************************************//\r\n _EncodingDisp = dispinterface\r\n ['{DDEDB94D-4F3F-35C1-97C9-3F1D87628D9E}']\r\n end;\r\n {$EXTERNALSYM _EncodingDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _System_Text_Decoder\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {2ADB0D4A-5976-38E4-852B-C131797430F5}\r\n// *********************************************************************//\r\n _System_Text_Decoder = interface(IDispatch)\r\n ['{2ADB0D4A-5976-38E4-852B-C131797430F5}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _System_Text_DecoderDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {2ADB0D4A-5976-38E4-852B-C131797430F5}\r\n// *********************************************************************//\r\n _System_Text_DecoderDisp = dispinterface\r\n ['{2ADB0D4A-5976-38E4-852B-C131797430F5}']\r\n end;\r\n {$EXTERNALSYM _System_Text_DecoderDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _System_Text_Encoder\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {8FD56502-8724-3DF0-A1B5-9D0E8D4E4F78}\r\n// *********************************************************************//\r\n _System_Text_Encoder = interface(IDispatch)\r\n ['{8FD56502-8724-3DF0-A1B5-9D0E8D4E4F78}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _System_Text_EncoderDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {8FD56502-8724-3DF0-A1B5-9D0E8D4E4F78}\r\n// *********************************************************************//\r\n _System_Text_EncoderDisp = dispinterface\r\n ['{8FD56502-8724-3DF0-A1B5-9D0E8D4E4F78}']\r\n end;\r\n {$EXTERNALSYM _System_Text_EncoderDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _ASCIIEncoding\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {0CBE0204-12A1-3D40-9D9E-195DE6AAA534}\r\n// *********************************************************************//\r\n _ASCIIEncoding = interface(IDispatch)\r\n ['{0CBE0204-12A1-3D40-9D9E-195DE6AAA534}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _ASCIIEncodingDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {0CBE0204-12A1-3D40-9D9E-195DE6AAA534}\r\n// *********************************************************************//\r\n _ASCIIEncodingDisp = dispinterface\r\n ['{0CBE0204-12A1-3D40-9D9E-195DE6AAA534}']\r\n end;\r\n {$EXTERNALSYM _ASCIIEncodingDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _UnicodeEncoding\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {F7DD3B7F-2B05-3894-8EDA-59CDF9395B6A}\r\n// *********************************************************************//\r\n _UnicodeEncoding = interface(IDispatch)\r\n ['{F7DD3B7F-2B05-3894-8EDA-59CDF9395B6A}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _UnicodeEncodingDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {F7DD3B7F-2B05-3894-8EDA-59CDF9395B6A}\r\n// *********************************************************************//\r\n _UnicodeEncodingDisp = dispinterface\r\n ['{F7DD3B7F-2B05-3894-8EDA-59CDF9395B6A}']\r\n end;\r\n {$EXTERNALSYM _UnicodeEncodingDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _UTF7Encoding\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {89B9F00B-AA2A-3A49-91B4-E8D1F1C00E58}\r\n// *********************************************************************//\r\n _UTF7Encoding = interface(IDispatch)\r\n ['{89B9F00B-AA2A-3A49-91B4-E8D1F1C00E58}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _UTF7EncodingDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {89B9F00B-AA2A-3A49-91B4-E8D1F1C00E58}\r\n// *********************************************************************//\r\n _UTF7EncodingDisp = dispinterface\r\n ['{89B9F00B-AA2A-3A49-91B4-E8D1F1C00E58}']\r\n end;\r\n {$EXTERNALSYM _UTF7EncodingDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _UTF8Encoding\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {010FC1D0-3EF9-3F3B-AA0A-B78A1FF83A37}\r\n// *********************************************************************//\r\n _UTF8Encoding = interface(IDispatch)\r\n ['{010FC1D0-3EF9-3F3B-AA0A-B78A1FF83A37}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _UTF8EncodingDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {010FC1D0-3EF9-3F3B-AA0A-B78A1FF83A37}\r\n// *********************************************************************//\r\n _UTF8EncodingDisp = dispinterface\r\n ['{010FC1D0-3EF9-3F3B-AA0A-B78A1FF83A37}']\r\n end;\r\n {$EXTERNALSYM _UTF8EncodingDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: IResourceReader\r\n// Flags: (4416) Dual OleAutomation Dispatchable\r\n// GUID: {8965A22F-FBA8-36AD-8132-70BBD0DA457D}\r\n// *********************************************************************//\r\n IResourceReader = interface(IDispatch)\r\n ['{8965A22F-FBA8-36AD-8132-70BBD0DA457D}']\r\n procedure Close; safecall;\r\n function GetEnumerator: IDictionaryEnumerator; safecall;\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: IResourceReaderDisp\r\n// Flags: (4416) Dual OleAutomation Dispatchable\r\n// GUID: {8965A22F-FBA8-36AD-8132-70BBD0DA457D}\r\n// *********************************************************************//\r\n IResourceReaderDisp = dispinterface\r\n ['{8965A22F-FBA8-36AD-8132-70BBD0DA457D}']\r\n procedure Close; dispid 1610743808;\r\n function GetEnumerator: IDictionaryEnumerator; dispid 1610743809;\r\n end;\r\n {$EXTERNALSYM IResourceReaderDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: IResourceWriter\r\n// Flags: (4416) Dual OleAutomation Dispatchable\r\n// GUID: {E97AA6E5-595E-31C3-82F0-688FB91954C6}\r\n// *********************************************************************//\r\n IResourceWriter = interface(IDispatch)\r\n ['{E97AA6E5-595E-31C3-82F0-688FB91954C6}']\r\n procedure AddResource(const name: WideString; const value: WideString); safecall;\r\n procedure AddResource_2(const name: WideString; value: OleVariant); safecall;\r\n procedure AddResource_3(const name: WideString; value: PSafeArray); safecall;\r\n procedure Close; safecall;\r\n procedure Generate; safecall;\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: IResourceWriterDisp\r\n// Flags: (4416) Dual OleAutomation Dispatchable\r\n// GUID: {E97AA6E5-595E-31C3-82F0-688FB91954C6}\r\n// *********************************************************************//\r\n IResourceWriterDisp = dispinterface\r\n ['{E97AA6E5-595E-31C3-82F0-688FB91954C6}']\r\n procedure AddResource(const name: WideString; const value: WideString); dispid 1610743808;\r\n procedure AddResource_2(const name: WideString; value: OleVariant); dispid 1610743809;\r\n procedure AddResource_3(const name: WideString; value: {??PSafeArray}OleVariant); dispid 1610743810;\r\n procedure Close; dispid 1610743811;\r\n procedure Generate; dispid 1610743812;\r\n end;\r\n {$EXTERNALSYM IResourceWriterDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _MissingManifestResourceException\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {1A4E1878-FE8C-3F59-B6A9-21AB82BE57E9}\r\n// *********************************************************************//\r\n _MissingManifestResourceException = interface(IDispatch)\r\n ['{1A4E1878-FE8C-3F59-B6A9-21AB82BE57E9}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _MissingManifestResourceExceptionDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {1A4E1878-FE8C-3F59-B6A9-21AB82BE57E9}\r\n// *********************************************************************//\r\n _MissingManifestResourceExceptionDisp = dispinterface\r\n ['{1A4E1878-FE8C-3F59-B6A9-21AB82BE57E9}']\r\n end;\r\n {$EXTERNALSYM _MissingManifestResourceExceptionDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _NeutralResourcesLanguageAttribute\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {F48DF808-8B7D-3F4E-9159-1DFD60F298D6}\r\n// *********************************************************************//\r\n _NeutralResourcesLanguageAttribute = interface(IDispatch)\r\n ['{F48DF808-8B7D-3F4E-9159-1DFD60F298D6}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _NeutralResourcesLanguageAttributeDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {F48DF808-8B7D-3F4E-9159-1DFD60F298D6}\r\n// *********************************************************************//\r\n _NeutralResourcesLanguageAttributeDisp = dispinterface\r\n ['{F48DF808-8B7D-3F4E-9159-1DFD60F298D6}']\r\n end;\r\n {$EXTERNALSYM _NeutralResourcesLanguageAttributeDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _ResourceManager\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {4DE671B7-7C85-37E9-AFF8-1222ABE4883E}\r\n// *********************************************************************//\r\n _ResourceManager = interface(IDispatch)\r\n ['{4DE671B7-7C85-37E9-AFF8-1222ABE4883E}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _ResourceManagerDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {4DE671B7-7C85-37E9-AFF8-1222ABE4883E}\r\n// *********************************************************************//\r\n _ResourceManagerDisp = dispinterface\r\n ['{4DE671B7-7C85-37E9-AFF8-1222ABE4883E}']\r\n end;\r\n {$EXTERNALSYM _ResourceManagerDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _ResourceReader\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {7FBCFDC7-5CEC-3945-8095-DAED61BE5FB1}\r\n// *********************************************************************//\r\n _ResourceReader = interface(IDispatch)\r\n ['{7FBCFDC7-5CEC-3945-8095-DAED61BE5FB1}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _ResourceReaderDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {7FBCFDC7-5CEC-3945-8095-DAED61BE5FB1}\r\n// *********************************************************************//\r\n _ResourceReaderDisp = dispinterface\r\n ['{7FBCFDC7-5CEC-3945-8095-DAED61BE5FB1}']\r\n end;\r\n {$EXTERNALSYM _ResourceReaderDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _ResourceSet\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {44D5F81A-727C-35AE-8DF8-9FF6722F1C6C}\r\n// *********************************************************************//\r\n _ResourceSet = interface(IDispatch)\r\n ['{44D5F81A-727C-35AE-8DF8-9FF6722F1C6C}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _ResourceSetDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {44D5F81A-727C-35AE-8DF8-9FF6722F1C6C}\r\n// *********************************************************************//\r\n _ResourceSetDisp = dispinterface\r\n ['{44D5F81A-727C-35AE-8DF8-9FF6722F1C6C}']\r\n end;\r\n {$EXTERNALSYM _ResourceSetDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _ResourceWriter\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {AF170258-AAC6-3A86-BD34-303E62CED10E}\r\n// *********************************************************************//\r\n _ResourceWriter = interface(IDispatch)\r\n ['{AF170258-AAC6-3A86-BD34-303E62CED10E}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _ResourceWriterDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {AF170258-AAC6-3A86-BD34-303E62CED10E}\r\n// *********************************************************************//\r\n _ResourceWriterDisp = dispinterface\r\n ['{AF170258-AAC6-3A86-BD34-303E62CED10E}']\r\n end;\r\n {$EXTERNALSYM _ResourceWriterDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _SatelliteContractVersionAttribute\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {5CBB1F47-FBA5-33B9-9D4A-57D6E3D133D2}\r\n// *********************************************************************//\r\n _SatelliteContractVersionAttribute = interface(IDispatch)\r\n ['{5CBB1F47-FBA5-33B9-9D4A-57D6E3D133D2}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _SatelliteContractVersionAttributeDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {5CBB1F47-FBA5-33B9-9D4A-57D6E3D133D2}\r\n// *********************************************************************//\r\n _SatelliteContractVersionAttributeDisp = dispinterface\r\n ['{5CBB1F47-FBA5-33B9-9D4A-57D6E3D133D2}']\r\n end;\r\n {$EXTERNALSYM _SatelliteContractVersionAttributeDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _Registry\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {23BAE0C0-3A36-32F0-9DAD-0E95ADD67D23}\r\n// *********************************************************************//\r\n _Registry = interface(IDispatch)\r\n ['{23BAE0C0-3A36-32F0-9DAD-0E95ADD67D23}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _RegistryDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {23BAE0C0-3A36-32F0-9DAD-0E95ADD67D23}\r\n// *********************************************************************//\r\n _RegistryDisp = dispinterface\r\n ['{23BAE0C0-3A36-32F0-9DAD-0E95ADD67D23}']\r\n end;\r\n {$EXTERNALSYM _RegistryDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _RegistryKey\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {2EAC6733-8D92-31D9-BE04-DC467EFC3EB1}\r\n// *********************************************************************//\r\n _RegistryKey = interface(IDispatch)\r\n ['{2EAC6733-8D92-31D9-BE04-DC467EFC3EB1}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _RegistryKeyDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {2EAC6733-8D92-31D9-BE04-DC467EFC3EB1}\r\n// *********************************************************************//\r\n _RegistryKeyDisp = dispinterface\r\n ['{2EAC6733-8D92-31D9-BE04-DC467EFC3EB1}']\r\n end;\r\n {$EXTERNALSYM _RegistryKeyDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _X509Certificate\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {68FD6F14-A7B2-36C8-A724-D01F90D73477}\r\n// *********************************************************************//\r\n _X509Certificate = interface(IDispatch)\r\n ['{68FD6F14-A7B2-36C8-A724-D01F90D73477}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _X509CertificateDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {68FD6F14-A7B2-36C8-A724-D01F90D73477}\r\n// *********************************************************************//\r\n _X509CertificateDisp = dispinterface\r\n ['{68FD6F14-A7B2-36C8-A724-D01F90D73477}']\r\n end;\r\n {$EXTERNALSYM _X509CertificateDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _AsymmetricAlgorithm\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {09343AC0-D19A-3E62-BC16-0F600F10180A}\r\n// *********************************************************************//\r\n _AsymmetricAlgorithm = interface(IDispatch)\r\n ['{09343AC0-D19A-3E62-BC16-0F600F10180A}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _AsymmetricAlgorithmDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {09343AC0-D19A-3E62-BC16-0F600F10180A}\r\n// *********************************************************************//\r\n _AsymmetricAlgorithmDisp = dispinterface\r\n ['{09343AC0-D19A-3E62-BC16-0F600F10180A}']\r\n end;\r\n {$EXTERNALSYM _AsymmetricAlgorithmDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _AsymmetricKeyExchangeDeformatter\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {B6685CCA-7A49-37D1-A805-3DE829CB8DEB}\r\n// *********************************************************************//\r\n _AsymmetricKeyExchangeDeformatter = interface(IDispatch)\r\n ['{B6685CCA-7A49-37D1-A805-3DE829CB8DEB}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _AsymmetricKeyExchangeDeformatterDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {B6685CCA-7A49-37D1-A805-3DE829CB8DEB}\r\n// *********************************************************************//\r\n _AsymmetricKeyExchangeDeformatterDisp = dispinterface\r\n ['{B6685CCA-7A49-37D1-A805-3DE829CB8DEB}']\r\n end;\r\n {$EXTERNALSYM _AsymmetricKeyExchangeDeformatterDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _AsymmetricKeyExchangeFormatter\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {1365B84B-6477-3C40-BE6A-089DC01ECED9}\r\n// *********************************************************************//\r\n _AsymmetricKeyExchangeFormatter = interface(IDispatch)\r\n ['{1365B84B-6477-3C40-BE6A-089DC01ECED9}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _AsymmetricKeyExchangeFormatterDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {1365B84B-6477-3C40-BE6A-089DC01ECED9}\r\n// *********************************************************************//\r\n _AsymmetricKeyExchangeFormatterDisp = dispinterface\r\n ['{1365B84B-6477-3C40-BE6A-089DC01ECED9}']\r\n end;\r\n {$EXTERNALSYM _AsymmetricKeyExchangeFormatterDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _AsymmetricSignatureDeformatter\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {7CA5FE57-D1AC-3064-BB0B-F450BE40F194}\r\n// *********************************************************************//\r\n _AsymmetricSignatureDeformatter = interface(IDispatch)\r\n ['{7CA5FE57-D1AC-3064-BB0B-F450BE40F194}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _AsymmetricSignatureDeformatterDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {7CA5FE57-D1AC-3064-BB0B-F450BE40F194}\r\n// *********************************************************************//\r\n _AsymmetricSignatureDeformatterDisp = dispinterface\r\n ['{7CA5FE57-D1AC-3064-BB0B-F450BE40F194}']\r\n end;\r\n {$EXTERNALSYM _AsymmetricSignatureDeformatterDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _AsymmetricSignatureFormatter\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {5363D066-6295-3618-BE33-3F0B070B7976}\r\n// *********************************************************************//\r\n _AsymmetricSignatureFormatter = interface(IDispatch)\r\n ['{5363D066-6295-3618-BE33-3F0B070B7976}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _AsymmetricSignatureFormatterDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {5363D066-6295-3618-BE33-3F0B070B7976}\r\n// *********************************************************************//\r\n _AsymmetricSignatureFormatterDisp = dispinterface\r\n ['{5363D066-6295-3618-BE33-3F0B070B7976}']\r\n end;\r\n {$EXTERNALSYM _AsymmetricSignatureFormatterDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: ICryptoTransform\r\n// Flags: (4416) Dual OleAutomation Dispatchable\r\n// GUID: {8ABAD867-F515-3CF6-BB62-5F0C88B3BB11}\r\n// *********************************************************************//\r\n ICryptoTransform = interface(IDispatch)\r\n ['{8ABAD867-F515-3CF6-BB62-5F0C88B3BB11}']\r\n function Get_InputBlockSize: Integer; safecall;\r\n function Get_OutputBlockSize: Integer; safecall;\r\n function Get_CanTransformMultipleBlocks: WordBool; safecall;\r\n function Get_CanReuseTransform: WordBool; safecall;\r\n function TransformBlock(inputBuffer: PSafeArray; inputOffset: Integer; inputCount: Integer; \r\n outputBuffer: PSafeArray; outputOffset: Integer): Integer; safecall;\r\n function TransformFinalBlock(inputBuffer: PSafeArray; inputOffset: Integer; inputCount: Integer): PSafeArray; safecall;\r\n property InputBlockSize: Integer read Get_InputBlockSize;\r\n property OutputBlockSize: Integer read Get_OutputBlockSize;\r\n property CanTransformMultipleBlocks: WordBool read Get_CanTransformMultipleBlocks;\r\n property CanReuseTransform: WordBool read Get_CanReuseTransform;\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: ICryptoTransformDisp\r\n// Flags: (4416) Dual OleAutomation Dispatchable\r\n// GUID: {8ABAD867-F515-3CF6-BB62-5F0C88B3BB11}\r\n// *********************************************************************//\r\n ICryptoTransformDisp = dispinterface\r\n ['{8ABAD867-F515-3CF6-BB62-5F0C88B3BB11}']\r\n property InputBlockSize: Integer readonly dispid 1610743808;\r\n property OutputBlockSize: Integer readonly dispid 1610743809;\r\n property CanTransformMultipleBlocks: WordBool readonly dispid 1610743810;\r\n property CanReuseTransform: WordBool readonly dispid 1610743811;\r\n function TransformBlock(inputBuffer: {??PSafeArray}OleVariant; inputOffset: Integer; \r\n inputCount: Integer; outputBuffer: {??PSafeArray}OleVariant; \r\n outputOffset: Integer): Integer; dispid 1610743812;\r\n function TransformFinalBlock(inputBuffer: {??PSafeArray}OleVariant; inputOffset: Integer; \r\n inputCount: Integer): {??PSafeArray}OleVariant; dispid 1610743813;\r\n end;\r\n {$EXTERNALSYM ICryptoTransformDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _ToBase64Transform\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {23DED1E1-7D5F-3936-AA4E-18BBCC39B155}\r\n// *********************************************************************//\r\n _ToBase64Transform = interface(IDispatch)\r\n ['{23DED1E1-7D5F-3936-AA4E-18BBCC39B155}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _ToBase64TransformDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {23DED1E1-7D5F-3936-AA4E-18BBCC39B155}\r\n// *********************************************************************//\r\n _ToBase64TransformDisp = dispinterface\r\n ['{23DED1E1-7D5F-3936-AA4E-18BBCC39B155}']\r\n end;\r\n {$EXTERNALSYM _ToBase64TransformDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _FromBase64Transform\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {FC0717A6-2E86-372F-81F4-B35ED4BDF0DE}\r\n// *********************************************************************//\r\n _FromBase64Transform = interface(IDispatch)\r\n ['{FC0717A6-2E86-372F-81F4-B35ED4BDF0DE}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _FromBase64TransformDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {FC0717A6-2E86-372F-81F4-B35ED4BDF0DE}\r\n// *********************************************************************//\r\n _FromBase64TransformDisp = dispinterface\r\n ['{FC0717A6-2E86-372F-81F4-B35ED4BDF0DE}']\r\n end;\r\n {$EXTERNALSYM _FromBase64TransformDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _KeySizes\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {8978B0BE-A89E-3FF9-9834-77862CEBFF3D}\r\n// *********************************************************************//\r\n _KeySizes = interface(IDispatch)\r\n ['{8978B0BE-A89E-3FF9-9834-77862CEBFF3D}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _KeySizesDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {8978B0BE-A89E-3FF9-9834-77862CEBFF3D}\r\n// *********************************************************************//\r\n _KeySizesDisp = dispinterface\r\n ['{8978B0BE-A89E-3FF9-9834-77862CEBFF3D}']\r\n end;\r\n {$EXTERNALSYM _KeySizesDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _CryptographicException\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {4311E8F5-B249-3F81-8FF4-CF853D85306D}\r\n// *********************************************************************//\r\n _CryptographicException = interface(IDispatch)\r\n ['{4311E8F5-B249-3F81-8FF4-CF853D85306D}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _CryptographicExceptionDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {4311E8F5-B249-3F81-8FF4-CF853D85306D}\r\n// *********************************************************************//\r\n _CryptographicExceptionDisp = dispinterface\r\n ['{4311E8F5-B249-3F81-8FF4-CF853D85306D}']\r\n end;\r\n {$EXTERNALSYM _CryptographicExceptionDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _CryptographicUnexpectedOperationException\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {7FB08423-038F-3ACC-B600-E6D072BAE160}\r\n// *********************************************************************//\r\n _CryptographicUnexpectedOperationException = interface(IDispatch)\r\n ['{7FB08423-038F-3ACC-B600-E6D072BAE160}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _CryptographicUnexpectedOperationExceptionDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {7FB08423-038F-3ACC-B600-E6D072BAE160}\r\n// *********************************************************************//\r\n _CryptographicUnexpectedOperationExceptionDisp = dispinterface\r\n ['{7FB08423-038F-3ACC-B600-E6D072BAE160}']\r\n end;\r\n {$EXTERNALSYM _CryptographicUnexpectedOperationExceptionDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _CryptoAPITransform\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {983B8639-2ED7-364C-9899-682ABB2CE850}\r\n// *********************************************************************//\r\n _CryptoAPITransform = interface(IDispatch)\r\n ['{983B8639-2ED7-364C-9899-682ABB2CE850}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _CryptoAPITransformDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {983B8639-2ED7-364C-9899-682ABB2CE850}\r\n// *********************************************************************//\r\n _CryptoAPITransformDisp = dispinterface\r\n ['{983B8639-2ED7-364C-9899-682ABB2CE850}']\r\n end;\r\n {$EXTERNALSYM _CryptoAPITransformDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _CspParameters\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {D5331D95-FFF2-358F-AFD5-588F469FF2E4}\r\n// *********************************************************************//\r\n _CspParameters = interface(IDispatch)\r\n ['{D5331D95-FFF2-358F-AFD5-588F469FF2E4}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _CspParametersDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {D5331D95-FFF2-358F-AFD5-588F469FF2E4}\r\n// *********************************************************************//\r\n _CspParametersDisp = dispinterface\r\n ['{D5331D95-FFF2-358F-AFD5-588F469FF2E4}']\r\n end;\r\n {$EXTERNALSYM _CspParametersDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _CryptoConfig\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {AB00F3F8-7DDE-3FF5-B805-6C5DBB200549}\r\n// *********************************************************************//\r\n _CryptoConfig = interface(IDispatch)\r\n ['{AB00F3F8-7DDE-3FF5-B805-6C5DBB200549}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _CryptoConfigDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {AB00F3F8-7DDE-3FF5-B805-6C5DBB200549}\r\n// *********************************************************************//\r\n _CryptoConfigDisp = dispinterface\r\n ['{AB00F3F8-7DDE-3FF5-B805-6C5DBB200549}']\r\n end;\r\n {$EXTERNALSYM _CryptoConfigDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _Stream\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {2752364A-924F-3603-8F6F-6586DF98B292}\r\n// *********************************************************************//\r\n _Stream = interface(IDispatch)\r\n ['{2752364A-924F-3603-8F6F-6586DF98B292}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _StreamDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {2752364A-924F-3603-8F6F-6586DF98B292}\r\n// *********************************************************************//\r\n _StreamDisp = dispinterface\r\n ['{2752364A-924F-3603-8F6F-6586DF98B292}']\r\n end;\r\n {$EXTERNALSYM _StreamDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _CryptoStream\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {4134F762-D0EC-3210-93C0-DE4F443D5669}\r\n// *********************************************************************//\r\n _CryptoStream = interface(IDispatch)\r\n ['{4134F762-D0EC-3210-93C0-DE4F443D5669}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _CryptoStreamDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {4134F762-D0EC-3210-93C0-DE4F443D5669}\r\n// *********************************************************************//\r\n _CryptoStreamDisp = dispinterface\r\n ['{4134F762-D0EC-3210-93C0-DE4F443D5669}']\r\n end;\r\n {$EXTERNALSYM _CryptoStreamDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _SymmetricAlgorithm\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {05BC0E38-7136-3825-9E34-26C1CF2142C9}\r\n// *********************************************************************//\r\n _SymmetricAlgorithm = interface(IDispatch)\r\n ['{05BC0E38-7136-3825-9E34-26C1CF2142C9}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _SymmetricAlgorithmDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {05BC0E38-7136-3825-9E34-26C1CF2142C9}\r\n// *********************************************************************//\r\n _SymmetricAlgorithmDisp = dispinterface\r\n ['{05BC0E38-7136-3825-9E34-26C1CF2142C9}']\r\n end;\r\n {$EXTERNALSYM _SymmetricAlgorithmDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _DES\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {C7EF0214-B91C-3799-98DD-C994AABFC741}\r\n// *********************************************************************//\r\n _DES = interface(IDispatch)\r\n ['{C7EF0214-B91C-3799-98DD-C994AABFC741}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _DESDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {C7EF0214-B91C-3799-98DD-C994AABFC741}\r\n// *********************************************************************//\r\n _DESDisp = dispinterface\r\n ['{C7EF0214-B91C-3799-98DD-C994AABFC741}']\r\n end;\r\n {$EXTERNALSYM _DESDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _DESCryptoServiceProvider\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {65E8495E-5207-3248-9250-0FC849B4F096}\r\n// *********************************************************************//\r\n _DESCryptoServiceProvider = interface(IDispatch)\r\n ['{65E8495E-5207-3248-9250-0FC849B4F096}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _DESCryptoServiceProviderDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {65E8495E-5207-3248-9250-0FC849B4F096}\r\n// *********************************************************************//\r\n _DESCryptoServiceProviderDisp = dispinterface\r\n ['{65E8495E-5207-3248-9250-0FC849B4F096}']\r\n end;\r\n {$EXTERNALSYM _DESCryptoServiceProviderDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _DeriveBytes\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {140EE78F-067F-3765-9258-C3BC72FE976B}\r\n// *********************************************************************//\r\n _DeriveBytes = interface(IDispatch)\r\n ['{140EE78F-067F-3765-9258-C3BC72FE976B}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _DeriveBytesDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {140EE78F-067F-3765-9258-C3BC72FE976B}\r\n// *********************************************************************//\r\n _DeriveBytesDisp = dispinterface\r\n ['{140EE78F-067F-3765-9258-C3BC72FE976B}']\r\n end;\r\n {$EXTERNALSYM _DeriveBytesDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _DSA\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {0EB5B5E0-1BE6-3A5F-87B3-E3323342F44E}\r\n// *********************************************************************//\r\n _DSA = interface(IDispatch)\r\n ['{0EB5B5E0-1BE6-3A5F-87B3-E3323342F44E}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _DSADisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {0EB5B5E0-1BE6-3A5F-87B3-E3323342F44E}\r\n// *********************************************************************//\r\n _DSADisp = dispinterface\r\n ['{0EB5B5E0-1BE6-3A5F-87B3-E3323342F44E}']\r\n end;\r\n {$EXTERNALSYM _DSADisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _DSACryptoServiceProvider\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {1F38AAFE-7502-332F-971F-C2FC700A1D55}\r\n// *********************************************************************//\r\n _DSACryptoServiceProvider = interface(IDispatch)\r\n ['{1F38AAFE-7502-332F-971F-C2FC700A1D55}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _DSACryptoServiceProviderDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {1F38AAFE-7502-332F-971F-C2FC700A1D55}\r\n// *********************************************************************//\r\n _DSACryptoServiceProviderDisp = dispinterface\r\n ['{1F38AAFE-7502-332F-971F-C2FC700A1D55}']\r\n end;\r\n {$EXTERNALSYM _DSACryptoServiceProviderDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _DSASignatureDeformatter\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {0E774498-ADE6-3820-B1D5-426B06397BE7}\r\n// *********************************************************************//\r\n _DSASignatureDeformatter = interface(IDispatch)\r\n ['{0E774498-ADE6-3820-B1D5-426B06397BE7}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _DSASignatureDeformatterDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {0E774498-ADE6-3820-B1D5-426B06397BE7}\r\n// *********************************************************************//\r\n _DSASignatureDeformatterDisp = dispinterface\r\n ['{0E774498-ADE6-3820-B1D5-426B06397BE7}']\r\n end;\r\n {$EXTERNALSYM _DSASignatureDeformatterDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _DSASignatureFormatter\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {4B5FC561-5983-31E4-903B-1404231B2C89}\r\n// *********************************************************************//\r\n _DSASignatureFormatter = interface(IDispatch)\r\n ['{4B5FC561-5983-31E4-903B-1404231B2C89}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _DSASignatureFormatterDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {4B5FC561-5983-31E4-903B-1404231B2C89}\r\n// *********************************************************************//\r\n _DSASignatureFormatterDisp = dispinterface\r\n ['{4B5FC561-5983-31E4-903B-1404231B2C89}']\r\n end;\r\n {$EXTERNALSYM _DSASignatureFormatterDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _HashAlgorithm\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {69D3BABA-1C3D-354C-ACFE-F19109EC3896}\r\n// *********************************************************************//\r\n _HashAlgorithm = interface(IDispatch)\r\n ['{69D3BABA-1C3D-354C-ACFE-F19109EC3896}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _HashAlgorithmDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {69D3BABA-1C3D-354C-ACFE-F19109EC3896}\r\n// *********************************************************************//\r\n _HashAlgorithmDisp = dispinterface\r\n ['{69D3BABA-1C3D-354C-ACFE-F19109EC3896}']\r\n end;\r\n {$EXTERNALSYM _HashAlgorithmDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _KeyedHashAlgorithm\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {D182CF91-628C-3FF6-87F0-41BA51CC7433}\r\n// *********************************************************************//\r\n _KeyedHashAlgorithm = interface(IDispatch)\r\n ['{D182CF91-628C-3FF6-87F0-41BA51CC7433}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _KeyedHashAlgorithmDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {D182CF91-628C-3FF6-87F0-41BA51CC7433}\r\n// *********************************************************************//\r\n _KeyedHashAlgorithmDisp = dispinterface\r\n ['{D182CF91-628C-3FF6-87F0-41BA51CC7433}']\r\n end;\r\n {$EXTERNALSYM _KeyedHashAlgorithmDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _HMACSHA1\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {63AC7C37-C51A-3D82-8FDD-2A567039E46D}\r\n// *********************************************************************//\r\n _HMACSHA1 = interface(IDispatch)\r\n ['{63AC7C37-C51A-3D82-8FDD-2A567039E46D}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _HMACSHA1Disp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {63AC7C37-C51A-3D82-8FDD-2A567039E46D}\r\n// *********************************************************************//\r\n _HMACSHA1Disp = dispinterface\r\n ['{63AC7C37-C51A-3D82-8FDD-2A567039E46D}']\r\n end;\r\n {$EXTERNALSYM _HMACSHA1Disp}\r\n\r\n// *********************************************************************//\r\n// Interface: _MACTripleDES\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {1CAC0BDA-AC58-31BC-B624-63F77D0C3D2F}\r\n// *********************************************************************//\r\n _MACTripleDES = interface(IDispatch)\r\n ['{1CAC0BDA-AC58-31BC-B624-63F77D0C3D2F}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _MACTripleDESDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {1CAC0BDA-AC58-31BC-B624-63F77D0C3D2F}\r\n// *********************************************************************//\r\n _MACTripleDESDisp = dispinterface\r\n ['{1CAC0BDA-AC58-31BC-B624-63F77D0C3D2F}']\r\n end;\r\n {$EXTERNALSYM _MACTripleDESDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _MD5\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {9AA8765E-69A0-30E3-9CDE-EBC70662AE37}\r\n// *********************************************************************//\r\n _MD5 = interface(IDispatch)\r\n ['{9AA8765E-69A0-30E3-9CDE-EBC70662AE37}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _MD5Disp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {9AA8765E-69A0-30E3-9CDE-EBC70662AE37}\r\n// *********************************************************************//\r\n _MD5Disp = dispinterface\r\n ['{9AA8765E-69A0-30E3-9CDE-EBC70662AE37}']\r\n end;\r\n {$EXTERNALSYM _MD5Disp}\r\n\r\n// *********************************************************************//\r\n// Interface: _MD5CryptoServiceProvider\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {D3F5C812-5867-33C9-8CEE-CB170E8D844A}\r\n// *********************************************************************//\r\n _MD5CryptoServiceProvider = interface(IDispatch)\r\n ['{D3F5C812-5867-33C9-8CEE-CB170E8D844A}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _MD5CryptoServiceProviderDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {D3F5C812-5867-33C9-8CEE-CB170E8D844A}\r\n// *********************************************************************//\r\n _MD5CryptoServiceProviderDisp = dispinterface\r\n ['{D3F5C812-5867-33C9-8CEE-CB170E8D844A}']\r\n end;\r\n {$EXTERNALSYM _MD5CryptoServiceProviderDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _MaskGenerationMethod\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {85601FEE-A79D-3710-AF21-099089EDC0BF}\r\n// *********************************************************************//\r\n _MaskGenerationMethod = interface(IDispatch)\r\n ['{85601FEE-A79D-3710-AF21-099089EDC0BF}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _MaskGenerationMethodDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {85601FEE-A79D-3710-AF21-099089EDC0BF}\r\n// *********************************************************************//\r\n _MaskGenerationMethodDisp = dispinterface\r\n ['{85601FEE-A79D-3710-AF21-099089EDC0BF}']\r\n end;\r\n {$EXTERNALSYM _MaskGenerationMethodDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _PasswordDeriveBytes\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {3CD62D67-586F-309E-A6D8-1F4BAAC5AC28}\r\n// *********************************************************************//\r\n _PasswordDeriveBytes = interface(IDispatch)\r\n ['{3CD62D67-586F-309E-A6D8-1F4BAAC5AC28}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _PasswordDeriveBytesDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {3CD62D67-586F-309E-A6D8-1F4BAAC5AC28}\r\n// *********************************************************************//\r\n _PasswordDeriveBytesDisp = dispinterface\r\n ['{3CD62D67-586F-309E-A6D8-1F4BAAC5AC28}']\r\n end;\r\n {$EXTERNALSYM _PasswordDeriveBytesDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _PKCS1MaskGenerationMethod\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {425BFF0D-59E4-36A8-B1FF-1F5D39D698F4}\r\n// *********************************************************************//\r\n _PKCS1MaskGenerationMethod = interface(IDispatch)\r\n ['{425BFF0D-59E4-36A8-B1FF-1F5D39D698F4}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _PKCS1MaskGenerationMethodDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {425BFF0D-59E4-36A8-B1FF-1F5D39D698F4}\r\n// *********************************************************************//\r\n _PKCS1MaskGenerationMethodDisp = dispinterface\r\n ['{425BFF0D-59E4-36A8-B1FF-1F5D39D698F4}']\r\n end;\r\n {$EXTERNALSYM _PKCS1MaskGenerationMethodDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _RC2\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {F7C0C4CC-0D49-31EE-A3D3-B8B551E4928C}\r\n// *********************************************************************//\r\n _RC2 = interface(IDispatch)\r\n ['{F7C0C4CC-0D49-31EE-A3D3-B8B551E4928C}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _RC2Disp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {F7C0C4CC-0D49-31EE-A3D3-B8B551E4928C}\r\n// *********************************************************************//\r\n _RC2Disp = dispinterface\r\n ['{F7C0C4CC-0D49-31EE-A3D3-B8B551E4928C}']\r\n end;\r\n {$EXTERNALSYM _RC2Disp}\r\n\r\n// *********************************************************************//\r\n// Interface: _RC2CryptoServiceProvider\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {875715C5-CB64-3920-8156-0EE9CB0E07EA}\r\n// *********************************************************************//\r\n _RC2CryptoServiceProvider = interface(IDispatch)\r\n ['{875715C5-CB64-3920-8156-0EE9CB0E07EA}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _RC2CryptoServiceProviderDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {875715C5-CB64-3920-8156-0EE9CB0E07EA}\r\n// *********************************************************************//\r\n _RC2CryptoServiceProviderDisp = dispinterface\r\n ['{875715C5-CB64-3920-8156-0EE9CB0E07EA}']\r\n end;\r\n {$EXTERNALSYM _RC2CryptoServiceProviderDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _RandomNumberGenerator\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {7AE4B03C-414A-36E0-BA68-F9603004C925}\r\n// *********************************************************************//\r\n _RandomNumberGenerator = interface(IDispatch)\r\n ['{7AE4B03C-414A-36E0-BA68-F9603004C925}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _RandomNumberGeneratorDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {7AE4B03C-414A-36E0-BA68-F9603004C925}\r\n// *********************************************************************//\r\n _RandomNumberGeneratorDisp = dispinterface\r\n ['{7AE4B03C-414A-36E0-BA68-F9603004C925}']\r\n end;\r\n {$EXTERNALSYM _RandomNumberGeneratorDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _RNGCryptoServiceProvider\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {2C65D4C0-584C-3E4E-8E6D-1AFB112BFF69}\r\n// *********************************************************************//\r\n _RNGCryptoServiceProvider = interface(IDispatch)\r\n ['{2C65D4C0-584C-3E4E-8E6D-1AFB112BFF69}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _RNGCryptoServiceProviderDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {2C65D4C0-584C-3E4E-8E6D-1AFB112BFF69}\r\n// *********************************************************************//\r\n _RNGCryptoServiceProviderDisp = dispinterface\r\n ['{2C65D4C0-584C-3E4E-8E6D-1AFB112BFF69}']\r\n end;\r\n {$EXTERNALSYM _RNGCryptoServiceProviderDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _RSA\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {0B3FB710-A25C-3310-8774-1CF117F95BD4}\r\n// *********************************************************************//\r\n _RSA = interface(IDispatch)\r\n ['{0B3FB710-A25C-3310-8774-1CF117F95BD4}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _RSADisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {0B3FB710-A25C-3310-8774-1CF117F95BD4}\r\n// *********************************************************************//\r\n _RSADisp = dispinterface\r\n ['{0B3FB710-A25C-3310-8774-1CF117F95BD4}']\r\n end;\r\n {$EXTERNALSYM _RSADisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _RSACryptoServiceProvider\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {BD9DF856-2300-3254-BCF0-679BA03C7A13}\r\n// *********************************************************************//\r\n _RSACryptoServiceProvider = interface(IDispatch)\r\n ['{BD9DF856-2300-3254-BCF0-679BA03C7A13}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _RSACryptoServiceProviderDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {BD9DF856-2300-3254-BCF0-679BA03C7A13}\r\n// *********************************************************************//\r\n _RSACryptoServiceProviderDisp = dispinterface\r\n ['{BD9DF856-2300-3254-BCF0-679BA03C7A13}']\r\n end;\r\n {$EXTERNALSYM _RSACryptoServiceProviderDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _RSAOAEPKeyExchangeDeformatter\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {37625095-7BAA-377D-A0DC-7F465C0167AA}\r\n// *********************************************************************//\r\n _RSAOAEPKeyExchangeDeformatter = interface(IDispatch)\r\n ['{37625095-7BAA-377D-A0DC-7F465C0167AA}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _RSAOAEPKeyExchangeDeformatterDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {37625095-7BAA-377D-A0DC-7F465C0167AA}\r\n// *********************************************************************//\r\n _RSAOAEPKeyExchangeDeformatterDisp = dispinterface\r\n ['{37625095-7BAA-377D-A0DC-7F465C0167AA}']\r\n end;\r\n {$EXTERNALSYM _RSAOAEPKeyExchangeDeformatterDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _RSAOAEPKeyExchangeFormatter\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {77A416E7-2AC6-3D0E-98FF-3BA0F586F56F}\r\n// *********************************************************************//\r\n _RSAOAEPKeyExchangeFormatter = interface(IDispatch)\r\n ['{77A416E7-2AC6-3D0E-98FF-3BA0F586F56F}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _RSAOAEPKeyExchangeFormatterDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {77A416E7-2AC6-3D0E-98FF-3BA0F586F56F}\r\n// *********************************************************************//\r\n _RSAOAEPKeyExchangeFormatterDisp = dispinterface\r\n ['{77A416E7-2AC6-3D0E-98FF-3BA0F586F56F}']\r\n end;\r\n {$EXTERNALSYM _RSAOAEPKeyExchangeFormatterDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _RSAPKCS1KeyExchangeDeformatter\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {8034AAF4-3666-3B6F-85CF-463F9BFD31A9}\r\n// *********************************************************************//\r\n _RSAPKCS1KeyExchangeDeformatter = interface(IDispatch)\r\n ['{8034AAF4-3666-3B6F-85CF-463F9BFD31A9}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _RSAPKCS1KeyExchangeDeformatterDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {8034AAF4-3666-3B6F-85CF-463F9BFD31A9}\r\n// *********************************************************************//\r\n _RSAPKCS1KeyExchangeDeformatterDisp = dispinterface\r\n ['{8034AAF4-3666-3B6F-85CF-463F9BFD31A9}']\r\n end;\r\n {$EXTERNALSYM _RSAPKCS1KeyExchangeDeformatterDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _RSAPKCS1KeyExchangeFormatter\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {9FF67F8E-A7AA-3BA6-90EE-9D44AF6E2F8C}\r\n// *********************************************************************//\r\n _RSAPKCS1KeyExchangeFormatter = interface(IDispatch)\r\n ['{9FF67F8E-A7AA-3BA6-90EE-9D44AF6E2F8C}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _RSAPKCS1KeyExchangeFormatterDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {9FF67F8E-A7AA-3BA6-90EE-9D44AF6E2F8C}\r\n// *********************************************************************//\r\n _RSAPKCS1KeyExchangeFormatterDisp = dispinterface\r\n ['{9FF67F8E-A7AA-3BA6-90EE-9D44AF6E2F8C}']\r\n end;\r\n {$EXTERNALSYM _RSAPKCS1KeyExchangeFormatterDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _RSAPKCS1SignatureDeformatter\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {FC38507E-06A4-3300-8652-8D7B54341F65}\r\n// *********************************************************************//\r\n _RSAPKCS1SignatureDeformatter = interface(IDispatch)\r\n ['{FC38507E-06A4-3300-8652-8D7B54341F65}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _RSAPKCS1SignatureDeformatterDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {FC38507E-06A4-3300-8652-8D7B54341F65}\r\n// *********************************************************************//\r\n _RSAPKCS1SignatureDeformatterDisp = dispinterface\r\n ['{FC38507E-06A4-3300-8652-8D7B54341F65}']\r\n end;\r\n {$EXTERNALSYM _RSAPKCS1SignatureDeformatterDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _RSAPKCS1SignatureFormatter\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {FB7A5FF4-CFA8-3F24-AD5F-D5EB39359707}\r\n// *********************************************************************//\r\n _RSAPKCS1SignatureFormatter = interface(IDispatch)\r\n ['{FB7A5FF4-CFA8-3F24-AD5F-D5EB39359707}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _RSAPKCS1SignatureFormatterDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {FB7A5FF4-CFA8-3F24-AD5F-D5EB39359707}\r\n// *********************************************************************//\r\n _RSAPKCS1SignatureFormatterDisp = dispinterface\r\n ['{FB7A5FF4-CFA8-3F24-AD5F-D5EB39359707}']\r\n end;\r\n {$EXTERNALSYM _RSAPKCS1SignatureFormatterDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _Rijndael\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {21B52A91-856F-373C-AD42-4CF3F1021F5A}\r\n// *********************************************************************//\r\n _Rijndael = interface(IDispatch)\r\n ['{21B52A91-856F-373C-AD42-4CF3F1021F5A}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _RijndaelDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {21B52A91-856F-373C-AD42-4CF3F1021F5A}\r\n// *********************************************************************//\r\n _RijndaelDisp = dispinterface\r\n ['{21B52A91-856F-373C-AD42-4CF3F1021F5A}']\r\n end;\r\n {$EXTERNALSYM _RijndaelDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _RijndaelManaged\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {427EA9D3-11D8-3E38-9E05-A4F7FA684183}\r\n// *********************************************************************//\r\n _RijndaelManaged = interface(IDispatch)\r\n ['{427EA9D3-11D8-3E38-9E05-A4F7FA684183}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _RijndaelManagedDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {427EA9D3-11D8-3E38-9E05-A4F7FA684183}\r\n// *********************************************************************//\r\n _RijndaelManagedDisp = dispinterface\r\n ['{427EA9D3-11D8-3E38-9E05-A4F7FA684183}']\r\n end;\r\n {$EXTERNALSYM _RijndaelManagedDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _SHA1\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {48600DD2-0099-337F-92D6-961D1E5010D4}\r\n// *********************************************************************//\r\n _SHA1 = interface(IDispatch)\r\n ['{48600DD2-0099-337F-92D6-961D1E5010D4}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _SHA1Disp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {48600DD2-0099-337F-92D6-961D1E5010D4}\r\n// *********************************************************************//\r\n _SHA1Disp = dispinterface\r\n ['{48600DD2-0099-337F-92D6-961D1E5010D4}']\r\n end;\r\n {$EXTERNALSYM _SHA1Disp}\r\n\r\n// *********************************************************************//\r\n// Interface: _SHA1CryptoServiceProvider\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {A16537BC-1EDF-3516-B75E-CC65CAF873AB}\r\n// *********************************************************************//\r\n _SHA1CryptoServiceProvider = interface(IDispatch)\r\n ['{A16537BC-1EDF-3516-B75E-CC65CAF873AB}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _SHA1CryptoServiceProviderDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {A16537BC-1EDF-3516-B75E-CC65CAF873AB}\r\n// *********************************************************************//\r\n _SHA1CryptoServiceProviderDisp = dispinterface\r\n ['{A16537BC-1EDF-3516-B75E-CC65CAF873AB}']\r\n end;\r\n {$EXTERNALSYM _SHA1CryptoServiceProviderDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _SHA1Managed\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {C27990BB-3CFD-3D29-8DC0-BBE5FBADEAFD}\r\n// *********************************************************************//\r\n _SHA1Managed = interface(IDispatch)\r\n ['{C27990BB-3CFD-3D29-8DC0-BBE5FBADEAFD}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _SHA1ManagedDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {C27990BB-3CFD-3D29-8DC0-BBE5FBADEAFD}\r\n// *********************************************************************//\r\n _SHA1ManagedDisp = dispinterface\r\n ['{C27990BB-3CFD-3D29-8DC0-BBE5FBADEAFD}']\r\n end;\r\n {$EXTERNALSYM _SHA1ManagedDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _SHA256\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {3B274703-DFAE-3F9C-A1B5-9990DF9D7FA3}\r\n// *********************************************************************//\r\n _SHA256 = interface(IDispatch)\r\n ['{3B274703-DFAE-3F9C-A1B5-9990DF9D7FA3}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _SHA256Disp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {3B274703-DFAE-3F9C-A1B5-9990DF9D7FA3}\r\n// *********************************************************************//\r\n _SHA256Disp = dispinterface\r\n ['{3B274703-DFAE-3F9C-A1B5-9990DF9D7FA3}']\r\n end;\r\n {$EXTERNALSYM _SHA256Disp}\r\n\r\n// *********************************************************************//\r\n// Interface: _SHA256Managed\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {3D077954-7BCC-325B-9DDA-3B17A03378E0}\r\n// *********************************************************************//\r\n _SHA256Managed = interface(IDispatch)\r\n ['{3D077954-7BCC-325B-9DDA-3B17A03378E0}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _SHA256ManagedDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {3D077954-7BCC-325B-9DDA-3B17A03378E0}\r\n// *********************************************************************//\r\n _SHA256ManagedDisp = dispinterface\r\n ['{3D077954-7BCC-325B-9DDA-3B17A03378E0}']\r\n end;\r\n {$EXTERNALSYM _SHA256ManagedDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _SHA384\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {B60AD5D7-2C2E-35B7-8D77-7946156CFE8E}\r\n// *********************************************************************//\r\n _SHA384 = interface(IDispatch)\r\n ['{B60AD5D7-2C2E-35B7-8D77-7946156CFE8E}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _SHA384Disp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {B60AD5D7-2C2E-35B7-8D77-7946156CFE8E}\r\n// *********************************************************************//\r\n _SHA384Disp = dispinterface\r\n ['{B60AD5D7-2C2E-35B7-8D77-7946156CFE8E}']\r\n end;\r\n {$EXTERNALSYM _SHA384Disp}\r\n\r\n// *********************************************************************//\r\n// Interface: _SHA384Managed\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {DE541460-F838-3698-B2DA-510B09070118}\r\n// *********************************************************************//\r\n _SHA384Managed = interface(IDispatch)\r\n ['{DE541460-F838-3698-B2DA-510B09070118}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _SHA384ManagedDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {DE541460-F838-3698-B2DA-510B09070118}\r\n// *********************************************************************//\r\n _SHA384ManagedDisp = dispinterface\r\n ['{DE541460-F838-3698-B2DA-510B09070118}']\r\n end;\r\n {$EXTERNALSYM _SHA384ManagedDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _SHA512\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {49DD9E4B-84F3-3D6D-91FB-3FEDCEF634C7}\r\n// *********************************************************************//\r\n _SHA512 = interface(IDispatch)\r\n ['{49DD9E4B-84F3-3D6D-91FB-3FEDCEF634C7}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _SHA512Disp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {49DD9E4B-84F3-3D6D-91FB-3FEDCEF634C7}\r\n// *********************************************************************//\r\n _SHA512Disp = dispinterface\r\n ['{49DD9E4B-84F3-3D6D-91FB-3FEDCEF634C7}']\r\n end;\r\n {$EXTERNALSYM _SHA512Disp}\r\n\r\n// *********************************************************************//\r\n// Interface: _SHA512Managed\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {DC8CE439-7954-36ED-803C-674F72F27249}\r\n// *********************************************************************//\r\n _SHA512Managed = interface(IDispatch)\r\n ['{DC8CE439-7954-36ED-803C-674F72F27249}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _SHA512ManagedDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {DC8CE439-7954-36ED-803C-674F72F27249}\r\n// *********************************************************************//\r\n _SHA512ManagedDisp = dispinterface\r\n ['{DC8CE439-7954-36ED-803C-674F72F27249}']\r\n end;\r\n {$EXTERNALSYM _SHA512ManagedDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _SignatureDescription\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {8017B414-4886-33DA-80A3-7865C1350D43}\r\n// *********************************************************************//\r\n _SignatureDescription = interface(IDispatch)\r\n ['{8017B414-4886-33DA-80A3-7865C1350D43}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _SignatureDescriptionDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {8017B414-4886-33DA-80A3-7865C1350D43}\r\n// *********************************************************************//\r\n _SignatureDescriptionDisp = dispinterface\r\n ['{8017B414-4886-33DA-80A3-7865C1350D43}']\r\n end;\r\n {$EXTERNALSYM _SignatureDescriptionDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _TripleDES\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {C040B889-5278-3132-AFF9-AFA61707A81D}\r\n// *********************************************************************//\r\n _TripleDES = interface(IDispatch)\r\n ['{C040B889-5278-3132-AFF9-AFA61707A81D}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _TripleDESDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {C040B889-5278-3132-AFF9-AFA61707A81D}\r\n// *********************************************************************//\r\n _TripleDESDisp = dispinterface\r\n ['{C040B889-5278-3132-AFF9-AFA61707A81D}']\r\n end;\r\n {$EXTERNALSYM _TripleDESDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _TripleDESCryptoServiceProvider\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {EC69D083-3CD0-3C0C-998C-3B738DB535D5}\r\n// *********************************************************************//\r\n _TripleDESCryptoServiceProvider = interface(IDispatch)\r\n ['{EC69D083-3CD0-3C0C-998C-3B738DB535D5}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _TripleDESCryptoServiceProviderDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {EC69D083-3CD0-3C0C-998C-3B738DB535D5}\r\n// *********************************************************************//\r\n _TripleDESCryptoServiceProviderDisp = dispinterface\r\n ['{EC69D083-3CD0-3C0C-998C-3B738DB535D5}']\r\n end;\r\n {$EXTERNALSYM _TripleDESCryptoServiceProviderDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: ISecurityEncodable\r\n// Flags: (4416) Dual OleAutomation Dispatchable\r\n// GUID: {FD46BDE5-ACDF-3CA5-B189-F0678387077F}\r\n// *********************************************************************//\r\n ISecurityEncodable = interface(IDispatch)\r\n ['{FD46BDE5-ACDF-3CA5-B189-F0678387077F}']\r\n function ToXml: _SecurityElement; safecall;\r\n procedure FromXml(const e: _SecurityElement); safecall;\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: ISecurityEncodableDisp\r\n// Flags: (4416) Dual OleAutomation Dispatchable\r\n// GUID: {FD46BDE5-ACDF-3CA5-B189-F0678387077F}\r\n// *********************************************************************//\r\n ISecurityEncodableDisp = dispinterface\r\n ['{FD46BDE5-ACDF-3CA5-B189-F0678387077F}']\r\n function ToXml: _SecurityElement; dispid 1610743808;\r\n procedure FromXml(const e: _SecurityElement); dispid 1610743809;\r\n end;\r\n {$EXTERNALSYM ISecurityEncodableDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: ISecurityPolicyEncodable\r\n// Flags: (4416) Dual OleAutomation Dispatchable\r\n// GUID: {E6C21BA7-21BB-34E9-8E57-DB66D8CE4A70}\r\n// *********************************************************************//\r\n ISecurityPolicyEncodable = interface(IDispatch)\r\n ['{E6C21BA7-21BB-34E9-8E57-DB66D8CE4A70}']\r\n function ToXml(const level: _PolicyLevel): _SecurityElement; safecall;\r\n procedure FromXml(const e: _SecurityElement; const level: _PolicyLevel); safecall;\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: ISecurityPolicyEncodableDisp\r\n// Flags: (4416) Dual OleAutomation Dispatchable\r\n// GUID: {E6C21BA7-21BB-34E9-8E57-DB66D8CE4A70}\r\n// *********************************************************************//\r\n ISecurityPolicyEncodableDisp = dispinterface\r\n ['{E6C21BA7-21BB-34E9-8E57-DB66D8CE4A70}']\r\n function ToXml(const level: _PolicyLevel): _SecurityElement; dispid 1610743808;\r\n procedure FromXml(const e: _SecurityElement; const level: _PolicyLevel); dispid 1610743809;\r\n end;\r\n {$EXTERNALSYM ISecurityPolicyEncodableDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: IMembershipCondition\r\n// Flags: (4416) Dual OleAutomation Dispatchable\r\n// GUID: {6844EFF4-4F86-3CA1-A1EA-AAF583A6395E}\r\n// *********************************************************************//\r\n IMembershipCondition = interface(IDispatch)\r\n ['{6844EFF4-4F86-3CA1-A1EA-AAF583A6395E}']\r\n function Check(const Evidence: _Evidence): WordBool; safecall;\r\n function Copy: IMembershipCondition; safecall;\r\n function Get_ToString: WideString; safecall;\r\n function Equals(obj: OleVariant): WordBool; safecall;\r\n property ToString: WideString read Get_ToString;\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: IMembershipConditionDisp\r\n// Flags: (4416) Dual OleAutomation Dispatchable\r\n// GUID: {6844EFF4-4F86-3CA1-A1EA-AAF583A6395E}\r\n// *********************************************************************//\r\n IMembershipConditionDisp = dispinterface\r\n ['{6844EFF4-4F86-3CA1-A1EA-AAF583A6395E}']\r\n function Check(const Evidence: _Evidence): WordBool; dispid 1610743808;\r\n function Copy: IMembershipCondition; dispid 1610743809;\r\n property ToString: WideString readonly dispid 0;\r\n function Equals(obj: OleVariant): WordBool; dispid 1610743811;\r\n end;\r\n {$EXTERNALSYM IMembershipConditionDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _AllMembershipCondition\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {99F01720-3CC2-366D-9AB9-50E36647617F}\r\n// *********************************************************************//\r\n _AllMembershipCondition = interface(IDispatch)\r\n ['{99F01720-3CC2-366D-9AB9-50E36647617F}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _AllMembershipConditionDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {99F01720-3CC2-366D-9AB9-50E36647617F}\r\n// *********************************************************************//\r\n _AllMembershipConditionDisp = dispinterface\r\n ['{99F01720-3CC2-366D-9AB9-50E36647617F}']\r\n end;\r\n {$EXTERNALSYM _AllMembershipConditionDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _ApplicationDirectory\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {9CCC831B-1BA7-34BE-A966-56D5A6DB5AAD}\r\n// *********************************************************************//\r\n _ApplicationDirectory = interface(IDispatch)\r\n ['{9CCC831B-1BA7-34BE-A966-56D5A6DB5AAD}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _ApplicationDirectoryDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {9CCC831B-1BA7-34BE-A966-56D5A6DB5AAD}\r\n// *********************************************************************//\r\n _ApplicationDirectoryDisp = dispinterface\r\n ['{9CCC831B-1BA7-34BE-A966-56D5A6DB5AAD}']\r\n end;\r\n {$EXTERNALSYM _ApplicationDirectoryDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _ApplicationDirectoryMembershipCondition\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {A02A2B22-1DBA-3F92-9F84-5563182851BB}\r\n// *********************************************************************//\r\n _ApplicationDirectoryMembershipCondition = interface(IDispatch)\r\n ['{A02A2B22-1DBA-3F92-9F84-5563182851BB}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _ApplicationDirectoryMembershipConditionDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {A02A2B22-1DBA-3F92-9F84-5563182851BB}\r\n// *********************************************************************//\r\n _ApplicationDirectoryMembershipConditionDisp = dispinterface\r\n ['{A02A2B22-1DBA-3F92-9F84-5563182851BB}']\r\n end;\r\n {$EXTERNALSYM _ApplicationDirectoryMembershipConditionDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _CodeGroup\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {D7093F61-ED6B-343F-B1E9-02472FCC710E}\r\n// *********************************************************************//\r\n _CodeGroup = interface(IDispatch)\r\n ['{D7093F61-ED6B-343F-B1E9-02472FCC710E}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _CodeGroupDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {D7093F61-ED6B-343F-B1E9-02472FCC710E}\r\n// *********************************************************************//\r\n _CodeGroupDisp = dispinterface\r\n ['{D7093F61-ED6B-343F-B1E9-02472FCC710E}']\r\n end;\r\n {$EXTERNALSYM _CodeGroupDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _Evidence\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {A505EDBC-380E-3B23-9E1A-0974D4EF02EF}\r\n// *********************************************************************//\r\n _Evidence = interface(IDispatch)\r\n ['{A505EDBC-380E-3B23-9E1A-0974D4EF02EF}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _EvidenceDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {A505EDBC-380E-3B23-9E1A-0974D4EF02EF}\r\n// *********************************************************************//\r\n _EvidenceDisp = dispinterface\r\n ['{A505EDBC-380E-3B23-9E1A-0974D4EF02EF}']\r\n end;\r\n {$EXTERNALSYM _EvidenceDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _FileCodeGroup\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {DFAD74DC-8390-32F6-9612-1BD293B233F4}\r\n// *********************************************************************//\r\n _FileCodeGroup = interface(IDispatch)\r\n ['{DFAD74DC-8390-32F6-9612-1BD293B233F4}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _FileCodeGroupDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {DFAD74DC-8390-32F6-9612-1BD293B233F4}\r\n// *********************************************************************//\r\n _FileCodeGroupDisp = dispinterface\r\n ['{DFAD74DC-8390-32F6-9612-1BD293B233F4}']\r\n end;\r\n {$EXTERNALSYM _FileCodeGroupDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _FirstMatchCodeGroup\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {54B0AFB1-E7D3-3770-BB0E-75A95E8D2656}\r\n// *********************************************************************//\r\n _FirstMatchCodeGroup = interface(IDispatch)\r\n ['{54B0AFB1-E7D3-3770-BB0E-75A95E8D2656}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _FirstMatchCodeGroupDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {54B0AFB1-E7D3-3770-BB0E-75A95E8D2656}\r\n// *********************************************************************//\r\n _FirstMatchCodeGroupDisp = dispinterface\r\n ['{54B0AFB1-E7D3-3770-BB0E-75A95E8D2656}']\r\n end;\r\n {$EXTERNALSYM _FirstMatchCodeGroupDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _Hash\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {7574E121-74A6-3626-B578-0783BADB19D2}\r\n// *********************************************************************//\r\n _Hash = interface(IDispatch)\r\n ['{7574E121-74A6-3626-B578-0783BADB19D2}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _HashDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {7574E121-74A6-3626-B578-0783BADB19D2}\r\n// *********************************************************************//\r\n _HashDisp = dispinterface\r\n ['{7574E121-74A6-3626-B578-0783BADB19D2}']\r\n end;\r\n {$EXTERNALSYM _HashDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _HashMembershipCondition\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {6BA6EA7A-C9FC-3E73-82EC-18F29D83EEFD}\r\n// *********************************************************************//\r\n _HashMembershipCondition = interface(IDispatch)\r\n ['{6BA6EA7A-C9FC-3E73-82EC-18F29D83EEFD}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _HashMembershipConditionDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {6BA6EA7A-C9FC-3E73-82EC-18F29D83EEFD}\r\n// *********************************************************************//\r\n _HashMembershipConditionDisp = dispinterface\r\n ['{6BA6EA7A-C9FC-3E73-82EC-18F29D83EEFD}']\r\n end;\r\n {$EXTERNALSYM _HashMembershipConditionDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: IIdentityPermissionFactory\r\n// Flags: (4416) Dual OleAutomation Dispatchable\r\n// GUID: {4E95244E-C6FC-3A86-8DB7-1712454DE3B6}\r\n// *********************************************************************//\r\n IIdentityPermissionFactory = interface(IDispatch)\r\n ['{4E95244E-C6FC-3A86-8DB7-1712454DE3B6}']\r\n function CreateIdentityPermission(const Evidence: _Evidence): IPermission; safecall;\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: IIdentityPermissionFactoryDisp\r\n// Flags: (4416) Dual OleAutomation Dispatchable\r\n// GUID: {4E95244E-C6FC-3A86-8DB7-1712454DE3B6}\r\n// *********************************************************************//\r\n IIdentityPermissionFactoryDisp = dispinterface\r\n ['{4E95244E-C6FC-3A86-8DB7-1712454DE3B6}']\r\n function CreateIdentityPermission(const Evidence: _Evidence): IPermission; dispid 1610743808;\r\n end;\r\n {$EXTERNALSYM IIdentityPermissionFactoryDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _NetCodeGroup\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {A8F69ECA-8C48-3B5E-92A1-654925058059}\r\n// *********************************************************************//\r\n _NetCodeGroup = interface(IDispatch)\r\n ['{A8F69ECA-8C48-3B5E-92A1-654925058059}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _NetCodeGroupDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {A8F69ECA-8C48-3B5E-92A1-654925058059}\r\n// *********************************************************************//\r\n _NetCodeGroupDisp = dispinterface\r\n ['{A8F69ECA-8C48-3B5E-92A1-654925058059}']\r\n end;\r\n {$EXTERNALSYM _NetCodeGroupDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _PermissionRequestEvidence\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {34B0417E-E71D-304C-9FAC-689350A1B41C}\r\n// *********************************************************************//\r\n _PermissionRequestEvidence = interface(IDispatch)\r\n ['{34B0417E-E71D-304C-9FAC-689350A1B41C}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _PermissionRequestEvidenceDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {34B0417E-E71D-304C-9FAC-689350A1B41C}\r\n// *********************************************************************//\r\n _PermissionRequestEvidenceDisp = dispinterface\r\n ['{34B0417E-E71D-304C-9FAC-689350A1B41C}']\r\n end;\r\n {$EXTERNALSYM _PermissionRequestEvidenceDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _PolicyException\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {A9C9F3D9-E153-39B8-A533-B8DF4664407B}\r\n// *********************************************************************//\r\n _PolicyException = interface(IDispatch)\r\n ['{A9C9F3D9-E153-39B8-A533-B8DF4664407B}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _PolicyExceptionDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {A9C9F3D9-E153-39B8-A533-B8DF4664407B}\r\n// *********************************************************************//\r\n _PolicyExceptionDisp = dispinterface\r\n ['{A9C9F3D9-E153-39B8-A533-B8DF4664407B}']\r\n end;\r\n {$EXTERNALSYM _PolicyExceptionDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _PolicyLevel\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {44494E35-C370-3014-BC78-0F2ECBF83F53}\r\n// *********************************************************************//\r\n _PolicyLevel = interface(IDispatch)\r\n ['{44494E35-C370-3014-BC78-0F2ECBF83F53}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _PolicyLevelDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {44494E35-C370-3014-BC78-0F2ECBF83F53}\r\n// *********************************************************************//\r\n _PolicyLevelDisp = dispinterface\r\n ['{44494E35-C370-3014-BC78-0F2ECBF83F53}']\r\n end;\r\n {$EXTERNALSYM _PolicyLevelDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _PolicyStatement\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {3EEFD1FC-4D8D-3177-99F6-6C19D9E088D3}\r\n// *********************************************************************//\r\n _PolicyStatement = interface(IDispatch)\r\n ['{3EEFD1FC-4D8D-3177-99F6-6C19D9E088D3}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _PolicyStatementDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {3EEFD1FC-4D8D-3177-99F6-6C19D9E088D3}\r\n// *********************************************************************//\r\n _PolicyStatementDisp = dispinterface\r\n ['{3EEFD1FC-4D8D-3177-99F6-6C19D9E088D3}']\r\n end;\r\n {$EXTERNALSYM _PolicyStatementDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _Publisher\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {77CCA693-ABF6-3773-BF58-C0B02701A744}\r\n// *********************************************************************//\r\n _Publisher = interface(IDispatch)\r\n ['{77CCA693-ABF6-3773-BF58-C0B02701A744}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _PublisherDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {77CCA693-ABF6-3773-BF58-C0B02701A744}\r\n// *********************************************************************//\r\n _PublisherDisp = dispinterface\r\n ['{77CCA693-ABF6-3773-BF58-C0B02701A744}']\r\n end;\r\n {$EXTERNALSYM _PublisherDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _PublisherMembershipCondition\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {3515CF63-9863-3044-B3E1-210E98EFC702}\r\n// *********************************************************************//\r\n _PublisherMembershipCondition = interface(IDispatch)\r\n ['{3515CF63-9863-3044-B3E1-210E98EFC702}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _PublisherMembershipConditionDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {3515CF63-9863-3044-B3E1-210E98EFC702}\r\n// *********************************************************************//\r\n _PublisherMembershipConditionDisp = dispinterface\r\n ['{3515CF63-9863-3044-B3E1-210E98EFC702}']\r\n end;\r\n {$EXTERNALSYM _PublisherMembershipConditionDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _Site\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {90C40B4C-B0D0-30F5-B520-FDBA97BC31A0}\r\n// *********************************************************************//\r\n _Site = interface(IDispatch)\r\n ['{90C40B4C-B0D0-30F5-B520-FDBA97BC31A0}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _SiteDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {90C40B4C-B0D0-30F5-B520-FDBA97BC31A0}\r\n// *********************************************************************//\r\n _SiteDisp = dispinterface\r\n ['{90C40B4C-B0D0-30F5-B520-FDBA97BC31A0}']\r\n end;\r\n {$EXTERNALSYM _SiteDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _SiteMembershipCondition\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {0A7C3542-8031-3593-872C-78D85D7CC273}\r\n// *********************************************************************//\r\n _SiteMembershipCondition = interface(IDispatch)\r\n ['{0A7C3542-8031-3593-872C-78D85D7CC273}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _SiteMembershipConditionDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {0A7C3542-8031-3593-872C-78D85D7CC273}\r\n// *********************************************************************//\r\n _SiteMembershipConditionDisp = dispinterface\r\n ['{0A7C3542-8031-3593-872C-78D85D7CC273}']\r\n end;\r\n {$EXTERNALSYM _SiteMembershipConditionDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _StrongName\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {2A75C1FD-06B0-3CBB-B467-2545D4D6C865}\r\n// *********************************************************************//\r\n _StrongName = interface(IDispatch)\r\n ['{2A75C1FD-06B0-3CBB-B467-2545D4D6C865}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _StrongNameDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {2A75C1FD-06B0-3CBB-B467-2545D4D6C865}\r\n// *********************************************************************//\r\n _StrongNameDisp = dispinterface\r\n ['{2A75C1FD-06B0-3CBB-B467-2545D4D6C865}']\r\n end;\r\n {$EXTERNALSYM _StrongNameDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _StrongNameMembershipCondition\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {579E93BC-FFAB-3B8D-9181-CE9C22B51915}\r\n// *********************************************************************//\r\n _StrongNameMembershipCondition = interface(IDispatch)\r\n ['{579E93BC-FFAB-3B8D-9181-CE9C22B51915}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _StrongNameMembershipConditionDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {579E93BC-FFAB-3B8D-9181-CE9C22B51915}\r\n// *********************************************************************//\r\n _StrongNameMembershipConditionDisp = dispinterface\r\n ['{579E93BC-FFAB-3B8D-9181-CE9C22B51915}']\r\n end;\r\n {$EXTERNALSYM _StrongNameMembershipConditionDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _UnionCodeGroup\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {D9D822DE-44E5-33CE-A43F-173E475CECB1}\r\n// *********************************************************************//\r\n _UnionCodeGroup = interface(IDispatch)\r\n ['{D9D822DE-44E5-33CE-A43F-173E475CECB1}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _UnionCodeGroupDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {D9D822DE-44E5-33CE-A43F-173E475CECB1}\r\n// *********************************************************************//\r\n _UnionCodeGroupDisp = dispinterface\r\n ['{D9D822DE-44E5-33CE-A43F-173E475CECB1}']\r\n end;\r\n {$EXTERNALSYM _UnionCodeGroupDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _Url\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {D94ED9BF-C065-3703-81A2-2F76EA8E312F}\r\n// *********************************************************************//\r\n _Url = interface(IDispatch)\r\n ['{D94ED9BF-C065-3703-81A2-2F76EA8E312F}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _UrlDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {D94ED9BF-C065-3703-81A2-2F76EA8E312F}\r\n// *********************************************************************//\r\n _UrlDisp = dispinterface\r\n ['{D94ED9BF-C065-3703-81A2-2F76EA8E312F}']\r\n end;\r\n {$EXTERNALSYM _UrlDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _UrlMembershipCondition\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {BB7A158D-DBD9-3E13-B137-8E61E87E1128}\r\n// *********************************************************************//\r\n _UrlMembershipCondition = interface(IDispatch)\r\n ['{BB7A158D-DBD9-3E13-B137-8E61E87E1128}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _UrlMembershipConditionDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {BB7A158D-DBD9-3E13-B137-8E61E87E1128}\r\n// *********************************************************************//\r\n _UrlMembershipConditionDisp = dispinterface\r\n ['{BB7A158D-DBD9-3E13-B137-8E61E87E1128}']\r\n end;\r\n {$EXTERNALSYM _UrlMembershipConditionDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _Zone\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {742E0C26-0E23-3D20-968C-D221094909AA}\r\n// *********************************************************************//\r\n _Zone = interface(IDispatch)\r\n ['{742E0C26-0E23-3D20-968C-D221094909AA}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _ZoneDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {742E0C26-0E23-3D20-968C-D221094909AA}\r\n// *********************************************************************//\r\n _ZoneDisp = dispinterface\r\n ['{742E0C26-0E23-3D20-968C-D221094909AA}']\r\n end;\r\n {$EXTERNALSYM _ZoneDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _ZoneMembershipCondition\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {ADBC3463-0101-3429-A06C-DB2F1DD6B724}\r\n// *********************************************************************//\r\n _ZoneMembershipCondition = interface(IDispatch)\r\n ['{ADBC3463-0101-3429-A06C-DB2F1DD6B724}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _ZoneMembershipConditionDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {ADBC3463-0101-3429-A06C-DB2F1DD6B724}\r\n// *********************************************************************//\r\n _ZoneMembershipConditionDisp = dispinterface\r\n ['{ADBC3463-0101-3429-A06C-DB2F1DD6B724}']\r\n end;\r\n {$EXTERNALSYM _ZoneMembershipConditionDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: IIdentity\r\n// Flags: (4416) Dual OleAutomation Dispatchable\r\n// GUID: {F4205A87-4D46-303D-B1D9-5A99F7C90D30}\r\n// *********************************************************************//\r\n IIdentity = interface(IDispatch)\r\n ['{F4205A87-4D46-303D-B1D9-5A99F7C90D30}']\r\n function Get_name: WideString; safecall;\r\n function Get_AuthenticationType: WideString; safecall;\r\n function Get_IsAuthenticated: WordBool; safecall;\r\n property name: WideString read Get_name;\r\n property AuthenticationType: WideString read Get_AuthenticationType;\r\n property IsAuthenticated: WordBool read Get_IsAuthenticated;\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: IIdentityDisp\r\n// Flags: (4416) Dual OleAutomation Dispatchable\r\n// GUID: {F4205A87-4D46-303D-B1D9-5A99F7C90D30}\r\n// *********************************************************************//\r\n IIdentityDisp = dispinterface\r\n ['{F4205A87-4D46-303D-B1D9-5A99F7C90D30}']\r\n property name: WideString readonly dispid 1610743808;\r\n property AuthenticationType: WideString readonly dispid 1610743809;\r\n property IsAuthenticated: WordBool readonly dispid 1610743810;\r\n end;\r\n {$EXTERNALSYM IIdentityDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _GenericIdentity\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {9A37D8B2-2256-3FE3-8BF0-4FC421A1244F}\r\n// *********************************************************************//\r\n _GenericIdentity = interface(IDispatch)\r\n ['{9A37D8B2-2256-3FE3-8BF0-4FC421A1244F}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _GenericIdentityDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {9A37D8B2-2256-3FE3-8BF0-4FC421A1244F}\r\n// *********************************************************************//\r\n _GenericIdentityDisp = dispinterface\r\n ['{9A37D8B2-2256-3FE3-8BF0-4FC421A1244F}']\r\n end;\r\n {$EXTERNALSYM _GenericIdentityDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: IPrincipal\r\n// Flags: (4416) Dual OleAutomation Dispatchable\r\n// GUID: {4283CA6C-D291-3481-83C9-9554481FE888}\r\n// *********************************************************************//\r\n IPrincipal = interface(IDispatch)\r\n ['{4283CA6C-D291-3481-83C9-9554481FE888}']\r\n function Get_Identity: IIdentity; safecall;\r\n function IsInRole(const role: WideString): WordBool; safecall;\r\n property Identity: IIdentity read Get_Identity;\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: IPrincipalDisp\r\n// Flags: (4416) Dual OleAutomation Dispatchable\r\n// GUID: {4283CA6C-D291-3481-83C9-9554481FE888}\r\n// *********************************************************************//\r\n IPrincipalDisp = dispinterface\r\n ['{4283CA6C-D291-3481-83C9-9554481FE888}']\r\n property Identity: IIdentity readonly dispid 1610743808;\r\n function IsInRole(const role: WideString): WordBool; dispid 1610743809;\r\n end;\r\n {$EXTERNALSYM IPrincipalDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _GenericPrincipal\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {B4701C26-1509-3726-B2E1-409A636C9B4F}\r\n// *********************************************************************//\r\n _GenericPrincipal = interface(IDispatch)\r\n ['{B4701C26-1509-3726-B2E1-409A636C9B4F}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _GenericPrincipalDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {B4701C26-1509-3726-B2E1-409A636C9B4F}\r\n// *********************************************************************//\r\n _GenericPrincipalDisp = dispinterface\r\n ['{B4701C26-1509-3726-B2E1-409A636C9B4F}']\r\n end;\r\n {$EXTERNALSYM _GenericPrincipalDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _WindowsIdentity\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {D8CF3F23-1A66-3344-8230-07EB53970B85}\r\n// *********************************************************************//\r\n _WindowsIdentity = interface(IDispatch)\r\n ['{D8CF3F23-1A66-3344-8230-07EB53970B85}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _WindowsIdentityDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {D8CF3F23-1A66-3344-8230-07EB53970B85}\r\n// *********************************************************************//\r\n _WindowsIdentityDisp = dispinterface\r\n ['{D8CF3F23-1A66-3344-8230-07EB53970B85}']\r\n end;\r\n {$EXTERNALSYM _WindowsIdentityDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _WindowsImpersonationContext\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {60ECFDDA-650A-324C-B4B3-F4D75B563BB1}\r\n// *********************************************************************//\r\n _WindowsImpersonationContext = interface(IDispatch)\r\n ['{60ECFDDA-650A-324C-B4B3-F4D75B563BB1}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _WindowsImpersonationContextDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {60ECFDDA-650A-324C-B4B3-F4D75B563BB1}\r\n// *********************************************************************//\r\n _WindowsImpersonationContextDisp = dispinterface\r\n ['{60ECFDDA-650A-324C-B4B3-F4D75B563BB1}']\r\n end;\r\n {$EXTERNALSYM _WindowsImpersonationContextDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _WindowsPrincipal\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {6C42BAF9-1893-34FC-B3AF-06931E9B34A3}\r\n// *********************************************************************//\r\n _WindowsPrincipal = interface(IDispatch)\r\n ['{6C42BAF9-1893-34FC-B3AF-06931E9B34A3}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _WindowsPrincipalDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {6C42BAF9-1893-34FC-B3AF-06931E9B34A3}\r\n// *********************************************************************//\r\n _WindowsPrincipalDisp = dispinterface\r\n ['{6C42BAF9-1893-34FC-B3AF-06931E9B34A3}']\r\n end;\r\n {$EXTERNALSYM _WindowsPrincipalDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _DispIdAttribute\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {BBE41AC5-8692-3427-9AE1-C1058A38D492}\r\n// *********************************************************************//\r\n _DispIdAttribute = interface(IDispatch)\r\n ['{BBE41AC5-8692-3427-9AE1-C1058A38D492}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _DispIdAttributeDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {BBE41AC5-8692-3427-9AE1-C1058A38D492}\r\n// *********************************************************************//\r\n _DispIdAttributeDisp = dispinterface\r\n ['{BBE41AC5-8692-3427-9AE1-C1058A38D492}']\r\n end;\r\n {$EXTERNALSYM _DispIdAttributeDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _InterfaceTypeAttribute\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {A2145F38-CAC1-33DD-A318-21948AF6825D}\r\n// *********************************************************************//\r\n _InterfaceTypeAttribute = interface(IDispatch)\r\n ['{A2145F38-CAC1-33DD-A318-21948AF6825D}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _InterfaceTypeAttributeDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {A2145F38-CAC1-33DD-A318-21948AF6825D}\r\n// *********************************************************************//\r\n _InterfaceTypeAttributeDisp = dispinterface\r\n ['{A2145F38-CAC1-33DD-A318-21948AF6825D}']\r\n end;\r\n {$EXTERNALSYM _InterfaceTypeAttributeDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _ClassInterfaceAttribute\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {6B6391EE-842F-3E9A-8EEE-F13325E10996}\r\n// *********************************************************************//\r\n _ClassInterfaceAttribute = interface(IDispatch)\r\n ['{6B6391EE-842F-3E9A-8EEE-F13325E10996}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _ClassInterfaceAttributeDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {6B6391EE-842F-3E9A-8EEE-F13325E10996}\r\n// *********************************************************************//\r\n _ClassInterfaceAttributeDisp = dispinterface\r\n ['{6B6391EE-842F-3E9A-8EEE-F13325E10996}']\r\n end;\r\n {$EXTERNALSYM _ClassInterfaceAttributeDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _ComVisibleAttribute\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {1E7FFFE2-AAD9-34EE-8A9F-3C016B880FF0}\r\n// *********************************************************************//\r\n _ComVisibleAttribute = interface(IDispatch)\r\n ['{1E7FFFE2-AAD9-34EE-8A9F-3C016B880FF0}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _ComVisibleAttributeDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {1E7FFFE2-AAD9-34EE-8A9F-3C016B880FF0}\r\n// *********************************************************************//\r\n _ComVisibleAttributeDisp = dispinterface\r\n ['{1E7FFFE2-AAD9-34EE-8A9F-3C016B880FF0}']\r\n end;\r\n {$EXTERNALSYM _ComVisibleAttributeDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _LCIDConversionAttribute\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {4AB67927-3C86-328A-8186-F85357DD5527}\r\n// *********************************************************************//\r\n _LCIDConversionAttribute = interface(IDispatch)\r\n ['{4AB67927-3C86-328A-8186-F85357DD5527}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _LCIDConversionAttributeDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {4AB67927-3C86-328A-8186-F85357DD5527}\r\n// *********************************************************************//\r\n _LCIDConversionAttributeDisp = dispinterface\r\n ['{4AB67927-3C86-328A-8186-F85357DD5527}']\r\n end;\r\n {$EXTERNALSYM _LCIDConversionAttributeDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _ComRegisterFunctionAttribute\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {51BA926F-AAB5-3945-B8A6-C8F0F4A7D12B}\r\n// *********************************************************************//\r\n _ComRegisterFunctionAttribute = interface(IDispatch)\r\n ['{51BA926F-AAB5-3945-B8A6-C8F0F4A7D12B}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _ComRegisterFunctionAttributeDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {51BA926F-AAB5-3945-B8A6-C8F0F4A7D12B}\r\n// *********************************************************************//\r\n _ComRegisterFunctionAttributeDisp = dispinterface\r\n ['{51BA926F-AAB5-3945-B8A6-C8F0F4A7D12B}']\r\n end;\r\n {$EXTERNALSYM _ComRegisterFunctionAttributeDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _ComUnregisterFunctionAttribute\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {9F164188-34EB-3F86-9F74-0BBE4155E65E}\r\n// *********************************************************************//\r\n _ComUnregisterFunctionAttribute = interface(IDispatch)\r\n ['{9F164188-34EB-3F86-9F74-0BBE4155E65E}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _ComUnregisterFunctionAttributeDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {9F164188-34EB-3F86-9F74-0BBE4155E65E}\r\n// *********************************************************************//\r\n _ComUnregisterFunctionAttributeDisp = dispinterface\r\n ['{9F164188-34EB-3F86-9F74-0BBE4155E65E}']\r\n end;\r\n {$EXTERNALSYM _ComUnregisterFunctionAttributeDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _ProgIdAttribute\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {2B9F01DF-5A12-3688-98D6-C34BF5ED1865}\r\n// *********************************************************************//\r\n _ProgIdAttribute = interface(IDispatch)\r\n ['{2B9F01DF-5A12-3688-98D6-C34BF5ED1865}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _ProgIdAttributeDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {2B9F01DF-5A12-3688-98D6-C34BF5ED1865}\r\n// *********************************************************************//\r\n _ProgIdAttributeDisp = dispinterface\r\n ['{2B9F01DF-5A12-3688-98D6-C34BF5ED1865}']\r\n end;\r\n {$EXTERNALSYM _ProgIdAttributeDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _ImportedFromTypeLibAttribute\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {3F3311CE-6BAF-3FB0-B855-489AFF740B6E}\r\n// *********************************************************************//\r\n _ImportedFromTypeLibAttribute = interface(IDispatch)\r\n ['{3F3311CE-6BAF-3FB0-B855-489AFF740B6E}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _ImportedFromTypeLibAttributeDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {3F3311CE-6BAF-3FB0-B855-489AFF740B6E}\r\n// *********************************************************************//\r\n _ImportedFromTypeLibAttributeDisp = dispinterface\r\n ['{3F3311CE-6BAF-3FB0-B855-489AFF740B6E}']\r\n end;\r\n {$EXTERNALSYM _ImportedFromTypeLibAttributeDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _IDispatchImplAttribute\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {5778E7C7-2040-330E-B47A-92974DFFCFD4}\r\n// *********************************************************************//\r\n _IDispatchImplAttribute = interface(IDispatch)\r\n ['{5778E7C7-2040-330E-B47A-92974DFFCFD4}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _IDispatchImplAttributeDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {5778E7C7-2040-330E-B47A-92974DFFCFD4}\r\n// *********************************************************************//\r\n _IDispatchImplAttributeDisp = dispinterface\r\n ['{5778E7C7-2040-330E-B47A-92974DFFCFD4}']\r\n end;\r\n {$EXTERNALSYM _IDispatchImplAttributeDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _ComSourceInterfacesAttribute\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {E1984175-55F5-3065-82D8-A683FDFCF0AC}\r\n// *********************************************************************//\r\n _ComSourceInterfacesAttribute = interface(IDispatch)\r\n ['{E1984175-55F5-3065-82D8-A683FDFCF0AC}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _ComSourceInterfacesAttributeDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {E1984175-55F5-3065-82D8-A683FDFCF0AC}\r\n// *********************************************************************//\r\n _ComSourceInterfacesAttributeDisp = dispinterface\r\n ['{E1984175-55F5-3065-82D8-A683FDFCF0AC}']\r\n end;\r\n {$EXTERNALSYM _ComSourceInterfacesAttributeDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _ComConversionLossAttribute\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {FD5B6AAC-FF8C-3472-B894-CD6DFADB6939}\r\n// *********************************************************************//\r\n _ComConversionLossAttribute = interface(IDispatch)\r\n ['{FD5B6AAC-FF8C-3472-B894-CD6DFADB6939}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _ComConversionLossAttributeDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {FD5B6AAC-FF8C-3472-B894-CD6DFADB6939}\r\n// *********************************************************************//\r\n _ComConversionLossAttributeDisp = dispinterface\r\n ['{FD5B6AAC-FF8C-3472-B894-CD6DFADB6939}']\r\n end;\r\n {$EXTERNALSYM _ComConversionLossAttributeDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _TypeLibTypeAttribute\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {B5A1729E-B721-3121-A838-FDE43AF13468}\r\n// *********************************************************************//\r\n _TypeLibTypeAttribute = interface(IDispatch)\r\n ['{B5A1729E-B721-3121-A838-FDE43AF13468}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _TypeLibTypeAttributeDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {B5A1729E-B721-3121-A838-FDE43AF13468}\r\n// *********************************************************************//\r\n _TypeLibTypeAttributeDisp = dispinterface\r\n ['{B5A1729E-B721-3121-A838-FDE43AF13468}']\r\n end;\r\n {$EXTERNALSYM _TypeLibTypeAttributeDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _TypeLibFuncAttribute\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {3D18A8E2-EEDE-3139-B29D-8CAC057955DF}\r\n// *********************************************************************//\r\n _TypeLibFuncAttribute = interface(IDispatch)\r\n ['{3D18A8E2-EEDE-3139-B29D-8CAC057955DF}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _TypeLibFuncAttributeDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {3D18A8E2-EEDE-3139-B29D-8CAC057955DF}\r\n// *********************************************************************//\r\n _TypeLibFuncAttributeDisp = dispinterface\r\n ['{3D18A8E2-EEDE-3139-B29D-8CAC057955DF}']\r\n end;\r\n {$EXTERNALSYM _TypeLibFuncAttributeDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _TypeLibVarAttribute\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {7B89862A-02A4-3279-8B42-4095FA3A778E}\r\n// *********************************************************************//\r\n _TypeLibVarAttribute = interface(IDispatch)\r\n ['{7B89862A-02A4-3279-8B42-4095FA3A778E}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _TypeLibVarAttributeDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {7B89862A-02A4-3279-8B42-4095FA3A778E}\r\n// *********************************************************************//\r\n _TypeLibVarAttributeDisp = dispinterface\r\n ['{7B89862A-02A4-3279-8B42-4095FA3A778E}']\r\n end;\r\n {$EXTERNALSYM _TypeLibVarAttributeDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _MarshalAsAttribute\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {D858399F-E19E-3423-A720-AC12ABE2E5E8}\r\n// *********************************************************************//\r\n _MarshalAsAttribute = interface(IDispatch)\r\n ['{D858399F-E19E-3423-A720-AC12ABE2E5E8}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _MarshalAsAttributeDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {D858399F-E19E-3423-A720-AC12ABE2E5E8}\r\n// *********************************************************************//\r\n _MarshalAsAttributeDisp = dispinterface\r\n ['{D858399F-E19E-3423-A720-AC12ABE2E5E8}']\r\n end;\r\n {$EXTERNALSYM _MarshalAsAttributeDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _ComImportAttribute\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {1B093056-5454-386F-8971-BBCBC4E9A8F3}\r\n// *********************************************************************//\r\n _ComImportAttribute = interface(IDispatch)\r\n ['{1B093056-5454-386F-8971-BBCBC4E9A8F3}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _ComImportAttributeDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {1B093056-5454-386F-8971-BBCBC4E9A8F3}\r\n// *********************************************************************//\r\n _ComImportAttributeDisp = dispinterface\r\n ['{1B093056-5454-386F-8971-BBCBC4E9A8F3}']\r\n end;\r\n {$EXTERNALSYM _ComImportAttributeDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _GuidAttribute\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {74435DAD-EC55-354B-8F5B-FA70D13B6293}\r\n// *********************************************************************//\r\n _GuidAttribute = interface(IDispatch)\r\n ['{74435DAD-EC55-354B-8F5B-FA70D13B6293}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _GuidAttributeDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {74435DAD-EC55-354B-8F5B-FA70D13B6293}\r\n// *********************************************************************//\r\n _GuidAttributeDisp = dispinterface\r\n ['{74435DAD-EC55-354B-8F5B-FA70D13B6293}']\r\n end;\r\n {$EXTERNALSYM _GuidAttributeDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _PreserveSigAttribute\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {FDF2A2EE-C882-3198-A48B-E37F0E574DFA}\r\n// *********************************************************************//\r\n _PreserveSigAttribute = interface(IDispatch)\r\n ['{FDF2A2EE-C882-3198-A48B-E37F0E574DFA}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _PreserveSigAttributeDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {FDF2A2EE-C882-3198-A48B-E37F0E574DFA}\r\n// *********************************************************************//\r\n _PreserveSigAttributeDisp = dispinterface\r\n ['{FDF2A2EE-C882-3198-A48B-E37F0E574DFA}']\r\n end;\r\n {$EXTERNALSYM _PreserveSigAttributeDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _InAttribute\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {8474B65C-C39A-3D05-893D-577B9A314615}\r\n// *********************************************************************//\r\n _InAttribute = interface(IDispatch)\r\n ['{8474B65C-C39A-3D05-893D-577B9A314615}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _InAttributeDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {8474B65C-C39A-3D05-893D-577B9A314615}\r\n// *********************************************************************//\r\n _InAttributeDisp = dispinterface\r\n ['{8474B65C-C39A-3D05-893D-577B9A314615}']\r\n end;\r\n {$EXTERNALSYM _InAttributeDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _OutAttribute\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {0697FC8C-9B04-3783-95C7-45ECCAC1CA27}\r\n// *********************************************************************//\r\n _OutAttribute = interface(IDispatch)\r\n ['{0697FC8C-9B04-3783-95C7-45ECCAC1CA27}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _OutAttributeDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {0697FC8C-9B04-3783-95C7-45ECCAC1CA27}\r\n// *********************************************************************//\r\n _OutAttributeDisp = dispinterface\r\n ['{0697FC8C-9B04-3783-95C7-45ECCAC1CA27}']\r\n end;\r\n {$EXTERNALSYM _OutAttributeDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _OptionalAttribute\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {0D6BD9AD-198E-3904-AD99-F6F82A2787C4}\r\n// *********************************************************************//\r\n _OptionalAttribute = interface(IDispatch)\r\n ['{0D6BD9AD-198E-3904-AD99-F6F82A2787C4}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _OptionalAttributeDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {0D6BD9AD-198E-3904-AD99-F6F82A2787C4}\r\n// *********************************************************************//\r\n _OptionalAttributeDisp = dispinterface\r\n ['{0D6BD9AD-198E-3904-AD99-F6F82A2787C4}']\r\n end;\r\n {$EXTERNALSYM _OptionalAttributeDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _DllImportAttribute\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {A1A26181-D55E-3EE2-96E6-70B354EF9371}\r\n// *********************************************************************//\r\n _DllImportAttribute = interface(IDispatch)\r\n ['{A1A26181-D55E-3EE2-96E6-70B354EF9371}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _DllImportAttributeDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {A1A26181-D55E-3EE2-96E6-70B354EF9371}\r\n// *********************************************************************//\r\n _DllImportAttributeDisp = dispinterface\r\n ['{A1A26181-D55E-3EE2-96E6-70B354EF9371}']\r\n end;\r\n {$EXTERNALSYM _DllImportAttributeDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _StructLayoutAttribute\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {23753322-C7B3-3F9A-AC96-52672C1B1CA9}\r\n// *********************************************************************//\r\n _StructLayoutAttribute = interface(IDispatch)\r\n ['{23753322-C7B3-3F9A-AC96-52672C1B1CA9}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _StructLayoutAttributeDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {23753322-C7B3-3F9A-AC96-52672C1B1CA9}\r\n// *********************************************************************//\r\n _StructLayoutAttributeDisp = dispinterface\r\n ['{23753322-C7B3-3F9A-AC96-52672C1B1CA9}']\r\n end;\r\n {$EXTERNALSYM _StructLayoutAttributeDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _FieldOffsetAttribute\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {C14342B8-BAFD-322A-BB71-62C672DA284E}\r\n// *********************************************************************//\r\n _FieldOffsetAttribute = interface(IDispatch)\r\n ['{C14342B8-BAFD-322A-BB71-62C672DA284E}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _FieldOffsetAttributeDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {C14342B8-BAFD-322A-BB71-62C672DA284E}\r\n// *********************************************************************//\r\n _FieldOffsetAttributeDisp = dispinterface\r\n ['{C14342B8-BAFD-322A-BB71-62C672DA284E}']\r\n end;\r\n {$EXTERNALSYM _FieldOffsetAttributeDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _ComAliasNameAttribute\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {E78785C4-3A73-3C15-9390-618BF3A14719}\r\n// *********************************************************************//\r\n _ComAliasNameAttribute = interface(IDispatch)\r\n ['{E78785C4-3A73-3C15-9390-618BF3A14719}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _ComAliasNameAttributeDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {E78785C4-3A73-3C15-9390-618BF3A14719}\r\n// *********************************************************************//\r\n _ComAliasNameAttributeDisp = dispinterface\r\n ['{E78785C4-3A73-3C15-9390-618BF3A14719}']\r\n end;\r\n {$EXTERNALSYM _ComAliasNameAttributeDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _AutomationProxyAttribute\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {57B908A8-C082-3581-8A47-6B41B86E8FDC}\r\n// *********************************************************************//\r\n _AutomationProxyAttribute = interface(IDispatch)\r\n ['{57B908A8-C082-3581-8A47-6B41B86E8FDC}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _AutomationProxyAttributeDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {57B908A8-C082-3581-8A47-6B41B86E8FDC}\r\n// *********************************************************************//\r\n _AutomationProxyAttributeDisp = dispinterface\r\n ['{57B908A8-C082-3581-8A47-6B41B86E8FDC}']\r\n end;\r\n {$EXTERNALSYM _AutomationProxyAttributeDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _PrimaryInteropAssemblyAttribute\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {C69E96B2-6161-3621-B165-5805198C6B8D}\r\n// *********************************************************************//\r\n _PrimaryInteropAssemblyAttribute = interface(IDispatch)\r\n ['{C69E96B2-6161-3621-B165-5805198C6B8D}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _PrimaryInteropAssemblyAttributeDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {C69E96B2-6161-3621-B165-5805198C6B8D}\r\n// *********************************************************************//\r\n _PrimaryInteropAssemblyAttributeDisp = dispinterface\r\n ['{C69E96B2-6161-3621-B165-5805198C6B8D}']\r\n end;\r\n {$EXTERNALSYM _PrimaryInteropAssemblyAttributeDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _CoClassAttribute\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {15D54C00-7C95-38D7-B859-E19346677DCD}\r\n// *********************************************************************//\r\n _CoClassAttribute = interface(IDispatch)\r\n ['{15D54C00-7C95-38D7-B859-E19346677DCD}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _CoClassAttributeDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {15D54C00-7C95-38D7-B859-E19346677DCD}\r\n// *********************************************************************//\r\n _CoClassAttributeDisp = dispinterface\r\n ['{15D54C00-7C95-38D7-B859-E19346677DCD}']\r\n end;\r\n {$EXTERNALSYM _CoClassAttributeDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _ComEventInterfaceAttribute\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {76CC0491-9A10-35C0-8A66-7931EC345B7F}\r\n// *********************************************************************//\r\n _ComEventInterfaceAttribute = interface(IDispatch)\r\n ['{76CC0491-9A10-35C0-8A66-7931EC345B7F}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _ComEventInterfaceAttributeDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {76CC0491-9A10-35C0-8A66-7931EC345B7F}\r\n// *********************************************************************//\r\n _ComEventInterfaceAttributeDisp = dispinterface\r\n ['{76CC0491-9A10-35C0-8A66-7931EC345B7F}']\r\n end;\r\n {$EXTERNALSYM _ComEventInterfaceAttributeDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _TypeLibVersionAttribute\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {A03B61A4-CA61-3460-8232-2F4EC96AA88F}\r\n// *********************************************************************//\r\n _TypeLibVersionAttribute = interface(IDispatch)\r\n ['{A03B61A4-CA61-3460-8232-2F4EC96AA88F}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _TypeLibVersionAttributeDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {A03B61A4-CA61-3460-8232-2F4EC96AA88F}\r\n// *********************************************************************//\r\n _TypeLibVersionAttributeDisp = dispinterface\r\n ['{A03B61A4-CA61-3460-8232-2F4EC96AA88F}']\r\n end;\r\n {$EXTERNALSYM _TypeLibVersionAttributeDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _ComCompatibleVersionAttribute\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {AD419379-2AC8-3588-AB1E-0115413277C4}\r\n// *********************************************************************//\r\n _ComCompatibleVersionAttribute = interface(IDispatch)\r\n ['{AD419379-2AC8-3588-AB1E-0115413277C4}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _ComCompatibleVersionAttributeDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {AD419379-2AC8-3588-AB1E-0115413277C4}\r\n// *********************************************************************//\r\n _ComCompatibleVersionAttributeDisp = dispinterface\r\n ['{AD419379-2AC8-3588-AB1E-0115413277C4}']\r\n end;\r\n {$EXTERNALSYM _ComCompatibleVersionAttributeDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _BestFitMappingAttribute\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {ED47ABE7-C84B-39F9-BE1B-828CFB925AFE}\r\n// *********************************************************************//\r\n _BestFitMappingAttribute = interface(IDispatch)\r\n ['{ED47ABE7-C84B-39F9-BE1B-828CFB925AFE}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _BestFitMappingAttributeDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {ED47ABE7-C84B-39F9-BE1B-828CFB925AFE}\r\n// *********************************************************************//\r\n _BestFitMappingAttributeDisp = dispinterface\r\n ['{ED47ABE7-C84B-39F9-BE1B-828CFB925AFE}']\r\n end;\r\n {$EXTERNALSYM _BestFitMappingAttributeDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _ExternalException\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {A83F04E9-FD28-384A-9DFF-410688AC23AB}\r\n// *********************************************************************//\r\n _ExternalException = interface(IDispatch)\r\n ['{A83F04E9-FD28-384A-9DFF-410688AC23AB}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _ExternalExceptionDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {A83F04E9-FD28-384A-9DFF-410688AC23AB}\r\n// *********************************************************************//\r\n _ExternalExceptionDisp = dispinterface\r\n ['{A83F04E9-FD28-384A-9DFF-410688AC23AB}']\r\n end;\r\n {$EXTERNALSYM _ExternalExceptionDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _COMException\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {A28C19DF-B488-34AE-BECC-7DE744D17F7B}\r\n// *********************************************************************//\r\n _COMException = interface(IDispatch)\r\n ['{A28C19DF-B488-34AE-BECC-7DE744D17F7B}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _COMExceptionDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {A28C19DF-B488-34AE-BECC-7DE744D17F7B}\r\n// *********************************************************************//\r\n _COMExceptionDisp = dispinterface\r\n ['{A28C19DF-B488-34AE-BECC-7DE744D17F7B}']\r\n end;\r\n {$EXTERNALSYM _COMExceptionDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _CurrencyWrapper\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {7DF6F279-DA62-3C9F-8944-4DD3C0F08170}\r\n// *********************************************************************//\r\n _CurrencyWrapper = interface(IDispatch)\r\n ['{7DF6F279-DA62-3C9F-8944-4DD3C0F08170}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _CurrencyWrapperDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {7DF6F279-DA62-3C9F-8944-4DD3C0F08170}\r\n// *********************************************************************//\r\n _CurrencyWrapperDisp = dispinterface\r\n ['{7DF6F279-DA62-3C9F-8944-4DD3C0F08170}']\r\n end;\r\n {$EXTERNALSYM _CurrencyWrapperDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _DispatchWrapper\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {72103C67-D511-329C-B19A-DD5EC3F1206C}\r\n// *********************************************************************//\r\n _DispatchWrapper = interface(IDispatch)\r\n ['{72103C67-D511-329C-B19A-DD5EC3F1206C}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _DispatchWrapperDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {72103C67-D511-329C-B19A-DD5EC3F1206C}\r\n// *********************************************************************//\r\n _DispatchWrapperDisp = dispinterface\r\n ['{72103C67-D511-329C-B19A-DD5EC3F1206C}']\r\n end;\r\n {$EXTERNALSYM _DispatchWrapperDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _ErrorWrapper\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {F79DB336-06BE-3959-A5AB-58B2AB6C5FD1}\r\n// *********************************************************************//\r\n _ErrorWrapper = interface(IDispatch)\r\n ['{F79DB336-06BE-3959-A5AB-58B2AB6C5FD1}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _ErrorWrapperDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {F79DB336-06BE-3959-A5AB-58B2AB6C5FD1}\r\n// *********************************************************************//\r\n _ErrorWrapperDisp = dispinterface\r\n ['{F79DB336-06BE-3959-A5AB-58B2AB6C5FD1}']\r\n end;\r\n {$EXTERNALSYM _ErrorWrapperDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _ExtensibleClassFactory\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {519EB857-7A2D-3A95-A2A3-8BB8ED63D41B}\r\n// *********************************************************************//\r\n _ExtensibleClassFactory = interface(IDispatch)\r\n ['{519EB857-7A2D-3A95-A2A3-8BB8ED63D41B}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _ExtensibleClassFactoryDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {519EB857-7A2D-3A95-A2A3-8BB8ED63D41B}\r\n// *********************************************************************//\r\n _ExtensibleClassFactoryDisp = dispinterface\r\n ['{519EB857-7A2D-3A95-A2A3-8BB8ED63D41B}']\r\n end;\r\n {$EXTERNALSYM _ExtensibleClassFactoryDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: ICustomAdapter\r\n// Flags: (4416) Dual OleAutomation Dispatchable\r\n// GUID: {3CC86595-FEB5-3CE9-BA14-D05C8DC3321C}\r\n// *********************************************************************//\r\n ICustomAdapter = interface(IDispatch)\r\n ['{3CC86595-FEB5-3CE9-BA14-D05C8DC3321C}']\r\n function GetUnderlyingObject: IUnknown; safecall;\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: ICustomAdapterDisp\r\n// Flags: (4416) Dual OleAutomation Dispatchable\r\n// GUID: {3CC86595-FEB5-3CE9-BA14-D05C8DC3321C}\r\n// *********************************************************************//\r\n ICustomAdapterDisp = dispinterface\r\n ['{3CC86595-FEB5-3CE9-BA14-D05C8DC3321C}']\r\n function GetUnderlyingObject: IUnknown; dispid 1610743808;\r\n end;\r\n {$EXTERNALSYM ICustomAdapterDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: ICustomMarshaler\r\n// Flags: (4416) Dual OleAutomation Dispatchable\r\n// GUID: {601CD486-04BF-3213-9EA9-06EBE4351D74}\r\n// *********************************************************************//\r\n ICustomMarshaler = interface(IDispatch)\r\n ['{601CD486-04BF-3213-9EA9-06EBE4351D74}']\r\n function MarshalNativeToManaged(pNativeData: Integer): OleVariant; safecall;\r\n function MarshalManagedToNative(ManagedObj: OleVariant): Integer; safecall;\r\n procedure CleanUpNativeData(pNativeData: Integer); safecall;\r\n procedure CleanUpManagedData(ManagedObj: OleVariant); safecall;\r\n function GetNativeDataSize: Integer; safecall;\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: ICustomMarshalerDisp\r\n// Flags: (4416) Dual OleAutomation Dispatchable\r\n// GUID: {601CD486-04BF-3213-9EA9-06EBE4351D74}\r\n// *********************************************************************//\r\n ICustomMarshalerDisp = dispinterface\r\n ['{601CD486-04BF-3213-9EA9-06EBE4351D74}']\r\n function MarshalNativeToManaged(pNativeData: Integer): OleVariant; dispid 1610743808;\r\n function MarshalManagedToNative(ManagedObj: OleVariant): Integer; dispid 1610743809;\r\n procedure CleanUpNativeData(pNativeData: Integer); dispid 1610743810;\r\n procedure CleanUpManagedData(ManagedObj: OleVariant); dispid 1610743811;\r\n function GetNativeDataSize: Integer; dispid 1610743812;\r\n end;\r\n {$EXTERNALSYM ICustomMarshalerDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: ICustomFactory\r\n// Flags: (4416) Dual OleAutomation Dispatchable\r\n// GUID: {0CA9008E-EE90-356E-9F6D-B59E6006B9A4}\r\n// *********************************************************************//\r\n ICustomFactory = interface(IDispatch)\r\n ['{0CA9008E-EE90-356E-9F6D-B59E6006B9A4}']\r\n function CreateInstance(const serverType: _Type): _MarshalByRefObject; safecall;\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: ICustomFactoryDisp\r\n// Flags: (4416) Dual OleAutomation Dispatchable\r\n// GUID: {0CA9008E-EE90-356E-9F6D-B59E6006B9A4}\r\n// *********************************************************************//\r\n ICustomFactoryDisp = dispinterface\r\n ['{0CA9008E-EE90-356E-9F6D-B59E6006B9A4}']\r\n function CreateInstance(const serverType: _Type): _MarshalByRefObject; dispid 1610743808;\r\n end;\r\n {$EXTERNALSYM ICustomFactoryDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _InvalidComObjectException\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {DE9156B5-5E7A-3041-BF45-A29A6C2CF48A}\r\n// *********************************************************************//\r\n _InvalidComObjectException = interface(IDispatch)\r\n ['{DE9156B5-5E7A-3041-BF45-A29A6C2CF48A}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _InvalidComObjectExceptionDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {DE9156B5-5E7A-3041-BF45-A29A6C2CF48A}\r\n// *********************************************************************//\r\n _InvalidComObjectExceptionDisp = dispinterface\r\n ['{DE9156B5-5E7A-3041-BF45-A29A6C2CF48A}']\r\n end;\r\n {$EXTERNALSYM _InvalidComObjectExceptionDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _InvalidOleVariantTypeException\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {76E5DBD6-F960-3C65-8EA6-FC8AD6A67022}\r\n// *********************************************************************//\r\n _InvalidOleVariantTypeException = interface(IDispatch)\r\n ['{76E5DBD6-F960-3C65-8EA6-FC8AD6A67022}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _InvalidOleVariantTypeExceptionDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {76E5DBD6-F960-3C65-8EA6-FC8AD6A67022}\r\n// *********************************************************************//\r\n _InvalidOleVariantTypeExceptionDisp = dispinterface\r\n ['{76E5DBD6-F960-3C65-8EA6-FC8AD6A67022}']\r\n end;\r\n {$EXTERNALSYM _InvalidOleVariantTypeExceptionDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: IRegistrationServices\r\n// Flags: (4416) Dual OleAutomation Dispatchable\r\n// GUID: {CCBD682C-73A5-4568-B8B0-C7007E11ABA2}\r\n// *********************************************************************//\r\n IRegistrationServices = interface(IDispatch)\r\n ['{CCBD682C-73A5-4568-B8B0-C7007E11ABA2}']\r\n function RegisterAssembly(const Assembly: _Assembly; flags: AssemblyRegistrationFlags): WordBool; safecall;\r\n function UnregisterAssembly(const Assembly: _Assembly): WordBool; safecall;\r\n function GetRegistrableTypesInAssembly(const Assembly: _Assembly): PSafeArray; safecall;\r\n function GetProgIdForType(const Type_: _Type): WideString; safecall;\r\n procedure RegisterTypeForComClients(const Type_: _Type; var G: TGUID); safecall;\r\n function GetManagedCategoryGuid: TGUID; safecall;\r\n function TypeRequiresRegistration(const Type_: _Type): WordBool; safecall;\r\n function TypeRepresentsComType(const Type_: _Type): WordBool; safecall;\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: IRegistrationServicesDisp\r\n// Flags: (4416) Dual OleAutomation Dispatchable\r\n// GUID: {CCBD682C-73A5-4568-B8B0-C7007E11ABA2}\r\n// *********************************************************************//\r\n IRegistrationServicesDisp = dispinterface\r\n ['{CCBD682C-73A5-4568-B8B0-C7007E11ABA2}']\r\n function RegisterAssembly(const Assembly: _Assembly; flags: AssemblyRegistrationFlags): WordBool; dispid 1610743808;\r\n function UnregisterAssembly(const Assembly: _Assembly): WordBool; dispid 1610743809;\r\n function GetRegistrableTypesInAssembly(const Assembly: _Assembly): {??PSafeArray}OleVariant; dispid 1610743810;\r\n function GetProgIdForType(const Type_: _Type): WideString; dispid 1610743811;\r\n procedure RegisterTypeForComClients(const Type_: _Type; var G: {??TGUID}OleVariant); dispid 1610743812;\r\n function GetManagedCategoryGuid: {??TGUID}OleVariant; dispid 1610743813;\r\n function TypeRequiresRegistration(const Type_: _Type): WordBool; dispid 1610743814;\r\n function TypeRepresentsComType(const Type_: _Type): WordBool; dispid 1610743815;\r\n end;\r\n {$EXTERNALSYM IRegistrationServicesDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: ITypeLibImporterNotifySink\r\n// Flags: (256) OleAutomation\r\n// GUID: {F1C3BF76-C3E4-11D3-88E7-00902754C43A}\r\n// *********************************************************************//\r\n ITypeLibImporterNotifySink = interface(IUnknown)\r\n ['{F1C3BF76-C3E4-11D3-88E7-00902754C43A}']\r\n function ReportEvent(eventKind: ImporterEventKind; eventCode: Integer; \r\n const eventMsg: WideString): HResult; stdcall;\r\n function ResolveRef(const typeLib: IUnknown; out pRetVal: _Assembly): HResult; stdcall;\r\n end;\r\n\r\n// *********************************************************************//\r\n// Interface: ITypeLibExporterNotifySink\r\n// Flags: (256) OleAutomation\r\n// GUID: {F1C3BF77-C3E4-11D3-88E7-00902754C43A}\r\n// *********************************************************************//\r\n ITypeLibExporterNotifySink = interface(IUnknown)\r\n ['{F1C3BF77-C3E4-11D3-88E7-00902754C43A}']\r\n function ReportEvent(eventKind: ExporterEventKind; eventCode: Integer; \r\n const eventMsg: WideString): HResult; stdcall;\r\n function ResolveRef(const Assembly: _Assembly; out pRetVal: IUnknown): HResult; stdcall;\r\n end;\r\n\r\n// *********************************************************************//\r\n// Interface: ITypeLibConverter\r\n// Flags: (256) OleAutomation\r\n// GUID: {F1C3BF78-C3E4-11D3-88E7-00902754C43A}\r\n// *********************************************************************//\r\n ITypeLibConverter = interface(IUnknown)\r\n ['{F1C3BF78-C3E4-11D3-88E7-00902754C43A}']\r\n function ConvertTypeLibToAssembly(const typeLib: IUnknown; const asmFileName: WideString; \r\n flags: TypeLibImporterFlags; \r\n const notifySink: ITypeLibImporterNotifySink; \r\n publicKey: PSafeArray; const keyPair: _StrongNameKeyPair; \r\n const asmNamespace: WideString; const asmVersion: _Version; \r\n out pRetVal: _AssemblyBuilder): HResult; stdcall;\r\n function ConvertAssemblyToTypeLib(const Assembly: _Assembly; const typeLibName: WideString; \r\n flags: TypeLibExporterFlags; \r\n const notifySink: ITypeLibExporterNotifySink; \r\n out pRetVal: IUnknown): HResult; stdcall;\r\n function GetPrimaryInteropAssembly(G: TGUID; major: Integer; minor: Integer; lcid: Integer; \r\n out asmName: WideString; out asmCodeBase: WideString; \r\n out pRetVal: WordBool): HResult; stdcall;\r\n function ConvertTypeLibToAssembly_2(const typeLib: IUnknown; const asmFileName: WideString; \r\n flags: Integer; \r\n const notifySink: ITypeLibImporterNotifySink; \r\n publicKey: PSafeArray; const keyPair: _StrongNameKeyPair; \r\n unsafeInterfaces: WordBool; out pRetVal: _AssemblyBuilder): HResult; stdcall;\r\n end;\r\n\r\n// *********************************************************************//\r\n// Interface: ITypeLibExporterNameProvider\r\n// Flags: (256) OleAutomation\r\n// GUID: {FA1F3615-ACB9-486D-9EAC-1BEF87E36B09}\r\n// *********************************************************************//\r\n ITypeLibExporterNameProvider = interface(IUnknown)\r\n ['{FA1F3615-ACB9-486D-9EAC-1BEF87E36B09}']\r\n function GetNames(out pRetVal: PSafeArray): HResult; stdcall;\r\n end;\r\n\r\n// *********************************************************************//\r\n// Interface: _Marshal\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {5F06D2F8-F3D4-3585-814C-2E886C465F25}\r\n// *********************************************************************//\r\n _Marshal = interface(IDispatch)\r\n ['{5F06D2F8-F3D4-3585-814C-2E886C465F25}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _MarshalDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {5F06D2F8-F3D4-3585-814C-2E886C465F25}\r\n// *********************************************************************//\r\n _MarshalDisp = dispinterface\r\n ['{5F06D2F8-F3D4-3585-814C-2E886C465F25}']\r\n end;\r\n {$EXTERNALSYM _MarshalDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _MarshalDirectiveException\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {523F42A5-1FD2-355D-82BF-0D67C4A0A0E7}\r\n// *********************************************************************//\r\n _MarshalDirectiveException = interface(IDispatch)\r\n ['{523F42A5-1FD2-355D-82BF-0D67C4A0A0E7}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _MarshalDirectiveExceptionDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {523F42A5-1FD2-355D-82BF-0D67C4A0A0E7}\r\n// *********************************************************************//\r\n _MarshalDirectiveExceptionDisp = dispinterface\r\n ['{523F42A5-1FD2-355D-82BF-0D67C4A0A0E7}']\r\n end;\r\n {$EXTERNALSYM _MarshalDirectiveExceptionDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _ObjectCreationDelegate\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {E4A369D3-6CF0-3B05-9C0C-1A91E331641A}\r\n// *********************************************************************//\r\n _ObjectCreationDelegate = interface(IDispatch)\r\n ['{E4A369D3-6CF0-3B05-9C0C-1A91E331641A}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _ObjectCreationDelegateDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {E4A369D3-6CF0-3B05-9C0C-1A91E331641A}\r\n// *********************************************************************//\r\n _ObjectCreationDelegateDisp = dispinterface\r\n ['{E4A369D3-6CF0-3B05-9C0C-1A91E331641A}']\r\n end;\r\n {$EXTERNALSYM _ObjectCreationDelegateDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _RuntimeEnvironment\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {EDCEE21A-3E3A-331E-A86D-274028BE6716}\r\n// *********************************************************************//\r\n _RuntimeEnvironment = interface(IDispatch)\r\n ['{EDCEE21A-3E3A-331E-A86D-274028BE6716}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _RuntimeEnvironmentDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {EDCEE21A-3E3A-331E-A86D-274028BE6716}\r\n// *********************************************************************//\r\n _RuntimeEnvironmentDisp = dispinterface\r\n ['{EDCEE21A-3E3A-331E-A86D-274028BE6716}']\r\n end;\r\n {$EXTERNALSYM _RuntimeEnvironmentDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _SafeArrayRankMismatchException\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {8608FE7B-2FDC-318A-B711-6F7B2FEDED06}\r\n// *********************************************************************//\r\n _SafeArrayRankMismatchException = interface(IDispatch)\r\n ['{8608FE7B-2FDC-318A-B711-6F7B2FEDED06}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _SafeArrayRankMismatchExceptionDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {8608FE7B-2FDC-318A-B711-6F7B2FEDED06}\r\n// *********************************************************************//\r\n _SafeArrayRankMismatchExceptionDisp = dispinterface\r\n ['{8608FE7B-2FDC-318A-B711-6F7B2FEDED06}']\r\n end;\r\n {$EXTERNALSYM _SafeArrayRankMismatchExceptionDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _SafeArrayTypeMismatchException\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {E093FB32-E43B-3B3F-A163-742C920C2AF3}\r\n// *********************************************************************//\r\n _SafeArrayTypeMismatchException = interface(IDispatch)\r\n ['{E093FB32-E43B-3B3F-A163-742C920C2AF3}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _SafeArrayTypeMismatchExceptionDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {E093FB32-E43B-3B3F-A163-742C920C2AF3}\r\n// *********************************************************************//\r\n _SafeArrayTypeMismatchExceptionDisp = dispinterface\r\n ['{E093FB32-E43B-3B3F-A163-742C920C2AF3}']\r\n end;\r\n {$EXTERNALSYM _SafeArrayTypeMismatchExceptionDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _SEHException\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {3E72E067-4C5E-36C8-BBEF-1E2978C7780D}\r\n// *********************************************************************//\r\n _SEHException = interface(IDispatch)\r\n ['{3E72E067-4C5E-36C8-BBEF-1E2978C7780D}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _SEHExceptionDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {3E72E067-4C5E-36C8-BBEF-1E2978C7780D}\r\n// *********************************************************************//\r\n _SEHExceptionDisp = dispinterface\r\n ['{3E72E067-4C5E-36C8-BBEF-1E2978C7780D}']\r\n end;\r\n {$EXTERNALSYM _SEHExceptionDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _UnknownWrapper\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {1C8D8B14-4589-3DCA-8E0F-A30E80FBD1A8}\r\n// *********************************************************************//\r\n _UnknownWrapper = interface(IDispatch)\r\n ['{1C8D8B14-4589-3DCA-8E0F-A30E80FBD1A8}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _UnknownWrapperDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {1C8D8B14-4589-3DCA-8E0F-A30E80FBD1A8}\r\n// *********************************************************************//\r\n _UnknownWrapperDisp = dispinterface\r\n ['{1C8D8B14-4589-3DCA-8E0F-A30E80FBD1A8}']\r\n end;\r\n {$EXTERNALSYM _UnknownWrapperDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: IExpando\r\n// Flags: (4416) Dual OleAutomation Dispatchable\r\n// GUID: {AFBF15E6-C37C-11D2-B88E-00A0C9B471B8}\r\n// *********************************************************************//\r\n IExpando = interface(IDispatch)\r\n ['{AFBF15E6-C37C-11D2-B88E-00A0C9B471B8}']\r\n function AddField(const name: WideString): _FieldInfo; safecall;\r\n function AddProperty(const name: WideString): _PropertyInfo; safecall;\r\n function AddMethod(const name: WideString; const Method: _Delegate): _MethodInfo; safecall;\r\n procedure RemoveMember(const m: _MemberInfo); safecall;\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: IExpandoDisp\r\n// Flags: (4416) Dual OleAutomation Dispatchable\r\n// GUID: {AFBF15E6-C37C-11D2-B88E-00A0C9B471B8}\r\n// *********************************************************************//\r\n IExpandoDisp = dispinterface\r\n ['{AFBF15E6-C37C-11D2-B88E-00A0C9B471B8}']\r\n function AddField(const name: WideString): _FieldInfo; dispid 1610743808;\r\n function AddProperty(const name: WideString): _PropertyInfo; dispid 1610743809;\r\n function AddMethod(const name: WideString; const Method: _Delegate): _MethodInfo; dispid 1610743810;\r\n procedure RemoveMember(const m: _MemberInfo); dispid 1610743811;\r\n end;\r\n {$EXTERNALSYM IExpandoDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _BinaryReader\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {442E3C03-A205-3F21-AA4D-31768BB8EA28}\r\n// *********************************************************************//\r\n _BinaryReader = interface(IDispatch)\r\n ['{442E3C03-A205-3F21-AA4D-31768BB8EA28}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _BinaryReaderDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {442E3C03-A205-3F21-AA4D-31768BB8EA28}\r\n// *********************************************************************//\r\n _BinaryReaderDisp = dispinterface\r\n ['{442E3C03-A205-3F21-AA4D-31768BB8EA28}']\r\n end;\r\n {$EXTERNALSYM _BinaryReaderDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _BinaryWriter\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {4CA8147E-BAA3-3A7F-92CE-A4FD7F17D8DA}\r\n// *********************************************************************//\r\n _BinaryWriter = interface(IDispatch)\r\n ['{4CA8147E-BAA3-3A7F-92CE-A4FD7F17D8DA}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _BinaryWriterDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {4CA8147E-BAA3-3A7F-92CE-A4FD7F17D8DA}\r\n// *********************************************************************//\r\n _BinaryWriterDisp = dispinterface\r\n ['{4CA8147E-BAA3-3A7F-92CE-A4FD7F17D8DA}']\r\n end;\r\n {$EXTERNALSYM _BinaryWriterDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _BufferedStream\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {4B7571C3-1275-3457-8FEE-9976FD3937E3}\r\n// *********************************************************************//\r\n _BufferedStream = interface(IDispatch)\r\n ['{4B7571C3-1275-3457-8FEE-9976FD3937E3}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _BufferedStreamDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {4B7571C3-1275-3457-8FEE-9976FD3937E3}\r\n// *********************************************************************//\r\n _BufferedStreamDisp = dispinterface\r\n ['{4B7571C3-1275-3457-8FEE-9976FD3937E3}']\r\n end;\r\n {$EXTERNALSYM _BufferedStreamDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _Directory\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {8CE58FF5-F26D-38A4-9195-0E2ECB3B56B9}\r\n// *********************************************************************//\r\n _Directory = interface(IDispatch)\r\n ['{8CE58FF5-F26D-38A4-9195-0E2ECB3B56B9}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _DirectoryDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {8CE58FF5-F26D-38A4-9195-0E2ECB3B56B9}\r\n// *********************************************************************//\r\n _DirectoryDisp = dispinterface\r\n ['{8CE58FF5-F26D-38A4-9195-0E2ECB3B56B9}']\r\n end;\r\n {$EXTERNALSYM _DirectoryDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _FileSystemInfo\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {A5D29A57-36A8-3E36-A099-7458B1FABAA2}\r\n// *********************************************************************//\r\n _FileSystemInfo = interface(IDispatch)\r\n ['{A5D29A57-36A8-3E36-A099-7458B1FABAA2}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _FileSystemInfoDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {A5D29A57-36A8-3E36-A099-7458B1FABAA2}\r\n// *********************************************************************//\r\n _FileSystemInfoDisp = dispinterface\r\n ['{A5D29A57-36A8-3E36-A099-7458B1FABAA2}']\r\n end;\r\n {$EXTERNALSYM _FileSystemInfoDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _DirectoryInfo\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {487E52F1-2BB9-3BD0-A0CA-6728B3A1D051}\r\n// *********************************************************************//\r\n _DirectoryInfo = interface(IDispatch)\r\n ['{487E52F1-2BB9-3BD0-A0CA-6728B3A1D051}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _DirectoryInfoDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {487E52F1-2BB9-3BD0-A0CA-6728B3A1D051}\r\n// *********************************************************************//\r\n _DirectoryInfoDisp = dispinterface\r\n ['{487E52F1-2BB9-3BD0-A0CA-6728B3A1D051}']\r\n end;\r\n {$EXTERNALSYM _DirectoryInfoDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _IOException\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {C5BFC9BF-27A7-3A59-A986-44C85F3521BF}\r\n// *********************************************************************//\r\n _IOException = interface(IDispatch)\r\n ['{C5BFC9BF-27A7-3A59-A986-44C85F3521BF}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _IOExceptionDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {C5BFC9BF-27A7-3A59-A986-44C85F3521BF}\r\n// *********************************************************************//\r\n _IOExceptionDisp = dispinterface\r\n ['{C5BFC9BF-27A7-3A59-A986-44C85F3521BF}']\r\n end;\r\n {$EXTERNALSYM _IOExceptionDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _DirectoryNotFoundException\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {C8A200E4-9735-30E4-B168-ED861A3020F2}\r\n// *********************************************************************//\r\n _DirectoryNotFoundException = interface(IDispatch)\r\n ['{C8A200E4-9735-30E4-B168-ED861A3020F2}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _DirectoryNotFoundExceptionDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {C8A200E4-9735-30E4-B168-ED861A3020F2}\r\n// *********************************************************************//\r\n _DirectoryNotFoundExceptionDisp = dispinterface\r\n ['{C8A200E4-9735-30E4-B168-ED861A3020F2}']\r\n end;\r\n {$EXTERNALSYM _DirectoryNotFoundExceptionDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _EndOfStreamException\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {D625AFD0-8FD9-3113-A900-43912A54C421}\r\n// *********************************************************************//\r\n _EndOfStreamException = interface(IDispatch)\r\n ['{D625AFD0-8FD9-3113-A900-43912A54C421}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _EndOfStreamExceptionDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {D625AFD0-8FD9-3113-A900-43912A54C421}\r\n// *********************************************************************//\r\n _EndOfStreamExceptionDisp = dispinterface\r\n ['{D625AFD0-8FD9-3113-A900-43912A54C421}']\r\n end;\r\n {$EXTERNALSYM _EndOfStreamExceptionDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _File\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {5D59051F-E19D-329A-9962-FD00D552E13D}\r\n// *********************************************************************//\r\n _File = interface(IDispatch)\r\n ['{5D59051F-E19D-329A-9962-FD00D552E13D}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _FileDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {5D59051F-E19D-329A-9962-FD00D552E13D}\r\n// *********************************************************************//\r\n _FileDisp = dispinterface\r\n ['{5D59051F-E19D-329A-9962-FD00D552E13D}']\r\n end;\r\n {$EXTERNALSYM _FileDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _FileInfo\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {C3C429F9-8590-3A01-B2B2-434837F3D16D}\r\n// *********************************************************************//\r\n _FileInfo = interface(IDispatch)\r\n ['{C3C429F9-8590-3A01-B2B2-434837F3D16D}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _FileInfoDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {C3C429F9-8590-3A01-B2B2-434837F3D16D}\r\n// *********************************************************************//\r\n _FileInfoDisp = dispinterface\r\n ['{C3C429F9-8590-3A01-B2B2-434837F3D16D}']\r\n end;\r\n {$EXTERNALSYM _FileInfoDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _FileLoadException\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {51D2C393-9B70-3551-84B5-FF5409FB3ADA}\r\n// *********************************************************************//\r\n _FileLoadException = interface(IDispatch)\r\n ['{51D2C393-9B70-3551-84B5-FF5409FB3ADA}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _FileLoadExceptionDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {51D2C393-9B70-3551-84B5-FF5409FB3ADA}\r\n// *********************************************************************//\r\n _FileLoadExceptionDisp = dispinterface\r\n ['{51D2C393-9B70-3551-84B5-FF5409FB3ADA}']\r\n end;\r\n {$EXTERNALSYM _FileLoadExceptionDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _FileNotFoundException\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {A15A976B-81E3-3EF4-8FF1-D75DDBE20AEF}\r\n// *********************************************************************//\r\n _FileNotFoundException = interface(IDispatch)\r\n ['{A15A976B-81E3-3EF4-8FF1-D75DDBE20AEF}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _FileNotFoundExceptionDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {A15A976B-81E3-3EF4-8FF1-D75DDBE20AEF}\r\n// *********************************************************************//\r\n _FileNotFoundExceptionDisp = dispinterface\r\n ['{A15A976B-81E3-3EF4-8FF1-D75DDBE20AEF}']\r\n end;\r\n {$EXTERNALSYM _FileNotFoundExceptionDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _FileStream\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {74265195-4A46-3D6F-A9DD-69C367EA39C8}\r\n// *********************************************************************//\r\n _FileStream = interface(IDispatch)\r\n ['{74265195-4A46-3D6F-A9DD-69C367EA39C8}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _FileStreamDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {74265195-4A46-3D6F-A9DD-69C367EA39C8}\r\n// *********************************************************************//\r\n _FileStreamDisp = dispinterface\r\n ['{74265195-4A46-3D6F-A9DD-69C367EA39C8}']\r\n end;\r\n {$EXTERNALSYM _FileStreamDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _MemoryStream\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {2DBC46FE-B3DD-3858-AFC2-D3A2D492A588}\r\n// *********************************************************************//\r\n _MemoryStream = interface(IDispatch)\r\n ['{2DBC46FE-B3DD-3858-AFC2-D3A2D492A588}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _MemoryStreamDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {2DBC46FE-B3DD-3858-AFC2-D3A2D492A588}\r\n// *********************************************************************//\r\n _MemoryStreamDisp = dispinterface\r\n ['{2DBC46FE-B3DD-3858-AFC2-D3A2D492A588}']\r\n end;\r\n {$EXTERNALSYM _MemoryStreamDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _Path\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {6DF93530-D276-31D9-8573-346778C650AF}\r\n// *********************************************************************//\r\n _Path = interface(IDispatch)\r\n ['{6DF93530-D276-31D9-8573-346778C650AF}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _PathDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {6DF93530-D276-31D9-8573-346778C650AF}\r\n// *********************************************************************//\r\n _PathDisp = dispinterface\r\n ['{6DF93530-D276-31D9-8573-346778C650AF}']\r\n end;\r\n {$EXTERNALSYM _PathDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _PathTooLongException\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {468B8EB4-89AC-381B-8F86-5E47EC0648B4}\r\n// *********************************************************************//\r\n _PathTooLongException = interface(IDispatch)\r\n ['{468B8EB4-89AC-381B-8F86-5E47EC0648B4}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _PathTooLongExceptionDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {468B8EB4-89AC-381B-8F86-5E47EC0648B4}\r\n// *********************************************************************//\r\n _PathTooLongExceptionDisp = dispinterface\r\n ['{468B8EB4-89AC-381B-8F86-5E47EC0648B4}']\r\n end;\r\n {$EXTERNALSYM _PathTooLongExceptionDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _TextReader\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {897471F2-9450-3F03-A41F-D2E1F1397854}\r\n// *********************************************************************//\r\n _TextReader = interface(IDispatch)\r\n ['{897471F2-9450-3F03-A41F-D2E1F1397854}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _TextReaderDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {897471F2-9450-3F03-A41F-D2E1F1397854}\r\n// *********************************************************************//\r\n _TextReaderDisp = dispinterface\r\n ['{897471F2-9450-3F03-A41F-D2E1F1397854}']\r\n end;\r\n {$EXTERNALSYM _TextReaderDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _StreamReader\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {E645B470-DC3F-3CE0-8104-5837FEDA04B3}\r\n// *********************************************************************//\r\n _StreamReader = interface(IDispatch)\r\n ['{E645B470-DC3F-3CE0-8104-5837FEDA04B3}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _StreamReaderDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {E645B470-DC3F-3CE0-8104-5837FEDA04B3}\r\n// *********************************************************************//\r\n _StreamReaderDisp = dispinterface\r\n ['{E645B470-DC3F-3CE0-8104-5837FEDA04B3}']\r\n end;\r\n {$EXTERNALSYM _StreamReaderDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _TextWriter\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {556137EA-8825-30BC-9D49-E47A9DB034EE}\r\n// *********************************************************************//\r\n _TextWriter = interface(IDispatch)\r\n ['{556137EA-8825-30BC-9D49-E47A9DB034EE}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _TextWriterDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {556137EA-8825-30BC-9D49-E47A9DB034EE}\r\n// *********************************************************************//\r\n _TextWriterDisp = dispinterface\r\n ['{556137EA-8825-30BC-9D49-E47A9DB034EE}']\r\n end;\r\n {$EXTERNALSYM _TextWriterDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _StreamWriter\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {1F124E1C-D05D-3643-A59F-C3DE6051994F}\r\n// *********************************************************************//\r\n _StreamWriter = interface(IDispatch)\r\n ['{1F124E1C-D05D-3643-A59F-C3DE6051994F}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _StreamWriterDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {1F124E1C-D05D-3643-A59F-C3DE6051994F}\r\n// *********************************************************************//\r\n _StreamWriterDisp = dispinterface\r\n ['{1F124E1C-D05D-3643-A59F-C3DE6051994F}']\r\n end;\r\n {$EXTERNALSYM _StreamWriterDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _StringReader\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {59733B03-0EA5-358C-95B5-659FCD9AA0B4}\r\n// *********************************************************************//\r\n _StringReader = interface(IDispatch)\r\n ['{59733B03-0EA5-358C-95B5-659FCD9AA0B4}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _StringReaderDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {59733B03-0EA5-358C-95B5-659FCD9AA0B4}\r\n// *********************************************************************//\r\n _StringReaderDisp = dispinterface\r\n ['{59733B03-0EA5-358C-95B5-659FCD9AA0B4}']\r\n end;\r\n {$EXTERNALSYM _StringReaderDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _StringWriter\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {CB9F94C0-D691-3B62-B0B2-3CE5309CFA62}\r\n// *********************************************************************//\r\n _StringWriter = interface(IDispatch)\r\n ['{CB9F94C0-D691-3B62-B0B2-3CE5309CFA62}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _StringWriterDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {CB9F94C0-D691-3B62-B0B2-3CE5309CFA62}\r\n// *********************************************************************//\r\n _StringWriterDisp = dispinterface\r\n ['{CB9F94C0-D691-3B62-B0B2-3CE5309CFA62}']\r\n end;\r\n {$EXTERNALSYM _StringWriterDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _AccessedThroughPropertyAttribute\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {998DCF16-F603-355D-8C89-3B675947997F}\r\n// *********************************************************************//\r\n _AccessedThroughPropertyAttribute = interface(IDispatch)\r\n ['{998DCF16-F603-355D-8C89-3B675947997F}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _AccessedThroughPropertyAttributeDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {998DCF16-F603-355D-8C89-3B675947997F}\r\n// *********************************************************************//\r\n _AccessedThroughPropertyAttributeDisp = dispinterface\r\n ['{998DCF16-F603-355D-8C89-3B675947997F}']\r\n end;\r\n {$EXTERNALSYM _AccessedThroughPropertyAttributeDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _CallConvCdecl\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {A6C2239B-08E6-3822-9769-E3D4B0431B82}\r\n// *********************************************************************//\r\n _CallConvCdecl = interface(IDispatch)\r\n ['{A6C2239B-08E6-3822-9769-E3D4B0431B82}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _CallConvCdeclDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {A6C2239B-08E6-3822-9769-E3D4B0431B82}\r\n// *********************************************************************//\r\n _CallConvCdeclDisp = dispinterface\r\n ['{A6C2239B-08E6-3822-9769-E3D4B0431B82}']\r\n end;\r\n {$EXTERNALSYM _CallConvCdeclDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _CallConvStdcall\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {8E17A5CD-1160-32DC-8548-407E7C3827C9}\r\n// *********************************************************************//\r\n _CallConvStdcall = interface(IDispatch)\r\n ['{8E17A5CD-1160-32DC-8548-407E7C3827C9}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _CallConvStdcallDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {8E17A5CD-1160-32DC-8548-407E7C3827C9}\r\n// *********************************************************************//\r\n _CallConvStdcallDisp = dispinterface\r\n ['{8E17A5CD-1160-32DC-8548-407E7C3827C9}']\r\n end;\r\n {$EXTERNALSYM _CallConvStdcallDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _CallConvThiscall\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {FA73DD3D-A472-35ED-B8BE-F99A13581F72}\r\n// *********************************************************************//\r\n _CallConvThiscall = interface(IDispatch)\r\n ['{FA73DD3D-A472-35ED-B8BE-F99A13581F72}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _CallConvThiscallDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {FA73DD3D-A472-35ED-B8BE-F99A13581F72}\r\n// *********************************************************************//\r\n _CallConvThiscallDisp = dispinterface\r\n ['{FA73DD3D-A472-35ED-B8BE-F99A13581F72}']\r\n end;\r\n {$EXTERNALSYM _CallConvThiscallDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _CallConvFastcall\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {3B452D17-3C5E-36C4-A12D-5E9276036CF8}\r\n// *********************************************************************//\r\n _CallConvFastcall = interface(IDispatch)\r\n ['{3B452D17-3C5E-36C4-A12D-5E9276036CF8}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _CallConvFastcallDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {3B452D17-3C5E-36C4-A12D-5E9276036CF8}\r\n// *********************************************************************//\r\n _CallConvFastcallDisp = dispinterface\r\n ['{3B452D17-3C5E-36C4-A12D-5E9276036CF8}']\r\n end;\r\n {$EXTERNALSYM _CallConvFastcallDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _RuntimeHelpers\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {028A39F4-2061-3C98-897C-2F6B29370B9B}\r\n// *********************************************************************//\r\n _RuntimeHelpers = interface(IDispatch)\r\n ['{028A39F4-2061-3C98-897C-2F6B29370B9B}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _RuntimeHelpersDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {028A39F4-2061-3C98-897C-2F6B29370B9B}\r\n// *********************************************************************//\r\n _RuntimeHelpersDisp = dispinterface\r\n ['{028A39F4-2061-3C98-897C-2F6B29370B9B}']\r\n end;\r\n {$EXTERNALSYM _RuntimeHelpersDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _CustomConstantAttribute\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {62CAF4A2-6A78-3FC7-AF81-A6BBF930761F}\r\n// *********************************************************************//\r\n _CustomConstantAttribute = interface(IDispatch)\r\n ['{62CAF4A2-6A78-3FC7-AF81-A6BBF930761F}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _CustomConstantAttributeDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {62CAF4A2-6A78-3FC7-AF81-A6BBF930761F}\r\n// *********************************************************************//\r\n _CustomConstantAttributeDisp = dispinterface\r\n ['{62CAF4A2-6A78-3FC7-AF81-A6BBF930761F}']\r\n end;\r\n {$EXTERNALSYM _CustomConstantAttributeDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _DateTimeConstantAttribute\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {EF387020-B664-3ACD-A1D2-806345845953}\r\n// *********************************************************************//\r\n _DateTimeConstantAttribute = interface(IDispatch)\r\n ['{EF387020-B664-3ACD-A1D2-806345845953}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _DateTimeConstantAttributeDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {EF387020-B664-3ACD-A1D2-806345845953}\r\n// *********************************************************************//\r\n _DateTimeConstantAttributeDisp = dispinterface\r\n ['{EF387020-B664-3ACD-A1D2-806345845953}']\r\n end;\r\n {$EXTERNALSYM _DateTimeConstantAttributeDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _DiscardableAttribute\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {3C3A8C69-7417-32FA-AA20-762D85E1B594}\r\n// *********************************************************************//\r\n _DiscardableAttribute = interface(IDispatch)\r\n ['{3C3A8C69-7417-32FA-AA20-762D85E1B594}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _DiscardableAttributeDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {3C3A8C69-7417-32FA-AA20-762D85E1B594}\r\n// *********************************************************************//\r\n _DiscardableAttributeDisp = dispinterface\r\n ['{3C3A8C69-7417-32FA-AA20-762D85E1B594}']\r\n end;\r\n {$EXTERNALSYM _DiscardableAttributeDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _DecimalConstantAttribute\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {7E133967-CCEC-3E89-8BD2-6CFCA649ECBF}\r\n// *********************************************************************//\r\n _DecimalConstantAttribute = interface(IDispatch)\r\n ['{7E133967-CCEC-3E89-8BD2-6CFCA649ECBF}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _DecimalConstantAttributeDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {7E133967-CCEC-3E89-8BD2-6CFCA649ECBF}\r\n// *********************************************************************//\r\n _DecimalConstantAttributeDisp = dispinterface\r\n ['{7E133967-CCEC-3E89-8BD2-6CFCA649ECBF}']\r\n end;\r\n {$EXTERNALSYM _DecimalConstantAttributeDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _CompilationRelaxationsAttribute\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {C5C4F625-2329-3382-8994-AAF561E5DFE9}\r\n// *********************************************************************//\r\n _CompilationRelaxationsAttribute = interface(IDispatch)\r\n ['{C5C4F625-2329-3382-8994-AAF561E5DFE9}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _CompilationRelaxationsAttributeDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {C5C4F625-2329-3382-8994-AAF561E5DFE9}\r\n// *********************************************************************//\r\n _CompilationRelaxationsAttributeDisp = dispinterface\r\n ['{C5C4F625-2329-3382-8994-AAF561E5DFE9}']\r\n end;\r\n {$EXTERNALSYM _CompilationRelaxationsAttributeDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _CompilerGlobalScopeAttribute\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {1EED213E-656A-3A73-A4B9-0D3B26FD942B}\r\n// *********************************************************************//\r\n _CompilerGlobalScopeAttribute = interface(IDispatch)\r\n ['{1EED213E-656A-3A73-A4B9-0D3B26FD942B}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _CompilerGlobalScopeAttributeDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {1EED213E-656A-3A73-A4B9-0D3B26FD942B}\r\n// *********************************************************************//\r\n _CompilerGlobalScopeAttributeDisp = dispinterface\r\n ['{1EED213E-656A-3A73-A4B9-0D3B26FD942B}']\r\n end;\r\n {$EXTERNALSYM _CompilerGlobalScopeAttributeDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _IDispatchConstantAttribute\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {97D0B28A-6932-3D74-B67F-6BCD3C921E7D}\r\n// *********************************************************************//\r\n _IDispatchConstantAttribute = interface(IDispatch)\r\n ['{97D0B28A-6932-3D74-B67F-6BCD3C921E7D}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _IDispatchConstantAttributeDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {97D0B28A-6932-3D74-B67F-6BCD3C921E7D}\r\n// *********************************************************************//\r\n _IDispatchConstantAttributeDisp = dispinterface\r\n ['{97D0B28A-6932-3D74-B67F-6BCD3C921E7D}']\r\n end;\r\n {$EXTERNALSYM _IDispatchConstantAttributeDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _IndexerNameAttribute\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {243368F5-67C9-3510-9424-335A8A67772F}\r\n// *********************************************************************//\r\n _IndexerNameAttribute = interface(IDispatch)\r\n ['{243368F5-67C9-3510-9424-335A8A67772F}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _IndexerNameAttributeDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {243368F5-67C9-3510-9424-335A8A67772F}\r\n// *********************************************************************//\r\n _IndexerNameAttributeDisp = dispinterface\r\n ['{243368F5-67C9-3510-9424-335A8A67772F}']\r\n end;\r\n {$EXTERNALSYM _IndexerNameAttributeDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _IsVolatile\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {0278C819-0C06-3756-B053-601A3E566D9B}\r\n// *********************************************************************//\r\n _IsVolatile = interface(IDispatch)\r\n ['{0278C819-0C06-3756-B053-601A3E566D9B}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _IsVolatileDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {0278C819-0C06-3756-B053-601A3E566D9B}\r\n// *********************************************************************//\r\n _IsVolatileDisp = dispinterface\r\n ['{0278C819-0C06-3756-B053-601A3E566D9B}']\r\n end;\r\n {$EXTERNALSYM _IsVolatileDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _IUnknownConstantAttribute\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {54542649-CE64-3F96-BCE5-FDE3BB22F242}\r\n// *********************************************************************//\r\n _IUnknownConstantAttribute = interface(IDispatch)\r\n ['{54542649-CE64-3F96-BCE5-FDE3BB22F242}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _IUnknownConstantAttributeDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {54542649-CE64-3F96-BCE5-FDE3BB22F242}\r\n// *********************************************************************//\r\n _IUnknownConstantAttributeDisp = dispinterface\r\n ['{54542649-CE64-3F96-BCE5-FDE3BB22F242}']\r\n end;\r\n {$EXTERNALSYM _IUnknownConstantAttributeDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _MethodImplAttribute\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {98966503-5D80-3242-83EF-79E136F6B954}\r\n// *********************************************************************//\r\n _MethodImplAttribute = interface(IDispatch)\r\n ['{98966503-5D80-3242-83EF-79E136F6B954}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _MethodImplAttributeDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {98966503-5D80-3242-83EF-79E136F6B954}\r\n// *********************************************************************//\r\n _MethodImplAttributeDisp = dispinterface\r\n ['{98966503-5D80-3242-83EF-79E136F6B954}']\r\n end;\r\n {$EXTERNALSYM _MethodImplAttributeDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _RequiredAttributeAttribute\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {DB2C11D9-3870-35E7-A10C-A3DDC3DC79B1}\r\n// *********************************************************************//\r\n _RequiredAttributeAttribute = interface(IDispatch)\r\n ['{DB2C11D9-3870-35E7-A10C-A3DDC3DC79B1}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _RequiredAttributeAttributeDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {DB2C11D9-3870-35E7-A10C-A3DDC3DC79B1}\r\n// *********************************************************************//\r\n _RequiredAttributeAttributeDisp = dispinterface\r\n ['{DB2C11D9-3870-35E7-A10C-A3DDC3DC79B1}']\r\n end;\r\n {$EXTERNALSYM _RequiredAttributeAttributeDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: IStackWalk\r\n// Flags: (4416) Dual OleAutomation Dispatchable\r\n// GUID: {60FC57B0-4A46-32A0-A5B4-B05B0DE8E781}\r\n// *********************************************************************//\r\n IStackWalk = interface(IDispatch)\r\n ['{60FC57B0-4A46-32A0-A5B4-B05B0DE8E781}']\r\n procedure _Assert; safecall;\r\n procedure Demand; safecall;\r\n procedure Deny; safecall;\r\n procedure PermitOnly; safecall;\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: IStackWalkDisp\r\n// Flags: (4416) Dual OleAutomation Dispatchable\r\n// GUID: {60FC57B0-4A46-32A0-A5B4-B05B0DE8E781}\r\n// *********************************************************************//\r\n IStackWalkDisp = dispinterface\r\n ['{60FC57B0-4A46-32A0-A5B4-B05B0DE8E781}']\r\n procedure Assert; dispid 1610743808;\r\n procedure Demand; dispid 1610743809;\r\n procedure Deny; dispid 1610743810;\r\n procedure PermitOnly; dispid 1610743811;\r\n end;\r\n {$EXTERNALSYM IStackWalkDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _PermissionSet\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {C2AF4970-4FB6-319C-A8AA-0614D27F2B2C}\r\n// *********************************************************************//\r\n _PermissionSet = interface(IDispatch)\r\n ['{C2AF4970-4FB6-319C-A8AA-0614D27F2B2C}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _PermissionSetDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {C2AF4970-4FB6-319C-A8AA-0614D27F2B2C}\r\n// *********************************************************************//\r\n _PermissionSetDisp = dispinterface\r\n ['{C2AF4970-4FB6-319C-A8AA-0614D27F2B2C}']\r\n end;\r\n {$EXTERNALSYM _PermissionSetDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _NamedPermissionSet\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {BA3E053F-ADE3-3233-874A-16E624C9A49B}\r\n// *********************************************************************//\r\n _NamedPermissionSet = interface(IDispatch)\r\n ['{BA3E053F-ADE3-3233-874A-16E624C9A49B}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _NamedPermissionSetDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {BA3E053F-ADE3-3233-874A-16E624C9A49B}\r\n// *********************************************************************//\r\n _NamedPermissionSetDisp = dispinterface\r\n ['{BA3E053F-ADE3-3233-874A-16E624C9A49B}']\r\n end;\r\n {$EXTERNALSYM _NamedPermissionSetDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _SecurityElement\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {8D597C42-2CFD-32B6-B6D6-86C9E2CFF00A}\r\n// *********************************************************************//\r\n _SecurityElement = interface(IDispatch)\r\n ['{8D597C42-2CFD-32B6-B6D6-86C9E2CFF00A}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _SecurityElementDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {8D597C42-2CFD-32B6-B6D6-86C9E2CFF00A}\r\n// *********************************************************************//\r\n _SecurityElementDisp = dispinterface\r\n ['{8D597C42-2CFD-32B6-B6D6-86C9E2CFF00A}']\r\n end;\r\n {$EXTERNALSYM _SecurityElementDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _XmlSyntaxException\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {D9FCAD88-D869-3788-A802-1B1E007C7A22}\r\n// *********************************************************************//\r\n _XmlSyntaxException = interface(IDispatch)\r\n ['{D9FCAD88-D869-3788-A802-1B1E007C7A22}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _XmlSyntaxExceptionDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {D9FCAD88-D869-3788-A802-1B1E007C7A22}\r\n// *********************************************************************//\r\n _XmlSyntaxExceptionDisp = dispinterface\r\n ['{D9FCAD88-D869-3788-A802-1B1E007C7A22}']\r\n end;\r\n {$EXTERNALSYM _XmlSyntaxExceptionDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: IPermission\r\n// Flags: (4416) Dual OleAutomation Dispatchable\r\n// GUID: {A19B3FC6-D680-3DD4-A17A-F58A7D481494}\r\n// *********************************************************************//\r\n IPermission = interface(IDispatch)\r\n ['{A19B3FC6-D680-3DD4-A17A-F58A7D481494}']\r\n function Copy: IPermission; safecall;\r\n function Intersect(const Target: IPermission): IPermission; safecall;\r\n function Union(const Target: IPermission): IPermission; safecall;\r\n function IsSubsetOf(const Target: IPermission): WordBool; safecall;\r\n procedure Demand; safecall;\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: IPermissionDisp\r\n// Flags: (4416) Dual OleAutomation Dispatchable\r\n// GUID: {A19B3FC6-D680-3DD4-A17A-F58A7D481494}\r\n// *********************************************************************//\r\n IPermissionDisp = dispinterface\r\n ['{A19B3FC6-D680-3DD4-A17A-F58A7D481494}']\r\n function Copy: IPermission; dispid 1610743808;\r\n function Intersect(const Target: IPermission): IPermission; dispid 1610743809;\r\n function Union(const Target: IPermission): IPermission; dispid 1610743810;\r\n function IsSubsetOf(const Target: IPermission): WordBool; dispid 1610743811;\r\n procedure Demand; dispid 1610743812;\r\n end;\r\n {$EXTERNALSYM IPermissionDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _CodeAccessPermission\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {4803CE39-2F30-31FC-B84B-5A0141385269}\r\n// *********************************************************************//\r\n _CodeAccessPermission = interface(IDispatch)\r\n ['{4803CE39-2F30-31FC-B84B-5A0141385269}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _CodeAccessPermissionDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {4803CE39-2F30-31FC-B84B-5A0141385269}\r\n// *********************************************************************//\r\n _CodeAccessPermissionDisp = dispinterface\r\n ['{4803CE39-2F30-31FC-B84B-5A0141385269}']\r\n end;\r\n {$EXTERNALSYM _CodeAccessPermissionDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: IUnrestrictedPermission\r\n// Flags: (4416) Dual OleAutomation Dispatchable\r\n// GUID: {0F1284E6-4399-3963-8DDD-A6A4904F66C8}\r\n// *********************************************************************//\r\n IUnrestrictedPermission = interface(IDispatch)\r\n ['{0F1284E6-4399-3963-8DDD-A6A4904F66C8}']\r\n function IsUnrestricted: WordBool; safecall;\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: IUnrestrictedPermissionDisp\r\n// Flags: (4416) Dual OleAutomation Dispatchable\r\n// GUID: {0F1284E6-4399-3963-8DDD-A6A4904F66C8}\r\n// *********************************************************************//\r\n IUnrestrictedPermissionDisp = dispinterface\r\n ['{0F1284E6-4399-3963-8DDD-A6A4904F66C8}']\r\n function IsUnrestricted: WordBool; dispid 1610743808;\r\n end;\r\n {$EXTERNALSYM IUnrestrictedPermissionDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _EnvironmentPermission\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {0720590D-5218-352A-A337-5449E6BD19DA}\r\n// *********************************************************************//\r\n _EnvironmentPermission = interface(IDispatch)\r\n ['{0720590D-5218-352A-A337-5449E6BD19DA}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _EnvironmentPermissionDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {0720590D-5218-352A-A337-5449E6BD19DA}\r\n// *********************************************************************//\r\n _EnvironmentPermissionDisp = dispinterface\r\n ['{0720590D-5218-352A-A337-5449E6BD19DA}']\r\n end;\r\n {$EXTERNALSYM _EnvironmentPermissionDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _FileDialogPermission\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {A8B7138C-8932-3D78-A585-A91569C743AC}\r\n// *********************************************************************//\r\n _FileDialogPermission = interface(IDispatch)\r\n ['{A8B7138C-8932-3D78-A585-A91569C743AC}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _FileDialogPermissionDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {A8B7138C-8932-3D78-A585-A91569C743AC}\r\n// *********************************************************************//\r\n _FileDialogPermissionDisp = dispinterface\r\n ['{A8B7138C-8932-3D78-A585-A91569C743AC}']\r\n end;\r\n {$EXTERNALSYM _FileDialogPermissionDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _FileIOPermission\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {A2ED7EFC-8E59-3CCC-AE92-EA2377F4D5EF}\r\n// *********************************************************************//\r\n _FileIOPermission = interface(IDispatch)\r\n ['{A2ED7EFC-8E59-3CCC-AE92-EA2377F4D5EF}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _FileIOPermissionDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {A2ED7EFC-8E59-3CCC-AE92-EA2377F4D5EF}\r\n// *********************************************************************//\r\n _FileIOPermissionDisp = dispinterface\r\n ['{A2ED7EFC-8E59-3CCC-AE92-EA2377F4D5EF}']\r\n end;\r\n {$EXTERNALSYM _FileIOPermissionDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _IsolatedStoragePermission\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {7FEE7903-F97C-3350-AD42-196B00AD2564}\r\n// *********************************************************************//\r\n _IsolatedStoragePermission = interface(IDispatch)\r\n ['{7FEE7903-F97C-3350-AD42-196B00AD2564}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _IsolatedStoragePermissionDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {7FEE7903-F97C-3350-AD42-196B00AD2564}\r\n// *********************************************************************//\r\n _IsolatedStoragePermissionDisp = dispinterface\r\n ['{7FEE7903-F97C-3350-AD42-196B00AD2564}']\r\n end;\r\n {$EXTERNALSYM _IsolatedStoragePermissionDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _IsolatedStorageFilePermission\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {0D0C83E8-BDE1-3BA5-B1EF-A8FC686D8BC9}\r\n// *********************************************************************//\r\n _IsolatedStorageFilePermission = interface(IDispatch)\r\n ['{0D0C83E8-BDE1-3BA5-B1EF-A8FC686D8BC9}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _IsolatedStorageFilePermissionDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {0D0C83E8-BDE1-3BA5-B1EF-A8FC686D8BC9}\r\n// *********************************************************************//\r\n _IsolatedStorageFilePermissionDisp = dispinterface\r\n ['{0D0C83E8-BDE1-3BA5-B1EF-A8FC686D8BC9}']\r\n end;\r\n {$EXTERNALSYM _IsolatedStorageFilePermissionDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _SecurityAttribute\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {48815668-6C27-3312-803E-2757F55CE96A}\r\n// *********************************************************************//\r\n _SecurityAttribute = interface(IDispatch)\r\n ['{48815668-6C27-3312-803E-2757F55CE96A}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _SecurityAttributeDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {48815668-6C27-3312-803E-2757F55CE96A}\r\n// *********************************************************************//\r\n _SecurityAttributeDisp = dispinterface\r\n ['{48815668-6C27-3312-803E-2757F55CE96A}']\r\n end;\r\n {$EXTERNALSYM _SecurityAttributeDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _CodeAccessSecurityAttribute\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {9C5149CB-D3C6-32FD-A0D5-95350DE7B813}\r\n// *********************************************************************//\r\n _CodeAccessSecurityAttribute = interface(IDispatch)\r\n ['{9C5149CB-D3C6-32FD-A0D5-95350DE7B813}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _CodeAccessSecurityAttributeDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {9C5149CB-D3C6-32FD-A0D5-95350DE7B813}\r\n// *********************************************************************//\r\n _CodeAccessSecurityAttributeDisp = dispinterface\r\n ['{9C5149CB-D3C6-32FD-A0D5-95350DE7B813}']\r\n end;\r\n {$EXTERNALSYM _CodeAccessSecurityAttributeDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _EnvironmentPermissionAttribute\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {4164071A-ED12-3BDD-AF40-FDABCAA77D5F}\r\n// *********************************************************************//\r\n _EnvironmentPermissionAttribute = interface(IDispatch)\r\n ['{4164071A-ED12-3BDD-AF40-FDABCAA77D5F}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _EnvironmentPermissionAttributeDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {4164071A-ED12-3BDD-AF40-FDABCAA77D5F}\r\n// *********************************************************************//\r\n _EnvironmentPermissionAttributeDisp = dispinterface\r\n ['{4164071A-ED12-3BDD-AF40-FDABCAA77D5F}']\r\n end;\r\n {$EXTERNALSYM _EnvironmentPermissionAttributeDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _FileDialogPermissionAttribute\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {0CCCA629-440F-313E-96CD-BA1B4B4997F7}\r\n// *********************************************************************//\r\n _FileDialogPermissionAttribute = interface(IDispatch)\r\n ['{0CCCA629-440F-313E-96CD-BA1B4B4997F7}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _FileDialogPermissionAttributeDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {0CCCA629-440F-313E-96CD-BA1B4B4997F7}\r\n// *********************************************************************//\r\n _FileDialogPermissionAttributeDisp = dispinterface\r\n ['{0CCCA629-440F-313E-96CD-BA1B4B4997F7}']\r\n end;\r\n {$EXTERNALSYM _FileDialogPermissionAttributeDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _FileIOPermissionAttribute\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {0DCA817D-F21A-3943-B54C-5E800CE5BC50}\r\n// *********************************************************************//\r\n _FileIOPermissionAttribute = interface(IDispatch)\r\n ['{0DCA817D-F21A-3943-B54C-5E800CE5BC50}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _FileIOPermissionAttributeDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {0DCA817D-F21A-3943-B54C-5E800CE5BC50}\r\n// *********************************************************************//\r\n _FileIOPermissionAttributeDisp = dispinterface\r\n ['{0DCA817D-F21A-3943-B54C-5E800CE5BC50}']\r\n end;\r\n {$EXTERNALSYM _FileIOPermissionAttributeDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _PrincipalPermissionAttribute\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {68AB69E4-5D68-3B51-B74D-1BEAB9F37F2B}\r\n// *********************************************************************//\r\n _PrincipalPermissionAttribute = interface(IDispatch)\r\n ['{68AB69E4-5D68-3B51-B74D-1BEAB9F37F2B}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _PrincipalPermissionAttributeDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {68AB69E4-5D68-3B51-B74D-1BEAB9F37F2B}\r\n// *********************************************************************//\r\n _PrincipalPermissionAttributeDisp = dispinterface\r\n ['{68AB69E4-5D68-3B51-B74D-1BEAB9F37F2B}']\r\n end;\r\n {$EXTERNALSYM _PrincipalPermissionAttributeDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _ReflectionPermissionAttribute\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {D31EED10-A5F0-308F-A951-E557961EC568}\r\n// *********************************************************************//\r\n _ReflectionPermissionAttribute = interface(IDispatch)\r\n ['{D31EED10-A5F0-308F-A951-E557961EC568}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _ReflectionPermissionAttributeDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {D31EED10-A5F0-308F-A951-E557961EC568}\r\n// *********************************************************************//\r\n _ReflectionPermissionAttributeDisp = dispinterface\r\n ['{D31EED10-A5F0-308F-A951-E557961EC568}']\r\n end;\r\n {$EXTERNALSYM _ReflectionPermissionAttributeDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _RegistryPermissionAttribute\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {38B6068C-1E94-3119-8841-1ECA35ED8578}\r\n// *********************************************************************//\r\n _RegistryPermissionAttribute = interface(IDispatch)\r\n ['{38B6068C-1E94-3119-8841-1ECA35ED8578}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _RegistryPermissionAttributeDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {38B6068C-1E94-3119-8841-1ECA35ED8578}\r\n// *********************************************************************//\r\n _RegistryPermissionAttributeDisp = dispinterface\r\n ['{38B6068C-1E94-3119-8841-1ECA35ED8578}']\r\n end;\r\n {$EXTERNALSYM _RegistryPermissionAttributeDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _SecurityPermissionAttribute\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {3A5B876C-CDE4-32D2-9C7E-020A14ACA332}\r\n// *********************************************************************//\r\n _SecurityPermissionAttribute = interface(IDispatch)\r\n ['{3A5B876C-CDE4-32D2-9C7E-020A14ACA332}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _SecurityPermissionAttributeDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {3A5B876C-CDE4-32D2-9C7E-020A14ACA332}\r\n// *********************************************************************//\r\n _SecurityPermissionAttributeDisp = dispinterface\r\n ['{3A5B876C-CDE4-32D2-9C7E-020A14ACA332}']\r\n end;\r\n {$EXTERNALSYM _SecurityPermissionAttributeDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _UIPermissionAttribute\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {1D5C0F70-AF29-38A3-9436-3070A310C73B}\r\n// *********************************************************************//\r\n _UIPermissionAttribute = interface(IDispatch)\r\n ['{1D5C0F70-AF29-38A3-9436-3070A310C73B}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _UIPermissionAttributeDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {1D5C0F70-AF29-38A3-9436-3070A310C73B}\r\n// *********************************************************************//\r\n _UIPermissionAttributeDisp = dispinterface\r\n ['{1D5C0F70-AF29-38A3-9436-3070A310C73B}']\r\n end;\r\n {$EXTERNALSYM _UIPermissionAttributeDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _ZoneIdentityPermissionAttribute\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {2E3BE3ED-2F22-3B20-9F92-BD29B79D6F42}\r\n// *********************************************************************//\r\n _ZoneIdentityPermissionAttribute = interface(IDispatch)\r\n ['{2E3BE3ED-2F22-3B20-9F92-BD29B79D6F42}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _ZoneIdentityPermissionAttributeDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {2E3BE3ED-2F22-3B20-9F92-BD29B79D6F42}\r\n// *********************************************************************//\r\n _ZoneIdentityPermissionAttributeDisp = dispinterface\r\n ['{2E3BE3ED-2F22-3B20-9F92-BD29B79D6F42}']\r\n end;\r\n {$EXTERNALSYM _ZoneIdentityPermissionAttributeDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _StrongNameIdentityPermissionAttribute\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {C9A740F4-26E9-39A8-8885-8CA26BD79B21}\r\n// *********************************************************************//\r\n _StrongNameIdentityPermissionAttribute = interface(IDispatch)\r\n ['{C9A740F4-26E9-39A8-8885-8CA26BD79B21}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _StrongNameIdentityPermissionAttributeDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {C9A740F4-26E9-39A8-8885-8CA26BD79B21}\r\n// *********************************************************************//\r\n _StrongNameIdentityPermissionAttributeDisp = dispinterface\r\n ['{C9A740F4-26E9-39A8-8885-8CA26BD79B21}']\r\n end;\r\n {$EXTERNALSYM _StrongNameIdentityPermissionAttributeDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _SiteIdentityPermissionAttribute\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {6FE6894A-2A53-3FB6-A06E-348F9BDAD23B}\r\n// *********************************************************************//\r\n _SiteIdentityPermissionAttribute = interface(IDispatch)\r\n ['{6FE6894A-2A53-3FB6-A06E-348F9BDAD23B}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _SiteIdentityPermissionAttributeDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {6FE6894A-2A53-3FB6-A06E-348F9BDAD23B}\r\n// *********************************************************************//\r\n _SiteIdentityPermissionAttributeDisp = dispinterface\r\n ['{6FE6894A-2A53-3FB6-A06E-348F9BDAD23B}']\r\n end;\r\n {$EXTERNALSYM _SiteIdentityPermissionAttributeDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _UrlIdentityPermissionAttribute\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {CA4A2073-48C5-3E61-8349-11701A90DD9B}\r\n// *********************************************************************//\r\n _UrlIdentityPermissionAttribute = interface(IDispatch)\r\n ['{CA4A2073-48C5-3E61-8349-11701A90DD9B}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _UrlIdentityPermissionAttributeDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {CA4A2073-48C5-3E61-8349-11701A90DD9B}\r\n// *********************************************************************//\r\n _UrlIdentityPermissionAttributeDisp = dispinterface\r\n ['{CA4A2073-48C5-3E61-8349-11701A90DD9B}']\r\n end;\r\n {$EXTERNALSYM _UrlIdentityPermissionAttributeDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _PublisherIdentityPermissionAttribute\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {6722C730-1239-3784-AC94-C285AE5B901A}\r\n// *********************************************************************//\r\n _PublisherIdentityPermissionAttribute = interface(IDispatch)\r\n ['{6722C730-1239-3784-AC94-C285AE5B901A}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _PublisherIdentityPermissionAttributeDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {6722C730-1239-3784-AC94-C285AE5B901A}\r\n// *********************************************************************//\r\n _PublisherIdentityPermissionAttributeDisp = dispinterface\r\n ['{6722C730-1239-3784-AC94-C285AE5B901A}']\r\n end;\r\n {$EXTERNALSYM _PublisherIdentityPermissionAttributeDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _IsolatedStoragePermissionAttribute\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {5C4C522F-DE4E-3595-9AA9-9319C86A5283}\r\n// *********************************************************************//\r\n _IsolatedStoragePermissionAttribute = interface(IDispatch)\r\n ['{5C4C522F-DE4E-3595-9AA9-9319C86A5283}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _IsolatedStoragePermissionAttributeDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {5C4C522F-DE4E-3595-9AA9-9319C86A5283}\r\n// *********************************************************************//\r\n _IsolatedStoragePermissionAttributeDisp = dispinterface\r\n ['{5C4C522F-DE4E-3595-9AA9-9319C86A5283}']\r\n end;\r\n {$EXTERNALSYM _IsolatedStoragePermissionAttributeDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _IsolatedStorageFilePermissionAttribute\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {6F1F8AAE-D667-39CC-98FA-722BEBBBEAC3}\r\n// *********************************************************************//\r\n _IsolatedStorageFilePermissionAttribute = interface(IDispatch)\r\n ['{6F1F8AAE-D667-39CC-98FA-722BEBBBEAC3}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _IsolatedStorageFilePermissionAttributeDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {6F1F8AAE-D667-39CC-98FA-722BEBBBEAC3}\r\n// *********************************************************************//\r\n _IsolatedStorageFilePermissionAttributeDisp = dispinterface\r\n ['{6F1F8AAE-D667-39CC-98FA-722BEBBBEAC3}']\r\n end;\r\n {$EXTERNALSYM _IsolatedStorageFilePermissionAttributeDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _PermissionSetAttribute\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {947A1995-BC16-3E7C-B65A-99E71F39C091}\r\n// *********************************************************************//\r\n _PermissionSetAttribute = interface(IDispatch)\r\n ['{947A1995-BC16-3E7C-B65A-99E71F39C091}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _PermissionSetAttributeDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {947A1995-BC16-3E7C-B65A-99E71F39C091}\r\n// *********************************************************************//\r\n _PermissionSetAttributeDisp = dispinterface\r\n ['{947A1995-BC16-3E7C-B65A-99E71F39C091}']\r\n end;\r\n {$EXTERNALSYM _PermissionSetAttributeDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _PublisherIdentityPermission\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {E86CC74A-1233-3DF3-B13F-8B27EEAAC1F6}\r\n// *********************************************************************//\r\n _PublisherIdentityPermission = interface(IDispatch)\r\n ['{E86CC74A-1233-3DF3-B13F-8B27EEAAC1F6}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _PublisherIdentityPermissionDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {E86CC74A-1233-3DF3-B13F-8B27EEAAC1F6}\r\n// *********************************************************************//\r\n _PublisherIdentityPermissionDisp = dispinterface\r\n ['{E86CC74A-1233-3DF3-B13F-8B27EEAAC1F6}']\r\n end;\r\n {$EXTERNALSYM _PublisherIdentityPermissionDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _ReflectionPermission\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {AEB3727F-5C3A-34C4-BF18-A38F088AC8C7}\r\n// *********************************************************************//\r\n _ReflectionPermission = interface(IDispatch)\r\n ['{AEB3727F-5C3A-34C4-BF18-A38F088AC8C7}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _ReflectionPermissionDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {AEB3727F-5C3A-34C4-BF18-A38F088AC8C7}\r\n// *********************************************************************//\r\n _ReflectionPermissionDisp = dispinterface\r\n ['{AEB3727F-5C3A-34C4-BF18-A38F088AC8C7}']\r\n end;\r\n {$EXTERNALSYM _ReflectionPermissionDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _RegistryPermission\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {C3FB5510-3454-3B31-B64F-DE6AAD6BE820}\r\n// *********************************************************************//\r\n _RegistryPermission = interface(IDispatch)\r\n ['{C3FB5510-3454-3B31-B64F-DE6AAD6BE820}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _RegistryPermissionDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {C3FB5510-3454-3B31-B64F-DE6AAD6BE820}\r\n// *********************************************************************//\r\n _RegistryPermissionDisp = dispinterface\r\n ['{C3FB5510-3454-3B31-B64F-DE6AAD6BE820}']\r\n end;\r\n {$EXTERNALSYM _RegistryPermissionDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _PrincipalPermission\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {7C6B06D1-63AD-35EF-A938-149B4AD9A71F}\r\n// *********************************************************************//\r\n _PrincipalPermission = interface(IDispatch)\r\n ['{7C6B06D1-63AD-35EF-A938-149B4AD9A71F}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _PrincipalPermissionDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {7C6B06D1-63AD-35EF-A938-149B4AD9A71F}\r\n// *********************************************************************//\r\n _PrincipalPermissionDisp = dispinterface\r\n ['{7C6B06D1-63AD-35EF-A938-149B4AD9A71F}']\r\n end;\r\n {$EXTERNALSYM _PrincipalPermissionDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _SecurityPermission\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {33C54A2D-02BD-3848-80B6-742D537085E5}\r\n// *********************************************************************//\r\n _SecurityPermission = interface(IDispatch)\r\n ['{33C54A2D-02BD-3848-80B6-742D537085E5}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _SecurityPermissionDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {33C54A2D-02BD-3848-80B6-742D537085E5}\r\n// *********************************************************************//\r\n _SecurityPermissionDisp = dispinterface\r\n ['{33C54A2D-02BD-3848-80B6-742D537085E5}']\r\n end;\r\n {$EXTERNALSYM _SecurityPermissionDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _SiteIdentityPermission\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {790B3EE9-7E06-3CD0-8243-5848486D6A78}\r\n// *********************************************************************//\r\n _SiteIdentityPermission = interface(IDispatch)\r\n ['{790B3EE9-7E06-3CD0-8243-5848486D6A78}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _SiteIdentityPermissionDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {790B3EE9-7E06-3CD0-8243-5848486D6A78}\r\n// *********************************************************************//\r\n _SiteIdentityPermissionDisp = dispinterface\r\n ['{790B3EE9-7E06-3CD0-8243-5848486D6A78}']\r\n end;\r\n {$EXTERNALSYM _SiteIdentityPermissionDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _StrongNameIdentityPermission\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {5F1562FB-0160-3655-BAEA-B15BEF609161}\r\n// *********************************************************************//\r\n _StrongNameIdentityPermission = interface(IDispatch)\r\n ['{5F1562FB-0160-3655-BAEA-B15BEF609161}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _StrongNameIdentityPermissionDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {5F1562FB-0160-3655-BAEA-B15BEF609161}\r\n// *********************************************************************//\r\n _StrongNameIdentityPermissionDisp = dispinterface\r\n ['{5F1562FB-0160-3655-BAEA-B15BEF609161}']\r\n end;\r\n {$EXTERNALSYM _StrongNameIdentityPermissionDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _StrongNamePublicKeyBlob\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {AF53D21A-D6AF-3406-B399-7DF9D2AAD48A}\r\n// *********************************************************************//\r\n _StrongNamePublicKeyBlob = interface(IDispatch)\r\n ['{AF53D21A-D6AF-3406-B399-7DF9D2AAD48A}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _StrongNamePublicKeyBlobDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {AF53D21A-D6AF-3406-B399-7DF9D2AAD48A}\r\n// *********************************************************************//\r\n _StrongNamePublicKeyBlobDisp = dispinterface\r\n ['{AF53D21A-D6AF-3406-B399-7DF9D2AAD48A}']\r\n end;\r\n {$EXTERNALSYM _StrongNamePublicKeyBlobDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _UIPermission\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {47698389-F182-3A67-87DF-AED490E14DC6}\r\n// *********************************************************************//\r\n _UIPermission = interface(IDispatch)\r\n ['{47698389-F182-3A67-87DF-AED490E14DC6}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _UIPermissionDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {47698389-F182-3A67-87DF-AED490E14DC6}\r\n// *********************************************************************//\r\n _UIPermissionDisp = dispinterface\r\n ['{47698389-F182-3A67-87DF-AED490E14DC6}']\r\n end;\r\n {$EXTERNALSYM _UIPermissionDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _UrlIdentityPermission\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {EC7CAC31-08A2-393B-BDF2-D052EB53AF2C}\r\n// *********************************************************************//\r\n _UrlIdentityPermission = interface(IDispatch)\r\n ['{EC7CAC31-08A2-393B-BDF2-D052EB53AF2C}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _UrlIdentityPermissionDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {EC7CAC31-08A2-393B-BDF2-D052EB53AF2C}\r\n// *********************************************************************//\r\n _UrlIdentityPermissionDisp = dispinterface\r\n ['{EC7CAC31-08A2-393B-BDF2-D052EB53AF2C}']\r\n end;\r\n {$EXTERNALSYM _UrlIdentityPermissionDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _ZoneIdentityPermission\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {38B2F8D7-8CF4-323B-9C17-9C55EE287A63}\r\n// *********************************************************************//\r\n _ZoneIdentityPermission = interface(IDispatch)\r\n ['{38B2F8D7-8CF4-323B-9C17-9C55EE287A63}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _ZoneIdentityPermissionDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {38B2F8D7-8CF4-323B-9C17-9C55EE287A63}\r\n// *********************************************************************//\r\n _ZoneIdentityPermissionDisp = dispinterface\r\n ['{38B2F8D7-8CF4-323B-9C17-9C55EE287A63}']\r\n end;\r\n {$EXTERNALSYM _ZoneIdentityPermissionDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _SuppressUnmanagedCodeSecurityAttribute\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {8000E51A-541C-3B20-A8EC-C8A8B41116C4}\r\n// *********************************************************************//\r\n _SuppressUnmanagedCodeSecurityAttribute = interface(IDispatch)\r\n ['{8000E51A-541C-3B20-A8EC-C8A8B41116C4}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _SuppressUnmanagedCodeSecurityAttributeDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {8000E51A-541C-3B20-A8EC-C8A8B41116C4}\r\n// *********************************************************************//\r\n _SuppressUnmanagedCodeSecurityAttributeDisp = dispinterface\r\n ['{8000E51A-541C-3B20-A8EC-C8A8B41116C4}']\r\n end;\r\n {$EXTERNALSYM _SuppressUnmanagedCodeSecurityAttributeDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _UnverifiableCodeAttribute\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {41F41C1B-7B8D-39A3-A28F-AAE20787F469}\r\n// *********************************************************************//\r\n _UnverifiableCodeAttribute = interface(IDispatch)\r\n ['{41F41C1B-7B8D-39A3-A28F-AAE20787F469}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _UnverifiableCodeAttributeDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {41F41C1B-7B8D-39A3-A28F-AAE20787F469}\r\n// *********************************************************************//\r\n _UnverifiableCodeAttributeDisp = dispinterface\r\n ['{41F41C1B-7B8D-39A3-A28F-AAE20787F469}']\r\n end;\r\n {$EXTERNALSYM _UnverifiableCodeAttributeDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _AllowPartiallyTrustedCallersAttribute\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {F1C930C4-2233-3924-9840-231D008259B4}\r\n// *********************************************************************//\r\n _AllowPartiallyTrustedCallersAttribute = interface(IDispatch)\r\n ['{F1C930C4-2233-3924-9840-231D008259B4}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _AllowPartiallyTrustedCallersAttributeDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {F1C930C4-2233-3924-9840-231D008259B4}\r\n// *********************************************************************//\r\n _AllowPartiallyTrustedCallersAttributeDisp = dispinterface\r\n ['{F1C930C4-2233-3924-9840-231D008259B4}']\r\n end;\r\n {$EXTERNALSYM _AllowPartiallyTrustedCallersAttributeDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _SecurityException\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {F174290F-E4CF-3976-88AA-4F8E32EB03DB}\r\n// *********************************************************************//\r\n _SecurityException = interface(IDispatch)\r\n ['{F174290F-E4CF-3976-88AA-4F8E32EB03DB}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _SecurityExceptionDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {F174290F-E4CF-3976-88AA-4F8E32EB03DB}\r\n// *********************************************************************//\r\n _SecurityExceptionDisp = dispinterface\r\n ['{F174290F-E4CF-3976-88AA-4F8E32EB03DB}']\r\n end;\r\n {$EXTERNALSYM _SecurityExceptionDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _SecurityManager\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {ABC04B16-5539-3C7E-92EC-0905A4A24464}\r\n// *********************************************************************//\r\n _SecurityManager = interface(IDispatch)\r\n ['{ABC04B16-5539-3C7E-92EC-0905A4A24464}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _SecurityManagerDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {ABC04B16-5539-3C7E-92EC-0905A4A24464}\r\n// *********************************************************************//\r\n _SecurityManagerDisp = dispinterface\r\n ['{ABC04B16-5539-3C7E-92EC-0905A4A24464}']\r\n end;\r\n {$EXTERNALSYM _SecurityManagerDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _VerificationException\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {F65070DF-57AF-3AE3-B951-D2AD7D513347}\r\n// *********************************************************************//\r\n _VerificationException = interface(IDispatch)\r\n ['{F65070DF-57AF-3AE3-B951-D2AD7D513347}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _VerificationExceptionDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {F65070DF-57AF-3AE3-B951-D2AD7D513347}\r\n// *********************************************************************//\r\n _VerificationExceptionDisp = dispinterface\r\n ['{F65070DF-57AF-3AE3-B951-D2AD7D513347}']\r\n end;\r\n {$EXTERNALSYM _VerificationExceptionDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: IContextAttribute\r\n// Flags: (4416) Dual OleAutomation Dispatchable\r\n// GUID: {4A68BAA3-27AA-314A-BDBB-6AE9BDFC0420}\r\n// *********************************************************************//\r\n IContextAttribute = interface(IDispatch)\r\n ['{4A68BAA3-27AA-314A-BDBB-6AE9BDFC0420}']\r\n function IsContextOK(const ctx: _Context; const msg: IConstructionCallMessage): WordBool; safecall;\r\n procedure GetPropertiesForNewContext(const msg: IConstructionCallMessage); safecall;\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: IContextAttributeDisp\r\n// Flags: (4416) Dual OleAutomation Dispatchable\r\n// GUID: {4A68BAA3-27AA-314A-BDBB-6AE9BDFC0420}\r\n// *********************************************************************//\r\n IContextAttributeDisp = dispinterface\r\n ['{4A68BAA3-27AA-314A-BDBB-6AE9BDFC0420}']\r\n function IsContextOK(const ctx: _Context; const msg: IConstructionCallMessage): WordBool; dispid 1610743808;\r\n procedure GetPropertiesForNewContext(const msg: IConstructionCallMessage); dispid 1610743809;\r\n end;\r\n {$EXTERNALSYM IContextAttributeDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: IContextProperty\r\n// Flags: (4416) Dual OleAutomation Dispatchable\r\n// GUID: {F01D896D-8D5F-3235-BE59-20E1E10DC22A}\r\n// *********************************************************************//\r\n IContextProperty = interface(IDispatch)\r\n ['{F01D896D-8D5F-3235-BE59-20E1E10DC22A}']\r\n function Get_name: WideString; safecall;\r\n function IsNewContextOK(const newCtx: _Context): WordBool; safecall;\r\n procedure Freeze(const newContext: _Context); safecall;\r\n property name: WideString read Get_name;\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: IContextPropertyDisp\r\n// Flags: (4416) Dual OleAutomation Dispatchable\r\n// GUID: {F01D896D-8D5F-3235-BE59-20E1E10DC22A}\r\n// *********************************************************************//\r\n IContextPropertyDisp = dispinterface\r\n ['{F01D896D-8D5F-3235-BE59-20E1E10DC22A}']\r\n property name: WideString readonly dispid 1610743808;\r\n function IsNewContextOK(const newCtx: _Context): WordBool; dispid 1610743809;\r\n procedure Freeze(const newContext: _Context); dispid 1610743810;\r\n end;\r\n {$EXTERNALSYM IContextPropertyDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _ContextAttribute\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {F042505B-7AAC-313B-A8C7-3F1AC949C311}\r\n// *********************************************************************//\r\n _ContextAttribute = interface(IDispatch)\r\n ['{F042505B-7AAC-313B-A8C7-3F1AC949C311}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _ContextAttributeDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {F042505B-7AAC-313B-A8C7-3F1AC949C311}\r\n// *********************************************************************//\r\n _ContextAttributeDisp = dispinterface\r\n ['{F042505B-7AAC-313B-A8C7-3F1AC949C311}']\r\n end;\r\n {$EXTERNALSYM _ContextAttributeDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: IActivator\r\n// Flags: (4416) Dual OleAutomation Dispatchable\r\n// GUID: {C02BBB79-5AA8-390D-927F-717B7BFF06A1}\r\n// *********************************************************************//\r\n IActivator = interface(IDispatch)\r\n ['{C02BBB79-5AA8-390D-927F-717B7BFF06A1}']\r\n function Get_NextActivator: IActivator; safecall;\r\n procedure _Set_NextActivator(const pRetVal: IActivator); safecall;\r\n function Activate(const msg: IConstructionCallMessage): IConstructionReturnMessage; safecall;\r\n function Get_level: ActivatorLevel; safecall;\r\n property NextActivator: IActivator read Get_NextActivator;\r\n property level: ActivatorLevel read Get_level;\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: IActivatorDisp\r\n// Flags: (4416) Dual OleAutomation Dispatchable\r\n// GUID: {C02BBB79-5AA8-390D-927F-717B7BFF06A1}\r\n// *********************************************************************//\r\n IActivatorDisp = dispinterface\r\n ['{C02BBB79-5AA8-390D-927F-717B7BFF06A1}']\r\n property NextActivator: IActivator readonly dispid 1610743808;\r\n function Activate(const msg: IConstructionCallMessage): IConstructionReturnMessage; dispid 1610743810;\r\n property level: ActivatorLevel readonly dispid 1610743811;\r\n end;\r\n {$EXTERNALSYM IActivatorDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: IMessageSink\r\n// Flags: (4416) Dual OleAutomation Dispatchable\r\n// GUID: {941F8AAA-A353-3B1D-A019-12E44377F1CD}\r\n// *********************************************************************//\r\n IMessageSink = interface(IDispatch)\r\n ['{941F8AAA-A353-3B1D-A019-12E44377F1CD}']\r\n function SyncProcessMessage(const msg: IMessage): IMessage; safecall;\r\n function AsyncProcessMessage(const msg: IMessage; const replySink: IMessageSink): IMessageCtrl; safecall;\r\n function Get_NextSink: IMessageSink; safecall;\r\n property NextSink: IMessageSink read Get_NextSink;\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: IMessageSinkDisp\r\n// Flags: (4416) Dual OleAutomation Dispatchable\r\n// GUID: {941F8AAA-A353-3B1D-A019-12E44377F1CD}\r\n// *********************************************************************//\r\n IMessageSinkDisp = dispinterface\r\n ['{941F8AAA-A353-3B1D-A019-12E44377F1CD}']\r\n function SyncProcessMessage(const msg: IMessage): IMessage; dispid 1610743808;\r\n function AsyncProcessMessage(const msg: IMessage; const replySink: IMessageSink): IMessageCtrl; dispid 1610743809;\r\n property NextSink: IMessageSink readonly dispid 1610743810;\r\n end;\r\n {$EXTERNALSYM IMessageSinkDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _AsyncResult\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {3936ABE1-B29E-3593-83F1-793D1A7F3898}\r\n// *********************************************************************//\r\n _AsyncResult = interface(IDispatch)\r\n ['{3936ABE1-B29E-3593-83F1-793D1A7F3898}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _AsyncResultDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {3936ABE1-B29E-3593-83F1-793D1A7F3898}\r\n// *********************************************************************//\r\n _AsyncResultDisp = dispinterface\r\n ['{3936ABE1-B29E-3593-83F1-793D1A7F3898}']\r\n end;\r\n {$EXTERNALSYM _AsyncResultDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _CallContext\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {53BCE4D4-6209-396D-BD4A-0B0A0A177DF9}\r\n// *********************************************************************//\r\n _CallContext = interface(IDispatch)\r\n ['{53BCE4D4-6209-396D-BD4A-0B0A0A177DF9}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _CallContextDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {53BCE4D4-6209-396D-BD4A-0B0A0A177DF9}\r\n// *********************************************************************//\r\n _CallContextDisp = dispinterface\r\n ['{53BCE4D4-6209-396D-BD4A-0B0A0A177DF9}']\r\n end;\r\n {$EXTERNALSYM _CallContextDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: ILogicalThreadAffinative\r\n// Flags: (4416) Dual OleAutomation Dispatchable\r\n// GUID: {4D125449-BA27-3927-8589-3E1B34B622E5}\r\n// *********************************************************************//\r\n ILogicalThreadAffinative = interface(IDispatch)\r\n ['{4D125449-BA27-3927-8589-3E1B34B622E5}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: ILogicalThreadAffinativeDisp\r\n// Flags: (4416) Dual OleAutomation Dispatchable\r\n// GUID: {4D125449-BA27-3927-8589-3E1B34B622E5}\r\n// *********************************************************************//\r\n ILogicalThreadAffinativeDisp = dispinterface\r\n ['{4D125449-BA27-3927-8589-3E1B34B622E5}']\r\n end;\r\n {$EXTERNALSYM ILogicalThreadAffinativeDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _LogicalCallContext\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {9AFF21F5-1C9C-35E7-AEA4-C3AA0BEB3B77}\r\n// *********************************************************************//\r\n _LogicalCallContext = interface(IDispatch)\r\n ['{9AFF21F5-1C9C-35E7-AEA4-C3AA0BEB3B77}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _LogicalCallContextDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {9AFF21F5-1C9C-35E7-AEA4-C3AA0BEB3B77}\r\n// *********************************************************************//\r\n _LogicalCallContextDisp = dispinterface\r\n ['{9AFF21F5-1C9C-35E7-AEA4-C3AA0BEB3B77}']\r\n end;\r\n {$EXTERNALSYM _LogicalCallContextDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _ChannelServices\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {FFB2E16E-E5C7-367C-B326-965ABF510F24}\r\n// *********************************************************************//\r\n _ChannelServices = interface(IDispatch)\r\n ['{FFB2E16E-E5C7-367C-B326-965ABF510F24}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _ChannelServicesDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {FFB2E16E-E5C7-367C-B326-965ABF510F24}\r\n// *********************************************************************//\r\n _ChannelServicesDisp = dispinterface\r\n ['{FFB2E16E-E5C7-367C-B326-965ABF510F24}']\r\n end;\r\n {$EXTERNALSYM _ChannelServicesDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: IClientResponseChannelSinkStack\r\n// Flags: (4416) Dual OleAutomation Dispatchable\r\n// GUID: {3AFAB213-F5A2-3241-93BA-329EA4BA8016}\r\n// *********************************************************************//\r\n IClientResponseChannelSinkStack = interface(IDispatch)\r\n ['{3AFAB213-F5A2-3241-93BA-329EA4BA8016}']\r\n procedure AsyncProcessResponse(const headers: ITransportHeaders; const Stream: _Stream); safecall;\r\n procedure DispatchReplyMessage(const msg: IMessage); safecall;\r\n procedure DispatchException(const e: _Exception); safecall;\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: IClientResponseChannelSinkStackDisp\r\n// Flags: (4416) Dual OleAutomation Dispatchable\r\n// GUID: {3AFAB213-F5A2-3241-93BA-329EA4BA8016}\r\n// *********************************************************************//\r\n IClientResponseChannelSinkStackDisp = dispinterface\r\n ['{3AFAB213-F5A2-3241-93BA-329EA4BA8016}']\r\n procedure AsyncProcessResponse(const headers: ITransportHeaders; const Stream: _Stream); dispid 1610743808;\r\n procedure DispatchReplyMessage(const msg: IMessage); dispid 1610743809;\r\n procedure DispatchException(const e: _Exception); dispid 1610743810;\r\n end;\r\n {$EXTERNALSYM IClientResponseChannelSinkStackDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: IClientChannelSinkStack\r\n// Flags: (4416) Dual OleAutomation Dispatchable\r\n// GUID: {3A5FDE6B-DB46-34E8-BACD-16EA5A440540}\r\n// *********************************************************************//\r\n IClientChannelSinkStack = interface(IDispatch)\r\n ['{3A5FDE6B-DB46-34E8-BACD-16EA5A440540}']\r\n procedure Push(const sink: IClientChannelSink; state: OleVariant); safecall;\r\n function Pop(const sink: IClientChannelSink): OleVariant; safecall;\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: IClientChannelSinkStackDisp\r\n// Flags: (4416) Dual OleAutomation Dispatchable\r\n// GUID: {3A5FDE6B-DB46-34E8-BACD-16EA5A440540}\r\n// *********************************************************************//\r\n IClientChannelSinkStackDisp = dispinterface\r\n ['{3A5FDE6B-DB46-34E8-BACD-16EA5A440540}']\r\n procedure Push(const sink: IClientChannelSink; state: OleVariant); dispid 1610743808;\r\n function Pop(const sink: IClientChannelSink): OleVariant; dispid 1610743809;\r\n end;\r\n {$EXTERNALSYM IClientChannelSinkStackDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _ClientChannelSinkStack\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {E1796120-C324-30D8-86F4-20086711463B}\r\n// *********************************************************************//\r\n _ClientChannelSinkStack = interface(IDispatch)\r\n ['{E1796120-C324-30D8-86F4-20086711463B}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _ClientChannelSinkStackDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {E1796120-C324-30D8-86F4-20086711463B}\r\n// *********************************************************************//\r\n _ClientChannelSinkStackDisp = dispinterface\r\n ['{E1796120-C324-30D8-86F4-20086711463B}']\r\n end;\r\n {$EXTERNALSYM _ClientChannelSinkStackDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: IServerResponseChannelSinkStack\r\n// Flags: (4416) Dual OleAutomation Dispatchable\r\n// GUID: {9BE679A6-61FD-38FC-A7B2-89982D33338B}\r\n// *********************************************************************//\r\n IServerResponseChannelSinkStack = interface(IDispatch)\r\n ['{9BE679A6-61FD-38FC-A7B2-89982D33338B}']\r\n procedure AsyncProcessResponse(const msg: IMessage; const headers: ITransportHeaders; \r\n const Stream: _Stream); safecall;\r\n function GetResponseStream(const msg: IMessage; const headers: ITransportHeaders): _Stream; safecall;\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: IServerResponseChannelSinkStackDisp\r\n// Flags: (4416) Dual OleAutomation Dispatchable\r\n// GUID: {9BE679A6-61FD-38FC-A7B2-89982D33338B}\r\n// *********************************************************************//\r\n IServerResponseChannelSinkStackDisp = dispinterface\r\n ['{9BE679A6-61FD-38FC-A7B2-89982D33338B}']\r\n procedure AsyncProcessResponse(const msg: IMessage; const headers: ITransportHeaders; \r\n const Stream: _Stream); dispid 1610743808;\r\n function GetResponseStream(const msg: IMessage; const headers: ITransportHeaders): _Stream; dispid 1610743809;\r\n end;\r\n {$EXTERNALSYM IServerResponseChannelSinkStackDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: IServerChannelSinkStack\r\n// Flags: (4416) Dual OleAutomation Dispatchable\r\n// GUID: {E694A733-768D-314D-B317-DCEAD136B11D}\r\n// *********************************************************************//\r\n IServerChannelSinkStack = interface(IDispatch)\r\n ['{E694A733-768D-314D-B317-DCEAD136B11D}']\r\n procedure Push(const sink: IServerChannelSink; state: OleVariant); safecall;\r\n function Pop(const sink: IServerChannelSink): OleVariant; safecall;\r\n procedure Store(const sink: IServerChannelSink; state: OleVariant); safecall;\r\n procedure StoreAndDispatch(const sink: IServerChannelSink; state: OleVariant); safecall;\r\n procedure ServerCallback(const ar: IAsyncResult); safecall;\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: IServerChannelSinkStackDisp\r\n// Flags: (4416) Dual OleAutomation Dispatchable\r\n// GUID: {E694A733-768D-314D-B317-DCEAD136B11D}\r\n// *********************************************************************//\r\n IServerChannelSinkStackDisp = dispinterface\r\n ['{E694A733-768D-314D-B317-DCEAD136B11D}']\r\n procedure Push(const sink: IServerChannelSink; state: OleVariant); dispid 1610743808;\r\n function Pop(const sink: IServerChannelSink): OleVariant; dispid 1610743809;\r\n procedure Store(const sink: IServerChannelSink; state: OleVariant); dispid 1610743810;\r\n procedure StoreAndDispatch(const sink: IServerChannelSink; state: OleVariant); dispid 1610743811;\r\n procedure ServerCallback(const ar: IAsyncResult); dispid 1610743812;\r\n end;\r\n {$EXTERNALSYM IServerChannelSinkStackDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _ServerChannelSinkStack\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {52DA9F90-89B3-35AB-907B-3562642967DE}\r\n// *********************************************************************//\r\n _ServerChannelSinkStack = interface(IDispatch)\r\n ['{52DA9F90-89B3-35AB-907B-3562642967DE}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _ServerChannelSinkStackDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {52DA9F90-89B3-35AB-907B-3562642967DE}\r\n// *********************************************************************//\r\n _ServerChannelSinkStackDisp = dispinterface\r\n ['{52DA9F90-89B3-35AB-907B-3562642967DE}']\r\n end;\r\n {$EXTERNALSYM _ServerChannelSinkStackDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _InternalMessageWrapper\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {EF926E1F-3EE7-32BC-8B01-C6E98C24BC19}\r\n// *********************************************************************//\r\n _InternalMessageWrapper = interface(IDispatch)\r\n ['{EF926E1F-3EE7-32BC-8B01-C6E98C24BC19}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _InternalMessageWrapperDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {EF926E1F-3EE7-32BC-8B01-C6E98C24BC19}\r\n// *********************************************************************//\r\n _InternalMessageWrapperDisp = dispinterface\r\n ['{EF926E1F-3EE7-32BC-8B01-C6E98C24BC19}']\r\n end;\r\n {$EXTERNALSYM _InternalMessageWrapperDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: IMessage\r\n// Flags: (4416) Dual OleAutomation Dispatchable\r\n// GUID: {1A8B0DE6-B825-38C5-B744-8F93075FD6FA}\r\n// *********************************************************************//\r\n IMessage = interface(IDispatch)\r\n ['{1A8B0DE6-B825-38C5-B744-8F93075FD6FA}']\r\n function Get_Properties: IDictionary; safecall;\r\n property Properties: IDictionary read Get_Properties;\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: IMessageDisp\r\n// Flags: (4416) Dual OleAutomation Dispatchable\r\n// GUID: {1A8B0DE6-B825-38C5-B744-8F93075FD6FA}\r\n// *********************************************************************//\r\n IMessageDisp = dispinterface\r\n ['{1A8B0DE6-B825-38C5-B744-8F93075FD6FA}']\r\n property Properties: IDictionary readonly dispid 1610743808;\r\n end;\r\n {$EXTERNALSYM IMessageDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: IMethodMessage\r\n// Flags: (4416) Dual OleAutomation Dispatchable\r\n// GUID: {8E5E0B95-750E-310D-892C-8CA7231CF75B}\r\n// *********************************************************************//\r\n IMethodMessage = interface(IDispatch)\r\n ['{8E5E0B95-750E-310D-892C-8CA7231CF75B}']\r\n function Get_Uri: WideString; safecall;\r\n function Get_MethodName: WideString; safecall;\r\n function Get_typeName: WideString; safecall;\r\n function Get_MethodSignature: OleVariant; safecall;\r\n function Get_ArgCount: Integer; safecall;\r\n function GetArgName(index: Integer): WideString; safecall;\r\n function GetArg(argNum: Integer): OleVariant; safecall;\r\n function Get_args: PSafeArray; safecall;\r\n function Get_HasVarArgs: WordBool; safecall;\r\n function Get_LogicalCallContext: _LogicalCallContext; safecall;\r\n function Get_MethodBase: _MethodBase; safecall;\r\n property Uri: WideString read Get_Uri;\r\n property MethodName: WideString read Get_MethodName;\r\n property typeName: WideString read Get_typeName;\r\n property MethodSignature: OleVariant read Get_MethodSignature;\r\n property ArgCount: Integer read Get_ArgCount;\r\n property args: PSafeArray read Get_args;\r\n property HasVarArgs: WordBool read Get_HasVarArgs;\r\n property LogicalCallContext: _LogicalCallContext read Get_LogicalCallContext;\r\n property MethodBase: _MethodBase read Get_MethodBase;\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: IMethodMessageDisp\r\n// Flags: (4416) Dual OleAutomation Dispatchable\r\n// GUID: {8E5E0B95-750E-310D-892C-8CA7231CF75B}\r\n// *********************************************************************//\r\n IMethodMessageDisp = dispinterface\r\n ['{8E5E0B95-750E-310D-892C-8CA7231CF75B}']\r\n property Uri: WideString readonly dispid 1610743808;\r\n property MethodName: WideString readonly dispid 1610743809;\r\n property typeName: WideString readonly dispid 1610743810;\r\n property MethodSignature: OleVariant readonly dispid 1610743811;\r\n property ArgCount: Integer readonly dispid 1610743812;\r\n function GetArgName(index: Integer): WideString; dispid 1610743813;\r\n function GetArg(argNum: Integer): OleVariant; dispid 1610743814;\r\n property args: {??PSafeArray}OleVariant readonly dispid 1610743815;\r\n property HasVarArgs: WordBool readonly dispid 1610743816;\r\n property LogicalCallContext: _LogicalCallContext readonly dispid 1610743817;\r\n property MethodBase: _MethodBase readonly dispid 1610743818;\r\n end;\r\n {$EXTERNALSYM IMethodMessageDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: IMethodCallMessage\r\n// Flags: (4416) Dual OleAutomation Dispatchable\r\n// GUID: {B90EFAA6-25E4-33D2-ACA3-94BF74DC4AB9}\r\n// *********************************************************************//\r\n IMethodCallMessage = interface(IDispatch)\r\n ['{B90EFAA6-25E4-33D2-ACA3-94BF74DC4AB9}']\r\n function Get_InArgCount: Integer; safecall;\r\n function GetInArgName(index: Integer): WideString; safecall;\r\n function GetInArg(argNum: Integer): OleVariant; safecall;\r\n function Get_InArgs: PSafeArray; safecall;\r\n property InArgCount: Integer read Get_InArgCount;\r\n property InArgs: PSafeArray read Get_InArgs;\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: IMethodCallMessageDisp\r\n// Flags: (4416) Dual OleAutomation Dispatchable\r\n// GUID: {B90EFAA6-25E4-33D2-ACA3-94BF74DC4AB9}\r\n// *********************************************************************//\r\n IMethodCallMessageDisp = dispinterface\r\n ['{B90EFAA6-25E4-33D2-ACA3-94BF74DC4AB9}']\r\n property InArgCount: Integer readonly dispid 1610743808;\r\n function GetInArgName(index: Integer): WideString; dispid 1610743809;\r\n function GetInArg(argNum: Integer): OleVariant; dispid 1610743810;\r\n property InArgs: {??PSafeArray}OleVariant readonly dispid 1610743811;\r\n end;\r\n {$EXTERNALSYM IMethodCallMessageDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _MethodCallMessageWrapper\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {C9614D78-10EA-3310-87EA-821B70632898}\r\n// *********************************************************************//\r\n _MethodCallMessageWrapper = interface(IDispatch)\r\n ['{C9614D78-10EA-3310-87EA-821B70632898}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _MethodCallMessageWrapperDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {C9614D78-10EA-3310-87EA-821B70632898}\r\n// *********************************************************************//\r\n _MethodCallMessageWrapperDisp = dispinterface\r\n ['{C9614D78-10EA-3310-87EA-821B70632898}']\r\n end;\r\n {$EXTERNALSYM _MethodCallMessageWrapperDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: ISponsor\r\n// Flags: (4416) Dual OleAutomation Dispatchable\r\n// GUID: {675591AF-0508-3131-A7CC-287D265CA7D6}\r\n// *********************************************************************//\r\n ISponsor = interface(IDispatch)\r\n ['{675591AF-0508-3131-A7CC-287D265CA7D6}']\r\n function Renewal(const lease: ILease): TimeSpan; safecall;\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: ISponsorDisp\r\n// Flags: (4416) Dual OleAutomation Dispatchable\r\n// GUID: {675591AF-0508-3131-A7CC-287D265CA7D6}\r\n// *********************************************************************//\r\n ISponsorDisp = dispinterface\r\n ['{675591AF-0508-3131-A7CC-287D265CA7D6}']\r\n function Renewal(const lease: ILease): {??TimeSpan}OleVariant; dispid 1610743808;\r\n end;\r\n {$EXTERNALSYM ISponsorDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _ClientSponsor\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {FF19D114-3BDA-30AC-8E89-36CA64A87120}\r\n// *********************************************************************//\r\n _ClientSponsor = interface(IDispatch)\r\n ['{FF19D114-3BDA-30AC-8E89-36CA64A87120}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _ClientSponsorDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {FF19D114-3BDA-30AC-8E89-36CA64A87120}\r\n// *********************************************************************//\r\n _ClientSponsorDisp = dispinterface\r\n ['{FF19D114-3BDA-30AC-8E89-36CA64A87120}']\r\n end;\r\n {$EXTERNALSYM _ClientSponsorDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _CrossContextDelegate\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {EE949B7B-439F-363E-B9FC-34DB1FB781D7}\r\n// *********************************************************************//\r\n _CrossContextDelegate = interface(IDispatch)\r\n ['{EE949B7B-439F-363E-B9FC-34DB1FB781D7}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _CrossContextDelegateDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {EE949B7B-439F-363E-B9FC-34DB1FB781D7}\r\n// *********************************************************************//\r\n _CrossContextDelegateDisp = dispinterface\r\n ['{EE949B7B-439F-363E-B9FC-34DB1FB781D7}']\r\n end;\r\n {$EXTERNALSYM _CrossContextDelegateDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _Context\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {11A2EA7A-D600-307B-A606-511A6C7950D1}\r\n// *********************************************************************//\r\n _Context = interface(IDispatch)\r\n ['{11A2EA7A-D600-307B-A606-511A6C7950D1}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _ContextDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {11A2EA7A-D600-307B-A606-511A6C7950D1}\r\n// *********************************************************************//\r\n _ContextDisp = dispinterface\r\n ['{11A2EA7A-D600-307B-A606-511A6C7950D1}']\r\n end;\r\n {$EXTERNALSYM _ContextDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _ContextProperty\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {4ACB3495-05DB-381B-890A-D12F5340DCA3}\r\n// *********************************************************************//\r\n _ContextProperty = interface(IDispatch)\r\n ['{4ACB3495-05DB-381B-890A-D12F5340DCA3}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _ContextPropertyDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {4ACB3495-05DB-381B-890A-D12F5340DCA3}\r\n// *********************************************************************//\r\n _ContextPropertyDisp = dispinterface\r\n ['{4ACB3495-05DB-381B-890A-D12F5340DCA3}']\r\n end;\r\n {$EXTERNALSYM _ContextPropertyDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: IContextPropertyActivator\r\n// Flags: (4416) Dual OleAutomation Dispatchable\r\n// GUID: {7197B56B-5FA1-31EF-B38B-62FEE737277F}\r\n// *********************************************************************//\r\n IContextPropertyActivator = interface(IDispatch)\r\n ['{7197B56B-5FA1-31EF-B38B-62FEE737277F}']\r\n function IsOKToActivate(const msg: IConstructionCallMessage): WordBool; safecall;\r\n procedure CollectFromClientContext(const msg: IConstructionCallMessage); safecall;\r\n function DeliverClientContextToServerContext(const msg: IConstructionCallMessage): WordBool; safecall;\r\n procedure CollectFromServerContext(const msg: IConstructionReturnMessage); safecall;\r\n function DeliverServerContextToClientContext(const msg: IConstructionReturnMessage): WordBool; safecall;\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: IContextPropertyActivatorDisp\r\n// Flags: (4416) Dual OleAutomation Dispatchable\r\n// GUID: {7197B56B-5FA1-31EF-B38B-62FEE737277F}\r\n// *********************************************************************//\r\n IContextPropertyActivatorDisp = dispinterface\r\n ['{7197B56B-5FA1-31EF-B38B-62FEE737277F}']\r\n function IsOKToActivate(const msg: IConstructionCallMessage): WordBool; dispid 1610743808;\r\n procedure CollectFromClientContext(const msg: IConstructionCallMessage); dispid 1610743809;\r\n function DeliverClientContextToServerContext(const msg: IConstructionCallMessage): WordBool; dispid 1610743810;\r\n procedure CollectFromServerContext(const msg: IConstructionReturnMessage); dispid 1610743811;\r\n function DeliverServerContextToClientContext(const msg: IConstructionReturnMessage): WordBool; dispid 1610743812;\r\n end;\r\n {$EXTERNALSYM IContextPropertyActivatorDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: IChannel\r\n// Flags: (4416) Dual OleAutomation Dispatchable\r\n// GUID: {563581E8-C86D-39E2-B2E8-6C23F7987A4B}\r\n// *********************************************************************//\r\n IChannel = interface(IDispatch)\r\n ['{563581E8-C86D-39E2-B2E8-6C23F7987A4B}']\r\n function Get_ChannelPriority: Integer; safecall;\r\n function Get_ChannelName: WideString; safecall;\r\n function Parse(const Url: WideString; out objectURI: WideString): WideString; safecall;\r\n property ChannelPriority: Integer read Get_ChannelPriority;\r\n property ChannelName: WideString read Get_ChannelName;\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: IChannelDisp\r\n// Flags: (4416) Dual OleAutomation Dispatchable\r\n// GUID: {563581E8-C86D-39E2-B2E8-6C23F7987A4B}\r\n// *********************************************************************//\r\n IChannelDisp = dispinterface\r\n ['{563581E8-C86D-39E2-B2E8-6C23F7987A4B}']\r\n property ChannelPriority: Integer readonly dispid 1610743808;\r\n property ChannelName: WideString readonly dispid 1610743809;\r\n function Parse(const Url: WideString; out objectURI: WideString): WideString; dispid 1610743810;\r\n end;\r\n {$EXTERNALSYM IChannelDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: IChannelSender\r\n// Flags: (4416) Dual OleAutomation Dispatchable\r\n// GUID: {10F1D605-E201-3145-B7AE-3AD746701986}\r\n// *********************************************************************//\r\n IChannelSender = interface(IDispatch)\r\n ['{10F1D605-E201-3145-B7AE-3AD746701986}']\r\n function CreateMessageSink(const Url: WideString; remoteChannelData: OleVariant; \r\n out objectURI: WideString): IMessageSink; safecall;\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: IChannelSenderDisp\r\n// Flags: (4416) Dual OleAutomation Dispatchable\r\n// GUID: {10F1D605-E201-3145-B7AE-3AD746701986}\r\n// *********************************************************************//\r\n IChannelSenderDisp = dispinterface\r\n ['{10F1D605-E201-3145-B7AE-3AD746701986}']\r\n function CreateMessageSink(const Url: WideString; remoteChannelData: OleVariant; \r\n out objectURI: WideString): IMessageSink; dispid 1610743808;\r\n end;\r\n {$EXTERNALSYM IChannelSenderDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: IChannelReceiver\r\n// Flags: (4416) Dual OleAutomation Dispatchable\r\n// GUID: {48AD41DA-0872-31DA-9887-F81F213527E6}\r\n// *********************************************************************//\r\n IChannelReceiver = interface(IDispatch)\r\n ['{48AD41DA-0872-31DA-9887-F81F213527E6}']\r\n function Get_ChannelData: OleVariant; safecall;\r\n function GetUrlsForUri(const objectURI: WideString): PSafeArray; safecall;\r\n procedure StartListening(data: OleVariant); safecall;\r\n procedure StopListening(data: OleVariant); safecall;\r\n property ChannelData: OleVariant read Get_ChannelData;\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: IChannelReceiverDisp\r\n// Flags: (4416) Dual OleAutomation Dispatchable\r\n// GUID: {48AD41DA-0872-31DA-9887-F81F213527E6}\r\n// *********************************************************************//\r\n IChannelReceiverDisp = dispinterface\r\n ['{48AD41DA-0872-31DA-9887-F81F213527E6}']\r\n property ChannelData: OleVariant readonly dispid 1610743808;\r\n function GetUrlsForUri(const objectURI: WideString): {??PSafeArray}OleVariant; dispid 1610743809;\r\n procedure StartListening(data: OleVariant); dispid 1610743810;\r\n procedure StopListening(data: OleVariant); dispid 1610743811;\r\n end;\r\n {$EXTERNALSYM IChannelReceiverDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: IServerChannelSinkProvider\r\n// Flags: (4416) Dual OleAutomation Dispatchable\r\n// GUID: {7DD6E975-24EA-323C-A98C-0FDE96F9C4E6}\r\n// *********************************************************************//\r\n IServerChannelSinkProvider = interface(IDispatch)\r\n ['{7DD6E975-24EA-323C-A98C-0FDE96F9C4E6}']\r\n procedure GetChannelData(const ChannelData: IChannelDataStore); safecall;\r\n function CreateSink(const channel: IChannelReceiver): IServerChannelSink; safecall;\r\n function Get_Next: IServerChannelSinkProvider; safecall;\r\n procedure _Set_Next(const pRetVal: IServerChannelSinkProvider); safecall;\r\n property Next: IServerChannelSinkProvider read Get_Next;\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: IServerChannelSinkProviderDisp\r\n// Flags: (4416) Dual OleAutomation Dispatchable\r\n// GUID: {7DD6E975-24EA-323C-A98C-0FDE96F9C4E6}\r\n// *********************************************************************//\r\n IServerChannelSinkProviderDisp = dispinterface\r\n ['{7DD6E975-24EA-323C-A98C-0FDE96F9C4E6}']\r\n procedure GetChannelData(const ChannelData: IChannelDataStore); dispid 1610743808;\r\n function CreateSink(const channel: IChannelReceiver): IServerChannelSink; dispid 1610743809;\r\n property Next: IServerChannelSinkProvider readonly dispid 1610743810;\r\n end;\r\n {$EXTERNALSYM IServerChannelSinkProviderDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: IChannelSinkBase\r\n// Flags: (4416) Dual OleAutomation Dispatchable\r\n// GUID: {308DE042-ACC8-32F8-B632-7CB9799D9AA6}\r\n// *********************************************************************//\r\n IChannelSinkBase = interface(IDispatch)\r\n ['{308DE042-ACC8-32F8-B632-7CB9799D9AA6}']\r\n function Get_Properties: IDictionary; safecall;\r\n property Properties: IDictionary read Get_Properties;\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: IChannelSinkBaseDisp\r\n// Flags: (4416) Dual OleAutomation Dispatchable\r\n// GUID: {308DE042-ACC8-32F8-B632-7CB9799D9AA6}\r\n// *********************************************************************//\r\n IChannelSinkBaseDisp = dispinterface\r\n ['{308DE042-ACC8-32F8-B632-7CB9799D9AA6}']\r\n property Properties: IDictionary readonly dispid 1610743808;\r\n end;\r\n {$EXTERNALSYM IChannelSinkBaseDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: IServerChannelSink\r\n// Flags: (4416) Dual OleAutomation Dispatchable\r\n// GUID: {21B5F37B-BEF3-354C-8F84-0F9F0863F5C5}\r\n// *********************************************************************//\r\n IServerChannelSink = interface(IDispatch)\r\n ['{21B5F37B-BEF3-354C-8F84-0F9F0863F5C5}']\r\n function ProcessMessage(const sinkStack: IServerChannelSinkStack; const requestMsg: IMessage; \r\n const requestHeaders: ITransportHeaders; const requestStream: _Stream; \r\n out responseMsg: IMessage; out responseHeaders: ITransportHeaders; \r\n out responseStream: _Stream): ServerProcessing; safecall;\r\n procedure AsyncProcessResponse(const sinkStack: IServerResponseChannelSinkStack; \r\n state: OleVariant; const msg: IMessage; \r\n const headers: ITransportHeaders; const Stream: _Stream); safecall;\r\n function GetResponseStream(const sinkStack: IServerResponseChannelSinkStack; state: OleVariant; \r\n const msg: IMessage; const headers: ITransportHeaders): _Stream; safecall;\r\n function Get_NextChannelSink: IServerChannelSink; safecall;\r\n property NextChannelSink: IServerChannelSink read Get_NextChannelSink;\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: IServerChannelSinkDisp\r\n// Flags: (4416) Dual OleAutomation Dispatchable\r\n// GUID: {21B5F37B-BEF3-354C-8F84-0F9F0863F5C5}\r\n// *********************************************************************//\r\n IServerChannelSinkDisp = dispinterface\r\n ['{21B5F37B-BEF3-354C-8F84-0F9F0863F5C5}']\r\n function ProcessMessage(const sinkStack: IServerChannelSinkStack; const requestMsg: IMessage; \r\n const requestHeaders: ITransportHeaders; const requestStream: _Stream; \r\n out responseMsg: IMessage; out responseHeaders: ITransportHeaders; \r\n out responseStream: _Stream): ServerProcessing; dispid 1610743808;\r\n procedure AsyncProcessResponse(const sinkStack: IServerResponseChannelSinkStack; \r\n state: OleVariant; const msg: IMessage; \r\n const headers: ITransportHeaders; const Stream: _Stream); dispid 1610743809;\r\n function GetResponseStream(const sinkStack: IServerResponseChannelSinkStack; state: OleVariant; \r\n const msg: IMessage; const headers: ITransportHeaders): _Stream; dispid 1610743810;\r\n property NextChannelSink: IServerChannelSink readonly dispid 1610743811;\r\n end;\r\n {$EXTERNALSYM IServerChannelSinkDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _EnterpriseServicesHelper\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {77C9BCEB-9958-33C0-A858-599F66697DA7}\r\n// *********************************************************************//\r\n _EnterpriseServicesHelper = interface(IDispatch)\r\n ['{77C9BCEB-9958-33C0-A858-599F66697DA7}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _EnterpriseServicesHelperDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {77C9BCEB-9958-33C0-A858-599F66697DA7}\r\n// *********************************************************************//\r\n _EnterpriseServicesHelperDisp = dispinterface\r\n ['{77C9BCEB-9958-33C0-A858-599F66697DA7}']\r\n end;\r\n {$EXTERNALSYM _EnterpriseServicesHelperDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _Header\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {0D296515-AD19-3602-B415-D8EC77066081}\r\n// *********************************************************************//\r\n _Header = interface(IDispatch)\r\n ['{0D296515-AD19-3602-B415-D8EC77066081}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _HeaderDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {0D296515-AD19-3602-B415-D8EC77066081}\r\n// *********************************************************************//\r\n _HeaderDisp = dispinterface\r\n ['{0D296515-AD19-3602-B415-D8EC77066081}']\r\n end;\r\n {$EXTERNALSYM _HeaderDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _HeaderHandler\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {5DBBAF39-A3DF-30B7-AAEA-9FD11394123F}\r\n// *********************************************************************//\r\n _HeaderHandler = interface(IDispatch)\r\n ['{5DBBAF39-A3DF-30B7-AAEA-9FD11394123F}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _HeaderHandlerDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {5DBBAF39-A3DF-30B7-AAEA-9FD11394123F}\r\n// *********************************************************************//\r\n _HeaderHandlerDisp = dispinterface\r\n ['{5DBBAF39-A3DF-30B7-AAEA-9FD11394123F}']\r\n end;\r\n {$EXTERNALSYM _HeaderHandlerDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: IConstructionCallMessage\r\n// Flags: (4416) Dual OleAutomation Dispatchable\r\n// GUID: {FA28E3AF-7D09-31D5-BEEB-7F2626497CDE}\r\n// *********************************************************************//\r\n IConstructionCallMessage = interface(IDispatch)\r\n ['{FA28E3AF-7D09-31D5-BEEB-7F2626497CDE}']\r\n function Get_Activator: IActivator; safecall;\r\n procedure _Set_Activator(const pRetVal: IActivator); safecall;\r\n function Get_CallSiteActivationAttributes: PSafeArray; safecall;\r\n function Get_ActivationTypeName: WideString; safecall;\r\n function Get_ActivationType: _Type; safecall;\r\n function Get_ContextProperties: IList; safecall;\r\n property Activator: IActivator read Get_Activator;\r\n property CallSiteActivationAttributes: PSafeArray read Get_CallSiteActivationAttributes;\r\n property ActivationTypeName: WideString read Get_ActivationTypeName;\r\n property ActivationType: _Type read Get_ActivationType;\r\n property ContextProperties: IList read Get_ContextProperties;\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: IConstructionCallMessageDisp\r\n// Flags: (4416) Dual OleAutomation Dispatchable\r\n// GUID: {FA28E3AF-7D09-31D5-BEEB-7F2626497CDE}\r\n// *********************************************************************//\r\n IConstructionCallMessageDisp = dispinterface\r\n ['{FA28E3AF-7D09-31D5-BEEB-7F2626497CDE}']\r\n property Activator: IActivator readonly dispid 1610743808;\r\n property CallSiteActivationAttributes: {??PSafeArray}OleVariant readonly dispid 1610743810;\r\n property ActivationTypeName: WideString readonly dispid 1610743811;\r\n property ActivationType: _Type readonly dispid 1610743812;\r\n property ContextProperties: IList readonly dispid 1610743813;\r\n end;\r\n {$EXTERNALSYM IConstructionCallMessageDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: IMethodReturnMessage\r\n// Flags: (4416) Dual OleAutomation Dispatchable\r\n// GUID: {F617690A-55F4-36AF-9149-D199831F8594}\r\n// *********************************************************************//\r\n IMethodReturnMessage = interface(IDispatch)\r\n ['{F617690A-55F4-36AF-9149-D199831F8594}']\r\n function Get_OutArgCount: Integer; safecall;\r\n function GetOutArgName(index: Integer): WideString; safecall;\r\n function GetOutArg(argNum: Integer): OleVariant; safecall;\r\n function Get_OutArgs: PSafeArray; safecall;\r\n function Get_Exception: _Exception; safecall;\r\n function Get_ReturnValue: OleVariant; safecall;\r\n property OutArgCount: Integer read Get_OutArgCount;\r\n property OutArgs: PSafeArray read Get_OutArgs;\r\n property Exception: _Exception read Get_Exception;\r\n property ReturnValue: OleVariant read Get_ReturnValue;\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: IMethodReturnMessageDisp\r\n// Flags: (4416) Dual OleAutomation Dispatchable\r\n// GUID: {F617690A-55F4-36AF-9149-D199831F8594}\r\n// *********************************************************************//\r\n IMethodReturnMessageDisp = dispinterface\r\n ['{F617690A-55F4-36AF-9149-D199831F8594}']\r\n property OutArgCount: Integer readonly dispid 1610743808;\r\n function GetOutArgName(index: Integer): WideString; dispid 1610743809;\r\n function GetOutArg(argNum: Integer): OleVariant; dispid 1610743810;\r\n property OutArgs: {??PSafeArray}OleVariant readonly dispid 1610743811;\r\n property Exception: _Exception readonly dispid 1610743812;\r\n property ReturnValue: OleVariant readonly dispid 1610743813;\r\n end;\r\n {$EXTERNALSYM IMethodReturnMessageDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: IConstructionReturnMessage\r\n// Flags: (4416) Dual OleAutomation Dispatchable\r\n// GUID: {CA0AB564-F5E9-3A7F-A80B-EB0AEEFA44E9}\r\n// *********************************************************************//\r\n IConstructionReturnMessage = interface(IDispatch)\r\n ['{CA0AB564-F5E9-3A7F-A80B-EB0AEEFA44E9}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: IConstructionReturnMessageDisp\r\n// Flags: (4416) Dual OleAutomation Dispatchable\r\n// GUID: {CA0AB564-F5E9-3A7F-A80B-EB0AEEFA44E9}\r\n// *********************************************************************//\r\n IConstructionReturnMessageDisp = dispinterface\r\n ['{CA0AB564-F5E9-3A7F-A80B-EB0AEEFA44E9}']\r\n end;\r\n {$EXTERNALSYM IConstructionReturnMessageDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: IChannelReceiverHook\r\n// Flags: (4416) Dual OleAutomation Dispatchable\r\n// GUID: {3A02D3F7-3F40-3022-853D-CFDA765182FE}\r\n// *********************************************************************//\r\n IChannelReceiverHook = interface(IDispatch)\r\n ['{3A02D3F7-3F40-3022-853D-CFDA765182FE}']\r\n function Get_ChannelScheme: WideString; safecall;\r\n function Get_WantsToListen: WordBool; safecall;\r\n function Get_ChannelSinkChain: IServerChannelSink; safecall;\r\n procedure AddHookChannelUri(const channelUri: WideString); safecall;\r\n property ChannelScheme: WideString read Get_ChannelScheme;\r\n property WantsToListen: WordBool read Get_WantsToListen;\r\n property ChannelSinkChain: IServerChannelSink read Get_ChannelSinkChain;\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: IChannelReceiverHookDisp\r\n// Flags: (4416) Dual OleAutomation Dispatchable\r\n// GUID: {3A02D3F7-3F40-3022-853D-CFDA765182FE}\r\n// *********************************************************************//\r\n IChannelReceiverHookDisp = dispinterface\r\n ['{3A02D3F7-3F40-3022-853D-CFDA765182FE}']\r\n property ChannelScheme: WideString readonly dispid 1610743808;\r\n property WantsToListen: WordBool readonly dispid 1610743809;\r\n property ChannelSinkChain: IServerChannelSink readonly dispid 1610743810;\r\n procedure AddHookChannelUri(const channelUri: WideString); dispid 1610743811;\r\n end;\r\n {$EXTERNALSYM IChannelReceiverHookDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: IClientChannelSinkProvider\r\n// Flags: (4416) Dual OleAutomation Dispatchable\r\n// GUID: {3F8742C2-AC57-3440-A283-FE5FF4C75025}\r\n// *********************************************************************//\r\n IClientChannelSinkProvider = interface(IDispatch)\r\n ['{3F8742C2-AC57-3440-A283-FE5FF4C75025}']\r\n function CreateSink(const channel: IChannelSender; const Url: WideString; \r\n remoteChannelData: OleVariant): IClientChannelSink; safecall;\r\n function Get_Next: IClientChannelSinkProvider; safecall;\r\n procedure _Set_Next(const pRetVal: IClientChannelSinkProvider); safecall;\r\n property Next: IClientChannelSinkProvider read Get_Next;\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: IClientChannelSinkProviderDisp\r\n// Flags: (4416) Dual OleAutomation Dispatchable\r\n// GUID: {3F8742C2-AC57-3440-A283-FE5FF4C75025}\r\n// *********************************************************************//\r\n IClientChannelSinkProviderDisp = dispinterface\r\n ['{3F8742C2-AC57-3440-A283-FE5FF4C75025}']\r\n function CreateSink(const channel: IChannelSender; const Url: WideString; \r\n remoteChannelData: OleVariant): IClientChannelSink; dispid 1610743808;\r\n property Next: IClientChannelSinkProvider readonly dispid 1610743809;\r\n end;\r\n {$EXTERNALSYM IClientChannelSinkProviderDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: IClientFormatterSinkProvider\r\n// Flags: (4416) Dual OleAutomation Dispatchable\r\n// GUID: {6D94B6F3-DA91-3C2F-B876-083769667468}\r\n// *********************************************************************//\r\n IClientFormatterSinkProvider = interface(IDispatch)\r\n ['{6D94B6F3-DA91-3C2F-B876-083769667468}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: IClientFormatterSinkProviderDisp\r\n// Flags: (4416) Dual OleAutomation Dispatchable\r\n// GUID: {6D94B6F3-DA91-3C2F-B876-083769667468}\r\n// *********************************************************************//\r\n IClientFormatterSinkProviderDisp = dispinterface\r\n ['{6D94B6F3-DA91-3C2F-B876-083769667468}']\r\n end;\r\n {$EXTERNALSYM IClientFormatterSinkProviderDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: IServerFormatterSinkProvider\r\n// Flags: (4416) Dual OleAutomation Dispatchable\r\n// GUID: {042B5200-4317-3E4D-B653-7E9A08F1A5F2}\r\n// *********************************************************************//\r\n IServerFormatterSinkProvider = interface(IDispatch)\r\n ['{042B5200-4317-3E4D-B653-7E9A08F1A5F2}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: IServerFormatterSinkProviderDisp\r\n// Flags: (4416) Dual OleAutomation Dispatchable\r\n// GUID: {042B5200-4317-3E4D-B653-7E9A08F1A5F2}\r\n// *********************************************************************//\r\n IServerFormatterSinkProviderDisp = dispinterface\r\n ['{042B5200-4317-3E4D-B653-7E9A08F1A5F2}']\r\n end;\r\n {$EXTERNALSYM IServerFormatterSinkProviderDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: IClientChannelSink\r\n// Flags: (4416) Dual OleAutomation Dispatchable\r\n// GUID: {FF726320-6B92-3E6C-AAAC-F97063D0B142}\r\n// *********************************************************************//\r\n IClientChannelSink = interface(IDispatch)\r\n ['{FF726320-6B92-3E6C-AAAC-F97063D0B142}']\r\n procedure ProcessMessage(const msg: IMessage; const requestHeaders: ITransportHeaders; \r\n const requestStream: _Stream; out responseHeaders: ITransportHeaders; \r\n out responseStream: _Stream); safecall;\r\n procedure AsyncProcessRequest(const sinkStack: IClientChannelSinkStack; const msg: IMessage; \r\n const headers: ITransportHeaders; const Stream: _Stream); safecall;\r\n procedure AsyncProcessResponse(const sinkStack: IClientResponseChannelSinkStack; \r\n state: OleVariant; const headers: ITransportHeaders; \r\n const Stream: _Stream); safecall;\r\n function GetRequestStream(const msg: IMessage; const headers: ITransportHeaders): _Stream; safecall;\r\n function Get_NextChannelSink: IClientChannelSink; safecall;\r\n property NextChannelSink: IClientChannelSink read Get_NextChannelSink;\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: IClientChannelSinkDisp\r\n// Flags: (4416) Dual OleAutomation Dispatchable\r\n// GUID: {FF726320-6B92-3E6C-AAAC-F97063D0B142}\r\n// *********************************************************************//\r\n IClientChannelSinkDisp = dispinterface\r\n ['{FF726320-6B92-3E6C-AAAC-F97063D0B142}']\r\n procedure ProcessMessage(const msg: IMessage; const requestHeaders: ITransportHeaders; \r\n const requestStream: _Stream; out responseHeaders: ITransportHeaders; \r\n out responseStream: _Stream); dispid 1610743808;\r\n procedure AsyncProcessRequest(const sinkStack: IClientChannelSinkStack; const msg: IMessage; \r\n const headers: ITransportHeaders; const Stream: _Stream); dispid 1610743809;\r\n procedure AsyncProcessResponse(const sinkStack: IClientResponseChannelSinkStack; \r\n state: OleVariant; const headers: ITransportHeaders; \r\n const Stream: _Stream); dispid 1610743810;\r\n function GetRequestStream(const msg: IMessage; const headers: ITransportHeaders): _Stream; dispid 1610743811;\r\n property NextChannelSink: IClientChannelSink readonly dispid 1610743812;\r\n end;\r\n {$EXTERNALSYM IClientChannelSinkDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: IClientFormatterSink\r\n// Flags: (4416) Dual OleAutomation Dispatchable\r\n// GUID: {46527C03-B144-3CF0-86B3-B8776148A6E9}\r\n// *********************************************************************//\r\n IClientFormatterSink = interface(IDispatch)\r\n ['{46527C03-B144-3CF0-86B3-B8776148A6E9}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: IClientFormatterSinkDisp\r\n// Flags: (4416) Dual OleAutomation Dispatchable\r\n// GUID: {46527C03-B144-3CF0-86B3-B8776148A6E9}\r\n// *********************************************************************//\r\n IClientFormatterSinkDisp = dispinterface\r\n ['{46527C03-B144-3CF0-86B3-B8776148A6E9}']\r\n end;\r\n {$EXTERNALSYM IClientFormatterSinkDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: IChannelDataStore\r\n// Flags: (4416) Dual OleAutomation Dispatchable\r\n// GUID: {1E250CCD-DC30-3217-A7E4-148F375A0088}\r\n// *********************************************************************//\r\n IChannelDataStore = interface(IDispatch)\r\n ['{1E250CCD-DC30-3217-A7E4-148F375A0088}']\r\n function Get_ChannelUris: PSafeArray; safecall;\r\n function Get_Item(key: OleVariant): OleVariant; safecall;\r\n procedure _Set_Item(key: OleVariant; pRetVal: OleVariant); safecall;\r\n property ChannelUris: PSafeArray read Get_ChannelUris;\r\n property Item[key: OleVariant]: OleVariant read Get_Item write _Set_Item; default;\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: IChannelDataStoreDisp\r\n// Flags: (4416) Dual OleAutomation Dispatchable\r\n// GUID: {1E250CCD-DC30-3217-A7E4-148F375A0088}\r\n// *********************************************************************//\r\n IChannelDataStoreDisp = dispinterface\r\n ['{1E250CCD-DC30-3217-A7E4-148F375A0088}']\r\n property ChannelUris: {??PSafeArray}OleVariant readonly dispid 1610743808;\r\n property Item[key: OleVariant]: OleVariant dispid 0; default;\r\n end;\r\n {$EXTERNALSYM IChannelDataStoreDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _ChannelDataStore\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {AA6DA581-F972-36DE-A53B-7585428A68AB}\r\n// *********************************************************************//\r\n _ChannelDataStore = interface(IDispatch)\r\n ['{AA6DA581-F972-36DE-A53B-7585428A68AB}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _ChannelDataStoreDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {AA6DA581-F972-36DE-A53B-7585428A68AB}\r\n// *********************************************************************//\r\n _ChannelDataStoreDisp = dispinterface\r\n ['{AA6DA581-F972-36DE-A53B-7585428A68AB}']\r\n end;\r\n {$EXTERNALSYM _ChannelDataStoreDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: ITransportHeaders\r\n// Flags: (4416) Dual OleAutomation Dispatchable\r\n// GUID: {1AC82FBE-4FF0-383C-BBFD-FE40ECB3628D}\r\n// *********************************************************************//\r\n ITransportHeaders = interface(IDispatch)\r\n ['{1AC82FBE-4FF0-383C-BBFD-FE40ECB3628D}']\r\n function Get_Item(key: OleVariant): OleVariant; safecall;\r\n procedure _Set_Item(key: OleVariant; pRetVal: OleVariant); safecall;\r\n function GetEnumerator: IEnumVARIANT; safecall;\r\n property Item[key: OleVariant]: OleVariant read Get_Item write _Set_Item; default;\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: ITransportHeadersDisp\r\n// Flags: (4416) Dual OleAutomation Dispatchable\r\n// GUID: {1AC82FBE-4FF0-383C-BBFD-FE40ECB3628D}\r\n// *********************************************************************//\r\n ITransportHeadersDisp = dispinterface\r\n ['{1AC82FBE-4FF0-383C-BBFD-FE40ECB3628D}']\r\n property Item[key: OleVariant]: OleVariant dispid 0; default;\r\n function GetEnumerator: IEnumVARIANT; dispid -4;\r\n end;\r\n {$EXTERNALSYM ITransportHeadersDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _TransportHeaders\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {65887F70-C646-3A66-8697-8A3F7D8FE94D}\r\n// *********************************************************************//\r\n _TransportHeaders = interface(IDispatch)\r\n ['{65887F70-C646-3A66-8697-8A3F7D8FE94D}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _TransportHeadersDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {65887F70-C646-3A66-8697-8A3F7D8FE94D}\r\n// *********************************************************************//\r\n _TransportHeadersDisp = dispinterface\r\n ['{65887F70-C646-3A66-8697-8A3F7D8FE94D}']\r\n end;\r\n {$EXTERNALSYM _TransportHeadersDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _SinkProviderData\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {A18545B7-E5EE-31EE-9B9B-41199B11C995}\r\n// *********************************************************************//\r\n _SinkProviderData = interface(IDispatch)\r\n ['{A18545B7-E5EE-31EE-9B9B-41199B11C995}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _SinkProviderDataDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {A18545B7-E5EE-31EE-9B9B-41199B11C995}\r\n// *********************************************************************//\r\n _SinkProviderDataDisp = dispinterface\r\n ['{A18545B7-E5EE-31EE-9B9B-41199B11C995}']\r\n end;\r\n {$EXTERNALSYM _SinkProviderDataDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _BaseChannelObjectWithProperties\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {A1329EC9-E567-369F-8258-18366D89EAF8}\r\n// *********************************************************************//\r\n _BaseChannelObjectWithProperties = interface(IDispatch)\r\n ['{A1329EC9-E567-369F-8258-18366D89EAF8}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _BaseChannelObjectWithPropertiesDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {A1329EC9-E567-369F-8258-18366D89EAF8}\r\n// *********************************************************************//\r\n _BaseChannelObjectWithPropertiesDisp = dispinterface\r\n ['{A1329EC9-E567-369F-8258-18366D89EAF8}']\r\n end;\r\n {$EXTERNALSYM _BaseChannelObjectWithPropertiesDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _BaseChannelSinkWithProperties\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {8AF3451E-154D-3D86-80D8-F8478B9733ED}\r\n// *********************************************************************//\r\n _BaseChannelSinkWithProperties = interface(IDispatch)\r\n ['{8AF3451E-154D-3D86-80D8-F8478B9733ED}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _BaseChannelSinkWithPropertiesDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {8AF3451E-154D-3D86-80D8-F8478B9733ED}\r\n// *********************************************************************//\r\n _BaseChannelSinkWithPropertiesDisp = dispinterface\r\n ['{8AF3451E-154D-3D86-80D8-F8478B9733ED}']\r\n end;\r\n {$EXTERNALSYM _BaseChannelSinkWithPropertiesDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _BaseChannelWithProperties\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {94BB98ED-18BB-3843-A7FE-642824AB4E01}\r\n// *********************************************************************//\r\n _BaseChannelWithProperties = interface(IDispatch)\r\n ['{94BB98ED-18BB-3843-A7FE-642824AB4E01}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _BaseChannelWithPropertiesDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {94BB98ED-18BB-3843-A7FE-642824AB4E01}\r\n// *********************************************************************//\r\n _BaseChannelWithPropertiesDisp = dispinterface\r\n ['{94BB98ED-18BB-3843-A7FE-642824AB4E01}']\r\n end;\r\n {$EXTERNALSYM _BaseChannelWithPropertiesDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: IContributeClientContextSink\r\n// Flags: (4416) Dual OleAutomation Dispatchable\r\n// GUID: {4DB956B7-69D0-312A-AA75-44FB55FD5D4B}\r\n// *********************************************************************//\r\n IContributeClientContextSink = interface(IDispatch)\r\n ['{4DB956B7-69D0-312A-AA75-44FB55FD5D4B}']\r\n function GetClientContextSink(const NextSink: IMessageSink): IMessageSink; safecall;\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: IContributeClientContextSinkDisp\r\n// Flags: (4416) Dual OleAutomation Dispatchable\r\n// GUID: {4DB956B7-69D0-312A-AA75-44FB55FD5D4B}\r\n// *********************************************************************//\r\n IContributeClientContextSinkDisp = dispinterface\r\n ['{4DB956B7-69D0-312A-AA75-44FB55FD5D4B}']\r\n function GetClientContextSink(const NextSink: IMessageSink): IMessageSink; dispid 1610743808;\r\n end;\r\n {$EXTERNALSYM IContributeClientContextSinkDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: IContributeDynamicSink\r\n// Flags: (4416) Dual OleAutomation Dispatchable\r\n// GUID: {A0FE9B86-0C06-32CE-85FA-2FF1B58697FB}\r\n// *********************************************************************//\r\n IContributeDynamicSink = interface(IDispatch)\r\n ['{A0FE9B86-0C06-32CE-85FA-2FF1B58697FB}']\r\n function GetDynamicSink: IDynamicMessageSink; safecall;\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: IContributeDynamicSinkDisp\r\n// Flags: (4416) Dual OleAutomation Dispatchable\r\n// GUID: {A0FE9B86-0C06-32CE-85FA-2FF1B58697FB}\r\n// *********************************************************************//\r\n IContributeDynamicSinkDisp = dispinterface\r\n ['{A0FE9B86-0C06-32CE-85FA-2FF1B58697FB}']\r\n function GetDynamicSink: IDynamicMessageSink; dispid 1610743808;\r\n end;\r\n {$EXTERNALSYM IContributeDynamicSinkDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: IContributeEnvoySink\r\n// Flags: (4416) Dual OleAutomation Dispatchable\r\n// GUID: {124777B6-0308-3569-97E5-E6FE88EAE4EB}\r\n// *********************************************************************//\r\n IContributeEnvoySink = interface(IDispatch)\r\n ['{124777B6-0308-3569-97E5-E6FE88EAE4EB}']\r\n function GetEnvoySink(const obj: _MarshalByRefObject; const NextSink: IMessageSink): IMessageSink; safecall;\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: IContributeEnvoySinkDisp\r\n// Flags: (4416) Dual OleAutomation Dispatchable\r\n// GUID: {124777B6-0308-3569-97E5-E6FE88EAE4EB}\r\n// *********************************************************************//\r\n IContributeEnvoySinkDisp = dispinterface\r\n ['{124777B6-0308-3569-97E5-E6FE88EAE4EB}']\r\n function GetEnvoySink(const obj: _MarshalByRefObject; const NextSink: IMessageSink): IMessageSink; dispid 1610743808;\r\n end;\r\n {$EXTERNALSYM IContributeEnvoySinkDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: IContributeObjectSink\r\n// Flags: (4416) Dual OleAutomation Dispatchable\r\n// GUID: {6A5D38BC-2789-3546-81A1-F10C0FB59366}\r\n// *********************************************************************//\r\n IContributeObjectSink = interface(IDispatch)\r\n ['{6A5D38BC-2789-3546-81A1-F10C0FB59366}']\r\n function GetObjectSink(const obj: _MarshalByRefObject; const NextSink: IMessageSink): IMessageSink; safecall;\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: IContributeObjectSinkDisp\r\n// Flags: (4416) Dual OleAutomation Dispatchable\r\n// GUID: {6A5D38BC-2789-3546-81A1-F10C0FB59366}\r\n// *********************************************************************//\r\n IContributeObjectSinkDisp = dispinterface\r\n ['{6A5D38BC-2789-3546-81A1-F10C0FB59366}']\r\n function GetObjectSink(const obj: _MarshalByRefObject; const NextSink: IMessageSink): IMessageSink; dispid 1610743808;\r\n end;\r\n {$EXTERNALSYM IContributeObjectSinkDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: IContributeServerContextSink\r\n// Flags: (4416) Dual OleAutomation Dispatchable\r\n// GUID: {0CAA23EC-F78C-39C9-8D25-B7A9CE4097A7}\r\n// *********************************************************************//\r\n IContributeServerContextSink = interface(IDispatch)\r\n ['{0CAA23EC-F78C-39C9-8D25-B7A9CE4097A7}']\r\n function GetServerContextSink(const NextSink: IMessageSink): IMessageSink; safecall;\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: IContributeServerContextSinkDisp\r\n// Flags: (4416) Dual OleAutomation Dispatchable\r\n// GUID: {0CAA23EC-F78C-39C9-8D25-B7A9CE4097A7}\r\n// *********************************************************************//\r\n IContributeServerContextSinkDisp = dispinterface\r\n ['{0CAA23EC-F78C-39C9-8D25-B7A9CE4097A7}']\r\n function GetServerContextSink(const NextSink: IMessageSink): IMessageSink; dispid 1610743808;\r\n end;\r\n {$EXTERNALSYM IContributeServerContextSinkDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: IDynamicProperty\r\n// Flags: (4416) Dual OleAutomation Dispatchable\r\n// GUID: {00A358D4-4D58-3B9D-8FB6-FB7F6BC1713B}\r\n// *********************************************************************//\r\n IDynamicProperty = interface(IDispatch)\r\n ['{00A358D4-4D58-3B9D-8FB6-FB7F6BC1713B}']\r\n function Get_name: WideString; safecall;\r\n property name: WideString read Get_name;\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: IDynamicPropertyDisp\r\n// Flags: (4416) Dual OleAutomation Dispatchable\r\n// GUID: {00A358D4-4D58-3B9D-8FB6-FB7F6BC1713B}\r\n// *********************************************************************//\r\n IDynamicPropertyDisp = dispinterface\r\n ['{00A358D4-4D58-3B9D-8FB6-FB7F6BC1713B}']\r\n property name: WideString readonly dispid 1610743808;\r\n end;\r\n {$EXTERNALSYM IDynamicPropertyDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: IDynamicMessageSink\r\n// Flags: (4416) Dual OleAutomation Dispatchable\r\n// GUID: {C74076BB-8A2D-3C20-A542-625329E9AF04}\r\n// *********************************************************************//\r\n IDynamicMessageSink = interface(IDispatch)\r\n ['{C74076BB-8A2D-3C20-A542-625329E9AF04}']\r\n procedure ProcessMessageStart(const reqMsg: IMessage; bCliSide: WordBool; bAsync: WordBool); safecall;\r\n procedure ProcessMessageFinish(const replyMsg: IMessage; bCliSide: WordBool; bAsync: WordBool); safecall;\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: IDynamicMessageSinkDisp\r\n// Flags: (4416) Dual OleAutomation Dispatchable\r\n// GUID: {C74076BB-8A2D-3C20-A542-625329E9AF04}\r\n// *********************************************************************//\r\n IDynamicMessageSinkDisp = dispinterface\r\n ['{C74076BB-8A2D-3C20-A542-625329E9AF04}']\r\n procedure ProcessMessageStart(const reqMsg: IMessage; bCliSide: WordBool; bAsync: WordBool); dispid 1610743808;\r\n procedure ProcessMessageFinish(const replyMsg: IMessage; bCliSide: WordBool; bAsync: WordBool); dispid 1610743809;\r\n end;\r\n {$EXTERNALSYM IDynamicMessageSinkDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: ILease\r\n// Flags: (4416) Dual OleAutomation Dispatchable\r\n// GUID: {53A561F2-CBBF-3748-BFFE-2180002DB3DF}\r\n// *********************************************************************//\r\n ILease = interface(IDispatch)\r\n ['{53A561F2-CBBF-3748-BFFE-2180002DB3DF}']\r\n procedure Register(const obj: ISponsor; renewalTime: TimeSpan); safecall;\r\n procedure Register_2(const obj: ISponsor); safecall;\r\n procedure Unregister(const obj: ISponsor); safecall;\r\n function Renew(renewalTime: TimeSpan): TimeSpan; safecall;\r\n function Get_RenewOnCallTime: TimeSpan; safecall;\r\n procedure Set_RenewOnCallTime(pRetVal: TimeSpan); safecall;\r\n function Get_SponsorshipTimeout: TimeSpan; safecall;\r\n procedure Set_SponsorshipTimeout(pRetVal: TimeSpan); safecall;\r\n function Get_InitialLeaseTime: TimeSpan; safecall;\r\n procedure Set_InitialLeaseTime(pRetVal: TimeSpan); safecall;\r\n function Get_CurrentLeaseTime: TimeSpan; safecall;\r\n function Get_CurrentState: LeaseState; safecall;\r\n property RenewOnCallTime: TimeSpan read Get_RenewOnCallTime;\r\n property SponsorshipTimeout: TimeSpan read Get_SponsorshipTimeout;\r\n property InitialLeaseTime: TimeSpan read Get_InitialLeaseTime;\r\n property CurrentLeaseTime: TimeSpan read Get_CurrentLeaseTime;\r\n property CurrentState: LeaseState read Get_CurrentState;\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: ILeaseDisp\r\n// Flags: (4416) Dual OleAutomation Dispatchable\r\n// GUID: {53A561F2-CBBF-3748-BFFE-2180002DB3DF}\r\n// *********************************************************************//\r\n ILeaseDisp = dispinterface\r\n ['{53A561F2-CBBF-3748-BFFE-2180002DB3DF}']\r\n procedure Register(const obj: ISponsor; renewalTime: {??TimeSpan}OleVariant); dispid 1610743808;\r\n procedure Register_2(const obj: ISponsor); dispid 1610743809;\r\n procedure Unregister(const obj: ISponsor); dispid 1610743810;\r\n function Renew(renewalTime: {??TimeSpan}OleVariant): {??TimeSpan}OleVariant; dispid 1610743811;\r\n property RenewOnCallTime: {??TimeSpan}OleVariant readonly dispid 1610743812;\r\n property SponsorshipTimeout: {??TimeSpan}OleVariant readonly dispid 1610743814;\r\n property InitialLeaseTime: {??TimeSpan}OleVariant readonly dispid 1610743816;\r\n property CurrentLeaseTime: {??TimeSpan}OleVariant readonly dispid 1610743818;\r\n property CurrentState: LeaseState readonly dispid 1610743819;\r\n end;\r\n {$EXTERNALSYM ILeaseDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: IMessageCtrl\r\n// Flags: (4416) Dual OleAutomation Dispatchable\r\n// GUID: {3677CBB0-784D-3C15-BBC8-75CD7DC3901E}\r\n// *********************************************************************//\r\n IMessageCtrl = interface(IDispatch)\r\n ['{3677CBB0-784D-3C15-BBC8-75CD7DC3901E}']\r\n procedure Cancel(msToCancel: Integer); safecall;\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: IMessageCtrlDisp\r\n// Flags: (4416) Dual OleAutomation Dispatchable\r\n// GUID: {3677CBB0-784D-3C15-BBC8-75CD7DC3901E}\r\n// *********************************************************************//\r\n IMessageCtrlDisp = dispinterface\r\n ['{3677CBB0-784D-3C15-BBC8-75CD7DC3901E}']\r\n procedure Cancel(msToCancel: Integer); dispid 1610743808;\r\n end;\r\n {$EXTERNALSYM IMessageCtrlDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: IRemotingFormatter\r\n// Flags: (4416) Dual OleAutomation Dispatchable\r\n// GUID: {AE1850FD-3596-3727-A242-2FC31C5A0312}\r\n// *********************************************************************//\r\n IRemotingFormatter = interface(IDispatch)\r\n ['{AE1850FD-3596-3727-A242-2FC31C5A0312}']\r\n function Deserialize(const serializationStream: _Stream; const handler: _HeaderHandler): OleVariant; safecall;\r\n procedure Serialize(const serializationStream: _Stream; graph: OleVariant; headers: PSafeArray); safecall;\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: IRemotingFormatterDisp\r\n// Flags: (4416) Dual OleAutomation Dispatchable\r\n// GUID: {AE1850FD-3596-3727-A242-2FC31C5A0312}\r\n// *********************************************************************//\r\n IRemotingFormatterDisp = dispinterface\r\n ['{AE1850FD-3596-3727-A242-2FC31C5A0312}']\r\n function Deserialize(const serializationStream: _Stream; const handler: _HeaderHandler): OleVariant; dispid 1610743808;\r\n procedure Serialize(const serializationStream: _Stream; graph: OleVariant; \r\n headers: {??PSafeArray}OleVariant); dispid 1610743809;\r\n end;\r\n {$EXTERNALSYM IRemotingFormatterDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _LifetimeServices\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {B0AD9A21-5439-3D88-8975-4018B828D74C}\r\n// *********************************************************************//\r\n _LifetimeServices = interface(IDispatch)\r\n ['{B0AD9A21-5439-3D88-8975-4018B828D74C}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _LifetimeServicesDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {B0AD9A21-5439-3D88-8975-4018B828D74C}\r\n// *********************************************************************//\r\n _LifetimeServicesDisp = dispinterface\r\n ['{B0AD9A21-5439-3D88-8975-4018B828D74C}']\r\n end;\r\n {$EXTERNALSYM _LifetimeServicesDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _ReturnMessage\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {0EEFF4C2-84BF-3E4E-BF22-B7BDBB5DF899}\r\n// *********************************************************************//\r\n _ReturnMessage = interface(IDispatch)\r\n ['{0EEFF4C2-84BF-3E4E-BF22-B7BDBB5DF899}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _ReturnMessageDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {0EEFF4C2-84BF-3E4E-BF22-B7BDBB5DF899}\r\n// *********************************************************************//\r\n _ReturnMessageDisp = dispinterface\r\n ['{0EEFF4C2-84BF-3E4E-BF22-B7BDBB5DF899}']\r\n end;\r\n {$EXTERNALSYM _ReturnMessageDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _MethodCall\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {95E01216-5467-371B-8597-4074402CCB06}\r\n// *********************************************************************//\r\n _MethodCall = interface(IDispatch)\r\n ['{95E01216-5467-371B-8597-4074402CCB06}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _MethodCallDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {95E01216-5467-371B-8597-4074402CCB06}\r\n// *********************************************************************//\r\n _MethodCallDisp = dispinterface\r\n ['{95E01216-5467-371B-8597-4074402CCB06}']\r\n end;\r\n {$EXTERNALSYM _MethodCallDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _ConstructionCall\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {A2246AE7-EB81-3A20-8E70-C9FA341C7E10}\r\n// *********************************************************************//\r\n _ConstructionCall = interface(IDispatch)\r\n ['{A2246AE7-EB81-3A20-8E70-C9FA341C7E10}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _ConstructionCallDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {A2246AE7-EB81-3A20-8E70-C9FA341C7E10}\r\n// *********************************************************************//\r\n _ConstructionCallDisp = dispinterface\r\n ['{A2246AE7-EB81-3A20-8E70-C9FA341C7E10}']\r\n end;\r\n {$EXTERNALSYM _ConstructionCallDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _MethodResponse\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {9E9EA93A-D000-3AB9-BFCA-DDEB398A55B9}\r\n// *********************************************************************//\r\n _MethodResponse = interface(IDispatch)\r\n ['{9E9EA93A-D000-3AB9-BFCA-DDEB398A55B9}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _MethodResponseDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {9E9EA93A-D000-3AB9-BFCA-DDEB398A55B9}\r\n// *********************************************************************//\r\n _MethodResponseDisp = dispinterface\r\n ['{9E9EA93A-D000-3AB9-BFCA-DDEB398A55B9}']\r\n end;\r\n {$EXTERNALSYM _MethodResponseDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: IFieldInfo\r\n// Flags: (4416) Dual OleAutomation Dispatchable\r\n// GUID: {CC18FD4D-AA2D-3AB4-9848-584BBAE4AB44}\r\n// *********************************************************************//\r\n IFieldInfo = interface(IDispatch)\r\n ['{CC18FD4D-AA2D-3AB4-9848-584BBAE4AB44}']\r\n function Get_FieldNames: PSafeArray; safecall;\r\n procedure Set_FieldNames(pRetVal: PSafeArray); safecall;\r\n function Get_FieldTypes: PSafeArray; safecall;\r\n procedure Set_FieldTypes(pRetVal: PSafeArray); safecall;\r\n property FieldNames: PSafeArray read Get_FieldNames;\r\n property FieldTypes: PSafeArray read Get_FieldTypes;\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: IFieldInfoDisp\r\n// Flags: (4416) Dual OleAutomation Dispatchable\r\n// GUID: {CC18FD4D-AA2D-3AB4-9848-584BBAE4AB44}\r\n// *********************************************************************//\r\n IFieldInfoDisp = dispinterface\r\n ['{CC18FD4D-AA2D-3AB4-9848-584BBAE4AB44}']\r\n property FieldNames: {??PSafeArray}OleVariant readonly dispid 1610743808;\r\n property FieldTypes: {??PSafeArray}OleVariant readonly dispid 1610743810;\r\n end;\r\n {$EXTERNALSYM IFieldInfoDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _ConstructionResponse\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {BE457280-6FFA-3E76-9822-83DE63C0C4E0}\r\n// *********************************************************************//\r\n _ConstructionResponse = interface(IDispatch)\r\n ['{BE457280-6FFA-3E76-9822-83DE63C0C4E0}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _ConstructionResponseDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {BE457280-6FFA-3E76-9822-83DE63C0C4E0}\r\n// *********************************************************************//\r\n _ConstructionResponseDisp = dispinterface\r\n ['{BE457280-6FFA-3E76-9822-83DE63C0C4E0}']\r\n end;\r\n {$EXTERNALSYM _ConstructionResponseDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _MethodReturnMessageWrapper\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {89304439-A24F-30F6-9A8F-89CE472D85DA}\r\n// *********************************************************************//\r\n _MethodReturnMessageWrapper = interface(IDispatch)\r\n ['{89304439-A24F-30F6-9A8F-89CE472D85DA}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _MethodReturnMessageWrapperDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {89304439-A24F-30F6-9A8F-89CE472D85DA}\r\n// *********************************************************************//\r\n _MethodReturnMessageWrapperDisp = dispinterface\r\n ['{89304439-A24F-30F6-9A8F-89CE472D85DA}']\r\n end;\r\n {$EXTERNALSYM _MethodReturnMessageWrapperDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _ObjectHandle\r\n// Flags: (4560) Hidden Dual NonExtensible OleAutomation Dispatchable\r\n// GUID: {EA675B47-64E0-3B5F-9BE7-F7DC2990730D}\r\n// *********************************************************************//\r\n _ObjectHandle = interface(IDispatch)\r\n ['{EA675B47-64E0-3B5F-9BE7-F7DC2990730D}']\r\n function Get_ToString: WideString; safecall;\r\n function Equals(obj: OleVariant): WordBool; safecall;\r\n function GetHashCode: Integer; safecall;\r\n function GetType: _Type; safecall;\r\n function GetLifetimeService: OleVariant; safecall;\r\n function InitializeLifetimeService: OleVariant; safecall;\r\n function CreateObjRef(const requestedType: _Type): _ObjRef; safecall;\r\n function Unwrap: OleVariant; safecall;\r\n property ToString: WideString read Get_ToString;\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _ObjectHandleDisp\r\n// Flags: (4560) Hidden Dual NonExtensible OleAutomation Dispatchable\r\n// GUID: {EA675B47-64E0-3B5F-9BE7-F7DC2990730D}\r\n// *********************************************************************//\r\n _ObjectHandleDisp = dispinterface\r\n ['{EA675B47-64E0-3B5F-9BE7-F7DC2990730D}']\r\n property ToString: WideString readonly dispid 0;\r\n function Equals(obj: OleVariant): WordBool; dispid 1610743809;\r\n function GetHashCode: Integer; dispid 1610743810;\r\n function GetType: _Type; dispid 1610743811;\r\n function GetLifetimeService: OleVariant; dispid 1610743812;\r\n function InitializeLifetimeService: OleVariant; dispid 1610743813;\r\n function CreateObjRef(const requestedType: _Type): _ObjRef; dispid 1610743814;\r\n function Unwrap: OleVariant; dispid 1610743815;\r\n end;\r\n {$EXTERNALSYM _ObjectHandleDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: IRemotingTypeInfo\r\n// Flags: (4416) Dual OleAutomation Dispatchable\r\n// GUID: {C09EFFA9-1FFE-3A52-A733-6236CBC45E7B}\r\n// *********************************************************************//\r\n IRemotingTypeInfo = interface(IDispatch)\r\n ['{C09EFFA9-1FFE-3A52-A733-6236CBC45E7B}']\r\n function Get_typeName: WideString; safecall;\r\n procedure Set_typeName(const pRetVal: WideString); safecall;\r\n function CanCastTo(const fromType: _Type; o: OleVariant): WordBool; safecall;\r\n property typeName: WideString read Get_typeName;\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: IRemotingTypeInfoDisp\r\n// Flags: (4416) Dual OleAutomation Dispatchable\r\n// GUID: {C09EFFA9-1FFE-3A52-A733-6236CBC45E7B}\r\n// *********************************************************************//\r\n IRemotingTypeInfoDisp = dispinterface\r\n ['{C09EFFA9-1FFE-3A52-A733-6236CBC45E7B}']\r\n property typeName: WideString readonly dispid 1610743808;\r\n function CanCastTo(const fromType: _Type; o: OleVariant): WordBool; dispid 1610743810;\r\n end;\r\n {$EXTERNALSYM IRemotingTypeInfoDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: IChannelInfo\r\n// Flags: (4416) Dual OleAutomation Dispatchable\r\n// GUID: {855E6566-014A-3FE8-AA70-1EAC771E3A88}\r\n// *********************************************************************//\r\n IChannelInfo = interface(IDispatch)\r\n ['{855E6566-014A-3FE8-AA70-1EAC771E3A88}']\r\n function Get_ChannelData: PSafeArray; safecall;\r\n procedure Set_ChannelData(pRetVal: PSafeArray); safecall;\r\n property ChannelData: PSafeArray read Get_ChannelData;\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: IChannelInfoDisp\r\n// Flags: (4416) Dual OleAutomation Dispatchable\r\n// GUID: {855E6566-014A-3FE8-AA70-1EAC771E3A88}\r\n// *********************************************************************//\r\n IChannelInfoDisp = dispinterface\r\n ['{855E6566-014A-3FE8-AA70-1EAC771E3A88}']\r\n property ChannelData: {??PSafeArray}OleVariant readonly dispid 1610743808;\r\n end;\r\n {$EXTERNALSYM IChannelInfoDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: IEnvoyInfo\r\n// Flags: (4416) Dual OleAutomation Dispatchable\r\n// GUID: {2A6E91B9-A874-38E4-99C2-C5D83D78140D}\r\n// *********************************************************************//\r\n IEnvoyInfo = interface(IDispatch)\r\n ['{2A6E91B9-A874-38E4-99C2-C5D83D78140D}']\r\n function Get_EnvoySinks: IMessageSink; safecall;\r\n procedure _Set_EnvoySinks(const pRetVal: IMessageSink); safecall;\r\n property EnvoySinks: IMessageSink read Get_EnvoySinks;\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: IEnvoyInfoDisp\r\n// Flags: (4416) Dual OleAutomation Dispatchable\r\n// GUID: {2A6E91B9-A874-38E4-99C2-C5D83D78140D}\r\n// *********************************************************************//\r\n IEnvoyInfoDisp = dispinterface\r\n ['{2A6E91B9-A874-38E4-99C2-C5D83D78140D}']\r\n property EnvoySinks: IMessageSink readonly dispid 1610743808;\r\n end;\r\n {$EXTERNALSYM IEnvoyInfoDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _ObjRef\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {1DD3CF3D-DF8E-32FF-91EC-E19AA10B63FB}\r\n// *********************************************************************//\r\n _ObjRef = interface(IDispatch)\r\n ['{1DD3CF3D-DF8E-32FF-91EC-E19AA10B63FB}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _ObjRefDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {1DD3CF3D-DF8E-32FF-91EC-E19AA10B63FB}\r\n// *********************************************************************//\r\n _ObjRefDisp = dispinterface\r\n ['{1DD3CF3D-DF8E-32FF-91EC-E19AA10B63FB}']\r\n end;\r\n {$EXTERNALSYM _ObjRefDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _OneWayAttribute\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {8FFEDC68-5233-3FA8-813D-405AABB33ECB}\r\n// *********************************************************************//\r\n _OneWayAttribute = interface(IDispatch)\r\n ['{8FFEDC68-5233-3FA8-813D-405AABB33ECB}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _OneWayAttributeDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {8FFEDC68-5233-3FA8-813D-405AABB33ECB}\r\n// *********************************************************************//\r\n _OneWayAttributeDisp = dispinterface\r\n ['{8FFEDC68-5233-3FA8-813D-405AABB33ECB}']\r\n end;\r\n {$EXTERNALSYM _OneWayAttributeDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _ProxyAttribute\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {D80FF312-2930-3680-A5E9-B48296C7415F}\r\n// *********************************************************************//\r\n _ProxyAttribute = interface(IDispatch)\r\n ['{D80FF312-2930-3680-A5E9-B48296C7415F}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _ProxyAttributeDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {D80FF312-2930-3680-A5E9-B48296C7415F}\r\n// *********************************************************************//\r\n _ProxyAttributeDisp = dispinterface\r\n ['{D80FF312-2930-3680-A5E9-B48296C7415F}']\r\n end;\r\n {$EXTERNALSYM _ProxyAttributeDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _RealProxy\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {E0CF3F77-C7C3-33DA-BEB4-46147FC905DE}\r\n// *********************************************************************//\r\n _RealProxy = interface(IDispatch)\r\n ['{E0CF3F77-C7C3-33DA-BEB4-46147FC905DE}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _RealProxyDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {E0CF3F77-C7C3-33DA-BEB4-46147FC905DE}\r\n// *********************************************************************//\r\n _RealProxyDisp = dispinterface\r\n ['{E0CF3F77-C7C3-33DA-BEB4-46147FC905DE}']\r\n end;\r\n {$EXTERNALSYM _RealProxyDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _SoapAttribute\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {725692A5-9E12-37F6-911C-E3DA77E5FACA}\r\n// *********************************************************************//\r\n _SoapAttribute = interface(IDispatch)\r\n ['{725692A5-9E12-37F6-911C-E3DA77E5FACA}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _SoapAttributeDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {725692A5-9E12-37F6-911C-E3DA77E5FACA}\r\n// *********************************************************************//\r\n _SoapAttributeDisp = dispinterface\r\n ['{725692A5-9E12-37F6-911C-E3DA77E5FACA}']\r\n end;\r\n {$EXTERNALSYM _SoapAttributeDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _SoapTypeAttribute\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {EBCDCD84-8C74-39FD-821C-F5EB3A2704D7}\r\n// *********************************************************************//\r\n _SoapTypeAttribute = interface(IDispatch)\r\n ['{EBCDCD84-8C74-39FD-821C-F5EB3A2704D7}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _SoapTypeAttributeDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {EBCDCD84-8C74-39FD-821C-F5EB3A2704D7}\r\n// *********************************************************************//\r\n _SoapTypeAttributeDisp = dispinterface\r\n ['{EBCDCD84-8C74-39FD-821C-F5EB3A2704D7}']\r\n end;\r\n {$EXTERNALSYM _SoapTypeAttributeDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _SoapMethodAttribute\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {C58145B5-BD5A-3896-95D9-B358F54FBC44}\r\n// *********************************************************************//\r\n _SoapMethodAttribute = interface(IDispatch)\r\n ['{C58145B5-BD5A-3896-95D9-B358F54FBC44}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _SoapMethodAttributeDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {C58145B5-BD5A-3896-95D9-B358F54FBC44}\r\n// *********************************************************************//\r\n _SoapMethodAttributeDisp = dispinterface\r\n ['{C58145B5-BD5A-3896-95D9-B358F54FBC44}']\r\n end;\r\n {$EXTERNALSYM _SoapMethodAttributeDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _SoapFieldAttribute\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {46A3F9FF-F73C-33C7-BCC3-1BEF4B25E4AE}\r\n// *********************************************************************//\r\n _SoapFieldAttribute = interface(IDispatch)\r\n ['{46A3F9FF-F73C-33C7-BCC3-1BEF4B25E4AE}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _SoapFieldAttributeDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {46A3F9FF-F73C-33C7-BCC3-1BEF4B25E4AE}\r\n// *********************************************************************//\r\n _SoapFieldAttributeDisp = dispinterface\r\n ['{46A3F9FF-F73C-33C7-BCC3-1BEF4B25E4AE}']\r\n end;\r\n {$EXTERNALSYM _SoapFieldAttributeDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _SoapParameterAttribute\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {C32ABFC9-3917-30BF-A7BC-44250BDFC5D8}\r\n// *********************************************************************//\r\n _SoapParameterAttribute = interface(IDispatch)\r\n ['{C32ABFC9-3917-30BF-A7BC-44250BDFC5D8}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _SoapParameterAttributeDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {C32ABFC9-3917-30BF-A7BC-44250BDFC5D8}\r\n// *********************************************************************//\r\n _SoapParameterAttributeDisp = dispinterface\r\n ['{C32ABFC9-3917-30BF-A7BC-44250BDFC5D8}']\r\n end;\r\n {$EXTERNALSYM _SoapParameterAttributeDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _RemotingConfiguration\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {4B10971E-D61D-373F-BC8D-2CCF31126215}\r\n// *********************************************************************//\r\n _RemotingConfiguration = interface(IDispatch)\r\n ['{4B10971E-D61D-373F-BC8D-2CCF31126215}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _RemotingConfigurationDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {4B10971E-D61D-373F-BC8D-2CCF31126215}\r\n// *********************************************************************//\r\n _RemotingConfigurationDisp = dispinterface\r\n ['{4B10971E-D61D-373F-BC8D-2CCF31126215}']\r\n end;\r\n {$EXTERNALSYM _RemotingConfigurationDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _System_Runtime_Remoting_TypeEntry\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {8359F3AB-643F-3BCF-91E8-16E779EDEBE1}\r\n// *********************************************************************//\r\n _System_Runtime_Remoting_TypeEntry = interface(IDispatch)\r\n ['{8359F3AB-643F-3BCF-91E8-16E779EDEBE1}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _System_Runtime_Remoting_TypeEntryDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {8359F3AB-643F-3BCF-91E8-16E779EDEBE1}\r\n// *********************************************************************//\r\n _System_Runtime_Remoting_TypeEntryDisp = dispinterface\r\n ['{8359F3AB-643F-3BCF-91E8-16E779EDEBE1}']\r\n end;\r\n {$EXTERNALSYM _System_Runtime_Remoting_TypeEntryDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _ActivatedClientTypeEntry\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {BAC12781-6865-3558-A8D1-F1CADD2806DD}\r\n// *********************************************************************//\r\n _ActivatedClientTypeEntry = interface(IDispatch)\r\n ['{BAC12781-6865-3558-A8D1-F1CADD2806DD}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _ActivatedClientTypeEntryDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {BAC12781-6865-3558-A8D1-F1CADD2806DD}\r\n// *********************************************************************//\r\n _ActivatedClientTypeEntryDisp = dispinterface\r\n ['{BAC12781-6865-3558-A8D1-F1CADD2806DD}']\r\n end;\r\n {$EXTERNALSYM _ActivatedClientTypeEntryDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _ActivatedServiceTypeEntry\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {94855A3B-5CA2-32CF-B1AB-48FD3915822C}\r\n// *********************************************************************//\r\n _ActivatedServiceTypeEntry = interface(IDispatch)\r\n ['{94855A3B-5CA2-32CF-B1AB-48FD3915822C}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _ActivatedServiceTypeEntryDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {94855A3B-5CA2-32CF-B1AB-48FD3915822C}\r\n// *********************************************************************//\r\n _ActivatedServiceTypeEntryDisp = dispinterface\r\n ['{94855A3B-5CA2-32CF-B1AB-48FD3915822C}']\r\n end;\r\n {$EXTERNALSYM _ActivatedServiceTypeEntryDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _WellKnownClientTypeEntry\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {4D0BC339-E3F9-3E9E-8F68-92168E6F6981}\r\n// *********************************************************************//\r\n _WellKnownClientTypeEntry = interface(IDispatch)\r\n ['{4D0BC339-E3F9-3E9E-8F68-92168E6F6981}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _WellKnownClientTypeEntryDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {4D0BC339-E3F9-3E9E-8F68-92168E6F6981}\r\n// *********************************************************************//\r\n _WellKnownClientTypeEntryDisp = dispinterface\r\n ['{4D0BC339-E3F9-3E9E-8F68-92168E6F6981}']\r\n end;\r\n {$EXTERNALSYM _WellKnownClientTypeEntryDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _WellKnownServiceTypeEntry\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {60B8B604-0AED-3093-AC05-EB98FB29FC47}\r\n// *********************************************************************//\r\n _WellKnownServiceTypeEntry = interface(IDispatch)\r\n ['{60B8B604-0AED-3093-AC05-EB98FB29FC47}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _WellKnownServiceTypeEntryDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {60B8B604-0AED-3093-AC05-EB98FB29FC47}\r\n// *********************************************************************//\r\n _WellKnownServiceTypeEntryDisp = dispinterface\r\n ['{60B8B604-0AED-3093-AC05-EB98FB29FC47}']\r\n end;\r\n {$EXTERNALSYM _WellKnownServiceTypeEntryDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _RemotingException\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {7264843F-F60C-39A9-99E1-029126AA0815}\r\n// *********************************************************************//\r\n _RemotingException = interface(IDispatch)\r\n ['{7264843F-F60C-39A9-99E1-029126AA0815}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _RemotingExceptionDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {7264843F-F60C-39A9-99E1-029126AA0815}\r\n// *********************************************************************//\r\n _RemotingExceptionDisp = dispinterface\r\n ['{7264843F-F60C-39A9-99E1-029126AA0815}']\r\n end;\r\n {$EXTERNALSYM _RemotingExceptionDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _ServerException\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {19373C44-55B4-3487-9AD8-4C621AAE85EA}\r\n// *********************************************************************//\r\n _ServerException = interface(IDispatch)\r\n ['{19373C44-55B4-3487-9AD8-4C621AAE85EA}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _ServerExceptionDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {19373C44-55B4-3487-9AD8-4C621AAE85EA}\r\n// *********************************************************************//\r\n _ServerExceptionDisp = dispinterface\r\n ['{19373C44-55B4-3487-9AD8-4C621AAE85EA}']\r\n end;\r\n {$EXTERNALSYM _ServerExceptionDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _RemotingTimeoutException\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {44DB8E15-ACB1-34EE-81F9-56ED7AE37A5C}\r\n// *********************************************************************//\r\n _RemotingTimeoutException = interface(IDispatch)\r\n ['{44DB8E15-ACB1-34EE-81F9-56ED7AE37A5C}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _RemotingTimeoutExceptionDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {44DB8E15-ACB1-34EE-81F9-56ED7AE37A5C}\r\n// *********************************************************************//\r\n _RemotingTimeoutExceptionDisp = dispinterface\r\n ['{44DB8E15-ACB1-34EE-81F9-56ED7AE37A5C}']\r\n end;\r\n {$EXTERNALSYM _RemotingTimeoutExceptionDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _RemotingServices\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {7B91368D-A50A-3D36-BE8E-5B8836A419AD}\r\n// *********************************************************************//\r\n _RemotingServices = interface(IDispatch)\r\n ['{7B91368D-A50A-3D36-BE8E-5B8836A419AD}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _RemotingServicesDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {7B91368D-A50A-3D36-BE8E-5B8836A419AD}\r\n// *********************************************************************//\r\n _RemotingServicesDisp = dispinterface\r\n ['{7B91368D-A50A-3D36-BE8E-5B8836A419AD}']\r\n end;\r\n {$EXTERNALSYM _RemotingServicesDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _InternalRemotingServices\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {F4EFB305-CDC4-31C5-8102-33C9B91774F3}\r\n// *********************************************************************//\r\n _InternalRemotingServices = interface(IDispatch)\r\n ['{F4EFB305-CDC4-31C5-8102-33C9B91774F3}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _InternalRemotingServicesDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {F4EFB305-CDC4-31C5-8102-33C9B91774F3}\r\n// *********************************************************************//\r\n _InternalRemotingServicesDisp = dispinterface\r\n ['{F4EFB305-CDC4-31C5-8102-33C9B91774F3}']\r\n end;\r\n {$EXTERNALSYM _InternalRemotingServicesDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _MessageSurrogateFilter\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {04A35D22-0B08-34E7-A573-88EF2374375E}\r\n// *********************************************************************//\r\n _MessageSurrogateFilter = interface(IDispatch)\r\n ['{04A35D22-0B08-34E7-A573-88EF2374375E}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _MessageSurrogateFilterDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {04A35D22-0B08-34E7-A573-88EF2374375E}\r\n// *********************************************************************//\r\n _MessageSurrogateFilterDisp = dispinterface\r\n ['{04A35D22-0B08-34E7-A573-88EF2374375E}']\r\n end;\r\n {$EXTERNALSYM _MessageSurrogateFilterDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _RemotingSurrogateSelector\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {551F7A57-8651-37DB-A94A-6A3CA09C0ED7}\r\n// *********************************************************************//\r\n _RemotingSurrogateSelector = interface(IDispatch)\r\n ['{551F7A57-8651-37DB-A94A-6A3CA09C0ED7}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _RemotingSurrogateSelectorDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {551F7A57-8651-37DB-A94A-6A3CA09C0ED7}\r\n// *********************************************************************//\r\n _RemotingSurrogateSelectorDisp = dispinterface\r\n ['{551F7A57-8651-37DB-A94A-6A3CA09C0ED7}']\r\n end;\r\n {$EXTERNALSYM _RemotingSurrogateSelectorDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _SoapServices\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {7416B6EE-82E8-3A16-966B-018A40E7B1AA}\r\n// *********************************************************************//\r\n _SoapServices = interface(IDispatch)\r\n ['{7416B6EE-82E8-3A16-966B-018A40E7B1AA}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _SoapServicesDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {7416B6EE-82E8-3A16-966B-018A40E7B1AA}\r\n// *********************************************************************//\r\n _SoapServicesDisp = dispinterface\r\n ['{7416B6EE-82E8-3A16-966B-018A40E7B1AA}']\r\n end;\r\n {$EXTERNALSYM _SoapServicesDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: ISoapXsd\r\n// Flags: (4416) Dual OleAutomation Dispatchable\r\n// GUID: {80031D2A-AD59-3FB4-97F3-B864D71DA86B}\r\n// *********************************************************************//\r\n ISoapXsd = interface(IDispatch)\r\n ['{80031D2A-AD59-3FB4-97F3-B864D71DA86B}']\r\n function GetXsdType: WideString; safecall;\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: ISoapXsdDisp\r\n// Flags: (4416) Dual OleAutomation Dispatchable\r\n// GUID: {80031D2A-AD59-3FB4-97F3-B864D71DA86B}\r\n// *********************************************************************//\r\n ISoapXsdDisp = dispinterface\r\n ['{80031D2A-AD59-3FB4-97F3-B864D71DA86B}']\r\n function GetXsdType: WideString; dispid 1610743808;\r\n end;\r\n {$EXTERNALSYM ISoapXsdDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _SoapDateTime\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {1738ADBC-156E-3897-844F-C3147C528DEA}\r\n// *********************************************************************//\r\n _SoapDateTime = interface(IDispatch)\r\n ['{1738ADBC-156E-3897-844F-C3147C528DEA}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _SoapDateTimeDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {1738ADBC-156E-3897-844F-C3147C528DEA}\r\n// *********************************************************************//\r\n _SoapDateTimeDisp = dispinterface\r\n ['{1738ADBC-156E-3897-844F-C3147C528DEA}']\r\n end;\r\n {$EXTERNALSYM _SoapDateTimeDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _SoapDuration\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {7EF50DDB-32A5-30A1-B412-47FAB911404A}\r\n// *********************************************************************//\r\n _SoapDuration = interface(IDispatch)\r\n ['{7EF50DDB-32A5-30A1-B412-47FAB911404A}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _SoapDurationDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {7EF50DDB-32A5-30A1-B412-47FAB911404A}\r\n// *********************************************************************//\r\n _SoapDurationDisp = dispinterface\r\n ['{7EF50DDB-32A5-30A1-B412-47FAB911404A}']\r\n end;\r\n {$EXTERNALSYM _SoapDurationDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _SoapTime\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {A3BF0BCD-EC32-38E6-92F2-5F37BAD8030D}\r\n// *********************************************************************//\r\n _SoapTime = interface(IDispatch)\r\n ['{A3BF0BCD-EC32-38E6-92F2-5F37BAD8030D}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _SoapTimeDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {A3BF0BCD-EC32-38E6-92F2-5F37BAD8030D}\r\n// *********************************************************************//\r\n _SoapTimeDisp = dispinterface\r\n ['{A3BF0BCD-EC32-38E6-92F2-5F37BAD8030D}']\r\n end;\r\n {$EXTERNALSYM _SoapTimeDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _SoapDate\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {CFA6E9D2-B3DE-39A6-94D1-CC691DE193F8}\r\n// *********************************************************************//\r\n _SoapDate = interface(IDispatch)\r\n ['{CFA6E9D2-B3DE-39A6-94D1-CC691DE193F8}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _SoapDateDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {CFA6E9D2-B3DE-39A6-94D1-CC691DE193F8}\r\n// *********************************************************************//\r\n _SoapDateDisp = dispinterface\r\n ['{CFA6E9D2-B3DE-39A6-94D1-CC691DE193F8}']\r\n end;\r\n {$EXTERNALSYM _SoapDateDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _SoapYearMonth\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {103C7EF9-A9EE-35FB-84C5-3086C9725A20}\r\n// *********************************************************************//\r\n _SoapYearMonth = interface(IDispatch)\r\n ['{103C7EF9-A9EE-35FB-84C5-3086C9725A20}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _SoapYearMonthDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {103C7EF9-A9EE-35FB-84C5-3086C9725A20}\r\n// *********************************************************************//\r\n _SoapYearMonthDisp = dispinterface\r\n ['{103C7EF9-A9EE-35FB-84C5-3086C9725A20}']\r\n end;\r\n {$EXTERNALSYM _SoapYearMonthDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _SoapYear\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {C20769F3-858D-316A-BE6D-C347A47948AD}\r\n// *********************************************************************//\r\n _SoapYear = interface(IDispatch)\r\n ['{C20769F3-858D-316A-BE6D-C347A47948AD}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _SoapYearDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {C20769F3-858D-316A-BE6D-C347A47948AD}\r\n// *********************************************************************//\r\n _SoapYearDisp = dispinterface\r\n ['{C20769F3-858D-316A-BE6D-C347A47948AD}']\r\n end;\r\n {$EXTERNALSYM _SoapYearDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _SoapMonthDay\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {F9EAD0AA-4156-368F-AE05-FD59D70F758D}\r\n// *********************************************************************//\r\n _SoapMonthDay = interface(IDispatch)\r\n ['{F9EAD0AA-4156-368F-AE05-FD59D70F758D}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _SoapMonthDayDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {F9EAD0AA-4156-368F-AE05-FD59D70F758D}\r\n// *********************************************************************//\r\n _SoapMonthDayDisp = dispinterface\r\n ['{F9EAD0AA-4156-368F-AE05-FD59D70F758D}']\r\n end;\r\n {$EXTERNALSYM _SoapMonthDayDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _SoapDay\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {D9E8314D-5053-3497-8A33-97D3DCFE33E2}\r\n// *********************************************************************//\r\n _SoapDay = interface(IDispatch)\r\n ['{D9E8314D-5053-3497-8A33-97D3DCFE33E2}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _SoapDayDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {D9E8314D-5053-3497-8A33-97D3DCFE33E2}\r\n// *********************************************************************//\r\n _SoapDayDisp = dispinterface\r\n ['{D9E8314D-5053-3497-8A33-97D3DCFE33E2}']\r\n end;\r\n {$EXTERNALSYM _SoapDayDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _SoapMonth\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {B4E32423-E473-3562-AA12-62FDE5A7D4A2}\r\n// *********************************************************************//\r\n _SoapMonth = interface(IDispatch)\r\n ['{B4E32423-E473-3562-AA12-62FDE5A7D4A2}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _SoapMonthDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {B4E32423-E473-3562-AA12-62FDE5A7D4A2}\r\n// *********************************************************************//\r\n _SoapMonthDisp = dispinterface\r\n ['{B4E32423-E473-3562-AA12-62FDE5A7D4A2}']\r\n end;\r\n {$EXTERNALSYM _SoapMonthDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _SoapHexBinary\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {63B9DA95-FB91-358A-B7B7-90C34AA34AB7}\r\n// *********************************************************************//\r\n _SoapHexBinary = interface(IDispatch)\r\n ['{63B9DA95-FB91-358A-B7B7-90C34AA34AB7}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _SoapHexBinaryDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {63B9DA95-FB91-358A-B7B7-90C34AA34AB7}\r\n// *********************************************************************//\r\n _SoapHexBinaryDisp = dispinterface\r\n ['{63B9DA95-FB91-358A-B7B7-90C34AA34AB7}']\r\n end;\r\n {$EXTERNALSYM _SoapHexBinaryDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _SoapBase64Binary\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {8ED115A1-5E7B-34DC-AB85-90316F28015D}\r\n// *********************************************************************//\r\n _SoapBase64Binary = interface(IDispatch)\r\n ['{8ED115A1-5E7B-34DC-AB85-90316F28015D}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _SoapBase64BinaryDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {8ED115A1-5E7B-34DC-AB85-90316F28015D}\r\n// *********************************************************************//\r\n _SoapBase64BinaryDisp = dispinterface\r\n ['{8ED115A1-5E7B-34DC-AB85-90316F28015D}']\r\n end;\r\n {$EXTERNALSYM _SoapBase64BinaryDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _SoapInteger\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {30C65C40-4E54-3051-9D8F-4709B6AB214C}\r\n// *********************************************************************//\r\n _SoapInteger = interface(IDispatch)\r\n ['{30C65C40-4E54-3051-9D8F-4709B6AB214C}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _SoapIntegerDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {30C65C40-4E54-3051-9D8F-4709B6AB214C}\r\n// *********************************************************************//\r\n _SoapIntegerDisp = dispinterface\r\n ['{30C65C40-4E54-3051-9D8F-4709B6AB214C}']\r\n end;\r\n {$EXTERNALSYM _SoapIntegerDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _SoapPositiveInteger\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {4979EC29-C2B7-3AD6-986D-5AAF7344CC4E}\r\n// *********************************************************************//\r\n _SoapPositiveInteger = interface(IDispatch)\r\n ['{4979EC29-C2B7-3AD6-986D-5AAF7344CC4E}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _SoapPositiveIntegerDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {4979EC29-C2B7-3AD6-986D-5AAF7344CC4E}\r\n// *********************************************************************//\r\n _SoapPositiveIntegerDisp = dispinterface\r\n ['{4979EC29-C2B7-3AD6-986D-5AAF7344CC4E}']\r\n end;\r\n {$EXTERNALSYM _SoapPositiveIntegerDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _SoapNonPositiveInteger\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {AAF5401E-F71C-3FE3-8A73-A25074B20D3A}\r\n// *********************************************************************//\r\n _SoapNonPositiveInteger = interface(IDispatch)\r\n ['{AAF5401E-F71C-3FE3-8A73-A25074B20D3A}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _SoapNonPositiveIntegerDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {AAF5401E-F71C-3FE3-8A73-A25074B20D3A}\r\n// *********************************************************************//\r\n _SoapNonPositiveIntegerDisp = dispinterface\r\n ['{AAF5401E-F71C-3FE3-8A73-A25074B20D3A}']\r\n end;\r\n {$EXTERNALSYM _SoapNonPositiveIntegerDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _SoapNonNegativeInteger\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {BC261FC6-7132-3FB5-9AAC-224845D3AA99}\r\n// *********************************************************************//\r\n _SoapNonNegativeInteger = interface(IDispatch)\r\n ['{BC261FC6-7132-3FB5-9AAC-224845D3AA99}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _SoapNonNegativeIntegerDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {BC261FC6-7132-3FB5-9AAC-224845D3AA99}\r\n// *********************************************************************//\r\n _SoapNonNegativeIntegerDisp = dispinterface\r\n ['{BC261FC6-7132-3FB5-9AAC-224845D3AA99}']\r\n end;\r\n {$EXTERNALSYM _SoapNonNegativeIntegerDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _SoapNegativeInteger\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {E384AA10-A70C-3943-97CF-0F7C282C3BDC}\r\n// *********************************************************************//\r\n _SoapNegativeInteger = interface(IDispatch)\r\n ['{E384AA10-A70C-3943-97CF-0F7C282C3BDC}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _SoapNegativeIntegerDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {E384AA10-A70C-3943-97CF-0F7C282C3BDC}\r\n// *********************************************************************//\r\n _SoapNegativeIntegerDisp = dispinterface\r\n ['{E384AA10-A70C-3943-97CF-0F7C282C3BDC}']\r\n end;\r\n {$EXTERNALSYM _SoapNegativeIntegerDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _SoapAnyUri\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {818EC118-BE7E-3CDE-92C8-44B99160920E}\r\n// *********************************************************************//\r\n _SoapAnyUri = interface(IDispatch)\r\n ['{818EC118-BE7E-3CDE-92C8-44B99160920E}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _SoapAnyUriDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {818EC118-BE7E-3CDE-92C8-44B99160920E}\r\n// *********************************************************************//\r\n _SoapAnyUriDisp = dispinterface\r\n ['{818EC118-BE7E-3CDE-92C8-44B99160920E}']\r\n end;\r\n {$EXTERNALSYM _SoapAnyUriDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _SoapQName\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {3AC646B6-6B84-382F-9AED-22C2433244E6}\r\n// *********************************************************************//\r\n _SoapQName = interface(IDispatch)\r\n ['{3AC646B6-6B84-382F-9AED-22C2433244E6}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _SoapQNameDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {3AC646B6-6B84-382F-9AED-22C2433244E6}\r\n// *********************************************************************//\r\n _SoapQNameDisp = dispinterface\r\n ['{3AC646B6-6B84-382F-9AED-22C2433244E6}']\r\n end;\r\n {$EXTERNALSYM _SoapQNameDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _SoapNotation\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {974F01F4-6086-3137-9448-6A31FC9BEF08}\r\n// *********************************************************************//\r\n _SoapNotation = interface(IDispatch)\r\n ['{974F01F4-6086-3137-9448-6A31FC9BEF08}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _SoapNotationDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {974F01F4-6086-3137-9448-6A31FC9BEF08}\r\n// *********************************************************************//\r\n _SoapNotationDisp = dispinterface\r\n ['{974F01F4-6086-3137-9448-6A31FC9BEF08}']\r\n end;\r\n {$EXTERNALSYM _SoapNotationDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _SoapNormalizedString\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {F4926B50-3F23-37E0-9AFA-AA91FF89A7BD}\r\n// *********************************************************************//\r\n _SoapNormalizedString = interface(IDispatch)\r\n ['{F4926B50-3F23-37E0-9AFA-AA91FF89A7BD}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _SoapNormalizedStringDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {F4926B50-3F23-37E0-9AFA-AA91FF89A7BD}\r\n// *********************************************************************//\r\n _SoapNormalizedStringDisp = dispinterface\r\n ['{F4926B50-3F23-37E0-9AFA-AA91FF89A7BD}']\r\n end;\r\n {$EXTERNALSYM _SoapNormalizedStringDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _SoapToken\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {AB4E97B9-651D-36F4-AABA-28ACF5746624}\r\n// *********************************************************************//\r\n _SoapToken = interface(IDispatch)\r\n ['{AB4E97B9-651D-36F4-AABA-28ACF5746624}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _SoapTokenDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {AB4E97B9-651D-36F4-AABA-28ACF5746624}\r\n// *********************************************************************//\r\n _SoapTokenDisp = dispinterface\r\n ['{AB4E97B9-651D-36F4-AABA-28ACF5746624}']\r\n end;\r\n {$EXTERNALSYM _SoapTokenDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _SoapLanguage\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {14AED851-A168-3462-B877-8F9A01126653}\r\n// *********************************************************************//\r\n _SoapLanguage = interface(IDispatch)\r\n ['{14AED851-A168-3462-B877-8F9A01126653}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _SoapLanguageDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {14AED851-A168-3462-B877-8F9A01126653}\r\n// *********************************************************************//\r\n _SoapLanguageDisp = dispinterface\r\n ['{14AED851-A168-3462-B877-8F9A01126653}']\r\n end;\r\n {$EXTERNALSYM _SoapLanguageDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _SoapName\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {5EB06BEF-4ADF-3CC1-A6F2-62F76886B13A}\r\n// *********************************************************************//\r\n _SoapName = interface(IDispatch)\r\n ['{5EB06BEF-4ADF-3CC1-A6F2-62F76886B13A}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _SoapNameDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {5EB06BEF-4ADF-3CC1-A6F2-62F76886B13A}\r\n// *********************************************************************//\r\n _SoapNameDisp = dispinterface\r\n ['{5EB06BEF-4ADF-3CC1-A6F2-62F76886B13A}']\r\n end;\r\n {$EXTERNALSYM _SoapNameDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _SoapIdrefs\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {7947A829-ADB5-34D0-9CC8-6C172742C803}\r\n// *********************************************************************//\r\n _SoapIdrefs = interface(IDispatch)\r\n ['{7947A829-ADB5-34D0-9CC8-6C172742C803}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _SoapIdrefsDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {7947A829-ADB5-34D0-9CC8-6C172742C803}\r\n// *********************************************************************//\r\n _SoapIdrefsDisp = dispinterface\r\n ['{7947A829-ADB5-34D0-9CC8-6C172742C803}']\r\n end;\r\n {$EXTERNALSYM _SoapIdrefsDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _SoapEntities\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {ACA96DA3-96ED-397E-8A72-EE1BE1025F5E}\r\n// *********************************************************************//\r\n _SoapEntities = interface(IDispatch)\r\n ['{ACA96DA3-96ED-397E-8A72-EE1BE1025F5E}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _SoapEntitiesDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {ACA96DA3-96ED-397E-8A72-EE1BE1025F5E}\r\n// *********************************************************************//\r\n _SoapEntitiesDisp = dispinterface\r\n ['{ACA96DA3-96ED-397E-8A72-EE1BE1025F5E}']\r\n end;\r\n {$EXTERNALSYM _SoapEntitiesDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _SoapNmtoken\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {E941FA15-E6C8-3DD4-B060-C0DDFBC0240A}\r\n// *********************************************************************//\r\n _SoapNmtoken = interface(IDispatch)\r\n ['{E941FA15-E6C8-3DD4-B060-C0DDFBC0240A}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _SoapNmtokenDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {E941FA15-E6C8-3DD4-B060-C0DDFBC0240A}\r\n// *********************************************************************//\r\n _SoapNmtokenDisp = dispinterface\r\n ['{E941FA15-E6C8-3DD4-B060-C0DDFBC0240A}']\r\n end;\r\n {$EXTERNALSYM _SoapNmtokenDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _SoapNmtokens\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {A5E385AE-27FB-3708-BAF7-0BF1F3955747}\r\n// *********************************************************************//\r\n _SoapNmtokens = interface(IDispatch)\r\n ['{A5E385AE-27FB-3708-BAF7-0BF1F3955747}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _SoapNmtokensDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {A5E385AE-27FB-3708-BAF7-0BF1F3955747}\r\n// *********************************************************************//\r\n _SoapNmtokensDisp = dispinterface\r\n ['{A5E385AE-27FB-3708-BAF7-0BF1F3955747}']\r\n end;\r\n {$EXTERNALSYM _SoapNmtokensDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _SoapNcName\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {725CDAF7-B739-35C1-8463-E2A923E1F618}\r\n// *********************************************************************//\r\n _SoapNcName = interface(IDispatch)\r\n ['{725CDAF7-B739-35C1-8463-E2A923E1F618}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _SoapNcNameDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {725CDAF7-B739-35C1-8463-E2A923E1F618}\r\n// *********************************************************************//\r\n _SoapNcNameDisp = dispinterface\r\n ['{725CDAF7-B739-35C1-8463-E2A923E1F618}']\r\n end;\r\n {$EXTERNALSYM _SoapNcNameDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _SoapId\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {6A46B6A2-2D2C-3C67-AF67-AAE0175F17AE}\r\n// *********************************************************************//\r\n _SoapId = interface(IDispatch)\r\n ['{6A46B6A2-2D2C-3C67-AF67-AAE0175F17AE}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _SoapIdDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {6A46B6A2-2D2C-3C67-AF67-AAE0175F17AE}\r\n// *********************************************************************//\r\n _SoapIdDisp = dispinterface\r\n ['{6A46B6A2-2D2C-3C67-AF67-AAE0175F17AE}']\r\n end;\r\n {$EXTERNALSYM _SoapIdDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _SoapIdref\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {7DB7FD83-DE89-38E1-9645-D4CABDE694C0}\r\n// *********************************************************************//\r\n _SoapIdref = interface(IDispatch)\r\n ['{7DB7FD83-DE89-38E1-9645-D4CABDE694C0}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _SoapIdrefDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {7DB7FD83-DE89-38E1-9645-D4CABDE694C0}\r\n// *********************************************************************//\r\n _SoapIdrefDisp = dispinterface\r\n ['{7DB7FD83-DE89-38E1-9645-D4CABDE694C0}']\r\n end;\r\n {$EXTERNALSYM _SoapIdrefDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _SoapEntity\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {37171746-B784-3586-A7D5-692A7604A66B}\r\n// *********************************************************************//\r\n _SoapEntity = interface(IDispatch)\r\n ['{37171746-B784-3586-A7D5-692A7604A66B}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _SoapEntityDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {37171746-B784-3586-A7D5-692A7604A66B}\r\n// *********************************************************************//\r\n _SoapEntityDisp = dispinterface\r\n ['{37171746-B784-3586-A7D5-692A7604A66B}']\r\n end;\r\n {$EXTERNALSYM _SoapEntityDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _SynchronizationAttribute\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {2D985674-231C-33D4-B14D-F3A6BD2EBE19}\r\n// *********************************************************************//\r\n _SynchronizationAttribute = interface(IDispatch)\r\n ['{2D985674-231C-33D4-B14D-F3A6BD2EBE19}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _SynchronizationAttributeDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {2D985674-231C-33D4-B14D-F3A6BD2EBE19}\r\n// *********************************************************************//\r\n _SynchronizationAttributeDisp = dispinterface\r\n ['{2D985674-231C-33D4-B14D-F3A6BD2EBE19}']\r\n end;\r\n {$EXTERNALSYM _SynchronizationAttributeDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: ITrackingHandler\r\n// Flags: (4416) Dual OleAutomation Dispatchable\r\n// GUID: {03EC7D10-17A5-3585-9A2E-0596FCAC3870}\r\n// *********************************************************************//\r\n ITrackingHandler = interface(IDispatch)\r\n ['{03EC7D10-17A5-3585-9A2E-0596FCAC3870}']\r\n procedure MarshaledObject(obj: OleVariant; const or_: _ObjRef); safecall;\r\n procedure UnmarshaledObject(obj: OleVariant; const or_: _ObjRef); safecall;\r\n procedure DisconnectedObject(obj: OleVariant); safecall;\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: ITrackingHandlerDisp\r\n// Flags: (4416) Dual OleAutomation Dispatchable\r\n// GUID: {03EC7D10-17A5-3585-9A2E-0596FCAC3870}\r\n// *********************************************************************//\r\n ITrackingHandlerDisp = dispinterface\r\n ['{03EC7D10-17A5-3585-9A2E-0596FCAC3870}']\r\n procedure MarshaledObject(obj: OleVariant; const or_: _ObjRef); dispid 1610743808;\r\n procedure UnmarshaledObject(obj: OleVariant; const or_: _ObjRef); dispid 1610743809;\r\n procedure DisconnectedObject(obj: OleVariant); dispid 1610743810;\r\n end;\r\n {$EXTERNALSYM ITrackingHandlerDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _TrackingServices\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {F51728F2-2DEF-308C-874A-CBB1BAA9CF9E}\r\n// *********************************************************************//\r\n _TrackingServices = interface(IDispatch)\r\n ['{F51728F2-2DEF-308C-874A-CBB1BAA9CF9E}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _TrackingServicesDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {F51728F2-2DEF-308C-874A-CBB1BAA9CF9E}\r\n// *********************************************************************//\r\n _TrackingServicesDisp = dispinterface\r\n ['{F51728F2-2DEF-308C-874A-CBB1BAA9CF9E}']\r\n end;\r\n {$EXTERNALSYM _TrackingServicesDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _UrlAttribute\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {717105A3-739B-3BC3-A2B7-AD215903FAD2}\r\n// *********************************************************************//\r\n _UrlAttribute = interface(IDispatch)\r\n ['{717105A3-739B-3BC3-A2B7-AD215903FAD2}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _UrlAttributeDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {717105A3-739B-3BC3-A2B7-AD215903FAD2}\r\n// *********************************************************************//\r\n _UrlAttributeDisp = dispinterface\r\n ['{717105A3-739B-3BC3-A2B7-AD215903FAD2}']\r\n end;\r\n {$EXTERNALSYM _UrlAttributeDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _IsolatedStorage\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {34EC3BD7-F2F6-3C20-A639-804BFF89DF65}\r\n// *********************************************************************//\r\n _IsolatedStorage = interface(IDispatch)\r\n ['{34EC3BD7-F2F6-3C20-A639-804BFF89DF65}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _IsolatedStorageDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {34EC3BD7-F2F6-3C20-A639-804BFF89DF65}\r\n// *********************************************************************//\r\n _IsolatedStorageDisp = dispinterface\r\n ['{34EC3BD7-F2F6-3C20-A639-804BFF89DF65}']\r\n end;\r\n {$EXTERNALSYM _IsolatedStorageDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _IsolatedStorageFile\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {6BBB7DEE-186F-3D51-9486-BE0A71E915CE}\r\n// *********************************************************************//\r\n _IsolatedStorageFile = interface(IDispatch)\r\n ['{6BBB7DEE-186F-3D51-9486-BE0A71E915CE}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _IsolatedStorageFileDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {6BBB7DEE-186F-3D51-9486-BE0A71E915CE}\r\n// *********************************************************************//\r\n _IsolatedStorageFileDisp = dispinterface\r\n ['{6BBB7DEE-186F-3D51-9486-BE0A71E915CE}']\r\n end;\r\n {$EXTERNALSYM _IsolatedStorageFileDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _IsolatedStorageFileStream\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {68D5592B-47C8-381A-8D51-3925C16CF025}\r\n// *********************************************************************//\r\n _IsolatedStorageFileStream = interface(IDispatch)\r\n ['{68D5592B-47C8-381A-8D51-3925C16CF025}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _IsolatedStorageFileStreamDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {68D5592B-47C8-381A-8D51-3925C16CF025}\r\n// *********************************************************************//\r\n _IsolatedStorageFileStreamDisp = dispinterface\r\n ['{68D5592B-47C8-381A-8D51-3925C16CF025}']\r\n end;\r\n {$EXTERNALSYM _IsolatedStorageFileStreamDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _IsolatedStorageException\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {AEC2B0DE-9898-3607-B845-63E2E307CB5F}\r\n// *********************************************************************//\r\n _IsolatedStorageException = interface(IDispatch)\r\n ['{AEC2B0DE-9898-3607-B845-63E2E307CB5F}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _IsolatedStorageExceptionDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {AEC2B0DE-9898-3607-B845-63E2E307CB5F}\r\n// *********************************************************************//\r\n _IsolatedStorageExceptionDisp = dispinterface\r\n ['{AEC2B0DE-9898-3607-B845-63E2E307CB5F}']\r\n end;\r\n {$EXTERNALSYM _IsolatedStorageExceptionDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: INormalizeForIsolatedStorage\r\n// Flags: (4416) Dual OleAutomation Dispatchable\r\n// GUID: {F5006531-D4D7-319E-9EDA-9B4B65AD8D4F}\r\n// *********************************************************************//\r\n INormalizeForIsolatedStorage = interface(IDispatch)\r\n ['{F5006531-D4D7-319E-9EDA-9B4B65AD8D4F}']\r\n function Normalize: OleVariant; safecall;\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: INormalizeForIsolatedStorageDisp\r\n// Flags: (4416) Dual OleAutomation Dispatchable\r\n// GUID: {F5006531-D4D7-319E-9EDA-9B4B65AD8D4F}\r\n// *********************************************************************//\r\n INormalizeForIsolatedStorageDisp = dispinterface\r\n ['{F5006531-D4D7-319E-9EDA-9B4B65AD8D4F}']\r\n function Normalize: OleVariant; dispid 1610743808;\r\n end;\r\n {$EXTERNALSYM INormalizeForIsolatedStorageDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: ISoapMessage\r\n// Flags: (4416) Dual OleAutomation Dispatchable\r\n// GUID: {E699146C-7793-3455-9BEF-964C90D8F995}\r\n// *********************************************************************//\r\n ISoapMessage = interface(IDispatch)\r\n ['{E699146C-7793-3455-9BEF-964C90D8F995}']\r\n function Get_ParamNames: PSafeArray; safecall;\r\n procedure Set_ParamNames(pRetVal: PSafeArray); safecall;\r\n function Get_ParamValues: PSafeArray; safecall;\r\n procedure Set_ParamValues(pRetVal: PSafeArray); safecall;\r\n function Get_ParamTypes: PSafeArray; safecall;\r\n procedure Set_ParamTypes(pRetVal: PSafeArray); safecall;\r\n function Get_MethodName: WideString; safecall;\r\n procedure Set_MethodName(const pRetVal: WideString); safecall;\r\n function Get_XmlNameSpace: WideString; safecall;\r\n procedure Set_XmlNameSpace(const pRetVal: WideString); safecall;\r\n function Get_headers: PSafeArray; safecall;\r\n procedure Set_headers(pRetVal: PSafeArray); safecall;\r\n property ParamNames: PSafeArray read Get_ParamNames;\r\n property ParamValues: PSafeArray read Get_ParamValues;\r\n property ParamTypes: PSafeArray read Get_ParamTypes;\r\n property MethodName: WideString read Get_MethodName;\r\n property XmlNameSpace: WideString read Get_XmlNameSpace;\r\n property headers: PSafeArray read Get_headers;\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: ISoapMessageDisp\r\n// Flags: (4416) Dual OleAutomation Dispatchable\r\n// GUID: {E699146C-7793-3455-9BEF-964C90D8F995}\r\n// *********************************************************************//\r\n ISoapMessageDisp = dispinterface\r\n ['{E699146C-7793-3455-9BEF-964C90D8F995}']\r\n property ParamNames: {??PSafeArray}OleVariant readonly dispid 1610743808;\r\n property ParamValues: {??PSafeArray}OleVariant readonly dispid 1610743810;\r\n property ParamTypes: {??PSafeArray}OleVariant readonly dispid 1610743812;\r\n property MethodName: WideString readonly dispid 1610743814;\r\n property XmlNameSpace: WideString readonly dispid 1610743816;\r\n property headers: {??PSafeArray}OleVariant readonly dispid 1610743818;\r\n end;\r\n {$EXTERNALSYM ISoapMessageDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _InternalRM\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {361A5049-1BC8-35A9-946A-53A877902F25}\r\n// *********************************************************************//\r\n _InternalRM = interface(IDispatch)\r\n ['{361A5049-1BC8-35A9-946A-53A877902F25}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _InternalRMDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {361A5049-1BC8-35A9-946A-53A877902F25}\r\n// *********************************************************************//\r\n _InternalRMDisp = dispinterface\r\n ['{361A5049-1BC8-35A9-946A-53A877902F25}']\r\n end;\r\n {$EXTERNALSYM _InternalRMDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _InternalST\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {A864FB13-F945-3DC0-A01C-B903F944FC97}\r\n// *********************************************************************//\r\n _InternalST = interface(IDispatch)\r\n ['{A864FB13-F945-3DC0-A01C-B903F944FC97}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _InternalSTDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {A864FB13-F945-3DC0-A01C-B903F944FC97}\r\n// *********************************************************************//\r\n _InternalSTDisp = dispinterface\r\n ['{A864FB13-F945-3DC0-A01C-B903F944FC97}']\r\n end;\r\n {$EXTERNALSYM _InternalSTDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _SoapMessage\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {BC0847B2-BD5C-37B3-BA67-7D2D54B17238}\r\n// *********************************************************************//\r\n _SoapMessage = interface(IDispatch)\r\n ['{BC0847B2-BD5C-37B3-BA67-7D2D54B17238}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _SoapMessageDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {BC0847B2-BD5C-37B3-BA67-7D2D54B17238}\r\n// *********************************************************************//\r\n _SoapMessageDisp = dispinterface\r\n ['{BC0847B2-BD5C-37B3-BA67-7D2D54B17238}']\r\n end;\r\n {$EXTERNALSYM _SoapMessageDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _SoapFault\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {A1C392FC-314C-39D5-8DE6-1F8EBCA0A1E2}\r\n// *********************************************************************//\r\n _SoapFault = interface(IDispatch)\r\n ['{A1C392FC-314C-39D5-8DE6-1F8EBCA0A1E2}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _SoapFaultDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {A1C392FC-314C-39D5-8DE6-1F8EBCA0A1E2}\r\n// *********************************************************************//\r\n _SoapFaultDisp = dispinterface\r\n ['{A1C392FC-314C-39D5-8DE6-1F8EBCA0A1E2}']\r\n end;\r\n {$EXTERNALSYM _SoapFaultDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _ServerFault\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {02D1BD78-3BB6-37AD-A9F8-F7D5DA273E4E}\r\n// *********************************************************************//\r\n _ServerFault = interface(IDispatch)\r\n ['{02D1BD78-3BB6-37AD-A9F8-F7D5DA273E4E}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _ServerFaultDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {02D1BD78-3BB6-37AD-A9F8-F7D5DA273E4E}\r\n// *********************************************************************//\r\n _ServerFaultDisp = dispinterface\r\n ['{02D1BD78-3BB6-37AD-A9F8-F7D5DA273E4E}']\r\n end;\r\n {$EXTERNALSYM _ServerFaultDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _BinaryFormatter\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {3BCF0CB2-A849-375E-8189-1BA5F1F4A9B0}\r\n// *********************************************************************//\r\n _BinaryFormatter = interface(IDispatch)\r\n ['{3BCF0CB2-A849-375E-8189-1BA5F1F4A9B0}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _BinaryFormatterDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {3BCF0CB2-A849-375E-8189-1BA5F1F4A9B0}\r\n// *********************************************************************//\r\n _BinaryFormatterDisp = dispinterface\r\n ['{3BCF0CB2-A849-375E-8189-1BA5F1F4A9B0}']\r\n end;\r\n {$EXTERNALSYM _BinaryFormatterDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _AssemblyBuilder\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {BEBB2505-8B54-3443-AEAD-142A16DD9CC7}\r\n// *********************************************************************//\r\n _AssemblyBuilder = interface(IDispatch)\r\n ['{BEBB2505-8B54-3443-AEAD-142A16DD9CC7}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _AssemblyBuilderDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {BEBB2505-8B54-3443-AEAD-142A16DD9CC7}\r\n// *********************************************************************//\r\n _AssemblyBuilderDisp = dispinterface\r\n ['{BEBB2505-8B54-3443-AEAD-142A16DD9CC7}']\r\n end;\r\n {$EXTERNALSYM _AssemblyBuilderDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _ConstructorBuilder\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {ED3E4384-D7E2-3FA7-8FFD-8940D330519A}\r\n// *********************************************************************//\r\n _ConstructorBuilder = interface(IDispatch)\r\n ['{ED3E4384-D7E2-3FA7-8FFD-8940D330519A}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _ConstructorBuilderDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {ED3E4384-D7E2-3FA7-8FFD-8940D330519A}\r\n// *********************************************************************//\r\n _ConstructorBuilderDisp = dispinterface\r\n ['{ED3E4384-D7E2-3FA7-8FFD-8940D330519A}']\r\n end;\r\n {$EXTERNALSYM _ConstructorBuilderDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _EventBuilder\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {AADABA99-895D-3D65-9760-B1F12621FAE8}\r\n// *********************************************************************//\r\n _EventBuilder = interface(IDispatch)\r\n ['{AADABA99-895D-3D65-9760-B1F12621FAE8}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _EventBuilderDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {AADABA99-895D-3D65-9760-B1F12621FAE8}\r\n// *********************************************************************//\r\n _EventBuilderDisp = dispinterface\r\n ['{AADABA99-895D-3D65-9760-B1F12621FAE8}']\r\n end;\r\n {$EXTERNALSYM _EventBuilderDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _FieldBuilder\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {CE1A3BF5-975E-30CC-97C9-1EF70F8F3993}\r\n// *********************************************************************//\r\n _FieldBuilder = interface(IDispatch)\r\n ['{CE1A3BF5-975E-30CC-97C9-1EF70F8F3993}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _FieldBuilderDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {CE1A3BF5-975E-30CC-97C9-1EF70F8F3993}\r\n// *********************************************************************//\r\n _FieldBuilderDisp = dispinterface\r\n ['{CE1A3BF5-975E-30CC-97C9-1EF70F8F3993}']\r\n end;\r\n {$EXTERNALSYM _FieldBuilderDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _ILGenerator\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {A4924B27-6E3B-37F7-9B83-A4501955E6A7}\r\n// *********************************************************************//\r\n _ILGenerator = interface(IDispatch)\r\n ['{A4924B27-6E3B-37F7-9B83-A4501955E6A7}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _ILGeneratorDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {A4924B27-6E3B-37F7-9B83-A4501955E6A7}\r\n// *********************************************************************//\r\n _ILGeneratorDisp = dispinterface\r\n ['{A4924B27-6E3B-37F7-9B83-A4501955E6A7}']\r\n end;\r\n {$EXTERNALSYM _ILGeneratorDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _LocalBuilder\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {4E6350D1-A08B-3DEC-9A3E-C465F9AEEC0C}\r\n// *********************************************************************//\r\n _LocalBuilder = interface(IDispatch)\r\n ['{4E6350D1-A08B-3DEC-9A3E-C465F9AEEC0C}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _LocalBuilderDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {4E6350D1-A08B-3DEC-9A3E-C465F9AEEC0C}\r\n// *********************************************************************//\r\n _LocalBuilderDisp = dispinterface\r\n ['{4E6350D1-A08B-3DEC-9A3E-C465F9AEEC0C}']\r\n end;\r\n {$EXTERNALSYM _LocalBuilderDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _MethodBuilder\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {007D8A14-FDF3-363E-9A0B-FEC0618260A2}\r\n// *********************************************************************//\r\n _MethodBuilder = interface(IDispatch)\r\n ['{007D8A14-FDF3-363E-9A0B-FEC0618260A2}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _MethodBuilderDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {007D8A14-FDF3-363E-9A0B-FEC0618260A2}\r\n// *********************************************************************//\r\n _MethodBuilderDisp = dispinterface\r\n ['{007D8A14-FDF3-363E-9A0B-FEC0618260A2}']\r\n end;\r\n {$EXTERNALSYM _MethodBuilderDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _CustomAttributeBuilder\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {BE9ACCE8-AAFF-3B91-81AE-8211663F5CAD}\r\n// *********************************************************************//\r\n _CustomAttributeBuilder = interface(IDispatch)\r\n ['{BE9ACCE8-AAFF-3B91-81AE-8211663F5CAD}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _CustomAttributeBuilderDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {BE9ACCE8-AAFF-3B91-81AE-8211663F5CAD}\r\n// *********************************************************************//\r\n _CustomAttributeBuilderDisp = dispinterface\r\n ['{BE9ACCE8-AAFF-3B91-81AE-8211663F5CAD}']\r\n end;\r\n {$EXTERNALSYM _CustomAttributeBuilderDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _MethodRental\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {C2323C25-F57F-3880-8A4D-12EBEA7A5852}\r\n// *********************************************************************//\r\n _MethodRental = interface(IDispatch)\r\n ['{C2323C25-F57F-3880-8A4D-12EBEA7A5852}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _MethodRentalDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {C2323C25-F57F-3880-8A4D-12EBEA7A5852}\r\n// *********************************************************************//\r\n _MethodRentalDisp = dispinterface\r\n ['{C2323C25-F57F-3880-8A4D-12EBEA7A5852}']\r\n end;\r\n {$EXTERNALSYM _MethodRentalDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _ModuleBuilder\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {D05FFA9A-04AF-3519-8EE1-8D93AD73430B}\r\n// *********************************************************************//\r\n _ModuleBuilder = interface(IDispatch)\r\n ['{D05FFA9A-04AF-3519-8EE1-8D93AD73430B}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _ModuleBuilderDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {D05FFA9A-04AF-3519-8EE1-8D93AD73430B}\r\n// *********************************************************************//\r\n _ModuleBuilderDisp = dispinterface\r\n ['{D05FFA9A-04AF-3519-8EE1-8D93AD73430B}']\r\n end;\r\n {$EXTERNALSYM _ModuleBuilderDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _OpCodes\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {1DB1CC2A-DA73-389E-828B-5C616F4FAC49}\r\n// *********************************************************************//\r\n _OpCodes = interface(IDispatch)\r\n ['{1DB1CC2A-DA73-389E-828B-5C616F4FAC49}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _OpCodesDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {1DB1CC2A-DA73-389E-828B-5C616F4FAC49}\r\n// *********************************************************************//\r\n _OpCodesDisp = dispinterface\r\n ['{1DB1CC2A-DA73-389E-828B-5C616F4FAC49}']\r\n end;\r\n {$EXTERNALSYM _OpCodesDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _ParameterBuilder\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {36329EBA-F97A-3565-BC07-0ED5C6EF19FC}\r\n// *********************************************************************//\r\n _ParameterBuilder = interface(IDispatch)\r\n ['{36329EBA-F97A-3565-BC07-0ED5C6EF19FC}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _ParameterBuilderDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {36329EBA-F97A-3565-BC07-0ED5C6EF19FC}\r\n// *********************************************************************//\r\n _ParameterBuilderDisp = dispinterface\r\n ['{36329EBA-F97A-3565-BC07-0ED5C6EF19FC}']\r\n end;\r\n {$EXTERNALSYM _ParameterBuilderDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _PropertyBuilder\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {15F9A479-9397-3A63-ACBD-F51977FB0F02}\r\n// *********************************************************************//\r\n _PropertyBuilder = interface(IDispatch)\r\n ['{15F9A479-9397-3A63-ACBD-F51977FB0F02}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _PropertyBuilderDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {15F9A479-9397-3A63-ACBD-F51977FB0F02}\r\n// *********************************************************************//\r\n _PropertyBuilderDisp = dispinterface\r\n ['{15F9A479-9397-3A63-ACBD-F51977FB0F02}']\r\n end;\r\n {$EXTERNALSYM _PropertyBuilderDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _SignatureHelper\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {7D13DD37-5A04-393C-BBCA-A5FEA802893D}\r\n// *********************************************************************//\r\n _SignatureHelper = interface(IDispatch)\r\n ['{7D13DD37-5A04-393C-BBCA-A5FEA802893D}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _SignatureHelperDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {7D13DD37-5A04-393C-BBCA-A5FEA802893D}\r\n// *********************************************************************//\r\n _SignatureHelperDisp = dispinterface\r\n ['{7D13DD37-5A04-393C-BBCA-A5FEA802893D}']\r\n end;\r\n {$EXTERNALSYM _SignatureHelperDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _TypeBuilder\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {7E5678EE-48B3-3F83-B076-C58543498A58}\r\n// *********************************************************************//\r\n _TypeBuilder = interface(IDispatch)\r\n ['{7E5678EE-48B3-3F83-B076-C58543498A58}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _TypeBuilderDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {7E5678EE-48B3-3F83-B076-C58543498A58}\r\n// *********************************************************************//\r\n _TypeBuilderDisp = dispinterface\r\n ['{7E5678EE-48B3-3F83-B076-C58543498A58}']\r\n end;\r\n {$EXTERNALSYM _TypeBuilderDisp}\r\n\r\n// *********************************************************************//\r\n// Interface: _EnumBuilder\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {C7BD73DE-9F85-3290-88EE-090B8BDFE2DF}\r\n// *********************************************************************//\r\n _EnumBuilder = interface(IDispatch)\r\n ['{C7BD73DE-9F85-3290-88EE-090B8BDFE2DF}']\r\n end;\r\n\r\n// *********************************************************************//\r\n// DispIntf: _EnumBuilderDisp\r\n// Flags: (4432) Hidden Dual OleAutomation Dispatchable\r\n// GUID: {C7BD73DE-9F85-3290-88EE-090B8BDFE2DF}\r\n// *********************************************************************//\r\n _EnumBuilderDisp = dispinterface\r\n ['{C7BD73DE-9F85-3290-88EE-090B8BDFE2DF}']\r\n end;\r\n {$EXTERNALSYM _EnumBuilderDisp}\r\n\r\n// *********************************************************************//\r\n// The Class CoAppDomain provides a Create and CreateRemote method to \r\n// create instances of the default interface _AppDomain exposed by \r\n// the CoClass AppDomain. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoAppDomain = class\r\n class function Create: _AppDomain;\r\n class function CreateRemote(const MachineName: string): _AppDomain;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoRegistrationServices provides a Create and CreateRemote method to \r\n// create instances of the default interface IRegistrationServices exposed by \r\n// the CoClass RegistrationServices. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoRegistrationServices = class\r\n class function Create: IRegistrationServices;\r\n class function CreateRemote(const MachineName: string): IRegistrationServices;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoTypeLibConverter provides a Create and CreateRemote method to \r\n// create instances of the default interface ITypeLibConverter exposed by \r\n// the CoClass TypeLibConverter. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoTypeLibConverter = class\r\n class function Create: ITypeLibConverter;\r\n class function CreateRemote(const MachineName: string): ITypeLibConverter;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoAppDomainSetup provides a Create and CreateRemote method to \r\n// create instances of the default interface IAppDomainSetup exposed by \r\n// the CoClass AppDomainSetup. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoAppDomainSetup = class\r\n class function Create: IAppDomainSetup;\r\n class function CreateRemote(const MachineName: string): IAppDomainSetup;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoObject_ provides a Create and CreateRemote method to \r\n// create instances of the default interface _Object exposed by \r\n// the CoClass Object_. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoObject_ = class\r\n class function Create: _Object;\r\n class function CreateRemote(const MachineName: string): _Object;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoArray_ provides a Create and CreateRemote method to \r\n// create instances of the default interface _Array exposed by \r\n// the CoClass Array_. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoArray_ = class\r\n class function Create: _Array;\r\n class function CreateRemote(const MachineName: string): _Array;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoString_ provides a Create and CreateRemote method to \r\n// create instances of the default interface _String exposed by \r\n// the CoClass String_. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoString_ = class\r\n class function Create: _String;\r\n class function CreateRemote(const MachineName: string): _String;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoStringBuilder provides a Create and CreateRemote method to \r\n// create instances of the default interface _StringBuilder exposed by \r\n// the CoClass StringBuilder. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoStringBuilder = class\r\n class function Create: _StringBuilder;\r\n class function CreateRemote(const MachineName: string): _StringBuilder;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoException provides a Create and CreateRemote method to \r\n// create instances of the default interface _Exception exposed by \r\n// the CoClass Exception. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoException = class\r\n class function Create: _Exception;\r\n class function CreateRemote(const MachineName: string): _Exception;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoValueType provides a Create and CreateRemote method to \r\n// create instances of the default interface _ValueType exposed by \r\n// the CoClass ValueType. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoValueType = class\r\n class function Create: _ValueType;\r\n class function CreateRemote(const MachineName: string): _ValueType;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoSystemException provides a Create and CreateRemote method to \r\n// create instances of the default interface _SystemException exposed by \r\n// the CoClass SystemException. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoSystemException = class\r\n class function Create: _SystemException;\r\n class function CreateRemote(const MachineName: string): _SystemException;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoOutOfMemoryException provides a Create and CreateRemote method to \r\n// create instances of the default interface _OutOfMemoryException exposed by \r\n// the CoClass OutOfMemoryException. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoOutOfMemoryException = class\r\n class function Create: _OutOfMemoryException;\r\n class function CreateRemote(const MachineName: string): _OutOfMemoryException;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoStackOverflowException provides a Create and CreateRemote method to \r\n// create instances of the default interface _StackOverflowException exposed by \r\n// the CoClass StackOverflowException. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoStackOverflowException = class\r\n class function Create: _StackOverflowException;\r\n class function CreateRemote(const MachineName: string): _StackOverflowException;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoExecutionEngineException provides a Create and CreateRemote method to \r\n// create instances of the default interface _ExecutionEngineException exposed by \r\n// the CoClass ExecutionEngineException. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoExecutionEngineException = class\r\n class function Create: _ExecutionEngineException;\r\n class function CreateRemote(const MachineName: string): _ExecutionEngineException;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoDelegate provides a Create and CreateRemote method to \r\n// create instances of the default interface _Delegate exposed by \r\n// the CoClass Delegate. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoDelegate = class\r\n class function Create: _Delegate;\r\n class function CreateRemote(const MachineName: string): _Delegate;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoMulticastDelegate provides a Create and CreateRemote method to \r\n// create instances of the default interface _MulticastDelegate exposed by \r\n// the CoClass MulticastDelegate. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoMulticastDelegate = class\r\n class function Create: _MulticastDelegate;\r\n class function CreateRemote(const MachineName: string): _MulticastDelegate;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoEnum provides a Create and CreateRemote method to \r\n// create instances of the default interface _Enum exposed by \r\n// the CoClass Enum. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoEnum = class\r\n class function Create: _Enum;\r\n class function CreateRemote(const MachineName: string): _Enum;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoMemberAccessException provides a Create and CreateRemote method to \r\n// create instances of the default interface _MemberAccessException exposed by \r\n// the CoClass MemberAccessException. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoMemberAccessException = class\r\n class function Create: _MemberAccessException;\r\n class function CreateRemote(const MachineName: string): _MemberAccessException;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoActivator provides a Create and CreateRemote method to \r\n// create instances of the default interface _Activator exposed by \r\n// the CoClass Activator. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoActivator = class\r\n class function Create: _Activator;\r\n class function CreateRemote(const MachineName: string): _Activator;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoApplicationException provides a Create and CreateRemote method to \r\n// create instances of the default interface _ApplicationException exposed by \r\n// the CoClass ApplicationException. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoApplicationException = class\r\n class function Create: _ApplicationException;\r\n class function CreateRemote(const MachineName: string): _ApplicationException;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoEventArgs provides a Create and CreateRemote method to \r\n// create instances of the default interface _EventArgs exposed by \r\n// the CoClass EventArgs. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoEventArgs = class\r\n class function Create: _EventArgs;\r\n class function CreateRemote(const MachineName: string): _EventArgs;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoResolveEventArgs provides a Create and CreateRemote method to \r\n// create instances of the default interface _ResolveEventArgs exposed by \r\n// the CoClass ResolveEventArgs. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoResolveEventArgs = class\r\n class function Create: _ResolveEventArgs;\r\n class function CreateRemote(const MachineName: string): _ResolveEventArgs;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoAssemblyLoadEventArgs provides a Create and CreateRemote method to \r\n// create instances of the default interface _AssemblyLoadEventArgs exposed by \r\n// the CoClass AssemblyLoadEventArgs. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoAssemblyLoadEventArgs = class\r\n class function Create: _AssemblyLoadEventArgs;\r\n class function CreateRemote(const MachineName: string): _AssemblyLoadEventArgs;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoResolveEventHandler provides a Create and CreateRemote method to \r\n// create instances of the default interface _ResolveEventHandler exposed by \r\n// the CoClass ResolveEventHandler. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoResolveEventHandler = class\r\n class function Create: _ResolveEventHandler;\r\n class function CreateRemote(const MachineName: string): _ResolveEventHandler;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoAssemblyLoadEventHandler provides a Create and CreateRemote method to \r\n// create instances of the default interface _AssemblyLoadEventHandler exposed by \r\n// the CoClass AssemblyLoadEventHandler. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoAssemblyLoadEventHandler = class\r\n class function Create: _AssemblyLoadEventHandler;\r\n class function CreateRemote(const MachineName: string): _AssemblyLoadEventHandler;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoMarshalByRefObject provides a Create and CreateRemote method to \r\n// create instances of the default interface _MarshalByRefObject exposed by \r\n// the CoClass MarshalByRefObject. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoMarshalByRefObject = class\r\n class function Create: _MarshalByRefObject;\r\n class function CreateRemote(const MachineName: string): _MarshalByRefObject;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoCrossAppDomainDelegate provides a Create and CreateRemote method to \r\n// create instances of the default interface _CrossAppDomainDelegate exposed by \r\n// the CoClass CrossAppDomainDelegate. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoCrossAppDomainDelegate = class\r\n class function Create: _CrossAppDomainDelegate;\r\n class function CreateRemote(const MachineName: string): _CrossAppDomainDelegate;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoAttribute provides a Create and CreateRemote method to \r\n// create instances of the default interface _Attribute exposed by \r\n// the CoClass Attribute. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoAttribute = class\r\n class function Create: _Attribute;\r\n class function CreateRemote(const MachineName: string): _Attribute;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoLoaderOptimizationAttribute provides a Create and CreateRemote method to \r\n// create instances of the default interface _LoaderOptimizationAttribute exposed by \r\n// the CoClass LoaderOptimizationAttribute. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoLoaderOptimizationAttribute = class\r\n class function Create: _LoaderOptimizationAttribute;\r\n class function CreateRemote(const MachineName: string): _LoaderOptimizationAttribute;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoAppDomainUnloadedException provides a Create and CreateRemote method to \r\n// create instances of the default interface _AppDomainUnloadedException exposed by \r\n// the CoClass AppDomainUnloadedException. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoAppDomainUnloadedException = class\r\n class function Create: _AppDomainUnloadedException;\r\n class function CreateRemote(const MachineName: string): _AppDomainUnloadedException;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoArgumentException provides a Create and CreateRemote method to \r\n// create instances of the default interface _ArgumentException exposed by \r\n// the CoClass ArgumentException. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoArgumentException = class\r\n class function Create: _ArgumentException;\r\n class function CreateRemote(const MachineName: string): _ArgumentException;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoArgumentNullException provides a Create and CreateRemote method to \r\n// create instances of the default interface _ArgumentNullException exposed by \r\n// the CoClass ArgumentNullException. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoArgumentNullException = class\r\n class function Create: _ArgumentNullException;\r\n class function CreateRemote(const MachineName: string): _ArgumentNullException;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoArgumentOutOfRangeException provides a Create and CreateRemote method to \r\n// create instances of the default interface _ArgumentOutOfRangeException exposed by \r\n// the CoClass ArgumentOutOfRangeException. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoArgumentOutOfRangeException = class\r\n class function Create: _ArgumentOutOfRangeException;\r\n class function CreateRemote(const MachineName: string): _ArgumentOutOfRangeException;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoArithmeticException provides a Create and CreateRemote method to \r\n// create instances of the default interface _ArithmeticException exposed by \r\n// the CoClass ArithmeticException. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoArithmeticException = class\r\n class function Create: _ArithmeticException;\r\n class function CreateRemote(const MachineName: string): _ArithmeticException;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoArrayTypeMismatchException provides a Create and CreateRemote method to \r\n// create instances of the default interface _ArrayTypeMismatchException exposed by \r\n// the CoClass ArrayTypeMismatchException. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoArrayTypeMismatchException = class\r\n class function Create: _ArrayTypeMismatchException;\r\n class function CreateRemote(const MachineName: string): _ArrayTypeMismatchException;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoAsyncCallback provides a Create and CreateRemote method to \r\n// create instances of the default interface _AsyncCallback exposed by \r\n// the CoClass AsyncCallback. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoAsyncCallback = class\r\n class function Create: _AsyncCallback;\r\n class function CreateRemote(const MachineName: string): _AsyncCallback;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoAttributeUsageAttribute provides a Create and CreateRemote method to \r\n// create instances of the default interface _AttributeUsageAttribute exposed by \r\n// the CoClass AttributeUsageAttribute. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoAttributeUsageAttribute = class\r\n class function Create: _AttributeUsageAttribute;\r\n class function CreateRemote(const MachineName: string): _AttributeUsageAttribute;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoBadImageFormatException provides a Create and CreateRemote method to \r\n// create instances of the default interface _BadImageFormatException exposed by \r\n// the CoClass BadImageFormatException. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoBadImageFormatException = class\r\n class function Create: _BadImageFormatException;\r\n class function CreateRemote(const MachineName: string): _BadImageFormatException;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoBitConverter provides a Create and CreateRemote method to \r\n// create instances of the default interface _BitConverter exposed by \r\n// the CoClass BitConverter. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoBitConverter = class\r\n class function Create: _BitConverter;\r\n class function CreateRemote(const MachineName: string): _BitConverter;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoBuffer provides a Create and CreateRemote method to \r\n// create instances of the default interface _Buffer exposed by \r\n// the CoClass Buffer. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoBuffer = class\r\n class function Create: _Buffer;\r\n class function CreateRemote(const MachineName: string): _Buffer;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoCannotUnloadAppDomainException provides a Create and CreateRemote method to \r\n// create instances of the default interface _CannotUnloadAppDomainException exposed by \r\n// the CoClass CannotUnloadAppDomainException. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoCannotUnloadAppDomainException = class\r\n class function Create: _CannotUnloadAppDomainException;\r\n class function CreateRemote(const MachineName: string): _CannotUnloadAppDomainException;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoCharEnumerator provides a Create and CreateRemote method to \r\n// create instances of the default interface _CharEnumerator exposed by \r\n// the CoClass CharEnumerator. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoCharEnumerator = class\r\n class function Create: _CharEnumerator;\r\n class function CreateRemote(const MachineName: string): _CharEnumerator;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoCLSCompliantAttribute provides a Create and CreateRemote method to \r\n// create instances of the default interface _CLSCompliantAttribute exposed by \r\n// the CoClass CLSCompliantAttribute. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoCLSCompliantAttribute = class\r\n class function Create: _CLSCompliantAttribute;\r\n class function CreateRemote(const MachineName: string): _CLSCompliantAttribute;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoTypeUnloadedException provides a Create and CreateRemote method to \r\n// create instances of the default interface _TypeUnloadedException exposed by \r\n// the CoClass TypeUnloadedException. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoTypeUnloadedException = class\r\n class function Create: _TypeUnloadedException;\r\n class function CreateRemote(const MachineName: string): _TypeUnloadedException;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoConsole provides a Create and CreateRemote method to \r\n// create instances of the default interface _Console exposed by \r\n// the CoClass Console. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoConsole = class\r\n class function Create: _Console;\r\n class function CreateRemote(const MachineName: string): _Console;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoContextMarshalException provides a Create and CreateRemote method to \r\n// create instances of the default interface _ContextMarshalException exposed by \r\n// the CoClass ContextMarshalException. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoContextMarshalException = class\r\n class function Create: _ContextMarshalException;\r\n class function CreateRemote(const MachineName: string): _ContextMarshalException;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoConvert provides a Create and CreateRemote method to \r\n// create instances of the default interface _Convert exposed by \r\n// the CoClass Convert. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoConvert = class\r\n class function Create: _Convert;\r\n class function CreateRemote(const MachineName: string): _Convert;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoContextBoundObject provides a Create and CreateRemote method to \r\n// create instances of the default interface _ContextBoundObject exposed by \r\n// the CoClass ContextBoundObject. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoContextBoundObject = class\r\n class function Create: _ContextBoundObject;\r\n class function CreateRemote(const MachineName: string): _ContextBoundObject;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoContextStaticAttribute provides a Create and CreateRemote method to \r\n// create instances of the default interface _ContextStaticAttribute exposed by \r\n// the CoClass ContextStaticAttribute. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoContextStaticAttribute = class\r\n class function Create: _ContextStaticAttribute;\r\n class function CreateRemote(const MachineName: string): _ContextStaticAttribute;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoTimeZone provides a Create and CreateRemote method to \r\n// create instances of the default interface _TimeZone exposed by \r\n// the CoClass TimeZone. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoTimeZone = class\r\n class function Create: _TimeZone;\r\n class function CreateRemote(const MachineName: string): _TimeZone;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoDBNull provides a Create and CreateRemote method to \r\n// create instances of the default interface _DBNull exposed by \r\n// the CoClass DBNull. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoDBNull = class\r\n class function Create: _DBNull;\r\n class function CreateRemote(const MachineName: string): _DBNull;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoBinder provides a Create and CreateRemote method to \r\n// create instances of the default interface _Binder exposed by \r\n// the CoClass Binder. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoBinder = class\r\n class function Create: _Binder;\r\n class function CreateRemote(const MachineName: string): _Binder;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoDivideByZeroException provides a Create and CreateRemote method to \r\n// create instances of the default interface _DivideByZeroException exposed by \r\n// the CoClass DivideByZeroException. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoDivideByZeroException = class\r\n class function Create: _DivideByZeroException;\r\n class function CreateRemote(const MachineName: string): _DivideByZeroException;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoDuplicateWaitObjectException provides a Create and CreateRemote method to \r\n// create instances of the default interface _DuplicateWaitObjectException exposed by \r\n// the CoClass DuplicateWaitObjectException. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoDuplicateWaitObjectException = class\r\n class function Create: _DuplicateWaitObjectException;\r\n class function CreateRemote(const MachineName: string): _DuplicateWaitObjectException;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoTypeLoadException provides a Create and CreateRemote method to \r\n// create instances of the default interface _TypeLoadException exposed by \r\n// the CoClass TypeLoadException. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoTypeLoadException = class\r\n class function Create: _TypeLoadException;\r\n class function CreateRemote(const MachineName: string): _TypeLoadException;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoEntryPointNotFoundException provides a Create and CreateRemote method to \r\n// create instances of the default interface _EntryPointNotFoundException exposed by \r\n// the CoClass EntryPointNotFoundException. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoEntryPointNotFoundException = class\r\n class function Create: _EntryPointNotFoundException;\r\n class function CreateRemote(const MachineName: string): _EntryPointNotFoundException;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoDllNotFoundException provides a Create and CreateRemote method to \r\n// create instances of the default interface _DllNotFoundException exposed by \r\n// the CoClass DllNotFoundException. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoDllNotFoundException = class\r\n class function Create: _DllNotFoundException;\r\n class function CreateRemote(const MachineName: string): _DllNotFoundException;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoEnvironment provides a Create and CreateRemote method to \r\n// create instances of the default interface _Environment exposed by \r\n// the CoClass Environment. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoEnvironment = class\r\n class function Create: _Environment;\r\n class function CreateRemote(const MachineName: string): _Environment;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoEventHandler provides a Create and CreateRemote method to \r\n// create instances of the default interface _EventHandler exposed by \r\n// the CoClass EventHandler. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoEventHandler = class\r\n class function Create: _EventHandler;\r\n class function CreateRemote(const MachineName: string): _EventHandler;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoFieldAccessException provides a Create and CreateRemote method to \r\n// create instances of the default interface _FieldAccessException exposed by \r\n// the CoClass FieldAccessException. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoFieldAccessException = class\r\n class function Create: _FieldAccessException;\r\n class function CreateRemote(const MachineName: string): _FieldAccessException;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoFlagsAttribute provides a Create and CreateRemote method to \r\n// create instances of the default interface _FlagsAttribute exposed by \r\n// the CoClass FlagsAttribute. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoFlagsAttribute = class\r\n class function Create: _FlagsAttribute;\r\n class function CreateRemote(const MachineName: string): _FlagsAttribute;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoFormatException provides a Create and CreateRemote method to \r\n// create instances of the default interface _FormatException exposed by \r\n// the CoClass FormatException. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoFormatException = class\r\n class function Create: _FormatException;\r\n class function CreateRemote(const MachineName: string): _FormatException;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoGC provides a Create and CreateRemote method to \r\n// create instances of the default interface _GC exposed by \r\n// the CoClass GC. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoGC = class\r\n class function Create: _GC;\r\n class function CreateRemote(const MachineName: string): _GC;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoIndexOutOfRangeException provides a Create and CreateRemote method to \r\n// create instances of the default interface _IndexOutOfRangeException exposed by \r\n// the CoClass IndexOutOfRangeException. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoIndexOutOfRangeException = class\r\n class function Create: _IndexOutOfRangeException;\r\n class function CreateRemote(const MachineName: string): _IndexOutOfRangeException;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoInvalidCastException provides a Create and CreateRemote method to \r\n// create instances of the default interface _InvalidCastException exposed by \r\n// the CoClass InvalidCastException. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoInvalidCastException = class\r\n class function Create: _InvalidCastException;\r\n class function CreateRemote(const MachineName: string): _InvalidCastException;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoInvalidOperationException provides a Create and CreateRemote method to \r\n// create instances of the default interface _InvalidOperationException exposed by \r\n// the CoClass InvalidOperationException. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoInvalidOperationException = class\r\n class function Create: _InvalidOperationException;\r\n class function CreateRemote(const MachineName: string): _InvalidOperationException;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoInvalidProgramException provides a Create and CreateRemote method to \r\n// create instances of the default interface _InvalidProgramException exposed by \r\n// the CoClass InvalidProgramException. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoInvalidProgramException = class\r\n class function Create: _InvalidProgramException;\r\n class function CreateRemote(const MachineName: string): _InvalidProgramException;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoLocalDataStoreSlot provides a Create and CreateRemote method to \r\n// create instances of the default interface _LocalDataStoreSlot exposed by \r\n// the CoClass LocalDataStoreSlot. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoLocalDataStoreSlot = class\r\n class function Create: _LocalDataStoreSlot;\r\n class function CreateRemote(const MachineName: string): _LocalDataStoreSlot;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoMath provides a Create and CreateRemote method to \r\n// create instances of the default interface _Math exposed by \r\n// the CoClass Math. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoMath = class\r\n class function Create: _Math;\r\n class function CreateRemote(const MachineName: string): _Math;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoMethodAccessException provides a Create and CreateRemote method to \r\n// create instances of the default interface _MethodAccessException exposed by \r\n// the CoClass MethodAccessException. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoMethodAccessException = class\r\n class function Create: _MethodAccessException;\r\n class function CreateRemote(const MachineName: string): _MethodAccessException;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoMissingMemberException provides a Create and CreateRemote method to \r\n// create instances of the default interface _MissingMemberException exposed by \r\n// the CoClass MissingMemberException. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoMissingMemberException = class\r\n class function Create: _MissingMemberException;\r\n class function CreateRemote(const MachineName: string): _MissingMemberException;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoMissingFieldException provides a Create and CreateRemote method to \r\n// create instances of the default interface _MissingFieldException exposed by \r\n// the CoClass MissingFieldException. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoMissingFieldException = class\r\n class function Create: _MissingFieldException;\r\n class function CreateRemote(const MachineName: string): _MissingFieldException;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoMissingMethodException provides a Create and CreateRemote method to \r\n// create instances of the default interface _MissingMethodException exposed by \r\n// the CoClass MissingMethodException. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoMissingMethodException = class\r\n class function Create: _MissingMethodException;\r\n class function CreateRemote(const MachineName: string): _MissingMethodException;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoMulticastNotSupportedException provides a Create and CreateRemote method to \r\n// create instances of the default interface _MulticastNotSupportedException exposed by \r\n// the CoClass MulticastNotSupportedException. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoMulticastNotSupportedException = class\r\n class function Create: _MulticastNotSupportedException;\r\n class function CreateRemote(const MachineName: string): _MulticastNotSupportedException;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoNonSerializedAttribute provides a Create and CreateRemote method to \r\n// create instances of the default interface _NonSerializedAttribute exposed by \r\n// the CoClass NonSerializedAttribute. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoNonSerializedAttribute = class\r\n class function Create: _NonSerializedAttribute;\r\n class function CreateRemote(const MachineName: string): _NonSerializedAttribute;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoNotFiniteNumberException provides a Create and CreateRemote method to \r\n// create instances of the default interface _NotFiniteNumberException exposed by \r\n// the CoClass NotFiniteNumberException. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoNotFiniteNumberException = class\r\n class function Create: _NotFiniteNumberException;\r\n class function CreateRemote(const MachineName: string): _NotFiniteNumberException;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoNotImplementedException provides a Create and CreateRemote method to \r\n// create instances of the default interface _NotImplementedException exposed by \r\n// the CoClass NotImplementedException. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoNotImplementedException = class\r\n class function Create: _NotImplementedException;\r\n class function CreateRemote(const MachineName: string): _NotImplementedException;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoNotSupportedException provides a Create and CreateRemote method to \r\n// create instances of the default interface _NotSupportedException exposed by \r\n// the CoClass NotSupportedException. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoNotSupportedException = class\r\n class function Create: _NotSupportedException;\r\n class function CreateRemote(const MachineName: string): _NotSupportedException;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoNullReferenceException provides a Create and CreateRemote method to \r\n// create instances of the default interface _NullReferenceException exposed by \r\n// the CoClass NullReferenceException. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoNullReferenceException = class\r\n class function Create: _NullReferenceException;\r\n class function CreateRemote(const MachineName: string): _NullReferenceException;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoObjectDisposedException provides a Create and CreateRemote method to \r\n// create instances of the default interface _ObjectDisposedException exposed by \r\n// the CoClass ObjectDisposedException. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoObjectDisposedException = class\r\n class function Create: _ObjectDisposedException;\r\n class function CreateRemote(const MachineName: string): _ObjectDisposedException;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoObsoleteAttribute provides a Create and CreateRemote method to \r\n// create instances of the default interface _ObsoleteAttribute exposed by \r\n// the CoClass ObsoleteAttribute. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoObsoleteAttribute = class\r\n class function Create: _ObsoleteAttribute;\r\n class function CreateRemote(const MachineName: string): _ObsoleteAttribute;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoOperatingSystem provides a Create and CreateRemote method to \r\n// create instances of the default interface _OperatingSystem exposed by \r\n// the CoClass OperatingSystem. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoOperatingSystem = class\r\n class function Create: _OperatingSystem;\r\n class function CreateRemote(const MachineName: string): _OperatingSystem;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoOverflowException provides a Create and CreateRemote method to \r\n// create instances of the default interface _OverflowException exposed by \r\n// the CoClass OverflowException. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoOverflowException = class\r\n class function Create: _OverflowException;\r\n class function CreateRemote(const MachineName: string): _OverflowException;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoParamArrayAttribute provides a Create and CreateRemote method to \r\n// create instances of the default interface _ParamArrayAttribute exposed by \r\n// the CoClass ParamArrayAttribute. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoParamArrayAttribute = class\r\n class function Create: _ParamArrayAttribute;\r\n class function CreateRemote(const MachineName: string): _ParamArrayAttribute;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoPlatformNotSupportedException provides a Create and CreateRemote method to \r\n// create instances of the default interface _PlatformNotSupportedException exposed by \r\n// the CoClass PlatformNotSupportedException. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoPlatformNotSupportedException = class\r\n class function Create: _PlatformNotSupportedException;\r\n class function CreateRemote(const MachineName: string): _PlatformNotSupportedException;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoRandom provides a Create and CreateRemote method to \r\n// create instances of the default interface _Random exposed by \r\n// the CoClass Random. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoRandom = class\r\n class function Create: _Random;\r\n class function CreateRemote(const MachineName: string): _Random;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoRankException provides a Create and CreateRemote method to \r\n// create instances of the default interface _RankException exposed by \r\n// the CoClass RankException. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoRankException = class\r\n class function Create: _RankException;\r\n class function CreateRemote(const MachineName: string): _RankException;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoMemberInfo provides a Create and CreateRemote method to \r\n// create instances of the default interface _MemberInfo exposed by \r\n// the CoClass MemberInfo. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoMemberInfo = class\r\n class function Create: _MemberInfo;\r\n class function CreateRemote(const MachineName: string): _MemberInfo;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoType_ provides a Create and CreateRemote method to \r\n// create instances of the default interface _Type exposed by \r\n// the CoClass Type_. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoType_ = class\r\n class function Create: _Type;\r\n class function CreateRemote(const MachineName: string): _Type;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoSerializableAttribute provides a Create and CreateRemote method to \r\n// create instances of the default interface _SerializableAttribute exposed by \r\n// the CoClass SerializableAttribute. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoSerializableAttribute = class\r\n class function Create: _SerializableAttribute;\r\n class function CreateRemote(const MachineName: string): _SerializableAttribute;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoTypeInitializationException provides a Create and CreateRemote method to \r\n// create instances of the default interface _TypeInitializationException exposed by \r\n// the CoClass TypeInitializationException. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoTypeInitializationException = class\r\n class function Create: _TypeInitializationException;\r\n class function CreateRemote(const MachineName: string): _TypeInitializationException;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoUnauthorizedAccessException provides a Create and CreateRemote method to \r\n// create instances of the default interface _UnauthorizedAccessException exposed by \r\n// the CoClass UnauthorizedAccessException. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoUnauthorizedAccessException = class\r\n class function Create: _UnauthorizedAccessException;\r\n class function CreateRemote(const MachineName: string): _UnauthorizedAccessException;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoUnhandledExceptionEventArgs provides a Create and CreateRemote method to \r\n// create instances of the default interface _UnhandledExceptionEventArgs exposed by \r\n// the CoClass UnhandledExceptionEventArgs. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoUnhandledExceptionEventArgs = class\r\n class function Create: _UnhandledExceptionEventArgs;\r\n class function CreateRemote(const MachineName: string): _UnhandledExceptionEventArgs;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoUnhandledExceptionEventHandler provides a Create and CreateRemote method to \r\n// create instances of the default interface _UnhandledExceptionEventHandler exposed by \r\n// the CoClass UnhandledExceptionEventHandler. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoUnhandledExceptionEventHandler = class\r\n class function Create: _UnhandledExceptionEventHandler;\r\n class function CreateRemote(const MachineName: string): _UnhandledExceptionEventHandler;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoVersion provides a Create and CreateRemote method to \r\n// create instances of the default interface _Version exposed by \r\n// the CoClass Version. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoVersion = class\r\n class function Create: _Version;\r\n class function CreateRemote(const MachineName: string): _Version;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoWeakReference provides a Create and CreateRemote method to \r\n// create instances of the default interface _WeakReference exposed by \r\n// the CoClass WeakReference. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoWeakReference = class\r\n class function Create: _WeakReference;\r\n class function CreateRemote(const MachineName: string): _WeakReference;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoWaitHandle provides a Create and CreateRemote method to \r\n// create instances of the default interface _WaitHandle exposed by \r\n// the CoClass WaitHandle. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoWaitHandle = class\r\n class function Create: _WaitHandle;\r\n class function CreateRemote(const MachineName: string): _WaitHandle;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoAutoResetEvent provides a Create and CreateRemote method to \r\n// create instances of the default interface _AutoResetEvent exposed by \r\n// the CoClass AutoResetEvent. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoAutoResetEvent = class\r\n class function Create: _AutoResetEvent;\r\n class function CreateRemote(const MachineName: string): _AutoResetEvent;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoCompressedStack provides a Create and CreateRemote method to \r\n// create instances of the default interface _CompressedStack exposed by \r\n// the CoClass CompressedStack. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoCompressedStack = class\r\n class function Create: _CompressedStack;\r\n class function CreateRemote(const MachineName: string): _CompressedStack;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoInterlocked provides a Create and CreateRemote method to \r\n// create instances of the default interface _Interlocked exposed by \r\n// the CoClass Interlocked. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoInterlocked = class\r\n class function Create: _Interlocked;\r\n class function CreateRemote(const MachineName: string): _Interlocked;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoManualResetEvent provides a Create and CreateRemote method to \r\n// create instances of the default interface _ManualResetEvent exposed by \r\n// the CoClass ManualResetEvent. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoManualResetEvent = class\r\n class function Create: _ManualResetEvent;\r\n class function CreateRemote(const MachineName: string): _ManualResetEvent;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoMonitor provides a Create and CreateRemote method to \r\n// create instances of the default interface _Monitor exposed by \r\n// the CoClass Monitor. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoMonitor = class\r\n class function Create: _Monitor;\r\n class function CreateRemote(const MachineName: string): _Monitor;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoMutex provides a Create and CreateRemote method to \r\n// create instances of the default interface _Mutex exposed by \r\n// the CoClass Mutex. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoMutex = class\r\n class function Create: _Mutex;\r\n class function CreateRemote(const MachineName: string): _Mutex;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoOverlapped provides a Create and CreateRemote method to \r\n// create instances of the default interface _Overlapped exposed by \r\n// the CoClass Overlapped. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoOverlapped = class\r\n class function Create: _Overlapped;\r\n class function CreateRemote(const MachineName: string): _Overlapped;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoReaderWriterLock provides a Create and CreateRemote method to \r\n// create instances of the default interface _ReaderWriterLock exposed by \r\n// the CoClass ReaderWriterLock. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoReaderWriterLock = class\r\n class function Create: _ReaderWriterLock;\r\n class function CreateRemote(const MachineName: string): _ReaderWriterLock;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoSynchronizationLockException provides a Create and CreateRemote method to \r\n// create instances of the default interface _SynchronizationLockException exposed by \r\n// the CoClass SynchronizationLockException. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoSynchronizationLockException = class\r\n class function Create: _SynchronizationLockException;\r\n class function CreateRemote(const MachineName: string): _SynchronizationLockException;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoThread provides a Create and CreateRemote method to \r\n// create instances of the default interface _Thread exposed by \r\n// the CoClass Thread. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoThread = class\r\n class function Create: _Thread;\r\n class function CreateRemote(const MachineName: string): _Thread;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoThreadAbortException provides a Create and CreateRemote method to \r\n// create instances of the default interface _ThreadAbortException exposed by \r\n// the CoClass ThreadAbortException. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoThreadAbortException = class\r\n class function Create: _ThreadAbortException;\r\n class function CreateRemote(const MachineName: string): _ThreadAbortException;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoSTAThreadAttribute provides a Create and CreateRemote method to \r\n// create instances of the default interface _STAThreadAttribute exposed by \r\n// the CoClass STAThreadAttribute. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoSTAThreadAttribute = class\r\n class function Create: _STAThreadAttribute;\r\n class function CreateRemote(const MachineName: string): _STAThreadAttribute;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoMTAThreadAttribute provides a Create and CreateRemote method to \r\n// create instances of the default interface _MTAThreadAttribute exposed by \r\n// the CoClass MTAThreadAttribute. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoMTAThreadAttribute = class\r\n class function Create: _MTAThreadAttribute;\r\n class function CreateRemote(const MachineName: string): _MTAThreadAttribute;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoThreadInterruptedException provides a Create and CreateRemote method to \r\n// create instances of the default interface _ThreadInterruptedException exposed by \r\n// the CoClass ThreadInterruptedException. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoThreadInterruptedException = class\r\n class function Create: _ThreadInterruptedException;\r\n class function CreateRemote(const MachineName: string): _ThreadInterruptedException;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoRegisteredWaitHandle provides a Create and CreateRemote method to \r\n// create instances of the default interface _RegisteredWaitHandle exposed by \r\n// the CoClass RegisteredWaitHandle. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoRegisteredWaitHandle = class\r\n class function Create: _RegisteredWaitHandle;\r\n class function CreateRemote(const MachineName: string): _RegisteredWaitHandle;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoWaitCallback provides a Create and CreateRemote method to \r\n// create instances of the default interface _WaitCallback exposed by \r\n// the CoClass WaitCallback. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoWaitCallback = class\r\n class function Create: _WaitCallback;\r\n class function CreateRemote(const MachineName: string): _WaitCallback;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoWaitOrTimerCallback provides a Create and CreateRemote method to \r\n// create instances of the default interface _WaitOrTimerCallback exposed by \r\n// the CoClass WaitOrTimerCallback. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoWaitOrTimerCallback = class\r\n class function Create: _WaitOrTimerCallback;\r\n class function CreateRemote(const MachineName: string): _WaitOrTimerCallback;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoIOCompletionCallback provides a Create and CreateRemote method to \r\n// create instances of the default interface _IOCompletionCallback exposed by \r\n// the CoClass IOCompletionCallback. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoIOCompletionCallback = class\r\n class function Create: _IOCompletionCallback;\r\n class function CreateRemote(const MachineName: string): _IOCompletionCallback;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoThreadPool provides a Create and CreateRemote method to \r\n// create instances of the default interface _ThreadPool exposed by \r\n// the CoClass ThreadPool. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoThreadPool = class\r\n class function Create: _ThreadPool;\r\n class function CreateRemote(const MachineName: string): _ThreadPool;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoThreadStart provides a Create and CreateRemote method to \r\n// create instances of the default interface _ThreadStart exposed by \r\n// the CoClass ThreadStart. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoThreadStart = class\r\n class function Create: _ThreadStart;\r\n class function CreateRemote(const MachineName: string): _ThreadStart;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoThreadStateException provides a Create and CreateRemote method to \r\n// create instances of the default interface _ThreadStateException exposed by \r\n// the CoClass ThreadStateException. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoThreadStateException = class\r\n class function Create: _ThreadStateException;\r\n class function CreateRemote(const MachineName: string): _ThreadStateException;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoThreadStaticAttribute provides a Create and CreateRemote method to \r\n// create instances of the default interface _ThreadStaticAttribute exposed by \r\n// the CoClass ThreadStaticAttribute. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoThreadStaticAttribute = class\r\n class function Create: _ThreadStaticAttribute;\r\n class function CreateRemote(const MachineName: string): _ThreadStaticAttribute;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoTimeout provides a Create and CreateRemote method to \r\n// create instances of the default interface _Timeout exposed by \r\n// the CoClass Timeout. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoTimeout = class\r\n class function Create: _Timeout;\r\n class function CreateRemote(const MachineName: string): _Timeout;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoTimerCallback provides a Create and CreateRemote method to \r\n// create instances of the default interface _TimerCallback exposed by \r\n// the CoClass TimerCallback. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoTimerCallback = class\r\n class function Create: _TimerCallback;\r\n class function CreateRemote(const MachineName: string): _TimerCallback;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoTimer provides a Create and CreateRemote method to \r\n// create instances of the default interface _Timer exposed by \r\n// the CoClass Timer. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoTimer = class\r\n class function Create: _Timer;\r\n class function CreateRemote(const MachineName: string): _Timer;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoArrayList provides a Create and CreateRemote method to \r\n// create instances of the default interface _ArrayList exposed by \r\n// the CoClass ArrayList. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoArrayList = class\r\n class function Create: _ArrayList;\r\n class function CreateRemote(const MachineName: string): _ArrayList;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoBitArray provides a Create and CreateRemote method to \r\n// create instances of the default interface _BitArray exposed by \r\n// the CoClass BitArray. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoBitArray = class\r\n class function Create: _BitArray;\r\n class function CreateRemote(const MachineName: string): _BitArray;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoCaseInsensitiveComparer provides a Create and CreateRemote method to \r\n// create instances of the default interface _CaseInsensitiveComparer exposed by \r\n// the CoClass CaseInsensitiveComparer. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoCaseInsensitiveComparer = class\r\n class function Create: _CaseInsensitiveComparer;\r\n class function CreateRemote(const MachineName: string): _CaseInsensitiveComparer;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoCaseInsensitiveHashCodeProvider provides a Create and CreateRemote method to \r\n// create instances of the default interface _CaseInsensitiveHashCodeProvider exposed by \r\n// the CoClass CaseInsensitiveHashCodeProvider. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoCaseInsensitiveHashCodeProvider = class\r\n class function Create: _CaseInsensitiveHashCodeProvider;\r\n class function CreateRemote(const MachineName: string): _CaseInsensitiveHashCodeProvider;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoCollectionBase provides a Create and CreateRemote method to \r\n// create instances of the default interface _CollectionBase exposed by \r\n// the CoClass CollectionBase. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoCollectionBase = class\r\n class function Create: _CollectionBase;\r\n class function CreateRemote(const MachineName: string): _CollectionBase;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoComparer provides a Create and CreateRemote method to \r\n// create instances of the default interface _Comparer exposed by \r\n// the CoClass Comparer. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoComparer = class\r\n class function Create: _Comparer;\r\n class function CreateRemote(const MachineName: string): _Comparer;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoDictionaryBase provides a Create and CreateRemote method to \r\n// create instances of the default interface _DictionaryBase exposed by \r\n// the CoClass DictionaryBase. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoDictionaryBase = class\r\n class function Create: _DictionaryBase;\r\n class function CreateRemote(const MachineName: string): _DictionaryBase;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoHashtable provides a Create and CreateRemote method to \r\n// create instances of the default interface _Hashtable exposed by \r\n// the CoClass Hashtable. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoHashtable = class\r\n class function Create: _Hashtable;\r\n class function CreateRemote(const MachineName: string): _Hashtable;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoQueue provides a Create and CreateRemote method to \r\n// create instances of the default interface _Queue exposed by \r\n// the CoClass Queue. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoQueue = class\r\n class function Create: _Queue;\r\n class function CreateRemote(const MachineName: string): _Queue;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoReadOnlyCollectionBase provides a Create and CreateRemote method to \r\n// create instances of the default interface _ReadOnlyCollectionBase exposed by \r\n// the CoClass ReadOnlyCollectionBase. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoReadOnlyCollectionBase = class\r\n class function Create: _ReadOnlyCollectionBase;\r\n class function CreateRemote(const MachineName: string): _ReadOnlyCollectionBase;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoSortedList provides a Create and CreateRemote method to \r\n// create instances of the default interface _SortedList exposed by \r\n// the CoClass SortedList. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoSortedList = class\r\n class function Create: _SortedList;\r\n class function CreateRemote(const MachineName: string): _SortedList;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoStack provides a Create and CreateRemote method to \r\n// create instances of the default interface _Stack exposed by \r\n// the CoClass Stack. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoStack = class\r\n class function Create: _Stack;\r\n class function CreateRemote(const MachineName: string): _Stack;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoConditionalAttribute provides a Create and CreateRemote method to \r\n// create instances of the default interface _ConditionalAttribute exposed by \r\n// the CoClass ConditionalAttribute. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoConditionalAttribute = class\r\n class function Create: _ConditionalAttribute;\r\n class function CreateRemote(const MachineName: string): _ConditionalAttribute;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoDebugger provides a Create and CreateRemote method to \r\n// create instances of the default interface _Debugger exposed by \r\n// the CoClass Debugger. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoDebugger = class\r\n class function Create: _Debugger;\r\n class function CreateRemote(const MachineName: string): _Debugger;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoDebuggerStepThroughAttribute provides a Create and CreateRemote method to \r\n// create instances of the default interface _DebuggerStepThroughAttribute exposed by \r\n// the CoClass DebuggerStepThroughAttribute. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoDebuggerStepThroughAttribute = class\r\n class function Create: _DebuggerStepThroughAttribute;\r\n class function CreateRemote(const MachineName: string): _DebuggerStepThroughAttribute;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoDebuggerHiddenAttribute provides a Create and CreateRemote method to \r\n// create instances of the default interface _DebuggerHiddenAttribute exposed by \r\n// the CoClass DebuggerHiddenAttribute. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoDebuggerHiddenAttribute = class\r\n class function Create: _DebuggerHiddenAttribute;\r\n class function CreateRemote(const MachineName: string): _DebuggerHiddenAttribute;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoDebuggableAttribute provides a Create and CreateRemote method to \r\n// create instances of the default interface _DebuggableAttribute exposed by \r\n// the CoClass DebuggableAttribute. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoDebuggableAttribute = class\r\n class function Create: _DebuggableAttribute;\r\n class function CreateRemote(const MachineName: string): _DebuggableAttribute;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoStackTrace provides a Create and CreateRemote method to \r\n// create instances of the default interface _StackTrace exposed by \r\n// the CoClass StackTrace. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoStackTrace = class\r\n class function Create: _StackTrace;\r\n class function CreateRemote(const MachineName: string): _StackTrace;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoStackFrame provides a Create and CreateRemote method to \r\n// create instances of the default interface _StackFrame exposed by \r\n// the CoClass StackFrame. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoStackFrame = class\r\n class function Create: _StackFrame;\r\n class function CreateRemote(const MachineName: string): _StackFrame;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoSymDocumentType provides a Create and CreateRemote method to \r\n// create instances of the default interface _SymDocumentType exposed by \r\n// the CoClass SymDocumentType. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoSymDocumentType = class\r\n class function Create: _SymDocumentType;\r\n class function CreateRemote(const MachineName: string): _SymDocumentType;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoSymLanguageType provides a Create and CreateRemote method to \r\n// create instances of the default interface _SymLanguageType exposed by \r\n// the CoClass SymLanguageType. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoSymLanguageType = class\r\n class function Create: _SymLanguageType;\r\n class function CreateRemote(const MachineName: string): _SymLanguageType;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoSymLanguageVendor provides a Create and CreateRemote method to \r\n// create instances of the default interface _SymLanguageVendor exposed by \r\n// the CoClass SymLanguageVendor. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoSymLanguageVendor = class\r\n class function Create: _SymLanguageVendor;\r\n class function CreateRemote(const MachineName: string): _SymLanguageVendor;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoAmbiguousMatchException provides a Create and CreateRemote method to \r\n// create instances of the default interface _AmbiguousMatchException exposed by \r\n// the CoClass AmbiguousMatchException. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoAmbiguousMatchException = class\r\n class function Create: _AmbiguousMatchException;\r\n class function CreateRemote(const MachineName: string): _AmbiguousMatchException;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoModuleResolveEventHandler provides a Create and CreateRemote method to \r\n// create instances of the default interface _ModuleResolveEventHandler exposed by \r\n// the CoClass ModuleResolveEventHandler. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoModuleResolveEventHandler = class\r\n class function Create: _ModuleResolveEventHandler;\r\n class function CreateRemote(const MachineName: string): _ModuleResolveEventHandler;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoAssembly provides a Create and CreateRemote method to \r\n// create instances of the default interface _Assembly exposed by \r\n// the CoClass Assembly. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoAssembly = class\r\n class function Create: _Assembly;\r\n class function CreateRemote(const MachineName: string): _Assembly;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoAssemblyCultureAttribute provides a Create and CreateRemote method to \r\n// create instances of the default interface _AssemblyCultureAttribute exposed by \r\n// the CoClass AssemblyCultureAttribute. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoAssemblyCultureAttribute = class\r\n class function Create: _AssemblyCultureAttribute;\r\n class function CreateRemote(const MachineName: string): _AssemblyCultureAttribute;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoAssemblyVersionAttribute provides a Create and CreateRemote method to \r\n// create instances of the default interface _AssemblyVersionAttribute exposed by \r\n// the CoClass AssemblyVersionAttribute. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoAssemblyVersionAttribute = class\r\n class function Create: _AssemblyVersionAttribute;\r\n class function CreateRemote(const MachineName: string): _AssemblyVersionAttribute;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoAssemblyKeyFileAttribute provides a Create and CreateRemote method to \r\n// create instances of the default interface _AssemblyKeyFileAttribute exposed by \r\n// the CoClass AssemblyKeyFileAttribute. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoAssemblyKeyFileAttribute = class\r\n class function Create: _AssemblyKeyFileAttribute;\r\n class function CreateRemote(const MachineName: string): _AssemblyKeyFileAttribute;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoAssemblyKeyNameAttribute provides a Create and CreateRemote method to \r\n// create instances of the default interface _AssemblyKeyNameAttribute exposed by \r\n// the CoClass AssemblyKeyNameAttribute. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoAssemblyKeyNameAttribute = class\r\n class function Create: _AssemblyKeyNameAttribute;\r\n class function CreateRemote(const MachineName: string): _AssemblyKeyNameAttribute;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoAssemblyDelaySignAttribute provides a Create and CreateRemote method to \r\n// create instances of the default interface _AssemblyDelaySignAttribute exposed by \r\n// the CoClass AssemblyDelaySignAttribute. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoAssemblyDelaySignAttribute = class\r\n class function Create: _AssemblyDelaySignAttribute;\r\n class function CreateRemote(const MachineName: string): _AssemblyDelaySignAttribute;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoAssemblyAlgorithmIdAttribute provides a Create and CreateRemote method to \r\n// create instances of the default interface _AssemblyAlgorithmIdAttribute exposed by \r\n// the CoClass AssemblyAlgorithmIdAttribute. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoAssemblyAlgorithmIdAttribute = class\r\n class function Create: _AssemblyAlgorithmIdAttribute;\r\n class function CreateRemote(const MachineName: string): _AssemblyAlgorithmIdAttribute;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoAssemblyFlagsAttribute provides a Create and CreateRemote method to \r\n// create instances of the default interface _AssemblyFlagsAttribute exposed by \r\n// the CoClass AssemblyFlagsAttribute. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoAssemblyFlagsAttribute = class\r\n class function Create: _AssemblyFlagsAttribute;\r\n class function CreateRemote(const MachineName: string): _AssemblyFlagsAttribute;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoAssemblyFileVersionAttribute provides a Create and CreateRemote method to \r\n// create instances of the default interface _AssemblyFileVersionAttribute exposed by \r\n// the CoClass AssemblyFileVersionAttribute. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoAssemblyFileVersionAttribute = class\r\n class function Create: _AssemblyFileVersionAttribute;\r\n class function CreateRemote(const MachineName: string): _AssemblyFileVersionAttribute;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoAssemblyName provides a Create and CreateRemote method to \r\n// create instances of the default interface _AssemblyName exposed by \r\n// the CoClass AssemblyName. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoAssemblyName = class\r\n class function Create: _AssemblyName;\r\n class function CreateRemote(const MachineName: string): _AssemblyName;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoAssemblyNameProxy provides a Create and CreateRemote method to \r\n// create instances of the default interface _AssemblyNameProxy exposed by \r\n// the CoClass AssemblyNameProxy. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoAssemblyNameProxy = class\r\n class function Create: _AssemblyNameProxy;\r\n class function CreateRemote(const MachineName: string): _AssemblyNameProxy;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoAssemblyCopyrightAttribute provides a Create and CreateRemote method to \r\n// create instances of the default interface _AssemblyCopyrightAttribute exposed by \r\n// the CoClass AssemblyCopyrightAttribute. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoAssemblyCopyrightAttribute = class\r\n class function Create: _AssemblyCopyrightAttribute;\r\n class function CreateRemote(const MachineName: string): _AssemblyCopyrightAttribute;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoAssemblyTrademarkAttribute provides a Create and CreateRemote method to \r\n// create instances of the default interface _AssemblyTrademarkAttribute exposed by \r\n// the CoClass AssemblyTrademarkAttribute. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoAssemblyTrademarkAttribute = class\r\n class function Create: _AssemblyTrademarkAttribute;\r\n class function CreateRemote(const MachineName: string): _AssemblyTrademarkAttribute;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoAssemblyProductAttribute provides a Create and CreateRemote method to \r\n// create instances of the default interface _AssemblyProductAttribute exposed by \r\n// the CoClass AssemblyProductAttribute. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoAssemblyProductAttribute = class\r\n class function Create: _AssemblyProductAttribute;\r\n class function CreateRemote(const MachineName: string): _AssemblyProductAttribute;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoAssemblyCompanyAttribute provides a Create and CreateRemote method to \r\n// create instances of the default interface _AssemblyCompanyAttribute exposed by \r\n// the CoClass AssemblyCompanyAttribute. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoAssemblyCompanyAttribute = class\r\n class function Create: _AssemblyCompanyAttribute;\r\n class function CreateRemote(const MachineName: string): _AssemblyCompanyAttribute;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoAssemblyDescriptionAttribute provides a Create and CreateRemote method to \r\n// create instances of the default interface _AssemblyDescriptionAttribute exposed by \r\n// the CoClass AssemblyDescriptionAttribute. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoAssemblyDescriptionAttribute = class\r\n class function Create: _AssemblyDescriptionAttribute;\r\n class function CreateRemote(const MachineName: string): _AssemblyDescriptionAttribute;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoAssemblyTitleAttribute provides a Create and CreateRemote method to \r\n// create instances of the default interface _AssemblyTitleAttribute exposed by \r\n// the CoClass AssemblyTitleAttribute. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoAssemblyTitleAttribute = class\r\n class function Create: _AssemblyTitleAttribute;\r\n class function CreateRemote(const MachineName: string): _AssemblyTitleAttribute;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoAssemblyConfigurationAttribute provides a Create and CreateRemote method to \r\n// create instances of the default interface _AssemblyConfigurationAttribute exposed by \r\n// the CoClass AssemblyConfigurationAttribute. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoAssemblyConfigurationAttribute = class\r\n class function Create: _AssemblyConfigurationAttribute;\r\n class function CreateRemote(const MachineName: string): _AssemblyConfigurationAttribute;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoAssemblyDefaultAliasAttribute provides a Create and CreateRemote method to \r\n// create instances of the default interface _AssemblyDefaultAliasAttribute exposed by \r\n// the CoClass AssemblyDefaultAliasAttribute. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoAssemblyDefaultAliasAttribute = class\r\n class function Create: _AssemblyDefaultAliasAttribute;\r\n class function CreateRemote(const MachineName: string): _AssemblyDefaultAliasAttribute;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoAssemblyInformationalVersionAttribute provides a Create and CreateRemote method to \r\n// create instances of the default interface _AssemblyInformationalVersionAttribute exposed by \r\n// the CoClass AssemblyInformationalVersionAttribute. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoAssemblyInformationalVersionAttribute = class\r\n class function Create: _AssemblyInformationalVersionAttribute;\r\n class function CreateRemote(const MachineName: string): _AssemblyInformationalVersionAttribute;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoCustomAttributeFormatException provides a Create and CreateRemote method to \r\n// create instances of the default interface _CustomAttributeFormatException exposed by \r\n// the CoClass CustomAttributeFormatException. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoCustomAttributeFormatException = class\r\n class function Create: _CustomAttributeFormatException;\r\n class function CreateRemote(const MachineName: string): _CustomAttributeFormatException;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoMethodBase provides a Create and CreateRemote method to \r\n// create instances of the default interface _MethodBase exposed by \r\n// the CoClass MethodBase. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoMethodBase = class\r\n class function Create: _MethodBase;\r\n class function CreateRemote(const MachineName: string): _MethodBase;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoConstructorInfo provides a Create and CreateRemote method to \r\n// create instances of the default interface _ConstructorInfo exposed by \r\n// the CoClass ConstructorInfo. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoConstructorInfo = class\r\n class function Create: _ConstructorInfo;\r\n class function CreateRemote(const MachineName: string): _ConstructorInfo;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoDefaultMemberAttribute provides a Create and CreateRemote method to \r\n// create instances of the default interface _DefaultMemberAttribute exposed by \r\n// the CoClass DefaultMemberAttribute. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoDefaultMemberAttribute = class\r\n class function Create: _DefaultMemberAttribute;\r\n class function CreateRemote(const MachineName: string): _DefaultMemberAttribute;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoEventInfo provides a Create and CreateRemote method to \r\n// create instances of the default interface _EventInfo exposed by \r\n// the CoClass EventInfo. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoEventInfo = class\r\n class function Create: _EventInfo;\r\n class function CreateRemote(const MachineName: string): _EventInfo;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoFieldInfo provides a Create and CreateRemote method to \r\n// create instances of the default interface _FieldInfo exposed by \r\n// the CoClass FieldInfo. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoFieldInfo = class\r\n class function Create: _FieldInfo;\r\n class function CreateRemote(const MachineName: string): _FieldInfo;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoInvalidFilterCriteriaException provides a Create and CreateRemote method to \r\n// create instances of the default interface _InvalidFilterCriteriaException exposed by \r\n// the CoClass InvalidFilterCriteriaException. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoInvalidFilterCriteriaException = class\r\n class function Create: _InvalidFilterCriteriaException;\r\n class function CreateRemote(const MachineName: string): _InvalidFilterCriteriaException;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoManifestResourceInfo provides a Create and CreateRemote method to \r\n// create instances of the default interface _ManifestResourceInfo exposed by \r\n// the CoClass ManifestResourceInfo. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoManifestResourceInfo = class\r\n class function Create: _ManifestResourceInfo;\r\n class function CreateRemote(const MachineName: string): _ManifestResourceInfo;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoMemberFilter provides a Create and CreateRemote method to \r\n// create instances of the default interface _MemberFilter exposed by \r\n// the CoClass MemberFilter. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoMemberFilter = class\r\n class function Create: _MemberFilter;\r\n class function CreateRemote(const MachineName: string): _MemberFilter;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoMethodInfo provides a Create and CreateRemote method to \r\n// create instances of the default interface _MethodInfo exposed by \r\n// the CoClass MethodInfo. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoMethodInfo = class\r\n class function Create: _MethodInfo;\r\n class function CreateRemote(const MachineName: string): _MethodInfo;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoMissing provides a Create and CreateRemote method to \r\n// create instances of the default interface _Missing exposed by \r\n// the CoClass Missing. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoMissing = class\r\n class function Create: _Missing;\r\n class function CreateRemote(const MachineName: string): _Missing;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoModule provides a Create and CreateRemote method to \r\n// create instances of the default interface _Module exposed by \r\n// the CoClass Module. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoModule = class\r\n class function Create: _Module;\r\n class function CreateRemote(const MachineName: string): _Module;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoParameterInfo provides a Create and CreateRemote method to \r\n// create instances of the default interface _ParameterInfo exposed by \r\n// the CoClass ParameterInfo. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoParameterInfo = class\r\n class function Create: _ParameterInfo;\r\n class function CreateRemote(const MachineName: string): _ParameterInfo;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoPointer provides a Create and CreateRemote method to \r\n// create instances of the default interface _Pointer exposed by \r\n// the CoClass Pointer. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoPointer = class\r\n class function Create: _Pointer;\r\n class function CreateRemote(const MachineName: string): _Pointer;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoPropertyInfo provides a Create and CreateRemote method to \r\n// create instances of the default interface _PropertyInfo exposed by \r\n// the CoClass PropertyInfo. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoPropertyInfo = class\r\n class function Create: _PropertyInfo;\r\n class function CreateRemote(const MachineName: string): _PropertyInfo;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoReflectionTypeLoadException provides a Create and CreateRemote method to \r\n// create instances of the default interface _ReflectionTypeLoadException exposed by \r\n// the CoClass ReflectionTypeLoadException. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoReflectionTypeLoadException = class\r\n class function Create: _ReflectionTypeLoadException;\r\n class function CreateRemote(const MachineName: string): _ReflectionTypeLoadException;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoStrongNameKeyPair provides a Create and CreateRemote method to \r\n// create instances of the default interface _StrongNameKeyPair exposed by \r\n// the CoClass StrongNameKeyPair. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoStrongNameKeyPair = class\r\n class function Create: _StrongNameKeyPair;\r\n class function CreateRemote(const MachineName: string): _StrongNameKeyPair;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoTargetException provides a Create and CreateRemote method to \r\n// create instances of the default interface _TargetException exposed by \r\n// the CoClass TargetException. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoTargetException = class\r\n class function Create: _TargetException;\r\n class function CreateRemote(const MachineName: string): _TargetException;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoTargetInvocationException provides a Create and CreateRemote method to \r\n// create instances of the default interface _TargetInvocationException exposed by \r\n// the CoClass TargetInvocationException. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoTargetInvocationException = class\r\n class function Create: _TargetInvocationException;\r\n class function CreateRemote(const MachineName: string): _TargetInvocationException;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoTargetParameterCountException provides a Create and CreateRemote method to \r\n// create instances of the default interface _TargetParameterCountException exposed by \r\n// the CoClass TargetParameterCountException. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoTargetParameterCountException = class\r\n class function Create: _TargetParameterCountException;\r\n class function CreateRemote(const MachineName: string): _TargetParameterCountException;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoTypeDelegator provides a Create and CreateRemote method to \r\n// create instances of the default interface _TypeDelegator exposed by \r\n// the CoClass TypeDelegator. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoTypeDelegator = class\r\n class function Create: _TypeDelegator;\r\n class function CreateRemote(const MachineName: string): _TypeDelegator;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoTypeFilter provides a Create and CreateRemote method to \r\n// create instances of the default interface _TypeFilter exposed by \r\n// the CoClass TypeFilter. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoTypeFilter = class\r\n class function Create: _TypeFilter;\r\n class function CreateRemote(const MachineName: string): _TypeFilter;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoUnmanagedMarshal provides a Create and CreateRemote method to \r\n// create instances of the default interface _UnmanagedMarshal exposed by \r\n// the CoClass UnmanagedMarshal. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoUnmanagedMarshal = class\r\n class function Create: _UnmanagedMarshal;\r\n class function CreateRemote(const MachineName: string): _UnmanagedMarshal;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoFormatter provides a Create and CreateRemote method to \r\n// create instances of the default interface _Formatter exposed by \r\n// the CoClass Formatter. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoFormatter = class\r\n class function Create: _Formatter;\r\n class function CreateRemote(const MachineName: string): _Formatter;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoFormatterConverter provides a Create and CreateRemote method to \r\n// create instances of the default interface _FormatterConverter exposed by \r\n// the CoClass FormatterConverter. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoFormatterConverter = class\r\n class function Create: _FormatterConverter;\r\n class function CreateRemote(const MachineName: string): _FormatterConverter;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoFormatterServices provides a Create and CreateRemote method to \r\n// create instances of the default interface _FormatterServices exposed by \r\n// the CoClass FormatterServices. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoFormatterServices = class\r\n class function Create: _FormatterServices;\r\n class function CreateRemote(const MachineName: string): _FormatterServices;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoObjectIDGenerator provides a Create and CreateRemote method to \r\n// create instances of the default interface _ObjectIDGenerator exposed by \r\n// the CoClass ObjectIDGenerator. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoObjectIDGenerator = class\r\n class function Create: _ObjectIDGenerator;\r\n class function CreateRemote(const MachineName: string): _ObjectIDGenerator;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoObjectManager provides a Create and CreateRemote method to \r\n// create instances of the default interface _ObjectManager exposed by \r\n// the CoClass ObjectManager. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoObjectManager = class\r\n class function Create: _ObjectManager;\r\n class function CreateRemote(const MachineName: string): _ObjectManager;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoSerializationBinder provides a Create and CreateRemote method to \r\n// create instances of the default interface _SerializationBinder exposed by \r\n// the CoClass SerializationBinder. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoSerializationBinder = class\r\n class function Create: _SerializationBinder;\r\n class function CreateRemote(const MachineName: string): _SerializationBinder;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoSerializationInfo provides a Create and CreateRemote method to \r\n// create instances of the default interface _SerializationInfo exposed by \r\n// the CoClass SerializationInfo. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoSerializationInfo = class\r\n class function Create: _SerializationInfo;\r\n class function CreateRemote(const MachineName: string): _SerializationInfo;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoSerializationInfoEnumerator provides a Create and CreateRemote method to \r\n// create instances of the default interface _SerializationInfoEnumerator exposed by \r\n// the CoClass SerializationInfoEnumerator. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoSerializationInfoEnumerator = class\r\n class function Create: _SerializationInfoEnumerator;\r\n class function CreateRemote(const MachineName: string): _SerializationInfoEnumerator;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoSerializationException provides a Create and CreateRemote method to \r\n// create instances of the default interface _SerializationException exposed by \r\n// the CoClass SerializationException. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoSerializationException = class\r\n class function Create: _SerializationException;\r\n class function CreateRemote(const MachineName: string): _SerializationException;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoSurrogateSelector provides a Create and CreateRemote method to \r\n// create instances of the default interface _SurrogateSelector exposed by \r\n// the CoClass SurrogateSelector. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoSurrogateSelector = class\r\n class function Create: _SurrogateSelector;\r\n class function CreateRemote(const MachineName: string): _SurrogateSelector;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoCalendar provides a Create and CreateRemote method to \r\n// create instances of the default interface _Calendar exposed by \r\n// the CoClass Calendar. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoCalendar = class\r\n class function Create: _Calendar;\r\n class function CreateRemote(const MachineName: string): _Calendar;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoCompareInfo provides a Create and CreateRemote method to \r\n// create instances of the default interface _CompareInfo exposed by \r\n// the CoClass CompareInfo. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoCompareInfo = class\r\n class function Create: _CompareInfo;\r\n class function CreateRemote(const MachineName: string): _CompareInfo;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoCultureInfo provides a Create and CreateRemote method to \r\n// create instances of the default interface _CultureInfo exposed by \r\n// the CoClass CultureInfo. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoCultureInfo = class\r\n class function Create: _CultureInfo;\r\n class function CreateRemote(const MachineName: string): _CultureInfo;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoDateTimeFormatInfo provides a Create and CreateRemote method to \r\n// create instances of the default interface _DateTimeFormatInfo exposed by \r\n// the CoClass DateTimeFormatInfo. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoDateTimeFormatInfo = class\r\n class function Create: _DateTimeFormatInfo;\r\n class function CreateRemote(const MachineName: string): _DateTimeFormatInfo;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoDaylightTime provides a Create and CreateRemote method to \r\n// create instances of the default interface _DaylightTime exposed by \r\n// the CoClass DaylightTime. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoDaylightTime = class\r\n class function Create: _DaylightTime;\r\n class function CreateRemote(const MachineName: string): _DaylightTime;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoGregorianCalendar provides a Create and CreateRemote method to \r\n// create instances of the default interface _GregorianCalendar exposed by \r\n// the CoClass GregorianCalendar. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoGregorianCalendar = class\r\n class function Create: _GregorianCalendar;\r\n class function CreateRemote(const MachineName: string): _GregorianCalendar;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoHebrewCalendar provides a Create and CreateRemote method to \r\n// create instances of the default interface _HebrewCalendar exposed by \r\n// the CoClass HebrewCalendar. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoHebrewCalendar = class\r\n class function Create: _HebrewCalendar;\r\n class function CreateRemote(const MachineName: string): _HebrewCalendar;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoHijriCalendar provides a Create and CreateRemote method to \r\n// create instances of the default interface _HijriCalendar exposed by \r\n// the CoClass HijriCalendar. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoHijriCalendar = class\r\n class function Create: _HijriCalendar;\r\n class function CreateRemote(const MachineName: string): _HijriCalendar;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoJapaneseCalendar provides a Create and CreateRemote method to \r\n// create instances of the default interface _JapaneseCalendar exposed by \r\n// the CoClass JapaneseCalendar. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoJapaneseCalendar = class\r\n class function Create: _JapaneseCalendar;\r\n class function CreateRemote(const MachineName: string): _JapaneseCalendar;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoJulianCalendar provides a Create and CreateRemote method to \r\n// create instances of the default interface _JulianCalendar exposed by \r\n// the CoClass JulianCalendar. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoJulianCalendar = class\r\n class function Create: _JulianCalendar;\r\n class function CreateRemote(const MachineName: string): _JulianCalendar;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoKoreanCalendar provides a Create and CreateRemote method to \r\n// create instances of the default interface _KoreanCalendar exposed by \r\n// the CoClass KoreanCalendar. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoKoreanCalendar = class\r\n class function Create: _KoreanCalendar;\r\n class function CreateRemote(const MachineName: string): _KoreanCalendar;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoRegionInfo provides a Create and CreateRemote method to \r\n// create instances of the default interface _RegionInfo exposed by \r\n// the CoClass RegionInfo. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoRegionInfo = class\r\n class function Create: _RegionInfo;\r\n class function CreateRemote(const MachineName: string): _RegionInfo;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoSortKey provides a Create and CreateRemote method to \r\n// create instances of the default interface _SortKey exposed by \r\n// the CoClass SortKey. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoSortKey = class\r\n class function Create: _SortKey;\r\n class function CreateRemote(const MachineName: string): _SortKey;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoStringInfo provides a Create and CreateRemote method to \r\n// create instances of the default interface _StringInfo exposed by \r\n// the CoClass StringInfo. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoStringInfo = class\r\n class function Create: _StringInfo;\r\n class function CreateRemote(const MachineName: string): _StringInfo;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoTaiwanCalendar provides a Create and CreateRemote method to \r\n// create instances of the default interface _TaiwanCalendar exposed by \r\n// the CoClass TaiwanCalendar. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoTaiwanCalendar = class\r\n class function Create: _TaiwanCalendar;\r\n class function CreateRemote(const MachineName: string): _TaiwanCalendar;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoTextElementEnumerator provides a Create and CreateRemote method to \r\n// create instances of the default interface _TextElementEnumerator exposed by \r\n// the CoClass TextElementEnumerator. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoTextElementEnumerator = class\r\n class function Create: _TextElementEnumerator;\r\n class function CreateRemote(const MachineName: string): _TextElementEnumerator;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoTextInfo provides a Create and CreateRemote method to \r\n// create instances of the default interface _TextInfo exposed by \r\n// the CoClass TextInfo. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoTextInfo = class\r\n class function Create: _TextInfo;\r\n class function CreateRemote(const MachineName: string): _TextInfo;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoThaiBuddhistCalendar provides a Create and CreateRemote method to \r\n// create instances of the default interface _ThaiBuddhistCalendar exposed by \r\n// the CoClass ThaiBuddhistCalendar. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoThaiBuddhistCalendar = class\r\n class function Create: _ThaiBuddhistCalendar;\r\n class function CreateRemote(const MachineName: string): _ThaiBuddhistCalendar;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoNumberFormatInfo provides a Create and CreateRemote method to \r\n// create instances of the default interface _NumberFormatInfo exposed by \r\n// the CoClass NumberFormatInfo. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoNumberFormatInfo = class\r\n class function Create: _NumberFormatInfo;\r\n class function CreateRemote(const MachineName: string): _NumberFormatInfo;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoEncoding provides a Create and CreateRemote method to \r\n// create instances of the default interface _Encoding exposed by \r\n// the CoClass Encoding. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoEncoding = class\r\n class function Create: _Encoding;\r\n class function CreateRemote(const MachineName: string): _Encoding;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoSystem_Text_Decoder provides a Create and CreateRemote method to \r\n// create instances of the default interface _System_Text_Decoder exposed by \r\n// the CoClass System_Text_Decoder. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoSystem_Text_Decoder = class\r\n class function Create: _System_Text_Decoder;\r\n class function CreateRemote(const MachineName: string): _System_Text_Decoder;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoSystem_Text_Encoder provides a Create and CreateRemote method to \r\n// create instances of the default interface _System_Text_Encoder exposed by \r\n// the CoClass System_Text_Encoder. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoSystem_Text_Encoder = class\r\n class function Create: _System_Text_Encoder;\r\n class function CreateRemote(const MachineName: string): _System_Text_Encoder;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoASCIIEncoding provides a Create and CreateRemote method to \r\n// create instances of the default interface _ASCIIEncoding exposed by \r\n// the CoClass ASCIIEncoding. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoASCIIEncoding = class\r\n class function Create: _ASCIIEncoding;\r\n class function CreateRemote(const MachineName: string): _ASCIIEncoding;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoUnicodeEncoding provides a Create and CreateRemote method to \r\n// create instances of the default interface _UnicodeEncoding exposed by \r\n// the CoClass UnicodeEncoding. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoUnicodeEncoding = class\r\n class function Create: _UnicodeEncoding;\r\n class function CreateRemote(const MachineName: string): _UnicodeEncoding;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoUTF7Encoding provides a Create and CreateRemote method to \r\n// create instances of the default interface _UTF7Encoding exposed by \r\n// the CoClass UTF7Encoding. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoUTF7Encoding = class\r\n class function Create: _UTF7Encoding;\r\n class function CreateRemote(const MachineName: string): _UTF7Encoding;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoUTF8Encoding provides a Create and CreateRemote method to \r\n// create instances of the default interface _UTF8Encoding exposed by \r\n// the CoClass UTF8Encoding. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoUTF8Encoding = class\r\n class function Create: _UTF8Encoding;\r\n class function CreateRemote(const MachineName: string): _UTF8Encoding;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoMissingManifestResourceException provides a Create and CreateRemote method to \r\n// create instances of the default interface _MissingManifestResourceException exposed by \r\n// the CoClass MissingManifestResourceException. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoMissingManifestResourceException = class\r\n class function Create: _MissingManifestResourceException;\r\n class function CreateRemote(const MachineName: string): _MissingManifestResourceException;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoNeutralResourcesLanguageAttribute provides a Create and CreateRemote method to \r\n// create instances of the default interface _NeutralResourcesLanguageAttribute exposed by \r\n// the CoClass NeutralResourcesLanguageAttribute. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoNeutralResourcesLanguageAttribute = class\r\n class function Create: _NeutralResourcesLanguageAttribute;\r\n class function CreateRemote(const MachineName: string): _NeutralResourcesLanguageAttribute;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoResourceManager provides a Create and CreateRemote method to \r\n// create instances of the default interface _ResourceManager exposed by \r\n// the CoClass ResourceManager. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoResourceManager = class\r\n class function Create: _ResourceManager;\r\n class function CreateRemote(const MachineName: string): _ResourceManager;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoResourceReader provides a Create and CreateRemote method to \r\n// create instances of the default interface _ResourceReader exposed by \r\n// the CoClass ResourceReader. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoResourceReader = class\r\n class function Create: _ResourceReader;\r\n class function CreateRemote(const MachineName: string): _ResourceReader;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoResourceSet provides a Create and CreateRemote method to \r\n// create instances of the default interface _ResourceSet exposed by \r\n// the CoClass ResourceSet. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoResourceSet = class\r\n class function Create: _ResourceSet;\r\n class function CreateRemote(const MachineName: string): _ResourceSet;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoResourceWriter provides a Create and CreateRemote method to \r\n// create instances of the default interface _ResourceWriter exposed by \r\n// the CoClass ResourceWriter. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoResourceWriter = class\r\n class function Create: _ResourceWriter;\r\n class function CreateRemote(const MachineName: string): _ResourceWriter;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoSatelliteContractVersionAttribute provides a Create and CreateRemote method to \r\n// create instances of the default interface _SatelliteContractVersionAttribute exposed by \r\n// the CoClass SatelliteContractVersionAttribute. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoSatelliteContractVersionAttribute = class\r\n class function Create: _SatelliteContractVersionAttribute;\r\n class function CreateRemote(const MachineName: string): _SatelliteContractVersionAttribute;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoRegistry provides a Create and CreateRemote method to \r\n// create instances of the default interface _Registry exposed by \r\n// the CoClass Registry. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoRegistry = class\r\n class function Create: _Registry;\r\n class function CreateRemote(const MachineName: string): _Registry;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoRegistryKey provides a Create and CreateRemote method to \r\n// create instances of the default interface _RegistryKey exposed by \r\n// the CoClass RegistryKey. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoRegistryKey = class\r\n class function Create: _RegistryKey;\r\n class function CreateRemote(const MachineName: string): _RegistryKey;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoX509Certificate provides a Create and CreateRemote method to \r\n// create instances of the default interface _X509Certificate exposed by \r\n// the CoClass X509Certificate. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoX509Certificate = class\r\n class function Create: _X509Certificate;\r\n class function CreateRemote(const MachineName: string): _X509Certificate;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoAsymmetricAlgorithm provides a Create and CreateRemote method to \r\n// create instances of the default interface _AsymmetricAlgorithm exposed by \r\n// the CoClass AsymmetricAlgorithm. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoAsymmetricAlgorithm = class\r\n class function Create: _AsymmetricAlgorithm;\r\n class function CreateRemote(const MachineName: string): _AsymmetricAlgorithm;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoAsymmetricKeyExchangeDeformatter provides a Create and CreateRemote method to \r\n// create instances of the default interface _AsymmetricKeyExchangeDeformatter exposed by \r\n// the CoClass AsymmetricKeyExchangeDeformatter. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoAsymmetricKeyExchangeDeformatter = class\r\n class function Create: _AsymmetricKeyExchangeDeformatter;\r\n class function CreateRemote(const MachineName: string): _AsymmetricKeyExchangeDeformatter;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoAsymmetricKeyExchangeFormatter provides a Create and CreateRemote method to \r\n// create instances of the default interface _AsymmetricKeyExchangeFormatter exposed by \r\n// the CoClass AsymmetricKeyExchangeFormatter. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoAsymmetricKeyExchangeFormatter = class\r\n class function Create: _AsymmetricKeyExchangeFormatter;\r\n class function CreateRemote(const MachineName: string): _AsymmetricKeyExchangeFormatter;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoAsymmetricSignatureDeformatter provides a Create and CreateRemote method to \r\n// create instances of the default interface _AsymmetricSignatureDeformatter exposed by \r\n// the CoClass AsymmetricSignatureDeformatter. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoAsymmetricSignatureDeformatter = class\r\n class function Create: _AsymmetricSignatureDeformatter;\r\n class function CreateRemote(const MachineName: string): _AsymmetricSignatureDeformatter;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoAsymmetricSignatureFormatter provides a Create and CreateRemote method to \r\n// create instances of the default interface _AsymmetricSignatureFormatter exposed by \r\n// the CoClass AsymmetricSignatureFormatter. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoAsymmetricSignatureFormatter = class\r\n class function Create: _AsymmetricSignatureFormatter;\r\n class function CreateRemote(const MachineName: string): _AsymmetricSignatureFormatter;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoToBase64Transform provides a Create and CreateRemote method to \r\n// create instances of the default interface _ToBase64Transform exposed by \r\n// the CoClass ToBase64Transform. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoToBase64Transform = class\r\n class function Create: _ToBase64Transform;\r\n class function CreateRemote(const MachineName: string): _ToBase64Transform;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoFromBase64Transform provides a Create and CreateRemote method to \r\n// create instances of the default interface _FromBase64Transform exposed by \r\n// the CoClass FromBase64Transform. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoFromBase64Transform = class\r\n class function Create: _FromBase64Transform;\r\n class function CreateRemote(const MachineName: string): _FromBase64Transform;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoKeySizes provides a Create and CreateRemote method to \r\n// create instances of the default interface _KeySizes exposed by \r\n// the CoClass KeySizes. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoKeySizes = class\r\n class function Create: _KeySizes;\r\n class function CreateRemote(const MachineName: string): _KeySizes;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoCryptographicException provides a Create and CreateRemote method to \r\n// create instances of the default interface _CryptographicException exposed by \r\n// the CoClass CryptographicException. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoCryptographicException = class\r\n class function Create: _CryptographicException;\r\n class function CreateRemote(const MachineName: string): _CryptographicException;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoCryptographicUnexpectedOperationException provides a Create and CreateRemote method to \r\n// create instances of the default interface _CryptographicUnexpectedOperationException exposed by \r\n// the CoClass CryptographicUnexpectedOperationException. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoCryptographicUnexpectedOperationException = class\r\n class function Create: _CryptographicUnexpectedOperationException;\r\n class function CreateRemote(const MachineName: string): _CryptographicUnexpectedOperationException;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoCryptoAPITransform provides a Create and CreateRemote method to \r\n// create instances of the default interface _CryptoAPITransform exposed by \r\n// the CoClass CryptoAPITransform. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoCryptoAPITransform = class\r\n class function Create: _CryptoAPITransform;\r\n class function CreateRemote(const MachineName: string): _CryptoAPITransform;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoCspParameters provides a Create and CreateRemote method to \r\n// create instances of the default interface _CspParameters exposed by \r\n// the CoClass CspParameters. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoCspParameters = class\r\n class function Create: _CspParameters;\r\n class function CreateRemote(const MachineName: string): _CspParameters;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoCryptoConfig provides a Create and CreateRemote method to \r\n// create instances of the default interface _CryptoConfig exposed by \r\n// the CoClass CryptoConfig. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoCryptoConfig = class\r\n class function Create: _CryptoConfig;\r\n class function CreateRemote(const MachineName: string): _CryptoConfig;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoStream provides a Create and CreateRemote method to \r\n// create instances of the default interface _Stream exposed by \r\n// the CoClass Stream. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoStream = class\r\n class function Create: _Stream;\r\n class function CreateRemote(const MachineName: string): _Stream;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoCryptoStream provides a Create and CreateRemote method to \r\n// create instances of the default interface _CryptoStream exposed by \r\n// the CoClass CryptoStream. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoCryptoStream = class\r\n class function Create: _CryptoStream;\r\n class function CreateRemote(const MachineName: string): _CryptoStream;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoSymmetricAlgorithm provides a Create and CreateRemote method to \r\n// create instances of the default interface _SymmetricAlgorithm exposed by \r\n// the CoClass SymmetricAlgorithm. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoSymmetricAlgorithm = class\r\n class function Create: _SymmetricAlgorithm;\r\n class function CreateRemote(const MachineName: string): _SymmetricAlgorithm;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoDES provides a Create and CreateRemote method to \r\n// create instances of the default interface _DES exposed by \r\n// the CoClass DES. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoDES = class\r\n class function Create: _DES;\r\n class function CreateRemote(const MachineName: string): _DES;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoDESCryptoServiceProvider provides a Create and CreateRemote method to \r\n// create instances of the default interface _DESCryptoServiceProvider exposed by \r\n// the CoClass DESCryptoServiceProvider. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoDESCryptoServiceProvider = class\r\n class function Create: _DESCryptoServiceProvider;\r\n class function CreateRemote(const MachineName: string): _DESCryptoServiceProvider;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoDeriveBytes provides a Create and CreateRemote method to \r\n// create instances of the default interface _DeriveBytes exposed by \r\n// the CoClass DeriveBytes. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoDeriveBytes = class\r\n class function Create: _DeriveBytes;\r\n class function CreateRemote(const MachineName: string): _DeriveBytes;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoDSA provides a Create and CreateRemote method to \r\n// create instances of the default interface _DSA exposed by \r\n// the CoClass DSA. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoDSA = class\r\n class function Create: _DSA;\r\n class function CreateRemote(const MachineName: string): _DSA;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoDSACryptoServiceProvider provides a Create and CreateRemote method to \r\n// create instances of the default interface _DSACryptoServiceProvider exposed by \r\n// the CoClass DSACryptoServiceProvider. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoDSACryptoServiceProvider = class\r\n class function Create: _DSACryptoServiceProvider;\r\n class function CreateRemote(const MachineName: string): _DSACryptoServiceProvider;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoDSASignatureDeformatter provides a Create and CreateRemote method to \r\n// create instances of the default interface _DSASignatureDeformatter exposed by \r\n// the CoClass DSASignatureDeformatter. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoDSASignatureDeformatter = class\r\n class function Create: _DSASignatureDeformatter;\r\n class function CreateRemote(const MachineName: string): _DSASignatureDeformatter;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoDSASignatureFormatter provides a Create and CreateRemote method to \r\n// create instances of the default interface _DSASignatureFormatter exposed by \r\n// the CoClass DSASignatureFormatter. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoDSASignatureFormatter = class\r\n class function Create: _DSASignatureFormatter;\r\n class function CreateRemote(const MachineName: string): _DSASignatureFormatter;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoHashAlgorithm provides a Create and CreateRemote method to \r\n// create instances of the default interface _HashAlgorithm exposed by \r\n// the CoClass HashAlgorithm. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoHashAlgorithm = class\r\n class function Create: _HashAlgorithm;\r\n class function CreateRemote(const MachineName: string): _HashAlgorithm;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoKeyedHashAlgorithm provides a Create and CreateRemote method to \r\n// create instances of the default interface _KeyedHashAlgorithm exposed by \r\n// the CoClass KeyedHashAlgorithm. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoKeyedHashAlgorithm = class\r\n class function Create: _KeyedHashAlgorithm;\r\n class function CreateRemote(const MachineName: string): _KeyedHashAlgorithm;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoHMACSHA1 provides a Create and CreateRemote method to \r\n// create instances of the default interface _HMACSHA1 exposed by \r\n// the CoClass HMACSHA1. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoHMACSHA1 = class\r\n class function Create: _HMACSHA1;\r\n class function CreateRemote(const MachineName: string): _HMACSHA1;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoMACTripleDES provides a Create and CreateRemote method to \r\n// create instances of the default interface _MACTripleDES exposed by \r\n// the CoClass MACTripleDES. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoMACTripleDES = class\r\n class function Create: _MACTripleDES;\r\n class function CreateRemote(const MachineName: string): _MACTripleDES;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoMD5 provides a Create and CreateRemote method to \r\n// create instances of the default interface _MD5 exposed by \r\n// the CoClass MD5. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoMD5 = class\r\n class function Create: _MD5;\r\n class function CreateRemote(const MachineName: string): _MD5;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoMD5CryptoServiceProvider provides a Create and CreateRemote method to \r\n// create instances of the default interface _MD5CryptoServiceProvider exposed by \r\n// the CoClass MD5CryptoServiceProvider. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoMD5CryptoServiceProvider = class\r\n class function Create: _MD5CryptoServiceProvider;\r\n class function CreateRemote(const MachineName: string): _MD5CryptoServiceProvider;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoMaskGenerationMethod provides a Create and CreateRemote method to \r\n// create instances of the default interface _MaskGenerationMethod exposed by \r\n// the CoClass MaskGenerationMethod. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoMaskGenerationMethod = class\r\n class function Create: _MaskGenerationMethod;\r\n class function CreateRemote(const MachineName: string): _MaskGenerationMethod;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoPasswordDeriveBytes provides a Create and CreateRemote method to \r\n// create instances of the default interface _PasswordDeriveBytes exposed by \r\n// the CoClass PasswordDeriveBytes. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoPasswordDeriveBytes = class\r\n class function Create: _PasswordDeriveBytes;\r\n class function CreateRemote(const MachineName: string): _PasswordDeriveBytes;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoPKCS1MaskGenerationMethod provides a Create and CreateRemote method to \r\n// create instances of the default interface _PKCS1MaskGenerationMethod exposed by \r\n// the CoClass PKCS1MaskGenerationMethod. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoPKCS1MaskGenerationMethod = class\r\n class function Create: _PKCS1MaskGenerationMethod;\r\n class function CreateRemote(const MachineName: string): _PKCS1MaskGenerationMethod;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoRC2 provides a Create and CreateRemote method to \r\n// create instances of the default interface _RC2 exposed by \r\n// the CoClass RC2. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoRC2 = class\r\n class function Create: _RC2;\r\n class function CreateRemote(const MachineName: string): _RC2;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoRC2CryptoServiceProvider provides a Create and CreateRemote method to \r\n// create instances of the default interface _RC2CryptoServiceProvider exposed by \r\n// the CoClass RC2CryptoServiceProvider. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoRC2CryptoServiceProvider = class\r\n class function Create: _RC2CryptoServiceProvider;\r\n class function CreateRemote(const MachineName: string): _RC2CryptoServiceProvider;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoRandomNumberGenerator provides a Create and CreateRemote method to \r\n// create instances of the default interface _RandomNumberGenerator exposed by \r\n// the CoClass RandomNumberGenerator. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoRandomNumberGenerator = class\r\n class function Create: _RandomNumberGenerator;\r\n class function CreateRemote(const MachineName: string): _RandomNumberGenerator;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoRNGCryptoServiceProvider provides a Create and CreateRemote method to \r\n// create instances of the default interface _RNGCryptoServiceProvider exposed by \r\n// the CoClass RNGCryptoServiceProvider. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoRNGCryptoServiceProvider = class\r\n class function Create: _RNGCryptoServiceProvider;\r\n class function CreateRemote(const MachineName: string): _RNGCryptoServiceProvider;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoRSA provides a Create and CreateRemote method to \r\n// create instances of the default interface _RSA exposed by \r\n// the CoClass RSA. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoRSA = class\r\n class function Create: _RSA;\r\n class function CreateRemote(const MachineName: string): _RSA;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoRSACryptoServiceProvider provides a Create and CreateRemote method to \r\n// create instances of the default interface _RSACryptoServiceProvider exposed by \r\n// the CoClass RSACryptoServiceProvider. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoRSACryptoServiceProvider = class\r\n class function Create: _RSACryptoServiceProvider;\r\n class function CreateRemote(const MachineName: string): _RSACryptoServiceProvider;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoRSAOAEPKeyExchangeDeformatter provides a Create and CreateRemote method to \r\n// create instances of the default interface _RSAOAEPKeyExchangeDeformatter exposed by \r\n// the CoClass RSAOAEPKeyExchangeDeformatter. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoRSAOAEPKeyExchangeDeformatter = class\r\n class function Create: _RSAOAEPKeyExchangeDeformatter;\r\n class function CreateRemote(const MachineName: string): _RSAOAEPKeyExchangeDeformatter;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoRSAOAEPKeyExchangeFormatter provides a Create and CreateRemote method to \r\n// create instances of the default interface _RSAOAEPKeyExchangeFormatter exposed by \r\n// the CoClass RSAOAEPKeyExchangeFormatter. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoRSAOAEPKeyExchangeFormatter = class\r\n class function Create: _RSAOAEPKeyExchangeFormatter;\r\n class function CreateRemote(const MachineName: string): _RSAOAEPKeyExchangeFormatter;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoRSAPKCS1KeyExchangeDeformatter provides a Create and CreateRemote method to \r\n// create instances of the default interface _RSAPKCS1KeyExchangeDeformatter exposed by \r\n// the CoClass RSAPKCS1KeyExchangeDeformatter. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoRSAPKCS1KeyExchangeDeformatter = class\r\n class function Create: _RSAPKCS1KeyExchangeDeformatter;\r\n class function CreateRemote(const MachineName: string): _RSAPKCS1KeyExchangeDeformatter;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoRSAPKCS1KeyExchangeFormatter provides a Create and CreateRemote method to \r\n// create instances of the default interface _RSAPKCS1KeyExchangeFormatter exposed by \r\n// the CoClass RSAPKCS1KeyExchangeFormatter. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoRSAPKCS1KeyExchangeFormatter = class\r\n class function Create: _RSAPKCS1KeyExchangeFormatter;\r\n class function CreateRemote(const MachineName: string): _RSAPKCS1KeyExchangeFormatter;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoRSAPKCS1SignatureDeformatter provides a Create and CreateRemote method to \r\n// create instances of the default interface _RSAPKCS1SignatureDeformatter exposed by \r\n// the CoClass RSAPKCS1SignatureDeformatter. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoRSAPKCS1SignatureDeformatter = class\r\n class function Create: _RSAPKCS1SignatureDeformatter;\r\n class function CreateRemote(const MachineName: string): _RSAPKCS1SignatureDeformatter;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoRSAPKCS1SignatureFormatter provides a Create and CreateRemote method to \r\n// create instances of the default interface _RSAPKCS1SignatureFormatter exposed by \r\n// the CoClass RSAPKCS1SignatureFormatter. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoRSAPKCS1SignatureFormatter = class\r\n class function Create: _RSAPKCS1SignatureFormatter;\r\n class function CreateRemote(const MachineName: string): _RSAPKCS1SignatureFormatter;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoRijndael provides a Create and CreateRemote method to \r\n// create instances of the default interface _Rijndael exposed by \r\n// the CoClass Rijndael. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoRijndael = class\r\n class function Create: _Rijndael;\r\n class function CreateRemote(const MachineName: string): _Rijndael;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoRijndaelManaged provides a Create and CreateRemote method to \r\n// create instances of the default interface _RijndaelManaged exposed by \r\n// the CoClass RijndaelManaged. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoRijndaelManaged = class\r\n class function Create: _RijndaelManaged;\r\n class function CreateRemote(const MachineName: string): _RijndaelManaged;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoSHA1 provides a Create and CreateRemote method to \r\n// create instances of the default interface _SHA1 exposed by \r\n// the CoClass SHA1. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoSHA1 = class\r\n class function Create: _SHA1;\r\n class function CreateRemote(const MachineName: string): _SHA1;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoSHA1CryptoServiceProvider provides a Create and CreateRemote method to \r\n// create instances of the default interface _SHA1CryptoServiceProvider exposed by \r\n// the CoClass SHA1CryptoServiceProvider. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoSHA1CryptoServiceProvider = class\r\n class function Create: _SHA1CryptoServiceProvider;\r\n class function CreateRemote(const MachineName: string): _SHA1CryptoServiceProvider;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoSHA1Managed provides a Create and CreateRemote method to \r\n// create instances of the default interface _SHA1Managed exposed by \r\n// the CoClass SHA1Managed. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoSHA1Managed = class\r\n class function Create: _SHA1Managed;\r\n class function CreateRemote(const MachineName: string): _SHA1Managed;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoSHA256 provides a Create and CreateRemote method to \r\n// create instances of the default interface _SHA256 exposed by \r\n// the CoClass SHA256. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoSHA256 = class\r\n class function Create: _SHA256;\r\n class function CreateRemote(const MachineName: string): _SHA256;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoSHA256Managed provides a Create and CreateRemote method to \r\n// create instances of the default interface _SHA256Managed exposed by \r\n// the CoClass SHA256Managed. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoSHA256Managed = class\r\n class function Create: _SHA256Managed;\r\n class function CreateRemote(const MachineName: string): _SHA256Managed;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoSHA384 provides a Create and CreateRemote method to \r\n// create instances of the default interface _SHA384 exposed by \r\n// the CoClass SHA384. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoSHA384 = class\r\n class function Create: _SHA384;\r\n class function CreateRemote(const MachineName: string): _SHA384;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoSHA384Managed provides a Create and CreateRemote method to \r\n// create instances of the default interface _SHA384Managed exposed by \r\n// the CoClass SHA384Managed. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoSHA384Managed = class\r\n class function Create: _SHA384Managed;\r\n class function CreateRemote(const MachineName: string): _SHA384Managed;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoSHA512 provides a Create and CreateRemote method to \r\n// create instances of the default interface _SHA512 exposed by \r\n// the CoClass SHA512. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoSHA512 = class\r\n class function Create: _SHA512;\r\n class function CreateRemote(const MachineName: string): _SHA512;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoSHA512Managed provides a Create and CreateRemote method to \r\n// create instances of the default interface _SHA512Managed exposed by \r\n// the CoClass SHA512Managed. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoSHA512Managed = class\r\n class function Create: _SHA512Managed;\r\n class function CreateRemote(const MachineName: string): _SHA512Managed;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoSignatureDescription provides a Create and CreateRemote method to \r\n// create instances of the default interface _SignatureDescription exposed by \r\n// the CoClass SignatureDescription. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoSignatureDescription = class\r\n class function Create: _SignatureDescription;\r\n class function CreateRemote(const MachineName: string): _SignatureDescription;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoTripleDES provides a Create and CreateRemote method to \r\n// create instances of the default interface _TripleDES exposed by \r\n// the CoClass TripleDES. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoTripleDES = class\r\n class function Create: _TripleDES;\r\n class function CreateRemote(const MachineName: string): _TripleDES;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoTripleDESCryptoServiceProvider provides a Create and CreateRemote method to \r\n// create instances of the default interface _TripleDESCryptoServiceProvider exposed by \r\n// the CoClass TripleDESCryptoServiceProvider. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoTripleDESCryptoServiceProvider = class\r\n class function Create: _TripleDESCryptoServiceProvider;\r\n class function CreateRemote(const MachineName: string): _TripleDESCryptoServiceProvider;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoAllMembershipCondition provides a Create and CreateRemote method to \r\n// create instances of the default interface _AllMembershipCondition exposed by \r\n// the CoClass AllMembershipCondition. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoAllMembershipCondition = class\r\n class function Create: _AllMembershipCondition;\r\n class function CreateRemote(const MachineName: string): _AllMembershipCondition;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoApplicationDirectory provides a Create and CreateRemote method to \r\n// create instances of the default interface _ApplicationDirectory exposed by \r\n// the CoClass ApplicationDirectory. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoApplicationDirectory = class\r\n class function Create: _ApplicationDirectory;\r\n class function CreateRemote(const MachineName: string): _ApplicationDirectory;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoApplicationDirectoryMembershipCondition provides a Create and CreateRemote method to \r\n// create instances of the default interface _ApplicationDirectoryMembershipCondition exposed by \r\n// the CoClass ApplicationDirectoryMembershipCondition. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoApplicationDirectoryMembershipCondition = class\r\n class function Create: _ApplicationDirectoryMembershipCondition;\r\n class function CreateRemote(const MachineName: string): _ApplicationDirectoryMembershipCondition;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoCodeGroup provides a Create and CreateRemote method to \r\n// create instances of the default interface _CodeGroup exposed by \r\n// the CoClass CodeGroup. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoCodeGroup = class\r\n class function Create: _CodeGroup;\r\n class function CreateRemote(const MachineName: string): _CodeGroup;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoEvidence provides a Create and CreateRemote method to \r\n// create instances of the default interface _Evidence exposed by \r\n// the CoClass Evidence. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoEvidence = class\r\n class function Create: _Evidence;\r\n class function CreateRemote(const MachineName: string): _Evidence;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoFileCodeGroup provides a Create and CreateRemote method to \r\n// create instances of the default interface _FileCodeGroup exposed by \r\n// the CoClass FileCodeGroup. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoFileCodeGroup = class\r\n class function Create: _FileCodeGroup;\r\n class function CreateRemote(const MachineName: string): _FileCodeGroup;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoFirstMatchCodeGroup provides a Create and CreateRemote method to \r\n// create instances of the default interface _FirstMatchCodeGroup exposed by \r\n// the CoClass FirstMatchCodeGroup. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoFirstMatchCodeGroup = class\r\n class function Create: _FirstMatchCodeGroup;\r\n class function CreateRemote(const MachineName: string): _FirstMatchCodeGroup;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoHash provides a Create and CreateRemote method to \r\n// create instances of the default interface _Hash exposed by \r\n// the CoClass Hash. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoHash = class\r\n class function Create: _Hash;\r\n class function CreateRemote(const MachineName: string): _Hash;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoHashMembershipCondition provides a Create and CreateRemote method to \r\n// create instances of the default interface _HashMembershipCondition exposed by \r\n// the CoClass HashMembershipCondition. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoHashMembershipCondition = class\r\n class function Create: _HashMembershipCondition;\r\n class function CreateRemote(const MachineName: string): _HashMembershipCondition;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoNetCodeGroup provides a Create and CreateRemote method to \r\n// create instances of the default interface _NetCodeGroup exposed by \r\n// the CoClass NetCodeGroup. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoNetCodeGroup = class\r\n class function Create: _NetCodeGroup;\r\n class function CreateRemote(const MachineName: string): _NetCodeGroup;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoPermissionRequestEvidence provides a Create and CreateRemote method to \r\n// create instances of the default interface _PermissionRequestEvidence exposed by \r\n// the CoClass PermissionRequestEvidence. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoPermissionRequestEvidence = class\r\n class function Create: _PermissionRequestEvidence;\r\n class function CreateRemote(const MachineName: string): _PermissionRequestEvidence;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoPolicyException provides a Create and CreateRemote method to \r\n// create instances of the default interface _PolicyException exposed by \r\n// the CoClass PolicyException. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoPolicyException = class\r\n class function Create: _PolicyException;\r\n class function CreateRemote(const MachineName: string): _PolicyException;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoPolicyLevel provides a Create and CreateRemote method to \r\n// create instances of the default interface _PolicyLevel exposed by \r\n// the CoClass PolicyLevel. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoPolicyLevel = class\r\n class function Create: _PolicyLevel;\r\n class function CreateRemote(const MachineName: string): _PolicyLevel;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoPolicyStatement provides a Create and CreateRemote method to \r\n// create instances of the default interface _PolicyStatement exposed by \r\n// the CoClass PolicyStatement. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoPolicyStatement = class\r\n class function Create: _PolicyStatement;\r\n class function CreateRemote(const MachineName: string): _PolicyStatement;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoPublisher provides a Create and CreateRemote method to \r\n// create instances of the default interface _Publisher exposed by \r\n// the CoClass Publisher. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoPublisher = class\r\n class function Create: _Publisher;\r\n class function CreateRemote(const MachineName: string): _Publisher;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoPublisherMembershipCondition provides a Create and CreateRemote method to \r\n// create instances of the default interface _PublisherMembershipCondition exposed by \r\n// the CoClass PublisherMembershipCondition. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoPublisherMembershipCondition = class\r\n class function Create: _PublisherMembershipCondition;\r\n class function CreateRemote(const MachineName: string): _PublisherMembershipCondition;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoSite provides a Create and CreateRemote method to \r\n// create instances of the default interface _Site exposed by \r\n// the CoClass Site. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoSite = class\r\n class function Create: _Site;\r\n class function CreateRemote(const MachineName: string): _Site;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoSiteMembershipCondition provides a Create and CreateRemote method to \r\n// create instances of the default interface _SiteMembershipCondition exposed by \r\n// the CoClass SiteMembershipCondition. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoSiteMembershipCondition = class\r\n class function Create: _SiteMembershipCondition;\r\n class function CreateRemote(const MachineName: string): _SiteMembershipCondition;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoStrongName provides a Create and CreateRemote method to \r\n// create instances of the default interface _StrongName exposed by \r\n// the CoClass StrongName. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoStrongName = class\r\n class function Create: _StrongName;\r\n class function CreateRemote(const MachineName: string): _StrongName;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoStrongNameMembershipCondition provides a Create and CreateRemote method to \r\n// create instances of the default interface _StrongNameMembershipCondition exposed by \r\n// the CoClass StrongNameMembershipCondition. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoStrongNameMembershipCondition = class\r\n class function Create: _StrongNameMembershipCondition;\r\n class function CreateRemote(const MachineName: string): _StrongNameMembershipCondition;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoUnionCodeGroup provides a Create and CreateRemote method to \r\n// create instances of the default interface _UnionCodeGroup exposed by \r\n// the CoClass UnionCodeGroup. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoUnionCodeGroup = class\r\n class function Create: _UnionCodeGroup;\r\n class function CreateRemote(const MachineName: string): _UnionCodeGroup;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoUrl provides a Create and CreateRemote method to \r\n// create instances of the default interface _Url exposed by \r\n// the CoClass Url. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoUrl = class\r\n class function Create: _Url;\r\n class function CreateRemote(const MachineName: string): _Url;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoUrlMembershipCondition provides a Create and CreateRemote method to \r\n// create instances of the default interface _UrlMembershipCondition exposed by \r\n// the CoClass UrlMembershipCondition. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoUrlMembershipCondition = class\r\n class function Create: _UrlMembershipCondition;\r\n class function CreateRemote(const MachineName: string): _UrlMembershipCondition;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoZone provides a Create and CreateRemote method to \r\n// create instances of the default interface _Zone exposed by \r\n// the CoClass Zone. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoZone = class\r\n class function Create: _Zone;\r\n class function CreateRemote(const MachineName: string): _Zone;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoZoneMembershipCondition provides a Create and CreateRemote method to \r\n// create instances of the default interface _ZoneMembershipCondition exposed by \r\n// the CoClass ZoneMembershipCondition. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoZoneMembershipCondition = class\r\n class function Create: _ZoneMembershipCondition;\r\n class function CreateRemote(const MachineName: string): _ZoneMembershipCondition;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoGenericIdentity provides a Create and CreateRemote method to \r\n// create instances of the default interface _GenericIdentity exposed by \r\n// the CoClass GenericIdentity. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoGenericIdentity = class\r\n class function Create: _GenericIdentity;\r\n class function CreateRemote(const MachineName: string): _GenericIdentity;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoGenericPrincipal provides a Create and CreateRemote method to \r\n// create instances of the default interface _GenericPrincipal exposed by \r\n// the CoClass GenericPrincipal. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoGenericPrincipal = class\r\n class function Create: _GenericPrincipal;\r\n class function CreateRemote(const MachineName: string): _GenericPrincipal;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoWindowsIdentity provides a Create and CreateRemote method to \r\n// create instances of the default interface _WindowsIdentity exposed by \r\n// the CoClass WindowsIdentity. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoWindowsIdentity = class\r\n class function Create: _WindowsIdentity;\r\n class function CreateRemote(const MachineName: string): _WindowsIdentity;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoWindowsImpersonationContext provides a Create and CreateRemote method to \r\n// create instances of the default interface _WindowsImpersonationContext exposed by \r\n// the CoClass WindowsImpersonationContext. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoWindowsImpersonationContext = class\r\n class function Create: _WindowsImpersonationContext;\r\n class function CreateRemote(const MachineName: string): _WindowsImpersonationContext;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoWindowsPrincipal provides a Create and CreateRemote method to \r\n// create instances of the default interface _WindowsPrincipal exposed by \r\n// the CoClass WindowsPrincipal. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoWindowsPrincipal = class\r\n class function Create: _WindowsPrincipal;\r\n class function CreateRemote(const MachineName: string): _WindowsPrincipal;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoDispIdAttribute provides a Create and CreateRemote method to \r\n// create instances of the default interface _DispIdAttribute exposed by \r\n// the CoClass DispIdAttribute. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoDispIdAttribute = class\r\n class function Create: _DispIdAttribute;\r\n class function CreateRemote(const MachineName: string): _DispIdAttribute;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoInterfaceTypeAttribute provides a Create and CreateRemote method to \r\n// create instances of the default interface _InterfaceTypeAttribute exposed by \r\n// the CoClass InterfaceTypeAttribute. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoInterfaceTypeAttribute = class\r\n class function Create: _InterfaceTypeAttribute;\r\n class function CreateRemote(const MachineName: string): _InterfaceTypeAttribute;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoClassInterfaceAttribute provides a Create and CreateRemote method to \r\n// create instances of the default interface _ClassInterfaceAttribute exposed by \r\n// the CoClass ClassInterfaceAttribute. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoClassInterfaceAttribute = class\r\n class function Create: _ClassInterfaceAttribute;\r\n class function CreateRemote(const MachineName: string): _ClassInterfaceAttribute;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoComVisibleAttribute provides a Create and CreateRemote method to \r\n// create instances of the default interface _ComVisibleAttribute exposed by \r\n// the CoClass ComVisibleAttribute. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoComVisibleAttribute = class\r\n class function Create: _ComVisibleAttribute;\r\n class function CreateRemote(const MachineName: string): _ComVisibleAttribute;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoLCIDConversionAttribute provides a Create and CreateRemote method to \r\n// create instances of the default interface _LCIDConversionAttribute exposed by \r\n// the CoClass LCIDConversionAttribute. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoLCIDConversionAttribute = class\r\n class function Create: _LCIDConversionAttribute;\r\n class function CreateRemote(const MachineName: string): _LCIDConversionAttribute;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoComRegisterFunctionAttribute provides a Create and CreateRemote method to \r\n// create instances of the default interface _ComRegisterFunctionAttribute exposed by \r\n// the CoClass ComRegisterFunctionAttribute. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoComRegisterFunctionAttribute = class\r\n class function Create: _ComRegisterFunctionAttribute;\r\n class function CreateRemote(const MachineName: string): _ComRegisterFunctionAttribute;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoComUnregisterFunctionAttribute provides a Create and CreateRemote method to \r\n// create instances of the default interface _ComUnregisterFunctionAttribute exposed by \r\n// the CoClass ComUnregisterFunctionAttribute. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoComUnregisterFunctionAttribute = class\r\n class function Create: _ComUnregisterFunctionAttribute;\r\n class function CreateRemote(const MachineName: string): _ComUnregisterFunctionAttribute;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoProgIdAttribute provides a Create and CreateRemote method to \r\n// create instances of the default interface _ProgIdAttribute exposed by \r\n// the CoClass ProgIdAttribute. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoProgIdAttribute = class\r\n class function Create: _ProgIdAttribute;\r\n class function CreateRemote(const MachineName: string): _ProgIdAttribute;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoImportedFromTypeLibAttribute provides a Create and CreateRemote method to \r\n// create instances of the default interface _ImportedFromTypeLibAttribute exposed by \r\n// the CoClass ImportedFromTypeLibAttribute. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoImportedFromTypeLibAttribute = class\r\n class function Create: _ImportedFromTypeLibAttribute;\r\n class function CreateRemote(const MachineName: string): _ImportedFromTypeLibAttribute;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoIDispatchImplAttribute provides a Create and CreateRemote method to \r\n// create instances of the default interface _IDispatchImplAttribute exposed by \r\n// the CoClass IDispatchImplAttribute. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoIDispatchImplAttribute = class\r\n class function Create: _IDispatchImplAttribute;\r\n class function CreateRemote(const MachineName: string): _IDispatchImplAttribute;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoComSourceInterfacesAttribute provides a Create and CreateRemote method to \r\n// create instances of the default interface _ComSourceInterfacesAttribute exposed by \r\n// the CoClass ComSourceInterfacesAttribute. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoComSourceInterfacesAttribute = class\r\n class function Create: _ComSourceInterfacesAttribute;\r\n class function CreateRemote(const MachineName: string): _ComSourceInterfacesAttribute;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoComConversionLossAttribute provides a Create and CreateRemote method to \r\n// create instances of the default interface _ComConversionLossAttribute exposed by \r\n// the CoClass ComConversionLossAttribute. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoComConversionLossAttribute = class\r\n class function Create: _ComConversionLossAttribute;\r\n class function CreateRemote(const MachineName: string): _ComConversionLossAttribute;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoTypeLibTypeAttribute provides a Create and CreateRemote method to \r\n// create instances of the default interface _TypeLibTypeAttribute exposed by \r\n// the CoClass TypeLibTypeAttribute. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoTypeLibTypeAttribute = class\r\n class function Create: _TypeLibTypeAttribute;\r\n class function CreateRemote(const MachineName: string): _TypeLibTypeAttribute;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoTypeLibFuncAttribute provides a Create and CreateRemote method to \r\n// create instances of the default interface _TypeLibFuncAttribute exposed by \r\n// the CoClass TypeLibFuncAttribute. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoTypeLibFuncAttribute = class\r\n class function Create: _TypeLibFuncAttribute;\r\n class function CreateRemote(const MachineName: string): _TypeLibFuncAttribute;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoTypeLibVarAttribute provides a Create and CreateRemote method to \r\n// create instances of the default interface _TypeLibVarAttribute exposed by \r\n// the CoClass TypeLibVarAttribute. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoTypeLibVarAttribute = class\r\n class function Create: _TypeLibVarAttribute;\r\n class function CreateRemote(const MachineName: string): _TypeLibVarAttribute;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoMarshalAsAttribute provides a Create and CreateRemote method to \r\n// create instances of the default interface _MarshalAsAttribute exposed by \r\n// the CoClass MarshalAsAttribute. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoMarshalAsAttribute = class\r\n class function Create: _MarshalAsAttribute;\r\n class function CreateRemote(const MachineName: string): _MarshalAsAttribute;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoComImportAttribute provides a Create and CreateRemote method to \r\n// create instances of the default interface _ComImportAttribute exposed by \r\n// the CoClass ComImportAttribute. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoComImportAttribute = class\r\n class function Create: _ComImportAttribute;\r\n class function CreateRemote(const MachineName: string): _ComImportAttribute;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoGuidAttribute provides a Create and CreateRemote method to \r\n// create instances of the default interface _GuidAttribute exposed by \r\n// the CoClass GuidAttribute. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoGuidAttribute = class\r\n class function Create: _GuidAttribute;\r\n class function CreateRemote(const MachineName: string): _GuidAttribute;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoPreserveSigAttribute provides a Create and CreateRemote method to \r\n// create instances of the default interface _PreserveSigAttribute exposed by \r\n// the CoClass PreserveSigAttribute. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoPreserveSigAttribute = class\r\n class function Create: _PreserveSigAttribute;\r\n class function CreateRemote(const MachineName: string): _PreserveSigAttribute;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoInAttribute provides a Create and CreateRemote method to \r\n// create instances of the default interface _InAttribute exposed by \r\n// the CoClass InAttribute. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoInAttribute = class\r\n class function Create: _InAttribute;\r\n class function CreateRemote(const MachineName: string): _InAttribute;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoOutAttribute provides a Create and CreateRemote method to \r\n// create instances of the default interface _OutAttribute exposed by \r\n// the CoClass OutAttribute. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoOutAttribute = class\r\n class function Create: _OutAttribute;\r\n class function CreateRemote(const MachineName: string): _OutAttribute;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoOptionalAttribute provides a Create and CreateRemote method to \r\n// create instances of the default interface _OptionalAttribute exposed by \r\n// the CoClass OptionalAttribute. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoOptionalAttribute = class\r\n class function Create: _OptionalAttribute;\r\n class function CreateRemote(const MachineName: string): _OptionalAttribute;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoDllImportAttribute provides a Create and CreateRemote method to \r\n// create instances of the default interface _DllImportAttribute exposed by \r\n// the CoClass DllImportAttribute. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoDllImportAttribute = class\r\n class function Create: _DllImportAttribute;\r\n class function CreateRemote(const MachineName: string): _DllImportAttribute;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoStructLayoutAttribute provides a Create and CreateRemote method to \r\n// create instances of the default interface _StructLayoutAttribute exposed by \r\n// the CoClass StructLayoutAttribute. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoStructLayoutAttribute = class\r\n class function Create: _StructLayoutAttribute;\r\n class function CreateRemote(const MachineName: string): _StructLayoutAttribute;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoFieldOffsetAttribute provides a Create and CreateRemote method to \r\n// create instances of the default interface _FieldOffsetAttribute exposed by \r\n// the CoClass FieldOffsetAttribute. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoFieldOffsetAttribute = class\r\n class function Create: _FieldOffsetAttribute;\r\n class function CreateRemote(const MachineName: string): _FieldOffsetAttribute;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoComAliasNameAttribute provides a Create and CreateRemote method to \r\n// create instances of the default interface _ComAliasNameAttribute exposed by \r\n// the CoClass ComAliasNameAttribute. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoComAliasNameAttribute = class\r\n class function Create: _ComAliasNameAttribute;\r\n class function CreateRemote(const MachineName: string): _ComAliasNameAttribute;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoAutomationProxyAttribute provides a Create and CreateRemote method to \r\n// create instances of the default interface _AutomationProxyAttribute exposed by \r\n// the CoClass AutomationProxyAttribute. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoAutomationProxyAttribute = class\r\n class function Create: _AutomationProxyAttribute;\r\n class function CreateRemote(const MachineName: string): _AutomationProxyAttribute;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoPrimaryInteropAssemblyAttribute provides a Create and CreateRemote method to \r\n// create instances of the default interface _PrimaryInteropAssemblyAttribute exposed by \r\n// the CoClass PrimaryInteropAssemblyAttribute. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoPrimaryInteropAssemblyAttribute = class\r\n class function Create: _PrimaryInteropAssemblyAttribute;\r\n class function CreateRemote(const MachineName: string): _PrimaryInteropAssemblyAttribute;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoCoClassAttribute provides a Create and CreateRemote method to \r\n// create instances of the default interface _CoClassAttribute exposed by \r\n// the CoClass CoClassAttribute. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoCoClassAttribute = class\r\n class function Create: _CoClassAttribute;\r\n class function CreateRemote(const MachineName: string): _CoClassAttribute;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoComEventInterfaceAttribute provides a Create and CreateRemote method to \r\n// create instances of the default interface _ComEventInterfaceAttribute exposed by \r\n// the CoClass ComEventInterfaceAttribute. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoComEventInterfaceAttribute = class\r\n class function Create: _ComEventInterfaceAttribute;\r\n class function CreateRemote(const MachineName: string): _ComEventInterfaceAttribute;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoTypeLibVersionAttribute provides a Create and CreateRemote method to \r\n// create instances of the default interface _TypeLibVersionAttribute exposed by \r\n// the CoClass TypeLibVersionAttribute. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoTypeLibVersionAttribute = class\r\n class function Create: _TypeLibVersionAttribute;\r\n class function CreateRemote(const MachineName: string): _TypeLibVersionAttribute;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoComCompatibleVersionAttribute provides a Create and CreateRemote method to \r\n// create instances of the default interface _ComCompatibleVersionAttribute exposed by \r\n// the CoClass ComCompatibleVersionAttribute. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoComCompatibleVersionAttribute = class\r\n class function Create: _ComCompatibleVersionAttribute;\r\n class function CreateRemote(const MachineName: string): _ComCompatibleVersionAttribute;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoBestFitMappingAttribute provides a Create and CreateRemote method to \r\n// create instances of the default interface _BestFitMappingAttribute exposed by \r\n// the CoClass BestFitMappingAttribute. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoBestFitMappingAttribute = class\r\n class function Create: _BestFitMappingAttribute;\r\n class function CreateRemote(const MachineName: string): _BestFitMappingAttribute;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoExternalException provides a Create and CreateRemote method to \r\n// create instances of the default interface _ExternalException exposed by \r\n// the CoClass ExternalException. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoExternalException = class\r\n class function Create: _ExternalException;\r\n class function CreateRemote(const MachineName: string): _ExternalException;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoCOMException provides a Create and CreateRemote method to \r\n// create instances of the default interface _COMException exposed by \r\n// the CoClass COMException. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoCOMException = class\r\n class function Create: _COMException;\r\n class function CreateRemote(const MachineName: string): _COMException;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoCurrencyWrapper provides a Create and CreateRemote method to \r\n// create instances of the default interface _CurrencyWrapper exposed by \r\n// the CoClass CurrencyWrapper. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoCurrencyWrapper = class\r\n class function Create: _CurrencyWrapper;\r\n class function CreateRemote(const MachineName: string): _CurrencyWrapper;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoDispatchWrapper provides a Create and CreateRemote method to \r\n// create instances of the default interface _DispatchWrapper exposed by \r\n// the CoClass DispatchWrapper. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoDispatchWrapper = class\r\n class function Create: _DispatchWrapper;\r\n class function CreateRemote(const MachineName: string): _DispatchWrapper;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoErrorWrapper provides a Create and CreateRemote method to \r\n// create instances of the default interface _ErrorWrapper exposed by \r\n// the CoClass ErrorWrapper. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoErrorWrapper = class\r\n class function Create: _ErrorWrapper;\r\n class function CreateRemote(const MachineName: string): _ErrorWrapper;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoExtensibleClassFactory provides a Create and CreateRemote method to \r\n// create instances of the default interface _ExtensibleClassFactory exposed by \r\n// the CoClass ExtensibleClassFactory. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoExtensibleClassFactory = class\r\n class function Create: _ExtensibleClassFactory;\r\n class function CreateRemote(const MachineName: string): _ExtensibleClassFactory;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoInvalidComObjectException provides a Create and CreateRemote method to \r\n// create instances of the default interface _InvalidComObjectException exposed by \r\n// the CoClass InvalidComObjectException. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoInvalidComObjectException = class\r\n class function Create: _InvalidComObjectException;\r\n class function CreateRemote(const MachineName: string): _InvalidComObjectException;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoInvalidOleVariantTypeException provides a Create and CreateRemote method to \r\n// create instances of the default interface _InvalidOleVariantTypeException exposed by \r\n// the CoClass InvalidOleVariantTypeException. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoInvalidOleVariantTypeException = class\r\n class function Create: _InvalidOleVariantTypeException;\r\n class function CreateRemote(const MachineName: string): _InvalidOleVariantTypeException;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoMarshal provides a Create and CreateRemote method to \r\n// create instances of the default interface _Marshal exposed by \r\n// the CoClass Marshal. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoMarshal = class\r\n class function Create: _Marshal;\r\n class function CreateRemote(const MachineName: string): _Marshal;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoMarshalDirectiveException provides a Create and CreateRemote method to \r\n// create instances of the default interface _MarshalDirectiveException exposed by \r\n// the CoClass MarshalDirectiveException. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoMarshalDirectiveException = class\r\n class function Create: _MarshalDirectiveException;\r\n class function CreateRemote(const MachineName: string): _MarshalDirectiveException;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoObjectCreationDelegate provides a Create and CreateRemote method to \r\n// create instances of the default interface _ObjectCreationDelegate exposed by \r\n// the CoClass ObjectCreationDelegate. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoObjectCreationDelegate = class\r\n class function Create: _ObjectCreationDelegate;\r\n class function CreateRemote(const MachineName: string): _ObjectCreationDelegate;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoRuntimeEnvironment provides a Create and CreateRemote method to \r\n// create instances of the default interface _RuntimeEnvironment exposed by \r\n// the CoClass RuntimeEnvironment. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoRuntimeEnvironment = class\r\n class function Create: _RuntimeEnvironment;\r\n class function CreateRemote(const MachineName: string): _RuntimeEnvironment;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoSafeArrayRankMismatchException provides a Create and CreateRemote method to \r\n// create instances of the default interface _SafeArrayRankMismatchException exposed by \r\n// the CoClass SafeArrayRankMismatchException. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoSafeArrayRankMismatchException = class\r\n class function Create: _SafeArrayRankMismatchException;\r\n class function CreateRemote(const MachineName: string): _SafeArrayRankMismatchException;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoSafeArrayTypeMismatchException provides a Create and CreateRemote method to \r\n// create instances of the default interface _SafeArrayTypeMismatchException exposed by \r\n// the CoClass SafeArrayTypeMismatchException. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoSafeArrayTypeMismatchException = class\r\n class function Create: _SafeArrayTypeMismatchException;\r\n class function CreateRemote(const MachineName: string): _SafeArrayTypeMismatchException;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoSEHException provides a Create and CreateRemote method to \r\n// create instances of the default interface _SEHException exposed by \r\n// the CoClass SEHException. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoSEHException = class\r\n class function Create: _SEHException;\r\n class function CreateRemote(const MachineName: string): _SEHException;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoUnknownWrapper provides a Create and CreateRemote method to \r\n// create instances of the default interface _UnknownWrapper exposed by \r\n// the CoClass UnknownWrapper. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoUnknownWrapper = class\r\n class function Create: _UnknownWrapper;\r\n class function CreateRemote(const MachineName: string): _UnknownWrapper;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoBinaryReader provides a Create and CreateRemote method to \r\n// create instances of the default interface _BinaryReader exposed by \r\n// the CoClass BinaryReader. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoBinaryReader = class\r\n class function Create: _BinaryReader;\r\n class function CreateRemote(const MachineName: string): _BinaryReader;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoBinaryWriter provides a Create and CreateRemote method to \r\n// create instances of the default interface _BinaryWriter exposed by \r\n// the CoClass BinaryWriter. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoBinaryWriter = class\r\n class function Create: _BinaryWriter;\r\n class function CreateRemote(const MachineName: string): _BinaryWriter;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoBufferedStream provides a Create and CreateRemote method to \r\n// create instances of the default interface _BufferedStream exposed by \r\n// the CoClass BufferedStream. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoBufferedStream = class\r\n class function Create: _BufferedStream;\r\n class function CreateRemote(const MachineName: string): _BufferedStream;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoDirectory provides a Create and CreateRemote method to \r\n// create instances of the default interface _Directory exposed by \r\n// the CoClass Directory. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoDirectory = class\r\n class function Create: _Directory;\r\n class function CreateRemote(const MachineName: string): _Directory;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoFileSystemInfo provides a Create and CreateRemote method to \r\n// create instances of the default interface _FileSystemInfo exposed by \r\n// the CoClass FileSystemInfo. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoFileSystemInfo = class\r\n class function Create: _FileSystemInfo;\r\n class function CreateRemote(const MachineName: string): _FileSystemInfo;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoDirectoryInfo provides a Create and CreateRemote method to \r\n// create instances of the default interface _DirectoryInfo exposed by \r\n// the CoClass DirectoryInfo. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoDirectoryInfo = class\r\n class function Create: _DirectoryInfo;\r\n class function CreateRemote(const MachineName: string): _DirectoryInfo;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoIOException provides a Create and CreateRemote method to \r\n// create instances of the default interface _IOException exposed by \r\n// the CoClass IOException. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoIOException = class\r\n class function Create: _IOException;\r\n class function CreateRemote(const MachineName: string): _IOException;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoDirectoryNotFoundException provides a Create and CreateRemote method to \r\n// create instances of the default interface _DirectoryNotFoundException exposed by \r\n// the CoClass DirectoryNotFoundException. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoDirectoryNotFoundException = class\r\n class function Create: _DirectoryNotFoundException;\r\n class function CreateRemote(const MachineName: string): _DirectoryNotFoundException;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoEndOfStreamException provides a Create and CreateRemote method to \r\n// create instances of the default interface _EndOfStreamException exposed by \r\n// the CoClass EndOfStreamException. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoEndOfStreamException = class\r\n class function Create: _EndOfStreamException;\r\n class function CreateRemote(const MachineName: string): _EndOfStreamException;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoFile_ provides a Create and CreateRemote method to \r\n// create instances of the default interface _File exposed by \r\n// the CoClass File_. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoFile_ = class\r\n class function Create: _File;\r\n class function CreateRemote(const MachineName: string): _File;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoFileInfo provides a Create and CreateRemote method to \r\n// create instances of the default interface _FileInfo exposed by \r\n// the CoClass FileInfo. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoFileInfo = class\r\n class function Create: _FileInfo;\r\n class function CreateRemote(const MachineName: string): _FileInfo;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoFileLoadException provides a Create and CreateRemote method to \r\n// create instances of the default interface _FileLoadException exposed by \r\n// the CoClass FileLoadException. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoFileLoadException = class\r\n class function Create: _FileLoadException;\r\n class function CreateRemote(const MachineName: string): _FileLoadException;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoFileNotFoundException provides a Create and CreateRemote method to \r\n// create instances of the default interface _FileNotFoundException exposed by \r\n// the CoClass FileNotFoundException. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoFileNotFoundException = class\r\n class function Create: _FileNotFoundException;\r\n class function CreateRemote(const MachineName: string): _FileNotFoundException;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoFileStream provides a Create and CreateRemote method to \r\n// create instances of the default interface _FileStream exposed by \r\n// the CoClass FileStream. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoFileStream = class\r\n class function Create: _FileStream;\r\n class function CreateRemote(const MachineName: string): _FileStream;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoMemoryStream provides a Create and CreateRemote method to \r\n// create instances of the default interface _MemoryStream exposed by \r\n// the CoClass MemoryStream. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoMemoryStream = class\r\n class function Create: _MemoryStream;\r\n class function CreateRemote(const MachineName: string): _MemoryStream;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoPath provides a Create and CreateRemote method to \r\n// create instances of the default interface _Path exposed by \r\n// the CoClass Path. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoPath = class\r\n class function Create: _Path;\r\n class function CreateRemote(const MachineName: string): _Path;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoPathTooLongException provides a Create and CreateRemote method to \r\n// create instances of the default interface _PathTooLongException exposed by \r\n// the CoClass PathTooLongException. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoPathTooLongException = class\r\n class function Create: _PathTooLongException;\r\n class function CreateRemote(const MachineName: string): _PathTooLongException;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoTextReader provides a Create and CreateRemote method to \r\n// create instances of the default interface _TextReader exposed by \r\n// the CoClass TextReader. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoTextReader = class\r\n class function Create: _TextReader;\r\n class function CreateRemote(const MachineName: string): _TextReader;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoStreamReader provides a Create and CreateRemote method to \r\n// create instances of the default interface _StreamReader exposed by \r\n// the CoClass StreamReader. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoStreamReader = class\r\n class function Create: _StreamReader;\r\n class function CreateRemote(const MachineName: string): _StreamReader;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoTextWriter provides a Create and CreateRemote method to \r\n// create instances of the default interface _TextWriter exposed by \r\n// the CoClass TextWriter. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoTextWriter = class\r\n class function Create: _TextWriter;\r\n class function CreateRemote(const MachineName: string): _TextWriter;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoStreamWriter provides a Create and CreateRemote method to \r\n// create instances of the default interface _StreamWriter exposed by \r\n// the CoClass StreamWriter. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoStreamWriter = class\r\n class function Create: _StreamWriter;\r\n class function CreateRemote(const MachineName: string): _StreamWriter;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoStringReader provides a Create and CreateRemote method to \r\n// create instances of the default interface _StringReader exposed by \r\n// the CoClass StringReader. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoStringReader = class\r\n class function Create: _StringReader;\r\n class function CreateRemote(const MachineName: string): _StringReader;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoStringWriter provides a Create and CreateRemote method to \r\n// create instances of the default interface _StringWriter exposed by \r\n// the CoClass StringWriter. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoStringWriter = class\r\n class function Create: _StringWriter;\r\n class function CreateRemote(const MachineName: string): _StringWriter;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoAccessedThroughPropertyAttribute provides a Create and CreateRemote method to \r\n// create instances of the default interface _AccessedThroughPropertyAttribute exposed by \r\n// the CoClass AccessedThroughPropertyAttribute. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoAccessedThroughPropertyAttribute = class\r\n class function Create: _AccessedThroughPropertyAttribute;\r\n class function CreateRemote(const MachineName: string): _AccessedThroughPropertyAttribute;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoCallConvCdecl provides a Create and CreateRemote method to \r\n// create instances of the default interface _CallConvCdecl exposed by \r\n// the CoClass CallConvCdecl. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoCallConvCdecl = class\r\n class function Create: _CallConvCdecl;\r\n class function CreateRemote(const MachineName: string): _CallConvCdecl;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoCallConvStdcall provides a Create and CreateRemote method to \r\n// create instances of the default interface _CallConvStdcall exposed by \r\n// the CoClass CallConvStdcall. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoCallConvStdcall = class\r\n class function Create: _CallConvStdcall;\r\n class function CreateRemote(const MachineName: string): _CallConvStdcall;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoCallConvThiscall provides a Create and CreateRemote method to \r\n// create instances of the default interface _CallConvThiscall exposed by \r\n// the CoClass CallConvThiscall. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoCallConvThiscall = class\r\n class function Create: _CallConvThiscall;\r\n class function CreateRemote(const MachineName: string): _CallConvThiscall;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoCallConvFastcall provides a Create and CreateRemote method to \r\n// create instances of the default interface _CallConvFastcall exposed by \r\n// the CoClass CallConvFastcall. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoCallConvFastcall = class\r\n class function Create: _CallConvFastcall;\r\n class function CreateRemote(const MachineName: string): _CallConvFastcall;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoRuntimeHelpers provides a Create and CreateRemote method to \r\n// create instances of the default interface _RuntimeHelpers exposed by \r\n// the CoClass RuntimeHelpers. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoRuntimeHelpers = class\r\n class function Create: _RuntimeHelpers;\r\n class function CreateRemote(const MachineName: string): _RuntimeHelpers;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoCustomConstantAttribute provides a Create and CreateRemote method to \r\n// create instances of the default interface _CustomConstantAttribute exposed by \r\n// the CoClass CustomConstantAttribute. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoCustomConstantAttribute = class\r\n class function Create: _CustomConstantAttribute;\r\n class function CreateRemote(const MachineName: string): _CustomConstantAttribute;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoDateTimeConstantAttribute provides a Create and CreateRemote method to \r\n// create instances of the default interface _DateTimeConstantAttribute exposed by \r\n// the CoClass DateTimeConstantAttribute. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoDateTimeConstantAttribute = class\r\n class function Create: _DateTimeConstantAttribute;\r\n class function CreateRemote(const MachineName: string): _DateTimeConstantAttribute;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoDiscardableAttribute provides a Create and CreateRemote method to \r\n// create instances of the default interface _DiscardableAttribute exposed by \r\n// the CoClass DiscardableAttribute. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoDiscardableAttribute = class\r\n class function Create: _DiscardableAttribute;\r\n class function CreateRemote(const MachineName: string): _DiscardableAttribute;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoDecimalConstantAttribute provides a Create and CreateRemote method to \r\n// create instances of the default interface _DecimalConstantAttribute exposed by \r\n// the CoClass DecimalConstantAttribute. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoDecimalConstantAttribute = class\r\n class function Create: _DecimalConstantAttribute;\r\n class function CreateRemote(const MachineName: string): _DecimalConstantAttribute;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoCompilationRelaxationsAttribute provides a Create and CreateRemote method to \r\n// create instances of the default interface _CompilationRelaxationsAttribute exposed by \r\n// the CoClass CompilationRelaxationsAttribute. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoCompilationRelaxationsAttribute = class\r\n class function Create: _CompilationRelaxationsAttribute;\r\n class function CreateRemote(const MachineName: string): _CompilationRelaxationsAttribute;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoCompilerGlobalScopeAttribute provides a Create and CreateRemote method to \r\n// create instances of the default interface _CompilerGlobalScopeAttribute exposed by \r\n// the CoClass CompilerGlobalScopeAttribute. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoCompilerGlobalScopeAttribute = class\r\n class function Create: _CompilerGlobalScopeAttribute;\r\n class function CreateRemote(const MachineName: string): _CompilerGlobalScopeAttribute;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoIDispatchConstantAttribute provides a Create and CreateRemote method to \r\n// create instances of the default interface _IDispatchConstantAttribute exposed by \r\n// the CoClass IDispatchConstantAttribute. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoIDispatchConstantAttribute = class\r\n class function Create: _IDispatchConstantAttribute;\r\n class function CreateRemote(const MachineName: string): _IDispatchConstantAttribute;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoIndexerNameAttribute provides a Create and CreateRemote method to \r\n// create instances of the default interface _IndexerNameAttribute exposed by \r\n// the CoClass IndexerNameAttribute. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoIndexerNameAttribute = class\r\n class function Create: _IndexerNameAttribute;\r\n class function CreateRemote(const MachineName: string): _IndexerNameAttribute;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoIsVolatile provides a Create and CreateRemote method to \r\n// create instances of the default interface _IsVolatile exposed by \r\n// the CoClass IsVolatile. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoIsVolatile = class\r\n class function Create: _IsVolatile;\r\n class function CreateRemote(const MachineName: string): _IsVolatile;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoIUnknownConstantAttribute provides a Create and CreateRemote method to \r\n// create instances of the default interface _IUnknownConstantAttribute exposed by \r\n// the CoClass IUnknownConstantAttribute. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoIUnknownConstantAttribute = class\r\n class function Create: _IUnknownConstantAttribute;\r\n class function CreateRemote(const MachineName: string): _IUnknownConstantAttribute;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoMethodImplAttribute provides a Create and CreateRemote method to \r\n// create instances of the default interface _MethodImplAttribute exposed by \r\n// the CoClass MethodImplAttribute. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoMethodImplAttribute = class\r\n class function Create: _MethodImplAttribute;\r\n class function CreateRemote(const MachineName: string): _MethodImplAttribute;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoRequiredAttributeAttribute provides a Create and CreateRemote method to \r\n// create instances of the default interface _RequiredAttributeAttribute exposed by \r\n// the CoClass RequiredAttributeAttribute. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoRequiredAttributeAttribute = class\r\n class function Create: _RequiredAttributeAttribute;\r\n class function CreateRemote(const MachineName: string): _RequiredAttributeAttribute;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoPermissionSet provides a Create and CreateRemote method to \r\n// create instances of the default interface _PermissionSet exposed by \r\n// the CoClass PermissionSet. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoPermissionSet = class\r\n class function Create: _PermissionSet;\r\n class function CreateRemote(const MachineName: string): _PermissionSet;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoNamedPermissionSet provides a Create and CreateRemote method to \r\n// create instances of the default interface _NamedPermissionSet exposed by \r\n// the CoClass NamedPermissionSet. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoNamedPermissionSet = class\r\n class function Create: _NamedPermissionSet;\r\n class function CreateRemote(const MachineName: string): _NamedPermissionSet;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoSecurityElement provides a Create and CreateRemote method to \r\n// create instances of the default interface _SecurityElement exposed by \r\n// the CoClass SecurityElement. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoSecurityElement = class\r\n class function Create: _SecurityElement;\r\n class function CreateRemote(const MachineName: string): _SecurityElement;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoXmlSyntaxException provides a Create and CreateRemote method to \r\n// create instances of the default interface _XmlSyntaxException exposed by \r\n// the CoClass XmlSyntaxException. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoXmlSyntaxException = class\r\n class function Create: _XmlSyntaxException;\r\n class function CreateRemote(const MachineName: string): _XmlSyntaxException;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoCodeAccessPermission provides a Create and CreateRemote method to \r\n// create instances of the default interface _CodeAccessPermission exposed by \r\n// the CoClass CodeAccessPermission. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoCodeAccessPermission = class\r\n class function Create: _CodeAccessPermission;\r\n class function CreateRemote(const MachineName: string): _CodeAccessPermission;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoEnvironmentPermission provides a Create and CreateRemote method to \r\n// create instances of the default interface _EnvironmentPermission exposed by \r\n// the CoClass EnvironmentPermission. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoEnvironmentPermission = class\r\n class function Create: _EnvironmentPermission;\r\n class function CreateRemote(const MachineName: string): _EnvironmentPermission;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoFileDialogPermission provides a Create and CreateRemote method to \r\n// create instances of the default interface _FileDialogPermission exposed by \r\n// the CoClass FileDialogPermission. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoFileDialogPermission = class\r\n class function Create: _FileDialogPermission;\r\n class function CreateRemote(const MachineName: string): _FileDialogPermission;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoFileIOPermission provides a Create and CreateRemote method to \r\n// create instances of the default interface _FileIOPermission exposed by \r\n// the CoClass FileIOPermission. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoFileIOPermission = class\r\n class function Create: _FileIOPermission;\r\n class function CreateRemote(const MachineName: string): _FileIOPermission;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoIsolatedStoragePermission provides a Create and CreateRemote method to \r\n// create instances of the default interface _IsolatedStoragePermission exposed by \r\n// the CoClass IsolatedStoragePermission. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoIsolatedStoragePermission = class\r\n class function Create: _IsolatedStoragePermission;\r\n class function CreateRemote(const MachineName: string): _IsolatedStoragePermission;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoIsolatedStorageFilePermission provides a Create and CreateRemote method to \r\n// create instances of the default interface _IsolatedStorageFilePermission exposed by \r\n// the CoClass IsolatedStorageFilePermission. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoIsolatedStorageFilePermission = class\r\n class function Create: _IsolatedStorageFilePermission;\r\n class function CreateRemote(const MachineName: string): _IsolatedStorageFilePermission;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoSecurityAttribute provides a Create and CreateRemote method to \r\n// create instances of the default interface _SecurityAttribute exposed by \r\n// the CoClass SecurityAttribute. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoSecurityAttribute = class\r\n class function Create: _SecurityAttribute;\r\n class function CreateRemote(const MachineName: string): _SecurityAttribute;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoCodeAccessSecurityAttribute provides a Create and CreateRemote method to \r\n// create instances of the default interface _CodeAccessSecurityAttribute exposed by \r\n// the CoClass CodeAccessSecurityAttribute. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoCodeAccessSecurityAttribute = class\r\n class function Create: _CodeAccessSecurityAttribute;\r\n class function CreateRemote(const MachineName: string): _CodeAccessSecurityAttribute;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoEnvironmentPermissionAttribute provides a Create and CreateRemote method to \r\n// create instances of the default interface _EnvironmentPermissionAttribute exposed by \r\n// the CoClass EnvironmentPermissionAttribute. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoEnvironmentPermissionAttribute = class\r\n class function Create: _EnvironmentPermissionAttribute;\r\n class function CreateRemote(const MachineName: string): _EnvironmentPermissionAttribute;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoFileDialogPermissionAttribute provides a Create and CreateRemote method to \r\n// create instances of the default interface _FileDialogPermissionAttribute exposed by \r\n// the CoClass FileDialogPermissionAttribute. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoFileDialogPermissionAttribute = class\r\n class function Create: _FileDialogPermissionAttribute;\r\n class function CreateRemote(const MachineName: string): _FileDialogPermissionAttribute;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoFileIOPermissionAttribute provides a Create and CreateRemote method to \r\n// create instances of the default interface _FileIOPermissionAttribute exposed by \r\n// the CoClass FileIOPermissionAttribute. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoFileIOPermissionAttribute = class\r\n class function Create: _FileIOPermissionAttribute;\r\n class function CreateRemote(const MachineName: string): _FileIOPermissionAttribute;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoPrincipalPermissionAttribute provides a Create and CreateRemote method to \r\n// create instances of the default interface _PrincipalPermissionAttribute exposed by \r\n// the CoClass PrincipalPermissionAttribute. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoPrincipalPermissionAttribute = class\r\n class function Create: _PrincipalPermissionAttribute;\r\n class function CreateRemote(const MachineName: string): _PrincipalPermissionAttribute;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoReflectionPermissionAttribute provides a Create and CreateRemote method to \r\n// create instances of the default interface _ReflectionPermissionAttribute exposed by \r\n// the CoClass ReflectionPermissionAttribute. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoReflectionPermissionAttribute = class\r\n class function Create: _ReflectionPermissionAttribute;\r\n class function CreateRemote(const MachineName: string): _ReflectionPermissionAttribute;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoRegistryPermissionAttribute provides a Create and CreateRemote method to \r\n// create instances of the default interface _RegistryPermissionAttribute exposed by \r\n// the CoClass RegistryPermissionAttribute. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoRegistryPermissionAttribute = class\r\n class function Create: _RegistryPermissionAttribute;\r\n class function CreateRemote(const MachineName: string): _RegistryPermissionAttribute;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoSecurityPermissionAttribute provides a Create and CreateRemote method to \r\n// create instances of the default interface _SecurityPermissionAttribute exposed by \r\n// the CoClass SecurityPermissionAttribute. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoSecurityPermissionAttribute = class\r\n class function Create: _SecurityPermissionAttribute;\r\n class function CreateRemote(const MachineName: string): _SecurityPermissionAttribute;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoUIPermissionAttribute provides a Create and CreateRemote method to \r\n// create instances of the default interface _UIPermissionAttribute exposed by \r\n// the CoClass UIPermissionAttribute. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoUIPermissionAttribute = class\r\n class function Create: _UIPermissionAttribute;\r\n class function CreateRemote(const MachineName: string): _UIPermissionAttribute;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoZoneIdentityPermissionAttribute provides a Create and CreateRemote method to \r\n// create instances of the default interface _ZoneIdentityPermissionAttribute exposed by \r\n// the CoClass ZoneIdentityPermissionAttribute. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoZoneIdentityPermissionAttribute = class\r\n class function Create: _ZoneIdentityPermissionAttribute;\r\n class function CreateRemote(const MachineName: string): _ZoneIdentityPermissionAttribute;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoStrongNameIdentityPermissionAttribute provides a Create and CreateRemote method to \r\n// create instances of the default interface _StrongNameIdentityPermissionAttribute exposed by \r\n// the CoClass StrongNameIdentityPermissionAttribute. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoStrongNameIdentityPermissionAttribute = class\r\n class function Create: _StrongNameIdentityPermissionAttribute;\r\n class function CreateRemote(const MachineName: string): _StrongNameIdentityPermissionAttribute;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoSiteIdentityPermissionAttribute provides a Create and CreateRemote method to \r\n// create instances of the default interface _SiteIdentityPermissionAttribute exposed by \r\n// the CoClass SiteIdentityPermissionAttribute. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoSiteIdentityPermissionAttribute = class\r\n class function Create: _SiteIdentityPermissionAttribute;\r\n class function CreateRemote(const MachineName: string): _SiteIdentityPermissionAttribute;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoUrlIdentityPermissionAttribute provides a Create and CreateRemote method to \r\n// create instances of the default interface _UrlIdentityPermissionAttribute exposed by \r\n// the CoClass UrlIdentityPermissionAttribute. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoUrlIdentityPermissionAttribute = class\r\n class function Create: _UrlIdentityPermissionAttribute;\r\n class function CreateRemote(const MachineName: string): _UrlIdentityPermissionAttribute;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoPublisherIdentityPermissionAttribute provides a Create and CreateRemote method to \r\n// create instances of the default interface _PublisherIdentityPermissionAttribute exposed by \r\n// the CoClass PublisherIdentityPermissionAttribute. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoPublisherIdentityPermissionAttribute = class\r\n class function Create: _PublisherIdentityPermissionAttribute;\r\n class function CreateRemote(const MachineName: string): _PublisherIdentityPermissionAttribute;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoIsolatedStoragePermissionAttribute provides a Create and CreateRemote method to \r\n// create instances of the default interface _IsolatedStoragePermissionAttribute exposed by \r\n// the CoClass IsolatedStoragePermissionAttribute. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoIsolatedStoragePermissionAttribute = class\r\n class function Create: _IsolatedStoragePermissionAttribute;\r\n class function CreateRemote(const MachineName: string): _IsolatedStoragePermissionAttribute;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoIsolatedStorageFilePermissionAttribute provides a Create and CreateRemote method to \r\n// create instances of the default interface _IsolatedStorageFilePermissionAttribute exposed by \r\n// the CoClass IsolatedStorageFilePermissionAttribute. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoIsolatedStorageFilePermissionAttribute = class\r\n class function Create: _IsolatedStorageFilePermissionAttribute;\r\n class function CreateRemote(const MachineName: string): _IsolatedStorageFilePermissionAttribute;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoPermissionSetAttribute provides a Create and CreateRemote method to \r\n// create instances of the default interface _PermissionSetAttribute exposed by \r\n// the CoClass PermissionSetAttribute. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoPermissionSetAttribute = class\r\n class function Create: _PermissionSetAttribute;\r\n class function CreateRemote(const MachineName: string): _PermissionSetAttribute;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoPublisherIdentityPermission provides a Create and CreateRemote method to \r\n// create instances of the default interface _PublisherIdentityPermission exposed by \r\n// the CoClass PublisherIdentityPermission. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoPublisherIdentityPermission = class\r\n class function Create: _PublisherIdentityPermission;\r\n class function CreateRemote(const MachineName: string): _PublisherIdentityPermission;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoReflectionPermission provides a Create and CreateRemote method to \r\n// create instances of the default interface _ReflectionPermission exposed by \r\n// the CoClass ReflectionPermission. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoReflectionPermission = class\r\n class function Create: _ReflectionPermission;\r\n class function CreateRemote(const MachineName: string): _ReflectionPermission;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoRegistryPermission provides a Create and CreateRemote method to \r\n// create instances of the default interface _RegistryPermission exposed by \r\n// the CoClass RegistryPermission. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoRegistryPermission = class\r\n class function Create: _RegistryPermission;\r\n class function CreateRemote(const MachineName: string): _RegistryPermission;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoPrincipalPermission provides a Create and CreateRemote method to \r\n// create instances of the default interface _PrincipalPermission exposed by \r\n// the CoClass PrincipalPermission. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoPrincipalPermission = class\r\n class function Create: _PrincipalPermission;\r\n class function CreateRemote(const MachineName: string): _PrincipalPermission;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoSecurityPermission provides a Create and CreateRemote method to \r\n// create instances of the default interface _SecurityPermission exposed by \r\n// the CoClass SecurityPermission. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoSecurityPermission = class\r\n class function Create: _SecurityPermission;\r\n class function CreateRemote(const MachineName: string): _SecurityPermission;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoSiteIdentityPermission provides a Create and CreateRemote method to \r\n// create instances of the default interface _SiteIdentityPermission exposed by \r\n// the CoClass SiteIdentityPermission. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoSiteIdentityPermission = class\r\n class function Create: _SiteIdentityPermission;\r\n class function CreateRemote(const MachineName: string): _SiteIdentityPermission;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoStrongNameIdentityPermission provides a Create and CreateRemote method to \r\n// create instances of the default interface _StrongNameIdentityPermission exposed by \r\n// the CoClass StrongNameIdentityPermission. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoStrongNameIdentityPermission = class\r\n class function Create: _StrongNameIdentityPermission;\r\n class function CreateRemote(const MachineName: string): _StrongNameIdentityPermission;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoStrongNamePublicKeyBlob provides a Create and CreateRemote method to \r\n// create instances of the default interface _StrongNamePublicKeyBlob exposed by \r\n// the CoClass StrongNamePublicKeyBlob. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoStrongNamePublicKeyBlob = class\r\n class function Create: _StrongNamePublicKeyBlob;\r\n class function CreateRemote(const MachineName: string): _StrongNamePublicKeyBlob;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoUIPermission provides a Create and CreateRemote method to \r\n// create instances of the default interface _UIPermission exposed by \r\n// the CoClass UIPermission. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoUIPermission = class\r\n class function Create: _UIPermission;\r\n class function CreateRemote(const MachineName: string): _UIPermission;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoUrlIdentityPermission provides a Create and CreateRemote method to \r\n// create instances of the default interface _UrlIdentityPermission exposed by \r\n// the CoClass UrlIdentityPermission. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoUrlIdentityPermission = class\r\n class function Create: _UrlIdentityPermission;\r\n class function CreateRemote(const MachineName: string): _UrlIdentityPermission;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoZoneIdentityPermission provides a Create and CreateRemote method to \r\n// create instances of the default interface _ZoneIdentityPermission exposed by \r\n// the CoClass ZoneIdentityPermission. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoZoneIdentityPermission = class\r\n class function Create: _ZoneIdentityPermission;\r\n class function CreateRemote(const MachineName: string): _ZoneIdentityPermission;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoSuppressUnmanagedCodeSecurityAttribute provides a Create and CreateRemote method to \r\n// create instances of the default interface _SuppressUnmanagedCodeSecurityAttribute exposed by \r\n// the CoClass SuppressUnmanagedCodeSecurityAttribute. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoSuppressUnmanagedCodeSecurityAttribute = class\r\n class function Create: _SuppressUnmanagedCodeSecurityAttribute;\r\n class function CreateRemote(const MachineName: string): _SuppressUnmanagedCodeSecurityAttribute;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoUnverifiableCodeAttribute provides a Create and CreateRemote method to \r\n// create instances of the default interface _UnverifiableCodeAttribute exposed by \r\n// the CoClass UnverifiableCodeAttribute. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoUnverifiableCodeAttribute = class\r\n class function Create: _UnverifiableCodeAttribute;\r\n class function CreateRemote(const MachineName: string): _UnverifiableCodeAttribute;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoAllowPartiallyTrustedCallersAttribute provides a Create and CreateRemote method to \r\n// create instances of the default interface _AllowPartiallyTrustedCallersAttribute exposed by \r\n// the CoClass AllowPartiallyTrustedCallersAttribute. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoAllowPartiallyTrustedCallersAttribute = class\r\n class function Create: _AllowPartiallyTrustedCallersAttribute;\r\n class function CreateRemote(const MachineName: string): _AllowPartiallyTrustedCallersAttribute;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoSecurityException provides a Create and CreateRemote method to \r\n// create instances of the default interface _SecurityException exposed by \r\n// the CoClass SecurityException. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoSecurityException = class\r\n class function Create: _SecurityException;\r\n class function CreateRemote(const MachineName: string): _SecurityException;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoSecurityManager provides a Create and CreateRemote method to \r\n// create instances of the default interface _SecurityManager exposed by \r\n// the CoClass SecurityManager. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoSecurityManager = class\r\n class function Create: _SecurityManager;\r\n class function CreateRemote(const MachineName: string): _SecurityManager;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoVerificationException provides a Create and CreateRemote method to \r\n// create instances of the default interface _VerificationException exposed by \r\n// the CoClass VerificationException. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoVerificationException = class\r\n class function Create: _VerificationException;\r\n class function CreateRemote(const MachineName: string): _VerificationException;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoContextAttribute provides a Create and CreateRemote method to \r\n// create instances of the default interface _ContextAttribute exposed by \r\n// the CoClass ContextAttribute. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoContextAttribute = class\r\n class function Create: _ContextAttribute;\r\n class function CreateRemote(const MachineName: string): _ContextAttribute;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoAsyncResult provides a Create and CreateRemote method to \r\n// create instances of the default interface _AsyncResult exposed by \r\n// the CoClass AsyncResult. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoAsyncResult = class\r\n class function Create: _AsyncResult;\r\n class function CreateRemote(const MachineName: string): _AsyncResult;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoCallContext provides a Create and CreateRemote method to \r\n// create instances of the default interface _CallContext exposed by \r\n// the CoClass CallContext. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoCallContext = class\r\n class function Create: _CallContext;\r\n class function CreateRemote(const MachineName: string): _CallContext;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoLogicalCallContext provides a Create and CreateRemote method to \r\n// create instances of the default interface _LogicalCallContext exposed by \r\n// the CoClass LogicalCallContext. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoLogicalCallContext = class\r\n class function Create: _LogicalCallContext;\r\n class function CreateRemote(const MachineName: string): _LogicalCallContext;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoChannelServices provides a Create and CreateRemote method to \r\n// create instances of the default interface _ChannelServices exposed by \r\n// the CoClass ChannelServices. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoChannelServices = class\r\n class function Create: _ChannelServices;\r\n class function CreateRemote(const MachineName: string): _ChannelServices;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoClientChannelSinkStack provides a Create and CreateRemote method to \r\n// create instances of the default interface _ClientChannelSinkStack exposed by \r\n// the CoClass ClientChannelSinkStack. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoClientChannelSinkStack = class\r\n class function Create: _ClientChannelSinkStack;\r\n class function CreateRemote(const MachineName: string): _ClientChannelSinkStack;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoServerChannelSinkStack provides a Create and CreateRemote method to \r\n// create instances of the default interface _ServerChannelSinkStack exposed by \r\n// the CoClass ServerChannelSinkStack. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoServerChannelSinkStack = class\r\n class function Create: _ServerChannelSinkStack;\r\n class function CreateRemote(const MachineName: string): _ServerChannelSinkStack;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoInternalMessageWrapper provides a Create and CreateRemote method to \r\n// create instances of the default interface _InternalMessageWrapper exposed by \r\n// the CoClass InternalMessageWrapper. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoInternalMessageWrapper = class\r\n class function Create: _InternalMessageWrapper;\r\n class function CreateRemote(const MachineName: string): _InternalMessageWrapper;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoMethodCallMessageWrapper provides a Create and CreateRemote method to \r\n// create instances of the default interface _MethodCallMessageWrapper exposed by \r\n// the CoClass MethodCallMessageWrapper. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoMethodCallMessageWrapper = class\r\n class function Create: _MethodCallMessageWrapper;\r\n class function CreateRemote(const MachineName: string): _MethodCallMessageWrapper;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoClientSponsor provides a Create and CreateRemote method to \r\n// create instances of the default interface _ClientSponsor exposed by \r\n// the CoClass ClientSponsor. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoClientSponsor = class\r\n class function Create: _ClientSponsor;\r\n class function CreateRemote(const MachineName: string): _ClientSponsor;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoCrossContextDelegate provides a Create and CreateRemote method to \r\n// create instances of the default interface _CrossContextDelegate exposed by \r\n// the CoClass CrossContextDelegate. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoCrossContextDelegate = class\r\n class function Create: _CrossContextDelegate;\r\n class function CreateRemote(const MachineName: string): _CrossContextDelegate;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoContext provides a Create and CreateRemote method to \r\n// create instances of the default interface _Context exposed by \r\n// the CoClass Context. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoContext = class\r\n class function Create: _Context;\r\n class function CreateRemote(const MachineName: string): _Context;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoContextProperty provides a Create and CreateRemote method to \r\n// create instances of the default interface _ContextProperty exposed by \r\n// the CoClass ContextProperty. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoContextProperty = class\r\n class function Create: _ContextProperty;\r\n class function CreateRemote(const MachineName: string): _ContextProperty;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoEnterpriseServicesHelper provides a Create and CreateRemote method to \r\n// create instances of the default interface _EnterpriseServicesHelper exposed by \r\n// the CoClass EnterpriseServicesHelper. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoEnterpriseServicesHelper = class\r\n class function Create: _EnterpriseServicesHelper;\r\n class function CreateRemote(const MachineName: string): _EnterpriseServicesHelper;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoHeader provides a Create and CreateRemote method to \r\n// create instances of the default interface _Header exposed by \r\n// the CoClass Header. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoHeader = class\r\n class function Create: _Header;\r\n class function CreateRemote(const MachineName: string): _Header;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoHeaderHandler provides a Create and CreateRemote method to \r\n// create instances of the default interface _HeaderHandler exposed by \r\n// the CoClass HeaderHandler. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoHeaderHandler = class\r\n class function Create: _HeaderHandler;\r\n class function CreateRemote(const MachineName: string): _HeaderHandler;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoChannelDataStore provides a Create and CreateRemote method to \r\n// create instances of the default interface _ChannelDataStore exposed by \r\n// the CoClass ChannelDataStore. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoChannelDataStore = class\r\n class function Create: _ChannelDataStore;\r\n class function CreateRemote(const MachineName: string): _ChannelDataStore;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoTransportHeaders provides a Create and CreateRemote method to \r\n// create instances of the default interface _TransportHeaders exposed by \r\n// the CoClass TransportHeaders. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoTransportHeaders = class\r\n class function Create: _TransportHeaders;\r\n class function CreateRemote(const MachineName: string): _TransportHeaders;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoSinkProviderData provides a Create and CreateRemote method to \r\n// create instances of the default interface _SinkProviderData exposed by \r\n// the CoClass SinkProviderData. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoSinkProviderData = class\r\n class function Create: _SinkProviderData;\r\n class function CreateRemote(const MachineName: string): _SinkProviderData;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoBaseChannelObjectWithProperties provides a Create and CreateRemote method to \r\n// create instances of the default interface _BaseChannelObjectWithProperties exposed by \r\n// the CoClass BaseChannelObjectWithProperties. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoBaseChannelObjectWithProperties = class\r\n class function Create: _BaseChannelObjectWithProperties;\r\n class function CreateRemote(const MachineName: string): _BaseChannelObjectWithProperties;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoBaseChannelSinkWithProperties provides a Create and CreateRemote method to \r\n// create instances of the default interface _BaseChannelSinkWithProperties exposed by \r\n// the CoClass BaseChannelSinkWithProperties. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoBaseChannelSinkWithProperties = class\r\n class function Create: _BaseChannelSinkWithProperties;\r\n class function CreateRemote(const MachineName: string): _BaseChannelSinkWithProperties;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoBaseChannelWithProperties provides a Create and CreateRemote method to \r\n// create instances of the default interface _BaseChannelWithProperties exposed by \r\n// the CoClass BaseChannelWithProperties. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoBaseChannelWithProperties = class\r\n class function Create: _BaseChannelWithProperties;\r\n class function CreateRemote(const MachineName: string): _BaseChannelWithProperties;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoLifetimeServices provides a Create and CreateRemote method to \r\n// create instances of the default interface _LifetimeServices exposed by \r\n// the CoClass LifetimeServices. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoLifetimeServices = class\r\n class function Create: _LifetimeServices;\r\n class function CreateRemote(const MachineName: string): _LifetimeServices;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoReturnMessage provides a Create and CreateRemote method to \r\n// create instances of the default interface _ReturnMessage exposed by \r\n// the CoClass ReturnMessage. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoReturnMessage = class\r\n class function Create: _ReturnMessage;\r\n class function CreateRemote(const MachineName: string): _ReturnMessage;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoMethodCall provides a Create and CreateRemote method to \r\n// create instances of the default interface _MethodCall exposed by \r\n// the CoClass MethodCall. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoMethodCall = class\r\n class function Create: _MethodCall;\r\n class function CreateRemote(const MachineName: string): _MethodCall;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoConstructionCall provides a Create and CreateRemote method to \r\n// create instances of the default interface _ConstructionCall exposed by \r\n// the CoClass ConstructionCall. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoConstructionCall = class\r\n class function Create: _ConstructionCall;\r\n class function CreateRemote(const MachineName: string): _ConstructionCall;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoMethodResponse provides a Create and CreateRemote method to \r\n// create instances of the default interface _MethodResponse exposed by \r\n// the CoClass MethodResponse. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoMethodResponse = class\r\n class function Create: _MethodResponse;\r\n class function CreateRemote(const MachineName: string): _MethodResponse;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoConstructionResponse provides a Create and CreateRemote method to \r\n// create instances of the default interface _ConstructionResponse exposed by \r\n// the CoClass ConstructionResponse. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoConstructionResponse = class\r\n class function Create: _ConstructionResponse;\r\n class function CreateRemote(const MachineName: string): _ConstructionResponse;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoMethodReturnMessageWrapper provides a Create and CreateRemote method to \r\n// create instances of the default interface _MethodReturnMessageWrapper exposed by \r\n// the CoClass MethodReturnMessageWrapper. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoMethodReturnMessageWrapper = class\r\n class function Create: _MethodReturnMessageWrapper;\r\n class function CreateRemote(const MachineName: string): _MethodReturnMessageWrapper;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoObjectHandle provides a Create and CreateRemote method to \r\n// create instances of the default interface _ObjectHandle exposed by \r\n// the CoClass ObjectHandle. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoObjectHandle = class\r\n class function Create: _ObjectHandle;\r\n class function CreateRemote(const MachineName: string): _ObjectHandle;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoObjRef provides a Create and CreateRemote method to \r\n// create instances of the default interface _ObjRef exposed by \r\n// the CoClass ObjRef. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoObjRef = class\r\n class function Create: _ObjRef;\r\n class function CreateRemote(const MachineName: string): _ObjRef;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoOneWayAttribute provides a Create and CreateRemote method to \r\n// create instances of the default interface _OneWayAttribute exposed by \r\n// the CoClass OneWayAttribute. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoOneWayAttribute = class\r\n class function Create: _OneWayAttribute;\r\n class function CreateRemote(const MachineName: string): _OneWayAttribute;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoProxyAttribute provides a Create and CreateRemote method to \r\n// create instances of the default interface _ProxyAttribute exposed by \r\n// the CoClass ProxyAttribute. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoProxyAttribute = class\r\n class function Create: _ProxyAttribute;\r\n class function CreateRemote(const MachineName: string): _ProxyAttribute;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoRealProxy provides a Create and CreateRemote method to \r\n// create instances of the default interface _RealProxy exposed by \r\n// the CoClass RealProxy. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoRealProxy = class\r\n class function Create: _RealProxy;\r\n class function CreateRemote(const MachineName: string): _RealProxy;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoSoapAttribute provides a Create and CreateRemote method to \r\n// create instances of the default interface _SoapAttribute exposed by \r\n// the CoClass SoapAttribute. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoSoapAttribute = class\r\n class function Create: _SoapAttribute;\r\n class function CreateRemote(const MachineName: string): _SoapAttribute;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoSoapTypeAttribute provides a Create and CreateRemote method to \r\n// create instances of the default interface _SoapTypeAttribute exposed by \r\n// the CoClass SoapTypeAttribute. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoSoapTypeAttribute = class\r\n class function Create: _SoapTypeAttribute;\r\n class function CreateRemote(const MachineName: string): _SoapTypeAttribute;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoSoapMethodAttribute provides a Create and CreateRemote method to \r\n// create instances of the default interface _SoapMethodAttribute exposed by \r\n// the CoClass SoapMethodAttribute. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoSoapMethodAttribute = class\r\n class function Create: _SoapMethodAttribute;\r\n class function CreateRemote(const MachineName: string): _SoapMethodAttribute;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoSoapFieldAttribute provides a Create and CreateRemote method to \r\n// create instances of the default interface _SoapFieldAttribute exposed by \r\n// the CoClass SoapFieldAttribute. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoSoapFieldAttribute = class\r\n class function Create: _SoapFieldAttribute;\r\n class function CreateRemote(const MachineName: string): _SoapFieldAttribute;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoSoapParameterAttribute provides a Create and CreateRemote method to \r\n// create instances of the default interface _SoapParameterAttribute exposed by \r\n// the CoClass SoapParameterAttribute. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoSoapParameterAttribute = class\r\n class function Create: _SoapParameterAttribute;\r\n class function CreateRemote(const MachineName: string): _SoapParameterAttribute;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoRemotingConfiguration provides a Create and CreateRemote method to \r\n// create instances of the default interface _RemotingConfiguration exposed by \r\n// the CoClass RemotingConfiguration. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoRemotingConfiguration = class\r\n class function Create: _RemotingConfiguration;\r\n class function CreateRemote(const MachineName: string): _RemotingConfiguration;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoSystem_Runtime_Remoting_TypeEntry provides a Create and CreateRemote method to \r\n// create instances of the default interface _System_Runtime_Remoting_TypeEntry exposed by \r\n// the CoClass System_Runtime_Remoting_TypeEntry. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoSystem_Runtime_Remoting_TypeEntry = class\r\n class function Create: _System_Runtime_Remoting_TypeEntry;\r\n class function CreateRemote(const MachineName: string): _System_Runtime_Remoting_TypeEntry;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoActivatedClientTypeEntry provides a Create and CreateRemote method to \r\n// create instances of the default interface _ActivatedClientTypeEntry exposed by \r\n// the CoClass ActivatedClientTypeEntry. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoActivatedClientTypeEntry = class\r\n class function Create: _ActivatedClientTypeEntry;\r\n class function CreateRemote(const MachineName: string): _ActivatedClientTypeEntry;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoActivatedServiceTypeEntry provides a Create and CreateRemote method to \r\n// create instances of the default interface _ActivatedServiceTypeEntry exposed by \r\n// the CoClass ActivatedServiceTypeEntry. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoActivatedServiceTypeEntry = class\r\n class function Create: _ActivatedServiceTypeEntry;\r\n class function CreateRemote(const MachineName: string): _ActivatedServiceTypeEntry;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoWellKnownClientTypeEntry provides a Create and CreateRemote method to \r\n// create instances of the default interface _WellKnownClientTypeEntry exposed by \r\n// the CoClass WellKnownClientTypeEntry. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoWellKnownClientTypeEntry = class\r\n class function Create: _WellKnownClientTypeEntry;\r\n class function CreateRemote(const MachineName: string): _WellKnownClientTypeEntry;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoWellKnownServiceTypeEntry provides a Create and CreateRemote method to \r\n// create instances of the default interface _WellKnownServiceTypeEntry exposed by \r\n// the CoClass WellKnownServiceTypeEntry. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoWellKnownServiceTypeEntry = class\r\n class function Create: _WellKnownServiceTypeEntry;\r\n class function CreateRemote(const MachineName: string): _WellKnownServiceTypeEntry;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoRemotingException provides a Create and CreateRemote method to \r\n// create instances of the default interface _RemotingException exposed by \r\n// the CoClass RemotingException. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoRemotingException = class\r\n class function Create: _RemotingException;\r\n class function CreateRemote(const MachineName: string): _RemotingException;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoServerException provides a Create and CreateRemote method to \r\n// create instances of the default interface _ServerException exposed by \r\n// the CoClass ServerException. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoServerException = class\r\n class function Create: _ServerException;\r\n class function CreateRemote(const MachineName: string): _ServerException;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoRemotingTimeoutException provides a Create and CreateRemote method to \r\n// create instances of the default interface _RemotingTimeoutException exposed by \r\n// the CoClass RemotingTimeoutException. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoRemotingTimeoutException = class\r\n class function Create: _RemotingTimeoutException;\r\n class function CreateRemote(const MachineName: string): _RemotingTimeoutException;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoRemotingServices provides a Create and CreateRemote method to \r\n// create instances of the default interface _RemotingServices exposed by \r\n// the CoClass RemotingServices. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoRemotingServices = class\r\n class function Create: _RemotingServices;\r\n class function CreateRemote(const MachineName: string): _RemotingServices;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoInternalRemotingServices provides a Create and CreateRemote method to \r\n// create instances of the default interface _InternalRemotingServices exposed by \r\n// the CoClass InternalRemotingServices. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoInternalRemotingServices = class\r\n class function Create: _InternalRemotingServices;\r\n class function CreateRemote(const MachineName: string): _InternalRemotingServices;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoMessageSurrogateFilter provides a Create and CreateRemote method to \r\n// create instances of the default interface _MessageSurrogateFilter exposed by \r\n// the CoClass MessageSurrogateFilter. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoMessageSurrogateFilter = class\r\n class function Create: _MessageSurrogateFilter;\r\n class function CreateRemote(const MachineName: string): _MessageSurrogateFilter;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoRemotingSurrogateSelector provides a Create and CreateRemote method to \r\n// create instances of the default interface _RemotingSurrogateSelector exposed by \r\n// the CoClass RemotingSurrogateSelector. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoRemotingSurrogateSelector = class\r\n class function Create: _RemotingSurrogateSelector;\r\n class function CreateRemote(const MachineName: string): _RemotingSurrogateSelector;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoSoapServices provides a Create and CreateRemote method to \r\n// create instances of the default interface _SoapServices exposed by \r\n// the CoClass SoapServices. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoSoapServices = class\r\n class function Create: _SoapServices;\r\n class function CreateRemote(const MachineName: string): _SoapServices;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoSoapDateTime provides a Create and CreateRemote method to \r\n// create instances of the default interface _SoapDateTime exposed by \r\n// the CoClass SoapDateTime. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoSoapDateTime = class\r\n class function Create: _SoapDateTime;\r\n class function CreateRemote(const MachineName: string): _SoapDateTime;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoSoapDuration provides a Create and CreateRemote method to \r\n// create instances of the default interface _SoapDuration exposed by \r\n// the CoClass SoapDuration. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoSoapDuration = class\r\n class function Create: _SoapDuration;\r\n class function CreateRemote(const MachineName: string): _SoapDuration;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoSoapTime provides a Create and CreateRemote method to \r\n// create instances of the default interface _SoapTime exposed by \r\n// the CoClass SoapTime. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoSoapTime = class\r\n class function Create: _SoapTime;\r\n class function CreateRemote(const MachineName: string): _SoapTime;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoSoapDate provides a Create and CreateRemote method to \r\n// create instances of the default interface _SoapDate exposed by \r\n// the CoClass SoapDate. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoSoapDate = class\r\n class function Create: _SoapDate;\r\n class function CreateRemote(const MachineName: string): _SoapDate;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoSoapYearMonth provides a Create and CreateRemote method to \r\n// create instances of the default interface _SoapYearMonth exposed by \r\n// the CoClass SoapYearMonth. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoSoapYearMonth = class\r\n class function Create: _SoapYearMonth;\r\n class function CreateRemote(const MachineName: string): _SoapYearMonth;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoSoapYear provides a Create and CreateRemote method to \r\n// create instances of the default interface _SoapYear exposed by \r\n// the CoClass SoapYear. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoSoapYear = class\r\n class function Create: _SoapYear;\r\n class function CreateRemote(const MachineName: string): _SoapYear;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoSoapMonthDay provides a Create and CreateRemote method to \r\n// create instances of the default interface _SoapMonthDay exposed by \r\n// the CoClass SoapMonthDay. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoSoapMonthDay = class\r\n class function Create: _SoapMonthDay;\r\n class function CreateRemote(const MachineName: string): _SoapMonthDay;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoSoapDay provides a Create and CreateRemote method to \r\n// create instances of the default interface _SoapDay exposed by \r\n// the CoClass SoapDay. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoSoapDay = class\r\n class function Create: _SoapDay;\r\n class function CreateRemote(const MachineName: string): _SoapDay;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoSoapMonth provides a Create and CreateRemote method to \r\n// create instances of the default interface _SoapMonth exposed by \r\n// the CoClass SoapMonth. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoSoapMonth = class\r\n class function Create: _SoapMonth;\r\n class function CreateRemote(const MachineName: string): _SoapMonth;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoSoapHexBinary provides a Create and CreateRemote method to \r\n// create instances of the default interface _SoapHexBinary exposed by \r\n// the CoClass SoapHexBinary. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoSoapHexBinary = class\r\n class function Create: _SoapHexBinary;\r\n class function CreateRemote(const MachineName: string): _SoapHexBinary;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoSoapBase64Binary provides a Create and CreateRemote method to \r\n// create instances of the default interface _SoapBase64Binary exposed by \r\n// the CoClass SoapBase64Binary. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoSoapBase64Binary = class\r\n class function Create: _SoapBase64Binary;\r\n class function CreateRemote(const MachineName: string): _SoapBase64Binary;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoSoapInteger provides a Create and CreateRemote method to \r\n// create instances of the default interface _SoapInteger exposed by \r\n// the CoClass SoapInteger. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoSoapInteger = class\r\n class function Create: _SoapInteger;\r\n class function CreateRemote(const MachineName: string): _SoapInteger;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoSoapPositiveInteger provides a Create and CreateRemote method to \r\n// create instances of the default interface _SoapPositiveInteger exposed by \r\n// the CoClass SoapPositiveInteger. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoSoapPositiveInteger = class\r\n class function Create: _SoapPositiveInteger;\r\n class function CreateRemote(const MachineName: string): _SoapPositiveInteger;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoSoapNonPositiveInteger provides a Create and CreateRemote method to \r\n// create instances of the default interface _SoapNonPositiveInteger exposed by \r\n// the CoClass SoapNonPositiveInteger. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoSoapNonPositiveInteger = class\r\n class function Create: _SoapNonPositiveInteger;\r\n class function CreateRemote(const MachineName: string): _SoapNonPositiveInteger;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoSoapNonNegativeInteger provides a Create and CreateRemote method to \r\n// create instances of the default interface _SoapNonNegativeInteger exposed by \r\n// the CoClass SoapNonNegativeInteger. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoSoapNonNegativeInteger = class\r\n class function Create: _SoapNonNegativeInteger;\r\n class function CreateRemote(const MachineName: string): _SoapNonNegativeInteger;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoSoapNegativeInteger provides a Create and CreateRemote method to \r\n// create instances of the default interface _SoapNegativeInteger exposed by \r\n// the CoClass SoapNegativeInteger. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoSoapNegativeInteger = class\r\n class function Create: _SoapNegativeInteger;\r\n class function CreateRemote(const MachineName: string): _SoapNegativeInteger;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoSoapAnyUri provides a Create and CreateRemote method to \r\n// create instances of the default interface _SoapAnyUri exposed by \r\n// the CoClass SoapAnyUri. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoSoapAnyUri = class\r\n class function Create: _SoapAnyUri;\r\n class function CreateRemote(const MachineName: string): _SoapAnyUri;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoSoapQName provides a Create and CreateRemote method to \r\n// create instances of the default interface _SoapQName exposed by \r\n// the CoClass SoapQName. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoSoapQName = class\r\n class function Create: _SoapQName;\r\n class function CreateRemote(const MachineName: string): _SoapQName;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoSoapNotation provides a Create and CreateRemote method to \r\n// create instances of the default interface _SoapNotation exposed by \r\n// the CoClass SoapNotation. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoSoapNotation = class\r\n class function Create: _SoapNotation;\r\n class function CreateRemote(const MachineName: string): _SoapNotation;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoSoapNormalizedString provides a Create and CreateRemote method to \r\n// create instances of the default interface _SoapNormalizedString exposed by \r\n// the CoClass SoapNormalizedString. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoSoapNormalizedString = class\r\n class function Create: _SoapNormalizedString;\r\n class function CreateRemote(const MachineName: string): _SoapNormalizedString;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoSoapToken provides a Create and CreateRemote method to \r\n// create instances of the default interface _SoapToken exposed by \r\n// the CoClass SoapToken. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoSoapToken = class\r\n class function Create: _SoapToken;\r\n class function CreateRemote(const MachineName: string): _SoapToken;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoSoapLanguage provides a Create and CreateRemote method to \r\n// create instances of the default interface _SoapLanguage exposed by \r\n// the CoClass SoapLanguage. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoSoapLanguage = class\r\n class function Create: _SoapLanguage;\r\n class function CreateRemote(const MachineName: string): _SoapLanguage;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoSoapName provides a Create and CreateRemote method to \r\n// create instances of the default interface _SoapName exposed by \r\n// the CoClass SoapName. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoSoapName = class\r\n class function Create: _SoapName;\r\n class function CreateRemote(const MachineName: string): _SoapName;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoSoapIdrefs provides a Create and CreateRemote method to \r\n// create instances of the default interface _SoapIdrefs exposed by \r\n// the CoClass SoapIdrefs. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoSoapIdrefs = class\r\n class function Create: _SoapIdrefs;\r\n class function CreateRemote(const MachineName: string): _SoapIdrefs;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoSoapEntities provides a Create and CreateRemote method to \r\n// create instances of the default interface _SoapEntities exposed by \r\n// the CoClass SoapEntities. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoSoapEntities = class\r\n class function Create: _SoapEntities;\r\n class function CreateRemote(const MachineName: string): _SoapEntities;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoSoapNmtoken provides a Create and CreateRemote method to \r\n// create instances of the default interface _SoapNmtoken exposed by \r\n// the CoClass SoapNmtoken. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoSoapNmtoken = class\r\n class function Create: _SoapNmtoken;\r\n class function CreateRemote(const MachineName: string): _SoapNmtoken;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoSoapNmtokens provides a Create and CreateRemote method to \r\n// create instances of the default interface _SoapNmtokens exposed by \r\n// the CoClass SoapNmtokens. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoSoapNmtokens = class\r\n class function Create: _SoapNmtokens;\r\n class function CreateRemote(const MachineName: string): _SoapNmtokens;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoSoapNcName provides a Create and CreateRemote method to \r\n// create instances of the default interface _SoapNcName exposed by \r\n// the CoClass SoapNcName. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoSoapNcName = class\r\n class function Create: _SoapNcName;\r\n class function CreateRemote(const MachineName: string): _SoapNcName;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoSoapId provides a Create and CreateRemote method to \r\n// create instances of the default interface _SoapId exposed by \r\n// the CoClass SoapId. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoSoapId = class\r\n class function Create: _SoapId;\r\n class function CreateRemote(const MachineName: string): _SoapId;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoSoapIdref provides a Create and CreateRemote method to \r\n// create instances of the default interface _SoapIdref exposed by \r\n// the CoClass SoapIdref. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoSoapIdref = class\r\n class function Create: _SoapIdref;\r\n class function CreateRemote(const MachineName: string): _SoapIdref;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoSoapEntity provides a Create and CreateRemote method to \r\n// create instances of the default interface _SoapEntity exposed by \r\n// the CoClass SoapEntity. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoSoapEntity = class\r\n class function Create: _SoapEntity;\r\n class function CreateRemote(const MachineName: string): _SoapEntity;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoSynchronizationAttribute provides a Create and CreateRemote method to \r\n// create instances of the default interface _SynchronizationAttribute exposed by \r\n// the CoClass SynchronizationAttribute. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoSynchronizationAttribute = class\r\n class function Create: _SynchronizationAttribute;\r\n class function CreateRemote(const MachineName: string): _SynchronizationAttribute;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoTrackingServices provides a Create and CreateRemote method to \r\n// create instances of the default interface _TrackingServices exposed by \r\n// the CoClass TrackingServices. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoTrackingServices = class\r\n class function Create: _TrackingServices;\r\n class function CreateRemote(const MachineName: string): _TrackingServices;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoUrlAttribute provides a Create and CreateRemote method to \r\n// create instances of the default interface _UrlAttribute exposed by \r\n// the CoClass UrlAttribute. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoUrlAttribute = class\r\n class function Create: _UrlAttribute;\r\n class function CreateRemote(const MachineName: string): _UrlAttribute;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoIsolatedStorage provides a Create and CreateRemote method to \r\n// create instances of the default interface _IsolatedStorage exposed by \r\n// the CoClass IsolatedStorage. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoIsolatedStorage = class\r\n class function Create: _IsolatedStorage;\r\n class function CreateRemote(const MachineName: string): _IsolatedStorage;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoIsolatedStorageFile provides a Create and CreateRemote method to \r\n// create instances of the default interface _IsolatedStorageFile exposed by \r\n// the CoClass IsolatedStorageFile. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoIsolatedStorageFile = class\r\n class function Create: _IsolatedStorageFile;\r\n class function CreateRemote(const MachineName: string): _IsolatedStorageFile;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoIsolatedStorageFileStream provides a Create and CreateRemote method to \r\n// create instances of the default interface _IsolatedStorageFileStream exposed by \r\n// the CoClass IsolatedStorageFileStream. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoIsolatedStorageFileStream = class\r\n class function Create: _IsolatedStorageFileStream;\r\n class function CreateRemote(const MachineName: string): _IsolatedStorageFileStream;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoIsolatedStorageException provides a Create and CreateRemote method to \r\n// create instances of the default interface _IsolatedStorageException exposed by \r\n// the CoClass IsolatedStorageException. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoIsolatedStorageException = class\r\n class function Create: _IsolatedStorageException;\r\n class function CreateRemote(const MachineName: string): _IsolatedStorageException;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoInternalRM provides a Create and CreateRemote method to \r\n// create instances of the default interface _InternalRM exposed by \r\n// the CoClass InternalRM. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoInternalRM = class\r\n class function Create: _InternalRM;\r\n class function CreateRemote(const MachineName: string): _InternalRM;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoInternalST provides a Create and CreateRemote method to \r\n// create instances of the default interface _InternalST exposed by \r\n// the CoClass InternalST. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoInternalST = class\r\n class function Create: _InternalST;\r\n class function CreateRemote(const MachineName: string): _InternalST;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoSoapMessage provides a Create and CreateRemote method to \r\n// create instances of the default interface _SoapMessage exposed by \r\n// the CoClass SoapMessage. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoSoapMessage = class\r\n class function Create: _SoapMessage;\r\n class function CreateRemote(const MachineName: string): _SoapMessage;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoSoapFault provides a Create and CreateRemote method to \r\n// create instances of the default interface _SoapFault exposed by \r\n// the CoClass SoapFault. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoSoapFault = class\r\n class function Create: _SoapFault;\r\n class function CreateRemote(const MachineName: string): _SoapFault;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoServerFault provides a Create and CreateRemote method to \r\n// create instances of the default interface _ServerFault exposed by \r\n// the CoClass ServerFault. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoServerFault = class\r\n class function Create: _ServerFault;\r\n class function CreateRemote(const MachineName: string): _ServerFault;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoBinaryFormatter provides a Create and CreateRemote method to \r\n// create instances of the default interface _BinaryFormatter exposed by \r\n// the CoClass BinaryFormatter. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoBinaryFormatter = class\r\n class function Create: _BinaryFormatter;\r\n class function CreateRemote(const MachineName: string): _BinaryFormatter;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoAssemblyBuilder provides a Create and CreateRemote method to \r\n// create instances of the default interface _AssemblyBuilder exposed by \r\n// the CoClass AssemblyBuilder. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoAssemblyBuilder = class\r\n class function Create: _AssemblyBuilder;\r\n class function CreateRemote(const MachineName: string): _AssemblyBuilder;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoConstructorBuilder provides a Create and CreateRemote method to \r\n// create instances of the default interface _ConstructorBuilder exposed by \r\n// the CoClass ConstructorBuilder. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoConstructorBuilder = class\r\n class function Create: _ConstructorBuilder;\r\n class function CreateRemote(const MachineName: string): _ConstructorBuilder;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoEventBuilder provides a Create and CreateRemote method to \r\n// create instances of the default interface _EventBuilder exposed by \r\n// the CoClass EventBuilder. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoEventBuilder = class\r\n class function Create: _EventBuilder;\r\n class function CreateRemote(const MachineName: string): _EventBuilder;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoFieldBuilder provides a Create and CreateRemote method to \r\n// create instances of the default interface _FieldBuilder exposed by \r\n// the CoClass FieldBuilder. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoFieldBuilder = class\r\n class function Create: _FieldBuilder;\r\n class function CreateRemote(const MachineName: string): _FieldBuilder;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoILGenerator provides a Create and CreateRemote method to \r\n// create instances of the default interface _ILGenerator exposed by \r\n// the CoClass ILGenerator. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoILGenerator = class\r\n class function Create: _ILGenerator;\r\n class function CreateRemote(const MachineName: string): _ILGenerator;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoLocalBuilder provides a Create and CreateRemote method to \r\n// create instances of the default interface _LocalBuilder exposed by \r\n// the CoClass LocalBuilder. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoLocalBuilder = class\r\n class function Create: _LocalBuilder;\r\n class function CreateRemote(const MachineName: string): _LocalBuilder;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoMethodBuilder provides a Create and CreateRemote method to \r\n// create instances of the default interface _MethodBuilder exposed by \r\n// the CoClass MethodBuilder. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoMethodBuilder = class\r\n class function Create: _MethodBuilder;\r\n class function CreateRemote(const MachineName: string): _MethodBuilder;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoCustomAttributeBuilder provides a Create and CreateRemote method to \r\n// create instances of the default interface _CustomAttributeBuilder exposed by \r\n// the CoClass CustomAttributeBuilder. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoCustomAttributeBuilder = class\r\n class function Create: _CustomAttributeBuilder;\r\n class function CreateRemote(const MachineName: string): _CustomAttributeBuilder;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoMethodRental provides a Create and CreateRemote method to \r\n// create instances of the default interface _MethodRental exposed by \r\n// the CoClass MethodRental. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoMethodRental = class\r\n class function Create: _MethodRental;\r\n class function CreateRemote(const MachineName: string): _MethodRental;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoModuleBuilder provides a Create and CreateRemote method to \r\n// create instances of the default interface _ModuleBuilder exposed by \r\n// the CoClass ModuleBuilder. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoModuleBuilder = class\r\n class function Create: _ModuleBuilder;\r\n class function CreateRemote(const MachineName: string): _ModuleBuilder;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoOpCodes provides a Create and CreateRemote method to \r\n// create instances of the default interface _OpCodes exposed by \r\n// the CoClass OpCodes. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoOpCodes = class\r\n class function Create: _OpCodes;\r\n class function CreateRemote(const MachineName: string): _OpCodes;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoParameterBuilder provides a Create and CreateRemote method to \r\n// create instances of the default interface _ParameterBuilder exposed by \r\n// the CoClass ParameterBuilder. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoParameterBuilder = class\r\n class function Create: _ParameterBuilder;\r\n class function CreateRemote(const MachineName: string): _ParameterBuilder;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoPropertyBuilder provides a Create and CreateRemote method to \r\n// create instances of the default interface _PropertyBuilder exposed by \r\n// the CoClass PropertyBuilder. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoPropertyBuilder = class\r\n class function Create: _PropertyBuilder;\r\n class function CreateRemote(const MachineName: string): _PropertyBuilder;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoSignatureHelper provides a Create and CreateRemote method to \r\n// create instances of the default interface _SignatureHelper exposed by \r\n// the CoClass SignatureHelper. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoSignatureHelper = class\r\n class function Create: _SignatureHelper;\r\n class function CreateRemote(const MachineName: string): _SignatureHelper;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoTypeBuilder provides a Create and CreateRemote method to \r\n// create instances of the default interface _TypeBuilder exposed by \r\n// the CoClass TypeBuilder. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoTypeBuilder = class\r\n class function Create: _TypeBuilder;\r\n class function CreateRemote(const MachineName: string): _TypeBuilder;\r\n end;\r\n\r\n// *********************************************************************//\r\n// The Class CoEnumBuilder provides a Create and CreateRemote method to \r\n// create instances of the default interface _EnumBuilder exposed by \r\n// the CoClass EnumBuilder. The functions are intended to be used by \r\n// clients wishing to automate the CoClass objects exposed by the \r\n// server of this typelibrary. \r\n// *********************************************************************//\r\n CoEnumBuilder = class\r\n class function Create: _EnumBuilder;\r\n class function CreateRemote(const MachineName: string): _EnumBuilder;\r\n end;\r\n\r\n//DOM-IGNORE-END\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jcl.svn.sourceforge.net/svnroot/jcl/tags/JCL-2.4-Build4571/jcl/source/windows/mscorlib_TLB.pas $';\r\n Revision: '$Revision: 3599 $';\r\n Date: '$Date: 2011-09-03 00:07:50 +0200 (sam. 03 sept. 2011) $';\r\n LogPath: 'JCL\\source\\windows';\r\n Extra: '';\r\n Data: nil\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses \r\n {$IFDEF HAS_UNITSCOPE}\r\n System.Win.ComObj;\r\n {$ELSE ~HAS_UNITSCOPE}\r\n ComObj;\r\n {$ENDIF ~HAS_UNITSCOPE}\r\n\r\nclass function CoAppDomain.Create: _AppDomain;\r\nbegin\r\n Result := CreateComObject(CLASS_AppDomain) as _AppDomain;\r\nend;\r\n\r\nclass function CoAppDomain.CreateRemote(const MachineName: string): _AppDomain;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_AppDomain) as _AppDomain;\r\nend;\r\n\r\nclass function CoRegistrationServices.Create: IRegistrationServices;\r\nbegin\r\n Result := CreateComObject(CLASS_RegistrationServices) as IRegistrationServices;\r\nend;\r\n\r\nclass function CoRegistrationServices.CreateRemote(const MachineName: string): IRegistrationServices;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_RegistrationServices) as IRegistrationServices;\r\nend;\r\n\r\nclass function CoTypeLibConverter.Create: ITypeLibConverter;\r\nbegin\r\n Result := CreateComObject(CLASS_TypeLibConverter) as ITypeLibConverter;\r\nend;\r\n\r\nclass function CoTypeLibConverter.CreateRemote(const MachineName: string): ITypeLibConverter;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_TypeLibConverter) as ITypeLibConverter;\r\nend;\r\n\r\nclass function CoAppDomainSetup.Create: IAppDomainSetup;\r\nbegin\r\n Result := CreateComObject(CLASS_AppDomainSetup) as IAppDomainSetup;\r\nend;\r\n\r\nclass function CoAppDomainSetup.CreateRemote(const MachineName: string): IAppDomainSetup;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_AppDomainSetup) as IAppDomainSetup;\r\nend;\r\n\r\nclass function CoObject_.Create: _Object;\r\nbegin\r\n Result := CreateComObject(CLASS_Object_) as _Object;\r\nend;\r\n\r\nclass function CoObject_.CreateRemote(const MachineName: string): _Object;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_Object_) as _Object;\r\nend;\r\n\r\nclass function CoArray_.Create: _Array;\r\nbegin\r\n Result := CreateComObject(CLASS_Array_) as _Array;\r\nend;\r\n\r\nclass function CoArray_.CreateRemote(const MachineName: string): _Array;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_Array_) as _Array;\r\nend;\r\n\r\nclass function CoString_.Create: _String;\r\nbegin\r\n Result := CreateComObject(CLASS_String_) as _String;\r\nend;\r\n\r\nclass function CoString_.CreateRemote(const MachineName: string): _String;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_String_) as _String;\r\nend;\r\n\r\nclass function CoStringBuilder.Create: _StringBuilder;\r\nbegin\r\n Result := CreateComObject(CLASS_StringBuilder) as _StringBuilder;\r\nend;\r\n\r\nclass function CoStringBuilder.CreateRemote(const MachineName: string): _StringBuilder;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_StringBuilder) as _StringBuilder;\r\nend;\r\n\r\nclass function CoException.Create: _Exception;\r\nbegin\r\n Result := CreateComObject(CLASS_Exception) as _Exception;\r\nend;\r\n\r\nclass function CoException.CreateRemote(const MachineName: string): _Exception;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_Exception) as _Exception;\r\nend;\r\n\r\nclass function CoValueType.Create: _ValueType;\r\nbegin\r\n Result := CreateComObject(CLASS_ValueType) as _ValueType;\r\nend;\r\n\r\nclass function CoValueType.CreateRemote(const MachineName: string): _ValueType;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_ValueType) as _ValueType;\r\nend;\r\n\r\nclass function CoSystemException.Create: _SystemException;\r\nbegin\r\n Result := CreateComObject(CLASS_SystemException) as _SystemException;\r\nend;\r\n\r\nclass function CoSystemException.CreateRemote(const MachineName: string): _SystemException;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_SystemException) as _SystemException;\r\nend;\r\n\r\nclass function CoOutOfMemoryException.Create: _OutOfMemoryException;\r\nbegin\r\n Result := CreateComObject(CLASS_OutOfMemoryException) as _OutOfMemoryException;\r\nend;\r\n\r\nclass function CoOutOfMemoryException.CreateRemote(const MachineName: string): _OutOfMemoryException;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_OutOfMemoryException) as _OutOfMemoryException;\r\nend;\r\n\r\nclass function CoStackOverflowException.Create: _StackOverflowException;\r\nbegin\r\n Result := CreateComObject(CLASS_StackOverflowException) as _StackOverflowException;\r\nend;\r\n\r\nclass function CoStackOverflowException.CreateRemote(const MachineName: string): _StackOverflowException;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_StackOverflowException) as _StackOverflowException;\r\nend;\r\n\r\nclass function CoExecutionEngineException.Create: _ExecutionEngineException;\r\nbegin\r\n Result := CreateComObject(CLASS_ExecutionEngineException) as _ExecutionEngineException;\r\nend;\r\n\r\nclass function CoExecutionEngineException.CreateRemote(const MachineName: string): _ExecutionEngineException;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_ExecutionEngineException) as _ExecutionEngineException;\r\nend;\r\n\r\nclass function CoDelegate.Create: _Delegate;\r\nbegin\r\n Result := CreateComObject(CLASS_Delegate) as _Delegate;\r\nend;\r\n\r\nclass function CoDelegate.CreateRemote(const MachineName: string): _Delegate;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_Delegate) as _Delegate;\r\nend;\r\n\r\nclass function CoMulticastDelegate.Create: _MulticastDelegate;\r\nbegin\r\n Result := CreateComObject(CLASS_MulticastDelegate) as _MulticastDelegate;\r\nend;\r\n\r\nclass function CoMulticastDelegate.CreateRemote(const MachineName: string): _MulticastDelegate;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_MulticastDelegate) as _MulticastDelegate;\r\nend;\r\n\r\nclass function CoEnum.Create: _Enum;\r\nbegin\r\n Result := CreateComObject(CLASS_Enum) as _Enum;\r\nend;\r\n\r\nclass function CoEnum.CreateRemote(const MachineName: string): _Enum;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_Enum) as _Enum;\r\nend;\r\n\r\nclass function CoMemberAccessException.Create: _MemberAccessException;\r\nbegin\r\n Result := CreateComObject(CLASS_MemberAccessException) as _MemberAccessException;\r\nend;\r\n\r\nclass function CoMemberAccessException.CreateRemote(const MachineName: string): _MemberAccessException;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_MemberAccessException) as _MemberAccessException;\r\nend;\r\n\r\nclass function CoActivator.Create: _Activator;\r\nbegin\r\n Result := CreateComObject(CLASS_Activator) as _Activator;\r\nend;\r\n\r\nclass function CoActivator.CreateRemote(const MachineName: string): _Activator;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_Activator) as _Activator;\r\nend;\r\n\r\nclass function CoApplicationException.Create: _ApplicationException;\r\nbegin\r\n Result := CreateComObject(CLASS_ApplicationException) as _ApplicationException;\r\nend;\r\n\r\nclass function CoApplicationException.CreateRemote(const MachineName: string): _ApplicationException;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_ApplicationException) as _ApplicationException;\r\nend;\r\n\r\nclass function CoEventArgs.Create: _EventArgs;\r\nbegin\r\n Result := CreateComObject(CLASS_EventArgs) as _EventArgs;\r\nend;\r\n\r\nclass function CoEventArgs.CreateRemote(const MachineName: string): _EventArgs;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_EventArgs) as _EventArgs;\r\nend;\r\n\r\nclass function CoResolveEventArgs.Create: _ResolveEventArgs;\r\nbegin\r\n Result := CreateComObject(CLASS_ResolveEventArgs) as _ResolveEventArgs;\r\nend;\r\n\r\nclass function CoResolveEventArgs.CreateRemote(const MachineName: string): _ResolveEventArgs;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_ResolveEventArgs) as _ResolveEventArgs;\r\nend;\r\n\r\nclass function CoAssemblyLoadEventArgs.Create: _AssemblyLoadEventArgs;\r\nbegin\r\n Result := CreateComObject(CLASS_AssemblyLoadEventArgs) as _AssemblyLoadEventArgs;\r\nend;\r\n\r\nclass function CoAssemblyLoadEventArgs.CreateRemote(const MachineName: string): _AssemblyLoadEventArgs;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_AssemblyLoadEventArgs) as _AssemblyLoadEventArgs;\r\nend;\r\n\r\nclass function CoResolveEventHandler.Create: _ResolveEventHandler;\r\nbegin\r\n Result := CreateComObject(CLASS_ResolveEventHandler) as _ResolveEventHandler;\r\nend;\r\n\r\nclass function CoResolveEventHandler.CreateRemote(const MachineName: string): _ResolveEventHandler;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_ResolveEventHandler) as _ResolveEventHandler;\r\nend;\r\n\r\nclass function CoAssemblyLoadEventHandler.Create: _AssemblyLoadEventHandler;\r\nbegin\r\n Result := CreateComObject(CLASS_AssemblyLoadEventHandler) as _AssemblyLoadEventHandler;\r\nend;\r\n\r\nclass function CoAssemblyLoadEventHandler.CreateRemote(const MachineName: string): _AssemblyLoadEventHandler;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_AssemblyLoadEventHandler) as _AssemblyLoadEventHandler;\r\nend;\r\n\r\nclass function CoMarshalByRefObject.Create: _MarshalByRefObject;\r\nbegin\r\n Result := CreateComObject(CLASS_MarshalByRefObject) as _MarshalByRefObject;\r\nend;\r\n\r\nclass function CoMarshalByRefObject.CreateRemote(const MachineName: string): _MarshalByRefObject;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_MarshalByRefObject) as _MarshalByRefObject;\r\nend;\r\n\r\nclass function CoCrossAppDomainDelegate.Create: _CrossAppDomainDelegate;\r\nbegin\r\n Result := CreateComObject(CLASS_CrossAppDomainDelegate) as _CrossAppDomainDelegate;\r\nend;\r\n\r\nclass function CoCrossAppDomainDelegate.CreateRemote(const MachineName: string): _CrossAppDomainDelegate;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_CrossAppDomainDelegate) as _CrossAppDomainDelegate;\r\nend;\r\n\r\nclass function CoAttribute.Create: _Attribute;\r\nbegin\r\n Result := CreateComObject(CLASS_Attribute) as _Attribute;\r\nend;\r\n\r\nclass function CoAttribute.CreateRemote(const MachineName: string): _Attribute;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_Attribute) as _Attribute;\r\nend;\r\n\r\nclass function CoLoaderOptimizationAttribute.Create: _LoaderOptimizationAttribute;\r\nbegin\r\n Result := CreateComObject(CLASS_LoaderOptimizationAttribute) as _LoaderOptimizationAttribute;\r\nend;\r\n\r\nclass function CoLoaderOptimizationAttribute.CreateRemote(const MachineName: string): _LoaderOptimizationAttribute;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_LoaderOptimizationAttribute) as _LoaderOptimizationAttribute;\r\nend;\r\n\r\nclass function CoAppDomainUnloadedException.Create: _AppDomainUnloadedException;\r\nbegin\r\n Result := CreateComObject(CLASS_AppDomainUnloadedException) as _AppDomainUnloadedException;\r\nend;\r\n\r\nclass function CoAppDomainUnloadedException.CreateRemote(const MachineName: string): _AppDomainUnloadedException;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_AppDomainUnloadedException) as _AppDomainUnloadedException;\r\nend;\r\n\r\nclass function CoArgumentException.Create: _ArgumentException;\r\nbegin\r\n Result := CreateComObject(CLASS_ArgumentException) as _ArgumentException;\r\nend;\r\n\r\nclass function CoArgumentException.CreateRemote(const MachineName: string): _ArgumentException;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_ArgumentException) as _ArgumentException;\r\nend;\r\n\r\nclass function CoArgumentNullException.Create: _ArgumentNullException;\r\nbegin\r\n Result := CreateComObject(CLASS_ArgumentNullException) as _ArgumentNullException;\r\nend;\r\n\r\nclass function CoArgumentNullException.CreateRemote(const MachineName: string): _ArgumentNullException;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_ArgumentNullException) as _ArgumentNullException;\r\nend;\r\n\r\nclass function CoArgumentOutOfRangeException.Create: _ArgumentOutOfRangeException;\r\nbegin\r\n Result := CreateComObject(CLASS_ArgumentOutOfRangeException) as _ArgumentOutOfRangeException;\r\nend;\r\n\r\nclass function CoArgumentOutOfRangeException.CreateRemote(const MachineName: string): _ArgumentOutOfRangeException;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_ArgumentOutOfRangeException) as _ArgumentOutOfRangeException;\r\nend;\r\n\r\nclass function CoArithmeticException.Create: _ArithmeticException;\r\nbegin\r\n Result := CreateComObject(CLASS_ArithmeticException) as _ArithmeticException;\r\nend;\r\n\r\nclass function CoArithmeticException.CreateRemote(const MachineName: string): _ArithmeticException;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_ArithmeticException) as _ArithmeticException;\r\nend;\r\n\r\nclass function CoArrayTypeMismatchException.Create: _ArrayTypeMismatchException;\r\nbegin\r\n Result := CreateComObject(CLASS_ArrayTypeMismatchException) as _ArrayTypeMismatchException;\r\nend;\r\n\r\nclass function CoArrayTypeMismatchException.CreateRemote(const MachineName: string): _ArrayTypeMismatchException;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_ArrayTypeMismatchException) as _ArrayTypeMismatchException;\r\nend;\r\n\r\nclass function CoAsyncCallback.Create: _AsyncCallback;\r\nbegin\r\n Result := CreateComObject(CLASS_AsyncCallback) as _AsyncCallback;\r\nend;\r\n\r\nclass function CoAsyncCallback.CreateRemote(const MachineName: string): _AsyncCallback;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_AsyncCallback) as _AsyncCallback;\r\nend;\r\n\r\nclass function CoAttributeUsageAttribute.Create: _AttributeUsageAttribute;\r\nbegin\r\n Result := CreateComObject(CLASS_AttributeUsageAttribute) as _AttributeUsageAttribute;\r\nend;\r\n\r\nclass function CoAttributeUsageAttribute.CreateRemote(const MachineName: string): _AttributeUsageAttribute;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_AttributeUsageAttribute) as _AttributeUsageAttribute;\r\nend;\r\n\r\nclass function CoBadImageFormatException.Create: _BadImageFormatException;\r\nbegin\r\n Result := CreateComObject(CLASS_BadImageFormatException) as _BadImageFormatException;\r\nend;\r\n\r\nclass function CoBadImageFormatException.CreateRemote(const MachineName: string): _BadImageFormatException;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_BadImageFormatException) as _BadImageFormatException;\r\nend;\r\n\r\nclass function CoBitConverter.Create: _BitConverter;\r\nbegin\r\n Result := CreateComObject(CLASS_BitConverter) as _BitConverter;\r\nend;\r\n\r\nclass function CoBitConverter.CreateRemote(const MachineName: string): _BitConverter;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_BitConverter) as _BitConverter;\r\nend;\r\n\r\nclass function CoBuffer.Create: _Buffer;\r\nbegin\r\n Result := CreateComObject(CLASS_Buffer) as _Buffer;\r\nend;\r\n\r\nclass function CoBuffer.CreateRemote(const MachineName: string): _Buffer;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_Buffer) as _Buffer;\r\nend;\r\n\r\nclass function CoCannotUnloadAppDomainException.Create: _CannotUnloadAppDomainException;\r\nbegin\r\n Result := CreateComObject(CLASS_CannotUnloadAppDomainException) as _CannotUnloadAppDomainException;\r\nend;\r\n\r\nclass function CoCannotUnloadAppDomainException.CreateRemote(const MachineName: string): _CannotUnloadAppDomainException;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_CannotUnloadAppDomainException) as _CannotUnloadAppDomainException;\r\nend;\r\n\r\nclass function CoCharEnumerator.Create: _CharEnumerator;\r\nbegin\r\n Result := CreateComObject(CLASS_CharEnumerator) as _CharEnumerator;\r\nend;\r\n\r\nclass function CoCharEnumerator.CreateRemote(const MachineName: string): _CharEnumerator;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_CharEnumerator) as _CharEnumerator;\r\nend;\r\n\r\nclass function CoCLSCompliantAttribute.Create: _CLSCompliantAttribute;\r\nbegin\r\n Result := CreateComObject(CLASS_CLSCompliantAttribute) as _CLSCompliantAttribute;\r\nend;\r\n\r\nclass function CoCLSCompliantAttribute.CreateRemote(const MachineName: string): _CLSCompliantAttribute;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_CLSCompliantAttribute) as _CLSCompliantAttribute;\r\nend;\r\n\r\nclass function CoTypeUnloadedException.Create: _TypeUnloadedException;\r\nbegin\r\n Result := CreateComObject(CLASS_TypeUnloadedException) as _TypeUnloadedException;\r\nend;\r\n\r\nclass function CoTypeUnloadedException.CreateRemote(const MachineName: string): _TypeUnloadedException;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_TypeUnloadedException) as _TypeUnloadedException;\r\nend;\r\n\r\nclass function CoConsole.Create: _Console;\r\nbegin\r\n Result := CreateComObject(CLASS_Console) as _Console;\r\nend;\r\n\r\nclass function CoConsole.CreateRemote(const MachineName: string): _Console;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_Console) as _Console;\r\nend;\r\n\r\nclass function CoContextMarshalException.Create: _ContextMarshalException;\r\nbegin\r\n Result := CreateComObject(CLASS_ContextMarshalException) as _ContextMarshalException;\r\nend;\r\n\r\nclass function CoContextMarshalException.CreateRemote(const MachineName: string): _ContextMarshalException;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_ContextMarshalException) as _ContextMarshalException;\r\nend;\r\n\r\nclass function CoConvert.Create: _Convert;\r\nbegin\r\n Result := CreateComObject(CLASS_Convert) as _Convert;\r\nend;\r\n\r\nclass function CoConvert.CreateRemote(const MachineName: string): _Convert;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_Convert) as _Convert;\r\nend;\r\n\r\nclass function CoContextBoundObject.Create: _ContextBoundObject;\r\nbegin\r\n Result := CreateComObject(CLASS_ContextBoundObject) as _ContextBoundObject;\r\nend;\r\n\r\nclass function CoContextBoundObject.CreateRemote(const MachineName: string): _ContextBoundObject;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_ContextBoundObject) as _ContextBoundObject;\r\nend;\r\n\r\nclass function CoContextStaticAttribute.Create: _ContextStaticAttribute;\r\nbegin\r\n Result := CreateComObject(CLASS_ContextStaticAttribute) as _ContextStaticAttribute;\r\nend;\r\n\r\nclass function CoContextStaticAttribute.CreateRemote(const MachineName: string): _ContextStaticAttribute;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_ContextStaticAttribute) as _ContextStaticAttribute;\r\nend;\r\n\r\nclass function CoTimeZone.Create: _TimeZone;\r\nbegin\r\n Result := CreateComObject(CLASS_TimeZone) as _TimeZone;\r\nend;\r\n\r\nclass function CoTimeZone.CreateRemote(const MachineName: string): _TimeZone;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_TimeZone) as _TimeZone;\r\nend;\r\n\r\nclass function CoDBNull.Create: _DBNull;\r\nbegin\r\n Result := CreateComObject(CLASS_DBNull) as _DBNull;\r\nend;\r\n\r\nclass function CoDBNull.CreateRemote(const MachineName: string): _DBNull;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_DBNull) as _DBNull;\r\nend;\r\n\r\nclass function CoBinder.Create: _Binder;\r\nbegin\r\n Result := CreateComObject(CLASS_Binder) as _Binder;\r\nend;\r\n\r\nclass function CoBinder.CreateRemote(const MachineName: string): _Binder;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_Binder) as _Binder;\r\nend;\r\n\r\nclass function CoDivideByZeroException.Create: _DivideByZeroException;\r\nbegin\r\n Result := CreateComObject(CLASS_DivideByZeroException) as _DivideByZeroException;\r\nend;\r\n\r\nclass function CoDivideByZeroException.CreateRemote(const MachineName: string): _DivideByZeroException;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_DivideByZeroException) as _DivideByZeroException;\r\nend;\r\n\r\nclass function CoDuplicateWaitObjectException.Create: _DuplicateWaitObjectException;\r\nbegin\r\n Result := CreateComObject(CLASS_DuplicateWaitObjectException) as _DuplicateWaitObjectException;\r\nend;\r\n\r\nclass function CoDuplicateWaitObjectException.CreateRemote(const MachineName: string): _DuplicateWaitObjectException;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_DuplicateWaitObjectException) as _DuplicateWaitObjectException;\r\nend;\r\n\r\nclass function CoTypeLoadException.Create: _TypeLoadException;\r\nbegin\r\n Result := CreateComObject(CLASS_TypeLoadException) as _TypeLoadException;\r\nend;\r\n\r\nclass function CoTypeLoadException.CreateRemote(const MachineName: string): _TypeLoadException;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_TypeLoadException) as _TypeLoadException;\r\nend;\r\n\r\nclass function CoEntryPointNotFoundException.Create: _EntryPointNotFoundException;\r\nbegin\r\n Result := CreateComObject(CLASS_EntryPointNotFoundException) as _EntryPointNotFoundException;\r\nend;\r\n\r\nclass function CoEntryPointNotFoundException.CreateRemote(const MachineName: string): _EntryPointNotFoundException;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_EntryPointNotFoundException) as _EntryPointNotFoundException;\r\nend;\r\n\r\nclass function CoDllNotFoundException.Create: _DllNotFoundException;\r\nbegin\r\n Result := CreateComObject(CLASS_DllNotFoundException) as _DllNotFoundException;\r\nend;\r\n\r\nclass function CoDllNotFoundException.CreateRemote(const MachineName: string): _DllNotFoundException;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_DllNotFoundException) as _DllNotFoundException;\r\nend;\r\n\r\nclass function CoEnvironment.Create: _Environment;\r\nbegin\r\n Result := CreateComObject(CLASS_Environment) as _Environment;\r\nend;\r\n\r\nclass function CoEnvironment.CreateRemote(const MachineName: string): _Environment;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_Environment) as _Environment;\r\nend;\r\n\r\nclass function CoEventHandler.Create: _EventHandler;\r\nbegin\r\n Result := CreateComObject(CLASS_EventHandler) as _EventHandler;\r\nend;\r\n\r\nclass function CoEventHandler.CreateRemote(const MachineName: string): _EventHandler;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_EventHandler) as _EventHandler;\r\nend;\r\n\r\nclass function CoFieldAccessException.Create: _FieldAccessException;\r\nbegin\r\n Result := CreateComObject(CLASS_FieldAccessException) as _FieldAccessException;\r\nend;\r\n\r\nclass function CoFieldAccessException.CreateRemote(const MachineName: string): _FieldAccessException;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_FieldAccessException) as _FieldAccessException;\r\nend;\r\n\r\nclass function CoFlagsAttribute.Create: _FlagsAttribute;\r\nbegin\r\n Result := CreateComObject(CLASS_FlagsAttribute) as _FlagsAttribute;\r\nend;\r\n\r\nclass function CoFlagsAttribute.CreateRemote(const MachineName: string): _FlagsAttribute;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_FlagsAttribute) as _FlagsAttribute;\r\nend;\r\n\r\nclass function CoFormatException.Create: _FormatException;\r\nbegin\r\n Result := CreateComObject(CLASS_FormatException) as _FormatException;\r\nend;\r\n\r\nclass function CoFormatException.CreateRemote(const MachineName: string): _FormatException;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_FormatException) as _FormatException;\r\nend;\r\n\r\nclass function CoGC.Create: _GC;\r\nbegin\r\n Result := CreateComObject(CLASS_GC) as _GC;\r\nend;\r\n\r\nclass function CoGC.CreateRemote(const MachineName: string): _GC;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_GC) as _GC;\r\nend;\r\n\r\nclass function CoIndexOutOfRangeException.Create: _IndexOutOfRangeException;\r\nbegin\r\n Result := CreateComObject(CLASS_IndexOutOfRangeException) as _IndexOutOfRangeException;\r\nend;\r\n\r\nclass function CoIndexOutOfRangeException.CreateRemote(const MachineName: string): _IndexOutOfRangeException;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_IndexOutOfRangeException) as _IndexOutOfRangeException;\r\nend;\r\n\r\nclass function CoInvalidCastException.Create: _InvalidCastException;\r\nbegin\r\n Result := CreateComObject(CLASS_InvalidCastException) as _InvalidCastException;\r\nend;\r\n\r\nclass function CoInvalidCastException.CreateRemote(const MachineName: string): _InvalidCastException;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_InvalidCastException) as _InvalidCastException;\r\nend;\r\n\r\nclass function CoInvalidOperationException.Create: _InvalidOperationException;\r\nbegin\r\n Result := CreateComObject(CLASS_InvalidOperationException) as _InvalidOperationException;\r\nend;\r\n\r\nclass function CoInvalidOperationException.CreateRemote(const MachineName: string): _InvalidOperationException;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_InvalidOperationException) as _InvalidOperationException;\r\nend;\r\n\r\nclass function CoInvalidProgramException.Create: _InvalidProgramException;\r\nbegin\r\n Result := CreateComObject(CLASS_InvalidProgramException) as _InvalidProgramException;\r\nend;\r\n\r\nclass function CoInvalidProgramException.CreateRemote(const MachineName: string): _InvalidProgramException;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_InvalidProgramException) as _InvalidProgramException;\r\nend;\r\n\r\nclass function CoLocalDataStoreSlot.Create: _LocalDataStoreSlot;\r\nbegin\r\n Result := CreateComObject(CLASS_LocalDataStoreSlot) as _LocalDataStoreSlot;\r\nend;\r\n\r\nclass function CoLocalDataStoreSlot.CreateRemote(const MachineName: string): _LocalDataStoreSlot;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_LocalDataStoreSlot) as _LocalDataStoreSlot;\r\nend;\r\n\r\nclass function CoMath.Create: _Math;\r\nbegin\r\n Result := CreateComObject(CLASS_Math) as _Math;\r\nend;\r\n\r\nclass function CoMath.CreateRemote(const MachineName: string): _Math;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_Math) as _Math;\r\nend;\r\n\r\nclass function CoMethodAccessException.Create: _MethodAccessException;\r\nbegin\r\n Result := CreateComObject(CLASS_MethodAccessException) as _MethodAccessException;\r\nend;\r\n\r\nclass function CoMethodAccessException.CreateRemote(const MachineName: string): _MethodAccessException;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_MethodAccessException) as _MethodAccessException;\r\nend;\r\n\r\nclass function CoMissingMemberException.Create: _MissingMemberException;\r\nbegin\r\n Result := CreateComObject(CLASS_MissingMemberException) as _MissingMemberException;\r\nend;\r\n\r\nclass function CoMissingMemberException.CreateRemote(const MachineName: string): _MissingMemberException;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_MissingMemberException) as _MissingMemberException;\r\nend;\r\n\r\nclass function CoMissingFieldException.Create: _MissingFieldException;\r\nbegin\r\n Result := CreateComObject(CLASS_MissingFieldException) as _MissingFieldException;\r\nend;\r\n\r\nclass function CoMissingFieldException.CreateRemote(const MachineName: string): _MissingFieldException;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_MissingFieldException) as _MissingFieldException;\r\nend;\r\n\r\nclass function CoMissingMethodException.Create: _MissingMethodException;\r\nbegin\r\n Result := CreateComObject(CLASS_MissingMethodException) as _MissingMethodException;\r\nend;\r\n\r\nclass function CoMissingMethodException.CreateRemote(const MachineName: string): _MissingMethodException;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_MissingMethodException) as _MissingMethodException;\r\nend;\r\n\r\nclass function CoMulticastNotSupportedException.Create: _MulticastNotSupportedException;\r\nbegin\r\n Result := CreateComObject(CLASS_MulticastNotSupportedException) as _MulticastNotSupportedException;\r\nend;\r\n\r\nclass function CoMulticastNotSupportedException.CreateRemote(const MachineName: string): _MulticastNotSupportedException;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_MulticastNotSupportedException) as _MulticastNotSupportedException;\r\nend;\r\n\r\nclass function CoNonSerializedAttribute.Create: _NonSerializedAttribute;\r\nbegin\r\n Result := CreateComObject(CLASS_NonSerializedAttribute) as _NonSerializedAttribute;\r\nend;\r\n\r\nclass function CoNonSerializedAttribute.CreateRemote(const MachineName: string): _NonSerializedAttribute;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_NonSerializedAttribute) as _NonSerializedAttribute;\r\nend;\r\n\r\nclass function CoNotFiniteNumberException.Create: _NotFiniteNumberException;\r\nbegin\r\n Result := CreateComObject(CLASS_NotFiniteNumberException) as _NotFiniteNumberException;\r\nend;\r\n\r\nclass function CoNotFiniteNumberException.CreateRemote(const MachineName: string): _NotFiniteNumberException;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_NotFiniteNumberException) as _NotFiniteNumberException;\r\nend;\r\n\r\nclass function CoNotImplementedException.Create: _NotImplementedException;\r\nbegin\r\n Result := CreateComObject(CLASS_NotImplementedException) as _NotImplementedException;\r\nend;\r\n\r\nclass function CoNotImplementedException.CreateRemote(const MachineName: string): _NotImplementedException;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_NotImplementedException) as _NotImplementedException;\r\nend;\r\n\r\nclass function CoNotSupportedException.Create: _NotSupportedException;\r\nbegin\r\n Result := CreateComObject(CLASS_NotSupportedException) as _NotSupportedException;\r\nend;\r\n\r\nclass function CoNotSupportedException.CreateRemote(const MachineName: string): _NotSupportedException;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_NotSupportedException) as _NotSupportedException;\r\nend;\r\n\r\nclass function CoNullReferenceException.Create: _NullReferenceException;\r\nbegin\r\n Result := CreateComObject(CLASS_NullReferenceException) as _NullReferenceException;\r\nend;\r\n\r\nclass function CoNullReferenceException.CreateRemote(const MachineName: string): _NullReferenceException;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_NullReferenceException) as _NullReferenceException;\r\nend;\r\n\r\nclass function CoObjectDisposedException.Create: _ObjectDisposedException;\r\nbegin\r\n Result := CreateComObject(CLASS_ObjectDisposedException) as _ObjectDisposedException;\r\nend;\r\n\r\nclass function CoObjectDisposedException.CreateRemote(const MachineName: string): _ObjectDisposedException;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_ObjectDisposedException) as _ObjectDisposedException;\r\nend;\r\n\r\nclass function CoObsoleteAttribute.Create: _ObsoleteAttribute;\r\nbegin\r\n Result := CreateComObject(CLASS_ObsoleteAttribute) as _ObsoleteAttribute;\r\nend;\r\n\r\nclass function CoObsoleteAttribute.CreateRemote(const MachineName: string): _ObsoleteAttribute;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_ObsoleteAttribute) as _ObsoleteAttribute;\r\nend;\r\n\r\nclass function CoOperatingSystem.Create: _OperatingSystem;\r\nbegin\r\n Result := CreateComObject(CLASS_OperatingSystem) as _OperatingSystem;\r\nend;\r\n\r\nclass function CoOperatingSystem.CreateRemote(const MachineName: string): _OperatingSystem;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_OperatingSystem) as _OperatingSystem;\r\nend;\r\n\r\nclass function CoOverflowException.Create: _OverflowException;\r\nbegin\r\n Result := CreateComObject(CLASS_OverflowException) as _OverflowException;\r\nend;\r\n\r\nclass function CoOverflowException.CreateRemote(const MachineName: string): _OverflowException;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_OverflowException) as _OverflowException;\r\nend;\r\n\r\nclass function CoParamArrayAttribute.Create: _ParamArrayAttribute;\r\nbegin\r\n Result := CreateComObject(CLASS_ParamArrayAttribute) as _ParamArrayAttribute;\r\nend;\r\n\r\nclass function CoParamArrayAttribute.CreateRemote(const MachineName: string): _ParamArrayAttribute;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_ParamArrayAttribute) as _ParamArrayAttribute;\r\nend;\r\n\r\nclass function CoPlatformNotSupportedException.Create: _PlatformNotSupportedException;\r\nbegin\r\n Result := CreateComObject(CLASS_PlatformNotSupportedException) as _PlatformNotSupportedException;\r\nend;\r\n\r\nclass function CoPlatformNotSupportedException.CreateRemote(const MachineName: string): _PlatformNotSupportedException;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_PlatformNotSupportedException) as _PlatformNotSupportedException;\r\nend;\r\n\r\nclass function CoRandom.Create: _Random;\r\nbegin\r\n Result := CreateComObject(CLASS_Random) as _Random;\r\nend;\r\n\r\nclass function CoRandom.CreateRemote(const MachineName: string): _Random;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_Random) as _Random;\r\nend;\r\n\r\nclass function CoRankException.Create: _RankException;\r\nbegin\r\n Result := CreateComObject(CLASS_RankException) as _RankException;\r\nend;\r\n\r\nclass function CoRankException.CreateRemote(const MachineName: string): _RankException;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_RankException) as _RankException;\r\nend;\r\n\r\nclass function CoMemberInfo.Create: _MemberInfo;\r\nbegin\r\n Result := CreateComObject(CLASS_MemberInfo) as _MemberInfo;\r\nend;\r\n\r\nclass function CoMemberInfo.CreateRemote(const MachineName: string): _MemberInfo;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_MemberInfo) as _MemberInfo;\r\nend;\r\n\r\nclass function CoType_.Create: _Type;\r\nbegin\r\n Result := CreateComObject(CLASS_Type_) as _Type;\r\nend;\r\n\r\nclass function CoType_.CreateRemote(const MachineName: string): _Type;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_Type_) as _Type;\r\nend;\r\n\r\nclass function CoSerializableAttribute.Create: _SerializableAttribute;\r\nbegin\r\n Result := CreateComObject(CLASS_SerializableAttribute) as _SerializableAttribute;\r\nend;\r\n\r\nclass function CoSerializableAttribute.CreateRemote(const MachineName: string): _SerializableAttribute;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_SerializableAttribute) as _SerializableAttribute;\r\nend;\r\n\r\nclass function CoTypeInitializationException.Create: _TypeInitializationException;\r\nbegin\r\n Result := CreateComObject(CLASS_TypeInitializationException) as _TypeInitializationException;\r\nend;\r\n\r\nclass function CoTypeInitializationException.CreateRemote(const MachineName: string): _TypeInitializationException;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_TypeInitializationException) as _TypeInitializationException;\r\nend;\r\n\r\nclass function CoUnauthorizedAccessException.Create: _UnauthorizedAccessException;\r\nbegin\r\n Result := CreateComObject(CLASS_UnauthorizedAccessException) as _UnauthorizedAccessException;\r\nend;\r\n\r\nclass function CoUnauthorizedAccessException.CreateRemote(const MachineName: string): _UnauthorizedAccessException;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_UnauthorizedAccessException) as _UnauthorizedAccessException;\r\nend;\r\n\r\nclass function CoUnhandledExceptionEventArgs.Create: _UnhandledExceptionEventArgs;\r\nbegin\r\n Result := CreateComObject(CLASS_UnhandledExceptionEventArgs) as _UnhandledExceptionEventArgs;\r\nend;\r\n\r\nclass function CoUnhandledExceptionEventArgs.CreateRemote(const MachineName: string): _UnhandledExceptionEventArgs;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_UnhandledExceptionEventArgs) as _UnhandledExceptionEventArgs;\r\nend;\r\n\r\nclass function CoUnhandledExceptionEventHandler.Create: _UnhandledExceptionEventHandler;\r\nbegin\r\n Result := CreateComObject(CLASS_UnhandledExceptionEventHandler) as _UnhandledExceptionEventHandler;\r\nend;\r\n\r\nclass function CoUnhandledExceptionEventHandler.CreateRemote(const MachineName: string): _UnhandledExceptionEventHandler;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_UnhandledExceptionEventHandler) as _UnhandledExceptionEventHandler;\r\nend;\r\n\r\nclass function CoVersion.Create: _Version;\r\nbegin\r\n Result := CreateComObject(CLASS_Version) as _Version;\r\nend;\r\n\r\nclass function CoVersion.CreateRemote(const MachineName: string): _Version;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_Version) as _Version;\r\nend;\r\n\r\nclass function CoWeakReference.Create: _WeakReference;\r\nbegin\r\n Result := CreateComObject(CLASS_WeakReference) as _WeakReference;\r\nend;\r\n\r\nclass function CoWeakReference.CreateRemote(const MachineName: string): _WeakReference;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_WeakReference) as _WeakReference;\r\nend;\r\n\r\nclass function CoWaitHandle.Create: _WaitHandle;\r\nbegin\r\n Result := CreateComObject(CLASS_WaitHandle) as _WaitHandle;\r\nend;\r\n\r\nclass function CoWaitHandle.CreateRemote(const MachineName: string): _WaitHandle;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_WaitHandle) as _WaitHandle;\r\nend;\r\n\r\nclass function CoAutoResetEvent.Create: _AutoResetEvent;\r\nbegin\r\n Result := CreateComObject(CLASS_AutoResetEvent) as _AutoResetEvent;\r\nend;\r\n\r\nclass function CoAutoResetEvent.CreateRemote(const MachineName: string): _AutoResetEvent;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_AutoResetEvent) as _AutoResetEvent;\r\nend;\r\n\r\nclass function CoCompressedStack.Create: _CompressedStack;\r\nbegin\r\n Result := CreateComObject(CLASS_CompressedStack) as _CompressedStack;\r\nend;\r\n\r\nclass function CoCompressedStack.CreateRemote(const MachineName: string): _CompressedStack;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_CompressedStack) as _CompressedStack;\r\nend;\r\n\r\nclass function CoInterlocked.Create: _Interlocked;\r\nbegin\r\n Result := CreateComObject(CLASS_Interlocked) as _Interlocked;\r\nend;\r\n\r\nclass function CoInterlocked.CreateRemote(const MachineName: string): _Interlocked;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_Interlocked) as _Interlocked;\r\nend;\r\n\r\nclass function CoManualResetEvent.Create: _ManualResetEvent;\r\nbegin\r\n Result := CreateComObject(CLASS_ManualResetEvent) as _ManualResetEvent;\r\nend;\r\n\r\nclass function CoManualResetEvent.CreateRemote(const MachineName: string): _ManualResetEvent;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_ManualResetEvent) as _ManualResetEvent;\r\nend;\r\n\r\nclass function CoMonitor.Create: _Monitor;\r\nbegin\r\n Result := CreateComObject(CLASS_Monitor) as _Monitor;\r\nend;\r\n\r\nclass function CoMonitor.CreateRemote(const MachineName: string): _Monitor;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_Monitor) as _Monitor;\r\nend;\r\n\r\nclass function CoMutex.Create: _Mutex;\r\nbegin\r\n Result := CreateComObject(CLASS_Mutex) as _Mutex;\r\nend;\r\n\r\nclass function CoMutex.CreateRemote(const MachineName: string): _Mutex;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_Mutex) as _Mutex;\r\nend;\r\n\r\nclass function CoOverlapped.Create: _Overlapped;\r\nbegin\r\n Result := CreateComObject(CLASS_Overlapped) as _Overlapped;\r\nend;\r\n\r\nclass function CoOverlapped.CreateRemote(const MachineName: string): _Overlapped;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_Overlapped) as _Overlapped;\r\nend;\r\n\r\nclass function CoReaderWriterLock.Create: _ReaderWriterLock;\r\nbegin\r\n Result := CreateComObject(CLASS_ReaderWriterLock) as _ReaderWriterLock;\r\nend;\r\n\r\nclass function CoReaderWriterLock.CreateRemote(const MachineName: string): _ReaderWriterLock;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_ReaderWriterLock) as _ReaderWriterLock;\r\nend;\r\n\r\nclass function CoSynchronizationLockException.Create: _SynchronizationLockException;\r\nbegin\r\n Result := CreateComObject(CLASS_SynchronizationLockException) as _SynchronizationLockException;\r\nend;\r\n\r\nclass function CoSynchronizationLockException.CreateRemote(const MachineName: string): _SynchronizationLockException;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_SynchronizationLockException) as _SynchronizationLockException;\r\nend;\r\n\r\nclass function CoThread.Create: _Thread;\r\nbegin\r\n Result := CreateComObject(CLASS_Thread) as _Thread;\r\nend;\r\n\r\nclass function CoThread.CreateRemote(const MachineName: string): _Thread;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_Thread) as _Thread;\r\nend;\r\n\r\nclass function CoThreadAbortException.Create: _ThreadAbortException;\r\nbegin\r\n Result := CreateComObject(CLASS_ThreadAbortException) as _ThreadAbortException;\r\nend;\r\n\r\nclass function CoThreadAbortException.CreateRemote(const MachineName: string): _ThreadAbortException;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_ThreadAbortException) as _ThreadAbortException;\r\nend;\r\n\r\nclass function CoSTAThreadAttribute.Create: _STAThreadAttribute;\r\nbegin\r\n Result := CreateComObject(CLASS_STAThreadAttribute) as _STAThreadAttribute;\r\nend;\r\n\r\nclass function CoSTAThreadAttribute.CreateRemote(const MachineName: string): _STAThreadAttribute;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_STAThreadAttribute) as _STAThreadAttribute;\r\nend;\r\n\r\nclass function CoMTAThreadAttribute.Create: _MTAThreadAttribute;\r\nbegin\r\n Result := CreateComObject(CLASS_MTAThreadAttribute) as _MTAThreadAttribute;\r\nend;\r\n\r\nclass function CoMTAThreadAttribute.CreateRemote(const MachineName: string): _MTAThreadAttribute;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_MTAThreadAttribute) as _MTAThreadAttribute;\r\nend;\r\n\r\nclass function CoThreadInterruptedException.Create: _ThreadInterruptedException;\r\nbegin\r\n Result := CreateComObject(CLASS_ThreadInterruptedException) as _ThreadInterruptedException;\r\nend;\r\n\r\nclass function CoThreadInterruptedException.CreateRemote(const MachineName: string): _ThreadInterruptedException;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_ThreadInterruptedException) as _ThreadInterruptedException;\r\nend;\r\n\r\nclass function CoRegisteredWaitHandle.Create: _RegisteredWaitHandle;\r\nbegin\r\n Result := CreateComObject(CLASS_RegisteredWaitHandle) as _RegisteredWaitHandle;\r\nend;\r\n\r\nclass function CoRegisteredWaitHandle.CreateRemote(const MachineName: string): _RegisteredWaitHandle;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_RegisteredWaitHandle) as _RegisteredWaitHandle;\r\nend;\r\n\r\nclass function CoWaitCallback.Create: _WaitCallback;\r\nbegin\r\n Result := CreateComObject(CLASS_WaitCallback) as _WaitCallback;\r\nend;\r\n\r\nclass function CoWaitCallback.CreateRemote(const MachineName: string): _WaitCallback;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_WaitCallback) as _WaitCallback;\r\nend;\r\n\r\nclass function CoWaitOrTimerCallback.Create: _WaitOrTimerCallback;\r\nbegin\r\n Result := CreateComObject(CLASS_WaitOrTimerCallback) as _WaitOrTimerCallback;\r\nend;\r\n\r\nclass function CoWaitOrTimerCallback.CreateRemote(const MachineName: string): _WaitOrTimerCallback;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_WaitOrTimerCallback) as _WaitOrTimerCallback;\r\nend;\r\n\r\nclass function CoIOCompletionCallback.Create: _IOCompletionCallback;\r\nbegin\r\n Result := CreateComObject(CLASS_IOCompletionCallback) as _IOCompletionCallback;\r\nend;\r\n\r\nclass function CoIOCompletionCallback.CreateRemote(const MachineName: string): _IOCompletionCallback;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_IOCompletionCallback) as _IOCompletionCallback;\r\nend;\r\n\r\nclass function CoThreadPool.Create: _ThreadPool;\r\nbegin\r\n Result := CreateComObject(CLASS_ThreadPool) as _ThreadPool;\r\nend;\r\n\r\nclass function CoThreadPool.CreateRemote(const MachineName: string): _ThreadPool;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_ThreadPool) as _ThreadPool;\r\nend;\r\n\r\nclass function CoThreadStart.Create: _ThreadStart;\r\nbegin\r\n Result := CreateComObject(CLASS_ThreadStart) as _ThreadStart;\r\nend;\r\n\r\nclass function CoThreadStart.CreateRemote(const MachineName: string): _ThreadStart;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_ThreadStart) as _ThreadStart;\r\nend;\r\n\r\nclass function CoThreadStateException.Create: _ThreadStateException;\r\nbegin\r\n Result := CreateComObject(CLASS_ThreadStateException) as _ThreadStateException;\r\nend;\r\n\r\nclass function CoThreadStateException.CreateRemote(const MachineName: string): _ThreadStateException;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_ThreadStateException) as _ThreadStateException;\r\nend;\r\n\r\nclass function CoThreadStaticAttribute.Create: _ThreadStaticAttribute;\r\nbegin\r\n Result := CreateComObject(CLASS_ThreadStaticAttribute) as _ThreadStaticAttribute;\r\nend;\r\n\r\nclass function CoThreadStaticAttribute.CreateRemote(const MachineName: string): _ThreadStaticAttribute;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_ThreadStaticAttribute) as _ThreadStaticAttribute;\r\nend;\r\n\r\nclass function CoTimeout.Create: _Timeout;\r\nbegin\r\n Result := CreateComObject(CLASS_Timeout) as _Timeout;\r\nend;\r\n\r\nclass function CoTimeout.CreateRemote(const MachineName: string): _Timeout;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_Timeout) as _Timeout;\r\nend;\r\n\r\nclass function CoTimerCallback.Create: _TimerCallback;\r\nbegin\r\n Result := CreateComObject(CLASS_TimerCallback) as _TimerCallback;\r\nend;\r\n\r\nclass function CoTimerCallback.CreateRemote(const MachineName: string): _TimerCallback;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_TimerCallback) as _TimerCallback;\r\nend;\r\n\r\nclass function CoTimer.Create: _Timer;\r\nbegin\r\n Result := CreateComObject(CLASS_Timer) as _Timer;\r\nend;\r\n\r\nclass function CoTimer.CreateRemote(const MachineName: string): _Timer;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_Timer) as _Timer;\r\nend;\r\n\r\nclass function CoArrayList.Create: _ArrayList;\r\nbegin\r\n Result := CreateComObject(CLASS_ArrayList) as _ArrayList;\r\nend;\r\n\r\nclass function CoArrayList.CreateRemote(const MachineName: string): _ArrayList;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_ArrayList) as _ArrayList;\r\nend;\r\n\r\nclass function CoBitArray.Create: _BitArray;\r\nbegin\r\n Result := CreateComObject(CLASS_BitArray) as _BitArray;\r\nend;\r\n\r\nclass function CoBitArray.CreateRemote(const MachineName: string): _BitArray;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_BitArray) as _BitArray;\r\nend;\r\n\r\nclass function CoCaseInsensitiveComparer.Create: _CaseInsensitiveComparer;\r\nbegin\r\n Result := CreateComObject(CLASS_CaseInsensitiveComparer) as _CaseInsensitiveComparer;\r\nend;\r\n\r\nclass function CoCaseInsensitiveComparer.CreateRemote(const MachineName: string): _CaseInsensitiveComparer;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_CaseInsensitiveComparer) as _CaseInsensitiveComparer;\r\nend;\r\n\r\nclass function CoCaseInsensitiveHashCodeProvider.Create: _CaseInsensitiveHashCodeProvider;\r\nbegin\r\n Result := CreateComObject(CLASS_CaseInsensitiveHashCodeProvider) as _CaseInsensitiveHashCodeProvider;\r\nend;\r\n\r\nclass function CoCaseInsensitiveHashCodeProvider.CreateRemote(const MachineName: string): _CaseInsensitiveHashCodeProvider;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_CaseInsensitiveHashCodeProvider) as _CaseInsensitiveHashCodeProvider;\r\nend;\r\n\r\nclass function CoCollectionBase.Create: _CollectionBase;\r\nbegin\r\n Result := CreateComObject(CLASS_CollectionBase) as _CollectionBase;\r\nend;\r\n\r\nclass function CoCollectionBase.CreateRemote(const MachineName: string): _CollectionBase;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_CollectionBase) as _CollectionBase;\r\nend;\r\n\r\nclass function CoComparer.Create: _Comparer;\r\nbegin\r\n Result := CreateComObject(CLASS_Comparer) as _Comparer;\r\nend;\r\n\r\nclass function CoComparer.CreateRemote(const MachineName: string): _Comparer;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_Comparer) as _Comparer;\r\nend;\r\n\r\nclass function CoDictionaryBase.Create: _DictionaryBase;\r\nbegin\r\n Result := CreateComObject(CLASS_DictionaryBase) as _DictionaryBase;\r\nend;\r\n\r\nclass function CoDictionaryBase.CreateRemote(const MachineName: string): _DictionaryBase;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_DictionaryBase) as _DictionaryBase;\r\nend;\r\n\r\nclass function CoHashtable.Create: _Hashtable;\r\nbegin\r\n Result := CreateComObject(CLASS_Hashtable) as _Hashtable;\r\nend;\r\n\r\nclass function CoHashtable.CreateRemote(const MachineName: string): _Hashtable;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_Hashtable) as _Hashtable;\r\nend;\r\n\r\nclass function CoQueue.Create: _Queue;\r\nbegin\r\n Result := CreateComObject(CLASS_Queue) as _Queue;\r\nend;\r\n\r\nclass function CoQueue.CreateRemote(const MachineName: string): _Queue;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_Queue) as _Queue;\r\nend;\r\n\r\nclass function CoReadOnlyCollectionBase.Create: _ReadOnlyCollectionBase;\r\nbegin\r\n Result := CreateComObject(CLASS_ReadOnlyCollectionBase) as _ReadOnlyCollectionBase;\r\nend;\r\n\r\nclass function CoReadOnlyCollectionBase.CreateRemote(const MachineName: string): _ReadOnlyCollectionBase;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_ReadOnlyCollectionBase) as _ReadOnlyCollectionBase;\r\nend;\r\n\r\nclass function CoSortedList.Create: _SortedList;\r\nbegin\r\n Result := CreateComObject(CLASS_SortedList) as _SortedList;\r\nend;\r\n\r\nclass function CoSortedList.CreateRemote(const MachineName: string): _SortedList;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_SortedList) as _SortedList;\r\nend;\r\n\r\nclass function CoStack.Create: _Stack;\r\nbegin\r\n Result := CreateComObject(CLASS_Stack) as _Stack;\r\nend;\r\n\r\nclass function CoStack.CreateRemote(const MachineName: string): _Stack;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_Stack) as _Stack;\r\nend;\r\n\r\nclass function CoConditionalAttribute.Create: _ConditionalAttribute;\r\nbegin\r\n Result := CreateComObject(CLASS_ConditionalAttribute) as _ConditionalAttribute;\r\nend;\r\n\r\nclass function CoConditionalAttribute.CreateRemote(const MachineName: string): _ConditionalAttribute;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_ConditionalAttribute) as _ConditionalAttribute;\r\nend;\r\n\r\nclass function CoDebugger.Create: _Debugger;\r\nbegin\r\n Result := CreateComObject(CLASS_Debugger) as _Debugger;\r\nend;\r\n\r\nclass function CoDebugger.CreateRemote(const MachineName: string): _Debugger;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_Debugger) as _Debugger;\r\nend;\r\n\r\nclass function CoDebuggerStepThroughAttribute.Create: _DebuggerStepThroughAttribute;\r\nbegin\r\n Result := CreateComObject(CLASS_DebuggerStepThroughAttribute) as _DebuggerStepThroughAttribute;\r\nend;\r\n\r\nclass function CoDebuggerStepThroughAttribute.CreateRemote(const MachineName: string): _DebuggerStepThroughAttribute;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_DebuggerStepThroughAttribute) as _DebuggerStepThroughAttribute;\r\nend;\r\n\r\nclass function CoDebuggerHiddenAttribute.Create: _DebuggerHiddenAttribute;\r\nbegin\r\n Result := CreateComObject(CLASS_DebuggerHiddenAttribute) as _DebuggerHiddenAttribute;\r\nend;\r\n\r\nclass function CoDebuggerHiddenAttribute.CreateRemote(const MachineName: string): _DebuggerHiddenAttribute;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_DebuggerHiddenAttribute) as _DebuggerHiddenAttribute;\r\nend;\r\n\r\nclass function CoDebuggableAttribute.Create: _DebuggableAttribute;\r\nbegin\r\n Result := CreateComObject(CLASS_DebuggableAttribute) as _DebuggableAttribute;\r\nend;\r\n\r\nclass function CoDebuggableAttribute.CreateRemote(const MachineName: string): _DebuggableAttribute;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_DebuggableAttribute) as _DebuggableAttribute;\r\nend;\r\n\r\nclass function CoStackTrace.Create: _StackTrace;\r\nbegin\r\n Result := CreateComObject(CLASS_StackTrace) as _StackTrace;\r\nend;\r\n\r\nclass function CoStackTrace.CreateRemote(const MachineName: string): _StackTrace;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_StackTrace) as _StackTrace;\r\nend;\r\n\r\nclass function CoStackFrame.Create: _StackFrame;\r\nbegin\r\n Result := CreateComObject(CLASS_StackFrame) as _StackFrame;\r\nend;\r\n\r\nclass function CoStackFrame.CreateRemote(const MachineName: string): _StackFrame;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_StackFrame) as _StackFrame;\r\nend;\r\n\r\nclass function CoSymDocumentType.Create: _SymDocumentType;\r\nbegin\r\n Result := CreateComObject(CLASS_SymDocumentType) as _SymDocumentType;\r\nend;\r\n\r\nclass function CoSymDocumentType.CreateRemote(const MachineName: string): _SymDocumentType;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_SymDocumentType) as _SymDocumentType;\r\nend;\r\n\r\nclass function CoSymLanguageType.Create: _SymLanguageType;\r\nbegin\r\n Result := CreateComObject(CLASS_SymLanguageType) as _SymLanguageType;\r\nend;\r\n\r\nclass function CoSymLanguageType.CreateRemote(const MachineName: string): _SymLanguageType;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_SymLanguageType) as _SymLanguageType;\r\nend;\r\n\r\nclass function CoSymLanguageVendor.Create: _SymLanguageVendor;\r\nbegin\r\n Result := CreateComObject(CLASS_SymLanguageVendor) as _SymLanguageVendor;\r\nend;\r\n\r\nclass function CoSymLanguageVendor.CreateRemote(const MachineName: string): _SymLanguageVendor;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_SymLanguageVendor) as _SymLanguageVendor;\r\nend;\r\n\r\nclass function CoAmbiguousMatchException.Create: _AmbiguousMatchException;\r\nbegin\r\n Result := CreateComObject(CLASS_AmbiguousMatchException) as _AmbiguousMatchException;\r\nend;\r\n\r\nclass function CoAmbiguousMatchException.CreateRemote(const MachineName: string): _AmbiguousMatchException;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_AmbiguousMatchException) as _AmbiguousMatchException;\r\nend;\r\n\r\nclass function CoModuleResolveEventHandler.Create: _ModuleResolveEventHandler;\r\nbegin\r\n Result := CreateComObject(CLASS_ModuleResolveEventHandler) as _ModuleResolveEventHandler;\r\nend;\r\n\r\nclass function CoModuleResolveEventHandler.CreateRemote(const MachineName: string): _ModuleResolveEventHandler;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_ModuleResolveEventHandler) as _ModuleResolveEventHandler;\r\nend;\r\n\r\nclass function CoAssembly.Create: _Assembly;\r\nbegin\r\n Result := CreateComObject(CLASS_Assembly) as _Assembly;\r\nend;\r\n\r\nclass function CoAssembly.CreateRemote(const MachineName: string): _Assembly;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_Assembly) as _Assembly;\r\nend;\r\n\r\nclass function CoAssemblyCultureAttribute.Create: _AssemblyCultureAttribute;\r\nbegin\r\n Result := CreateComObject(CLASS_AssemblyCultureAttribute) as _AssemblyCultureAttribute;\r\nend;\r\n\r\nclass function CoAssemblyCultureAttribute.CreateRemote(const MachineName: string): _AssemblyCultureAttribute;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_AssemblyCultureAttribute) as _AssemblyCultureAttribute;\r\nend;\r\n\r\nclass function CoAssemblyVersionAttribute.Create: _AssemblyVersionAttribute;\r\nbegin\r\n Result := CreateComObject(CLASS_AssemblyVersionAttribute) as _AssemblyVersionAttribute;\r\nend;\r\n\r\nclass function CoAssemblyVersionAttribute.CreateRemote(const MachineName: string): _AssemblyVersionAttribute;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_AssemblyVersionAttribute) as _AssemblyVersionAttribute;\r\nend;\r\n\r\nclass function CoAssemblyKeyFileAttribute.Create: _AssemblyKeyFileAttribute;\r\nbegin\r\n Result := CreateComObject(CLASS_AssemblyKeyFileAttribute) as _AssemblyKeyFileAttribute;\r\nend;\r\n\r\nclass function CoAssemblyKeyFileAttribute.CreateRemote(const MachineName: string): _AssemblyKeyFileAttribute;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_AssemblyKeyFileAttribute) as _AssemblyKeyFileAttribute;\r\nend;\r\n\r\nclass function CoAssemblyKeyNameAttribute.Create: _AssemblyKeyNameAttribute;\r\nbegin\r\n Result := CreateComObject(CLASS_AssemblyKeyNameAttribute) as _AssemblyKeyNameAttribute;\r\nend;\r\n\r\nclass function CoAssemblyKeyNameAttribute.CreateRemote(const MachineName: string): _AssemblyKeyNameAttribute;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_AssemblyKeyNameAttribute) as _AssemblyKeyNameAttribute;\r\nend;\r\n\r\nclass function CoAssemblyDelaySignAttribute.Create: _AssemblyDelaySignAttribute;\r\nbegin\r\n Result := CreateComObject(CLASS_AssemblyDelaySignAttribute) as _AssemblyDelaySignAttribute;\r\nend;\r\n\r\nclass function CoAssemblyDelaySignAttribute.CreateRemote(const MachineName: string): _AssemblyDelaySignAttribute;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_AssemblyDelaySignAttribute) as _AssemblyDelaySignAttribute;\r\nend;\r\n\r\nclass function CoAssemblyAlgorithmIdAttribute.Create: _AssemblyAlgorithmIdAttribute;\r\nbegin\r\n Result := CreateComObject(CLASS_AssemblyAlgorithmIdAttribute) as _AssemblyAlgorithmIdAttribute;\r\nend;\r\n\r\nclass function CoAssemblyAlgorithmIdAttribute.CreateRemote(const MachineName: string): _AssemblyAlgorithmIdAttribute;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_AssemblyAlgorithmIdAttribute) as _AssemblyAlgorithmIdAttribute;\r\nend;\r\n\r\nclass function CoAssemblyFlagsAttribute.Create: _AssemblyFlagsAttribute;\r\nbegin\r\n Result := CreateComObject(CLASS_AssemblyFlagsAttribute) as _AssemblyFlagsAttribute;\r\nend;\r\n\r\nclass function CoAssemblyFlagsAttribute.CreateRemote(const MachineName: string): _AssemblyFlagsAttribute;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_AssemblyFlagsAttribute) as _AssemblyFlagsAttribute;\r\nend;\r\n\r\nclass function CoAssemblyFileVersionAttribute.Create: _AssemblyFileVersionAttribute;\r\nbegin\r\n Result := CreateComObject(CLASS_AssemblyFileVersionAttribute) as _AssemblyFileVersionAttribute;\r\nend;\r\n\r\nclass function CoAssemblyFileVersionAttribute.CreateRemote(const MachineName: string): _AssemblyFileVersionAttribute;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_AssemblyFileVersionAttribute) as _AssemblyFileVersionAttribute;\r\nend;\r\n\r\nclass function CoAssemblyName.Create: _AssemblyName;\r\nbegin\r\n Result := CreateComObject(CLASS_AssemblyName) as _AssemblyName;\r\nend;\r\n\r\nclass function CoAssemblyName.CreateRemote(const MachineName: string): _AssemblyName;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_AssemblyName) as _AssemblyName;\r\nend;\r\n\r\nclass function CoAssemblyNameProxy.Create: _AssemblyNameProxy;\r\nbegin\r\n Result := CreateComObject(CLASS_AssemblyNameProxy) as _AssemblyNameProxy;\r\nend;\r\n\r\nclass function CoAssemblyNameProxy.CreateRemote(const MachineName: string): _AssemblyNameProxy;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_AssemblyNameProxy) as _AssemblyNameProxy;\r\nend;\r\n\r\nclass function CoAssemblyCopyrightAttribute.Create: _AssemblyCopyrightAttribute;\r\nbegin\r\n Result := CreateComObject(CLASS_AssemblyCopyrightAttribute) as _AssemblyCopyrightAttribute;\r\nend;\r\n\r\nclass function CoAssemblyCopyrightAttribute.CreateRemote(const MachineName: string): _AssemblyCopyrightAttribute;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_AssemblyCopyrightAttribute) as _AssemblyCopyrightAttribute;\r\nend;\r\n\r\nclass function CoAssemblyTrademarkAttribute.Create: _AssemblyTrademarkAttribute;\r\nbegin\r\n Result := CreateComObject(CLASS_AssemblyTrademarkAttribute) as _AssemblyTrademarkAttribute;\r\nend;\r\n\r\nclass function CoAssemblyTrademarkAttribute.CreateRemote(const MachineName: string): _AssemblyTrademarkAttribute;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_AssemblyTrademarkAttribute) as _AssemblyTrademarkAttribute;\r\nend;\r\n\r\nclass function CoAssemblyProductAttribute.Create: _AssemblyProductAttribute;\r\nbegin\r\n Result := CreateComObject(CLASS_AssemblyProductAttribute) as _AssemblyProductAttribute;\r\nend;\r\n\r\nclass function CoAssemblyProductAttribute.CreateRemote(const MachineName: string): _AssemblyProductAttribute;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_AssemblyProductAttribute) as _AssemblyProductAttribute;\r\nend;\r\n\r\nclass function CoAssemblyCompanyAttribute.Create: _AssemblyCompanyAttribute;\r\nbegin\r\n Result := CreateComObject(CLASS_AssemblyCompanyAttribute) as _AssemblyCompanyAttribute;\r\nend;\r\n\r\nclass function CoAssemblyCompanyAttribute.CreateRemote(const MachineName: string): _AssemblyCompanyAttribute;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_AssemblyCompanyAttribute) as _AssemblyCompanyAttribute;\r\nend;\r\n\r\nclass function CoAssemblyDescriptionAttribute.Create: _AssemblyDescriptionAttribute;\r\nbegin\r\n Result := CreateComObject(CLASS_AssemblyDescriptionAttribute) as _AssemblyDescriptionAttribute;\r\nend;\r\n\r\nclass function CoAssemblyDescriptionAttribute.CreateRemote(const MachineName: string): _AssemblyDescriptionAttribute;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_AssemblyDescriptionAttribute) as _AssemblyDescriptionAttribute;\r\nend;\r\n\r\nclass function CoAssemblyTitleAttribute.Create: _AssemblyTitleAttribute;\r\nbegin\r\n Result := CreateComObject(CLASS_AssemblyTitleAttribute) as _AssemblyTitleAttribute;\r\nend;\r\n\r\nclass function CoAssemblyTitleAttribute.CreateRemote(const MachineName: string): _AssemblyTitleAttribute;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_AssemblyTitleAttribute) as _AssemblyTitleAttribute;\r\nend;\r\n\r\nclass function CoAssemblyConfigurationAttribute.Create: _AssemblyConfigurationAttribute;\r\nbegin\r\n Result := CreateComObject(CLASS_AssemblyConfigurationAttribute) as _AssemblyConfigurationAttribute;\r\nend;\r\n\r\nclass function CoAssemblyConfigurationAttribute.CreateRemote(const MachineName: string): _AssemblyConfigurationAttribute;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_AssemblyConfigurationAttribute) as _AssemblyConfigurationAttribute;\r\nend;\r\n\r\nclass function CoAssemblyDefaultAliasAttribute.Create: _AssemblyDefaultAliasAttribute;\r\nbegin\r\n Result := CreateComObject(CLASS_AssemblyDefaultAliasAttribute) as _AssemblyDefaultAliasAttribute;\r\nend;\r\n\r\nclass function CoAssemblyDefaultAliasAttribute.CreateRemote(const MachineName: string): _AssemblyDefaultAliasAttribute;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_AssemblyDefaultAliasAttribute) as _AssemblyDefaultAliasAttribute;\r\nend;\r\n\r\nclass function CoAssemblyInformationalVersionAttribute.Create: _AssemblyInformationalVersionAttribute;\r\nbegin\r\n Result := CreateComObject(CLASS_AssemblyInformationalVersionAttribute) as _AssemblyInformationalVersionAttribute;\r\nend;\r\n\r\nclass function CoAssemblyInformationalVersionAttribute.CreateRemote(const MachineName: string): _AssemblyInformationalVersionAttribute;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_AssemblyInformationalVersionAttribute) as _AssemblyInformationalVersionAttribute;\r\nend;\r\n\r\nclass function CoCustomAttributeFormatException.Create: _CustomAttributeFormatException;\r\nbegin\r\n Result := CreateComObject(CLASS_CustomAttributeFormatException) as _CustomAttributeFormatException;\r\nend;\r\n\r\nclass function CoCustomAttributeFormatException.CreateRemote(const MachineName: string): _CustomAttributeFormatException;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_CustomAttributeFormatException) as _CustomAttributeFormatException;\r\nend;\r\n\r\nclass function CoMethodBase.Create: _MethodBase;\r\nbegin\r\n Result := CreateComObject(CLASS_MethodBase) as _MethodBase;\r\nend;\r\n\r\nclass function CoMethodBase.CreateRemote(const MachineName: string): _MethodBase;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_MethodBase) as _MethodBase;\r\nend;\r\n\r\nclass function CoConstructorInfo.Create: _ConstructorInfo;\r\nbegin\r\n Result := CreateComObject(CLASS_ConstructorInfo) as _ConstructorInfo;\r\nend;\r\n\r\nclass function CoConstructorInfo.CreateRemote(const MachineName: string): _ConstructorInfo;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_ConstructorInfo) as _ConstructorInfo;\r\nend;\r\n\r\nclass function CoDefaultMemberAttribute.Create: _DefaultMemberAttribute;\r\nbegin\r\n Result := CreateComObject(CLASS_DefaultMemberAttribute) as _DefaultMemberAttribute;\r\nend;\r\n\r\nclass function CoDefaultMemberAttribute.CreateRemote(const MachineName: string): _DefaultMemberAttribute;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_DefaultMemberAttribute) as _DefaultMemberAttribute;\r\nend;\r\n\r\nclass function CoEventInfo.Create: _EventInfo;\r\nbegin\r\n Result := CreateComObject(CLASS_EventInfo) as _EventInfo;\r\nend;\r\n\r\nclass function CoEventInfo.CreateRemote(const MachineName: string): _EventInfo;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_EventInfo) as _EventInfo;\r\nend;\r\n\r\nclass function CoFieldInfo.Create: _FieldInfo;\r\nbegin\r\n Result := CreateComObject(CLASS_FieldInfo) as _FieldInfo;\r\nend;\r\n\r\nclass function CoFieldInfo.CreateRemote(const MachineName: string): _FieldInfo;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_FieldInfo) as _FieldInfo;\r\nend;\r\n\r\nclass function CoInvalidFilterCriteriaException.Create: _InvalidFilterCriteriaException;\r\nbegin\r\n Result := CreateComObject(CLASS_InvalidFilterCriteriaException) as _InvalidFilterCriteriaException;\r\nend;\r\n\r\nclass function CoInvalidFilterCriteriaException.CreateRemote(const MachineName: string): _InvalidFilterCriteriaException;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_InvalidFilterCriteriaException) as _InvalidFilterCriteriaException;\r\nend;\r\n\r\nclass function CoManifestResourceInfo.Create: _ManifestResourceInfo;\r\nbegin\r\n Result := CreateComObject(CLASS_ManifestResourceInfo) as _ManifestResourceInfo;\r\nend;\r\n\r\nclass function CoManifestResourceInfo.CreateRemote(const MachineName: string): _ManifestResourceInfo;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_ManifestResourceInfo) as _ManifestResourceInfo;\r\nend;\r\n\r\nclass function CoMemberFilter.Create: _MemberFilter;\r\nbegin\r\n Result := CreateComObject(CLASS_MemberFilter) as _MemberFilter;\r\nend;\r\n\r\nclass function CoMemberFilter.CreateRemote(const MachineName: string): _MemberFilter;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_MemberFilter) as _MemberFilter;\r\nend;\r\n\r\nclass function CoMethodInfo.Create: _MethodInfo;\r\nbegin\r\n Result := CreateComObject(CLASS_MethodInfo) as _MethodInfo;\r\nend;\r\n\r\nclass function CoMethodInfo.CreateRemote(const MachineName: string): _MethodInfo;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_MethodInfo) as _MethodInfo;\r\nend;\r\n\r\nclass function CoMissing.Create: _Missing;\r\nbegin\r\n Result := CreateComObject(CLASS_Missing) as _Missing;\r\nend;\r\n\r\nclass function CoMissing.CreateRemote(const MachineName: string): _Missing;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_Missing) as _Missing;\r\nend;\r\n\r\nclass function CoModule.Create: _Module;\r\nbegin\r\n Result := CreateComObject(CLASS_Module) as _Module;\r\nend;\r\n\r\nclass function CoModule.CreateRemote(const MachineName: string): _Module;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_Module) as _Module;\r\nend;\r\n\r\nclass function CoParameterInfo.Create: _ParameterInfo;\r\nbegin\r\n Result := CreateComObject(CLASS_ParameterInfo) as _ParameterInfo;\r\nend;\r\n\r\nclass function CoParameterInfo.CreateRemote(const MachineName: string): _ParameterInfo;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_ParameterInfo) as _ParameterInfo;\r\nend;\r\n\r\nclass function CoPointer.Create: _Pointer;\r\nbegin\r\n Result := CreateComObject(CLASS_Pointer) as _Pointer;\r\nend;\r\n\r\nclass function CoPointer.CreateRemote(const MachineName: string): _Pointer;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_Pointer) as _Pointer;\r\nend;\r\n\r\nclass function CoPropertyInfo.Create: _PropertyInfo;\r\nbegin\r\n Result := CreateComObject(CLASS_PropertyInfo) as _PropertyInfo;\r\nend;\r\n\r\nclass function CoPropertyInfo.CreateRemote(const MachineName: string): _PropertyInfo;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_PropertyInfo) as _PropertyInfo;\r\nend;\r\n\r\nclass function CoReflectionTypeLoadException.Create: _ReflectionTypeLoadException;\r\nbegin\r\n Result := CreateComObject(CLASS_ReflectionTypeLoadException) as _ReflectionTypeLoadException;\r\nend;\r\n\r\nclass function CoReflectionTypeLoadException.CreateRemote(const MachineName: string): _ReflectionTypeLoadException;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_ReflectionTypeLoadException) as _ReflectionTypeLoadException;\r\nend;\r\n\r\nclass function CoStrongNameKeyPair.Create: _StrongNameKeyPair;\r\nbegin\r\n Result := CreateComObject(CLASS_StrongNameKeyPair) as _StrongNameKeyPair;\r\nend;\r\n\r\nclass function CoStrongNameKeyPair.CreateRemote(const MachineName: string): _StrongNameKeyPair;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_StrongNameKeyPair) as _StrongNameKeyPair;\r\nend;\r\n\r\nclass function CoTargetException.Create: _TargetException;\r\nbegin\r\n Result := CreateComObject(CLASS_TargetException) as _TargetException;\r\nend;\r\n\r\nclass function CoTargetException.CreateRemote(const MachineName: string): _TargetException;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_TargetException) as _TargetException;\r\nend;\r\n\r\nclass function CoTargetInvocationException.Create: _TargetInvocationException;\r\nbegin\r\n Result := CreateComObject(CLASS_TargetInvocationException) as _TargetInvocationException;\r\nend;\r\n\r\nclass function CoTargetInvocationException.CreateRemote(const MachineName: string): _TargetInvocationException;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_TargetInvocationException) as _TargetInvocationException;\r\nend;\r\n\r\nclass function CoTargetParameterCountException.Create: _TargetParameterCountException;\r\nbegin\r\n Result := CreateComObject(CLASS_TargetParameterCountException) as _TargetParameterCountException;\r\nend;\r\n\r\nclass function CoTargetParameterCountException.CreateRemote(const MachineName: string): _TargetParameterCountException;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_TargetParameterCountException) as _TargetParameterCountException;\r\nend;\r\n\r\nclass function CoTypeDelegator.Create: _TypeDelegator;\r\nbegin\r\n Result := CreateComObject(CLASS_TypeDelegator) as _TypeDelegator;\r\nend;\r\n\r\nclass function CoTypeDelegator.CreateRemote(const MachineName: string): _TypeDelegator;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_TypeDelegator) as _TypeDelegator;\r\nend;\r\n\r\nclass function CoTypeFilter.Create: _TypeFilter;\r\nbegin\r\n Result := CreateComObject(CLASS_TypeFilter) as _TypeFilter;\r\nend;\r\n\r\nclass function CoTypeFilter.CreateRemote(const MachineName: string): _TypeFilter;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_TypeFilter) as _TypeFilter;\r\nend;\r\n\r\nclass function CoUnmanagedMarshal.Create: _UnmanagedMarshal;\r\nbegin\r\n Result := CreateComObject(CLASS_UnmanagedMarshal) as _UnmanagedMarshal;\r\nend;\r\n\r\nclass function CoUnmanagedMarshal.CreateRemote(const MachineName: string): _UnmanagedMarshal;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_UnmanagedMarshal) as _UnmanagedMarshal;\r\nend;\r\n\r\nclass function CoFormatter.Create: _Formatter;\r\nbegin\r\n Result := CreateComObject(CLASS_Formatter) as _Formatter;\r\nend;\r\n\r\nclass function CoFormatter.CreateRemote(const MachineName: string): _Formatter;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_Formatter) as _Formatter;\r\nend;\r\n\r\nclass function CoFormatterConverter.Create: _FormatterConverter;\r\nbegin\r\n Result := CreateComObject(CLASS_FormatterConverter) as _FormatterConverter;\r\nend;\r\n\r\nclass function CoFormatterConverter.CreateRemote(const MachineName: string): _FormatterConverter;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_FormatterConverter) as _FormatterConverter;\r\nend;\r\n\r\nclass function CoFormatterServices.Create: _FormatterServices;\r\nbegin\r\n Result := CreateComObject(CLASS_FormatterServices) as _FormatterServices;\r\nend;\r\n\r\nclass function CoFormatterServices.CreateRemote(const MachineName: string): _FormatterServices;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_FormatterServices) as _FormatterServices;\r\nend;\r\n\r\nclass function CoObjectIDGenerator.Create: _ObjectIDGenerator;\r\nbegin\r\n Result := CreateComObject(CLASS_ObjectIDGenerator) as _ObjectIDGenerator;\r\nend;\r\n\r\nclass function CoObjectIDGenerator.CreateRemote(const MachineName: string): _ObjectIDGenerator;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_ObjectIDGenerator) as _ObjectIDGenerator;\r\nend;\r\n\r\nclass function CoObjectManager.Create: _ObjectManager;\r\nbegin\r\n Result := CreateComObject(CLASS_ObjectManager) as _ObjectManager;\r\nend;\r\n\r\nclass function CoObjectManager.CreateRemote(const MachineName: string): _ObjectManager;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_ObjectManager) as _ObjectManager;\r\nend;\r\n\r\nclass function CoSerializationBinder.Create: _SerializationBinder;\r\nbegin\r\n Result := CreateComObject(CLASS_SerializationBinder) as _SerializationBinder;\r\nend;\r\n\r\nclass function CoSerializationBinder.CreateRemote(const MachineName: string): _SerializationBinder;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_SerializationBinder) as _SerializationBinder;\r\nend;\r\n\r\nclass function CoSerializationInfo.Create: _SerializationInfo;\r\nbegin\r\n Result := CreateComObject(CLASS_SerializationInfo) as _SerializationInfo;\r\nend;\r\n\r\nclass function CoSerializationInfo.CreateRemote(const MachineName: string): _SerializationInfo;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_SerializationInfo) as _SerializationInfo;\r\nend;\r\n\r\nclass function CoSerializationInfoEnumerator.Create: _SerializationInfoEnumerator;\r\nbegin\r\n Result := CreateComObject(CLASS_SerializationInfoEnumerator) as _SerializationInfoEnumerator;\r\nend;\r\n\r\nclass function CoSerializationInfoEnumerator.CreateRemote(const MachineName: string): _SerializationInfoEnumerator;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_SerializationInfoEnumerator) as _SerializationInfoEnumerator;\r\nend;\r\n\r\nclass function CoSerializationException.Create: _SerializationException;\r\nbegin\r\n Result := CreateComObject(CLASS_SerializationException) as _SerializationException;\r\nend;\r\n\r\nclass function CoSerializationException.CreateRemote(const MachineName: string): _SerializationException;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_SerializationException) as _SerializationException;\r\nend;\r\n\r\nclass function CoSurrogateSelector.Create: _SurrogateSelector;\r\nbegin\r\n Result := CreateComObject(CLASS_SurrogateSelector) as _SurrogateSelector;\r\nend;\r\n\r\nclass function CoSurrogateSelector.CreateRemote(const MachineName: string): _SurrogateSelector;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_SurrogateSelector) as _SurrogateSelector;\r\nend;\r\n\r\nclass function CoCalendar.Create: _Calendar;\r\nbegin\r\n Result := CreateComObject(CLASS_Calendar) as _Calendar;\r\nend;\r\n\r\nclass function CoCalendar.CreateRemote(const MachineName: string): _Calendar;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_Calendar) as _Calendar;\r\nend;\r\n\r\nclass function CoCompareInfo.Create: _CompareInfo;\r\nbegin\r\n Result := CreateComObject(CLASS_CompareInfo) as _CompareInfo;\r\nend;\r\n\r\nclass function CoCompareInfo.CreateRemote(const MachineName: string): _CompareInfo;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_CompareInfo) as _CompareInfo;\r\nend;\r\n\r\nclass function CoCultureInfo.Create: _CultureInfo;\r\nbegin\r\n Result := CreateComObject(CLASS_CultureInfo) as _CultureInfo;\r\nend;\r\n\r\nclass function CoCultureInfo.CreateRemote(const MachineName: string): _CultureInfo;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_CultureInfo) as _CultureInfo;\r\nend;\r\n\r\nclass function CoDateTimeFormatInfo.Create: _DateTimeFormatInfo;\r\nbegin\r\n Result := CreateComObject(CLASS_DateTimeFormatInfo) as _DateTimeFormatInfo;\r\nend;\r\n\r\nclass function CoDateTimeFormatInfo.CreateRemote(const MachineName: string): _DateTimeFormatInfo;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_DateTimeFormatInfo) as _DateTimeFormatInfo;\r\nend;\r\n\r\nclass function CoDaylightTime.Create: _DaylightTime;\r\nbegin\r\n Result := CreateComObject(CLASS_DaylightTime) as _DaylightTime;\r\nend;\r\n\r\nclass function CoDaylightTime.CreateRemote(const MachineName: string): _DaylightTime;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_DaylightTime) as _DaylightTime;\r\nend;\r\n\r\nclass function CoGregorianCalendar.Create: _GregorianCalendar;\r\nbegin\r\n Result := CreateComObject(CLASS_GregorianCalendar) as _GregorianCalendar;\r\nend;\r\n\r\nclass function CoGregorianCalendar.CreateRemote(const MachineName: string): _GregorianCalendar;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_GregorianCalendar) as _GregorianCalendar;\r\nend;\r\n\r\nclass function CoHebrewCalendar.Create: _HebrewCalendar;\r\nbegin\r\n Result := CreateComObject(CLASS_HebrewCalendar) as _HebrewCalendar;\r\nend;\r\n\r\nclass function CoHebrewCalendar.CreateRemote(const MachineName: string): _HebrewCalendar;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_HebrewCalendar) as _HebrewCalendar;\r\nend;\r\n\r\nclass function CoHijriCalendar.Create: _HijriCalendar;\r\nbegin\r\n Result := CreateComObject(CLASS_HijriCalendar) as _HijriCalendar;\r\nend;\r\n\r\nclass function CoHijriCalendar.CreateRemote(const MachineName: string): _HijriCalendar;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_HijriCalendar) as _HijriCalendar;\r\nend;\r\n\r\nclass function CoJapaneseCalendar.Create: _JapaneseCalendar;\r\nbegin\r\n Result := CreateComObject(CLASS_JapaneseCalendar) as _JapaneseCalendar;\r\nend;\r\n\r\nclass function CoJapaneseCalendar.CreateRemote(const MachineName: string): _JapaneseCalendar;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_JapaneseCalendar) as _JapaneseCalendar;\r\nend;\r\n\r\nclass function CoJulianCalendar.Create: _JulianCalendar;\r\nbegin\r\n Result := CreateComObject(CLASS_JulianCalendar) as _JulianCalendar;\r\nend;\r\n\r\nclass function CoJulianCalendar.CreateRemote(const MachineName: string): _JulianCalendar;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_JulianCalendar) as _JulianCalendar;\r\nend;\r\n\r\nclass function CoKoreanCalendar.Create: _KoreanCalendar;\r\nbegin\r\n Result := CreateComObject(CLASS_KoreanCalendar) as _KoreanCalendar;\r\nend;\r\n\r\nclass function CoKoreanCalendar.CreateRemote(const MachineName: string): _KoreanCalendar;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_KoreanCalendar) as _KoreanCalendar;\r\nend;\r\n\r\nclass function CoRegionInfo.Create: _RegionInfo;\r\nbegin\r\n Result := CreateComObject(CLASS_RegionInfo) as _RegionInfo;\r\nend;\r\n\r\nclass function CoRegionInfo.CreateRemote(const MachineName: string): _RegionInfo;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_RegionInfo) as _RegionInfo;\r\nend;\r\n\r\nclass function CoSortKey.Create: _SortKey;\r\nbegin\r\n Result := CreateComObject(CLASS_SortKey) as _SortKey;\r\nend;\r\n\r\nclass function CoSortKey.CreateRemote(const MachineName: string): _SortKey;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_SortKey) as _SortKey;\r\nend;\r\n\r\nclass function CoStringInfo.Create: _StringInfo;\r\nbegin\r\n Result := CreateComObject(CLASS_StringInfo) as _StringInfo;\r\nend;\r\n\r\nclass function CoStringInfo.CreateRemote(const MachineName: string): _StringInfo;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_StringInfo) as _StringInfo;\r\nend;\r\n\r\nclass function CoTaiwanCalendar.Create: _TaiwanCalendar;\r\nbegin\r\n Result := CreateComObject(CLASS_TaiwanCalendar) as _TaiwanCalendar;\r\nend;\r\n\r\nclass function CoTaiwanCalendar.CreateRemote(const MachineName: string): _TaiwanCalendar;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_TaiwanCalendar) as _TaiwanCalendar;\r\nend;\r\n\r\nclass function CoTextElementEnumerator.Create: _TextElementEnumerator;\r\nbegin\r\n Result := CreateComObject(CLASS_TextElementEnumerator) as _TextElementEnumerator;\r\nend;\r\n\r\nclass function CoTextElementEnumerator.CreateRemote(const MachineName: string): _TextElementEnumerator;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_TextElementEnumerator) as _TextElementEnumerator;\r\nend;\r\n\r\nclass function CoTextInfo.Create: _TextInfo;\r\nbegin\r\n Result := CreateComObject(CLASS_TextInfo) as _TextInfo;\r\nend;\r\n\r\nclass function CoTextInfo.CreateRemote(const MachineName: string): _TextInfo;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_TextInfo) as _TextInfo;\r\nend;\r\n\r\nclass function CoThaiBuddhistCalendar.Create: _ThaiBuddhistCalendar;\r\nbegin\r\n Result := CreateComObject(CLASS_ThaiBuddhistCalendar) as _ThaiBuddhistCalendar;\r\nend;\r\n\r\nclass function CoThaiBuddhistCalendar.CreateRemote(const MachineName: string): _ThaiBuddhistCalendar;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_ThaiBuddhistCalendar) as _ThaiBuddhistCalendar;\r\nend;\r\n\r\nclass function CoNumberFormatInfo.Create: _NumberFormatInfo;\r\nbegin\r\n Result := CreateComObject(CLASS_NumberFormatInfo) as _NumberFormatInfo;\r\nend;\r\n\r\nclass function CoNumberFormatInfo.CreateRemote(const MachineName: string): _NumberFormatInfo;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_NumberFormatInfo) as _NumberFormatInfo;\r\nend;\r\n\r\nclass function CoEncoding.Create: _Encoding;\r\nbegin\r\n Result := CreateComObject(CLASS_Encoding) as _Encoding;\r\nend;\r\n\r\nclass function CoEncoding.CreateRemote(const MachineName: string): _Encoding;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_Encoding) as _Encoding;\r\nend;\r\n\r\nclass function CoSystem_Text_Decoder.Create: _System_Text_Decoder;\r\nbegin\r\n Result := CreateComObject(CLASS_System_Text_Decoder) as _System_Text_Decoder;\r\nend;\r\n\r\nclass function CoSystem_Text_Decoder.CreateRemote(const MachineName: string): _System_Text_Decoder;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_System_Text_Decoder) as _System_Text_Decoder;\r\nend;\r\n\r\nclass function CoSystem_Text_Encoder.Create: _System_Text_Encoder;\r\nbegin\r\n Result := CreateComObject(CLASS_System_Text_Encoder) as _System_Text_Encoder;\r\nend;\r\n\r\nclass function CoSystem_Text_Encoder.CreateRemote(const MachineName: string): _System_Text_Encoder;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_System_Text_Encoder) as _System_Text_Encoder;\r\nend;\r\n\r\nclass function CoASCIIEncoding.Create: _ASCIIEncoding;\r\nbegin\r\n Result := CreateComObject(CLASS_ASCIIEncoding) as _ASCIIEncoding;\r\nend;\r\n\r\nclass function CoASCIIEncoding.CreateRemote(const MachineName: string): _ASCIIEncoding;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_ASCIIEncoding) as _ASCIIEncoding;\r\nend;\r\n\r\nclass function CoUnicodeEncoding.Create: _UnicodeEncoding;\r\nbegin\r\n Result := CreateComObject(CLASS_UnicodeEncoding) as _UnicodeEncoding;\r\nend;\r\n\r\nclass function CoUnicodeEncoding.CreateRemote(const MachineName: string): _UnicodeEncoding;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_UnicodeEncoding) as _UnicodeEncoding;\r\nend;\r\n\r\nclass function CoUTF7Encoding.Create: _UTF7Encoding;\r\nbegin\r\n Result := CreateComObject(CLASS_UTF7Encoding) as _UTF7Encoding;\r\nend;\r\n\r\nclass function CoUTF7Encoding.CreateRemote(const MachineName: string): _UTF7Encoding;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_UTF7Encoding) as _UTF7Encoding;\r\nend;\r\n\r\nclass function CoUTF8Encoding.Create: _UTF8Encoding;\r\nbegin\r\n Result := CreateComObject(CLASS_UTF8Encoding) as _UTF8Encoding;\r\nend;\r\n\r\nclass function CoUTF8Encoding.CreateRemote(const MachineName: string): _UTF8Encoding;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_UTF8Encoding) as _UTF8Encoding;\r\nend;\r\n\r\nclass function CoMissingManifestResourceException.Create: _MissingManifestResourceException;\r\nbegin\r\n Result := CreateComObject(CLASS_MissingManifestResourceException) as _MissingManifestResourceException;\r\nend;\r\n\r\nclass function CoMissingManifestResourceException.CreateRemote(const MachineName: string): _MissingManifestResourceException;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_MissingManifestResourceException) as _MissingManifestResourceException;\r\nend;\r\n\r\nclass function CoNeutralResourcesLanguageAttribute.Create: _NeutralResourcesLanguageAttribute;\r\nbegin\r\n Result := CreateComObject(CLASS_NeutralResourcesLanguageAttribute) as _NeutralResourcesLanguageAttribute;\r\nend;\r\n\r\nclass function CoNeutralResourcesLanguageAttribute.CreateRemote(const MachineName: string): _NeutralResourcesLanguageAttribute;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_NeutralResourcesLanguageAttribute) as _NeutralResourcesLanguageAttribute;\r\nend;\r\n\r\nclass function CoResourceManager.Create: _ResourceManager;\r\nbegin\r\n Result := CreateComObject(CLASS_ResourceManager) as _ResourceManager;\r\nend;\r\n\r\nclass function CoResourceManager.CreateRemote(const MachineName: string): _ResourceManager;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_ResourceManager) as _ResourceManager;\r\nend;\r\n\r\nclass function CoResourceReader.Create: _ResourceReader;\r\nbegin\r\n Result := CreateComObject(CLASS_ResourceReader) as _ResourceReader;\r\nend;\r\n\r\nclass function CoResourceReader.CreateRemote(const MachineName: string): _ResourceReader;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_ResourceReader) as _ResourceReader;\r\nend;\r\n\r\nclass function CoResourceSet.Create: _ResourceSet;\r\nbegin\r\n Result := CreateComObject(CLASS_ResourceSet) as _ResourceSet;\r\nend;\r\n\r\nclass function CoResourceSet.CreateRemote(const MachineName: string): _ResourceSet;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_ResourceSet) as _ResourceSet;\r\nend;\r\n\r\nclass function CoResourceWriter.Create: _ResourceWriter;\r\nbegin\r\n Result := CreateComObject(CLASS_ResourceWriter) as _ResourceWriter;\r\nend;\r\n\r\nclass function CoResourceWriter.CreateRemote(const MachineName: string): _ResourceWriter;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_ResourceWriter) as _ResourceWriter;\r\nend;\r\n\r\nclass function CoSatelliteContractVersionAttribute.Create: _SatelliteContractVersionAttribute;\r\nbegin\r\n Result := CreateComObject(CLASS_SatelliteContractVersionAttribute) as _SatelliteContractVersionAttribute;\r\nend;\r\n\r\nclass function CoSatelliteContractVersionAttribute.CreateRemote(const MachineName: string): _SatelliteContractVersionAttribute;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_SatelliteContractVersionAttribute) as _SatelliteContractVersionAttribute;\r\nend;\r\n\r\nclass function CoRegistry.Create: _Registry;\r\nbegin\r\n Result := CreateComObject(CLASS_Registry) as _Registry;\r\nend;\r\n\r\nclass function CoRegistry.CreateRemote(const MachineName: string): _Registry;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_Registry) as _Registry;\r\nend;\r\n\r\nclass function CoRegistryKey.Create: _RegistryKey;\r\nbegin\r\n Result := CreateComObject(CLASS_RegistryKey) as _RegistryKey;\r\nend;\r\n\r\nclass function CoRegistryKey.CreateRemote(const MachineName: string): _RegistryKey;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_RegistryKey) as _RegistryKey;\r\nend;\r\n\r\nclass function CoX509Certificate.Create: _X509Certificate;\r\nbegin\r\n Result := CreateComObject(CLASS_X509Certificate) as _X509Certificate;\r\nend;\r\n\r\nclass function CoX509Certificate.CreateRemote(const MachineName: string): _X509Certificate;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_X509Certificate) as _X509Certificate;\r\nend;\r\n\r\nclass function CoAsymmetricAlgorithm.Create: _AsymmetricAlgorithm;\r\nbegin\r\n Result := CreateComObject(CLASS_AsymmetricAlgorithm) as _AsymmetricAlgorithm;\r\nend;\r\n\r\nclass function CoAsymmetricAlgorithm.CreateRemote(const MachineName: string): _AsymmetricAlgorithm;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_AsymmetricAlgorithm) as _AsymmetricAlgorithm;\r\nend;\r\n\r\nclass function CoAsymmetricKeyExchangeDeformatter.Create: _AsymmetricKeyExchangeDeformatter;\r\nbegin\r\n Result := CreateComObject(CLASS_AsymmetricKeyExchangeDeformatter) as _AsymmetricKeyExchangeDeformatter;\r\nend;\r\n\r\nclass function CoAsymmetricKeyExchangeDeformatter.CreateRemote(const MachineName: string): _AsymmetricKeyExchangeDeformatter;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_AsymmetricKeyExchangeDeformatter) as _AsymmetricKeyExchangeDeformatter;\r\nend;\r\n\r\nclass function CoAsymmetricKeyExchangeFormatter.Create: _AsymmetricKeyExchangeFormatter;\r\nbegin\r\n Result := CreateComObject(CLASS_AsymmetricKeyExchangeFormatter) as _AsymmetricKeyExchangeFormatter;\r\nend;\r\n\r\nclass function CoAsymmetricKeyExchangeFormatter.CreateRemote(const MachineName: string): _AsymmetricKeyExchangeFormatter;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_AsymmetricKeyExchangeFormatter) as _AsymmetricKeyExchangeFormatter;\r\nend;\r\n\r\nclass function CoAsymmetricSignatureDeformatter.Create: _AsymmetricSignatureDeformatter;\r\nbegin\r\n Result := CreateComObject(CLASS_AsymmetricSignatureDeformatter) as _AsymmetricSignatureDeformatter;\r\nend;\r\n\r\nclass function CoAsymmetricSignatureDeformatter.CreateRemote(const MachineName: string): _AsymmetricSignatureDeformatter;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_AsymmetricSignatureDeformatter) as _AsymmetricSignatureDeformatter;\r\nend;\r\n\r\nclass function CoAsymmetricSignatureFormatter.Create: _AsymmetricSignatureFormatter;\r\nbegin\r\n Result := CreateComObject(CLASS_AsymmetricSignatureFormatter) as _AsymmetricSignatureFormatter;\r\nend;\r\n\r\nclass function CoAsymmetricSignatureFormatter.CreateRemote(const MachineName: string): _AsymmetricSignatureFormatter;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_AsymmetricSignatureFormatter) as _AsymmetricSignatureFormatter;\r\nend;\r\n\r\nclass function CoToBase64Transform.Create: _ToBase64Transform;\r\nbegin\r\n Result := CreateComObject(CLASS_ToBase64Transform) as _ToBase64Transform;\r\nend;\r\n\r\nclass function CoToBase64Transform.CreateRemote(const MachineName: string): _ToBase64Transform;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_ToBase64Transform) as _ToBase64Transform;\r\nend;\r\n\r\nclass function CoFromBase64Transform.Create: _FromBase64Transform;\r\nbegin\r\n Result := CreateComObject(CLASS_FromBase64Transform) as _FromBase64Transform;\r\nend;\r\n\r\nclass function CoFromBase64Transform.CreateRemote(const MachineName: string): _FromBase64Transform;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_FromBase64Transform) as _FromBase64Transform;\r\nend;\r\n\r\nclass function CoKeySizes.Create: _KeySizes;\r\nbegin\r\n Result := CreateComObject(CLASS_KeySizes) as _KeySizes;\r\nend;\r\n\r\nclass function CoKeySizes.CreateRemote(const MachineName: string): _KeySizes;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_KeySizes) as _KeySizes;\r\nend;\r\n\r\nclass function CoCryptographicException.Create: _CryptographicException;\r\nbegin\r\n Result := CreateComObject(CLASS_CryptographicException) as _CryptographicException;\r\nend;\r\n\r\nclass function CoCryptographicException.CreateRemote(const MachineName: string): _CryptographicException;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_CryptographicException) as _CryptographicException;\r\nend;\r\n\r\nclass function CoCryptographicUnexpectedOperationException.Create: _CryptographicUnexpectedOperationException;\r\nbegin\r\n Result := CreateComObject(CLASS_CryptographicUnexpectedOperationException) as _CryptographicUnexpectedOperationException;\r\nend;\r\n\r\nclass function CoCryptographicUnexpectedOperationException.CreateRemote(const MachineName: string): _CryptographicUnexpectedOperationException;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_CryptographicUnexpectedOperationException) as _CryptographicUnexpectedOperationException;\r\nend;\r\n\r\nclass function CoCryptoAPITransform.Create: _CryptoAPITransform;\r\nbegin\r\n Result := CreateComObject(CLASS_CryptoAPITransform) as _CryptoAPITransform;\r\nend;\r\n\r\nclass function CoCryptoAPITransform.CreateRemote(const MachineName: string): _CryptoAPITransform;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_CryptoAPITransform) as _CryptoAPITransform;\r\nend;\r\n\r\nclass function CoCspParameters.Create: _CspParameters;\r\nbegin\r\n Result := CreateComObject(CLASS_CspParameters) as _CspParameters;\r\nend;\r\n\r\nclass function CoCspParameters.CreateRemote(const MachineName: string): _CspParameters;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_CspParameters) as _CspParameters;\r\nend;\r\n\r\nclass function CoCryptoConfig.Create: _CryptoConfig;\r\nbegin\r\n Result := CreateComObject(CLASS_CryptoConfig) as _CryptoConfig;\r\nend;\r\n\r\nclass function CoCryptoConfig.CreateRemote(const MachineName: string): _CryptoConfig;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_CryptoConfig) as _CryptoConfig;\r\nend;\r\n\r\nclass function CoStream.Create: _Stream;\r\nbegin\r\n Result := CreateComObject(CLASS_Stream) as _Stream;\r\nend;\r\n\r\nclass function CoStream.CreateRemote(const MachineName: string): _Stream;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_Stream) as _Stream;\r\nend;\r\n\r\nclass function CoCryptoStream.Create: _CryptoStream;\r\nbegin\r\n Result := CreateComObject(CLASS_CryptoStream) as _CryptoStream;\r\nend;\r\n\r\nclass function CoCryptoStream.CreateRemote(const MachineName: string): _CryptoStream;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_CryptoStream) as _CryptoStream;\r\nend;\r\n\r\nclass function CoSymmetricAlgorithm.Create: _SymmetricAlgorithm;\r\nbegin\r\n Result := CreateComObject(CLASS_SymmetricAlgorithm) as _SymmetricAlgorithm;\r\nend;\r\n\r\nclass function CoSymmetricAlgorithm.CreateRemote(const MachineName: string): _SymmetricAlgorithm;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_SymmetricAlgorithm) as _SymmetricAlgorithm;\r\nend;\r\n\r\nclass function CoDES.Create: _DES;\r\nbegin\r\n Result := CreateComObject(CLASS_DES) as _DES;\r\nend;\r\n\r\nclass function CoDES.CreateRemote(const MachineName: string): _DES;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_DES) as _DES;\r\nend;\r\n\r\nclass function CoDESCryptoServiceProvider.Create: _DESCryptoServiceProvider;\r\nbegin\r\n Result := CreateComObject(CLASS_DESCryptoServiceProvider) as _DESCryptoServiceProvider;\r\nend;\r\n\r\nclass function CoDESCryptoServiceProvider.CreateRemote(const MachineName: string): _DESCryptoServiceProvider;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_DESCryptoServiceProvider) as _DESCryptoServiceProvider;\r\nend;\r\n\r\nclass function CoDeriveBytes.Create: _DeriveBytes;\r\nbegin\r\n Result := CreateComObject(CLASS_DeriveBytes) as _DeriveBytes;\r\nend;\r\n\r\nclass function CoDeriveBytes.CreateRemote(const MachineName: string): _DeriveBytes;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_DeriveBytes) as _DeriveBytes;\r\nend;\r\n\r\nclass function CoDSA.Create: _DSA;\r\nbegin\r\n Result := CreateComObject(CLASS_DSA) as _DSA;\r\nend;\r\n\r\nclass function CoDSA.CreateRemote(const MachineName: string): _DSA;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_DSA) as _DSA;\r\nend;\r\n\r\nclass function CoDSACryptoServiceProvider.Create: _DSACryptoServiceProvider;\r\nbegin\r\n Result := CreateComObject(CLASS_DSACryptoServiceProvider) as _DSACryptoServiceProvider;\r\nend;\r\n\r\nclass function CoDSACryptoServiceProvider.CreateRemote(const MachineName: string): _DSACryptoServiceProvider;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_DSACryptoServiceProvider) as _DSACryptoServiceProvider;\r\nend;\r\n\r\nclass function CoDSASignatureDeformatter.Create: _DSASignatureDeformatter;\r\nbegin\r\n Result := CreateComObject(CLASS_DSASignatureDeformatter) as _DSASignatureDeformatter;\r\nend;\r\n\r\nclass function CoDSASignatureDeformatter.CreateRemote(const MachineName: string): _DSASignatureDeformatter;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_DSASignatureDeformatter) as _DSASignatureDeformatter;\r\nend;\r\n\r\nclass function CoDSASignatureFormatter.Create: _DSASignatureFormatter;\r\nbegin\r\n Result := CreateComObject(CLASS_DSASignatureFormatter) as _DSASignatureFormatter;\r\nend;\r\n\r\nclass function CoDSASignatureFormatter.CreateRemote(const MachineName: string): _DSASignatureFormatter;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_DSASignatureFormatter) as _DSASignatureFormatter;\r\nend;\r\n\r\nclass function CoHashAlgorithm.Create: _HashAlgorithm;\r\nbegin\r\n Result := CreateComObject(CLASS_HashAlgorithm) as _HashAlgorithm;\r\nend;\r\n\r\nclass function CoHashAlgorithm.CreateRemote(const MachineName: string): _HashAlgorithm;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_HashAlgorithm) as _HashAlgorithm;\r\nend;\r\n\r\nclass function CoKeyedHashAlgorithm.Create: _KeyedHashAlgorithm;\r\nbegin\r\n Result := CreateComObject(CLASS_KeyedHashAlgorithm) as _KeyedHashAlgorithm;\r\nend;\r\n\r\nclass function CoKeyedHashAlgorithm.CreateRemote(const MachineName: string): _KeyedHashAlgorithm;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_KeyedHashAlgorithm) as _KeyedHashAlgorithm;\r\nend;\r\n\r\nclass function CoHMACSHA1.Create: _HMACSHA1;\r\nbegin\r\n Result := CreateComObject(CLASS_HMACSHA1) as _HMACSHA1;\r\nend;\r\n\r\nclass function CoHMACSHA1.CreateRemote(const MachineName: string): _HMACSHA1;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_HMACSHA1) as _HMACSHA1;\r\nend;\r\n\r\nclass function CoMACTripleDES.Create: _MACTripleDES;\r\nbegin\r\n Result := CreateComObject(CLASS_MACTripleDES) as _MACTripleDES;\r\nend;\r\n\r\nclass function CoMACTripleDES.CreateRemote(const MachineName: string): _MACTripleDES;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_MACTripleDES) as _MACTripleDES;\r\nend;\r\n\r\nclass function CoMD5.Create: _MD5;\r\nbegin\r\n Result := CreateComObject(CLASS_MD5) as _MD5;\r\nend;\r\n\r\nclass function CoMD5.CreateRemote(const MachineName: string): _MD5;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_MD5) as _MD5;\r\nend;\r\n\r\nclass function CoMD5CryptoServiceProvider.Create: _MD5CryptoServiceProvider;\r\nbegin\r\n Result := CreateComObject(CLASS_MD5CryptoServiceProvider) as _MD5CryptoServiceProvider;\r\nend;\r\n\r\nclass function CoMD5CryptoServiceProvider.CreateRemote(const MachineName: string): _MD5CryptoServiceProvider;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_MD5CryptoServiceProvider) as _MD5CryptoServiceProvider;\r\nend;\r\n\r\nclass function CoMaskGenerationMethod.Create: _MaskGenerationMethod;\r\nbegin\r\n Result := CreateComObject(CLASS_MaskGenerationMethod) as _MaskGenerationMethod;\r\nend;\r\n\r\nclass function CoMaskGenerationMethod.CreateRemote(const MachineName: string): _MaskGenerationMethod;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_MaskGenerationMethod) as _MaskGenerationMethod;\r\nend;\r\n\r\nclass function CoPasswordDeriveBytes.Create: _PasswordDeriveBytes;\r\nbegin\r\n Result := CreateComObject(CLASS_PasswordDeriveBytes) as _PasswordDeriveBytes;\r\nend;\r\n\r\nclass function CoPasswordDeriveBytes.CreateRemote(const MachineName: string): _PasswordDeriveBytes;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_PasswordDeriveBytes) as _PasswordDeriveBytes;\r\nend;\r\n\r\nclass function CoPKCS1MaskGenerationMethod.Create: _PKCS1MaskGenerationMethod;\r\nbegin\r\n Result := CreateComObject(CLASS_PKCS1MaskGenerationMethod) as _PKCS1MaskGenerationMethod;\r\nend;\r\n\r\nclass function CoPKCS1MaskGenerationMethod.CreateRemote(const MachineName: string): _PKCS1MaskGenerationMethod;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_PKCS1MaskGenerationMethod) as _PKCS1MaskGenerationMethod;\r\nend;\r\n\r\nclass function CoRC2.Create: _RC2;\r\nbegin\r\n Result := CreateComObject(CLASS_RC2) as _RC2;\r\nend;\r\n\r\nclass function CoRC2.CreateRemote(const MachineName: string): _RC2;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_RC2) as _RC2;\r\nend;\r\n\r\nclass function CoRC2CryptoServiceProvider.Create: _RC2CryptoServiceProvider;\r\nbegin\r\n Result := CreateComObject(CLASS_RC2CryptoServiceProvider) as _RC2CryptoServiceProvider;\r\nend;\r\n\r\nclass function CoRC2CryptoServiceProvider.CreateRemote(const MachineName: string): _RC2CryptoServiceProvider;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_RC2CryptoServiceProvider) as _RC2CryptoServiceProvider;\r\nend;\r\n\r\nclass function CoRandomNumberGenerator.Create: _RandomNumberGenerator;\r\nbegin\r\n Result := CreateComObject(CLASS_RandomNumberGenerator) as _RandomNumberGenerator;\r\nend;\r\n\r\nclass function CoRandomNumberGenerator.CreateRemote(const MachineName: string): _RandomNumberGenerator;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_RandomNumberGenerator) as _RandomNumberGenerator;\r\nend;\r\n\r\nclass function CoRNGCryptoServiceProvider.Create: _RNGCryptoServiceProvider;\r\nbegin\r\n Result := CreateComObject(CLASS_RNGCryptoServiceProvider) as _RNGCryptoServiceProvider;\r\nend;\r\n\r\nclass function CoRNGCryptoServiceProvider.CreateRemote(const MachineName: string): _RNGCryptoServiceProvider;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_RNGCryptoServiceProvider) as _RNGCryptoServiceProvider;\r\nend;\r\n\r\nclass function CoRSA.Create: _RSA;\r\nbegin\r\n Result := CreateComObject(CLASS_RSA) as _RSA;\r\nend;\r\n\r\nclass function CoRSA.CreateRemote(const MachineName: string): _RSA;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_RSA) as _RSA;\r\nend;\r\n\r\nclass function CoRSACryptoServiceProvider.Create: _RSACryptoServiceProvider;\r\nbegin\r\n Result := CreateComObject(CLASS_RSACryptoServiceProvider) as _RSACryptoServiceProvider;\r\nend;\r\n\r\nclass function CoRSACryptoServiceProvider.CreateRemote(const MachineName: string): _RSACryptoServiceProvider;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_RSACryptoServiceProvider) as _RSACryptoServiceProvider;\r\nend;\r\n\r\nclass function CoRSAOAEPKeyExchangeDeformatter.Create: _RSAOAEPKeyExchangeDeformatter;\r\nbegin\r\n Result := CreateComObject(CLASS_RSAOAEPKeyExchangeDeformatter) as _RSAOAEPKeyExchangeDeformatter;\r\nend;\r\n\r\nclass function CoRSAOAEPKeyExchangeDeformatter.CreateRemote(const MachineName: string): _RSAOAEPKeyExchangeDeformatter;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_RSAOAEPKeyExchangeDeformatter) as _RSAOAEPKeyExchangeDeformatter;\r\nend;\r\n\r\nclass function CoRSAOAEPKeyExchangeFormatter.Create: _RSAOAEPKeyExchangeFormatter;\r\nbegin\r\n Result := CreateComObject(CLASS_RSAOAEPKeyExchangeFormatter) as _RSAOAEPKeyExchangeFormatter;\r\nend;\r\n\r\nclass function CoRSAOAEPKeyExchangeFormatter.CreateRemote(const MachineName: string): _RSAOAEPKeyExchangeFormatter;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_RSAOAEPKeyExchangeFormatter) as _RSAOAEPKeyExchangeFormatter;\r\nend;\r\n\r\nclass function CoRSAPKCS1KeyExchangeDeformatter.Create: _RSAPKCS1KeyExchangeDeformatter;\r\nbegin\r\n Result := CreateComObject(CLASS_RSAPKCS1KeyExchangeDeformatter) as _RSAPKCS1KeyExchangeDeformatter;\r\nend;\r\n\r\nclass function CoRSAPKCS1KeyExchangeDeformatter.CreateRemote(const MachineName: string): _RSAPKCS1KeyExchangeDeformatter;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_RSAPKCS1KeyExchangeDeformatter) as _RSAPKCS1KeyExchangeDeformatter;\r\nend;\r\n\r\nclass function CoRSAPKCS1KeyExchangeFormatter.Create: _RSAPKCS1KeyExchangeFormatter;\r\nbegin\r\n Result := CreateComObject(CLASS_RSAPKCS1KeyExchangeFormatter) as _RSAPKCS1KeyExchangeFormatter;\r\nend;\r\n\r\nclass function CoRSAPKCS1KeyExchangeFormatter.CreateRemote(const MachineName: string): _RSAPKCS1KeyExchangeFormatter;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_RSAPKCS1KeyExchangeFormatter) as _RSAPKCS1KeyExchangeFormatter;\r\nend;\r\n\r\nclass function CoRSAPKCS1SignatureDeformatter.Create: _RSAPKCS1SignatureDeformatter;\r\nbegin\r\n Result := CreateComObject(CLASS_RSAPKCS1SignatureDeformatter) as _RSAPKCS1SignatureDeformatter;\r\nend;\r\n\r\nclass function CoRSAPKCS1SignatureDeformatter.CreateRemote(const MachineName: string): _RSAPKCS1SignatureDeformatter;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_RSAPKCS1SignatureDeformatter) as _RSAPKCS1SignatureDeformatter;\r\nend;\r\n\r\nclass function CoRSAPKCS1SignatureFormatter.Create: _RSAPKCS1SignatureFormatter;\r\nbegin\r\n Result := CreateComObject(CLASS_RSAPKCS1SignatureFormatter) as _RSAPKCS1SignatureFormatter;\r\nend;\r\n\r\nclass function CoRSAPKCS1SignatureFormatter.CreateRemote(const MachineName: string): _RSAPKCS1SignatureFormatter;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_RSAPKCS1SignatureFormatter) as _RSAPKCS1SignatureFormatter;\r\nend;\r\n\r\nclass function CoRijndael.Create: _Rijndael;\r\nbegin\r\n Result := CreateComObject(CLASS_Rijndael) as _Rijndael;\r\nend;\r\n\r\nclass function CoRijndael.CreateRemote(const MachineName: string): _Rijndael;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_Rijndael) as _Rijndael;\r\nend;\r\n\r\nclass function CoRijndaelManaged.Create: _RijndaelManaged;\r\nbegin\r\n Result := CreateComObject(CLASS_RijndaelManaged) as _RijndaelManaged;\r\nend;\r\n\r\nclass function CoRijndaelManaged.CreateRemote(const MachineName: string): _RijndaelManaged;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_RijndaelManaged) as _RijndaelManaged;\r\nend;\r\n\r\nclass function CoSHA1.Create: _SHA1;\r\nbegin\r\n Result := CreateComObject(CLASS_SHA1) as _SHA1;\r\nend;\r\n\r\nclass function CoSHA1.CreateRemote(const MachineName: string): _SHA1;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_SHA1) as _SHA1;\r\nend;\r\n\r\nclass function CoSHA1CryptoServiceProvider.Create: _SHA1CryptoServiceProvider;\r\nbegin\r\n Result := CreateComObject(CLASS_SHA1CryptoServiceProvider) as _SHA1CryptoServiceProvider;\r\nend;\r\n\r\nclass function CoSHA1CryptoServiceProvider.CreateRemote(const MachineName: string): _SHA1CryptoServiceProvider;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_SHA1CryptoServiceProvider) as _SHA1CryptoServiceProvider;\r\nend;\r\n\r\nclass function CoSHA1Managed.Create: _SHA1Managed;\r\nbegin\r\n Result := CreateComObject(CLASS_SHA1Managed) as _SHA1Managed;\r\nend;\r\n\r\nclass function CoSHA1Managed.CreateRemote(const MachineName: string): _SHA1Managed;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_SHA1Managed) as _SHA1Managed;\r\nend;\r\n\r\nclass function CoSHA256.Create: _SHA256;\r\nbegin\r\n Result := CreateComObject(CLASS_SHA256) as _SHA256;\r\nend;\r\n\r\nclass function CoSHA256.CreateRemote(const MachineName: string): _SHA256;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_SHA256) as _SHA256;\r\nend;\r\n\r\nclass function CoSHA256Managed.Create: _SHA256Managed;\r\nbegin\r\n Result := CreateComObject(CLASS_SHA256Managed) as _SHA256Managed;\r\nend;\r\n\r\nclass function CoSHA256Managed.CreateRemote(const MachineName: string): _SHA256Managed;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_SHA256Managed) as _SHA256Managed;\r\nend;\r\n\r\nclass function CoSHA384.Create: _SHA384;\r\nbegin\r\n Result := CreateComObject(CLASS_SHA384) as _SHA384;\r\nend;\r\n\r\nclass function CoSHA384.CreateRemote(const MachineName: string): _SHA384;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_SHA384) as _SHA384;\r\nend;\r\n\r\nclass function CoSHA384Managed.Create: _SHA384Managed;\r\nbegin\r\n Result := CreateComObject(CLASS_SHA384Managed) as _SHA384Managed;\r\nend;\r\n\r\nclass function CoSHA384Managed.CreateRemote(const MachineName: string): _SHA384Managed;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_SHA384Managed) as _SHA384Managed;\r\nend;\r\n\r\nclass function CoSHA512.Create: _SHA512;\r\nbegin\r\n Result := CreateComObject(CLASS_SHA512) as _SHA512;\r\nend;\r\n\r\nclass function CoSHA512.CreateRemote(const MachineName: string): _SHA512;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_SHA512) as _SHA512;\r\nend;\r\n\r\nclass function CoSHA512Managed.Create: _SHA512Managed;\r\nbegin\r\n Result := CreateComObject(CLASS_SHA512Managed) as _SHA512Managed;\r\nend;\r\n\r\nclass function CoSHA512Managed.CreateRemote(const MachineName: string): _SHA512Managed;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_SHA512Managed) as _SHA512Managed;\r\nend;\r\n\r\nclass function CoSignatureDescription.Create: _SignatureDescription;\r\nbegin\r\n Result := CreateComObject(CLASS_SignatureDescription) as _SignatureDescription;\r\nend;\r\n\r\nclass function CoSignatureDescription.CreateRemote(const MachineName: string): _SignatureDescription;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_SignatureDescription) as _SignatureDescription;\r\nend;\r\n\r\nclass function CoTripleDES.Create: _TripleDES;\r\nbegin\r\n Result := CreateComObject(CLASS_TripleDES) as _TripleDES;\r\nend;\r\n\r\nclass function CoTripleDES.CreateRemote(const MachineName: string): _TripleDES;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_TripleDES) as _TripleDES;\r\nend;\r\n\r\nclass function CoTripleDESCryptoServiceProvider.Create: _TripleDESCryptoServiceProvider;\r\nbegin\r\n Result := CreateComObject(CLASS_TripleDESCryptoServiceProvider) as _TripleDESCryptoServiceProvider;\r\nend;\r\n\r\nclass function CoTripleDESCryptoServiceProvider.CreateRemote(const MachineName: string): _TripleDESCryptoServiceProvider;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_TripleDESCryptoServiceProvider) as _TripleDESCryptoServiceProvider;\r\nend;\r\n\r\nclass function CoAllMembershipCondition.Create: _AllMembershipCondition;\r\nbegin\r\n Result := CreateComObject(CLASS_AllMembershipCondition) as _AllMembershipCondition;\r\nend;\r\n\r\nclass function CoAllMembershipCondition.CreateRemote(const MachineName: string): _AllMembershipCondition;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_AllMembershipCondition) as _AllMembershipCondition;\r\nend;\r\n\r\nclass function CoApplicationDirectory.Create: _ApplicationDirectory;\r\nbegin\r\n Result := CreateComObject(CLASS_ApplicationDirectory) as _ApplicationDirectory;\r\nend;\r\n\r\nclass function CoApplicationDirectory.CreateRemote(const MachineName: string): _ApplicationDirectory;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_ApplicationDirectory) as _ApplicationDirectory;\r\nend;\r\n\r\nclass function CoApplicationDirectoryMembershipCondition.Create: _ApplicationDirectoryMembershipCondition;\r\nbegin\r\n Result := CreateComObject(CLASS_ApplicationDirectoryMembershipCondition) as _ApplicationDirectoryMembershipCondition;\r\nend;\r\n\r\nclass function CoApplicationDirectoryMembershipCondition.CreateRemote(const MachineName: string): _ApplicationDirectoryMembershipCondition;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_ApplicationDirectoryMembershipCondition) as _ApplicationDirectoryMembershipCondition;\r\nend;\r\n\r\nclass function CoCodeGroup.Create: _CodeGroup;\r\nbegin\r\n Result := CreateComObject(CLASS_CodeGroup) as _CodeGroup;\r\nend;\r\n\r\nclass function CoCodeGroup.CreateRemote(const MachineName: string): _CodeGroup;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_CodeGroup) as _CodeGroup;\r\nend;\r\n\r\nclass function CoEvidence.Create: _Evidence;\r\nbegin\r\n Result := CreateComObject(CLASS_Evidence) as _Evidence;\r\nend;\r\n\r\nclass function CoEvidence.CreateRemote(const MachineName: string): _Evidence;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_Evidence) as _Evidence;\r\nend;\r\n\r\nclass function CoFileCodeGroup.Create: _FileCodeGroup;\r\nbegin\r\n Result := CreateComObject(CLASS_FileCodeGroup) as _FileCodeGroup;\r\nend;\r\n\r\nclass function CoFileCodeGroup.CreateRemote(const MachineName: string): _FileCodeGroup;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_FileCodeGroup) as _FileCodeGroup;\r\nend;\r\n\r\nclass function CoFirstMatchCodeGroup.Create: _FirstMatchCodeGroup;\r\nbegin\r\n Result := CreateComObject(CLASS_FirstMatchCodeGroup) as _FirstMatchCodeGroup;\r\nend;\r\n\r\nclass function CoFirstMatchCodeGroup.CreateRemote(const MachineName: string): _FirstMatchCodeGroup;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_FirstMatchCodeGroup) as _FirstMatchCodeGroup;\r\nend;\r\n\r\nclass function CoHash.Create: _Hash;\r\nbegin\r\n Result := CreateComObject(CLASS_Hash) as _Hash;\r\nend;\r\n\r\nclass function CoHash.CreateRemote(const MachineName: string): _Hash;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_Hash) as _Hash;\r\nend;\r\n\r\nclass function CoHashMembershipCondition.Create: _HashMembershipCondition;\r\nbegin\r\n Result := CreateComObject(CLASS_HashMembershipCondition) as _HashMembershipCondition;\r\nend;\r\n\r\nclass function CoHashMembershipCondition.CreateRemote(const MachineName: string): _HashMembershipCondition;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_HashMembershipCondition) as _HashMembershipCondition;\r\nend;\r\n\r\nclass function CoNetCodeGroup.Create: _NetCodeGroup;\r\nbegin\r\n Result := CreateComObject(CLASS_NetCodeGroup) as _NetCodeGroup;\r\nend;\r\n\r\nclass function CoNetCodeGroup.CreateRemote(const MachineName: string): _NetCodeGroup;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_NetCodeGroup) as _NetCodeGroup;\r\nend;\r\n\r\nclass function CoPermissionRequestEvidence.Create: _PermissionRequestEvidence;\r\nbegin\r\n Result := CreateComObject(CLASS_PermissionRequestEvidence) as _PermissionRequestEvidence;\r\nend;\r\n\r\nclass function CoPermissionRequestEvidence.CreateRemote(const MachineName: string): _PermissionRequestEvidence;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_PermissionRequestEvidence) as _PermissionRequestEvidence;\r\nend;\r\n\r\nclass function CoPolicyException.Create: _PolicyException;\r\nbegin\r\n Result := CreateComObject(CLASS_PolicyException) as _PolicyException;\r\nend;\r\n\r\nclass function CoPolicyException.CreateRemote(const MachineName: string): _PolicyException;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_PolicyException) as _PolicyException;\r\nend;\r\n\r\nclass function CoPolicyLevel.Create: _PolicyLevel;\r\nbegin\r\n Result := CreateComObject(CLASS_PolicyLevel) as _PolicyLevel;\r\nend;\r\n\r\nclass function CoPolicyLevel.CreateRemote(const MachineName: string): _PolicyLevel;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_PolicyLevel) as _PolicyLevel;\r\nend;\r\n\r\nclass function CoPolicyStatement.Create: _PolicyStatement;\r\nbegin\r\n Result := CreateComObject(CLASS_PolicyStatement) as _PolicyStatement;\r\nend;\r\n\r\nclass function CoPolicyStatement.CreateRemote(const MachineName: string): _PolicyStatement;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_PolicyStatement) as _PolicyStatement;\r\nend;\r\n\r\nclass function CoPublisher.Create: _Publisher;\r\nbegin\r\n Result := CreateComObject(CLASS_Publisher) as _Publisher;\r\nend;\r\n\r\nclass function CoPublisher.CreateRemote(const MachineName: string): _Publisher;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_Publisher) as _Publisher;\r\nend;\r\n\r\nclass function CoPublisherMembershipCondition.Create: _PublisherMembershipCondition;\r\nbegin\r\n Result := CreateComObject(CLASS_PublisherMembershipCondition) as _PublisherMembershipCondition;\r\nend;\r\n\r\nclass function CoPublisherMembershipCondition.CreateRemote(const MachineName: string): _PublisherMembershipCondition;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_PublisherMembershipCondition) as _PublisherMembershipCondition;\r\nend;\r\n\r\nclass function CoSite.Create: _Site;\r\nbegin\r\n Result := CreateComObject(CLASS_Site) as _Site;\r\nend;\r\n\r\nclass function CoSite.CreateRemote(const MachineName: string): _Site;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_Site) as _Site;\r\nend;\r\n\r\nclass function CoSiteMembershipCondition.Create: _SiteMembershipCondition;\r\nbegin\r\n Result := CreateComObject(CLASS_SiteMembershipCondition) as _SiteMembershipCondition;\r\nend;\r\n\r\nclass function CoSiteMembershipCondition.CreateRemote(const MachineName: string): _SiteMembershipCondition;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_SiteMembershipCondition) as _SiteMembershipCondition;\r\nend;\r\n\r\nclass function CoStrongName.Create: _StrongName;\r\nbegin\r\n Result := CreateComObject(CLASS_StrongName) as _StrongName;\r\nend;\r\n\r\nclass function CoStrongName.CreateRemote(const MachineName: string): _StrongName;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_StrongName) as _StrongName;\r\nend;\r\n\r\nclass function CoStrongNameMembershipCondition.Create: _StrongNameMembershipCondition;\r\nbegin\r\n Result := CreateComObject(CLASS_StrongNameMembershipCondition) as _StrongNameMembershipCondition;\r\nend;\r\n\r\nclass function CoStrongNameMembershipCondition.CreateRemote(const MachineName: string): _StrongNameMembershipCondition;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_StrongNameMembershipCondition) as _StrongNameMembershipCondition;\r\nend;\r\n\r\nclass function CoUnionCodeGroup.Create: _UnionCodeGroup;\r\nbegin\r\n Result := CreateComObject(CLASS_UnionCodeGroup) as _UnionCodeGroup;\r\nend;\r\n\r\nclass function CoUnionCodeGroup.CreateRemote(const MachineName: string): _UnionCodeGroup;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_UnionCodeGroup) as _UnionCodeGroup;\r\nend;\r\n\r\nclass function CoUrl.Create: _Url;\r\nbegin\r\n Result := CreateComObject(CLASS_Url) as _Url;\r\nend;\r\n\r\nclass function CoUrl.CreateRemote(const MachineName: string): _Url;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_Url) as _Url;\r\nend;\r\n\r\nclass function CoUrlMembershipCondition.Create: _UrlMembershipCondition;\r\nbegin\r\n Result := CreateComObject(CLASS_UrlMembershipCondition) as _UrlMembershipCondition;\r\nend;\r\n\r\nclass function CoUrlMembershipCondition.CreateRemote(const MachineName: string): _UrlMembershipCondition;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_UrlMembershipCondition) as _UrlMembershipCondition;\r\nend;\r\n\r\nclass function CoZone.Create: _Zone;\r\nbegin\r\n Result := CreateComObject(CLASS_Zone) as _Zone;\r\nend;\r\n\r\nclass function CoZone.CreateRemote(const MachineName: string): _Zone;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_Zone) as _Zone;\r\nend;\r\n\r\nclass function CoZoneMembershipCondition.Create: _ZoneMembershipCondition;\r\nbegin\r\n Result := CreateComObject(CLASS_ZoneMembershipCondition) as _ZoneMembershipCondition;\r\nend;\r\n\r\nclass function CoZoneMembershipCondition.CreateRemote(const MachineName: string): _ZoneMembershipCondition;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_ZoneMembershipCondition) as _ZoneMembershipCondition;\r\nend;\r\n\r\nclass function CoGenericIdentity.Create: _GenericIdentity;\r\nbegin\r\n Result := CreateComObject(CLASS_GenericIdentity) as _GenericIdentity;\r\nend;\r\n\r\nclass function CoGenericIdentity.CreateRemote(const MachineName: string): _GenericIdentity;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_GenericIdentity) as _GenericIdentity;\r\nend;\r\n\r\nclass function CoGenericPrincipal.Create: _GenericPrincipal;\r\nbegin\r\n Result := CreateComObject(CLASS_GenericPrincipal) as _GenericPrincipal;\r\nend;\r\n\r\nclass function CoGenericPrincipal.CreateRemote(const MachineName: string): _GenericPrincipal;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_GenericPrincipal) as _GenericPrincipal;\r\nend;\r\n\r\nclass function CoWindowsIdentity.Create: _WindowsIdentity;\r\nbegin\r\n Result := CreateComObject(CLASS_WindowsIdentity) as _WindowsIdentity;\r\nend;\r\n\r\nclass function CoWindowsIdentity.CreateRemote(const MachineName: string): _WindowsIdentity;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_WindowsIdentity) as _WindowsIdentity;\r\nend;\r\n\r\nclass function CoWindowsImpersonationContext.Create: _WindowsImpersonationContext;\r\nbegin\r\n Result := CreateComObject(CLASS_WindowsImpersonationContext) as _WindowsImpersonationContext;\r\nend;\r\n\r\nclass function CoWindowsImpersonationContext.CreateRemote(const MachineName: string): _WindowsImpersonationContext;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_WindowsImpersonationContext) as _WindowsImpersonationContext;\r\nend;\r\n\r\nclass function CoWindowsPrincipal.Create: _WindowsPrincipal;\r\nbegin\r\n Result := CreateComObject(CLASS_WindowsPrincipal) as _WindowsPrincipal;\r\nend;\r\n\r\nclass function CoWindowsPrincipal.CreateRemote(const MachineName: string): _WindowsPrincipal;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_WindowsPrincipal) as _WindowsPrincipal;\r\nend;\r\n\r\nclass function CoDispIdAttribute.Create: _DispIdAttribute;\r\nbegin\r\n Result := CreateComObject(CLASS_DispIdAttribute) as _DispIdAttribute;\r\nend;\r\n\r\nclass function CoDispIdAttribute.CreateRemote(const MachineName: string): _DispIdAttribute;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_DispIdAttribute) as _DispIdAttribute;\r\nend;\r\n\r\nclass function CoInterfaceTypeAttribute.Create: _InterfaceTypeAttribute;\r\nbegin\r\n Result := CreateComObject(CLASS_InterfaceTypeAttribute) as _InterfaceTypeAttribute;\r\nend;\r\n\r\nclass function CoInterfaceTypeAttribute.CreateRemote(const MachineName: string): _InterfaceTypeAttribute;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_InterfaceTypeAttribute) as _InterfaceTypeAttribute;\r\nend;\r\n\r\nclass function CoClassInterfaceAttribute.Create: _ClassInterfaceAttribute;\r\nbegin\r\n Result := CreateComObject(CLASS_ClassInterfaceAttribute) as _ClassInterfaceAttribute;\r\nend;\r\n\r\nclass function CoClassInterfaceAttribute.CreateRemote(const MachineName: string): _ClassInterfaceAttribute;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_ClassInterfaceAttribute) as _ClassInterfaceAttribute;\r\nend;\r\n\r\nclass function CoComVisibleAttribute.Create: _ComVisibleAttribute;\r\nbegin\r\n Result := CreateComObject(CLASS_ComVisibleAttribute) as _ComVisibleAttribute;\r\nend;\r\n\r\nclass function CoComVisibleAttribute.CreateRemote(const MachineName: string): _ComVisibleAttribute;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_ComVisibleAttribute) as _ComVisibleAttribute;\r\nend;\r\n\r\nclass function CoLCIDConversionAttribute.Create: _LCIDConversionAttribute;\r\nbegin\r\n Result := CreateComObject(CLASS_LCIDConversionAttribute) as _LCIDConversionAttribute;\r\nend;\r\n\r\nclass function CoLCIDConversionAttribute.CreateRemote(const MachineName: string): _LCIDConversionAttribute;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_LCIDConversionAttribute) as _LCIDConversionAttribute;\r\nend;\r\n\r\nclass function CoComRegisterFunctionAttribute.Create: _ComRegisterFunctionAttribute;\r\nbegin\r\n Result := CreateComObject(CLASS_ComRegisterFunctionAttribute) as _ComRegisterFunctionAttribute;\r\nend;\r\n\r\nclass function CoComRegisterFunctionAttribute.CreateRemote(const MachineName: string): _ComRegisterFunctionAttribute;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_ComRegisterFunctionAttribute) as _ComRegisterFunctionAttribute;\r\nend;\r\n\r\nclass function CoComUnregisterFunctionAttribute.Create: _ComUnregisterFunctionAttribute;\r\nbegin\r\n Result := CreateComObject(CLASS_ComUnregisterFunctionAttribute) as _ComUnregisterFunctionAttribute;\r\nend;\r\n\r\nclass function CoComUnregisterFunctionAttribute.CreateRemote(const MachineName: string): _ComUnregisterFunctionAttribute;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_ComUnregisterFunctionAttribute) as _ComUnregisterFunctionAttribute;\r\nend;\r\n\r\nclass function CoProgIdAttribute.Create: _ProgIdAttribute;\r\nbegin\r\n Result := CreateComObject(CLASS_ProgIdAttribute) as _ProgIdAttribute;\r\nend;\r\n\r\nclass function CoProgIdAttribute.CreateRemote(const MachineName: string): _ProgIdAttribute;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_ProgIdAttribute) as _ProgIdAttribute;\r\nend;\r\n\r\nclass function CoImportedFromTypeLibAttribute.Create: _ImportedFromTypeLibAttribute;\r\nbegin\r\n Result := CreateComObject(CLASS_ImportedFromTypeLibAttribute) as _ImportedFromTypeLibAttribute;\r\nend;\r\n\r\nclass function CoImportedFromTypeLibAttribute.CreateRemote(const MachineName: string): _ImportedFromTypeLibAttribute;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_ImportedFromTypeLibAttribute) as _ImportedFromTypeLibAttribute;\r\nend;\r\n\r\nclass function CoIDispatchImplAttribute.Create: _IDispatchImplAttribute;\r\nbegin\r\n Result := CreateComObject(CLASS_IDispatchImplAttribute) as _IDispatchImplAttribute;\r\nend;\r\n\r\nclass function CoIDispatchImplAttribute.CreateRemote(const MachineName: string): _IDispatchImplAttribute;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_IDispatchImplAttribute) as _IDispatchImplAttribute;\r\nend;\r\n\r\nclass function CoComSourceInterfacesAttribute.Create: _ComSourceInterfacesAttribute;\r\nbegin\r\n Result := CreateComObject(CLASS_ComSourceInterfacesAttribute) as _ComSourceInterfacesAttribute;\r\nend;\r\n\r\nclass function CoComSourceInterfacesAttribute.CreateRemote(const MachineName: string): _ComSourceInterfacesAttribute;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_ComSourceInterfacesAttribute) as _ComSourceInterfacesAttribute;\r\nend;\r\n\r\nclass function CoComConversionLossAttribute.Create: _ComConversionLossAttribute;\r\nbegin\r\n Result := CreateComObject(CLASS_ComConversionLossAttribute) as _ComConversionLossAttribute;\r\nend;\r\n\r\nclass function CoComConversionLossAttribute.CreateRemote(const MachineName: string): _ComConversionLossAttribute;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_ComConversionLossAttribute) as _ComConversionLossAttribute;\r\nend;\r\n\r\nclass function CoTypeLibTypeAttribute.Create: _TypeLibTypeAttribute;\r\nbegin\r\n Result := CreateComObject(CLASS_TypeLibTypeAttribute) as _TypeLibTypeAttribute;\r\nend;\r\n\r\nclass function CoTypeLibTypeAttribute.CreateRemote(const MachineName: string): _TypeLibTypeAttribute;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_TypeLibTypeAttribute) as _TypeLibTypeAttribute;\r\nend;\r\n\r\nclass function CoTypeLibFuncAttribute.Create: _TypeLibFuncAttribute;\r\nbegin\r\n Result := CreateComObject(CLASS_TypeLibFuncAttribute) as _TypeLibFuncAttribute;\r\nend;\r\n\r\nclass function CoTypeLibFuncAttribute.CreateRemote(const MachineName: string): _TypeLibFuncAttribute;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_TypeLibFuncAttribute) as _TypeLibFuncAttribute;\r\nend;\r\n\r\nclass function CoTypeLibVarAttribute.Create: _TypeLibVarAttribute;\r\nbegin\r\n Result := CreateComObject(CLASS_TypeLibVarAttribute) as _TypeLibVarAttribute;\r\nend;\r\n\r\nclass function CoTypeLibVarAttribute.CreateRemote(const MachineName: string): _TypeLibVarAttribute;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_TypeLibVarAttribute) as _TypeLibVarAttribute;\r\nend;\r\n\r\nclass function CoMarshalAsAttribute.Create: _MarshalAsAttribute;\r\nbegin\r\n Result := CreateComObject(CLASS_MarshalAsAttribute) as _MarshalAsAttribute;\r\nend;\r\n\r\nclass function CoMarshalAsAttribute.CreateRemote(const MachineName: string): _MarshalAsAttribute;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_MarshalAsAttribute) as _MarshalAsAttribute;\r\nend;\r\n\r\nclass function CoComImportAttribute.Create: _ComImportAttribute;\r\nbegin\r\n Result := CreateComObject(CLASS_ComImportAttribute) as _ComImportAttribute;\r\nend;\r\n\r\nclass function CoComImportAttribute.CreateRemote(const MachineName: string): _ComImportAttribute;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_ComImportAttribute) as _ComImportAttribute;\r\nend;\r\n\r\nclass function CoGuidAttribute.Create: _GuidAttribute;\r\nbegin\r\n Result := CreateComObject(CLASS_GuidAttribute) as _GuidAttribute;\r\nend;\r\n\r\nclass function CoGuidAttribute.CreateRemote(const MachineName: string): _GuidAttribute;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_GuidAttribute) as _GuidAttribute;\r\nend;\r\n\r\nclass function CoPreserveSigAttribute.Create: _PreserveSigAttribute;\r\nbegin\r\n Result := CreateComObject(CLASS_PreserveSigAttribute) as _PreserveSigAttribute;\r\nend;\r\n\r\nclass function CoPreserveSigAttribute.CreateRemote(const MachineName: string): _PreserveSigAttribute;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_PreserveSigAttribute) as _PreserveSigAttribute;\r\nend;\r\n\r\nclass function CoInAttribute.Create: _InAttribute;\r\nbegin\r\n Result := CreateComObject(CLASS_InAttribute) as _InAttribute;\r\nend;\r\n\r\nclass function CoInAttribute.CreateRemote(const MachineName: string): _InAttribute;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_InAttribute) as _InAttribute;\r\nend;\r\n\r\nclass function CoOutAttribute.Create: _OutAttribute;\r\nbegin\r\n Result := CreateComObject(CLASS_OutAttribute) as _OutAttribute;\r\nend;\r\n\r\nclass function CoOutAttribute.CreateRemote(const MachineName: string): _OutAttribute;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_OutAttribute) as _OutAttribute;\r\nend;\r\n\r\nclass function CoOptionalAttribute.Create: _OptionalAttribute;\r\nbegin\r\n Result := CreateComObject(CLASS_OptionalAttribute) as _OptionalAttribute;\r\nend;\r\n\r\nclass function CoOptionalAttribute.CreateRemote(const MachineName: string): _OptionalAttribute;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_OptionalAttribute) as _OptionalAttribute;\r\nend;\r\n\r\nclass function CoDllImportAttribute.Create: _DllImportAttribute;\r\nbegin\r\n Result := CreateComObject(CLASS_DllImportAttribute) as _DllImportAttribute;\r\nend;\r\n\r\nclass function CoDllImportAttribute.CreateRemote(const MachineName: string): _DllImportAttribute;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_DllImportAttribute) as _DllImportAttribute;\r\nend;\r\n\r\nclass function CoStructLayoutAttribute.Create: _StructLayoutAttribute;\r\nbegin\r\n Result := CreateComObject(CLASS_StructLayoutAttribute) as _StructLayoutAttribute;\r\nend;\r\n\r\nclass function CoStructLayoutAttribute.CreateRemote(const MachineName: string): _StructLayoutAttribute;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_StructLayoutAttribute) as _StructLayoutAttribute;\r\nend;\r\n\r\nclass function CoFieldOffsetAttribute.Create: _FieldOffsetAttribute;\r\nbegin\r\n Result := CreateComObject(CLASS_FieldOffsetAttribute) as _FieldOffsetAttribute;\r\nend;\r\n\r\nclass function CoFieldOffsetAttribute.CreateRemote(const MachineName: string): _FieldOffsetAttribute;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_FieldOffsetAttribute) as _FieldOffsetAttribute;\r\nend;\r\n\r\nclass function CoComAliasNameAttribute.Create: _ComAliasNameAttribute;\r\nbegin\r\n Result := CreateComObject(CLASS_ComAliasNameAttribute) as _ComAliasNameAttribute;\r\nend;\r\n\r\nclass function CoComAliasNameAttribute.CreateRemote(const MachineName: string): _ComAliasNameAttribute;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_ComAliasNameAttribute) as _ComAliasNameAttribute;\r\nend;\r\n\r\nclass function CoAutomationProxyAttribute.Create: _AutomationProxyAttribute;\r\nbegin\r\n Result := CreateComObject(CLASS_AutomationProxyAttribute) as _AutomationProxyAttribute;\r\nend;\r\n\r\nclass function CoAutomationProxyAttribute.CreateRemote(const MachineName: string): _AutomationProxyAttribute;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_AutomationProxyAttribute) as _AutomationProxyAttribute;\r\nend;\r\n\r\nclass function CoPrimaryInteropAssemblyAttribute.Create: _PrimaryInteropAssemblyAttribute;\r\nbegin\r\n Result := CreateComObject(CLASS_PrimaryInteropAssemblyAttribute) as _PrimaryInteropAssemblyAttribute;\r\nend;\r\n\r\nclass function CoPrimaryInteropAssemblyAttribute.CreateRemote(const MachineName: string): _PrimaryInteropAssemblyAttribute;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_PrimaryInteropAssemblyAttribute) as _PrimaryInteropAssemblyAttribute;\r\nend;\r\n\r\nclass function CoCoClassAttribute.Create: _CoClassAttribute;\r\nbegin\r\n Result := CreateComObject(CLASS_CoClassAttribute) as _CoClassAttribute;\r\nend;\r\n\r\nclass function CoCoClassAttribute.CreateRemote(const MachineName: string): _CoClassAttribute;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_CoClassAttribute) as _CoClassAttribute;\r\nend;\r\n\r\nclass function CoComEventInterfaceAttribute.Create: _ComEventInterfaceAttribute;\r\nbegin\r\n Result := CreateComObject(CLASS_ComEventInterfaceAttribute) as _ComEventInterfaceAttribute;\r\nend;\r\n\r\nclass function CoComEventInterfaceAttribute.CreateRemote(const MachineName: string): _ComEventInterfaceAttribute;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_ComEventInterfaceAttribute) as _ComEventInterfaceAttribute;\r\nend;\r\n\r\nclass function CoTypeLibVersionAttribute.Create: _TypeLibVersionAttribute;\r\nbegin\r\n Result := CreateComObject(CLASS_TypeLibVersionAttribute) as _TypeLibVersionAttribute;\r\nend;\r\n\r\nclass function CoTypeLibVersionAttribute.CreateRemote(const MachineName: string): _TypeLibVersionAttribute;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_TypeLibVersionAttribute) as _TypeLibVersionAttribute;\r\nend;\r\n\r\nclass function CoComCompatibleVersionAttribute.Create: _ComCompatibleVersionAttribute;\r\nbegin\r\n Result := CreateComObject(CLASS_ComCompatibleVersionAttribute) as _ComCompatibleVersionAttribute;\r\nend;\r\n\r\nclass function CoComCompatibleVersionAttribute.CreateRemote(const MachineName: string): _ComCompatibleVersionAttribute;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_ComCompatibleVersionAttribute) as _ComCompatibleVersionAttribute;\r\nend;\r\n\r\nclass function CoBestFitMappingAttribute.Create: _BestFitMappingAttribute;\r\nbegin\r\n Result := CreateComObject(CLASS_BestFitMappingAttribute) as _BestFitMappingAttribute;\r\nend;\r\n\r\nclass function CoBestFitMappingAttribute.CreateRemote(const MachineName: string): _BestFitMappingAttribute;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_BestFitMappingAttribute) as _BestFitMappingAttribute;\r\nend;\r\n\r\nclass function CoExternalException.Create: _ExternalException;\r\nbegin\r\n Result := CreateComObject(CLASS_ExternalException) as _ExternalException;\r\nend;\r\n\r\nclass function CoExternalException.CreateRemote(const MachineName: string): _ExternalException;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_ExternalException) as _ExternalException;\r\nend;\r\n\r\nclass function CoCOMException.Create: _COMException;\r\nbegin\r\n Result := CreateComObject(CLASS_COMException) as _COMException;\r\nend;\r\n\r\nclass function CoCOMException.CreateRemote(const MachineName: string): _COMException;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_COMException) as _COMException;\r\nend;\r\n\r\nclass function CoCurrencyWrapper.Create: _CurrencyWrapper;\r\nbegin\r\n Result := CreateComObject(CLASS_CurrencyWrapper) as _CurrencyWrapper;\r\nend;\r\n\r\nclass function CoCurrencyWrapper.CreateRemote(const MachineName: string): _CurrencyWrapper;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_CurrencyWrapper) as _CurrencyWrapper;\r\nend;\r\n\r\nclass function CoDispatchWrapper.Create: _DispatchWrapper;\r\nbegin\r\n Result := CreateComObject(CLASS_DispatchWrapper) as _DispatchWrapper;\r\nend;\r\n\r\nclass function CoDispatchWrapper.CreateRemote(const MachineName: string): _DispatchWrapper;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_DispatchWrapper) as _DispatchWrapper;\r\nend;\r\n\r\nclass function CoErrorWrapper.Create: _ErrorWrapper;\r\nbegin\r\n Result := CreateComObject(CLASS_ErrorWrapper) as _ErrorWrapper;\r\nend;\r\n\r\nclass function CoErrorWrapper.CreateRemote(const MachineName: string): _ErrorWrapper;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_ErrorWrapper) as _ErrorWrapper;\r\nend;\r\n\r\nclass function CoExtensibleClassFactory.Create: _ExtensibleClassFactory;\r\nbegin\r\n Result := CreateComObject(CLASS_ExtensibleClassFactory) as _ExtensibleClassFactory;\r\nend;\r\n\r\nclass function CoExtensibleClassFactory.CreateRemote(const MachineName: string): _ExtensibleClassFactory;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_ExtensibleClassFactory) as _ExtensibleClassFactory;\r\nend;\r\n\r\nclass function CoInvalidComObjectException.Create: _InvalidComObjectException;\r\nbegin\r\n Result := CreateComObject(CLASS_InvalidComObjectException) as _InvalidComObjectException;\r\nend;\r\n\r\nclass function CoInvalidComObjectException.CreateRemote(const MachineName: string): _InvalidComObjectException;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_InvalidComObjectException) as _InvalidComObjectException;\r\nend;\r\n\r\nclass function CoInvalidOleVariantTypeException.Create: _InvalidOleVariantTypeException;\r\nbegin\r\n Result := CreateComObject(CLASS_InvalidOleVariantTypeException) as _InvalidOleVariantTypeException;\r\nend;\r\n\r\nclass function CoInvalidOleVariantTypeException.CreateRemote(const MachineName: string): _InvalidOleVariantTypeException;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_InvalidOleVariantTypeException) as _InvalidOleVariantTypeException;\r\nend;\r\n\r\nclass function CoMarshal.Create: _Marshal;\r\nbegin\r\n Result := CreateComObject(CLASS_Marshal) as _Marshal;\r\nend;\r\n\r\nclass function CoMarshal.CreateRemote(const MachineName: string): _Marshal;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_Marshal) as _Marshal;\r\nend;\r\n\r\nclass function CoMarshalDirectiveException.Create: _MarshalDirectiveException;\r\nbegin\r\n Result := CreateComObject(CLASS_MarshalDirectiveException) as _MarshalDirectiveException;\r\nend;\r\n\r\nclass function CoMarshalDirectiveException.CreateRemote(const MachineName: string): _MarshalDirectiveException;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_MarshalDirectiveException) as _MarshalDirectiveException;\r\nend;\r\n\r\nclass function CoObjectCreationDelegate.Create: _ObjectCreationDelegate;\r\nbegin\r\n Result := CreateComObject(CLASS_ObjectCreationDelegate) as _ObjectCreationDelegate;\r\nend;\r\n\r\nclass function CoObjectCreationDelegate.CreateRemote(const MachineName: string): _ObjectCreationDelegate;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_ObjectCreationDelegate) as _ObjectCreationDelegate;\r\nend;\r\n\r\nclass function CoRuntimeEnvironment.Create: _RuntimeEnvironment;\r\nbegin\r\n Result := CreateComObject(CLASS_RuntimeEnvironment) as _RuntimeEnvironment;\r\nend;\r\n\r\nclass function CoRuntimeEnvironment.CreateRemote(const MachineName: string): _RuntimeEnvironment;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_RuntimeEnvironment) as _RuntimeEnvironment;\r\nend;\r\n\r\nclass function CoSafeArrayRankMismatchException.Create: _SafeArrayRankMismatchException;\r\nbegin\r\n Result := CreateComObject(CLASS_SafeArrayRankMismatchException) as _SafeArrayRankMismatchException;\r\nend;\r\n\r\nclass function CoSafeArrayRankMismatchException.CreateRemote(const MachineName: string): _SafeArrayRankMismatchException;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_SafeArrayRankMismatchException) as _SafeArrayRankMismatchException;\r\nend;\r\n\r\nclass function CoSafeArrayTypeMismatchException.Create: _SafeArrayTypeMismatchException;\r\nbegin\r\n Result := CreateComObject(CLASS_SafeArrayTypeMismatchException) as _SafeArrayTypeMismatchException;\r\nend;\r\n\r\nclass function CoSafeArrayTypeMismatchException.CreateRemote(const MachineName: string): _SafeArrayTypeMismatchException;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_SafeArrayTypeMismatchException) as _SafeArrayTypeMismatchException;\r\nend;\r\n\r\nclass function CoSEHException.Create: _SEHException;\r\nbegin\r\n Result := CreateComObject(CLASS_SEHException) as _SEHException;\r\nend;\r\n\r\nclass function CoSEHException.CreateRemote(const MachineName: string): _SEHException;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_SEHException) as _SEHException;\r\nend;\r\n\r\nclass function CoUnknownWrapper.Create: _UnknownWrapper;\r\nbegin\r\n Result := CreateComObject(CLASS_UnknownWrapper) as _UnknownWrapper;\r\nend;\r\n\r\nclass function CoUnknownWrapper.CreateRemote(const MachineName: string): _UnknownWrapper;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_UnknownWrapper) as _UnknownWrapper;\r\nend;\r\n\r\nclass function CoBinaryReader.Create: _BinaryReader;\r\nbegin\r\n Result := CreateComObject(CLASS_BinaryReader) as _BinaryReader;\r\nend;\r\n\r\nclass function CoBinaryReader.CreateRemote(const MachineName: string): _BinaryReader;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_BinaryReader) as _BinaryReader;\r\nend;\r\n\r\nclass function CoBinaryWriter.Create: _BinaryWriter;\r\nbegin\r\n Result := CreateComObject(CLASS_BinaryWriter) as _BinaryWriter;\r\nend;\r\n\r\nclass function CoBinaryWriter.CreateRemote(const MachineName: string): _BinaryWriter;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_BinaryWriter) as _BinaryWriter;\r\nend;\r\n\r\nclass function CoBufferedStream.Create: _BufferedStream;\r\nbegin\r\n Result := CreateComObject(CLASS_BufferedStream) as _BufferedStream;\r\nend;\r\n\r\nclass function CoBufferedStream.CreateRemote(const MachineName: string): _BufferedStream;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_BufferedStream) as _BufferedStream;\r\nend;\r\n\r\nclass function CoDirectory.Create: _Directory;\r\nbegin\r\n Result := CreateComObject(CLASS_Directory) as _Directory;\r\nend;\r\n\r\nclass function CoDirectory.CreateRemote(const MachineName: string): _Directory;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_Directory) as _Directory;\r\nend;\r\n\r\nclass function CoFileSystemInfo.Create: _FileSystemInfo;\r\nbegin\r\n Result := CreateComObject(CLASS_FileSystemInfo) as _FileSystemInfo;\r\nend;\r\n\r\nclass function CoFileSystemInfo.CreateRemote(const MachineName: string): _FileSystemInfo;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_FileSystemInfo) as _FileSystemInfo;\r\nend;\r\n\r\nclass function CoDirectoryInfo.Create: _DirectoryInfo;\r\nbegin\r\n Result := CreateComObject(CLASS_DirectoryInfo) as _DirectoryInfo;\r\nend;\r\n\r\nclass function CoDirectoryInfo.CreateRemote(const MachineName: string): _DirectoryInfo;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_DirectoryInfo) as _DirectoryInfo;\r\nend;\r\n\r\nclass function CoIOException.Create: _IOException;\r\nbegin\r\n Result := CreateComObject(CLASS_IOException) as _IOException;\r\nend;\r\n\r\nclass function CoIOException.CreateRemote(const MachineName: string): _IOException;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_IOException) as _IOException;\r\nend;\r\n\r\nclass function CoDirectoryNotFoundException.Create: _DirectoryNotFoundException;\r\nbegin\r\n Result := CreateComObject(CLASS_DirectoryNotFoundException) as _DirectoryNotFoundException;\r\nend;\r\n\r\nclass function CoDirectoryNotFoundException.CreateRemote(const MachineName: string): _DirectoryNotFoundException;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_DirectoryNotFoundException) as _DirectoryNotFoundException;\r\nend;\r\n\r\nclass function CoEndOfStreamException.Create: _EndOfStreamException;\r\nbegin\r\n Result := CreateComObject(CLASS_EndOfStreamException) as _EndOfStreamException;\r\nend;\r\n\r\nclass function CoEndOfStreamException.CreateRemote(const MachineName: string): _EndOfStreamException;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_EndOfStreamException) as _EndOfStreamException;\r\nend;\r\n\r\nclass function CoFile_.Create: _File;\r\nbegin\r\n Result := CreateComObject(CLASS_File_) as _File;\r\nend;\r\n\r\nclass function CoFile_.CreateRemote(const MachineName: string): _File;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_File_) as _File;\r\nend;\r\n\r\nclass function CoFileInfo.Create: _FileInfo;\r\nbegin\r\n Result := CreateComObject(CLASS_FileInfo) as _FileInfo;\r\nend;\r\n\r\nclass function CoFileInfo.CreateRemote(const MachineName: string): _FileInfo;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_FileInfo) as _FileInfo;\r\nend;\r\n\r\nclass function CoFileLoadException.Create: _FileLoadException;\r\nbegin\r\n Result := CreateComObject(CLASS_FileLoadException) as _FileLoadException;\r\nend;\r\n\r\nclass function CoFileLoadException.CreateRemote(const MachineName: string): _FileLoadException;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_FileLoadException) as _FileLoadException;\r\nend;\r\n\r\nclass function CoFileNotFoundException.Create: _FileNotFoundException;\r\nbegin\r\n Result := CreateComObject(CLASS_FileNotFoundException) as _FileNotFoundException;\r\nend;\r\n\r\nclass function CoFileNotFoundException.CreateRemote(const MachineName: string): _FileNotFoundException;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_FileNotFoundException) as _FileNotFoundException;\r\nend;\r\n\r\nclass function CoFileStream.Create: _FileStream;\r\nbegin\r\n Result := CreateComObject(CLASS_FileStream) as _FileStream;\r\nend;\r\n\r\nclass function CoFileStream.CreateRemote(const MachineName: string): _FileStream;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_FileStream) as _FileStream;\r\nend;\r\n\r\nclass function CoMemoryStream.Create: _MemoryStream;\r\nbegin\r\n Result := CreateComObject(CLASS_MemoryStream) as _MemoryStream;\r\nend;\r\n\r\nclass function CoMemoryStream.CreateRemote(const MachineName: string): _MemoryStream;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_MemoryStream) as _MemoryStream;\r\nend;\r\n\r\nclass function CoPath.Create: _Path;\r\nbegin\r\n Result := CreateComObject(CLASS_Path) as _Path;\r\nend;\r\n\r\nclass function CoPath.CreateRemote(const MachineName: string): _Path;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_Path) as _Path;\r\nend;\r\n\r\nclass function CoPathTooLongException.Create: _PathTooLongException;\r\nbegin\r\n Result := CreateComObject(CLASS_PathTooLongException) as _PathTooLongException;\r\nend;\r\n\r\nclass function CoPathTooLongException.CreateRemote(const MachineName: string): _PathTooLongException;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_PathTooLongException) as _PathTooLongException;\r\nend;\r\n\r\nclass function CoTextReader.Create: _TextReader;\r\nbegin\r\n Result := CreateComObject(CLASS_TextReader) as _TextReader;\r\nend;\r\n\r\nclass function CoTextReader.CreateRemote(const MachineName: string): _TextReader;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_TextReader) as _TextReader;\r\nend;\r\n\r\nclass function CoStreamReader.Create: _StreamReader;\r\nbegin\r\n Result := CreateComObject(CLASS_StreamReader) as _StreamReader;\r\nend;\r\n\r\nclass function CoStreamReader.CreateRemote(const MachineName: string): _StreamReader;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_StreamReader) as _StreamReader;\r\nend;\r\n\r\nclass function CoTextWriter.Create: _TextWriter;\r\nbegin\r\n Result := CreateComObject(CLASS_TextWriter) as _TextWriter;\r\nend;\r\n\r\nclass function CoTextWriter.CreateRemote(const MachineName: string): _TextWriter;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_TextWriter) as _TextWriter;\r\nend;\r\n\r\nclass function CoStreamWriter.Create: _StreamWriter;\r\nbegin\r\n Result := CreateComObject(CLASS_StreamWriter) as _StreamWriter;\r\nend;\r\n\r\nclass function CoStreamWriter.CreateRemote(const MachineName: string): _StreamWriter;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_StreamWriter) as _StreamWriter;\r\nend;\r\n\r\nclass function CoStringReader.Create: _StringReader;\r\nbegin\r\n Result := CreateComObject(CLASS_StringReader) as _StringReader;\r\nend;\r\n\r\nclass function CoStringReader.CreateRemote(const MachineName: string): _StringReader;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_StringReader) as _StringReader;\r\nend;\r\n\r\nclass function CoStringWriter.Create: _StringWriter;\r\nbegin\r\n Result := CreateComObject(CLASS_StringWriter) as _StringWriter;\r\nend;\r\n\r\nclass function CoStringWriter.CreateRemote(const MachineName: string): _StringWriter;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_StringWriter) as _StringWriter;\r\nend;\r\n\r\nclass function CoAccessedThroughPropertyAttribute.Create: _AccessedThroughPropertyAttribute;\r\nbegin\r\n Result := CreateComObject(CLASS_AccessedThroughPropertyAttribute) as _AccessedThroughPropertyAttribute;\r\nend;\r\n\r\nclass function CoAccessedThroughPropertyAttribute.CreateRemote(const MachineName: string): _AccessedThroughPropertyAttribute;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_AccessedThroughPropertyAttribute) as _AccessedThroughPropertyAttribute;\r\nend;\r\n\r\nclass function CoCallConvCdecl.Create: _CallConvCdecl;\r\nbegin\r\n Result := CreateComObject(CLASS_CallConvCdecl) as _CallConvCdecl;\r\nend;\r\n\r\nclass function CoCallConvCdecl.CreateRemote(const MachineName: string): _CallConvCdecl;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_CallConvCdecl) as _CallConvCdecl;\r\nend;\r\n\r\nclass function CoCallConvStdcall.Create: _CallConvStdcall;\r\nbegin\r\n Result := CreateComObject(CLASS_CallConvStdcall) as _CallConvStdcall;\r\nend;\r\n\r\nclass function CoCallConvStdcall.CreateRemote(const MachineName: string): _CallConvStdcall;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_CallConvStdcall) as _CallConvStdcall;\r\nend;\r\n\r\nclass function CoCallConvThiscall.Create: _CallConvThiscall;\r\nbegin\r\n Result := CreateComObject(CLASS_CallConvThiscall) as _CallConvThiscall;\r\nend;\r\n\r\nclass function CoCallConvThiscall.CreateRemote(const MachineName: string): _CallConvThiscall;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_CallConvThiscall) as _CallConvThiscall;\r\nend;\r\n\r\nclass function CoCallConvFastcall.Create: _CallConvFastcall;\r\nbegin\r\n Result := CreateComObject(CLASS_CallConvFastcall) as _CallConvFastcall;\r\nend;\r\n\r\nclass function CoCallConvFastcall.CreateRemote(const MachineName: string): _CallConvFastcall;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_CallConvFastcall) as _CallConvFastcall;\r\nend;\r\n\r\nclass function CoRuntimeHelpers.Create: _RuntimeHelpers;\r\nbegin\r\n Result := CreateComObject(CLASS_RuntimeHelpers) as _RuntimeHelpers;\r\nend;\r\n\r\nclass function CoRuntimeHelpers.CreateRemote(const MachineName: string): _RuntimeHelpers;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_RuntimeHelpers) as _RuntimeHelpers;\r\nend;\r\n\r\nclass function CoCustomConstantAttribute.Create: _CustomConstantAttribute;\r\nbegin\r\n Result := CreateComObject(CLASS_CustomConstantAttribute) as _CustomConstantAttribute;\r\nend;\r\n\r\nclass function CoCustomConstantAttribute.CreateRemote(const MachineName: string): _CustomConstantAttribute;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_CustomConstantAttribute) as _CustomConstantAttribute;\r\nend;\r\n\r\nclass function CoDateTimeConstantAttribute.Create: _DateTimeConstantAttribute;\r\nbegin\r\n Result := CreateComObject(CLASS_DateTimeConstantAttribute) as _DateTimeConstantAttribute;\r\nend;\r\n\r\nclass function CoDateTimeConstantAttribute.CreateRemote(const MachineName: string): _DateTimeConstantAttribute;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_DateTimeConstantAttribute) as _DateTimeConstantAttribute;\r\nend;\r\n\r\nclass function CoDiscardableAttribute.Create: _DiscardableAttribute;\r\nbegin\r\n Result := CreateComObject(CLASS_DiscardableAttribute) as _DiscardableAttribute;\r\nend;\r\n\r\nclass function CoDiscardableAttribute.CreateRemote(const MachineName: string): _DiscardableAttribute;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_DiscardableAttribute) as _DiscardableAttribute;\r\nend;\r\n\r\nclass function CoDecimalConstantAttribute.Create: _DecimalConstantAttribute;\r\nbegin\r\n Result := CreateComObject(CLASS_DecimalConstantAttribute) as _DecimalConstantAttribute;\r\nend;\r\n\r\nclass function CoDecimalConstantAttribute.CreateRemote(const MachineName: string): _DecimalConstantAttribute;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_DecimalConstantAttribute) as _DecimalConstantAttribute;\r\nend;\r\n\r\nclass function CoCompilationRelaxationsAttribute.Create: _CompilationRelaxationsAttribute;\r\nbegin\r\n Result := CreateComObject(CLASS_CompilationRelaxationsAttribute) as _CompilationRelaxationsAttribute;\r\nend;\r\n\r\nclass function CoCompilationRelaxationsAttribute.CreateRemote(const MachineName: string): _CompilationRelaxationsAttribute;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_CompilationRelaxationsAttribute) as _CompilationRelaxationsAttribute;\r\nend;\r\n\r\nclass function CoCompilerGlobalScopeAttribute.Create: _CompilerGlobalScopeAttribute;\r\nbegin\r\n Result := CreateComObject(CLASS_CompilerGlobalScopeAttribute) as _CompilerGlobalScopeAttribute;\r\nend;\r\n\r\nclass function CoCompilerGlobalScopeAttribute.CreateRemote(const MachineName: string): _CompilerGlobalScopeAttribute;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_CompilerGlobalScopeAttribute) as _CompilerGlobalScopeAttribute;\r\nend;\r\n\r\nclass function CoIDispatchConstantAttribute.Create: _IDispatchConstantAttribute;\r\nbegin\r\n Result := CreateComObject(CLASS_IDispatchConstantAttribute) as _IDispatchConstantAttribute;\r\nend;\r\n\r\nclass function CoIDispatchConstantAttribute.CreateRemote(const MachineName: string): _IDispatchConstantAttribute;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_IDispatchConstantAttribute) as _IDispatchConstantAttribute;\r\nend;\r\n\r\nclass function CoIndexerNameAttribute.Create: _IndexerNameAttribute;\r\nbegin\r\n Result := CreateComObject(CLASS_IndexerNameAttribute) as _IndexerNameAttribute;\r\nend;\r\n\r\nclass function CoIndexerNameAttribute.CreateRemote(const MachineName: string): _IndexerNameAttribute;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_IndexerNameAttribute) as _IndexerNameAttribute;\r\nend;\r\n\r\nclass function CoIsVolatile.Create: _IsVolatile;\r\nbegin\r\n Result := CreateComObject(CLASS_IsVolatile) as _IsVolatile;\r\nend;\r\n\r\nclass function CoIsVolatile.CreateRemote(const MachineName: string): _IsVolatile;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_IsVolatile) as _IsVolatile;\r\nend;\r\n\r\nclass function CoIUnknownConstantAttribute.Create: _IUnknownConstantAttribute;\r\nbegin\r\n Result := CreateComObject(CLASS_IUnknownConstantAttribute) as _IUnknownConstantAttribute;\r\nend;\r\n\r\nclass function CoIUnknownConstantAttribute.CreateRemote(const MachineName: string): _IUnknownConstantAttribute;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_IUnknownConstantAttribute) as _IUnknownConstantAttribute;\r\nend;\r\n\r\nclass function CoMethodImplAttribute.Create: _MethodImplAttribute;\r\nbegin\r\n Result := CreateComObject(CLASS_MethodImplAttribute) as _MethodImplAttribute;\r\nend;\r\n\r\nclass function CoMethodImplAttribute.CreateRemote(const MachineName: string): _MethodImplAttribute;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_MethodImplAttribute) as _MethodImplAttribute;\r\nend;\r\n\r\nclass function CoRequiredAttributeAttribute.Create: _RequiredAttributeAttribute;\r\nbegin\r\n Result := CreateComObject(CLASS_RequiredAttributeAttribute) as _RequiredAttributeAttribute;\r\nend;\r\n\r\nclass function CoRequiredAttributeAttribute.CreateRemote(const MachineName: string): _RequiredAttributeAttribute;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_RequiredAttributeAttribute) as _RequiredAttributeAttribute;\r\nend;\r\n\r\nclass function CoPermissionSet.Create: _PermissionSet;\r\nbegin\r\n Result := CreateComObject(CLASS_PermissionSet) as _PermissionSet;\r\nend;\r\n\r\nclass function CoPermissionSet.CreateRemote(const MachineName: string): _PermissionSet;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_PermissionSet) as _PermissionSet;\r\nend;\r\n\r\nclass function CoNamedPermissionSet.Create: _NamedPermissionSet;\r\nbegin\r\n Result := CreateComObject(CLASS_NamedPermissionSet) as _NamedPermissionSet;\r\nend;\r\n\r\nclass function CoNamedPermissionSet.CreateRemote(const MachineName: string): _NamedPermissionSet;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_NamedPermissionSet) as _NamedPermissionSet;\r\nend;\r\n\r\nclass function CoSecurityElement.Create: _SecurityElement;\r\nbegin\r\n Result := CreateComObject(CLASS_SecurityElement) as _SecurityElement;\r\nend;\r\n\r\nclass function CoSecurityElement.CreateRemote(const MachineName: string): _SecurityElement;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_SecurityElement) as _SecurityElement;\r\nend;\r\n\r\nclass function CoXmlSyntaxException.Create: _XmlSyntaxException;\r\nbegin\r\n Result := CreateComObject(CLASS_XmlSyntaxException) as _XmlSyntaxException;\r\nend;\r\n\r\nclass function CoXmlSyntaxException.CreateRemote(const MachineName: string): _XmlSyntaxException;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_XmlSyntaxException) as _XmlSyntaxException;\r\nend;\r\n\r\nclass function CoCodeAccessPermission.Create: _CodeAccessPermission;\r\nbegin\r\n Result := CreateComObject(CLASS_CodeAccessPermission) as _CodeAccessPermission;\r\nend;\r\n\r\nclass function CoCodeAccessPermission.CreateRemote(const MachineName: string): _CodeAccessPermission;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_CodeAccessPermission) as _CodeAccessPermission;\r\nend;\r\n\r\nclass function CoEnvironmentPermission.Create: _EnvironmentPermission;\r\nbegin\r\n Result := CreateComObject(CLASS_EnvironmentPermission) as _EnvironmentPermission;\r\nend;\r\n\r\nclass function CoEnvironmentPermission.CreateRemote(const MachineName: string): _EnvironmentPermission;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_EnvironmentPermission) as _EnvironmentPermission;\r\nend;\r\n\r\nclass function CoFileDialogPermission.Create: _FileDialogPermission;\r\nbegin\r\n Result := CreateComObject(CLASS_FileDialogPermission) as _FileDialogPermission;\r\nend;\r\n\r\nclass function CoFileDialogPermission.CreateRemote(const MachineName: string): _FileDialogPermission;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_FileDialogPermission) as _FileDialogPermission;\r\nend;\r\n\r\nclass function CoFileIOPermission.Create: _FileIOPermission;\r\nbegin\r\n Result := CreateComObject(CLASS_FileIOPermission) as _FileIOPermission;\r\nend;\r\n\r\nclass function CoFileIOPermission.CreateRemote(const MachineName: string): _FileIOPermission;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_FileIOPermission) as _FileIOPermission;\r\nend;\r\n\r\nclass function CoIsolatedStoragePermission.Create: _IsolatedStoragePermission;\r\nbegin\r\n Result := CreateComObject(CLASS_IsolatedStoragePermission) as _IsolatedStoragePermission;\r\nend;\r\n\r\nclass function CoIsolatedStoragePermission.CreateRemote(const MachineName: string): _IsolatedStoragePermission;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_IsolatedStoragePermission) as _IsolatedStoragePermission;\r\nend;\r\n\r\nclass function CoIsolatedStorageFilePermission.Create: _IsolatedStorageFilePermission;\r\nbegin\r\n Result := CreateComObject(CLASS_IsolatedStorageFilePermission) as _IsolatedStorageFilePermission;\r\nend;\r\n\r\nclass function CoIsolatedStorageFilePermission.CreateRemote(const MachineName: string): _IsolatedStorageFilePermission;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_IsolatedStorageFilePermission) as _IsolatedStorageFilePermission;\r\nend;\r\n\r\nclass function CoSecurityAttribute.Create: _SecurityAttribute;\r\nbegin\r\n Result := CreateComObject(CLASS_SecurityAttribute) as _SecurityAttribute;\r\nend;\r\n\r\nclass function CoSecurityAttribute.CreateRemote(const MachineName: string): _SecurityAttribute;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_SecurityAttribute) as _SecurityAttribute;\r\nend;\r\n\r\nclass function CoCodeAccessSecurityAttribute.Create: _CodeAccessSecurityAttribute;\r\nbegin\r\n Result := CreateComObject(CLASS_CodeAccessSecurityAttribute) as _CodeAccessSecurityAttribute;\r\nend;\r\n\r\nclass function CoCodeAccessSecurityAttribute.CreateRemote(const MachineName: string): _CodeAccessSecurityAttribute;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_CodeAccessSecurityAttribute) as _CodeAccessSecurityAttribute;\r\nend;\r\n\r\nclass function CoEnvironmentPermissionAttribute.Create: _EnvironmentPermissionAttribute;\r\nbegin\r\n Result := CreateComObject(CLASS_EnvironmentPermissionAttribute) as _EnvironmentPermissionAttribute;\r\nend;\r\n\r\nclass function CoEnvironmentPermissionAttribute.CreateRemote(const MachineName: string): _EnvironmentPermissionAttribute;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_EnvironmentPermissionAttribute) as _EnvironmentPermissionAttribute;\r\nend;\r\n\r\nclass function CoFileDialogPermissionAttribute.Create: _FileDialogPermissionAttribute;\r\nbegin\r\n Result := CreateComObject(CLASS_FileDialogPermissionAttribute) as _FileDialogPermissionAttribute;\r\nend;\r\n\r\nclass function CoFileDialogPermissionAttribute.CreateRemote(const MachineName: string): _FileDialogPermissionAttribute;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_FileDialogPermissionAttribute) as _FileDialogPermissionAttribute;\r\nend;\r\n\r\nclass function CoFileIOPermissionAttribute.Create: _FileIOPermissionAttribute;\r\nbegin\r\n Result := CreateComObject(CLASS_FileIOPermissionAttribute) as _FileIOPermissionAttribute;\r\nend;\r\n\r\nclass function CoFileIOPermissionAttribute.CreateRemote(const MachineName: string): _FileIOPermissionAttribute;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_FileIOPermissionAttribute) as _FileIOPermissionAttribute;\r\nend;\r\n\r\nclass function CoPrincipalPermissionAttribute.Create: _PrincipalPermissionAttribute;\r\nbegin\r\n Result := CreateComObject(CLASS_PrincipalPermissionAttribute) as _PrincipalPermissionAttribute;\r\nend;\r\n\r\nclass function CoPrincipalPermissionAttribute.CreateRemote(const MachineName: string): _PrincipalPermissionAttribute;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_PrincipalPermissionAttribute) as _PrincipalPermissionAttribute;\r\nend;\r\n\r\nclass function CoReflectionPermissionAttribute.Create: _ReflectionPermissionAttribute;\r\nbegin\r\n Result := CreateComObject(CLASS_ReflectionPermissionAttribute) as _ReflectionPermissionAttribute;\r\nend;\r\n\r\nclass function CoReflectionPermissionAttribute.CreateRemote(const MachineName: string): _ReflectionPermissionAttribute;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_ReflectionPermissionAttribute) as _ReflectionPermissionAttribute;\r\nend;\r\n\r\nclass function CoRegistryPermissionAttribute.Create: _RegistryPermissionAttribute;\r\nbegin\r\n Result := CreateComObject(CLASS_RegistryPermissionAttribute) as _RegistryPermissionAttribute;\r\nend;\r\n\r\nclass function CoRegistryPermissionAttribute.CreateRemote(const MachineName: string): _RegistryPermissionAttribute;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_RegistryPermissionAttribute) as _RegistryPermissionAttribute;\r\nend;\r\n\r\nclass function CoSecurityPermissionAttribute.Create: _SecurityPermissionAttribute;\r\nbegin\r\n Result := CreateComObject(CLASS_SecurityPermissionAttribute) as _SecurityPermissionAttribute;\r\nend;\r\n\r\nclass function CoSecurityPermissionAttribute.CreateRemote(const MachineName: string): _SecurityPermissionAttribute;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_SecurityPermissionAttribute) as _SecurityPermissionAttribute;\r\nend;\r\n\r\nclass function CoUIPermissionAttribute.Create: _UIPermissionAttribute;\r\nbegin\r\n Result := CreateComObject(CLASS_UIPermissionAttribute) as _UIPermissionAttribute;\r\nend;\r\n\r\nclass function CoUIPermissionAttribute.CreateRemote(const MachineName: string): _UIPermissionAttribute;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_UIPermissionAttribute) as _UIPermissionAttribute;\r\nend;\r\n\r\nclass function CoZoneIdentityPermissionAttribute.Create: _ZoneIdentityPermissionAttribute;\r\nbegin\r\n Result := CreateComObject(CLASS_ZoneIdentityPermissionAttribute) as _ZoneIdentityPermissionAttribute;\r\nend;\r\n\r\nclass function CoZoneIdentityPermissionAttribute.CreateRemote(const MachineName: string): _ZoneIdentityPermissionAttribute;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_ZoneIdentityPermissionAttribute) as _ZoneIdentityPermissionAttribute;\r\nend;\r\n\r\nclass function CoStrongNameIdentityPermissionAttribute.Create: _StrongNameIdentityPermissionAttribute;\r\nbegin\r\n Result := CreateComObject(CLASS_StrongNameIdentityPermissionAttribute) as _StrongNameIdentityPermissionAttribute;\r\nend;\r\n\r\nclass function CoStrongNameIdentityPermissionAttribute.CreateRemote(const MachineName: string): _StrongNameIdentityPermissionAttribute;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_StrongNameIdentityPermissionAttribute) as _StrongNameIdentityPermissionAttribute;\r\nend;\r\n\r\nclass function CoSiteIdentityPermissionAttribute.Create: _SiteIdentityPermissionAttribute;\r\nbegin\r\n Result := CreateComObject(CLASS_SiteIdentityPermissionAttribute) as _SiteIdentityPermissionAttribute;\r\nend;\r\n\r\nclass function CoSiteIdentityPermissionAttribute.CreateRemote(const MachineName: string): _SiteIdentityPermissionAttribute;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_SiteIdentityPermissionAttribute) as _SiteIdentityPermissionAttribute;\r\nend;\r\n\r\nclass function CoUrlIdentityPermissionAttribute.Create: _UrlIdentityPermissionAttribute;\r\nbegin\r\n Result := CreateComObject(CLASS_UrlIdentityPermissionAttribute) as _UrlIdentityPermissionAttribute;\r\nend;\r\n\r\nclass function CoUrlIdentityPermissionAttribute.CreateRemote(const MachineName: string): _UrlIdentityPermissionAttribute;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_UrlIdentityPermissionAttribute) as _UrlIdentityPermissionAttribute;\r\nend;\r\n\r\nclass function CoPublisherIdentityPermissionAttribute.Create: _PublisherIdentityPermissionAttribute;\r\nbegin\r\n Result := CreateComObject(CLASS_PublisherIdentityPermissionAttribute) as _PublisherIdentityPermissionAttribute;\r\nend;\r\n\r\nclass function CoPublisherIdentityPermissionAttribute.CreateRemote(const MachineName: string): _PublisherIdentityPermissionAttribute;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_PublisherIdentityPermissionAttribute) as _PublisherIdentityPermissionAttribute;\r\nend;\r\n\r\nclass function CoIsolatedStoragePermissionAttribute.Create: _IsolatedStoragePermissionAttribute;\r\nbegin\r\n Result := CreateComObject(CLASS_IsolatedStoragePermissionAttribute) as _IsolatedStoragePermissionAttribute;\r\nend;\r\n\r\nclass function CoIsolatedStoragePermissionAttribute.CreateRemote(const MachineName: string): _IsolatedStoragePermissionAttribute;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_IsolatedStoragePermissionAttribute) as _IsolatedStoragePermissionAttribute;\r\nend;\r\n\r\nclass function CoIsolatedStorageFilePermissionAttribute.Create: _IsolatedStorageFilePermissionAttribute;\r\nbegin\r\n Result := CreateComObject(CLASS_IsolatedStorageFilePermissionAttribute) as _IsolatedStorageFilePermissionAttribute;\r\nend;\r\n\r\nclass function CoIsolatedStorageFilePermissionAttribute.CreateRemote(const MachineName: string): _IsolatedStorageFilePermissionAttribute;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_IsolatedStorageFilePermissionAttribute) as _IsolatedStorageFilePermissionAttribute;\r\nend;\r\n\r\nclass function CoPermissionSetAttribute.Create: _PermissionSetAttribute;\r\nbegin\r\n Result := CreateComObject(CLASS_PermissionSetAttribute) as _PermissionSetAttribute;\r\nend;\r\n\r\nclass function CoPermissionSetAttribute.CreateRemote(const MachineName: string): _PermissionSetAttribute;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_PermissionSetAttribute) as _PermissionSetAttribute;\r\nend;\r\n\r\nclass function CoPublisherIdentityPermission.Create: _PublisherIdentityPermission;\r\nbegin\r\n Result := CreateComObject(CLASS_PublisherIdentityPermission) as _PublisherIdentityPermission;\r\nend;\r\n\r\nclass function CoPublisherIdentityPermission.CreateRemote(const MachineName: string): _PublisherIdentityPermission;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_PublisherIdentityPermission) as _PublisherIdentityPermission;\r\nend;\r\n\r\nclass function CoReflectionPermission.Create: _ReflectionPermission;\r\nbegin\r\n Result := CreateComObject(CLASS_ReflectionPermission) as _ReflectionPermission;\r\nend;\r\n\r\nclass function CoReflectionPermission.CreateRemote(const MachineName: string): _ReflectionPermission;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_ReflectionPermission) as _ReflectionPermission;\r\nend;\r\n\r\nclass function CoRegistryPermission.Create: _RegistryPermission;\r\nbegin\r\n Result := CreateComObject(CLASS_RegistryPermission) as _RegistryPermission;\r\nend;\r\n\r\nclass function CoRegistryPermission.CreateRemote(const MachineName: string): _RegistryPermission;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_RegistryPermission) as _RegistryPermission;\r\nend;\r\n\r\nclass function CoPrincipalPermission.Create: _PrincipalPermission;\r\nbegin\r\n Result := CreateComObject(CLASS_PrincipalPermission) as _PrincipalPermission;\r\nend;\r\n\r\nclass function CoPrincipalPermission.CreateRemote(const MachineName: string): _PrincipalPermission;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_PrincipalPermission) as _PrincipalPermission;\r\nend;\r\n\r\nclass function CoSecurityPermission.Create: _SecurityPermission;\r\nbegin\r\n Result := CreateComObject(CLASS_SecurityPermission) as _SecurityPermission;\r\nend;\r\n\r\nclass function CoSecurityPermission.CreateRemote(const MachineName: string): _SecurityPermission;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_SecurityPermission) as _SecurityPermission;\r\nend;\r\n\r\nclass function CoSiteIdentityPermission.Create: _SiteIdentityPermission;\r\nbegin\r\n Result := CreateComObject(CLASS_SiteIdentityPermission) as _SiteIdentityPermission;\r\nend;\r\n\r\nclass function CoSiteIdentityPermission.CreateRemote(const MachineName: string): _SiteIdentityPermission;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_SiteIdentityPermission) as _SiteIdentityPermission;\r\nend;\r\n\r\nclass function CoStrongNameIdentityPermission.Create: _StrongNameIdentityPermission;\r\nbegin\r\n Result := CreateComObject(CLASS_StrongNameIdentityPermission) as _StrongNameIdentityPermission;\r\nend;\r\n\r\nclass function CoStrongNameIdentityPermission.CreateRemote(const MachineName: string): _StrongNameIdentityPermission;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_StrongNameIdentityPermission) as _StrongNameIdentityPermission;\r\nend;\r\n\r\nclass function CoStrongNamePublicKeyBlob.Create: _StrongNamePublicKeyBlob;\r\nbegin\r\n Result := CreateComObject(CLASS_StrongNamePublicKeyBlob) as _StrongNamePublicKeyBlob;\r\nend;\r\n\r\nclass function CoStrongNamePublicKeyBlob.CreateRemote(const MachineName: string): _StrongNamePublicKeyBlob;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_StrongNamePublicKeyBlob) as _StrongNamePublicKeyBlob;\r\nend;\r\n\r\nclass function CoUIPermission.Create: _UIPermission;\r\nbegin\r\n Result := CreateComObject(CLASS_UIPermission) as _UIPermission;\r\nend;\r\n\r\nclass function CoUIPermission.CreateRemote(const MachineName: string): _UIPermission;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_UIPermission) as _UIPermission;\r\nend;\r\n\r\nclass function CoUrlIdentityPermission.Create: _UrlIdentityPermission;\r\nbegin\r\n Result := CreateComObject(CLASS_UrlIdentityPermission) as _UrlIdentityPermission;\r\nend;\r\n\r\nclass function CoUrlIdentityPermission.CreateRemote(const MachineName: string): _UrlIdentityPermission;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_UrlIdentityPermission) as _UrlIdentityPermission;\r\nend;\r\n\r\nclass function CoZoneIdentityPermission.Create: _ZoneIdentityPermission;\r\nbegin\r\n Result := CreateComObject(CLASS_ZoneIdentityPermission) as _ZoneIdentityPermission;\r\nend;\r\n\r\nclass function CoZoneIdentityPermission.CreateRemote(const MachineName: string): _ZoneIdentityPermission;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_ZoneIdentityPermission) as _ZoneIdentityPermission;\r\nend;\r\n\r\nclass function CoSuppressUnmanagedCodeSecurityAttribute.Create: _SuppressUnmanagedCodeSecurityAttribute;\r\nbegin\r\n Result := CreateComObject(CLASS_SuppressUnmanagedCodeSecurityAttribute) as _SuppressUnmanagedCodeSecurityAttribute;\r\nend;\r\n\r\nclass function CoSuppressUnmanagedCodeSecurityAttribute.CreateRemote(const MachineName: string): _SuppressUnmanagedCodeSecurityAttribute;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_SuppressUnmanagedCodeSecurityAttribute) as _SuppressUnmanagedCodeSecurityAttribute;\r\nend;\r\n\r\nclass function CoUnverifiableCodeAttribute.Create: _UnverifiableCodeAttribute;\r\nbegin\r\n Result := CreateComObject(CLASS_UnverifiableCodeAttribute) as _UnverifiableCodeAttribute;\r\nend;\r\n\r\nclass function CoUnverifiableCodeAttribute.CreateRemote(const MachineName: string): _UnverifiableCodeAttribute;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_UnverifiableCodeAttribute) as _UnverifiableCodeAttribute;\r\nend;\r\n\r\nclass function CoAllowPartiallyTrustedCallersAttribute.Create: _AllowPartiallyTrustedCallersAttribute;\r\nbegin\r\n Result := CreateComObject(CLASS_AllowPartiallyTrustedCallersAttribute) as _AllowPartiallyTrustedCallersAttribute;\r\nend;\r\n\r\nclass function CoAllowPartiallyTrustedCallersAttribute.CreateRemote(const MachineName: string): _AllowPartiallyTrustedCallersAttribute;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_AllowPartiallyTrustedCallersAttribute) as _AllowPartiallyTrustedCallersAttribute;\r\nend;\r\n\r\nclass function CoSecurityException.Create: _SecurityException;\r\nbegin\r\n Result := CreateComObject(CLASS_SecurityException) as _SecurityException;\r\nend;\r\n\r\nclass function CoSecurityException.CreateRemote(const MachineName: string): _SecurityException;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_SecurityException) as _SecurityException;\r\nend;\r\n\r\nclass function CoSecurityManager.Create: _SecurityManager;\r\nbegin\r\n Result := CreateComObject(CLASS_SecurityManager) as _SecurityManager;\r\nend;\r\n\r\nclass function CoSecurityManager.CreateRemote(const MachineName: string): _SecurityManager;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_SecurityManager) as _SecurityManager;\r\nend;\r\n\r\nclass function CoVerificationException.Create: _VerificationException;\r\nbegin\r\n Result := CreateComObject(CLASS_VerificationException) as _VerificationException;\r\nend;\r\n\r\nclass function CoVerificationException.CreateRemote(const MachineName: string): _VerificationException;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_VerificationException) as _VerificationException;\r\nend;\r\n\r\nclass function CoContextAttribute.Create: _ContextAttribute;\r\nbegin\r\n Result := CreateComObject(CLASS_ContextAttribute) as _ContextAttribute;\r\nend;\r\n\r\nclass function CoContextAttribute.CreateRemote(const MachineName: string): _ContextAttribute;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_ContextAttribute) as _ContextAttribute;\r\nend;\r\n\r\nclass function CoAsyncResult.Create: _AsyncResult;\r\nbegin\r\n Result := CreateComObject(CLASS_AsyncResult) as _AsyncResult;\r\nend;\r\n\r\nclass function CoAsyncResult.CreateRemote(const MachineName: string): _AsyncResult;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_AsyncResult) as _AsyncResult;\r\nend;\r\n\r\nclass function CoCallContext.Create: _CallContext;\r\nbegin\r\n Result := CreateComObject(CLASS_CallContext) as _CallContext;\r\nend;\r\n\r\nclass function CoCallContext.CreateRemote(const MachineName: string): _CallContext;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_CallContext) as _CallContext;\r\nend;\r\n\r\nclass function CoLogicalCallContext.Create: _LogicalCallContext;\r\nbegin\r\n Result := CreateComObject(CLASS_LogicalCallContext) as _LogicalCallContext;\r\nend;\r\n\r\nclass function CoLogicalCallContext.CreateRemote(const MachineName: string): _LogicalCallContext;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_LogicalCallContext) as _LogicalCallContext;\r\nend;\r\n\r\nclass function CoChannelServices.Create: _ChannelServices;\r\nbegin\r\n Result := CreateComObject(CLASS_ChannelServices) as _ChannelServices;\r\nend;\r\n\r\nclass function CoChannelServices.CreateRemote(const MachineName: string): _ChannelServices;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_ChannelServices) as _ChannelServices;\r\nend;\r\n\r\nclass function CoClientChannelSinkStack.Create: _ClientChannelSinkStack;\r\nbegin\r\n Result := CreateComObject(CLASS_ClientChannelSinkStack) as _ClientChannelSinkStack;\r\nend;\r\n\r\nclass function CoClientChannelSinkStack.CreateRemote(const MachineName: string): _ClientChannelSinkStack;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_ClientChannelSinkStack) as _ClientChannelSinkStack;\r\nend;\r\n\r\nclass function CoServerChannelSinkStack.Create: _ServerChannelSinkStack;\r\nbegin\r\n Result := CreateComObject(CLASS_ServerChannelSinkStack) as _ServerChannelSinkStack;\r\nend;\r\n\r\nclass function CoServerChannelSinkStack.CreateRemote(const MachineName: string): _ServerChannelSinkStack;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_ServerChannelSinkStack) as _ServerChannelSinkStack;\r\nend;\r\n\r\nclass function CoInternalMessageWrapper.Create: _InternalMessageWrapper;\r\nbegin\r\n Result := CreateComObject(CLASS_InternalMessageWrapper) as _InternalMessageWrapper;\r\nend;\r\n\r\nclass function CoInternalMessageWrapper.CreateRemote(const MachineName: string): _InternalMessageWrapper;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_InternalMessageWrapper) as _InternalMessageWrapper;\r\nend;\r\n\r\nclass function CoMethodCallMessageWrapper.Create: _MethodCallMessageWrapper;\r\nbegin\r\n Result := CreateComObject(CLASS_MethodCallMessageWrapper) as _MethodCallMessageWrapper;\r\nend;\r\n\r\nclass function CoMethodCallMessageWrapper.CreateRemote(const MachineName: string): _MethodCallMessageWrapper;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_MethodCallMessageWrapper) as _MethodCallMessageWrapper;\r\nend;\r\n\r\nclass function CoClientSponsor.Create: _ClientSponsor;\r\nbegin\r\n Result := CreateComObject(CLASS_ClientSponsor) as _ClientSponsor;\r\nend;\r\n\r\nclass function CoClientSponsor.CreateRemote(const MachineName: string): _ClientSponsor;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_ClientSponsor) as _ClientSponsor;\r\nend;\r\n\r\nclass function CoCrossContextDelegate.Create: _CrossContextDelegate;\r\nbegin\r\n Result := CreateComObject(CLASS_CrossContextDelegate) as _CrossContextDelegate;\r\nend;\r\n\r\nclass function CoCrossContextDelegate.CreateRemote(const MachineName: string): _CrossContextDelegate;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_CrossContextDelegate) as _CrossContextDelegate;\r\nend;\r\n\r\nclass function CoContext.Create: _Context;\r\nbegin\r\n Result := CreateComObject(CLASS_Context) as _Context;\r\nend;\r\n\r\nclass function CoContext.CreateRemote(const MachineName: string): _Context;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_Context) as _Context;\r\nend;\r\n\r\nclass function CoContextProperty.Create: _ContextProperty;\r\nbegin\r\n Result := CreateComObject(CLASS_ContextProperty) as _ContextProperty;\r\nend;\r\n\r\nclass function CoContextProperty.CreateRemote(const MachineName: string): _ContextProperty;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_ContextProperty) as _ContextProperty;\r\nend;\r\n\r\nclass function CoEnterpriseServicesHelper.Create: _EnterpriseServicesHelper;\r\nbegin\r\n Result := CreateComObject(CLASS_EnterpriseServicesHelper) as _EnterpriseServicesHelper;\r\nend;\r\n\r\nclass function CoEnterpriseServicesHelper.CreateRemote(const MachineName: string): _EnterpriseServicesHelper;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_EnterpriseServicesHelper) as _EnterpriseServicesHelper;\r\nend;\r\n\r\nclass function CoHeader.Create: _Header;\r\nbegin\r\n Result := CreateComObject(CLASS_Header) as _Header;\r\nend;\r\n\r\nclass function CoHeader.CreateRemote(const MachineName: string): _Header;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_Header) as _Header;\r\nend;\r\n\r\nclass function CoHeaderHandler.Create: _HeaderHandler;\r\nbegin\r\n Result := CreateComObject(CLASS_HeaderHandler) as _HeaderHandler;\r\nend;\r\n\r\nclass function CoHeaderHandler.CreateRemote(const MachineName: string): _HeaderHandler;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_HeaderHandler) as _HeaderHandler;\r\nend;\r\n\r\nclass function CoChannelDataStore.Create: _ChannelDataStore;\r\nbegin\r\n Result := CreateComObject(CLASS_ChannelDataStore) as _ChannelDataStore;\r\nend;\r\n\r\nclass function CoChannelDataStore.CreateRemote(const MachineName: string): _ChannelDataStore;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_ChannelDataStore) as _ChannelDataStore;\r\nend;\r\n\r\nclass function CoTransportHeaders.Create: _TransportHeaders;\r\nbegin\r\n Result := CreateComObject(CLASS_TransportHeaders) as _TransportHeaders;\r\nend;\r\n\r\nclass function CoTransportHeaders.CreateRemote(const MachineName: string): _TransportHeaders;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_TransportHeaders) as _TransportHeaders;\r\nend;\r\n\r\nclass function CoSinkProviderData.Create: _SinkProviderData;\r\nbegin\r\n Result := CreateComObject(CLASS_SinkProviderData) as _SinkProviderData;\r\nend;\r\n\r\nclass function CoSinkProviderData.CreateRemote(const MachineName: string): _SinkProviderData;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_SinkProviderData) as _SinkProviderData;\r\nend;\r\n\r\nclass function CoBaseChannelObjectWithProperties.Create: _BaseChannelObjectWithProperties;\r\nbegin\r\n Result := CreateComObject(CLASS_BaseChannelObjectWithProperties) as _BaseChannelObjectWithProperties;\r\nend;\r\n\r\nclass function CoBaseChannelObjectWithProperties.CreateRemote(const MachineName: string): _BaseChannelObjectWithProperties;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_BaseChannelObjectWithProperties) as _BaseChannelObjectWithProperties;\r\nend;\r\n\r\nclass function CoBaseChannelSinkWithProperties.Create: _BaseChannelSinkWithProperties;\r\nbegin\r\n Result := CreateComObject(CLASS_BaseChannelSinkWithProperties) as _BaseChannelSinkWithProperties;\r\nend;\r\n\r\nclass function CoBaseChannelSinkWithProperties.CreateRemote(const MachineName: string): _BaseChannelSinkWithProperties;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_BaseChannelSinkWithProperties) as _BaseChannelSinkWithProperties;\r\nend;\r\n\r\nclass function CoBaseChannelWithProperties.Create: _BaseChannelWithProperties;\r\nbegin\r\n Result := CreateComObject(CLASS_BaseChannelWithProperties) as _BaseChannelWithProperties;\r\nend;\r\n\r\nclass function CoBaseChannelWithProperties.CreateRemote(const MachineName: string): _BaseChannelWithProperties;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_BaseChannelWithProperties) as _BaseChannelWithProperties;\r\nend;\r\n\r\nclass function CoLifetimeServices.Create: _LifetimeServices;\r\nbegin\r\n Result := CreateComObject(CLASS_LifetimeServices) as _LifetimeServices;\r\nend;\r\n\r\nclass function CoLifetimeServices.CreateRemote(const MachineName: string): _LifetimeServices;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_LifetimeServices) as _LifetimeServices;\r\nend;\r\n\r\nclass function CoReturnMessage.Create: _ReturnMessage;\r\nbegin\r\n Result := CreateComObject(CLASS_ReturnMessage) as _ReturnMessage;\r\nend;\r\n\r\nclass function CoReturnMessage.CreateRemote(const MachineName: string): _ReturnMessage;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_ReturnMessage) as _ReturnMessage;\r\nend;\r\n\r\nclass function CoMethodCall.Create: _MethodCall;\r\nbegin\r\n Result := CreateComObject(CLASS_MethodCall) as _MethodCall;\r\nend;\r\n\r\nclass function CoMethodCall.CreateRemote(const MachineName: string): _MethodCall;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_MethodCall) as _MethodCall;\r\nend;\r\n\r\nclass function CoConstructionCall.Create: _ConstructionCall;\r\nbegin\r\n Result := CreateComObject(CLASS_ConstructionCall) as _ConstructionCall;\r\nend;\r\n\r\nclass function CoConstructionCall.CreateRemote(const MachineName: string): _ConstructionCall;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_ConstructionCall) as _ConstructionCall;\r\nend;\r\n\r\nclass function CoMethodResponse.Create: _MethodResponse;\r\nbegin\r\n Result := CreateComObject(CLASS_MethodResponse) as _MethodResponse;\r\nend;\r\n\r\nclass function CoMethodResponse.CreateRemote(const MachineName: string): _MethodResponse;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_MethodResponse) as _MethodResponse;\r\nend;\r\n\r\nclass function CoConstructionResponse.Create: _ConstructionResponse;\r\nbegin\r\n Result := CreateComObject(CLASS_ConstructionResponse) as _ConstructionResponse;\r\nend;\r\n\r\nclass function CoConstructionResponse.CreateRemote(const MachineName: string): _ConstructionResponse;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_ConstructionResponse) as _ConstructionResponse;\r\nend;\r\n\r\nclass function CoMethodReturnMessageWrapper.Create: _MethodReturnMessageWrapper;\r\nbegin\r\n Result := CreateComObject(CLASS_MethodReturnMessageWrapper) as _MethodReturnMessageWrapper;\r\nend;\r\n\r\nclass function CoMethodReturnMessageWrapper.CreateRemote(const MachineName: string): _MethodReturnMessageWrapper;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_MethodReturnMessageWrapper) as _MethodReturnMessageWrapper;\r\nend;\r\n\r\nclass function CoObjectHandle.Create: _ObjectHandle;\r\nbegin\r\n Result := CreateComObject(CLASS_ObjectHandle) as _ObjectHandle;\r\nend;\r\n\r\nclass function CoObjectHandle.CreateRemote(const MachineName: string): _ObjectHandle;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_ObjectHandle) as _ObjectHandle;\r\nend;\r\n\r\nclass function CoObjRef.Create: _ObjRef;\r\nbegin\r\n Result := CreateComObject(CLASS_ObjRef) as _ObjRef;\r\nend;\r\n\r\nclass function CoObjRef.CreateRemote(const MachineName: string): _ObjRef;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_ObjRef) as _ObjRef;\r\nend;\r\n\r\nclass function CoOneWayAttribute.Create: _OneWayAttribute;\r\nbegin\r\n Result := CreateComObject(CLASS_OneWayAttribute) as _OneWayAttribute;\r\nend;\r\n\r\nclass function CoOneWayAttribute.CreateRemote(const MachineName: string): _OneWayAttribute;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_OneWayAttribute) as _OneWayAttribute;\r\nend;\r\n\r\nclass function CoProxyAttribute.Create: _ProxyAttribute;\r\nbegin\r\n Result := CreateComObject(CLASS_ProxyAttribute) as _ProxyAttribute;\r\nend;\r\n\r\nclass function CoProxyAttribute.CreateRemote(const MachineName: string): _ProxyAttribute;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_ProxyAttribute) as _ProxyAttribute;\r\nend;\r\n\r\nclass function CoRealProxy.Create: _RealProxy;\r\nbegin\r\n Result := CreateComObject(CLASS_RealProxy) as _RealProxy;\r\nend;\r\n\r\nclass function CoRealProxy.CreateRemote(const MachineName: string): _RealProxy;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_RealProxy) as _RealProxy;\r\nend;\r\n\r\nclass function CoSoapAttribute.Create: _SoapAttribute;\r\nbegin\r\n Result := CreateComObject(CLASS_SoapAttribute) as _SoapAttribute;\r\nend;\r\n\r\nclass function CoSoapAttribute.CreateRemote(const MachineName: string): _SoapAttribute;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_SoapAttribute) as _SoapAttribute;\r\nend;\r\n\r\nclass function CoSoapTypeAttribute.Create: _SoapTypeAttribute;\r\nbegin\r\n Result := CreateComObject(CLASS_SoapTypeAttribute) as _SoapTypeAttribute;\r\nend;\r\n\r\nclass function CoSoapTypeAttribute.CreateRemote(const MachineName: string): _SoapTypeAttribute;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_SoapTypeAttribute) as _SoapTypeAttribute;\r\nend;\r\n\r\nclass function CoSoapMethodAttribute.Create: _SoapMethodAttribute;\r\nbegin\r\n Result := CreateComObject(CLASS_SoapMethodAttribute) as _SoapMethodAttribute;\r\nend;\r\n\r\nclass function CoSoapMethodAttribute.CreateRemote(const MachineName: string): _SoapMethodAttribute;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_SoapMethodAttribute) as _SoapMethodAttribute;\r\nend;\r\n\r\nclass function CoSoapFieldAttribute.Create: _SoapFieldAttribute;\r\nbegin\r\n Result := CreateComObject(CLASS_SoapFieldAttribute) as _SoapFieldAttribute;\r\nend;\r\n\r\nclass function CoSoapFieldAttribute.CreateRemote(const MachineName: string): _SoapFieldAttribute;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_SoapFieldAttribute) as _SoapFieldAttribute;\r\nend;\r\n\r\nclass function CoSoapParameterAttribute.Create: _SoapParameterAttribute;\r\nbegin\r\n Result := CreateComObject(CLASS_SoapParameterAttribute) as _SoapParameterAttribute;\r\nend;\r\n\r\nclass function CoSoapParameterAttribute.CreateRemote(const MachineName: string): _SoapParameterAttribute;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_SoapParameterAttribute) as _SoapParameterAttribute;\r\nend;\r\n\r\nclass function CoRemotingConfiguration.Create: _RemotingConfiguration;\r\nbegin\r\n Result := CreateComObject(CLASS_RemotingConfiguration) as _RemotingConfiguration;\r\nend;\r\n\r\nclass function CoRemotingConfiguration.CreateRemote(const MachineName: string): _RemotingConfiguration;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_RemotingConfiguration) as _RemotingConfiguration;\r\nend;\r\n\r\nclass function CoSystem_Runtime_Remoting_TypeEntry.Create: _System_Runtime_Remoting_TypeEntry;\r\nbegin\r\n Result := CreateComObject(CLASS_System_Runtime_Remoting_TypeEntry) as _System_Runtime_Remoting_TypeEntry;\r\nend;\r\n\r\nclass function CoSystem_Runtime_Remoting_TypeEntry.CreateRemote(const MachineName: string): _System_Runtime_Remoting_TypeEntry;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_System_Runtime_Remoting_TypeEntry) as _System_Runtime_Remoting_TypeEntry;\r\nend;\r\n\r\nclass function CoActivatedClientTypeEntry.Create: _ActivatedClientTypeEntry;\r\nbegin\r\n Result := CreateComObject(CLASS_ActivatedClientTypeEntry) as _ActivatedClientTypeEntry;\r\nend;\r\n\r\nclass function CoActivatedClientTypeEntry.CreateRemote(const MachineName: string): _ActivatedClientTypeEntry;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_ActivatedClientTypeEntry) as _ActivatedClientTypeEntry;\r\nend;\r\n\r\nclass function CoActivatedServiceTypeEntry.Create: _ActivatedServiceTypeEntry;\r\nbegin\r\n Result := CreateComObject(CLASS_ActivatedServiceTypeEntry) as _ActivatedServiceTypeEntry;\r\nend;\r\n\r\nclass function CoActivatedServiceTypeEntry.CreateRemote(const MachineName: string): _ActivatedServiceTypeEntry;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_ActivatedServiceTypeEntry) as _ActivatedServiceTypeEntry;\r\nend;\r\n\r\nclass function CoWellKnownClientTypeEntry.Create: _WellKnownClientTypeEntry;\r\nbegin\r\n Result := CreateComObject(CLASS_WellKnownClientTypeEntry) as _WellKnownClientTypeEntry;\r\nend;\r\n\r\nclass function CoWellKnownClientTypeEntry.CreateRemote(const MachineName: string): _WellKnownClientTypeEntry;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_WellKnownClientTypeEntry) as _WellKnownClientTypeEntry;\r\nend;\r\n\r\nclass function CoWellKnownServiceTypeEntry.Create: _WellKnownServiceTypeEntry;\r\nbegin\r\n Result := CreateComObject(CLASS_WellKnownServiceTypeEntry) as _WellKnownServiceTypeEntry;\r\nend;\r\n\r\nclass function CoWellKnownServiceTypeEntry.CreateRemote(const MachineName: string): _WellKnownServiceTypeEntry;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_WellKnownServiceTypeEntry) as _WellKnownServiceTypeEntry;\r\nend;\r\n\r\nclass function CoRemotingException.Create: _RemotingException;\r\nbegin\r\n Result := CreateComObject(CLASS_RemotingException) as _RemotingException;\r\nend;\r\n\r\nclass function CoRemotingException.CreateRemote(const MachineName: string): _RemotingException;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_RemotingException) as _RemotingException;\r\nend;\r\n\r\nclass function CoServerException.Create: _ServerException;\r\nbegin\r\n Result := CreateComObject(CLASS_ServerException) as _ServerException;\r\nend;\r\n\r\nclass function CoServerException.CreateRemote(const MachineName: string): _ServerException;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_ServerException) as _ServerException;\r\nend;\r\n\r\nclass function CoRemotingTimeoutException.Create: _RemotingTimeoutException;\r\nbegin\r\n Result := CreateComObject(CLASS_RemotingTimeoutException) as _RemotingTimeoutException;\r\nend;\r\n\r\nclass function CoRemotingTimeoutException.CreateRemote(const MachineName: string): _RemotingTimeoutException;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_RemotingTimeoutException) as _RemotingTimeoutException;\r\nend;\r\n\r\nclass function CoRemotingServices.Create: _RemotingServices;\r\nbegin\r\n Result := CreateComObject(CLASS_RemotingServices) as _RemotingServices;\r\nend;\r\n\r\nclass function CoRemotingServices.CreateRemote(const MachineName: string): _RemotingServices;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_RemotingServices) as _RemotingServices;\r\nend;\r\n\r\nclass function CoInternalRemotingServices.Create: _InternalRemotingServices;\r\nbegin\r\n Result := CreateComObject(CLASS_InternalRemotingServices) as _InternalRemotingServices;\r\nend;\r\n\r\nclass function CoInternalRemotingServices.CreateRemote(const MachineName: string): _InternalRemotingServices;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_InternalRemotingServices) as _InternalRemotingServices;\r\nend;\r\n\r\nclass function CoMessageSurrogateFilter.Create: _MessageSurrogateFilter;\r\nbegin\r\n Result := CreateComObject(CLASS_MessageSurrogateFilter) as _MessageSurrogateFilter;\r\nend;\r\n\r\nclass function CoMessageSurrogateFilter.CreateRemote(const MachineName: string): _MessageSurrogateFilter;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_MessageSurrogateFilter) as _MessageSurrogateFilter;\r\nend;\r\n\r\nclass function CoRemotingSurrogateSelector.Create: _RemotingSurrogateSelector;\r\nbegin\r\n Result := CreateComObject(CLASS_RemotingSurrogateSelector) as _RemotingSurrogateSelector;\r\nend;\r\n\r\nclass function CoRemotingSurrogateSelector.CreateRemote(const MachineName: string): _RemotingSurrogateSelector;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_RemotingSurrogateSelector) as _RemotingSurrogateSelector;\r\nend;\r\n\r\nclass function CoSoapServices.Create: _SoapServices;\r\nbegin\r\n Result := CreateComObject(CLASS_SoapServices) as _SoapServices;\r\nend;\r\n\r\nclass function CoSoapServices.CreateRemote(const MachineName: string): _SoapServices;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_SoapServices) as _SoapServices;\r\nend;\r\n\r\nclass function CoSoapDateTime.Create: _SoapDateTime;\r\nbegin\r\n Result := CreateComObject(CLASS_SoapDateTime) as _SoapDateTime;\r\nend;\r\n\r\nclass function CoSoapDateTime.CreateRemote(const MachineName: string): _SoapDateTime;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_SoapDateTime) as _SoapDateTime;\r\nend;\r\n\r\nclass function CoSoapDuration.Create: _SoapDuration;\r\nbegin\r\n Result := CreateComObject(CLASS_SoapDuration) as _SoapDuration;\r\nend;\r\n\r\nclass function CoSoapDuration.CreateRemote(const MachineName: string): _SoapDuration;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_SoapDuration) as _SoapDuration;\r\nend;\r\n\r\nclass function CoSoapTime.Create: _SoapTime;\r\nbegin\r\n Result := CreateComObject(CLASS_SoapTime) as _SoapTime;\r\nend;\r\n\r\nclass function CoSoapTime.CreateRemote(const MachineName: string): _SoapTime;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_SoapTime) as _SoapTime;\r\nend;\r\n\r\nclass function CoSoapDate.Create: _SoapDate;\r\nbegin\r\n Result := CreateComObject(CLASS_SoapDate) as _SoapDate;\r\nend;\r\n\r\nclass function CoSoapDate.CreateRemote(const MachineName: string): _SoapDate;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_SoapDate) as _SoapDate;\r\nend;\r\n\r\nclass function CoSoapYearMonth.Create: _SoapYearMonth;\r\nbegin\r\n Result := CreateComObject(CLASS_SoapYearMonth) as _SoapYearMonth;\r\nend;\r\n\r\nclass function CoSoapYearMonth.CreateRemote(const MachineName: string): _SoapYearMonth;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_SoapYearMonth) as _SoapYearMonth;\r\nend;\r\n\r\nclass function CoSoapYear.Create: _SoapYear;\r\nbegin\r\n Result := CreateComObject(CLASS_SoapYear) as _SoapYear;\r\nend;\r\n\r\nclass function CoSoapYear.CreateRemote(const MachineName: string): _SoapYear;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_SoapYear) as _SoapYear;\r\nend;\r\n\r\nclass function CoSoapMonthDay.Create: _SoapMonthDay;\r\nbegin\r\n Result := CreateComObject(CLASS_SoapMonthDay) as _SoapMonthDay;\r\nend;\r\n\r\nclass function CoSoapMonthDay.CreateRemote(const MachineName: string): _SoapMonthDay;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_SoapMonthDay) as _SoapMonthDay;\r\nend;\r\n\r\nclass function CoSoapDay.Create: _SoapDay;\r\nbegin\r\n Result := CreateComObject(CLASS_SoapDay) as _SoapDay;\r\nend;\r\n\r\nclass function CoSoapDay.CreateRemote(const MachineName: string): _SoapDay;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_SoapDay) as _SoapDay;\r\nend;\r\n\r\nclass function CoSoapMonth.Create: _SoapMonth;\r\nbegin\r\n Result := CreateComObject(CLASS_SoapMonth) as _SoapMonth;\r\nend;\r\n\r\nclass function CoSoapMonth.CreateRemote(const MachineName: string): _SoapMonth;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_SoapMonth) as _SoapMonth;\r\nend;\r\n\r\nclass function CoSoapHexBinary.Create: _SoapHexBinary;\r\nbegin\r\n Result := CreateComObject(CLASS_SoapHexBinary) as _SoapHexBinary;\r\nend;\r\n\r\nclass function CoSoapHexBinary.CreateRemote(const MachineName: string): _SoapHexBinary;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_SoapHexBinary) as _SoapHexBinary;\r\nend;\r\n\r\nclass function CoSoapBase64Binary.Create: _SoapBase64Binary;\r\nbegin\r\n Result := CreateComObject(CLASS_SoapBase64Binary) as _SoapBase64Binary;\r\nend;\r\n\r\nclass function CoSoapBase64Binary.CreateRemote(const MachineName: string): _SoapBase64Binary;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_SoapBase64Binary) as _SoapBase64Binary;\r\nend;\r\n\r\nclass function CoSoapInteger.Create: _SoapInteger;\r\nbegin\r\n Result := CreateComObject(CLASS_SoapInteger) as _SoapInteger;\r\nend;\r\n\r\nclass function CoSoapInteger.CreateRemote(const MachineName: string): _SoapInteger;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_SoapInteger) as _SoapInteger;\r\nend;\r\n\r\nclass function CoSoapPositiveInteger.Create: _SoapPositiveInteger;\r\nbegin\r\n Result := CreateComObject(CLASS_SoapPositiveInteger) as _SoapPositiveInteger;\r\nend;\r\n\r\nclass function CoSoapPositiveInteger.CreateRemote(const MachineName: string): _SoapPositiveInteger;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_SoapPositiveInteger) as _SoapPositiveInteger;\r\nend;\r\n\r\nclass function CoSoapNonPositiveInteger.Create: _SoapNonPositiveInteger;\r\nbegin\r\n Result := CreateComObject(CLASS_SoapNonPositiveInteger) as _SoapNonPositiveInteger;\r\nend;\r\n\r\nclass function CoSoapNonPositiveInteger.CreateRemote(const MachineName: string): _SoapNonPositiveInteger;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_SoapNonPositiveInteger) as _SoapNonPositiveInteger;\r\nend;\r\n\r\nclass function CoSoapNonNegativeInteger.Create: _SoapNonNegativeInteger;\r\nbegin\r\n Result := CreateComObject(CLASS_SoapNonNegativeInteger) as _SoapNonNegativeInteger;\r\nend;\r\n\r\nclass function CoSoapNonNegativeInteger.CreateRemote(const MachineName: string): _SoapNonNegativeInteger;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_SoapNonNegativeInteger) as _SoapNonNegativeInteger;\r\nend;\r\n\r\nclass function CoSoapNegativeInteger.Create: _SoapNegativeInteger;\r\nbegin\r\n Result := CreateComObject(CLASS_SoapNegativeInteger) as _SoapNegativeInteger;\r\nend;\r\n\r\nclass function CoSoapNegativeInteger.CreateRemote(const MachineName: string): _SoapNegativeInteger;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_SoapNegativeInteger) as _SoapNegativeInteger;\r\nend;\r\n\r\nclass function CoSoapAnyUri.Create: _SoapAnyUri;\r\nbegin\r\n Result := CreateComObject(CLASS_SoapAnyUri) as _SoapAnyUri;\r\nend;\r\n\r\nclass function CoSoapAnyUri.CreateRemote(const MachineName: string): _SoapAnyUri;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_SoapAnyUri) as _SoapAnyUri;\r\nend;\r\n\r\nclass function CoSoapQName.Create: _SoapQName;\r\nbegin\r\n Result := CreateComObject(CLASS_SoapQName) as _SoapQName;\r\nend;\r\n\r\nclass function CoSoapQName.CreateRemote(const MachineName: string): _SoapQName;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_SoapQName) as _SoapQName;\r\nend;\r\n\r\nclass function CoSoapNotation.Create: _SoapNotation;\r\nbegin\r\n Result := CreateComObject(CLASS_SoapNotation) as _SoapNotation;\r\nend;\r\n\r\nclass function CoSoapNotation.CreateRemote(const MachineName: string): _SoapNotation;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_SoapNotation) as _SoapNotation;\r\nend;\r\n\r\nclass function CoSoapNormalizedString.Create: _SoapNormalizedString;\r\nbegin\r\n Result := CreateComObject(CLASS_SoapNormalizedString) as _SoapNormalizedString;\r\nend;\r\n\r\nclass function CoSoapNormalizedString.CreateRemote(const MachineName: string): _SoapNormalizedString;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_SoapNormalizedString) as _SoapNormalizedString;\r\nend;\r\n\r\nclass function CoSoapToken.Create: _SoapToken;\r\nbegin\r\n Result := CreateComObject(CLASS_SoapToken) as _SoapToken;\r\nend;\r\n\r\nclass function CoSoapToken.CreateRemote(const MachineName: string): _SoapToken;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_SoapToken) as _SoapToken;\r\nend;\r\n\r\nclass function CoSoapLanguage.Create: _SoapLanguage;\r\nbegin\r\n Result := CreateComObject(CLASS_SoapLanguage) as _SoapLanguage;\r\nend;\r\n\r\nclass function CoSoapLanguage.CreateRemote(const MachineName: string): _SoapLanguage;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_SoapLanguage) as _SoapLanguage;\r\nend;\r\n\r\nclass function CoSoapName.Create: _SoapName;\r\nbegin\r\n Result := CreateComObject(CLASS_SoapName) as _SoapName;\r\nend;\r\n\r\nclass function CoSoapName.CreateRemote(const MachineName: string): _SoapName;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_SoapName) as _SoapName;\r\nend;\r\n\r\nclass function CoSoapIdrefs.Create: _SoapIdrefs;\r\nbegin\r\n Result := CreateComObject(CLASS_SoapIdrefs) as _SoapIdrefs;\r\nend;\r\n\r\nclass function CoSoapIdrefs.CreateRemote(const MachineName: string): _SoapIdrefs;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_SoapIdrefs) as _SoapIdrefs;\r\nend;\r\n\r\nclass function CoSoapEntities.Create: _SoapEntities;\r\nbegin\r\n Result := CreateComObject(CLASS_SoapEntities) as _SoapEntities;\r\nend;\r\n\r\nclass function CoSoapEntities.CreateRemote(const MachineName: string): _SoapEntities;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_SoapEntities) as _SoapEntities;\r\nend;\r\n\r\nclass function CoSoapNmtoken.Create: _SoapNmtoken;\r\nbegin\r\n Result := CreateComObject(CLASS_SoapNmtoken) as _SoapNmtoken;\r\nend;\r\n\r\nclass function CoSoapNmtoken.CreateRemote(const MachineName: string): _SoapNmtoken;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_SoapNmtoken) as _SoapNmtoken;\r\nend;\r\n\r\nclass function CoSoapNmtokens.Create: _SoapNmtokens;\r\nbegin\r\n Result := CreateComObject(CLASS_SoapNmtokens) as _SoapNmtokens;\r\nend;\r\n\r\nclass function CoSoapNmtokens.CreateRemote(const MachineName: string): _SoapNmtokens;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_SoapNmtokens) as _SoapNmtokens;\r\nend;\r\n\r\nclass function CoSoapNcName.Create: _SoapNcName;\r\nbegin\r\n Result := CreateComObject(CLASS_SoapNcName) as _SoapNcName;\r\nend;\r\n\r\nclass function CoSoapNcName.CreateRemote(const MachineName: string): _SoapNcName;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_SoapNcName) as _SoapNcName;\r\nend;\r\n\r\nclass function CoSoapId.Create: _SoapId;\r\nbegin\r\n Result := CreateComObject(CLASS_SoapId) as _SoapId;\r\nend;\r\n\r\nclass function CoSoapId.CreateRemote(const MachineName: string): _SoapId;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_SoapId) as _SoapId;\r\nend;\r\n\r\nclass function CoSoapIdref.Create: _SoapIdref;\r\nbegin\r\n Result := CreateComObject(CLASS_SoapIdref) as _SoapIdref;\r\nend;\r\n\r\nclass function CoSoapIdref.CreateRemote(const MachineName: string): _SoapIdref;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_SoapIdref) as _SoapIdref;\r\nend;\r\n\r\nclass function CoSoapEntity.Create: _SoapEntity;\r\nbegin\r\n Result := CreateComObject(CLASS_SoapEntity) as _SoapEntity;\r\nend;\r\n\r\nclass function CoSoapEntity.CreateRemote(const MachineName: string): _SoapEntity;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_SoapEntity) as _SoapEntity;\r\nend;\r\n\r\nclass function CoSynchronizationAttribute.Create: _SynchronizationAttribute;\r\nbegin\r\n Result := CreateComObject(CLASS_SynchronizationAttribute) as _SynchronizationAttribute;\r\nend;\r\n\r\nclass function CoSynchronizationAttribute.CreateRemote(const MachineName: string): _SynchronizationAttribute;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_SynchronizationAttribute) as _SynchronizationAttribute;\r\nend;\r\n\r\nclass function CoTrackingServices.Create: _TrackingServices;\r\nbegin\r\n Result := CreateComObject(CLASS_TrackingServices) as _TrackingServices;\r\nend;\r\n\r\nclass function CoTrackingServices.CreateRemote(const MachineName: string): _TrackingServices;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_TrackingServices) as _TrackingServices;\r\nend;\r\n\r\nclass function CoUrlAttribute.Create: _UrlAttribute;\r\nbegin\r\n Result := CreateComObject(CLASS_UrlAttribute) as _UrlAttribute;\r\nend;\r\n\r\nclass function CoUrlAttribute.CreateRemote(const MachineName: string): _UrlAttribute;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_UrlAttribute) as _UrlAttribute;\r\nend;\r\n\r\nclass function CoIsolatedStorage.Create: _IsolatedStorage;\r\nbegin\r\n Result := CreateComObject(CLASS_IsolatedStorage) as _IsolatedStorage;\r\nend;\r\n\r\nclass function CoIsolatedStorage.CreateRemote(const MachineName: string): _IsolatedStorage;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_IsolatedStorage) as _IsolatedStorage;\r\nend;\r\n\r\nclass function CoIsolatedStorageFile.Create: _IsolatedStorageFile;\r\nbegin\r\n Result := CreateComObject(CLASS_IsolatedStorageFile) as _IsolatedStorageFile;\r\nend;\r\n\r\nclass function CoIsolatedStorageFile.CreateRemote(const MachineName: string): _IsolatedStorageFile;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_IsolatedStorageFile) as _IsolatedStorageFile;\r\nend;\r\n\r\nclass function CoIsolatedStorageFileStream.Create: _IsolatedStorageFileStream;\r\nbegin\r\n Result := CreateComObject(CLASS_IsolatedStorageFileStream) as _IsolatedStorageFileStream;\r\nend;\r\n\r\nclass function CoIsolatedStorageFileStream.CreateRemote(const MachineName: string): _IsolatedStorageFileStream;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_IsolatedStorageFileStream) as _IsolatedStorageFileStream;\r\nend;\r\n\r\nclass function CoIsolatedStorageException.Create: _IsolatedStorageException;\r\nbegin\r\n Result := CreateComObject(CLASS_IsolatedStorageException) as _IsolatedStorageException;\r\nend;\r\n\r\nclass function CoIsolatedStorageException.CreateRemote(const MachineName: string): _IsolatedStorageException;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_IsolatedStorageException) as _IsolatedStorageException;\r\nend;\r\n\r\nclass function CoInternalRM.Create: _InternalRM;\r\nbegin\r\n Result := CreateComObject(CLASS_InternalRM) as _InternalRM;\r\nend;\r\n\r\nclass function CoInternalRM.CreateRemote(const MachineName: string): _InternalRM;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_InternalRM) as _InternalRM;\r\nend;\r\n\r\nclass function CoInternalST.Create: _InternalST;\r\nbegin\r\n Result := CreateComObject(CLASS_InternalST) as _InternalST;\r\nend;\r\n\r\nclass function CoInternalST.CreateRemote(const MachineName: string): _InternalST;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_InternalST) as _InternalST;\r\nend;\r\n\r\nclass function CoSoapMessage.Create: _SoapMessage;\r\nbegin\r\n Result := CreateComObject(CLASS_SoapMessage) as _SoapMessage;\r\nend;\r\n\r\nclass function CoSoapMessage.CreateRemote(const MachineName: string): _SoapMessage;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_SoapMessage) as _SoapMessage;\r\nend;\r\n\r\nclass function CoSoapFault.Create: _SoapFault;\r\nbegin\r\n Result := CreateComObject(CLASS_SoapFault) as _SoapFault;\r\nend;\r\n\r\nclass function CoSoapFault.CreateRemote(const MachineName: string): _SoapFault;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_SoapFault) as _SoapFault;\r\nend;\r\n\r\nclass function CoServerFault.Create: _ServerFault;\r\nbegin\r\n Result := CreateComObject(CLASS_ServerFault) as _ServerFault;\r\nend;\r\n\r\nclass function CoServerFault.CreateRemote(const MachineName: string): _ServerFault;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_ServerFault) as _ServerFault;\r\nend;\r\n\r\nclass function CoBinaryFormatter.Create: _BinaryFormatter;\r\nbegin\r\n Result := CreateComObject(CLASS_BinaryFormatter) as _BinaryFormatter;\r\nend;\r\n\r\nclass function CoBinaryFormatter.CreateRemote(const MachineName: string): _BinaryFormatter;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_BinaryFormatter) as _BinaryFormatter;\r\nend;\r\n\r\nclass function CoAssemblyBuilder.Create: _AssemblyBuilder;\r\nbegin\r\n Result := CreateComObject(CLASS_AssemblyBuilder) as _AssemblyBuilder;\r\nend;\r\n\r\nclass function CoAssemblyBuilder.CreateRemote(const MachineName: string): _AssemblyBuilder;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_AssemblyBuilder) as _AssemblyBuilder;\r\nend;\r\n\r\nclass function CoConstructorBuilder.Create: _ConstructorBuilder;\r\nbegin\r\n Result := CreateComObject(CLASS_ConstructorBuilder) as _ConstructorBuilder;\r\nend;\r\n\r\nclass function CoConstructorBuilder.CreateRemote(const MachineName: string): _ConstructorBuilder;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_ConstructorBuilder) as _ConstructorBuilder;\r\nend;\r\n\r\nclass function CoEventBuilder.Create: _EventBuilder;\r\nbegin\r\n Result := CreateComObject(CLASS_EventBuilder) as _EventBuilder;\r\nend;\r\n\r\nclass function CoEventBuilder.CreateRemote(const MachineName: string): _EventBuilder;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_EventBuilder) as _EventBuilder;\r\nend;\r\n\r\nclass function CoFieldBuilder.Create: _FieldBuilder;\r\nbegin\r\n Result := CreateComObject(CLASS_FieldBuilder) as _FieldBuilder;\r\nend;\r\n\r\nclass function CoFieldBuilder.CreateRemote(const MachineName: string): _FieldBuilder;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_FieldBuilder) as _FieldBuilder;\r\nend;\r\n\r\nclass function CoILGenerator.Create: _ILGenerator;\r\nbegin\r\n Result := CreateComObject(CLASS_ILGenerator) as _ILGenerator;\r\nend;\r\n\r\nclass function CoILGenerator.CreateRemote(const MachineName: string): _ILGenerator;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_ILGenerator) as _ILGenerator;\r\nend;\r\n\r\nclass function CoLocalBuilder.Create: _LocalBuilder;\r\nbegin\r\n Result := CreateComObject(CLASS_LocalBuilder) as _LocalBuilder;\r\nend;\r\n\r\nclass function CoLocalBuilder.CreateRemote(const MachineName: string): _LocalBuilder;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_LocalBuilder) as _LocalBuilder;\r\nend;\r\n\r\nclass function CoMethodBuilder.Create: _MethodBuilder;\r\nbegin\r\n Result := CreateComObject(CLASS_MethodBuilder) as _MethodBuilder;\r\nend;\r\n\r\nclass function CoMethodBuilder.CreateRemote(const MachineName: string): _MethodBuilder;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_MethodBuilder) as _MethodBuilder;\r\nend;\r\n\r\nclass function CoCustomAttributeBuilder.Create: _CustomAttributeBuilder;\r\nbegin\r\n Result := CreateComObject(CLASS_CustomAttributeBuilder) as _CustomAttributeBuilder;\r\nend;\r\n\r\nclass function CoCustomAttributeBuilder.CreateRemote(const MachineName: string): _CustomAttributeBuilder;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_CustomAttributeBuilder) as _CustomAttributeBuilder;\r\nend;\r\n\r\nclass function CoMethodRental.Create: _MethodRental;\r\nbegin\r\n Result := CreateComObject(CLASS_MethodRental) as _MethodRental;\r\nend;\r\n\r\nclass function CoMethodRental.CreateRemote(const MachineName: string): _MethodRental;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_MethodRental) as _MethodRental;\r\nend;\r\n\r\nclass function CoModuleBuilder.Create: _ModuleBuilder;\r\nbegin\r\n Result := CreateComObject(CLASS_ModuleBuilder) as _ModuleBuilder;\r\nend;\r\n\r\nclass function CoModuleBuilder.CreateRemote(const MachineName: string): _ModuleBuilder;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_ModuleBuilder) as _ModuleBuilder;\r\nend;\r\n\r\nclass function CoOpCodes.Create: _OpCodes;\r\nbegin\r\n Result := CreateComObject(CLASS_OpCodes) as _OpCodes;\r\nend;\r\n\r\nclass function CoOpCodes.CreateRemote(const MachineName: string): _OpCodes;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_OpCodes) as _OpCodes;\r\nend;\r\n\r\nclass function CoParameterBuilder.Create: _ParameterBuilder;\r\nbegin\r\n Result := CreateComObject(CLASS_ParameterBuilder) as _ParameterBuilder;\r\nend;\r\n\r\nclass function CoParameterBuilder.CreateRemote(const MachineName: string): _ParameterBuilder;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_ParameterBuilder) as _ParameterBuilder;\r\nend;\r\n\r\nclass function CoPropertyBuilder.Create: _PropertyBuilder;\r\nbegin\r\n Result := CreateComObject(CLASS_PropertyBuilder) as _PropertyBuilder;\r\nend;\r\n\r\nclass function CoPropertyBuilder.CreateRemote(const MachineName: string): _PropertyBuilder;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_PropertyBuilder) as _PropertyBuilder;\r\nend;\r\n\r\nclass function CoSignatureHelper.Create: _SignatureHelper;\r\nbegin\r\n Result := CreateComObject(CLASS_SignatureHelper) as _SignatureHelper;\r\nend;\r\n\r\nclass function CoSignatureHelper.CreateRemote(const MachineName: string): _SignatureHelper;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_SignatureHelper) as _SignatureHelper;\r\nend;\r\n\r\nclass function CoTypeBuilder.Create: _TypeBuilder;\r\nbegin\r\n Result := CreateComObject(CLASS_TypeBuilder) as _TypeBuilder;\r\nend;\r\n\r\nclass function CoTypeBuilder.CreateRemote(const MachineName: string): _TypeBuilder;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_TypeBuilder) as _TypeBuilder;\r\nend;\r\n\r\nclass function CoEnumBuilder.Create: _EnumBuilder;\r\nbegin\r\n Result := CreateComObject(CLASS_EnumBuilder) as _EnumBuilder;\r\nend;\r\n\r\nclass function CoEnumBuilder.CreateRemote(const MachineName: string): _EnumBuilder;\r\nbegin\r\n Result := CreateRemoteComObject(MachineName, CLASS_EnumBuilder) as _EnumBuilder;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jcl/source/windows/obj/bzip2/win32/dirinfo.txt", "content": "This is the directory where object files of bzip (http://www.bzip.org) for win32 reside." }, { "path": "External/Jedi/Jcl/source/windows/obj/bzip2/win32/makefile.mak", "content": "#\r\n# makefile to make bzip2 .obj files using Borland's C++ compiler bcc32\r\n# derived from a makefile generated by BCB6' bpr2mak\r\n#\r\n# if bzip2 source directory is different from ..\\..\\..\\..\\..\\..\\thirdparty\\bzip2\\bzip2-1.0.6, use\r\n# \"make -Dbzip2src=\" to tell make where to find the \r\n# source files\r\n#\r\n# Make.exe needs to reside in the same directory as bcc32.exe.\r\n# For example, if you have Borlands free C++ v. 5.5 compiler (available from\r\n# http://www.borland.com/products/downloads/download_cbuilder.html#) installed:\r\n#\r\n# >C:\\Program Files\\Borland\\BCC55\\Bin\\make\r\n#\r\n# or, if you want to use C++ Builder 6:\r\n#\r\n# >C:\\Program Files\\Borland\\CBuilder6\\Bin\\make\r\n#\r\n# or, if you want to use Borland Developer Studio 2006:\r\n#\r\n# >C:\\Program files\\Borland\\BDS\\4.0\\bin\\make\r\n#\r\n# To choose the target CPU, pass \"-DCPU=n\" as option to make, with n being a\r\n# number between 3 and 6, with the following meanings:\r\n#\r\n# n Target CPU (or compatible)\r\n# --------------------------------\r\n# 3 80386\r\n# 4 80486\r\n# 5 Pentium (default)\r\n# 6 Pentium Pro\r\n#\r\n# Robert Rossmair, 2004-10-16\r\n#\r\n\r\nCallingConvention = -pc\r\n\r\n!if !$d(BCB)\r\nBCB = $(MAKEDIR)\\..\r\n!endif\r\n\r\nBCC = $(BCB)\r\n\r\n!if !$d(bzip2src)\r\nbzip2src = ..\\..\\..\\..\\..\\..\\thirdparty\\bzip2\\bzip2-1.0.6\r\n!endif\r\n\r\n!if !$d(CPU)\r\nCPU = 5 # Pentium\r\n!endif\r\n\r\n# ---------------------------------------------------------------------------\r\n# IDE SECTION\r\n# ---------------------------------------------------------------------------\r\n# The following section of the project makefile is managed by the BCB IDE.\r\n# It is recommended to use the IDE to change any of the values in this\r\n# section.\r\n# ---------------------------------------------------------------------------\r\n\r\nVERSION = BCB.06.00\r\n# ---------------------------------------------------------------------------\r\nOBJFILES = .\\bzlib.obj .\\randtable.obj .\\crctable.obj .\\compress.obj \\\r\n .\\decompress.obj .\\huffman.obj .\\blocksort.obj\r\n# ---------------------------------------------------------------------------\r\nDEBUGLIBPATH = $(BCB)\\lib\\debug\r\nRELEASELIBPATH = $(BCB)\\lib\\release\r\nUSERDEFINES = \r\nSYSDEFINES = BZ_EXPORT;BZ_NO_STDIO\r\nINCLUDEPATH = $(bzip2src);$(BCC)\\include;$(BCB)\\include\\vcl\r\n# LIBPATH = $(bzip2src)\r\nWARNINGS= -w-par -w-aus\r\nPATHC = .;$(bzip2src)\r\n# PATHOBJ = .;$(LIBPATH)\r\n# ---------------------------------------------------------------------------\r\nCFLAG1 = -O2 -Ve -X- -a8 -$(CPU) -b -d -k- -vi -tWM $(CallingConvention)\r\n\r\n# ---------------------------------------------------------------------------\r\n# MAKE SECTION\r\n# ---------------------------------------------------------------------------\r\n# This section of the project file is not used by the BCB IDE. It is for\r\n# the benefit of building from the command-line using the MAKE utility.\r\n# ---------------------------------------------------------------------------\r\n\r\n.autodepend\r\n# ---------------------------------------------------------------------------\r\n\r\n!if !$d(BCC32)\r\nBCC32 = bcc32\r\n!endif\r\n\r\n# ---------------------------------------------------------------------------\r\n!if $d(PATHC)\r\n.PATH.C = $(PATHC)\r\n!endif\r\n\r\n# ---------------------------------------------------------------------------\r\nbzip2: $(OBJFILES)\r\n\r\n# ---------------------------------------------------------------------------\r\n.c.obj:\r\n $(BCC)\\BIN\\$(BCC32) -c $(CFLAG1) $(WARNINGS) -I$(INCLUDEPATH) -D$(USERDEFINES);$(SYSDEFINES) -n$(@D) {$< }\r\n# ---------------------------------------------------------------------------\r\n\r\n\r\n\r\n\r\n" }, { "path": "External/Jedi/Jcl/source/windows/obj/bzip2/win64/dirinfo.txt", "content": "This is the directory where object files of bzip (http://www.bzip.org) for win64 reside." }, { "path": "External/Jedi/Jcl/source/windows/obj/bzip2/win64/makefile.mak", "content": "#\r\n# makefile to make bzip2 .obj files using Microsoft C++ compiler (cl.exe)\r\n#\r\n# if bzip2 source directory is different from ..\\..\\..\\..\\..\\..\\thirdparty\\bzip2\\bzip2-1.0.6, use\r\n# \"make -Dbzip2src=\" to tell make where to find the \r\n# source files\r\n#\r\n# Make.exe needs to reside in the same directory as bcc32.exe.\r\n# For example, if you have Borlands free C++ v. 5.5 compiler (available from\r\n# http://www.borland.com/products/downloads/download_cbuilder.html#) installed:\r\n#\r\n# >C:\\Program Files\\Borland\\BCC55\\Bin\\make\r\n#\r\n# or, if you want to use C++ Builder 6:\r\n#\r\n# >C:\\Program Files\\Borland\\CBuilder6\\Bin\\make\r\n#\r\n# or, if you want to use Borland Developer Studio 2006:\r\n#\r\n# >C:\\Program files\\Borland\\BDS\\4.0\\bin\\make\r\n#\r\n\r\n!if !$d(bzip2src)\r\nbzip2src = ..\\..\\..\\..\\..\\..\\thirdparty\\bzip2\\bzip2-1.0.6\r\n!endif\r\n\r\n# ---------------------------------------------------------------------------\r\nOBJFILES = .\\bzlib.obj .\\randtable.obj .\\crctable.obj .\\compress.obj \\\r\n .\\decompress.obj .\\huffman.obj .\\blocksort.obj\r\n# ---------------------------------------------------------------------------\r\nUSERDEFINES = BZ_EXPORT\r\nSYSDEFINES = BZ_NO_STDIO\r\nPATHC = .;$(bzip2src)\r\n# ---------------------------------------------------------------------------\r\n# MAKE SECTION\r\n# ---------------------------------------------------------------------------\r\n# This section of the project file is not used by the BCB IDE. It is for\r\n# the benefit of building from the command-line using the MAKE utility.\r\n# ---------------------------------------------------------------------------\r\n\r\n.autodepend\r\n# ---------------------------------------------------------------------------\r\n\r\n# ---------------------------------------------------------------------------\r\n!if $d(PATHC)\r\n.PATH.C = $(PATHC)\r\n!endif\r\n\r\n# ---------------------------------------------------------------------------\r\nbzip2: $(OBJFILES)\r\n\r\n# ---------------------------------------------------------------------------\r\n.c.obj:\r\n cl -c -nologo -D_KERNEL32_ -GS- -Z7 -wd4068 -D$(SYSDEFINES) -D$(USERDEFINES) -Gs999999 -Fo$@ $<\r\n# ---------------------------------------------------------------------------\r\n\r\n\r\n\r\n\r\n" }, { "path": "External/Jedi/Jcl/source/windows/obj/pcre/win32/dirinfo.txt", "content": "This is the directory where object files of PCRE (http://www.pcre.org/) for win32 reside." }, { "path": "External/Jedi/Jcl/source/windows/obj/pcre/win32/makefile.mak", "content": "#\r\n# makefile to make pcre .obj files using Borland's C++ compiler bcc32\r\n# derived from a makefile generated by BCB6' bpr2mak\r\n#\r\n# if pcre source directory is different from ..\\..\\..\\..\\..\\..\\thirdparty\\pcre\\pcre-8.31, use\r\n# \"make -Dpcresrc=\" to tell make where to find the \r\n# source files\r\n#\r\n# Make.exe needs to reside in the same directory as bcc32.exe.\r\n# For example, if you have Borlands free C++ v. 5.5 compiler (available from\r\n# http://www.borland.com/products/downloads/download_cbuilder.html#) installed:\r\n#\r\n# >C:\\Program Files\\Borland\\BCC55\\Bin\\make\r\n#\r\n# or, if you want to use C++ Builder 6:\r\n#\r\n# >C:\\Program Files\\Borland\\CBuilder6\\Bin\\make\r\n#\r\n# or, if you want to use Borland Developer Studio 2006:\r\n#\r\n# >C:\\Program files\\Borland\\BDS\\4.0\\bin\\make\r\n#\r\n# To choose the target CPU, pass \"-DCPU=n\" as option to make, with n being a\r\n# number between 3 and 6, with the following meanings:\r\n#\r\n# n Target CPU (or compatible)\r\n# --------------------------------\r\n# 3 80386\r\n# 4 80486\r\n# 5 Pentium (default)\r\n# 6 Pentium Pro\r\n#\r\n# Robert Rossmair, 2004-10-16\r\n#\r\n\r\nCallingConvention = -pr\r\n\r\n!if !$d(BCB)\r\nBCB = $(MAKEDIR)\\..\r\n!endif\r\n\r\nBCC = $(BCB)\r\n\r\n!if !$d(pcresrc)\r\npcresrc = ..\\..\\..\\..\\..\\..\\thirdparty\\pcre\\pcre-8.31\r\n!endif\r\n\r\n!if !$d(CPU)\r\nCPU = 5 # Pentium\r\n!endif\r\n\r\n# ---------------------------------------------------------------------------\r\n# IDE SECTION\r\n# ---------------------------------------------------------------------------\r\n# The following section of the project makefile is managed by the BCB IDE.\r\n# It is recommended to use the IDE to change any of the values in this\r\n# section.\r\n# ---------------------------------------------------------------------------\r\n\r\nVERSION = BCB.06.00\r\n# ---------------------------------------------------------------------------\r\nOBJ32FILES = .\\pcre_compile.obj .\\pcre_config.obj .\\pcre_dfa_exec.obj \\\r\n .\\pcre_exec.obj .\\pcre_fullinfo.obj .\\pcre_get.obj \\\r\n .\\pcre_jit_compile.obj .\\pcre_maketables.obj \\\r\n .\\pcre_newline.obj .\\pcre_ord2utf8.obj .\\pcre_refcount.obj .\\pcre_study.obj \\\r\n .\\pcre_tables.obj .\\pcre_ucd.obj \\\r\n .\\pcre_valid_utf8.obj .\\pcre_version.obj .\\pcre_xclass.obj \\\r\n .\\pcre_chartables.obj\r\n\r\nOBJ64FILES = .\\pcre16_compile.obj .\\pcre16_config.obj .\\pcre16_dfa_exec.obj \\\r\n .\\pcre16_exec.obj .\\pcre16_fullinfo.obj .\\pcre16_get.obj \\\r\n .\\pcre16_jit_compile.obj .\\pcre16_maketables.obj \\\r\n .\\pcre16_newline.obj .\\pcre16_ord2utf16.obj .\\pcre16_refcount.obj \\\r\n .\\pcre16_study.obj .\\pcre16_tables.obj .\\pcre16_ucd.obj \\\r\n .\\pcre16_valid_utf16.obj .\\pcre16_version.obj .\\pcre16_xclass.obj \\\r\n .\\pcre16_chartables.obj .\\pcre16_string_utils.obj\r\n\r\nOBJFILES = $(OBJ32FILES) $(OBJ64FILES)\r\n\r\n# ---------------------------------------------------------------------------\r\nDEBUGLIBPATH = $(BCB)\\lib\\debug\r\nRELEASELIBPATH = $(BCB)\\lib\\release\r\nUSERDEFINES = SUPPORT_UTF;SUPPORT_UCP;SUPPORT_JIT;SUPPORT_PCRE8;SUPPORT_PCRE16\r\nSYSDEFINES = NO_STRICT;_NO_VCL;_RTLDLL\r\nINCLUDEPATH = $(pcresrc);$(BCC)\\include;$(BCB)\\include\\vcl\r\nLIBPATH = $(BCB)\\lib\\obj;$(BCB)\\lib\r\n# LIBPATH = $(pcresrc)\r\nWARNINGS= -wpar -w-aus\r\nPATHC = .;$(pcresrc)\r\n# PATHOBJ = .;$(LIBPATH)\r\nALLLIB = import32.lib cw32i.lib\r\nINCLUDES = $(pcresrc)\\pcre.h $(pcresrc)\\config.h\r\nTABLES = $(pcresrc)\\pcre_chartables.c\r\n# ---------------------------------------------------------------------------\r\nCFLAG1 = -O2 -Ve -X- -a8 -$(CPU) -b -d -k- -vi -tWM- -DHAVE_CONFIG_H\r\n\r\nLFLAGS = -D\"\" -ap -Tpe -x -Gn\r\n# ---------------------------------------------------------------------------\r\n# MAKE SECTION\r\n# ---------------------------------------------------------------------------\r\n# This section of the project file is not used by the BCB IDE. It is for\r\n# the benefit of building from the command-line using the MAKE utility.\r\n# ---------------------------------------------------------------------------\r\n\r\n.autodepend\r\n# ---------------------------------------------------------------------------\r\n\r\n!if !$d(BCC32)\r\nBCC32 = bcc32\r\n!endif\r\n\r\n!if !$d(LINKER)\r\nLINKER = ilink32\r\n!endif\r\n\r\n# ---------------------------------------------------------------------------\r\n!if $d(PATHC)\r\n.PATH.C = $(PATHC)\r\n!endif\r\n\r\n# ---------------------------------------------------------------------------\r\npcre: $(INCLUDES) $(TABLES) $(OBJFILES)\r\n\r\n# ---------------------------------------------------------------------------\r\n.c.obj:\r\n $(BCC)\\BIN\\$(BCC32) -c $(CFLAG1) $(CallingConvention) $(WARNINGS) -I$(INCLUDEPATH) -D$(USERDEFINES);$(SYSDEFINES) -n$(@D) {$< }\r\n\r\n$(pcresrc)\\pcre.h: $(pcresrc)\\pcre.h.generic\r\n copy /Y $? $@\r\n\r\n$(pcresrc)\\config.h: $(pcresrc)\\config.h.generic\r\n copy /Y $? $@\r\n\r\n$(pcresrc)\\pcre_chartables.c: $(pcresrc)\\pcre_chartables.c.dist\r\n copy /Y $? $@\r\n\r\n# ---------------------------------------------------------------------------\r\n\r\n\r\n\r\n\r\n" }, { "path": "External/Jedi/Jcl/source/windows/obj/pcre/win64/dirinfo.txt", "content": "This is the directory where object files of PCRE (http://www.pcre.org/) for win64 reside." }, { "path": "External/Jedi/Jcl/source/windows/obj/pcre/win64/makefile.mak", "content": "#\r\n# makefile to make pcre .obj files using Microsoft C++ compiler (cl.exe)\r\n#\r\n# if pcre source directory is different from ..\\..\\..\\..\\..\\..\\thirdparty\\pcre\\pcre-8.31, use\r\n# \"make -Dpcresrc=\" to tell make where to find the \r\n# source files\r\n#\r\n# Make.exe needs to reside in the same directory as bcc32.exe.\r\n# For example, if you have Borlands free C++ v. 5.5 compiler (available from\r\n# http://www.borland.com/products/downloads/download_cbuilder.html#) installed:\r\n#\r\n# >C:\\Program Files\\Borland\\BCC55\\Bin\\make\r\n#\r\n# or, if you want to use C++ Builder 6:\r\n#\r\n# >C:\\Program Files\\Borland\\CBuilder6\\Bin\\make\r\n#\r\n# or, if you want to use Borland Developer Studio 2006:\r\n#\r\n# >C:\\Program files\\Borland\\BDS\\4.0\\bin\\make\r\n\r\n!if !$d(BCB)\r\nBCB = $(MAKEDIR)\\..\r\n!endif\r\n\r\nBCC = $(BCB)\r\n\r\n!if !$d(pcresrc)\r\npcresrc = ..\\..\\..\\..\\..\\..\\thirdparty\\pcre\\pcre-8.31\r\n!endif\r\n\r\n# ---------------------------------------------------------------------------\r\nOBJ32FILES = .\\pcre_compile.obj .\\pcre_config.obj .\\pcre_dfa_exec.obj \\\r\n .\\pcre_exec.obj .\\pcre_fullinfo.obj .\\pcre_get.obj \\\r\n .\\pcre_jit_compile.obj .\\pcre_maketables.obj \\\r\n .\\pcre_newline.obj .\\pcre_ord2utf8.obj .\\pcre_refcount.obj .\\pcre_study.obj \\\r\n .\\pcre_tables.obj .\\pcre_ucd.obj \\\r\n .\\pcre_valid_utf8.obj .\\pcre_version.obj .\\pcre_xclass.obj \\\r\n .\\pcre_chartables.obj\r\n\r\nOBJ64FILES = .\\pcre16_compile.obj .\\pcre16_config.obj .\\pcre16_dfa_exec.obj \\\r\n .\\pcre16_exec.obj .\\pcre16_fullinfo.obj .\\pcre16_get.obj \\\r\n .\\pcre16_jit_compile.obj .\\pcre16_maketables.obj \\\r\n .\\pcre16_newline.obj .\\pcre16_ord2utf16.obj .\\pcre16_refcount.obj \\\r\n .\\pcre16_study.obj .\\pcre16_tables.obj .\\pcre16_ucd.obj \\\r\n .\\pcre16_valid_utf16.obj .\\pcre16_version.obj .\\pcre16_xclass.obj \\\r\n .\\pcre16_chartables.obj .\\pcre16_string_utils.obj\r\n\r\nOBJFILES = $(OBJ32FILES) $(OBJ64FILES)\r\n\r\n# ---------------------------------------------------------------------------\r\nUSERDEFINES = SUPPORT_UTF;SUPPORT_UCP;SUPPORT_JIT;SUPPORT_PCRE8;SUPPORT_PCRE16\r\nSYSDEFINES = NO_STRICT;_NO_VCL;_RTLDLL\r\nINCLUDEPATH = $(pcresrc);$(BCC)\\include;$(BCB)\\include\\vcl\r\nLIBPATH = $(BCB)\\lib\\obj;$(BCB)\\lib\r\nPATHC = .;$(pcresrc)\r\nALLLIB = import32.lib cw32i.lib\r\nINCLUDES = $(pcresrc)\\pcre.h $(pcresrc)\\config.h\r\nTABLES = $(pcresrc)\\pcre_chartables.c\r\n# ---------------------------------------------------------------------------\r\nCFLAG1 = -O2 -Ve -X- -a8 -5 -b -d -k- -vi -tWM- -DHAVE_CONFIG_H\r\n\r\nLFLAGS = -D\"\" -ap -Tpe -x -Gn\r\n# ---------------------------------------------------------------------------\r\n# MAKE SECTION\r\n# ---------------------------------------------------------------------------\r\n# This section of the project file is not used by the BCB IDE. It is for\r\n# the benefit of building from the command-line using the MAKE utility.\r\n# ---------------------------------------------------------------------------\r\n\r\n.autodepend\r\n# ---------------------------------------------------------------------------\r\n\r\n!if !$d(BCC32)\r\nBCC32 = bcc32\r\n!endif\r\n\r\n!if !$d(LINKER)\r\nLINKER = ilink32\r\n!endif\r\n\r\n# ---------------------------------------------------------------------------\r\n!if $d(PATHC)\r\n.PATH.C = $(PATHC)\r\n!endif\r\n\r\n# ---------------------------------------------------------------------------\r\npcre: $(INCLUDES) $(TABLES) $(OBJFILES)\r\n\r\n# ---------------------------------------------------------------------------\r\n.c.obj:\r\n cl -c -nologo -D_KERNEL32_ -GS- -Z7 -wd4068 -I$(pcresrc) -D$(SYSDEFINES) -DSUPPORT_UTF8 -DSUPPORT_UCP -DSUPPORT_JIT -DHAVE_CONFIG_H -Gs999999 -Fo$@ $<\r\n\r\n$(pcresrc)\\pcre.h: $(pcresrc)\\pcre.h.generic\r\n copy /Y $? $@\r\n\r\n$(pcresrc)\\config.h: $(pcresrc)\\config.h.generic\r\n copy /Y $? $@\r\n\r\n$(pcresrc)\\pcre_chartables.c: $(pcresrc)\\pcre_chartables.c.dist\r\n copy /Y $? $@\r\n\r\n# ---------------------------------------------------------------------------\r\n\r\n\r\n\r\n\r\n" }, { "path": "External/Jedi/Jcl/source/windows/obj/zlib/win32/dirinfo.txt", "content": "This is the directory where object files of zlib (http://www.zlib.net) for win32 reside." }, { "path": "External/Jedi/Jcl/source/windows/obj/zlib/win32/makefile.mak", "content": "#\r\n# makefile to make zlib .obj files using Borland's C++ compiler bcc32\r\n# derived from a makefile generated by BCB6' bpr2mak\r\n#\r\n# if zlib source directory is different from ..\\..\\..\\..\\..\\..\\thirdparty\\zlib\\zlib-1.2.7, use\r\n# \"make -Dzlibsrc=\" to tell make where to find the \r\n# source files\r\n#\r\n# Make.exe needs to reside in the same directory as bcc32.exe.\r\n# For example, if you have Borlands free C++ v. 5.5 compiler (available from\r\n# http://www.borland.com/products/downloads/download_cbuilder.html#) installed:\r\n#\r\n# >C:\\Program Files\\Borland\\BCC55\\Bin\\make\r\n#\r\n# or, if you want to use C++ Builder 6:\r\n#\r\n# >C:\\Program Files\\Borland\\CBuilder6\\Bin\\make\r\n#\r\n# or, if you want to use Borland Developer Studio 2006:\r\n#\r\n# >C:\\Program files\\Borland\\BDS\\4.0\\bin\\make\r\n#\r\n# To choose the target CPU, pass \"-DCPU=n\" as option to make, with n being a\r\n# number between 3 and 6, with the following meanings:\r\n#\r\n# n Target CPU (or compatible)\r\n# --------------------------------\r\n# 3 80386\r\n# 4 80486\r\n# 5 Pentium (default)\r\n# 6 Pentium Pro\r\n#\r\n# Note: This assumes -DZEXPORT=__fastcall -DZEXPORTVA=__cdecl\r\n#\r\n# Robert Rossmair, 2004-10-16\r\n#\r\n\r\nCallingConvention = -pr -DZEXPORT=__fastcall -DZEXPORTVA=__cdecl\r\n\r\n!if !$d(BCB)\r\nBCB = $(MAKEDIR)\\..\r\n!endif\r\n\r\nBCC = $(BCB)\r\n\r\n!if !$d(zlibsrc)\r\nzlibsrc = ..\\..\\..\\..\\..\\..\\thirdparty\\zlib\\zlib-1.2.7\r\n!endif\r\n\r\n!if !$d(CPU)\r\nCPU = 5 # Pentium\r\n!endif\r\n\r\n# ---------------------------------------------------------------------------\r\n# IDE SECTION\r\n# ---------------------------------------------------------------------------\r\n# The following section of the project makefile is managed by the BCB IDE.\r\n# It is recommended to use the IDE to change any of the values in this\r\n# section.\r\n# ---------------------------------------------------------------------------\r\n\r\nVERSION = BCB.06.00\r\n# ---------------------------------------------------------------------------\r\nOBJFILES = .\\zutil.obj .\\compress.obj .\\crc32.obj .\\deflate.obj \\\r\n .\\infback.obj .\\inffast.obj .\\inflate.obj .\\inftrees.obj .\\trees.obj \\\r\n .\\uncompr.obj .\\adler32.obj\r\n# ---------------------------------------------------------------------------\r\nDEBUGLIBPATH = $(BCB)\\lib\\debug\r\nRELEASELIBPATH = $(BCB)\\lib\\release\r\nUSERDEFINES = \r\nSYSDEFINES = NO_STRICT\r\nINCLUDEPATH = $(zlibsrc);$(BCC)\\include;$(BCB)\\include\\vcl\r\n# LIBPATH = $(zlibsrc)\r\nWARNINGS= -w-par -w-aus\r\nPATHC = .;$(zlibsrc)\r\n# PATHOBJ = .;$(LIBPATH)\r\n# ---------------------------------------------------------------------------\r\nCFLAG1 = -O2 -Ve -X- -a8 -$(CPU) -b -d -k- -vi -tWM $(CallingConvention)\r\n\r\n# ---------------------------------------------------------------------------\r\n# MAKE SECTION\r\n# ---------------------------------------------------------------------------\r\n# This section of the project file is not used by the BCB IDE. It is for\r\n# the benefit of building from the command-line using the MAKE utility.\r\n# ---------------------------------------------------------------------------\r\n\r\n.autodepend\r\n# ---------------------------------------------------------------------------\r\n\r\n!if !$d(BCC32)\r\nBCC32 = bcc32\r\n!endif\r\n\r\n# ---------------------------------------------------------------------------\r\n!if $d(PATHC)\r\n.PATH.C = $(PATHC)\r\n!endif\r\n\r\n# ---------------------------------------------------------------------------\r\nzlib: $(OBJFILES)\r\n\r\n# ---------------------------------------------------------------------------\r\n.c.obj:\r\n $(BCC)\\BIN\\$(BCC32) -c $(CFLAG1) $(WARNINGS) -I$(INCLUDEPATH) -D$(USERDEFINES);$(SYSDEFINES) -n$(@D) {$< }\r\n# ---------------------------------------------------------------------------\r\n\r\n\r\n\r\n\r\n" }, { "path": "External/Jedi/Jcl/source/windows/obj/zlib/win64/dirinfo.txt", "content": "This is the directory where object files of zlib (http://www.zlib.net) for win64 reside." }, { "path": "External/Jedi/Jcl/source/windows/obj/zlib/win64/makefile.mak", "content": "#\r\n# makefile to make zlib .obj files using Microsoft C++ compiler (cl.exe)\r\n#\r\n# if zlib source directory is different from ..\\..\\..\\..\\..\\..\\thirdparty\\zlib\\zlib-1.2.7, use\r\n# \"make -Dzlibsrc=\" to tell make where to find the\r\n# source files\r\n#\r\n# Make.exe needs to reside in the same directory as bcc32.exe.\r\n# For example, if you have Borlands free C++ v. 5.5 compiler (available from\r\n# http://www.borland.com/products/downloads/download_cbuilder.html#) installed:\r\n#\r\n# >C:\\Program Files\\Borland\\BCC55\\Bin\\make\r\n#\r\n# or, if you want to use C++ Builder 6:\r\n#\r\n# >C:\\Program Files\\Borland\\CBuilder6\\Bin\\make\r\n#\r\n# or, if you want to use Borland Developer Studio 2006:\r\n#\r\n# >C:\\Program files\\Borland\\BDS\\4.0\\bin\\make\r\n\r\n!if !$d(zlibsrc)\r\nzlibsrc = ..\\..\\..\\..\\..\\..\\thirdparty\\zlib\\zlib-1.2.7\r\n!endif\r\n\r\n# ---------------------------------------------------------------------------\r\nOBJFILES = .\\zutil.obj .\\compress.obj .\\crc32.obj .\\deflate.obj \\\r\n .\\infback.obj .\\inffast.obj .\\inflate.obj .\\inftrees.obj .\\trees.obj \\\r\n .\\uncompr.obj .\\adler32.obj\r\n# ---------------------------------------------------------------------------\r\nSYSDEFINES = NO_STRICT\r\nINCLUDEPATH = $(zlibsrc);$(BCC)\\include;$(BCB)\\include\\vcl\r\nPATHC = .;$(zlibsrc)\r\n# ---------------------------------------------------------------------------\r\nCFLAG1 = -O2 -Ve -X- -a8 -$(CPU) -b -d -k- -vi -tWM $(CallingConvention)\r\n\r\n# ---------------------------------------------------------------------------\r\n# MAKE SECTION\r\n# ---------------------------------------------------------------------------\r\n# This section of the project file is not used by the BCB IDE. It is for\r\n# the benefit of building from the command-line using the MAKE utility.\r\n# ---------------------------------------------------------------------------\r\n\r\n.autodepend\r\n# ---------------------------------------------------------------------------\r\n!if $d(PATHC)\r\n.PATH.C = $(PATHC)\r\n!endif\r\n\r\n# ---------------------------------------------------------------------------\r\nzlib: $(OBJFILES)\r\n\r\n# ---------------------------------------------------------------------------\r\n.c.obj:\r\n cl -c -nologo -D_KERNEL32_ -GS- -Z7 -wd4068 -I$(pcresrc) -D$(SYSDEFINES) -D$(USERDEFINES) -DHAVE_CONFIG_H -Gs999999 -Fo$@ $<\r\n# ---------------------------------------------------------------------------\r\n\r\n\r\n\r\n\r\n" }, { "path": "External/Jedi/Jcl/source/windows/sevenzip.pas", "content": "{**************************************************************************************************}\r\n{ }\r\n{ Project JEDI Code Library (JCL) }\r\n{ }\r\n{ interface of the 'sevenzip' (http://sourceforge.net/projects/sevenzip/) compression library }\r\n{ version 4.62, December 2th, 2008 }\r\n{ }\r\n{ Copyright (C) 1999-2008 Igor Pavlov }\r\n{ }\r\n{ GNU LGPL information }\r\n{ -------------------- }\r\n{ }\r\n{ This library is free software; you can redistribute it and/or modify it under the terms of }\r\n{ the GNU Lesser General Public License as published by the Free Software Foundation; either }\r\n{ version 2.1 of the License, or (at your option) any later version. }\r\n{ }\r\n{ This library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; }\r\n{ without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. }\r\n{ See the GNU Lesser General Public License for more details. }\r\n{ }\r\n{ You should have received a copy of the GNU Lesser General Public License along with this }\r\n{ library; if not, write to }\r\n{ the Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA }\r\n{ }\r\n{ unRAR restriction }\r\n{ ----------------- }\r\n{ }\r\n{ The decompression engine for RAR archives was developed using source code of unRAR program. }\r\n{ All copyrights to original unRAR code are owned by Alexander Roshal. }\r\n{ }\r\n{ The license for original unRAR code has the following restriction: }\r\n{ }\r\n{ The unRAR sources cannot be used to re-create the RAR compression algorithm, }\r\n{ which is proprietary. Distribution of modified unRAR sources in separate form }\r\n{ or as a part of other software is permitted, provided that it is clearly }\r\n{ stated in the documentation and source comments that the code may }\r\n{ not be used to develop a RAR (WinRAR) compatible archiver. }\r\n{ }\r\n{**************************************************************************************************}\r\n{ }\r\n{ Translation 2007-2008 Florent Ouchet for the JEDI Code Library }\r\n{ Contributors: }\r\n{ Uwe Schuster (uschuster) }\r\n{ Jan Goyvaerts (jgsoft) }\r\n{ }\r\n{**************************************************************************************************}\r\n{ }\r\n{ Last modified: $Date:: 2012-04-19 20:13:33 +0200 (jeu. 19 avr. 2012) $ }\r\n{ Revision: $Rev:: 3779 $ }\r\n{ Author: $Author:: outchy $ }\r\n{ }\r\n{**************************************************************************************************}\r\n\r\nunit sevenzip;\r\n\r\ninterface\r\n\r\n{$I jcl.inc}\r\n{$I windowsonly.inc}\r\n\r\nuses\r\n {$IFDEF HAS_UNITSCOPE}\r\n Winapi.ActiveX, Winapi.Windows,\r\n {$ELSE ~HAS_UNITSCOPE}\r\n ActiveX, Windows,\r\n {$ENDIF ~HAS_UNITSCOPE}\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n JclBase,\r\n JclSysUtils;\r\n\r\n//DOM-IGNORE-BEGIN\r\n\r\n// Guid.txt \r\nconst\r\n CLSID_CCodec : TGUID = '{23170F69-40C1-2790-0000-000000000000}';\r\n CLSID_CCodecBCJ2 : TGUID = '{23170F69-40C1-2790-1B01-030300000000}'; // BCJ2 0303011B\r\n CLSID_CCodecBCJ : TGUID = '{23170F69-40C1-2790-0301-030300000000}'; // BCJ 03030103\r\n CLSID_CCodecSWAP2 : TGUID = '{23170F69-40C1-2790-0203-030000000000}'; // swap2 020302\r\n CLSID_CCodecSWAP4 : TGUID = '{23170F69-40C1-2790-0403-020000000000}'; // swap4 020304\r\n CLSID_CCodecBPPC : TGUID = '{23170F69-40C1-2790-0502-030300000000}'; // branch ppc 03030205\r\n CLSID_CCodecBIA64 : TGUID = '{23170F69-40C1-2790-0104-030300000000}'; // branch IA64 03030401\r\n CLSID_CCodecBARM : TGUID = '{23170F69-40C1-2790-0105-030300000000}'; // branch ARM 03030501\r\n CLSID_CCodecBARMT : TGUID = '{23170F69-40C1-2790-0107-030300000000}'; // branch ARM Thumb 03030701\r\n CLSID_CCodecBARMS : TGUID = '{23170F69-40C1-2790-0508-030300000000}'; // branch ARM Sparc 03030805\r\n CLSID_CCodecBZIP : TGUID = '{23170F69-40C1-2790-0202-040000000000}'; // bzip2 040202\r\n CLSID_CCodecCOPY : TGUID = '{23170F69-40C1-2790-0000-000000000000}'; // copy 0\r\n CLSID_CCodecDEF64 : TGUID = '{23170F69-40C1-2790-0901-040000000000}'; // deflate64 040109\r\n CLSID_CCodecDEFNSIS : TGUID = '{23170F69-40C1-2790-0109-040000000000}'; // deflate nsis 040901\r\n CLSID_CCodecDEFREG : TGUID = '{23170F69-40C1-2790-0801-040000000000}'; // deflate register 040108\r\n CLSID_CCodecLZMA : TGUID = '{23170F69-40C1-2790-0101-030000000000}'; // lzma 030101\r\n CLSID_CCodecPPMD : TGUID = '{23170F69-40C1-2790-0104-030000000000}'; // ppmd 030401\r\n CLSID_CCodecRAR1 : TGUID = '{23170F69-40C1-2790-0103-040000000000}'; // rar1 040301\r\n CLSID_CCodecRAR2 : TGUID = '{23170F69-40C1-2790-0203-040000000000}'; // rar2 040302\r\n CLSID_CCodecRAR3 : TGUID = '{23170F69-40C1-2790-0303-040000000000}'; // rar3 040303\r\n CLSID_CAESCodec : TGUID = '{23170F69-40C1-2790-0107-F10600000000}'; // AES 06F10701\r\n\r\n CLSID_CArchiveHandler : TGUID = '{23170F69-40C1-278A-1000-000110000000}';\r\n CLSID_CFormatZip : TGUID = '{23170F69-40C1-278A-1000-000110010000}';\r\n CLSID_CFormatBZ2 : TGUID = '{23170F69-40C1-278A-1000-000110020000}';\r\n CLSID_CFormatRar : TGUID = '{23170F69-40C1-278A-1000-000110030000}';\r\n CLSID_CFormatArj : TGUID = '{23170F69-40C1-278A-1000-000110040000}';\r\n CLSID_CFormatZ : TGUID = '{23170F69-40C1-278A-1000-000110050000}';\r\n CLSID_CFormatLzh : TGUID = '{23170F69-40C1-278A-1000-000110060000}';\r\n CLSID_CFormat7z : TGUID = '{23170F69-40C1-278A-1000-000110070000}';\r\n CLSID_CFormatCab : TGUID = '{23170F69-40C1-278A-1000-000110080000}';\r\n CLSID_CFormatNsis : TGUID = '{23170F69-40C1-278A-1000-000110090000}';\r\n CLSID_CFormatLzma : TGUID = '{23170F69-40C1-278A-1000-0001100A0000}';\r\n CLSID_CFormatLzma86 : TGUID = '{23170F69-40C1-278A-1000-0001100B0000}';\r\n CLSID_CFormatXz : TGUID = '{23170F69-40C1-278A-1000-0001100C0000}';\r\n CLSID_CFormatPpmd : TGUID = '{23170F69-40C1-278A-1000-0001100D0000}';\r\n CLSID_CFormatTE : TGUID = '{23170F69-40C1-278A-1000-000110CF0000}';\r\n CLSID_CFormatUEFIc : TGUID = '{23170F69-40C1-278A-1000-000110D00000}';\r\n CLSID_CFormatUEFIs : TGUID = '{23170F69-40C1-278A-1000-000110D10000}';\r\n CLSID_CFormatSquashFS : TGUID = '{23170F69-40C1-278A-1000-000110D20000}';\r\n CLSID_CFormatCramFS : TGUID = '{23170F69-40C1-278A-1000-000110D30000}';\r\n CLSID_CFormatAPM : TGUID = '{23170F69-40C1-278A-1000-000110D40000}';\r\n CLSID_CFormatMslz : TGUID = '{23170F69-40C1-278A-1000-000110D50000}';\r\n CLSID_CFormatFlv : TGUID = '{23170F69-40C1-278A-1000-000110D60000}';\r\n CLSID_CFormatSwf : TGUID = '{23170F69-40C1-278A-1000-000110D70000}';\r\n CLSID_CFormatSwfc : TGUID = '{23170F69-40C1-278A-1000-000110D80000}';\r\n CLSID_CFormatNtfs : TGUID = '{23170F69-40C1-278A-1000-000110D90000}';\r\n CLSID_CFormatFat : TGUID = '{23170F69-40C1-278A-1000-000110DA0000}';\r\n CLSID_CFormatMbr : TGUID = '{23170F69-40C1-278A-1000-000110DB0000}';\r\n CLSID_CFormatVhd : TGUID = '{23170F69-40C1-278A-1000-000110DC0000}';\r\n CLSID_CFormatPe : TGUID = '{23170F69-40C1-278A-1000-000110DD0000}';\r\n CLSID_CFormatElf : TGUID = '{23170F69-40C1-278A-1000-000110DE0000}';\r\n CLSID_CFormatMacho : TGUID = '{23170F69-40C1-278A-1000-000110DF0000}';\r\n CLSID_CFormatUdf : TGUID = '{23170F69-40C1-278A-1000-000110E00000}';\r\n CLSID_CFormatXar : TGUID = '{23170F69-40C1-278A-1000-000110E10000}';\r\n CLSID_CFormatMub : TGUID = '{23170F69-40C1-278A-1000-000110E20000}';\r\n CLSID_CFormatHfs : TGUID = '{23170F69-40C1-278A-1000-000110E30000}';\r\n CLSID_CFormatDmg : TGUID = '{23170F69-40C1-278A-1000-000110E40000}';\r\n CLSID_CFormatCompound : TGUID = '{23170F69-40C1-278A-1000-000110E50000}';\r\n CLSID_CFormatWim : TGUID = '{23170F69-40C1-278A-1000-000110E60000}';\r\n CLSID_CFormatIso : TGUID = '{23170F69-40C1-278A-1000-000110E70000}';\r\n //CLSID_CFormatBkf : TGUID = '{23170F69-40C1-278A-1000-000110E80000}'; not in 4.57\r\n CLSID_CFormatChm : TGUID = '{23170F69-40C1-278A-1000-000110E90000}';\r\n CLSID_CFormatSplit : TGUID = '{23170F69-40C1-278A-1000-000110EA0000}';\r\n CLSID_CFormatRpm : TGUID = '{23170F69-40C1-278A-1000-000110EB0000}';\r\n CLSID_CFormatDeb : TGUID = '{23170F69-40C1-278A-1000-000110EC0000}';\r\n CLSID_CFormatCpio : TGUID = '{23170F69-40C1-278A-1000-000110ED0000}';\r\n CLSID_CFormatTar : TGUID = '{23170F69-40C1-278A-1000-000110EE0000}';\r\n CLSID_CFormatGZip : TGUID = '{23170F69-40C1-278A-1000-000110EF0000}';\r\n\r\n// IStream.h\r\ntype\r\n // \"23170F69-40C1-278A-0000-000300xx0000\"\r\n ISequentialInStream = interface(IUnknown)\r\n ['{23170F69-40C1-278A-0000-000300010000}']\r\n function Read(Data: Pointer; Size: Cardinal; ProcessedSize: PCardinal): HRESULT; stdcall;\r\n {Out: if size != 0, return_value = S_OK and (*processedSize == 0),\r\n then there are no more bytes in stream.\r\n if (size > 0) && there are bytes in stream,\r\n this function must read at least 1 byte.\r\n This function is allowed to read less than number of remaining bytes in stream.\r\n You must call Read function in loop, if you need exact amount of data}\r\n end;\r\n\r\n ISequentialOutStream = interface(IUnknown)\r\n ['{23170F69-40C1-278A-0000-000300020000}']\r\n function Write(Data: Pointer; Size: Cardinal; ProcessedSize: PCardinal): HRESULT; stdcall;\r\n {if (size > 0) this function must write at least 1 byte.\r\n This function is allowed to write less than \"size\".\r\n You must call Write function in loop, if you need to write exact amount of data}\r\n end;\r\n\r\n IInStream = interface(ISequentialInStream)\r\n ['{23170F69-40C1-278A-0000-000300030000}']\r\n function Seek(Offset: Int64; SeekOrigin: Cardinal; NewPosition: PInt64): HRESULT; stdcall;\r\n end;\r\n\r\n IOutStream = interface(ISequentialOutStream)\r\n ['{23170F69-40C1-278A-0000-000300040000}']\r\n function Seek(Offset: Int64; SeekOrigin: Cardinal; NewPosition: PInt64): HRESULT; stdcall;\r\n function SetSize(NewSize: Int64): HRESULT; stdcall;\r\n end;\r\n\r\n IStreamGetSize = interface(IUnknown)\r\n ['{23170F69-40C1-278A-0000-000300060000}']\r\n function GetSize(Size: PInt64): HRESULT; stdcall;\r\n end;\r\n\r\n IOutStreamFlush = interface(IUnknown)\r\n ['{23170F69-40C1-278A-0000-000300070000}']\r\n function Flush: HRESULT; stdcall;\r\n end;\r\n\r\n// PropID.h\r\nconst\r\n kpidNoProperty = 0;\r\n kpidMainSubfile = 1;\r\n kpidHandlerItemIndex = 2;\r\n kpidPath = 3;\r\n kpidName = 4;\r\n kpidExtension = 5;\r\n kpidIsFolder = 6 {$IFDEF SUPPORTS_DEPRECATED} deprecated {$IFDEF SUPPORTS_DEPRECATED_DETAILS} 'Use kpidIsDir' {$ENDIF} {$ENDIF};\r\n kpidIsDir = 6;\r\n kpidSize = 7;\r\n kpidPackedSize = 8 {$IFDEF SUPPORTS_DEPRECATED} deprecated {$IFDEF SUPPORTS_DEPRECATED_DETAILS} 'Use kpidPackSize' {$ENDIF} {$ENDIF};\r\n kpidPackSize = 8;\r\n kpidAttributes = 9 {$IFDEF SUPPORTS_DEPRECATED} deprecated {$IFDEF SUPPORTS_DEPRECATED_DETAILS} 'Use kpidAttrib' {$ENDIF} {$ENDIF};\r\n kpidAttrib = 9;\r\n kpidCreationTime = 10 {$IFDEF SUPPORTS_DEPRECATED} deprecated {$IFDEF SUPPORTS_DEPRECATED_DETAILS} 'Use kpidCTime' {$ENDIF} {$ENDIF};\r\n kpidCTime = 10;\r\n kpidLastAccessTime = 11 {$IFDEF SUPPORTS_DEPRECATED} deprecated {$IFDEF SUPPORTS_DEPRECATED_DETAILS} 'Use kpidATime' {$ENDIF} {$ENDIF};\r\n kpidATime = 11;\r\n kpidLastWriteTime = 12 {$IFDEF SUPPORTS_DEPRECATED} deprecated {$IFDEF SUPPORTS_DEPRECATED_DETAILS} 'Use kpidMTime' {$ENDIF} {$ENDIF};\r\n kpidMTime = 12;\r\n kpidSolid = 13;\r\n kpidCommented = 14;\r\n kpidEncrypted = 15;\r\n kpidSplitBefore = 16;\r\n kpidSplitAfter = 17;\r\n kpidDictionarySize = 18;\r\n kpidCRC = 19;\r\n kpidType = 20;\r\n kpidIsAnti = 21;\r\n kpidMethod = 22;\r\n kpidHostOS = 23;\r\n kpidFileSystem = 24;\r\n kpidUser = 25;\r\n kpidGroup = 26;\r\n kpidBlock = 27;\r\n kpidComment = 28;\r\n kpidPosition = 29;\r\n kpidPrefix = 30;\r\n kpidNumSubDirs = 31;\r\n kpidNumSubFiles = 32;\r\n kpidUnpackVer = 33;\r\n kpidVolume = 34;\r\n kpidIsVolume = 35;\r\n kpidOffset = 36;\r\n kpidLinks = 37;\r\n kpidNumBlocks = 38;\r\n kpidNumVolumes = 39;\r\n kpidTimeType = 40;\r\n kpidBit64 = 41;\r\n kpidBigEndian = 42;\r\n kpidCpu = 43;\r\n kpidPhySize = 44;\r\n kpidHeadersSize = 45;\r\n kpidChecksum = 46;\r\n kpidCharacts = 47;\r\n kpidVa = 48;\r\n kpidId = 49;\r\n kpidShortName = 50;\r\n kpidCreatorApp = 51;\r\n kpidSectorSize = 52;\r\n kpidPosixAttrib = 53;\r\n kpidLink = 54;\r\n\r\n kpidTotalSize = $1100;\r\n kpidFreeSpace = $1101;\r\n kpidClusterSize = $1102;\r\n kpidVolumeName = $1103;\r\n\r\n kpidLocalName = $1200;\r\n kpidProvider = $1201;\r\n\r\n kpidUserDefined = $10000;\r\n\r\n// HandlerOut.cpp\r\n\r\n kCopyMethodName = WideString('Copy');\r\n kLZMAMethodName = WideString('LZMA');\r\n kLZMA2MethodName = WideString('LZMA2');\r\n kBZip2MethodName = WideString('BZip2');\r\n kPpmdMethodName = WideString('PPMd');\r\n kDeflateMethodName = WideString('Deflate');\r\n kDeflate64MethodName = WideString('Deflate64');\r\n\r\n kAES128MethodName = WideString('AES128');\r\n kAES192MethodName = WideString('AES192');\r\n kAES256MethodName = WideString('AES256');\r\n kZipCryptoMethodName = WideString('ZIPCRYPTO');\r\n\r\n// ICoder.h\r\ntype\r\n ICompressProgressInfo = interface(IUnknown)\r\n ['{23170F69-40C1-278A-0000-000400040000}']\r\n function SetRatioInfo(InSize: PInt64; OutSize: PInt64): HRESULT; stdcall;\r\n end;\r\n\r\n ICompressCoder = interface(IUnknown)\r\n ['{23170F69-40C1-278A-0000-000400050000}']\r\n function Code(InStream: ISequentialInStream; OutStream: ISequentialOutStream;\r\n InSize, OutSize: PInt64; Progress: ICompressProgressInfo): HRESULT; stdcall;\r\n end;\r\n\r\n PISequentialInStream = ^ISequentialInStream;\r\n PISequentialOutStream = ^ISequentialOutStream;\r\n\r\n ICompressCoder2 = interface(IUnknown)\r\n ['{23170F69-40C1-278A-0000-000400180000}']\r\n function Code(InStreams: PISequentialInStream; InSizes: JclBase.PPInt64; NumInStreams: Cardinal;\r\n OutStreams: PISequentialOutStream; OutSizes: JclBase.PPInt64; NumOutStreams: Cardinal;\r\n Progress: ICompressProgressInfo): HRESULT; stdcall;\r\n end;\r\n\r\nconst\r\n kDictionarySize = $400;\r\n kUsedMemorySize = $401;\r\n kOrder = $402;\r\n kBlockSize = $403;\r\n kPosStateBits = $440;\r\n kLitContextBits = $441;\r\n kLitPosBits = $442;\r\n kNumFastBytes = $450;\r\n kMatchFinder = $451;\r\n kMatchFinderCycles = $452;\r\n kNumPasses = $460;\r\n kAlgorithm = $470;\r\n kMultiThread = $480;\r\n kNumThreads = $481;\r\n kEndMarker = $490;\r\n\r\ntype\r\n ICompressSetCoderProperties = interface(IUnknown)\r\n ['{23170F69-40C1-278A-0000-000400200000}']\r\n function SetCoderProperties(PropIDs: PPropID; Properties: PPropVariant;\r\n NumProperties: Cardinal): HRESULT; stdcall;\r\n end;\r\n\r\n ICompressSetDecoderProperties2 = interface(IUnknown)\r\n ['{23170F69-40C1-278A-0000-000400220000}']\r\n function SetDecoderProperties2(Data: PByte; Size: Cardinal): HRESULT; stdcall;\r\n end;\r\n\r\n ICompressWriteCoderProperties = interface(IUnknown)\r\n ['{23170F69-40C1-278A-0000-000400230000}']\r\n function WriteCoderProperties(OutStream: ISequentialOutStream): HRESULT; stdcall;\r\n end;\r\n\r\n ICompressGetInStreamProcessedSize = interface(IUnknown)\r\n ['{23170F69-40C1-278A-0000-000400240000}']\r\n function GetInStreamProcessedSize(Value: PInt64): HRESULT; stdcall;\r\n end;\r\n\r\n ICompressSetCoderMt = interface(IUnknown)\r\n ['{23170F69-40C1-278A-0000-000400250000}']\r\n function SetNumberOfThreads(NumThreads: Cardinal): HRESULT; stdcall;\r\n end;\r\n\r\n ICompressGetSubStreamSize = interface(IUnknown)\r\n ['{23170F69-40C1-278A-0000-000400300000}']\r\n function GetSubStreamSize(SubStream: Int64; out Value: Int64): HRESULT; stdcall;\r\n end;\r\n\r\n ICompressSetInStream = interface(IUnknown)\r\n ['{23170F69-40C1-278A-0000-000400310000}']\r\n function SetInStream(InStream: ISequentialInStream): HRESULT; stdcall;\r\n function ReleaseInStream: HRESULT; stdcall;\r\n end;\r\n\r\n ICompressSetOutStream = interface(IUnknown)\r\n ['{23170F69-40C1-278A-0000-000400320000}']\r\n function SetOutStream(OutStream: ISequentialOutStream): HRESULT; stdcall;\r\n function ReleaseOutStream: HRESULT; stdcall;\r\n end;\r\n\r\n ICompressSetInStreamSize = interface(IUnknown)\r\n ['{23170F69-40C1-278A-0000-000400330000}']\r\n function SetInStreamSize(InSize: PInt64): HRESULT; stdcall;\r\n end;\r\n\r\n ICompressSetOutStreamSize = interface(IUnknown)\r\n ['{23170F69-40C1-278A-0000-000400340000}']\r\n function SetOutStreamSize(OutSize: PInt64): HRESULT; stdcall;\r\n end;\r\n\r\n ICompressFilter = interface(IUnknown)\r\n ['{23170F69-40C1-278A-0000-000400400000}']\r\n function Init: HRESULT; stdcall;\r\n function Filter(Data: PByte; Size: Cardinal): Cardinal; stdcall;\r\n // Filter return outSize (UInt32)\r\n // if (outSize <= size): Filter have converted outSize bytes\r\n // if (outSize > size): Filter have not converted anything.\r\n // and it needs at least outSize bytes to convert one block\r\n // (it's for crypto block algorithms).\r\n end;\r\n\r\n ICompressCodecsInfo = interface(IUnknown)\r\n ['{23170F69-40C1-278A-0000-000400600000}']\r\n function GetNumberOfMethods(NumMethods: PCardinal): HRESULT; stdcall;\r\n function GetProperty(Index: Cardinal; PropID: TPropID; out Value: TPropVariant): HRESULT; stdcall;\r\n function CreateDecoder(Index: Cardinal; IID: PGUID; out Decoder): HRESULT; stdcall;\r\n function CreateEncoder(Index: Cardinal; IID: PGUID; out Coder): HRESULT; stdcall;\r\n end;\r\n\r\n ISetCompressCodecsInfo = interface(IUnknown)\r\n ['{23170F69-40C1-278A-0000-000400610000}']\r\n function SetCompressCodecsInfo(CompressCodecsInfo: ICompressCodecsInfo): HRESULT; stdcall;\r\n end;\r\n\r\n ICryptoProperties = interface(IUnknown)\r\n ['{23170F69-40C1-278A-0000-000400800000}']\r\n function SetKey(Data: PByte; Size: Cardinal): HRESULT; stdcall;\r\n function SetInitVector(Data: PByte; Size: Cardinal): HRESULT; stdcall;\r\n end;\r\n\r\n ICryptoSetPassword = interface(IUnknown)\r\n ['{23170F69-40C1-278A-0000-000400900000}']\r\n function CryptoSetPassword(Data: PByte; Size: Cardinal): HRESULT; stdcall;\r\n end;\r\n\r\n ICryptoSetCRC = interface(IUnknown)\r\n ['{23170F69-40C1-278A-0000-000400A00000}']\r\n function CryptoSetCRC(crc: Cardinal): HRESULT; stdcall;\r\n end;\r\n\r\nconst\r\n kID = 0;\r\n kName = 1;\r\n kDecoder = 2;\r\n kEncoder = 3;\r\n kInStreams = 4;\r\n kOutStreams = 5;\r\n kDescription = 6;\r\n kDecoderIsAssigned = 7;\r\n kEncoderIsAssigned = 8;\r\n\r\n// IProgress.h\r\ntype\r\n IProgress = interface(IUnknown)\r\n ['{23170F69-40C1-278A-0000-000000050000}']\r\n function SetTotal(Total: Int64): HRESULT; stdcall;\r\n function SetCompleted(CompleteValue: PInt64): HRESULT; stdcall;\r\n end;\r\n \r\n// IArchive.h\r\nconst\r\n // file time type\r\n kWindows = 0;\r\n kUnix = 1;\r\n kDOS = 2;\r\n\r\n // archive\r\n kArchiveName = 0;\r\n kClassID = 1;\r\n kExtension = 2;\r\n kAddExtension = 3;\r\n kUpdate = 4;\r\n kKeepName = 5;\r\n kStartSignature = 6;\r\n kFinishSignature = 7;\r\n kAssociate = 8;\r\n\r\n // ask mode\r\n kExtract = 0;\r\n kTest = 1;\r\n kSkip = 2;\r\n\r\n // operation result\r\n kOK = 0;\r\n kUnSupportedMethod = 1;\r\n kDataError = 2;\r\n kCRCError = 3;\r\n\r\n kError = 1;\r\n\r\ntype\r\n // \"23170F69-40C1-278A-0000-000600xx0000\"\r\n IArchiveOpenCallback = interface(IUnknown)\r\n ['{23170F69-40C1-278A-0000-000600100000}']\r\n function SetTotal(Files: PInt64; Bytes: PInt64): HRESULT; stdcall;\r\n function SetCompleted(Files: PInt64; Bytes: PInt64): HRESULT; stdcall;\r\n end;\r\n\r\n IArchiveExtractCallback = interface(IProgress)\r\n ['{23170F69-40C1-278A-0000-000600200000}']\r\n function GetStream(Index: Cardinal; out OutStream: ISequentialOutStream;\r\n askExtractMode: Cardinal): HRESULT; stdcall;\r\n // GetStream OUT: S_OK - OK, S_FALSE - skeep this file\r\n function PrepareOperation(askExtractMode: Cardinal): HRESULT; stdcall;\r\n function SetOperationResult(resultEOperationResult: Integer): HRESULT; stdcall;\r\n end;\r\n\r\n IArchiveOpenVolumeCallback = interface(IUnknown)\r\n ['{23170F69-40C1-278A-0000-000600300000}']\r\n function GetProperty(PropID: TPropID; out Value: TPropVariant): HRESULT; stdcall;\r\n function GetStream(Name: PWideChar; out InStream: IInStream): HRESULT; stdcall;\r\n end;\r\n\r\n IInArchiveGetStream = interface(IUnknown)\r\n ['{23170F69-40C1-278A-0000-000600400000}']\r\n function GetStream(Index: Cardinal; out Stream: ISequentialInStream): HRESULT; stdcall;\r\n end;\r\n\r\n IArchiveOpenSetSubArchiveName = interface(IUnknown)\r\n ['{23170F69-40C1-278A-0000-000600500000}']\r\n function SetSubArchiveName(Name: PWideChar): HRESULT; stdcall;\r\n end;\r\n\r\n IInArchive = interface(IUnknown)\r\n ['{23170F69-40C1-278A-0000-000600600000}']\r\n function Open(Stream: IInStream; MaxCheckStartPosition: PInt64;\r\n OpenArchiveCallback: IArchiveOpenCallback): HRESULT; stdcall;\r\n function Close: HRESULT; stdcall;\r\n function GetNumberOfItems(NumItems: PCardinal): HRESULT; stdcall;\r\n function GetProperty(Index: Cardinal; PropID: TPropID;\r\n var Value: TPropVariant): HRESULT; stdcall;\r\n function Extract(Indices: PCardinal; NumItems: Cardinal;\r\n TestMode: Integer; ExtractCallback: IArchiveExtractCallback): HRESULT; stdcall;\r\n // indices must be sorted\r\n // numItems = 0xFFFFFFFF means all files\r\n // testMode != 0 means \"test files operation\"\r\n function GetArchiveProperty(PropID: TPropID; out Value: TPropVariant): HRESULT; stdcall;\r\n\r\n function GetNumberOfProperties(NumProperties: PCardinal): HRESULT; stdcall;\r\n function GetPropertyInfo(Index: Cardinal; out Name: TBStr; out PropID: TPropID;\r\n out VarType: TVarType): HRESULT; stdcall;\r\n\r\n function GetNumberOfArchiveProperties(NumProperties: PCardinal): HRESULT; stdcall;\r\n function GetArchivePropertyInfo(Index: Cardinal; out Name: TBStr; out PropID: TPropID;\r\n out VarType: TVarType): HRESULT; stdcall;\r\n end;\r\n\r\n IArchiveUpdateCallback = interface(IProgress)\r\n ['{23170F69-40C1-278A-0000-000600800000}']\r\n function GetUpdateItemInfo(Index: Cardinal;\r\n NewData: PInteger; // 1 - new data, 0 - old data\r\n NewProperties: PInteger; // 1 - new properties, 0 - old properties\r\n IndexInArchive: PCardinal // -1 if there is no in archive, or if doesn't matter\r\n ): HRESULT; stdcall;\r\n function GetProperty(Index: Cardinal; PropID: TPropID; out Value: TPropVariant): HRESULT; stdcall;\r\n function GetStream(Index: Cardinal; out InStream: ISequentialInStream): HRESULT; stdcall;\r\n function SetOperationResult(OperationResult: Integer): HRESULT; stdcall;\r\n end;\r\n\r\n IArchiveUpdateCallback2 = interface(IArchiveUpdateCallback)\r\n ['{23170F69-40C1-278A-0000-000600820000}']\r\n function GetVolumeSize(Index: Cardinal; Size: PInt64): HRESULT; stdcall;\r\n function GetVolumeStream(Index: Cardinal; out VolumeStream: ISequentialOutStream): HRESULT; stdcall;\r\n end;\r\n\r\n IOutArchive = interface(IUnknown)\r\n ['{23170F69-40C1-278A-0000-000600A00000}']\r\n function UpdateItems(OutStream: ISequentialOutStream; NumItems: Cardinal;\r\n UpdateCallback: IArchiveUpdateCallback): HRESULT; stdcall;\r\n function GetFileTimeType(Type_: PCardinal): HRESULT; stdcall;\r\n end;\r\n\r\n ISetProperties = interface(IUnknown)\r\n ['{23170F69-40C1-278A-0000-000600030000}']\r\n function SetProperties(Names: PPWideChar; Values: PPropVariant; NumProperties: Integer): HRESULT; stdcall;\r\n end;\r\n\r\n// IPassword.h\r\ntype\r\n ICryptoGetTextPassword = interface(IUnknown)\r\n ['{23170F69-40C1-278A-0000-000500100000}']\r\n function CryptoGetTextPassword(password: PBStr): HRESULT; stdcall;\r\n end;\r\n\r\n ICryptoGetTextPassword2 = interface(IUnknown)\r\n ['{23170F69-40C1-278A-0000-000500110000}']\r\n function CryptoGetTextPassword2(PasswordIsDefined: PInteger;\r\n Password: PBStr): HRESULT; stdcall;\r\n end;\r\n\r\n// ZipHandlerOut.cpp\r\nconst\r\n kDeflateAlgoX1 = 0 {$IFDEF SUPPORTS_DEPRECATED} deprecated {$IFDEF SUPPORTS_DEPRECATED_DETAILS} 'Use kLzAlgoX1' {$ENDIF} {$ENDIF};\r\n kLzAlgoX1 = 0;\r\n kDeflateAlgoX5 = 1 {$IFDEF SUPPORTS_DEPRECATED} deprecated {$IFDEF SUPPORTS_DEPRECATED_DETAILS} 'Use kLzAlgoX5' {$ENDIF} {$ENDIF};\r\n kLzAlgoX5 = 1;\r\n\r\n kDeflateNumPassesX1 = 1;\r\n kDeflateNumPassesX7 = 3;\r\n kDeflateNumPassesX9 = 10;\r\n\r\n kNumFastBytesX1 = 32 {$IFDEF SUPPORTS_DEPRECATED} deprecated {$IFDEF SUPPORTS_DEPRECATED_DETAILS} 'Use kDeflateNumFastBytesX1' {$ENDIF} {$ENDIF};\r\n kDeflateNumFastBytesX1 = 32;\r\n kNumFastBytesX7 = 64 {$IFDEF SUPPORTS_DEPRECATED} deprecated {$IFDEF SUPPORTS_DEPRECATED_DETAILS} 'Use kDeflateNumFastBytesX7' {$ENDIF} {$ENDIF};\r\n kDeflateNumFastBytesX7 = 64;\r\n kNumFastBytesX9 = 128 {$IFDEF SUPPORTS_DEPRECATED} deprecated {$IFDEF SUPPORTS_DEPRECATED_DETAILS} 'Use kDeflateNumFastBytesX9' {$ENDIF} {$ENDIF};\r\n kDeflateNumFastBytesX9 = 128;\r\n\r\n kLzmaNumFastBytesX1 = 32;\r\n kLzmaNumFastBytesX7 = 64;\r\n\r\n kBZip2NumPassesX1 = 1;\r\n kBZip2NumPassesX7 = 2;\r\n kBZip2NumPassesX9 = 7;\r\n\r\n kBZip2DicSizeX1 = 100000;\r\n kBZip2DicSizeX3 = 500000;\r\n kBZip2DicSizeX5 = 900000;\r\n\r\n// HandlerOut.cpp\r\nconst\r\n kLzmaAlgoX1 = 0;\r\n kLzmaAlgoX5 = 1;\r\n\r\n kLzmaDicSizeX1 = 1 shl 16;\r\n kLzmaDicSizeX3 = 1 shl 20;\r\n kLzmaDicSizeX5 = 1 shl 24;\r\n kLzmaDicSizeX7 = 1 shl 25;\r\n kLzmaDicSizeX9 = 1 shl 26;\r\n\r\n kLzmaFastBytesX1 = 32;\r\n kLzmaFastBytesX7 = 64;\r\n\r\n kPpmdMemSizeX1 = (1 shl 22);\r\n kPpmdMemSizeX5 = (1 shl 24);\r\n kPpmdMemSizeX7 = (1 shl 26);\r\n kPpmdMemSizeX9 = (192 shl 20);\r\n\r\n kPpmdOrderX1 = 4;\r\n kPpmdOrderX5 = 6;\r\n kPpmdOrderX7 = 16;\r\n kPpmdOrderX9 = 32;\r\n\r\n kDeflateFastBytesX1 = 32;\r\n kDeflateFastBytesX7 = 64;\r\n kDeflateFastBytesX9 = 128;\r\n\r\n{$IFDEF 7ZIP_LINKONREQUEST}\r\ntype\r\n TCreateObjectFunc = function (ClsID: PGUID; IID: PGUID; out Obj): HRESULT; stdcall;\r\n TGetHandlerProperty2 = function (FormatIndex: Cardinal; PropID: TPropID; out Value: TPropVariant): HRESULT; stdcall;\r\n TGetHandlerProperty = function (PropID: TPropID; out Value: TPropVariant): HRESULT; stdcall;\r\n TGetMethodProperty = function (CodecIndex: Cardinal; PropID: TPropID; out Value: TPropVariant): HRESULT; stdcall;\r\n TGetNumberOfFormatsFunc = function (NumFormats: PCardinal): HRESULT; stdcall;\r\n TGetNumberOfMethodsFunc = function (NumMethods: PCardinal): HRESULT; stdcall;\r\n TSetLargePageMode = function: HRESULT; stdcall;\r\n\r\nvar\r\n CreateObject: TCreateObjectFunc = nil;\r\n GetHandlerProperty2: TGetHandlerProperty2 = nil;\r\n GetHandlerProperty: TGetHandlerProperty = nil;\r\n GetMethodProperty: TGetMethodProperty = nil;\r\n GetNumberOfFormats: TGetNumberOfFormatsFunc = nil;\r\n GetNumberOfMethods: TGetNumberOfMethodsFunc = nil;\r\n SetLargePageMode: TSetLargePageMode = nil;\r\n{$ELSE ~7ZIP_LINKONREQUEST}\r\nfunction CreateObject(ClsID: PGUID; IID: PGUID; out Obj): HRESULT; stdcall;\r\nfunction GetHandlerProperty2(FormatIndex: Cardinal; PropID: TPropID; out Value: TPropVariant): HRESULT; stdcall;\r\nfunction GetHandlerProperty(PropID: TPropID; out Value: TPropVariant): HRESULT; stdcall;\r\nfunction GetMethodProperty(CodecIndex: Cardinal; PropID: TPropID; out Value: TPropVariant): HRESULT; stdcall;\r\nfunction GetNumberOfFormats(NumFormats: PCardinal): HRESULT; stdcall;\r\nfunction GetNumberOfMethods(NumMethods: PCardinal): HRESULT; stdcall;\r\nfunction SetLargePageMode: HRESULT; stdcall;\r\n{$ENDIF ~7ZIP_LINKONREQUEST}\r\n\r\n//DOM-IGNORE-END\r\n\r\nconst\r\n SevenzipDefaultLibraryName = '7z.dll';\r\n CreateObjectDefaultExportName = 'CreateObject';\r\n GetHandlerProperty2DefaultExportName = 'GetHandlerProperty2';\r\n GetHandlerPropertyDefaultExportName = 'GetHandlerProperty';\r\n GetMethodPropertyDefaultExportName = 'GetMethodProperty';\r\n GetNumberOfFormatsDefaultExportName = 'GetNumberOfFormats';\r\n GetNumberOfMethodsDefaultExportName = 'GetNumberOfMethods';\r\n SetLargePageModeDefaultExportName = 'SetLargePageMode';\r\n\r\n{$IFDEF 7ZIP_LINKONREQUEST}\r\nvar\r\n SevenzipLibraryName: string = SevenzipDefaultLibraryName;\r\n CreateObjectExportName: string = CreateObjectDefaultExportName;\r\n GetHandlerProperty2ExportName: string = GetHandlerProperty2DefaultExportName;\r\n GetHandlerPropertyExportName: string = GetHandlerPropertyDefaultExportName;\r\n GetMethodPropertyExportName: string = GetMethodPropertyDefaultExportName;\r\n GetNumberOfFormatsExportName: string = GetNumberOfFormatsDefaultExportName;\r\n GetNumberOfMethodsExportName: string = GetNumberOfMethodsDefaultExportName;\r\n SetLargePageModeExportName: string = SetLargePageModeDefaultExportName;\r\n SevenzipLibraryHandle: TModuleHandle = INVALID_MODULEHANDLE_VALUE;\r\n{$ENDIF 7ZIP_LINKONREQUEST}\r\n\r\nfunction Load7Zip: Boolean;\r\nfunction Is7ZipLoaded: Boolean;\r\nprocedure Unload7Zip;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jcl.svn.sourceforge.net/svnroot/jcl/tags/JCL-2.4-Build4571/jcl/source/windows/sevenzip.pas $';\r\n Revision: '$Revision: 3779 $';\r\n Date: '$Date: 2012-04-19 20:13:33 +0200 (jeu. 19 avr. 2012) $';\r\n LogPath: 'JCL\\source\\windows';\r\n Extra: '';\r\n Data: nil\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\n{$IFDEF 7ZIP_LINKDLL}\r\nfunction CreateObject; external SevenzipDefaultLibraryName name CreateObjectDefaultExportName;\r\nfunction GetHandlerProperty2; external SevenzipDefaultLibraryName name GetHandlerProperty2DefaultExportName;\r\nfunction GetHandlerProperty; external SevenzipDefaultLibraryName name GetHandlerPropertyDefaultExportName;\r\nfunction GetMethodProperty; external SevenzipDefaultLibraryName name GetMethodPropertyDefaultExportName;\r\nfunction GetNumberOfFormats; external SevenzipDefaultLibraryName name GetNumberOfFormatsDefaultExportName;\r\nfunction GetNumberOfMethods; external SevenzipDefaultLibraryName name GetNumberOfMethodsDefaultExportName;\r\nfunction SetLargePageMode; external SevenzipDefaultLibraryName name SetLargePageModeDefaultExportName;\r\n{$ENDIF 7ZIP_LINKDLL}\r\n\r\nfunction Load7Zip: Boolean;\r\n{$IFDEF 7ZIP_LINKONREQUEST}\r\nbegin\r\n Result := SevenzipLibraryHandle <> INVALID_MODULEHANDLE_VALUE;\r\n if Result then\r\n Exit;\r\n\r\n Result := JclSysUtils.LoadModule(SevenzipLibraryHandle, SevenzipLibraryName);\r\n if Result then\r\n begin\r\n @CreateObject := GetModuleSymbol(SevenzipLibraryHandle, CreateObjectExportName);\r\n @GetHandlerProperty2 := GetModuleSymbol(SevenzipLibraryHandle, GetHandlerProperty2ExportName);\r\n @GetHandlerProperty := GetModuleSymbol(SevenzipLibraryHandle, GetHandlerPropertyExportName);\r\n @GetMethodProperty := GetModuleSymbol(SevenzipLibraryHandle, GetMethodPropertyExportName);\r\n @GetNumberOfFormats := GetModuleSymbol(SevenzipLibraryHandle, GetNumberOfFormatsExportName);\r\n @GetNumberOfMethods := GetModuleSymbol(SevenzipLibraryHandle, GetNumberOfMethodsExportName);\r\n @SetLargePageMode := GetModuleSymbol(SevenzipLibraryHandle, SetLargePageModeExportName);\r\n Result := Assigned(@CreateObject) and Assigned(@GetHandlerProperty2) and\r\n Assigned(@GetHandlerProperty) and Assigned(@GetMethodProperty) and\r\n Assigned(@GetNumberOfFormats) and Assigned(@GetNumberOfMethods) and\r\n Assigned(@SetLargePageMode);\r\n end;\r\nend;\r\n{$ELSE ~7ZIP_LINKONREQUEST}\r\nbegin\r\n Result := True;\r\nend;\r\n{$ENDIF ~7ZIP_LINKONREQUEST}\r\n\r\nfunction Is7ZipLoaded: Boolean;\r\nbegin\r\n {$IFDEF 7ZIP_LINKONREQUEST}\r\n Result := SevenzipLibraryHandle <> INVALID_MODULEHANDLE_VALUE;\r\n {$ELSE ~7ZIP_LINKONREQUEST}\r\n Result := True;\r\n {$ENDIF ~7ZIP_LINKONREQUEST}\r\nend;\r\n\r\nprocedure Unload7Zip;\r\nbegin\r\n {$IFDEF 7ZIP_LINKONREQUEST}\r\n @CreateObject := nil;\r\n @GetHandlerProperty2 := nil;\r\n @GetHandlerProperty := nil;\r\n @GetMethodProperty := nil;\r\n @GetNumberOfFormats := nil;\r\n @GetNumberOfMethods := nil;\r\n @SetLargePageMode := nil;\r\n JclSysUtils.UnloadModule(SevenzipLibraryHandle);\r\n {$ENDIF 7ZIP_LINKONREQUEST}\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/common/common.txt", "content": "This folder contains files that might be shared by other parts of JEDI, like INC files and API translation. " }, { "path": "External/Jedi/Jvcl/common/crossplatform.inc", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: crossplatform.inc, released on 2004-05-16.\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: crossplatform.inc 12461 2009-08-14 17:21:33Z obones $\r\n\r\n// This inc file depends on jedi.inc which has to\r\n// be included first (usually indirectly through\r\n// the inclusion of jvcl.inc).\r\n\r\n// Suppress platform warnings which are irrelevant\r\n// because the including unit inherently has to handle\r\n// platform specifics already.\r\n\r\n{$IFDEF SUPPORTS_PLATFORM_WARNINGS}\r\n {$WARN UNIT_PLATFORM OFF}\r\n {$WARN SYMBOL_PLATFORM OFF}\r\n{$ENDIF SUPPORTS_PLATFORM_WARNINGS}" }, { "path": "External/Jedi/Jvcl/common/jedi/jedi.inc", "content": "{$IFNDEF JEDI_INC}\r\n{$DEFINE JEDI_INC}\r\n\r\n{**************************************************************************************************}\r\n{ }\r\n{ The contents of this file are subject to the Mozilla Public License Version 1.1 (the \"License\");}\r\n{ you may not use this file except in compliance with the License. You may obtain a copy of the }\r\n{ License at http://www.mozilla.org/MPL/ }\r\n{ }\r\n{ Software distributed under the License is distributed on an \"AS IS\" basis, WITHOUT WARRANTY OF }\r\n{ ANY KIND, either express or implied. See the License for the specific language governing rights }\r\n{ and limitations under the License. }\r\n{ }\r\n{ The Original Code is: jedi.inc. }\r\n{ The Initial Developer of the Original Code is Project JEDI http://www.delphi-jedi.org }\r\n{ }\r\n{ Alternatively, the contents of this file may be used under the terms of the GNU Lesser General }\r\n{ Public License (the \"LGPL License\"), in which case the provisions of the LGPL License are }\r\n{ applicable instead of those above. If you wish to allow use of your version of this file only }\r\n{ under the terms of the LGPL License and not to allow others to use your version of this file }\r\n{ under the MPL, indicate your decision by deleting the provisions above and replace them with }\r\n{ the notice and other provisions required by the LGPL License. If you do not delete the }\r\n{ provisions above, a recipient may use your version of this file under either the MPL or the }\r\n{ LGPL License. }\r\n{ }\r\n{ For more information about the LGPL: http://www.gnu.org/copyleft/lesser.html }\r\n{ }\r\n{**************************************************************************************************}\r\n{ }\r\n{ This file defines various generic compiler directives used in different libraries, e.g. in the }\r\n{ JEDI Code Library (JCL) and JEDI Visual Component Library Library (JVCL). The directives in }\r\n{ this file are of generic nature and consist mostly of mappings from the VERXXX directives }\r\n{ defined by Delphi, C++Builder and FPC to friendly names such as DELPHI5 and }\r\n{ SUPPORTS_WIDESTRING. These friendly names are subsequently used in the libraries to test for }\r\n{ compiler versions and/or whether the compiler supports certain features (such as widestrings or }\r\n{ 64 bit integers. The libraries provide an additional, library specific, include file. For the }\r\n{ JCL e.g. this is jcl.inc. These files should be included in source files instead of this file }\r\n{ (which is pulled in automatically). }\r\n{ }\r\n{**************************************************************************************************}\r\n{ }\r\n{ Last modified: $Date:: 2012-09-04 16:01:38 +0200 (mar. 04 sept. 2012) $ }\r\n{ Revision: $Rev:: 161 $ }\r\n{ Author: $Author:: outchy $ }\r\n{ }\r\n{**************************************************************************************************}\r\n\r\n(*\r\n\r\n- Development environment directives\r\n\r\n This file defines two directives to indicate which development environment the\r\n library is being compiled with. Currently this can either be Delphi, Kylix,\r\n C++Builder or FPC.\r\n\r\n Directive Description\r\n ------------------------------------------------------------------------------\r\n DELPHI Defined if compiled with Delphi\r\n KYLIX Defined if compiled with Kylix\r\n DELPHICOMPILER Defined if compiled with Delphi or Kylix/Delphi\r\n BCB Defined if compiled with C++Builder\r\n CPPBUILDER Defined if compiled with C++Builder (alias for BCB)\r\n BCBCOMPILER Defined if compiled with C++Builder or Kylix/C++\r\n DELPHILANGUAGE Defined if compiled with Delphi, Kylix or C++Builder\r\n BORLAND Defined if compiled with Delphi, Kylix or C++Builder\r\n FPC Defined if compiled with FPC\r\n\r\n- Platform Directives\r\n\r\n Platform directives are not all explicitly defined in this file, some are\r\n defined by the compiler itself. They are listed here only for completeness.\r\n\r\n Directive Description\r\n ------------------------------------------------------------------------------\r\n WIN32 Defined when target platform is 32 bit Windows\r\n WIN64 Defined when target platform is 64 bit Windows\r\n MSWINDOWS Defined when target platform is 32 bit Windows\r\n LINUX Defined when target platform is Linux\r\n UNIX Defined when target platform is Unix-like (including Linux)\r\n CLR Defined when target platform is .NET\r\n\r\n- Architecture directives. These are auto-defined by FPC\r\n CPU32 and CPU64 are mostly for generic pointer size dependant differences rather\r\n than for a specific architecture.\r\n\r\n CPU386 Defined when target platform is native x86 (win32)\r\n CPUx86_64 Defined when target platform is native x86_64 (win64)\r\n CPU32 Defined when target is 32-bit\r\n CPU64\t Defined when target is 64-bit\r\n CPUASM Defined when target assembler is available\r\n\r\n- Visual library Directives\r\n\r\n The following directives indicate for a visual library. In a Delphi/BCB\r\n (Win32) application you need to define the VisualCLX symbol in the project\r\n options, if you want to use the VisualCLX library. Alternatively you can use\r\n the IDE expert, which is distributed with the JCL to do this automatically.\r\n\r\n Directive Description\r\n ------------------------------------------------------------------------------\r\n VCL Defined for Delphi/BCB (Win32) exactly if VisualCLX is not defined\r\n VisualCLX Defined for Kylix; needs to be defined for Delphi/BCB to\r\n use JCL with VisualCLX applications.\r\n\r\n\r\n- Other cross-platform related defines\r\n\r\n These symbols are intended to help in writing portable code.\r\n\r\n Directive Description\r\n ------------------------------------------------------------------------------\r\n PUREPASCAL Code is machine-independent (as opposed to assembler code)\r\n Win32API Code is specific for the Win32 API;\r\n use instead of \"{$IFNDEF CLR} {$IFDEF MSWINDOWS}\" constructs\r\n\r\n\r\n- Delphi Versions\r\n\r\n The following directives are direct mappings from the VERXXX directives to a\r\n friendly name of the associated compiler. These directives are only defined if\r\n the compiler is Delphi (ie DELPHI is defined).\r\n\r\n Directive Description\r\n ------------------------------------------------------------------------------\r\n DELPHI1 Defined when compiling with Delphi 1 (Codename WASABI/MANGO)\r\n DELPHI2 Defined when compiling with Delphi 2 (Codename POLARIS)\r\n DELPHI3 Defined when compiling with Delphi 3 (Codename IVORY)\r\n DELPHI4 Defined when compiling with Delphi 4 (Codename ALLEGRO)\r\n DELPHI5 Defined when compiling with Delphi 5 (Codename ARGUS)\r\n DELPHI6 Defined when compiling with Delphi 6 (Codename ILLIAD)\r\n DELPHI7 Defined when compiling with Delphi 7 (Codename AURORA)\r\n DELPHI8 Defined when compiling with Delphi 8 (Codename OCTANE)\r\n DELPHI2005 Defined when compiling with Delphi 2005 (Codename DIAMONDBACK)\r\n DELPHI9 Alias for DELPHI2005\r\n DELPHI10 Defined when compiling with Delphi 2006 (Codename DEXTER)\r\n DELPHI2006 Alias for DELPHI10\r\n DELPHI11 Defined when compiling with Delphi 2007 for Win32 (Codename SPACELY)\r\n DELPHI2007 Alias for DELPHI11\r\n DELPHI12 Defined when compiling with Delphi 2009 for Win32 (Codename TIBURON)\r\n DELPHI2009 Alias for DELPHI12\r\n DELPHI14 Defined when compiling with Delphi 2010 for Win32 (Codename WEAVER)\r\n DELPHI2010 Alias for DELPHI14\r\n DELPHI15 Defined when compiling with Delphi XE for Win32 (Codename FULCRUM)\r\n DELPHIXE Alias for DELPHI15\r\n DELPHI16 Defined when compiling with Delphi XE2 for Win32 (Codename PULSAR)\r\n DELPHIXE2 Alias for DELPHI16\r\n DELPHI17 Defined when compiling with Delphi XE3 for Win32 (Codename WATERDRAGON)\r\n DELPHIXE3 Alias for DELPHI17\r\n DELPHI1_UP Defined when compiling with Delphi 1 or higher\r\n DELPHI2_UP Defined when compiling with Delphi 2 or higher\r\n DELPHI3_UP Defined when compiling with Delphi 3 or higher\r\n DELPHI4_UP Defined when compiling with Delphi 4 or higher\r\n DELPHI5_UP Defined when compiling with Delphi 5 or higher\r\n DELPHI6_UP Defined when compiling with Delphi 6 or higher\r\n DELPHI7_UP Defined when compiling with Delphi 7 or higher\r\n DELPHI8_UP Defined when compiling with Delphi 8 or higher\r\n DELPHI2005_UP Defined when compiling with Delphi 2005 or higher\r\n DELPHI9_UP Alias for DELPHI2005_UP\r\n DELPHI10_UP Defined when compiling with Delphi 2006 or higher\r\n DELPHI2006_UP Alias for DELPHI10_UP\r\n DELPHI11_UP Defined when compiling with Delphi 2007 for Win32 or higher\r\n DELPHI2007_UP Alias for DELPHI11_UP\r\n DELPHI12_UP Defined when compiling with Delphi 2009 for Win32 or higher\r\n DELPHI2009_UP Alias for DELPHI12_UP\r\n DELPHI14_UP Defined when compiling with Delphi 2010 for Win32 or higher\r\n DELPHI2010_UP Alias for DELPHI14_UP\r\n DELPHI15_UP Defined when compiling with Delphi XE for Win32 or higher\r\n DELPHIXE_UP Alias for DELPHI15_UP\r\n DELPHI16_UP Defined when compiling with Delphi XE2 for Win32 or higher\r\n DELPHIXE2_UP Alias for DELPHI16_UP\r\n DELPHI17_UP Defined when compiling with Delphi XE3 for Win32 or higher\r\n DELPHIXE3_UP Alias for DELPHI17_UP\r\n\r\n\r\n- Kylix Versions\r\n\r\n The following directives are direct mappings from the VERXXX directives to a\r\n friendly name of the associated compiler. These directives are only defined if\r\n the compiler is Kylix (ie KYLIX is defined).\r\n\r\n Directive Description\r\n ------------------------------------------------------------------------------\r\n KYLIX1 Defined when compiling with Kylix 1\r\n KYLIX2 Defined when compiling with Kylix 2\r\n KYLIX3 Defined when compiling with Kylix 3 (Codename CORTEZ)\r\n KYLIX1_UP Defined when compiling with Kylix 1 or higher\r\n KYLIX2_UP Defined when compiling with Kylix 2 or higher\r\n KYLIX3_UP Defined when compiling with Kylix 3 or higher\r\n\r\n\r\n- Delphi Compiler Versions (Delphi / Kylix, not in BCB mode)\r\n\r\n Directive Description\r\n ------------------------------------------------------------------------------\r\n DELPHICOMPILER1 Defined when compiling with Delphi 1\r\n DELPHICOMPILER2 Defined when compiling with Delphi 2\r\n DELPHICOMPILER3 Defined when compiling with Delphi 3\r\n DELPHICOMPILER4 Defined when compiling with Delphi 4\r\n DELPHICOMPILER5 Defined when compiling with Delphi 5\r\n DELPHICOMPILER6 Defined when compiling with Delphi 6 or Kylix 1, 2 or 3\r\n DELPHICOMPILER7 Defined when compiling with Delphi 7\r\n DELPHICOMPILER8 Defined when compiling with Delphi 8\r\n DELPHICOMPILER9 Defined when compiling with Delphi 2005\r\n DELPHICOMPILER10 Defined when compiling with Delphi Personality of BDS 4.0\r\n DELPHICOMPILER11 Defined when compiling with Delphi 2007 for Win32\r\n DELPHICOMPILER12 Defined when compiling with Delphi Personality of BDS 6.0\r\n DELPHICOMPILER14 Defined when compiling with Delphi Personality of BDS 7.0\r\n DELPHICOMPILER15 Defined when compiling with Delphi Personality of BDS 8.0\r\n DELPHICOMPILER16 Defined when compiling with Delphi Personality of BDS 9.0\r\n DELPHICOMPILER17 Defined when compiling with Delphi Personality of BDS 10.0\r\n DELPHICOMPILER1_UP Defined when compiling with Delphi 1 or higher\r\n DELPHICOMPILER2_UP Defined when compiling with Delphi 2 or higher\r\n DELPHICOMPILER3_UP Defined when compiling with Delphi 3 or higher\r\n DELPHICOMPILER4_UP Defined when compiling with Delphi 4 or higher\r\n DELPHICOMPILER5_UP Defined when compiling with Delphi 5 or higher\r\n DELPHICOMPILER6_UP Defined when compiling with Delphi 6 or Kylix 1, 2 or 3 or higher\r\n DELPHICOMPILER7_UP Defined when compiling with Delphi 7 or higher\r\n DELPHICOMPILER8_UP Defined when compiling with Delphi 8 or higher\r\n DELPHICOMPILER9_UP Defined when compiling with Delphi 2005\r\n DELPHICOMPILER10_UP Defined when compiling with Delphi 2006 or higher\r\n DELPHICOMPILER11_UP Defined when compiling with Delphi 2007 for Win32 or higher\r\n DELPHICOMPILER12_UP Defined when compiling with Delphi 2009 for Win32 or higher\r\n DELPHICOMPILER14_UP Defined when compiling with Delphi 2010 for Win32 or higher\r\n DELPHICOMPILER15_UP Defined when compiling with Delphi XE for Win32 or higher\r\n DELPHICOMPILER16_UP Defined when compiling with Delphi XE2 for Win32 or higher\r\n DELPHICOMPILER17_UP Defined when compiling with Delphi XE3 for Win32 or higher\r\n\r\n\r\n- C++Builder Versions\r\n\r\n The following directives are direct mappings from the VERXXX directives to a\r\n friendly name of the associated compiler. These directives are only defined if\r\n the compiler is C++Builder (ie BCB is defined).\r\n\r\n Directive Description\r\n ------------------------------------------------------------------------------\r\n BCB1 Defined when compiling with C++Builder 1\r\n BCB3 Defined when compiling with C++Builder 3\r\n BCB4 Defined when compiling with C++Builder 4\r\n BCB5 Defined when compiling with C++Builder 5 (Codename RAMPAGE)\r\n BCB6 Defined when compiling with C++Builder 6 (Codename RIPTIDE)\r\n BCB10 Defined when compiling with C++Builder Personality of BDS 4.0 (also known as C++Builder 2006) (Codename DEXTER)\r\n BCB11 Defined when compiling with C++Builder Personality of RAD Studio 2007 (also known as C++Builder 2007) (Codename COGSWELL)\r\n BCB12 Defined when compiling with C++Builder Personality of RAD Studio 2009 (also known as C++Builder 2009) (Codename TIBURON)\r\n BCB14 Defined when compiling with C++Builder Personality of RAD Studio 2010 (also known as C++Builder 2010) (Codename WEAVER)\r\n BCB15 Defined when compiling with C++Builder Personality of RAD Studio XE (also known as C++Builder XE) (Codename FULCRUM)\r\n BCB16 Defined when compiling with C++Builder Personality of RAD Studio XE2 (also known as C++Builder XE2) (Codename PULSAR)\r\n BCB17 Defined when compiling with C++Builder Personality of RAD Studio XE3 (also known as C++Builder XE3) (Codename WATERDRAGON)\r\n BCB1_UP Defined when compiling with C++Builder 1 or higher\r\n BCB3_UP Defined when compiling with C++Builder 3 or higher\r\n BCB4_UP Defined when compiling with C++Builder 4 or higher\r\n BCB5_UP Defined when compiling with C++Builder 5 or higher\r\n BCB6_UP Defined when compiling with C++Builder 6 or higher\r\n BCB10_UP Defined when compiling with C++Builder Personality of BDS 4.0 or higher\r\n BCB11_UP Defined when compiling with C++Builder Personality of RAD Studio 2007 or higher\r\n BCB12_UP Defined when compiling with C++Builder Personality of RAD Studio 2009 or higher\r\n BCB14_UP Defined when compiling with C++Builder Personality of RAD Studio 2010 or higher\r\n BCB15_UP Defined when compiling with C++Builder Personality of RAD Studio XE or higher\r\n BCB16_UP Defined when compiling with C++Builder Personality of RAD Studio XE2 or higher\r\n BCB17_UP Defined when compiling with C++Builder Personality of RAD Studio XE3 or higher\r\n\r\n\r\n- RAD Studio / Borland Developer Studio Versions\r\n\r\n The following directives are direct mappings from the VERXXX directives to a\r\n friendly name of the associated IDE. These directives are only defined if\r\n the IDE is Borland Developer Studio Version 2 or above.\r\n\r\n Note: Borland Developer Studio 2006 is marketed as Delphi 2006 or C++Builder 2006,\r\n but those provide only different labels for identical content.\r\n\r\n Directive Description\r\n ------------------------------------------------------------------------------\r\n BDS Defined when compiling with BDS version of dcc32.exe (Codename SIDEWINDER)\r\n BDS2 Defined when compiling with BDS 2.0 (Delphi 8) (Codename OCTANE)\r\n BDS3 Defined when compiling with BDS 3.0 (Delphi 2005) (Codename DIAMONDBACK)\r\n BDS4 Defined when compiling with BDS 4.0 (Borland Developer Studio 2006) (Codename DEXTER)\r\n BDS5 Defined when compiling with BDS 5.0 (CodeGear RAD Studio 2007) (Codename HIGHLANDER)\r\n BDS6 Defined when compiling with BDS 6.0 (CodeGear RAD Studio 2009) (Codename TIBURON)\r\n BDS7 Defined when compiling with BDS 7.0 (Embarcadero RAD Studio 2010) (Codename WEAVER)\r\n BDS8 Defined when compiling with BDS 8.0 (Embarcadero RAD Studio XE) (Codename FULCRUM)\r\n BDS9 Defined when compiling with BDS 9.0 (Embarcadero RAD Studio XE2) (Codename PULSAR)\r\n BDS10 Defined when compiling with BDS 10.0 (Embarcadero RAD Studio XE3) (Codename WATERDRAGON)\r\n BDS2_UP Defined when compiling with BDS 2.0 or higher\r\n BDS3_UP Defined when compiling with BDS 3.0 or higher\r\n BDS4_UP Defined when compiling with BDS 4.0 or higher\r\n BDS5_UP Defined when compiling with BDS 5.0 or higher\r\n BDS6_UP Defined when compiling with BDS 6.0 or higher\r\n BDS7_UP Defined when compiling with BDS 7.0 or higher\r\n BDS8_UP Defined when compiling with BDS 8.0 or higher\r\n BDS9_UP Defined when compiling with BDS 9.0 or higher\r\n BDS10_UP Defined when compiling with BDS 10.0 or higher\r\n\r\n- Compiler Versions\r\n\r\n The following directives are direct mappings from the VERXXX directives to a\r\n friendly name of the associated compiler. Unlike the DELPHI_X and BCB_X\r\n directives, these directives are indepedent of the development environment.\r\n That is, they are defined regardless of whether compilation takes place using\r\n Delphi or C++Builder.\r\n\r\n Directive Description\r\n ------------------------------------------------------------------------------\r\n COMPILER1 Defined when compiling with Delphi 1\r\n COMPILER2 Defined when compiling with Delphi 2 or C++Builder 1\r\n COMPILER3 Defined when compiling with Delphi 3\r\n COMPILER35 Defined when compiling with C++Builder 3\r\n COMPILER4 Defined when compiling with Delphi 4 or C++Builder 4\r\n COMPILER5 Defined when compiling with Delphi 5 or C++Builder 5\r\n COMPILER6 Defined when compiling with Delphi 6 or C++Builder 6\r\n COMPILER7 Defined when compiling with Delphi 7\r\n COMPILER8 Defined when compiling with Delphi 8\r\n COMPILER9 Defined when compiling with Delphi 9\r\n COMPILER10 Defined when compiling with Delphi or C++Builder Personalities of BDS 4.0\r\n COMPILER11 Defined when compiling with Delphi or C++Builder Personalities of BDS 5.0\r\n COMPILER12 Defined when compiling with Delphi or C++Builder Personalities of BDS 6.0\r\n COMPILER14 Defined when compiling with Delphi or C++Builder Personalities of BDS 7.0\r\n COMPILER15 Defined when compiling with Delphi or C++Builder Personalities of BDS 8.0\r\n COMPILER16 Defined when compiling with Delphi or C++Builder Personalities of BDS 9.0\r\n COMPILER17 Defined when compiling with Delphi or C++Builder Personalities of BDS 10.0\r\n COMPILER1_UP Defined when compiling with Delphi 1 or higher\r\n COMPILER2_UP Defined when compiling with Delphi 2 or C++Builder 1 or higher\r\n COMPILER3_UP Defined when compiling with Delphi 3 or higher\r\n COMPILER35_UP Defined when compiling with C++Builder 3 or higher\r\n COMPILER4_UP Defined when compiling with Delphi 4 or C++Builder 4 or higher\r\n COMPILER5_UP Defined when compiling with Delphi 5 or C++Builder 5 or higher\r\n COMPILER6_UP Defined when compiling with Delphi 6 or C++Builder 6 or higher\r\n COMPILER7_UP Defined when compiling with Delphi 7\r\n COMPILER8_UP Defined when compiling with Delphi 8\r\n COMPILER9_UP Defined when compiling with Delphi Personalities of BDS 3.0\r\n COMPILER10_UP Defined when compiling with Delphi or C++Builder Personalities of BDS 4.0 or higher\r\n COMPILER11_UP Defined when compiling with Delphi or C++Builder Personalities of BDS 5.0 or higher\r\n COMPILER12_UP Defined when compiling with Delphi or C++Builder Personalities of BDS 6.0 or higher\r\n COMPILER14_UP Defined when compiling with Delphi or C++Builder Personalities of BDS 7.0 or higher\r\n COMPILER15_UP Defined when compiling with Delphi or C++Builder Personalities of BDS 8.0 or higher\r\n COMPILER16_UP Defined when compiling with Delphi or C++Builder Personalities of BDS 9.0 or higher\r\n COMPILER17_UP Defined when compiling with Delphi or C++Builder Personalities of BDS 10.0 or higher\r\n\r\n\r\n- RTL Versions\r\n\r\n Use e.g. following to determine the exact RTL version since version 14.0:\r\n {$IFDEF CONDITIONALEXPRESSIONS}\r\n {$IF Declared(RTLVersion) and (RTLVersion >= 14.2)}\r\n // code for Delphi 6.02 or higher, Kylix 2 or higher, C++Builder 6 or higher\r\n ...\r\n {$IFEND}\r\n {$ENDIF}\r\n\r\n Directive Description\r\n ------------------------------------------------------------------------------\r\n RTL80_UP Defined when compiling with Delphi 1 or higher\r\n RTL90_UP Defined when compiling with Delphi 2 or higher\r\n RTL93_UP Defined when compiling with C++Builder 1 or higher\r\n RTL100_UP Defined when compiling with Delphi 3 or higher\r\n RTL110_UP Defined when compiling with C++Builder 3 or higher\r\n RTL120_UP Defined when compiling with Delphi 4 or higher\r\n RTL125_UP Defined when compiling with C++Builder 4 or higher\r\n RTL130_UP Defined when compiling with Delphi 5 or C++Builder 5 or higher\r\n RTL140_UP Defined when compiling with Delphi 6, Kylix 1, 2 or 3 or C++Builder 6 or higher\r\n RTL150_UP Defined when compiling with Delphi 7 or higher\r\n RTL160_UP Defined when compiling with Delphi 8 or higher\r\n RTL170_UP Defined when compiling with Delphi Personalities of BDS 3.0 or higher\r\n RTL180_UP Defined when compiling with Delphi or C++Builder Personalities of BDS 4.0 or higher\r\n RTL185_UP Defined when compiling with Delphi or C++Builder Personalities of BDS 5.0 or higher\r\n RTL190_UP Defined when compiling with Delphi.NET of BDS 5.0 or higher\r\n RTL200_UP Defined when compiling with Delphi or C++Builder Personalities of BDS 6.0 or higher\r\n RTL210_UP Defined when compiling with Delphi or C++Builder Personalities of BDS 7.0 or higher\r\n RTL220_UP Defined when compiling with Delphi or C++Builder Personalities of BDS 8.0 or higher\r\n RTL230_UP Defined when compiling with Delphi or C++Builder Personalities of BDS 9.0 or higher\r\n RTL240_UP Defined when compiling with Delphi or C++Builder Personalities of BDS 10.0 or higher\r\n\r\n\r\n- CLR Versions\r\n\r\n Directive Description\r\n ------------------------------------------------------------------------------\r\n CLR Defined when compiling for .NET\r\n CLR10 Defined when compiling for .NET 1.0 (may be overriden by FORCE_CLR10)\r\n CLR10_UP Defined when compiling for .NET 1.0 or higher\r\n CLR11 Defined when compiling for .NET 1.1 (may be overriden by FORCE_CLR11)\r\n CLR11_UP Defined when compiling for .NET 1.1 or higher\r\n CLR20 Defined when compiling for .NET 2.0 (may be overriden by FORCE_CLR20)\r\n CLR20_UP Defined when compiling for .NET 2.0 or higher\r\n\r\n\r\n- Feature Directives\r\n\r\n The features directives are used to test if the compiler supports specific\r\n features, such as method overloading, and adjust the sources accordingly. Use\r\n of these directives is preferred over the use of the DELPHI and COMPILER\r\n directives.\r\n\r\n Directive Description\r\n ------------------------------------------------------------------------------\r\n SUPPORTS_CONSTPARAMS Compiler supports const parameters (D1+)\r\n SUPPORTS_SINGLE Compiler supports the Single type (D1+)\r\n SUPPORTS_DOUBLE Compiler supports the Double type (D1+)\r\n SUPPORTS_EXTENDED Compiler supports the Extended type (D1+)\r\n SUPPORTS_CURRENCY Compiler supports the Currency type (D2+)\r\n SUPPORTS_THREADVAR Compiler supports threadvar declarations (D2+)\r\n SUPPORTS_OUTPARAMS Compiler supports out parameters (D3+)\r\n SUPPORTS_VARIANT Compiler supports variant (D2+)\r\n SUPPORTS_WIDECHAR Compiler supports the WideChar type (D2+)\r\n SUPPORTS_WIDESTRING Compiler supports the WideString type (D3+/BCB3+)\r\n SUPPORTS_INTERFACE Compiler supports interfaces (D3+/BCB3+)\r\n SUPPORTS_DISPINTERFACE Compiler supports dispatch interfaces (D3+/BCB3+)\r\n SUPPORTS_DISPID Compiler supports dispatch ids (D3+/BCB3+/FPC)\r\n SUPPORTS_EXTSYM Compiler supports the $EXTERNALSYM directive (D4+/BCB3+)\r\n SUPPORTS_NODEFINE Compiler supports the $NODEFINE directive (D4+/BCB3+)\r\n SUPPORTS_LONGWORD Compiler supports the LongWord type (unsigned 32 bit) (D4+/BCB4+)\r\n SUPPORTS_INT64 Compiler supports the Int64 type (D4+/BCB4+)\r\n SUPPORTS_UINT64 Compiler supports the UInt64 type (D XE+ ?)\r\n SUPPORTS_DYNAMICARRAYS Compiler supports dynamic arrays (D4+/BCB4+)\r\n SUPPORTS_DEFAULTPARAMS Compiler supports default parameters (D4+/BCB4+)\r\n SUPPORTS_OVERLOAD Compiler supports overloading (D4+/BCB4+)\r\n SUPPORTS_IMPLEMENTS Compiler supports implements (D4+/BCB4+)\r\n SUPPORTS_DEPRECATED Compiler supports the deprecated directive (D6+/BCB6+)\r\n SUPPORTS_PLATFORM Compiler supports the platform directive (D6+/BCB6+)\r\n SUPPORTS_LIBRARY Compiler supports the library directive (D6+/BCB6+/FPC)\r\n SUPPORTS_LOCAL Compiler supports the local directive (D6+/BCB6+)\r\n SUPPORTS_SETPEFLAGS Compiler supports the SetPEFlags directive (D6+/BCB6+)\r\n SUPPORTS_EXPERIMENTAL_WARNINGS Compiler supports the WARN SYMBOL_EXPERIMENTAL and WARN UNIT_EXPERIMENTAL directives (D6+/BCB6+)\r\n SUPPORTS_INLINE Compiler supports the inline directive (D9+/FPC)\r\n SUPPORTS_FOR_IN Compiler supports for in loops (D9+)\r\n SUPPORTS_NESTED_CONSTANTS Compiler supports nested constants (D9+)\r\n SUPPORTS_NESTED_TYPES Compiler supports nested types (D9+)\r\n SUPPORTS_REGION Compiler supports the REGION and ENDREGION directives (D9+)\r\n SUPPORTS_ENHANCED_RECORDS Compiler supports class [operator|function|procedure] for record types (D9.NET, D10+)\r\n SUPPORTS_CLASS_FIELDS Compiler supports class fields (D9.NET, D10+)\r\n SUPPORTS_CLASS_HELPERS Compiler supports class helpers (D9.NET, D10+)\r\n SUPPORTS_CLASS_OPERATORS Compiler supports class operators (D9.NET, D10+)\r\n SUPPORTS_CLASS_CTORDTORS Compiler supports class contructors/destructors (D14+)\r\n SUPPORTS_STRICT Compiler supports strict keyword (D9.NET, D10+)\r\n SUPPORTS_STATIC Compiler supports static keyword (D9.NET, D10+)\r\n SUPPORTS_FINAL Compiler supports final keyword (D9.NET, D10+)\r\n SUPPORTS_METHODINFO Compiler supports the METHODINFO directives (D10+)\r\n SUPPORTS_GENERICS Compiler supports generic implementations (D11.NET, D12+)\r\n SUPPORTS_DEPRECATED_DETAILS Compiler supports additional text for the deprecated directive (D11.NET, D12+)\r\n ACCEPT_DEPRECATED Compiler supports or ignores the deprecated directive (D6+/BCB6+/FPC)\r\n ACCEPT_PLATFORM Compiler supports or ignores the platform directive (D6+/BCB6+/FPC)\r\n ACCEPT_LIBRARY Compiler supports or ignores the library directive (D6+/BCB6+)\r\n SUPPORTS_CUSTOMVARIANTS Compiler supports custom variants (D6+/BCB6+)\r\n SUPPORTS_VARARGS Compiler supports varargs (D6+/BCB6+)\r\n SUPPORTS_ENUMVALUE Compiler supports assigning ordinalities to values of enums (D6+/BCB6+)\r\n SUPPORTS_DEPRECATED_WARNINGS Compiler supports deprecated warnings (D6+/BCB6+)\r\n SUPPORTS_LIBRARY_WARNINGS Compiler supports library warnings (D6+/BCB6+)\r\n SUPPORTS_PLATFORM_WARNINGS Compiler supports platform warnings (D6+/BCB6+)\r\n SUPPORTS_UNSAFE_WARNINGS Compiler supports unsafe warnings (D7)\r\n SUPPORTS_WEAKPACKAGEUNIT Compiler supports the WEAKPACKAGEUNIT directive\r\n SUPPORTS_COMPILETIME_MESSAGES Compiler supports the MESSAGE directive\r\n SUPPORTS_PACKAGES Compiler supports Packages\r\n HAS_UNIT_LIBC Unit Libc exists (Kylix, FPC on Linux/x86)\r\n HAS_UNIT_RTLCONSTS Unit RTLConsts exists (D6+/BCB6+/FPC)\r\n HAS_UNIT_TYPES Unit Types exists (D6+/BCB6+/FPC)\r\n HAS_UNIT_VARIANTS Unit Variants exists (D6+/BCB6+/FPC)\r\n HAS_UNIT_STRUTILS Unit StrUtils exists (D6+/BCB6+/FPC)\r\n HAS_UNIT_DATEUTILS Unit DateUtils exists (D6+/BCB6+/FPC)\r\n HAS_UNIT_CONTNRS Unit contnrs exists (D6+/BCB6+/FPC)\r\n HAS_UNIT_HTTPPROD Unit HTTPProd exists (D9+)\r\n HAS_UNIT_GIFIMG Unit GifImg exists (D11+)\r\n HAS_UNIT_ANSISTRINGS Unit AnsiStrings exists (D12+)\r\n HAS_UNIT_PNGIMAGE Unit PngImage exists (D12+)\r\n HAS_UNIT_CHARACTER Unit Character exists (D12+)\r\n XPLATFORM_RTL The RTL supports crossplatform function names (e.g. RaiseLastOSError) (D6+/BCB6+/FPC)\r\n SUPPORTS_UNICODE string type is aliased to an unicode string (WideString or UnicodeString) (DX.NET, D12+)\r\n SUPPORTS_UNICODE_STRING Compiler supports UnicodeString (D12+)\r\n SUPPORTS_INT_ALIASES Types Int8, Int16, Int32, UInt8, UInt16 and UInt32 are defined in the unit System (D12+)\r\n HAS_UNIT_RTTI Unit RTTI is available (D14+)\r\n SUPPORTS_CAST_INTERFACE_TO_OBJ The compiler supports casts from interfaces to objects (D14+)\r\n SUPPORTS_DELAYED_LOADING The compiler generates stubs for delaying imported function loads (D14+)\r\n HAS_UNIT_REGULAREXPRESSIONSAPI Unit RegularExpressionsAPI is available (D15+)\r\n HAS_UNIT_SYSTEM_UITYPES Unit System.UITypes is available (D16+)\r\n HAS_UNIT_SYSTEM_ACTIONS Unit System.Actions is available (D17+)\r\n\r\n\r\n- Compiler Settings\r\n\r\n The compiler settings directives indicate whether a specific compiler setting\r\n is in effect. This facilitates changing compiler settings locally in a more\r\n compact and readible manner.\r\n\r\n Directive Description\r\n ------------------------------------------------------------------------------\r\n ALIGN_ON Compiling in the A+ state (no alignment)\r\n BOOLEVAL_ON Compiling in the B+ state (complete boolean evaluation)\r\n ASSERTIONS_ON Compiling in the C+ state (assertions on)\r\n DEBUGINFO_ON Compiling in the D+ state (debug info generation on)\r\n IMPORTEDDATA_ON Compiling in the G+ state (creation of imported data references)\r\n LONGSTRINGS_ON Compiling in the H+ state (string defined as AnsiString)\r\n IOCHECKS_ON Compiling in the I+ state (I/O checking enabled)\r\n WRITEABLECONST_ON Compiling in the J+ state (typed constants can be modified)\r\n LOCALSYMBOLS Compiling in the L+ state (local symbol generation)\r\n LOCALSYMBOLS_ON Alias of LOCALSYMBOLS\r\n TYPEINFO_ON Compiling in the M+ state (RTTI generation on)\r\n OPTIMIZATION_ON Compiling in the O+ state (code optimization on)\r\n OPENSTRINGS_ON Compiling in the P+ state (variable string parameters are openstrings)\r\n OVERFLOWCHECKS_ON Compiling in the Q+ state (overflow checing on)\r\n RANGECHECKS_ON Compiling in the R+ state (range checking on)\r\n TYPEDADDRESS_ON Compiling in the T+ state (pointers obtained using the @ operator are typed)\r\n SAFEDIVIDE_ON Compiling in the U+ state (save FDIV instruction through RTL emulation)\r\n VARSTRINGCHECKS_ON Compiling in the V+ state (type checking of shortstrings)\r\n STACKFRAMES_ON Compiling in the W+ state (generation of stack frames)\r\n EXTENDEDSYNTAX_ON Compiling in the X+ state (Delphi extended syntax enabled)\r\n*)\r\n\r\n{$DEFINE BORLAND}\r\n\r\n{ Set FreePascal to Delphi mode }\r\n{$IFDEF FPC}\r\n {$MODE DELPHI}\r\n {$ASMMODE Intel}\r\n {$UNDEF BORLAND}\r\n {$DEFINE CPUASM}\r\n // FPC defines CPU32, CPU64 and Unix automatically\r\n{$ENDIF}\r\n\r\n{$IFDEF BORLAND}\r\n {$IFDEF LINUX}\r\n {$DEFINE KYLIX}\r\n {$ENDIF LINUX}\r\n {$IFNDEF CLR}\r\n {$IFNDEF CPUX86}\r\n {$IFNDEF CPUX64}\r\n {$DEFINE CPU386} // For Borland compilers select the x86 compat assembler by default\r\n {$DEFINE CPU32} // Assume Borland compilers are 32-bit (rather than 64-bit)\r\n {$DEFINE CPUASM}\r\n {$ELSE ~CPUX64}\r\n {$DEFINE CPU64}\r\n {$DEFINE CPUASM}\r\n {$DEFINE DELPHI64_TEMPORARY}\r\n {$ENDIF ~CPUX64}\r\n {$ELSE ~CPUX86}\r\n {$DEFINE CPU386}\r\n {$DEFINE CPU32}\r\n {$DEFINE CPUASM}\r\n {$ENDIF ~CPUX86}\r\n {$ENDIF ~CLR}\r\n{$ENDIF BORLAND}\r\n\r\n{------------------------------------------------------------------------------}\r\n{ VERXXX to COMPILERX, DELPHIX and BCBX mappings }\r\n{------------------------------------------------------------------------------}\r\n\r\n{$IFDEF BORLAND}\r\n {$IFDEF KYLIX}\r\n {$I kylix.inc} // FPC incompatible stuff\r\n {$ELSE ~KYLIX}\r\n\r\n {$DEFINE UNKNOWN_COMPILER_VERSION}\r\n\r\n {$IFDEF VER80}\r\n {$DEFINE COMPILER1}\r\n {$DEFINE DELPHI1}\r\n {$DEFINE DELPHICOMPILER1}\r\n {$DEFINE RTL80_UP}\r\n {$UNDEF UNKNOWN_COMPILER_VERSION}\r\n {$ENDIF}\r\n\r\n {$IFDEF VER90}\r\n {$DEFINE COMPILER2}\r\n {$DEFINE DELPHI2}\r\n {$DEFINE DELPHICOMPILER2}\r\n {$DEFINE RTL90_UP}\r\n {$UNDEF UNKNOWN_COMPILER_VERSION}\r\n {$ENDIF}\r\n\r\n {$IFDEF VER93}\r\n {$DEFINE COMPILER2}\r\n {$DEFINE BCB1}\r\n {$DEFINE BCB}\r\n {$DEFINE RTL93_UP}\r\n {$UNDEF UNKNOWN_COMPILER_VERSION}\r\n {$ENDIF}\r\n\r\n {$IFDEF VER100}\r\n {$DEFINE COMPILER3}\r\n {$DEFINE DELPHI3}\r\n {$DEFINE DELPHICOMPILER3}\r\n {$DEFINE RTL100_UP}\r\n {$UNDEF UNKNOWN_COMPILER_VERSION}\r\n {$ENDIF}\r\n\r\n {$IFDEF VER110}\r\n {$DEFINE COMPILER35}\r\n {$DEFINE BCB3}\r\n {$DEFINE BCB}\r\n {$DEFINE RTL110_UP}\r\n {$UNDEF UNKNOWN_COMPILER_VERSION}\r\n {$ENDIF}\r\n\r\n {$IFDEF VER120}\r\n {$DEFINE COMPILER4}\r\n {$DEFINE DELPHI4}\r\n {$DEFINE DELPHICOMPILER4}\r\n {$DEFINE RTL120_UP}\r\n {$UNDEF UNKNOWN_COMPILER_VERSION}\r\n {$ENDIF}\r\n\r\n {$IFDEF VER125}\r\n {$DEFINE COMPILER4}\r\n {$DEFINE BCB4}\r\n {$DEFINE BCB}\r\n {$DEFINE RTL125_UP}\r\n {$UNDEF UNKNOWN_COMPILER_VERSION}\r\n {$ENDIF}\r\n\r\n {$IFDEF VER130}\r\n {$DEFINE COMPILER5}\r\n {$IFDEF BCB}\r\n {$DEFINE BCB5}\r\n {$ELSE}\r\n {$DEFINE DELPHI5}\r\n {$DEFINE DELPHICOMPILER5}\r\n {$ENDIF}\r\n {$DEFINE RTL130_UP}\r\n {$UNDEF UNKNOWN_COMPILER_VERSION}\r\n {$ENDIF}\r\n\r\n {$IFDEF VER140}\r\n {$DEFINE COMPILER6}\r\n {$IFDEF BCB}\r\n {$DEFINE BCB6}\r\n {$ELSE}\r\n {$DEFINE DELPHI6}\r\n {$DEFINE DELPHICOMPILER6}\r\n {$ENDIF}\r\n {$DEFINE RTL140_UP}\r\n {$UNDEF UNKNOWN_COMPILER_VERSION}\r\n {$ENDIF}\r\n\r\n {$IFDEF VER150}\r\n {$DEFINE COMPILER7}\r\n {$DEFINE DELPHI7}\r\n {$DEFINE DELPHICOMPILER7}\r\n {$DEFINE RTL150_UP}\r\n {$UNDEF UNKNOWN_COMPILER_VERSION}\r\n {$ENDIF}\r\n\r\n {$IFDEF VER160}\r\n {$DEFINE BDS2}\r\n {$DEFINE BDS}\r\n {$IFDEF CLR}\r\n {$DEFINE CLR10}\r\n {$ENDIF CLR}\r\n {$DEFINE COMPILER8}\r\n {$DEFINE DELPHI8}\r\n {$DEFINE DELPHICOMPILER8}\r\n {$DEFINE RTL160_UP}\r\n {$UNDEF UNKNOWN_COMPILER_VERSION}\r\n {$ENDIF}\r\n\r\n {$IFDEF VER170}\r\n {$DEFINE BDS3}\r\n {$DEFINE BDS}\r\n {$IFDEF CLR}\r\n {$DEFINE CLR11}\r\n {$ENDIF CLR}\r\n {$DEFINE COMPILER9}\r\n {$DEFINE DELPHI9}\r\n {$DEFINE DELPHI2005} // synonym to DELPHI9\r\n {$DEFINE DELPHICOMPILER9}\r\n {$DEFINE RTL170_UP}\r\n {$UNDEF UNKNOWN_COMPILER_VERSION}\r\n {$ENDIF}\r\n\r\n {$IFDEF VER180}\r\n {$DEFINE BDS}\r\n {$IFDEF CLR}\r\n {$DEFINE CLR11}\r\n {$ENDIF CLR}\r\n {$IFDEF VER185}\r\n {$DEFINE BDS5}\r\n {$DEFINE COMPILER11}\r\n {$IFDEF BCB}\r\n {$DEFINE BCB11}\r\n {$ELSE}\r\n {$DEFINE DELPHI11}\r\n {$DEFINE DELPHI2007} // synonym to DELPHI11\r\n {$DEFINE DELPHICOMPILER11}\r\n {$ENDIF}\r\n {$DEFINE RTL185_UP}\r\n {$ELSE ~~VER185}\r\n {$DEFINE BDS4}\r\n {$DEFINE COMPILER10}\r\n {$IFDEF BCB}\r\n {$DEFINE BCB10}\r\n {$ELSE}\r\n {$DEFINE DELPHI10}\r\n {$DEFINE DELPHI2006} // synonym to DELPHI10\r\n {$DEFINE DELPHICOMPILER10}\r\n {$ENDIF}\r\n {$DEFINE RTL180_UP}\r\n {$ENDIF ~VER185}\r\n {$UNDEF UNKNOWN_COMPILER_VERSION}\r\n {$ENDIF}\r\n\r\n {$IFDEF VER190} // Delphi 2007 for .NET\r\n {$DEFINE BDS}\r\n {$DEFINE BDS5}\r\n {$IFDEF CLR}\r\n {$DEFINE CLR20}\r\n {$ENDIF CLR}\r\n {$DEFINE COMPILER11}\r\n {$DEFINE DELPHI11}\r\n {$DEFINE DELPHI2007} // synonym to DELPHI11\r\n {$DEFINE DELPHICOMPILER11}\r\n {$DEFINE RTL190_UP}\r\n {$UNDEF UNKNOWN_COMPILER_VERSION}\r\n {$ENDIF VER190}\r\n\r\n {$IFDEF VER200} // RAD Studio 2009\r\n {$DEFINE BDS}\r\n {$DEFINE BDS6}\r\n {$IFDEF CLR}\r\n {$DEFINE CLR20}\r\n {$ENDIF CLR}\r\n {$DEFINE COMPILER12}\r\n {$IFDEF BCB}\r\n {$DEFINE BCB12}\r\n {$ELSE}\r\n {$DEFINE DELPHI12}\r\n {$DEFINE DELPHI2009} // synonym to DELPHI12\r\n {$DEFINE DELPHICOMPILER12}\r\n {$ENDIF BCB}\r\n {$IFDEF CLR}\r\n {$DEFINE RTL190_UP}\r\n {$ELSE}\r\n {$DEFINE RTL200_UP}\r\n {$ENDIF}\r\n {$UNDEF UNKNOWN_COMPILER_VERSION}\r\n {$ENDIF VER200}\r\n\r\n {$IFDEF VER210} // RAD Studio 2010\r\n {$DEFINE BDS}\r\n {$DEFINE BDS7}\r\n {$DEFINE COMPILER14}\r\n {$IFDEF BCB}\r\n {$DEFINE BCB14}\r\n {$ELSE}\r\n {$DEFINE DELPHI14}\r\n {$DEFINE DELPHI2010} // synonym to DELPHI14\r\n {$DEFINE DELPHICOMPILER14}\r\n {$ENDIF BCB}\r\n {$DEFINE RTL210_UP}\r\n {$UNDEF UNKNOWN_COMPILER_VERSION}\r\n {$ENDIF VER210}\r\n\r\n {$IFDEF VER220} // RAD Studio XE\r\n {$DEFINE BDS}\r\n {$DEFINE BDS8}\r\n {$DEFINE COMPILER15}\r\n {$IFDEF BCB}\r\n {$DEFINE BCB15}\r\n {$ELSE}\r\n {$DEFINE DELPHI15}\r\n {$DEFINE DELPHIXE} // synonym to DELPHI15\r\n {$DEFINE DELPHICOMPILER15}\r\n {$ENDIF BCB}\r\n {$DEFINE RTL220_UP}\r\n {$UNDEF UNKNOWN_COMPILER_VERSION}\r\n {$ENDIF VER220}\r\n\r\n {$IFDEF VER230} // RAD Studio XE2\r\n {$DEFINE BDS}\r\n {$DEFINE BDS9}\r\n {$DEFINE COMPILER16}\r\n {$IFDEF BCB}\r\n {$DEFINE BCB16}\r\n {$ELSE}\r\n {$DEFINE DELPHI16}\r\n {$DEFINE DELPHIXE2} // synonym to DELPHI16\r\n {$DEFINE DELPHICOMPILER16}\r\n {$ENDIF BCB}\r\n {$DEFINE RTL230_UP}\r\n {$UNDEF UNKNOWN_COMPILER_VERSION}\r\n {$ENDIF VER230}\r\n\r\n {$IFDEF VER240} // RAD Studio XE3\r\n {$DEFINE BDS}\r\n {$DEFINE BDS10}\r\n {$DEFINE COMPILER17}\r\n {$IFDEF BCB}\r\n {$DEFINE BCB17}\r\n {$ELSE}\r\n {$DEFINE DELPHI17}\r\n {$DEFINE DELPHIXE3} // synonym to DELPHI17\r\n {$DEFINE DELPHICOMPILER17}\r\n {$ENDIF BCB}\r\n {$DEFINE RTL240_UP}\r\n {$UNDEF UNKNOWN_COMPILER_VERSION}\r\n {$ENDIF VER240}\r\n\r\n {$IFDEF UNKNOWN_COMPILER_VERSION} // adjust for newer version (always use latest version)\r\n {$DEFINE BDS}\r\n {$DEFINE BDS10}\r\n {$DEFINE COMPILER17}\r\n {$IFDEF BCB}\r\n {$DEFINE BCB17}\r\n {$ELSE}\r\n {$DEFINE DELPHI17}\r\n {$DEFINE DELPHIXE3} // synonym to DELPHI17\r\n {$DEFINE DELPHICOMPILER17}\r\n {$ENDIF BCB}\r\n {$DEFINE RTL240_UP}\r\n {$UNDEF UNKNOWN_COMPILER_VERSION}\r\n {$ENDIF}\r\n\r\n {$ENDIF ~KYLIX}\r\n\r\n {$IFDEF BCB}\r\n {$DEFINE CPPBUILDER}\r\n {$DEFINE BCBCOMPILER}\r\n {$ELSE ~BCB}\r\n {$DEFINE DELPHI}\r\n {$DEFINE DELPHICOMPILER}\r\n {$ENDIF ~BCB}\r\n\r\n{$ENDIF BORLAND}\r\n\r\n{------------------------------------------------------------------------------}\r\n{ DELPHIX_UP from DELPHIX mappings }\r\n{------------------------------------------------------------------------------}\r\n\r\n{$IFDEF DELPHI17} {$DEFINE DELPHI17_UP} {$ENDIF}\r\n{$IFDEF DELPHI16} {$DEFINE DELPHI16_UP} {$ENDIF}\r\n{$IFDEF DELPHI15} {$DEFINE DELPHI15_UP} {$ENDIF}\r\n{$IFDEF DELPHI14} {$DEFINE DELPHI14_UP} {$ENDIF}\r\n{$IFDEF DELPHI12} {$DEFINE DELPHI12_UP} {$ENDIF}\r\n{$IFDEF DELPHI11} {$DEFINE DELPHI11_UP} {$ENDIF}\r\n{$IFDEF DELPHI10} {$DEFINE DELPHI10_UP} {$ENDIF}\r\n{$IFDEF DELPHI9} {$DEFINE DELPHI9_UP} {$ENDIF}\r\n{$IFDEF DELPHI8} {$DEFINE DELPHI8_UP} {$ENDIF}\r\n{$IFDEF DELPHI7} {$DEFINE DELPHI7_UP} {$ENDIF}\r\n{$IFDEF DELPHI6} {$DEFINE DELPHI6_UP} {$ENDIF}\r\n{$IFDEF DELPHI5} {$DEFINE DELPHI5_UP} {$ENDIF}\r\n{$IFDEF DELPHI4} {$DEFINE DELPHI4_UP} {$ENDIF}\r\n{$IFDEF DELPHI3} {$DEFINE DELPHI3_UP} {$ENDIF}\r\n{$IFDEF DELPHI2} {$DEFINE DELPHI2_UP} {$ENDIF}\r\n{$IFDEF DELPHI1} {$DEFINE DELPHI1_UP} {$ENDIF}\r\n\r\n{------------------------------------------------------------------------------}\r\n{ DELPHIX_UP from DELPHIX_UP mappings }\r\n{------------------------------------------------------------------------------}\r\n\r\n{$IFDEF DELPHI17_UP}\r\n {$DEFINE DELPHIXE3_UP} // synonym to DELPHI17_UP\r\n {$DEFINE DELPHI16_UP}\r\n{$ENDIF}\r\n\r\n{$IFDEF DELPHI16_UP}\r\n {$DEFINE DELPHIXE2_UP} // synonym to DELPHI16_UP\r\n {$DEFINE DELPHI15_UP}\r\n{$ENDIF}\r\n\r\n{$IFDEF DELPHI15_UP}\r\n {$DEFINE DELPHIXE_UP} // synonym to DELPHI15_UP\r\n {$DEFINE DELPHI14_UP}\r\n{$ENDIF}\r\n\r\n{$IFDEF DELPHI14_UP}\r\n {$DEFINE DELPHI2010_UP} // synonym to DELPHI14_UP\r\n {$DEFINE DELPHI12_UP}\r\n{$ENDIF}\r\n\r\n{$IFDEF DELPHI12_UP}\r\n {$DEFINE DELPHI2009_UP} // synonym to DELPHI12_UP\r\n {$DEFINE DELPHI11_UP}\r\n{$ENDIF}\r\n\r\n{$IFDEF DELPHI11_UP}\r\n {$DEFINE DELPHI2007_UP} // synonym to DELPHI11_UP\r\n {$DEFINE DELPHI10_UP}\r\n{$ENDIF}\r\n\r\n{$IFDEF DELPHI10_UP}\r\n {$DEFINE DELPHI2006_UP} // synonym to DELPHI10_UP\r\n {$DEFINE DELPHI9_UP}\r\n{$ENDIF}\r\n\r\n{$IFDEF DELPHI9_UP}\r\n {$DEFINE DELPHI2005_UP} // synonym to DELPHI9_UP\r\n {$DEFINE DELPHI8_UP}\r\n{$ENDIF}\r\n\r\n{$IFDEF DELPHI8_UP} {$DEFINE DELPHI7_UP} {$ENDIF}\r\n{$IFDEF DELPHI7_UP} {$DEFINE DELPHI6_UP} {$ENDIF}\r\n{$IFDEF DELPHI6_UP} {$DEFINE DELPHI5_UP} {$ENDIF}\r\n{$IFDEF DELPHI5_UP} {$DEFINE DELPHI4_UP} {$ENDIF}\r\n{$IFDEF DELPHI4_UP} {$DEFINE DELPHI3_UP} {$ENDIF}\r\n{$IFDEF DELPHI3_UP} {$DEFINE DELPHI2_UP} {$ENDIF}\r\n{$IFDEF DELPHI2_UP} {$DEFINE DELPHI1_UP} {$ENDIF}\r\n\r\n{------------------------------------------------------------------------------}\r\n{ BCBX_UP from BCBX mappings }\r\n{------------------------------------------------------------------------------}\r\n\r\n{$IFDEF BCB17} {$DEFINE BCB17_UP} {$ENDIF}\r\n{$IFDEF BCB16} {$DEFINE BCB16_UP} {$ENDIF}\r\n{$IFDEF BCB15} {$DEFINE BCB15_UP} {$ENDIF}\r\n{$IFDEF BCB14} {$DEFINE BCB14_UP} {$ENDIF}\r\n{$IFDEF BCB12} {$DEFINE BCB12_UP} {$ENDIF}\r\n{$IFDEF BCB11} {$DEFINE BCB11_UP} {$ENDIF}\r\n{$IFDEF BCB10} {$DEFINE BCB10_UP} {$ENDIF}\r\n{$IFDEF BCB6} {$DEFINE BCB6_UP} {$ENDIF}\r\n{$IFDEF BCB5} {$DEFINE BCB5_UP} {$ENDIF}\r\n{$IFDEF BCB4} {$DEFINE BCB4_UP} {$ENDIF}\r\n{$IFDEF BCB3} {$DEFINE BCB3_UP} {$ENDIF}\r\n{$IFDEF BCB1} {$DEFINE BCB1_UP} {$ENDIF}\r\n\r\n{------------------------------------------------------------------------------}\r\n{ BCBX_UP from BCBX_UP mappings }\r\n{------------------------------------------------------------------------------}\r\n\r\n{$IFDEF BCB17_UP} {$DEFINE BCB16_UP} {$ENDIF}\r\n{$IFDEF BCB16_UP} {$DEFINE BCB15_UP} {$ENDIF}\r\n{$IFDEF BCB15_UP} {$DEFINE BCB14_UP} {$ENDIF}\r\n{$IFDEF BCB14_UP} {$DEFINE BCB12_UP} {$ENDIF}\r\n{$IFDEF BCB12_UP} {$DEFINE BCB11_UP} {$ENDIF}\r\n{$IFDEF BCB11_UP} {$DEFINE BCB10_UP} {$ENDIF}\r\n{$IFDEF BCB10_UP} {$DEFINE BCB6_UP} {$ENDIF}\r\n{$IFDEF BCB6_UP} {$DEFINE BCB5_UP} {$ENDIF}\r\n{$IFDEF BCB5_UP} {$DEFINE BCB4_UP} {$ENDIF}\r\n{$IFDEF BCB4_UP} {$DEFINE BCB3_UP} {$ENDIF}\r\n{$IFDEF BCB3_UP} {$DEFINE BCB1_UP} {$ENDIF}\r\n\r\n{------------------------------------------------------------------------------}\r\n{ BDSX_UP from BDSX mappings }\r\n{------------------------------------------------------------------------------}\r\n\r\n{$IFDEF BDS10} {$DEFINE BDS10_UP} {$ENDIF}\r\n{$IFDEF BDS9} {$DEFINE BDS9_UP} {$ENDIF}\r\n{$IFDEF BDS8} {$DEFINE BDS8_UP} {$ENDIF}\r\n{$IFDEF BDS7} {$DEFINE BDS7_UP} {$ENDIF}\r\n{$IFDEF BDS6} {$DEFINE BDS6_UP} {$ENDIF}\r\n{$IFDEF BDS5} {$DEFINE BDS5_UP} {$ENDIF}\r\n{$IFDEF BDS4} {$DEFINE BDS4_UP} {$ENDIF}\r\n{$IFDEF BDS3} {$DEFINE BDS3_UP} {$ENDIF}\r\n{$IFDEF BDS2} {$DEFINE BDS2_UP} {$ENDIF}\r\n\r\n{------------------------------------------------------------------------------}\r\n{ BDSX_UP from BDSX_UP mappings }\r\n{------------------------------------------------------------------------------}\r\n\r\n{$IFDEF BDS10_UP} {$DEFINE BDS9_UP} {$ENDIF}\r\n{$IFDEF BDS9_UP} {$DEFINE BDS8_UP} {$ENDIF}\r\n{$IFDEF BDS8_UP} {$DEFINE BDS7_UP} {$ENDIF}\r\n{$IFDEF BDS7_UP} {$DEFINE BDS6_UP} {$ENDIF}\r\n{$IFDEF BDS6_UP} {$DEFINE BDS5_UP} {$ENDIF}\r\n{$IFDEF BDS5_UP} {$DEFINE BDS4_UP} {$ENDIF}\r\n{$IFDEF BDS4_UP} {$DEFINE BDS3_UP} {$ENDIF}\r\n{$IFDEF BDS3_UP} {$DEFINE BDS2_UP} {$ENDIF}\r\n\r\n{------------------------------------------------------------------------------}\r\n{ DELPHICOMPILERX_UP from DELPHICOMPILERX mappings }\r\n{------------------------------------------------------------------------------}\r\n\r\n{$IFDEF DELPHICOMPILER17} {$DEFINE DELPHICOMPILER17_UP} {$ENDIF}\r\n{$IFDEF DELPHICOMPILER16} {$DEFINE DELPHICOMPILER16_UP} {$ENDIF}\r\n{$IFDEF DELPHICOMPILER15} {$DEFINE DELPHICOMPILER15_UP} {$ENDIF}\r\n{$IFDEF DELPHICOMPILER14} {$DEFINE DELPHICOMPILER14_UP} {$ENDIF}\r\n{$IFDEF DELPHICOMPILER12} {$DEFINE DELPHICOMPILER12_UP} {$ENDIF}\r\n{$IFDEF DELPHICOMPILER11} {$DEFINE DELPHICOMPILER11_UP} {$ENDIF}\r\n{$IFDEF DELPHICOMPILER10} {$DEFINE DELPHICOMPILER10_UP} {$ENDIF}\r\n{$IFDEF DELPHICOMPILER9} {$DEFINE DELPHICOMPILER9_UP} {$ENDIF}\r\n{$IFDEF DELPHICOMPILER8} {$DEFINE DELPHICOMPILER8_UP} {$ENDIF}\r\n{$IFDEF DELPHICOMPILER7} {$DEFINE DELPHICOMPILER7_UP} {$ENDIF}\r\n{$IFDEF DELPHICOMPILER6} {$DEFINE DELPHICOMPILER6_UP} {$ENDIF}\r\n{$IFDEF DELPHICOMPILER5} {$DEFINE DELPHICOMPILER5_UP} {$ENDIF}\r\n{$IFDEF DELPHICOMPILER4} {$DEFINE DELPHICOMPILER4_UP} {$ENDIF}\r\n{$IFDEF DELPHICOMPILER3} {$DEFINE DELPHICOMPILER3_UP} {$ENDIF}\r\n{$IFDEF DELPHICOMPILER2} {$DEFINE DELPHICOMPILER2_UP} {$ENDIF}\r\n{$IFDEF DELPHICOMPILER1} {$DEFINE DELPHICOMPILER1_UP} {$ENDIF}\r\n\r\n{------------------------------------------------------------------------------}\r\n{ DELPHICOMPILERX_UP from DELPHICOMPILERX_UP mappings }\r\n{------------------------------------------------------------------------------}\r\n\r\n{$IFDEF DELPHICOMPILER17_UP} {$DEFINE DELPHICOMPILER16_UP} {$ENDIF}\r\n{$IFDEF DELPHICOMPILER16_UP} {$DEFINE DELPHICOMPILER15_UP} {$ENDIF}\r\n{$IFDEF DELPHICOMPILER15_UP} {$DEFINE DELPHICOMPILER14_UP} {$ENDIF}\r\n{$IFDEF DELPHICOMPILER14_UP} {$DEFINE DELPHICOMPILER12_UP} {$ENDIF}\r\n{$IFDEF DELPHICOMPILER12_UP} {$DEFINE DELPHICOMPILER11_UP} {$ENDIF}\r\n{$IFDEF DELPHICOMPILER11_UP} {$DEFINE DELPHICOMPILER10_UP} {$ENDIF}\r\n{$IFDEF DELPHICOMPILER10_UP} {$DEFINE DELPHICOMPILER9_UP} {$ENDIF}\r\n{$IFDEF DELPHICOMPILER9_UP} {$DEFINE DELPHICOMPILER8_UP} {$ENDIF}\r\n{$IFDEF DELPHICOMPILER8_UP} {$DEFINE DELPHICOMPILER7_UP} {$ENDIF}\r\n{$IFDEF DELPHICOMPILER8_UP} {$DEFINE DELPHICOMPILER7_UP} {$ENDIF}\r\n{$IFDEF DELPHICOMPILER7_UP} {$DEFINE DELPHICOMPILER6_UP} {$ENDIF}\r\n{$IFDEF DELPHICOMPILER6_UP} {$DEFINE DELPHICOMPILER5_UP} {$ENDIF}\r\n{$IFDEF DELPHICOMPILER5_UP} {$DEFINE DELPHICOMPILER4_UP} {$ENDIF}\r\n{$IFDEF DELPHICOMPILER4_UP} {$DEFINE DELPHICOMPILER3_UP} {$ENDIF}\r\n{$IFDEF DELPHICOMPILER3_UP} {$DEFINE DELPHICOMPILER2_UP} {$ENDIF}\r\n{$IFDEF DELPHICOMPILER2_UP} {$DEFINE DELPHICOMPILER1_UP} {$ENDIF}\r\n\r\n{------------------------------------------------------------------------------}\r\n{ COMPILERX_UP from COMPILERX mappings }\r\n{------------------------------------------------------------------------------}\r\n\r\n{$IFDEF COMPILER17} {$DEFINE COMPILER17_UP} {$ENDIF}\r\n{$IFDEF COMPILER16} {$DEFINE COMPILER16_UP} {$ENDIF}\r\n{$IFDEF COMPILER15} {$DEFINE COMPILER15_UP} {$ENDIF}\r\n{$IFDEF COMPILER14} {$DEFINE COMPILER14_UP} {$ENDIF}\r\n{$IFDEF COMPILER12} {$DEFINE COMPILER12_UP} {$ENDIF}\r\n{$IFDEF COMPILER11} {$DEFINE COMPILER11_UP} {$ENDIF}\r\n{$IFDEF COMPILER10} {$DEFINE COMPILER10_UP} {$ENDIF}\r\n{$IFDEF COMPILER9} {$DEFINE COMPILER9_UP} {$ENDIF}\r\n{$IFDEF COMPILER8} {$DEFINE COMPILER8_UP} {$ENDIF}\r\n{$IFDEF COMPILER7} {$DEFINE COMPILER7_UP} {$ENDIF}\r\n{$IFDEF COMPILER6} {$DEFINE COMPILER6_UP} {$ENDIF}\r\n{$IFDEF COMPILER5} {$DEFINE COMPILER5_UP} {$ENDIF}\r\n{$IFDEF COMPILER4} {$DEFINE COMPILER4_UP} {$ENDIF}\r\n{$IFDEF COMPILER35} {$DEFINE COMPILER35_UP} {$ENDIF}\r\n{$IFDEF COMPILER3} {$DEFINE COMPILER3_UP} {$ENDIF}\r\n{$IFDEF COMPILER2} {$DEFINE COMPILER2_UP} {$ENDIF}\r\n{$IFDEF COMPILER1} {$DEFINE COMPILER1_UP} {$ENDIF}\r\n\r\n{------------------------------------------------------------------------------}\r\n{ COMPILERX_UP from COMPILERX_UP mappings }\r\n{------------------------------------------------------------------------------}\r\n\r\n{$IFDEF COMPILER17_UP} {$DEFINE COMPILER16_UP} {$ENDIF}\r\n{$IFDEF COMPILER16_UP} {$DEFINE COMPILER15_UP} {$ENDIF}\r\n{$IFDEF COMPILER15_UP} {$DEFINE COMPILER14_UP} {$ENDIF}\r\n{$IFDEF COMPILER14_UP} {$DEFINE COMPILER12_UP} {$ENDIF}\r\n{$IFDEF COMPILER12_UP} {$DEFINE COMPILER11_UP} {$ENDIF}\r\n{$IFDEF COMPILER11_UP} {$DEFINE COMPILER10_UP} {$ENDIF}\r\n{$IFDEF COMPILER10_UP} {$DEFINE COMPILER9_UP} {$ENDIF}\r\n{$IFDEF COMPILER9_UP} {$DEFINE COMPILER8_UP} {$ENDIF}\r\n{$IFDEF COMPILER8_UP} {$DEFINE COMPILER7_UP} {$ENDIF}\r\n{$IFDEF COMPILER7_UP} {$DEFINE COMPILER6_UP} {$ENDIF}\r\n{$IFDEF COMPILER6_UP} {$DEFINE COMPILER5_UP} {$ENDIF}\r\n{$IFDEF COMPILER5_UP} {$DEFINE COMPILER4_UP} {$ENDIF}\r\n{$IFDEF COMPILER4_UP} {$DEFINE COMPILER35_UP} {$ENDIF}\r\n{$IFDEF COMPILER35_UP} {$DEFINE COMPILER3_UP} {$ENDIF}\r\n{$IFDEF COMPILER3_UP} {$DEFINE COMPILER2_UP} {$ENDIF}\r\n{$IFDEF COMPILER2_UP} {$DEFINE COMPILER1_UP} {$ENDIF}\r\n\r\n{------------------------------------------------------------------------------}\r\n{ RTLX_UP from RTLX_UP mappings }\r\n{------------------------------------------------------------------------------}\r\n\r\n{$IFDEF RTL240_UP} {$DEFINE RTL230_UP} {$ENDIF}\r\n{$IFDEF RTL230_UP} {$DEFINE RTL220_UP} {$ENDIF}\r\n{$IFDEF RTL220_UP} {$DEFINE RTL210_UP} {$ENDIF}\r\n{$IFDEF RTL210_UP} {$DEFINE RTL200_UP} {$ENDIF}\r\n{$IFDEF RTL200_UP} {$DEFINE RTL190_UP} {$ENDIF}\r\n{$IFDEF RTL190_UP} {$DEFINE RTL185_UP} {$ENDIF}\r\n{$IFDEF RTL185_UP} {$DEFINE RTL180_UP} {$ENDIF}\r\n{$IFDEF RTL180_UP} {$DEFINE RTL170_UP} {$ENDIF}\r\n{$IFDEF RTL170_UP} {$DEFINE RTL160_UP} {$ENDIF}\r\n{$IFDEF RTL160_UP} {$DEFINE RTL150_UP} {$ENDIF}\r\n{$IFDEF RTL150_UP} {$DEFINE RTL145_UP} {$ENDIF}\r\n{$IFDEF RTL145_UP} {$DEFINE RTL142_UP} {$ENDIF}\r\n{$IFDEF RTL142_UP} {$DEFINE RTL140_UP} {$ENDIF}\r\n{$IFDEF RTL140_UP} {$DEFINE RTL130_UP} {$ENDIF}\r\n{$IFDEF RTL130_UP} {$DEFINE RTL125_UP} {$ENDIF}\r\n{$IFDEF RTL125_UP} {$DEFINE RTL120_UP} {$ENDIF}\r\n{$IFDEF RTL120_UP} {$DEFINE RTL110_UP} {$ENDIF}\r\n{$IFDEF RTL110_UP} {$DEFINE RTL100_UP} {$ENDIF}\r\n{$IFDEF RTL100_UP} {$DEFINE RTL93_UP} {$ENDIF}\r\n{$IFDEF RTL93_UP} {$DEFINE RTL90_UP} {$ENDIF}\r\n{$IFDEF RTL90_UP} {$DEFINE RTL80_UP} {$ENDIF}\r\n\r\n{------------------------------------------------------------------------------}\r\n{ Check for CLR overrides of default detection }\r\n{------------------------------------------------------------------------------}\r\n\r\n{$IFDEF CLR}\r\n {$IFDEF FORCE_CLR10}\r\n {$DEFINE CLR10}\r\n {$UNDEF CLR11}\r\n {$UNDEF CLR20}\r\n {$ENDIF FORCE_CLR10}\r\n\r\n {$IFDEF FORCE_CLR11}\r\n {$UNDEF CLR10}\r\n {$DEFINE CLR11}\r\n {$UNDEF CLR20}\r\n {$ENDIF FORCE_CLR11}\r\n\r\n {$IFDEF FORCE_CLR20}\r\n {$UNDEF CLR10}\r\n {$UNDEF CLR11}\r\n {$DEFINE CLR20}\r\n {$ENDIF FORCE_CLR20}\r\n{$ENDIF CLR}\r\n\r\n{------------------------------------------------------------------------------}\r\n{ CLRX from CLRX_UP mappings }\r\n{------------------------------------------------------------------------------}\r\n\r\n{$IFDEF CLR10} {$DEFINE CLR10_UP} {$ENDIF}\r\n{$IFDEF CLR11} {$DEFINE CLR11_UP} {$ENDIF}\r\n{$IFDEF CLR20} {$DEFINE CLR20_UP} {$ENDIF}\r\n\r\n{------------------------------------------------------------------------------}\r\n{ CLRX_UP from CLRX_UP mappings }\r\n{------------------------------------------------------------------------------}\r\n\r\n{$IFDEF CLR20_UP} {$DEFINE CLR11_UP} {$ENDIF}\r\n{$IFDEF CLR11_UP} {$DEFINE CLR10_UP} {$ENDIF}\r\n\r\n{------------------------------------------------------------------------------}\r\n\r\n{$IFDEF DELPHICOMPILER}\r\n {$DEFINE DELPHILANGUAGE}\r\n{$ENDIF}\r\n\r\n{$IFDEF BCBCOMPILER}\r\n {$DEFINE DELPHILANGUAGE}\r\n{$ENDIF}\r\n\r\n{------------------------------------------------------------------------------}\r\n{ KYLIXX_UP from KYLIXX mappings }\r\n{------------------------------------------------------------------------------}\r\n\r\n{$IFDEF KYLIX3} {$DEFINE KYLIX3_UP} {$ENDIF}\r\n{$IFDEF KYLIX2} {$DEFINE KYLIX2_UP} {$ENDIF}\r\n{$IFDEF KYLIX1} {$DEFINE KYLIX1_UP} {$ENDIF}\r\n\r\n{------------------------------------------------------------------------------}\r\n{ KYLIXX_UP from KYLIXX_UP mappings }\r\n{------------------------------------------------------------------------------}\r\n\r\n{$IFDEF KYLIX3_UP} {$DEFINE KYLIX2_UP} {$ENDIF}\r\n{$IFDEF KYLIX2_UP} {$DEFINE KYLIX1_UP} {$ENDIF}\r\n\r\n{------------------------------------------------------------------------------}\r\n{ Map COMPILERX_UP to friendly feature names }\r\n{------------------------------------------------------------------------------}\r\n\r\n{$IFDEF FPC}\r\n {$IFDEF VER1_0}\r\n Please use FPC 2.0 or higher to compile this.\r\n {$ELSE}\r\n {$DEFINE SUPPORTS_OUTPARAMS}\r\n {$DEFINE SUPPORTS_WIDECHAR}\r\n {$DEFINE SUPPORTS_WIDESTRING}\r\n {$IFDEF HASINTF}\r\n {$DEFINE SUPPORTS_INTERFACE}\r\n {$ENDIF}\r\n {$IFDEF HASVARIANT}\r\n {$DEFINE SUPPORTS_VARIANT}\r\n {$ENDIF}\r\n {$IFDEF FPC_HAS_TYPE_SINGLE}\r\n {$DEFINE SUPPORTS_SINGLE}\r\n {$ENDIF}\r\n {$IFDEF FPC_HAS_TYPE_DOUBLE}\r\n {$DEFINE SUPPORTS_DOUBLE}\r\n {$ENDIF}\r\n {$IFDEF FPC_HAS_TYPE_EXTENDED}\r\n {$DEFINE SUPPORTS_EXTENDED}\r\n {$ENDIF}\r\n {$IFDEF HASCURRENCY}\r\n {$DEFINE SUPPORTS_CURRENCY}\r\n {$ENDIF}\r\n {$DEFINE SUPPORTS_THREADVAR}\r\n {$DEFINE SUPPORTS_CONSTPARAMS}\r\n {$DEFINE SUPPORTS_LONGWORD}\r\n {$DEFINE SUPPORTS_INT64}\r\n {$DEFINE SUPPORTS_DYNAMICARRAYS}\r\n {$DEFINE SUPPORTS_DEFAULTPARAMS}\r\n {$DEFINE SUPPORTS_OVERLOAD}\r\n {$DEFINE ACCEPT_DEPRECATED} // 2.2 also gives warnings\r\n {$DEFINE ACCEPT_PLATFORM} // 2.2 also gives warnings\r\n {$DEFINE ACCEPT_LIBRARY}\r\n {$DEFINE SUPPORTS_EXTSYM}\r\n {$DEFINE SUPPORTS_NODEFINE}\r\n\r\n {$DEFINE SUPPORTS_CUSTOMVARIANTS}\r\n {$DEFINE SUPPORTS_VARARGS}\r\n {$DEFINE SUPPORTS_ENUMVALUE}\r\n {$IFDEF LINUX}\r\n {$DEFINE HAS_UNIT_LIBC}\r\n {$ENDIF LINUX}\r\n {$DEFINE HAS_UNIT_CONTNRS}\r\n {$DEFINE HAS_UNIT_TYPES}\r\n {$DEFINE HAS_UNIT_VARIANTS}\r\n {$DEFINE HAS_UNIT_STRUTILS}\r\n {$DEFINE HAS_UNIT_DATEUTILS}\r\n {$DEFINE HAS_UNIT_RTLCONSTS}\r\n\r\n {$DEFINE XPLATFORM_RTL}\r\n\r\n {$IFDEF VER2_2}\r\n {$DEFINE SUPPORTS_DISPINTERFACE}\r\n {$DEFINE SUPPORTS_IMPLEMENTS}\r\n {$DEFINE SUPPORTS_DISPID}\r\n {$ELSE}\r\n {$UNDEF SUPPORTS_DISPINTERFACE}\r\n {$UNDEF SUPPORTS_IMPLEMENTS}\r\n {$endif}\r\n {$UNDEF SUPPORTS_UNSAFE_WARNINGS}\r\n {$ENDIF}\r\n{$ENDIF FPC}\r\n\r\n{$IFDEF CLR}\r\n {$DEFINE SUPPORTS_UNICODE}\r\n{$ENDIF CLR}\r\n\r\n{$IFDEF COMPILER1_UP}\r\n {$DEFINE SUPPORTS_CONSTPARAMS}\r\n {$DEFINE SUPPORTS_SINGLE}\r\n {$DEFINE SUPPORTS_DOUBLE}\r\n {$DEFINE SUPPORTS_EXTENDED}\r\n {$DEFINE SUPPORTS_PACKAGES} \r\n{$ENDIF COMPILER1_UP}\r\n\r\n{$IFDEF COMPILER2_UP}\r\n {$DEFINE SUPPORTS_CURRENCY}\r\n {$DEFINE SUPPORTS_THREADVAR}\r\n {$DEFINE SUPPORTS_VARIANT}\r\n {$DEFINE SUPPORTS_WIDECHAR}\r\n{$ENDIF COMPILER2_UP}\r\n\r\n{$IFDEF COMPILER3_UP}\r\n {$DEFINE SUPPORTS_OUTPARAMS}\r\n {$DEFINE SUPPORTS_WIDESTRING}\r\n {$DEFINE SUPPORTS_INTERFACE}\r\n {$DEFINE SUPPORTS_DISPINTERFACE}\r\n {$DEFINE SUPPORTS_DISPID}\r\n {$DEFINE SUPPORTS_WEAKPACKAGEUNIT}\r\n{$ENDIF COMPILER3_UP}\r\n\r\n{$IFDEF COMPILER35_UP}\r\n {$DEFINE SUPPORTS_EXTSYM}\r\n {$DEFINE SUPPORTS_NODEFINE}\r\n{$ENDIF COMPILER35_UP}\r\n\r\n{$IFDEF COMPILER4_UP}\r\n {$DEFINE SUPPORTS_LONGWORD}\r\n {$DEFINE SUPPORTS_INT64}\r\n {$DEFINE SUPPORTS_DYNAMICARRAYS}\r\n {$DEFINE SUPPORTS_DEFAULTPARAMS}\r\n {$DEFINE SUPPORTS_OVERLOAD}\r\n {$DEFINE SUPPORTS_IMPLEMENTS}\r\n{$ENDIF COMPILER4_UP}\r\n\r\n{$IFDEF COMPILER6_UP}\r\n {$DEFINE SUPPORTS_DEPRECATED}\r\n {$DEFINE SUPPORTS_LIBRARY}\r\n {$DEFINE SUPPORTS_PLATFORM}\r\n {$DEFINE SUPPORTS_LOCAL}\r\n {$DEFINE SUPPORTS_SETPEFLAGS}\r\n {$DEFINE SUPPORTS_EXPERIMENTAL_WARNINGS}\r\n {$DEFINE ACCEPT_DEPRECATED}\r\n {$DEFINE ACCEPT_PLATFORM}\r\n {$DEFINE ACCEPT_LIBRARY}\r\n {$DEFINE SUPPORTS_DEPRECATED_WARNINGS}\r\n {$DEFINE SUPPORTS_LIBRARY_WARNINGS}\r\n {$DEFINE SUPPORTS_PLATFORM_WARNINGS}\r\n {$DEFINE SUPPORTS_CUSTOMVARIANTS}\r\n {$DEFINE SUPPORTS_VARARGS}\r\n {$DEFINE SUPPORTS_ENUMVALUE}\r\n {$DEFINE SUPPORTS_COMPILETIME_MESSAGES}\r\n{$ENDIF COMPILER6_UP}\r\n\r\n{$IFDEF COMPILER7_UP}\r\n {$DEFINE SUPPORTS_UNSAFE_WARNINGS}\r\n{$ENDIF COMPILER7_UP}\r\n\r\n{$IFDEF COMPILER9_UP}\r\n {$DEFINE SUPPORTS_FOR_IN}\r\n {$DEFINE SUPPORTS_INLINE}\r\n {$DEFINE SUPPORTS_NESTED_CONSTANTS}\r\n {$DEFINE SUPPORTS_NESTED_TYPES}\r\n {$DEFINE SUPPORTS_REGION}\r\n {$IFDEF CLR}\r\n {$DEFINE SUPPORTS_ENHANCED_RECORDS}\r\n {$DEFINE SUPPORTS_CLASS_FIELDS}\r\n {$DEFINE SUPPORTS_CLASS_HELPERS}\r\n {$DEFINE SUPPORTS_CLASS_OPERATORS}\r\n {$DEFINE SUPPORTS_STRICT}\r\n {$DEFINE SUPPORTS_STATIC}\r\n {$DEFINE SUPPORTS_FINAL}\r\n {$ENDIF CLR}\r\n{$ENDIF COMPILER9_UP}\r\n\r\n{$IFDEF COMPILER10_UP}\r\n {$DEFINE SUPPORTS_ENHANCED_RECORDS}\r\n {$DEFINE SUPPORTS_CLASS_FIELDS}\r\n {$DEFINE SUPPORTS_CLASS_HELPERS}\r\n {$DEFINE SUPPORTS_CLASS_OPERATORS}\r\n {$DEFINE SUPPORTS_STRICT}\r\n {$DEFINE SUPPORTS_STATIC}\r\n {$DEFINE SUPPORTS_FINAL}\r\n {$DEFINE SUPPORTS_METHODINFO}\r\n{$ENDIF COMPILER10_UP}\r\n\r\n{$IFDEF COMPILER11_UP}\r\n {$IFDEF CLR}\r\n {$DEFINE SUPPORTS_GENERICS}\r\n {$DEFINE SUPPORTS_DEPRECATED_DETAILS}\r\n {$ENDIF CLR}\r\n{$ENDIF COMPILER11_UP}\r\n\r\n{$IFDEF COMPILER12_UP}\r\n {$DEFINE SUPPORTS_GENERICS}\r\n {$DEFINE SUPPORTS_DEPRECATED_DETAILS}\r\n {$DEFINE SUPPORTS_INT_ALIASES}\r\n {$IFNDEF CLR}\r\n {$DEFINE SUPPORTS_UNICODE}\r\n {$DEFINE SUPPORTS_UNICODE_STRING}\r\n {$ENDIF CLR}\r\n{$ENDIF COMPILER12_UP}\r\n\r\n{$IFDEF COMPILER14_UP}\r\n {$DEFINE SUPPORTS_CLASS_CTORDTORS}\r\n {$DEFINE HAS_UNIT_RTTI}\r\n {$DEFINE SUPPORTS_CAST_INTERFACE_TO_OBJ}\r\n {$DEFINE SUPPORTS_DELAYED_LOADING}\r\n{$ENDIF COMPILER14_UP}\r\n\r\n{$IFDEF COMPILER16_UP}\r\n {$DEFINE USE_64BIT_TYPES}\r\n{$ENDIF COMPILER16_UP}\r\n\r\n{$IFDEF RTL130_UP}\r\n {$DEFINE HAS_UNIT_CONTNRS}\r\n{$ENDIF RTL130_UP}\r\n\r\n{$IFDEF RTL140_UP}\r\n {$IFDEF LINUX}\r\n {$DEFINE HAS_UNIT_LIBC}\r\n {$ENDIF LINUX}\r\n {$DEFINE HAS_UNIT_RTLCONSTS}\r\n {$DEFINE HAS_UNIT_TYPES}\r\n {$DEFINE HAS_UNIT_VARIANTS}\r\n {$DEFINE HAS_UNIT_STRUTILS}\r\n {$DEFINE HAS_UNIT_DATEUTILS}\r\n {$DEFINE XPLATFORM_RTL}\r\n{$ENDIF RTL140_UP}\r\n\r\n{$IFDEF RTL170_UP}\r\n {$DEFINE HAS_UNIT_HTTPPROD}\r\n{$ENDIF RTL170_UP}\r\n\r\n{$IFDEF RTL185_UP}\r\n {$DEFINE HAS_UNIT_GIFIMG}\r\n{$ENDIF RTL185_UP}\r\n\r\n{$IFDEF RTL200_UP}\r\n {$DEFINE HAS_UNIT_ANSISTRINGS}\r\n {$DEFINE HAS_UNIT_PNGIMAGE}\r\n {$DEFINE HAS_UNIT_CHARACTER}\r\n{$ENDIF RTL200_UP}\r\n\r\n{$IFDEF RTL220_UP}\r\n {$DEFINE SUPPORTS_UINT64}\r\n {$DEFINE HAS_UNIT_REGULAREXPRESSIONSAPI}\r\n{$ENDIF RTL220_UP}\r\n\r\n{$IFDEF RTL230_UP}\r\n {$DEFINE HAS_UNITSCOPE}\r\n {$DEFINE HAS_UNIT_SYSTEM_UITYPES}\r\n{$ENDIF RTL230_UP}\r\n\r\n{$IFDEF RTL240_UP}\r\n {$DEFINE HAS_UNIT_SYSTEM_ACTIONS}\r\n{$ENDIF RTL240_UP}\r\n\r\n{------------------------------------------------------------------------------}\r\n{ Cross-platform related defines }\r\n{------------------------------------------------------------------------------}\r\n\r\n{$IFNDEF CPUASM}\r\n {$DEFINE PUREPASCAL}\r\n{$ENDIF ~CPUASM}\r\n\r\n{$IFDEF WIN32}\r\n {$DEFINE MSWINDOWS} // predefined for D6+/BCB6+\r\n {$DEFINE Win32API}\r\n{$ENDIF}\r\n\r\n{$IFDEF DELPHILANGUAGE}\r\n {$IFDEF LINUX}\r\n {$DEFINE UNIX}\r\n {$ENDIF}\r\n\r\n {$IFNDEF CONSOLE}\r\n {$IFDEF LINUX}\r\n {$DEFINE VisualCLX}\r\n {$ENDIF}\r\n {$IFNDEF VisualCLX}\r\n {$DEFINE VCL}\r\n {$ENDIF}\r\n {$ENDIF ~CONSOLE}\r\n{$ENDIF DELPHILANGUAGE}\r\n\r\n{------------------------------------------------------------------------------}\r\n{ Compiler settings }\r\n{------------------------------------------------------------------------------}\r\n\r\n{$IFOPT A+} {$DEFINE ALIGN_ON} {$ENDIF}\r\n{$IFOPT B+} {$DEFINE BOOLEVAL_ON} {$ENDIF}\r\n{$IFDEF COMPILER2_UP}\r\n {$IFOPT C+} {$DEFINE ASSERTIONS_ON} {$ENDIF}\r\n{$ENDIF}\r\n{$IFOPT D+} {$DEFINE DEBUGINFO_ON} {$ENDIF}\r\n{$IFOPT G+} {$DEFINE IMPORTEDDATA_ON} {$ENDIF}\r\n{$IFDEF COMPILER2_UP}\r\n {$IFOPT H+} {$DEFINE LONGSTRINGS_ON} {$ENDIF}\r\n{$ENDIF}\r\n\r\n// Hints\r\n{$IFOPT I+} {$DEFINE IOCHECKS_ON} {$ENDIF}\r\n{$IFDEF COMPILER2_UP}\r\n {$IFOPT J+} {$DEFINE WRITEABLECONST_ON} {$ENDIF}\r\n{$ENDIF}\r\n{$IFOPT L+} {$DEFINE LOCALSYMBOLS} {$DEFINE LOCALSYMBOLS_ON} {$ENDIF}\r\n{$IFOPT M+} {$DEFINE TYPEINFO_ON} {$ENDIF}\r\n{$IFOPT O+} {$DEFINE OPTIMIZATION_ON} {$ENDIF}\r\n{$IFOPT P+} {$DEFINE OPENSTRINGS_ON} {$ENDIF}\r\n{$IFOPT Q+} {$DEFINE OVERFLOWCHECKS_ON} {$ENDIF}\r\n{$IFOPT R+} {$DEFINE RANGECHECKS_ON} {$ENDIF}\r\n\r\n// Real compatibility\r\n{$IFOPT T+} {$DEFINE TYPEDADDRESS_ON} {$ENDIF}\r\n{$IFOPT U+} {$DEFINE SAFEDIVIDE_ON} {$ENDIF}\r\n{$IFOPT V+} {$DEFINE VARSTRINGCHECKS_ON} {$ENDIF}\r\n{$IFOPT W+} {$DEFINE STACKFRAMES_ON} {$ENDIF}\r\n\r\n// Warnings\r\n{$IFOPT X+} {$DEFINE EXTENDEDSYNTAX_ON} {$ENDIF}\r\n\r\n// for Delphi/BCB trial versions remove the point from the line below\r\n{.$UNDEF SUPPORTS_WEAKPACKAGEUNIT}\r\n\r\n{$ENDIF ~JEDI_INC}\r\n" }, { "path": "External/Jedi/Jvcl/common/jedi/kylix.inc", "content": "//\r\n// This is FPC-incompatible code and was excluded from jedi.inc for this reason\r\n//\r\n// Kylix 3/C++ for some reason evaluates CompilerVersion comparisons to False,\r\n// if the constant to compare with is a floating point value - weird.\r\n// The \"+\" sign prevents Kylix/Delphi from issueing a warning about comparing\r\n// signed and unsigned values.\r\n//\r\n {$IF not Declared(CompilerVersion)}\r\n {$DEFINE KYLIX1}\r\n {$DEFINE COMPILER6}\r\n {$DEFINE DELPHICOMPILER6}\r\n {$DEFINE RTL140_UP}\r\n {$ELSEIF Declared(CompilerVersion) and (CompilerVersion > +14)}\r\n {$DEFINE KYLIX2}\r\n {$DEFINE COMPILER6}\r\n {$DEFINE DELPHICOMPILER6}\r\n {$DEFINE RTL142_UP}\r\n {$ELSEIF Declared(CompilerVersion) and (CompilerVersion < +15)}\r\n {$DEFINE KYLIX3}\r\n {$DEFINE COMPILER6}\r\n {$IFNDEF BCB}\r\n {$DEFINE DELPHICOMPILER6}\r\n {$ENDIF}\r\n {$DEFINE RTL145_UP}\r\n {$ELSE}\r\n Add new Kylix version\r\n {$IFEND}\r\n\r\n\r\n" }, { "path": "External/Jedi/Jvcl/common/jvcl.inc", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JVCL.INC, released on 2002-07-04.\r\n\r\nLast Modified: 2008-11-11\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n{$A+,B-,C+,D+,E-,F-,G+,H+,I+,J-,K-,L+,M-,N+,O+,P+,Q-,R-,S-,T-,U-,V+,W-,X+,Y+,Z1}\r\n\r\n{$IFDEF JVCL_NO_DEBUGINFO} // set by the Installer\r\n {$D-}\r\n{$ENDIF JVCL_NO_DEBUGINFO}\r\n\r\n{$I jedi\\jedi.inc}\r\n\r\n{$IFNDEF JEDI_INC}\r\nALERT_jedi_inc_incompatible\r\n// secure against old versions of jedi.inc.\r\n{$ENDIF !JEDI_INC}\r\n\r\n// Reduces warnings on D7:\r\n{$IFDEF COMPILER7_UP}\r\n {$WARN UNSAFE_TYPE OFF}\r\n {$WARN UNSAFE_CODE OFF}\r\n {$WARN UNSAFE_CAST OFF}\r\n{$ENDIF COMPILER7_UP}\r\n\r\n{$IFDEF BCB}\r\n {$ObjExportAll ON}\r\n{$ENDIF BCB}\r\n\r\n\r\n{$UNDEF JVCL_CONFIGURED}\r\n\r\n{$IFDEF DEFAULT_JVCL_INC}\r\n{-----------------------------------------------------------------------------}\r\n{ Default configuration }\r\n{-----------------------------------------------------------------------------}\r\n {$I jvclbase.inc}\r\n {$DEFINE JVCL_CONFIGURED}\r\n{$ELSE}\r\n{-----------------------------------------------------------------------------}\r\n{ Delphi }\r\n{-----------------------------------------------------------------------------}\r\n{$IFDEF DELPHI6}\r\n {$I jvcld6.inc}\r\n {$DEFINE JVCL_CONFIGURED}\r\n{$ENDIF DELPIH6}\r\n{-----------------------------------------------------------------------------}\r\n{$IFDEF DELPHI7}\r\n {$I jvcld7.inc}\r\n {$DEFINE JVCL_CONFIGURED}\r\n{$ENDIF DELPIH7}\r\n{-----------------------------------------------------------------------------}\r\n{$IFDEF DELPHI9}\r\n {$I jvcld9.inc}\r\n {$DEFINE JVCL_CONFIGURED}\r\n{$ENDIF DELPIH9}\r\n{-----------------------------------------------------------------------------}\r\n{$IFDEF DELPHI10}\r\n {$I jvcld10.inc}\r\n {$DEFINE JVCL_CONFIGURED}\r\n{$ENDIF DELPIH10}\r\n{-----------------------------------------------------------------------------}\r\n{$IFDEF DELPHI11}\r\n {$I jvcld11.inc}\r\n {$DEFINE JVCL_CONFIGURED}\r\n{$ENDIF DELPHI11}\r\n{-----------------------------------------------------------------------------}\r\n{$IFDEF DELPHI12}\r\n {$I jvcld12.inc}\r\n {$DEFINE JVCL_CONFIGURED}\r\n{$ENDIF DELPHI12}\r\n{-----------------------------------------------------------------------------}\r\n{$IFDEF DELPHI14}\r\n {$I jvcld14.inc}\r\n {$DEFINE JVCL_CONFIGURED}\r\n{$ENDIF DELPHI14}\r\n{-----------------------------------------------------------------------------}\r\n{$IFDEF DELPHI15}\r\n {$I jvcld15.inc}\r\n {$DEFINE JVCL_CONFIGURED}\r\n{$ENDIF DELPHI15}\r\n{-----------------------------------------------------------------------------}\r\n{$IFDEF DELPHI16}\r\n {$IFDEF CPUX86}\r\n {$I jvcld16.inc}\r\n {$ENDIF CPUX86}\r\n {$IFDEF CPUX64}\r\n {$I jvcld16_x64.inc}\r\n {$ENDIF CPUX64}\r\n {$DEFINE JVCL_CONFIGURED}\r\n{$ENDIF DELPHI16}\r\n{-----------------------------------------------------------------------------}\r\n{$IFDEF DELPHI17}\r\n {$IFDEF CPUX86}\r\n {$I jvcld17.inc}\r\n {$ENDIF CPUX86}\r\n {$IFDEF CPUX64}\r\n {$I jvcld17_x64.inc}\r\n {$ENDIF CPUX64}\r\n {$DEFINE JVCL_CONFIGURED}\r\n{$ENDIF DELPHI17}\r\n{-----------------------------------------------------------------------------}\r\n{ C++Builder }\r\n{-----------------------------------------------------------------------------}\r\n{$IFDEF BCB6}\r\n {$I jvclc6.inc}\r\n {$DEFINE JVCL_CONFIGURED}\r\n{$ENDIF BCB6}\r\n{-----------------------------------------------------------------------------}\r\n{$IFDEF BCB10}\r\n {$I jvcld10.inc} // same include file for BDS based C++\r\n {$DEFINE JVCL_CONFIGURED}\r\n{$ENDIF BCB10}\r\n{-----------------------------------------------------------------------------}\r\n{$IFDEF BCB11}\r\n {$I jvcld11.inc} // same include file for BDS based C++\r\n {$DEFINE JVCL_CONFIGURED}\r\n{$ENDIF BCB11}\r\n{-----------------------------------------------------------------------------}\r\n{$IFDEF BCB12}\r\n {$I jvcld12.inc} // same include file for BDS based C++\r\n {$DEFINE JVCL_CONFIGURED}\r\n{$ENDIF BCB12}\r\n{-----------------------------------------------------------------------------}\r\n{$IFDEF BCB14}\r\n {$I jvcld14.inc} // same include file for BDS based C++\r\n {$DEFINE JVCL_CONFIGURED}\r\n{$ENDIF BCB14}\r\n{-----------------------------------------------------------------------------}\r\n{$IFDEF BCB15}\r\n {$I jvcld15.inc} // same include file for BDS based C++\r\n {$DEFINE JVCL_CONFIGURED}\r\n{$ENDIF BCB15}\r\n{-----------------------------------------------------------------------------}\r\n{$IFDEF BCB16}\r\n {$IFDEF CPUX86}\r\n {$I jvcld16win32.inc} // same include file for BDS based C++\r\n {$ENDIF CPUX86}\r\n {$IFDEF CPUX64}\r\n //there is no 64-bit C++Builder\r\n {$ENDIF CPUX64}\r\n {$DEFINE JVCL_CONFIGURED}\r\n{$ENDIF BCB16}\r\n{-----------------------------------------------------------------------------}\r\n{$IFDEF BCB17}\r\n {$IFDEF CPUX86}\r\n {$I jvcld17win32.inc} // same include file for BDS based C++\r\n {$ENDIF CPUX86}\r\n {$IFDEF CPUX64}\r\n //there is no 64-bit C++Builder yet\r\n {$ENDIF CPUX64}\r\n {$DEFINE JVCL_CONFIGURED}\r\n{$ENDIF BCB17}\r\n\r\n{$ENDIF DEFAULT_JVCL_INC}\r\n{-----------------------------------------------------------------------------}\r\n\r\n\r\n{$IFNDEF JVCL_CONFIGURED}\r\n {$IFDEF SUPPORTS_COMPILETIME_MESSAGES}\r\n {$MESSAGE FATAL 'Your Delphi/BCB version is not supported by this JVCL version!'}\r\n {$ELSE}\r\n 'Your Delphi/BCB version is not supported by this JVCL version!'\r\n {$ENDIF SUPPORTS_COMPILETIME_MESSAGES}\r\n{$ENDIF !JVCL_CONFIGURED}\r\n\r\n\r\n// check configuration dependencies\r\n\r\n{$IFNDEF JVCL_UseQuickReport}\r\n {$UNDEF QREPORT4}\r\n{$ENDIF !JVCL_UseQuickReport}\r\n\r\n{$IFDEF JVCL_GENERATE_CPP_PACKAGE_FILES}\r\n // dcc32 -IL does not support class constructor/destructor\r\n {$UNDEF SUPPORTS_CLASS_CTORDTORS}\r\n{$ENDIF JVCL_GENERATE_CPP_PACKAGE_FILES}\r\n\r\n{$IFDEF NO_UNITVERSIONING} // used by the Installer\r\n {$UNDEF UNITVERSIONING}\r\n{$ENDIF NO_UNITVERSIONING}\r\n\r\n// D7 has theme support built in...\r\n{$IFDEF COMPILER7_UP}\r\n {$DEFINE JVCLThemesEnabled}\r\n{$ELSE}\r\n {$IFDEF JVCLThemesEnabled}\r\n {$DEFINE JVCLThemesEnabledD6}\r\n {$ENDIF JVCLThemesEnabled}\r\n{$ENDIF COMPILER7_UP}\r\n\r\n{$IFDEF USE_3RDPARTY_DEVEXPRESS_CXEDITOR_SHARED}\r\n {$DEFINE USE_3RDPARTY_DEVEXPRESS_CXEDITOR}\r\n{$ENDIF}\r\n{$IFDEF USE_3RDPARTY_DEVEXPRESS_CXEDITOR_NON_SHARED}\r\n {$DEFINE USE_3RDPARTY_DEVEXPRESS_CXEDITOR}\r\n{$ENDIF}\r\n{$IFDEF USE_3RDPARTY_DEVEXPRESS_CXGRID_SHARED}\r\n {$DEFINE USE_3RDPARTY_DEVEXPRESS_CXGRID}\r\n{$ENDIF}\r\n{$IFDEF USE_3RDPARTY_DEVEXPRESS_CXGRID_NON_SHARED}\r\n {$DEFINE USE_3RDPARTY_DEVEXPRESS_CXGRID}\r\n{$ENDIF}\r\n{$IFDEF USE_3RDPARTY_DEVEXPRESS_CXVERTICALGRID_SHARED}\r\n {$DEFINE USE_3RDPARTY_DEVEXPRESS_CXVERTICALGRID}\r\n{$ENDIF}\r\n{$IFDEF USE_3RDPARTY_DEVEXPRESS_CXVERTICALGRID_NON_SHARED}\r\n {$DEFINE USE_3RDPARTY_DEVEXPRESS_CXVERTICALGRID}\r\n{$ENDIF}\r\n{$IFDEF USE_3RDPARTY_DEVEXPRESS_CXPIVOTGRID_SHARED}\r\n {$DEFINE USE_3RDPARTY_DEVEXPRESS_CXPIVOTGRID}\r\n{$ENDIF}\r\n{$IFDEF USE_3RDPARTY_DEVEXPRESS_CXPIVOTGRID_NON_SHARED}\r\n {$DEFINE USE_3RDPARTY_DEVEXPRESS_CXPIVOTGRID}\r\n{$ENDIF}\r\n{$IFDEF USE_3RDPARTY_DEVEXPRESS_CXTREELIST_SHARED}\r\n {$DEFINE USE_3RDPARTY_DEVEXPRESS_CXTREELIST}\r\n{$ENDIF}\r\n{$IFDEF USE_3RDPARTY_DEVEXPRESS_CXTREELIST_NON_SHARED}\r\n {$DEFINE USE_3RDPARTY_DEVEXPRESS_CXTREELIST}\r\n{$ENDIF}\r\n\r\n{$IFDEF USE_3RDPARTY_DEVART_ODAC}\r\n {$DEFINE USE_3RDPARTY_DEVART_DAC}\r\n{$ENDIF}\r\n{$IFDEF USE_3RDPARTY_DEVART_UNIDAC}\r\n {$DEFINE USE_3RDPARTY_DEVART_DAC}\r\n{$ENDIF}\r\n" }, { "path": "External/Jedi/Jvcl/common/jvclbase.inc", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JVCL.INC, released on 2004-12-22.\r\n\r\nLast Modified: 2004-12-22\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n\r\n{------------------------------------------------------------------------------}\r\n{ This file contains the default JVCL configuration. }\r\n{------------------------------------------------------------------------------}\r\n\r\n{%hidden%}\r\n{ Enable this define if you are using the Delphi 6, 7 or 2005 Personal Edition. }\r\n{.$DEFINE DelphiPersonalEdition}\r\n\r\n{%hidden%}\r\n{ The installer enables this define if you compile JVCL for Delphi and C++ Builder. It disables\r\n the class constructor/destructor support that is not supported by C++Builder. }\r\n{.$DEFINE JVCL_GENERATE_CPP_PACKAGE_FILES}\r\n\r\n{ Enable this define if you have the dxgettext (http://dxgettext.sourceforge.net)\r\ntranslation tool installed and want to use it with the JVCL. }\r\n{.$DEFINE USE_DXGETTEXT}\r\n\r\n{ Enable this define if you use/have QuickReport }\r\n{.$DEFINE JVCL_UseQuickReport}\r\n\r\n{ Enable this define if you have QReport 4 installed. This will require qr4rund7 instead\r\nof qrpt. NB! JVCL_UseQuickReport must also be defined}\r\n{.$DEFINE QREPORT4}\r\n\r\n{ Enable this define if you have installed the Internet Components with the Delphi installer }\r\n{.$DEFINE INTERNET_COMPONENTS}\r\n\r\n{ Activate this define if you have Mike Lischke's Theme Manager\r\n(http://www.lischke-online.de) installed and available and\r\nyou are using D6/BCB6 or below. The ThemeManager package must\r\nbe compiled as \"never-build package\". }\r\n{.$DEFINE JVCLThemesEnabled}\r\n\r\n{ Activates MIDAS components (DBRemoteLogin).\r\nNOTE: if you activate this, you must also manually add JvDlgsXXX.dcp to\r\nthe requires node of JvDBXXX.bpk !!! }\r\n{.$DEFINE Jv_MIDAS}\r\n\r\n{ This define enables GIF image support. Deactivate this define\r\nif you are using another GIF image support library. }\r\n{$DEFINE USE_JV_GIF}\r\n\r\n{ Activate this define if you do not want to use TGauge Borland sample\r\ncomponent in TDBProgress component and FileUtil routines. In this case\r\nTProgressBar component will be used. }\r\n{$DEFINE USE_PROGRESSBAR}\r\n\r\n{ This define controls whether FourDigitYear variable is used to control\r\ndate format in TDateEdit, TDBDateEdit components. When this define is not\r\nactive the ShortDateFormat variable is used instead. }\r\n{$DEFINE USE_FOUR_DIGIT_YEAR}\r\n\r\n{ This define controls whether a popup calendar is used as default\r\ninstead of a modal dialog in TDateEdit, TDBDateEdit components. }\r\n{$DEFINE DEFAULT_POPUP_CALENDAR}\r\n\r\n{ This define controls whether JvInterpreter handles\r\nOLE automation calls (for VCL only). }\r\n{$DEFINE JvInterpreter_OLEAUTO}\r\n\r\n{ Used by JvTimeFrameWork, see JvTFDays.pas for more info on time blocks. }\r\n{$DEFINE Jv_TIMEBLOCKS}\r\n\r\n{ This activates the unit versioning system where each JVCL unit gets a record that defines\r\nwhich revision, date and filename the unit has. }\r\n{.$DEFINE UNITVERSIONING}\r\n\r\n// *********************************************************************\r\n// Start Definition of Third Party Components\r\n// *********************************************************************\r\n\r\n{ Activates SM-Export Wrapper Components (in DBActions) \r\nFor further informations have a look at http://www.scalabium.com \r\nATTENTION : \r\nBEFORE YOU ACTIVATE THIS OPTION YOU MUST CHANGE THE\r\nSMEXPORT PACKAGE FROM AUTOMATIC COMPILE NO MANUAL COMPILE }\r\n{.$DEFINE USE_3RDPARTY_SMEXPORT}\r\n\r\n{ Activates SM-Import Wrapper Components (in DBActions)\r\nFor further informations have a look at http://www.scalabium.com\r\nATTENTION :\r\nBEFORE YOU ACTIVATE THIS OPTION YOU MUST CHANGE THE\r\nSMIMPORT PACKAGE FROM AUTOMATIC COMPILE NO MANUAL COMPILE }\r\n{.$DEFINE USE_3RDPARTY_SMIMPORT}\r\n\r\n{ Activates Support for the DevExpress cxEditor-Controls\r\nFor further informations have a look at http://www.devexpress.com \r\nYou have to choose between shared and non shared packages}\r\n{.$DEFINE USE_3RDPARTY_DEVEXPRESS_CXEDITOR_SHARED}\r\n{.$DEFINE USE_3RDPARTY_DEVEXPRESS_CXEDITOR_NON_SHARED}\r\n\r\n{ Activates Support for the DevExpress cxGrid-Controls\r\nFor further informations have a look at http://www.devexpress.com \r\nYou have to choose between shared and non shared packages}\r\n{.$DEFINE USE_3RDPARTY_DEVEXPRESS_CXGRID_SHARED}\r\n{.$DEFINE USE_3RDPARTY_DEVEXPRESS_CXGRID_NON_SHARED}\r\n\r\n{ Activates Support for the DevExpress cxVerticalGrid-Controls\r\nFor further informations have a look at http://www.devexpress.com \r\nYou have to choose between shared and non shared packages}\r\n{.$DEFINE USE_3RDPARTY_DEVEXPRESS_CXVERTICALGRID_SHARED}\r\n{.$DEFINE USE_3RDPARTY_DEVEXPRESS_CXVERTICALGRID_NON_SHARED}\r\n\r\n{ Activates Support for the DevExpress cxPivotGrid-Controls\r\nFor further informations have a look at http://www.devexpress.com \r\nYou have to choose between shared and non shared packages}\r\n{.$DEFINE USE_3RDPARTY_DEVEXPRESS_CXPIVOTGRID_SHARED}\r\n{.$DEFINE USE_3RDPARTY_DEVEXPRESS_CXPIVOTGRID_NON_SHARED}\r\n\r\n{ Activates Support for the DevExpress cxTreeList-Controls\r\nFor further informations have a look at http://www.devexpress.com \r\nYou have to choose between shared and non shared packages}\r\n{.$DEFINE USE_3RDPARTY_DEVEXPRESS_CXTREELIST_SHARED}\r\n{.$DEFINE USE_3RDPARTY_DEVEXPRESS_CXTREELIST_NON_SHARED}\r\n\r\n\r\n{ Activates the Internet Direct (Indy)-Components\r\nFor further informations have a look at http://www.indyproject.org }\r\n{.$DEFINE USE_3RDPARTY_INDY}\r\n\r\n{ Activates the Internet Direct (Indy)-Components version 10.\r\nYou MUST also activate $DEFINE USE_3RDPARTY_INDY for the compilation to work\r\nFor further informations have a look at http://www.indyproject.org }\r\n{.$DEFINE USE_3RDPARTY_INDY10}\r\n\r\n{ Activates Support for the ICS-Components (Internet component suite\r\nFor further informations have a look at http://www.overbyte.be/\r\nATTENTION :\r\nBEFORE YOU ACTIVATE THIS OPTION YOU MUST CHANGE THE\r\nICS* PACKAGE FROM AUTOMATIC COMPILE TO MANUAL COMPILE }\r\n{.$DEFINE USE_3RDPARTY_ICS}\r\n\r\n{ Activates Support for Direct Oracle Access Components\r\nFor further informations have a look at http://www.allroundautomations.com }\r\n{.$DEFINE USE_3RDPARTY_DOA}\r\n\r\n{ Activates Support for the DevArt VCL Oracle Data Access Components\r\nFor further informations have a look at http://www.devart.com }\r\n{.$DEFINE USE_3RDPARTY_DEVART_ODAC}\r\n\r\n{ Activates Support for the DevArt VCL Universal Data Access Components\r\nFor further informations have a look at http://www.devart.com }\r\n{.$DEFINE USE_3RDPARTY_DEVART_UNIDAC}\r\n\r\n\r\n\r\n" }, { "path": "External/Jedi/Jvcl/common/jvclc6.inc", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JVCL.INC, released on 2004-12-22.\r\n\r\nLast Modified: 2004-12-22\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n\r\n{------------------------------------------------------------------------------}\r\n{ This file contains the default JVCL configuration. }\r\n{------------------------------------------------------------------------------}\r\n\r\n{%hidden%}\r\n{ Enable this define if you are using the Delphi 6, 7 or 2005 Personal Edition. }\r\n{.$DEFINE DelphiPersonalEdition}\r\n\r\n{%hidden%}\r\n{ The installer enables this define if you compile JVCL for Delphi and C++ Builder. It disables\r\n the class constructor/destructor support that is not supported by C++Builder. }\r\n{.$DEFINE JVCL_GENERATE_CPP_PACKAGE_FILES}\r\n\r\n{ Enable this define if you have the dxgettext (http://dxgettext.sourceforge.net)\r\ntranslation tool installed and want to use it with the JVCL. }\r\n{.$DEFINE USE_DXGETTEXT}\r\n\r\n{ Enable this define if you use/have QuickReport }\r\n{.$DEFINE JVCL_UseQuickReport}\r\n\r\n{ Enable this define if you have QReport 4 installed. This will require qr4rund7 instead\r\nof qrpt. NB! JVCL_UseQuickReport must also be defined}\r\n{.$DEFINE QREPORT4}\r\n\r\n{ Enable this define if you have installed the Internet Components with the Delphi installer }\r\n{.$DEFINE INTERNET_COMPONENTS}\r\n\r\n{ Activate this define if you have Mike Lischke's Theme Manager\r\n(http://www.lischke-online.de) installed and available and\r\nyou are using D6/BCB6 or below. The ThemeManager package must\r\nbe compiled as \"never-build package\". }\r\n{.$DEFINE JVCLThemesEnabled}\r\n\r\n{ Activates MIDAS components (DBRemoteLogin).\r\nNOTE: if you activate this, you must also manually add JvDlgsXXX.dcp to\r\nthe requires node of JvDBXXX.bpk !!! }\r\n{.$DEFINE Jv_MIDAS}\r\n\r\n{ This define enables GIF image support. Deactivate this define\r\nif you are using another GIF image support library. }\r\n{$DEFINE USE_JV_GIF}\r\n\r\n{ Activate this define if you do not want to use TGauge Borland sample\r\ncomponent in TDBProgress component and FileUtil routines. In this case\r\nTProgressBar component will be used. }\r\n{$DEFINE USE_PROGRESSBAR}\r\n\r\n{ This define controls whether FourDigitYear variable is used to control\r\ndate format in TDateEdit, TDBDateEdit components. When this define is not\r\nactive the ShortDateFormat variable is used instead. }\r\n{$DEFINE USE_FOUR_DIGIT_YEAR}\r\n\r\n{ This define controls whether a popup calendar is used as default\r\ninstead of a modal dialog in TDateEdit, TDBDateEdit components. }\r\n{$DEFINE DEFAULT_POPUP_CALENDAR}\r\n\r\n{ This define controls whether JvInterpreter handles\r\nOLE automation calls (for VCL only). }\r\n{$DEFINE JvInterpreter_OLEAUTO}\r\n\r\n{ Used by JvTimeFrameWork, see JvTFDays.pas for more info on time blocks. }\r\n{$DEFINE Jv_TIMEBLOCKS}\r\n\r\n{ This activates the unit versioning system where each JVCL unit gets a record that defines\r\nwhich revision, date and filename the unit has. }\r\n{.$DEFINE UNITVERSIONING}\r\n\r\n// *********************************************************************\r\n// Start Definition of Third Party Components\r\n// *********************************************************************\r\n\r\n{ Activates SM-Export Wrapper Components (in DBActions) \r\nFor further informations have a look at http://www.scalabium.com \r\nATTENTION : \r\nBEFORE YOU ACTIVATE THIS OPTION YOU MUST CHANGE THE\r\nSMEXPORT PACKAGE FROM AUTOMATIC COMPILE NO MANUAL COMPILE }\r\n{.$DEFINE USE_3RDPARTY_SMEXPORT}\r\n\r\n{ Activates SM-Import Wrapper Components (in DBActions)\r\nFor further informations have a look at http://www.scalabium.com\r\nATTENTION :\r\nBEFORE YOU ACTIVATE THIS OPTION YOU MUST CHANGE THE\r\nSMIMPORT PACKAGE FROM AUTOMATIC COMPILE NO MANUAL COMPILE }\r\n{.$DEFINE USE_3RDPARTY_SMIMPORT}\r\n\r\n{ Activates Support for the DevExpress cxEditor-Controls\r\nFor further informations have a look at http://www.devexpress.com \r\nYou have to choose between shared and non shared packages}\r\n{.$DEFINE USE_3RDPARTY_DEVEXPRESS_CXEDITOR_SHARED}\r\n{.$DEFINE USE_3RDPARTY_DEVEXPRESS_CXEDITOR_NON_SHARED}\r\n\r\n{ Activates Support for the DevExpress cxGrid-Controls\r\nFor further informations have a look at http://www.devexpress.com \r\nYou have to choose between shared and non shared packages}\r\n{.$DEFINE USE_3RDPARTY_DEVEXPRESS_CXGRID_SHARED}\r\n{.$DEFINE USE_3RDPARTY_DEVEXPRESS_CXGRID_NON_SHARED}\r\n\r\n{ Activates Support for the DevExpress cxVerticalGrid-Controls\r\nFor further informations have a look at http://www.devexpress.com \r\nYou have to choose between shared and non shared packages}\r\n{.$DEFINE USE_3RDPARTY_DEVEXPRESS_CXVERTICALGRID_SHARED}\r\n{.$DEFINE USE_3RDPARTY_DEVEXPRESS_CXVERTICALGRID_NON_SHARED}\r\n\r\n{ Activates Support for the DevExpress cxPivotGrid-Controls\r\nFor further informations have a look at http://www.devexpress.com \r\nYou have to choose between shared and non shared packages}\r\n{.$DEFINE USE_3RDPARTY_DEVEXPRESS_CXPIVOTGRID_SHARED}\r\n{.$DEFINE USE_3RDPARTY_DEVEXPRESS_CXPIVOTGRID_NON_SHARED}\r\n\r\n{ Activates Support for the DevExpress cxTreeList-Controls\r\nFor further informations have a look at http://www.devexpress.com \r\nYou have to choose between shared and non shared packages}\r\n{.$DEFINE USE_3RDPARTY_DEVEXPRESS_CXTREELIST_SHARED}\r\n{.$DEFINE USE_3RDPARTY_DEVEXPRESS_CXTREELIST_NON_SHARED}\r\n\r\n\r\n{ Activates the Internet Direct (Indy)-Components\r\nFor further informations have a look at http://www.indyproject.org }\r\n{.$DEFINE USE_3RDPARTY_INDY}\r\n\r\n{ Activates the Internet Direct (Indy)-Components version 10.\r\nYou MUST also activate $DEFINE USE_3RDPARTY_INDY for the compilation to work\r\nFor further informations have a look at http://www.indyproject.org }\r\n{.$DEFINE USE_3RDPARTY_INDY10}\r\n\r\n{ Activates Support for the ICS-Components (Internet component suite\r\nFor further informations have a look at http://www.overbyte.be/\r\nATTENTION :\r\nBEFORE YOU ACTIVATE THIS OPTION YOU MUST CHANGE THE\r\nICS* PACKAGE FROM AUTOMATIC COMPILE TO MANUAL COMPILE }\r\n{.$DEFINE USE_3RDPARTY_ICS}\r\n\r\n{ Activates Support for Direct Oracle Access Components\r\nFor further informations have a look at http://www.allroundautomations.com }\r\n{.$DEFINE USE_3RDPARTY_DOA}\r\n\r\n{ Activates Support for the DevArt VCL Oracle Data Access Components\r\nFor further informations have a look at http://www.devart.com }\r\n{.$DEFINE USE_3RDPARTY_DEVART_ODAC}\r\n\r\n{ Activates Support for the DevArt VCL Universal Data Access Components\r\nFor further informations have a look at http://www.devart.com }\r\n{.$DEFINE USE_3RDPARTY_DEVART_UNIDAC}\r\n\r\n\r\n\r\n" }, { "path": "External/Jedi/Jvcl/common/jvcld10.inc", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JVCL.INC, released on 2004-12-22.\r\n\r\nLast Modified: 2004-12-22\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n\r\n{------------------------------------------------------------------------------}\r\n{ This file contains the default JVCL configuration. }\r\n{------------------------------------------------------------------------------}\r\n\r\n{%hidden%}\r\n{ Enable this define if you are using the Delphi 6, 7 or 2005 Personal Edition. }\r\n{.$DEFINE DelphiPersonalEdition}\r\n\r\n{%hidden%}\r\n{ The installer enables this define if you compile JVCL for Delphi and C++ Builder. It disables\r\n the class constructor/destructor support that is not supported by C++Builder. }\r\n{.$DEFINE JVCL_GENERATE_CPP_PACKAGE_FILES}\r\n\r\n{ Enable this define if you have the dxgettext (http://dxgettext.sourceforge.net)\r\ntranslation tool installed and want to use it with the JVCL. }\r\n{.$DEFINE USE_DXGETTEXT}\r\n\r\n{ Enable this define if you use/have QuickReport }\r\n{.$DEFINE JVCL_UseQuickReport}\r\n\r\n{ Enable this define if you have QReport 4 installed. This will require qr4rund7 instead\r\nof qrpt. NB! JVCL_UseQuickReport must also be defined}\r\n{.$DEFINE QREPORT4}\r\n\r\n{ Enable this define if you have installed the Internet Components with the Delphi installer }\r\n{.$DEFINE INTERNET_COMPONENTS}\r\n\r\n{ Activate this define if you have Mike Lischke's Theme Manager\r\n(http://www.lischke-online.de) installed and available and\r\nyou are using D6/BCB6 or below. The ThemeManager package must\r\nbe compiled as \"never-build package\". }\r\n{.$DEFINE JVCLThemesEnabled}\r\n\r\n{ Activates MIDAS components (DBRemoteLogin).\r\nNOTE: if you activate this, you must also manually add JvDlgsXXX.dcp to\r\nthe requires node of JvDBXXX.bpk !!! }\r\n{.$DEFINE Jv_MIDAS}\r\n\r\n{ This define enables GIF image support. Deactivate this define\r\nif you are using another GIF image support library. }\r\n{$DEFINE USE_JV_GIF}\r\n\r\n{ Activate this define if you do not want to use TGauge Borland sample\r\ncomponent in TDBProgress component and FileUtil routines. In this case\r\nTProgressBar component will be used. }\r\n{$DEFINE USE_PROGRESSBAR}\r\n\r\n{ This define controls whether FourDigitYear variable is used to control\r\ndate format in TDateEdit, TDBDateEdit components. When this define is not\r\nactive the ShortDateFormat variable is used instead. }\r\n{$DEFINE USE_FOUR_DIGIT_YEAR}\r\n\r\n{ This define controls whether a popup calendar is used as default\r\ninstead of a modal dialog in TDateEdit, TDBDateEdit components. }\r\n{$DEFINE DEFAULT_POPUP_CALENDAR}\r\n\r\n{ This define controls whether JvInterpreter handles\r\nOLE automation calls (for VCL only). }\r\n{$DEFINE JvInterpreter_OLEAUTO}\r\n\r\n{ Used by JvTimeFrameWork, see JvTFDays.pas for more info on time blocks. }\r\n{$DEFINE Jv_TIMEBLOCKS}\r\n\r\n{ This activates the unit versioning system where each JVCL unit gets a record that defines\r\nwhich revision, date and filename the unit has. }\r\n{.$DEFINE UNITVERSIONING}\r\n\r\n// *********************************************************************\r\n// Start Definition of Third Party Components\r\n// *********************************************************************\r\n\r\n{ Activates SM-Export Wrapper Components (in DBActions) \r\nFor further informations have a look at http://www.scalabium.com \r\nATTENTION : \r\nBEFORE YOU ACTIVATE THIS OPTION YOU MUST CHANGE THE\r\nSMEXPORT PACKAGE FROM AUTOMATIC COMPILE NO MANUAL COMPILE }\r\n{.$DEFINE USE_3RDPARTY_SMEXPORT}\r\n\r\n{ Activates SM-Import Wrapper Components (in DBActions)\r\nFor further informations have a look at http://www.scalabium.com\r\nATTENTION :\r\nBEFORE YOU ACTIVATE THIS OPTION YOU MUST CHANGE THE\r\nSMIMPORT PACKAGE FROM AUTOMATIC COMPILE NO MANUAL COMPILE }\r\n{.$DEFINE USE_3RDPARTY_SMIMPORT}\r\n\r\n{ Activates Support for the DevExpress cxEditor-Controls\r\nFor further informations have a look at http://www.devexpress.com \r\nYou have to choose between shared and non shared packages}\r\n{.$DEFINE USE_3RDPARTY_DEVEXPRESS_CXEDITOR_SHARED}\r\n{.$DEFINE USE_3RDPARTY_DEVEXPRESS_CXEDITOR_NON_SHARED}\r\n\r\n{ Activates Support for the DevExpress cxGrid-Controls\r\nFor further informations have a look at http://www.devexpress.com \r\nYou have to choose between shared and non shared packages}\r\n{.$DEFINE USE_3RDPARTY_DEVEXPRESS_CXGRID_SHARED}\r\n{.$DEFINE USE_3RDPARTY_DEVEXPRESS_CXGRID_NON_SHARED}\r\n\r\n{ Activates Support for the DevExpress cxVerticalGrid-Controls\r\nFor further informations have a look at http://www.devexpress.com \r\nYou have to choose between shared and non shared packages}\r\n{.$DEFINE USE_3RDPARTY_DEVEXPRESS_CXVERTICALGRID_SHARED}\r\n{.$DEFINE USE_3RDPARTY_DEVEXPRESS_CXVERTICALGRID_NON_SHARED}\r\n\r\n{ Activates Support for the DevExpress cxPivotGrid-Controls\r\nFor further informations have a look at http://www.devexpress.com \r\nYou have to choose between shared and non shared packages}\r\n{.$DEFINE USE_3RDPARTY_DEVEXPRESS_CXPIVOTGRID_SHARED}\r\n{.$DEFINE USE_3RDPARTY_DEVEXPRESS_CXPIVOTGRID_NON_SHARED}\r\n\r\n{ Activates Support for the DevExpress cxTreeList-Controls\r\nFor further informations have a look at http://www.devexpress.com \r\nYou have to choose between shared and non shared packages}\r\n{.$DEFINE USE_3RDPARTY_DEVEXPRESS_CXTREELIST_SHARED}\r\n{.$DEFINE USE_3RDPARTY_DEVEXPRESS_CXTREELIST_NON_SHARED}\r\n\r\n\r\n{ Activates the Internet Direct (Indy)-Components\r\nFor further informations have a look at http://www.indyproject.org }\r\n{.$DEFINE USE_3RDPARTY_INDY}\r\n\r\n{ Activates the Internet Direct (Indy)-Components version 10.\r\nYou MUST also activate $DEFINE USE_3RDPARTY_INDY for the compilation to work\r\nFor further informations have a look at http://www.indyproject.org }\r\n{.$DEFINE USE_3RDPARTY_INDY10}\r\n\r\n{ Activates Support for the ICS-Components (Internet component suite\r\nFor further informations have a look at http://www.overbyte.be/\r\nATTENTION :\r\nBEFORE YOU ACTIVATE THIS OPTION YOU MUST CHANGE THE\r\nICS* PACKAGE FROM AUTOMATIC COMPILE TO MANUAL COMPILE }\r\n{.$DEFINE USE_3RDPARTY_ICS}\r\n\r\n{ Activates Support for Direct Oracle Access Components\r\nFor further informations have a look at http://www.allroundautomations.com }\r\n{.$DEFINE USE_3RDPARTY_DOA}\r\n\r\n{ Activates Support for the DevArt VCL Oracle Data Access Components\r\nFor further informations have a look at http://www.devart.com }\r\n{.$DEFINE USE_3RDPARTY_DEVART_ODAC}\r\n\r\n{ Activates Support for the DevArt VCL Universal Data Access Components\r\nFor further informations have a look at http://www.devart.com }\r\n{.$DEFINE USE_3RDPARTY_DEVART_UNIDAC}\r\n\r\n\r\n\r\n" }, { "path": "External/Jedi/Jvcl/common/jvcld11.inc", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JVCL.INC, released on 2004-12-22.\r\n\r\nLast Modified: 2004-12-22\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n\r\n{------------------------------------------------------------------------------}\r\n{ This file contains the default JVCL configuration. }\r\n{------------------------------------------------------------------------------}\r\n\r\n{%hidden%}\r\n{ Enable this define if you are using the Delphi 6, 7 or 2005 Personal Edition. }\r\n{.$DEFINE DelphiPersonalEdition}\r\n\r\n{%hidden%}\r\n{ The installer enables this define if you compile JVCL for Delphi and C++ Builder. It disables\r\n the class constructor/destructor support that is not supported by C++Builder. }\r\n{.$DEFINE JVCL_GENERATE_CPP_PACKAGE_FILES}\r\n\r\n{ Enable this define if you have the dxgettext (http://dxgettext.sourceforge.net)\r\ntranslation tool installed and want to use it with the JVCL. }\r\n{.$DEFINE USE_DXGETTEXT}\r\n\r\n{ Enable this define if you use/have QuickReport }\r\n{.$DEFINE JVCL_UseQuickReport}\r\n\r\n{ Enable this define if you have QReport 4 installed. This will require qr4rund7 instead\r\nof qrpt. NB! JVCL_UseQuickReport must also be defined}\r\n{.$DEFINE QREPORT4}\r\n\r\n{ Enable this define if you have installed the Internet Components with the Delphi installer }\r\n{.$DEFINE INTERNET_COMPONENTS}\r\n\r\n{ Activate this define if you have Mike Lischke's Theme Manager\r\n(http://www.lischke-online.de) installed and available and\r\nyou are using D6/BCB6 or below. The ThemeManager package must\r\nbe compiled as \"never-build package\". }\r\n{.$DEFINE JVCLThemesEnabled}\r\n\r\n{ Activates MIDAS components (DBRemoteLogin).\r\nNOTE: if you activate this, you must also manually add JvDlgsXXX.dcp to\r\nthe requires node of JvDBXXX.bpk !!! }\r\n{.$DEFINE Jv_MIDAS}\r\n\r\n{ This define enables GIF image support. Deactivate this define\r\nif you are using another GIF image support library. }\r\n{$DEFINE USE_JV_GIF}\r\n\r\n{ Activate this define if you do not want to use TGauge Borland sample\r\ncomponent in TDBProgress component and FileUtil routines. In this case\r\nTProgressBar component will be used. }\r\n{$DEFINE USE_PROGRESSBAR}\r\n\r\n{ This define controls whether FourDigitYear variable is used to control\r\ndate format in TDateEdit, TDBDateEdit components. When this define is not\r\nactive the ShortDateFormat variable is used instead. }\r\n{$DEFINE USE_FOUR_DIGIT_YEAR}\r\n\r\n{ This define controls whether a popup calendar is used as default\r\ninstead of a modal dialog in TDateEdit, TDBDateEdit components. }\r\n{$DEFINE DEFAULT_POPUP_CALENDAR}\r\n\r\n{ This define controls whether JvInterpreter handles\r\nOLE automation calls (for VCL only). }\r\n{$DEFINE JvInterpreter_OLEAUTO}\r\n\r\n{ Used by JvTimeFrameWork, see JvTFDays.pas for more info on time blocks. }\r\n{$DEFINE Jv_TIMEBLOCKS}\r\n\r\n{ This activates the unit versioning system where each JVCL unit gets a record that defines\r\nwhich revision, date and filename the unit has. }\r\n{.$DEFINE UNITVERSIONING}\r\n\r\n// *********************************************************************\r\n// Start Definition of Third Party Components\r\n// *********************************************************************\r\n\r\n{ Activates SM-Export Wrapper Components (in DBActions) \r\nFor further informations have a look at http://www.scalabium.com \r\nATTENTION : \r\nBEFORE YOU ACTIVATE THIS OPTION YOU MUST CHANGE THE\r\nSMEXPORT PACKAGE FROM AUTOMATIC COMPILE NO MANUAL COMPILE }\r\n{.$DEFINE USE_3RDPARTY_SMEXPORT}\r\n\r\n{ Activates SM-Import Wrapper Components (in DBActions)\r\nFor further informations have a look at http://www.scalabium.com\r\nATTENTION :\r\nBEFORE YOU ACTIVATE THIS OPTION YOU MUST CHANGE THE\r\nSMIMPORT PACKAGE FROM AUTOMATIC COMPILE NO MANUAL COMPILE }\r\n{.$DEFINE USE_3RDPARTY_SMIMPORT}\r\n\r\n{ Activates Support for the DevExpress cxEditor-Controls\r\nFor further informations have a look at http://www.devexpress.com \r\nYou have to choose between shared and non shared packages}\r\n{.$DEFINE USE_3RDPARTY_DEVEXPRESS_CXEDITOR_SHARED}\r\n{.$DEFINE USE_3RDPARTY_DEVEXPRESS_CXEDITOR_NON_SHARED}\r\n\r\n{ Activates Support for the DevExpress cxGrid-Controls\r\nFor further informations have a look at http://www.devexpress.com \r\nYou have to choose between shared and non shared packages}\r\n{.$DEFINE USE_3RDPARTY_DEVEXPRESS_CXGRID_SHARED}\r\n{.$DEFINE USE_3RDPARTY_DEVEXPRESS_CXGRID_NON_SHARED}\r\n\r\n{ Activates Support for the DevExpress cxVerticalGrid-Controls\r\nFor further informations have a look at http://www.devexpress.com \r\nYou have to choose between shared and non shared packages}\r\n{.$DEFINE USE_3RDPARTY_DEVEXPRESS_CXVERTICALGRID_SHARED}\r\n{.$DEFINE USE_3RDPARTY_DEVEXPRESS_CXVERTICALGRID_NON_SHARED}\r\n\r\n{ Activates Support for the DevExpress cxPivotGrid-Controls\r\nFor further informations have a look at http://www.devexpress.com \r\nYou have to choose between shared and non shared packages}\r\n{.$DEFINE USE_3RDPARTY_DEVEXPRESS_CXPIVOTGRID_SHARED}\r\n{.$DEFINE USE_3RDPARTY_DEVEXPRESS_CXPIVOTGRID_NON_SHARED}\r\n\r\n{ Activates Support for the DevExpress cxTreeList-Controls\r\nFor further informations have a look at http://www.devexpress.com \r\nYou have to choose between shared and non shared packages}\r\n{.$DEFINE USE_3RDPARTY_DEVEXPRESS_CXTREELIST_SHARED}\r\n{.$DEFINE USE_3RDPARTY_DEVEXPRESS_CXTREELIST_NON_SHARED}\r\n\r\n\r\n{ Activates the Internet Direct (Indy)-Components\r\nFor further informations have a look at http://www.indyproject.org }\r\n{.$DEFINE USE_3RDPARTY_INDY}\r\n\r\n{ Activates the Internet Direct (Indy)-Components version 10.\r\nYou MUST also activate $DEFINE USE_3RDPARTY_INDY for the compilation to work\r\nFor further informations have a look at http://www.indyproject.org }\r\n{.$DEFINE USE_3RDPARTY_INDY10}\r\n\r\n{ Activates Support for the ICS-Components (Internet component suite\r\nFor further informations have a look at http://www.overbyte.be/\r\nATTENTION :\r\nBEFORE YOU ACTIVATE THIS OPTION YOU MUST CHANGE THE\r\nICS* PACKAGE FROM AUTOMATIC COMPILE TO MANUAL COMPILE }\r\n{.$DEFINE USE_3RDPARTY_ICS}\r\n\r\n{ Activates Support for Direct Oracle Access Components\r\nFor further informations have a look at http://www.allroundautomations.com }\r\n{.$DEFINE USE_3RDPARTY_DOA}\r\n\r\n{ Activates Support for the DevArt VCL Oracle Data Access Components\r\nFor further informations have a look at http://www.devart.com }\r\n{.$DEFINE USE_3RDPARTY_DEVART_ODAC}\r\n\r\n{ Activates Support for the DevArt VCL Universal Data Access Components\r\nFor further informations have a look at http://www.devart.com }\r\n{.$DEFINE USE_3RDPARTY_DEVART_UNIDAC}\r\n\r\n\r\n\r\n\r\n{%missing%}\r\n{ JVCL DEVELOPER INFO: This option is missing, please update the jvclbase.inc file. }\r\n{.$DEFINE USE_3RDPARTY_CORELAB_ODAC}\r\n\r\n{%missing%}\r\n{ JVCL DEVELOPER INFO: This option is missing, please update the jvclbase.inc file. }\r\n{.$DEFINE USE_3RDPARTY_DEVEXPRESS_CXEDITOR}\r\n\r\n{%missing%}\r\n{ JVCL DEVELOPER INFO: This option is missing, please update the jvclbase.inc file. }\r\n{.$DEFINE USE_3RDPARTY_DEVEXPRESS_CXGRID}\r\n" }, { "path": "External/Jedi/Jvcl/common/jvcld12.inc", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JVCL.INC, released on 2004-12-22.\r\n\r\nLast Modified: 2004-12-22\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n\r\n{------------------------------------------------------------------------------}\r\n{ This file contains the default JVCL configuration. }\r\n{------------------------------------------------------------------------------}\r\n\r\n{%hidden%}\r\n{ Enable this define if you are using the Delphi 6, 7 or 2005 Personal Edition. }\r\n{.$DEFINE DelphiPersonalEdition}\r\n\r\n{%hidden%}\r\n{ The installer enables this define if you compile JVCL for Delphi and C++ Builder. It disables\r\n the class constructor/destructor support that is not supported by C++Builder. }\r\n{.$DEFINE JVCL_GENERATE_CPP_PACKAGE_FILES}\r\n\r\n{ Enable this define if you have the dxgettext (http://dxgettext.sourceforge.net)\r\ntranslation tool installed and want to use it with the JVCL. }\r\n{.$DEFINE USE_DXGETTEXT}\r\n\r\n{ Enable this define if you use/have QuickReport }\r\n{.$DEFINE JVCL_UseQuickReport}\r\n\r\n{ Enable this define if you have QReport 4 installed. This will require qr4rund7 instead\r\nof qrpt. NB! JVCL_UseQuickReport must also be defined}\r\n{.$DEFINE QREPORT4}\r\n\r\n{ Enable this define if you have installed the Internet Components with the Delphi installer }\r\n{.$DEFINE INTERNET_COMPONENTS}\r\n\r\n{ Activate this define if you have Mike Lischke's Theme Manager\r\n(http://www.lischke-online.de) installed and available and\r\nyou are using D6/BCB6 or below. The ThemeManager package must\r\nbe compiled as \"never-build package\". }\r\n{.$DEFINE JVCLThemesEnabled}\r\n\r\n{ Activates MIDAS components (DBRemoteLogin).\r\nNOTE: if you activate this, you must also manually add JvDlgsXXX.dcp to\r\nthe requires node of JvDBXXX.bpk !!! }\r\n{.$DEFINE Jv_MIDAS}\r\n\r\n{ This define enables GIF image support. Deactivate this define\r\nif you are using another GIF image support library. }\r\n{$DEFINE USE_JV_GIF}\r\n\r\n{ Activate this define if you do not want to use TGauge Borland sample\r\ncomponent in TDBProgress component and FileUtil routines. In this case\r\nTProgressBar component will be used. }\r\n{$DEFINE USE_PROGRESSBAR}\r\n\r\n{ This define controls whether FourDigitYear variable is used to control\r\ndate format in TDateEdit, TDBDateEdit components. When this define is not\r\nactive the ShortDateFormat variable is used instead. }\r\n{$DEFINE USE_FOUR_DIGIT_YEAR}\r\n\r\n{ This define controls whether a popup calendar is used as default\r\ninstead of a modal dialog in TDateEdit, TDBDateEdit components. }\r\n{$DEFINE DEFAULT_POPUP_CALENDAR}\r\n\r\n{ This define controls whether JvInterpreter handles\r\nOLE automation calls (for VCL only). }\r\n{$DEFINE JvInterpreter_OLEAUTO}\r\n\r\n{ Used by JvTimeFrameWork, see JvTFDays.pas for more info on time blocks. }\r\n{$DEFINE Jv_TIMEBLOCKS}\r\n\r\n{ This activates the unit versioning system where each JVCL unit gets a record that defines\r\nwhich revision, date and filename the unit has. }\r\n{.$DEFINE UNITVERSIONING}\r\n\r\n// *********************************************************************\r\n// Start Definition of Third Party Components\r\n// *********************************************************************\r\n\r\n{ Activates SM-Export Wrapper Components (in DBActions) \r\nFor further informations have a look at http://www.scalabium.com \r\nATTENTION : \r\nBEFORE YOU ACTIVATE THIS OPTION YOU MUST CHANGE THE\r\nSMEXPORT PACKAGE FROM AUTOMATIC COMPILE NO MANUAL COMPILE }\r\n{.$DEFINE USE_3RDPARTY_SMEXPORT}\r\n\r\n{ Activates SM-Import Wrapper Components (in DBActions)\r\nFor further informations have a look at http://www.scalabium.com\r\nATTENTION :\r\nBEFORE YOU ACTIVATE THIS OPTION YOU MUST CHANGE THE\r\nSMIMPORT PACKAGE FROM AUTOMATIC COMPILE NO MANUAL COMPILE }\r\n{.$DEFINE USE_3RDPARTY_SMIMPORT}\r\n\r\n{ Activates Support for the DevExpress cxEditor-Controls\r\nFor further informations have a look at http://www.devexpress.com \r\nYou have to choose between shared and non shared packages}\r\n{.$DEFINE USE_3RDPARTY_DEVEXPRESS_CXEDITOR_SHARED}\r\n{.$DEFINE USE_3RDPARTY_DEVEXPRESS_CXEDITOR_NON_SHARED}\r\n\r\n{ Activates Support for the DevExpress cxGrid-Controls\r\nFor further informations have a look at http://www.devexpress.com \r\nYou have to choose between shared and non shared packages}\r\n{.$DEFINE USE_3RDPARTY_DEVEXPRESS_CXGRID_SHARED}\r\n{.$DEFINE USE_3RDPARTY_DEVEXPRESS_CXGRID_NON_SHARED}\r\n\r\n{ Activates Support for the DevExpress cxVerticalGrid-Controls\r\nFor further informations have a look at http://www.devexpress.com \r\nYou have to choose between shared and non shared packages}\r\n{.$DEFINE USE_3RDPARTY_DEVEXPRESS_CXVERTICALGRID_SHARED}\r\n{.$DEFINE USE_3RDPARTY_DEVEXPRESS_CXVERTICALGRID_NON_SHARED}\r\n\r\n{ Activates Support for the DevExpress cxPivotGrid-Controls\r\nFor further informations have a look at http://www.devexpress.com \r\nYou have to choose between shared and non shared packages}\r\n{.$DEFINE USE_3RDPARTY_DEVEXPRESS_CXPIVOTGRID_SHARED}\r\n{.$DEFINE USE_3RDPARTY_DEVEXPRESS_CXPIVOTGRID_NON_SHARED}\r\n\r\n{ Activates Support for the DevExpress cxTreeList-Controls\r\nFor further informations have a look at http://www.devexpress.com \r\nYou have to choose between shared and non shared packages}\r\n{.$DEFINE USE_3RDPARTY_DEVEXPRESS_CXTREELIST_SHARED}\r\n{.$DEFINE USE_3RDPARTY_DEVEXPRESS_CXTREELIST_NON_SHARED}\r\n\r\n\r\n{ Activates the Internet Direct (Indy)-Components\r\nFor further informations have a look at http://www.indyproject.org }\r\n{.$DEFINE USE_3RDPARTY_INDY}\r\n\r\n{ Activates the Internet Direct (Indy)-Components version 10.\r\nYou MUST also activate $DEFINE USE_3RDPARTY_INDY for the compilation to work\r\nFor further informations have a look at http://www.indyproject.org }\r\n{.$DEFINE USE_3RDPARTY_INDY10}\r\n\r\n{ Activates Support for the ICS-Components (Internet component suite\r\nFor further informations have a look at http://www.overbyte.be/\r\nATTENTION :\r\nBEFORE YOU ACTIVATE THIS OPTION YOU MUST CHANGE THE\r\nICS* PACKAGE FROM AUTOMATIC COMPILE TO MANUAL COMPILE }\r\n{.$DEFINE USE_3RDPARTY_ICS}\r\n\r\n{ Activates Support for Direct Oracle Access Components\r\nFor further informations have a look at http://www.allroundautomations.com }\r\n{.$DEFINE USE_3RDPARTY_DOA}\r\n\r\n{ Activates Support for the DevArt VCL Oracle Data Access Components\r\nFor further informations have a look at http://www.devart.com }\r\n{.$DEFINE USE_3RDPARTY_DEVART_ODAC}\r\n\r\n{ Activates Support for the DevArt VCL Universal Data Access Components\r\nFor further informations have a look at http://www.devart.com }\r\n{.$DEFINE USE_3RDPARTY_DEVART_UNIDAC}\r\n\r\n\r\n\r\n" }, { "path": "External/Jedi/Jvcl/common/jvcld14.inc", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JVCL.INC, released on 2004-12-22.\r\n\r\nLast Modified: 2004-12-22\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n\r\n{------------------------------------------------------------------------------}\r\n{ This file contains the default JVCL configuration. }\r\n{------------------------------------------------------------------------------}\r\n\r\n{%hidden%}\r\n{ Enable this define if you are using the Delphi 6, 7 or 2005 Personal Edition. }\r\n{.$DEFINE DelphiPersonalEdition}\r\n\r\n{%hidden%}\r\n{ The installer enables this define if you compile JVCL for Delphi and C++ Builder. It disables\r\n the class constructor/destructor support that is not supported by C++Builder. }\r\n{.$DEFINE JVCL_GENERATE_CPP_PACKAGE_FILES}\r\n\r\n{ Enable this define if you have the dxgettext (http://dxgettext.sourceforge.net)\r\ntranslation tool installed and want to use it with the JVCL. }\r\n{.$DEFINE USE_DXGETTEXT}\r\n\r\n{ Enable this define if you use/have QuickReport }\r\n{.$DEFINE JVCL_UseQuickReport}\r\n\r\n{ Enable this define if you have QReport 4 installed. This will require qr4rund7 instead\r\nof qrpt. NB! JVCL_UseQuickReport must also be defined}\r\n{.$DEFINE QREPORT4}\r\n\r\n{ Enable this define if you have installed the Internet Components with the Delphi installer }\r\n{.$DEFINE INTERNET_COMPONENTS}\r\n\r\n{ Activate this define if you have Mike Lischke's Theme Manager\r\n(http://www.lischke-online.de) installed and available and\r\nyou are using D6/BCB6 or below. The ThemeManager package must\r\nbe compiled as \"never-build package\". }\r\n{.$DEFINE JVCLThemesEnabled}\r\n\r\n{ Activates MIDAS components (DBRemoteLogin).\r\nNOTE: if you activate this, you must also manually add JvDlgsXXX.dcp to\r\nthe requires node of JvDBXXX.bpk !!! }\r\n{.$DEFINE Jv_MIDAS}\r\n\r\n{ This define enables GIF image support. Deactivate this define\r\nif you are using another GIF image support library. }\r\n{$DEFINE USE_JV_GIF}\r\n\r\n{ Activate this define if you do not want to use TGauge Borland sample\r\ncomponent in TDBProgress component and FileUtil routines. In this case\r\nTProgressBar component will be used. }\r\n{$DEFINE USE_PROGRESSBAR}\r\n\r\n{ This define controls whether FourDigitYear variable is used to control\r\ndate format in TDateEdit, TDBDateEdit components. When this define is not\r\nactive the ShortDateFormat variable is used instead. }\r\n{$DEFINE USE_FOUR_DIGIT_YEAR}\r\n\r\n{ This define controls whether a popup calendar is used as default\r\ninstead of a modal dialog in TDateEdit, TDBDateEdit components. }\r\n{$DEFINE DEFAULT_POPUP_CALENDAR}\r\n\r\n{ This define controls whether JvInterpreter handles\r\nOLE automation calls (for VCL only). }\r\n{$DEFINE JvInterpreter_OLEAUTO}\r\n\r\n{ Used by JvTimeFrameWork, see JvTFDays.pas for more info on time blocks. }\r\n{$DEFINE Jv_TIMEBLOCKS}\r\n\r\n{ This activates the unit versioning system where each JVCL unit gets a record that defines\r\nwhich revision, date and filename the unit has. }\r\n{.$DEFINE UNITVERSIONING}\r\n\r\n// *********************************************************************\r\n// Start Definition of Third Party Components\r\n// *********************************************************************\r\n\r\n{ Activates SM-Export Wrapper Components (in DBActions) \r\nFor further informations have a look at http://www.scalabium.com \r\nATTENTION : \r\nBEFORE YOU ACTIVATE THIS OPTION YOU MUST CHANGE THE\r\nSMEXPORT PACKAGE FROM AUTOMATIC COMPILE NO MANUAL COMPILE }\r\n{.$DEFINE USE_3RDPARTY_SMEXPORT}\r\n\r\n{ Activates SM-Import Wrapper Components (in DBActions)\r\nFor further informations have a look at http://www.scalabium.com\r\nATTENTION :\r\nBEFORE YOU ACTIVATE THIS OPTION YOU MUST CHANGE THE\r\nSMIMPORT PACKAGE FROM AUTOMATIC COMPILE NO MANUAL COMPILE }\r\n{.$DEFINE USE_3RDPARTY_SMIMPORT}\r\n\r\n{ Activates Support for the DevExpress cxEditor-Controls\r\nFor further informations have a look at http://www.devexpress.com \r\nYou have to choose between shared and non shared packages}\r\n{.$DEFINE USE_3RDPARTY_DEVEXPRESS_CXEDITOR_SHARED}\r\n{.$DEFINE USE_3RDPARTY_DEVEXPRESS_CXEDITOR_NON_SHARED}\r\n\r\n{ Activates Support for the DevExpress cxGrid-Controls\r\nFor further informations have a look at http://www.devexpress.com \r\nYou have to choose between shared and non shared packages}\r\n{.$DEFINE USE_3RDPARTY_DEVEXPRESS_CXGRID_SHARED}\r\n{.$DEFINE USE_3RDPARTY_DEVEXPRESS_CXGRID_NON_SHARED}\r\n\r\n{ Activates Support for the DevExpress cxVerticalGrid-Controls\r\nFor further informations have a look at http://www.devexpress.com \r\nYou have to choose between shared and non shared packages}\r\n{.$DEFINE USE_3RDPARTY_DEVEXPRESS_CXVERTICALGRID_SHARED}\r\n{.$DEFINE USE_3RDPARTY_DEVEXPRESS_CXVERTICALGRID_NON_SHARED}\r\n\r\n{ Activates Support for the DevExpress cxPivotGrid-Controls\r\nFor further informations have a look at http://www.devexpress.com \r\nYou have to choose between shared and non shared packages}\r\n{.$DEFINE USE_3RDPARTY_DEVEXPRESS_CXPIVOTGRID_SHARED}\r\n{.$DEFINE USE_3RDPARTY_DEVEXPRESS_CXPIVOTGRID_NON_SHARED}\r\n\r\n{ Activates Support for the DevExpress cxTreeList-Controls\r\nFor further informations have a look at http://www.devexpress.com \r\nYou have to choose between shared and non shared packages}\r\n{.$DEFINE USE_3RDPARTY_DEVEXPRESS_CXTREELIST_SHARED}\r\n{.$DEFINE USE_3RDPARTY_DEVEXPRESS_CXTREELIST_NON_SHARED}\r\n\r\n\r\n{ Activates the Internet Direct (Indy)-Components\r\nFor further informations have a look at http://www.indyproject.org }\r\n{.$DEFINE USE_3RDPARTY_INDY}\r\n\r\n{ Activates the Internet Direct (Indy)-Components version 10.\r\nYou MUST also activate $DEFINE USE_3RDPARTY_INDY for the compilation to work\r\nFor further informations have a look at http://www.indyproject.org }\r\n{.$DEFINE USE_3RDPARTY_INDY10}\r\n\r\n{ Activates Support for the ICS-Components (Internet component suite\r\nFor further informations have a look at http://www.overbyte.be/\r\nATTENTION :\r\nBEFORE YOU ACTIVATE THIS OPTION YOU MUST CHANGE THE\r\nICS* PACKAGE FROM AUTOMATIC COMPILE TO MANUAL COMPILE }\r\n{.$DEFINE USE_3RDPARTY_ICS}\r\n\r\n{ Activates Support for Direct Oracle Access Components\r\nFor further informations have a look at http://www.allroundautomations.com }\r\n{.$DEFINE USE_3RDPARTY_DOA}\r\n\r\n{ Activates Support for the DevArt VCL Oracle Data Access Components\r\nFor further informations have a look at http://www.devart.com }\r\n{.$DEFINE USE_3RDPARTY_DEVART_ODAC}\r\n\r\n{ Activates Support for the DevArt VCL Universal Data Access Components\r\nFor further informations have a look at http://www.devart.com }\r\n{.$DEFINE USE_3RDPARTY_DEVART_UNIDAC}\r\n\r\n\r\n\r\n\r\n{%missing%}\r\n{ JVCL DEVELOPER INFO: This option is missing, please update the jvclbase.inc file. }\r\n{.$DEFINE USE_3RDPARTY_CORELAB_ODAC}\r\n\r\n{%missing%}\r\n{ JVCL DEVELOPER INFO: This option is missing, please update the jvclbase.inc file. }\r\n{.$DEFINE USE_3RDPARTY_DEVEXPRESS_CXEDITOR}\r\n\r\n{%missing%}\r\n{ JVCL DEVELOPER INFO: This option is missing, please update the jvclbase.inc file. }\r\n{.$DEFINE USE_3RDPARTY_DEVEXPRESS_CXGRID}\r\n" }, { "path": "External/Jedi/Jvcl/common/jvcld15.inc", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JVCL.INC, released on 2004-12-22.\r\n\r\nLast Modified: 2004-12-22\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n\r\n{------------------------------------------------------------------------------}\r\n{ This file contains the default JVCL configuration. }\r\n{------------------------------------------------------------------------------}\r\n\r\n{%hidden%}\r\n{ Enable this define if you are using the Delphi 6, 7 or 2005 Personal Edition. }\r\n{.$DEFINE DelphiPersonalEdition}\r\n\r\n{%hidden%}\r\n{ The installer enables this define if you compile JVCL for Delphi and C++ Builder. It disables\r\n the class constructor/destructor support that is not supported by C++Builder. }\r\n{.$DEFINE JVCL_GENERATE_CPP_PACKAGE_FILES}\r\n\r\n{ Enable this define if you have the dxgettext (http://dxgettext.sourceforge.net)\r\ntranslation tool installed and want to use it with the JVCL. }\r\n{.$DEFINE USE_DXGETTEXT}\r\n\r\n{ Enable this define if you use/have QuickReport }\r\n{.$DEFINE JVCL_UseQuickReport}\r\n\r\n{ Enable this define if you have QReport 4 installed. This will require qr4rund7 instead\r\nof qrpt. NB! JVCL_UseQuickReport must also be defined}\r\n{.$DEFINE QREPORT4}\r\n\r\n{ Enable this define if you have installed the Internet Components with the Delphi installer }\r\n{.$DEFINE INTERNET_COMPONENTS}\r\n\r\n{ Activate this define if you have Mike Lischke's Theme Manager\r\n(http://www.lischke-online.de) installed and available and\r\nyou are using D6/BCB6 or below. The ThemeManager package must\r\nbe compiled as \"never-build package\". }\r\n{.$DEFINE JVCLThemesEnabled}\r\n\r\n{ Activates MIDAS components (DBRemoteLogin).\r\nNOTE: if you activate this, you must also manually add JvDlgsXXX.dcp to\r\nthe requires node of JvDBXXX.bpk !!! }\r\n{.$DEFINE Jv_MIDAS}\r\n\r\n{ This define enables GIF image support. Deactivate this define\r\nif you are using another GIF image support library. }\r\n{$DEFINE USE_JV_GIF}\r\n\r\n{ Activate this define if you do not want to use TGauge Borland sample\r\ncomponent in TDBProgress component and FileUtil routines. In this case\r\nTProgressBar component will be used. }\r\n{$DEFINE USE_PROGRESSBAR}\r\n\r\n{ This define controls whether FourDigitYear variable is used to control\r\ndate format in TDateEdit, TDBDateEdit components. When this define is not\r\nactive the ShortDateFormat variable is used instead. }\r\n{$DEFINE USE_FOUR_DIGIT_YEAR}\r\n\r\n{ This define controls whether a popup calendar is used as default\r\ninstead of a modal dialog in TDateEdit, TDBDateEdit components. }\r\n{$DEFINE DEFAULT_POPUP_CALENDAR}\r\n\r\n{ This define controls whether JvInterpreter handles\r\nOLE automation calls (for VCL only). }\r\n{$DEFINE JvInterpreter_OLEAUTO}\r\n\r\n{ Used by JvTimeFrameWork, see JvTFDays.pas for more info on time blocks. }\r\n{$DEFINE Jv_TIMEBLOCKS}\r\n\r\n{ This activates the unit versioning system where each JVCL unit gets a record that defines\r\nwhich revision, date and filename the unit has. }\r\n{.$DEFINE UNITVERSIONING}\r\n\r\n// *********************************************************************\r\n// Start Definition of Third Party Components\r\n// *********************************************************************\r\n\r\n{ Activates SM-Export Wrapper Components (in DBActions) \r\nFor further informations have a look at http://www.scalabium.com \r\nATTENTION : \r\nBEFORE YOU ACTIVATE THIS OPTION YOU MUST CHANGE THE\r\nSMEXPORT PACKAGE FROM AUTOMATIC COMPILE NO MANUAL COMPILE }\r\n{.$DEFINE USE_3RDPARTY_SMEXPORT}\r\n\r\n{ Activates SM-Import Wrapper Components (in DBActions)\r\nFor further informations have a look at http://www.scalabium.com\r\nATTENTION :\r\nBEFORE YOU ACTIVATE THIS OPTION YOU MUST CHANGE THE\r\nSMIMPORT PACKAGE FROM AUTOMATIC COMPILE NO MANUAL COMPILE }\r\n{.$DEFINE USE_3RDPARTY_SMIMPORT}\r\n\r\n{ Activates Support for the DevExpress cxEditor-Controls\r\nFor further informations have a look at http://www.devexpress.com \r\nYou have to choose between shared and non shared packages}\r\n{.$DEFINE USE_3RDPARTY_DEVEXPRESS_CXEDITOR_SHARED}\r\n{.$DEFINE USE_3RDPARTY_DEVEXPRESS_CXEDITOR_NON_SHARED}\r\n\r\n{ Activates Support for the DevExpress cxGrid-Controls\r\nFor further informations have a look at http://www.devexpress.com \r\nYou have to choose between shared and non shared packages}\r\n{.$DEFINE USE_3RDPARTY_DEVEXPRESS_CXGRID_SHARED}\r\n{.$DEFINE USE_3RDPARTY_DEVEXPRESS_CXGRID_NON_SHARED}\r\n\r\n{ Activates Support for the DevExpress cxVerticalGrid-Controls\r\nFor further informations have a look at http://www.devexpress.com \r\nYou have to choose between shared and non shared packages}\r\n{.$DEFINE USE_3RDPARTY_DEVEXPRESS_CXVERTICALGRID_SHARED}\r\n{.$DEFINE USE_3RDPARTY_DEVEXPRESS_CXVERTICALGRID_NON_SHARED}\r\n\r\n{ Activates Support for the DevExpress cxPivotGrid-Controls\r\nFor further informations have a look at http://www.devexpress.com \r\nYou have to choose between shared and non shared packages}\r\n{.$DEFINE USE_3RDPARTY_DEVEXPRESS_CXPIVOTGRID_SHARED}\r\n{.$DEFINE USE_3RDPARTY_DEVEXPRESS_CXPIVOTGRID_NON_SHARED}\r\n\r\n{ Activates Support for the DevExpress cxTreeList-Controls\r\nFor further informations have a look at http://www.devexpress.com \r\nYou have to choose between shared and non shared packages}\r\n{.$DEFINE USE_3RDPARTY_DEVEXPRESS_CXTREELIST_SHARED}\r\n{.$DEFINE USE_3RDPARTY_DEVEXPRESS_CXTREELIST_NON_SHARED}\r\n\r\n\r\n{ Activates the Internet Direct (Indy)-Components\r\nFor further informations have a look at http://www.indyproject.org }\r\n{.$DEFINE USE_3RDPARTY_INDY}\r\n\r\n{ Activates the Internet Direct (Indy)-Components version 10.\r\nYou MUST also activate $DEFINE USE_3RDPARTY_INDY for the compilation to work\r\nFor further informations have a look at http://www.indyproject.org }\r\n{.$DEFINE USE_3RDPARTY_INDY10}\r\n\r\n{ Activates Support for the ICS-Components (Internet component suite\r\nFor further informations have a look at http://www.overbyte.be/\r\nATTENTION :\r\nBEFORE YOU ACTIVATE THIS OPTION YOU MUST CHANGE THE\r\nICS* PACKAGE FROM AUTOMATIC COMPILE TO MANUAL COMPILE }\r\n{.$DEFINE USE_3RDPARTY_ICS}\r\n\r\n{ Activates Support for Direct Oracle Access Components\r\nFor further informations have a look at http://www.allroundautomations.com }\r\n{.$DEFINE USE_3RDPARTY_DOA}\r\n\r\n{ Activates Support for the DevArt VCL Oracle Data Access Components\r\nFor further informations have a look at http://www.devart.com }\r\n{.$DEFINE USE_3RDPARTY_DEVART_ODAC}\r\n\r\n{ Activates Support for the DevArt VCL Universal Data Access Components\r\nFor further informations have a look at http://www.devart.com }\r\n{.$DEFINE USE_3RDPARTY_DEVART_UNIDAC}\r\n\r\n\r\n\r\n" }, { "path": "External/Jedi/Jvcl/common/jvcld16.inc", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JVCL.INC, released on 2004-12-22.\r\n\r\nLast Modified: 2004-12-22\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n\r\n{------------------------------------------------------------------------------}\r\n{ This file contains the default JVCL configuration. }\r\n{------------------------------------------------------------------------------}\r\n\r\n{%hidden%}\r\n{ Enable this define if you are using the Delphi 6, 7 or 2005 Personal Edition. }\r\n{.$DEFINE DelphiPersonalEdition}\r\n\r\n{%hidden%}\r\n{ The installer enables this define if you compile JVCL for Delphi and C++ Builder. It disables\r\n the class constructor/destructor support that is not supported by C++Builder. }\r\n{.$DEFINE JVCL_GENERATE_CPP_PACKAGE_FILES}\r\n\r\n{ Enable this define if you have the dxgettext (http://dxgettext.sourceforge.net)\r\ntranslation tool installed and want to use it with the JVCL. }\r\n{.$DEFINE USE_DXGETTEXT}\r\n\r\n{ Enable this define if you use/have QuickReport }\r\n{.$DEFINE JVCL_UseQuickReport}\r\n\r\n{ Enable this define if you have QReport 4 installed. This will require qr4rund7 instead\r\nof qrpt. NB! JVCL_UseQuickReport must also be defined}\r\n{.$DEFINE QREPORT4}\r\n\r\n{ Enable this define if you have installed the Internet Components with the Delphi installer }\r\n{.$DEFINE INTERNET_COMPONENTS}\r\n\r\n{ Activate this define if you have Mike Lischke's Theme Manager\r\n(http://www.lischke-online.de) installed and available and\r\nyou are using D6/BCB6 or below. The ThemeManager package must\r\nbe compiled as \"never-build package\". }\r\n{.$DEFINE JVCLThemesEnabled}\r\n\r\n{ Activates MIDAS components (DBRemoteLogin).\r\nNOTE: if you activate this, you must also manually add JvDlgsXXX.dcp to\r\nthe requires node of JvDBXXX.bpk !!! }\r\n{.$DEFINE Jv_MIDAS}\r\n\r\n{ This define enables GIF image support. Deactivate this define\r\nif you are using another GIF image support library. }\r\n{$DEFINE USE_JV_GIF}\r\n\r\n{ Activate this define if you do not want to use TGauge Borland sample\r\ncomponent in TDBProgress component and FileUtil routines. In this case\r\nTProgressBar component will be used. }\r\n{$DEFINE USE_PROGRESSBAR}\r\n\r\n{ This define controls whether FourDigitYear variable is used to control\r\ndate format in TDateEdit, TDBDateEdit components. When this define is not\r\nactive the ShortDateFormat variable is used instead. }\r\n{$DEFINE USE_FOUR_DIGIT_YEAR}\r\n\r\n{ This define controls whether a popup calendar is used as default\r\ninstead of a modal dialog in TDateEdit, TDBDateEdit components. }\r\n{$DEFINE DEFAULT_POPUP_CALENDAR}\r\n\r\n{ This define controls whether JvInterpreter handles\r\nOLE automation calls (for VCL only). }\r\n{$DEFINE JvInterpreter_OLEAUTO}\r\n\r\n{ Used by JvTimeFrameWork, see JvTFDays.pas for more info on time blocks. }\r\n{$DEFINE Jv_TIMEBLOCKS}\r\n\r\n{ This activates the unit versioning system where each JVCL unit gets a record that defines\r\nwhich revision, date and filename the unit has. }\r\n{.$DEFINE UNITVERSIONING}\r\n\r\n// *********************************************************************\r\n// Start Definition of Third Party Components\r\n// *********************************************************************\r\n\r\n{ Activates SM-Export Wrapper Components (in DBActions) \r\nFor further informations have a look at http://www.scalabium.com \r\nATTENTION : \r\nBEFORE YOU ACTIVATE THIS OPTION YOU MUST CHANGE THE\r\nSMEXPORT PACKAGE FROM AUTOMATIC COMPILE NO MANUAL COMPILE }\r\n{.$DEFINE USE_3RDPARTY_SMEXPORT}\r\n\r\n{ Activates SM-Import Wrapper Components (in DBActions)\r\nFor further informations have a look at http://www.scalabium.com\r\nATTENTION :\r\nBEFORE YOU ACTIVATE THIS OPTION YOU MUST CHANGE THE\r\nSMIMPORT PACKAGE FROM AUTOMATIC COMPILE NO MANUAL COMPILE }\r\n{.$DEFINE USE_3RDPARTY_SMIMPORT}\r\n\r\n{ Activates Support for the DevExpress cxEditor-Controls\r\nFor further informations have a look at http://www.devexpress.com \r\nYou have to choose between shared and non shared packages}\r\n{.$DEFINE USE_3RDPARTY_DEVEXPRESS_CXEDITOR_SHARED}\r\n{.$DEFINE USE_3RDPARTY_DEVEXPRESS_CXEDITOR_NON_SHARED}\r\n\r\n{ Activates Support for the DevExpress cxGrid-Controls\r\nFor further informations have a look at http://www.devexpress.com \r\nYou have to choose between shared and non shared packages}\r\n{.$DEFINE USE_3RDPARTY_DEVEXPRESS_CXGRID_SHARED}\r\n{.$DEFINE USE_3RDPARTY_DEVEXPRESS_CXGRID_NON_SHARED}\r\n\r\n{ Activates Support for the DevExpress cxVerticalGrid-Controls\r\nFor further informations have a look at http://www.devexpress.com \r\nYou have to choose between shared and non shared packages}\r\n{.$DEFINE USE_3RDPARTY_DEVEXPRESS_CXVERTICALGRID_SHARED}\r\n{.$DEFINE USE_3RDPARTY_DEVEXPRESS_CXVERTICALGRID_NON_SHARED}\r\n\r\n{ Activates Support for the DevExpress cxPivotGrid-Controls\r\nFor further informations have a look at http://www.devexpress.com \r\nYou have to choose between shared and non shared packages}\r\n{.$DEFINE USE_3RDPARTY_DEVEXPRESS_CXPIVOTGRID_SHARED}\r\n{.$DEFINE USE_3RDPARTY_DEVEXPRESS_CXPIVOTGRID_NON_SHARED}\r\n\r\n{ Activates Support for the DevExpress cxTreeList-Controls\r\nFor further informations have a look at http://www.devexpress.com \r\nYou have to choose between shared and non shared packages}\r\n{.$DEFINE USE_3RDPARTY_DEVEXPRESS_CXTREELIST_SHARED}\r\n{.$DEFINE USE_3RDPARTY_DEVEXPRESS_CXTREELIST_NON_SHARED}\r\n\r\n\r\n{ Activates the Internet Direct (Indy)-Components\r\nFor further informations have a look at http://www.indyproject.org }\r\n{.$DEFINE USE_3RDPARTY_INDY}\r\n\r\n{ Activates the Internet Direct (Indy)-Components version 10.\r\nYou MUST also activate $DEFINE USE_3RDPARTY_INDY for the compilation to work\r\nFor further informations have a look at http://www.indyproject.org }\r\n{.$DEFINE USE_3RDPARTY_INDY10}\r\n\r\n{ Activates Support for the ICS-Components (Internet component suite\r\nFor further informations have a look at http://www.overbyte.be/\r\nATTENTION :\r\nBEFORE YOU ACTIVATE THIS OPTION YOU MUST CHANGE THE\r\nICS* PACKAGE FROM AUTOMATIC COMPILE TO MANUAL COMPILE }\r\n{.$DEFINE USE_3RDPARTY_ICS}\r\n\r\n{ Activates Support for Direct Oracle Access Components\r\nFor further informations have a look at http://www.allroundautomations.com }\r\n{.$DEFINE USE_3RDPARTY_DOA}\r\n\r\n{ Activates Support for the DevArt VCL Oracle Data Access Components\r\nFor further informations have a look at http://www.devart.com }\r\n{.$DEFINE USE_3RDPARTY_DEVART_ODAC}\r\n\r\n{ Activates Support for the DevArt VCL Universal Data Access Components\r\nFor further informations have a look at http://www.devart.com }\r\n{.$DEFINE USE_3RDPARTY_DEVART_UNIDAC}\r\n\r\n\r\n\r\n\r\n{%missing%}\r\n{ JVCL DEVELOPER INFO: This option is missing, please update the jvclbase.inc file. }\r\n{.$DEFINE USE_3RDPARTY_CORELAB_ODAC}\r\n\r\n{%missing%}\r\n{ JVCL DEVELOPER INFO: This option is missing, please update the jvclbase.inc file. }\r\n{.$DEFINE USE_3RDPARTY_DEVEXPRESS_CXEDITOR}\r\n\r\n{%missing%}\r\n{ JVCL DEVELOPER INFO: This option is missing, please update the jvclbase.inc file. }\r\n{.$DEFINE USE_3RDPARTY_DEVEXPRESS_CXGRID}\r\n" }, { "path": "External/Jedi/Jvcl/common/jvcld16_x64.inc", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JVCL.INC, released on 2004-12-22.\r\n\r\nLast Modified: 2004-12-22\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n\r\n{------------------------------------------------------------------------------}\r\n{ This file contains the default JVCL configuration. }\r\n{------------------------------------------------------------------------------}\r\n\r\n{%hidden%}\r\n{ Enable this define if you are using the Delphi 6, 7 or 2005 Personal Edition. }\r\n{.$DEFINE DelphiPersonalEdition}\r\n\r\n{%hidden%}\r\n{ The installer enables this define if you compile JVCL for Delphi and C++ Builder. It disables\r\n the class constructor/destructor support that is not supported by C++Builder. }\r\n{.$DEFINE JVCL_GENERATE_CPP_PACKAGE_FILES}\r\n\r\n{ Enable this define if you have the dxgettext (http://dxgettext.sourceforge.net)\r\ntranslation tool installed and want to use it with the JVCL. }\r\n{.$DEFINE USE_DXGETTEXT}\r\n\r\n{ Enable this define if you use/have QuickReport }\r\n{.$DEFINE JVCL_UseQuickReport}\r\n\r\n{ Enable this define if you have QReport 4 installed. This will require qr4rund7 instead\r\nof qrpt. NB! JVCL_UseQuickReport must also be defined}\r\n{.$DEFINE QREPORT4}\r\n\r\n{ Enable this define if you have installed the Internet Components with the Delphi installer }\r\n{.$DEFINE INTERNET_COMPONENTS}\r\n\r\n{ Activate this define if you have Mike Lischke's Theme Manager\r\n(http://www.lischke-online.de) installed and available and\r\nyou are using D6/BCB6 or below. The ThemeManager package must\r\nbe compiled as \"never-build package\". }\r\n{.$DEFINE JVCLThemesEnabled}\r\n\r\n{ Activates MIDAS components (DBRemoteLogin).\r\nNOTE: if you activate this, you must also manually add JvDlgsXXX.dcp to\r\nthe requires node of JvDBXXX.bpk !!! }\r\n{.$DEFINE Jv_MIDAS}\r\n\r\n{ This define enables GIF image support. Deactivate this define\r\nif you are using another GIF image support library. }\r\n{$DEFINE USE_JV_GIF}\r\n\r\n{ Activate this define if you do not want to use TGauge Borland sample\r\ncomponent in TDBProgress component and FileUtil routines. In this case\r\nTProgressBar component will be used. }\r\n{$DEFINE USE_PROGRESSBAR}\r\n\r\n{ This define controls whether FourDigitYear variable is used to control\r\ndate format in TDateEdit, TDBDateEdit components. When this define is not\r\nactive the ShortDateFormat variable is used instead. }\r\n{$DEFINE USE_FOUR_DIGIT_YEAR}\r\n\r\n{ This define controls whether a popup calendar is used as default\r\ninstead of a modal dialog in TDateEdit, TDBDateEdit components. }\r\n{$DEFINE DEFAULT_POPUP_CALENDAR}\r\n\r\n{ This define controls whether JvInterpreter handles\r\nOLE automation calls (for VCL only). }\r\n{$DEFINE JvInterpreter_OLEAUTO}\r\n\r\n{ Used by JvTimeFrameWork, see JvTFDays.pas for more info on time blocks. }\r\n{$DEFINE Jv_TIMEBLOCKS}\r\n\r\n{ This activates the unit versioning system where each JVCL unit gets a record that defines\r\nwhich revision, date and filename the unit has. }\r\n{.$DEFINE UNITVERSIONING}\r\n\r\n// *********************************************************************\r\n// Start Definition of Third Party Components\r\n// *********************************************************************\r\n\r\n{ Activates SM-Export Wrapper Components (in DBActions) \r\nFor further informations have a look at http://www.scalabium.com \r\nATTENTION : \r\nBEFORE YOU ACTIVATE THIS OPTION YOU MUST CHANGE THE\r\nSMEXPORT PACKAGE FROM AUTOMATIC COMPILE NO MANUAL COMPILE }\r\n{.$DEFINE USE_3RDPARTY_SMEXPORT}\r\n\r\n{ Activates SM-Import Wrapper Components (in DBActions)\r\nFor further informations have a look at http://www.scalabium.com\r\nATTENTION :\r\nBEFORE YOU ACTIVATE THIS OPTION YOU MUST CHANGE THE\r\nSMIMPORT PACKAGE FROM AUTOMATIC COMPILE NO MANUAL COMPILE }\r\n{.$DEFINE USE_3RDPARTY_SMIMPORT}\r\n\r\n{ Activates Support for the DevExpress cxEditor-Controls\r\nFor further informations have a look at http://www.devexpress.com \r\nYou have to choose between shared and non shared packages}\r\n{.$DEFINE USE_3RDPARTY_DEVEXPRESS_CXEDITOR_SHARED}\r\n{.$DEFINE USE_3RDPARTY_DEVEXPRESS_CXEDITOR_NON_SHARED}\r\n\r\n{ Activates Support for the DevExpress cxGrid-Controls\r\nFor further informations have a look at http://www.devexpress.com \r\nYou have to choose between shared and non shared packages}\r\n{.$DEFINE USE_3RDPARTY_DEVEXPRESS_CXGRID_SHARED}\r\n{.$DEFINE USE_3RDPARTY_DEVEXPRESS_CXGRID_NON_SHARED}\r\n\r\n{ Activates Support for the DevExpress cxVerticalGrid-Controls\r\nFor further informations have a look at http://www.devexpress.com \r\nYou have to choose between shared and non shared packages}\r\n{.$DEFINE USE_3RDPARTY_DEVEXPRESS_CXVERTICALGRID_SHARED}\r\n{.$DEFINE USE_3RDPARTY_DEVEXPRESS_CXVERTICALGRID_NON_SHARED}\r\n\r\n{ Activates Support for the DevExpress cxPivotGrid-Controls\r\nFor further informations have a look at http://www.devexpress.com \r\nYou have to choose between shared and non shared packages}\r\n{.$DEFINE USE_3RDPARTY_DEVEXPRESS_CXPIVOTGRID_SHARED}\r\n{.$DEFINE USE_3RDPARTY_DEVEXPRESS_CXPIVOTGRID_NON_SHARED}\r\n\r\n{ Activates Support for the DevExpress cxTreeList-Controls\r\nFor further informations have a look at http://www.devexpress.com \r\nYou have to choose between shared and non shared packages}\r\n{.$DEFINE USE_3RDPARTY_DEVEXPRESS_CXTREELIST_SHARED}\r\n{.$DEFINE USE_3RDPARTY_DEVEXPRESS_CXTREELIST_NON_SHARED}\r\n\r\n\r\n{ Activates the Internet Direct (Indy)-Components\r\nFor further informations have a look at http://www.indyproject.org }\r\n{.$DEFINE USE_3RDPARTY_INDY}\r\n\r\n{ Activates the Internet Direct (Indy)-Components version 10.\r\nYou MUST also activate $DEFINE USE_3RDPARTY_INDY for the compilation to work\r\nFor further informations have a look at http://www.indyproject.org }\r\n{.$DEFINE USE_3RDPARTY_INDY10}\r\n\r\n{ Activates Support for the ICS-Components (Internet component suite\r\nFor further informations have a look at http://www.overbyte.be/\r\nATTENTION :\r\nBEFORE YOU ACTIVATE THIS OPTION YOU MUST CHANGE THE\r\nICS* PACKAGE FROM AUTOMATIC COMPILE TO MANUAL COMPILE }\r\n{.$DEFINE USE_3RDPARTY_ICS}\r\n\r\n{ Activates Support for Direct Oracle Access Components\r\nFor further informations have a look at http://www.allroundautomations.com }\r\n{.$DEFINE USE_3RDPARTY_DOA}\r\n\r\n{ Activates Support for the DevArt VCL Oracle Data Access Components\r\nFor further informations have a look at http://www.devart.com }\r\n{.$DEFINE USE_3RDPARTY_DEVART_ODAC}\r\n\r\n{ Activates Support for the DevArt VCL Universal Data Access Components\r\nFor further informations have a look at http://www.devart.com }\r\n{.$DEFINE USE_3RDPARTY_DEVART_UNIDAC}\r\n\r\n\r\n\r\n\r\n{%missing%}\r\n{ JVCL DEVELOPER INFO: This option is missing, please update the jvclbase.inc file. }\r\n{.$DEFINE USE_3RDPARTY_CORELAB_ODAC}\r\n\r\n{%missing%}\r\n{ JVCL DEVELOPER INFO: This option is missing, please update the jvclbase.inc file. }\r\n{.$DEFINE USE_3RDPARTY_DEVEXPRESS_CXEDITOR}\r\n\r\n{%missing%}\r\n{ JVCL DEVELOPER INFO: This option is missing, please update the jvclbase.inc file. }\r\n{.$DEFINE USE_3RDPARTY_DEVEXPRESS_CXGRID}\r\n" }, { "path": "External/Jedi/Jvcl/common/jvcld17.inc", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JVCL.INC, released on 2004-12-22.\r\n\r\nLast Modified: 2004-12-22\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n\r\n{------------------------------------------------------------------------------}\r\n{ This file contains the default JVCL configuration. }\r\n{------------------------------------------------------------------------------}\r\n\r\n{%hidden%}\r\n{ Enable this define if you are using the Delphi 6, 7 or 2005 Personal Edition. }\r\n{.$DEFINE DelphiPersonalEdition}\r\n\r\n{%hidden%}\r\n{ The installer enables this define if you compile JVCL for Delphi and C++ Builder. It disables\r\n the class constructor/destructor support that is not supported by C++Builder. }\r\n{.$DEFINE JVCL_GENERATE_CPP_PACKAGE_FILES}\r\n\r\n{ Enable this define if you have the dxgettext (http://dxgettext.sourceforge.net)\r\ntranslation tool installed and want to use it with the JVCL. }\r\n{.$DEFINE USE_DXGETTEXT}\r\n\r\n{ Enable this define if you use/have QuickReport }\r\n{.$DEFINE JVCL_UseQuickReport}\r\n\r\n{ Enable this define if you have QReport 4 installed. This will require qr4rund7 instead\r\nof qrpt. NB! JVCL_UseQuickReport must also be defined}\r\n{.$DEFINE QREPORT4}\r\n\r\n{ Enable this define if you have installed the Internet Components with the Delphi installer }\r\n{.$DEFINE INTERNET_COMPONENTS}\r\n\r\n{ Activate this define if you have Mike Lischke's Theme Manager\r\n(http://www.lischke-online.de) installed and available and\r\nyou are using D6/BCB6 or below. The ThemeManager package must\r\nbe compiled as \"never-build package\". }\r\n{$DEFINE JVCLThemesEnabled}\r\n\r\n{ Activates MIDAS components (DBRemoteLogin).\r\nNOTE: if you activate this, you must also manually add JvDlgsXXX.dcp to\r\nthe requires node of JvDBXXX.bpk !!! }\r\n{.$DEFINE Jv_MIDAS}\r\n\r\n{ This define enables GIF image support. Deactivate this define\r\nif you are using another GIF image support library. }\r\n{.$DEFINE USE_JV_GIF}\r\n\r\n{ Activate this define if you do not want to use TGauge Borland sample\r\ncomponent in TDBProgress component and FileUtil routines. In this case\r\nTProgressBar component will be used. }\r\n{$DEFINE USE_PROGRESSBAR}\r\n\r\n{ This define controls whether FourDigitYear variable is used to control\r\ndate format in TDateEdit, TDBDateEdit components. When this define is not\r\nactive the ShortDateFormat variable is used instead. }\r\n{$DEFINE USE_FOUR_DIGIT_YEAR}\r\n\r\n{ This define controls whether a popup calendar is used as default\r\ninstead of a modal dialog in TDateEdit, TDBDateEdit components. }\r\n{$DEFINE DEFAULT_POPUP_CALENDAR}\r\n\r\n{ This define controls whether JvInterpreter handles\r\nOLE automation calls (for VCL only). }\r\n{$DEFINE JvInterpreter_OLEAUTO}\r\n\r\n{ Used by JvTimeFrameWork, see JvTFDays.pas for more info on time blocks. }\r\n{$DEFINE Jv_TIMEBLOCKS}\r\n\r\n{ This activates the unit versioning system where each JVCL unit gets a record that defines\r\nwhich revision, date and filename the unit has. }\r\n{.$DEFINE UNITVERSIONING}\r\n\r\n// *********************************************************************\r\n// Start Definition of Third Party Components\r\n// *********************************************************************\r\n\r\n{ Activates SM-Export Wrapper Components (in DBActions)\r\nFor further informations have a look at http://www.scalabium.com\r\nATTENTION :\r\nBEFORE YOU ACTIVATE THIS OPTION YOU MUST CHANGE THE\r\nSMEXPORT PACKAGE FROM AUTOMATIC COMPILE NO MANUAL COMPILE }\r\n{.$DEFINE USE_3RDPARTY_SMEXPORT}\r\n\r\n{ Activates SM-Import Wrapper Components (in DBActions)\r\nFor further informations have a look at http://www.scalabium.com\r\nATTENTION :\r\nBEFORE YOU ACTIVATE THIS OPTION YOU MUST CHANGE THE\r\nSMIMPORT PACKAGE FROM AUTOMATIC COMPILE NO MANUAL COMPILE }\r\n{.$DEFINE USE_3RDPARTY_SMIMPORT}\r\n\r\n{ Activates Support for the DevExpress cxEditor-Controls\r\nFor further informations have a look at http://www.devexpress.com }\r\n{.$DEFINE USE_3RDPARTY_DEVEXPRESS_CXEDITOR}\r\n\r\n{ Activates Support for the DevExpress cxGrid-Controls\r\nFor further informations have a look at http://www.devexpress.com }\r\n{.$DEFINE USE_3RDPARTY_DEVEXPRESS_CXGRID}\r\n\r\n{ Activates Support for the DevExpress cxVerticalGrid-Controls\r\nFor further informations have a look at http://www.devexpress.com }\r\n{.$DEFINE USE_3RDPARTY_DEVEXPRESS_CXVERTICALGRID}\r\n\r\n{ Activates Support for the DevExpress cxPivotGrid-Controls\r\nFor further informations have a look at http://www.devexpress.com }\r\n{.$DEFINE USE_3RDPARTY_DEVEXPRESS_CXPIVOTGRID}\r\n\r\n{ Activates Support for the DevExpress cxTreeList-Controls\r\nFor further informations have a look at http://www.devexpress.com }\r\n{.$DEFINE USE_3RDPARTY_DEVEXPRESS_CXTREELIST}\r\n\r\n{ Activates the Internet Direct (Indy)-Components\r\nFor further informations have a look at http://www.indyproject.org }\r\n{.$DEFINE USE_3RDPARTY_INDY}\r\n\r\n{ Activates the Internet Direct (Indy)-Components version 10.\r\nYou MUST also activate $DEFINE USE_3RDPARTY_INDY for the compilation to work\r\nFor further informations have a look at http://www.indyproject.org }\r\n{.$DEFINE USE_3RDPARTY_INDY10}\r\n\r\n{ Activates Support for the ICS-Components (Internet component suite\r\nFor further informations have a look at http://www.overbyte.be/\r\nATTENTION :\r\nBEFORE YOU ACTIVATE THIS OPTION YOU MUST CHANGE THE\r\nICS* PACKAGE FROM AUTOMATIC COMPILE TO MANUAL COMPILE }\r\n{.$DEFINE USE_3RDPARTY_ICS}\r\n\r\n{ Activates Support for Direct Oracle Access Components\r\nFor further informations have a look at http://www.allroundautomations.com }\r\n{.$DEFINE USE_3RDPARTY_DOA}\r\n\r\n{ Activates Support for the CoreLabs VCL Oracle Data Access Components\r\nFor further informations have a look at http://www.crlab.com }\r\n{.$DEFINE USE_3RDPARTY_CORELAB_ODAC}\r\n\r\n{ Activates Support for the DevArt VCL Universal Data Access Components\r\nFor further informations have a look at http://www.devart.com }\r\n{.$DEFINE USE_3RDPARTY_DEVART_UNIDAC}\r\n" }, { "path": "External/Jedi/Jvcl/common/jvcld17_x64.inc", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JVCL.INC, released on 2004-12-22.\r\n\r\nLast Modified: 2004-12-22\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n\r\n{------------------------------------------------------------------------------}\r\n{ This file contains the default JVCL configuration. }\r\n{------------------------------------------------------------------------------}\r\n\r\n{%hidden%}\r\n{ Enable this define if you are using the Delphi 6, 7 or 2005 Personal Edition. }\r\n{.$DEFINE DelphiPersonalEdition}\r\n\r\n{%hidden%}\r\n{ The installer enables this define if you compile JVCL for Delphi and C++ Builder. It disables\r\n the class constructor/destructor support that is not supported by C++Builder. }\r\n{.$DEFINE JVCL_GENERATE_CPP_PACKAGE_FILES}\r\n\r\n{ Enable this define if you have the dxgettext (http://dxgettext.sourceforge.net)\r\ntranslation tool installed and want to use it with the JVCL. }\r\n{.$DEFINE USE_DXGETTEXT}\r\n\r\n{ Enable this define if you use/have QuickReport }\r\n{.$DEFINE JVCL_UseQuickReport}\r\n\r\n{ Enable this define if you have QReport 4 installed. This will require qr4rund7 instead\r\nof qrpt. NB! JVCL_UseQuickReport must also be defined}\r\n{.$DEFINE QREPORT4}\r\n\r\n{ Enable this define if you have installed the Internet Components with the Delphi installer }\r\n{.$DEFINE INTERNET_COMPONENTS}\r\n\r\n{ Activate this define if you have Mike Lischke's Theme Manager\r\n(http://www.lischke-online.de) installed and available and\r\nyou are using D6/BCB6 or below. The ThemeManager package must\r\nbe compiled as \"never-build package\". }\r\n{.$DEFINE JVCLThemesEnabled}\r\n\r\n{ Activates MIDAS components (DBRemoteLogin).\r\nNOTE: if you activate this, you must also manually add JvDlgsXXX.dcp to\r\nthe requires node of JvDBXXX.bpk !!! }\r\n{.$DEFINE Jv_MIDAS}\r\n\r\n{ This define enables GIF image support. Deactivate this define\r\nif you are using another GIF image support library. }\r\n{.$DEFINE USE_JV_GIF}\r\n\r\n{ Activate this define if you do not want to use TGauge Borland sample\r\ncomponent in TDBProgress component and FileUtil routines. In this case\r\nTProgressBar component will be used. }\r\n{$DEFINE USE_PROGRESSBAR}\r\n\r\n{ This define controls whether FourDigitYear variable is used to control\r\ndate format in TDateEdit, TDBDateEdit components. When this define is not\r\nactive the ShortDateFormat variable is used instead. }\r\n{$DEFINE USE_FOUR_DIGIT_YEAR}\r\n\r\n{ This define controls whether a popup calendar is used as default\r\ninstead of a modal dialog in TDateEdit, TDBDateEdit components. }\r\n{$DEFINE DEFAULT_POPUP_CALENDAR}\r\n\r\n{ This define controls whether JvInterpreter handles\r\nOLE automation calls (for VCL only). }\r\n{$DEFINE JvInterpreter_OLEAUTO}\r\n\r\n{ Used by JvTimeFrameWork, see JvTFDays.pas for more info on time blocks. }\r\n{$DEFINE Jv_TIMEBLOCKS}\r\n\r\n{ This activates the unit versioning system where each JVCL unit gets a record that defines\r\nwhich revision, date and filename the unit has. }\r\n{.$DEFINE UNITVERSIONING}\r\n\r\n// *********************************************************************\r\n// Start Definition of Third Party Components\r\n// *********************************************************************\r\n\r\n{ Activates SM-Export Wrapper Components (in DBActions)\r\nFor further informations have a look at http://www.scalabium.com\r\nATTENTION :\r\nBEFORE YOU ACTIVATE THIS OPTION YOU MUST CHANGE THE\r\nSMEXPORT PACKAGE FROM AUTOMATIC COMPILE NO MANUAL COMPILE }\r\n{.$DEFINE USE_3RDPARTY_SMEXPORT}\r\n\r\n{ Activates SM-Import Wrapper Components (in DBActions)\r\nFor further informations have a look at http://www.scalabium.com\r\nATTENTION :\r\nBEFORE YOU ACTIVATE THIS OPTION YOU MUST CHANGE THE\r\nSMIMPORT PACKAGE FROM AUTOMATIC COMPILE NO MANUAL COMPILE }\r\n{.$DEFINE USE_3RDPARTY_SMIMPORT}\r\n\r\n{ Activates Support for the DevExpress cxEditor-Controls\r\nFor further informations have a look at http://www.devexpress.com }\r\n{.$DEFINE USE_3RDPARTY_DEVEXPRESS_CXEDITOR}\r\n\r\n{ Activates Support for the DevExpress cxGrid-Controls\r\nFor further informations have a look at http://www.devexpress.com }\r\n{.$DEFINE USE_3RDPARTY_DEVEXPRESS_CXGRID}\r\n\r\n{ Activates Support for the DevExpress cxVerticalGrid-Controls\r\nFor further informations have a look at http://www.devexpress.com }\r\n{.$DEFINE USE_3RDPARTY_DEVEXPRESS_CXVERTICALGRID}\r\n\r\n{ Activates Support for the DevExpress cxPivotGrid-Controls\r\nFor further informations have a look at http://www.devexpress.com }\r\n{.$DEFINE USE_3RDPARTY_DEVEXPRESS_CXPIVOTGRID}\r\n\r\n{ Activates Support for the DevExpress cxTreeList-Controls\r\nFor further informations have a look at http://www.devexpress.com }\r\n{.$DEFINE USE_3RDPARTY_DEVEXPRESS_CXTREELIST}\r\n\r\n{ Activates the Internet Direct (Indy)-Components\r\nFor further informations have a look at http://www.indyproject.org }\r\n{.$DEFINE USE_3RDPARTY_INDY}\r\n\r\n{ Activates the Internet Direct (Indy)-Components version 10.\r\nYou MUST also activate $DEFINE USE_3RDPARTY_INDY for the compilation to work\r\nFor further informations have a look at http://www.indyproject.org }\r\n{.$DEFINE USE_3RDPARTY_INDY10}\r\n\r\n{ Activates Support for the ICS-Components (Internet component suite\r\nFor further informations have a look at http://www.overbyte.be/\r\nATTENTION :\r\nBEFORE YOU ACTIVATE THIS OPTION YOU MUST CHANGE THE\r\nICS* PACKAGE FROM AUTOMATIC COMPILE TO MANUAL COMPILE }\r\n{.$DEFINE USE_3RDPARTY_ICS}\r\n\r\n{ Activates Support for Direct Oracle Access Components\r\nFor further informations have a look at http://www.allroundautomations.com }\r\n{.$DEFINE USE_3RDPARTY_DOA}\r\n\r\n{ Activates Support for the CoreLabs VCL Oracle Data Access Components\r\nFor further informations have a look at http://www.crlab.com }\r\n{.$DEFINE USE_3RDPARTY_CORELAB_ODAC}\r\n\r\n{ Activates Support for the DevArt VCL Universal Data Access Components\r\nFor further informations have a look at http://www.devart.com }\r\n{.$DEFINE USE_3RDPARTY_DEVART_UNIDAC}\r\n" }, { "path": "External/Jedi/Jvcl/common/jvcld6.inc", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JVCL.INC, released on 2004-12-22.\r\n\r\nLast Modified: 2004-12-22\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n\r\n{------------------------------------------------------------------------------}\r\n{ This file contains the default JVCL configuration. }\r\n{------------------------------------------------------------------------------}\r\n\r\n{%hidden%}\r\n{ Enable this define if you are using the Delphi 6, 7 or 2005 Personal Edition. }\r\n{.$DEFINE DelphiPersonalEdition}\r\n\r\n{%hidden%}\r\n{ The installer enables this define if you compile JVCL for Delphi and C++ Builder. It disables\r\n the class constructor/destructor support that is not supported by C++Builder. }\r\n{.$DEFINE JVCL_GENERATE_CPP_PACKAGE_FILES}\r\n\r\n{ Enable this define if you have the dxgettext (http://dxgettext.sourceforge.net)\r\ntranslation tool installed and want to use it with the JVCL. }\r\n{.$DEFINE USE_DXGETTEXT}\r\n\r\n{ Enable this define if you use/have QuickReport }\r\n{.$DEFINE JVCL_UseQuickReport}\r\n\r\n{ Enable this define if you have QReport 4 installed. This will require qr4rund7 instead\r\nof qrpt. NB! JVCL_UseQuickReport must also be defined}\r\n{.$DEFINE QREPORT4}\r\n\r\n{ Enable this define if you have installed the Internet Components with the Delphi installer }\r\n{.$DEFINE INTERNET_COMPONENTS}\r\n\r\n{ Activate this define if you have Mike Lischke's Theme Manager\r\n(http://www.lischke-online.de) installed and available and\r\nyou are using D6/BCB6 or below. The ThemeManager package must\r\nbe compiled as \"never-build package\". }\r\n{.$DEFINE JVCLThemesEnabled}\r\n\r\n{ Activates MIDAS components (DBRemoteLogin).\r\nNOTE: if you activate this, you must also manually add JvDlgsXXX.dcp to\r\nthe requires node of JvDBXXX.bpk !!! }\r\n{.$DEFINE Jv_MIDAS}\r\n\r\n{ This define enables GIF image support. Deactivate this define\r\nif you are using another GIF image support library. }\r\n{$DEFINE USE_JV_GIF}\r\n\r\n{ Activate this define if you do not want to use TGauge Borland sample\r\ncomponent in TDBProgress component and FileUtil routines. In this case\r\nTProgressBar component will be used. }\r\n{$DEFINE USE_PROGRESSBAR}\r\n\r\n{ This define controls whether FourDigitYear variable is used to control\r\ndate format in TDateEdit, TDBDateEdit components. When this define is not\r\nactive the ShortDateFormat variable is used instead. }\r\n{$DEFINE USE_FOUR_DIGIT_YEAR}\r\n\r\n{ This define controls whether a popup calendar is used as default\r\ninstead of a modal dialog in TDateEdit, TDBDateEdit components. }\r\n{$DEFINE DEFAULT_POPUP_CALENDAR}\r\n\r\n{ This define controls whether JvInterpreter handles\r\nOLE automation calls (for VCL only). }\r\n{$DEFINE JvInterpreter_OLEAUTO}\r\n\r\n{ Used by JvTimeFrameWork, see JvTFDays.pas for more info on time blocks. }\r\n{$DEFINE Jv_TIMEBLOCKS}\r\n\r\n{ This activates the unit versioning system where each JVCL unit gets a record that defines\r\nwhich revision, date and filename the unit has. }\r\n{.$DEFINE UNITVERSIONING}\r\n\r\n// *********************************************************************\r\n// Start Definition of Third Party Components\r\n// *********************************************************************\r\n\r\n{ Activates SM-Export Wrapper Components (in DBActions) \r\nFor further informations have a look at http://www.scalabium.com \r\nATTENTION : \r\nBEFORE YOU ACTIVATE THIS OPTION YOU MUST CHANGE THE\r\nSMEXPORT PACKAGE FROM AUTOMATIC COMPILE NO MANUAL COMPILE }\r\n{.$DEFINE USE_3RDPARTY_SMEXPORT}\r\n\r\n{ Activates SM-Import Wrapper Components (in DBActions)\r\nFor further informations have a look at http://www.scalabium.com\r\nATTENTION :\r\nBEFORE YOU ACTIVATE THIS OPTION YOU MUST CHANGE THE\r\nSMIMPORT PACKAGE FROM AUTOMATIC COMPILE NO MANUAL COMPILE }\r\n{.$DEFINE USE_3RDPARTY_SMIMPORT}\r\n\r\n{ Activates Support for the DevExpress cxEditor-Controls\r\nFor further informations have a look at http://www.devexpress.com \r\nYou have to choose between shared and non shared packages}\r\n{.$DEFINE USE_3RDPARTY_DEVEXPRESS_CXEDITOR_SHARED}\r\n{.$DEFINE USE_3RDPARTY_DEVEXPRESS_CXEDITOR_NON_SHARED}\r\n\r\n{ Activates Support for the DevExpress cxGrid-Controls\r\nFor further informations have a look at http://www.devexpress.com \r\nYou have to choose between shared and non shared packages}\r\n{.$DEFINE USE_3RDPARTY_DEVEXPRESS_CXGRID_SHARED}\r\n{.$DEFINE USE_3RDPARTY_DEVEXPRESS_CXGRID_NON_SHARED}\r\n\r\n{ Activates Support for the DevExpress cxVerticalGrid-Controls\r\nFor further informations have a look at http://www.devexpress.com \r\nYou have to choose between shared and non shared packages}\r\n{.$DEFINE USE_3RDPARTY_DEVEXPRESS_CXVERTICALGRID_SHARED}\r\n{.$DEFINE USE_3RDPARTY_DEVEXPRESS_CXVERTICALGRID_NON_SHARED}\r\n\r\n{ Activates Support for the DevExpress cxPivotGrid-Controls\r\nFor further informations have a look at http://www.devexpress.com \r\nYou have to choose between shared and non shared packages}\r\n{.$DEFINE USE_3RDPARTY_DEVEXPRESS_CXPIVOTGRID_SHARED}\r\n{.$DEFINE USE_3RDPARTY_DEVEXPRESS_CXPIVOTGRID_NON_SHARED}\r\n\r\n{ Activates Support for the DevExpress cxTreeList-Controls\r\nFor further informations have a look at http://www.devexpress.com \r\nYou have to choose between shared and non shared packages}\r\n{.$DEFINE USE_3RDPARTY_DEVEXPRESS_CXTREELIST_SHARED}\r\n{.$DEFINE USE_3RDPARTY_DEVEXPRESS_CXTREELIST_NON_SHARED}\r\n\r\n\r\n{ Activates the Internet Direct (Indy)-Components\r\nFor further informations have a look at http://www.indyproject.org }\r\n{.$DEFINE USE_3RDPARTY_INDY}\r\n\r\n{ Activates the Internet Direct (Indy)-Components version 10.\r\nYou MUST also activate $DEFINE USE_3RDPARTY_INDY for the compilation to work\r\nFor further informations have a look at http://www.indyproject.org }\r\n{.$DEFINE USE_3RDPARTY_INDY10}\r\n\r\n{ Activates Support for the ICS-Components (Internet component suite\r\nFor further informations have a look at http://www.overbyte.be/\r\nATTENTION :\r\nBEFORE YOU ACTIVATE THIS OPTION YOU MUST CHANGE THE\r\nICS* PACKAGE FROM AUTOMATIC COMPILE TO MANUAL COMPILE }\r\n{.$DEFINE USE_3RDPARTY_ICS}\r\n\r\n{ Activates Support for Direct Oracle Access Components\r\nFor further informations have a look at http://www.allroundautomations.com }\r\n{.$DEFINE USE_3RDPARTY_DOA}\r\n\r\n{ Activates Support for the DevArt VCL Oracle Data Access Components\r\nFor further informations have a look at http://www.devart.com }\r\n{.$DEFINE USE_3RDPARTY_DEVART_ODAC}\r\n\r\n{ Activates Support for the DevArt VCL Universal Data Access Components\r\nFor further informations have a look at http://www.devart.com }\r\n{.$DEFINE USE_3RDPARTY_DEVART_UNIDAC}\r\n\r\n\r\n\r\n" }, { "path": "External/Jedi/Jvcl/common/jvcld7.inc", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JVCL.INC, released on 2004-12-22.\r\n\r\nLast Modified: 2004-12-22\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n\r\n{------------------------------------------------------------------------------}\r\n{ This file contains the default JVCL configuration. }\r\n{------------------------------------------------------------------------------}\r\n\r\n{%hidden%}\r\n{ Enable this define if you are using the Delphi 6, 7 or 2005 Personal Edition. }\r\n{.$DEFINE DelphiPersonalEdition}\r\n\r\n{%hidden%}\r\n{ The installer enables this define if you compile JVCL for Delphi and C++ Builder. It disables\r\n the class constructor/destructor support that is not supported by C++Builder. }\r\n{.$DEFINE JVCL_GENERATE_CPP_PACKAGE_FILES}\r\n\r\n{ Enable this define if you have the dxgettext (http://dxgettext.sourceforge.net)\r\ntranslation tool installed and want to use it with the JVCL. }\r\n{.$DEFINE USE_DXGETTEXT}\r\n\r\n{ Enable this define if you use/have QuickReport }\r\n{.$DEFINE JVCL_UseQuickReport}\r\n\r\n{ Enable this define if you have QReport 4 installed. This will require qr4rund7 instead\r\nof qrpt. NB! JVCL_UseQuickReport must also be defined}\r\n{.$DEFINE QREPORT4}\r\n\r\n{ Enable this define if you have installed the Internet Components with the Delphi installer }\r\n{.$DEFINE INTERNET_COMPONENTS}\r\n\r\n{ Activate this define if you have Mike Lischke's Theme Manager\r\n(http://www.lischke-online.de) installed and available and\r\nyou are using D6/BCB6 or below. The ThemeManager package must\r\nbe compiled as \"never-build package\". }\r\n{.$DEFINE JVCLThemesEnabled}\r\n\r\n{ Activates MIDAS components (DBRemoteLogin).\r\nNOTE: if you activate this, you must also manually add JvDlgsXXX.dcp to\r\nthe requires node of JvDBXXX.bpk !!! }\r\n{.$DEFINE Jv_MIDAS}\r\n\r\n{ This define enables GIF image support. Deactivate this define\r\nif you are using another GIF image support library. }\r\n{$DEFINE USE_JV_GIF}\r\n\r\n{ Activate this define if you do not want to use TGauge Borland sample\r\ncomponent in TDBProgress component and FileUtil routines. In this case\r\nTProgressBar component will be used. }\r\n{$DEFINE USE_PROGRESSBAR}\r\n\r\n{ This define controls whether FourDigitYear variable is used to control\r\ndate format in TDateEdit, TDBDateEdit components. When this define is not\r\nactive the ShortDateFormat variable is used instead. }\r\n{$DEFINE USE_FOUR_DIGIT_YEAR}\r\n\r\n{ This define controls whether a popup calendar is used as default\r\ninstead of a modal dialog in TDateEdit, TDBDateEdit components. }\r\n{$DEFINE DEFAULT_POPUP_CALENDAR}\r\n\r\n{ This define controls whether JvInterpreter handles\r\nOLE automation calls (for VCL only). }\r\n{$DEFINE JvInterpreter_OLEAUTO}\r\n\r\n{ Used by JvTimeFrameWork, see JvTFDays.pas for more info on time blocks. }\r\n{$DEFINE Jv_TIMEBLOCKS}\r\n\r\n{ This activates the unit versioning system where each JVCL unit gets a record that defines\r\nwhich revision, date and filename the unit has. }\r\n{.$DEFINE UNITVERSIONING}\r\n\r\n// *********************************************************************\r\n// Start Definition of Third Party Components\r\n// *********************************************************************\r\n\r\n{ Activates SM-Export Wrapper Components (in DBActions) \r\nFor further informations have a look at http://www.scalabium.com \r\nATTENTION : \r\nBEFORE YOU ACTIVATE THIS OPTION YOU MUST CHANGE THE\r\nSMEXPORT PACKAGE FROM AUTOMATIC COMPILE NO MANUAL COMPILE }\r\n{.$DEFINE USE_3RDPARTY_SMEXPORT}\r\n\r\n{ Activates SM-Import Wrapper Components (in DBActions)\r\nFor further informations have a look at http://www.scalabium.com\r\nATTENTION :\r\nBEFORE YOU ACTIVATE THIS OPTION YOU MUST CHANGE THE\r\nSMIMPORT PACKAGE FROM AUTOMATIC COMPILE NO MANUAL COMPILE }\r\n{.$DEFINE USE_3RDPARTY_SMIMPORT}\r\n\r\n{ Activates Support for the DevExpress cxEditor-Controls\r\nFor further informations have a look at http://www.devexpress.com \r\nYou have to choose between shared and non shared packages}\r\n{.$DEFINE USE_3RDPARTY_DEVEXPRESS_CXEDITOR_SHARED}\r\n{.$DEFINE USE_3RDPARTY_DEVEXPRESS_CXEDITOR_NON_SHARED}\r\n\r\n{ Activates Support for the DevExpress cxGrid-Controls\r\nFor further informations have a look at http://www.devexpress.com \r\nYou have to choose between shared and non shared packages}\r\n{.$DEFINE USE_3RDPARTY_DEVEXPRESS_CXGRID_SHARED}\r\n{.$DEFINE USE_3RDPARTY_DEVEXPRESS_CXGRID_NON_SHARED}\r\n\r\n{ Activates Support for the DevExpress cxVerticalGrid-Controls\r\nFor further informations have a look at http://www.devexpress.com \r\nYou have to choose between shared and non shared packages}\r\n{.$DEFINE USE_3RDPARTY_DEVEXPRESS_CXVERTICALGRID_SHARED}\r\n{.$DEFINE USE_3RDPARTY_DEVEXPRESS_CXVERTICALGRID_NON_SHARED}\r\n\r\n{ Activates Support for the DevExpress cxPivotGrid-Controls\r\nFor further informations have a look at http://www.devexpress.com \r\nYou have to choose between shared and non shared packages}\r\n{.$DEFINE USE_3RDPARTY_DEVEXPRESS_CXPIVOTGRID_SHARED}\r\n{.$DEFINE USE_3RDPARTY_DEVEXPRESS_CXPIVOTGRID_NON_SHARED}\r\n\r\n{ Activates Support for the DevExpress cxTreeList-Controls\r\nFor further informations have a look at http://www.devexpress.com \r\nYou have to choose between shared and non shared packages}\r\n{.$DEFINE USE_3RDPARTY_DEVEXPRESS_CXTREELIST_SHARED}\r\n{.$DEFINE USE_3RDPARTY_DEVEXPRESS_CXTREELIST_NON_SHARED}\r\n\r\n\r\n{ Activates the Internet Direct (Indy)-Components\r\nFor further informations have a look at http://www.indyproject.org }\r\n{.$DEFINE USE_3RDPARTY_INDY}\r\n\r\n{ Activates the Internet Direct (Indy)-Components version 10.\r\nYou MUST also activate $DEFINE USE_3RDPARTY_INDY for the compilation to work\r\nFor further informations have a look at http://www.indyproject.org }\r\n{.$DEFINE USE_3RDPARTY_INDY10}\r\n\r\n{ Activates Support for the ICS-Components (Internet component suite\r\nFor further informations have a look at http://www.overbyte.be/\r\nATTENTION :\r\nBEFORE YOU ACTIVATE THIS OPTION YOU MUST CHANGE THE\r\nICS* PACKAGE FROM AUTOMATIC COMPILE TO MANUAL COMPILE }\r\n{.$DEFINE USE_3RDPARTY_ICS}\r\n\r\n{ Activates Support for Direct Oracle Access Components\r\nFor further informations have a look at http://www.allroundautomations.com }\r\n{.$DEFINE USE_3RDPARTY_DOA}\r\n\r\n{ Activates Support for the DevArt VCL Oracle Data Access Components\r\nFor further informations have a look at http://www.devart.com }\r\n{.$DEFINE USE_3RDPARTY_DEVART_ODAC}\r\n\r\n{ Activates Support for the DevArt VCL Universal Data Access Components\r\nFor further informations have a look at http://www.devart.com }\r\n{.$DEFINE USE_3RDPARTY_DEVART_UNIDAC}\r\n\r\n\r\n\r\n" }, { "path": "External/Jedi/Jvcl/common/jvcld9.inc", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JVCL.INC, released on 2004-12-22.\r\n\r\nLast Modified: 2004-12-22\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n\r\n{------------------------------------------------------------------------------}\r\n{ This file contains the default JVCL configuration. }\r\n{------------------------------------------------------------------------------}\r\n\r\n{%hidden%}\r\n{ Enable this define if you are using the Delphi 6, 7 or 2005 Personal Edition. }\r\n{.$DEFINE DelphiPersonalEdition}\r\n\r\n{%hidden%}\r\n{ The installer enables this define if you compile JVCL for Delphi and C++ Builder. It disables\r\n the class constructor/destructor support that is not supported by C++Builder. }\r\n{.$DEFINE JVCL_GENERATE_CPP_PACKAGE_FILES}\r\n\r\n{ Enable this define if you have the dxgettext (http://dxgettext.sourceforge.net)\r\ntranslation tool installed and want to use it with the JVCL. }\r\n{.$DEFINE USE_DXGETTEXT}\r\n\r\n{ Enable this define if you use/have QuickReport }\r\n{.$DEFINE JVCL_UseQuickReport}\r\n\r\n{ Enable this define if you have QReport 4 installed. This will require qr4rund7 instead\r\nof qrpt. NB! JVCL_UseQuickReport must also be defined}\r\n{.$DEFINE QREPORT4}\r\n\r\n{ Enable this define if you have installed the Internet Components with the Delphi installer }\r\n{.$DEFINE INTERNET_COMPONENTS}\r\n\r\n{ Activate this define if you have Mike Lischke's Theme Manager\r\n(http://www.lischke-online.de) installed and available and\r\nyou are using D6/BCB6 or below. The ThemeManager package must\r\nbe compiled as \"never-build package\". }\r\n{.$DEFINE JVCLThemesEnabled}\r\n\r\n{ Activates MIDAS components (DBRemoteLogin).\r\nNOTE: if you activate this, you must also manually add JvDlgsXXX.dcp to\r\nthe requires node of JvDBXXX.bpk !!! }\r\n{.$DEFINE Jv_MIDAS}\r\n\r\n{ This define enables GIF image support. Deactivate this define\r\nif you are using another GIF image support library. }\r\n{$DEFINE USE_JV_GIF}\r\n\r\n{ Activate this define if you do not want to use TGauge Borland sample\r\ncomponent in TDBProgress component and FileUtil routines. In this case\r\nTProgressBar component will be used. }\r\n{$DEFINE USE_PROGRESSBAR}\r\n\r\n{ This define controls whether FourDigitYear variable is used to control\r\ndate format in TDateEdit, TDBDateEdit components. When this define is not\r\nactive the ShortDateFormat variable is used instead. }\r\n{$DEFINE USE_FOUR_DIGIT_YEAR}\r\n\r\n{ This define controls whether a popup calendar is used as default\r\ninstead of a modal dialog in TDateEdit, TDBDateEdit components. }\r\n{$DEFINE DEFAULT_POPUP_CALENDAR}\r\n\r\n{ This define controls whether JvInterpreter handles\r\nOLE automation calls (for VCL only). }\r\n{$DEFINE JvInterpreter_OLEAUTO}\r\n\r\n{ Used by JvTimeFrameWork, see JvTFDays.pas for more info on time blocks. }\r\n{$DEFINE Jv_TIMEBLOCKS}\r\n\r\n{ This activates the unit versioning system where each JVCL unit gets a record that defines\r\nwhich revision, date and filename the unit has. }\r\n{.$DEFINE UNITVERSIONING}\r\n\r\n// *********************************************************************\r\n// Start Definition of Third Party Components\r\n// *********************************************************************\r\n\r\n{ Activates SM-Export Wrapper Components (in DBActions) \r\nFor further informations have a look at http://www.scalabium.com \r\nATTENTION : \r\nBEFORE YOU ACTIVATE THIS OPTION YOU MUST CHANGE THE\r\nSMEXPORT PACKAGE FROM AUTOMATIC COMPILE NO MANUAL COMPILE }\r\n{.$DEFINE USE_3RDPARTY_SMEXPORT}\r\n\r\n{ Activates SM-Import Wrapper Components (in DBActions)\r\nFor further informations have a look at http://www.scalabium.com\r\nATTENTION :\r\nBEFORE YOU ACTIVATE THIS OPTION YOU MUST CHANGE THE\r\nSMIMPORT PACKAGE FROM AUTOMATIC COMPILE NO MANUAL COMPILE }\r\n{.$DEFINE USE_3RDPARTY_SMIMPORT}\r\n\r\n{ Activates Support for the DevExpress cxEditor-Controls\r\nFor further informations have a look at http://www.devexpress.com \r\nYou have to choose between shared and non shared packages}\r\n{.$DEFINE USE_3RDPARTY_DEVEXPRESS_CXEDITOR_SHARED}\r\n{.$DEFINE USE_3RDPARTY_DEVEXPRESS_CXEDITOR_NON_SHARED}\r\n\r\n{ Activates Support for the DevExpress cxGrid-Controls\r\nFor further informations have a look at http://www.devexpress.com \r\nYou have to choose between shared and non shared packages}\r\n{.$DEFINE USE_3RDPARTY_DEVEXPRESS_CXGRID_SHARED}\r\n{.$DEFINE USE_3RDPARTY_DEVEXPRESS_CXGRID_NON_SHARED}\r\n\r\n{ Activates Support for the DevExpress cxVerticalGrid-Controls\r\nFor further informations have a look at http://www.devexpress.com \r\nYou have to choose between shared and non shared packages}\r\n{.$DEFINE USE_3RDPARTY_DEVEXPRESS_CXVERTICALGRID_SHARED}\r\n{.$DEFINE USE_3RDPARTY_DEVEXPRESS_CXVERTICALGRID_NON_SHARED}\r\n\r\n{ Activates Support for the DevExpress cxPivotGrid-Controls\r\nFor further informations have a look at http://www.devexpress.com \r\nYou have to choose between shared and non shared packages}\r\n{.$DEFINE USE_3RDPARTY_DEVEXPRESS_CXPIVOTGRID_SHARED}\r\n{.$DEFINE USE_3RDPARTY_DEVEXPRESS_CXPIVOTGRID_NON_SHARED}\r\n\r\n{ Activates Support for the DevExpress cxTreeList-Controls\r\nFor further informations have a look at http://www.devexpress.com \r\nYou have to choose between shared and non shared packages}\r\n{.$DEFINE USE_3RDPARTY_DEVEXPRESS_CXTREELIST_SHARED}\r\n{.$DEFINE USE_3RDPARTY_DEVEXPRESS_CXTREELIST_NON_SHARED}\r\n\r\n\r\n{ Activates the Internet Direct (Indy)-Components\r\nFor further informations have a look at http://www.indyproject.org }\r\n{.$DEFINE USE_3RDPARTY_INDY}\r\n\r\n{ Activates the Internet Direct (Indy)-Components version 10.\r\nYou MUST also activate $DEFINE USE_3RDPARTY_INDY for the compilation to work\r\nFor further informations have a look at http://www.indyproject.org }\r\n{.$DEFINE USE_3RDPARTY_INDY10}\r\n\r\n{ Activates Support for the ICS-Components (Internet component suite\r\nFor further informations have a look at http://www.overbyte.be/\r\nATTENTION :\r\nBEFORE YOU ACTIVATE THIS OPTION YOU MUST CHANGE THE\r\nICS* PACKAGE FROM AUTOMATIC COMPILE TO MANUAL COMPILE }\r\n{.$DEFINE USE_3RDPARTY_ICS}\r\n\r\n{ Activates Support for Direct Oracle Access Components\r\nFor further informations have a look at http://www.allroundautomations.com }\r\n{.$DEFINE USE_3RDPARTY_DOA}\r\n\r\n{ Activates Support for the DevArt VCL Oracle Data Access Components\r\nFor further informations have a look at http://www.devart.com }\r\n{.$DEFINE USE_3RDPARTY_DEVART_ODAC}\r\n\r\n{ Activates Support for the DevArt VCL Universal Data Access Components\r\nFor further informations have a look at http://www.devart.com }\r\n{.$DEFINE USE_3RDPARTY_DEVART_UNIDAC}\r\n\r\n\r\n\r\n" }, { "path": "External/Jedi/Jvcl/common/linuxonly.inc", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: LINUXONLY.INC, released on 2004-01-04\r\n\r\nLast Modified: 2004-05-07\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n\r\n// This inc file depends on jedi.inc which has to\r\n// be included first (usually indirectly through\r\n// the inclusion of jvcl.inc).\r\n\r\n// Suppress platform warnings which are irrelevant\r\n// because the including unit can only be compiled\r\n// for the Unixs platforms anyway.\r\n\r\n{$WARN UNIT_PLATFORM OFF}\r\n{$WARN SYMBOL_PLATFORM OFF}\r\n\r\n// Cause a compilation error for non-Unix platforms.\r\n\r\n{$IFNDEF UNIX}\r\n {$IFDEF SUPPORTS_COMPILETIME_MESSAGES}\r\n {$MESSAGE FATAL 'This unit is only supported on Unix!'}\r\n {$ELSE}\r\n 'This unit is only supported on Unix!'\r\n {$ENDIF SUPPORTS_COMPILETIME_MESSAGES}\r\n{$ENDIF !UNIX}" }, { "path": "External/Jedi/Jvcl/common/windowsonly.inc", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: WINDOWSONLY.INC, released on 2002-07-04.\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: windowsonly.inc 12461 2009-08-14 17:21:33Z obones $\r\n\r\n// This inc file depends on jedi.inc which has to\r\n// be included first (usually indirectly through\r\n// the inclusion of jvcl.inc).\r\n\r\n// Suppress platform warnings which are irrelevant\r\n// because the including unit can only be compiled\r\n// for the Windows platform anyway.\r\n\r\n{$IFDEF SUPPORTS_PLATFORM_WARNINGS}\r\n {$WARN UNIT_PLATFORM OFF}\r\n {$WARN SYMBOL_PLATFORM OFF}\r\n{$ENDIF SUPPORTS_PLATFORM_WARNINGS}\r\n\r\n// Cause a compilation error for any platform except Windows.\r\n\r\n{$IFNDEF MSWINDOWS}\r\n {$IFDEF SUPPORTS_COMPILETIME_MESSAGES}\r\n {$MESSAGE FATAL 'This unit is only supported on Windows!'}\r\n {$ELSE}\r\n 'This unit is only supported on Windows!'\r\n {$ENDIF SUPPORTS_COMPILETIME_MESSAGES}\r\n{$ENDIF !MSWINDOWS}" }, { "path": "External/Jedi/Jvcl/common/windowsversion.inc", "content": "{$IFNDEF WINDOWSVERSION_INC}\r\n{$DEFINE WINDOWSVERSION_INC}\r\n\r\n{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: windowsversion.inc, released on 2004-10-28.\r\n\r\nYou may retrieve the latest version of this file at the JCL home page,\r\nlocated at http://jcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n\r\n// Last modified: $Date: 2009-08-14 19:21:33 +0200 (ven. 14 août 2009) $\r\n// For history see end of file\r\n\r\n// This file is intended for C header conversions.\r\n// It defines several mutually exclusive IFDEFs which determine\r\n// the Windows version the API conversion is usable with.\r\n\r\n// Global switch to make UNICODE versions of API functions default\r\n{.DEFINE UNICODE}\r\n\r\n// individual versions including service packs\r\n// ONLY A SINGLE ONE IS ALLOWED TO BE ACTIVATED BY REMOVING THE DOT!\r\n{.$DEFINE WIN95}\r\n{$DEFINE WIN98Gold}\r\n{.$DEFINE WIN98SE}\r\n{.$DEFINE WIN98ME}\r\n{.$DEFINE WINNT35}\r\n{.$DEFINE WINNT351}\r\n{.$DEFINE WINNT4}\r\n{.$DEFINE WINNT4_SP1}\r\n{.$DEFINE WINNT4_SP2}\r\n{.$DEFINE WINNT4_SP3}\r\n{.$DEFINE WINNT4_SP4}\r\n{.$DEFINE WINNT4_SP5}\r\n{.$DEFINE WINNT4_SP6}\r\n{.$DEFINE WIN2000}\r\n{.$DEFINE WIN2000_SP1}\r\n{.$DEFINE WIN2000_SP2}\r\n{.$DEFINE WIN2000_SP3}\r\n{.$DEFINE WIN2000_SP4}\r\n{.$DEFINE WINXP}\r\n{.$DEFINE WINXP_SP1}\r\n{.$DEFINE WINXP_SP2}\r\n{.$DEFINE WIN2003}\r\n{.$DEFINE WINVista}\r\n\r\n// secondary IFDEFs for \"_UP\" which means also any later OS version\r\n\r\n{$IFDEF WINVista} {$DEFINE WINVista_UP} {$ENDIF}\r\n{$IFDEF WIN2003} {$DEFINE WIN2003_UP} {$ENDIF}\r\n{$IFDEF WINXP_SP2} {$DEFINE WINXP_SP2_UP} {$ENDIF}\r\n{$IFDEF WINXP_SP1} {$DEFINE WINXP_SP1_UP} {$ENDIF}\r\n{$IFDEF WINXP} {$DEFINE WINXP_UP} {$ENDIF}\r\n{$IFDEF WIN2000_SP4} {$DEFINE WIN2000_SP4_UP} {$ENDIF}\r\n{$IFDEF WIN2000_SP3} {$DEFINE WIN2000_SP3_UP} {$ENDIF}\r\n{$IFDEF WIN2000_SP2} {$DEFINE WIN2000_SP2_UP} {$ENDIF}\r\n{$IFDEF WIN2000_SP1} {$DEFINE WIN2000_SP1_UP} {$ENDIF}\r\n{$IFDEF WIN2000} {$DEFINE WIN2000_UP} {$ENDIF}\r\n{$IFDEF WINNT4_SP6} {$DEFINE WINNT4_SP6_UP} {$ENDIF}\r\n{$IFDEF WINNT4_SP5} {$DEFINE WINNT4_SP5_UP} {$ENDIF}\r\n{$IFDEF WINNT4_SP4} {$DEFINE WINNT4_SP4_UP} {$ENDIF}\r\n{$IFDEF WINNT4_SP3} {$DEFINE WINNT4_SP3_UP} {$ENDIF}\r\n{$IFDEF WINNT4_SP2} {$DEFINE WINNT4_SP2_UP} {$ENDIF}\r\n{$IFDEF WINNT4_SP1} {$DEFINE WINNT4_SP1_UP} {$ENDIF}\r\n{$IFDEF WINNT4} {$DEFINE WINNT4_UP} {$ENDIF}\r\n{$IFDEF WINNT351} {$DEFINE WINNT351_UP} {$ENDIF}\r\n{$IFDEF WINNT35} {$DEFINE WINNT35_UP} {$ENDIF}\r\n{$IFDEF WIN98Gold} {$DEFINE WIN98Gold_UP} {$ENDIF}\r\n{$IFDEF WIN98ME} {$DEFINE WIN98ME_UP} {$ENDIF}\r\n{$IFDEF WIN98SE} {$DEFINE WIN98SE_UP} {$ENDIF}\r\n{$IFDEF WIN98} {$DEFINE WIN98_UP} {$ENDIF}\r\n{$IFDEF WIN95} {$DEFINE WIN95_UP} {$ENDIF}\r\n\r\n// implicit IFDEFs for \"_UP\" based on initial \"_UP\" defines\r\n\r\n{$IFDEF WINVista_UP} {$DEFINE WIN2003_UP} {$ENDIF}\r\n{$IFDEF WIN2003_UP} {$DEFINE WINXP_SP2_UP} {$ENDIF}\r\n{$IFDEF WINXP_SP2_UP} {$DEFINE WINXP_SP1_UP} {$ENDIF}\r\n{$IFDEF WINXP_SP1_UP} {$DEFINE WINXP_UP} {$ENDIF}\r\n{$IFDEF WINXP_UP} {$DEFINE WIN2000_SP4_UP} {$ENDIF}\r\n{$IFDEF WIN2000_SP4_UP} {$DEFINE WIN2000_SP3_UP} {$ENDIF}\r\n{$IFDEF WIN2000_SP3_UP} {$DEFINE WIN2000_SP2_UP} {$ENDIF}\r\n{$IFDEF WIN2000_SP2_UP} {$DEFINE WIN2000_SP1_UP} {$ENDIF}\r\n{$IFDEF WIN2000_SP1_UP} {$DEFINE WIN2000_UP} {$ENDIF}\r\n{$IFDEF WIN2000_UP} {$DEFINE WINNT4_SP6_UP} {$ENDIF}\r\n{$IFDEF WINNT4_SP6_UP} {$DEFINE WINNT4_SP5_UP} {$ENDIF}\r\n{$IFDEF WINNT4_SP5_UP} {$DEFINE WINNT4_SP4_UP} {$ENDIF}\r\n{$IFDEF WINNT4_SP4_UP} {$DEFINE WINNT4_SP3_UP} {$ENDIF}\r\n{$IFDEF WINNT4_SP3_UP} {$DEFINE WINNT4_SP2_UP} {$ENDIF}\r\n{$IFDEF WINNT4_SP2_UP} {$DEFINE WINNT4_SP1_UP} {$ENDIF}\r\n{$IFDEF WINNT4_SP1_UP} {$DEFINE WINNT4_UP} {$ENDIF}\r\n{$IFDEF WINNT4_UP} {$DEFINE WINNT351_UP} {$ENDIF}\r\n{$IFDEF WINNT351_UP} {$DEFINE WINNT35_UP} {$ENDIF}\r\n{$IFDEF WINNT35_UP} {$DEFINE WINNT_UP} {$ENDIF}\r\n{$IFDEF WINNT_UP} {$DEFINE WIN98Gold_UP} {$ENDIF}\r\n{$IFDEF WIN98Gold_UP} {$DEFINE WIN98ME_UP} {$ENDIF}\r\n{$IFDEF WIN98ME_UP} {$DEFINE WIN98SE_UP} {$ENDIF}\r\n{$IFDEF WIN98SE_UP} {$DEFINE WIN98_UP} {$ENDIF}\r\n{$IFDEF WIN98_UP} {$DEFINE WIN95_UP} {$ENDIF}\r\n\r\n// History:\r\n\r\n// $Log$\r\n// Revision 1.3 2006/02/11 16:50:17 marquardt\r\n// another fix to SetupApi.pas, windowsversion.inc defaults to Win98\r\n//\r\n// Revision 1.2 2005/08/28 15:23:33 obones\r\n// Added missing $\r\n//\r\n// Revision 1.1 2004/11/07 20:36:05 marquardt\r\n// Config Manager and Setup API conversions\r\n//\r\n\r\n{$ENDIF ~WINDOWSVERSION_INC}\r\n" }, { "path": "External/Jedi/Jvcl/resources/resources.txt", "content": "" }, { "path": "External/Jedi/Jvcl/run/Cfg.pas", "content": "{******************************************************************}\r\n{ }\r\n{ Borland Delphi Runtime Library }\r\n{ Config Manager API interface unit }\r\n{ }\r\n{ Portions created by Microsoft are }\r\n{ Copyright (c) Microsoft Corporation. All rights reserved. }\r\n{ }\r\n{ The original file is: cfg.h, released August 2001. }\r\n{ The original Pascal code is: Cfg.pas, released 5 Nov 2004. }\r\n{ The initial developer of the Pascal code is Robert Marquardt }\r\n{ (robert_marquardt att gmx dott de) }\r\n{ }\r\n{ Portions created by Robert Marquardt are }\r\n{ Copyright (C) 2004 Robert Marquardt. }\r\n{ }\r\n{ Contributor(s): }\r\n{ }\r\n{ Obtained through: }\r\n{ Joint Endeavour of Delphi Innovators (Project JEDI) }\r\n{ }\r\n{ You may retrieve the latest version of this file at the Project }\r\n{ JEDI home page, located at http://delphi-jedi.org }\r\n{ }\r\n{ The contents of this file are used with permission, subject to }\r\n{ the Mozilla Public License Version 1.1 (the \"License\"); you may }\r\n{ not use this file except in compliance with the License. You may }\r\n{ obtain a copy of the License at }\r\n{ http://www.mozilla.org/MPL/MPL-1.1.html }\r\n{ }\r\n{ Software distributed under the License is distributed on an }\r\n{ \"AS IS\" basis, WITHOUT WARRANTY OF ANY KIND, either express or }\r\n{ implied. See the License for the specific language governing }\r\n{ rights and limitations under the License. }\r\n{ }\r\n{******************************************************************}\r\n\r\nunit Cfg;\r\n\r\ninterface\r\n\r\nuses\r\n Windows;\r\n\r\n{$WEAKPACKAGEUNIT ON}\r\n\r\n{$HPPEMIT '#include \"cfg.h\"'}\r\n\r\n//\r\n// The following definitions are also used by kernel mode code to\r\n// set up the registry.\r\n//\r\n//\r\n// VetoType used in\r\n// CM_Disable_DevNode\r\n// CM_Uninstall_DevNode\r\n// CM_Query_And_Remove_SubTree\r\n//\r\nconst\r\n PNP_VetoTypeUnknown = 0; // Name is unspecified\r\n {$EXTERNALSYM PNP_VetoTypeUnknown}\r\n PNP_VetoLegacyDevice = 1; // Name is an Instance Path\r\n {$EXTERNALSYM PNP_VetoLegacyDevice}\r\n PNP_VetoPendingClose = 2; // Name is an Instance Path\r\n {$EXTERNALSYM PNP_VetoPendingClose}\r\n PNP_VetoWindowsApp = 3; // Name is a Module\r\n {$EXTERNALSYM PNP_VetoWindowsApp}\r\n PNP_VetoWindowsService = 4; // Name is a Service\r\n {$EXTERNALSYM PNP_VetoWindowsService}\r\n PNP_VetoOutstandingOpen = 5; // Name is an Instance Path\r\n {$EXTERNALSYM PNP_VetoOutstandingOpen}\r\n PNP_VetoDevice = 6; // Name is an Instance Path\r\n {$EXTERNALSYM PNP_VetoDevice}\r\n PNP_VetoDriver = 7; // Name is a Driver Service Name\r\n {$EXTERNALSYM PNP_VetoDriver}\r\n PNP_VetoIllegalDeviceRequest = 8; // Name is an Instance Path\r\n {$EXTERNALSYM PNP_VetoIllegalDeviceRequest}\r\n PNP_VetoInsufficientPower = 9; // Name is unspecified\r\n {$EXTERNALSYM PNP_VetoInsufficientPower}\r\n PNP_VetoNonDisableable = 10; // Name is an Instance Path\r\n {$EXTERNALSYM PNP_VetoNonDisableable}\r\n PNP_VetoLegacyDriver = 11; // Name is a Service\r\n {$EXTERNALSYM PNP_VetoLegacyDriver}\r\n PNP_VetoInsufficientRights = 12; // Name is unspecified\r\n {$EXTERNALSYM PNP_VetoInsufficientRights}\r\ntype\r\n PPNP_VETO_TYPE = ^PNP_VETO_TYPE;\r\n {$EXTERNALSYM PPNP_VETO_TYPE}\r\n PNP_VETO_TYPE = DWORD;\r\n {$EXTERNALSYM PNP_VETO_TYPE}\r\n\r\nconst\r\n //\r\n // DevInst problem values, returned by call to CM_Get_DevInst_Status\r\n //\r\n CM_PROB_NOT_CONFIGURED = $00000001; // no config for device\r\n {$EXTERNALSYM CM_PROB_NOT_CONFIGURED}\r\n CM_PROB_DEVLOADER_FAILED = $00000002; // service load failed\r\n {$EXTERNALSYM CM_PROB_DEVLOADER_FAILED}\r\n CM_PROB_OUT_OF_MEMORY = $00000003; // out of memory\r\n {$EXTERNALSYM CM_PROB_OUT_OF_MEMORY}\r\n CM_PROB_ENTRY_IS_WRONG_TYPE = $00000004; //\r\n {$EXTERNALSYM CM_PROB_ENTRY_IS_WRONG_TYPE}\r\n CM_PROB_LACKED_ARBITRATOR = $00000005; //\r\n {$EXTERNALSYM CM_PROB_LACKED_ARBITRATOR}\r\n CM_PROB_BOOT_CONFIG_CONFLICT = $00000006; // boot config conflict\r\n {$EXTERNALSYM CM_PROB_BOOT_CONFIG_CONFLICT}\r\n CM_PROB_FAILED_FILTER = $00000007; //\r\n {$EXTERNALSYM CM_PROB_FAILED_FILTER}\r\n CM_PROB_DEVLOADER_NOT_FOUND = $00000008; // Devloader not found\r\n {$EXTERNALSYM CM_PROB_DEVLOADER_NOT_FOUND}\r\n CM_PROB_INVALID_DATA = $00000009; //\r\n {$EXTERNALSYM CM_PROB_INVALID_DATA}\r\n CM_PROB_FAILED_START = $0000000A; //\r\n {$EXTERNALSYM CM_PROB_FAILED_START}\r\n CM_PROB_LIAR = $0000000B; //\r\n {$EXTERNALSYM CM_PROB_LIAR}\r\n CM_PROB_NORMAL_CONFLICT = $0000000C; // config conflict\r\n {$EXTERNALSYM CM_PROB_NORMAL_CONFLICT}\r\n CM_PROB_NOT_VERIFIED = $0000000D; //\r\n {$EXTERNALSYM CM_PROB_NOT_VERIFIED}\r\n CM_PROB_NEED_RESTART = $0000000E; // requires restart\r\n {$EXTERNALSYM CM_PROB_NEED_RESTART}\r\n CM_PROB_REENUMERATION = $0000000F; //\r\n {$EXTERNALSYM CM_PROB_REENUMERATION}\r\n CM_PROB_PARTIAL_LOG_CONF = $00000010; //\r\n {$EXTERNALSYM CM_PROB_PARTIAL_LOG_CONF}\r\n CM_PROB_UNKNOWN_RESOURCE = $00000011; // unknown res type\r\n {$EXTERNALSYM CM_PROB_UNKNOWN_RESOURCE}\r\n CM_PROB_REINSTALL = $00000012; //\r\n {$EXTERNALSYM CM_PROB_REINSTALL}\r\n CM_PROB_REGISTRY = $00000013; //\r\n {$EXTERNALSYM CM_PROB_REGISTRY}\r\n CM_PROB_VXDLDR = $00000014; // WINDOWS 95 ONLY\r\n {$EXTERNALSYM CM_PROB_VXDLDR}\r\n CM_PROB_WILL_BE_REMOVED = $00000015; // devinst will remove\r\n {$EXTERNALSYM CM_PROB_WILL_BE_REMOVED}\r\n CM_PROB_DISABLED = $00000016; // devinst is disabled\r\n {$EXTERNALSYM CM_PROB_DISABLED}\r\n CM_PROB_DEVLOADER_NOT_READY = $00000017; // Devloader not ready\r\n {$EXTERNALSYM CM_PROB_DEVLOADER_NOT_READY}\r\n CM_PROB_DEVICE_NOT_THERE = $00000018; // device doesn't exist\r\n {$EXTERNALSYM CM_PROB_DEVICE_NOT_THERE}\r\n CM_PROB_MOVED = $00000019; //\r\n {$EXTERNALSYM CM_PROB_MOVED}\r\n CM_PROB_TOO_EARLY = $0000001A; //\r\n {$EXTERNALSYM CM_PROB_TOO_EARLY}\r\n CM_PROB_NO_VALID_LOG_CONF = $0000001B; // no valid log config\r\n {$EXTERNALSYM CM_PROB_NO_VALID_LOG_CONF}\r\n CM_PROB_FAILED_INSTALL = $0000001C; // install failed\r\n {$EXTERNALSYM CM_PROB_FAILED_INSTALL}\r\n CM_PROB_HARDWARE_DISABLED = $0000001D; // device disabled\r\n {$EXTERNALSYM CM_PROB_HARDWARE_DISABLED}\r\n CM_PROB_CANT_SHARE_IRQ = $0000001E; // can't share IRQ\r\n {$EXTERNALSYM CM_PROB_CANT_SHARE_IRQ}\r\n CM_PROB_FAILED_ADD = $0000001F; // driver failed add\r\n {$EXTERNALSYM CM_PROB_FAILED_ADD}\r\n CM_PROB_DISABLED_SERVICE = $00000020; // service's Start = 4\r\n {$EXTERNALSYM CM_PROB_DISABLED_SERVICE}\r\n CM_PROB_TRANSLATION_FAILED = $00000021; // resource translation failed\r\n {$EXTERNALSYM CM_PROB_TRANSLATION_FAILED}\r\n CM_PROB_NO_SOFTCONFIG = $00000022; // no soft config\r\n {$EXTERNALSYM CM_PROB_NO_SOFTCONFIG}\r\n CM_PROB_BIOS_TABLE = $00000023; // device missing in BIOS table\r\n {$EXTERNALSYM CM_PROB_BIOS_TABLE}\r\n CM_PROB_IRQ_TRANSLATION_FAILED = $00000024; // IRQ translator failed\r\n {$EXTERNALSYM CM_PROB_IRQ_TRANSLATION_FAILED}\r\n CM_PROB_FAILED_DRIVER_ENTRY = $00000025; // DriverEntry() failed.\r\n {$EXTERNALSYM CM_PROB_FAILED_DRIVER_ENTRY}\r\n CM_PROB_DRIVER_FAILED_PRIOR_UNLOAD = $00000026; // Driver should have unloaded.\r\n {$EXTERNALSYM CM_PROB_DRIVER_FAILED_PRIOR_UNLOAD}\r\n CM_PROB_DRIVER_FAILED_LOAD = $00000027; // Driver load unsuccessful.\r\n {$EXTERNALSYM CM_PROB_DRIVER_FAILED_LOAD}\r\n CM_PROB_DRIVER_SERVICE_KEY_INVALID = $00000028; // Error accessing driver's service key\r\n {$EXTERNALSYM CM_PROB_DRIVER_SERVICE_KEY_INVALID}\r\n CM_PROB_LEGACY_SERVICE_NO_DEVICES = $00000029; // Loaded legacy service created no devices\r\n {$EXTERNALSYM CM_PROB_LEGACY_SERVICE_NO_DEVICES}\r\n CM_PROB_DUPLICATE_DEVICE = $0000002A; // Two devices were discovered with the same name\r\n {$EXTERNALSYM CM_PROB_DUPLICATE_DEVICE}\r\n CM_PROB_FAILED_POST_START = $0000002B; // The drivers set the device state to failed\r\n {$EXTERNALSYM CM_PROB_FAILED_POST_START}\r\n CM_PROB_HALTED = $0000002C; // This device was failed post start via usermode\r\n {$EXTERNALSYM CM_PROB_HALTED}\r\n CM_PROB_PHANTOM = $0000002D; // The devinst currently exists only in the registry\r\n {$EXTERNALSYM CM_PROB_PHANTOM}\r\n CM_PROB_SYSTEM_SHUTDOWN = $0000002E; // The system is shutting down\r\n {$EXTERNALSYM CM_PROB_SYSTEM_SHUTDOWN}\r\n CM_PROB_HELD_FOR_EJECT = $0000002F; // The device is offline awaiting removal\r\n {$EXTERNALSYM CM_PROB_HELD_FOR_EJECT}\r\n CM_PROB_DRIVER_BLOCKED = $00000030; // One or more drivers is blocked from loading\r\n {$EXTERNALSYM CM_PROB_DRIVER_BLOCKED}\r\n CM_PROB_REGISTRY_TOO_LARGE = $00000031; // System hive has grown too large\r\n {$EXTERNALSYM CM_PROB_REGISTRY_TOO_LARGE}\r\n NUM_CM_PROB = $00000032;\r\n {$EXTERNALSYM NUM_CM_PROB}\r\n\r\n //\r\n // Configuration Manager Global State Flags (returned by CM_Get_Global_State)\r\n //\r\n CM_GLOBAL_STATE_CAN_DO_UI = $00000001; // Can do UI?\r\n {$EXTERNALSYM CM_GLOBAL_STATE_CAN_DO_UI}\r\n CM_GLOBAL_STATE_ON_BIG_STACK = $00000002; // WINDOWS 95 ONLY\r\n {$EXTERNALSYM CM_GLOBAL_STATE_ON_BIG_STACK}\r\n CM_GLOBAL_STATE_SERVICES_AVAILABLE = $00000004; // CM APIs available?\r\n {$EXTERNALSYM CM_GLOBAL_STATE_SERVICES_AVAILABLE}\r\n CM_GLOBAL_STATE_SHUTTING_DOWN = $00000008; // CM shutting down\r\n {$EXTERNALSYM CM_GLOBAL_STATE_SHUTTING_DOWN}\r\n CM_GLOBAL_STATE_DETECTION_PENDING = $00000010; // detection pending\r\n {$EXTERNALSYM CM_GLOBAL_STATE_DETECTION_PENDING}\r\n\r\n //\r\n // Device Instance status flags, returned by call to CM_Get_DevInst_Status\r\n //\r\n DN_ROOT_ENUMERATED = $00000001; // Was enumerated by ROOT\r\n {$EXTERNALSYM DN_ROOT_ENUMERATED}\r\n DN_DRIVER_LOADED = $00000002; // Has Register_Device_Driver\r\n {$EXTERNALSYM DN_DRIVER_LOADED}\r\n DN_ENUM_LOADED = $00000004; // Has Register_Enumerator\r\n {$EXTERNALSYM DN_ENUM_LOADED}\r\n DN_STARTED = $00000008; // Is currently configured\r\n {$EXTERNALSYM DN_STARTED}\r\n DN_MANUAL = $00000010; // Manually installed\r\n {$EXTERNALSYM DN_MANUAL}\r\n DN_NEED_TO_ENUM = $00000020; // May need reenumeration\r\n {$EXTERNALSYM DN_NEED_TO_ENUM}\r\n DN_NOT_FIRST_TIME = $00000040; // Has received a config\r\n {$EXTERNALSYM DN_NOT_FIRST_TIME}\r\n DN_HARDWARE_ENUM = $00000080; // Enum generates hardware ID\r\n {$EXTERNALSYM DN_HARDWARE_ENUM}\r\n DN_LIAR = $00000100; // Lied about can reconfig once\r\n {$EXTERNALSYM DN_LIAR}\r\n DN_HAS_MARK = $00000200; // Not CM_Create_DevInst lately\r\n {$EXTERNALSYM DN_HAS_MARK}\r\n DN_HAS_PROBLEM = $00000400; // Need device installer\r\n {$EXTERNALSYM DN_HAS_PROBLEM}\r\n DN_FILTERED = $00000800; // Is filtered\r\n {$EXTERNALSYM DN_FILTERED}\r\n DN_MOVED = $00001000; // Has been moved\r\n {$EXTERNALSYM DN_MOVED}\r\n DN_DISABLEABLE = $00002000; // Can be rebalanced\r\n {$EXTERNALSYM DN_DISABLEABLE}\r\n DN_REMOVABLE = $00004000; // Can be removed\r\n {$EXTERNALSYM DN_REMOVABLE}\r\n DN_PRIVATE_PROBLEM = $00008000; // Has a private problem\r\n {$EXTERNALSYM DN_PRIVATE_PROBLEM}\r\n DN_MF_PARENT = $00010000; // Multi function parent\r\n {$EXTERNALSYM DN_MF_PARENT}\r\n DN_MF_CHILD = $00020000; // Multi function child\r\n {$EXTERNALSYM DN_MF_CHILD}\r\n DN_WILL_BE_REMOVED = $00040000; // DevInst is being removed\r\n {$EXTERNALSYM DN_WILL_BE_REMOVED}\r\n\r\n //\r\n // Windows 4 OPK2 Flags\r\n //\r\n DN_NOT_FIRST_TIMEE = $00080000; // S: Has received a config enumerate\r\n {$EXTERNALSYM DN_NOT_FIRST_TIMEE}\r\n DN_STOP_FREE_RES = $00100000; // S: When child is stopped, free resources\r\n {$EXTERNALSYM DN_STOP_FREE_RES}\r\n DN_REBAL_CANDIDATE = $00200000; // S: Don't skip during rebalance\r\n {$EXTERNALSYM DN_REBAL_CANDIDATE}\r\n DN_BAD_PARTIAL = $00400000; // S: This devnode's log_confs do not have same resources\r\n {$EXTERNALSYM DN_BAD_PARTIAL}\r\n DN_NT_ENUMERATOR = $00800000; // S: This devnode's is an NT enumerator\r\n {$EXTERNALSYM DN_NT_ENUMERATOR}\r\n DN_NT_DRIVER = $01000000; // S: This devnode's is an NT driver\r\n {$EXTERNALSYM DN_NT_DRIVER}\r\n //\r\n // Windows 4.1 Flags\r\n //\r\n DN_NEEDS_LOCKING = $02000000; // S: Devnode need lock resume processing\r\n {$EXTERNALSYM DN_NEEDS_LOCKING}\r\n DN_ARM_WAKEUP = $04000000; // S: Devnode can be the wakeup device\r\n {$EXTERNALSYM DN_ARM_WAKEUP}\r\n DN_APM_ENUMERATOR = $08000000; // S: APM aware enumerator\r\n {$EXTERNALSYM DN_APM_ENUMERATOR}\r\n DN_APM_DRIVER = $10000000; // S: APM aware driver\r\n {$EXTERNALSYM DN_APM_DRIVER}\r\n DN_SILENT_INSTALL = $20000000; // S: Silent install\r\n {$EXTERNALSYM DN_SILENT_INSTALL}\r\n DN_NO_SHOW_IN_DM = $40000000; // S: No show in device manager\r\n {$EXTERNALSYM DN_NO_SHOW_IN_DM}\r\n DN_BOOT_LOG_PROB = $80000000; // S: Had a problem during preassignment of boot log conf\r\n {$EXTERNALSYM DN_BOOT_LOG_PROB}\r\n\r\n //\r\n // Windows NT Flags\r\n //\r\n // These are overloaded on top of unused Win 9X flags\r\n //\r\n //DN_LIAR = $00000100; // Lied about can reconfig once\r\n DN_NEED_RESTART = DN_LIAR; // System needs to be restarted for this Devnode to work properly\r\n {$EXTERNALSYM DN_NEED_RESTART}\r\n //DN_NOT_FIRST_TIME = $00000040; // Has Register_Enumerator\r\n DN_DRIVER_BLOCKED = DN_NOT_FIRST_TIME; // One or more drivers are blocked from loading for this Devnode\r\n {$EXTERNALSYM DN_DRIVER_BLOCKED}\r\n //DN_MOVED = $00001000; // Has been moved\r\n DN_LEGACY_DRIVER = DN_MOVED; // This device is using a legacy driver\r\n {$EXTERNALSYM DN_LEGACY_DRIVER}\r\n\r\n DN_CHANGEABLE_FLAGS = DWORD(DN_NOT_FIRST_TIME +\r\n DN_HARDWARE_ENUM + DN_HAS_MARK + DN_DISABLEABLE +\r\n DN_REMOVABLE + DN_MF_CHILD + DN_MF_PARENT +\r\n DN_NOT_FIRST_TIMEE + DN_STOP_FREE_RES + DN_REBAL_CANDIDATE +\r\n DN_NT_ENUMERATOR + DN_NT_DRIVER + DN_SILENT_INSTALL + DN_NO_SHOW_IN_DM);\r\n {$EXTERNALSYM DN_CHANGEABLE_FLAGS}\r\n\r\n //\r\n // Logical configuration Priority values\r\n //\r\n // These priority values are used in user-mode calls to CM_Add_Empty_Log_Conf.\r\n // Drivers may also specify priority values for a given IO_RESOURCE_LIST\r\n // structure by including a ConfigData member union as the first\r\n // IO_RESOURCE_DESCRIPTOR in the IO_RESOURCE_LIST. In this case, the descriptor\r\n // type would be CmResourceTypeConfigData.\r\n //\r\n LCPRI_FORCECONFIG = $00000000; // Coming from a forced config\r\n {$EXTERNALSYM LCPRI_FORCECONFIG}\r\n LCPRI_BOOTCONFIG = $00000001; // Coming from a boot config\r\n {$EXTERNALSYM LCPRI_BOOTCONFIG}\r\n LCPRI_DESIRED = $00002000; // Preferable (better performance)\r\n {$EXTERNALSYM LCPRI_DESIRED}\r\n LCPRI_NORMAL = $00003000; // Workable (acceptable performance)\r\n {$EXTERNALSYM LCPRI_NORMAL}\r\n LCPRI_LASTBESTCONFIG = $00003FFF; // CM only--do not use\r\n {$EXTERNALSYM LCPRI_LASTBESTCONFIG}\r\n LCPRI_SUBOPTIMAL = $00005000; // Not desired, but will work\r\n {$EXTERNALSYM LCPRI_SUBOPTIMAL}\r\n LCPRI_LASTSOFTCONFIG = $00007FFF; // CM only--do not use\r\n {$EXTERNALSYM LCPRI_LASTSOFTCONFIG}\r\n LCPRI_RESTART = $00008000; // Need to restart\r\n {$EXTERNALSYM LCPRI_RESTART}\r\n LCPRI_REBOOT = $00009000; // Need to reboot\r\n {$EXTERNALSYM LCPRI_REBOOT}\r\n LCPRI_POWEROFF = $0000A000; // Need to shutdown/power-off\r\n {$EXTERNALSYM LCPRI_POWEROFF}\r\n LCPRI_HARDRECONFIG = $0000C000; // Need to change a jumper\r\n {$EXTERNALSYM LCPRI_HARDRECONFIG}\r\n LCPRI_HARDWIRED = $0000E000; // Cannot be changed\r\n {$EXTERNALSYM LCPRI_HARDWIRED}\r\n LCPRI_IMPOSSIBLE = $0000F000; // Impossible configuration\r\n {$EXTERNALSYM LCPRI_IMPOSSIBLE}\r\n LCPRI_DISABLED = $0000FFFF; // Disabled configuration\r\n {$EXTERNALSYM LCPRI_DISABLED}\r\n MAX_LCPRI = $0000FFFF; // Maximum known LC Priority\r\n {$EXTERNALSYM MAX_LCPRI}\r\n\r\nimplementation\r\n\r\nend.\r\n\r\n" }, { "path": "External/Jedi/Jvcl/run/CfgMgr32.pas", "content": "{******************************************************************}\r\n{ }\r\n{ Borland Delphi Runtime Library }\r\n{ Config Manager API interface unit }\r\n{ }\r\n{ Portions created by Microsoft are }\r\n{ Copyright (c) Microsoft Corporation. All rights reserved. }\r\n{ }\r\n{ The original file is: cfgmgr32.h, released August 2001. }\r\n{ The original Pascal code is: CfgMgr32.pas, released 5 Nov 2004. }\r\n{ The initial developer of the Pascal code is Robert Marquardt }\r\n{ (robert_marquardt att gmx dott de) }\r\n{ }\r\n{ Portions created by Robert Marquardt are }\r\n{ Copyright (C) 2004 Robert Marquardt. }\r\n{ }\r\n{ Contributor(s): }\r\n{ }\r\n{ Obtained through: }\r\n{ Joint Endeavour of Delphi Innovators (Project JEDI) }\r\n{ }\r\n{ You may retrieve the latest version of this file at the Project }\r\n{ JEDI home page, located at http://delphi-jedi.org }\r\n{ }\r\n{ The contents of this file are used with permission, subject to }\r\n{ the Mozilla Public License Version 1.1 (the \"License\"); you may }\r\n{ not use this file except in compliance with the License. You may }\r\n{ obtain a copy of the License at }\r\n{ http://www.mozilla.org/MPL/MPL-1.1.html }\r\n{ }\r\n{ Software distributed under the License is distributed on an }\r\n{ \"AS IS\" basis, WITHOUT WARRANTY OF ANY KIND, either express or }\r\n{ implied. See the License for the specific language governing }\r\n{ rights and limitations under the License. }\r\n{ }\r\n{******************************************************************}\r\n\r\nunit CfgMgr32;\r\n\r\n{$I windowsversion.inc}\r\n\r\ninterface\r\n\r\nuses\r\n Windows,\r\n Cfg, WinConvTypes;\r\n\r\n{$WEAKPACKAGEUNIT ON}\r\n\r\n// (rom) this is the switch to change between static and dynamic linking.\r\n// (rom) it is enabled by default here.\r\n// (rom) To disable simply change the '$' to a '.'.\r\n{$DEFINE CFGMGR32_LINKONREQUEST}\r\n\r\n{$HPPEMIT '#include \"cfgmgr32.h\"'}\r\n\r\n//--------------------------------------------------------------\r\n// General size definitions\r\n//--------------------------------------------------------------\r\n\r\nconst\r\n MAX_DEVICE_ID_LEN = 200;\r\n {$EXTERNALSYM MAX_DEVICE_ID_LEN}\r\n MAX_DEVNODE_ID_LEN = MAX_DEVICE_ID_LEN;\r\n {$EXTERNALSYM MAX_DEVNODE_ID_LEN}\r\n\r\n MAX_GUID_STRING_LEN = 39; // 38 chars + terminator null\r\n {$EXTERNALSYM MAX_GUID_STRING_LEN}\r\n MAX_CLASS_NAME_LEN = 32;\r\n {$EXTERNALSYM MAX_CLASS_NAME_LEN}\r\n MAX_PROFILE_LEN = 80;\r\n {$EXTERNALSYM MAX_PROFILE_LEN}\r\n\r\n MAX_CONFIG_VALUE = 9999;\r\n {$EXTERNALSYM MAX_CONFIG_VALUE}\r\n MAX_INSTANCE_VALUE = 9999;\r\n {$EXTERNALSYM MAX_INSTANCE_VALUE}\r\n\r\n MAX_MEM_REGISTERS = 9; // Win95 compatibility--not applicable to 32-bit ConfigMgr\r\n {$EXTERNALSYM MAX_MEM_REGISTERS}\r\n MAX_IO_PORTS = 20; // Win95 compatibility--not applicable to 32-bit ConfigMgr\r\n {$EXTERNALSYM MAX_IO_PORTS}\r\n MAX_IRQS = 7; // Win95 compatibility--not applicable to 32-bit ConfigMgr\r\n {$EXTERNALSYM MAX_IRQS}\r\n MAX_DMA_CHANNELS = 7; // Win95 compatibility--not applicable to 32-bit ConfigMgr\r\n {$EXTERNALSYM MAX_DMA_CHANNELS}\r\n\r\n DWORD_MAX = $FFFFFFFF;\r\n {$EXTERNALSYM DWORD_MAX}\r\n DWORDLONG_MAX = $FFFFFFFFFFFFFFFF;\r\n {$EXTERNALSYM DWORDLONG_MAX}\r\n\r\n CONFIGMG_VERSION = $0400;\r\n {$EXTERNALSYM CONFIGMG_VERSION}\r\n\r\ntype\r\n PDWORDLONG = ^DWORDLONG;\r\n {$EXTERNALSYM PDWORDLONG}\r\n DWORDLONG = Int64; // (rom) no unsigned Int64 available in Delphi\r\n {$EXTERNALSYM DWORDLONG}\r\n\r\n//--------------------------------------------------------------\r\n// Data types\r\n//--------------------------------------------------------------\r\n\r\n //\r\n // Standardized Return Value data type\r\n //\r\n RETURN_TYPE = DWORD;\r\n {$EXTERNALSYM RETURN_TYPE}\r\n CONFIGRET = RETURN_TYPE;\r\n {$EXTERNALSYM CONFIGRET}\r\n\r\n //\r\n // Device Instance Handle data type\r\n //\r\n PDEVNODE = ^DEVNODE;\r\n {$EXTERNALSYM PDEVNODE}\r\n DEVNODE = DWORD;\r\n {$EXTERNALSYM DEVNODE}\r\n PDEVINST = ^DEVINST;\r\n {$EXTERNALSYM PDEVINST}\r\n DEVINST = DWORD;\r\n {$EXTERNALSYM DEVINST}\r\n\r\n //\r\n // Device Instance Identifier data type\r\n // The device instance ID specifies the registry path, relative to the\r\n // Enum key , for a device instance. For example: \\Root\\*PNP0500\\0000.\r\n //\r\n DEVNODEID_A = PAnsiChar; // Device ID ANSI name.\r\n {$EXTERNALSYM DEVNODEID_A}\r\n DEVNODEID_W = PWideChar; // Device ID Unicode name.\r\n {$EXTERNALSYM DEVNODEID_W}\r\n DEVINSTID_A = PAnsiChar; // Device ID ANSI name.\r\n {$EXTERNALSYM DEVINSTID_A}\r\n DEVINSTID_W = PWideChar; // Device ID Unicode name.\r\n {$EXTERNALSYM DEVINSTID_W}\r\n {$IFDEF UNICODE}\r\n DEVNODEID = DEVNODEID_W;\r\n DEVINSTID = DEVINSTID_W;\r\n {$ELSE}\r\n DEVNODEID = DEVNODEID_A;\r\n DEVINSTID = DEVINSTID_A;\r\n {$ENDIF UNICODE}\r\n {$EXTERNALSYM DEVNODEID}\r\n {$EXTERNALSYM DEVINSTID}\r\n\r\n //\r\n // Logical Configuration Handle data type\r\n //\r\n LOG_CONF = DWORD_PTR;\r\n {$EXTERNALSYM LOG_CONF}\r\n PLOG_CONF = ^LOG_CONF;\r\n {$EXTERNALSYM PLOG_CONF}\r\n\r\n //\r\n // Resource Descriptor Handle data type\r\n //\r\n RES_DES = DWORD_PTR;\r\n {$EXTERNALSYM RES_DES}\r\n PRES_DES = ^RES_DES;\r\n {$EXTERNALSYM PRES_DES}\r\n\r\n //\r\n // Resource ID data type (may take any of the ResType_* values)\r\n //\r\n RESOURCEID = ULONG;\r\n {$EXTERNALSYM RESOURCEID}\r\n PRESOURCEID = ^RESOURCEID;\r\n {$EXTERNALSYM PRESOURCEID}\r\n\r\n //\r\n // Priority data type (may take any of the LCPRI_* values)\r\n //\r\n PRIORITY = ULONG;\r\n {$EXTERNALSYM PRIORITY}\r\n PPRIORITY = ^PRIORITY;\r\n {$EXTERNALSYM PPRIORITY}\r\n\r\n //\r\n // Range List Handle data type\r\n //\r\n RANGE_LIST = DWORD_PTR;\r\n {$EXTERNALSYM RANGE_LIST}\r\n PRANGE_LIST = ^RANGE_LIST;\r\n {$EXTERNALSYM PRANGE_LIST}\r\n\r\n //\r\n // Range Element Handle data type\r\n //\r\n RANGE_ELEMENT = DWORD_PTR;\r\n {$EXTERNALSYM RANGE_ELEMENT}\r\n PRANGE_ELEMENT = ^RANGE_ELEMENT;\r\n {$EXTERNALSYM PRANGE_ELEMENT}\r\n\r\n //\r\n // Machine Handle data type\r\n //\r\n HMACHINE = THandle;\r\n {$EXTERNALSYM HMACHINE}\r\n PHMACHINE = ^HMACHINE;\r\n {$EXTERNALSYM PHMACHINE}\r\n\r\n //\r\n // Conflict List data types\r\n //\r\n CONFLICT_LIST = ULONG_PTR;\r\n {$EXTERNALSYM CONFLICT_LIST}\r\n PCONFLICT_LIST = ^CONFLICT_LIST;\r\n {$EXTERNALSYM PCONFLICT_LIST}\r\n\r\n PCONFLICT_DETAILS_A = ^CONFLICT_DETAILS_A;\r\n {$EXTERNALSYM PCONFLICT_DETAILS_A}\r\n CONFLICT_DETAILS_A = packed record\r\n CD_ulSize: ULONG; // size of structure, ie: sizeof(CONFLICT_DETAILS)\r\n CD_ulMask: ULONG; // indicates what information is required/valid\r\n CD_dnDevInst: DEVINST; // filled with DevInst of conflicting device if CM_CDMASK_DEVINST set\r\n CD_rdResDes: RES_DES; // filled with a ResDes of conflict if CM_CDMASK_RESDES set\r\n CD_ulFlags: ULONG; // various flags regarding conflict\r\n CD_szDescription: array [0..MAX_PATH-1] of Char; // description of conflicting device\r\n end;\r\n {$EXTERNALSYM CONFLICT_DETAILS_A}\r\n\r\n PCONFLICT_DETAILS_W = ^CONFLICT_DETAILS_W;\r\n {$EXTERNALSYM PCONFLICT_DETAILS_W}\r\n CONFLICT_DETAILS_W = packed record\r\n CD_ulSize: ULONG; // size of structure, ie: sizeof(CONFLICT_DETAILS)\r\n CD_ulMask: ULONG; // indicates what information is required/valid\r\n CD_dnDevInst: DEVINST; // filled with DevInst of conflicting device if CM_CDMASK_DEVINST set\r\n CD_rdResDes: RES_DES; // filled with a ResDes of conflict if CM_CDMASK_RESDES set\r\n CD_ulFlags: ULONG; // various flags regarding conflict\r\n CD_szDescription: array [0..MAX_PATH-1] of WideChar; // description of conflicting device\r\n end;\r\n {$EXTERNALSYM CONFLICT_DETAILS_W}\r\n\r\n {$IFDEF UNICODE}\r\n CONFLICT_DETAILS = CONFLICT_DETAILS_W;\r\n PCONFLICT_DETAILS = PCONFLICT_DETAILS_W;\r\n {$ELSE}\r\n CONFLICT_DETAILS = CONFLICT_DETAILS_A;\r\n PCONFLICT_DETAILS = PCONFLICT_DETAILS_A;\r\n {$ENDIF UNICODE}\r\n {$EXTERNALSYM CONFLICT_DETAILS}\r\n {$EXTERNALSYM PCONFLICT_DETAILS}\r\n\r\nconst\r\n CM_CDMASK_DEVINST = $00000001; // mask to retrieve CD_dnDevInst attribute for conflict\r\n {$EXTERNALSYM CM_CDMASK_DEVINST}\r\n CM_CDMASK_RESDES = $00000002; // mask to retrieve CD_rdResDes attribute for conflict\r\n {$EXTERNALSYM CM_CDMASK_RESDES}\r\n CM_CDMASK_FLAGS = $00000004; // mask to retrieve CD_ulFlags attribute for conflict\r\n {$EXTERNALSYM CM_CDMASK_FLAGS}\r\n CM_CDMASK_DESCRIPTION = $00000008; // mask to retrieve CD_szDescription attribute for conflict\r\n {$EXTERNALSYM CM_CDMASK_DESCRIPTION}\r\n CM_CDMASK_VALID = $0000000F; // valid bits\r\n {$EXTERNALSYM CM_CDMASK_VALID}\r\n\r\n CM_CDFLAGS_DRIVER = $00000001; // CD_ulFlags: CD_szDescription reports back legacy driver name\r\n {$EXTERNALSYM CM_CDFLAGS_DRIVER}\r\n CM_CDFLAGS_ROOT_OWNED = $00000002; // CD_ulFlags: Root owned device\r\n {$EXTERNALSYM CM_CDFLAGS_ROOT_OWNED}\r\n CM_CDFLAGS_RESERVED = $00000004; // CD_ulFlags: Specified range is not available for use\r\n {$EXTERNALSYM CM_CDFLAGS_RESERVED}\r\n\r\ntype\r\n REGDISPOSITION = ^ULONG;\r\n {$EXTERNALSYM REGDISPOSITION}\r\n\r\n//--------------------------------------------------------------\r\n// Memory resource\r\n//--------------------------------------------------------------\r\n\r\nconst\r\n //\r\n // Define the attribute flags for memory ranges. Each bit flag is\r\n // identified by a constant bitmask. Following the bitmask definition,\r\n // are the two possible values.\r\n //\r\n mMD_MemoryType = $1; // Bitmask, whether memory is writable\r\n {$EXTERNALSYM mMD_MemoryType}\r\n fMD_MemoryType = mMD_MemoryType; // compatibility\r\n {$EXTERNALSYM fMD_MemoryType}\r\n fMD_ROM = $0; // Memory range is read-only\r\n {$EXTERNALSYM fMD_ROM}\r\n fMD_RAM = $1; // Memory range may be written to\r\n {$EXTERNALSYM fMD_RAM}\r\n\r\n mMD_32_24 = $2; // Bitmask, memory is 24 or 32-bit\r\n {$EXTERNALSYM mMD_32_24}\r\n fMD_32_24 = mMD_32_24; // compatibility\r\n {$EXTERNALSYM fMD_32_24}\r\n fMD_24 = $0; // Memory range is 24-bit\r\n {$EXTERNALSYM fMD_24}\r\n fMD_32 = $2; // Memory range is 32-bit\r\n {$EXTERNALSYM fMD_32}\r\n\r\n mMD_Prefetchable = $4; // Bitmask,whether memory prefetchable\r\n {$EXTERNALSYM mMD_Prefetchable}\r\n fMD_Prefetchable = mMD_Prefetchable; // compatibility\r\n {$EXTERNALSYM fMD_Prefetchable}\r\n fMD_Pref = mMD_Prefetchable; // compatibility\r\n {$EXTERNALSYM fMD_Pref}\r\n fMD_PrefetchDisallowed = $0; // Memory range is not prefetchable\r\n {$EXTERNALSYM fMD_PrefetchDisallowed}\r\n fMD_PrefetchAllowed = $4; // Memory range is prefetchable\r\n {$EXTERNALSYM fMD_PrefetchAllowed}\r\n\r\n mMD_Readable = $8; // Bitmask,whether memory is readable\r\n {$EXTERNALSYM mMD_Readable}\r\n fMD_Readable = mMD_Readable; // compatibility\r\n {$EXTERNALSYM fMD_Readable}\r\n fMD_ReadAllowed = $0; // Memory range is readable\r\n {$EXTERNALSYM fMD_ReadAllowed}\r\n fMD_ReadDisallowed = $8; // Memory range is write-only\r\n {$EXTERNALSYM fMD_ReadDisallowed}\r\n\r\n mMD_CombinedWrite = $10; // Bitmask,supports write-behind\r\n {$EXTERNALSYM mMD_CombinedWrite}\r\n fMD_CombinedWrite = mMD_CombinedWrite; // compatibility\r\n {$EXTERNALSYM fMD_CombinedWrite}\r\n fMD_CombinedWriteDisallowed = $0; // no combined-write caching\r\n {$EXTERNALSYM fMD_CombinedWriteDisallowed}\r\n fMD_CombinedWriteAllowed = $10; // supports combined-write caching\r\n {$EXTERNALSYM fMD_CombinedWriteAllowed}\r\n\r\n mMD_Cacheable = $20; // Bitmask,whether memory is cacheable\r\n {$EXTERNALSYM mMD_Cacheable}\r\n fMD_NonCacheable = $0; // Memory range is non-cacheable\r\n {$EXTERNALSYM fMD_NonCacheable}\r\n fMD_Cacheable = $20; // Memory range is cacheable\r\n {$EXTERNALSYM fMD_Cacheable}\r\n\r\ntype\r\n //\r\n // MEM_RANGE Structure\r\n //\r\n PMEM_RANGE = ^MEM_RANGE;\r\n {$EXTERNALSYM PMEM_RANGE}\r\n MEM_RANGE = packed record\r\n MR_Align: DWORDLONG; // specifies mask for base alignment\r\n MR_nBytes: ULONG; // specifies number of bytes required\r\n MR_Min: DWORDLONG; // specifies minimum address of the range\r\n MR_Max: DWORDLONG; // specifies maximum address of the range\r\n MR_Flags: DWORD; // specifies flags describing range (fMD flags)\r\n MR_Reserved: DWORD;\r\n end;\r\n {$EXTERNALSYM MEM_RANGE}\r\n\r\n //\r\n // MEM_DES structure\r\n //\r\n PMEM_DES = ^MEM_DES;\r\n {$EXTERNALSYM PMEM_DES}\r\n MEM_DES = packed record\r\n MD_Count: DWORD; // number of MEM_RANGE structs in MEM_RESOURCE\r\n MD_Type: DWORD; // size (in bytes) of MEM_RANGE (MType_Range)\r\n MD_Alloc_Base: DWORDLONG; // base memory address of range allocated\r\n MD_Alloc_End: DWORDLONG; // end of allocated range\r\n MD_Flags: DWORD; // flags describing allocated range (fMD flags)\r\n MD_Reserved: DWORD;\r\n end;\r\n {$EXTERNALSYM MEM_DES}\r\n\r\n //\r\n // MEM_RESOURCE structure\r\n //\r\n PMEM_RESOURCE = ^MEM_RESOURCE;\r\n {$EXTERNALSYM PMEM_RESOURCE}\r\n MEM_RESOURCE = packed record\r\n MEM_Header: MEM_DES; // info about memory range list\r\n MEM_Data: array [0..0] of MEM_RANGE; // list of memory ranges\r\n end;\r\n {$EXTERNALSYM MEM_RESOURCE}\r\n\r\nconst\r\n //\r\n // Define the size of each range structure\r\n //\r\n MType_Range = SizeOf(MEM_RANGE);\r\n {$EXTERNALSYM MType_Range}\r\n\r\n//--------------------------------------------------------------\r\n// I/O Port Resource\r\n//--------------------------------------------------------------\r\n\r\nconst\r\n //\r\n // Define the attribute flags for port resources. Each bit flag is\r\n // identified by a constant bitmask. Following the bitmask definition,\r\n // are the two possible values.\r\n //\r\n fIOD_PortType = $1; // Bitmask,whether port is IO or memory\r\n {$EXTERNALSYM fIOD_PortType}\r\n fIOD_Memory = $0; // Port resource really uses memory\r\n {$EXTERNALSYM fIOD_Memory}\r\n fIOD_IO = $1; // Port resource uses IO ports\r\n {$EXTERNALSYM fIOD_IO}\r\n fIOD_DECODE = $00fc; // decode flags\r\n {$EXTERNALSYM fIOD_DECODE}\r\n fIOD_10_BIT_DECODE = $0004;\r\n {$EXTERNALSYM fIOD_10_BIT_DECODE}\r\n fIOD_12_BIT_DECODE = $0008;\r\n {$EXTERNALSYM fIOD_12_BIT_DECODE}\r\n fIOD_16_BIT_DECODE = $0010;\r\n {$EXTERNALSYM fIOD_16_BIT_DECODE}\r\n fIOD_POSITIVE_DECODE = $0020;\r\n {$EXTERNALSYM fIOD_POSITIVE_DECODE}\r\n fIOD_PASSIVE_DECODE = $0040;\r\n {$EXTERNALSYM fIOD_PASSIVE_DECODE}\r\n fIOD_WINDOW_DECODE = $0080;\r\n {$EXTERNALSYM fIOD_WINDOW_DECODE}\r\n\r\n //\r\n // these are for compatiblity\r\n //\r\n IO_ALIAS_10_BIT_DECODE = $00000004;\r\n {$EXTERNALSYM IO_ALIAS_10_BIT_DECODE}\r\n IO_ALIAS_12_BIT_DECODE = $00000010;\r\n {$EXTERNALSYM IO_ALIAS_12_BIT_DECODE}\r\n IO_ALIAS_16_BIT_DECODE = $00000000;\r\n {$EXTERNALSYM IO_ALIAS_16_BIT_DECODE}\r\n IO_ALIAS_POSITIVE_DECODE = $000000FF;\r\n {$EXTERNALSYM IO_ALIAS_POSITIVE_DECODE}\r\n\r\ntype\r\n //\r\n // IO_RANGE structure\r\n //\r\n PIO_RANGE = ^IO_RANGE;\r\n {$EXTERNALSYM PIO_RANGE}\r\n IO_RANGE = packed record\r\n IOR_Align: DWORDLONG; // mask for base alignment\r\n IOR_nPorts: DWORD; // number of ports\r\n IOR_Min: DWORDLONG; // minimum port address\r\n IOR_Max: DWORDLONG; // maximum port address\r\n IOR_RangeFlags: DWORD; // flags for this port range\r\n IOR_Alias: DWORDLONG; // multiplier that generates aliases for port(s)\r\n end;\r\n {$EXTERNALSYM IO_RANGE}\r\n\r\n //\r\n // IO_DES structure\r\n //\r\n PIO_DES = ^IO_DES;\r\n {$EXTERNALSYM PIO_DES}\r\n IO_DES = packed record\r\n IOD_Count: DWORD; // number of IO_RANGE structs in IO_RESOURCE\r\n IOD_Type: DWORD; // size (in bytes) of IO_RANGE (IOType_Range)\r\n IOD_Alloc_Base: DWORDLONG; // base of allocated port range\r\n IOD_Alloc_End: DWORDLONG; // end of allocated port range\r\n IOD_DesFlags: DWORD; // flags relating to allocated port range\r\n end;\r\n {$EXTERNALSYM IO_DES}\r\n\r\n //\r\n // IO_RESOURCE\r\n //\r\n PIO_RESOURCE = ^IO_RESOURCE;\r\n {$EXTERNALSYM PIO_RESOURCE}\r\n IO_RESOURCE = packed record\r\n IO_Header: IO_DES; // info about I/O port range list\r\n IO_Data: array [0..0] of IO_RANGE; // list of I/O port ranges\r\n end;\r\n {$EXTERNALSYM IO_RESOURCE}\r\n\r\nconst\r\n IOA_Local = $ff;\r\n {$EXTERNALSYM IOA_Local}\r\n\r\n //\r\n // Define the size of each range structure\r\n //\r\n IOType_Range = SizeOf(IO_RANGE);\r\n {$EXTERNALSYM IOType_Range}\r\n\r\n//--------------------------------------------------------------\r\n// DMA Resource\r\n//--------------------------------------------------------------\r\n\r\nconst\r\n //\r\n // Define the attribute flags for a DMA resource range. Each bit flag is\r\n // identified with a constant bitmask. Following the bitmask definition\r\n // are the possible values.\r\n //\r\n mDD_Width = $3; // Bitmask, width of the DMA channel:\r\n {$EXTERNALSYM mDD_Width}\r\n fDD_BYTE = $0; // 8-bit DMA channel\r\n {$EXTERNALSYM fDD_BYTE}\r\n fDD_WORD = $1; // 16-bit DMA channel\r\n {$EXTERNALSYM fDD_WORD}\r\n fDD_DWORD = $2; // 32-bit DMA channel\r\n {$EXTERNALSYM fDD_DWORD}\r\n fDD_BYTE_AND_WORD = $3; // 8-bit and 16-bit DMA channel\r\n {$EXTERNALSYM fDD_BYTE_AND_WORD}\r\n\r\n mDD_BusMaster = $4; // Bitmask, whether bus mastering is supported\r\n {$EXTERNALSYM mDD_BusMaster}\r\n fDD_NoBusMaster = $0; // no bus mastering\r\n {$EXTERNALSYM fDD_NoBusMaster}\r\n fDD_BusMaster = $4; // bus mastering\r\n {$EXTERNALSYM fDD_BusMaster}\r\n\r\n mDD_Type = $18; // Bitmask, specifies type of DMA\r\n {$EXTERNALSYM mDD_Type}\r\n fDD_TypeStandard = $00; // standard DMA\r\n {$EXTERNALSYM fDD_TypeStandard}\r\n fDD_TypeA = $08; // Type-A DMA\r\n {$EXTERNALSYM fDD_TypeA}\r\n fDD_TypeB = $10; // Type-B DMA\r\n {$EXTERNALSYM fDD_TypeB}\r\n fDD_TypeF = $18; // Type-F DMA\r\n {$EXTERNALSYM fDD_TypeF}\r\n\r\ntype\r\n //\r\n // DMA_RANGE structure\r\n //\r\n PDMA_RANGE = ^DMA_RANGE;\r\n {$EXTERNALSYM PDMA_RANGE}\r\n DMA_RANGE = packed record\r\n DR_Min: ULONG; // minimum DMA port in the range\r\n DR_Max: ULONG; // maximum DMA port in the range\r\n DR_Flags: ULONG; // flags describing the range (fDD flags)\r\n end;\r\n {$EXTERNALSYM DMA_RANGE}\r\n\r\n //\r\n // DMA_DES structure\r\n //\r\n PDMA_DES = ^DMA_DES;\r\n {$EXTERNALSYM PDMA_DES}\r\n DMA_DES = packed record\r\n DD_Count: DWORD; // number of DMA_RANGE structs in DMA_RESOURCE\r\n DD_Type: DWORD; // size (in bytes) of DMA_RANGE struct (DType_Range)\r\n DD_Flags: DWORD; // Flags describing DMA channel (fDD flags)\r\n DD_Alloc_Chan: ULONG; // Specifies the DMA channel that was allocated\r\n end;\r\n {$EXTERNALSYM DMA_DES}\r\n\r\n //\r\n // DMA_RESOURCE\r\n //\r\n PDMA_RESOURCE = ^DMA_RESOURCE;\r\n {$EXTERNALSYM PDMA_RESOURCE}\r\n DMA_RESOURCE = packed record\r\n DMA_Header: DMA_DES; // info about DMA channel range list\r\n DMA_Data: array [0..0] of DMA_RANGE; // list of DMA ranges\r\n end;\r\n {$EXTERNALSYM DMA_RESOURCE}\r\n\r\nconst\r\n //\r\n // Define the size of each range structure\r\n //\r\n DType_Range = SizeOf(DMA_RANGE);\r\n {$EXTERNALSYM DType_Range}\r\n\r\n//--------------------------------------------------------------\r\n// Interrupt Resource\r\n//--------------------------------------------------------------\r\n\r\nconst\r\n //\r\n // Define the attribute flags for an interrupt resource range. Each bit flag\r\n // is identified with a constant bitmask. Following the bitmask definition\r\n // are the possible values.\r\n //\r\n mIRQD_Share = $1; // Bitmask,whether the IRQ may be shared:\r\n {$EXTERNALSYM mIRQD_Share}\r\n fIRQD_Exclusive = $0; // The IRQ may not be shared\r\n {$EXTERNALSYM fIRQD_Exclusive}\r\n fIRQD_Share = $1; // The IRQ may be shared\r\n {$EXTERNALSYM fIRQD_Share}\r\n\r\n fIRQD_Share_Bit = 0; // compatibility\r\n {$EXTERNALSYM fIRQD_Share_Bit}\r\n fIRQD_Level_Bit = 1; // compatibility\r\n {$EXTERNALSYM fIRQD_Level_Bit}\r\n\r\n //\r\n // ** NOTE: 16-bit ConfigMgr uses fIRQD_Level_Bit being set to indicate that the\r\n // ** interrupt is _level-sensitive_. For 32-bit ConfigMgr, if this bit is set,\r\n // ** then the interrupt is _edge-sensitive_.\r\n //\r\n mIRQD_Edge_Level = $2; // Bitmask,whether edge or level triggered:\r\n {$EXTERNALSYM mIRQD_Edge_Level}\r\n fIRQD_Level = $0; // The IRQ is level-sensitive\r\n {$EXTERNALSYM fIRQD_Level}\r\n fIRQD_Edge = $2; // The IRQ is edge-sensitive\r\n {$EXTERNALSYM fIRQD_Edge}\r\n\r\ntype\r\n //\r\n // IRQ_RANGE\r\n //\r\n PIRQ_RANGE = ^IRQ_RANGE;\r\n {$EXTERNALSYM PIRQ_RANGE}\r\n IRQ_RANGE = packed record\r\n IRQR_Min: ULONG; // minimum IRQ in the range\r\n IRQR_Max: ULONG; // maximum IRQ in the range\r\n IRQR_Flags: ULONG; // flags describing the range (fIRQD flags)\r\n end;\r\n {$EXTERNALSYM IRQ_RANGE}\r\n\r\n //\r\n // IRQ_DES structure\r\n //\r\n PIRQ_DES_32 = ^IRQ_DES_32;\r\n {$EXTERNALSYM PIRQ_DES_32}\r\n IRQ_DES_32 = packed record\r\n IRQD_Count: DWORD; // number of IRQ_RANGE structs in IRQ_RESOURCE\r\n IRQD_Type: DWORD; // size (in bytes) of IRQ_RANGE (IRQType_Range)\r\n IRQD_Flags: DWORD; // flags describing the IRQ (fIRQD flags)\r\n IRQD_Alloc_Num: ULONG; // specifies the IRQ that was allocated\r\n IRQD_Affinity: ULONG32;\r\n end;\r\n {$EXTERNALSYM IRQ_DES_32}\r\n\r\n PIRQ_DES_64 = ^IRQ_DES_64;\r\n {$EXTERNALSYM PIRQ_DES_64}\r\n IRQ_DES_64 = packed record\r\n IRQD_Count: DWORD; // number of IRQ_RANGE structs in IRQ_RESOURCE\r\n IRQD_Type: DWORD; // size (in bytes) of IRQ_RANGE (IRQType_Range)\r\n IRQD_Flags: DWORD; // flags describing the IRQ (fIRQD flags)\r\n IRQD_Alloc_Num: ULONG; // specifies the IRQ that was allocated\r\n IRQD_Affinity: ULONG64;\r\n end;\r\n {$EXTERNALSYM IRQ_DES_64}\r\n\r\n {$IFDEF _WIN64}\r\n IRQ_DES = IRQ_DES_64;\r\n PIRQ_DES = PIRQ_DES_64;\r\n {$ELSE}\r\n IRQ_DES = IRQ_DES_32;\r\n PIRQ_DES = PIRQ_DES_32;\r\n {$ENDIF UNICODE}\r\n {$EXTERNALSYM IRQ_DES}\r\n {$EXTERNALSYM PIRQ_DES}\r\n\r\n //\r\n // IRQ_RESOURCE structure\r\n //\r\n PIRQ_RESOURCE_32 = ^IRQ_RESOURCE_32;\r\n {$EXTERNALSYM PIRQ_RESOURCE_32}\r\n IRQ_RESOURCE_32 = packed record\r\n IRQ_Header: IRQ_DES_32; // info about IRQ range list\r\n IRQ_Data: array [0..0] of IRQ_RANGE; // list of IRQ ranges\r\n end;\r\n {$EXTERNALSYM IRQ_RESOURCE_32}\r\n\r\n PIRQ_RESOURCE_64 = ^IRQ_RESOURCE_64;\r\n {$EXTERNALSYM PIRQ_RESOURCE_64}\r\n IRQ_RESOURCE_64 = packed record\r\n IRQ_Header: IRQ_DES_64; // info about IRQ range list\r\n IRQ_Data: array [0..0] of IRQ_RANGE; // list of IRQ ranges\r\n end;\r\n {$EXTERNALSYM IRQ_RESOURCE_64}\r\n\r\n {$IFDEF _WIN64}\r\n IRQ_RESOURCE = IRQ_RESOURCE_64;\r\n PIRQ_RESOURCE = PIRQ_RESOURCE_64;\r\n {$ELSE}\r\n IRQ_RESOURCE = IRQ_RESOURCE_32;\r\n PIRQ_RESOURCE = PIRQ_RESOURCE_32;\r\n {$ENDIF _WIN64}\r\n {$EXTERNALSYM IRQ_RESOURCE}\r\n {$EXTERNALSYM PIRQ_RESOURCE}\r\n\r\nconst\r\n //\r\n // Define the size of each range structure\r\n //\r\n IRQType_Range = SizeOf(IRQ_RANGE);\r\n {$EXTERNALSYM IRQType_Range}\r\n\r\n //\r\n // Flags for resource descriptor APIs indicating the width of certain\r\n // variable-size resource descriptor structure fields, where applicable.\r\n //\r\n CM_RESDES_WIDTH_DEFAULT = $00000000; // 32 or 64-bit IRQ_RESOURCE / IRQ_DES, based on client\r\n {$EXTERNALSYM CM_RESDES_WIDTH_DEFAULT}\r\n CM_RESDES_WIDTH_32 = $00000001; // 32-bit IRQ_RESOURCE / IRQ_DES\r\n {$EXTERNALSYM CM_RESDES_WIDTH_32}\r\n CM_RESDES_WIDTH_64 = $00000002; // 64-bit IRQ_RESOURCE / IRQ_DES\r\n {$EXTERNALSYM CM_RESDES_WIDTH_64}\r\n CM_RESDES_WIDTH_BITS = $00000003;\r\n {$EXTERNALSYM CM_RESDES_WIDTH_BITS}\r\n\r\n//--------------------------------------------------------------\r\n// Device Private Resource\r\n//--------------------------------------------------------------\r\n\r\ntype\r\n //\r\n // DEVICEPRIVATE_RANGE structure\r\n //\r\n PDEVPRIVATE_RANGE = ^DEVPRIVATE_RANGE;\r\n {$EXTERNALSYM PDEVPRIVATE_RANGE}\r\n DEVPRIVATE_RANGE = packed record\r\n PR_Data1: DWORD; // mask for base alignment\r\n PR_Data2: DWORD; // number of bytes\r\n PR_Data3: DWORD; // minimum address\r\n end;\r\n {$EXTERNALSYM DEVPRIVATE_RANGE}\r\n\r\n //\r\n // DEVPRIVATE_DES structure\r\n //\r\n PDEVPRIVATE_DES = ^DEVPRIVATE_DES;\r\n {$EXTERNALSYM PDEVPRIVATE_DES}\r\n DEVPRIVATE_DES = packed record\r\n PD_Count: DWORD;\r\n PD_Type: DWORD;\r\n PD_Data1: DWORD;\r\n PD_Data2: DWORD;\r\n PD_Data3: DWORD;\r\n PD_Flags: DWORD;\r\n end;\r\n {$EXTERNALSYM DEVPRIVATE_DES}\r\n\r\n //\r\n // DEVPRIVATE_RESOURCE\r\n //\r\n PDEVPRIVATE_RESOURCE = ^DEVPRIVATE_RESOURCE;\r\n {$EXTERNALSYM PDEVPRIVATE_RESOURCE}\r\n DEVPRIVATE_RESOURCE = packed record\r\n PRV_Header: DEVPRIVATE_DES;\r\n PRV_Data: array [0..0] of DEVPRIVATE_RANGE;\r\n end;\r\n {$EXTERNALSYM DEVPRIVATE_RESOURCE}\r\n\r\nconst\r\n //\r\n // Define the size of each range structure\r\n //\r\n PType_Range = SizeOf(DEVPRIVATE_RANGE);\r\n {$EXTERNALSYM PType_Range}\r\n\r\n//--------------------------------------------------------------\r\n// Class-Specific Resource\r\n//--------------------------------------------------------------\r\n\r\ntype\r\n PCS_DES = ^CS_DES;\r\n {$EXTERNALSYM PCS_DES}\r\n CS_DES = packed record\r\n CSD_SignatureLength: DWORD;\r\n CSD_LegacyDataOffset: DWORD;\r\n CSD_LegacyDataSize: DWORD;\r\n CSD_Flags: DWORD;\r\n CSD_ClassGuid: TGUID;\r\n CSD_Signature: array [0..0] of Byte;\r\n end;\r\n {$EXTERNALSYM CS_DES}\r\n\r\n PCS_RESOURCE = ^CS_RESOURCE;\r\n {$EXTERNALSYM PCS_RESOURCE}\r\n CS_RESOURCE = packed record\r\n CS_Header: CS_DES;\r\n end;\r\n {$EXTERNALSYM CS_RESOURCE}\r\n\r\n//--------------------------------------------------------------\r\n// PC Card Configuration Resource\r\n//--------------------------------------------------------------\r\n\r\nconst\r\n //\r\n // Define the attribute flags for a PC Card configuration resource descriptor.\r\n // Each bit flag is identified with a constant bitmask. Following the bitmask\r\n // definition are the possible values.\r\n //\r\n mPCD_IO_8_16 = $1; // Bitmask, whether I/O is 8 or 16 bits\r\n {$EXTERNALSYM mPCD_IO_8_16}\r\n fPCD_IO_8 = $0; // I/O is 8-bit\r\n {$EXTERNALSYM fPCD_IO_8}\r\n fPCD_IO_16 = $1; // I/O is 16-bit\r\n {$EXTERNALSYM fPCD_IO_16}\r\n mPCD_MEM_8_16 = $2; // Bitmask, whether MEM is 8 or 16 bits\r\n {$EXTERNALSYM mPCD_MEM_8_16}\r\n fPCD_MEM_8 = $0; // MEM is 8-bit\r\n {$EXTERNALSYM fPCD_MEM_8}\r\n fPCD_MEM_16 = $2; // MEM is 16-bit\r\n {$EXTERNALSYM fPCD_MEM_16}\r\n mPCD_MEM_A_C = $C; // Bitmask, whether MEMx is Attribute or Common\r\n {$EXTERNALSYM mPCD_MEM_A_C}\r\n fPCD_MEM1_A = $4; // MEM1 is Attribute\r\n {$EXTERNALSYM fPCD_MEM1_A}\r\n fPCD_MEM2_A = $8; // MEM2 is Attribute\r\n {$EXTERNALSYM fPCD_MEM2_A}\r\n fPCD_IO_ZW_8 = $10; // zero wait on 8 bit I/O\r\n {$EXTERNALSYM fPCD_IO_ZW_8}\r\n fPCD_IO_SRC_16 = $20; // iosrc 16\r\n {$EXTERNALSYM fPCD_IO_SRC_16}\r\n fPCD_IO_WS_16 = $40; // wait states on 16 bit io\r\n {$EXTERNALSYM fPCD_IO_WS_16}\r\n mPCD_MEM_WS = $300; // Bitmask, for additional wait states on memory windows\r\n {$EXTERNALSYM mPCD_MEM_WS}\r\n fPCD_MEM_WS_ONE = $100; // 1 wait state\r\n {$EXTERNALSYM fPCD_MEM_WS_ONE}\r\n fPCD_MEM_WS_TWO = $200; // 2 wait states\r\n {$EXTERNALSYM fPCD_MEM_WS_TWO}\r\n fPCD_MEM_WS_THREE = $300; // 3 wait states\r\n {$EXTERNALSYM fPCD_MEM_WS_THREE}\r\n\r\n fPCD_MEM_A = $4; // MEM is Attribute\r\n {$EXTERNALSYM fPCD_MEM_A}\r\n\r\n fPCD_ATTRIBUTES_PER_WINDOW = $8000;\r\n {$EXTERNALSYM fPCD_ATTRIBUTES_PER_WINDOW}\r\n\r\n fPCD_IO1_16 = $00010000; // I/O window 1 is 16-bit\r\n {$EXTERNALSYM fPCD_IO1_16}\r\n fPCD_IO1_ZW_8 = $00020000; // I/O window 1 zero wait on 8 bit I/O\r\n {$EXTERNALSYM fPCD_IO1_ZW_8}\r\n fPCD_IO1_SRC_16 = $00040000; // I/O window 1 iosrc 16\r\n {$EXTERNALSYM fPCD_IO1_SRC_16}\r\n fPCD_IO1_WS_16 = $00080000; // I/O window 1 wait states on 16 bit io\r\n {$EXTERNALSYM fPCD_IO1_WS_16}\r\n\r\n fPCD_IO2_16 = $00100000; // I/O window 2 is 16-bit\r\n {$EXTERNALSYM fPCD_IO2_16}\r\n fPCD_IO2_ZW_8 = $00200000; // I/O window 2 zero wait on 8 bit I/O\r\n {$EXTERNALSYM fPCD_IO2_ZW_8}\r\n fPCD_IO2_SRC_16 = $00400000; // I/O window 2 iosrc 16\r\n {$EXTERNALSYM fPCD_IO2_SRC_16}\r\n fPCD_IO2_WS_16 = $00800000; // I/O window 2 wait states on 16 bit io\r\n {$EXTERNALSYM fPCD_IO2_WS_16}\r\n\r\n mPCD_MEM1_WS = $03000000; // MEM window 1 Bitmask, for additional wait states on memory windows\r\n {$EXTERNALSYM mPCD_MEM1_WS}\r\n fPCD_MEM1_WS_ONE = $01000000; // MEM window 1, 1 wait state\r\n {$EXTERNALSYM fPCD_MEM1_WS_ONE}\r\n fPCD_MEM1_WS_TWO = $02000000; // MEM window 1, 2 wait states\r\n {$EXTERNALSYM fPCD_MEM1_WS_TWO}\r\n fPCD_MEM1_WS_THREE = $03000000; // MEM window 1, 3 wait states\r\n {$EXTERNALSYM fPCD_MEM1_WS_THREE}\r\n fPCD_MEM1_16 = $04000000; // MEM window 1 is 16-bit\r\n {$EXTERNALSYM fPCD_MEM1_16}\r\n\r\n mPCD_MEM2_WS = $30000000; // MEM window 2 Bitmask, for additional wait states on memory windows\r\n {$EXTERNALSYM mPCD_MEM2_WS}\r\n fPCD_MEM2_WS_ONE = $10000000; // MEM window 2, 1 wait state\r\n {$EXTERNALSYM fPCD_MEM2_WS_ONE}\r\n fPCD_MEM2_WS_TWO = $20000000; // MEM window 2, 2 wait states\r\n {$EXTERNALSYM fPCD_MEM2_WS_TWO}\r\n fPCD_MEM2_WS_THREE = $30000000; // MEM window 2, 3 wait states\r\n {$EXTERNALSYM fPCD_MEM2_WS_THREE}\r\n fPCD_MEM2_16 = $40000000; // MEM window 2 is 16-bit\r\n {$EXTERNALSYM fPCD_MEM2_16}\r\n\r\n PCD_MAX_MEMORY = 2;\r\n {$EXTERNALSYM PCD_MAX_MEMORY}\r\n PCD_MAX_IO = 2;\r\n {$EXTERNALSYM PCD_MAX_IO}\r\n\r\ntype\r\n PPCCARD_DES = ^PCCARD_DES;\r\n {$EXTERNALSYM PPCCARD_DES}\r\n PCCARD_DES = packed record\r\n PCD_Count: DWORD;\r\n PCD_Type: DWORD;\r\n PCD_Flags: DWORD;\r\n PCD_ConfigIndex: Byte;\r\n PCD_Reserved: array [0..2] of Byte;\r\n PCD_MemoryCardBase1: DWORD;\r\n PCD_MemoryCardBase2: DWORD;\r\n PCD_MemoryCardBase: array [0..PCD_MAX_MEMORY-1] of DWORD; // will soon be removed\r\n PCD_MemoryFlags: array [0..PCD_MAX_MEMORY-1] of WORD; // will soon be removed\r\n PCD_IoFlags: array [0..PCD_MAX_IO-1] of Byte; // will soon be removed\r\n end;\r\n {$EXTERNALSYM PCCARD_DES}\r\n\r\n PPCCARD_RESOURCE = ^PCCARD_RESOURCE;\r\n {$EXTERNALSYM PPCCARD_RESOURCE}\r\n PCCARD_RESOURCE = packed record\r\n PcCard_Header: PCCARD_DES;\r\n end;\r\n {$EXTERNALSYM PCCARD_RESOURCE}\r\n\r\n//--------------------------------------------------------------\r\n// MF (multifunction) PCCard Configuration Resource\r\n//--------------------------------------------------------------\r\n\r\nconst\r\n mPMF_AUDIO_ENABLE = $8; // Bitmask, whether audio is enabled or not\r\n {$EXTERNALSYM mPMF_AUDIO_ENABLE}\r\n fPMF_AUDIO_ENABLE = $8; // Audio is enabled\r\n {$EXTERNALSYM fPMF_AUDIO_ENABLE}\r\n\r\ntype\r\n PMFCARD_DES = ^MFCARD_DES;\r\n {$EXTERNALSYM PMFCARD_DES}\r\n MFCARD_DES = packed record\r\n PMF_Count: DWORD;\r\n PMF_Type: DWORD;\r\n PMF_Flags: DWORD;\r\n PMF_ConfigOptions: Byte;\r\n PMF_IoResourceIndex: Byte;\r\n PMF_Reserved: array [0..1] of Byte;\r\n PMF_ConfigRegisterBase: DWORD;\r\n end;\r\n {$EXTERNALSYM MFCARD_DES}\r\n\r\n PMFCARD_RESOURCE = ^MFCARD_RESOURCE;\r\n {$EXTERNALSYM PMFCARD_RESOURCE}\r\n MFCARD_RESOURCE = packed record\r\n MfCard_Header: MFCARD_DES;\r\n end;\r\n {$EXTERNALSYM MFCARD_RESOURCE}\r\n\r\n//--------------------------------------------------------------\r\n// Bus Number Resource\r\n//--------------------------------------------------------------\r\n\r\n//\r\n// Define the attribute flags for a Bus Number resource descriptor.\r\n// Each bit flag is identified with a constant bitmask. Following the bitmask\r\n// definition are the possible values.\r\n//\r\n// Currently unused.\r\n//\r\n\r\n //\r\n // BUSNUMBER_RANGE\r\n //\r\n PBUSNUMBER_RANGE = ^BUSNUMBER_RANGE;\r\n {$EXTERNALSYM PBUSNUMBER_RANGE}\r\n BUSNUMBER_RANGE = packed record\r\n BUSR_Min: ULONG; // minimum Bus Number in the range\r\n BUSR_Max: ULONG; // maximum Bus Number in the range\r\n BUSR_nBusNumbers: ULONG; // specifies number of buses required\r\n BUSR_Flags: ULONG; // flags describing the range (currently unused)\r\n end;\r\n {$EXTERNALSYM BUSNUMBER_RANGE}\r\n\r\n //\r\n // BUSNUMBER_DES structure\r\n //\r\n PBUSNUMBER_DES = ^BUSNUMBER_DES;\r\n {$EXTERNALSYM PBUSNUMBER_DES}\r\n BUSNUMBER_DES = packed record\r\n BUSD_Count: DWORD; // number of BUSNUMBER_RANGE structs in BUSNUMBER_RESOURCE\r\n BUSD_Type: DWORD; // size (in bytes) of BUSNUMBER_RANGE (BusNumberType_Range)\r\n BUSD_Flags: DWORD; // flags describing the range (currently unused)\r\n BUSD_Alloc_Base: ULONG; // specifies the first Bus that was allocated\r\n BUSD_Alloc_End: ULONG; // specifies the last Bus number that was allocated\r\n end;\r\n {$EXTERNALSYM BUSNUMBER_DES}\r\n\r\n //\r\n // BUSNUMBER_RESOURCE structure\r\n //\r\n PBUSNUMBER_RESOURCE = ^BUSNUMBER_RESOURCE;\r\n {$EXTERNALSYM PBUSNUMBER_RESOURCE}\r\n BUSNUMBER_RESOURCE = packed record\r\n BusNumber_Header: BUSNUMBER_DES; // info about Bus Number range list\r\n BusNumber_Data: array [0..0] of BUSNUMBER_RANGE; // list of Bus Number ranges\r\n end;\r\n {$EXTERNALSYM BUSNUMBER_RESOURCE}\r\n\r\nconst\r\n //\r\n // Define the size of each range structure\r\n //\r\n BusNumberType_Range = SizeOf(BUSNUMBER_RANGE);\r\n {$EXTERNALSYM BusNumberType_Range}\r\n\r\n//--------------------------------------------------------------\r\n// Hardware Profile Information\r\n//--------------------------------------------------------------\r\n\r\nconst\r\n //\r\n // Define flags relating to hardware profiles\r\n //\r\n CM_HWPI_NOT_DOCKABLE = $00000000; // machine is not dockable\r\n {$EXTERNALSYM CM_HWPI_NOT_DOCKABLE}\r\n CM_HWPI_UNDOCKED = $00000001; // hw profile for docked config\r\n {$EXTERNALSYM CM_HWPI_UNDOCKED}\r\n CM_HWPI_DOCKED = $00000002; // hw profile for undocked config\r\n {$EXTERNALSYM CM_HWPI_DOCKED}\r\n\r\ntype\r\n //\r\n // HWPROFILEINFO structure\r\n //\r\n PHWPROFILEINFO_A = ^HWPROFILEINFO_A;\r\n {$EXTERNALSYM PHWPROFILEINFO_A}\r\n HWPROFILEINFO_A = packed record\r\n HWPI_ulHWProfile: ULONG; // handle of hw profile\r\n HWPI_szFriendlyName: array [0..MAX_PROFILE_LEN-1] of Char; // friendly name of hw profile\r\n HWPI_dwFlags: DWORD; // profile flags (CM_HWPI_*)\r\n end;\r\n {$EXTERNALSYM HWPROFILEINFO_A}\r\n\r\n PHWPROFILEINFO_W = ^HWPROFILEINFO_W;\r\n {$EXTERNALSYM PHWPROFILEINFO_W}\r\n HWPROFILEINFO_W = packed record\r\n HWPI_ulHWProfile: ULONG; // handle of hw profile\r\n HWPI_szFriendlyName: array [0..MAX_PROFILE_LEN-1] of Char; // friendly name of hw profile\r\n HWPI_dwFlags: DWORD; // profile flags (CM_HWPI_*)\r\n end;\r\n {$EXTERNALSYM HWPROFILEINFO_W}\r\n\r\n {$IFDEF UNICODE}\r\n HWPROFILEINFO = HWPROFILEINFO_W;\r\n PHWPROFILEINFO = PHWPROFILEINFO_W;\r\n {$ELSE}\r\n HWPROFILEINFO = HWPROFILEINFO_A;\r\n PHWPROFILEINFO = PHWPROFILEINFO_A;\r\n {$ENDIF UNICODE}\r\n {$EXTERNALSYM HWPROFILEINFO}\r\n {$EXTERNALSYM PHWPROFILEINFO}\r\n\r\n//--------------------------------------------------------------\r\n// Miscellaneous\r\n//--------------------------------------------------------------\r\n\r\nconst\r\n //\r\n // Resource types\r\n //\r\n ResType_All = $00000000; // Return all resource types\r\n {$EXTERNALSYM ResType_All}\r\n ResType_None = $00000000; // Arbitration always succeeded\r\n {$EXTERNALSYM ResType_None}\r\n ResType_Mem = $00000001; // Physical address resource\r\n {$EXTERNALSYM ResType_Mem}\r\n ResType_IO = $00000002; // Physical I/O address resource\r\n {$EXTERNALSYM ResType_IO}\r\n ResType_DMA = $00000003; // DMA channels resource\r\n {$EXTERNALSYM ResType_DMA}\r\n ResType_IRQ = $00000004; // IRQ resource\r\n {$EXTERNALSYM ResType_IRQ}\r\n ResType_DoNotUse = $00000005; // Used as spacer to sync subsequent ResTypes w/NT\r\n {$EXTERNALSYM ResType_DoNotUse}\r\n ResType_BusNumber = $00000006; // bus number resource\r\n {$EXTERNALSYM ResType_BusNumber}\r\n ResType_MAX = $00000006; // Maximum known (arbitrated) ResType\r\n {$EXTERNALSYM ResType_MAX}\r\n ResType_Ignored_Bit = $00008000; // Ignore this resource\r\n {$EXTERNALSYM ResType_Ignored_Bit}\r\n ResType_ClassSpecific = $0000FFFF; // class-specific resource\r\n {$EXTERNALSYM ResType_ClassSpecific}\r\n ResType_Reserved = $00008000; // reserved for internal use\r\n {$EXTERNALSYM ResType_Reserved}\r\n ResType_DevicePrivate = $00008001; // device private data\r\n {$EXTERNALSYM ResType_DevicePrivate}\r\n ResType_PcCardConfig = $00008002; // PC Card configuration data\r\n {$EXTERNALSYM ResType_PcCardConfig}\r\n ResType_MfCardConfig = $00008003; // MF Card configuration data\r\n {$EXTERNALSYM ResType_MfCardConfig}\r\n\r\n //\r\n // Flags specifying options for ranges that conflict with ranges already in\r\n // the range list (CM_Add_Range)\r\n //\r\n CM_ADD_RANGE_ADDIFCONFLICT = $00000000; // merg with conflicting range\r\n {$EXTERNALSYM CM_ADD_RANGE_ADDIFCONFLICT}\r\n CM_ADD_RANGE_DONOTADDIFCONFLICT = $00000001; // error if range conflicts\r\n {$EXTERNALSYM CM_ADD_RANGE_DONOTADDIFCONFLICT}\r\n CM_ADD_RANGE_BITS = $00000001;\r\n {$EXTERNALSYM CM_ADD_RANGE_BITS}\r\n\r\n //\r\n // Logical Config Flags (specified in call to CM_Get_First_Log_Conf\r\n //\r\n BASIC_LOG_CONF = $00000000; // Specifies the req list.\r\n {$EXTERNALSYM BASIC_LOG_CONF}\r\n FILTERED_LOG_CONF = $00000001; // Specifies the filtered req list.\r\n {$EXTERNALSYM FILTERED_LOG_CONF}\r\n ALLOC_LOG_CONF = $00000002; // Specifies the Alloc Element.\r\n {$EXTERNALSYM ALLOC_LOG_CONF}\r\n BOOT_LOG_CONF = $00000003; // Specifies the RM Alloc Element.\r\n {$EXTERNALSYM BOOT_LOG_CONF}\r\n FORCED_LOG_CONF = $00000004; // Specifies the Forced Log Conf\r\n {$EXTERNALSYM FORCED_LOG_CONF}\r\n OVERRIDE_LOG_CONF = $00000005; // Specifies the Override req list.\r\n {$EXTERNALSYM OVERRIDE_LOG_CONF}\r\n NUM_LOG_CONF = $00000006; // Number of Log Conf type\r\n {$EXTERNALSYM NUM_LOG_CONF}\r\n LOG_CONF_BITS = $00000007; // The bits of the log conf type.\r\n {$EXTERNALSYM LOG_CONF_BITS}\r\n\r\n PRIORITY_EQUAL_FIRST = $00000008; // Same priority, new one first\r\n {$EXTERNALSYM PRIORITY_EQUAL_FIRST}\r\n PRIORITY_EQUAL_LAST = $00000000; // Same priority, new one last\r\n {$EXTERNALSYM PRIORITY_EQUAL_LAST}\r\n PRIORITY_BIT = $00000008;\r\n {$EXTERNALSYM PRIORITY_BIT}\r\n\r\n //\r\n // Registry disposition values\r\n // (specified in call to CM_Open_DevNode_Key and CM_Open_Class_Key)\r\n //\r\n RegDisposition_OpenAlways = $00000000; // open if exists else create\r\n {$EXTERNALSYM RegDisposition_OpenAlways}\r\n RegDisposition_OpenExisting = $00000001; // open key only if exists\r\n {$EXTERNALSYM RegDisposition_OpenExisting}\r\n RegDisposition_Bits = $00000001;\r\n {$EXTERNALSYM RegDisposition_Bits}\r\n\r\n //\r\n // ulFlags values for CM API routines\r\n //\r\n\r\n //\r\n // Flags for CM_Add_ID\r\n //\r\n CM_ADD_ID_HARDWARE = $00000000;\r\n {$EXTERNALSYM CM_ADD_ID_HARDWARE}\r\n CM_ADD_ID_COMPATIBLE = $00000001;\r\n {$EXTERNALSYM CM_ADD_ID_COMPATIBLE}\r\n CM_ADD_ID_BITS = $00000001;\r\n {$EXTERNALSYM CM_ADD_ID_BITS}\r\n\r\n //\r\n // Device Node creation flags\r\n //\r\n CM_CREATE_DEVNODE_NORMAL = $00000000; // install later\r\n {$EXTERNALSYM CM_CREATE_DEVNODE_NORMAL}\r\n CM_CREATE_DEVNODE_NO_WAIT_INSTALL = $00000001; // NOT SUPPORTED ON NT\r\n {$EXTERNALSYM CM_CREATE_DEVNODE_NO_WAIT_INSTALL}\r\n CM_CREATE_DEVNODE_PHANTOM = $00000002;\r\n {$EXTERNALSYM CM_CREATE_DEVNODE_PHANTOM}\r\n CM_CREATE_DEVNODE_GENERATE_ID = $00000004;\r\n {$EXTERNALSYM CM_CREATE_DEVNODE_GENERATE_ID}\r\n CM_CREATE_DEVNODE_DO_NOT_INSTALL = $00000008;\r\n {$EXTERNALSYM CM_CREATE_DEVNODE_DO_NOT_INSTALL}\r\n CM_CREATE_DEVNODE_BITS = $0000000F;\r\n {$EXTERNALSYM CM_CREATE_DEVNODE_BITS}\r\n\r\n CM_CREATE_DEVINST_NORMAL = CM_CREATE_DEVNODE_NORMAL;\r\n {$EXTERNALSYM CM_CREATE_DEVINST_NORMAL}\r\n CM_CREATE_DEVINST_NO_WAIT_INSTALL = CM_CREATE_DEVNODE_NO_WAIT_INSTALL;\r\n {$EXTERNALSYM CM_CREATE_DEVINST_NO_WAIT_INSTALL}\r\n CM_CREATE_DEVINST_PHANTOM = CM_CREATE_DEVNODE_PHANTOM;\r\n {$EXTERNALSYM CM_CREATE_DEVINST_PHANTOM}\r\n CM_CREATE_DEVINST_GENERATE_ID = CM_CREATE_DEVNODE_GENERATE_ID;\r\n {$EXTERNALSYM CM_CREATE_DEVINST_GENERATE_ID}\r\n CM_CREATE_DEVINST_DO_NOT_INSTALL = CM_CREATE_DEVNODE_DO_NOT_INSTALL;\r\n {$EXTERNALSYM CM_CREATE_DEVINST_DO_NOT_INSTALL}\r\n CM_CREATE_DEVINST_BITS = CM_CREATE_DEVNODE_BITS;\r\n {$EXTERNALSYM CM_CREATE_DEVINST_BITS}\r\n\r\n //\r\n // Flags for CM_Delete_Class_Key\r\n //\r\n CM_DELETE_CLASS_ONLY = $00000000;\r\n {$EXTERNALSYM CM_DELETE_CLASS_ONLY}\r\n CM_DELETE_CLASS_SUBKEYS = $00000001;\r\n {$EXTERNALSYM CM_DELETE_CLASS_SUBKEYS}\r\n CM_DELETE_CLASS_BITS = $00000001;\r\n {$EXTERNALSYM CM_DELETE_CLASS_BITS}\r\n\r\n //\r\n // Detection reason flags (specified in call to CM_Run_Detection)\r\n //\r\n CM_DETECT_NEW_PROFILE = $00000001; // detection for new hw profile\r\n {$EXTERNALSYM CM_DETECT_NEW_PROFILE}\r\n CM_DETECT_CRASHED = $00000002; // Previous detection crashed\r\n {$EXTERNALSYM CM_DETECT_CRASHED}\r\n CM_DETECT_HWPROF_FIRST_BOOT = $00000004;\r\n {$EXTERNALSYM CM_DETECT_HWPROF_FIRST_BOOT}\r\n CM_DETECT_RUN = $80000000;\r\n {$EXTERNALSYM CM_DETECT_RUN}\r\n CM_DETECT_BITS = $80000007;\r\n {$EXTERNALSYM CM_DETECT_BITS}\r\n\r\n CM_DISABLE_POLITE = $00000000; // Ask the driver\r\n {$EXTERNALSYM CM_DISABLE_POLITE}\r\n CM_DISABLE_ABSOLUTE = $00000001; // Don't ask the driver\r\n {$EXTERNALSYM CM_DISABLE_ABSOLUTE}\r\n CM_DISABLE_HARDWARE = $00000002; // Don't ask the driver, and won't be restarteable\r\n {$EXTERNALSYM CM_DISABLE_HARDWARE}\r\n CM_DISABLE_UI_NOT_OK = $00000004; // Don't popup any veto API\r\n {$EXTERNALSYM CM_DISABLE_UI_NOT_OK}\r\n CM_DISABLE_BITS = $00000007; // The bits for the disable function\r\n {$EXTERNALSYM CM_DISABLE_BITS}\r\n\r\n //\r\n // Flags for CM_Get_Device_ID_List, CM_Get_Device_ID_List_Size\r\n //\r\n CM_GETIDLIST_FILTER_NONE = $00000000;\r\n {$EXTERNALSYM CM_GETIDLIST_FILTER_NONE}\r\n CM_GETIDLIST_FILTER_ENUMERATOR = $00000001;\r\n {$EXTERNALSYM CM_GETIDLIST_FILTER_ENUMERATOR}\r\n CM_GETIDLIST_FILTER_SERVICE = $00000002;\r\n {$EXTERNALSYM CM_GETIDLIST_FILTER_SERVICE}\r\n CM_GETIDLIST_FILTER_EJECTRELATIONS = $00000004;\r\n {$EXTERNALSYM CM_GETIDLIST_FILTER_EJECTRELATIONS}\r\n CM_GETIDLIST_FILTER_REMOVALRELATIONS = $00000008;\r\n {$EXTERNALSYM CM_GETIDLIST_FILTER_REMOVALRELATIONS}\r\n CM_GETIDLIST_FILTER_POWERRELATIONS = $00000010;\r\n {$EXTERNALSYM CM_GETIDLIST_FILTER_POWERRELATIONS}\r\n CM_GETIDLIST_FILTER_BUSRELATIONS = $00000020;\r\n {$EXTERNALSYM CM_GETIDLIST_FILTER_BUSRELATIONS}\r\n CM_GETIDLIST_DONOTGENERATE = $10000040;\r\n {$EXTERNALSYM CM_GETIDLIST_DONOTGENERATE}\r\n CM_GETIDLIST_FILTER_BITS = $1000007F;\r\n {$EXTERNALSYM CM_GETIDLIST_FILTER_BITS}\r\n\r\n //\r\n // Flags for CM_Get_Device_Interface_List, CM_Get_Device_Interface_List_Size\r\n //\r\n CM_GET_DEVICE_INTERFACE_LIST_PRESENT = $00000000; // only currently 'live' device interfaces\r\n {$EXTERNALSYM CM_GET_DEVICE_INTERFACE_LIST_PRESENT}\r\n CM_GET_DEVICE_INTERFACE_LIST_ALL_DEVICES = $00000001; // all registered device interfaces, live or not\r\n {$EXTERNALSYM CM_GET_DEVICE_INTERFACE_LIST_ALL_DEVICES}\r\n CM_GET_DEVICE_INTERFACE_LIST_BITS = $00000001;\r\n {$EXTERNALSYM CM_GET_DEVICE_INTERFACE_LIST_BITS}\r\n\r\n //\r\n // Registry properties (specified in call to CM_Get_DevInst_Registry_Property or CM_Get_Class_Registry_Property,\r\n // some are allowed in calls to CM_Set_DevInst_Registry_Property and CM_Set_Class_Registry_Property)\r\n // CM_DRP_xxxx values should be used for CM_Get_DevInst_Registry_Property / CM_Set_DevInst_Registry_Property\r\n // CM_CRP_xxxx values should be used for CM_Get_Class_Registry_Property / CM_Set_Class_Registry_Property\r\n // DRP/CRP values that overlap must have a 1:1 correspondence with each other\r\n //\r\n CM_DRP_DEVICEDESC = $00000001; // DeviceDesc REG_SZ property (RW)\r\n {$EXTERNALSYM CM_DRP_DEVICEDESC}\r\n CM_DRP_HARDWAREID = $00000002; // HardwareID REG_MULTI_SZ property (RW)\r\n {$EXTERNALSYM CM_DRP_HARDWAREID}\r\n CM_DRP_COMPATIBLEIDS = $00000003; // CompatibleIDs REG_MULTI_SZ property (RW)\r\n {$EXTERNALSYM CM_DRP_COMPATIBLEIDS}\r\n CM_DRP_UNUSED0 = $00000004; // unused\r\n {$EXTERNALSYM CM_DRP_UNUSED0}\r\n CM_DRP_SERVICE = $00000005; // Service REG_SZ property (RW)\r\n {$EXTERNALSYM CM_DRP_SERVICE}\r\n CM_DRP_UNUSED1 = $00000006; // unused\r\n {$EXTERNALSYM CM_DRP_UNUSED1}\r\n CM_DRP_UNUSED2 = $00000007; // unused\r\n {$EXTERNALSYM CM_DRP_UNUSED2}\r\n CM_DRP_CLASS = $00000008; // Class REG_SZ property (RW)\r\n {$EXTERNALSYM CM_DRP_CLASS}\r\n CM_DRP_CLASSGUID = $00000009; // ClassGUID REG_SZ property (RW)\r\n {$EXTERNALSYM CM_DRP_CLASSGUID}\r\n CM_DRP_DRIVER = $0000000A; // Driver REG_SZ property (RW)\r\n {$EXTERNALSYM CM_DRP_DRIVER}\r\n CM_DRP_CONFIGFLAGS = $0000000B; // ConfigFlags REG_DWORD property (RW)\r\n {$EXTERNALSYM CM_DRP_CONFIGFLAGS}\r\n CM_DRP_MFG = $0000000C; // Mfg REG_SZ property (RW)\r\n {$EXTERNALSYM CM_DRP_MFG}\r\n CM_DRP_FRIENDLYNAME = $0000000D; // FriendlyName REG_SZ property (RW)\r\n {$EXTERNALSYM CM_DRP_FRIENDLYNAME}\r\n CM_DRP_LOCATION_INFORMATION = $0000000E; // LocationInformation REG_SZ property (RW)\r\n {$EXTERNALSYM CM_DRP_LOCATION_INFORMATION}\r\n CM_DRP_PHYSICAL_DEVICE_OBJECT_NAME = $0000000F; // PhysicalDeviceObjectName REG_SZ property (R)\r\n {$EXTERNALSYM CM_DRP_PHYSICAL_DEVICE_OBJECT_NAME}\r\n CM_DRP_CAPABILITIES = $00000010; // Capabilities REG_DWORD property (R)\r\n {$EXTERNALSYM CM_DRP_CAPABILITIES}\r\n CM_DRP_UI_NUMBER = $00000011; // UiNumber REG_DWORD property (R)\r\n {$EXTERNALSYM CM_DRP_UI_NUMBER}\r\n CM_DRP_UPPERFILTERS = $00000012; // UpperFilters REG_MULTI_SZ property (RW)\r\n {$EXTERNALSYM CM_DRP_UPPERFILTERS}\r\n CM_DRP_LOWERFILTERS = $00000013; // LowerFilters REG_MULTI_SZ property (RW)\r\n {$EXTERNALSYM CM_DRP_LOWERFILTERS}\r\n CM_DRP_BUSTYPEGUID = $00000014; // Bus Type Guid, GUID, (R)\r\n {$EXTERNALSYM CM_DRP_BUSTYPEGUID}\r\n CM_DRP_LEGACYBUSTYPE = $00000015; // Legacy bus type, INTERFACE_TYPE, (R)\r\n {$EXTERNALSYM CM_DRP_LEGACYBUSTYPE}\r\n CM_DRP_BUSNUMBER = $00000016; // Bus Number, DWORD, (R)\r\n {$EXTERNALSYM CM_DRP_BUSNUMBER}\r\n CM_DRP_ENUMERATOR_NAME = $00000017; // Enumerator Name REG_SZ property (R)\r\n {$EXTERNALSYM CM_DRP_ENUMERATOR_NAME}\r\n CM_DRP_SECURITY = $00000018; // Security - Device override (RW)\r\n {$EXTERNALSYM CM_DRP_SECURITY}\r\n CM_CRP_SECURITY = CM_DRP_SECURITY; // Class default security (RW)\r\n {$EXTERNALSYM CM_CRP_SECURITY}\r\n CM_DRP_SECURITY_SDS = $00000019; // Security - Device override (RW)\r\n {$EXTERNALSYM CM_DRP_SECURITY_SDS}\r\n CM_CRP_SECURITY_SDS = CM_DRP_SECURITY_SDS; // Class default security (RW)\r\n {$EXTERNALSYM CM_CRP_SECURITY_SDS}\r\n CM_DRP_DEVTYPE = $0000001A; // Device Type - Device override (RW)\r\n {$EXTERNALSYM CM_DRP_DEVTYPE}\r\n CM_CRP_DEVTYPE = CM_DRP_DEVTYPE; // Class default Device-type (RW)\r\n {$EXTERNALSYM CM_CRP_DEVTYPE}\r\n CM_DRP_EXCLUSIVE = $0000001B; // Exclusivity - Device override (RW)\r\n {$EXTERNALSYM CM_DRP_EXCLUSIVE}\r\n CM_CRP_EXCLUSIVE = CM_DRP_EXCLUSIVE; // Class default (RW)\r\n {$EXTERNALSYM CM_CRP_EXCLUSIVE}\r\n CM_DRP_CHARACTERISTICS = $0000001C; // Characteristics - Device Override (RW)\r\n {$EXTERNALSYM CM_DRP_CHARACTERISTICS}\r\n CM_CRP_CHARACTERISTICS = CM_DRP_CHARACTERISTICS; // Class default (RW)\r\n {$EXTERNALSYM CM_CRP_CHARACTERISTICS}\r\n CM_DRP_ADDRESS = $0000001D; // Device Address (R)\r\n {$EXTERNALSYM CM_DRP_ADDRESS}\r\n CM_DRP_UI_NUMBER_DESC_FORMAT = $0000001E; // UINumberDescFormat REG_SZ property (RW)\r\n {$EXTERNALSYM CM_DRP_UI_NUMBER_DESC_FORMAT}\r\n CM_DRP_DEVICE_POWER_DATA = $0000001F; // CM_POWER_DATA REG_BINARY property (R)\r\n {$EXTERNALSYM CM_DRP_DEVICE_POWER_DATA}\r\n CM_DRP_REMOVAL_POLICY = $00000020; // CM_DEVICE_REMOVAL_POLICY REG_DWORD (R)\r\n {$EXTERNALSYM CM_DRP_REMOVAL_POLICY}\r\n CM_DRP_REMOVAL_POLICY_HW_DEFAULT = $00000021; // CM_DRP_REMOVAL_POLICY_HW_DEFAULT REG_DWORD (R)\r\n {$EXTERNALSYM CM_DRP_REMOVAL_POLICY_HW_DEFAULT}\r\n CM_DRP_REMOVAL_POLICY_OVERRIDE = $00000022; // CM_DRP_REMOVAL_POLICY_OVERRIDE REG_DWORD (RW)\r\n {$EXTERNALSYM CM_DRP_REMOVAL_POLICY_OVERRIDE}\r\n CM_DRP_INSTALL_STATE = $00000023; // CM_DRP_INSTALL_STATE REG_DWORD (R)\r\n {$EXTERNALSYM CM_DRP_INSTALL_STATE}\r\n\r\n CM_DRP_MIN = $00000001; // First device register\r\n {$EXTERNALSYM CM_DRP_MIN}\r\n CM_CRP_MIN = CM_DRP_MIN; // First class register\r\n {$EXTERNALSYM CM_CRP_MIN}\r\n CM_DRP_MAX = $00000023; // Last device register\r\n {$EXTERNALSYM CM_DRP_MAX}\r\n CM_CRP_MAX = CM_DRP_MAX; // Last class register\r\n {$EXTERNALSYM CM_CRP_MAX}\r\n\r\n //\r\n // Capabilities bits (the capability value is returned from calling\r\n // CM_Get_DevInst_Registry_Property with CM_DRP_CAPABILITIES property)\r\n //\r\n CM_DEVCAP_LOCKSUPPORTED = $00000001;\r\n {$EXTERNALSYM CM_DEVCAP_LOCKSUPPORTED}\r\n CM_DEVCAP_EJECTSUPPORTED = $00000002;\r\n {$EXTERNALSYM CM_DEVCAP_EJECTSUPPORTED}\r\n CM_DEVCAP_REMOVABLE = $00000004;\r\n {$EXTERNALSYM CM_DEVCAP_REMOVABLE}\r\n CM_DEVCAP_DOCKDEVICE = $00000008;\r\n {$EXTERNALSYM CM_DEVCAP_DOCKDEVICE}\r\n CM_DEVCAP_UNIQUEID = $00000010;\r\n {$EXTERNALSYM CM_DEVCAP_UNIQUEID}\r\n CM_DEVCAP_SILENTINSTALL = $00000020;\r\n {$EXTERNALSYM CM_DEVCAP_SILENTINSTALL}\r\n CM_DEVCAP_RAWDEVICEOK = $00000040;\r\n {$EXTERNALSYM CM_DEVCAP_RAWDEVICEOK}\r\n CM_DEVCAP_SURPRISEREMOVALOK = $00000080;\r\n {$EXTERNALSYM CM_DEVCAP_SURPRISEREMOVALOK}\r\n CM_DEVCAP_HARDWAREDISABLED = $00000100;\r\n {$EXTERNALSYM CM_DEVCAP_HARDWAREDISABLED}\r\n CM_DEVCAP_NONDYNAMIC = $00000200;\r\n {$EXTERNALSYM CM_DEVCAP_NONDYNAMIC}\r\n\r\n //\r\n // Removal policies (retrievable via CM_Get_DevInst_Registry_Property with\r\n // the CM_DRP_REMOVAL_POLICY, CM_DRP_REMOVAL_POLICY_OVERRIDE, or\r\n // CM_DRP_REMOVAL_POLICY_HW_DEFAULT properties)\r\n //\r\n CM_REMOVAL_POLICY_EXPECT_NO_REMOVAL = 1;\r\n {$EXTERNALSYM CM_REMOVAL_POLICY_EXPECT_NO_REMOVAL}\r\n CM_REMOVAL_POLICY_EXPECT_ORDERLY_REMOVAL = 2;\r\n {$EXTERNALSYM CM_REMOVAL_POLICY_EXPECT_ORDERLY_REMOVAL}\r\n CM_REMOVAL_POLICY_EXPECT_SURPRISE_REMOVAL = 3;\r\n {$EXTERNALSYM CM_REMOVAL_POLICY_EXPECT_SURPRISE_REMOVAL}\r\n\r\n //\r\n // Device install states (retrievable via CM_Get_DevInst_Registry_Property with\r\n // the CM_DRP_INSTALL_STATE properties)\r\n //\r\n CM_INSTALL_STATE_INSTALLED = 0;\r\n {$EXTERNALSYM CM_INSTALL_STATE_INSTALLED}\r\n CM_INSTALL_STATE_NEEDS_REINSTALL = 1;\r\n {$EXTERNALSYM CM_INSTALL_STATE_NEEDS_REINSTALL}\r\n CM_INSTALL_STATE_FAILED_INSTALL = 2;\r\n {$EXTERNALSYM CM_INSTALL_STATE_FAILED_INSTALL}\r\n CM_INSTALL_STATE_FINISH_INSTALL = 3;\r\n {$EXTERNALSYM CM_INSTALL_STATE_FINISH_INSTALL}\r\n\r\n //\r\n // Flags for CM_Locate_DevNode\r\n //\r\n CM_LOCATE_DEVNODE_NORMAL = $00000000;\r\n {$EXTERNALSYM CM_LOCATE_DEVNODE_NORMAL}\r\n CM_LOCATE_DEVNODE_PHANTOM = $00000001;\r\n {$EXTERNALSYM CM_LOCATE_DEVNODE_PHANTOM}\r\n CM_LOCATE_DEVNODE_CANCELREMOVE = $00000002;\r\n {$EXTERNALSYM CM_LOCATE_DEVNODE_CANCELREMOVE}\r\n CM_LOCATE_DEVNODE_NOVALIDATION = $00000004;\r\n {$EXTERNALSYM CM_LOCATE_DEVNODE_NOVALIDATION}\r\n CM_LOCATE_DEVNODE_BITS = $00000007;\r\n {$EXTERNALSYM CM_LOCATE_DEVNODE_BITS}\r\n\r\n CM_LOCATE_DEVINST_NORMAL = CM_LOCATE_DEVNODE_NORMAL;\r\n {$EXTERNALSYM CM_LOCATE_DEVINST_NORMAL}\r\n CM_LOCATE_DEVINST_PHANTOM = CM_LOCATE_DEVNODE_PHANTOM;\r\n {$EXTERNALSYM CM_LOCATE_DEVINST_PHANTOM}\r\n CM_LOCATE_DEVINST_CANCELREMOVE = CM_LOCATE_DEVNODE_CANCELREMOVE;\r\n {$EXTERNALSYM CM_LOCATE_DEVINST_CANCELREMOVE}\r\n CM_LOCATE_DEVINST_NOVALIDATION = CM_LOCATE_DEVNODE_NOVALIDATION;\r\n {$EXTERNALSYM CM_LOCATE_DEVINST_NOVALIDATION}\r\n CM_LOCATE_DEVINST_BITS = CM_LOCATE_DEVNODE_BITS;\r\n {$EXTERNALSYM CM_LOCATE_DEVINST_BITS}\r\n\r\n //\r\n // Flags for CM_Open_Class_Key\r\n //\r\n CM_OPEN_CLASS_KEY_INSTALLER = $00000000;\r\n {$EXTERNALSYM CM_OPEN_CLASS_KEY_INSTALLER}\r\n CM_OPEN_CLASS_KEY_INTERFACE = $00000001;\r\n {$EXTERNALSYM CM_OPEN_CLASS_KEY_INTERFACE}\r\n CM_OPEN_CLASS_KEY_BITS = $00000001;\r\n {$EXTERNALSYM CM_OPEN_CLASS_KEY_BITS}\r\n\r\n //\r\n // Flags for CM_Query_And_Remove_SubTree\r\n //\r\n CM_REMOVE_UI_OK = $00000000;\r\n {$EXTERNALSYM CM_REMOVE_UI_OK}\r\n CM_REMOVE_UI_NOT_OK = $00000001;\r\n {$EXTERNALSYM CM_REMOVE_UI_NOT_OK}\r\n CM_REMOVE_NO_RESTART = $00000002;\r\n {$EXTERNALSYM CM_REMOVE_NO_RESTART}\r\n CM_REMOVE_BITS = $00000003;\r\n {$EXTERNALSYM CM_REMOVE_BITS}\r\n\r\n //\r\n // Backward compatibility--do not use\r\n // (use above CM_REMOVE_* flags instead)\r\n //\r\n CM_QUERY_REMOVE_UI_OK = CM_REMOVE_UI_OK;\r\n {$EXTERNALSYM CM_QUERY_REMOVE_UI_OK}\r\n CM_QUERY_REMOVE_UI_NOT_OK = CM_REMOVE_UI_NOT_OK;\r\n {$EXTERNALSYM CM_QUERY_REMOVE_UI_NOT_OK}\r\n CM_QUERY_REMOVE_BITS = CM_QUERY_REMOVE_UI_OK or CM_QUERY_REMOVE_UI_NOT_OK;\r\n {$EXTERNALSYM CM_QUERY_REMOVE_BITS}\r\n\r\n //\r\n // Flags for CM_Reenumerate_DevNode\r\n //\r\n CM_REENUMERATE_NORMAL = $00000000;\r\n {$EXTERNALSYM CM_REENUMERATE_NORMAL}\r\n CM_REENUMERATE_SYNCHRONOUS = $00000001;\r\n {$EXTERNALSYM CM_REENUMERATE_SYNCHRONOUS}\r\n CM_REENUMERATE_RETRY_INSTALLATION = $00000002;\r\n {$EXTERNALSYM CM_REENUMERATE_RETRY_INSTALLATION}\r\n CM_REENUMERATE_ASYNCHRONOUS = $00000004;\r\n {$EXTERNALSYM CM_REENUMERATE_ASYNCHRONOUS}\r\n CM_REENUMERATE_BITS = $00000007;\r\n {$EXTERNALSYM CM_REENUMERATE_BITS}\r\n\r\n //\r\n // Flags for CM_Register_Device_Driver\r\n //\r\n CM_REGISTER_DEVICE_DRIVER_STATIC = $00000000;\r\n {$EXTERNALSYM CM_REGISTER_DEVICE_DRIVER_STATIC}\r\n CM_REGISTER_DEVICE_DRIVER_DISABLEABLE = $00000001;\r\n {$EXTERNALSYM CM_REGISTER_DEVICE_DRIVER_DISABLEABLE}\r\n CM_REGISTER_DEVICE_DRIVER_REMOVABLE = $00000002;\r\n {$EXTERNALSYM CM_REGISTER_DEVICE_DRIVER_REMOVABLE}\r\n CM_REGISTER_DEVICE_DRIVER_BITS = $00000003;\r\n {$EXTERNALSYM CM_REGISTER_DEVICE_DRIVER_BITS}\r\n\r\n //\r\n // Registry Branch Locations (for CM_Open_DevNode_Key)\r\n //\r\n CM_REGISTRY_HARDWARE = $00000000;\r\n {$EXTERNALSYM CM_REGISTRY_HARDWARE}\r\n CM_REGISTRY_SOFTWARE = $00000001;\r\n {$EXTERNALSYM CM_REGISTRY_SOFTWARE}\r\n CM_REGISTRY_USER = $00000100;\r\n {$EXTERNALSYM CM_REGISTRY_USER}\r\n CM_REGISTRY_CONFIG = $00000200;\r\n {$EXTERNALSYM CM_REGISTRY_CONFIG}\r\n CM_REGISTRY_BITS = $00000301;\r\n {$EXTERNALSYM CM_REGISTRY_BITS}\r\n\r\n //\r\n // Flags for CM_Set_DevNode_Problem\r\n //\r\n CM_SET_DEVNODE_PROBLEM_NORMAL = $00000000; // only set problem if currently no problem\r\n {$EXTERNALSYM CM_SET_DEVNODE_PROBLEM_NORMAL}\r\n CM_SET_DEVNODE_PROBLEM_OVERRIDE = $00000001; // override current problem with new problem\r\n {$EXTERNALSYM CM_SET_DEVNODE_PROBLEM_OVERRIDE}\r\n CM_SET_DEVNODE_PROBLEM_BITS = $00000001;\r\n {$EXTERNALSYM CM_SET_DEVNODE_PROBLEM_BITS}\r\n\r\n CM_SET_DEVINST_PROBLEM_NORMAL = CM_SET_DEVNODE_PROBLEM_NORMAL;\r\n {$EXTERNALSYM CM_SET_DEVINST_PROBLEM_NORMAL}\r\n CM_SET_DEVINST_PROBLEM_OVERRIDE = CM_SET_DEVNODE_PROBLEM_OVERRIDE;\r\n {$EXTERNALSYM CM_SET_DEVINST_PROBLEM_OVERRIDE}\r\n CM_SET_DEVINST_PROBLEM_BITS = CM_SET_DEVNODE_PROBLEM_BITS;\r\n {$EXTERNALSYM CM_SET_DEVINST_PROBLEM_BITS}\r\n\r\n //\r\n // Flags for CM_Set_HW_Prof_Flags\r\n //\r\n CM_SET_HW_PROF_FLAGS_UI_NOT_OK = $00000001; // Don't popup any veto UI\r\n {$EXTERNALSYM CM_SET_HW_PROF_FLAGS_UI_NOT_OK}\r\n CM_SET_HW_PROF_FLAGS_BITS = $00000001;\r\n {$EXTERNALSYM CM_SET_HW_PROF_FLAGS_BITS}\r\n\r\n //\r\n // Re-enable and configuration actions (specified in call to CM_Setup_DevInst)\r\n //\r\n CM_SETUP_DEVNODE_READY = $00000000; // Reenable problem devinst\r\n {$EXTERNALSYM CM_SETUP_DEVNODE_READY}\r\n CM_SETUP_DEVINST_READY = CM_SETUP_DEVNODE_READY;\r\n {$EXTERNALSYM CM_SETUP_DEVINST_READY}\r\n CM_SETUP_DOWNLOAD = $00000001; // Get info about devinst\r\n {$EXTERNALSYM CM_SETUP_DOWNLOAD}\r\n CM_SETUP_WRITE_LOG_CONFS = $00000002;\r\n {$EXTERNALSYM CM_SETUP_WRITE_LOG_CONFS}\r\n CM_SETUP_PROP_CHANGE = $00000003;\r\n {$EXTERNALSYM CM_SETUP_PROP_CHANGE}\r\n CM_SETUP_DEVNODE_RESET = $00000004; // Reset problem devinst without starting\r\n {$EXTERNALSYM CM_SETUP_DEVNODE_RESET}\r\n CM_SETUP_DEVINST_RESET = CM_SETUP_DEVNODE_RESET;\r\n {$EXTERNALSYM CM_SETUP_DEVINST_RESET}\r\n CM_SETUP_BITS = $00000007;\r\n {$EXTERNALSYM CM_SETUP_BITS}\r\n\r\n //\r\n // Flags for CM_Query_Arbitrator_Free_Data and\r\n // CM_Query_Arbitrator_Free_Data_Size.\r\n //\r\n CM_QUERY_ARBITRATOR_RAW = $00000000;\r\n {$EXTERNALSYM CM_QUERY_ARBITRATOR_RAW}\r\n CM_QUERY_ARBITRATOR_TRANSLATED = $00000001;\r\n {$EXTERNALSYM CM_QUERY_ARBITRATOR_TRANSLATED}\r\n CM_QUERY_ARBITRATOR_BITS = $00000001;\r\n {$EXTERNALSYM CM_QUERY_ARBITRATOR_BITS}\r\n\r\n //\r\n // Flags for CM_Get_DevNode_Custom_Property\r\n //\r\n CM_CUSTOMDEVPROP_MERGE_MULTISZ = $00000001;\r\n {$EXTERNALSYM CM_CUSTOMDEVPROP_MERGE_MULTISZ}\r\n CM_CUSTOMDEVPROP_BITS = $00000001;\r\n {$EXTERNALSYM CM_CUSTOMDEVPROP_BITS}\r\n\r\n//--------------------------------------------------------------\r\n// Function prototypes\r\n//--------------------------------------------------------------\r\n\r\n{$IFNDEF CFGMGR32_LINKONREQUEST}\r\n\r\nfunction CM_Add_Empty_Log_Conf(var lcLogConf: LOG_CONF;\r\n dnDevInst: DEVINST; Priority: PRIORITY; ulFlags: ULONG): CONFIGRET; stdcall;\r\n\r\nfunction CM_Add_Empty_Log_Conf_Ex(var lcLogConf: LOG_CONF;\r\n dnDevInst: DEVINST; Priority: PRIORITY; ulFlags: ULONG;\r\n hMachine: HMACHINE): CONFIGRET; stdcall;\r\n\r\nfunction CM_Add_IDA(dnDevInst: DEVINST; pszID: PAnsiChar;\r\n ulFlags: ULONG): CONFIGRET; stdcall;\r\nfunction CM_Add_IDW(dnDevInst: DEVINST; pszID: PWideChar;\r\n ulFlags: ULONG): CONFIGRET; stdcall;\r\nfunction CM_Add_ID(dnDevInst: DEVINST; pszID: PTSTR;\r\n ulFlags: ULONG): CONFIGRET; stdcall;\r\n\r\nfunction CM_Add_ID_ExA(dnDevInst: DEVINST; pszID: PAnsiChar;\r\n ulFlags: ULONG; hMachine: HMACHINE): CONFIGRET; stdcall;\r\nfunction CM_Add_ID_ExW(dnDevInst: DEVINST; pszID: PWideChar;\r\n ulFlags: ULONG; hMachine: HMACHINE): CONFIGRET; stdcall;\r\nfunction CM_Add_ID_Ex(dnDevInst: DEVINST; pszID: PTSTR;\r\n ulFlags: ULONG; hMachine: HMACHINE): CONFIGRET; stdcall;\r\n\r\nfunction CM_Add_Range(ullStartValue: DWORDLONG;\r\n ullEndValue: DWORDLONG; rlh: RANGE_LIST;\r\n ulFlags: ULONG): CONFIGRET; stdcall;\r\n\r\nfunction CM_Add_Res_Des(var rdResDes: RES_DES; lcLogConf: LOG_CONF;\r\n ResourceID: RESOURCEID; ResourceData: Pointer; ResourceLen: ULONG;\r\n ulFlags: ULONG): CONFIGRET; stdcall;\r\n\r\nfunction CM_Add_Res_Des_Ex(var rdResDes: RES_DES;\r\n lcLogConf: LOG_CONF; ResourceID: RESOURCEID; ResourceData: Pointer;\r\n ResourceLen: ULONG; ulFlags: ULONG; hMachine: HMACHINE): CONFIGRET; stdcall;\r\n\r\nfunction CM_Connect_MachineA(const UNCServerName: PAnsiChar;\r\n var hMachine: HMACHINE): CONFIGRET; stdcall;\r\nfunction CM_Connect_MachineW(const UNCServerName: PWideChar;\r\n var hMachine: HMACHINE): CONFIGRET; stdcall;\r\nfunction CM_Connect_Machine(const UNCServerName: PTSTR;\r\n var hMachine: HMACHINE): CONFIGRET; stdcall;\r\n\r\nfunction CM_Create_DevNodeA(var dnDevInst: DEVINST; pDeviceID: DEVINSTID_A;\r\n dnParent: DEVINST; ulFlags: ULONG): CONFIGRET; stdcall;\r\nfunction CM_Create_DevNodeW(var dnDevInst: DEVINST; pDeviceID: DEVINSTID_W;\r\n dnParent: DEVINST; ulFlags: ULONG): CONFIGRET; stdcall;\r\nfunction CM_Create_DevNode(var dnDevInst: DEVINST; pDeviceID: DEVINSTID;\r\n dnParent: DEVINST; ulFlags: ULONG): CONFIGRET; stdcall;\r\n\r\nfunction CM_Create_DevNode_ExA(var dnDevInst: DEVINST; pDeviceID: DEVINSTID_A;\r\n dnParent: DEVINST; ulFlags: ULONG; hMachine: HMACHINE): CONFIGRET; stdcall;\r\nfunction CM_Create_DevNode_ExW(var dnDevInst: DEVINST; pDeviceID: DEVINSTID_W;\r\n dnParent: DEVINST; ulFlags: ULONG; hMachine: HMACHINE): CONFIGRET; stdcall;\r\nfunction CM_Create_DevNode_Ex(var dnDevInst: DEVINST; pDeviceID: DEVINSTID;\r\n dnParent: DEVINST; ulFlags: ULONG; hMachine: HMACHINE): CONFIGRET; stdcall;\r\n\r\nfunction CM_Create_DevInstA(var dnDevInst: DEVINST; pDeviceID: DEVINSTID_A;\r\n dnParent: DEVINST; ulFlags: ULONG): CONFIGRET; stdcall;\r\nfunction CM_Create_DevInstW(var dnDevInst: DEVINST; pDeviceID: DEVINSTID_W;\r\n dnParent: DEVINST; ulFlags: ULONG): CONFIGRET; stdcall;\r\nfunction CM_Create_DevInst(var dnDevInst: DEVINST; pDeviceID: DEVINSTID;\r\n dnParent: DEVINST; ulFlags: ULONG): CONFIGRET; stdcall;\r\n\r\nfunction CM_Create_DevInst_ExA(var dnDevInst: DEVINST; pDeviceID: DEVINSTID_A;\r\n dnParent: DEVINST; ulFlags: ULONG; hMachine: HMACHINE): CONFIGRET; stdcall;\r\nfunction CM_Create_DevInst_ExW(var dnDevInst: DEVINST; pDeviceID: DEVINSTID_W;\r\n dnParent: DEVINST; ulFlags: ULONG; hMachine: HMACHINE): CONFIGRET; stdcall;\r\n\r\nfunction CM_Create_DevInst_Ex(var dnDevInst: DEVINST; pDeviceID: DEVINSTID;\r\n dnParent: DEVINST; ulFlags: ULONG; hMachine: HMACHINE): CONFIGRET; stdcall;\r\n\r\nfunction CM_Create_Range_List(var rlh: RANGE_LIST; ulFlags: ULONG): CONFIGRET; stdcall;\r\n\r\nfunction CM_Delete_Class_Key(ClassGuid: PGUID; ulFlags: ULONG): CONFIGRET; stdcall;\r\n\r\nfunction CM_Delete_Class_Key_Ex(ClassGuid: PGUID; ulFlags: ULONG;\r\n hMachine: HMACHINE): CONFIGRET; stdcall;\r\n\r\nfunction CM_Delete_DevNode_Key(dnDevNode: DEVNODE;\r\n ulHardwareProfile: ULONG; ulFlags: ULONG): CONFIGRET; stdcall;\r\n\r\nfunction CM_Delete_DevNode_Key_Ex(dnDevNode: DEVNODE;\r\n ulHardwareProfile: ULONG; ulFlags: ULONG; hMachine: HMACHINE): CONFIGRET; stdcall;\r\n\r\nfunction CM_Delete_DevInst_Key(dnDevNode: DEVINST;\r\n ulHardwareProfile: ULONG; ulFlags: ULONG): CONFIGRET; stdcall;\r\n\r\nfunction CM_Delete_DevInst_Key_Ex(dnDevNode: DEVINST; ulHardwareProfile: ULONG;\r\n ulFlags: ULONG; hMachine: HMACHINE): CONFIGRET; stdcall;\r\n\r\nfunction CM_Delete_Range(ullStartValue: DWORDLONG; ullEndValue: DWORDLONG;\r\n rlh: RANGE_LIST; ulFlags: ULONG): CONFIGRET; stdcall;\r\n\r\nfunction CM_Detect_Resource_Conflict(dnDevInst: DEVINST;\r\n ResourceID: RESOURCEID; ResourceData: Pointer; ResourceLen: ULONG;\r\n var bConflictDetected: BOOL; ulFlags: ULONG): CONFIGRET; stdcall;\r\n\r\nfunction CM_Detect_Resource_Conflict_Ex(dnDevInst: DEVINST;\r\n ResourceID: RESOURCEID; ResourceData: Pointer; ResourceLen: ULONG;\r\n var bConflictDetected: BOOL; ulFlags: ULONG; hMachine: HMACHINE): CONFIGRET; stdcall;\r\n\r\nfunction CM_Disable_DevNode(dnDevInst: DEVINST; ulFlags: ULONG): CONFIGRET; stdcall;\r\n\r\nfunction CM_Disable_DevNode_Ex(dnDevInst: DEVINST;\r\n ulFlags: ULONG; hMachine: HMACHINE): CONFIGRET; stdcall;\r\n\r\nfunction CM_Disable_DevInst(dnDevInst: DEVINST; ulFlags: ULONG): CONFIGRET; stdcall;\r\n\r\nfunction CM_Disable_DevInst_Ex(dnDevInst: DEVINST;\r\n ulFlags: ULONG; hMachine: HMACHINE): CONFIGRET; stdcall;\r\n\r\nfunction CM_Disconnect_Machine(hMachine: HMACHINE): CONFIGRET; stdcall;\r\n\r\nfunction CM_Dup_Range_List(rlhOld: RANGE_LIST; rlhNew: RANGE_LIST;\r\n ulFlags: ULONG): CONFIGRET; stdcall;\r\n\r\nfunction CM_Enable_DevNode(dnDevInst: DEVINST; ulFlags: ULONG): CONFIGRET; stdcall;\r\n\r\nfunction CM_Enable_DevNode_Ex(dnDevInst: DEVINST;\r\n ulFlags: ULONG; hMachine: HMACHINE): CONFIGRET; stdcall;\r\n\r\nfunction CM_Enable_DevInst(dnDevInst: DEVINST; ulFlags: ULONG): CONFIGRET; stdcall;\r\n\r\nfunction CM_Enable_DevInst_Ex(dnDevInst: DEVINST;\r\n ulFlags: ULONG; hMachine: HMACHINE): CONFIGRET; stdcall;\r\n\r\nfunction CM_Enumerate_Classes(ulClassIndex: ULONG;\r\n var ClassGuid: TGUID; ulFlags: ULONG): CONFIGRET; stdcall;\r\n\r\nfunction CM_Enumerate_Classes_Ex(ulClassIndex: ULONG; var ClassGuid: TGUID;\r\n ulFlags: ULONG; hMachine: HMACHINE): CONFIGRET; stdcall;\r\n\r\nfunction CM_Enumerate_EnumeratorsA(ulEnumIndex: ULONG; Buffer: PAnsiChar;\r\n var ulLength: ULONG; ulFlags: ULONG): CONFIGRET; stdcall;\r\nfunction CM_Enumerate_EnumeratorsW(ulEnumIndex: ULONG; Buffer: PWideChar;\r\n var ulLength: ULONG; ulFlags: ULONG): CONFIGRET; stdcall;\r\nfunction CM_Enumerate_Enumerators(ulEnumIndex: ULONG; Buffer: PTSTR;\r\n var ulLength: ULONG; ulFlags: ULONG): CONFIGRET; stdcall;\r\n\r\nfunction CM_Enumerate_Enumerators_ExA(ulEnumIndex: ULONG; Buffer: PAnsiChar;\r\n var ulLength: ULONG; ulFlags: ULONG; hMachine: HMACHINE): CONFIGRET; stdcall;\r\nfunction CM_Enumerate_Enumerators_ExW(ulEnumIndex: ULONG; Buffer: PWideChar;\r\n var ulLength: ULONG; ulFlags: ULONG; hMachine: HMACHINE): CONFIGRET; stdcall;\r\nfunction CM_Enumerate_Enumerators_Ex(ulEnumIndex: ULONG; Buffer: PTSTR;\r\n var ulLength: ULONG; ulFlags: ULONG; hMachine: HMACHINE): CONFIGRET; stdcall;\r\n\r\nfunction CM_Find_Range(var pullStart: DWORDLONG; ullStart: DWORDLONG;\r\n ulLength: ULONG; ullAlignment: DWORDLONG; ullEnd: DWORDLONG;\r\n rlh: RANGE_LIST; ulFlags: ULONG): CONFIGRET; stdcall;\r\n\r\nfunction CM_First_Range(rlh: RANGE_LIST; var ullStart: DWORDLONG;\r\n var ullEnd: DWORDLONG; preElement: PRANGE_ELEMENT;\r\n ulFlags: ULONG): CONFIGRET; stdcall;\r\n\r\nfunction CM_Free_Log_Conf(lcLogConfToBeFreed: LOG_CONF;\r\n ulFlags: ULONG): CONFIGRET; stdcall;\r\n\r\nfunction CM_Free_Log_Conf_Ex(lcLogConfToBeFreed: LOG_CONF;\r\n ulFlags: ULONG; hMachine: HMACHINE): CONFIGRET; stdcall;\r\n\r\nfunction CM_Free_Log_Conf_Handle(lcLogConf: LOG_CONF): CONFIGRET; stdcall;\r\n\r\nfunction CM_Free_Range_List(rlh: RANGE_LIST; ulFlags: ULONG): CONFIGRET; stdcall;\r\n\r\nfunction CM_Free_Res_Des(prdResDes: PRES_DES;\r\n rdResDes: RES_DES; ulFlags: ULONG): CONFIGRET; stdcall;\r\n\r\nfunction CM_Free_Res_Des_Ex(prdResDes: PRES_DES; rdResDes: RES_DES;\r\n ulFlags: ULONG; hMachine: HMACHINE): CONFIGRET; stdcall;\r\n\r\nfunction CM_Free_Res_Des_Handle(rdResDes: RES_DES): CONFIGRET; stdcall;\r\n\r\nfunction CM_Get_Child(var dnDevInstChild: DEVINST;\r\n dnDevInst: DEVINST; ulFlags: ULONG): CONFIGRET; stdcall;\r\n\r\nfunction CM_Get_Child_Ex(var dnDevInstChild: DEVINST; dnDevInst: DEVINST;\r\n ulFlags: ULONG; hMachine: HMACHINE): CONFIGRET; stdcall;\r\n\r\nfunction CM_Get_Class_NameA(ClassGuid: PGUID; Buffer: PAnsiChar;\r\n var ulLength: ULONG; ulFlags: ULONG): CONFIGRET; stdcall;\r\nfunction CM_Get_Class_NameW(ClassGuid: PGUID; Buffer: PWideChar;\r\n var ulLength: ULONG; ulFlags: ULONG): CONFIGRET; stdcall;\r\nfunction CM_Get_Class_Name(ClassGuid: PGUID; Buffer: PTSTR;\r\n var ulLength: ULONG; ulFlags: ULONG): CONFIGRET; stdcall;\r\n\r\nfunction CM_Get_Class_Name_ExA(ClassGuid: PGUID; Buffer: PAnsiChar;\r\n var ulLength: ULONG; ulFlags: ULONG; hMachine: HMACHINE): CONFIGRET; stdcall;\r\nfunction CM_Get_Class_Name_ExW(ClassGuid: PGUID; Buffer: PWideChar;\r\n var ulLength: ULONG; ulFlags: ULONG; hMachine: HMACHINE): CONFIGRET; stdcall;\r\nfunction CM_Get_Class_Name_Ex(ClassGuid: PGUID; Buffer: PTSTR;\r\n var ulLength: ULONG; ulFlags: ULONG; hMachine: HMACHINE): CONFIGRET; stdcall;\r\n\r\nfunction CM_Get_Class_Key_NameA(ClassGuid: PGUID; pszKeyName: PAnsiChar;\r\n var ulLength: ULONG; ulFlags: ULONG): CONFIGRET; stdcall;\r\nfunction CM_Get_Class_Key_NameW(ClassGuid: PGUID; pszKeyName: PWideChar;\r\n var ulLength: ULONG; ulFlags: ULONG): CONFIGRET; stdcall;\r\nfunction CM_Get_Class_Key_Name(ClassGuid: PGUID; pszKeyName: PTSTR;\r\n var ulLength: ULONG; ulFlags: ULONG): CONFIGRET; stdcall;\r\n\r\nfunction CM_Get_Class_Key_Name_ExA(ClassGuid: PGUID; pszKeyName: PAnsiChar;\r\n var ulLength: ULONG; ulFlags: ULONG; hMachine: HMACHINE): CONFIGRET; stdcall;\r\nfunction CM_Get_Class_Key_Name_ExW(ClassGuid: PGUID; pszKeyName: PWideChar;\r\n var ulLength: ULONG; ulFlags: ULONG; hMachine: HMACHINE): CONFIGRET; stdcall;\r\nfunction CM_Get_Class_Key_Name_Ex(ClassGuid: PGUID; pszKeyName: PTSTR;\r\n var ulLength: ULONG; ulFlags: ULONG; hMachine: HMACHINE): CONFIGRET; stdcall;\r\n\r\nfunction CM_Get_Depth(var ulDepth: ULONG; dnDevInst: DEVINST;\r\n ulFlags: ULONG): CONFIGRET; stdcall;\r\n\r\nfunction CM_Get_Depth_Ex(var ulDepth: ULONG; dnDevInst: DEVINST;\r\n ulFlags: ULONG; hMachine: HMACHINE): CONFIGRET; stdcall;\r\n\r\nfunction CM_Get_Device_IDA(dnDevInst: DEVINST; Buffer: PAnsiChar;\r\n BufferLen: ULONG; ulFlags: ULONG): CONFIGRET; stdcall;\r\nfunction CM_Get_Device_IDW(dnDevInst: DEVINST; Buffer: PWideChar;\r\n BufferLen: ULONG; ulFlags: ULONG): CONFIGRET; stdcall;\r\nfunction CM_Get_Device_ID(dnDevInst: DEVINST; Buffer: PTSTR;\r\n BufferLen: ULONG; ulFlags: ULONG): CONFIGRET; stdcall;\r\n\r\nfunction CM_Get_Device_ID_ExA(dnDevInst: DEVINST; Buffer: PAnsiChar;\r\n BufferLen: ULONG; ulFlags: ULONG; hMachine: HMACHINE): CONFIGRET; stdcall;\r\nfunction CM_Get_Device_ID_ExW(dnDevInst: DEVINST; Buffer: PWideChar;\r\n BufferLen: ULONG; ulFlags: ULONG; hMachine: HMACHINE): CONFIGRET; stdcall;\r\nfunction CM_Get_Device_ID_Ex(dnDevInst: DEVINST; Buffer: PTSTR;\r\n BufferLen: ULONG; ulFlags: ULONG; hMachine: HMACHINE): CONFIGRET; stdcall;\r\n\r\nfunction CM_Get_Device_ID_ListA(const pszFilter: PAnsiChar; // OPTIONAL\r\n Buffer: PAnsiChar; BufferLen: ULONG; ulFlags: ULONG): CONFIGRET; stdcall;\r\nfunction CM_Get_Device_ID_ListW(const pszFilter: PWideChar; // OPTIONAL\r\n Buffer: PWideChar; BufferLen: ULONG; ulFlags: ULONG): CONFIGRET; stdcall;\r\nfunction CM_Get_Device_ID_List(const pszFilter: PTSTR; // OPTIONAL\r\n Buffer: PTSTR; BufferLen: ULONG; ulFlags: ULONG): CONFIGRET; stdcall;\r\n\r\nfunction CM_Get_Device_ID_List_ExA(const pszFilter: PAnsiChar; // OPTIONAL\r\n Buffer: PAnsiChar; BufferLen: ULONG; ulFlags: ULONG;\r\n hMachine: HMACHINE): CONFIGRET; stdcall;\r\nfunction CM_Get_Device_ID_List_ExW(const pszFilter: PWideChar; // OPTIONAL\r\n Buffer: PWideChar; BufferLen: ULONG; ulFlags: ULONG;\r\n hMachine: HMACHINE): CONFIGRET; stdcall;\r\nfunction CM_Get_Device_ID_List_Ex(const pszFilter: PTSTR; // OPTIONAL\r\n Buffer: PTSTR; BufferLen: ULONG; ulFlags: ULONG;\r\n hMachine: HMACHINE): CONFIGRET; stdcall;\r\n\r\nfunction CM_Get_Device_ID_List_SizeA(var ulLen: ULONG;\r\n const pszFilter: PAnsiChar; // OPTIONAL\r\n ulFlags: ULONG): CONFIGRET; stdcall;\r\nfunction CM_Get_Device_ID_List_SizeW(var ulLen: ULONG;\r\n const pszFilter: PWideChar; // OPTIONAL\r\n ulFlags: ULONG): CONFIGRET; stdcall;\r\nfunction CM_Get_Device_ID_List_Size(var pulLen: ULONG;\r\n const pszFilter: PTSTR; // OPTIONAL\r\n ulFlags: ULONG): CONFIGRET; stdcall;\r\n\r\nfunction CM_Get_Device_ID_List_Size_ExA(var ulLen: ULONG;\r\n const pszFilter: PAnsiChar; // OPTIONAL\r\n ulFlags: ULONG; hMachine: HMACHINE): CONFIGRET; stdcall;\r\nfunction CM_Get_Device_ID_List_Size_ExW(var ulLen: ULONG;\r\n const pszFilter: PWideChar; // OPTIONAL\r\n ulFlags: ULONG; hMachine: HMACHINE): CONFIGRET; stdcall;\r\nfunction CM_Get_Device_ID_List_Size_Ex(var ulLen: ULONG;\r\n const pszFilter: PTSTR; // OPTIONAL\r\n ulFlags: ULONG; hMachine: HMACHINE): CONFIGRET; stdcall;\r\n\r\nfunction CM_Get_Device_ID_Size(var ulLen: ULONG;\r\n dnDevInst: DEVINST; ulFlags: ULONG): CONFIGRET; stdcall;\r\n\r\nfunction CM_Get_Device_ID_Size_Ex(var ulLen: ULONG; dnDevInst: DEVINST;\r\n ulFlags: ULONG; hMachine: HMACHINE): CONFIGRET; stdcall;\r\n\r\nfunction CM_Get_DevNode_Registry_PropertyA(dnDevInst: DEVINST;\r\n ulProperty: ULONG;\r\n pulRegDataType: PULONG; // OPTIONAL\r\n Buffer: Pointer; // OPTIONAL\r\n var ulLength: ULONG; ulFlags: ULONG): CONFIGRET; stdcall;\r\nfunction CM_Get_DevNode_Registry_PropertyW(dnDevInst: DEVINST;\r\n ulProperty: ULONG;\r\n pulRegDataType: PULONG; // OPTIONAL\r\n Buffer: Pointer; // OPTIONAL\r\n var ulLength: ULONG; ulFlags: ULONG): CONFIGRET; stdcall;\r\nfunction CM_Get_DevNode_Registry_Property(dnDevInst: DEVINST;\r\n ulProperty: ULONG;\r\n pulRegDataType: PULONG; // OPTIONAL\r\n Buffer: Pointer; // OPTIONAL\r\n var ulLength: ULONG; ulFlags: ULONG): CONFIGRET; stdcall;\r\n\r\nfunction CM_Get_DevNode_Registry_Property_ExA(dnDevInst: DEVINST; ulProperty: ULONG;\r\n pulRegDataType: PULONG; // OPTIONAL\r\n Buffer: Pointer; // OPTIONAL\r\n var ulLength: ULONG; ulFlags: ULONG; hMachine: HMACHINE): CONFIGRET; stdcall;\r\nfunction CM_Get_DevNode_Registry_Property_ExW(dnDevInst: DEVINST; ulProperty: ULONG;\r\n pulRegDataType: PULONG; // OPTIONAL\r\n Buffer: Pointer; // OPTIONAL\r\n var ulLength: ULONG; ulFlags: ULONG; hMachine: HMACHINE): CONFIGRET; stdcall;\r\nfunction CM_Get_DevNode_Registry_Property_Ex(dnDevInst: DEVINST; ulProperty: ULONG;\r\n pulRegDataType: PULONG; // OPTIONAL\r\n Buffer: Pointer; // OPTIONAL\r\n var ulLength: ULONG; ulFlags: ULONG; hMachine: HMACHINE): CONFIGRET; stdcall;\r\n\r\nfunction CM_Get_DevInst_Registry_PropertyA(dnDevInst: DEVINST; ulProperty: ULONG;\r\n pulRegDataType: PULONG; // OPTIONAL\r\n Buffer: Pointer; // OPTIONAL\r\n var ulLength: ULONG; ulFlags: ULONG): CONFIGRET; stdcall;\r\nfunction CM_Get_DevInst_Registry_PropertyW(dnDevInst: DEVINST; ulProperty: ULONG;\r\n pulRegDataType: PULONG; // OPTIONAL\r\n Buffer: Pointer; // OPTIONAL\r\n var ulLength: ULONG; ulFlags: ULONG): CONFIGRET; stdcall;\r\nfunction CM_Get_DevInst_Registry_Property(dnDevInst: DEVINST; ulProperty: ULONG;\r\n pulRegDataType: PULONG; // OPTIONAL\r\n Buffer: Pointer; // OPTIONAL\r\n var ulLength: ULONG; ulFlags: ULONG): CONFIGRET; stdcall;\r\n\r\nfunction CM_Get_DevInst_Registry_Property_ExA(dnDevInst: DEVINST; ulProperty: ULONG;\r\n pulRegDataType: PULONG; // OPTIONAL\r\n Buffer: Pointer; // OPTIONAL\r\n var ulLength: ULONG; ulFlags: ULONG; hMachine: HMACHINE): CONFIGRET; stdcall;\r\nfunction CM_Get_DevInst_Registry_Property_ExW(dnDevInst: DEVINST; ulProperty: ULONG;\r\n pulRegDataType: PULONG; // OPTIONAL\r\n Buffer: Pointer; // OPTIONAL\r\n var ulLength: ULONG; ulFlags: ULONG; hMachine: HMACHINE): CONFIGRET; stdcall;\r\nfunction CM_Get_DevInst_Registry_Property_Ex(dnDevInst: DEVINST; ulProperty: ULONG;\r\n pulRegDataType: PULONG; // OPTIONAL\r\n Buffer: Pointer; // OPTIONAL\r\n var ulLength: ULONG; ulFlags: ULONG; hMachine: HMACHINE): CONFIGRET; stdcall;\r\n\r\n{$IFDEF WINXP_UP}\r\n\r\nfunction CM_Get_DevNode_Custom_PropertyA(dnDevInst: DEVINST;\r\n const pszCustomPropertyName: PAnsiChar;\r\n pulRegDataType: PULONG; // OPTIONAL\r\n Buffer: Pointer; // OPTIONAL\r\n var ulLength: ULONG; ulFlags: ULONG): CONFIGRET; stdcall;\r\nfunction CM_Get_DevNode_Custom_PropertyW(dnDevInst: DEVINST;\r\n const pszCustomPropertyName: PWideChar;\r\n pulRegDataType: PULONG; // OPTIONAL\r\n Buffer: Pointer; // OPTIONAL\r\n var ulLength: ULONG; ulFlags: ULONG): CONFIGRET; stdcall;\r\nfunction CM_Get_DevNode_Custom_Property(dnDevInst: DEVINST;\r\n const pszCustomPropertyName: PTSTR;\r\n pulRegDataType: PULONG; // OPTIONAL\r\n Buffer: Pointer; // OPTIONAL\r\n var ulLength: ULONG; ulFlags: ULONG): CONFIGRET; stdcall;\r\n\r\nfunction CM_Get_DevNode_Custom_Property_ExA(dnDevInst: DEVINST;\r\n const pszCustomPropertyName: PAnsiChar;\r\n pulRegDataType: PULONG; // OPTIONAL\r\n Buffer: Pointer; // OPTIONAL\r\n var ulLength: ULONG; ulFlags: ULONG; hMachine: HMACHINE): CONFIGRET; stdcall;\r\nfunction CM_Get_DevNode_Custom_Property_ExW(dnDevInst: DEVINST;\r\n const pszCustomPropertyName: PWideChar;\r\n pulRegDataType: PULONG; // OPTIONAL\r\n Buffer: Pointer; // OPTIONAL\r\n var ulLength: ULONG; ulFlags: ULONG; hMachine: HMACHINE): CONFIGRET; stdcall;\r\nfunction CM_Get_DevNode_Custom_Property_Ex(dnDevInst: DEVINST;\r\n const pszCustomPropertyName: PTSTR;\r\n pulRegDataType: PULONG; // OPTIONAL\r\n Buffer: Pointer; // OPTIONAL\r\n var ulLength: ULONG; ulFlags: ULONG; hMachine: HMACHINE): CONFIGRET; stdcall;\r\n\r\nfunction CM_Get_DevInst_Custom_PropertyA(dnDevInst: DEVINST;\r\n const pszCustomPropertyName: PAnsiChar;\r\n pulRegDataType: PULONG; // OPTIONAL\r\n Buffer: Pointer; // OPTIONAL\r\n var ulLength: ULONG; ulFlags: ULONG): CONFIGRET; stdcall;\r\nfunction CM_Get_DevInst_Custom_PropertyW(dnDevInst: DEVINST;\r\n const pszCustomPropertyName: PWideChar;\r\n pulRegDataType: PULONG; // OPTIONAL\r\n Buffer: Pointer; // OPTIONAL\r\n var ulLength: ULONG; ulFlags: ULONG): CONFIGRET; stdcall;\r\nfunction CM_Get_DevInst_Custom_Property(dnDevInst: DEVINST;\r\n const pszCustomPropertyName: PTSTR;\r\n pulRegDataType: PULONG; // OPTIONAL\r\n Buffer: Pointer; // OPTIONAL\r\n var ulLength: ULONG; ulFlags: ULONG): CONFIGRET; stdcall;\r\n\r\nfunction CM_Get_DevInst_Custom_Property_ExA(dnDevInst: DEVINST;\r\n const pszCustomPropertyName: PAnsiChar;\r\n pulRegDataType: PULONG; // OPTIONAL\r\n Buffer: Pointer; // OPTIONAL\r\n var ulLength: ULONG; ulFlags: ULONG; hMachine: HMACHINE): CONFIGRET; stdcall;\r\nfunction CM_Get_DevInst_Custom_Property_ExW(dnDevInst: DEVINST;\r\n const pszCustomPropertyName: PWideChar;\r\n pulRegDataType: PULONG; // OPTIONAL\r\n Buffer: Pointer; // OPTIONAL\r\n var ulLength: ULONG; ulFlags: ULONG; hMachine: HMACHINE): CONFIGRET; stdcall;\r\nfunction CM_Get_DevInst_Custom_Property_Ex(dnDevInst: DEVINST;\r\n const pszCustomPropertyName: PTSTR;\r\n pulRegDataType: PULONG; // OPTIONAL\r\n Buffer: Pointer; // OPTIONAL\r\n var ulLength: ULONG; ulFlags: ULONG; hMachine: HMACHINE): CONFIGRET; stdcall;\r\n\r\n{$ENDIF WINXP_UP}\r\n\r\nfunction CM_Get_DevNode_Status(var ulStatus: ULONG; var ulProblemNumber: ULONG;\r\n dnDevInst: DEVINST; ulFlags: ULONG): CONFIGRET; stdcall;\r\n\r\nfunction CM_Get_DevInst_Status(var ulStatus: ULONG; var ulProblemNumber: ULONG;\r\n dnDevInst: DEVINST; ulFlags: ULONG): CONFIGRET; stdcall;\r\n\r\nfunction CM_Get_DevNode_Status_Ex(var ulStatus: ULONG; var ulProblemNumber: ULONG;\r\n dnDevInst: DEVINST; ulFlags: ULONG; hMachine: HMACHINE): CONFIGRET; stdcall;\r\n\r\nfunction CM_Get_DevInst_Status_Ex(var ulStatus: ULONG; var ulProblemNumber: ULONG;\r\n dnDevInst: DEVINST; ulFlags: ULONG; hMachine: HMACHINE): CONFIGRET; stdcall;\r\n\r\nfunction CM_Get_First_Log_Conf(plcLogConf: PLOG_CONF; // OPTIONAL\r\n dnDevInst: DEVINST; ulFlags: ULONG): CONFIGRET; stdcall;\r\n\r\nfunction CM_Get_First_Log_Conf_Ex(plcLogConf: PLOG_CONF; // OPTIONAL\r\n dnDevInst: DEVINST; ulFlags: ULONG; hMachine: HMACHINE): CONFIGRET; stdcall;\r\n\r\nfunction CM_Get_Global_State(var ulState: ULONG; ulFlags: ULONG): CONFIGRET; stdcall;\r\n\r\nfunction CM_Get_Global_State_Ex(var ulState: ULONG; ulFlags: ULONG;\r\n hMachine: HMACHINE): CONFIGRET; stdcall;\r\n\r\nfunction CM_Get_Hardware_Profile_InfoA(ulIndex: ULONG;\r\n var HWProfileInfo: HWPROFILEINFO_A; ulFlags: ULONG): CONFIGRET; stdcall;\r\nfunction CM_Get_Hardware_Profile_InfoW(ulIndex: ULONG;\r\n var HWProfileInfo: HWPROFILEINFO_W; ulFlags: ULONG): CONFIGRET; stdcall;\r\nfunction CM_Get_Hardware_Profile_Info(ulIndex: ULONG;\r\n var HWProfileInfo: HWPROFILEINFO; ulFlags: ULONG): CONFIGRET; stdcall;\r\n\r\nfunction CM_Get_Hardware_Profile_Info_ExA(ulIndex: ULONG;\r\n var HWProfileInfo: HWPROFILEINFO_A; ulFlags: ULONG;\r\n hMachine: HMACHINE): CONFIGRET; stdcall;\r\nfunction CM_Get_Hardware_Profile_Info_ExW(ulIndex: ULONG;\r\n var HWProfileInfo: HWPROFILEINFO_W; ulFlags: ULONG;\r\n hMachine: HMACHINE): CONFIGRET; stdcall;\r\nfunction CM_Get_Hardware_Profile_Info_Ex(ulIndex: ULONG;\r\n var HWProfileInfo: HWPROFILEINFO; ulFlags: ULONG;\r\n hMachine: HMACHINE): CONFIGRET; stdcall;\r\n\r\nfunction CM_Get_HW_Prof_FlagsA(szDevInstName: DEVINSTID_A;\r\n ulHardwareProfile: ULONG; var ulValue: ULONG;\r\n ulFlags: ULONG): CONFIGRET; stdcall;\r\nfunction CM_Get_HW_Prof_FlagsW(szDevInstName: DEVINSTID_W;\r\n ulHardwareProfile: ULONG; var ulValue: ULONG;\r\n ulFlags: ULONG): CONFIGRET; stdcall;\r\nfunction CM_Get_HW_Prof_Flags(szDevInstName: DEVINSTID;\r\n ulHardwareProfile: ULONG; var ulValue: ULONG; ulFlags: ULONG): CONFIGRET; stdcall;\r\n\r\nfunction CM_Get_HW_Prof_Flags_ExA(szDevInstName: DEVINSTID_A;\r\n ulHardwareProfile: ULONG; var ulValue: ULONG;\r\n ulFlags: ULONG; hMachine: HMACHINE): CONFIGRET; stdcall;\r\nfunction CM_Get_HW_Prof_Flags_ExW(szDevInstName: DEVINSTID_W;\r\n ulHardwareProfile: ULONG; var ulValue: ULONG;\r\n ulFlags: ULONG; hMachine: HMACHINE): CONFIGRET; stdcall;\r\nfunction CM_Get_HW_Prof_Flags_Ex(szDevInstName: DEVINSTID;\r\n ulHardwareProfile: ULONG; var ulValue: ULONG;\r\n ulFlags: ULONG; hMachine: HMACHINE): CONFIGRET; stdcall;\r\n\r\n{$IFNDEF WINNT4}\r\n\r\nfunction CM_Get_Device_Interface_AliasA(const pszDeviceInterface: PAnsiChar;\r\n AliasInterfaceGuid: PGUID; pszAliasDeviceInterface: PAnsiChar;\r\n var ulLength: ULONG; ulFlags: ULONG): CONFIGRET; stdcall;\r\nfunction CM_Get_Device_Interface_AliasW(const pszDeviceInterface: PWideChar;\r\n AliasInterfaceGuid: PGUID; pszAliasDeviceInterface: PWideChar;\r\n var ulLength: ULONG; ulFlags: ULONG): CONFIGRET; stdcall;\r\nfunction CM_Get_Device_Interface_Alias(const pszDeviceInterface: PTSTR;\r\n AliasInterfaceGuid: PGUID; pszAliasDeviceInterface: PTSTR;\r\n var ulLength: ULONG; ulFlags: ULONG): CONFIGRET; stdcall;\r\n\r\nfunction CM_Get_Device_Interface_Alias_ExA(const pszDeviceInterface: PAnsiChar;\r\n AliasInterfaceGuid: PGUID; pszAliasDeviceInterface: PAnsiChar;\r\n var ulLength: ULONG; ulFlags: ULONG; hMachine: HMACHINE): CONFIGRET; stdcall;\r\nfunction CM_Get_Device_Interface_Alias_ExW(const pszDeviceInterface: PWideChar;\r\n AliasInterfaceGuid: PGUID; pszAliasDeviceInterface: PWideChar;\r\n var ulLength: ULONG; ulFlags: ULONG; hMachine: HMACHINE): CONFIGRET; stdcall;\r\nfunction CM_Get_Device_Interface_Alias_Ex(const pszDeviceInterface: PTSTR;\r\n AliasInterfaceGuid: PGUID; pszAliasDeviceInterface: PTSTR;\r\n var ulLength: ULONG; ulFlags: ULONG; hMachine: HMACHINE): CONFIGRET; stdcall;\r\n\r\nfunction CM_Get_Device_Interface_ListA(InterfaceClassGuid: PGUID;\r\n pDeviceID: DEVINSTID_A; // OPTIONAL\r\n Buffer: PAnsiChar; BufferLen: ULONG; ulFlags: ULONG): CONFIGRET; stdcall;\r\nfunction CM_Get_Device_Interface_ListW(InterfaceClassGuid: PGUID;\r\n pDeviceID: DEVINSTID_W; // OPTIONAL\r\n Buffer: PWideChar; BufferLen: ULONG; ulFlags: ULONG): CONFIGRET; stdcall;\r\nfunction CM_Get_Device_Interface_List(InterfaceClassGuid: PGUID;\r\n pDeviceID: DEVINSTID; // OPTIONAL\r\n Buffer: PTSTR; BufferLen: ULONG; ulFlags: ULONG): CONFIGRET; stdcall;\r\n\r\nfunction CM_Get_Device_Interface_List_ExA(InterfaceClassGuid: PGUID;\r\n pDeviceID: DEVINSTID_A; // OPTIONAL\r\n Buffer: PAnsiChar; BufferLen: ULONG; ulFlags: ULONG;\r\n hMachine: HMACHINE): CONFIGRET; stdcall;\r\nfunction CM_Get_Device_Interface_List_ExW(InterfaceClassGuid: PGUID;\r\n pDeviceID: DEVINSTID_W; // OPTIONAL\r\n Buffer: PWideChar; BufferLen: ULONG; ulFlags: ULONG;\r\n hMachine: HMACHINE): CONFIGRET; stdcall;\r\nfunction CM_Get_Device_Interface_List_Ex(InterfaceClassGuid: PGUID;\r\n pDeviceID: DEVINSTID; // OPTIONAL\r\n Buffer: PTSTR; BufferLen: ULONG; ulFlags: ULONG;\r\n hMachine: HMACHINE): CONFIGRET; stdcall;\r\n\r\nfunction CM_Get_Device_Interface_List_SizeA(var ulLen: ULONG;\r\n InterfaceClassGuid: PGUID; pDeviceID: DEVINSTID_A; // OPTIONAL\r\n ulFlags: ULONG): CONFIGRET; stdcall;\r\nfunction CM_Get_Device_Interface_List_SizeW(var ulLen: ULONG;\r\n InterfaceClassGuid: PGUID; pDeviceID: DEVINSTID_W; // OPTIONAL\r\n ulFlags: ULONG): CONFIGRET; stdcall;\r\nfunction CM_Get_Device_Interface_List_Size(var ulLen: ULONG;\r\n InterfaceClassGuid: PGUID; pDeviceID: DEVINSTID; // OPTIONAL\r\n ulFlags: ULONG): CONFIGRET; stdcall;\r\n\r\nfunction CM_Get_Device_Interface_List_Size_ExA(var ulLen: ULONG;\r\n InterfaceClassGuid: PGUID; pDeviceID: DEVINSTID_A; // OPTIONAL\r\n ulFlags: ULONG; hMachine: HMACHINE): CONFIGRET; stdcall;\r\nfunction CM_Get_Device_Interface_List_Size_ExW(var ulLen: ULONG;\r\n InterfaceClassGuid: PGUID; pDeviceID: DEVINSTID_W; // OPTIONAL\r\n ulFlags: ULONG; hMachine: HMACHINE): CONFIGRET; stdcall;\r\nfunction CM_Get_Device_Interface_List_Size_Ex(var ulLen: ULONG;\r\n InterfaceClassGuid: PGUID; pDeviceID: DEVINSTID; // OPTIONAL\r\n ulFlags: ULONG; hMachine: HMACHINE): CONFIGRET; stdcall;\r\n\r\nfunction CM_Get_Log_Conf_Priority(lcLogConf: LOG_CONF;\r\n var Priority: PRIORITY; ulFlags: ULONG): CONFIGRET; stdcall;\r\n\r\nfunction CM_Get_Log_Conf_Priority_Ex(lcLogConf: LOG_CONF;\r\n var Priority: PRIORITY; ulFlags: ULONG; hMachine: HMACHINE): CONFIGRET; stdcall;\r\n\r\n{$ENDIF !WINNT4}\r\n\r\nfunction CM_Get_Next_Log_Conf(plcLogConf: PLOG_CONF; // OPTIONAL\r\n lcLogConf: LOG_CONF; ulFlags: ULONG): CONFIGRET; stdcall;\r\n\r\nfunction CM_Get_Next_Log_Conf_Ex(plcLogConf: PLOG_CONF; // OPTIONAL\r\n lcLogConf: LOG_CONF; ulFlags: ULONG; hMachine: HMACHINE): CONFIGRET; stdcall;\r\n\r\nfunction CM_Get_Parent(var dnDevInstParent: DEVINST;\r\n dnDevInst: DEVINST; ulFlags: ULONG): CONFIGRET; stdcall;\r\n\r\nfunction CM_Get_Parent_Ex(var dnDevInstParent: DEVINST;\r\n dnDevInst: DEVINST; ulFlags: ULONG; hMachine: HMACHINE): CONFIGRET; stdcall;\r\n\r\nfunction CM_Get_Res_Des_Data(rdResDes: RES_DES; Buffer: Pointer;\r\n BufferLen: ULONG; ulFlags: ULONG): CONFIGRET; stdcall;\r\n\r\nfunction CM_Get_Res_Des_Data_Ex(rdResDes: RES_DES; Buffer: Pointer;\r\n BufferLen: ULONG; ulFlags: ULONG; hMachine: HMACHINE): CONFIGRET; stdcall;\r\n\r\nfunction CM_Get_Res_Des_Data_Size(var ulSize: ULONG; rdResDes: RES_DES;\r\n ulFlags: ULONG): CONFIGRET; stdcall;\r\n\r\nfunction CM_Get_Res_Des_Data_Size_Ex(var ulSize: ULONG; rdResDes: RES_DES;\r\n ulFlags: ULONG; hMachine: HMACHINE): CONFIGRET; stdcall;\r\n\r\nfunction CM_Get_Sibling(var dnDevInstSibling: DEVINST;\r\n DevInst: DEVINST; ulFlags: ULONG): CONFIGRET; stdcall;\r\n\r\nfunction CM_Get_Sibling_Ex(var dnDevInstSibling: DEVINST;\r\n DevInst: DEVINST; ulFlags: ULONG; hMachine: HMACHINE): CONFIGRET; stdcall;\r\n\r\nfunction CM_Get_Version: WORD; stdcall;\r\n\r\nfunction CM_Get_Version_Ex(hMachine: HMACHINE): WORD; stdcall;\r\n\r\n{$IFDEF WINXP_UP}\r\n\r\nfunction CM_Is_Version_Available(wVersion: WORD): BOOL; stdcall;\r\n\r\nfunction CM_Is_Version_Available_Ex(wVersion: WORD;\r\n hMachine: HMACHINE): BOOL; stdcall;\r\n\r\n{$ENDIF WINXP_UP}\r\n\r\nfunction CM_Intersect_Range_List(rlhOld1: RANGE_LIST;rlhOld2: RANGE_LIST;\r\n rlhNew: RANGE_LIST; ulFlags: ULONG): CONFIGRET; stdcall;\r\n\r\nfunction CM_Invert_Range_List(rlhOld: RANGE_LIST; rlhNew: RANGE_LIST;\r\n ullMaxValue: DWORDLONG; ulFlags: ULONG): CONFIGRET; stdcall;\r\n\r\nfunction CM_Locate_DevNodeA(var dnDevInst: DEVINST;\r\n pDeviceID: DEVINSTID_A; // OPTIONAL\r\n ulFlags: ULONG): CONFIGRET; stdcall;\r\nfunction CM_Locate_DevNodeW(var dnDevInst: DEVINST;\r\n pDeviceID: DEVINSTID_W; // OPTIONAL\r\n ulFlags: ULONG): CONFIGRET; stdcall;\r\nfunction CM_Locate_DevNode(var dnDevInst: DEVINST;\r\n pDeviceID: DEVINSTID; // OPTIONAL\r\n ulFlags: ULONG): CONFIGRET; stdcall;\r\n\r\nfunction CM_Locate_DevNode_ExA(var dnDevInst: DEVINST;\r\n pDeviceID: DEVINSTID_A; // OPTIONAL\r\n ulFlags: ULONG; hMachine: HMACHINE): CONFIGRET; stdcall;\r\nfunction CM_Locate_DevNode_ExW(var dnDevInst: DEVINST;\r\n pDeviceID: DEVINSTID_W; // OPTIONAL\r\n ulFlags: ULONG; hMachine: HMACHINE): CONFIGRET; stdcall;\r\nfunction CM_Locate_DevNode_Ex(var dnDevInst: DEVINST;\r\n pDeviceID: DEVINSTID; // OPTIONAL\r\n ulFlags: ULONG; hMachine: HMACHINE): CONFIGRET; stdcall;\r\n\r\nfunction CM_Locate_DevInstA(var dnDevInst: DEVINST;\r\n pDeviceID: DEVINSTID_A; // OPTIONAL\r\n ulFlags: ULONG): CONFIGRET; stdcall;\r\nfunction CM_Locate_DevInstW(var dnDevInst: DEVINST;\r\n pDeviceID: DEVINSTID_W; // OPTIONAL\r\n ulFlags: ULONG): CONFIGRET; stdcall;\r\nfunction CM_Locate_DevInst(var dnDevInst: DEVINST;\r\n pDeviceID: DEVINSTID; // OPTIONAL\r\n ulFlags: ULONG): CONFIGRET; stdcall;\r\n\r\nfunction CM_Locate_DevInst_ExA(var dnDevInst: DEVINST;\r\n pDeviceID: DEVINSTID_A; // OPTIONAL\r\n ulFlags: ULONG; hMachine: HMACHINE): CONFIGRET; stdcall;\r\nfunction CM_Locate_DevInst_ExW(var dnDevInst: DEVINST;\r\n pDeviceID: DEVINSTID_W; // OPTIONAL\r\n ulFlags: ULONG; hMachine: HMACHINE): CONFIGRET; stdcall;\r\nfunction CM_Locate_DevInst_Ex(var dnDevInst: DEVINST;\r\n pDeviceID: DEVINSTID; // OPTIONAL\r\n ulFlags: ULONG; hMachine: HMACHINE): CONFIGRET; stdcall;\r\n\r\nfunction CM_Merge_Range_List(rlhOld1: RANGE_LIST; rlhOld2: RANGE_LIST;\r\n rlhNew: RANGE_LIST; ulFlags: ULONG): CONFIGRET; stdcall;\r\n\r\nfunction CM_Modify_Res_Des(var rdResDesModified: RES_DES;\r\n rdResDes: RES_DES; ResourceID: RESOURCEID; ResourceData: Pointer;\r\n ResourceLen: ULONG; ulFlags: ULONG): CONFIGRET; stdcall;\r\n\r\nfunction CM_Modify_Res_Des_Ex(var rdResDesModified: RES_DES;\r\n rdResDes: RES_DES; ResourceID: RESOURCEID; ResourceData: Pointer;\r\n ResourceLen: ULONG; ulFlags: ULONG; hMachine: HMACHINE): CONFIGRET; stdcall;\r\n\r\nfunction CM_Move_DevNode(dnFromDevInst: DEVINST;\r\n dnToDevInst: DEVINST; ulFlags: ULONG): CONFIGRET; stdcall;\r\n\r\nfunction CM_Move_DevInst(dnFromDevInst: DEVINST;\r\n dnToDevInst: DEVINST; ulFlags: ULONG): CONFIGRET; stdcall;\r\n\r\nfunction CM_Move_DevNode_Ex(dnFromDevInst: DEVINST;\r\n dnToDevInst: DEVINST; ulFlags: ULONG; hMachine: HMACHINE): CONFIGRET; stdcall;\r\n\r\nfunction CM_Move_DevInst_Ex(dnFromDevInst: DEVINST;\r\n dnToDevInst: DEVINST; ulFlags: ULONG; hMachine: HMACHINE): CONFIGRET; stdcall;\r\n\r\nfunction CM_Next_Range(var reElement: RANGE_ELEMENT;\r\n var ullStart: DWORDLONG; var ullEnd: DWORDLONG;\r\n ulFlags: ULONG): CONFIGRET; stdcall;\r\n\r\nfunction CM_Get_Next_Res_Des(var rdResDesNext: RES_DES;\r\n rdResDes: RES_DES; ForResource: RESOURCEID; var ResourceID: RESOURCEID;\r\n ulFlags: ULONG): CONFIGRET; stdcall;\r\n\r\nfunction CM_Get_Next_Res_Des_Ex(var rdResDesNext: RES_DES;\r\n rdResDes: RES_DES; ForResource: RESOURCEID; var ResourceID: RESOURCEID;\r\n ulFlags: ULONG; hMachine: HMACHINE): CONFIGRET; stdcall;\r\n\r\nfunction CM_Open_Class_KeyA(ClassGuid: PGUID; // OPTIONAL\r\n const pszClassName: PAnsiChar; // OPTIONAL\r\n samDesired: REGSAM; Disposition: REGDISPOSITION;\r\n var hkClass: HKEY; ulFlags: ULONG): CONFIGRET; stdcall;\r\nfunction CM_Open_Class_KeyW(ClassGuid: PGUID; // OPTIONAL\r\n const pszClassName: PWideChar; // OPTIONAL\r\n samDesired: REGSAM; Disposition: REGDISPOSITION;\r\n var hkClass: HKEY; ulFlags: ULONG): CONFIGRET; stdcall;\r\nfunction CM_Open_Class_Key(ClassGuid: PGUID; // OPTIONAL\r\n const pszClassName: PTSTR; // OPTIONAL\r\n samDesired: REGSAM; Disposition: REGDISPOSITION;\r\n var hkClass: HKEY; ulFlags: ULONG): CONFIGRET; stdcall;\r\n\r\nfunction CM_Open_Class_Key_ExA(pszClassGuid: PGUID; // OPTIONAL\r\n const pszClassName: PAnsiChar; // OPTIONAL\r\n samDesired: REGSAM; Disposition: REGDISPOSITION;\r\n var hkClass: HKEY; ulFlags: ULONG; hMachine: HMACHINE): CONFIGRET; stdcall;\r\nfunction CM_Open_Class_Key_ExW(pszClassGuid: PGUID; // OPTIONAL\r\n const pszClassName: PWideChar; // OPTIONAL\r\n samDesired: REGSAM; Disposition: REGDISPOSITION;\r\n var hkClass: HKEY; ulFlags: ULONG; hMachine: HMACHINE): CONFIGRET; stdcall;\r\nfunction CM_Open_Class_Key_Ex(pszClassGuid: PGUID; // OPTIONAL\r\n const pszClassName: PTSTR; // OPTIONAL\r\n samDesired: REGSAM; Disposition: REGDISPOSITION;\r\n var hkClass: HKEY; ulFlags: ULONG; hMachine: HMACHINE): CONFIGRET; stdcall;\r\n\r\nfunction CM_Open_DevNode_Key(dnDevNode: DEVINST; samDesired: REGSAM;\r\n ulHardwareProfile: ULONG; Disposition: REGDISPOSITION;\r\n var hkDevice: HKEY; ulFlags: ULONG): CONFIGRET; stdcall;\r\n\r\nfunction CM_Open_DevInst_Key(dnDevNode: DEVINST; samDesired: REGSAM;\r\n ulHardwareProfile: ULONG; Disposition: REGDISPOSITION;\r\n var hkDevice: HKEY; ulFlags: ULONG): CONFIGRET; stdcall;\r\n\r\nfunction CM_Open_DevNode_Key_Ex(dnDevNode: DEVINST; samDesired: REGSAM;\r\n ulHardwareProfile: ULONG; Disposition: REGDISPOSITION; var hkDevice: HKEY;\r\n ulFlags: ULONG; hMachine: HMACHINE): CONFIGRET; stdcall;\r\n\r\nfunction CM_Open_DevInst_Key_Ex(dnDevNode: DEVINST; samDesired: REGSAM;\r\n ulHardwareProfile: ULONG; Disposition: REGDISPOSITION; var hkDevice: HKEY;\r\n ulFlags: ULONG; hMachine: HMACHINE): CONFIGRET; stdcall;\r\n\r\nfunction CM_Query_Arbitrator_Free_Data(pData: Pointer; DataLen: ULONG;\r\n dnDevInst: DEVINST; ResourceID: RESOURCEID; ulFlags: ULONG): CONFIGRET; stdcall;\r\n\r\nfunction CM_Query_Arbitrator_Free_Data_Ex(pData: Pointer; DataLen: ULONG;\r\n dnDevInst: DEVINST; ResourceID: RESOURCEID; ulFlags: ULONG;\r\n hMachine: HMACHINE): CONFIGRET; stdcall;\r\n\r\nfunction CM_Query_Arbitrator_Free_Size(var ulSize: ULONG; dnDevInst: DEVINST;\r\n ResourceID: RESOURCEID; ulFlags: ULONG): CONFIGRET; stdcall;\r\n\r\nfunction CM_Query_Arbitrator_Free_Size_Ex(var ulSize: ULONG; dnDevInst: DEVINST;\r\n ResourceID: RESOURCEID; ulFlags: ULONG; hMachine: HMACHINE): CONFIGRET; stdcall;\r\n\r\nfunction CM_Query_Remove_SubTree(dnAncestor: DEVINST;\r\n ulFlags: ULONG): CONFIGRET; stdcall;\r\n\r\nfunction CM_Query_Remove_SubTree_Ex(dnAncestor: DEVINST;\r\n ulFlags: ULONG; hMachine: HMACHINE): CONFIGRET; stdcall;\r\n\r\n{$IFDEF WIN2000_UP}\r\n\r\nfunction CM_Query_And_Remove_SubTreeA(dnAncestor: DEVINST;\r\n pVetoType: PPNP_VETO_TYPE; // OPTIONAL\r\n pszVetoName: PAnsiChar; // OPTIONAL\r\n ulNameLength: ULONG; ulFlags: ULONG): CONFIGRET; stdcall;\r\nfunction CM_Query_And_Remove_SubTreeW(dnAncestor: DEVINST;\r\n pVetoType: PPNP_VETO_TYPE; // OPTIONAL\r\n pszVetoName: PWideChar; // OPTIONAL\r\n ulNameLength: ULONG; ulFlags: ULONG): CONFIGRET; stdcall;\r\nfunction CM_Query_And_Remove_SubTree(dnAncestor: DEVINST;\r\n pVetoType: PPNP_VETO_TYPE; // OPTIONAL\r\n pszVetoName: PTSTR; // OPTIONAL\r\n ulNameLength: ULONG; ulFlags: ULONG): CONFIGRET; stdcall;\r\n\r\nfunction CM_Query_And_Remove_SubTree_ExA(dnAncestor: DEVINST;\r\n pVetoType: PPNP_VETO_TYPE; // OPTIONAL\r\n pszVetoName: PAnsiChar; // OPTIONAL\r\n ulNameLength: ULONG; ulFlags: ULONG; hMachine: HMACHINE): CONFIGRET; stdcall;\r\nfunction CM_Query_And_Remove_SubTree_ExW(dnAncestor: DEVINST;\r\n pVetoType: PPNP_VETO_TYPE; // OPTIONAL\r\n pszVetoName: PWideChar; // OPTIONAL\r\n ulNameLength: ULONG; ulFlags: ULONG; hMachine: HMACHINE): CONFIGRET; stdcall;\r\nfunction CM_Query_And_Remove_SubTree_Ex(dnAncestor: DEVINST;\r\n pVetoType: PPNP_VETO_TYPE; // OPTIONAL\r\n pszVetoName: PTSTR; // OPTIONAL\r\n ulNameLength: ULONG; ulFlags: ULONG; hMachine: HMACHINE): CONFIGRET; stdcall;\r\n\r\nfunction CM_Request_Device_EjectA(dnDevInst: DEVINST;\r\n pVetoType: PPNP_VETO_TYPE; // OPTIONAL\r\n pszVetoName: PAnsiChar; // OPTIONAL\r\n ulNameLength: ULONG; ulFlags: ULONG): CONFIGRET; stdcall;\r\nfunction CM_Request_Device_EjectW(dnDevInst: DEVINST;\r\n pVetoType: PPNP_VETO_TYPE; // OPTIONAL\r\n pszVetoName: PWideChar; // OPTIONAL\r\n ulNameLength: ULONG; ulFlags: ULONG): CONFIGRET; stdcall;\r\nfunction CM_Request_Device_Eject(dnDevInst: DEVINST;\r\n pVetoType: PPNP_VETO_TYPE; // OPTIONAL\r\n pszVetoName: PTSTR; // OPTIONAL\r\n ulNameLength: ULONG; ulFlags: ULONG): CONFIGRET; stdcall;\r\n\r\nfunction CM_Request_Device_Eject_ExA(dnDevInst: DEVINST;\r\n pVetoType: PPNP_VETO_TYPE; // OPTIONAL\r\n pszVetoName: PAnsiChar; // OPTIONAL\r\n ulNameLength: ULONG; ulFlags: ULONG; hMachine: HMACHINE): CONFIGRET; stdcall;\r\nfunction CM_Request_Device_Eject_ExW(dnDevInst: DEVINST;\r\n pVetoType: PPNP_VETO_TYPE; // OPTIONAL\r\n pszVetoName: PWideChar; // OPTIONAL\r\n ulNameLength: ULONG; ulFlags: ULONG; hMachine: HMACHINE): CONFIGRET; stdcall;\r\nfunction CM_Request_Device_Eject_Ex(dnDevInst: DEVINST;\r\n pVetoType: PPNP_VETO_TYPE; // OPTIONAL\r\n pszVetoName: PTSTR; // OPTIONAL\r\n ulNameLength: ULONG; ulFlags: ULONG; hMachine: HMACHINE): CONFIGRET; stdcall;\r\n\r\n{$ENDIF WIN2000_UP}\r\n\r\nfunction CM_Reenumerate_DevNode(dnDevInst: DEVINST;\r\n ulFlags: ULONG): CONFIGRET; stdcall;\r\n\r\nfunction CM_Reenumerate_DevInst(dnDevInst: DEVINST;\r\n ulFlags: ULONG): CONFIGRET; stdcall;\r\n\r\nfunction CM_Reenumerate_DevNode_Ex(dnDevInst: DEVINST;\r\n ulFlags: ULONG; hMachine: HMACHINE): CONFIGRET; stdcall;\r\n\r\nfunction CM_Reenumerate_DevInst_Ex(dnDevInst: DEVINST;\r\n ulFlags: ULONG; hMachine: HMACHINE): CONFIGRET; stdcall;\r\n\r\n{$IFNDEF WINNT4}\r\n\r\nfunction CM_Register_Device_InterfaceA(dnDevInst: DEVINST;\r\n InterfaceClassGuid: PGUID;\r\n const pszReference: PAnsiChar; // OPTIONAL\r\n pszDeviceInterface: PAnsiChar; var ulLength: ULONG;\r\n ulFlags: ULONG): CONFIGRET; stdcall;\r\nfunction CM_Register_Device_InterfaceW(dnDevInst: DEVINST;\r\n InterfaceClassGuid: PGUID;\r\n const pszReference: PWideChar; // OPTIONAL\r\n pszDeviceInterface: PWideChar; var ulLength: ULONG;\r\n ulFlags: ULONG): CONFIGRET; stdcall;\r\nfunction CM_Register_Device_Interface(dnDevInst: DEVINST;\r\n InterfaceClassGuid: PGUID;\r\n const pszReference: PTSTR; // OPTIONAL\r\n pszDeviceInterface: PTSTR; var ulLength: ULONG;\r\n ulFlags: ULONG): CONFIGRET; stdcall;\r\n\r\nfunction CM_Register_Device_Interface_ExA(dnDevInst: DEVINST;\r\n InterfaceClassGuid: PGUID;\r\n const pszReference: PAnsiChar; // OPTIONAL\r\n pszDeviceInterface: PAnsiChar; var ulLength: ULONG;\r\n ulFlags: ULONG; hMachine: HMACHINE): CONFIGRET; stdcall;\r\nfunction CM_Register_Device_Interface_ExW(dnDevInst: DEVINST;\r\n InterfaceClassGuid: PGUID;\r\n const pszReference: PWideChar; // OPTIONAL\r\n pszDeviceInterface: PWideChar; var ulLength: ULONG;\r\n ulFlags: ULONG; hMachine: HMACHINE): CONFIGRET; stdcall;\r\nfunction CM_Register_Device_Interface_Ex(dnDevInst: DEVINST;\r\n InterfaceClassGuid: PGUID;\r\n const pszReference: PTSTR; // OPTIONAL\r\n pszDeviceInterface: PTSTR; var ulLength: ULONG;\r\n ulFlags: ULONG; hMachine: HMACHINE): CONFIGRET; stdcall;\r\n\r\nfunction CM_Set_DevNode_Problem_Ex(dnDevInst: DEVINST;\r\n ulProblem: ULONG; ulFlags: ULONG; hMachine: HMACHINE): CONFIGRET; stdcall;\r\n\r\nfunction CM_Set_DevInst_Problem_Ex(dnDevInst: DEVINST;\r\n ulProblem: ULONG; ulFlags: ULONG; hMachine: HMACHINE): CONFIGRET; stdcall;\r\n\r\nfunction CM_Set_DevNode_Problem(dnDevInst: DEVINST; ulProblem: ULONG;\r\n ulFlags: ULONG): CONFIGRET; stdcall;\r\n\r\nfunction CM_Set_DevInst_Problem(dnDevInst: DEVINST; ulProblem: ULONG;\r\n ulFlags: ULONG): CONFIGRET; stdcall;\r\n\r\nfunction CM_Unregister_Device_InterfaceA(const pszDeviceInterface: PAnsiChar;\r\n ulFlags: ULONG): CONFIGRET; stdcall;\r\nfunction CM_Unregister_Device_InterfaceW(const pszDeviceInterface: PWideChar;\r\n ulFlags: ULONG): CONFIGRET; stdcall;\r\nfunction CM_Unregister_Device_Interface(const pszDeviceInterface: PTSTR;\r\n ulFlags: ULONG): CONFIGRET; stdcall;\r\n\r\nfunction CM_Unregister_Device_Interface_ExA(const pszDeviceInterface: PAnsiChar;\r\n ulFlags: ULONG; hMachine: HMACHINE): CONFIGRET; stdcall;\r\nfunction CM_Unregister_Device_Interface_ExW(const pszDeviceInterface: PWideChar;\r\n ulFlags: ULONG; hMachine: HMACHINE): CONFIGRET; stdcall;\r\nfunction CM_Unregister_Device_Interface_Ex(const pszDeviceInterface: PTSTR;\r\n ulFlags: ULONG; hMachine: HMACHINE): CONFIGRET; stdcall;\r\n\r\nfunction CM_Register_Device_Driver(dnDevInst: DEVINST;\r\n ulFlags: ULONG): CONFIGRET; stdcall;\r\n\r\nfunction CM_Register_Device_Driver_Ex(dnDevInst: DEVINST;\r\n ulFlags: ULONG; hMachine: HMACHINE): CONFIGRET; stdcall;\r\n\r\n{$ENDIF !WINNT4}\r\n\r\nfunction CM_Remove_SubTree(dnAncestor: DEVINST; ulFlags: ULONG): CONFIGRET; stdcall;\r\n\r\nfunction CM_Remove_SubTree_Ex(dnAncestor: DEVINST; ulFlags: ULONG;\r\n hMachine: HMACHINE): CONFIGRET; stdcall;\r\n\r\nfunction CM_Set_DevNode_Registry_PropertyA(dnDevInst: DEVINST;\r\n ulProperty: ULONG; Buffer: Pointer; // OPTIONAL\r\n ulLength: ULONG; ulFlags: ULONG): CONFIGRET; stdcall;\r\nfunction CM_Set_DevNode_Registry_PropertyW(dnDevInst: DEVINST;\r\n ulProperty: ULONG; Buffer: Pointer; // OPTIONAL\r\n ulLength: ULONG; ulFlags: ULONG): CONFIGRET; stdcall;\r\nfunction CM_Set_DevNode_Registry_Property(dnDevInst: DEVINST;\r\n ulProperty: ULONG; Buffer: Pointer; // OPTIONAL\r\n ulLength: ULONG; ulFlags: ULONG): CONFIGRET; stdcall;\r\n\r\nfunction CM_Set_DevNode_Registry_Property_ExA(dnDevInst: DEVINST;\r\n ulProperty: ULONG; Buffer: Pointer; // OPTIONAL\r\n ulLength: ULONG; ulFlags: ULONG; hMachine: HMACHINE): CONFIGRET; stdcall;\r\nfunction CM_Set_DevNode_Registry_Property_ExW(dnDevInst: DEVINST;\r\n ulProperty: ULONG; Buffer: Pointer; // OPTIONAL\r\n ulLength: ULONG; ulFlags: ULONG; hMachine: HMACHINE): CONFIGRET; stdcall;\r\nfunction CM_Set_DevNode_Registry_Property_Ex(dnDevInst: DEVINST;\r\n ulProperty: ULONG; Buffer: Pointer; // OPTIONAL\r\n ulLength: ULONG; ulFlags: ULONG; hMachine: HMACHINE): CONFIGRET; stdcall;\r\n\r\nfunction CM_Set_DevInst_Registry_PropertyA(dnDevInst: DEVINST;\r\n ulProperty: ULONG; Buffer: Pointer; // OPTIONAL\r\n ulLength: ULONG; ulFlags: ULONG): CONFIGRET; stdcall;\r\nfunction CM_Set_DevInst_Registry_PropertyW(dnDevInst: DEVINST;\r\n ulProperty: ULONG; Buffer: Pointer; // OPTIONAL\r\n ulLength: ULONG; ulFlags: ULONG): CONFIGRET; stdcall;\r\nfunction CM_Set_DevInst_Registry_Property(dnDevInst: DEVINST;\r\n ulProperty: ULONG; Buffer: Pointer; // OPTIONAL\r\n ulLength: ULONG; ulFlags: ULONG): CONFIGRET; stdcall;\r\n\r\nfunction CM_Set_DevInst_Registry_Property_ExA(dnDevInst: DEVINST;\r\n ulProperty: ULONG; Buffer: Pointer; // OPTIONAL\r\n ulLength: ULONG; ulFlags: ULONG; hMachine: HMACHINE): CONFIGRET; stdcall;\r\nfunction CM_Set_DevInst_Registry_Property_ExW(dnDevInst: DEVINST;\r\n ulProperty: ULONG; Buffer: Pointer; // OPTIONAL\r\n ulLength: ULONG; ulFlags: ULONG; hMachine: HMACHINE): CONFIGRET; stdcall;\r\nfunction CM_Set_DevInst_Registry_Property_Ex(dnDevInst: DEVINST;\r\n ulProperty: ULONG; Buffer: Pointer; // OPTIONAL\r\n ulLength: ULONG; ulFlags: ULONG; hMachine: HMACHINE): CONFIGRET; stdcall;\r\n\r\n{$IFNDEF WINNT4}\r\nfunction CM_Is_Dock_Station_Present(var bPresent: BOOL): CONFIGRET; stdcall;\r\n{$ENDIF !WINNT4}\r\n\r\n{$IFDEF WIN2000_UP}\r\nfunction CM_Is_Dock_Station_Present_Ex(var bPresent: BOOL;\r\n hMachine: HMACHINE): CONFIGRET; stdcall;\r\n{$ENDIF WIN2000_UP}\r\n\r\n{$IFNDEF WINNT4}\r\nfunction CM_Request_Eject_PC: CONFIGRET; stdcall;\r\n{$ENDIF !WINNT4}\r\n\r\n{$IFDEF WIN2000_UP}\r\nfunction CM_Request_Eject_PC_Ex(hMachine: HMACHINE): CONFIGRET; stdcall;\r\n{$ENDIF WIN2000_UP}\r\n\r\nfunction CM_Set_HW_Prof_FlagsA(szDevInstName: DEVINSTID_A;\r\n ulConfig: ULONG; ulValue: ULONG; ulFlags: ULONG): CONFIGRET; stdcall;\r\nfunction CM_Set_HW_Prof_FlagsW(szDevInstName: DEVINSTID_W;\r\n ulConfig: ULONG; ulValue: ULONG; ulFlags: ULONG): CONFIGRET; stdcall;\r\nfunction CM_Set_HW_Prof_Flags(szDevInstName: DEVINSTID;\r\n ulConfig: ULONG; ulValue: ULONG; ulFlags: ULONG): CONFIGRET; stdcall;\r\n\r\nfunction CM_Set_HW_Prof_Flags_ExA(szDevInstName: DEVINSTID_A;\r\n ulConfig: ULONG; ulValue: ULONG; ulFlags: ULONG;\r\n hMachine: HMACHINE): CONFIGRET; stdcall;\r\nfunction CM_Set_HW_Prof_Flags_ExW(szDevInstName: DEVINSTID_W;\r\n ulConfig: ULONG; ulValue: ULONG; ulFlags: ULONG;\r\n hMachine: HMACHINE): CONFIGRET; stdcall;\r\nfunction CM_Set_HW_Prof_Flags_Ex(szDevInstName: DEVINSTID;\r\n ulConfig: ULONG; ulValue: ULONG; ulFlags: ULONG;\r\n hMachine: HMACHINE): CONFIGRET; stdcall;\r\n\r\nfunction CM_Setup_DevNode(dnDevInst: DEVINST; ulFlags: ULONG): CONFIGRET; stdcall;\r\n\r\nfunction CM_Setup_DevInst(dnDevInst: DEVINST; ulFlags: ULONG): CONFIGRET; stdcall;\r\n\r\nfunction CM_Setup_DevNode_Ex(dnDevInst: DEVINST; ulFlags: ULONG;\r\n hMachine: HMACHINE): CONFIGRET; stdcall;\r\n\r\nfunction CM_Setup_DevInst_Ex(dnDevInst: DEVINST; ulFlags: ULONG;\r\n hMachine: HMACHINE): CONFIGRET; stdcall;\r\n\r\nfunction CM_Test_Range_Available(ullStartValue: DWORDLONG; ullEndValue: DWORDLONG;\r\n rlh: RANGE_LIST; ulFlags: ULONG): CONFIGRET; stdcall;\r\n\r\nfunction CM_Uninstall_DevNode(dnPhantom: DEVNODE; ulFlags: ULONG): CONFIGRET; stdcall;\r\n\r\nfunction CM_Uninstall_DevInst(dnPhantom: DEVINST; ulFlags: ULONG): CONFIGRET; stdcall;\r\n\r\nfunction CM_Uninstall_DevNode_Ex(dnPhantom: DEVNODE; ulFlags: ULONG;\r\n hMachine: HMACHINE): CONFIGRET; stdcall;\r\n\r\nfunction CM_Uninstall_DevInst_Ex(dnPhantom: DEVINST; ulFlags: ULONG;\r\n hMachine: HMACHINE): CONFIGRET; stdcall;\r\n\r\nfunction CM_Run_Detection(ulFlags: ULONG): CONFIGRET; stdcall;\r\n\r\nfunction CM_Run_Detection_Ex(ulFlags: ULONG; hMachine: HMACHINE): CONFIGRET; stdcall;\r\n\r\nfunction CM_Set_HW_Prof(ulHardwareProfile: ULONG; ulFlags: ULONG): CONFIGRET; stdcall;\r\n\r\nfunction CM_Set_HW_Prof_Ex(ulHardwareProfile: ULONG; ulFlags: ULONG;\r\n hMachine: HMACHINE): CONFIGRET; stdcall;\r\n\r\n{$IFDEF WIN2000_UP}\r\n\r\nfunction CM_Query_Resource_Conflict_List(var clConflictList: CONFLICT_LIST;\r\n dnDevInst: DEVINST; ResourceID: RESOURCEID; ResourceData: Pointer;\r\n ResourceLen: ULONG; ulFlags: ULONG; hMachine: HMACHINE): CONFIGRET; stdcall;\r\n\r\nfunction CM_Free_Resource_Conflict_Handle(clConflictList: CONFLICT_LIST): CONFIGRET; stdcall;\r\n\r\nfunction CM_Get_Resource_Conflict_Count(clConflictList: CONFLICT_LIST;\r\n var ulCount: ULONG): CONFIGRET; stdcall;\r\n\r\nfunction CM_Get_Resource_Conflict_DetailsA(clConflictList: CONFLICT_LIST;\r\n ulIndex: ULONG; var ConflictDetails: CONFLICT_DETAILS_A): CONFIGRET; stdcall;\r\nfunction CM_Get_Resource_Conflict_DetailsW(clConflictList: CONFLICT_LIST;\r\n ulIndex: ULONG; var ConflictDetails: CONFLICT_DETAILS_W): CONFIGRET; stdcall;\r\nfunction CM_Get_Resource_Conflict_Details(clConflictList: CONFLICT_LIST;\r\n ulIndex: ULONG; var ConflictDetails: CONFLICT_DETAILS): CONFIGRET; stdcall;\r\n\r\nfunction CM_Get_Class_Registry_PropertyA(ClassGUID: PGUID; ulProperty: ULONG;\r\n pulRegDataType: PULONG; // OPTIONAL\r\n Buffer: Pointer; // OPTIONAL\r\n var ulLength: ULONG; ulFlags: ULONG; hMachine: HMACHINE): CONFIGRET; stdcall;\r\nfunction CM_Get_Class_Registry_PropertyW(ClassGUID: PGUID; ulProperty: ULONG;\r\n pulRegDataType: PULONG; // OPTIONAL\r\n Buffer: Pointer; // OPTIONAL\r\n var ulLength: ULONG; ulFlags: ULONG; hMachine: HMACHINE): CONFIGRET; stdcall;\r\nfunction CM_Get_Class_Registry_Property(ClassGUID: PGUID; ulProperty: ULONG;\r\n pulRegDataType: PULONG; // OPTIONAL\r\n Buffer: Pointer; // OPTIONAL\r\n var ulLength: ULONG; ulFlags: ULONG; hMachine: HMACHINE): CONFIGRET; stdcall;\r\n\r\nfunction CM_Set_Class_Registry_PropertyA(ClassGUID: PGUID; ulProperty: ULONG;\r\n Buffer: Pointer; // OPTIONAL\r\n ulLength: ULONG; ulFlags: ULONG; hMachine: HMACHINE): CONFIGRET; stdcall;\r\nfunction CM_Set_Class_Registry_PropertyW(ClassGUID: PGUID; ulProperty: ULONG;\r\n Buffer: Pointer; // OPTIONAL\r\n ulLength: ULONG; ulFlags: ULONG; hMachine: HMACHINE): CONFIGRET; stdcall;\r\nfunction CM_Set_Class_Registry_Property(ClassGUID: PGUID; ulProperty: ULONG;\r\n Buffer: Pointer; // OPTIONAL\r\n ulLength: ULONG; ulFlags: ULONG; hMachine: HMACHINE): CONFIGRET; stdcall;\r\n\r\nfunction CM_WaitNoPendingInstallEvents(dwTimeout: DWORD): DWORD; stdcall;\r\nfunction CMP_WaitNoPendingInstallEvents(dwTimeout: DWORD): DWORD; stdcall;\r\n\r\n{$ENDIF WIN2000_UP}\r\n\r\n{$ELSE}\r\n\r\ntype\r\n TCM_Add_Empty_Log_Conf = function(var lcLogConf: LOG_CONF;\r\n dnDevInst: DEVINST; Priority: PRIORITY; ulFlags: ULONG): CONFIGRET; stdcall;\r\n\r\n TCM_Add_Empty_Log_Conf_Ex = function(var lcLogConf: LOG_CONF;\r\n dnDevInst: DEVINST; Priority: PRIORITY; ulFlags: ULONG;\r\n hMachine: HMACHINE): CONFIGRET; stdcall;\r\n\r\n TCM_Add_IDA = function(dnDevInst: DEVINST; pszID: PAnsiChar;\r\n ulFlags: ULONG): CONFIGRET; stdcall;\r\n TCM_Add_IDW = function(dnDevInst: DEVINST; pszID: PWideChar;\r\n ulFlags: ULONG): CONFIGRET; stdcall;\r\n TCM_Add_ID = function(dnDevInst: DEVINST; pszID: PTSTR;\r\n ulFlags: ULONG): CONFIGRET; stdcall;\r\n\r\n TCM_Add_ID_ExA = function(dnDevInst: DEVINST; pszID: PAnsiChar;\r\n ulFlags: ULONG; hMachine: HMACHINE): CONFIGRET; stdcall;\r\n TCM_Add_ID_ExW = function(dnDevInst: DEVINST; pszID: PWideChar;\r\n ulFlags: ULONG; hMachine: HMACHINE): CONFIGRET; stdcall;\r\n TCM_Add_ID_Ex = function(dnDevInst: DEVINST; pszID: PTSTR;\r\n ulFlags: ULONG; hMachine: HMACHINE): CONFIGRET; stdcall;\r\n\r\n TCM_Add_Range = function(ullStartValue: DWORDLONG;\r\n ullEndValue: DWORDLONG; rlh: RANGE_LIST;\r\n ulFlags: ULONG): CONFIGRET; stdcall;\r\n\r\n TCM_Add_Res_Des = function(var rdResDes: RES_DES; lcLogConf: LOG_CONF;\r\n ResourceID: RESOURCEID; ResourceData: Pointer; ResourceLen: ULONG;\r\n ulFlags: ULONG): CONFIGRET; stdcall;\r\n\r\n TCM_Add_Res_Des_Ex = function(var rdResDes: RES_DES;\r\n lcLogConf: LOG_CONF; ResourceID: RESOURCEID; ResourceData: Pointer;\r\n ResourceLen: ULONG; ulFlags: ULONG; hMachine: HMACHINE): CONFIGRET; stdcall;\r\n\r\n TCM_Connect_MachineA = function(const UNCServerName: PAnsiChar;\r\n var hMachine: HMACHINE): CONFIGRET; stdcall;\r\n TCM_Connect_MachineW = function(const UNCServerName: PWideChar;\r\n var hMachine: HMACHINE): CONFIGRET; stdcall;\r\n TCM_Connect_Machine = function(const UNCServerName: PTSTR;\r\n var hMachine: HMACHINE): CONFIGRET; stdcall;\r\n\r\n TCM_Create_DevNodeA = function(var dnDevInst: DEVINST; pDeviceID: DEVINSTID_A;\r\n dnParent: DEVINST; ulFlags: ULONG): CONFIGRET; stdcall;\r\n TCM_Create_DevNodeW = function(var dnDevInst: DEVINST; pDeviceID: DEVINSTID_W;\r\n dnParent: DEVINST; ulFlags: ULONG): CONFIGRET; stdcall;\r\n TCM_Create_DevNode = function(var dnDevInst: DEVINST; pDeviceID: DEVINSTID;\r\n dnParent: DEVINST; ulFlags: ULONG): CONFIGRET; stdcall;\r\n\r\n TCM_Create_DevNode_ExA = function(var dnDevInst: DEVINST; pDeviceID: DEVINSTID_A;\r\n dnParent: DEVINST; ulFlags: ULONG; hMachine: HMACHINE): CONFIGRET; stdcall;\r\n TCM_Create_DevNode_ExW = function(var dnDevInst: DEVINST; pDeviceID: DEVINSTID_W;\r\n dnParent: DEVINST; ulFlags: ULONG; hMachine: HMACHINE): CONFIGRET; stdcall;\r\n TCM_Create_DevNode_Ex = function(var dnDevInst: DEVINST; pDeviceID: DEVINSTID;\r\n dnParent: DEVINST; ulFlags: ULONG; hMachine: HMACHINE): CONFIGRET; stdcall;\r\n\r\n TCM_Create_DevInstA = function(var dnDevInst: DEVINST; pDeviceID: DEVINSTID_A;\r\n dnParent: DEVINST; ulFlags: ULONG): CONFIGRET; stdcall;\r\n TCM_Create_DevInstW = function(var dnDevInst: DEVINST; pDeviceID: DEVINSTID_W;\r\n dnParent: DEVINST; ulFlags: ULONG): CONFIGRET; stdcall;\r\n TCM_Create_DevInst = function(var dnDevInst: DEVINST; pDeviceID: DEVINSTID;\r\n dnParent: DEVINST; ulFlags: ULONG): CONFIGRET; stdcall;\r\n\r\n TCM_Create_DevInst_ExA = function(var dnDevInst: DEVINST; pDeviceID: DEVINSTID_A;\r\n dnParent: DEVINST; ulFlags: ULONG; hMachine: HMACHINE): CONFIGRET; stdcall;\r\n TCM_Create_DevInst_ExW = function(var dnDevInst: DEVINST; pDeviceID: DEVINSTID_W;\r\n dnParent: DEVINST; ulFlags: ULONG; hMachine: HMACHINE): CONFIGRET; stdcall;\r\n\r\n TCM_Create_DevInst_Ex = function(var dnDevInst: DEVINST; pDeviceID: DEVINSTID;\r\n dnParent: DEVINST; ulFlags: ULONG; hMachine: HMACHINE): CONFIGRET; stdcall;\r\n\r\n TCM_Create_Range_List = function(var rlh: RANGE_LIST; ulFlags: ULONG): CONFIGRET; stdcall;\r\n\r\n TCM_Delete_Class_Key = function(ClassGuid: PGUID; ulFlags: ULONG): CONFIGRET; stdcall;\r\n\r\n TCM_Delete_Class_Key_Ex = function(ClassGuid: PGUID; ulFlags: ULONG;\r\n hMachine: HMACHINE): CONFIGRET; stdcall;\r\n\r\n TCM_Delete_DevNode_Key = function(dnDevNode: DEVNODE;\r\n ulHardwareProfile: ULONG; ulFlags: ULONG): CONFIGRET; stdcall;\r\n\r\n TCM_Delete_DevNode_Key_Ex = function(dnDevNode: DEVNODE;\r\n ulHardwareProfile: ULONG; ulFlags: ULONG; hMachine: HMACHINE): CONFIGRET; stdcall;\r\n\r\n TCM_Delete_DevInst_Key = function(dnDevNode: DEVINST;\r\n ulHardwareProfile: ULONG; ulFlags: ULONG): CONFIGRET; stdcall;\r\n\r\n TCM_Delete_DevInst_Key_Ex = function(dnDevNode: DEVINST; ulHardwareProfile: ULONG;\r\n ulFlags: ULONG; hMachine: HMACHINE): CONFIGRET; stdcall;\r\n\r\n TCM_Delete_Range = function(ullStartValue: DWORDLONG; ullEndValue: DWORDLONG;\r\n rlh: RANGE_LIST; ulFlags: ULONG): CONFIGRET; stdcall;\r\n\r\n TCM_Detect_Resource_Conflict = function(dnDevInst: DEVINST;\r\n ResourceID: RESOURCEID; ResourceData: Pointer; ResourceLen: ULONG;\r\n var bConflictDetected: BOOL; ulFlags: ULONG): CONFIGRET; stdcall;\r\n\r\n TCM_Detect_Resource_Conflict_Ex = function(dnDevInst: DEVINST;\r\n ResourceID: RESOURCEID; ResourceData: Pointer; ResourceLen: ULONG;\r\n var bConflictDetected: BOOL; ulFlags: ULONG; hMachine: HMACHINE): CONFIGRET; stdcall;\r\n\r\n TCM_Disable_DevNode = function(dnDevInst: DEVINST; ulFlags: ULONG): CONFIGRET; stdcall;\r\n\r\n TCM_Disable_DevNode_Ex = function(dnDevInst: DEVINST;\r\n ulFlags: ULONG; hMachine: HMACHINE): CONFIGRET; stdcall;\r\n\r\n TCM_Disable_DevInst = function(dnDevInst: DEVINST; ulFlags: ULONG): CONFIGRET; stdcall;\r\n\r\n TCM_Disable_DevInst_Ex = function(dnDevInst: DEVINST;\r\n ulFlags: ULONG; hMachine: HMACHINE): CONFIGRET; stdcall;\r\n\r\n TCM_Disconnect_Machine = function(hMachine: HMACHINE): CONFIGRET; stdcall;\r\n\r\n TCM_Dup_Range_List = function(rlhOld: RANGE_LIST; rlhNew: RANGE_LIST;\r\n ulFlags: ULONG): CONFIGRET; stdcall;\r\n\r\n TCM_Enable_DevNode = function(dnDevInst: DEVINST; ulFlags: ULONG): CONFIGRET; stdcall;\r\n\r\n TCM_Enable_DevNode_Ex = function(dnDevInst: DEVINST;\r\n ulFlags: ULONG; hMachine: HMACHINE): CONFIGRET; stdcall;\r\n\r\n TCM_Enable_DevInst = function(dnDevInst: DEVINST; ulFlags: ULONG): CONFIGRET; stdcall;\r\n\r\n TCM_Enable_DevInst_Ex = function(dnDevInst: DEVINST;\r\n ulFlags: ULONG; hMachine: HMACHINE): CONFIGRET; stdcall;\r\n\r\n TCM_Enumerate_Classes = function(ulClassIndex: ULONG;\r\n var ClassGuid: TGUID; ulFlags: ULONG): CONFIGRET; stdcall;\r\n\r\n TCM_Enumerate_Classes_Ex = function(ulClassIndex: ULONG; var ClassGuid: TGUID;\r\n ulFlags: ULONG; hMachine: HMACHINE): CONFIGRET; stdcall;\r\n\r\n TCM_Enumerate_EnumeratorsA = function(ulEnumIndex: ULONG; Buffer: PAnsiChar;\r\n var ulLength: ULONG; ulFlags: ULONG): CONFIGRET; stdcall;\r\n TCM_Enumerate_EnumeratorsW = function(ulEnumIndex: ULONG; Buffer: PWideChar;\r\n var ulLength: ULONG; ulFlags: ULONG): CONFIGRET; stdcall;\r\n TCM_Enumerate_Enumerators = function(ulEnumIndex: ULONG; Buffer: PTSTR;\r\n var ulLength: ULONG; ulFlags: ULONG): CONFIGRET; stdcall;\r\n\r\n TCM_Enumerate_Enumerators_ExA = function(ulEnumIndex: ULONG; Buffer: PAnsiChar;\r\n var ulLength: ULONG; ulFlags: ULONG; hMachine: HMACHINE): CONFIGRET; stdcall;\r\n TCM_Enumerate_Enumerators_ExW = function(ulEnumIndex: ULONG; Buffer: PWideChar;\r\n var ulLength: ULONG; ulFlags: ULONG; hMachine: HMACHINE): CONFIGRET; stdcall;\r\n TCM_Enumerate_Enumerators_Ex = function(ulEnumIndex: ULONG; Buffer: PTSTR;\r\n var ulLength: ULONG; ulFlags: ULONG; hMachine: HMACHINE): CONFIGRET; stdcall;\r\n\r\n TCM_Find_Range = function(var pullStart: DWORDLONG; ullStart: DWORDLONG;\r\n ulLength: ULONG; ullAlignment: DWORDLONG; ullEnd: DWORDLONG;\r\n rlh: RANGE_LIST; ulFlags: ULONG): CONFIGRET; stdcall;\r\n\r\n TCM_First_Range = function(rlh: RANGE_LIST; var ullStart: DWORDLONG;\r\n var ullEnd: DWORDLONG; preElement: PRANGE_ELEMENT;\r\n ulFlags: ULONG): CONFIGRET; stdcall;\r\n\r\n TCM_Free_Log_Conf = function(lcLogConfToBeFreed: LOG_CONF;\r\n ulFlags: ULONG): CONFIGRET; stdcall;\r\n\r\n TCM_Free_Log_Conf_Ex = function(lcLogConfToBeFreed: LOG_CONF;\r\n ulFlags: ULONG; hMachine: HMACHINE): CONFIGRET; stdcall;\r\n\r\n TCM_Free_Log_Conf_Handle = function(lcLogConf: LOG_CONF): CONFIGRET; stdcall;\r\n\r\n TCM_Free_Range_List = function(rlh: RANGE_LIST; ulFlags: ULONG): CONFIGRET; stdcall;\r\n\r\n TCM_Free_Res_Des = function(prdResDes: PRES_DES;\r\n rdResDes: RES_DES; ulFlags: ULONG): CONFIGRET; stdcall;\r\n\r\n TCM_Free_Res_Des_Ex = function(prdResDes: PRES_DES; rdResDes: RES_DES;\r\n ulFlags: ULONG; hMachine: HMACHINE): CONFIGRET; stdcall;\r\n\r\n TCM_Free_Res_Des_Handle = function(rdResDes: RES_DES): CONFIGRET; stdcall;\r\n\r\n TCM_Get_Child = function(var dnDevInstChild: DEVINST;\r\n dnDevInst: DEVINST; ulFlags: ULONG): CONFIGRET; stdcall;\r\n\r\n TCM_Get_Child_Ex = function(var dnDevInstChild: DEVINST; dnDevInst: DEVINST;\r\n ulFlags: ULONG; hMachine: HMACHINE): CONFIGRET; stdcall;\r\n\r\n TCM_Get_Class_NameA = function(ClassGuid: PGUID; Buffer: PAnsiChar;\r\n var ulLength: ULONG; ulFlags: ULONG): CONFIGRET; stdcall;\r\n TCM_Get_Class_NameW = function(ClassGuid: PGUID; Buffer: PWideChar;\r\n var ulLength: ULONG; ulFlags: ULONG): CONFIGRET; stdcall;\r\n TCM_Get_Class_Name = function(ClassGuid: PGUID; Buffer: PTSTR;\r\n var ulLength: ULONG; ulFlags: ULONG): CONFIGRET; stdcall;\r\n\r\n TCM_Get_Class_Name_ExA = function(ClassGuid: PGUID; Buffer: PAnsiChar;\r\n var ulLength: ULONG; ulFlags: ULONG; hMachine: HMACHINE): CONFIGRET; stdcall;\r\n TCM_Get_Class_Name_ExW = function(ClassGuid: PGUID; Buffer: PWideChar;\r\n var ulLength: ULONG; ulFlags: ULONG; hMachine: HMACHINE): CONFIGRET; stdcall;\r\n TCM_Get_Class_Name_Ex = function(ClassGuid: PGUID; Buffer: PTSTR;\r\n var ulLength: ULONG; ulFlags: ULONG; hMachine: HMACHINE): CONFIGRET; stdcall;\r\n\r\n TCM_Get_Class_Key_NameA = function(ClassGuid: PGUID; pszKeyName: PAnsiChar;\r\n var ulLength: ULONG; ulFlags: ULONG): CONFIGRET; stdcall;\r\n TCM_Get_Class_Key_NameW = function(ClassGuid: PGUID; pszKeyName: PWideChar;\r\n var ulLength: ULONG; ulFlags: ULONG): CONFIGRET; stdcall;\r\n TCM_Get_Class_Key_Name = function(ClassGuid: PGUID; pszKeyName: PTSTR;\r\n var ulLength: ULONG; ulFlags: ULONG): CONFIGRET; stdcall;\r\n\r\n TCM_Get_Class_Key_Name_ExA = function(ClassGuid: PGUID; pszKeyName: PAnsiChar;\r\n var ulLength: ULONG; ulFlags: ULONG; hMachine: HMACHINE): CONFIGRET; stdcall;\r\n TCM_Get_Class_Key_Name_ExW = function(ClassGuid: PGUID; pszKeyName: PWideChar;\r\n var ulLength: ULONG; ulFlags: ULONG; hMachine: HMACHINE): CONFIGRET; stdcall;\r\n TCM_Get_Class_Key_Name_Ex = function(ClassGuid: PGUID; pszKeyName: PTSTR;\r\n var ulLength: ULONG; ulFlags: ULONG; hMachine: HMACHINE): CONFIGRET; stdcall;\r\n\r\n TCM_Get_Depth = function(var ulDepth: ULONG; dnDevInst: DEVINST;\r\n ulFlags: ULONG): CONFIGRET; stdcall;\r\n\r\n TCM_Get_Depth_Ex = function(var ulDepth: ULONG; dnDevInst: DEVINST;\r\n ulFlags: ULONG; hMachine: HMACHINE): CONFIGRET; stdcall;\r\n\r\n TCM_Get_Device_IDA = function(dnDevInst: DEVINST; Buffer: PAnsiChar;\r\n BufferLen: ULONG; ulFlags: ULONG): CONFIGRET; stdcall;\r\n TCM_Get_Device_IDW = function(dnDevInst: DEVINST; Buffer: PWideChar;\r\n BufferLen: ULONG; ulFlags: ULONG): CONFIGRET; stdcall;\r\n TCM_Get_Device_ID = function(dnDevInst: DEVINST; Buffer: PTSTR;\r\n BufferLen: ULONG; ulFlags: ULONG): CONFIGRET; stdcall;\r\n\r\n TCM_Get_Device_ID_ExA = function(dnDevInst: DEVINST; Buffer: PAnsiChar;\r\n BufferLen: ULONG; ulFlags: ULONG; hMachine: HMACHINE): CONFIGRET; stdcall;\r\n TCM_Get_Device_ID_ExW = function(dnDevInst: DEVINST; Buffer: PWideChar;\r\n BufferLen: ULONG; ulFlags: ULONG; hMachine: HMACHINE): CONFIGRET; stdcall;\r\n TCM_Get_Device_ID_Ex = function(dnDevInst: DEVINST; Buffer: PTSTR;\r\n BufferLen: ULONG; ulFlags: ULONG; hMachine: HMACHINE): CONFIGRET; stdcall;\r\n\r\n TCM_Get_Device_ID_ListA = function(const pszFilter: PAnsiChar; // OPTIONAL\r\n Buffer: PAnsiChar; BufferLen: ULONG; ulFlags: ULONG): CONFIGRET; stdcall;\r\n TCM_Get_Device_ID_ListW = function(const pszFilter: PWideChar; // OPTIONAL\r\n Buffer: PWideChar; BufferLen: ULONG; ulFlags: ULONG): CONFIGRET; stdcall;\r\n TCM_Get_Device_ID_List = function(const pszFilter: PTSTR; // OPTIONAL\r\n Buffer: PTSTR; BufferLen: ULONG; ulFlags: ULONG): CONFIGRET; stdcall;\r\n\r\n TCM_Get_Device_ID_List_ExA = function(const pszFilter: PAnsiChar; // OPTIONAL\r\n Buffer: PAnsiChar; BufferLen: ULONG; ulFlags: ULONG;\r\n hMachine: HMACHINE): CONFIGRET; stdcall;\r\n TCM_Get_Device_ID_List_ExW = function(const pszFilter: PWideChar; // OPTIONAL\r\n Buffer: PWideChar; BufferLen: ULONG; ulFlags: ULONG;\r\n hMachine: HMACHINE): CONFIGRET; stdcall;\r\n TCM_Get_Device_ID_List_Ex = function(const pszFilter: PTSTR; // OPTIONAL\r\n Buffer: PTSTR; BufferLen: ULONG; ulFlags: ULONG;\r\n hMachine: HMACHINE): CONFIGRET; stdcall;\r\n\r\n TCM_Get_Device_ID_List_SizeA = function(var ulLen: ULONG;\r\n const pszFilter: PAnsiChar; // OPTIONAL\r\n ulFlags: ULONG): CONFIGRET; stdcall;\r\n TCM_Get_Device_ID_List_SizeW = function(var ulLen: ULONG;\r\n const pszFilter: PWideChar; // OPTIONAL\r\n ulFlags: ULONG): CONFIGRET; stdcall;\r\n TCM_Get_Device_ID_List_Size = function(var pulLen: ULONG;\r\n const pszFilter: PTSTR; // OPTIONAL\r\n ulFlags: ULONG): CONFIGRET; stdcall;\r\n\r\n TCM_Get_Device_ID_List_Size_ExA = function(var ulLen: ULONG;\r\n const pszFilter: PAnsiChar; // OPTIONAL\r\n ulFlags: ULONG; hMachine: HMACHINE): CONFIGRET; stdcall;\r\n TCM_Get_Device_ID_List_Size_ExW = function(var ulLen: ULONG;\r\n const pszFilter: PWideChar; // OPTIONAL\r\n ulFlags: ULONG; hMachine: HMACHINE): CONFIGRET; stdcall;\r\n TCM_Get_Device_ID_List_Size_Ex = function(var ulLen: ULONG;\r\n const pszFilter: PTSTR; // OPTIONAL\r\n ulFlags: ULONG; hMachine: HMACHINE): CONFIGRET; stdcall;\r\n\r\n TCM_Get_Device_ID_Size = function(var ulLen: ULONG;\r\n dnDevInst: DEVINST; ulFlags: ULONG): CONFIGRET; stdcall;\r\n\r\n TCM_Get_Device_ID_Size_Ex = function(var ulLen: ULONG; dnDevInst: DEVINST;\r\n ulFlags: ULONG; hMachine: HMACHINE): CONFIGRET; stdcall;\r\n\r\n TCM_Get_DevNode_Registry_PropertyA = function(dnDevInst: DEVINST;\r\n ulProperty: ULONG;\r\n pulRegDataType: PULONG; // OPTIONAL\r\n Buffer: Pointer; // OPTIONAL\r\n var ulLength: ULONG; ulFlags: ULONG): CONFIGRET; stdcall;\r\n TCM_Get_DevNode_Registry_PropertyW = function(dnDevInst: DEVINST;\r\n ulProperty: ULONG;\r\n pulRegDataType: PULONG; // OPTIONAL\r\n Buffer: Pointer; // OPTIONAL\r\n var ulLength: ULONG; ulFlags: ULONG): CONFIGRET; stdcall;\r\n TCM_Get_DevNode_Registry_Property = function(dnDevInst: DEVINST;\r\n ulProperty: ULONG;\r\n pulRegDataType: PULONG; // OPTIONAL\r\n Buffer: Pointer; // OPTIONAL\r\n var ulLength: ULONG; ulFlags: ULONG): CONFIGRET; stdcall;\r\n\r\n TCM_Get_DevNode_Registry_Property_ExA = function(dnDevInst: DEVINST; ulProperty: ULONG;\r\n pulRegDataType: PULONG; // OPTIONAL\r\n Buffer: Pointer; // OPTIONAL\r\n var ulLength: ULONG; ulFlags: ULONG; hMachine: HMACHINE): CONFIGRET; stdcall;\r\n TCM_Get_DevNode_Registry_Property_ExW = function(dnDevInst: DEVINST; ulProperty: ULONG;\r\n pulRegDataType: PULONG; // OPTIONAL\r\n Buffer: Pointer; // OPTIONAL\r\n var ulLength: ULONG; ulFlags: ULONG; hMachine: HMACHINE): CONFIGRET; stdcall;\r\n TCM_Get_DevNode_Registry_Property_Ex = function(dnDevInst: DEVINST; ulProperty: ULONG;\r\n pulRegDataType: PULONG; // OPTIONAL\r\n Buffer: Pointer; // OPTIONAL\r\n var ulLength: ULONG; ulFlags: ULONG; hMachine: HMACHINE): CONFIGRET; stdcall;\r\n\r\n TCM_Get_DevInst_Registry_PropertyA = function(dnDevInst: DEVINST; ulProperty: ULONG;\r\n pulRegDataType: PULONG; // OPTIONAL\r\n Buffer: Pointer; // OPTIONAL\r\n var ulLength: ULONG; ulFlags: ULONG): CONFIGRET; stdcall;\r\n TCM_Get_DevInst_Registry_PropertyW = function(dnDevInst: DEVINST; ulProperty: ULONG;\r\n pulRegDataType: PULONG; // OPTIONAL\r\n Buffer: Pointer; // OPTIONAL\r\n var ulLength: ULONG; ulFlags: ULONG): CONFIGRET; stdcall;\r\n TCM_Get_DevInst_Registry_Property = function(dnDevInst: DEVINST; ulProperty: ULONG;\r\n pulRegDataType: PULONG; // OPTIONAL\r\n Buffer: Pointer; // OPTIONAL\r\n var ulLength: ULONG; ulFlags: ULONG): CONFIGRET; stdcall;\r\n\r\n TCM_Get_DevInst_Registry_Property_ExA = function(dnDevInst: DEVINST; ulProperty: ULONG;\r\n pulRegDataType: PULONG; // OPTIONAL\r\n Buffer: Pointer; // OPTIONAL\r\n var ulLength: ULONG; ulFlags: ULONG; hMachine: HMACHINE): CONFIGRET; stdcall;\r\n TCM_Get_DevInst_Registry_Property_ExW = function(dnDevInst: DEVINST; ulProperty: ULONG;\r\n pulRegDataType: PULONG; // OPTIONAL\r\n Buffer: Pointer; // OPTIONAL\r\n var ulLength: ULONG; ulFlags: ULONG; hMachine: HMACHINE): CONFIGRET; stdcall;\r\n TCM_Get_DevInst_Registry_Property_Ex = function(dnDevInst: DEVINST; ulProperty: ULONG;\r\n pulRegDataType: PULONG; // OPTIONAL\r\n Buffer: Pointer; // OPTIONAL\r\n var ulLength: ULONG; ulFlags: ULONG; hMachine: HMACHINE): CONFIGRET; stdcall;\r\n\r\n {$IFDEF WINXP_UP}\r\n\r\n TCM_Get_DevNode_Custom_PropertyA = function(dnDevInst: DEVINST;\r\n const pszCustomPropertyName: PAnsiChar;\r\n pulRegDataType: PULONG; // OPTIONAL\r\n Buffer: Pointer; // OPTIONAL\r\n var ulLength: ULONG; ulFlags: ULONG): CONFIGRET; stdcall;\r\n TCM_Get_DevNode_Custom_PropertyW = function(dnDevInst: DEVINST;\r\n const pszCustomPropertyName: PWideChar;\r\n pulRegDataType: PULONG; // OPTIONAL\r\n Buffer: Pointer; // OPTIONAL\r\n var ulLength: ULONG; ulFlags: ULONG): CONFIGRET; stdcall;\r\n TCM_Get_DevNode_Custom_Property = function(dnDevInst: DEVINST;\r\n const pszCustomPropertyName: PTSTR;\r\n pulRegDataType: PULONG; // OPTIONAL\r\n Buffer: Pointer; // OPTIONAL\r\n var ulLength: ULONG; ulFlags: ULONG): CONFIGRET; stdcall;\r\n\r\n TCM_Get_DevNode_Custom_Property_ExA = function(dnDevInst: DEVINST;\r\n const pszCustomPropertyName: PAnsiChar;\r\n pulRegDataType: PULONG; // OPTIONAL\r\n Buffer: Pointer; // OPTIONAL\r\n var ulLength: ULONG; ulFlags: ULONG; hMachine: HMACHINE): CONFIGRET; stdcall;\r\n TCM_Get_DevNode_Custom_Property_ExW = function(dnDevInst: DEVINST;\r\n const pszCustomPropertyName: PWideChar;\r\n pulRegDataType: PULONG; // OPTIONAL\r\n Buffer: Pointer; // OPTIONAL\r\n var ulLength: ULONG; ulFlags: ULONG; hMachine: HMACHINE): CONFIGRET; stdcall;\r\n TCM_Get_DevNode_Custom_Property_Ex = function(dnDevInst: DEVINST;\r\n const pszCustomPropertyName: PTSTR;\r\n pulRegDataType: PULONG; // OPTIONAL\r\n Buffer: Pointer; // OPTIONAL\r\n var ulLength: ULONG; ulFlags: ULONG; hMachine: HMACHINE): CONFIGRET; stdcall;\r\n\r\n TCM_Get_DevInst_Custom_PropertyA = function(dnDevInst: DEVINST;\r\n const pszCustomPropertyName: PAnsiChar;\r\n pulRegDataType: PULONG; // OPTIONAL\r\n Buffer: Pointer; // OPTIONAL\r\n var ulLength: ULONG; ulFlags: ULONG): CONFIGRET; stdcall;\r\n TCM_Get_DevInst_Custom_PropertyW = function(dnDevInst: DEVINST;\r\n const pszCustomPropertyName: PWideChar;\r\n pulRegDataType: PULONG; // OPTIONAL\r\n Buffer: Pointer; // OPTIONAL\r\n var ulLength: ULONG; ulFlags: ULONG): CONFIGRET; stdcall;\r\n TCM_Get_DevInst_Custom_Property = function(dnDevInst: DEVINST;\r\n const pszCustomPropertyName: PTSTR;\r\n pulRegDataType: PULONG; // OPTIONAL\r\n Buffer: Pointer; // OPTIONAL\r\n var ulLength: ULONG; ulFlags: ULONG): CONFIGRET; stdcall;\r\n\r\n TCM_Get_DevInst_Custom_Property_ExA = function(dnDevInst: DEVINST;\r\n const pszCustomPropertyName: PAnsiChar;\r\n pulRegDataType: PULONG; // OPTIONAL\r\n Buffer: Pointer; // OPTIONAL\r\n var ulLength: ULONG; ulFlags: ULONG; hMachine: HMACHINE): CONFIGRET; stdcall;\r\n TCM_Get_DevInst_Custom_Property_ExW = function(dnDevInst: DEVINST;\r\n const pszCustomPropertyName: PWideChar;\r\n pulRegDataType: PULONG; // OPTIONAL\r\n Buffer: Pointer; // OPTIONAL\r\n var ulLength: ULONG; ulFlags: ULONG; hMachine: HMACHINE): CONFIGRET; stdcall;\r\n TCM_Get_DevInst_Custom_Property_Ex = function(dnDevInst: DEVINST;\r\n const pszCustomPropertyName: PTSTR;\r\n pulRegDataType: PULONG; // OPTIONAL\r\n Buffer: Pointer; // OPTIONAL\r\n var ulLength: ULONG; ulFlags: ULONG; hMachine: HMACHINE): CONFIGRET; stdcall;\r\n\r\n {$ENDIF WINXP_UP}\r\n\r\n TCM_Get_DevNode_Status = function(var ulStatus: ULONG; var ulProblemNumber: ULONG;\r\n dnDevInst: DEVINST; ulFlags: ULONG): CONFIGRET; stdcall;\r\n\r\n TCM_Get_DevInst_Status = function(var ulStatus: ULONG; var ulProblemNumber: ULONG;\r\n dnDevInst: DEVINST; ulFlags: ULONG): CONFIGRET; stdcall;\r\n\r\n TCM_Get_DevNode_Status_Ex = function(var ulStatus: ULONG; var ulProblemNumber: ULONG;\r\n dnDevInst: DEVINST; ulFlags: ULONG; hMachine: HMACHINE): CONFIGRET; stdcall;\r\n\r\n TCM_Get_DevInst_Status_Ex = function(var ulStatus: ULONG; var ulProblemNumber: ULONG;\r\n dnDevInst: DEVINST; ulFlags: ULONG; hMachine: HMACHINE): CONFIGRET; stdcall;\r\n\r\n TCM_Get_First_Log_Conf = function(plcLogConf: PLOG_CONF; // OPTIONAL\r\n dnDevInst: DEVINST; ulFlags: ULONG): CONFIGRET; stdcall;\r\n\r\n TCM_Get_First_Log_Conf_Ex = function(plcLogConf: PLOG_CONF; // OPTIONAL\r\n dnDevInst: DEVINST; ulFlags: ULONG; hMachine: HMACHINE): CONFIGRET; stdcall;\r\n\r\n TCM_Get_Global_State = function(var ulState: ULONG; ulFlags: ULONG): CONFIGRET; stdcall;\r\n\r\n TCM_Get_Global_State_Ex = function(var ulState: ULONG; ulFlags: ULONG;\r\n hMachine: HMACHINE): CONFIGRET; stdcall;\r\n\r\n TCM_Get_Hardware_Profile_InfoA = function(ulIndex: ULONG;\r\n var HWProfileInfo: HWPROFILEINFO_A; ulFlags: ULONG): CONFIGRET; stdcall;\r\n TCM_Get_Hardware_Profile_InfoW = function(ulIndex: ULONG;\r\n var HWProfileInfo: HWPROFILEINFO_W; ulFlags: ULONG): CONFIGRET; stdcall;\r\n TCM_Get_Hardware_Profile_Info = function(ulIndex: ULONG;\r\n var HWProfileInfo: HWPROFILEINFO; ulFlags: ULONG): CONFIGRET; stdcall;\r\n\r\n TCM_Get_Hardware_Profile_Info_ExA = function(ulIndex: ULONG;\r\n var HWProfileInfo: HWPROFILEINFO_A; ulFlags: ULONG;\r\n hMachine: HMACHINE): CONFIGRET; stdcall;\r\n TCM_Get_Hardware_Profile_Info_ExW = function(ulIndex: ULONG;\r\n var HWProfileInfo: HWPROFILEINFO_W; ulFlags: ULONG;\r\n hMachine: HMACHINE): CONFIGRET; stdcall;\r\n TCM_Get_Hardware_Profile_Info_Ex = function(ulIndex: ULONG;\r\n var HWProfileInfo: HWPROFILEINFO; ulFlags: ULONG;\r\n hMachine: HMACHINE): CONFIGRET; stdcall;\r\n\r\n TCM_Get_HW_Prof_FlagsA = function(szDevInstName: DEVINSTID_A;\r\n ulHardwareProfile: ULONG; var ulValue: ULONG;\r\n ulFlags: ULONG): CONFIGRET; stdcall;\r\n TCM_Get_HW_Prof_FlagsW = function(szDevInstName: DEVINSTID_W;\r\n ulHardwareProfile: ULONG; var ulValue: ULONG;\r\n ulFlags: ULONG): CONFIGRET; stdcall;\r\n TCM_Get_HW_Prof_Flags = function(szDevInstName: DEVINSTID;\r\n ulHardwareProfile: ULONG; var ulValue: ULONG; ulFlags: ULONG): CONFIGRET; stdcall;\r\n\r\n TCM_Get_HW_Prof_Flags_ExA = function(szDevInstName: DEVINSTID_A;\r\n ulHardwareProfile: ULONG; var ulValue: ULONG;\r\n ulFlags: ULONG; hMachine: HMACHINE): CONFIGRET; stdcall;\r\n TCM_Get_HW_Prof_Flags_ExW = function(szDevInstName: DEVINSTID_W;\r\n ulHardwareProfile: ULONG; var ulValue: ULONG;\r\n ulFlags: ULONG; hMachine: HMACHINE): CONFIGRET; stdcall;\r\n TCM_Get_HW_Prof_Flags_Ex = function(szDevInstName: DEVINSTID;\r\n ulHardwareProfile: ULONG; var ulValue: ULONG;\r\n ulFlags: ULONG; hMachine: HMACHINE): CONFIGRET; stdcall;\r\n\r\n {$IFNDEF WINNT4}\r\n\r\n TCM_Get_Device_Interface_AliasA = function(const pszDeviceInterface: PAnsiChar;\r\n AliasInterfaceGuid: PGUID; pszAliasDeviceInterface: PAnsiChar;\r\n var ulLength: ULONG; ulFlags: ULONG): CONFIGRET; stdcall;\r\n TCM_Get_Device_Interface_AliasW = function(const pszDeviceInterface: PWideChar;\r\n AliasInterfaceGuid: PGUID; pszAliasDeviceInterface: PWideChar;\r\n var ulLength: ULONG; ulFlags: ULONG): CONFIGRET; stdcall;\r\n\r\n TCM_Get_Device_Interface_Alias = function(const pszDeviceInterface: PTSTR;\r\n AliasInterfaceGuid: PGUID; pszAliasDeviceInterface: PTSTR;\r\n var ulLength: ULONG; ulFlags: ULONG): CONFIGRET; stdcall;\r\n\r\n TCM_Get_Device_Interface_Alias_ExA = function(const pszDeviceInterface: PAnsiChar;\r\n AliasInterfaceGuid: PGUID; pszAliasDeviceInterface: PAnsiChar;\r\n var ulLength: ULONG; ulFlags: ULONG; hMachine: HMACHINE): CONFIGRET; stdcall;\r\n TCM_Get_Device_Interface_Alias_ExW = function(const pszDeviceInterface: PWideChar;\r\n AliasInterfaceGuid: PGUID; pszAliasDeviceInterface: PWideChar;\r\n var ulLength: ULONG; ulFlags: ULONG; hMachine: HMACHINE): CONFIGRET; stdcall;\r\n TCM_Get_Device_Interface_Alias_Ex = function(const pszDeviceInterface: PTSTR;\r\n AliasInterfaceGuid: PGUID; pszAliasDeviceInterface: PTSTR;\r\n var ulLength: ULONG; ulFlags: ULONG; hMachine: HMACHINE): CONFIGRET; stdcall;\r\n\r\n TCM_Get_Device_Interface_ListA = function(InterfaceClassGuid: PGUID;\r\n pDeviceID: DEVINSTID_A; // OPTIONAL\r\n Buffer: PAnsiChar; BufferLen: ULONG; ulFlags: ULONG): CONFIGRET; stdcall;\r\n TCM_Get_Device_Interface_ListW = function(InterfaceClassGuid: PGUID;\r\n pDeviceID: DEVINSTID_W; // OPTIONAL\r\n Buffer: PWideChar; BufferLen: ULONG; ulFlags: ULONG): CONFIGRET; stdcall;\r\n TCM_Get_Device_Interface_List = function(InterfaceClassGuid: PGUID;\r\n pDeviceID: DEVINSTID; // OPTIONAL\r\n Buffer: PTSTR; BufferLen: ULONG; ulFlags: ULONG): CONFIGRET; stdcall;\r\n\r\n TCM_Get_Device_Interface_List_ExA = function(InterfaceClassGuid: PGUID;\r\n pDeviceID: DEVINSTID_A; // OPTIONAL\r\n Buffer: PAnsiChar; BufferLen: ULONG; ulFlags: ULONG;\r\n hMachine: HMACHINE): CONFIGRET; stdcall;\r\n TCM_Get_Device_Interface_List_ExW = function(InterfaceClassGuid: PGUID;\r\n pDeviceID: DEVINSTID_W; // OPTIONAL\r\n Buffer: PWideChar; BufferLen: ULONG; ulFlags: ULONG;\r\n hMachine: HMACHINE): CONFIGRET; stdcall;\r\n TCM_Get_Device_Interface_List_Ex = function(InterfaceClassGuid: PGUID;\r\n pDeviceID: DEVINSTID; // OPTIONAL\r\n Buffer: PTSTR; BufferLen: ULONG; ulFlags: ULONG;\r\n hMachine: HMACHINE): CONFIGRET; stdcall;\r\n\r\n TCM_Get_Device_Interface_List_SizeA = function(var ulLen: ULONG;\r\n InterfaceClassGuid: PGUID; pDeviceID: DEVINSTID_A; // OPTIONAL\r\n ulFlags: ULONG): CONFIGRET; stdcall;\r\n TCM_Get_Device_Interface_List_SizeW = function(var ulLen: ULONG;\r\n InterfaceClassGuid: PGUID; pDeviceID: DEVINSTID_W; // OPTIONAL\r\n ulFlags: ULONG): CONFIGRET; stdcall;\r\n TCM_Get_Device_Interface_List_Size = function(var ulLen: ULONG;\r\n InterfaceClassGuid: PGUID; pDeviceID: DEVINSTID; // OPTIONAL\r\n ulFlags: ULONG): CONFIGRET; stdcall;\r\n\r\n TCM_Get_Device_Interface_List_Size_ExA = function(var ulLen: ULONG;\r\n InterfaceClassGuid: PGUID; pDeviceID: DEVINSTID_A; // OPTIONAL\r\n ulFlags: ULONG; hMachine: HMACHINE): CONFIGRET; stdcall;\r\n TCM_Get_Device_Interface_List_Size_ExW = function(var ulLen: ULONG;\r\n InterfaceClassGuid: PGUID; pDeviceID: DEVINSTID_W; // OPTIONAL\r\n ulFlags: ULONG; hMachine: HMACHINE): CONFIGRET; stdcall;\r\n TCM_Get_Device_Interface_List_Size_Ex = function(var ulLen: ULONG;\r\n InterfaceClassGuid: PGUID; pDeviceID: DEVINSTID; // OPTIONAL\r\n ulFlags: ULONG; hMachine: HMACHINE): CONFIGRET; stdcall;\r\n\r\n TCM_Get_Log_Conf_Priority = function(lcLogConf: LOG_CONF;\r\n var Priority: PRIORITY; ulFlags: ULONG): CONFIGRET; stdcall;\r\n\r\n TCM_Get_Log_Conf_Priority_Ex = function(lcLogConf: LOG_CONF;\r\n var Priority: PRIORITY; ulFlags: ULONG; hMachine: HMACHINE): CONFIGRET; stdcall;\r\n\r\n {$ENDIF !WINNT4}\r\n\r\n TCM_Get_Next_Log_Conf = function(plcLogConf: PLOG_CONF; // OPTIONAL\r\n lcLogConf: LOG_CONF; ulFlags: ULONG): CONFIGRET; stdcall;\r\n\r\n TCM_Get_Next_Log_Conf_Ex = function(plcLogConf: PLOG_CONF; // OPTIONAL\r\n lcLogConf: LOG_CONF; ulFlags: ULONG; hMachine: HMACHINE): CONFIGRET; stdcall;\r\n\r\n TCM_Get_Parent = function(var dnDevInstParent: DEVINST;\r\n dnDevInst: DEVINST; ulFlags: ULONG): CONFIGRET; stdcall;\r\n\r\n TCM_Get_Parent_Ex = function(var dnDevInstParent: DEVINST;\r\n dnDevInst: DEVINST; ulFlags: ULONG; hMachine: HMACHINE): CONFIGRET; stdcall;\r\n\r\n TCM_Get_Res_Des_Data = function(rdResDes: RES_DES; Buffer: Pointer;\r\n BufferLen: ULONG; ulFlags: ULONG): CONFIGRET; stdcall;\r\n\r\n TCM_Get_Res_Des_Data_Ex = function(rdResDes: RES_DES; Buffer: Pointer;\r\n BufferLen: ULONG; ulFlags: ULONG; hMachine: HMACHINE): CONFIGRET; stdcall;\r\n\r\n TCM_Get_Res_Des_Data_Size = function(var ulSize: ULONG; rdResDes: RES_DES;\r\n ulFlags: ULONG): CONFIGRET; stdcall;\r\n\r\n TCM_Get_Res_Des_Data_Size_Ex = function(var ulSize: ULONG; rdResDes: RES_DES;\r\n ulFlags: ULONG; hMachine: HMACHINE): CONFIGRET; stdcall;\r\n\r\n TCM_Get_Sibling = function(var dnDevInstSibling: DEVINST;\r\n DevInst: DEVINST; ulFlags: ULONG): CONFIGRET; stdcall;\r\n\r\n TCM_Get_Sibling_Ex = function(var dnDevInstSibling: DEVINST;\r\n DevInst: DEVINST; ulFlags: ULONG; hMachine: HMACHINE): CONFIGRET; stdcall;\r\n\r\n TCM_Get_Version = function: WORD; stdcall;\r\n\r\n TCM_Get_Version_Ex = function(hMachine: HMACHINE): WORD; stdcall;\r\n\r\n {$IFDEF WINXP_UP}\r\n\r\n TCM_Is_Version_Available = function(wVersion: WORD): BOOL; stdcall;\r\n\r\n TCM_Is_Version_Available_Ex = function(wVersion: WORD;\r\n hMachine: HMACHINE): BOOL; stdcall;\r\n\r\n {$ENDIF WINXP_UP}\r\n\r\n TCM_Intersect_Range_List = function(rlhOld1: RANGE_LIST;rlhOld2: RANGE_LIST;\r\n rlhNew: RANGE_LIST; ulFlags: ULONG): CONFIGRET; stdcall;\r\n\r\n TCM_Invert_Range_List = function(rlhOld: RANGE_LIST; rlhNew: RANGE_LIST;\r\n ullMaxValue: DWORDLONG; ulFlags: ULONG): CONFIGRET; stdcall;\r\n\r\n TCM_Locate_DevNodeA = function(var dnDevInst: DEVINST;\r\n pDeviceID: DEVINSTID_A; // OPTIONAL\r\n ulFlags: ULONG): CONFIGRET; stdcall;\r\n TCM_Locate_DevNodeW = function(var dnDevInst: DEVINST;\r\n pDeviceID: DEVINSTID_W; // OPTIONAL\r\n ulFlags: ULONG): CONFIGRET; stdcall;\r\n TCM_Locate_DevNode = function(var dnDevInst: DEVINST;\r\n pDeviceID: DEVINSTID; // OPTIONAL\r\n ulFlags: ULONG): CONFIGRET; stdcall;\r\n\r\n TCM_Locate_DevNode_ExA = function(var dnDevInst: DEVINST;\r\n pDeviceID: DEVINSTID_A; // OPTIONAL\r\n ulFlags: ULONG; hMachine: HMACHINE): CONFIGRET; stdcall;\r\n TCM_Locate_DevNode_ExW = function(var dnDevInst: DEVINST;\r\n pDeviceID: DEVINSTID_W; // OPTIONAL\r\n ulFlags: ULONG; hMachine: HMACHINE): CONFIGRET; stdcall;\r\n TCM_Locate_DevNode_Ex = function(var dnDevInst: DEVINST;\r\n pDeviceID: DEVINSTID; // OPTIONAL\r\n ulFlags: ULONG; hMachine: HMACHINE): CONFIGRET; stdcall;\r\n\r\n TCM_Locate_DevInstA = function(var dnDevInst: DEVINST;\r\n pDeviceID: DEVINSTID_A; // OPTIONAL\r\n ulFlags: ULONG): CONFIGRET; stdcall;\r\n TCM_Locate_DevInstW = function(var dnDevInst: DEVINST;\r\n pDeviceID: DEVINSTID_W; // OPTIONAL\r\n ulFlags: ULONG): CONFIGRET; stdcall;\r\n TCM_Locate_DevInst = function(var dnDevInst: DEVINST;\r\n pDeviceID: DEVINSTID; // OPTIONAL\r\n ulFlags: ULONG): CONFIGRET; stdcall;\r\n\r\n TCM_Locate_DevInst_ExA = function(var dnDevInst: DEVINST;\r\n pDeviceID: DEVINSTID_A; // OPTIONAL\r\n ulFlags: ULONG; hMachine: HMACHINE): CONFIGRET; stdcall;\r\n TCM_Locate_DevInst_ExW = function(var dnDevInst: DEVINST;\r\n pDeviceID: DEVINSTID_W; // OPTIONAL\r\n ulFlags: ULONG; hMachine: HMACHINE): CONFIGRET; stdcall;\r\n TCM_Locate_DevInst_Ex = function(var dnDevInst: DEVINST;\r\n pDeviceID: DEVINSTID; // OPTIONAL\r\n ulFlags: ULONG; hMachine: HMACHINE): CONFIGRET; stdcall;\r\n\r\n TCM_Merge_Range_List = function(rlhOld1: RANGE_LIST; rlhOld2: RANGE_LIST;\r\n rlhNew: RANGE_LIST; ulFlags: ULONG): CONFIGRET; stdcall;\r\n\r\n TCM_Modify_Res_Des = function(var rdResDesModified: RES_DES;\r\n rdResDes: RES_DES; ResourceID: RESOURCEID; ResourceData: Pointer;\r\n ResourceLen: ULONG; ulFlags: ULONG): CONFIGRET; stdcall;\r\n\r\n TCM_Modify_Res_Des_Ex = function(var rdResDesModified: RES_DES;\r\n rdResDes: RES_DES; ResourceID: RESOURCEID; ResourceData: Pointer;\r\n ResourceLen: ULONG; ulFlags: ULONG; hMachine: HMACHINE): CONFIGRET; stdcall;\r\n\r\n TCM_Move_DevNode = function(dnFromDevInst: DEVINST;\r\n dnToDevInst: DEVINST; ulFlags: ULONG): CONFIGRET; stdcall;\r\n\r\n TCM_Move_DevInst = function(dnFromDevInst: DEVINST;\r\n dnToDevInst: DEVINST; ulFlags: ULONG): CONFIGRET; stdcall;\r\n\r\n TCM_Move_DevNode_Ex = function(dnFromDevInst: DEVINST;\r\n dnToDevInst: DEVINST; ulFlags: ULONG; hMachine: HMACHINE): CONFIGRET; stdcall;\r\n\r\n TCM_Move_DevInst_Ex = function(dnFromDevInst: DEVINST;\r\n dnToDevInst: DEVINST; ulFlags: ULONG; hMachine: HMACHINE): CONFIGRET; stdcall;\r\n\r\n TCM_Next_Range = function(var reElement: RANGE_ELEMENT;\r\n var ullStart: DWORDLONG; var ullEnd: DWORDLONG;\r\n ulFlags: ULONG): CONFIGRET; stdcall;\r\n\r\n TCM_Get_Next_Res_Des = function(var rdResDesNext: RES_DES;\r\n rdResDes: RES_DES; ForResource: RESOURCEID; var ResourceID: RESOURCEID;\r\n ulFlags: ULONG): CONFIGRET; stdcall;\r\n\r\n TCM_Get_Next_Res_Des_Ex = function(var rdResDesNext: RES_DES;\r\n rdResDes: RES_DES; ForResource: RESOURCEID; var ResourceID: RESOURCEID;\r\n ulFlags: ULONG; hMachine: HMACHINE): CONFIGRET; stdcall;\r\n\r\n TCM_Open_Class_KeyA = function(ClassGuid: PGUID; // OPTIONAL\r\n const pszClassName: PAnsiChar; // OPTIONAL\r\n samDesired: REGSAM; Disposition: REGDISPOSITION;\r\n var hkClass: HKEY; ulFlags: ULONG): CONFIGRET; stdcall;\r\n TCM_Open_Class_KeyW = function(ClassGuid: PGUID; // OPTIONAL\r\n const pszClassName: PWideChar; // OPTIONAL\r\n samDesired: REGSAM; Disposition: REGDISPOSITION;\r\n var hkClass: HKEY; ulFlags: ULONG): CONFIGRET; stdcall;\r\n TCM_Open_Class_Key = function(ClassGuid: PGUID; // OPTIONAL\r\n const pszClassName: PTSTR; // OPTIONAL\r\n samDesired: REGSAM; Disposition: REGDISPOSITION;\r\n var hkClass: HKEY; ulFlags: ULONG): CONFIGRET; stdcall;\r\n\r\n TCM_Open_Class_Key_ExA = function(pszClassGuid: PGUID; // OPTIONAL\r\n const pszClassName: PAnsiChar; // OPTIONAL\r\n samDesired: REGSAM; Disposition: REGDISPOSITION;\r\n var hkClass: HKEY; ulFlags: ULONG; hMachine: HMACHINE): CONFIGRET; stdcall;\r\n TCM_Open_Class_Key_ExW = function(pszClassGuid: PGUID; // OPTIONAL\r\n const pszClassName: PWideChar; // OPTIONAL\r\n samDesired: REGSAM; Disposition: REGDISPOSITION;\r\n var hkClass: HKEY; ulFlags: ULONG; hMachine: HMACHINE): CONFIGRET; stdcall;\r\n TCM_Open_Class_Key_Ex = function(pszClassGuid: PGUID; // OPTIONAL\r\n const pszClassName: PTSTR; // OPTIONAL\r\n samDesired: REGSAM; Disposition: REGDISPOSITION;\r\n var hkClass: HKEY; ulFlags: ULONG; hMachine: HMACHINE): CONFIGRET; stdcall;\r\n\r\n TCM_Open_DevNode_Key = function(dnDevNode: DEVINST; samDesired: REGSAM;\r\n ulHardwareProfile: ULONG; Disposition: REGDISPOSITION;\r\n var hkDevice: HKEY; ulFlags: ULONG): CONFIGRET; stdcall;\r\n\r\n TCM_Open_DevInst_Key = function(dnDevNode: DEVINST; samDesired: REGSAM;\r\n ulHardwareProfile: ULONG; Disposition: REGDISPOSITION;\r\n var hkDevice: HKEY; ulFlags: ULONG): CONFIGRET; stdcall;\r\n\r\n TCM_Open_DevNode_Key_Ex = function(dnDevNode: DEVINST; samDesired: REGSAM;\r\n ulHardwareProfile: ULONG; Disposition: REGDISPOSITION; var hkDevice: HKEY;\r\n ulFlags: ULONG; hMachine: HMACHINE): CONFIGRET; stdcall;\r\n\r\n TCM_Open_DevInst_Key_Ex = function(dnDevNode: DEVINST; samDesired: REGSAM;\r\n ulHardwareProfile: ULONG; Disposition: REGDISPOSITION; var hkDevice: HKEY;\r\n ulFlags: ULONG; hMachine: HMACHINE): CONFIGRET; stdcall;\r\n\r\n TCM_Query_Arbitrator_Free_Data = function(pData: Pointer; DataLen: ULONG;\r\n dnDevInst: DEVINST; ResourceID: RESOURCEID; ulFlags: ULONG): CONFIGRET; stdcall;\r\n\r\n TCM_Query_Arbitrator_Free_Data_Ex = function(pData: Pointer; DataLen: ULONG;\r\n dnDevInst: DEVINST; ResourceID: RESOURCEID; ulFlags: ULONG;\r\n hMachine: HMACHINE): CONFIGRET; stdcall;\r\n\r\n TCM_Query_Arbitrator_Free_Size = function(var ulSize: ULONG; dnDevInst: DEVINST;\r\n ResourceID: RESOURCEID; ulFlags: ULONG): CONFIGRET; stdcall;\r\n\r\n TCM_Query_Arbitrator_Free_Size_Ex = function(var ulSize: ULONG; dnDevInst: DEVINST;\r\n ResourceID: RESOURCEID; ulFlags: ULONG; hMachine: HMACHINE): CONFIGRET; stdcall;\r\n\r\n TCM_Query_Remove_SubTree = function(dnAncestor: DEVINST;\r\n ulFlags: ULONG): CONFIGRET; stdcall;\r\n\r\n TCM_Query_Remove_SubTree_Ex = function(dnAncestor: DEVINST;\r\n ulFlags: ULONG; hMachine: HMACHINE): CONFIGRET; stdcall;\r\n\r\n {$IFDEF WIN2000_UP}\r\n\r\n TCM_Query_And_Remove_SubTreeA = function(dnAncestor: DEVINST;\r\n pVetoType: PPNP_VETO_TYPE; // OPTIONAL\r\n pszVetoName: PAnsiChar; // OPTIONAL\r\n ulNameLength: ULONG; ulFlags: ULONG): CONFIGRET; stdcall;\r\n TCM_Query_And_Remove_SubTreeW = function(dnAncestor: DEVINST;\r\n pVetoType: PPNP_VETO_TYPE; // OPTIONAL\r\n pszVetoName: PWideChar; // OPTIONAL\r\n ulNameLength: ULONG; ulFlags: ULONG): CONFIGRET; stdcall;\r\n TCM_Query_And_Remove_SubTree = function(dnAncestor: DEVINST;\r\n pVetoType: PPNP_VETO_TYPE; // OPTIONAL\r\n pszVetoName: PTSTR; // OPTIONAL\r\n ulNameLength: ULONG; ulFlags: ULONG): CONFIGRET; stdcall;\r\n\r\n TCM_Query_And_Remove_SubTree_ExA = function(dnAncestor: DEVINST;\r\n pVetoType: PPNP_VETO_TYPE; // OPTIONAL\r\n pszVetoName: PAnsiChar; // OPTIONAL\r\n ulNameLength: ULONG; ulFlags: ULONG; hMachine: HMACHINE): CONFIGRET; stdcall;\r\n TCM_Query_And_Remove_SubTree_ExW = function(dnAncestor: DEVINST;\r\n pVetoType: PPNP_VETO_TYPE; // OPTIONAL\r\n pszVetoName: PWideChar; // OPTIONAL\r\n ulNameLength: ULONG; ulFlags: ULONG; hMachine: HMACHINE): CONFIGRET; stdcall;\r\n TCM_Query_And_Remove_SubTree_Ex = function(dnAncestor: DEVINST;\r\n pVetoType: PPNP_VETO_TYPE; // OPTIONAL\r\n pszVetoName: PTSTR; // OPTIONAL\r\n ulNameLength: ULONG; ulFlags: ULONG; hMachine: HMACHINE): CONFIGRET; stdcall;\r\n\r\n TCM_Request_Device_EjectA = function(dnDevInst: DEVINST;\r\n pVetoType: PPNP_VETO_TYPE; // OPTIONAL\r\n pszVetoName: PAnsiChar; // OPTIONAL\r\n ulNameLength: ULONG; ulFlags: ULONG): CONFIGRET; stdcall;\r\n TCM_Request_Device_EjectW = function(dnDevInst: DEVINST;\r\n pVetoType: PPNP_VETO_TYPE; // OPTIONAL\r\n pszVetoName: PWideChar; // OPTIONAL\r\n ulNameLength: ULONG; ulFlags: ULONG): CONFIGRET; stdcall;\r\n TCM_Request_Device_Eject = function(dnDevInst: DEVINST;\r\n pVetoType: PPNP_VETO_TYPE; // OPTIONAL\r\n pszVetoName: PTSTR; // OPTIONAL\r\n ulNameLength: ULONG; ulFlags: ULONG): CONFIGRET; stdcall;\r\n\r\n TCM_Request_Device_Eject_ExA = function(dnDevInst: DEVINST;\r\n pVetoType: PPNP_VETO_TYPE; // OPTIONAL\r\n pszVetoName: PAnsiChar; // OPTIONAL\r\n ulNameLength: ULONG; ulFlags: ULONG; hMachine: HMACHINE): CONFIGRET; stdcall;\r\n TCM_Request_Device_Eject_ExW = function(dnDevInst: DEVINST;\r\n pVetoType: PPNP_VETO_TYPE; // OPTIONAL\r\n pszVetoName: PWideChar; // OPTIONAL\r\n ulNameLength: ULONG; ulFlags: ULONG; hMachine: HMACHINE): CONFIGRET; stdcall;\r\n TCM_Request_Device_Eject_Ex = function(dnDevInst: DEVINST;\r\n pVetoType: PPNP_VETO_TYPE; // OPTIONAL\r\n pszVetoName: PTSTR; // OPTIONAL\r\n ulNameLength: ULONG; ulFlags: ULONG; hMachine: HMACHINE): CONFIGRET; stdcall;\r\n\r\n {$ENDIF WIN2000_UP}\r\n\r\n TCM_Reenumerate_DevNode = function(dnDevInst: DEVINST;\r\n ulFlags: ULONG): CONFIGRET; stdcall;\r\n\r\n TCM_Reenumerate_DevInst = function(dnDevInst: DEVINST;\r\n ulFlags: ULONG): CONFIGRET; stdcall;\r\n\r\n TCM_Reenumerate_DevNode_Ex = function(dnDevInst: DEVINST;\r\n ulFlags: ULONG; hMachine: HMACHINE): CONFIGRET; stdcall;\r\n\r\n TCM_Reenumerate_DevInst_Ex = function(dnDevInst: DEVINST;\r\n ulFlags: ULONG; hMachine: HMACHINE): CONFIGRET; stdcall;\r\n\r\n {$IFNDEF WINNT4}\r\n\r\n TCM_Register_Device_InterfaceA = function(dnDevInst: DEVINST;\r\n InterfaceClassGuid: PGUID;\r\n const pszReference: PAnsiChar; // OPTIONAL\r\n pszDeviceInterface: PAnsiChar; var ulLength: ULONG;\r\n ulFlags: ULONG): CONFIGRET; stdcall;\r\n TCM_Register_Device_InterfaceW = function(dnDevInst: DEVINST;\r\n InterfaceClassGuid: PGUID;\r\n const pszReference: PWideChar; // OPTIONAL\r\n pszDeviceInterface: PWideChar; var ulLength: ULONG;\r\n ulFlags: ULONG): CONFIGRET; stdcall;\r\n TCM_Register_Device_Interface = function(dnDevInst: DEVINST;\r\n InterfaceClassGuid: PGUID;\r\n const pszReference: PTSTR; // OPTIONAL\r\n pszDeviceInterface: PTSTR; var ulLength: ULONG;\r\n ulFlags: ULONG): CONFIGRET; stdcall;\r\n\r\n TCM_Register_Device_Interface_ExA = function(dnDevInst: DEVINST;\r\n InterfaceClassGuid: PGUID;\r\n const pszReference: PAnsiChar; // OPTIONAL\r\n pszDeviceInterface: PAnsiChar; var ulLength: ULONG;\r\n ulFlags: ULONG; hMachine: HMACHINE): CONFIGRET; stdcall;\r\n TCM_Register_Device_Interface_ExW = function(dnDevInst: DEVINST;\r\n InterfaceClassGuid: PGUID;\r\n const pszReference: PWideChar; // OPTIONAL\r\n pszDeviceInterface: PWideChar; var ulLength: ULONG;\r\n ulFlags: ULONG; hMachine: HMACHINE): CONFIGRET; stdcall;\r\n TCM_Register_Device_Interface_Ex = function(dnDevInst: DEVINST;\r\n InterfaceClassGuid: PGUID;\r\n const pszReference: PTSTR; // OPTIONAL\r\n pszDeviceInterface: PTSTR; var ulLength: ULONG;\r\n ulFlags: ULONG; hMachine: HMACHINE): CONFIGRET; stdcall;\r\n\r\n TCM_Set_DevNode_Problem_Ex = function(dnDevInst: DEVINST;\r\n ulProblem: ULONG; ulFlags: ULONG; hMachine: HMACHINE): CONFIGRET; stdcall;\r\n\r\n TCM_Set_DevInst_Problem_Ex = function(dnDevInst: DEVINST;\r\n ulProblem: ULONG; ulFlags: ULONG; hMachine: HMACHINE): CONFIGRET; stdcall;\r\n\r\n TCM_Set_DevNode_Problem = function(dnDevInst: DEVINST; ulProblem: ULONG;\r\n ulFlags: ULONG): CONFIGRET; stdcall;\r\n\r\n TCM_Set_DevInst_Problem = function(dnDevInst: DEVINST; ulProblem: ULONG;\r\n ulFlags: ULONG): CONFIGRET; stdcall;\r\n\r\n TCM_Unregister_Device_InterfaceA = function(const pszDeviceInterface: PAnsiChar;\r\n ulFlags: ULONG): CONFIGRET; stdcall;\r\n TCM_Unregister_Device_InterfaceW = function(const pszDeviceInterface: PWideChar;\r\n ulFlags: ULONG): CONFIGRET; stdcall;\r\n TCM_Unregister_Device_Interface = function(const pszDeviceInterface: PTSTR;\r\n ulFlags: ULONG): CONFIGRET; stdcall;\r\n\r\n TCM_Unregister_Device_Interface_ExA = function(const pszDeviceInterface: PAnsiChar;\r\n ulFlags: ULONG; hMachine: HMACHINE): CONFIGRET; stdcall;\r\n TCM_Unregister_Device_Interface_ExW = function(const pszDeviceInterface: PWideChar;\r\n ulFlags: ULONG; hMachine: HMACHINE): CONFIGRET; stdcall;\r\n TCM_Unregister_Device_Interface_Ex = function(const pszDeviceInterface: PTSTR;\r\n ulFlags: ULONG; hMachine: HMACHINE): CONFIGRET; stdcall;\r\n\r\n TCM_Register_Device_Driver = function(dnDevInst: DEVINST;\r\n ulFlags: ULONG): CONFIGRET; stdcall;\r\n\r\n TCM_Register_Device_Driver_Ex = function(dnDevInst: DEVINST;\r\n ulFlags: ULONG; hMachine: HMACHINE): CONFIGRET; stdcall;\r\n\r\n {$ENDIF !WINNT4}\r\n\r\n TCM_Remove_SubTree = function(dnAncestor: DEVINST; ulFlags: ULONG): CONFIGRET; stdcall;\r\n\r\n TCM_Remove_SubTree_Ex = function(dnAncestor: DEVINST; ulFlags: ULONG;\r\n hMachine: HMACHINE): CONFIGRET; stdcall;\r\n\r\n TCM_Set_DevNode_Registry_PropertyA = function(dnDevInst: DEVINST;\r\n ulProperty: ULONG; Buffer: Pointer; // OPTIONAL\r\n ulLength: ULONG; ulFlags: ULONG): CONFIGRET; stdcall;\r\n TCM_Set_DevNode_Registry_PropertyW = function(dnDevInst: DEVINST;\r\n ulProperty: ULONG; Buffer: Pointer; // OPTIONAL\r\n ulLength: ULONG; ulFlags: ULONG): CONFIGRET; stdcall;\r\n TCM_Set_DevNode_Registry_Property = function(dnDevInst: DEVINST;\r\n ulProperty: ULONG; Buffer: Pointer; // OPTIONAL\r\n ulLength: ULONG; ulFlags: ULONG): CONFIGRET; stdcall;\r\n\r\n TCM_Set_DevNode_Registry_Property_ExA = function(dnDevInst: DEVINST;\r\n ulProperty: ULONG; Buffer: Pointer; // OPTIONAL\r\n ulLength: ULONG; ulFlags: ULONG; hMachine: HMACHINE): CONFIGRET; stdcall;\r\n TCM_Set_DevNode_Registry_Property_ExW = function(dnDevInst: DEVINST;\r\n ulProperty: ULONG; Buffer: Pointer; // OPTIONAL\r\n ulLength: ULONG; ulFlags: ULONG; hMachine: HMACHINE): CONFIGRET; stdcall;\r\n TCM_Set_DevNode_Registry_Property_Ex = function(dnDevInst: DEVINST;\r\n ulProperty: ULONG; Buffer: Pointer; // OPTIONAL\r\n ulLength: ULONG; ulFlags: ULONG; hMachine: HMACHINE): CONFIGRET; stdcall;\r\n\r\n TCM_Set_DevInst_Registry_PropertyA = function(dnDevInst: DEVINST;\r\n ulProperty: ULONG; Buffer: Pointer; // OPTIONAL\r\n ulLength: ULONG; ulFlags: ULONG): CONFIGRET; stdcall;\r\n TCM_Set_DevInst_Registry_PropertyW = function(dnDevInst: DEVINST;\r\n ulProperty: ULONG; Buffer: Pointer; // OPTIONAL\r\n ulLength: ULONG; ulFlags: ULONG): CONFIGRET; stdcall;\r\n TCM_Set_DevInst_Registry_Property = function(dnDevInst: DEVINST;\r\n ulProperty: ULONG; Buffer: Pointer; // OPTIONAL\r\n ulLength: ULONG; ulFlags: ULONG): CONFIGRET; stdcall;\r\n\r\n TCM_Set_DevInst_Registry_Property_ExA = function(dnDevInst: DEVINST;\r\n ulProperty: ULONG; Buffer: Pointer; // OPTIONAL\r\n ulLength: ULONG; ulFlags: ULONG; hMachine: HMACHINE): CONFIGRET; stdcall;\r\n TCM_Set_DevInst_Registry_Property_ExW = function(dnDevInst: DEVINST;\r\n ulProperty: ULONG; Buffer: Pointer; // OPTIONAL\r\n ulLength: ULONG; ulFlags: ULONG; hMachine: HMACHINE): CONFIGRET; stdcall;\r\n TCM_Set_DevInst_Registry_Property_Ex = function(dnDevInst: DEVINST;\r\n ulProperty: ULONG; Buffer: Pointer; // OPTIONAL\r\n ulLength: ULONG; ulFlags: ULONG; hMachine: HMACHINE): CONFIGRET; stdcall;\r\n\r\n {$IFNDEF WINNT4}\r\n TCM_Is_Dock_Station_Present = function(var bPresent: BOOL): CONFIGRET; stdcall;\r\n {$ENDIF !WINNT4}\r\n\r\n {$IFDEF WIN2000_UP}\r\n TCM_Is_Dock_Station_Present_Ex = function(var bPresent: BOOL;\r\n hMachine: HMACHINE): CONFIGRET; stdcall;\r\n {$ENDIF WIN2000_UP}\r\n\r\n {$IFNDEF WINNT4}\r\n TCM_Request_Eject_PC = function: CONFIGRET; stdcall;\r\n {$ENDIF !WINNT4}\r\n\r\n {$IFDEF WIN2000_UP}\r\n TCM_Request_Eject_PC_Ex = function(hMachine: HMACHINE): CONFIGRET; stdcall;\r\n {$ENDIF WIN2000_UP}\r\n\r\n TCM_Set_HW_Prof_FlagsA = function(szDevInstName: DEVINSTID_A;\r\n ulConfig: ULONG; ulValue: ULONG; ulFlags: ULONG): CONFIGRET; stdcall;\r\n TCM_Set_HW_Prof_FlagsW = function(szDevInstName: DEVINSTID_W;\r\n ulConfig: ULONG; ulValue: ULONG; ulFlags: ULONG): CONFIGRET; stdcall;\r\n TCM_Set_HW_Prof_Flags = function(szDevInstName: DEVINSTID;\r\n ulConfig: ULONG; ulValue: ULONG; ulFlags: ULONG): CONFIGRET; stdcall;\r\n\r\n TCM_Set_HW_Prof_Flags_ExA = function(szDevInstName: DEVINSTID_A;\r\n ulConfig: ULONG; ulValue: ULONG; ulFlags: ULONG;\r\n hMachine: HMACHINE): CONFIGRET; stdcall;\r\n TCM_Set_HW_Prof_Flags_ExW = function(szDevInstName: DEVINSTID_W;\r\n ulConfig: ULONG; ulValue: ULONG; ulFlags: ULONG;\r\n hMachine: HMACHINE): CONFIGRET; stdcall;\r\n TCM_Set_HW_Prof_Flags_Ex = function(szDevInstName: DEVINSTID;\r\n ulConfig: ULONG; ulValue: ULONG; ulFlags: ULONG;\r\n hMachine: HMACHINE): CONFIGRET; stdcall;\r\n\r\n TCM_Setup_DevNode = function(dnDevInst: DEVINST; ulFlags: ULONG): CONFIGRET; stdcall;\r\n\r\n TCM_Setup_DevInst = function(dnDevInst: DEVINST; ulFlags: ULONG): CONFIGRET; stdcall;\r\n\r\n TCM_Setup_DevNode_Ex = function(dnDevInst: DEVINST; ulFlags: ULONG;\r\n hMachine: HMACHINE): CONFIGRET; stdcall;\r\n\r\n TCM_Setup_DevInst_Ex = function(dnDevInst: DEVINST; ulFlags: ULONG;\r\n hMachine: HMACHINE): CONFIGRET; stdcall;\r\n\r\n TCM_Test_Range_Available = function(ullStartValue: DWORDLONG; ullEndValue: DWORDLONG;\r\n rlh: RANGE_LIST; ulFlags: ULONG): CONFIGRET; stdcall;\r\n\r\n TCM_Uninstall_DevNode = function(dnPhantom: DEVNODE; ulFlags: ULONG): CONFIGRET; stdcall;\r\n\r\n TCM_Uninstall_DevInst = function(dnPhantom: DEVINST; ulFlags: ULONG): CONFIGRET; stdcall;\r\n\r\n TCM_Uninstall_DevNode_Ex = function(dnPhantom: DEVNODE; ulFlags: ULONG;\r\n hMachine: HMACHINE): CONFIGRET; stdcall;\r\n\r\n TCM_Uninstall_DevInst_Ex = function(dnPhantom: DEVINST; ulFlags: ULONG;\r\n hMachine: HMACHINE): CONFIGRET; stdcall;\r\n\r\n TCM_Run_Detection = function(ulFlags: ULONG): CONFIGRET; stdcall;\r\n\r\n TCM_Run_Detection_Ex = function(ulFlags: ULONG; hMachine: HMACHINE): CONFIGRET; stdcall;\r\n\r\n TCM_Set_HW_Prof = function(ulHardwareProfile: ULONG; ulFlags: ULONG): CONFIGRET; stdcall;\r\n\r\n TCM_Set_HW_Prof_Ex = function(ulHardwareProfile: ULONG; ulFlags: ULONG;\r\n hMachine: HMACHINE): CONFIGRET; stdcall;\r\n\r\n {$IFDEF WIN2000_UP}\r\n\r\n TCM_Query_Resource_Conflict_List = function(var clConflictList: CONFLICT_LIST;\r\n dnDevInst: DEVINST; ResourceID: RESOURCEID; ResourceData: Pointer;\r\n ResourceLen: ULONG; ulFlags: ULONG; hMachine: HMACHINE): CONFIGRET; stdcall;\r\n\r\n TCM_Free_Resource_Conflict_Handle = function(clConflictList: CONFLICT_LIST): CONFIGRET; stdcall;\r\n\r\n TCM_Get_Resource_Conflict_Count = function(clConflictList: CONFLICT_LIST;\r\n var ulCount: ULONG): CONFIGRET; stdcall;\r\n\r\n TCM_Get_Resource_Conflict_DetailsA = function(clConflictList: CONFLICT_LIST;\r\n ulIndex: ULONG; var ConflictDetails: CONFLICT_DETAILS_A): CONFIGRET; stdcall;\r\n TCM_Get_Resource_Conflict_DetailsW = function(clConflictList: CONFLICT_LIST;\r\n ulIndex: ULONG; var ConflictDetails: CONFLICT_DETAILS_W): CONFIGRET; stdcall;\r\n TCM_Get_Resource_Conflict_Details = function(clConflictList: CONFLICT_LIST;\r\n ulIndex: ULONG; var ConflictDetails: CONFLICT_DETAILS): CONFIGRET; stdcall;\r\n\r\n TCM_Get_Class_Registry_PropertyA = function(ClassGUID: PGUID; ulProperty: ULONG;\r\n pulRegDataType: PULONG; // OPTIONAL\r\n Buffer: Pointer; // OPTIONAL\r\n var ulLength: ULONG; ulFlags: ULONG; hMachine: HMACHINE): CONFIGRET; stdcall;\r\n TCM_Get_Class_Registry_PropertyW = function(ClassGUID: PGUID; ulProperty: ULONG;\r\n pulRegDataType: PULONG; // OPTIONAL\r\n Buffer: Pointer; // OPTIONAL\r\n var ulLength: ULONG; ulFlags: ULONG; hMachine: HMACHINE): CONFIGRET; stdcall;\r\n TCM_Get_Class_Registry_Property = function(ClassGUID: PGUID; ulProperty: ULONG;\r\n pulRegDataType: PULONG; // OPTIONAL\r\n Buffer: Pointer; // OPTIONAL\r\n var ulLength: ULONG; ulFlags: ULONG; hMachine: HMACHINE): CONFIGRET; stdcall;\r\n\r\n TCM_Set_Class_Registry_PropertyA = function(ClassGUID: PGUID; ulProperty: ULONG;\r\n Buffer: Pointer; // OPTIONAL\r\n ulLength: ULONG; ulFlags: ULONG; hMachine: HMACHINE): CONFIGRET; stdcall;\r\n TCM_Set_Class_Registry_PropertyW = function(ClassGUID: PGUID; ulProperty: ULONG;\r\n Buffer: Pointer; // OPTIONAL\r\n ulLength: ULONG; ulFlags: ULONG; hMachine: HMACHINE): CONFIGRET; stdcall;\r\n TCM_Set_Class_Registry_Property = function(ClassGUID: PGUID; ulProperty: ULONG;\r\n Buffer: Pointer; // OPTIONAL\r\n ulLength: ULONG; ulFlags: ULONG; hMachine: HMACHINE): CONFIGRET; stdcall;\r\n\r\n TCM_WaitNoPendingInstallEvents = function(dwTimeout: DWORD): DWORD; stdcall;\r\n TCMP_WaitNoPendingInstallEvents = function(dwTimeout: DWORD): DWORD; stdcall;\r\n\r\n {$ENDIF WIN2000_UP}\r\n\r\nvar\r\n CM_Add_Empty_Log_Conf: TCM_Add_Empty_Log_Conf;\r\n CM_Add_Empty_Log_Conf_Ex: TCM_Add_Empty_Log_Conf_Ex;\r\n CM_Add_IDA: TCM_Add_IDA;\r\n CM_Add_IDW: TCM_Add_IDW;\r\n CM_Add_ID: TCM_Add_ID;\r\n CM_Add_ID_ExA: TCM_Add_ID_ExA;\r\n CM_Add_ID_ExW: TCM_Add_ID_ExW;\r\n CM_Add_ID_Ex: TCM_Add_ID_Ex;\r\n CM_Add_Range: TCM_Add_Range;\r\n CM_Add_Res_Des: TCM_Add_Res_Des;\r\n CM_Add_Res_Des_Ex: TCM_Add_Res_Des_Ex;\r\n CM_Connect_MachineA: TCM_Connect_MachineA;\r\n CM_Connect_MachineW: TCM_Connect_MachineW;\r\n CM_Connect_Machine: TCM_Connect_Machine;\r\n CM_Create_DevNodeA: TCM_Create_DevNodeA;\r\n CM_Create_DevNodeW: TCM_Create_DevNodeW;\r\n CM_Create_DevNode: TCM_Create_DevNode;\r\n CM_Create_DevNode_ExA: TCM_Create_DevNode_ExA;\r\n CM_Create_DevNode_ExW: TCM_Create_DevNode_ExW;\r\n CM_Create_DevNode_Ex: TCM_Create_DevNode_Ex;\r\n CM_Create_DevInstA: TCM_Create_DevInstA;\r\n CM_Create_DevInstW: TCM_Create_DevInstW;\r\n CM_Create_DevInst: TCM_Create_DevInst;\r\n CM_Create_DevInst_ExA: TCM_Create_DevInst_ExA;\r\n CM_Create_DevInst_ExW: TCM_Create_DevInst_ExW;\r\n CM_Create_DevInst_Ex: TCM_Create_DevInst_Ex;\r\n CM_Create_Range_List: TCM_Create_Range_List;\r\n CM_Delete_Class_Key: TCM_Delete_Class_Key;\r\n CM_Delete_Class_Key_Ex: TCM_Delete_Class_Key_Ex;\r\n CM_Delete_DevNode_Key: TCM_Delete_DevNode_Key;\r\n CM_Delete_DevNode_Key_Ex: TCM_Delete_DevNode_Key_Ex;\r\n CM_Delete_DevInst_Key: TCM_Delete_DevInst_Key;\r\n CM_Delete_DevInst_Key_Ex: TCM_Delete_DevInst_Key_Ex;\r\n CM_Delete_Range: TCM_Delete_Range;\r\n CM_Detect_Resource_Conflict: TCM_Detect_Resource_Conflict;\r\n CM_Detect_Resource_Conflict_Ex: TCM_Detect_Resource_Conflict_Ex;\r\n CM_Disable_DevNode: TCM_Disable_DevNode;\r\n CM_Disable_DevNode_Ex: TCM_Disable_DevNode_Ex;\r\n CM_Disable_DevInst: TCM_Disable_DevInst;\r\n CM_Disable_DevInst_Ex: TCM_Disable_DevInst_Ex;\r\n CM_Disconnect_Machine: TCM_Disconnect_Machine;\r\n CM_Dup_Range_List: TCM_Dup_Range_List;\r\n CM_Enable_DevNode: TCM_Enable_DevNode;\r\n CM_Enable_DevNode_Ex: TCM_Enable_DevNode_Ex;\r\n CM_Enable_DevInst: TCM_Enable_DevInst;\r\n CM_Enable_DevInst_Ex: TCM_Enable_DevInst_Ex;\r\n CM_Enumerate_Classes: TCM_Enumerate_Classes;\r\n CM_Enumerate_Classes_Ex: TCM_Enumerate_Classes_Ex;\r\n CM_Enumerate_EnumeratorsA: TCM_Enumerate_EnumeratorsA;\r\n CM_Enumerate_EnumeratorsW: TCM_Enumerate_EnumeratorsW;\r\n CM_Enumerate_Enumerators: TCM_Enumerate_Enumerators;\r\n CM_Enumerate_Enumerators_ExA: TCM_Enumerate_Enumerators_ExA;\r\n CM_Enumerate_Enumerators_ExW: TCM_Enumerate_Enumerators_ExW;\r\n CM_Enumerate_Enumerators_Ex: TCM_Enumerate_Enumerators_Ex;\r\n CM_Find_Range: TCM_Find_Range;\r\n CM_First_Range: TCM_First_Range;\r\n CM_Free_Log_Conf: TCM_Free_Log_Conf;\r\n CM_Free_Log_Conf_Ex: TCM_Free_Log_Conf_Ex;\r\n CM_Free_Log_Conf_Handle: TCM_Free_Log_Conf_Handle;\r\n CM_Free_Range_List: TCM_Free_Range_List;\r\n CM_Free_Res_Des: TCM_Free_Res_Des;\r\n CM_Free_Res_Des_Ex: TCM_Free_Res_Des_Ex;\r\n CM_Free_Res_Des_Handle: TCM_Free_Res_Des_Handle;\r\n CM_Get_Child: TCM_Get_Child;\r\n CM_Get_Child_Ex: TCM_Get_Child_Ex;\r\n CM_Get_Class_NameA: TCM_Get_Class_NameA;\r\n CM_Get_Class_NameW: TCM_Get_Class_NameW;\r\n CM_Get_Class_Name: TCM_Get_Class_Name;\r\n CM_Get_Class_Name_ExA: TCM_Get_Class_Name_ExA;\r\n CM_Get_Class_Name_ExW: TCM_Get_Class_Name_ExW;\r\n CM_Get_Class_Name_Ex: TCM_Get_Class_Name_Ex;\r\n CM_Get_Class_Key_NameA: TCM_Get_Class_Key_NameA;\r\n CM_Get_Class_Key_NameW: TCM_Get_Class_Key_NameW;\r\n CM_Get_Class_Key_Name: TCM_Get_Class_Key_Name;\r\n CM_Get_Class_Key_Name_ExA: TCM_Get_Class_Key_Name_ExA;\r\n CM_Get_Class_Key_Name_ExW: TCM_Get_Class_Key_Name_ExW;\r\n CM_Get_Class_Key_Name_Ex: TCM_Get_Class_Key_Name_Ex;\r\n CM_Get_Depth: TCM_Get_Depth;\r\n CM_Get_Depth_Ex: TCM_Get_Depth_Ex;\r\n CM_Get_Device_IDA: TCM_Get_Device_IDA;\r\n CM_Get_Device_IDW: TCM_Get_Device_IDW;\r\n CM_Get_Device_ID: TCM_Get_Device_ID;\r\n CM_Get_Device_ID_ExA: TCM_Get_Device_ID_ExA;\r\n CM_Get_Device_ID_ExW: TCM_Get_Device_ID_ExW;\r\n CM_Get_Device_ID_Ex: TCM_Get_Device_ID_Ex;\r\n CM_Get_Device_ID_ListA: TCM_Get_Device_ID_ListA;\r\n CM_Get_Device_ID_ListW: TCM_Get_Device_ID_ListW;\r\n CM_Get_Device_ID_List: TCM_Get_Device_ID_List;\r\n CM_Get_Device_ID_List_ExA: TCM_Get_Device_ID_List_ExA;\r\n CM_Get_Device_ID_List_ExW: TCM_Get_Device_ID_List_ExW;\r\n CM_Get_Device_ID_List_Ex: TCM_Get_Device_ID_List_Ex;\r\n CM_Get_Device_ID_List_SizeA: TCM_Get_Device_ID_List_SizeA;\r\n CM_Get_Device_ID_List_SizeW: TCM_Get_Device_ID_List_SizeW;\r\n CM_Get_Device_ID_List_Size: TCM_Get_Device_ID_List_Size;\r\n CM_Get_Device_ID_List_Size_ExA: TCM_Get_Device_ID_List_Size_ExA;\r\n CM_Get_Device_ID_List_Size_ExW: TCM_Get_Device_ID_List_Size_ExW;\r\n CM_Get_Device_ID_List_Size_Ex: TCM_Get_Device_ID_List_Size_Ex;\r\n CM_Get_Device_ID_Size: TCM_Get_Device_ID_Size;\r\n CM_Get_Device_ID_Size_Ex: TCM_Get_Device_ID_Size_Ex;\r\n CM_Get_DevNode_Registry_PropertyA: TCM_Get_DevNode_Registry_PropertyA;\r\n CM_Get_DevNode_Registry_PropertyW: TCM_Get_DevNode_Registry_PropertyW;\r\n CM_Get_DevNode_Registry_Property: TCM_Get_DevNode_Registry_Property;\r\n CM_Get_DevNode_Registry_Property_ExA: TCM_Get_DevNode_Registry_Property_ExA;\r\n CM_Get_DevNode_Registry_Property_ExW: TCM_Get_DevNode_Registry_Property_ExW;\r\n CM_Get_DevNode_Registry_Property_Ex: TCM_Get_DevNode_Registry_Property_Ex;\r\n CM_Get_DevInst_Registry_PropertyA: TCM_Get_DevInst_Registry_PropertyA;\r\n CM_Get_DevInst_Registry_PropertyW: TCM_Get_DevInst_Registry_PropertyW;\r\n CM_Get_DevInst_Registry_Property: TCM_Get_DevInst_Registry_Property;\r\n CM_Get_DevInst_Registry_Property_ExA: TCM_Get_DevInst_Registry_Property_ExA;\r\n CM_Get_DevInst_Registry_Property_ExW: TCM_Get_DevInst_Registry_Property_ExW;\r\n CM_Get_DevInst_Registry_Property_Ex: TCM_Get_DevInst_Registry_Property_Ex;\r\n {$IFDEF WINXP_UP}\r\n CM_Get_DevNode_Custom_PropertyA: TCM_Get_DevNode_Custom_PropertyA;\r\n CM_Get_DevNode_Custom_PropertyW: TCM_Get_DevNode_Custom_PropertyW;\r\n CM_Get_DevNode_Custom_Property: TCM_Get_DevNode_Custom_Property;\r\n CM_Get_DevNode_Custom_Property_ExA: TCM_Get_DevNode_Custom_Property_ExA;\r\n CM_Get_DevNode_Custom_Property_ExW: TCM_Get_DevNode_Custom_Property_ExW;\r\n CM_Get_DevNode_Custom_Property_Ex: TCM_Get_DevNode_Custom_Property_Ex;\r\n CM_Get_DevInst_Custom_PropertyA: TCM_Get_DevInst_Custom_PropertyA;\r\n CM_Get_DevInst_Custom_PropertyW: TCM_Get_DevInst_Custom_PropertyW;\r\n CM_Get_DevInst_Custom_Property: TCM_Get_DevInst_Custom_Property;\r\n CM_Get_DevInst_Custom_Property_ExA: TCM_Get_DevInst_Custom_Property_ExA;\r\n CM_Get_DevInst_Custom_Property_ExW: TCM_Get_DevInst_Custom_Property_ExW;\r\n CM_Get_DevInst_Custom_Property_Ex: TCM_Get_DevInst_Custom_Property_Ex;\r\n {$ENDIF WINXP_UP}\r\n CM_Get_DevNode_Status: TCM_Get_DevNode_Status;\r\n CM_Get_DevInst_Status: TCM_Get_DevInst_Status;\r\n CM_Get_DevNode_Status_Ex: TCM_Get_DevNode_Status_Ex;\r\n CM_Get_DevInst_Status_Ex: TCM_Get_DevInst_Status_Ex;\r\n CM_Get_First_Log_Conf: TCM_Get_First_Log_Conf;\r\n CM_Get_First_Log_Conf_Ex: TCM_Get_First_Log_Conf_Ex;\r\n CM_Get_Global_State: TCM_Get_Global_State;\r\n CM_Get_Global_State_Ex: TCM_Get_Global_State_Ex;\r\n CM_Get_Hardware_Profile_InfoA: TCM_Get_Hardware_Profile_InfoA;\r\n CM_Get_Hardware_Profile_InfoW: TCM_Get_Hardware_Profile_InfoW;\r\n CM_Get_Hardware_Profile_Info: TCM_Get_Hardware_Profile_Info;\r\n CM_Get_Hardware_Profile_Info_ExA: TCM_Get_Hardware_Profile_Info_ExA;\r\n CM_Get_Hardware_Profile_Info_ExW: TCM_Get_Hardware_Profile_Info_ExW;\r\n CM_Get_Hardware_Profile_Info_Ex: TCM_Get_Hardware_Profile_Info_Ex;\r\n CM_Get_HW_Prof_FlagsA: TCM_Get_HW_Prof_FlagsA;\r\n CM_Get_HW_Prof_FlagsW: TCM_Get_HW_Prof_FlagsW;\r\n CM_Get_HW_Prof_Flags: TCM_Get_HW_Prof_Flags;\r\n CM_Get_HW_Prof_Flags_ExA: TCM_Get_HW_Prof_Flags_ExA;\r\n CM_Get_HW_Prof_Flags_ExW: TCM_Get_HW_Prof_Flags_ExW;\r\n CM_Get_HW_Prof_Flags_Ex: TCM_Get_HW_Prof_Flags_Ex;\r\n {$IFNDEF WINNT4}\r\n CM_Get_Device_Interface_AliasA: TCM_Get_Device_Interface_AliasA;\r\n CM_Get_Device_Interface_AliasW: TCM_Get_Device_Interface_AliasW;\r\n CM_Get_Device_Interface_Alias: TCM_Get_Device_Interface_Alias;\r\n CM_Get_Device_Interface_Alias_ExA: TCM_Get_Device_Interface_Alias_ExA;\r\n CM_Get_Device_Interface_Alias_ExW: TCM_Get_Device_Interface_Alias_ExW;\r\n CM_Get_Device_Interface_Alias_Ex: TCM_Get_Device_Interface_Alias_Ex;\r\n CM_Get_Device_Interface_ListA: TCM_Get_Device_Interface_ListA;\r\n CM_Get_Device_Interface_ListW: TCM_Get_Device_Interface_ListW;\r\n CM_Get_Device_Interface_List: TCM_Get_Device_Interface_List;\r\n CM_Get_Device_Interface_List_ExA: TCM_Get_Device_Interface_List_ExA;\r\n CM_Get_Device_Interface_List_ExW: TCM_Get_Device_Interface_List_ExW;\r\n CM_Get_Device_Interface_List_Ex: TCM_Get_Device_Interface_List_Ex;\r\n CM_Get_Device_Interface_List_SizeA: TCM_Get_Device_Interface_List_SizeA;\r\n CM_Get_Device_Interface_List_SizeW: TCM_Get_Device_Interface_List_SizeW;\r\n CM_Get_Device_Interface_List_Size: TCM_Get_Device_Interface_List_Size;\r\n CM_Get_Device_Interface_List_Size_ExA: TCM_Get_Device_Interface_List_Size_ExA;\r\n CM_Get_Device_Interface_List_Size_ExW: TCM_Get_Device_Interface_List_Size_ExW;\r\n CM_Get_Device_Interface_List_Size_Ex: TCM_Get_Device_Interface_List_Size_Ex;\r\n CM_Get_Log_Conf_Priority: TCM_Get_Log_Conf_Priority;\r\n CM_Get_Log_Conf_Priority_Ex: TCM_Get_Log_Conf_Priority_Ex;\r\n {$ENDIF !WINNT4}\r\n CM_Get_Next_Log_Conf: TCM_Get_Next_Log_Conf;\r\n CM_Get_Next_Log_Conf_Ex: TCM_Get_Next_Log_Conf_Ex;\r\n CM_Get_Parent: TCM_Get_Parent;\r\n CM_Get_Parent_Ex: TCM_Get_Parent_Ex;\r\n CM_Get_Res_Des_Data: TCM_Get_Res_Des_Data;\r\n CM_Get_Res_Des_Data_Ex: TCM_Get_Res_Des_Data_Ex;\r\n CM_Get_Res_Des_Data_Size: TCM_Get_Res_Des_Data_Size;\r\n CM_Get_Res_Des_Data_Size_Ex: TCM_Get_Res_Des_Data_Size_Ex;\r\n CM_Get_Sibling: TCM_Get_Sibling;\r\n CM_Get_Sibling_Ex: TCM_Get_Sibling_Ex;\r\n CM_Get_Version: TCM_Get_Version;\r\n CM_Get_Version_Ex: TCM_Get_Version_Ex;\r\n {$IFDEF WINXP_UP}\r\n CM_Is_Version_Available: TCM_Is_Version_Available;\r\n CM_Is_Version_Available_Ex: TCM_Is_Version_Available_Ex;\r\n {$ENDIF WINXP_UP}\r\n CM_Intersect_Range_List: TCM_Intersect_Range_List;\r\n CM_Invert_Range_List: TCM_Invert_Range_List;\r\n CM_Locate_DevNodeA: TCM_Locate_DevNodeA;\r\n CM_Locate_DevNodeW: TCM_Locate_DevNodeW;\r\n CM_Locate_DevNode: TCM_Locate_DevNode;\r\n CM_Locate_DevNode_ExA: TCM_Locate_DevNode_ExA;\r\n CM_Locate_DevNode_ExW: TCM_Locate_DevNode_ExW;\r\n CM_Locate_DevNode_Ex: TCM_Locate_DevNode_Ex;\r\n CM_Locate_DevInstA: TCM_Locate_DevInstA;\r\n CM_Locate_DevInstW: TCM_Locate_DevInstW;\r\n CM_Locate_DevInst: TCM_Locate_DevInst;\r\n CM_Locate_DevInst_ExA: TCM_Locate_DevInst_ExA;\r\n CM_Locate_DevInst_ExW: TCM_Locate_DevInst_ExW;\r\n CM_Locate_DevInst_Ex: TCM_Locate_DevInst_Ex;\r\n CM_Merge_Range_List: TCM_Merge_Range_List;\r\n CM_Modify_Res_Des: TCM_Modify_Res_Des;\r\n CM_Modify_Res_Des_Ex: TCM_Modify_Res_Des_Ex;\r\n CM_Move_DevNode: TCM_Move_DevNode;\r\n CM_Move_DevInst: TCM_Move_DevInst;\r\n CM_Move_DevNode_Ex: TCM_Move_DevNode_Ex;\r\n CM_Move_DevInst_Ex: TCM_Move_DevInst_Ex;\r\n CM_Next_Range: TCM_Next_Range;\r\n CM_Get_Next_Res_Des: TCM_Get_Next_Res_Des;\r\n CM_Get_Next_Res_Des_Ex: TCM_Get_Next_Res_Des_Ex;\r\n CM_Open_Class_KeyA: TCM_Open_Class_KeyA;\r\n CM_Open_Class_KeyW: TCM_Open_Class_KeyW;\r\n CM_Open_Class_Key: TCM_Open_Class_Key;\r\n CM_Open_Class_Key_ExA: TCM_Open_Class_Key_ExA;\r\n CM_Open_Class_Key_ExW: TCM_Open_Class_Key_ExW;\r\n CM_Open_Class_Key_Ex: TCM_Open_Class_Key_Ex;\r\n CM_Open_DevNode_Key: TCM_Open_DevNode_Key;\r\n CM_Open_DevInst_Key: TCM_Open_DevInst_Key;\r\n CM_Open_DevNode_Key_Ex: TCM_Open_DevNode_Key_Ex;\r\n CM_Open_DevInst_Key_Ex: TCM_Open_DevInst_Key_Ex;\r\n CM_Query_Arbitrator_Free_Data: TCM_Query_Arbitrator_Free_Data;\r\n CM_Query_Arbitrator_Free_Data_Ex: TCM_Query_Arbitrator_Free_Data_Ex;\r\n CM_Query_Arbitrator_Free_Size: TCM_Query_Arbitrator_Free_Size;\r\n CM_Query_Arbitrator_Free_Size_Ex: TCM_Query_Arbitrator_Free_Size_Ex;\r\n CM_Query_Remove_SubTree: TCM_Query_Remove_SubTree;\r\n CM_Query_Remove_SubTree_Ex: TCM_Query_Remove_SubTree_Ex;\r\n {$IFDEF WIN2000_UP}\r\n CM_Query_And_Remove_SubTreeA: TCM_Query_And_Remove_SubTreeA;\r\n CM_Query_And_Remove_SubTreeW: TCM_Query_And_Remove_SubTreeW;\r\n CM_Query_And_Remove_SubTree: TCM_Query_And_Remove_SubTree;\r\n CM_Query_And_Remove_SubTree_ExA: TCM_Query_And_Remove_SubTree_ExA;\r\n CM_Query_And_Remove_SubTree_ExW: TCM_Query_And_Remove_SubTree_ExW;\r\n CM_Query_And_Remove_SubTree_Ex: TCM_Query_And_Remove_SubTree_Ex;\r\n CM_Request_Device_EjectA: TCM_Request_Device_EjectA;\r\n CM_Request_Device_EjectW: TCM_Request_Device_EjectW;\r\n CM_Request_Device_Eject: TCM_Request_Device_Eject;\r\n CM_Request_Device_Eject_ExA: TCM_Request_Device_Eject_ExA;\r\n CM_Request_Device_Eject_ExW: TCM_Request_Device_Eject_ExW;\r\n CM_Request_Device_Eject_Ex: TCM_Request_Device_Eject_Ex;\r\n {$ENDIF WIN2000_UP}\r\n CM_Reenumerate_DevNode: TCM_Reenumerate_DevNode;\r\n CM_Reenumerate_DevInst: TCM_Reenumerate_DevInst;\r\n CM_Reenumerate_DevNode_Ex: TCM_Reenumerate_DevNode_Ex;\r\n CM_Reenumerate_DevInst_Ex: TCM_Reenumerate_DevInst_Ex;\r\n {$IFNDEF WINNT4}\r\n CM_Register_Device_InterfaceA: TCM_Register_Device_InterfaceA;\r\n CM_Register_Device_InterfaceW: TCM_Register_Device_InterfaceW;\r\n CM_Register_Device_Interface: TCM_Register_Device_Interface;\r\n CM_Register_Device_Interface_ExA: TCM_Register_Device_Interface_ExA;\r\n CM_Register_Device_Interface_ExW: TCM_Register_Device_Interface_ExW;\r\n CM_Register_Device_Interface_Ex: TCM_Register_Device_Interface_Ex;\r\n CM_Set_DevNode_Problem_Ex: TCM_Set_DevNode_Problem_Ex;\r\n CM_Set_DevInst_Problem_Ex: TCM_Set_DevInst_Problem_Ex;\r\n CM_Set_DevNode_Problem: TCM_Set_DevNode_Problem;\r\n CM_Set_DevInst_Problem: TCM_Set_DevInst_Problem;\r\n CM_Unregister_Device_InterfaceA: TCM_Unregister_Device_InterfaceA;\r\n CM_Unregister_Device_InterfaceW: TCM_Unregister_Device_InterfaceW;\r\n CM_Unregister_Device_Interface: TCM_Unregister_Device_Interface;\r\n CM_Unregister_Device_Interface_ExA: TCM_Unregister_Device_Interface_ExA;\r\n CM_Unregister_Device_Interface_ExW: TCM_Unregister_Device_Interface_ExW;\r\n CM_Unregister_Device_Interface_Ex: TCM_Unregister_Device_Interface_Ex;\r\n CM_Register_Device_Driver: TCM_Register_Device_Driver;\r\n CM_Register_Device_Driver_Ex: TCM_Register_Device_Driver_Ex;\r\n {$ENDIF !WINNT4}\r\n CM_Remove_SubTree: TCM_Remove_SubTree;\r\n CM_Remove_SubTree_Ex: TCM_Remove_SubTree_Ex;\r\n CM_Set_DevNode_Registry_PropertyA: TCM_Set_DevNode_Registry_PropertyA;\r\n CM_Set_DevNode_Registry_PropertyW: TCM_Set_DevNode_Registry_PropertyW;\r\n CM_Set_DevNode_Registry_Property: TCM_Set_DevNode_Registry_Property;\r\n CM_Set_DevNode_Registry_Property_ExA: TCM_Set_DevNode_Registry_Property_ExA;\r\n CM_Set_DevNode_Registry_Property_ExW: TCM_Set_DevNode_Registry_Property_ExW;\r\n CM_Set_DevNode_Registry_Property_Ex: TCM_Set_DevNode_Registry_Property_Ex;\r\n CM_Set_DevInst_Registry_PropertyA: TCM_Set_DevInst_Registry_PropertyA;\r\n CM_Set_DevInst_Registry_PropertyW: TCM_Set_DevInst_Registry_PropertyW;\r\n CM_Set_DevInst_Registry_Property: TCM_Set_DevInst_Registry_Property;\r\n CM_Set_DevInst_Registry_Property_ExA: TCM_Set_DevInst_Registry_Property_ExA;\r\n CM_Set_DevInst_Registry_Property_ExW: TCM_Set_DevInst_Registry_Property_ExW;\r\n CM_Set_DevInst_Registry_Property_Ex: TCM_Set_DevInst_Registry_Property_Ex;\r\n {$IFNDEF WINNT4}\r\n CM_Is_Dock_Station_Present: TCM_Is_Dock_Station_Present;\r\n {$ENDIF !WINNT4}\r\n {$IFDEF WIN2000_UP}\r\n CM_Is_Dock_Station_Present_Ex: TCM_Is_Dock_Station_Present_Ex;\r\n {$ENDIF WIN2000_UP}\r\n {$IFNDEF WINNT4}\r\n CM_Request_Eject_PC: TCM_Request_Eject_PC;\r\n {$ENDIF !WINNT4}\r\n {$IFDEF WIN2000_UP}\r\n CM_Request_Eject_PC_Ex: TCM_Request_Eject_PC_Ex;\r\n {$ENDIF WIN2000_UP}\r\n CM_Set_HW_Prof_FlagsA: TCM_Set_HW_Prof_FlagsA;\r\n CM_Set_HW_Prof_FlagsW: TCM_Set_HW_Prof_FlagsW;\r\n CM_Set_HW_Prof_Flags: TCM_Set_HW_Prof_Flags;\r\n CM_Set_HW_Prof_Flags_ExA: TCM_Set_HW_Prof_Flags_ExA;\r\n CM_Set_HW_Prof_Flags_ExW: TCM_Set_HW_Prof_Flags_ExW;\r\n CM_Set_HW_Prof_Flags_Ex: TCM_Set_HW_Prof_Flags_Ex;\r\n CM_Setup_DevNode: TCM_Setup_DevNode;\r\n CM_Setup_DevInst: TCM_Setup_DevInst;\r\n CM_Setup_DevNode_Ex: TCM_Setup_DevNode_Ex;\r\n CM_Setup_DevInst_Ex: TCM_Setup_DevInst_Ex;\r\n CM_Test_Range_Available: TCM_Test_Range_Available;\r\n CM_Uninstall_DevNode: TCM_Uninstall_DevNode;\r\n CM_Uninstall_DevInst: TCM_Uninstall_DevInst;\r\n CM_Uninstall_DevNode_Ex: TCM_Uninstall_DevNode_Ex;\r\n CM_Uninstall_DevInst_Ex: TCM_Uninstall_DevInst_Ex;\r\n CM_Run_Detection: TCM_Run_Detection;\r\n CM_Run_Detection_Ex: TCM_Run_Detection_Ex;\r\n CM_Set_HW_Prof: TCM_Set_HW_Prof;\r\n CM_Set_HW_Prof_Ex: TCM_Set_HW_Prof_Ex;\r\n {$IFDEF WIN2000_UP}\r\n CM_Query_Resource_Conflict_List: TCM_Query_Resource_Conflict_List;\r\n CM_Free_Resource_Conflict_Handle: TCM_Free_Resource_Conflict_Handle;\r\n CM_Get_Resource_Conflict_Count: TCM_Get_Resource_Conflict_Count;\r\n CM_Get_Resource_Conflict_DetailsA: TCM_Get_Resource_Conflict_DetailsA;\r\n CM_Get_Resource_Conflict_DetailsW: TCM_Get_Resource_Conflict_DetailsW;\r\n CM_Get_Resource_Conflict_Details: TCM_Get_Resource_Conflict_Details;\r\n CM_Get_Class_Registry_PropertyA: TCM_Get_Class_Registry_PropertyA;\r\n CM_Get_Class_Registry_PropertyW: TCM_Get_Class_Registry_PropertyW;\r\n CM_Get_Class_Registry_Property: TCM_Get_Class_Registry_Property;\r\n CM_Set_Class_Registry_PropertyA: TCM_Set_Class_Registry_PropertyA;\r\n CM_Set_Class_Registry_PropertyW: TCM_Set_Class_Registry_PropertyW;\r\n CM_Set_Class_Registry_Property: TCM_Set_Class_Registry_Property;\r\n CM_WaitNoPendingInstallEvents: TCM_WaitNoPendingInstallEvents;\r\n CMP_WaitNoPendingInstallEvents: TCMP_WaitNoPendingInstallEvents;\r\n {$ENDIF WIN2000_UP}\r\n\r\n{$ENDIF !CFGMGR32_LINKONREQUEST}\r\n\r\n//--------------------------------------------------------------\r\n// Configuration Manager return status codes\r\n//--------------------------------------------------------------\r\n\r\nconst\r\n CR_SUCCESS = $00000000;\r\n {$EXTERNALSYM CR_SUCCESS}\r\n CR_DEFAULT = $00000001;\r\n {$EXTERNALSYM CR_DEFAULT}\r\n CR_OUT_OF_MEMORY = $00000002;\r\n {$EXTERNALSYM CR_OUT_OF_MEMORY}\r\n CR_INVALID_POINTER = $00000003;\r\n {$EXTERNALSYM CR_INVALID_POINTER}\r\n CR_INVALID_FLAG = $00000004;\r\n {$EXTERNALSYM CR_INVALID_FLAG}\r\n CR_INVALID_DEVNODE = $00000005;\r\n {$EXTERNALSYM CR_INVALID_DEVNODE}\r\n CR_INVALID_DEVINST = CR_INVALID_DEVNODE;\r\n {$EXTERNALSYM CR_INVALID_DEVINST}\r\n CR_INVALID_RES_DES = $00000006;\r\n {$EXTERNALSYM CR_INVALID_RES_DES}\r\n CR_INVALID_LOG_CONF = $00000007;\r\n {$EXTERNALSYM CR_INVALID_LOG_CONF}\r\n CR_INVALID_ARBITRATOR = $00000008;\r\n {$EXTERNALSYM CR_INVALID_ARBITRATOR}\r\n CR_INVALID_NODELIST = $00000009;\r\n {$EXTERNALSYM CR_INVALID_NODELIST}\r\n CR_DEVNODE_HAS_REQS = $0000000A;\r\n {$EXTERNALSYM CR_DEVNODE_HAS_REQS}\r\n CR_DEVINST_HAS_REQS = CR_DEVNODE_HAS_REQS;\r\n {$EXTERNALSYM CR_DEVINST_HAS_REQS}\r\n CR_INVALID_RESOURCEID = $0000000B;\r\n {$EXTERNALSYM CR_INVALID_RESOURCEID}\r\n CR_DLVXD_NOT_FOUND = $0000000C; // WIN 95 ONLY\r\n {$EXTERNALSYM CR_DLVXD_NOT_FOUND}\r\n CR_NO_SUCH_DEVNODE = $0000000D;\r\n {$EXTERNALSYM CR_NO_SUCH_DEVNODE}\r\n CR_NO_SUCH_DEVINST = CR_NO_SUCH_DEVNODE;\r\n {$EXTERNALSYM CR_NO_SUCH_DEVINST}\r\n CR_NO_MORE_LOG_CONF = $0000000E;\r\n {$EXTERNALSYM CR_NO_MORE_LOG_CONF}\r\n CR_NO_MORE_RES_DES = $0000000F;\r\n {$EXTERNALSYM CR_NO_MORE_RES_DES}\r\n CR_ALREADY_SUCH_DEVNODE = $00000010;\r\n {$EXTERNALSYM CR_ALREADY_SUCH_DEVNODE}\r\n CR_ALREADY_SUCH_DEVINST = CR_ALREADY_SUCH_DEVNODE;\r\n {$EXTERNALSYM CR_ALREADY_SUCH_DEVINST}\r\n CR_INVALID_RANGE_LIST = $00000011;\r\n {$EXTERNALSYM CR_INVALID_RANGE_LIST}\r\n CR_INVALID_RANGE = $00000012;\r\n {$EXTERNALSYM CR_INVALID_RANGE}\r\n CR_FAILURE = $00000013;\r\n {$EXTERNALSYM CR_FAILURE}\r\n CR_NO_SUCH_LOGICAL_DEV = $00000014;\r\n {$EXTERNALSYM CR_NO_SUCH_LOGICAL_DEV}\r\n CR_CREATE_BLOCKED = $00000015;\r\n {$EXTERNALSYM CR_CREATE_BLOCKED}\r\n CR_NOT_SYSTEM_VM = $00000016; // WIN 95 ONLY\r\n {$EXTERNALSYM CR_NOT_SYSTEM_VM}\r\n CR_REMOVE_VETOED = $00000017;\r\n {$EXTERNALSYM CR_REMOVE_VETOED}\r\n CR_APM_VETOED = $00000018;\r\n {$EXTERNALSYM CR_APM_VETOED}\r\n CR_INVALID_LOAD_TYPE = $00000019;\r\n {$EXTERNALSYM CR_INVALID_LOAD_TYPE}\r\n CR_BUFFER_SMALL = $0000001A;\r\n {$EXTERNALSYM CR_BUFFER_SMALL}\r\n CR_NO_ARBITRATOR = $0000001B;\r\n {$EXTERNALSYM CR_NO_ARBITRATOR}\r\n CR_NO_REGISTRY_HANDLE = $0000001C;\r\n {$EXTERNALSYM CR_NO_REGISTRY_HANDLE}\r\n CR_REGISTRY_ERROR = $0000001D;\r\n {$EXTERNALSYM CR_REGISTRY_ERROR}\r\n CR_INVALID_DEVICE_ID = $0000001E;\r\n {$EXTERNALSYM CR_INVALID_DEVICE_ID}\r\n CR_INVALID_DATA = $0000001F;\r\n {$EXTERNALSYM CR_INVALID_DATA}\r\n CR_INVALID_API = $00000020;\r\n {$EXTERNALSYM CR_INVALID_API}\r\n CR_DEVLOADER_NOT_READY = $00000021;\r\n {$EXTERNALSYM CR_DEVLOADER_NOT_READY}\r\n CR_NEED_RESTART = $00000022;\r\n {$EXTERNALSYM CR_NEED_RESTART}\r\n CR_NO_MORE_HW_PROFILES = $00000023;\r\n {$EXTERNALSYM CR_NO_MORE_HW_PROFILES}\r\n CR_DEVICE_NOT_THERE = $00000024;\r\n {$EXTERNALSYM CR_DEVICE_NOT_THERE}\r\n CR_NO_SUCH_VALUE = $00000025;\r\n {$EXTERNALSYM CR_NO_SUCH_VALUE}\r\n CR_WRONG_TYPE = $00000026;\r\n {$EXTERNALSYM CR_WRONG_TYPE}\r\n CR_INVALID_PRIORITY = $00000027;\r\n {$EXTERNALSYM CR_INVALID_PRIORITY}\r\n CR_NOT_DISABLEABLE = $00000028;\r\n {$EXTERNALSYM CR_NOT_DISABLEABLE}\r\n CR_FREE_RESOURCES = $00000029;\r\n {$EXTERNALSYM CR_FREE_RESOURCES}\r\n CR_QUERY_VETOED = $0000002A;\r\n {$EXTERNALSYM CR_QUERY_VETOED}\r\n CR_CANT_SHARE_IRQ = $0000002B;\r\n {$EXTERNALSYM CR_CANT_SHARE_IRQ}\r\n CR_NO_DEPENDENT = $0000002C;\r\n {$EXTERNALSYM CR_NO_DEPENDENT}\r\n CR_SAME_RESOURCES = $0000002D;\r\n {$EXTERNALSYM CR_SAME_RESOURCES}\r\n CR_NO_SUCH_REGISTRY_KEY = $0000002E;\r\n {$EXTERNALSYM CR_NO_SUCH_REGISTRY_KEY}\r\n CR_INVALID_MACHINENAME = $0000002F; // NT ONLY\r\n {$EXTERNALSYM CR_INVALID_MACHINENAME}\r\n CR_REMOTE_COMM_FAILURE = $00000030; // NT ONLY\r\n {$EXTERNALSYM CR_REMOTE_COMM_FAILURE}\r\n CR_MACHINE_UNAVAILABLE = $00000031; // NT ONLY\r\n {$EXTERNALSYM CR_MACHINE_UNAVAILABLE}\r\n CR_NO_CM_SERVICES = $00000032; // NT ONLY\r\n {$EXTERNALSYM CR_NO_CM_SERVICES}\r\n CR_ACCESS_DENIED = $00000033; // NT ONLY\r\n {$EXTERNALSYM CR_ACCESS_DENIED}\r\n CR_CALL_NOT_IMPLEMENTED = $00000034;\r\n {$EXTERNALSYM CR_CALL_NOT_IMPLEMENTED}\r\n CR_INVALID_PROPERTY = $00000035;\r\n {$EXTERNALSYM CR_INVALID_PROPERTY}\r\n CR_DEVICE_INTERFACE_ACTIVE = $00000036;\r\n {$EXTERNALSYM CR_DEVICE_INTERFACE_ACTIVE}\r\n CR_NO_SUCH_DEVICE_INTERFACE = $00000037;\r\n {$EXTERNALSYM CR_NO_SUCH_DEVICE_INTERFACE}\r\n CR_INVALID_REFERENCE_STRING = $00000038;\r\n {$EXTERNALSYM CR_INVALID_REFERENCE_STRING}\r\n CR_INVALID_CONFLICT_LIST = $00000039;\r\n {$EXTERNALSYM CR_INVALID_CONFLICT_LIST}\r\n CR_INVALID_INDEX = $0000003A;\r\n {$EXTERNALSYM CR_INVALID_INDEX}\r\n CR_INVALID_STRUCTURE_SIZE = $0000003B;\r\n {$EXTERNALSYM CR_INVALID_STRUCTURE_SIZE}\r\n NUM_CR_RESULTS = $0000003C;\r\n {$EXTERNALSYM NUM_CR_RESULTS}\r\n\r\nfunction IsConfigManagerApiLoaded: Boolean;\r\nfunction LoadConfigManagerApi: Boolean;\r\nprocedure UnloadConfigManagerApi;\r\n\r\nimplementation\r\n\r\n{$IFDEF CFGMGR32_LINKONREQUEST}\r\nuses\r\n ModuleLoader;\r\n{$ENDIF CFGMGR32_LINKONREQUEST}\r\n\r\nconst\r\n CfgMgrDllName = 'cfgmgr32.dll';\r\n SetupApiDllName = 'SETUPAPI.DLL';\r\n {$IFDEF UNICODE}\r\n NameSuffix = 'W';\r\n {$ELSE}\r\n NameSuffix = 'A';\r\n {$ENDIF UNICODE}\r\n\r\n{$IFDEF CFGMGR32_LINKONREQUEST}\r\nvar\r\n CfgMgrApiLib: TModuleHandle = INVALID_MODULEHANDLE_VALUE;\r\n CfgMgrApiLoadCount: Integer = 0;\r\n{$ENDIF CFGMGR32_LINKONREQUEST}\r\n\r\nfunction IsConfigManagerApiLoaded: Boolean;\r\nbegin\r\n {$IFDEF CFGMGR32_LINKONREQUEST}\r\n Result := CfgMgrApiLib <> INVALID_MODULEHANDLE_VALUE;\r\n {$ELSE}\r\n Result := True;\r\n {$ENDIF CFGMGR32_LINKONREQUEST}\r\nend;\r\n\r\nfunction LoadConfigManagerApi: Boolean;\r\nbegin\r\n Result := LoadSetupApi;\r\n if not Result then\r\n Exit;\r\n {$IFDEF CFGMGR32_LINKONREQUEST}\r\n Inc(CfgMgrApiLoadCount);\r\n if CfgMgrApiLoadCount > 1 then\r\n Exit;\r\n Result := LoadModule(CfgMgrApiLib, CfgMgrDllName);\r\n if Result then\r\n begin\r\n @CM_Add_Empty_Log_Conf := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Add_Empty_Log_Conf', Result);\r\n @CM_Add_Empty_Log_Conf_Ex := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Add_Empty_Log_Conf_Ex', Result);\r\n @CM_Add_IDA := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Add_IDA', Result);\r\n @CM_Add_IDW := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Add_IDW', Result);\r\n @CM_Add_ID := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Add_ID' + NameSuffix, Result);\r\n @CM_Add_ID_ExA := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Add_ID_ExA', Result);\r\n @CM_Add_ID_ExW := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Add_ID_ExW', Result);\r\n @CM_Add_ID_Ex := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Add_ID_Ex' + NameSuffix, Result);\r\n @CM_Add_Range := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Add_Range', Result);\r\n @CM_Add_Res_Des := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Add_Res_Des', Result);\r\n @CM_Add_Res_Des_Ex := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Add_Res_Des_Ex', Result);\r\n @CM_Connect_MachineA := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Connect_MachineA', Result);\r\n @CM_Connect_MachineW := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Connect_MachineW', Result);\r\n @CM_Connect_Machine := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Connect_Machine' + NameSuffix, Result);\r\n @CM_Create_DevNodeA := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Create_DevNodeA', Result);\r\n @CM_Create_DevNodeW := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Create_DevNodeW', Result);\r\n @CM_Create_DevNode := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Create_DevNode' + NameSuffix, Result);\r\n @CM_Create_DevNode_ExA := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Create_DevNode_ExA', Result);\r\n @CM_Create_DevNode_ExW := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Create_DevNode_ExW', Result);\r\n @CM_Create_DevNode_Ex := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Create_DevNode_Ex' + NameSuffix, Result);\r\n @CM_Create_DevInstA := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Create_DevNodeA', Result);\r\n @CM_Create_DevInstW := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Create_DevNodeW', Result);\r\n @CM_Create_DevInst := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Create_DevNode' + NameSuffix, Result);\r\n @CM_Create_DevInst_ExA := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Create_DevNode_ExA', Result);\r\n @CM_Create_DevInst_ExW := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Create_DevNode_ExW', Result);\r\n @CM_Create_DevInst_Ex := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Create_DevNode_Ex' + NameSuffix, Result);\r\n @CM_Create_Range_List := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Create_Range_List', Result);\r\n @CM_Delete_Class_Key := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Delete_Class_Key', Result);\r\n @CM_Delete_Class_Key_Ex := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Delete_Class_Key_Ex', Result);\r\n @CM_Delete_DevNode_Key := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Delete_DevNode_Key', Result);\r\n @CM_Delete_DevNode_Key_Ex := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Delete_DevNode_Key_Ex', Result);\r\n @CM_Delete_DevInst_Key := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Delete_DevNode_Key', Result);\r\n @CM_Delete_DevInst_Key_Ex := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Delete_DevNode_Key_Ex', Result);\r\n @CM_Delete_Range := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Delete_Range', Result);\r\n @CM_Detect_Resource_Conflict := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Detect_Resource_Conflict', Result);\r\n @CM_Detect_Resource_Conflict_Ex := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Detect_Resource_Conflict_Ex', Result);\r\n @CM_Disable_DevNode := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Disable_DevNode', Result);\r\n @CM_Disable_DevNode_Ex := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Disable_DevNode_Ex', Result);\r\n @CM_Disable_DevInst := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Disable_DevNode', Result);\r\n @CM_Disable_DevInst_Ex := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Disable_DevNode_Ex', Result);\r\n @CM_Disconnect_Machine := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Disconnect_Machine', Result);\r\n @CM_Dup_Range_List := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Dup_Range_List', Result);\r\n @CM_Enable_DevNode := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Enable_DevNode', Result);\r\n @CM_Enable_DevNode_Ex := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Enable_DevNode_Ex', Result);\r\n @CM_Enable_DevInst := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Enable_DevNode', Result);\r\n @CM_Enable_DevInst_Ex := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Enable_DevNode_Ex', Result);\r\n @CM_Enumerate_Classes := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Enumerate_Classes', Result);\r\n @CM_Enumerate_Classes_Ex := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Enumerate_Classes_Ex', Result);\r\n @CM_Enumerate_EnumeratorsA := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Enumerate_EnumeratorsA', Result);\r\n @CM_Enumerate_EnumeratorsW := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Enumerate_EnumeratorsW', Result);\r\n @CM_Enumerate_Enumerators := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Enumerate_Enumerators' + NameSuffix, Result);\r\n @CM_Enumerate_Enumerators_ExA := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Enumerate_Enumerators_ExA', Result);\r\n @CM_Enumerate_Enumerators_ExW := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Enumerate_Enumerators_ExW', Result);\r\n @CM_Enumerate_Enumerators_Ex := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Enumerate_Enumerators_Ex' + NameSuffix, Result);\r\n @CM_Find_Range := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Find_Range', Result);\r\n @CM_First_Range := GetModuleSymbolEx(CfgMgrApiLib, 'CM_First_Range', Result);\r\n @CM_Free_Log_Conf := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Free_Log_Conf', Result);\r\n @CM_Free_Log_Conf_Ex := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Free_Log_Conf_Ex', Result);\r\n @CM_Free_Log_Conf_Handle := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Free_Log_Conf_Handle', Result);\r\n @CM_Free_Range_List := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Free_Range_List', Result);\r\n @CM_Free_Res_Des := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Free_Res_Des', Result);\r\n @CM_Free_Res_Des_Ex := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Free_Res_Des_Ex', Result);\r\n @CM_Free_Res_Des_Handle := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Free_Res_Des_Handle', Result);\r\n @CM_Get_Child := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Get_Child', Result);\r\n @CM_Get_Child_Ex := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Get_Child_Ex', Result);\r\n @CM_Get_Class_NameA := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Get_Class_NameA', Result);\r\n @CM_Get_Class_NameW := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Get_Class_NameW', Result);\r\n @CM_Get_Class_Name := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Get_Class_Name' + NameSuffix, Result);\r\n @CM_Get_Class_Name_ExA := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Get_Class_Name_ExA', Result);\r\n @CM_Get_Class_Name_ExW := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Get_Class_Name_ExW', Result);\r\n @CM_Get_Class_Name_Ex := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Get_Class_Name_Ex' + NameSuffix, Result);\r\n @CM_Get_Class_Key_NameA := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Get_Class_Key_NameA', Result);\r\n @CM_Get_Class_Key_NameW := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Get_Class_Key_NameW', Result);\r\n @CM_Get_Class_Key_Name := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Get_Class_Key_Name' + NameSuffix, Result);\r\n @CM_Get_Class_Key_Name_ExA := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Get_Class_Key_Name_ExA', Result);\r\n @CM_Get_Class_Key_Name_ExW := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Get_Class_Key_Name_ExW', Result);\r\n @CM_Get_Class_Key_Name_Ex := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Get_Class_Key_Name_Ex' + NameSuffix, Result);\r\n @CM_Get_Depth := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Get_Depth', Result);\r\n @CM_Get_Depth_Ex := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Get_Depth_Ex', Result);\r\n @CM_Get_Device_IDA := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Get_Device_IDA', Result);\r\n @CM_Get_Device_IDW := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Get_Device_IDW', Result);\r\n @CM_Get_Device_ID := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Get_Device_ID' + NameSuffix, Result);\r\n @CM_Get_Device_ID_ExA := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Get_Device_ID_ExA', Result);\r\n @CM_Get_Device_ID_ExW := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Get_Device_ID_ExW', Result);\r\n @CM_Get_Device_ID_Ex := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Get_Device_ID_Ex' + NameSuffix, Result);\r\n @CM_Get_Device_ID_ListA := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Get_Device_ID_ListA', Result);\r\n @CM_Get_Device_ID_ListW := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Get_Device_ID_ListW', Result);\r\n @CM_Get_Device_ID_List := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Get_Device_ID_List' + NameSuffix, Result);\r\n @CM_Get_Device_ID_List_ExA := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Get_Device_ID_List_ExA', Result);\r\n @CM_Get_Device_ID_List_ExW := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Get_Device_ID_List_ExW', Result);\r\n @CM_Get_Device_ID_List_Ex := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Get_Device_ID_List_Ex' + NameSuffix, Result);\r\n @CM_Get_Device_ID_List_SizeA := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Get_Device_ID_List_SizeA', Result);\r\n @CM_Get_Device_ID_List_SizeW := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Get_Device_ID_List_SizeW', Result);\r\n @CM_Get_Device_ID_List_Size := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Get_Device_ID_List_Size' + NameSuffix, Result);\r\n @CM_Get_Device_ID_List_Size_ExA := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Get_Device_ID_List_Size_ExA', Result);\r\n @CM_Get_Device_ID_List_Size_ExW := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Get_Device_ID_List_Size_ExW', Result);\r\n @CM_Get_Device_ID_List_Size_Ex := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Get_Device_ID_List_Size_Ex' + NameSuffix, Result);\r\n @CM_Get_Device_ID_Size := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Get_Device_ID_Size', Result);\r\n @CM_Get_Device_ID_Size_Ex := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Get_Device_ID_Size_Ex', Result);\r\n @CM_Get_DevNode_Registry_PropertyA := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Get_DevNode_Registry_PropertyA', Result);\r\n @CM_Get_DevNode_Registry_PropertyW := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Get_DevNode_Registry_PropertyW', Result);\r\n @CM_Get_DevNode_Registry_Property := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Get_DevNode_Registry_Property' + NameSuffix, Result);\r\n @CM_Get_DevNode_Registry_Property_ExA := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Get_DevNode_Registry_Property_ExA', Result);\r\n @CM_Get_DevNode_Registry_Property_ExW := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Get_DevNode_Registry_Property_ExW', Result);\r\n @CM_Get_DevNode_Registry_Property_Ex := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Get_DevNode_Registry_Property_Ex' + NameSuffix, Result);\r\n @CM_Get_DevInst_Registry_PropertyA := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Get_DevNode_Registry_PropertyA', Result);\r\n @CM_Get_DevInst_Registry_PropertyW := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Get_DevNode_Registry_PropertyW', Result);\r\n @CM_Get_DevInst_Registry_Property := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Get_DevNode_Registry_Property' + NameSuffix, Result);\r\n @CM_Get_DevInst_Registry_Property_ExA := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Get_DevNode_Registry_Property_ExA', Result);\r\n @CM_Get_DevInst_Registry_Property_ExW := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Get_DevNode_Registry_Property_ExW', Result);\r\n @CM_Get_DevInst_Registry_Property_Ex := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Get_DevNode_Registry_Property_Ex' + NameSuffix, Result);\r\n {$IFDEF WINXP_UP}\r\n @CM_Get_DevNode_Custom_PropertyA := GetModuleSymbolEx(GetSetupApiModuleHandle, 'CM_Get_DevNode_Custom_PropertyA', Result);\r\n @CM_Get_DevNode_Custom_PropertyW := GetModuleSymbolEx(GetSetupApiModuleHandle, 'CM_Get_DevNode_Custom_PropertyW', Result);\r\n @CM_Get_DevNode_Custom_Property := GetModuleSymbolEx(GetSetupApiModuleHandle, 'CM_Get_DevNode_Custom_Property' + NameSuffix, Result);\r\n @CM_Get_DevNode_Custom_Property_ExA := GetModuleSymbolEx(GetSetupApiModuleHandle, 'CM_Get_DevNode_Custom_Property_ExA', Result);\r\n @CM_Get_DevNode_Custom_Property_ExW := GetModuleSymbolEx(GetSetupApiModuleHandle, 'CM_Get_DevNode_Custom_Property_ExW', Result);\r\n @CM_Get_DevNode_Custom_Property_Ex := GetModuleSymbolEx(GetSetupApiModuleHandle, 'CM_Get_DevNode_Custom_Property_Ex' + NameSuffix, Result);\r\n @CM_Get_DevInst_Custom_PropertyA := GetModuleSymbolEx(GetSetupApiModuleHandle, 'CM_Get_DevNode_Custom_PropertyA', Result);\r\n @CM_Get_DevInst_Custom_PropertyW := GetModuleSymbolEx(GetSetupApiModuleHandle, 'CM_Get_DevNode_Custom_PropertyW', Result);\r\n @CM_Get_DevInst_Custom_Property := GetModuleSymbolEx(GetSetupApiModuleHandle, 'CM_Get_DevNode_Custom_Property' + NameSuffix, Result);\r\n @CM_Get_DevInst_Custom_Property_ExA := GetModuleSymbolEx(GetSetupApiModuleHandle, 'CM_Get_DevNode_Custom_Property_ExA', Result);\r\n @CM_Get_DevInst_Custom_Property_ExW := GetModuleSymbolEx(GetSetupApiModuleHandle, 'CM_Get_DevNode_Custom_Property_ExW', Result);\r\n @CM_Get_DevInst_Custom_Property_Ex := GetModuleSymbolEx(GetSetupApiModuleHandle, 'CM_Get_DevNode_Custom_Property_Ex' + NameSuffix, Result);\r\n {$ENDIF WINXP_UP}\r\n @CM_Get_DevNode_Status := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Get_DevNode_Status', Result);\r\n @CM_Get_DevInst_Status := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Get_DevNode_Status', Result);\r\n @CM_Get_DevNode_Status_Ex := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Get_DevNode_Status_Ex', Result);\r\n @CM_Get_DevInst_Status_Ex := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Get_DevNode_Status_Ex', Result);\r\n @CM_Get_First_Log_Conf := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Get_First_Log_Conf', Result);\r\n @CM_Get_First_Log_Conf_Ex := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Get_First_Log_Conf_Ex', Result);\r\n @CM_Get_Global_State := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Get_Global_State', Result);\r\n @CM_Get_Global_State_Ex := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Get_Global_State_Ex', Result);\r\n @CM_Get_Hardware_Profile_InfoA := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Get_Hardware_Profile_InfoA', Result);\r\n @CM_Get_Hardware_Profile_InfoW := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Get_Hardware_Profile_InfoW', Result);\r\n @CM_Get_Hardware_Profile_Info := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Get_Hardware_Profile_Info' + NameSuffix, Result);\r\n @CM_Get_Hardware_Profile_Info_ExA := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Get_Hardware_Profile_Info_ExA', Result);\r\n @CM_Get_Hardware_Profile_Info_ExW := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Get_Hardware_Profile_Info_ExW', Result);\r\n @CM_Get_Hardware_Profile_Info_Ex := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Get_Hardware_Profile_Info_Ex' + NameSuffix, Result);\r\n @CM_Get_HW_Prof_FlagsA := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Get_HW_Prof_FlagsA', Result);\r\n @CM_Get_HW_Prof_FlagsW := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Get_HW_Prof_FlagsW', Result);\r\n @CM_Get_HW_Prof_Flags := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Get_HW_Prof_Flags' + NameSuffix, Result);\r\n @CM_Get_HW_Prof_Flags_ExA := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Get_HW_Prof_Flags_ExA', Result);\r\n @CM_Get_HW_Prof_Flags_ExW := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Get_HW_Prof_Flags_ExW', Result);\r\n @CM_Get_HW_Prof_Flags_Ex := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Get_HW_Prof_Flags_Ex' + NameSuffix, Result);\r\n {$IFNDEF WINNT4}\r\n @CM_Get_Device_Interface_AliasA := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Get_Device_Interface_AliasA', Result);\r\n @CM_Get_Device_Interface_AliasW := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Get_Device_Interface_AliasW', Result);\r\n @CM_Get_Device_Interface_Alias := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Get_Device_Interface_Alias' + NameSuffix, Result);\r\n @CM_Get_Device_Interface_Alias_ExA := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Get_Device_Interface_Alias_ExA', Result);\r\n @CM_Get_Device_Interface_Alias_ExW := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Get_Device_Interface_Alias_ExW', Result);\r\n @CM_Get_Device_Interface_Alias_Ex := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Get_Device_Interface_Alias_Ex' + NameSuffix, Result);\r\n @CM_Get_Device_Interface_ListA := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Get_Device_Interface_ListA', Result);\r\n @CM_Get_Device_Interface_ListW := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Get_Device_Interface_ListW', Result);\r\n @CM_Get_Device_Interface_List := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Get_Device_Interface_List' + NameSuffix, Result);\r\n @CM_Get_Device_Interface_List_ExA := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Get_Device_Interface_List_ExA', Result);\r\n @CM_Get_Device_Interface_List_ExW := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Get_Device_Interface_List_ExW', Result);\r\n @CM_Get_Device_Interface_List_Ex := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Get_Device_Interface_List_Ex' + NameSuffix, Result);\r\n @CM_Get_Device_Interface_List_SizeA := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Get_Device_Interface_List_SizeA', Result);\r\n @CM_Get_Device_Interface_List_SizeW := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Get_Device_Interface_List_SizeW', Result);\r\n @CM_Get_Device_Interface_List_Size := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Get_Device_Interface_List_Size' + NameSuffix, Result);\r\n @CM_Get_Device_Interface_List_Size_ExA := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Get_Device_Interface_List_Size_ExA', Result);\r\n @CM_Get_Device_Interface_List_Size_ExW := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Get_Device_Interface_List_Size_ExW', Result);\r\n @CM_Get_Device_Interface_List_Size_Ex := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Get_Device_Interface_List_Size_Ex' + NameSuffix, Result);\r\n @CM_Get_Log_Conf_Priority := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Get_Log_Conf_Priority', Result);\r\n @CM_Get_Log_Conf_Priority_Ex := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Get_Log_Conf_Priority_Ex', Result);\r\n {$ENDIF !WINNT4}\r\n @CM_Get_Next_Log_Conf := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Get_Next_Log_Conf', Result);\r\n @CM_Get_Next_Log_Conf_Ex := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Get_Next_Log_Conf_Ex', Result);\r\n @CM_Get_Parent := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Get_Parent', Result);\r\n @CM_Get_Parent_Ex := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Get_Parent_Ex', Result);\r\n @CM_Get_Res_Des_Data := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Get_Res_Des_Data', Result);\r\n @CM_Get_Res_Des_Data_Ex := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Get_Res_Des_Data_Ex', Result);\r\n @CM_Get_Res_Des_Data_Size := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Get_Res_Des_Data_Size', Result);\r\n @CM_Get_Res_Des_Data_Size_Ex := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Get_Res_Des_Data_Size_Ex', Result);\r\n @CM_Get_Sibling := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Get_Sibling', Result);\r\n @CM_Get_Sibling_Ex := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Get_Sibling_Ex', Result);\r\n @CM_Get_Version := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Get_Version', Result);\r\n @CM_Get_Version_Ex := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Get_Version_Ex', Result);\r\n {$IFDEF WINXP_UP}\r\n @CM_Is_Version_Available := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Is_Version_Available', Result);\r\n @CM_Is_Version_Available_Ex := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Is_Version_Available_Ex', Result);\r\n {$ENDIF WINXP_UP}\r\n @CM_Intersect_Range_List := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Intersect_Range_List', Result);\r\n @CM_Invert_Range_List := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Invert_Range_List', Result);\r\n @CM_Locate_DevNodeA := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Locate_DevNodeA', Result);\r\n @CM_Locate_DevNodeW := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Locate_DevNodeW', Result);\r\n @CM_Locate_DevNode := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Locate_DevNode' + NameSuffix, Result);\r\n @CM_Locate_DevNode_ExA := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Locate_DevNode_ExA', Result);\r\n @CM_Locate_DevNode_ExW := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Locate_DevNode_ExW', Result);\r\n @CM_Locate_DevNode_Ex := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Locate_DevNode_Ex' + NameSuffix, Result);\r\n @CM_Locate_DevInstA := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Locate_DevNodeA', Result);\r\n @CM_Locate_DevInstW := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Locate_DevNodeW', Result);\r\n @CM_Locate_DevInst := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Locate_DevNode' + NameSuffix, Result);\r\n @CM_Locate_DevInst_ExA := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Locate_DevNode_ExA', Result);\r\n @CM_Locate_DevInst_ExW := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Locate_DevNode_ExW', Result);\r\n @CM_Locate_DevInst_Ex := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Locate_DevNode_Ex' + NameSuffix, Result);\r\n @CM_Merge_Range_List := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Merge_Range_List', Result);\r\n @CM_Modify_Res_Des := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Modify_Res_Des', Result);\r\n @CM_Modify_Res_Des_Ex := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Modify_Res_Des_Ex', Result);\r\n @CM_Move_DevNode := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Move_DevNode', Result);\r\n @CM_Move_DevInst := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Move_DevNode', Result);\r\n @CM_Move_DevNode_Ex := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Move_DevNode_Ex', Result);\r\n @CM_Move_DevInst_Ex := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Move_DevNode_Ex', Result);\r\n @CM_Next_Range := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Next_Range', Result);\r\n @CM_Get_Next_Res_Des := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Get_Next_Res_Des', Result);\r\n @CM_Get_Next_Res_Des_Ex := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Get_Next_Res_Des_Ex', Result);\r\n @CM_Open_Class_KeyA := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Open_Class_KeyA', Result);\r\n @CM_Open_Class_KeyW := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Open_Class_KeyW', Result);\r\n @CM_Open_Class_Key := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Open_Class_Key' + NameSuffix, Result);\r\n @CM_Open_Class_Key_ExA := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Open_Class_Key_ExA', Result);\r\n @CM_Open_Class_Key_ExW := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Open_Class_Key_ExW', Result);\r\n @CM_Open_Class_Key_Ex := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Open_Class_Key_Ex' + NameSuffix, Result);\r\n @CM_Open_DevNode_Key := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Open_DevNode_Key', Result);\r\n @CM_Open_DevInst_Key := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Open_DevNode_Key', Result);\r\n @CM_Open_DevNode_Key_Ex := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Open_DevNode_Key_Ex', Result);\r\n @CM_Open_DevInst_Key_Ex := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Open_DevNode_Key_Ex', Result);\r\n @CM_Query_Arbitrator_Free_Data := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Query_Arbitrator_Free_Data', Result);\r\n @CM_Query_Arbitrator_Free_Data_Ex := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Query_Arbitrator_Free_Data_Ex', Result);\r\n @CM_Query_Arbitrator_Free_Size := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Query_Arbitrator_Free_Size', Result);\r\n @CM_Query_Arbitrator_Free_Size_Ex := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Query_Arbitrator_Free_Size_Ex', Result);\r\n @CM_Query_Remove_SubTree := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Query_Remove_SubTree', Result);\r\n @CM_Query_Remove_SubTree_Ex := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Query_Remove_SubTree_Ex', Result);\r\n {$IFDEF WIN2000_UP}\r\n @CM_Query_And_Remove_SubTreeA := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Query_And_Remove_SubTreeA', Result);\r\n @CM_Query_And_Remove_SubTreeW := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Query_And_Remove_SubTreeW', Result);\r\n @CM_Query_And_Remove_SubTree := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Query_And_Remove_SubTree' + NameSuffix, Result);\r\n @CM_Query_And_Remove_SubTree_ExA := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Query_And_Remove_SubTree_ExA', Result);\r\n @CM_Query_And_Remove_SubTree_ExW := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Query_And_Remove_SubTree_ExW', Result);\r\n @CM_Query_And_Remove_SubTree_Ex := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Query_And_Remove_SubTree_Ex' + NameSuffix, Result);\r\n @CM_Request_Device_EjectA := GetModuleSymbolEx(GetSetupApiModuleHandle, 'CM_Request_Device_EjectA', Result);\r\n @CM_Request_Device_EjectW := GetModuleSymbolEx(GetSetupApiModuleHandle, 'CM_Request_Device_EjectW', Result);\r\n @CM_Request_Device_Eject := GetModuleSymbolEx(GetSetupApiModuleHandle, 'CM_Request_Device_Eject' + NameSuffix, Result);\r\n @CM_Request_Device_Eject_ExA := GetModuleSymbolEx(GetSetupApiModuleHandle, 'CM_Request_Device_Eject_ExA', Result);\r\n @CM_Request_Device_Eject_ExW := GetModuleSymbolEx(GetSetupApiModuleHandle, 'CM_Request_Device_Eject_ExW', Result);\r\n @CM_Request_Device_Eject_Ex := GetModuleSymbolEx(GetSetupApiModuleHandle, 'CM_Request_Device_Eject_Ex' + NameSuffix, Result);\r\n {$ENDIF WIN2000_UP}\r\n @CM_Reenumerate_DevNode := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Reenumerate_DevNode', Result);\r\n @CM_Reenumerate_DevInst := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Reenumerate_DevNode', Result);\r\n @CM_Reenumerate_DevNode_Ex := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Reenumerate_DevNode_Ex', Result);\r\n @CM_Reenumerate_DevInst_Ex := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Reenumerate_DevNode_Ex', Result);\r\n {$IFNDEF WINNT4}\r\n @CM_Register_Device_InterfaceA := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Register_Device_InterfaceA', Result);\r\n @CM_Register_Device_InterfaceW := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Register_Device_InterfaceW', Result);\r\n @CM_Register_Device_Interface := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Register_Device_Interface' + NameSuffix, Result);\r\n @CM_Register_Device_Interface_ExA := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Register_Device_Interface_ExA', Result);\r\n @CM_Register_Device_Interface_ExW := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Register_Device_Interface_ExW', Result);\r\n @CM_Register_Device_Interface_Ex := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Register_Device_Interface_Ex' + NameSuffix, Result);\r\n @CM_Set_DevNode_Problem_Ex := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Set_DevNode_Problem_Ex', Result);\r\n @CM_Set_DevInst_Problem_Ex := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Set_DevNode_Problem_Ex', Result);\r\n @CM_Set_DevNode_Problem := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Set_DevNode_Problem', Result);\r\n @CM_Set_DevInst_Problem := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Set_DevNode_Problem', Result);\r\n @CM_Unregister_Device_InterfaceA := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Unregister_Device_InterfaceA', Result);\r\n @CM_Unregister_Device_InterfaceW := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Unregister_Device_InterfaceW', Result);\r\n @CM_Unregister_Device_Interface := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Unregister_Device_Interface' + NameSuffix, Result);\r\n @CM_Unregister_Device_Interface_ExA := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Unregister_Device_Interface_ExA', Result);\r\n @CM_Unregister_Device_Interface_ExW := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Unregister_Device_Interface_ExW', Result);\r\n @CM_Unregister_Device_Interface_Ex := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Unregister_Device_Interface_Ex' + NameSuffix, Result);\r\n @CM_Register_Device_Driver := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Register_Device_Driver', Result);\r\n @CM_Register_Device_Driver_Ex := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Register_Device_Driver_Ex', Result);\r\n {$ENDIF !WINNT4}\r\n @CM_Remove_SubTree := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Remove_SubTree', Result);\r\n @CM_Remove_SubTree_Ex := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Remove_SubTree_Ex', Result);\r\n @CM_Set_DevNode_Registry_PropertyA := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Set_DevNode_Registry_PropertyA', Result);\r\n @CM_Set_DevNode_Registry_PropertyW := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Set_DevNode_Registry_PropertyW', Result);\r\n @CM_Set_DevNode_Registry_Property := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Set_DevNode_Registry_Property' + NameSuffix, Result);\r\n @CM_Set_DevNode_Registry_Property_ExA := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Set_DevNode_Registry_Property_ExA', Result);\r\n @CM_Set_DevNode_Registry_Property_ExW := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Set_DevNode_Registry_Property_ExW', Result);\r\n @CM_Set_DevNode_Registry_Property_Ex := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Set_DevNode_Registry_Property_Ex' + NameSuffix, Result);\r\n @CM_Set_DevInst_Registry_PropertyA := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Set_DevNode_Registry_PropertyA', Result);\r\n @CM_Set_DevInst_Registry_PropertyW := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Set_DevNode_Registry_PropertyW', Result);\r\n @CM_Set_DevInst_Registry_Property := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Set_DevNode_Registry_Property' + NameSuffix, Result);\r\n @CM_Set_DevInst_Registry_Property_ExA := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Set_DevNode_Registry_Property_ExA', Result);\r\n @CM_Set_DevInst_Registry_Property_ExW := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Set_DevNode_Registry_Property_ExW', Result);\r\n @CM_Set_DevInst_Registry_Property_Ex := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Set_DevNode_Registry_Property_Ex' + NameSuffix, Result);\r\n {$IFNDEF WINNT4}\r\n @CM_Is_Dock_Station_Present := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Is_Dock_Station_Present', Result);\r\n {$ENDIF !WINNT4}\r\n {$IFDEF WIN2000_UP}\r\n @CM_Is_Dock_Station_Present_Ex := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Is_Dock_Station_Present_Ex', Result);\r\n {$ENDIF WIN2000_UP}\r\n {$IFNDEF WINNT4}\r\n @CM_Request_Eject_PC := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Request_Eject_PC', Result);\r\n {$ENDIF !WINNT4}\r\n {$IFDEF WIN2000_UP}\r\n @CM_Request_Eject_PC_Ex := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Request_Eject_PC_Ex', Result);\r\n {$ENDIF WIN2000_UP}\r\n @CM_Set_HW_Prof_FlagsA := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Set_HW_Prof_FlagsA', Result);\r\n @CM_Set_HW_Prof_FlagsW := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Set_HW_Prof_FlagsW', Result);\r\n @CM_Set_HW_Prof_Flags := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Set_HW_Prof_Flags' + NameSuffix, Result);\r\n @CM_Set_HW_Prof_Flags_ExA := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Set_HW_Prof_Flags_ExA', Result);\r\n @CM_Set_HW_Prof_Flags_ExW := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Set_HW_Prof_Flags_ExW', Result);\r\n @CM_Set_HW_Prof_Flags_Ex := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Set_HW_Prof_Flags_Ex' + NameSuffix, Result);\r\n @CM_Setup_DevNode := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Setup_DevNode', Result);\r\n @CM_Setup_DevInst := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Setup_DevNode', Result);\r\n @CM_Setup_DevNode_Ex := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Setup_DevNode_Ex', Result);\r\n @CM_Setup_DevInst_Ex := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Setup_DevNode_Ex', Result);\r\n @CM_Test_Range_Available := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Test_Range_Available', Result);\r\n @CM_Uninstall_DevNode := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Uninstall_DevNode', Result);\r\n @CM_Uninstall_DevInst := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Uninstall_DevNode', Result);\r\n @CM_Uninstall_DevNode_Ex := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Uninstall_DevNode_Ex', Result);\r\n @CM_Uninstall_DevInst_Ex := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Uninstall_DevNode_Ex', Result);\r\n @CM_Run_Detection := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Run_Detection', Result);\r\n @CM_Run_Detection_Ex := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Run_Detection_Ex', Result);\r\n @CM_Set_HW_Prof := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Set_HW_Prof', Result);\r\n @CM_Set_HW_Prof_Ex := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Set_HW_Prof_Ex', Result);\r\n {$IFDEF WIN2000_UP}\r\n @CM_Query_Resource_Conflict_List := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Query_Resource_Conflict_List', Result);\r\n @CM_Free_Resource_Conflict_Handle := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Free_Resource_Conflict_Handle', Result);\r\n @CM_Get_Resource_Conflict_Count := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Get_Resource_Conflict_Count', Result);\r\n @CM_Get_Resource_Conflict_DetailsA := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Get_Resource_Conflict_DetailsA', Result);\r\n @CM_Get_Resource_Conflict_DetailsW := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Get_Resource_Conflict_DetailsW', Result);\r\n @CM_Get_Resource_Conflict_Details := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Get_Resource_Conflict_Details' + NameSuffix, Result);\r\n @CM_Get_Class_Registry_PropertyA := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Get_Class_Registry_PropertyA', Result);\r\n @CM_Get_Class_Registry_PropertyW := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Get_Class_Registry_PropertyW', Result);\r\n @CM_Get_Class_Registry_Property := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Get_Class_Registry_Property' + NameSuffix, Result);\r\n @CM_Set_Class_Registry_PropertyA := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Set_Class_Registry_PropertyA', Result);\r\n @CM_Set_Class_Registry_PropertyW := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Set_Class_Registry_PropertyW', Result);\r\n @CM_Set_Class_Registry_Property := GetModuleSymbolEx(CfgMgrApiLib, 'CM_Set_Class_Registry_Property' + NameSuffix, Result);\r\n @CM_WaitNoPendingInstallEvents := GetModuleSymbolEx(CfgMgrApiLib, 'CMP_WaitNoPendingInstallEvents', Result);\r\n @CMP_WaitNoPendingInstallEvents := GetModuleSymbolEx(CfgMgrApiLib, 'CMP_WaitNoPendingInstallEvents', Result);\r\n {$ENDIF WIN2000_UP}\r\n if not Result then\r\n UnloadConfigManagerApi;\r\n end;\r\n {$ELSE}\r\n Result := True;\r\n {$ENDIF CFGMGR32_LINKONREQUEST}\r\nend;\r\n\r\nprocedure UnloadConfigManagerApi;\r\nbegin\r\n UnloadSetupApi;\r\n {$IFDEF CFGMGR32_LINKONREQUEST}\r\n Dec(CfgMgrApiLoadCount);\r\n if CfgMgrApiLoadCount > 0 then\r\n Exit;\r\n UnloadModule(CfgMgrApiLib);\r\n CM_Add_Empty_Log_Conf := nil;\r\n CM_Add_Empty_Log_Conf_Ex := nil;\r\n CM_Add_IDA := nil;\r\n CM_Add_IDW := nil;\r\n CM_Add_ID := nil;\r\n CM_Add_ID_ExA := nil;\r\n CM_Add_ID_ExW := nil;\r\n CM_Add_ID_Ex := nil;\r\n CM_Add_Range := nil;\r\n CM_Add_Res_Des := nil;\r\n CM_Add_Res_Des_Ex := nil;\r\n CM_Connect_MachineA := nil;\r\n CM_Connect_MachineW := nil;\r\n CM_Connect_Machine := nil;\r\n CM_Create_DevNodeA := nil;\r\n CM_Create_DevNodeW := nil;\r\n CM_Create_DevNode := nil;\r\n CM_Create_DevNode_ExA := nil;\r\n CM_Create_DevNode_ExW := nil;\r\n CM_Create_DevNode_Ex := nil;\r\n CM_Create_DevInstA := nil;\r\n CM_Create_DevInstW := nil;\r\n CM_Create_DevInst := nil;\r\n CM_Create_DevInst_ExA := nil;\r\n CM_Create_DevInst_ExW := nil;\r\n CM_Create_DevInst_Ex := nil;\r\n CM_Create_Range_List := nil;\r\n CM_Delete_Class_Key := nil;\r\n CM_Delete_Class_Key_Ex := nil;\r\n CM_Delete_DevNode_Key := nil;\r\n CM_Delete_DevNode_Key_Ex := nil;\r\n CM_Delete_DevInst_Key := nil;\r\n CM_Delete_DevInst_Key_Ex := nil;\r\n CM_Delete_Range := nil;\r\n CM_Detect_Resource_Conflict := nil;\r\n CM_Detect_Resource_Conflict_Ex := nil;\r\n CM_Disable_DevNode := nil;\r\n CM_Disable_DevNode_Ex := nil;\r\n CM_Disable_DevInst := nil;\r\n CM_Disable_DevInst_Ex := nil;\r\n CM_Disconnect_Machine := nil;\r\n CM_Dup_Range_List := nil;\r\n CM_Enable_DevNode := nil;\r\n CM_Enable_DevNode_Ex := nil;\r\n CM_Enable_DevInst := nil;\r\n CM_Enable_DevInst_Ex := nil;\r\n CM_Enumerate_Classes := nil;\r\n CM_Enumerate_Classes_Ex := nil;\r\n CM_Enumerate_EnumeratorsA := nil;\r\n CM_Enumerate_EnumeratorsW := nil;\r\n CM_Enumerate_Enumerators := nil;\r\n CM_Enumerate_Enumerators_ExA := nil;\r\n CM_Enumerate_Enumerators_ExW := nil;\r\n CM_Enumerate_Enumerators_Ex := nil;\r\n CM_Find_Range := nil;\r\n CM_First_Range := nil;\r\n CM_Free_Log_Conf := nil;\r\n CM_Free_Log_Conf_Ex := nil;\r\n CM_Free_Log_Conf_Handle := nil;\r\n CM_Free_Range_List := nil;\r\n CM_Free_Res_Des := nil;\r\n CM_Free_Res_Des_Ex := nil;\r\n CM_Free_Res_Des_Handle := nil;\r\n CM_Get_Child := nil;\r\n CM_Get_Child_Ex := nil;\r\n CM_Get_Class_NameA := nil;\r\n CM_Get_Class_NameW := nil;\r\n CM_Get_Class_Name := nil;\r\n CM_Get_Class_Name_ExA := nil;\r\n CM_Get_Class_Name_ExW := nil;\r\n CM_Get_Class_Name_Ex := nil;\r\n CM_Get_Class_Key_NameA := nil;\r\n CM_Get_Class_Key_NameW := nil;\r\n CM_Get_Class_Key_Name := nil;\r\n CM_Get_Class_Key_Name_ExA := nil;\r\n CM_Get_Class_Key_Name_ExW := nil;\r\n CM_Get_Class_Key_Name_Ex := nil;\r\n CM_Get_Depth := nil;\r\n CM_Get_Depth_Ex := nil;\r\n CM_Get_Device_IDA := nil;\r\n CM_Get_Device_IDW := nil;\r\n CM_Get_Device_ID := nil;\r\n CM_Get_Device_ID_ExA := nil;\r\n CM_Get_Device_ID_ExW := nil;\r\n CM_Get_Device_ID_Ex := nil;\r\n CM_Get_Device_ID_ListA := nil;\r\n CM_Get_Device_ID_ListW := nil;\r\n CM_Get_Device_ID_List := nil;\r\n CM_Get_Device_ID_List_ExA := nil;\r\n CM_Get_Device_ID_List_ExW := nil;\r\n CM_Get_Device_ID_List_Ex := nil;\r\n CM_Get_Device_ID_List_SizeA := nil;\r\n CM_Get_Device_ID_List_SizeW := nil;\r\n CM_Get_Device_ID_List_Size := nil;\r\n CM_Get_Device_ID_List_Size_ExA := nil;\r\n CM_Get_Device_ID_List_Size_ExW := nil;\r\n CM_Get_Device_ID_List_Size_Ex := nil;\r\n CM_Get_Device_ID_Size := nil;\r\n CM_Get_Device_ID_Size_Ex := nil;\r\n CM_Get_DevNode_Registry_PropertyA := nil;\r\n CM_Get_DevNode_Registry_PropertyW := nil;\r\n CM_Get_DevNode_Registry_Property := nil;\r\n CM_Get_DevNode_Registry_Property_ExA := nil;\r\n CM_Get_DevNode_Registry_Property_ExW := nil;\r\n CM_Get_DevNode_Registry_Property_Ex := nil;\r\n CM_Get_DevInst_Registry_PropertyA := nil;\r\n CM_Get_DevInst_Registry_PropertyW := nil;\r\n CM_Get_DevInst_Registry_Property := nil;\r\n CM_Get_DevInst_Registry_Property_ExA := nil;\r\n CM_Get_DevInst_Registry_Property_ExW := nil;\r\n CM_Get_DevInst_Registry_Property_Ex := nil;\r\n {$IFDEF WINXP_UP}\r\n CM_Get_DevNode_Custom_PropertyA := nil;\r\n CM_Get_DevNode_Custom_PropertyW := nil;\r\n CM_Get_DevNode_Custom_Property := nil;\r\n CM_Get_DevNode_Custom_Property_ExA := nil;\r\n CM_Get_DevNode_Custom_Property_ExW := nil;\r\n CM_Get_DevNode_Custom_Property_Ex := nil;\r\n CM_Get_DevInst_Custom_PropertyA := nil;\r\n CM_Get_DevInst_Custom_PropertyW := nil;\r\n CM_Get_DevInst_Custom_Property := nil;\r\n CM_Get_DevInst_Custom_Property_ExA := nil;\r\n CM_Get_DevInst_Custom_Property_ExW := nil;\r\n CM_Get_DevInst_Custom_Property_Ex := nil;\r\n {$ENDIF WINXP_UP}\r\n CM_Get_DevNode_Status := nil;\r\n CM_Get_DevInst_Status := nil;\r\n CM_Get_DevNode_Status_Ex := nil;\r\n CM_Get_DevInst_Status_Ex := nil;\r\n CM_Get_First_Log_Conf := nil;\r\n CM_Get_First_Log_Conf_Ex := nil;\r\n CM_Get_Global_State := nil;\r\n CM_Get_Global_State_Ex := nil;\r\n CM_Get_Hardware_Profile_InfoA := nil;\r\n CM_Get_Hardware_Profile_InfoW := nil;\r\n CM_Get_Hardware_Profile_Info := nil;\r\n CM_Get_Hardware_Profile_Info_ExA := nil;\r\n CM_Get_Hardware_Profile_Info_ExW := nil;\r\n CM_Get_Hardware_Profile_Info_Ex := nil;\r\n CM_Get_HW_Prof_FlagsA := nil;\r\n CM_Get_HW_Prof_FlagsW := nil;\r\n CM_Get_HW_Prof_Flags := nil;\r\n CM_Get_HW_Prof_Flags_ExA := nil;\r\n CM_Get_HW_Prof_Flags_ExW := nil;\r\n CM_Get_HW_Prof_Flags_Ex := nil;\r\n {$IFNDEF WINNT4}\r\n CM_Get_Device_Interface_AliasA := nil;\r\n CM_Get_Device_Interface_AliasW := nil;\r\n CM_Get_Device_Interface_Alias := nil;\r\n CM_Get_Device_Interface_Alias_ExA := nil;\r\n CM_Get_Device_Interface_Alias_ExW := nil;\r\n CM_Get_Device_Interface_Alias_Ex := nil;\r\n CM_Get_Device_Interface_ListA := nil;\r\n CM_Get_Device_Interface_ListW := nil;\r\n CM_Get_Device_Interface_List := nil;\r\n CM_Get_Device_Interface_List_ExA := nil;\r\n CM_Get_Device_Interface_List_ExW := nil;\r\n CM_Get_Device_Interface_List_Ex := nil;\r\n CM_Get_Device_Interface_List_SizeA := nil;\r\n CM_Get_Device_Interface_List_SizeW := nil;\r\n CM_Get_Device_Interface_List_Size := nil;\r\n CM_Get_Device_Interface_List_Size_ExA := nil;\r\n CM_Get_Device_Interface_List_Size_ExW := nil;\r\n CM_Get_Device_Interface_List_Size_Ex := nil;\r\n CM_Get_Log_Conf_Priority := nil;\r\n CM_Get_Log_Conf_Priority_Ex := nil;\r\n {$ENDIF !WINNT4}\r\n CM_Get_Next_Log_Conf := nil;\r\n CM_Get_Next_Log_Conf_Ex := nil;\r\n CM_Get_Parent := nil;\r\n CM_Get_Parent_Ex := nil;\r\n CM_Get_Res_Des_Data := nil;\r\n CM_Get_Res_Des_Data_Ex := nil;\r\n CM_Get_Res_Des_Data_Size := nil;\r\n CM_Get_Res_Des_Data_Size_Ex := nil;\r\n CM_Get_Sibling := nil;\r\n CM_Get_Sibling_Ex := nil;\r\n CM_Get_Version := nil;\r\n CM_Get_Version_Ex := nil;\r\n {$IFDEF WINXP_UP}\r\n CM_Is_Version_Available := nil;\r\n CM_Is_Version_Available_Ex := nil;\r\n {$ENDIF WINXP_UP}\r\n CM_Intersect_Range_List := nil;\r\n CM_Invert_Range_List := nil;\r\n CM_Locate_DevNodeA := nil;\r\n CM_Locate_DevNodeW := nil;\r\n CM_Locate_DevNode := nil;\r\n CM_Locate_DevNode_ExA := nil;\r\n CM_Locate_DevNode_ExW := nil;\r\n CM_Locate_DevNode_Ex := nil;\r\n CM_Locate_DevInstA := nil;\r\n CM_Locate_DevInstW := nil;\r\n CM_Locate_DevInst := nil;\r\n CM_Locate_DevInst_ExA := nil;\r\n CM_Locate_DevInst_ExW := nil;\r\n CM_Locate_DevInst_Ex := nil;\r\n CM_Merge_Range_List := nil;\r\n CM_Modify_Res_Des := nil;\r\n CM_Modify_Res_Des_Ex := nil;\r\n CM_Move_DevNode := nil;\r\n CM_Move_DevInst := nil;\r\n CM_Move_DevNode_Ex := nil;\r\n CM_Move_DevInst_Ex := nil;\r\n CM_Next_Range := nil;\r\n CM_Get_Next_Res_Des := nil;\r\n CM_Get_Next_Res_Des_Ex := nil;\r\n CM_Open_Class_KeyA := nil;\r\n CM_Open_Class_KeyW := nil;\r\n CM_Open_Class_Key := nil;\r\n CM_Open_Class_Key_ExA := nil;\r\n CM_Open_Class_Key_ExW := nil;\r\n CM_Open_Class_Key_Ex := nil;\r\n CM_Open_DevNode_Key := nil;\r\n CM_Open_DevInst_Key := nil;\r\n CM_Open_DevNode_Key_Ex := nil;\r\n CM_Open_DevInst_Key_Ex := nil;\r\n CM_Query_Arbitrator_Free_Data := nil;\r\n CM_Query_Arbitrator_Free_Data_Ex := nil;\r\n CM_Query_Arbitrator_Free_Size := nil;\r\n CM_Query_Arbitrator_Free_Size_Ex := nil;\r\n CM_Query_Remove_SubTree := nil;\r\n CM_Query_Remove_SubTree_Ex := nil;\r\n {$IFDEF WIN2000_UP}\r\n CM_Query_And_Remove_SubTreeA := nil;\r\n CM_Query_And_Remove_SubTreeW := nil;\r\n CM_Query_And_Remove_SubTree := nil;\r\n CM_Query_And_Remove_SubTree_ExA := nil;\r\n CM_Query_And_Remove_SubTree_ExW := nil;\r\n CM_Query_And_Remove_SubTree_Ex := nil;\r\n CM_Request_Device_EjectA := nil;\r\n CM_Request_Device_EjectW := nil;\r\n CM_Request_Device_Eject := nil;\r\n CM_Request_Device_Eject_ExA := nil;\r\n CM_Request_Device_Eject_ExW := nil;\r\n CM_Request_Device_Eject_Ex := nil;\r\n {$ENDIF WIN2000_UP}\r\n CM_Reenumerate_DevNode := nil;\r\n CM_Reenumerate_DevInst := nil;\r\n CM_Reenumerate_DevNode_Ex := nil;\r\n CM_Reenumerate_DevInst_Ex := nil;\r\n {$IFNDEF WINNT4}\r\n CM_Register_Device_InterfaceA := nil;\r\n CM_Register_Device_InterfaceW := nil;\r\n CM_Register_Device_Interface := nil;\r\n CM_Register_Device_Interface_ExA := nil;\r\n CM_Register_Device_Interface_ExW := nil;\r\n CM_Register_Device_Interface_Ex := nil;\r\n CM_Set_DevNode_Problem_Ex := nil;\r\n CM_Set_DevInst_Problem_Ex := nil;\r\n CM_Set_DevNode_Problem := nil;\r\n CM_Set_DevInst_Problem := nil;\r\n CM_Unregister_Device_InterfaceA := nil;\r\n CM_Unregister_Device_InterfaceW := nil;\r\n CM_Unregister_Device_Interface := nil;\r\n CM_Unregister_Device_Interface_ExA := nil;\r\n CM_Unregister_Device_Interface_ExW := nil;\r\n CM_Unregister_Device_Interface_Ex := nil;\r\n CM_Register_Device_Driver := nil;\r\n CM_Register_Device_Driver_Ex := nil;\r\n {$ENDIF !WINNT4}\r\n CM_Remove_SubTree := nil;\r\n CM_Remove_SubTree_Ex := nil;\r\n CM_Set_DevNode_Registry_PropertyA := nil;\r\n CM_Set_DevNode_Registry_PropertyW := nil;\r\n CM_Set_DevNode_Registry_Property := nil;\r\n CM_Set_DevNode_Registry_Property_ExA := nil;\r\n CM_Set_DevNode_Registry_Property_ExW := nil;\r\n CM_Set_DevNode_Registry_Property_Ex := nil;\r\n CM_Set_DevInst_Registry_PropertyA := nil;\r\n CM_Set_DevInst_Registry_PropertyW := nil;\r\n CM_Set_DevInst_Registry_Property := nil;\r\n CM_Set_DevInst_Registry_Property_ExA := nil;\r\n CM_Set_DevInst_Registry_Property_ExW := nil;\r\n CM_Set_DevInst_Registry_Property_Ex := nil;\r\n {$IFNDEF WINNT4}\r\n CM_Is_Dock_Station_Present := nil;\r\n {$ENDIF !WINNT4}\r\n {$IFDEF WIN2000_UP}\r\n CM_Is_Dock_Station_Present_Ex := nil;\r\n {$ENDIF WIN2000_UP}\r\n {$IFNDEF WINNT4}\r\n CM_Request_Eject_PC := nil;\r\n {$ENDIF !WINNT4}\r\n {$IFDEF WIN2000_UP}\r\n CM_Request_Eject_PC_Ex := nil;\r\n {$ENDIF WIN2000_UP}\r\n CM_Set_HW_Prof_FlagsA := nil;\r\n CM_Set_HW_Prof_FlagsW := nil;\r\n CM_Set_HW_Prof_Flags := nil;\r\n CM_Set_HW_Prof_Flags_ExA := nil;\r\n CM_Set_HW_Prof_Flags_ExW := nil;\r\n CM_Set_HW_Prof_Flags_Ex := nil;\r\n CM_Setup_DevNode := nil;\r\n CM_Setup_DevInst := nil;\r\n CM_Setup_DevNode_Ex := nil;\r\n CM_Setup_DevInst_Ex := nil;\r\n CM_Test_Range_Available := nil;\r\n CM_Uninstall_DevNode := nil;\r\n CM_Uninstall_DevInst := nil;\r\n CM_Uninstall_DevNode_Ex := nil;\r\n CM_Uninstall_DevInst_Ex := nil;\r\n CM_Run_Detection := nil;\r\n CM_Run_Detection_Ex := nil;\r\n CM_Set_HW_Prof := nil;\r\n CM_Set_HW_Prof_Ex := nil;\r\n {$IFDEF WIN2000_UP}\r\n CM_Query_Resource_Conflict_List := nil;\r\n CM_Free_Resource_Conflict_Handle := nil;\r\n CM_Get_Resource_Conflict_Count := nil;\r\n CM_Get_Resource_Conflict_DetailsA := nil;\r\n CM_Get_Resource_Conflict_DetailsW := nil;\r\n CM_Get_Resource_Conflict_Details := nil;\r\n CM_Get_Class_Registry_PropertyA := nil;\r\n CM_Get_Class_Registry_PropertyW := nil;\r\n CM_Get_Class_Registry_Property := nil;\r\n CM_Set_Class_Registry_PropertyA := nil;\r\n CM_Set_Class_Registry_PropertyW := nil;\r\n CM_Set_Class_Registry_Property := nil;\r\n CM_WaitNoPendingInstallEvents := nil;\r\n CMP_WaitNoPendingInstallEvents := nil;\r\n {$ENDIF WIN2000_UP}\r\n {$ENDIF CFGMGR32_LINKONREQUEST}\r\nend;\r\n\r\n{$IFNDEF CFGMGR32_LINKONREQUEST}\r\n\r\nfunction CM_Add_Empty_Log_Conf; external CfgMgrDllName name 'CM_Add_Empty_Log_Conf';\r\nfunction CM_Add_Empty_Log_Conf_Ex; external CfgMgrDllName name 'CM_Add_Empty_Log_Conf_Ex';\r\nfunction CM_Add_ID; external CfgMgrDllName name 'CM_Add_ID' + NameSuffix;\r\nfunction CM_Add_IDA; external CfgMgrDllName name 'CM_Add_IDA';\r\nfunction CM_Add_IDW; external CfgMgrDllName name 'CM_Add_IDW';\r\nfunction CM_Add_ID_Ex; external CfgMgrDllName name 'CM_Add_ID_Ex' + NameSuffix;\r\nfunction CM_Add_ID_ExA; external CfgMgrDllName name 'CM_Add_ID_ExA';\r\nfunction CM_Add_ID_ExW; external CfgMgrDllName name 'CM_Add_ID_ExW';\r\nfunction CM_Add_Range; external CfgMgrDllName name 'CM_Add_Range';\r\nfunction CM_Add_Res_Des; external CfgMgrDllName name 'CM_Add_Res_Des';\r\nfunction CM_Add_Res_Des_Ex; external CfgMgrDllName name 'CM_Add_Res_Des_Ex';\r\nfunction CM_Connect_Machine; external CfgMgrDllName name 'CM_Connect_Machine' + NameSuffix;\r\nfunction CM_Connect_MachineA; external CfgMgrDllName name 'CM_Connect_MachineA';\r\nfunction CM_Connect_MachineW; external CfgMgrDllName name 'CM_Connect_MachineW';\r\nfunction CM_Create_DevNode; external CfgMgrDllName name 'CM_Create_DevNode' + NameSuffix;\r\nfunction CM_Create_DevNodeA; external CfgMgrDllName name 'CM_Create_DevNodeA';\r\nfunction CM_Create_DevNodeW; external CfgMgrDllName name 'CM_Create_DevNodeW';\r\nfunction CM_Create_DevNode_Ex; external CfgMgrDllName name 'CM_Create_DevNode_Ex' + NameSuffix;\r\nfunction CM_Create_DevNode_ExA; external CfgMgrDllName name 'CM_Create_DevNode_ExA';\r\nfunction CM_Create_DevNode_ExW; external CfgMgrDllName name 'CM_Create_DevNode_ExW';\r\nfunction CM_Create_DevInst; external CfgMgrDllName name 'CM_Create_DevNode' + NameSuffix;\r\nfunction CM_Create_DevInstA; external CfgMgrDllName name 'CM_Create_DevNodeA';\r\nfunction CM_Create_DevInstW; external CfgMgrDllName name 'CM_Create_DevNodeW';\r\nfunction CM_Create_DevInst_Ex; external CfgMgrDllName name 'CM_Create_DevNode_Ex' + NameSuffix;\r\nfunction CM_Create_DevInst_ExA; external CfgMgrDllName name 'CM_Create_DevNode_ExA';\r\nfunction CM_Create_DevInst_ExW; external CfgMgrDllName name 'CM_Create_DevNode_ExW';\r\nfunction CM_Create_Range_List; external CfgMgrDllName name 'CM_Create_Range_List';\r\nfunction CM_Delete_Class_Key; external CfgMgrDllName name 'CM_Delete_Class_Key';\r\nfunction CM_Delete_Class_Key_Ex; external CfgMgrDllName name 'CM_Delete_Class_Key_Ex';\r\nfunction CM_Delete_DevNode_Key; external CfgMgrDllName name 'CM_Delete_DevNode_Key';\r\nfunction CM_Delete_DevNode_Key_Ex; external CfgMgrDllName name 'CM_Delete_DevNode_Key_Ex';\r\nfunction CM_Delete_DevInst_Key; external CfgMgrDllName name 'CM_Delete_DevNode_Key';\r\nfunction CM_Delete_DevInst_Key_Ex; external CfgMgrDllName name 'CM_Delete_DevNode_Key_Ex';\r\nfunction CM_Delete_Range; external CfgMgrDllName name 'CM_Delete_Range';\r\nfunction CM_Detect_Resource_Conflict; external CfgMgrDllName name 'CM_Detect_Resource_Conflict';\r\nfunction CM_Detect_Resource_Conflict_Ex; external CfgMgrDllName name 'CM_Detect_Resource_Conflict_Ex';\r\nfunction CM_Disable_DevNode; external CfgMgrDllName name 'CM_Disable_DevNode';\r\nfunction CM_Disable_DevNode_Ex; external CfgMgrDllName name 'CM_Disable_DevNode_Ex';\r\nfunction CM_Disable_DevInst; external CfgMgrDllName name 'CM_Disable_DevNode';\r\nfunction CM_Disable_DevInst_Ex; external CfgMgrDllName name 'CM_Disable_DevNode_Ex';\r\nfunction CM_Disconnect_Machine; external CfgMgrDllName name 'CM_Disconnect_Machine';\r\nfunction CM_Dup_Range_List; external CfgMgrDllName name 'CM_Dup_Range_List';\r\nfunction CM_Enable_DevNode; external CfgMgrDllName name 'CM_Enable_DevNode';\r\nfunction CM_Enable_DevNode_Ex; external CfgMgrDllName name 'CM_Enable_DevNode_Ex';\r\nfunction CM_Enable_DevInst; external CfgMgrDllName name 'CM_Enable_DevNode';\r\nfunction CM_Enable_DevInst_Ex; external CfgMgrDllName name 'CM_Enable_DevNode_Ex';\r\nfunction CM_Enumerate_Classes; external CfgMgrDllName name 'CM_Enumerate_Classes';\r\nfunction CM_Enumerate_Classes_Ex; external CfgMgrDllName name 'CM_Enumerate_Classes_Ex';\r\nfunction CM_Enumerate_Enumerators; external CfgMgrDllName name 'CM_Enumerate_Enumerators' + NameSuffix;\r\nfunction CM_Enumerate_EnumeratorsA; external CfgMgrDllName name 'CM_Enumerate_EnumeratorsA';\r\nfunction CM_Enumerate_EnumeratorsW; external CfgMgrDllName name 'CM_Enumerate_EnumeratorsW';\r\nfunction CM_Enumerate_Enumerators_Ex; external CfgMgrDllName name 'CM_Enumerate_Enumerators_Ex' + NameSuffix;\r\nfunction CM_Enumerate_Enumerators_ExA; external CfgMgrDllName name 'CM_Enumerate_Enumerators_ExA';\r\nfunction CM_Enumerate_Enumerators_ExW; external CfgMgrDllName name 'CM_Enumerate_Enumerators_ExW';\r\nfunction CM_Find_Range; external CfgMgrDllName name 'CM_Find_Range';\r\nfunction CM_First_Range; external CfgMgrDllName name 'CM_First_Range';\r\nfunction CM_Free_Log_Conf; external CfgMgrDllName name 'CM_Free_Log_Conf';\r\nfunction CM_Free_Log_Conf_Ex; external CfgMgrDllName name 'CM_Free_Log_Conf_Ex';\r\nfunction CM_Free_Log_Conf_Handle; external CfgMgrDllName name 'CM_Free_Log_Conf_Handle';\r\nfunction CM_Free_Range_List; external CfgMgrDllName name 'CM_Free_Range_List';\r\nfunction CM_Free_Res_Des; external CfgMgrDllName name 'CM_Free_Res_Des';\r\nfunction CM_Free_Res_Des_Ex; external CfgMgrDllName name 'CM_Free_Res_Des_Ex';\r\nfunction CM_Free_Res_Des_Handle; external CfgMgrDllName name 'CM_Free_Res_Des_Handle';\r\nfunction CM_Get_Child; external CfgMgrDllName name 'CM_Get_Child';\r\nfunction CM_Get_Child_Ex; external CfgMgrDllName name 'CM_Get_Child_Ex';\r\nfunction CM_Get_Class_Name; external CfgMgrDllName name 'CM_Get_Class_Name' + NameSuffix;\r\nfunction CM_Get_Class_NameA; external CfgMgrDllName name 'CM_Get_Class_NameA';\r\nfunction CM_Get_Class_NameW; external CfgMgrDllName name 'CM_Get_Class_NameW';\r\nfunction CM_Get_Class_Name_Ex; external CfgMgrDllName name 'CM_Get_Class_Name_Ex' + NameSuffix;\r\nfunction CM_Get_Class_Name_ExA; external CfgMgrDllName name 'CM_Get_Class_Name_ExA';\r\nfunction CM_Get_Class_Name_ExW; external CfgMgrDllName name 'CM_Get_Class_Name_ExW';\r\nfunction CM_Get_Class_Key_Name; external CfgMgrDllName name 'CM_Get_Class_Key_Name' + NameSuffix;\r\nfunction CM_Get_Class_Key_NameA; external CfgMgrDllName name 'CM_Get_Class_Key_NameA';\r\nfunction CM_Get_Class_Key_NameW; external CfgMgrDllName name 'CM_Get_Class_Key_NameW';\r\nfunction CM_Get_Class_Key_Name_Ex; external CfgMgrDllName name 'CM_Get_Class_Key_Name_Ex' + NameSuffix;\r\nfunction CM_Get_Class_Key_Name_ExA; external CfgMgrDllName name 'CM_Get_Class_Key_Name_ExA';\r\nfunction CM_Get_Class_Key_Name_ExW; external CfgMgrDllName name 'CM_Get_Class_Key_Name_ExW';\r\nfunction CM_Get_Depth; external CfgMgrDllName name 'CM_Get_Depth';\r\nfunction CM_Get_Depth_Ex; external CfgMgrDllName name 'CM_Get_Depth_Ex';\r\nfunction CM_Get_Device_ID; external CfgMgrDllName name 'CM_Get_Device_ID' + NameSuffix;\r\nfunction CM_Get_Device_IDA; external CfgMgrDllName name 'CM_Get_Device_IDA';\r\nfunction CM_Get_Device_IDW; external CfgMgrDllName name 'CM_Get_Device_IDW';\r\nfunction CM_Get_Device_ID_Ex; external CfgMgrDllName name 'CM_Get_Device_ID_Ex' + NameSuffix;\r\nfunction CM_Get_Device_ID_ExA; external CfgMgrDllName name 'CM_Get_Device_ID_ExA';\r\nfunction CM_Get_Device_ID_ExW; external CfgMgrDllName name 'CM_Get_Device_ID_ExW';\r\nfunction CM_Get_Device_ID_List; external CfgMgrDllName name 'CM_Get_Device_ID_List' + NameSuffix;\r\nfunction CM_Get_Device_ID_ListA; external CfgMgrDllName name 'CM_Get_Device_ID_ListA';\r\nfunction CM_Get_Device_ID_ListW; external CfgMgrDllName name 'CM_Get_Device_ID_ListW';\r\nfunction CM_Get_Device_ID_List_Ex; external CfgMgrDllName name 'CM_Get_Device_ID_List_Ex' + NameSuffix;\r\nfunction CM_Get_Device_ID_List_ExA; external CfgMgrDllName name 'CM_Get_Device_ID_List_ExA';\r\nfunction CM_Get_Device_ID_List_ExW; external CfgMgrDllName name 'CM_Get_Device_ID_List_ExW';\r\nfunction CM_Get_Device_ID_List_Size; external CfgMgrDllName name 'CM_Get_Device_ID_List_Size' + NameSuffix;\r\nfunction CM_Get_Device_ID_List_SizeA; external CfgMgrDllName name 'CM_Get_Device_ID_List_SizeA';\r\nfunction CM_Get_Device_ID_List_SizeW; external CfgMgrDllName name 'CM_Get_Device_ID_List_SizeW';\r\nfunction CM_Get_Device_ID_List_Size_Ex; external CfgMgrDllName name 'CM_Get_Device_ID_List_Size_Ex' + NameSuffix;\r\nfunction CM_Get_Device_ID_List_Size_ExA; external CfgMgrDllName name 'CM_Get_Device_ID_List_Size_ExA';\r\nfunction CM_Get_Device_ID_List_Size_ExW; external CfgMgrDllName name 'CM_Get_Device_ID_List_Size_ExW';\r\nfunction CM_Get_Device_ID_Size; external CfgMgrDllName name 'CM_Get_Device_ID_Size';\r\nfunction CM_Get_Device_ID_Size_Ex; external CfgMgrDllName name 'CM_Get_Device_ID_Size_Ex';\r\nfunction CM_Get_DevNode_Registry_Property; external CfgMgrDllName name 'CM_Get_DevNode_Registry_Property' + NameSuffix;\r\nfunction CM_Get_DevNode_Registry_PropertyA; external CfgMgrDllName name 'CM_Get_DevNode_Registry_PropertyA';\r\nfunction CM_Get_DevNode_Registry_PropertyW; external CfgMgrDllName name 'CM_Get_DevNode_Registry_PropertyW';\r\nfunction CM_Get_DevNode_Registry_Property_Ex; external CfgMgrDllName name 'CM_Get_DevNode_Registry_Property_Ex' + NameSuffix;\r\nfunction CM_Get_DevNode_Registry_Property_ExA; external CfgMgrDllName name 'CM_Get_DevNode_Registry_Property_ExA';\r\nfunction CM_Get_DevNode_Registry_Property_ExW; external CfgMgrDllName name 'CM_Get_DevNode_Registry_Property_ExW';\r\nfunction CM_Get_DevInst_Registry_Property; external CfgMgrDllName name 'CM_Get_DevNode_Registry_Property' + NameSuffix;\r\nfunction CM_Get_DevInst_Registry_PropertyA; external CfgMgrDllName name 'CM_Get_DevNode_Registry_PropertyA';\r\nfunction CM_Get_DevInst_Registry_PropertyW; external CfgMgrDllName name 'CM_Get_DevNode_Registry_PropertyW';\r\nfunction CM_Get_DevInst_Registry_Property_Ex; external CfgMgrDllName name 'CM_Get_DevNode_Registry_Property_Ex' + NameSuffix;\r\nfunction CM_Get_DevInst_Registry_Property_ExA; external CfgMgrDllName name 'CM_Get_DevNode_Registry_Property_ExA';\r\nfunction CM_Get_DevInst_Registry_Property_ExW; external CfgMgrDllName name 'CM_Get_DevNode_Registry_Property_ExW';\r\n{$IFDEF WINXP_UP}\r\nfunction CM_Get_DevNode_Custom_Property; external SetupApiDllName name 'CM_Get_DevNode_Custom_Property' + NameSuffix;\r\nfunction CM_Get_DevNode_Custom_PropertyA; external SetupApiDllName name 'CM_Get_DevNode_Custom_PropertyA';\r\nfunction CM_Get_DevNode_Custom_PropertyW; external SetupApiDllName name 'CM_Get_DevNode_Custom_PropertyW';\r\nfunction CM_Get_DevNode_Custom_Property_Ex; external SetupApiDllName name 'CM_Get_DevNode_Custom_Property_Ex' + NameSuffix;\r\nfunction CM_Get_DevNode_Custom_Property_ExA; external SetupApiDllName name 'CM_Get_DevNode_Custom_Property_ExA';\r\nfunction CM_Get_DevNode_Custom_Property_ExW; external SetupApiDllName name 'CM_Get_DevNode_Custom_Property_ExW';\r\nfunction CM_Get_DevInst_Custom_Property; external SetupApiDllName name 'CM_Get_DevNode_Custom_Property' + NameSuffix;\r\nfunction CM_Get_DevInst_Custom_PropertyA; external SetupApiDllName name 'CM_Get_DevNode_Custom_PropertyA';\r\nfunction CM_Get_DevInst_Custom_PropertyW; external SetupApiDllName name 'CM_Get_DevNode_Custom_PropertyW';\r\nfunction CM_Get_DevInst_Custom_Property_Ex; external SetupApiDllName name 'CM_Get_DevNode_Custom_Property_Ex' + NameSuffix;\r\nfunction CM_Get_DevInst_Custom_Property_ExA; external SetupApiDllName name 'CM_Get_DevNode_Custom_Property_ExA';\r\nfunction CM_Get_DevInst_Custom_Property_ExW; external SetupApiDllName name 'CM_Get_DevNode_Custom_Property_ExW';\r\n{$ENDIF WINXP_UP}\r\nfunction CM_Get_DevNode_Status; external CfgMgrDllName name 'CM_Get_DevNode_Status';\r\nfunction CM_Get_DevInst_Status; external CfgMgrDllName name 'CM_Get_DevNode_Status';\r\nfunction CM_Get_DevNode_Status_Ex; external CfgMgrDllName name 'CM_Get_DevNode_Status_Ex';\r\nfunction CM_Get_DevInst_Status_Ex; external CfgMgrDllName name 'CM_Get_DevNode_Status_Ex';\r\nfunction CM_Get_First_Log_Conf; external CfgMgrDllName name 'CM_Get_First_Log_Conf';\r\nfunction CM_Get_First_Log_Conf_Ex; external CfgMgrDllName name 'CM_Get_First_Log_Conf_Ex';\r\nfunction CM_Get_Global_State; external CfgMgrDllName name 'CM_Get_Global_State';\r\nfunction CM_Get_Global_State_Ex; external CfgMgrDllName name 'CM_Get_Global_State_Ex';\r\nfunction CM_Get_Hardware_Profile_Info; external CfgMgrDllName name 'CM_Get_Hardware_Profile_Info' + NameSuffix;\r\nfunction CM_Get_Hardware_Profile_InfoA; external CfgMgrDllName name 'CM_Get_Hardware_Profile_InfoA';\r\nfunction CM_Get_Hardware_Profile_Info_Ex; external CfgMgrDllName name 'CM_Get_Hardware_Profile_Info_Ex' + NameSuffix;\r\nfunction CM_Get_Hardware_Profile_Info_ExA; external CfgMgrDllName name 'CM_Get_Hardware_Profile_Info_ExA';\r\nfunction CM_Get_Hardware_Profile_InfoW; external CfgMgrDllName name 'CM_Get_Hardware_Profile_InfoW';\r\nfunction CM_Get_Hardware_Profile_Info_ExW; external CfgMgrDllName name 'CM_Get_Hardware_Profile_Info_ExW';\r\nfunction CM_Get_HW_Prof_Flags; external CfgMgrDllName name 'CM_Get_HW_Prof_Flags' + NameSuffix;\r\nfunction CM_Get_HW_Prof_FlagsA; external CfgMgrDllName name 'CM_Get_HW_Prof_FlagsA';\r\nfunction CM_Get_HW_Prof_FlagsW; external CfgMgrDllName name 'CM_Get_HW_Prof_FlagsW';\r\nfunction CM_Get_HW_Prof_Flags_Ex; external CfgMgrDllName name 'CM_Get_HW_Prof_Flags_Ex' + NameSuffix;\r\nfunction CM_Get_HW_Prof_Flags_ExA; external CfgMgrDllName name 'CM_Get_HW_Prof_Flags_ExA';\r\nfunction CM_Get_HW_Prof_Flags_ExW; external CfgMgrDllName name 'CM_Get_HW_Prof_Flags_ExW';\r\n{$IFNDEF WINNT4}\r\nfunction CM_Get_Device_Interface_Alias; external CfgMgrDllName name 'CM_Get_Device_Interface_Alias' + NameSuffix;\r\nfunction CM_Get_Device_Interface_AliasA; external CfgMgrDllName name 'CM_Get_Device_Interface_AliasA';\r\nfunction CM_Get_Device_Interface_AliasW; external CfgMgrDllName name 'CM_Get_Device_Interface_AliasW';\r\nfunction CM_Get_Device_Interface_Alias_Ex; external CfgMgrDllName name 'CM_Get_Device_Interface_Alias_Ex' + NameSuffix;\r\nfunction CM_Get_Device_Interface_Alias_ExA; external CfgMgrDllName name 'CM_Get_Device_Interface_Alias_ExA';\r\nfunction CM_Get_Device_Interface_Alias_ExW; external CfgMgrDllName name 'CM_Get_Device_Interface_Alias_ExW';\r\nfunction CM_Get_Device_Interface_List; external CfgMgrDllName name 'CM_Get_Device_Interface_List' + NameSuffix;\r\nfunction CM_Get_Device_Interface_ListA; external CfgMgrDllName name 'CM_Get_Device_Interface_ListA';\r\nfunction CM_Get_Device_Interface_ListW; external CfgMgrDllName name 'CM_Get_Device_Interface_ListW';\r\nfunction CM_Get_Device_Interface_List_Ex; external CfgMgrDllName name 'CM_Get_Device_Interface_List_Ex' + NameSuffix;\r\nfunction CM_Get_Device_Interface_List_ExA; external CfgMgrDllName name 'CM_Get_Device_Interface_List_ExA';\r\nfunction CM_Get_Device_Interface_List_ExW; external CfgMgrDllName name 'CM_Get_Device_Interface_List_ExW';\r\nfunction CM_Get_Device_Interface_List_Size; external CfgMgrDllName name 'CM_Get_Device_Interface_List_Size' + NameSuffix;\r\nfunction CM_Get_Device_Interface_List_SizeA; external CfgMgrDllName name 'CM_Get_Device_Interface_List_SizeA';\r\nfunction CM_Get_Device_Interface_List_SizeW; external CfgMgrDllName name 'CM_Get_Device_Interface_List_SizeW';\r\nfunction CM_Get_Device_Interface_List_Size_Ex; external CfgMgrDllName name 'CM_Get_Device_Interface_List_Size_Ex' + NameSuffix;\r\nfunction CM_Get_Device_Interface_List_Size_ExA; external CfgMgrDllName name 'CM_Get_Device_Interface_List_Size_ExA';\r\nfunction CM_Get_Device_Interface_List_Size_ExW; external CfgMgrDllName name 'CM_Get_Device_Interface_List_Size_ExW';\r\nfunction CM_Get_Log_Conf_Priority; external CfgMgrDllName name 'CM_Get_Log_Conf_Priority';\r\nfunction CM_Get_Log_Conf_Priority_Ex; external CfgMgrDllName name 'CM_Get_Log_Conf_Priority_Ex';\r\n{$ENDIF !WINNT4}\r\nfunction CM_Get_Next_Log_Conf; external CfgMgrDllName name 'CM_Get_Next_Log_Conf';\r\nfunction CM_Get_Next_Log_Conf_Ex; external CfgMgrDllName name 'CM_Get_Next_Log_Conf_Ex';\r\nfunction CM_Get_Parent; external CfgMgrDllName name 'CM_Get_Parent';\r\nfunction CM_Get_Parent_Ex; external CfgMgrDllName name 'CM_Get_Parent_Ex';\r\nfunction CM_Get_Res_Des_Data; external CfgMgrDllName name 'CM_Get_Res_Des_Data';\r\nfunction CM_Get_Res_Des_Data_Ex; external CfgMgrDllName name 'CM_Get_Res_Des_Data_Ex';\r\nfunction CM_Get_Res_Des_Data_Size; external CfgMgrDllName name 'CM_Get_Res_Des_Data_Size';\r\nfunction CM_Get_Res_Des_Data_Size_Ex; external CfgMgrDllName name 'CM_Get_Res_Des_Data_Size_Ex';\r\nfunction CM_Get_Sibling; external CfgMgrDllName name 'CM_Get_Sibling';\r\nfunction CM_Get_Sibling_Ex; external CfgMgrDllName name 'CM_Get_Sibling_Ex';\r\nfunction CM_Get_Version; external CfgMgrDllName name 'CM_Get_Version';\r\nfunction CM_Get_Version_Ex; external CfgMgrDllName name 'CM_Get_Version_Ex';\r\n{$IFDEF WINXP_UP}\r\nfunction CM_Is_Version_Available; external SetupApiDllName name 'CM_Is_Version_Available';\r\nfunction CM_Is_Version_Available_Ex; external SetupApiDllName name 'CM_Is_Version_Available_Ex';\r\n{$ENDIF WINXP_UP}\r\nfunction CM_Intersect_Range_List; external CfgMgrDllName name 'CM_Intersect_Range_List';\r\nfunction CM_Invert_Range_List; external CfgMgrDllName name 'CM_Invert_Range_List';\r\nfunction CM_Locate_DevNode; external CfgMgrDllName name 'CM_Locate_DevNode' + NameSuffix;\r\nfunction CM_Locate_DevNodeA; external CfgMgrDllName name 'CM_Locate_DevNodeA';\r\nfunction CM_Locate_DevNodeW; external CfgMgrDllName name 'CM_Locate_DevNodeW';\r\nfunction CM_Locate_DevNode_Ex; external CfgMgrDllName name 'CM_Locate_DevNode_Ex' + NameSuffix;\r\nfunction CM_Locate_DevNode_ExA; external CfgMgrDllName name 'CM_Locate_DevNode_ExA';\r\nfunction CM_Locate_DevNode_ExW; external CfgMgrDllName name 'CM_Locate_DevNode_ExW';\r\nfunction CM_Locate_DevInst; external CfgMgrDllName name 'CM_Locate_DevNode' + NameSuffix;\r\nfunction CM_Locate_DevInstA; external CfgMgrDllName name 'CM_Locate_DevNodeA';\r\nfunction CM_Locate_DevInstW; external CfgMgrDllName name 'CM_Locate_DevNodeW';\r\nfunction CM_Locate_DevInst_Ex; external CfgMgrDllName name 'CM_Locate_DevNode_Ex' + NameSuffix;\r\nfunction CM_Locate_DevInst_ExA; external CfgMgrDllName name 'CM_Locate_DevNode_ExA';\r\nfunction CM_Locate_DevInst_ExW; external CfgMgrDllName name 'CM_Locate_DevNode_ExW';\r\nfunction CM_Merge_Range_List; external CfgMgrDllName name 'CM_Merge_Range_List';\r\nfunction CM_Modify_Res_Des; external CfgMgrDllName name 'CM_Modify_Res_Des';\r\nfunction CM_Modify_Res_Des_Ex; external CfgMgrDllName name 'CM_Modify_Res_Des_Ex';\r\nfunction CM_Move_DevNode; external CfgMgrDllName name 'CM_Move_DevNode';\r\nfunction CM_Move_DevInst; external CfgMgrDllName name 'CM_Move_DevNode';\r\nfunction CM_Move_DevNode_Ex; external CfgMgrDllName name 'CM_Move_DevNode_Ex';\r\nfunction CM_Move_DevInst_Ex; external CfgMgrDllName name 'CM_Move_DevNode_Ex';\r\nfunction CM_Next_Range; external CfgMgrDllName name 'CM_Next_Range';\r\nfunction CM_Get_Next_Res_Des; external CfgMgrDllName name 'CM_Get_Next_Res_Des';\r\nfunction CM_Get_Next_Res_Des_Ex; external CfgMgrDllName name 'CM_Get_Next_Res_Des_Ex';\r\nfunction CM_Open_Class_Key; external CfgMgrDllName name 'CM_Open_Class_Key' + NameSuffix;\r\nfunction CM_Open_Class_KeyA; external CfgMgrDllName name 'CM_Open_Class_KeyA';\r\nfunction CM_Open_Class_KeyW; external CfgMgrDllName name 'CM_Open_Class_KeyW';\r\nfunction CM_Open_Class_Key_Ex; external CfgMgrDllName name 'CM_Open_Class_Key_Ex' + NameSuffix;\r\nfunction CM_Open_Class_Key_ExA; external CfgMgrDllName name 'CM_Open_Class_Key_ExA';\r\nfunction CM_Open_Class_Key_ExW; external CfgMgrDllName name 'CM_Open_Class_Key_ExW';\r\nfunction CM_Open_DevNode_Key; external CfgMgrDllName name 'CM_Open_DevNode_Key';\r\nfunction CM_Open_DevInst_Key; external CfgMgrDllName name 'CM_Open_DevNode_Key';\r\nfunction CM_Open_DevNode_Key_Ex; external CfgMgrDllName name 'CM_Open_DevNode_Key_Ex';\r\nfunction CM_Open_DevInst_Key_Ex; external CfgMgrDllName name 'CM_Open_DevNode_Key_Ex';\r\nfunction CM_Query_Arbitrator_Free_Data; external CfgMgrDllName name 'CM_Query_Arbitrator_Free_Data';\r\nfunction CM_Query_Arbitrator_Free_Data_Ex; external CfgMgrDllName name 'CM_Query_Arbitrator_Free_Data_Ex';\r\nfunction CM_Query_Arbitrator_Free_Size; external CfgMgrDllName name 'CM_Query_Arbitrator_Free_Size';\r\nfunction CM_Query_Arbitrator_Free_Size_Ex; external CfgMgrDllName name 'CM_Query_Arbitrator_Free_Size_Ex';\r\nfunction CM_Query_Remove_SubTree; external CfgMgrDllName name 'CM_Query_Remove_SubTree';\r\nfunction CM_Query_Remove_SubTree_Ex; external CfgMgrDllName name 'CM_Query_Remove_SubTree_Ex';\r\n{$IFDEF WIN2000_UP}\r\nfunction CM_Query_And_Remove_SubTree; external CfgMgrDllName name 'CM_Query_And_Remove_SubTree' + NameSuffix;\r\nfunction CM_Query_And_Remove_SubTreeA; external CfgMgrDllName name 'CM_Query_And_Remove_SubTreeA';\r\nfunction CM_Query_And_Remove_SubTree_Ex; external CfgMgrDllName name 'CM_Query_And_Remove_SubTree_Ex' + NameSuffix;\r\nfunction CM_Query_And_Remove_SubTree_ExA; external CfgMgrDllName name 'CM_Query_And_Remove_SubTree_ExA';\r\nfunction CM_Query_And_Remove_SubTreeW; external CfgMgrDllName name 'CM_Query_And_Remove_SubTreeW';\r\nfunction CM_Query_And_Remove_SubTree_ExW; external CfgMgrDllName name 'CM_Query_And_Remove_SubTree_ExW';\r\nfunction CM_Request_Device_Eject; external SetupApiDllName name 'CM_Request_Device_Eject' + NameSuffix;\r\nfunction CM_Request_Device_EjectA; external SetupApiDllName name 'CM_Request_Device_EjectA';\r\nfunction CM_Request_Device_EjectW; external SetupApiDllName name 'CM_Request_Device_EjectW';\r\nfunction CM_Request_Device_Eject_Ex; external SetupApiDllName name 'CM_Request_Device_Eject_Ex' + NameSuffix;\r\nfunction CM_Request_Device_Eject_ExA; external SetupApiDllName name 'CM_Request_Device_Eject_ExA';\r\nfunction CM_Request_Device_Eject_ExW; external SetupApiDllName name 'CM_Request_Device_Eject_ExW';\r\n{$ENDIF WIN2000_UP}\r\nfunction CM_Reenumerate_DevNode; external CfgMgrDllName name 'CM_Reenumerate_DevNode';\r\nfunction CM_Reenumerate_DevInst; external CfgMgrDllName name 'CM_Reenumerate_DevNode';\r\nfunction CM_Reenumerate_DevNode_Ex; external CfgMgrDllName name 'CM_Reenumerate_DevNode_Ex';\r\nfunction CM_Reenumerate_DevInst_Ex; external CfgMgrDllName name 'CM_Reenumerate_DevNode_Ex';\r\n{$IFNDEF WINNT4}\r\nfunction CM_Register_Device_Interface; external CfgMgrDllName name 'CM_Register_Device_Interface' + NameSuffix;\r\nfunction CM_Register_Device_InterfaceA; external CfgMgrDllName name 'CM_Register_Device_InterfaceA';\r\nfunction CM_Register_Device_InterfaceW; external CfgMgrDllName name 'CM_Register_Device_InterfaceW';\r\nfunction CM_Register_Device_Interface_Ex; external CfgMgrDllName name 'CM_Register_Device_Interface_Ex' + NameSuffix;\r\nfunction CM_Register_Device_Interface_ExA; external CfgMgrDllName name 'CM_Register_Device_Interface_ExA';\r\nfunction CM_Register_Device_Interface_ExW; external CfgMgrDllName name 'CM_Register_Device_Interface_ExW';\r\nfunction CM_Set_DevNode_Problem_Ex; external CfgMgrDllName name 'CM_Set_DevNode_Problem_Ex';\r\nfunction CM_Set_DevInst_Problem_Ex; external CfgMgrDllName name 'CM_Set_DevNode_Problem_Ex';\r\nfunction CM_Set_DevNode_Problem; external CfgMgrDllName name 'CM_Set_DevNode_Problem';\r\nfunction CM_Set_DevInst_Problem; external CfgMgrDllName name 'CM_Set_DevNode_Problem';\r\nfunction CM_Unregister_Device_Interface; external CfgMgrDllName name 'CM_Unregister_Device_Interface' + NameSuffix;\r\nfunction CM_Unregister_Device_InterfaceA; external CfgMgrDllName name 'CM_Unregister_Device_InterfaceA';\r\nfunction CM_Unregister_Device_InterfaceW; external CfgMgrDllName name 'CM_Unregister_Device_InterfaceW';\r\nfunction CM_Unregister_Device_Interface_Ex; external CfgMgrDllName name 'CM_Unregister_Device_Interface_Ex' + NameSuffix;\r\nfunction CM_Unregister_Device_Interface_ExA; external CfgMgrDllName name 'CM_Unregister_Device_Interface_ExA';\r\nfunction CM_Unregister_Device_Interface_ExW; external CfgMgrDllName name 'CM_Unregister_Device_Interface_ExW';\r\nfunction CM_Register_Device_Driver; external CfgMgrDllName name 'CM_Register_Device_Driver';\r\nfunction CM_Register_Device_Driver_Ex; external CfgMgrDllName name 'CM_Register_Device_Driver_Ex';\r\n{$ENDIF !WINNT4}\r\nfunction CM_Remove_SubTree; external CfgMgrDllName name 'CM_Remove_SubTree';\r\nfunction CM_Remove_SubTree_Ex; external CfgMgrDllName name 'CM_Remove_SubTree_Ex';\r\nfunction CM_Set_DevNode_Registry_Property; external CfgMgrDllName name 'CM_Set_DevNode_Registry_Property' + NameSuffix;\r\nfunction CM_Set_DevNode_Registry_PropertyA; external CfgMgrDllName name 'CM_Set_DevNode_Registry_PropertyA';\r\nfunction CM_Set_DevNode_Registry_PropertyW; external CfgMgrDllName name 'CM_Set_DevNode_Registry_PropertyW';\r\nfunction CM_Set_DevNode_Registry_Property_Ex; external CfgMgrDllName name 'CM_Set_DevNode_Registry_Property_Ex' + NameSuffix;\r\nfunction CM_Set_DevNode_Registry_Property_ExA; external CfgMgrDllName name 'CM_Set_DevNode_Registry_Property_ExA';\r\nfunction CM_Set_DevNode_Registry_Property_ExW; external CfgMgrDllName name 'CM_Set_DevNode_Registry_Property_ExW';\r\nfunction CM_Set_DevInst_Registry_Property; external CfgMgrDllName name 'CM_Set_DevNode_Registry_Property' + NameSuffix;\r\nfunction CM_Set_DevInst_Registry_PropertyA; external CfgMgrDllName name 'CM_Set_DevNode_Registry_PropertyA';\r\nfunction CM_Set_DevInst_Registry_PropertyW; external CfgMgrDllName name 'CM_Set_DevNode_Registry_PropertyW';\r\nfunction CM_Set_DevInst_Registry_Property_Ex; external CfgMgrDllName name 'CM_Set_DevNode_Registry_Property_Ex' + NameSuffix;\r\nfunction CM_Set_DevInst_Registry_Property_ExA; external CfgMgrDllName name 'CM_Set_DevNode_Registry_Property_ExA';\r\nfunction CM_Set_DevInst_Registry_Property_ExW; external CfgMgrDllName name 'CM_Set_DevNode_Registry_Property_ExW';\r\n{$IFNDEF WINNT4}\r\nfunction CM_Is_Dock_Station_Present; external CfgMgrDllName name 'CM_Is_Dock_Station_Present';\r\n{$ENDIF !WINNT4}\r\n{$IFDEF WIN2000_UP}\r\nfunction CM_Is_Dock_Station_Present_Ex; external CfgMgrDllName name 'CM_Is_Dock_Station_Present_Ex';\r\n{$ENDIF WIN2000_UP}\r\n{$IFNDEF WINNT4}\r\nfunction CM_Request_Eject_PC; external CfgMgrDllName name 'CM_Request_Eject_PC';\r\n{$ENDIF !WINNT4}\r\n{$IFDEF WIN2000_UP}\r\nfunction CM_Request_Eject_PC_Ex; external CfgMgrDllName name 'CM_Request_Eject_PC_Ex';\r\n{$ENDIF WIN2000_UP}\r\nfunction CM_Set_HW_Prof_Flags; external CfgMgrDllName name 'CM_Set_HW_Prof_Flags' + NameSuffix;\r\nfunction CM_Set_HW_Prof_FlagsA; external CfgMgrDllName name 'CM_Set_HW_Prof_FlagsA';\r\nfunction CM_Set_HW_Prof_FlagsW; external CfgMgrDllName name 'CM_Set_HW_Prof_FlagsW';\r\nfunction CM_Set_HW_Prof_Flags_Ex; external CfgMgrDllName name 'CM_Set_HW_Prof_Flags_Ex' + NameSuffix;\r\nfunction CM_Set_HW_Prof_Flags_ExA; external CfgMgrDllName name 'CM_Set_HW_Prof_Flags_ExA';\r\nfunction CM_Set_HW_Prof_Flags_ExW; external CfgMgrDllName name 'CM_Set_HW_Prof_Flags_ExW';\r\nfunction CM_Setup_DevNode; external CfgMgrDllName name 'CM_Setup_DevNode';\r\nfunction CM_Setup_DevInst; external CfgMgrDllName name 'CM_Setup_DevNode';\r\nfunction CM_Setup_DevNode_Ex; external CfgMgrDllName name 'CM_Setup_DevNode_Ex';\r\nfunction CM_Setup_DevInst_Ex; external CfgMgrDllName name 'CM_Setup_DevNode_Ex';\r\nfunction CM_Test_Range_Available; external CfgMgrDllName name 'CM_Test_Range_Available';\r\nfunction CM_Uninstall_DevNode; external CfgMgrDllName name 'CM_Uninstall_DevNode';\r\nfunction CM_Uninstall_DevInst; external CfgMgrDllName name 'CM_Uninstall_DevNode';\r\nfunction CM_Uninstall_DevNode_Ex; external CfgMgrDllName name 'CM_Uninstall_DevNode_Ex';\r\nfunction CM_Uninstall_DevInst_Ex; external CfgMgrDllName name 'CM_Uninstall_DevNode_Ex';\r\nfunction CM_Run_Detection; external CfgMgrDllName name 'CM_Run_Detection';\r\nfunction CM_Run_Detection_Ex; external CfgMgrDllName name 'CM_Run_Detection_Ex';\r\nfunction CM_Set_HW_Prof; external CfgMgrDllName name 'CM_Set_HW_Prof';\r\nfunction CM_Set_HW_Prof_Ex; external CfgMgrDllName name 'CM_Set_HW_Prof_Ex';\r\n{$IFDEF WIN2000_UP}\r\nfunction CM_Query_Resource_Conflict_List; external CfgMgrDllName name 'CM_Query_Resource_Conflict_List';\r\nfunction CM_Free_Resource_Conflict_Handle; external CfgMgrDllName name 'CM_Free_Resource_Conflict_Handle';\r\nfunction CM_Get_Resource_Conflict_Count; external CfgMgrDllName name 'CM_Get_Resource_Conflict_Count';\r\nfunction CM_Get_Resource_Conflict_Details; external CfgMgrDllName name 'CM_Get_Resource_Conflict_Details' + NameSuffix;\r\nfunction CM_Get_Resource_Conflict_DetailsA; external CfgMgrDllName name 'CM_Get_Resource_Conflict_DetailsA';\r\nfunction CM_Get_Resource_Conflict_DetailsW; external CfgMgrDllName name 'CM_Get_Resource_Conflict_DetailsW';\r\nfunction CM_Get_Class_Registry_Property; external CfgMgrDllName name 'CM_Get_Class_Registry_Property' + NameSuffix;\r\nfunction CM_Get_Class_Registry_PropertyA; external CfgMgrDllName name 'CM_Get_Class_Registry_PropertyA';\r\nfunction CM_Get_Class_Registry_PropertyW; external CfgMgrDllName name 'CM_Get_Class_Registry_PropertyW';\r\nfunction CM_Set_Class_Registry_Property; external CfgMgrDllName name 'CM_Set_Class_Registry_Property' + NameSuffix;\r\nfunction CM_Set_Class_Registry_PropertyA; external CfgMgrDllName name 'CM_Set_Class_Registry_PropertyA';\r\nfunction CM_Set_Class_Registry_PropertyW; external CfgMgrDllName name 'CM_Set_Class_Registry_PropertyW';\r\nfunction CM_WaitNoPendingInstallEvents; external CfgMgrDllName name 'CMP_WaitNoPendingInstallEvents';\r\nfunction CMP_WaitNoPendingInstallEvents; external CfgMgrDllName name 'CMP_WaitNoPendingInstallEvents';\r\n{$ENDIF WIN2000_UP}\r\n\r\n{$ENDIF !CFGMGR32_LINKONREQUEST}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/DBT.pas", "content": "{******************************************************************}\r\n{ }\r\n{ Borland Delphi Runtime Library }\r\n{ interface unit }\r\n{ }\r\n{ Portions created by Microsoft are }\r\n{ Copyright (C) 1993-1998 Microsoft Corporation. }\r\n{ All Rights Reserved. }\r\n{ }\r\n{ The original file is: dbt.h, released 24 May 1993 }\r\n{ The original Pascal code is: dbt.pas, released 01 Jan 1998 }\r\n{ The initial developer of the Pascal code is Tom Deprez }\r\n{ (Tom.Deprez@village.uunet.be) }\r\n{ }\r\n{ Portions created by Tom Deprez are }\r\n{ Copyright (C) 1999-2000 Tom Deprez. }\r\n{ }\r\n{ Contributor(s): }\r\n{ Robert Marquardt : pointed out that TWMDeviceChange }\r\n{ is better placed inside dbt.pas }\r\n{ }\r\n{ }\r\n{ Obtained through: }\r\n{ }\r\n{ Joint Endeavour of Delphi Innovators (Project JEDI) }\r\n{ }\r\n{ You may retrieve the latest version of this file at the Project }\r\n{ JEDI home page, located at http://delphi-jedi.org }\r\n{ }\r\n{ The contents of this file are used with permission, subject to }\r\n{ the Mozilla Public License Version 1.1 (the \"License\"); you may }\r\n{ not use this file except in compliance with the License. You may }\r\n{ obtain a copy of the License at }\r\n{ http://www.mozilla.org/MPL/MPL-1.1.html }\r\n{ }\r\n{ Software distributed under the License is distributed on an }\r\n{ \"AS IS\" basis, WITHOUT WARRANTY OF ANY KIND, either express or }\r\n{ implied. See the License for the specific language governing }\r\n{ rights and limitations under the License. }\r\n{ }\r\n{******************************************************************}\r\n\r\nunit DBT;\r\n\r\n{$I jvcl.inc}\r\n\r\n{$WEAKPACKAGEUNIT ON}\r\n\r\ninterface\r\n\r\n(*$HPPEMIT '' *)\r\n(*$HPPEMIT '#include ' *)\r\n(*$HPPEMIT '' *)\r\n\r\nuses\r\n Windows, Messages;\r\n\r\n{ *\r\n * BroadcastSpecialMessage constants\r\n * }\r\n\r\nconst\r\n {$EXTERNALSYM WM_DEVICECHANGE}\r\n WM_DEVICECHANGE = $0219;\r\n\r\n\r\n{ *\r\n * Broadcast message and receipient flags.\r\n *\r\n * Note that there is a third \"flag\". If the wParam has:\r\n *\r\n * bit 15 on: lparam is a pointer and bit 14 is meaningfull.\r\n * bit 15 off: lparam is just a UNLONG data type.\r\n *\r\n * bit 14 on: lparam is a pointer to an ASCIIZ string.\r\n * bit 14 off: lparam is a pointer to a binary struture starting with\r\n * a dword describing the length of the structure.\r\n * }\r\n\r\nconst\r\n {$EXTERNALSYM BSF_QUERY}\r\n BSF_QUERY = $00000001;\r\n {$EXTERNALSYM BSF_IGNORECURRENTTASK}\r\n BSF_IGNORECURRENTTASK = $00000002; { Meaningless for VxDs }\r\n {$EXTERNALSYM BSF_FLUSHDISK}\r\n BSF_FLUSHDISK = $00000004; { Shouldn't be used by VxDs }\r\n {$EXTERNALSYM BSF_NOHANG}\r\n BSF_NOHANG = $00000008;\r\n {$EXTERNALSYM BSF_POSTMESSAGE}\r\n BSF_POSTMESSAGE = $00000010;\r\n {$EXTERNALSYM BSF_FORCEIFHUNG}\r\n BSF_FORCEIFHUNG = $00000020;\r\n {$EXTERNALSYM BSF_NOTIMEOUTIFNOTHUNG}\r\n BSF_NOTIMEOUTIFNOTHUNG = $00000040;\r\n {$EXTERNALSYM BSF_MSGSRV32ISOK}\r\n BSF_MSGSRV32ISOK = DWORD($80000000); { Called synchronously from PM API }\r\n {$EXTERNALSYM BSF_MSGSRV32ISOK_BIT}\r\n BSF_MSGSRV32ISOK_BIT = 31; { Called synchronously from PM API }\r\n {$EXTERNALSYM BSM_ALLCOMPONENTS}\r\n BSM_ALLCOMPONENTS = $00000000;\r\n {$EXTERNALSYM BSM_VXDS}\r\n BSM_VXDS = $00000001;\r\n {$EXTERNALSYM BSM_NETDRIVER}\r\n BSM_NETDRIVER = $00000002;\r\n {$EXTERNALSYM BSM_INSTALLABLEDRIVERS}\r\n BSM_INSTALLABLEDRIVERS = $00000004;\r\n {$EXTERNALSYM BSM_APPLICATIONS}\r\n BSM_APPLICATIONS = $00000008;\r\n\r\n\r\n{ *\r\n * Message = WM_DEVICECHANGE\r\n * wParam = DBT_APPYBEGIN\r\n * lParam = (not used)\r\n *\r\n * 'Appy-time is now available. This message is itself sent\r\n * at 'Appy-time.\r\n *\r\n * Message = WM_DEVICECHANGE\r\n * wParam = DBT_APPYEND\r\n * lParam = (not used)\r\n *\r\n * 'Appy-time is no longer available. This message is*NOT* sent\r\n * at 'Appy-time. (It cannot be, because 'Appy-time is gone.)\r\n *\r\n * NOTE! It is possible for DBT_APPYBEGIN and DBT_APPYEND to be sent\r\n * multiple times during a single Windows session. Each appearance of\r\n * 'Appy-time is bracketed by these two messages, but 'Appy-time may\r\n * momentarily become unavailable during otherwise normal Windows\r\n * processing. The current status of 'Appy-time availability can always\r\n * be obtained from a call to _SHELL_QueryAppyTimeAvailable.\r\n * }\r\n\r\nconst\r\n {$EXTERNALSYM DBT_APPYBEGIN}\r\n DBT_APPYBEGIN = $0000;\r\n {$EXTERNALSYM DBT_APPYEND}\r\n DBT_APPYEND = $0001;\r\n\r\n\r\n{ *\r\n * Message = WM_DEVICECHANGE\r\n * wParam = DBT_DEVNODES_CHANGED\r\n * lParam = 0\r\n *\r\n * send when configmg finished a process tree batch. Some devnodes\r\n * may have been added or removed. This is used by ring3 people which\r\n * need to be refreshed whenever any devnode changed occur (like\r\n * device manager). People specific to certain devices should use\r\n * DBT_DEVICE* instead.\r\n * }\r\n\r\nconst\r\n {$EXTERNALSYM DBT_DEVNODES_CHANGED}\r\n DBT_DEVNODES_CHANGED = $0007;\r\n\r\n\r\n{ *\r\n * Message = WM_DEVICECHANGE\r\n * wParam = DBT_QUERYCHANGECONFIG\r\n * lParam = 0\r\n *\r\n * sent to ask if a config change is allowed\r\n * }\r\n\r\nconst\r\n {$EXTERNALSYM DBT_QUERYCHANGECONFIG}\r\n DBT_QUERYCHANGECONFIG = $0017;\r\n\r\n\r\n{ *\r\n * Message = WM_DEVICECHANGE\r\n * wParam = DBT_CONFIGCHANGED\r\n * lParam = 0\r\n *\r\n * sent when a config has changed\r\n * }\r\n\r\nconst\r\n {$EXTERNALSYM DBT_CONFIGCHANGED}\r\n DBT_CONFIGCHANGED = $0018;\r\n\r\n\r\n{ *\r\n * Message = WM_DEVICECHANGE\r\n * wParam = DBT_CONFIGCHANGECANCELED\r\n * lParam = 0\r\n *\r\n * someone cancelled the config change\r\n * }\r\n\r\nconst\r\n {$EXTERNALSYM DBT_CONFIGCHANGECANCELED}\r\n DBT_CONFIGCHANGECANCELED = $0019;\r\n\r\n\r\n{ *\r\n * Message = WM_DEVICECHANGE\r\n * wParam = DBT_MONITORCHANGE\r\n * lParam = new resolution to use (LOWORD=x, HIWORD=y)\r\n * if 0, use the default res for current config\r\n *\r\n * this message is sent when the display monitor has changed\r\n * and the system should change the display mode to match it.\r\n * }\r\n\r\nconst\r\n {$EXTERNALSYM DBT_MONITORCHANGE}\r\n DBT_MONITORCHANGE = $001B;\r\n\r\n\r\n{ *\r\n * Message = WM_DEVICECHANGE\r\n * wParam = DBT_SHELLLOGGEDON\r\n * lParam = 0\r\n *\r\n * The shell has finished login on: VxD can now do Shell_EXEC.\r\n * }\r\n\r\nconst\r\n {$EXTERNALSYM DBT_SHELLLOGGEDON}\r\n DBT_SHELLLOGGEDON = $0020;\r\n\r\n\r\n{ *\r\n * Message = WM_DEVICECHANGE\r\n * wParam = DBT_CONFIGMGAPI\r\n * lParam = CONFIGMG API Packet\r\n *\r\n * CONFIGMG ring 3 call.\r\n * }\r\n\r\nconst\r\n {$EXTERNALSYM DBT_CONFIGMGAPI32}\r\n DBT_CONFIGMGAPI32 = $0022;\r\n\r\n\r\n{ *\r\n * Message = WM_DEVICECHANGE\r\n * wParam = DBT_VXDINITCOMPLETE\r\n * lParam = 0\r\n *\r\n * CONFIGMG ring 3 call.\r\n * }\r\n\r\nconst\r\n {$EXTERNALSYM DBT_VXDINITCOMPLETE}\r\n DBT_VXDINITCOMPLETE = $0023;\r\n\r\n\r\n{ *\r\n * Message = WM_DEVICECHANGE\r\n * wParam = DBT_VOLLOCK*\r\n * lParam = pointer to VolLockBroadcast structure described below\r\n *\r\n * Messages issued by IFSMGR for volume locking purposes on WM_DEVICECHANGE.\r\n * All these messages pass a pointer to a struct which has no pointers.\r\n * }\r\n\r\nconst\r\n {$EXTERNALSYM DBT_VOLLOCKQUERYLOCK}\r\n DBT_VOLLOCKQUERYLOCK = $8041;\r\n {$EXTERNALSYM DBT_VOLLOCKLOCKTAKEN}\r\n DBT_VOLLOCKLOCKTAKEN = $8042;\r\n {$EXTERNALSYM DBT_VOLLOCKLOCKFAILED}\r\n DBT_VOLLOCKLOCKFAILED = $8043;\r\n {$EXTERNALSYM DBT_VOLLOCKQUERYUNLOCK}\r\n DBT_VOLLOCKQUERYUNLOCK = $8044;\r\n {$EXTERNALSYM DBT_VOLLOCKLOCKRELEASED}\r\n DBT_VOLLOCKLOCKRELEASED = $8045;\r\n {$EXTERNALSYM DBT_VOLLOCKUNLOCKFAILED}\r\n DBT_VOLLOCKUNLOCKFAILED = $8046;\r\n\r\n\r\n{ *\r\n * Device broadcast header\r\n * }\r\n\r\ntype\r\n PDevBroadcastHdr = ^TDevBroadcastHdr;\r\n {$EXTERNALSYM DEV_BROADCAST_HDR}\r\n DEV_BROADCAST_HDR = record\r\n dbch_size: DWORD;\r\n dbch_devicetype: DWORD;\r\n dbch_reserved: DWORD;\r\n end;\r\n TDevBroadcastHdr = DEV_BROADCAST_HDR;\r\n\r\n\r\n{ *\r\n * Structure for volume lock broadcast\r\n * }\r\n\r\ntype\r\n PVolLockBroadcast = ^TVolLockBroadcast;\r\n {$EXTERNALSYM VolLockBroadcast}\r\n VolLockBroadcast = record\r\n vlb_dbh: TDevBroadcastHdr;\r\n vlb_owner: DWORD;\r\n vlb_perms: Byte;\r\n vlb_lockType: Byte;\r\n vlb_drive: Byte;\r\n vlb_flags: Byte;\r\n end;\r\n TVolLockBroadcast = VolLockBroadcast;\r\n\r\n{ *\r\n * Values for vlb_perms\r\n * }\r\n\r\nconst\r\n {$EXTERNALSYM LOCKP_ALLOW_WRITES}\r\n LOCKP_ALLOW_WRITES = $01; { Bit 0 set - allow writes }\r\n {$EXTERNALSYM LOCKP_FAIL_WRITES}\r\n LOCKP_FAIL_WRITES = $00; { Bit 0 clear - fail writes }\r\n {$EXTERNALSYM LOCKP_FAIL_MEM_MAPPING}\r\n LOCKP_FAIL_MEM_MAPPING = $02; { Bit 1 set - fail memory mappings }\r\n {$EXTERNALSYM LOCKP_ALLOW_MEM_MAPPING}\r\n LOCKP_ALLOW_MEM_MAPPING = $00; { Bit 1 clear - allow memory mappings }\r\n {$EXTERNALSYM LOCKP_USER_MASK}\r\n LOCKP_USER_MASK = $03; { Mask for user lock flags }\r\n {$EXTERNALSYM LOCKP_LOCK_FOR_FORMAT}\r\n LOCKP_LOCK_FOR_FORMAT = $04; { Level 0 lock for format }\r\n\r\n{ *\r\n * Values for vlb_flags\r\n * }\r\n\r\nconst\r\n {$EXTERNALSYM LOCKF_LOGICAL_LOCK}\r\n LOCKF_LOGICAL_LOCK = $00; { Bit 0 clear - logical lock }\r\n {$EXTERNALSYM LOCKF_PHYSICAL_LOCK}\r\n LOCKF_PHYSICAL_LOCK = $01; { Bit 0 set - physical lock }\r\n\r\n{ *\r\n * Message = WM_DEVICECHANGE\r\n * wParam = DBT_NODISKSPACE\r\n * lParam = drive number of drive that is out of disk space (1-based)\r\n *\r\n * Message issued by IFS manager when it detects that a drive is run out of\r\n * free space.\r\n * }\r\n\r\nconst\r\n {$EXTERNALSYM DBT_NO_DISK_SPACE}\r\n DBT_NO_DISK_SPACE = $0047;\r\n\r\n\r\n{ *\r\n * Message = WM_DEVICECHANGE\r\n * wParam = DBT_LOW_DISK_SPACE\r\n * lParam = drive number of drive that is low on disk space (1-based)\r\n *\r\n * Message issued by VFAT when it detects that a drive it has mounted\r\n * has the remaning free space below a threshold specified by the\r\n * registry or by a disk space management application.\r\n * The broadcast is issued by VFAT ONLY when space is either allocated\r\n * or freed by VFAT.\r\n * }\r\n\r\nconst\r\n {$EXTERNALSYM DBT_LOW_DISK_SPACE}\r\n DBT_LOW_DISK_SPACE = $0048;\r\n\r\n {$EXTERNALSYM DBT_CONFIGMGPRIVATE}\r\n DBT_CONFIGMGPRIVATE = $7FFF;\r\n\r\n\r\n{ *\r\n * The following messages are for WM_DEVICECHANGE. The immediate list\r\n * is for the wParam. ALL THESE MESSAGES PASS A POINTER TO A STRUCT\r\n * STARTING WITH A DWORD SIZE AND HAVING NO POINTER IN THE STRUCT.\r\n * }\r\n\r\nconst\r\n {$EXTERNALSYM DBT_DEVICEARRIVAL}\r\n DBT_DEVICEARRIVAL = $8000; { system detected a new device }\r\n {$EXTERNALSYM DBT_DEVICEQUERYREMOVE}\r\n DBT_DEVICEQUERYREMOVE = $8001; { wants to remove, may fail }\r\n {$EXTERNALSYM DBT_DEVICEQUERYREMOVEFAILED}\r\n DBT_DEVICEQUERYREMOVEFAILED = $8002; { removal aborted }\r\n {$EXTERNALSYM DBT_DEVICEREMOVEPENDING}\r\n DBT_DEVICEREMOVEPENDING = $8003; { about to remove, still avail. }\r\n {$EXTERNALSYM DBT_DEVICEREMOVECOMPLETE}\r\n DBT_DEVICEREMOVECOMPLETE = $8004; { device is gone }\r\n {$EXTERNALSYM DBT_DEVICETYPESPECIFIC}\r\n DBT_DEVICETYPESPECIFIC = $8005; { type specific event }\r\n {$EXTERNALSYM DBT_CUSTOMEVENT}\r\n DBT_CUSTOMEVENT = $8006; { user-defined event }\r\n {$EXTERNALSYM DBT_DEVTYP_OEM}\r\n DBT_DEVTYP_OEM = $00000000; { oem-defined device type }\r\n {$EXTERNALSYM DBT_DEVTYP_DEVNODE}\r\n DBT_DEVTYP_DEVNODE = $00000001; { devnode number }\r\n {$EXTERNALSYM DBT_DEVTYP_VOLUME}\r\n DBT_DEVTYP_VOLUME = $00000002; { logical volume }\r\n {$EXTERNALSYM DBT_DEVTYP_PORT}\r\n DBT_DEVTYP_PORT = $00000003; { serial, parallel }\r\n {$EXTERNALSYM DBT_DEVTYP_NET}\r\n DBT_DEVTYP_NET = $00000004; { network resource }\r\n {$EXTERNALSYM DBT_DEVTYP_DEVICEINTERFACE}\r\n DBT_DEVTYP_DEVICEINTERFACE = $00000005; { device interface class }\r\n {$EXTERNALSYM DBT_DEVTYP_HANDLE}\r\n DBT_DEVTYP_HANDLE = $00000006; { file system handle }\r\n\r\ntype\r\n PDevBroadcastHeader = ^TDevBroadcastHeader;\r\n // no EXTERNALSYM because this struct is not declared as C type\r\n DEV_BROADCAST_HEADER = record\r\n dbcd_size: DWORD;\r\n dbcd_devicetype: DWORD;\r\n dbcd_reserved: DWORD;\r\n end;\r\n TDevBroadcastHeader = DEV_BROADCAST_HEADER;\r\n\r\n PDevBroadcastOem = ^TDevBroadcastOem;\r\n {$EXTERNALSYM DEV_BROADCAST_OEM}\r\n DEV_BROADCAST_OEM = record\r\n dbco_size: DWORD;\r\n dbco_devicetype: DWORD;\r\n dbco_reserved: DWORD;\r\n dbco_identifier: DWORD;\r\n dbco_suppfunc: DWORD;\r\n end;\r\n TDevBroadcastOem = DEV_BROADCAST_OEM;\r\n\r\n PDevBroadcastDevNode = ^TDevBroadcastDevNode;\r\n {$EXTERNALSYM DEV_BROADCAST_DEVNODE}\r\n DEV_BROADCAST_DEVNODE = record\r\n dbcd_size: DWORD;\r\n dbcd_devicetype: DWORD;\r\n dbcd_reserved: DWORD;\r\n dbcd_devnode: DWORD;\r\n end;\r\n TDevBroadcastDevNode = DEV_BROADCAST_DEVNODE;\r\n\r\n PDevBroadcastVolume = ^TDevBroadcastVolume;\r\n {$EXTERNALSYM DEV_BROADCAST_VOLUME}\r\n DEV_BROADCAST_VOLUME = record\r\n dbcv_size: DWORD;\r\n dbcv_devicetype: DWORD;\r\n dbcv_reserved: DWORD;\r\n dbcv_unitmask: DWORD;\r\n dbcv_flags: Word;\r\n end;\r\n TDevBroadcastVolume = DEV_BROADCAST_VOLUME;\r\n\r\nconst\r\n {$EXTERNALSYM DBTF_MEDIA}\r\n DBTF_MEDIA = $0001; { media commings and goings }\r\n {$EXTERNALSYM DBTF_NET}\r\n DBTF_NET = $0002; { network volume }\r\n\r\ntype\r\n PDevBroadCastPortA = ^TDevBroadCastPortA;\r\n {$EXTERNALSYM DEV_BROADCAST_PORT_A}\r\n DEV_BROADCAST_PORT_A = record\r\n dbcp_size: DWORD;\r\n dbcp_devicetype: DWORD;\r\n dbcp_reserved: DWORD;\r\n dbcp_name: array [0..0] of AnsiChar;\r\n end;\r\n TDevBroadCastPortA = DEV_BROADCAST_PORT_A;\r\n PDevBroadCastPortW = ^TDevBroadCastPortW;\r\n {$EXTERNALSYM DEV_BROADCAST_PORT_W}\r\n DEV_BROADCAST_PORT_W = record\r\n dbcp_size: DWORD;\r\n dbcp_devicetype: DWORD;\r\n dbcp_reserved: DWORD;\r\n dbcp_name: array [0..0] of WideChar;\r\n end;\r\n TDevBroadCastPortW = DEV_BROADCAST_PORT_W;\r\n PDevBroadCastPort = PDevBroadCastPortA;\r\n\r\ntype\r\n PDevBroadcastNet = ^TDevBroadcastNet;\r\n {$EXTERNALSYM DEV_BROADCAST_NET}\r\n DEV_BROADCAST_NET = record\r\n dbcn_size: DWORD;\r\n dbcn_devicetype: DWORD;\r\n dbcn_reserved: DWORD;\r\n dbcn_resource: DWORD;\r\n dbcn_flags: DWORD;\r\n end;\r\n TDevBroadcastNet = DEV_BROADCAST_NET;\r\n\r\n PDevBroadcastDeviceInterfaceA = ^TDevBroadcastDeviceInterfaceA;\r\n {$EXTERNALSYM DEV_BROADCAST_DEVICEINTERFACE_A}\r\n DEV_BROADCAST_DEVICEINTERFACE_A = record\r\n dbcc_size: DWORD;\r\n dbcc_devicetype: DWORD;\r\n dbcc_reserved: DWORD;\r\n dbcc_classguid: TGUID;\r\n dbcc_name: array [0..0] of AnsiChar;\r\n end;\r\n TDevBroadcastDeviceInterfaceA = DEV_BROADCAST_DEVICEINTERFACE_A;\r\n PDevBroadcastDeviceInterfaceW = ^TDevBroadcastDeviceInterfaceW;\r\n {$EXTERNALSYM DEV_BROADCAST_DEVICEINTERFACE_W}\r\n DEV_BROADCAST_DEVICEINTERFACE_W = record\r\n dbcc_size: DWORD;\r\n dbcc_devicetype: DWORD;\r\n dbcc_reserved: DWORD;\r\n dbcc_classguid: TGUID;\r\n dbcc_name: array [0..0] of WideChar;\r\n end;\r\n TDevBroadcastDeviceInterfaceW = DEV_BROADCAST_DEVICEINTERFACE_W;\r\n PDevBroadcastDeviceInterface = PDevBroadcastDeviceInterfaceA;\r\n\r\n {$EXTERNALSYM DEV_BROADCAST_HANDLE}\r\n PDevBroadcastHandle = ^TDevBroadcastHandle;\r\n DEV_BROADCAST_HANDLE = record\r\n dbch_size: DWORD;\r\n dbch_devicetype: DWORD;\r\n dbch_reserved: DWORD;\r\n dbch_handle: THandle; { file handle used in call to RegisterDeviceNotification }\r\n dbch_hdevnotify: DWORD; { HDEVNOTIFY returned from RegisterDeviceNotification }\r\n\r\n { The following 3 fields are only valid if wParam is DBT_CUSTOMEVENT. }\r\n\r\n dbch_eventguid: TGUID;\r\n dbch_nameoffset: DWORD; { offset (bytes) of variable-length string buffer (-1 if none)}\r\n dbch_data: array [0..0] of Byte; { variable-sized buffer, potentially containing binary and/or text data }\r\n end;\r\n TDevBroadcastHandle = DEV_BROADCAST_HANDLE;\r\n\r\nconst\r\n {$EXTERNALSYM DBTF_RESOURCE}\r\n DBTF_RESOURCE = $00000001; { network resource }\r\n {$EXTERNALSYM DBTF_XPORT}\r\n DBTF_XPORT = $00000002; { new transport coming or going }\r\n {$EXTERNALSYM DBTF_SLOWNET}\r\n DBTF_SLOWNET = $00000004; { new incoming transport is slow }\r\n { (dbcn_resource undefined for now) }\r\n {$EXTERNALSYM DBT_VPOWERDAPI}\r\n DBT_VPOWERDAPI = $8100; { VPOWERD API for Win95 }\r\n\r\n\r\n{ *\r\n * User-defined message types all use wParam = 0xFFFF with the\r\n * lParam a pointer to the structure below.\r\n *\r\n * dbud_dbh - DEV_BROADCAST_HEADER must be filled in as usual.\r\n *\r\n * dbud_szName contains a case-sensitive ASCIIZ name which names the\r\n * message. The message name consists of the vendor name, a backslash,\r\n * then arbitrary user-defined ASCIIZ text. For example:\r\n *\r\n * \"WidgetWare\\QueryScannerShutdown\"\r\n * \"WidgetWare\\Video Q39S\\AdapterReady\"\r\n *\r\n * After the ASCIIZ name, arbitrary information may be provided.\r\n * Make sure that dbud_dbh.dbch_size is big enough to encompass\r\n * all the data. And remember that nothing in the structure may\r\n * contain pointers.\r\n * }\r\n\r\nconst\r\n {$EXTERNALSYM DBT_USERDEFINED}\r\n DBT_USERDEFINED = $FFF;\r\n\r\ntype\r\n PDevBroadcastUserdefined = ^TDevBroadcastUserdefined;\r\n // no EXTERNALSYM because this struct is not declared as C type\r\n DEV_BROADCAST_USERDEFINED = record\r\n dbud_dbh: TDevBroadcastHdr;\r\n dbud_szName: array [0..0] of Char; { ASCIIZ name }\r\n {dbud_rgbUserDefined[]: Byte; // User-defined contents }\r\n end;\r\n TDevBroadcastUserdefined = DEV_BROADCAST_USERDEFINED;\r\n\r\n{ added own message type for WM_DEVICECHANGE }\r\n\r\ntype\r\n TWMDeviceChange = record\r\n Msg: Cardinal;\r\n {$IFDEF COMPILER16_UP}\r\n MsgFiller: TDWordFiller;\r\n {$ENDIF COMPILER16_UP}\r\n Event: WPARAM;\r\n dwData: Pointer;\r\n Result: LRESULT;\r\n end;\r\n\r\nimplementation\r\n\r\nend.\r\n\r\n" }, { "path": "External/Jedi/Jvcl/run/Hid.pas", "content": "{******************************************************************}\r\n{ }\r\n{ Borland Delphi Runtime Library }\r\n{ Public Definitions of HID functions from HID.DLL }\r\n{ }\r\n{ Portions created by Microsoft are }\r\n{ Copyright (C) 1995-1999 Microsoft Corporation. }\r\n{ All Rights Reserved. }\r\n{ }\r\n{ The original file are: hidsdi.h, hidpi.h, released March 1999. }\r\n{ The original Pascal code is: Hid.pas, released 29 Jan 2000. }\r\n{ The initial developer of the Pascal code is Robert Marquardt }\r\n{ (robert_marquardt att gmx dott de) }\r\n{ }\r\n{ Portions created by Robert Marquardt are }\r\n{ Copyright (C) 1999, 2000 Robert Marquardt. }\r\n{ }\r\n{ Contributor(s): Marcel van Brakel (brakelm att bart dott nl) }\r\n{ }\r\n{ Obtained through: }\r\n{ Joint Endeavour of Delphi Innovators (Project JEDI) }\r\n{ }\r\n{ You may retrieve the latest version of this file at the Project }\r\n{ JEDI home page, located at http://delphi-jedi.org }\r\n{ }\r\n{ The contents of this file are used with permission, subject to }\r\n{ the Mozilla Public License Version 1.1 (the \"License\"); you may }\r\n{ not use this file except in compliance with the License. You may }\r\n{ obtain a copy of the License at }\r\n{ http://www.mozilla.org/NPL/NPL-1_1Final.html }\r\n{ }\r\n{ Software distributed under the License is distributed on an }\r\n{ \"AS IS\" basis, WITHOUT WARRANTY OF ANY KIND, either express or }\r\n{ implied. See the License for the specific language governing }\r\n{ rights and limitations under the License. }\r\n{ }\r\n{******************************************************************}\r\n\r\nunit Hid;\r\n\r\ninterface\r\n\r\n{$WEAKPACKAGEUNIT}\r\n\r\n// (rom) loads HID.DLL dynamically\r\n{$DEFINE HID_LINKONREQUEST}\r\n\r\n// (rom) enable for functions only in HID.DLL of Windows 98 SE or better\r\n{ $ DEFINE WIN2000}\r\n\r\n// (rom) enable for functions only in HID.DLL of Windows XP\r\n{ $ DEFINE WINXP}\r\n\r\n{$IFDEF WINXP}\r\n{$DEFINE WIN2000}\r\n{$ENDIF WINXP}\r\n\r\nuses\r\n Windows;\r\n\r\n{$ALIGN ON}\r\n\r\ntype\r\n // (rom) moved from HidUsage.pas\r\n PUsage = ^TUsage;\r\n TUsage = Word;\r\n\r\n // (rom) from WINNT.H\r\n NTSTATUS = Longint;\r\n {$EXTERNALSYM NTSTATUS}\r\n\r\n// FACILITY_HID_ERROR_CODE defined in ntstatus.h\r\nconst\r\n FACILITY_HID_ERROR_CODE = $11;\r\n {$EXTERNALSYM FACILITY_HID_ERROR_CODE}\r\n\r\n //\r\n // Define NT Status codes with Facility Code of FACILITY_HID_ERROR_CODE\r\n // (rom) vv\r\n HIDP_STATUS_SUCCESS = NTSTATUS($00110000);\r\n HIDP_STATUS_NULL = NTSTATUS($80110001);\r\n HIDP_STATUS_INVALID_PREPARSED_DATA = NTSTATUS($C0110001);\r\n HIDP_STATUS_INVALID_REPORT_TYPE = NTSTATUS($C0110002);\r\n HIDP_STATUS_INVALID_REPORT_LENGTH = NTSTATUS($C0110003);\r\n HIDP_STATUS_USAGE_NOT_FOUND = NTSTATUS($C0110004);\r\n HIDP_STATUS_VALUE_OUT_OF_RANGE = NTSTATUS($C0110005);\r\n HIDP_STATUS_BAD_LOG_PHY_VALUES = NTSTATUS($C0110006);\r\n HIDP_STATUS_BUFFER_TOO_SMALL = NTSTATUS($C0110007);\r\n HIDP_STATUS_INTERNAL_ERROR = NTSTATUS($C0110008);\r\n HIDP_STATUS_I8042_TRANS_UNKNOWN = NTSTATUS($C0110009);\r\n HIDP_STATUS_INCOMPATIBLE_REPORT_ID = NTSTATUS($C011000A);\r\n HIDP_STATUS_NOT_VALUE_ARRAY = NTSTATUS($C011000B);\r\n HIDP_STATUS_IS_VALUE_ARRAY = NTSTATUS($C011000C);\r\n HIDP_STATUS_DATA_INDEX_NOT_FOUND = NTSTATUS($C011000D);\r\n HIDP_STATUS_DATA_INDEX_OUT_OF_RANGE = NTSTATUS($C011000E);\r\n HIDP_STATUS_BUTTON_NOT_PRESSED = NTSTATUS($C011000F);\r\n HIDP_STATUS_REPORT_DOES_NOT_EXIST = NTSTATUS($C0110010);\r\n HIDP_STATUS_NOT_IMPLEMENTED = NTSTATUS($C0110020);\r\n //\r\n // We blundered this status code.\r\n //\r\n HIDP_STATUS_I8242_TRANS_UNKNOWN = HIDP_STATUS_I8042_TRANS_UNKNOWN;\r\n\r\n // Special Link collection values for using the query functions\r\n //\r\n // Root collection references the collection at the base of the link\r\n // collection tree.\r\n // Unspecifies, references all collections in the link collection tree.\r\n\r\n HIDP_LINK_COLLECTION_ROOT = -1;\r\n HIDP_LINK_COLLECTION_UNSPECIFIED = 0;\r\n\r\n // A bitmap of the current shift state of the keyboard when using the\r\n // below keyboard usages to i8042 translation function.\r\n\r\nconst\r\n // (rom) values for the bits of THIDPKeyboardModifierState\r\n kmsLeftControl = $0001;\r\n kmsLeftShift = $0002;\r\n kmsLeftAlt = $0004;\r\n kmsLeftGUI = $0008;\r\n kmsRightControl = $0010;\r\n kmsRightShift = $0020;\r\n kmsRightAlt = $0040;\r\n kmsRightGUI = $0080;\r\n kmsCapsLock = $0100;\r\n kmsScollLock = $0200;\r\n kmsNumLock = $0400;\r\ntype\r\n THIDPKeyboardModifierState = DWORD;\r\n\r\n // (rom) bit value to check IsAlias of THIDPLinkCollectionNode\r\nconst\r\n lcnIsAlias = 1;\r\n\r\ntype\r\n // (rom) to represent the union names\r\n THIDVariantFlags = (Range, NotRange);\r\n\r\n PHIDDConfiguration = ^THIDDConfiguration;\r\n HIDD_CONFIGURATION = record\r\n cookie: Pointer;\r\n size: ULONG;\r\n RingBufferSize: ULONG;\r\n end;\r\n THIDDConfiguration = HIDD_CONFIGURATION;\r\n\r\n PHIDDAttributes = ^THIDDAttributes;\r\n HIDD_ATTRIBUTES = record\r\n Size: ULONG; // size of structure (set before call)\r\n VendorID: Word;\r\n ProductID: Word;\r\n VersionNumber: Word;\r\n //\r\n // Additional fields will be added to the end of this structure.\r\n //\r\n end;\r\n THIDDAttributes = HIDD_ATTRIBUTES;\r\n\r\n PHIDPPreparsedData = Pointer;\r\n\r\nconst\r\n HidP_Input = 0;\r\n HidP_Output = 1;\r\n HidP_Feature = 2;\r\n\r\ntype\r\n PHIDPReportType = ^THIDPReportType;\r\n THIDPReportType = DWORD;\r\n\r\nconst\r\n // Produce Make or Break Codes\r\n HidP_Keyboard_Break = 0;\r\n HidP_Keyboard_Make = 1;\r\ntype\r\n PHIDPKeyboardDirection = ^THIDPKeyboardDirection;\r\n THIDPKeyboardDirection = DWORD;\r\n\r\n PUsageAndPage = ^TUsageAndPage;\r\n USAGE_AND_PAGE = record\r\n Usage: TUsage;\r\n UsagePage: TUsage;\r\n end;\r\n TUsageAndPage = USAGE_AND_PAGE;\r\n\r\n PHIDPButtonCaps = ^THIDPButtonCaps;\r\n HIDP_BUTTON_CAPS = record\r\n UsagePage: TUsage;\r\n ReportID: BYTE;\r\n IsAlias: ByteBool;\r\n\r\n BitField: Word;\r\n LinkCollection: Word; // A unique internal index pointer\r\n\r\n LinkUsage: TUsage;\r\n LinkUsagePage: TUsage;\r\n\r\n IsRange: ByteBool;\r\n IsStringRange: ByteBool;\r\n IsDesignatorRange: ByteBool;\r\n IsAbsolute: ByteBool;\r\n\r\n Reserved: array [0..9] of ULONG;\r\n\r\n case THIDVariantFlags of\r\n Range:\r\n ( UsageMin, UsageMax: TUsage;\r\n StringMin, StringMax,\r\n DesignatorMin, DesignatorMax,\r\n DataIndexMin, DataIndexMax: Word );\r\n NotRange:\r\n ( Usage, Reserved1: TUsage;\r\n StringIndex, Reserved2,\r\n DesignatorIndex, Reserved3,\r\n DataIndex, Reserved4: Word );\r\n end;\r\n THIDPButtonCaps = HIDP_BUTTON_CAPS;\r\n\r\n PHIDPValueCaps = ^THIDPValueCaps;\r\n HIDP_VALUE_CAPS = record\r\n UsagePage: TUsage;\r\n ReportID: BYTE;\r\n IsAlias: ByteBool;\r\n\r\n BitField: Word;\r\n LinkCollection: Word; // A unique internal index pointer\r\n\r\n LinkUsage: TUsage;\r\n LinkUsagePage: TUsage;\r\n\r\n IsRange: ByteBool;\r\n IsStringRange: ByteBool;\r\n IsDesignatorRange: ByteBool;\r\n IsAbsolute: ByteBool;\r\n\r\n HasNull: ByteBool; // Does this channel have a null report union\r\n Reserved: BYTE;\r\n BitSize: Word; // How many bits are devoted to this value?\r\n\r\n ReportCount: Word; // See Note below. Usually set to 1.\r\n Reserved_: array [0..4] of Word;\r\n // (rom) name change Reserved2 gives name clash in Pascal\r\n UnitsExp: ULONG;\r\n Units: ULONG;\r\n\r\n LogicalMin: Integer;\r\n LogicalMax: Integer;\r\n PhysicalMin: Integer;\r\n PhysicalMax: Integer;\r\n\r\n case THIDVariantFlags of\r\n Range:\r\n ( UsageMin, UsageMax: TUsage;\r\n StringMin, StringMax,\r\n DesignatorMin, DesignatorMax,\r\n DataIndexMin, DataIndexMax: Word );\r\n NotRange:\r\n ( Usage, Reserved1: TUsage;\r\n StringIndex, Reserved2,\r\n DesignatorIndex, Reserved3,\r\n DataIndex, Reserved4: Word );\r\n end;\r\n THIDPValueCaps = HIDP_VALUE_CAPS;\r\n\r\n//\r\n// Notes:\r\n//\r\n// ReportCount: When a report descriptor declares an Input, Output, or\r\n// Feature main item with fewer usage declarations than the report count, then\r\n// the last usage applies to all remaining unspecified count in that main item.\r\n// (As an example you might have data that required many fields to describe,\r\n// possibly buffered bytes.) In this case, only one value cap structure is\r\n// allocated for these associtated fields, all with the same usage, and Report\r\n// Count reflects the number of fields involved. Normally ReportCount is 1.\r\n// To access all of the fields in such a value structure would require using\r\n// HidP_GetUsageValueArray and HidP_SetUsageValueArray. HidP_GetUsageValue/\r\n// HidP_SetScaledUsageValue will also work, however, these functions will only\r\n// work with the first field of the structure.\r\n//\r\n\r\n//\r\n// The link collection tree consists of an array of LINK_COLLECTION_NODES\r\n// where the index into this array is the same as the collection number.\r\n//\r\n// Given a collection A which contains a subcollection B, A is defined to be\r\n// the parent B, and B is defined to be the child.\r\n//\r\n// Given collections A, B, and C where B and C are children of A, and B was\r\n// encountered before C in the report descriptor, B is defined as a sibling of\r\n// C. (This implies, of course, that if B is a sibling of C, then C is NOT a\r\n// sibling of B).\r\n//\r\n// B is defined as the NextSibling of C if and only if there exists NO\r\n// child collection of A, call it D, such that B is a sibling of D and D\r\n// is a sibling of C.\r\n//\r\n// E is defined to be the FirstChild of A if and only if for all children of A,\r\n// F, that are not equivalent to E, F is a sibling of E.\r\n// (This implies, of course, that the does not exist a child of A, call it G,\r\n// where E is a sibling of G). In other words the first sibling is the last\r\n// link collection found in the list.\r\n//\r\n// In other words, if a collection B is defined within the definition of another\r\n// collection A, B becomes a child of A. All collections with the same parent\r\n// are considered siblings. The FirstChild of the parent collection, A, will be\r\n// last collection defined that has A as a parent. The order of sibling pointers\r\n// is similarly determined. When a collection B is defined, it becomes the\r\n// FirstChild of it's parent collection. The previously defined FirstChild of the\r\n// parent collection becomes the NextSibling of the new collection. As new\r\n// collections with the same parent are discovered, the chain of sibling is built.\r\n//\r\n// With that in mind, the following describes conclusively a data structure\r\n// that provides direct traversal up, down, and accross the link collection\r\n// tree.\r\n\r\n PHIDPLinkCollectionNode = ^THIDPLinkCollectionNode;\r\n HIDP_LINK_COLLECTION_NODE = record\r\n LinkUsage: TUsage;\r\n LinkUsagePage: TUsage;\r\n Parent: Word;\r\n NumberOfChildren: Word;\r\n NextSibling: Word;\r\n FirstChild: Word;\r\n CollectionType: BYTE; // As defined in 6.2.2.6 of HID spec\r\n IsAlias: BYTE; // This link node is an alias of the next link node.\r\n Reserved: Word; // (rom) bitfields\r\n UserContext: Pointer; // The user can hang his coat here.\r\n end;\r\n THIDPLinkCollectionNode = HIDP_LINK_COLLECTION_NODE;\r\n\r\n//\r\n// When a link collection is described by a delimiter, alias link collection\r\n// nodes are created. (One for each usage within the delimiter).\r\n// The parser assigns each capability description listed above only one\r\n// link collection.\r\n//\r\n// If a control is defined within a collection defined by\r\n// delimited usages, then that control is said to be within multiple link\r\n// collections, one for each usage within the open and close delimiter tokens.\r\n// Such multiple link collecions are said to be aliases. The first N-1 such\r\n// collections, listed in the link collection node array, have their IsAlias\r\n// bit set. The last such link collection is the link collection index used\r\n// in the capabilities described above.\r\n// Clients wishing to set a control in an aliased collection, should walk the\r\n// collection array once for each time they see the IsAlias flag set, and use\r\n// the last link collection as the index for the below accessor functions.\r\n//\r\n// NB: if IsAlias is set, then NextSibling should be one more than the current\r\n// link collection node index.\r\n\r\n PHIDPReportDescriptor = PAnsiChar;\r\n\r\n PHIDPCaps = ^THIDPCaps;\r\n HIDP_CAPS = record\r\n Usage: TUsage;\r\n UsagePage: TUsage;\r\n InputReportByteLength: Word;\r\n OutputReportByteLength: Word;\r\n FeatureReportByteLength: Word;\r\n Reserved: array [0..16] of Word;\r\n\r\n NumberLinkCollectionNodes: Word;\r\n\r\n NumberInputButtonCaps: Word;\r\n NumberInputValueCaps: Word;\r\n NumberInputDataIndices: Word;\r\n\r\n NumberOutputButtonCaps: Word;\r\n NumberOutputValueCaps: Word;\r\n NumberOutputDataIndices: Word;\r\n\r\n NumberFeatureButtonCaps: Word;\r\n NumberFeatureValueCaps: Word;\r\n NumberFeatureDataIndices: Word;\r\n end;\r\n THIDPCaps = HIDP_CAPS;\r\n\r\n PHIDPData = ^THIDPData;\r\n HIDP_DATA = record\r\n DataIndex: Word;\r\n Reserved: Word;\r\n case Integer of\r\n 0: (RawValue: ULONG); // for values\r\n 1: (On_: ByteBool); // for buttons MUST BE TRUE for buttons.\r\n // (rom) name change On is reserved in Pascal\r\n end;\r\n THIDPData = HIDP_DATA;\r\n\r\n// The HIDP_DATA structure is used with HidP_GetData and HidP_SetData\r\n// functions.\r\n//\r\n// The parser contiguously assigns every control (button or value) in a hid\r\n// device a unique data index from zero to NumberXXXDataIndices -1 , inclusive.\r\n// This value is found in the HIDP_BUTTON_CAPS and HIDP_VALUE_CAPS structures.\r\n//\r\n// Most clients will find the Get/Set Buttons / Value accessor functions\r\n// sufficient to their needs, as they will allow the clients to access the\r\n// data known to them while ignoring the other controls.\r\n//\r\n// More complex clients, which actually read the Button / Value Caps, and which\r\n// do a value add service to these routines (EG Direct Input), will need to\r\n// access all the data in the device without interest in the individual usage\r\n// or link collection location. These are the clients that will find\r\n// HidP_Data useful.\r\n\r\n PHIDPUnknownToken = ^THIDPUnknownToken;\r\n HIDP_UNKNOWN_TOKEN = record\r\n Token: BYTE;\r\n Reserved: array [0..2] of BYTE;\r\n BitField: DWORD;\r\n end;\r\n THIDPUnknownToken = HIDP_UNKNOWN_TOKEN;\r\n\r\n PHIDPExtendedAttributes = ^THIDPExtendedAttributes;\r\n HIDP_EXTENDED_ATTRIBUTES = record\r\n NumGlobalUnknowns: BYTE;\r\n Reserved: array [0..2] of BYTE;\r\n GlobalUnknowns: PHIDPUnknownToken;\r\n // ... Additional attributes\r\n Data: array [0..0] of ULONG; // variableLength DO NOT ACCESS THIS FIELD\r\n end;\r\n THIDPExtendedAttributes = HIDP_EXTENDED_ATTRIBUTES;\r\n\r\n // (rom) callback function type for HidP_TranslateUsagesToI8042ScanCodes param\r\n // (rom) maybe calling convention is incorrect\r\n THIDPInsertScanCodes = function(\r\n Context: Pointer; // Some caller supplied context\r\n NewScanCodes: PAnsiChar; // A list of i8042 scan codes\r\n Length: ULONG // the length of the scan code list\r\n ): Boolean; stdcall;\r\n\r\n{$IFNDEF HID_LINKONREQUEST}\r\n\r\n// (rom) undocumented easter egg function\r\n// (rom) fills buffer with \"Hello\\nI hate Jello\\n\"\r\n// (rom) returns number of bytes filled in == strlen(Buffer)+1 == 20\r\n// (rom) bugs: handing in nil as buffer gives access violation.\r\n// (rom) always returns 20 even if buffer length is less than 20\r\n// (rom) but does not produce buffer overflow\r\n\r\nfunction HidD_Hello(Buffer: PAnsiChar; BufferLength: ULONG): ULONG; stdcall;\r\n\r\nprocedure HidD_GetHidGuid(var HidGuid: TGUID) stdcall;\r\n\r\nfunction HidD_GetPreparsedData(HidDeviceObject: THandle;\r\n var PreparsedData: PHIDPPreparsedData): LongBool; stdcall;\r\n\r\nfunction HidD_FreePreparsedData(PreparsedData: PHIDPPreparsedData): LongBool; stdcall;\r\n\r\n// Routine Description:\r\n// Get the configuration information for this Hid device\r\n//\r\n// Arguments:\r\n// HidDeviceObject A handle to a Hid Device Object.\r\n//\r\n// Configuration A configuration structure. HidD_GetConfiguration MUST\r\n// be called before the configuration can be modified and\r\n// set using HidD_SetConfiguration\r\n//\r\n// ConfigurationLength That is ``sizeof (HIDD_CONFIGURATION)''. Using this\r\n// parameter, we can later increase the length of the\r\n// configuration array and not break older apps.\r\n//\r\n// Return Value:\r\n// TRUE if successful\r\n// FALSE otherwise -- Use GetLastError() to get extended error information\r\n\r\nfunction HidD_GetConfiguration(HidDeviceObject: THandle;\r\n var HidConfig: THIDDConfiguration; Size: Integer): LongBool; stdcall;\r\n\r\n// Routine Description:\r\n// Set the configuration information for this Hid device...\r\n//\r\n// NOTE: HidD_GetConfiguration must be called to retrieve the current\r\n// configuration information before this information can be modified\r\n// and set.\r\n//\r\n// Arguments:\r\n// HidDeviceObject A handle to a Hid Device Object.\r\n//\r\n// Configuration A configuration structure. HidD_GetConfiguration MUST\r\n// be called before the configuration can be modified and\r\n// set using HidD_SetConfiguration\r\n//\r\n// ConfigurationLength That is ``sizeof (HIDD_CONFIGURATION)''. Using this\r\n// parameter, we can later increase the length of the\r\n// configuration array and not break older apps.\r\n//\r\n// Return Value:\r\n// TRUE if successful\r\n// FALSE otherwise -- Use GetLastError() to get extended error information\r\n\r\nfunction HidD_SetConfiguration(HidDeviceObject: THandle;\r\n const HidConfig: THIDDConfiguration; Size: Integer): LongBool; stdcall;\r\n\r\n// Routine Description:\r\n// Flush the input queue for the given HID device.\r\n//\r\n// Arguments:\r\n// HidDeviceObject A handle to a Hid Device that the client obtains using\r\n// a call to CreateFile on a valid Hid device string name.\r\n// The string name can be obtained using standard PnP calls.\r\n//\r\n// Return Value:\r\n// TRUE if successful\r\n// FALSE otherwise -- Use GetLastError() to get extended error information\r\n\r\nfunction HidD_FlushQueue(HidDeviceObject: THandle): LongBool; stdcall;\r\n\r\n// Routine Description:\r\n// Retrieve a feature report from a HID device.\r\n//\r\n// Arguments:\r\n// HidDeviceObject A handle to a Hid Device Object.\r\n//\r\n// ReportBuffer The buffer that the feature report should be placed\r\n// into. The first byte of the buffer should be set to\r\n// the report ID of the desired report\r\n//\r\n// ReportBufferLength The size (in bytes) of ReportBuffer. This value\r\n// should be greater than or equal to the\r\n// FeatureReportByteLength field as specified in the\r\n// HIDP_CAPS structure for the device\r\n// Return Value:\r\n// TRUE if successful\r\n// FALSE otherwise -- Use GetLastError() to get extended error information\r\n\r\nfunction HidD_GetFeature(HidDeviceObject: THandle;\r\n var Report; Size: Integer): LongBool; stdcall;\r\n\r\n// Routine Description:\r\n// Send a feature report to a HID device.\r\n//\r\n// Arguments:\r\n// HidDeviceObject A handle to a Hid Device Object.\r\n//\r\n// ReportBuffer The buffer of the feature report to send to the device\r\n//\r\n// ReportBufferLength The size (in bytes) of ReportBuffer. This value\r\n// should be greater than or equal to the\r\n// FeatureReportByteLength field as specified in the\r\n// HIDP_CAPS structure for the device\r\n// Return Value:\r\n// TRUE if successful\r\n// FALSE otherwise -- Use GetLastError() to get extended error information\r\n\r\nfunction HidD_SetFeature(HidDeviceObject: THandle;\r\n var Report; Size: Integer): LongBool; stdcall;\r\n\r\n// Routine Description:\r\n// This function returns the number of input buffers used by the specified\r\n// file handle to the Hid device. Each file object has a number of buffers\r\n// associated with it to queue reports read from the device but which have\r\n// not yet been read by the user-mode app with a handle to that device.\r\n//\r\n// Arguments:\r\n// HidDeviceObject A handle to a Hid Device Object.\r\n//\r\n// NumberBuffers Number of buffers currently being used for this file\r\n// handle to the Hid device\r\n//\r\n// Return Value:\r\n// TRUE if successful\r\n// FALSE otherwise -- Use GetLastError() to get extended error information\r\n\r\nfunction HidD_GetNumInputBuffers(HidDeviceObject: THandle;\r\n var NumBufs: Integer): LongBool; stdcall;\r\n\r\n// Routine Description:\r\n// This function sets the number of input buffers used by the specified\r\n// file handle to the Hid device. Each file object has a number of buffers\r\n// associated with it to queue reports read from the device but which have\r\n// not yet been read by the user-mode app with a handle to that device.\r\n//\r\n// Arguments:\r\n// HidDeviceObject A handle to a Hid Device Object.\r\n//\r\n// NumberBuffers New number of buffers to use for this file handle to\r\n// the Hid device\r\n//\r\n// Return Value:\r\n// TRUE if successful\r\n// FALSE otherwise -- Use GetLastError() to get extended error information\r\n\r\nfunction HidD_SetNumInputBuffers(HidDeviceObject: THandle;\r\n NumBufs: Integer): LongBool; stdcall;\r\n\r\n// Routine Description:\r\n// Given a handle to a valid Hid Class Device Object, retrieve the preparsed\r\n// data for the device. This routine will allocate the appropriately\r\n// sized buffer to hold this preparsed data. It is up to client to call\r\n// HidD_FreePreparsedData to free the memory allocated to this structure when\r\n// it is no longer needed.\r\n//\r\n// Arguments:\r\n// HidDeviceObject A handle to a Hid Device that the client obtains using\r\n// a call to CreateFile on a valid Hid device string name.\r\n// The string name can be obtained using standard PnP calls.\r\n//\r\n// PreparsedData An opaque data structure used by other functions in this\r\n// library to retrieve information about a given device.\r\n//\r\n// Return Value:\r\n// TRUE if successful.\r\n// FALSE otherwise -- Use GetLastError() to get extended error information\r\n\r\nfunction HidD_GetAttributes(HidDeviceObject: THandle;\r\n var HidAttrs: THIDDAttributes): LongBool; stdcall;\r\n\r\n// Routine Description:\r\n// This function retrieves the manufacturer string from the specified\r\n// Hid device.\r\n//\r\n// Arguments:\r\n// HidDeviceObject A handle to a Hid Device Object.\r\n//\r\n// Buffer Buffer which on return will contain the manufacturer\r\n// string returned from the device. This string is a\r\n// wide-character string\r\n//\r\n// BufferLength Length of Buffer (in bytes)\r\n//\r\n// Return Value:\r\n// TRUE if successful\r\n// FALSE otherwise -- Use GetLastError() to get extended error information\r\n\r\nfunction HidD_GetManufacturerString(HidDeviceObject: THandle;\r\n Buffer: PWideChar; BufferLength: Integer): LongBool; stdcall;\r\n\r\n// Routine Description:\r\n// This function retrieves the product string from the specified\r\n// Hid device.\r\n//\r\n// Arguments:\r\n// HidDeviceObject A handle to a Hid Device Object.\r\n//\r\n// Buffer Buffer which on return will contain the product\r\n// string returned from the device. This string is a\r\n// wide-character string\r\n//\r\n// BufferLength Length of Buffer (in bytes)\r\n//\r\n// Return Value:\r\n// TRUE if successful\r\n// FALSE otherwise -- Use GetLastError() to get extended error information\r\n\r\nfunction HidD_GetProductString(HidDeviceObject: THandle;\r\n Buffer: PWideChar; BufferLength: Integer): LongBool; stdcall;\r\n\r\n// Routine Description:\r\n// This function retrieves the serial number string from the specified\r\n// Hid device.\r\n//\r\n// Arguments:\r\n// HidDeviceObject A handle to a Hid Device Object.\r\n//\r\n// Buffer Buffer which on return will contain the serial number\r\n// string returned from the device. This string is a\r\n// wide-character string\r\n//\r\n// BufferLength Length of Buffer (in bytes)\r\n//\r\n// Return Value:\r\n// TRUE if successful\r\n// FALSE otherwise -- Use GetLastError() to get extended error information\r\n\r\nfunction HidD_GetSerialNumberString(HidDeviceObject: THandle;\r\n Buffer: PWideChar; BufferLength: Integer): LongBool; stdcall;\r\n\r\n// Routine Description:\r\n// This function retrieves the raw physical descriptor for the specified\r\n// Hid device.\r\n//\r\n// Arguments:\r\n// HidDeviceObject A handle to a Hid Device Object.\r\n//\r\n// Buffer Buffer which on return will contain the physical\r\n// descriptor if one exists for the specified device\r\n// handle\r\n//\r\n// BufferLength Length of buffer (in bytes)\r\n//\r\n// Return Value:\r\n// TRUE if successful\r\n// FALSE otherwise -- Use GetLastError() to get extended error information\r\n\r\nfunction HidD_GetPhysicalDescriptor(HidDeviceObject: THandle;\r\n var Buffer; BufferLength: Integer): LongBool; stdcall;\r\n\r\n// Routine Description:\r\n// This function retrieves a string from the specified Hid device that is\r\n// specified with a certain string index.\r\n//\r\n// Arguments:\r\n// HidDeviceObject A handle to a Hid Device Object.\r\n//\r\n// StringIndex Index of the string to retrieve\r\n//\r\n// Buffer Buffer which on return will contain the product\r\n// string returned from the device. This string is a\r\n// wide-character string\r\n//\r\n// BufferLength Length of Buffer (in bytes)\r\n//\r\n// Return Value:\r\n// TRUE if successful\r\n// FALSE otherwise -- Use GetLastError() to get extended error information\r\n\r\nfunction HidD_GetIndexedString(HidDeviceObject: THandle;\r\n Index: Integer; Buffer: PWideChar; BufferLength: Integer): LongBool; stdcall;\r\n\r\n// Routine Description:\r\n// Returns a list of capabilities of a given hid device as described by its\r\n// preparsed data.\r\n// \r\n// Arguments:\r\n// PreparsedData The preparsed data returned from HIDCLASS.\r\n// Capabilities a HIDP_CAPS structure\r\n// \r\n// Return Value:\r\n// - HIDP_STATUS_SUCCESS\r\n// - HIDP_STATUS_INVALID_PREPARSED_DATA\r\n\r\n\r\n{$IFDEF WINXP}\r\n\r\n// (rom) new XP functions\r\n\r\nfunction HidD_GetInputReport(HidDeviceObject: THandle;\r\n Buffer: Pointer; BufferLength: ULONG): LongBool; stdcall;\r\n\r\nfunction HidD_SetOutputReport(HidDeviceObject: THandle;\r\n Buffer: Pointer; BufferLength: ULONG): LongBool; stdcall;\r\n\r\n{$ENDIF WINXP}\r\n\r\nfunction HidP_GetCaps(PreparsedData: PHIDPPreparsedData;\r\n var Capabilities: THIDPCaps): NTSTATUS; stdcall;\r\n\r\n// Routine Description:\r\n// Return a list of PHIDP_LINK_COLLECTION_NODEs used to describe the link\r\n// collection tree of this hid device. See the above description of\r\n// struct _HIDP_LINK_COLLECTION_NODE.\r\n// \r\n// Arguments:\r\n// LinkCollectionNodes - a caller allocated array into which\r\n// HidP_GetLinkCollectionNodes will store the information\r\n// \r\n// LinkCollectionNodesLength - the caller sets this value to the length of the\r\n// the array in terms of number of elements.\r\n// HidP_GetLinkCollectionNodes sets this value to the actual\r\n// number of elements set. The total number of nodes required to\r\n// describe this HID device can be found in the\r\n// NumberLinkCollectionNodes field in the HIDP_CAPS structure.\r\n\r\nfunction HidP_GetLinkCollectionNodes(LinkCollectionNodes: PHIDPLinkCollectionNode;\r\n var LinkCollectionNodesLength: ULONG; PreparsedData: PHIDPPreparsedData): NTSTATUS; stdcall;\r\n\r\nfunction HidP_GetSpecificButtonCaps(ReportType: THIDPReportType;\r\n UsagePage: TUsage; LinkCollection: Word; Usage: TUsage; ButtonCaps: PHIDPButtonCaps;\r\n var ButtonCapsLength: Word; PreparsedData: PHIDPPreparsedData): NTSTATUS; stdcall;\r\n\r\nfunction HidP_GetSpecificValueCaps(ReportType: THIDPReportType; UsagePage: TUsage;\r\n LinkCollection: Word; Usage: TUsage; ValueCaps: PHIDPValueCaps;\r\n var ValueCapsLength: Word; PreparsedData: PHIDPPreparsedData): NTSTATUS; stdcall;\r\n\r\n// Routine Description:\r\n// \r\n// Please Note: For obvious reasons HidP_SetData and HidP_GetData will not\r\n// access UsageValueArrays.\r\n// \r\n// Parameters:\r\n// ReportType One of HidP_Input, HidP_Output, or HidP_Feature.\r\n// \r\n// DataList Array of HIDP_DATA structures that will receive the data\r\n// values that are set in the given report\r\n//\r\n// DataLength As input, length in array elements of DataList. As output,\r\n// contains the number of data elements that were successfully\r\n// set by HidP_GetData. The maximum size necessary for DataList\r\n// can be determined by calling HidP_MaxDataListLength\r\n// \r\n// PreparasedData Preparsed data structure returned by HIDCLASS\r\n// \r\n// Report Buffer which to set the data into.\r\n// \r\n// ReportLength Length of Report...Report should be at least as long as the\r\n// value indicated in the HIDP_CAPS structure for the device and\r\n// the corresponding ReportType\r\n// \r\n// Return Value\r\n// HidP_GetData returns the following error codes.\r\n// \r\n// - HIDP_STATUS_SUCCESS -- upon successful retrieval of all data\r\n// from the report packet.\r\n// - HIDP_STATUS_INVALID_REPORT_TYPE -- if ReportType is not valid.\r\n// - HIDP_STATUS_INVALID_PREPARSED_DATA -- if PreparsedData is not valid\r\n// - HIDP_STATUS_INVALID_REPORT_LENGTH -- the length of the report packet is not equal\r\n// to the length specified in HIDP_CAPS\r\n// structure for the given ReportType\r\n// - HIDP_STATUS_REPORT_DOES_NOT_EXIST -- if there are no reports on this device\r\n// for the given ReportType\r\n// - HIDP_STATUS_BUFFER_TOO_SMALL -- if there are not enough array entries in\r\n// DataList to store all the indice values\r\n// in the given report. DataLength will\r\n// contain the number of array entries\r\n// required to hold all data\r\n\r\nfunction HidP_GetData(ReportType: THIDPReportType; DataList: PHIDPData;\r\n var DataLength: ULONG; PreparsedData: PHIDPPreparsedData;\r\n var Report; ReportLength: ULONG): NTSTATUS; stdcall;\r\n\r\n// Routine Description:\r\n// \r\n// Please Note: Since usage value arrays deal with multiple fields for\r\n// for one usage value, they cannot be used with HidP_SetData\r\n// and HidP_GetData. In this case,\r\n// HIDP_STATUS_IS_USAGE_VALUE_ARRAY will be returned.\r\n// \r\n// Parameters:\r\n// \r\n// ReportType One of HidP_Input, HidP_Output, or HidP_Feature.\r\n// \r\n// DataList Array of HIDP_DATA structures that contains the data values\r\n// that are to be set into the given report\r\n//\r\n// DataLength As input, length in array elements of DataList. As output,\r\n// contains the number of data elements set on successful\r\n// completion or an index into the DataList array to identify\r\n// the faulting HIDP_DATA value if an error code is returned.\r\n// \r\n// PreparasedData Preparsed data structure returned by HIDCLASS\r\n// \r\n// Report Buffer which to set the data into.\r\n// \r\n// ReportLength Length of Report...Report should be at least as long as the\r\n// value indicated in the HIDP_CAPS structure for the device and\r\n// the corresponding ReportType\r\n// \r\n// Return Value\r\n// HidP_SetData returns the following error codes. The report packet will\r\n// have all the data set up until the HIDP_DATA structure that caused the\r\n// error. DataLength, in the error case, will return this problem index.\r\n// \r\n// - HIDP_STATUS_SUCCESS -- upon successful insertion of all data\r\n// into the report packet.\r\n// - HIDP_STATUS_INVALID_REPORT_TYPE -- if ReportType is not valid.\r\n// - HIDP_STATUS_INVALID_PREPARSED_DATA -- if PreparsedData is not valid\r\n// - HIDP_STATUS_DATA_INDEX_NOT_FOUND -- if a HIDP_DATA structure referenced a\r\n// data index that does not exist for this\r\n// device's ReportType\r\n// - HIDP_STATUS_INVALID_REPORT_LENGTH -- the length of the report packet is not equal\r\n// to the length specified in HIDP_CAPS\r\n// structure for the given ReportType\r\n// - HIDP_STATUS_REPORT_DOES_NOT_EXIST -- if there are no reports on this device\r\n// for the given ReportType\r\n// - HIDP_STATUS_IS_USAGE_VALUE_ARRAY -- if one of the HIDP_DATA structures\r\n// references a usage value array.\r\n// DataLength will contain the index into\r\n// the array that was invalid\r\n// - HIDP_STATUS_BUTTON_NOT_PRESSED -- if a HIDP_DATA structure attempted\r\n// to unset a button that was not already\r\n// set in the Report\r\n// - HIDP_STATUS_INCOMPATIBLE_REPORT_ID -- a HIDP_DATA structure was found with\r\n// a valid index value but is contained\r\n// in a different report than the one\r\n// currently being processed\r\n// - HIDP_STATUS_BUFFER_TOO_SMALL -- if there are not enough entries in\r\n// a given Main Array Item to report all\r\n// buttons that have been requested to be\r\n// set\r\n\r\nfunction HidP_SetData(ReportType: THIDPReportType; DataList: PHIDPData;\r\n var DataLength: ULONG; PreparsedData: PHIDPPreparsedData;\r\n var Report; ReportLength: ULONG): NTSTATUS; stdcall;\r\n\r\n// Routine Description:\r\n// \r\n// This function returns the maximum length of HIDP_DATA elements that\r\n// HidP_GetData could return for the given report type.\r\n// \r\n// Parameters:\r\n// \r\n// ReportType One of HidP_Input, HidP_Output or HidP_Feature.\r\n// \r\n// PreparsedData Preparsed data structure returned by HIDCLASS\r\n// \r\n// Return Value:\r\n// \r\n// The length of the data list array required for the HidP_GetData function\r\n// call. If an error occurs (either HIDP_STATUS_INVALID_REPORT_TYPE or\r\n// HIDP_STATUS_INVALID_PREPARSED_DATA), this function returns 0.\r\n\r\nfunction HidP_MaxDataListLength(ReportType: THIDPReportType;\r\n PreparsedData: PHIDPPreparsedData): ULONG; stdcall;\r\n\r\n// Routine Description:\r\n// This function returns the binary values (buttons) that are set in a HID\r\n// report. Given a report packet of correct length, it searches the report\r\n// packet for each usage for the given usage page and returns them in the\r\n// usage list.\r\n// \r\n// Parameters:\r\n// ReportType One of HidP_Input, HidP_Output or HidP_Feature.\r\n// \r\n// UsagePage All of the usages in the usage list, which HidP_GetUsages will\r\n// retrieve in the report, refer to this same usage page.\r\n// If the client wishes to get usages in a packet for multiple\r\n// usage pages then that client needs to make multiple calls\r\n// to HidP_GetUsages.\r\n// \r\n// LinkCollection An optional value which can limit which usages are returned\r\n// in the UsageList to those usages that exist in a specific\r\n// LinkCollection. A non-zero value indicates the index into\r\n// the HIDP_LINK_COLLECITON_NODE list returned by\r\n// HidP_GetLinkCollectionNodes of the link collection the\r\n// usage should belong to. A value of 0 indicates this\r\n// should value be ignored.\r\n// \r\n// UsageList The usage array that will contain all the usages found in\r\n// the report packet.\r\n// \r\n// UsageLength The length of the given usage array in array elements.\r\n// On input, this value describes the length of the usage list.\r\n// On output, HidP_GetUsages sets this value to the number of\r\n// usages that was found. Use HidP_MaxUsageListLength to\r\n// determine the maximum length needed to return all the usages\r\n// that a given report packet may contain.\r\n// \r\n// PreparsedData Preparsed data structure returned by HIDCLASS\r\n// \r\n// Report The report packet.\r\n// \r\n// ReportLength Length (in bytes) of the given report packet\r\n// \r\n// \r\n// Return Value\r\n// HidP_GetUsages returns the following error codes:\r\n// \r\n// - HIDP_STATUS_SUCCESS -- upon successfully retrieving all the\r\n// usages from the report packet\r\n// - HIDP_STATUS_INVALID_REPORT_TYPE -- if ReportType is not valid.\r\n// - HIDP_STATUS_INVALID_PREPARSED_DATA -- if PreparsedData is not valid\r\n// - HIDP_STATUS_INVALID_REPORT_LENGTH -- the length of the report packet is not\r\n// equal to the length specified in\r\n// the HIDP_CAPS structure for the given\r\n// ReportType\r\n// - HIDP_STATUS_REPORT_DOES_NOT_EXIST -- if there are no reports on this device\r\n// for the given ReportType\r\n// - HIDP_STATUS_BUFFER_TOO_SMALL -- if the UsageList is not big enough to\r\n// hold all the usages found in the report\r\n// packet. If this is returned, the buffer\r\n// will contain UsageLength number of\r\n// usages. Use HidP_MaxUsageListLength to\r\n// find the maximum length needed\r\n// - HIDP_STATUS_INCOMPATIBLE_REPORT_ID -- if no usages were found but usages\r\n// that match the UsagePage and\r\n// LinkCollection specified could be found\r\n// in a report with a different report ID\r\n// - HIDP_STATUS_USAGE_NOT_FOUND -- if there are no usages in a reports for\r\n// the device and ReportType that match the\r\n// UsagePage and LinkCollection that were\r\n// specified\r\n\r\nfunction HidP_GetUsages(ReportType: THIDPReportType; UsagePage: TUsage;\r\n LinkCollection: Word; UsageList: PUsage; var UsageLength: ULONG;\r\n PreparsedData: PHIDPPreparsedData; var Report;\r\n ReportLength: ULONG): NTSTATUS; stdcall;\r\n\r\nfunction HidP_GetButtons(ReportType: THIDPReportType; UsagePage: TUsage;\r\n LinkCollection: Word; UsageList: PUsage; var UsageLength: ULONG;\r\n PreparsedData: PHIDPPreparsedData; var Report;\r\n ReportLength: ULONG): NTSTATUS; stdcall;\r\n\r\n// Routine Description:\r\n// This function returns the binary values (buttons) in a HID report.\r\n// Given a report packet of correct length, it searches the report packet\r\n// for all buttons and returns the UsagePage and Usage for each of the buttons\r\n// it finds.\r\n// \r\n// Parameters:\r\n// ReportType One of HidP_Input, HidP_Output or HidP_Feature.\r\n//\r\n// LinkCollection An optional value which can limit which usages are returned\r\n// in the ButtonList to those usages that exist in a specific\r\n// LinkCollection. A non-zero value indicates the index into\r\n// the HIDP_LINK_COLLECITON_NODE list returned by\r\n// HidP_GetLinkCollectionNodes of the link collection the\r\n// usage should belong to. A value of 0 indicates this\r\n// should value be ignored.\r\n// \r\n// ButtonList An array of USAGE_AND_PAGE structures describing all the\r\n// buttons currently ``down'' in the device.\r\n// \r\n// UsageLength The length of the given array in terms of elements.\r\n// On input, this value describes the length of the list. On\r\n// output, HidP_GetUsagesEx sets this value to the number of\r\n// usages that were found. Use HidP_MaxUsageListLength to\r\n// determine the maximum length needed to return all the usages\r\n// that a given report packet may contain.\r\n// \r\n// PreparsedData Preparsed data returned by HIDCLASS\r\n// \r\n// Report The report packet.\r\n// \r\n// ReportLength Length (in bytes) of the given report packet.\r\n// \r\n// \r\n// Return Value\r\n// HidP_GetUsagesEx returns the following error codes:\r\n// \r\n// - HIDP_STATUS_SUCCESS -- upon successfully retrieving all the\r\n// usages from the report packet\r\n// - HIDP_STATUS_INVALID_REPORT_TYPE -- if ReportType is not valid.\r\n// - HIDP_STATUS_INVALID_PREPARSED_DATA -- if PreparsedData is not valid\r\n// - HIDP_STATUS_INVALID_REPORT_LENGTH -- the length of the report packet is not\r\n// equal to the length specified in\r\n// the HIDP_CAPS structure for the given\r\n// ReportType\r\n// - HIDP_STATUS_REPORT_DOES_NOT_EXIST -- if there are no reports on this device\r\n// for the given ReportType\r\n// - HIDP_STATUS_BUFFER_TOO_SMALL -- if ButtonList is not big enough to\r\n// hold all the usages found in the report\r\n// packet. If this is returned, the buffer\r\n// will contain UsageLength number of\r\n// usages. Use HidP_MaxUsageListLength to\r\n// find the maximum length needed\r\n// - HIDP_STATUS_INCOMPATIBLE_REPORT_ID -- if no usages were found but usages\r\n// that match the specified LinkCollection\r\n// exist in report with a different report\r\n// ID.\r\n// - HIDP_STATUS_USAGE_NOT_FOUND -- if there are no usages in any reports that\r\n// match the LinkCollection parameter\r\n\r\nfunction HidP_GetUsagesEx(ReportType: THIDPReportType; LinkCollection: Word;\r\n UsageList: PUsageAndPage; var UsageLength: ULONG;\r\n PreparsedData: PHIDPPreparsedData; var Report;\r\n ReportLength: ULONG): NTSTATUS; stdcall;\r\n\r\nfunction HidP_GetButtonsEx(ReportType: THIDPReportType; LinkCollection: Word;\r\n UsageList: PUsageAndPage; var UsageLength: ULONG;\r\n PreparsedData: PHIDPPreparsedData; var Report;\r\n ReportLength: ULONG): NTSTATUS; stdcall;\r\n\r\n// Routine Description:\r\n// This function sets binary values (buttons) in a report. Given an\r\n// initialized packet of correct length, it modifies the report packet so that\r\n// each element in the given list of usages has been set in the report packet.\r\n// For example, in an output report with 5 LEDs, each with a given usage,\r\n// an application could turn on any subset of these lights by placing their\r\n// usages in any order into the usage array (UsageList). HidP_SetUsages would,\r\n// in turn, set the appropriate bit or add the corresponding byte into the\r\n// HID Main Array Item.\r\n// \r\n// A properly initialized Report packet is one of the correct byte length,\r\n// and all zeros.\r\n// \r\n// NOTE: A packet that has already been set with a call to a HidP_Set routine\r\n// can also be passed in. This routine then sets processes the UsageList\r\n// in the same fashion but verifies that the ReportID already set in\r\n// Report matches the report ID for the given usages.\r\n// \r\n// Parameters:\r\n// ReportType One of HidP_Input, HidP_Output or HidP_Feature.\r\n// \r\n// UsagePage All of the usages in the usage array, which HidP_SetUsages will\r\n// set in the report, refer to this same usage page.\r\n// If a client wishes to set usages in a report for multiple\r\n// usage pages then that client needs to make multiple calls to\r\n// HidP_SetUsages for each of the usage pages.\r\n// \r\n// UsageList A usage array containing the usages that HidP_SetUsages will set in\r\n// the report packet.\r\n// \r\n// UsageLength The length of the given usage array in array elements.\r\n// The parser will set this value to the position in the usage\r\n// array where it stopped processing. If successful, UsageLength\r\n// will be unchanged. In any error condition, this parameter\r\n// reflects how many of the usages in the usage list have\r\n// actually been set by the parser. This is useful for finding\r\n// the usage in the list which caused the error.\r\n// \r\n// PreparsedData The preparsed data recevied from HIDCLASS\r\n// \r\n// Report The report packet.\r\n// \r\n// ReportLength Length of the given report packet...Must be equal to the\r\n// value reported in the HIDP_CAPS structure for the device\r\n// and corresponding report type.\r\n// \r\n// Return Value\r\n// HidP_SetUsages returns the following error codes. On error, the report packet\r\n// will be correct up until the usage element that caused the error.\r\n// \r\n// - HIDP_STATUS_SUCCESS -- upon successful insertion of all usages\r\n// into the report packet.\r\n// - HIDP_STATUS_INVALID_REPORT_TYPE -- if ReportType is not valid.\r\n// - HIDP_STATUS_INVALID_PREPARSED_DATA -- if PreparsedData is not valid\r\n// - HIDP_STATUS_INVALID_REPORT_LENGTH -- the length of the report packet is not\r\n// equal to the length specified in\r\n// the HIDP_CAPS structure for the given\r\n// ReportType\r\n// - HIDP_STATUS_REPORT_DOES_NOT_EXIST -- if there are no reports on this device\r\n// for the given ReportType\r\n// - HIDP_STATUS_INCOMPATIBLE_REPORT_ID -- if a usage was found that exists in a\r\n// different report. If the report is\r\n// zero-initialized on entry the first\r\n// usage in the list will determine which\r\n// report ID is used. Otherwise, the\r\n// parser will verify that usage matches\r\n// the passed in report's ID\r\n// - HIDP_STATUS_USAGE_NOT_FOUND -- if the usage does not exist for any\r\n// report (no matter what the report ID)\r\n// for the given report type.\r\n// - HIDP_STATUS_BUFFER_TOO_SMALL -- if there are not enough entries in a\r\n// given Main Array Item to list all of\r\n// the given usages. The caller needs\r\n// to split his request into more than\r\n// one call\r\n\r\nfunction HidP_SetUsages(ReportType: THIDPReportType; UsagePage: TUsage;\r\n LinkCollection: Word; UsageList: PUsage; var UsageLength: ULONG;\r\n PreparsedData: PHIDPPreparsedData; var Report;\r\n ReportLength: ULONG): NTSTATUS; stdcall;\r\n\r\nfunction HidP_SetButtons(ReportType: THIDPReportType; UsagePage: TUsage;\r\n LinkCollection: Word; ButtonList: PUsage; var ButtonLength: ULONG;\r\n PreparsedData: PHIDPPreparsedData; var Report;\r\n ReportLength: ULONG): NTSTATUS; stdcall;\r\n\r\n// Routine Description:\r\n// This function unsets (turns off) binary values (buttons) in the report. Given\r\n// an initialized packet of correct length, it modifies the report packet so\r\n// that each element in the given list of usages has been unset in the\r\n// report packet.\r\n// \r\n// This function is the \"undo\" operation for SetUsages. If the given usage\r\n// is not already set in the Report, it will return an error code of\r\n// HIDP_STATUS_BUTTON_NOT_PRESSED. If the button is pressed, HidP_UnsetUsages\r\n// will unset the appropriate bit or remove the corresponding index value from\r\n// the HID Main Array Item.\r\n// \r\n// A properly initialized Report packet is one of the correct byte length,\r\n// and all zeros..\r\n// \r\n// NOTE: A packet that has already been set with a call to a HidP_Set routine\r\n// can also be passed in. This routine then processes the UsageList\r\n// in the same fashion but verifies that the ReportID already set in\r\n// Report matches the report ID for the given usages.\r\n// \r\n// Parameters:\r\n// ReportType One of HidP_Input, HidP_Output or HidP_Feature.\r\n// \r\n// UsagePage All of the usages in the usage array, which HidP_UnsetUsages will\r\n// unset in the report, refer to this same usage page.\r\n// If a client wishes to unset usages in a report for multiple\r\n// usage pages then that client needs to make multiple calls to\r\n// HidP_UnsetUsages for each of the usage pages.\r\n// \r\n// UsageList A usage array containing the usages that HidP_UnsetUsages will\r\n// unset in the report packet.\r\n// \r\n// UsageLength The length of the given usage array in array elements.\r\n// The parser will set this value to the position in the usage\r\n// array where it stopped processing. If successful, UsageLength\r\n// will be unchanged. In any error condition, this parameter\r\n// reflects how many of the usages in the usage list have\r\n// actually been unset by the parser. This is useful for finding\r\n// the usage in the list which caused the error.\r\n// \r\n// PreparsedData The preparsed data recevied from HIDCLASS\r\n// \r\n// Report The report packet.\r\n// \r\n// ReportLength Length of the given report packet...Must be equal to the\r\n// value reported in the HIDP_CAPS structure for the device\r\n// and corresponding report type.\r\n// \r\n// Return Value\r\n// HidP_UnsetUsages returns the following error codes. On error, the report\r\n// packet will be correct up until the usage element that caused the error.\r\n// \r\n// - HIDP_STATUS_SUCCESS -- upon successful \"unsetting\" of all usages\r\n// in the report packet.\r\n// - HIDP_STATUS_INVALID_REPORT_TYPE -- if ReportType is not valid.\r\n// - HIDP_STATUS_INVALID_PREPARSED_DATA -- if PreparsedData is not valid\r\n// - HIDP_STATUS_INVALID_REPORT_LENGTH -- the length of the report packet is not\r\n// equal to the length specified in\r\n// the HIDP_CAPS structure for the given\r\n// ReportType\r\n// - HIDP_STATUS_REPORT_DOES_NOT_EXIST -- if there are no reports on this device\r\n// for the given ReportType\r\n// - HIDP_STATUS_INCOMPATIBLE_REPORT_ID -- if a usage was found that exists in a\r\n// different report. If the report is\r\n// zero-initialized on entry the first\r\n// usage in the list will determine which\r\n// report ID is used. Otherwise, the\r\n// parser will verify that usage matches\r\n// the passed in report's ID\r\n// - HIDP_STATUS_USAGE_NOT_FOUND -- if the usage does not exist for any\r\n// report (no matter what the report ID)\r\n// for the given report type.\r\n// - HIDP_STATUS_BUTTON_NOT_PRESSED -- if a usage corresponds to a button that\r\n// is not already set in the given report\r\n\r\nfunction HidP_UnsetUsages(ReportType: THIDPReportType; UsagePage: TUsage;\r\n LinkCollection: Word; UsageList: PUsage; var UsageLength: ULONG;\r\n PreparsedData: PHIDPPreparsedData; var Report;\r\n ReportLength: ULONG): NTSTATUS; stdcall;\r\n\r\nfunction HidP_UnsetButtons(ReportType: THIDPReportType; UsagePage: TUsage;\r\n LinkCollection: Word; ButtonList: PUsage; var ButtonLength: ULONG;\r\n PreparsedData: PHIDPPreparsedData; var Report;\r\n ReportLength: ULONG): NTSTATUS; stdcall;\r\n\r\n// Routine Description:\r\n// This function returns the maximum number of usages that a call to\r\n// HidP_GetUsages or HidP_GetUsagesEx could return for a given HID report.\r\n// If calling for number of usages returned by HidP_GetUsagesEx, use 0 as\r\n// the UsagePage value.\r\n// \r\n// Parameters:\r\n// ReportType One of HidP_Input, HidP_Output or HidP_Feature.\r\n// \r\n// UsagePage Specifies the optional UsagePage to query for. If 0, will\r\n// return all the maximum number of usage values that could be\r\n// returned for a given ReportType. If non-zero, will return\r\n// the maximum number of usages that would be returned for the\r\n// ReportType with the given UsagePage.\r\n// \r\n// PreparsedData Preparsed data returned from HIDCLASS\r\n// \r\n// Return Value:\r\n// The length of the usage list array required for the HidP_GetUsages or\r\n// HidP_GetUsagesEx function call. If an error occurs (such as\r\n// HIDP_STATUS_INVALID_REPORT_TYPE or HIDP_INVALID_PREPARSED_DATA, this\r\n// returns 0.\r\n\r\nfunction HidP_MaxUsageListLength(ReportType: THIDPReportType; UsagePage: TUsage;\r\n PreparsedData: PHIDPPreparsedData): ULONG; stdcall;\r\n\r\nfunction HidP_MaxButtonListLength(ReportType: THIDPReportType; UsagePage: TUsage;\r\n PreparsedData: PHIDPPreparsedData): ULONG; stdcall;\r\n\r\n// Description\r\n// HidP_GetUsageValue retrieves the value from the HID Report for the usage\r\n// specified by the combination of usage page, usage and link collection.\r\n// If a report packet contains two different fields with the same\r\n// Usage and UsagePage, they can be distinguished with the optional\r\n// LinkCollection field value.\r\n// \r\n// Parameters:\r\n// \r\n// ReportType One of HidP_Input or HidP_Feature.\r\n// \r\n// UsagePage The usage page to which the given usage refers.\r\n// \r\n// LinkCollection (Optional) This value can be used to differentiate\r\n// between two fields that may have the same\r\n// UsagePage and Usage but exist in different\r\n// collections. If the link collection value\r\n// is zero, this function will set the first field\r\n// it finds that matches the usage page and\r\n// usage.\r\n// \r\n// Usage The usage whose value HidP_GetUsageValue will retrieve\r\n// \r\n// UsageValue The raw value that is set for the specified field in the report\r\n// buffer. This value will either fall within the logical range\r\n// or if NULL values are allowed, a number outside the range to\r\n// indicate a NULL\r\n// \r\n// PreparsedData The preparsed data returned for HIDCLASS\r\n// \r\n// Report The report packet.\r\n// \r\n// ReportLength Length (in bytes) of the given report packet.\r\n// \r\n// \r\n// Return Value:\r\n// HidP_GetUsageValue returns the following error codes:\r\n// \r\n// - HIDP_STATUS_SUCCESS -- upon successfully retrieving the value\r\n// from the report packet\r\n// - HIDP_STATUS_INVALID_REPORT_TYPE -- if ReportType is not valid.\r\n// - HIDP_STATUS_INVALID_PREPARSED_DATA -- if PreparsedData is not valid\r\n// - HIDP_STATUS_INVALID_REPORT_LENGTH -- the length of the report packet is not\r\n// equal to the length specified in\r\n// the HIDP_CAPS structure for the given\r\n// ReportType\r\n// - HIDP_STATUS_REPORT_DOES_NOT_EXIST -- if there are no reports on this device\r\n// for the given ReportType\r\n// - HIDP_STATUS_INCOMPATIBLE_REPORT_ID -- the specified usage page, usage and\r\n// link collection exist but exists in\r\n// a report with a different report ID\r\n// than the report being passed in. To\r\n// set this value, call HidP_GetUsageValue\r\n// again with a different report packet\r\n// - HIDP_STATUS_USAGE_NOT_FOUND -- if the usage page, usage, and link\r\n// collection combination does not exist\r\n// in any reports for this ReportType\r\n\r\nfunction HidP_GetUsageValue(ReportType: THIDPReportType; UsagePage: TUsage;\r\n LinkCollection: Word; Usage: TUsage; var UsageValue: ULONG;\r\n PreparsedData: PHIDPPreparsedData; var Report;\r\n ReportLength: ULONG): NTSTATUS; stdcall;\r\n\r\n// Description\r\n// HidP_GetScaledUsageValue retrieves a UsageValue from the HID report packet\r\n// in the field corresponding to the given usage page and usage. If a report\r\n// packet contains two different fields with the same Usage and UsagePage,\r\n// they can be distinguished with the optional LinkCollection field value.\r\n//\r\n// If the specified field has a defined physical range, this function converts\r\n// the logical value that exists in the report packet to the corresponding\r\n// physical value. If a physical range does not exist, the function will\r\n// return the logical value. This function will check to verify that the\r\n// logical value in the report falls within the declared logical range.\r\n// \r\n// When doing the conversion between logical and physical values, this\r\n// function assumes a linear extrapolation between the physical max/min and\r\n// the logical max/min. (Where logical is the values reported by the device\r\n// and physical is the value returned by this function). If the data field\r\n// size is less than 32 bits, then HidP_GetScaledUsageValue will sign extend\r\n// the value to 32 bits.\r\n// \r\n// If the range checking fails but the field has NULL values, the function\r\n// will set UsageValue to 0 and return HIDP_STATUS_NULL. Otherwise, it\r\n// returns a HIDP_STATUS_OUT_OF_RANGE error.\r\n// \r\n// Parameters:\r\n// \r\n// ReportType One of HidP_Output or HidP_Feature.\r\n// \r\n// UsagePage The usage page to which the given usage refers.\r\n// \r\n// LinkCollection (Optional) This value can be used to differentiate\r\n// between two fields that may have the same\r\n// UsagePage and Usage but exist in different\r\n// collections. If the link collection value\r\n// is zero, this function will retrieve the first\r\n// field it finds that matches the usage page\r\n// and usage.\r\n// \r\n// Usage The usage whose value HidP_GetScaledUsageValue will retrieve\r\n// \r\n// UsageValue The value retrieved from the report buffer. See the routine\r\n// description above for the different interpretations of this\r\n// value\r\n// \r\n// PreparsedData The preparsed data returned from HIDCLASS\r\n// \r\n// Report The report packet.\r\n// \r\n// ReportLength Length (in bytes) of the given report packet.\r\n// \r\n// \r\n// Return Value:\r\n// HidP_GetScaledUsageValue returns the following error codes:\r\n// \r\n// - HIDP_STATUS_SUCCESS -- upon successfully retrieving the value\r\n// from the report packet\r\n// - HIDP_STATUS_NULL -- if the report packet had a NULL value\r\n// set\r\n// - HIDP_STATUS_INVALID_REPORT_TYPE -- if ReportType is not valid.\r\n// - HIDP_STATUS_INVALID_PREPARSED_DATA -- if PreparsedData is not valid\r\n// - HIDP_STATUS_INVALID_REPORT_LENGTH -- the length of the report packet is not\r\n// equal to the length specified in\r\n// the HIDP_CAPS structure for the given\r\n// ReportType\r\n// - HIDP_STATUS_VALUE_OUT_OF_RANGE -- if the value retrieved from the packet\r\n// falls outside the logical range and\r\n// the field does not support NULL values\r\n// - HIDP_STATUS_BAD_LOG_PHY_VALUES -- if the field has a physical range but\r\n// either the logical range is invalid\r\n// (max <= min) or the physical range is\r\n// invalid\r\n// - HIDP_STATUS_INCOMPATIBLE_REPORT_ID -- the specified usage page, usage and\r\n// link collection exist but exists in\r\n// a report with a different report ID\r\n// than the report being passed in. To\r\n// set this value, call\r\n// HidP_GetScaledUsageValue with a\r\n// different report packet\r\n// - HIDP_STATUS_USAGE_NOT_FOUND -- if the usage page, usage, and link\r\n// collection combination does not exist\r\n// in any reports for this ReportType\r\n\r\nfunction HidP_GetScaledUsageValue(ReportType: THIDPReportType; UsagePage: TUsage;\r\n LinkCollection: Word; Usage: TUsage; var UsageValue: Integer;\r\n PreparsedData: PHIDPPreparsedData; var Report;\r\n ReportLength: ULONG): NTSTATUS; stdcall;\r\n\r\n// Routine Descripton:\r\n// A usage value array occurs when the last usage in the list of usages\r\n// describing a main item must be repeated because there are less usages defined\r\n// than there are report counts declared for the given main item. In this case\r\n// a single value cap is allocated for that usage and the report count of that\r\n// value cap is set to reflect the number of fields to which that usage refers.\r\n// \r\n// HidP_GetUsageValueArray returns the raw bits for that usage which spans\r\n// more than one field in a report.\r\n// \r\n// NOTE: This function currently does not support value arrays where the\r\n// ReportSize for each of the fields in the array is not a multiple\r\n// of 8 bits.\r\n// \r\n// The UsageValue buffer will have the raw values as they are set\r\n// in the report packet.\r\n// \r\n// Parameters:\r\n//\r\n// ReportType One of HidP_Input, HidP_Output or HidP_Feature.\r\n// \r\n// UsagePage The usage page to which the given usage refers.\r\n// \r\n// LinkCollection (Optional) This value can be used to differentiate\r\n// between two fields that may have the same\r\n// UsagePage and Usage but exist in different\r\n// collections. If the link collection value\r\n// is zero, this function will set the first field\r\n// it finds that matches the usage page and\r\n// usage.\r\n// \r\n// Usage The usage whose value HidP_GetUsageValueArray will retreive.\r\n// \r\n// UsageValue A pointer to an array of characters where the value will be\r\n// placed. The number of BITS required is found by multiplying the\r\n// BitSize and ReportCount fields of the Value Cap for this\r\n// control. The least significant bit of this control found in the\r\n// given report will be placed in the least significant bit location\r\n// of the buffer (little-endian format), regardless of whether\r\n// or not the field is byte aligned or if the BitSize is a multiple\r\n// of sizeof (CHAR).\r\n// \r\n// See note above about current implementation limitations\r\n//\r\n// UsageValueByteLength\r\n// the length of the given UsageValue buffer.\r\n// \r\n// PreparsedData The preparsed data returned by the HIDCLASS\r\n// \r\n// Report The report packet.\r\n// \r\n// ReportLength Length of the given report packet.\r\n// \r\n// Return Value:\r\n//\r\n// - HIDP_STATUS_SUCCESS -- upon successfully retrieving the value\r\n// from the report packet\r\n// - HIDP_STATUS_INVALID_REPORT_TYPE -- if ReportType is not valid.\r\n// - HIDP_STATUS_INVALID_PREPARSED_DATA -- if PreparsedData is not valid\r\n// - HIDP_STATUS_INVALID_REPORT_LENGTH -- the length of the report packet is not\r\n// equal to the length specified in\r\n// the HIDP_CAPS structure for the given\r\n// ReportType\r\n// - HIDP_STATUS_NOT_VALUE_ARRAY -- if the control specified is not a\r\n// value array -- a value array will have\r\n// a ReportCount field in the\r\n// HIDP_VALUE_CAPS structure that is > 1\r\n// Use HidP_GetUsageValue instead\r\n// - HIDP_STATUS_BUFFER_TOO_SMALL -- if the size of the passed in buffer in\r\n// which to return the array is too small\r\n// (ie. has fewer values than the number of\r\n// fields in the array\r\n// - HIDP_STATUS_NOT_IMPLEMENTED -- if the usage value array has field sizes\r\n// that are not multiples of 8 bits, this\r\n// error code is returned since the function\r\n// currently does not handle getting values\r\n// from such arrays.\r\n// - HIDP_STATUS_INCOMPATIBLE_REPORT_ID -- the specified usage page, usage and\r\n// link collection exist but exists in\r\n// a report with a different report ID\r\n// than the report being passed in. To\r\n// set this value, call\r\n// HidP_GetUsageValueArray with a\r\n// different report packet\r\n// - HIDP_STATUS_USAGE_NOT_FOUND -- if the usage page, usage, and link\r\n// collection combination does not exist\r\n// in any reports for this ReportType\r\n\r\nfunction HidP_GetUsageValueArray(ReportType: THIDPReportType; UsagePage: TUsage;\r\n LinkCollection: Word; Usage: TUsage; UsageValue: PAnsiChar;\r\n UsageValueByteLength: Word; PreparsedData: PHIDPPreparsedData;\r\n var Report; ReportLength: ULONG): NTSTATUS; stdcall;\r\n\r\n// Description:\r\n// HidP_SetUsageValue inserts a value into the HID Report Packet in the field\r\n// corresponding to the given usage page and usage. HidP_SetUsageValue\r\n// casts this value to the appropriate bit length. If a report packet\r\n// contains two different fields with the same Usage and UsagePage,\r\n// they can be distinguished with the optional LinkCollection field value.\r\n// Using this function sets the raw value into the report packet with\r\n// no checking done as to whether it actually falls within the logical\r\n// minimum/logical maximum range. Use HidP_SetScaledUsageValue for this...\r\n// \r\n// NOTE: Although the UsageValue parameter is a ULONG, any casting that is\r\n// done will preserve or sign-extend the value. The value being set\r\n// should be considered a LONG value and will be treated as such by\r\n// this function.\r\n// \r\n// Parameters:\r\n// \r\n// ReportType One of HidP_Output or HidP_Feature.\r\n// \r\n// UsagePage The usage page to which the given usage refers.\r\n// \r\n// LinkCollection (Optional) This value can be used to differentiate\r\n// between two fields that may have the same\r\n// UsagePage and Usage but exist in different\r\n// collections. If the link collection value\r\n// is zero, this function will set the first field\r\n// it finds that matches the usage page and\r\n// usage.\r\n// \r\n// Usage The usage whose value HidP_SetUsageValue will set.\r\n// \r\n// UsageValue The raw value to set in the report buffer. This value must be within\r\n// the logical range or if a NULL value this value should be the\r\n// most negative value that can be represented by the number of bits\r\n// for this field.\r\n// \r\n// PreparsedData The preparsed data returned for HIDCLASS\r\n// \r\n// Report The report packet.\r\n// \r\n// ReportLength Length (in bytes) of the given report packet.\r\n// \r\n// \r\n// Return Value:\r\n// HidP_SetUsageValue returns the following error codes:\r\n// \r\n// - HIDP_STATUS_SUCCESS -- upon successfully setting the value\r\n// in the report packet\r\n// - HIDP_STATUS_INVALID_REPORT_TYPE -- if ReportType is not valid.\r\n// - HIDP_STATUS_INVALID_PREPARSED_DATA -- if PreparsedData is not valid\r\n// - HIDP_STATUS_INVALID_REPORT_LENGTH -- the length of the report packet is not\r\n// equal to the length specified in\r\n// the HIDP_CAPS structure for the given\r\n// ReportType\r\n// - HIDP_STATUS_REPORT_DOES_NOT_EXIST -- if there are no reports on this device\r\n// for the given ReportType\r\n// - HIDP_STATUS_INCOMPATIBLE_REPORT_ID -- the specified usage page, usage and\r\n// link collection exist but exists in\r\n// a report with a different report ID\r\n// than the report being passed in. To\r\n// set this value, call HidP_SetUsageValue\r\n// again with a zero-initizialed report\r\n// packet\r\n// - HIDP_STATUS_USAGE_NOT_FOUND -- if the usage page, usage, and link\r\n// collection combination does not exist\r\n// in any reports for this ReportType\r\n\r\nfunction HidP_SetUsageValue(ReportType: THIDPReportType; UsagePage: TUsage;\r\n LinkCollection: Word; Usage: TUsage; UsageValue: ULONG;\r\n PreparsedData: PHIDPPreparsedData; var Report;\r\n ReportLength: ULONG): NTSTATUS; stdcall;\r\n\r\n// Description:\r\n// HidP_SetScaledUsageValue inserts the UsageValue into the HID report packet\r\n// in the field corresponding to the given usage page and usage. If a report\r\n// packet contains two different fields with the same Usage and UsagePage,\r\n// they can be distinguished with the optional LinkCollection field value.\r\n// \r\n// If the specified field has a defined physical range, this function converts\r\n// the physical value specified to the corresponding logical value for the\r\n// report. If a physical value does not exist, the function will verify that\r\n// the value specified falls within the logical range and set according.\r\n// \r\n// If the range checking fails but the field has NULL values, the function will\r\n// set the field to the defined NULL value (most negative number possible) and\r\n// return HIDP_STATUS_NULL. In other words, use this function to set NULL\r\n// values for a given field by passing in a value that falls outside the\r\n// physical range if it is defined or the logical range otherwise.\r\n// \r\n// If the field does not support NULL values, an out of range error will be\r\n// returned instead.\r\n// \r\n// Parameters:\r\n// \r\n// ReportType One of HidP_Output or HidP_Feature.\r\n// \r\n// UsagePage The usage page to which the given usage refers.\r\n// \r\n// LinkCollection (Optional) This value can be used to differentiate\r\n// between two fields that may have the same\r\n// UsagePage and Usage but exist in different\r\n// collections. If the link collection value\r\n// is zero, this function will set the first field\r\n// it finds that matches the usage page and\r\n// usage.\r\n// \r\n// Usage The usage whose value HidP_SetScaledUsageValue will set.\r\n// \r\n// UsageValue The value to set in the report buffer. See the routine\r\n// description above for the different interpretations of this\r\n// value\r\n// \r\n// PreparsedData The preparsed data returned from HIDCLASS\r\n// \r\n// Report The report packet.\r\n// \r\n// ReportLength Length (in bytes) of the given report packet.\r\n// \r\n// \r\n// Return Value:\r\n// HidP_SetScaledUsageValue returns the following error codes:\r\n// \r\n// - HIDP_STATUS_SUCCESS -- upon successfully setting the value\r\n// in the report packet\r\n// - HIDP_STATUS_NULL -- upon successfully setting the value\r\n// in the report packet as a NULL value\r\n// - HIDP_STATUS_INVALID_REPORT_TYPE -- if ReportType is not valid.\r\n// - HIDP_STATUS_INVALID_PREPARSED_DATA -- if PreparsedData is not valid\r\n// - HIDP_STATUS_INVALID_REPORT_LENGTH -- the length of the report packet is not\r\n// equal to the length specified in\r\n// the HIDP_CAPS structure for the given\r\n// ReportType\r\n// - HIDP_STATUS_VALUE_OUT_OF_RANGE -- if the value specified failed to fall\r\n// within the physical range if it exists\r\n// or within the logical range otherwise\r\n// and the field specified by the usage\r\n// does not allow NULL values\r\n// - HIDP_STATUS_BAD_LOG_PHY_VALUES -- if the field has a physical range but\r\n// either the logical range is invalid\r\n// (max <= min) or the physical range is\r\n// invalid\r\n// - HIDP_STATUS_INCOMPATIBLE_REPORT_ID -- the specified usage page, usage and\r\n// link collection exist but exists in\r\n// a report with a different report ID\r\n// than the report being passed in. To\r\n// set this value, call\r\n// HidP_SetScaledUsageValue again with\r\n// a zero-initialized report packet\r\n// - HIDP_STATUS_USAGE_NOT_FOUND -- if the usage page, usage, and link\r\n// collection combination does not exist\r\n// in any reports for this ReportType\r\n\r\nfunction HidP_SetScaledUsageValue(ReportType: THIDPReportType; UsagePage: TUsage;\r\n LinkCollection: Word; Usage: TUsage; UsageValue: Integer;\r\n PreparsedData: PHIDPPreparsedData; var Report;\r\n ReportLength: ULONG): NTSTATUS; stdcall;\r\n\r\n// Routine Descripton:\r\n// A usage value array occurs when the last usage in the list of usages\r\n// describing a main item must be repeated because there are less usages defined\r\n// than there are report counts declared for the given main item. In this case\r\n// a single value cap is allocated for that usage and the report count of that\r\n// value cap is set to reflect the number of fields to which that usage refers.\r\n// \r\n// HidP_SetUsageValueArray sets the raw bits for that usage which spans\r\n// more than one field in a report.\r\n// \r\n// NOTE: This function currently does not support value arrays where the\r\n// ReportSize for each of the fields in the array is not a multiple\r\n// of 8 bits.\r\n// \r\n// The UsageValue buffer should have the values set as they would appear\r\n// in the report buffer. If this function supported non 8-bit multiples\r\n// for the ReportSize then caller should format the input buffer so that\r\n// each new value begins at the bit immediately following the last bit\r\n// of the previous value\r\n// \r\n// Parameters:\r\n//\r\n// ReportType One of HidP_Output or HidP_Feature.\r\n// \r\n// UsagePage The usage page to which the given usage refers.\r\n// \r\n// LinkCollection (Optional) This value can be used to differentiate\r\n// between two fields that may have the same\r\n// UsagePage and Usage but exist in different\r\n// collections. If the link collection value\r\n// is zero, this function will set the first field\r\n// it finds that matches the usage page and\r\n// usage.\r\n// \r\n// Usage The usage whose value array HidP_SetUsageValueArray will set.\r\n// \r\n// UsageValue The buffer with the values to set into the value array.\r\n// The number of BITS required is found by multiplying the\r\n// BitSize and ReportCount fields of the Value Cap for this\r\n// control. The least significant bit of this control found in the\r\n// given report will be placed in the least significan bit location\r\n// of the array given (little-endian format), regardless of whether\r\n// or not the field is byte alligned or if the BitSize is a multiple\r\n// of sizeof (CHAR).\r\n// \r\n// See the above note for current implementation limitations.\r\n// \r\n// UsageValueByteLength Length of the UsageValue buffer (in bytes)\r\n// \r\n// PreparsedData The preparsed data returned from HIDCLASS\r\n// \r\n// Report The report packet.\r\n//\r\n// ReportLength Length (in bytes) of the given report packet.\r\n// \r\n// \r\n// Return Value:\r\n// - HIDP_STATUS_SUCCESS -- upon successfully setting the value\r\n// array in the report packet\r\n// - HIDP_STATUS_INVALID_REPORT_TYPE -- if ReportType is not valid.\r\n// - HIDP_STATUS_INVALID_PREPARSED_DATA -- if PreparsedData is not valid\r\n// - HIDP_STATUS_INVALID_REPORT_LENGTH -- the length of the report packet is not\r\n// equal to the length specified in\r\n// the HIDP_CAPS structure for the given\r\n// ReportType\r\n// - HIDP_STATUS_REPORT_DOES_NOT_EXIST -- if there are no reports on this device\r\n// for the given ReportType\r\n// - HIDP_STATUS_NOT_VALUE_ARRAY -- if the control specified is not a\r\n// value array -- a value array will have\r\n// a ReportCount field in the\r\n// HIDP_VALUE_CAPS structure that is > 1\r\n// Use HidP_SetUsageValue instead\r\n// - HIDP_STATUS_BUFFER_TOO_SMALL -- if the size of the passed in buffer with\r\n// the values to set is too small (ie. has\r\n// fewer values than the number of fields in\r\n// the array\r\n// - HIDP_STATUS_NOT_IMPLEMENTED -- if the usage value array has field sizes\r\n// that are not multiples of 8 bits, this\r\n// error code is returned since the function\r\n// currently does not handle setting into\r\n// such arrays.\r\n// - HIDP_STATUS_INCOMPATIBLE_REPORT_ID -- the specified usage page, usage and\r\n// link collection exist but exists in\r\n// a report with a different report ID\r\n// than the report being passed in. To\r\n// set this value, call\r\n// HidP_SetUsageValueArray again with\r\n// a zero-initialized report packet\r\n// - HIDP_STATUS_USAGE_NOT_FOUND -- if the usage page, usage, and link\r\n// collection combination does not exist\r\n// in any reports for this ReportType\r\n\r\nfunction HidP_SetUsageValueArray(ReportType: THIDPReportType; UsagePage: TUsage;\r\n LinkCollection: Word; Usage: TUsage; UsageValue: PAnsiChar;\r\n UsageValueByteLength: Word; PreparsedData: PHIDPPreparsedData;\r\n var Report; ReportLength: ULONG): NTSTATUS; stdcall;\r\n\r\n// Routine Description:\r\n// This function will return the difference between a two lists of usages\r\n// (as might be returned from HidP_GetUsages), In other words, it will return\r\n// return a list of usages that are in the current list but not the previous\r\n// list as well as a list of usages that are in the previous list but not\r\n// the current list.\r\n// \r\n// Parameters:\r\n// \r\n// PreviousUsageList The list of usages before.\r\n// CurrentUsageList The list of usages now.\r\n// BreakUsageList Previous - Current.\r\n// MakeUsageList Current - Previous.\r\n// UsageListLength Represents the length of the usage lists in array\r\n// elements. If comparing two lists with a differing\r\n// number of array elements, this value should be\r\n// the size of the larger of the two lists. Any\r\n// zero found with a list indicates an early termination\r\n// of the list and any usages found after the first zero\r\n// will be ignored.\r\n\r\nfunction HidP_UsageListDifference(PreviousUsageList: PUsage;\r\n CurrentUsageList: PUsage; BreakUsageList: PUsage;\r\n MakeUsageList: PUsage; UsageListLength: ULONG): NTSTATUS; stdcall;\r\n\r\n// (rom) these two functions are prototyped in hidpi.h\r\n// (rom) but are missing in all HID.DLL versions\r\n\r\n// function HidP_UsageAndPageListDifference(PreviousUsageList: PUsageAndPage;\r\n// CurrentUsageList: PUsageAndPage; BreakUsageList: PUsageAndPage;\r\n// MakeUsageList: PUsageAndPage; UsageListLength: ULONG):NTSTATUS; stdcall;\r\n\r\n// function HidP_TranslateUsageAndPagesToI8042ScanCodes(ChangedUsageList: PUsageAndPage;\r\n// UsageListLength: ULONG; KeyAction: THIDPKeyboardDirection;\r\n// var ModifierState: THIDPKeyboardModifierState;\r\n// InsertCodesProcedure: THIDPInsertScanCodes;\r\n// InsertCodesContext: Pointer): NTSTATUS; stdcall;\r\n\r\nfunction HidP_TranslateUsagesToI8042ScanCodes(ChangedUsageList: PUsage;\r\n UsageListLength: ULONG; KeyAction: THIDPKeyboardDirection;\r\n var ModifierState: THIDPKeyboardModifierState;\r\n InsertCodesProcedure: THIDPInsertScanCodes;\r\n InsertCodesContext: Pointer): NTSTATUS; stdcall;\r\n\r\n// Description:\r\n// Given a data index from the value or button capabilities of a given control\r\n// return any extended attributes for the control if any exist.\r\n// \r\n// Parameters:\r\n// ReportType One of HidP_Input, HidP_Output, or HidP_Feature.\r\n// \r\n// DataIndex The data index for the given control, found in the capabilities\r\n// structure for that control\r\n// \r\n// PreparsedData The preparsed data returned from HIDCLASS.\r\n// \r\n// Attributes Pointer to a buffer into which the extended attribute data will\r\n// be copied.\r\n// \r\n// LengthAttributes Length of the given buffer in bytes.\r\n//\r\n// Return Value\r\n// HIDP_STATUS_SUCCESS\r\n// HIDP_STATUS_DATA_INDEX_NOT_FOUND\r\n\r\n{$IFDEF WIN2000}\r\n\r\n// (rom) This function is not in the HID.DLL of Windows 98\r\n// (rom) never call it unless you have Windows 98 SE or Windows 2000\r\n\r\nfunction HidP_GetExtendedAttributes(ReportType: THIDPReportType;\r\n DataIndex: Word; PreparsedData: PHIDPPreparsedData;\r\n Attributes: PHIDPExtendedAttributes;\r\n var LengthAttributes: ULONG): NTSTATUS; stdcall;\r\n\r\n// Routine Description:\r\n// \r\n// Initialize a report based on the given report ID.\r\n// \r\n// Parameters:\r\n// \r\n// ReportType One of HidP_Input, HidP_Output, or HidP_Feature.\r\n//\r\n// PreparsedData Preparsed data structure returned by HIDCLASS\r\n// \r\n// Report Buffer which to set the data into.\r\n// \r\n// ReportLength Length of Report...Report should be at least as long as the\r\n// value indicated in the HIDP_CAPS structure for the device and\r\n// the corresponding ReportType\r\n// \r\n// Return Value\r\n// \r\n// - HIDP_STATUS_INVALID_REPORT_TYPE -- if ReportType is not valid.\r\n// - HIDP_STATUS_INVALID_PREPARSED_DATA -- if PreparsedData is not valid\r\n// - HIDP_STATUS_INVALID_REPORT_LENGTH -- the length of the report packet is not equal\r\n// to the length specified in HIDP_CAPS\r\n// structure for the given ReportType\r\n// - HIDP_STATUS_REPORT_DOES_NOT_EXIST -- if there are no reports on this device\r\n// for the given ReportType\r\n\r\n// (rom) This function is not in the HID.DLL of Windows 98\r\n// (rom) never call it unless you have Windows 98 SE or Windows 2000\r\n\r\nfunction HidP_InitializeReportForID(ReportType: THIDPReportType;\r\n ReportID: BYTE; PreparsedData: PHIDPPreparsedData;\r\n var Report; ReportLength: ULONG): NTSTATUS; stdcall;\r\n\r\n{$ENDIF WIN2000}\r\n\r\n{$ELSE}\r\n\r\n THidD_Hello = function(Buffer: PAnsiChar; BufferLength: ULONG): ULONG; stdcall;\r\n THidD_GetHidGuid = procedure(var HidGuid: TGUID) stdcall;\r\n THidD_GetPreparsedData = function(HidDeviceObject: THandle;\r\n var PreparsedData: PHIDPPreparsedData): LongBool; stdcall;\r\n THidD_FreePreparsedData = function(PreparsedData: PHIDPPreparsedData): LongBool; stdcall;\r\n THidD_GetConfiguration = function(HidDeviceObject: THandle;\r\n var HidConfig: THIDDConfiguration; Size: Integer): LongBool; stdcall;\r\n THidD_SetConfiguration = function(HidDeviceObject: THandle;\r\n const HidConfig: THIDDConfiguration; Size: Integer): LongBool; stdcall;\r\n THidD_FlushQueue = function(HidDeviceObject: THandle): LongBool; stdcall;\r\n THidD_GetFeature = function(HidDeviceObject: THandle;\r\n var Report; Size: Integer): LongBool; stdcall;\r\n THidD_SetFeature = function(HidDeviceObject: THandle;\r\n var Report; Size: Integer): LongBool; stdcall;\r\n THidD_GetNumInputBuffers = function(HidDeviceObject: THandle;\r\n var NumBufs: Integer): LongBool; stdcall;\r\n THidD_SetNumInputBuffers = function(HidDeviceObject: THandle;\r\n NumBufs: Integer): LongBool; stdcall;\r\n THidD_GetAttributes = function(HidDeviceObject: THandle;\r\n var HidAttrs: THIDDAttributes): LongBool; stdcall;\r\n THidD_GetManufacturerString = function(HidDeviceObject: THandle;\r\n Buffer: PWideChar; BufferLength: Integer): LongBool; stdcall;\r\n THidD_GetProductString = function(HidDeviceObject: THandle;\r\n Buffer: PWideChar; BufferLength: Integer): LongBool; stdcall;\r\n THidD_GetSerialNumberString = function(HidDeviceObject: THandle;\r\n Buffer: PWideChar; BufferLength: Integer): LongBool; stdcall;\r\n THidD_GetPhysicalDescriptor = function(HidDeviceObject: THandle;\r\n var Buffer; BufferLength: Integer): LongBool; stdcall;\r\n THidD_GetIndexedString = function(HidDeviceObject: THandle;\r\n Index: Integer; Buffer: PWideChar; BufferLength: Integer): LongBool; stdcall;\r\n\r\n // (rom) new XP functions\r\n THidD_GetInputReport = function(HidDeviceObject: THandle;\r\n Buffer: Pointer; BufferLength: ULONG): LongBool; stdcall;\r\n THidD_SetOutputReport = function(HidDeviceObject: THandle;\r\n Buffer: Pointer; BufferLength: ULONG): LongBool; stdcall;\r\n\r\n THidP_GetCaps = function(PreparsedData: PHIDPPreparsedData;\r\n var Capabilities: THIDPCaps): NTSTATUS; stdcall;\r\n THidP_GetLinkCollectionNodes = function(LinkCollectionNodes: PHIDPLinkCollectionNode;\r\n var LinkCollectionNodesLength: ULONG; PreparsedData: PHIDPPreparsedData): NTSTATUS; stdcall;\r\n THidP_GetSpecificButtonCaps = function(ReportType: THIDPReportType;\r\n UsagePage: TUsage; LinkCollection: Word; Usage: TUsage; ButtonCaps: PHIDPButtonCaps;\r\n var ButtonCapsLength: Word; PreparsedData: PHIDPPreparsedData): NTSTATUS; stdcall;\r\n THidP_GetSpecificValueCaps = function(ReportType: THIDPReportType; UsagePage: TUsage;\r\n LinkCollection: Word; Usage: TUsage; ValueCaps: PHIDPValueCaps;\r\n var ValueCapsLength: Word; PreparsedData: PHIDPPreparsedData): NTSTATUS; stdcall;\r\n THidP_GetData = function(ReportType: THIDPReportType; DataList: PHIDPData;\r\n var DataLength: ULONG; PreparsedData: PHIDPPreparsedData;\r\n var Report; ReportLength: ULONG): NTSTATUS; stdcall;\r\n THidP_SetData = function(ReportType: THIDPReportType; DataList: PHIDPData;\r\n var DataLength: ULONG; PreparsedData: PHIDPPreparsedData;\r\n var Report; ReportLength: ULONG): NTSTATUS; stdcall;\r\n THidP_MaxDataListLength = function(ReportType: THIDPReportType;\r\n PreparsedData: PHIDPPreparsedData): ULONG; stdcall;\r\n THidP_GetUsages = function(ReportType: THIDPReportType; UsagePage: TUsage;\r\n LinkCollection: Word; UsageList: PUsage; var UsageLength: ULONG;\r\n PreparsedData: PHIDPPreparsedData; var Report;\r\n ReportLength: ULONG): NTSTATUS; stdcall;\r\n THidP_GetButtons = function(ReportType: THIDPReportType; UsagePage: TUsage;\r\n LinkCollection: Word; UsageList: PUsage; var UsageLength: ULONG;\r\n PreparsedData: PHIDPPreparsedData; var Report;\r\n ReportLength: ULONG): NTSTATUS; stdcall;\r\n THidP_GetUsagesEx = function(ReportType: THIDPReportType; LinkCollection: Word;\r\n UsageList: PUsageAndPage; var UsageLength: ULONG;\r\n PreparsedData: PHIDPPreparsedData; var Report;\r\n ReportLength: ULONG): NTSTATUS; stdcall;\r\n THidP_GetButtonsEx = function(ReportType: THIDPReportType; LinkCollection: Word;\r\n UsageList: PUsageAndPage; var UsageLength: ULONG;\r\n PreparsedData: PHIDPPreparsedData; var Report;\r\n ReportLength: ULONG): NTSTATUS; stdcall;\r\n THidP_SetUsages = function(ReportType: THIDPReportType; UsagePage: TUsage;\r\n LinkCollection: Word; UsageList: PUsage; var UsageLength: ULONG;\r\n PreparsedData: PHIDPPreparsedData; var Report;\r\n ReportLength: ULONG): NTSTATUS; stdcall;\r\n THidP_SetButtons = function(ReportType: THIDPReportType; UsagePage: TUsage;\r\n LinkCollection: Word; ButtonList: PUsage; var ButtonLength: ULONG;\r\n PreparsedData: PHIDPPreparsedData; var Report;\r\n ReportLength: ULONG): NTSTATUS; stdcall;\r\n THidP_UnsetUsages = function(ReportType: THIDPReportType; UsagePage: TUsage;\r\n LinkCollection: Word; UsageList: PUsage; var UsageLength: ULONG;\r\n PreparsedData: PHIDPPreparsedData; var Report;\r\n ReportLength: ULONG): NTSTATUS; stdcall;\r\n THidP_UnsetButtons = function(ReportType: THIDPReportType; UsagePage: TUsage;\r\n LinkCollection: Word; ButtonList: PUsage; var ButtonLength: ULONG;\r\n PreparsedData: PHIDPPreparsedData; var Report;\r\n ReportLength: ULONG): NTSTATUS; stdcall;\r\n THidP_MaxUsageListLength = function(ReportType: THIDPReportType; UsagePage: TUsage;\r\n PreparsedData: PHIDPPreparsedData): ULONG; stdcall;\r\n THidP_MaxButtonListLength = function(ReportType: THIDPReportType; UsagePage: TUsage;\r\n PreparsedData: PHIDPPreparsedData): ULONG; stdcall;\r\n THidP_GetUsageValue = function(ReportType: THIDPReportType; UsagePage: TUsage;\r\n LinkCollection: Word; Usage: TUsage; var UsageValue: ULONG;\r\n PreparsedData: PHIDPPreparsedData; var Report;\r\n ReportLength: ULONG): NTSTATUS; stdcall;\r\n THidP_GetScaledUsageValue = function(ReportType: THIDPReportType; UsagePage: TUsage;\r\n LinkCollection: Word; Usage: TUsage; var UsageValue: Integer;\r\n PreparsedData: PHIDPPreparsedData; var Report;\r\n ReportLength: ULONG): NTSTATUS; stdcall;\r\n THidP_GetUsageValueArray = function(ReportType: THIDPReportType; UsagePage: TUsage;\r\n LinkCollection: Word; Usage: TUsage; UsageValue: PAnsiChar;\r\n UsageValueByteLength: Word; PreparsedData: PHIDPPreparsedData;\r\n var Report; ReportLength: ULONG): NTSTATUS; stdcall;\r\n THidP_SetUsageValue = function(ReportType: THIDPReportType; UsagePage: TUsage;\r\n LinkCollection: Word; Usage: TUsage; UsageValue: ULONG;\r\n PreparsedData: PHIDPPreparsedData; var Report;\r\n ReportLength: ULONG): NTSTATUS; stdcall;\r\n THidP_SetScaledUsageValue = function(ReportType: THIDPReportType; UsagePage: TUsage;\r\n LinkCollection: Word; Usage: TUsage; UsageValue: Integer;\r\n PreparsedData: PHIDPPreparsedData; var Report;\r\n ReportLength: ULONG): NTSTATUS; stdcall;\r\n THidP_SetUsageValueArray = function(ReportType: THIDPReportType; UsagePage: TUsage;\r\n LinkCollection: Word; Usage: TUsage; UsageValue: PAnsiChar;\r\n UsageValueByteLength: Word; PreparsedData: PHIDPPreparsedData;\r\n var Report; ReportLength: ULONG): NTSTATUS; stdcall;\r\n THidP_UsageListDifference = function(PreviousUsageList: PUsage;\r\n CurrentUsageList: PUsage; BreakUsageList: PUsage;\r\n MakeUsageList: PUsage; UsageListLength: ULONG): NTSTATUS; stdcall;\r\n THidP_TranslateUsagesToI8042ScanCodes = function(ChangedUsageList: PUsage;\r\n UsageListLength: ULONG; KeyAction: THIDPKeyboardDirection;\r\n var ModifierState: THIDPKeyboardModifierState;\r\n InsertCodesProcedure: THIDPInsertScanCodes;\r\n InsertCodesContext: Pointer): NTSTATUS; stdcall;\r\n \r\n // (rom) new Win2000 functions\r\n THidP_GetExtendedAttributes = function(ReportType: THIDPReportType;\r\n DataIndex: Word; PreparsedData: PHIDPPreparsedData;\r\n Attributes: PHIDPExtendedAttributes;\r\n var LengthAttributes: ULONG): NTSTATUS; stdcall;\r\n THidP_InitializeReportForID = function(ReportType: THIDPReportType;\r\n ReportID: BYTE; PreparsedData: PHIDPPreparsedData;\r\n var Report; ReportLength: ULONG): NTSTATUS; stdcall;\r\n\r\nvar\r\n HidD_Hello: THidD_Hello;\r\n HidD_GetHidGuid: THidD_GetHidGuid;\r\n HidD_GetPreparsedData: THidD_GetPreparsedData;\r\n HidD_FreePreparsedData: THidD_FreePreparsedData;\r\n HidD_GetConfiguration: THidD_GetConfiguration;\r\n HidD_SetConfiguration: THidD_SetConfiguration;\r\n HidD_FlushQueue: THidD_FlushQueue;\r\n HidD_GetFeature: THidD_GetFeature;\r\n HidD_SetFeature: THidD_SetFeature;\r\n HidD_GetNumInputBuffers: THidD_GetNumInputBuffers;\r\n HidD_SetNumInputBuffers: THidD_SetNumInputBuffers;\r\n HidD_GetAttributes: THidD_GetAttributes;\r\n HidD_GetManufacturerString: THidD_GetManufacturerString;\r\n HidD_GetProductString: THidD_GetProductString;\r\n HidD_GetSerialNumberString: THidD_GetSerialNumberString;\r\n HidD_GetPhysicalDescriptor: THidD_GetPhysicalDescriptor;\r\n HidD_GetIndexedString: THidD_GetIndexedString;\r\n\r\n // (rom) new XP functions\r\n HidD_GetInputReport: THidD_GetInputReport;\r\n HidD_SetOutputReport: THidD_SetOutputReport;\r\n\r\n HidP_GetCaps: THidP_GetCaps;\r\n HidP_GetLinkCollectionNodes: THidP_GetLinkCollectionNodes;\r\n HidP_GetSpecificButtonCaps: THidP_GetSpecificButtonCaps;\r\n HidP_GetSpecificValueCaps: THidP_GetSpecificValueCaps;\r\n HidP_GetData: THidP_GetData;\r\n HidP_SetData: THidP_SetData;\r\n HidP_MaxDataListLength: THidP_MaxDataListLength;\r\n HidP_GetUsages: THidP_GetUsages;\r\n HidP_GetButtons: THidP_GetButtons;\r\n HidP_GetUsagesEx: THidP_GetUsagesEx;\r\n HidP_GetButtonsEx: THidP_GetButtonsEx;\r\n HidP_SetUsages: THidP_SetUsages;\r\n HidP_SetButtons: THidP_SetButtons;\r\n HidP_UnsetUsages: THidP_UnsetUsages;\r\n HidP_UnsetButtons: THidP_UnsetButtons;\r\n HidP_MaxUsageListLength: THidP_MaxUsageListLength;\r\n HidP_MaxButtonListLength: THidP_MaxButtonListLength;\r\n HidP_GetUsageValue: THidP_GetUsageValue;\r\n HidP_GetScaledUsageValue: THidP_GetScaledUsageValue;\r\n HidP_GetUsageValueArray: THidP_GetUsageValueArray;\r\n HidP_SetUsageValue: THidP_SetUsageValue;\r\n HidP_SetScaledUsageValue: THidP_SetScaledUsageValue;\r\n HidP_SetUsageValueArray: THidP_SetUsageValueArray;\r\n HidP_UsageListDifference: THidP_UsageListDifference;\r\n HidP_TranslateUsagesToI8042ScanCodes: THidP_TranslateUsagesToI8042ScanCodes;\r\n\r\n // (rom) new XP functions\r\n HidP_GetExtendedAttributes: THidP_GetExtendedAttributes;\r\n HidP_InitializeReportForID: THidP_InitializeReportForID;\r\n\r\n{$ENDIF HID_LINKONREQUEST}\r\n\r\n// Description:\r\n// HidP_GetButtonCaps returns all the buttons (binary values) that are a part\r\n// of the given report type for the Hid device represented by the given\r\n// preparsed data.\r\n// \r\n// Parameters:\r\n// ReportType One of HidP_Input, HidP_Output, or HidP_Feature.\r\n// \r\n// UsagePage A usage page value used to limit the button caps returned to\r\n// those on a given usage page. If set to 0, this parameter is\r\n// ignored. Can be used with LinkCollection and Usage parameters\r\n// to further limit the number of button caps structures returned.\r\n// \r\n// LinkCollection HIDP_LINK_COLLECTION node array index used to limit the\r\n// button caps returned to those buttons in a given link\r\n// collection. If set to 0, this parameter is\r\n// ignored. Can be used with UsagePage and Usage parameters\r\n// to further limit the number of button caps structures\r\n// returned.\r\n// \r\n// Usage A usage value used to limit the button caps returned to those\r\n// with the specified usage value. If set to 0, this parameter\r\n// is ignored. Can be used with LinkCollection and UsagePage\r\n// parameters to further limit the number of button caps\r\n// structures returned.\r\n//\r\n// ButtonCaps A _HIDP_BUTTON_CAPS array containing information about all the\r\n// binary values in the given report. This buffer is provided by\r\n// the caller.\r\n// \r\n// ButtonLength As input, this parameter specifies the length of the\r\n// ButtonCaps parameter (array) in number of array elements.\r\n// As output, this value is set to indicate how many of those\r\n// array elements were filled in by the function. The maximum number of\r\n// button caps that can be returned is found in the HIDP_CAPS\r\n// structure. If HIDP_STATUS_BUFFER_TOO_SMALL is returned,\r\n// this value contains the number of array elements needed to\r\n// successfully complete the request.\r\n// \r\n// PreparsedData The preparsed data returned from HIDCLASS.\r\n// \r\n// \r\n// Return Value\r\n// HidP_GetSpecificButtonCaps returns the following error codes:\r\n// - HIDP_STATUS_SUCCESS.\r\n// - HIDP_STATUS_INVALID_REPORT_TYPE\r\n// - HIDP_STATUS_INVALID_PREPARSED_DATA\r\n// - HIDP_STATUS_BUFFER_TOO_SMALL (all given entries however have been filled in)\r\n// - HIDP_STATUS_USAGE_NOT_FOUND\r\n\r\n// (rom) this function is a macro and cannot be implemented with the original name\r\n\r\nfunction HidP_GetButtonCaps_(ReportType: THIDPReportType; ButtonCaps: PHIDPButtonCaps;\r\n var ButtonCapsLength: Word; PreparsedData: PHIDPPreparsedData): NTSTATUS;\r\n\r\n// Description:\r\n// HidP_GetValueCaps returns all the values (non-binary) that are a part\r\n// of the given report type for the Hid device represented by the given\r\n// preparsed data.\r\n// \r\n// Parameters:\r\n// ReportType One of HidP_Input, HidP_Output, or HidP_Feature.\r\n// \r\n// UsagePage A usage page value used to limit the value caps returned to\r\n// those on a given usage page. If set to 0, this parameter is\r\n// ignored. Can be used with LinkCollection and Usage parameters\r\n// to further limit the number of value caps structures returned.\r\n// \r\n// LinkCollection HIDP_LINK_COLLECTION node array index used to limit the\r\n// value caps returned to those buttons in a given link\r\n// collection. If set to 0, this parameter is\r\n// ignored. Can be used with UsagePage and Usage parameters\r\n// to further limit the number of value caps structures\r\n// returned.\r\n//\r\n// Usage A usage value used to limit the value caps returned to those\r\n// with the specified usage value. If set to 0, this parameter\r\n// is ignored. Can be used with LinkCollection and UsagePage\r\n// parameters to further limit the number of value caps\r\n// structures returned.\r\n// \r\n// ValueCaps A _HIDP_VALUE_CAPS array containing information about all the\r\n// non-binary values in the given report. This buffer is provided\r\n// by the caller.\r\n// \r\n// ValueLength As input, this parameter specifies the length of the ValueCaps\r\n// parameter (array) in number of array elements. As output,\r\n// this value is set to indicate how many of those array elements\r\n// were filled in by the function. The maximum number of\r\n// value caps that can be returned is found in the HIDP_CAPS\r\n// structure. If HIDP_STATUS_BUFFER_TOO_SMALL is returned,\r\n// this value contains the number of array elements needed to\r\n// successfully complete the request.\r\n// \r\n// PreparsedData The preparsed data returned from HIDCLASS.\r\n// \r\n// \r\n// Return Value\r\n// HidP_GetValueCaps returns the following error codes:\r\n// - HIDP_STATUS_SUCCESS.\r\n// - HIDP_STATUS_INVALID_REPORT_TYPE\r\n// - HIDP_STATUS_INVALID_PREPARSED_DATA\r\n// - HIDP_STATUS_BUFFER_TOO_SMALL (all given entries however have been filled in)\r\n// - HIDP_STATUS_USAGE_NOT_FOUND\r\n\r\n// (rom) this function is a macro and cannot be implemented with the original name\r\n\r\nfunction HidP_GetValueCaps_(ReportType: THIDPReportType; ValueCaps: PHIDPValueCaps;\r\n var ValueCapsLength: Word; PreparsedData: PHIDPPreparsedData): NTSTATUS;\r\n\r\nfunction HidP_IsSameUsageAndPage_(u1, u2: TUsageAndPage): Boolean;\r\n\r\nfunction IsHidLoaded: Boolean;\r\nfunction LoadHid: Boolean;\r\nprocedure UnloadHid;\r\n\r\nconst\r\n HidModuleName = 'HID.dll';\r\n\r\nimplementation\r\n\r\nuses\r\n SysUtils,\r\n ModuleLoader;\r\n\r\n{$IFDEF HID_LINKONREQUEST}\r\nvar\r\n HidLib: TModuleHandle = INVALID_MODULEHANDLE_VALUE;\r\n{$ENDIF HID_LINKONREQUEST}\r\n\r\n// (rom) this function is a macro and cannot be implemented with the original name\r\n// (rom) simply adds three 0 params on call\r\n\r\nfunction HidP_GetButtonCaps_(ReportType: THIDPReportType;\r\n ButtonCaps: PHIDPButtonCaps; var ButtonCapsLength: Word;\r\n PreparsedData: PHIDPPreparsedData): NTSTATUS;\r\nbegin\r\n Result :=\r\n HidP_GetSpecificButtonCaps(ReportType, 0, 0, 0, ButtonCaps,\r\n ButtonCapsLength, PreparsedData);\r\nend;\r\n\r\n// (rom) this function is a macro and cannot be implemented with the original name\r\n// (rom) simply adds three 0 params on call\r\n\r\nfunction HidP_GetValueCaps_(ReportType: THIDPReportType;\r\n ValueCaps: PHIDPValueCaps; var ValueCapsLength: Word;\r\n PreparsedData: PHIDPPreparsedData): NTSTATUS;\r\nbegin\r\n Result :=\r\n HidP_GetSpecificValueCaps(ReportType, 0, 0, 0, ValueCaps,\r\n ValueCapsLength, PreparsedData);\r\nend;\r\n\r\n// (rom) implements HidP_IsSameUsageAndPage macro\r\n// (rom) the original macro is a really dirty trick\r\n\r\nfunction HidP_IsSameUsageAndPage_(u1, u2: TUsageAndPage): Boolean;\r\nbegin\r\n Result := (u1.Usage = u2.Usage) and (u1.UsagePage = u2.UsagePage);\r\nend;\r\n\r\nfunction IsHidLoaded: Boolean;\r\nbegin\r\n {$IFDEF HID_LINKONREQUEST}\r\n Result := HidLib <> INVALID_MODULEHANDLE_VALUE;\r\n {$ELSE}\r\n Result := True;\r\n {$ENDIF HID_LINKONREQUEST}\r\nend;\r\n\r\nfunction LoadHid: Boolean;\r\nbegin\r\n {$IFDEF HID_LINKONREQUEST}\r\n Result := LoadModule(HidLib, HidModuleName);\r\n if Result then\r\n begin\r\n @HidD_Hello := GetModuleSymbolEx(HidLib, 'HidD_Hello', Result);\r\n @HidD_GetHidGuid := GetModuleSymbolEx(HidLib, 'HidD_GetHidGuid', Result);\r\n @HidD_GetPreparsedData := GetModuleSymbolEx(HidLib, 'HidD_GetPreparsedData', Result);\r\n @HidD_FreePreparsedData := GetModuleSymbolEx(HidLib, 'HidD_FreePreparsedData', Result);\r\n @HidD_GetConfiguration := GetModuleSymbolEx(HidLib, 'HidD_GetConfiguration', Result);\r\n @HidD_SetConfiguration := GetModuleSymbolEx(HidLib, 'HidD_SetConfiguration', Result);\r\n @HidD_FlushQueue := GetModuleSymbolEx(HidLib, 'HidD_FlushQueue', Result);\r\n @HidD_GetFeature := GetModuleSymbolEx(HidLib, 'HidD_GetFeature', Result);\r\n @HidD_SetFeature := GetModuleSymbolEx(HidLib, 'HidD_SetFeature', Result);\r\n @HidD_GetNumInputBuffers := GetModuleSymbolEx(HidLib, 'HidD_GetNumInputBuffers', Result);\r\n @HidD_SetNumInputBuffers := GetModuleSymbolEx(HidLib, 'HidD_SetNumInputBuffers', Result);\r\n @HidD_GetAttributes := GetModuleSymbolEx(HidLib, 'HidD_GetAttributes', Result);\r\n @HidD_GetManufacturerString := GetModuleSymbolEx(HidLib, 'HidD_GetManufacturerString', Result);\r\n @HidD_GetProductString := GetModuleSymbolEx(HidLib, 'HidD_GetProductString', Result);\r\n @HidD_GetSerialNumberString := GetModuleSymbolEx(HidLib, 'HidD_GetSerialNumberString', Result);\r\n @HidD_GetPhysicalDescriptor := GetModuleSymbolEx(HidLib, 'HidD_GetPhysicalDescriptor', Result);\r\n @HidD_GetIndexedString := GetModuleSymbolEx(HidLib, 'HidD_GetIndexedString', Result);\r\n if (Win32Platform = VER_PLATFORM_WIN32_NT) and CheckWin32Version(5, 1) then\r\n begin\r\n @HidD_GetInputReport := GetModuleSymbolEx(HidLib, 'HidD_GetInputReport', Result);\r\n @HidD_SetOutputReport := GetModuleSymbolEx(HidLib, 'HidD_SetOutputReport', Result);\r\n end;\r\n @HidP_GetCaps := GetModuleSymbolEx(HidLib, 'HidP_GetCaps', Result);\r\n @HidP_GetLinkCollectionNodes := GetModuleSymbolEx(HidLib, 'HidP_GetLinkCollectionNodes', Result);\r\n @HidP_GetSpecificButtonCaps := GetModuleSymbolEx(HidLib, 'HidP_GetSpecificButtonCaps', Result);\r\n @HidP_GetSpecificValueCaps := GetModuleSymbolEx(HidLib, 'HidP_GetSpecificValueCaps', Result);\r\n @HidP_GetData := GetModuleSymbolEx(HidLib, 'HidP_GetData', Result);\r\n @HidP_SetData := GetModuleSymbolEx(HidLib, 'HidP_SetData', Result);\r\n @HidP_MaxDataListLength := GetModuleSymbolEx(HidLib, 'HidP_MaxDataListLength', Result);\r\n @HidP_GetUsages := GetModuleSymbolEx(HidLib, 'HidP_GetUsages', Result);\r\n @HidP_GetButtons := GetModuleSymbolEx(HidLib, 'HidP_GetUsages', Result);\r\n @HidP_GetUsagesEx := GetModuleSymbolEx(HidLib, 'HidP_GetUsagesEx', Result);\r\n @HidP_GetButtonsEx := GetModuleSymbolEx(HidLib, 'HidP_GetUsagesEx', Result);\r\n @HidP_SetUsages := GetModuleSymbolEx(HidLib, 'HidP_SetUsages', Result);\r\n @HidP_SetButtons := GetModuleSymbolEx(HidLib, 'HidP_SetUsages', Result);\r\n @HidP_UnsetUsages := GetModuleSymbolEx(HidLib, 'HidP_UnsetUsages', Result);\r\n @HidP_UnsetButtons := GetModuleSymbolEx(HidLib, 'HidP_UnsetUsages', Result);\r\n @HidP_MaxUsageListLength := GetModuleSymbolEx(HidLib, 'HidP_MaxUsageListLength', Result);\r\n @HidP_MaxButtonListLength := GetModuleSymbolEx(HidLib, 'HidP_MaxUsageListLength', Result);\r\n @HidP_GetUsageValue := GetModuleSymbolEx(HidLib, 'HidP_GetUsageValue', Result);\r\n @HidP_GetScaledUsageValue := GetModuleSymbolEx(HidLib, 'HidP_GetScaledUsageValue', Result);\r\n @HidP_GetUsageValueArray := GetModuleSymbolEx(HidLib, 'HidP_GetUsageValueArray', Result);\r\n @HidP_SetUsageValue := GetModuleSymbolEx(HidLib, 'HidP_SetUsageValue', Result);\r\n @HidP_SetScaledUsageValue := GetModuleSymbolEx(HidLib, 'HidP_SetScaledUsageValue', Result);\r\n @HidP_SetUsageValueArray := GetModuleSymbolEx(HidLib, 'HidP_SetUsageValueArray', Result);\r\n @HidP_UsageListDifference := GetModuleSymbolEx(HidLib, 'HidP_UsageListDifference', Result);\r\n @HidP_TranslateUsagesToI8042ScanCodes := GetModuleSymbolEx(HidLib, 'HidP_TranslateUsagesToI8042ScanCodes', Result);\r\n if (Win32Platform = VER_PLATFORM_WIN32_NT) and CheckWin32Version(5, 0) then\r\n begin\r\n @HidP_GetExtendedAttributes := GetModuleSymbolEx(HidLib, 'HidP_GetExtendedAttributes', Result);\r\n @HidP_InitializeReportForID := GetModuleSymbolEx(HidLib, 'HidP_InitializeReportForID', Result);\r\n end;\r\n if not Result then\r\n UnloadHid;\r\n end;\r\n {$ELSE}\r\n Result := True;\r\n {$ENDIF HID_LINKONREQUEST}\r\nend;\r\n\r\nprocedure UnloadHid;\r\nbegin\r\n {$IFDEF HID_LINKONREQUEST}\r\n UnloadModule(HidLib);\r\n @HidD_Hello := nil;\r\n @HidD_GetHidGuid := nil;\r\n @HidD_GetPreparsedData := nil;\r\n @HidD_FreePreparsedData := nil;\r\n @HidD_GetConfiguration := nil;\r\n @HidD_SetConfiguration := nil;\r\n @HidD_FlushQueue := nil;\r\n @HidD_SetFeature := nil;\r\n @HidD_GetNumInputBuffers := nil;\r\n @HidD_SetNumInputBuffers := nil;\r\n @HidD_GetAttributes := nil;\r\n @HidD_GetManufacturerString := nil;\r\n @HidD_GetProductString := nil;\r\n @HidD_GetSerialNumberString := nil;\r\n @HidD_GetPhysicalDescriptor := nil;\r\n @HidD_GetIndexedString := nil;\r\n\r\n @HidD_GetInputReport := nil;\r\n @HidD_SetOutputReport := nil;\r\n\r\n @HidP_GetLinkCollectionNodes := nil;\r\n @HidP_GetSpecificButtonCaps := nil;\r\n @HidP_GetSpecificValueCaps := nil;\r\n @HidP_GetData := nil;\r\n @HidP_SetData := nil;\r\n @HidP_MaxDataListLength := nil;\r\n @HidP_GetUsages := nil;\r\n @HidP_GetButtons := nil;\r\n @HidP_GetUsagesEx := nil;\r\n @HidP_GetButtonsEx := nil;\r\n @HidP_SetUsages := nil;\r\n @HidP_SetButtons := nil;\r\n @HidP_UnsetUsages := nil;\r\n @HidP_UnsetButtons := nil;\r\n @HidP_MaxUsageListLength := nil;\r\n @HidP_MaxButtonListLength := nil;\r\n @HidP_GetUsageValue := nil;\r\n @HidP_GetScaledUsageValue := nil;\r\n @HidP_GetUsageValueArray := nil;\r\n @HidP_SetUsageValue := nil;\r\n @HidP_SetScaledUsageValue := nil;\r\n @HidP_SetUsageValueArray := nil;\r\n @HidP_UsageListDifference := nil;\r\n @HidP_TranslateUsagesToI8042ScanCodes := nil;\r\n\r\n @HidP_GetExtendedAttributes := nil;\r\n @HidP_InitializeReportForID := nil;\r\n {$ENDIF HID_LINKONREQUEST}\r\nend;\r\n\r\n{$IFNDEF HID_LINKONREQUEST}\r\n\r\nfunction HidD_Hello; external HidModuleName name 'HidD_Hello';\r\nprocedure HidD_GetHidGuid; external HidModuleName name 'HidD_GetHidGuid';\r\nfunction HidD_GetPreparsedData; external HidModuleName name 'HidD_GetPreparsedData';\r\nfunction HidD_FreePreparsedData; external HidModuleName name 'HidD_FreePreparsedData';\r\nfunction HidD_GetConfiguration; external HidModuleName name 'HidD_GetConfiguration';\r\nfunction HidD_SetConfiguration; external HidModuleName name 'HidD_SetConfiguration';\r\nfunction HidD_FlushQueue; external HidModuleName name 'HidD_FlushQueue';\r\nfunction HidD_GetFeature; external HidModuleName name 'HidD_GetFeature';\r\nfunction HidD_SetFeature; external HidModuleName name 'HidD_SetFeature';\r\nfunction HidD_GetNumInputBuffers; external HidModuleName name 'HidD_GetNumInputBuffers';\r\nfunction HidD_SetNumInputBuffers; external HidModuleName name 'HidD_SetNumInputBuffers';\r\nfunction HidD_GetAttributes; external HidModuleName name 'HidD_GetAttributes';\r\nfunction HidD_GetManufacturerString; external HidModuleName name 'HidD_GetManufacturerString';\r\nfunction HidD_GetProductString; external HidModuleName name 'HidD_GetProductString';\r\nfunction HidD_GetSerialNumberString; external HidModuleName name 'HidD_GetSerialNumberString';\r\nfunction HidD_GetPhysicalDescriptor; external HidModuleName name 'HidD_GetPhysicalDescriptor';\r\nfunction HidD_GetIndexedString; external HidModuleName name 'HidD_GetIndexedString';\r\n{$IFDEF WINXP}\r\nfunction HidD_GetInputReport; external HidModuleName name 'HidD_GetInputReport';\r\nfunction HidD_SetOutputReport; external HidModuleName name 'HidD_SetOutputReport';\r\n{$ENDIF WINXP}\r\nfunction HidP_GetCaps; external HidModuleName name 'HidP_GetCaps';\r\nfunction HidP_GetLinkCollectionNodes; external HidModuleName name 'HidP_GetLinkCollectionNodes';\r\nfunction HidP_GetSpecificButtonCaps; external HidModuleName name 'HidP_GetSpecificButtonCaps';\r\nfunction HidP_GetSpecificValueCaps; external HidModuleName name 'HidP_GetSpecificValueCaps';\r\nfunction HidP_GetData; external HidModuleName name 'HidP_GetData';\r\nfunction HidP_SetData; external HidModuleName name 'HidP_SetData';\r\nfunction HidP_MaxDataListLength; external HidModuleName name 'HidP_MaxDataListLength';\r\nfunction HidP_GetUsages; external HidModuleName name 'HidP_GetUsages';\r\nfunction HidP_GetButtons; external HidModuleName name 'HidP_GetUsages';\r\nfunction HidP_GetUsagesEx; external HidModuleName name 'HidP_GetUsagesEx';\r\nfunction HidP_GetButtonsEx; external HidModuleName name 'HidP_GetUsagesEx';\r\nfunction HidP_SetUsages; external HidModuleName name 'HidP_SetUsages';\r\nfunction HidP_SetButtons; external HidModuleName name 'HidP_SetUsages';\r\nfunction HidP_UnsetUsages; external HidModuleName name 'HidP_UnsetUsages';\r\nfunction HidP_UnsetButtons; external HidModuleName name 'HidP_UnsetUsages';\r\nfunction HidP_MaxUsageListLength; external HidModuleName name 'HidP_MaxUsageListLength';\r\nfunction HidP_MaxButtonListLength; external HidModuleName name 'HidP_MaxUsageListLength';\r\nfunction HidP_GetUsageValue; external HidModuleName name 'HidP_GetUsageValue';\r\nfunction HidP_GetScaledUsageValue; external HidModuleName name 'HidP_GetScaledUsageValue';\r\nfunction HidP_GetUsageValueArray; external HidModuleName name 'HidP_GetUsageValueArray';\r\nfunction HidP_SetUsageValue; external HidModuleName name 'HidP_SetUsageValue';\r\nfunction HidP_SetScaledUsageValue; external HidModuleName name 'HidP_SetScaledUsageValue';\r\nfunction HidP_SetUsageValueArray; external HidModuleName name 'HidP_SetUsageValueArray';\r\nfunction HidP_UsageListDifference; external HidModuleName name 'HidP_UsageListDifference';\r\nfunction HidP_TranslateUsagesToI8042ScanCodes; external HidModuleName name 'HidP_TranslateUsagesToI8042ScanCodes';\r\n// function HidP_UsageAndPageListDifference; external HidModuleName name 'function HidP_UsageAndPageListDifference';\r\n// function HidP_TranslateUsageAndPagesToI8042ScanCodes; external HidModuleName name 'HidP_TranslateUsageAndPagesToI8042ScanCodes';\r\n{$IFDEF WIN2000}\r\nfunction HidP_GetExtendedAttributes; external HidModuleName name 'HidP_GetExtendedAttributes';\r\nfunction HidP_InitializeReportForID; external HidModuleName name 'HidP_InitializeReportForID';\r\n{$ENDIF WIN2000}\r\n\r\n{$ENDIF HID_LINKONREQUEST}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/HidToken.pas", "content": "{******************************************************************}\r\n{ }\r\n{ Borland Delphi Runtime Library }\r\n{ Public Definitions of HID USAGES }\r\n{ }\r\n{ Portions created by Microsoft are }\r\n{ Copyright (c) 1996-1999 Microsoft Corporation. }\r\n{ All Rights Reserved. }\r\n{ }\r\n{ The original file is: hidtoken.h, released March 1999. }\r\n{ The original Pascal code is: HidToken.pas, released 31 Jan 2000. }\r\n{ The initial developer of the Pascal code is Robert Marquardt }\r\n{ (robert_marquardt att gmx dott de) }\r\n{ }\r\n{ Portions created by Robert Marquardt are }\r\n{ Copyright (c) 1999, 2000 Robert Marquardt. }\r\n{ }\r\n{ Contributor(s): Marcel van Brakel (brakelm att bart dott nl) }\r\n{ }\r\n{ Obtained through: }\r\n{ Joint Endeavour of Delphi Innovators (Project JEDI) }\r\n{ }\r\n{ You may retrieve the latest version of this file at the Project }\r\n{ JEDI home page, located at http://delphi-jedi.org }\r\n{ }\r\n{ The contents of this file are used with permission, subject to }\r\n{ the Mozilla Public License Version 1.1 (the \"License\"); you may }\r\n{ not use this file except in compliance with the License. You may }\r\n{ obtain a copy of the License at }\r\n{ http://www.mozilla.org/NPL/NPL-1_1Final.html }\r\n{ }\r\n{ Software distributed under the License is distributed on an }\r\n{ \"AS IS\" basis, WITHOUT WARRANTY OF ANY KIND, either express or }\r\n{ implied. See the License for the specific language governing }\r\n{ rights and limitations under the License. }\r\n{ }\r\n{******************************************************************}\r\n\r\nunit HidToken;\r\n\r\n{$WEAKPACKAGEUNIT}\r\n\r\ninterface\r\n\r\nconst\r\n HIDP_ITEM_LONG = $FE;\r\n HIDP_ITEM_LENGTH_DATA = $03;\r\n\r\n // Main Items\r\n // Only main items with one byte data (bSize = 1) are supported.\r\n HIDP_MAIN_INPUT_1 = $81;\r\n HIDP_MAIN_INPUT_2 = $82;\r\n HIDP_MAIN_OUTPUT_1 = $91;\r\n HIDP_MAIN_OUTPUT_2 = $92;\r\n HIDP_MAIN_FEATURE_1 = $B1;\r\n HIDP_MAIN_FEATURE_2 = $B2;\r\n HIDP_MAIN_COLLECTION = $A1;\r\n HIDP_MAIN_ENDCOLLECTION = $C0;\r\n HIDP_MAIN_COLLECTION_LINK = $00;\r\n HIDP_MAIN_COLLECTION_APP = $01;\r\n\r\n // Global Items\r\n HIDP_GLOBAL_USAGE_PAGE_1 = $05; // UsagePage of 1 byte\r\n HIDP_GLOBAL_USAGE_PAGE_2 = $06; // UsagePage of 2 bytes\r\n HIDP_GLOBAL_USAGE_PAGE_4 = $07; // UsagePage of 4 bytes\r\n HIDP_GLOBAL_LOG_MIN_1 = $15; // minimum value of size 1 byte.\r\n HIDP_GLOBAL_LOG_MIN_2 = $16; // minimum value of size 2 bytes.\r\n HIDP_GLOBAL_LOG_MIN_4 = $17; // minimum value of size 4 bytes.\r\n HIDP_GLOBAL_LOG_MAX_1 = $25; // maximum of size 1 byte.\r\n HIDP_GLOBAL_LOG_MAX_2 = $26; // maximum of size 2 bytes.\r\n HIDP_GLOBAL_LOG_MAX_4 = $27; // maximum of size 4 bytes.\r\n\r\n HIDP_GLOBAL_PHY_MIN_1 = $35; // minimum value of size 1 byte.\r\n HIDP_GLOBAL_PHY_MIN_2 = $36; // minimum value of size 2 bytes.\r\n HIDP_GLOBAL_PHY_MIN_4 = $37; // minimum value of size 4 bytes.\r\n HIDP_GLOBAL_PHY_MAX_1 = $45; // maximum of size 1 byte.\r\n HIDP_GLOBAL_PHY_MAX_2 = $46; // maximum of size 2 bytes.\r\n HIDP_GLOBAL_PHY_MAX_4 = $47; // maximum of size 4 bytes.\r\n\r\n HIDP_GLOBAL_UNIT_EXP_1 = $55; // Exponent of size 1 byte.\r\n HIDP_GLOBAL_UNIT_EXP_2 = $56; // Exponent of size 2 bytes.\r\n HIDP_GLOBAL_UNIT_EXP_4 = $57; // Exponent of size 4 bytes.\r\n HIDP_GLOBAL_UNIT_1 = $65; // UNIT of size 1 byte.\r\n HIDP_GLOBAL_UNIT_2 = $66; // UNIT of size 2 bytes.\r\n HIDP_GLOBAL_UNIT_4 = $67; // UNIT of size 4 bytes.\r\n\r\n HIDP_GLOBAL_REPORT_SIZE = $75; // Report size in bits\r\n HIDP_GLOBAL_REPORT_ID = $85; // ID only size 1 byte supported\r\n HIDP_GLOBAL_REPORT_COUNT_1 = $95; // Number of data fields 1 byte\r\n HIDP_GLOBAL_REPORT_COUNT_2 = $96; // Number of data fields 2 bytes\r\n HIDP_GLOBAL_PUSH = $A4; // The dreaded PUSH command\r\n HIDP_GLOBAL_POP = $B4; // And the dreaded POP command\r\n\r\n // Local Items\r\n HIDP_LOCAL_USAGE_1 = $09;\r\n HIDP_LOCAL_USAGE_2 = $0A;\r\n HIDP_LOCAL_USAGE_4 = $0B;\r\n HIDP_LOCAL_USAGE_MIN_1 = $19;\r\n HIDP_LOCAL_USAGE_MIN_2 = $1A;\r\n HIDP_LOCAL_USAGE_MIN_4 = $1B;\r\n HIDP_LOCAL_USAGE_MAX_1 = $29;\r\n HIDP_LOCAL_USAGE_MAX_2 = $2A;\r\n HIDP_LOCAL_USAGE_MAX_4 = $2B;\r\n HIDP_LOCAL_DESIG_INDEX = $39; // Designators of byte size supported\r\n HIDP_LOCAL_DESIG_MIN = $49;\r\n HIDP_LOCAL_DESIG_MAX = $59;\r\n HIDP_LOCAL_STRING_INDEX = $79; // String indices of size byte supported\r\n HIDP_LOCAL_STRING_MIN = $89;\r\n HIDP_LOCAL_STRING_MAX = $99;\r\n HIDP_LOCAL_DELIMITER = $A9;\r\n\r\nfunction HidPIsMain (x: Integer): Boolean;\r\nfunction HidPIsMainItem (x: Integer): Boolean;\r\nfunction HidPIsGlobalItem (x: Integer): Boolean;\r\nfunction HidPIsLocalItem (x: Integer): Boolean;\r\nfunction HidPIsReservedItem(x: Integer): Boolean;\r\n\r\nimplementation\r\n\r\nfunction HidPIsMain(x: Integer): Boolean;\r\nbegin\r\n Result := ((x and $0C) = 0);\r\nend;\r\n\r\nfunction HidPIsMainItem(x: Integer): Boolean;\r\nbegin\r\n Result := ((x and $0C) = 0);\r\nend;\r\n\r\nfunction HidPIsGlobalItem(x: Integer): Boolean;\r\nbegin\r\n Result := ((x and $0C) = $04);\r\nend;\r\n\r\nfunction HidPIsLocalItem(x: Integer): Boolean;\r\nbegin\r\n Result := ((x and $0C) = $08);\r\nend;\r\n\r\nfunction HidPIsReservedItem(x: Integer): Boolean;\r\nbegin\r\n Result := ((x and $0C) = $0C);\r\nend;\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/HidUsage.pas", "content": "{******************************************************************}\r\n{ }\r\n{ Borland Delphi Runtime Library }\r\n{ Public Definitions of HID USAGES }\r\n{ }\r\n{ Portions created by Microsoft are }\r\n{ Copyright (c) 1996, 1997 Microsoft Corporation }\r\n{ All Rights Reserved. }\r\n{ }\r\n{ The original file is: hidusage.h, released March 1999. }\r\n{ The original Pascal code is: HidUsage.pas, released 31 Jan 2000. }\r\n{ The initial developer of the Pascal code is Robert Marquardt }\r\n{ (robert_marquardt att gmx dott de) }\r\n{ }\r\n{ Portions created by Robert Marquardt are }\r\n{ Copyright (c) 1999, 2000 Robert Marquardt. }\r\n{ }\r\n{ Contributor(s): Marcel van Brakel (brakelm att chello dott nl) }\r\n{ Francois KREBS (fkrebs att free dott fr) }\r\n{ }\r\n{ Obtained through: }\r\n{ Joint Endeavour of Delphi Innovators (Project JEDI) }\r\n{ }\r\n{ You may retrieve the latest version of this file at the Project }\r\n{ JEDI home page, located at http://delphi-jedi.org }\r\n{ }\r\n{ The contents of this file are used with permission, subject to }\r\n{ the Mozilla Public License Version 1.1 (the \"License\"); you may }\r\n{ not use this file except in compliance with the License. You may }\r\n{ obtain a copy of the License at }\r\n{ http://www.mozilla.org/NPL/NPL-1_1Final.html }\r\n{ }\r\n{ Software distributed under the License is distributed on an }\r\n{ \"AS IS\" basis, WITHOUT WARRANTY OF ANY KIND, either express or }\r\n{ implied. See the License for the specific language governing }\r\n{ rights and limitations under the License. }\r\n{ }\r\n{******************************************************************}\r\n\r\nunit HidUsage;\r\n\r\ninterface\r\n\r\n{$WEAKPACKAGEUNIT}\r\n\r\nuses Windows;\r\n\r\nconst\r\n //\r\n // Usage Pages\r\n //\r\n HID_USAGE_PAGE_UNDEFINED = $00;\r\n HID_USAGE_PAGE_GENERIC = $01;\r\n HID_USAGE_PAGE_SIMULATION = $02;\r\n HID_USAGE_PAGE_VR = $03;\r\n HID_USAGE_PAGE_SPORT = $04;\r\n HID_USAGE_PAGE_GAME = $05;\r\n HID_USAGE_PAGE_GENERIC_GAME_CONTROLS = $06;\r\n HID_USAGE_PAGE_KEYBOARD = $07;\r\n HID_USAGE_PAGE_LED = $08;\r\n HID_USAGE_PAGE_BUTTON = $09;\r\n HID_USAGE_PAGE_ORDINAL = $0A;\r\n HID_USAGE_PAGE_TELEPHONY = $0B;\r\n HID_USAGE_PAGE_CONSUMER = $0C;\r\n HID_USAGE_PAGE_DIGITIZER = $0D;\r\n HID_USAGE_PAGE_PHYSICAL_INPUT_DEVICE = $0F;\r\n HID_USAGE_PAGE_UNICODE = $10;\r\n HID_USAGE_PAGE_ALPHANUMERIC = $14;\r\n\r\n HID_USAGE_PAGE_MEDICAL_INSTRUMENT = $40;\r\n\r\n HID_USAGE_PAGE_USB_MONITOR = $80;\r\n HID_USAGE_PAGE_MONITOR_ENUMERATED_VALUES = $81;\r\n HID_USAGE_PAGE_VESA_VIRTUAL_CONTROLS = $82;\r\n HID_USAGE_PAGE_RESERVED = $83;\r\n HID_USAGE_PAGE_POWER_DEVICE = $84;\r\n HID_USAGE_PAGE_BATTERY_SYSTEM = $85;\r\n HID_USAGE_PAGE_BARCODE_SCANNER = $8C;\r\n HID_USAGE_PAGE_WEIGHING_DEVICE = $8D;\r\n HID_USAGE_PAGE_MAGNETIC_STRIPE_READER = $8E;\r\n\r\n //\r\n // Usages from Generic Desktop Page (0x01)\r\n //\r\n HID_USAGE_UNDEFINED = $00;\r\n HID_USAGE_GENERIC_POINTER = $01;\r\n HID_USAGE_GENERIC_MOUSE = $02;\r\n HID_USAGE_GENERIC_RESERVED1 = $03;\r\n HID_USAGE_GENERIC_JOYSTICK = $04;\r\n HID_USAGE_GENERIC_GAMEPAD = $05;\r\n HID_USAGE_GENERIC_KEYBOARD = $06;\r\n HID_USAGE_GENERIC_KEYPAD = $07;\r\n HID_USAGE_GENERIC_MULTIAXIS = $08;\r\n\r\n HID_USAGE_GENERIC_X = $30;\r\n HID_USAGE_GENERIC_Y = $31;\r\n HID_USAGE_GENERIC_Z = $32;\r\n HID_USAGE_GENERIC_RX = $33;\r\n HID_USAGE_GENERIC_RY = $34;\r\n HID_USAGE_GENERIC_RZ = $35;\r\n HID_USAGE_GENERIC_SLIDER = $36;\r\n HID_USAGE_GENERIC_DIAL = $37;\r\n HID_USAGE_GENERIC_WHEEL = $38;\r\n HID_USAGE_GENERIC_HATSWITCH = $39;\r\n HID_USAGE_GENERIC_COUNTED_BUFFER = $3A;\r\n HID_USAGE_GENERIC_BYTE_COUNT = $3B;\r\n HID_USAGE_GENERIC_MOTION_WAKEUP = $3C;\r\n HID_USAGE_GENERIC_START = $3D;\r\n HID_USAGE_GENERIC_SELECT = $3E;\r\n HID_USAGE_GENERIC_RESERVED2 = $3F;\r\n HID_USAGE_GENERIC_VX = $40;\r\n HID_USAGE_GENERIC_VY = $41;\r\n HID_USAGE_GENERIC_VZ = $42;\r\n HID_USAGE_GENERIC_VBRX = $43;\r\n HID_USAGE_GENERIC_VBRY = $44;\r\n HID_USAGE_GENERIC_VBRZ = $45;\r\n HID_USAGE_GENERIC_VNO = $46;\r\n HID_USAGE_FEATURE_NOTIFICATION = $47;\r\n HID_USAGE_GENERIC_SYSTEM_CTL = $80;\r\n HID_USAGE_GENERIC_SYSCTL_POWER = $81;\r\n HID_USAGE_GENERIC_SYSCTL_SLEEP = $82;\r\n HID_USAGE_GENERIC_SYSCTL_WAKE = $83;\r\n HID_USAGE_GENERIC_SYSCTL_CONTEXT_MENU = $84;\r\n HID_USAGE_GENERIC_SYSCTL_MAIN_MENU = $85;\r\n HID_USAGE_GENERIC_SYSCTL_APP_MENU = $86;\r\n HID_USAGE_GENERIC_SYSCTL_HELP_MENU = $87;\r\n HID_USAGE_GENERIC_SYSCTL_MENU_EXIT = $88;\r\n HID_USAGE_GENERIC_SYSCTL_MENU_SELECT = $89;\r\n HID_USAGE_GENERIC_SYSCTL_MENU_RIGHT = $8A;\r\n HID_USAGE_GENERIC_SYSCTL_MENU_LEFT = $8B;\r\n HID_USAGE_GENERIC_SYSCTL_MENU_UP = $8C;\r\n HID_USAGE_GENERIC_SYSCTL_MENU_DOWN = $8D;\r\n HID_USAGE_GENERIC_SYSCTL_COLD_RESTART = $8E;\r\n HID_USAGE_GENERIC_SYSCTL_WARM_RESTART = $8F;\r\n HID_USAGE_GENERIC_SYSCTL_DPAD_UP = $90;\r\n HID_USAGE_GENERIC_SYSCTL_DPAD_DOWN = $91;\r\n HID_USAGE_GENERIC_SYSCTL_DPAD_RIGHT = $92;\r\n HID_USAGE_GENERIC_SYSCTL_DPAD_LEFT = $93;\r\n\r\n HID_USAGE_GENERIC_SYSCTL_DOCK = $A0;\r\n HID_USAGE_GENERIC_SYSCTL_UNDOCK = $A1;\r\n HID_USAGE_GENERIC_SYSCTL_SETUP = $A2;\r\n HID_USAGE_GENERIC_SYSCTL_BREAK = $A3;\r\n HID_USAGE_GENERIC_SYSCTL_DEBUGGER_BREAK = $A4;\r\n HID_USAGE_GENERIC_SYSCTL_APP_BREAK = $A5;\r\n HID_USAGE_GENERIC_SYSCTL_APP_DEBUGGER_BREAK = $A6;\r\n HID_USAGE_GENERIC_SYSCTL_SYSTEM_SPEAKER_MUTE = $A7;\r\n HID_USAGE_GENERIC_SYSCTL_SYSTEM_HIBERNATE = $A8;\r\n\r\n HID_USAGE_GENERIC_SYSCTL_DISPLAY_INVERT = $B0;\r\n HID_USAGE_GENERIC_SYSCTL_DISPLAY_INTERNAL = $B1;\r\n HID_USAGE_GENERIC_SYSCTL_DISPLAY_EXTERNAL = $B2;\r\n HID_USAGE_GENERIC_SYSCTL_DISPLAY_BOTH = $B3;\r\n HID_USAGE_GENERIC_SYSCTL_DISPLAY_DUAL = $B4;\r\n HID_USAGE_GENERIC_SYSCTL_DISPLAY_TOGGLE_INT_EXT = $B5;\r\n HID_USAGE_GENERIC_SYSCTL_DISPLAY_SWAP = $B6;\r\n HID_USAGE_GENERIC_SYSCTL_DISPLAY_LCD_AUTOSCALE = $B7;\r\n\r\n //\r\n // Usages from Simulation Controls Page (0x02)\r\n //\r\n HID_USAGE_SIMULATION_UNDEFINED = $00;\r\n HID_USAGE_SIMULATION_FLIGHT = $01;\r\n HID_USAGE_SIMULATION_AUTOMOBILE = $02;\r\n HID_USAGE_SIMULATION_TANK = $03;\r\n HID_USAGE_SIMULATION_SPACESHIP = $04;\r\n HID_USAGE_SIMULATION_SUBMARINE = $05;\r\n HID_USAGE_SIMULATION_SAILING = $06;\r\n HID_USAGE_SIMULATION_MOTORCYCLE = $07;\r\n HID_USAGE_SIMULATION_SPORTS = $08;\r\n HID_USAGE_SIMULATION_AIRPLANE = $09;\r\n HID_USAGE_SIMULATION_HELICOPTER = $0A;\r\n HID_USAGE_SIMULATION_MAGIC_CARPET = $0B;\r\n HID_USAGE_SIMULATION_BICYCLE = $0C;\r\n HID_USAGE_SIMULATION_FLIGHT_CONTROL_STICK = $20;\r\n HID_USAGE_SIMULATION_FLIGHT_STICK = $21;\r\n HID_USAGE_SIMULATION_CYCLIC_CONTROL = $22;\r\n HID_USAGE_SIMULATION_CYCLIC_TRIM = $23;\r\n HID_USAGE_SIMULATION_FLIGHT_YOKE = $24;\r\n HID_USAGE_SIMULATION_TRACK_CONTROL = $25;\r\n HID_USAGE_SIMULATION_AILERON = $B0;\r\n HID_USAGE_SIMULATION_AILERON_TRIM = $B1;\r\n HID_USAGE_SIMULATION_ANTITORQUE_CONTROL = $B2;\r\n HID_USAGE_SIMULATION_AUTOPILOT_ENABLE = $B3;\r\n HID_USAGE_SIMULATION_CHAFF_RELEASE = $B4;\r\n HID_USAGE_SIMULATION_COLLECTIVE_CONTROL = $B5;\r\n HID_USAGE_SIMULATION_DIVE_BREAK = $B6;\r\n HID_USAGE_SIMULATION_ELECTRONIC_COUNTERMEASURES = $B7;\r\n HID_USAGE_SIMULATION_ELEVATOR = $B8;\r\n HID_USAGE_SIMULATION_ELEVATOR_TRIM = $B9;\r\n HID_USAGE_SIMULATION_RUDDER = $BA;\r\n HID_USAGE_SIMULATION_THROTTLE = $BB;\r\n HID_USAGE_SIMULATION_FLIGHT_COMMUNICATIONS = $BC;\r\n HID_USAGE_SIMULATION_FLARE_RELEASE = $BD;\r\n HID_USAGE_SIMULATION_LANDING_GEAR = $BE;\r\n HID_USAGE_SIMULATION_TOE_BRAKE = $BF;\r\n HID_USAGE_SIMULATION_TRIGGER = $C0;\r\n HID_USAGE_SIMULATION_WEAPONS_ARM = $C1;\r\n HID_USAGE_SIMULATION_WEAPONS_SELECT = $C2;\r\n HID_USAGE_SIMULATION_WING_FLAPS = $C3;\r\n HID_USAGE_SIMULATION_ACCELERATOR = $C4;\r\n HID_USAGE_SIMULATION_BRAKE = $C5;\r\n HID_USAGE_SIMULATION_CLUTCH = $C6;\r\n HID_USAGE_SIMULATION_SHIFTER = $C7;\r\n HID_USAGE_SIMULATION_STEERING = $C8;\r\n HID_USAGE_SIMULATION_TURRET_DIRECTION = $C9;\r\n HID_USAGE_SIMULATION_BARREL_ELEVATION = $CA;\r\n HID_USAGE_SIMULATION_DIVE_PLANE = $CB;\r\n HID_USAGE_SIMULATION_BALLAST = $CC;\r\n HID_USAGE_SIMULATION_BICYCLE_CRANK = $CD;\r\n HID_USAGE_SIMULATION_HANDLE_BARS = $CE;\r\n HID_USAGE_SIMULATION_FRONT_BRAKE = $CF;\r\n HID_USAGE_SIMULATION_REAR_BRAKE = $D0;\r\n\r\n //\r\n // Virtual Reality Controls Page (0x03)\r\n //\r\n HID_USAGE_VR_UNDEFINED = $00;\r\n HID_USAGE_VR_BELT = $01;\r\n HID_USAGE_VR_BODY_SUIT = $02;\r\n HID_USAGE_VR_FLEXOR = $03;\r\n HID_USAGE_VR_GLOVE = $04;\r\n HID_USAGE_VR_HEAD_TRACKER = $05;\r\n HID_USAGE_VR_HEAD_MOUNTED_DISPLAY = $06;\r\n HID_USAGE_VR_HAND_TRACKER = $07;\r\n HID_USAGE_VR_OCULOMETER = $08;\r\n HID_USAGE_VR_VEST = $09;\r\n HID_USAGE_VR_ANIMATRONIC_DEVICE = $0A;\r\n\r\n HID_USAGE_VR_STEREO_ENABLE = $20;\r\n HID_USAGE_VR_DISPLAY_ENABLE = $21;\r\n\r\n //\r\n // Sport Controls Page (0x04)\r\n //\r\n HID_USAGE_SPORT_UNDEFINED = $00;\r\n HID_USAGE_SPORT_BASEBALL_BAT = $01;\r\n HID_USAGE_SPORT_GOLF_CLUB = $02;\r\n HID_USAGE_SPORT_ROWING_MACHINE = $03;\r\n HID_USAGE_SPORT_TREADMILL = $04;\r\n\r\n HID_USAGE_SPORT_OAR = $30;\r\n HID_USAGE_SPORT_SLOPE = $31;\r\n HID_USAGE_SPORT_RATE = $32;\r\n HID_USAGE_SPORT_STICK_SPEED = $33;\r\n HID_USAGE_SPORT_STICK_FACE_ANGLE = $34;\r\n HID_USAGE_SPORT_STICK_HEEL_TOE = $35;\r\n HID_USAGE_SPORT_STICK_FOLLOW_THROUGH = $36;\r\n HID_USAGE_SPORT_STICK_TEMPO = $37;\r\n HID_USAGE_SPORT_STICK_TYPE = $38;\r\n HID_USAGE_SPORT_STICK_HEIGHT = $39;\r\n\r\n HID_USAGE_SPORT_PUTTER = $50;\r\n HID_USAGE_SPORT_IRON_1 = $51;\r\n HID_USAGE_SPORT_IRON_2 = $52;\r\n HID_USAGE_SPORT_IRON_3 = $53;\r\n HID_USAGE_SPORT_IRON_4 = $54;\r\n HID_USAGE_SPORT_IRON_5 = $55;\r\n HID_USAGE_SPORT_IRON_6 = $56;\r\n HID_USAGE_SPORT_IRON_7 = $57;\r\n HID_USAGE_SPORT_IRON_8 = $58;\r\n HID_USAGE_SPORT_IRON_9 = $59;\r\n HID_USAGE_SPORT_IRON_10 = $5A;\r\n HID_USAGE_SPORT_IRON_11 = $5B;\r\n HID_USAGE_SPORT_SAND_WEDGE = $5C;\r\n HID_USAGE_SPORT_LOFT_WEDGE = $5D;\r\n HID_USAGE_SPORT_POWER_WEDGE = $5E;\r\n HID_USAGE_SPORT_WOOD_1 = $5F;\r\n HID_USAGE_SPORT_WOOD_3 = $60;\r\n HID_USAGE_SPORT_WOOD_5 = $61;\r\n HID_USAGE_SPORT_WOOD_7 = $62;\r\n HID_USAGE_SPORT_WOOD_9 = $63;\r\n\r\n //\r\n // Game Controls Page (0x05)\r\n //\r\n HID_USAGE_GAME_UNDEFINED = $00;\r\n HID_USAGE_GAME_3D_GAME_CONTROLLER = $01;\r\n HID_USAGE_GAME_PINBALL_DEVICE = $02;\r\n HID_USAGE_GAME_GUN_DEVICE = $03;\r\n\r\n HID_USAGE_GAME_POINT_OF_VIEW = $20;\r\n HID_USAGE_GAME_TURN_RIGHT_LEFT = $21;\r\n HID_USAGE_GAME_PITCH_FORWARD_BACKWARD = $22;\r\n HID_USAGE_GAME_ROLL_RIGHT_LEFT = $23;\r\n HID_USAGE_GAME_MOVE_RIGHT_LEFT = $24;\r\n HID_USAGE_GAME_MOVE_FORWARD_BACKWARD = $25;\r\n HID_USAGE_GAME_MOVE_UP_DOWN = $26;\r\n HID_USAGE_GAME_LEAN_RIGHT_LEFT = $27;\r\n HID_USAGE_GAME_LEAN_FORWARD_BACKWARD = $28;\r\n HID_USAGE_GAME_HEIGHT_OF_POV = $29;\r\n HID_USAGE_GAME_FLIPPER = $2A;\r\n HID_USAGE_GAME_SECONDARY_FLIPPER = $2B;\r\n HID_USAGE_GAME_BUMP = $2C;\r\n HID_USAGE_GAME_NEW_GAME = $2D;\r\n HID_USAGE_GAME_SHOOT_BALL = $2E;\r\n HID_USAGE_GAME_PLAYER = $2F;\r\n HID_USAGE_GAME_GUN_BOLT = $30;\r\n HID_USAGE_GAME_GUN_CLIP = $31;\r\n HID_USAGE_GAME_GUN_SELECTOR = $32;\r\n HID_USAGE_GAME_GUN_SINGLE_SHOT = $33;\r\n HID_USAGE_GAME_GUN_BURST = $34;\r\n HID_USAGE_GAME_GUN_AUTOMATIC = $35;\r\n HID_USAGE_GAME_GUN_SAFETY = $36;\r\n HID_USAGE_GAME_GAMEPAD_FIRE_JUMP = $37;\r\n\r\n HID_USAGE_GAME_GAMEPAD_TRIGGER = $39;\r\n\r\n //\r\n // Generic Device Controls Page (0x06)\r\n //\r\n HID_USAGE_GENERIC_GAME_UNDEFINED = $00;\r\n HID_USAGE_GENERIC_GAME_BATTERY_STRENGTH = $20;\r\n HID_USAGE_GENERIC_GAME_WIRELESS_CHANNEL = $21;\r\n HID_USAGE_GENERIC_GAME_WIRELESS_ID = $22;\r\n\r\n //\r\n // Keyboard/Keypad Page (0x07)\r\n //\r\n\r\n // Error \"keys\"\r\n HID_USAGE_KEYBOARD_NOEVENT = $00;\r\n HID_USAGE_KEYBOARD_ROLLOVER = $01;\r\n HID_USAGE_KEYBOARD_POSTFAIL = $02;\r\n HID_USAGE_KEYBOARD_UNDEFINED = $03;\r\n\r\n // Letters\r\n HID_USAGE_KEYBOARD_aA = $04;\r\n HID_USAGE_KEYBOARD_bB = $05;\r\n HID_USAGE_KEYBOARD_cC = $06;\r\n HID_USAGE_KEYBOARD_dD = $07;\r\n HID_USAGE_KEYBOARD_eE = $08;\r\n HID_USAGE_KEYBOARD_fF = $09;\r\n HID_USAGE_KEYBOARD_gG = $0A;\r\n HID_USAGE_KEYBOARD_hH = $0B;\r\n HID_USAGE_KEYBOARD_iI = $0C;\r\n HID_USAGE_KEYBOARD_jJ = $0D;\r\n HID_USAGE_KEYBOARD_kK = $0E;\r\n HID_USAGE_KEYBOARD_lL = $0F;\r\n HID_USAGE_KEYBOARD_mM = $10;\r\n HID_USAGE_KEYBOARD_nN = $11;\r\n HID_USAGE_KEYBOARD_oO = $12;\r\n HID_USAGE_KEYBOARD_pP = $13;\r\n HID_USAGE_KEYBOARD_qQ = $14;\r\n HID_USAGE_KEYBOARD_rR = $15;\r\n HID_USAGE_KEYBOARD_sS = $16;\r\n HID_USAGE_KEYBOARD_tT = $17;\r\n HID_USAGE_KEYBOARD_uU = $18;\r\n HID_USAGE_KEYBOARD_vV = $19;\r\n HID_USAGE_KEYBOARD_wW = $1A;\r\n HID_USAGE_KEYBOARD_xX = $1B;\r\n HID_USAGE_KEYBOARD_yY = $1C;\r\n HID_USAGE_KEYBOARD_zZ = $1D;\r\n\r\n // Numbers\r\n HID_USAGE_KEYBOARD_ONE = $1E; // or !\r\n HID_USAGE_KEYBOARD_TWO = $1F; // or @\r\n HID_USAGE_KEYBOARD_THREE = $20; // or #\r\n HID_USAGE_KEYBOARD_FOUR = $21; // or $\r\n HID_USAGE_KEYBOARD_FIVE = $22; // or %\r\n HID_USAGE_KEYBOARD_SIX = $23; // or ^\r\n HID_USAGE_KEYBOARD_SEVEN = $24; // or &\r\n HID_USAGE_KEYBOARD_EIGHT = $25; // or *\r\n HID_USAGE_KEYBOARD_NINE = $26; // or (\r\n HID_USAGE_KEYBOARD_ZERO = $27; // or )\r\n\r\n HID_USAGE_KEYBOARD_ENTER = $28; // RETURN is another key\r\n HID_USAGE_KEYBOARD_ESCAPE = $29;\r\n HID_USAGE_KEYBOARD_BACKSPACE = $2A; // Delete left char\r\n HID_USAGE_KEYBOARD_TAB = $2B;\r\n HID_USAGE_KEYBOARD_SPACE = $2C;\r\n HID_USAGE_KEYBOARD_MINUS = $2D; // or _\r\n HID_USAGE_KEYBOARD_EQUAL = $2E; // or +\r\n HID_USAGE_KEYBOARD_LSQBRACKET = $2F; // or {\r\n HID_USAGE_KEYBOARD_RSQBRACKET = $30; // or }\r\n HID_USAGE_KEYBOARD_BACKSLASH = $31; // or |\r\n HID_USAGE_KEYBOARD_HASHMARK2 = $32; // or ~ Non US Key\r\n HID_USAGE_KEYBOARD_SEMICOLON = $33;\r\n HID_USAGE_KEYBOARD_APOSTROPH = $34; // or :\r\n HID_USAGE_KEYBOARD_GRAVEACCENT = $35; // or Tilde\r\n HID_USAGE_KEYBOARD_COMMA = $36; // or <\r\n HID_USAGE_KEYBOARD_DOT = $37; // or >\r\n HID_USAGE_KEYBOARD_SLASH = $38; // or ?\r\n\r\n HID_USAGE_KEYBOARD_CAPS_LOCK = $39;\r\n\r\n // Function keys\r\n HID_USAGE_KEYBOARD_F1 = $3A;\r\n HID_USAGE_KEYBOARD_F2 = $3B;\r\n HID_USAGE_KEYBOARD_F3 = $3C;\r\n HID_USAGE_KEYBOARD_F4 = $3D;\r\n HID_USAGE_KEYBOARD_F5 = $3E;\r\n HID_USAGE_KEYBOARD_F6 = $3F;\r\n HID_USAGE_KEYBOARD_F7 = $40;\r\n HID_USAGE_KEYBOARD_F8 = $41;\r\n HID_USAGE_KEYBOARD_F9 = $42;\r\n HID_USAGE_KEYBOARD_F10 = $43;\r\n HID_USAGE_KEYBOARD_F11 = $44;\r\n HID_USAGE_KEYBOARD_F12 = $45;\r\n\r\n HID_USAGE_KEYBOARD_PRINT_SCREEN = $46;\r\n HID_USAGE_KEYBOARD_SCROLL_LOCK = $47;\r\n\r\n HID_USAGE_KEYBOARD_PAUSE = $48;\r\n HID_USAGE_KEYBOARD_INSERT = $49;\r\n HID_USAGE_KEYBOARD_HOME = $4A;\r\n HID_USAGE_KEYBOARD_PAGEUP = $4B;\r\n HID_USAGE_KEYBOARD_DELETE = $4C;\r\n HID_USAGE_KEYBOARD_END = $4D;\r\n HID_USAGE_KEYBOARD_PAGEDOWN = $4E;\r\n HID_USAGE_KEYBOARD_RIGHT = $4F;\r\n HID_USAGE_KEYBOARD_LEFT = $50;\r\n HID_USAGE_KEYBOARD_DOWN = $51;\r\n HID_USAGE_KEYBOARD_UP = $52;\r\n\r\n HID_USAGE_KEYPAD_NUM_LOCK = $53;\r\n HID_USAGE_KEYPAD_SLASH = $54;\r\n HID_USAGE_KEYPAD_STAR = $55;\r\n HID_USAGE_KEYPAD_MINUS = $56;\r\n HID_USAGE_KEYPAD_PLUS = $57;\r\n HID_USAGE_KEYPAD_ENTER = $58;\r\n HID_USAGE_KEYPAD_ONE = $59;\r\n HID_USAGE_KEYPAD_TWO = $5A;\r\n HID_USAGE_KEYPAD_THREE = $5B;\r\n HID_USAGE_KEYPAD_FOUR = $5C;\r\n HID_USAGE_KEYPAD_FIVE = $5D;\r\n HID_USAGE_KEYPAD_SIX = $5E;\r\n HID_USAGE_KEYPAD_SEVEN = $5F;\r\n HID_USAGE_KEYPAD_EIGHT = $60;\r\n HID_USAGE_KEYPAD_NINE = $61;\r\n HID_USAGE_KEYPAD_ZERO = $62;\r\n HID_USAGE_KEYPAD_DOT = $63;\r\n\r\n HID_USAGE_KEYBOARD_BACKSLASH2 = $64; // or | Non US key\r\n\r\n HID_USAGE_KEYBOARD_APPLICATION = $65;\r\n\r\n // Keys not for Windows\r\n HID_USAGE_KEYBOARD_POWER = $66;\r\n HID_USAGE_KEYPAD_EQUAL2 = $67;\r\n\r\n // Keys not for Windows\r\n HID_USAGE_KEYBOARD_F13 = $68;\r\n HID_USAGE_KEYBOARD_F14 = $69;\r\n HID_USAGE_KEYBOARD_F15 = $6A;\r\n HID_USAGE_KEYBOARD_F16 = $6B;\r\n HID_USAGE_KEYBOARD_F17 = $6C;\r\n HID_USAGE_KEYBOARD_F18 = $6D;\r\n HID_USAGE_KEYBOARD_F19 = $6E;\r\n HID_USAGE_KEYBOARD_F20 = $6F;\r\n HID_USAGE_KEYBOARD_F21 = $70;\r\n HID_USAGE_KEYBOARD_F22 = $71;\r\n HID_USAGE_KEYBOARD_F23 = $72;\r\n HID_USAGE_KEYBOARD_F24 = $73;\r\n HID_USAGE_KEYBOARD_EXECUTE = $74;\r\n HID_USAGE_KEYBOARD_HELP = $75;\r\n HID_USAGE_KEYBOARD_MENU = $76;\r\n HID_USAGE_KEYBOARD_SELECT = $77;\r\n HID_USAGE_KEYBOARD_STOP = $78;\r\n HID_USAGE_KEYBOARD_AGAIN = $79;\r\n HID_USAGE_KEYBOARD_UNDO = $7A;\r\n HID_USAGE_KEYBOARD_CUT = $7B;\r\n HID_USAGE_KEYBOARD_COPY = $7C;\r\n HID_USAGE_KEYBOARD_PASTE = $7D;\r\n HID_USAGE_KEYBOARD_FIND = $7E;\r\n HID_USAGE_KEYBOARD_MUTE = $7F;\r\n HID_USAGE_KEYBOARD_VOLUME_UP = $80;\r\n HID_USAGE_KEYBOARD_VOLUME_DOWN = $81;\r\n\r\n HID_USAGE_KEYBOARD_LOCKCAPS = $82;\r\n HID_USAGE_KEYBOARD_LOCKNUM = $83;\r\n HID_USAGE_KEYBOARD_LOCKSCROLL = $84;\r\n\r\n HID_USAGE_KEYPAD_COMMA = $85;\r\n HID_USAGE_KEYPAD_EQUALSIGN = $86;\r\n\r\n HID_USAGE_KEYBOARD_INATL1 = $87;\r\n HID_USAGE_KEYBOARD_INATL2 = $88;\r\n HID_USAGE_KEYBOARD_INATL3 = $89;\r\n HID_USAGE_KEYBOARD_INATL4 = $8A;\r\n HID_USAGE_KEYBOARD_INATL5 = $8B;\r\n HID_USAGE_KEYBOARD_INATL6 = $8C;\r\n HID_USAGE_KEYBOARD_INATL7 = $8D;\r\n HID_USAGE_KEYBOARD_INATL8 = $8E;\r\n HID_USAGE_KEYBOARD_INATL9 = $8F;\r\n HID_USAGE_KEYBOARD_LANG1 = $90;\r\n HID_USAGE_KEYBOARD_LANG2 = $91;\r\n HID_USAGE_KEYBOARD_LANG3 = $92;\r\n HID_USAGE_KEYBOARD_LANG4 = $93;\r\n HID_USAGE_KEYBOARD_LANG5 = $94;\r\n HID_USAGE_KEYBOARD_LANG6 = $95;\r\n HID_USAGE_KEYBOARD_LANG7 = $96;\r\n HID_USAGE_KEYBOARD_LANG8 = $97;\r\n HID_USAGE_KEYBOARD_LANG9 = $98;\r\n\r\n HID_USAGE_KEYBOARD_ALTERASE = $99;\r\n HID_USAGE_KEYBOARD_SYSREQ = $9A;\r\n HID_USAGE_KEYBOARD_CANCEL = $9B;\r\n HID_USAGE_KEYBOARD_CLEAR = $9C;\r\n HID_USAGE_KEYBOARD_PRIOR = $9D;\r\n HID_USAGE_KEYBOARD_RETURN = $9E;\r\n HID_USAGE_KEYBOARD_SEPARATOR = $9F;\r\n HID_USAGE_KEYBOARD_OUT = $A0;\r\n HID_USAGE_KEYBOARD_OPER = $A1;\r\n HID_USAGE_KEYBOARD_CLEAR_AGAIN = $A2;\r\n HID_USAGE_KEYBOARD_CRSEL = $A3;\r\n HID_USAGE_KEYBOARD_EXSEL = $A4;\r\n\r\n HID_USAGE_KEYPAD_HUNDREDS = $B0;\r\n HID_USAGE_KEYPAD_THOUSANDS = $B1;\r\n HID_USAGE_KEYPAD_THOUSANDS_SEP = $B2;\r\n HID_USAGE_KEYPAD_DECIMAL_SEP = $B3;\r\n HID_USAGE_KEYPAD_CURR_UNIT = $B4;\r\n HID_USAGE_KEYPAD_CURR_SUBUNIT = $B5;\r\n HID_USAGE_KEYPAD_LROUNDBRACKET = $B6;\r\n HID_USAGE_KEYPAD_RROUNDBRACKET = $B7;\r\n HID_USAGE_KEYPAD_LCURLYBRACKET = $B8;\r\n HID_USAGE_KEYPAD_RCURLYBRACKET = $B9;\r\n HID_USAGE_KEYPAD_TABULATOR = $BA;\r\n HID_USAGE_KEYPAD_BACKSPACE = $BB;\r\n HID_USAGE_KEYPAD_A = $BC;\r\n HID_USAGE_KEYPAD_B = $BD;\r\n HID_USAGE_KEYPAD_C = $BE;\r\n HID_USAGE_KEYPAD_D = $BF;\r\n HID_USAGE_KEYPAD_E = $C0;\r\n HID_USAGE_KEYPAD_F = $C1;\r\n HID_USAGE_KEYPAD_XOR = $C2;\r\n HID_USAGE_KEYPAD_CIRCUMFLEX = $C3;\r\n HID_USAGE_KEYPAD_PERCENT = $C4;\r\n HID_USAGE_KEYPAD_BIGGER_THAN = $C5;\r\n HID_USAGE_KEYPAD_LESS_THAN = $C6;\r\n HID_USAGE_KEYPAD_BINARY_AND = $C7;\r\n HID_USAGE_KEYPAD_LOGICAL_AND = $C8;\r\n HID_USAGE_KEYPAD_BINARY_OR = $C9;\r\n HID_USAGE_KEYPAD_LOGICAL_OR = $CA;\r\n HID_USAGE_KEYPAD_COLON = $CB;\r\n HID_USAGE_KEYPAD_HASHMARK = $CC;\r\n HID_USAGE_KEYPAD_SPACE = $CD;\r\n HID_USAGE_KEYPAD_AT = $CE;\r\n HID_USAGE_KEYPAD_EXCLAMATION = $CF;\r\n HID_USAGE_KEYPAD_MEM_STORE = $D0;\r\n HID_USAGE_KEYPAD_MEM_RECALL = $D1;\r\n HID_USAGE_KEYPAD_MEM_CLEAR = $D2;\r\n HID_USAGE_KEYPAD_MEM_ADD = $D3;\r\n HID_USAGE_KEYPAD_MEM_SUBTRACT = $D4;\r\n HID_USAGE_KEYPAD_MEM_MULTIPLY = $D5;\r\n HID_USAGE_KEYPAD_MEM_DIVIDE = $D6;\r\n HID_USAGE_KEYPAD_PLUS_MINUS = $D7;\r\n HID_USAGE_KEYPAD_CLEAR = $D8;\r\n HID_USAGE_KEYPAD_CLEAR_ENTRY = $D9;\r\n HID_USAGE_KEYPAD_BINARY = $DA;\r\n HID_USAGE_KEYPAD_OCTAL = $DB;\r\n HID_USAGE_KEYPAD_DECIMAL = $DC;\r\n HID_USAGE_KEYPAD_HEXADECIMAL = $DD;\r\n HID_USAGE_KEYPAD_RESERVED1 = $DE;\r\n HID_USAGE_KEYPAD_RESERVED2 = $DF;\r\n\r\n HID_USAGE_KEYBOARD_LCTRL = $E0;\r\n HID_USAGE_KEYBOARD_LSHFT = $E1;\r\n HID_USAGE_KEYBOARD_LALT = $E2;\r\n HID_USAGE_KEYBOARD_LGUI = $E3;\r\n HID_USAGE_KEYBOARD_RCTRL = $E4;\r\n HID_USAGE_KEYBOARD_RSHFT = $E5;\r\n HID_USAGE_KEYBOARD_RALT = $E6;\r\n HID_USAGE_KEYBOARD_RGUI = $E7;\r\n\r\n // and hundreds more...\r\n // (rom) $E8 to $FFFF are reserved in \"USB HID Usage Tables 1.11\" (Hut1_11.pdf)\r\n\r\n //\r\n // LED Page (0x08)\r\n //\r\n HID_USAGE_LED_UNDEFINED = $00;\r\n HID_USAGE_LED_NUM_LOCK = $01;\r\n HID_USAGE_LED_CAPS_LOCK = $02;\r\n HID_USAGE_LED_SCROLL_LOCK = $03;\r\n HID_USAGE_LED_COMPOSE = $04;\r\n HID_USAGE_LED_KANA = $05;\r\n HID_USAGE_LED_POWER = $06;\r\n HID_USAGE_LED_SHIFT = $07;\r\n HID_USAGE_LED_DO_NOT_DISTURB = $08;\r\n HID_USAGE_LED_MUTE = $09;\r\n HID_USAGE_LED_TONE_ENABLE = $0A;\r\n HID_USAGE_LED_HIGH_CUT_FILTER = $0B;\r\n HID_USAGE_LED_LOW_CUT_FILTER = $0C;\r\n HID_USAGE_LED_EQUALIZER_ENABLE = $0D;\r\n HID_USAGE_LED_SOUND_FIELD_ON = $0E;\r\n HID_USAGE_LED_SURROUND_FIELD_ON = $0F;\r\n HID_USAGE_LED_REPEAT = $10;\r\n HID_USAGE_LED_STEREO = $11;\r\n HID_USAGE_LED_SAMPLING_RATE_DETECT = $12;\r\n HID_USAGE_LED_SPINNING = $13;\r\n HID_USAGE_LED_CAV = $14;\r\n HID_USAGE_LED_CLV = $15;\r\n HID_USAGE_LED_RECORDING_FORMAT_DET = $16;\r\n HID_USAGE_LED_OFF_HOOK = $17;\r\n HID_USAGE_LED_RING = $18;\r\n HID_USAGE_LED_MESSAGE_WAITING = $19;\r\n HID_USAGE_LED_DATA_MODE = $1A;\r\n HID_USAGE_LED_BATTERY_OPERATION = $1B;\r\n HID_USAGE_LED_BATTERY_OK = $1C;\r\n HID_USAGE_LED_BATTERY_LOW = $1D;\r\n HID_USAGE_LED_SPEAKER = $1E;\r\n HID_USAGE_LED_HEAD_SET = $1F;\r\n HID_USAGE_LED_HOLD = $20;\r\n HID_USAGE_LED_MICROPHONE = $21;\r\n HID_USAGE_LED_COVERAGE = $22;\r\n HID_USAGE_LED_NIGHT_MODE = $23;\r\n HID_USAGE_LED_SEND_CALLS = $24;\r\n HID_USAGE_LED_CALL_PICKUP = $25;\r\n HID_USAGE_LED_CONFERENCE = $26;\r\n HID_USAGE_LED_STAND_BY = $27;\r\n HID_USAGE_LED_CAMERA_ON = $28;\r\n HID_USAGE_LED_CAMERA_OFF = $29;\r\n HID_USAGE_LED_ON_LINE = $2A;\r\n HID_USAGE_LED_OFF_LINE = $2B;\r\n HID_USAGE_LED_BUSY = $2C;\r\n HID_USAGE_LED_READY = $2D;\r\n HID_USAGE_LED_PAPER_OUT = $2E;\r\n HID_USAGE_LED_PAPER_JAM = $2F;\r\n HID_USAGE_LED_REMOTE = $30;\r\n HID_USAGE_LED_FORWARD = $31;\r\n HID_USAGE_LED_REVERSE = $32;\r\n HID_USAGE_LED_STOP = $33;\r\n HID_USAGE_LED_REWIND = $34;\r\n HID_USAGE_LED_FAST_FORWARD = $35;\r\n HID_USAGE_LED_PLAY = $36;\r\n HID_USAGE_LED_PAUSE = $37;\r\n HID_USAGE_LED_RECORD = $38;\r\n HID_USAGE_LED_ERROR = $39;\r\n HID_USAGE_LED_SELECTED_INDICATOR = $3A;\r\n HID_USAGE_LED_IN_USE_INDICATOR = $3B;\r\n HID_USAGE_LED_MULTI_MODE_INDICATOR = $3C;\r\n HID_USAGE_LED_INDICATOR_ON = $3D;\r\n HID_USAGE_LED_INDICATOR_FLASH = $3E;\r\n HID_USAGE_LED_INDICATOR_SLOW_BLINK = $3F;\r\n HID_USAGE_LED_INDICATOR_FAST_BLINK = $40;\r\n HID_USAGE_LED_INDICATOR_OFF = $41;\r\n HID_USAGE_LED_FLASH_ON_TIME = $42;\r\n HID_USAGE_LED_SLOW_BLINK_ON_TIME = $43;\r\n HID_USAGE_LED_SLOW_BLINK_OFF_TIME = $44;\r\n HID_USAGE_LED_FAST_BLINK_ON_TIME = $45;\r\n HID_USAGE_LED_FAST_BLINK_OFF_TIME = $46;\r\n HID_USAGE_LED_INDICATOR_COLOR = $47;\r\n HID_USAGE_LED_RED = $48;\r\n HID_USAGE_LED_GREEN = $49;\r\n HID_USAGE_LED_AMBER = $4A;\r\n HID_USAGE_LED_GENERIC_INDICATOR = $4B;\r\n HID_USAGE_LED_SYSTEM_SUSPEND = $4C;\r\n HID_USAGE_LED_EXTERNAL_POWER = $4D;\r\n\r\n // (rom) $4E to $FFFF are reserved in \"USB HID Usage Tables 1.11\" (Hut1_11.pdf)\r\n\r\n //\r\n // Button Page (0x09)\r\n //\r\n // There is no need to label these usages.\r\n //\r\n HID_USAGE_BUTTON_NO_BUTTON = $00; // (rom) Usage 1..65535 is the button number\r\n\r\n //\r\n // Ordinal Page (0x0A)\r\n //\r\n // There is no need to label these usages.\r\n //\r\n HID_USAGE_ORDINAL_RESERVED = $00; // (rom) Usage 1..65535 is the ordinal number\r\n\r\n //\r\n // Telephony Device Page (0x0B)\r\n //\r\n HID_USAGE_TELEPHONY_UNDEFINED = $00;\r\n HID_USAGE_TELEPHONY_PHONE = $01;\r\n HID_USAGE_TELEPHONY_ANSWERING_MACHINE = $02;\r\n HID_USAGE_TELEPHONY_MESSAGE_CONTROLS = $03;\r\n HID_USAGE_TELEPHONY_HANDSET = $04;\r\n HID_USAGE_TELEPHONY_HEADSET = $05;\r\n HID_USAGE_TELEPHONY_KEYPAD = $06;\r\n HID_USAGE_TELEPHONY_PROGRAMMABLE_BUTTON = $07;\r\n\r\n HID_USAGE_TELEPHONY_HOOK_SWITCH = $20;\r\n HID_USAGE_TELEPHONY_FLASH = $21;\r\n HID_USAGE_TELEPHONY_FEATURE = $22;\r\n HID_USAGE_TELEPHONY_HOLD = $23;\r\n HID_USAGE_TELEPHONY_REDIAL = $24;\r\n HID_USAGE_TELEPHONY_TRANSFER = $25;\r\n HID_USAGE_TELEPHONY_DROP = $26;\r\n HID_USAGE_TELEPHONY_PARK = $27;\r\n HID_USAGE_TELEPHONY_FORWARD_CALLS = $28;\r\n HID_USAGE_TELEPHONY_ALTERNATE_FUNCTION = $29;\r\n HID_USAGE_TELEPHONY_LINE = $2A;\r\n HID_USAGE_TELEPHONY_SPEAKER_PHONE = $2B;\r\n HID_USAGE_TELEPHONY_CONFERENCE = $2C;\r\n HID_USAGE_TELEPHONY_RING_ENABLE = $2D;\r\n HID_USAGE_TELEPHONY_RING_SELECT = $2E;\r\n HID_USAGE_TELEPHONY_PHONE_MUTE = $2F;\r\n HID_USAGE_TELEPHONY_CALLER_ID = $30;\r\n HID_USAGE_TELEPHONY_SEND = $31;\r\n\r\n HID_USAGE_TELEPHONY_SPEED_DIAL = $50;\r\n HID_USAGE_TELEPHONY_STORE_NUMBER = $51;\r\n HID_USAGE_TELEPHONY_RECALL_NUMBER = $52;\r\n HID_USAGE_TELEPHONY_PHONE_DIRECTORY = $53;\r\n\r\n HID_USAGE_TELEPHONY_VOICE_MAIL = $70;\r\n HID_USAGE_TELEPHONY_SCREEN_CALLS = $71;\r\n HID_USAGE_TELEPHONY_DO_NOT_DISTURB = $72;\r\n HID_USAGE_TELEPHONY_MESSAGE = $73;\r\n HID_USAGE_TELEPHONY_ANSWER_ON_OFF = $74;\r\n\r\n HID_USAGE_TELEPHONY_INSIDE_DIAL_TONE = $90;\r\n HID_USAGE_TELEPHONY_OUTSIDE_DIAL_TONE = $91;\r\n HID_USAGE_TELEPHONY_INSIDE_RING_TONE = $92;\r\n HID_USAGE_TELEPHONY_OUTSIDE_RING_TONE = $93;\r\n HID_USAGE_TELEPHONY_PRIORITY_RING_TONE = $94;\r\n HID_USAGE_TELEPHONY_INSIDE_RINGBACK = $95;\r\n HID_USAGE_TELEPHONY_PRIORITY_RINGBACK = $96;\r\n HID_USAGE_TELEPHONY_LINE_BUSY_TONE = $97;\r\n HID_USAGE_TELEPHONY_REORDER_TONE = $98;\r\n HID_USAGE_TELEPHONY_CALL_WAITING_TONE = $99;\r\n HID_USAGE_TELEPHONY_CONFIRMATION_TONE_1 = $9A;\r\n HID_USAGE_TELEPHONY_CONFIRMATION_TONE_2 = $9B;\r\n HID_USAGE_TELEPHONY_TONES_OFF = $9C;\r\n HID_USAGE_TELEPHONY_OUTSIDE_RINGBACK = $9D;\r\n HID_USAGE_TELEPHONY_RINGER = $9E;\r\n\r\n HID_USAGE_TELEPHONY_KEY_0 = $B0;\r\n HID_USAGE_TELEPHONY_KEY_1 = $B1;\r\n HID_USAGE_TELEPHONY_KEY_2 = $B2;\r\n HID_USAGE_TELEPHONY_KEY_3 = $B3;\r\n HID_USAGE_TELEPHONY_KEY_4 = $B4;\r\n HID_USAGE_TELEPHONY_KEY_5 = $B5;\r\n HID_USAGE_TELEPHONY_KEY_6 = $B6;\r\n HID_USAGE_TELEPHONY_KEY_7 = $B7;\r\n HID_USAGE_TELEPHONY_KEY_8 = $B8;\r\n HID_USAGE_TELEPHONY_KEY_9 = $B9;\r\n HID_USAGE_TELEPHONY_KEY_STAR = $BA;\r\n HID_USAGE_TELEPHONY_KEY_POUND = $BB;\r\n HID_USAGE_TELEPHONY_KEY_A = $BC;\r\n HID_USAGE_TELEPHONY_KEY_B = $BD;\r\n HID_USAGE_TELEPHONY_KEY_C = $BE;\r\n HID_USAGE_TELEPHONY_KEY_D = $BF;\r\n\r\n // (rom) $C0 to $FFFF are reserved in \"USB HID Usage Tables 1.11\" (Hut1_11.pdf)\r\n\r\n //\r\n // Consumer Page (0x0C)\r\n //\r\n HID_USAGE_CONSUMER_UNDEFINED = $000;\r\n HID_USAGE_CONSUMER_CONSUMER_CONTROL = $001;\r\n HID_USAGE_CONSUMER_NUMERIC_KEY_PAD = $002;\r\n HID_USAGE_CONSUMER_PROGRAMMABLE_BUTTONS = $003;\r\n HID_USAGE_CONSUMER_MICROPHONE = $004;\r\n HID_USAGE_CONSUMER_HEADPHONE = $005;\r\n HID_USAGE_CONSUMER_GRAPHIC_EQUALIZER = $006;\r\n\r\n HID_USAGE_CONSUMER_PLUS_10 = $020;\r\n HID_USAGE_CONSUMER_PLUS_100 = $021;\r\n HID_USAGE_CONSUMER_AM_PM = $022;\r\n\r\n HID_USAGE_CONSUMER_POWER = $030;\r\n HID_USAGE_CONSUMER_RESET = $031;\r\n HID_USAGE_CONSUMER_SLEEP = $032;\r\n HID_USAGE_CONSUMER_SLEEP_AFTER = $033;\r\n HID_USAGE_CONSUMER_SLEEP_MODE = $034;\r\n HID_USAGE_CONSUMER_ILLUMINATION = $035;\r\n HID_USAGE_CONSUMER_FUNCTION_BUTTONS = $036;\r\n\r\n HID_USAGE_CONSUMER_MENU = $040;\r\n HID_USAGE_CONSUMER_MENU_PICK = $041;\r\n HID_USAGE_CONSUMER_MENU_UP = $042;\r\n HID_USAGE_CONSUMER_MENU_DOWN = $043;\r\n HID_USAGE_CONSUMER_MENU_LEFT = $044;\r\n HID_USAGE_CONSUMER_MENU_RIGHT = $045;\r\n HID_USAGE_CONSUMER_MENU_ESCAPE = $046;\r\n HID_USAGE_CONSUMER_MENU_VALUE_INCREASE = $047;\r\n HID_USAGE_CONSUMER_MENU_VALUE_DECREASE = $048;\r\n\r\n HID_USAGE_CONSUMER_DATA_ON_SCREEN = $060;\r\n HID_USAGE_CONSUMER_CLOSED_CAPTION = $061;\r\n HID_USAGE_CONSUMER_CLOSED_CAPTION_SELECT = $062;\r\n HID_USAGE_CONSUMER_VCR_TV = $063;\r\n HID_USAGE_CONSUMER_BROADCAST_MODE = $064;\r\n HID_USAGE_CONSUMER_SNAPSHOT = $065;\r\n HID_USAGE_CONSUMER_STILL = $066;\r\n\r\n HID_USAGE_CONSUMER_SELECTION = $080;\r\n HID_USAGE_CONSUMER_ASSIGN_SELECTION = $081;\r\n HID_USAGE_CONSUMER_MODE_STEP = $082;\r\n HID_USAGE_CONSUMER_RECALL_LAST = $083;\r\n HID_USAGE_CONSUMER_ENTER_CHANNEL = $084;\r\n HID_USAGE_CONSUMER_ORDER_MOVIE = $085;\r\n HID_USAGE_CONSUMER_CHANNEL = $086;\r\n HID_USAGE_CONSUMER_MEDIA_SELECTION = $087;\r\n HID_USAGE_CONSUMER_MEDIA_SELECT_COMPUTER = $088;\r\n HID_USAGE_CONSUMER_MEDIA_SELECT_TV = $089;\r\n HID_USAGE_CONSUMER_MEDIA_SELECT_WWW = $08A;\r\n HID_USAGE_CONSUMER_MEDIA_SELECT_DVD = $08B;\r\n HID_USAGE_CONSUMER_MEDIA_SELECT_TELEPHONE = $08C;\r\n HID_USAGE_CONSUMER_MEDIA_SELECT_PROGRAM_GUIDE = $08D;\r\n HID_USAGE_CONSUMER_MEDIA_SELECT_VIDEO_PHONE = $08E;\r\n HID_USAGE_CONSUMER_MEDIA_SELECT_GAMES = $08F;\r\n HID_USAGE_CONSUMER_MEDIA_SELECT_MESSAGES = $090;\r\n HID_USAGE_CONSUMER_MEDIA_SELECT_CD = $091;\r\n HID_USAGE_CONSUMER_MEDIA_SELECT_VCR = $092;\r\n HID_USAGE_CONSUMER_MEDIA_SELECT_TUNER = $093;\r\n HID_USAGE_CONSUMER_QUIT = $094;\r\n HID_USAGE_CONSUMER_HELP = $095;\r\n HID_USAGE_CONSUMER_MEDIA_SELECT_TAPE = $096;\r\n HID_USAGE_CONSUMER_MEDIA_SELECT_CABLE = $097;\r\n HID_USAGE_CONSUMER_MEDIA_SELECT_SATELLITE = $098;\r\n HID_USAGE_CONSUMER_MEDIA_SELECT_SECURITY = $099;\r\n HID_USAGE_CONSUMER_MEDIA_SELECT_HOME = $09A;\r\n HID_USAGE_CONSUMER_MEDIA_SELECT_CALL = $09B;\r\n HID_USAGE_CONSUMER_CHANNEL_INCREMENT = $09C;\r\n HID_USAGE_CONSUMER_CHANNEL_DECREMENT = $09D;\r\n HID_USAGE_CONSUMER_MEDIA_SELECT_SAP = $09E;\r\n HID_USAGE_CONSUMER_RESERVED = $09F;\r\n HID_USAGE_CONSUMER_VCR_PLUS = $0A0;\r\n HID_USAGE_CONSUMER_ONCE = $0A1;\r\n HID_USAGE_CONSUMER_DAILY = $0A2;\r\n HID_USAGE_CONSUMER_WEEKLY = $0A3;\r\n HID_USAGE_CONSUMER_MONTHLY = $0A4;\r\n\r\n HID_USAGE_CONSUMER_PLAY = $0B0;\r\n HID_USAGE_CONSUMER_PAUSE = $0B1;\r\n HID_USAGE_CONSUMER_RECORD = $0B2;\r\n HID_USAGE_CONSUMER_FAST_FORWARD = $0B3;\r\n HID_USAGE_CONSUMER_REWIND = $0B4;\r\n HID_USAGE_CONSUMER_SCAN_NEXT_TRACK = $0B5;\r\n HID_USAGE_CONSUMER_SCAN_PREV_TRACK = $0B6;\r\n HID_USAGE_CONSUMER_STOP = $0B7;\r\n HID_USAGE_CONSUMER_EJECT = $0B8;\r\n HID_USAGE_CONSUMER_RANDOM_PLAY = $0B9;\r\n HID_USAGE_CONSUMER_SELECT_DISC = $0BA;\r\n HID_USAGE_CONSUMER_ENTER_DISC = $0BB;\r\n HID_USAGE_CONSUMER_REPEAT = $0BC;\r\n HID_USAGE_CONSUMER_TRACKING = $0BD;\r\n HID_USAGE_CONSUMER_TRACK_NORMAL = $0BE;\r\n HID_USAGE_CONSUMER_SLOW_TRACKING = $0BF;\r\n HID_USAGE_CONSUMER_FRAME_FORWARD = $0C0;\r\n HID_USAGE_CONSUMER_FRAME_BACK = $0C1;\r\n HID_USAGE_CONSUMER_MARK = $0C2;\r\n HID_USAGE_CONSUMER_CLEAR_MARK = $0C3;\r\n HID_USAGE_CONSUMER_REPEAT_FROM_MARK = $0C4;\r\n HID_USAGE_CONSUMER_RETURN_TO_MARK = $0C5;\r\n HID_USAGE_CONSUMER_SEARCH_MARK_FORWARD = $0C6;\r\n HID_USAGE_CONSUMER_SEARCK_MARK_BACKWARDS = $0C7;\r\n HID_USAGE_CONSUMER_COUNTER_RESET = $0C8;\r\n HID_USAGE_CONSUMER_SHOW_COUNTER = $0C9;\r\n HID_USAGE_CONSUMER_TRACKING_INCREMENT = $0CA;\r\n HID_USAGE_CONSUMER_TRACKING_DECREMENT = $0CB;\r\n HID_USAGE_CONSUMER_STOP_EJECT = $0CC;\r\n HID_USAGE_CONSUMER_PLAY_PAUSE = $0CD;\r\n HID_USAGE_CONSUMER_PLAY_SKIP = $0CE;\r\n\r\n HID_USAGE_CONSUMER_VOLUME = $0E0;\r\n HID_USAGE_CONSUMER_BALANCE = $0E1;\r\n HID_USAGE_CONSUMER_MUTE = $0E2;\r\n HID_USAGE_CONSUMER_BASS = $0E3;\r\n HID_USAGE_CONSUMER_TREBLE = $0E4;\r\n HID_USAGE_CONSUMER_BASS_BOOST = $0E5;\r\n HID_USAGE_CONSUMER_SURROUND_MODE = $0E6;\r\n HID_USAGE_CONSUMER_LOUDNESS = $0E7;\r\n HID_USAGE_CONSUMER_MPX = $0E8;\r\n HID_USAGE_CONSUMER_VOLUME_INCREMENT = $0E9;\r\n HID_USAGE_CONSUMER_VOLUME_DECREMENT = $0EA;\r\n\r\n HID_USAGE_CONSUMER_SPEED_SELECT = $0F0;\r\n HID_USAGE_CONSUMER_PLAYBACK_SPEED = $0F1;\r\n HID_USAGE_CONSUMER_STANDARD_PLAY = $0F2;\r\n HID_USAGE_CONSUMER_LONG_PLAY = $0F3;\r\n HID_USAGE_CONSUMER_EXTENDED_PLAY = $0F4;\r\n HID_USAGE_CONSUMER_SLOW = $0F5;\r\n\r\n HID_USAGE_CONSUMER_FAN_ENABLE = $100;\r\n HID_USAGE_CONSUMER_FAN_SPEED = $101;\r\n HID_USAGE_CONSUMER_LIGHT_ENABLE = $102;\r\n HID_USAGE_CONSUMER_LIGHT_ILLUMINATION_LEVEL = $103;\r\n HID_USAGE_CONSUMER_CLIMATE_CONTROL_ENABLE = $104;\r\n HID_USAGE_CONSUMER_ROOM_TEMPERATURE = $105;\r\n HID_USAGE_CONSUMER_SECURITY_ENABLE = $106;\r\n HID_USAGE_CONSUMER_FIRE_ALARM = $107;\r\n HID_USAGE_CONSUMER_POLICE_ALARM = $108;\r\n HID_USAGE_CONSUMER_PROXIMITY = $109;\r\n HID_USAGE_CONSUMER_MOTION = $10A;\r\n HID_USAGE_CONSUMER_DURESS_ALARM = $10B;\r\n HID_USAGE_CONSUMER_HOLDUP_ALARM = $10C;\r\n HID_USAGE_CONSUMER_MEDICAL_ALARM = $10D;\r\n\r\n HID_USAGE_CONSUMER_BALANCE_RIGHT = $150;\r\n HID_USAGE_CONSUMER_BALANCE_LEFT = $151;\r\n HID_USAGE_CONSUMER_BASS_INCREMENT = $152;\r\n HID_USAGE_CONSUMER_BASS_DECREMENT = $153;\r\n HID_USAGE_CONSUMER_TREBLE_INCREMENT = $154;\r\n HID_USAGE_CONSUMER_TREBLE_DECREMENT = $155;\r\n\r\n HID_USAGE_CONSUMER_SPEAKER_SYSTEM = $160;\r\n HID_USAGE_CONSUMER_CHANNEL_LEFT = $161;\r\n HID_USAGE_CONSUMER_CHANNEL_RIGHT = $162;\r\n HID_USAGE_CONSUMER_CHANNEL_CENTER = $163;\r\n HID_USAGE_CONSUMER_CHANNEL_FRONT = $164;\r\n HID_USAGE_CONSUMER_CHANNEL_CENTER_FRONT = $165;\r\n HID_USAGE_CONSUMER_CHANNEL_SIDE = $166;\r\n HID_USAGE_CONSUMER_CHANNEL_SURROUND = $167;\r\n HID_USAGE_CONSUMER_CHANNEL_LOW_FREQ_ENH = $168;\r\n HID_USAGE_CONSUMER_CHANNEL_TOP = $169;\r\n HID_USAGE_CONSUMER_CHANNEL_UNKNOWN = $16A;\r\n\r\n HID_USAGE_CONSUMER_SUB_CHANNEL = $170;\r\n HID_USAGE_CONSUMER_SUB_CHANNEL_INCREMENT = $171;\r\n HID_USAGE_CONSUMER_SUB_CHANNEL_DECREMENT = $172;\r\n HID_USAGE_CONSUMER_ALTERNATE_AUDIO_INCREMENT = $173;\r\n HID_USAGE_CONSUMER_ALTERNATE_AUDIO_DECREMENT = $174;\r\n\r\n HID_USAGE_CONSUMER_APP_LAUNCH_BUTTONS = $180;\r\n HID_USAGE_CONSUMER_AL_LAUNCH_BUTTON_CONFIG_TOOL = $181;\r\n HID_USAGE_CONSUMER_AL_PROG_BUTTON_CONFIG = $182;\r\n HID_USAGE_CONSUMER_AL_CONSUMER_CONTROL_CONFIG = $183;\r\n HID_USAGE_CONSUMER_AL_WORD_PROCESSOR = $184;\r\n HID_USAGE_CONSUMER_AL_TEXT_EDITOR = $185;\r\n HID_USAGE_CONSUMER_AL_SPREADSHEET = $186;\r\n HID_USAGE_CONSUMER_AL_GRAPHICS_EDITOR = $187;\r\n HID_USAGE_CONSUMER_AL_PRESENTATION_APP = $188;\r\n HID_USAGE_CONSUMER_AL_DATABASE_APP = $189;\r\n HID_USAGE_CONSUMER_AL_EMAIL_READER = $18A;\r\n HID_USAGE_CONSUMER_AL_NEWSREADER = $18B;\r\n HID_USAGE_CONSUMER_AL_VOICEMAIL = $18C;\r\n HID_USAGE_CONSUMER_AL_CONTACTS_ADDESSBOOK = $18D;\r\n HID_USAGE_CONSUMER_AL_CALENDAR_SCHEDULE = $18E;\r\n HID_USAGE_CONSUMER_AL_TASK_PROJECT_MANAGER = $18F;\r\n HID_USAGE_CONSUMER_AL_LOG_JOURNAL_TIMECARD = $190;\r\n HID_USAGE_CONSUMER_AL_CHECKBOOK_FINANCE = $191;\r\n HID_USAGE_CONSUMER_AL_CALCULATOR = $192;\r\n HID_USAGE_CONSUMER_AL_AV_CAPTURE_PLAYBACK = $193;\r\n HID_USAGE_CONSUMER_AL_LOCAL_MACHINE_BROWSER = $194;\r\n HID_USAGE_CONSUMER_AL_LAN_WAN_BROWSER = $195;\r\n HID_USAGE_CONSUMER_AL_INTERNET_BROWSER = $196;\r\n HID_USAGE_CONSUMER_AL_REMOTE_NETWORKING_ISP_CONNECT = $197;\r\n HID_USAGE_CONSUMER_AL_NETWORK_CONFERENCE = $198;\r\n HID_USAGE_CONSUMER_AL_NETWORK_CHAT = $199;\r\n HID_USAGE_CONSUMER_AL_TELEPHONY_DIALER = $19A;\r\n HID_USAGE_CONSUMER_AL_LOGON = $19B;\r\n HID_USAGE_CONSUMER_AL_LOGOFF = $19C;\r\n HID_USAGE_CONSUMER_AL_LOGON_LOGOFF = $19D;\r\n HID_USAGE_CONSUMER_AL_TERMINAL_LOCK_SCREENSAVER = $19E;\r\n HID_USAGE_CONSUMER_AL_CONTROL_PANEL = $19F;\r\n HID_USAGE_CONSUMER_AL_COMMAND_LINE_PROCESSOR_RUN = $1A0;\r\n HID_USAGE_CONSUMER_AL_PROCESS_TASK_MANAGER = $1A1;\r\n HID_USAGE_CONSUMER_AL_SELECT_TASK_APP = $1A2;\r\n HID_USAGE_CONSUMER_AL_NEXT_TASK_APP = $1A3;\r\n HID_USAGE_CONSUMER_AL_PREV_TASK_APP = $1A4;\r\n HID_USAGE_CONSUMER_AL_PREEMPTIVE_HALT_TASK_APP = $1A5;\r\n HID_USAGE_CONSUMER_AL_INTEGRATED_HELP_CENTER = $1A6;\r\n HID_USAGE_CONSUMER_AL_DOCUMENTS = $1A7;\r\n HID_USAGE_CONSUMER_AL_THESAURUS = $1A8;\r\n HID_USAGE_CONSUMER_AL_DICTIONARY = $1A9;\r\n HID_USAGE_CONSUMER_AL_DESKTOP = $1AA;\r\n HID_USAGE_CONSUMER_AL_SPELL_CHECK = $1AB;\r\n HID_USAGE_CONSUMER_AL_GRAMMAR_CHECK = $1AC;\r\n HID_USAGE_CONSUMER_AL_WIRELESS_STATUS = $1AD;\r\n HID_USAGE_CONSUMER_AL_KEYBOARD_LAYOUT = $1AE;\r\n HID_USAGE_CONSUMER_AL_VIRUS_PROTECTION = $1AF;\r\n HID_USAGE_CONSUMER_AL_ENCRYPTION = $1B0;\r\n HID_USAGE_CONSUMER_AL_SCREENSAVER = $1B1;\r\n HID_USAGE_CONSUMER_AL_ALARMS = $1B2;\r\n HID_USAGE_CONSUMER_AL_CLOCK = $1B3;\r\n HID_USAGE_CONSUMER_AL_FILE_BROWSER = $1B4;\r\n HID_USAGE_CONSUMER_AL_POWER_STATUS = $1B5;\r\n\r\n HID_USAGE_CONSUMER_GENERIC_GUI_APP_CONTROLS = $200;\r\n HID_USAGE_CONSUMER_AC_NEW = $201;\r\n HID_USAGE_CONSUMER_AC_OPEN = $202;\r\n HID_USAGE_CONSUMER_AC_CLOSE = $203;\r\n HID_USAGE_CONSUMER_AC_EXIT = $204;\r\n HID_USAGE_CONSUMER_AC_MAXIMIZE = $205;\r\n HID_USAGE_CONSUMER_AC_MINIMIZE = $206;\r\n HID_USAGE_CONSUMER_AC_SAVE = $207;\r\n HID_USAGE_CONSUMER_AC_PRINT = $208;\r\n HID_USAGE_CONSUMER_AC_PROPERTIES = $209;\r\n\r\n HID_USAGE_CONSUMER_AC_UNDO = $21A;\r\n HID_USAGE_CONSUMER_AC_COPY = $21B;\r\n HID_USAGE_CONSUMER_AC_CUT = $21C;\r\n HID_USAGE_CONSUMER_AC_PASTE = $21D;\r\n HID_USAGE_CONSUMER_AC_SELECT_ALL = $21E;\r\n HID_USAGE_CONSUMER_AC_FIND = $21F;\r\n HID_USAGE_CONSUMER_AC_FIND_AND_REPLACE = $220;\r\n HID_USAGE_CONSUMER_AC_SEARCH = $221;\r\n HID_USAGE_CONSUMER_AC_GO_TO = $222;\r\n HID_USAGE_CONSUMER_AC_HOME = $223;\r\n HID_USAGE_CONSUMER_AC_BACK = $224;\r\n HID_USAGE_CONSUMER_AC_FORWARD = $225;\r\n HID_USAGE_CONSUMER_AC_STOP = $226;\r\n HID_USAGE_CONSUMER_AC_REFRESH = $227;\r\n HID_USAGE_CONSUMER_AC_PREV_LINK = $228;\r\n HID_USAGE_CONSUMER_AC_NEXT_LINK = $229;\r\n HID_USAGE_CONSUMER_AC_BOOKMARKS = $22A;\r\n HID_USAGE_CONSUMER_AC_HISTORY = $22B;\r\n HID_USAGE_CONSUMER_AC_SUBSCRIPTIONS = $22C;\r\n HID_USAGE_CONSUMER_AC_ZOOM_IN = $22D;\r\n HID_USAGE_CONSUMER_AC_ZOOM_OUT = $22E;\r\n HID_USAGE_CONSUMER_AC_ZOOM = $22F;\r\n HID_USAGE_CONSUMER_AC_FULL_SCREEN_VIEW = $230;\r\n HID_USAGE_CONSUMER_AC_NORMAL_VIEW = $231;\r\n HID_USAGE_CONSUMER_AC_VIEW_TOGGLE = $232;\r\n HID_USAGE_CONSUMER_AC_SCROLL_UP = $233;\r\n HID_USAGE_CONSUMER_AC_SCROLL_DOWN = $234;\r\n HID_USAGE_CONSUMER_AC_SCROLL = $235;\r\n HID_USAGE_CONSUMER_AC_PAN_LEFT = $236;\r\n HID_USAGE_CONSUMER_AC_PAN_RIGHT = $237;\r\n HID_USAGE_CONSUMER_AC_PAN = $238;\r\n HID_USAGE_CONSUMER_AC_NEW_WINDOW = $239;\r\n HID_USAGE_CONSUMER_AC_TILE_HORIZONTALLY = $23A;\r\n HID_USAGE_CONSUMER_AC_TILE_VERTICALLY = $23B;\r\n HID_USAGE_CONSUMER_AC_FORMAT = $23C;\r\n HID_USAGE_CONSUMER_AC_EDIT = $23D;\r\n HID_USAGE_CONSUMER_AC_BOLD = $23E;\r\n HID_USAGE_CONSUMER_AC_ITALICS = $23F;\r\n HID_USAGE_CONSUMER_AC_UNDERLINE = $240;\r\n HID_USAGE_CONSUMER_AC_STRIKETHROUGH = $241;\r\n HID_USAGE_CONSUMER_AC_SUBSCRIPT = $242;\r\n HID_USAGE_CONSUMER_AC_SUPERSCRIPT = $243;\r\n HID_USAGE_CONSUMER_AC_ALL_CAPS = $244;\r\n HID_USAGE_CONSUMER_AC_ROTATE = $245;\r\n HID_USAGE_CONSUMER_AC_RESIZE = $246;\r\n HID_USAGE_CONSUMER_AC_FLIP_HORIZONTAL = $247;\r\n HID_USAGE_CONSUMER_AC_FLIP_VERTICAL = $248;\r\n HID_USAGE_CONSUMER_AC_MIRROR_HORIZONTAL = $249;\r\n HID_USAGE_CONSUMER_AC_MIRROR_VERTICAL = $24A;\r\n HID_USAGE_CONSUMER_AC_FONT_SELECT = $24B;\r\n HID_USAGE_CONSUMER_AC_FONT_COLOR = $24C;\r\n HID_USAGE_CONSUMER_AC_FONT_SIZE = $24D;\r\n HID_USAGE_CONSUMER_AC_JUSTIFY_LEFT = $24E;\r\n HID_USAGE_CONSUMER_AC_JUSTIFY_CENTER_H = $24F;\r\n HID_USAGE_CONSUMER_AC_JUSTIFY_RIGHT = $250;\r\n HID_USAGE_CONSUMER_AC_JUSTIFY_BLOCK_H = $251;\r\n HID_USAGE_CONSUMER_AC_JUSTIFY_TOP = $252;\r\n HID_USAGE_CONSUMER_AC_JUSTIFY_CENTER_V = $253;\r\n HID_USAGE_CONSUMER_AC_JUSTIFY_BOTTOM = $254;\r\n HID_USAGE_CONSUMER_AC_JUSTIFY_BLOCK_V = $255;\r\n HID_USAGE_CONSUMER_AC_INDENT_DECREASE = $256;\r\n HID_USAGE_CONSUMER_AC_INDENT_INCREASE = $257;\r\n HID_USAGE_CONSUMER_AC_NUMBERED_LIST = $258;\r\n HID_USAGE_CONSUMER_AC_RESTART_NUMBERING = $259;\r\n HID_USAGE_CONSUMER_AC_BULLETED_LIST = $25A;\r\n HID_USAGE_CONSUMER_AC_PROMOTE = $25B;\r\n HID_USAGE_CONSUMER_AC_DEMOTE = $25C;\r\n HID_USAGE_CONSUMER_AC_YES = $25D;\r\n HID_USAGE_CONSUMER_AC_NO = $25E;\r\n HID_USAGE_CONSUMER_AC_CANCEL = $25F;\r\n HID_USAGE_CONSUMER_AC_CATALOG = $260;\r\n HID_USAGE_CONSUMER_AC_BUY_CHECKOUT = $261;\r\n HID_USAGE_CONSUMER_AC_ADD_TO_CART = $262;\r\n HID_USAGE_CONSUMER_AC_EXPAND = $263;\r\n HID_USAGE_CONSUMER_AC_EXPAND_ALL = $264;\r\n HID_USAGE_CONSUMER_AC_COLLAPSE = $265;\r\n HID_USAGE_CONSUMER_AC_COLLAPSE_ALL = $266;\r\n HID_USAGE_CONSUMER_AC_PRINT_PREVIEW = $267;\r\n HID_USAGE_CONSUMER_AC_PASTE_SPECIAL = $268;\r\n HID_USAGE_CONSUMER_AC_INSERT_MODE = $269;\r\n HID_USAGE_CONSUMER_AC_DELETE = $26A;\r\n HID_USAGE_CONSUMER_AC_LOCK = $26B;\r\n HID_USAGE_CONSUMER_AC_UNLOCK = $26C;\r\n HID_USAGE_CONSUMER_AC_PROTECT = $26D;\r\n HID_USAGE_CONSUMER_AC_UNPROTECT = $26E;\r\n HID_USAGE_CONSUMER_AC_ATTACH_COMMENT = $26F;\r\n HID_USAGE_CONSUMER_AC_DELETE_COMMENT = $270;\r\n HID_USAGE_CONSUMER_AC_VIEW_COMMENT = $271;\r\n HID_USAGE_CONSUMER_AC_SELECT_WORD = $272;\r\n HID_USAGE_CONSUMER_AC_SELECT_SENTENCE = $273;\r\n HID_USAGE_CONSUMER_AC_SELECT_PARAGRAPH = $274;\r\n HID_USAGE_CONSUMER_AC_SELECT_COLUMN = $275;\r\n HID_USAGE_CONSUMER_AC_SELECT_ROW = $276;\r\n HID_USAGE_CONSUMER_AC_SELECT_TABLE = $277;\r\n HID_USAGE_CONSUMER_AC_SELECT_OBJECT = $278;\r\n HID_USAGE_CONSUMER_AC_REDO_REPEAT = $279;\r\n HID_USAGE_CONSUMER_AC_SORT = $27A;\r\n HID_USAGE_CONSUMER_AC_SORT_ASCENDING = $27B;\r\n HID_USAGE_CONSUMER_AC_SORT_DESCENDING = $27C;\r\n HID_USAGE_CONSUMER_AC_FILTER = $27D;\r\n HID_USAGE_CONSUMER_AC_SET_CLOCK = $27E;\r\n HID_USAGE_CONSUMER_AC_VIEW_CLOCK = $27F;\r\n HID_USAGE_CONSUMER_AC_SELECT_TIME_ZONE = $280;\r\n HID_USAGE_CONSUMER_AC_EDIT_TIME_ZONES = $281;\r\n HID_USAGE_CONSUMER_AC_SET_ALARM = $282;\r\n HID_USAGE_CONSUMER_AC_CLEAR_ALARM = $283;\r\n HID_USAGE_CONSUMER_AC_SNOOZE_ALARM = $284;\r\n HID_USAGE_CONSUMER_AC_RESET_ALARM = $285;\r\n HID_USAGE_CONSUMER_AC_SYNCHRONIZE = $286;\r\n HID_USAGE_CONSUMER_AC_SEND_RECEIVE = $287;\r\n HID_USAGE_CONSUMER_AC_SEND_TO = $288;\r\n HID_USAGE_CONSUMER_AC_REPLY = $289;\r\n HID_USAGE_CONSUMER_AC_REPLY_ALL = $28A;\r\n HID_USAGE_CONSUMER_AC_FORWARD_MSG = $28B;\r\n HID_USAGE_CONSUMER_AC_SEND = $28C;\r\n HID_USAGE_CONSUMER_AC_ATTACH_FILE = $28D;\r\n HID_USAGE_CONSUMER_AC_UPLOAD = $28E;\r\n HID_USAGE_CONSUMER_AC_DOWNLOAD = $28F;\r\n HID_USAGE_CONSUMER_AC_SET_BORDERS = $290;\r\n HID_USAGE_CONSUMER_AC_INSERT_ROW = $291;\r\n HID_USAGE_CONSUMER_AC_INSERT_COLUMN = $292;\r\n HID_USAGE_CONSUMER_AC_INSERT_FILE = $293;\r\n HID_USAGE_CONSUMER_AC_INSERT_PICTURE = $294;\r\n HID_USAGE_CONSUMER_AC_INSERT_OBJECT = $295;\r\n HID_USAGE_CONSUMER_AC_INSERT_SYMBOL = $296;\r\n HID_USAGE_CONSUMER_AC_SAVE_AND_CLOSE = $297;\r\n HID_USAGE_CONSUMER_AC_RENAME = $298;\r\n HID_USAGE_CONSUMER_AC_MERGE = $299;\r\n HID_USAGE_CONSUMER_AC_SPLIT = $29A;\r\n HID_USAGE_CONSUMER_AC_DISTRIBUTE_HORIZONTALLY = $29B;\r\n HID_USAGE_CONSUMER_AC_DISTRIBUTE_VERTICALLY = $29C;\r\n\r\n // (rom) $29D to $FFFF are reserved in \"USB HID Usage Tables 1.11\" (Hut1_11.pdf)\r\n\r\n //\r\n // Digitizer Page (0x0D)\r\n //\r\n HID_USAGE_DIGITIZER_UNDEFINED = $00;\r\n HID_USAGE_DIGITIZER_DIGITIZER = $01;\r\n HID_USAGE_DIGITIZER_PEN = $02;\r\n HID_USAGE_DIGITIZER_LIGHT_PEN = $03;\r\n HID_USAGE_DIGITIZER_TOUCH_SCREEN = $04;\r\n HID_USAGE_DIGITIZER_TOUCH_PAD = $05;\r\n HID_USAGE_DIGITIZER_WHITE_BOARD = $06;\r\n HID_USAGE_DIGITIZER_COORDINATE_MEASURING_MACHINE = $07;\r\n HID_USAGE_DIGITIZER_3D_DIGITIZER = $08;\r\n HID_USAGE_DIGITIZER_STEREO_PLOTTER = $09;\r\n HID_USAGE_DIGITIZER_ARTICULATED_ARM = $0A;\r\n HID_USAGE_DIGITIZER_ARMATURE = $0B;\r\n HID_USAGE_DIGITIZER_MULTIPLE_POINT_DIGITIZER = $0C;\r\n HID_USAGE_DIGITIZER_FREE_SPACE_WAND = $0D;\r\n\r\n HID_USAGE_DIGITIZER_STYLUS = $20;\r\n HID_USAGE_DIGITIZER_PUCK = $21;\r\n HID_USAGE_DIGITIZER_FINGER = $22;\r\n\r\n HID_USAGE_DIGITIZER_TIP_PRESSURE = $30;\r\n HID_USAGE_DIGITIZER_BARREL_PRESSURE = $31;\r\n HID_USAGE_DIGITIZER_IN_RANGE = $32;\r\n HID_USAGE_DIGITIZER_TOUCH = $33;\r\n HID_USAGE_DIGITIZER_UNTOUCH = $34;\r\n HID_USAGE_DIGITIZER_TAP = $35;\r\n HID_USAGE_DIGITIZER_QUALITY = $36;\r\n HID_USAGE_DIGITIZER_DATA_VALID = $37;\r\n HID_USAGE_DIGITIZER_TRANSDUCER_INDEX = $38;\r\n HID_USAGE_DIGITIZER_TABLET_FUNCTION_KEYS = $39;\r\n HID_USAGE_DIGITIZER_PROGRAM_CHANGE_KEYS = $3A;\r\n HID_USAGE_DIGITIZER_BATTERY_STRENGTH = $3B;\r\n HID_USAGE_DIGITIZER_INVERT = $3C;\r\n HID_USAGE_DIGITIZER_X_TILT = $3D;\r\n HID_USAGE_DIGITIZER_Y_TILT = $3E;\r\n HID_USAGE_DIGITIZER_AZIMUTH = $3F;\r\n HID_USAGE_DIGITIZER_ALTITUDE = $40;\r\n HID_USAGE_DIGITIZER_TWIST = $41;\r\n HID_USAGE_DIGITIZER_TIP_SWITCH = $42;\r\n HID_USAGE_DIGITIZER_SECONDARY_TIP_SWITCH = $43;\r\n HID_USAGE_DIGITIZER_BARREL_SWITCH = $44;\r\n HID_USAGE_DIGITIZER_ERASER = $45;\r\n HID_USAGE_DIGITIZER_TABLET_PICK = $46;\r\n\r\n // (rom) $47 to $FFFF are reserved in \"USB HID Usage Tables 1.11\" (Hut1_11.pdf)\r\n\r\n //\r\n // Physical Input Page (0x0F)\r\n //\r\n HID_USAGE_PID_UNDEFINED = $00;\r\n HID_USAGE_PID_PHYSICAL_INTERFACE_DEVICE = $01;\r\n \r\n HID_USAGE_PID_NORMAL = $20;\r\n HID_USAGE_PID_SET_EFFECT_REPORT = $21;\r\n HID_USAGE_PID_EFFECT_BLOCK_INDEX = $22;\r\n HID_USAGE_PID_PARAMETER_BLOCK_OFFSET = $23;\r\n HID_USAGE_PID_ROM_FLAG = $24;\r\n HID_USAGE_PID_EFFECT_TYPE = $25;\r\n HID_USAGE_PID_ET_CONSTANT_FORCE = $26;\r\n HID_USAGE_PID_ET_RAMP = $27;\r\n HID_USAGE_PID_ET_CUSTOM_FORCE_DATA = $28;\r\n\r\n HID_USAGE_PID_ET_SQUARE = $30;\r\n HID_USAGE_PID_ET_SINE = $31;\r\n HID_USAGE_PID_ET_TRIANGLE = $32;\r\n HID_USAGE_PID_ET_SAWTOOTH_UP = $33;\r\n HID_USAGE_PID_ET_SAWTOOTH_DOWN = $34;\r\n\r\n HID_USAGE_PID_ET_SPRING = $40;\r\n HID_USAGE_PID_ET_DAMPER = $41;\r\n HID_USAGE_PID_ET_INERTIA = $42;\r\n HID_USAGE_PID_ET_FRICTION = $43;\r\n\r\n HID_USAGE_PID_DURATION = $50;\r\n HID_USAGE_PID_SAMPLE_PERIOD = $51;\r\n HID_USAGE_PID_GAIN = $52;\r\n HID_USAGE_PID_TRIGGER_BUTTON = $53;\r\n HID_USAGE_PID_TRIGGER_REPEAT_INTERVAL = $54;\r\n HID_USAGE_PID_AXES_ENABLE = $55;\r\n HID_USAGE_PID_DIRECTION_ENABLE = $56;\r\n HID_USAGE_PID_DIRECTION = $57;\r\n HID_USAGE_PID_TYPE_SPECIFIC_BLOCK_OFFSET = $58;\r\n HID_USAGE_PID_BLOCK_TYPE = $59;\r\n HID_USAGE_PID_SET_ENVELOPE_REPORT = $5A;\r\n HID_USAGE_PID_ATTACK_LEVEL = $5B;\r\n HID_USAGE_PID_ATTACK_TIME = $5C;\r\n HID_USAGE_PID_FADE_LEVEL = $5D;\r\n HID_USAGE_PID_FADE_TIME = $5E;\r\n HID_USAGE_PID_SET_CONDITION_REPORT = $5F;\r\n HID_USAGE_PID_CP_OFFSET = $60;\r\n HID_USAGE_PID_POSITIVE_COEFFICIENT = $61;\r\n HID_USAGE_PID_NEGATIVE_COEFFICIENT = $62;\r\n HID_USAGE_PID_POSITIVE_SATURATION = $63;\r\n HID_USAGE_PID_NEGATIVE_SATURATION = $64;\r\n HID_USAGE_PID_DEAD_BAND = $65;\r\n HID_USAGE_PID_DOWNLOAD_FORCE_SAMPLE = $66;\r\n HID_USAGE_PID_ISOCH_CUSTOM_FORCE_ENABLE = $67;\r\n HID_USAGE_PID_CUSTOM_FORCE_DATA_REPORT = $68;\r\n HID_USAGE_PID_CUSTOM_FORCE_DATA = $69;\r\n HID_USAGE_PID_CUSTOM_FORCE_VENDOR_DEFINED_DATA = $6A;\r\n HID_USAGE_PID_SET_CUSTOM_FORCE_REPORT = $6B;\r\n HID_USAGE_PID_CUSTOM_FORCE_DATA_OFFSET = $6C;\r\n HID_USAGE_PID_SAMPLE_COUNT = $6D;\r\n HID_USAGE_PID_SET_PERIODIC_REPORT = $6E;\r\n HID_USAGE_PID_OFFSET = $6F;\r\n HID_USAGE_PID_MAGNITUDE = $70;\r\n HID_USAGE_PID_PHASE = $71;\r\n HID_USAGE_PID_PERIOD = $72;\r\n HID_USAGE_PID_SET_CONSTANT_FORCE_REPORT = $73;\r\n HID_USAGE_PID_SET_RAMP_FORCE_REPORT = $74;\r\n HID_USAGE_PID_RAMP_START = $75;\r\n HID_USAGE_PID_RAMP_END = $76;\r\n HID_USAGE_PID_EFFECT_OPERATION_REPORT = $77;\r\n HID_USAGE_PID_EFFECT_OPERATION = $78;\r\n HID_USAGE_PID_OP_EFFECT_START = $79;\r\n HID_USAGE_PID_OP_EFFECT_START_SOLO = $7A;\r\n HID_USAGE_PID_OP_EFFECT_STOP = $7B;\r\n HID_USAGE_PID_LOOP_COUNT = $7C;\r\n HID_USAGE_PID_DEVICE_GAIN_REPORT = $7D;\r\n HID_USAGE_PID_DEVICE_GAIN = $7E;\r\n HID_USAGE_PID_PID_POOL_REPORT = $7F;\r\n HID_USAGE_PID_RAM_POOL_SIZE = $80;\r\n HID_USAGE_PID_ROM_POOL_SIZE = $81;\r\n HID_USAGE_PID_ROM_EFFECT_BLOCK_COUNT = $82;\r\n HID_USAGE_PID_SIMULTANEOUS_EFFECTS_MAX = $83;\r\n HID_USAGE_PID_POOL_ALIGNMENT = $84;\r\n HID_USAGE_PID_PID_POOL_MOVE_REPORT = $85;\r\n HID_USAGE_PID_MOVE_SOURCE = $86;\r\n HID_USAGE_PID_MOVE_DESTINATION = $87;\r\n HID_USAGE_PID_MOVE_LENGTH = $88;\r\n HID_USAGE_PID_PID_BLOCK_LOAD_REPORT = $89;\r\n\r\n HID_USAGE_PID_BLOCK_LOAD_STATUS = $8B;\r\n HID_USAGE_PID_BLOCK_LOAD_SUCCESS = $8C;\r\n HID_USAGE_PID_BLOCK_LOAD_FULL = $8D;\r\n HID_USAGE_PID_BLOCK_LOAD_ERROR = $8E;\r\n HID_USAGE_PID_BLOCK_HANDLE = $8F;\r\n HID_USAGE_PID_PID_BLOCK_FREE_REPORT = $90;\r\n HID_USAGE_PID_TYPE_SPECIFIC_BLOCK_HANDLE = $91;\r\n HID_USAGE_PID_PID_STATE_REPORT = $92;\r\n\r\n HID_USAGE_PID_EFFECT_PLAYING = $94;\r\n HID_USAGE_PID_PID_DEVICE_CONTROL_REPORT = $95;\r\n HID_USAGE_PID_PID_DEVICE_CONTROL = $96;\r\n HID_USAGE_PID_DC_ENABLE_ACTUATORS = $97;\r\n HID_USAGE_PID_DC_DISABLE_ACTUATORS = $98;\r\n HID_USAGE_PID_DC_STOP_ALL_EFFECTS = $99;\r\n HID_USAGE_PID_DC_DEVICE_RESET = $9A;\r\n HID_USAGE_PID_DC_DEVICE_PAUSE = $9B;\r\n HID_USAGE_PID_DC_DEVICE_CONTINUE = $9C;\r\n\r\n HID_USAGE_PID_DEVICE_PAUSED = $9F;\r\n HID_USAGE_PID_ACTUATORS_ENABLED = $A0;\r\n\r\n HID_USAGE_PID_SAFETY_SWITCH = $A4;\r\n HID_USAGE_PID_ACTUATOR_OVERRIDE_SWITCH = $A5;\r\n HID_USAGE_PID_ACTUATOR_POWER = $A6;\r\n HID_USAGE_PID_START_DELAY = $A7;\r\n HID_USAGE_PID_PARAMETER_BLOCK_SIZE = $A8;\r\n HID_USAGE_PID_DEVICE_MANAGED_POOL = $A9;\r\n HID_USAGE_PID_SHARED_PARAMETER_BLOCKS = $AA;\r\n HID_USAGE_PID_CREATE_NEW_EFFECT_REPORT = $AB;\r\n HID_USAGE_PID_RAM_POOL_AVAILABLE = $AC;\r\n\r\n // (rom) $AD to $FFFF are reserved in \"Device Class Definition for Physical Interface Devices 1.0\" (pid1_01.pdf)\r\n\r\n //\r\n // Unicode Page (0x10)\r\n //\r\n // (rom) The Unicode Page directly maps to the two-octet form defined in the Unicode Standard\r\n\r\n //\r\n // Alphanumeric Display Page (0x14)\r\n //\r\n HID_USAGE_ALNUM_DISPLAY_UNDEFINED = $00;\r\n HID_USAGE_ALNUM_DISPLAY_ALPHANUMERIC_DISPLAY = $01;\r\n\r\n HID_USAGE_ALNUM_DISPLAY_DISPLAY_ATTRIBUTES_REPORT = $20;\r\n HID_USAGE_ALNUM_DISPLAY_ASCII_CHARSET = $21;\r\n HID_USAGE_ALNUM_DISPLAY_DATA_READ_BACK = $22;\r\n HID_USAGE_ALNUM_DISPLAY_FONT_READ_BACK = $23;\r\n HID_USAGE_ALNUM_DISPLAY_DISPLAY_CONTROL_REPORT = $24;\r\n HID_USAGE_ALNUM_DISPLAY_CLEAR_DISPLAY = $25;\r\n HID_USAGE_ALNUM_DISPLAY_DISPLAY_ENABLE = $26;\r\n HID_USAGE_ALNUM_DISPLAY_SCREEN_SAVER_DELAY = $27;\r\n HID_USAGE_ALNUM_DISPLAY_SCREEN_SAVER_ENABLE = $28;\r\n HID_USAGE_ALNUM_DISPLAY_VERTICAL_SCROLL = $29;\r\n HID_USAGE_ALNUM_DISPLAY_HORIZONTAL_SCROLL = $2A;\r\n HID_USAGE_ALNUM_DISPLAY_CHARACTER_REPORT = $2B;\r\n HID_USAGE_ALNUM_DISPLAY_DISPLAY_DATA = $2C;\r\n HID_USAGE_ALNUM_DISPLAY_DISPLAY_STATUS = $2D;\r\n HID_USAGE_ALNUM_DISPLAY_STAT_NOT_READY = $2E;\r\n HID_USAGE_ALNUM_DISPLAY_STAT_READY = $2F;\r\n HID_USAGE_ALNUM_DISPLAY_ERR_NOT_A_LOADABLE_CHAR = $30;\r\n HID_USAGE_ALNUM_DISPLAY_ERR_FONT_DATA_CANNOT_BE_READ = $31;\r\n HID_USAGE_ALNUM_DISPLAY_CURSOR_POSITION_REPORT = $32;\r\n HID_USAGE_ALNUM_DISPLAY_ROW = $33;\r\n HID_USAGE_ALNUM_DISPLAY_COLUMN = $34;\r\n HID_USAGE_ALNUM_DISPLAY_ROWS = $35;\r\n HID_USAGE_ALNUM_DISPLAY_COLUMNS = $36;\r\n HID_USAGE_ALNUM_DISPLAY_CURSOR_PIXEL_POSITIONING = $37;\r\n HID_USAGE_ALNUM_DISPLAY_CURSOR_MODE = $38;\r\n HID_USAGE_ALNUM_DISPLAY_CURSOR_ENABLE = $39;\r\n HID_USAGE_ALNUM_DISPLAY_CURSOR_BLINK = $3A;\r\n HID_USAGE_ALNUM_DISPLAY_FONT_REPORT = $3B;\r\n HID_USAGE_ALNUM_DISPLAY_FONT_DATA = $3C;\r\n HID_USAGE_ALNUM_DISPLAY_CHAR_WIDTH = $3D;\r\n HID_USAGE_ALNUM_DISPLAY_CHAR_HEIGHT = $3E;\r\n HID_USAGE_ALNUM_DISPLAY_CHAR_SPACING_HORIZONTAL = $3F;\r\n HID_USAGE_ALNUM_DISPLAY_CHAR_SPACING_VERTICAL = $40;\r\n HID_USAGE_ALNUM_DISPLAY_UNICODE_CHARSET = $41;\r\n HID_USAGE_ALNUM_DISPLAY_FONT_7_SEGMENT = $42;\r\n HID_USAGE_ALNUM_DISPLAY_7_SEGMENT_DIRECT_MAP = $43;\r\n HID_USAGE_ALNUM_DISPLAY_FONT_14_SEGMENT = $44;\r\n HID_USAGE_ALNUM_DISPLAY_14_SEGMENT_DIRECT_MAP = $45;\r\n HID_USAGE_ALNUM_DISPLAY_DISPLAY_BRIGHTNESS = $46;\r\n HID_USAGE_ALNUM_DISPLAY_DISPLAY_CONTRAST = $47;\r\n HID_USAGE_ALNUM_DISPLAY_CHAR_ATTRIBUTE = $48;\r\n HID_USAGE_ALNUM_DISPLAY_ATTRIBUTE_READBACK = $49;\r\n HID_USAGE_ALNUM_DISPLAY_ATTRIBUTE_DATA = $4A;\r\n HID_USAGE_ALNUM_DISPLAY_CHAR_ATTR_ENHANCE = $4B;\r\n HID_USAGE_ALNUM_DISPLAY_CHAR_ATTR_UNDERLINE = $4C;\r\n HID_USAGE_ALNUM_DISPLAY_CHAR_ATTR_BLINK = $4D;\r\n\r\n // (rom) $4E to $FFFF are reserved in \"USB HID Usage Tables 1.11\" (Hut1_11.pdf)\r\n\r\n //\r\n // Medical Instrument Page (0x40)\r\n //\r\n HID_USAGE_MEDICAL_INSTRUMENT_UNDEFINED = $00;\r\n HID_USAGE_MEDICAL_INSTRUMENT_MEDICAL_ULTRASOUND = $01;\r\n\r\n HID_USAGE_MEDICAL_INSTRUMENT_VCR_AQUISITION = $20;\r\n HID_USAGE_MEDICAL_INSTRUMENT_FREEZE_THAW = $21;\r\n HID_USAGE_MEDICAL_INSTRUMENT_CLIP_STORE = $22;\r\n HID_USAGE_MEDICAL_INSTRUMENT_UPDATE = $23;\r\n HID_USAGE_MEDICAL_INSTRUMENT_NEXT = $24;\r\n HID_USAGE_MEDICAL_INSTRUMENT_SAVE = $25;\r\n HID_USAGE_MEDICAL_INSTRUMENT_PRINT = $26;\r\n HID_USAGE_MEDICAL_INSTRUMENT_MICROPHONE_ENABLE = $27;\r\n\r\n HID_USAGE_MEDICAL_INSTRUMENT_CINE = $40;\r\n HID_USAGE_MEDICAL_INSTRUMENT_TRANSMIT_POWER = $41;\r\n HID_USAGE_MEDICAL_INSTRUMENT_VOLUME = $42;\r\n HID_USAGE_MEDICAL_INSTRUMENT_FOCUS = $43;\r\n HID_USAGE_MEDICAL_INSTRUMENT_DEPTH = $44;\r\n\r\n HID_USAGE_MEDICAL_INSTRUMENT_SOFT_STEP_PRIMARY = $60;\r\n HID_USAGE_MEDICAL_INSTRUMENT_SOFT_STEP_SECONDARY = $61;\r\n\r\n HID_USAGE_MEDICAL_INSTRUMENT_DEPTH_GAIN_COMPENSATION = $70;\r\n\r\n HID_USAGE_MEDICAL_INSTRUMENT_ZOOM_SELECT = $80;\r\n HID_USAGE_MEDICAL_INSTRUMENT_ZOOM_ADJUST = $81;\r\n HID_USAGE_MEDICAL_INSTRUMENT_SPECTRAL_DOPPLER_MODE_SELECT = $82;\r\n HID_USAGE_MEDICAL_INSTRUMENT_SPECTRAL_DOPPLER_ADJUST = $83;\r\n HID_USAGE_MEDICAL_INSTRUMENT_COLOR_DOPPLER_MODE_SELECT = $84;\r\n HID_USAGE_MEDICAL_INSTRUMENT_COLOR_DOPPLER_ADJUST = $85;\r\n HID_USAGE_MEDICAL_INSTRUMENT_MOTION_MODE_SELECT = $86;\r\n HID_USAGE_MEDICAL_INSTRUMENT_MOTION_MODE_ADJUST = $87;\r\n HID_USAGE_MEDICAL_INSTRUMENT_2D_MODE_SELECT = $88;\r\n HID_USAGE_MEDICAL_INSTRUMENT_2D_MODE_ADJUST = $89;\r\n\r\n HID_USAGE_MEDICAL_INSTRUMENT_SOFT_CONTROL_SELECT = $A0;\r\n HID_USAGE_MEDICAL_INSTRUMENT_SOFT_CONTROL_ADJUST = $A1;\r\n\r\n // (rom) $A2 to $FFFF are reserved in \"USB HID Usage Tables 1.11\" (Hut1_11.pdf)\r\n\r\n //\r\n // USB Monitor Page (0x80)\r\n //\r\n HID_USAGE_MONITOR_RESERVED = $00;\r\n HID_USAGE_MONITOR_MONITOR_CONTROL = $01;\r\n HID_USAGE_MONITOR_EDID_INFORMATION = $02;\r\n HID_USAGE_MONITOR_VDIF_INFORMATION = $03;\r\n HID_USAGE_MONITOR_VESA_VERSION = $04;\r\n\r\n //\r\n // Monitor Enumerated Values Page (0x81)\r\n //\r\n HID_USAGE_MONITOR_ENUM_VALUE_NO_VALUE = $00;\r\n\r\n // (rom) read \"usbmon10.pdf\" from USB IF for more info\r\n\r\n //\r\n // Monitor VESA Virtual Control Page (0x82)\r\n //\r\n HID_USAGE_MONITOR_VESA_BRIGHTNESS = $10;\r\n HID_USAGE_MONITOR_VESA_CONTRAST = $12;\r\n HID_USAGE_MONITOR_VESA_RED_VIDEO_GAIN = $16;\r\n HID_USAGE_MONITOR_VESA_GREEN_VIDEO_GAIN = $18;\r\n HID_USAGE_MONITOR_VESA_BLUE_VIDEO_GAIN = $1A;\r\n HID_USAGE_MONITOR_VESA_FOCUS = $1C;\r\n HID_USAGE_MONITOR_VESA_HORIZONTAL_POS = $20;\r\n HID_USAGE_MONITOR_VESA_HORIZONTAL_SIZE = $22;\r\n HID_USAGE_MONITOR_VESA_HORIZONTAL_PINCUSHION = $24;\r\n HID_USAGE_MONITOR_VESA_HORIZONTAL_PINCUSHION_BALANCE = $26;\r\n HID_USAGE_MONITOR_VESA_HORIZONTAL_MISCONVERGENCE = $28;\r\n HID_USAGE_MONITOR_VESA_HORIZONTAL_LINEARITY = $2A;\r\n HID_USAGE_MONITOR_VESA_HORIZONTAL_LINEARITY_BALANCE = $2C;\r\n HID_USAGE_MONITOR_VESA_VERTICAL_POS = $30;\r\n HID_USAGE_MONITOR_VESA_VERTICAL_SIZE = $32;\r\n HID_USAGE_MONITOR_VESA_VERTICAL_PINCUSHION = $34;\r\n HID_USAGE_MONITOR_VESA_VERTICAL_PINCUSHION_BALANCE = $36;\r\n HID_USAGE_MONITOR_VESA_VERTICAL_MISCONVERGENCE = $38;\r\n HID_USAGE_MONITOR_VESA_VERTICAL_LINEARITY = $3A;\r\n HID_USAGE_MONITOR_VESA_VERTICAL_LINEARITY_BALANCE = $3C;\r\n HID_USAGE_MONITOR_VESA_PARALLELOGRAM_DISTORTION = $40;\r\n HID_USAGE_MONITOR_VESA_TRAPEZOIDAL_DISTORTION = $42;\r\n HID_USAGE_MONITOR_VESA_TILT = $44;\r\n HID_USAGE_MONITOR_VESA_TOP_CORNER_DISTORTION = $46;\r\n HID_USAGE_MONITOR_VESA_TOP_CORNER_DISTORTION_BALANCE = $48;\r\n HID_USAGE_MONITOR_VESA_BOTTOM_CORNER_DISTORTION = $4A;\r\n HID_USAGE_MONITOR_VESA_BOTTOM_CORNER_DISTORTION_BALANCE = $4C;\r\n HID_USAGE_MONITOR_VESA_HORIZONTAL_MOIRE = $56;\r\n HID_USAGE_MONITOR_VESA_VERTICAL_MOIRE = $58;\r\n HID_USAGE_MONITOR_VESA_RED_VIDEO_BLACK_LEVEL = $6C;\r\n HID_USAGE_MONITOR_VESA_GREEN_VIDEO_BLACK_LEVEL = $6E;\r\n HID_USAGE_MONITOR_VESA_BLUE_VIDEO_BLACK_LEVEL = $70;\r\n HID_USAGE_MONITOR_VESA_INPUT_LEVEL_SELECT = $5E;\r\n HID_USAGE_MONITOR_VESA_INPUT_SOURCE_SELECT = $60;\r\n HID_USAGE_MONITOR_VESA_ON_SCREEN_DISPLAY = $CA;\r\n HID_USAGE_MONITOR_VESA_STEREO_MODE = $D4;\r\n HID_USAGE_MONITOR_VESA_AUTO_SIZE_CENTER = $A2;\r\n HID_USAGE_MONITOR_VESA_POLARITY_HORIZONTAL_SYNC = $A4;\r\n HID_USAGE_MONITOR_VESA_POLARITY_VERTICAL_SYNC = $A6;\r\n HID_USAGE_MONITOR_VESA_SYNC_TYPE = $A8;\r\n HID_USAGE_MONITOR_VESA_SCREEN_ORIENTATION = $AA;\r\n HID_USAGE_MONITOR_VESA_HORIZONTAL_FREQUENCY = $AC;\r\n HID_USAGE_MONITOR_VESA_VERTICAL_FREQUENCY = $AE;\r\n HID_USAGE_MONITOR_VESA_DEGAUSS = $01;\r\n HID_USAGE_MONITOR_VESA_SETTINGS = $B0;\r\n\r\n //\r\n // Monitor Reserved Page (0x83)\r\n //\r\n\r\n //\r\n // Power Device Page (0x84)\r\n //\r\n HID_USAGE_POWER_DEVICE_UNDEFINED = $00;\r\n HID_USAGE_POWER_DEVICE_INAME = $01;\r\n HID_USAGE_POWER_DEVICE_PRESENT_STATUS = $02;\r\n HID_USAGE_POWER_DEVICE_CHANGED_STATUS = $03;\r\n HID_USAGE_POWER_DEVICE_UPS = $04;\r\n HID_USAGE_POWER_DEVICE_POWER_SUPPLY = $05;\r\n\r\n HID_USAGE_POWER_DEVICE_BATTERY_SYSTEM = $10;\r\n HID_USAGE_POWER_DEVICE_BATTERY_SYSTEM_ID = $11;\r\n HID_USAGE_POWER_DEVICE_BATTERY = $12;\r\n HID_USAGE_POWER_DEVICE_BATTERY_ID = $13;\r\n HID_USAGE_POWER_DEVICE_CHARGER = $14;\r\n HID_USAGE_POWER_DEVICE_CHARGER_ID = $15;\r\n HID_USAGE_POWER_DEVICE_POWER_CONVERTER = $16;\r\n HID_USAGE_POWER_DEVICE_POWER_CONVERTER_ID = $17;\r\n HID_USAGE_POWER_DEVICE_OUTLET_SYSTEM = $18;\r\n HID_USAGE_POWER_DEVICE_OUTLET_SYSTEM_ID = $19;\r\n HID_USAGE_POWER_DEVICE_INPUT = $1A;\r\n HID_USAGE_POWER_DEVICE_INPUT_ID = $1B;\r\n HID_USAGE_POWER_DEVICE_OUTPUT = $1C;\r\n HID_USAGE_POWER_DEVICE_OUTPUT_ID = $1D;\r\n HID_USAGE_POWER_DEVICE_FLOW = $1E;\r\n HID_USAGE_POWER_DEVICE_FLOW_ID = $1F;\r\n HID_USAGE_POWER_DEVICE_OUTLET = $20;\r\n HID_USAGE_POWER_DEVICE_OUTLET_ID = $21;\r\n HID_USAGE_POWER_DEVICE_GANG = $22;\r\n HID_USAGE_POWER_DEVICE_GANG_ID = $23;\r\n HID_USAGE_POWER_DEVICE_POWER_SUMMARY = $24;\r\n HID_USAGE_POWER_DEVICE_POWER_SUMMARY_ID = $25;\r\n\r\n HID_USAGE_POWER_DEVICE_VOLTAGE = $30;\r\n HID_USAGE_POWER_DEVICE_CURRENT = $31;\r\n HID_USAGE_POWER_DEVICE_FREQUENCY = $32;\r\n HID_USAGE_POWER_DEVICE_APPARENT_POWER = $33;\r\n HID_USAGE_POWER_DEVICE_ACTIVE_POWER = $34;\r\n HID_USAGE_POWER_DEVICE_PERCENT_LOAD = $35;\r\n HID_USAGE_POWER_DEVICE_TEMPERATURE = $36;\r\n HID_USAGE_POWER_DEVICE_HUMIDITY = $37;\r\n HID_USAGE_POWER_DEVICE_BAD_COUNT = $38;\r\n\r\n HID_USAGE_POWER_DEVICE_CONFIG_VOLTAGE = $40;\r\n HID_USAGE_POWER_DEVICE_CONFIG_CURRENT = $41;\r\n HID_USAGE_POWER_DEVICE_CONFIG_FREQUENCY = $42;\r\n HID_USAGE_POWER_DEVICE_CONFIG_APPARENT_POWER = $43;\r\n HID_USAGE_POWER_DEVICE_CONFIG_ACTIVE_POWER = $44;\r\n HID_USAGE_POWER_DEVICE_CONFIG_PERCENT_LOAD = $45;\r\n HID_USAGE_POWER_DEVICE_CONFIG_TEMPERATURE = $46;\r\n HID_USAGE_POWER_DEVICE_CONFIG_HUMIDITY = $47;\r\n\r\n HID_USAGE_POWER_DEVICE_SWITCH_ON_CONTROL = $50;\r\n HID_USAGE_POWER_DEVICE_SWITCH_OFF_CONTROL = $51;\r\n HID_USAGE_POWER_DEVICE_TOGGLE_CONTROL = $52;\r\n HID_USAGE_POWER_DEVICE_LOW_VOLTAGE_TRANSFER = $53;\r\n HID_USAGE_POWER_DEVICE_HIGH_VOLTAGE_TRANSFER = $54;\r\n HID_USAGE_POWER_DEVICE_DELAY_BEFORE_REBOOT = $55;\r\n HID_USAGE_POWER_DEVICE_DELAY_BEFORE_STARTUP = $56;\r\n HID_USAGE_POWER_DEVICE_DELAY_BEFORE_SHUTDOWN = $57;\r\n HID_USAGE_POWER_DEVICE_TEST = $58;\r\n HID_USAGE_POWER_DEVICE_MODULE_RESET = $59;\r\n HID_USAGE_POWER_DEVICE_AUDIBLE_ALARM_CONTROL = $5A;\r\n\r\n HID_USAGE_POWER_DEVICE_PRESENT = $60;\r\n HID_USAGE_POWER_DEVICE_GOOD = $61;\r\n HID_USAGE_POWER_DEVICE_INTERNAL_FAILURE = $62;\r\n HID_USAGE_POWER_DEVICE_VOLTAGE_OUT_OF_RANGE = $63;\r\n HID_USAGE_POWER_DEVICE_FREQUENCY_OUT_OF_RANGE = $64;\r\n HID_USAGE_POWER_DEVICE_OVERLOAD = $65;\r\n HID_USAGE_POWER_DEVICE_OVERCHARGED = $66;\r\n HID_USAGE_POWER_DEVICE_OVERTEMPERATURE = $67;\r\n HID_USAGE_POWER_DEVICE_SHUTDOWN_REQUESTED = $68;\r\n HID_USAGE_POWER_DEVICE_SHUTDOWN_IMMINENT = $69;\r\n\r\n HID_USAGE_POWER_DEVICE_SWITCH_ON_OFF = $6B;\r\n HID_USAGE_POWER_DEVICE_SWITCHABLE = $6C;\r\n HID_USAGE_POWER_DEVICE_USED = $6D;\r\n HID_USAGE_POWER_DEVICE_BOOST = $6E;\r\n HID_USAGE_POWER_DEVICE_BUCK = $6F;\r\n HID_USAGE_POWER_DEVICE_INITIALIZED = $70;\r\n HID_USAGE_POWER_DEVICE_TESTED = $71;\r\n HID_USAGE_POWER_DEVICE_AWAITING_POWER = $72;\r\n HID_USAGE_POWER_DEVICE_COMMUNICATION_LOST = $73;\r\n\r\n HID_USAGE_POWER_DEVICE_IMANUFACTURER = $FD;\r\n HID_USAGE_POWER_DEVICE_IPRODUCT = $FE;\r\n HID_USAGE_POWER_DEVICE_ISERIALNUMBER = $FF;\r\n\r\n //\r\n // Battery System Page (0x85)\r\n //\r\n HID_USAGE_BATTERY_SYSTEM_UNDEFINED = $00;\r\n HID_USAGE_BATTERY_SYSTEM_SMB_BATTERY_MODE = $01;\r\n HID_USAGE_BATTERY_SYSTEM_SMB_BATTERY_STATUS = $02;\r\n HID_USAGE_BATTERY_SYSTEM_SMB_ALARM_WARNING = $03;\r\n HID_USAGE_BATTERY_SYSTEM_SMB_CHARGER_MODE = $04;\r\n HID_USAGE_BATTERY_SYSTEM_SMB_CHARGER_STATUS = $05;\r\n HID_USAGE_BATTERY_SYSTEM_SMB_CHARGER_SPEC_INFO = $06;\r\n HID_USAGE_BATTERY_SYSTEM_SMB_SELECTOR_STATE = $07;\r\n HID_USAGE_BATTERY_SYSTEM_SMB_SELECTOR_PRESETS = $08;\r\n HID_USAGE_BATTERY_SYSTEM_SMB_SELECTOR_INFO = $09;\r\n \r\n HID_USAGE_BATTERY_SYSTEM_OPTIONAL_MFG_FUNCTION_1 = $10;\r\n HID_USAGE_BATTERY_SYSTEM_OPTIONAL_MFG_FUNCTION_2 = $11;\r\n HID_USAGE_BATTERY_SYSTEM_OPTIONAL_MFG_FUNCTION_3 = $12;\r\n HID_USAGE_BATTERY_SYSTEM_OPTIONAL_MFG_FUNCTION_4 = $13;\r\n HID_USAGE_BATTERY_SYSTEM_OPTIONAL_MFG_FUNCTION_5 = $14;\r\n HID_USAGE_BATTERY_SYSTEM_CONNECTION_TO_SMBUS = $15;\r\n HID_USAGE_BATTERY_SYSTEM_OUTPUT_CONNECTION = $16;\r\n HID_USAGE_BATTERY_SYSTEM_CHARGER_CONNECTION = $17;\r\n HID_USAGE_BATTERY_SYSTEM_BATTERY_INSERTION = $18;\r\n HID_USAGE_BATTERY_SYSTEM_USE_NEXT = $19;\r\n HID_USAGE_BATTERY_SYSTEM_OK_TO_USE = $1A;\r\n HID_USAGE_BATTERY_SYSTEM_BATTERY_SUPPORTED = $1B;\r\n HID_USAGE_BATTERY_SYSTEM_SELECTOR_REVISION = $1C;\r\n HID_USAGE_BATTERY_SYSTEM_CHARGING_INDICATOR = $1D;\r\n\r\n HID_USAGE_BATTERY_SYSTEM_MANUFACTURER_ACCESS = $28;\r\n HID_USAGE_BATTERY_SYSTEM_REMAINING_CAPACITY_LIMIT = $29;\r\n HID_USAGE_BATTERY_SYSTEM_REMAINING_TIME_LIMIT = $2A;\r\n HID_USAGE_BATTERY_SYSTEM_AT_RATE = $2B;\r\n HID_USAGE_BATTERY_SYSTEM_CAPACITY_MODE = $2C;\r\n HID_USAGE_BATTERY_SYSTEM_BROADCAST_TO_CHARGER = $2D;\r\n HID_USAGE_BATTERY_SYSTEM_PRIMARY_BATTERY = $2E;\r\n HID_USAGE_BATTERY_SYSTEM_CHARGE_CONTROLLER = $2F;\r\n\r\n HID_USAGE_BATTERY_SYSTEM_TERMINATE_CHARGE = $40;\r\n HID_USAGE_BATTERY_SYSTEM_TERMINATE_DISCHARGE = $41;\r\n HID_USAGE_BATTERY_SYSTEM_BELOW_REMAINING_CAPACITY_LIMIT = $42;\r\n HID_USAGE_BATTERY_SYSTEM_REMAINING_TIME_LIMIT_EXPIRED = $43;\r\n HID_USAGE_BATTERY_SYSTEM_CHARGING = $44;\r\n HID_USAGE_BATTERY_SYSTEM_DISCHARGING = $45;\r\n HID_USAGE_BATTERY_SYSTEM_FULLY_CHARGED = $46;\r\n HID_USAGE_BATTERY_SYSTEM_FULLY_DISCHARGED = $47;\r\n HID_USAGE_BATTERY_SYSTEM_CONDITIONING_FLAG = $48;\r\n HID_USAGE_BATTERY_SYSTEM_AT_RATE_OK = $49;\r\n HID_USAGE_BATTERY_SYSTEM_SMB_ERROR_CODE = $4A;\r\n HID_USAGE_BATTERY_SYSTEM_NEED_REPLACEMENT = $4B;\r\n\r\n HID_USAGE_BATTERY_SYSTEM_AT_RATE_TIME_TO_FULL = $60;\r\n HID_USAGE_BATTERY_SYSTEM_AT_RATE_TIME_TO_EMPTY = $61;\r\n HID_USAGE_BATTERY_SYSTEM_AVERAGE_CURRENT = $62;\r\n HID_USAGE_BATTERY_SYSTEM_MAX_ERROR = $63;\r\n HID_USAGE_BATTERY_SYSTEM_RELATIVE_STATE_OF_CHARGE = $64;\r\n HID_USAGE_BATTERY_SYSTEM_ABSOLUTE_STATE_OF_CHARGE = $65;\r\n HID_USAGE_BATTERY_SYSTEM_REMAINING_CAPACITY = $66;\r\n HID_USAGE_BATTERY_SYSTEM_FULL_CHARGE_CAPACITY = $67;\r\n HID_USAGE_BATTERY_SYSTEM_RUN_TIME_TO_EMPTY = $68;\r\n HID_USAGE_BATTERY_SYSTEM_AVERAGE_TIME_TO_EMPTY = $69;\r\n HID_USAGE_BATTERY_SYSTEM_AVERAGE_TIME_TO_FULL = $6A;\r\n HID_USAGE_BATTERY_SYSTEM_CYCLE_COUNT = $6B;\r\n\r\n HID_USAGE_BATTERY_SYSTEM_BATT_PACK_MODEL_LEVEL = $80;\r\n HID_USAGE_BATTERY_SYSTEM_INTERNAL_CHARGE_CONTROLLER = $81;\r\n HID_USAGE_BATTERY_SYSTEM_PRIMARY_BATTERY_SUPPORT = $82;\r\n HID_USAGE_BATTERY_SYSTEM_DESIGN_CAPACITY = $83;\r\n HID_USAGE_BATTERY_SYSTEM_SPECIFICATION_INFO = $84;\r\n HID_USAGE_BATTERY_SYSTEM_MANUFACTURER_DATE = $85;\r\n HID_USAGE_BATTERY_SYSTEM_SERIAL_NUMBER = $86;\r\n HID_USAGE_BATTERY_SYSTEM_I_MANUFACTURER_NAME = $87;\r\n HID_USAGE_BATTERY_SYSTEM_I_DEVICE_NAME = $88;\r\n HID_USAGE_BATTERY_SYSTEM_I_DEVICE_CHEMISTERY = $89;\r\n HID_USAGE_BATTERY_SYSTEM_MANUFACTURER_DATA = $8A;\r\n HID_USAGE_BATTERY_SYSTEM_RECHARGABLE = $8B;\r\n HID_USAGE_BATTERY_SYSTEM_WARNING_CAPACITY_LIMIT = $8c;\r\n HID_USAGE_BATTERY_SYSTEM_CAPACITY_GRANULARITY_1 = $8d;\r\n HID_USAGE_BATTERY_SYSTEM_CAPACITY_GRANULARITY_2 = $8E;\r\n HID_USAGE_BATTERY_SYSTEM_I_OEM_INFORMATION = $8F;\r\n\r\n HID_USAGE_BATTERY_SYSTEM_INHIBIT_CHARGE = $C0;\r\n HID_USAGE_BATTERY_SYSTEM_ENABLE_POLLING = $C1;\r\n HID_USAGE_BATTERY_SYSTEM_RESET_TO_ZERO = $C2;\r\n\r\n HID_USAGE_BATTERY_SYSTEM_AC_PRESENT = $D0;\r\n HID_USAGE_BATTERY_SYSTEM_BATTERY_PRESENT = $D1;\r\n HID_USAGE_BATTERY_SYSTEM_POWER_FAIL = $D2;\r\n HID_USAGE_BATTERY_SYSTEM_ALARM_INHIBITED = $D3;\r\n HID_USAGE_BATTERY_SYSTEM_THERMISTOR_UNDER_RANGE = $D4;\r\n HID_USAGE_BATTERY_SYSTEM_THERMISTOR_HOT = $D5;\r\n HID_USAGE_BATTERY_SYSTEM_THERMISTOR_COLD = $D6;\r\n HID_USAGE_BATTERY_SYSTEM_THERMISTOR_OVER_RANGE = $D7;\r\n HID_USAGE_BATTERY_SYSTEM_VOLTAGE_OUT_OF_RANGE = $D8;\r\n HID_USAGE_BATTERY_SYSTEM_CURRENT_OUT_OF_RANGE = $D9;\r\n HID_USAGE_BATTERY_SYSTEM_CURRENT_NOT_REGULATED = $DA;\r\n HID_USAGE_BATTERY_SYSTEM_VOLTAGE_NOT_REGULATED = $DB;\r\n HID_USAGE_BATTERY_SYSTEM_MASTER_MODE = $DC;\r\n\r\n HID_USAGE_BATTERY_SYSTEM_CHARGER_SELECTOR_SUPPORT = $F0;\r\n HID_USAGE_BATTERY_SYSTEM_CHARGER_SPEC = $F1;\r\n HID_USAGE_BATTERY_SYSTEM_LEVEL_2 = $F2;\r\n HID_USAGE_BATTERY_SYSTEM_LEVEL_3 = $F3;\r\n\r\n // (rom) $F4 to $FF are reserved in \"Usage Tables for HID Power Devices 1.0\" (pdcv10.pdf)\r\n\r\n //\r\n // Barcode Scanner Page (0x8C)\r\n //\r\n HID_USAGE_BARCODE_SCANNER_UNDEFINED = $000;\r\n HID_USAGE_BARCODE_SCANNER_BAR_CODE_BADGE_READER = $001;\r\n HID_USAGE_BARCODE_SCANNER_BAR_CODE_SCANNER = $002;\r\n HID_USAGE_BARCODE_SCANNER_DUMB_BAR_CODE_SCANNER = $003;\r\n HID_USAGE_BARCODE_SCANNER_CORDLESS_SCANNER_BASE = $004;\r\n HID_USAGE_BARCODE_SCANNER_BAR_CODE_SCANNER_CRADLE = $005;\r\n\r\n HID_USAGE_BARCODE_SCANNER_ATTRIBUTE_REPORT = $010;\r\n HID_USAGE_BARCODE_SCANNER_SETTINGS_REPORT = $011;\r\n HID_USAGE_BARCODE_SCANNER_SCANNED_DATA_REPORT = $012;\r\n HID_USAGE_BARCODE_SCANNER_RAW_SCANNED_DATA_REPORT = $013;\r\n HID_USAGE_BARCODE_SCANNER_TRIGGER_REPORT = $014;\r\n HID_USAGE_BARCODE_SCANNER_STATUS_REPORT = $015;\r\n HID_USAGE_BARCODE_SCANNER_UPC_EAN_CONTROL_REPORT = $016;\r\n HID_USAGE_BARCODE_SCANNER_EAN_2_3_LABEL_CONTROL_REPORT = $017;\r\n HID_USAGE_BARCODE_SCANNER_CODE_39_CONTROL_REPORT = $018;\r\n HID_USAGE_BARCODE_SCANNER_INTERLEAVED_2_OF_5_CONTROL_REPORT = $019;\r\n HID_USAGE_BARCODE_SCANNER_STANDARD_2_OF_5_CONTROL_REPORT = $01A;\r\n HID_USAGE_BARCODE_SCANNER_MSI_PLESSEY_CONTROL_REPORT = $01B;\r\n HID_USAGE_BARCODE_SCANNER_CODABAR_CONTROL_REPORT = $01C;\r\n HID_USAGE_BARCODE_SCANNER_CODE_128_CONTROL_REPORT = $01D;\r\n HID_USAGE_BARCODE_SCANNER_MISC_1D_CONTROL_REPORT = $01E;\r\n HID_USAGE_BARCODE_SCANNER_2D_CONTROL_REPORT = $01F;\r\n\r\n HID_USAGE_BARCODE_SCANNER_AIMING_POINTER_MODE = $030;\r\n HID_USAGE_BARCODE_SCANNER_BAR_CODE_PRESENT_SENSOR = $031;\r\n HID_USAGE_BARCODE_SCANNER_CLASS_1A_LASER = $032;\r\n HID_USAGE_BARCODE_SCANNER_CLASS_2_LASER = $033;\r\n HID_USAGE_BARCODE_SCANNER_HEATER_PRESENT = $034;\r\n HID_USAGE_BARCODE_SCANNER_CONTACT_SCANNER = $035;\r\n HID_USAGE_BARCODE_SCANNER_ELECTRONIC_ARTICLE_SURVEILLANCE_NOTIFICATION = $036;\r\n HID_USAGE_BARCODE_SCANNER_CONSTANT_ARTICLE_SURVEILLANCE_NOTIFICATION = $037;\r\n HID_USAGE_BARCODE_SCANNER_ERROR_INDICATION = $038;\r\n HID_USAGE_BARCODE_SCANNER_FIXED_BEEPER = $039;\r\n HID_USAGE_BARCODE_SCANNER_GOOD_DECODE_INDICATION = $03A;\r\n HID_USAGE_BARCODE_SCANNER_HANDS_FREE_SCANNING = $03B;\r\n HID_USAGE_BARCODE_SCANNER_INTRINSICALLY_SAFE = $03C;\r\n HID_USAGE_BARCODE_SCANNER_KLASSE_EINS_LASER = $03D;\r\n HID_USAGE_BARCODE_SCANNER_LONG_RANGE_SCANNER = $03E;\r\n HID_USAGE_BARCODE_SCANNER_MIRROR_SPEED_CONTROL = $03F;\r\n HID_USAGE_BARCODE_SCANNER_NOT_ON_FILE_INDICATION = $040;\r\n HID_USAGE_BARCODE_SCANNER_PROGRAMMABLE_BEEPER = $041;\r\n HID_USAGE_BARCODE_SCANNER_TRIGGERLESS = $042;\r\n HID_USAGE_BARCODE_SCANNER_WAND = $043;\r\n HID_USAGE_BARCODE_SCANNER_WATER_RESISTANT = $044;\r\n HID_USAGE_BARCODE_SCANNER_MULTI_RANGE_SCANNER = $045;\r\n HID_USAGE_BARCODE_SCANNER_PROXIMITIY_SENSOR = $046;\r\n\r\n HID_USAGE_BARCODE_SCANNER_FRAGMENT_DECODING = $04D;\r\n HID_USAGE_BARCODE_SCANNER_SCANNER_READ_CONFIDENCE = $04E;\r\n HID_USAGE_BARCODE_SCANNER_DATA_PREFIX = $04F;\r\n HID_USAGE_BARCODE_SCANNER_PREFIX_AIMI = $050;\r\n HID_USAGE_BARCODE_SCANNER_PREFIX_NODE = $051;\r\n HID_USAGE_BARCODE_SCANNER_PREFIX_PROPRIETARY = $052;\r\n\r\n HID_USAGE_BARCODE_SCANNER_ACTIVE_TIME = $055;\r\n HID_USAGE_BARCODE_SCANNER_AIMING_LASER_PATTERN = $056;\r\n HID_USAGE_BARCODE_SCANNER_BAR_CODE_PRESENT = $057;\r\n HID_USAGE_BARCODE_SCANNER_BEEPER_STATE = $058;\r\n HID_USAGE_BARCODE_SCANNER_LASER_ON_TIME = $059;\r\n HID_USAGE_BARCODE_SCANNER_LASER_STATE = $05A;\r\n HID_USAGE_BARCODE_SCANNER_LOCKOUT_TIME = $05B;\r\n HID_USAGE_BARCODE_SCANNER_MOTOR_STATE = $05C;\r\n HID_USAGE_BARCODE_SCANNER_MOTOR_TIMEOUT = $05D;\r\n HID_USAGE_BARCODE_SCANNER_POWER_ON_RESET_SCANNER = $05E;\r\n HID_USAGE_BARCODE_SCANNER_PREVENT_READ_OF_BARCODES = $05F;\r\n HID_USAGE_BARCODE_SCANNER_INITIATE_BARCODE_READ = $060;\r\n HID_USAGE_BARCODE_SCANNER_TRIGGER_STATE = $061;\r\n HID_USAGE_BARCODE_SCANNER_TRIGGER_MODE = $062;\r\n HID_USAGE_BARCODE_SCANNER_TM_BLINKING_LASER_ON = $063;\r\n HID_USAGE_BARCODE_SCANNER_TM_CONTINUOUS_LASER_ON = $064;\r\n HID_USAGE_BARCODE_SCANNER_TM_LASER_ON_WHILE_PULLED = $065;\r\n HID_USAGE_BARCODE_SCANNER_TM_LASER_STAYS_ON_AFTER_TRIGGER_RELEASE = $066;\r\n\r\n HID_USAGE_BARCODE_SCANNER_COMMIT_PARAMETERS_TO_NVM = $06D;\r\n HID_USAGE_BARCODE_SCANNER_PARAMETER_SCANNING = $06E;\r\n HID_USAGE_BARCODE_SCANNER_PARAMETERS_CHANGED = $06F;\r\n HID_USAGE_BARCODE_SCANNER_SET_PARAMETER_DEFAULT_VALUES = $070;\r\n\r\n HID_USAGE_BARCODE_SCANNER_SCANNER_IN_CRADLE = $075;\r\n HID_USAGE_BARCODE_SCANNER_SCANNER_IN_RANGE = $076;\r\n\r\n HID_USAGE_BARCODE_SCANNER_AIM_DURATION = $07A;\r\n HID_USAGE_BARCODE_SCANNER_GOOD_READ_LAMP_DURATION = $07B;\r\n HID_USAGE_BARCODE_SCANNER_GOOD_READ_LAMP_INTENSITY = $07C;\r\n HID_USAGE_BARCODE_SCANNER_GOOD_READ_LED = $07D;\r\n HID_USAGE_BARCODE_SCANNER_GOOD_READ_TONE_FREQUENCY = $07E;\r\n HID_USAGE_BARCODE_SCANNER_GOOD_READ_TONE_LENGTH = $07F;\r\n HID_USAGE_BARCODE_SCANNER_GOOD_READ_TONE_VOLUME = $080;\r\n\r\n HID_USAGE_BARCODE_SCANNER_NO_READ_MESSAGE = $082;\r\n HID_USAGE_BARCODE_SCANNER_NOT_ON_FILE_VOLUME = $083;\r\n HID_USAGE_BARCODE_SCANNER_POWERUP_BEEP = $084;\r\n HID_USAGE_BARCODE_SCANNER_SOUND_ERROR_BEEP = $085;\r\n HID_USAGE_BARCODE_SCANNER_SOUND_GOOD_READ_BEEP = $086;\r\n HID_USAGE_BARCODE_SCANNER_SOUND_NOT_ON_FILE_BEEP = $087;\r\n HID_USAGE_BARCODE_SCANNER_GOOD_READ_WHEN_TO_WRITE = $088;\r\n HID_USAGE_BARCODE_SCANNER_GRWTI_AFTER_DECODE = $089;\r\n HID_USAGE_BARCODE_SCANNER_GRWTI_BEEP_LAMP_AFTER_TRANSMIT = $08a;\r\n HID_USAGE_BARCODE_SCANNER_GRWTI_NO_BEEP_LAMP_USE_AT_ALL = $08B;\r\n\r\n HID_USAGE_BARCODE_SCANNER_BOOKLAND_EAN = $091;\r\n HID_USAGE_BARCODE_SCANNER_CONVERT_EAN_8_TO_13_TYPE = $092;\r\n HID_USAGE_BARCODE_SCANNER_CONVERT_UPC_A_TO_EAN_13 = $093;\r\n HID_USAGE_BARCODE_SCANNER_CONVERT_UPC_E_TO_A = $094;\r\n HID_USAGE_BARCODE_SCANNER_EAN_13 = $095;\r\n HID_USAGE_BARCODE_SCANNER_EAN_8 = $096;\r\n HID_USAGE_BARCODE_SCANNER_EAN_99_128_MANDATORY = $097;\r\n HID_USAGE_BARCODE_SCANNER_EAN_99_P5_128_OPTIONAL = $098;\r\n\r\n HID_USAGE_BARCODE_SCANNER_UPC_EAN = $09A;\r\n HID_USAGE_BARCODE_SCANNER_UPC_EAN_COUPON_CODE = $09B;\r\n HID_USAGE_BARCODE_SCANNER_UPC_EAN_PERIODICALS = $09C;\r\n HID_USAGE_BARCODE_SCANNER_UPC_A = $09D;\r\n HID_USAGE_BARCODE_SCANNER_UPC_A_WITH_128_MANDATORY = $09E;\r\n HID_USAGE_BARCODE_SCANNER_UPC_A_WITH_128_OPTIONAL = $09F;\r\n HID_USAGE_BARCODE_SCANNER_UPC_A_WITH_P5_OPTIONAL = $0A0;\r\n HID_USAGE_BARCODE_SCANNER_UPC_E = $0A1;\r\n HID_USAGE_BARCODE_SCANNER_UPC_E1 = $0A2;\r\n\r\n HID_USAGE_BARCODE_SCANNER_PERIODICAL = $0A9;\r\n HID_USAGE_BARCODE_SCANNER_PERIODICAL_AUTODISCRIMINATE_2 = $0AA;\r\n HID_USAGE_BARCODE_SCANNER_PERIODICAL_ONLY_DECODE_WITH_2 = $0AB;\r\n HID_USAGE_BARCODE_SCANNER_PERIODICAL_IGNORE_2 = $0AC;\r\n HID_USAGE_BARCODE_SCANNER_PERIODICAL_AUTODISCRIMINATE_5 = $0AD;\r\n HID_USAGE_BARCODE_SCANNER_PERIODICAL_ONLY_DECODE_WITH_5 = $0AE;\r\n HID_USAGE_BARCODE_SCANNER_PERIODICAL_IGNORE_5 = $0AF;\r\n HID_USAGE_BARCODE_SCANNER_CHECK = $0B0;\r\n HID_USAGE_BARCODE_SCANNER_CHECK_DISABLE_PRICE = $0B1;\r\n HID_USAGE_BARCODE_SCANNER_CHECK_ENABLE_4_DIGIT_PRICE = $0B2;\r\n HID_USAGE_BARCODE_SCANNER_CHECK_ENABLE_5_DIGIT_PRICE = $0B3;\r\n HID_USAGE_BARCODE_SCANNER_CHECK_ENABLE_EUROPEAN_4_DIGIT_PRICE = $0B4;\r\n HID_USAGE_BARCODE_SCANNER_CHECK_ENABLE_EUROPEAN_5_DIGIT_PRICE = $0B5;\r\n\r\n HID_USAGE_BARCODE_SCANNER_EAN_TWO_LABEL = $0B7;\r\n HID_USAGE_BARCODE_SCANNER_EAN_THREE_LABEL = $0B8;\r\n HID_USAGE_BARCODE_SCANNER_EAN_8_FLAG_DIGIT_1 = $0B9;\r\n HID_USAGE_BARCODE_SCANNER_EAN_8_FLAG_DIGIT_2 = $0BA;\r\n HID_USAGE_BARCODE_SCANNER_EAN_8_FLAG_DIGIT_3 = $0BB;\r\n HID_USAGE_BARCODE_SCANNER_EAN_13_FLAG_DIGIT_1 = $0BC;\r\n HID_USAGE_BARCODE_SCANNER_EAN_13_FLAG_DIGIT_2 = $0BD;\r\n HID_USAGE_BARCODE_SCANNER_EAN_13_FLAG_DIGIT_3 = $0BE;\r\n HID_USAGE_BARCODE_SCANNER_ADD_EAN_2_3_LABEL_DEFINITION = $0BF;\r\n HID_USAGE_BARCODE_SCANNER_CLEAR_ALL_EAN_2_3_LABEL_DEFINITIONS = $0C0;\r\n\r\n HID_USAGE_BARCODE_SCANNER_CODABAR = $0C3;\r\n HID_USAGE_BARCODE_SCANNER_CODE_128 = $0C4;\r\n\r\n HID_USAGE_BARCODE_SCANNER_CODE_39 = $0C7;\r\n HID_USAGE_BARCODE_SCANNER_CODE_93 = $0C8;\r\n HID_USAGE_BARCODE_SCANNER_FULL_ASCII_CONVERSION = $0C9;\r\n HID_USAGE_BARCODE_SCANNER_INTERLEAVED_2_OF_5 = $0CA;\r\n HID_USAGE_BARCODE_SCANNER_ITALIAN_PHARMACY_CODE = $0CB;\r\n HID_USAGE_BARCODE_SCANNER_MSI_PLESSEY = $0CC;\r\n HID_USAGE_BARCODE_SCANNER_STANDARD_2_OF_5_IATA = $0CD;\r\n HID_USAGE_BARCODE_SCANNER_STANDARD_2_OF_5 = $0CE;\r\n\r\n HID_USAGE_BARCODE_SCANNER_TRANSMIT_START_STOP = $0D3;\r\n HID_USAGE_BARCODE_SCANNER_TRI_OPTIC = $0D4;\r\n HID_USAGE_BARCODE_SCANNER_UCC_EAN_128 = $0D5;\r\n HID_USAGE_BARCODE_SCANNER_CHECK_DIGIT = $0D6;\r\n HID_USAGE_BARCODE_SCANNER_CD_DISABLE = $0D7;\r\n HID_USAGE_BARCODE_SCANNER_CD_ENABLE_INTERLEAVED_2_OF_5_OPCC = $0D8;\r\n HID_USAGE_BARCODE_SCANNER_CD_ENABLE_INTERLEAVED_2_OF_5_USS = $0D9;\r\n HID_USAGE_BARCODE_SCANNER_CD_ENABLE_STANDARD_2_OF_5_OPCC = $0DA;\r\n HID_USAGE_BARCODE_SCANNER_CD_ENABLE_STANDARD_2_OF_5_USS = $0DB;\r\n HID_USAGE_BARCODE_SCANNER_CD_ENABLE_ONE_MSI_PLESSEY = $0DC;\r\n HID_USAGE_BARCODE_SCANNER_CD_ENABLE_TWO_MSI_PLESSEY = $0DD;\r\n HID_USAGE_BARCODE_SCANNER_CD_CODABAR_ENABLE = $0DE;\r\n HID_USAGE_BARCODE_SCANNER_CD_CODE_39_ENABLE = $0DF;\r\n\r\n HID_USAGE_BARCODE_SCANNER_TRANSMIT_CHECK_DIGIT = $0F0;\r\n HID_USAGE_BARCODE_SCANNER_DISABLE_CHECK_DIGIT_TRANSMIT = $0F1;\r\n HID_USAGE_BARCODE_SCANNER_ENABLE_CHECK_DIGIT_TRANSMIT = $0F2;\r\n\r\n HID_USAGE_BARCODE_SCANNER_SYMBOLOGY_IDENTIFIER_1 = $0FB;\r\n HID_USAGE_BARCODE_SCANNER_SYMBOLOGY_IDENTIFIER_2 = $0FC;\r\n HID_USAGE_BARCODE_SCANNER_SYMBOLOGY_IDENTIFIER_3 = $0FD;\r\n HID_USAGE_BARCODE_SCANNER_DECODED_DATA = $0FE;\r\n HID_USAGE_BARCODE_SCANNER_DECODED_DATA_CONTINUED = $0FF;\r\n HID_USAGE_BARCODE_SCANNER_BAR_SPACE_DATA = $100;\r\n HID_USAGE_BARCODE_SCANNER_SCANNER_DATA_ACCURACY = $101;\r\n HID_USAGE_BARCODE_SCANNER_RAW_DATA_POLARITY = $102;\r\n HID_USAGE_BARCODE_SCANNER_POLARITY_INVERTED_BAR_CODE = $103;\r\n HID_USAGE_BARCODE_SCANNER_POLARITY_NORMAL_BAR_CODE = $104;\r\n\r\n HID_USAGE_BARCODE_SCANNER_MINIMUM_LENGTH_TO_DECODE = $106;\r\n HID_USAGE_BARCODE_SCANNER_MAXIMUM_LENGTH_TO_DECODE = $107;\r\n HID_USAGE_BARCODE_SCANNER_FIRST_DISCRETE_LENGTH_TO_DECODE = $108;\r\n HID_USAGE_BARCODE_SCANNER_SECOND_DISCRETE_LENGTH_TO_DECODE = $109;\r\n HID_USAGE_BARCODE_SCANNER_DATA_LENGTH_METHOD = $10A;\r\n HID_USAGE_BARCODE_SCANNER_DLM_READ_ANY = $10B;\r\n HID_USAGE_BARCODE_SCANNER_DLM_CHECK_IN_RANGE = $10C;\r\n HID_USAGE_BARCODE_SCANNER_DLM_CHECK_FOR_DISCRETE = $10D;\r\n \r\n HID_USAGE_BARCODE_SCANNER_AZTEC_CODE = $110;\r\n HID_USAGE_BARCODE_SCANNER_BC412 = $111;\r\n HID_USAGE_BARCODE_SCANNER_CHANNEL_CODE = $112;\r\n HID_USAGE_BARCODE_SCANNER_CODE_16 = $113;\r\n HID_USAGE_BARCODE_SCANNER_CODE_32 = $114;\r\n HID_USAGE_BARCODE_SCANNER_CODE_49 = $115;\r\n HID_USAGE_BARCODE_SCANNER_CODE_ONE = $116;\r\n HID_USAGE_BARCODE_SCANNER_COLORCODE = $117;\r\n HID_USAGE_BARCODE_SCANNER_DATA_MATRIX = $118;\r\n HID_USAGE_BARCODE_SCANNER_MAXICODE = $119;\r\n HID_USAGE_BARCODE_SCANNER_MICROPDF = $11A;\r\n HID_USAGE_BARCODE_SCANNER_PDF_417 = $11B;\r\n HID_USAGE_BARCODE_SCANNER_POSICODE = $11C;\r\n HID_USAGE_BARCODE_SCANNER_QR_CODE = $11D;\r\n HID_USAGE_BARCODE_SCANNER_SUPERCODE = $11E;\r\n HID_USAGE_BARCODE_SCANNER_ULTRACODE = $11F;\r\n HID_USAGE_BARCODE_SCANNER_USD_5 = $120;\r\n HID_USAGE_BARCODE_SCANNER_VERICODE = $121;\r\n\r\n // (rom) $122 to $FFFF are reserved in \"HID Point of Sale Usage Tables 1.02\" (pos1_02.pdf)\r\n\r\n //\r\n // Weighing Device Page (0x8D)\r\n //\r\n HID_USAGE_SCALE_UNDEFINED = $00;\r\n HID_USAGE_SCALE_WEIGHING_DEVICE = $01;\r\n\r\n HID_USAGE_SCALE_SCALE_DEVICE_CLASS = $20;\r\n HID_USAGE_SCALE_SCALE_CLASS_I_METRIC_CLASS = $21;\r\n HID_USAGE_SCALE_SCALE_CLASS_I_METRIC = $22;\r\n HID_USAGE_SCALE_SCALE_CLASS_II_METRIC = $23;\r\n HID_USAGE_SCALE_SCALE_CLASS_III_METRIC = $24;\r\n HID_USAGE_SCALE_SCALE_CLASS_IIIL_METRIC = $25;\r\n HID_USAGE_SCALE_SCALE_CLASS_IV_METRIC = $26;\r\n HID_USAGE_SCALE_SCALE_CLASS_III_ENGLISH = $27;\r\n HID_USAGE_SCALE_SCALE_CLASS_IIIL_ENGLISH = $28;\r\n HID_USAGE_SCALE_SCALE_CLASS_IV_ENGLISH = $29;\r\n HID_USAGE_SCALE_SCALE_CLASS_GENERIC = $2A;\r\n\r\n HID_USAGE_SCALE_SCALE_ATTRIBUTE_REPORT = $30;\r\n HID_USAGE_SCALE_SCALE_CONTROL_REPORT = $31;\r\n HID_USAGE_SCALE_SCALE_DATA_REPORT = $32;\r\n HID_USAGE_SCALE_SCALE_STATUS_REPORT = $33;\r\n HID_USAGE_SCALE_SCALE_WEIGHT_LIMIT_REPORT = $34;\r\n HID_USAGE_SCALE_SCALE_STATISTICS_REPORT = $35;\r\n\r\n HID_USAGE_SCALE_DATA_WEIGHT = $40;\r\n HID_USAGE_SCALE_DATA_SCALING = $41;\r\n\r\n HID_USAGE_SCALE_WEIGHT_UNIT_CLASS = $50;\r\n HID_USAGE_SCALE_WEIGHT_UNIT_MILLIGRAM = $51;\r\n HID_USAGE_SCALE_WEIGHT_UNIT_GRAM = $52;\r\n HID_USAGE_SCALE_WEIGHT_UNIT_KILOGRAM = $53;\r\n HID_USAGE_SCALE_WEIGHT_UNIT_CARATS = $54;\r\n HID_USAGE_SCALE_WEIGHT_UNIT_TAELS = $55;\r\n HID_USAGE_SCALE_WEIGHT_UNIT_GRAINS = $56;\r\n HID_USAGE_SCALE_WEIGHT_UNIT_PENNYWEIGHTS = $57;\r\n HID_USAGE_SCALE_WEIGHT_UNIT_METRIC_TON = $58;\r\n HID_USAGE_SCALE_WEIGHT_UNIT_AVOIR_TON = $59;\r\n HID_USAGE_SCALE_WEIGHT_UNIT_TROY_OUNCE = $5A;\r\n HID_USAGE_SCALE_WEIGHT_UNIT_OUNCE = $5B;\r\n HID_USAGE_SCALE_WEIGHT_UNIT_POUND = $5C;\r\n\r\n HID_USAGE_SCALE_CALIBRATION_COUNT = $60;\r\n HID_USAGE_SCALE_RE_ZERO_COUNT = $61;\r\n\r\n HID_USAGE_SCALE_SCALE_STATUS_CLASS = $70;\r\n HID_USAGE_SCALE_SCS_FAULT = $71;\r\n HID_USAGE_SCALE_SCS_STABLE_AT_CENTER_OF_ZERO = $72;\r\n HID_USAGE_SCALE_SCS_IN_MOTION = $73;\r\n HID_USAGE_SCALE_SCS_WEIGHT_STABLE = $74;\r\n HID_USAGE_SCALE_SCS_UNDER_ZERO = $75;\r\n HID_USAGE_SCALE_SCS_OVER_WEIGHT_LIMIT = $76;\r\n HID_USAGE_SCALE_SCS_REQUIRES_CALIBRATION = $77;\r\n HID_USAGE_SCALE_SCS_REQUIRES_REZEROING = $78;\r\n\r\n HID_USAGE_SCALE_ZERO_SCALE = $80;\r\n HID_USAGE_SCALE_ENFORCED_ZERO_RETURN = $81;\r\n\r\n // (rom) $82 to $FFFF are reserved in \"HID Point of Sale Usage Tables 1.02\" (pos1_02.pdf)\r\n\r\n //\r\n // Magnetic Stripe Reader Page (0x8E)\r\n //\r\n HID_USAGE_MSR_UNDEFINED = $00;\r\n HID_USAGE_MSR_MSR_DEVICE_READ_ONLY = $01;\r\n\r\n HID_USAGE_MSR_TRACK_1_LENGTH = $11;\r\n HID_USAGE_MSR_TRACK_2_LENGTH = $12;\r\n HID_USAGE_MSR_TRACK_3_LENGTH = $13;\r\n HID_USAGE_MSR_TRACK_JIS_LENGTH = $14;\r\n\r\n HID_USAGE_MSR_TRACK_DATA = $20;\r\n HID_USAGE_MSR_TRACK_1_DATA = $21;\r\n HID_USAGE_MSR_TRACK_2_DATA = $22;\r\n HID_USAGE_MSR_TRACK_3_DATA = $23;\r\n HID_USAGE_MSR_TRACK_JIS_DATA = $24;\r\n\r\n // (rom) $25 to $FFFF are reserved in \"\"HID Point of Sale Usage Tables 1.02\" (pos1_02.pdf)\r\n\r\nimplementation\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JVCLVer.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JVCLVer.PAS, released on 2001-02-28.\r\n\r\nThe Initial Developer of the Original Code is Joe Doe .\r\nPortions created by Joe Doe are Copyright (C) 1999 Joe Doe.\r\nPortions created by XXXX Corp. are Copyright (C) 1998, 1999 XXXX Corp.\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\n Michael Beck [mbeck att bigfoot dott com].\r\n Hofi\r\n\r\nLast Modified: 2004-10-19\r\n\r\nChanges:\r\n2004-10-10:\r\n * Added by Hofi\r\n JVCL_VERSION\r\n Helps conditional compiling in BCB.\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JVCLVer.pas 13423 2012-09-10 12:11:51Z obones $\r\n\r\nunit JVCLVer;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\n{$IFDEF UNITVERSIONING}\r\nuses\r\n JclUnitVersioning;\r\n{$ENDIF UNITVERSIONING}\r\n\r\nconst\r\n sJVCLVersion = '3.47';\r\n JVCLVersionMajor = 3; // 0=pre-release|beta/1, 2, ...=final\r\n JVCLVersionMinor = 47; // minor release\r\n JVCLVersionRelease = 0; // 0: pre-release|beta/>=1: release\r\n JVCLVersionBuild = 0; // build number, days since march 1, 2006\r\n\r\n JVCLVersion = (JVCLVersionMajor shl 24) or (JVCLVersionMinor shl 16) or\r\n (JVCLVersionRelease shl 15) or (JVCLVersionBuild shl 0);\r\n JVCL_VERSION = JVCLVersionMajor * 100 + JVCLVersionMinor;\r\n JVCL_VERSIONSTRING = sJVCLVersion;\r\n\r\ntype\r\n TJVCLAboutInfo = (JVCLAbout);\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JVCLVer.pas $';\r\n Revision: '$Revision: 13423 $';\r\n Date: '$Date: 2012-09-10 14:11:51 +0200 (lun. 10 sept. 2012) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvADOQuery.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvOdacSmartQuery.PAS, released on 2002-05-26.\r\n\r\nThe Initial Developer of the Original Code is Jens Fudickar\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nDescription:\r\n Oracle Dataset with Threaded Functions\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvADOQuery.pas 13145 2011-11-02 21:15:19Z ahuser $\r\n\r\nunit JvADOQuery;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n SysUtils, Classes, Forms, Controls,\r\n DB, ADODB,\r\n JvBaseDBThreadedDataset;\r\n\r\ntype\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvADOQuery = class(TADOQuery, IJvThreadedDatasetInterface)\r\n procedure BreakExecution;\r\n procedure BringThreadDialogToFront;\r\n function DoGetInheritedNextRecord: Boolean;\r\n procedure DoInheritedAfterOpen;\r\n procedure DoInheritedAfterRefresh;\r\n procedure DoInheritedAfterScroll;\r\n procedure DoInheritedBeforeOpen;\r\n procedure DoInheritedBeforeRefresh;\r\n procedure DoInheritedInternalLast;\r\n procedure DoInheritedInternalRefresh;\r\n procedure DoInheritedSetActive(Active: Boolean);\r\n procedure DoInternalOpen;\r\n function GetDatasetFetchAllRecords: Boolean;\r\n function IsThreadAllowed: Boolean;\r\n procedure SetDatasetFetchAllRecords(const Value: Boolean);\r\n private\r\n FOnFetchProgress: TFetchProgressEvent;\r\n FThreadHandler: TJvBaseDatasetThreadHandler;\r\n function GetAfterOpenFetch: TDataSetNotifyEvent;\r\n function GetAfterOpenFetch1: TDataSetNotifyEvent;\r\n function GetAfterThreadExecution: TJvThreadedDatasetThreadEvent;\r\n function GetBeforeThreadExecution: TJvThreadedDatasetThreadEvent;\r\n function GetDialogOptions: TJvThreadedDatasetDialogOptions;\r\n function GetThreadOptions: TJvThreadedDatasetThreadOptions;\r\n procedure SetAfterOpenFetch(const Value: TDataSetNotifyEvent);\r\n procedure SetAfterOpenFetch1(const Value: TDataSetNotifyEvent);\r\n procedure SetAfterThreadExecution(const Value: TJvThreadedDatasetThreadEvent);\r\n procedure SetBeforeThreadExecution(const Value: TJvThreadedDatasetThreadEvent);\r\n procedure SetDialogOptions(Value: TJvThreadedDatasetDialogOptions);\r\n procedure SetThreadOptions(const Value: TJvThreadedDatasetThreadOptions);\r\n property ThreadHandler: TJvBaseDatasetThreadHandler read FThreadHandler;\r\n protected\r\n procedure DoAfterOpen; override;\r\n procedure DoAfterRefresh; override;\r\n procedure DoAfterScroll; override;\r\n procedure DoBeforeOpen; override;\r\n procedure DoBeforeRefresh; override;\r\n function GetNextRecord: Boolean; override;\r\n function GetOnThreadException: TJvThreadedDatasetThreadExceptionEvent;\r\n procedure InternalLast; override;\r\n procedure InternalRefresh; override;\r\n procedure ReplaceOnFetchProgress(DataSet: TCustomADODataSet; Progress, MaxProgress: Integer; var EventStatus:\r\n TEventStatus);\r\n procedure SetActive(Value: Boolean); override;\r\n procedure SetOnThreadException(const Value: TJvThreadedDatasetThreadExceptionEvent);\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n function CurrentFetchDuration: TDateTime;\r\n function CurrentOpenDuration: TDateTime;\r\n function EofReached: Boolean;\r\n function ErrorException: Exception;\r\n function ErrorMessage: string;\r\n function ThreadIsActive: Boolean;\r\n published\r\n property AfterOpenFetch: TDataSetNotifyEvent read GetAfterOpenFetch1 write SetAfterOpenFetch1;\r\n property AfterThreadExecution: TJvThreadedDatasetThreadEvent read GetAfterThreadExecution write SetAfterThreadExecution;\r\n property OnFetchProgress: TFetchProgressEvent read FOnFetchProgress write FOnFetchProgress;\r\n property BeforeThreadExecution: TJvThreadedDatasetThreadEvent read GetBeforeThreadExecution write\r\n SetBeforeThreadExecution;\r\n property DialogOptions: TJvThreadedDatasetDialogOptions read GetDialogOptions write SetDialogOptions;\r\n property ThreadOptions: TJvThreadedDatasetThreadOptions read GetThreadOptions write SetThreadOptions;\r\n property OnThreadException: TJvThreadedDatasetThreadExceptionEvent read GetOnThreadException write SetOnThreadException;\r\n end;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvADODataSet = class(TADODataSet, IJvThreadedDatasetInterface)\r\n procedure BreakExecution;\r\n procedure BringThreadDialogToFront;\r\n function DoGetInheritedNextRecord: Boolean;\r\n procedure DoInheritedAfterOpen;\r\n procedure DoInheritedAfterRefresh;\r\n procedure DoInheritedAfterScroll;\r\n procedure DoInheritedBeforeOpen;\r\n procedure DoInheritedBeforeRefresh;\r\n procedure DoInheritedInternalLast;\r\n procedure DoInheritedInternalRefresh;\r\n procedure DoInheritedSetActive(Active: Boolean);\r\n procedure DoInternalOpen;\r\n function GetDatasetFetchAllRecords: Boolean;\r\n function IsThreadAllowed: Boolean;\r\n procedure SetDatasetFetchAllRecords(const Value: Boolean);\r\n private\r\n FOnFetchProgress: TFetchProgressEvent;\r\n FThreadHandler: TJvBaseDatasetThreadHandler;\r\n function GetAfterOpenFetch: TDataSetNotifyEvent;\r\n function GetAfterOpenFetch1: TDataSetNotifyEvent;\r\n function GetAfterThreadExecution: TJvThreadedDatasetThreadEvent;\r\n function GetBeforeThreadExecution: TJvThreadedDatasetThreadEvent;\r\n function GetDialogOptions: TJvThreadedDatasetDialogOptions;\r\n function GetThreadOptions: TJvThreadedDatasetThreadOptions;\r\n procedure SetAfterOpenFetch(const Value: TDataSetNotifyEvent);\r\n procedure SetAfterOpenFetch1(const Value: TDataSetNotifyEvent);\r\n procedure SetAfterThreadExecution(const Value: TJvThreadedDatasetThreadEvent);\r\n procedure SetBeforeThreadExecution(const Value: TJvThreadedDatasetThreadEvent);\r\n procedure SetDialogOptions(Value: TJvThreadedDatasetDialogOptions);\r\n procedure SetThreadOptions(const Value: TJvThreadedDatasetThreadOptions);\r\n property ThreadHandler: TJvBaseDatasetThreadHandler read FThreadHandler;\r\n protected\r\n procedure DoAfterOpen; override;\r\n procedure DoAfterRefresh; override;\r\n procedure DoAfterScroll; override;\r\n procedure DoBeforeOpen; override;\r\n procedure DoBeforeRefresh; override;\r\n function GetNextRecord: Boolean; override;\r\n function GetOnThreadException: TJvThreadedDatasetThreadExceptionEvent;\r\n procedure InternalLast; override;\r\n procedure InternalRefresh; override;\r\n procedure ReplaceOnFetchProgress(DataSet: TCustomADODataSet; Progress, MaxProgress: Integer; var EventStatus:\r\n TEventStatus);\r\n procedure SetActive(Value: Boolean); override;\r\n procedure SetOnThreadException(const Value: TJvThreadedDatasetThreadExceptionEvent);\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n function CurrentFetchDuration: TDateTime;\r\n function CurrentOpenDuration: TDateTime;\r\n function EofReached: Boolean;\r\n function ErrorException: Exception;\r\n function ErrorMessage: string;\r\n function ThreadIsActive: Boolean;\r\n published\r\n property AfterOpenFetch: TDataSetNotifyEvent read GetAfterOpenFetch1 write SetAfterOpenFetch1;\r\n property AfterThreadExecution: TJvThreadedDatasetThreadEvent read GetAfterThreadExecution write SetAfterThreadExecution;\r\n property OnFetchProgress: TFetchProgressEvent read FOnFetchProgress write FOnFetchProgress;\r\n property BeforeThreadExecution: TJvThreadedDatasetThreadEvent read GetBeforeThreadExecution write\r\n SetBeforeThreadExecution;\r\n property DialogOptions: TJvThreadedDatasetDialogOptions read GetDialogOptions write SetDialogOptions;\r\n property ThreadOptions: TJvThreadedDatasetThreadOptions read GetThreadOptions write SetThreadOptions;\r\n property OnThreadException: TJvThreadedDatasetThreadExceptionEvent read GetOnThreadException write SetOnThreadException;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvADOQuery.pas $';\r\n Revision: '$Revision: 13145 $';\r\n Date: '$Date: 2011-11-02 22:15:19 +0100 (mer. 02 nov. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n Variants;\r\n\r\n//=== { TJvADOSmartQuery } ==================================================\r\n\r\nconstructor TJvADOQuery.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FThreadHandler := TJvBaseDatasetThreadHandler.Create(Self, Self);\r\n inherited OnFetchProgress := ReplaceOnFetchProgress;\r\nend;\r\n\r\ndestructor TJvADOQuery.Destroy;\r\nbegin\r\n FreeAndNil(FThreadHandler);\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvADOQuery.BreakExecution;\r\nbegin\r\n //BreakExec;\r\nend;\r\n\r\nprocedure TJvADOQuery.BringThreadDialogToFront;\r\nbegin\r\n if Assigned(ThreadHandler) then\r\n ThreadHandler.BringDialogToFront;\r\nend;\r\n\r\nfunction TJvADOQuery.CurrentFetchDuration: TDateTime;\r\nbegin\r\n if Assigned(ThreadHandler) then\r\n Result := ThreadHandler.CurrentFetchDuration\r\n else\r\n Result := 0;\r\nend;\r\n\r\nfunction TJvADOQuery.CurrentOpenDuration: TDateTime;\r\nbegin\r\n if Assigned(ThreadHandler) then\r\n Result := ThreadHandler.CurrentOpenDuration\r\n else\r\n Result := 0;\r\nend;\r\n\r\nprocedure TJvADOQuery.DoAfterOpen;\r\nbegin\r\n ThreadHandler.AfterOpen;\r\nend;\r\n\r\nprocedure TJvADOQuery.DoAfterRefresh;\r\nbegin\r\n ThreadHandler.AfterRefresh;\r\nend;\r\n\r\nprocedure TJvADOQuery.DoAfterScroll;\r\nbegin\r\n ThreadHandler.AfterScroll;\r\nend;\r\n\r\nprocedure TJvADOQuery.DoBeforeOpen;\r\nbegin\r\n ThreadHandler.BeforeOpen;\r\nend;\r\n\r\nprocedure TJvADOQuery.DoBeforeRefresh;\r\nbegin\r\n ThreadHandler.BeforeRefresh;\r\nend;\r\n\r\nfunction TJvADOQuery.DoGetInheritedNextRecord: Boolean;\r\nbegin\r\n Result := Inherited GetNextRecord;\r\nend;\r\n\r\nprocedure TJvADOQuery.DoInheritedAfterOpen;\r\nbegin\r\n inherited DoAfterOpen;\r\nend;\r\n\r\nprocedure TJvADOQuery.DoInheritedAfterRefresh;\r\nbegin\r\n inherited DoAfterRefresh;\r\nend;\r\n\r\nprocedure TJvADOQuery.DoInheritedAfterScroll;\r\nbegin\r\n inherited DoAfterScroll;\r\nend;\r\n\r\nprocedure TJvADOQuery.DoInheritedBeforeOpen;\r\nbegin\r\n inherited DoBeforeOpen;\r\nend;\r\n\r\nprocedure TJvADOQuery.DoInheritedBeforeRefresh;\r\nbegin\r\n inherited DoBeforeRefresh;\r\nend;\r\n\r\nprocedure TJvADOQuery.DoInheritedInternalLast;\r\nbegin\r\n inherited InternalLast;\r\nend;\r\n\r\nprocedure TJvADOQuery.DoInheritedInternalRefresh;\r\nbegin\r\n inherited InternalRefresh;\r\nend;\r\n\r\nprocedure TJvADOQuery.DoInheritedSetActive(Active: Boolean);\r\nbegin\r\n inherited SetActive(Active);\r\nend;\r\n\r\nprocedure TJvADOQuery.DoInternalOpen;\r\nbegin\r\n InternalOpen;\r\nend;\r\n\r\nfunction TJvADOQuery.EofReached: Boolean;\r\nbegin\r\n if Assigned(ThreadHandler) then\r\n Result := ThreadHandler.EofReached\r\n else\r\n Result := False;\r\nend;\r\n\r\nfunction TJvADOQuery.ErrorException: Exception;\r\nbegin\r\n if Assigned(ThreadHandler) then\r\n Result := ThreadHandler.ErrorException\r\n else\r\n Result := Nil;\r\nend;\r\n\r\nfunction TJvADOQuery.ErrorMessage: string;\r\nbegin\r\n if Assigned(ThreadHandler) then\r\n Result := ThreadHandler.ErrorMessage\r\n else\r\n Result := '';\r\nend;\r\n\r\nfunction TJvADOQuery.GetAfterOpenFetch: TDataSetNotifyEvent;\r\nbegin\r\n if Assigned(ThreadHandler) then\r\n Result := ThreadHandler.AfterOpenFetch\r\n else\r\n Result := nil;\r\nend;\r\n\r\nfunction TJvADOQuery.GetAfterOpenFetch1: TDataSetNotifyEvent;\r\nbegin\r\n if Assigned(ThreadHandler) then\r\n Result := ThreadHandler.AfterOpenFetch\r\n else\r\n Result := nil;\r\nend;\r\n\r\nfunction TJvADOQuery.GetAfterThreadExecution: TJvThreadedDatasetThreadEvent;\r\nbegin\r\n if Assigned(ThreadHandler) then\r\n Result := ThreadHandler.AfterThreadExecution\r\n else\r\n Result := nil;\r\nend;\r\n\r\nfunction TJvADOQuery.GetBeforeThreadExecution: TJvThreadedDatasetThreadEvent;\r\nbegin\r\n if Assigned(ThreadHandler) then\r\n Result := ThreadHandler.BeforeThreadExecution\r\n else\r\n Result := nil;\r\nend;\r\n\r\nfunction TJvADOQuery.GetDatasetFetchAllRecords: Boolean;\r\nbegin\r\n Result := False;\r\nend;\r\n\r\nfunction TJvADOQuery.GetDialogOptions: TJvThreadedDatasetDialogOptions;\r\nbegin\r\n if Assigned(ThreadHandler) then\r\n Result := ThreadHandler.DialogOptions\r\n else\r\n Result := nil;\r\nend;\r\n\r\nfunction TJvADOQuery.GetNextRecord: Boolean;\r\nbegin\r\n if Assigned(ThreadHandler) then\r\n Result := ThreadHandler.GetNextRecord\r\n else\r\n Result := inherited GetNextRecord;\r\nend;\r\n\r\nfunction TJvADOQuery.GetOnThreadException: TJvThreadedDatasetThreadExceptionEvent;\r\nbegin\r\n if Assigned(ThreadHandler) then\r\n Result := ThreadHandler.OnThreadException\r\n else\r\n Result := nil;\r\nend;\r\n\r\nfunction TJvADOQuery.GetThreadOptions: TJvThreadedDatasetThreadOptions;\r\nbegin\r\n if Assigned(ThreadHandler) then\r\n Result := ThreadHandler.ThreadOptions\r\n else\r\n Result := nil;\r\nend;\r\n\r\nprocedure TJvADOQuery.InternalLast;\r\nbegin\r\n if Assigned(ThreadHandler) then\r\n ThreadHandler.InternalLast;\r\nend;\r\n\r\nprocedure TJvADOQuery.InternalRefresh;\r\nbegin\r\n if Assigned(ThreadHandler) then\r\n ThreadHandler.InternalRefresh;\r\nend;\r\n\r\nfunction TJvADOQuery.IsThreadAllowed: Boolean;\r\nbegin\r\n Result := True;\r\nend;\r\n\r\nprocedure TJvADOQuery.ReplaceOnFetchProgress(DataSet: TCustomADODataSet; Progress, MaxProgress: Integer; var\r\n EventStatus: TEventStatus);\r\nbegin\r\n if Assigned(ThreadHandler) then\r\n if ThreadHandler.CheckContinueRecordFetch <> tdccrContinue then\r\n EventStatus := esCancel\r\n else\r\n EventStatus := esOk;\r\n if Assigned(OnFetchProgress) and (EventStatus <> esCancel) then\r\n OnFetchProgress(Dataset, Progress, MaxProgress, EventStatus);\r\nend;\r\n\r\nprocedure TJvADOQuery.SetActive(Value: Boolean);\r\nbegin\r\n if Assigned(ThreadHandler) then\r\n ThreadHandler.SetActive(Value);\r\nend;\r\n\r\nprocedure TJvADOQuery.SetAfterOpenFetch(const Value: TDataSetNotifyEvent);\r\nbegin\r\n if Assigned(ThreadHandler) then\r\n ThreadHandler.AfterOpenFetch := Value;\r\nend;\r\n\r\nprocedure TJvADOQuery.SetAfterOpenFetch1(const Value: TDataSetNotifyEvent);\r\nbegin\r\n if Assigned(ThreadHandler) then\r\n ThreadHandler.AfterOpenFetch := Value;\r\nend;\r\n\r\nprocedure TJvADOQuery.SetAfterThreadExecution(const Value: TJvThreadedDatasetThreadEvent);\r\nbegin\r\n if Assigned(ThreadHandler) then\r\n ThreadHandler.AfterThreadExecution := Value;\r\nend;\r\n\r\nprocedure TJvADOQuery.SetBeforeThreadExecution(const Value: TJvThreadedDatasetThreadEvent);\r\nbegin\r\n if Assigned(ThreadHandler) then\r\n ThreadHandler.BeforeThreadExecution := Value;\r\nend;\r\n\r\nprocedure TJvADOQuery.SetDatasetFetchAllRecords(const Value: Boolean);\r\nbegin\r\n// FetchAll := Value;\r\nend;\r\n\r\nprocedure TJvADOQuery.SetDialogOptions(Value: TJvThreadedDatasetDialogOptions);\r\nbegin\r\n if Assigned(ThreadHandler) then\r\n ThreadHandler.DialogOptions.Assign(Value);\r\nend;\r\n\r\nprocedure TJvADOQuery.SetOnThreadException(const Value: TJvThreadedDatasetThreadExceptionEvent);\r\nbegin\r\n if Assigned(ThreadHandler) then\r\n ThreadHandler.OnThreadException := Value;\r\nend;\r\n\r\nprocedure TJvADOQuery.SetThreadOptions(const Value: TJvThreadedDatasetThreadOptions);\r\nbegin\r\n if Assigned(ThreadHandler) then\r\n ThreadHandler.ThreadOptions.Assign(Value);\r\nend;\r\n\r\nfunction TJvADOQuery.ThreadIsActive: Boolean;\r\nbegin\r\n if Assigned(ThreadHandler) then\r\n Result := ThreadHandler.ThreadIsActive\r\n else\r\n Result := False;\r\nend;\r\n\r\n//=== { TJvADOSmartQuery } ==================================================\r\n\r\nconstructor TJvADODataSet.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FThreadHandler := TJvBaseDatasetThreadHandler.Create(Self, Self);\r\n inherited OnFetchProgress := ReplaceOnFetchProgress;\r\nend;\r\n\r\ndestructor TJvADODataSet.Destroy;\r\nbegin\r\n FreeAndNil(FThreadHandler);\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvADODataSet.BreakExecution;\r\nbegin\r\n //BreakExec;\r\nend;\r\n\r\nprocedure TJvADODataSet.BringThreadDialogToFront;\r\nbegin\r\n if Assigned(ThreadHandler) then\r\n ThreadHandler.BringDialogToFront;\r\nend;\r\n\r\nfunction TJvADODataSet.CurrentFetchDuration: TDateTime;\r\nbegin\r\n if Assigned(ThreadHandler) then\r\n Result := ThreadHandler.CurrentFetchDuration\r\n else\r\n Result := 0;\r\nend;\r\n\r\nfunction TJvADODataSet.CurrentOpenDuration: TDateTime;\r\nbegin\r\n if Assigned(ThreadHandler) then\r\n Result := ThreadHandler.CurrentOpenDuration\r\n else\r\n Result := 0;\r\nend;\r\n\r\nprocedure TJvADODataSet.DoAfterOpen;\r\nbegin\r\n ThreadHandler.AfterOpen;\r\nend;\r\n\r\nprocedure TJvADODataSet.DoAfterRefresh;\r\nbegin\r\n ThreadHandler.AfterRefresh;\r\nend;\r\n\r\nprocedure TJvADODataSet.DoAfterScroll;\r\nbegin\r\n ThreadHandler.AfterScroll;\r\nend;\r\n\r\nprocedure TJvADODataSet.DoBeforeOpen;\r\nbegin\r\n ThreadHandler.BeforeOpen;\r\nend;\r\n\r\nprocedure TJvADODataSet.DoBeforeRefresh;\r\nbegin\r\n ThreadHandler.BeforeRefresh;\r\nend;\r\n\r\nfunction TJvADODataSet.DoGetInheritedNextRecord: Boolean;\r\nbegin\r\n Result := Inherited GetNextRecord;\r\nend;\r\n\r\nprocedure TJvADODataSet.DoInheritedAfterOpen;\r\nbegin\r\n inherited DoAfterOpen;\r\nend;\r\n\r\nprocedure TJvADODataSet.DoInheritedAfterRefresh;\r\nbegin\r\n inherited DoAfterRefresh;\r\nend;\r\n\r\nprocedure TJvADODataSet.DoInheritedAfterScroll;\r\nbegin\r\n inherited DoAfterScroll;\r\nend;\r\n\r\nprocedure TJvADODataSet.DoInheritedBeforeOpen;\r\nbegin\r\n inherited DoBeforeOpen;\r\nend;\r\n\r\nprocedure TJvADODataSet.DoInheritedBeforeRefresh;\r\nbegin\r\n inherited DoBeforeRefresh;\r\nend;\r\n\r\nprocedure TJvADODataSet.DoInheritedInternalLast;\r\nbegin\r\n inherited InternalLast;\r\nend;\r\n\r\nprocedure TJvADODataSet.DoInheritedInternalRefresh;\r\nbegin\r\n inherited InternalRefresh;\r\nend;\r\n\r\nprocedure TJvADODataSet.DoInheritedSetActive(Active: Boolean);\r\nbegin\r\n inherited SetActive(Active);\r\nend;\r\n\r\nprocedure TJvADODataSet.DoInternalOpen;\r\nbegin\r\n InternalOpen;\r\nend;\r\n\r\nfunction TJvADODataSet.EofReached: Boolean;\r\nbegin\r\n if Assigned(ThreadHandler) then\r\n Result := ThreadHandler.EofReached\r\n else\r\n Result := False;\r\nend;\r\n\r\nfunction TJvADODataSet.ErrorException: Exception;\r\nbegin\r\n if Assigned(ThreadHandler) then\r\n Result := ThreadHandler.ErrorException\r\n else\r\n Result := Nil;\r\nend;\r\n\r\nfunction TJvADODataSet.ErrorMessage: string;\r\nbegin\r\n if Assigned(ThreadHandler) then\r\n Result := ThreadHandler.ErrorMessage\r\n else\r\n Result := '';\r\nend;\r\n\r\nfunction TJvADODataSet.GetAfterOpenFetch: TDataSetNotifyEvent;\r\nbegin\r\n if Assigned(ThreadHandler) then\r\n Result := ThreadHandler.AfterOpenFetch\r\n else\r\n Result := nil;\r\nend;\r\n\r\nfunction TJvADODataSet.GetAfterOpenFetch1: TDataSetNotifyEvent;\r\nbegin\r\n if Assigned(ThreadHandler) then\r\n Result := ThreadHandler.AfterOpenFetch\r\n else\r\n Result := nil;\r\nend;\r\n\r\nfunction TJvADODataSet.GetAfterThreadExecution: TJvThreadedDatasetThreadEvent;\r\nbegin\r\n if Assigned(ThreadHandler) then\r\n Result := ThreadHandler.AfterThreadExecution\r\n else\r\n Result := nil;\r\nend;\r\n\r\nfunction TJvADODataSet.GetBeforeThreadExecution: TJvThreadedDatasetThreadEvent;\r\nbegin\r\n if Assigned(ThreadHandler) then\r\n Result := ThreadHandler.BeforeThreadExecution\r\n else\r\n Result := nil;\r\nend;\r\n\r\nfunction TJvADODataSet.GetDatasetFetchAllRecords: Boolean;\r\nbegin\r\n Result := False;\r\nend;\r\n\r\nfunction TJvADODataSet.GetDialogOptions: TJvThreadedDatasetDialogOptions;\r\nbegin\r\n if Assigned(ThreadHandler) then\r\n Result := ThreadHandler.DialogOptions\r\n else\r\n Result := nil;\r\nend;\r\n\r\nfunction TJvADODataSet.GetNextRecord: Boolean;\r\nbegin\r\n if Assigned(ThreadHandler) then\r\n Result := ThreadHandler.GetNextRecord\r\n else\r\n Result := inherited GetNextRecord;\r\nend;\r\n\r\nfunction TJvADODataSet.GetOnThreadException: TJvThreadedDatasetThreadExceptionEvent;\r\nbegin\r\n if Assigned(ThreadHandler) then\r\n Result := ThreadHandler.OnThreadException\r\n else\r\n Result := nil;\r\nend;\r\n\r\nfunction TJvADODataSet.GetThreadOptions: TJvThreadedDatasetThreadOptions;\r\nbegin\r\n if Assigned(ThreadHandler) then\r\n Result := ThreadHandler.ThreadOptions\r\n else\r\n Result := nil;\r\nend;\r\n\r\nprocedure TJvADODataSet.InternalLast;\r\nbegin\r\n if Assigned(ThreadHandler) then\r\n ThreadHandler.InternalLast;\r\nend;\r\n\r\nprocedure TJvADODataSet.InternalRefresh;\r\nbegin\r\n if Assigned(ThreadHandler) then\r\n ThreadHandler.InternalRefresh;\r\nend;\r\n\r\nfunction TJvADODataSet.IsThreadAllowed: Boolean;\r\nbegin\r\n if Assigned(Datasource) and Assigned(Datasource.Dataset) and (Datasource.Dataset is TJvADODataSet) then\r\n Result := not TJvADODataSet(Datasource.Dataset).ThreadHandler.ThreadIsActive\r\n else\r\n Result := True;\r\nend;\r\n\r\nprocedure TJvADODataSet.ReplaceOnFetchProgress(DataSet: TCustomADODataSet; Progress, MaxProgress: Integer; var\r\n EventStatus: TEventStatus);\r\nbegin\r\n if Assigned(ThreadHandler) then\r\n if ThreadHandler.CheckContinueRecordFetch <> tdccrContinue then\r\n EventStatus := esCancel\r\n else\r\n EventStatus := esOk;\r\n if Assigned(OnFetchProgress) and (EventStatus <> esCancel) then\r\n OnFetchProgress(Dataset, Progress, MaxProgress, EventStatus);\r\nend;\r\n\r\nprocedure TJvADODataSet.SetActive(Value: Boolean);\r\nbegin\r\n if Assigned(ThreadHandler) then\r\n ThreadHandler.SetActive(Value);\r\nend;\r\n\r\nprocedure TJvADODataSet.SetAfterOpenFetch(const Value: TDataSetNotifyEvent);\r\nbegin\r\n if Assigned(ThreadHandler) then\r\n ThreadHandler.AfterOpenFetch := Value;\r\nend;\r\n\r\nprocedure TJvADODataSet.SetAfterOpenFetch1(const Value: TDataSetNotifyEvent);\r\nbegin\r\n if Assigned(ThreadHandler) then\r\n ThreadHandler.AfterOpenFetch := Value;\r\nend;\r\n\r\nprocedure TJvADODataSet.SetAfterThreadExecution(const Value: TJvThreadedDatasetThreadEvent);\r\nbegin\r\n if Assigned(ThreadHandler) then\r\n ThreadHandler.AfterThreadExecution := Value;\r\nend;\r\n\r\nprocedure TJvADODataSet.SetBeforeThreadExecution(const Value: TJvThreadedDatasetThreadEvent);\r\nbegin\r\n if Assigned(ThreadHandler) then\r\n ThreadHandler.BeforeThreadExecution := Value;\r\nend;\r\n\r\nprocedure TJvADODataSet.SetDatasetFetchAllRecords(const Value: Boolean);\r\nbegin\r\n// FetchAll := Value;\r\nend;\r\n\r\nprocedure TJvADODataSet.SetDialogOptions(Value: TJvThreadedDatasetDialogOptions);\r\nbegin\r\n if Assigned(ThreadHandler) then\r\n ThreadHandler.DialogOptions.Assign(Value);\r\nend;\r\n\r\nprocedure TJvADODataSet.SetOnThreadException(const Value: TJvThreadedDatasetThreadExceptionEvent);\r\nbegin\r\n if Assigned(ThreadHandler) then\r\n ThreadHandler.OnThreadException := Value;\r\nend;\r\n\r\nprocedure TJvADODataSet.SetThreadOptions(const Value: TJvThreadedDatasetThreadOptions);\r\nbegin\r\n if Assigned(ThreadHandler) then\r\n ThreadHandler.ThreadOptions.Assign(Value);\r\nend;\r\n\r\nfunction TJvADODataSet.ThreadIsActive: Boolean;\r\nbegin\r\n if Assigned(ThreadHandler) then\r\n Result := ThreadHandler.ThreadIsActive\r\n else\r\n Result := False;\r\nend;\r\n\r\n\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\nend.\r\n\r\n" }, { "path": "External/Jedi/Jvcl/run/JvAVICapture.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvAVICapture.PAS, released 2003-07-05.\r\n\r\nThe Initial Developer of the Original Code is Olivier Sannier \r\nPortions created by Olivier Sannier are Copyright (C) 2003 Olivier Sannier.\r\nAll Rights Reserved.\r\n\r\nContributor(s): none to date\r\n\r\nCurrent Version: 0.4\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nDescription: This unit defines a component that you can drop on any form or\r\n frame and that will display the video stream captured by a video\r\n device installed under Windows. You can perform live previews,\r\n record movies (and save them to avi files) or even capture\r\n single frames. A direct access is provided to the frames so that\r\n you can process them if you want. This is an encapsulation of the\r\n AVICap API from Win32.\r\n\r\nKnown Issues: none known\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvAVICapture.pas 13300 2012-05-19 20:29:49Z obones $\r\n\r\nunit JvAVICapture;\r\n\r\n{$I jvcl.inc}\r\n{$I windowsonly.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, Messages, VFW, MMSystem, SysUtils, Classes, Graphics, Controls,\r\n JvTypes;\r\n\r\ntype\r\n TJvScrollPos = class(TPersistent)\r\n protected\r\n FLeft: Integer;\r\n FTop: Integer;\r\n published\r\n property Left: Integer read FLeft write FLeft;\r\n property Top: Integer read FTop write FTop;\r\n end;\r\n\r\n // The video format used by the video device\r\n TJvVideoFormat = class(TPersistent)\r\n protected\r\n FHWnd: HWND; // the AVICap window using this format\r\n FWidth: Cardinal; // width of the image\r\n FHeight: Cardinal; // height of the image\r\n FBitDepth: Cardinal; // bits per pixel (8-16-24-32...)\r\n FPixelFormat: TPixelFormat; // pixel format (RGB, BGR, YUV...)\r\n FCompression: Integer; // compression used\r\n public\r\n constructor Create; // Create the video format\r\n procedure Update; // Update from the AVICap window\r\n function Apply: Boolean; // apply the format to the window, returns True if successfull\r\n\r\n property Width: Cardinal read FWidth write FWidth;\r\n property Height: Cardinal read FHeight write FHeight;\r\n property BitDepth: Cardinal read FBitDepth write FBitDepth;\r\n property PixelFormat: TPixelFormat read FPixelFormat;\r\n property Compression: Integer read FCompression write FCompression;\r\n end;\r\n\r\n // The audio format used by the device\r\n TJvAudioFormat = class(TPersistent)\r\n protected\r\n FHWnd: HWND; // the AVICap window using this format\r\n FFormatTag: Cardinal; // the format tag (PCM or others...)\r\n FChannels: Cardinal; // number of channels (usually 1 or 2)\r\n FSamplesPerSec: Cardinal; // number of samples per second in the stream\r\n FAvgBytesPerSec: Cardinal; // the average number of bytes per second\r\n FBlockAlign: Cardinal; // size of the block to align on\r\n FBitsPerSample: Cardinal; // number of bits per sample\r\n FExtraSize: Cardinal; // size of the extra data\r\n FExtra: Pointer; // extra data for formats other than PCM\r\n public\r\n // creates the audio format object and initializes it\r\n constructor Create;\r\n // updates from the AVICap window\r\n procedure Update;\r\n // apply the format to the window, returns True if successfull\r\n function Apply: Boolean;\r\n // fill in a PWaveFormatEx structure to use with API calls\r\n procedure FillWaveFormatEx(var wfex: PWaveFormatEx);\r\n // run-time only property, see FSize\r\n property ExtraSize: Cardinal read FExtraSize write FExtraSize;\r\n // run-time only property, see FExtra\r\n property Extra: Pointer read FExtra write FExtra;\r\n published\r\n // see the relevant fields for details on the following properties\r\n property FormatTag: Cardinal read FFormatTag write FFormatTag;\r\n property Channels: Cardinal read FChannels write FChannels;\r\n property SamplesPerSec: Cardinal read FSamplesPerSec write FSamplesPerSec;\r\n property AvgBytesPerSec: Cardinal read FAvgBytesPerSec write FAvgBytesPerSec;\r\n property BlockAlign: Cardinal read FBlockAlign write FBlockAlign;\r\n property BitsPerSample: Cardinal read FBitsPerSample write FBitsPerSample;\r\n end;\r\n\r\n // a percentage\r\n TJvPercent = 0..100;\r\n\r\n // the number of audio buffers to use (maximum 10)\r\n TJvNumAudioBuffer = 0..10;\r\n\r\n // the type of a virtual key\r\n TJvVirtualKey = type Integer;\r\n\r\n // the capture settings to use to save a video stream to an AVI file\r\n TJvCaptureSettings = class(TPersistent)\r\n protected\r\n // the AVICap window that will use these settings and from which\r\n // we will get the values when we update them\r\n FHWnd: HWND;\r\n // if True, the API will popup a confirmation window when starting the\r\n // capture session allowing the user to choose to continue or not.\r\n FConfirmCapture: Boolean;\r\n // the delay in microsecond between two frames. This is a requested\r\n // value, it may not be fully respected by the driver when capturing\r\n FFrameDelay: Cardinal;\r\n // the percentage of frames dropped above which the capture will end\r\n // in an error state (too many drops having occured)\r\n FPercentDropForError: TJvPercent;\r\n // if True the capture session will be launched in a separate background\r\n // thread, not disabling the caller. Reentrance issues must then be\r\n // considered to avoid the user to launch twice the capture, for instance\r\n FYield: Boolean;\r\n // the requested number of video buffers. The actual number of allocated\r\n // buffers may well be smaller because of hardware limitations\r\n FNumVideoBuffer: Cardinal;\r\n // the requested number of audio buffers. The actual number of allocated\r\n // buffers may well be smaller because of hardware limitations\r\n FNumAudioBuffer: TJvNumAudioBuffer;\r\n // if True, the audio stream will also be captured\r\n FCaptureAudio: Boolean;\r\n // if True, a left mouse click will stop the capture session\r\n FAbortLeftMouse: Boolean;\r\n // if True, a right mouse click will stop the capture session\r\n FAbortRightMouse: Boolean;\r\n // if different from 0, a press on that virtual key will stop the\r\n // capture session\r\n FKeyAbort: TJvVirtualKey;\r\n // if True, the FTimeLimit parameter will be considered\r\n FLimitEnabled: Boolean;\r\n // the time limit for the capture session (in seconds). Will only be\r\n // considered if FLimitEnabled is True\r\n FTimeLimit: Cardinal;\r\n // if True, the capture will occur at twice the size specified in the\r\n // other parameters of this class.\r\n FStepCapture2x: Boolean;\r\n // the number of frames to sample and make the average of when using\r\n // a step capture\r\n FStepCaptureAverageFrames: Cardinal;\r\n // the size of an audio buffer\r\n FAudioBufferSize: Cardinal;\r\n // if True, the audio stream is the master one with respect to time\r\n // alignment. if False, the video stream is the master (recommanded)\r\n FAudioMaster: Boolean;\r\n // if True, the capture will controll a MCI device as its source\r\n FMCIControl: Boolean;\r\n // if True, the step capture is enabled on the MCI device\r\n // this is only considered if FMCIControl is True\r\n FMCIStep: Boolean;\r\n // time of the MCI device to start capture at\r\n // this is only considered if FMCIControl is True\r\n FMCIStartTime: Cardinal;\r\n // time of the MCI device to stop capture at\r\n // this is only considered if FMCIControl is True\r\n FMCIStopTime: Cardinal;\r\n // sets the FKeyAbort field\r\n procedure SetKeyAbort(nKeyAbort: TJvVirtualKey);\r\n // get and set the FPS property\r\n function GetFPS: Double;\r\n procedure SetFPS(const Value: Double);\r\n // set the FrameDelay property, ensuring the value is always\r\n // greater than 0\r\n procedure SetFrameDelay(const Value: Cardinal);\r\n public\r\n // creates and initializes the class\r\n constructor Create;\r\n // updates the class fields from the AVICap window\r\n procedure Update;\r\n // applies the class fields to the AVICap window, returns True if successful\r\n function Apply: Boolean;\r\n published\r\n // (rom) default values would be a good idea\r\n // please refer to the relevant field declarations for detail on the following properties\r\n property ConfirmCapture: Boolean read FConfirmCapture write FConfirmCapture;\r\n property FrameDelay: Cardinal read FFrameDelay write SetFrameDelay;\r\n property FPS: Double read GetFPS write SetFPS;\r\n property PercentDropForError: TJvPercent read FPercentDropForError write FPercentDropForError;\r\n property Yield: Boolean read FYield write FYield;\r\n property NumVideoBuffer: Cardinal read FNumVideoBuffer write FNumVideoBuffer;\r\n property NumAudioBuffer: TJvNumAudioBuffer read FNumAudioBuffer write FNumAudioBuffer;\r\n property CaptureAudio: Boolean read FCaptureAudio write FCaptureAudio;\r\n property AbortLeftMouse: Boolean read FAbortLeftMouse write FAbortLeftMouse;\r\n property AbortRightMouse: Boolean read FAbortRightMouse write FAbortRightMouse;\r\n property KeyAbort: TJvVirtualKey read FKeyAbort write SetKeyAbort;\r\n property LimitEnabled: Boolean read FLimitEnabled write FLimitEnabled;\r\n property TimeLimit: Cardinal read FTimeLimit write FTimeLimit;\r\n property StepCapture2x: Boolean read FStepCapture2x write FStepCapture2x;\r\n property StepCaptureAverageFrames: Cardinal read FStepCaptureAverageFrames write FStepCaptureAverageFrames;\r\n property AudioBufferSize: Cardinal read FAudioBufferSize write FAudioBufferSize;\r\n property AudioMaster: Boolean read FAudioMaster write FAudioMaster;\r\n property MCIControl: Boolean read FMCIControl write FMCIControl;\r\n property MCIStep: Boolean read FMCIStep write FMCIStep;\r\n property MCIStartTime: Cardinal read FMCIStartTime write FMCIStartTime;\r\n property MCIStopTime: Cardinal read FMCIStopTime write FMCIStopTime;\r\n end;\r\n\r\n // the type for the number of colors a palette can have\r\n TJvPaletteNbColors = 0..256;\r\n\r\n TJvPalette = class(TPersistent)\r\n protected\r\n FHWnd: HWND; // the AVICap window that will use these settings\r\n public\r\n // create the object\r\n constructor Create;\r\n // save the palette associated with the driver into the given file\r\n // and returns True upon success.\r\n function Save(FileName: string): Boolean;\r\n // loads the palette from the given file and returns True upon success\r\n // FHWnd must not be null\r\n function Load(FileName: string): Boolean;\r\n // paste the palette from the clipboard\r\n function PasteFromClipboard: Boolean;\r\n // automatically create the best palette from the first nbFrames frames with\r\n // a maximum of nbColors colors\r\n function AutoCreate(nbFrames: Integer; nbColors: TJvPaletteNbColors): Boolean;\r\n // Use this call from a frame callback and set the Flag to True to indicate that\r\n // the current frame must be considered when creating the palette. Continue\r\n // calling this method with Flag set to True as long as you need it.\r\n // Then call it again with Flag set to False, to finalize the palette and pass\r\n // it to the capture driver that will now use it.\r\n function ManuallyCreate(Flag: Boolean; nbColors: TJvPaletteNbColors): Boolean;\r\n end;\r\n\r\n // the driver index (-1 if not connected, 0-9 if connected as there are at most 10 drivers\r\n // according to Microsoft documentation. But there can be more than 1 source per driver...\r\n TJvDriverIndex = -1..9;\r\n\r\n // The exception triggered when an invalid index driver index is given\r\n EInvalidDriverIndexError = class(EJVCLException)\r\n public\r\n constructor Create(Index: TJvDriverIndex; MaxIndex: TJvDriverIndex);\r\n end;\r\n\r\n // what a driver can do on the system\r\n TJvDriverCaps = set of\r\n (dcOverlay, // overlay rendering\r\n dcDlgVideoSource, // display a dialog to choose video source\r\n dcDlgVideoFormat, // display a dialog to choose video format\r\n dcDlgVideoDisplay, // display a dialog to choose video display\r\n dcCaptureInitialized, // is the capture initialized\r\n dcSuppliesPalettes); // if the driver supplies palettes\r\n\r\n TJvUsedEvents = set of\r\n (ueCapControl, // the OnCapControl event will be triggered\r\n ueError, // the OnError event will be triggered\r\n ueFrame, // the OnFrame event will be triggered\r\n ueStatus, // the OnStatus event will be triggered\r\n ueVideoStream, // the OnVideoStream event will be triggered\r\n ueWaveStream, // the OnWaveStream event will be triggered\r\n ueYield); // the OnYield event will be triggered\r\n\r\n // the video dialog to display\r\n TJvVideoDialog =\r\n (vdSource, // the source dialog (only if dcDlgVideoSource is in the caps)\r\n vdFormat, // the format dialog (only if dcDlgVideoFormat is in the caps)\r\n vdDisplay, // the display dialog (only if dcDlgVideoDisplay is in the caps)\r\n vdCompression); // the compression dialog (with all the installed video codecs)\r\n\r\n // local type for the events\r\n PJvVideoHdr = PVIDEOHDR;\r\n PJvWaveHdr = PWaveHdr;\r\n\r\n // forward declaration for the events\r\n TJvAVICapture = class;\r\n\r\n // the event triggered in case of an error\r\n // Sender is the TJvAVICapture component triggering the event\r\n // nErr is the error number\r\n // Str is the string associated with that error\r\n TOnError = procedure(Sender: TJvAVICapture; nErr: Integer; Str: string) of object;\r\n\r\n // the event triggered in case of a status change (use it to follow progress)\r\n // Sender is the TJvAVICapture component triggering the event\r\n // nId is the id of the status change (see win32 API for more details)\r\n // Str is the string associated with that status change\r\n TOnStatus = procedure(Sender: TJvAVICapture; nId: Integer; Str: string) of object;\r\n\r\n // the event triggerred when the driver is yielding. a good place to put a\r\n // call to Application.ProcessMessages\r\n // Sender is the TJvAVICapture component triggering the event\r\n TOnYield = procedure(Sender: TJvAVICapture) of object;\r\n\r\n // the event trigerred when a frame is ready to be written to disk during streaming capture\r\n // Sender is the TJvAVICapture component triggering the event\r\n // videoHdr is the video header describing the stream\r\n TOnVideoStream = procedure(Sender: TJvAVICapture; videoHdr: PJvVideoHdr) of object;\r\n\r\n // the event trigerred when a frame is ready, in a non streaming capture session\r\n TOnFrame = TOnVideoStream;\r\n\r\n // the event trigerred when an audio buffer is ready to be written do disk during streaming capture\r\n // Sender is the TJvAVICapture component triggering the event\r\n // audioHdr is the audio header describing the stream\r\n TOnWaveStream = procedure(Sender: TJvAVICapture; waveHdr: PJvWaveHdr) of object;\r\n\r\n // the event triggered when you want to use precise capture control\r\n // Sender is the TJvAVICapture component triggering the event\r\n // state is the state in which the capture is (refer to API for details)\r\n // Result is to be set to True if capture must continue, False if it must stop\r\n TOnCapControl = procedure(Sender: TJvAVICapture; nState: Integer; var Result: Boolean) of object;\r\n\r\n // the main component. Just drop it on a form or a frame, set the driver property, set previewing to\r\n // True and you should see the video coming through (even in design mode !)\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvAVICapture = class(TWinControl)\r\n protected\r\n FCaptureSettings: TJvCaptureSettings; // the capture settings\r\n FCapturing: Boolean; // True if capture is happening\r\n FConnected: Boolean; // True if connected to a driver\r\n FDrivers: TStringList; // the available drivers as a TStringList\r\n FDriverCaps: TJvDriverCaps; // the current driver capabilities\r\n FHWnd: HWND; // the handle to the AviCap window\r\n FNoFile: Boolean; // True if not capturing to a file\r\n FOverlaying: Boolean; // True if using overlay display\r\n FPreviewFrameDelay: Cardinal; // the time between two preview frames (ms)\r\n FPreviewing: Boolean; // True if previewing\r\n FSingleFrameCapturing: Boolean; // True if capturing using single frame capture\r\n FTitle: string; // the title of the AVICap window\r\n FVideoLeft: Integer; // the left coordinate of the displayed video\r\n FVideoTop: Integer; // the top coordinate of the displayed video\r\n // the user supplied event handlers\r\n // see respective types for details\r\n FOnError: TOnError;\r\n FOnStatus: TOnStatus;\r\n FOnYield: TOnYield;\r\n FOnFrame: TOnFrame;\r\n FOnVideoStream: TOnVideoStream;\r\n FOnWaveStream: TOnWaveStream;\r\n FOnCapControl: TOnCapControl;\r\n\r\n FFileName: string; // the filename for the capture file\r\n FFileSizeAlloc: Cardinal; // the size to allocate for the capture file\r\n FUsedEvents: TJvUsedEvents; // which events are used\r\n FCaptureStatus: TCAPSTATUS; // the state of the current capture\r\n FVideoFormat: TJvVideoFormat; // the current video format used (or to be used)\r\n FAudioFormat: TJvAudioFormat; // the current audio format used (or to be used)\r\n FScrollPos: TJvScrollPos; // the scrolling position in the window\r\n FPalette: TJvPalette; // the palette in use\r\n FDriverIndex: TJvDriverIndex; // the driver index (-1 if not connected)\r\n\r\n // the Pointer to the previous WndProc of the AviCap window\r\n FPreviousWndProc: Pointer;\r\n // window creation stuff, where the AviCap window is created:\r\n // what is done is that the component inherits from TWinControl and as such\r\n // has its own handle. We then create the AviCap window and set it as a child\r\n // of the TWinControl. This allows to take advantage of all the VCL handling\r\n // for design time, parent, ownership... and we can focus on using the\r\n // AviCap window to do the capture\r\n procedure CreateWindowHandle(const Params: TCreateParams); override;\r\n // destroys the AviCap window just before letting the VCL destroy the handle\r\n // for the TWinControl\r\n procedure DestroyWindowHandle; override;\r\n // Resizes the internal window that is used to display the AviCap content.\r\n procedure ResizeAviCapWindow(Width, Height: Integer);\r\n // We enforce the size of the window to be equal to the\r\n // video frame in this method as it is the place where it\r\n // should be done, rather than doing it in SetBounds\r\n function CanAutoSize(var NewWidth, NewHeight: Integer): Boolean; override;\r\n // sets the title of the AviCap window\r\n procedure SetTitle(nTitle: string);\r\n // sets the preview frame delay (the time between two frames)\r\n procedure SetPreviewFrameDelay(nPreviewFrameDelay: Cardinal);\r\n // sets and gets the preview frame rate in frames per second\r\n procedure SetPreviewFPS(nPreviewFPS: Double);\r\n function GetPreviewFPS: Double;\r\n // sets the previewing property and starts or stop previewing accordingly\r\n procedure SetPreviewing(nPreviewing: Boolean);\r\n // sets and gets the filename for capture\r\n procedure SetFileName(nFileName: TFileName);\r\n function GetFileName: TFileName;\r\n // delivers FDrivers as TStrings for property\r\n function GetDrivers: TStrings;\r\n // sets the file size to allocate before capture. This might speed up capture as\r\n // the file won't need to be grown\r\n procedure SetFileSizeAlloc(nFileSizeAlloc: Cardinal);\r\n // sets the used events and updates the related values in the AviCap window\r\n procedure SetUsedEvents(nUsedEvents: TJvUsedEvents);\r\n // sets the overlaying rendering. May do nothing if driver cannot do overlay rendering\r\n procedure SetOverlaying(nOverlaying: Boolean);\r\n // returns the name of the driver or an empty string if FConnected is False\r\n function GetDriverName: string;\r\n // returns the version of the driver or an empty string if FConnected is False\r\n function GetDriverVersion: string;\r\n // set the scrolling position in the AviCap window. Useful if the frame is larger than\r\n // the actual size of the control\r\n procedure SetScrollPos(nScrollPos: TJvScrollPos);\r\n // sets and gets the MCI device used with this AviCap component (may well be empty)\r\n procedure SetMCIDevice(nMCIDevice: string);\r\n function GetMCIDevice: string;\r\n // sets the driver index to the given value and tries to connect. If connection\r\n // is not possible, will not change the current value\r\n procedure SetDriverIndex(nIndex: TJvDriverIndex);\r\n // tries to starts or stops capture according to the value\r\n // immediately check the value of FCapturing to see if capture\r\n // started succesfuly\r\n procedure SetCapturing(nCapturing: Boolean);\r\n // tries starts or stops single frame capture according to the value\r\n // immediately check the value of FSingleFrameCapturing to see\r\n // if capture started succesfuly\r\n procedure SetSingleFrameCapturing(const Value: Boolean);\r\n // sets the FNoFile flag\r\n procedure SetNoFile(nNoFile: Boolean);\r\n // sets the FVideoLeft and FVideoTop values and also\r\n // makes the required capCall\r\n procedure SetVideoLeft(const Value: Integer);\r\n procedure SetVideoTop(const Value: Integer);\r\n // updates the content of the FDriverCaps field\r\n procedure UpdateCaps;\r\n // updates the content of the FCaptureStatus field\r\n procedure UpdateCaptureStatus;\r\n // stops and start using callbacks. This is required as it appears that the\r\n // callbacks are still called after a capture session has been stopped.\r\n procedure StopCallbacks;\r\n procedure RestartCallbacks;\r\n // Functions to be called from the callbacks that will trigger the user events\r\n procedure DoError(ErrId: Integer; Str: string);\r\n procedure DoStatus(nId: Integer; Str: string);\r\n procedure DoYield;\r\n procedure DoFrame(videoHdr: PVIDEOHDR);\r\n procedure DoVideoStream(videoHdr: PVIDEOHDR);\r\n procedure DoWaveStream(waveHdr: PWaveHdr);\r\n procedure DoCapControl(nState: Integer; var AResult: Boolean);\r\n public\r\n // creates the component and initializes the different fields\r\n constructor Create(AOwner: TComponent); override;\r\n // destroys the component\r\n destructor Destroy; override;\r\n // sets the size of the component\r\n procedure SetBounds(nLeft, nTop, nWidth, nHeight: Integer); override;\r\n // enumarate the drivers and populates the FDrivers list\r\n procedure EnumDrivers;\r\n // tries to connect to the given driver. Returns True if successful, False otherwise\r\n function Connect(Driver: TJvDriverIndex): Boolean;\r\n // tries to disconnect from a driver. Returns True if successful, False otherwise\r\n function Disconnect: Boolean;\r\n // shows the given dialog and returns True if user pressed ok. If the driver\r\n // cannot show the given dialog...\r\n function ShowDialog(Dialog: TJvVideoDialog): Boolean;\r\n // starts and stop previewing, returning True upon success\r\n function StartPreview: Boolean;\r\n function StopPreview: Boolean;\r\n // start capturing to a file using streaming capture\r\n function StartCapture: Boolean;\r\n // start capturing without using a file. You should use the OnVideoStream event in that\r\n // case to process the frames yourself. This might be useful in a videoconferencing\r\n // software, where you transfer the frames directly\r\n function StartCaptureNoFile: Boolean;\r\n // stops the capture properly\r\n function StopCapture: Boolean;\r\n // aborts the capture, leaving the file unusable\r\n function AbortCapture: Boolean;\r\n // starts frame by frame capture (non streaming)\r\n function StartSingleFrameCapture: Boolean;\r\n // captures one frame in a frame by frame capture session\r\n function CaptureFrame: Boolean;\r\n // stops frame by frame capture\r\n function StopSingleFrameCapture: Boolean;\r\n // starts and stop overlay rendering, returns True if successful\r\n function StartOverlay: Boolean;\r\n function StopOverlay: Boolean;\r\n // applies the capture settings, returns True if successful\r\n function ApplyCaptureSettings: Boolean;\r\n // applies the audio format settings, returns True if successful\r\n function ApplyAudioFormat: Boolean;\r\n // saves the stream under the given filename\r\n function SaveAs(Name: string): Boolean;\r\n // sets information chunks in the output file\r\n function SetInfoChunk(const Chunk: TCAPINFOCHUNK): Boolean;\r\n // saves the latest captured frame to a DIB file\r\n function SaveDIB(Name: string): Boolean;\r\n // copies the latest frame to the clipboard\r\n function CopyToClipboard: Boolean;\r\n // grabs one frame, not using any capture session\r\n // if stop is True, previewing and overlaying are stopped\r\n // if stop is False, previewing and overlaying are left untouched\r\n function GrabFrame(Stop: Boolean): Boolean;\r\n // public properties (run-time only), refer to fields and methods descriptions\r\n // for details on the usage\r\n property CaptureStatus: TCAPSTATUS read FCaptureStatus;\r\n property Capturing: Boolean read FCapturing write SetCapturing;\r\n property Connected: Boolean read FConnected;\r\n property DriverCaps: TJvDriverCaps read FDriverCaps;\r\n property DriverName: string read GetDriverName;\r\n property DriverVersion: string read GetDriverVersion;\r\n property Drivers: TStrings read GetDrivers;\r\n property Handle: HWND read FHWnd;\r\n property Palette: TJvPalette read FPalette;\r\n property SingleFrameCapturing: Boolean read FSingleFrameCapturing write SetSingleFrameCapturing;\r\n property VideoFormat: TJvVideoFormat read FVideoFormat;\r\n published\r\n // published properties, refer to the field and methods descriptions for details\r\n property AudioFormat: TJvAudioFormat read FAudioFormat;\r\n property CaptureSettings: TJvCaptureSettings read FCaptureSettings;\r\n property DriverIndex: TJvDriverIndex read FDriverIndex write SetDriverIndex default -1;\r\n property FileName: TFileName read GetFileName write SetFileName;\r\n property FileSizeAlloc: Cardinal read FFileSizeAlloc write SetFileSizeAlloc default 0;\r\n property MCIDevice: string read GetMCIDevice write SetMCIDevice;\r\n property NoFile: Boolean read FNoFile write SetNoFile default False;\r\n property Overlaying: Boolean read FOverlaying write SetOverlaying default False;\r\n property PreviewFrameDelay: Cardinal read FPreviewFrameDelay write SetPreviewFrameDelay default 50;\r\n property PreviewFPS: Double read GetPreviewFPS write SetPreviewFPS;\r\n property Previewing: Boolean read FPreviewing write SetPreviewing default False;\r\n property ScrollPos: TJvScrollPos read FScrollPos write SetScrollPos;\r\n property Title: string read FTitle write SetTitle;\r\n property UsedEvents: TJvUsedEvents read FUsedEvents write SetUsedEvents default [];\r\n property VideoLeft: Integer read FVideoLeft write SetVideoLeft default 0;\r\n property VideoTop: Integer read FVideoTop write SetVideoTop default 0;\r\n // inherited properties getting published\r\n property AutoSize;\r\n property ParentShowHint;\r\n property ShowHint;\r\n property Visible;\r\n // the events, refer to the fields decriptions for details\r\n property OnError: TOnError read FOnError write FOnError;\r\n property OnStatus: TOnStatus read FOnStatus write FOnStatus;\r\n property OnYield: TOnYield read FOnYield write FOnYield;\r\n property OnFrame: TOnFrame read FOnFrame write FOnFrame;\r\n property OnVideoStream: TOnVideoStream read FOnVideoStream write FOnVideoStream;\r\n property OnWaveStream: TOnWaveStream read FOnWaveStream write FOnWaveStream;\r\n property OnCapControl: TOnCapControl read FOnCapControl write FOnCapControl;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvAVICapture.pas $';\r\n Revision: '$Revision: 13300 $';\r\n Date: '$Date: 2012-05-19 22:29:49 +0200 (sam. 19 mai 2012) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n Math, // for Min and Max\r\n {$IFNDEF COMPILER12_UP}\r\n JvJCLUtils, // SetWindowLongPtr\r\n {$ENDIF ~COMPILER12_UP}\r\n JvResources;\r\n\r\nconst\r\n // minimal height and width of the display window\r\n cMinHeight = 20;\r\n cMinWidth = 20;\r\n\r\n{ Global functions }\r\n\r\n// an helper function that tells if the window is connected to a driver\r\n\r\nfunction capDriverConnected(hWnd: HWND): Boolean;\r\nvar\r\n TmpName: array [0..MAX_PATH] of Char;\r\nbegin\r\n Result := capDriverGetName(hWnd, TmpName, SizeOf(TmpName));\r\nend;\r\n\r\n{ This is the custom window procedure, which replaces the one originally associated\r\n with the AviCap window. all we do is pass the messages to the TWinControl\r\n containing the AviCap window so that it can resize and move itself.\r\n Then we pass the message to the original window procedure for it to handle the\r\n messages it needs to perform the video capture\r\n}\r\n\r\nfunction CustomWndProc(hWnd: HWND; Msg: UINT; wParam: WPARAM; lParam: LPARAM): LRESULT; stdcall;\r\nvar\r\n SelfObj: TJvAVICapture;\r\nbegin\r\n Result := 0;\r\n\r\n // get the Pointer to self from the window user data\r\n SelfObj := TJvAVICapture(GetWindowLongPtr(hWnd, GWL_USERDATA));\r\n if SelfObj <> nil then\r\n begin\r\n // send the message to the containing window, except for WM_NCHITTEST\r\n // This will prevent 100% processor usage when the mouse is kept over\r\n // the control during design time or run time\r\n // Note: We MUST convert SelfObj to a TWinControl as the Handle\r\n // property of TJvAVICapture returns the handle of the AVICap window\r\n // thus leading to an infinite loop if we were to use it...\r\n if Msg <> WM_NCHITTEST then\r\n PostMessage(TWinControl(SelfObj).Handle, Msg, wParam, lParam);\r\n\r\n // sending the message to the original window proc\r\n Result := CallWindowProc(SelfObj.FPreviousWndProc, hWnd, Msg, wParam, lParam);\r\n end;\r\nend;\r\n\r\n{ Callbacks }\r\n\r\n// This is the callback called in case of an error\r\n// will only be called if the user chose so with ueError\r\n\r\nfunction ErrorCallback(hWnd: HWND; ErrId: Integer; Str: LPTSTR): LRESULT; stdcall;\r\nvar\r\n SelfObj: TJvAVICapture;\r\nbegin\r\n // clear previous error if required\r\n if ErrId = 0 then\r\n begin\r\n Result := LRESULT(Ord(True));\r\n Exit;\r\n end;\r\n\r\n // get the Pointer to self from the window user data\r\n SelfObj := TJvAVICapture(GetWindowLongPtr(hWnd, GWL_USERDATA));\r\n if SelfObj <> nil then\r\n SelfObj.DoError(ErrId, Str);\r\n\r\n Result := LRESULT(Ord(True));\r\nend;\r\n\r\n// This is the callback called in case of a status change\r\n// will only be called if the user chose so with ueStatus\r\n\r\nfunction StatusCallback(hWnd: HWND; nId: Integer; Str: LPTSTR): LRESULT; stdcall;\r\nvar\r\n SelfObj: TJvAVICapture;\r\nbegin\r\n // get the Pointer to self from the window user data\r\n SelfObj := TJvAVICapture(GetWindowLongPtr(hWnd, GWL_USERDATA));\r\n if SelfObj <> nil then\r\n SelfObj.DoStatus(nId, Str);\r\n\r\n Result := LRESULT(Ord(True));\r\nend;\r\n\r\n// This is the callback called in case of yielding\r\n// will only be called if the user chose so with ueYield\r\n\r\nfunction YieldCallback(hWnd: HWND): LRESULT; stdcall;\r\nvar\r\n SelfObj: TJvAVICapture;\r\nbegin\r\n // get the Pointer to self from the window user data\r\n SelfObj := TJvAVICapture(GetWindowLongPtr(hWnd, GWL_USERDATA));\r\n if SelfObj <> nil then\r\n SelfObj.DoYield;\r\n\r\n Result := LRESULT(Ord(True));\r\nend;\r\n\r\n// This is the callback called in case a new frame is available while a non\r\n// streaming capture is in progress\r\n// will only be called if the user chose so with ueFrame\r\n\r\nfunction FrameCallback(hWnd: HWND; videoHdr: PVIDEOHDR): LRESULT; stdcall;\r\nvar\r\n SelfObj: TJvAVICapture;\r\nbegin\r\n // get the Pointer to self from the window user data\r\n SelfObj := TJvAVICapture(GetWindowLongPtr(hWnd, GWL_USERDATA));\r\n if SelfObj <> nil then\r\n SelfObj.DoFrame(videoHdr);\r\n\r\n Result := LRESULT(Ord(True));\r\nend;\r\n\r\n// This is the callback called when a frame is available, just before being\r\n// written to disk, only if using stream capture\r\n// will only be called if the user chose so with ueVideoStream\r\n\r\nfunction VideoStreamCallback(hWnd: HWND; videoHdr: PVIDEOHDR): LRESULT; stdcall;\r\nvar\r\n SelfObj: TJvAVICapture;\r\nbegin\r\n // get the Pointer to self from the window user data\r\n SelfObj := TJvAVICapture(GetWindowLongPtr(hWnd, GWL_USERDATA));\r\n if SelfObj <> nil then\r\n SelfObj.DoVideoStream(videoHdr);\r\n\r\n Result := LRESULT(Ord(True));\r\nend;\r\n\r\n// this is the callback when an audio buffer is ready to be written to disk\r\n// and only when using streaming capture\r\n// will only be called if user chose so with ueWaveStream\r\n\r\nfunction WaveStreamCallback(hWnd: HWND; waveHdr: PWaveHdr): LRESULT; stdcall;\r\nvar\r\n SelfObj: TJvAVICapture;\r\nbegin\r\n // get the Pointer to self from the window user data\r\n SelfObj := TJvAVICapture(GetWindowLongPtr(hWnd, GWL_USERDATA));\r\n if SelfObj <> nil then\r\n SelfObj.DoWaveStream(waveHdr);\r\n\r\n Result := LRESULT(Ord(True));\r\nend;\r\n\r\n// this is the callback called when a precise capture control event has\r\n// occured. Only called if user chose so with ueCapControl\r\n\r\nfunction CapControlCallback(hWnd: HWND; nState: Integer): LRESULT; stdcall;\r\nvar\r\n SelfObj: TJvAVICapture;\r\n res: Boolean;\r\nbegin\r\n res := True;\r\n // get the Pointer to self from the window user data\r\n SelfObj := TJvAVICapture(GetWindowLongPtr(hWnd, GWL_USERDATA));\r\n if SelfObj <> nil then\r\n SelfObj.DoCapControl(nState, res);\r\n\r\n Result := LRESULT(Ord(res));\r\nend;\r\n\r\n//=== { TJvVideoFormat } =====================================================\r\n\r\nfunction TJvVideoFormat.Apply: Boolean;\r\nvar\r\n BmpInfo: BITMAPINFOHEADER;\r\nbegin\r\n Result := False;\r\n if FHWnd <> 0 then\r\n begin\r\n BmpInfo.biWidth := FWidth;\r\n BmpInfo.biHeight := FHeight;\r\n BmpInfo.biBitCount := FBitDepth;\r\n BmpInfo.biCompression := FCompression;\r\n\r\n Result := capSetVideoFormat(FHWnd, @BmpInfo, SizeOf(BmpInfo));\r\n end;\r\nend;\r\n\r\nconstructor TJvVideoFormat.Create;\r\nbegin\r\n inherited Create;\r\n FHWnd := 0;\r\nend;\r\n\r\nprocedure TJvVideoFormat.Update;\r\nvar\r\n BmpInfo: BITMAPINFOHEADER;\r\nbegin\r\n if (FHWnd <> 0) and capDriverConnected(FHWnd) then\r\n begin\r\n // get format from the AviCap window\r\n capGetVideoFormat(FHWnd, @BmpInfo, SizeOf(BmpInfo));\r\n\r\n // update the internal values\r\n FWidth := BmpInfo.biWidth;\r\n FHeight := BmpInfo.biHeight;\r\n FBitDepth := BmpInfo.biBitCount;\r\n FCompression := BmpInfo.biCompression;\r\n\r\n case BitDepth of\r\n 0:\r\n FPixelFormat := pfDevice;\r\n 1:\r\n FPixelFormat := pf1bit;\r\n 4:\r\n FPixelFormat := pf4bit;\r\n 8:\r\n FPixelFormat := pf8bit;\r\n 16:\r\n FPixelFormat := pf15bit;\r\n 24:\r\n FPixelFormat := pf24bit;\r\n 32:\r\n FPixelFormat := pf32bit;\r\n else\r\n FPixelFormat := pfCustom;\r\n end;\r\n end;\r\nend;\r\n\r\n//=== { TJvAudioFormat } =====================================================\r\n\r\nconstructor TJvAudioFormat.Create;\r\nbegin\r\n inherited Create;\r\n FHWnd := 0;\r\n FExtra := nil;\r\nend;\r\n\r\nprocedure TJvAudioFormat.Update;\r\nvar\r\n Info: tWAVEFORMATEX;\r\nbegin\r\n if (FHWnd <> 0) and capDriverConnected(FHWnd) then\r\n begin\r\n // gets the format from the AviCap window\r\n capGetAudioFormat(FHWnd, @Info, SizeOf(Info));\r\n\r\n // sets the internal values\r\n FFormatTag := Info.wFormatTag;\r\n FChannels := Info.nChannels;\r\n FSamplesPerSec := Info.nSamplesPerSec;\r\n FAvgBytesPerSec := Info.nAvgBytesPerSec;\r\n FBlockAlign := Info.nBlockAlign;\r\n FBitsPerSample := Info.wBitsPerSample;\r\n FExtraSize := Info.cbSize;\r\n\r\n // if there is extra data, save it too\r\n if FExtraSize > 0 then\r\n begin\r\n // if there was extra data saved before, free it before\r\n if FExtra <> nil then\r\n FreeMem(FExtra);\r\n GetMem(FExtra, ExtraSize);\r\n CopyMemory(FExtra, PAnsiChar(@Info) + SizeOf(tWAVEFORMATEX), FExtraSize);\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJvAudioFormat.Apply: Boolean;\r\nvar\r\n pwfex: PWaveFormatEx;\r\nbegin\r\n Result := False;\r\n if FHWnd <> 0 then\r\n begin\r\n FillWaveFormatEx(pwfex);\r\n Result := capSetAudioFormat(FHWnd, pwfex, SizeOf(tWAVEFORMATEX) + pwfex^.cbSize);\r\n end;\r\nend;\r\n\r\nprocedure TJvAudioFormat.FillWaveFormatEx(var wfex: PWaveFormatEx);\r\nbegin\r\n case FormatTag of\r\n WAVE_FORMAT_PCM:\r\n begin\r\n GetMem(wfex, SizeOf(tWAVEFORMATEX));\r\n wfex^.wFormatTag := FFormatTag;\r\n // ensure maximum 2 channels\r\n wfex^.nChannels := FChannels mod 3;\r\n wfex^.nSamplesPerSec := FSamplesPerSec;\r\n // ensure 8 or 16 bits\r\n wfex^.wBitsPerSample := ((FBitsPerSample div 8) mod 3) * 8;\r\n // using rules defined in Documentation\r\n wfex^.nBlockAlign := wfex.nChannels * wfex.wBitsPerSample div 8;\r\n wfex^.nAvgBytesPerSec := wfex.nSamplesPerSec * wfex.nBlockAlign;\r\n wfex^.cbSize := 0;\r\n end;\r\n else\r\n GetMem(wfex, SizeOf(tWAVEFORMATEX) + FExtraSize);\r\n wfex^.wFormatTag := FFormatTag;\r\n wfex^.nChannels := FChannels;\r\n wfex^.nSamplesPerSec := FSamplesPerSec;\r\n wfex^.nAvgBytesPerSec := FAvgBytesPerSec;\r\n wfex^.nBlockAlign := FBlockAlign;\r\n wfex^.wBitsPerSample := FBitsPerSample;\r\n wfex^.cbSize := FExtraSize;\r\n\r\n // copy Extra to the end of the structure\r\n CopyMemory(PAnsiChar(@wfex) + SizeOf(tWAVEFORMATEX), FExtra, FExtraSize);\r\n end;\r\nend;\r\n\r\n//=== { TJvCaptureSettings } =================================================\r\n\r\nconstructor TJvCaptureSettings.Create;\r\nbegin\r\n inherited Create;\r\n FHWnd := 0;\r\n FFrameDelay := 1;\r\nend;\r\n\r\nprocedure TJvCaptureSettings.SetKeyAbort(nKeyAbort: TJvVirtualKey);\r\nvar\r\n Modifiers: Word;\r\nbegin\r\n // Unregister any previous hotkey\r\n if FKeyAbort <> 0 then\r\n UnregisterHotKey(FHWnd, 0);\r\n\r\n // register hotkey, only if needed\r\n if nKeyAbort <> 0 then\r\n begin\r\n Modifiers := 0;\r\n if (nKeyAbort and $4000) <> 0 then\r\n Modifiers := Modifiers or MOD_SHIFT;\r\n if (nKeyAbort and $8000) <> 0 then\r\n Modifiers := Modifiers or MOD_CONTROL;\r\n if RegisterHotKey(FHWnd, 0, Modifiers, nKeyAbort and $FF) then\r\n FKeyAbort := nKeyAbort;\r\n end\r\n else\r\n FKeyAbort := nKeyAbort;\r\nend;\r\n\r\nprocedure TJvCaptureSettings.Update;\r\nvar\r\n Parms: TCAPTUREPARMS;\r\nbegin\r\n if FHWnd <> 0 then\r\n begin\r\n // get capture settings from window\r\n capCaptureGetSetup(FHWnd, @Parms, SizeOf(Parms));\r\n\r\n // udapte internal settings\r\n with Parms do\r\n begin\r\n FFrameDelay := dwRequestMicroSecPerFrame;\r\n// FFramesPerSec := 1/dwRequestMicroSecPerFrame*1E6;\r\n FConfirmCapture := fMakeUserHitOKToCapture;\r\n FPercentDropForError := wPercentDropForError;\r\n FYield := FYield;\r\n FNumVideoBuffer := wNumVideoRequested;\r\n FCaptureAudio := FCaptureAudio;\r\n FNumAudioBuffer := wNumAudioRequested;\r\n FAbortLeftMouse := FAbortLeftMouse;\r\n FAbortRightMouse := FAbortRightMouse;\r\n FKeyAbort := vKeyAbort;\r\n FLimitEnabled := FLimitEnabled;\r\n FTimeLimit := wTimeLimit;\r\n FStepCapture2x := fStepCaptureAt2x;\r\n FStepCaptureAverageFrames := wStepCaptureAverageFrames;\r\n FAudioBufferSize := dwAudioBufferSize;\r\n FAudioMaster := (AVStreamMaster = AVSTREAMMASTER_AUDIO);\r\n FMCIControl := FMCIControl;\r\n FMCIStep := fStepMCIDevice;\r\n FMCIStartTime := dwMCIStartTime;\r\n FMCIStopTime := dwMCIStopTime;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJvCaptureSettings.Apply: Boolean;\r\nvar\r\n Parms: TCAPTUREPARMS;\r\nbegin\r\n Result := False;\r\n if FHWnd <> 0 then\r\n begin\r\n // get original values from window\r\n capCaptureGetSetup(FHWnd, @Parms, SizeOf(Parms));\r\n\r\n // set our own values\r\n with Parms do\r\n begin\r\n dwRequestMicroSecPerFrame := FFrameDelay;\r\n fMakeUserHitOKToCapture := ConfirmCapture;\r\n wPercentDropForError := PercentDropForError;\r\n FYield := Yield;\r\n wNumVideoRequested := NumVideoBuffer;\r\n FCaptureAudio := CaptureAudio;\r\n wNumAudioRequested := NumAudioBuffer;\r\n FAbortLeftMouse := AbortLeftMouse;\r\n FAbortRightMouse := AbortRightMouse;\r\n vKeyAbort := FKeyAbort;\r\n FLimitEnabled := LimitEnabled;\r\n wTimeLimit := TimeLimit;\r\n fStepCaptureAt2x := StepCapture2x;\r\n wStepCaptureAverageFrames := StepCaptureAverageFrames;\r\n dwAudioBufferSize := AudioBufferSize;\r\n if AudioMaster then\r\n AVStreamMaster := AVSTREAMMASTER_AUDIO\r\n else\r\n AVStreamMaster := AVSTREAMMASTER_NONE;\r\n FMCIControl := Self.FMCIControl;\r\n fStepMCIDevice := Self.FMCIStep;\r\n dwMCIStartTime := FMCIStartTime;\r\n dwMCIStopTime := FMCIStopTime;\r\n end;\r\n\r\n // apply new settings\r\n Result := capCaptureSetSetup(FHWnd, @Parms, SizeOf(Parms));\r\n end;\r\nend;\r\n\r\nfunction TJvCaptureSettings.GetFPS: Double;\r\nbegin\r\n Result := 1 / FFrameDelay * 1.0E6;\r\nend;\r\n\r\nprocedure TJvCaptureSettings.SetFPS(const Value: Double);\r\nbegin\r\n FFrameDelay := Round(1.0E6 / Value);\r\nend;\r\n\r\nprocedure TJvCaptureSettings.SetFrameDelay(const Value: Cardinal);\r\nbegin\r\n // to avoid division by 0 and stupid value for a time delay\r\n // between two frames\r\n if Value = 0 then\r\n FFrameDelay := 1\r\n else\r\n FFrameDelay := Value;\r\nend;\r\n\r\n//=== { TJvPalette } =========================================================\r\n\r\nconstructor TJvPalette.Create;\r\nbegin\r\n inherited Create;\r\n FHWnd := 0;\r\nend;\r\n\r\nfunction TJvPalette.Load(FileName: string): Boolean;\r\nbegin\r\n Result := (FHWnd <> 0) and capPaletteOpen(FHWnd, PChar(FileName));\r\nend;\r\n\r\nfunction TJvPalette.Save(FileName: string): Boolean;\r\nbegin\r\n Result := (FHWnd <> 0) and capPaletteSave(FHWnd, PChar(FileName));\r\nend;\r\n\r\nfunction TJvPalette.PasteFromClipboard: Boolean;\r\nbegin\r\n Result := (FHWnd <> 0) and capPalettePaste(FHWnd);\r\nend;\r\n\r\nfunction TJvPalette.AutoCreate(nbFrames: Integer; nbColors: TJvPaletteNbColors): Boolean;\r\nbegin\r\n Result := (FHWnd <> 0) and capPaletteAuto(FHWnd, nbFrames, nbColors);\r\nend;\r\n\r\nfunction TJvPalette.ManuallyCreate(Flag: Boolean; nbColors: TJvPaletteNbColors): Boolean;\r\nbegin\r\n Result := (FHWnd <> 0) and capPaletteManual(FHWnd, Flag, nbColors);\r\nend;\r\n\r\n//=== { TJvAVICapture } ======================================================\r\n\r\nconstructor TJvAVICapture.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FScrollPos := TJvScrollPos.Create;\r\n // Not connected yet\r\n FDriverIndex := -1;\r\n FFileSizeAlloc := 0;\r\n FOverlaying := False;\r\n FPreviewing := False;\r\n FUsedEvents := [];\r\n FVideoLeft := 0;\r\n FVideoTop := 0;\r\n FDrivers := TStringList.Create;\r\n // Preview frame delay = 50ms between frames (20 frames per second)\r\n FPreviewFrameDelay := 50;\r\n FVideoFormat := TJvVideoFormat.Create;\r\n FAudioFormat := TJvAudioFormat.Create;\r\n // Default to PCM, 11.025khz 8 bit Mono\r\n with FAudioFormat do\r\n begin\r\n FormatTag := WAVE_FORMAT_PCM;\r\n Channels := 1;\r\n BitsPerSample := 8;\r\n SamplesPerSec := 11025;\r\n end;\r\n FCaptureSettings := TJvCaptureSettings.Create;\r\n FPalette := TJvPalette.Create;\r\n SetBounds(0, 0, 320, 240);\r\n EnumDrivers;\r\n // set all events to 'used'\r\n UsedEvents := [ueError, ueStatus, ueYield, ueFrame, ueVideoStream, ueWaveStream, ueCapControl];\r\nend;\r\n\r\ndestructor TJvAVICapture.Destroy;\r\nbegin\r\n Disconnect;\r\n FDrivers.Free;\r\n FCaptureSettings.Free;\r\n FAudioFormat.Free;\r\n FVideoFormat.Free;\r\n FPalette.Free;\r\n FScrollPos.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvAVICapture.CreateWindowHandle(const Params: TCreateParams);\r\nbegin\r\n // ensure the TWinControl is fully created first\r\n inherited CreateWindowHandle(Params);\r\n // no hint to show\r\n //ParentShowHint := False;\r\n //ShowHint := False;\r\n\r\n // create the AviCap window\r\n FHWnd := capCreateCaptureWindow(\r\n PChar(Title), // use the user defined title\r\n WS_VISIBLE or // window is visible\r\n WS_CHILD and // it is a child window\r\n not WS_CAPTION and // it has no caption\r\n not WS_BORDER, // it has no border\r\n 0, // 0 left coordinate\r\n 0, // 0 top coordinate\r\n 320, // width defaults to 320\r\n 240, // height defaults to 240\r\n inherited Handle, // child of the TWinControl\r\n 0); // window identifier\r\n\r\n // place the Pointer to Self in the user data\r\n SetWindowLongPtr(FHWnd, GWL_USERDATA, LONG_PTR(Self));\r\n // replace the WndProc to be ours\r\n FPreviousWndProc := Pointer(GetWindowLongPtr(FHWnd, GWL_WNDPROC));\r\n SetWindowLongPtr(FHWnd, GWL_WNDPROC, LONG_PTR(@CustomWndProc));\r\n // updates the FHWnd member of audio format, capture settings, palette and video format\r\n // yes, they are private members, but they can still be accessed by a foreign class\r\n // because the access is done in the same pas file !\r\n FAudioFormat.FHWnd := FHWnd;\r\n FCaptureSettings.FHWnd := FHWnd;\r\n FPalette.FHWnd := FHWnd;\r\n FVideoFormat.FHWnd := FHWnd;\r\n // sets the callbacks\r\n UsedEvents := FUsedEvents;\r\nend;\r\n\r\nprocedure TJvAVICapture.DestroyWindowHandle;\r\nbegin\r\n // restore the window proc\r\n SetWindowLongPtr(FHWnd, GWL_WNDPROC, LONG_PTR(FPreviousWndProc));\r\n // destroy the AviCap Window\r\n DestroyWindow(FHWnd);\r\n // let the TWinControl window be destroyed\r\n inherited DestroyWindowHandle;\r\nend;\r\n\r\nprocedure TJvAVICapture.SetTitle(nTitle: string);\r\nbegin\r\n if FHWnd <> 0 then\r\n begin\r\n FTitle := nTitle;\r\n SetWindowText(FHWnd, PChar(FTitle));\r\n end;\r\nend;\r\n\r\nprocedure TJvAVICapture.SetPreviewFrameDelay(nPreviewFrameDelay: Cardinal);\r\nbegin\r\n FPreviewFrameDelay := nPreviewFrameDelay;\r\n if Previewing then\r\n begin\r\n StopPreview;\r\n StartPreview;\r\n end;\r\nend;\r\n\r\nprocedure TJvAVICapture.SetPreviewFPS(nPreviewFPS: Double);\r\nbegin\r\n SetPreviewFrameDelay(Round(1.0E3 * 1.0 / nPreviewFPS));\r\nend;\r\n\r\nfunction TJvAVICapture.GetPreviewFPS: Double;\r\nbegin\r\n Result := 1.0E3 * 1.0 / FPreviewFrameDelay;\r\nend;\r\n\r\nprocedure TJvAVICapture.SetPreviewing(nPreviewing: Boolean);\r\nbegin\r\n if (not nPreviewing) and Previewing then\r\n StopPreview;\r\n if nPreviewing and (not Previewing) then\r\n StartPreview;\r\nend;\r\n\r\nprocedure TJvAVICapture.SetFileName(nFileName: TFileName);\r\nbegin\r\n if FHWnd <> 0 then\r\n begin\r\n FFileName := nFileName;\r\n // change the filename\r\n capFileSetCaptureFile(FHWnd, PChar(nFileName));\r\n end;\r\nend;\r\n\r\nfunction TJvAVICapture.GetFileName: TFileName;\r\nvar\r\n Name: array [0..MAX_PATH] of Char;\r\nbegin\r\n if FHWnd <> 0 then\r\n begin\r\n // get the filename from the window\r\n capFileGetCaptureFile(FHWnd, Name, SizeOf(Name));\r\n FFileName := Name;\r\n end;\r\n Result := FFileName;\r\nend;\r\n\r\nfunction TJvAVICapture.GetDrivers: TStrings;\r\nbegin\r\n Result := FDrivers;\r\nend;\r\n\r\nprocedure TJvAVICapture.SetFileSizeAlloc(nFileSizeAlloc: Cardinal);\r\nbegin\r\n if FHWnd <> 0 then\r\n begin\r\n FFileSizeAlloc := nFileSizeAlloc;\r\n capFileAlloc(FHWnd, FFileSizeAlloc);\r\n end;\r\nend;\r\n\r\nprocedure TJvAVICapture.SetUsedEvents(nUsedEvents: TJvUsedEvents);\r\nbegin\r\n FUsedEvents := nUsedEvents;\r\n\r\n if FHWnd <> 0 then\r\n begin\r\n if ueError in FUsedEvents then\r\n capSetCallbackOnError(FHWnd, @ErrorCallback)\r\n else\r\n capSetCallbackOnError(FHWnd, nil);\r\n\r\n if ueStatus in FUsedEvents then\r\n capSetCallbackOnStatus(FHWnd, @StatusCallback)\r\n else\r\n capSetCallbackOnStatus(FHWnd, nil);\r\n\r\n if ueYield in FUsedEvents then\r\n capSetCallbackOnYield(FHWnd, @YieldCallback)\r\n else\r\n capSetCallbackOnYield(FHWnd, nil);\r\n\r\n if ueFrame in FUsedEvents then\r\n capSetCallbackOnFrame(FHWnd, @FrameCallback)\r\n else\r\n capSetCallbackOnFrame(FHWnd, nil);\r\n\r\n if ueVideoStream in FUsedEvents then\r\n capSetCallbackOnVideoStream(FHWnd, @VideoStreamCallback)\r\n else\r\n capSetCallbackOnVideoStream(FHWnd, nil);\r\n\r\n if ueWaveStream in FUsedEvents then\r\n capSetCallbackOnWaveStream(FHWnd, @WaveStreamCallback)\r\n else\r\n capSetCallbackOnWaveStream(FHWnd, nil);\r\n\r\n if ueCapControl in FUsedEvents then\r\n capSetCallbackOnCapControl(FHWnd, @CapControlCallback)\r\n else\r\n capSetCallbackOnCapControl(FHWnd, nil);\r\n end;\r\nend;\r\n\r\nprocedure TJvAVICapture.SetOverlaying(nOverlaying: Boolean);\r\nbegin\r\n if not nOverlaying then\r\n begin\r\n if Overlaying then\r\n StopOverlay;\r\n end\r\n else\r\n if not Overlaying then\r\n StartOverlay;\r\nend;\r\n\r\nfunction TJvAVICapture.GetDriverName: string;\r\nvar\r\n Name: array [0..MAX_PATH] of Char;\r\nbegin\r\n if FHWnd <> 0 then\r\n begin\r\n capDriverGetName(FHWnd, Name, SizeOf(Name));\r\n Result := Name;\r\n end\r\n else\r\n Result := RsNotConnected;\r\nend;\r\n\r\nfunction TJvAVICapture.GetDriverVersion: string;\r\nvar\r\n Version: array [0..MAX_PATH] of Char;\r\nbegin\r\n if FHWnd <> 0 then\r\n begin\r\n capDriverGetVersion(FHWnd, Version, SizeOf(Version));\r\n Result := Version;\r\n end\r\n else\r\n Result := RsNotConnected;\r\nend;\r\n\r\nprocedure TJvAVICapture.SetScrollPos(nScrollPos: TJvScrollPos);\r\nvar\r\n TmpPoint: TPoint;\r\nbegin\r\n if FHWnd <> 0 then\r\n begin\r\n FScrollPos := nScrollPos;\r\n TmpPoint.X := FScrollPos.Left;\r\n TmpPoint.Y := FScrollPos.Top;\r\n capSetScrollPos(FHWnd, @TmpPoint);\r\n end;\r\nend;\r\n\r\nprocedure TJvAVICapture.SetMCIDevice(nMCIDevice: string);\r\nbegin\r\n if FHWnd <> 0 then\r\n capSetMCIDeviceName(FHWnd, PChar(nMCIDevice));\r\nend;\r\n\r\nfunction TJvAVICapture.GetMCIDevice: string;\r\nvar\r\n Name: array [0..MAX_PATH] of Char;\r\nbegin\r\n if FHWnd <> 0 then\r\n begin\r\n capGetMCIDeviceName(FHWnd, Name, SizeOf(Name));\r\n Result := Name;\r\n end\r\n else\r\n Result := RsNotConnected;\r\nend;\r\n\r\nprocedure TJvAVICapture.SetDriverIndex(nIndex: TJvDriverIndex);\r\nbegin\r\n if Connect(nIndex) then\r\n FDriverIndex := nIndex;\r\nend;\r\n\r\nprocedure TJvAVICapture.SetCapturing(nCapturing: Boolean);\r\nbegin\r\n if FCapturing then\r\n begin\r\n if not nCapturing then\r\n StopCapture;\r\n end\r\n else\r\n if nCapturing then\r\n if FNoFile then\r\n StartCaptureNoFile\r\n else\r\n StartCapture;\r\nend;\r\n\r\nprocedure TJvAVICapture.SetNoFile(nNoFile: Boolean);\r\nbegin\r\n // only allow to change if not capturing\r\n if not FCapturing then\r\n FNoFile := nNoFile;\r\nend;\r\n\r\nprocedure TJvAVICapture.UpdateCaps;\r\nvar\r\n Caps: TCAPDRIVERCAPS;\r\nbegin\r\n if FHWnd <> 0 then\r\n begin\r\n // get value from the window\r\n capDriverGetCaps(FHWnd, @Caps, SizeOf(Caps));\r\n // update internal value\r\n FDriverCaps := [];\r\n if Caps.fHasOverlay then\r\n FDriverCaps := FDriverCaps + [dcOverlay];\r\n if Caps.fHasDlgVideoSource then\r\n FDriverCaps := FDriverCaps + [dcDlgVideoSource];\r\n if Caps.fHasDlgVideoFormat then\r\n FDriverCaps := FDriverCaps + [dcDlgVideoFormat];\r\n if Caps.fHasDlgVideoDisplay then\r\n FDriverCaps := FDriverCaps + [dcDlgVideoDisplay];\r\n if Caps.fCaptureInitialized then\r\n FDriverCaps := FDriverCaps + [dcCaptureInitialized];\r\n if Caps.fDriverSuppliesPalettes then\r\n FDriverCaps := FDriverCaps + [dcSuppliesPalettes];\r\n end;\r\nend;\r\n\r\nprocedure TJvAVICapture.UpdateCaptureStatus;\r\nbegin\r\n if FHWnd <> 0 then\r\n begin\r\n capGetStatus(FHWnd, @FCaptureStatus, SizeOf(FCaptureStatus));\r\n FCapturing := FCaptureStatus.fCapturingNow;\r\n FPreviewing := FCaptureStatus.fLiveWindow;\r\n FOverlaying := FCaptureStatus.fOverlayWindow;\r\n end;\r\nend;\r\n\r\nprocedure TJvAVICapture.StopCallbacks;\r\nbegin\r\n if FHWnd <> 0 then\r\n begin\r\n if not (csDesigning in ComponentState) then\r\n capSetCallbackOnError(FHWnd, nil);\r\n\r\n capSetCallbackOnStatus(FHWnd, nil);\r\n capSetCallbackOnYield(FHWnd, nil);\r\n capSetCallbackOnFrame(FHWnd, nil);\r\n capSetCallbackOnVideoStream(FHWnd, nil);\r\n capSetCallbackOnWaveStream(FHWnd, nil);\r\n capSetCallbackOnCapControl(FHWnd, nil);\r\n end;\r\nend;\r\n\r\nprocedure TJvAVICapture.ResizeAviCapWindow(Width, Height: Integer);\r\nbegin\r\n MoveWindow(FHwnd, 0, 0, Width, Height, True);\r\nend;\r\n\r\nprocedure TJvAVICapture.RestartCallbacks;\r\nbegin\r\n UsedEvents := FUsedEvents;\r\nend;\r\n\r\nprocedure TJvAVICapture.SetBounds(nLeft, nTop, nWidth, nHeight: Integer);\r\nvar\r\n lWidth, lHeight: Integer;\r\nbegin\r\n // reload video size\r\n FVideoFormat.Update;\r\n\r\n // Force the width and height to stay in a constant interval :\r\n // not less than cMinHeight and cMinWidth\r\n // not more than the video size\r\n // Autosizing will have been enforced in the CanAutoSize procedure\r\n lHeight := Max(Min(nHeight, FVideoFormat.Height), cMinHeight);\r\n lWidth := Max(Min(nWidth, FVideoFormat.Width), cMinWidth);\r\n\r\n // If we changed the size here, force the resize of the internal window.\r\n if (lHeight <> nHeight) or (lWidth <> nWidth) then\r\n ResizeAviCapWindow(lWidth, lHeight);\r\n\r\n inherited SetBounds(nLeft, nTop, lWidth, lHeight);\r\nend;\r\n\r\nprocedure TJvAVICapture.EnumDrivers;\r\nvar\r\n I: Integer;\r\n DeviceName: array [0..MAX_PATH] of Char;\r\n DeviceVersion: array [0..MAX_PATH] of Char;\r\nbegin\r\n // no more than 10 drivers in the system (cf Win32 API)\r\n Drivers.Clear;\r\n for I := 0 to 9 do\r\n if capGetDriverDescription(I, DeviceName, SizeOf(DeviceName), DeviceVersion, SizeOf(DeviceVersion)) then\r\n Drivers.Add(DeviceName);\r\nend;\r\n\r\nfunction TJvAVICapture.Connect(Driver: TJvDriverIndex): Boolean;\r\nbegin\r\n // Request a handle, will create the AviCap internal window\r\n // will trigger an exception if no parent is set\r\n HandleNeeded;\r\n\r\n if Driver = -1 then\r\n begin\r\n // if Driver is -1, then we disconnect\r\n Result := Disconnect;\r\n // force the video format to be 0, 0 and update the size of the control\r\n FVideoFormat.FHeight := 0;\r\n FVideoFormat.FWidth := 0;\r\n end\r\n else\r\n begin\r\n // else we try to connect to that driver\r\n Result := capDriverConnect(FHWnd, Driver);\r\n FConnected := Result;\r\n\r\n if FConnected then\r\n begin\r\n // if connected successfully, update the property\r\n FDriverIndex := Driver;\r\n UpdateCaps;\r\n FCaptureSettings.Update;\r\n FAudioFormat.Update;\r\n UpdateCaptureStatus;\r\n end\r\n else\r\n // if not, trigger an exception\r\n raise EInvalidDriverIndexError.Create(Driver, Drivers.Count - 1);\r\n end;\r\n AdjustSize;\r\nend;\r\n\r\nfunction TJvAVICapture.Disconnect: Boolean;\r\nbegin\r\n Result := capDriverDisconnect(FHWnd);\r\n UpdateCaptureStatus;\r\n FConnected := False;\r\nend;\r\n\r\nfunction TJvAVICapture.ShowDialog(Dialog: TJvVideoDialog): Boolean;\r\nbegin\r\n Result := False;\r\n if FHWnd <> 0 then\r\n begin\r\n case Dialog of\r\n vdSource:\r\n Result := capDlgVideoSource(FHWnd);\r\n vdFormat:\r\n Result := capDlgVideoFormat(FHWnd);\r\n vdDisplay:\r\n Result := capDlgVideoDisplay(FHWnd);\r\n vdCompression:\r\n Result := capDlgVideoCompression(FHWnd);\r\n end;\r\n // update everything to reflect user changes\r\n UpdateCaps;\r\n VideoFormat.Update;\r\n AudioFormat.Update;\r\n CaptureSettings.Update;\r\n AdjustSize;\r\n end;\r\nend;\r\n\r\nfunction TJvAVICapture.StartPreview: Boolean;\r\nbegin\r\n // if we have a valid window that is not already previewing\r\n if (FHWnd <> 0) and not FPreviewing then\r\n begin\r\n capPreviewRate(FHWnd, FPreviewFrameDelay);\r\n FPreviewing := capPreview(FHWnd, True);\r\n UpdateCaptureStatus;\r\n VideoFormat.Update;\r\n if FPreviewing then\r\n begin\r\n FOverlaying := False;\r\n RestartCallbacks;\r\n end;\r\n Result := FPreviewing;\r\n end\r\n else\r\n Result := False;\r\nend;\r\n\r\nfunction TJvAVICapture.StopPreview: Boolean;\r\nbegin\r\n // if we have a valid window doing previewing\r\n // then the result is the result of capPreview\r\n Result := (FHWnd <> 0) and FPreviewing and capPreview(FHWnd, False);\r\n\r\n // if succesfully stopped preview, update internal values\r\n if Result then\r\n begin\r\n UpdateCaptureStatus;\r\n FPreviewing := False;\r\n StopCallbacks;\r\n end;\r\nend;\r\n\r\nfunction TJvAVICapture.StartCapture: Boolean;\r\nbegin\r\n if (FHWnd <> 0) and not FCapturing and ApplyCaptureSettings and\r\n ApplyAudioFormat then\r\n begin\r\n UpdateCaptureStatus;\r\n VideoFormat.Update;\r\n FCapturing := capCaptureSequence(FHWnd);\r\n if FCapturing then\r\n RestartCallbacks;\r\n Result := FCapturing;\r\n end\r\n else\r\n Result := False;\r\nend;\r\n\r\nfunction TJvAVICapture.StartCaptureNoFile: Boolean;\r\nbegin\r\n if (FHWnd <> 0) and not FCapturing and ApplyCaptureSettings and\r\n ApplyAudioFormat then\r\n begin\r\n UpdateCaptureStatus;\r\n VideoFormat.Update;\r\n FCapturing := capCaptureSequenceNoFile(FHWnd);\r\n FNoFile := True;\r\n if FCapturing then\r\n RestartCallbacks;\r\n Result := FCapturing;\r\n end\r\n else\r\n Result := False;\r\nend;\r\n\r\nfunction TJvAVICapture.StopCapture: Boolean;\r\nbegin\r\n Result := (FHWnd <> 0) and FCapturing and capCaptureStop(FHWnd);\r\n if Result then\r\n begin\r\n FCapturing := False;\r\n StopCallbacks;\r\n end;\r\nend;\r\n\r\nfunction TJvAVICapture.AbortCapture: Boolean;\r\nbegin\r\n Result := (FHWnd <> 0) and FCapturing and capCaptureAbort(FHWnd);\r\n if Result then\r\n begin\r\n FCapturing := False;\r\n StopCallbacks;\r\n end;\r\nend;\r\n\r\nfunction TJvAVICapture.StartSingleFrameCapture: Boolean;\r\nbegin\r\n Result := (FHWnd <> 0) and not FSingleFrameCapturing and\r\n capCaptureSingleFrameOpen(FHWnd);\r\n if Result then\r\n begin\r\n UpdateCaptureStatus;\r\n VideoFormat.Update;\r\n RestartCallbacks;\r\n FSingleFrameCapturing := True;\r\n end;\r\nend;\r\n\r\nfunction TJvAVICapture.CaptureFrame: Boolean;\r\nbegin\r\n Result := (FHWnd <> 0) and FSingleFrameCapturing and\r\n capCaptureSingleFrame(FHWnd);\r\n UpdateCaptureStatus;\r\n VideoFormat.Update;\r\nend;\r\n\r\nfunction TJvAVICapture.StopSingleFrameCapture: Boolean;\r\nbegin\r\n Result := (FHWnd <> 0) and FSingleFrameCapturing and\r\n capCaptureSingleFrameClose(FHWnd);\r\n if Result then\r\n begin\r\n UpdateCaptureStatus;\r\n VideoFormat.Update;\r\n StopCallbacks;\r\n FSingleFrameCapturing := False;\r\n end;\r\nend;\r\n\r\nfunction TJvAVICapture.StartOverlay: Boolean;\r\nbegin\r\n if (FHWnd <> 0) and not FOverlaying then\r\n begin\r\n capPreviewRate(FHWnd, FPreviewFrameDelay);\r\n FOverlaying := capOverlay(FHWnd, True);\r\n UpdateCaptureStatus;\r\n VideoFormat.Update;\r\n if FOverlaying then\r\n begin\r\n FPreviewing := False;\r\n RestartCallbacks;\r\n end;\r\n Result := FOverlaying;\r\n end\r\n else\r\n Result := False;\r\nend;\r\n\r\nfunction TJvAVICapture.StopOverlay: Boolean;\r\nbegin\r\n Result := (FHWnd <> 0) and FOverlaying and capOverlay(FHWnd, False);\r\n if Result then\r\n begin\r\n UpdateCaptureStatus;\r\n FOverlaying := False;\r\n StopCallbacks;\r\n end;\r\nend;\r\n\r\nfunction TJvAVICapture.ApplyCaptureSettings: Boolean;\r\nbegin\r\n Result := CaptureSettings.Apply;\r\nend;\r\n\r\nfunction TJvAVICapture.ApplyAudioFormat: Boolean;\r\nbegin\r\n Result := AudioFormat.Apply;\r\nend;\r\n\r\nfunction TJvAVICapture.SaveAs(Name: string): Boolean;\r\nbegin\r\n Result := (FHWnd <> 0) and capFileSaveAs(FHWnd, PChar(Name));\r\nend;\r\n\r\nfunction TJvAVICapture.SetInfoChunk(const Chunk: TCAPINFOCHUNK): Boolean;\r\nbegin\r\n Result := (FHWnd <> 0) and capFileSetInfoChunk(FHWnd, @Chunk);\r\nend;\r\n\r\nfunction TJvAVICapture.SaveDIB(Name: string): Boolean;\r\nbegin\r\n Result := (FHWnd <> 0) and capFileSaveDIB(FHWnd, PChar(Name));\r\nend;\r\n\r\nfunction TJvAVICapture.CopyToClipboard: Boolean;\r\nbegin\r\n Result := (FHWnd <> 0) and capEditCopy(FHWnd);\r\nend;\r\n\r\nfunction TJvAVICapture.GrabFrame(Stop: Boolean): Boolean;\r\nbegin\r\n Result := False;\r\n if FHWnd <> 0 then\r\n if Stop then\r\n begin\r\n FPreviewing := False;\r\n FOverlaying := False;\r\n Result := capGrabFrame(FHWnd);\r\n end\r\n else\r\n Result := capGrabFrameNoStop(FHWnd);\r\nend;\r\n\r\nprocedure TJvAVICapture.DoError(ErrId: Integer; Str: string);\r\nbegin\r\n if csDesigning in ComponentState then\r\n Windows.MessageBox(WindowHandle, PChar(Str), PChar(RsErrorMessagePrefix + IntToStr(ErrId)), MB_ICONERROR);\r\n if Assigned(FOnError) then\r\n FOnError(Self, ErrId, Str);\r\nend;\r\n\r\nprocedure TJvAVICapture.DoStatus(nId: Integer; Str: string);\r\nbegin\r\n UpdateCaptureStatus;\r\n if Assigned(FOnStatus) then\r\n FOnStatus(Self, nId, Str);\r\nend;\r\n\r\nprocedure TJvAVICapture.DoYield;\r\nbegin\r\n UpdateCaptureStatus;\r\n if Assigned(FOnYield) then\r\n FOnYield(Self);\r\nend;\r\n\r\nprocedure TJvAVICapture.DoFrame(videoHdr: PVIDEOHDR);\r\nbegin\r\n if Assigned(FOnFrame) then\r\n FOnFrame(Self, videoHdr);\r\nend;\r\n\r\nprocedure TJvAVICapture.DoVideoStream(videoHdr: PVIDEOHDR);\r\nbegin\r\n if Assigned(FOnVideoStream) then\r\n FOnVideoStream(Self, videoHdr);\r\nend;\r\n\r\nprocedure TJvAVICapture.DoWaveStream(waveHdr: PWaveHdr);\r\nbegin\r\n if Assigned(FOnWaveStream) then\r\n FOnWaveStream(Self, waveHdr);\r\nend;\r\n\r\nprocedure TJvAVICapture.DoCapControl(nState: Integer; var AResult: Boolean);\r\nbegin\r\n AResult := True;\r\n if Assigned(FOnCapControl) then\r\n FOnCapControl(Self, nState, AResult);\r\nend;\r\n\r\nprocedure TJvAVICapture.SetVideoLeft(const Value: Integer);\r\nvar\r\n P: TPoint;\r\nbegin\r\n P.X := Value;\r\n P.Y := VideoTop;\r\n if capSetScrollPos(FHWnd, @P) then\r\n FVideoLeft := Value;\r\nend;\r\n\r\nprocedure TJvAVICapture.SetVideoTop(const Value: Integer);\r\nvar\r\n P: TPoint;\r\nbegin\r\n P.X := VideoLeft;\r\n P.Y := Value;\r\n if capSetScrollPos(FHWnd, @P) then\r\n FVideoTop := Value;\r\nend;\r\n\r\nfunction TJvAVICapture.CanAutoSize(var NewWidth, NewHeight: Integer): Boolean;\r\nbegin\r\n // always possible to do autosizing\r\n Result := True;\r\n\r\n // reload video size\r\n FVideoFormat.Update;\r\n\r\n // force the width and height to be equal\r\n // to the one from the video (with a minimum value set\r\n // in case there is no video yet)\r\n NewHeight := Max(cMinHeight, FVideoFormat.Height);\r\n NewWidth := Max(cMinWidth, FVideoFormat.Width);\r\n\r\n // We must call ResizeAviCapWindow here as well as in SetBounds because\r\n // CanAutoSize might be call without a call to SetBounds.\r\n ResizeAviCapWindow(NewWidth, NewHeight);\r\nend;\r\n\r\nprocedure TJvAVICapture.SetSingleFrameCapturing(const Value: Boolean);\r\nbegin\r\n if Value then\r\n StartSingleFrameCapture\r\n else\r\n StopSingleFrameCapture;\r\nend;\r\n\r\n//=== EInvalidDriverIndexError ===============================================\r\n\r\nconstructor EInvalidDriverIndexError.Create(Index: TJvDriverIndex; MaxIndex: TJvDriverIndex);\r\nbegin\r\n inherited CreateResFmt(@RsEInvalidDriverIndex, [Index, MaxIndex]);\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvActions.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvActions.Pas, released on 2002-10-04.\r\n\r\nThe Initial Developer of the Original Code is Sbastien Buysse [sbuysse att buypin dott com]\r\nPortions created by Sbastien Buysse are Copyright (C) 2002 Sbastien Buysse.\r\nAll Rights Reserved.\r\n\r\nContributor(s): -\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvActions.pas 12461 2009-08-14 17:21:33Z obones $\r\n\r\nunit JvActions;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n {$IFDEF MSWINDOWS}\r\n JclMapi,\r\n JclAnsiStrings,\r\n Windows, ShellAPI,\r\n {$ENDIF MSWINDOWS}\r\n ActnList,\r\n {$IFDEF UNIX}\r\n QWindows,\r\n {$ENDIF UNIX}\r\n Classes;\r\n\r\ntype\r\n {$IFDEF MSWINDOWS}\r\n\r\n TJvSendMailOptions = class(TPersistent)\r\n private\r\n FMailer: TJclEmail;\r\n FShowDialogs: Boolean;\r\n function GetAttachments: TAnsiStrings;\r\n function GetBody: string;\r\n function GetFindOptions: TJclEmailFindOptions;\r\n function GetHtmlBody: Boolean;\r\n function GetLogonOptions: TJclEmailLogonOptions;\r\n function GetReadMsg: TJclEmailReadMsg;\r\n function GetSubject: string;\r\n function GetUserLogged: Boolean;\r\n procedure SetAttachments(const Value: TAnsiStrings);\r\n procedure SetBody(const Value: string);\r\n procedure SetFindOptions(const Value: TJclEmailFindOptions);\r\n procedure SetHtmlBody(const Value: Boolean);\r\n procedure SetLogonOptions(const Value: TJclEmailLogonOptions);\r\n procedure SetSubject(const Value: string);\r\n function GetRecipients: string;\r\n procedure SetRecipients(const Value: string);\r\n public\r\n constructor Create;\r\n destructor Destroy; override;\r\n function Execute: Boolean;\r\n property Mailer: TJclEmail read FMailer write FMailer;\r\n published\r\n property Attachments: TAnsiStrings read GetAttachments write SetAttachments;\r\n property Body: string read GetBody write SetBody;\r\n property FindOptions: TJclEmailFindOptions read GetFindOptions write SetFindOptions;\r\n property HtmlBody: Boolean read GetHtmlBody write SetHtmlBody;\r\n property LogonOptions: TJclEmailLogonOptions read GetLogonOptions write SetLogonOptions;\r\n property ReadMsg: TJclEmailReadMsg read GetReadMsg;\r\n property Recipients: string read GetRecipients write SetRecipients;\r\n property ShowDialogs: Boolean read FShowDialogs write FShowDialogs default True;\r\n property Subject: string read GetSubject write SetSubject;\r\n property UserLogged: Boolean read GetUserLogged;\r\n end;\r\n\r\n TJvSendMailAction = class(TAction)\r\n private\r\n FMailOptions: TJvSendMailOptions;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n function Execute: Boolean; override;\r\n published\r\n property MailOptions: TJvSendMailOptions read FMailOptions write FMailOptions;\r\n end;\r\n\r\n {$ENDIF MSWINDOWS}\r\n\r\n TJvWebAction = class(TAction)\r\n private\r\n FURL: string;\r\n public\r\n function HandlesTarget(Target: TObject): Boolean; override;\r\n procedure UpdateTarget(Target: TObject); override;\r\n function Execute: Boolean; override;\r\n published\r\n property URL: string read FURL write FURL;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvActions.pas $';\r\n Revision: '$Revision: 12461 $';\r\n Date: '$Date: 2009-08-14 19:21:33 +0200 (ven. 14 août 2009) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\n\r\n{$IFDEF MSWINDOWS}\r\n\r\n//=== { TJvSendMailAction } ==================================================\r\n\r\nconstructor TJvSendMailAction.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n DisableIfNoHandler := False;\r\n FMailOptions := TJvSendMailOptions.Create;\r\nend;\r\n\r\ndestructor TJvSendMailAction.Destroy;\r\nbegin\r\n FMailOptions.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJvSendMailAction.Execute: Boolean;\r\nbegin\r\n Result := MailOptions.Execute;\r\nend;\r\n\r\n//=== { TJvSendMailOptions } =================================================\r\n\r\nconstructor TJvSendMailOptions.Create;\r\nbegin\r\n inherited Create;\r\n FShowDialogs := True;\r\n FMailer := TJclEmail.Create;\r\nend;\r\n\r\ndestructor TJvSendMailOptions.Destroy;\r\nbegin\r\n FMailer.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJvSendMailOptions.Execute: Boolean;\r\nbegin\r\n Result := Mailer.Send(ShowDialogs);\r\nend;\r\n\r\nfunction TJvSendMailOptions.GetAttachments: TAnsiStrings;\r\nbegin\r\n Result := Mailer.Attachments;\r\nend;\r\n\r\nfunction TJvSendMailOptions.GetBody: string;\r\nbegin\r\n Result := string(Mailer.Body);\r\nend;\r\n\r\nfunction TJvSendMailOptions.GetFindOptions: TJclEmailFindOptions;\r\nbegin\r\n Result := Mailer.FindOptions;\r\nend;\r\n\r\nfunction TJvSendMailOptions.GetHtmlBody: Boolean;\r\nbegin\r\n Result := Mailer.HtmlBody;\r\nend;\r\n\r\nfunction TJvSendMailOptions.GetLogonOptions: TJclEmailLogonOptions;\r\nbegin\r\n Result := Mailer.LogonOptions;\r\nend;\r\n\r\nfunction TJvSendMailOptions.GetReadMsg: TJclEmailReadMsg;\r\nbegin\r\n Result := Mailer.ReadMsg;\r\nend;\r\n\r\nfunction TJvSendMailOptions.GetRecipients: string;\r\nbegin\r\n if Mailer.Recipients.Count = 0 then\r\n Result := ''\r\n else\r\n Result := string(Mailer.Recipients.Items[0].Address);\r\nend;\r\n\r\nfunction TJvSendMailOptions.GetSubject: string;\r\nbegin\r\n Result := string(Mailer.Subject);\r\nend;\r\n\r\nfunction TJvSendMailOptions.GetUserLogged: Boolean;\r\nbegin\r\n Result := Mailer.UserLogged;\r\nend;\r\n\r\nprocedure TJvSendMailOptions.SetAttachments(const Value: TAnsiStrings);\r\nbegin\r\n Mailer.Attachments.Assign(Value);\r\nend;\r\n\r\nprocedure TJvSendMailOptions.SetBody(const Value: string);\r\nbegin\r\n Mailer.Body := AnsiString(Value); // we know we might lose values here, but MAPI has always been ANSI anyway\r\nend;\r\n\r\nprocedure TJvSendMailOptions.SetFindOptions(const Value: TJclEmailFindOptions);\r\nbegin\r\n Mailer.FindOptions := Value;\r\nend;\r\n\r\nprocedure TJvSendMailOptions.SetHtmlBody(const Value: Boolean);\r\nbegin\r\n Mailer.HtmlBody := Value;\r\nend;\r\n\r\nprocedure TJvSendMailOptions.SetLogonOptions(const Value: TJclEmailLogonOptions);\r\nbegin\r\n Mailer.LogonOptions := Value;\r\nend;\r\n\r\nprocedure TJvSendMailOptions.SetRecipients(const Value: string);\r\nbegin\r\n Mailer.Recipients.Clear;\r\n Mailer.Recipients.Add(AnsiString(Value)); // we know we might lose values here, but MAPI has always been ANSI anyway\r\nend;\r\n\r\nprocedure TJvSendMailOptions.SetSubject(const Value: string);\r\nbegin\r\n Mailer.Subject := AnsiString(Value); // we know we might lose values here, but MAPI has always been ANSI anyway\r\nend;\r\n\r\n{$ENDIF MSWINDOWS}\r\n\r\n//=== { TJvWebAction } =======================================================\r\n\r\nfunction TJvWebAction.Execute: Boolean;\r\nbegin\r\n Result := ShellExecute(0, 'open', PChar(URL), nil, nil, SW_SHOWNORMAL) > HINSTANCE_ERROR;\r\nend;\r\n\r\nfunction TJvWebAction.HandlesTarget(Target: TObject): Boolean;\r\nbegin\r\n Result := True;\r\nend;\r\n\r\nprocedure TJvWebAction.UpdateTarget(Target: TObject);\r\nbegin\r\n Enabled := URL <> '';\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvActionsEngine.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvActionsEngine.Pas, released on 2007-03-12.\r\n\r\nThe Initial Developer of the Original Code is Jens Fudickar [jens dott fudicker att oratool dott de]\r\nPortions created by Jens Fudickar are Copyright (C) 2007 Jens Fudickar.\r\nAll Rights Reserved.\r\n\r\nContributor(s): -\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvActionsEngine.pas 13415 2012-09-10 09:51:54Z obones $\r\n\r\nunit JvActionsEngine;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n {$IFDEF MSWINDOWS}\r\n Windows, ActnList, Graphics, ImgList,\r\n {$ENDIF MSWINDOWS}\r\n {$IFDEF HAS_UNIT_SYSTEM_UITYPES}\r\n System.UITypes,\r\n {$ENDIF HAS_UNIT_SYSTEM_UITYPES}\r\n Controls, Classes;\r\n\r\ntype\r\n TJvActionEngineBaseAction = class;\r\n\r\n TJvChangeActionComponent = procedure(ActionComponent: TComponent) of object;\r\n\r\n TJvActionBaseEngine = class(TComponent)\r\n private\r\n protected\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n function SupportsComponent(AComponent: TComponent): Boolean; virtual;\r\n function SupportsAction(AAction: TJvActionEngineBaseAction): Boolean; virtual;\r\n published\r\n end;\r\n\r\n TJvActionBaseEngineClass = class of TJvActionBaseEngine;\r\n\r\n TJvActionEngineList = class(TList)\r\n private\r\n function GetEngine(Index: Integer): TJvActionBaseEngine;\r\n public\r\n destructor Destroy; override;\r\n procedure RegisterEngine(AEngineClass: TJvActionBaseEngineClass);\r\n function GetControlEngine(AComponent: TComponent; AAction: TJvActionEngineBaseAction): TJvActionBaseEngine; virtual;\r\n function Supports(AComponent: TComponent; AAction: TJvActionEngineBaseAction = nil): Boolean;\r\n property Engine[Index: Integer]: TJvActionBaseEngine read GetEngine;\r\n end;\r\n\r\n TJvActionEngineBaseAction = class(TAction)\r\n private\r\n FActionComponent: TComponent;\r\n FControlEngine: TJvActionBaseEngine;\r\n FLastTarget: TComponent;\r\n FOnChangeActionComponent: TJvChangeActionComponent;\r\n protected\r\n //1 This Procedure is called when the ActionComponent is changed\r\n procedure ChangeActionComponent(const AActionComponent: TComponent); virtual;\r\n procedure CheckChecked(var AChecked: Boolean); virtual;\r\n procedure CheckEnabled(var AEnabled: Boolean); virtual;\r\n procedure CheckVisible(var AVisible: Boolean); virtual;\r\n function DetectControlEngine(aActionComponent: TComponent): Boolean; virtual;\r\n function GetEngineList: TJvActionEngineList; virtual; abstract;\r\n procedure Notification(AComponent: TComponent; Operation: TOperation); override;\r\n procedure SetActionComponent(const Value: TComponent); virtual;\r\n property ControlEngine: TJvActionBaseEngine read FControlEngine;\r\n property EngineList: TJvActionEngineList read GetEngineList;\r\n property LastTarget: TComponent read FLastTarget;\r\n //1 Use this event to check the Enabled Flag depending on properties of the ActionComponent\r\n property OnChangeActionComponent: TJvChangeActionComponent read FOnChangeActionComponent write FOnChangeActionComponent;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n function HandlesTarget(Target: TObject): Boolean; override;\r\n procedure SetChecked(Value: Boolean); {$IFDEF RTL240_UP}override;{$ENDIF RTL240_UP}\r\n procedure SetEnabled(Value: Boolean); {$IFDEF RTL240_UP}override;{$ENDIF RTL240_UP}\r\n procedure SetImageIndex(Value: TImageIndex); {$IFDEF RTL240_UP}override;{$ENDIF RTL240_UP}\r\n procedure SetParentComponent(AParent: TComponent); override;\r\n procedure SetVisible(Value: Boolean); {$IFDEF RTL240_UP}override;{$ENDIF RTL240_UP}\r\n procedure UpdateTarget(Target: TObject); override;\r\n property ActionComponent: TComponent read FActionComponent write SetActionComponent;\r\n end;\r\n\r\ntype\r\n TJvActionBaseActionList = class(TActionList)\r\n //The idea of the Action Classes is to work different type of controls.\r\n //\r\n //Then we have a list of ActionEngines which have the availability to\r\n //validate find for a Component if it is supported or not.\r\n //For each new type of controls with specific need of handles a new Engine\r\n //must be created and registered. An example for these engines can be found\r\n //in \"JvDBActionsEngineControlCxGrid.pas\".\r\n //\r\n //When a ActionComponent is assigned the action tries to find the correct\r\n //engine based on the component and uses the engine for all further operations.\r\n //\r\n //There are two ways to assign a ActionComponent:\r\n //1. Assigning the component to the action list, then all actions in\r\n // this list (which are based on TJvActionEngineBaseAction class)\r\n // gets the ActionComponent assigned also.\r\n //2. Using the active control, like the normal action handling.\r\n private\r\n FActionComponent: TComponent;\r\n FOnChangeActionComponent: TJvChangeActionComponent;\r\n protected\r\n procedure SetActionComponent(Value: TComponent);\r\n property ActionComponent: TComponent read FActionComponent write SetActionComponent;\r\n property OnChangeActionComponent: TJvChangeActionComponent read FOnChangeActionComponent write FOnChangeActionComponent;\r\n public\r\n procedure Notification(AComponent: TComponent; Operation: TOperation); override;\r\n end;\r\n\r\n {$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile:\r\n '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvActionsEngine.pas $';\r\n Revision: '$Revision: 13415 $';\r\n Date: '$Date: 2012-09-10 11:51:54 +0200 (lun. 10 sept. 2012) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n {$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n SysUtils, Variants,\r\n JvJVCLUtils;\r\n\r\n//=== { TJvActionEngineList } ========================================\r\n\r\ndestructor TJvActionEngineList.Destroy;\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := Count - 1 downto 0 do\r\n begin\r\n TJvActionBaseEngine(Items[I]).Free;\r\n Items[I] := nil;\r\n Delete(I);\r\n end;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvActionEngineList.RegisterEngine(AEngineClass: TJvActionBaseEngineClass);\r\nbegin\r\n Add(AEngineClass.Create(nil));\r\nend;\r\n\r\nfunction TJvActionEngineList.GetControlEngine(AComponent: TComponent; AAction: TJvActionEngineBaseAction):\r\n TJvActionBaseEngine;\r\nvar\r\n Ind: Integer;\r\nbegin\r\n Result := nil;\r\n for Ind := 0 to Count - 1 do\r\n if Engine[Ind].SupportsComponent(AComponent) then\r\n if not Assigned(AAction) or Engine[Ind].SupportsAction(AAction) then\r\n begin\r\n Result := TJvActionBaseEngine(Items[Ind]);\r\n Break;\r\n end;\r\nend;\r\n\r\nfunction TJvActionEngineList.GetEngine(Index: Integer): TJvActionBaseEngine;\r\nbegin\r\n Result := TJvActionBaseEngine(Items[Index]);\r\nend;\r\n\r\nfunction TJvActionEngineList.Supports(AComponent: TComponent; AAction: TJvActionEngineBaseAction = nil): Boolean;\r\nbegin\r\n Result := Assigned(GetControlEngine(AComponent, AAction));\r\nend;\r\n\r\nconstructor TJvActionBaseEngine.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\nend;\r\n\r\nfunction TJvActionBaseEngine.SupportsComponent(AComponent: TComponent): Boolean;\r\nbegin\r\n Result := False;\r\nend;\r\n\r\nfunction TJvActionBaseEngine.SupportsAction(AAction: TJvActionEngineBaseAction): Boolean;\r\nbegin\r\n Result := False;\r\nend;\r\n\r\nconstructor TJvActionEngineBaseAction.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FLastTarget := nil;\r\n FControlEngine := nil;\r\n if Assigned(AOwner) and (AOwner is TJvActionBaseActionList) then\r\n ActionComponent := TJvActionBaseActionList(AOwner).ActionComponent\r\n else\r\n FActionComponent := nil;\r\nend;\r\n\r\nprocedure TJvActionEngineBaseAction.ChangeActionComponent(const\r\n AActionComponent: TComponent);\r\nbegin\r\n if Assigned(OnChangeActionComponent) then\r\n OnChangeActionComponent(AActionComponent);\r\nend;\r\n\r\nprocedure TJvActionEngineBaseAction.CheckChecked(var AChecked: Boolean);\r\nbegin\r\nend;\r\n\r\nprocedure TJvActionEngineBaseAction.CheckEnabled(var AEnabled: Boolean);\r\nbegin\r\nend;\r\n\r\nprocedure TJvActionEngineBaseAction.CheckVisible(var AVisible: Boolean);\r\nbegin\r\nend;\r\n\r\nfunction TJvActionEngineBaseAction.DetectControlEngine(aActionComponent:\r\n TComponent): Boolean;\r\nbegin\r\n if Assigned(EngineList) and Assigned(aActionComponent) then\r\n FControlEngine := EngineList.GetControlEngine(aActionComponent, self)\r\n else\r\n FControlEngine := nil;\r\n Result := Assigned(FControlEngine);\r\nend;\r\n\r\nfunction TJvActionEngineBaseAction.HandlesTarget(Target: TObject): Boolean;\r\nbegin\r\n if Target is TComponent then\r\n begin\r\n ActionComponent := TComponent(Target);\r\n Result := Assigned(ControlEngine);\r\n end\r\n else\r\n Result := False;\r\nend;\r\n\r\nprocedure TJvActionEngineBaseAction.Notification(AComponent: TComponent;\r\n Operation: TOperation);\r\nbegin\r\n inherited Notification(AComponent, Operation);\r\n if (Operation = opRemove) and (AComponent = FActionComponent) then\r\n ActionComponent := nil;\r\nend;\r\n\r\n//=== { TJvActionEngineBaseAction } ========================================\r\n\r\nprocedure TJvActionEngineBaseAction.SetActionComponent(const Value: TComponent);\r\nvar\r\n intValue: TComponent;\r\n changed: Boolean;\r\nbegin\r\n if FLastTarget <> Value then\r\n begin\r\n FLastTarget := Value;\r\n if DetectControlEngine(Value) then\r\n intValue := Value\r\n else\r\n intValue := nil;\r\n Changed := FActionComponent <> intValue;\r\n ReplaceComponentReference(Self, intValue, FActionComponent);\r\n if changed then\r\n ChangeActionComponent(FActionComponent);\r\n end;\r\nend;\r\n\r\nprocedure TJvActionEngineBaseAction.SetChecked(Value: Boolean);\r\nbegin\r\n CheckChecked (Value);\r\n if Checked <> Value then\r\n {$IFDEF RTL240_UP}\r\n inherited SetChecked (Value);\r\n {$ELSE}\r\n Checked := Value;\r\n {$ENDIF RTL240_UP}\r\nend;\r\n\r\nprocedure TJvActionEngineBaseAction.SetEnabled(Value: Boolean);\r\nbegin\r\n CheckEnabled (Value);\r\n if Enabled <> Value then\r\n {$IFDEF RTL240_UP}\r\n inherited SetEnabled (Value);\r\n {$ELSE}\r\n Enabled := Value;\r\n {$ENDIF RTL240_UP}\r\nend;\r\n\r\nprocedure TJvActionEngineBaseAction.SetImageIndex(Value: TImageIndex);\r\nbegin\r\n if ImageIndex <> Value then\r\n {$IFDEF RTL240_UP}\r\n inherited SetImageIndex (Value);\r\n {$ELSE}\r\n ImageIndex := Value;\r\n {$ENDIF RTL240_UP}\r\nend;\r\n\r\nprocedure TJvActionEngineBaseAction.SetParentComponent(AParent: TComponent);\r\nbegin\r\n Inherited SetParentComponent(AParent);\r\n if AParent is TJvActionBaseActionList then\r\n ActionComponent := TJvActionBaseActionList(AParent).ActionComponent;\r\nend;\r\n\r\nprocedure TJvActionEngineBaseAction.SetVisible(Value: Boolean);\r\nbegin\r\n CheckVisible(Value);\r\n if Visible <> Value then\r\n {$IFDEF RTL240_UP}\r\n inherited SetVisible (Value);\r\n {$ELSE}\r\n Visible := Value;\r\n {$ENDIF RTL240_UP}\r\nend;\r\n\r\nprocedure TJvActionEngineBaseAction.UpdateTarget(Target: TObject);\r\nbegin\r\n if Assigned(ControlEngine) then\r\n ControlEngine.UpdateAction(self)\r\n else\r\n inherited UpdateTarget(Target);\r\nend;\r\n\r\n//=== { TJvDatabaseActionList } ==============================================\r\n\r\nprocedure TJvActionBaseActionList.SetActionComponent(Value: TComponent);\r\nvar\r\n I: Integer;\r\nbegin\r\n if ReplaceComponentReference(Self, Value, FActionComponent) then\r\n begin\r\n for I := 0 to ActionCount - 1 do\r\n if Actions[I] is TJvActionEngineBaseAction then\r\n TJvActionEngineBaseAction(Actions[I]).ActionComponent := Value;\r\n if Assigned(OnChangeActionComponent) then\r\n OnChangeActionComponent(Value);\r\n end;\r\nend;\r\n\r\nprocedure TJvActionBaseActionList.Notification(AComponent: TComponent; Operation: TOperation);\r\nbegin\r\n inherited Notification(AComponent, Operation);\r\n if Operation = opRemove then\r\n if AComponent = FActionComponent then\r\n ActionComponent := nil;\r\nend;\r\n\r\n\r\ninitialization\r\n {$IFDEF UNITVERSIONING}\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n {$ENDIF UNITVERSIONING}\r\n\r\nfinalization\r\n {$IFDEF UNITVERSIONING}\r\n UnregisterUnitVersion(HInstance);\r\n {$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvAddPrinter.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvAddPrinter.PAS, released on 2001-02-28.\r\n\r\nThe Initial Developer of the Original Code is Sbastien Buysse [sbuysse att buypin dott com]\r\nPortions created by Sbastien Buysse are Copyright (C) 2001 Sbastien Buysse.\r\nAll Rights Reserved.\r\n\r\nContributor(s): Michael Beck [mbeck att bigfoot dott com].\r\n Serhiy Perevoznyk [serge_perevoznyk att hotmail dott com]\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvAddPrinter.pas 13352 2012-06-14 09:21:26Z obones $\r\n\r\nunit JvAddPrinter;\r\n\r\n{$I jvcl.inc}\r\n{$I windowsonly.inc}\r\n\r\ninterface\r\n\r\nuses\r\n Windows, Classes,\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n JvBaseDlg;\r\n\r\ntype\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvAddPrinterDialog = class(TJvCommonDialog)\r\n public\r\n function Execute(ParentWnd: HWND): Boolean; overload; override;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvAddPrinter.pas $';\r\n Revision: '$Revision: 13352 $';\r\n Date: '$Date: 2012-06-14 11:21:26 +0200 (jeu. 14 juin 2012) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n ActiveX, ShlObj, ShellAPI, SysUtils;\r\n\r\n// (rom) move to JCL\r\n\r\nfunction ItemIDListCreate(const Allocator: IMalloc; const Size: Integer): PItemIDList;\r\nbegin\r\n Result := Allocator.Alloc(Size);\r\n if Result <> nil then\r\n FillChar(Result^, Size, 0);\r\nend;\r\n\r\nfunction ItemIDListGetNextItem(const ItemIDList: PItemIDList): PItemIDList;\r\nbegin\r\n if ItemIDList = nil then\r\n Result := nil\r\n else\r\n Result := PItemIDList(Cardinal(ItemIDList) + ItemIDList.mkid.cb);\r\nend;\r\n\r\nfunction ItemIDListGetSize(const ItemIDList: PItemIDList): Cardinal;\r\nvar\r\n TempItemIDList: PItemIDList;\r\nbegin\r\n Result := 0;\r\n TempItemIDList := ItemIDList;\r\n if TempItemIDList <> nil then\r\n begin\r\n while TempItemIDList.mkid.cb > 0 do\r\n begin\r\n Inc(Result, TempItemIDList.mkid.cb);\r\n TempItemIDList := ItemIDListGetNextItem(TempItemIDList);\r\n end;\r\n Inc(Result, 2 * SizeOf(Byte));\r\n end;\r\nend;\r\n\r\nfunction ItemIDListsConcatenate(const Allocator: IMalloc; const List1, List2: PItemIDList): PItemIDList;\r\nvar\r\n List1Length: Cardinal;\r\n List2Length: Cardinal;\r\n NewItemIDList: PItemIDList;\r\nbegin\r\n List1Length := 0;\r\n if List1 <> nil then\r\n List1Length := ItemIDListGetSize(List1) - 2 * SizeOf(Byte);\r\n List2Length := ItemIDListGetSize(List2);\r\n NewItemIDList := ItemIDListCreate(Allocator, List1Length + List2Length);\r\n if NewItemIDList <> nil then\r\n begin\r\n if List1 <> nil then\r\n CopyMemory(NewItemIDList, List1, List1Length);\r\n CopyMemory(Pointer(Cardinal(NewItemIDList) + List1Length), List2, List2Length);\r\n end;\r\n Result := NewItemIDList;\r\nend;\r\n\r\nfunction GetPrinterItemIDList(const DesktopFolder: IShellFolder): PItemIDList;\r\nbegin\r\n Result := nil;\r\n if DesktopFolder <> nil then\r\n if Failed(SHGetSpecialFolderLocation(0, CSIDL_PRINTERS, Result)) then\r\n Result := nil;\r\nend;\r\n\r\nfunction GetAddPrinterItem(const Allocator: IMalloc): PItemIDList;\r\nvar\r\n DesktopFolder: IShellFolder;\r\n EnumIDList: IEnumIDList;\r\n hOK: HRESULT;\r\n PrinterItemIDList: PItemIDList;\r\n PrintersFolder: IShellFolder;\r\n Retrieved: Integer;\r\n TempItemIDList: PItemIDList;\r\nbegin\r\n Result := nil;\r\n if Allocator <> nil then\r\n if Succeeded(SHGetDesktopFolder(DesktopFolder)) then\r\n begin\r\n PrinterItemIDList := GetPrinterItemIDList(DesktopFolder);\r\n if PrinterItemIDList <> nil then\r\n begin\r\n hOK := DesktopFolder.BindToObject(PrinterItemIDList, nil, IID_IShellFolder, Pointer(PrintersFolder));\r\n if Succeeded(hOK) then\r\n if Succeeded(PrintersFolder.EnumObjects(0, SHCONTF_FOLDERS or SHCONTF_NONFOLDERS, EnumIDList)) then\r\n begin\r\n hOK := EnumIDList.Next(1, TempItemIDList, Cardinal(Retrieved));\r\n if (Retrieved > 0) and Succeeded(hOK) then\r\n Result := ItemIDListsConcatenate(Allocator, PrinterItemIDList, TempItemIDList);\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\n//=== { TJvAddPrinterDialog } ================================================\r\n\r\nfunction TJvAddPrinterDialog.Execute(ParentWnd: HWND): Boolean;\r\nvar\r\n AddPrinterItemIDList: PItemIDList;\r\n Allocator: IMalloc;\r\n ShellExecuteInfo: TShellExecuteInfo;\r\nbegin\r\n Result := False;\r\n if CoGetMalloc(MEMCTX_TASK, Allocator) = S_OK then\r\n begin\r\n AddPrinterItemIDList := GetAddPrinterItem(Allocator);\r\n try\r\n if AddPrinterItemIDList <> nil then\r\n begin\r\n FillChar(ShellExecuteInfo, SizeOf(TShellExecuteInfo), 0);\r\n with ShellExecuteInfo do\r\n begin\r\n cbSize := SizeOf(TShellExecuteInfo);\r\n fMask := SEE_MASK_INVOKEIDLIST or SEE_MASK_FLAG_NO_UI;\r\n lpIDList := AddPrinterItemIDList;\r\n nShow := SW_SHOWDEFAULT;\r\n Wnd := ParentWnd;\r\n end;\r\n // (rom) now reports success\r\n Result := ShellExecuteEx(@ShellExecuteInfo);\r\n end;\r\n finally\r\n Allocator.Free(AddPrinterItemIDList);\r\n end;\r\n end;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvAirBrush.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvAirBrush.PAS, released on 2002-06-15.\r\n\r\nThe Initial Developer of the Original Code is Jan Verhoeven [jan1 dott verhoeven att wxs dott nl]\r\nPortions created by Jan Verhoeven are Copyright (C) 2002 Jan Verhoeven.\r\nAll Rights Reserved.\r\n\r\nContributor(s): Robert Love [rlove att slcdug dott org].\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvAirBrush.pas 13104 2011-09-07 06:50:43Z obones $\r\n\r\nunit JvAirBrush;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Classes, Windows, Types, Graphics,\r\n JvComponentBase;\r\n\r\ntype\r\n TJvAirBrushShape = (absRound, absSquare, absLeftSlash, absRightSlash,\r\n absHorizontal, absVertical, absSpray);\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvAirBrush = class(TJvComponent)\r\n private\r\n FBitmap: TBitmap;\r\n FIntensity: Integer;\r\n FSize: Integer;\r\n FColor: TColor;\r\n FShape: TJvAirBrushShape;\r\n FInterval: Integer;\r\n FCounter: Longword;\r\n procedure SetColor(const Value: TColor);\r\n procedure SetIntensity(const Value: Integer);\r\n procedure SetSize(const Value: Integer);\r\n procedure MakeBrush;\r\n procedure SetShape(const Value: TJvAirBrushShape);\r\n function GetAir: Boolean;\r\n procedure SetInterval(const Value: Integer);\r\n procedure MakeSpray;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n procedure Draw(ACanvas: TCanvas; X, Y: Integer);\r\n property Air: Boolean read GetAir;\r\n published\r\n property Size: Integer read FSize write SetSize default 40;\r\n property Color: TColor read FColor write SetColor default clBlack;\r\n property Intensity: Integer read FIntensity write SetIntensity default 10;\r\n property Shape: TJvAirBrushShape read FShape write SetShape default absRound;\r\n // (rom) Interval seems nonfunctional. Delete or reactivate for spray?\r\n property Interval: Integer read FInterval write SetInterval default 100;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvAirBrush.pas $';\r\n Revision: '$Revision: 13104 $';\r\n Date: '$Date: 2011-09-07 08:50:43 +0200 (mer. 07 sept. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n JvPaintFX;\r\n\r\nconstructor TJvAirBrush.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FSize := 40;\r\n FCounter := GetTickCount;\r\n FInterval := 100;\r\n FIntensity := 10;\r\n FColor := clBlack;\r\n FBitmap := TBitmap.Create;\r\n FShape := absRound;\r\nend;\r\n\r\ndestructor TJvAirBrush.Destroy;\r\nbegin\r\n FBitmap.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvAirBrush.SetColor(const Value: TColor);\r\nbegin\r\n FColor := Value;\r\n MakeBrush;\r\nend;\r\n\r\nprocedure TJvAirBrush.SetIntensity(const Value: Integer);\r\nbegin\r\n if Value <> FIntensity then\r\n if (Value >= 1) and (Value <= 100) then\r\n FIntensity := Value;\r\nend;\r\n\r\nprocedure TJvAirBrush.SetSize(const Value: Integer);\r\nbegin\r\n if Value <> FSize then\r\n if (Value >= 10) and (Value <= 200) then\r\n begin\r\n FSize := Value;\r\n MakeBrush;\r\n end;\r\nend;\r\n\r\nprocedure TJvAirBrush.MakeBrush;\r\nvar\r\n Pts: array [0..3] of TPoint;\r\nbegin\r\n with FBitmap do\r\n begin\r\n Width := Size;\r\n Height := Size;\r\n Canvas.Brush.Color := clWhite;\r\n Canvas.FillRect(Rect(0, 0, Width, Height));\r\n Canvas.Pen.Style := psClear;\r\n Canvas.Brush.Color := Color;\r\n case Shape of\r\n absRound:\r\n Canvas.Ellipse(0, 0, Width, Height);\r\n absSquare:\r\n Canvas.Rectangle(0, 0, Width, Height);\r\n absRightSlash:\r\n begin\r\n Pts[0] := Point(0, Height - 1);\r\n Pts[1] := Point(Width div 4, Height - 1);\r\n Pts[2] := Point(Width - 1, 0);\r\n Pts[3] := Point(Width - 1 - (Width div 4), 0);\r\n Canvas.Polygon(Pts);\r\n end;\r\n absLeftSlash:\r\n begin\r\n Pts[0] := Point(0, 0);\r\n Pts[1] := Point(Width div 4, 0);\r\n Pts[2] := Point(Width - 1, Height - 1);\r\n Pts[3] := Point(Width - 1 - (Width div 4), Height - 1);\r\n Canvas.Polygon(Pts);\r\n end;\r\n absHorizontal:\r\n Canvas.Rectangle(0, Height div 4, Width - 1, Height - 1 - (Height div 4));\r\n absVertical:\r\n Canvas.Rectangle(Width div 4, 0, Width - 1 - (Width div 4), Height - 1);\r\n absSpray:\r\n MakeSpray;\r\n end;\r\n TransparentColor := clWhite;\r\n Transparent := True;\r\n end;\r\nend;\r\n\r\n// (rom) better make FBitmap pf24bit here and use Scanline to speed this up\r\n\r\nprocedure TJvAirBrush.MakeSpray;\r\nvar\r\n X, Y, X2, Y2: Integer;\r\nbegin\r\n X2 := FBitmap.Width div 2;\r\n Y2 := FBitmap.Height div 2;\r\n with FBitmap.Canvas do\r\n for Y := 0 to FBitmap.Height - 1 do\r\n for X := 0 to FBitmap.Width - 1 do\r\n if (Sqr(X - X2) + Sqr(Y - Y2)) < Sqr(X2) then\r\n if ((X mod 3) = 0) and ((Y mod 3) = 0) then\r\n Pixels[X, Y] := Color;\r\nend;\r\n\r\nprocedure TJvAirBrush.Draw(ACanvas: TCanvas; X, Y: Integer);\r\nvar\r\n Bmp, Dst: TBitmap;\r\n RPaint, Rt: TRect;\r\n CLeft, CTop: Integer;\r\nbegin\r\n // MakeBrush;\r\n CLeft := X - (Size div 2);\r\n CTop := Y - (Size div 2);\r\n RPaint := Rect(CLeft, CTop, CLeft + Size, CTop + Size);\r\n Bmp := TBitmap.Create;\r\n Bmp.Width := FBitmap.Width;\r\n Bmp.Height := FBitmap.Height;\r\n Dst := TBitmap.Create;\r\n Dst.Width := FBitmap.Width;\r\n Dst.Height := FBitmap.Height;\r\n try\r\n Rt := Rect(0, 0, Bmp.Width, Bmp.Height);\r\n Bmp.Canvas.CopyRect(Rt, ACanvas, RPaint);\r\n Bmp.PixelFormat := pf24bit;\r\n FBitmap.PixelFormat := pf24bit;\r\n Dst.PixelFormat := pf24bit;\r\n TJvPaintFX.Blend2(Bmp, FBitmap, Dst, Intensity / 100);\r\n Dst.TransparentColor := clWhite;\r\n Dst.Transparent := True;\r\n ACanvas.Draw(CLeft, CTop, Dst);\r\n finally\r\n Bmp.Free;\r\n Dst.Free;\r\n end;\r\nend;\r\n\r\nprocedure TJvAirBrush.SetShape(const Value: TJvAirBrushShape);\r\nbegin\r\n FShape := Value;\r\n MakeBrush;\r\nend;\r\n\r\nprocedure TJvAirBrush.SetInterval(const Value: Integer);\r\nbegin\r\n FInterval := Value;\r\nend;\r\n\r\nfunction TJvAirBrush.GetAir: Boolean;\r\nbegin\r\n if Integer(GetTickCount - FCounter) > Interval then\r\n begin\r\n Result := True;\r\n FCounter := GetTickCount;\r\n end\r\n else\r\n Result := False;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvAlarms.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvAlarms.PAS, released on 2001-02-28.\r\n\r\nThe Initial Developer of the Original Code is Sbastien Buysse [sbuysse att buypin dott com]\r\nPortions created by Sbastien Buysse are Copyright (C) 2001 Sbastien Buysse.\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\nMichael Beck [mbeck att bigfoot dott com].\r\nPeter Thrnqvist [peter3 at sourceforge dot net]\r\nJerry Gagnon [jgagnon at paladus dot com]\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvAlarms.pas 13104 2011-09-07 06:50:43Z obones $\r\n\r\nunit JvAlarms;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n ExtCtrls,\r\n SysUtils, Classes,\r\n JvTypes, JvComponentBase;\r\n\r\ntype\r\n TJvAlarmItemEvent = procedure(Sender: TObject;\r\n const TriggerTime: TDateTime) of object;\r\n\r\n TJvAlarmItem = class(TCollectionItem)\r\n private\r\n FName: string;\r\n FTime: TDateTime;\r\n FKind: TJvTriggerKind;\r\n FOnAlarm : TJvAlarmItemEvent;\r\n public\r\n procedure Assign(Source: TPersistent); override;\r\n published\r\n property Name: string read FName write FName;\r\n property Time: TDateTime read FTime write FTime;\r\n property Kind: TJvTriggerKind read FKind write FKind;\r\n property OnAlarm: TJvAlarmItemEvent read FOnAlarm write FOnAlarm;\r\n end;\r\n\r\n TJvAlarmEvent = procedure(Sender: TObject;\r\n const Alarm: TJvAlarmItem; const TriggerTime: TDateTime) of object;\r\n\r\n TJvAlarmItems = class(TOwnedCollection)\r\n private\r\n function GetItems(Index: Integer): TJvAlarmItem;\r\n procedure SetItems(Index: Integer; const Value: TJvAlarmItem);\r\n public\r\n constructor Create(AOwner: TPersistent);\r\n function Add: TJvAlarmItem;\r\n procedure Assign(Source: TPersistent); override;\r\n property Items[Index: Integer]: TJvAlarmItem read GetItems write SetItems; default;\r\n end;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64 or pidOSX32)]\r\n {$ENDIF RTL230_UP}\r\n TJvAlarms = class(TJvComponent)\r\n private\r\n FActive: Boolean;\r\n FLast: TTimeStamp;\r\n FOnAlarm: TJvAlarmEvent;\r\n FRunning: Boolean;\r\n FTimer: TTimer;\r\n FAlarms: TJvAlarmItems;\r\n FBusy: Boolean;\r\n procedure OnTimer(Sender: TObject);\r\n procedure SetActive(const Value: Boolean);\r\n procedure SetAlarms(const Value: TJvAlarmItems);\r\n protected\r\n procedure DoAlarm(const Alarm: TJvAlarmItem; const TriggerTime: TDateTime);\r\n procedure ResetAlarms;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n procedure Add(const AName: string; const ATime: TDateTime; const AKind: TJvTriggerKind = tkOneShot);\r\n procedure Delete(const Idx: Cardinal);\r\n // property Alarms[Idx: Cardinal]: TJvAlarm read GetAlarm;\r\n property Running: Boolean read FRunning;\r\n published\r\n property Alarms: TJvAlarmItems read FAlarms write SetAlarms;\r\n property Active: Boolean read FActive write SetActive default False;\r\n property OnAlarm: TJvAlarmEvent read FOnAlarm write FOnAlarm;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvAlarms.pas $';\r\n Revision: '$Revision: 13104 $';\r\n Date: '$Date: 2011-09-07 08:50:43 +0200 (mer. 07 sept. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\n\r\n//=== { TJvAlarms } ==========================================================\r\n\r\nconstructor TJvAlarms.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FAlarms := TJvAlarmItems.Create(Self);\r\n FActive := False;\r\n FRunning := False;\r\n FOnAlarm := nil;\r\n FTimer := TTimer.Create(Self);\r\n FTimer.Interval := 500;\r\n FTimer.OnTimer := OnTimer;\r\n FTimer.Enabled := False;\r\n FLast := DateTimeToTimeStamp(Now);\r\nend;\r\n\r\ndestructor TJvAlarms.Destroy;\r\nbegin\r\n FAlarms.Free;\r\n FTimer.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvAlarms.Add(const AName: string; const ATime: TDateTime;\r\n const AKind: TJvTriggerKind);\r\nbegin\r\n // hs (Oneshot-) timed out ? then we ignore this alarm !\r\n // works only by calling this funtion directly !\r\n if (ATime >= Now) or (AKind <> tkOneShot) then\r\n begin\r\n with Alarms.Add do\r\n begin\r\n Name := AName;\r\n Time := ATime;\r\n Kind := AKind;\r\n end;\r\n FRunning := Active;\r\n FTimer.Enabled := Running;\r\n end;\r\nend;\r\n\r\nprocedure TJvAlarms.Delete(const Idx: Cardinal);\r\nbegin\r\n Alarms.Delete(Idx);\r\n // (p3)\r\n FRunning := Active and (Alarms.Count > 0);\r\n FTimer.Enabled := Running;\r\nend;\r\n\r\nprocedure TJvAlarms.DoAlarm(const Alarm: TJvAlarmItem;\r\n const TriggerTime: TDateTime);\r\nbegin\r\n if Assigned(Alarm.FOnAlarm) then\r\n Alarm.FOnAlarm(Self, TriggerTime)\r\n else if Assigned(FOnAlarm) then\r\n FOnAlarm(Self, Alarm, TriggerTime);\r\nend;\r\n\r\nprocedure TJvAlarms.OnTimer(Sender: TObject);\r\nvar\r\n I: Cardinal;\r\n Current: TDateTime;\r\n Stamp: TTimeStamp;\r\n Year, Month, Day: Word;\r\n Alarm: TJvAlarmItem;\r\n // hs reentry flag added\r\n // may be necessary if a user function in DoAlarm does not\r\n // return (ex.: modal dialog box) before the same alarm is activated next time.\r\n // it's just a workaround - may be done better :-)\r\nbegin\r\n if not FBusy then\r\n begin\r\n FBusy := True;\r\n try\r\n if Alarms.Count >= 0 then\r\n begin\r\n Current := Now;\r\n Stamp := DateTimeToTimeStamp(Current);\r\n // sort out delayed Timer events which may arrive in bunches\r\n if ((Stamp.Time - FLast.Time) >= 1000) or (Stamp.Date > FLast.Date) then\r\n begin\r\n FLast := Stamp;\r\n for I := Alarms.Count - 1 downto 0 do\r\n begin\r\n Alarm := Alarms[I];\r\n if Current >= Alarm.Time then\r\n begin\r\n // Call OnAlarm - avoid calling a function that takes > 500msecs to complete\r\n // since this could mean no other alarm events are called\r\n DoAlarm(Alarm, Current);\r\n Stamp := DateTimeToTimeStamp(Alarm.Time);\r\n case Alarm.Kind of\r\n tkOneShot:\r\n ;\r\n //hs Delete(I) removed - later on was a reference to 'Alarm.Kind'\r\n // which failed caused by an invalid Alarm\r\n tkEachSecond:\r\n Inc(Stamp.Time, 1000);\r\n tkEachMinute:\r\n Inc(Stamp.Time, 60 * 1000);\r\n tkEachHour:\r\n Inc(Stamp.Time, 60 * 60 * 1000);\r\n tkEachDay:\r\n Inc(Stamp.Date);\r\n tkEachMonth:\r\n Stamp := DateTimeToTimeStamp(IncMonth(Alarm.Time, 1));\r\n tkEachYear:\r\n begin\r\n DecodeDate(Current, Year, Month, Day);\r\n // (rom) a showoff with boolean expressions :-)\r\n Inc(Stamp.Date, 365 + Ord(IsLeapYear(Year)));\r\n end;\r\n end;\r\n if Stamp.Time > 24 * 60 * 60 * 1000 then\r\n begin\r\n Inc(Stamp.Date);\r\n Dec(Stamp.Time, 24 * 60 * 60 * 1000);\r\n end;\r\n if Alarm.Kind <> tkOneShot then\r\n Alarm.Time := TimeStampToDateTime(Stamp)\r\n // hs a better place for 'Delete(I)'\r\n else\r\n Delete(I);\r\n end;\r\n end;\r\n end;\r\n end;\r\n finally\r\n FBusy := False;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvAlarms.SetActive(const Value: Boolean);\r\nbegin\r\n FActive := Value;\r\n FRunning := FActive and (Alarms.Count > 0);\r\n FLast := DateTimeToTimeStamp(Now);\r\n if FRunning then\r\n ResetAlarms;\r\n FTimer.Enabled := Running;\r\nend;\r\n\r\nprocedure TJvAlarms.SetAlarms(const Value: TJvAlarmItems);\r\nbegin\r\n FAlarms.Assign(Value);\r\nend;\r\n\r\nprocedure TJvAlarms.ResetAlarms;\r\nvar\r\n Current: TDateTime;\r\n I: Integer;\r\n\r\n function MaxDate(Val1, Val2: TDateTime): TDateTime;\r\n begin\r\n Result := Val1;\r\n if Val2 > Val1 then\r\n Result := Val2;\r\n end;\r\n\r\nbegin\r\n // make sure no alarm item is in past time (this will trigger the OnAlaram event every second until the alarm catches up)\r\n Current := Now;\r\n for I := 0 to Alarms.Count - 1 do\r\n Alarms[I].Time := MaxDate(Current, Alarms[I].Time);\r\nend;\r\n\r\n//=== { TJvAlarmItems } ======================================================\r\n\r\nconstructor TJvAlarmItems.Create(AOwner: TPersistent);\r\nbegin\r\n inherited Create(AOwner, TJvAlarmItem);\r\nend;\r\n\r\nfunction TJvAlarmItems.Add: TJvAlarmItem;\r\nbegin\r\n Result := TJvAlarmItem(inherited Add);\r\nend;\r\n\r\nprocedure TJvAlarmItems.Assign(Source: TPersistent);\r\nvar\r\n I: Integer;\r\nbegin\r\n if Source is TJvAlarmItems then\r\n begin\r\n Clear;\r\n for I := 1 to TJvAlarmItems(Source).Count do\r\n Add.Assign(TJvAlarmItems(Source).Items[I - 1]);\r\n end\r\n else\r\n inherited Assign(Source);\r\nend;\r\n\r\nfunction TJvAlarmItems.GetItems(Index: Integer): TJvAlarmItem;\r\nbegin\r\n Result := TJvAlarmItem(inherited Items[Index]);\r\nend;\r\n\r\nprocedure TJvAlarmItems.SetItems(Index: Integer; const Value: TJvAlarmItem);\r\nbegin\r\n inherited Items[Index] := Value;\r\nend;\r\n\r\n//=== { TJvAlarmItem } =======================================================\r\n\r\nprocedure TJvAlarmItem.Assign(Source: TPersistent);\r\nbegin\r\n if Source is TJvAlarmItem then\r\n begin\r\n Name := TJvAlarmItem(Source).Name;\r\n Time := TJvAlarmItem(Source).Time;\r\n Kind := TJvAlarmItem(Source).Kind;\r\n end\r\n else\r\n inherited Assign(Source);\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvAni.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvAni.PAS, released on 2001-02-28.\r\n\r\nThe Initial Developer of the Original Code is Sbastien Buysse [sbuysse att buypin dott com]\r\nPortions created by Sbastien Buysse are Copyright (C) 2001 Sbastien Buysse.\r\nAll Rights Reserved.\r\n\r\nThe Original Code is: JvAniFile.PAS, released on 2002-07-04.\r\n\r\nThe Initial Developers of the Original Code are: Fedor Koshevnikov, Igor Pavluk and Serge Korolev\r\nCopyright (c) 1997, 1998 Fedor Koshevnikov, Igor Pavluk and Serge Korolev\r\nCopyright (c) 2001,2002 SGB Software\r\nAll Rights Reserved.\r\n\r\nContributor(s): Michael Beck [mbeck att bigfoot dott com].\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvAni.pas 12461 2009-08-14 17:21:33Z obones $\r\n\r\nunit JvAni;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Classes, RTLConsts, Windows, Graphics, Controls, ExtCtrls, Dialogs,\r\n JvTypes;\r\n\r\ntype\r\n TJvIconFrame = class(TPersistent)\r\n private\r\n FIcon: TIcon;\r\n FIsIcon: Boolean;\r\n FHotSpot: TPoint;\r\n FRate: Longint;\r\n public\r\n constructor Create(JifRate: Longint);\r\n destructor Destroy; override;\r\n procedure Assign(Source: TPersistent); override;\r\n property Icon: TIcon read FIcon;\r\n property HotSpot: TPoint read FHotSpot;\r\n property Rate: Longint read FRate;\r\n end;\r\n\r\n TJvAni = class(TGraphic)\r\n private\r\n FHeader: TJvAniHeader;\r\n FTitle: string;\r\n FAuthor: string;\r\n FIcons: TList;\r\n FOriginalColors: Word;\r\n FIndex: Integer;\r\n FRates: array of Longint;\r\n FSequence: array of Longint;\r\n FFrameCount: Integer;\r\n FFrameResult: TJvIconFrame;\r\n FTimer: TTimer;\r\n procedure RiffReadError;\r\n function ReadCreateIcon(Stream: TStream; ASize: Longint;\r\n var HotSpot: TPoint; var IsIcon: Boolean): TIcon;\r\n procedure ReadAniStream(Stream: TStream);\r\n procedure WriteAniStream(Stream: TStream);\r\n procedure Clear;\r\n procedure NewImage;\r\n function GetAnimated: Boolean;\r\n function GetAuthor: string;\r\n function GetTitle: string;\r\n function GetIconCount: Integer;\r\n function GetFrameCount: Integer;\r\n function GetIcons(Index: Integer): TIcon;\r\n function GetFrames(Index: Integer): TJvIconFrame;\r\n procedure SetIndex(const Value: Integer);\r\n procedure SetAnimated(const Value: Boolean);\r\n procedure CalcDelay;\r\n protected\r\n function GetEmpty: Boolean; override;\r\n function GetHeight: Integer; override;\r\n function GetWidth: Integer; override;\r\n procedure SetHeight(Value: Integer); override;\r\n procedure SetWidth(Value: Integer); override;\r\n procedure Animate(Sender: TObject);\r\n procedure SetTransparent(Value: Boolean); override;\r\n function GetTransparent: Boolean; override;\r\n procedure AssignTo(Dest: TPersistent); override;\r\n public\r\n constructor Create; override;\r\n destructor Destroy; override;\r\n procedure Assign(Source: TPersistent); override;\r\n procedure LoadFromStream(Stream: TStream); override;\r\n procedure SaveToStream(Stream: TStream); override;\r\n procedure LoadFromFile(const FileName: string); override;\r\n procedure SaveToFile(const FileName: string); override;\r\n procedure LoadFromClipboardFormat(AFormat: Word; AData: THandle; APalette: HPALETTE); override;\r\n procedure SaveToClipboardFormat(var Format: Word; var Data: THandle; var APalette: HPALETTE); override;\r\n procedure AssignToBitmap(Bitmap: TBitmap; BackColor: TColor;\r\n DecreaseColors, Vertical: Boolean);\r\n procedure AssignIconsToBitmap(Bitmap: TBitmap; BackColor: TColor;\r\n DecreaseColors, Vertical: Boolean);\r\n procedure Draw(ACanvas: TCanvas; const ARect: TRect); override;\r\n property Animated: Boolean read GetAnimated write SetAnimated;\r\n property Author: string read GetAuthor;\r\n property IconCount: Integer read GetIconCount;\r\n property FrameCount: Integer read GetFrameCount;\r\n property Frames[Index: Integer]: TJvIconFrame read GetFrames;\r\n property Header: TJvAniHeader read FHeader;\r\n property Icons[Index: Integer]: TIcon read GetIcons;\r\n property Index: Integer read FIndex write SetIndex;\r\n property OriginalColors: Word read FOriginalColors;\r\n property Title: string read GetTitle;\r\n end;\r\n\r\nfunction LoadJvAniDialog: TJvAni;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvAni.pas $';\r\n Revision: '$Revision: 12461 $';\r\n Date: '$Date: 2009-08-14 19:21:33 +0200 (ven. 14 août 2009) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n SysUtils,\r\n Consts, Math,\r\n JvJVCLUtils, JvJCLUtils, JvIconList, JvConsts, JvResources;\r\n\r\n//=== { TJvAnimatedCursorImage helper } ======================================\r\n\r\n// (rom) created because JvAnimatedEditor.pas and JvIconListForm.pas contained the same code\r\n\r\nfunction LoadJvAniDialog: TJvAni;\r\nvar\r\n CurDir: string;\r\nbegin\r\n Result := nil;\r\n CurDir := GetCurrentDir;\r\n with TOpenDialog.Create(nil) do\r\n try\r\n Options := [ ofHideReadOnly, ofFileMustExist];\r\n DefaultExt := RsAniExtension;\r\n Filter := RsAniCurFilter;\r\n if Execute then\r\n begin\r\n Result := TJvAni.Create;\r\n try\r\n Result.LoadFromFile(FileName);\r\n except\r\n FreeAndNil(Result);\r\n raise;\r\n end;\r\n end;\r\n finally\r\n Free;\r\n SetCurrentDir(CurDir);\r\n end;\r\nend;\r\n\r\nfunction PadUp(Value: Longint): Longint;\r\nbegin\r\n Result := Value + (Value mod 2); // Up Value to nearest word boundary\r\nend;\r\n\r\nprocedure DecreaseBMPColors(Bmp: TBitmap; Colors: Integer);\r\n\r\nvar\r\n Stream: TStream;\r\nbegin\r\n if (Bmp <> nil) and (Colors > 0) then\r\n begin\r\n Stream := BitmapToMemory(Bmp, Colors);\r\n try\r\n Bmp.LoadFromStream(Stream);\r\n finally\r\n Stream.Free;\r\n end;\r\n end;\r\nend;\r\n\r\n\r\n\r\nfunction GetDInColors(BitCount: Word): Integer;\r\nbegin\r\n case BitCount of\r\n 1, 4, 8:\r\n Result := 1 shl BitCount;\r\n else\r\n Result := 0;\r\n end;\r\nend;\r\n\r\n{ ReadTag, ReadChunk, SkipChunk. Some handy functions for reading RIFF files. }\r\n\r\nfunction ReadTag(S: TStream; var Tag: TJvAniTag): Boolean;\r\nbegin\r\n Tag.ckID := #0#0#0#0;\r\n Tag.ckSize := 0;\r\n Result := S.Read(Tag, SizeOf(TJvAniTag)) = SizeOf(TJvAniTag);\r\nend;\r\n\r\nfunction ReadChunk(S: TStream; const Tag: TJvAniTag; var Data): Boolean;\r\nbegin\r\n Result := S.Read(Data, Tag.ckSize) = Tag.ckSize;\r\n if Result then\r\n Result := S.Seek(Tag.ckSize mod 2, soFromCurrent) <> -1;\r\nend;\r\n\r\nfunction ReadChunkN(S: TStream; const Tag: TJvAniTag; var Data;\r\n cbMax: Longint): Boolean;\r\nvar\r\n cbRead: Longint;\r\nbegin\r\n FillChar(Data, cbMax, #0);\r\n cbRead := Tag.ckSize;\r\n if cbMax < cbRead then\r\n cbRead := cbMax;\r\n Result := S.Read(Data, cbRead) = cbRead;\r\n if Result then\r\n begin\r\n cbRead := PadUp(Tag.ckSize) - cbRead;\r\n Result := S.Seek(cbRead, soFromCurrent) <> -1;\r\n end;\r\nend;\r\n\r\nfunction SkipChunk(S: TStream; const Tag: TJvAniTag): Boolean;\r\nbegin\r\n // Round pTag^.ckSize up to nearest word boundary to maintain alignment\r\n Result := S.Seek(PadUp(Tag.ckSize), soFromCurrent) <> -1;\r\nend;\r\n\r\n{ Icon and cursor types }\r\n\r\nconst\r\n RC3_STOCKICON = 0;\r\n RC3_ICON = 1;\r\n RC3_CURSOR = 2;\r\n\r\ntype\r\n PCursorOrIcon = ^TCursorOrIcon;\r\n TCursorOrIcon = packed record\r\n Reserved: Word;\r\n wType: Word;\r\n Count: Word;\r\n end;\r\n\r\n PIconRec = ^TIconRec;\r\n TIconRec = packed record\r\n Width: Byte;\r\n Height: Byte;\r\n Colors: Word;\r\n xHotspot: Word;\r\n yHotspot: Word;\r\n DIBSize: Longint;\r\n DIBOffset: Longint;\r\n end;\r\n\r\n//=== { TJvIconFrame } =======================================================\r\n\r\nconstructor TJvIconFrame.Create(JifRate: Longint);\r\nbegin\r\n inherited Create;\r\n FIcon := nil;\r\n FRate := JifRate;\r\nend;\r\n\r\ndestructor TJvIconFrame.Destroy;\r\nbegin\r\n FIcon.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvIconFrame.Assign(Source: TPersistent);\r\nbegin\r\n if Source is TJvIconFrame then\r\n with Source as TJvIconFrame do\r\n begin\r\n if Self.FIcon = nil then\r\n Self.FIcon := TIcon.Create;\r\n Self.FIcon.Assign(Icon);\r\n Self.FIsIcon := FIsIcon;\r\n Self.FHotSpot := HotSpot;\r\n Self.FRate := Rate;\r\n end\r\n else\r\n inherited Assign(Source);\r\nend;\r\n\r\n//=== { TJvAni } =============================================================\r\n\r\nconstructor TJvAni.Create;\r\nbegin\r\n inherited Create;\r\n FIcons := TList.Create;\r\n FIndex := -1;\r\n FTimer := TTimer.Create(nil);\r\n FTimer.Interval := 100;\r\n FTimer.OnTimer := Animate;\r\n FTimer.Enabled := False;\r\n FFrameResult := TJvIconFrame.Create(0);\r\nend;\r\n\r\ndestructor TJvAni.Destroy;\r\nbegin\r\n NewImage;\r\n FreeAndNil(FIcons);\r\n FreeAndNil(FTimer);\r\n FFrameResult.FIcon := nil;\r\n FreeAndNil(FFrameResult);\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvAni.Clear;\r\nbegin\r\n if FIcons.Count > 0 then\r\n begin\r\n NewImage;\r\n Changed(Self);\r\n end;\r\nend;\r\n\r\nprocedure TJvAni.NewImage;\r\nvar\r\n I: Integer;\r\nbegin\r\n if Assigned(FIcons) then\r\n for I := 0 to FIcons.Count - 1 do\r\n TJvIconFrame(FIcons[I]).Free;\r\n FreeAndNil(FIcons);\r\n SetLength(FRates, 0);\r\n SetLength(FSequence, 0);\r\n FFrameCount := 0;\r\n FTitle := '';\r\n FAuthor := '';\r\n FillChar(FHeader, SizeOf(FHeader), 0);\r\n FOriginalColors := 0;\r\n FIndex := -1;\r\nend;\r\n\r\nprocedure TJvAni.Assign(Source: TPersistent);\r\nvar\r\n I: Integer;\r\n Frame: TJvIconFrame;\r\nbegin\r\n if Source = nil then\r\n Clear\r\n else\r\n if Source is TJvAni then\r\n begin\r\n Clear;\r\n try\r\n with TJvAni(Source) do\r\n begin\r\n Move(FHeader, Self.FHeader, SizeOf(FHeader));\r\n Self.FTitle := Title;\r\n Self.FAuthor := Author;\r\n Self.FOriginalColors := FOriginalColors;\r\n Self.FFrameCount := FrameCount;\r\n SetLength(Self.FRates, Length(FRates));\r\n if Length(FRates) <> 0 then\r\n Move(FRates[0], Self.FRates[0], Length(FRates) * SizeOf(Longint));\r\n SetLength(Self.FSequence, Length(FSequence));\r\n if Length(FSequence) <> 0 then\r\n Move(FSequence[0], Self.FSequence[0], Length(FSequence) * SizeOf(Longint));\r\n for I := 0 to FIcons.Count - 1 do\r\n begin\r\n Frame := TJvIconFrame.Create(FHeader.dwJIFRate);\r\n try\r\n Frame.Assign(TJvIconFrame(FIcons[I]));\r\n Self.FIcons.Add(Frame);\r\n except\r\n Frame.Free;\r\n raise;\r\n end;\r\n end;\r\n Self.FIndex := Index;\r\n Self.Animated := Animated;\r\n end;\r\n except\r\n NewImage;\r\n raise;\r\n end;\r\n end\r\n else\r\n inherited Assign(Source);\r\nend;\r\n\r\nprocedure TJvAni.AssignTo(Dest: TPersistent);\r\nvar\r\n I: Integer;\r\nbegin\r\n if Dest is TIcon then\r\n begin\r\n if FrameCount > 0 then\r\n Dest.Assign(Frames[Index].Icon)\r\n else\r\n Dest.Assign(nil);\r\n end\r\n else\r\n if Dest is TBitmap then\r\n begin\r\n if FrameCount > 0 then\r\n AssignToBitmap(TBitmap(Dest), TBitmap(Dest).Canvas.Brush.Color, True, False)\r\n else\r\n Dest.Assign(nil);\r\n end\r\n else\r\n if Dest is TJvIconList then\r\n begin\r\n TJvIconList(Dest).BeginUpdate;\r\n try\r\n TJvIconList(Dest).Clear;\r\n for I := 0 to FrameCount - 1 do\r\n TJvIconList(Dest).Add(Frames[I].Icon);\r\n finally\r\n TJvIconList(Dest).EndUpdate;\r\n end;\r\n end\r\n else\r\n inherited AssignTo(Dest);\r\nend;\r\n\r\nfunction TJvAni.GetEmpty: Boolean;\r\nbegin\r\n Result := (FrameCount = 0);\r\nend;\r\n\r\nprocedure TJvAni.SetHeight(Value: Integer);\r\nbegin\r\n raise EInvalidGraphicOperation.CreateRes(@SChangeIconSize);\r\nend;\r\n\r\nprocedure TJvAni.SetWidth(Value: Integer);\r\nbegin\r\n raise EInvalidGraphicOperation.CreateRes(@SChangeIconSize);\r\nend;\r\n\r\nfunction TJvAni.GetWidth: Integer;\r\nbegin\r\n Result := Frames[Index].Icon.Width;\r\nend;\r\n\r\nfunction TJvAni.GetHeight: Integer;\r\nbegin\r\n Result := Frames[Index].Icon.Height;\r\nend;\r\n\r\n\r\n\r\nprocedure TJvAni.LoadFromClipboardFormat(AFormat: Word; AData: THandle; APalette: HPALETTE);\r\nbegin\r\n raise EInvalidGraphicOperation.CreateRes(@SIconToClipboard);\r\nend;\r\n\r\nprocedure TJvAni.SaveToClipboardFormat(var Format: Word; var Data: THandle; var APalette: HPALETTE);\r\nbegin\r\n raise EInvalidGraphicOperation.CreateRes(@SIconToClipboard);\r\nend;\r\n\r\n\r\n\r\nprocedure TJvAni.SetIndex(const Value: Integer);\r\nbegin\r\n if (Value >= 0) and (Value < FrameCount) and (FIndex <> Value) then\r\n begin\r\n FIndex := Value;\r\n Changed(Self);\r\n end;\r\nend;\r\n\r\nfunction TJvAni.GetAuthor: string;\r\nbegin\r\n Result := FAuthor;\r\nend;\r\n\r\nfunction TJvAni.GetTitle: string;\r\nbegin\r\n Result := FTitle;\r\nend;\r\n\r\nfunction TJvAni.GetIconCount: Integer;\r\nbegin\r\n Result := FIcons.Count;\r\nend;\r\n\r\nfunction TJvAni.GetFrameCount: Integer;\r\nbegin\r\n Result := FFrameCount;\r\nend;\r\n\r\nfunction TJvAni.GetAnimated: Boolean;\r\nbegin\r\n Result := FTimer.Enabled;\r\nend;\r\n\r\nprocedure TJvAni.SetAnimated(const Value: Boolean);\r\nbegin\r\n if Value <> FTimer.Enabled then\r\n FTimer.Enabled := Value;\r\nend;\r\n\r\nprocedure TJvAni.Animate(Sender: TObject);\r\nbegin\r\n FTimer.Enabled := False;\r\n if FrameCount > 0 then\r\n Index := (Index + 1) mod Integer(FrameCount);\r\n CalcDelay;\r\n FTimer.Enabled := True;\r\nend;\r\n\r\nprocedure TJvAni.CalcDelay;\r\nbegin\r\n if Index = -1 then\r\n Animated := False\r\n else\r\n begin\r\n FTimer.Interval := (Cardinal(Frames[Index].Rate) * 100) div 6;\r\n if FTimer.Interval = 0 then\r\n FTimer.Interval := 100;\r\n end;\r\nend;\r\n\r\nprocedure TJvAni.SetTransparent(Value: Boolean);\r\nbegin\r\n // Icons are always transparent so animations also\r\nend;\r\n\r\nfunction TJvAni.GetTransparent: Boolean;\r\nbegin\r\n Result := True;\r\nend;\r\n\r\nprocedure TJvAni.RiffReadError;\r\nbegin\r\n raise EReadError.CreateRes(@SReadError);\r\nend;\r\n\r\nfunction TJvAni.GetIcons(Index: Integer): TIcon;\r\nbegin\r\n if (Index >= 0) and (Index < IconCount) then\r\n Result := TJvIconFrame(FIcons[Index]).FIcon\r\n else\r\n Result := nil;\r\nend;\r\n\r\nfunction TJvAni.GetFrames(Index: Integer): TJvIconFrame;\r\nvar\r\n N: Integer;\r\nbegin\r\n if (Index >= 0) and (Index < FrameCount) then\r\n begin\r\n if Length(FSequence) <> 0 then\r\n N := FSequence[Index]\r\n else\r\n N := Index;\r\n FFrameResult.FIcon := TJvIconFrame(FIcons[N]).FIcon;\r\n FFrameResult.FIsIcon := TJvIconFrame(FIcons[N]).FIsIcon;\r\n FFrameResult.FHotSpot := TJvIconFrame(FIcons[N]).FHotSpot;\r\n if Length(FRates) <> 0 then\r\n FFrameResult.FRate := FRates[Index]\r\n else\r\n FFrameResult.FRate := FHeader.dwJIFRate;\r\n Result := FFrameResult;\r\n end\r\n else\r\n Result := nil;\r\nend;\r\n\r\nfunction TJvAni.ReadCreateIcon(Stream: TStream; ASize: Longint;\r\n var HotSpot: TPoint; var IsIcon: Boolean): TIcon;\r\ntype\r\n PIconRecArray = ^TIconRecArray;\r\n TIconRecArray = array [0..300] of TIconRec;\r\nvar\r\n List: PIconRecArray;\r\n Mem: TMemoryStream;\r\n HeaderLen, I: Integer;\r\n BI: PBitmapInfoHeader;\r\nbegin\r\n Result := nil;\r\n Mem := TMemoryStream.Create;\r\n try\r\n Mem.SetSize(ASize);\r\n Mem.CopyFrom(Stream, ASize);\r\n HotSpot := Point(0, 0);\r\n IsIcon := PCursorOrIcon(Mem.Memory)^.wType = RC3_ICON;\r\n if PCursorOrIcon(Mem.Memory)^.wType = RC3_CURSOR then\r\n PCursorOrIcon(Mem.Memory)^.wType := RC3_ICON;\r\n if PCursorOrIcon(Mem.Memory)^.wType = RC3_ICON then\r\n begin\r\n { determinate original icon color }\r\n HeaderLen := PCursorOrIcon(Mem.Memory)^.Count * SizeOf(TIconRec);\r\n GetMem(List, HeaderLen);\r\n try\r\n Mem.Position := SizeOf(TCursorOrIcon);\r\n Mem.Read(List^, HeaderLen);\r\n for I := 0 to PCursorOrIcon(Mem.Memory)^.Count - 1 do\r\n with List^[I] do\r\n begin\r\n GetMem(BI, DIBSize);\r\n try\r\n Mem.Seek(DIBOffset, soFromBeginning);\r\n Mem.Read(BI^, DIBSize);\r\n FOriginalColors := Max(GetDInColors(BI^.biBitCount), FOriginalColors);\r\n HotSpot := Point(xHotspot, yHotspot);\r\n finally\r\n FreeMem(BI, DIBSize);\r\n end;\r\n end;\r\n finally\r\n FreeMem(List, HeaderLen);\r\n end;\r\n { return to start of stream }\r\n Mem.Position := 0;\r\n Result := TIcon.Create;\r\n try\r\n Result.LoadFromStream(Mem);\r\n if IsIcon then\r\n HotSpot := Point(Result.Width div 2, Result.Height div 2);\r\n except\r\n Result.Free;\r\n Result := nil;\r\n end;\r\n end;\r\n finally\r\n Mem.Free;\r\n end;\r\nend;\r\n\r\n{ Loads an animated cursor from a RIFF file. The RIFF file format for\r\n animated cursors looks like this:\r\n\r\n\"RIFF\" [Length of File]\r\n \"ACON\"\r\n \"LIST\" [Length of List]\r\n \"INAM\" [Length of Title] [Data]\r\n \"IART\" [Length of Author] [Data]\r\n \"fram\"\r\n \"icon\" [Length of Icon][Data] ; 1st in list\r\n ...\r\n \"icon\" [Length of Icon] [Data] ; Last in list (1 to cFrames)\r\n \"anih\" [Length of ANI header (36 bytes)] [Data] ; (see ANI Header TypeDef)\r\n \"rate\" [Length of rate block] [Data] ; ea. rate is a long (length is 1 to cSteps)\r\n \"seq \" [Length of sequence block] [Data] ; ea. seq is a long (length is 1 to cSteps)\r\n}\r\n\r\nprocedure TJvAni.ReadAniStream(Stream: TStream);\r\nvar\r\n I: Integer;\r\n Tag: TJvAniTag;\r\n Frame: TJvIconFrame;\r\n cbChunk, cbRead: Longint;\r\n Icon: TIcon;\r\n IsIcon: Boolean;\r\n HotSpot: TPoint;\r\n Buffer: array [0..255] of Char;\r\nbegin\r\n { Make sure it's a RIFF ANI file }\r\n if not ReadTag(Stream, Tag) or (Tag.ckID <> FOURCC_RIFF) then\r\n RiffReadError;\r\n if (Stream.Read(Tag.ckID, SizeOf(Tag.ckID)) < SizeOf(Tag.ckID)) or\r\n (Tag.ckID <> FOURCC_ACON) then\r\n RiffReadError;\r\n Clear;\r\n { look for 'anih', 'rate', 'seq ', and 'icon' chunks }\r\n while ReadTag(Stream, Tag) do\r\n begin\r\n if Tag.ckID = FOURCC_anih then\r\n begin\r\n if not ReadChunk(Stream, Tag, FHeader) then\r\n Break;\r\n if ((FHeader.dwFlags and AF_ICON) <> AF_ICON) or\r\n (FHeader.dwFrames = 0) then\r\n RiffReadError;\r\n end\r\n else\r\n if Tag.ckID = FOURCC_rate then\r\n begin\r\n { If we find a rate chunk, read it into its preallocated space }\r\n SetLength(FRates, Tag.ckSize div SizeOf(Longint));\r\n if not ReadChunkN(Stream, Tag, FRates[0], Tag.ckSize) then\r\n Break;\r\n end\r\n else\r\n if Tag.ckID = FOURCC_seq then\r\n begin\r\n { If we find a seq chunk, read it into its preallocated space }\r\n FFrameCount := Tag.ckSize div SizeOf(Longint);\r\n SetLength(FSequence, FFrameCount);\r\n if not ReadChunkN(Stream, Tag, FSequence[0], Tag.ckSize) then\r\n Break;\r\n end\r\n else\r\n if Tag.ckID = FOURCC_LIST then\r\n begin\r\n cbChunk := PadUp(Tag.ckSize);\r\n { See if this list is the 'fram' list of icon chunks }\r\n cbRead := Stream.Read(Tag.ckID, SizeOf(Tag.ckID));\r\n if cbRead < SizeOf(Tag.ckID) then\r\n Break;\r\n Dec(cbChunk, cbRead);\r\n if Tag.ckID = FOURCC_fram then\r\n begin\r\n while cbChunk >= SizeOf(Tag) do\r\n begin\r\n if not ReadTag(Stream, Tag) then\r\n Break;\r\n Dec(cbChunk, SizeOf(Tag));\r\n if Tag.ckID = FOURCC_icon then\r\n begin\r\n { Ok, load the icon/cursor bits }\r\n Icon := ReadCreateIcon(Stream, Tag.ckSize, HotSpot, IsIcon);\r\n if Icon = nil then\r\n Break;\r\n Frame := TJvIconFrame.Create(FHeader.dwJIFRate);\r\n Frame.FIcon := Icon;\r\n Frame.FHotSpot := HotSpot;\r\n Frame.FIsIcon := IsIcon;\r\n FIcons.Add(Frame);\r\n end\r\n else\r\n { Unknown chunk in fram list, just ignore it }\r\n SkipChunk(Stream, Tag);\r\n Dec(cbChunk, PadUp(Tag.ckSize));\r\n end;\r\n end\r\n else\r\n if Tag.ckID = FOURCC_INFO then\r\n begin\r\n { now look for INAM and IART chunks }\r\n while cbChunk >= SizeOf(Tag) do\r\n begin\r\n if not ReadTag(Stream, Tag) then\r\n Break;\r\n Dec(cbChunk, SizeOf(Tag));\r\n if Tag.ckID = FOURCC_INAM then\r\n begin\r\n if (cbChunk < Tag.ckSize) or\r\n not ReadChunkN(Stream, Tag, Buffer[0], SizeOf(Buffer) - 1) then\r\n Break;\r\n Dec(cbChunk, PadUp(Tag.ckSize));\r\n FTitle := Buffer;\r\n end\r\n else\r\n if Tag.ckID = FOURCC_IART then\r\n begin\r\n if (cbChunk < Tag.ckSize) or\r\n not ReadChunkN(Stream, Tag, Buffer[0], SizeOf(Buffer) - 1) then\r\n Break;\r\n Dec(cbChunk, PadUp(Tag.ckSize));\r\n FAuthor := Buffer;\r\n end\r\n else\r\n begin\r\n if not SkipChunk(Stream, Tag) then\r\n Break;\r\n Dec(cbChunk, PadUp(Tag.ckSize));\r\n end;\r\n end;\r\n end\r\n else\r\n begin\r\n { Not the fram list or the INFO list. Skip the rest of this\r\n chunk. (Do not forget that we have already skipped one dword) }\r\n Tag.ckSize := cbChunk;\r\n SkipChunk(Stream, Tag);\r\n end;\r\n end\r\n else\r\n begin\r\n { We are not interested in this chunk, skip it. }\r\n if not SkipChunk(Stream, Tag) then\r\n Break;\r\n end;\r\n end;\r\n { Update the frame count in case we coalesced some frames while reading\r\n in the file. }\r\n for I := FIcons.Count - 1 downto 0 do\r\n begin\r\n if TJvIconFrame(FIcons[I]).FIcon = nil then\r\n begin\r\n TJvIconFrame(FIcons[I]).Free;\r\n FIcons.Delete(I);\r\n end;\r\n end;\r\n if FrameCount = 0 then\r\n FFrameCount := FIcons.Count;\r\n FHeader.dwFrames := FIcons.Count;\r\n if FHeader.dwFrames = 0 then\r\n RiffReadError;\r\nend;\r\n\r\nprocedure SetFOURCC(var FourCC: TJvFourCC; const ID: AnsiString);\r\nbegin\r\n FourCC[0] := ID[1];\r\n FourCC[1] := ID[2];\r\n FourCC[2] := ID[3];\r\n FourCC[3] := ID[4];\r\nend;\r\n\r\nprocedure StartWriteChunk(Stream: TStream; var Tag: TJvAniTag; const ID: AnsiString);\r\nbegin\r\n SetFOURCC(Tag.ckID, ID);\r\n Tag.ckSize := Stream.Position;\r\n Stream.Write(Tag, SizeOf(Tag));\r\nend;\r\n\r\nprocedure EndWriteChunk(Stream: TStream; var Tag: TJvAniTag; AddSize: Integer);\r\nvar\r\n Pos: Int64;\r\n B: Byte;\r\nbegin\r\n Pos := Stream.Position;\r\n Tag.ckSize := Pos - Tag.ckSize;\r\n Stream.Seek(-Tag.ckSize, soFromCurrent);\r\n Dec(Tag.ckSize, SizeOf(TJvAniTag));\r\n Inc(Tag.ckSize, AddSize);\r\n Stream.Write(Tag, SizeOf(Tag));\r\n Stream.Seek(Pos, soFromBeginning);\r\n if Odd(Tag.ckSize) then\r\n begin\r\n B := 0;\r\n Stream.Write(B, 1);\r\n end;\r\nend;\r\n\r\nprocedure TJvAni.WriteAniStream(Stream: TStream);\r\nvar\r\n I: Integer;\r\n MemStream: TMemoryStream;\r\n TagRIFF, TagLIST, Tag: TJvAniTag;\r\n ID: TJvFourCC;\r\nbegin\r\n MemStream := TMemoryStream.Create;\r\n try\r\n StartWriteChunk(MemStream, TagRIFF, FOURCC_RIFF);\r\n\r\n SetFOURCC(ID, FOURCC_ACON);\r\n MemStream.Write(ID, SizeOf(TJvFourCC));\r\n\r\n if (Title <> '') or (Author <> '') then\r\n begin\r\n StartWriteChunk(MemStream, TagLIST, FOURCC_LIST);\r\n SetFOURCC(ID, FOURCC_INFO);\r\n MemStream.Write(ID, SizeOf(TJvFourCC));\r\n if Title <> '' then\r\n begin\r\n StartWriteChunk(MemStream, Tag, FOURCC_INAM);\r\n MemStream.Write(PChar(Title)^, Length(Title) + 1);\r\n EndWriteChunk(MemStream, Tag, 0);\r\n end;\r\n if Author <> '' then\r\n begin\r\n StartWriteChunk(MemStream, Tag, FOURCC_IART);\r\n MemStream.Write(PChar(Author)^, Length(Author) + 1);\r\n EndWriteChunk(MemStream, Tag, 0);\r\n end;\r\n EndWriteChunk(MemStream, TagLIST, 0);\r\n end;\r\n StartWriteChunk(MemStream, Tag, FOURCC_anih);\r\n FHeader.dwFrames := IconCount;\r\n MemStream.Write(FHeader, SizeOf(TJvAniHeader));\r\n EndWriteChunk(MemStream, Tag, 0);\r\n if Length(FRates) <> 0 then\r\n begin\r\n StartWriteChunk(MemStream, Tag, FOURCC_rate);\r\n MemStream.Write(FRates, Length(FRates) * SizeOf(Longint));\r\n EndWriteChunk(MemStream, Tag, 0);\r\n end;\r\n if Length(FSequence) <> 0 then\r\n begin\r\n StartWriteChunk(MemStream, Tag, FOURCC_seq);\r\n MemStream.Write(FSequence[0], Length(FSequence) * SizeOf(Longint));\r\n EndWriteChunk(MemStream, Tag, 0);\r\n end;\r\n\r\n StartWriteChunk(MemStream, TagLIST, FOURCC_LIST);\r\n SetFOURCC(ID, FOURCC_fram);\r\n MemStream.Write(ID, SizeOf(TJvFourCC));\r\n for I := 0 to IconCount - 1 do\r\n begin\r\n StartWriteChunk(MemStream, Tag, FOURCC_icon);\r\n Icons[I].SaveToStream(MemStream);\r\n EndWriteChunk(MemStream, Tag, 0);\r\n end;\r\n EndWriteChunk(MemStream, TagLIST, 0);\r\n\r\n EndWriteChunk(MemStream, TagRIFF, SizeOf(TJvAniTag));\r\n Stream.CopyFrom(MemStream, 0);\r\n finally\r\n MemStream.Free;\r\n end;\r\nend;\r\n\r\nprocedure TJvAni.LoadFromStream(Stream: TStream);\r\nvar\r\n Data: TMemoryStream;\r\n Size: Longint;\r\nbegin\r\n Size := Stream.Size - Stream.Position;\r\n Data := TMemoryStream.Create;\r\n try\r\n Data.SetSize(Size);\r\n Stream.ReadBuffer(Data.Memory^, Size);\r\n if Size > 0 then\r\n begin\r\n Data.Position := 0;\r\n ReadAniStream(Data);\r\n end;\r\n finally\r\n Data.Free;\r\n end;\r\n if FrameCount > 0 then\r\n Index := 0;\r\nend;\r\n\r\nprocedure TJvAni.SaveToStream(Stream: TStream);\r\nbegin\r\n if IconCount = 0 then\r\n raise EInvalidGraphicOperation.CreateRes(@SInvalidImage);\r\n WriteAniStream(Stream);\r\nend;\r\n\r\nprocedure TJvAni.LoadFromFile(const FileName: string);\r\nvar\r\n Stream: TStream;\r\nbegin\r\n Stream := TFileStream.Create(FileName, fmOpenRead or fmShareDenyNone);\r\n try\r\n try\r\n LoadFromStream(Stream);\r\n except\r\n NewImage;\r\n raise;\r\n end;\r\n finally\r\n Stream.Free;\r\n end;\r\nend;\r\n\r\nprocedure TJvAni.SaveToFile(const FileName: string);\r\nvar\r\n Stream: TStream;\r\nbegin\r\n Stream := TFileStream.Create(FileName, fmCreate or fmShareExclusive);\r\n try\r\n SaveToStream(Stream);\r\n finally\r\n Stream.Free;\r\n end;\r\nend;\r\n\r\nprocedure TJvAni.Draw(ACanvas: TCanvas; const ARect: TRect);\r\nbegin\r\n if Assigned(FIcons) and (FIcons.Count > 0) then\r\n if (Frames[Index] <> nil) and not Frames[Index].Icon.Empty then\r\n DrawRealSizeIcon(ACanvas, Frames[Index].Icon, ARect.Left, ARect.Top);\r\nend;\r\n\r\nprocedure TJvAni.AssignToBitmap(Bitmap: TBitmap; BackColor: TColor;\r\n DecreaseColors, Vertical: Boolean);\r\nvar\r\n I: Integer;\r\n Temp: TBitmap;\r\n Idx: Integer;\r\n R: TRect;\r\nbegin\r\n Temp := TBitmap.Create;\r\n try\r\n if FIcons.Count > 0 then\r\n begin\r\n with Temp do\r\n begin\r\n Monochrome := False;\r\n Canvas.Brush.Color := BackColor;\r\n if Vertical then\r\n begin\r\n Width := Icons[0].Width;\r\n Height := Icons[0].Height * FrameCount;\r\n end\r\n else\r\n begin\r\n Width := Icons[0].Width * FrameCount;\r\n Height := Icons[0].Height;\r\n end;\r\n Canvas.FillRect(Bounds(0, 0, Width, Height));\r\n Idx := Index;\r\n for I := 0 to FrameCount - 1 do\r\n begin\r\n Index := I;\r\n R := Rect(Frames[I].Icon.Width * I * Ord(not Vertical),\r\n Frames[I].Icon.Height * I * Ord(Vertical), 0, 0);\r\n Draw(Canvas, R);\r\n end;\r\n Index := Idx;\r\n end;\r\n if DecreaseColors then\r\n DecreaseBMPColors(Temp, Max(OriginalColors, 16));\r\n end;\r\n Bitmap.Assign(Temp);\r\n finally\r\n Temp.Free;\r\n end;\r\nend;\r\n\r\nprocedure TJvAni.AssignIconsToBitmap(Bitmap: TBitmap; BackColor: TColor;\r\n DecreaseColors, Vertical: Boolean);\r\nvar\r\n I: Integer;\r\n Temp: TBitmap;\r\n Idx: Integer;\r\n R: TRect;\r\nbegin\r\n Temp := TBitmap.Create;\r\n try\r\n if FIcons.Count > 0 then\r\n begin\r\n with Temp do\r\n begin\r\n Monochrome := False;\r\n Canvas.Brush.Color := BackColor;\r\n if Vertical then\r\n begin\r\n Width := Icons[0].Width;\r\n Height := Icons[0].Height * IconCount;\r\n end\r\n else\r\n begin\r\n Width := Icons[0].Width * IconCount;\r\n Height := Icons[0].Height;\r\n end;\r\n Canvas.FillRect(Bounds(0, 0, Width, Height));\r\n Idx := Index;\r\n for I := 0 to IconCount - 1 do\r\n begin\r\n Index := I;\r\n R := Rect(Icons[I].Width * I * Ord(not Vertical),\r\n Icons[I].Height * I * Ord(Vertical), 0, 0);\r\n Draw(Canvas, R);\r\n end;\r\n Index := Idx;\r\n end;\r\n if DecreaseColors then\r\n DecreaseBMPColors(Temp, Max(OriginalColors, 16));\r\n end;\r\n Bitmap.Assign(Temp);\r\n finally\r\n Temp.Free;\r\n end;\r\nend;\r\n\r\n\r\n\r\ninitialization\r\n {$IFDEF UNITVERSIONING}\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n {$ENDIF UNITVERSIONING}\r\n {$IFDEF COMPILER7_UP}\r\n GroupDescendentsWith(TJvAni, TControl);\r\n {$ENDIF COMPILER7_UP}\r\n Classes.RegisterClass(TJvAni);\r\n TPicture.RegisterFileFormat(RsAniExtension, RsAniFilterName, TJvAni);\r\n\r\nfinalization\r\n TPicture.UnregisterGraphicClass(TJvAni);\r\n {$IFDEF UNITVERSIONING}\r\n UnregisterUnitVersion(HInstance);\r\n {$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvAnimTitle.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvAnimTitle.PAS, released on 2001-02-28.\r\n\r\nThe Initial Developer of the Original Code is Sbastien Buysse [sbuysse att buypin dott com]\r\nPortions created by Sbastien Buysse are Copyright (C) 2001 Sbastien Buysse.\r\nAll Rights Reserved.\r\n\r\nContributor(s): Michael Beck [mbeck att bigfoot dott com].\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvAnimTitle.pas 13104 2011-09-07 06:50:43Z obones $\r\n\r\nunit JvAnimTitle;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Classes, Controls, ExtCtrls, Forms,\r\n JvComponentBase;\r\n\r\ntype\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64 or pidOSX32)]\r\n {$ENDIF RTL230_UP}\r\n TJvAnimTitle = class(TJvComponent)\r\n private\r\n FTimer: TTimer;\r\n FEnabled: Boolean;\r\n FTitle: string;\r\n FCurrentTitle: string;\r\n FDelay: Integer;\r\n FSens: Boolean;\r\n FForm: TCustomForm;\r\n FBlink: Integer;\r\n FBlinked: Integer;\r\n FBlinking: Boolean;\r\n procedure SetTitle(const NewTitle: string);\r\n procedure SetEnabled(NewEnable: Boolean);\r\n procedure SetDelay(NewDelay: Integer);\r\n procedure AnimateTitle(Sender: TObject);\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n published\r\n property Title: string read FTitle write SetTitle;\r\n property Enabled: Boolean read FEnabled write SetEnabled default False;\r\n property Delay: Integer read FDelay write SetDelay default 50;\r\n property Blink: Integer read FBlink write FBlink default 5;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvAnimTitle.pas $';\r\n Revision: '$Revision: 13104 $';\r\n Date: '$Date: 2011-09-07 08:50:43 +0200 (mer. 07 sept. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\n\r\nconstructor TJvAnimTitle.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FEnabled := False;\r\n FDelay := 50;\r\n FBlink := 5;\r\n FForm := GetParentForm(TControl(AOwner));\r\n FTitle := FForm.Caption;\r\n FSens := True;\r\n FBlinking := False;\r\n FBlinked := 0;\r\n\r\n FTimer := TTimer.Create(Self);\r\n FTimer.Enabled := FEnabled;\r\n FTimer.Interval := FDelay;\r\n FTimer.OnTimer := AnimateTitle;\r\nend;\r\n\r\ndestructor TJvAnimTitle.Destroy;\r\nbegin\r\n FTimer.Free;\r\n if not (csDestroying in FForm.ComponentState) then\r\n FForm.Caption := FTitle;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvAnimTitle.AnimateTitle(Sender: TObject);\r\nbegin\r\n if FBlinking then\r\n begin\r\n // (rom) this is a bad implementation better try to manipulate\r\n // (rom) the WM_GETTEXT and WM_SETTEXT to the Form window\r\n if FForm.Caption = Title then\r\n FForm.Caption := ''\r\n else\r\n begin\r\n FForm.Caption := Title;\r\n Inc(FBlinked);\r\n if FBlinked >= Blink then\r\n begin\r\n FBlinking := False;\r\n FBlinked := 0;\r\n end;\r\n end;\r\n end\r\n else\r\n begin\r\n if FSens then\r\n begin\r\n if Length(FCurrentTitle) = Length(Title) then\r\n begin\r\n FSens := False;\r\n if Blink > 0 then\r\n FBlinking := True;\r\n end\r\n else\r\n FCurrentTitle := FCurrentTitle + Title[Length(FCurrentTitle) + 1];\r\n end\r\n else\r\n if FCurrentTitle = '' then\r\n FSens := True\r\n else\r\n SetLength(FCurrentTitle, Length(FCurrentTitle) - 1);\r\n {$IFDEF UNIX}\r\n if FCurrentTitle = '' then\r\n FForm.Caption := ' ' // else caption becomes <1>\r\n else\r\n {$ENDIF UNIX}\r\n FForm.Caption := FCurrentTitle;\r\n end;\r\nend;\r\n\r\nprocedure TJvAnimTitle.SetTitle(const NewTitle: string);\r\nbegin\r\n FTitle := NewTitle;\r\n FCurrentTitle := '';\r\n FSens := True;\r\nend;\r\n\r\nprocedure TJvAnimTitle.SetEnabled(NewEnable: Boolean);\r\nbegin\r\n FEnabled := NewEnable;\r\n FTimer.Enabled := FEnabled;\r\nend;\r\n\r\nprocedure TJvAnimTitle.SetDelay(NewDelay: Integer);\r\nbegin\r\n FDelay := NewDelay;\r\n FTimer.Interval := FDelay;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvAnimate.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvAnimate.PAS, released on 2001-02-28.\r\n\r\nThe Initial Developer of the Original Code is Sbastien Buysse [sbuysse att buypin dott com]\r\nPortions created by Sbastien Buysse are Copyright (C) 2001 Sbastien Buysse.\r\nAll Rights Reserved.\r\n\r\nContributor(s): Michael Beck [mbeck att bigfoot dott com].\r\n Andr Snepvangers [asn att xs4all dott nl]\r\n\r\n2003-01-19 - (asn) support for CLX\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvAnimate.pas 13104 2011-09-07 06:50:43Z obones $\r\n\r\nunit JvAnimate;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Classes, Controls,\r\n JvThemes, JvExComCtrls;\r\n\r\ntype\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvAnimate = class(TJvExAnimate)\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n published\r\n property HintColor;\r\n property OnMouseEnter;\r\n property OnMouseLeave;\r\n property OnParentColorChange;\r\n property OnClick;\r\n property OnDblClick;\r\n property OnDragDrop;\r\n property OnDragOver;\r\n property OnEndDrag;\r\n property OnKeyDown;\r\n property OnKeyPress;\r\n property OnKeyUp;\r\n property OnStartDrag;\r\n property OnResize;\r\n property OnMouseDown;\r\n property OnMouseUp;\r\n property OnMouseMove;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvAnimate.pas $';\r\n Revision: '$Revision: 13104 $';\r\n Date: '$Date: 2011-09-07 08:50:43 +0200 (mer. 07 sept. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\n\r\nconstructor TJvAnimate.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n IncludeThemeStyle(Self, [csParentBackground]);\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvAnimatedImage.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvxAnimate.PAS, released on 2002-07-04.\r\n\r\nThe Initial Developers of the Original Code are: Fedor Koshevnikov, Igor Pavluk and Serge Korolev\r\nCopyright (c) 1997, 1998 Fedor Koshevnikov, Igor Pavluk and Serge Korolev\r\nCopyright (c) 2001,2002 SGB Software\r\nAll Rights Reserved.\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvAnimatedImage.pas 13104 2011-09-07 06:50:43Z obones $\r\n\r\nunit JvAnimatedImage;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n {$IFDEF MSWINDOWS}\r\n Windows, Messages,\r\n {$ENDIF MSWINDOWS}\r\n {$IFDEF HAS_UNIT_LIBC}\r\n Libc,\r\n {$ENDIF HAS_UNIT_LIBC}\r\n Types,\r\n Graphics, Controls,\r\n Classes,\r\n JvTimer, JvComponent;\r\n\r\ntype\r\n TJvImageControl = class(TJvGraphicControl)\r\n private\r\n FDrawing: Boolean;\r\n FPaintBuffered: Boolean;\r\n FLock: TRTLCriticalSection;\r\n protected\r\n FGraphic: TGraphic;\r\n function DoPaletteChange: Boolean;\r\n procedure Paint; override;\r\n procedure BufferedPaint; virtual;\r\n procedure DoPaintImage; virtual; abstract;\r\n procedure DoPaintControl;\r\n procedure PaintDesignRect;\r\n procedure PaintImage;\r\n procedure PictureChanged;\r\n procedure Lock;\r\n procedure Unlock;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n published\r\n property Height default 105;\r\n property Width default 105;\r\n end;\r\n\r\n TGlyphOrientation = (goHorizontal, goVertical);\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvAnimatedImage = class(TJvImageControl)\r\n private\r\n FActive: Boolean;\r\n FGlyph: TBitmap;\r\n FImageWidth: Integer;\r\n FImageHeight: Integer;\r\n FInactiveGlyph: Integer;\r\n FOrientation: TGlyphOrientation;\r\n FTimer: TJvTimer;\r\n FNumGlyphs: Integer;\r\n FGlyphNum: Integer;\r\n FCenter: Boolean;\r\n FStretch: Boolean;\r\n FTransparentColor: TColor;\r\n FTimerRepaint: Boolean;\r\n FOnFrameChanged: TNotifyEvent;\r\n FOnStart: TNotifyEvent;\r\n FOnStop: TNotifyEvent;\r\n FAsyncDrawing: Boolean;\r\n FTransparent: Boolean;\r\n procedure DefineBitmapSize;\r\n procedure ResetImageBounds;\r\n function GetInterval: Cardinal;\r\n procedure SetInterval(Value: Cardinal);\r\n procedure SetActive(Value: Boolean);\r\n procedure SetAsyncDrawing(Value: Boolean);\r\n procedure SetCenter(Value: Boolean);\r\n procedure SetOrientation(Value: TGlyphOrientation);\r\n procedure SetGlyph(Value: TBitmap);\r\n procedure SetGlyphNum(Value: Integer);\r\n procedure SetInactiveGlyph(Value: Integer);\r\n procedure SetNumGlyphs(Value: Integer);\r\n procedure SetStretch(Value: Boolean);\r\n procedure SetTransparentColor(Value: TColor);\r\n procedure SetTransparent(const Value:Boolean);\r\n procedure ReadOpaque(Reader: TReader);\r\n procedure ImageChanged(Sender: TObject);\r\n procedure UpdateInactive;\r\n procedure TimerExpired(Sender: TObject);\r\n function TransparentStored: Boolean;\r\n protected\r\n function CanAutoSize(var NewWidth, NewHeight: Integer): Boolean; override;\r\n function GetPalette: HPALETTE; override;\r\n procedure AdjustSize; override;\r\n procedure Loaded; override;\r\n procedure BufferedPaint; override;\r\n procedure DoPaintImage; override;\r\n procedure FrameChanged; dynamic;\r\n procedure Start; dynamic;\r\n procedure Stop; dynamic;\r\n procedure DefineProperties(Filer: TFiler); override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n published\r\n property Align;\r\n property Anchors;\r\n property Constraints;\r\n property AutoSize default True;\r\n property AsyncDrawing: Boolean read FAsyncDrawing write SetAsyncDrawing default False;\r\n property Active: Boolean read FActive write SetActive default False;\r\n property Center: Boolean read FCenter write SetCenter default False;\r\n property Orientation: TGlyphOrientation read FOrientation write SetOrientation\r\n default goHorizontal;\r\n property Glyph: TBitmap read FGlyph write SetGlyph;\r\n property GlyphNum: Integer read FGlyphNum write SetGlyphNum default 0;\r\n property Interval: Cardinal read GetInterval write SetInterval default 100;\r\n property NumGlyphs: Integer read FNumGlyphs write SetNumGlyphs default 1;\r\n property InactiveGlyph: Integer read FInactiveGlyph write SetInactiveGlyph default -1;\r\n property TransparentColor: TColor read FTransparentColor write SetTransparentColor\r\n stored TransparentStored;\r\n property Color;\r\n property Cursor;\r\n property Transparent: Boolean read FTransparent write SetTransparent default False;\r\n property DragCursor;\r\n property OnEndDock;\r\n property OnStartDock;\r\n property DragMode;\r\n property ParentColor default True;\r\n property ParentShowHint;\r\n property PopupMenu;\r\n property ShowHint;\r\n property Stretch: Boolean read FStretch write SetStretch default True;\r\n property Visible;\r\n property OnClick;\r\n property OnDblClick;\r\n property OnMouseMove;\r\n property OnMouseDown;\r\n property OnMouseUp;\r\n property OnDragOver;\r\n property OnDragDrop;\r\n property OnEndDrag;\r\n property OnStartDrag;\r\n property OnContextPopup;\r\n property OnFrameChanged: TNotifyEvent read FOnFrameChanged write FOnFrameChanged;\r\n property OnStart: TNotifyEvent read FOnStart write FOnStart;\r\n property OnStop: TNotifyEvent read FOnStop write FOnStop;\r\n end;\r\n\r\ntype\r\n TJvLockedBitmap = class(TBitmap)\r\n protected\r\n procedure Draw(ACanvas: TCanvas; const Rect: TRect); override;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvAnimatedImage.pas $';\r\n Revision: '$Revision: 13104 $';\r\n Date: '$Date: 2011-09-07 08:50:43 +0200 (mer. 07 sept. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n Forms,\r\n //JclSysUtils,\r\n JvConsts, JvJVCLUtils;\r\n\r\n//=== { TJvLockedBitmap } ====================================================\r\n\r\nprocedure TJvLockedBitmap.Draw(ACanvas: TCanvas; const Rect: TRect);\r\nbegin\r\n if not Empty then\r\n Canvas.Lock;\r\n try\r\n inherited Draw(ACanvas, Rect);\r\n finally\r\n if not Empty then\r\n Canvas.Unlock;\r\n end;\r\nend;\r\n\r\n//=== { TJvImageControl } ====================================================\r\n\r\nconstructor TJvImageControl.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n InitializeCriticalSection(FLock);\r\n ControlStyle := ControlStyle + [csClickEvents, csCaptureMouse, csOpaque,\r\n csReplicatable, csDoubleClicks];\r\n Height := 105;\r\n Width := 105;\r\n ParentColor := True;\r\nend;\r\n\r\ndestructor TJvImageControl.Destroy;\r\nbegin\r\n DeleteCriticalSection(FLock);\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvImageControl.Lock;\r\nbegin\r\n EnterCriticalSection(FLock);\r\nend;\r\n\r\nprocedure TJvImageControl.Unlock;\r\nbegin\r\n LeaveCriticalSection(FLock);\r\nend;\r\n\r\nprocedure TJvImageControl.PaintImage;\r\nvar\r\n Save: Boolean;\r\nbegin\r\n with Canvas do\r\n begin\r\n Brush.Color := Color;\r\n FillRect(Bounds(0, 0, ClientWidth, ClientHeight));\r\n end;\r\n Save := FDrawing;\r\n FDrawing := True;\r\n try\r\n DoPaintImage;\r\n finally\r\n FDrawing := Save;\r\n end;\r\nend;\r\n\r\nprocedure TJvImageControl.Paint;\r\nvar\r\n Bmp: TBitmap;\r\n DC: HDC;\r\nbegin\r\n Bmp := TJvLockedBitmap.Create;\r\n try\r\n Bmp.Width := ClientWidth;\r\n Bmp.Height := ClientHeight;\r\n Bmp.Canvas.Lock;\r\n DC := Canvas.Handle;\r\n try\r\n Canvas.Handle := Bmp.Canvas.Handle;\r\n FPaintBuffered := True;\r\n try\r\n BufferedPaint;\r\n finally\r\n FPaintBuffered := False;\r\n end;\r\n finally\r\n Canvas.Handle := DC;\r\n Canvas.Draw(0, 0, Bmp);\r\n Bmp.Canvas.Unlock;\r\n end;\r\n finally\r\n Bmp.Free;\r\n end;\r\nend;\r\n\r\nprocedure TJvImageControl.BufferedPaint;\r\nbegin\r\nend;\r\n\r\nprocedure TJvImageControl.PaintDesignRect;\r\nbegin\r\n if csDesigning in ComponentState then\r\n with Canvas do\r\n begin\r\n Pen.Style := psDash;\r\n Brush.Style := bsClear;\r\n Rectangle(0, 0, Width, Height);\r\n end;\r\nend;\r\n\r\nprocedure TJvImageControl.DoPaintControl;\r\nvar\r\n DC: HDC;\r\nbegin\r\n if GetCurrentThreadID = MainThreadID then\r\n begin\r\n Repaint;\r\n Exit;\r\n end;\r\n DC := GetDC(Parent.Handle);\r\n try\r\n IntersectClipRect(DC, Left, Top, Left + Width, Top + Height);\r\n MoveWindowOrg(DC, Left, Top);\r\n Perform(WM_PAINT, DC, 0);\r\n finally\r\n ReleaseDC(Parent.Handle, DC);\r\n end;\r\nend;\r\n\r\nfunction TJvImageControl.DoPaletteChange: Boolean;\r\nvar\r\n ParentForm: TCustomForm;\r\n Tmp: TGraphic;\r\nbegin\r\n Result := False;\r\n Tmp := FGraphic;\r\n if Visible and (not (csLoading in ComponentState)) and\r\n (Tmp <> nil) and Tmp.PaletteModified then\r\n begin\r\n if GetPalette <> 0 then\r\n begin\r\n ParentForm := GetParentForm(Self);\r\n if Assigned(ParentForm) and ParentForm.Active and ParentForm.HandleAllocated then\r\n begin\r\n if FDrawing then\r\n ParentForm.Perform(WM_QUERYNEWPALETTE, 0, 0)\r\n else\r\n PostMessage(ParentForm.Handle, WM_QUERYNEWPALETTE, 0, 0);\r\n Result := True;\r\n Tmp.PaletteModified := False;\r\n end;\r\n end\r\n else\r\n Tmp.PaletteModified := False;\r\n end;\r\nend;\r\n\r\nprocedure TJvImageControl.PictureChanged;\r\nbegin\r\n if not (csDestroying in ComponentState) then\r\n begin\r\n AdjustSize;\r\n if FGraphic <> nil then\r\n if DoPaletteChange and FDrawing then\r\n Update;\r\n if not FDrawing then\r\n Invalidate;\r\n end;\r\nend;\r\n\r\n//=== { TJvAnimatedImage } ===================================================\r\n\r\nconstructor TJvAnimatedImage.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FTimer := TJvTimer.Create(Self);\r\n FTimer.Enabled := False;\r\n FTimer.Interval := 100;\r\n AutoSize := True;\r\n FTransparent := False;\r\n FGlyph := TJvLockedBitmap.Create;\r\n FGraphic := FGlyph;\r\n FGlyph.OnChange := ImageChanged;\r\n FNumGlyphs := 1;\r\n FInactiveGlyph := -1;\r\n FTransparentColor := clNone;\r\n FOrientation := goHorizontal;\r\n FStretch := True;\r\nend;\r\n\r\ndestructor TJvAnimatedImage.Destroy;\r\nbegin\r\n Destroying;\r\n FOnFrameChanged := nil;\r\n FOnStart := nil;\r\n FOnStop := nil;\r\n FGlyph.OnChange := nil;\r\n Active := False;\r\n FGlyph.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvAnimatedImage.Loaded;\r\nbegin\r\n inherited Loaded;\r\n ResetImageBounds;\r\n UpdateInactive;\r\nend;\r\n\r\nfunction TJvAnimatedImage.GetPalette: HPALETTE;\r\nbegin\r\n Result := 0;\r\n if not FGlyph.Empty then\r\n Result := FGlyph.Palette;\r\nend;\r\n\r\nprocedure TJvAnimatedImage.ImageChanged(Sender: TObject);\r\nbegin\r\n Lock;\r\n try\r\n FTransparentColor := FGlyph.TransparentColor and not PaletteMask;\r\n finally\r\n Unlock;\r\n end;\r\n DefineBitmapSize;\r\n PictureChanged;\r\nend;\r\n\r\nprocedure TJvAnimatedImage.UpdateInactive;\r\nbegin\r\n if (not Active) and (FInactiveGlyph >= 0) and\r\n (FInactiveGlyph < FNumGlyphs) and (FGlyphNum <> FInactiveGlyph) then\r\n begin\r\n Lock;\r\n try\r\n FGlyphNum := FInactiveGlyph;\r\n finally\r\n Unlock;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJvAnimatedImage.TransparentStored: Boolean;\r\nbegin\r\n Result := (FGlyph.Empty and (FTransparentColor <> clNone)) or\r\n ((FGlyph.TransparentColor and not PaletteMask) <> FTransparentColor);\r\nend;\r\n\r\nprocedure TJvAnimatedImage.SetTransparent(const Value:Boolean);\r\nbegin\r\n if Value <> FTransparent then\r\n begin\r\n Lock;\r\n try\r\n FTransparent := Value;\r\n finally\r\n Unlock;\r\n end;\r\n PictureChanged;\r\n end;\r\nend;\r\n\r\nprocedure TJvAnimatedImage.SetTransparentColor(Value: TColor);\r\nbegin\r\n if Value <> TransparentColor then\r\n begin\r\n Lock;\r\n try\r\n FTransparentColor := Value;\r\n finally\r\n Unlock;\r\n end;\r\n PictureChanged;\r\n end;\r\nend;\r\n\r\nprocedure TJvAnimatedImage.SetOrientation(Value: TGlyphOrientation);\r\nbegin\r\n if FOrientation <> Value then\r\n begin\r\n Lock;\r\n try\r\n FOrientation := Value;\r\n finally\r\n Unlock;\r\n end;\r\n ImageChanged(FGlyph);\r\n end;\r\nend;\r\n\r\nprocedure TJvAnimatedImage.SetGlyph(Value: TBitmap);\r\nbegin\r\n Lock;\r\n try\r\n FGlyph.Assign(Value);\r\n finally\r\n Unlock;\r\n end;\r\nend;\r\n\r\nprocedure TJvAnimatedImage.SetStretch(Value: Boolean);\r\nbegin\r\n if Value <> FStretch then\r\n begin\r\n Lock;\r\n try\r\n FStretch := Value;\r\n finally\r\n Unlock;\r\n end;\r\n PictureChanged;\r\n if Active then\r\n Repaint;\r\n end;\r\nend;\r\n\r\nprocedure TJvAnimatedImage.SetCenter(Value: Boolean);\r\nbegin\r\n if Value <> FCenter then\r\n begin\r\n Lock;\r\n try\r\n FCenter := Value;\r\n finally\r\n Unlock;\r\n end;\r\n PictureChanged;\r\n if Active then\r\n Repaint;\r\n end;\r\nend;\r\n\r\nprocedure TJvAnimatedImage.SetGlyphNum(Value: Integer);\r\nbegin\r\n if Value <> FGlyphNum then\r\n begin\r\n if (Value < FNumGlyphs) and (Value >= 0) then\r\n begin\r\n Lock;\r\n try\r\n FGlyphNum := Value;\r\n finally\r\n Unlock;\r\n end;\r\n UpdateInactive;\r\n FrameChanged;\r\n PictureChanged;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvAnimatedImage.SetInactiveGlyph(Value: Integer);\r\nbegin\r\n if Value < 0 then\r\n Value := -1;\r\n if Value <> FInactiveGlyph then\r\n begin\r\n if (Value < FNumGlyphs) or (csLoading in ComponentState) then\r\n begin\r\n Lock;\r\n try\r\n FInactiveGlyph := Value;\r\n UpdateInactive;\r\n finally\r\n Unlock;\r\n end;\r\n FrameChanged;\r\n PictureChanged;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvAnimatedImage.SetNumGlyphs(Value: Integer);\r\nbegin\r\n Lock;\r\n try\r\n FNumGlyphs := Value;\r\n if FInactiveGlyph >= FNumGlyphs then\r\n begin\r\n FInactiveGlyph := -1;\r\n FGlyphNum := 0;\r\n end\r\n else\r\n UpdateInactive;\r\n ResetImageBounds;\r\n finally\r\n Unlock;\r\n end;\r\n FrameChanged;\r\n PictureChanged;\r\nend;\r\n\r\nprocedure TJvAnimatedImage.DefineBitmapSize;\r\nbegin\r\n Lock;\r\n try\r\n FNumGlyphs := 1;\r\n FGlyphNum := 0;\r\n FImageWidth := 0;\r\n FImageHeight := 0;\r\n if (FOrientation = goHorizontal) and (FGlyph.Height > 0) and\r\n (FGlyph.Width mod FGlyph.Height = 0) then\r\n FNumGlyphs := FGlyph.Width div FGlyph.Height\r\n else\r\n if (FOrientation = goVertical) and (FGlyph.Width > 0) and\r\n (FGlyph.Height mod FGlyph.Width = 0) then\r\n FNumGlyphs := FGlyph.Height div FGlyph.Width;\r\n ResetImageBounds;\r\n finally\r\n Unlock;\r\n end;\r\nend;\r\n\r\nprocedure TJvAnimatedImage.ResetImageBounds;\r\nbegin\r\n if FNumGlyphs < 1 then\r\n FNumGlyphs := 1;\r\n if FOrientation = goHorizontal then\r\n begin\r\n FImageHeight := FGlyph.Height;\r\n FImageWidth := FGlyph.Width div FNumGlyphs;\r\n end\r\n else\r\n {if Orientation = goVertical then}\r\n begin\r\n FImageWidth := FGlyph.Width;\r\n FImageHeight := FGlyph.Height div FNumGlyphs;\r\n end;\r\nend;\r\n\r\nprocedure TJvAnimatedImage.AdjustSize;\r\nbegin\r\n if not (csReading in ComponentState) then\r\n if AutoSize and (FImageWidth > 0) and (FImageHeight > 0) then\r\n SetBounds(Left, Top, FImageWidth, FImageHeight);\r\nend;\r\n\r\nprocedure TJvAnimatedImage.DoPaintImage;\r\nvar\r\n BmpIndex: Integer;\r\n SrcRect, DstRect: TRect;\r\nbegin\r\n if (not Active) and (FInactiveGlyph >= 0) and\r\n (FInactiveGlyph < FNumGlyphs) then\r\n BmpIndex := FInactiveGlyph\r\n else\r\n BmpIndex := FGlyphNum;\r\n { copy image from parent and back-level controls }\r\n if Transparent then\r\n CopyParentImage(Self, Canvas);\r\n if (FImageWidth > 0) and (FImageHeight > 0) then\r\n begin\r\n if Orientation = goHorizontal then\r\n SrcRect := Bounds(BmpIndex * FImageWidth, 0, FImageWidth, FImageHeight)\r\n else\r\n {if Orientation = goVertical then}\r\n SrcRect := Bounds(0, BmpIndex * FImageHeight, FImageWidth, FImageHeight);\r\n if Stretch then\r\n DstRect := ClientRect\r\n else\r\n if Center then\r\n DstRect := Bounds((ClientWidth - FImageWidth) div 2,\r\n (ClientHeight - FImageHeight) div 2, FImageWidth, FImageHeight)\r\n else\r\n DstRect := Rect(0, 0, FImageWidth, FImageHeight);\r\n StretchBitmapRectTransparent(Canvas, DstRect.Left, DstRect.Top, DstRect.Right - DstRect.Left,\r\n DstRect.Bottom - DstRect.Top, SrcRect, FGlyph, FTransparentColor);\r\n end;\r\nend;\r\n\r\nprocedure TJvAnimatedImage.BufferedPaint;\r\nbegin\r\n PaintImage;\r\n if Transparent or FGlyph.Empty then\r\n PaintDesignRect;\r\nend;\r\n\r\nprocedure TJvAnimatedImage.TimerExpired(Sender: TObject);\r\nbegin\r\n if csPaintCopy in ControlState then\r\n Exit;\r\n if Visible and (FNumGlyphs > 1) and (Parent <> nil) and\r\n Parent.HandleAllocated then\r\n begin\r\n Lock;\r\n try\r\n if FGlyphNum < FNumGlyphs - 1 then\r\n Inc(FGlyphNum)\r\n else\r\n FGlyphNum := 0;\r\n if (FGlyphNum = FInactiveGlyph) and (FNumGlyphs > 1) then\r\n if FGlyphNum < FNumGlyphs - 1 then\r\n Inc(FGlyphNum)\r\n else\r\n FGlyphNum := 0;\r\n Canvas.Lock;\r\n try\r\n FTimerRepaint := True;\r\n if AsyncDrawing and Assigned(FOnFrameChanged) then\r\n FTimer.Synchronize(FrameChanged)\r\n else\r\n FrameChanged;\r\n DoPaintControl;\r\n finally\r\n FTimerRepaint := False;\r\n Canvas.Unlock;\r\n end;\r\n finally\r\n Unlock;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvAnimatedImage.FrameChanged;\r\nbegin\r\n if Assigned(FOnFrameChanged) then\r\n FOnFrameChanged(Self);\r\nend;\r\n\r\nprocedure TJvAnimatedImage.Stop;\r\nbegin\r\n if not (csReading in ComponentState) then\r\n if Assigned(FOnStop) then\r\n FOnStop(Self);\r\nend;\r\n\r\nprocedure TJvAnimatedImage.Start;\r\nbegin\r\n if not (csReading in ComponentState) then\r\n if Assigned(FOnStart) then\r\n FOnStart(Self);\r\nend;\r\n\r\nfunction TJvAnimatedImage.CanAutoSize(var NewWidth, NewHeight: Integer): Boolean;\r\nbegin\r\n Result := True;\r\n if not (csDesigning in ComponentState) and\r\n (FImageWidth > 0) and (FImageHeight > 0) then\r\n begin\r\n if Align in [alNone, alLeft, alRight] then\r\n NewWidth := FImageWidth;\r\n if Align in [alNone, alTop, alBottom] then\r\n NewHeight := FImageHeight;\r\n end;\r\nend;\r\n\r\nprocedure TJvAnimatedImage.SetInterval(Value: Cardinal);\r\nbegin\r\n FTimer.Interval := Value;\r\nend;\r\n\r\nfunction TJvAnimatedImage.GetInterval: Cardinal;\r\nbegin\r\n Result := FTimer.Interval;\r\nend;\r\n\r\nprocedure TJvAnimatedImage.SetActive(Value: Boolean);\r\nbegin\r\n if FActive <> Value then\r\n begin\r\n if Value then\r\n begin\r\n FTimer.OnTimer := TimerExpired;\r\n FTimer.Enabled := True;\r\n FActive := FTimer.Enabled;\r\n Start;\r\n end\r\n else\r\n begin\r\n FTimer.Enabled := False;\r\n FTimer.OnTimer := nil;\r\n FActive := False;\r\n UpdateInactive;\r\n FrameChanged;\r\n Stop;\r\n PictureChanged;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvAnimatedImage.SetAsyncDrawing(Value: Boolean);\r\nbegin\r\n if FAsyncDrawing <> Value then\r\n begin\r\n Lock;\r\n try\r\n {if Value then\r\n HookBitmap;}\r\n if Assigned(FTimer) then\r\n FTimer.SyncEvent := not Value;\r\n FAsyncDrawing := Value;\r\n finally\r\n Unlock;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvAnimatedImage.ReadOpaque(Reader: TReader);\r\nbegin\r\n Transparent := not Reader.ReadBoolean;\r\nend;\r\n\r\nprocedure TJvAnimatedImage.DefineProperties(Filer: TFiler);\r\nbegin\r\n inherited DefineProperties(Filer);\r\n Filer.DefineProperty('Opaque', ReadOpaque, nil, False);\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvAppAnimatedIcon.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvAppAnimatedIcon.PAS, released on 2001-02-28.\r\n\r\nThe Initial Developer of the Original Code is Sbastien Buysse [sbuysse att buypin dott com]\r\nPortions created by Sbastien Buysse are Copyright (C) 2001 Sbastien Buysse.\r\nAll Rights Reserved.\r\n\r\nContributor(s): Michael Beck [mbeck att bigfoot dott com].\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvAppAnimatedIcon.pas 13104 2011-09-07 06:50:43Z obones $\r\n\r\nunit JvAppAnimatedIcon;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Classes, Controls, ExtCtrls, Graphics, ImgList,\r\n JvComponentBase;\r\n\r\ntype\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64 or pidOSX32)]\r\n {$ENDIF RTL230_UP}\r\n TJvAppAnimatedIcon = class(TJvComponent)\r\n private\r\n FActive: Boolean;\r\n FDelay: Cardinal;\r\n FIcons: TImageList;\r\n FTimer: TTimer;\r\n FNumber: Integer;\r\n procedure SetActive(const Value: Boolean);\r\n procedure SetDelay(const Value: Cardinal);\r\n procedure SetIcons(const Value: TImageList);\r\n procedure Animate(Sender: TObject);\r\n protected\r\n procedure Notification(AComponent: TComponent; Operation: TOperation); override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n published\r\n property Active: Boolean read FActive write SetActive default False;\r\n property Delay: Cardinal read FDelay write SetDelay default 100;\r\n property Icons: TImageList read FIcons write SetIcons;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvAppAnimatedIcon.pas $';\r\n Revision: '$Revision: 13104 $';\r\n Date: '$Date: 2011-09-07 08:50:43 +0200 (mer. 07 sept. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n Forms, JvJVCLUtils;\r\n\r\nconstructor TJvAppAnimatedIcon.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FActive := False;\r\n FDelay := 100;\r\n FNumber := 0;\r\n FTimer := TTimer.Create(Self);\r\n FTimer.OnTimer := Animate;\r\n FTimer.Interval := FDelay;\r\n FTimer.Enabled := FActive;\r\nend;\r\n\r\ndestructor TJvAppAnimatedIcon.Destroy;\r\nbegin\r\n FTimer.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvAppAnimatedIcon.Notification(AComponent: TComponent;\r\n Operation: TOperation);\r\nbegin\r\n inherited Notification(AComponent, Operation);\r\n \r\n if Operation = opRemove then\r\n begin\r\n if AComponent = FIcons then\r\n SetIcons(nil);\r\n end;\r\nend;\r\n\r\nprocedure TJvAppAnimatedIcon.Animate(Sender: TObject);\r\n\r\nbegin\r\n if (Icons <> nil) and (Icons.Count <> 0) then\r\n begin\r\n FNumber := (FNumber + 1) mod Icons.Count;\r\n Icons.GetIcon(FNumber, Application.Icon);\r\n end;\r\nend;\r\n\r\nprocedure TJvAppAnimatedIcon.SetActive(const Value: Boolean);\r\nbegin\r\n FActive := Value;\r\n FTimer.Enabled := FActive;\r\nend;\r\n\r\nprocedure TJvAppAnimatedIcon.SetDelay(const Value: Cardinal);\r\nbegin\r\n FDelay := Value;\r\n FTimer.Interval := FDelay;\r\nend;\r\n\r\nprocedure TJvAppAnimatedIcon.SetIcons(const Value: TImageList);\r\nbegin\r\n ReplaceComponentReference(Self, Value, TComponent(FIcons));\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvAppCommand.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvAppCommand.PAS, released on 2005-09-02.\r\n\r\nThe Initial Developer of the Original Code is Robert Marquardt [robert_marquardt att dmx dott de]\r\nPortions created by Robert Marquardt are Copyright (C) 2001 Robert Marquardt.\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvAppCommand.pas 13104 2011-09-07 06:50:43Z obones $\r\n\r\nunit JvAppCommand;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, Messages, SysUtils, Classes, Controls, Forms,\r\n JvComponentBase;\r\n\r\nconst\r\n // from JwaWinUser.pas\r\n WM_APPCOMMAND = $0319;\r\n\r\n // Cmd values\r\n APPCOMMAND_BROWSER_BACKWARD = 1;\r\n APPCOMMAND_BROWSER_FORWARD = 2;\r\n APPCOMMAND_BROWSER_REFRESH = 3;\r\n APPCOMMAND_BROWSER_STOP = 4;\r\n APPCOMMAND_BROWSER_SEARCH = 5;\r\n APPCOMMAND_BROWSER_FAVORITES = 6;\r\n APPCOMMAND_BROWSER_HOME = 7;\r\n APPCOMMAND_VOLUME_MUTE = 8;\r\n APPCOMMAND_VOLUME_DOWN = 9;\r\n APPCOMMAND_VOLUME_UP = 10;\r\n APPCOMMAND_MEDIA_NEXTTRACK = 11;\r\n APPCOMMAND_MEDIA_PREVIOUSTRACK = 12;\r\n APPCOMMAND_MEDIA_STOP = 13;\r\n APPCOMMAND_MEDIA_PLAY_PAUSE = 14;\r\n APPCOMMAND_LAUNCH_MAIL = 15;\r\n APPCOMMAND_LAUNCH_MEDIA_SELECT = 16;\r\n APPCOMMAND_LAUNCH_APP1 = 17;\r\n APPCOMMAND_LAUNCH_APP2 = 18;\r\n APPCOMMAND_BASS_DOWN = 19;\r\n APPCOMMAND_BASS_BOOST = 20;\r\n APPCOMMAND_BASS_UP = 21;\r\n APPCOMMAND_TREBLE_DOWN = 22;\r\n APPCOMMAND_TREBLE_UP = 23;\r\n\r\n APPCOMMAND_MICROPHONE_VOLUME_MUTE = 24;\r\n APPCOMMAND_MICROPHONE_VOLUME_DOWN = 25;\r\n APPCOMMAND_MICROPHONE_VOLUME_UP = 26;\r\n APPCOMMAND_HELP = 27;\r\n APPCOMMAND_FIND = 28;\r\n APPCOMMAND_NEW = 29;\r\n APPCOMMAND_OPEN = 30;\r\n APPCOMMAND_CLOSE = 31;\r\n APPCOMMAND_SAVE = 32;\r\n APPCOMMAND_PRINT = 33;\r\n APPCOMMAND_UNDO = 34;\r\n APPCOMMAND_REDO = 35;\r\n APPCOMMAND_COPY = 36;\r\n APPCOMMAND_CUT = 37;\r\n APPCOMMAND_PASTE = 38;\r\n APPCOMMAND_REPLY_TO_MAIL = 39;\r\n APPCOMMAND_FORWARD_MAIL = 40;\r\n APPCOMMAND_SEND_MAIL = 41;\r\n APPCOMMAND_SPELL_CHECK = 42;\r\n APPCOMMAND_DICTATE_OR_COMMAND_CONTROL_TOGGLE = 43;\r\n APPCOMMAND_MIC_ON_OFF_TOGGLE = 44;\r\n APPCOMMAND_CORRECTION_LIST = 45;\r\n\r\n APPCOMMAND_MEDIA_PLAY = 46;\r\n APPCOMMAND_MEDIA_PAUSE = 47;\r\n APPCOMMAND_MEDIA_RECORD = 48;\r\n APPCOMMAND_MEDIA_FAST_FORWARD = 49;\r\n APPCOMMAND_MEDIA_REWIND = 50;\r\n APPCOMMAND_MEDIA_CHANNEL_UP = 51;\r\n APPCOMMAND_MEDIA_CHANNEL_DOWN = 52;\r\n\r\n // KeyState bit values\r\n MK_LBUTTON = $0001;\r\n MK_RBUTTON = $0002;\r\n MK_SHIFT = $0004;\r\n MK_CONTROL = $0008;\r\n MK_MBUTTON = $0010;\r\n MK_XBUTTON1 = $0020;\r\n MK_XBUTTON2 = $0040;\r\n\r\ntype\r\n // source of app command\r\n TJvAppCommandDevice = (acdKey, acdMouse, acdOEM);\r\n\r\n TJvAppCommandEvent = procedure(Handle: THandle;\r\n Cmd: WORD; Device: TJvAppCommandDevice; KeyState: WORD;\r\n var Handled: Boolean) of object;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvAppCommand = class(TJvComponent)\r\n private\r\n FActive: Boolean;\r\n FOnAppCommand: TJvAppCommandEvent;\r\n FForm: TCustomForm;\r\n procedure SetActive(Value: Boolean);\r\n function NewWndProc(var Msg: TMessage): Boolean;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n published\r\n property Active: Boolean read FActive write SetActive default True;\r\n property OnAppCommand: TJvAppCommandEvent read FOnAppCommand write FOnAppCommand;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvAppCommand.pas $';\r\n Revision: '$Revision: 13104 $';\r\n Date: '$Date: 2011-09-07 08:50:43 +0200 (mer. 07 sept. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\n// Required for outside use (see the MegaDemo for instance)\r\nfunction GET_APPCOMMAND_LPARAM(lParam: LPARAM): WORD;\r\nfunction GET_DEVICE_LPARAM(lParam: LPARAM): WORD;\r\nfunction GET_KEYSTATE_LPARAM(lParam: LPARAM): WORD;\r\n\r\nimplementation\r\n\r\nuses\r\n JvWndProcHook;\r\n\r\nconst\r\n // from JwaWinUser.pas\r\n FAPPCOMMAND_MOUSE = $8000;\r\n FAPPCOMMAND_KEY = 0;\r\n FAPPCOMMAND_OEM = $1000;\r\n FAPPCOMMAND_MASK = $F000;\r\n\r\nfunction GET_APPCOMMAND_LPARAM(lParam: LPARAM): WORD;\r\nbegin\r\n Result := WORD(HIWORD(lParam) and not FAPPCOMMAND_MASK);\r\nend;\r\n\r\nfunction GET_DEVICE_LPARAM(lParam: LPARAM): WORD;\r\nbegin\r\n Result := WORD(HIWORD(lParam) and FAPPCOMMAND_MASK);\r\nend;\r\n\r\nfunction GET_KEYSTATE_LPARAM(lParam: LPARAM): WORD;\r\nbegin\r\n Result := LOWORD(lParam);\r\nend;\r\n\r\n//=== { TJvAppCommand } ======================================================\r\n\r\nconstructor TJvAppCommand.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FForm := GetParentForm(TControl(AOwner));\r\n Active := True;\r\nend;\r\n\r\ndestructor TJvAppCommand.Destroy;\r\nbegin\r\n Active := False;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvAppCommand.SetActive(Value: Boolean);\r\nbegin\r\n if FActive <> Value then\r\n begin\r\n FActive := Value;\r\n if (FForm <> nil) and not (csDesigning in ComponentState) then\r\n if Value then\r\n RegisterWndProcHook(FForm, NewWndProc, hoBeforeMsg)\r\n else\r\n UnregisterWndProcHook(FForm, NewWndProc, hoBeforeMsg);\r\n end;\r\nend;\r\n\r\nfunction TJvAppCommand.NewWndProc(var Msg: TMessage): Boolean;\r\nvar\r\n Dev: TJvAppCommandDevice;\r\nbegin\r\n Result := False;\r\n if (Msg.Msg = WM_APPCOMMAND) and Active then\r\n begin\r\n Msg.Result := 1;\r\n Result := True;\r\n if Assigned(FOnAppCommand) then\r\n begin\r\n case GET_DEVICE_LPARAM(Msg.LParam) of\r\n FAPPCOMMAND_MOUSE:\r\n Dev := acdMouse;\r\n FAPPCOMMAND_OEM:\r\n Dev := acdOEM;\r\n else\r\n Dev := acdKey;\r\n end;\r\n\r\n FOnAppCommand(THandle(Msg.WParam), GET_APPCOMMAND_LPARAM(Msg.LParam),\r\n Dev, GET_KEYSTATE_LPARAM(Msg.LParam), Result);\r\n Msg.Result := Ord(Result);\r\n end;\r\n end;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvAppDBStorage.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvAppDBStorage.pas, released on 2004-02-04.\r\n\r\nThe Initial Developer of the Original Code is Peter Thrnqvist\r\nPortions created by Peter Thrnqvist are Copyright (C) 2004 Peter Thrnqvist\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvAppDBStorage.pas 13191 2012-01-19 20:30:54Z ahuser $\r\n\r\nunit JvAppDBStorage;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n SysUtils, Classes, DB, Variants, DBCtrls,\r\n JvAppStorage, JvTypes;\r\n\r\n// DB table must contain 3 fields for the storage\r\n// performance is probably improved if there is an index on the section and key fields (this can be unique)\r\n// \"section\": string - must support locate!\r\n// \"key\": string - must support locate!\r\n// \"value\": string or memo\r\n\r\ntype\r\n TJvDBStorageWriteEvent = procedure(Sender: TObject; const Section, Key, Value: string) of object;\r\n TJvDBStorageReadEvent = procedure(Sender: TObject; const Section, Key: string; var Value: string) of object;\r\n EJvAppDBStorageError = class(Exception);\r\n\r\n TJvCustomAppDBStorage = class(TJvCustomAppStorage)\r\n private\r\n FSectionLink: TFieldDataLink;\r\n FKeyLink: TFieldDataLink;\r\n FValueLink: TFieldDataLink;\r\n FOnRead: TJvDBStorageReadEvent;\r\n FOnWrite: TJvDBStorageWriteEvent;\r\n FBookmark: {$IFDEF RTL200_UP}TBookmark{$ELSE}TBookmarkStr{$ENDIF RTL200_UP};\r\n FDataSource: TDataSource;\r\n procedure SetDataSource(const Value: TDataSource);\r\n function GetKeyField: string;\r\n function GetSectionField: string;\r\n function GetValueField: string;\r\n procedure SetKeyField(const Value: string);\r\n procedure SetSectionField(const Value: string);\r\n procedure SetValueField(const Value: string);\r\n protected\r\n function FieldsAssigned: Boolean;\r\n procedure EnumFolders(const Path: string; const Strings: TStrings;\r\n const ReportListAsValue: Boolean = True); override;\r\n procedure EnumValues(const Path: string; const Strings: TStrings;\r\n const ReportListAsValue: Boolean = True); override;\r\n function PathExistsInt(const Path: string): Boolean; override;\r\n function IsFolderInt(const Path: string; ListIsValue: Boolean = True): Boolean; override;\r\n procedure RemoveValue(const Section, Key: string);\r\n procedure DeleteSubTreeInt(const Path: string); override;\r\n\r\n function ValueStoredInt(const Path: string): Boolean; override;\r\n procedure DeleteValueInt(const Path: string); override;\r\n function DoReadInteger(const Path: string; Default: Integer): Integer; override;\r\n procedure DoWriteInteger(const Path: string; Value: Integer); override;\r\n function DoReadFloat(const Path: string; Default: Extended): Extended; override;\r\n procedure DoWriteFloat(const Path: string; Value: Extended); override;\r\n function DoReadString(const Path: string; const Default: string): string; override;\r\n procedure DoWriteString(const Path: string; const Value: string); override;\r\n function DoReadBinary(const Path: string; Buf: TJvBytes; BufSize: Integer): Integer; override;\r\n procedure DoWriteBinary(const Path: string; const Buf: TJvBytes; BufSize: Integer); override;\r\n procedure Notification(AComponent: TComponent; Operation: TOperation); override;\r\n function SectionExists(const Path: string; RestorePosition: Boolean): Boolean;\r\n function ValueExists(const Section, Key: string; RestorePosition: Boolean): Boolean;\r\n function ReadValue(const Section, Key: string): string; virtual;\r\n procedure WriteValue(const Section, Key, Value: string); virtual;\r\n procedure StoreDataset;\r\n procedure RestoreDataset;\r\n function GetPhysicalReadOnly: Boolean; override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n protected\r\n property DataSource: TDataSource read FDataSource write SetDataSource;\r\n property KeyField: string read GetKeyField write SetKeyField;\r\n property SectionField: string read GetSectionField write SetSectionField;\r\n property ValueField: string read GetValueField write SetValueField;\r\n property OnRead: TJvDBStorageReadEvent read FOnRead write FOnRead;\r\n property OnWrite: TJvDBStorageWriteEvent read FOnWrite write FOnWrite;\r\n end;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvAppDBStorage = class(TJvCustomAppDBStorage)\r\n published\r\n property ReadOnly;\r\n\r\n property DataSource;\r\n property FlushOnDestroy;\r\n property KeyField;\r\n property SectionField;\r\n property SubStorages;\r\n property ValueField;\r\n\r\n property OnRead;\r\n property OnWrite;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvAppDBStorage.pas $';\r\n Revision: '$Revision: 13191 $';\r\n Date: '$Date: 2012-01-19 21:30:54 +0100 (jeu. 19 janv. 2012) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n {$IFDEF SUPPORTS_INLINE}\r\n Windows,\r\n {$ENDIF SUPPORTS_INLINE}\r\n JclMime,\r\n JvJCLUtils, JvResources, JclStrings, JvJVCLUtils;\r\n\r\nconstructor TJvCustomAppDBStorage.Create(AOwner: TComponent);\r\nbegin\r\n // (p3) create these before calling inherited (AV's otherwise)\r\n FSectionLink := TFieldDataLink.Create;\r\n FKeyLink := TFieldDataLink.Create;\r\n FValueLink := TFieldDataLink.Create;\r\n inherited Create(AOwner);\r\nend;\r\n\r\ndestructor TJvCustomAppDBStorage.Destroy;\r\nbegin\r\n DataSource := nil;\r\n FreeAndNil(FSectionLink);\r\n FreeAndNil(FKeyLink);\r\n FreeAndNil(FValueLink);\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvCustomAppDBStorage.DeleteSubTreeInt(const Path: string);\r\nbegin\r\n if FieldsAssigned then\r\n begin\r\n StoreDataset;\r\n try\r\n while SectionExists(Path, False) do\r\n DataSource.DataSet.Delete;\r\n finally\r\n RestoreDataset;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomAppDBStorage.DeleteValueInt(const Path: string);\r\nvar\r\n Section: string;\r\n Key: string;\r\nbegin\r\n SplitKeyPath(Path, Section, Key);\r\n if FieldsAssigned then\r\n begin\r\n StoreDataset;\r\n try\r\n while ValueExists(Section, Key, False) do\r\n DataSource.DataSet.Delete;\r\n finally\r\n RestoreDataset;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJvCustomAppDBStorage.DoReadBinary(const Path: string; Buf: TJvBytes; BufSize: Integer): Integer;\r\nvar\r\n Value: AnsiString;\r\nbegin\r\n raise EJvAppDBStorageError.CreateRes(@RsENotSupported);\r\n // TODO -cTESTING -oJVCL: NOT TESTED!!!\r\n Value := JclMime.MimeDecodeString(AnsiString(DoReadString(Path, ''))); // the cast to AnsiString converts with loss under D2009\r\n Result := Length(Value);\r\n if Result > BufSize then\r\n raise EJvAppDBStorageError.CreateResFmt(@RsEBufTooSmallFmt, [Result]);\r\n if Length(Value) > 0 then\r\n Move(Value[1], Buf, Result * SizeOf(AnsiChar));\r\nend;\r\n\r\nfunction TJvCustomAppDBStorage.DoReadFloat(const Path: string; Default: Extended): Extended;\r\nbegin\r\n // NOTE: StrToFloatDefIgnoreInvalidCharacters now called JvSafeStrToFloatDef:\r\n Result := JvSafeStrToFloatDef(DoReadString(Path, ''), Default);\r\nend;\r\n\r\nfunction TJvCustomAppDBStorage.DoReadInteger(const Path: string; Default: Integer): Integer;\r\nbegin\r\n Result := StrToIntDef(DoReadString(Path, ''), Default);\r\nend;\r\n\r\nfunction TJvCustomAppDBStorage.DoReadString(const Path: string;\r\n const Default: string): string;\r\nvar\r\n Section: string;\r\n Key: string;\r\nbegin\r\n SplitKeyPath(Path, Section, Key);\r\n Result := ReadValue(Section, Key);\r\n if Result = '' then\r\n Result := Default;\r\nend;\r\n\r\nprocedure TJvCustomAppDBStorage.DoWriteBinary(const Path: string;\r\n const Buf: TJvBytes; BufSize: Integer);\r\nvar\r\n Value, Buf1: AnsiString;\r\nbegin\r\n raise EJvAppDBStorageError.CreateRes(@RsENotSupported);\r\n // TODO -cTESTING -oJVCL: NOT TESTED!!!\r\n SetLength(Value, BufSize);\r\n if BufSize > 0 then\r\n begin\r\n SetLength(Buf1, BufSize);\r\n Move(Buf, Buf1[1], BufSize);\r\n JclMime.MimeEncode(Buf1[1], BufSize, Value[1]);\r\n DoWriteString(Path, string(Value));\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomAppDBStorage.DoWriteFloat(const Path: string; Value: Extended);\r\nbegin\r\n WriteBinary(Path, @Value, SizeOf(Value));\r\nend;\r\n\r\nprocedure TJvCustomAppDBStorage.DoWriteInteger(const Path: string;Value: Integer);\r\nbegin\r\n DoWriteString(Path, IntToStr(Value));\r\nend;\r\n\r\nprocedure TJvCustomAppDBStorage.DoWriteString(const Path: string; const Value: string);\r\nvar\r\n Section: string;\r\n Key: string;\r\nbegin\r\n SplitKeyPath(Path, Section, Key);\r\n WriteValue(Section, Key, Value);\r\nend;\r\n\r\nprocedure TJvCustomAppDBStorage.EnumFolders(const Path: string; const Strings: TStrings;\r\n const ReportListAsValue: Boolean);\r\nbegin\r\n raise EJvAppDBStorageError.CreateRes(@RsENotSupported);\r\nend;\r\n\r\nprocedure TJvCustomAppDBStorage.EnumValues(const Path: string; const Strings: TStrings;\r\n const ReportListAsValue: Boolean);\r\nbegin\r\n raise EJvAppDBStorageError.CreateRes(@RsENotSupported);\r\nend;\r\n\r\nfunction TJvCustomAppDBStorage.FieldsAssigned: Boolean;\r\nbegin\r\n Result := (FSectionLink.Field <> nil) and (FKeyLink.Field <> nil) and (FValueLink.Field <> nil);\r\nend;\r\n\r\nfunction TJvCustomAppDBStorage.GetKeyField: string;\r\nbegin\r\n Result := FKeyLink.FieldName;\r\nend;\r\n\r\nfunction TJvCustomAppDBStorage.GetSectionField: string;\r\nbegin\r\n Result := FSectionLink.FieldName;\r\nend;\r\n\r\nfunction TJvCustomAppDBStorage.GetValueField: string;\r\nbegin\r\n Result := FValueLink.FieldName;\r\nend;\r\n\r\nfunction TJvCustomAppDBStorage.IsFolderInt(const Path: string;\r\n ListIsValue: Boolean): Boolean;\r\nbegin\r\n { TODO -oJVCL -cTESTING : Is this correct implementation? }\r\n Result := SectionExists(StrEnsureNoPrefix(PathDelim, Path), True);\r\nend;\r\n\r\nprocedure TJvCustomAppDBStorage.Notification(AComponent: TComponent; Operation: TOperation);\r\nbegin\r\n inherited Notification(AComponent, Operation);\r\n if (Operation = opRemove) and not (csDestroying in ComponentState) then\r\n if AComponent = DataSource then\r\n DataSource := nil;\r\nend;\r\n\r\nfunction TJvCustomAppDBStorage.PathExistsInt(const Path: string): Boolean;\r\nbegin\r\n { TODO -oJVCL -cTESTING : Is this correct implementation? }\r\n Result := SectionExists(StrEnsureNoPrefix(PathDelim, Path), True);\r\nend;\r\n\r\nfunction TJvCustomAppDBStorage.ReadValue(const Section, Key: string): string;\r\nbegin\r\n if ValueExists(Section, Key, False) then\r\n Result := FValueLink.Field.AsString\r\n else\r\n Result := '';\r\n // always call event\r\n if Assigned(FOnRead) then\r\n FOnRead(Self, Section, Key, Result);\r\nend;\r\n\r\nprocedure TJvCustomAppDBStorage.RemoveValue(const Section, Key: string);\r\nbegin\r\n { TODO -oJVCL -cTESTING : NOT TESTED!!! }\r\n if ValueExists(Section, Key, False) then\r\n FValueLink.Field.Clear;\r\nend;\r\n\r\nprocedure TJvCustomAppDBStorage.RestoreDataset;\r\nbegin\r\n if FBookmark = {$IFDEF RTL200_UP}nil{$ELSE}''{$ENDIF RTL200_UP} then\r\n Exit;\r\n if FieldsAssigned then\r\n DataSource.DataSet.Bookmark := FBookmark;\r\n FBookmark := {$IFDEF RTL200_UP}nil{$ELSE}''{$ENDIF RTL200_UP};\r\nend;\r\n\r\nfunction TJvCustomAppDBStorage.GetPhysicalReadOnly: Boolean;\r\nbegin\r\n if FieldsAssigned then\r\n Result := False\r\n else\r\n Result := not DataSource.DataSet.CanModify;\r\nend;\r\n\r\nfunction TJvCustomAppDBStorage.SectionExists(const Path: string; RestorePosition: Boolean): Boolean;\r\nbegin\r\n Result := FieldsAssigned and DataSource.DataSet.Active;\r\n if Result then\r\n begin\r\n if RestorePosition then\r\n StoreDataset;\r\n try\r\n Result := DataSource.DataSet.Locate(SectionField, Path, [loCaseInsensitive]);\r\n finally\r\n if RestorePosition then\r\n RestoreDataset;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomAppDBStorage.SetDataSource(const Value: TDataSource);\r\nbegin\r\n if Assigned(FSectionLink) and not (FSectionLink.DataSourceFixed and (csLoading in ComponentState)) then\r\n begin\r\n FSectionLink.DataSource := Value;\r\n FKeyLink.DataSource := Value;\r\n FValueLink.DataSource := Value;\r\n end;\r\n ReplaceComponentReference(Self, Value, TComponent(FDataSource));\r\nend;\r\n\r\nprocedure TJvCustomAppDBStorage.SetKeyField(const Value: string);\r\nbegin\r\n FKeyLink.FieldName := Value;\r\nend;\r\n\r\nprocedure TJvCustomAppDBStorage.SetSectionField(const Value: string);\r\nbegin\r\n FSectionLink.FieldName := Value;\r\nend;\r\n\r\nprocedure TJvCustomAppDBStorage.SetValueField(const Value: string);\r\nbegin\r\n FValueLink.FieldName := Value;\r\nend;\r\n\r\nprocedure TJvCustomAppDBStorage.StoreDataset;\r\nbegin\r\n if FBookmark <> {$IFDEF RTL200_UP}nil{$ELSE}''{$ENDIF RTL200_UP} then\r\n RestoreDataset;\r\n if FieldsAssigned and DataSource.DataSet.Active then\r\n begin\r\n FBookmark := DataSource.DataSet.Bookmark;\r\n DataSource.DataSet.DisableControls;\r\n end;\r\nend;\r\n\r\nfunction TJvCustomAppDBStorage.ValueExists(const Section, Key: string; RestorePosition: Boolean): Boolean;\r\nbegin\r\n Result := FieldsAssigned and DataSource.DataSet.Active;\r\n if Result then\r\n begin\r\n if RestorePosition then\r\n StoreDataset;\r\n try\r\n Result := DataSource.DataSet.Locate(Format('%s;%s', [SectionField, KeyField]), VarArrayOf([Section, Key]),\r\n [loCaseInsensitive]);\r\n finally\r\n if RestorePosition then\r\n RestoreDataset;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJvCustomAppDBStorage.ValueStoredInt(const Path: string): Boolean;\r\nvar\r\n Section: string;\r\n Key: string;\r\nbegin\r\n SplitKeyPath(Path, Section, Key);\r\n Result := ValueExists(Section, Key, True);\r\nend;\r\n\r\nprocedure TJvCustomAppDBStorage.WriteValue(const Section, Key, Value: string);\r\nbegin\r\n if FieldsAssigned then\r\n begin\r\n if ValueExists(Section, Key, False) then\r\n begin\r\n if AnsiSameStr(FValueLink.Field.AsString, Value) then\r\n Exit; // don't save if it's the same value (NB: this also skips the event)\r\n DataSource.DataSet.Edit\r\n end\r\n else\r\n DataSource.DataSet.Append;\r\n FSectionLink.Field.AsString := Section;\r\n FKeyLink.Field.AsString := Key;\r\n FValueLink.Field.AsString := Value;\r\n DataSource.DataSet.Post;\r\n end;\r\n // always call event\r\n if Assigned(FOnWrite) then\r\n FOnWrite(Self, Section, Key, Value);\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvAppEvent.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvAppEvent.PAS, released on 2002-07-04.\r\n\r\nThe Initial Developers of the Original Code are: Fedor Koshevnikov, Igor Pavluk and Serge Korolev\r\nCopyright (c) 1997, 1998 Fedor Koshevnikov, Igor Pavluk and Serge Korolev\r\nCopyright (c) 2001,2002 SGB Software\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\n Hofi\r\n Andreas Hausladen\r\n\r\nChanges:\r\n2004-10-07:\r\n * Added by Hofi\r\n TJvAppEvents\r\n property CancelDispatch\r\n gives a chance to break event dispatching in a particular event handler.\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvAppEvent.pas 13104 2011-09-07 06:50:43Z obones $\r\n\r\nunit JvAppEvent;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, Messages,\r\n SysUtils, Classes, Controls, Graphics, Forms, ActnList,\r\n JvTypes, JvComponentBase;\r\n\r\nconst\r\n DefHintColor = clInfoBk;\r\n DefHintPause = 500;\r\n DefHintShortPause = DefHintPause div 10;\r\n DefHintHidePause = DefHintPause * 5;\r\n\r\ntype\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64 or pidOSX32)]\r\n {$ENDIF RTL230_UP}\r\n TJvAppEvents = class(TJvComponent)\r\n private\r\n FChained: Boolean;\r\n FHintColor: TColor;\r\n FHintPause: Integer;\r\n FShowHint: Boolean;\r\n FUpdateFormatSettings: Boolean;\r\n FCancelDispatch: Boolean;\r\n FHintShortPause: Integer;\r\n FHintHidePause: Integer;\r\n FShowMainForm: Boolean;\r\n FHintShortCuts: Boolean;\r\n FMouseDragImmediate: Boolean;\r\n FMouseDragThreshold: Integer;\r\n FOnActionExecute: TActionEvent;\r\n FOnActionUpdate: TActionEvent;\r\n FOnShortCut: TShortCutEvent;\r\n FUpdateMetricSettings: Boolean;\r\n FBiDiMode: TBiDiMode;\r\n FBiDiKeyboard: string;\r\n FNonBiDiKeyboard: string;\r\n FOnPaintIcon: TNotifyEvent;\r\n FOnActivate: TNotifyEvent;\r\n FOnDeactivate: TNotifyEvent;\r\n FOnException: TExceptionEvent;\r\n FOnIdle: TIdleEvent;\r\n FOnHelp: THelpEvent;\r\n FOnHint: TNotifyEvent;\r\n FOnMessage: TMessageEvent;\r\n FOnMinimize: TNotifyEvent;\r\n FOnRestore: TNotifyEvent;\r\n FOnShowHint: TShowHintEvent;\r\n {$IFDEF COMPILER7_UP}\r\n FOnModalBegin: TNotifyEvent;\r\n FOnModalEnd: TNotifyEvent;\r\n {$ENDIF COMPILER7_UP}\r\n FOnSettingsChanged: TNotifyEvent;\r\n FOnActiveControlChange: TNotifyEvent;\r\n FOnActiveFormChange: TNotifyEvent;\r\n procedure UpdateAppProps;\r\n function GetHintColor: TColor;\r\n function GetHintPause: Integer;\r\n function GetShowHint: Boolean;\r\n procedure SetHintColor(Value: TColor);\r\n procedure SetHintPause(Value: Integer);\r\n procedure SetShowHint(Value: Boolean);\r\n function GetUpdateFormatSettings: Boolean;\r\n procedure SetUpdateFormatSettings(Value: Boolean);\r\n function GetHintShortPause: Integer;\r\n function GetHintHidePause: Integer;\r\n function GetShowMainForm: Boolean;\r\n procedure SetHintShortPause(Value: Integer);\r\n procedure SetHintHidePause(Value: Integer);\r\n procedure SetShowMainForm(Value: Boolean);\r\n function GetHintShortCuts: Boolean;\r\n procedure SetHintShortCuts(Value: Boolean);\r\n function GetMouseDragImmediate: Boolean;\r\n function GetMouseDragThreshold: Integer;\r\n procedure SetMouseDragImmediate(Value: Boolean);\r\n procedure SetMouseDragThreshold(Value: Integer);\r\n function GetUpdateMetricSettings: Boolean;\r\n procedure SetUpdateMetricSettings(Value: Boolean);\r\n function GetBiDiMode: TBiDiMode;\r\n procedure SetBiDiMode(Value: TBiDiMode);\r\n function GetBiDiKeyboard: string;\r\n function GetNonBiDiKeyboard: string;\r\n procedure SetBiDiKeyboard(const Value: string);\r\n procedure SetNonBiDiKeyboard(const Value: string);\r\n procedure SetOnException(const Value: TExceptionEvent);\r\n protected\r\n procedure Loaded; override;\r\n procedure PaintIcon; virtual;\r\n procedure SettingsChanged; dynamic;\r\n function MessageHook(var Msg: TMessage): Boolean; virtual;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n procedure CancelDispatch;\r\n published\r\n property Chained: Boolean read FChained write FChained default True;\r\n property HintColor: TColor read GetHintColor write SetHintColor default DefHintColor;\r\n property HintPause: Integer read GetHintPause write SetHintPause default DefHintPause;\r\n property ShowHint: Boolean read GetShowHint write SetShowHint default True;\r\n property UpdateFormatSettings: Boolean read GetUpdateFormatSettings write SetUpdateFormatSettings default True;\r\n property HintShortPause: Integer read GetHintShortPause write SetHintShortPause default DefHintShortPause;\r\n property HintHidePause: Integer read GetHintHidePause write SetHintHidePause default DefHintHidePause;\r\n property ShowMainForm: Boolean read GetShowMainForm write SetShowMainForm default True;\r\n property HintShortCuts: Boolean read GetHintShortCuts write SetHintShortCuts default True;\r\n property UpdateMetricSettings: Boolean read GetUpdateMetricSettings write SetUpdateMetricSettings default True;\r\n property BiDiMode: TBiDiMode read GetBiDiMode write SetBiDiMode default bdLeftToRight;\r\n property BiDiKeyboard: string read GetBiDiKeyboard write SetBiDiKeyboard;\r\n property NonBiDiKeyboard: string read GetNonBiDiKeyboard write SetNonBiDiKeyboard;\r\n property MouseDragImmediate: Boolean read GetMouseDragImmediate write SetMouseDragImmediate default True;\r\n property MouseDragThreshold: Integer read GetMouseDragThreshold write SetMouseDragThreshold default 5;\r\n property OnActionExecute: TActionEvent read FOnActionExecute write FOnActionExecute;\r\n property OnActionUpdate: TActionEvent read FOnActionUpdate write FOnActionUpdate;\r\n property OnShortCut: TShortCutEvent read FOnShortCut write FOnShortCut;\r\n property OnActivate: TNotifyEvent read FOnActivate write FOnActivate;\r\n property OnDeactivate: TNotifyEvent read FOnDeactivate write FOnDeactivate;\r\n property OnException: TExceptionEvent read FOnException write SetOnException;\r\n property OnIdle: TIdleEvent read FOnIdle write FOnIdle;\r\n property OnHelp: THelpEvent read FOnHelp write FOnHelp;\r\n property OnHint: TNotifyEvent read FOnHint write FOnHint;\r\n property OnMinimize: TNotifyEvent read FOnMinimize write FOnMinimize;\r\n property OnPaintIcon: TNotifyEvent read FOnPaintIcon write FOnPaintIcon;\r\n property OnRestore: TNotifyEvent read FOnRestore write FOnRestore;\r\n property OnShowHint: TShowHintEvent read FOnShowHint write FOnShowHint;\r\n {$IFDEF COMPILER7_UP}\r\n property OnModalBegin: TNotifyEvent read FOnModalBegin write FOnModalBegin;\r\n property OnModalEnd: TNotifyEvent read FOnModalEnd write FOnModalEnd;\r\n {$ENDIF COMPILER7_UP}\r\n property OnMessage: TMessageEvent read FOnMessage write FOnMessage;\r\n property OnSettingsChanged: TNotifyEvent read FOnSettingsChanged write FOnSettingsChanged;\r\n property OnActiveControlChange: TNotifyEvent read FOnActiveControlChange write FOnActiveControlChange;\r\n property OnActiveFormChange: TNotifyEvent read FOnActiveFormChange write FOnActiveFormChange;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvAppEvent.pas $';\r\n Revision: '$Revision: 13104 $';\r\n Date: '$Date: 2011-09-07 08:50:43 +0200 (mer. 07 sept. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n AppEvnts;\r\n\r\ntype\r\n {$IFDEF COMPILER7} // In Delphi 7 they forgot to publish those events\r\n TApplicationEvents = class(AppEvnts.TApplicationEvents)\r\n published\r\n property OnModalBegin;\r\n property OnModalEnd;\r\n end;\r\n {$ENDIF COMPILER7}\r\n\r\n TJvAppEventList = class(TComponent)\r\n private\r\n FApplicationEvents: TApplicationEvents;\r\n FAppEvents: TList;\r\n FHooked: Boolean;\r\n FExceptionHandlerCount: Integer;\r\n FOnActiveControlChange: TNotifyEvent;\r\n FOnActiveFormChange: TNotifyEvent;\r\n procedure AddEvents(App: TJvAppEvents);\r\n procedure RemoveEvents(App: TJvAppEvents);\r\n procedure ClearEvents;\r\n function GetItem(Index: Integer): TJvAppEvents; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\n protected\r\n procedure Notification(AComponent: TComponent; Operation: TOperation); override;\r\n\r\n procedure DoActivate(Sender: TObject);\r\n procedure DoDeactivate(Sender: TObject);\r\n procedure DoException(Sender: TObject; E: Exception);\r\n procedure DoIdle(Sender: TObject; var Done: Boolean);\r\n procedure DoHint(Sender: TObject);\r\n procedure DoMinimize(Sender: TObject);\r\n procedure DoRestore(Sender: TObject);\r\n function DoHelp(Command: Word; Data: {$IFDEF RTL230_UP}THelpEventData{$ELSE}Longint{$ENDIF}; var CallHelp: Boolean): Boolean;\r\n procedure DoMessage(var Msg: TMsg; var Handled: Boolean);\r\n procedure DoShortCut(var Msg: TWMKey; var Handled: Boolean);\r\n procedure DoShowHint(var HintStr: THintString; var CanShow: Boolean; var HintInfo: THintInfo);\r\n procedure DoActiveControlChange(Sender: TObject);\r\n procedure DoActiveFormChange(Sender: TObject);\r\n procedure DoActionExecute(Action: TBasicAction; var Handled: Boolean);\r\n procedure DoActionUpdate(Action: TBasicAction; var Handled: Boolean);\r\n {$IFDEF COMPILER7_UP}\r\n procedure DoModalBegin(Sender: TObject);\r\n procedure DoModalEnd(Sender: TObject);\r\n {$ENDIF COMPILER7_UP}\r\n public\r\n constructor Create; reintroduce;\r\n destructor Destroy; override;\r\n\r\n { OnException needs special treatment. Otherwise the first TJvAppEvents instance\r\n will steal the OnException handler. }\r\n procedure RegisterExceptionHandler;\r\n procedure UnregisterExceptionHandler;\r\n\r\n property Items[Index: Integer]: TJvAppEvents read GetItem;\r\n end;\r\n\r\n//=== { TJvAppEventList } ====================================================\r\n\r\nconstructor TJvAppEventList.Create;\r\nbegin\r\n inherited Create(nil);\r\n FAppEvents := TList.Create;\r\nend;\r\n\r\ndestructor TJvAppEventList.Destroy;\r\nbegin\r\n ClearEvents;\r\n FAppEvents.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvAppEventList.ClearEvents;\r\nbegin\r\n if FHooked then\r\n begin\r\n FreeAndNil(FApplicationEvents);\r\n // Screen might get destroyed and set to nil before our finalization is called\r\n if Assigned(Screen) then\r\n begin\r\n {Screen.OnActiveControlChange := FOnActiveControlChange;\r\n Screen.OnActiveFormChange := FOnActiveFormChange;}\r\n Screen.OnActiveControlChange := nil;\r\n Screen.OnActiveFormChange := nil;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvAppEventList.AddEvents(App: TJvAppEvents);\r\nbegin\r\n if (App <> nil) and (FAppEvents.IndexOf(App) = -1) then\r\n begin\r\n FAppEvents.Add(App);\r\n if not (csDesigning in App.ComponentState) and (FAppEvents.Count = 1) then\r\n begin\r\n if FApplicationEvents = nil then\r\n FApplicationEvents := TApplicationEvents.Create(Self);\r\n\r\n FApplicationEvents.OnActionExecute := DoActionExecute;\r\n FApplicationEvents.OnActionUpdate := DoActionUpdate;\r\n FApplicationEvents.OnShortCut := DoShortCut;\r\n FApplicationEvents.OnActivate := DoActivate;\r\n FApplicationEvents.OnDeactivate := DoDeactivate;\r\n if FExceptionHandlerCount > 0 then\r\n FApplicationEvents.OnException := DoException;\r\n FApplicationEvents.OnIdle := DoIdle;\r\n FApplicationEvents.OnHelp := DoHelp;\r\n FApplicationEvents.OnHint := DoHint;\r\n FApplicationEvents.OnMessage := DoMessage;\r\n FApplicationEvents.OnMinimize := DoMinimize;\r\n FApplicationEvents.OnRestore := DoRestore;\r\n FApplicationEvents.OnShowHint := DoShowHint;\r\n {$IFDEF COMPILER7_UP}\r\n FApplicationEvents.OnModalBegin := DoModalBegin;\r\n FApplicationEvents.OnModalEnd := DoModalEnd;\r\n {$ENDIF COMPILER7_UP}\r\n\r\n if Screen <> nil then\r\n begin\r\n FOnActiveControlChange := Screen.OnActiveControlChange;\r\n FOnActiveFormChange := Screen.OnActiveFormChange;\r\n Screen.OnActiveControlChange := DoActiveControlChange;\r\n Screen.OnActiveFormChange := DoActiveFormChange;\r\n end;\r\n FHooked := True;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvAppEventList.RemoveEvents(App: TJvAppEvents);\r\nbegin\r\n if FAppEvents.IndexOf(App) >= 0 then\r\n FAppEvents.Remove(App);\r\n if not (csDesigning in App.ComponentState) and (FAppEvents.Count = 0) then\r\n ClearEvents;\r\nend;\r\n\r\nprocedure TJvAppEventList.RegisterExceptionHandler;\r\nbegin\r\n Inc(FExceptionHandlerCount);\r\n if (FExceptionHandlerCount = 1) and (FApplicationEvents <> nil) then\r\n FApplicationEvents.OnException := DoException\r\nend;\r\n\r\nprocedure TJvAppEventList.UnregisterExceptionHandler;\r\nbegin\r\n Dec(FExceptionHandlerCount);\r\n if (FExceptionHandlerCount = 0) and (FApplicationEvents <> nil) then\r\n FApplicationEvents.OnException := nil;\r\nend;\r\n\r\nprocedure TJvAppEventList.DoActivate(Sender: TObject);\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := FAppEvents.Count - 1 downto 0 do\r\n begin\r\n Items[I].FCancelDispatch := False;\r\n if Assigned(Items[I].FOnActivate) then\r\n Items[I].FOnActivate(Sender);\r\n if not Items[I].Chained or Items[I].FCancelDispatch then\r\n Exit;\r\n end;\r\nend;\r\n\r\nprocedure TJvAppEventList.DoDeactivate(Sender: TObject);\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := FAppEvents.Count - 1 downto 0 do\r\n begin\r\n Items[I].FCancelDispatch := False;\r\n if Assigned(Items[I].FOnDeactivate) then\r\n Items[I].FOnDeactivate(Sender);\r\n if not Items[I].Chained or Items[I].FCancelDispatch then\r\n Exit;\r\n end;\r\nend;\r\n\r\nprocedure TJvAppEventList.DoException(Sender: TObject; E: Exception);\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := FAppEvents.Count - 1 downto 0 do\r\n begin\r\n Items[I].FCancelDispatch := False;\r\n if Assigned(Items[I].FOnException) then\r\n Items[I].FOnException(Sender, E);\r\n if not Items[I].Chained or Items[I].FCancelDispatch then\r\n Exit;\r\n end;\r\nend;\r\n\r\nprocedure TJvAppEventList.DoIdle(Sender: TObject; var Done: Boolean);\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := FAppEvents.Count - 1 downto 0 do\r\n begin\r\n Items[I].FCancelDispatch := False;\r\n if Assigned(Items[I].FOnIdle) then\r\n Items[I].FOnIdle(Sender, Done);\r\n if not Items[I].Chained or Items[I].FCancelDispatch then\r\n Exit;\r\n end;\r\nend;\r\n\r\nfunction TJvAppEventList.DoHelp(Command: Word; Data: {$IFDEF RTL230_UP}THelpEventData{$ELSE}Longint{$ENDIF}; var CallHelp: Boolean): Boolean;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := False;\r\n for I := FAppEvents.Count - 1 downto 0 do\r\n begin\r\n Items[I].FCancelDispatch := False;\r\n if Assigned(Items[I].FOnHelp) then\r\n Result := Items[I].FOnHelp(Command, Data, CallHelp);\r\n if not Items[I].Chained or Items[I].FCancelDispatch then\r\n Exit;\r\n end;\r\nend;\r\n\r\nprocedure TJvAppEventList.DoHint(Sender: TObject);\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := FAppEvents.Count - 1 downto 0 do\r\n begin\r\n Items[I].FCancelDispatch := False;\r\n if Assigned(Items[I].FOnHint) then\r\n Items[I].FOnHint(Sender);\r\n if not Items[I].Chained or Items[I].FCancelDispatch then\r\n Exit;\r\n end;\r\nend;\r\n\r\nprocedure TJvAppEventList.DoMessage(var Msg: TMsg; var Handled: Boolean);\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := FAppEvents.Count - 1 downto 0 do\r\n begin\r\n Items[I].FCancelDispatch := False;\r\n if Assigned(Items[I].FOnMessage) then\r\n Items[I].FOnMessage(Msg, Handled);\r\n if not Items[I].Chained or Handled or Items[I].FCancelDispatch then\r\n Exit;\r\n end;\r\nend;\r\n\r\nprocedure TJvAppEventList.DoMinimize(Sender: TObject);\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := FAppEvents.Count - 1 downto 0 do\r\n begin\r\n Items[I].FCancelDispatch := False;\r\n if Assigned(Items[I].FOnMinimize) then\r\n Items[I].FOnMinimize(Sender);\r\n if not Items[I].Chained or Items[I].FCancelDispatch then\r\n Exit;\r\n end;\r\nend;\r\n\r\nprocedure TJvAppEventList.DoRestore(Sender: TObject);\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := FAppEvents.Count - 1 downto 0 do\r\n begin\r\n Items[I].FCancelDispatch := False;\r\n if Assigned(Items[I].FOnRestore) then\r\n Items[I].FOnRestore(Sender);\r\n if not Items[I].Chained or Items[I].FCancelDispatch then\r\n Exit;\r\n end;\r\nend;\r\n\r\nprocedure TJvAppEventList.DoShowHint(var HintStr: THintString; var CanShow: Boolean;\r\n var HintInfo: THintInfo);\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := FAppEvents.Count - 1 downto 0 do\r\n begin\r\n Items[I].FCancelDispatch := False;\r\n if Assigned(Items[I].FOnShowHint) then\r\n Items[I].FOnShowHint(HintStr, CanShow, HintInfo);\r\n if not Items[I].Chained or Items[I].FCancelDispatch then\r\n Exit;\r\n end;\r\nend;\r\n\r\nfunction TJvAppEventList.GetItem(Index: Integer): TJvAppEvents;\r\nbegin\r\n Result := TJvAppEvents(FAppEvents[Index]);\r\nend;\r\n\r\nprocedure TJvAppEventList.Notification(AComponent: TComponent; Operation: TOperation);\r\nbegin\r\n inherited Notification(AComponent, Operation);\r\n if (Operation = opRemove) and (AComponent = FApplicationEvents) then\r\n FApplicationEvents := nil;\r\nend;\r\n\r\nprocedure TJvAppEventList.DoActiveControlChange(Sender: TObject);\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := FAppEvents.Count - 1 downto 0 do\r\n begin\r\n Items[I].FCancelDispatch := False;\r\n if Assigned(Items[I].FOnActiveControlChange) then\r\n Items[I].FOnActiveControlChange(Sender);\r\n if not Items[I].Chained or Items[I].FCancelDispatch then\r\n Exit;\r\n end;\r\n if Assigned(FOnActiveControlChange) then\r\n FOnActiveControlChange(Sender);\r\nend;\r\n\r\nprocedure TJvAppEventList.DoActiveFormChange(Sender: TObject);\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := FAppEvents.Count - 1 downto 0 do\r\n begin\r\n Items[I].FCancelDispatch := False;\r\n if Assigned(Items[I].FOnActiveFormChange) then\r\n Items[I].FOnActiveFormChange(Sender);\r\n if not Items[I].Chained or Items[I].FCancelDispatch then\r\n Exit;\r\n end;\r\n if Assigned(FOnActiveFormChange) then\r\n FOnActiveFormChange(Sender);\r\nend;\r\n\r\nprocedure TJvAppEventList.DoActionExecute(Action: TBasicAction;\r\n var Handled: Boolean);\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := FAppEvents.Count - 1 downto 0 do\r\n begin\r\n Items[I].FCancelDispatch := False;\r\n if Assigned(Items[I].FOnActionExecute) then\r\n Items[I].FOnActionExecute(Action, Handled);\r\n if not Items[I].Chained or Handled or Items[I].FCancelDispatch then\r\n Exit;\r\n end;\r\nend;\r\n\r\nprocedure TJvAppEventList.DoActionUpdate(Action: TBasicAction;\r\n var Handled: Boolean);\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := FAppEvents.Count - 1 downto 0 do\r\n begin\r\n Items[I].FCancelDispatch := False;\r\n if Assigned(Items[I].FOnActionUpdate) then\r\n Items[I].FOnActionUpdate(Action, Handled);\r\n if not Items[I].Chained or Handled or Items[I].FCancelDispatch then\r\n Exit;\r\n end;\r\nend;\r\n\r\nprocedure TJvAppEventList.DoShortCut(var Msg: TWMKey; var Handled: Boolean);\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := FAppEvents.Count - 1 downto 0 do\r\n begin\r\n Items[I].FCancelDispatch := False;\r\n if Assigned(Items[I].FOnShortCut) then\r\n Items[I].FOnShortCut(Msg, Handled);\r\n if not Items[I].Chained or Handled or Items[I].FCancelDispatch then\r\n Exit;\r\n end;\r\nend;\r\n\r\n{$IFDEF COMPILER7_UP}\r\nprocedure TJvAppEventList.DoModalBegin(Sender: TObject);\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := FAppEvents.Count - 1 downto 0 do\r\n begin\r\n Items[I].FCancelDispatch := False;\r\n if Assigned(Items[I].FOnModalBegin) then\r\n Items[I].FOnModalBegin(Sender);\r\n if not Items[I].Chained or Items[I].FCancelDispatch then\r\n Exit;\r\n end;\r\nend;\r\n\r\nprocedure TJvAppEventList.DoModalEnd(Sender: TObject);\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := FAppEvents.Count - 1 downto 0 do\r\n begin\r\n Items[I].FCancelDispatch := False;\r\n if Assigned(Items[I].FOnModalEnd) then\r\n Items[I].FOnModalEnd(Sender);\r\n if not Items[I].Chained or Items[I].FCancelDispatch then\r\n Exit;\r\n end;\r\nend;\r\n{$ENDIF COMPILER7_UP}\r\n\r\n//=== { TJvAppEvents } =======================================================\r\n\r\nvar\r\n AppList: TJvAppEventList = nil;\r\n\r\nconstructor TJvAppEvents.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n if AppList = nil then\r\n AppList := TJvAppEventList.Create;\r\n\r\n FChained := True;\r\n FHintColor := DefHintColor;\r\n FHintPause := DefHintPause;\r\n FShowHint := True;\r\n FCancelDispatch := False;\r\n FHintShortPause := DefHintShortPause;\r\n FHintHidePause := DefHintHidePause;\r\n FShowMainForm := True;\r\n FHintShortCuts := True;\r\n FMouseDragImmediate := True;\r\n FMouseDragThreshold := 5;\r\n FUpdateFormatSettings := True;\r\n FUpdateMetricSettings := True;\r\n FBiDiMode := bdLeftToRight;\r\n if not (csDesigning in ComponentState) then\r\n Application.HookMainWindow(MessageHook);\r\n AppList.AddEvents(Self);\r\nend;\r\n\r\ndestructor TJvAppEvents.Destroy;\r\nbegin\r\n if not (csDesigning in ComponentState) then\r\n Application.UnhookMainWindow(MessageHook);\r\n if (Self <> nil) and (AppList <> nil) then\r\n begin\r\n SetOnException(nil);\r\n AppList.RemoveEvents(Self);\r\n end;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvAppEvents.Loaded;\r\nbegin\r\n inherited Loaded;\r\n UpdateAppProps;\r\nend;\r\n\r\nprocedure TJvAppEvents.CancelDispatch;\r\nbegin\r\n FCancelDispatch := True;\r\nend;\r\n\r\nprocedure TJvAppEvents.PaintIcon;\r\nvar\r\n PS: TPaintStruct;\r\nbegin\r\n BeginPaint(Application.Handle, PS);\r\n try\r\n if PS.fErase then\r\n Windows.FillRect(PS.hdc, PS.rcPaint, HBRUSH(COLOR_BACKGROUND + 1));\r\n if Assigned(FOnPaintIcon) then\r\n FOnPaintIcon(Self);\r\n finally\r\n EndPaint(Application.Handle, PS);\r\n end;\r\nend;\r\n\r\nprocedure TJvAppEvents.SettingsChanged;\r\nbegin\r\n if Assigned(FOnSettingsChanged) then\r\n FOnSettingsChanged(Self);\r\nend;\r\n\r\nfunction TJvAppEvents.MessageHook(var Msg: TMessage): Boolean;\r\nbegin\r\n Result := False;\r\n case Msg.Msg of\r\n WM_WININICHANGE:\r\n begin\r\n try\r\n SettingsChanged;\r\n except\r\n Application.HandleException(Self);\r\n end;\r\n end;\r\n WM_PAINT:\r\n if Assigned(FOnPaintIcon) and IsIconic(Application.Handle) then\r\n begin\r\n PaintIcon;\r\n Result := True;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJvAppEvents.GetHintColor: TColor;\r\nbegin\r\n if csDesigning in ComponentState then\r\n Result := FHintColor\r\n else\r\n Result := Application.HintColor;\r\nend;\r\n\r\nfunction TJvAppEvents.GetHintPause: Integer;\r\nbegin\r\n if csDesigning in ComponentState then\r\n Result := FHintPause\r\n else\r\n Result := Application.HintPause;\r\nend;\r\n\r\nfunction TJvAppEvents.GetShowHint: Boolean;\r\nbegin\r\n if csDesigning in ComponentState then\r\n Result := FShowHint\r\n else\r\n Result := Application.ShowHint;\r\nend;\r\n\r\nprocedure TJvAppEvents.SetHintColor(Value: TColor);\r\nbegin\r\n FHintColor := Value;\r\n if not (csDesigning in ComponentState) then\r\n Application.HintColor := Value;\r\nend;\r\n\r\nprocedure TJvAppEvents.SetHintPause(Value: Integer);\r\nbegin\r\n FHintPause := Value;\r\n if not (csDesigning in ComponentState) then\r\n Application.HintPause := Value;\r\nend;\r\n\r\nprocedure TJvAppEvents.SetShowHint(Value: Boolean);\r\nbegin\r\n FShowHint := Value;\r\n if not (csDesigning in ComponentState) then\r\n Application.ShowHint := Value;\r\nend;\r\n\r\nfunction TJvAppEvents.GetUpdateFormatSettings: Boolean;\r\nbegin\r\n if not (csDesigning in ComponentState) then\r\n Result := Application.UpdateFormatSettings\r\n else\r\n Result := FUpdateFormatSettings;\r\nend;\r\n\r\nprocedure TJvAppEvents.SetUpdateFormatSettings(Value: Boolean);\r\nbegin\r\n FUpdateFormatSettings := Value;\r\n if not (csDesigning in ComponentState) then\r\n Application.UpdateFormatSettings := Value;\r\nend;\r\n\r\nfunction TJvAppEvents.GetHintShortPause: Integer;\r\nbegin\r\n if csDesigning in ComponentState then\r\n Result := FHintShortPause\r\n else\r\n Result := Application.HintShortPause;\r\nend;\r\n\r\nfunction TJvAppEvents.GetHintHidePause: Integer;\r\nbegin\r\n if csDesigning in ComponentState then\r\n Result := FHintHidePause\r\n else\r\n Result := Application.HintHidePause;\r\nend;\r\n\r\nfunction TJvAppEvents.GetShowMainForm: Boolean;\r\nbegin\r\n if csDesigning in ComponentState then\r\n Result := FShowMainForm\r\n else\r\n Result := Application.ShowMainForm;\r\nend;\r\n\r\nprocedure TJvAppEvents.SetHintShortPause(Value: Integer);\r\nbegin\r\n FHintShortPause := Value;\r\n if not (csDesigning in ComponentState) then\r\n Application.HintShortPause := Value;\r\nend;\r\n\r\nprocedure TJvAppEvents.SetHintHidePause(Value: Integer);\r\nbegin\r\n FHintHidePause := Value;\r\n if not (csDesigning in ComponentState) then\r\n Application.HintHidePause := Value;\r\nend;\r\n\r\nprocedure TJvAppEvents.SetShowMainForm(Value: Boolean);\r\nbegin\r\n FShowMainForm := Value;\r\n if not (csDesigning in ComponentState) then\r\n Application.ShowMainForm := Value;\r\nend;\r\n\r\nfunction TJvAppEvents.GetUpdateMetricSettings: Boolean;\r\nbegin\r\n if csDesigning in ComponentState then\r\n Result := FUpdateMetricSettings\r\n else\r\n Result := Application.UpdateMetricSettings;\r\nend;\r\n\r\nprocedure TJvAppEvents.SetUpdateMetricSettings(Value: Boolean);\r\nbegin\r\n FUpdateMetricSettings := Value;\r\n if not (csDesigning in ComponentState) then\r\n Application.UpdateMetricSettings := Value;\r\nend;\r\n\r\nfunction TJvAppEvents.GetHintShortCuts: Boolean;\r\nbegin\r\n if csDesigning in ComponentState then\r\n Result := FHintShortCuts\r\n else\r\n Result := Application.HintShortCuts;\r\nend;\r\n\r\nfunction TJvAppEvents.GetMouseDragImmediate: Boolean;\r\nbegin\r\n if (csDesigning in ComponentState) or (Mouse = nil) then\r\n Result := FMouseDragImmediate\r\n else\r\n Result := Mouse.DragImmediate;\r\nend;\r\n\r\nfunction TJvAppEvents.GetMouseDragThreshold: Integer;\r\nbegin\r\n if (csDesigning in ComponentState) or (Mouse = nil) then\r\n Result := FMouseDragThreshold\r\n else\r\n Result := Mouse.DragThreshold;\r\nend;\r\n\r\nprocedure TJvAppEvents.SetMouseDragImmediate(Value: Boolean);\r\nbegin\r\n FMouseDragImmediate := Value;\r\n if not (csDesigning in ComponentState) and (Mouse <> nil) then\r\n Mouse.DragImmediate := Value;\r\nend;\r\n\r\nprocedure TJvAppEvents.SetMouseDragThreshold(Value: Integer);\r\nbegin\r\n FMouseDragThreshold := Value;\r\n if not (csDesigning in ComponentState) and (Mouse <> nil) then\r\n Mouse.DragThreshold := Value;\r\nend;\r\n\r\nprocedure TJvAppEvents.SetHintShortCuts(Value: Boolean);\r\nbegin\r\n FHintShortCuts := Value;\r\n if not (csDesigning in ComponentState) then\r\n Application.HintShortCuts := Value;\r\nend;\r\n\r\nfunction TJvAppEvents.GetBiDiMode: TBiDiMode;\r\nbegin\r\n if csDesigning in ComponentState then\r\n Result := FBiDiMode\r\n else\r\n Result := Application.BiDiMode;\r\nend;\r\n\r\nprocedure TJvAppEvents.SetBiDiMode(Value: TBiDiMode);\r\nbegin\r\n FBiDiMode := Value;\r\n if not (csDesigning in ComponentState) then\r\n Application.BiDiMode := Value;\r\nend;\r\n\r\nfunction TJvAppEvents.GetBiDiKeyboard: string;\r\nbegin\r\n if csDesigning in ComponentState then\r\n Result := FBiDiKeyboard\r\n else\r\n Result := Application.BiDiKeyboard;\r\nend;\r\n\r\nfunction TJvAppEvents.GetNonBiDiKeyboard: string;\r\nbegin\r\n if csDesigning in ComponentState then\r\n Result := FNonBiDiKeyboard\r\n else\r\n Result := Application.NonBiDiKeyboard;\r\nend;\r\n\r\nprocedure TJvAppEvents.SetBiDiKeyboard(const Value: string);\r\nbegin\r\n FBiDiKeyboard := Value;\r\n if not (csDesigning in ComponentState) then\r\n Application.BiDiKeyboard := Value;\r\nend;\r\n\r\nprocedure TJvAppEvents.SetNonBiDiKeyboard(const Value: string);\r\nbegin\r\n FNonBiDiKeyboard := Value;\r\n if not (csDesigning in ComponentState) then\r\n Application.NonBiDiKeyboard := Value;\r\nend;\r\n\r\nprocedure TJvAppEvents.SetOnException(const Value: TExceptionEvent);\r\nbegin\r\n if Assigned(FOnException) then\r\n AppList.UnregisterExceptionHandler;\r\n FOnException := Value;\r\n if Assigned(FOnException) then\r\n AppList.RegisterExceptionHandler;\r\nend;\r\n\r\nprocedure TJvAppEvents.UpdateAppProps;\r\nbegin\r\n if not (csDesigning in ComponentState) then\r\n begin\r\n Application.HintColor := FHintColor;\r\n Application.HintPause := FHintPause;\r\n Application.ShowHint := FShowHint;\r\n Application.HintShortPause := FHintShortPause;\r\n Application.HintHidePause := FHintHidePause;\r\n Application.ShowMainForm := FShowMainForm;\r\n Application.HintShortCuts := FHintShortCuts;\r\n Application.UpdateFormatSettings := FUpdateFormatSettings;\r\n Application.UpdateMetricSettings := FUpdateMetricSettings;\r\n Application.BiDiMode := FBiDiMode;\r\n Application.BiDiKeyboard := FBiDiKeyboard;\r\n Application.NonBiDiKeyboard := FNonBiDiKeyboard;\r\n Mouse.DragImmediate := FMouseDragImmediate;\r\n Mouse.DragThreshold := FMouseDragThreshold;\r\n end;\r\nend;\r\n\r\ninitialization\r\n {$IFDEF UNITVERSIONING}\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n {$ENDIF UNITVERSIONING}\r\n\r\nfinalization\r\n FreeAndNil(AppList);\r\n {$IFDEF UNITVERSIONING}\r\n UnregisterUnitVersion(HInstance);\r\n {$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvAppHotKey.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvHotKey.PAS, released on 2002-05-26.\r\n\r\nThe Initial Developer of the Original Code is Peter Thrnqvist [peter3 at sourceforge dot net]\r\nPortions created by Peter Thrnqvist are Copyright (C) 2002 Peter Thrnqvist.\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nDescription:\r\n A component that allows the user to register an application wide hotkey combination.\r\n Set the HotKey property to a *unique* combination of Ctrl,Alt,Shift and a character.\r\n Set active to True to receive notifications when the hotkey is pressed. The OnHotKey\r\n event is called when the user presses the hotkey combination.\r\n\r\n30/03/2006 Added property WinModifier. Windows key will now be recognized.\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvAppHotKey.pas 13104 2011-09-07 06:50:43Z obones $\r\n\r\nunit JvAppHotKey;\r\n\r\n{$I jvcl.inc}\r\n{$I windowsonly.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, Messages, Classes,\r\n JvComponentBase;\r\n\r\ntype\r\n TJvHotKeyRegisterFailed = procedure(Sender: TObject; var HotKey: TShortCut) of object;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64 or pidOSX32)]\r\n {$ENDIF RTL230_UP}\r\n TJvApplicationHotKey = class(TJvComponent)\r\n protected\r\n FActive: Boolean;\r\n FHotKey: TShortCut;\r\n FOnHotKey: TNotifyEvent;\r\n FHandle: THandle;\r\n FID: Integer;\r\n FHasRegistered: Boolean;\r\n FOnHotKeyRegisterFailed: TJvHotKeyRegisterFailed;\r\n FWindowsKey : Boolean;\r\n\r\n procedure SetActive(Value: Boolean);\r\n procedure SetHotKey(Value: TShortCut);\r\n function WndProc(var Msg: TMessage): Boolean;\r\n procedure GetWndProc;\r\n procedure ResetWndProc;\r\n protected\r\n procedure DoHotKey; virtual;\r\n function DoRegisterHotKey: Boolean; dynamic;\r\n\r\n procedure SetWindowsKey(Value : Boolean);\r\n public\r\n destructor Destroy; override;\r\n published\r\n property Active: Boolean read FActive write SetActive default False;\r\n property HotKey: TShortCut read FHotKey write SetHotKey;\r\n\r\n // If True, the Windows Key must be pressed for the shortcut to trigger\r\n property WindowsKey: Boolean read FWindowsKey write SetWindowsKey default False;\r\n\r\n property OnHotKey: TNotifyEvent read FOnHotKey write FOnHotKey;\r\n property OnHotKeyRegisterFailed: TJvHotKeyRegisterFailed\r\n read FOnHotKeyRegisterFailed write FOnHotKeyRegisterFailed;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvAppHotKey.pas $';\r\n Revision: '$Revision: 13104 $';\r\n Date: '$Date: 2011-09-07 08:50:43 +0200 (mer. 07 sept. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n Controls, Menus,\r\n JvWndProcHook;\r\n\r\nvar\r\n HotKeyInstances: Integer = 0;\r\n\r\nprocedure GetHotKey(AShortCut: TShortCut; var VirtKey, Modifiers: Word);\r\nvar\r\n Shift: TShiftState;\r\nbegin\r\n ShortCutToKey(AShortCut, VirtKey, Shift);\r\n Modifiers := 0;\r\n if ssCtrl in Shift then\r\n Modifiers := Modifiers or MOD_CONTROL;\r\n if ssShift in Shift then\r\n Modifiers := Modifiers or MOD_SHIFT;\r\n if ssAlt in Shift then\r\n Modifiers := Modifiers or MOD_ALT;\r\nend;\r\n\r\n\r\n//=== { TJvApplicationHotKey } ===============================================\r\n\r\ndestructor TJvApplicationHotKey.Destroy;\r\nbegin\r\n ResetWndProc;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvApplicationHotKey.SetHotKey(Value: TShortCut);\r\nvar\r\n B: Boolean;\r\nbegin\r\n if FHotKey <> Value then\r\n begin\r\n B := FActive;\r\n SetActive(False);\r\n FHotKey := Value;\r\n SetActive(B);\r\n end;\r\nend;\r\n\r\nprocedure TJvApplicationHotKey.SetWindowsKey(Value : Boolean);\r\nbegin\r\n FWindowsKey := Value;\r\n If Active then\r\n begin\r\n Active := False;\r\n Active := True;\r\n end;\r\nend;\r\n\r\nfunction TJvApplicationHotKey.DoRegisterHotKey: Boolean;\r\nvar\r\n AShortCut: TShortCut;\r\n VirtKey, Mods: Word;\r\nbegin\r\n Result := False;\r\n if FHandle = 0 then\r\n begin\r\n FHandle := TWinControl(Owner).Handle;\r\n GetHotKey(FHotKey, VirtKey, Mods);\r\n\r\n if WindowsKey then\r\n Mods := Mods or MOD_WIN;\r\n\r\n while not RegisterHotKey(FHandle, FID, Mods, VirtKey) do\r\n begin\r\n if Assigned(FOnHotKeyRegisterFailed) then\r\n begin\r\n AShortCut := FHotKey;\r\n FOnHotKeyRegisterFailed(Self, FHotKey);\r\n // make sure we don't get stuck in a loop here:\r\n if AShortCut = FHotKey then\r\n Exit;\r\n GetHotKey(FHotKey, VirtKey, Mods);\r\n end\r\n else\r\n Exit;\r\n end;\r\n Result := True;\r\n end;\r\nend;\r\n\r\nprocedure TJvApplicationHotKey.SetActive(Value: Boolean);\r\nbegin\r\n if FActive <> Value then\r\n begin\r\n if csDesigning in ComponentState then\r\n begin\r\n FActive := Value;\r\n Exit;\r\n end;\r\n if Value and not FHasRegistered then\r\n begin\r\n if IsLibrary then\r\n FID := GlobalAddAtom(PChar(ParamStr(0)))\r\n else\r\n begin\r\n FID := HotKeyInstances;\r\n Inc(HotKeyInstances);\r\n end;\r\n if not DoRegisterHotKey then\r\n Exit;\r\n GetWndProc;\r\n end\r\n else\r\n if FHasRegistered then\r\n begin\r\n UnRegisterHotKey(FHandle, FID);\r\n ResetWndProc;\r\n if IsLibrary then\r\n GlobalDeleteAtom(FID);\r\n end;\r\n FActive := Value;\r\n end;\r\nend;\r\n\r\nprocedure TJvApplicationHotKey.DoHotKey;\r\nbegin\r\n if Assigned(FOnHotKey) then\r\n FOnHotKey(Self);\r\nend;\r\n\r\nprocedure TJvApplicationHotKey.GetWndProc;\r\nbegin\r\n if not FHasRegistered and (Owner is TWinControl) then\r\n begin\r\n RegisterWndProcHook(TWinControl(Owner), WndProc, hoAfterMsg);\r\n FHasRegistered := True;\r\n end\r\n else\r\n SetActive(False);\r\nend;\r\n\r\nprocedure TJvApplicationHotKey.ResetWndProc;\r\nbegin\r\n if FHasRegistered and (Owner is TWinControl) then\r\n begin\r\n UnregisterWndProcHook(TWinControl(Owner), WndProc, hoAfterMsg);\r\n FHasRegistered := False;\r\n end;\r\n FHandle := 0;\r\nend;\r\n\r\nfunction TJvApplicationHotKey.WndProc(var Msg: TMessage): Boolean;\r\nbegin\r\n if (Msg.Msg = WM_HOTKEY) and (WPARAM(FID) = Msg.WParam) then\r\n DoHotKey;\r\n Result := False;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvAppIniStorage.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvAppIniStorage.pas, released on --.\r\n\r\nThe Initial Developer of the Original Code is Marcel Bestebroer\r\nPortions created by Marcel Bestebroer are Copyright (C) 2002 - 2003 Marcel\r\nBestebroer\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\n Jens Fudickar\r\n Olivier Sannier\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvAppIniStorage.pas 13350 2012-06-13 14:54:41Z obones $\r\n\r\nunit JvAppIniStorage;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, SysUtils, Classes, IniFiles,\r\n JvAppStorage, JvPropertyStore, JvTypes;\r\n\r\ntype\r\n TJvAppIniStorageOptions = class(TJvAppFileStorageOptions)\r\n private\r\n FReplaceCRLF: Boolean;\r\n FPreserveLeadingTrailingBlanks: Boolean;\r\n protected\r\n procedure SetReplaceCRLF(Value: Boolean); virtual;\r\n procedure SetPreserveLeadingTrailingBlanks(Value: Boolean); virtual;\r\n public\r\n constructor Create; override;\r\n procedure Assign(Source: TPersistent); override;\r\n published\r\n property BooleanStringTrueValues;\r\n property BooleanStringFalseValues;\r\n property BooleanAsString;\r\n property EnumerationAsString;\r\n property TypedIntegerAsString;\r\n property SetAsString;\r\n property DateTimeAsString;\r\n property FloatAsString default False;\r\n property DefaultIfReadConvertError;\r\n property DefaultIfValueNotExists;\r\n property StoreDefaultValues;\r\n property UseOldItemNameFormat;\r\n property UseTranslateStringEngineDateTimeFormats;\r\n property BackupType;\r\n property BackupKeepFileAfterFlush;\r\n property BackupHistoryCount;\r\n property BackupHistoryType;\r\n property ReplaceCRLF: Boolean read FReplaceCRLF write SetReplaceCRLF default False;\r\n property PreserveLeadingTrailingBlanks: Boolean read FPreserveLeadingTrailingBlanks\r\n write SetPreserveLeadingTrailingBlanks default False;\r\n end;\r\n\r\n // Storage to INI file, all in memory. This is the base class\r\n // for INI type storage, descendents will actually implement\r\n // the writing to a file or anything else\r\n TJvCustomAppIniStorage = class(TJvCustomAppMemoryFileStorage)\r\n private\r\n FIniFile: TMemIniFile;\r\n FDefaultSection: string;\r\n function CalcDefaultSection(Section: string): string;\r\n function GetStorageOptions: TJvAppIniStorageOptions;\r\n procedure SetStorageOptions(Value: TJvAppIniStorageOptions);\r\n {$IFDEF UNICODE}\r\n function GetEncoding: TEncoding;\r\n procedure SetEncoding(const Value: TEncoding);\r\n {$ENDIF UNICODE}\r\n protected\r\n class function GetStorageOptionsClass: TJvAppStorageOptionsClass; override;\r\n\r\n // Replaces all CRLF through \"\\n\"\r\n function ReplaceCRLFToSlashN(const Value: string): string;\r\n // Replaces all \"\\n\" through CRLF\r\n function ReplaceSlashNToCRLF(const Value: string): string;\r\n // Adds \" at the beginning and the end\r\n function SaveLeadingTrailingBlanks(const Value: string): string;\r\n // Removes \" at the beginning and the end\r\n function RestoreLeadingTrailingBlanks(const Value: string): string;\r\n\r\n function GetAsString: string; override;\r\n procedure SetAsString(const Value: string); override;\r\n function DefaultExtension: string; override;\r\n\r\n procedure EnumFolders(const Path: string; const Strings: TStrings;\r\n const ReportListAsValue: Boolean = True); override;\r\n procedure EnumValues(const Path: string; const Strings: TStrings;\r\n const ReportListAsValue: Boolean = True); override;\r\n function PathExistsInt(const Path: string): Boolean; override;\r\n function ValueExists(const Section, Key: string): Boolean;\r\n function IsFolderInt(const Path: string; ListIsValue: Boolean = True): Boolean; override;\r\n function ReadValue(const Section, Key: string): string; virtual;\r\n procedure WriteValue(const Section, Key, Value: string); virtual;\r\n procedure RemoveValue(const Section, Key: string); virtual;\r\n procedure DeleteSubTreeInt(const Path: string); override;\r\n procedure SplitKeyPath(const Path: string; out Key, ValueName: string); override;\r\n function ValueStoredInt(const Path: string): Boolean; override;\r\n procedure DeleteValueInt(const Path: string); override;\r\n function DoReadInteger(const Path: string; Default: Integer): Integer; override;\r\n procedure DoWriteInteger(const Path: string; Value: Integer); override;\r\n function DoReadFloat(const Path: string; Default: Extended): Extended; override;\r\n procedure DoWriteFloat(const Path: string; Value: Extended); override;\r\n function DoReadString(const Path: string; const Default: string): string; override;\r\n procedure DoWriteString(const Path: string; const Value: string); override;\r\n function DoReadBinary(const Path: string; Buf: TJvBytes; BufSize: Integer): Integer; override;\r\n procedure DoWriteBinary(const Path: string; const Buf: TJvBytes; BufSize: Integer); override;\r\n property DefaultSection: string read FDefaultSection write FDefaultSection;\r\n property IniFile: TMemIniFile read FIniFile;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n {$IFDEF UNICODE}\r\n property Encoding: TEncoding read GetEncoding write SetEncoding;\r\n {$ENDIF UNICODE}\r\n published\r\n property StorageOptions: TJvAppIniStorageOptions read GetStorageOptions write SetStorageOptions;\r\n end;\r\n\r\n // This class handles the flushing into a disk file\r\n // and publishes a few properties for them to be\r\n // used by the user in the IDE\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64 or pidOSX32)]\r\n {$ENDIF RTL230_UP}\r\n TJvAppIniFileStorage = class(TJvCustomAppIniStorage)\r\n protected\r\n procedure ClearInternal; override;\r\n procedure FlushInternal; override;\r\n procedure ReloadInternal; override;\r\n public\r\n property AsString;\r\n property IniFile;\r\n published\r\n property AutoFlush;\r\n property AutoReload;\r\n property FileName;\r\n property FlushOnDestroy;\r\n property Location;\r\n property DefaultSection;\r\n property SubStorages;\r\n property OnGetFileName;\r\n //1 Synchronize the Flush and Reload procedure\r\n /// Defines if the execution of flush and reload for the current\r\n /// File should be synchronized via a global mutex\r\n property SynchronizeFlushReload;\r\n end;\r\n\r\nprocedure StorePropertyStoreToIniFile(APropertyStore: TJvCustomPropertyStore;\r\n const AFileName: string; const AAppStoragePath: string = ''; const\r\n ADefaultSection: string = ''; AStorageOptions: TJvCustomAppStorageOptions =\r\n nil);\r\nprocedure LoadPropertyStoreFromIniFile(APropertyStore: TJvCustomPropertyStore;\r\n const AFileName: string; const AAppStoragePath: string = ''; const\r\n ADefaultSection: string = ''; AStorageOptions: TJvCustomAppStorageOptions =\r\n nil);\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvAppIniStorage.pas $';\r\n Revision: '$Revision: 13350 $';\r\n Date: '$Date: 2012-06-13 16:54:41 +0200 (mer. 13 juin 2012) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n JvJCLUtils, // BinStrToBuf & BufToBinStr\r\n JvConsts, JvResources,\r\n JclStrings;\r\n\r\nconst\r\n cNullDigit = '0';\r\n cCount = 'Count';\r\n cSectionHeaderStart = '[';\r\n cSectionHeaderEnd = ']';\r\n cKeyValueSeparator = '=';\r\n\r\n//=== { TJvAppIniStorageOptions } ============================================\r\n\r\nconstructor TJvAppIniStorageOptions.Create;\r\nbegin\r\n inherited Create;\r\n FReplaceCRLF := False;\r\n FPreserveLeadingTrailingBlanks := False;\r\n FloatAsString := False;\r\nend;\r\n\r\nprocedure TJvAppIniStorageOptions.Assign(Source: TPersistent);\r\nbegin\r\n if (Source = Self) then\r\n Exit;\r\n if Source is TJvAppIniStorageOptions then\r\n begin\r\n ReplaceCRLF := TJvAppIniStorageOptions(Source).ReplaceCRLF;\r\n PreserveLeadingTrailingBlanks := TJvAppIniStorageOptions(Source).PreserveLeadingTrailingBlanks;\r\n end;\r\n inherited Assign(Source);\r\nend;\r\n\r\nprocedure TJvAppIniStorageOptions.SetReplaceCRLF(Value: Boolean);\r\nbegin\r\n FReplaceCRLF := Value;\r\nend;\r\n\r\nprocedure TJvAppIniStorageOptions.SetPreserveLeadingTrailingBlanks(Value: Boolean);\r\nbegin\r\n FPreserveLeadingTrailingBlanks := Value;\r\nend;\r\n\r\n{ Optimalization of TCustomIniFile.ValueExists is only done for Delphi 7; Probably\r\n works the same for other versions, but I can't check that.\r\n Note that this is a dirty hack, a better way would be to rewrite TMemIniFile;\r\n especially expose FSections, but other optimizations can be done also.\r\n For example TCustomIniFile.SectionExists}\r\n{$IFDEF DELPHI7}\r\ntype\r\n TJvMemIniFile = class(TMemIniFile)\r\n public\r\n function DoesValueExists(const Section, Ident: string): Boolean;\r\n end;\r\n\r\n TMemIniFileAccessPrivate = class(TCustomIniFile)\r\n public\r\n FSections: TStringList;\r\n end;\r\n\r\nfunction TJvMemIniFile.DoesValueExists(const Section, Ident: string): Boolean;\r\nvar\r\n I: Integer;\r\n Strings: TStrings;\r\nbegin\r\n I := TMemIniFileAccessPrivate(Self).FSections.IndexOf(Section);\r\n if I >= 0 then\r\n begin\r\n Strings := TStrings(TMemIniFileAccessPrivate(Self).FSections.Objects[I]);\r\n I := Strings.IndexOfName(Ident);\r\n Result := I >= 0;\r\n end else\r\n Result := False;\r\nend;\r\n{$ENDIF DELPHI7}\r\n\r\n//=== { TJvCustomAppIniStorage } =============================================\r\n\r\nconstructor TJvCustomAppIniStorage.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n {$IFDEF DELPHI7}\r\n FIniFile := TJvMemIniFile.Create(Name);\r\n {$ELSE}\r\n FIniFile := TMemIniFile.Create(Name);\r\n {$ENDIF DELPHI7}\r\nend;\r\n\r\ndestructor TJvCustomAppIniStorage.Destroy;\r\nbegin\r\n inherited Destroy;\r\n // Has to be done AFTER inherited, see comment in\r\n // TJvCustomAppMemoryFileStorage\r\n FIniFile.Free;\r\nend;\r\n\r\n// Replaces all CRLF through \"\\n\"\r\n// (rom) probably better use JclStrings.StrEscapedToString and StrStringToEscaped\r\nfunction TJvCustomAppIniStorage.ReplaceCRLFToSlashN(const Value: string): string;\r\nbegin\r\n if (Pos(#13, Value) > 0) or (Pos(#10, Value) > 0) then\r\n begin\r\n Result := StringReplace(Value, '\\', '\\\\', [rfReplaceAll]);\r\n Result := StringReplace(Result , #13#10, '\\n', [rfReplaceAll]);\r\n Result := StringReplace(Result , #10, '\\n', [rfReplaceAll]);\r\n Result := StringReplace(Result , #13, '\\n', [rfReplaceAll]);\r\n end\r\n else\r\n Result := Value;\r\nend;\r\n\r\n// Replaces all \"\\n\" through CRLF\r\nfunction TJvCustomAppIniStorage.ReplaceSlashNToCRLF(const Value: string): string;\r\nvar\r\n P: Integer;\r\n C1, C2: Char;\r\n\r\n function GetNext: Boolean;\r\n begin\r\n Result := Length(Value) >= P;\r\n if Result then\r\n begin\r\n C1 := Value[P];\r\n C2 := Value[P + 1];\r\n end;\r\n Inc(P);\r\n end;\r\n\r\nbegin\r\n P := 1;\r\n C1 := #0;\r\n C2 := #0;\r\n while GetNext do\r\n begin\r\n if (C1 = '\\') and (C2 = '\\') then\r\n begin\r\n Result := Result + C1;\r\n Inc(P);\r\n end\r\n else\r\n if (C1 = '\\') and (C2 = 'n') then\r\n begin\r\n Result := Result + #13#10;\r\n Inc(P);\r\n end\r\n else\r\n Result := Result + C1;\r\n end;\r\nend;\r\n\r\n// Adds \" at the beginning and the end\r\nfunction TJvCustomAppIniStorage.SaveLeadingTrailingBlanks(const Value: string): string;\r\nvar\r\n C1, C2: Char;\r\nbegin\r\n if Value = '' then\r\n Result := ''\r\n else\r\n begin\r\n C1 := Value[1];\r\n C2 := Value[Length(Value)];\r\n if (C1 = ' ') or (C2 = ' ') or\r\n ((C1 = '\"') and (C2 = '\"')) then\r\n Result := '\"' + Value + '\"'\r\n else\r\n Result := Value;\r\n end;\r\nend;\r\n\r\n// Removes \" at the beginning and the end\r\nfunction TJvCustomAppIniStorage.RestoreLeadingTrailingBlanks(const Value: string): string;\r\nbegin\r\n if (Length(Value)>=2) and (Value[1] = '\"') and (Value[Length(Value)] = '\"') then\r\n Result := Copy(Value, 2, Length(Value) - 2)\r\n else\r\n Result := Value;\r\nend;\r\n\r\nprocedure TJvCustomAppIniStorage.SplitKeyPath(const Path: string; out Key, ValueName: string);\r\nbegin\r\n inherited SplitKeyPath(Path, Key, ValueName);\r\n if Key = '' then\r\n Key := DefaultSection;\r\nend;\r\n\r\nfunction TJvCustomAppIniStorage.ValueStoredInt(const Path: string): Boolean;\r\nvar\r\n Section: string;\r\n Key: string;\r\nbegin\r\n SplitKeyPath(Path, Section, Key);\r\n Result := ValueExists(Section, Key);\r\nend;\r\n\r\nprocedure TJvCustomAppIniStorage.DeleteValueInt(const Path: string);\r\nvar\r\n Section: string;\r\n Key: string;\r\nbegin\r\n SplitKeyPath(Path, Section, Key);\r\n RemoveValue(Section, Key);\r\nend;\r\n\r\nfunction TJvCustomAppIniStorage.DoReadInteger(const Path: string; Default: Integer): Integer;\r\nvar\r\n Section: string;\r\n Key: string;\r\n Value: string;\r\nbegin\r\n SplitKeyPath(Path, Section, Key);\r\n if ValueExists(Section, Key) then\r\n begin\r\n Value := ReadValue(Section, Key);\r\n if Value = '' then\r\n Value := cNullDigit;\r\n Result := StrToInt(Value);\r\n end\r\n else\r\n Result := Default;\r\nend;\r\n\r\nprocedure TJvCustomAppIniStorage.DoWriteInteger(const Path: string; Value: Integer);\r\nvar\r\n Section: string;\r\n Key: string;\r\nbegin\r\n SplitKeyPath(Path, Section, Key);\r\n WriteValue(Section, Key, IntToStr(Value));\r\nend;\r\n\r\nfunction TJvCustomAppIniStorage.DoReadFloat(const Path: string; Default: Extended): Extended;\r\nvar\r\n Section: string;\r\n Key: string;\r\n Value: string;\r\n {$IFDEF CPUX64}\r\n Ext80Value: Extended80;\r\n {$ENDIF CPUX64}\r\nbegin\r\n SplitKeyPath(Path, Section, Key);\r\n if ValueExists(Section, Key) then\r\n begin\r\n Value := ReadValue(Section, Key);\r\n {$IFDEF CPUX64}\r\n // Keep backward compatiblity to x86 Extended type\r\n if BinStrToBuf(Value, @Ext80Value, SizeOf(Ext80Value)) = SizeOf(Ext80Value) then\r\n try\r\n Result := Ext80Value\r\n except\r\n Result := Default;\r\n end\r\n else\r\n {$ELSE}\r\n if BinStrToBuf(Value, @Result, SizeOf(Result)) <> SizeOf(Result) then\r\n {$ENDIF CPUX64}\r\n Result := Default;\r\n end\r\n else\r\n Result := Default;\r\nend;\r\n\r\nprocedure TJvCustomAppIniStorage.DoWriteFloat(const Path: string; Value: Extended);\r\nvar\r\n Section: string;\r\n Key: string;\r\n {$IFDEF CPUX64}\r\n Ext80Value: Extended80;\r\n {$ENDIF CPUX64}\r\nbegin\r\n SplitKeyPath(Path, Section, Key);\r\n {$IFDEF CPUX64}\r\n // Keep backward compatiblity to x86 Extended type\r\n Ext80Value := Value;\r\n WriteValue(Section, Key, BufToBinStr(@Ext80Value, SizeOf(Ext80Value)));\r\n {$ELSE}\r\n WriteValue(Section, Key, BufToBinStr(@Value, SizeOf(Value)));\r\n {$ENDIF CPUX64}\r\nend;\r\n\r\nfunction TJvCustomAppIniStorage.DoReadString(const Path: string; const Default: string): string;\r\nvar\r\n Section: string;\r\n Key: string;\r\nbegin\r\n SplitKeyPath(Path, Section, Key);\r\n if ValueExists(Section, Key) then\r\n Result := ReadValue(Section, Key)\r\n else\r\n Result := Default;\r\nend;\r\n\r\nprocedure TJvCustomAppIniStorage.DoWriteString(const Path: string; const Value: string);\r\nvar\r\n Section: string;\r\n Key: string;\r\nbegin\r\n SplitKeyPath(Path, Section, Key);\r\n WriteValue(Section, Key, Value);\r\nend;\r\n\r\nfunction TJvCustomAppIniStorage.DoReadBinary(const Path: string; Buf: TJvBytes; BufSize: Integer): Integer;\r\nvar\r\n Section: string;\r\n Key: string;\r\n Value: string;\r\nbegin\r\n SplitKeyPath(Path, Section, Key);\r\n if ValueExists(Section, Key) then\r\n begin\r\n Value := ReadValue(Section, Key);\r\n Result := BinStrToBuf(Value, Buf, BufSize);\r\n end\r\n else\r\n Result := 0;\r\nend;\r\n\r\nprocedure TJvCustomAppIniStorage.DoWriteBinary(const Path: string; const Buf: TJvBytes; BufSize: Integer);\r\nvar\r\n Section: string;\r\n Key: string;\r\nbegin\r\n SplitKeyPath(Path, Section, Key);\r\n WriteValue(Section, Key, BufToBinStr(Buf, BufSize));\r\nend;\r\n\r\nprocedure TJvCustomAppIniStorage.EnumFolders(const Path: string; const Strings: TStrings;\r\n const ReportListAsValue: Boolean);\r\nvar\r\n RefPath: string;\r\n I: Integer;\r\n TempStrings : tStrings;\r\n s : String;\r\n p : Integer;\r\n lr : Integer;\r\nbegin\r\n TempStrings := TStringlist.Create;\r\n Strings.BeginUpdate;\r\n try\r\n RefPath := GetAbsPath(Path);\r\n ReloadIfNeeded;\r\n IniFile.ReadSections(TempStrings);\r\n lr := Length(RefPath);\r\n for i := 0 to TempStrings.Count - 1 do\r\n begin\r\n s := TempStrings[i];\r\n if (RefPath <> '') and (Copy(s, 1, lr + 1) <> RefPath + PathDelim) then\r\n Continue;\r\n if ReportListAsValue and ValueExists(s, cCount) then\r\n Continue;\r\n if RefPath <> '' then\r\n s := Copy(s, 2 + lr, Length(s) - lr);\r\n p := Pos(PathDelim, s);\r\n if p > 0 then\r\n s := Copy(s, 1, p-1);\r\n if (RefPath = '') and (s = DefaultSection) then\r\n Continue;\r\n if Strings.IndexOf(s) < 0 then\r\n Strings.Add(s);\r\n end;\r\n finally\r\n Strings.EndUpdate;\r\n TempStrings.Free;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomAppIniStorage.EnumValues(const Path: string; const Strings: TStrings;\r\n const ReportListAsValue: Boolean);\r\nvar\r\n PathIsList: Boolean;\r\n RefPath: string;\r\n I: Integer;\r\nbegin\r\n Strings.BeginUpdate;\r\n try\r\n PathIsList := ReportListAsValue and ListStored(Path);\r\n RefPath := GetAbsPath(Path);\r\n if RefPath = '' then\r\n RefPath := DefaultSection;\r\n ReloadIfNeeded;\r\n IniFile.ReadSectionValues(RefPath, Strings);\r\n for I := Strings.Count - 1 downto 0 do\r\n begin\r\n Strings[I] := Copy(Strings[I], 1, Pos(cKeyValueSeparator, Strings[I]) - 1);\r\n if PathIsList and (AnsiSameText(cCount, Strings[I]) or NameIsListItem(Strings[I])) then\r\n Strings.Delete(I);\r\n end;\r\n if PathIsList then\r\n Strings.Add('');\r\n finally\r\n Strings.EndUpdate;\r\n end;\r\nend;\r\n\r\n\r\nfunction TJvCustomAppIniStorage.CalcDefaultSection(Section: string): string;\r\nbegin\r\n if (Section = '') or (Section[1] = '.') then\r\n Result := DefaultSection + Section\r\n else\r\n Result := Section;\r\n if (Result = '') or (Result[1] = '.') then\r\n raise EJVCLAppStorageError.CreateRes(@RsEReadValueFailed);\r\nend;\r\n\r\nfunction TJvCustomAppIniStorage.GetStorageOptions: TJvAppIniStorageOptions;\r\nbegin\r\n Result := TJvAppIniStorageOptions(inherited StorageOptions);\r\nend;\r\n\r\nprocedure TJvCustomAppIniStorage.SetStorageOptions(Value: TJvAppIniStorageOptions);\r\nbegin\r\n (Inherited StorageOptions).Assign(Value);\r\nend;\r\n\r\nfunction TJvCustomAppIniStorage.ValueExists(const Section, Key: string): Boolean;\r\nbegin\r\n if IniFile <> nil then\r\n begin\r\n ReloadIfNeeded;\r\n {$IFDEF DELPHI7}\r\n Result := TJvMemIniFile(IniFile).DoesValueExists(CalcDefaultSection(Section), Key);\r\n {$ELSE}\r\n Result := IniFile.ValueExists(CalcDefaultSection(Section), Key);\r\n {$ENDIF DELPHI7}\r\n end\r\n else\r\n Result := False;\r\nend;\r\n\r\nfunction TJvCustomAppIniStorage.ReadValue(const Section, Key: string): string;\r\nbegin\r\n if IniFile <> nil then\r\n begin\r\n ReloadIfNeeded;\r\n if TJvAppIniStorageOptions(StorageOptions).ReplaceCRLF then\r\n Result := ReplaceSlashNToCRLF(IniFile.ReadString(CalcDefaultSection(Section), Key, ''))\r\n else\r\n Result := IniFile.ReadString(CalcDefaultSection(Section), Key, '');\r\n if TJvAppIniStorageOptions(StorageOptions).PreserveLeadingTrailingBlanks then\r\n Result := RestoreLeadingTrailingBlanks(Result);\r\n end\r\n else\r\n Result := '';\r\nend;\r\n\r\nprocedure TJvCustomAppIniStorage.WriteValue(const Section, Key, Value: string);\r\nbegin\r\n if IniFile <> nil then\r\n begin\r\n ReloadIfNeeded;\r\n if TJvAppIniStorageOptions(StorageOptions).PreserveLeadingTrailingBlanks then\r\n if TJvAppIniStorageOptions(StorageOptions).ReplaceCRLF then\r\n IniFile.WriteString(CalcDefaultSection(Section), Key,\r\n SaveLeadingTrailingBlanks(ReplaceCRLFToSlashN(Value)))\r\n else\r\n IniFile.WriteString(CalcDefaultSection(Section), Key,\r\n SaveLeadingTrailingBlanks(Value))\r\n else\r\n if TJvAppIniStorageOptions(StorageOptions).ReplaceCRLF then\r\n IniFile.WriteString(CalcDefaultSection(Section), Key, ReplaceCRLFToSlashN(Value))\r\n else\r\n IniFile.WriteString(CalcDefaultSection(Section), Key, Value);\r\n FlushIfNeeded;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomAppIniStorage.DeleteSubTreeInt(const Path: string);\r\nvar\r\n TopSection: string;\r\n Sections: TStringList;\r\n I: Integer;\r\nbegin\r\n if IniFile <> nil then\r\n begin\r\n TopSection := GetAbsPath(Path);\r\n Sections := TStringList.Create;\r\n try\r\n if AutoReload and not IsUpdating then\r\n Reload;\r\n IniFile.ReadSections(Sections);\r\n if TopSection = '' then\r\n for I := 0 to Sections.Count - 1 do\r\n IniFile.EraseSection(Sections[I])\r\n else\r\n for I := 0 to Sections.Count - 1 do\r\n if Pos(TopSection, Sections[I]) = 1 then\r\n IniFile.EraseSection(Sections[I]);\r\n FlushIfNeeded;\r\n finally\r\n Sections.Free;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomAppIniStorage.RemoveValue(const Section, Key: string);\r\nvar\r\n LSection: string;\r\nbegin\r\n if IniFile <> nil then\r\n begin\r\n ReloadIfNeeded;\r\n LSection := CalcDefaultSection(Section);\r\n if IniFile.ValueExists(LSection, Key) then\r\n begin\r\n IniFile.DeleteKey(LSection, Key);\r\n FlushIfNeeded;\r\n end\r\n else\r\n if IniFile.SectionExists(LSection + PathDelim + Key) then\r\n begin\r\n IniFile.EraseSection(LSection + PathDelim + Key);\r\n FlushIfNeeded;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJvCustomAppIniStorage.PathExistsInt(const Path: string): Boolean;\r\nbegin\r\n ReloadIfNeeded;\r\n Result := IniFile.SectionExists(StrEnsureNoPrefix(PathDelim, Path));\r\nend;\r\n\r\nfunction TJvCustomAppIniStorage.IsFolderInt(const Path: string; ListIsValue: Boolean): Boolean;\r\nvar\r\n RefPath: string;\r\n ValueNames: TStringList;\r\n Sections : TStringList;\r\n I: Integer;\r\nbegin\r\n RefPath := GetAbsPath(Path);\r\n if RefPath = '' then\r\n RefPath := DefaultSection;\r\n ReloadIfNeeded;\r\n if IniFile.SectionExists(RefPath) then\r\n if ListIsValue and IniFile.ValueExists(RefPath, cCount) then\r\n begin\r\n ValueNames := TStringList.Create;\r\n try\r\n EnumValues(Path, ValueNames, True);\r\n I := ValueNames.Count - 1;\r\n Result := i > 0;\r\n while Result and (I >= 0) do\r\n begin\r\n Result := not AnsiSameText(ValueNames[I], cCount) and not NameIsListItem(ValueNames[I]);\r\n Dec(I);\r\n end;\r\n finally\r\n ValueNames.Free;\r\n end;\r\n end\r\n else\r\n Result := True\r\n else\r\n begin\r\n Sections := tStringList.Create;\r\n try\r\n IniFile.ReadSections(Sections);\r\n for i := 0 to Sections.Count - 1 do\r\n if Pos(RefPath+PathDelim, Sections[i]) = 1 then\r\n begin\r\n Result := True;\r\n Exit;\r\n end;\r\n Result := False;\r\n finally\r\n Sections.Free;\r\n end;\r\n end;\r\nend;\r\n\r\nclass function TJvCustomAppIniStorage.GetStorageOptionsClass: TJvAppStorageOptionsClass;\r\nbegin\r\n Result := TJvAppIniStorageOptions;\r\nend;\r\n\r\nfunction TJvCustomAppIniStorage.GetAsString: string;\r\nvar\r\n TmpList: TStringList;\r\nbegin\r\n TmpList := TStringList.Create;\r\n try\r\n IniFile.GetStrings(TmpList);\r\n Result := TmpList.Text;\r\n finally\r\n TmpList.Free;\r\n end;\r\nend;\r\n\r\n{$IFDEF UNICODE}\r\nfunction TJvCustomAppIniStorage.GetEncoding: TEncoding;\r\nbegin\r\n Result := FIniFile.Encoding;\r\nend;\r\n\r\nprocedure TJvCustomAppIniStorage.SetEncoding(const Value: TEncoding);\r\nbegin\r\n FIniFile.Encoding := Value;\r\nend;\r\n{$ENDIF UNICODE}\r\n\r\nprocedure TJvCustomAppIniStorage.SetAsString(const Value: string);\r\nvar\r\n TmpList: TStringList;\r\nbegin\r\n TmpList := TStringList.Create;\r\n try\r\n TmpList.Text := Value;\r\n IniFile.SetStrings(TmpList);\r\n finally\r\n TmpList.Free;\r\n end;\r\nend;\r\n\r\nfunction TJvCustomAppIniStorage.DefaultExtension: string;\r\nbegin\r\n Result := 'ini';\r\nend;\r\n\r\n//=== { TJvAppIniFileStorage } ===============================================\r\n\r\nprocedure TJvAppIniFileStorage.ClearInternal;\r\nbegin\r\n IniFile.Clear;\r\nend;\r\n\r\n\r\nprocedure TJvAppIniFileStorage.FlushInternal;\r\nbegin\r\n IniFile.Rename(FullFileName, False);\r\n IniFile.UpdateFile;\r\nend;\r\n\r\nprocedure TJvAppIniFileStorage.ReloadInternal;\r\nbegin\r\n IniFile.Rename(FullFileName, True);\r\nend;\r\n\r\n//=== { Common procedures } ==================================================\r\n\r\nprocedure StorePropertyStoreToIniFile(APropertyStore: TJvCustomPropertyStore;\r\n const AFileName: string; const AAppStoragePath: string = ''; const\r\n ADefaultSection: string = ''; AStorageOptions: TJvCustomAppStorageOptions =\r\n nil);\r\nvar\r\n AppStorage: TJvAppIniFileStorage;\r\n SaveAppStorage: TJvCustomAppStorage;\r\n SaveAppStoragePath: string;\r\nbegin\r\n if not Assigned(APropertyStore) then\r\n Exit;\r\n AppStorage := TJvAppIniFileStorage.Create(nil);\r\n try\r\n if Assigned(AStorageOptions) then\r\n AppStorage.StorageOptions.Assign(AStorageOptions);\r\n AppStorage.Location := flCustom;\r\n AppStorage.FileName := AFileName;\r\n AppStorage.DefaultSection := ADefaultSection;\r\n AppStorage.FlushOnDestroy := False;\r\n AppStorage.SynchronizeFlushReload := True;\r\n SaveAppStorage := APropertyStore.AppStorage;\r\n SaveAppStoragePath := APropertyStore.AppStoragePath;\r\n try\r\n APropertyStore.AppStoragePath := AAppStoragePath;\r\n APropertyStore.AppStorage := AppStorage;\r\n APropertyStore.StoreProperties;\r\n finally\r\n APropertyStore.AppStoragePath := SaveAppStoragePath;\r\n APropertyStore.AppStorage := SaveAppStorage;\r\n end;\r\n finally\r\n AppStorage.Free;\r\n end;\r\nend;\r\n\r\nprocedure LoadPropertyStoreFromIniFile(APropertyStore: TJvCustomPropertyStore;\r\n const AFileName: string; const AAppStoragePath: string = ''; const\r\n ADefaultSection: string = ''; AStorageOptions: TJvCustomAppStorageOptions =\r\n nil);\r\nvar\r\n AppStorage: TJvAppIniFileStorage;\r\n SaveAppStorage: TJvCustomAppStorage;\r\n SaveAppStoragePath: string;\r\nbegin\r\n if not Assigned(APropertyStore) then\r\n Exit;\r\n AppStorage := TJvAppIniFileStorage.Create(nil);\r\n try\r\n if Assigned(AStorageOptions) then\r\n AppStorage.StorageOptions.Assign(AStorageOptions);\r\n AppStorage.Location := flCustom;\r\n AppStorage.FileName := AFileName;\r\n AppStorage.DefaultSection := ADefaultSection;\r\n AppStorage.FlushOnDestroy := False;\r\n AppStorage.SynchronizeFlushReload := True;\r\n SaveAppStorage := APropertyStore.AppStorage;\r\n SaveAppStoragePath := APropertyStore.AppStoragePath;\r\n try\r\n APropertyStore.AppStoragePath := AAppStoragePath;\r\n APropertyStore.AppStorage := AppStorage;\r\n APropertyStore.LoadProperties;\r\n finally\r\n APropertyStore.AppStoragePath := SaveAppStoragePath;\r\n APropertyStore.AppStorage := SaveAppStorage;\r\n end;\r\n finally\r\n AppStorage.Free;\r\n end;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvAppInst.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvAppInst.pas, released on 2003-10-07.\r\n\r\nThe Initial Developer of the Original Code is Andreas Hausladen [Andreas dott Hausladen att gmx dott de]\r\nPortions created by Andreas Hausladen are Copyright (C) 2003 Andreas Hausladen.\r\nAll Rights Reserved.\r\n\r\nContributor(s): -\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvAppInst.pas 13189 2012-01-12 18:19:24Z ahuser $\r\n\r\nunit JvAppInst;\r\n\r\n{$I jvcl.inc}\r\n{$I windowsonly.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, Messages, Forms,\r\n Classes, { Classes must be after Forms for Delphi 5 compatibility. }\r\n JclAppInst;\r\n\r\ntype\r\n TJvAppInstDataKind = TJclAppInstDataKind; // = Integer\r\n\r\n TInstanceChangeEvent = procedure(Sender: TObject; ProcessId: Cardinal) of object;\r\n TUserNotifyEvent = procedure(Sender: TObject; Param: Integer) of object;\r\n TDataAvailableEvent = procedure(Sender: TObject; Kind: TJvAppInstDataKind;\r\n Data: Pointer; Size: Integer) of object;\r\n { Data contains the sent data and is released when the function returns }\r\n TCmdLineReceivedEvent = procedure(Sender: TObject; CmdLine: TStrings) of object;\r\n\r\n { TJvAppInstance encapsulates the TJclAppInstance class. To set a\r\n UniqueAppIdGuidStr you must call JclAppInst.JclAppInstances in the\r\n initialization section of a unit or before the forms are created (OnCreate\r\n is too late).\r\n This class is not thread safe. }\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64 or pidOSX32)]\r\n {$ENDIF RTL230_UP}\r\n TJvAppInstances = class(TComponent)\r\n private\r\n FHandle: THandle;\r\n FOnInstanceCreated: TInstanceChangeEvent;\r\n FOnInstanceDestroyed: TInstanceChangeEvent;\r\n FOnUserNotify: TUserNotifyEvent;\r\n FOnDataAvailable: TDataAvailableEvent;\r\n FOnCmdLineReceived: TCmdLineReceivedEvent;\r\n FOnRejected: TNotifyEvent;\r\n FAutoActivate: Boolean;\r\n FMaxInstances: Integer;\r\n FActive: Boolean;\r\n FSendCmdLine: Boolean;\r\n function GetAppInstances: TJclAppInstances;\r\n protected\r\n procedure Loaded; override;\r\n procedure WndProc(var Msg: TMessage); virtual;\r\n function GetIsRemoteInstanceActive: Boolean;\r\n procedure DoInstanceCreated(ProcessId: Cardinal); virtual;\r\n procedure DoInstanceDestroyed(ProcessId: Cardinal); virtual;\r\n procedure DoUserNotify(Param: Integer); virtual;\r\n procedure DoDataAvailable(Kind: TJvAppInstDataKind; Data: Pointer; Size: Integer); virtual;\r\n procedure DoCmdLineReceived(CmdLine: TStrings); virtual;\r\n procedure DoRejected; virtual;\r\n property Handle: THandle read FHandle;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n procedure Check;\r\n procedure UserNotify(Param: Integer);\r\n function SendData(DataKind: TJclAppInstDataKind; Data: Pointer; Size: Integer): Boolean;\r\n property AppInstances: TJclAppInstances read GetAppInstances;\r\n published\r\n property Active: Boolean read FActive write FActive default True;\r\n property AutoActivate: Boolean read FAutoActivate write FAutoActivate default True;\r\n { AutoActivate: True means that the first instance is brought to front\r\n by the second process instance. }\r\n property MaxInstances: Integer read FMaxInstances write FMaxInstances default 1;\r\n { MaxInstances: 0 means no restriction }\r\n property SendCmdLine: Boolean read FSendCmdLine write FSendCmdLine default True;\r\n { SendCmdLine: True means that the second process instance sends it's\r\n CmdLine to the first instance before it terminates. }\r\n property OnInstanceCreated: TInstanceChangeEvent read FOnInstanceCreated write FOnInstanceCreated;\r\n property OnInstanceDestroyed: TInstanceChangeEvent read FOnInstanceDestroyed write FOnInstanceDestroyed;\r\n property OnUserNotify: TUserNotifyEvent read FOnUserNotify write FOnUserNotify;\r\n property OnDataAvailable: TDataAvailableEvent read FOnDataAvailable write FOnDataAvailable;\r\n property OnCmdLineReceived: TCmdLineReceivedEvent read FOnCmdLineReceived write FOnCmdLineReceived;\r\n property OnRejected: TNotifyEvent read FOnRejected write FOnRejected;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvAppInst.pas $';\r\n Revision: '$Revision: 13189 $';\r\n Date: '$Date: 2012-01-12 19:19:24 +0100 (jeu. 12 janv. 2012) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n SysUtils,\r\n JvJVCLUtils;\r\n\r\nconst\r\n sAppInstancesWindowClassName = 'JvAppInstances_WindowClass'; // do not localize\r\n AI_GETACTIVE = $0004;\r\n AI_SETACTIVE = $0005;\r\n\r\n\r\n\r\nvar\r\n FirstJvAppInstance: Boolean = True;\r\n\r\nconstructor TJvAppInstances.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n\r\n if not (csDesigning in ComponentState) then\r\n begin\r\n FHandle := AllocateHWndEx(WndProc, sAppInstancesWindowClassName);\r\n if FirstJvAppInstance then\r\n begin\r\n FirstJvAppInstance := False;\r\n AppInstances.CheckInstance($FFFF); // increase shared instance count\r\n end;\r\n end;\r\n\r\n FActive := True;\r\n FMaxInstances := 1;\r\n FAutoActivate := True;\r\n FSendCmdLine := True;\r\nend;\r\n\r\ndestructor TJvAppInstances.Destroy;\r\nbegin\r\n if not (csDesigning in ComponentState) then\r\n DeallocateHWndEx(FHandle);\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvAppInstances.Check;\r\nbegin\r\n if Active and not (csDesigning in ComponentState) then\r\n if MaxInstances > 0 then\r\n if AppInstances.InstanceIndex[GetCurrentProcessId] >= MaxInstances then // Mantis 3990\r\n begin\r\n if GetIsRemoteInstanceActive then\r\n begin\r\n DoRejected;\r\n if AutoActivate then\r\n AppInstances.SwitchTo(0);\r\n if SendCmdLine then\r\n AppInstances.SendCmdLineParams(sAppInstancesWindowClassName, Handle);\r\n\r\n // As ExitProcess will prevent ANY finalization to occur, we free the\r\n // AppInstances object so that it can cleanup the process information\r\n AppInstances.Free;\r\n ExitProcess(0);\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvAppInstances.DoCmdLineReceived(CmdLine: TStrings);\r\nbegin\r\n if Assigned(FOnCmdLineReceived) then\r\n FOnCmdLineReceived(Self, CmdLine);\r\nend;\r\n\r\nprocedure TJvAppInstances.DoDataAvailable(Kind: TJvAppInstDataKind;\r\n Data: Pointer; Size: Integer);\r\nbegin\r\n if Assigned(FOnDataAvailable) then\r\n FOnDataAvailable(Self, Kind, Data, Size);\r\nend;\r\n\r\nprocedure TJvAppInstances.DoInstanceCreated(ProcessId: Cardinal);\r\nbegin\r\n if Assigned(FOnInstanceCreated) then\r\n FOnInstanceCreated(Self, ProcessId);\r\nend;\r\n\r\nprocedure TJvAppInstances.DoInstanceDestroyed(ProcessId: Cardinal);\r\nbegin\r\n if Assigned(FOnInstanceDestroyed) then\r\n FOnInstanceDestroyed(Self, ProcessId);\r\nend;\r\n\r\nprocedure TJvAppInstances.DoUserNotify(Param: Integer);\r\nbegin\r\n if Assigned(FOnUserNotify) then\r\n FOnUserNotify(Self, Param);\r\nend;\r\n\r\nprocedure TJvAppInstances.DoRejected;\r\nbegin\r\n if Assigned(FOnRejected) then\r\n FOnRejected(Self);\r\nend;\r\n\r\nfunction TJvAppInstances.GetAppInstances: TJclAppInstances;\r\nbegin\r\n if csDesigning in ComponentState then\r\n Result := nil\r\n else\r\n Result := JclAppInstances; // create AppInstance\r\nend;\r\n\r\nprocedure TJvAppInstances.Loaded;\r\nbegin\r\n inherited Loaded;\r\n Check;\r\nend;\r\n\r\nprocedure TJvAppInstances.WndProc(var Msg: TMessage);\r\nvar\r\n Kind: TJvAppInstDataKind;\r\n Data: Pointer;\r\n Size: Integer;\r\n CmdLine: TStrings;\r\nbegin\r\n try\r\n if Msg.Msg = AppInstances.MessageID then\r\n begin\r\n case Msg.WParam of\r\n AI_INSTANCECREATED:\r\n if Cardinal(Msg.LParam) <> GetCurrentProcessId then\r\n DoInstanceCreated(Cardinal(Msg.LParam));\r\n AI_INSTANCEDESTROYED:\r\n DoInstanceDestroyed(Cardinal(Msg.LParam));\r\n AI_USERMSG:\r\n DoUserNotify(Msg.LParam);\r\n AI_GETACTIVE:\r\n SendMessage(HWND(Msg.LParam), AppInstances.MessageID,\r\n AI_SETACTIVE, Ord(Active));\r\n AI_SETACTIVE:\r\n Active := Msg.LParam <> 0;\r\n end;\r\n end\r\n else\r\n begin\r\n Kind := ReadMessageCheck(Msg, Handle);\r\n case Kind of\r\n AppInstDataKindNoData:\r\n ; // do nothing\r\n AppInstCmdLineDataKind:\r\n begin\r\n if Assigned(FOnCmdLineReceived) then\r\n begin\r\n CmdLine := TStringList.Create;\r\n try\r\n ReadMessageStrings(Msg, CmdLine);\r\n DoCmdLineReceived(CmdLine);\r\n finally\r\n CmdLine.Free;\r\n end;\r\n end;\r\n Exit;\r\n end;\r\n else\r\n if Assigned(FOnDataAvailable) then\r\n begin\r\n ReadMessageData(Msg, Data, Size);\r\n try\r\n DoDataAvailable(Kind, Data, Size);\r\n finally\r\n FreeMem(Data);\r\n end;\r\n end;\r\n Exit;\r\n end;\r\n end;\r\n except\r\n on E: Exception do\r\n Application.ShowException(E);\r\n end;\r\n\r\n with Msg do\r\n Result := DefWindowProc(Handle, Msg, WParam, LParam);\r\nend;\r\n\r\nprocedure TJvAppInstances.UserNotify(Param: Integer);\r\nbegin\r\n AppInstances.UserNotify(Param);\r\nend;\r\n\r\nfunction TJvAppInstances.SendData(DataKind: TJclAppInstDataKind;\r\n Data: Pointer; Size: Integer): Boolean;\r\nbegin\r\n Result := AppInstances.SendData(sAppInstancesWindowClassName, DataKind, Data,\r\n Size, Handle);\r\nend;\r\n\r\ntype\r\n PEnumWinData = ^TEnumWinData;\r\n TEnumWinData = record\r\n Instance: TJvAppInstances;\r\n Message: TMessage;\r\n end;\r\n\r\nfunction EnumWinProc(Wnd: HWND; Data: PEnumWinData): BOOL; stdcall;\r\nbegin\r\n with Data^.Message do\r\n SendMessage(Wnd, Msg, WParam, LParam);\r\n Result := Data^.Instance.Active;\r\nend;\r\n\r\nfunction TJvAppInstances.GetIsRemoteInstanceActive: Boolean;\r\nvar\r\n I: Integer;\r\n Wnd: HWND;\r\n TID: DWORD;\r\n Data: TEnumWinData;\r\nbegin\r\n for I := 0 to AppInstances.InstanceCount - 1 do\r\n begin\r\n if AppInstances.ProcessIDs[I] = GetCurrentProcessId then\r\n Continue;\r\n Wnd := AppInstances.AppWnds[I];\r\n TID := GetWindowThreadProcessId(Wnd, nil);\r\n Data.Instance := Self;\r\n Data.Message.Msg := AppInstances.MessageID;\r\n Data.Message.WParam := AI_GETACTIVE;\r\n Data.Message.LParam := Handle;\r\n EnumThreadWindows(TID, @EnumWinProc, LPARAM(@Data));\r\n if not Active then\r\n Break;\r\n end;\r\n Result := Active;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvAppRegistryStorage.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvAppRegistryStorage.pas, released on --.\r\n\r\nThe Initial Developer of the Original Code is Marcel Bestebroer\r\nPortions created by Marcel Bestebroer are Copyright (C) 2002 - 2003 Marcel\r\nBestebroer\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\n Jens Fudickar\r\n Hofi\r\n\r\nLast Modified: 2005-04-10\r\n\r\nChanges:\r\n2005-04-10: by outchy\r\n * Issue 2854: wrong parameter in TJvAppRegistryStorage.DoReadBinary\r\n and TJvAppRegistryStorage.DoWriteBinary\r\n2004-10-11: by Hofi\r\n * Changed\r\n in class\r\n TJvAppRegistryStorage\r\n Root can be set to 'Software\\%COMPANY_NAME%\\%APPL_NAME%' by default\r\n via UseOldDefaultRoot property, just like earlier in the original\r\n RX TFormStorage version. (see below what %APPL_NAME% and %COMPANY_NAME% is)\r\n You can use\r\n - '%NONE%' to sign an empty Root\r\n (design time empty value or spaces automatically converted)\r\n - '%APPL_NAME%' to sign in Root a new path element equal to Application name\r\n - '%COMPANY_NAME%' to sign in Root a new path element equal to DefCompanyName\r\n Create(AOwner: TComponent);\r\n * Added\r\n to class\r\n TJvAppRegistryStorage\r\n property UseOldDefaultRoot:\r\n procedure Loaded; override;\r\n procedure SetRoot(const Value: string);\r\n procedure SetUseOldDefaultRoot(Value: Boolean);\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvAppRegistryStorage.pas 13218 2012-02-24 10:21:00Z obones $\r\n\r\nunit JvAppRegistryStorage;\r\n\r\n{$I jvcl.inc}\r\n{$I windowsonly.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, Classes, Forms,\r\n JvAppStorage, JvTypes;\r\n\r\ntype\r\n TJvAppRegistryStorageOptions = class(TJvAppStorageOptions)\r\n private\r\n public\r\n published\r\n //Flag to determine if a stringlist should be stored as single string and not as list of string items\r\n property StoreStringListAsSingleString;\r\n end;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvAppRegistryStorage = class(TJvCustomAppStorage)\r\n private\r\n FRegHKEY: HKEY;\r\n FUseOldDefaultRoot: Boolean;\r\n FAppNameErrorHandled: Boolean;\r\n FCompanyNameErrorHandled: Boolean;\r\n function GetStorageOptions: TJvAppRegistryStorageOptions;\r\n procedure SetStorageOptions(const Value: TJvAppRegistryStorageOptions);\r\n protected\r\n procedure Loaded; override;\r\n\r\n function GetRegRoot: TJvRegKey;\r\n procedure SetRegRoot(Value: TJvRegKey);\r\n procedure SetRoot(const Value: string);\r\n procedure SetUseOldDefaultRoot(Value: Boolean);\r\n\r\n { Create the registry key path if it doesn't exist yet. Any key in the path that doesn't exist\r\n is created. }\r\n procedure CreateKey(const Key: string);\r\n\r\n procedure EnumFolders(const Path: string; const Strings: TStrings;\r\n const ReportListAsValue: Boolean = True); override;\r\n procedure EnumValues(const Path: string; const Strings: TStrings;\r\n const ReportListAsValue: Boolean = True); override;\r\n\r\n function IsFolderInt(const Path: string; ListIsValue: Boolean = True): Boolean; override;\r\n function PathExistsInt(const Path: string): Boolean; override;\r\n function ValueStoredInt(const Path: string): Boolean; override;\r\n procedure DeleteValueInt(const Path: string); override;\r\n procedure DeleteSubTreeInt(const Path: string); override;\r\n\r\n function DoReadBoolean(const Path: string; Default: Boolean): Boolean; override;\r\n procedure DoWriteBoolean(const Path: string; Value: Boolean); override;\r\n function DoReadInteger(const Path: string; Default: Integer): Integer; override;\r\n procedure DoWriteInteger(const Path: string; Value: Integer); override;\r\n function DoReadFloat(const Path: string; Default: Extended): Extended; override;\r\n procedure DoWriteFloat(const Path: string; Value: Extended); override;\r\n function DoReadString(const Path: string; const Default: string): string; override;\r\n procedure DoWriteString(const Path: string; const Value: string); override;\r\n function DoReadBinary(const Path: string; Buf: TJvBytes; BufSize: Integer): Integer; override;\r\n procedure DoWriteBinary(const Path: string; const Buf: TJvBytes; BufSize: Integer); override;\r\n function DoReadWideString(const Path: string; const Default: Widestring): Widestring; override;\r\n procedure DoWriteWideString(const Path: string; const Value: Widestring); override;\r\n class function GetStorageOptionsClass: TJvAppStorageOptionsClass; override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n published\r\n property RegRoot: TJvRegKey read GetRegRoot write SetRegRoot default hkCurrentUser;\r\n property Root read GetRoot write SetRoot;\r\n property SubStorages;\r\n property FlushOnDestroy;\r\n property UseOldDefaultRoot: Boolean read FUseOldDefaultRoot write SetUseOldDefaultRoot stored True default False ;\r\n\r\n property ReadOnly;\r\n property StorageOptions: TJvAppRegistryStorageOptions read GetStorageOptions\r\n write SetStorageOptions;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvAppRegistryStorage.pas $';\r\n Revision: '$Revision: 13218 $';\r\n Date: '$Date: 2012-02-24 11:21:00 +0100 (ven. 24 févr. 2012) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n SysUtils, Dialogs,\r\n JclRegistry, JclResources,\r\n JvConsts, JvResources;\r\n\r\nconst\r\n cCount = 'Count';\r\n cSoftwareKey = 'Software';\r\n cNoRootMask = '%NONE%';\r\n cAppNameMask = '%APPL_NAME%';\r\n cCompanyNameMask = '%COMPANY_NAME%';\r\n cDefaultAppName = 'MyJVCLApplication';\r\n cDefaultCompanyName = 'MyCompany';\r\n cOldDefaultRootMask = cSoftwareKey + '\\' + cCompanyNameMask + '\\' + cAppNameMask;\r\n\r\n{ (rom) disabled unused\r\nconst\r\n HKEY_Names: array [HKEY_CLASSES_ROOT..HKEY_DYN_DATA, 0..1] of PChar =\r\n (\r\n ('HKEY_CLASSES_ROOT', 'HKCR'),\r\n ('HKEY_CURRENT_USER', 'HKCU'),\r\n ('HKEY_LOCAL_MACHINE', 'HKLM'),\r\n ('HKEY_USERS', 'HKU'),\r\n ('HKEY_PERFORMANCE_DATA', 'HKPD'),\r\n ('HKEY_CURRENT_CONFIG', 'HKCC'),\r\n ('HKEY_DYN_DATA', 'HKDD')\r\n );\r\n}\r\n\r\n//=== { TJvAppRegistryStorage } ==============================================\r\n\r\nconstructor TJvAppRegistryStorage.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FRegHKEY := HKEY_CURRENT_USER;\r\n FUseOldDefaultRoot := False;\r\n FAppNameErrorHandled := False;\r\n FCompanyNameErrorHandled := False;\r\nend;\r\n\r\nprocedure TJvAppRegistryStorage.SetRoot(const Value: string);\r\nvar\r\n S: string;\r\n Changed: Boolean;\r\n\r\nbegin\r\n inherited SetRoot(Value);\r\n if csDesigning in ComponentState then\r\n begin\r\n if Value <> cOldDefaultRootMask then\r\n FUseOldDefaultRoot := False;\r\n if GetRoot = '' then\r\n SetRoot(cNoRootMask);\r\n end\r\n else\r\n begin\r\n { this makes GetDefaultIniRegKey unnecessary ?!?! }\r\n if GetRoot = cNoRootMask then\r\n SetRoot('')\r\n else\r\n s := ActiveTranslateStringEngine.TranslateString(GetRoot, Changed);\r\n if changed then\r\n SetRoot (s);\r\n end;\r\nend;\r\n\r\nprocedure TJvAppRegistryStorage.Loaded;\r\nbegin\r\n inherited Loaded;\r\n SetUseOldDefaultRoot(UseOldDefaultRoot);\r\n SetRoot(GetRoot);\r\nend;\r\n\r\nprocedure TJvAppRegistryStorage.SetUseOldDefaultRoot(Value: Boolean);\r\nbegin\r\n FUseOldDefaultRoot := Value;\r\n if FUseOldDefaultRoot then\r\n SetRoot(cOldDefaultRootMask);\r\nend;\r\n\r\nfunction TJvAppRegistryStorage.GetRegRoot: TJvRegKey;\r\nbegin\r\n Result := TJvRegKey(FRegHKEY - HKEY_CLASSES_ROOT);\r\nend;\r\n\r\nprocedure TJvAppRegistryStorage.SetRegRoot(Value: TJvRegKey);\r\nbegin\r\n if Value <> RegRoot then\r\n FRegHKEY := HKEY_CLASSES_ROOT + Longword(Ord(Value));\r\nend;\r\n\r\nprocedure TJvAppRegistryStorage.CreateKey(const Key: string);\r\nvar\r\n ResKey: HKEY;\r\nbegin\r\n if not RegKeyExists(FRegHKEY, Key) then\r\n if Windows.RegCreateKey(FRegHKEY, PChar(Key), ResKey) = ERROR_SUCCESS then\r\n RegCloseKey(ResKey)\r\n else\r\n raise EJVCLException.CreateResFmt(@RsEUnableToCreateKey, [Key]);\r\nend;\r\n\r\nprocedure TJvAppRegistryStorage.EnumFolders(const Path: string; const Strings: TStrings;\r\n const ReportListAsValue: Boolean);\r\nvar\r\n Key: string;\r\n TmpHKEY: HKEY;\r\n I: Integer;\r\n SubKeyName: array [0..255] of Char;\r\n EnumRes: Longint;\r\nbegin\r\n Key := GetAbsPath(Path);\r\n if RegKeyExists(FRegHKEY, Key) then\r\n if RegOpenKey(FRegHKEY, PChar(Key), TmpHKEY) = ERROR_SUCCESS then\r\n begin\r\n Strings.BeginUpdate;\r\n try\r\n I := 0;\r\n repeat\r\n EnumRes := RegEnumKey(TmpHKEY, I, SubKeyName, SizeOf(SubKeyName));\r\n if (EnumRes = ERROR_SUCCESS) and (not ReportListAsValue or\r\n not ListStored(Path + RegPathDelim + SubKeyName)) then\r\n Strings.Add(SubKeyName);\r\n Inc(I);\r\n until EnumRes <> ERROR_SUCCESS;\r\n if EnumRes <> ERROR_NO_MORE_ITEMS then\r\n raise EJclRegistryError.CreateRes(@RsEEnumeratingRegistry);\r\n finally\r\n RegCloseKey(TmpHKEY);\r\n Strings.EndUpdate;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvAppRegistryStorage.EnumValues(const Path: string; const Strings: TStrings;\r\n const ReportListAsValue: Boolean);\r\nvar\r\n PathIsList: Boolean;\r\n Key: string;\r\n TmpHKEY: HKEY;\r\n I: Integer;\r\n Name: array [0..511] of Char;\r\n NameLen: Cardinal;\r\n EnumRes: Longint;\r\nbegin\r\n PathIsList := ReportListAsValue and ListStored(Path);\r\n if PathIsList then\r\n Strings.Add('');\r\n Key := GetAbsPath(Path);\r\n if RegKeyExists(FRegHKEY, Key) then\r\n if RegOpenKey(FRegHKEY, PChar(Key), TmpHKEY) = ERROR_SUCCESS then\r\n begin\r\n Strings.BeginUpdate;\r\n try\r\n I := 0;\r\n repeat\r\n NameLen := SizeOf(Name);\r\n EnumRes := RegEnumValue(TmpHKEY, I, Name, NameLen, nil, nil, nil, nil);\r\n if (EnumRes = ERROR_SUCCESS) and (not PathIsList or (not AnsiSameText(cCount, Name) and\r\n not NameIsListItem(Name))) then\r\n Strings.Add(Name);\r\n Inc(I);\r\n until EnumRes <> ERROR_SUCCESS;\r\n if EnumRes <> ERROR_NO_MORE_ITEMS then\r\n raise EJclRegistryError.CreateRes(@RsEEnumeratingRegistry);\r\n finally\r\n RegCloseKey(TmpHKEY);\r\n Strings.EndUpdate;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJvAppRegistryStorage.IsFolderInt(const Path: string; ListIsValue: Boolean): Boolean;\r\nvar\r\n RefPath: string;\r\n PathHKEY: HKEY;\r\n I: Integer;\r\n Name: array [0..511] of Char;\r\n NameLen: Cardinal;\r\n EnumRes: Longint;\r\nbegin\r\n Result := False;\r\n RefPath := GetAbsPath(Path);\r\n if RegOpenKey(FRegHKEY, PChar(RefPath), PathHKEY) = ERROR_SUCCESS then\r\n try\r\n Result := True;\r\n if ListIsValue and (RegQueryValueEx(PathHKEY, cCount, nil, nil, nil, nil) = ERROR_SUCCESS) then\r\n begin\r\n Result := False;\r\n I := 0;\r\n repeat\r\n NameLen := SizeOf(Name);\r\n EnumRes := RegEnumValue(PathHKEY, I, Name, NameLen, nil, nil, nil, nil);\r\n Result := (EnumRes = ERROR_SUCCESS) and not AnsiSameText(cCount, Name) and\r\n not NameIsListItem(Name);\r\n Inc(I);\r\n until (EnumRes <> ERROR_SUCCESS) or Result;\r\n if EnumRes <> ERROR_NO_MORE_ITEMS then\r\n raise EJclRegistryError.CreateRes(@RsEEnumeratingRegistry);\r\n end;\r\n finally\r\n RegCloseKey(PathHKEY);\r\n end;\r\nend;\r\n\r\nfunction TJvAppRegistryStorage.PathExistsInt(const Path: string): Boolean;\r\nvar\r\n SubKey: string;\r\n ValueName: string;\r\nbegin\r\n SplitKeyPath(Path, SubKey, ValueName);\r\n Result := RegKeyExists(FRegHKEY, SubKey + RegPathDelim + ValueName);\r\nend;\r\n\r\nfunction TJvAppRegistryStorage.ValueStoredInt(const Path: string): Boolean;\r\nvar\r\n SubKey: string;\r\n ValueName: string;\r\n TmpKey: HKEY;\r\nbegin\r\n SplitKeyPath(Path, SubKey, ValueName);\r\n Result := RegKeyExists(FRegHKEY, SubKey);\r\n if Result then\r\n if RegOpenKey(FRegHKEY, PChar(SubKey), TmpKey) = ERROR_SUCCESS then\r\n try\r\n Result := RegQueryValueEx(TmpKey, PChar(ValueName), nil, nil, nil, nil) = ERROR_SUCCESS;\r\n finally\r\n RegCloseKey(TmpKey);\r\n end\r\n else\r\n raise EJclRegistryError.CreateResFmt(@RsUnableToOpenKeyRead, [SubKey, ValueName]);\r\nend;\r\n\r\nprocedure TJvAppRegistryStorage.DeleteValueInt(const Path: string);\r\nvar\r\n SubKey: string;\r\n ValueName: string;\r\nbegin\r\n if ValueStored(Path) then\r\n begin\r\n SplitKeyPath(Path, SubKey, ValueName);\r\n RegDeleteEntry(FRegHKEY, SubKey, ValueName);\r\n end;\r\nend;\r\n\r\nprocedure TJvAppRegistryStorage.DeleteSubTreeInt(const Path: string);\r\nvar\r\n KeyRoot: string;\r\nbegin\r\n KeyRoot := GetAbsPath(Path);\r\n if RegKeyExists(FRegHKEY, KeyRoot) then\r\n RegDeleteKeyTree(FRegHKEY, KeyRoot);\r\nend;\r\n\r\nfunction TJvAppRegistryStorage.DoReadInteger(const Path: string; Default: Integer): Integer;\r\nvar\r\n SubKey: string;\r\n ValueName: string;\r\nbegin\r\n SplitKeyPath(Path, SubKey, ValueName);\r\n try\r\n Result := RegReadIntegerDef(FRegHKEY, SubKey, ValueName, Default);\r\n except\r\n on E: EJclRegistryError do\r\n if StorageOptions.DefaultIfReadConvertError then\r\n Result := Default\r\n else\r\n raise;\r\n end;\r\nend;\r\n\r\nprocedure TJvAppRegistryStorage.DoWriteInteger(const Path: string; Value: Integer);\r\nvar\r\n SubKey: string;\r\n ValueName: string;\r\nbegin\r\n SplitKeyPath(Path, SubKey, ValueName);\r\n CreateKey(SubKey);\r\n RegWriteInteger(FRegHKEY, SubKey, ValueName, Value);\r\nend;\r\n\r\nfunction TJvAppRegistryStorage.DoReadBoolean(const Path: string; Default: Boolean): Boolean;\r\nvar\r\n SubKey: string;\r\n ValueName: string;\r\nbegin\r\n SplitKeyPath(Path, SubKey, ValueName);\r\n try\r\n Result := RegReadBoolDef(FRegHKEY, SubKey, ValueName, Default);\r\n except\r\n on E: EJclRegistryError do\r\n if StorageOptions.DefaultIfReadConvertError then\r\n Result := Default\r\n else\r\n raise;\r\n end;\r\nend;\r\n\r\nprocedure TJvAppRegistryStorage.DoWriteBoolean(const Path: string; Value: Boolean);\r\nvar\r\n SubKey: string;\r\n ValueName: string;\r\nbegin\r\n SplitKeyPath(Path, SubKey, ValueName);\r\n CreateKey(SubKey);\r\n RegWriteBool(FRegHKEY, SubKey, ValueName, Value);\r\nend;\r\n\r\nfunction TJvAppRegistryStorage.DoReadFloat(const Path: string; Default: Extended): Extended;\r\nvar\r\n SubKey: string;\r\n ValueName: string;\r\n DataType: Cardinal;\r\n {$IFDEF CPUX64}\r\n Ext80Value: Extended80;\r\n {$ENDIF CPUX64}\r\nbegin\r\n SplitKeyPath(Path, SubKey, ValueName);\r\n Result := Default;\r\n try\r\n if not RegGetDataType(FRegHKEY, SubKey, ValueName, DataType) or (DataType = REG_BINARY) then\r\n begin\r\n {$IFDEF CPUX64}\r\n // Keep backward compatiblity to x86 Extended type\r\n RegReadBinary(FRegHKEY, SubKey, ValueName, Ext80Value, SizeOf(Ext80Value));\r\n try\r\n Result := Ext80Value\r\n except\r\n Result := Default;\r\n end;\r\n {$ELSE}\r\n RegReadBinary(FRegHKEY, SubKey, ValueName, Result, SizeOf(Result));\r\n {$ENDIF CPUX64}\r\n end\r\n else\r\n raise EJclRegistryError.CreateResFmt(@RsWrongDataType, ['', SubKey, ValueName]);\r\n except\r\n on E: EJclRegistryError do\r\n if StorageOptions.DefaultIfReadConvertError then\r\n Result := Default\r\n else\r\n raise;\r\n end;\r\nend;\r\n\r\nprocedure TJvAppRegistryStorage.DoWriteFloat(const Path: string; Value: Extended);\r\nvar\r\n SubKey: string;\r\n ValueName: string;\r\n {$IFDEF CPUX64}\r\n Ext80Value: Extended80;\r\n {$ENDIF CPUX64}\r\nbegin\r\n SplitKeyPath(Path, SubKey, ValueName);\r\n CreateKey(SubKey);\r\n {$IFDEF CPUX64}\r\n // Keep backward compatiblity to x86 Extended type\r\n Ext80Value := Value;\r\n RegWriteBinary(FRegHKEY, SubKey, ValueName, Ext80Value, SizeOf(Ext80Value));\r\n {$ELSE}\r\n RegWriteBinary(FRegHKEY, SubKey, ValueName, Value, SizeOf(Value));\r\n {$ENDIF CPUX64}\r\nend;\r\n\r\nfunction TJvAppRegistryStorage.DoReadString(const Path: string; const Default: string): string;\r\nvar\r\n SubKey: string;\r\n ValueName: string;\r\nbegin\r\n SplitKeyPath(Path, SubKey, ValueName);\r\n try\r\n Result := RegReadStringDef(FRegHKEY, SubKey, ValueName, Default);\r\n except\r\n on E: EJclRegistryError do\r\n if StorageOptions.DefaultIfReadConvertError then\r\n Result := Default\r\n else\r\n raise;\r\n end;\r\nend;\r\n\r\nprocedure TJvAppRegistryStorage.DoWriteString(const Path: string; const Value: string);\r\nvar\r\n SubKey: string;\r\n ValueName: string;\r\nbegin\r\n SplitKeyPath(Path, SubKey, ValueName);\r\n CreateKey(SubKey);\r\n RegWriteString(FRegHKEY, SubKey, ValueName, Value);\r\nend;\r\n\r\nfunction TJvAppRegistryStorage.DoReadWideString(const Path: string; const Default: Widestring): Widestring;\r\nvar\r\n SubKey: string;\r\n ValueName: string;\r\nbegin\r\n SplitKeyPath(Path, SubKey, ValueName);\r\n try\r\n Result := RegReadWideStringDef(FRegHKEY, SubKey, ValueName, Default);\r\n except\r\n on E: EJclRegistryError do\r\n if StorageOptions.DefaultIfReadConvertError then\r\n Result := Default\r\n else\r\n raise;\r\n end;\r\nend;\r\n\r\nprocedure TJvAppRegistryStorage.DoWriteWideString(const Path: string; const Value: Widestring);\r\nvar\r\n SubKey: string;\r\n ValueName: string;\r\nbegin\r\n SplitKeyPath(Path, SubKey, ValueName);\r\n CreateKey(SubKey);\r\n RegWriteWideString(FRegHKEY, SubKey, ValueName, Value);\r\nend;\r\n\r\nfunction TJvAppRegistryStorage.DoReadBinary(const Path: string; Buf: TJvBytes; BufSize: Integer): Integer;\r\nvar\r\n SubKey: string;\r\n ValueName: string;\r\nbegin\r\n SplitKeyPath(Path, SubKey, ValueName);\r\n Result := RegReadBinary(FRegHKEY, SubKey, ValueName, Buf^, BufSize);\r\nend;\r\n\r\nprocedure TJvAppRegistryStorage.DoWriteBinary(const Path: string; const Buf: TJvBytes; BufSize: Integer);\r\nvar\r\n SubKey: string;\r\n ValueName: string;\r\nbegin\r\n SplitKeyPath(Path, SubKey, ValueName);\r\n CreateKey(SubKey);\r\n RegWriteBinary(FRegHKEY, SubKey, ValueName, Buf^, BufSize);\r\nend;\r\n\r\nfunction TJvAppRegistryStorage.GetStorageOptions: TJvAppRegistryStorageOptions;\r\nbegin\r\n Result := TJvAppRegistryStorageOptions(inherited StorageOptions);\r\nend;\r\n\r\nclass function TJvAppRegistryStorage.GetStorageOptionsClass:\r\n TJvAppStorageOptionsClass;\r\nbegin\r\n Result := TJvAppRegistryStorageOptions;\r\nend;\r\n\r\nprocedure TJvAppRegistryStorage.SetStorageOptions(const Value:\r\n TJvAppRegistryStorageOptions);\r\nbegin\r\n (Inherited StorageOptions).Assign(Value);\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvAppStorage.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvAppStorage.pas, released on --.\r\n\r\nThe Initial Developer of the Original Code is Marcel Bestebroer\r\nPortions created by Marcel Bestebroer are Copyright (C) 2002 - 2003 Marcel\r\nBestebroer\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\n Jens Fudickar\r\n Olivier Sannier\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nDescription:\r\n General storage unit - provides with a basic storage backend component to store application\r\n specific data. Descendants can provide specific backends for registry, INI-files, DB, XML,\r\n etc. Should be used to provide a common interface for storing data as is done in some of\r\n the JVCL components (eg. JvFormPlacement/JvFormStorage).\r\n\r\n This was requested in one of the comments of the JVCL 3.0 Survey Results.\r\n\r\n Paths\r\n =====\r\n Paths are relative to the current path. Paths are specified using backslashes (\\) between\r\n individual folders and the value. Paths starting with a backslash are always relative to the root\r\n storage (application specific root, absolute root path).\r\n\r\n Dots (.) are used to reference parent folders with the following rules:\r\n * a single dot (.) refers to the current folder\r\n * each additional dot moves up a level in the folder hierarchie, ie. \"....\\Here\" refers to a\r\n folder three levels up from the current where a sub folder/value name \"Here\" is searched. Of\r\n course the normal (OS path) specification can be used as well (\"..\\..\\..\\Here\" would be the\r\n same as the first example).\r\n\r\n Multiple backslashes without names between them are ignored (\"Root\\\\Here\" is the same as\r\n \"Root\\Here\").\r\n\r\n Storage hierarchies\r\n ===================\r\n Each storage allows you add an unlimited number of sub storages. A sub storage is a symbolic\r\n link between a path in a storage to another storage (which in turn can also provide sub storages).\r\n\r\n Suppose you want to store both generic as well as user specific settings. This can be accomplished\r\n with two stores, one for the generic settings and one specific for the current user. The generic\r\n store (referred to as 'asRegBackend' from now on) will link to the user specific store (referred\r\n to as 'asUserIniBackend' from now on) using asRegBackend.SubStorages. The RootPath for the\r\n asUserIniBackend sub-store link will be set to 'UserSettings'. From that point on, any reference\r\n to a sub path of '\\UserSettings' from the asRegBackend storage will be handed over to the\r\n asUserIniBackend storage. Examples:\r\n\r\n Path Target\r\n ==== ======\r\n \\WinPath asRegBackend:'\\WinPath'\r\n \\Generic\\UserSettings\\Me asRegBackend:'\\Generic\\UserSettings\\Me'\r\n \\UserSettings asRegBackend:'\\UserSettings'\r\n \\UserSettings\\FirstName asUserIniBackend:'\\FirstName'\r\n \\UserSettings\\Sub1\\Sub1.1 asUserIniBackend:'\\Sub1\\Sub1.1'\r\n\r\n Because all settings can be read from a single store (from the application's perspective) you have\r\n created the option to keep your settings storage and retrieval code simple and easy to understand.\r\n Upon startup you can set asUserIniBackend to the correct INI file for the user that has logged on,\r\n and you are ready to read in the settings of that user.\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvAppStorage.pas 13415 2012-09-10 09:51:54Z obones $\r\n\r\nunit JvAppStorage;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows,\r\n JclStrings, // must be included before WideStrings\r\n {$IFDEF COMPILER10_UP}\r\n WideStrings,\r\n {$ENDIF COMPILER10_UP}\r\n SysUtils, Classes, TypInfo, Variants,\r\n JclBase,\r\n {$IFNDEF COMPILER12_UP}\r\n JvJCLUtils,\r\n {$ENDIF ~COMPILER12_UP}\r\n JvComponentBase, JvTypes, JvTranslateString;\r\n\r\nconst\r\n // (rom) this name is shared in several units and should be made global\r\n cItem = 'Item';\r\n {$NODEFINE cItem}\r\n cVersionCheckName = 'Version';\r\n {$NODEFINE cVersionCheckName}\r\n\r\ntype\r\n TJvCustomAppStorage = class;\r\n TJvAppStorage = class;\r\n TJvCustomAppStorageOptions = class;\r\n TJvAppSubStorages = class;\r\n TJvAppSubStorage = class;\r\n\r\n EJVCLAppStorageError = class(EJVCLException);\r\n\r\n { TAppStorage does not automatically store published properties of a class that\r\n supports the IJvAppStorageHandler interface. Instead it invokes the Read and\r\n Write methods. }\r\n IJvAppStorageHandler = interface\r\n ['{E3754817-49A3-4612-A228-5D44A088681D}']\r\n procedure ReadFromAppStorage(AppStorage: TJvCustomAppStorage; const BasePath: string);\r\n procedure WriteToAppStorage(AppStorage: TJvCustomAppStorage; const BasePath: string);\r\n end;\r\n\r\n { TAppStorage automatically stores published properties of a class that\r\n supports the IJvAppStoragePublishedProps interface, even if the class\r\n supports the IJvAppStorageHandler interface, too. }\r\n IJvAppStoragePublishedProps = interface\r\n ['{0211AEF7-CCE9-4F13-B3CE-287251C89182}']\r\n end;\r\n\r\n TJvAppStorageListItemEvent = procedure(Sender: TJvCustomAppStorage; const Path: string;\r\n const List: TObject; const Index: Integer; const ItemName: string) of object;\r\n TJvAppStorageListDeleteEvent = procedure(Sender: TJvCustomAppStorage; const Path: string;\r\n const List: TObject; const First, Last: Integer; const ItemName: string) of object;\r\n TJvAppStoragePropTranslateEvent = procedure(Sender: TJvCustomAppStorage; Instance: TPersistent;\r\n var Name: string; const Reading: Boolean) of object;\r\n TJvAppStorageCryptEvent = procedure(var Value: string) of object;\r\n TJvAppStorageGetFileNameEvent = procedure(Sender: TJvCustomAppStorage;\r\n var FileName: TFileName) of object;\r\n TJvAppStorageObjectListItemCreateEvent = function(Sender: TJvCustomAppStorage; const Path: string; Index: Integer):\r\n TPersistent of object;\r\n TJvAppStorageErrorEvent = procedure(Sender: TObject; const Value: string) of object;\r\n\r\n TJvAppStorageOptionsClass = class of TJvCustomAppStorageOptions;\r\n\r\n TJvAppStorageEnumOption = (\r\n aeoFolders, // report folders\r\n aeoValues, // report values\r\n aeoReportListAsValue, // report list as value (a list is actually a folder containing a Count and Item? values)\r\n aeoReportRelative, // report all found folders and values relative to the requested path (otherwise relative to the Root path)\r\n aeoRecursive); // scan sub folders as well\r\n TJvAppStorageEnumOptions = set of TJvAppStorageEnumOption;\r\n\r\n TSynchronizeMethod = procedure of object;\r\n\r\n TFileLocation = (\r\n flCustom, // FileName property will contain full path\r\n{$IFDEF MSWINDOWS}\r\n flWindows, // Store in %WINDOWS%; only use file name part of FileName property.\r\n{$ENDIF MSWINDOWS}\r\n flTemp, // Store in %TEMP%; only use file name part of FileName property.\r\n flExeFile, // Store in same folder as application's exe file; only use file name part of FileName property.\r\n flUserFolder);\r\n // Store in %USER%\\Application Data. Use the FileName property if it's a relative path or only the file name part of FileName property.\r\n\r\n TJvCustomAppStorage = class(TJvComponent)\r\n private\r\n CachedFormatSettings: TFormatSettings;\r\n FRoot: string;\r\n FCurPath: string;\r\n FStorageOptions: TJvCustomAppStorageOptions;\r\n FSubStorages: TJvAppSubStorages;\r\n FOnTranslatePropertyName: TJvAppStoragePropTranslateEvent;\r\n FOnEncryptPropertyValue: TJvAppStorageCryptEvent;\r\n FOnDecryptPropertyValue: TJvAppStorageCryptEvent;\r\n FCryptEnabledStatus: Integer;\r\n FAutoFlush: Boolean;\r\n FUpdateCount: Integer;\r\n FAutoReload: Boolean;\r\n FCurrentInstanceCreateEvent: TJvAppStorageObjectListItemCreateEvent;\r\n FInternalTranslateStringEngine: TJvTranslateString;\r\n FReadOnly: Boolean;\r\n FOnError: TJvAppStorageErrorEvent;\r\n FTranslateStringEngine: TJvTranslateString;\r\n FSynchronizeFlushReload: Boolean;\r\n function GetActiveTranslateStringEngine: TJvTranslateString;\r\n function GetUpdating: Boolean;\r\n procedure SetTranslateStringEngine(const Value: TJvTranslateString);\r\n protected\r\n FFlushOnDestroy: Boolean;\r\n\r\n procedure Notification(AComponent: TComponent; Operation: TOperation); override;\r\n\r\n //1 Synchronize the Flush and Reload procedure\r\n /// Defines if the execution of flush and reload for the current\r\n /// AppStoragePath should be synchronized via a global mutex\r\n /// This property should be published in the dependent classes\r\n /// The procedure Synchronize could be used in the dependent class\r\n /// to implement the synchronisation\r\n property SynchronizeFlushReload: Boolean read FSynchronizeFlushReload write\r\n FSynchronizeFlushReload default False;\r\n //1 Synchronize the execution of an method using a JclMutex\r\n procedure Synchronize(AMethod: TSynchronizeMethod; AIdentifier: String);\r\n\r\n { Sets the value of FFlushOnDestroy. Derived classes may override this\r\n method to prevent it from changing or add extra behaviour to it. }\r\n procedure SetFlushOnDestroy(Value: Boolean); virtual;\r\n\r\n //Returns the property count of an instance\r\n function GetPropCount(Instance: TPersistent): Integer;\r\n //Returns the property name of an instance at a certain index\r\n function GetPropName(Instance: TPersistent; Index: Integer): string;\r\n { Retrieve the class that holds the storage options and format settings. }\r\n class function GetStorageOptionsClass: TJvAppStorageOptionsClass; virtual;\r\n { Split the specified path into an absolute path and a value name (the last item in the path\r\n string). Just a helper for all the storage methods. }\r\n procedure SplitKeyPath(const Path: string; out Key, ValueName: string); virtual;\r\n { SubStorages property set method. Does nothing. }\r\n procedure SetSubStorages(Value: TJvAppSubStorages);\r\n { Retrieve application specific root. Path is prepended to any path specified and serves as an\r\n absolute root for any storage method. }\r\n function GetRoot: string;\r\n { Set application specific root. Path is prepended to any path specified and serves as an\r\n absolute root for any storage method. }\r\n procedure SetRoot(const Value: string);\r\n { Retrieves currently set path (including the Root path). }\r\n function GetCurrentPath: string;\r\n { Returns the path as an absolute path (including the Root path). If the given path does not\r\n start with a backslash (\\) the path is appended to the Root path, resolving any references to\r\n parent folders. }\r\n function GetAbsPath(const Path: string): string;\r\n { StringList item reader used by ReadStringList in the call to ReadList. }\r\n procedure ReadStringListItem(Sender: TJvCustomAppStorage; const Path: string;\r\n const List: TObject; const Index: Integer; const ItemName: string);\r\n { StringList item writer used by WriteStringList in the call to WriteList. }\r\n procedure WriteStringListItem(Sender: TJvCustomAppStorage; const Path: string;\r\n const List: TObject; const Index: Integer; const ItemName: string);\r\n { StringList item deleter used by WriteStringList in the call to WriteList. }\r\n procedure DeleteStringListItem(Sender: TJvCustomAppStorage; const Path: string;\r\n const List: TObject; const First, Last: Integer; const ItemName: string);\r\n\r\n { Default Function for creating a new Object. The classname could be received from the AppStorage using the Path \"Classname\" }\r\n function DefaultObjectListItemCreateEvent(Sender: TJvCustomAppStorage; const Path: string; Index: Integer):\r\n TPersistent;\r\n\r\n { ObjectList item reader used by ReadObjectList in the call to ReadList. }\r\n procedure ReadObjectListItem(Sender: TJvCustomAppStorage; const Path: string;\r\n const List: TObject; const Index: Integer; const ItemName: string);\r\n { ObjectList item writer used by WriteObjectList in the call to WriteList. }\r\n procedure WriteObjectListItem(Sender: TJvCustomAppStorage; const Path: string;\r\n const List: TObject; const Index: Integer; const ItemName: string);\r\n { ObjectList item deleter used by WriteObjectList in the call to WriteList. }\r\n procedure DeleteObjectListItem(Sender: TJvCustomAppStorage; const Path: string;\r\n const List: TObject; const First, Last: Integer; const ItemName: string);\r\n {$IFDEF COMPILER10_UP}\r\n { StringList item reader used by ReadWideStringList in the call to ReadList. }\r\n procedure ReadWideStringListItem(Sender: TJvCustomAppStorage; const Path: string;\r\n const List: TObject; const Index: Integer; const ItemName: string);\r\n { StringList item writer used by WriteStringList in the call to WriteList. }\r\n procedure WriteWideStringListItem(Sender: TJvCustomAppStorage; const Path: string;\r\n const List: TObject; const Index: Integer; const ItemName: string);\r\n { StringList item deleter used by WriteStringList in the call to WriteList. }\r\n procedure DeleteWideStringListItem(Sender: TJvCustomAppStorage; const Path: string;\r\n const List: TObject; const First, Last: Integer; const ItemName: string);\r\n {$ENDIF}\r\n\r\n { StringList item reader used by ReadStringObjectList in the call to ReadList. }\r\n procedure ReadStringObjectListItem(Sender: TJvCustomAppStorage; const Path: string;\r\n const List: TObject; const Index: Integer; const ItemName: string);\r\n { StringList item writer used by WriteStringObjectList in the call to WriteList. }\r\n procedure WriteStringObjectListItem(Sender: TJvCustomAppStorage; const Path: string;\r\n const List: TObject; const Index: Integer; const ItemName: string);\r\n { StringList item deleter used by WriteStringObjectList in the call to WriteList. }\r\n procedure DeleteStringObjectListItem(Sender: TJvCustomAppStorage; const Path: string;\r\n const List: TObject; const First, Last: Integer; const ItemName: string);\r\n\r\n { Collection item reader used by ReadCollection in the call to ReadList. }\r\n procedure ReadCollectionItem(Sender: TJvCustomAppStorage; const Path: string;\r\n const List: TObject; const Index: Integer; const ItemName: string);\r\n { Collection item writer used by WriteCollection in the call to WriteList. }\r\n procedure WriteCollectionItem(Sender: TJvCustomAppStorage; const Path: string;\r\n const List: TObject; const Index: Integer; const ItemName: string);\r\n { Collection item deleter used by WriteCollection in the call to WriteList. }\r\n procedure DeleteCollectionItem(Sender: TJvCustomAppStorage; const Path: string;\r\n const List: TObject; const First, Last: Integer; const ItemName: string);\r\n\r\n { Enum all folders in the specified folder. }\r\n procedure EnumFolders(const Path: string; const Strings: TStrings;\r\n const ReportListAsValue: Boolean = True); virtual; abstract;\r\n { Enum all values below in the specified folder. }\r\n procedure EnumValues(const Path: string; const Strings: TStrings;\r\n const ReportListAsValue: Boolean = True); virtual; abstract;\r\n { Internal retrieval of GetStoredValues. Is used to handle recursiveness. }\r\n procedure InternalGetStoredValues(const PrefixPath, SearchPath: string;\r\n const Strings: TStrings; const Options: TJvAppStorageEnumOptions);\r\n { Current root path for storage. Paths used in other methods are relative to this path. }\r\n function GetPath: string;\r\n { Specify a new root. Given path is relative to the current path. Se remarks above }\r\n procedure SetPath(const Path: string);\r\n { Determines if the specified name belongs to a list value. }\r\n class function NameIsListItem(const Name: string): Boolean;\r\n { Application specific root. Path is prepended to any specified path and serves as an absolute\r\n root for any reading/writing. Not all implementation will use it. Generally it's used for\r\n storages not specific to an application (such as the registry). }\r\n property Root: string read GetRoot write SetRoot;\r\n { Set the StorageOptions Property }\r\n procedure SetStorageOptions(Value: TJvCustomAppStorageOptions);\r\n { Invokes the OnTranslatePropertyName event if one is assigned. }\r\n procedure DoTranslatePropertyName(Instance: TPersistent; var Name: string; const Reading: Boolean);\r\n { Determines if the specified is a sub store of this storage (will scan the entire sub storage\r\n hierarchy. }\r\n function HasSubStorage(AStore: TJvCustomAppStorage): Boolean;\r\n\r\n { Determines if the path represents a folder (ignores sub stores) }\r\n function IsFolderInt(const Path: string; ListIsValue: Boolean = True): Boolean; virtual; abstract;\r\n { Determines if the specified path exists (ignores sub stores) }\r\n function PathExistsInt(const Path: string): Boolean; virtual; abstract;\r\n { Determines if the specified value is stored (ignores sub stores) }\r\n function ValueStoredInt(const Path: string): Boolean; virtual; abstract;\r\n { Determines if the specified list is stored (ignores sub stores) }\r\n function ListStoredInt(const Path: string; const ItemName: string = cItem): Boolean; virtual;\r\n { Deletes the specified value. If the value wasn't stored, nothing will happen (ignores sub\r\n stores). }\r\n procedure DeleteValueInt(const Path: string); virtual; abstract;\r\n { Deletes all values and sub folders of the specified folder including the folder itself\r\n (ignores sub stores). }\r\n procedure DeleteSubTreeInt(const Path: string); virtual; abstract;\r\n { Retrieves the specified Integer value. If the value is not found, the Default will be\r\n returned. If the value is not an Integer (or can't be converted to an Integer an EConvertError\r\n exception will be raised. }\r\n function DoReadInteger(const Path: string; Default: Integer): Integer; virtual; abstract;\r\n { Stores an Integer value. }\r\n procedure DoWriteInteger(const Path: string; Value: Integer); virtual; abstract;\r\n { Retrieves the specified Extended value. If the value is not found, the Default will be\r\n returned. If the value is not an Extended (or can't be converted to an Extended an\r\n EConvertError exception will be raised.}\r\n function DoReadFloat(const Path: string; Default: Extended): Extended; virtual; abstract;\r\n { Stores an Extended value. }\r\n procedure DoWriteFloat(const Path: string; Value: Extended); virtual; abstract;\r\n { Retrieves the specified string value. If the value is not found, the Default will be\r\n returned. If the value is not a string (or can't be converted to a string an EConvertError\r\n exception will be raised. }\r\n function DoReadString(const Path: string; const Default: string): string; virtual; abstract;\r\n { Stores an string value. }\r\n procedure DoWriteString(const Path: string; const Value: string); virtual; abstract;\r\n\r\n { Retrieves the specified widestring value. If the value is not found, the Default will be\r\n returned. If the value is not a string (or can't be converted to a string an EConvertError\r\n exception will be raised. }\r\n function DoReadWideString(const Path: string; const Default: Widestring): Widestring; virtual;\r\n { Stores an widestring value. }\r\n procedure DoWriteWideString(const Path: string; const Value: Widestring); virtual;\r\n\r\n { Retrieves the specified value into a buffer. The result holds the number of bytes actually\r\n retrieved. }\r\n function DoReadBinary(const Path: string; Buf: TJvBytes; BufSize: Integer): Integer; virtual; abstract;\r\n { Stores a buffer. }\r\n procedure DoWriteBinary(const Path: string; const Buf: TJvBytes; BufSize: Integer); virtual; abstract;\r\n { Retrieves the specified TDateTime value. If the value is not found, the Default will be\r\n returned. If the value is not a TDateTime (or can't be converted to an TDateTime an\r\n EConvertError exception will be raised. }\r\n function DoReadDateTime(const Path: string; Default: TDateTime): TDateTime; virtual;\r\n { Stores a TDateTime value (ignores sub stores). }\r\n procedure DoWriteDateTime(const Path: string; Value: TDateTime); virtual;\r\n { Retrieves the specified Boolean value. If the value is not found, the Default will be\r\n returned. If the value is not a Boolean (or can't be converted to an Boolean an\r\n EConvertError exception will be raised. }\r\n function DoReadBoolean(const Path: string; Default: Boolean): Boolean; virtual;\r\n { Stores a Boolean value. }\r\n procedure DoWriteBoolean(const Path: string; Value: Boolean); virtual;\r\n\r\n { Retrieves the specified Integer value. If the value is not found, the Default will be\r\n returned. If the value is not an Integer (or can't be converted to an Integer an EConvertError\r\n exception will be raised. }\r\n function ReadIntegerInt(const Path: string; Default: Integer): Integer; virtual;\r\n { Stores an Integer value (ignores sub stores). }\r\n procedure WriteIntegerInt(const Path: string; Value: Integer); virtual;\r\n { Retrieves the specified Extended value. If the value is not found, the Default will be\r\n returned. If the value is not an Extended (or can't be converted to an Extended an\r\n EConvertError exception will be raised (ignores sub stores). }\r\n function ReadFloatInt(const Path: string; Default: Extended): Extended; virtual;\r\n { Stores an Extended value (ignores sub stores). }\r\n procedure WriteFloatInt(const Path: string; Value: Extended); virtual;\r\n { Retrieves the specified string value. If the value is not found, the Default will be\r\n returned. If the value is not a string (or can't be converted to a string an EConvertError\r\n exception will be raised (ignores sub stores). }\r\n function ReadStringInt(const Path: string; const Default: string): string; virtual;\r\n { Stores an string value (ignores sub stores). }\r\n procedure WriteStringInt(const Path: string; const Value: string); virtual;\r\n { Retrieves the specified value into a buffer. The result holds the number of bytes actually\r\n retrieved (ignores sub stores). }\r\n function ReadBinaryInt(const Path: string; Buf: TJvBytes; BufSize: Integer): Integer; virtual;\r\n { Stores a buffer (ignores sub stores). }\r\n procedure WriteBinaryInt(const Path: string; const Buf: TJvBytes; BufSize: Integer); virtual;\r\n { Retrieves the specified TDateTime value. If the value is not found, the Default will be\r\n returned. If the value is not a TDateTime (or can't be converted to an TDateTime an\r\n EConvertError exception will be raised (ignores sub stores). }\r\n function ReadDateTimeInt(const Path: string; Default: TDateTime): TDateTime; virtual;\r\n { Stores a TDateTime value (ignores sub stores). }\r\n procedure WriteDateTimeInt(const Path: string; Value: TDateTime); virtual;\r\n { Retrieves the specified Boolean value. If the value is not found, the Default will be\r\n returned. If the value is not a Boolean (or can't be converted to an Boolean an\r\n EConvertError exception will be raised (ignores sub stores). }\r\n function ReadBooleanInt(const Path: string; Default: Boolean): Boolean; virtual;\r\n { Stores a Boolean value (ignores sub stores). }\r\n procedure WriteBooleanInt(const Path: string; Value: Boolean); virtual;\r\n { Retrieves an enumeration. If the value is not found, the Default will be returned (ignores sub\r\n stores). }\r\n procedure ReadEnumerationInt(const Path: string; TypeInfo: PTypeInfo; const Default;\r\n out Value); virtual;\r\n { Stores an enumeration (ignores sub stores). }\r\n procedure WriteEnumerationInt(const Path: string; TypeInfo: PTypeInfo; const Value); virtual;\r\n { Retrieves a set. If the value is not found, the Default will be returned (ignores sub\r\n stores). }\r\n procedure ReadSetInt(const Path: string; ATypeInfo: PTypeInfo; const Default; out Value); virtual;\r\n { Stores a set (ignores sub stores). }\r\n procedure WriteSetInt(const Path: string; ATypeInfo: PTypeInfo; const Value); virtual;\r\n\r\n function EncryptPropertyValue(Value: string): string;\r\n function DecryptPropertyValue(Value: string): string;\r\n\r\n procedure SetReadOnly(Value: Boolean);\r\n function GetReadOnly: Boolean;\r\n function GetPhysicalReadOnly: Boolean; virtual;\r\n\r\n property SubStorages: TJvAppSubStorages read FSubStorages write SetSubStorages;\r\n function DecodeStrToDateTime(Value: string): TDateTime; virtual;\r\n function EncodeDateTimeToStr(Value: TDateTime): string; virtual;\r\n procedure Loaded; override;\r\n procedure DoError(const msg: string);\r\n function GetFormatSettings: TFormatSettings;\r\n function ReadListItemCount(const Path: string; const ItemName: string = cItem): Integer; virtual;\r\n procedure WriteListItemCount(const Path: string; const ItemCount: Integer; const ItemName: string = cItem); virtual;\r\n // Change the ReadOnly CurrentInstanceCreateEvent Event\r\n procedure SetCurrentInstanceCreateEvent(const Value:\r\n TJvAppStorageObjectListItemCreateEvent);\r\n property CurrentInstanceCreateEvent: TJvAppStorageObjectListItemCreateEvent\r\n read FCurrentInstanceCreateEvent;\r\n public\r\n {$IFDEF SUPPORTS_CLASS_CTORDTORS}\r\n class destructor Destroy;\r\n {$ENDIF SUPPORTS_CLASS_CTORDTORS}\r\n\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n // (p3) moved Flush, Reload and AutoFlush to the base storage because users\r\n // should be able to call Flush and Reload as needed without being dependant on whether\r\n // the spcific storage implements it or not. Also made them virtual - if Flush and Reload\r\n // doesn't make sense for a specific storage, it shouldn't have to implement them\r\n procedure Flush; virtual;\r\n procedure Reload; virtual;\r\n // Do a Reload if the function ReloadNeeded returns true\r\n procedure ReloadIfNeeded;\r\n function ReloadNeeded: Boolean; virtual;\r\n //1 Do a Flush if the function FlushNeeded returns true\r\n procedure FlushIfNeeded;\r\n function FlushNeeded: Boolean; virtual;\r\n //1 Disables all AutoFlush/AutoReload activities\r\n procedure BeginUpdate;\r\n //1 Reanables all AutoFlush/AutoReload activities\r\n procedure EndUpdate;\r\n //1 Property to show whether the storage is in a beginupdate/endupdate block or not\r\n property IsUpdating: Boolean read GetUpdating;\r\n // Property to define that after every change in the data this\r\n // changes should automaticly stored\r\n property AutoFlush: Boolean read FAutoFlush write FAutoFlush default False;\r\n // Property to define that before any data is read from the storage\r\n // the contents should be reread\r\n property AutoReload: Boolean read FAutoReload write FAutoReload default False;\r\n { This procedure gives the possibility to delete a tree out of the Appstorage\r\n depending on a stored value named \"Version\".\r\n Path is the path of the storage, VersionNumber is the Value which is compared.\r\n DeleteIfNotEqual when the Subtree is delete:\r\n TRUE : The tree is deleted when the stored value is not equal the parameter\r\n VersionNumber\r\n FALSE : The tree is deleted when the stored value is less the parameter\r\n VersionNumber\r\n WriteVersionNumber: This parameter determines if the Value of VersionNumber\r\n should be stored in the subtree after the check.\r\n VersionName is the Name of the stored version number in the path }\r\n procedure CheckDeletePathByVersion(const Path: string; VersionNumber: Integer;\r\n DeleteIfNotEqual: Boolean = False; WriteVersionNumber: Boolean = True;\r\n const VersionName: string = cVersionCheckName);\r\n class function ConcatPaths(const Paths: array of string): string;\r\n { Resolve a path to it's actual used storage backend and root path. }\r\n procedure ResolvePath(const InPath: string; out TargetStore: TJvCustomAppStorage; out TargetPath: string);\r\n { Determines if the path represents a folder }\r\n function IsFolder(const Path: string; ListIsValue: Boolean = True): Boolean;\r\n { Determines if the specified path exists }\r\n function PathExists(const Path: string): Boolean;\r\n { Determines if the specified value is stored }\r\n function ValueStored(const Path: string): Boolean;\r\n { Determines if the specified list is stored }\r\n function ListStored(const Path: string; const ItemName: string = cItem): Boolean;\r\n { Deletes the specified value. If the value wasn't stored, nothing will happen. }\r\n procedure DeleteValue(const Path: string);\r\n { Deletes all values and sub folders of the specified folder including the folder itself. }\r\n procedure DeleteSubTree(const Path: string);\r\n { Retrieves the specified Integer value. If the value is not found, the Default will be\r\n returned. If the value is not an Integer (or can't be converted to an Integer an EConvertError\r\n exception will be raised. }\r\n function ReadInteger(const Path: string; Default: Integer = 0): Integer;\r\n { Stores an Integer value. }\r\n procedure WriteInteger(const Path: string; Value: Integer);\r\n { Retrieves the specified Extended value. If the value is not found, the Default will be\r\n returned. If the value is not an Extended (or can't be converted to an Extended an\r\n EConvertError exception will be raised.}\r\n function ReadFloat(const Path: string; Default: Extended = 0): Extended;\r\n { Stores an Extended value. }\r\n procedure WriteFloat(const Path: string; Value: Extended);\r\n { Retrieves the specified string value. If the value is not found, the Default will be\r\n returned. If the value is not a string (or can't be converted to a string an EConvertError\r\n exception will be raised. }\r\n function ReadString(const Path: string; const Default: string = ''): string;\r\n { Stores an string value. }\r\n procedure WriteString(const Path: string; const Value: string);\r\n { Retrieves the specified TDateTime value. If the value is not found, the Default will be\r\n returned. If the value is not a TDateTime (or can't be converted to an TDateTime an\r\n EConvertError exception will be raised. }\r\n function ReadDateTime(const Path: string; Default: TDateTime = 0): TDateTime;\r\n { Stores a TDateTime value. }\r\n procedure WriteDateTime(const Path: string; Value: TDateTime);\r\n { Retrieves the specified value into a buffer. The result holds the number of bytes actually\r\n retrieved. }\r\n function ReadBinary(const Path: string; Buf: TJvBytes; BufSize: Integer): Integer;\r\n { Stores a buffer. }\r\n procedure WriteBinary(const Path: string; const Buf: TJvBytes; BufSize: Integer);\r\n { Retrieves the specified list. Caller provides a callback method that will read the individual\r\n items. ReadList will first determine the number of items to read and calls the specified\r\n method for each item. }\r\n function ReadList(const Path: string;\r\n const List: TObject; const OnReadItem: TJvAppStorageListItemEvent;\r\n const ItemName: string = cItem): Integer;\r\n { Stores a list of items. The number of items is stored first. For each item the provided\r\n item write method is called. Any additional items in the list (from a previous write) will be\r\n removed by the optionally provided delete method. }\r\n procedure WriteList(const Path: string; const List: TObject; const ItemCount: Integer;\r\n const OnWriteItem: TJvAppStorageListItemEvent;\r\n const OnDeleteItems: TJvAppStorageListDeleteEvent = nil;\r\n const ItemName: string = cItem);\r\n\r\n { Retrieves a list of objects. The list is optionally cleared before before reading starts.\r\n The ObjectType of the Object is retrieved from the stored \"Classname\" value.\r\n The result value is the number of items read. Uses ReadList with internally provided methods to\r\n do the actual reading. }\r\n function ReadObjectList(const Path: string; List: TList;\r\n const ClearFirst: Boolean = True; const ItemName: string = cItem): Integer; overload;\r\n { Retrieves a list of objects. The list is optionally cleared before before reading starts.\r\n The ObjectType of the Object is defined by the ItemCreator-Event.\r\n The result value is the number of items read. Uses ReadList with internally provided methods to\r\n do the actual reading. }\r\n function ReadObjectList(const Path: string; List: TList;\r\n ItemCreator: TJvAppStorageObjectListItemCreateEvent;\r\n const ClearFirst: Boolean = True; const ItemName: string = cItem): Integer; overload;\r\n { Stores a list of objects. Uses WriteList with internally provided methods to do the actual\r\n storing. }\r\n procedure WriteObjectList(const Path: string; List: TList; const ItemName: string = cItem);\r\n\r\n { Retrieves a list of collection items . The list is optionally cleared before before reading starts.\r\n The result value is the number of items read. Uses ReadList with internally provided methods to\r\n do the actual reading. }\r\n function ReadCollection(const Path: string; List: TCollection;\r\n const ClearFirst: Boolean = True; const ItemName: string = cItem): Integer;\r\n { Stores all items of a collection. Uses WriteList with internally provided methods to do the actual\r\n storing. }\r\n procedure WriteCollection(const Path: string; List: TCollection; const ItemName: string = cItem);\r\n\r\n { Retrieves a string list with addition objects.\r\n The ObjectType of the Object is retrieved from the stored \"Classname\" value.\r\n The string list is optionally cleared before reading starts. The\r\n result value is the number of items read. Uses ReadList with internally provided methods to\r\n do the actual reading. }\r\n function ReadStringObjectList(const Path: string; const SL: TStrings;\r\n const ClearFirst: Boolean = True;\r\n const ItemName: string = cItem): Integer; overload;\r\n { Retrieves a string list with addition objects.\r\n The ObjectType of the Object is defined by the ItemCreator-Event.\r\n The string list is optionally cleared before reading starts. The\r\n result value is the number of items read. Uses ReadList with internally provided methods to\r\n do the actual reading. }\r\n function ReadStringObjectList(const Path: string; const SL: TStrings;\r\n ItemCreator: TJvAppStorageObjectListItemCreateEvent;\r\n const ClearFirst: Boolean = True;\r\n const ItemName: string = cItem): Integer; overload;\r\n\r\n { Stores and also the attached object informations of a string list.\r\n Uses WriteList with internally provided methods to do the actual\r\n storing. }\r\n procedure WriteStringObjectList(const Path: string; const SL: TStrings; const ItemName: string = cItem);\r\n { Retrieves a string list. The string list is optionally cleared before reading starts. The\r\n result value is the number of items read. Uses ReadList with internally provided methods to\r\n do the actual reading. }\r\n function ReadStringList(const Path: string; const SL: TStrings;\r\n const ClearFirst: Boolean = True; const ItemName: string = cItem): Integer;\r\n { Stores a string list. Uses WriteList with internally provided methods to do the actual\r\n storing. }\r\n procedure WriteStringList(const Path: string; const SL: TStrings; const ItemName: string = cItem);\r\n {$IFDEF COMPILER10_UP}\r\n { Retrieves a wide string list. The string list is optionally cleared before reading starts. The\r\n result value is the number of items read. Uses ReadList with internally provided methods to\r\n do the actual reading. }\r\n function ReadWideStringList(const Path: string; const SL: TWideStrings;\r\n const ClearFirst: Boolean = True; const ItemName: string = cItem): Integer;\r\n { Stores a WideString list. Uses WriteList with internally provided methods to do the actual\r\n storing. }\r\n procedure WriteWideStringList(const Path: string; const SL: TWideStrings; const ItemName: string = cItem);\r\n {$ENDIF}\r\n { Retrieves an enumeration. If the value is not found, the Default will be returned. }\r\n procedure ReadEnumeration(const Path: string; TypeInfo: PTypeInfo; const Default; out Value);\r\n { Stores an enumeration }\r\n procedure WriteEnumeration(const Path: string; TypeInfo: PTypeInfo;\r\n const Value);\r\n procedure ReadSet(const Path: string; ATypeInfo: PTypeInfo; const Default; out Value);\r\n { Stores a set. }\r\n procedure WriteSet(const Path: string; ATypeInfo: PTypeInfo; const Value);\r\n { Retrieves the specified Boolean value. If the value is not found, the Default will be\r\n returned. If the value is not an Boolean (or can't be converted to a Boolean an EConvertError\r\n exception will be raised. }\r\n function ReadBoolean(const Path: string; Default: Boolean = True): Boolean;\r\n { Stores an Boolean value\r\n The value is stored as string TRUE/FALSE. }\r\n procedure WriteBoolean(const Path: string; Value: Boolean);\r\n { Retrieves an Property. If the value is not found, the Property is not changed. }\r\n procedure ReadProperty(const Path: string; const PersObj: TPersistent; const PropName: string; const Recursive, ClearFirst:\r\n Boolean; const IgnoreProperties: TStrings = nil);\r\n { Stores an Property }\r\n procedure WriteProperty(const Path: string; const PersObj: TPersistent; const PropName: string; const Recursive: Boolean; const\r\n IgnoreProperties: TStrings = nil);\r\n { Retrieves a set. If the value is not found, the Default will be returned. }\r\n { Retrieves a TPersistent-Object with all of its published properties }\r\n procedure ReadPersistent(const Path: string; const PersObj: TPersistent;\r\n const Recursive: Boolean = True; const ClearFirst: Boolean = True; const IgnoreProperties: TStrings = nil);\r\n { Stores a TPersistent-Object with all of its published properties}\r\n procedure WritePersistent(const Path: string; const PersObj: TPersistent; const Recursive: Boolean = True; const\r\n IgnoreProperties: TStrings = nil);\r\n\r\n { Translates a Char value to a (valid) key name. Used by the set storage methods. }\r\n function GetCharName(Ch: Char): string; virtual;\r\n { Translates an Integer value to a key name. Used by the set storage methods. }\r\n function GetIntName(Value: Integer): string; virtual;\r\n { Translates between a property name and it's storage name. If Reading is True, AName is\r\n interpreted as a storage name to be translated to a real property name. If Reading is False,\r\n AName is interpreted as a property name to be translated to a storage name. Will invoke the\r\n OnTranslatePropertyName event if one is assigned, or return AName if no handler is assigned. }\r\n function TranslatePropertyName(Instance: TPersistent; const AName: string; const Reading: Boolean): string;\r\n { Enumerate a list of stored values and/or folder below the specified path, optionally scanning\r\n sub folders as well. The associated object is an integer specifying what the string\r\n represents: 1: Folder; 2: Value; 3: Both }\r\n procedure GetStoredValues(const Path: string; const Strings: TStrings;\r\n const Options: TJvAppStorageEnumOptions = [aeoValues, aeoReportListAsValue, aeoRecursive]);\r\n { Enables the Cryption of Property-Values (Only String-Values) }\r\n procedure EnablePropertyValueCrypt;\r\n { Disables the Cryption of Property-Values (Only String-Values) }\r\n procedure DisablePropertyValueCrypt;\r\n { Returns the current state if Property-Value Cryption is enabled }\r\n function IsPropertyValueCryptEnabled: Boolean;\r\n function ItemNameIndexPath(const ItemName: string; const Index: Integer): string; virtual;\r\n function ReadWideString(const Path: string; const Default: WideString = ''): WideString;\r\n procedure WriteWideString(const Path: string; const Value: WideString);\r\n //1 The current Translateengine which should be used for all operations. It's the internal translateengine, or the assigned property TranslateStringEngine\r\n property ActiveTranslateStringEngine: TJvTranslateString read GetActiveTranslateStringEngine;\r\n { Root of any values to be read/written. This value is combined with the path given in one of\r\n the Read*/Write* methods to determine the actual key used. It's always relative to the value\r\n of Root (which is an absolute path) }\r\n property Path: string read GetPath write SetPath;\r\n { Defines if the Storage-Component is readonly or not.\r\n If Readonly is true all Calls to an Write*-Procedure will be ignored.\r\n The property is calulated by a combination of setting the\r\n property ReadOnly and Result of the function GetPhysicalReadOnly }\r\n property ReadOnly: Boolean read GetReadOnly write SetReadOnly default False;\r\n { If True, the destructor will call Flush as its first instruction.\r\n This property was added following Mantis 3168 and is True by default\r\n to keep backward compatibility }\r\n property FlushOnDestroy: Boolean read FFlushOnDestroy write SetFlushOnDestroy default True;\r\n published\r\n property StorageOptions: TJvCustomAppStorageOptions read FStorageOptions write SetStorageOptions;\r\n //1 This engine gives you the possibility to translate Strings with %-Replacements\r\n property TranslateStringEngine: TJvTranslateString read FTranslateStringEngine write SetTranslateStringEngine;\r\n property OnTranslatePropertyName: TJvAppStoragePropTranslateEvent read FOnTranslatePropertyName write FOnTranslatePropertyName;\r\n property OnEncryptPropertyValue: TJvAppStorageCryptEvent read FOnEncryptPropertyValue write FOnEncryptPropertyValue;\r\n property OnDecryptPropertyValue: TJvAppStorageCryptEvent read FOnDecryptPropertyValue write FOnDecryptPropertyValue;\r\n\r\n // called when an error occured in one of the methods.\r\n property OnError: TJvAppStorageErrorEvent read FOnError write FOnError;\r\n end;\r\n\r\n { Generic store that can only be used to combine various other storages (only storages in the\r\n SubStorages collection are usable; any references to paths not specified in this collection\r\n will raise an exception). Can be used for example to provide access to the entire registry\r\n hive from a single app store component by adding a number of TJvAppRegistryStorage storages,\r\n each referencing a specific root key and link them to a suitable root key path:\r\n\r\n RootPath Store\r\n ======== =====\r\n HKCR asRegStoreHKCR\r\n HKEY_CLASSES_ROOT asRegStoreHKCR\r\n HKCU asRegStoreHKCU\r\n HKEY_CURRENT_USER asRegStoreHKCU\r\n HKLM asRegStoreHKLM\r\n HKEY_LOCAL_MACHINE asRegStoreHKLM\r\n\r\n In the above scheme, both 'HKCU\\' as well as 'HKEY_CURRENT_USER'' will link to\r\n asRegStoreHKCU, ie. HKCU and HKEY_CURRENT_USER are aliases of each other. }\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64 or pidOSX32)]\r\n {$ENDIF RTL230_UP}\r\n TJvAppStorage = class(TJvCustomAppStorage)\r\n protected\r\n function IsFolderInt(const Path: string; ListIsValue: Boolean = True): Boolean; override;\r\n function PathExistsInt(const Path: string): Boolean; override;\r\n function ValueStoredInt(const Path: string): Boolean; override;\r\n procedure DeleteValueInt(const Path: string); override;\r\n procedure DeleteSubTreeInt(const Path: string); override;\r\n function ReadIntegerInt(const Path: string; Default: Integer = 0): Integer; override;\r\n procedure WriteIntegerInt(const Path: string; Value: Integer); override;\r\n function ReadFloatInt(const Path: string; Default: Extended = 0): Extended; override;\r\n procedure WriteFloatInt(const Path: string; Value: Extended); override;\r\n function ReadStringInt(const Path: string; const Default: string = ''): string; override;\r\n procedure WriteStringInt(const Path: string; const Value: string); override;\r\n function ReadBinaryInt(const Path: string; Buf: TJvBytes; BufSize: Integer): Integer; override;\r\n procedure WriteBinaryInt(const Path: string; const Buf: TJvBytes; BufSize: Integer); override;\r\n function ReadDateTimeInt(const Path: string; Default: TDateTime): TDateTime; override;\r\n procedure WriteDateTimeInt(const Path: string; Value: TDateTime); override;\r\n function ReadBooleanInt(const Path: string; Default: Boolean): Boolean; override;\r\n procedure WriteBooleanInt(const Path: string; Value: Boolean); override;\r\n procedure ReadEnumerationInt(const Path: string; TypeInfo: PTypeInfo; const Default; out Value); override;\r\n procedure WriteEnumerationInt(const Path: string; TypeInfo: PTypeInfo; const Value); override;\r\n procedure ReadSetInt(const Path: string; ATypeInfo: PTypeInfo; const Default; out Value); override;\r\n procedure WriteSetInt(const Path: string; ATypeInfo: PTypeInfo; const Value); override;\r\n property ReadOnly;\r\n published\r\n property FlushOnDestroy;\r\n property SubStorages;\r\n end;\r\n\r\n TJvCustomAppStorageOptions = class(TPersistent)\r\n private\r\n FBooleanAsString: Boolean;\r\n FBooleanStringTrueValues: string;\r\n FBooleanStringFalseValues: string;\r\n FEnumAsStr: Boolean;\r\n FIntAsStr: Boolean;\r\n FSetAsStr: Boolean;\r\n FDateTimeAsString: Boolean;\r\n FFloatAsString: Boolean;\r\n FDefaultIfReadConvertError: Boolean;\r\n FDefaultIfValueNotExists: Boolean;\r\n FStoreDefaultValues: Boolean;\r\n FStoreStringListAsSingleString: Boolean;\r\n FUseOldItemNameFormat: Boolean;\r\n FUseTranslateStringEngineDateTimeFormats: Boolean;\r\n protected\r\n procedure SetBooleanAsString(Value: Boolean); virtual;\r\n procedure SetBooleanStringTrueValues(Value: string); virtual;\r\n procedure SetBooleanStringFalseValues(Value: string); virtual;\r\n procedure SetEnumAsStr(Value: Boolean); virtual;\r\n procedure SetIntAsStr(Value: Boolean); virtual;\r\n procedure SetSetAsStr(Value: Boolean); virtual;\r\n procedure SetDateTimeAsStr(Value: Boolean); virtual;\r\n procedure SetFloatAsStr(Value: Boolean); virtual;\r\n procedure SetDefaultIfReadConvertError(Value: Boolean); virtual;\r\n procedure SetDefaultIfValueNotExists(Value: Boolean); virtual;\r\n function IsValueListString(const AValue, AList: string): Boolean; virtual;\r\n procedure SetStoreStringListAsSingleString(const Value: Boolean); virtual;\r\n procedure SetUseOldItemNameFormat(const Value: Boolean); virtual;\r\n procedure SetStoreDefaultValues(const Value: Boolean); virtual;\r\n //Flag to determine if a stringlist should be stored as single string and not as list of string items\r\n property StoreStringListAsSingleString: Boolean read FStoreStringListAsSingleString write\r\n SetStoreStringListAsSingleString default False;\r\n public\r\n constructor Create; virtual;\r\n procedure Assign(Source: TPersistent); override;\r\n function DefaultTrueString: string;\r\n function DefaultFalseString: string;\r\n function IsValueTrueString(Value: string): Boolean;\r\n function IsValueFalseString(Value: string): Boolean;\r\n\r\n property BooleanStringTrueValues: string read FBooleanStringTrueValues write SetBooleanStringTrueValues;\r\n property BooleanStringFalseValues: string read FBooleanStringFalseValues write SetBooleanStringFalseValues;\r\n property BooleanAsString: Boolean read FBooleanAsString write SetBooleanAsString default True;\r\n property EnumerationAsString: Boolean read FEnumAsStr write SetEnumAsStr default True;\r\n property TypedIntegerAsString: Boolean read FIntAsStr write SetIntAsStr default True;\r\n property SetAsString: Boolean read FSetAsStr write SetSetAsStr default False;\r\n property DateTimeAsString: Boolean read FDateTimeAsString write SetDateTimeAsStr default True;\r\n property FloatAsString: Boolean read FFloatAsString write SetFloatAsStr default False;\r\n property DefaultIfReadConvertError: Boolean read FDefaultIfReadConvertError write SetDefaultIfReadConvertError default False;\r\n property DefaultIfValueNotExists: Boolean read FDefaultIfValueNotExists write SetDefaultIfValueNotExists default True;\r\n property StoreDefaultValues: Boolean read FStoreDefaultValues write SetStoreDefaultValues default True;\r\n //1 Property to define the format of list entries, the new format is [], the old format is .\r\n /// Property to define the format of list entries, the new format is [],\r\n /// the old format is .\r\n /// The advantage of the new format for xml-appstorage is that the brackets will be\r\n /// removed.\r\n property UseOldItemNameFormat: Boolean read FUseOldItemNameFormat write SetUseOldItemNameFormat default True;\r\n //1 Property to define that the TranslateEngine DateFormat and TimeFormat Property Values will be used to read/write DateTime values\r\n property UseTranslateStringEngineDateTimeFormats: Boolean read\r\n FUseTranslateStringEngineDateTimeFormats write\r\n FUseTranslateStringEngineDateTimeFormats default False;\r\n end;\r\n\r\n TJvAppStorageOptions = class(TJvCustomAppStorageOptions)\r\n published\r\n property BooleanStringTrueValues;\r\n property BooleanStringFalseValues;\r\n property BooleanAsString;\r\n property EnumerationAsString;\r\n property TypedIntegerAsString;\r\n property SetAsString;\r\n property DateTimeAsString;\r\n property FloatAsString;\r\n property DefaultIfReadConvertError;\r\n property DefaultIfValueNotExists;\r\n property StoreDefaultValues;\r\n property UseOldItemNameFormat;\r\n property UseTranslateStringEngineDateTimeFormats;\r\n end;\r\n\r\n TJvAppSubStorages = class(TOwnedCollection)\r\n private\r\n function GetRootStorage: TJvCustomAppStorage;\r\n function GetItem(I: Integer): TJvAppSubStorage;\r\n procedure SetItem(I: Integer; Value: TJvAppSubStorage);\r\n protected\r\n { Notify sub storages of a change in the options of the root storage. This allows sub storage\r\n to be kept in sync with the root storage. }\r\n procedure RootOptionsChanged;\r\n { Check if the given root path is unique, optionally ignoring a specific sub storage (eg. when\r\n modifying the root path of a storage, that storage's RootPath is irrelavant in determining\r\n if the new name will be unique). }\r\n function CheckUniqueBase(const APath: string; IgnoreIndex: Integer): Boolean;\r\n { Retrieves the sub storage for the given root path, optionally ignoring a specific sub storage.\r\n The specified path is assumed to be at root level (regardless whether the paths starts with\r\n a backslash (\\) or not) and leading and trailing backslashes are removed automatically.\r\n The last element in the path string is ignored to avoid returning a sub storage for the root\r\n path itself. To search for a sub store for a root path, simply add '\\*' at the end of the\r\n path. }\r\n function MatchFor(APath: string; IgnoreIndex: Integer = -1): TJvAppSubStorage;\r\n\r\n property RootStorage: TJvCustomAppStorage read GetRootStorage;\r\n public\r\n constructor Create(AOwner: TJvCustomAppStorage);\r\n procedure Add(RootPath: string; AppStorage: TJvCustomAppStorage);\r\n procedure Delete(Index: Integer); overload;\r\n procedure Delete(RootPath: string; const IncludeSubPaths: Boolean = False); overload;\r\n procedure Delete(AppStorage: TJvCustomAppStorage); overload;\r\n\r\n property Items[I: Integer]: TJvAppSubStorage read GetItem write SetItem; default;\r\n end;\r\n\r\n TJvAppSubStorage = class(TCollectionItem)\r\n private\r\n FRootPath: string;\r\n FAppStorage: TJvCustomAppStorage;\r\n protected\r\n function GetOwnerStore: TJvCustomAppStorage;\r\n function GetDisplayName: string; override;\r\n procedure SetRootPath(Value: string);\r\n procedure SetAppStorage(Value: TJvCustomAppStorage);\r\n\r\n property OwnerStore: TJvCustomAppStorage read GetOwnerStore;\r\n published\r\n property RootPath: string read FRootPath write SetRootPath;\r\n property AppStorage: TJvCustomAppStorage read FAppStorage write SetAppStorage;\r\n end;\r\n\r\n\r\n TJvAppFileStorageBackupType = (afsbtNone, afsbtCreateBefore, afsbtRenameAfter);\r\n TJvAppFileStorageBackupHistoryType = (afsbhtNone, afsbhtAllways, afsbht1Minute, afsbht15Minute, afsbht1Hour, afsbht4Hour,\r\n afsbht12Hour, afsbht1Day, afsbht3Day, afsbht1Week, afsbht1Month);\r\n\r\n TJvAppFileStorageOptions = class(TJvCustomAppStorageOptions)\r\n private\r\n FBackupHistoryCount: Integer;\r\n FBackupHistoryType: TJvAppFileStorageBackupHistoryType;\r\n FBackupType: TJvAppFileStorageBackupType;\r\n FBackupKeepFileAfterFlush: Boolean;\r\n public\r\n constructor Create; override;\r\n procedure Assign(Source: TPersistent); override;\r\n //1 Property to define the number of history files which should be preserved\r\n property BackupHistoryCount: Integer read FBackupHistoryCount write FBackupHistoryCount default 0;\r\n //1 Property to define how often a history file of the backup file should be created\r\n property BackupHistoryType: TJvAppFileStorageBackupHistoryType read FBackupHistoryType write FBackupHistoryType default\r\n afsbhtNone;\r\n //1 Property to define that the backup file should be preserved after the flush has been finished or not\r\n property BackupKeepFileAfterFlush: Boolean read FBackupKeepFileAfterFlush write FBackupKeepFileAfterFlush default false;\r\n /// Property to define if and how a backup file should be created.\r\n /// - None = No Backup\r\n /// - CreateBefore = Copy the old file as backup before writing the new file\r\n /// - AfterReplace = Write the new file into a tmp file and after writing rename\r\n /// the old file as backup and the new as save file\r\n property BackupType: TJvAppFileStorageBackupType read FBackupType write FBackupType default afsbtNone;\r\n end;\r\n\r\n // Base class for all in memory file storage classes.\r\n // All descendents implement a file storage, but all changes\r\n // are left in memory until the Flush method is called.\r\n // Flush is automatically called by the destructor, but\r\n // you can override Flush to write the file on a support\r\n // different from a disk, such as database record.\r\n // Please note that in the derived class, if you use an object\r\n // to represent the file in memory, this object MUST be freed\r\n // AFTER the call to inherited in the destructor of your\r\n // derived class or Flush would access a deleted object\r\n TJvCustomAppMemoryFileStorage = class(TJvCustomAppStorage)\r\n private\r\n FFullFileName: TFileName;\r\n function CalculateFullFileName: string;\r\n function GetStorageOptions: TJvAppFileStorageOptions;\r\n procedure SetFileNameInternal(const Value: TFileName);\r\n procedure SetStorageOptions(const Value: TJvAppFileStorageOptions);\r\n protected\r\n FFileName: TFileName;\r\n FLocation: TFileLocation;\r\n FOnGetFileName: TJvAppStorageGetFileNameEvent;\r\n FPhysicalReadOnly: Boolean;\r\n FFileLoaded: Boolean;\r\n {$IFDEF DELPHI2005_UP}\r\n FFileAge: TDateTime;\r\n {$ELSE}\r\n FFileAge: Integer;\r\n {$ENDIF}\r\n\r\n function GetAsString: string; virtual; abstract;\r\n procedure SetAsString(const Value: string); virtual; abstract;\r\n\r\n procedure SetFileName(const Value: TFileName);\r\n procedure SetOnGetFileName(Value: TJvAppStorageGetFileNameEvent);\r\n procedure SetLocation(const Value: TFileLocation);\r\n function DefaultExtension: string; virtual;\r\n\r\n function DoGetFileName: TFileName; virtual;\r\n property AsString: string read GetAsString write SetAsString;\r\n\r\n // OnGetFileName triggered on Location = flCustom\r\n property OnGetFileName: TJvAppStorageGetFileNameEvent read FOnGetFileName write SetOnGetFileName;\r\n\r\n function GetPhysicalReadOnly: Boolean; override;\r\n procedure RecalculateFullFileName;\r\n\r\n procedure ClearInternal; virtual; abstract;\r\n procedure FlushInternal; virtual; abstract;\r\n procedure FlushToFile;\r\n { Retrieve the class that holds the storage options and format settings. }\r\n class function GetStorageOptionsClass: TJvAppStorageOptionsClass; override;\r\n procedure ReloadInternal; virtual; abstract;\r\n\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n procedure Flush; override;\r\n\r\n procedure Reload; override;\r\n function ReloadNeeded: Boolean; override;\r\n\r\n property FileName: TFileName read FFileName write SetFileName;\r\n property FullFileName: TFileName read FFullFileName;\r\n property Location: TFileLocation read FLocation write SetLocation default flExeFile;\r\n published\r\n property ReadOnly;\r\n property StorageOptions: TJvAppFileStorageOptions read GetStorageOptions write SetStorageOptions;\r\n end;\r\n\r\n { This Engine implements the possibility to implement special property handlers\r\n for TObject-based properties for storing/restoring them with the\r\n functions read/writeproperty.\r\n New engines could be registered using the method RegisterAppStoragePropertyEngine\r\n }\r\n TJvAppStoragePropertyBaseEngine = class(TObject)\r\n public\r\n constructor Create; virtual;\r\n function Supports(AObject: TObject; AProperty: TObject): Boolean; virtual;\r\n procedure ReadProperty(AStorage: TJvCustomAppStorage; const APath: string; AObject: TObject; AProperty: TObject; const Recursive,\r\n ClearFirst: Boolean; const IgnoreProperties: TStrings = nil); virtual;\r\n procedure WriteProperty(AStorage: TJvCustomAppStorage; const APath: string; AObject: TObject; AProperty: TObject; const\r\n Recursive: Boolean; const IgnoreProperties: TStrings = nil); virtual;\r\n end;\r\n\r\n TJvAppStoragePropertyBaseEngineClass = class of TJvAppStoragePropertyBaseEngine;\r\n\r\nprocedure RegisterAppStoragePropertyEngine(AEngineClass: TJvAppStoragePropertyBaseEngineClass);\r\nprocedure UnregisterAppStoragePropertyEngine(AEngineClass: TJvAppStoragePropertyBaseEngineClass);\r\n\r\n// (marcelb) moved back; the constants are useful to the outside world after a call to GetStoredValues\r\n// (rom) give it better names and delete these comments :-)\r\nconst\r\n aptFolder = 1;\r\n aptValue = 2;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvAppStorage.pas $';\r\n Revision: '$Revision: 13415 $';\r\n Date: '$Date: 2012-09-10 11:51:54 +0200 (lun. 10 sept. 2012) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n StrUtils,\r\n JclFileUtils, JclSysInfo, JclRTTI, JclMime,\r\n JvPropertyStore, JvConsts, JvResources, JvStrings, JclSynch, JvJVCLUtils;\r\n\r\ntype\r\n TJvAppStoragePropertyEngineList = class(TList)\r\n public\r\n destructor Destroy; override;\r\n procedure RegisterEngine(AEngineClass: TJvAppStoragePropertyBaseEngineClass);\r\n procedure UnregisterEngine(AEngineClass: TJvAppStoragePropertyBaseEngineClass);\r\n function GetEngine(AObject: TObject; AProperty: TObject): TJvAppStoragePropertyBaseEngine;\r\n function ReadProperty(AStorage: TJvCustomAppStorage; const APath: string; AObject: TObject; AProperty: TObject; const Recursive,\r\n ClearFirst: Boolean; const IgnoreProperties: TStrings = nil): Boolean;\r\n function WriteProperty(AStorage: TJvCustomAppStorage; const APath: string; AObject: TObject; AProperty: TObject; const Recursive:\r\n Boolean; const IgnoreProperties: TStrings = nil): Boolean;\r\n end;\r\n\r\nvar\r\n GlobalRegisteredAppStoragePropertyEngineList: TJvAppStoragePropertyEngineList;\r\n GlobalRegisteredAppStoragePropertyEngineListDestroyed: Boolean;\r\n\r\nfunction RegisteredAppStoragePropertyEngineList: TJvAppStoragePropertyEngineList;\r\nbegin\r\n if (GlobalRegisteredAppStoragePropertyEngineList = nil) and\r\n not GlobalRegisteredAppStoragePropertyEngineListDestroyed then\r\n GlobalRegisteredAppStoragePropertyEngineList := TJvAppStoragePropertyEngineList.Create;\r\n Result := GlobalRegisteredAppStoragePropertyEngineList;\r\nend;\r\n\r\n//=== Global Engine Handling =================================================\r\n\r\nprocedure RegisterAppStoragePropertyEngine(AEngineClass: TJvAppStoragePropertyBaseEngineClass);\r\nbegin\r\n if RegisteredAppStoragePropertyEngineList <> nil then\r\n RegisteredAppStoragePropertyEngineList.RegisterEngine(AEngineClass);\r\nend;\r\n\r\nprocedure UnregisterAppStoragePropertyEngine(AEngineClass: TJvAppStoragePropertyBaseEngineClass);\r\nbegin\r\n if RegisteredAppStoragePropertyEngineList <> nil then\r\n RegisteredAppStoragePropertyEngineList.UnregisterEngine(AEngineClass);\r\nend;\r\n\r\nprocedure DestroyAppStoragePropertyEngineList;\r\nbegin\r\n GlobalRegisteredAppStoragePropertyEngineListDestroyed := True;\r\n GlobalRegisteredAppStoragePropertyEngineList.Free;\r\n GlobalRegisteredAppStoragePropertyEngineList := nil;\r\nend;\r\n\r\nconst\r\n // (rom) this name is shared in several units and should be made global\r\n cCount = 'Count';\r\n cObject = 'Object';\r\n cItemName = 'Itemname';\r\n cClassName = 'Classname';\r\n cInvalidIdentifier = ' #!@not known@!# ';\r\n // (rom) should this be PathDelim + '*' as implemented before i changed it\r\n // (rom) or \\* as comments say?\r\n cSubStorePath = PathDelim + '*';\r\n\r\nfunction OptimizePaths(const Paths: array of string): string;\r\nvar\r\n PathIndex: Integer;\r\n Head, Tail, ResultIndex: Integer;\r\n AllDots: Boolean;\r\n MaxLength: Integer;\r\n I: Integer;\r\n DotCount: Integer;\r\n L: Integer;\r\nbegin\r\n PathIndex := High(Paths);\r\n\r\n if PathIndex < 0 then\r\n begin\r\n Result := '';\r\n Exit;\r\n end;\r\n\r\n while (PathIndex > 0) and (StrLeft(Paths[PathIndex], 1) <> PathDelim) do\r\n Dec(PathIndex);\r\n\r\n MaxLength := 0;\r\n for I := PathIndex to High(Paths) do\r\n Inc(MaxLength, Length(Paths[I]) + 1);\r\n\r\n SetLength(Result, MaxLength);\r\n\r\n ResultIndex := 1;\r\n\r\n repeat\r\n Head := 1;\r\n // L is only used for optimalization\r\n L := Length(Paths[PathIndex]);\r\n repeat\r\n // skip first path delimiters\r\n while (Head <= L) and (Paths[PathIndex][Head] = PathDelim) do\r\n Inc(Head);\r\n Tail := Head;\r\n // search for a path delimiter\r\n AllDots := True;\r\n while (Head <= L) and (Paths[PathIndex][Head] <> PathDelim) do\r\n begin\r\n AllDots := AllDots and (Paths[PathIndex][Head] = '.');\r\n Inc(Head);\r\n end;\r\n // Chunk [Tail..Head) is without a path delimiter, it can be either empty (Head=Tail)\r\n // be full with dots or be a regular path.\r\n if Head <> Tail then\r\n begin\r\n if AllDots then\r\n begin\r\n // [Tail..Head) are all dots\r\n DotCount := Head - Tail;\r\n if (DotCount > 1) and (ResultIndex > 1) then\r\n begin\r\n // Go back to the previous path delimiter; Current path delimiter is\r\n // at Result[ResultIndex - 1]\r\n Dec(ResultIndex, 2);\r\n while DotCount > 1 do\r\n begin\r\n while (ResultIndex > 1) and (Result[ResultIndex] <> PathDelim) do\r\n Dec(ResultIndex);\r\n if ResultIndex = 1 then\r\n Break;\r\n // Result[ResultIndex] = PathDelim\r\n Dec(ResultIndex);\r\n Dec(DotCount);\r\n end;\r\n if ResultIndex > 1 then\r\n Inc(ResultIndex, 2);\r\n end;\r\n end\r\n else\r\n begin\r\n // copy [Tail..Head) to Result..\r\n MoveChar(Paths[PathIndex], Tail - 1, Result, ResultIndex - 1, Head - Tail); // from JclBase.pas\r\n Inc(ResultIndex, Head - Tail);\r\n // ..and add a path delimiter to Result\r\n Result[ResultIndex] := PathDelim;\r\n Inc(ResultIndex);\r\n end;\r\n end;\r\n until Head > L;\r\n Inc(PathIndex);\r\n until PathIndex > High(Paths);\r\n\r\n // skip the last added delimiter (if it exists)\r\n if ResultIndex > 1 then\r\n Dec(ResultIndex);\r\n\r\n SetLength(Result, ResultIndex - 1);\r\nend;\r\n\r\nprocedure CopyEnumValue(const Source; var Target; const Kind: TOrdType);\r\nbegin\r\n case Kind of\r\n otSByte, otUByte:\r\n Byte(Target) := Byte(Source);\r\n otSWord, otUWord:\r\n Word(Target) := Word(Source);\r\n otSLong, otULong:\r\n Longword(Target) := Longword(Source);\r\n end;\r\nend;\r\n\r\nfunction OrdOfEnum(const Value; OrdType: TOrdType): Integer;\r\nbegin\r\n case OrdType of\r\n otSByte:\r\n Result := Shortint(Value);\r\n otUByte:\r\n Result := Byte(Value);\r\n otSWord:\r\n Result := Smallint(Value);\r\n otUWord:\r\n Result := Word(Value);\r\n otSLong, otULong:\r\n Result := Longint(Value);\r\n else\r\n Result := -1;\r\n end;\r\nend;\r\n\r\n//=== { TJvCustomAppStorageOptions } =========================================\r\n\r\nconstructor TJvCustomAppStorageOptions.Create;\r\nbegin\r\n inherited Create;\r\n BooleanStringTrueValues := 'TRUE, YES, Y';\r\n BooleanStringFalseValues := 'FALSE, NO, N';\r\n BooleanAsString := True;\r\n EnumerationAsString := True;\r\n TypedIntegerAsString := True;\r\n SetAsString := False;\r\n DateTimeAsString := True;\r\n DefaultIfReadConvertError := False;\r\n DefaultIfValueNotExists := True;\r\n StoreDefaultValues := True;\r\n StoreStringListAsSingleString := False;\r\n UseOldItemNameFormat := True;\r\n FUseTranslateStringEngineDateTimeFormats := False;\r\nend;\r\n\r\nprocedure TJvCustomAppStorageOptions.Assign(Source: TPersistent);\r\nbegin\r\n if (Source = Self) then\r\n Exit;\r\n if Source is TJvCustomAppStorageOptions then\r\n begin\r\n BooleanStringTrueValues := TJvCustomAppStorageOptions(Source).BooleanStringTrueValues;\r\n BooleanStringFalseValues := TJvCustomAppStorageOptions(Source).BooleanStringFalseValues;\r\n BooleanAsString := TJvCustomAppStorageOptions(Source).BooleanAsString;\r\n EnumerationAsString := TJvCustomAppStorageOptions(Source).EnumerationAsString;\r\n TypedIntegerAsString := TJvCustomAppStorageOptions(Source).TypedIntegerAsString;\r\n SetAsString := TJvCustomAppStorageOptions(Source).SetAsString;\r\n DateTimeAsString := TJvCustomAppStorageOptions(Source).DateTimeAsString;\r\n DefaultIfReadConvertError := TJvCustomAppStorageOptions(Source).DefaultIfReadConvertError;\r\n DefaultIfValueNotExists := TJvCustomAppStorageOptions(Source).DefaultIfValueNotExists;\r\n StoreDefaultValues := TJvCustomAppStorageOptions(Source).StoreDefaultValues;\r\n StoreStringListAsSingleString := TJvCustomAppStorageOptions(Source).StoreStringListAsSingleString;\r\n UseOldItemNameFormat := TJvCustomAppStorageOptions(Source).UseOldItemNameFormat;\r\n UseTranslateStringEngineDateTimeFormats := TJvCustomAppStorageOptions(Source).UseTranslateStringEngineDateTimeFormats;\r\n end\r\n else\r\n inherited assign(Source);\r\nend;\r\n\r\nfunction TJvCustomAppStorageOptions.IsValueListString(const AValue, AList: string): Boolean;\r\nvar\r\n st: TStringList;\r\nbegin\r\n st := TStringList.Create;\r\n try\r\n st.CommaText := UpperCase(AList);\r\n Result := st.IndexOf(UpperCase(AValue)) >= 0;\r\n finally\r\n st.Free;\r\n end;\r\nend;\r\n\r\nfunction TJvCustomAppStorageOptions.DefaultTrueString: string;\r\nvar\r\n I: Integer;\r\nbegin\r\n I := Pos(',', FBooleanStringTrueValues);\r\n if I = 0 then\r\n I := Length(FBooleanStringTrueValues) + 1;\r\n Result := Trim(Copy(FBooleanStringTrueValues, 1, I - 1));\r\nend;\r\n\r\nfunction TJvCustomAppStorageOptions.DefaultFalseString: string;\r\nvar\r\n I: Integer;\r\nbegin\r\n I := Pos(',', FBooleanStringFalseValues);\r\n if I = 0 then\r\n I := Length(FBooleanStringFalseValues) + 1;\r\n Result := Trim(Copy(FBooleanStringFalseValues, 1, I - 1));\r\nend;\r\n\r\nfunction TJvCustomAppStorageOptions.IsValueTrueString(Value: string): Boolean;\r\nbegin\r\n Result := IsValueListString(Value, FBooleanStringTrueValues);\r\nend;\r\n\r\nfunction TJvCustomAppStorageOptions.IsValueFalseString(Value: string): Boolean;\r\nbegin\r\n Result := IsValueListString(Value, FBooleanStringFalseValues);\r\nend;\r\n\r\nprocedure TJvCustomAppStorageOptions.SetBooleanAsString(Value: Boolean);\r\nbegin\r\n FBooleanAsString := Value and (DefaultTrueString <> '') and (DefaultFalseString <> '');\r\nend;\r\n\r\nprocedure TJvCustomAppStorageOptions.SetBooleanStringTrueValues(Value: string);\r\nbegin\r\n FBooleanStringTrueValues := Value;\r\n FBooleanAsString := FBooleanAsString and (DefaultTrueString <> '')\r\nend;\r\n\r\nprocedure TJvCustomAppStorageOptions.SetBooleanStringFalseValues(Value: string);\r\nbegin\r\n FBooleanStringFalseValues := Value;\r\n FBooleanAsString := FBooleanAsString and (DefaultFalseString <> '')\r\nend;\r\n\r\nprocedure TJvCustomAppStorageOptions.SetEnumAsStr(Value: Boolean);\r\nbegin\r\n FEnumAsStr := Value;\r\nend;\r\n\r\nprocedure TJvCustomAppStorageOptions.SetIntAsStr(Value: Boolean);\r\nbegin\r\n FIntAsStr := Value;\r\nend;\r\n\r\nprocedure TJvCustomAppStorageOptions.SetSetAsStr(Value: Boolean);\r\nbegin\r\n FSetAsStr := Value;\r\nend;\r\n\r\nprocedure TJvCustomAppStorageOptions.SetStoreDefaultValues(const Value: Boolean);\r\nbegin\r\n FStoreDefaultValues := Value;\r\nend;\r\n\r\nprocedure TJvCustomAppStorageOptions.SetDateTimeAsStr(Value: Boolean);\r\nbegin\r\n FDateTimeAsString := Value;\r\nend;\r\n\r\nprocedure TJvCustomAppStorageOptions.SetFloatAsStr(Value: Boolean);\r\nbegin\r\n FFloatAsString := Value;\r\nend;\r\n\r\nprocedure TJvCustomAppStorageOptions.SetDefaultIfReadConvertError(Value: Boolean);\r\nbegin\r\n FDefaultIfReadConvertError := Value;\r\nend;\r\n\r\nprocedure TJvCustomAppStorageOptions.SetDefaultIfValueNotExists(Value: Boolean);\r\nbegin\r\n FDefaultIfValueNotExists := Value;\r\nend;\r\n\r\nprocedure TJvCustomAppStorageOptions.SetStoreStringListAsSingleString(const Value: Boolean);\r\nbegin\r\n FStoreStringListAsSingleString := Value;\r\nend;\r\n\r\nprocedure TJvCustomAppStorageOptions.SetUseOldItemNameFormat(const Value: Boolean);\r\nbegin\r\n FUseOldItemNameFormat := Value;\r\nend;\r\n\r\n//=== { TJvCustomAppStorage } ================================================\r\n\r\n{$IFDEF SUPPORTS_CLASS_CTORDTORS}\r\nclass destructor TJvCustomAppStorage.Destroy;\r\nbegin\r\n DestroyAppStoragePropertyEngineList;\r\nend;\r\n{$ENDIF SUPPORTS_CLASS_CTORDTORS}\r\n\r\nconstructor TJvCustomAppStorage.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FFlushOnDestroy := True;\r\n FAutoFlush := False;\r\n FAutoReload := False;\r\n FStorageOptions := GetStorageOptionsClass.Create;\r\n FSubStorages := TJvAppSubStorages.Create(Self);\r\n FCryptEnabledStatus := 0;\r\n FReadOnly := False;\r\n FInternalTranslateStringEngine := TJvTranslateString.Create(Self);\r\n FSynchronizeFlushReload := False;\r\nend;\r\n\r\ndestructor TJvCustomAppStorage.Destroy;\r\nbegin\r\n if FlushOnDestroy then\r\n Flush;\r\n FreeAndNil(FInternalTranslateStringEngine);\r\n FreeAndNil(FSubStorages);\r\n FreeAndNil(FStorageOptions);\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvCustomAppStorage.Flush;\r\nbegin\r\n // do nothing\r\nend;\r\n\r\nprocedure TJvCustomAppStorage.Reload;\r\nbegin\r\n // do nothing\r\nend;\r\n\r\nprocedure TJvCustomAppStorage.ReloadIfNeeded;\r\nbegin\r\n if ReloadNeeded then\r\n Reload;\r\nend;\r\n\r\nfunction TJvCustomAppStorage.ReloadNeeded: Boolean;\r\nbegin\r\n Result := AutoReload and not IsUpdating;\r\nend;\r\n\r\nprocedure TJvCustomAppStorage.FlushIfNeeded;\r\nbegin\r\n if FlushNeeded then\r\n Flush;\r\nend;\r\n\r\nfunction TJvCustomAppStorage.FlushNeeded: Boolean;\r\nbegin\r\n Result := AutoFlush and not IsUpdating;\r\nend;\r\n\r\nprocedure TJvCustomAppStorage.Notification(AComponent: TComponent; Operation: TOperation);\r\nbegin\r\n inherited Notification(AComponent, Operation);\r\n if (Operation = opRemove) then\r\n if (AComponent is TJvCustomAppStorage) and Assigned(SubStorages) then\r\n SubStorages.Delete(AComponent as TJvCustomAppStorage)\r\n else if (AComponent = FTranslateStringEngine) then\r\n FTranslateStringEngine := nil;\r\nend;\r\n\r\nprocedure TJvCustomAppStorage.SetFlushOnDestroy(Value: Boolean);\r\nbegin\r\n FFlushOnDestroy := Value;\r\nend;\r\n\r\nfunction TJvCustomAppStorage.GetPropCount(Instance: TPersistent): Integer;\r\nvar\r\n Data: PTypeData;\r\nbegin\r\n Data := GetTypeData(Instance.ClassInfo);\r\n Result := Data.PropCount;\r\nend;\r\n\r\nfunction TJvCustomAppStorage.GetPropName(Instance: TPersistent; Index: Integer): string;\r\nvar\r\n PropList: PPropList;\r\n PropInfo: PPropInfo;\r\n Data: PTypeData;\r\nbegin\r\n Result := '';\r\n Data := GetTypeData(Instance.ClassInfo);\r\n GetMem(PropList, Data^.PropCount * SizeOf(PPropInfo));\r\n try\r\n GetPropInfos(Instance.ClassInfo, PropList);\r\n PropInfo := PropList^[Index];\r\n Result := {$IFDEF SUPPORTS_UNICODE}UTF8ToString{$ENDIF SUPPORTS_UNICODE}(PropInfo^.Name);\r\n finally\r\n FreeMem(PropList);\r\n end;\r\nend;\r\n\r\nclass function TJvCustomAppStorage.GetStorageOptionsClass: TJvAppStorageOptionsClass;\r\nbegin\r\n Result := TJvAppStorageOptions;\r\nend;\r\n\r\nprocedure TJvCustomAppStorage.SplitKeyPath(const Path: string; out Key, ValueName: string);\r\nvar\r\n AbsPath: string;\r\n ValueNamePos: Integer;\r\nbegin\r\n AbsPath := GetAbsPath(Path);\r\n ValueNamePos := LastDelimiter(PathDelim, AbsPath);\r\n Key := StrLeft(AbsPath, ValueNamePos - 1);\r\n ValueName := StrRestOf(AbsPath, ValueNamePos + 1);\r\nend;\r\n\r\nprocedure TJvCustomAppStorage.SetSubStorages(Value: TJvAppSubStorages);\r\nbegin\r\nend;\r\n\r\nfunction TJvCustomAppStorage.GetRoot: string;\r\nbegin\r\n Result := FRoot;\r\nend;\r\n\r\nprocedure TJvCustomAppStorage.SetRoot(const Value: string);\r\nbegin\r\n FRoot := OptimizePaths([Value]);\r\nend;\r\n\r\nfunction TJvCustomAppStorage.GetCurrentPath: string;\r\nbegin\r\n Result := GetAbsPath('');\r\nend;\r\n\r\nfunction TJvCustomAppStorage.GetAbsPath(const Path: string): string;\r\nbegin\r\n Result := GetRoot + PathDelim + OptimizePaths([GetPath, Path]);\r\n while (Result <> '') and (Result[1] = PathDelim) do\r\n Delete(Result, 1, 1);\r\nend;\r\n\r\nprocedure TJvCustomAppStorage.ReadStringListItem(Sender: TJvCustomAppStorage;\r\n const Path: string; const List: TObject; const Index: Integer; const ItemName: string);\r\nbegin\r\n if List is TStrings then\r\n TStrings(List).Add(Sender.ReadString(ConcatPaths([Path, ItemNameIndexPath (ItemName, Index)])));\r\nend;\r\n\r\nprocedure TJvCustomAppStorage.WriteStringListItem(Sender: TJvCustomAppStorage;\r\n const Path: string; const List: TObject; const Index: Integer; const ItemName: string);\r\nbegin\r\n if List is TStrings then\r\n Sender.WriteString(ConcatPaths([Path, ItemNameIndexPath (ItemName, Index)]), TStrings(List)[Index]);\r\nend;\r\n\r\nprocedure TJvCustomAppStorage.DeleteStringListItem(Sender: TJvCustomAppStorage;\r\n const Path: string; const List: TObject; const First, Last: Integer; const ItemName: string);\r\nvar\r\n I: Integer;\r\nbegin\r\n if List is TStrings then\r\n for I := First to Last do\r\n Sender.DeleteValue(ConcatPaths([Path, ItemName + IntToStr(I)]));\r\nend;\r\n\r\n{$IFDEF COMPILER10_UP}\r\nprocedure TJvCustomAppStorage.ReadWideStringListItem(Sender: TJvCustomAppStorage;\r\n const Path: string; const List: TObject; const Index: Integer; const ItemName: string);\r\nbegin\r\n if List is WideStrings.TWideStrings then\r\n WideStrings.TWideStrings(List).Add(Sender.ReadWideString(ConcatPaths([Path, ItemName + IntToStr(Index)])));\r\nend;\r\n\r\nprocedure TJvCustomAppStorage.WriteWideStringListItem(Sender: TJvCustomAppStorage;\r\n const Path: string; const List: TObject; const Index: Integer; const ItemName: string);\r\nbegin\r\n if List is WideStrings.TWideStrings then\r\n Sender.WriteWideString(ConcatPaths([Path, ItemName + IntToStr(Index)]), WideStrings.TWideStrings(List)[Index]);\r\nend;\r\n\r\nprocedure TJvCustomAppStorage.DeleteWideStringListItem(Sender: TJvCustomAppStorage;\r\n const Path: string; const List: TObject; const First, Last: Integer; const ItemName: string);\r\nvar\r\n I: Integer;\r\nbegin\r\n if List is WideStrings.TWideStrings then\r\n for I := First to Last do\r\n Sender.DeleteValue(ConcatPaths([Path, ItemName + IntToStr(I)]));\r\nend;\r\n{$ENDIF}\r\n\r\nfunction TJvCustomAppStorage.DefaultObjectListItemCreateEvent(Sender: TJvCustomAppStorage;\r\n const Path: string; Index: Integer): TPersistent;\r\nvar\r\n NewClassName: string;\r\nbegin\r\n NewClassName := Sender.ReadString(ConcatPaths([Path, cClassName]));\r\n Result := GetClass(NewClassName).Create;\r\nend;\r\n\r\nprocedure TJvCustomAppStorage.ReadObjectListItem(Sender: TJvCustomAppStorage;\r\n const Path: string; const List: TObject; const Index: Integer; const ItemName: string);\r\nvar\r\n NewItem: TPersistent;\r\n NewPath: string;\r\n TargetStore: TJvCustomAppStorage;\r\n TargetPath: string;\r\nbegin\r\n if List is TList then\r\n begin\r\n NewPath := ConcatPaths([Path, ItemNameIndexPath (ItemName, Index)]);\r\n ResolvePath(NewPath, TargetStore, TargetPath); // Only needed for assigning the event\r\n NewItem := TargetStore.CurrentInstanceCreateEvent(Sender, NewPath, Index);\r\n TList(List).Add(NewItem);\r\n Sender.ReadPersistent(NewPath, NewItem);\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomAppStorage.WriteObjectListItem(Sender: TJvCustomAppStorage;\r\n const Path: string; const List: TObject; const Index: Integer; const ItemName: string);\r\nbegin\r\n if List is TList then\r\n if Assigned(TList(List)[Index]) then\r\n Sender.WritePersistent(ConcatPaths([Path, ItemNameIndexPath (ItemName, Index)]), TPersistent(TList(List)[Index]));\r\nend;\r\n\r\nprocedure TJvCustomAppStorage.DeleteObjectListItem(Sender: TJvCustomAppStorage;\r\n const Path: string; const List: TObject; const First, Last: Integer; const ItemName: string);\r\nvar\r\n I: Integer;\r\nbegin\r\n if List is TList then\r\n for I := First to Last do\r\n Sender.DeleteValue(ConcatPaths([Path, ItemName + IntToStr(I)]));\r\nend;\r\n\r\nprocedure TJvCustomAppStorage.ReadStringObjectListItem(Sender: TJvCustomAppStorage;\r\n const Path: string; const List: TObject; const Index: Integer; const ItemName: string);\r\nvar\r\n NewItem: TPersistent;\r\n NewPath: string;\r\n NewName: string;\r\n TargetStore: TJvCustomAppStorage;\r\n TargetPath: string;\r\nbegin\r\n if List is TStrings then\r\n begin\r\n NewPath := ConcatPaths([Path, ItemNameIndexPath (ItemName, Index)]);\r\n ResolvePath(NewPath, TargetStore, TargetPath); // Only needed for assigning the event\r\n NewItem := TargetStore.CurrentInstanceCreateEvent(Sender, ConcatPaths([NewPath, cObject]), Index);\r\n NewName := Sender.ReadString(ConcatPaths([NewPath, cItemName]));\r\n TStrings(List).AddObject(NewName, NewItem);\r\n if NewItem is TJvCustomPropertyStore then\r\n Sender.ReadPersistent(ConcatPaths([NewPath, cObject]), NewItem,\r\n True, True, TJvCustomPropertyStore(NewItem).CombinedIgnoreProperties)\r\n else\r\n Sender.ReadPersistent(ConcatPaths([NewPath, cObject]), NewItem);\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomAppStorage.WriteStringObjectListItem(Sender: TJvCustomAppStorage;\r\n const Path: string; const List: TObject; const Index: Integer; const ItemName: string);\r\nvar\r\n Obj: TObject;\r\nbegin\r\n if List is TStrings then\r\n begin\r\n Sender.WriteString(ConcatPaths([Path, ItemNameIndexPath (ItemName, Index), cItemName]), TStrings(List)[Index]);\r\n Obj := TStrings(List).Objects[Index];\r\n if Assigned(Obj) then\r\n if (Obj is TJvCustomPropertyStore) then\r\n if not TJvCustomPropertyStore(Obj).ReadOnly then\r\n Sender.WritePersistent(ConcatPaths([Path, ItemNameIndexPath (ItemName, Index), cObject]), TPersistent(Obj),\r\n True, TJvCustomPropertyStore(Obj).CombinedIgnoreProperties)\r\n else\r\n else\r\n Sender.WritePersistent(ConcatPaths([Path, ItemNameIndexPath (ItemName, Index), cObject]), TPersistent(Obj));\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomAppStorage.DeleteStringObjectListItem(Sender: TJvCustomAppStorage;\r\n const Path: string; const List: TObject; const First, Last: Integer; const ItemName: string);\r\nvar\r\n I: Integer;\r\nbegin\r\n if List is TStrings then\r\n for I := First to Last do\r\n Sender.DeleteValue(ConcatPaths([Path, ItemName + IntToStr(I)]));\r\nend;\r\n\r\nprocedure TJvCustomAppStorage.ReadCollectionItem(Sender: TJvCustomAppStorage;\r\n const Path: string; const List: TObject; const Index: Integer; const ItemName: string);\r\nvar\r\n NewItem: TPersistent;\r\n NewPath: string;\r\nbegin\r\n if List is TCollection then\r\n begin\r\n NewPath := ConcatPaths([Path, ItemNameIndexPath (ItemName, Index)]);\r\n NewItem := TCollection(List).Add;\r\n if NewItem is TJvCustomPropertyStore then\r\n Sender.ReadPersistent(NewPath, NewItem, True, True,\r\n TJvCustomPropertyStore(NewItem).CombinedIgnoreProperties)\r\n else\r\n Sender.ReadPersistent(NewPath, NewItem);\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomAppStorage.WriteCollectionItem(Sender: TJvCustomAppStorage;\r\n const Path: string; const List: TObject; const Index: Integer; const ItemName: string);\r\nvar\r\n Item: TObject;\r\nbegin\r\n if List is TCollection then\r\n begin\r\n Item := TCollection(List).Items[Index];\r\n if Assigned(Item) then\r\n if Item is TJvCustomPropertyStore then\r\n if not TJvCustomPropertyStore(Item).ReadOnly then\r\n Sender.WritePersistent(ConcatPaths([Path, ItemNameIndexPath (ItemName, Index)]), TPersistent(Item),\r\n True, TJvCustomPropertyStore(Item).CombinedIgnoreProperties)\r\n else\r\n else\r\n Sender.WritePersistent(ConcatPaths([Path, ItemNameIndexPath (ItemName, Index)]), TPersistent(Item));\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomAppStorage.DeleteCollectionItem(Sender: TJvCustomAppStorage;\r\n const Path: string; const List: TObject; const First, Last: Integer; const ItemName: string);\r\nvar\r\n I: Integer;\r\nbegin\r\n if List is TCollection then\r\n for I := First to Last do\r\n Sender.DeleteValue(ConcatPaths([Path, ItemName + IntToStr(I)]));\r\nend;\r\n\r\nprocedure TJvCustomAppStorage.InternalGetStoredValues(const PrefixPath, SearchPath: string;\r\n const Strings: TStrings; const Options: TJvAppStorageEnumOptions);\r\nvar\r\n TempList: TStrings;\r\n I: Integer;\r\n S: string;\r\n PrevIdx: Integer;\r\n InsertPath : string;\r\nbegin\r\n if PrefixPath = PathDelim then\r\n InsertPath := ''\r\n else\r\n InsertPath := PrefixPath;\r\n TempList := TStringList.Create;\r\n try\r\n if aeoValues in Options then\r\n begin\r\n EnumValues(SearchPath, TempList, aeoReportListAsValue in Options);\r\n for I := 0 to TempList.Count - 1 do\r\n begin\r\n if TempList[I] = '' then\r\n S := Copy(PrefixPath, 1, Length(PrefixPath) - 1)\r\n else\r\n S := InsertPath + TempList[I];\r\n if S <> '' then\r\n begin\r\n PrevIdx := Strings.IndexOf(S);\r\n if PrevIdx > -1 then\r\n Strings.Objects[PrevIdx] :=\r\n TObject(Integer(Strings.Objects[PrevIdx]) or aptValue)\r\n else\r\n Strings.AddObject(S, TObject(aptValue));\r\n end;\r\n end;\r\n end;\r\n if (aeoFolders in Options) or (aeoRecursive in Options) then\r\n begin\r\n TempList.Clear;\r\n EnumFolders(SearchPath, TempList, False);\r\n for I := 0 to TempList.Count - 1 do\r\n begin\r\n if (aeoFolders in Options) and IsFolder(SearchPath + PathDelim +\r\n TempList[I], aeoReportListAsValue in Options) then\r\n begin\r\n PrevIdx := Strings.IndexOf(InsertPath + TempList[I]);\r\n if PrevIdx > -1 then\r\n Strings.Objects[PrevIdx] :=\r\n TObject(Integer(Strings.Objects[PrevIdx]) or aptFolder)\r\n else\r\n Strings.AddObject(InsertPath + TempList[I], TObject(aptFolder));\r\n end;\r\n if aeoRecursive in Options then\r\n InternalGetStoredValues(ConcatPaths([PrefixPath, TempList[I]]) + PathDelim,\r\n ConcatPaths([SearchPath, TempList[I]]),\r\n Strings, Options);\r\n end;\r\n end;\r\n finally\r\n TempList.Free;\r\n end;\r\nend;\r\n\r\nfunction TJvCustomAppStorage.GetPath: string;\r\nbegin\r\n Result := FCurPath;\r\nend;\r\n\r\nprocedure TJvCustomAppStorage.SetPath(const Path: string);\r\nbegin\r\n FCurPath := OptimizePaths([Path]);\r\nend;\r\n\r\nprocedure TJvCustomAppStorage.SetStorageOptions(Value: TJvCustomAppStorageOptions);\r\nbegin\r\n if (Value <> nil) and (Value <> FStorageOptions) then\r\n FStorageOptions.Assign(Value);\r\nend;\r\n\r\nprocedure TJvCustomAppStorage.DoTranslatePropertyName(Instance: TPersistent; var Name: string; const Reading: Boolean);\r\nbegin\r\n if Assigned(FOnTranslatePropertyName) then\r\n FOnTranslatePropertyName(Self, Instance, Name, Reading);\r\nend;\r\n\r\nfunction TJvCustomAppStorage.HasSubStorage(AStore: TJvCustomAppStorage): Boolean;\r\nvar\r\n I: Integer;\r\nbegin\r\n I := SubStorages.Count - 1;\r\n Result := False;\r\n while not Result and (I >= 0) do\r\n begin\r\n Result := (SubStorages[I].AppStorage = AStore) or\r\n ((SubStorages[I].AppStorage <> nil) and SubStorages[I].AppStorage.HasSubStorage(AStore));\r\n Dec(I);\r\n end;\r\nend;\r\n\r\nfunction TJvCustomAppStorage.ListStoredInt(const Path: string; const ItemName: string = cItem): Boolean;\r\nbegin\r\n Result := ValueStoredInt(StrEnsureSuffix(PathDelim, Path) + cCount);\r\nend;\r\n\r\nfunction TJvCustomAppStorage.DoReadDateTime(const Path: string; Default: TDateTime): TDateTime;\r\nbegin\r\n Result := DoReadFloat(Path, Default);\r\nend;\r\n\r\nfunction TJvCustomAppStorage.DoReadWideString(const Path: string;\r\n const Default: Widestring): Widestring;\r\nbegin\r\n {$IFDEF COMPILER12_UP}\r\n Result := ReadString(Path, string(Default));\r\n {$ELSE}\r\n Result := UTF8Decode(ReadString(Path, UTF8Encode(Default)));\r\n {$ENDIF COMPILER12_UP}\r\nend;\r\n\r\nprocedure TJvCustomAppStorage.DoWriteDateTime(const Path: string; Value: TDateTime);\r\nbegin\r\n DoWriteFloat(Path, Value);\r\nend;\r\n\r\nprocedure TJvCustomAppStorage.DoWriteWideString(const Path: string;\r\n const Value: Widestring);\r\nbegin\r\n {$IFDEF COMPILER12_UP}\r\n DoWriteString(Path,string(Value));\r\n {$ELSE}\r\n DoWriteString(Path,string(UTF8Encode(Value)));\r\n {$ENDIF COMPILER12_UP}\r\nend;\r\n\r\nprocedure TJvCustomAppStorage.DoError(const msg: string);\r\nbegin\r\n if Assigned(OnError) then\r\n OnError(Self, msg);\r\nend;\r\n\r\nfunction TJvCustomAppStorage.DoReadBoolean(const Path: string; Default: Boolean): Boolean;\r\nbegin\r\n Result := DoReadInteger(Path, Ord(Default)) <> Ord(False);\r\nend;\r\n\r\nprocedure TJvCustomAppStorage.DoWriteBoolean(const Path: string; Value: Boolean);\r\nbegin\r\n DoWriteInteger(Path, Ord(Value));\r\nend;\r\n\r\nfunction TJvCustomAppStorage.ReadIntegerInt(const Path: string; Default: Integer): Integer;\r\nbegin\r\n if not ValueStoredInt(Path) and StorageOptions.DefaultIfValueNotExists then\r\n Result := Default\r\n else\r\n try\r\n Result := DoReadInteger(Path, Default);\r\n except\r\n on E: EConvertError do\r\n if StorageOptions.DefaultIfReadConvertError then\r\n Result := Default\r\n else\r\n raise;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomAppStorage.WriteIntegerInt(const Path: string; Value: Integer);\r\nbegin\r\n DoWriteInteger(Path, Value);\r\nend;\r\n\r\nfunction TJvCustomAppStorage.ReadFloatInt(const Path: string; Default: Extended): Extended;\r\nbegin\r\n if not ValueStoredInt(Path) and StorageOptions.DefaultIfValueNotExists then\r\n Result := Default\r\n else\r\n try\r\n if StorageOptions.FloatAsString then\r\n try\r\n Result := StrToFloat(DecryptPropertyValue(DoReadString(Path, EncryptPropertyValue(FloatToStr(Default)))));\r\n except\r\n on E: EConvertError do\r\n Result := DoReadFloat(Path, Default);\r\n end\r\n else\r\n try\r\n Result := DoReadFloat(Path, Default);\r\n except\r\n on E: EConvertError do\r\n Result := StrToFloat(DecryptPropertyValue(DoReadString(Path, EncryptPropertyValue(FloatToStr(Default)))));\r\n end\r\n except\r\n on E: EConvertError do\r\n if StorageOptions.DefaultIfReadConvertError then\r\n Result := Default\r\n else\r\n raise;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomAppStorage.WriteFloatInt(const Path: string; Value: Extended);\r\nbegin\r\n if StorageOptions.FloatAsString then\r\n DoWriteString(Path, EncryptPropertyValue(FloatToStr(Value)))\r\n else\r\n DoWriteFloat(Path, Value);\r\nend;\r\n\r\nfunction TJvCustomAppStorage.ReadStringInt(const Path: string; const Default: string): string;\r\nbegin\r\n if not ValueStoredInt(Path) and StorageOptions.DefaultIfValueNotExists then\r\n Result := Default\r\n else\r\n try\r\n Result := DecryptPropertyValue(DoReadString(Path, EncryptPropertyValue(Default)));\r\n except\r\n on E: EConvertError do\r\n if StorageOptions.DefaultIfReadConvertError then\r\n Result := Default\r\n else\r\n raise;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomAppStorage.WriteStringInt(const Path: string; const Value: string);\r\nbegin\r\n DoWriteString(Path, EncryptPropertyValue(Value));\r\nend;\r\n\r\nfunction TJvCustomAppStorage.ReadBinaryInt(const Path: string; Buf: TJvBytes; BufSize: Integer): Integer;\r\nbegin\r\n Result := DoReadBinary(Path, Buf, BufSize);\r\nend;\r\n\r\nprocedure TJvCustomAppStorage.WriteBinaryInt(const Path: string; const Buf: TJvBytes; BufSize: Integer);\r\nbegin\r\n DoWriteBinary(Path, Buf, BufSize);\r\nend;\r\n\r\nfunction TJvCustomAppStorage.ReadDateTimeInt(const Path: string; Default: TDateTime): TDateTime;\r\nbegin\r\n if not ValueStoredInt(Path) and StorageOptions.DefaultIfValueNotExists then\r\n Result := Default\r\n else\r\n try\r\n if StorageOptions.DateTimeAsString then\r\n try\r\n Result := DecodeStrToDateTime(DecryptPropertyValue(DoReadString(Path, EncryptPropertyValue(EncodeDateTimeToStr(Default)))));\r\n except\r\n on E: EConvertError do\r\n Result := DoReadDateTime(Path, Default);\r\n end\r\n else\r\n try\r\n Result := DoReadDateTime(Path, Default);\r\n except\r\n on E: EConvertError do\r\n Result := DecodeStrToDateTime(DecryptPropertyValue(DoReadString(Path,\r\n EncryptPropertyValue(EncodeDateTimeToStr(Default)))));\r\n end\r\n except\r\n on E: EConvertError do\r\n if StorageOptions.DefaultIfReadConvertError then\r\n Result := Default\r\n else\r\n raise;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomAppStorage.WriteDateTimeInt(const Path: string; Value: TDateTime);\r\nbegin\r\n if StorageOptions.DateTimeAsString then\r\n DoWriteString(Path, EncryptPropertyValue(EncodeDateTimeToStr(Value)))\r\n else\r\n DoWriteFloat(Path, Value);\r\nend;\r\n\r\nfunction TJvCustomAppStorage.ReadBooleanInt(const Path: string; Default: Boolean): Boolean;\r\nvar\r\n Value: string;\r\nbegin\r\n if not ValueStoredInt(Path) and StorageOptions.DefaultIfValueNotExists then\r\n Result := Default\r\n else\r\n try\r\n if StorageOptions.BooleanAsString then\r\n try\r\n if Default then\r\n Value := DecryptPropertyValue(DoReadString(Path, EncryptPropertyValue(StorageOptions.DefaultTrueString)))\r\n else\r\n Value := DecryptPropertyValue(DoReadString(Path, EncryptPropertyValue(StorageOptions.DefaultFalseString)));\r\n if StorageOptions.IsValueTrueString(Value) then\r\n Result := True\r\n else\r\n if StorageOptions.IsValueFalseString(Value) then\r\n Result := False\r\n else\r\n Result := DoReadBoolean(Path, Default);\r\n except\r\n on E: EConvertError do\r\n Result := DoReadBoolean(Path, Default);\r\n end\r\n else\r\n Result := DoReadBoolean(Path, Default);\r\n except\r\n on E: EConvertError do\r\n if StorageOptions.DefaultIfReadConvertError then\r\n Result := Default\r\n else\r\n raise;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomAppStorage.WriteBooleanInt(const Path: string; Value: Boolean);\r\nbegin\r\n if StorageOptions.BooleanAsString then\r\n if Value then\r\n DoWriteString(Path, EncryptPropertyValue(StorageOptions.DefaultTrueString))\r\n else\r\n DoWriteString(Path, EncryptPropertyValue(StorageOptions.DefaultFalseString))\r\n else\r\n DoWriteBoolean(Path, Value);\r\nend;\r\n\r\nclass function TJvCustomAppStorage.NameIsListItem(const Name: string): Boolean;\r\nvar\r\n NameStart: PChar;\r\nbegin\r\n NameStart := AnsiStrRScan(PChar(Name), PathDelim);\r\n if NameStart = nil then\r\n NameStart := PChar(Name);\r\n Result := (AnsiStrLIComp(NameStart, cItem, 4) = 0) and CharInSet(NameStart[4], DigitSymbols);\r\nend;\r\n\r\nclass function TJvCustomAppStorage.ConcatPaths(const Paths: array of string): string;\r\nbegin\r\n Result := OptimizePaths(Paths);\r\nend;\r\n\r\nprocedure TJvCustomAppStorage.ResolvePath(const InPath: string; out TargetStore: TJvCustomAppStorage;\r\n out TargetPath: string);\r\nvar\r\n SubStorageItem: TJvAppSubStorage;\r\nbegin\r\n TargetPath := PathDelim + ConcatPaths([Path, InPath]);\r\n TargetStore := Self;\r\n SubStorageItem := SubStorages.MatchFor(TargetPath);\r\n if (SubStorageItem <> nil) and (SubStorageItem.AppStorage <> nil) then\r\n begin\r\n TargetStore := SubStorageItem.AppStorage;\r\n Delete(TargetPath, 1, Length(SubStorageItem.RootPath) + 1);\r\n TargetPath := PathDelim + OptimizePaths([TargetPath]);\r\n if TargetPath = PathDelim then\r\n raise EJVCLAppStorageError.CreateRes(@RsEInvalidPath);\r\n end;\r\nend;\r\n\r\nfunction TJvCustomAppStorage.IsFolder(const Path: string; ListIsValue: Boolean): Boolean;\r\nvar\r\n TargetStore: TJvCustomAppStorage;\r\n TargetPath: string;\r\nbegin\r\n ResolvePath(Path, TargetStore, TargetPath);\r\n Result := TargetStore.IsFolderInt(TargetPath, ListIsValue);\r\nend;\r\n\r\nfunction TJvCustomAppStorage.PathExists(const Path: string): Boolean;\r\nvar\r\n TargetStore: TJvCustomAppStorage;\r\n TargetPath: string;\r\nbegin\r\n ResolvePath(Path, TargetStore, TargetPath);\r\n Result := TargetStore.PathExistsInt(TargetPath);\r\nend;\r\n\r\nfunction TJvCustomAppStorage.ValueStored(const Path: string): Boolean;\r\nvar\r\n TargetStore: TJvCustomAppStorage;\r\n TargetPath: string;\r\nbegin\r\n ResolvePath(Path, TargetStore, TargetPath);\r\n Result := TargetStore.ValueStoredInt(TargetPath);\r\nend;\r\n\r\nfunction TJvCustomAppStorage.ListStored(const Path: string; const ItemName: string = cItem): Boolean;\r\nvar\r\n TargetStore: TJvCustomAppStorage;\r\n TargetPath: string;\r\nbegin\r\n ResolvePath(Path, TargetStore, TargetPath);\r\n Result := TargetStore.ListStoredInt(TargetPath, ItemName);\r\nend;\r\n\r\nprocedure TJvCustomAppStorage.DeleteValue(const Path: string);\r\nvar\r\n TargetStore: TJvCustomAppStorage;\r\n TargetPath: string;\r\nbegin\r\n ResolvePath(Path, TargetStore, TargetPath);\r\n if not TargetStore.ReadOnly then\r\n TargetStore.DeleteValueInt(TargetPath);\r\nend;\r\n\r\nprocedure TJvCustomAppStorage.DeleteSubTree(const Path: string);\r\nvar\r\n TargetStore: TJvCustomAppStorage;\r\n TargetPath: string;\r\nbegin\r\n ResolvePath(Path, TargetStore, TargetPath);\r\n if not TargetStore.ReadOnly then\r\n TargetStore.DeleteSubTreeInt(Path);\r\nend;\r\n\r\nfunction TJvCustomAppStorage.ReadInteger(const Path: string; Default: Integer): Integer;\r\nvar\r\n TargetStore: TJvCustomAppStorage;\r\n TargetPath: string;\r\nbegin\r\n ResolvePath(Path, TargetStore, TargetPath);\r\n Result := TargetStore.ReadIntegerInt(TargetPath, Default);\r\nend;\r\n\r\nprocedure TJvCustomAppStorage.WriteInteger(const Path: string; Value: Integer);\r\nvar\r\n TargetStore: TJvCustomAppStorage;\r\n TargetPath: string;\r\nbegin\r\n ResolvePath(Path, TargetStore, TargetPath);\r\n if not TargetStore.ReadOnly then\r\n TargetStore.WriteIntegerInt(TargetPath, Value);\r\nend;\r\n\r\nfunction TJvCustomAppStorage.ReadFloat(const Path: string; Default: Extended): Extended;\r\nvar\r\n TargetStore: TJvCustomAppStorage;\r\n TargetPath: string;\r\nbegin\r\n ResolvePath(Path, TargetStore, TargetPath);\r\n Result := TargetStore.ReadFloatInt(TargetPath, Default);\r\nend;\r\n\r\nprocedure TJvCustomAppStorage.WriteFloat(const Path: string; Value: Extended);\r\nvar\r\n TargetStore: TJvCustomAppStorage;\r\n TargetPath: string;\r\nbegin\r\n ResolvePath(Path, TargetStore, TargetPath);\r\n if not TargetStore.ReadOnly then\r\n TargetStore.WriteFloatInt(TargetPath, Value);\r\nend;\r\n\r\nfunction TJvCustomAppStorage.ReadString(const Path: string; const Default: string): string;\r\nvar\r\n TargetStore: TJvCustomAppStorage;\r\n TargetPath: string;\r\nbegin\r\n ResolvePath(Path, TargetStore, TargetPath);\r\n Result := TargetStore.ReadStringInt(TargetPath, Default);\r\nend;\r\n\r\nprocedure TJvCustomAppStorage.WriteString(const Path: string; const Value: string);\r\nvar\r\n TargetStore: TJvCustomAppStorage;\r\n TargetPath: string;\r\nbegin\r\n ResolvePath(Path, TargetStore, TargetPath);\r\n if not TargetStore.ReadOnly then\r\n TargetStore.WriteStringInt(TargetPath, Value);\r\nend;\r\n\r\nfunction TJvCustomAppStorage.ReadBinary(const Path: string; Buf: TJvBytes; BufSize: Integer): Integer;\r\nvar\r\n TargetStore: TJvCustomAppStorage;\r\n TargetPath: string;\r\nbegin\r\n ResolvePath(Path, TargetStore, TargetPath);\r\n Result := TargetStore.ReadBinaryInt(TargetPath, Buf, BufSize);\r\nend;\r\n\r\nprocedure TJvCustomAppStorage.WriteBinary(const Path: string; const Buf: TJvBytes; BufSize: Integer);\r\nvar\r\n TargetStore: TJvCustomAppStorage;\r\n TargetPath: string;\r\nbegin\r\n ResolvePath(Path, TargetStore, TargetPath);\r\n if not TargetStore.ReadOnly then\r\n TargetStore.WriteBinaryInt(TargetPath, Buf, BufSize);\r\nend;\r\n\r\nfunction TJvCustomAppStorage.ReadDateTime(const Path: string; Default: TDateTime): TDateTime;\r\nvar\r\n TargetStore: TJvCustomAppStorage;\r\n TargetPath: string;\r\nbegin\r\n ResolvePath(Path, TargetStore, TargetPath);\r\n Result := TargetStore.ReadDateTimeInt(TargetPath, Default);\r\nend;\r\n\r\nprocedure TJvCustomAppStorage.WriteDateTime(const Path: string; Value: TDateTime);\r\nvar\r\n TargetStore: TJvCustomAppStorage;\r\n TargetPath: string;\r\nbegin\r\n ResolvePath(Path, TargetStore, TargetPath);\r\n if not TargetStore.ReadOnly then\r\n TargetStore.WriteDateTimeInt(TargetPath, Value);\r\nend;\r\n\r\nfunction TJvCustomAppStorage.ReadBoolean(const Path: string; Default: Boolean): Boolean;\r\nvar\r\n TargetStore: TJvCustomAppStorage;\r\n TargetPath: string;\r\nbegin\r\n ResolvePath(Path, TargetStore, TargetPath);\r\n Result := TargetStore.ReadBooleanInt(TargetPath, Default);\r\nend;\r\n\r\nprocedure TJvCustomAppStorage.WriteBoolean(const Path: string; Value: Boolean);\r\nvar\r\n TargetStore: TJvCustomAppStorage;\r\n TargetPath: string;\r\nbegin\r\n ResolvePath(Path, TargetStore, TargetPath);\r\n if not TargetStore.ReadOnly then\r\n TargetStore.WriteBooleanInt(TargetPath, Value);\r\nend;\r\n\r\nfunction TJvCustomAppStorage.ReadList(const Path: string; const List: TObject;\r\n const OnReadItem: TJvAppStorageListItemEvent;\r\n const ItemName: string = cItem): Integer;\r\nvar\r\n I: Integer;\r\n ItemCount: Integer;\r\nbegin\r\n BeginUpdate;\r\n try\r\n ItemCount := ReadListItemCount (Path, ItemName);\r\n for I := 0 to ItemCount - 1 do\r\n OnReadItem(Self, Path, List, I, ItemName);\r\n Result := ItemCount;\r\n finally\r\n EndUpdate;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomAppStorage.WriteList(const Path: string; const List: TObject;\r\n const ItemCount: Integer; const OnWriteItem: TJvAppStorageListItemEvent;\r\n const OnDeleteItems: TJvAppStorageListDeleteEvent = nil; const ItemName: string = cItem);\r\nvar\r\n TargetStore: TJvCustomAppStorage;\r\n TargetPath: string;\r\n PrevListCount: Integer;\r\n I: Integer;\r\nbegin\r\n ResolvePath(Path + cSubStorePath, TargetStore, TargetPath); // Only Needed for ReadOnly\r\n if not TargetStore.ReadOnly then\r\n begin\r\n TargetStore.BeginUpdate;\r\n try\r\n PrevListCount := ReadListItemCount (Path, ItemName);\r\n for I := 0 to ItemCount - 1 do\r\n OnWriteItem(Self, Path, List, I, ItemName);\r\n if (PrevListCount > ItemCount) and Assigned(OnDeleteItems) then\r\n OnDeleteItems(Self, Path, List, ItemCount, PrevListCount - 1, ItemName);\r\n WriteListItemCount (Path, ItemCount, ItemName);\r\n finally\r\n TargetStore.EndUpdate;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJvCustomAppStorage.ReadObjectList(const Path: string; List: TList;\r\n const ClearFirst: Boolean = True; const ItemName: string = cItem): Integer;\r\nbegin\r\n Result := ReadObjectList(Path, List, DefaultObjectListItemCreateEvent, ClearFirst, ItemName);\r\nend;\r\n\r\nfunction TJvCustomAppStorage.ReadObjectList(const Path: string; List: TList;\r\n ItemCreator: TJvAppStorageObjectListItemCreateEvent;\r\n const ClearFirst: Boolean = True; const ItemName: string = cItem): Integer;\r\nvar\r\n TargetStore: TJvCustomAppStorage;\r\n TargetPath: string;\r\n FOldInstanceCreateEvent: TJvAppStorageObjectListItemCreateEvent;\r\nbegin\r\n if not ListStored(Path, ItemName) and StorageOptions.DefaultIfValueNotExists then\r\n Result := List.Count\r\n else\r\n begin\r\n if ClearFirst then\r\n List.Clear;\r\n ResolvePath(Path + cSubStorePath, TargetStore, TargetPath); // Only needed for assigning the event\r\n FOldInstanceCreateEvent := TargetStore.CurrentInstanceCreateEvent;\r\n try\r\n TargetStore.SetCurrentInstanceCreateEvent(ItemCreator);\r\n Result := ReadList(Path, List, ReadObjectListItem, ItemName);\r\n finally\r\n TargetStore.SetCurrentInstanceCreateEvent(FOldInstanceCreateEvent);\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomAppStorage.WriteObjectList(const Path: string; List: TList;\r\n const ItemName: string = cItem);\r\nbegin\r\n WriteList(Path, List, List.Count, WriteObjectListItem, DeleteObjectListItem, ItemName);\r\nend;\r\n\r\nfunction TJvCustomAppStorage.ReadCollection(const Path: string; List: TCollection;\r\n const ClearFirst: Boolean = True; const ItemName: string = cItem): Integer;\r\nbegin\r\n if not ListStored(Path, ItemName) and StorageOptions.DefaultIfValueNotExists then\r\n Result := List.Count\r\n else\r\n try\r\n List.BeginUpdate;\r\n if ClearFirst then\r\n List.Clear;\r\n ReadPersistent(Path,List,True,False);\r\n Result := ReadList(Path, List, ReadCollectionItem, ItemName);\r\n finally\r\n List.EndUpdate;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomAppStorage.WriteCollection(const Path: string;\r\n List: TCollection; const ItemName: string = cItem);\r\nbegin\r\n WriteList(Path, List, List.Count, WriteCollectionItem, DeleteCollectionItem, ItemName);\r\n WritePersistent(Path,List);\r\nend;\r\n\r\nfunction TJvCustomAppStorage.ReadStringList(const Path: string; const SL: TStrings;\r\n const ClearFirst: Boolean = True; const ItemName: string = cItem): Integer;\r\nbegin\r\n BeginUpdate;\r\n SL.BeginUpdate;\r\n try\r\n if ClearFirst then\r\n SL.Clear;\r\n if not ListStored(Path, ItemName) then\r\n begin\r\n if ValueStored(Path) then\r\n Sl.Text := ReadString(Path);\r\n Result := SL.Count\r\n end\r\n else\r\n begin\r\n ReadPersistent(Path,SL,True,False);\r\n Result := ReadList(Path, SL, ReadStringListItem, ItemName);\r\n end;\r\n finally\r\n SL.EndUpdate;\r\n EndUpdate;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomAppStorage.WriteStringList(const Path: string;\r\n const SL: TStrings; const ItemName: string = cItem);\r\nbegin\r\n BeginUpdate;\r\n try\r\n if StorageOptions.StoreStringListAsSingleString then\r\n begin\r\n if ListStored(Path, ItemName) then\r\n DeleteSubTree(Path);\r\n WriteString(Path, SL.Text);\r\n end\r\n else\r\n begin\r\n WriteList(Path, SL, SL.Count, WriteStringListItem, DeleteStringListItem, ItemName);\r\n WritePersistent(Path,SL);\r\n end;\r\n finally\r\n EndUpdate;\r\n end;\r\nend;\r\n\r\n{$IFDEF COMPILER10_UP}\r\nfunction TJvCustomAppStorage.ReadWideStringList(const Path: string; const SL: WideStrings.TWideStrings;\r\n const ClearFirst: Boolean = True; const ItemName: string = cItem): Integer;\r\nbegin\r\n BeginUpdate;\r\n try\r\n if not ListStored(Path) and StorageOptions.DefaultIfValueNotExists then\r\n Result := SL.Count\r\n else\r\n begin\r\n SL.BeginUpdate;\r\n try\r\n if ClearFirst then\r\n SL.Clear;\r\n ReadPersistent(Path,SL,True,False);\r\n Result := ReadList(Path, SL, ReadWideStringListItem, ItemName);\r\n finally\r\n SL.EndUpdate;\r\n end;\r\n end;\r\n finally\r\n EndUpdate;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomAppStorage.WriteWideStringList(const Path: string;\r\n const SL: WideStrings.TWideStrings; const ItemName: string = cItem);\r\nbegin\r\n BeginUpdate;\r\n try\r\n WriteList(Path, SL, SL.Count, WriteWideStringListItem, DeleteWideStringListItem, ItemName);\r\n WritePersistent(Path,SL);\r\n finally\r\n EndUpdate;\r\n end;\r\nend;\r\n{$ENDIF}\r\n\r\nfunction TJvCustomAppStorage.ReadStringObjectList(const Path: string; const SL: TStrings;\r\n const ClearFirst: Boolean = True; const ItemName: string = cItem): Integer;\r\nbegin\r\n Result := ReadStringObjectList(Path, SL, DefaultObjectListItemCreateEvent, ClearFirst, ItemName);\r\nend;\r\n\r\nfunction TJvCustomAppStorage.ReadStringObjectList(const Path: string;\r\n const SL: TStrings; ItemCreator: TJvAppStorageObjectListItemCreateEvent;\r\n const ClearFirst: Boolean = True; const ItemName: string = cItem): Integer;\r\nvar\r\n TargetStore: TJvCustomAppStorage;\r\n TargetPath: string;\r\n FOldInstanceCreateEvent: TJvAppStorageObjectListItemCreateEvent;\r\nbegin\r\n if not ListStoredInt(Path, ItemName) and StorageOptions.DefaultIfValueNotExists then\r\n Result := SL.Count\r\n else\r\n begin\r\n SL.BeginUpdate;\r\n try\r\n ResolvePath(Path + cSubStorePath, TargetStore, TargetPath);\r\n Delete(TargetPath, Length(TargetPath) - 1, 2);\r\n if ClearFirst then\r\n SL.Clear;\r\n ReadPersistent(Path,SL,True,False);\r\n FOldInstanceCreateEvent := TargetStore.CurrentInstanceCreateEvent;\r\n try\r\n TargetStore.SetCurrentInstanceCreateEvent(ItemCreator);\r\n Result := TargetStore.ReadList(TargetPath, SL, TargetStore.ReadStringObjectListItem, ItemName);\r\n finally\r\n TargetStore.SetCurrentInstanceCreateEvent(FOldInstanceCreateEvent);\r\n end;\r\n finally\r\n SL.EndUpdate;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomAppStorage.WriteStringObjectList(const Path: string;\r\n const SL: TStrings; const ItemName: string = cItem);\r\nvar\r\n TargetStore: TJvCustomAppStorage;\r\n TargetPath: string;\r\nbegin\r\n ResolvePath(Path + cSubStorePath, TargetStore, TargetPath);\r\n Delete(TargetPath, Length(TargetPath) - 1, 2);\r\n TargetStore.WriteList(TargetPath, SL, SL.Count,\r\n TargetStore.WriteStringObjectListItem, TargetStore.DeleteStringObjectListItem, ItemName);\r\n WritePersistent(Path,SL);\r\nend;\r\n\r\nprocedure TJvCustomAppStorage.ReadEnumerationInt(const Path: string;\r\n TypeInfo: PTypeInfo; const Default; out Value);\r\nvar\r\n OrdValue: Integer;\r\n Conv: TIdentToInt;\r\n S: string;\r\n TmpDefReadError: Boolean;\r\nbegin\r\n if not ValueStoredInt(Path) and StorageOptions.DefaultIfValueNotExists then\r\n CopyEnumValue(Default, Value, GetTypeData(TypeInfo).OrdType)\r\n else\r\n begin\r\n OrdValue := 0;\r\n CopyEnumValue(Default, OrdValue, GetTypeData(TypeInfo).OrdType);\r\n if (TypeInfo = System.TypeInfo(Boolean)) or ((TypeInfo.Kind = tkEnumeration) and\r\n (GetTypeData(GetTypeData(TypeInfo).BaseType^).MinValue < 0)) then\r\n OrdValue := Ord(ReadBooleanInt(Path, OrdValue <> 0))\r\n else\r\n begin\r\n try\r\n if TypeInfo.Kind in [tkChar, tkWChar] then\r\n OrdValue := ReadIntegerInt(Path, OrdValue)\r\n else\r\n if TypeInfo.Kind = tkInteger then\r\n begin\r\n { Could be stored as a normal int or as an identifier.\r\n Try identifier first as that will not raise an exception }\r\n Conv := FindIdentToInt(TypeInfo);\r\n if Assigned(Conv) then\r\n begin\r\n TmpDefReadError := StorageOptions.DefaultIfReadConvertError;\r\n StorageOptions.DefaultIfReadConvertError := True;\r\n try\r\n S := ReadStringInt(Path, '');\r\n finally\r\n StorageOptions.DefaultIfReadConvertError := TmpDefReadError;\r\n end;\r\n if (S = '') or not (Conv(S, OrdValue)) then\r\n OrdValue := ReadIntegerInt(Path, OrdValue);\r\n end\r\n else\r\n OrdValue := ReadIntegerInt(Path, OrdValue);\r\n end\r\n else\r\n if TypeInfo.Kind = tkEnumeration then\r\n begin\r\n // Usage of an invalid identifier to signal the value does not exist\r\n OrdValue := GetEnumValue(TypeInfo, ReadStringInt(Path, cInvalidIdentifier));\r\n if OrdValue = -1 then\r\n begin\r\n OrdValue := ReadIntegerInt(Path, OrdValue);\r\n if OrdValue = -1 then\r\n CopyEnumValue(Default, OrdValue, GetTypeData(TypeInfo).OrdType)\r\n end;\r\n end\r\n else\r\n raise EJVCLAppStorageError.CreateRes(@RsEInvalidType);\r\n except\r\n on E: EConvertError do\r\n if StorageOptions.DefaultIfReadConvertError then\r\n CopyEnumValue(Default, OrdValue, GetTypeData(TypeInfo).OrdType)\r\n else\r\n raise;\r\n end;\r\n end;\r\n CopyEnumValue(OrdValue, Value, GetTypeData(TypeInfo).OrdType);\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomAppStorage.WriteEnumerationInt(const Path: string;\r\n TypeInfo: PTypeInfo; const Value);\r\nvar\r\n Conv: TIntToIdent;\r\n S: string;\r\nbegin\r\n if TypeInfo = System.TypeInfo(Boolean) then\r\n WriteBooleanInt(Path, Boolean(Value))\r\n else\r\n if (TypeInfo.Kind = tkEnumeration) and\r\n (GetTypeData(GetTypeData(TypeInfo).BaseType^).MinValue < 0) then\r\n WriteBooleanInt(Path, OrdOfEnum(Value, GetTypeData(TypeInfo).OrdType) <> 0)\r\n else\r\n if TypeInfo.Kind in [tkChar, tkWChar] then\r\n WriteIntegerInt(Path, OrdOfEnum(Value, GetTypeData(TypeInfo).OrdType))\r\n else\r\n if TypeInfo.Kind = tkInteger then\r\n begin\r\n if StorageOptions.TypedIntegerAsString then\r\n begin\r\n Conv := FindIntToIdent(TypeInfo);\r\n if Assigned(Conv) and Conv(OrdOfEnum(Value, GetTypeData(TypeInfo).OrdType), S) then\r\n WriteStringInt(Path, S)\r\n else\r\n WriteIntegerInt(Path, OrdOfEnum(Value, GetTypeData(TypeInfo).OrdType));\r\n end\r\n else\r\n WriteIntegerInt(Path, OrdOfEnum(Value, GetTypeData(TypeInfo).OrdType));\r\n end\r\n else\r\n if TypeInfo.Kind = tkEnumeration then\r\n begin\r\n if StorageOptions.EnumerationAsString then\r\n WriteStringInt(Path, GetEnumName(TypeInfo, OrdOfEnum(Value, GetTypeData(TypeInfo).OrdType)))\r\n else\r\n WriteIntegerInt(Path, OrdOfEnum(Value, GetTypeData(TypeInfo).OrdType));\r\n end\r\n else\r\n raise EJVCLAppStorageError.CreateRes(@RsEInvalidType);\r\nend;\r\n\r\nprocedure TJvCustomAppStorage.ReadEnumeration(const Path: string; TypeInfo: PTypeInfo; const Default; out Value);\r\nvar\r\n TargetStore: TJvCustomAppStorage;\r\n TargetPath: string;\r\nbegin\r\n ResolvePath(Path, TargetStore, TargetPath);\r\n TargetStore.ReadEnumerationInt(TargetPath, TypeInfo, Default, Value);\r\nend;\r\n\r\nprocedure TJvCustomAppStorage.WriteEnumeration(const Path: string;\r\n TypeInfo: PTypeInfo; const Value);\r\nvar\r\n TargetStore: TJvCustomAppStorage;\r\n TargetPath: string;\r\nbegin\r\n ResolvePath(Path, TargetStore, TargetPath);\r\n if not TargetStore.ReadOnly then\r\n TargetStore.WriteEnumerationInt(TargetPath, TypeInfo, Value);\r\nend;\r\n\r\nprocedure TJvCustomAppStorage.ReadSetInt(const Path: string;\r\n ATypeInfo: PTypeInfo; const Default; out Value);\r\nvar\r\n Lst: TStrings;\r\n I: Integer;\r\n JclOrdinalRangeTypeInfo : IJclOrdinalRangeTypeInfo;\r\n JclEnumerationTypeInfo : IJclEnumerationTypeInfo;\r\nbegin\r\n if IsFolder(Path) then\r\n begin\r\n Lst := TStringList.Create;\r\n try\r\n JclOrdinalRangeTypeInfo := (JclTypeInfo(ATypeInfo) as IJclSetTypeInfo).BaseType as IJclOrdinalRangeTypeInfo;\r\n case JclOrdinalRangeTypeInfo.GetTypeKind of\r\n tkEnumeration:\r\n begin\r\n JclEnumerationTypeInfo := ((JclTypeInfo(ATypeInfo) as IJclSetTypeInfo).BaseType as IJclEnumerationTypeInfo);\r\n for I := JclEnumerationTypeInfo.GetMinValue to JclEnumerationTypeInfo.GetMaxValue do\r\n if ReadBooleanInt(ConcatPaths([Path, JclEnumerationTypeInfo.GetNames(I)]), False) then\r\n Lst.Add(JclEnumerationTypeInfo.GetNames(I));\r\n (JclTypeInfo(ATypeInfo) as IJclSetTypeInfo).SetAsList(Value, Lst);\r\n end;\r\n tkChar:\r\n begin\r\n JclStrToSet(ATypeInfo, Value, ''); // empty out value\r\n for I := JclOrdinalRangeTypeInfo.GetMinValue to JclOrdinalRangeTypeInfo.GetMaxValue do\r\n if ReadBooleanInt(ConcatPaths([Path, GetCharName(Chr(I))]), False) then\r\n Include(TIntegerSet(Value), I);\r\n end;\r\n tkInteger:\r\n begin\r\n for I := JclOrdinalRangeTypeInfo.GetMinValue to JclOrdinalRangeTypeInfo.GetMaxValue do\r\n if ReadBooleanInt(ConcatPaths([Path, GetIntName(I)]), False) then\r\n Lst.Add(IntToStr(I));\r\n (JclTypeInfo(ATypeInfo) as IJclSetTypeInfo).SetAsList(Value, Lst);\r\n end;\r\n else\r\n raise EJVCLAppStorageError.CreateRes(@RsEUnknownBaseType);\r\n end;\r\n finally\r\n FreeAndNil(Lst);\r\n end;\r\n end\r\n else\r\n // It's stored as a string value or not stored at all\r\n JclStrToSet(ATypeInfo, Value, ReadStringInt(Path, JclSetToStr(ATypeInfo, Default, True)));\r\nend;\r\n\r\nprocedure TJvCustomAppStorage.WriteSetInt(const Path: string; ATypeInfo: PTypeInfo; const Value);\r\nvar\r\n Lst: TStrings;\r\n I: Integer;\r\n JclOrdinalRangeTypeInfo : IJclOrdinalRangeTypeInfo;\r\n JclEnumerationTypeInfo : IJclEnumerationTypeInfo;\r\nbegin\r\n if StorageOptions.SetAsString then\r\n WriteStringInt(Path, JclSetToStr(ATypeInfo, Value, True))\r\n else\r\n begin\r\n Lst := TStringList.Create;\r\n try\r\n JclOrdinalRangeTypeInfo := (JclTypeInfo(ATypeInfo) as IJclSetTypeInfo).BaseType as IJclOrdinalRangeTypeInfo;\r\n begin\r\n case JclOrdinalRangeTypeInfo.GetTypeKind of\r\n tkEnumeration:\r\n begin\r\n (JclTypeInfo(ATypeInfo) as IJclSetTypeInfo).GetAsList(Value, False, Lst);\r\n JclEnumerationTypeInfo :=((JclTypeInfo(ATypeInfo) as IJclSetTypeInfo).BaseType as IJclEnumerationTypeInfo);\r\n for I := JclEnumerationTypeInfo.GetMinValue to JclEnumerationTypeInfo.GetMaxValue do\r\n WriteBooleanInt(ConcatPaths([Path, JclEnumerationTypeInfo.GetNames(I)]),\r\n Lst.IndexOf(JclEnumerationTypeInfo.GetNames(I)) > -1);\r\n end;\r\n tkChar:\r\n begin\r\n for I := JclOrdinalRangeTypeInfo.GetMinValue to JclOrdinalRangeTypeInfo.GetMaxValue do\r\n WriteBooleanInt(ConcatPaths([Path, GetCharName(Chr(I))]), I in TIntegerSet(Value));\r\n end;\r\n tkInteger:\r\n begin\r\n (JclTypeInfo(ATypeInfo) as IJclSetTypeInfo).GetAsList(Value, False, Lst);\r\n for I := JclOrdinalRangeTypeInfo.GetMinValue to JclOrdinalRangeTypeInfo.GetMaxValue do\r\n WriteBooleanInt(ConcatPaths([Path, GetIntName(I)]),\r\n Lst.IndexOf(IntToStr(I)) > -1);\r\n end;\r\n else\r\n raise EJVCLAppStorageError.CreateRes(@RsEUnknownBaseType);\r\n end;\r\n end;\r\n finally\r\n FreeAndNil(Lst);\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomAppStorage.ReadSet(const Path: string; ATypeInfo: PTypeInfo; const Default; out Value);\r\nvar\r\n TargetStore: TJvCustomAppStorage;\r\n TargetPath: string;\r\nbegin\r\n ResolvePath(Path, TargetStore, TargetPath);\r\n TargetStore.ReadSetInt(TargetPath, ATypeInfo, Default, Value);\r\nend;\r\n\r\nprocedure TJvCustomAppStorage.WriteSet(const Path: string; ATypeInfo: PTypeInfo; const Value);\r\nvar\r\n TargetStore: TJvCustomAppStorage;\r\n TargetPath: string;\r\nbegin\r\n ResolvePath(Path, TargetStore, TargetPath);\r\n if not TargetStore.ReadOnly then\r\n TargetStore.WriteSetInt(TargetPath, ATypeInfo, Value);\r\nend;\r\n\r\nprocedure TJvCustomAppStorage.ReadProperty(const Path: string; const PersObj: TPersistent; const PropName: string; const\r\n Recursive, ClearFirst: Boolean; const IgnoreProperties: TStrings = nil);\r\nvar\r\n //Index: Integer;\r\n TmpValue: Integer;\r\n SubObj: TObject;\r\n P: PPropInfo;\r\nbegin\r\n if not Assigned(PersObj) then\r\n Exit;\r\n case PropType(PersObj, PropName) of\r\n {$IFDEF UNICODE} tkUString, {$ENDIF}\r\n tkLString, tkString:\r\n SetStrProp(PersObj, PropName, ReadString(Path, GetStrProp(PersObj, PropName)));\r\n tkWString:\r\n {$IFDEF RTL240_UP}SetStrProp{$ELSE}SetWideStrProp{$ENDIF RTL240_UP}(PersObj, PropName, ReadWideString(Path, {$IFDEF RTL240_UP}GetStrProp{$ELSE}GetWideStrProp{$ENDIF RTL240_UP}(PersObj, PropName)));\r\n tkEnumeration:\r\n begin\r\n TmpValue := GetOrdProp(PersObj, PropName);\r\n ReadEnumeration(Path, GetPropInfo(PersObj, PropName).PropType^, TmpValue, TmpValue);\r\n SetOrdProp(PersObj, PropName, TmpValue);\r\n end;\r\n tkVariant:\r\n SetVariantProp(PersObj, PropName, ReadString(Path, VarToStr(GetVariantProp(PersObj, PropName))));\r\n tkSet:\r\n begin\r\n TmpValue := GetOrdProp(PersObj, PropName);\r\n ReadSet(Path, GetPropInfo(PersObj, PropName).PropType^, TmpValue, TmpValue);\r\n SetOrdProp(PersObj, PropName, TmpValue);\r\n end;\r\n tkChar, tkWChar, tkInteger:\r\n begin\r\n TmpValue := GetOrdProp(PersObj, PropName);\r\n ReadEnumeration(Path, GetPropInfo(PersObj, PropName).PropType^, TmpValue, TmpValue);\r\n SetOrdProp(PersObj, PropName, TmpValue);\r\n end;\r\n tkInt64:\r\n SetInt64Prop(PersObj, PropName, StrToInt64(ReadString(Path,\r\n IntToStr(GetInt64Prop(PersObj, PropName)))));\r\n tkFloat:\r\n begin\r\n P := GetPropInfo(PersObj, PropName, tkAny);\r\n if (P <> nil) and (P.PropType <> nil) and (P.PropType^ = TypeInfo(TDateTime)) then\r\n SetFloatProp(PersObj, PropName, ReadDateTime(Path, GetFloatProp(PersObj, PropName)))\r\n else\r\n SetFloatProp(PersObj, PropName, ReadFloat(Path, GetFloatProp(PersObj, PropName)));\r\n end;\r\n tkClass:\r\n begin\r\n SubObj := GetObjectProp(PersObj, PropName);\r\n if (RegisteredAppStoragePropertyEngineList <> nil) and\r\n Recursive and\r\n RegisteredAppStoragePropertyEngineList.ReadProperty(Self, Path, PersObj, SubObj, Recursive, ClearFirst, IgnoreProperties) then\r\n // Do nothing else, the handling is done in the ReadProperty procedure\r\n else\r\n if SubObj is TStrings then\r\n ReadStringList(Path, TStrings(SubObj), ClearFirst)\r\n else\r\n if (SubObj is TPersistent) and Recursive then\r\n if SubObj is TJvCustomPropertyStore then\r\n begin\r\n TJvCustomPropertyStore(SubObj).AppStoragePath := Path;\r\n TJvCustomPropertyStore(SubObj).AppStorage := Self;\r\n TJvCustomPropertyStore(SubObj).LoadProperties;\r\n end\r\n else\r\n if SubObj is TCollection then\r\n ReadCollection(Path, TCollection(SubObj), ClearFirst)\r\n else\r\n ReadPersistent(Path, TPersistent(SubObj), True, ClearFirst, IgnoreProperties);\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomAppStorage.WriteProperty(const Path: string; const PersObj: TPersistent; const PropName: string; const\r\n Recursive: Boolean; const IgnoreProperties: TStrings = nil);\r\nvar\r\n TmpValue: Integer;\r\n SubObj: TObject;\r\n P: PPropInfo;\r\n\r\n function IsDefaultOrdProp(PropInfo: PPropInfo): Boolean;\r\n var\r\n Value: Longint;\r\n Default: LongInt;\r\n begin\r\n Value := GetOrdProp(PersObj, PropInfo);\r\n Default := PPropInfo(PropInfo)^.Default;\r\n Result := (Default <> LongInt($80000000)) and (Value = Default);\r\n end;\r\n\r\n function IsDefaultStrProp(PropInfo: PPropInfo): Boolean;\r\n var\r\n Value: WideString;\r\n begin\r\n Value := GetWideStrProp(PersObj, PropInfo);\r\n Result := Value = '';\r\n end;\r\n\r\n function IsDefaultInt64Prop(PropInfo: PPropInfo): Boolean;\r\n var\r\n Value: Int64;\r\n begin\r\n Value := GetInt64Prop(PersObj, PropInfo);\r\n Result := Value = 0;\r\n end;\r\n\r\n function IsDefaultFloatProp(PropInfo: PPropInfo): Boolean;\r\n var\r\n Value: Extended;\r\n begin\r\n Value := GetFloatProp(PersObj, PropInfo);\r\n Result := Value = 0;\r\n end;\r\n\r\nbegin\r\n if not Assigned(PersObj) then\r\n Exit;\r\n\r\n P := GetPropInfo(PersObj, PropName, tkAny);\r\n\r\n // If not storing the default values, then do not do anything if the property\r\n // is read only, write only or its \"stored\" function returns False.\r\n // Note: we do not add a call to IsDefaultPropertyValue here because it would\r\n // return True for any sub component which is not desirable as we want to\r\n // always store sub classes whether they are components or not.\r\n if not StorageOptions.StoreDefaultValues\r\n and (not Assigned(P.GetProc) or not Assigned(P.SetProc) or not IsStoredProp(PersObj, P))\r\n and (PropType(PersObj, PropName) <> tkClass) then // Classes can have data without having a stored property\r\n Exit;\r\n\r\n case PropType(PersObj, PropName) of\r\n {$IFDEF UNICODE} tkUString, {$ENDIF}\r\n tkLString, tkString:\r\n if StorageOptions.StoreDefaultValues or not IsDefaultStrProp(P) then\r\n WriteString(Path, GetStrProp(PersObj, PropName));\r\n tkWString:\r\n if StorageOptions.StoreDefaultValues or not IsDefaultStrProp(P) then\r\n WriteWideString(Path, {$IFDEF RTL240_UP}GetStrProp{$ELSE}GetWideStrProp{$ENDIF RTL240_UP}(PersObj, PropName));\r\n tkVariant:\r\n if StorageOptions.StoreDefaultValues or not IsDefaultStrProp(P) then\r\n WriteString(Path, VarToStr(GetVariantProp(PersObj, PropName)));\r\n tkEnumeration:\r\n begin\r\n if StorageOptions.StoreDefaultValues or not IsDefaultOrdProp(P) then\r\n begin\r\n TmpValue := GetOrdProp(PersObj, PropName);\r\n WriteEnumeration(Path, P.PropType^, TmpValue);\r\n end;\r\n end;\r\n tkSet:\r\n begin\r\n if StorageOptions.StoreDefaultValues or not IsDefaultOrdProp(P) then\r\n begin\r\n TmpValue := GetOrdProp(PersObj, PropName);\r\n WriteSet(Path, P.PropType^, TmpValue);\r\n end;\r\n end;\r\n tkChar, tkWChar, tkInteger:\r\n begin\r\n if StorageOptions.StoreDefaultValues or not IsDefaultOrdProp(P) then\r\n begin\r\n if StorageOptions.TypedIntegerAsString then\r\n begin\r\n TmpValue := GetOrdProp(PersObj, PropName);\r\n WriteEnumeration(Path, P.PropType^, TmpValue);\r\n end\r\n else\r\n begin\r\n WriteInteger(Path, GetOrdProp(PersObj, PropName));\r\n end;\r\n end;\r\n end;\r\n tkInt64:\r\n if StorageOptions.StoreDefaultValues or not IsDefaultInt64Prop(P) then\r\n WriteString(Path, IntToStr(GetInt64Prop(PersObj, PropName)));\r\n tkFloat:\r\n begin\r\n if StorageOptions.StoreDefaultValues or not IsDefaultFloatProp(P) then\r\n begin\r\n if (P <> nil) and (P.PropType <> nil) and (P.PropType^ = TypeInfo(TDateTime)) then\r\n WriteDateTime(Path, GetFloatProp(PersObj, PropName))\r\n else\r\n WriteFloat(Path, GetFloatProp(PersObj, PropName));\r\n end;\r\n end;\r\n tkClass:\r\n begin\r\n SubObj := GetObjectProp(PersObj, PropName);\r\n if (RegisteredAppStoragePropertyEngineList <> nil) and\r\n Recursive and\r\n RegisteredAppStoragePropertyEngineList.WriteProperty(Self, Path, PersObj, SubObj, Recursive, IgnoreProperties) then\r\n begin\r\n // Do nothing else, the handling is done in the WriteProperty procedure\r\n end\r\n else\r\n begin\r\n if SubObj is TStrings then\r\n begin\r\n if StorageOptions.StoreDefaultValues or (TStrings(SubObj).Count > 0) then\r\n WriteStringList(Path, TStrings(SubObj))\r\n end\r\n else\r\n begin\r\n if (SubObj is TPersistent) and Recursive then\r\n begin\r\n if SubObj is TJvCustomPropertyStore then\r\n begin\r\n TJvCustomPropertyStore(SubObj).AppStoragePath := Path;\r\n TJvCustomPropertyStore(SubObj).AppStorage := Self;\r\n TJvCustomPropertyStore(SubObj).StoreProperties;\r\n end\r\n else\r\n begin\r\n if SubObj is TCollection then\r\n WriteCollection(Path, TCollection(SubObj))\r\n else\r\n WritePersistent(Path, TPersistent(SubObj), Recursive, IgnoreProperties);\r\n end;\r\n end;\r\n end;\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomAppStorage.ReadPersistent(const Path: string; const PersObj: TPersistent;\r\n const Recursive, ClearFirst: Boolean; const IgnoreProperties: TStrings);\r\nvar\r\n Index: Integer;\r\n PropName: string;\r\n KeyName: string;\r\n PropPath: string;\r\n JvAppStorageHandler: IJvAppStorageHandler;\r\nbegin\r\n if not Assigned(PersObj) then\r\n Exit;\r\n if Supports(PersObj, IJvAppStorageHandler, JvAppStorageHandler) then\r\n JvAppStorageHandler.ReadFromAppStorage(Self, Path);\r\n if not Supports(PersObj, IJvAppStorageHandler) or\r\n Supports(PersObj, IJvAppStoragePublishedProps) then\r\n for Index := 0 to GetPropCount(PersObj) - 1 do\r\n begin\r\n PropName := GetPropName(PersObj, Index);\r\n KeyName := TranslatePropertyName(PersObj, PropName, False);\r\n PropPath := ConcatPaths([Path, KeyName]);\r\n if (IgnoreProperties = nil) or (IgnoreProperties.IndexOf(PropName) = -1) then\r\n ReadProperty(PropPath, PersObj, PropName, Recursive, ClearFirst, IgnoreProperties);\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomAppStorage.WritePersistent(const Path: string; const PersObj: TPersistent; const Recursive: Boolean = True;\r\n const IgnoreProperties: TStrings = nil);\r\nvar\r\n Index: Integer;\r\n PropName: string;\r\n KeyName: string;\r\n PropPath: string;\r\n JvAppStorageHandler: IJvAppStorageHandler;\r\nbegin\r\n if not Assigned(PersObj) then\r\n Exit;\r\n if Supports(PersObj, IJvAppStorageHandler, JvAppStorageHandler) then\r\n JvAppStorageHandler.WriteToAppStorage(Self, Path);\r\n if not Supports(PersObj, IJvAppStorageHandler) or Supports(PersObj, IJvAppStoragePublishedProps) then\r\n for Index := 0 to GetPropCount(PersObj) - 1 do\r\n begin\r\n PropName := GetPropName(PersObj, Index);\r\n KeyName := TranslatePropertyName(PersObj, PropName, False);\r\n PropPath := ConcatPaths([Path, KeyName]);\r\n if (IgnoreProperties = nil) or (IgnoreProperties.IndexOf(PropName) = -1) then\r\n WriteProperty(PropPath, PersObj, PropName, Recursive, IgnoreProperties);\r\n end;\r\nend;\r\n\r\nfunction TJvCustomAppStorage.GetCharName(Ch: Char): string;\r\nbegin\r\n if CharInSet(Ch, ['!'..'z']) then\r\n Result := 'Char_' + Ch\r\n else\r\n Result := 'Char#' + IntToStr(Ord(Ch));\r\nend;\r\n\r\nfunction TJvCustomAppStorage.GetIntName(Value: Integer): string;\r\nbegin\r\n Result := 'Int_' + IntToStr(Value);\r\nend;\r\n\r\nfunction TJvCustomAppStorage.EncryptPropertyValue(Value: string): string;\r\nbegin\r\n if Assigned(FOnEncryptPropertyValue) and IsPropertyValueCryptEnabled then\r\n begin\r\n FOnEncryptPropertyValue(Value);\r\n Value := string(MimeEncodeString(AnsiString(Value)));\r\n end;\r\n Result := Value;\r\nend;\r\n\r\nfunction TJvCustomAppStorage.DecryptPropertyValue(Value: string): string;\r\nbegin\r\n if Assigned(FOnDecryptPropertyValue) and IsPropertyValueCryptEnabled then\r\n begin\r\n Value := string(MimeDecodeString(AnsiString(Value)));\r\n FOnDecryptPropertyValue(Value);\r\n end;\r\n Result := Value;\r\nend;\r\n\r\nfunction TJvCustomAppStorage.TranslatePropertyName(Instance: TPersistent; const AName: string; const Reading: Boolean):\r\n string;\r\nbegin\r\n Result := AName;\r\n if Instance is TJvCustomPropertyStore then\r\n Result := TJvCustomPropertyStore(Instance).TranslatePropertyName(Result)\r\n else\r\n DoTranslatePropertyName(Instance, Result, Reading);\r\nend;\r\n\r\nprocedure TJvCustomAppStorage.SetReadOnly(Value: Boolean);\r\nbegin\r\n FReadOnly := Value;\r\nend;\r\n\r\nfunction TJvCustomAppStorage.GetReadOnly: Boolean;\r\nbegin\r\n if csDesigning in ComponentState then\r\n Result := FReadOnly\r\n else\r\n Result := FReadOnly or GetPhysicalReadOnly;\r\nend;\r\n\r\nfunction TJvCustomAppStorage.GetPhysicalReadOnly: Boolean;\r\nbegin\r\n Result := False;\r\nend;\r\n\r\nprocedure TJvCustomAppStorage.GetStoredValues(const Path: string;\r\n const Strings: TStrings; const Options: TJvAppStorageEnumOptions);\r\nvar\r\n SearchPath: string;\r\n I: Integer;\r\n OptimizedSearchPath: string;\r\nbegin\r\n Strings.BeginUpdate;\r\n try\r\n Strings.Clear;\r\n SearchPath := OptimizePaths([Path]);\r\n\r\n if aeoReportRelative in Options then\r\n begin\r\n InternalGetStoredValues('', SearchPath, Strings, Options);\r\n end\r\n else\r\n begin\r\n OptimizedSearchPath := OptimizePaths([Self.Path, SearchPath]);\r\n InternalGetStoredValues(OptimizedSearchPath +\r\n PathDelim, SearchPath, Strings, Options);\r\n\r\n // Mantis 3803: Only remove the path if ReportRelative was not asked.\r\n // If not, then with \\F1\\R1 and \\F1\\F1 we would only return the values\r\n // in \\F1\\R1 in \"relative mode\" which is not correct\r\n I := Strings.IndexOf(OptimizedSearchPath);\r\n if I > -1 then\r\n Strings.Delete(I);\r\n end;\r\n finally\r\n Strings.EndUpdate;\r\n end;\r\nend;\r\n\r\n{ Enables the Cryption of Property-Values (Only String-Values) }\r\n\r\nprocedure TJvCustomAppStorage.EnablePropertyValueCrypt;\r\nbegin\r\n Inc(FCryptEnabledStatus);\r\nend;\r\n\r\n{ Disables the Cryption of Property-Values (Only String-Values) }\r\n\r\nprocedure TJvCustomAppStorage.DisablePropertyValueCrypt;\r\nbegin\r\n Dec(FCryptEnabledStatus);\r\nend;\r\n\r\n{ Returns the current state if Property-Value Cryption is enabled }\r\n\r\nfunction TJvCustomAppStorage.IsPropertyValueCryptEnabled: Boolean;\r\nbegin\r\n Result := (FCryptEnabledStatus > 0);\r\nend;\r\n\r\nfunction TJvCustomAppStorage.ItemNameIndexPath(const ItemName: string; const Index: Integer): string;\r\nbegin\r\n if StorageOptions.UseOldItemNameFormat then\r\n Result := ItemName + IntToStr(Index)\r\n else\r\n Result := ItemName + '['+IntToStr(Index)+']';\r\nend;\r\n\r\nprocedure TJvCustomAppStorage.Loaded;\r\nbegin\r\n inherited Loaded;\r\n if not IsUpdating then\r\n Reload;\r\nend;\r\n\r\nprocedure TJvCustomAppStorage.BeginUpdate;\r\nvar i : Integer;\r\nbegin\r\n GetFormatSettings;\r\n ReloadIfNeeded;\r\n Inc(FUpdateCount);\r\n for i := 0 to SubStorages.Count - 1 do\r\n if Assigned(SubStorages[i].AppStorage) then\r\n SubStorages[i].AppStorage.BeginUpdate;\r\nend;\r\n\r\nprocedure TJvCustomAppStorage.CheckDeletePathByVersion(const Path: string;\r\n VersionNumber: Integer; DeleteIfNotEqual: Boolean = False;\r\n WriteVersionNumber: Boolean = True; const VersionName: string = 'Version');\r\nvar\r\n TargetStore: TJvCustomAppStorage;\r\n TargetPath: string;\r\n OldVersionNumber: Integer;\r\nbegin\r\n ResolvePath(Path, TargetStore, TargetPath);\r\n if not TargetStore.ReadOnly and (Versionname <> '') then\r\n begin\r\n TargetStore.BeginUpdate;\r\n try\r\n OldVersionNumber := Targetstore.ReadInteger(TargetStore.ConcatPaths([Path, VersionName]));\r\n if DeleteIfNotEqual and (OldVersionNumber <> VersionNumber) then\r\n Targetstore.DeleteSubTree(Path)\r\n else\r\n if (OldVersionNumber < VersionNumber) then\r\n Targetstore.DeleteSubTree(Path);\r\n if (OldVersionNumber <> VersionNumber) and WriteVersionNumber then\r\n TargetStore.WriteInteger(TargetStore.ConcatPaths([Path, VersionName]), VersionNumber);\r\n finally\r\n TargetStore.EndUpdate;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJvCustomAppStorage.DecodeStrToDateTime(Value: string): TDateTime;\r\nbegin\r\n if StorageOptions.UseTranslateStringEngineDateTimeFormats then\r\n try\r\n Result := StrToDateTime(Value{$IFDEF COMPILER7_UP}, GetFormatSettings{$ENDIF COMPILER7_UP});\r\n except\r\n on E: EConvertError do\r\n Result := StrToDateTime(Value);\r\n end\r\n else\r\n Result := StrToDateTime(Value);\r\nend;\r\n\r\nfunction TJvCustomAppStorage.EncodeDateTimeToStr(Value: TDateTime): string;\r\nbegin\r\n if StorageOptions.UseTranslateStringEngineDateTimeFormats then\r\n Result := DateTimeToStr(Value{$IFDEF COMPILER7_UP}, GetFormatSettings{$ENDIF COMPILER7_UP})\r\n else\r\n Result := DateTimeToStr(Value);\r\nend;\r\n\r\nprocedure TJvCustomAppStorage.EndUpdate;\r\nvar i : Integer;\r\nbegin\r\n for i := 0 to SubStorages.Count - 1 do\r\n if Assigned(SubStorages[i].AppStorage) then\r\n SubStorages[i].AppStorage.EndUpdate;\r\n Dec(FUpdateCount);\r\n FlushIfNeeded;\r\n if FUpdateCount < 0 then\r\n FUpdateCount := 0;\r\nend;\r\n\r\nfunction TJvCustomAppStorage.GetActiveTranslateStringEngine: TJvTranslateString;\r\nbegin\r\n if Assigned(TranslateStringEngine) then\r\n Result := TranslateStringEngine\r\n else\r\n Result := FInternalTranslateStringEngine;\r\nend;\r\n\r\nfunction TJvCustomAppStorage.GetFormatSettings: TFormatSettings;\r\n{$IFDEF COMPILER7_UP}\r\nvar \r\n Atse: TJvTranslateString;\r\n{$ENDIF COMPILER7_UP}\r\nbegin\r\n {$IFDEF COMPILER7_UP}\r\n if Not IsUpdating then\r\n begin\r\n {$IFDEF RTL220_UP}\r\n CachedFormatSettings := TFormatSettings.Create;\r\n {$ELSE ~RTL220_UP}\r\n GetLocaleFormatSettings(LOCALE_SYSTEM_DEFAULT, CachedFormatSettings);\r\n {$ENDIF ~RTL220_UP}\r\n atse := ActiveTranslateStringEngine;\r\n if Assigned(atse) then\r\n begin\r\n if (atse.DateFormat <> '') then\r\n begin\r\n CachedFormatSettings.ShortDateFormat := atse.DateFormat;\r\n CachedFormatSettings.LongDateFormat := atse.DateFormat;\r\n end;\r\n CachedFormatSettings.DateSeparator := atse.DateSeparator;\r\n if (atse.TimeFormat <> '') then\r\n begin\r\n CachedFormatSettings.ShortTimeFormat := atse.TimeFormat;\r\n CachedFormatSettings.LongTimeFormat := atse.TimeFormat;\r\n end;\r\n CachedFormatSettings.TimeSeparator := atse.TimeSeparator;\r\n end;\r\n end;\r\n {$ENDIF COMPILER7_UP}\r\n Result := CachedFormatSettings;\r\nend;\r\n\r\nfunction TJvCustomAppStorage.GetUpdating: Boolean;\r\nbegin\r\n Result := FUpdateCount <> 0;\r\nend;\r\n\r\nfunction TJvCustomAppStorage.ReadListItemCount(const Path: string; const ItemName: string = cItem): Integer;\r\nbegin\r\n Result := ReadInteger(ConcatPaths([Path, cCount]), 0);\r\nend;\r\n\r\nprocedure TJvCustomAppStorage.Synchronize(AMethod: TSynchronizeMethod;\r\n AIdentifier: String);\r\nvar\r\n JclMutex: TJclMutex;\r\nbegin\r\n if Assigned(AMethod) then\r\n begin\r\n JclMutex := TJclMutex.Create(nil, False,\r\n string(B64Encode(AnsiString(RsJvAppStorageSynchronizeProcedureName + AIdentifier))));\r\n try\r\n if JclMutex.WaitForever = wrSignaled then\r\n try\r\n AMethod;\r\n finally\r\n JclMutex.Release;\r\n end\r\n else\r\n raise Exception.CreateResFmt(@RsJvAppStorageSynchronizeTimeout, [RsJvAppStorageSynchronizeProcedureName+AIdentifier]);\r\n finally\r\n FreeAndNil(JclMutex);\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomAppStorage.WriteListItemCount(const Path: string; const ItemCount: Integer; const ItemName: string =\r\n cItem);\r\nbegin\r\n WriteInteger(ConcatPaths([Path, cCount]), ItemCount);\r\nend;\r\n\r\nprocedure TJvCustomAppStorage.SetTranslateStringEngine(const Value: TJvTranslateString);\r\nbegin\r\n ReplaceComponentReference(Self, Value, TComponent(FTranslateStringEngine));\r\nend;\r\n\r\nfunction TJvCustomAppStorage.ReadWideString(const Path: string; const Default: WideString = ''): WideString;\r\nbegin\r\n Result := DoReadWideString(Path,Default);\r\nend;\r\n\r\nprocedure TJvCustomAppStorage.SetCurrentInstanceCreateEvent(const Value:\r\n TJvAppStorageObjectListItemCreateEvent);\r\nbegin\r\n FCurrentInstanceCreateEvent := Value;\r\nend;\r\n\r\nprocedure TJvCustomAppStorage.WriteWideString(const Path: string;\r\n const Value: WideString);\r\nbegin\r\n DoWriteWideString(Path,Value);\r\nend;\r\n\r\n//=== { TJvAppStorage } ======================================================\r\n\r\nfunction TJvAppStorage.IsFolderInt(const Path: string; ListIsValue: Boolean): Boolean;\r\nbegin\r\n raise EJVCLAppStorageError.CreateRes(@RsEInvalidPath);\r\nend;\r\n\r\nfunction TJvAppStorage.PathExistsInt(const Path: string): Boolean;\r\nbegin\r\n raise EJVCLAppStorageError.CreateRes(@RsEInvalidPath);\r\nend;\r\n\r\nfunction TJvAppStorage.ValueStoredInt(const Path: string): Boolean;\r\nbegin\r\n raise EJVCLAppStorageError.CreateRes(@RsEInvalidPath);\r\nend;\r\n\r\nprocedure TJvAppStorage.DeleteValueInt(const Path: string);\r\nbegin\r\n raise EJVCLAppStorageError.CreateRes(@RsEInvalidPath);\r\nend;\r\n\r\nprocedure TJvAppStorage.DeleteSubTreeInt(const Path: string);\r\nbegin\r\n raise EJVCLAppStorageError.CreateRes(@RsEInvalidPath);\r\nend;\r\n\r\nfunction TJvAppStorage.ReadIntegerInt(const Path: string; Default: Integer): Integer;\r\nbegin\r\n raise EJVCLAppStorageError.CreateRes(@RsEInvalidPath);\r\nend;\r\n\r\nprocedure TJvAppStorage.WriteIntegerInt(const Path: string; Value: Integer);\r\nbegin\r\n raise EJVCLAppStorageError.CreateRes(@RsEInvalidPath);\r\nend;\r\n\r\nfunction TJvAppStorage.ReadFloatInt(const Path: string; Default: Extended): Extended;\r\nbegin\r\n raise EJVCLAppStorageError.CreateRes(@RsEInvalidPath);\r\nend;\r\n\r\nprocedure TJvAppStorage.WriteFloatInt(const Path: string; Value: Extended);\r\nbegin\r\n raise EJVCLAppStorageError.CreateRes(@RsEInvalidPath);\r\nend;\r\n\r\nfunction TJvAppStorage.ReadStringInt(const Path: string; const Default: string): string;\r\nbegin\r\n raise EJVCLAppStorageError.CreateRes(@RsEInvalidPath);\r\nend;\r\n\r\nprocedure TJvAppStorage.WriteStringInt(const Path: string; const Value: string);\r\nbegin\r\n raise EJVCLAppStorageError.CreateRes(@RsEInvalidPath);\r\nend;\r\n\r\nfunction TJvAppStorage.ReadBinaryInt(const Path: string; Buf: TJvBytes; BufSize: Integer): Integer;\r\nbegin\r\n raise EJVCLAppStorageError.CreateRes(@RsEInvalidPath);\r\nend;\r\n\r\nprocedure TJvAppStorage.WriteBinaryInt(const Path: string; const Buf: TJvBytes; BufSize: Integer);\r\nbegin\r\n raise EJVCLAppStorageError.CreateRes(@RsEInvalidPath);\r\nend;\r\n\r\nfunction TJvAppStorage.ReadDateTimeInt(const Path: string; Default: TDateTime): TDateTime;\r\nbegin\r\n raise EJVCLAppStorageError.CreateRes(@RsEInvalidPath);\r\nend;\r\n\r\nprocedure TJvAppStorage.WriteDateTimeInt(const Path: string; Value: TDateTime);\r\nbegin\r\n raise EJVCLAppStorageError.CreateRes(@RsEInvalidPath);\r\nend;\r\n\r\nfunction TJvAppStorage.ReadBooleanInt(const Path: string; Default: Boolean): Boolean;\r\nbegin\r\n raise EJVCLAppStorageError.CreateRes(@RsEInvalidPath);\r\nend;\r\n\r\nprocedure TJvAppStorage.WriteBooleanInt(const Path: string; Value: Boolean);\r\nbegin\r\n raise EJVCLAppStorageError.CreateRes(@RsEInvalidPath);\r\nend;\r\n\r\nprocedure TJvAppStorage.ReadEnumerationInt(const Path: string; TypeInfo: PTypeInfo; const Default; out Value);\r\nbegin\r\n raise EJVCLAppStorageError.CreateRes(@RsEInvalidPath);\r\nend;\r\n\r\nprocedure TJvAppStorage.WriteEnumerationInt(const Path: string; TypeInfo: PTypeInfo; const Value);\r\nbegin\r\n raise EJVCLAppStorageError.CreateRes(@RsEInvalidPath);\r\nend;\r\n\r\nprocedure TJvAppStorage.ReadSetInt(const Path: string; ATypeInfo: PTypeInfo; const Default; out Value);\r\nbegin\r\n raise EJVCLAppStorageError.CreateRes(@RsEInvalidPath);\r\nend;\r\n\r\nprocedure TJvAppStorage.WriteSetInt(const Path: string; ATypeInfo: PTypeInfo; const Value);\r\nbegin\r\n raise EJVCLAppStorageError.CreateRes(@RsEInvalidPath);\r\nend;\r\n\r\n//=== { TJvAppSubStorages } ==================================================\r\n\r\nconstructor TJvAppSubStorages.Create(AOwner: TJvCustomAppStorage);\r\nbegin\r\n inherited Create(AOwner, TJvAppSubStorage);\r\nend;\r\n\r\nfunction TJvAppSubStorages.GetRootStorage: TJvCustomAppStorage;\r\nbegin\r\n Result := TJvCustomAppStorage(GetOwner);\r\nend;\r\n\r\nfunction TJvAppSubStorages.GetItem(I: Integer): TJvAppSubStorage;\r\nbegin\r\n Result := TJvAppSubStorage(inherited GetItem(I));\r\nend;\r\n\r\nprocedure TJvAppSubStorages.SetItem(I: Integer; Value: TJvAppSubStorage);\r\nbegin\r\n inherited SetItem(I, Value);\r\nend;\r\n\r\nprocedure TJvAppSubStorages.RootOptionsChanged;\r\nbegin\r\nend;\r\n\r\nfunction TJvAppSubStorages.CheckUniqueBase(const APath: string; IgnoreIndex: Integer): Boolean;\r\nbegin\r\n Result := MatchFor(OptimizePaths([APath]) + cSubStorePath, IgnoreIndex) = nil;\r\nend;\r\n\r\nfunction TJvAppSubStorages.MatchFor(APath: string; IgnoreIndex: Integer): TJvAppSubStorage;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := nil;\r\n APath := OptimizePaths([APath]);\r\n // APath is now a valid path, stripped from it's leading/trailing backslashes\r\n for I := 0 to Count - 1 do\r\n if I <> IgnoreIndex then\r\n if AnsiStartsText(Items[I].RootPath, APath) then\r\n // Possible match. Check if next char is a \\\r\n if APath[Length(Items[I].RootPath) + 1] = PathDelim then\r\n { Next char in APath is a backslash, so we have a valid match. Check with any previous\r\n to see if it is better than that one. }\r\n if (Result = nil) or (Length(Result.RootPath) < Length(Items[I].RootPath)) then\r\n Result := Items[I]; // no previous match or new match is close to what we searched for\r\nend;\r\n\r\nprocedure TJvAppSubStorages.Add(RootPath: string; AppStorage: TJvCustomAppStorage);\r\nvar\r\n Tmp: TJvAppSubStorage;\r\nbegin\r\n Tmp := TJvAppSubStorage.Create(Self);\r\n try\r\n Tmp.RootPath := RootPath;\r\n Tmp.AppStorage := AppStorage;\r\n except\r\n FreeAndNil(Tmp);\r\n raise;\r\n end;\r\nend;\r\n\r\nprocedure TJvAppSubStorages.Delete(Index: Integer);\r\nbegin\r\n inherited Delete(Index);\r\nend;\r\n\r\nprocedure TJvAppSubStorages.Delete(RootPath: string; const IncludeSubPaths: Boolean);\r\nvar\r\n I: Integer;\r\n SubPath: string;\r\nbegin\r\n RootPath := OptimizePaths([RootPath]);\r\n if RootPath <> '' then\r\n begin\r\n SubPath := RootPath + PathDelim;\r\n I := Count - 1;\r\n while I >= 0 do\r\n begin\r\n if AnsiSameText(RootPath, Items[I].RootPath) or\r\n (IncludeSubPaths and (AnsiStartsText(SubPath, Items[I].RootPath))) then\r\n Delete(I);\r\n Dec(I);\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvAppSubStorages.Delete(AppStorage: TJvCustomAppStorage);\r\nvar\r\n I: Integer;\r\nbegin\r\n I := Count - 1;\r\n while I >= 0 do\r\n begin\r\n if Items[I].AppStorage = AppStorage then\r\n Delete(I);\r\n Dec(I);\r\n end;\r\nend;\r\n\r\n//=== { TJvAppSubStorage } ===================================================\r\n\r\nfunction TJvAppSubStorage.GetOwnerStore: TJvCustomAppStorage;\r\nbegin\r\n Result := TJvAppSubStorages(Collection).RootStorage;\r\nend;\r\n\r\nfunction TJvAppSubStorage.GetDisplayName: string;\r\nbegin\r\n if (RootPath <> '') and (AppStorage <> nil) then\r\n Result := PathDelim + RootPath + '=' + AppStorage.Name\r\n else\r\n Result := inherited GetDisplayName;\r\nend;\r\n\r\nprocedure TJvAppSubStorage.SetRootPath(Value: string);\r\nbegin\r\n Value := OptimizePaths([Value]);\r\n if Value <> RootPath then\r\n if TJvAppSubStorages(Collection).CheckUniqueBase(Value, Index) then\r\n FRootPath := Value\r\n else\r\n raise EJVCLAppStorageError.CreateResFmt(@RsENotAUniqueRootPath, [Value]);\r\nend;\r\n\r\nprocedure TJvAppSubStorage.SetAppStorage(Value: TJvCustomAppStorage);\r\nbegin\r\n if Value <> AppStorage then\r\n begin\r\n if (Value <> nil) and (Value.HasSubStorage(OwnerStore) or (Value = OwnerStore)) then\r\n raise EJVCLAppStorageError.CreateRes(@RsECircularReferenceOfStorages);\r\n ReplaceComponentReference(OwnerStore, Value, TComponent(FAppstorage));\r\n end;\r\nend;\r\n\r\n//=== { TJvAppStorageFileName } ==============================================\r\n\r\n{procedure TJvAppStorageFileName.SetLocation(Value: TFileLocation);\r\nbegin\r\n if Location <> Value then\r\n begin\r\n FLocation := Value;\r\n DoChange;\r\n end;\r\nend;\r\n\r\nprocedure TJvAppStorageFileName.SetFileName(Value: TFileName);\r\nbegin\r\n if FileName <> Value then\r\n begin\r\n FFileName := Value;\r\n DoChange;\r\n end;\r\nend;\r\n\r\nprocedure TJvAppStorageFileName.DoChange;\r\nbegin\r\n if Assigned(FOnChange) then\r\n OnChange(Self);\r\nend;\r\n\r\nfunction TJvAppStorageFileName.GetFileName: TFileName;\r\nvar\r\n NameOnly: string;\r\n RelPathName: string;\r\nbegin\r\n if FileName = '' then\r\n Result := ''\r\n else\r\n begin\r\n NameOnly := ExtractFileName(FileName);\r\n if PathIsAbsolute(FileName) then\r\n RelPathName := NameOnly\r\n else\r\n RelPathName := FileName;\r\n case Location of\r\n flCustom:\r\n Result := FileName;\r\n flTemp:\r\n Result := PathAddSeparator(GetWindowsTempFolder) + NameOnly;\r\n flWindows:\r\n Result := PathAddSeparator(GetWindowsFolder) + NameOnly;\r\n flExeFile:\r\n Result := ExtractFilePath(Application.ExeName) + NameOnly;\r\n flUserFolder:\r\n Result := PathAddSeparator(GetAppdataFolder) + RelPathName;\r\n end;\r\n end;\r\nend;\r\n\r\nconstructor TJvAppStorageFileName.Create(ADefaultExtension: string);\r\nbegin\r\n inherited Create;\r\n FLocation := flExeFile;\r\n FFileName := ChangeFileExt(ExtractFileName(Application.ExeName), '.' + ADefaultExtension);\r\nend; }\r\n\r\n//=== { TJvCustomAppMemoryFileStorage } ======================================\r\n\r\nconstructor TJvCustomAppMemoryFileStorage.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FLocation := flExeFile;\r\n FPhysicalReadOnly := False;\r\n FFileLoaded := False;\r\n FFileAge := -1;\r\nend;\r\n\r\nfunction TJvCustomAppMemoryFileStorage.CalculateFullFileName: string;\r\nvar\r\n NameOnly: string;\r\n RelPathName: string;\r\n TransFileName: string;\r\nbegin\r\n if (FileName = '') and (Location <> flCustom) then\r\n begin\r\n Result := '';\r\n end\r\n else\r\n begin\r\n TransFileName := ActiveTranslateStringEngine.TranslateString(FileName);\r\n NameOnly := ExtractFileName(TransFileName);\r\n if PathIsAbsolute(TransFileName) then\r\n RelPathName := NameOnly\r\n else\r\n RelPathName := TransFileName;\r\n case Location of\r\n flCustom:\r\n Result := DoGetFileName;\r\n flExeFile:\r\n Result := PathAddSeparator(ExtractFilePath(ParamStr(0))) + NameOnly;\r\n {$IFDEF MSWINDOWS}\r\n flTemp:\r\n Result := PathAddSeparator(GetWindowsTempFolder) + NameOnly;\r\n flWindows:\r\n Result := PathAddSeparator(GetWindowsFolder) + NameOnly;\r\n flUserFolder:\r\n Result := PathAddSeparator(GetAppdataFolder) + RelPathName;\r\n {$ENDIF MSWINDOWS}\r\n {$IFDEF UNIX}\r\n flTemp:\r\n Result := PathAddSeparator(PathGetTempPath) + NameOnly;\r\n flUserFolder:\r\n Result := PathAddSeparator(GetEnvironmentVariable('HOME')) + RelPathName;\r\n {$ENDIF UNIX}\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomAppMemoryFileStorage.RecalculateFullFileName;\r\nbegin\r\n FFullFileName := CalculateFullFileName;\r\n FPhysicalReadOnly := FileExists(FullFileName) and FileIsReadOnly(FullFileName);\r\nend;\r\n\r\nfunction TJvCustomAppMemoryFileStorage.ReloadNeeded: Boolean;\r\n{$IFDEF DELPHI2005_UP}\r\nvar t : TDateTime;\r\n{$ENDIF}\r\nbegin\r\n Result := (not FFileLoaded or AutoReload) and not IsUpdating;\r\n {$IFDEF DELPHI2005_UP}\r\n if Result and FileAge(FullFileName, t) then\r\n Result := FFileAge <> t;\r\n {$ELSE}\r\n if Result then\r\n Result := FFileAge <> FileAge(FullFileName);;\r\n {$ENDIF}\r\nend;\r\n\r\nfunction TJvCustomAppMemoryFileStorage.GetPhysicalReadOnly: Boolean;\r\nbegin\r\n Result := FPhysicalReadOnly;\r\nend;\r\n\r\nfunction TJvCustomAppMemoryFileStorage.DoGetFileName: TFileName;\r\nbegin\r\n Result := ActiveTranslateStringEngine.TranslateString(FileName);\r\n if Assigned(FOnGetFileName) then\r\n FOnGetFileName(Self, Result);\r\nend;\r\n\r\nprocedure TJvCustomAppMemoryFileStorage.SetFileNameInternal(const Value: TFileName);\r\nbegin\r\n // Mantis 3680: only add an extension if there is not already one.\r\n if (Length(ExtractFileExt(Value)) = 0) then\r\n FFileName := PathAddExtension(Value, DefaultExtension)\r\n else\r\n FFileName := Value;\r\n RecalculateFullFileName;\r\nend;\r\n\r\nprocedure TJvCustomAppMemoryFileStorage.SetFileName(const Value: TFileName);\r\nbegin\r\n if Value <> FileName then\r\n begin\r\n if not (csLoading in ComponentState) and not IsUpdating then\r\n if FullFileName <> CalculateFullFileName then\r\n Flush;\r\n\r\n SetFileNameInternal(Value);\r\n\r\n if not (csLoading in ComponentState) and not IsUpdating then\r\n Reload;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomAppMemoryFileStorage.SetOnGetFileName(Value: TJvAppStorageGetFileNameEvent);\r\nbegin\r\n if not (csLoading in ComponentState) and not IsUpdating then\r\n Flush;\r\n FOnGetFileName := Value;\r\n RecalculateFullFileName;\r\n if not (csLoading in ComponentState) and not IsUpdating then\r\n Reload;\r\nend;\r\n\r\nprocedure TJvCustomAppMemoryFileStorage.SetLocation(const Value: TFileLocation);\r\nbegin\r\n if FLocation <> Value then\r\n begin\r\n if not (csLoading in ComponentState) and not IsUpdating then\r\n if FullFileName <> CalculateFullFileName then\r\n Flush;\r\n FLocation := Value;\r\n RecalculateFullFileName;\r\n if not (csLoading in ComponentState) and not IsUpdating then\r\n Reload;\r\n end;\r\nend;\r\n\r\nfunction TJvCustomAppMemoryFileStorage.DefaultExtension: string;\r\nbegin\r\n Result := '';\r\nend;\r\n\r\n//=== { TJvCustomAppMemoryFileStorage } ===============================================\r\n\r\nprocedure TJvCustomAppMemoryFileStorage.Flush;\r\nbegin\r\n if (FullFileName <> '') and not ReadOnly and not (csDesigning in ComponentState) then\r\n if SynchronizeFlushReload then\r\n Synchronize(FlushToFile, FullFileName)\r\n else\r\n FlushToFile;\r\nend;\r\n\r\nprocedure TJvCustomAppMemoryFileStorage.FlushToFile;\r\nvar\r\n Path: string;\r\n BackupFileName : string;\r\n SaveFullFileName : string;\r\n SaveFileName : string;\r\nbegin\r\n if (FullFileName <> '') and not ReadOnly and not (csDesigning in ComponentState) then\r\n begin\r\n try\r\n Path := ExtractFilePath(FullFileName);\r\n if Path <> '' then\r\n ForceDirectories(Path);\r\n BackupFileName := GetBackupFileName(FullFileName);\r\n if (StorageOptions.BackupType = afsbtCreateBefore) and FileExists(FullFileName)then\r\n FileMove(FullFileName, BackupFileName, True);\r\n if (StorageOptions.BackupType = afsbtRenameAfter) then\r\n begin\r\n SaveFileName := FileName;\r\n SaveFullFileName := FullFileName;\r\n SetFileNameInternal(FileName+'.tmp');\r\n end;\r\n\r\n FlushInternal;\r\n\r\n if (StorageOptions.BackupType = afsbtRenameAfter) then\r\n begin\r\n FileMove(SaveFullFileName, BackupFileName, True);\r\n FileMove(FullFileName, SaveFullFileName, True);\r\n SetFileNameInternal(SaveFileName)\r\n end;\r\n if (StorageOptions.BackupHistoryCount > 0) and (StorageOptions.BackupHistoryType <> afsbhtNone) then\r\n case StorageOptions.BackupHistoryType of\r\n //afsbhtNone,\r\n afsbhtAllways : FileHistory(FullFileName, Path, StorageOptions.BackupHistoryCount, Now);\r\n afsbht1Minute : FileHistory(FullFileName, Path, StorageOptions.BackupHistoryCount, Now-(1/24/60));\r\n afsbht15Minute : FileHistory(FullFileName, Path, StorageOptions.BackupHistoryCount, Now-(1/24/4));\r\n afsbht1Hour : FileHistory(FullFileName, Path, StorageOptions.BackupHistoryCount, Now-(1/24));\r\n afsbht4Hour : FileHistory(FullFileName, Path, StorageOptions.BackupHistoryCount, Now-(1/8));\r\n afsbht12Hour : FileHistory(FullFileName, Path, StorageOptions.BackupHistoryCount, Now-(1/2));\r\n afsbht1Day : FileHistory(FullFileName, Path, StorageOptions.BackupHistoryCount, Now-1);\r\n afsbht3Day : FileHistory(FullFileName, Path, StorageOptions.BackupHistoryCount, Now-3);\r\n afsbht1Week : FileHistory(FullFileName, Path, StorageOptions.BackupHistoryCount, Now-7);\r\n afsbht1Month : FileHistory(FullFileName, Path, StorageOptions.BackupHistoryCount, Now-30);\r\n end;\r\n\r\n if (StorageOptions.BackupType <> afsbtNone) and not StorageOptions.BackupKeepFileAfterFlush then\r\n DeleteFile(BackupFileName);\r\n except\r\n on E: Exception do\r\n DoError(E.Message);\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJvCustomAppMemoryFileStorage.GetStorageOptions: TJvAppFileStorageOptions;\r\nbegin\r\n Result := TJvAppFileStorageOptions(inherited StorageOptions);\r\nend;\r\n\r\nclass function TJvCustomAppMemoryFileStorage.GetStorageOptionsClass: TJvAppStorageOptionsClass;\r\nbegin\r\n Result := TJvAppFileStorageOptions;\r\nend;\r\n\r\nprocedure TJvCustomAppMemoryFileStorage.Reload;\r\nbegin\r\n if not IsUpdating and not (csDesigning in ComponentState) then\r\n begin\r\n FFileLoaded := True;\r\n FPhysicalReadOnly := FileExists(FullFileName) and FileIsReadOnly(FullFileName);\r\n {$IFDEF DELPHI2005_UP}\r\n FileAge(FullFileName, FFileAge);\r\n {$ELSE}\r\n FFileAge:= FileAge(FullFileName);\r\n {$ENDIF}\r\n\r\n inherited Reload;\r\n if FileExists(FullFileName) then\r\n if SynchronizeFlushReload then\r\n Synchronize(ReloadInternal, FullFileName)\r\n else\r\n ReloadInternal\r\n else // file may have disappeared. If so, clear the internal data\r\n ClearInternal;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomAppMemoryFileStorage.SetStorageOptions(const Value: TJvAppFileStorageOptions);\r\nbegin\r\n (Inherited StorageOptions).Assign(Value);\r\nend;\r\n\r\n//=== { TJvAppStoragePropertyBaseEngine } ====================================\r\n\r\nconstructor TJvAppStoragePropertyBaseEngine.Create;\r\nbegin\r\n inherited Create;\r\n // virtual constructor\r\nend;\r\n\r\nfunction TJvAppStoragePropertyBaseEngine.Supports(AObject: TObject; AProperty: TObject): Boolean;\r\nbegin\r\n Result := False;\r\nend;\r\n\r\nprocedure TJvAppStoragePropertyBaseEngine.ReadProperty(AStorage: TJvCustomAppStorage; const APath: string; AObject: TObject;\r\n AProperty: TObject; const Recursive, ClearFirst: Boolean; const IgnoreProperties: TStrings = nil);\r\nbegin\r\nend;\r\n\r\nprocedure TJvAppStoragePropertyBaseEngine.WriteProperty(AStorage: TJvCustomAppStorage; const APath: string; AObject: TObject;\r\n AProperty: TObject; const Recursive: Boolean; const IgnoreProperties: TStrings = nil);\r\nbegin\r\nend;\r\n\r\n//=== { TJvAppStoragePropertyEngineList } ====================================\r\n\r\ndestructor TJvAppStoragePropertyEngineList.Destroy;\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := Count - 1 downto 0 do\r\n begin\r\n TJvAppStoragePropertyBaseEngine(Items[I]).Free;\r\n Delete(I);\r\n end;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvAppStoragePropertyEngineList.RegisterEngine(AEngineClass: TJvAppStoragePropertyBaseEngineClass);\r\nbegin\r\n Add(AEngineClass.Create);\r\nend;\r\n\r\nprocedure TJvAppStoragePropertyEngineList.UnregisterEngine(AEngineClass: TJvAppStoragePropertyBaseEngineClass);\r\nvar\r\n I: Integer;\r\n Found: Boolean;\r\nbegin\r\n Found := False;\r\n I := 0;\r\n while (I < Count) and not Found do\r\n begin\r\n if TObject(Items[I]).ClassType = AEngineClass then\r\n begin\r\n TJvAppStoragePropertyBaseEngine(Items[I]).Free;\r\n Delete(I);\r\n Found := True;\r\n end;\r\n Inc(I);\r\n end;\r\nend;\r\n\r\nfunction TJvAppStoragePropertyEngineList.GetEngine(AObject: TObject;\r\n AProperty: TObject): TJvAppStoragePropertyBaseEngine;\r\nvar\r\n Ind: Integer;\r\nbegin\r\n Result := nil;\r\n for Ind := 0 to Count - 1 do\r\n if TJvAppStoragePropertyBaseEngine(Items[Ind]).Supports(AObject, AProperty) then\r\n begin\r\n Result := TJvAppStoragePropertyBaseEngine(Items[Ind]);\r\n Break;\r\n end;\r\nend;\r\n\r\nfunction TJvAppStoragePropertyEngineList.ReadProperty(AStorage: TJvCustomAppStorage; const APath: string; AObject: TObject;\r\n AProperty: TObject; const Recursive, ClearFirst: Boolean; const IgnoreProperties: TStrings = nil): Boolean;\r\nvar\r\n Engine: TJvAppStoragePropertyBaseEngine;\r\nbegin\r\n Engine := GetEngine(AObject, AProperty);\r\n Result := Assigned(Engine);\r\n if Result then\r\n Engine.ReadProperty(AStorage, APath, AObject, AProperty, Recursive, ClearFirst, IgnoreProperties);\r\nend;\r\n\r\nfunction TJvAppStoragePropertyEngineList.WriteProperty(AStorage: TJvCustomAppStorage; const APath: string; AObject: TObject;\r\n AProperty: TObject; const Recursive: Boolean; const IgnoreProperties: TStrings = nil): Boolean;\r\nvar\r\n Engine: TJvAppStoragePropertyBaseEngine;\r\nbegin\r\n Engine := GetEngine(AObject, AProperty);\r\n Result := Assigned(Engine);\r\n if Result then\r\n Engine.WriteProperty(AStorage, APath, AObject, AProperty, Recursive, IgnoreProperties);\r\nend;\r\n\r\nconstructor TJvAppFileStorageOptions.Create;\r\nbegin\r\n inherited Create;\r\n FBackupKeepFileAfterFlush := false;\r\n FBackupType := afsbtNone;\r\n FBackupHistoryType := afsbhtNone;\r\n FBackupHistoryCount := 0;\r\nend;\r\n\r\nprocedure TJvAppFileStorageOptions.Assign(Source: TPersistent);\r\nbegin\r\n if (Source = Self) then\r\n Exit;\r\n if Source is TJvAppFileStorageOptions then\r\n begin\r\n BackupType := TJvAppFileStorageOptions(Source).BackupType;\r\n BackupKeepFileAfterFlush := TJvAppFileStorageOptions(Source).BackupKeepFileAfterFlush;\r\n end;\r\n inherited assign(Source);\r\nend;\r\n\r\ninitialization\r\n {$IFDEF UNITVERSIONING}\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n {$ENDIF UNITVERSIONING}\r\n\r\nfinalization\r\n {$IFNDEF SUPPORTS_CLASS_CTORDTORS}\r\n DestroyAppStoragePropertyEngineList;\r\n {$ENDIF ~SUPPORTS_CLASS_CTORDTORS}\r\n\r\n {$IFDEF UNITVERSIONING}\r\n UnregisterUnitVersion(HInstance);\r\n {$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvAppStoragePropertyEngineDB.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvAppStoragePropertyEngineDB.pas, released on 2005-01-13.\r\n\r\nThe Initial Developer of the Original Code is Jens Fudickar\r\nPortions created by Jens Fudickar are Copyright (C) 2005 Jens Fudickar\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\n Olivier Sannier\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nDescription:\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvAppStoragePropertyEngineDB.pas 13088 2011-07-10 12:10:33Z jfudickar $\r\n\r\nunit JvAppStoragePropertyEngineDB;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\n{$IFDEF UNITVERSIONING}\r\nuses\r\n JclUnitVersioning;\r\n{$ENDIF UNITVERSIONING}\r\n\r\nprocedure RegisterAppStoragePropertyEngines;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvAppStoragePropertyEngineDB.pas $';\r\n Revision: '$Revision: 13088 $';\r\n Date: '$Date: 2011-07-10 14:10:33 +0200 (dim. 10 juil. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n Classes, DBGrids,\r\n JvJCLUtils, JvAppStorage;\r\n\r\ntype\r\n TJvAppStoragePropertyDBGridColumnsEngine = class(TJvAppStoragePropertyBaseEngine)\r\n public\r\n function Supports(AObject: TObject; AProperty: TObject): Boolean; override;\r\n procedure ReadProperty(AStorage: TJvCustomAppStorage; const APath: string; AObject: TObject; AProperty: TObject; const Recursive,\r\n ClearFirst: Boolean; const IgnoreProperties: TStrings = nil); override;\r\n procedure WriteProperty(AStorage: TJvCustomAppStorage; const APath: string; AObject: TObject; AProperty: TObject; const\r\n Recursive: Boolean; const IgnoreProperties: TStrings = nil); override;\r\n end;\r\n\r\n//=== { TJvAppStoragePropertyDBGridColumnsEngine } ===========================\r\n\r\nfunction TJvAppStoragePropertyDBGridColumnsEngine.Supports(AObject: TObject; AProperty: TObject): Boolean;\r\nbegin\r\n Result := Assigned(AProperty) and (AProperty is TDBGridColumns);\r\nend;\r\n\r\ntype\r\n TAccessCustomDBGrid = class(TCustomDBGrid);\r\n\r\nprocedure TJvAppStoragePropertyDBGridColumnsEngine.ReadProperty(AStorage: TJvCustomAppStorage; const APath: string; AObject:\r\n TObject; AProperty: TObject; const Recursive, ClearFirst: Boolean; const IgnoreProperties: TStrings = nil);\r\nbegin\r\n if Assigned(AObject) and (AObject is TCustomDBGrid) then\r\n TAccessCustomDBGrid(AObject).BeginLayout;\r\n try\r\n if Assigned(AProperty) and (AProperty is TDBGridColumns) then\r\n AStorage.ReadCollection(APath, TCollection(AProperty), ClearFirst);\r\n finally\r\n if Assigned(AObject) and (AObject is TCustomDBGrid) then\r\n TAccessCustomDBGrid(AObject).EndLayout;\r\n end;\r\nend;\r\n\r\nprocedure TJvAppStoragePropertyDBGridColumnsEngine.WriteProperty(AStorage: TJvCustomAppStorage; const APath: string; AObject:\r\n TObject; AProperty: TObject; const Recursive: Boolean; const IgnoreProperties: TStrings = nil);\r\nbegin\r\n if Assigned(AProperty) and (AProperty is TDBGridColumns) then\r\n AStorage.WriteCollection(APath, TCollection(AProperty));\r\nend;\r\n\r\n//=== Global =================================================================\r\n\r\nprocedure RegisterAppStoragePropertyEngines;\r\nbegin\r\n RegisterAppStoragePropertyEngine(TJvAppStoragePropertyDBGridColumnsEngine);\r\nend;\r\n\r\nprocedure UnregisterAppStoragePropertyEngines;\r\nbegin\r\n UnregisterAppStoragePropertyEngine(TJvAppStoragePropertyDBGridColumnsEngine);\r\nend;\r\n\r\ninitialization\r\n {$IFDEF UNITVERSIONING}\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n {$ENDIF UNITVERSIONING}\r\n RegisterAppStoragePropertyEngines;\r\n\r\nfinalization\r\n UnregisterAppStoragePropertyEngines;\r\n {$IFDEF UNITVERSIONING}\r\n UnregisterUnitVersion(HInstance);\r\n {$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvAppStorageSelectList.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Initial Developers of the Original Code is: Jens Fudickar\r\nAll Rights Reserved.\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvAppStorageSelectList.pas 13138 2011-10-26 23:17:50Z jfudickar $\r\n\r\nunit JvAppStorageSelectList;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Classes, Controls, Forms,\r\n JvComponentBase, JvTypes, JvAppStorage, JvDynControlEngine,\r\n JvDynControlEngineIntf;\r\n\r\ntype\r\n TJvAppStorageSelectListOperation = (sloLoad, sloStore, sloManage);\r\n\r\n TJvBaseAppStorageSelectList = class;\r\n TJvBaseAppStorageSelectListDialogInstance = class(TJvComponent)\r\n private\r\n FAppStorageSelectList: TJvBaseAppStorageSelectList;\r\n FCaption: String;\r\n FDynControlEngine: TJvDynControlEngine;\r\n FOperation: TJvAppStorageSelectListOperation;\r\n FSelectDialog: TForm;\r\n function GetModalResult: TModalResult;\r\n protected\r\n function GetDynControlEngine: TJvDynControlEngine; virtual;\r\n property SelectDialog: TForm read FSelectDialog write FSelectDialog;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n function CreateControls(AOperation: TJvAppStorageSelectListOperation; ACaption: string = ''): TForm; virtual; abstract;\r\n function DialogResultValue: String; virtual; abstract;\r\n procedure ShowModal;\r\n property ModalResult: TModalResult read GetModalResult;\r\n property AppStorageSelectList: TJvBaseAppStorageSelectList read FAppStorageSelectList write FAppStorageSelectList;\r\n property Caption: String read FCaption write FCaption;\r\n property DynControlEngine: TJvDynControlEngine read GetDynControlEngine write FDynControlEngine;\r\n property Operation: TJvAppStorageSelectListOperation read FOperation write FOperation;\r\n end;\r\n\r\n TJvBaseAppStorageSelectListDialogInstanceClass = class of TJvBaseAppStorageSelectListDialogInstance;\r\n\r\n TJvBaseAppStorageSelectListDialog = class(TJvComponent)\r\n private\r\n FDynControlEngine: TJvDynControlEngine;\r\n protected\r\n function DialogInstanceClass: TJvBaseAppStorageSelectListDialogInstanceClass; virtual; abstract;\r\n function GetDynControlEngine: TJvDynControlEngine; virtual;\r\n public\r\n property DynControlEngine: TJvDynControlEngine read GetDynControlEngine write FDynControlEngine;\r\n end;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64 or pidOSX32)]\r\n {$ENDIF RTL230_UP}\r\n TJvAppStorageSelectListEasyDialog = class(TJvBaseAppStorageSelectListDialog)\r\n protected\r\n function DialogInstanceClass: TJvBaseAppStorageSelectListDialogInstanceClass; override;\r\n end;\r\n\r\n TJvAppStorageSelectListEasyDialogInstance = class(TJvBaseAppStorageSelectListDialogInstance)\r\n private\r\n FIComboBoxData: IJvDynControlData;\r\n FIComboBoxItems: IJvDynControlItems;\r\n FIListBoxData: IJvDynControlData;\r\n FIListBoxItems: IJvDynControlItems;\r\n protected\r\n procedure DialogOnCancelButtonClick(Sender: TObject);\r\n procedure DialogOnDestroy(Sender: TObject);\r\n procedure DialogOnListBoxChange(Sender: TObject);\r\n procedure DialogOnOkButtonClick(Sender: TObject);\r\n property IComboBoxData: IJvDynControlData read FIComboBoxData write FIComboBoxData;\r\n property IComboBoxItems: IJvDynControlItems read FIComboBoxItems write FIComboBoxItems;\r\n property IListBoxData: IJvDynControlData read FIListBoxData write FIListBoxData;\r\n property IListBoxItems: IJvDynControlItems read FIListBoxItems write FIListBoxItems;\r\n public\r\n function CreateControls(AOperation: TJvAppStorageSelectListOperation; ACaption: string = ''): TForm; override;\r\n function DialogResultValue: String; override;\r\n end;\r\n\r\n TJvBaseAppStorageSelectList = class(TJvComponent)\r\n private\r\n FAppStorage: TJvCustomAppStorage;\r\n FCheckEntries: Boolean;\r\n FSelectList: TStringList;\r\n FSelectListDialog: TJvBaseAppStorageSelectListDialog;\r\n FSelectPath: string;\r\n procedure SetSelectListDialog(const Value: TJvBaseAppStorageSelectListDialog);\r\n protected\r\n function CreateSelectListDialogInstance(AOwner: TComponent;AOperation: TJvAppStorageSelectListOperation; ACaption:\r\n string = ''): TJvBaseAppStorageSelectListDialogInstance; virtual;\r\n function GetAppStorage: TJvCustomAppStorage; virtual;\r\n function GetSelectList: TStrings; virtual;\r\n function GetStoragePath: string; virtual;\r\n procedure LoadSelectList;\r\n procedure Notification(AComponent: TComponent; Operation: TOperation); override;\r\n procedure SetAppStorage(Value: TJvCustomAppStorage); virtual;\r\n procedure SetSelectList(const Value: TStrings); virtual;\r\n procedure SetSelectPath(Value: string);\r\n procedure StoreSelectList;\r\n property SelectList: TStrings read GetSelectList write SetSelectList;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n procedure AddEntry(iName: string);\r\n procedure DeleteEntry(iName: string; iDeletePath: Boolean = true);\r\n function GetSelectListPath(AOperation: TJvAppStorageSelectListOperation; ACaption: string = ''): string;\r\n procedure ManageSelectList(ACaption: string = '');\r\n function StorageNamePath(iName : String): string;\r\n property AppStorage: TJvCustomAppStorage read GetAppStorage write SetAppStorage;\r\n property CheckEntries: Boolean read FCheckEntries write FCheckEntries default True;\r\n property SelectListDialog: TJvBaseAppStorageSelectListDialog read FSelectListDialog write SetSelectListDialog;\r\n property SelectPath: string read FSelectPath write SetSelectPath;\r\n end;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64 or pidOSX32)]\r\n {$ENDIF RTL230_UP}\r\n TJvAppStorageSelectList = class(TJvBaseAppStorageSelectList)\r\n published\r\n property AppStorage;\r\n property CheckEntries;\r\n property SelectListDialog;\r\n property SelectPath;\r\n end;\r\n\r\n\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvAppStorageSelectList.pas $';\r\n Revision: '$Revision: 13138 $';\r\n Date: '$Date: 2011-10-27 01:17:50 +0200 (jeu. 27 oct. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n SysUtils,\r\n JvResources, JvJVCLUtils;\r\n\r\nfunction TJvAppStorageSelectListEasyDialogInstance.CreateControls(AOperation: TJvAppStorageSelectListOperation;\r\n ACaption: string = ''): TForm;\r\nvar\r\n MainPanel, ButtonPanel, ListBoxPanel, ComboBoxPanel: TWinControl;\r\n OkButton, CancelButton: TWinControl;\r\n ComboBox: TWinControl;\r\n ListBox: TWinControl;\r\n ITmpPanel: IJvDynControlPanel;\r\n ITmpControl: IJvDynControl;\r\n ITmpControlCaption: IJvDynControlCaption;\r\n ITmpComboBox: IJvDynControlComboBox;\r\n ITmpDblClick: IJvDynControlDblClick;\r\n FDialog: TForm;\r\nbegin\r\n if not Assigned(DynControlEngine) then\r\n raise EJVCLException.CreateRes(@RsEDynControlEngineNotDefined);\r\n\r\n Operation := AOperation;\r\n\r\n FDialog := TForm(DynControlEngine.CreateForm('', ''));\r\n\r\n FDialog.BorderIcons := [];\r\n FDialog.DefaultMonitor := dmActiveForm;\r\n FDialog.BorderStyle := bsDialog;\r\n FDialog.FormStyle := fsNormal;\r\n FDialog.Position := poScreenCenter;\r\n FDialog.OnDestroy := DialogOnDestroy;\r\n\r\n if ACaption <> '' then\r\n FDialog.Caption := ACaption\r\n else\r\n case Operation of\r\n sloLoad:\r\n FDialog.Caption := RsLoadSettings;\r\n sloStore:\r\n FDialog.Caption := RsSaveSettings;\r\n sloManage:\r\n FDialog.Caption := RsDeleteSettings;\r\n end;\r\n\r\n MainPanel := DynControlEngine.CreatePanelControl(Self, FDialog, 'MainPanel', '', alClient);\r\n ButtonPanel := DynControlEngine.CreatePanelControl(Self, FDialog, 'ButtonPanel', '', alBottom);\r\n\r\n OkButton := DynControlEngine.CreateButton(Self, ButtonPanel, 'OkButton',\r\n RsButtonOKCaption, '', DialogOnOkButtonClick, True, False);\r\n if Operation <> sloStore then\r\n OkButton.Enabled := AppStorageSelectList.SelectList.Count > 0;\r\n CancelButton := DynControlEngine.CreateButton(Self, ButtonPanel, 'CancelButton',\r\n RsButtonCancelCaption, '', DialogOnCancelButtonClick, False, True);\r\n ButtonPanel.Height := OkButton.Height + 10;\r\n CancelButton.Top := 5;\r\n CancelButton.Left := ButtonPanel.Width - 5 - CancelButton.Width;\r\n CancelButton.Anchors := [akTop, akRight];\r\n OkButton.Top := 5;\r\n OkButton.Left := CancelButton.Left - 10 - OkButton.Width;\r\n OkButton.Anchors := [akTop, akRight];\r\n\r\n ComboBoxPanel := DynControlEngine.CreatePanelControl(Self, MainPanel, 'ComboBoxPanel', '', alBottom);\r\n IntfCast(ComboBoxPanel, IJvDynControlPanel, ITmpPanel);\r\n ITmpPanel.ControlSetBorder(bvNone, bvNone, 0, bsNone, 5);\r\n ListBoxPanel := DynControlEngine.CreatePanelControl(Self, MainPanel, 'ListPanel', '', alClient);\r\n IntfCast(ListBoxPanel, IJvDynControlPanel, ITmpPanel);\r\n ITmpPanel.ControlSetBorder(bvNone, bvNone, 0, bsNone, 5);\r\n\r\n ComboBox := DynControlEngine.CreateComboBoxControl(Self, ComboBoxPanel, 'ComboBox', AppStorageSelectList.SelectList);\r\n IntfCast(ComboBox, IJvDynControlItems, FIComboBoxItems);\r\n IntfCast(ComboBox, IJvDynControlData, FIComboBoxData);\r\n\r\n IComboBoxItems.ControlSetSorted(True);\r\n if Supports(ComboBox, IJvDynControlComboBox, ITmpComboBox) then\r\n case AOperation of\r\n sloLoad:\r\n ITmpComboBox.ControlSetNewEntriesAllowed(False);\r\n sloStore:\r\n ITmpComboBox.ControlSetNewEntriesAllowed(True);\r\n sloManage:\r\n ITmpComboBox.ControlSetNewEntriesAllowed(False);\r\n end;\r\n\r\n IComboBoxData.ControlValue := '';\r\n\r\n ListBox := DynControlEngine.CreateListBoxControl(Self, ListBoxPanel, 'ListBox', AppStorageSelectList.SelectList);\r\n Supports(ListBox, IJvDynControlItems, FIListBoxItems);\r\n Supports(ListBox, IJvDynControl, ITmpControl);\r\n Supports(ListBox, IJvDynControlData, FIListBoxData);\r\n ITmpControl.ControlSetOnClick(DialogOnListBoxChange);\r\n FIListBoxData.ControlSetOnChange(DialogOnListBoxChange);\r\n if Supports(ListBox, IJvDynControlDblClick, ITmpDblClick) then // ListBox instead of ListBox.ClassType and ITmpControl are needed here for D5/C5 support (obones)\r\n ITmpDblClick.ControlSetOnDblClick(DialogOnOkButtonClick);\r\n\r\n ComboBoxPanel.Height := ComboBox.Height + 12;\r\n ListBox.Align := alClient;\r\n ComboBox.Align := alClient;\r\n\r\n IntfCast(OkButton, IJvDynControlCaption, ITmpControlCaption);\r\n case AOperation of\r\n sloLoad:\r\n ITmpControlCaption.ControlSetCaption(RsLoadCaption);\r\n sloStore:\r\n ITmpControlCaption.ControlSetCaption(RsSaveCaption);\r\n sloManage:\r\n ITmpControlCaption.ControlSetCaption(RsDeleteCaption);\r\n end;\r\n Result := FDialog;\r\nend;\r\n\r\nprocedure TJvAppStorageSelectListEasyDialogInstance.DialogOnCancelButtonClick(Sender: TObject);\r\nbegin\r\n SelectDialog.ModalResult := mrCancel;\r\nend;\r\n\r\nprocedure TJvAppStorageSelectListEasyDialogInstance.DialogOnDestroy(Sender: TObject);\r\nbegin\r\n FIComboBoxItems := nil;\r\n FIComboBoxData := nil;\r\n FIListBoxItems := nil;\r\n FIListBoxData := nil;\r\nend;\r\n\r\nprocedure TJvAppStorageSelectListEasyDialogInstance.DialogOnListBoxChange(Sender: TObject);\r\nvar\r\n Index: Integer;\r\nbegin\r\n Index := IListBoxData.ControlValue;\r\n if (Index >= 0) and (Index < IListBoxItems.ControlItems.Count) then\r\n IComboBoxData.ControlValue := IListBoxItems.ControlItems[Index];\r\nend;\r\n\r\nprocedure TJvAppStorageSelectListEasyDialogInstance.DialogOnOkButtonClick(Sender: TObject);\r\nvar\r\n Value: string;\r\nbegin\r\n Value := IComboBoxData.ControlValue;\r\n if Operation = sloStore then\r\n SelectDialog.ModalResult := mrOk\r\n else\r\n if AppStorageSelectList.SelectList.IndexOf(Value) >= 0 then\r\n SelectDialog.ModalResult := mrOk;\r\nend;\r\n\r\nfunction TJvAppStorageSelectListEasyDialogInstance.DialogResultValue: String;\r\nbegin\r\n Result := IComboBoxData.ControlValue;\r\nend;\r\n\r\nconstructor TJvBaseAppStorageSelectList.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FCheckEntries := True;\r\n FSelectList := TStringList.Create;\r\nend;\r\n\r\ndestructor TJvBaseAppStorageSelectList.Destroy;\r\nbegin\r\n FreeAndNil(FSelectList);\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvBaseAppStorageSelectList.AddEntry(iName: string);\r\nbegin\r\n if SelectList.IndexOf(iName) < 0 then\r\n begin\r\n SelectList.Add(iName);\r\n StoreSelectList;\r\n end;\r\nend;\r\n\r\nfunction TJvBaseAppStorageSelectList.CreateSelectListDialogInstance(AOwner: TComponent;AOperation:\r\n TJvAppStorageSelectListOperation; ACaption: string = ''): TJvBaseAppStorageSelectListDialogInstance;\r\nbegin\r\n if Assigned(FSelectListDialog) then\r\n begin\r\n Result := FSelectListDialog.DialogInstanceClass.Create(AOwner);\r\n Result.DynControlEngine := FSelectListDialog.DynControlEngine;\r\n end\r\n else\r\n Result := TJvAppStorageSelectListEasyDialogInstance.Create(AOwner);\r\n Result.AppStorageSelectList := Self;\r\n Result.Operation := AOperation;\r\n Result.Caption := ACaption;\r\nend;\r\n\r\nprocedure TJvBaseAppStorageSelectList.DeleteEntry(iName: string; iDeletePath: Boolean = true);\r\nbegin\r\n if SelectList.IndexOf(iName) >= 0 then\r\n begin\r\n SelectList.Delete(SelectList.IndexOf(iName));\r\n AppStorage.BeginUpdate;\r\n try\r\n if iDeletePath then\r\n AppStorage.DeleteSubTree(StorageNamePath(iName));\r\n StoreSelectList;\r\n finally\r\n AppStorage.EndUpdate;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJvBaseAppStorageSelectList.GetAppStorage: TJvCustomAppStorage;\r\nbegin\r\n Result := FAppStorage;\r\nend;\r\n\r\nfunction TJvBaseAppStorageSelectList.GetSelectList: TStrings;\r\nbegin\r\n Result := FSelectList;\r\nend;\r\n\r\nfunction TJvBaseAppStorageSelectList.GetSelectListPath(AOperation: TJvAppStorageSelectListOperation; ACaption: string =\r\n ''): string;\r\nvar\r\n SelectDialog: TJvBaseAppStorageSelectListDialogInstance;\r\nbegin\r\n if not Assigned(AppStorage) then\r\n raise EJVCLException.CreateRes(@RsEDynAppStorageNotDefined);\r\n try\r\n LoadSelectList;\r\n SelectDialog := CreateSelectListDialogInstance(self, AOperation, ACaption);\r\n SelectDialog.ShowModal;\r\n if (SelectDialog.ModalResult = mrOk) and (SelectDialog.DialogResultValue <> '') then\r\n begin\r\n case AOperation of\r\n sloLoad:\r\n Result := StorageNamePath(SelectDialog.DialogResultValue);\r\n sloStore:\r\n begin\r\n AddEntry(SelectDialog.DialogResultValue);\r\n Result := StorageNamePath(SelectDialog.DialogResultValue);\r\n end;\r\n sloManage:\r\n begin\r\n DeleteEntry(SelectDialog.DialogResultValue);\r\n Result := StorageNamePath(SelectDialog.DialogResultValue);\r\n end;\r\n end;\r\n end;\r\n finally\r\n FreeAndNil(SelectDialog);\r\n end;\r\nend;\r\n\r\nfunction TJvBaseAppStorageSelectList.GetStoragePath: string;\r\nbegin\r\n Result := SelectPath;\r\nend;\r\n\r\nprocedure TJvBaseAppStorageSelectList.LoadSelectList;\r\nvar\r\n I: Integer;\r\nbegin\r\n if Assigned(AppStorage) then\r\n begin\r\n AppStorage.BeginUpdate;\r\n try\r\n AppStorage.ReadStringList(GetStoragePath, FSelectList, True);\r\n if CheckEntries then\r\n for I := FSelectList.Count - 1 downto 0 do\r\n if not AppStorage.PathExists(AppStorage.ConcatPaths ([GetStoragePath,FSelectList[I]])) then\r\n FSelectList.Delete(I);\r\n finally\r\n AppStorage.EndUpdate;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvBaseAppStorageSelectList.ManageSelectList(ACaption: string = '');\r\nbegin\r\n GetSelectListPath(sloManage, ACaption);\r\nend;\r\n\r\nprocedure TJvBaseAppStorageSelectList.Notification(AComponent: TComponent; Operation: TOperation);\r\nbegin\r\n inherited Notification(AComponent, Operation);\r\n if (Operation = opRemove) then\r\n if (AComponent = FSelectListDialog) then\r\n FSelectListDialog := nil\r\n else if (AComponent = FAppStorage) then\r\n FAppStorage := nil;\r\nend;\r\n\r\nprocedure TJvBaseAppStorageSelectList.SetAppStorage(Value: TJvCustomAppStorage);\r\nbegin\r\n ReplaceComponentReference(Self, Value, TComponent(FAppStorage));\r\nend;\r\n\r\nprocedure TJvBaseAppStorageSelectList.SetSelectList(const Value: TStrings);\r\nbegin\r\n FSelectList.Assign(Value);\r\nend;\r\n\r\nprocedure TJvBaseAppStorageSelectList.SetSelectListDialog(const Value: TJvBaseAppStorageSelectListDialog);\r\nbegin\r\n ReplaceComponentReference(Self, Value, TComponent(FSelectListDialog));\r\nend;\r\n\r\nprocedure TJvBaseAppStorageSelectList.SetSelectPath(Value: string);\r\nbegin\r\n FSelectPath := Value;\r\nend;\r\n\r\nfunction TJvBaseAppStorageSelectList.StorageNamePath(iName : String): string;\r\nbegin\r\n Result := AppStorage.ConcatPaths ([GetStoragePath,iName]);\r\nend;\r\n\r\nprocedure TJvBaseAppStorageSelectList.StoreSelectList;\r\nbegin\r\n if Assigned(AppStorage) then\r\n AppStorage.WriteStringList(GetStoragePath, FSelectList);\r\nend;\r\n\r\nconstructor TJvBaseAppStorageSelectListDialogInstance.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FSelectDialog := nil;\r\nend;\r\n\r\ndestructor TJvBaseAppStorageSelectListDialogInstance.Destroy;\r\nbegin\r\n FreeAndNil(FSelectDialog);\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJvBaseAppStorageSelectListDialogInstance.GetDynControlEngine: TJvDynControlEngine;\r\nbegin\r\n if Assigned(FDynControlEngine) then\r\n Result := FDynControlEngine\r\n else\r\n Result := DefaultDynControlEngine;\r\nend;\r\n\r\nfunction TJvBaseAppStorageSelectListDialogInstance.GetModalResult: TModalResult;\r\nbegin\r\n Result := FSelectDialog.ModalResult;\r\nend;\r\n\r\nprocedure TJvBaseAppStorageSelectListDialogInstance.ShowModal;\r\nbegin\r\n FreeAndNil(FSelectDialog);\r\n FSelectDialog := CreateControls (Operation, Caption);\r\n FSelectDialog.ShowModal;\r\nend;\r\n\r\nfunction TJvAppStorageSelectListEasyDialog.DialogInstanceClass: TJvBaseAppStorageSelectListDialogInstanceClass;\r\nbegin\r\n Result := TJvAppStorageSelectListEasyDialogInstance;\r\nend;\r\n\r\nfunction TJvBaseAppStorageSelectListDialog.GetDynControlEngine: TJvDynControlEngine;\r\nbegin\r\n if Assigned(FDynControlEngine) then\r\n Result := FDynControlEngine\r\n else\r\n Result := DefaultDynControlEngine;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvAppXMLStorage.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvAppXMLStorage.pas, released on 2003-12-06.\r\n\r\nThe Initial Developer of the Original Code is Olivier Sannier\r\nPortions created by Olivier Sannier are Copyright (C) 2003 Olivier Sannier\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\n Marcel Bestebroer\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvAppXMLStorage.pas 13306 2012-06-03 20:21:44Z jfudickar $\r\n\r\nunit JvAppXMLStorage;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n {$IFDEF MSWINDOWS}\r\n Windows,\r\n {$ENDIF MSWINDOWS}\r\n {$IFDEF HAS_UNIT_LIBC}\r\n Libc,\r\n {$ENDIF HAS_UNIT_LIBC}\r\n Classes,\r\n JvAppStorage, JvPropertyStore, JvSimpleXml, JvTypes, JclStreams;\r\n\r\ntype\r\n TJvCustomAppXMLStorage = class;\r\n\r\n TJvAppXMLStorageOptions = class(TJvAppFileStorageOptions)\r\n private\r\n FAutoEncodeEntity: Boolean;\r\n FAutoEncodeValue: Boolean;\r\n FAutoIndent: Boolean;\r\n FCodePage: Word;\r\n FEncoding: TJclStringEncoding;\r\n FInvalidCharReplacement: string;\r\n FWhiteSpaceReplacement: string;\r\n FStorage: TJvCustomAppXMLStorage;\r\n function GetAutoEncodeEntity: Boolean;\r\n function GetAutoEncodeValue: Boolean;\r\n procedure SetAutoEncodeEntity(const Value: Boolean);\r\n procedure SetAutoEncodeValue(const Value: Boolean);\r\n function GetAutoIndent: Boolean;\r\n procedure SetAutoIndent(const Value: Boolean);\r\n procedure SetInvalidCharReplacement(const Value: string);\r\n procedure SetWhiteSpaceReplacement(const Value: string);\r\n protected\r\n public\r\n constructor Create; override;\r\n procedure Assign(Source: TPersistent); override;\r\n published\r\n property BooleanStringTrueValues;\r\n property BooleanStringFalseValues;\r\n property BooleanAsString;\r\n property EnumerationAsString;\r\n property TypedIntegerAsString;\r\n property SetAsString;\r\n property DateTimeAsString;\r\n property FloatAsString;\r\n property DefaultIfReadConvertError;\r\n property DefaultIfValueNotExists;\r\n property StoreDefaultValues;\r\n property UseOldItemNameFormat;\r\n property UseTranslateStringEngineDateTimeFormats;\r\n property BackupType;\r\n property BackupKeepFileAfterFlush;\r\n property BackupHistoryCount;\r\n property BackupHistoryType;\r\n\r\n //Flag to determine if a stringlist should be stored as single string and not as list of string items\r\n property StoreStringListAsSingleString;\r\n property WhiteSpaceReplacement: string read FWhiteSpaceReplacement write SetWhiteSpaceReplacement;\r\n property AutoEncodeValue: Boolean read GetAutoEncodeValue write SetAutoEncodeValue default True;\r\n property AutoEncodeEntity: Boolean read GetAutoEncodeEntity write SetAutoEncodeEntity default True;\r\n property AutoIndent: Boolean read GetAutoIndent write SetAutoIndent default True;\r\n property CodePage: Word read FCodePage write FCodePage default CP_ACP;\r\n property Encoding: TJclStringEncoding read FEncoding write FEncoding default seAuto;\r\n property InvalidCharReplacement: string read FInvalidCharReplacement write SetInvalidCharReplacement;\r\n end;\r\n\r\n // This is the base class for an in memory XML file storage\r\n // There is at the moment only one derived class that simply\r\n // allows to flush into a disk file.\r\n // But there may be a new descendent that stores into a\r\n // database field, if anyone is willing to write such\r\n // a class (nothing much is involved, use the AsString property).\r\n TJvCustomAppXMLStorage = class(TJvCustomAppMemoryFileStorage)\r\n private\r\n function GetStorageOptions: TJvAppXMLStorageOptions;\r\n procedure SetStorageOptions(Value: TJvAppXMLStorageOptions);\r\n protected\r\n FXml: TJvSimpleXML;\r\n\r\n class function GetStorageOptionsClass: TJvAppStorageOptionsClass; override;\r\n\r\n function GetAsString: string; override;\r\n procedure SetAsString(const Value: string); override;\r\n\r\n function CheckNodeNameCharacters(const NodeName: string): string;\r\n\r\n function DefaultExtension: string; override;\r\n\r\n function GetOnDecodeValue: TJvSimpleXMLEncodeEvent;\r\n function GetOnEncodeValue: TJvSimpleXMLEncodeEvent;\r\n procedure SetOnDecodeValue(const Value: TJvSimpleXMLEncodeEvent);\r\n procedure SetOnEncodeValue(const Value: TJvSimpleXMLEncodeEvent);\r\n\r\n function GetRootNodeName: string;\r\n procedure SetRootNodeName(const Value: string);\r\n // Returns the last node in path, if it exists.\r\n // Returns nil in all other cases\r\n // If StartNode is nil, then FXML.Root is used as a\r\n // starting point for Path\r\n function GetNodeFromPath(Path: string; StartNode: TJvSimpleXmlElem = nil): TJvSimpleXmlElem;\r\n // Reads the \\ separated Key string and returns the last created node\r\n function CreateAndSetNode(Key: string): TJvSimpleXmlElem;\r\n procedure EnumFolders(const Path: string; const Strings: TStrings; const ReportListAsValue: Boolean = True); override;\r\n procedure EnumValues(const Path: string; const Strings: TStrings; const ReportListAsValue: Boolean = True); override;\r\n function IsFolderInt(const Path: string; ListIsValue: Boolean = True): Boolean; override;\r\n procedure SplitKeyPath(const Path: string; out Key, ValueName: string); override;\r\n function PathExistsInt(const Path: string): Boolean; override;\r\n function ValueStoredInt(const Path: string): Boolean; override;\r\n procedure DeleteValueInt(const Path: string); override;\r\n procedure DeleteSubTreeInt(const Path: string); override;\r\n function DoReadBoolean(const Path: string; Default: Boolean): Boolean; override;\r\n procedure DoWriteBoolean(const Path: string; Value: Boolean); override;\r\n function DoReadInteger(const Path: string; Default: Integer): Integer; override;\r\n procedure DoWriteInteger(const Path: string; Value: Integer); override;\r\n function DoReadFloat(const Path: string; Default: Extended): Extended; override;\r\n procedure DoWriteFloat(const Path: string; Value: Extended); override;\r\n function DoReadString(const Path: string; const Default: string): string; override;\r\n procedure DoWriteString(const Path: string; const Value: string); override;\r\n function DoReadBinary(const Path: string; Buf: TJvBytes; BufSize: Integer): Integer; override;\r\n procedure DoWriteBinary(const Path: string; const Buf: TJvBytes; BufSize: Integer); override;\r\n function GetValueElementFromNode(Node: TJvSimpleXMLElem; ValueName: string): TJvSimpleXMLElem;\r\n { Determines if the specified list is stored (ignores sub stores) }\r\n function ListStoredInt(const Path: string; const ItemName: string = cItem): Boolean; override;\r\n function ReadListItemCount(const Path: string; const ItemName: string = cItem): Integer; override;\r\n function SplitNodeNameIndex(var sNodeName : String; var sIndex : Integer): Boolean;\r\n procedure WriteListItemCount(const Path: string; const ItemCount: Integer; const ItemName: string = cItem); override;\r\n\r\n property Xml: TJvSimpleXML read FXml;\r\n property RootNodeName: string read GetRootNodeName write SetRootNodeName;\r\n property OnEncodeValue: TJvSimpleXMLEncodeEvent read GetOnEncodeValue write SetOnEncodeValue;\r\n property OnDecodeValue: TJvSimpleXMLEncodeEvent read GetOnDecodeValue write SetOnDecodeValue;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n published\r\n property StorageOptions: TJvAppXMLStorageOptions read GetStorageOptions write SetStorageOptions;\r\n end;\r\n\r\n // This class handles the flushing into a disk file\r\n // and publishes a few properties for them to be\r\n // used by the user in the IDE\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64 or pidOSX32)]\r\n {$ENDIF RTL230_UP}\r\n TJvAppXMLFileStorage = class(TJvCustomAppXMLStorage)\r\n protected\r\n procedure ClearInternal; override;\r\n procedure FlushInternal; override;\r\n procedure ReloadInternal; override;\r\n public\r\n property Xml;\r\n property AsString;\r\n published\r\n property AutoFlush;\r\n property AutoReload;\r\n property FileName;\r\n property FlushOnDestroy;\r\n property Location;\r\n property RootNodeName;\r\n property SubStorages;\r\n property OnGetFileName;\r\n property OnEncodeValue;\r\n property OnDecodeValue;\r\n //1 Synchronize the Flush and Reload procedure\r\n /// Defines if the execution of flush and reload for the current\r\n /// File should be synchronized via a global mutex\r\n property SynchronizeFlushReload;\r\n end;\r\n\r\nprocedure StorePropertyStoreToXmlFile(APropertyStore: TJvCustomPropertyStore; const AFileName: string; const\r\n AAppStoragePath: string = ''; AStorageOptions: TJvCustomAppStorageOptions = nil);\r\nprocedure LoadPropertyStoreFromXmlFile(APropertyStore: TJvCustomPropertyStore; const AFileName: string; const\r\n AAppStoragePath: string = ''; AStorageOptions: TJvCustomAppStorageOptions = nil);\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvAppXMLStorage.pas $';\r\n Revision: '$Revision: 13306 $';\r\n Date: '$Date: 2012-06-03 22:21:44 +0200 (dim. 03 juin 2012) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n SysUtils, TypInfo,\r\n JclStrings,\r\n JvJCLUtils, JvResources;\r\n\r\nconst\r\n cNullDigit = '0';\r\n cCount = 'Count';\r\n cEmptyPath = 'EmptyPath';\r\n AllowedNodeNameChars = ['A'..'Z', 'a'..'z', '0'..'9', '_', '-', '.', ':'];\r\n\r\n//=== { TJvAppXMLStorageOptions } ============================================\r\n\r\nconstructor TJvAppXMLStorageOptions.Create;\r\nbegin\r\n inherited Create;\r\n FWhiteSpaceReplacement := ''; // to keep the original behaviour\r\n FInvalidCharReplacement := '_';\r\n FAutoEncodeEntity := True;\r\n FAutoEncodeValue := True;\r\n FAutoIndent := True;\r\n FEncoding := seAuto;\r\n FCodePage := CP_ACP;\r\nend;\r\n\r\nprocedure TJvAppXMLStorageOptions.Assign(Source: TPersistent);\r\nbegin\r\n if (Source = Self) then\r\n Exit;\r\n if Source is TJvAppXMLStorageOptions then\r\n begin\r\n WhiteSpaceReplacement := TJvAppXMLStorageOptions(Source).WhiteSpaceReplacement;\r\n AutoEncodeValue := TJvAppXMLStorageOptions(Source).AutoEncodeValue;\r\n AutoEncodeEntity := TJvAppXMLStorageOptions(Source).AutoEncodeEntity;\r\n AutoIndent := TJvAppXMLStorageOptions(Source).AutoIndent;\r\n InvalidCharReplacement := TJvAppXMLStorageOptions(Source).InvalidCharReplacement;\r\n end;\r\n inherited assign(Source);\r\nend;\r\n\r\nfunction TJvAppXMLStorageOptions.GetAutoEncodeEntity: Boolean;\r\nbegin\r\n if Assigned(FStorage) then\r\n Result := sxoAutoEncodeEntity in FStorage.Xml.Options\r\n else\r\n Result := FAutoEncodeEntity;\r\nend;\r\n\r\nfunction TJvAppXMLStorageOptions.GetAutoEncodeValue: Boolean;\r\nbegin\r\n if Assigned(FStorage) then\r\n Result := sxoAutoEncodeValue in FStorage.Xml.Options\r\n else\r\n Result := FAutoEncodeValue;\r\nend;\r\n\r\nfunction TJvAppXMLStorageOptions.GetAutoIndent: Boolean;\r\nbegin\r\n if Assigned(FStorage) then\r\n Result := sxoAutoIndent in FStorage.Xml.Options\r\n else\r\n Result := FAutoIndent;\r\nend;\r\n\r\nprocedure TJvAppXMLStorageOptions.SetAutoEncodeEntity(const Value: Boolean);\r\nbegin\r\n FAutoEncodeEntity := Value;\r\n if Assigned(FStorage) then\r\n if Value then\r\n FStorage.Xml.Options := FStorage.Xml.Options + [sxoAutoEncodeEntity]\r\n else\r\n FStorage.Xml.Options := FStorage.Xml.Options - [sxoAutoEncodeEntity];\r\nend;\r\n\r\nprocedure TJvAppXMLStorageOptions.SetAutoEncodeValue(const Value: Boolean);\r\nbegin\r\n FAutoEncodeValue := Value;\r\n if Assigned(FStorage) then\r\n if Value then\r\n FStorage.Xml.Options := FStorage.Xml.Options + [sxoAutoEncodeValue]\r\n else\r\n FStorage.Xml.Options := FStorage.Xml.Options - [sxoAutoEncodeValue];\r\nend;\r\n\r\nprocedure TJvAppXMLStorageOptions.SetAutoIndent(const Value: Boolean);\r\nbegin\r\n FAutoIndent := Value;\r\n if Assigned(FStorage) then\r\n if Value then\r\n FStorage.Xml.Options := FStorage.Xml.Options + [sxoAutoIndent]\r\n else\r\n FStorage.Xml.Options := FStorage.Xml.Options - [sxoAutoIndent];\r\nend;\r\n\r\nprocedure TJvAppXMLStorageOptions.SetInvalidCharReplacement(const Value: string);\r\nvar\r\n I: Integer;\r\nbegin\r\n if Value <> FInvalidCharReplacement then\r\n begin\r\n for I := 1 to Length(Value) do\r\n if not CharInSet(Value[I], AllowedNodeNameChars) then\r\n raise EJVCLException.CreateResFmt(@RsENotAllowedCharacterForProperty, [Value[I], 'InvalidCharReplacement']);\r\n FInvalidCharReplacement := Value;\r\n end;\r\nend;\r\n\r\nprocedure TJvAppXMLStorageOptions.SetWhiteSpaceReplacement(const Value: string);\r\nvar\r\n I: Integer;\r\nbegin\r\n if Value <> FWhiteSpaceReplacement then\r\n if StrContainsChars(Value, CharIsWhiteSpace, True) then\r\n raise EJVCLException.CreateRes(@RsEWhiteSpaceReplacementCannotContainSpaces)\r\n else\r\n begin\r\n for I := 1 to Length(Value) do\r\n if not CharInSet(Value[I], AllowedNodeNameChars) then\r\n raise EJVCLException.CreateResFmt(@RsENotAllowedCharacterForProperty, [Value[I], 'WhiteSpaceReplacement']);\r\n FWhiteSpaceReplacement := Value;\r\n end;\r\nend;\r\n\r\n//=== { TJvCustomAppXMLStorage } =============================================\r\n\r\nconstructor TJvCustomAppXMLStorage.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n (StorageOptions as TJvAppXMLStorageOptions).FStorage := Self;\r\n FXml := TJvSimpleXml.Create(nil);\r\n TJvAppXMLStorageOptions(StorageOptions).AutoEncodeValue := True;\r\n TJvAppXMLStorageOptions(StorageOptions).AutoEncodeEntity := True;\r\n TJvAppXMLStorageOptions(StorageOptions).AutoIndent := True;\r\n // (rom) should probably be a resourcestring\r\n RootNodeName := 'Configuration';\r\nend;\r\n\r\ndestructor TJvCustomAppXMLStorage.Destroy;\r\nbegin\r\n inherited Destroy;\r\n // delete after the inherited call, see comment in\r\n // the base class, TJvCustomMemoryFileAppStorage\r\n FXml.Free;\r\nend;\r\n\r\nfunction TJvCustomAppXMLStorage.GetValueElementFromNode(Node: TJvSimpleXMLElem; ValueName: string): TJvSimpleXMLElem;\r\nvar\r\n Index: Integer;\r\nbegin\r\n if Assigned(Node) then\r\n if SplitNodeNameIndex(ValueName, Index) then\r\n Result := Node.Items.NamedElems[ValueName].Item[Index]\r\n else\r\n Result := Node.Items.ItemNamed[ValueName]\r\n else\r\n Result := nil;\r\nend;\r\n\r\nclass function TJvCustomAppXMLStorage.GetStorageOptionsClass: TJvAppStorageOptionsClass;\r\nbegin\r\n Result := TJvAppXMLStorageOptions;\r\nend;\r\n\r\nfunction TJvCustomAppXMLStorage.CheckNodeNameCharacters(const NodeName: string): string;\r\nvar\r\n J, K: Integer;\r\n WSRLength: Integer;\r\n ICRLength: Integer;\r\n CurLength: Integer;\r\n InsertIndex: Integer;\r\n FixedNodeName: string;\r\n WhiteSpaceReplacement: string;\r\n InvalidCharReplacement: string;\r\nbegin\r\n WhiteSpaceReplacement := TJvAppXMLStorageOptions(StorageOptions).WhiteSpaceReplacement;\r\n InvalidCharReplacement := TJvAppXMLStorageOptions(StorageOptions).InvalidCharReplacement;\r\n FixedNodeName := NodeName;\r\n WSRLength := Length(WhiteSpaceReplacement);\r\n ICRLength := Length(InvalidCharReplacement);\r\n CurLength := Length(NodeName);\r\n SetLength(FixedNodeName, CurLength);\r\n InsertIndex := 0;\r\n for J := 1 to Length(NodeName) do\r\n begin\r\n Inc(InsertIndex);\r\n if CharIsWhiteSpace(NodeName[J]) then\r\n case WSRLength of\r\n 0:\r\n raise EJVCLException.CreateRes(@RsENodeNameCannotContainSpaces);\r\n 1:\r\n FixedNodeName[InsertIndex] := WhiteSpaceReplacement[1];\r\n else\r\n for K := 1 to WSRLength do\r\n begin\r\n FixedNodeName[InsertIndex] := WhiteSpaceReplacement[K];\r\n Inc(InsertIndex);\r\n Inc(CurLength);\r\n SetLength(FixedNodeName, CurLength);\r\n end;\r\n end // case WSRLength of\r\n else\r\n if not CharInSet(NodeName[J], AllowedNodeNameChars) then\r\n case ICRLength of\r\n 0:\r\n raise EJVCLException.CreateResFmt(@RsENodeNameCannotInvalidChars, [NodeName[J]]);\r\n 1:\r\n FixedNodeName[InsertIndex] := InvalidCharReplacement[1];\r\n else\r\n for K := 1 to ICRLength do\r\n begin\r\n FixedNodeName[InsertIndex] := InvalidCharReplacement[K];\r\n Inc(InsertIndex);\r\n Inc(CurLength);\r\n SetLength(FixedNodeName, CurLength);\r\n end;\r\n end // case WSRLength of\r\n else\r\n FixedNodeName[InsertIndex] := NodeName[J];\r\n end;\r\n Result := FixedNodeName;\r\nend;\r\n\r\nprocedure TJvCustomAppXMLStorage.SetRootNodeName(const Value: string);\r\nbegin\r\n if Value = '' then\r\n raise EPropertyError.CreateRes(@RsENodeCannotBeEmpty)\r\n else\r\n begin\r\n Xml.Root.Name := CheckNodeNameCharacters(Value);\r\n Root := Value;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomAppXMLStorage.SplitKeyPath(const Path: string; out Key, ValueName: string);\r\nvar\r\n Index: Integer;\r\nbegin\r\n inherited SplitKeyPath(Path, Key, ValueName);\r\n if SplitNodeNameIndex (ValueName, Index) then\r\n ValueName := ItemNameIndexPath(ValueName, Index); // Recombine both values again for strings which have value in an indexed path directly\r\n if Key = '' then\r\n Key := Path;\r\nend;\r\n\r\nfunction TJvCustomAppXMLStorage.ValueStoredInt(const Path: string): Boolean;\r\nvar\r\n Section: string;\r\n ValueName: string;\r\n Node: TJvSimpleXmlElem;\r\nbegin\r\n ReloadIfNeeded;\r\n SplitKeyPath(Path, Section, ValueName);\r\n Node := GetNodeFromPath(Section);\r\n Result := Assigned(GetValueElementFromNode(Node, ValueName));\r\nend;\r\n\r\nprocedure TJvCustomAppXMLStorage.DeleteValueInt(const Path: string);\r\nvar\r\n Node: TJvSimpleXmlElem;\r\n Section: string;\r\n ValueName: string;\r\n Index: Integer;\r\nbegin\r\n if ValueStored(Path) then\r\n begin\r\n ReloadIfNeeded;\r\n SplitKeyPath(Path, Section, ValueName);\r\n Node := GetNodeFromPath(Section);\r\n\r\n if Assigned(Node) then\r\n begin\r\n if SplitNodeNameIndex(ValueName, Index) then\r\n Node.Items.NamedElems[ValueName].Delete(Index)\r\n else\r\n Node.Items.Delete(ValueName);\r\n end;\r\n FlushIfNeeded;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomAppXMLStorage.DeleteSubTreeInt(const Path: string);\r\nvar\r\n TopNode: string;\r\n Node: TJvSimpleXmlElem;\r\n Parent: TJvSimpleXmlElem;\r\n Name: string;\r\nbegin\r\n ReloadIfNeeded;\r\n TopNode := GetAbsPath(Path);\r\n if TopNode = '' then\r\n TopNode := Path;\r\n Node := GetNodeFromPath(TopNode);\r\n if Assigned(Node) then\r\n begin\r\n Name := Node.Name;\r\n Parent := Node.Parent;\r\n if Assigned(Parent) then\r\n Parent.Items.Delete(Name)\r\n else\r\n Node.Clear;\r\n FlushIfNeeded;\r\n end;\r\nend;\r\n\r\nfunction TJvCustomAppXMLStorage.DoReadInteger(const Path: string; Default: Integer): Integer;\r\nvar\r\n ParentPath: string;\r\n ValueName: string;\r\n Node: TJvSimpleXmlElem;\r\n ValueElem: TJvSimpleXmlElem;\r\nbegin\r\n ReloadIfNeeded;\r\n SplitKeyPath(Path, ParentPath, ValueName);\r\n\r\n Node := GetNodeFromPath(ParentPath);\r\n\r\n ValueElem := GetValueElementFromNode(Node, ValueName);\r\n if Assigned(ValueElem) then\r\n begin\r\n try\r\n Result := ValueElem.IntValue;\r\n except\r\n if StorageOptions.DefaultIfReadConvertError then\r\n Result := Default\r\n else\r\n raise;\r\n end;\r\n end\r\n else\r\n if StorageOptions.DefaultIfValueNotExists then\r\n Result := Default\r\n else\r\n raise EJVCLException.CreateResFmt(@RsEPathDoesntExists, [Path]);\r\nend;\r\n\r\nprocedure TJvCustomAppXMLStorage.DoWriteInteger(const Path: string; Value: Integer);\r\nvar\r\n ParentPath: string;\r\n ValueName: string;\r\n Node: TJvSimpleXmlElem;\r\n ValueElem: TJvSimpleXMLElem;\r\nbegin\r\n ReloadIfNeeded;\r\n SplitKeyPath(Path, ParentPath, ValueName);\r\n Node := CreateAndSetNode(ParentPath);\r\n Xml.Options := Xml.Options + [sxoAutoCreate];\r\n ValueElem := GetValueElementFromNode(Node, ValueName);\r\n if Assigned(ValueElem) then\r\n ValueElem.IntValue := Value;\r\n Xml.Options := Xml.Options - [sxoAutoCreate];\r\n FlushIfNeeded;\r\nend;\r\n\r\nfunction TJvCustomAppXMLStorage.DoReadFloat(const Path: string; Default: Extended): Extended;\r\nvar\r\n ParentPath: string;\r\n ValueName: string;\r\n StrValue: string;\r\n Node: TJvSimpleXmlElem;\r\n ValueElem: TJvSimpleXMLElem;\r\n {$IFDEF CPUX64}\r\n Ext80Value: Extended80;\r\n {$ENDIF CPUX64}\r\nbegin\r\n ReloadIfNeeded;\r\n SplitKeyPath(Path, ParentPath, ValueName);\r\n\r\n Node := GetNodeFromPath(ParentPath);\r\n\r\n ValueElem := GetValueElementFromNode(Node, ValueName);\r\n if Assigned(ValueElem) then\r\n begin\r\n try\r\n StrValue := ValueElem.Value;\r\n {$IFDEF CPUX64}\r\n // Keep backward compatiblity to x86 Extended type\r\n if BinStrToBuf(StrValue, @Ext80Value, SizeOf(Ext80Value)) = SizeOf(Ext80Value) then\r\n try\r\n Result := Ext80Value\r\n except\r\n Result := Default;\r\n end\r\n else\r\n {$ELSE}\r\n if BinStrToBuf(StrValue, @Result, SizeOf(Result)) <> SizeOf(Result) then\r\n {$ENDIF CPUX64}\r\n Result := Default;\r\n except\r\n if StorageOptions.DefaultIfReadConvertError then\r\n Result := Default\r\n else\r\n raise;\r\n end;\r\n end\r\n else\r\n if StorageOptions.DefaultIfValueNotExists then\r\n Result := Default\r\n else\r\n raise EJVCLException.CreateResFmt(@RsEPathDoesntExists, [Path]);\r\nend;\r\n\r\nprocedure TJvCustomAppXMLStorage.DoWriteFloat(const Path: string; Value: Extended);\r\nvar\r\n ParentPath: string;\r\n ValueName: string;\r\n Node: TJvSimpleXmlElem;\r\n ValueElem: TJvSimpleXMLElem;\r\n {$IFDEF CPUX64}\r\n Ext80Value: Extended80;\r\n {$ENDIF CPUX64}\r\nbegin\r\n ReloadIfNeeded;\r\n SplitKeyPath(Path, ParentPath, ValueName);\r\n Node := CreateAndSetNode(ParentPath);\r\n Xml.Options := Xml.Options + [sxoAutoCreate];\r\n ValueElem := GetValueElementFromNode(Node, ValueName);\r\n if Assigned(ValueElem) then\r\n begin\r\n {$IFDEF CPUX64}\r\n // Keep backward compatiblity to x86 Extended type\r\n Ext80Value := Value;\r\n ValueElem.Value := BufToBinStr(@Ext80Value, SizeOf(Ext80Value));\r\n {$ELSE}\r\n ValueElem.Value := BufToBinStr(@Value, SizeOf(Value));\r\n {$ENDIF CPUX64}\r\n end;\r\n Xml.Options := Xml.Options - [sxoAutoCreate];\r\n FlushIfNeeded;\r\nend;\r\n\r\nfunction TJvCustomAppXMLStorage.DoReadString(const Path: string; const Default: string): string;\r\nvar\r\n ParentPath: string;\r\n ValueName: string;\r\n Node: TJvSimpleXmlElem;\r\n ValueElem: TJvSimpleXMLElem;\r\nbegin\r\n ReloadIfNeeded;\r\n SplitKeyPath(Path, ParentPath, ValueName);\r\n\r\n Node := GetNodeFromPath(ParentPath);\r\n\r\n ValueElem := GetValueElementFromNode(Node, ValueName);\r\n if Assigned(ValueElem) then\r\n try\r\n Result := ValueElem.Value;\r\n except\r\n if StorageOptions.DefaultIfReadConvertError then\r\n Result := Default\r\n else\r\n raise;\r\n end\r\n else\r\n if StorageOptions.DefaultIfValueNotExists then\r\n Result := Default\r\n else\r\n raise EJVCLException.CreateResFmt(@RsEPathDoesntExists, [Path]);\r\nend;\r\n\r\nprocedure TJvCustomAppXMLStorage.DoWriteString(const Path: string; const Value: string);\r\nvar\r\n ParentPath: string;\r\n ValueName: string;\r\n Node: TJvSimpleXmlElem;\r\n ValueElem: TJvSimpleXMLElem;\r\nbegin\r\n ReloadIfNeeded;\r\n SplitKeyPath(Path, ParentPath, ValueName);\r\n Node := CreateAndSetNode(ParentPath);\r\n Xml.Options := Xml.Options + [sxoAutoCreate];\r\n ValueElem := GetValueElementFromNode(Node, ValueName);\r\n if Assigned(ValueElem) then\r\n ValueElem.Value := Value;\r\n Xml.Options := Xml.Options - [sxoAutoCreate];\r\n FlushIfNeeded;\r\nend;\r\n\r\nfunction TJvCustomAppXMLStorage.DoReadBinary(const Path: string; Buf: TJvBytes; BufSize: Integer): Integer;\r\nvar\r\n Value: string;\r\nbegin\r\n ReloadIfNeeded;\r\n Value := DoReadString(Path, '');\r\n Result := BinStrToBuf(Value, Buf, BufSize);\r\nend;\r\n\r\nprocedure TJvCustomAppXMLStorage.DoWriteBinary(const Path: string; const Buf: TJvBytes; BufSize: Integer);\r\nbegin\r\n ReloadIfNeeded;\r\n DoWriteString(Path, BufToBinStr(Buf, BufSize));\r\n FlushIfNeeded;\r\nend;\r\n\r\nprocedure TJvCustomAppXMLStorage.EnumFolders(const Path: string; const Strings: TStrings; const ReportListAsValue:\r\n Boolean = True);\r\nvar\r\n RefPath: string;\r\n I: Integer;\r\n Node: TJvSimpleXmlElem;\r\nbegin\r\n ReloadIfNeeded;\r\n RefPath := GetAbsPath(Path);\r\n if RefPath = '' then\r\n RefPath := cEmptyPath;\r\n\r\n Node := GetNodeFromPath(RefPath);\r\n\r\n if Node <> nil then\r\n begin\r\n Strings.BeginUpdate;\r\n try\r\n Strings.Clear;\r\n for I := 0 to Node.Items.Count - 1 do\r\n if Node.Items[i].Items.Count > 0 then\r\n Strings.Add(Node.Items[I].Name);\r\n finally\r\n Strings.EndUpdate;\r\n end;\r\n end\r\n// else\r\n// raise EJVCLException.CreateResFmt(@RsEPathDoesntExists, [RefPath]);\r\nend;\r\n\r\nprocedure TJvCustomAppXMLStorage.EnumValues(const Path: string; const Strings: TStrings; const ReportListAsValue:\r\n Boolean = True);\r\nvar\r\n PathIsList: Boolean;\r\n RefPath: string;\r\n I: Integer;\r\n Node: TJvSimpleXmlElem;\r\n Name: string;\r\nbegin\r\n ReloadIfNeeded;\r\n PathIsList := ReportListAsValue and ListStored(Path);\r\n RefPath := GetAbsPath(Path);\r\n if RefPath = '' then\r\n RefPath := cEmptyPath;\r\n\r\n Node := GetNodeFromPath(RefPath);\r\n\r\n if Node <> nil then\r\n begin\r\n Strings.BeginUpdate;\r\n try\r\n Strings.Clear;\r\n for I := 0 to Node.Items.Count - 1 do\r\n begin\r\n Name := Node.Items[I].Name;\r\n if (not PathIsList or (not AnsiSameText(cCount, Name) and\r\n not NameIsListItem(Name))) //and not IsFolder(FullName)\r\n then\r\n Strings.Add(Name);\r\n end;\r\n i := Strings.Count-1;\r\n while i >= 0 do\r\n begin\r\n if ListStored(ConcatPaths([Path, Strings[i]])) or IsFolder(ConcatPaths([Path, Strings[i]])) then\r\n Strings.Delete(i);\r\n Dec(i);\r\n end;\r\n finally\r\n Strings.EndUpdate;\r\n end;\r\n end\r\n// else\r\n// raise EJVCLException.CreateResFmt(@RsEPathDoesntExists, [RefPath]);\r\nend;\r\n\r\nfunction TJvCustomAppXMLStorage.IsFolderInt(const Path: string;\r\n ListIsValue: Boolean): Boolean;\r\nvar\r\n RefPath: string;\r\n ValueNames: TStrings;\r\n I: Integer;\r\n Node: TJvSimpleXmlElem;\r\n Name: string;\r\nbegin\r\n ReloadIfNeeded;\r\n RefPath := GetAbsPath(Path);\r\n if RefPath = '' then\r\n RefPath := cEmptyPath;\r\n\r\n Node := GetNodeFromPath(RefPath);\r\n if Assigned(Node) then\r\n if ListIsValue and Assigned(Node.Items.ItemNamed[cCount]) then\r\n begin\r\n ValueNames := TStringList.Create;\r\n try\r\n I := 0;\r\n repeat\r\n Name := Node.Items[I].Name;\r\n Result := not AnsiSameText(cCount, Name) and not NameIsListItem(Name);\r\n Inc(I);\r\n until (I = Node.Items.Count) or Result;\r\n finally\r\n ValueNames.Free;\r\n end;\r\n end\r\n else\r\n Result := Node.Items.Count>0\r\n else\r\n Result := False;\r\nend;\r\n\r\n\r\nfunction TJvCustomAppXMLStorage.GetRootNodeName: string;\r\nbegin\r\n Result := Xml.Root.Name;\r\nend;\r\n\r\nfunction TJvCustomAppXMLStorage.CreateAndSetNode(Key: string): TJvSimpleXmlElem;\r\nbegin\r\n Xml.Options := Xml.Options + [sxoAutoCreate];\r\n Result := GetNodeFromPath(Key);\r\n Xml.Options := Xml.Options - [sxoAutoCreate];\r\nend;\r\n\r\nfunction TJvCustomAppXMLStorage.GetNodeFromPath(Path: string; StartNode: TJvSimpleXmlElem = nil): TJvSimpleXmlElem;\r\nvar\r\n NodeList: TStringList;\r\n I: Integer;\r\n Node: TJvSimpleXmlElem;\r\n NodeName: string;\r\n Index : Integer;\r\n\r\nbegin\r\n Result := nil;\r\n\r\n ReloadIfNeeded;\r\n NodeList := TStringList.Create;\r\n if StartNode <> nil then\r\n Node := StartNode\r\n else\r\n Node := Xml.Root;\r\n\r\n try\r\n try\r\n StrToStrings(Path, '\\', NodeList, False);\r\n for I := 0 to NodeList.Count - 1 do\r\n begin\r\n // Node names cannot have spaces in them so we replace\r\n // those spaces by the replacement string. If there is\r\n // no such string, we trigger an exception as the XML\r\n // standard doesn't allow spaces in node names\r\n\r\n NodeName := NodeList[I];\r\n\r\n SplitNodeNameIndex(NodeName, Index);\r\n\r\n // If the name is the same as the root AND the first in\r\n if not ((I = 0) and (NodeName = Xml.Root.Name)) then\r\n if Index >= 0 then\r\n if Assigned(Node.Items.NamedElems[NodeName].Item[Index]) then\r\n Node := Node.Items.NamedElems[NodeName].Item[Index]\r\n else\r\n Exit\r\n else\r\n if Assigned(Node.Items.ItemNamed[NodeName]) then\r\n Node := Node.Items.ItemNamed[NodeName]\r\n else\r\n Exit;\r\n end;\r\n finally\r\n NodeList.Free;\r\n end;\r\n except\r\n Node := nil;\r\n end;\r\n Result := Node;\r\nend;\r\n\r\nfunction TJvCustomAppXMLStorage.PathExistsInt(const Path: string): Boolean;\r\nvar\r\n SubKey: string;\r\n ValueName: string;\r\n Node: TJvSimpleXmlElem;\r\nbegin\r\n Result := False;\r\n SplitKeyPath(Path, SubKey, ValueName);\r\n Node := GetNodeFromPath(SubKey);\r\n if Assigned(Node) then\r\n Result := Assigned(Node.Items.ItemNamed[ValueName]);\r\nend;\r\n\r\nfunction TJvCustomAppXMLStorage.DoReadBoolean(const Path: string;\r\n Default: Boolean): Boolean;\r\nvar\r\n ParentPath: string;\r\n ValueName: string;\r\n Node: TJvSimpleXmlElem;\r\nbegin\r\n ReloadIfNeeded;\r\n SplitKeyPath(Path, ParentPath, ValueName);\r\n\r\n Node := GetNodeFromPath(ParentPath);\r\n\r\n if Assigned(Node) and Assigned(Node.Items.ItemNamed[ValueName]) then\r\n try\r\n Result := Node.Items.ItemNamed[ValueName].BoolValue;\r\n except\r\n if StorageOptions.DefaultIfReadConvertError then\r\n Result := Default\r\n else\r\n raise;\r\n end\r\n else\r\n if StorageOptions.DefaultIfValueNotExists then\r\n Result := Default\r\n else\r\n raise EJVCLException.CreateResFmt(@RsEPathDoesntExists, [Path]);\r\nend;\r\n\r\nprocedure TJvCustomAppXMLStorage.DoWriteBoolean(const Path: string;\r\n Value: Boolean);\r\nvar\r\n ParentPath: string;\r\n ValueName: string;\r\n ANode: TJvSimpleXmlElem;\r\nbegin\r\n ReloadIfNeeded;\r\n SplitKeyPath(Path, ParentPath, ValueName);\r\n ANode := CreateAndSetNode(ParentPath);\r\n Xml.Options := Xml.Options + [sxoAutoCreate];\r\n ANode.Items.ItemNamed[ValueName].BoolValue := Value;\r\n Xml.Options := Xml.Options - [sxoAutoCreate];\r\n FlushIfNeeded;\r\nend;\r\n\r\nfunction TJvCustomAppXMLStorage.GetAsString: string;\r\nbegin\r\n Result := Xml.SaveToString;\r\nend;\r\n\r\nprocedure TJvCustomAppXMLStorage.SetAsString(const Value: string);\r\nbegin\r\n Xml.LoadFromString(Value);\r\nend;\r\n\r\nfunction TJvCustomAppXMLStorage.DefaultExtension: string;\r\nbegin\r\n Result := 'xml';\r\nend;\r\n\r\nfunction TJvCustomAppXMLStorage.GetOnDecodeValue: TJvSimpleXMLEncodeEvent;\r\nbegin\r\n Result := FXml.OnDecodeValue;\r\nend;\r\n\r\nfunction TJvCustomAppXMLStorage.GetOnEncodeValue: TJvSimpleXMLEncodeEvent;\r\nbegin\r\n Result := FXml.OnEncodeValue;\r\nend;\r\n\r\nprocedure TJvCustomAppXMLStorage.SetOnDecodeValue(const Value: TJvSimpleXMLEncodeEvent);\r\nbegin\r\n FXml.OnDecodeValue := Value;\r\nend;\r\n\r\nprocedure TJvCustomAppXMLStorage.SetOnEncodeValue(const Value: TJvSimpleXMLEncodeEvent);\r\nbegin\r\n FXml.OnEncodeValue := Value;\r\nend;\r\n\r\nfunction TJvCustomAppXMLStorage.GetStorageOptions: TJvAppXMLStorageOptions;\r\nbegin\r\n Result := TJvAppXMLStorageOptions(inherited StorageOptions);\r\nend;\r\n\r\nfunction TJvCustomAppXMLStorage.ListStoredInt(const Path: string; const ItemName: string = cItem): Boolean;\r\nbegin\r\n if StorageOptions.UseOldItemNameFormat then\r\n Result := Inherited ListStoredInt(Path, ItemName)\r\n else\r\n Result := ReadListItemCount (Path, ItemName) > 0;\r\nend;\r\n\r\nfunction TJvCustomAppXMLStorage.ReadListItemCount(const Path: string; const ItemName: string = cItem): Integer;\r\nvar\r\n Node: TJvSimpleXmlElem;\r\nbegin\r\n if StorageOptions.UseOldItemNameFormat then\r\n Result := Inherited ReadListItemCount(Path, ItemName)\r\n else\r\n begin\r\n Node := GetNodeFromPath(Path);\r\n if Assigned(Node) then\r\n Result := Node.Items.NamedElems[CheckNodeNameCharacters(Trim(ItemName))].Count\r\n else\r\n Result := 0;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomAppXMLStorage.SetStorageOptions(Value: TJvAppXMLStorageOptions);\r\nbegin\r\n (Inherited StorageOptions).Assign(Value);\r\nend;\r\n\r\nfunction TJvCustomAppXMLStorage.SplitNodeNameIndex(var sNodeName : String; var sIndex : Integer): Boolean;\r\nvar sh : string;\r\n p: Integer;\r\nbegin\r\n sIndex := -1;\r\n Result := False;\r\n if StorageOptions.UseOldItemNameFormat then\r\n begin\r\n sNodeName := CheckNodeNameCharacters(sNodeName);\r\n Exit;\r\n end;\r\n sh := trim(sNodeName);\r\n p := Pos(']', sh);\r\n if p <> Length(sh) then\r\n begin\r\n sNodeName := CheckNodeNameCharacters(sNodeName);\r\n Exit;\r\n end;\r\n p := CharLastPos(sh, '[');\r\n if p > 0 then\r\n begin\r\n try\r\n sIndex := StrToInt(Copy(sh, p+1, Length(sh)-p-1));\r\n sNodeName := CheckNodeNameCharacters(trim(Copy(sNodeName, 1, p-1)));\r\n except\r\n on e:exception do\r\n end;\r\n end;\r\n Result := sIndex >= 0;\r\nend;\r\n\r\nprocedure TJvCustomAppXMLStorage.WriteListItemCount(const Path: string; const ItemCount: Integer; const ItemName:\r\n string = cItem);\r\nbegin\r\n if StorageOptions.UseOldItemNameFormat then\r\n Inherited WriteListItemCount(Path, ItemCount, ItemName)\r\n else\r\n // No Write necessary\r\nend;\r\n\r\nprocedure TJvAppXMLFileStorage.ClearInternal;\r\nbegin\r\n Xml.Root.Clear;\r\nend;\r\n\r\nprocedure TJvAppXMLFileStorage.FlushInternal;\r\nbegin\r\n Xml.SaveToFile(FullFileName, StorageOptions.Encoding, StorageOptions.CodePage);\r\nend;\r\n\r\nprocedure TJvAppXMLFileStorage.ReloadInternal;\r\nbegin\r\n Xml.LoadFromFile(FullFileName, StorageOptions.Encoding, StorageOptions.CodePage);\r\nend;\r\n\r\n//=== { Common procedures } ==================================================\r\n\r\nprocedure StorePropertyStoreToXmlFile(APropertyStore: TJvCustomPropertyStore; const AFileName: string; const\r\n AAppStoragePath: string = ''; AStorageOptions: TJvCustomAppStorageOptions = nil);\r\nvar\r\n AppStorage: TJvAppXMLFileStorage;\r\n SaveAppStorage: TJvCustomAppStorage;\r\n SaveAppStoragePath: string;\r\nbegin\r\n if not Assigned(APropertyStore) then\r\n Exit;\r\n AppStorage := TJvAppXMLFileStorage.Create(nil);\r\n try\r\n AppStorage.StorageOptions.WhiteSpaceReplacement := '_';\r\n AppStorage.StorageOptions.UseOldItemNameFormat := False;\r\n AppStorage.FlushOnDestroy := False;\r\n AppStorage.SynchronizeFlushReload := True;\r\n if Assigned(AStorageOptions) then\r\n AppStorage.StorageOptions.Assign(AStorageOptions);\r\n AppStorage.Location := flCustom;\r\n AppStorage.FileName := AFileName;\r\n SaveAppStorage := APropertyStore.AppStorage;\r\n SaveAppStoragePath := APropertyStore.AppStoragePath;\r\n try\r\n APropertyStore.AppStoragePath := AAppStoragePath;\r\n APropertyStore.AppStorage := AppStorage;\r\n APropertyStore.StoreProperties;\r\n finally\r\n APropertyStore.AppStoragePath := SaveAppStoragePath;\r\n APropertyStore.AppStorage := SaveAppStorage;\r\n end;\r\n finally\r\n AppStorage.Free;\r\n end;\r\nend;\r\n\r\nprocedure LoadPropertyStoreFromXmlFile(APropertyStore: TJvCustomPropertyStore; const AFileName: string; const\r\n AAppStoragePath: string = ''; AStorageOptions: TJvCustomAppStorageOptions = nil);\r\nvar\r\n AppStorage: TJvAppXMLFileStorage;\r\n SaveAppStorage: TJvCustomAppStorage;\r\n SaveAppStoragePath: string;\r\nbegin\r\n if not Assigned(APropertyStore) then\r\n Exit;\r\n AppStorage := TJvAppXMLFileStorage.Create(nil);\r\n try\r\n AppStorage.StorageOptions.WhiteSpaceReplacement := '_';\r\n AppStorage.StorageOptions.UseOldItemNameFormat := False;\r\n AppStorage.FlushOnDestroy := False;\r\n AppStorage.SynchronizeFlushReload := True;\r\n if Assigned(AStorageOptions) then\r\n AppStorage.StorageOptions.Assign(AStorageOptions);\r\n AppStorage.Location := flCustom;\r\n AppStorage.FileName := AFileName;\r\n SaveAppStorage := APropertyStore.AppStorage;\r\n SaveAppStoragePath := APropertyStore.AppStoragePath;\r\n try\r\n APropertyStore.AppStoragePath := AAppStoragePath;\r\n APropertyStore.AppStorage := AppStorage;\r\n APropertyStore.LoadProperties;\r\n finally\r\n APropertyStore.AppStoragePath := SaveAppStoragePath;\r\n APropertyStore.AppStorage := SaveAppStorage;\r\n end;\r\n finally\r\n AppStorage.Free;\r\n end;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvArrayButton.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvArrayButton.PAS, released on 2002-06-15.\r\n\r\nThe Initial Developer of the Original Code is Jan Verhoeven [jan1 dott verhoeven att wxs dott nl]\r\nPortions created by Jan Verhoeven are Copyright (C) 2002 Jan Verhoeven.\r\nAll Rights Reserved.\r\n\r\nContributor(s): Robert Love [rlove att slcdug dott org].\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvArrayButton.pas 13104 2011-09-07 06:50:43Z obones $\r\n\r\nunit JvArrayButton;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, Messages, Classes, Graphics, Controls, Forms, Types,\r\n JvComponent, JvTypes;\r\n\r\ntype\r\n TArrayButtonClicked = procedure(ACol, ARow: Integer) of object;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvArrayButton = class(TJvGraphicControl)\r\n private\r\n FPtDown: TPoint;\r\n FPushDown: Boolean;\r\n FColor: TColor;\r\n FRows: Integer;\r\n FCols: Integer;\r\n FOnArrayButtonClicked: TArrayButtonClicked;\r\n FCaptions: TStringList;\r\n FColors: TStringList;\r\n FHints: THintStringList;\r\n FEnableds: array of Boolean;\r\n {$IFDEF JVCLThemesEnabled}\r\n FMouseOverBtn: TPoint;\r\n FThemed: Boolean;\r\n procedure SetThemed(Value: Boolean);\r\n {$ENDIF JVCLThemesEnabled}\r\n function GetCaptions: TStrings;\r\n function GetColors: TStrings;\r\n procedure SetCols(const Value: Integer);\r\n procedure SetRows(const Value: Integer);\r\n procedure SetCaptions(const Value: TStrings);\r\n procedure SetColors(const Value: TStrings);\r\n procedure MouseToCell(const X, Y: Integer; var ACol, ARow: Integer);\r\n function CellRect(ACol, ARow: Integer): TRect;\r\n procedure SetHints(const Value: THintStringList);\r\n function GetEnableds(Index: Integer): Boolean;\r\n procedure SetEnableds(Index: Integer; const Value: Boolean);\r\n protected\r\n procedure FontChanged; override;\r\n procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;\r\n procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;\r\n {$IFDEF JVCLThemesEnabled}\r\n procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;\r\n procedure MouseEnter(AControl: TControl); override;\r\n procedure MouseLeave(AControl: TControl); override;\r\n {$ENDIF JVCLThemesEnabled}\r\n procedure Paint; override;\r\n procedure SizeChanged; dynamic;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n\r\n {this procedure can be used in response to a Application.OnShowHint event\r\n button hints are stored in the hints property from array top-left to array bottom right\r\n in your application create a seperate OnShowHint event Handler\r\n within that Handler test HintInfo.HintControl is this object. If it is dispatch to this objects doShowHint.\r\n In the FormCreate event handler include:\r\n Application.OnShowHint := DrawHint;\r\n\r\n procedure TDrawF.DrawHint(var HintStr: string; var CanShow: Boolean;\r\n var HintInfo: THintInfo);\r\n begin\r\n if HintInfo.HintControl = JvArrayButton1 then\r\n JvArrayButton1.DoShowHint(HintStr, CanShow, HintInfo);\r\n end;\r\n\r\n I could have set the Application.OnShowHint handler directly in this component,\r\n but if you have more components that do this then only the last one would work\r\n }\r\n procedure DoShowHint(var HintStr: THintString;\r\n var CanShow: Boolean; var HintInfo: THintInfo);\r\n\r\n // A list of individual button Enabled state, from the top-left to the bottom-right button\r\n property Enableds[Index: Integer]: Boolean read GetEnableds write SetEnableds;\r\n published\r\n property Align;\r\n property Anchors;\r\n property Rows: Integer read FRows write SetRows;\r\n property Cols: Integer read FCols write SetCols;\r\n {A List of button captions from the top-left to the bottom-right button}\r\n property Captions: TStrings read GetCaptions write SetCaptions;\r\n property Enabled;\r\n property Font;\r\n property Height default 35;\r\n {A List of button hints from the top-left to the bottom-right button}\r\n property Hints: THintStringList read FHints write SetHints;\r\n {A List of button Colors from the top-left to the bottom-right button\r\n values must be standard Delphi Color names like clRed, clBlue or hex Color strings like $0000ff for red.\r\n please note the hex order in Delphi is BGR i.s.o. the RGB order you may know from HTML hex Color triplets}\r\n property Colors: TStrings read GetColors write SetColors;\r\n property Hint;\r\n property ShowHint default True;\r\n {$IFDEF JVCLThemesEnabled}\r\n property Themed: Boolean read FThemed write SetThemed default False;\r\n {$ENDIF JVCLThemesEnabled}\r\n property Visible;\r\n property Width default 35;\r\n {provides you with the Column and Row of the clicked button\r\n the topleft button has Column=0 and Row=0}\r\n property OnArrayButtonClicked: TArrayButtonClicked read FOnArrayButtonClicked write FOnArrayButtonClicked;\r\n property OnCanResize;\r\n property OnMouseDown;\r\n {$IFDEF COMPILER9_UP}\r\n property OnMouseEnter;\r\n property OnMouseLeave;\r\n {$ENDIF COMPILER9_UP}\r\n property OnMouseMove;\r\n property OnMouseUp;\r\n property OnMouseWheel;\r\n property OnMouseWheelDown;\r\n property OnMouseWheelUp;\r\n property OnResize;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvArrayButton.pas $';\r\n Revision: '$Revision: 13104 $';\r\n Date: '$Date: 2011-09-07 08:50:43 +0200 (mer. 07 sept. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n ExtCtrls, Buttons,\r\n JvJCLUtils, JvThemes;\r\n\r\nconstructor TJvArrayButton.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n Width := 35;\r\n Height := 35;\r\n FColor := clSilver;\r\n FPushDown := False;\r\n FCols := 1;\r\n FRows := 1;\r\n ShowHint := True;\r\n FCaptions := TStringList.Create;\r\n FHints := THintStringList.Create;\r\n FColors := TStringList.Create;\r\n {$IFDEF JVCLThemesEnabled}\r\n FThemed := False;\r\n FMouseOverBtn := Point(-1, -1);\r\n {$ENDIF JVCLThemesEnabled}\r\nend;\r\n\r\ndestructor TJvArrayButton.Destroy;\r\nbegin\r\n FCaptions.Free;\r\n FHints.Free;\r\n FColors.Free;\r\n SetLength(FEnableds, 0);\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvArrayButton.MouseToCell(const X, Y: Integer; var ACol, ARow: Integer);\r\nvar\r\n DH, DW: Integer;\r\nbegin\r\n DH := (Height - 2) div Rows;\r\n DW := (Width - 2) div Cols;\r\n ACol := X div DW;\r\n ARow := Y div DH;\r\nend;\r\n\r\nprocedure TJvArrayButton.MouseDown(Button: TMouseButton;\r\n Shift: TShiftState; X, Y: Integer);\r\nvar\r\n Col, Row: Integer;\r\nbegin\r\n if Button = mbLeft then\r\n begin\r\n MouseToCell(X, Y, Col, Row);\r\n if FEnableds[Row * Cols + Col] then\r\n begin\r\n FPushDown := True;\r\n FPtDown := Point(Col, Row);\r\n Invalidate;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvArrayButton.MouseUp(Button: TMouseButton; Shift: TShiftState;\r\n X, Y: Integer);\r\nbegin\r\n if (Button = mbLeft) and FPushDown then\r\n begin\r\n if FEnableds[FPtDown.Y * Cols + FPtDown.X] then\r\n begin\r\n FPushDown := False;\r\n Invalidate;\r\n if Assigned(FOnArrayButtonClicked) then\r\n OnArrayButtonClicked(FPtDown.X, FPtDown.Y);\r\n end;\r\n end\r\nend;\r\n\r\n{$IFDEF JVCLThemesEnabled}\r\n\r\nprocedure TJvArrayButton.MouseMove(Shift: TShiftState; X, Y: Integer);\r\nvar\r\n Pt: TPoint;\r\nbegin\r\n inherited MouseMove(Shift, X, Y);\r\n MouseToCell(X, Y, Pt.X, Pt.Y);\r\n if (not FPushDown) and\r\n ((Pt.X <> FMouseOverBtn.X) or (Pt.Y <> FMouseOverBtn.Y)) then\r\n begin\r\n FMouseOverBtn := Pt;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvArrayButton.MouseEnter(AControl: TControl);\r\nbegin\r\n inherited MouseEnter(AControl);\r\n Repaint;\r\nend;\r\n\r\nprocedure TJvArrayButton.MouseLeave(AControl: TControl);\r\nbegin\r\n inherited MouseLeave(AControl);\r\n Repaint;\r\nend;\r\n\r\n{$ENDIF JVCLThemesEnabled}\r\n\r\nprocedure TJvArrayButton.Paint;\r\nvar\r\n R: TRect;\r\n Col, Row: Integer;\r\n DH, DW: Integer;\r\n X0, Y0: Integer;\r\n Cap: string;\r\n BackColor: TColor;\r\n Index: Integer;\r\n\r\n procedure DrawBackground(AColor: TColor);\r\n begin\r\n Canvas.Brush.Color := AColor;\r\n DrawThemedBackground(Self, Canvas, R);\r\n end;\r\n\r\n procedure DrawUp;\r\n begin\r\n {$IFDEF JVCLThemesEnabled}\r\n if Themed and ThemeServices.{$IFDEF RTL230_UP}Enabled{$ELSE}ThemesEnabled{$ENDIF RTL230_UP} then\r\n begin\r\n R := DrawThemedButtonFace(Self, Canvas, R, 0, bsAutoDetect, False, False, False,\r\n PtInRect(R, ScreenToClient(Mouse.CursorPos)));\r\n SetBkMode(Canvas.Handle, Windows.TRANSPARENT);\r\n end\r\n else\r\n {$ENDIF JVCLThemesEnabled}\r\n begin\r\n DrawBackground(BackColor);\r\n Frame3D(Self.Canvas, R, clBtnHighlight, clBlack, 1);\r\n end;\r\n if Cap <> '' then\r\n DrawText(Canvas, Cap, -1, R, DT_CENTER or DT_VCENTER or DT_SINGLELINE);\r\n end;\r\n\r\n procedure DrawDown;\r\n begin\r\n {$IFDEF JVCLThemesEnabled}\r\n if Themed and ThemeServices.{$IFDEF RTL230_UP}Enabled{$ELSE}ThemesEnabled{$ENDIF RTL230_UP} then\r\n begin\r\n R := DrawThemedButtonFace(Self, Canvas, R, 0, bsAutoDetect, False, True, False,\r\n PtInRect(R, ScreenToClient(Mouse.CursorPos)));\r\n SetBkMode(Canvas.Handle, Windows.TRANSPARENT);\r\n end\r\n else\r\n {$ENDIF JVCLThemesEnabled}\r\n begin\r\n DrawBackground(BackColor);\r\n Frame3D(Self.Canvas, R, clBlack, clBtnHighlight, 1);\r\n end;\r\n if Cap <> '' then\r\n DrawText(Canvas, Cap, -1, R, DT_CENTER or DT_VCENTER or DT_SINGLELINE);\r\n end;\r\n\r\nbegin\r\n DH := (Height - 2) div Rows;\r\n DW := (Width - 2) div Cols;\r\n for Row := 0 to Rows - 1 do\r\n begin\r\n Y0 := 1 + Row * DH;\r\n for Col := 0 to Cols - 1 do\r\n begin\r\n X0 := 1 + Col * DW;\r\n R := Rect(X0, Y0, X0 + DW, Y0 + DH);\r\n Index := Row * Cols + Col;\r\n if Index < Captions.Count then\r\n Cap := Captions[Index]\r\n else\r\n Cap := '';\r\n if Index < Colors.Count then\r\n try\r\n BackColor := StringToColor(Colors[Index]);\r\n except\r\n BackColor := clSilver;\r\n end\r\n else\r\n BackColor := clSilver;\r\n if (csDesigning in ComponentState) then\r\n DrawUp\r\n else\r\n if (FPtDown.X = Col) and (FPtDown.Y = Row) then\r\n begin\r\n if FPushDown then\r\n DrawDown\r\n else\r\n DrawUp;\r\n end\r\n else\r\n DrawUp;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvArrayButton.SetCols(const Value: Integer);\r\nbegin\r\n if FCols <> Value then\r\n if (Value >= 1) and (Value <= 10) then\r\n begin\r\n FCols := Value;\r\n Invalidate;\r\n SizeChanged;\r\n end;\r\nend;\r\n\r\nprocedure TJvArrayButton.SetEnableds(Index: Integer; const Value: Boolean);\r\nbegin\r\n if FEnableds[Index] <> Value then\r\n begin\r\n FEnableds[Index] := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvArrayButton.SetRows(const Value: Integer);\r\nbegin\r\n if FRows <> Value then\r\n if (Value >= 1) and (Value <= 10) then\r\n begin\r\n FRows := Value;\r\n Invalidate;\r\n SizeChanged;\r\n end;\r\nend;\r\n\r\nprocedure TJvArrayButton.SizeChanged;\r\nvar\r\n OriginalEnableds: array of Boolean;\r\n I: Integer;\r\n MinLength: Integer;\r\nbegin\r\n SetLength(OriginalEnableds, Length(FEnableds));\r\n for I := 0 to Length(FEnableds) - 1 do\r\n OriginalEnableds[I] := FEnableds[I];\r\n\r\n SetLength(FEnableds, Rows * Cols);\r\n\r\n MinLength := Length(OriginalEnableds);\r\n if MinLength > Length(FEnableds) then\r\n MinLength := Length(FEnableds);\r\n\r\n for I := 0 to MinLength - 1 do\r\n FEnableds[I] := OriginalEnableds[I];\r\n for I := MinLength to Length(FEnableds) - 1 do\r\n FEnableds[I] := True;\r\nend;\r\n\r\n{$IFDEF JVCLThemesEnabled}\r\nprocedure TJvArrayButton.SetThemed(Value: Boolean);\r\nbegin\r\n if Value <> FThemed then\r\n begin\r\n FThemed := Value;\r\n if FThemed then\r\n IncludeThemeStyle(Self, [csParentBackground])\r\n else\r\n ExcludeThemeStyle(Self, [csParentBackground]);\r\n Invalidate;\r\n end;\r\nend;\r\n{$ENDIF JVCLThemesEnabled}\r\n\r\nfunction TJvArrayButton.GetCaptions: TStrings;\r\nbegin\r\n Result := FCaptions;\r\nend;\r\n\r\nprocedure TJvArrayButton.SetCaptions(const Value: TStrings);\r\nbegin\r\n FCaptions.Assign(Value);\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvArrayButton.FontChanged;\r\nbegin\r\n inherited FontChanged;\r\n Canvas.Font.Assign(Font);\r\n Invalidate;\r\nend;\r\n\r\nfunction TJvArrayButton.GetColors: TStrings;\r\nbegin\r\n Result := FColors;\r\nend;\r\n\r\nfunction TJvArrayButton.GetEnableds(Index: Integer): Boolean;\r\nbegin\r\n Result := FEnableds[Index];\r\nend;\r\n\r\nprocedure TJvArrayButton.SetColors(const Value: TStrings);\r\nbegin\r\n FColors.Assign(Value);\r\n Invalidate;\r\nend;\r\n\r\nfunction TJvArrayButton.CellRect(ACol, ARow: Integer): TRect;\r\nvar\r\n DH, DW, X0, Y0: Integer;\r\nbegin\r\n DH := (Height - 2) div Rows;\r\n DW := (Width - 2) div Cols;\r\n Y0 := 1 + ARow * DH;\r\n X0 := 1 + ACol * DW;\r\n // pt1:=clienttoscreen(point(X0,Y0));\r\n // pt2:=clienttoscreen(point(X0+DW,Y0+DH));\r\n // result:=rect(pt1.X,pt1.Y,pt2.X,pt2.Y);\r\n Result := Rect(X0, Y0, X0 + DW, Y0 + DH);\r\nend;\r\n\r\nprocedure TJvArrayButton.DoShowHint(var HintStr: THintString;\r\n var CanShow: Boolean; var HintInfo: THintInfo);\r\nvar\r\n ACol, ARow, X, Y: Integer;\r\n Index: Integer;\r\nbegin\r\n if HintInfo.HintControl = Self then\r\n begin\r\n X := HintInfo.CursorPos.X;\r\n Y := HintInfo.CursorPos.Y;\r\n MouseToCell(X, Y, ACol, ARow);\r\n if (ACol < 0) or (ARow < 0) then\r\n Exit;\r\n Index := ARow * Cols + ACol;\r\n if Index < Hints.Count then\r\n HintStr := Hints[Index]\r\n else\r\n HintStr := Hint;\r\n HintInfo.CursorRect := CellRect(ACol, ARow);\r\n CanShow := True;\r\n end;\r\nend;\r\n\r\nprocedure TJvArrayButton.SetHints(const Value: THintStringList);\r\nbegin\r\n FHints.Assign(Value);\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvArrowButton.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvArrowBtn.PAS, released on 2002-05-26.\r\n\r\nThe Initial Developer of the Original Code is Peter Thrnqvist [peter3 at sourceforge dot net]\r\nPortions created by Peter Thrnqvist are Copyright (C) 2002 Peter Thrnqvist.\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nDescription:\r\n The TJvArrowButton component implements an arrow button like\r\n the ones used in Office 97: one button and one arrow with\r\n separate events.\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvArrowButton.pas 13332 2012-06-12 15:22:24Z obones $\r\n\r\nunit JvArrowButton;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Classes, Windows, Messages, Controls, Graphics, Buttons, Menus, Types,\r\n CommCtrl,\r\n JvComponent, JvTypes;\r\n\r\ntype\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvArrowButton = class(TJvGraphicControl)\r\n private\r\n FGroupIndex: Integer;\r\n FGlyph: TObject;\r\n FDown: Boolean;\r\n FArrowClick: Boolean;\r\n FPressBoth: Boolean;\r\n FArrowWidth: Integer;\r\n FAllowAllUp: Boolean;\r\n FLayout: TButtonLayout;\r\n FSpacing: Integer;\r\n FFillFont: TFont;\r\n FMargin: Integer;\r\n FFlat: Boolean;\r\n FMouseInControl: Boolean;\r\n FDropDown: TPopupMenu;\r\n FDropOnButtonClick: Boolean;\r\n FOnDrop: TNotifyEvent;\r\n FVerticalAlignment: TVerticalAlignment;\r\n FAlignment: TAlignment;\r\n FFlatArrowColor: TColor;\r\n FFlatArrowDisabledColor: TColor;\r\n FSplittedButton: Boolean;\r\n procedure GlyphChanged(Sender: TObject);\r\n procedure UpdateExclusive;\r\n function GetGlyph: TBitmap;\r\n procedure SetGlyph(Value: TBitmap);\r\n function GetNumGlyphs: TNumGlyphs;\r\n procedure SetNumGlyphs(Value: TNumGlyphs);\r\n procedure SetDown(Value: Boolean);\r\n procedure SetFlat(Value: Boolean);\r\n procedure SetAllowAllUp(Value: Boolean);\r\n procedure SetGroupIndex(Value: Integer);\r\n procedure SetLayout(Value: TButtonLayout);\r\n procedure SetSpacing(Value: Integer);\r\n procedure SetMargin(Value: Integer);\r\n procedure SetArrowWidth(Value: Integer);\r\n procedure SetFillFont(Value: TFont);\r\n procedure UpdateTracking;\r\n procedure CMButtonPressed(var Msg: TCMButtonPressed); message CM_BUTTONPRESSED;\r\n procedure WMLButtonDblClk(var Msg: TWMLButtonDown); message WM_LBUTTONDBLCLK;\r\n procedure CMSysColorChange(var Msg: TMessage); message CM_SYSCOLORCHANGE;\r\n procedure SetAlignment(const Value: TAlignment);\r\n procedure SetVerticalAlignment(const Value: TVerticalAlignment);\r\n procedure SetFlatArrowColor(const Value: TColor);\r\n procedure SetFlatArrowDisabledColor(const Value: TColor);\r\n protected\r\n FState: TButtonState;\r\n function GetPalette: HPALETTE; override;\r\n procedure Loaded; override;\r\n procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;\r\n procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;\r\n procedure Paint; override;\r\n procedure MouseEnter(Control: TControl); override;\r\n procedure MouseLeave(Control: TControl); override;\r\n\r\n function WantKey(Key: Integer; Shift: TShiftState): Boolean; override;\r\n procedure EnabledChanged; override;\r\n procedure FontChanged; override;\r\n procedure TextChanged; override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n published\r\n property Align;\r\n property Alignment: TAlignment read FAlignment write SetAlignment default taCenter;\r\n property Action;\r\n property Anchors;\r\n property Constraints;\r\n property AllowAllUp: Boolean read FAllowAllUp write SetAllowAllUp default False;\r\n property ArrowWidth: Integer read FArrowWidth write SetArrowWidth default 13;\r\n property GroupIndex: Integer read FGroupIndex write SetGroupIndex default 0;\r\n property Down: Boolean read FDown write SetDown default False;\r\n property DropDown: TPopupMenu read FDropDown write FDropDown;\r\n property DropOnButtonClick: Boolean read FDropOnButtonClick write FDropOnButtonClick default False;\r\n property Caption;\r\n property Enabled;\r\n property Flat: Boolean read FFlat write SetFlat default False;\r\n property FlatArrowColor: TColor read FFlatArrowColor write SetFlatArrowColor default clBlack;\r\n property FlatArrowDisabledColor: TColor read FFlatArrowDisabledColor write SetFlatArrowDisabledColor default clBtnShadow;\r\n property Font;\r\n property FillFont: TFont read FFillFont write SetFillFont;\r\n property Glyph: TBitmap read GetGlyph write SetGlyph;\r\n property Layout: TButtonLayout read FLayout write SetLayout default blGlyphLeft;\r\n property Margin: Integer read FMargin write SetMargin default -1;\r\n property NumGlyphs: TNumGlyphs read GetNumGlyphs write SetNumGlyphs default 1;\r\n property ParentFont default True;\r\n property ParentShowHint;\r\n property PressBoth: Boolean read FPressBoth write FPressBoth default True;\r\n property ShowHint;\r\n property Spacing: Integer read FSpacing write SetSpacing default 4;\r\n property SplittedButton: Boolean read FSplittedButton write FSplittedButton default True;\r\n property VerticalAlignment: TVerticalAlignment read FVerticalAlignment write SetVerticalAlignment default taVerticalCenter;\r\n property Visible;\r\n property OnDrop: TNotifyEvent read FOnDrop write FOnDrop;\r\n property OnClick;\r\n property OnDblClick;\r\n property OnMouseDown;\r\n property OnMouseMove;\r\n property OnMouseUp;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvArrowButton.pas $';\r\n Revision: '$Revision: 13332 $';\r\n Date: '$Date: 2012-06-12 17:22:24 +0200 (mar. 12 juin 2012) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n SysUtils, Forms, ActnList, ImgList,\r\n JvConsts, JvThemes, JvJCLUtils;\r\n\r\ntype\r\n TGlyphList = class(TImageList)\r\n private\r\n FUsed: TBits;\r\n FCount: Integer;\r\n FRefCount: Integer;\r\n function AllocateIndex: Integer;\r\n public\r\n constructor CreateSize(AWidth, AHeight: Integer);\r\n destructor Destroy; override;\r\n function AddMasked(Image: TBitmap; MaskColor: TColor): Integer;\r\n procedure Delete(Index: Integer);\r\n procedure AddReference;\r\n function RemoveReference: Integer;\r\n\r\n property Count: Integer read FCount;\r\n end;\r\n\r\n TGlyphCache = class(TObject)\r\n private\r\n FGlyphLists: TList;\r\n public\r\n constructor Create;\r\n destructor Destroy; override;\r\n function GetList(AWidth, AHeight: Integer): TGlyphList;\r\n procedure ReturnList(var List: TGlyphList);\r\n function Empty: Boolean;\r\n end;\r\n\r\n TButtonGlyph = class(TObject)\r\n private\r\n FArrowButton: TJvArrowButton;\r\n FOriginal: TBitmap;\r\n FGlyphList: TGlyphList;\r\n FIndexs: array [TButtonState] of Integer;\r\n FTransparentColor: TColor;\r\n FNumGlyphs: TNumGlyphs;\r\n FOnChange: TNotifyEvent;\r\n procedure GlyphChanged(Sender: TObject);\r\n procedure SetGlyph(Value: TBitmap);\r\n procedure SetNumGlyphs(Value: TNumGlyphs);\r\n procedure Invalidate;\r\n function CreateButtonGlyph(State: TButtonState): Integer;\r\n procedure DrawButtonGlyph(Canvas: TCanvas; const GlyphPos: TPoint;\r\n State: TButtonState; Transparent: Boolean);\r\n procedure DrawButtonText(Canvas: TCanvas; const Caption: string;\r\n TextBounds: TRect; State: TButtonState; Alignment: TAlignment;\r\n VerticalAlignment: TVerticalAlignment);\r\n procedure CalcButtonLayout(Canvas: TCanvas; const Client: TRect;\r\n const Offset: TPoint; const Caption: string; Layout: TButtonLayout;\r\n Margin, Spacing: Integer; var GlyphPos: TPoint; var TextBounds: TRect;\r\n Alignment: TAlignment; VerticalAlignment: TVerticalAlignment);\r\n public\r\n constructor Create(AArrowButton: TJvArrowButton);\r\n destructor Destroy; override;\r\n { return the text rectangle }\r\n function Draw(Canvas: TCanvas; const Client: TRect; const Offset: TPoint;\r\n const Caption: string; Layout: TButtonLayout; Margin, Spacing: Integer;\r\n State: TButtonState; Transparent: Boolean; TextAlignment: TAlignment; TextVerticalAlignment: TVerticalAlignment): TRect;\r\n property Glyph: TBitmap read FOriginal write SetGlyph;\r\n property NumGlyphs: TNumGlyphs read FNumGlyphs write SetNumGlyphs;\r\n property OnChange: TNotifyEvent read FOnChange write FOnChange;\r\n end;\r\n\r\nprocedure DrawLine(Canvas: TCanvas; X, Y, X2, Y2: Integer);\r\nbegin\r\n Canvas.MoveTo(X, Y);\r\n Canvas.LineTo(X2, Y2);\r\nend;\r\n\r\n// (rom) best move to JCL\r\n\r\nprocedure GrayBitmap(Bmp: TBitmap);\r\nvar\r\n I, J, W, H: Integer;\r\n ColT: TColor;\r\n Col: TColor;\r\nbegin\r\n if Bmp.Empty then\r\n Exit;\r\n\r\n W := Bmp.Width;\r\n H := Bmp.Height;\r\n ColT := Bmp.Canvas.Pixels[0, 0];\r\n\r\n // (rom) speed up by using Scanline\r\n for I := 0 to W do\r\n for J := 0 to H do\r\n begin\r\n Col := Bmp.Canvas.Pixels[I, J];\r\n if (Col <> clWhite) and (Col <> ColT) then\r\n Col := clBlack\r\n else\r\n Col := ColT;\r\n Bmp.Canvas.Pixels[I, J] := Col;\r\n end;\r\nend;\r\n\r\n//=== { TGlyphList } =========================================================\r\n\r\nconstructor TGlyphList.CreateSize(AWidth, AHeight: Integer);\r\nbegin\r\n inherited CreateSize(AWidth, AHeight);\r\n FUsed := TBits.Create;\r\nend;\r\n\r\ndestructor TGlyphList.Destroy;\r\nbegin\r\n FUsed.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TGlyphList.AddReference;\r\nbegin\r\n Inc(FRefCount);\r\nend;\r\n\r\nfunction TGlyphList.RemoveReference: Integer;\r\nbegin\r\n Dec(FRefCount);\r\n Result := FRefCount;\r\nend;\r\n\r\nfunction TGlyphList.AllocateIndex: Integer;\r\nbegin\r\n Result := FUsed.OpenBit;\r\n if Result >= FUsed.Size then\r\n begin\r\n Result := inherited Add(nil, nil);\r\n FUsed.Size := Result + 1;\r\n end;\r\n FUsed[Result] := True;\r\nend;\r\n\r\nfunction TGlyphList.AddMasked(Image: TBitmap; MaskColor: TColor): Integer;\r\nbegin\r\n Result := AllocateIndex;\r\n ReplaceMasked(Result, Image, MaskColor);\r\n Inc(FCount);\r\nend;\r\n\r\nprocedure TGlyphList.Delete(Index: Integer);\r\nbegin\r\n if FUsed[Index] then\r\n begin\r\n Dec(FCount);\r\n FUsed[Index] := False;\r\n end;\r\nend;\r\n\r\n//=== { TGlyphCache } ========================================================\r\n\r\nconstructor TGlyphCache.Create;\r\nbegin\r\n inherited Create;\r\n FGlyphLists := TList.Create;\r\nend;\r\n\r\ndestructor TGlyphCache.Destroy;\r\nbegin\r\n FGlyphLists.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TGlyphCache.GetList(AWidth, AHeight: Integer): TGlyphList;\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := FGlyphLists.Count - 1 downto 0 do\r\n begin\r\n Result := TGlyphList(FGlyphLists[I]);\r\n if (AWidth = Result.Width) and (AHeight = Result.Height) then\r\n begin\r\n Result.AddReference;\r\n Exit;\r\n end;\r\n end;\r\n Result := TGlyphList.CreateSize(AWidth, AHeight);\r\n FGlyphLists.Add(Result);\r\n Result.AddReference;\r\nend;\r\n\r\nprocedure TGlyphCache.ReturnList(var List: TGlyphList);\r\nbegin\r\n if (List <> nil) and (List.RemoveReference = 0) then\r\n begin\r\n FGlyphLists.Remove(List);\r\n FreeAndNil(List);\r\n end\r\n else\r\n List := nil;\r\nend;\r\n\r\nfunction TGlyphCache.Empty: Boolean;\r\nbegin\r\n Result := FGlyphLists.Count = 0;\r\nend;\r\n\r\nvar\r\n GlyphCache: TGlyphCache = nil;\r\n Pattern: TBitmap = nil;\r\n ButtonCount: Integer = 0;\r\n\r\n//=== { TButtonGlyph } =======================================================\r\n\r\nprocedure CreateBrushPattern;\r\nvar\r\n X, Y: Integer;\r\nbegin\r\n Pattern.Free; // (rom) just to be sure\r\n Pattern := TBitmap.Create;\r\n Pattern.Width := 8;\r\n Pattern.Height := 8;\r\n with Pattern.Canvas do\r\n begin\r\n Brush.Style := bsSolid;\r\n Brush.Color := clBtnFace;\r\n FillRect(Rect(0, 0, Pattern.Width, Pattern.Height));\r\n for Y := 0 to 7 do\r\n for X := 0 to 7 do\r\n if (Y mod 2) = (X mod 2) then { toggles between even/odd pixles }\r\n Pixels[X, Y] := clBtnHighlight; { on even/odd rows }\r\n end;\r\nend;\r\n\r\nconstructor TButtonGlyph.Create(AArrowButton: TJvArrowButton);\r\nvar\r\n I: TButtonState;\r\nbegin\r\n inherited Create;\r\n FArrowButton := AArrowButton;\r\n FOriginal := TBitmap.Create;\r\n FOriginal.OnChange := GlyphChanged;\r\n FTransparentColor := clOlive;\r\n FNumGlyphs := 1;\r\n for I := Low(I) to High(I) do\r\n FIndexs[I] := -1;\r\n if GlyphCache = nil then\r\n GlyphCache := TGlyphCache.Create;\r\nend;\r\n\r\ndestructor TButtonGlyph.Destroy;\r\nbegin\r\n FOriginal.Free;\r\n Invalidate;\r\n if Assigned(GlyphCache) and GlyphCache.Empty then\r\n FreeAndNil(GlyphCache);\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TButtonGlyph.Invalidate;\r\nvar\r\n I: TButtonState;\r\nbegin\r\n for I := Low(TButtonState) to High(TButtonState) do\r\n begin\r\n if (FIndexs[I] <> -1) and (FGlyphList <> nil) then\r\n FGlyphList.Delete(FIndexs[I]);\r\n FIndexs[I] := -1;\r\n end;\r\n GlyphCache.ReturnList(FGlyphList);\r\nend;\r\n\r\nprocedure TButtonGlyph.GlyphChanged(Sender: TObject);\r\nbegin\r\n if Sender = FOriginal then\r\n begin\r\n FTransparentColor := FOriginal.TransparentColor;\r\n Invalidate;\r\n if Assigned(FOnChange) then\r\n FOnChange(Self);\r\n end;\r\nend;\r\n\r\nprocedure TButtonGlyph.SetGlyph(Value: TBitmap);\r\nvar\r\n Glyphs: Integer;\r\nbegin\r\n Invalidate;\r\n FOriginal.Assign(Value);\r\n if (Value <> nil) and (Value.Height > 0) then\r\n begin\r\n FTransparentColor := Value.TransparentColor;\r\n if Value.Width mod Value.Height = 0 then\r\n begin\r\n Glyphs := Value.Width div Value.Height;\r\n if Glyphs > 4 then\r\n Glyphs := 1;\r\n SetNumGlyphs(Glyphs);\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TButtonGlyph.SetNumGlyphs(Value: TNumGlyphs);\r\nbegin\r\n if (Value <> FNumGlyphs) and (Value > 0) then\r\n begin\r\n Invalidate;\r\n FNumGlyphs := Value;\r\n GlyphChanged(Glyph);\r\n end;\r\nend;\r\n\r\nfunction TButtonGlyph.CreateButtonGlyph(State: TButtonState): Integer;\r\nvar\r\n TmpImage, DDB, MonoBmp: TBitmap;\r\n IWidth, IHeight: Integer;\r\n IRect, ORect: TRect;\r\n I: TButtonState;\r\n DestDC: HDC;\r\nbegin\r\n if (State = bsDown) and (NumGlyphs < 3) then\r\n State := bsUp;\r\n Result := FIndexs[State];\r\n if Result <> -1 then\r\n Exit;\r\n if (FOriginal.Width = 0) or (FOriginal.Height = 0) then\r\n Exit;\r\n IWidth := FOriginal.Width div FNumGlyphs;\r\n IHeight := FOriginal.Height;\r\n if FGlyphList = nil then\r\n begin\r\n if GlyphCache = nil then\r\n GlyphCache := TGlyphCache.Create;\r\n FGlyphList := GlyphCache.GetList(IWidth, IHeight);\r\n end;\r\n TmpImage := TBitmap.Create;\r\n try\r\n TmpImage.Width := IWidth;\r\n TmpImage.Height := IHeight;\r\n IRect := Rect(0, 0, IWidth, IHeight);\r\n TmpImage.Canvas.Brush.Color := clBtnFace;\r\n TmpImage.Palette := CopyPalette(FOriginal.Palette);\r\n I := State;\r\n if Ord(I) >= NumGlyphs then\r\n I := bsUp;\r\n ORect := Rect(Ord(I) * IWidth, 0, (Ord(I) + 1) * IWidth, IHeight);\r\n case State of\r\n bsUp, bsDown, bsExclusive:\r\n begin\r\n TmpImage.Canvas.CopyRect(IRect, FOriginal.Canvas, ORect);\r\n if FOriginal.TransparentMode = tmFixed then\r\n FIndexs[State] := FGlyphList.AddMasked(TmpImage, FTransparentColor)\r\n else\r\n FIndexs[State] := FGlyphList.AddMasked(TmpImage, clDefault);\r\n end;\r\n bsDisabled:\r\n begin\r\n MonoBmp := nil;\r\n DDB := nil;\r\n try\r\n MonoBmp := TBitmap.Create;\r\n DDB := TBitmap.Create;\r\n DDB.Assign(FOriginal);\r\n DDB.HandleType := bmDDB;\r\n if NumGlyphs > 1 then\r\n with TmpImage.Canvas do\r\n begin { Change white & gray to clBtnHighlight and clBtnShadow }\r\n CopyRect(IRect, DDB.Canvas, ORect);\r\n MonoBmp.Monochrome := True;\r\n MonoBmp.Width := IWidth;\r\n MonoBmp.Height := IHeight;\r\n\r\n { Convert white to clBtnHighlight }\r\n DDB.Canvas.Brush.Color := clWhite;\r\n MonoBmp.Canvas.CopyRect(IRect, DDB.Canvas, ORect);\r\n Brush.Color := clBtnHighlight;\r\n DestDC := Handle;\r\n SetTextColor(DestDC, clBlack);\r\n SetBkColor(DestDC, clWhite);\r\n BitBlt(DestDC, 0, 0, IWidth, IHeight,\r\n MonoBmp.Canvas.Handle, 0, 0, ROP_DSPDxax);\r\n\r\n { Convert gray to clBtnShadow }\r\n DDB.Canvas.Brush.Color := clGray;\r\n MonoBmp.Canvas.CopyRect(IRect, DDB.Canvas, ORect);\r\n Brush.Color := clBtnShadow;\r\n DestDC := Handle;\r\n SetTextColor(DestDC, clBlack);\r\n SetBkColor(DestDC, clWhite);\r\n BitBlt(DestDC, 0, 0, IWidth, IHeight,\r\n MonoBmp.Canvas.Handle, 0, 0, ROP_DSPDxax);\r\n\r\n { Convert transparent color to clBtnFace }\r\n DDB.Canvas.Brush.Color := ColorToRGB(FTransparentColor);\r\n MonoBmp.Canvas.CopyRect(IRect, DDB.Canvas, ORect);\r\n Brush.Color := clBtnFace;\r\n DestDC := Handle;\r\n SetTextColor(DestDC, clBlack);\r\n SetBkColor(DestDC, clWhite);\r\n BitBlt(DestDC, 0, 0, IWidth, IHeight,\r\n MonoBmp.Canvas.Handle, 0, 0, ROP_DSPDxax);\r\n end\r\n else\r\n begin\r\n { Create a disabled version }\r\n with MonoBmp do\r\n begin\r\n Assign(FOriginal);\r\n GrayBitmap(MonoBmp);\r\n HandleType := bmDDB;\r\n Canvas.Brush.Color := clBlack;\r\n Width := IWidth;\r\n if Monochrome then\r\n begin\r\n Canvas.Font.Color := clWhite;\r\n Monochrome := False;\r\n Canvas.Brush.Color := clWhite;\r\n end;\r\n Monochrome := True;\r\n end;\r\n with TmpImage.Canvas do\r\n begin\r\n Brush.Color := clBtnFace;\r\n FillRect(IRect);\r\n Brush.Color := clBtnHighlight;\r\n SetTextColor(Handle, clBlack);\r\n SetBkColor(Handle, clWhite);\r\n BitBlt(Handle, 1, 1, IWidth, IHeight,\r\n MonoBmp.Canvas.Handle, 0, 0, ROP_DSPDxax);\r\n Brush.Color := clBtnShadow;\r\n SetTextColor(Handle, clBlack);\r\n SetBkColor(Handle, clWhite);\r\n BitBlt(Handle, 0, 0, IWidth, IHeight,\r\n MonoBmp.Canvas.Handle, 0, 0, ROP_DSPDxax);\r\n end;\r\n end;\r\n finally\r\n DDB.Free;\r\n MonoBmp.Free;\r\n end;\r\n\r\n FIndexs[State] := FGlyphList.AddMasked(TmpImage, clDefault);\r\n end;\r\n end;\r\n finally\r\n TmpImage.Free;\r\n end;\r\n Result := FIndexs[State];\r\n FOriginal.Dormant;\r\nend;\r\n\r\nprocedure TButtonGlyph.DrawButtonGlyph(Canvas: TCanvas; const GlyphPos: TPoint;\r\n State: TButtonState; Transparent: Boolean);\r\nvar\r\n Index: Integer;\r\n CustomAction: TCustomAction;\r\n ActionList: TCustomActionList;\r\n ImageList: TCustomImageList;\r\nbegin\r\n ImageList := nil;\r\n Index := -1;\r\n\r\n if (FOriginal <> nil) and not FOriginal.Empty then\r\n begin\r\n Index := CreateButtonGlyph(State);\r\n ImageList := FGlyphList;\r\n end\r\n else\r\n begin\r\n if (FArrowButton.Action is TCustomAction) then\r\n begin\r\n CustomAction := TCustomAction(FArrowButton.Action);\r\n ActionList := CustomAction.ActionList;\r\n if (ActionList.Images <> nil) and (CustomAction.ImageIndex >= 0) and\r\n (CustomAction.ImageIndex < ActionList.Images.Count) then\r\n begin\r\n ImageList := ActionList.Images;\r\n Index := CustomAction.ImageIndex;\r\n end;\r\n end;\r\n end;\r\n\r\n if Assigned(ImageList) then\r\n if Transparent or (State = bsExclusive) then\r\n ImageList_DrawEx(ImageList.Handle, Index, Canvas.Handle, GlyphPos.X, GlyphPos.Y, 0, 0,\r\n clNone, clNone, ILD_Transparent)\r\n else\r\n ImageList_DrawEx(ImageList.Handle, Index, Canvas.Handle, GlyphPos.X, GlyphPos.Y, 0, 0,\r\n ColorToRGB(clBtnFace), clNone, ILD_Normal);\r\nend;\r\n\r\nprocedure TButtonGlyph.DrawButtonText(Canvas: TCanvas; const Caption: string;\r\n TextBounds: TRect; State: TButtonState; Alignment: TAlignment; VerticalAlignment: TVerticalAlignment);\r\nconst\r\n AlignFlags: array[TAlignment] of Integer = (DT_LEFT, DT_RIGHT, DT_CENTER);\r\n VerticalAlignFlags: array[TVerticalAlignment] of Integer = (DT_TOP, DT_BOTTOM, DT_VCENTER);\r\nvar\r\n S: string;\r\nbegin\r\n S := Caption;\r\n with Canvas do\r\n begin\r\n Brush.Style := bsClear;\r\n if State = bsDisabled then\r\n begin\r\n OffsetRect(TextBounds, 1, 1);\r\n Font.Color := clBtnHighlight;\r\n DrawText(Canvas, S, -1, TextBounds, AlignFlags[Alignment] or VerticalAlignFlags[VerticalAlignment] or DT_SINGLELINE);\r\n OffsetRect(TextBounds, -1, -1);\r\n Font.Color := clBtnShadow;\r\n DrawText(Canvas, S, -1, TextBounds, AlignFlags[Alignment] or VerticalAlignFlags[VerticalAlignment] or DT_SINGLELINE);\r\n end\r\n else\r\n begin\r\n DrawText(Canvas, S, -1, TextBounds, AlignFlags[Alignment] or VerticalAlignFlags[VerticalAlignment] or DT_SINGLELINE);\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TButtonGlyph.CalcButtonLayout(Canvas: TCanvas; const Client: TRect;\r\n const Offset: TPoint; const Caption: string; Layout: TButtonLayout; Margin,\r\n Spacing: Integer; var GlyphPos: TPoint; var TextBounds: TRect; Alignment: TAlignment;\r\n VerticalAlignment: TVerticalAlignment);\r\nvar\r\n TextPos: TPoint;\r\n ClientSize, GlyphSize, TextSize: TPoint;\r\n TotalSize: TPoint;\r\n S: string;\r\n ActionList: TCustomActionList;\r\n CustomAction: TCustomAction;\r\nbegin\r\n { calculate the item sizes }\r\n ClientSize := Point(Client.Right - Client.Left, Client.Bottom -\r\n Client.Top);\r\n\r\n if (FOriginal <> nil) and not FOriginal.Empty then\r\n begin\r\n GlyphSize := Point(FOriginal.Width div FNumGlyphs, FOriginal.Height)\r\n end\r\n else\r\n begin\r\n GlyphSize := Point(0, 0);\r\n if (FArrowButton.Action is TCustomAction) then\r\n begin\r\n CustomAction := TCustomAction(FArrowButton.Action);\r\n ActionList := CustomAction.ActionList;\r\n if (ActionList.Images <> nil) and (CustomAction.ImageIndex >= 0) and\r\n (CustomAction.ImageIndex < ActionList.Images.Count) then\r\n GlyphSize := Point(ActionList.Images.Width, ActionList.Images.Height);\r\n end;\r\n end;\r\n\r\n if Length(Caption) > 0 then\r\n begin\r\n TextBounds := Rect(0, 0, Client.Right - Client.Left, 0);\r\n S := Caption;\r\n DrawText(Canvas, S, -1, TextBounds, DT_CALCRECT);\r\n TextSize := Point(TextBounds.Right - TextBounds.Left, TextBounds.Bottom -\r\n TextBounds.Top);\r\n end\r\n else\r\n begin\r\n TextBounds := Rect(0, 0, 0, 0);\r\n TextSize := Point(0, 0);\r\n end;\r\n\r\n { if there is no text or no bitmap, then Spacing is irrelevant }\r\n if (TextSize.X = 0) or (GlyphSize.X = 0) then\r\n Spacing := 0;\r\n\r\n { adjust Margin and Spacing }\r\n if Spacing = -1 then\r\n Spacing := 0;\r\n if Margin = -1 then\r\n Margin := 0;\r\n\r\n TotalSize := Point(ClientSize.X - Margin, ClientSize.Y - Margin);\r\n\r\n // Calculate glyph and text position. Start with the glyph layout that has\r\n // an impact on the area available to the text. The glyph is always centered\r\n // over the text it is attached to.\r\n TextPos.X := 0;\r\n TextPos.Y := 0;\r\n GlyphPos.X := 0;\r\n GlyphPos.Y := 0;\r\n case Layout of\r\n blGlyphLeft:\r\n begin\r\n TextPos.X := GlyphSize.X + Spacing;\r\n GlyphPos.X := - GlyphSize.X - Spacing;\r\n GlyphPos.Y := (TextSize.Y - GlyphSize.Y) div 2;\r\n end;\r\n blGlyphRight:\r\n begin\r\n TextPos.X := - GlyphSize.X - Spacing;\r\n GlyphPos.X := TextSize.X + Spacing;\r\n GlyphPos.Y := (TextSize.Y - GlyphSize.Y) div 2;\r\n end;\r\n blGlyphTop:\r\n begin\r\n TextPos.Y := GlyphSize.Y + Spacing;\r\n GlyphPos.Y := - GlyphSize.Y - Spacing;\r\n GlyphPos.X := (TextSize.X - GlyphSize.X) div 2;\r\n end;\r\n blGlyphBottom:\r\n begin\r\n TextPos.Y := - GlyphSize.Y - Spacing;\r\n GlyphPos.Y := TextSize.Y + Spacing;\r\n GlyphPos.X := (TextSize.X - GlyphSize.X) div 2;\r\n end;\r\n end;\r\n\r\n // Then continue with the horizontal text alignment\r\n case Alignment of\r\n taLeftJustify:\r\n begin\r\n if TextPos.X < 0 then\r\n TextPos.X := 0;\r\n Inc(TextPos.X, Margin);\r\n Inc(GlyphPos.X, TextPos.X);\r\n end;\r\n taCenter:\r\n begin\r\n TextPos.X := (TextPos.X + TotalSize.X - TextSize.X) div 2;\r\n Inc(GlyphPos.X, TextPos.X);\r\n end;\r\n taRightJustify:\r\n begin\r\n if TextPos.X > 0 then\r\n TextPos.X := 0;\r\n TextPos.X := TextPos.X + TotalSize.X - TextSize.X;\r\n Inc(GlyphPos.X, TextPos.X);\r\n end;\r\n end;\r\n\r\n // And finish with the vertical text alignment\r\n case VerticalAlignment of\r\n taAlignTop:\r\n begin\r\n if TextPos.Y < 0 then\r\n TextPos.Y := 0;\r\n Inc(TextPos.Y, Margin);\r\n Inc(GlyphPos.Y, TextPos.Y);\r\n end;\r\n taVerticalCenter:\r\n begin\r\n TextPos.Y := (TextPos.Y + TotalSize.Y - TextSize.Y) div 2;\r\n Inc(GlyphPos.Y, TextPos.Y);\r\n end;\r\n taAlignBottom:\r\n begin\r\n if TextPos.Y > 0 then\r\n TextPos.Y := 0;\r\n TextPos.Y := TextPos.Y + TotalSize.Y - TextSize.Y;\r\n Inc(GlyphPos.Y, TextPos.Y);\r\n end;\r\n end;\r\n\r\n // ensure no glyph goes out of the allowed area\r\n if GlyphPos.X < 0 then\r\n GlyphPos.X := 0;\r\n if GlyphPos.X + GlyphSize.X > TotalSize.X then\r\n GlyphPos.X := TotalSize.X - GlyphSize.X;\r\n if GlyphPos.Y < 0 then\r\n GlyphPos.Y := 0;\r\n if GlyphPos.Y + GlyphSize.Y > TotalSize.Y then\r\n GlyphPos.Y := TotalSize.Y - GlyphSize.Y;\r\n\r\n { fixup the result variables }\r\n Inc(GlyphPos.X, Client.Left + Offset.X);\r\n Inc(GlyphPos.Y, Client.Top + Offset.Y);\r\n OffsetRect(TextBounds, TextPos.X + Client.Left + Offset.X,\r\n TextPos.Y + Client.Top + Offset.X);\r\nend;\r\n\r\nfunction TButtonGlyph.Draw(Canvas: TCanvas; const Client: TRect;\r\n const Offset: TPoint; const Caption: string; Layout: TButtonLayout;\r\n Margin, Spacing: Integer; State: TButtonState; Transparent: Boolean; TextAlignment: TAlignment;\r\n TextVerticalAlignment: TVerticalAlignment): TRect;\r\nvar\r\n GlyphPos: TPoint;\r\nbegin\r\n CalcButtonLayout(Canvas, Client, Offset, Caption, Layout, Margin, Spacing,\r\n GlyphPos, Result, TextAlignment, TextVerticalAlignment);\r\n DrawButtonGlyph(Canvas, GlyphPos, State, Transparent);\r\n DrawButtonText(Canvas, Caption, Result, State, TextAlignment, TextVerticalAlignment);\r\nend;\r\n\r\n//=== { TJvArrowButton } =====================================================\r\n\r\nconstructor TJvArrowButton.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n SetBounds(0, 0, 42, 25);\r\n ControlStyle := [csCaptureMouse, {csOpaque, }csDoubleClicks];\r\n IncludeThemeStyle(Self, [csParentBackground]);\r\n FGlyph := TButtonGlyph.Create(Self);\r\n TButtonGlyph(FGlyph).OnChange := GlyphChanged;\r\n FFillFont := TFont.Create;\r\n FFillFont.Assign(Font);\r\n FFlatArrowColor := clBlack;\r\n FFlatArrowDisabledColor := clBtnShadow;\r\n FAllowAllUp := False;\r\n FArrowWidth := 13;\r\n FGroupIndex := 0;\r\n ParentFont := True;\r\n FDown := False;\r\n FFlat := False;\r\n FLayout := blGlyphLeft;\r\n FAlignment := taCenter;\r\n FVerticalAlignment := taVerticalCenter;\r\n FMargin := -1;\r\n FSpacing := 4;\r\n FSplittedButton := True;\r\n FPressBoth := True;\r\n Inc(ButtonCount);\r\nend;\r\n\r\ndestructor TJvArrowButton.Destroy;\r\nbegin\r\n FGlyph.Free;\r\n FFillFont.Free;\r\n Dec(ButtonCount);\r\n if ButtonCount = 0 then\r\n FreeAndNil(Pattern);\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvArrowButton.Paint;\r\nconst\r\n DownStyles: array [Boolean] of Integer = (BDR_RAISEDINNER, BDR_SUNKENOUTER);\r\n FillStyles: array [Boolean] of Integer = (BF_MIDDLE, 0);\r\nvar\r\n PaintRect: TRect;\r\n DrawFlags: Integer;\r\n Offset: TPoint;\r\n DivX, DivY: Integer;\r\n Push: Boolean;\r\n {$IFDEF JVCLThemesEnabled}\r\n Details: TThemedElementDetails;\r\n {$ENDIF JVCLThemesEnabled}\r\nbegin\r\n FMouseInControl := IsMouseOver(Self);\r\n if not Enabled then\r\n FState := bsDisabled\r\n else\r\n if FState = bsDisabled then\r\n begin\r\n if Down and (GroupIndex <> 0) then\r\n FState := bsExclusive\r\n else\r\n FState := bsUp;\r\n end;\r\n if FMouseInControl then\r\n Canvas.Font := FillFont\r\n else\r\n Canvas.Font := Self.Font;\r\n\r\n if SplittedButton then\r\n PaintRect := Rect(0, 0, Width - ArrowWidth, Height)\r\n else\r\n PaintRect := Rect(0, 0, Width, Height);\r\n\r\n if FArrowClick and not Down then\r\n FState := bsUp;\r\n\r\n if not Flat then\r\n begin\r\n DrawFlags := DFCS_BUTTONPUSH or DFCS_ADJUSTRECT;\r\n if not Enabled and not (csDesigning in ComponentState) then\r\n DrawFlags := DrawFlags or DFCS_INACTIVE\r\n else if (FState in [bsDown, bsExclusive]) or (not SplittedButton and FArrowClick) then\r\n DrawFlags := DrawFlags or DFCS_PUSHED;\r\n if FMouseInControl and not (csDesigning in ComponentState) then\r\n DrawFlags := DrawFlags or DFCS_HOT;\r\n DrawThemedFrameControl(Canvas.Handle, PaintRect, DFC_BUTTON, DrawFlags);\r\n end\r\n else\r\n begin\r\n if (FState in [bsDown, bsExclusive]) or\r\n (FMouseInControl and (FState <> bsDisabled)) or\r\n (csDesigning in ComponentState) then\r\n begin\r\n {$IFDEF JVCLThemesEnabled}\r\n if ThemeServices.{$IFDEF RTL230_UP}Enabled{$ELSE}ThemesEnabled{$ENDIF RTL230_UP} then\r\n begin\r\n Details := ThemeServices.GetElementDetails(ttbButtonNormal);\r\n if not Enabled and (csDesigning in ComponentState) then\r\n Details := ThemeServices.GetElementDetails(ttbButtonDisabled)\r\n else if (FState in [bsDown, bsExclusive]) or (not SplittedButton and FArrowClick) then\r\n Details := ThemeServices.GetElementDetails(ttbButtonPressed)\r\n else if FMouseInControl and (FState <> bsDisabled) or (csDesigning in ComponentState) then\r\n Details := ThemeServices.GetElementDetails(ttbButtonHot);\r\n ThemeServices.DrawElement(Canvas.Handle, Details, PaintRect);\r\n ThemeServices.GetElementContentRect(Canvas.Handle, Details, PaintRect, PaintRect);\r\n end\r\n else\r\n {$ENDIF JVCLThemesEnabled}\r\n DrawEdge(Canvas.Handle, PaintRect, DownStyles[FState in [bsDown, bsExclusive]],\r\n FillStyles[Flat] or BF_RECT);\r\n end;\r\n InflateRect(PaintRect, -1, -1);\r\n end;\r\n\r\n if not SplittedButton then\r\n PaintRect := Rect(0, 0, Width - ArrowWidth, Height);\r\n\r\n if FState in [bsDown, bsExclusive] then\r\n begin\r\n if (FState = bsExclusive) and (not Flat or not FMouseInControl) then\r\n begin\r\n if Pattern = nil then\r\n CreateBrushPattern;\r\n Canvas.Brush.Bitmap := Pattern;\r\n Canvas.FillRect(PaintRect);\r\n end;\r\n Offset.X := 1;\r\n Offset.Y := 1;\r\n end\r\n else\r\n begin\r\n Offset.X := 0;\r\n Offset.Y := 0;\r\n end;\r\n { draw image: }\r\n TButtonGlyph(FGlyph).Draw(Canvas, PaintRect, Offset, Caption, Layout, Margin,\r\n Spacing, FState, Flat {$IFDEF JVCLThemesEnabled} or ThemeServices.{$IFDEF RTL230_UP}Enabled{$ELSE}ThemesEnabled{$ENDIF RTL230_UP} {$ENDIF},\r\n Alignment, VerticalAlignment);\r\n\r\n { calculate were to put arrow part }\r\n PaintRect := Rect(Width - ArrowWidth, 0, Width, Height);\r\n {$IFDEF JVCLThemesEnabled}\r\n if ThemeServices.{$IFDEF RTL230_UP}Enabled{$ELSE}ThemesEnabled{$ENDIF RTL230_UP} then\r\n Dec(PaintRect.Left);\r\n {$ENDIF JVCLThemesEnabled}\r\n Push := FArrowClick or (PressBoth and (FState in [bsDown, bsExclusive]));\r\n if Push then\r\n begin\r\n Offset.X := 1;\r\n Offset.Y := 1;\r\n end\r\n else\r\n begin\r\n Offset.X := 0;\r\n Offset.Y := 0;\r\n end;\r\n\r\n if FSplittedButton then\r\n begin\r\n if not Flat then\r\n begin\r\n DrawFlags := DFCS_BUTTONPUSH; // or DFCS_ADJUSTRECT;\r\n if not Enabled and not (csDesigning in ComponentState) then\r\n DrawFlags := DrawFlags or DFCS_INACTIVE\r\n else if Push then\r\n DrawFlags := DrawFlags or DFCS_PUSHED\r\n else if FMouseInControl and not (csDesigning in ComponentState) then\r\n DrawFlags := DrawFlags or DFCS_HOT;\r\n DrawThemedFrameControl(Canvas.Handle, PaintRect, DFC_BUTTON, DrawFlags);\r\n end\r\n else\r\n if FMouseInControl and Enabled or (csDesigning in ComponentState) then\r\n begin\r\n {$IFDEF JVCLThemesEnabled}\r\n if ThemeServices.{$IFDEF RTL230_UP}Enabled{$ELSE}ThemesEnabled{$ENDIF RTL230_UP} then\r\n begin\r\n if not Enabled and (csDesigning in ComponentState) then\r\n Details := ThemeServices.GetElementDetails(ttbButtonDisabled)\r\n else if FState in [bsDown, bsExclusive] then\r\n Details := ThemeServices.GetElementDetails(ttbButtonPressed)\r\n else if FMouseInControl and (FState <> bsDisabled) or (csDesigning in ComponentState) then\r\n Details := ThemeServices.GetElementDetails(ttbButtonHot);\r\n ThemeServices.DrawElement(Canvas.Handle, Details, PaintRect);\r\n end\r\n else\r\n {$ENDIF JVCLThemesEnabled}\r\n DrawEdge(Canvas.Handle, PaintRect, DownStyles[Push],\r\n FillStyles[Flat] or BF_RECT);\r\n end;\r\n end;\r\n\r\n { find middle pixel }\r\n DivX := PaintRect.Right - PaintRect.Left;\r\n DivX := DivX div 2;\r\n DivY := PaintRect.Bottom - PaintRect.Top;\r\n DivY := DivY div 2;\r\n PaintRect.Bottom := PaintRect.Bottom - (DivY + DivX div 2) + 1;\r\n PaintRect.Top := PaintRect.Top + (DivY + DivX div 2) + 1;\r\n PaintRect.Left := PaintRect.Left + (DivX div 2);\r\n PaintRect.Right := (PaintRect.Right - DivX div 2);\r\n\r\n OffsetRect(PaintRect, Offset.X, Offset.Y);\r\n\r\n if not SplittedButton and (not Flat or (FMouseInControl and Enabled)) then\r\n begin\r\n { Draw vertical 'bar' }\r\n Canvas.Pen.Color := clBtnShadow;\r\n DrawLine(Canvas, Width - ArrowWidth - 1 + Offset.X, 4, Width - ArrowWidth - 1 + Offset.X, Height - 4);\r\n Canvas.Pen.Color := clBtnHighlight;\r\n DrawLine(Canvas, Width - ArrowWidth + Offset.X, 4, Width - ArrowWidth + Offset.X, Height - 4);\r\n Dec(PaintRect.Right, 1);\r\n end;\r\n\r\n if Flat and (not FMouseInControl or (csDesigning in ComponentState)) then\r\n begin\r\n if Enabled then\r\n Canvas.Pen.Color := FFlatArrowColor\r\n else\r\n Canvas.Pen.Color := FFlatArrowDisabledColor;\r\n end\r\n else\r\n begin\r\n if Enabled and not (csDesigning in ComponentState) then\r\n Canvas.Pen.Color := clBlack\r\n else\r\n Canvas.Pen.Color := clBtnShadow;\r\n end;\r\n\r\n { Draw arrow }\r\n while PaintRect.Left < PaintRect.Right + 1 do\r\n begin\r\n DrawLine(Canvas, PaintRect.Left, PaintRect.Bottom, PaintRect.Right, PaintRect.Bottom);\r\n InflateRect(PaintRect, -1, 1);\r\n end;\r\nend;\r\n\r\nprocedure TJvArrowButton.UpdateTracking;\r\nvar\r\n P: TPoint;\r\nbegin\r\n if Flat then\r\n if Enabled then\r\n begin\r\n GetCursorPos(P);\r\n FMouseInControl := not (FindDragTarget(P, True) = Self);\r\n if FMouseInControl then\r\n Perform(CM_MOUSELEAVE, 0, 0)\r\n else\r\n Perform(CM_MOUSEENTER, 0, 0);\r\n end;\r\nend;\r\n\r\nprocedure TJvArrowButton.Loaded;\r\nvar\r\n State: TButtonState;\r\nbegin\r\n inherited Loaded;\r\n if Enabled then\r\n State := bsUp\r\n else\r\n State := bsDisabled;\r\n TButtonGlyph(FGlyph).CreateButtonGlyph(State);\r\nend;\r\n\r\nprocedure TJvArrowButton.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);\r\nvar\r\n Pnt: TPoint;\r\n Msg: TMsg;\r\nbegin\r\n inherited MouseDown(Button, Shift, X, Y);\r\n if not Enabled then\r\n Exit;\r\n FArrowClick := (X >= Width - ArrowWidth) and (X <= Width) and (Y >= 0) and (Y <= Height) or DropOnButtonClick;\r\n\r\n if Button = mbLeft then\r\n begin\r\n if not Down then\r\n FState := bsDown\r\n else\r\n FState := bsExclusive;\r\n Repaint; // Invalidate;\r\n end;\r\n\r\n if Assigned(FDropDown) and FArrowClick then\r\n begin\r\n DropDown.PopupComponent := Self;\r\n Pnt := ClientToScreen(Point(0, Height));\r\n DropDown.Popup(Pnt.X, Pnt.Y);\r\n while PeekMessage(Msg, HWND_DESKTOP, WM_MOUSEFIRST, WM_MOUSELAST, PM_REMOVE) do\r\n {nothing};\r\n if GetCapture <> 0 then\r\n SendMessage(GetCapture, WM_CANCELMODE, 0, 0);\r\n end;\r\n\r\n if FArrowClick then\r\n if Assigned(FOnDrop) then\r\n FOnDrop(Self);\r\n FArrowClick := False;\r\n Repaint;\r\nend;\r\n\r\nprocedure TJvArrowButton.MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);\r\nvar\r\n DoClick: Boolean;\r\nbegin\r\n inherited MouseUp(Button, Shift, X, Y);\r\n\r\n if not Enabled then\r\n begin\r\n FState := bsUp;\r\n Repaint;\r\n end;\r\n\r\n DoClick := (X >= 0) and (X <= Width - ArrowWidth) and (Y >= 0) and (Y <= Height) and not DropOnButtonClick;\r\n\r\n if GroupIndex = 0 then\r\n begin\r\n { Redraw face in case mouse is captured }\r\n FState := bsUp;\r\n FMouseInControl := False;\r\n if DoClick and not (FState in [bsExclusive, bsDown]) then\r\n Invalidate;\r\n end\r\n else\r\n if DoClick then\r\n begin\r\n SetDown(not Down);\r\n if Down then\r\n Repaint;\r\n end\r\n else\r\n begin\r\n if Down then\r\n FState := bsExclusive;\r\n Repaint;\r\n end;\r\n if DoClick then\r\n Click;\r\n UpdateTracking;\r\n Repaint;\r\nend;\r\n\r\n\r\nfunction TJvArrowButton.GetPalette: HPALETTE;\r\nbegin\r\n Result := Glyph.Palette;\r\nend;\r\n\r\n\r\nfunction TJvArrowButton.GetGlyph: TBitmap;\r\nbegin\r\n Result := TButtonGlyph(FGlyph).Glyph;\r\nend;\r\n\r\nprocedure TJvArrowButton.SetGlyph(Value: TBitmap);\r\nbegin\r\n TButtonGlyph(FGlyph).Glyph := Value;\r\n Invalidate;\r\nend;\r\n\r\nfunction TJvArrowButton.GetNumGlyphs: TNumGlyphs;\r\nbegin\r\n Result := TButtonGlyph(FGlyph).NumGlyphs;\r\nend;\r\n\r\nprocedure TJvArrowButton.SetNumGlyphs(Value: TNumGlyphs);\r\nbegin\r\n if Value < 0 then\r\n Value := 1\r\n else\r\n if Value > 4 then\r\n Value := 4;\r\n if Value <> TButtonGlyph(FGlyph).NumGlyphs then\r\n begin\r\n TButtonGlyph(FGlyph).NumGlyphs := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvArrowButton.GlyphChanged(Sender: TObject);\r\nbegin\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvArrowButton.UpdateExclusive;\r\nvar\r\n Msg: TCMButtonPressed;\r\nbegin\r\n if (GroupIndex <> 0) and (Parent <> nil) then\r\n begin\r\n Msg.Msg := CM_BUTTONPRESSED;\r\n Msg.Index := GroupIndex;\r\n Msg.Control := Self;\r\n Msg.Result := 0;\r\n Parent.Broadcast(Msg);\r\n end;\r\nend;\r\n\r\nprocedure TJvArrowButton.SetDown(Value: Boolean);\r\nbegin\r\n if GroupIndex = 0 then\r\n Value := False;\r\n if Value <> FDown then\r\n begin\r\n if FDown and (not AllowAllUp) then\r\n Exit;\r\n FDown := Value;\r\n if Value then\r\n begin\r\n if FState = bsUp then\r\n Invalidate;\r\n FState := bsExclusive\r\n end\r\n else\r\n begin\r\n FState := bsUp;\r\n Repaint;\r\n end;\r\n if Value then\r\n UpdateExclusive;\r\n end;\r\nend;\r\n\r\nprocedure TJvArrowButton.SetFlat(Value: Boolean);\r\nbegin\r\n if Value <> FFlat then\r\n begin\r\n FFlat := Value;\r\n if Value then\r\n ControlStyle := ControlStyle - [csOpaque]\r\n else\r\n ControlStyle := ControlStyle + [csOpaque];\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvArrowButton.SetFlatArrowColor(const Value: TColor);\r\nbegin\r\n if Value <> FFlatArrowColor then\r\n begin\r\n FFlatArrowColor := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvArrowButton.SetFlatArrowDisabledColor(const Value: TColor);\r\nbegin\r\n if Value <> FFlatArrowDisabledColor then\r\n begin\r\n FFlatArrowDisabledColor := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvArrowButton.SetGroupIndex(Value: Integer);\r\nbegin\r\n if FGroupIndex <> Value then\r\n begin\r\n FGroupIndex := Value;\r\n UpdateExclusive;\r\n end;\r\nend;\r\n\r\nprocedure TJvArrowButton.SetLayout(Value: TButtonLayout);\r\nbegin\r\n if FLayout <> Value then\r\n begin\r\n FLayout := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvArrowButton.SetMargin(Value: Integer);\r\nbegin\r\n if (Value <> FMargin) and (Value >= -1) then\r\n begin\r\n FMargin := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvArrowButton.SetArrowWidth(Value: Integer);\r\nbegin\r\n if FArrowWidth <> Value then\r\n begin\r\n FArrowWidth := Value;\r\n Repaint;\r\n end;\r\nend;\r\n\r\nprocedure TJvArrowButton.SetFillFont(Value: TFont);\r\nbegin\r\n FFillFont.Assign(Value);\r\n Repaint;\r\nend;\r\n\r\nprocedure TJvArrowButton.SetSpacing(Value: Integer);\r\nbegin\r\n if Value <> FSpacing then\r\n begin\r\n FSpacing := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvArrowButton.SetAlignment(const Value: TAlignment);\r\nbegin\r\n if FAlignment <> Value then\r\n begin\r\n FAlignment := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvArrowButton.SetVerticalAlignment(const Value: TVerticalAlignment);\r\nbegin\r\n if FVerticalAlignment <> Value then\r\n begin\r\n FVerticalAlignment := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvArrowButton.SetAllowAllUp(Value: Boolean);\r\nbegin\r\n if FAllowAllUp <> Value then\r\n begin\r\n FAllowAllUp := Value;\r\n UpdateExclusive;\r\n end;\r\nend;\r\n\r\nprocedure TJvArrowButton.EnabledChanged;\r\nconst\r\n NewState: array [Boolean] of TButtonState = (bsDisabled, bsUp);\r\nbegin\r\n inherited EnabledChanged;\r\n TButtonGlyph(FGlyph).CreateButtonGlyph(NewState[Enabled]);\r\n UpdateTracking;\r\n Repaint;\r\nend;\r\n\r\nprocedure TJvArrowButton.CMButtonPressed(var Msg: TCMButtonPressed);\r\nvar\r\n Sender: TJvArrowButton;\r\n {$IFDEF JVCLThemesEnabled}\r\n R: TRect;\r\n {$ENDIF JVCLThemesEnabled}\r\nbegin\r\n if Msg.Index = GroupIndex then\r\n begin\r\n Sender := TJvArrowButton(Msg.Control);\r\n if Sender <> Self then\r\n begin\r\n if Sender.Down and Down then\r\n begin\r\n FDown := False;\r\n FState := bsUp;\r\n {$IFDEF JVCLThemesEnabled}\r\n if ThemeServices.{$IFDEF RTL230_UP}Enabled{$ELSE}ThemesEnabled{$ENDIF RTL230_UP} and Enabled and not Flat then\r\n begin\r\n R := BoundsRect;\r\n Windows.InvalidateRect(Parent.Handle, {$IFNDEF COMPILER12_UP}@{$ENDIF ~COMPILER12_UP}R, True);\r\n end\r\n else\r\n {$ENDIF JVCLThemesEnabled}\r\n Invalidate;\r\n end;\r\n FAllowAllUp := Sender.AllowAllUp;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJvArrowButton.WantKey(Key: Integer; Shift: TShiftState): Boolean;\r\nbegin\r\n Result := IsAccel(Key, Caption) and Enabled and (Shift * KeyboardShiftStates = [ssAlt]);\r\n if Result then\r\n Click\r\n else\r\n Result := inherited WantKey(Key, Shift);\r\nend;\r\n\r\nprocedure TJvArrowButton.FontChanged;\r\nbegin\r\n inherited FontChanged;\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvArrowButton.TextChanged;\r\nbegin\r\n inherited TextChanged;\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvArrowButton.WMLButtonDblClk(var Msg: TWMLButtonDown);\r\nbegin\r\n inherited;\r\n if Down then\r\n DblClick;\r\nend;\r\n\r\nprocedure TJvArrowButton.CMSysColorChange(var Msg: TMessage);\r\nbegin\r\n with TButtonGlyph(FGlyph) do\r\n begin\r\n Invalidate;\r\n CreateButtonGlyph(FState);\r\n end;\r\nend;\r\n\r\nprocedure TJvArrowButton.MouseEnter(Control: TControl);\r\n{$IFDEF JVCLThemesEnabled}\r\nvar\r\n R: TRect;\r\n{$ENDIF JVCLThemesEnabled}\r\nbegin\r\n inherited MouseEnter(Control);\r\n if Flat and not FMouseInControl and Enabled then\r\n begin\r\n FMouseInControl := True;\r\n Repaint;\r\n end;\r\n {$IFDEF JVCLThemesEnabled}\r\n if ThemeServices.{$IFDEF RTL230_UP}Enabled{$ELSE}ThemesEnabled{$ENDIF RTL230_UP} and Enabled and not Flat then\r\n begin\r\n R := BoundsRect;\r\n Windows.InvalidateRect(Parent.Handle, {$IFNDEF COMPILER12_UP}@{$ENDIF ~COMPILER12_UP}R, True);\r\n end;\r\n {$ENDIF JVCLThemesEnabled}\r\nend;\r\n\r\nprocedure TJvArrowButton.MouseLeave(Control: TControl);\r\n{$IFDEF JVCLThemesEnabled}\r\nvar\r\n R: TRect;\r\n{$ENDIF JVCLThemesEnabled}\r\nbegin\r\n inherited MouseLeave(Control);\r\n if Flat and FMouseInControl and Enabled then\r\n begin\r\n FMouseInControl := False;\r\n Invalidate;\r\n end;\r\n {$IFDEF JVCLThemesEnabled}\r\n if ThemeServices.{$IFDEF RTL230_UP}Enabled{$ELSE}ThemesEnabled{$ENDIF RTL230_UP} and Enabled and not Flat then\r\n begin\r\n R := BoundsRect;\r\n Windows.InvalidateRect(Parent.Handle, {$IFNDEF COMPILER12_UP}@{$ENDIF ~COMPILER12_UP}R, True);\r\n end;\r\n {$ENDIF JVCLThemesEnabled}\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvAutoComplete.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvAutoComplete.pas, released on 2004-09-04.\r\n\r\nThe Initial Developer of the Original Code is Andreas Hausladen [Andreas dott Hausdaden att gmx dott de]\r\nPortions created by Andreas Hausladen are Copyright (C) 2004 Andreas Hausladen.\r\nAll Rights Reserved.\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvAutoComplete.pas 13104 2011-09-07 06:50:43Z obones $\r\n\r\nunit JvAutoComplete;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows,\r\n Messages,\r\n SysUtils, Classes, Controls, StdCtrls;\r\n\r\ntype\r\n TJvGetSearchItemPrefixEvent = procedure(Sender: TObject; var Prefix: string) of object;\r\n\r\n { TControlAutoComplete implements an autocomplete code for controls. It is an\r\n abstract base class. After you have created an instance of a derived class\r\n you must either assign the AutoCompleteEvent to the OnKeyPress event of the\r\n control or you must call the AutoComplete method in a KeyPress event handler.\r\n\r\n (ahuser) 2005-01-31: changed from TObject to TComponent due to Notification()\r\n Do not register this component it is more a \"TObject\" than a TComponent. }\r\n TJvControlAutoComplete = class(TComponent)\r\n private\r\n FFilter: string;\r\n FLastTime: Cardinal;\r\n FMaxFilterTime: Cardinal;\r\n FListSearch: Boolean;\r\n FActive: Boolean;\r\n FOnDropDown: TNotifyEvent;\r\n FOnValidateItems: TNotifyEvent;\r\n FOnChange: TNotifyEvent;\r\n FOnValueChange: TNotifyEvent;\r\n FOnGetSearchItemPrefix: TJvGetSearchItemPrefixEvent;\r\n protected\r\n function GetText: TCaption; virtual; abstract;\r\n procedure SetText(const Value: TCaption); virtual; abstract;\r\n procedure GetEditSel(out StartPos, EndPos: Integer); virtual; abstract;\r\n procedure SetEditSel(StartPos, EndPos: Integer); virtual; abstract;\r\n procedure SetItemIndex(Index: Integer); virtual; abstract;\r\n function GetItemIndex: Integer; virtual; abstract;\r\n function FindItemPrefix(IndexStart: Integer; const Prefix: string): Integer; virtual; abstract;\r\n function GetItemAt(Index: Integer): string; virtual; abstract;\r\n function GetEditHandle: THandle; virtual; abstract;\r\n\r\n function GetActive: Boolean; virtual;\r\n procedure SetFilter(const Value: string);\r\n\r\n procedure DoDropDown; dynamic;\r\n procedure DoValidateItems; dynamic;\r\n procedure DoChange; dynamic;\r\n procedure DoValueChange; dynamic;\r\n procedure GetSearchItemPrefix(var Prefix: string); dynamic;\r\n public\r\n constructor Create; reintroduce;\r\n procedure AutoCompleteEvent(Sender: TObject; var Key: Char);\r\n procedure AutoComplete(var Key: Char); virtual;\r\n\r\n property ListSearch: Boolean read FListSearch write FListSearch; // no edit possible\r\n property MaxFilterTime: Cardinal read FMaxFilterTime write FMaxFilterTime; // only with ListSearch\r\n\r\n property Active: Boolean read GetActive write FActive;\r\n property OnDropDown: TNotifyEvent read FOnDropDown write FOnDropDown;\r\n property OnValidateItems: TNotifyEvent read FOnValidateItems write FOnValidateItems;\r\n property OnChange: TNotifyEvent read FOnChange write FOnChange;\r\n property OnValueChange: TNotifyEvent read FOnValueChange write FOnValueChange;\r\n property OnGetSearchItemPrefix: TJvGetSearchItemPrefixEvent read FOnGetSearchItemPrefix write FOnGetSearchItemPrefix;\r\n end;\r\n\r\n TJvBaseEditListAutoComplete = class(TJvControlAutoComplete)\r\n private\r\n FEditCtrl: TCustomEdit;\r\n FList: TStrings;\r\n procedure SetEditCtrl(Value: TCustomEdit);\r\n protected\r\n procedure Notification(AComponent: TComponent; Operation: TOperation); override;\r\n function GetText: TCaption; override;\r\n procedure SetText(const Value: TCaption); override;\r\n procedure GetEditSel(out StartPos, EndPos: Integer); override;\r\n procedure SetEditSel(StartPos, EndPos: Integer); override;\r\n function FindItemPrefix(IndexStart: Integer; const Prefix: string): Integer; override;\r\n function GetItemAt(Index: Integer): string; override;\r\n function GetEditHandle: THandle; override;\r\n function GetActive: Boolean; override;\r\n property List: TStrings read FList write FList;\r\n public\r\n constructor Create(AEditCtrl: TCustomEdit; AList: TStrings);\r\n destructor Destroy; override;\r\n property EditCtrl: TCustomEdit read FEditCtrl write SetEditCtrl;\r\n end;\r\n\r\n { TEditListAutoComplete implements an autocomplete code for a Edit/TStrings\r\n pair. After you have created an instance of this class you must either\r\n assign the AutoCompleteEvent to the OnKeyPress event of the edit control\r\n or you must call the AutoComplete method in a KeyPress event handler. }\r\n TJvEditListAutoComplete = class(TJvBaseEditListAutoComplete)\r\n private\r\n FOnItemIndexChange: TNotifyEvent;\r\n FOnValidateItemIndex: TNotifyEvent;\r\n public\r\n FItemIndex: Integer;\r\n function GetList: TStrings;\r\n procedure SetList(Value: TStrings);\r\n procedure SetInternalItemIndex(Value: Integer);\r\n protected\r\n procedure SetItemIndex(Index: Integer); override;\r\n function GetItemIndex: Integer; override;\r\n public\r\n constructor Create(AEditCtrl: TCustomEdit; AList: TStrings);\r\n property ItemIndex: Integer read FItemIndex write SetInternalItemIndex;\r\n property List: TStrings read GetList write SetList;\r\n property OnItemIndexChange: TNotifyEvent read FOnItemIndexChange write FOnItemIndexChange;\r\n property OnValidateItemIndex: TNotifyEvent read FOnValidateItemIndex write FOnValidateItemIndex;\r\n end;\r\n\r\n { TEditListBoxAutoComplete implements an autocomplete code for a Edit/ListBox\r\n pair. After you have created an instance of this class you must either\r\n assign the AutoCompleteEvent to the OnKeyPress event of the edit control\r\n or you must call the AutoComplete method in a KeyPress event handler. }\r\n TJvEditListBoxAutoComplete = class(TJvBaseEditListAutoComplete)\r\n private\r\n FListBox: TCustomListBox;\r\n procedure SetListBox(Value: TCustomListBox);\r\n protected\r\n procedure SetItemIndex(Index: Integer); override;\r\n function GetItemIndex: Integer; override;\r\n procedure Notification(AComponent: TComponent; Operation: TOperation); override;\r\n public\r\n constructor Create(AEditCtrl: TCustomEdit; AListBox: TCustomListBox);\r\n destructor Destroy; override;\r\n property ListBox: TCustomListBox read FListBox write SetListBox;\r\n end;\r\n\r\n { TComboBoxAutoComplete implements an autocomplete code for a ComboBox.\r\n After you have created an instance of this class you must either assign the\r\n AutoCompleteEvent to the OnKeyPress event of the edit control or you must\r\n call the AutoComplete method in a KeyPress event handler. }\r\n TJvComboBoxAutoComplete = class(TJvControlAutoComplete)\r\n private\r\n FComboBox: TCustomComboBox;\r\n procedure SetComboBox(Value: TCustomComboBox);\r\n protected\r\n function GetText: TCaption; override;\r\n procedure SetText(const Value: TCaption); override;\r\n procedure GetEditSel(out StartPos, EndPos: Integer); override;\r\n procedure SetEditSel(StartPos, EndPos: Integer); override;\r\n procedure SetItemIndex(Index: Integer); override;\r\n function GetItemIndex: Integer; override;\r\n function FindItemPrefix(IndexStart: Integer; const Prefix: string): Integer; override;\r\n function GetItemAt(Index: Integer): string; override;\r\n function GetEditHandle: THandle; override;\r\n function GetActive: Boolean; override;\r\n public\r\n constructor Create(AComboBox: TCustomComboBox);\r\n property ComboBox: TCustomComboBox read FComboBox write SetComboBox;\r\n end;\r\n\r\n TJvLookupAutoCompleteKind = (akListBox, akStrings);\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64 or pidOSX32)]\r\n {$ENDIF RTL230_UP}\r\n TJvLookupAutoComplete = class(TComponent)\r\n private\r\n FAutoComplete: TJvEditListAutoComplete;\r\n FListBox: TCustomListBox;\r\n FStrings: TStrings;\r\n FKind: TJvLookupAutoCompleteKind;\r\n FOrgKeyPress: TKeyPressEvent;\r\n FOnChange: TNotifyEvent;\r\n FOnValidateStrings: TNotifyEvent;\r\n FOnDropDown: TNotifyEvent;\r\n FOnValueChange: TNotifyEvent;\r\n function GetEdit: TCustomEdit;\r\n function GetItemIndex: Integer;\r\n function GetListSearch: Boolean;\r\n procedure SetEdit(Value: TCustomEdit);\r\n procedure SetItemIndex(Value: Integer);\r\n procedure SetKind(Value: TJvLookupAutoCompleteKind);\r\n procedure SetListBox(Value: TCustomListBox);\r\n procedure SetListSearch(Value: Boolean);\r\n procedure SetStrings(Value: TStrings);\r\n function GetActive: Boolean;\r\n procedure SetActive(const Value: Boolean);\r\n protected\r\n procedure Notification(AComponent: TComponent; Operation: TOperation); override;\r\n procedure EvKeyPress(Sender: TObject; var Key: Char); dynamic;\r\n procedure EvDropDown(Sender: TObject); dynamic;\r\n procedure EvValidateStrings(Sender: TObject); dynamic;\r\n procedure EvChange(Sender: TObject); dynamic;\r\n procedure EvValueChange(Sender: TObject); dynamic;\r\n procedure EvItemIndexChange(Sender: TObject); dynamic;\r\n procedure EvValidateItemIndex(Sender: TObject); dynamic;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n\r\n property ItemIndex: Integer read GetItemIndex write SetItemIndex;\r\n published\r\n property Active: Boolean read GetActive write SetActive default True;\r\n property Edit: TCustomEdit read GetEdit write SetEdit;\r\n property ListBox: TCustomListBox read FListBox write SetListBox;\r\n property Strings: TStrings read FStrings write SetStrings;\r\n property Kind: TJvLookupAutoCompleteKind read FKind write SetKind default akListBox;\r\n property ListSearch: Boolean read GetListSearch write SetListSearch default False;\r\n property OnDropDown: TNotifyEvent read FOnDropDown write FOnDropDown;\r\n property OnValidateStrings: TNotifyEvent read FOnValidateStrings write FOnValidateStrings;\r\n property OnChange: TNotifyEvent read FOnChange write FOnChange;\r\n property OnValueChange: TNotifyEvent read FOnValueChange write FOnValueChange;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvAutoComplete.pas $';\r\n Revision: '$Revision: 13104 $';\r\n Date: '$Date: 2011-09-07 08:50:43 +0200 (mer. 07 sept. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n StrUtils,\r\n {$IFNDEF COMPILER12_UP}\r\n JvJCLUtils,\r\n {$ENDIF ~COMPILER12_UP}\r\n JvConsts, JvJVCLUtils;\r\n\r\n//=== { TJvControlAutoComplete } =============================================\r\n\r\nconstructor TJvControlAutoComplete.Create;\r\nbegin\r\n inherited Create(nil);\r\n FActive := True;\r\n FMaxFilterTime := 500;\r\nend;\r\n\r\nfunction TJvControlAutoComplete.GetActive: Boolean;\r\nbegin\r\n Result := FActive;\r\nend;\r\n\r\nprocedure TJvControlAutoComplete.SetFilter(const Value: string);\r\nbegin\r\n FFilter := Value;\r\nend;\r\n\r\nprocedure TJvControlAutoComplete.DoValidateItems;\r\nbegin\r\n if Assigned(FOnValidateItems) then\r\n FOnValidateItems(Self);\r\nend;\r\n\r\nprocedure TJvControlAutoComplete.DoChange;\r\nbegin\r\n if Assigned(FOnChange) then\r\n FOnChange(Self);\r\nend;\r\n\r\nprocedure TJvControlAutoComplete.DoDropDown;\r\nbegin\r\n if Assigned(FOnDropDown) then\r\n FOnDropDown(Self);\r\nend;\r\n\r\nprocedure TJvControlAutoComplete.DoValueChange;\r\nbegin\r\n if Assigned(FOnValueChange) then\r\n FOnValueChange(Self);\r\nend;\r\n\r\nprocedure TJvControlAutoComplete.GetSearchItemPrefix(var Prefix: string);\r\nbegin\r\n if Assigned(FOnGetSearchItemPrefix) then\r\n FOnGetSearchItemPrefix(Self, Prefix);\r\nend;\r\n\r\nprocedure TJvControlAutoComplete.AutoCompleteEvent(Sender: TObject; var Key: Char);\r\nbegin\r\n AutoComplete(Key);\r\nend;\r\n\r\nprocedure TJvControlAutoComplete.AutoComplete(var Key: Char);\r\nvar\r\n StartPos, EndPos: Integer;\r\n SaveText, OldText: TCaption;\r\n LastByte: Integer;\r\n LT: Int64;\r\n Msg: TMsg;\r\n\r\n function HasSelectedText(var StartPos, EndPos: Integer): Boolean;\r\n begin\r\n GetEditSel(StartPos, EndPos);\r\n Result := EndPos > StartPos;\r\n end;\r\n\r\n procedure DeleteSelectedText;\r\n var\r\n StartPos, EndPos: Integer;\r\n OldText: string;\r\n begin\r\n OldText := GetText;\r\n GetEditSel(StartPos, EndPos);\r\n Delete(OldText, StartPos + 1, EndPos - StartPos);\r\n SetItemIndex(-1);\r\n SetText(OldText);\r\n SetEditSel(StartPos, StartPos);\r\n end;\r\n\r\n function SelectItem(const AnItem: string): Boolean;\r\n var\r\n Idx: Integer;\r\n ValueChange: Boolean;\r\n PartToFind: string;\r\n begin\r\n Result := False;\r\n PartToFind := AnItem;\r\n GetSearchItemPrefix(PartToFind);\r\n if PartToFind = '' then\r\n begin\r\n SetItemIndex(-1);\r\n DoChange;\r\n Exit;\r\n end;\r\n Idx := FindItemPrefix(-1, PartToFind);\r\n if Idx < 0 then\r\n Exit;\r\n Result := True;\r\n ValueChange := Idx <> GetItemIndex;\r\n SetItemIndex(Idx);\r\n if ListSearch then\r\n begin\r\n SetItemIndex(Idx);\r\n FFilter := PartToFind;\r\n end\r\n else\r\n begin\r\n SetText(AnItem + Copy(GetItemAt(Idx), Length(PartToFind) + 1, MaxInt));\r\n SetEditSel(Length(AnItem), Length(GetText));\r\n end;\r\n if ValueChange then\r\n DoValueChange;\r\n end;\r\n\r\nbegin\r\n if not Active then\r\n Exit;\r\n\r\n if ListSearch then\r\n begin\r\n LT := GetTickCount;\r\n if FLastTime > LT then\r\n LT := $100000000 + LT; // double limit.\r\n if LT - FLastTime >= MaxFilterTime then\r\n FFilter := '';\r\n FLastTime := GetTickCount;\r\n end\r\n else\r\n FFilter := GetText;\r\n\r\n case Key of\r\n Esc {VK_ESCAPE}:\r\n Exit;\r\n Tab {VK_TAB}:\r\n begin\r\n DoValidateItems;\r\n DoDropDown;\r\n end;\r\n BackSpace {VK_BACK}:\r\n begin\r\n DoValidateItems;\r\n if HasSelectedText(StartPos, EndPos) then\r\n DeleteSelectedText\r\n else\r\n if not ListSearch and (GetText <> '') then\r\n begin\r\n SaveText := GetText;\r\n LastByte := StartPos;\r\n while ByteType(SaveText, LastByte) = mbTrailByte do\r\n Dec(LastByte);\r\n OldText := Copy(SaveText, 1, LastByte - 1);\r\n SetItemIndex(-1);\r\n SetText(OldText + Copy(SaveText, EndPos + 1, MaxInt));\r\n SetEditSel(LastByte - 1, LastByte - 1);\r\n FFilter := GetText;\r\n end\r\n else\r\n begin\r\n while ByteType(FFilter, Length(FFilter)) = mbTrailByte do\r\n Delete(FFilter, Length(FFilter), 1);\r\n Delete(FFilter, Length(FFilter), 1);\r\n end;\r\n Key := #0;\r\n DoChange;\r\n end;\r\n else\r\n DoValidateItems;\r\n DoDropDown;\r\n\r\n if HasSelectedText(StartPos, EndPos) then\r\n SaveText := Copy(FFilter, 1, StartPos) + Key\r\n else\r\n SaveText := FFilter + Key;\r\n\r\n if CharInSet(Key, LeadBytes) then\r\n begin\r\n if PeekMessage(Msg, GetEditHandle, 0, 0, PM_NOREMOVE) and (Msg.Message = WM_CHAR) then\r\n begin\r\n if SelectItem(SaveText + Char(Msg.WParam)) then\r\n begin\r\n PeekMessage(Msg, GetEditHandle, 0, 0, PM_REMOVE);\r\n Key := #0;\r\n end;\r\n end;\r\n end\r\n else\r\n if SelectItem(SaveText) then\r\n Key := #0;\r\n end;\r\nend;\r\n\r\n//=== { TJvBaseEditListAutoComplete } ========================================\r\n\r\nconstructor TJvBaseEditListAutoComplete.Create(AEditCtrl: TCustomEdit;\r\n AList: TStrings);\r\nbegin\r\n inherited Create;\r\n FList := AList;\r\n EditCtrl := AEditCtrl;\r\nend;\r\n\r\ndestructor TJvBaseEditListAutoComplete.Destroy;\r\nbegin\r\n EditCtrl := nil;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvBaseEditListAutoComplete.Notification(AComponent: TComponent;\r\n Operation: TOperation);\r\nbegin\r\n if (Operation = opRemove) and (AComponent = FEditCtrl) then\r\n begin\r\n FEditCtrl := nil;\r\n SetFilter('');\r\n end;\r\n inherited Notification(AComponent, Operation);\r\nend;\r\n\r\nprocedure TJvBaseEditListAutoComplete.SetEditCtrl(Value: TCustomEdit);\r\nbegin\r\n ReplaceComponentReference(Self, Value, TComponent(FEditCtrl));\r\n\r\n if FEditCtrl <> nil then\r\n SetFilter(FEditCtrl.Text)\r\n else\r\n SetFilter('');\r\nend;\r\n\r\ntype\r\n TCustomEditAccess = class(TCustomEdit);\r\n\r\nfunction TJvBaseEditListAutoComplete.GetText: TCaption;\r\nbegin\r\n Result := EditCtrl.Text;\r\nend;\r\n\r\nprocedure TJvBaseEditListAutoComplete.SetText(const Value: TCaption);\r\nbegin\r\n EditCtrl.Text := Value;\r\nend;\r\n\r\nprocedure TJvBaseEditListAutoComplete.GetEditSel(out StartPos, EndPos: Integer);\r\n\r\nbegin\r\n SendMessage(EditCtrl.Handle, EM_GETSEL, WPARAM(@StartPos), LPARAM(@EndPos));\r\nend;\r\n\r\nprocedure TJvBaseEditListAutoComplete.SetEditSel(StartPos, EndPos: Integer);\r\nbegin\r\n EditCtrl.SelStart := StartPos;\r\n EditCtrl.SelLength := EndPos - StartPos;\r\nend;\r\n\r\nfunction TJvBaseEditListAutoComplete.FindItemPrefix(IndexStart: Integer; const Prefix: string): Integer;\r\nbegin\r\n if List <> nil then\r\n begin\r\n for Result := IndexStart + 1 to List.Count - 1 do\r\n if AnsiStartsText(Prefix, List[Result]) then\r\n Exit;\r\n for Result := 0 to IndexStart do\r\n if AnsiStartsText(Prefix, List[Result]) then\r\n Exit;\r\n end;\r\n Result := -1;\r\nend;\r\n\r\nfunction TJvBaseEditListAutoComplete.GetItemAt(Index: Integer): string;\r\nbegin\r\n Result := List[Index];\r\nend;\r\n\r\n\r\nfunction TJvBaseEditListAutoComplete.GetEditHandle: THandle;\r\nbegin\r\n Result := FEditCtrl.Handle;\r\nend;\r\n\r\n\r\nfunction TJvBaseEditListAutoComplete.GetActive: Boolean;\r\nbegin\r\n Result := inherited GetActive and (EditCtrl <> nil) and (List <> nil) and\r\n not TCustomEditAccess(EditCtrl).ReadOnly;\r\nend;\r\n\r\n//=== { TJvEditListAutoComplete } ============================================\r\n\r\nconstructor TJvEditListAutoComplete.Create(AEditCtrl: TCustomEdit;\r\n AList: TStrings);\r\nbegin\r\n inherited Create(AEditCtrl, AList);\r\n FItemIndex := -1;\r\nend;\r\n\r\nprocedure TJvEditListAutoComplete.SetInternalItemIndex(Value: Integer);\r\nbegin\r\n if (Value < 0) or (List = nil) then\r\n Value := -1;\r\n FItemIndex := Value;\r\n if (List <> nil) and (FItemIndex >= List.Count) then\r\n FItemIndex := List.Count - 1;\r\nend;\r\n\r\nfunction TJvEditListAutoComplete.GetList: TStrings;\r\nbegin\r\n Result := FList;\r\nend;\r\n\r\nprocedure TJvEditListAutoComplete.SetList(Value: TStrings);\r\nbegin\r\n FItemIndex := -1;\r\n FList := Value;\r\nend;\r\n\r\nprocedure TJvEditListAutoComplete.SetItemIndex(Index: Integer);\r\nbegin\r\n FItemIndex := Index;\r\n if Assigned(FOnItemIndexChange) then\r\n FOnItemIndexChange(Self);\r\nend;\r\n\r\nfunction TJvEditListAutoComplete.GetItemIndex: Integer;\r\nbegin\r\n if Assigned(FOnValidateItemIndex) then\r\n FOnValidateItemIndex(Self);\r\n Result := FItemIndex;\r\nend;\r\n\r\n//=== { TJvEditListBoxAutoComplete } =========================================\r\n\r\nconstructor TJvEditListBoxAutoComplete.Create(AEditCtrl: TCustomEdit; AListBox: TCustomListBox);\r\nbegin\r\n if AListBox = nil then\r\n inherited Create(AEditCtrl, nil)\r\n else\r\n inherited Create(AEditCtrl, AListBox.Items);\r\n ListBox := AListBox;\r\nend;\r\n\r\ndestructor TJvEditListBoxAutoComplete.Destroy;\r\nbegin\r\n ListBox := nil;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvEditListBoxAutoComplete.Notification(AComponent: TComponent; Operation: TOperation);\r\nbegin\r\n if (Operation = opRemove) and (AComponent = FListBox) then\r\n begin\r\n FListBox := nil;\r\n List := nil;\r\n end;\r\n inherited Notification(AComponent, Operation);\r\nend;\r\n\r\nprocedure TJvEditListBoxAutoComplete.SetListBox(Value: TCustomListBox);\r\nbegin\r\n ReplaceComponentReference(Self, Value, TComponent(FListBox));\r\n\r\n if FListBox <> nil then\r\n List := FListBox.Items\r\n else\r\n List := nil;\r\nend;\r\n\r\nprocedure TJvEditListBoxAutoComplete.SetItemIndex(Index: Integer);\r\nbegin\r\n ListBox.ItemIndex := Index;\r\nend;\r\n\r\nfunction TJvEditListBoxAutoComplete.GetItemIndex: Integer;\r\nbegin\r\n Result := ListBox.ItemIndex;\r\nend;\r\n\r\n//=== { TJvComboBoxAutoComplete } ============================================\r\n\r\nconstructor TJvComboBoxAutoComplete.Create(AComboBox: TCustomComboBox);\r\nbegin\r\n inherited Create;\r\n FComboBox := AComboBox;\r\nend;\r\n\r\ntype\r\n TCustomComboBoxAccess = class(TCustomComboBox);\r\n\r\nfunction TJvComboBoxAutoComplete.GetActive: Boolean;\r\nbegin\r\n Result := inherited GetActive and (ComboBox <> nil);\r\n if ComboBox <> nil then\r\n FListSearch := not (TCustomComboBoxAccess(ComboBox).Style in [csDropDown , csSimple ]);\r\nend;\r\n\r\n\r\nfunction TJvComboBoxAutoComplete.GetEditHandle: THandle;\r\nbegin\r\n Result := ComboBox.Handle;\r\nend;\r\n\r\n\r\nprocedure TJvComboBoxAutoComplete.GetEditSel(out StartPos, EndPos: Integer);\r\n\r\nbegin\r\n SendMessage(ComboBox.Handle, CB_GETEDITSEL, WPARAM(@StartPos), LPARAM(@EndPos));\r\nend;\r\n\r\nprocedure TJvComboBoxAutoComplete.SetEditSel(StartPos, EndPos: Integer);\r\nbegin\r\n ComboBox.SelStart := StartPos;\r\n ComboBox.SelLength := EndPos - StartPos;\r\nend;\r\n\r\nfunction TJvComboBoxAutoComplete.FindItemPrefix(IndexStart: Integer;\r\n const Prefix: string): Integer;\r\nbegin\r\n for Result := IndexStart + 1 to ComboBox.Items.Count - 1 do\r\n if AnsiStartsText(Prefix, ComboBox.Items[Result]) then\r\n Exit;\r\n for Result := 0 to IndexStart do\r\n if AnsiStartsText(Prefix, ComboBox.Items[Result]) then\r\n Exit;\r\n Result := -1;\r\nend;\r\n\r\nprocedure TJvComboBoxAutoComplete.SetItemIndex(Index: Integer);\r\nbegin\r\n ComboBox.ItemIndex := Index;\r\nend;\r\n\r\nfunction TJvComboBoxAutoComplete.GetItemIndex: Integer;\r\nbegin\r\n Result := ComboBox.ItemIndex;\r\nend;\r\n\r\nfunction TJvComboBoxAutoComplete.GetItemAt(Index: Integer): string;\r\nbegin\r\n Result := ComboBox.Items[Index];\r\nend;\r\n\r\nfunction TJvComboBoxAutoComplete.GetText: TCaption;\r\nbegin\r\n Result := TCustomComboBoxAccess(ComboBox).Text;\r\nend;\r\n\r\nprocedure TJvComboBoxAutoComplete.SetText(const Value: TCaption);\r\nbegin\r\n TCustomComboBoxAccess(ComboBox).Text := Value;\r\nend;\r\n\r\nprocedure TJvComboBoxAutoComplete.SetComboBox(Value: TCustomComboBox);\r\nbegin\r\n FComboBox := Value;\r\n if FComboBox <> nil then\r\n SetFilter(GetText)\r\n else\r\n SetFilter('');\r\nend;\r\n\r\n//=== { TJvLookupAutoComplete } ==============================================\r\n\r\nconstructor TJvLookupAutoComplete.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FAutoComplete := TJvEditListAutoComplete.Create(nil, nil);\r\n FAutoComplete.OnDropDown := EvDropDown;\r\n FAutoComplete.OnValidateItems := EvValidateStrings;\r\n FAutoComplete.OnChange := EvChange;\r\n FAutoComplete.OnValueChange := EvValueChange;\r\n FAutoComplete.OnItemIndexChange := EvItemIndexChange;\r\n FAutoComplete.OnValidateItemIndex := EvValidateItemIndex;\r\n\r\n FStrings := TStringList.Create;\r\nend;\r\n\r\ndestructor TJvLookupAutoComplete.Destroy;\r\nbegin\r\n SetEdit(nil); // SetEdit accesses FAutoComplete\r\n FAutoComplete.Free;\r\n SetListBox(nil);\r\n FStrings.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvLookupAutoComplete.EvChange(Sender: TObject);\r\nbegin\r\n if Assigned(FOnChange) then\r\n FOnChange(Self);\r\nend;\r\n\r\nprocedure TJvLookupAutoComplete.EvDropDown(Sender: TObject);\r\nbegin\r\n if Assigned(FOnDropDown) then\r\n FOnDropDown(Self);\r\nend;\r\n\r\nprocedure TJvLookupAutoComplete.EvItemIndexChange(Sender: TObject);\r\nbegin\r\n ItemIndex := FAutoComplete.ItemIndex;\r\nend;\r\n\r\nprocedure TJvLookupAutoComplete.EvKeyPress(Sender: TObject; var Key: Char);\r\nbegin\r\n if Assigned(FOrgKeyPress) then\r\n FOrgKeyPress(Sender, Key);\r\n FAutoComplete.AutoComplete(Key);\r\nend;\r\n\r\nprocedure TJvLookupAutoComplete.EvValidateItemIndex(Sender: TObject);\r\nbegin\r\n FAutoComplete.ItemIndex := ItemIndex;\r\nend;\r\n\r\nprocedure TJvLookupAutoComplete.EvValidateStrings(Sender: TObject);\r\nbegin\r\n if Assigned(FOnValidateStrings) then\r\n FOnValidateStrings(Self);\r\nend;\r\n\r\nprocedure TJvLookupAutoComplete.EvValueChange(Sender: TObject);\r\nbegin\r\n if Assigned(FOnValueChange) then\r\n FOnValueChange(Self);\r\nend;\r\n\r\nfunction TJvLookupAutoComplete.GetActive: Boolean;\r\nbegin\r\n Result := FAutoComplete.Active;\r\nend;\r\n\r\nfunction TJvLookupAutoComplete.GetEdit: TCustomEdit;\r\nbegin\r\n Result := FAutoComplete.EditCtrl;\r\nend;\r\n\r\nfunction TJvLookupAutoComplete.GetItemIndex: Integer;\r\nbegin\r\n Result := -1;\r\n case Kind of\r\n akListBox:\r\n if ListBox <> nil then\r\n Result := ListBox.ItemIndex;\r\n akStrings:\r\n Result := FAutoComplete.ItemIndex;\r\n end;\r\nend;\r\n\r\nfunction TJvLookupAutoComplete.GetListSearch: Boolean;\r\nbegin\r\n Result := FAutoComplete.ListSearch;\r\nend;\r\n\r\nprocedure TJvLookupAutoComplete.Notification(AComponent: TComponent;\r\n Operation: TOperation);\r\nbegin\r\n inherited Notification(AComponent, Operation);\r\n if Operation = opRemove then\r\n begin\r\n if AComponent = Edit then\r\n Edit := nil\r\n else\r\n if AComponent = ListBox then\r\n ListBox := nil;\r\n end;\r\nend;\r\n\r\nprocedure TJvLookupAutoComplete.SetActive(const Value: Boolean);\r\nbegin\r\n FAutoComplete.Active := Value;\r\nend;\r\n\r\nprocedure TJvLookupAutoComplete.SetEdit(Value: TCustomEdit);\r\nbegin\r\n if Value <> Edit then\r\n begin\r\n if Edit <> nil then\r\n begin\r\n TCustomEditAccess(Edit).OnKeyPress := FOrgKeyPress;\r\n Edit.RemoveFreeNotification(Self);\r\n end;\r\n FAutoComplete.EditCtrl := Value;\r\n if Edit <> nil then\r\n begin\r\n Edit.FreeNotification(Self);\r\n FOrgKeyPress := TCustomEditAccess(Edit).OnKeyPress;\r\n TCustomEditAccess(Edit).OnKeyPress := EvKeyPress;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvLookupAutoComplete.SetItemIndex(Value: Integer);\r\nbegin\r\n case Kind of\r\n akListBox:\r\n if ListBox <> nil then\r\n ListBox.ItemIndex := Value;\r\n akStrings:\r\n FAutoComplete.ItemIndex := Value;\r\n end;\r\nend;\r\n\r\nprocedure TJvLookupAutoComplete.SetKind(Value: TJvLookupAutoCompleteKind);\r\nbegin\r\n FKind := Value;\r\n case FKind of\r\n akListBox:\r\n if ListBox <> nil then\r\n FAutoComplete.List := ListBox.Items\r\n else\r\n FAutoComplete.List := nil;\r\n akStrings:\r\n FAutoComplete.List := FStrings;\r\n end;\r\nend;\r\n\r\nprocedure TJvLookupAutoComplete.SetListBox(Value: TCustomListBox);\r\nbegin\r\n if Value <> FListBox then\r\n begin\r\n ReplaceComponentReference(Self, Value, TComponent(FListBox));\r\n if Kind = akListBox then\r\n begin\r\n if FListBox <> nil then\r\n FAutoComplete.List := FListBox.Items\r\n else\r\n FAutoComplete.List := nil;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvLookupAutoComplete.SetListSearch(Value: Boolean);\r\nbegin\r\n FAutoComplete.ListSearch := Value;\r\nend;\r\n\r\nprocedure TJvLookupAutoComplete.SetStrings(Value: TStrings);\r\nbegin\r\n if Value <> FStrings then\r\n begin\r\n FStrings.Assign(Value);\r\n if Kind = akStrings then\r\n FAutoComplete.List := FStrings;\r\n end;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend." }, { "path": "External/Jedi/Jvcl/run/JvBDECheckPasswordForm.dfm", "content": "object JvChPswdForm: TJvChPswdForm\r\n Left = 309\r\n Top = 149\r\n ActiveControl = OldPswd\r\n BorderIcons = [biSystemMenu]\r\n BorderStyle = bsDialog\r\n ClientHeight = 115\r\n ClientWidth = 347\r\n Color = clBtnFace\r\n Font.Charset = DEFAULT_CHARSET\r\n Font.Color = clWindowText\r\n Font.Height = -11\r\n Font.Name = 'MS Sans Serif'\r\n Font.Style = []\r\n OldCreateOrder = True\r\n Position = poScreenCenter\r\n OnCreate = FormCreate\r\n OnShow = FormShow\r\n PixelsPerInch = 96\r\n TextHeight = 13\r\n object OldPswdLabel: TLabel\r\n Left = 19\r\n Top = 20\r\n Width = 94\r\n Height = 13\r\n AutoSize = False\r\n end\r\n object NewPswdLabel: TLabel\r\n Left = 19\r\n Top = 52\r\n Width = 94\r\n Height = 13\r\n AutoSize = False\r\n end\r\n object ConfirmLabel: TLabel\r\n Left = 19\r\n Top = 84\r\n Width = 94\r\n Height = 13\r\n AutoSize = False\r\n end\r\n object OldPswd: TEdit\r\n Left = 116\r\n Top = 16\r\n Width = 117\r\n Height = 21\r\n PasswordChar = '*'\r\n TabOrder = 0\r\n OnChange = PswdChange\r\n end\r\n object NewPswd: TEdit\r\n Left = 116\r\n Top = 48\r\n Width = 117\r\n Height = 21\r\n PasswordChar = '*'\r\n TabOrder = 1\r\n OnChange = PswdChange\r\n end\r\n object ConfirmNewPswd: TEdit\r\n Left = 116\r\n Top = 80\r\n Width = 117\r\n Height = 21\r\n PasswordChar = '*'\r\n TabOrder = 2\r\n OnChange = PswdChange\r\n end\r\n object OkBtn: TButton\r\n Left = 254\r\n Top = 16\r\n Width = 77\r\n Height = 25\r\n Caption = 'OK'\r\n Default = True\r\n TabOrder = 3\r\n OnClick = OkBtnClick\r\n end\r\n object CancelBtn: TButton\r\n Left = 254\r\n Top = 48\r\n Width = 77\r\n Height = 25\r\n Cancel = True\r\n Caption = 'Cancel'\r\n ModalResult = 2\r\n TabOrder = 4\r\n end\r\nend\r\n" }, { "path": "External/Jedi/Jvcl/run/JvBDECheckPasswordForm.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvChPswDlg.PAS, released on 2002-07-04.\r\n\r\nThe Initial Developers of the Original Code are: Fedor Koshevnikov, Igor Pavluk and Serge Korolev\r\nCopyright (c) 1997, 1998 Fedor Koshevnikov, Igor Pavluk and Serge Korolev\r\nCopyright (c) 2001,2002 SGB Software\r\nAll Rights Reserved.\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvBDECheckPasswordForm.pas 13389 2012-08-11 20:27:20Z ahuser $\r\n\r\nunit JvBDECheckPasswordForm;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, SysUtils, Classes, Controls, Forms, StdCtrls,\r\n DBTables, DB,\r\n JvComponent;\r\n\r\ntype\r\n TChangePasswordEvent = function(UsersTable: TTable;\r\n const OldPassword, NewPassword: string): Boolean of object;\r\n\r\nfunction ChangePasswordDialog(Database: TDatabase; AttemptNumber: Integer;\r\n const UsersTableName, UserNameField, LoginName: string;\r\n MaxPwdLen: Integer; EnableEmptyPassword: Boolean;\r\n ChangePasswordEvent: TChangePasswordEvent): Boolean;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvBDECheckPasswordForm.pas $';\r\n Revision: '$Revision: 13389 $';\r\n Date: '$Date: 2012-08-11 22:27:20 +0200 (sam. 11 août 2012) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n Consts,\r\n JvResources, JvJVCLUtils;\r\n\r\n{$R *.dfm}\r\n\r\ntype\r\n // (rom) moved to implementation for security reasons\r\n TJvChPswdForm = class(TJvForm)\r\n OldPswdLabel: TLabel;\r\n OldPswd: TEdit;\r\n NewPswdLabel: TLabel;\r\n NewPswd: TEdit;\r\n ConfirmLabel: TLabel;\r\n ConfirmNewPswd: TEdit;\r\n OkBtn: TButton;\r\n CancelBtn: TButton;\r\n procedure OkBtnClick(Sender: TObject);\r\n procedure FormShow(Sender: TObject);\r\n procedure FormCreate(Sender: TObject);\r\n procedure PswdChange(Sender: TObject);\r\n private\r\n FAttempt: Integer;\r\n FEnableEmpty: Boolean;\r\n procedure ClearEdits;\r\n procedure OkEnabled;\r\n public\r\n Database: TDatabase;\r\n AttemptNumber: Integer;\r\n UsersTableName: string;\r\n UserNameField: string;\r\n LoginName: string;\r\n OnChangePassword: TChangePasswordEvent;\r\n end;\r\n\r\nfunction ChangePasswordDialog(Database: TDatabase; AttemptNumber: Integer;\r\n const UsersTableName, UserNameField, LoginName: string;\r\n MaxPwdLen: Integer; EnableEmptyPassword: Boolean;\r\n ChangePasswordEvent: TChangePasswordEvent): Boolean;\r\nvar\r\n Form: TJvChPswdForm;\r\n SaveCursor: TCursor;\r\nbegin\r\n SaveCursor := Screen.Cursor;\r\n Screen.Cursor := crDefault;\r\n try\r\n Form := TJvChPswdForm.Create(Application);\r\n try\r\n Form.Database := Database;\r\n Form.AttemptNumber := AttemptNumber;\r\n Form.UsersTableName := UsersTableName;\r\n Form.UserNameField := UserNameField;\r\n Form.LoginName := LoginName;\r\n Form.OldPswd.MaxLength := MaxPwdLen;\r\n Form.NewPswd.MaxLength := MaxPwdLen;\r\n Form.ConfirmNewPswd.MaxLength := MaxPwdLen;\r\n Form.FEnableEmpty := EnableEmptyPassword;\r\n Form.OnChangePassword := ChangePasswordEvent;\r\n Result := (Form.ShowModal = mrOk);\r\n finally\r\n Form.Free;\r\n end;\r\n finally\r\n Screen.Cursor := SaveCursor;\r\n end;\r\nend;\r\n\r\nprocedure TJvChPswdForm.FormCreate(Sender: TObject);\r\nbegin\r\n Caption := RsChangePassword;\r\n OldPswdLabel.Caption := RsOldPasswordLabel;\r\n NewPswdLabel.Caption := RsNewPasswordLabel;\r\n ConfirmLabel.Caption := RsConfirmPasswordLabel;\r\n OkBtn.Caption := SOKButton;\r\n CancelBtn.Caption := SCancelButton;\r\nend;\r\n\r\nprocedure TJvChPswdForm.ClearEdits;\r\nbegin\r\n OldPswd.Text := '';\r\n NewPswd.Text := '';\r\n ConfirmNewPswd.Text := '';\r\n OkBtn.Enabled := FEnableEmpty;\r\nend;\r\n\r\nprocedure TJvChPswdForm.OkEnabled;\r\nbegin\r\n OkBtn.Enabled := FEnableEmpty or\r\n ((OldPswd.Text <> '') and (NewPswd.Text <> '') and (ConfirmNewPswd.Text <> ''));\r\nend;\r\n\r\nprocedure TJvChPswdForm.OkBtnClick(Sender: TObject);\r\ntype\r\n TChangePasswordError = (peMismatch, peOther);\r\nvar\r\n Table: TTable;\r\n Ok: Boolean;\r\n Error: TChangePasswordError;\r\nbegin\r\n Ok := False;\r\n Inc(FAttempt);\r\n try\r\n if FAttempt <= AttemptNumber then\r\n begin\r\n if UsersTableName <> '' then\r\n Table := TTable.Create(Self)\r\n else\r\n Table := nil;\r\n try\r\n Error := peOther;\r\n if Table <> nil then\r\n begin\r\n Table.DatabaseName := Database.DatabaseName;\r\n Table.SessionName := Database.SessionName;\r\n Table.TableName := UsersTableName;\r\n Table.IndexFieldNames := UserNameField;\r\n Table.Open;\r\n if Table.FindKey([LoginName]) then\r\n if NewPswd.Text <> ConfirmNewPswd.Text then\r\n Error := peMismatch\r\n else\r\n if Assigned(OnChangePassword) then\r\n Ok := OnChangePassword(Table, OldPswd.Text, NewPswd.Text);\r\n end\r\n else\r\n begin\r\n if NewPswd.Text <> ConfirmNewPswd.Text then\r\n Error := peMismatch\r\n else\r\n if Assigned(OnChangePassword) then\r\n Ok := OnChangePassword(Table, OldPswd.Text, NewPswd.Text);\r\n end;\r\n if Ok then\r\n JvMessageBox(RsPasswordChanged, MB_OK or MB_ICONINFORMATION)\r\n else\r\n if Error = peMismatch then\r\n JvMessageBox(RsPasswordsMismatch, MB_OK or MB_ICONERROR)\r\n else\r\n JvMessageBox(RsPasswordNotChanged, MB_OK or MB_ICONERROR);\r\n finally\r\n if Table <> nil then\r\n Table.Free;\r\n end;\r\n end;\r\n finally\r\n if Ok then\r\n ModalResult := mrOk\r\n else\r\n if FAttempt > AttemptNumber then\r\n ModalResult := mrCancel\r\n else\r\n ModalResult := mrNone;\r\n end;\r\nend;\r\n\r\nprocedure TJvChPswdForm.FormShow(Sender: TObject);\r\nbegin\r\n ClearEdits;\r\nend;\r\n\r\nprocedure TJvChPswdForm.PswdChange(Sender: TObject);\r\nbegin\r\n OkEnabled;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvBDEExceptionForm.dfm", "content": "object JvBdeErrorDlg: TJvBdeErrorDlg\r\n Left = 202\r\n Top = 100\r\n ActiveControl = OKBtn\r\n BorderIcons = [biSystemMenu]\r\n BorderStyle = bsDialog\r\n ClientHeight = 252\r\n ClientWidth = 380\r\n Color = clBtnFace\r\n Font.Charset = DEFAULT_CHARSET\r\n Font.Color = clWindowText\r\n Font.Height = -11\r\n Font.Name = 'MS Sans Serif'\r\n Font.Style = []\r\n FormStyle = fsStayOnTop\r\n OldCreateOrder = True\r\n Position = poScreenCenter\r\n OnCreate = FormCreate\r\n OnDestroy = FormDestroy\r\n OnShow = FormShow\r\n PixelsPerInch = 96\r\n TextHeight = 13\r\n object BasicPanel: TPanel\r\n Left = 0\r\n Top = 0\r\n Width = 288\r\n Height = 108\r\n Align = alClient\r\n BevelOuter = bvNone\r\n TabOrder = 0\r\n object ErrorText: TLabel\r\n Left = 49\r\n Top = 10\r\n Width = 231\r\n Height = 88\r\n Align = alClient\r\n WordWrap = True\r\n end\r\n object IconPanel: TPanel\r\n Left = 0\r\n Top = 10\r\n Width = 49\r\n Height = 88\r\n Align = alLeft\r\n BevelOuter = bvNone\r\n TabOrder = 0\r\n object IconImage: TImage\r\n Left = 6\r\n Top = 1\r\n Width = 34\r\n Height = 34\r\n end\r\n end\r\n object TopPanel: TPanel\r\n Left = 0\r\n Top = 0\r\n Width = 288\r\n Height = 10\r\n Align = alTop\r\n BevelOuter = bvNone\r\n TabOrder = 1\r\n end\r\n object RightPanel: TPanel\r\n Left = 280\r\n Top = 10\r\n Width = 8\r\n Height = 88\r\n Align = alRight\r\n BevelOuter = bvNone\r\n TabOrder = 2\r\n end\r\n object BottomPanel: TPanel\r\n Left = 0\r\n Top = 98\r\n Width = 288\r\n Height = 10\r\n Align = alBottom\r\n BevelOuter = bvNone\r\n TabOrder = 3\r\n end\r\n end\r\n object DetailsPanel: TPanel\r\n Left = 0\r\n Top = 108\r\n Width = 380\r\n Height = 144\r\n Align = alBottom\r\n BevelInner = bvLowered\r\n BevelOuter = bvLowered\r\n TabOrder = 2\r\n object BDELabel: TLabel\r\n Left = 87\r\n Top = 11\r\n Width = 121\r\n Height = 13\r\n Alignment = taRightJustify\r\n AutoSize = False\r\n end\r\n object NativeLabel: TLabel\r\n Left = 87\r\n Top = 30\r\n Width = 121\r\n Height = 13\r\n Alignment = taRightJustify\r\n AutoSize = False\r\n end\r\n object DbMessageText: TMemo\r\n Left = 7\r\n Top = 53\r\n Width = 366\r\n Height = 54\r\n TabStop = False\r\n Color = clBtnFace\r\n ReadOnly = True\r\n TabOrder = 0\r\n WantReturns = False\r\n end\r\n object DbResult: TEdit\r\n Left = 214\r\n Top = 8\r\n Width = 80\r\n Height = 21\r\n TabStop = False\r\n ParentColor = True\r\n ReadOnly = True\r\n TabOrder = 1\r\n end\r\n object DbCatSub: TEdit\r\n Left = 293\r\n Top = 8\r\n Width = 80\r\n Height = 21\r\n TabStop = False\r\n ParentColor = True\r\n ReadOnly = True\r\n TabOrder = 2\r\n end\r\n object NativeResult: TEdit\r\n Left = 214\r\n Top = 27\r\n Width = 159\r\n Height = 21\r\n TabStop = False\r\n ParentColor = True\r\n ReadOnly = True\r\n TabOrder = 3\r\n end\r\n object Back: TButton\r\n Left = 210\r\n Top = 112\r\n Width = 79\r\n Height = 25\r\n TabOrder = 4\r\n OnClick = BackClick\r\n end\r\n object Next: TButton\r\n Left = 294\r\n Top = 112\r\n Width = 79\r\n Height = 25\r\n TabOrder = 5\r\n OnClick = NextClick\r\n end\r\n end\r\n object ButtonPanel: TPanel\r\n Left = 288\r\n Top = 0\r\n Width = 92\r\n Height = 108\r\n Align = alRight\r\n BevelOuter = bvNone\r\n TabOrder = 1\r\n object DetailsBtn: TButton\r\n Left = 7\r\n Top = 65\r\n Width = 79\r\n Height = 25\r\n TabOrder = 1\r\n OnClick = DetailsBtnClick\r\n end\r\n object OKBtn: TButton\r\n Left = 7\r\n Top = 12\r\n Width = 79\r\n Height = 25\r\n Cancel = True\r\n Default = True\r\n ModalResult = 1\r\n TabOrder = 0\r\n end\r\n end\r\nend\r\n" }, { "path": "External/Jedi/Jvcl/run/JvBDEExceptionForm.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvDbExcpt.PAS, released on 2002-07-04.\r\n\r\nThe Initial Developers of the Original Code are: Fedor Koshevnikov, Igor Pavluk and Serge Korolev\r\nCopyright (c) 1997, 1998 Fedor Koshevnikov, Igor Pavluk and Serge Korolev\r\nCopyright (c) 2001,2002 SGB Software\r\nAll Rights Reserved.\r\n\r\nTJvBdeErrorDlg based on sample form\r\n DELPHI\\DEMOS\\DB\\TOOLS\\DBEXCEPT.PAS\r\n\r\nContributor(s):\r\n Hofi\r\n\r\nLast Modified: 2004-10-07\r\n\r\nChanges:\r\n2004-10-07:\r\n * Added by Hofi\r\n TJvBdeErrorDlg\r\n property GlobalNotMemberExceptionHandler\r\n gives a chance to handle db exceptions in a global common exception\r\n handler.\r\n\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvBDEExceptionForm.pas 12461 2009-08-14 17:21:33Z obones $\r\n\r\nunit JvBDEExceptionForm;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n SysUtils, Classes, Graphics, Controls, Forms, Dialogs,\r\n StdCtrls, ExtCtrls, DBTables,\r\n JvComponent;\r\n\r\ntype\r\n TDBErrorEvent = procedure(Error: TDBError; var Msg: string) of object;\r\n TNotMemberExceptionEventHandler = procedure (Sender: TObject; E: Exception);\r\n\r\n TJvBdeErrorDlg = class(TJvForm)\r\n BasicPanel: TPanel;\r\n ErrorText: TLabel;\r\n IconPanel: TPanel;\r\n IconImage: TImage;\r\n TopPanel: TPanel;\r\n RightPanel: TPanel;\r\n DetailsPanel: TPanel;\r\n DbMessageText: TMemo;\r\n DbResult: TEdit;\r\n DbCatSub: TEdit;\r\n NativeResult: TEdit;\r\n Back: TButton;\r\n Next: TButton;\r\n ButtonPanel: TPanel;\r\n DetailsBtn: TButton;\r\n OKBtn: TButton;\r\n BDELabel: TLabel;\r\n NativeLabel: TLabel;\r\n BottomPanel: TPanel;\r\n procedure FormCreate(Sender: TObject);\r\n procedure FormDestroy(Sender: TObject);\r\n procedure FormShow(Sender: TObject);\r\n procedure DetailsBtnClick(Sender: TObject);\r\n procedure BackClick(Sender: TObject);\r\n procedure NextClick(Sender: TObject);\r\n private\r\n FCurItem: Integer;\r\n FDetails: Boolean;\r\n FDetailsHeight: Integer;\r\n FDbException: EDbEngineError;\r\n FGlobalNotMemberExceptionHandler: TNotMemberExceptionEventHandler;\r\n FPrevOnException: TExceptionEvent;\r\n FOnErrorMsg: TDBErrorEvent;\r\n procedure GetErrorMsg(Error: TDBError; var Msg: string);\r\n procedure ShowError;\r\n procedure SetShowDetails(Value: Boolean);\r\n public\r\n procedure SetGlobalExceptionHandler(\r\n GlobalNotMemberExceptionHandler: TNotMemberExceptionEventHandler);\r\n procedure ShowException(Sender: TObject; E: Exception);\r\n property OnErrorMsg: TDBErrorEvent read FOnErrorMsg write FOnErrorMsg;\r\n end;\r\n\r\nconst\r\n DbErrorHelpCtx = THelpContext(0);\r\n\r\nprocedure DbErrorIntercept(\r\n GlobalNotMemberExceptionHandler: TNotMemberExceptionEventHandler = nil);\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvBDEExceptionForm.pas $';\r\n Revision: '$Revision: 12461 $';\r\n Date: '$Date: 2009-08-14 19:21:33 +0200 (ven. 14 août 2009) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n Consts, Windows, BDE,\r\n JvResources;\r\n\r\n{$R *.dfm}\r\n\r\nvar\r\n DbEngineErrorDlg: TJvBdeErrorDlg = nil;\r\n\r\nprocedure DbErrorIntercept(\r\n GlobalNotMemberExceptionHandler: TNotMemberExceptionEventHandler);\r\nbegin\r\n DbEngineErrorDlg.Free;\r\n DbEngineErrorDlg := TJvBdeErrorDlg.Create(Application);\r\n DbEngineErrorDlg.SetGlobalExceptionHandler(GlobalNotMemberExceptionHandler);\r\nend;\r\n\r\nprocedure TJvBdeErrorDlg.ShowException(Sender: TObject; E: Exception);\r\nbegin\r\n Screen.Cursor := crDefault;\r\n Application.NormalizeTopMosts;\r\n try\r\n if (E is EDbEngineError) and (FDbException = nil) and\r\n not Application.Terminated then\r\n begin\r\n FDbException := EDbEngineError(E);\r\n try\r\n ShowModal;\r\n finally\r\n FDbException := nil;\r\n end;\r\n if Assigned(FGlobalNotMemberExceptionHandler) then\r\n FGlobalNotMemberExceptionHandler(Sender, E);\r\n end\r\n else\r\n begin\r\n if Assigned(FGlobalNotMemberExceptionHandler) or Assigned(FPrevOnException) then\r\n begin\r\n if Assigned(FGlobalNotMemberExceptionHandler) then\r\n FGlobalNotMemberExceptionHandler(Sender, E);\r\n if Assigned(FPrevOnException) then\r\n FPrevOnException(Sender, E);\r\n end\r\n else\r\n Application.ShowException(E);\r\n end;\r\n except\r\n { ignore any exceptions }\r\n end;\r\n Application.RestoreTopMosts;\r\nend;\r\n\r\nprocedure TJvBdeErrorDlg.SetGlobalExceptionHandler(\r\n GlobalNotMemberExceptionHandler: TNotMemberExceptionEventHandler);\r\nbegin\r\n FGlobalNotMemberExceptionHandler := GlobalNotMemberExceptionHandler;\r\nend;\r\n\r\nprocedure TJvBdeErrorDlg.ShowError;\r\nvar\r\n BDEError: TDBError;\r\n S: string;\r\n I: Integer;\r\nbegin\r\n Back.Enabled := (FCurItem > 0);\r\n Next.Enabled := (FCurItem < FDbException.ErrorCount - 1);\r\n BDEError := FDbException.Errors[FCurItem];\r\n { Fill BDE error information }\r\n BDELabel.Enabled := True;\r\n DbResult.Text := IntToStr(BDEError.ErrorCode);\r\n DbCatSub.Text := Format('[$%s] [$%s]', [IntToHex(BDEError.Category, 2),\r\n IntToHex(BDEError.SubCode, 2)]);\r\n { Fill native error information }\r\n NativeLabel.Enabled := BDEError.NativeError <> 0;\r\n if NativeLabel.Enabled then\r\n NativeResult.Text := IntToStr(BDEError.NativeError)\r\n else\r\n NativeResult.Clear;\r\n { The message text is common to both BDE and native errors }\r\n S := Trim(BDEError.Message);\r\n for I := 1 to Length(S) do\r\n if S[I] < ' ' then\r\n S[I] := ' ';\r\n {GetErrorMsg(BDEError, S);}\r\n DbMessageText.Text := Trim(S);\r\nend;\r\n\r\nprocedure TJvBdeErrorDlg.SetShowDetails(Value: Boolean);\r\nbegin\r\n DisableAlign;\r\n try\r\n if Value then\r\n begin\r\n DetailsPanel.Height := FDetailsHeight;\r\n ClientHeight := DetailsPanel.Height + BasicPanel.Height;\r\n DetailsBtn.Caption := RsDetailsLeftCaption;\r\n FCurItem := 0;\r\n ShowError;\r\n end\r\n else\r\n begin\r\n ClientHeight := BasicPanel.Height;\r\n DetailsPanel.Height := 0;\r\n DetailsBtn.Caption := RsDetailsRightCaption;\r\n end;\r\n DetailsPanel.Enabled := Value;\r\n FDetails := Value;\r\n finally\r\n EnableAlign;\r\n end;\r\nend;\r\n\r\nprocedure TJvBdeErrorDlg.GetErrorMsg(Error: TDBError; var Msg: string);\r\nbegin\r\n if Assigned(FOnErrorMsg) then\r\n try\r\n FOnErrorMsg(Error, Msg);\r\n except\r\n end;\r\nend;\r\n\r\nprocedure TJvBdeErrorDlg.FormCreate(Sender: TObject);\r\nbegin\r\n FDetailsHeight := DetailsPanel.Height;\r\n Icon.Handle := LoadIcon(0, IDI_EXCLAMATION);\r\n IconImage.Picture.Icon := Icon;\r\n { Load string resources }\r\n Caption := RsDBExceptCaption;\r\n BDELabel.Caption := RsBDEErrorLabel;\r\n NativeLabel.Caption := RsServerErrorLabel;\r\n Next.Caption := RsNextButtonCaption;\r\n Back.Caption := RsPrevButtonCaption;\r\n OKBtn.Caption := SOKButton;\r\n { Set exception handler }\r\n FPrevOnException := Application.OnException;\r\n Application.OnException := ShowException;\r\nend;\r\n\r\nprocedure TJvBdeErrorDlg.FormDestroy(Sender: TObject);\r\nbegin\r\n Application.OnException := FPrevOnException;\r\nend;\r\n\r\nprocedure TJvBdeErrorDlg.FormShow(Sender: TObject);\r\nvar\r\n S: string;\r\n ErrNo: Integer;\r\nbegin\r\n if FDbException.HelpContext <> 0 then\r\n HelpContext := FDbException.HelpContext\r\n else\r\n HelpContext := DbErrorHelpCtx;\r\n FCurItem := 0;\r\n if (FDbException.ErrorCount > 1) and\r\n (FDbException.Errors[1].NativeError <> 0) and\r\n ((FDbException.Errors[0].ErrorCode = DBIERR_UNKNOWNSQL) or\r\n { General SQL error }\r\n (FDbException.Errors[0].ErrorCode = DBIERR_INVALIDUSRPASS)) then\r\n { Unknown username or password }\r\n ErrNo := 1\r\n else\r\n ErrNo := 0;\r\n S := Trim(FDbException.Errors[ErrNo].Message);\r\n GetErrorMsg(FDbException.Errors[ErrNo], S);\r\n ErrorText.Caption := S;\r\n SetShowDetails(False);\r\n DetailsBtn.Enabled := FDbException.ErrorCount > 0;\r\nend;\r\n\r\nprocedure TJvBdeErrorDlg.DetailsBtnClick(Sender: TObject);\r\nbegin\r\n SetShowDetails(not FDetails);\r\nend;\r\n\r\nprocedure TJvBdeErrorDlg.BackClick(Sender: TObject);\r\nbegin\r\n Dec(FCurItem);\r\n ShowError;\r\nend;\r\n\r\nprocedure TJvBdeErrorDlg.NextClick(Sender: TObject);\r\nbegin\r\n Inc(FCurItem);\r\n ShowError;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvBDEFilter.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvDBFilter.PAS, released on 2002-07-04.\r\n\r\nThe Initial Developers of the Original Code are: Fedor Koshevnikov, Igor Pavluk and Serge Korolev\r\nCopyright (c) 1997, 1998 Fedor Koshevnikov, Igor Pavluk and Serge Korolev\r\nCopyright (c) 2001,2002 SGB Software\r\nAll Rights Reserved.\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvBDEFilter.pas 13415 2012-09-10 09:51:54Z obones $\r\n\r\nunit JvBDEFilter;\r\n\r\ninterface\r\n\r\n{$I jvcl.inc}\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Classes, BDE, DB,\r\n JvTypes, JvComponentBase;\r\n\r\ntype\r\n TFilterLogicCond = (flAnd, flOr); { for captured DataSet }\r\n TDBFilterOption = TFilterOption;\r\n TDBFilterOptions = TFilterOptions;\r\n\r\n TFilterEvent = function(Sender: TObject; DataSet: TDataSet): Boolean of object;\r\n\r\n TDataSetStorage = record { for internal use only }\r\n FBof: Boolean;\r\n FEof: Boolean;\r\n State: TDataSetState;\r\n CanModify: Boolean;\r\n BeforePost: TDataSetNotifyEvent;\r\n BeforeCancel: TDataSetNotifyEvent;\r\n BeforeInsert: TDataSetNotifyEvent;\r\n BeforeEdit: TDataSetNotifyEvent;\r\n end;\r\n\r\n TJvDBFilter = class(TJvComponent)\r\n private\r\n FParser: TObject;\r\n FDataLink: TDataLink;\r\n FIgnoreDataEvents: Boolean;\r\n FPriority: Word;\r\n FOptions: TDBFilterOptions;\r\n FLogicCond: TFilterLogicCond;\r\n FFilter: TStringList;\r\n FExprHandle: hDBIFilter;\r\n FFuncHandle: hDBIFilter;\r\n FDataHandle: hDBICur;\r\n FActive: Boolean;\r\n FCaptured: Boolean;\r\n FStreamedActive: Boolean;\r\n FActivating: Boolean;\r\n FStorage: TDataSetStorage;\r\n FOnFiltering: TFilterEvent;\r\n FOnActivate: TNotifyEvent;\r\n FOnDeactivate: TNotifyEvent;\r\n FOnSetCapture: TNotifyEvent;\r\n FOnReleaseCapture: TNotifyEvent;\r\n procedure SetDataSource(Value: TDataSource);\r\n function GetDataSource: TDataSource;\r\n function BuildTree: Boolean;\r\n procedure DestroyTree;\r\n function GetFilter: TStrings;\r\n procedure SetFilter(Value: TStrings);\r\n procedure SetOptions(Value: TDBFilterOptions);\r\n procedure SetOnFiltering(const Value: TFilterEvent);\r\n procedure SetPriority(Value: Word);\r\n procedure SetLogicCond(Value: TFilterLogicCond);\r\n function GetFilterText: string;\r\n procedure FilterChanged(Sender: TObject);\r\n function CreateExprFilter: hDBIFilter;\r\n function CreateFuncFilter: hDBIFilter;\r\n procedure DropFilters;\r\n procedure SetFilterHandle(var Filter: hDBIFilter; Value: hDBIFilter);\r\n procedure RecreateExprFilter;\r\n procedure RecreateFuncFilter;\r\n procedure ActivateFilters;\r\n procedure DeactivateFilters;\r\n function RecordFilter(RecBuf: Pointer; RecNo: Longint): Smallint;stdcall;\r\n procedure BeforeDataPost(DataSet: TDataSet);\r\n procedure BeforeDataChange(DataSet: TDataSet);\r\n procedure BeforeDataCancel(DataSet: TDataSet);\r\n procedure SetActive(Value: Boolean);\r\n protected\r\n procedure Loaded; override;\r\n procedure Notification(AComponent: TComponent; Operation: TOperation); override;\r\n procedure DoActivate; dynamic;\r\n procedure DoDeactivate; dynamic;\r\n procedure ActiveChanged; virtual;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n procedure Update; virtual;\r\n procedure UpdateFuncFilter;\r\n procedure Activate;\r\n procedure Deactivate;\r\n procedure SetCapture;\r\n procedure ReleaseCapture;\r\n procedure ReadCaptureControls;\r\n property Captured: Boolean read FCaptured;\r\n property Handle: hDBIFilter read FExprHandle; { obsolete, use ExprFilter }\r\n property ExprFilter: hDBIFilter read FExprHandle;\r\n property FuncFilter: hDBIFilter read FFuncHandle;\r\n published\r\n property Active: Boolean read FActive write SetActive default False;\r\n property DataSource: TDataSource read GetDataSource write SetDataSource;\r\n property Filter: TStrings read GetFilter write SetFilter;\r\n property LogicCond: TFilterLogicCond read FLogicCond write SetLogicCond default flAnd;\r\n property Options: TDBFilterOptions read FOptions write SetOptions default [];\r\n property Priority: Word read FPriority write SetPriority default 0;\r\n property OnActivate: TNotifyEvent read FOnActivate write FOnActivate;\r\n property OnDeactivate: TNotifyEvent read FOnDeactivate write FOnDeactivate;\r\n property OnFiltering: TFilterEvent read FOnFiltering write SetOnFiltering;\r\n property OnSetCapture: TNotifyEvent read FOnSetCapture write FOnSetCapture;\r\n property OnReleaseCapture: TNotifyEvent read FOnReleaseCapture write FOnReleaseCapture;\r\n end;\r\n\r\n EJVCLFilterError = class(EJVCLException);\r\n\r\nprocedure DropAllFilters(DataSet: TDataSet);\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvBDEFilter.pas $';\r\n Revision: '$Revision: 13415 $';\r\n Date: '$Date: 2012-09-10 11:51:54 +0200 (lun. 10 sept. 2012) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n SysUtils, Forms, DBConsts, DBCommon, DBTables,\r\n JvDBUtils, JvBdeUtils, JvResources;\r\n\r\nprocedure DropAllFilters(DataSet: TDataSet);\r\nbegin\r\n if (DataSet <> nil) and DataSet.Active then\r\n begin\r\n DataSet.Filtered := False;\r\n DbiDropFilter(TBDEDataSet(DataSet).Handle, nil);\r\n DataSet.CursorPosChanged;\r\n DataSet.Resync([]);\r\n end;\r\nend;\r\n\r\nconst\r\n SExprNothing = '\"\"'; { nothing token name }\r\n cQuota = ''''; { quotas for string constants }\r\n cFldQuotaLeft = '['; { left qouta for field names }\r\n cFldQuotaRight = ']'; { right qouta for field names }\r\n\r\n{$HINTS OFF}\r\n\r\ntype\r\n {$IFDEF COMPILER12_UP}\r\n TJvRecordBuffer = TRecordBuffer; // Delphi 2009\r\n {$ELSE}\r\n TJvRecordBuffer = PAnsiChar;\r\n {$ENDIF COMPILER12_UP}\r\n \r\n TDataSetAccessProtected = class(TDataSet);\r\n\r\n{*******************************************************}\r\n{ !! ATTENTION Nasty implementation }\r\n{*******************************************************}\r\n{ }\r\n{ These class definitions were copied from TDataSet }\r\n{ (DB.PAS) and TBDEDataSet (DBTABLES.PAS). }\r\n{ It is needed to access FState, FBof, FEof, FBuffers, }\r\n{ FRecordCount, FActiveRecord, FCanModify private }\r\n{ fields of TDataSet. }\r\n{ }\r\n{ Any changes in the underlying classes may cause }\r\n{ errors in this implementation! }\r\n{ }\r\n{*******************************************************}\r\n\r\n PBufferList = TBufferList;\r\n\r\n TNastyDataSet = class(TComponent)\r\n private\r\n FFields: TFields;\r\n FAggFields: TFields;\r\n FFieldDefs: TFieldDefs;\r\n FFieldDefList: TFieldDefList;\r\n FFieldList: TFieldList;\r\n FDataSources: TList;\r\n FFirstDataLink: TDataLink;\r\n FBufferCount: Integer;\r\n FRecordCount: Integer;\r\n FActiveRecord: Integer;\r\n FCurrentRecord: Integer;\r\n FBuffers: TBufferList;\r\n FCalcBuffer: PChar;\r\n FBookmarkSize: Integer;\r\n FCalcFieldsSize: Integer;\r\n FDesigner: TDataSetDesigner;\r\n FDisableCount: Integer;\r\n FBlobFieldCount: Integer;\r\n FFilterText: string;\r\n FBlockReadSize: Integer;\r\n FConstraints: TCheckConstraints;\r\n FDataSetField: TDataSetField;\r\n FNestedDataSets: TList;\r\n FNestedDatasetClass: TClass;\r\n FReserved: Pointer;\r\n FFieldNoOfs: Integer;\r\n { Byte sized data members (for alignment) }\r\n FFilterOptions: TFilterOptions;\r\n FState: TDataSetState;\r\n FEnableEvent: TDataEvent;\r\n FDisableState: TDataSetState;\r\n FBof: Boolean;\r\n FEof: Boolean;\r\n end;\r\n\r\n TBDENastyDataSet = class(TDataSet)\r\n private\r\n FHandle: hDBICur;\r\n FStmtHandle: hDBIStmt;\r\n FRecProps: RecProps;\r\n FLocale: TLocale;\r\n FExprFilter: hDBIFilter;\r\n FFuncFilter: hDBIFilter;\r\n FFilterBuffer: PChar;\r\n FIndexFieldMap: DBIKey;\r\n FExpIndex: Boolean;\r\n FCaseInsIndex: Boolean;\r\n FCachedUpdates: Boolean;\r\n FInUpdateCallback: Boolean;\r\n FCanModify: Boolean;\r\n end;\r\n\r\n{$HINTS ON}\r\n\r\nprocedure DsSetState(DataSet: TDataSet; Value: TDataSetState);\r\nbegin\r\n TNastyDataSet(DataSet).FState := Value;\r\nend;\r\n\r\nprocedure DsSetBOF(DataSet: TDataSet; Value: Boolean);\r\nbegin\r\n TNastyDataSet(DataSet).FBof := Value;\r\nend;\r\n\r\nprocedure DsSetEOF(DataSet: TDataSet; Value: Boolean);\r\nbegin\r\n TNastyDataSet(DataSet).FEof := Value;\r\nend;\r\n\r\nprocedure AssignBuffers(const Source: TBufferList; var Dest: TBufferList);\r\nbegin\r\n SetLength(Dest, Length(Source));\r\n Move(Pointer(Source)^, Pointer(Dest)^, Length(Source) * SizeOf(PChar));\r\nend;\r\n\r\nprocedure DsGetBuffers(DataSet: TDataSet; var ABuf: TBufferList);\r\nbegin\r\n with TNastyDataSet(DataSet) do\r\n AssignBuffers(FBuffers, ABuf);\r\nend;\r\n\r\nprocedure DsSetBuffers(DataSet: TDataSet; const Value: TBufferList);\r\nbegin\r\n AssignBuffers(Value, TNastyDataSet(DataSet).FBuffers);\r\nend;\r\n\r\nfunction DsGetRecordCount(DataSet: TDataSet): Integer;\r\nbegin\r\n Result := TNastyDataSet(DataSet).FRecordCount;\r\nend;\r\n\r\nprocedure DsSetRecordCount(DataSet: TDataSet; Value: Integer);\r\nbegin\r\n TNastyDataSet(DataSet).FRecordCount := Value;\r\nend;\r\n\r\nfunction DsGetActiveRecord(DataSet: TDataSet): Integer;\r\nbegin\r\n Result := TNastyDataSet(DataSet).FActiveRecord;\r\nend;\r\n\r\nprocedure DsSetActiveRecord(DataSet: TDataSet; Value: Integer);\r\nbegin\r\n TNastyDataSet(DataSet).FActiveRecord := Value;\r\nend;\r\n\r\nfunction DsGetCanModify(DataSet: TBDEDataSet): Boolean;\r\nbegin\r\n Result := TBDENastyDataSet(DataSet).FCanModify;\r\nend;\r\n\r\nprocedure DsSetCanModify(DataSet: TBDEDataSet; Value: Boolean);\r\nbegin\r\n TBDENastyDataSet(DataSet).FCanModify := Value;\r\nend;\r\n\r\n//=== { TJvFilterDataLink } ==================================================\r\n\r\ntype\r\n TJvFilterDataLink = class(TDataLink)\r\n private\r\n FFilter: TJvDBFilter;\r\n protected\r\n procedure ActiveChanged; override;\r\n public\r\n constructor Create(Filter: TJvDBFilter);\r\n destructor Destroy; override;\r\n end;\r\n\r\nconstructor TJvFilterDataLink.Create(Filter: TJvDBFilter);\r\nbegin\r\n inherited Create;\r\n FFilter := Filter;\r\nend;\r\n\r\ndestructor TJvFilterDataLink.Destroy;\r\nbegin\r\n FFilter := nil;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvFilterDataLink.ActiveChanged;\r\nbegin\r\n if FFilter <> nil then\r\n FFilter.ActiveChanged;\r\nend;\r\n\r\n//=== { TJvDBFilter } ========================================================\r\n\r\nconstructor TJvDBFilter.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FDataLink := TJvFilterDataLink.Create(Self);\r\n FFilter := TStringList.Create;\r\n FFilter.OnChange := FilterChanged;\r\n FLogicCond := flAnd;\r\n FIgnoreDataEvents := False;\r\nend;\r\n\r\ndestructor TJvDBFilter.Destroy;\r\nbegin\r\n FFilter.OnChange := nil;\r\n Deactivate;\r\n DropFilters;\r\n FFilter.Free;\r\n FDataLink.Free;\r\n FDataLink := nil;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvDBFilter.Loaded;\r\nbegin\r\n inherited Loaded;\r\n try\r\n if FStreamedActive then\r\n Active := True;\r\n except\r\n if csDesigning in ComponentState then\r\n Application.HandleException(Self)\r\n else\r\n raise;\r\n end;\r\nend;\r\n\r\nfunction TJvDBFilter.GetDataSource: TDataSource;\r\nbegin\r\n Result := FDataLink.DataSource;\r\nend;\r\n\r\nprocedure TJvDBFilter.SetDataSource(Value: TDataSource);\r\nvar\r\n DSChange: Boolean;\r\nbegin\r\n if not (csLoading in ComponentState) then\r\n ReleaseCapture;\r\n DSChange := True;\r\n if (Value <> nil) and (DataSource <> nil) then\r\n DSChange := (Value.DataSet <> FDataLink.DataSet);\r\n FIgnoreDataEvents := not DSChange;\r\n try\r\n if not (csLoading in ComponentState) then\r\n ActiveChanged;\r\n \r\n if FDataLink.DataSource <> nil then\r\n FDataLink.DataSource.RemoveFreeNotification(Self);\r\n\r\n FDataLink.DataSource := Value;\r\n \r\n if Value <> nil then\r\n Value.FreeNotification(Self);\r\n finally\r\n FIgnoreDataEvents := False;\r\n end;\r\nend;\r\n\r\nprocedure TJvDBFilter.Notification(AComponent: TComponent;\r\n Operation: TOperation);\r\nbegin\r\n inherited Notification(AComponent, Operation);\r\n if (Operation = opRemove) and (FDataLink <> nil) then\r\n if AComponent = DataSource then\r\n DataSource := nil;\r\nend;\r\n\r\nfunction TJvDBFilter.CreateExprFilter: hDBIFilter;\r\nbegin\r\n Result := nil;\r\n if FFilter.Count > 0 then\r\n if BuildTree then\r\n try\r\n Check(DbiAddFilter((FDataLink.DataSet as TBDEDataSet).Handle,\r\n Longint(Self), FPriority, False,\r\n pCANExpr(TExprParser(FParser).FilterData), nil, Result));\r\n FDataHandle := TBDEDataSet(FDataLink.DataSet).Handle;\r\n finally\r\n DestroyTree;\r\n end;\r\nend;\r\n\r\nfunction TJvDBFilter.CreateFuncFilter: hDBIFilter;\r\nvar\r\n FuncPriority: Word;\r\nbegin\r\n if (FPriority < $FFFF) and (FExprHandle <> nil) then\r\n FuncPriority := FPriority + 1\r\n else\r\n FuncPriority := FPriority;\r\n Check(DbiAddFilter((FDataLink.DataSet as TBDEDataSet).Handle, Longint(Self),\r\n FuncPriority, False, nil, PFGENFilter(@TJvDBFilter.RecordFilter),\r\n Result));\r\n FDataHandle := TBDEDataSet(FDataLink.DataSet).Handle;\r\nend;\r\n\r\nprocedure TJvDBFilter.SetFilterHandle(var Filter: hDBIFilter;\r\n Value: hDBIFilter);\r\nvar\r\n Info: FilterInfo;\r\nbegin\r\n if FActive and FDataLink.Active then\r\n begin\r\n FDataLink.DataSet.CursorPosChanged;\r\n DbiSetToBegin((FDataLink.DataSet as TBDEDataSet).Handle);\r\n if (Filter <> nil) and (Filter <> Value) then\r\n DbiDropFilter((FDataLink.DataSet as TBDEDataSet).Handle, Filter);\r\n Filter := Value;\r\n if Filter <> nil then\r\n DbiActivateFilter((FDataLink.DataSet as TBDEDataSet).Handle, Filter);\r\n end\r\n else\r\n if FActive and (Filter <> nil) and (FDataHandle <> nil) and\r\n (FDataLink.DataSet = nil) and (Value = nil) then\r\n begin\r\n if DbiGetFilterInfo(FDataHandle, Filter, 0, 0, Info) = DBIERR_NONE then\r\n DbiDeactivateFilter(FDataHandle, Filter);\r\n Filter := Value;\r\n end\r\n else\r\n Filter := Value;\r\nend;\r\n\r\nprocedure TJvDBFilter.DropFilters;\r\nbegin\r\n SetFilterHandle(FExprHandle, nil);\r\n SetFilterHandle(FFuncHandle, nil);\r\n FDataHandle := nil;\r\n FActive := False;\r\nend;\r\n\r\nprocedure TJvDBFilter.ActivateFilters;\r\nbegin\r\n if FExprHandle <> nil then\r\n DbiActivateFilter((FDataLink.DataSet as TBDEDataSet).Handle, FExprHandle);\r\n if FFuncHandle <> nil then\r\n DbiActivateFilter((FDataLink.DataSet as TBDEDataSet).Handle, FFuncHandle);\r\nend;\r\n\r\nprocedure TJvDBFilter.DeactivateFilters;\r\nbegin\r\n if FFuncHandle <> nil then\r\n DbiDeactivateFilter(TBDEDataSet(FDataLink.DataSet).Handle, FFuncHandle);\r\n if FExprHandle <> nil then\r\n DbiDeactivateFilter(TBDEDataSet(FDataLink.DataSet).Handle, FExprHandle);\r\nend;\r\n\r\nfunction TJvDBFilter.RecordFilter(RecBuf: Pointer; RecNo: Longint): Smallint;\r\nvar\r\n ACanModify: Boolean;\r\n Buffers: PBufferList;\r\n BufPtr: TBufferList;\r\n ActiveRecord: Integer;\r\n RecCount: Integer;\r\n DS: TBDEDataSet;\r\nbegin\r\n Result := Ord(True);\r\n if Assigned(FOnFiltering) and (FFuncHandle <> nil) then\r\n try\r\n DS := FDataLink.DataSet as TBDEDataSet;\r\n { save current DataSet's private fields values }\r\n DsGetBuffers(DS, Buffers);\r\n ActiveRecord := DsGetActiveRecord(DS);\r\n RecCount := DsGetRecordCount(DS);\r\n ACanModify := DsGetCanModify(DS);\r\n try\r\n DsSetActiveRecord(DS, 0);\r\n DsSetRecordCount(DS, 1); { FActiveRecord + 1 }\r\n DsSetCanModify(DS, False);\r\n SetLength(BufPtr, 1);\r\n BufPtr[0] := TJvRecordBuffer(RecBuf);\r\n DsSetBuffers(DS, BufPtr);\r\n { call user defined function }\r\n Result := Ord(FOnFiltering(Self, DS));\r\n finally\r\n DsSetCanModify(DS, ACanModify);\r\n DsSetActiveRecord(DS, ActiveRecord);\r\n DsSetRecordCount(DS, RecCount);\r\n DsSetBuffers(DS, Buffers);\r\n end;\r\n except\r\n Application.HandleException(Self);\r\n Result := BDE.ABORT; { BDE constant, not SysUtils.pas procedure }\r\n end;\r\nend;\r\n\r\nprocedure TJvDBFilter.FilterChanged(Sender: TObject);\r\nbegin\r\n RecreateExprFilter;\r\nend;\r\n\r\nprocedure TJvDBFilter.SetOnFiltering(const Value: TFilterEvent);\r\nbegin\r\n if Assigned(FOnFiltering) <> Assigned(Value) then\r\n begin\r\n FOnFiltering := Value;\r\n RecreateFuncFilter;\r\n end\r\n else\r\n FOnFiltering := Value;\r\nend;\r\n\r\nprocedure TJvDBFilter.RecreateFuncFilter;\r\nvar\r\n Filter: hDBIFilter;\r\nbegin\r\n if FDataLink.Active and not (csReading in ComponentState) then\r\n begin\r\n if not FCaptured then\r\n FDataLink.DataSet.CheckBrowseMode;\r\n if Assigned(FOnFiltering) then\r\n Filter := CreateFuncFilter\r\n else\r\n Filter := nil;\r\n SetFilterHandle(FFuncHandle, Filter);\r\n end;\r\n if FDataLink.Active and Active and not FCaptured then\r\n FDataLink.DataSet.First;\r\nend;\r\n\r\nprocedure TJvDBFilter.RecreateExprFilter;\r\nvar\r\n Filter: hDBIFilter;\r\nbegin\r\n if FDataLink.Active and not (csReading in ComponentState) then\r\n begin\r\n if not FCaptured then\r\n FDataLink.DataSet.CheckBrowseMode;\r\n if FFilter.Count > 0 then\r\n try\r\n Filter := CreateExprFilter;\r\n except\r\n if Active or FActivating then\r\n raise\r\n else\r\n Filter := nil;\r\n end\r\n else\r\n Filter := nil;\r\n SetFilterHandle(FExprHandle, Filter);\r\n end;\r\n if FDataLink.Active and Active and not FCaptured then\r\n FDataLink.DataSet.First;\r\nend;\r\n\r\nfunction TJvDBFilter.GetFilter: TStrings;\r\nbegin\r\n Result := FFilter;\r\nend;\r\n\r\nprocedure TJvDBFilter.SetFilter(Value: TStrings);\r\nbegin\r\n FFilter.Assign(Value);\r\nend;\r\n\r\nprocedure TJvDBFilter.SetOptions(Value: TDBFilterOptions);\r\nbegin\r\n if Value <> FOptions then\r\n begin\r\n FOptions := Value;\r\n RecreateExprFilter;\r\n end;\r\nend;\r\n\r\nprocedure TJvDBFilter.SetLogicCond(Value: TFilterLogicCond);\r\nbegin\r\n FLogicCond := Value;\r\nend;\r\n\r\nprocedure TJvDBFilter.SetPriority(Value: Word);\r\nbegin\r\n if FPriority <> Value then\r\n begin\r\n FPriority := Value;\r\n Update;\r\n end;\r\nend;\r\n\r\nfunction TJvDBFilter.GetFilterText: string;\r\nvar\r\n BufLen: Word;\r\n I: Integer;\r\n StrEnd: PChar;\r\n StrBuf: array [0..255] of Char;\r\nbegin\r\n BufLen := 0;\r\n for I := 0 to FFilter.Count - 1 do\r\n if Filter.Strings[I] <> '' then\r\n Inc(BufLen, Length(Filter.Strings[I]) + 1);\r\n SetLength(Result, BufLen);\r\n if BufLen > 0 then\r\n begin\r\n StrEnd := @Result[1];\r\n for I := 0 to Filter.Count - 1 do\r\n if Filter.Strings[I] <> '' then\r\n begin\r\n StrPCopy(StrBuf, Filter.Strings[I]);\r\n StrEnd := StrECopy(StrEnd, StrBuf);\r\n StrEnd := StrECopy(StrEnd, ' ');\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvDBFilter.DestroyTree;\r\nbegin\r\n FreeAndNil(FParser);\r\nend;\r\n\r\nprocedure TJvDBFilter.BeforeDataPost(DataSet: TDataSet);\r\nbegin\r\n ReadCaptureControls;\r\n ReleaseCapture;\r\n Activate;\r\n SysUtils.Abort;\r\nend;\r\n\r\nprocedure TJvDBFilter.BeforeDataChange(DataSet: TDataSet);\r\nbegin\r\n raise EJVCLFilterError.CreateRes(@RsECaptureFilter);\r\nend;\r\n\r\nprocedure TJvDBFilter.BeforeDataCancel(DataSet: TDataSet);\r\nbegin\r\n ReleaseCapture;\r\nend;\r\n\r\nfunction TJvDBFilter.BuildTree: Boolean;\r\nvar\r\n Expr: string;\r\n I: Integer;\r\nbegin\r\n Result := True;\r\n if not FDataLink.Active then\r\n _DBError(SDataSetClosed);\r\n FFilter.OnChange := nil;\r\n try\r\n for I := FFilter.Count - 1 downto 0 do\r\n if FFilter[I] = '' then\r\n FFilter.Delete(I);\r\n finally\r\n FFilter.OnChange := FilterChanged;\r\n end;\r\n Expr := GetFilterText;\r\n if (FFilter.Count <> 0) and (Expr <> '') then\r\n FParser := TExprParser.Create(FDataLink.DataSet, Expr,\r\n TFilterOptions(FOptions), [], '', nil, FldTypeMap)\r\n else\r\n Result := False;\r\nend;\r\n\r\nprocedure TJvDBFilter.DoActivate;\r\nbegin\r\n if Assigned(FOnActivate) then\r\n FOnActivate(Self);\r\nend;\r\n\r\nprocedure TJvDBFilter.DoDeactivate;\r\nbegin\r\n if Assigned(FOnDeactivate) then\r\n FOnDeactivate(Self);\r\nend;\r\n\r\nprocedure TJvDBFilter.SetActive(Value: Boolean);\r\nvar\r\n Bookmark: TBookmark;\r\nbegin\r\n if csReading in ComponentState then\r\n FStreamedActive := Value\r\n else\r\n if FDataLink.Active then\r\n begin\r\n FDataLink.DataSet.CheckBrowseMode;\r\n if FActive <> Value then\r\n begin\r\n if Value then\r\n begin\r\n FActivating := True;\r\n try\r\n if FCaptured then\r\n raise EJVCLFilterError.CreateRes(@RsECaptureFilter);\r\n DbiSetToBegin((FDataLink.DataSet as TBDEDataSet).Handle);\r\n if FExprHandle = nil then\r\n RecreateExprFilter;\r\n if FFuncHandle = nil then\r\n RecreateFuncFilter;\r\n ActivateFilters;\r\n FDataLink.DataSet.First;\r\n FActive := Value;\r\n DoActivate;\r\n finally\r\n FActivating := False;\r\n end;\r\n end\r\n else\r\n begin\r\n if not IsDataSetEmpty(FDataLink.DataSet) then\r\n Bookmark := FDataLink.DataSet.GetBookmark\r\n else\r\n Bookmark := nil;\r\n try\r\n DbiSetToBegin((FDataLink.DataSet as TBDEDataSet).Handle);\r\n DeactivateFilters;\r\n if not SetToBookmark(FDataLink.DataSet, Bookmark) then\r\n FDataLink.DataSet.First;\r\n finally\r\n FDataLink.DataSet.FreeBookmark(Bookmark);\r\n end;\r\n FActive := Value;\r\n DoDeactivate;\r\n end;\r\n FActive := Value;\r\n end;\r\n end\r\n else\r\n FActive := Value;\r\nend;\r\n\r\nprocedure TJvDBFilter.Activate;\r\nbegin\r\n SetActive(True);\r\nend;\r\n\r\nprocedure TJvDBFilter.Deactivate;\r\nbegin\r\n SetActive(False);\r\nend;\r\n\r\nprocedure TJvDBFilter.SetCapture;\r\nbegin\r\n if not FCaptured and (FDataLink <> nil) then\r\n begin\r\n if not FDataLink.Active then\r\n _DBError(SDataSetClosed);\r\n DataSource.DataSet.CheckBrowseMode;\r\n Deactivate;\r\n FIgnoreDataEvents := True;\r\n { store private fields values }\r\n with FStorage do\r\n begin\r\n FBof := DataSource.DataSet.Bof;\r\n FEof := DataSource.DataSet.Eof;\r\n State := DataSource.DataSet.State;\r\n CanModify := DsGetCanModify(FDataLink.DataSet as TBDEDataSet);\r\n BeforePost := DataSource.DataSet.BeforePost;\r\n BeforeCancel := DataSource.DataSet.BeforeCancel;\r\n BeforeInsert := DataSource.DataSet.BeforeInsert;\r\n BeforeEdit := DataSource.DataSet.BeforeEdit;\r\n end;\r\n DbiInitRecord((DataSource.DataSet as TBDEDataSet).Handle,\r\n DataSource.DataSet.ActiveBuffer);\r\n DsSetBOF(DataSource.DataSet, True);\r\n DsSetEOF(DataSource.DataSet, True);\r\n DsSetState(DataSource.DataSet, dsEdit);\r\n DsSetCanModify(DataSource.DataSet as TBDEDataSet, True);\r\n DataSource.DataSet.BeforeCancel := BeforeDataCancel;\r\n DataSource.DataSet.BeforePost := BeforeDataPost;\r\n DataSource.DataSet.BeforeInsert := BeforeDataChange;\r\n DataSource.DataSet.BeforeEdit := BeforeDataChange;\r\n TDataSetAccessProtected(DataSource.DataSet).DataEvent(deUpdateState, 0);\r\n TDataSetAccessProtected(DataSource.DataSet).DataEvent(deDataSetChange, 0);\r\n {DataSource.DataSet := DataSource.DataSet;}\r\n FCaptured := True;\r\n if Assigned(FOnSetCapture) then\r\n FOnSetCapture(Self);\r\n end;\r\nend;\r\n\r\nprocedure TJvDBFilter.ReleaseCapture;\r\nbegin\r\n if (DataSource <> nil) and (DataSource.DataSet <> nil) and FCaptured then\r\n begin\r\n { restore private fields values stored in SetCapture }\r\n with FStorage do\r\n begin\r\n DsSetBOF(DataSource.DataSet, FBof);\r\n DsSetEOF(DataSource.DataSet, FEof);\r\n DsSetState(DataSource.DataSet, State);\r\n DsSetCanModify(DataSource.DataSet as TBDEDataSet, CanModify);\r\n DataSource.DataSet.BeforePost := BeforePost;\r\n DataSource.DataSet.BeforeCancel := BeforeCancel;\r\n DataSource.DataSet.BeforeInsert := BeforeInsert;\r\n DataSource.DataSet.BeforeEdit := BeforeEdit;\r\n end;\r\n FCaptured := False;\r\n FIgnoreDataEvents := False;\r\n DataSource.DataSet.Resync([]);\r\n TDataSetAccessProtected(DataSource.DataSet).DataEvent(deUpdateState, 0);\r\n TDataSetAccessProtected(DataSource.DataSet).DataEvent(deDataSetChange, 0);\r\n {DataSource.DataSet := DataSource.DataSet;}\r\n if Assigned(FOnReleaseCapture) then\r\n FOnReleaseCapture(Self);\r\n ActiveChanged;\r\n end;\r\nend;\r\n\r\nprocedure TJvDBFilter.ReadCaptureControls;\r\nconst\r\n LogicStr: array [TFilterLogicCond] of PChar = (' AND', ' OR');\r\nvar\r\n I: Integer;\r\n Field: TField;\r\n S: string;\r\nbegin\r\n if FCaptured then\r\n begin\r\n FFilter.BeginUpdate;\r\n try\r\n FFilter.Clear;\r\n with FDataLink.DataSet do\r\n begin\r\n UpdateRecord;\r\n for I := 0 to FieldCount - 1 do\r\n begin\r\n Field := Fields[I];\r\n if not (Field.IsNull or Field.Calculated or Field.Lookup) then\r\n begin\r\n S := '(' + cFldQuotaLeft + Field.FieldName + cFldQuotaRight +\r\n '=' + cQuota + Field.AsString + cQuota + ')';\r\n if FFilter.Count > 0 then\r\n S := S + LogicStr[FLogicCond];\r\n FFilter.Insert(0, S);\r\n end;\r\n end;\r\n end;\r\n finally\r\n FFilter.EndUpdate;\r\n end;\r\n end\r\n else\r\n raise EJVCLFilterError.CreateRes(@RsENotCaptureFilter);\r\nend;\r\n\r\nprocedure TJvDBFilter.UpdateFuncFilter;\r\nbegin\r\n if FDataLink.Active and Active and (FFuncHandle <> nil) then\r\n with FDataLink.DataSet as TBDEDataSet do\r\n begin\r\n DisableControls;\r\n try\r\n DbiDeactivateFilter(Handle, FFuncHandle);\r\n DbiActivateFilter(Handle, FFuncHandle);\r\n {CursorPosChanged; Resync([]);}\r\n First;\r\n finally\r\n EnableControls;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvDBFilter.Update;\r\nbegin\r\n if FDataLink.Active and Active then\r\n begin\r\n FDataLink.DataSet.DisableControls;\r\n try\r\n RecreateExprFilter;\r\n RecreateFuncFilter;\r\n {DeactivateFilters; ActivateFilters;}\r\n finally\r\n FDataLink.DataSet.EnableControls;\r\n end;\r\n end\r\n else\r\n DeactivateFilters;\r\nend;\r\n\r\nprocedure TJvDBFilter.ActiveChanged;\r\nvar\r\n WasActive: Boolean;\r\nbegin\r\n if not FIgnoreDataEvents then\r\n begin\r\n WasActive := Active;\r\n DropFilters;\r\n if not (csDestroying in ComponentState) then\r\n begin\r\n RecreateExprFilter;\r\n RecreateFuncFilter;\r\n if WasActive then\r\n Activate;\r\n end;\r\n end;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvBDEIndex.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvDBIndex.PAS, released on 2002-07-04.\r\n\r\nThe Initial Developers of the Original Code are: Fedor Koshevnikov, Igor Pavluk and Serge Korolev\r\nCopyright (c) 1997, 1998 Fedor Koshevnikov, Igor Pavluk and Serge Korolev\r\nCopyright (c) 2001,2002 SGB Software\r\nAll Rights Reserved.\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvBDEIndex.pas 12461 2009-08-14 17:21:33Z obones $\r\n\r\nunit JvBDEIndex;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Classes, DB,\r\n JvExStdCtrls;\r\n\r\ntype\r\n TJvIdxDisplayMode = (dmFieldLabels, dmFieldNames, dmIndexName);\r\n\r\n TJvDBIndexCombo = class(TJvExCustomComboBox)\r\n private\r\n FDataLink: TDataLink;\r\n FUpdate: Boolean;\r\n FNoIndexItemName: string;\r\n FEnableNoIndex: Boolean;\r\n FChanging: Boolean;\r\n FDisplayMode: TJvIdxDisplayMode;\r\n function GetDataSource: TDataSource;\r\n procedure SetDataSource(Value: TDataSource);\r\n function GetIndexFieldName(var AName: string): Boolean;\r\n procedure SetNoIndexItemName(const Value: string);\r\n function GetNoIndexItemName: string;\r\n procedure SetEnableNoIndex(Value: Boolean);\r\n procedure SetDisplayMode(Value: TJvIdxDisplayMode);\r\n procedure ActiveChanged;\r\n protected\r\n procedure EnabledChanged; override;\r\n procedure Loaded; override;\r\n procedure Notification(AComponent: TComponent; Operation: TOperation); override;\r\n procedure FillIndexList(List: TStrings);\r\n procedure Change; override;\r\n procedure UpdateList; virtual;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n published\r\n property DataSource: TDataSource read GetDataSource write SetDataSource;\r\n property NoIndexItemName: string read GetNoIndexItemName write SetNoIndexItemName;\r\n property EnableNoIndex: Boolean read FEnableNoIndex write SetEnableNoIndex default False;\r\n property DisplayMode: TJvIdxDisplayMode read FDisplayMode write SetDisplayMode default dmFieldLabels;\r\n property DragCursor;\r\n property DragMode;\r\n property Enabled;\r\n property Color;\r\n property DropDownCount;\r\n property Font;\r\n property Anchors;\r\n property BiDiMode;\r\n property Constraints;\r\n property DragKind;\r\n property ParentBiDiMode;\r\n property ImeMode;\r\n property ImeName;\r\n property ItemHeight;\r\n property ParentFont;\r\n property ParentShowHint;\r\n property PopupMenu;\r\n property ShowHint;\r\n property Sorted;\r\n property TabOrder;\r\n property TabStop;\r\n property Visible;\r\n property OnChange;\r\n property OnClick;\r\n property OnDblClick;\r\n property OnDragDrop;\r\n property OnDragOver;\r\n property OnEndDrag;\r\n property OnEnter;\r\n property OnExit;\r\n property OnKeyDown;\r\n property OnKeyPress;\r\n property OnKeyUp;\r\n property OnContextPopup;\r\n property OnStartDrag;\r\n property OnEndDock;\r\n property OnStartDock;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvBDEIndex.pas $';\r\n Revision: '$Revision: 12461 $';\r\n Date: '$Date: 2009-08-14 19:21:33 +0200 (ven. 14 août 2009) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n SysUtils, StdCtrls, DBTables,\r\n JvBdeUtils;\r\n\r\n//=== { TJvKeyDataLink } =====================================================\r\n\r\ntype\r\n TJvKeyDataLink = class(TDataLink)\r\n private\r\n FCombo: TJvDBIndexCombo;\r\n protected\r\n procedure ActiveChanged; override;\r\n procedure DataSetChanged; override;\r\n procedure DataSetScrolled(Distance: Integer); override;\r\n public\r\n constructor Create(ACombo: TJvDBIndexCombo);\r\n destructor Destroy; override;\r\n end;\r\n\r\nconstructor TJvKeyDataLink.Create(ACombo: TJvDBIndexCombo);\r\nbegin\r\n inherited Create;\r\n FCombo := ACombo;\r\nend;\r\n\r\ndestructor TJvKeyDataLink.Destroy;\r\nbegin\r\n FCombo := nil;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvKeyDataLink.ActiveChanged;\r\nbegin\r\n if FCombo <> nil then\r\n FCombo.ActiveChanged;\r\nend;\r\n\r\nprocedure TJvKeyDataLink.DataSetChanged;\r\nbegin\r\n if FCombo <> nil then\r\n FCombo.ActiveChanged;\r\nend;\r\n\r\nprocedure TJvKeyDataLink.DataSetScrolled(Distance: Integer);\r\nbegin\r\n { ignore this data event }\r\nend;\r\n\r\n//=== { TJvDBIndexCombo } ====================================================\r\n\r\nconstructor TJvDBIndexCombo.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FDataLink := TJvKeyDataLink.Create(Self);\r\n Style := csDropDownList;\r\n FUpdate := False;\r\n FNoIndexItemName := '';\r\n FEnableNoIndex := False;\r\n FDisplayMode := dmFieldLabels;\r\nend;\r\n\r\ndestructor TJvDBIndexCombo.Destroy;\r\nbegin\r\n FreeAndNil(FDataLink);\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvDBIndexCombo.SetNoIndexItemName(const Value: string);\r\nbegin\r\n if Value <> FNoIndexItemName then\r\n begin\r\n FNoIndexItemName := Value;\r\n if not (csLoading in ComponentState) then\r\n ActiveChanged;\r\n end;\r\nend;\r\n\r\nprocedure TJvDBIndexCombo.SetEnableNoIndex(Value: Boolean);\r\nbegin\r\n if FEnableNoIndex <> Value then\r\n begin\r\n FEnableNoIndex := Value;\r\n if not (csLoading in ComponentState) then\r\n ActiveChanged;\r\n end;\r\nend;\r\n\r\nprocedure TJvDBIndexCombo.SetDisplayMode(Value: TJvIdxDisplayMode);\r\nbegin\r\n if Value <> FDisplayMode then\r\n begin\r\n FDisplayMode := Value;\r\n if not (csLoading in ComponentState) then\r\n UpdateList;\r\n end;\r\nend;\r\n\r\nfunction TJvDBIndexCombo.GetNoIndexItemName: string;\r\nbegin\r\n Result := FNoIndexItemName;\r\nend;\r\n\r\nfunction TJvDBIndexCombo.GetDataSource: TDataSource;\r\nbegin\r\n if FDataLink <> nil then\r\n Result := FDataLink.DataSource\r\n else\r\n Result := nil;\r\nend;\r\n\r\nprocedure TJvDBIndexCombo.SetDataSource(Value: TDataSource);\r\nbegin\r\n if FDataLink.DataSource <> nil then\r\n FDataLink.DataSource.RemoveFreeNotification(Self);\r\n\r\n FDataLink.DataSource := Value;\r\n if Value <> nil then\r\n Value.FreeNotification(Self);\r\n if not (csLoading in ComponentState) then\r\n ActiveChanged;\r\nend;\r\n\r\nprocedure TJvDBIndexCombo.ActiveChanged;\r\nbegin\r\n if not (Enabled and FDataLink.Active and\r\n FDataLink.DataSet.InheritsFrom(TTable)) then\r\n begin\r\n Clear;\r\n ItemIndex := -1;\r\n end\r\n else\r\n UpdateList;\r\nend;\r\n\r\nprocedure TJvDBIndexCombo.Loaded;\r\nbegin\r\n inherited Loaded;\r\n ActiveChanged;\r\nend;\r\n\r\nprocedure TJvDBIndexCombo.Notification(AComponent: TComponent;\r\n Operation: TOperation);\r\nbegin\r\n inherited Notification(AComponent, Operation);\r\n if (Operation = opRemove) and (FDataLink <> nil) and\r\n (AComponent = DataSource) then\r\n DataSource := nil;\r\nend;\r\n\r\nprocedure TJvDBIndexCombo.EnabledChanged;\r\nbegin\r\n inherited EnabledChanged;\r\n if not (csLoading in ComponentState) then\r\n ActiveChanged;\r\nend;\r\n\r\nfunction TJvDBIndexCombo.GetIndexFieldName(var AName: string): Boolean;\r\nbegin\r\n Result := True;\r\n if ItemIndex >= 0 then\r\n begin\r\n if EnableNoIndex and (Items[ItemIndex] = NoIndexItemName) then\r\n AName := ''\r\n else\r\n begin\r\n AName := TIndexDef(Items.Objects[ItemIndex]).Fields;\r\n if (AName = '') or\r\n (ixDescending in TIndexDef(Items.Objects[ItemIndex]).Options) then\r\n begin\r\n AName := TIndexDef(Items.Objects[ItemIndex]).Name;\r\n Result := False;\r\n end;\r\n end;\r\n end\r\n else\r\n AName := '';\r\nend;\r\n\r\nprocedure TJvDBIndexCombo.FillIndexList(List: TStrings);\r\nvar\r\n AFld: string;\r\n Pos: Integer;\r\n I: Integer;\r\nbegin\r\n List.BeginUpdate;\r\n try\r\n List.Clear;\r\n if not FDataLink.Active then\r\n Exit;\r\n with FDataLink.DataSet as TTable do\r\n begin\r\n for I := 0 to IndexDefs.Count - 1 do\r\n with IndexDefs[I] do\r\n if not (ixExpression in Options) then\r\n begin\r\n if FDisplayMode = dmIndexName then\r\n begin\r\n if (Name = '') and (EnableNoIndex) and\r\n (TableType = ttparadox) and (ixprimary in Options) then\r\n AFLd := NoIndexItemName\r\n else\r\n AFld := Name\r\n end\r\n else\r\n begin\r\n AFld := '';\r\n Pos := 1;\r\n while Pos <= Length(Fields) do\r\n begin\r\n if AFld <> '' then\r\n AFld := AFld + '; ';\r\n case FDisplayMode of\r\n dmFieldLabels:\r\n AFld := AFld + FieldByName(ExtractFieldName(Fields, Pos)).DisplayLabel;\r\n dmFieldNames:\r\n AFld := AFld + FieldByName(ExtractFieldName(Fields, Pos)).FieldName;\r\n end;\r\n end;\r\n end;\r\n if List.IndexOf(AFld) < 0 then\r\n List.AddObject(AFld, IndexDefs[I]);\r\n end;\r\n end;\r\n if EnableNoIndex then\r\n if List.IndexOf(NoIndexItemName) < 0 then\r\n List.AddObject(NoIndexItemName, nil);\r\n finally\r\n List.EndUpdate;\r\n end;\r\nend;\r\n\r\nprocedure TJvDBIndexCombo.Change;\r\nvar\r\n ABookmark: TBookmark;\r\n AName: string;\r\nbegin\r\n if Enabled and FDataLink.Active and not FChanging and\r\n FDataLink.DataSet.InheritsFrom(TTable) and\r\n not (csLoading in ComponentState) then\r\n begin\r\n ABookmark := nil;\r\n with FDataLink.DataSet as TTable do\r\n begin\r\n if Database.IsSQLBased then\r\n ABookmark := GetBookmark;\r\n try\r\n if GetIndexFieldName(AName) then\r\n begin\r\n IndexFieldNames := AName;\r\n if (AName = '') and (IndexDefs.Count > 0) then\r\n IndexName := '';\r\n end\r\n else\r\n begin\r\n if AName = '' then\r\n IndexFieldNames := '';\r\n IndexName := AName;\r\n end;\r\n if (ABookmark <> nil) then\r\n SetToBookmark(TTable(Self.FDataLink.DataSet), ABookmark);\r\n finally\r\n if ABookmark <> nil then\r\n FreeBookmark(ABookmark);\r\n end;\r\n end;\r\n end;\r\n inherited Change;\r\nend;\r\n\r\nprocedure TJvDBIndexCombo.UpdateList;\r\n\r\n function FindIndex(Table: TTable): Integer;\r\n var\r\n I: Integer;\r\n IdxFields: string;\r\n begin\r\n Result := -1;\r\n IdxFields := '';\r\n if Table.IndexFieldNames <> '' then\r\n for I := 0 to Table.IndexFieldCount - 1 do\r\n begin\r\n if IdxFields <> '' then\r\n IdxFields := IdxFields + ';';\r\n IdxFields := IdxFields + Table.IndexFields[I].FieldName;\r\n end;\r\n for I := 0 to Items.Count - 1 do\r\n begin\r\n if (Items.Objects[I] <> nil) and\r\n (((IdxFields <> '') and\r\n (CompareText(TIndexDef(Items.Objects[I]).Fields, IdxFields) = 0)) or\r\n ((Table.IndexName <> '') and\r\n (CompareText(TIndexDef(Items.Objects[I]).Name, Table.IndexName) = 0))) then\r\n begin\r\n Result := I;\r\n Exit;\r\n end;\r\n end;\r\n if EnableNoIndex and FDataLink.Active then\r\n if (Table.IndexFieldNames = '') and (Table.IndexName = '') then\r\n Result := Items.IndexOf(NoIndexItemName);\r\n end;\r\n\r\nbegin\r\n if Enabled and FDataLink.Active then\r\n try\r\n Items.BeginUpdate;\r\n try\r\n if FDataLink.DataSet.InheritsFrom(TTable) then\r\n begin\r\n TTable(FDataLink.DataSet).IndexDefs.Update;\r\n FillIndexList(Items);\r\n ItemIndex := FindIndex(TTable(FDataLink.DataSet));\r\n FChanging := True;\r\n end\r\n else\r\n Items.Clear;\r\n finally\r\n Items.EndUpdate;\r\n end;\r\n finally\r\n FChanging := False;\r\n end;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvBDELists.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvDBLists.PAS, released on 2002-07-04.\r\n\r\nThe Initial Developers of the Original Code are: Fedor Koshevnikov, Igor Pavluk and Serge Korolev\r\nCopyright (c) 1997, 1998 Fedor Koshevnikov, Igor Pavluk and Serge Korolev\r\nCopyright (c) 2001,2002 SGB Software\r\nAll Rights Reserved.\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvBDELists.pas 13075 2011-06-27 22:56:21Z jfudickar $\r\n\r\nunit JvBDELists;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n SysUtils, Classes,\r\n BDE, DB, DBTables;\r\n\r\ntype\r\n TJvBDEItemType = (bdDatabases, bdDrivers, bdLangDrivers, bdUsers, bdRepositories);\r\n\r\n TJvCustomBDEItems = class(TBDEDataSet)\r\n private\r\n FItemType: TJvBDEItemType;\r\n FSessionName: string;\r\n FSessionLink: TDatabase;\r\n function GetDBSession: TSession;\r\n procedure SetSessionName(const Value: string);\r\n procedure SetItemType(Value: TJvBDEItemType);\r\n protected\r\n function GetRecordCount: Integer; override;\r\n procedure OpenCursor (InfoQuery: Boolean); override;\r\n procedure CloseCursor; override;\r\n function CreateHandle: HDBICur; override;\r\n property ItemType: TJvBDEItemType read FItemType write SetItemType\r\n default bdDatabases;\r\n property SessionName: string read FSessionName write SetSessionName;\r\n public\r\n function Locate(const KeyFields: string; const KeyValues: Variant;\r\n Options: TLocateOptions): Boolean; override;\r\n property DBSession: TSession read GetDBSession;\r\n end;\r\n\r\n TJvBDEItems = class(TJvCustomBDEItems)\r\n published\r\n property ItemType;\r\n property SessionName;\r\n end;\r\n\r\n TJvDBListDataSet = class(TDBDataSet)\r\n protected\r\n function GetRecordCount: Integer; override;\r\n public\r\n function Locate(const KeyFields: string; const KeyValues: Variant;\r\n Options: TLocateOptions): Boolean; override;\r\n end;\r\n\r\n TDBItemType = (dtTables, dtStoredProcs, dtFiles, dtFunctions);\r\n\r\n TJvCustomDatabaseItems = class(TJvDBListDataSet)\r\n private\r\n FExtended: Boolean;\r\n FSystemItems: Boolean;\r\n FFileMask: string;\r\n FItemType: TDBItemType;\r\n procedure SetFileMask(const Value: string);\r\n procedure SetExtendedInfo(Value: Boolean);\r\n procedure SetSystemItems(Value: Boolean);\r\n procedure SetItemType(Value: TDBItemType);\r\n protected\r\n function CreateHandle: HDBICur; override;\r\n function GetItemName: string;\r\n property ItemType: TDBItemType read FItemType write SetItemType\r\n default dtTables;\r\n property ExtendedInfo: Boolean read FExtended write SetExtendedInfo\r\n default False;\r\n property FileMask: string read FFileMask write SetFileMask;\r\n property SystemItems: Boolean read FSystemItems write SetSystemItems\r\n default False;\r\n public\r\n property ItemName: string read GetItemName;\r\n end;\r\n\r\n TJvDatabaseItems = class(TJvCustomDatabaseItems)\r\n published\r\n property ItemType;\r\n property ExtendedInfo;\r\n property FileMask;\r\n property SystemItems;\r\n end;\r\n\r\n TTabItemType = (dtFields, dtIndices, dtValChecks, dtRefInt,\r\n dtSecurity, dtFamily);\r\n\r\n TJvCustomTableItems = class(TJvDBListDataSet)\r\n private\r\n FTableName: TFileName;\r\n FItemType: TTabItemType;\r\n FPhysTypes: Boolean;\r\n procedure SetTableName(const Value: TFileName);\r\n procedure SetItemType(Value: TTabItemType);\r\n procedure SetPhysTypes(Value: Boolean);\r\n protected\r\n function CreateHandle: HDBICur; override;\r\n property ItemType: TTabItemType read FItemType write SetItemType default dtFields;\r\n property PhysTypes: Boolean read FPhysTypes write SetPhysTypes default False; { for dtFields only }\r\n property TableName: TFileName read FTableName write SetTableName;\r\n end;\r\n\r\n TJvTableItems = class(TJvCustomTableItems)\r\n published\r\n property ItemType;\r\n property PhysTypes;\r\n property TableName;\r\n end;\r\n\r\n TJvDatabaseDesc = class(TObject)\r\n private\r\n FDescription: DBDesc;\r\n public\r\n constructor Create(const DatabaseName: string);\r\n property Description: DBDesc read FDescription;\r\n end;\r\n\r\n TJvDriverDesc = class(TObject)\r\n private\r\n FDescription: DRVType;\r\n public\r\n constructor Create(const DriverType: string);\r\n property Description: DRVType read FDescription;\r\n end;\r\n\r\n{$IFNDEF BCB}\r\n{ Obsolete classes, for backward compatibility only }\r\n\r\ntype\r\n TJvDatabaseList = class(TJvCustomBDEItems)\r\n published\r\n property SessionName;\r\n end;\r\n\r\n TJvLangDrivList = class(TJvCustomBDEItems)\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n published\r\n property SessionName;\r\n end;\r\n\r\n TJvTableList = class(TJvCustomDatabaseItems)\r\n public\r\n function GetTableName: string;\r\n published\r\n property ExtendedInfo;\r\n property FileMask;\r\n property SystemItems;\r\n end;\r\n\r\n TJvStoredProcList = class(TJvCustomDatabaseItems)\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n published\r\n property ExtendedInfo;\r\n property SystemItems;\r\n end;\r\n\r\n TJvFieldList = class(TJvCustomTableItems)\r\n published\r\n property TableName;\r\n end;\r\n\r\n\r\n TJvIndexList = class(TJvCustomTableItems)\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n published\r\n property TableName;\r\n end;\r\n\r\n{$ENDIF !BCB}\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvBDELists.pas $';\r\n Revision: '$Revision: 13075 $';\r\n Date: '$Date: 2011-06-28 00:56:21 +0200 (mar. 28 juin 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n bdeconst, DBConsts,\r\n JvDBUtils, JvResources;\r\n\r\n//=== Utility routines =======================================================\r\n\r\nfunction dsGetRecordCount(DataSet: TBDEDataSet): Longint;\r\nbegin\r\n if DataSet.State = dsInactive then\r\n _DBError(SDataSetClosed);\r\n Check(DbiGetRecordCount(DataSet.Handle, Result));\r\nend;\r\n\r\n//=== { TJvSessionLink } =====================================================\r\n\r\ntype\r\n TJvSessionLink = class(TDatabase)\r\n private\r\n FList: TJvCustomBDEItems;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n end;\r\n\r\nconstructor TJvSessionLink.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n if (AOwner <> nil) and (AOwner is TSession) then\r\n SessionName := TSession(AOwner).SessionName;\r\n Temporary := True;\r\n KeepConnection := False;\r\nend;\r\n\r\ndestructor TJvSessionLink.Destroy;\r\nbegin\r\n if FList <> nil then\r\n begin\r\n FList.FSessionLink := nil;\r\n FList.Close;\r\n end;\r\n inherited Destroy;\r\nend;\r\n\r\n\r\n//=== { TJvCustomBDEItems } ==================================================\r\n\r\nprocedure TJvCustomBDEItems.SetItemType(Value: TJvBDEItemType);\r\nbegin\r\n if ItemType <> Value then\r\n begin\r\n CheckInactive;\r\n FItemType := Value;\r\n end;\r\nend;\r\n\r\nfunction TJvCustomBDEItems.CreateHandle: HDBICur;\r\nbegin\r\n case FItemType of\r\n bdDatabases:\r\n Check(DbiOpenDatabaseList(Result));\r\n bdDrivers:\r\n Check(DbiOpenDriverList(Result));\r\n bdLangDrivers:\r\n Check(DbiOpenLdList(Result));\r\n bdUsers:\r\n Check(DbiOpenUserList(Result));\r\n bdRepositories:\r\n Check(DbiOpenRepositoryList(Result));\r\n end;\r\nend;\r\n\r\n\r\nfunction TJvCustomBDEItems.GetDBSession: TSession;\r\nbegin\r\n Result := Sessions.FindSession(SessionName);\r\n if Result = nil then\r\n Result := DBTables.Session;\r\nend;\r\n\r\nprocedure TJvCustomBDEItems.SetSessionName(const Value: string);\r\nbegin\r\n CheckInactive;\r\n FSessionName := Value;\r\n DataEvent(dePropertyChange, 0);\r\nend;\r\n\r\nprocedure TJvCustomBDEItems.OpenCursor;\r\nvar\r\n S: TSession;\r\nbegin\r\n S := Sessions.List[SessionName];\r\n S.Open;\r\n Sessions.CurrentSession := S;\r\n FSessionLink := TJvSessionLink.Create(S);\r\n try\r\n TJvSessionLink(FSessionLink).FList := Self;\r\n inherited OpenCursor(InfoQuery);\r\n except\r\n FreeAndNil(FSessionLink);\r\n raise;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomBDEItems.CloseCursor;\r\nbegin\r\n inherited CloseCursor;\r\n if FSessionLink <> nil then\r\n begin\r\n TJvSessionLink(FSessionLink).FList := nil;\r\n FreeAndNil(FSessionLink);\r\n end;\r\nend;\r\n\r\nfunction TJvCustomBDEItems.GetRecordCount: Integer;\r\nbegin\r\n Result := dsGetRecordCount(Self);\r\nend;\r\n\r\nfunction TJvCustomBDEItems.Locate(const KeyFields: string;\r\n const KeyValues: Variant; Options: TLocateOptions): Boolean;\r\nbegin\r\n DoBeforeScroll;\r\n Result := DataSetLocateThrough(Self, KeyFields, KeyValues, Options);\r\n if Result then\r\n begin\r\n DataEvent(deDataSetChange, 0);\r\n DoAfterScroll;\r\n end;\r\nend;\r\n\r\n//=== { TJvDBListDataSet } ===================================================\r\n\r\nfunction TJvDBListDataSet.Locate(const KeyFields: string;\r\n const KeyValues: Variant; Options: TLocateOptions): Boolean;\r\nbegin\r\n DoBeforeScroll;\r\n Result := DataSetLocateThrough(Self, KeyFields, KeyValues, Options);\r\n if Result then\r\n begin\r\n DataEvent(deDataSetChange, 0);\r\n DoAfterScroll;\r\n end;\r\nend;\r\n\r\nfunction TJvDBListDataSet.GetRecordCount: Integer;\r\nbegin\r\n Result := dsGetRecordCount(Self);\r\nend;\r\n\r\n//=== { TJvCustomDatabaseItems } =============================================\r\n\r\nprocedure TJvCustomDatabaseItems.SetItemType(Value: TDBItemType);\r\nbegin\r\n if ItemType <> Value then\r\n begin\r\n CheckInactive;\r\n FItemType := Value;\r\n DataEvent(dePropertyChange, 0);\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomDatabaseItems.SetFileMask(const Value: string);\r\nbegin\r\n if FileMask <> Value then\r\n begin\r\n if Active and (FItemType in [dtTables, dtFiles]) then\r\n begin\r\n DisableControls;\r\n try\r\n Close;\r\n FFileMask := Value;\r\n Open;\r\n finally\r\n EnableControls;\r\n end;\r\n end\r\n else\r\n FFileMask := Value;\r\n DataEvent(dePropertyChange, 0);\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomDatabaseItems.SetExtendedInfo(Value: Boolean);\r\nbegin\r\n if FExtended <> Value then\r\n begin\r\n CheckInactive;\r\n FExtended := Value;\r\n DataEvent(dePropertyChange, 0);\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomDatabaseItems.SetSystemItems(Value: Boolean);\r\nbegin\r\n if FSystemItems <> Value then\r\n begin\r\n if Active and (FItemType in [dtTables, dtStoredProcs]) then\r\n begin\r\n DisableControls;\r\n try\r\n Close;\r\n FSystemItems := Value;\r\n Open;\r\n finally\r\n EnableControls;\r\n end;\r\n end\r\n else\r\n FSystemItems := Value;\r\n DataEvent(dePropertyChange, 0);\r\n end;\r\nend;\r\n\r\nfunction TJvCustomDatabaseItems.CreateHandle: HDBICur;\r\nvar\r\n WildCard: PAnsiChar;\r\n Pattern: array [0..DBIMAXTBLNAMELEN] of AnsiChar;\r\nbegin\r\n WildCard := nil;\r\n if FileMask <> '' then\r\n WildCard := AnsiToNative(DBLocale, AnsiString(FileMask), Pattern, SizeOf(Pattern) - 1); // cast to AnsiString might lead to loss in D2009\r\n case FItemType of\r\n dtTables:\r\n Check(DbiOpenTableList(DBHandle, FExtended, FSystemItems, WildCard, Result));\r\n dtStoredProcs:\r\n if DataBase.IsSQLBased then\r\n Check(DbiOpenSPList(DBHandle, FExtended, FSystemItems, nil, Result))\r\n else\r\n DatabaseError(RsELocalDatabase);\r\n dtFiles:\r\n Check(DbiOpenFileList(DBHandle, WildCard, Result));\r\n dtFunctions:\r\n if DataBase.IsSQLBased then\r\n Check(DbiOpenFunctionList(DBHandle, DBIFUNCOpts(FExtended), @Result))\r\n else\r\n DatabaseError(RsELocalDatabase);\r\n end;\r\nend;\r\n\r\nfunction TJvCustomDatabaseItems.GetItemName: string;\r\nconst\r\n cObjListNameField = 'NAME';\r\n cFileNameField = 'FILENAME';\r\n cTabListExtField = 'EXTENSION';\r\nvar\r\n Temp: string;\r\n Field: TField;\r\nbegin\r\n Result := '';\r\n if not Active then\r\n Exit;\r\n if FItemType = dtFiles then\r\n Field := FindField(cFileNameField)\r\n else\r\n Field := FindField(cObjListNameField);\r\n if Field = nil then\r\n Exit;\r\n Result := Field.AsString;\r\n if FItemType in [dtTables, dtFiles] then\r\n begin\r\n Field := FindField(cTabListExtField);\r\n if Field = nil then\r\n Exit;\r\n Temp := Field.AsString;\r\n if Temp <> '' then\r\n begin\r\n if Temp[1] <> '.' then\r\n Temp := '.' + Temp;\r\n Result := Result + Temp;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomTableItems.SetItemType(Value: TTabItemType);\r\nbegin\r\n if ItemType <> Value then\r\n begin\r\n CheckInactive;\r\n FItemType := Value;\r\n DataEvent(dePropertyChange, 0);\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomTableItems.SetPhysTypes(Value: Boolean);\r\nbegin\r\n if Value <> PhysTypes then\r\n begin\r\n if Active and (ItemType = dtFields) then\r\n begin\r\n DisableControls;\r\n try\r\n Close;\r\n FPhysTypes := Value;\r\n Open;\r\n finally\r\n EnableControls;\r\n end;\r\n end\r\n else\r\n FPhysTypes := Value;\r\n DataEvent(dePropertyChange, 0);\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomTableItems.SetTableName(const Value: TFileName);\r\nbegin\r\n if Value <> FTableName then\r\n begin\r\n if Active then\r\n begin\r\n DisableControls;\r\n try\r\n Close;\r\n FTableName := Value;\r\n if FTableName <> '' then\r\n Open;\r\n finally\r\n EnableControls;\r\n end;\r\n end\r\n else\r\n FTableName := Value;\r\n DataEvent(dePropertyChange, 0);\r\n end;\r\nend;\r\n\r\nfunction TJvCustomTableItems.CreateHandle: HDBICur;\r\nvar\r\n STableName: PAnsiChar;\r\nbegin\r\n if FTableName = '' then\r\n _DBError(SNoTableName);\r\n STableName := {$IFDEF SUPPORTS_UNICODE}AnsiStrAlloc{$ELSE}StrAlloc{$ENDIF SUPPORTS_UNICODE}(Length(FTableName) + 1);\r\n try\r\n AnsiToNative(DBLocale, AnsiString(FTableName), STableName, Length(FTableName)); // Cast to AnsiString may lead to data loss in D2009\r\n case FItemType of\r\n dtFields:\r\n while not CheckOpen(DbiOpenFieldList(DBHandle, STableName, nil,\r\n FPhysTypes, Result)) do {Retry}\r\n ;\r\n dtIndices:\r\n while not CheckOpen(DbiOpenIndexList(DBHandle, STableName, nil,\r\n Result)) do {Retry}\r\n ;\r\n dtValChecks:\r\n while not CheckOpen(DbiOpenVchkList(DBHandle, STableName, nil,\r\n Result)) do {Retry}\r\n ;\r\n dtRefInt:\r\n while not CheckOpen(DbiOpenRintList(DBHandle, STableName, nil,\r\n Result)) do {Retry}\r\n ;\r\n dtSecurity:\r\n while not CheckOpen(DbiOpenSecurityList(DBHandle, STableName, nil,\r\n Result)) do {Retry}\r\n ;\r\n dtFamily:\r\n while not CheckOpen(DbiOpenFamilyList(DBHandle, STableName, nil,\r\n Result)) do {Retry}\r\n ;\r\n end;\r\n finally\r\n StrDispose(STableName);\r\n end;\r\nend;\r\n\r\n//=== { TJvDatabaseDesc } ====================================================\r\n\r\nconstructor TJvDatabaseDesc.Create(const DatabaseName: string);\r\nvar\r\n Buffer: PAnsiChar;\r\nbegin\r\n inherited Create;\r\n Buffer := StrPCopy({$IFDEF SUPPORTS_UNICODE}AnsiStrAlloc{$ELSE}StrAlloc{$ENDIF SUPPORTS_UNICODE}(Length(DatabaseName) + 1), AnsiString(DatabaseName));\r\n try\r\n Check(DbiGetDatabaseDesc(Buffer, @FDescription));\r\n finally\r\n StrDispose(Buffer);\r\n end;\r\nend;\r\n\r\nconstructor TJvDriverDesc.Create(const DriverType: string);\r\nvar\r\n Buffer: PAnsiChar;\r\nbegin\r\n inherited Create;\r\n Buffer := StrPCopy({$IFDEF SUPPORTS_UNICODE}AnsiStrAlloc{$ELSE}StrAlloc{$ENDIF SUPPORTS_UNICODE}(Length(DriverType) + 1), AnsiString(DriverType));\r\n try\r\n Check(DbiGetDriverDesc(Buffer, FDescription));\r\n finally\r\n StrDispose(Buffer);\r\n end;\r\nend;\r\n\r\n{$IFNDEF BCB}\r\n\r\n//=== { TJvLangDrivList } ====================================================\r\n\r\nconstructor TJvLangDrivList.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FItemType := bdLangDrivers;\r\nend;\r\n\r\n//=== { TJvTableList } =======================================================\r\n\r\nfunction TJvTableList.GetTableName: string;\r\nbegin\r\n Result := ItemName;\r\nend;\r\n\r\nconstructor TJvStoredProcList.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FItemType := dtStoredProcs;\r\nend;\r\n\r\n//=== { TJvIndexList } =======================================================\r\n\r\nconstructor TJvIndexList.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FItemType := dtIndices;\r\nend;\r\n\r\n{$ENDIF !BCB}\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvBDELoginDialog.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvxLoginDlg.PAS, released on 2002-07-04.\r\n\r\nThe Initial Developers of the Original Code are: Fedor Koshevnikov, Igor Pavluk and Serge Korolev\r\nCopyright (c) 1997, 1998 Fedor Koshevnikov, Igor Pavluk and Serge Korolev\r\nCopyright (c) 2001,2002 SGB Software\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\n Polaris Software\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvBDELoginDialog.pas 12461 2009-08-14 17:21:33Z obones $\r\n\r\nunit JvBDELoginDialog;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, Classes, DBTables,\r\n JvLoginForm, JvAppStorage;\r\n\r\ntype\r\n TCheckUserNameEvent = function(UsersTable: TTable;\r\n const UserName, Password: string): Boolean of object;\r\n\r\n TDialogMode = (dmAppLogin, dmDBLogin, dmUnlock);\r\n\r\n TJvDBLoginEvent = procedure(Sender: TObject; const UserName, Password: string) of object;\r\n\r\n {$M+}\r\n TJvDBLoginDialog = class(TObject)\r\n private\r\n FDialog: TJvLoginForm;\r\n FMode: TDialogMode;\r\n FSelectDatabase: Boolean;\r\n FIniAliasName: string;\r\n FCheckUserEvent: TCheckUserNameEvent;\r\n FCheckUnlock: TCheckUnlockEvent;\r\n FIconDblClick: TNotifyEvent;\r\n FDatabase: TDatabase;\r\n FAttemptNumber: Integer;\r\n FShowDBName: Boolean;\r\n FUsersTableName: string;\r\n FUserNameField: string;\r\n FMaxPwdLen: Integer;\r\n FLoginName: string;\r\n FAppStorage: TJvCustomAppStorage;\r\n FAppStoragePath: string;\r\n FOnLoginFailure: TJvDBLoginEvent;\r\n FOnGetPassword: TJvOnGetPassword;\r\n procedure Login(Database: TDatabase; LoginParams: TStrings);\r\n function GetUserInfo: Boolean;\r\n function CheckUser(Table: TTable): Boolean;\r\n function CheckUnlock: Boolean;\r\n procedure OkBtnClick(Sender: TObject);\r\n procedure FormShow(Sender: TObject);\r\n function ExecuteAppLogin: Boolean;\r\n function ExecuteDbLogin(LoginParams: TStrings): Boolean;\r\n function ExecuteUnlock: Boolean;\r\n public\r\n constructor Create(DialogMode: TDialogMode; DatabaseSelect: Boolean);\r\n destructor Destroy; override;\r\n function Execute(LoginParams: TStrings): Boolean;\r\n function GetUserName: string;\r\n function GetPassword: string;\r\n function CheckDatabaseChange: Boolean;\r\n procedure FillParams(LoginParams: TStrings);\r\n property Mode: TDialogMode read FMode;\r\n property SelectDatabase: Boolean read FSelectDatabase;\r\n property OnCheckUnlock: TCheckUnlockEvent read FCheckUnlock write FCheckUnlock;\r\n property OnCheckUserEvent: TCheckUserNameEvent read FCheckUserEvent write FCheckUserEvent;\r\n property OnIconDblClick: TNotifyEvent read FIconDblClick write FIconDblClick;\r\n property AppStorage: TJvCustomAppStorage read FAppStorage write FAppStorage;\r\n property AppStoragePath: string read FAppStoragePath write FAppStoragePath;\r\n property Database: TDatabase read FDatabase write FDatabase;\r\n property AttemptNumber: Integer read FAttemptNumber write FAttemptNumber;\r\n property ShowDBName: Boolean read FShowDBName write FShowDBName;\r\n property UsersTableName: string read FUsersTableName write FUsersTableName;\r\n property UserNameField: string read FUserNameField write FUserNameField;\r\n property MaxPwdLen: Integer read FMaxPwdLen write FMaxPwdLen;\r\n property LoginName: string read FLoginName write FLoginName;\r\n published\r\n property OnLoginFailure: TJvDBLoginEvent read FOnLoginFailure write FOnLoginFailure;\r\n property OnGetPassword: TJvOnGetPassword read FOnGetPassword write FOnGetPassword;\r\n end;\r\n {$M-}\r\n\r\nprocedure OnLoginDialog(Database: TDatabase; LoginParams: TStrings;\r\n AttemptNumber: Integer; ShowDBName: Boolean);\r\n\r\nfunction LoginDialog(Database: TDatabase; AttemptNumber: Integer;\r\n const UsersTableName, UserNameField: string; MaxPwdLen: Integer;\r\n CheckUserEvent: TCheckUserNameEvent; IconDblClick: TNotifyEvent;\r\n var LoginName: string; AppStorage: TJvCustomAppStorage;\r\n AppStoragePath: string; SelectDatabase: Boolean;\r\n LoginFailure: TJvDBLoginEvent; OnGetPassword: TJvOnGetPassword): Boolean;\r\n\r\nfunction UnlockDialog(const UserName: string; OnUnlock: TCheckUnlockEvent;\r\n IconDblClick: TNotifyEvent): Boolean;\r\nfunction UnlockDialogEx(const UserName: string; OnUnlock: TCheckUnlockEvent;\r\n IconDblClick: TNotifyEvent; MaxPwdLen, AttemptNumber: Integer): Boolean;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvBDELoginDialog.pas $';\r\n Revision: '$Revision: 12461 $';\r\n Date: '$Date: 2009-08-14 19:21:33 +0200 (ven. 14 août 2009) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n SysUtils, Graphics, Controls, Forms, DB, BDE,\r\n JvBDELists,\r\n JvConsts, JvResources;\r\n\r\nconstructor TJvDBLoginDialog.Create(DialogMode: TDialogMode; DatabaseSelect: Boolean);\r\nbegin\r\n inherited Create;\r\n FMode := DialogMode;\r\n FSelectDatabase := DatabaseSelect;\r\n FDialog := CreateLoginDialog((FMode = dmUnlock), FSelectDatabase,\r\n FormShow, OkBtnClick);\r\n AttemptNumber := 3;\r\n ShowDBName := True;\r\nend;\r\n\r\ndestructor TJvDBLoginDialog.Destroy;\r\nbegin\r\n FDialog.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvDBLoginDialog.OkBtnClick(Sender: TObject);\r\nvar\r\n Ok: Boolean;\r\n SaveLogin: TDatabaseLoginEvent;\r\n SetCursor: Boolean;\r\nbegin\r\n if FMode = dmUnlock then\r\n begin\r\n Ok := False;\r\n try\r\n Ok := CheckUnlock;\r\n except\r\n Application.HandleException(Self);\r\n end;\r\n if Ok then\r\n FDialog.ModalResult := mrOk\r\n else\r\n FDialog.ModalResult := mrCancel;\r\n end\r\n else\r\n if Mode = dmAppLogin then\r\n begin\r\n SetCursor := GetCurrentThreadID = MainThreadID;\r\n SaveLogin := Database.OnLogin;\r\n try\r\n try\r\n if Database.Connected then\r\n Database.Close; //Polaris\r\n if FSelectDatabase then\r\n Database.AliasName := FDialog.CustomCombo.Text;\r\n Database.OnLogin := Login;\r\n if SetCursor then\r\n Screen.Cursor := crHourGlass;\r\n try\r\n Database.Open;\r\n finally\r\n if SetCursor then\r\n Screen.Cursor := crDefault;\r\n end;\r\n except\r\n Application.HandleException(Self);\r\n end;\r\n finally\r\n Database.OnLogin := SaveLogin;\r\n end;\r\n if Database.Connected then\r\n try\r\n if SetCursor then\r\n Screen.Cursor := crHourGlass;\r\n Ok := False;\r\n try\r\n Ok := GetUserInfo;\r\n except\r\n Application.HandleException(Self);\r\n end;\r\n if Ok then\r\n FDialog.ModalResult := mrOk\r\n else\r\n begin\r\n FDialog.ModalResult := mrNone;\r\n Database.Close;\r\n end;\r\n finally\r\n if SetCursor then\r\n Screen.Cursor := crDefault;\r\n end;\r\n end\r\n else { dmDBLogin }\r\n FDialog.ModalResult := mrOk\r\nend;\r\n\r\nprocedure TJvDBLoginDialog.FormShow(Sender: TObject);\r\nvar\r\n S: string;\r\nbegin\r\n if (FMode in [dmAppLogin, dmDBLogin]) and FSelectDatabase then\r\n begin\r\n with TJvBDEItems.Create(FDialog) do\r\n try\r\n SessionName := Database.SessionName;\r\n ItemType := bdDatabases;\r\n FDialog.CustomCombo.Items.Clear;\r\n Open;\r\n while not Eof do\r\n begin\r\n FDialog.CustomCombo.Items.Add(FieldByName('NAME').AsString);\r\n Next;\r\n end;\r\n if FIniAliasName = '' then\r\n S := Database.AliasName\r\n else\r\n S := FIniAliasName;\r\n with FDialog.CustomCombo do\r\n ItemIndex := Items.IndexOf(S);\r\n finally\r\n Free;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJvDBLoginDialog.ExecuteAppLogin: Boolean;\r\nbegin\r\n if Assigned(AppStorage) then\r\n begin\r\n FDialog.UserNameEdit.Text := AppStorage.ReadString(AppStorage.ConcatPaths([AppStoragePath, RsLastLoginUserName]),\r\n LoginName);\r\n FSelectDatabase := AppStorage.ReadBoolean(AppStorage.ConcatPaths([AppStoragePath, RsSelectDatabase]),\r\n FSelectDatabase);\r\n FIniAliasName := AppStorage.ReadString(AppStorage.ConcatPaths([AppStoragePath, RsLastAliasName]), '');\r\n end;\r\n FDialog.SelectDatabase := SelectDatabase;\r\n Result := (FDialog.ShowModal = mrOk);\r\n Database.OnLogin := nil;\r\n if Result then\r\n begin\r\n LoginName := GetUserName;\r\n if Assigned(AppStorage) then\r\n begin\r\n AppStorage.WriteString(AppStorage.ConcatPaths([AppStoragePath, RsLastLoginUserName]), GetUserName);\r\n AppStorage.WriteString(AppStorage.ConcatPaths([AppStoragePath, RsLastAliasName]), Database.AliasName);\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJvDBLoginDialog.ExecuteDbLogin(LoginParams: TStrings): Boolean;\r\nvar\r\n CurrSession: TSession;\r\nbegin\r\n Result := False;\r\n if (Database = nil) or not Assigned(LoginParams) then\r\n Exit;\r\n if ShowDBName then\r\n FDialog.AppTitleLabel.Caption := Format(RsDatabaseName, [Database.DatabaseName]);\r\n FDialog.UserNameEdit.Text := LoginParams.Values[szUSERNAME];\r\n CurrSession := Sessions.CurrentSession;\r\n try\r\n Result := FDialog.ShowModal = mrOk;\r\n if Result then\r\n FillParams(LoginParams)\r\n else\r\n SysUtils.Abort;\r\n finally\r\n Sessions.CurrentSession := CurrSession;\r\n end;\r\nend;\r\n\r\nfunction TJvDBLoginDialog.ExecuteUnlock: Boolean;\r\nbegin\r\n with FDialog.UserNameEdit do\r\n begin\r\n Text := LoginName;\r\n ReadOnly := True;\r\n Font.Color := clGrayText;\r\n end;\r\n Result := (FDialog.ShowModal = mrOk);\r\nend;\r\n\r\nfunction TJvDBLoginDialog.Execute(LoginParams: TStrings): Boolean;\r\nvar\r\n SaveCursor: TCursor;\r\nbegin\r\n SaveCursor := Screen.Cursor;\r\n Screen.Cursor := crDefault;\r\n try\r\n if Assigned(FIconDblClick) then\r\n begin\r\n with FDialog.AppIcon do\r\n begin\r\n OnDblClick := OnIconDblClick;\r\n Cursor := crHand;\r\n end;\r\n with FDialog.KeyImage do\r\n begin\r\n OnDblClick := OnIconDblClick;\r\n Cursor := crHand;\r\n end;\r\n end;\r\n FDialog.PasswordEdit.MaxLength := MaxPwdLen;\r\n FDialog.AttemptNumber := AttemptNumber;\r\n case FMode of\r\n dmAppLogin:\r\n Result := ExecuteAppLogin;\r\n dmDBLogin:\r\n Result := ExecuteDbLogin(LoginParams);\r\n dmUnlock:\r\n Result := ExecuteUnlock;\r\n else\r\n Result := False;\r\n end;\r\n if Result then\r\n LoginName := GetUserName;\r\n finally\r\n Screen.Cursor := SaveCursor;\r\n end;\r\nend;\r\n\r\nfunction TJvDBLoginDialog.GetUserName: string;\r\nbegin\r\n if CheckDatabaseChange then\r\n Result := Copy(FDialog.UserNameEdit.Text, 1,\r\n Pos('@', FDialog.UserNameEdit.Text) - 1)\r\n else\r\n Result := FDialog.UserNameEdit.Text;\r\nend;\r\n\r\nfunction TJvDBLoginDialog.CheckDatabaseChange: Boolean;\r\nbegin\r\n Result := (FMode in [dmAppLogin, dmDBLogin]) and\r\n (Pos('@', FDialog.UserNameEdit.Text) > 0) and\r\n ((Database <> nil) and (Database.DriverName <> '') and\r\n (CompareText(Database.DriverName, szCFGDBSTANDARD) <> 0));\r\nend;\r\n\r\nprocedure TJvDBLoginDialog.FillParams(LoginParams: TStrings);\r\nbegin\r\n LoginParams.BeginUpdate;\r\n try\r\n LoginParams.Values[szUSERNAME] := GetUserName;\r\n LoginParams.Values[szPASSWORD] := GetPassword;\r\n if CheckDatabaseChange then\r\n begin\r\n LoginParams.Values[szSERVERNAME] := Copy(FDialog.UserNameEdit.Text,\r\n Pos('@', FDialog.UserNameEdit.Text) + 1, MaxInt)\r\n end;\r\n finally\r\n LoginParams.EndUpdate;\r\n end;\r\nend;\r\n\r\nprocedure TJvDBLoginDialog.Login(Database: TDatabase; LoginParams: TStrings);\r\nbegin\r\n FillParams(LoginParams);\r\nend;\r\n\r\nfunction TJvDBLoginDialog.GetPassword: string;\r\nbegin\r\n Result := FDialog.PasswordEdit.Text;\r\n if Assigned(OnGetPassword) then\r\n OnGetPassword(Self, GetUserName, Result);\r\nend;\r\n\r\nfunction TJvDBLoginDialog.GetUserInfo: Boolean;\r\nvar\r\n Table: TTable;\r\nbegin\r\n if UsersTableName = '' then\r\n Result := CheckUser(nil)\r\n else\r\n begin\r\n Result := False;\r\n // Table := TTable.Create(Database);\r\n Table := TTable.Create(Application); // Polaris (?)\r\n try\r\n try\r\n Table.DatabaseName := Database.DatabaseName;\r\n Table.SessionName := Database.SessionName;\r\n Table.TableName := UsersTableName;\r\n Table.IndexFieldNames := UserNameField;\r\n Table.Open;\r\n if Table.FindKey([GetUserName]) then\r\n begin\r\n Result := CheckUser(Table);\r\n\r\n if not Result then\r\n begin\r\n if Assigned(FOnLoginFailure) then\r\n FOnLoginFailure(Self, GetUserName, FDialog.PasswordEdit.Text)\r\n else\r\n raise EDatabaseError.CreateRes(@RsEInvalidUserName);\r\n end;\r\n end\r\n else\r\n begin\r\n if Assigned(FOnLoginFailure) then\r\n FOnLoginFailure(Self, GetUserName, FDialog.PasswordEdit.Text)\r\n else\r\n raise EDatabaseError.CreateRes(@RsEInvalidUserName);\r\n end;\r\n except\r\n Application.HandleException(Self);\r\n end;\r\n finally\r\n Table.Free;\r\n end;\r\n end;\r\nend;\r\n\r\n\r\nfunction TJvDBLoginDialog.CheckUser(Table: TTable): Boolean;\r\nbegin\r\n if Assigned(FCheckUserEvent) then\r\n Result := FCheckUserEvent(Table, GetUserName, FDialog.PasswordEdit.Text)\r\n else\r\n Result := True;\r\nend;\r\n\r\nfunction TJvDBLoginDialog.CheckUnlock: Boolean;\r\nbegin\r\n if Assigned(FCheckUnlock) then\r\n Result := FCheckUnlock(FDialog.PasswordEdit.Text)\r\n else\r\n Result := True;\r\nend;\r\n\r\n//=== Utility routines =======================================================\r\n\r\nprocedure OnLoginDialog(Database: TDatabase; LoginParams: TStrings;\r\n AttemptNumber: Integer; ShowDBName: Boolean);\r\nvar\r\n Dlg: TJvDBLoginDialog;\r\nbegin\r\n Dlg := TJvDBLoginDialog.Create(dmDBLogin, False);\r\n try\r\n Dlg.Database := Database;\r\n Dlg.ShowDBName := ShowDBName;\r\n Dlg.AttemptNumber := AttemptNumber;\r\n Dlg.Execute(LoginParams);\r\n finally\r\n Dlg.Free;\r\n end;\r\nend;\r\n\r\nfunction UnlockDialogEx(const UserName: string; OnUnlock: TCheckUnlockEvent;\r\n IconDblClick: TNotifyEvent; MaxPwdLen, AttemptNumber: Integer): Boolean;\r\nvar\r\n Dlg: TJvDBLoginDialog;\r\nbegin\r\n Dlg := TJvDBLoginDialog.Create(dmUnlock, False);\r\n try\r\n Dlg.LoginName := UserName;\r\n Dlg.OnIconDblClick := IconDblClick;\r\n Dlg.OnCheckUnlock := OnUnlock;\r\n Dlg.MaxPwdLen := MaxPwdLen;\r\n Dlg.AttemptNumber := AttemptNumber;\r\n Result := Dlg.Execute(nil);\r\n finally\r\n Dlg.Free;\r\n end;\r\nend;\r\n\r\nfunction UnlockDialog(const UserName: string; OnUnlock: TCheckUnlockEvent;\r\n IconDblClick: TNotifyEvent): Boolean;\r\nbegin\r\n Result := UnlockDialogEx(UserName, OnUnlock, IconDblClick, 0, 1);\r\nend;\r\n\r\nfunction LoginDialog(Database: TDatabase; AttemptNumber: Integer;\r\n const UsersTableName, UserNameField: string; MaxPwdLen: Integer;\r\n CheckUserEvent: TCheckUserNameEvent; IconDblClick: TNotifyEvent;\r\n var LoginName: string; AppStorage: TJvCustomAppStorage;\r\n AppStoragePath: string; SelectDatabase: Boolean;\r\n LoginFailure: TJvDBLoginEvent; OnGetPassword: TJvOnGetPassword): Boolean;\r\nvar\r\n Dlg: TJvDBLoginDialog;\r\nbegin\r\n Dlg := TJvDBLoginDialog.Create(dmAppLogin, SelectDatabase);\r\n try\r\n Dlg.LoginName := LoginName;\r\n Dlg.OnIconDblClick := IconDblClick;\r\n Dlg.OnCheckUserEvent := CheckUserEvent;\r\n Dlg.OnLoginFailure := LoginFailure;\r\n Dlg.MaxPwdLen := MaxPwdLen;\r\n Dlg.Database := Database;\r\n Dlg.AttemptNumber := AttemptNumber;\r\n Dlg.UsersTableName := UsersTableName;\r\n Dlg.UserNameField := UserNameField;\r\n Dlg.AppStorage := AppStorage;\r\n Dlg.AppStoragePath := AppStoragePath;\r\n Dlg.OnGetPassword := OnGetPassword;\r\n Result := Dlg.Execute(nil);\r\n if Result then\r\n LoginName := Dlg.LoginName;\r\n finally\r\n Dlg.Free;\r\n end;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvBDEMemTable.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvMemTable.PAS, released on 2002-07-04.\r\n\r\nThe Initial Developers of the Original Code are: Fedor Koshevnikov, Igor Pavluk and Serge Korolev\r\nCopyright (c) 1997, 1998 Fedor Koshevnikov, Igor Pavluk and Serge Korolev\r\nCopyright (c) 2001,2002 SGB Software\r\nAll Rights Reserved.\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvBDEMemTable.pas 13415 2012-09-10 09:51:54Z obones $\r\n\r\nunit JvBDEMemTable;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n SysUtils, Classes,\r\n BDE, DB, DBTables;\r\n\r\ntype\r\n {$IFDEF RTL240_UP}\r\n TJvValueBuffer = TValueBuffer;\r\n {$ELSE}\r\n TJvValueBuffer = Pointer;\r\n {$ENDIF RTL240_UP}\r\n \r\n TJvBDEMemoryTable = class(TDBDataSet)\r\n private\r\n FTableName: TFileName;\r\n FMoveHandle: HDBICur;\r\n FEnableDelete: Boolean;\r\n FDisableEvents: Boolean;\r\n procedure EncodeFieldDesc(var FieldDesc: FLDDesc;\r\n const Name: string; DataType: TFieldType; Size, Precision: Word);\r\n procedure SetTableName(const Value: TFileName);\r\n function SupportedFieldType(AType: TFieldType): Boolean;\r\n procedure DeleteCurrentRecord;\r\n protected\r\n function CreateHandle: HDBICur; override;\r\n procedure DoBeforeClose; override;\r\n procedure DoAfterClose; override;\r\n procedure DoBeforeOpen; override;\r\n procedure DoAfterOpen; override;\r\n procedure DoBeforeScroll; override;\r\n procedure DoAfterScroll; override;\r\n function GetRecordCount: Integer; override;\r\n function GetRecNo: Integer; override;\r\n procedure SetRecNo(Value: Integer); override;\r\n procedure InternalDelete; override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n function BatchMove(ASource: TDataSet; AMode: TBatchMode;\r\n ARecordCount: Longint): Longint;\r\n procedure CopyStructure(ASource: TDataSet);\r\n procedure CreateTable;\r\n procedure DeleteTable;\r\n procedure EmptyTable;\r\n procedure GotoRecord(RecordNo: Longint);\r\n function GetFieldData(Field: TField; Buffer: TJvValueBuffer): Boolean; override;\r\n function IsSequenced: Boolean; override;\r\n function Locate(const KeyFields: string; const KeyValues: Variant;\r\n Options: TLocateOptions): Boolean; override;\r\n function Lookup(const KeyFields: string; const KeyValues: Variant;\r\n const ResultFields: string): Variant; override;\r\n procedure SetFieldValues(const FieldNames: array of string;\r\n const Values: array of const);\r\n published\r\n property EnableDelete: Boolean read FEnableDelete write FEnableDelete default True;\r\n property TableName: TFileName read FTableName write SetTableName;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvBDEMemTable.pas $';\r\n Revision: '$Revision: 13415 $';\r\n Date: '$Date: 2012-09-10 11:51:54 +0200 (lun. 10 sept. 2012) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n bdeconst, DBConsts, Math,\r\n JvDBUtils, JvBdeUtils;\r\n\r\nconst\r\n InternalMemTableName1 = '$InMem$';\r\n InternalMemTableName2 = '$JvInMem$';\r\n\r\n{ Memory tables are created in RAM and deleted when you close them. They\r\n are much faster and are very useful when you need fast operations on\r\n small tables. Memory tables do not support certain features (like\r\n deleting records, referntial integrity, indexes, autoincrement fields\r\n and BLOBs) }\r\n\r\nconstructor TJvBDEMemoryTable.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FEnableDelete := True;\r\nend;\r\n\r\nfunction TJvBDEMemoryTable.BatchMove(ASource: TDataSet; AMode: TBatchMode;\r\n ARecordCount: Longint): Longint;\r\nvar\r\n SourceActive: Boolean;\r\n MovedCount: Longint;\r\nbegin\r\n if (ASource = nil) or (Self = ASource) or\r\n not (AMode in [batCopy, batAppend]) then\r\n _DBError(SInvalidBatchMove);\r\n SourceActive := ASource.Active;\r\n try\r\n ASource.DisableControls;\r\n DisableControls;\r\n ASource.Open;\r\n ASource.CheckBrowseMode;\r\n ASource.UpdateCursorPos;\r\n if AMode = batCopy then\r\n begin\r\n Close;\r\n CopyStructure(ASource);\r\n end;\r\n if not Active then\r\n Open;\r\n CheckBrowseMode;\r\n if ARecordCount > 0 then\r\n begin\r\n ASource.UpdateCursorPos;\r\n MovedCount := ARecordCount;\r\n end\r\n else\r\n begin\r\n ASource.First;\r\n MovedCount := MaxLongint;\r\n end;\r\n try\r\n Result := 0;\r\n while not ASource.Eof do\r\n begin\r\n Append;\r\n AssignRecord(ASource, Self, True);\r\n Post;\r\n Inc(Result);\r\n if Result >= MovedCount then\r\n Break;\r\n ASource.Next;\r\n end;\r\n finally\r\n Self.First;\r\n end;\r\n finally\r\n if not SourceActive then\r\n ASource.Close;\r\n Self.EnableControls;\r\n ASource.EnableControls;\r\n end;\r\nend;\r\n\r\nprocedure TJvBDEMemoryTable.CopyStructure(ASource: TDataSet);\r\nvar\r\n I: Integer;\r\n\r\n procedure CreateField(FieldDef: TFieldDef; AOwner: TComponent);\r\n begin\r\n FieldDef.CreateField(AOwner, nil, FieldDef.Name, True);\r\n end;\r\n\r\nbegin\r\n CheckInactive;\r\n for I := FieldCount - 1 downto 0 do\r\n Fields[I].Free;\r\n if ASource = nil then\r\n Exit;\r\n ASource.FieldDefs.Update;\r\n FieldDefs := ASource.FieldDefs;\r\n for I := 0 to FieldDefs.Count - 1 do\r\n if SupportedFieldType(FieldDefs.Items[I].DataType) then\r\n begin\r\n if (csDesigning in ComponentState) and (Owner <> nil) then\r\n CreateField(FieldDefs.Items[I], Owner)\r\n else\r\n CreateField(FieldDefs.Items[I], Self);\r\n end;\r\nend;\r\n\r\nprocedure TJvBDEMemoryTable.DeleteCurrentRecord;\r\nvar\r\n CurRecNo, CurRec: Longint;\r\n Buffer: Pointer;\r\n iFldCount: Word;\r\n FieldDescs: PFLDDesc;\r\nbegin\r\n CurRecNo := RecNo;\r\n iFldCount := FieldDefs.Count;\r\n FieldDescs := AllocMem(iFldCount * SizeOf(FLDDesc));\r\n try\r\n Check(DbiGetFieldDescs(Handle, FieldDescs));\r\n Check(DbiCreateInMemTable(DBHandle, InternalMemTableName1, iFldCount, FieldDescs,\r\n FMoveHandle));\r\n try\r\n DisableControls;\r\n Buffer := AllocMem(RecordSize);\r\n try\r\n First;\r\n CurRec := 0;\r\n while not Self.Eof do\r\n begin\r\n Inc(CurRec);\r\n if CurRec <> CurRecNo then\r\n begin\r\n DbiInitRecord(FMoveHandle, Buffer);\r\n Self.GetCurrentRecord(Buffer);\r\n Check(DbiAppendRecord(FMoveHandle, Buffer));\r\n end;\r\n Self.Next;\r\n end;\r\n FDisableEvents := True;\r\n try\r\n Close;\r\n Open;\r\n FMoveHandle := nil;\r\n finally\r\n FDisableEvents := False;\r\n end;\r\n finally\r\n FreeMem(Buffer, RecordSize);\r\n end;\r\n except\r\n DbiCloseCursor(FMoveHandle);\r\n FMoveHandle := nil;\r\n raise;\r\n end;\r\n GotoRecord(CurRecNo - 1);\r\n finally\r\n if FieldDescs <> nil then\r\n FreeMem(FieldDescs, iFldCount * SizeOf(FLDDesc));\r\n FMoveHandle := nil;\r\n EnableControls;\r\n end;\r\nend;\r\n\r\n\r\nfunction TJvBDEMemoryTable.GetFieldData(Field: TField; Buffer: TJvValueBuffer): Boolean;\r\nvar\r\n IsBlank: LongBool;\r\n RecBuf: {$IFDEF COMPILER12_UP}PByte{$ELSE}PAnsiChar{$ENDIF COMPILER12_UP};\r\nbegin\r\n Result := inherited GetFieldData(Field, Buffer);\r\n if not Result then\r\n begin\r\n RecBuf := nil;\r\n case State of\r\n dsBrowse:\r\n if not IsEmpty then\r\n RecBuf := ActiveBuffer;\r\n dsEdit, dsInsert:\r\n RecBuf := ActiveBuffer;\r\n dsCalcFields:\r\n RecBuf := CalcBuffer;\r\n end;\r\n if RecBuf = nil then\r\n Exit;\r\n with Field do\r\n if FieldNo > 0 then\r\n begin\r\n Check(DbiGetField(Handle, FieldNo, RecBuf, nil, IsBlank));\r\n Result := not IsBlank;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvBDEMemoryTable.InternalDelete;\r\nbegin\r\n if EnableDelete then\r\n DeleteCurrentRecord\r\n else\r\n inherited InternalDelete;\r\nend;\r\n\r\nfunction TJvBDEMemoryTable.Locate(const KeyFields: string;\r\n const KeyValues: Variant; Options: TLocateOptions): Boolean;\r\nbegin\r\n DoBeforeScroll;\r\n Result := DataSetLocateThrough(Self, KeyFields, KeyValues, Options);\r\n if Result then\r\n begin\r\n DataEvent(deDataSetChange, 0);\r\n DoAfterScroll;\r\n end;\r\nend;\r\n\r\nfunction TJvBDEMemoryTable.Lookup(const KeyFields: string;\r\n const KeyValues: Variant; const ResultFields: string): Variant;\r\nbegin\r\n Result := False;\r\nend;\r\n\r\n\r\nprocedure TJvBDEMemoryTable.DoAfterClose;\r\nbegin\r\n if not FDisableEvents then\r\n inherited DoAfterClose;\r\nend;\r\n\r\nprocedure TJvBDEMemoryTable.DoAfterOpen;\r\nbegin\r\n if not FDisableEvents then\r\n inherited DoAfterOpen;\r\nend;\r\n\r\nprocedure TJvBDEMemoryTable.DoBeforeClose;\r\nbegin\r\n if not FDisableEvents then\r\n inherited DoBeforeClose;\r\nend;\r\n\r\nprocedure TJvBDEMemoryTable.DoBeforeOpen;\r\nbegin\r\n if not FDisableEvents then\r\n inherited DoBeforeOpen;\r\nend;\r\n\r\n\r\nprocedure TJvBDEMemoryTable.DoBeforeScroll;\r\nbegin\r\n if not FDisableEvents then\r\n inherited DoBeforeScroll;\r\nend;\r\n\r\nprocedure TJvBDEMemoryTable.DoAfterScroll;\r\nbegin\r\n if not FDisableEvents then\r\n inherited DoAfterScroll;\r\nend;\r\n\r\nfunction TJvBDEMemoryTable.SupportedFieldType(AType: TFieldType): Boolean;\r\nbegin\r\n Result := not (AType in [ftUnknown, ftWideString, ftOraBlob, ftOraClob, ftVariant, ftInterface,\r\n ftIDispatch, ftGuid] + ftNonTextTypes);\r\nend;\r\n\r\nfunction TJvBDEMemoryTable.CreateHandle: HDBICur;\r\nvar\r\n I: Integer;\r\n FldDescList: TFieldDescList;\r\n FieldDescs: PFLDDesc;\r\n iFldCount: Cardinal;\r\n szTblName: DBITBLNAME;\r\nbegin\r\n if (FMoveHandle <> nil) then\r\n begin\r\n Result := FMoveHandle;\r\n Exit;\r\n end;\r\n if FieldCount > 0 then\r\n FieldDefs.Clear;\r\n if FieldDefs.Count = 0 then\r\n for I := 0 to FieldCount - 1 do\r\n begin\r\n if not SupportedFieldType(Fields[I].DataType) then\r\n DatabaseErrorFmt(SUnknownFieldType, [Fields[I].FieldName]);\r\n with Fields[I] do\r\n if not (Calculated or Lookup) then\r\n FieldDefs.Add(FieldName, DataType, Size, Required);\r\n end;\r\n iFldCount := FieldDefs.Count;\r\n SetDBFlag(dbfTable, True);\r\n try\r\n if TableName = '' then\r\n AnsiToNative(Locale, InternalMemTableName1, szTblName, SizeOf(szTblName) - 1)\r\n else\r\n AnsiToNative(Locale, AnsiString(TableName), szTblName, SizeOf(szTblName) - 1);\r\n SetLength(FldDescList, iFldCount);\r\n FieldDescs := BDE.PFLDDesc(FldDescList);\r\n for I := 0 to FieldDefs.Count - 1 do\r\n with FieldDefs[I] do\r\n EncodeFieldDesc(FldDescList[I], Name, DataType, Size, Precision);\r\n Check(DbiTranslateRecordStructure(nil, iFldCount, FieldDescs, nil, nil,\r\n FieldDescs, False));\r\n Check(DbiCreateInMemTable(DBHandle, szTblName, iFldCount, FieldDescs,\r\n Result));\r\n finally\r\n SetDBFlag(dbfTable, False);\r\n end;\r\nend;\r\n\r\nprocedure TJvBDEMemoryTable.CreateTable;\r\nbegin\r\n CheckInactive;\r\n Open;\r\nend;\r\n\r\nprocedure TJvBDEMemoryTable.DeleteTable;\r\nbegin\r\n CheckBrowseMode;\r\n Close;\r\nend;\r\n\r\nprocedure TJvBDEMemoryTable.EmptyTable;\r\nbegin\r\n if Active then\r\n begin\r\n CheckBrowseMode;\r\n DisableControls;\r\n FDisableEvents := True;\r\n try\r\n Close;\r\n Open;\r\n finally\r\n FDisableEvents := False;\r\n EnableControls;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvBDEMemoryTable.EncodeFieldDesc(var FieldDesc: FLDDesc;\r\n const Name: string; DataType: TFieldType; Size, Precision: Word);\r\nbegin\r\n with FieldDesc do\r\n begin\r\n FillChar(szName, SizeOf(szName), 0);\r\n AnsiToNative(Locale, AnsiString(Name), szName, SizeOf(szName) - 1);\r\n iFldType := FieldLogicMap(DataType);\r\n iSubType := FieldSubtypeMap(DataType);\r\n if iSubType = fldstAUTOINC then\r\n iSubType := 0;\r\n case DataType of\r\n ftString, ftFixedChar, ftBytes, ftVarBytes, ftBlob..ftTypedBinary:\r\n iUnits1 := Size;\r\n ftBCD:\r\n begin\r\n { Default precision is 32, Size = Scale }\r\n if (Precision > 0) and (Precision <= 32) then\r\n iUnits1 := Precision\r\n else\r\n iUnits1 := 32;\r\n iUnits2 := Size; {Scale}\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJvBDEMemoryTable.GetRecordCount: Integer;\r\nbegin\r\n if State = dsInactive then\r\n _DBError(SDataSetClosed);\r\n Check(DbiGetRecordCount(Handle, Result));\r\nend;\r\n\r\nprocedure TJvBDEMemoryTable.SetRecNo(Value: Integer);\r\nvar\r\n Rslt: DBIResult;\r\nbegin\r\n CheckBrowseMode;\r\n UpdateCursorPos;\r\n Rslt := DbiSetToSeqNo(Handle, Value);\r\n if Rslt = DBIERR_EOF then\r\n Last\r\n else\r\n if Rslt = DBIERR_BOF then\r\n First\r\n else\r\n begin\r\n Check(Rslt);\r\n Resync([rmExact, rmCenter]);\r\n end;\r\nend;\r\n\r\nfunction TJvBDEMemoryTable.GetRecNo: Integer;\r\nvar\r\n Rslt: DBIResult;\r\nbegin\r\n Result := -1;\r\n if State in [dsBrowse, dsEdit] then\r\n begin\r\n UpdateCursorPos;\r\n Rslt := DbiGetSeqNo(Handle, Result);\r\n if (Rslt <> DBIERR_EOF) and (Rslt <> DBIERR_BOF) then\r\n Check(Rslt);\r\n end;\r\nend;\r\n\r\nprocedure TJvBDEMemoryTable.GotoRecord(RecordNo: Longint);\r\nbegin\r\n RecNo := RecordNo;\r\nend;\r\n\r\nfunction TJvBDEMemoryTable.IsSequenced: Boolean;\r\nbegin\r\n Result := not Filtered;\r\nend;\r\n\r\nprocedure TJvBDEMemoryTable.SetFieldValues(const FieldNames: array of string;\r\n const Values: array of const);\r\nvar\r\n I: Integer;\r\n Pos: Longint;\r\nbegin\r\n Pos := RecNo;\r\n DisableControls;\r\n try\r\n First;\r\n while not Eof do\r\n begin\r\n Edit;\r\n for I := 0 to Max(High(FieldNames), High(Values)) do\r\n FieldByName(FieldNames[I]).AssignValue(Values[I]);\r\n Post;\r\n Next;\r\n end;\r\n GotoRecord(Pos);\r\n finally\r\n EnableControls;\r\n end;\r\nend;\r\n\r\nprocedure TJvBDEMemoryTable.SetTableName(const Value: TFileName);\r\nbegin\r\n CheckInactive;\r\n FTableName := Value;\r\n DataEvent(dePropertyChange, 0);\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvBDEMove.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvDBMove.PAS, released on 2002-07-04.\r\n\r\nThe Initial Developers of the Original Code are: Andrei Prygounkov \r\nCopyright (c) 1999, 2002 Andrei Prygounkov\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nDescription:\r\n database batchmove\r\n\r\nHistory:\r\n 1.23 - added suport for table names with extensions;\r\n\r\n Note: All referenced fields MUST be Integer\r\n\r\n Example :\r\n Source = dbChildCompany\r\n Destination = dbCompany\r\n Tables = (\r\n Employee\r\n Children\r\n );\r\n References = (\r\n Children.Employee = Employee.Uni\r\n );\r\n TempTable = '_RATMP1_.DB';\r\n BeforePost = user defined unique generation procedure;\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvBDEMove.pas 13075 2011-06-27 22:56:21Z jfudickar $\r\n\r\nunit JvBDEMove;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Classes, DB, DBTables,\r\n JvComponentBase;\r\n\r\ntype\r\n TJvDBMove = class;\r\n TMoveAction = (maMove, maMap, maIgnore);\r\n\r\n TMoveEvent = procedure(Sender: TJvDBMove; Table: TTable; var Action: TMoveAction) of object;\r\n\r\n TJvDBMove = class(TJvComponent)\r\n private\r\n FSource: string;\r\n FDestination: string;\r\n FSTable: TTable;\r\n FDTable: TTable;\r\n FTempTable: string;\r\n FRTable: TTable; { temporary table }\r\n FTables: TStringList;\r\n FReferences: TStringList;\r\n FMappings: TStringList;\r\n FFieldRefs: TList;\r\n\r\n FProgress: Boolean;\r\n FRecordCount: Integer;\r\n FCurrentRecord: Integer;\r\n FErrorCount: Integer;\r\n FErrorBlobCount: Integer;\r\n FMaxPass: Integer;\r\n\r\n FOnMoveRecord: TMoveEvent;\r\n FOnPostError: TDataSetErrorEvent;\r\n\r\n procedure DoMove;\r\n function GetTables: TStrings;\r\n function GetReferences: TStrings;\r\n function GetMappings: TStrings;\r\n procedure SetTables(Value: TStrings);\r\n procedure SetReferences(Value: TStrings);\r\n procedure SetMappings(Value: TStrings);\r\n procedure CreateTmpTable;\r\n procedure CompileReferences;\r\n function Map(const TableName, FieldName: string): string;\r\n procedure CompatTables;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n procedure Execute;\r\n property RecordCount: Integer read FRecordCount;\r\n property CurrentRecord: Integer read FCurrentRecord;\r\n property ErrorCount: Integer read FErrorCount;\r\n property ErrorBlobCount: Integer read FErrorBlobCount;\r\n published\r\n property Source: string read FSource write FSource;\r\n property Destination: string read FDestination write FDestination;\r\n property Tables: TStrings read GetTables write SetTables;\r\n property TempTable: string read FTempTable write FTempTable;\r\n property References: TStrings read GetReferences write SetReferences;\r\n property Mappings: TStrings read GetMappings write SetMappings;\r\n property OnMoveRecord: TMoveEvent read FOnMoveRecord write FOnMoveRecord;\r\n property OnPostError: TDataSetErrorEvent read FOnPostError write FOnPostError;\r\n property Progress: Boolean read FProgress write FProgress default False;\r\n end;\r\n\r\n EJvDBMoveError = class(EDatabaseError);\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvBDEMove.pas $';\r\n Revision: '$Revision: 13075 $';\r\n Date: '$Date: 2011-06-28 00:56:21 +0200 (mar. 28 juin 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n Variants, SysUtils, BDE,\r\n JvBdeUtils, JvResources;\r\n\r\nconst\r\n cTable = 'Table';\r\n cField = 'Field';\r\n cOldValue = 'OldValue';\r\n cNewValue = 'NewValue';\r\n\r\ntype\r\n TFieldRef = class(TObject)\r\n private\r\n STableName: string;\r\n SFieldName: string;\r\n STableIndex: Integer;\r\n SFieldIndex: Integer;\r\n DTFieldIndex: Integer;\r\n MasterRef: Boolean;\r\n DTableName: string;\r\n DFieldName: string;\r\n DTableIndex: Integer;\r\n DFieldIndex: Integer;\r\n end;\r\n\r\nfunction CmdString(S: string): Boolean;\r\nbegin\r\n S := Trim(S);\r\n Result := (S <> '') and (S[1] <> ';');\r\nend;\r\n\r\nconstructor TJvDBMove.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FTables := TStringList.Create;\r\n FReferences := TStringList.Create;\r\n FMappings := TStringList.Create;\r\n FFieldRefs := TList.Create;\r\n FTempTable := '_RATMP1_';\r\n FMaxPass := 1;\r\nend;\r\n\r\ndestructor TJvDBMove.Destroy;\r\nbegin\r\n FTables.Free;\r\n FReferences.Free;\r\n FMappings.Free;\r\n FFieldRefs.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJvDBMove.GetTables: TStrings;\r\nbegin\r\n Result := FTables;\r\nend;\r\n\r\nprocedure TJvDBMove.SetTables(Value: TStrings);\r\nbegin\r\n FTables.Assign(Value);\r\n CompatTables;\r\nend;\r\n\r\nprocedure TJvDBMove.CompatTables;\r\nvar\r\n I: Integer;\r\nbegin\r\n { make compatible with previous version of TJvDBMove }\r\n for I := 0 to FTables.Count - 1 do\r\n if FTables[I] <> '' then\r\n FTables[I] := Trim(SubStr(FTables[I], 0, '='));\r\nend;\r\n\r\nfunction TJvDBMove.GetReferences: TStrings;\r\nbegin\r\n Result := FReferences;\r\nend;\r\n\r\nprocedure TJvDBMove.SetReferences(Value: TStrings);\r\nbegin\r\n FReferences.Assign(Value);\r\nend;\r\n\r\nfunction TJvDBMove.GetMappings: TStrings;\r\nbegin\r\n Result := FMappings;\r\nend;\r\n\r\nprocedure TJvDBMove.SetMappings(Value: TStrings);\r\nbegin\r\n FMappings.Assign(Value);\r\nend;\r\n\r\nfunction TJvDBMove.Map(const TableName, FieldName: string): string;\r\nbegin\r\n if FieldName = '' then\r\n begin\r\n Result := FMappings.Values[TableName];\r\n if Result = '' then\r\n Result := TableName;\r\n end\r\n else\r\n begin\r\n Result := SubStrEnd(FMappings.Values[ChangeFileExt(TableName, '') +\r\n '.' + FieldName], 0, '.');\r\n if Result = '' then\r\n Result := FieldName;\r\n end;\r\nend;\r\n\r\nprocedure TJvDBMove.CreateTmpTable;\r\nbegin\r\n with FRTable do\r\n begin\r\n Active := False; { The Table component must not be active }\r\n { First, describe the type of table and give it a name }\r\n DatabaseName := FDestination;\r\n TableType := ttDefault;\r\n TableName := FTempTable;\r\n { Next, describe the fields in the table }\r\n with FieldDefs do\r\n begin\r\n Clear;\r\n Add(cTable, ftInteger, 0, True);\r\n Add(cField, ftInteger, 0, True);\r\n Add(cOldValue, ftInteger, 0, True);\r\n Add(cNewValue, ftInteger, 0, True);\r\n end;\r\n { Next, describe any indexes }\r\n{ with IndexDefs do\r\n begin\r\n Clear;\r\n Add('', cTable + ';' + cField + ';' + cOldValue, [ixPrimary, ixUnique]);\r\n end;\r\n }{ Now that we have specified what we want, create the table }\r\n CreateTable;\r\n end;\r\nend;\r\n\r\nprocedure TJvDBMove.Execute;\r\n\r\n procedure CalcRecords;\r\n var\r\n I: Integer;\r\n begin\r\n FRecordCount := 0;\r\n FCurrentRecord := 0;\r\n for I := 0 to FTables.Count - 1 do\r\n if CmdString(FTables[I]) then\r\n begin\r\n FSTable.Close;\r\n FSTable.TableName := FTables[I];\r\n FSTable.Open;\r\n Inc(FRecordCount, FSTable.RecordCount);\r\n end;\r\n end;\r\n\r\nbegin\r\n CompatTables;\r\n FSTable := TTable.Create(Self);\r\n FDTable := TTable.Create(Self);\r\n FRTable := TTable.Create(Self);\r\n try\r\n FSTable.DatabaseName := FSource;\r\n FDTable.DatabaseName := FDestination;\r\n FRecordCount := -1;\r\n if FProgress then\r\n CalcRecords;\r\n CreateTmpTable;\r\n try\r\n FRTable.Open;\r\n CompileReferences;\r\n FDTable.OnPostError := FOnPostError;\r\n DoMove;\r\n finally\r\n FRTable.Close;\r\n FRTable.DeleteTable;\r\n end;\r\n finally\r\n FSTable.Free;\r\n FDTable.Free;\r\n FRTable.Free;\r\n end;\r\nend;\r\n\r\nprocedure TJvDBMove.CompileReferences;\r\nvar\r\n I, J: Integer;\r\n S: string;\r\n Master, Detail: string;\r\n FieldRef: TFieldRef;\r\nbegin\r\n FFieldRefs.Clear;\r\n for I := 0 to FReferences.Count - 1 do\r\n begin\r\n S := FReferences[I];\r\n if CmdString(S) then\r\n begin\r\n Detail := SubStr(S, 0, '=');\r\n Master := SubStr(S, 1, '=');\r\n if (Detail = '') or (Pos('.', Detail) = 0) or\r\n (Master = '') or (Pos('.', Master) = 0) then\r\n raise EJvDBMoveError.CreateRes(@RsEInvalidReferenceDescriptor);\r\n FieldRef := TFieldRef.Create;\r\n FieldRef.STableName := Trim(SubStr(Master, 0, '.'));\r\n FieldRef.SFieldName := Trim(SubStr(Master, 1, '.'));\r\n FieldRef.DTableName := Trim(SubStr(Detail, 0, '.'));\r\n FieldRef.DFieldName := Trim(SubStr(Detail, 1, '.'));\r\n FieldRef.STableIndex := -1;\r\n FieldRef.STableIndex := -1;\r\n FieldRef.SFieldIndex := -1;\r\n FieldRef.DFieldIndex := -1;\r\n FieldRef.DTFieldIndex := -1;\r\n FieldRef.MasterRef := True;\r\n for J := 0 to FFieldRefs.Count - 1 do\r\n with TFieldRef(FFieldRefs[J]) do\r\n if Cmp(STableName, FieldRef.STableName) and\r\n Cmp(SFieldName, FieldRef.SFieldName) then\r\n begin\r\n FieldRef.MasterRef := False;\r\n Break;\r\n end;\r\n FFieldRefs.Add(FieldRef);\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvDBMove.DoMove;\r\ntype\r\n TRef = record\r\n IsRef: Boolean;\r\n Value: Integer;\r\n HasRef: Boolean;\r\n end;\r\nvar\r\n MasterFields: array [0..1023] of TRef; // Max_Columns\r\n HasMaster, HasDetail: Boolean;\r\n AllFixups: Boolean;\r\n I, TableIndex: Integer;\r\n // Er : Integer;\r\n\r\n procedure UpdateRefList(ATableIndex: Integer);\r\n var\r\n I, F: Integer;\r\n begin\r\n FillChar(MasterFields, SizeOf(MasterFields), 0);\r\n for I := 0 to FFieldRefs.Count - 1 do\r\n with TFieldRef(FFieldRefs[I]) do\r\n begin\r\n if Cmp(STableName, ChangeFileExt(FSTable.TableName, '')) then\r\n begin\r\n STableIndex := ATableIndex;\r\n for F := 0 to FSTable.FieldCount - 1 do\r\n if Cmp(SFieldName, FSTable.Fields[F].FieldName) then\r\n begin\r\n SFieldIndex := F;\r\n DTFieldIndex := FDTable.FieldByName(\r\n Map(FSTable.TableName, FSTable.Fields[SFieldIndex].FieldName)).Index;\r\n MasterFields[F].IsRef := True;\r\n HasMaster := True;\r\n end;\r\n end;\r\n if Cmp(Map(DTableName, ''), ChangeFileExt(FDTable.TableName, '')) then\r\n begin\r\n DTableIndex := ATableIndex;\r\n for F := 0 to FDTable.FieldCount - 1 do\r\n if Cmp(Map(DTableName, DFieldName), FDTable.Fields[F].FieldName) then\r\n begin\r\n DFieldIndex := F;\r\n MasterFields[F].HasRef := True;\r\n HasDetail := True;\r\n end;\r\n end;\r\n end;\r\n end;\r\n\r\n procedure AppendRef(TableIndex: Integer);\r\n var\r\n I: Integer;\r\n begin\r\n for I := 0 to FFieldRefs.Count - 1 do\r\n with TFieldRef(FFieldRefs[I]) do\r\n if MasterRef and (STableIndex = TableIndex) then\r\n try\r\n FRTable.AppendRecord([TableIndex + 1, SFieldIndex + 1,\r\n MasterFields[SFieldIndex].Value,\r\n FDTable.Fields[DTFieldIndex].AsVariant]);\r\n except;\r\n end;\r\n end;\r\n\r\n function FixupRef(TableIndex: Integer): Boolean;\r\n var\r\n I: Integer;\r\n begin\r\n for I := 0 to FFieldRefs.Count - 1 do\r\n with TFieldRef(FFieldRefs[I]) do\r\n if (DTableIndex = TableIndex) and\r\n (DFieldIndex <> -1) and\r\n (FDTable.Fields[DFieldIndex].AsVariant <> Null) then\r\n begin\r\n { FDTable.Fields[DFieldIndex].AsVariant :=\r\n FRTable.Lookup(cTable + ';' + cField + ';' + cOldValue, VarArrayOf([\r\n STableIndex + 1,\r\n SFieldIndex + 1,\r\n FDTable.Fields[DFieldIndex].AsVariant]),\r\n cNewValue); }\r\n if FRTable.Locate(cTable + ';' + cField + ';' + cOldValue,\r\n VarArrayOf([STableIndex + 1, SFieldIndex + 1,\r\n FDTable.Fields[DFieldIndex].AsVariant]), []) then\r\n FDTable.Fields[DFieldIndex].AsVariant := FRTable[cNewValue]\r\n else\r\n begin\r\n // record not found, may be in second pass\r\n AllFixups := False;\r\n Result := False;\r\n Inc(FErrorCount);\r\n Exit;\r\n end;\r\n end;\r\n Result := True;\r\n end;\r\n\r\n procedure MoveRecord(TableIndex: Integer);\r\n var\r\n F: Integer;\r\n Action: TMoveAction;\r\n\r\n procedure MoveField(FieldIndex: Integer);\r\n begin\r\n try\r\n FDTable.FieldByName(Map(FSTable.TableName,\r\n FSTable.Fields[FieldIndex].FieldName)).AsVariant :=\r\n FSTable.Fields[FieldIndex].AsVariant;\r\n except\r\n on E: EDBEngineError do\r\n if E.Errors[0].ErrorCode = DBIERR_BLOBMODIFIED then\r\n begin\r\n Inc(FErrorCount);\r\n Inc(FErrorBlobCount);\r\n end\r\n else\r\n raise;\r\n end;\r\n end;\r\n\r\n begin\r\n FDTable.Append;\r\n try\r\n for F := 0 to FSTable.FieldCount - 1 do\r\n if FDTable.FindField(Map(FSTable.TableName,\r\n FSTable.Fields[F].FieldName)) <> nil then\r\n begin\r\n MoveField(F);\r\n if MasterFields[F].IsRef then\r\n MasterFields[F].Value := FSTable.Fields[F].AsInteger;\r\n end;\r\n Action := maMove;\r\n if HasDetail and not FixupRef(TableIndex) then\r\n Action := maIgnore;\r\n if (Action = maMove) and Assigned(FOnMoveRecord) then\r\n FOnMoveRecord(Self, FDTable, Action);\r\n if HasMaster and (Action in [maMove, maMap]) then\r\n AppendRef(TableIndex);\r\n if Action = maMove then\r\n try\r\n FDTable.Post\r\n except\r\n on E: EAbort do\r\n begin\r\n FDTable.Cancel;\r\n Inc(FErrorCount);\r\n end;\r\n end\r\n else\r\n FDTable.Cancel;\r\n except\r\n on E: EAbort do\r\n raise\r\n else\r\n if FDTable.State = dsInsert then\r\n FDTable.Cancel;\r\n // raise;\r\n end;\r\n end;\r\n\r\n procedure MoveTable(TableIndex: Integer);\r\n begin\r\n FSTable.Close;\r\n FDTable.Close;\r\n FSTable.TableName := FTables[TableIndex];\r\n FDTable.TableName := Map(FTables[TableIndex], '');\r\n FSTable.Open;\r\n FDTable.Open;\r\n UpdateRefList(TableIndex);\r\n while not FSTable.Eof do\r\n begin\r\n try\r\n Inc(FCurrentRecord);\r\n MoveRecord(TableIndex);\r\n except\r\n //\r\n raise;\r\n end;\r\n FSTable.Next;\r\n end;\r\n end;\r\n\r\nbegin\r\n FCurrentRecord := 0;\r\n FErrorCount := 0;\r\n FErrorBlobCount := 0;\r\n for I := 0 to FTables.Count - 1 do\r\n if CmdString(FTables[I]) then\r\n begin\r\n { in Tables list one table can be appear more than once,\r\n but we must use one TableIndex for all appearance }\r\n TableIndex := FTables.IndexOf(FTables[I]);\r\n // if (TableIndex = I) or not AllFixups then\r\n begin\r\n AllFixups := True;\r\n MoveTable(TableIndex);\r\n end;\r\n { if TableIndex = I then\r\n Er := FErrorCount else\r\n FErrorCount := Er; }\r\n end;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvBDEProgress.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvDbPrgrss.PAS, released on 2002-07-04.\r\n\r\nThe Initial Developers of the Original Code are: Fedor Koshevnikov, Igor Pavluk and Serge Korolev\r\nCopyright (c) 1997, 1998 Fedor Koshevnikov, Igor Pavluk and Serge Korolev\r\nCopyright (c) 2001,2002 SGB Software\r\nAll Rights Reserved.\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvBDEProgress.pas 13075 2011-06-27 22:56:21Z jfudickar $\r\n\r\nunit JvBDEProgress;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, Classes, Controls, DB, DBTables, BDE,\r\n {$IFDEF COMPILER10_UP}\r\n DBCommonTypes,\r\n {$ENDIF COMPILER10_UP}\r\n JvTimer, JvComponentBase;\r\n\r\ntype\r\n TOnMessageChange = procedure(Sender: TObject; const Msg: string) of object;\r\n TOnPercentChange = procedure(Sender: TObject; PercentDone: Integer) of object;\r\n TOnProgressEvent = procedure(Sender: TObject; var AbortQuery: Boolean) of object;\r\n TOnTraceEvent = procedure(Sender: TObject; Flag: TTraceFlag; const Msg: string) of object;\r\n\r\n TJvDBProgress = class(TJvComponent)\r\n private\r\n FActive: Boolean;\r\n FStartTime: Longint;\r\n FTimer: TJvTimer;\r\n FWaitCursor: TCursor;\r\n FGauge: TControl;\r\n FMessageControl: TControl;\r\n FStreamedValue: Boolean;\r\n FGenProgressCallback: TObject;\r\n FQryProgressCallback: TObject;\r\n FOnMessageChange: TOnMessageChange;\r\n FOnPercentChange: TOnPercentChange;\r\n FOnProgress: TOnProgressEvent;\r\n FTraceFlags: TTraceFlags;\r\n FTraceCallback: TObject;\r\n FTrace: Boolean;\r\n FOnTrace: TOnTraceEvent;\r\n FSessionName: string;\r\n FSessionLink: TObject;\r\n procedure SetTrace(Value: Boolean);\r\n procedure SetTraceFlags(Value: TTraceFlags);\r\n function TraceCallBack(CBInfo: Pointer): CBRType;\r\n function GetDBSession: TSession;\r\n procedure SetSessionName(const Value: string);\r\n procedure Activate;\r\n procedure Deactivate;\r\n procedure FreeTimer;\r\n procedure StartTimer;\r\n procedure TimerExpired(Sender: TObject);\r\n function GenProgressCallback(CBInfo: Pointer): CBRType;\r\n function QryProgressCallback(CBInfo: Pointer): CBRType;\r\n procedure SetActive(Value: Boolean);\r\n procedure SetPercent(Value: Integer);\r\n procedure SetMessage(const Value: string);\r\n procedure SetMessageControl(Value: TControl);\r\n procedure SetGauge(Value: TControl);\r\n protected\r\n procedure Notification(AComponent: TComponent; AOperation: TOperation); override;\r\n procedure Loaded; override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n function ProgressMsgValue(const Msg: string): Longint;\r\n published\r\n property Active: Boolean read FActive write SetActive default True;\r\n property WaitCursor: TCursor read FWaitCursor write FWaitCursor default crHourGlass;\r\n property MessageControl: TControl read FMessageControl write SetMessageControl;\r\n property Gauge: TControl read FGauge write SetGauge;\r\n property SessionName: string read FSessionName write SetSessionName;\r\n property Trace: Boolean read FTrace write SetTrace default False;\r\n property TraceFlags: TTraceFlags read FTraceFlags write SetTraceFlags default [];\r\n property OnTrace: TOnTraceEvent read FOnTrace write FOnTrace;\r\n property OnMessageChange: TOnMessageChange read FOnMessageChange write FOnMessageChange;\r\n property OnPercentChange: TOnPercentChange read FOnPercentChange write FOnPercentChange;\r\n property OnProgress: TOnProgressEvent read FOnProgress write FOnProgress;\r\n end;\r\n\r\n TJvDBCallbackEvent = function(CBInfo: Pointer): CBRType of object;\r\n TJvDBCallbackChain = (dcOnlyOnce, dcChain, dcReplace);\r\n\r\n TJvDBCallback = class(TObject)\r\n private\r\n FOwner: TObject;\r\n FCBType: CBType;\r\n FCBBuf: Pointer;\r\n FCBBufLen: Cardinal;\r\n FOldCBData: Longint;\r\n FOldCBBuf: Pointer;\r\n FOldCBBufLen: Word;\r\n FOldCBFunc: Pointer;\r\n FInstalled: Boolean;\r\n FChain: TJvDBCallbackChain;\r\n FCallbackEvent: TJvDBCallbackEvent;\r\n protected\r\n function Invoke(CallType: CBType; var CBInfo: Pointer): CBRType;\r\n public\r\n constructor Create(AOwner: TObject; CBType: CBType;\r\n CBBufSize: Cardinal; CallbackEvent: TJvDBCallbackEvent;\r\n Chain: TJvDBCallbackChain);\r\n destructor Destroy; override;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvBDEProgress.pas $';\r\n Revision: '$Revision: 13075 $';\r\n Date: '$Date: 2011-06-28 00:56:21 +0200 (mar. 28 juin 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n SysUtils, Math, Forms, StdCtrls,\r\n JvProgressUtils, JvJVCLUtils;\r\n\r\nconst\r\n cbQRYPROGRESS = cbRESERVED4;\r\n\r\nfunction BdeCallBack(CallType: CBType; Data: Longint; CBInfo: Pointer): CBRType; stdcall;\r\nbegin\r\n if Data <> 0 then\r\n Result := TJvDBCallback(Data).Invoke(CallType, CBInfo)\r\n else\r\n Result := cbrUSEDEF;\r\nend;\r\n\r\n//=== { TJvDBCallback } ======================================================\r\n\r\nconstructor TJvDBCallback.Create(AOwner: TObject; CBType: CBType;\r\n CBBufSize: Cardinal; CallbackEvent: TJvDBCallbackEvent;\r\n Chain: TJvDBCallbackChain);\r\nbegin\r\n inherited Create;\r\n FOwner := AOwner;\r\n FCBType := CBType;\r\n FCallbackEvent := CallbackEvent;\r\n DbiGetCallBack(nil, FCBType, @FOldCBData, @FOldCBBufLen, @FOldCBBuf,\r\n pfDBICallBack(FOldCBFunc));\r\n FChain := Chain;\r\n if not Assigned(FOldCBFunc) then\r\n FOldCBBufLen := 0;\r\n if not Assigned(FOldCBFunc) or (FChain in [dcChain, dcReplace]) then\r\n begin\r\n FCBBufLen := Max(CBBufSize, FOldCBBufLen);\r\n FCBBuf := AllocMem(FCBBufLen);\r\n Check(DbiRegisterCallback(nil, FCBType, Longint(Self), FCBBufLen,\r\n FCBBuf, BdeCallBack));\r\n FInstalled := True;\r\n end;\r\nend;\r\n\r\ndestructor TJvDBCallback.Destroy;\r\nbegin\r\n if FInstalled then\r\n if Assigned(FOldCBFunc) and (FChain = dcChain) then\r\n try\r\n DbiRegisterCallback(nil, FCBType, FOldCBData, FOldCBBufLen,\r\n FOldCBBuf, pfDBICallBack(FOldCBFunc));\r\n except\r\n end\r\n else\r\n DbiRegisterCallback(nil, FCBType, 0, 0, nil, nil);\r\n if FCBBuf <> nil then\r\n FreeMem(FCBBuf, FCBBufLen);\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJvDBCallback.Invoke(CallType: CBType; var CBInfo: Pointer): CBRType;\r\nbegin\r\n Result := cbrUSEDEF;\r\n if CallType = FCBType then\r\n try\r\n Result := FCallbackEvent(CBInfo);\r\n except\r\n Application.HandleException(Self);\r\n end;\r\n if Assigned(FOldCBFunc) and (FChain = dcChain) then\r\n Result := pfDBICallBack(FOldCBFunc)(CallType, FOldCBData, CBInfo);\r\nend;\r\n\r\nvar\r\n ProgressList: TList = nil;\r\n\r\nprocedure SetWaitCursor;\r\nbegin\r\n if GetCurrentThreadID = MainThreadID then\r\n Screen.Cursor :=\r\n TJvDBProgress(ProgressList.Items[ProgressList.Count - 1]).WaitCursor;\r\nend;\r\n\r\nprocedure AddProgress(Progress: TJvDBProgress);\r\nbegin\r\n if ProgressList = nil then\r\n ProgressList := TList.Create;\r\n if ProgressList.IndexOf(Progress) = -1 then\r\n ProgressList.Add(Progress);\r\nend;\r\n\r\nprocedure RemoveProgress(Progress: TJvDBProgress);\r\nbegin\r\n if ProgressList <> nil then\r\n begin\r\n ProgressList.Remove(Progress);\r\n if ProgressList.Count = 0 then\r\n begin\r\n ProgressList.Free;\r\n ProgressList := nil;\r\n Screen.Cursor := crDefault;\r\n end;\r\n end;\r\nend;\r\n\r\n//=== { TJvSessionLink } =====================================================\r\n\r\ntype\r\n TJvSessionLink = class(TDatabase)\r\n private\r\n FProgress: TJvDBProgress;\r\n public\r\n destructor Destroy; override;\r\n end;\r\n\r\ndestructor TJvSessionLink.Destroy;\r\nbegin\r\n if FProgress <> nil then\r\n begin\r\n FProgress.FSessionLink := nil;\r\n FProgress.Trace := False;\r\n FProgress.Active := False;\r\n end;\r\n inherited Destroy;\r\nend;\r\n\r\n//=== { TJvDBProgress } ======================================================\r\n\r\nconstructor TJvDBProgress.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FWaitCursor := crHourGlass;\r\n FActive := True;\r\nend;\r\n\r\ndestructor TJvDBProgress.Destroy;\r\nbegin\r\n FOnTrace := nil;\r\n Trace := False;\r\n Active := False;\r\n FreeTimer;\r\n FTimer.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvDBProgress.Loaded;\r\nbegin\r\n inherited Loaded;\r\n FStreamedValue := True;\r\n try\r\n SetActive(FActive);\r\n SetTrace(FTrace);\r\n finally\r\n FStreamedValue := False;\r\n end;\r\nend;\r\n\r\nprocedure TJvDBProgress.TimerExpired(Sender: TObject);\r\nbegin\r\n FreeTimer;\r\n SetPercent(0);\r\n SetMessage('');\r\nend;\r\n\r\nprocedure TJvDBProgress.FreeTimer;\r\nbegin\r\n if FTimer <> nil then\r\n begin\r\n FTimer.Enabled := False;\r\n FStartTime := 0;\r\n end;\r\n Screen.Cursor := crDefault;\r\n SetCursor(Screen.Cursors[crDefault]); { force update cursor }\r\nend;\r\n\r\nprocedure TJvDBProgress.StartTimer;\r\nbegin\r\n if FTimer = nil then\r\n begin\r\n FTimer := TJvTimer.Create(Self);\r\n FTimer.Interval := 500;\r\n end;\r\n with FTimer do\r\n begin\r\n if not Enabled then\r\n FStartTime := GetTickCount;\r\n OnTimer := TimerExpired;\r\n Enabled := True;\r\n end;\r\nend;\r\n\r\nprocedure TJvDBProgress.SetPercent(Value: Integer);\r\nbegin\r\n if Gauge <> nil then\r\n begin\r\n SetProgressMax(Gauge, 100);\r\n SetProgressValue(Gauge, Value);\r\n end;\r\n if Assigned(FOnPercentChange) then\r\n FOnPercentChange(Self, Value);\r\nend;\r\n\r\nprocedure TJvDBProgress.SetMessage(const Value: string);\r\nbegin\r\n if MessageControl <> nil then\r\n begin\r\n TLabel(MessageControl).Caption := Value;\r\n MessageControl.Refresh;\r\n end;\r\n if Assigned(FOnMessageChange) then\r\n FOnMessageChange(Self, Value);\r\nend;\r\n\r\nprocedure TJvDBProgress.SetActive(Value: Boolean);\r\nbegin\r\n if (FActive <> Value) or FStreamedValue then\r\n begin\r\n if not (csDesigning in ComponentState) then\r\n begin\r\n if Value then\r\n AddProgress(Self)\r\n else\r\n RemoveProgress(Self);\r\n if (FGenProgressCallback = nil) and Value then\r\n begin\r\n Activate;\r\n FGenProgressCallback := TJvDBCallback.Create(Self, cbGENPROGRESS,\r\n Max(SizeOf(CBPROGRESSDesc), SizeOf(DBIPATH) + SizeOf(Integer) * 4),\r\n GenProgressCallback, dcChain);\r\n FQryProgressCallback := TJvDBCallback.Create(Self, cbQRYPROGRESS,\r\n SizeOf(DBIQryProgress), QryProgressCallback, dcChain);\r\n end\r\n else\r\n if not Value and (FGenProgressCallback <> nil) then\r\n begin\r\n Sessions.CurrentSession := GetDBSession;\r\n FGenProgressCallback.Free;\r\n FGenProgressCallback := nil;\r\n FQryProgressCallback.Free;\r\n FQryProgressCallback := nil;\r\n FreeTimer;\r\n if not Trace then\r\n Deactivate;\r\n end;\r\n end;\r\n FActive := Value;\r\n end;\r\nend;\r\n\r\nprocedure TJvDBProgress.Activate;\r\nvar\r\n S: TSession;\r\nbegin\r\n if FSessionLink = nil then\r\n begin\r\n S := Sessions.List[SessionName];\r\n S.Open;\r\n Sessions.CurrentSession := S;\r\n FSessionLink := TJvSessionLink.Create(S);\r\n try\r\n TJvSessionLink(FSessionLink).Temporary := True;\r\n TJvSessionLink(FSessionLink).KeepConnection := False;\r\n TJvSessionLink(FSessionLink).FProgress := Self;\r\n except\r\n FSessionLink.Free;\r\n FSessionLink := nil;\r\n raise;\r\n end;\r\n end\r\n else\r\n Sessions.CurrentSession := TDatabase(FSessionLink).Session;\r\nend;\r\n\r\nprocedure TJvDBProgress.Deactivate;\r\nbegin\r\n if FSessionLink <> nil then\r\n begin\r\n TJvSessionLink(FSessionLink).FProgress := nil;\r\n FSessionLink.Free;\r\n FSessionLink := nil;\r\n end;\r\nend;\r\n\r\nfunction TJvDBProgress.GetDBSession: TSession;\r\nbegin\r\n Result := Sessions.FindSession(SessionName);\r\n if Result = nil then\r\n Result := DBTables.Session;\r\nend;\r\n\r\nprocedure TJvDBProgress.SetSessionName(const Value: string);\r\nvar\r\n KeepActive, KeepTrace: Boolean;\r\nbegin\r\n if Value <> SessionName then\r\n if not (csDesigning in ComponentState) then\r\n begin\r\n KeepActive := Active;\r\n KeepTrace := Trace;\r\n Active := False;\r\n Trace := False;\r\n FSessionName := Value;\r\n Active := KeepActive;\r\n Trace := KeepTrace;\r\n end\r\n else\r\n FSessionName := Value;\r\nend;\r\n\r\nprocedure TJvDBProgress.SetTrace(Value: Boolean);\r\nbegin\r\n if (FTrace <> Value) or (FStreamedValue and Value) then\r\n if not (csDesigning in ComponentState) then\r\n begin\r\n if Value then\r\n begin\r\n Activate;\r\n GetDBSession.TraceFlags := FTraceFlags;\r\n FTraceCallback := TJvDBCallback.Create(Self, cbTRACE,\r\n smTraceBufSize, TraceCallBack, dcReplace);\r\n end\r\n else\r\n if FTraceCallback <> nil then\r\n begin\r\n Sessions.CurrentSession := GetDBSession;\r\n FTraceCallback.Free;\r\n FTraceCallback := nil;\r\n if not Active then\r\n Deactivate;\r\n end;\r\n FTrace := (FTraceCallback <> nil);\r\n end\r\n else\r\n FTrace := Value;\r\nend;\r\n\r\nprocedure TJvDBProgress.SetTraceFlags(Value: TTraceFlags);\r\nbegin\r\n FTraceFlags := Value;\r\n if Trace then\r\n GetDBSession.TraceFlags := FTraceFlags;\r\nend;\r\n\r\nfunction TJvDBProgress.TraceCallBack(CBInfo: Pointer): CBRType;\r\nvar\r\n CurFlag: TTraceFlag;\r\nbegin\r\n Result := cbrUSEDEF;\r\n if Trace and Assigned(FOnTrace) then\r\n begin\r\n case PTraceDesc(CBInfo)^.eTraceCat of\r\n traceQPREPARE:\r\n CurFlag := tfQPrepare;\r\n traceQEXECUTE:\r\n CurFlag := tfQExecute;\r\n traceERROR:\r\n CurFlag := tfError;\r\n traceSTMT:\r\n CurFlag := tfStmt;\r\n traceCONNECT:\r\n CurFlag := tfConnect;\r\n traceTRANSACT:\r\n CurFlag := tfTransact;\r\n traceBLOB:\r\n CurFlag := tfBlob;\r\n traceMISC:\r\n CurFlag := tfMisc;\r\n traceVENDOR:\r\n CurFlag := tfVendor;\r\n traceDATAIN:\r\n CurFlag := tfDataIn;\r\n traceDATAOUT:\r\n CurFlag := tfDataOut;\r\n else\r\n Exit;\r\n end;\r\n if CurFlag in TraceFlags then\r\n FOnTrace(Self, CurFlag, string(StrPas(PTraceDesc(CBInfo)^.pszTrace)));\r\n end;\r\nend;\r\n\r\nprocedure TJvDBProgress.SetMessageControl(Value: TControl);\r\nbegin\r\n ReplaceComponentReference(Self, Value, TComponent(FMessageControl));\r\nend;\r\n\r\nprocedure TJvDBProgress.SetGauge(Value: TControl);\r\nbegin\r\n ReplaceComponentReference(Self, Value, TComponent(FGauge));\r\nend;\r\n\r\nprocedure TJvDBProgress.Notification(AComponent: TComponent; AOperation: TOperation);\r\nbegin\r\n inherited Notification(AComponent, AOperation);\r\n if AOperation = opRemove then\r\n if AComponent = Gauge then\r\n Gauge := nil\r\n else\r\n if AComponent = MessageControl then\r\n MessageControl := nil;\r\nend;\r\n\r\nfunction TJvDBProgress.GenProgressCallback(CBInfo: Pointer): CBRType;\r\nvar\r\n CallInfo: pCBPROGRESSDesc;\r\n AbortOp: Boolean;\r\nbegin\r\n CallInfo := CBInfo;\r\n Result := cbrUSEDEF;\r\n StartTimer;\r\n if (FTimer <> nil) and FTimer.Enabled {and (GetTickCount > FStartTime)} then\r\n SetWaitCursor;\r\n if Assigned(FOnProgress) then\r\n begin\r\n AbortOp := False;\r\n FOnProgress(Self, AbortOp);\r\n if AbortOp then\r\n Result := cbrABORT;\r\n end;\r\n if CallInfo^.iPercentDone >= 0 then\r\n SetPercent(CallInfo^.iPercentDone)\r\n else\r\n SetMessage(string(StrPas(CallInfo^.szMsg)));\r\nend;\r\n\r\nfunction TJvDBProgress.QryProgressCallback(CBInfo: Pointer): CBRType;\r\nvar\r\n CallInfo: pDBIQryProgress;\r\n AbortOp: Boolean;\r\n PcntDone: Double;\r\nbegin\r\n CallInfo := CBInfo;\r\n Result := cbrUSEDEF;\r\n StartTimer;\r\n {if (FTimer <> nil) and FTimer.Enabled then SetWaitCursor;}\r\n if Assigned(FOnProgress) then\r\n begin\r\n AbortOp := False;\r\n FOnProgress(Self, AbortOp);\r\n if AbortOp then\r\n Result := cbrABORT;\r\n end;\r\n with CallInfo^ do\r\n PcntDone := (stepsCompleted / Max(1, stepsInQry)) *\r\n (elemCompleted / Max(1, totElemInStep));\r\n SetPercent(Round(PcntDone * 100));\r\nend;\r\n\r\nfunction TJvDBProgress.ProgressMsgValue(const Msg: string): Longint;\r\nbegin\r\n if Msg <> '' then\r\n Result := StrToIntDef(Trim(Copy(Msg, Pos(':', Msg) + 1, MaxInt)), -1)\r\n else\r\n Result := -1;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvBDEQBE.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvDBQBE.PAS, released on 2002-07-04.\r\n\r\nThe Initial Developers of the Original Code are: Fedor Koshevnikov, Igor Pavluk and Serge Korolev\r\nCopyright (c) 1997, 1998 Fedor Koshevnikov, Igor Pavluk and Serge Korolev\r\nCopyright (c) 2001,2002 SGB Software\r\nAll Rights Reserved.\r\n\r\nAdditional credits and thanks goto AO ROSNO and\r\nMaster-Bank for there additions to this unit\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvBDEQBE.pas 13075 2011-06-27 22:56:21Z jfudickar $\r\n\r\nunit JvBDEQBE;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Classes, DB, DBTables, BDE;\r\n\r\nconst\r\n DefQBEStartParam = '#';\r\n\r\ntype\r\n TCheckType = (ctNone, ctCheck, ctCheckPlus, ctCheckDesc, ctCheckGroup);\r\n\r\n TJvQBEQuery = class(TDBDataSet)\r\n private\r\n FStmtHandle: HDBIStmt;\r\n FQBE: TStringList;\r\n FPrepared: Boolean;\r\n FParams: TParams;\r\n FStartParam: Char;\r\n FAuxiliaryTables: Boolean;\r\n FText: string;\r\n FRowsAffected: Integer;\r\n FConstrained: Boolean;\r\n FLocal: Boolean;\r\n FRequestLive: Boolean;\r\n FBlankAsZero: Boolean;\r\n FParamCheck: Boolean;\r\n function CreateCursor(GenHandle: Boolean): HDBICur;\r\n procedure ReplaceParams(QBEText: TStrings);\r\n procedure CreateParams(List: TParams; const Value: PChar);\r\n procedure FreeStatement;\r\n function GetQBE: TStrings;\r\n function GetQueryCursor(GenHandle: Boolean): HDBICur;\r\n procedure GetStatementHandle(QBEText: PAnsiChar);\r\n procedure PrepareQBE(Value: PAnsiChar);\r\n procedure QueryChanged(Sender: TObject);\r\n procedure SetQBE(Value: TStrings);\r\n procedure SetParams(Value: TParams);\r\n procedure SetPrepared(Value: Boolean);\r\n procedure SetPrepare(Value: Boolean);\r\n procedure SetStartParam(Value: Char);\r\n procedure ReadParamData(Reader: TReader);\r\n procedure WriteParamData(Writer: TWriter);\r\n function GetRowsAffected: Integer;\r\n protected\r\n { IProviderSupport }\r\n procedure PSExecute; override;\r\n function PSGetParams: TParams; override;\r\n procedure PSSetCommandText(const CommandText: string); override;\r\n procedure PSSetParams(AParams: TParams); override;\r\n function CreateHandle: HDBICur; override;\r\n procedure Disconnect; override;\r\n function GetParamsCount: Word;\r\n procedure DefineProperties(Filer: TFiler); override;\r\n function SetDBFlag(Flag: Integer; Value: Boolean): Boolean; override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n function GetQBEText: PChar;\r\n procedure ExecQBE;\r\n function ParamByName(const Value: string): TParam;\r\n procedure Prepare;\r\n procedure RefreshQuery;\r\n procedure UnPrepare;\r\n property Local: Boolean read FLocal;\r\n property ParamCount: Word read GetParamsCount;\r\n property Prepared: Boolean read FPrepared write SetPrepare;\r\n property StmtHandle: HDBIStmt read FStmtHandle;\r\n property Text: string read FText;\r\n property RowsAffected: Integer read GetRowsAffected;\r\n published\r\n property AutoRefresh;\r\n property AuxiliaryTables: Boolean read FAuxiliaryTables write FAuxiliaryTables default True;\r\n property ParamCheck: Boolean read FParamCheck write FParamCheck default True;\r\n property StartParam: Char read FStartParam write SetStartParam default DefQBEStartParam;\r\n { Ensure StartParam is declared before QBE }\r\n property QBE: TStrings read GetQBE write SetQBE;\r\n { Ensure QBE is declared before Params }\r\n property BlankAsZero: Boolean read FBlankAsZero write FBlankAsZero default False;\r\n property Params: TParams read FParams write SetParams stored False;\r\n property RequestLive: Boolean read FRequestLive write FRequestLive default False;\r\n property UpdateMode;\r\n property UpdateObject;\r\n property Constrained: Boolean read FConstrained write FConstrained default False;\r\n property Constraints stored ConstraintsStored;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvBDEQBE.pas $';\r\n Revision: '$Revision: 13075 $';\r\n Date: '$Date: 2011-06-28 00:56:21 +0200 (mar. 28 juin 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n SysUtils, DBConsts, bdeconst,\r\n JvDBUtils;\r\n\r\nconstructor TJvQBEQuery.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FQBE := TStringList.Create;\r\n FQBE.OnChange := QueryChanged;\r\n FParams := TParams.Create(Self);\r\n FStartParam := DefQBEStartParam;\r\n FParamCheck := True;\r\n FAuxiliaryTables := True;\r\n FRowsAffected := -1;\r\n FRequestLive := False;\r\nend;\r\n\r\ndestructor TJvQBEQuery.Destroy;\r\nbegin\r\n Destroying;\r\n Disconnect;\r\n FQBE.Free;\r\n FParams.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvQBEQuery.Disconnect;\r\nbegin\r\n Close;\r\n UnPrepare;\r\nend;\r\n\r\nprocedure TJvQBEQuery.RefreshQuery;\r\nvar\r\n Bookmark: TBookmark;\r\nbegin\r\n DisableControls;\r\n Bookmark := GetBookmark;\r\n try\r\n Close;\r\n Open;\r\n try\r\n GotoBookmark(Bookmark);\r\n except\r\n { ignore exceptions }\r\n end;\r\n finally\r\n FreeBookmark(Bookmark);\r\n EnableControls;\r\n end;\r\nend;\r\n\r\nprocedure TJvQBEQuery.SetPrepare(Value: Boolean);\r\nbegin\r\n if Value then\r\n Prepare\r\n else\r\n UnPrepare;\r\nend;\r\n\r\nprocedure TJvQBEQuery.Prepare;\r\nbegin\r\n SetDBFlag(dbfPrepared, True);\r\n SetPrepared(True);\r\nend;\r\n\r\nprocedure TJvQBEQuery.UnPrepare;\r\nbegin\r\n SetPrepared(False);\r\n SetDBFlag(dbfPrepared, False);\r\nend;\r\n\r\nprocedure TJvQBEQuery.SetStartParam(Value: Char);\r\nbegin\r\n if Value <> FStartParam then\r\n begin\r\n FStartParam := Value;\r\n QueryChanged(nil);\r\n end;\r\nend;\r\n\r\nfunction TJvQBEQuery.GetQBE: TStrings;\r\nbegin\r\n Result := FQBE;\r\nend;\r\n\r\nprocedure TJvQBEQuery.SetQBE(Value: TStrings);\r\nbegin\r\n if FQBE.Text <> Value.Text then\r\n begin\r\n Disconnect;\r\n FQBE.OnChange := nil;\r\n FQBE.Assign(Value);\r\n FQBE.OnChange := QueryChanged;\r\n QueryChanged(nil);\r\n end;\r\nend;\r\n\r\nprocedure TJvQBEQuery.QueryChanged(Sender: TObject);\r\nvar\r\n List: TParams;\r\nbegin\r\n if not (csReading in ComponentState) then\r\n begin\r\n Disconnect;\r\n FText := QBE.Text;\r\n if ParamCheck or (csDesigning in ComponentState) then\r\n begin\r\n List := TParams.Create(Self);\r\n try\r\n CreateParams(List, PChar(Text));\r\n List.AssignValues(FParams);\r\n FParams.Clear;\r\n FParams.Assign(List);\r\n finally\r\n List.Free;\r\n end;\r\n end;\r\n DataEvent(dePropertyChange, 0);\r\n end\r\n else\r\n begin\r\n FText := QBE.Text;\r\n FParams.Clear;\r\n CreateParams(FParams, PChar(Text));\r\n end;\r\nend;\r\n\r\nprocedure TJvQBEQuery.SetParams(Value: TParams);\r\nbegin\r\n FParams.AssignValues(Value);\r\nend;\r\n\r\nprocedure TJvQBEQuery.DefineProperties(Filer: TFiler);\r\nbegin\r\n inherited DefineProperties(Filer);\r\n Filer.DefineProperty('ParamData', ReadParamData, WriteParamData, True);\r\nend;\r\n\r\nprocedure TJvQBEQuery.ReadParamData(Reader: TReader);\r\nbegin\r\n Reader.ReadValue;\r\n Reader.ReadCollection(FParams);\r\nend;\r\n\r\nprocedure TJvQBEQuery.WriteParamData(Writer: TWriter);\r\nbegin\r\n Writer.WriteCollection(Params);\r\nend;\r\n\r\nfunction TJvQBEQuery.GetParamsCount: Word;\r\nbegin\r\n Result := FParams.Count;\r\nend;\r\n\r\nprocedure TJvQBEQuery.ReplaceParams(QBEText: TStrings);\r\nvar\r\n I: Integer;\r\n\r\n function ReplaceString(const S: string): string;\r\n var\r\n I, J, P, LiteralChars: Integer;\r\n Param: TParam;\r\n Temp: string;\r\n Found: Boolean;\r\n begin\r\n Result := S;\r\n for I := Params.Count - 1 downto 0 do\r\n begin\r\n Param := Params[I];\r\n if Param.DataType = ftUnknown then\r\n Continue; { ignore undefined params }\r\n repeat\r\n P := Pos(StartParam + Param.Name, Result);\r\n Found := (P > 0) and ((Length(Result) = P + Length(Param.Name)) or\r\n NameDelimiter(Result[P + Length(Param.Name) + 1]));\r\n if Found then\r\n begin\r\n LiteralChars := 0;\r\n for J := 1 to P - 1 do\r\n if IsLiteral(Result[J]) then\r\n Inc(LiteralChars);\r\n Found := LiteralChars mod 2 = 0;\r\n if Found then\r\n begin\r\n Temp := Param.Text;\r\n if Temp = '' then\r\n begin\r\n if (Param.DataType = ftString) and not Param.IsNull then\r\n Temp := '\"\"'\r\n else\r\n Temp := 'BLANK'; { special QBE operator }\r\n end;\r\n Result := Copy(Result, 1, P - 1) + Temp + Copy(Result,\r\n P + Length(Param.Name) + 1, MaxInt);\r\n end;\r\n end;\r\n until not Found;\r\n end;\r\n end;\r\n\r\nbegin\r\n QBEText.BeginUpdate;\r\n try\r\n for I := 0 to QBEText.Count - 1 do\r\n QBEText[I] := ReplaceString(QBEText[I]);\r\n finally\r\n QBEText.EndUpdate;\r\n end;\r\nend;\r\n\r\nprocedure TJvQBEQuery.SetPrepared(Value: Boolean);\r\nvar\r\n TempQBE: TStrings;\r\n AText: PAnsiChar;\r\nbegin\r\n if Handle <> nil then\r\n _DBError(SDataSetOpen);\r\n if (Value <> Prepared) or (ParamCount > 0) then\r\n begin\r\n if Value then\r\n begin\r\n FRowsAffected := -1;\r\n if ParamCount > 0 then\r\n begin\r\n TempQBE := TStringList.Create;\r\n try\r\n TempQBE.Assign(QBE);\r\n ReplaceParams(TempQBE);\r\n AText := PAnsiChar(AnsiString(TempQBE.Text));\r\n try\r\n FreeStatement;\r\n if StrLen(AText) > 1 then\r\n PrepareQBE(AText)\r\n else\r\n _DBError(SEmptySQLStatement);\r\n finally\r\n end;\r\n finally\r\n TempQBE.Free;\r\n end;\r\n end\r\n else\r\n begin\r\n if StrLen(PChar(Text)) > 1 then\r\n PrepareQBE(PAnsiChar(AnsiString(Text)))\r\n else\r\n _DBError(SEmptySQLStatement);\r\n end;\r\n end\r\n else\r\n begin\r\n FRowsAffected := RowsAffected;\r\n FreeStatement;\r\n end;\r\n FPrepared := Value;\r\n end;\r\nend;\r\n\r\nprocedure TJvQBEQuery.FreeStatement;\r\nbegin\r\n if StmtHandle <> nil then\r\n begin\r\n DbiQFree(FStmtHandle);\r\n FStmtHandle := nil;\r\n end;\r\nend;\r\n\r\nfunction TJvQBEQuery.ParamByName(const Value: string): TParam;\r\nbegin\r\n Result := FParams.ParamByName(Value);\r\nend;\r\n\r\nprocedure TJvQBEQuery.CreateParams(List: TParams; const Value: PChar);\r\nvar\r\n CurPos, StartPos: PChar;\r\n CurChar: Char;\r\n Literal: Boolean;\r\n EmbeddedLiteral: Boolean;\r\n Name: string;\r\n\r\n function StripLiterals(Buffer: PChar): string;\r\n var\r\n Len: Word;\r\n TempBuf: PChar;\r\n\r\n procedure StripChar(Value: Char);\r\n begin\r\n if TempBuf^ = Value then\r\n StrMove(TempBuf, TempBuf + 1, Len - 1);\r\n if TempBuf[StrLen(TempBuf) - 1] = Value then\r\n TempBuf[StrLen(TempBuf) - 1] := #0;\r\n end;\r\n\r\n begin\r\n Len := StrLen(Buffer) + 1;\r\n TempBuf := AllocMem(Len);\r\n Result := '';\r\n try\r\n StrCopy(TempBuf, Buffer);\r\n StripChar('''');\r\n StripChar('\"');\r\n Result := StrPas(TempBuf);\r\n finally\r\n FreeMem(TempBuf, Len);\r\n end;\r\n end;\r\n\r\nbegin\r\n CurPos := Value;\r\n Literal := False;\r\n EmbeddedLiteral := False;\r\n repeat\r\n CurChar := CurPos^;\r\n if (CurChar = FStartParam) and not Literal and\r\n ((CurPos + 1)^ <> FStartParam) then\r\n begin\r\n StartPos := CurPos;\r\n while (CurChar <> #0) and (Literal or not NameDelimiter(CurChar)) do\r\n begin\r\n Inc(CurPos);\r\n CurChar := CurPos^;\r\n if IsLiteral(CurChar) then\r\n begin\r\n Literal := Literal xor True;\r\n if CurPos = StartPos + 1 then\r\n EmbeddedLiteral := True;\r\n end;\r\n end;\r\n CurPos^ := #0;\r\n if EmbeddedLiteral then\r\n begin\r\n Name := StripLiterals(StartPos + 1);\r\n EmbeddedLiteral := False;\r\n end\r\n else\r\n Name := StrPas(StartPos + 1);\r\n if List.FindParam(Name) = nil then\r\n List.CreateParam(ftUnknown, Name, ptUnknown);\r\n CurPos^ := CurChar;\r\n StartPos^ := '?';\r\n Inc(StartPos);\r\n StrMove(StartPos, CurPos, StrLen(CurPos) + 1);\r\n CurPos := StartPos;\r\n end\r\n else\r\n if (CurChar = FStartParam) and not Literal and\r\n ((CurPos + 1)^ = FStartParam) then\r\n StrMove(CurPos, CurPos + 1, StrLen(CurPos) + 1)\r\n else\r\n if IsLiteral(CurChar) then\r\n Literal := Literal xor True;\r\n Inc(CurPos);\r\n until CurChar = #0;\r\nend;\r\n\r\nfunction TJvQBEQuery.CreateCursor(GenHandle: Boolean): HDBICur;\r\nbegin\r\n if QBE.Count > 0 then\r\n begin\r\n SetPrepared(True);\r\n Result := GetQueryCursor(GenHandle);\r\n end\r\n else\r\n Result := nil;\r\nend;\r\n\r\nfunction TJvQBEQuery.CreateHandle: HDBICur;\r\nbegin\r\n Result := CreateCursor(True)\r\nend;\r\n\r\nprocedure TJvQBEQuery.ExecQBE;\r\nbegin\r\n CheckInActive;\r\n SetDBFlag(dbfExecSQL, True);\r\n try\r\n CreateCursor(False);\r\n finally\r\n SetDBFlag(dbfExecSQL, False);\r\n end;\r\nend;\r\n\r\nfunction TJvQBEQuery.GetQueryCursor(GenHandle: Boolean): HDBICur;\r\nvar\r\n PCursor: phDBICur;\r\nbegin\r\n Result := nil;\r\n if GenHandle then\r\n PCursor := @Result\r\n else\r\n PCursor := nil;\r\n Check(DbiQExec(StmtHandle, PCursor));\r\nend;\r\n\r\nfunction TJvQBEQuery.SetDBFlag(Flag: Integer; Value: Boolean): Boolean;\r\nvar\r\n NewConnection: Boolean;\r\nbegin\r\n if Value then\r\n begin\r\n NewConnection := DBFlags = [];\r\n Result := inherited SetDBFlag(Flag, Value);\r\n if not (csReading in ComponentState) and NewConnection then\r\n FLocal := not Database.IsSQLBased;\r\n end\r\n else\r\n begin\r\n if DBFlags - [Flag] = [] then\r\n SetPrepared(False);\r\n Result := inherited SetDBFlag(Flag, Value);\r\n end;\r\nend;\r\n\r\nprocedure TJvQBEQuery.PrepareQBE(Value: PAnsiChar);\r\nbegin\r\n GetStatementHandle(Value);\r\nend;\r\n\r\nprocedure TJvQBEQuery.GetStatementHandle(QBEText: PAnsiChar);\r\nconst\r\n DataType: array [Boolean] of Longint = (Ord(wantCanned), Ord(wantLive));\r\nbegin\r\n Check(DbiQAlloc(DBHandle, qrylangQBE, FStmtHandle));\r\n try\r\n Check(DbiSetProp(hDBIObj(StmtHandle), stmtLIVENESS,\r\n DataType[RequestLive and not ForceUpdateCallback]));\r\n Check(DbiSetProp(hDBIObj(StmtHandle), stmtAUXTBLS, Longint(FAuxiliaryTables)));\r\n if Local and RequestLive and Constrained then\r\n Check(DbiSetProp(hDBIObj(StmtHandle), stmtCONSTRAINED, Ord(True)));\r\n if FBlankAsZero then\r\n Check(DbiSetProp(hDBIObj(StmtHandle), stmtBLANKS, Ord(True)));\r\n while not CheckOpen(DbiQPrepare(FStmtHandle, QBEText)) do {Retry}\r\n ;\r\n except\r\n DbiQFree(FStmtHandle);\r\n FStmtHandle := nil;\r\n raise;\r\n end;\r\nend;\r\n\r\nfunction TJvQBEQuery.GetQBEText: PChar;\r\nvar\r\n BufLen: Word;\r\n I: Integer;\r\n StrEnd: PChar;\r\n StrBuf: array [0..255] of Char;\r\nbegin\r\n BufLen := 1;\r\n for I := 0 to QBE.Count - 1 do\r\n Inc(BufLen, Length(QBE.Strings[I]) + 1);\r\n Result := StrAlloc(BufLen);\r\n try\r\n StrEnd := Result;\r\n for I := 0 to QBE.Count - 1 do\r\n begin\r\n StrPCopy(StrBuf, QBE.Strings[I]);\r\n StrEnd := StrECopy(StrEnd, StrBuf);\r\n StrEnd := StrECopy(StrEnd, ' ');\r\n end;\r\n except\r\n StrDispose(Result);\r\n raise;\r\n end;\r\nend;\r\n\r\nfunction TJvQBEQuery.GetRowsAffected: Integer;\r\nvar\r\n Length: Word;\r\nbegin\r\n if Prepared then\r\n begin\r\n if DbiGetProp(hDBIObj(StmtHandle), stmtROWCOUNT, @Result, SizeOf(Result),\r\n Length) <> 0 then\r\n Result := -1;\r\n end\r\n else\r\n Result := FRowsAffected;\r\nend;\r\n\r\n{ TJvQBEQuery.IProviderSupport }\r\n\r\nfunction TJvQBEQuery.PSGetParams: TParams;\r\nbegin\r\n Result := Params;\r\nend;\r\n\r\nprocedure TJvQBEQuery.PSSetParams(AParams: TParams);\r\nbegin\r\n if AParams.Count <> 0 then\r\n Params.Assign(AParams);\r\n Close;\r\nend;\r\n\r\nprocedure TJvQBEQuery.PSExecute;\r\nbegin\r\n ExecQBE;\r\nend;\r\n\r\nprocedure TJvQBEQuery.PSSetCommandText(const CommandText: string);\r\nbegin\r\n if CommandText <> '' then\r\n QBE.Text := CommandText;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvBDEQuery.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvQuery.PAS, released on 2002-07-04.\r\n\r\nThe Initial Developers of the Original Code are: Fedor Koshevnikov, Igor Pavluk and Serge Korolev\r\nCopyright (c) 1997, 1998 Fedor Koshevnikov, Igor Pavluk and Serge Korolev\r\nCopyright (c) 2001,2002 SGB Software\r\nAll Rights Reserved.\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvBDEQuery.pas 13415 2012-09-10 09:51:54Z obones $\r\n\r\nunit JvBDEQuery;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n SysUtils, Classes, DB, DBTables, BDE,\r\n JvComponentBase, JVCLVer, JvTypes;\r\n\r\nconst\r\n DefaultMacroChar = '%';\r\n DefaultTermChar = '/';\r\n\r\ntype\r\n TQueryOpenStatus = (qsOpened, qsExecuted, qsFailed);\r\n\r\n {$IFDEF COMPILER12_UP}\r\n TJvRecordBuffer = TRecordBuffer; // Delphi 2009\r\n {$ELSE}\r\n TJvRecordBuffer = PAnsiChar;\r\n {$ENDIF COMPILER12_UP}\r\n \r\n TJvQuery = class(TQuery)\r\n private\r\n FAboutJVCL: TJVCLAboutInfo;\r\n FDisconnectExpected: Boolean;\r\n FSaveQueryChanged: TNotifyEvent;\r\n FMacroChar: Char;\r\n FMacros: TParams;\r\n FSQL: TStringList;\r\n FStreamPatternChanged: Boolean;\r\n FPatternChanged: Boolean;\r\n FOpenStatus: TQueryOpenStatus;\r\n function GetMacros: TParams;\r\n procedure SetMacros(Value: TParams);\r\n function GetSQL: TStrings;\r\n procedure SetSQL(Value: TStrings);\r\n procedure PatternChanged(Sender: TObject);\r\n procedure QueryChanged(Sender: TObject);\r\n procedure RecreateMacros;\r\n procedure CreateMacros(List: TParams; const Value: PChar);\r\n procedure Expand(Query: TStrings);\r\n function GetMacroCount: Word;\r\n procedure SetMacroChar(Value: Char);\r\n function GetRealSQL: TStrings;\r\n protected\r\n procedure InternalFirst; override;\r\n function GetRecord(Buffer: TJvRecordBuffer; GetMode: TGetMode; DoCheck: Boolean): TGetResult; override;\r\n procedure Loaded; override;\r\n function CreateHandle: HDBICur; override;\r\n procedure OpenCursor(InfoQuery: Boolean); override;\r\n procedure Disconnect; override;\r\n { IProviderSupport }\r\n procedure PSExecute; override;\r\n function PSGetDefaultOrder: TIndexDef; override;\r\n function PSGetTableName: string; override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n procedure ExpandMacros;\r\n procedure ExecSQL;\r\n procedure Prepare;\r\n procedure OpenOrExec(ChangeLive: Boolean);\r\n procedure ExecDirect;\r\n function MacroByName(const Value: string): TParam;\r\n property MacroCount: Word read GetMacroCount;\r\n property OpenStatus: TQueryOpenStatus read FOpenStatus;\r\n property RealSQL: TStrings read GetRealSQL;\r\n published\r\n property AboutJVCL: TJVCLAboutInfo read FAboutJVCL write FAboutJVCL stored False;\r\n property MacroChar: Char read FMacroChar write SetMacroChar default DefaultMacroChar;\r\n property SQL: TStrings read GetSQL write SetSQL;\r\n property Macros: TParams read GetMacros write SetMacros;\r\n end;\r\n\r\n TRunQueryMode = (rqOpen, rqExecute, rqExecDirect, rqOpenOrExec);\r\n\r\n TJvQueryThread = class(TJvCustomThread)\r\n private\r\n FData: TBDEDataSet;\r\n FMode: TRunQueryMode;\r\n FPrepare: Boolean;\r\n FException: TObject;\r\n procedure DoHandleException;\r\n protected\r\n procedure ModeError; virtual;\r\n procedure DoTerminate; override;\r\n procedure Execute; override;\r\n procedure HandleException; virtual;\r\n public\r\n constructor Create(Data: TBDEDataSet; RunMode: TRunQueryMode;\r\n Prepare, CreateSuspended: Boolean);\r\n end;\r\n\r\n TScriptAction = (saFail, saAbort, saRetry, saIgnore, saContinue);\r\n\r\n TScriptErrorEvent = procedure(Sender: TObject; E: EDatabaseError;\r\n LineNo, StatementNo: Integer; var Action: TScriptAction) of object;\r\n\r\n TJvSQLScript = class(TJvComponent)\r\n private\r\n FSQL: TStringList;\r\n FParams: TParams;\r\n FQuery: TJvQuery;\r\n FTransaction: Boolean;\r\n FSemicolonTerm: Boolean;\r\n FIgnoreParams: Boolean;\r\n FTerm: Char;\r\n FBeforeExec: TNotifyEvent;\r\n FAfterExec: TNotifyEvent;\r\n FOnScriptError: TScriptErrorEvent;\r\n function GetSessionName: string;\r\n procedure SetSessionName(const Value: string);\r\n function GetDBSession: TSession;\r\n function GetText: string;\r\n procedure ReadParamData(Reader: TReader);\r\n procedure WriteParamData(Writer: TWriter);\r\n function GetDatabase: TDatabase;\r\n function GetDatabaseName: string;\r\n procedure SetDatabaseName(const Value: string);\r\n procedure CreateParams(List: TParams; const Value: PChar);\r\n procedure QueryChanged(Sender: TObject);\r\n function GetSQL: TStrings;\r\n procedure SetSQL(Value: TStrings);\r\n procedure SetParamsList(Value: TParams);\r\n function GetParamsCount: Cardinal;\r\n protected\r\n procedure DefineProperties(Filer: TFiler); override;\r\n procedure CheckExecQuery(LineNo, StatementNo: Integer);\r\n procedure ExecuteScript(StatementNo: Integer); virtual;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n procedure ExecSQL;\r\n procedure ExecStatement(StatementNo: Integer);\r\n function ParamByName(const Value: string): TParam;\r\n property DBSession: TSession read GetDBSession;\r\n property Text: string read GetText;\r\n property Database: TDatabase read GetDatabase;\r\n property ParamCount: Cardinal read GetParamsCount;\r\n published\r\n property DatabaseName: string read GetDatabaseName write SetDatabaseName;\r\n property IgnoreParams: Boolean read FIgnoreParams write FIgnoreParams default False;\r\n property SemicolonTerm: Boolean read FSemicolonTerm write FSemicolonTerm default True;\r\n property SessionName: string read GetSessionName write SetSessionName;\r\n property Term: Char read FTerm write FTerm default DefaultTermChar;\r\n property SQL: TStrings read GetSQL write SetSQL;\r\n property Params: TParams read FParams write SetParamsList stored False;\r\n property Transaction: Boolean read FTransaction write FTransaction;\r\n property BeforeExec: TNotifyEvent read FBeforeExec write FBeforeExec;\r\n property AfterExec: TNotifyEvent read FAfterExec write FAfterExec;\r\n property OnScriptError: TScriptErrorEvent read FOnScriptError write FOnScriptError;\r\n end;\r\n\r\nconst\r\n dbfExecScript = dbfTable;\r\n\r\nprocedure CreateQueryParams(List: TParams; const Value: PChar; Macro: Boolean;\r\n SpecialChar: Char; Delims: TSysCharSet);\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvBDEQuery.pas $';\r\n Revision: '$Revision: 13415 $';\r\n Date: '$Date: 2012-09-10 11:51:54 +0200 (lun. 10 sept. 2012) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n RTLConsts, Forms, Consts, bdeconst,\r\n {$IFNDEF COMPILER12_UP}\r\n JvJCLUtils,\r\n {$ENDIF ~COMPILER12_UP}\r\n JvDBUtils, JvBdeUtils;\r\n\r\n{ Parse SQL utility routines }\r\n\r\nfunction NameDelimiters(C: Char; Delims: TSysCharSet): Boolean;\r\nbegin\r\n Result := NameDelimiter(C) or CharInSet(C, Delims);\r\nend;\r\n\r\nprocedure CreateQueryParams(List: TParams; const Value: PChar; Macro: Boolean;\r\n SpecialChar: Char; Delims: TSysCharSet);\r\nvar\r\n CurPos, StartPos: PChar;\r\n CurChar: Char;\r\n Literal: Boolean;\r\n EmbeddedLiteral: Boolean;\r\n Name: string;\r\n\r\n function StripLiterals(Buffer: PChar): string;\r\n var\r\n Len: Word;\r\n TempBuf: PChar;\r\n\r\n procedure StripChar(Value: Char);\r\n begin\r\n if TempBuf^ = Value then\r\n StrMove(TempBuf, TempBuf + 1, Len - 1);\r\n if TempBuf[StrLen(TempBuf) - 1] = Value then\r\n TempBuf[StrLen(TempBuf) - 1] := #0;\r\n end;\r\n\r\n begin\r\n Len := StrLen(Buffer) + 1;\r\n TempBuf := AllocMem(Len);\r\n Result := '';\r\n try\r\n StrCopy(TempBuf, Buffer);\r\n StripChar('''');\r\n StripChar('\"');\r\n Result := StrPas(TempBuf);\r\n finally\r\n FreeMem(TempBuf, Len);\r\n end;\r\n end;\r\n\r\nbegin\r\n if SpecialChar = #0 then\r\n Exit;\r\n CurPos := Value;\r\n Literal := False;\r\n EmbeddedLiteral := False;\r\n repeat\r\n CurChar := CurPos^;\r\n if (CurChar = SpecialChar) and not Literal and ((CurPos + 1)^ <> SpecialChar) then\r\n begin\r\n StartPos := CurPos;\r\n while (CurChar <> #0) and (Literal or not NameDelimiters(CurChar, Delims)) do\r\n begin\r\n Inc(CurPos);\r\n CurChar := CurPos^;\r\n if IsLiteral(CurChar) then\r\n begin\r\n Literal := Literal xor True;\r\n if CurPos = StartPos + 1 then\r\n EmbeddedLiteral := True;\r\n end;\r\n end;\r\n CurPos^ := #0;\r\n if EmbeddedLiteral then\r\n begin\r\n Name := StripLiterals(StartPos + 1);\r\n EmbeddedLiteral := False;\r\n end\r\n else\r\n Name := StrPas(StartPos + 1);\r\n if Assigned(List) then\r\n begin\r\n if List.FindParam(Name) = nil then\r\n begin\r\n if Macro then\r\n List.CreateParam(ftString, Name, ptInput).AsString := TrueExpr\r\n else\r\n List.CreateParam(ftUnknown, Name, ptUnknown);\r\n end;\r\n end;\r\n CurPos^ := CurChar;\r\n StartPos^ := '?';\r\n Inc(StartPos);\r\n StrMove(StartPos, CurPos, StrLen(CurPos) + 1);\r\n CurPos := StartPos;\r\n end\r\n else\r\n if (CurChar = SpecialChar) and not Literal and ((CurPos + 1)^ = SpecialChar) then\r\n StrMove(CurPos, CurPos + 1, StrLen(CurPos) + 1)\r\n else\r\n if IsLiteral(CurChar) then\r\n Literal := Literal xor True;\r\n Inc(CurPos);\r\n until CurChar = #0;\r\nend;\r\n\r\n//=== { TJvQuery } ===========================================================\r\n\r\nconstructor TJvQuery.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FOpenStatus := qsFailed;\r\n FSaveQueryChanged := TStringList(inherited SQL).OnChange;\r\n TStringList(inherited SQL).OnChange := QueryChanged;\r\n FMacroChar := DefaultMacroChar;\r\n FSQL := TStringList.Create;\r\n FSQL.OnChange := PatternChanged;\r\n FMacros := TParams.Create(Self);\r\nend;\r\n\r\ndestructor TJvQuery.Destroy;\r\nbegin\r\n Destroying;\r\n Disconnect;\r\n FMacros.Free;\r\n FSQL.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvQuery.Loaded;\r\nbegin\r\n inherited Loaded;\r\n GetMacros; {!! trying this way}\r\nend;\r\n\r\nprocedure TJvQuery.InternalFirst;\r\nbegin\r\n if not (UniDirectional and BOF) then\r\n inherited InternalFirst;\r\nend;\r\n\r\nfunction TJvQuery.GetRecord(Buffer: TJvRecordBuffer; GetMode: TGetMode;\r\n DoCheck: Boolean): TGetResult;\r\nbegin\r\n //!!!!!!\r\n if UniDirectional and (GetMode in [gmPrior, gmNext]) then\r\n DoCheck := False;\r\n Result := inherited GetRecord(Buffer, GetMode, DoCheck);\r\nend;\r\n\r\nfunction TJvQuery.CreateHandle: HDBICur;\r\nbegin\r\n FOpenStatus := qsFailed;\r\n Result := inherited CreateHandle;\r\n if Result = nil then\r\n FOpenStatus := qsExecuted\r\n else\r\n FOpenStatus := qsOpened;\r\nend;\r\n\r\nprocedure TJvQuery.OpenCursor;\r\nbegin\r\n ExpandMacros;\r\n inherited OpenCursor(InfoQuery);\r\nend;\r\n\r\nprocedure TJvQuery.ExecSQL;\r\nbegin\r\n ExpandMacros;\r\n inherited ExecSQL;\r\nend;\r\n\r\nprocedure TJvQuery.Prepare;\r\nbegin\r\n ExpandMacros;\r\n inherited Prepare;\r\nend;\r\n\r\nprocedure TJvQuery.OpenOrExec(ChangeLive: Boolean);\r\n\r\n procedure TryOpen;\r\n begin\r\n try\r\n Open;\r\n except\r\n if OpenStatus <> qsExecuted then\r\n raise;\r\n end;\r\n end;\r\n\r\nbegin\r\n try\r\n TryOpen;\r\n except\r\n on E: EDatabaseError do\r\n if RequestLive and ChangeLive then\r\n begin\r\n RequestLive := False;\r\n try\r\n TryOpen;\r\n except\r\n on E: EDatabaseError do\r\n if OpenStatus <> qsOpened then\r\n ExecDirect\r\n else\r\n begin\r\n FOpenStatus := qsFailed;\r\n raise;\r\n end;\r\n else\r\n raise;\r\n end;\r\n end\r\n else\r\n begin\r\n if OpenStatus <> qsOpened then\r\n ExecDirect\r\n else\r\n begin\r\n FOpenStatus := qsFailed;\r\n raise;\r\n end;\r\n end;\r\n else\r\n raise;\r\n end;\r\nend;\r\n\r\nprocedure TJvQuery.ExecDirect;\r\nbegin\r\n CheckInactive;\r\n SetDBFlag(dbfExecSQL, True);\r\n try\r\n if SQL.Count > 0 then\r\n begin\r\n FOpenStatus := qsFailed;\r\n Check(DbiQExecDirect(DBHandle, qryLangSQL, PAnsiChar(AnsiString(inherited SQL.Text)),\r\n nil));\r\n FOpenStatus := qsExecuted;\r\n end\r\n else\r\n _DBError(SEmptySQLStatement);\r\n finally\r\n SetDBFlag(dbfExecSQL, False);\r\n end;\r\nend;\r\n\r\nprocedure TJvQuery.Disconnect;\r\nvar\r\n Strings: TStrings;\r\n Event1, Event2: TNotifyEvent;\r\nbegin\r\n inherited Disconnect;\r\n if csDestroying in ComponentState then\r\n Exit;\r\n Strings := inherited SQL;\r\n Event1 := TStringList(Strings).OnChange;\r\n Event2 := QueryChanged;\r\n if @Event1 <> @Event2 then\r\n begin\r\n if not FDisconnectExpected then\r\n SQL := inherited SQL;\r\n TStringList(inherited SQL).OnChange := QueryChanged;\r\n end;\r\nend;\r\n\r\nprocedure TJvQuery.SetMacroChar(Value: Char);\r\nbegin\r\n if Value <> FMacroChar then\r\n begin\r\n FMacroChar := Value;\r\n RecreateMacros;\r\n end;\r\nend;\r\n\r\nfunction TJvQuery.GetMacros: TParams;\r\nbegin\r\n if FStreamPatternChanged then\r\n begin\r\n FStreamPatternChanged := False;\r\n PatternChanged(nil);\r\n end;\r\n Result := FMacros;\r\nend;\r\n\r\nprocedure TJvQuery.SetMacros(Value: TParams);\r\nbegin\r\n FMacros.AssignValues(Value);\r\nend;\r\n\r\nfunction TJvQuery.GetSQL: TStrings;\r\nbegin\r\n Result := FSQL;\r\nend;\r\n\r\nprocedure TJvQuery.SetSQL(Value: TStrings);\r\nbegin\r\n inherited Disconnect;\r\n FSQL.OnChange := nil;\r\n FSQL.Assign(Value);\r\n FSQL.OnChange := PatternChanged;\r\n PatternChanged(nil);\r\nend;\r\n\r\nprocedure TJvQuery.PatternChanged(Sender: TObject);\r\nbegin\r\n if csLoading in ComponentState then\r\n begin\r\n FStreamPatternChanged := True;\r\n Exit;\r\n end;\r\n inherited Disconnect;\r\n RecreateMacros;\r\n FPatternChanged := True;\r\n try\r\n ExpandMacros;\r\n finally\r\n FPatternChanged := False;\r\n end;\r\nend;\r\n\r\nprocedure TJvQuery.QueryChanged(Sender: TObject);\r\nbegin\r\n FSaveQueryChanged(Sender);\r\n if not FDisconnectExpected then\r\n begin\r\n SQL := inherited SQL;\r\n end;\r\nend;\r\n\r\nprocedure TJvQuery.ExpandMacros;\r\nvar\r\n ExpandedSQL: TStringList;\r\nbegin\r\n if not FPatternChanged and not FStreamPatternChanged and\r\n (MacroCount = 0) then\r\n Exit;\r\n ExpandedSQL := TStringList.Create;\r\n try\r\n Expand(ExpandedSQL);\r\n FDisconnectExpected := True;\r\n try\r\n inherited SQL := ExpandedSQL;\r\n finally\r\n FDisconnectExpected := False;\r\n end;\r\n finally\r\n ExpandedSQL.Free;\r\n end;\r\nend;\r\n\r\nprocedure TJvQuery.RecreateMacros;\r\nvar\r\n List: TParams;\r\nbegin\r\n if not (csReading in ComponentState) then\r\n begin\r\n List := TParams.Create(Self);\r\n try\r\n CreateMacros(List, PChar(FSQL.Text));\r\n List.AssignValues(FMacros);\r\n FMacros.Clear;\r\n FMacros.Assign(List);\r\n finally\r\n List.Free;\r\n end;\r\n end\r\n else\r\n begin\r\n FMacros.Clear;\r\n CreateMacros(FMacros, PChar(FSQL.Text));\r\n end;\r\nend;\r\n\r\nprocedure TJvQuery.CreateMacros(List: TParams; const Value: PChar);\r\nbegin\r\n CreateQueryParams(List, Value, True, MacroChar, ['.']);\r\nend;\r\n\r\nprocedure TJvQuery.Expand(Query: TStrings);\r\nvar\r\n I: Integer;\r\n\r\n function ReplaceString(const S: string): string;\r\n var\r\n I, J, P, LiteralChars: Integer;\r\n Param: TParam;\r\n Found: Boolean;\r\n begin\r\n Result := S;\r\n for I := Macros.Count - 1 downto 0 do\r\n begin\r\n Param := Macros[I];\r\n if Param.DataType = ftUnknown then\r\n Continue;\r\n repeat\r\n P := Pos(MacroChar + Param.Name, Result);\r\n Found := (P > 0) and ((Length(Result) = P + Length(Param.Name)) or\r\n NameDelimiters(Result[P + Length(Param.Name) + 1], ['.']));\r\n if Found then\r\n begin\r\n LiteralChars := 0;\r\n for J := 1 to P - 1 do\r\n if IsLiteral(Result[J]) then\r\n Inc(LiteralChars);\r\n Found := LiteralChars mod 2 = 0;\r\n if Found then\r\n begin\r\n Result := Copy(Result, 1, P - 1) + Param.Text + Copy(Result,\r\n P + Length(Param.Name) + 1, MaxInt);\r\n end;\r\n end;\r\n until not Found;\r\n end;\r\n end;\r\n\r\nbegin\r\n Query.BeginUpdate;\r\n try\r\n for I := 0 to SQL.Count - 1 do\r\n Query.Add(ReplaceString(SQL[I]));\r\n finally\r\n Query.EndUpdate;\r\n end;\r\nend;\r\n\r\nfunction TJvQuery.GetMacroCount: Word;\r\nbegin\r\n Result := FMacros.Count;\r\nend;\r\n\r\nfunction TJvQuery.MacroByName(const Value: string): TParam;\r\nbegin\r\n Result := FMacros.ParamByName(Value);\r\nend;\r\n\r\nfunction TJvQuery.GetRealSQL: TStrings;\r\nbegin\r\n try\r\n ExpandMacros;\r\n except\r\n end;\r\n Result := inherited SQL;\r\nend;\r\n\r\n\r\nfunction TJvQuery.PSGetDefaultOrder: TIndexDef;\r\nbegin\r\n ExpandMacros;\r\n Result := inherited PSGetDefaultOrder;\r\nend;\r\n\r\nfunction TJvQuery.PSGetTableName: string;\r\nbegin\r\n ExpandMacros;\r\n Result := inherited PSGetTableName;\r\nend;\r\n\r\nprocedure TJvQuery.PSExecute;\r\nbegin\r\n ExecSQL;\r\nend;\r\n\r\n//=== { TJvQueryThread } =====================================================\r\n\r\nconstructor TJvQueryThread.Create(Data: TBDEDataSet; RunMode: TRunQueryMode;\r\n Prepare, CreateSuspended: Boolean);\r\nbegin\r\n inherited Create(CreateSuspended);\r\n FData := Data;\r\n FMode := RunMode;\r\n FPrepare := Prepare;\r\n FreeOnTerminate := True;\r\n FData.DisableControls;\r\n ThreadName := Format('%s: %s',[ClassName, Data.Name]);\r\nend;\r\n\r\nprocedure TJvQueryThread.DoTerminate;\r\nbegin\r\n Synchronize(FData.EnableControls);\r\n inherited DoTerminate;\r\nend;\r\n\r\nprocedure TJvQueryThread.ModeError;\r\nbegin\r\n SysUtils.Abort;\r\nend;\r\n\r\nprocedure TJvQueryThread.DoHandleException;\r\nbegin\r\n if (FException is Exception) and not (FException is EAbort) then\r\n begin\r\n if Assigned(Application.OnException) then\r\n Application.OnException(FData, Exception(FException))\r\n else\r\n Application.ShowException(Exception(FException));\r\n end;\r\nend;\r\n\r\nprocedure TJvQueryThread.HandleException;\r\nbegin\r\n FException := TObject(ExceptObject);\r\n Synchronize(DoHandleException);\r\nend;\r\n\r\nprocedure TJvQueryThread.Execute;\r\nbegin\r\n NameThread(ThreadName);\r\n try\r\n if FPrepare and not (FMode in [rqExecDirect]) then\r\n begin\r\n if FData is TJvQuery then\r\n TJvQuery(FData).Prepare\r\n else\r\n if FData is TQuery then\r\n TQuery(FData).Prepare\r\n else\r\n if FData is TStoredProc then\r\n TStoredProc(FData).Prepare;\r\n end;\r\n case FMode of\r\n rqOpen:\r\n FData.Open;\r\n rqExecute:\r\n begin\r\n if FData is TJvQuery then\r\n TJvQuery(FData).ExecSQL\r\n else\r\n if FData is TQuery then\r\n TQuery(FData).ExecSQL\r\n else\r\n if FData is TStoredProc then\r\n TStoredProc(FData).ExecProc\r\n else\r\n ModeError;\r\n end;\r\n rqExecDirect:\r\n begin\r\n if FData is TJvQuery then\r\n TJvQuery(FData).ExecDirect\r\n else\r\n ModeError;\r\n end;\r\n rqOpenOrExec:\r\n begin\r\n if FData is TJvQuery then\r\n TJvQuery(FData).OpenOrExec(True)\r\n else\r\n FData.Open;\r\n end;\r\n end;\r\n except\r\n HandleException;\r\n end;\r\nend;\r\n\r\n//=== { TJvSQLScript } =======================================================\r\n\r\nconstructor TJvSQLScript.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FSQL := TStringList.Create;\r\n FSQL.OnChange := QueryChanged;\r\n FParams := TParams.Create(Self);\r\n FQuery := TJvQuery.Create(Self);\r\n FSemicolonTerm := True;\r\n FTerm := DefaultTermChar;\r\nend;\r\n\r\ndestructor TJvSQLScript.Destroy;\r\nbegin\r\n FQuery.Free;\r\n FSQL.Free;\r\n FParams.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJvSQLScript.GetDatabase: TDatabase;\r\nbegin\r\n Result := FQuery.Database;\r\nend;\r\n\r\nfunction TJvSQLScript.GetDatabaseName: string;\r\nbegin\r\n Result := FQuery.DatabaseName;\r\nend;\r\n\r\nprocedure TJvSQLScript.SetDatabaseName(const Value: string);\r\nbegin\r\n FQuery.DatabaseName := Value;\r\nend;\r\n\r\nfunction TJvSQLScript.GetSessionName: string;\r\nbegin\r\n Result := FQuery.SessionName;\r\nend;\r\n\r\nprocedure TJvSQLScript.SetSessionName(const Value: string);\r\nbegin\r\n FQuery.SessionName := Value;\r\nend;\r\n\r\nfunction TJvSQLScript.GetDBSession: TSession;\r\nbegin\r\n Result := FQuery.DBSession;\r\nend;\r\n\r\nprocedure TJvSQLScript.CheckExecQuery(LineNo, StatementNo: Integer);\r\nvar\r\n Done: Boolean;\r\n Action: TScriptAction;\r\n I: Integer;\r\n Param: TParam;\r\n S: string;\r\nbegin\r\n Done := False;\r\n repeat\r\n try\r\n if IgnoreParams then\r\n FQuery.ExecDirect\r\n else\r\n begin\r\n for I := 0 to FQuery.Params.Count - 1 do\r\n begin\r\n Param := FQuery.Params[I];\r\n Param.Assign(Params.ParamByName(Param.Name));\r\n end;\r\n FQuery.ExecSQL;\r\n end;\r\n Done := True;\r\n except\r\n on E: EDatabaseError do\r\n begin\r\n Action := saFail;\r\n S := Format(SParseError, [SMsgdlgError, LineNo]);\r\n if E is EDBEngineError then\r\n TDBError.Create(EDBEngineError(E), 0, LineNo, {$IFNDEF COMPILER12_UP}PChar{$ENDIF ~COMPILER12_UP}(S))\r\n else\r\n begin\r\n if E.Message <> '' then\r\n E.Message := E.Message + '. ';\r\n E.Message := E.Message + S;\r\n end;\r\n if Assigned(FOnScriptError) then\r\n FOnScriptError(Self, E, LineNo, StatementNo, Action);\r\n if Action = saFail then\r\n raise;\r\n if Action = saAbort then\r\n SysUtils.Abort;\r\n if Action = saContinue then\r\n begin\r\n Application.HandleException(Self);\r\n Done := True;\r\n end\r\n else\r\n if Action = saIgnore then\r\n Done := True;\r\n end;\r\n end;\r\n until Done;\r\nend;\r\n\r\nprocedure TJvSQLScript.ExecuteScript(StatementNo: Integer);\r\nvar\r\n S, LastStr: string;\r\n IsTrans, SQLFilled, StmtFound: Boolean;\r\n I, P, CurrStatement: Integer;\r\nbegin\r\n IsTrans := FTransaction and not TransActive(Database) and (StatementNo < 0);\r\n LastStr := '';\r\n try\r\n if IsTrans then\r\n begin\r\n if not Database.IsSQLBased then\r\n Database.TransIsolation := tiDirtyRead;\r\n Database.StartTransaction;\r\n end;\r\n except\r\n IsTrans := False;\r\n end;\r\n try\r\n I := 0;\r\n CurrStatement := 0;\r\n StmtFound := False;\r\n while I < SQL.Count do\r\n begin\r\n FQuery.SQL.BeginUpdate;\r\n try\r\n FQuery.SQL.Clear;\r\n SQLFilled := False;\r\n repeat\r\n if LastStr <> '' then\r\n begin\r\n FQuery.SQL.Add(LastStr);\r\n LastStr := '';\r\n end;\r\n if I < SQL.Count then\r\n begin\r\n S := Trim(SQL[I]);\r\n Inc(I);\r\n P := Pos(';', S);\r\n if (P > 0) and FSemicolonTerm then\r\n begin\r\n LastStr := Trim(Copy(S, P + 1, MaxInt));\r\n S := Copy(S, 1, P - 1);\r\n if S <> '' then\r\n FQuery.SQL.Add(S);\r\n SQLFilled := True;\r\n end\r\n else\r\n begin\r\n if S = Term then\r\n SQLFilled := True\r\n else\r\n if S <> '' then\r\n FQuery.SQL.Add(S);\r\n end;\r\n end\r\n else\r\n SQLFilled := True;\r\n until SQLFilled;\r\n finally\r\n FQuery.SQL.EndUpdate;\r\n end;\r\n if FQuery.SQL.Count > 0 then\r\n begin\r\n if (StatementNo < 0) or (StatementNo = CurrStatement) then\r\n begin\r\n StmtFound := True;\r\n CheckExecQuery(I - 1, CurrStatement);\r\n if StatementNo = CurrStatement then\r\n Break;\r\n end;\r\n Inc(CurrStatement);\r\n end;\r\n end;\r\n if not StmtFound then\r\n begin\r\n DatabaseError(Format(SListIndexError, [StatementNo]));\r\n end;\r\n if IsTrans then\r\n Database.Commit;\r\n except\r\n if IsTrans then\r\n Database.Rollback;\r\n raise;\r\n end;\r\nend;\r\n\r\nprocedure TJvSQLScript.ExecStatement(StatementNo: Integer);\r\nbegin\r\n if SQL.Count = 0 then\r\n _DBError(SEmptySQLStatement);\r\n FQuery.SetDBFlag(dbfExecScript, True);\r\n try\r\n if not Database.Connected then\r\n _DBError(SDatabaseClosed);\r\n if Assigned(FBeforeExec) then\r\n FBeforeExec(Self);\r\n ExecuteScript(StatementNo);\r\n if Assigned(FAfterExec) then\r\n FAfterExec(Self);\r\n finally\r\n FQuery.SetDBFlag(dbfExecScript, False);\r\n end;\r\nend;\r\n\r\nprocedure TJvSQLScript.ExecSQL;\r\nbegin\r\n ExecStatement(-1);\r\nend;\r\n\r\nprocedure TJvSQLScript.CreateParams(List: TParams; const Value: PChar);\r\nbegin\r\n CreateQueryParams(List, Value, False, ':', []);\r\nend;\r\n\r\nfunction TJvSQLScript.GetSQL: TStrings;\r\nbegin\r\n Result := FSQL;\r\nend;\r\n\r\nprocedure TJvSQLScript.SetSQL(Value: TStrings);\r\nbegin\r\n FSQL.OnChange := nil;\r\n FSQL.Assign(Value);\r\n FSQL.OnChange := QueryChanged;\r\n QueryChanged(nil);\r\nend;\r\n\r\nfunction TJvSQLScript.GetText: string;\r\nbegin\r\n Result := SQL.Text;\r\nend;\r\n\r\nprocedure TJvSQLScript.QueryChanged(Sender: TObject);\r\nvar\r\n List: TParams;\r\nbegin\r\n if not (csReading in ComponentState) then\r\n begin\r\n List := TParams.Create(Self);\r\n try\r\n CreateParams(List, PChar(Text));\r\n List.AssignValues(FParams);\r\n FParams.Clear;\r\n FParams.Assign(List);\r\n finally\r\n List.Free;\r\n end;\r\n end\r\n else\r\n begin\r\n FParams.Clear;\r\n CreateParams(FParams, PChar(Text));\r\n end;\r\nend;\r\n\r\nfunction TJvSQLScript.ParamByName(const Value: string): TParam;\r\nbegin\r\n Result := FParams.ParamByName(Value);\r\nend;\r\n\r\nprocedure TJvSQLScript.SetParamsList(Value: TParams);\r\nbegin\r\n FParams.AssignValues(Value);\r\nend;\r\n\r\nfunction TJvSQLScript.GetParamsCount: Cardinal;\r\nbegin\r\n Result := FParams.Count;\r\nend;\r\n\r\n\r\nprocedure TJvSQLScript.DefineProperties(Filer: TFiler);\r\nbegin\r\n inherited DefineProperties(Filer);\r\n Filer.DefineProperty('ParamData', ReadParamData, WriteParamData, True);\r\nend;\r\n\r\nprocedure TJvSQLScript.ReadParamData(Reader: TReader);\r\nbegin\r\n Reader.ReadValue;\r\n Reader.ReadCollection(FParams);\r\nend;\r\n\r\nprocedure TJvSQLScript.WriteParamData(Writer: TWriter);\r\nbegin\r\n Writer.WriteCollection(Params);\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvBDESQLScript.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvSQLS.PAS, released on 2002-07-04.\r\n\r\nThe Initial Developers of the Original Code are: Andrei Prygounkov \r\nCopyright (c) 1999, 2002 Andrei Prygounkov\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nComponent : TJvaSQLScript\r\nDescription : db-aware component\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvBDESQLScript.pas 13075 2011-06-27 22:56:21Z jfudickar $\r\n\r\nunit JvBDESQLScript;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Classes, DBTables,\r\n JvDBUtils, JvComponentBase;\r\n\r\ntype\r\n TJvBDESQLScript = class;\r\n TOnScriptProgress = procedure(Sender: TJvBDESQLScript; var Cancel: Boolean; Line: Integer) of object;\r\n\r\n TJvBDESQLScript = class(TJvComponent)\r\n private\r\n FOnProgress: TOnScriptProgress;\r\n FScript: TStringList;\r\n FCommit: TCommit;\r\n FDatabase: TDatabase;\r\n function GetScript: TStrings;\r\n procedure SetScript(AValue: TStrings);\r\n procedure Progress(UserData: Integer; var Cancel: Boolean; Line: Integer);\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n published\r\n procedure Execute;\r\n property OnProgress: TOnScriptProgress read FOnProgress write FOnProgress;\r\n property Script: TStrings read GetScript write SetScript;\r\n property Commit: TCommit read FCommit write FCommit;\r\n property Database: TDatabase read FDatabase write FDatabase;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvBDESQLScript.pas $';\r\n Revision: '$Revision: 13075 $';\r\n Date: '$Date: 2011-06-28 00:56:21 +0200 (mar. 28 juin 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n JvBdeUtils;\r\n\r\nconstructor TJvBDESQLScript.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FScript := TStringList.Create;\r\nend;\r\n\r\ndestructor TJvBDESQLScript.Destroy;\r\nbegin\r\n FScript.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJvBDESQLScript.GetScript: TStrings;\r\nbegin\r\n Result := FScript;\r\nend;\r\n\r\nprocedure TJvBDESQLScript.SetScript(AValue: TStrings);\r\nbegin\r\n FScript.Assign(AValue);\r\nend;\r\n\r\nprocedure TJvBDESQLScript.Execute;\r\nbegin\r\n ExecuteSQLScript(FDatabase, FScript.Text, FCommit, Progress, 0);\r\nend;\r\n\r\nprocedure TJvBDESQLScript.Progress(UserData: Integer; var Cancel: Boolean; Line: Integer);\r\nbegin\r\n if Assigned(FOnProgress) then\r\n FOnProgress(Self, Cancel, Line);\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvBDESecurity.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvDBSecur.PAS, released on 2002-07-04.\r\n\r\nThe Initial Developers of the Original Code are: Fedor Koshevnikov, Igor Pavluk and Serge Korolev\r\nCopyright (c) 1997, 1998 Fedor Koshevnikov, Igor Pavluk and Serge Korolev\r\nCopyright (c) 2001,2002 SGB Software\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\n Hofi\r\n\r\nLast Modified: 2004-10-07\r\n\r\nChanges:\r\n2004-10-07:\r\n * Added\r\n TJvCustomLogin\r\n property Caption to support a custom dialog Caption.\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvBDESecurity.pas 12741 2010-04-02 10:43:13Z ahuser $\r\n\r\nunit JvBDESecurity;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n SysUtils, Classes, DBTables,\r\n JvLoginForm, JvBDELoginDialog, JvBDECheckPasswordForm;\r\n\r\ntype\r\n TCheckUserEvent = function(UsersTable: TTable; const Password: string): Boolean of object;\r\n\r\n TJvDBSecurity = class(TJvCustomLogin)\r\n private\r\n FDatabase: TDatabase;\r\n FUsersTableName: TFileName;\r\n FLoginNameField: string;\r\n FSelectAlias: Boolean;\r\n FOnCheckUser: TCheckUserEvent;\r\n FOnChangePassword: TChangePasswordEvent;\r\n FOnLoginFailure: TJvDBLoginEvent;\r\n procedure SetDatabase(Value: TDatabase);\r\n procedure SetUsersTableName(const Value: TFileName);\r\n function GetLoginNameField: string;\r\n procedure SetLoginNameField(const Value: string);\r\n protected\r\n function DoCheckUser(UsersTable: TTable; const UserName,\r\n Password: string): Boolean; dynamic;\r\n function DoLogin(var UserName: string): Boolean; override;\r\n procedure Loaded; override;\r\n procedure Notification(AComponent: TComponent; Operation: TOperation); override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n function ChangePassword: Boolean;\r\n published\r\n property Database: TDatabase read FDatabase write SetDatabase;\r\n property LoginNameField: string read GetLoginNameField write SetLoginNameField;\r\n property SelectAlias: Boolean read FSelectAlias write FSelectAlias default False;\r\n property UsersTableName: TFileName read FUsersTableName write SetUsersTableName;\r\n property Active;\r\n property AllowEmptyPassword;\r\n property AppStorage;\r\n property AppStoragePath;\r\n property AttemptNumber;\r\n property Caption;\r\n property MaxPasswordLen;\r\n property UpdateCaption;\r\n property OnCheckUser: TCheckUserEvent read FOnCheckUser write FOnCheckUser;\r\n property OnChangePassword: TChangePasswordEvent read FOnChangePassword\r\n write FOnChangePassword;\r\n property AfterLogin;\r\n property BeforeLogin;\r\n property OnUnlock;\r\n property OnUnlockApp;\r\n property OnIconDblClick;\r\n property OnLoginFailure: TJvDBLoginEvent read FOnLoginFailure write FOnLoginFailure;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvBDESecurity.pas $';\r\n Revision: '$Revision: 12741 $';\r\n Date: '$Date: 2010-04-02 12:43:13 +0200 (ven. 02 avr. 2010) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nUses JvJVCLUtils;\r\n\r\nconstructor TJvDBSecurity.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FSelectAlias := False;\r\n FLoginNameField := '';\r\nend;\r\n\r\nprocedure TJvDBSecurity.Notification(AComponent: TComponent; Operation: TOperation);\r\nbegin\r\n inherited Notification(AComponent, Operation);\r\n if (Operation = opRemove) and (AComponent = Database) then\r\n Database := nil;\r\nend;\r\n\r\nprocedure TJvDBSecurity.Loaded;\r\nbegin\r\n inherited Loaded;\r\n if not (csDesigning in ComponentState) and Active and (Database <> nil) then\r\n begin\r\n Database.LoginPrompt := True;\r\n if not Login then\r\n TerminateApplication;\r\n end;\r\nend;\r\n\r\nprocedure TJvDBSecurity.SetDatabase(Value: TDatabase);\r\nbegin\r\n ReplaceComponentReference(Self, Value, TComponent(FDatabase));\r\nend;\r\n\r\nprocedure TJvDBSecurity.SetUsersTableName(const Value: TFileName);\r\nbegin\r\n if FUsersTableName <> Value then\r\n FUsersTableName := Value;\r\nend;\r\n\r\nfunction TJvDBSecurity.GetLoginNameField: string;\r\nbegin\r\n Result := FLoginNameField;\r\nend;\r\n\r\nprocedure TJvDBSecurity.SetLoginNameField(const Value: string);\r\nbegin\r\n FLoginNameField := Value;\r\nend;\r\n\r\nfunction TJvDBSecurity.DoCheckUser(UsersTable: TTable;\r\n const UserName, Password: string): Boolean;\r\nvar\r\n SaveLoggedUser: string;\r\nbegin\r\n if Assigned(FOnCheckUser) then\r\n begin\r\n SaveLoggedUser := LoggedUser;\r\n try\r\n SetLoggedUser(UserName);\r\n Result := FOnCheckUser(UsersTable, Password);\r\n finally\r\n SetLoggedUser(SaveLoggedUser);\r\n end;\r\n end\r\n else\r\n Result := True;\r\nend;\r\n\r\nfunction TJvDBSecurity.DoLogin(var UserName: string): Boolean;\r\nvar\r\n IconClick: TNotifyEvent;\r\nbegin\r\n IconClick := OnIconDblClick;\r\n if Assigned(IconClick) then\r\n IconClick := DoIconDblClick;\r\n Result := LoginDialog(Database, AttemptNumber, UsersTableName,\r\n LoginNameField, MaxPasswordLen, DoCheckUser, IconClick, UserName,\r\n AppStorage, AppStoragePath, SelectAlias, FOnLoginFailure, OnGetPassword);\r\nend;\r\n\r\nfunction TJvDBSecurity.ChangePassword: Boolean;\r\nbegin\r\n Result := ChangePasswordDialog(Database, AttemptNumber, UsersTableName,\r\n LoginNameField, LoggedUser, MaxPasswordLen, AllowEmptyPassword,\r\n FOnChangePassword);\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvBackgrounds.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvBackgrounds.PAS, released on 2004-04-26.\r\n\r\nThe Initial Developer of the Original Code is Robert Rossmair [Robert dott Rossmair att t-online dott de]\r\nPortions created by Robert Rossmair are Copyright (C) 2003 Robert Rossmair.\r\nAll Rights Reserved.\r\n\r\nContributors:\r\n Andreas Hausladen (ahuser)\r\n Peter Thornqvist (peter3)\r\n Robert Marquardt (marquardt)\r\n Robert Rossmair (rrossmair)\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvBackgrounds.pas 13173 2011-11-19 12:43:58Z ahuser $\r\n\r\nunit JvBackgrounds;\r\n\r\n{$I jvcl.inc}\r\n{$I windowsonly.inc}\r\n\r\ninterface\r\n\r\n{***************** Conditional Compiler Symbols ************************\r\n\r\n USE_JvGIF use TGIFImage class from JVCL\r\n\r\n USE_AM_GIF use GIFImage library by Anders Melander et alii\r\n (download address: http://finn.mobilixnet.dk/delphi/).\r\n\r\n NO_DESIGNHOOK Disables visual feedback in design mode.\r\n $DEFINE this if you experience problems in design mode.\r\n Such problems might occur if there are other components\r\n manipulating the TrrBackgrounds.Client's window\r\n procedure.\r\n *********************************************************************** }\r\n\r\n{.$DEFINE USE_AM_GIF}\r\n{.$DEFINE USE_JvGIF}\r\n\r\n{$IFDEF USE_JvGIF}\r\n{$UNDEF USE_AM_GIF}\r\n{$ENDIF USE_JvGIF}\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, Messages, Contnrs, Graphics, Controls, Forms, Classes,\r\n JclGraphUtils,\r\n JvTypes;\r\n\r\ntype\r\n TJvBackgroundMode = (bmTile, bmCenter, bmTopLeft, bmTop, bmTopRight, bmLeft,\r\n bmBottomLeft, bmRight, bmBottom, bmBottomRight, bmStretch);\r\n EJvBackgroundError = class(EJVCLException);\r\n TJvBackgroundShiftMode = (smRows, smColumns);\r\n\r\n TJvBackgroundImage = class(TPersistent)\r\n private\r\n FPicture: TPicture;\r\n FCanvas: TCanvas;\r\n FHorzOffset: Integer;\r\n FVertOffset: Integer;\r\n FOnChange: TNotifyEvent;\r\n FWorkingBmp: TBitmap;\r\n FInUpdWorkingBmp: Boolean;\r\n FMode: TJvBackgroundMode;\r\n FTransparent: Boolean;\r\n FTransparentMode: TTransparentMode;\r\n FTransparentColor: TColor;\r\n FTileWidth: Integer;\r\n FTileHeight: Integer;\r\n FShift: Integer;\r\n FShiftMode: TJvBackgroundShiftMode;\r\n FZigZag: Boolean;\r\n FAutoSizeTile: Boolean;\r\n FFitPictureSize: Boolean;\r\n FEnabled: Boolean;\r\n FPictureValid: Boolean;\r\n FGrayMapped: Boolean;\r\n procedure SetGrayMapped(Value: Boolean);\r\n procedure SysColorChange;\r\n class function MainWindowHook(var Msg: TMessage): Boolean;\r\n procedure HookMainWindow;\r\n procedure UnhookMainWindow;\r\n procedure Changed;\r\n function GetTransparentColor: TColor;\r\n procedure PictureChanged(Sender: TObject);\r\n procedure SetAutoSizeTile(Value: Boolean);\r\n procedure SetEnabled(Value: Boolean);\r\n procedure SetFitPictureSize(Value: Boolean);\r\n procedure SetMode(Value: TJvBackgroundMode);\r\n procedure SetPicture(Value: TPicture);\r\n procedure SetShift(Value: Integer);\r\n procedure SetShiftMode(Value: TJvBackgroundShiftMode);\r\n procedure SetTileWidth(Value: Integer);\r\n procedure SetTileHeight(Value: Integer);\r\n procedure SetTransparent(Value: Boolean);\r\n procedure SetTransparentColor(Value: TColor);\r\n procedure SetTransparentMode(Value: TTransparentMode);\r\n procedure SetZigZag(Value: Boolean);\r\n procedure TileGraphic(AClient: TControl; Graphic: TGraphic);\r\n function TransparentColorStored: Boolean;\r\n procedure UpdateWorkingBmp;\r\n procedure WorkingBmpNeeded;\r\n protected\r\n function HandleWMEraseBkgnd(AClient: TWinControl; var Msg: TMessage): Boolean;\r\n function HandleWMPaint(AClient: TWinControl; var Msg: TMessage): Boolean;\r\n procedure PaintGraphic(AClient: TControl; DC: HDC; Graphic: TGraphic);\r\n property Canvas: TCanvas read FCanvas;\r\n property WorkingBmp: TBitmap read FWorkingBmp;\r\n public\r\n constructor Create;\r\n destructor Destroy; override;\r\n procedure Assign(Source: TPersistent); override;\r\n function DoEraseBackground(AClient: TWinControl; DC: HDC): Boolean;\r\n published\r\n property AutoSizeTile: Boolean read FAutoSizeTile write SetAutoSizeTile\r\n default True;\r\n property Enabled: Boolean read FEnabled write SetEnabled default True;\r\n property FitPictureSize: Boolean\r\n read FFitPictureSize write SetFitPictureSize default False;\r\n property GrayMapped: Boolean read FGrayMapped write SetGrayMapped default False;\r\n property Mode: TJvBackgroundMode read FMode write SetMode default bmTile;\r\n property Picture: TPicture read FPicture write SetPicture;\r\n property TileWidth: Integer read FTileWidth write SetTileWidth;\r\n property TileHeight: Integer read FTileHeight write SetTileHeight;\r\n property Transparent: Boolean read FTransparent write SetTransparent default False;\r\n property TransparentColor: TColor read GetTransparentColor\r\n write SetTransparentColor stored TransparentColorStored;\r\n property TransparentMode: TTransparentMode read FTransparentMode\r\n write SetTransparentMode default tmAuto;\r\n property Shift: Integer read FShift write SetShift default 0;\r\n property ShiftMode: TJvBackgroundShiftMode read FShiftMode write SetShiftMode default smRows;\r\n property ZigZag: Boolean read FZigZag write SetZigZag default False;\r\n end;\r\n\r\n TJvControlBackground = class(TJvBackgroundImage)\r\n private\r\n FClient: TWinControl;\r\n public\r\n function HookBeforeMessage(var Msg: TMessage): Boolean;\r\n procedure HookAfterMessage(var Msg: TMessage);\r\n constructor Create(AClient: TWinControl);\r\n end;\r\n\r\n TJvBackground = class;\r\n\r\n TJvBackgroundClientLink = class(TObject)\r\n private\r\n FBackground: TJvBackground;\r\n FClient: TWinControl;\r\n FNewWndProc: Pointer;\r\n FPrevWndProc: TFarProc;\r\n FClientIsMDIForm: Boolean;\r\n procedure ClientInvalidate;\r\n procedure MainWndProc(var Msg: TMessage);\r\n procedure ClientWndProc(var Message: TMessage);\r\n procedure ForceClient(Value: TWinControl; Force: Boolean = True);\r\n procedure HookClient;\r\n procedure UnhookClient;\r\n function GetClientColor: TColor;\r\n function GetClientHandle: THandle;\r\n procedure SetClient(Value: TWinControl);\r\n protected\r\n procedure Release;\r\n property Background: TJvBackground read FBackground;\r\n property ClientColor: TColor read GetClientColor;\r\n property ClientHandle: THandle read GetClientHandle;\r\n property Client: TWinControl read FClient write SetClient;\r\n property ClientIsMDIForm: Boolean read FClientIsMDIForm;\r\n public\r\n constructor Create(ABackground: TJvBackground; AClient: TWinControl);\r\n destructor Destroy; override;\r\n end;\r\n\r\n TJvBackgroundClients = class(TPersistent)\r\n private\r\n FBackground: TJvBackground;\r\n FLinks: TObjectList;\r\n FFixups: TStringList;\r\n function GetClient(Index: Integer): TWinControl;\r\n procedure Invalidate;\r\n procedure Notification(AComponent: TComponent; Operation: TOperation);\r\n procedure FixupReferences(Root: TComponent);\r\n procedure ReadData(Reader: TReader);\r\n procedure WriteData(Writer: TWriter);\r\n function GetLink(Index: Integer): TJvBackgroundClientLink;\r\n protected\r\n procedure DefineProperties(Filer: TFiler); override;\r\n property Background: TJvBackground read FBackground;\r\n property Links[Index: Integer]: TJvBackgroundClientLink read GetLink;\r\n public\r\n constructor Create(ABackground: TJvBackground);\r\n destructor Destroy; override;\r\n procedure Clear(Immediatelly: Boolean = False);\r\n procedure Add(Control: TWinControl);\r\n procedure Remove(Control: TWinControl);\r\n function IndexOf(Control: TWinControl): Integer;\r\n property Clients[Index: Integer]: TWinControl read GetClient; default;\r\n end;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64 or pidOSX32)]\r\n {$ENDIF RTL230_UP}\r\n TJvBackground = class(TComponent)\r\n private\r\n FClients: TJvBackgroundClients;\r\n FHandle: HWND;\r\n FImage: TJvBackgroundImage;\r\n procedure SetClients(Value: TJvBackgroundClients);\r\n procedure WallpaperChanged(Sender: TObject);\r\n procedure WndProc(var Msg: TMessage);\r\n procedure SetImage(const Value: TJvBackgroundImage);\r\n protected\r\n procedure Loaded; override;\r\n procedure Notification(AComponent: TComponent; Operation: TOperation); override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n function HasClient(Control: TWinControl): Boolean;\r\n published\r\n property Image: TJvBackgroundImage read FImage write SetImage;\r\n property Clients: TJvBackgroundClients read FClients write SetClients;\r\n end;\r\n\r\nprocedure GetMappedGrays(var Shades: array of TColor; StartIntensity: Byte);\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvBackgrounds.pas $';\r\n Revision: '$Revision: 13173 $';\r\n Date: '$Date: 2011-11-19 13:43:58 +0100 (sam. 19 nov. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n SysUtils, jpeg,\r\n StdCtrls, CommCtrl, ComCtrls, Dialogs,\r\n {$IFDEF USE_AM_GIF}\r\n GIFImage,\r\n {$DEFINE HANDLES_GIF}\r\n {$ENDIF USE_AM_GIF}\r\n {$IFDEF USE_JvGIF}\r\n JvGIF,\r\n {$DEFINE HANDLES_GIF}\r\n {$ENDIF USE_JvGIF}\r\n JvJCLUtils, JvConsts, JvResources;\r\n\r\ntype\r\n TWinControlAccessProtected = class(TWinControl);\r\n\r\n {$IFDEF USE_JvGIF}\r\n // make TJvGIFImage's Bitmap property visible\r\n TGIFImage = class(TJvGIFImage);\r\n {$ENDIF USE_JvGIF}\r\n\r\nconst\r\n ScrollLineSize = 3;\r\n ScrollUnit = 8;\r\n\r\ntype\r\n TColorGradation = array [Byte] of TColor;\r\n PColorGradation = ^TColorGradation;\r\n\r\nvar\r\n SysColorGradation: TColorGradation;\r\n SysColorGradationInitialized: Boolean = False;\r\n Hooked: TList = nil;\r\n Backgrounds: TList = nil;\r\n\r\nprocedure UpdateSysColorGradation;\r\nvar\r\n SysHLS: THLSVector;\r\n FaceLum, MaxLum: THLSValue;\r\n I: Integer;\r\nbegin\r\n SysHLS := RGBtoHLS(ColorToRGB(clBtnHighlight));\r\n MaxLum := SysHLS.Luminance;\r\n SysHLS := RGBtoHLS(ColorToRGB(clBtnFace));\r\n FaceLum := SysHLS.Luminance;\r\n with SysHLS do\r\n begin\r\n for I := 0 to 192 do\r\n begin\r\n Luminance := I * FaceLum div 192;\r\n SysColorGradation[I] := HLStoRGB(Hue, Luminance, Saturation);\r\n end;\r\n for I := 193 to 255 do\r\n begin\r\n Luminance := FaceLum + (MaxLum - FaceLum) * (I - 192) div (255 - 192);\r\n SysColorGradation[I] := HLStoRGB(Hue, Luminance, Saturation);\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure SysColorsNeeded;\r\nbegin\r\n if not SysColorGradationInitialized then\r\n begin\r\n SysColorGradationInitialized := True;\r\n UpdateSysColorGradation;\r\n end;\r\nend;\r\n\r\nprocedure GetMappedGrays(var Shades: array of TColor; StartIntensity: Byte);\r\nvar\r\n I, Intensity: Integer;\r\nbegin\r\n SysColorsNeeded;\r\n Intensity := StartIntensity;\r\n for I := Low(Shades) to High(Shades) do\r\n begin\r\n Shades[I] := SysColorGradation[Intensity];\r\n if Intensity < High(SysColorGradation) then\r\n Inc(Intensity);\r\n end;\r\nend;\r\n\r\nprocedure MapGrays(Dest: TBitmap; Source: TGraphic);\r\nvar\r\n Grays: PColorGradation;\r\n I: Integer;\r\n SrcWasTransparent: Boolean;\r\nbegin\r\n if Source = nil then\r\n Exit;\r\n New(Grays);\r\n try\r\n for I := Low(Grays^) to High(Grays^) do\r\n Grays[I] := RGB(I, I, I);\r\n with Dest do\r\n begin\r\n if ((Source is TBitmap) and (TBitmap(Source).PixelFormat in [pf1bit..pf8bit]))\r\n {$IFDEF HANDLES_GIF} or (Source is TGIFImage) {$ENDIF} then\r\n Assign(Source)\r\n else\r\n begin\r\n PixelFormat := pf8bit;\r\n Width := Source.Width;\r\n Height := Source.Height;\r\n SetBitmapColors(Dest, Grays^, 0);\r\n SrcWasTransparent := Source.Transparent;\r\n try\r\n Source.Transparent := False;\r\n Canvas.Draw(0, 0, Source);\r\n finally\r\n Source.Transparent := SrcWasTransparent;\r\n end;\r\n end;\r\n Handle := CreateMappedBmp(Handle, Grays^, SysColorGradation);\r\n end;\r\n finally\r\n Dispose(Grays);\r\n end;\r\nend;\r\n\r\nfunction TrimmedOffset(Offset, TileDim: Integer): Integer;\r\nbegin\r\n if TileDim <> 0 then\r\n if Offset > 0 then\r\n Offset := (Offset mod TileDim) - TileDim\r\n else\r\n if Offset < 0 then\r\n Dec(Offset, (Offset div TileDim) * TileDim);\r\n Result := Offset;\r\nend;\r\n\r\nfunction GetClientRect(AClient: TControl): TRect;\r\nvar\r\n MDIClientHandle: HWND;\r\nbegin\r\n if AClient is TCustomForm then\r\n begin\r\n MDIClientHandle := TForm(AClient).ClientHandle;\r\n if MDIClientHandle <> 0 then\r\n begin\r\n Windows.GetClientRect(MDIClientHandle, Result);\r\n Exit;\r\n end;\r\n end;\r\n Result := AClient.ClientRect;\r\nend;\r\n\r\nfunction GetVirtualClientRect(AClient: TControl): TRect;\r\nvar\r\n ClientHandle: HWND;\r\n ScrollInfo: TScrollInfo;\r\n R: TRect;\r\n TVTopItem: TTreeNode;\r\nbegin\r\n Result := GetClientRect(AClient);\r\n if AClient is TWinControl then\r\n begin\r\n ClientHandle := TWinControl(AClient).Handle;\r\n FillChar(ScrollInfo, SizeOf(ScrollInfo), 0);\r\n ScrollInfo.cbSize := SizeOf(ScrollInfo);\r\n ScrollInfo.fMask := SIF_ALL;\r\n GetScrollInfo(ClientHandle, SB_HORZ, ScrollInfo);\r\n if ScrollInfo.nPage > 0 then // horizontal scroll bar visible\r\n begin\r\n if ScrollInfo.nMax > Result.Right then\r\n Result.Right := ScrollInfo.nMax;\r\n Dec(Result.Left, ScrollInfo.nPos);\r\n Dec(Result.Right, ScrollInfo.nPos);\r\n end;\r\n GetScrollInfo(ClientHandle, SB_VERT, ScrollInfo);\r\n if ScrollInfo.nPage > 0 then // vertical scroll bar visible\r\n begin\r\n if AClient is TCustomListBox then\r\n with TListBox(AClient) do\r\n begin\r\n ScrollInfo.nPos := ScrollInfo.nPos * ItemHeight;\r\n ScrollInfo.nMax := ScrollInfo.nMax * ItemHeight;\r\n end\r\n else\r\n if AClient is TCustomTreeView then\r\n begin\r\n TVTopItem := TCustomTreeView(AClient).TopItem;\r\n if Assigned(TVTopItem) and TreeView_GetItemRect(ClientHandle, TVTopItem.ItemID, R, False) then\r\n begin\r\n ScrollInfo.nPos := ScrollInfo.nPos * R.Bottom;\r\n ScrollInfo.nMax := ScrollInfo.nMax * R.Bottom;\r\n end;\r\n end;\r\n if ScrollInfo.nMax > Result.Bottom then\r\n Result.Bottom := ScrollInfo.nMax;\r\n Dec(Result.Top, ScrollInfo.nPos);\r\n Dec(Result.Bottom, ScrollInfo.nPos);\r\n end;\r\n end;\r\nend;\r\n\r\nfunction GetClientBrush(AClient: TControl): TBrush;\r\nbegin\r\n if AClient is TWinControl then\r\n Result := TWinControl(AClient).Brush\r\n else\r\n Result := AClient.Parent.Brush;\r\nend;\r\n\r\nfunction IsMDIForm(Control: TControl): Boolean;\r\nbegin\r\n Result := False;\r\n if Assigned(Control) then\r\n if Control is TCustomForm then\r\n Result := TForm(Control).FormStyle = fsMDIForm;\r\nend;\r\n\r\n//=== { TJvBackgroundImage } =================================================\r\n\r\nconstructor TJvBackgroundImage.Create;\r\nbegin\r\n inherited Create;\r\n FCanvas := TCanvas.Create;\r\n FAutoSizeTile := True;\r\n FEnabled := True;\r\n FTransparentColor := clDefault;\r\n FPicture := TPicture.Create;\r\n FPicture.OnChange := PictureChanged;\r\n HookMainWindow;\r\nend;\r\n\r\ndestructor TJvBackgroundImage.Destroy;\r\nbegin\r\n UnhookMainWindow;\r\n FPicture.Free;\r\n FWorkingBmp.Free;\r\n FCanvas.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvBackgroundImage.Assign(Source: TPersistent);\r\nvar\r\n Src: TJvBackgroundImage;\r\nbegin\r\n if Source is TJvBackgroundImage then\r\n begin\r\n Src := TJvBackgroundImage(Source);\r\n AutoSizeTile := Src.AutoSizeTile;\r\n Enabled := Src.Enabled;\r\n FitPictureSize := Src.FitPictureSize;\r\n GrayMapped := Src.GrayMapped;\r\n Mode := Src.Mode;\r\n Picture := Src.Picture;\r\n TileWidth := Src.TileWidth;\r\n TileHeight := Src.TileHeight;\r\n Transparent := Src.Transparent;\r\n TransparentColor := Src.TransparentColor;\r\n TransparentMode := Src.TransparentMode;\r\n Shift := Src.Shift;\r\n ShiftMode := Src.ShiftMode;\r\n ZigZag := Src.ZigZag;\r\n end\r\n else\r\n inherited Assign(Source);\r\nend;\r\n\r\nprocedure TJvBackgroundImage.Changed;\r\nbegin\r\n if Assigned(FOnChange) then\r\n FOnChange(Self);\r\nend;\r\n\r\nfunction TJvBackgroundImage.HandleWMEraseBkgnd(AClient: TWinControl; var Msg: TMessage): Boolean;\r\nbegin\r\n Result := FEnabled and FPictureValid;\r\n if Result then\r\n begin\r\n if not IsIconic(AClient.Handle) then\r\n if not TWinControlAccessProtected(AClient).FDoubleBuffered or (Msg.wParam = WPARAM(Msg.lParam)) then\r\n DoEraseBackground(AClient,\r\n TWMEraseBkgnd(Msg).DC);\r\n Msg.Result := 1;\r\n end;\r\nend;\r\n\r\nfunction TJvBackgroundImage.HandleWMPaint(AClient: TWinControl; var Msg: TMessage): Boolean;\r\nvar\r\n DC, MemDC: HDC;\r\n MemBitmap, OldBitmap: HBITMAP;\r\n PS: TPaintStruct;\r\n ClientRect: TRect;\r\nbegin\r\n Result := False;\r\n if FEnabled and FPictureValid then\r\n if TWinControlAccessProtected(AClient).FDoubleBuffered and (TWMPaint(Msg).DC = 0) then\r\n begin\r\n DC := GetDC(HWND_DESKTOP);\r\n ClientRect := AClient.ClientRect;\r\n MemBitmap := CreateCompatibleBitmap(DC, ClientRect.Right, ClientRect.Bottom);\r\n ReleaseDC(HWND_DESKTOP, DC);\r\n MemDC := CreateScreenCompatibleDC;\r\n OldBitmap := SelectObject(MemDC, MemBitmap);\r\n try\r\n DC := BeginPaint(AClient.Handle, PS);\r\n DoEraseBackground(AClient, MemDC);\r\n Msg.Result := AClient.Perform(WM_PAINT, MemDC, 0);\r\n BitBlt(DC, 0, 0, ClientRect.Right, ClientRect.Bottom, MemDC, 0, 0, SRCCOPY);\r\n EndPaint(AClient.Handle, PS);\r\n finally\r\n SelectObject(MemDC, OldBitmap);\r\n DeleteDC(MemDC);\r\n DeleteObject(MemBitmap);\r\n end;\r\n Result := True;\r\n end;\r\nend;\r\n\r\nprocedure TJvBackgroundImage.TileGraphic(AClient: TControl; Graphic: TGraphic);\r\nvar\r\n I, J: Integer;\r\n iMin: Integer;\r\n FirstVisibleRow, S, OddShift: Integer;\r\n Left, Top, Width, Height: Integer;\r\n HorzOffset, VertOffset: Integer;\r\n R: TRect;\r\nbegin\r\n R := GetClientRect(AClient);\r\n Width := R.Right;\r\n Height := R.Bottom;\r\n if IsMDIForm(AClient) then\r\n begin\r\n HorzOffset := FHorzOffset;\r\n VertOffset := FVertOffset;\r\n end\r\n else\r\n begin\r\n R := GetVirtualClientRect(AClient);\r\n HorzOffset := R.Left;\r\n VertOffset := R.Top;\r\n end;\r\n if FShiftMode = smRows then\r\n begin\r\n FirstVisibleRow := -VertOffset div FTileHeight;\r\n if VertOffset > 0 then\r\n Dec(FirstVisibleRow);\r\n end\r\n else\r\n begin\r\n FirstVisibleRow := -HorzOffset div FTileWidth;\r\n if HorzOffset > 0 then\r\n Dec(FirstVisibleRow);\r\n end;\r\n Left := TrimmedOffset(HorzOffset, FTileWidth);\r\n Top := TrimmedOffset(VertOffset, FTileHeight);\r\n Dec(Width, Left);\r\n Dec(Height, Top);\r\n\r\n OddShift := 0; // just to satisfy the compiler\r\n if FShiftMode = smRows then\r\n begin\r\n if FZigZag then\r\n begin\r\n OddShift := FTileWidth div 2;\r\n if Odd(FirstVisibleRow) then\r\n S := OddShift\r\n else\r\n S := 0;\r\n end\r\n else\r\n begin\r\n S := (FirstVisibleRow * FShift) mod FTileWidth;\r\n if S < 0 then\r\n Inc(S, FTileWidth);\r\n end;\r\n for J := 0 to (Height - 1) div FTileHeight do\r\n begin\r\n if S = 0 then\r\n iMin := 0\r\n else\r\n iMin := -1;\r\n for I := iMin to (Width - 1) div FTileWidth do\r\n Canvas.Draw(Left + I * FTileWidth + S, Top + J * FTileHeight, Graphic);\r\n if FZigZag then\r\n S := S xor OddShift\r\n else\r\n begin\r\n Inc(S, FShift);\r\n S := S mod FTileWidth;\r\n end;\r\n end;\r\n end\r\n else\r\n begin\r\n if FZigZag then\r\n begin\r\n OddShift := FTileHeight div 2;\r\n if Odd(FirstVisibleRow) then\r\n S := OddShift\r\n else\r\n S := 0;\r\n end\r\n else\r\n begin\r\n S := (FirstVisibleRow * FShift) mod FTileHeight;\r\n if S < 0 then\r\n Inc(S, FTileHeight);\r\n end;\r\n for I := 0 to (Width - 1) div FTileWidth do\r\n begin\r\n if S = 0 then\r\n iMin := 0\r\n else\r\n iMin := -1;\r\n for J := iMin to (Height - 1) div FTileHeight do\r\n Canvas.Draw(Left + I * FTileWidth, Top + J * FTileHeight + S, Graphic);\r\n if FZigZag then\r\n S := S xor OddShift\r\n else\r\n begin\r\n Inc(S, FShift);\r\n S := S mod FTileHeight;\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvBackgroundImage.PaintGraphic(AClient: TControl; DC: HDC; Graphic: TGraphic);\r\nvar\r\n R, Rg: TRect;\r\n X, Y, W, H: Integer;\r\n SaveIndex: Integer;\r\n WindowStyle: DWORD;\r\n GraphW, GraphH: Integer;\r\n Factor, FactorVert: Single;\r\nbegin\r\n SaveIndex := SaveDC(DC);\r\n with Canvas do\r\n begin\r\n Handle := DC;\r\n if FMode = bmTile then\r\n TileGraphic(AClient, Graphic)\r\n else\r\n begin\r\n if IsMDIForm(AClient) then\r\n begin\r\n R := GetClientRect(AClient);\r\n // We don't want the background move\r\n // when scrollbars appear or disappear:\r\n WindowStyle := GetWindowLong(TForm(AClient).ClientHandle, GWL_STYLE);\r\n if (WindowStyle and WS_HSCROLL) <> 0 then\r\n Inc(R.Bottom, GetSystemMetrics(SM_CYHSCROLL));\r\n if (WindowStyle and WS_VSCROLL) <> 0 then\r\n Inc(R.Right, GetSystemMetrics(SM_CXVSCROLL));\r\n end\r\n else\r\n R := GetVirtualClientRect(AClient);\r\n W := R.Right - R.Left;\r\n H := R.Bottom - R.Top;\r\n GraphW := Graphic.Width;\r\n GraphH := Graphic.Height;\r\n if FFitPictureSize and not (FMode = bmStretch) then\r\n begin\r\n Factor := W / GraphW;\r\n FactorVert := H / GraphH;\r\n if FactorVert < Factor then\r\n Factor := FactorVert;\r\n GraphW := Round(Factor * GraphW);\r\n GraphH := Round(Factor * GraphH);\r\n end;\r\n Rg := Rect(0, 0, GraphW, GraphH);\r\n Brush := GetClientBrush(AClient);\r\n case FMode of\r\n bmCenter:\r\n begin\r\n X := R.Left + (W - GraphW) div 2;\r\n Y := R.Top + (H - GraphH) div 2;\r\n FillRect(Rect(R.Left, R.Top, R.Right, Y));\r\n FillRect(Rect(R.Left, Y, X, Y + GraphH));\r\n FillRect(Rect(X + GraphW, Y, R.Right, Y + GraphH));\r\n FillRect(Rect(R.Left, Y + GraphH, R.Right, R.Bottom));\r\n OffsetRect(Rg, X, Y);\r\n end;\r\n bmStretch:\r\n Rg := R;\r\n bmTopLeft:\r\n begin\r\n FillRect(Rect(R.Left + GraphW, R.Top, R.Right, R.Top + GraphH));\r\n FillRect(Rect(R.Left, R.Top + GraphH, R.Right, R.Bottom));\r\n OffsetRect(Rg, R.Left, R.Top);\r\n end;\r\n bmTopRight:\r\n begin\r\n FillRect(Rect(R.Left, R.Top, R.Right - GraphW, R.Top + GraphH));\r\n FillRect(Rect(R.Left, R.Top + GraphH, R.Right, R.Bottom));\r\n OffsetRect(Rg, R.Right - GraphW, R.Top);\r\n end;\r\n bmBottomLeft:\r\n begin\r\n FillRect(Rect(R.Left, R.Top, R.Right, R.Bottom - GraphH));\r\n FillRect(Rect(R.Left + GraphW, R.Bottom - GraphH, R.Right, R.Bottom));\r\n OffsetRect(Rg, R.Left, R.Bottom - GraphH);\r\n end;\r\n bmBottomRight:\r\n begin\r\n FillRect(Rect(R.Left, R.Top, R.Right, R.Bottom - GraphH));\r\n FillRect(Rect(R.Left, R.Bottom - GraphH, R.Right - GraphW, R.Bottom));\r\n OffsetRect(Rg, R.Right - GraphW, R.Bottom - GraphH);\r\n end;\r\n bmTop:\r\n begin\r\n X := R.Left + (W - GraphW) div 2;\r\n FillRect(Rect(R.Left, R.Top, X, GraphH));\r\n FillRect(Rect(X + GraphW, R.Top, R.Right, GraphH));\r\n FillRect(Rect(R.Left, R.Top + GraphH, R.Right, R.Bottom));\r\n OffsetRect(Rg, X, R.Top);\r\n end;\r\n bmLeft:\r\n begin\r\n Y := R.Top + (H - GraphH) div 2;\r\n FillRect(Rect(R.Left, R.Top, R.Right, Y));\r\n FillRect(Rect(R.Left + GraphW, Y, R.Right, Y + GraphH));\r\n FillRect(Rect(R.Left, Y + GraphH, R.Right, R.Bottom));\r\n OffsetRect(Rg, R.Left, Y);\r\n end;\r\n bmBottom:\r\n begin\r\n X := R.Left + (W - GraphW) div 2;\r\n Y := R.Bottom - GraphH;\r\n FillRect(Rect(R.Left, R.Top, R.Right, Y));\r\n FillRect(Rect(R.Left, Y, X, R.Bottom));\r\n FillRect(Rect(X + GraphW, Y, R.Right, R.Bottom));\r\n OffsetRect(Rg, X, Y);\r\n end;\r\n bmRight:\r\n begin\r\n X := R.Right - GraphW;\r\n Y := R.Top + (H - GraphH) div 2;\r\n FillRect(Rect(R.Left, R.Top, R.Right, Y));\r\n FillRect(Rect(R.Left, Y, X, Y + GraphH));\r\n FillRect(Rect(R.Left, Y + GraphH, R.Right, R.Bottom));\r\n OffsetRect(Rg, X, Y);\r\n end;\r\n end;\r\n StretchDraw(Rg, Graphic);\r\n end;\r\n Handle := 0;\r\n end;\r\n RestoreDC(DC, SaveIndex);\r\nend;\r\n\r\nfunction TJvBackgroundImage.DoEraseBackground(AClient: TWinControl; DC: HDC): Boolean;\r\nvar\r\n Graphic: TGraphic;\r\n Bmp: TBitmap;\r\nbegin\r\n Result := FPictureValid and AClient.HandleAllocated;\r\n if Result then\r\n begin\r\n Bmp := nil;\r\n try\r\n Graphic := FWorkingBmp;\r\n if Graphic = nil then\r\n Graphic := FPicture.Graphic\r\n else\r\n if Transparent then\r\n begin\r\n Bmp := TBitmap.Create;\r\n Bmp.Assign(Graphic);\r\n Bmp.Canvas.Brush := GetClientBrush(AClient);\r\n Bmp.Canvas.FillRect(Rect(0, 0, Bmp.Width, Bmp.Height));\r\n Bmp.Canvas.Draw(0, 0, Graphic);\r\n Bmp.Transparent := False;\r\n Graphic := Bmp;\r\n end;\r\n PaintGraphic(AClient, DC, Graphic);\r\n finally\r\n Bmp.Free;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJvBackgroundImage.GetTransparentColor: TColor;\r\nvar\r\n Bmp: TBitmap;\r\nbegin\r\n Bmp := nil;\r\n if FTransparentColor = clDefault then\r\n {$IFDEF HANDLES_GIF}\r\n if FPicture.Graphic is TGIFImage then\r\n Bmp := TGIFImage(FPicture.Graphic).Bitmap\r\n else\r\n {$ENDIF HANDLES_GIF}\r\n if FPicture.Graphic is TBitmap then\r\n Bmp := TBitmap(FPicture.Graphic);\r\n if Assigned(Bmp) then\r\n begin\r\n if Bmp.Monochrome then\r\n Result := clWhite\r\n else\r\n Result := Bmp.Canvas.Pixels[0, Bmp.Height - 1];\r\n end\r\n else\r\n Result := ColorToRGB(FTransparentColor);\r\n Result := Result or $02000000;\r\nend;\r\n\r\nprocedure TJvBackgroundImage.PictureChanged(Sender: TObject);\r\nbegin\r\n if FInUpdWorkingBmp then\r\n Exit;\r\n FPictureValid := (FPicture.Width > 0) and (FPicture.Height > 0);\r\n if (FTileWidth < Picture.Width) or (FTileHeight < Picture.Height) or (AutoSizeTile and FPictureValid) then\r\n begin\r\n FTileWidth := Picture.Width;\r\n FTileHeight := Picture.Height;\r\n end;\r\n with Picture do\r\n if Graphic <> nil then\r\n Graphic.Transparent := FTransparent;\r\n UpdateWorkingBmp;\r\nend;\r\n\r\nprocedure TJvBackgroundImage.SetAutoSizeTile(Value: Boolean);\r\nbegin\r\n if FAutoSizeTile <> Value then\r\n begin\r\n FAutoSizeTile := Value;\r\n if Mode = bmTile then\r\n if (TileWidth <> Picture.Width) or (TileHeight <> Picture.Height) then\r\n PictureChanged(Self);\r\n end;\r\nend;\r\n\r\nprocedure TJvBackgroundImage.SetEnabled(Value: Boolean);\r\nbegin\r\n if Value <> FEnabled then\r\n begin\r\n FEnabled := Value;\r\n Changed;\r\n end;\r\nend;\r\n\r\nprocedure TJvBackgroundImage.SetFitPictureSize(Value: Boolean);\r\nbegin\r\n if FFitPictureSize <> Value then\r\n begin\r\n FFitPictureSize := Value;\r\n if not (FMode in [bmTile, bmStretch]) then\r\n Changed;\r\n end;\r\nend;\r\n\r\nprocedure TJvBackgroundImage.SetMode(Value: TJvBackgroundMode);\r\nvar\r\n TileModeChanged: Boolean;\r\nbegin\r\n if Value <> FMode then\r\n begin\r\n TileModeChanged := (FMode = bmTile) or (Value = bmTile);\r\n FMode := Value;\r\n if TileModeChanged and ((FTileWidth <> Picture.Width) or (FTileHeight <> Picture.Height)) then\r\n PictureChanged(Self)\r\n else\r\n Changed;\r\n end;\r\nend;\r\n\r\nprocedure TJvBackgroundImage.SetPicture(Value: TPicture);\r\nbegin\r\n FPicture.Assign(Value);\r\nend;\r\n\r\nprocedure TJvBackgroundImage.SetShift(Value: Integer);\r\nbegin\r\n if Value <> FShift then\r\n begin\r\n FShift := Value;\r\n FZigZag := False;\r\n if FMode = bmTile then\r\n Changed;\r\n end;\r\nend;\r\n\r\nprocedure TJvBackgroundImage.SetShiftMode(Value: TJvBackgroundShiftMode);\r\nbegin\r\n if FShiftMode <> Value then\r\n begin\r\n FShiftMode := Value;\r\n if FMode = bmTile then\r\n Changed;\r\n end;\r\nend;\r\n\r\nprocedure TJvBackgroundImage.SetTileWidth(Value: Integer);\r\nbegin\r\n if AutoSizeTile then\r\n Exit;\r\n if Value < Picture.Width then\r\n Value := Picture.Width;\r\n if Value <> FTileWidth then\r\n begin\r\n FTileWidth := Value;\r\n if Mode = bmTile then\r\n PictureChanged(Self);\r\n end;\r\nend;\r\n\r\nprocedure TJvBackgroundImage.SetTileHeight(Value: Integer);\r\nbegin\r\n if AutoSizeTile then\r\n Exit;\r\n if Value < Picture.Height then\r\n Value := Picture.Height;\r\n if Value <> FTileHeight then\r\n begin\r\n FTileHeight := Value;\r\n if Mode = bmTile then\r\n PictureChanged(Self);\r\n end;\r\nend;\r\n\r\nprocedure TJvBackgroundImage.SetTransparent(Value: Boolean);\r\nbegin\r\n if Value <> FTransparent then\r\n begin\r\n FTransparent := Value;\r\n PictureChanged(Self);\r\n end;\r\nend;\r\n\r\nprocedure TJvBackgroundImage.SetTransparentColor(Value: TColor);\r\nbegin\r\n if Value <> FTransparentColor then\r\n begin\r\n if Value = clDefault then\r\n FTransparentMode := tmAuto\r\n else\r\n FTransparentMode := tmFixed;\r\n FTransparentColor := Value;\r\n if Transparent then\r\n UpdateWorkingBmp;\r\n end;\r\nend;\r\n\r\nprocedure TJvBackgroundImage.SetTransparentMode(Value: TTransparentMode);\r\nbegin\r\n if Value <> FTransparentMode then\r\n begin\r\n if Value = tmAuto then\r\n SetTransparentColor(clDefault)\r\n else\r\n SetTransparentColor(GetTransparentColor);\r\n end;\r\nend;\r\n\r\nprocedure TJvBackgroundImage.SetZigZag(Value: Boolean);\r\nbegin\r\n if Value <> FZigZag then\r\n begin\r\n FZigZag := Value;\r\n if FMode = bmTile then\r\n Changed;\r\n end;\r\nend;\r\n\r\nfunction TJvBackgroundImage.TransparentColorStored: Boolean;\r\nbegin\r\n Result := FTransparentMode = tmFixed;\r\nend;\r\n\r\n{\r\n TJvBackgroundImage.UpdateWorkingBmp\r\n Transparency: all except TJPEGImage\r\n GrayMapping: all except TIcon, TMetafile\r\n}\r\n\r\nprocedure TJvBackgroundImage.UpdateWorkingBmp;\r\nvar\r\n X, Y: Integer;\r\n IsBitmap: Boolean;\r\n Bmp: TBitmap;\r\n MaskBmp: TBitmap;\r\n {$IFNDEF NO_JPEG}\r\n GrayscaleState: Boolean;\r\n {$ENDIF !NO_JPEG}\r\n {$IFNDEF NO_JPEG}\r\n IsJPEG: Boolean;\r\n {$ENDIF !NO_JPEG}\r\n IsTransparent: Boolean;\r\n IsTranspGraphic: Boolean;\r\n IsIcon: Boolean;\r\n SizeTailored: Boolean;\r\n\r\n procedure DrawGraphic(Graphic: TGraphic);\r\n begin\r\n with FWorkingBmp.Canvas do\r\n begin\r\n Brush.Color := TransparentColor;\r\n FillRect(Rect(0, 0, FTileWidth, FTileHeight));\r\n Draw(X, Y, Graphic);\r\n end;\r\n end;\r\n\r\n function CreateTransparentBmp(Graphic: TGraphic): TBitmap;\r\n var\r\n W, H: Integer;\r\n begin\r\n Result := TBitmap.Create;\r\n if IsBitmap then\r\n Result.Assign(Graphic)\r\n else\r\n begin\r\n W := Graphic.Width;\r\n H := Graphic.Height;\r\n Result.Width := W;\r\n Result.Height := H;\r\n with Result.Canvas do\r\n begin\r\n Brush.Color := TransparentColor;\r\n FillRect(Rect(0, 0, W, H));\r\n Draw(0, 0, Graphic);\r\n end;\r\n end;\r\n end;\r\n\r\nbegin\r\n if FInUpdWorkingBmp then\r\n Exit;\r\n with FPicture do\r\n if Graphic <> nil then\r\n try\r\n FInUpdWorkingBmp := True;\r\n SizeTailored := False;\r\n X := 0;\r\n Y := 0;\r\n if FMode = bmTile then\r\n begin\r\n X := FTileWidth - Graphic.Width;\r\n Y := FTileHeight - Graphic.Height;\r\n SizeTailored := (X <> 0) or (Y <> 0);\r\n X := X div 2;\r\n Y := Y div 2;\r\n end;\r\n IsBitmap := (Graphic is TBitmap)\r\n // GIF goes as bitmap here\r\n {$IFDEF HANDLES_GIF} or (Graphic is TGIFImage) {$ENDIF};\r\n IsIcon := Graphic is TIcon;\r\n IsTranspGraphic := IsIcon or (Graphic is TMetafile);\r\n // if Graphic is transparent\r\n {$IFDEF NO_JPEG}\r\n IsTransparent := Transparent or IsTranspGraphic;\r\n {$ELSE}\r\n IsJPEG := Graphic is TJPEGImage;\r\n IsTransparent := (Transparent and not IsJPEG) or IsTranspGraphic;\r\n {$ENDIF NO_JPEG}\r\n if IsTransparent or FGrayMapped or SizeTailored then\r\n begin\r\n WorkingBmpNeeded;\r\n if IsTranspGraphic then\r\n with FWorkingBmp.Canvas do\r\n begin\r\n Brush.Color := TransparentColor;\r\n FillRect(Rect(0, 0, FTileWidth, FTileHeight));\r\n Draw(X, Y, Graphic);\r\n end\r\n else\r\n if IsTransparent then // and not IsTranspGraphic\r\n begin\r\n Bmp := CreateTransparentBmp(Graphic);\r\n try\r\n with TImageList.CreateSize(Graphic.Width, Graphic.Height) do\r\n try\r\n if FGrayMapped then\r\n begin\r\n MaskBmp := TBitmap.Create;\r\n with MaskBmp do\r\n try\r\n Assign(Bmp);\r\n Mask(GetTransparentColor);\r\n MapGrays(Bmp, FPicture.Graphic);\r\n Add(Bmp, MaskBmp);\r\n finally\r\n Free;\r\n end;\r\n end\r\n else\r\n AddMasked(Bmp, GetTransparentColor);\r\n FWorkingBmp.HandleType := bmDDB; // otherwise eventually background color won't appear correctly\r\n with FWorkingBmp.Canvas do\r\n begin\r\n Brush.Color := TransparentColor;\r\n FillRect(Rect(0, 0, FTileWidth, FTileHeight));\r\n end;\r\n BkColor := ColorToRGB(TransparentColor);\r\n Draw(FWorkingBmp.Canvas, X, Y, 0);\r\n finally\r\n Free;\r\n end\r\n finally\r\n Bmp.Free;\r\n end\r\n end\r\n else\r\n if GrayMapped then // and not Transparent\r\n begin\r\n Bmp := TBitmap.Create;\r\n try\r\n {$IFNDEF NO_JPEG}\r\n if IsJPEG then\r\n with TJPEGImage(Graphic) do\r\n begin\r\n GrayscaleState := Grayscale;\r\n try\r\n Grayscale := True;\r\n Bmp.Assign(Graphic);\r\n finally\r\n Grayscale := GrayscaleState;\r\n end;\r\n end;\r\n {$ENDIF !NO_JPEG}\r\n MapGrays(Bmp, FPicture.Graphic);\r\n DrawGraphic(Bmp);\r\n finally\r\n Bmp.Free;\r\n end\r\n end\r\n else // if SizeTailored\r\n DrawGraphic(Picture.Graphic);\r\n WorkingBmp.Transparent := Transparent;\r\n WorkingBmp.TransparentColor := TransparentColor;\r\n Changed;\r\n Exit;\r\n end;\r\n finally\r\n FInUpdWorkingBmp := False;\r\n end;\r\n FWorkingBmp.Free;\r\n FWorkingBmp := nil;\r\n Changed;\r\nend;\r\n\r\nprocedure TJvBackgroundImage.WorkingBmpNeeded;\r\nvar\r\n W, H: Integer;\r\nbegin\r\n if FWorkingBmp = nil then\r\n FWorkingBmp := TBitmap.Create;\r\n if FMode = bmTile then\r\n begin\r\n W := FTileWidth;\r\n H := FTileHeight;\r\n end\r\n else\r\n begin\r\n W := FPicture.Graphic.Width;\r\n H := FPicture.Graphic.Height;\r\n end;\r\n FWorkingBmp.Width := W;\r\n FWorkingBmp.Height := H;\r\nend;\r\n\r\nclass function TJvBackgroundImage.MainWindowHook(var Msg: TMessage): Boolean;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := False;\r\n if Msg.Msg = WM_SYSCOLORCHANGE then\r\n begin\r\n UpdateSysColorGradation;\r\n for I := 0 to Hooked.Count - 1 do\r\n TJvBackgroundImage(Hooked[I]).SysColorChange;\r\n end;\r\nend;\r\n\r\nprocedure TJvBackgroundImage.HookMainWindow;\r\nbegin\r\n if Hooked = nil then\r\n begin\r\n Hooked := TList.Create;\r\n Application.HookMainWindow(MainWindowHook);\r\n end;\r\n if Hooked.IndexOf(Self) = -1 then\r\n Hooked.Add(Self);\r\nend;\r\n\r\nprocedure TJvBackgroundImage.UnhookMainWindow;\r\nbegin\r\n Hooked.Remove(Self);\r\n if Hooked.Count = 0 then\r\n begin\r\n Application.UnhookMainWindow(MainWindowHook);\r\n Hooked.Free;\r\n Hooked := nil;\r\n end;\r\nend;\r\n\r\nprocedure TJvBackgroundImage.SysColorChange;\r\nbegin\r\n if FGrayMapped then\r\n UpdateWorkingBmp;\r\nend;\r\n\r\nprocedure TJvBackgroundImage.SetGrayMapped(Value: Boolean);\r\nbegin\r\n if Value <> FGrayMapped then\r\n begin\r\n if Value then\r\n SysColorsNeeded;\r\n FGrayMapped := Value;\r\n UpdateWorkingBmp;\r\n end;\r\nend;\r\n\r\n//=== { TJvControlBackground } ===============================================\r\n\r\nconstructor TJvControlBackground.Create(AClient: TWinControl);\r\nbegin\r\n inherited Create;\r\n FClient := AClient;\r\nend;\r\n\r\nfunction TJvControlBackground.HookBeforeMessage(var Msg: TMessage): Boolean;\r\nbegin\r\n Result := False;\r\n if FEnabled then\r\n case Msg.Msg of\r\n WM_PAINT:\r\n Result := HandleWMPaint(FClient, Msg);\r\n WM_ERASEBKGND:\r\n Result := HandleWMEraseBkgnd(FClient, Msg);\r\n end;\r\nend;\r\n\r\nprocedure TJvControlBackground.HookAfterMessage(var Msg: TMessage);\r\nbegin\r\n if FEnabled then\r\n case Msg.Msg of\r\n WM_SIZE:\r\n if not (FMode in [bmTile, bmTopLeft]) then\r\n FClient.Invalidate;\r\n WM_HSCROLL:\r\n if FMode <> bmTile then\r\n FClient.Invalidate;\r\n WM_VSCROLL:\r\n if FMode <> bmTile then\r\n FClient.Invalidate;\r\n end;\r\nend;\r\n\r\n//=== { TJvBackgroundClientLink } ============================================\r\n\r\nconstructor TJvBackgroundClientLink.Create(ABackground: TJvBackground;\r\n AClient: TWinControl);\r\nbegin\r\n inherited Create;\r\n FBackground := ABackground;\r\n FNewWndProc := MakeObjectInstance(MainWndProc);\r\n ForceClient(AClient);\r\n ClientInvalidate;\r\nend;\r\n\r\ndestructor TJvBackgroundClientLink.Destroy;\r\nbegin\r\n UnhookClient;\r\n if Assigned(FNewWndProc) then\r\n FreeObjectInstance(FNewWndProc);\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvBackgroundClientLink.ClientInvalidate;\r\nbegin\r\n if not (csReading in FBackground.ComponentState) and not (csDestroying in FClient.ComponentState) then\r\n Windows.InvalidateRect(ClientHandle, nil, True);\r\nend;\r\n\r\nfunction GetMDIClientScrollDelta(ClientHandle: HWND; ScrollBar: Integer;\r\n const Msg: TWMScroll): Integer;\r\nvar\r\n ScrollInfo: TScrollInfo;\r\n Delta, MaxChange: Integer;\r\nbegin\r\n ScrollInfo.cbSize := SizeOf(ScrollInfo);\r\n ScrollInfo.fMask := SIF_ALL;\r\n GetScrollInfo(ClientHandle, ScrollBar, ScrollInfo);\r\n Delta := 0;\r\n case Msg.ScrollCode of\r\n SB_LINELEFT:\r\n begin\r\n Delta := ScrollInfo.nPos - ScrollInfo.nMin;\r\n if Delta > ScrollLineSize then\r\n Delta := ScrollLineSize;\r\n end;\r\n SB_LINERIGHT:\r\n with ScrollInfo do\r\n begin\r\n Delta := nPage - 1;\r\n if Delta < 0 then\r\n Delta := 0;\r\n Delta := nPos - (nMax - Delta);\r\n if Delta < -ScrollLineSize then\r\n Delta := -ScrollLineSize;\r\n end;\r\n SB_PAGELEFT:\r\n with ScrollInfo do\r\n begin\r\n Delta := nPage - 1;\r\n if Delta < 0 then\r\n Delta := 0;\r\n if Delta > nPos - nMin then\r\n Delta := nPos - nMin;\r\n end;\r\n SB_PAGERIGHT:\r\n with ScrollInfo do\r\n begin\r\n Delta := nPage - 1;\r\n if Delta < 0 then\r\n Delta := 0;\r\n MaxChange := (nMax - Delta) - nPos;\r\n if Delta > MaxChange then\r\n Delta := MaxChange;\r\n Delta := -Delta;\r\n end;\r\n SB_THUMBPOSITION:\r\n Delta := -Msg.Pos;\r\n end;\r\n Result := Delta * ScrollUnit;\r\nend;\r\n\r\nprocedure TJvBackgroundClientLink.ClientWndProc(var Message: TMessage);\r\n\r\n procedure InvalidateBackground;\r\n begin\r\n Windows.InvalidateRect(ClientHandle, nil, True);\r\n end;\r\n\r\nbegin\r\n if ClientHandle <> 0 then\r\n with FBackground.FImage, Message do\r\n begin\r\n if ClientIsMDIForm then\r\n begin\r\n if Msg = WM_ERASEBKGND then\r\n if FEnabled and DoEraseBackground(FClient, TWMEraseBkgnd(Message).DC) then\r\n begin\r\n Result := 1;\r\n Exit;\r\n end;\r\n end\r\n else // not ClientIsMDIForm\r\n begin\r\n if FEnabled then\r\n case Msg of\r\n WM_PAINT:\r\n if HandleWMPaint(FClient, Message) then\r\n Exit;\r\n WM_ERASEBKGND:\r\n if HandleWMEraseBkgnd(FClient, Message) then\r\n Exit;\r\n end;\r\n Result := CallWindowProc(FPrevWndProc, ClientHandle, Msg, wParam, lParam);\r\n if Msg = CM_RELEASE then\r\n Exit;\r\n end;\r\n case Msg of\r\n WM_DESTROY:\r\n begin\r\n UnhookClient;\r\n if not (csDestroying in FClient.ComponentState) then\r\n PostMessage(FBackground.FHandle, CM_RECREATEWINDOW, 0, Windows.LPARAM(Self));\r\n end;\r\n WM_SIZE:\r\n if not (FMode in [bmTile, bmTopLeft]) then\r\n InvalidateBackground;\r\n WM_HSCROLL:\r\n begin\r\n if ClientIsMDIForm then\r\n Inc(FHorzOffset, GetMDIClientScrollDelta(ClientHandle,\r\n SB_HORZ, TWMScroll(Message)));\r\n if FMode <> bmTile then\r\n InvalidateBackground;\r\n end;\r\n WM_VSCROLL:\r\n begin\r\n if ClientIsMDIForm then\r\n Inc(FVertOffset, GetMDIClientScrollDelta(ClientHandle,\r\n SB_VERT, TWMScroll(Message)));\r\n if FMode <> bmTile then\r\n InvalidateBackground;\r\n end;\r\n end;\r\n if ClientIsMDIForm then\r\n Result := CallWindowProc(FPrevWndProc, ClientHandle, Msg, wParam, lParam);\r\n end;\r\nend;\r\n\r\nprocedure TJvBackgroundClientLink.MainWndProc(var Msg: TMessage);\r\nbegin\r\n try\r\n try\r\n ClientWndProc(Msg);\r\n finally\r\n //FreeDeviceContexts;\r\n FreeMemoryContexts;\r\n end;\r\n except\r\n Application.HandleException(Self);\r\n end;\r\nend;\r\n\r\nprocedure TJvBackgroundClientLink.ForceClient(Value: TWinControl; Force: Boolean = True);\r\nvar\r\n I: Integer;\r\n Bk: TJvBackground;\r\nbegin\r\n if Value <> FClient then\r\n begin\r\n for I := 0 to Backgrounds.Count - 1 do\r\n begin\r\n Bk := Backgrounds[I];\r\n if (Bk <> FBackground) and Bk.HasClient(Value) then\r\n if Force then\r\n begin\r\n Bk.Clients.Remove(Value);\r\n Break;\r\n end\r\n else\r\n Exit;\r\n end;\r\n UnhookClient;\r\n if Assigned(FClient) then\r\n FBackground.RemoveFreeNotification(FClient);\r\n FClient := Value;\r\n if Assigned(Value) then\r\n begin\r\n FClientIsMDIForm := IsMDIForm(Value);\r\n FBackground.FreeNotification(Value);\r\n if not (csLoading in FBackground.ComponentState) then\r\n HookClient;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvBackgroundClientLink.HookClient;\r\nbegin\r\n {$IFDEF NO_DESIGNHOOK}\r\n if csDesigning in ComponentState then\r\n Exit;\r\n {$ENDIF NO_DESIGNHOOK}\r\n if Assigned(FClient) and not Assigned(FPrevWndProc) then\r\n if not ((csLoading in FClient.ComponentState) or ((FClient is TCustomForm) and (csDesigning in FClient.ComponentState))) then\r\n begin\r\n FClient.HandleNeeded;\r\n FPrevWndProc := Pointer(SetWindowLongPtr(ClientHandle, GWL_WNDPROC, LONG_PTR(FNewWndProc)));\r\n FBackground.FImage.UpdateWorkingBmp;\r\n end;\r\nend;\r\n\r\nprocedure TJvBackgroundClientLink.UnhookClient;\r\nconst\r\n WorkaroundStr: array [Boolean] of string = ('', SWorkaround);\r\nbegin\r\n if Assigned(FPrevWndProc) then\r\n if Assigned(FClient) then\r\n begin\r\n if FClient.HandleAllocated then\r\n begin\r\n if (FNewWndProc <> Pointer(SetWindowLongPtr(ClientHandle, GWL_WNDPROC, LONG_PTR(FPrevWndProc)))) and\r\n not (csDestroying in FClient.ComponentState) then\r\n MessageDlg(Format(SChainError, [FBackground.Owner.Name, FBackground.Name, FClient.Name,\r\n WorkaroundStr[csDesigning in FBackground.ComponentState]]),\r\n mtWarning, [mbOK], 0);\r\n end;\r\n FPrevWndProc := nil;\r\n ClientInvalidate;\r\n FClientIsMDIForm := False;\r\n end;\r\nend;\r\n\r\nfunction TJvBackgroundClientLink.GetClientColor: TColor;\r\nbegin\r\n Result := TWinControlAccessProtected(FClient).Color;\r\nend;\r\n\r\nfunction TJvBackgroundClientLink.GetClientHandle: THandle;\r\nbegin\r\n Result := 0;\r\n if FClient is TCustomForm then\r\n Result := TForm(FClient).ClientHandle;\r\n if Result = 0 then\r\n if FClient.HandleAllocated then\r\n Result := FClient.Handle;\r\nend;\r\n\r\nprocedure TJvBackgroundClientLink.SetClient(Value: TWinControl);\r\nbegin\r\n ForceClient(Value);\r\nend;\r\n\r\nprocedure TJvBackgroundClientLink.Release;\r\nbegin\r\n UnhookClient;\r\n PostMessage(FBackground.FHandle, CM_RELEASECLIENTLINK, 0, LPARAM(Self));\r\nend;\r\n\r\n//=== { TJvBackgroundClients } ===============================================\r\n\r\nconstructor TJvBackgroundClients.Create(ABackground: TJvBackground);\r\nbegin\r\n inherited Create;\r\n FBackground := ABackground;\r\n FLinks := TObjectList.Create;\r\n FLinks.OwnsObjects := False;\r\n FFixups := TStringList.Create;\r\nend;\r\n\r\ndestructor TJvBackgroundClients.Destroy;\r\nbegin\r\n FFixups.Free;\r\n Clear(True); // release links immediatelly (the WndProc won't work because the handle is destroyed)\r\n FLinks.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvBackgroundClients.Clear(Immediatelly: Boolean = False);\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := 0 to FLinks.Count - 1 do\r\n if Immediatelly then\r\n Links[I].Free\r\n else\r\n Links[I].Release;\r\n FLinks.Clear;\r\nend;\r\n\r\nprocedure TJvBackgroundClients.Add(Control: TWinControl);\r\nbegin\r\n if IndexOf(Control) < 0 then\r\n FLinks.Add(TJvBackgroundClientLink.Create(FBackground, Control));\r\nend;\r\n\r\nprocedure TJvBackgroundClients.Remove(Control: TWinControl);\r\nvar\r\n I: Integer;\r\n Link: TJvBackgroundClientLink;\r\nbegin\r\n I := IndexOf(Control);\r\n if I >= 0 then\r\n begin\r\n Link := TJvBackgroundClientLink(Links[I]);\r\n FLinks.Delete(I);\r\n Link.Release;\r\n end;\r\nend;\r\n\r\nfunction TJvBackgroundClients.GetClient(Index: Integer): TWinControl;\r\nbegin\r\n Result := TJvBackgroundClientLink(FLinks[Index]).Client;\r\nend;\r\n\r\nfunction TJvBackgroundClients.IndexOf(Control: TWinControl): Integer;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := -1;\r\n for I := 0 to FLinks.Count - 1 do\r\n if Links[I].Client = Control then\r\n begin\r\n Result := I;\r\n Exit;\r\n end;\r\nend;\r\n\r\nprocedure TJvBackgroundClients.Notification(AComponent: TComponent; Operation: TOperation);\r\nvar\r\n I: Integer;\r\n Client: TWinControl;\r\nbegin\r\n if Operation = opRemove then\r\n for I := 0 to FLinks.Count - 1 do\r\n begin\r\n Client := Links[I].Client;\r\n if AComponent = Client then\r\n Remove(Client);\r\n end;\r\nend;\r\n\r\nprocedure TJvBackgroundClients.DefineProperties(Filer: TFiler);\r\n\r\n function WriteClients: Boolean;\r\n var\r\n I: Integer;\r\n AncestorClients: TJvBackgroundClients;\r\n begin\r\n AncestorClients := TJvBackgroundClients(Filer.Ancestor);\r\n if AncestorClients = nil then\r\n Result := True // FLinks.Count > 0\r\n else\r\n if AncestorClients.FLinks.Count <> FLinks.Count then\r\n Result := True\r\n else\r\n begin\r\n Result := False;\r\n for I := 0 to FLinks.Count - 1 do\r\n begin\r\n Result := not (Clients[I] = AncestorClients[I]);\r\n if Result then\r\n Break;\r\n end\r\n end;\r\n end;\r\n\r\nbegin\r\n inherited DefineProperties(Filer);\r\n Filer.DefineProperty('Clients', ReadData, WriteData, WriteClients);\r\nend;\r\n\r\nprocedure TJvBackgroundClients.ReadData(Reader: TReader);\r\nbegin\r\n Reader.ReadListBegin;\r\n while not Reader.EndOfList do\r\n FFixups.Add(Reader.ReadString);\r\n Reader.ReadListEnd;\r\nend;\r\n\r\nprocedure TJvBackgroundClients.WriteData(Writer: TWriter);\r\nvar\r\n I: Integer;\r\nbegin\r\n Writer.WriteListBegin;\r\n for I := 0 to FLinks.Count - 1 do\r\n Writer.WriteString(Clients[I].Name);\r\n Writer.WriteListEnd;\r\nend;\r\n\r\nprocedure TJvBackgroundClients.FixupReferences(Root: TComponent);\r\nvar\r\n I: Integer;\r\n S: string;\r\n NextItem: TComponent;\r\nbegin\r\n FLinks.Clear;\r\n with FFixups do\r\n begin\r\n FLinks.Capacity := Capacity;\r\n for I := 0 to Count - 1 do\r\n begin\r\n S := Strings[I];\r\n if Root.Name = S then\r\n NextItem := Root\r\n else\r\n NextItem := Root.FindComponent(Strings[I]);\r\n if NextItem = nil then\r\n Break;\r\n if NextItem is TWinControl then\r\n Self.Add(TWinControl(NextItem));\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJvBackgroundClients.GetLink(Index: Integer): TJvBackgroundClientLink;\r\nbegin\r\n Result := TJvBackgroundClientLink(FLinks[Index]);\r\nend;\r\n\r\nprocedure TJvBackgroundClients.Invalidate;\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := 0 to FLinks.Count - 1 do\r\n Links[I].ClientInvalidate;\r\nend;\r\n\r\n//=== { TJvBackground } ======================================================\r\n\r\nvar\r\n Registered: Boolean = False;\r\n\r\nconstructor TJvBackground.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FHandle := AllocateHWnd(WndProc);\r\n FImage := TJvBackgroundImage.Create;\r\n FImage.FOnChange := WallpaperChanged;\r\n if Backgrounds = nil then\r\n Backgrounds := TList.Create;\r\n Backgrounds.Add(Self);\r\n FClients := TJvBackgroundClients.Create(Self);\r\n if csDesigning in ComponentState then\r\n if Assigned(Owner) then\r\n if Owner is TWinControl then\r\n FClients.Add(TWinControl(Owner));\r\n if not Registered then\r\n begin\r\n Classes.RegisterClasses([TJvBackgroundImage]);\r\n Registered := True;\r\n end;\r\nend;\r\n\r\ndestructor TJvBackground.Destroy;\r\nbegin\r\n DeallocateHWnd(FHandle);\r\n FClients.Free;\r\n Backgrounds.Remove(Self);\r\n FImage.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvBackground.Loaded;\r\nbegin\r\n inherited Loaded;\r\n FClients.FixupReferences(Owner);\r\nend;\r\n\r\nprocedure TJvBackground.Notification(AComponent: TComponent; Operation: TOperation);\r\nbegin\r\n if not (csDestroying in ComponentState) and Assigned(FClients) then\r\n FClients.Notification(AComponent, Operation);\r\n inherited Notification(AComponent, Operation);\r\nend;\r\n\r\nprocedure TJvBackground.SetClients(Value: TJvBackgroundClients);\r\nbegin\r\n // dummy method to make Clients property visible in Object Inspector\r\nend;\r\n\r\nprocedure TJvBackground.WallpaperChanged;\r\nbegin\r\n Clients.Invalidate;\r\nend;\r\n\r\nprocedure TJvBackground.WndProc(var Msg: TMessage);\r\nbegin\r\n try\r\n case Msg.Msg of\r\n CM_RECREATEWINDOW:\r\n TJvBackgroundClientLink(Msg.lParam).HookClient;\r\n CM_RELEASECLIENTLINK:\r\n TJvBackgroundClientLink(Msg.lParam).Free;\r\n else\r\n Msg.Result := DefWindowProc(FHandle, Msg.Msg, Msg.wParam, Msg.lParam);\r\n end;\r\n except\r\n Application.HandleException(Self);\r\n end;\r\nend;\r\n\r\nprocedure TJvBackground.SetImage(const Value: TJvBackgroundImage);\r\nbegin\r\n FImage.Assign(Value);\r\nend;\r\n\r\nfunction TJvBackground.HasClient(Control: TWinControl): Boolean;\r\nbegin\r\n Result := Clients.IndexOf(Control) >= 0;\r\nend;\r\n\r\ninitialization\r\n {$IFDEF UNITVERSIONING}\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n {$ENDIF UNITVERSIONING}\r\n\r\nfinalization\r\n FreeAndNil(Hooked);\r\n FreeAndNil(Backgrounds);\r\n {$IFDEF UNITVERSIONING}\r\n UnregisterUnitVersion(HInstance);\r\n {$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvBalloonHint.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvBalloonHint.PAS, released on 2001-02-28.\r\n\r\nThe Initial Developer of the Original Code is Remko Bonte \r\nPortions created by Remko Bonte are Copyright (C) 2002 Remko Bonte.\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\n\r\n 2006-01-17 - J. Vignoles - Added support for Unicode hint and header\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n * Only dropdown shadow for windows xp systems.\r\n * Only custom animation for windows xp systems, because of use of window region.\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvBalloonHint.pas 13415 2012-09-10 09:51:54Z obones $\r\n\r\nunit JvBalloonHint;\r\n\r\n{$I jvcl.inc}\r\n{$I windowsonly.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, Messages, Classes, Controls, Graphics, Forms, ImgList,\r\n {$IFDEF HAS_UNIT_SYSTEM_UITYPES}\r\n System.UITypes,\r\n {$ENDIF HAS_UNIT_SYSTEM_UITYPES}\r\n JvComponentBase;\r\n\r\nconst\r\n cJvBallonHintVisibleTimeDefault = 5000;\r\n\r\ntype\r\n TJvStemSize = (ssExtraSmall, ssSmall, ssNormal, ssLarge);\r\n TJvIconKind = (ikCustom, ikNone, ikApplication, ikError, ikInformation, ikQuestion, ikWarning);\r\n TJvBalloonOption = (boUseDefaultHeader, boUseDefaultIcon, boUseDefaultImageIndex,\r\n boShowCloseBtn, boCustomAnimation, boPlaySound);\r\n TJvBalloonOptions = set of TJvBalloonOption;\r\n TJvApplicationHintOption = (ahShowHeaderInHint, ahShowIconInHint, ahPlaySound);\r\n TJvApplicationHintOptions = set of TJvApplicationHintOption;\r\n TJvBalloonPosition = (bpAuto, bpLeftDown, bpRightDown, bpLeftUp, bpRightUp);\r\n TJvAnimationStyle = (atNone, atSlide, atRoll, atRollHorNeg, atRollHorPos, atRollVerNeg,\r\n atRollVerPos, atSlideHorNeg, atSlideHorPos, atSlideVerNeg, atSlideVerPos, atCenter, atBlend);\r\n\r\n TJvBalloonHint = class;\r\n\r\n PHintData = ^THintData;\r\n THintData = record\r\n RAnchorWindow: TCustomForm;\r\n { Position of the top-left edge of the window balloon inside the client\r\n rect of the anchor window (Used to move the balloon window if the\r\n anchor window moves): }\r\n RAnchorPosition: TPoint;\r\n { Position of the stem point inside the client rect of the balloon window\r\n (Used the check on resize of the anchor window whether the stem point is\r\n still inside the balloon window): }\r\n RStemPointPosition: TPoint;\r\n RUTF8Header: {$IFDEF RTL200_UP}UTF8String{$ELSE}string{$ENDIF RTL200_UP};\r\n RUTF8Hint: {$IFDEF RTL200_UP}UTF8String{$ELSE}string{$ENDIF RTL200_UP};\r\n RIconKind: TJvIconKind;\r\n RImageIndex: TImageIndex;\r\n RVisibleTime: Integer;\r\n RShowCloseBtn: Boolean;\r\n RAnimationStyle: TJvAnimationStyle;\r\n RAnimationTime: Cardinal;\r\n { If the position of the balloon needs to be changed - for example if\r\n DefaultBalloonPosition = bpAuto - RSwitchHeight indicates how much we\r\n change the vertical position; if the balloon is an application hint,\r\n RSwitchHeight is the height of the cursor; if the balloon is attached to\r\n a control, RSwitchHeight is the height of that control }\r\n RSwitchHeight: Integer;\r\n end;\r\n\r\n TJvBalloonWindow = class(THintWindow)\r\n private\r\n FCurrentPosition: TJvBalloonPosition;\r\n FSwitchHeight: Integer;\r\n FShowIcon: Boolean;\r\n FShowHeader: Boolean;\r\n FMsg: WideString;\r\n FHeader: WideString;\r\n FTipHeight: Integer;\r\n FTipWidth: Integer;\r\n FTipDelta: Integer;\r\n FImageSize: TSize;\r\n\r\n FIconPos: TPoint;\r\n FRoundRect: TRect;\r\n FStemRect: TRect;\r\n FMsgRect: TRect;\r\n FHeaderRect: TRect;\r\n FCloseBtnRect: TRect;\r\n FShowCloseBtn: Boolean;\r\n FIsMultiLineMsg: Boolean;\r\n FUseRegion: Boolean;\r\n\r\n function GetStemPointPosition: TPoint;\r\n function GetStemPointPositionInRect(const ARect: TRect): TPoint;\r\n function MultiLineWidth(const Value: string): Integer;\r\n protected\r\n procedure CMTextChanged(var Msg: TMessage); message CM_TEXTCHANGED;\r\n procedure CMShowingChanged(var Msg: TMessage); message CM_SHOWINGCHANGED;\r\n procedure WMEraseBkgnd(var Msg: TWMEraseBkgnd); message WM_ERASEBKGND;\r\n procedure CreateParams(var Params: TCreateParams); override;\r\n procedure NCPaint(DC: HDC); override;\r\n procedure Paint; override;\r\n\r\n {$IFDEF JVCLThemesEnabled}\r\n function CreateThemedRegion: HRGN;\r\n {$ENDIF JVCLThemesEnabled}\r\n function CreateRegion: HRGN;\r\n procedure UpdateRegion;\r\n procedure CalcAutoPosition(var ARect: TRect);\r\n procedure CheckPosition(var ARect: TRect);\r\n\r\n function CalcOffset(const ARect: TRect): TPoint;\r\n procedure MeasureHeader(const MaxWidth: Integer; var AWidth, AHeight: Integer); virtual;\r\n procedure MeasureMsg(const MaxWidth: Integer; var AWidth, AHeight: Integer); virtual;\r\n procedure Init(AData: Pointer); virtual;\r\n procedure CreateWnd; override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n procedure ActivateHint(Rect: TRect; const AHint: string); override;\r\n function CalcHintRect(MaxWidth: Integer; const AHint: string;\r\n AData: Pointer): TRect; override;\r\n function CalcHintRectUTF8(MaxWidth: Integer; const AUTF8Hint: {$IFDEF RTL200_UP}UTF8String{$ELSE}string{$ENDIF RTL200_UP};\r\n AData: Pointer): TRect; virtual;\r\n function CalcHintRectW(MaxWidth: Integer; const AHint: WideString;\r\n AData: Pointer): TRect; virtual;\r\n property StemPointPosition: TPoint read GetStemPointPosition;\r\n end;\r\n\r\n TJvBalloonWindowEx = class(TJvBalloonWindow)\r\n private\r\n FCtrl: TJvBalloonHint;\r\n FCloseState: Cardinal;\r\n FImageIndex: TImageIndex;\r\n FIconKind: TJvIconKind;\r\n FAnimationTime: Cardinal;\r\n FAnimationStyle: TJvAnimationStyle;\r\n FIsAnchored: Boolean;\r\n protected\r\n procedure WMNCHitTest(var Msg: TWMNCHitTest); message WM_NCHITTEST;\r\n procedure WMMouseMove(var Msg: TWMMouseMove); message WM_MOUSEMOVE;\r\n procedure WMLButtonDown(var Msg: TWMLButtonDown); message WM_LBUTTONDOWN;\r\n procedure WMLButtonUp(var Msg: TWMLButtonUp); message WM_LBUTTONUP;\r\n procedure WMActivateApp(var Msg: TWMActivateApp); message WM_ACTIVATEAPP;\r\n\r\n procedure Paint; override;\r\n\r\n { Either calls NormalizeTopMost or RestoreTopMost depending on whether the\r\n anchor window has focus }\r\n procedure EnsureTopMost;\r\n { Sets the balloon on top of anchor window; but below other windows }\r\n procedure NormalizeTopMost;\r\n { Sets the balloon top most }\r\n procedure RestoreTopMost;\r\n\r\n procedure InternalActivateHint(var Rect: TRect; const AHint: string);\r\n procedure MoveWindow(NewPos: TPoint);\r\n procedure ChangeCloseState(const AState: Cardinal);\r\n\r\n procedure Init(AData: Pointer); override;\r\n end;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvBalloonHint = class(TJvComponent)\r\n private\r\n FHint: TJvBalloonWindowEx;\r\n FActive: Boolean;\r\n FOptions: TJvBalloonOptions;\r\n FImages: TCustomImageList;\r\n FDefaultHeader: WideString;\r\n FDefaultIcon: TJvIconKind;\r\n FDefaultImageIndex: TImageIndex;\r\n FData: THintData;\r\n FApplicationHintOptions: TJvApplicationHintOptions;\r\n FDefaultBalloonPosition: TJvBalloonPosition;\r\n FCustomAnimationTime: Cardinal;\r\n FCustomAnimationStyle: TJvAnimationStyle;\r\n\r\n FOnBalloonClick: TNotifyEvent;\r\n FOnClose: TNotifyEvent;\r\n FOnCloseBtnClick: TCloseQueryEvent;\r\n FOnDblClick: TNotifyEvent;\r\n FOnMouseDown: TMouseEvent;\r\n FOnMouseMove: TMouseMoveEvent;\r\n FOnMouseUp: TMouseEvent;\r\n\r\n FHandle: THandle;\r\n FTimerActive: Boolean;\r\n FMaxWidth: Integer;\r\n\r\n function GetHandle: THandle;\r\n function GetUseBalloonAsApplicationHint: Boolean;\r\n procedure SetImages(const Value: TCustomImageList);\r\n procedure SetOptions(const Value: TJvBalloonOptions);\r\n procedure SetUseBalloonAsApplicationHint(const Value: Boolean);\r\n protected\r\n function HookProc(var Msg: TMessage): Boolean;\r\n procedure Hook;\r\n procedure UnHook;\r\n\r\n procedure HandleMouseDown(Sender: TObject; Button: TMouseButton;\r\n Shift: TShiftState; X, Y: Integer);\r\n procedure HandleMouseUp(Sender: TObject; Button: TMouseButton;\r\n Shift: TShiftState; X, Y: Integer);\r\n procedure HandleMouseMove(Sender: TObject; Shift: TShiftState;\r\n X, Y: Integer);\r\n procedure HandleClick(Sender: TObject);\r\n procedure HandleDblClick(Sender: TObject);\r\n function HandleCloseBtnClick: Boolean;\r\n procedure Notification(AComponent: TComponent; Operation: TOperation); override;\r\n\r\n procedure StartHintTimer(Value: Integer);\r\n procedure StopHintTimer;\r\n\r\n procedure InternalActivateHintPos;\r\n procedure InternalActivateHint(ACtrl: TControl);\r\n\r\n procedure WndProc(var Msg: TMessage);\r\n\r\n property Handle: THandle read GetHandle;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n\r\n procedure ActivateHint(ACtrl: TControl; const AHint: WideString; const AHeader: WideString = '';\r\n const VisibleTime: Integer = cJvBallonHintVisibleTimeDefault); overload;\r\n procedure ActivateHint(ACtrl: TControl; const AHint: WideString; const AImageIndex: TImageIndex;\r\n const AHeader: WideString = ''; const VisibleTime: Integer = cJvBallonHintVisibleTimeDefault); overload;\r\n procedure ActivateHint(ACtrl: TControl; const AHint: WideString; const AIconKind: TJvIconKind;\r\n const AHeader: WideString = ''; const VisibleTime: Integer = cJvBallonHintVisibleTimeDefault); overload;\r\n procedure ActivateHintPos(AAnchorWindow: TCustomForm; AAnchorPosition: TPoint;\r\n const AHeader, AHint: WideString; const VisibleTime: Integer = cJvBallonHintVisibleTimeDefault;\r\n const AIconKind: TJvIconKind = ikInformation; const AImageIndex: TImageIndex = -1);\r\n procedure ActivateHintRect(ARect: TRect; const AHeader, AHint: WideString;\r\n const VisibleTime: Integer = cJvBallonHintVisibleTimeDefault; const AIconKind: TJvIconKind = ikInformation;\r\n const AImageIndex: TImageIndex = -1);\r\n procedure CancelHint;\r\n\r\n property Active: Boolean read FActive;\r\n published\r\n property CustomAnimationStyle: TJvAnimationStyle read FCustomAnimationStyle write\r\n FCustomAnimationStyle default atBlend;\r\n property CustomAnimationTime: Cardinal read FCustomAnimationTime write FCustomAnimationTime\r\n default 100;\r\n property DefaultBalloonPosition: TJvBalloonPosition read FDefaultBalloonPosition write\r\n FDefaultBalloonPosition default bpAuto;\r\n property DefaultImageIndex: TImageIndex read FDefaultImageIndex write FDefaultImageIndex\r\n default -1;\r\n property DefaultHeader: WideString read FDefaultHeader write FDefaultHeader;\r\n property DefaultIcon: TJvIconKind read FDefaultIcon write FDefaultIcon default ikInformation;\r\n property Images: TCustomImageList read FImages write SetImages;\r\n property Options: TJvBalloonOptions read FOptions write SetOptions default [boShowCloseBtn];\r\n property ApplicationHintOptions: TJvApplicationHintOptions read FApplicationHintOptions write\r\n FApplicationHintOptions default [ahShowHeaderInHint, ahShowIconInHint];\r\n property UseBalloonAsApplicationHint: Boolean read GetUseBalloonAsApplicationHint write\r\n SetUseBalloonAsApplicationHint default False;\r\n\r\n property MaxWidth: Integer read FMaxWidth write FMaxWidth default 0;\r\n\r\n property OnBalloonClick: TNotifyEvent read FOnBalloonClick write FOnBalloonClick;\r\n property OnCloseBtnClick: TCloseQueryEvent read FOnCloseBtnClick write FOnCloseBtnClick;\r\n property OnClose: TNotifyEvent read FOnClose write FOnClose;\r\n property OnDblClick: TNotifyEvent read FOnDblClick write FOnDblClick;\r\n property OnMouseDown: TMouseEvent read FOnMouseDown write FOnMouseDown;\r\n property OnMouseMove: TMouseMoveEvent read FOnMouseMove write FOnMouseMove;\r\n property OnMouseUp: TMouseEvent read FOnMouseUp write FOnMouseUp;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvBalloonHint.pas $';\r\n Revision: '$Revision: 13415 $';\r\n Date: '$Date: 2012-09-10 11:51:54 +0200 (lun. 10 sept. 2012) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n SysUtils, Math,\r\n Registry, CommCtrl, MMSystem,\r\n {$IFDEF JVCLThemesEnabled}\r\n UxTheme,\r\n {$IFNDEF COMPILER7_UP}\r\n TmSchema,\r\n {$ENDIF !COMPILER7_UP}\r\n {$ENDIF JVCLThemesEnabled}\r\n {$IFDEF SUPPORTS_INLINE}\r\n Types,\r\n {$ENDIF SUPPORTS_INLINE}\r\n ComCtrls, // needed for GetComCtlVersion\r\n {$IFNDEF COMPILER12_UP}\r\n JvJCLUtils,\r\n {$ENDIF ~COMPILER12_UP}\r\n JvJVCLUtils, JvThemes, JvWndProcHook, JvWin32,\r\n JclStringConversions, JclUnicode;\r\n\r\nconst\r\n { TJvStemSize = (ssSmall, ssNormal, ssLarge);\r\n ssLarge isn't used (yet)\r\n }\r\n cTipHeight: array [TJvStemSize] of Integer = (12, 19, 21, 24);\r\n cTipWidth: array [TJvStemSize] of Integer = (12, 19, 21, 24);\r\n cTipDelta: array [TJvStemSize] of Integer = (16, 16, 16, 17);\r\n DefaultTextFlags: Longint = DT_LEFT or DT_WORDBREAK or DT_EXPANDTABS or DT_NOPREFIX;\r\n\r\n{$IFDEF JVCLThemesEnabled}\r\nconst\r\n {$IFNDEF DELPHI11_UP}\r\n TTBSS_POINTINGUPLEFTWALL = 1;\r\n TTBSS_POINTINGUPCENTERED = 2;\r\n TTBSS_POINTINGUPRIGHTWALL = 3;\r\n TTBSS_POINTINGDOWNRIGHTWALL = 4;\r\n TTBSS_POINTINGDOWNCENTERED = 5;\r\n TTBSS_POINTINGDOWNLEFTWALL = 6;\r\n\r\n TTP_BALLOONSTEM = 6;\r\n {$ENDIF !DELPHI11_UP}\r\n\r\n cBalloonStemState: array [TJvBalloonPosition] of Integer = (\r\n TTBSS_POINTINGUPRIGHTWALL, // bpAuto\r\n TTBSS_POINTINGUPRIGHTWALL, // bpLeftDown\r\n TTBSS_POINTINGUPLEFTWALL, // bpRightDown\r\n TTBSS_POINTINGDOWNRIGHTWALL, // bpLeftUp\r\n TTBSS_POINTINGDOWNLEFTWALL // bpRightUp\r\n );\r\n{$ENDIF JVCLThemesEnabled}\r\n\r\n// Unicode wrapping around DrawTextW so that if ran under Win98/Me, it\r\n// continues to work.\r\ntype\r\n TDrawTextW = function(hDC: HDC; lpString: PWideChar; nCount: Integer;\r\n var lpRect: TRect; uFormat: UINT): Integer; stdcall;\r\n\r\nvar\r\n _DrawTextW: TDrawTextW = nil;\r\n\r\nprocedure InitUnicodeWrap;\r\nvar\r\n UserHandle: HMODULE;\r\nbegin\r\n { The system DLLs for Windows 98 have export symbols for wide character\r\n functions as well, but they all return FALSE, and GetLastError would return\r\n ERROR_CALL_NOT_IMPLEMENTED (120), so don't try to load DrawTextW for\r\n Windows 98 }\r\n\r\n if Win32Platform = VER_PLATFORM_WIN32_NT then\r\n begin\r\n { All Windows programs already load user32.dll so we can use GetModuleHandle }\r\n UserHandle := GetModuleHandle('USER32');\r\n if UserHandle <> 0 then\r\n @_DrawTextW := GetProcAddress(UserHandle, 'DrawTextW');\r\n end;\r\nend;\r\n\r\nfunction DrawTextW(hDC: HDC; const WS: WideString; var lpRect: TRect; uFormat: UINT): Integer;\r\nvar\r\n S: string;\r\nbegin\r\n if Assigned(_DrawTextW) then\r\n Result := _DrawTextW(hDC, PWideChar(WS), Length(WS), lpRect, uFormat)\r\n else\r\n begin\r\n { The Microsoft Layer for Unicode dll UNICOWS.DLL does probably the same as\r\n the following: }\r\n S := WideCharLenToString(PWideChar(WS), Length(WS));\r\n Result := DrawTextA(hDC, PAnsiChar(AnsiString(S)), Length(S), lpRect, uFormat);\r\n end;\r\nend;\r\n\r\nfunction WorkAreaRect: TRect;\r\nbegin\r\n SystemParametersInfo(SPI_GETWORKAREA, 0, @Result, 0);\r\nend;\r\n\r\nfunction DesktopRect: TRect;\r\nbegin\r\n Result := Rect(GetSystemMetrics(SM_XVIRTUALSCREEN),\r\n GetSystemMetrics(SM_YVIRTUALSCREEN),\r\n GetSystemMetrics(SM_CXVIRTUALSCREEN),\r\n GetSystemMetrics(SM_CYVIRTUALSCREEN));\r\nend;\r\n\r\nfunction IsWinXP_UP: Boolean;\r\nbegin\r\n Result := (Win32Platform = VER_PLATFORM_WIN32_NT) and CheckWin32Version(5, 1);\r\nend;\r\n\r\nfunction IsWinVista_UP: Boolean;\r\nbegin\r\n Result := (Win32Platform = VER_PLATFORM_WIN32_NT) and CheckWin32Version(6, 0);\r\nend;\r\n\r\nfunction IsWinSeven_UP: Boolean;\r\nbegin\r\n Result := (Win32Platform = VER_PLATFORM_WIN32_NT) and CheckWin32Version(6, 1);\r\nend;\r\n\r\nfunction InternalClientToParent(AControl: TControl; const Point: TPoint;\r\n AParent: TWinControl): TPoint;\r\nbegin\r\n Result := AControl.ClientToParent(Point, AParent);\r\nend;\r\n\r\nprocedure GetHintMessageFont(AFont: TFont);\r\nbegin\r\n AFont.Assign(Screen.HintFont);\r\n AFont.Style := AFont.Style - [fsBold];\r\nend;\r\n\r\nprocedure GetHintTitleFont(AFont: TFont);\r\n{$IFDEF JVCLThemesEnabled}\r\nvar\r\n AThemedTextColor: Integer;\r\n Result: Boolean;\r\n LogFontW: TLogFontW;\r\n{$ENDIF JVCLThemesEnabled}\r\nbegin\r\n {$IFDEF JVCLThemesEnabled}\r\n if IsWinVista_UP and ThemeServices.{$IFDEF RTL230_UP}Enabled{$ELSE}ThemesEnabled{$ENDIF RTL230_UP} then\r\n begin\r\n Result := GetThemeEnumValue(ThemeServices.Theme[teToolTip], TTP_BALLOONTITLE, 0,\r\n TMT_TEXTCOLOR, AThemedTextColor) = S_OK;\r\n if Result then\r\n begin\r\n // GetThemeFont is defined wrong; so cast it\r\n Result := GetThemeFont(ThemeServices.Theme[teToolTip], 0, TTP_BALLOONTITLE, 0,\r\n TMT_FONT, {$IFDEF COMPILER12_UP}PLogFontW{$ELSE}PLogFontA{$ENDIF COMPILER12_UP}(@LogFontW)^) = S_OK;\r\n\r\n if Result then\r\n begin\r\n AFont.Color := AThemedTextColor;\r\n AFont.Handle := CreateFontIndirectW(LogFontW);\r\n Exit;\r\n end;\r\n end;\r\n end;\r\n {$ENDIF JVCLThemesEnabled}\r\n AFont.Assign(Screen.HintFont);\r\n AFont.Style := AFont.Style + [fsBold];\r\nend;\r\n\r\nfunction IsMultiLineStr(const Value: WideString): Boolean;\r\nvar\r\n Head, Tail: PWideChar;\r\n LineCount: Integer;\r\nbegin\r\n // stripped copy of TWideStrings.SetText\r\n LineCount := 0;\r\n Head := PWideChar(Value);\r\n while (Head^ <> WideNull) and (LineCount < 2) do\r\n begin\r\n Tail := Head;\r\n {$IFDEF COMPILER12_UP}\r\n while not CharInSet(Tail^, [WideNull, WideLineFeed, WideCarriageReturn, WideVerticalTab, WideFormFeed]) and\r\n {$ELSE}\r\n while not (Tail^ in [WideNull, WideLineFeed, WideCarriageReturn, WideVerticalTab, WideFormFeed]) and\r\n {$ENDIF COMPILER12_UP}\r\n (Tail^ <> WideLineSeparator) and (Tail^ <> WideParagraphSeparator) do\r\n Inc(Tail);\r\n Inc(LineCount);\r\n Head := Tail;\r\n if Head^ <> WideNull then\r\n begin\r\n Inc(Head);\r\n if (Tail^ = WideCarriageReturn) and (Head^ = WideLineFeed) then\r\n Inc(Head);\r\n end;\r\n end;\r\n Result := LineCount >= 2;\r\nend;\r\n\r\ntype\r\n TGlobalCtrl = class(TComponent)\r\n private\r\n FBkColor: TColor;\r\n FCtrls: TList;\r\n FDefaultImages: TImageList;\r\n FNeedUpdateBkColor: Boolean;\r\n FOldHintWindowClass: THintWindowClass;\r\n FSounds: array [TJvIconKind] of string;\r\n FUseBalloonAsApplicationHint: Boolean;\r\n FDesigning: Boolean;\r\n function GetMainCtrl: TJvBalloonHint;\r\n procedure GetDefaultImages;\r\n procedure GetDefaultSounds;\r\n procedure SetBkColor(const Value: TColor);\r\n procedure SetUseBalloonAsApplicationHint(const Value: Boolean);\r\n protected\r\n procedure Add(ABalloonHint: TJvBalloonHint);\r\n procedure Remove(ABalloonHint: TJvBalloonHint);\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n function HintImageSize: TSize; overload;\r\n function HintImageSize(const AIconKind: TJvIconKind;\r\n const AImageIndex: TImageIndex): TSize; overload;\r\n procedure DrawHintImage(Canvas: TCanvas; X, Y: Integer; const ABkColor: TColor); overload;\r\n procedure DrawHintImage(Canvas: TCanvas; X, Y: Integer; const AIconKind: TJvIconKind;\r\n const AImageIndex: TImageIndex; const ABkColor: TColor); overload;\r\n procedure PlaySound(const AIconKind: TJvIconKind);\r\n\r\n property BkColor: TColor read FBkColor write SetBkColor;\r\n property MainCtrl: TJvBalloonHint read GetMainCtrl;\r\n property UseBalloonAsApplicationHint: Boolean read FUseBalloonAsApplicationHint\r\n write SetUseBalloonAsApplicationHint;\r\n end;\r\n\r\nvar\r\n GGlobalCtrl: TGlobalCtrl = nil;\r\n { A TJvBalloonHint may be needed, while there isn't an instance of it around.\r\n For example, if the user sets HintWindowClass to TJvBalloonWindow.\r\n }\r\n GMainCtrl: TJvBalloonHint = nil;\r\n\r\nfunction GlobalCtrl: TGlobalCtrl;\r\nbegin\r\n if not Assigned(GGlobalCtrl) then\r\n GGlobalCtrl := TGlobalCtrl.Create(nil);\r\n Result := GGlobalCtrl;\r\nend;\r\n\r\n//=== { TJvBalloonWindow } ===================================================\r\n\r\nconstructor TJvBalloonWindow.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n ControlStyle := [csCaptureMouse, csClickEvents, csDoubleClicks];\r\nend;\r\n\r\nvar\r\n OldAnimateWindowProc: TAnimateWindowProc;\r\n\r\nfunction JvAnimateWindowProc(hWnd: HWND; dwTime: DWORD; dwFlags: DWORD): BOOL; stdcall;\r\nbegin\r\n SendMessage(hWnd, CM_RECREATEWND, 0, 0);\r\n Result := OldAnimateWindowProc(hWnd, dwTime, dwFlags);\r\nend;\r\n\r\n{$IFNDEF COMPILER7_UP}\r\nconst\r\n ComCtlVersionIE6 = $00060000;\r\n{$ENDIF !COMPILER7_UP}\r\n\r\nprocedure TJvBalloonWindow.ActivateHint(Rect: TRect; const AHint: string);\r\nvar\r\n Delta: Integer;\r\nbegin\r\n ParentWindow := Application.Handle;\r\n if IsWinVista_UP and (GetComCtlVersion >= ComCtlVersionIE6) then\r\n RecreateWnd;\r\n if HandleAllocated and IsWindowVisible(Handle) then\r\n ShowWindow(Handle, SW_HIDE);\r\n\r\n if UseRightToLeftAlignment then\r\n begin\r\n // Remove the offset set by TApplication.ActivateHint\r\n Delta := MultiLineWidth(AHint) + 5;\r\n Inc(Rect.Left, Delta);\r\n Inc(Rect.Right, Delta);\r\n end;\r\n CheckPosition(Rect);\r\n UpdateRegion;\r\n\r\n Inc(Rect.Bottom, 4);\r\n UpdateBoundsRect(Rect);\r\n Dec(Rect.Bottom, 4);\r\n\r\n if ahPlaySound in GlobalCtrl.MainCtrl.ApplicationHintOptions then\r\n GlobalCtrl.PlaySound(GlobalCtrl.MainCtrl.DefaultIcon);\r\n if IsWinVista_UP and (GetComCtlVersion < ComCtlVersionIE6) then\r\n begin\r\n OldAnimateWindowProc := AnimateWindowProc;\r\n AnimateWindowProc := JvAnimateWindowProc;\r\n try\r\n inherited ActivateHint(Rect, AHint);\r\n finally\r\n AnimateWindowProc := OldAnimateWindowProc;\r\n end;\r\n end\r\n else\r\n inherited ActivateHint(Rect, AHint);\r\nend;\r\n\r\nprocedure TJvBalloonWindow.CalcAutoPosition(var ARect: TRect);\r\nvar\r\n NewPosition: TJvBalloonPosition;\r\n ScreenRect: TRect;\r\n LStemPointPosition: TPoint;\r\n Pt: TPoint;\r\nbegin\r\n { bpAuto returns the same value as bpLeftDown; bpLeftDown is choosen\r\n arbitrary }\r\n FCurrentPosition := bpLeftDown;\r\n ScreenRect := WorkAreaRect;\r\n\r\n { Note: 2*(Left + Width div 2) = 2*(Left + (Right-Left) div 2) ~=\r\n 2*Left + (Right-Left) = Left + Right;\r\n\r\n Thus multiply everything with 2\r\n\r\n Monitor:\r\n |---------------|\r\n | | |\r\n | 1 | 2 |\r\n | | |\r\n |---------------|\r\n | | |\r\n | 3 | 4 |\r\n | | |\r\n |---------------|\r\n\r\n }\r\n Pt := GetStemPointPositionInRect(ARect);\r\n LStemPointPosition := Point(Pt.X * 2, Pt.Y * 2);\r\n\r\n if LStemPointPosition.Y < ScreenRect.Top + ScreenRect.Bottom then\r\n begin\r\n if LStemPointPosition.X < ScreenRect.Left + ScreenRect.Right then\r\n { 1 }\r\n NewPosition := bpLeftUp\r\n else\r\n { 2 }\r\n NewPosition := bpRightUp;\r\n end\r\n else\r\n begin\r\n if LStemPointPosition.X < ScreenRect.Left + ScreenRect.Right then\r\n { 3 }\r\n NewPosition := bpLeftDown\r\n else\r\n { 4 }\r\n NewPosition := bpRightDown;\r\n end;\r\n\r\n if NewPosition <> FCurrentPosition then\r\n begin\r\n { Reset the offset.. }\r\n Pt := CalcOffset(ARect);\r\n OffsetRect(ARect, -Pt.X, -Pt.Y);\r\n\r\n FCurrentPosition := NewPosition;\r\n\r\n { ..and set the offset }\r\n Pt := CalcOffset(ARect);\r\n OffsetRect(ARect, Pt.X, Pt.Y);\r\n end;\r\nend;\r\n\r\nfunction TJvBalloonWindow.CalcHintRect(MaxWidth: Integer; const AHint: string;\r\n AData: Pointer): TRect;\r\nbegin\r\n // Mantis 3855: CalcHintRect is called by the VCL code and gives a non\r\n // UTF-8 string. However, this string may contain characters above 127 which\r\n // would then be interpreted as UTF-8 markers. So when you are sure the\r\n // string for the hint is UTF-8, use CalcHintRectUTF8 below. This is what is\r\n // done by the TJvBalloonHint.InternalActivateHintPos code.\r\n // In any case the CalcHintRectW function is called in the end.\r\n Result := CalcHintRectW(MaxWidth, WideString(AHint), AData);\r\nend;\r\n\r\nfunction TJvBalloonWindow.CalcHintRectUTF8(MaxWidth: Integer;\r\n const AUTF8Hint: {$IFDEF RTL200_UP}UTF8String{$ELSE}string{$ENDIF RTL200_UP}; AData: Pointer): TRect;\r\nbegin\r\n Result := CalcHintRectW(MaxWidth, {$IFDEF RTL200_UP}System.{$ENDIF RTL200_UP}UTF8ToWideString(AUTF8Hint), AData);\r\nend;\r\n\r\nfunction TJvBalloonWindow.CalcHintRectW(MaxWidth: Integer;\r\n const AHint: WideString; AData: Pointer): TRect;\r\nvar\r\n ASize: TSize;\r\n StemSize: TJvStemSize;\r\n Pt: TPoint;\r\nbegin\r\n FUseRegion := False;\r\n Init(AData);\r\n\r\n FMsg := AHint;\r\n FIsMultiLineMsg := IsMultiLineStr(FMsg);\r\n\r\n if FShowIcon then\r\n begin\r\n if IsWinVista_UP and (GetComCtlVersion >= ComCtlVersionIE6) then\r\n FIconPos := Point(12, 12)\r\n else\r\n FIconPos := Point(12, 9);\r\n end;\r\n\r\n SetRectEmpty(FHeaderRect);\r\n MeasureHeader(MaxWidth, FHeaderRect.Right, FHeaderRect.Bottom);\r\n if not IsRectEmpty(FHeaderRect) then\r\n begin\r\n if IsWinVista_UP and (GetComCtlVersion >= ComCtlVersionIE6) then\r\n OffsetRect(FHeaderRect, 12, 9)\r\n else\r\n OffsetRect(FHeaderRect, 12, 10)\r\n end;\r\n\r\n SetRectEmpty(FMsgRect);\r\n MeasureMsg(MaxWidth, FMsgRect.Right, FMsgRect.Bottom);\r\n if not IsRectEmpty(FMsgRect) then\r\n begin\r\n if IsWinVista_UP then\r\n begin\r\n {$IFDEF JVCLThemesEnabled}\r\n if ThemeServices.{$IFDEF RTL230_UP}Enabled{$ELSE}ThemesEnabled{$ENDIF RTL230_UP} then\r\n OffsetRect(FMsgRect, 12, Max(9, FHeaderRect.Bottom))\r\n else\r\n {$ENDIF JVCLThemesEnabled}\r\n if GetComCtlVersion >= ComCtlVersionIE6 then\r\n OffsetRect(FMsgRect, 12, FHeaderRect.Bottom + 3)\r\n else\r\n begin\r\n if FShowIcon then\r\n OffsetRect(FMsgRect, 12, Max(FIconPos.Y + FImageSize.cy + 6, FHeaderRect.Bottom + 5))\r\n else\r\n OffsetRect(FMsgRect, 12, Max(9, FHeaderRect.Bottom + 5));\r\n end;\r\n end\r\n else\r\n begin\r\n if FShowIcon then\r\n OffsetRect(FMsgRect, 12, Max(FIconPos.Y + FImageSize.cy + 5, FHeaderRect.Bottom + 4))\r\n else\r\n OffsetRect(FMsgRect, 12, Max(9, FHeaderRect.Bottom + 4));\r\n end;\r\n end;\r\n\r\n if FShowIcon then\r\n begin\r\n // move the right position of the header\r\n if IsWinVista_UP and (GetComCtlVersion >= ComCtlVersionIE6) then\r\n OffsetRect(FHeaderRect, FImageSize.cx + 5, 0)\r\n else\r\n OffsetRect(FHeaderRect, FImageSize.cx + 8, 0);\r\n\r\n // move the right position of the msg; only for vista\r\n if IsWinVista_UP and (GetComCtlVersion >= ComCtlVersionIE6) then\r\n OffsetRect(FMsgRect, FImageSize.cx + 5, 0);\r\n end;\r\n\r\n {$IFDEF JVCLThemesEnabled}\r\n if IsWinVista_UP and ThemeServices.{$IFDEF RTL230_UP}Enabled{$ELSE}ThemesEnabled{$ENDIF RTL230_UP} and FIsMultiLineMsg then\r\n begin\r\n GetThemePartSize(ThemeServices.Theme[teToolTip], 0, TTP_BALLOONSTEM, cBalloonStemState[FCurrentPosition],\r\n nil, TS_TRUE, ASize);\r\n FStemRect := Rect(0, 0, ASize.cx, ASize.cy);\r\n FTipHeight := ASize.cy;\r\n FTipWidth := ASize.cx;\r\n FTipDelta := $10;\r\n end\r\n else\r\n {$ENDIF JVCLThemesEnabled}\r\n begin\r\n if IsRectEmpty(FHeaderRect) then\r\n StemSize := ssExtraSmall\r\n else\r\n if not FIsMultiLineMsg then\r\n StemSize := ssSmall\r\n else\r\n StemSize := ssNormal;\r\n\r\n FTipHeight := cTipHeight[StemSize];\r\n FTipWidth := cTipWidth[StemSize];\r\n FStemRect := Rect(0, 0, FTipWidth, FTipHeight);\r\n FTipDelta := cTipDelta[StemSize];\r\n end;\r\n\r\n if FShowCloseBtn then\r\n begin\r\n {$IFDEF JVCLThemesEnabled}\r\n if IsWinXP_UP and ThemeServices.{$IFDEF RTL230_UP}Enabled{$ELSE}ThemesEnabled{$ENDIF RTL230_UP} then\r\n GetThemePartSize(ThemeServices.Theme[teToolTip], 0, TTP_CLOSE, TTCS_NORMAL,\r\n nil, TS_DRAW, ASize)\r\n else\r\n {$ENDIF JVCLThemesEnabled}\r\n begin\r\n ASize.cx := GetSystemMetrics(SM_CXSMICON);\r\n ASize.cy := GetSystemMetrics(SM_CYSMICON);\r\n end;\r\n FCloseBtnRect := Rect(0, 0, ASize.cx, ASize.cy);\r\n\r\n Inc(FHeaderRect.Right, ASize.cx);\r\n Inc(FMsgRect.Right, ASize.cx);\r\n end;\r\n\r\n if IsWinVista_UP and (GetComCtlVersion >= ComCtlVersionIE6) then\r\n begin\r\n FRoundRect := Rect(0, 0, Max(13 + FMsgRect.Right, 13 + FHeaderRect.Right),\r\n Max(FMsgRect.Bottom + 10, FHeaderRect.Bottom + 10));\r\n OffsetRect(FStemRect, FTipDelta, FRoundRect.Bottom - 1);\r\n end\r\n else\r\n begin\r\n FRoundRect := Rect(0, 0, Max(14 + FMsgRect.Right, 14 + FHeaderRect.Right),\r\n Max(FMsgRect.Bottom + 11, FHeaderRect.Bottom + 11));\r\n OffsetRect(FStemRect, FTipDelta, FRoundRect.Bottom - 1);\r\n end;\r\n\r\n UnionRect(Result, FRoundRect, FStemRect);\r\n Pt := CalcOffset(Result);\r\n OffsetRect(Result, Pt.X, Pt.Y);\r\n\r\n OffsetRect(FCloseBtnRect, FRoundRect.Right - (FCloseBtnRect.Right - FCloseBtnRect.Left) - 6, 6);\r\n FUseRegion := True;\r\nend;\r\n\r\nfunction TJvBalloonWindow.CalcOffset(const ARect: TRect): TPoint;\r\nbegin\r\n case FCurrentPosition of\r\n { bpAuto returns the same value as bpLeftDown; bpLeftDown is choosen\r\n arbitrary }\r\n bpAuto, bpLeftDown:\r\n Result := Point(ARect.Left - ARect.Right + FTipDelta, 0);\r\n bpRightDown:\r\n Result := Point(-FTipDelta, 0);\r\n bpLeftUp:\r\n Result := Point(ARect.Left - ARect.Right + FTipDelta, ARect.Top - ARect.Bottom - FSwitchHeight);\r\n bpRightUp:\r\n Result := Point(-FTipDelta, ARect.Top - ARect.Bottom - FSwitchHeight);\r\n end;\r\nend;\r\n\r\nprocedure TJvBalloonWindow.CheckPosition(var ARect: TRect);\r\nvar\r\n NewPosition: TJvBalloonPosition;\r\n ScreenRect: TRect;\r\n Pt: TPoint;\r\nbegin\r\n if FCurrentPosition = bpAuto then\r\n CalcAutoPosition(ARect);\r\n\r\n NewPosition := FCurrentPosition;\r\n ScreenRect := WorkAreaRect;\r\n\r\n if ARect.Bottom > ScreenRect.Bottom - ScreenRect.Top then\r\n begin\r\n if NewPosition = bpLeftDown then\r\n NewPosition := bpLeftUp\r\n else\r\n if NewPosition = bpRightDown then\r\n NewPosition := bpRightUp;\r\n end;\r\n if ARect.Right > ScreenRect.Right - ScreenRect.Left then\r\n begin\r\n if NewPosition = bpRightDown then\r\n NewPosition := bpLeftDown\r\n else\r\n if NewPosition = bpRightUp then\r\n NewPosition := bpLeftUp;\r\n end;\r\n if ARect.Left < ScreenRect.Left then\r\n begin\r\n if NewPosition = bpLeftDown then\r\n NewPosition := bpRightDown\r\n else\r\n if NewPosition = bpLeftUp then\r\n NewPosition := bpRightUp;\r\n end;\r\n if ARect.Top < ScreenRect.Top then\r\n begin\r\n if NewPosition = bpLeftUp then\r\n NewPosition := bpLeftDown\r\n else\r\n if NewPosition = bpRightUp then\r\n NewPosition := bpRightDown;\r\n end;\r\n\r\n if NewPosition <> FCurrentPosition then\r\n begin\r\n { Reset the offset.. }\r\n Pt := CalcOffset(ARect);\r\n OffsetRect(ARect, -Pt.X, -Pt.Y);\r\n FCurrentPosition := NewPosition;\r\n\r\n { ..and set the offset }\r\n Pt := CalcOffset(ARect);\r\n OffsetRect(ARect, Pt.X, Pt.Y);\r\n end;\r\n { final adjustment - just make sure no part is disappearing outside the top/left edge }\r\n if ARect.Left < ScreenRect.Left then\r\n begin\r\n Pt := CalcOffset(ARect);\r\n OffsetRect(ARect, -Pt.X, -Pt.Y);\r\n if FCurrentPosition = bpLeftUp then\r\n FCurrentPosition := bpRightUp\r\n else\r\n if FCurrentPosition = bpLeftDown then\r\n FCurrentPosition := bpRightDown;\r\n Pt := CalcOffset(ARect);\r\n OffsetRect(ARect, Pt.X, Pt.Y);\r\n end;\r\n\r\n if ARect.Top < ScreenRect.Top then\r\n begin\r\n Pt := CalcOffset(ARect);\r\n OffsetRect(ARect, -Pt.X, -Pt.Y);\r\n if FCurrentPosition = bpLeftUp then\r\n FCurrentPosition := bpLeftDown\r\n else\r\n if FCurrentPosition = bpRightUp then\r\n FCurrentPosition := bpRightDown;\r\n Pt := CalcOffset(ARect);\r\n OffsetRect(ARect, Pt.X, Pt.Y);\r\n end;\r\n\r\n case FCurrentPosition of\r\n bpLeftDown, bpRightDown:\r\n begin\r\n OffsetRect(FRoundRect, 0, FTipHeight - 1);\r\n OffsetRect(FStemRect, 0, -FStemRect.Top);\r\n OffsetRect(FMsgRect, 0, FTipHeight - 1);\r\n OffsetRect(FHeaderRect, 0, FTipHeight - 1);\r\n Inc(FIconPos.y, FTipHeight);\r\n OffsetRect(FCloseBtnRect, 0, FTipHeight);\r\n\r\n if FCurrentPosition = bpLeftDown then\r\n OffsetRect(FStemRect, -2 * FTipDelta + (FRoundRect.Right - FRoundRect.Left) - (FStemRect.Right - FStemRect.Left), 0);\r\n end;\r\n bpLeftUp, bpRightUp:\r\n begin\r\n if FCurrentPosition = bpLeftUp then\r\n OffsetRect(FStemRect, -2 * FTipDelta + (FRoundRect.Right - FRoundRect.Left) - (FStemRect.Right - FStemRect.Left), 0);\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvBalloonWindow.CMShowingChanged(var Msg: TMessage);\r\nbegin\r\n { In response of RecreateWnd, SetParentWindow calls, only respond when visible }\r\n { Actually only necessairy for TJvBalloonWindow not for TJvBalloonWindowEx }\r\n if Showing then\r\n UpdateRegion;\r\n inherited;\r\nend;\r\n\r\nprocedure TJvBalloonWindow.CMTextChanged(var Msg: TMessage);\r\nbegin\r\n {inherited;}\r\nend;\r\n\r\nprocedure TJvBalloonWindow.CreateParams(var Params: TCreateParams);\r\nbegin\r\n inherited CreateParams(Params);\r\n { Drop shadow in combination with custom animation may cause blurry effect,\r\n no solution.\r\n }\r\n with Params do\r\n begin\r\n Style := Style and not WS_BORDER;\r\n if IsWinXP_UP and (GetComCtlVersion >= ComCtlVersionIE6) then\r\n begin\r\n WindowClass.Style := WindowClass.Style or CS_DROPSHADOW;\r\n {$IFDEF JVCLThemesEnabled}\r\n if not IsWinSeven_UP and IsWinVista_UP and ThemeServices.{$IFDEF RTL230_UP}Enabled{$ELSE}ThemesEnabled{$ENDIF RTL230_UP} then\r\n ExStyle := ExStyle or WS_EX_LAYERED;\r\n {$ENDIF JVCLThemesEnabled}\r\n end\r\n else\r\n WindowClass.Style := WindowClass.Style and not CS_DROPSHADOW;\r\n end;\r\nend;\r\n\r\nfunction TJvBalloonWindow.CreateRegion: HRGN;\r\nvar\r\n RegionRound, RegionTip: HRGN;\r\n PtTail: array [0..2] of TPoint;\r\nbegin\r\n case FCurrentPosition of\r\n bpLeftDown:\r\n begin\r\n { 0\r\n / |\r\n / |\r\n / |\r\n 2----1\r\n }\r\n\r\n PtTail[0] := Point(FStemRect.Right, FStemRect.Top);\r\n PtTail[1] := Point(FStemRect.Right, FStemRect.Bottom);\r\n PtTail[2] := Point(FStemRect.Left, FStemRect.Bottom);\r\n end;\r\n bpRightDown:\r\n begin\r\n { 0\r\n | \\\r\n | \\\r\n | \\\r\n 1----2\r\n }\r\n\r\n PtTail[0] := Point(FStemRect.Left, FStemRect.Top);\r\n PtTail[1] := Point(FStemRect.Left, FStemRect.Bottom);\r\n PtTail[2] := Point(FStemRect.Right, FStemRect.Bottom);\r\n end;\r\n bpLeftUp:\r\n begin\r\n { 2----1\r\n \\ |\r\n \\ |\r\n \\ |\r\n 0\r\n }\r\n\r\n PtTail[0] := Point(FStemRect.Right, FStemRect.Bottom);\r\n PtTail[1] := Point(FStemRect.Right, FStemRect.Top);\r\n PtTail[2] := Point(FStemRect.Left, FStemRect.Top);\r\n end;\r\n bpRightUp:\r\n begin\r\n { 1----2\r\n | /\r\n | /\r\n | /\r\n 0\r\n }\r\n\r\n PtTail[0] := Point(FStemRect.Left, FStemRect.Bottom);\r\n PtTail[1] := Point(FStemRect.Left, FStemRect.Top);\r\n PtTail[2] := Point(FStemRect.Right, FStemRect.Top);\r\n end;\r\n end;\r\n\r\n RegionTip := CreatePolygonRgn(PtTail, 3, WINDING);\r\n RegionRound := CreateRoundRectRgn(FRoundRect.Left, FRoundRect.Top, FRoundRect.Right, FRoundRect.Bottom, 11, 11);\r\n Result := CreateRectRgn(0, 0, 1, 1);\r\n\r\n CombineRgn(Result, RegionTip, RegionRound, RGN_OR);\r\n DeleteObject(RegionTip);\r\n DeleteObject(RegionRound);\r\nend;\r\n\r\n{$IFDEF JVCLThemesEnabled}\r\nfunction TJvBalloonWindow.CreateThemedRegion: HRGN;\r\nvar\r\n RegionRound, RegionTip: HRGN;\r\nbegin\r\n Result := CreateRectRgn(0, 0, 1, 1);\r\n if GetThemeBackgroundRegion(ThemeServices.Theme[teToolTip], 0,\r\n TTP_BALLOON, 0, FRoundRect, RegionRound) = S_OK then\r\n begin\r\n if GetThemeBackgroundRegion(ThemeServices.Theme[teToolTip], 0,\r\n TTP_BALLOONSTEM, cBalloonStemState[FCurrentPosition], FStemRect, RegionTip) = S_OK then\r\n begin\r\n CombineRgn(Result, RegionTip, RegionRound, RGN_OR);\r\n DeleteObject(RegionTip);\r\n end;\r\n DeleteObject(RegionRound);\r\n end;\r\nend;\r\n{$ENDIF JVCLThemesEnabled}\r\n\r\nfunction TJvBalloonWindow.GetStemPointPosition: TPoint;\r\nbegin\r\n Result := GetStemPointPositionInRect(BoundsRect);\r\nend;\r\n\r\nfunction TJvBalloonWindow.GetStemPointPositionInRect(const ARect: TRect): TPoint;\r\nbegin\r\n { bpAuto returns the same value as bpLeftDown; bpLeftDown is choosen\r\n arbitrary }\r\n case FCurrentPosition of\r\n bpAuto, bpLeftDown:\r\n Result := Point(ARect.Right - FTipDelta, ARect.Top);\r\n bpRightDown:\r\n Result := Point(ARect.Left + FTipDelta, ARect.Top);\r\n bpLeftUp:\r\n Result := Point(ARect.Right - FTipDelta, ARect.Bottom);\r\n bpRightUp:\r\n Result := Point(ARect.Left + FTipDelta, ARect.Bottom);\r\n end;\r\nend;\r\n\r\nprocedure TJvBalloonWindow.Init(AData: Pointer);\r\nbegin\r\n with GlobalCtrl.MainCtrl do\r\n begin\r\n FShowIcon := (ahShowIconInHint in ApplicationHintOptions) and\r\n (DefaultIcon <> ikNone) and\r\n ((DefaultIcon <> ikCustom) or (DefaultImageIndex > -1));\r\n FShowHeader := (ahShowHeaderInHint in ApplicationHintOptions) and (DefaultHeader <> '');\r\n FHeader := DefaultHeader;\r\n FCurrentPosition := DefaultBalloonPosition;\r\n end;\r\n\r\n FImageSize := GlobalCtrl.HintImageSize;\r\n FSwitchHeight := GetSystemMetrics(SM_CYCURSOR);\r\nend;\r\n\r\nprocedure TJvBalloonWindow.MeasureHeader(const MaxWidth: Integer;\r\n var AWidth, AHeight: Integer);\r\nvar\r\n R: TRect;\r\nbegin\r\n if FShowHeader then\r\n begin\r\n R := Rect(0, 0, MaxWidth, 0);\r\n GetHintTitleFont(Canvas.Font);\r\n DrawTextW(Canvas.Handle, FHeader, R,\r\n DT_CALCRECT or DefaultTextFlags or DrawTextBiDiModeFlagsReadingOnly);\r\n AWidth := R.Right - R.Left;\r\n AHeight := R.Bottom - R.Top;\r\n end\r\n else\r\n begin\r\n AWidth := 0;\r\n AHeight := 0;\r\n end;\r\nend;\r\n\r\nprocedure TJvBalloonWindow.MeasureMsg(const MaxWidth: Integer;\r\n var AWidth, AHeight: Integer);\r\nvar\r\n R: TRect;\r\nbegin\r\n if FMsg > '' then\r\n begin\r\n R := Rect(0, 0, MaxWidth, 0);\r\n GetHintMessageFont(Canvas.Font);\r\n DrawTextW(Canvas.Handle, FMsg, R,\r\n DT_CALCRECT or DefaultTextFlags or DrawTextBiDiModeFlagsReadingOnly);\r\n AWidth := R.Right - R.Left;\r\n AHeight := R.Bottom - R.Top;\r\n end\r\n else\r\n begin\r\n AWidth := 0;\r\n AHeight := 0;\r\n end;\r\nend;\r\n\r\nfunction TJvBalloonWindow.MultiLineWidth(const Value: string): Integer;\r\nvar\r\n W: Integer;\r\n P, Start: PChar;\r\n S: string;\r\nbegin\r\n Result := 0;\r\n P := Pointer(Value);\r\n if P <> nil then\r\n while P^ <> #0 do\r\n begin\r\n Start := P;\r\n while not CharInSet(P^, [#0, #10, #13]) do\r\n P := StrNextChar(P);\r\n SetString(S, Start, P - Start);\r\n W := Self.Canvas.TextWidth(S);\r\n if W > Result then\r\n Result := W;\r\n if P^ = #13 then Inc(P);\r\n if P^ = #10 then Inc(P);\r\n end;\r\nend;\r\n\r\nprocedure TJvBalloonWindow.NCPaint(DC: HDC);\r\nbegin\r\n { Do nothing, thus prevent TJvHintWindow from drawing }\r\nend;\r\n\r\nprocedure TJvBalloonWindow.Paint;\r\nbegin\r\n if FShowIcon then\r\n GlobalCtrl.DrawHintImage(Canvas, FIconPos.X, FIconPos.Y, Color);\r\n\r\n if FMsg > '' then\r\n begin\r\n GetHintMessageFont(Canvas.Font);\r\n DrawTextW(Canvas.Handle, FMsg, FMsgRect,\r\n DefaultTextFlags or DrawTextBiDiModeFlagsReadingOnly);\r\n end;\r\n\r\n if FShowHeader then\r\n begin\r\n GetHintTitleFont(Canvas.Font);\r\n DrawTextW(Canvas.Handle, FHeader, FHeaderRect,\r\n DefaultTextFlags or DrawTextBiDiModeFlagsReadingOnly);\r\n end;\r\nend;\r\n\r\nprocedure TJvBalloonWindow.UpdateRegion;\r\nvar\r\n Region: HRGN;\r\n IsVisible: Boolean;\r\nbegin\r\n if not HandleAllocated or not FUseRegion or (FCurrentPosition = bpAuto) then\r\n Exit;\r\n\r\n {$IFDEF JVCLThemesEnabled}\r\n if IsWinVista_UP and ThemeServices.{$IFDEF RTL230_UP}Enabled{$ELSE}ThemesEnabled{$ENDIF RTL230_UP} and FIsMultiLineMsg then\r\n Region := CreateThemedRegion\r\n else\r\n {$ENDIF JVCLThemesEnabled}\r\n Region := CreateRegion;\r\n IsVisible := IsWindowVisible(Handle);\r\n if SetWindowRgn(Handle, Region, IsVisible) = 0 then\r\n DeleteObject(Region);\r\n { MSDN: After a successful call to SetWindowRgn, the system owns the region\r\n specified by the region handle hRgn. The system does not make a copy of\r\n the region. Thus, you should not make any further function calls with\r\n this region handle. In particular, do not delete this region handle. The\r\n system deletes the region handle when it no longer needed. }\r\nend;\r\n\r\nprocedure TJvBalloonWindow.WMEraseBkgnd(var Msg: TWMEraseBkgnd);\r\nvar\r\n Brush, BrushBlack: HBRUSH;\r\n Region: HRGN;\r\n RegionType: Integer;\r\n {$IFDEF JVCLThemesEnabled}\r\n R: TRect;\r\n {$ENDIF JVCLThemesEnabled}\r\nbegin\r\n {$IFDEF JVCLThemesEnabled}\r\n if IsWinVista_UP and ThemeServices.{$IFDEF RTL230_UP}Enabled{$ELSE}ThemesEnabled{$ENDIF RTL230_UP} then\r\n begin\r\n if FIsMultiLineMsg then\r\n begin\r\n DrawThemeBackground(ThemeServices.Theme[teToolTip], Msg.DC,\r\n TTP_BALLOON, 0, FRoundRect, @FRoundRect);\r\n DrawThemeBackground(ThemeServices.Theme[teToolTip], Msg.DC,\r\n TTP_BALLOONSTEM, cBalloonStemState[FCurrentPosition], FStemRect, @FStemRect);\r\n end\r\n else\r\n begin\r\n R := ClientRect;\r\n DrawThemeBackground(ThemeServices.Theme[teToolTip], Msg.DC,\r\n TTP_BALLOON, 0, R, @R);\r\n // draw black border\r\n BrushBlack := CreateSolidBrush(0);\r\n try\r\n Region := CreateRectRgn(0, 0, 0, 0);\r\n RegionType := GetWindowRgn(Handle, Region);\r\n if RegionType <> Windows.ERROR then\r\n FrameRgn(Msg.DC, Region, BrushBlack, 1, 1);\r\n DeleteObject(Region);\r\n finally\r\n DeleteObject(BrushBlack);\r\n end;\r\n end;\r\n\r\n Msg.Result := 1;\r\n Exit;\r\n end;\r\n {$ENDIF JVCLThemesEnabled}\r\n Brush := CreateSolidBrush(ColorToRGB(Color));\r\n BrushBlack := CreateSolidBrush(0);\r\n try\r\n Region := CreateRectRgn(0, 0, 0, 0);\r\n RegionType := GetWindowRgn(Handle, Region);\r\n if RegionType <> Windows.ERROR then\r\n begin\r\n FillRgn(Msg.DC, Region, Brush);\r\n // draw black border\r\n FrameRgn(Msg.DC, Region, BrushBlack, 1, 1);\r\n end;\r\n DeleteObject(Region);\r\n finally\r\n DeleteObject(Brush);\r\n DeleteObject(BrushBlack);\r\n end;\r\n Msg.Result := 1;\r\nend;\r\n\r\n//=== { TJvBalloonHint } =====================================================\r\n\r\nconstructor TJvBalloonHint.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FActive := False;\r\n FHint := TJvBalloonWindowEx.Create(Self);\r\n FHint.FCtrl := Self;\r\n FHint.Visible := False;\r\n FHint.OnMouseDown := HandleMouseDown;\r\n FHint.OnMouseUp := HandleMouseUp;\r\n FHint.OnMouseMove := HandleMouseMove;\r\n FHint.OnClick := HandleClick;\r\n FHint.OnDblClick := HandleDblClick;\r\n FOptions := [boShowCloseBtn];\r\n FApplicationHintOptions := [ahShowHeaderInHint, ahShowIconInHint];\r\n FDefaultIcon := ikInformation;\r\n FDefaultBalloonPosition := bpAuto;\r\n FDefaultImageIndex := -1;\r\n FCustomAnimationTime := 100;\r\n FCustomAnimationStyle := atBlend;\r\n FMaxWidth := 0;\r\n\r\n GlobalCtrl.Add(Self);\r\nend;\r\n\r\ndestructor TJvBalloonHint.Destroy;\r\nbegin\r\n CancelHint;\r\n StopHintTimer;\r\n\r\n if FHandle <> 0 then\r\n DeallocateHWndEx(FHandle);\r\n\r\n if GGlobalCtrl <> nil then\r\n GlobalCtrl.Remove(Self);\r\n\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvBalloonHint.ActivateHint(ACtrl: TControl; const AHint: WideString;\r\n const AImageIndex: TImageIndex; const AHeader: WideString;\r\n const VisibleTime: Integer);\r\nbegin\r\n if not Assigned(ACtrl) then\r\n Exit;\r\n\r\n CancelHint;\r\n\r\n with FData do\r\n begin\r\n RUTF8Hint := {$IFDEF RTL200_UP}UTF8Encode{$ELSE}WideStringToUTF8{$ENDIF RTL200_UP}(AHint);\r\n RIconKind := ikCustom;\r\n RImageIndex := AImageIndex;\r\n RUTF8Header := {$IFDEF RTL200_UP}UTF8Encode{$ELSE}WideStringToUTF8{$ENDIF RTL200_UP}(AHeader);\r\n RVisibleTime := VisibleTime;\r\n end;\r\n\r\n InternalActivateHint(ACtrl);\r\nend;\r\n\r\nprocedure TJvBalloonHint.ActivateHint(ACtrl: TControl;\r\n const AHint, AHeader: WideString; const VisibleTime: Integer);\r\nbegin\r\n if not Assigned(ACtrl) then\r\n Exit;\r\n\r\n CancelHint;\r\n\r\n with FData do\r\n begin\r\n RUTF8Hint := {$IFDEF RTL200_UP}UTF8Encode{$ELSE}WideStringToUTF8{$ENDIF RTL200_UP}(AHint);\r\n RUTF8Header := {$IFDEF RTL200_UP}UTF8Encode{$ELSE}WideStringToUTF8{$ENDIF RTL200_UP}(AHeader);\r\n RVisibleTime := VisibleTime;\r\n RIconKind := ikNone;\r\n end;\r\n\r\n InternalActivateHint(ACtrl);\r\nend;\r\n\r\nprocedure TJvBalloonHint.ActivateHint(ACtrl: TControl; const AHint: WideString;\r\n const AIconKind: TJvIconKind; const AHeader: WideString; const VisibleTime: Integer);\r\nbegin\r\n if not Assigned(ACtrl) then\r\n Exit;\r\n\r\n CancelHint;\r\n\r\n with FData do\r\n begin\r\n RUTF8Hint := {$IFDEF RTL200_UP}UTF8Encode{$ELSE}WideStringToUTF8{$ENDIF RTL200_UP}(AHint);\r\n RIconKind := AIconKind;\r\n RImageIndex := -1;\r\n RUTF8Header := {$IFDEF RTL200_UP}UTF8Encode{$ELSE}WideStringToUTF8{$ENDIF RTL200_UP}(AHeader);\r\n RVisibleTime := VisibleTime;\r\n end;\r\n\r\n InternalActivateHint(ACtrl);\r\nend;\r\n\r\nprocedure TJvBalloonHint.ActivateHintPos(AAnchorWindow: TCustomForm;\r\n AAnchorPosition: TPoint; const AHeader, AHint: WideString;\r\n const VisibleTime: Integer; const AIconKind: TJvIconKind;\r\n const AImageIndex: TImageIndex);\r\nbegin\r\n CancelHint;\r\n\r\n with FData do\r\n begin\r\n RAnchorWindow := AAnchorWindow;\r\n RAnchorPosition := AAnchorPosition;\r\n RUTF8Header := {$IFDEF RTL200_UP}UTF8Encode{$ELSE}WideStringToUTF8{$ENDIF RTL200_UP}(AHeader);\r\n RUTF8Hint := {$IFDEF RTL200_UP}UTF8Encode{$ELSE}WideStringToUTF8{$ENDIF RTL200_UP}(AHint);\r\n RVisibleTime := VisibleTime;\r\n RIconKind := AIconKind;\r\n RImageIndex := AImageIndex;\r\n RSwitchHeight := 0;\r\n end;\r\n\r\n InternalActivateHintPos;\r\nend;\r\n\r\nprocedure TJvBalloonHint.ActivateHintRect(ARect: TRect; const AHeader,\r\n AHint: WideString; const VisibleTime: Integer; const AIconKind: TJvIconKind;\r\n const AImageIndex: TImageIndex);\r\nbegin\r\n CancelHint;\r\n\r\n with FData do\r\n begin\r\n RAnchorWindow := nil;\r\n RAnchorPosition := Point((ARect.Left + ARect.Right) div 2, ARect.Bottom);\r\n RUTF8Header := {$IFDEF RTL200_UP}UTF8Encode{$ELSE}WideStringToUTF8{$ENDIF RTL200_UP}(AHeader);\r\n RUTF8Hint := {$IFDEF RTL200_UP}UTF8Encode{$ELSE}WideStringToUTF8{$ENDIF RTL200_UP}(AHint);\r\n RVisibleTime := VisibleTime;\r\n RIconKind := AIconKind;\r\n RImageIndex := AImageIndex;\r\n RSwitchHeight := ARect.Bottom - ARect.Top;\r\n end;\r\n\r\n InternalActivateHintPos;\r\nend;\r\n\r\nprocedure TJvBalloonHint.CancelHint;\r\nbegin\r\n if not FActive then\r\n Exit;\r\n\r\n FActive := False;\r\n StopHintTimer;\r\n UnHook;\r\n\r\n if GetCapture = FHint.Handle then\r\n ReleaseCapture;\r\n { Ensure property Visible is set to False: }\r\n FHint.Hide;\r\n { If ParentWindow = 0, calling Hide won't trigger the CM_SHOWINGCHANGED message\r\n thus ShowWindow/SetWindowPos isn't called. We do it ourselfs: }\r\n if FHint.ParentWindow = 0 then\r\n ShowWindow(FHint.Handle, SW_HIDE);\r\n\r\n FHint.ParentWindow := 0;\r\n\r\n if Assigned(FOnClose) then\r\n FOnClose(Self);\r\nend;\r\n\r\nprocedure TJvBalloonWindow.CreateWnd;\r\nbegin\r\n inherited CreateWnd;\r\n UpdateRegion;\r\nend;\r\n\r\nfunction TJvBalloonHint.GetHandle: THandle;\r\nbegin\r\n if FHandle = 0 then\r\n FHandle := AllocateHWndEx(WndProc);\r\n Result := FHandle;\r\nend;\r\n\r\nfunction TJvBalloonHint.GetUseBalloonAsApplicationHint: Boolean;\r\nbegin\r\n Result := GlobalCtrl.UseBalloonAsApplicationHint;\r\nend;\r\n\r\nprocedure TJvBalloonHint.HandleClick(Sender: TObject);\r\nbegin\r\n if Assigned(FOnBalloonClick) then\r\n FOnBalloonClick(Self);\r\nend;\r\n\r\nfunction TJvBalloonHint.HandleCloseBtnClick: Boolean;\r\nbegin\r\n Result := True;\r\n if Assigned(FOnCloseBtnClick) then\r\n FOnCloseBtnClick(Self, Result);\r\nend;\r\n\r\nprocedure TJvBalloonHint.HandleDblClick(Sender: TObject);\r\nbegin\r\n if Assigned(FOnDblClick) then\r\n FOnDblClick(Self);\r\nend;\r\n\r\nprocedure TJvBalloonHint.HandleMouseDown(Sender: TObject;\r\n Button: TMouseButton; Shift: TShiftState; X, Y: Integer);\r\nbegin\r\n if Assigned(FOnMouseDown) then\r\n FOnMouseDown(Self, Button, Shift, X, Y);\r\nend;\r\n\r\nprocedure TJvBalloonHint.HandleMouseMove(Sender: TObject;\r\n Shift: TShiftState; X, Y: Integer);\r\nbegin\r\n if Assigned(FOnMouseMove) then\r\n FOnMouseMove(Self, Shift, X, Y);\r\nend;\r\n\r\nprocedure TJvBalloonHint.HandleMouseUp(Sender: TObject;\r\n Button: TMouseButton; Shift: TShiftState; X, Y: Integer);\r\nbegin\r\n if Assigned(FOnMouseUp) then\r\n FOnMouseUp(Self, Button, Shift, X, Y);\r\nend;\r\n\r\nprocedure TJvBalloonHint.Hook;\r\nbegin\r\n if Assigned(FData.RAnchorWindow) then\r\n RegisterWndProcHook(FData.RAnchorWindow, HookProc, hoBeforeMsg);\r\nend;\r\n\r\nfunction TJvBalloonHint.HookProc(var Msg: TMessage): Boolean;\r\nbegin\r\n Result := False;\r\n case Msg.Msg of\r\n WM_MOVE:\r\n with FData do\r\n FHint.MoveWindow(RAnchorWindow.ClientToScreen(RAnchorPosition));\r\n WM_SIZE:\r\n with FData do\r\n { (rb) This goes wrong if the balloon is anchored to the window itself }\r\n if not PtInRect(RAnchorWindow.ClientRect, RStemPointPosition) then\r\n CancelHint;\r\n WM_SHOWWINDOW:\r\n ;\r\n WM_WINDOWPOSCHANGED:\r\n { Hide/Restore the balloon if the window is minimized }\r\n FHint.Visible :=\r\n not IsIconic(FData.RAnchorWindow.Handle) and\r\n not IsIconic(Application.Handle);\r\n WM_ACTIVATE:\r\n if Msg.WParam = WA_INACTIVE then\r\n { Remove HWND_TOPMOST flag }\r\n FHint.NormalizeTopMost\r\n else\r\n { Restore HWND_TOPMOST flag }\r\n FHint.RestoreTopMost;\r\n WM_CLOSE:\r\n CancelHint;\r\n WM_NCACTIVATE, WM_EXITSIZEMOVE:\r\n { (rb) Weird behaviour of windows ? }\r\n FHint.RestoreTopMost;\r\n end;\r\nend;\r\n\r\nprocedure TJvBalloonHint.InternalActivateHint(ACtrl: TControl);\r\nvar\r\n LParentForm: TCustomForm;\r\nbegin\r\n if not Assigned(ACtrl) then\r\n Exit;\r\n\r\n LParentForm := GetParentForm(ACtrl);\r\n with FData do\r\n begin\r\n RAnchorWindow := LParentForm;\r\n if LParentForm = ACtrl then\r\n RAnchorPosition := Point(ACtrl.Width div 2, ACtrl.ClientHeight)\r\n else\r\n RAnchorPosition := InternalClientToParent(ACtrl, Point(ACtrl.Width div 2, ACtrl.Height), LParentForm);\r\n\r\n RSwitchHeight := ACtrl.Height;\r\n end;\r\n\r\n InternalActivateHintPos;\r\nend;\r\n\r\nprocedure TJvBalloonHint.InternalActivateHintPos;\r\nvar\r\n Rect: TRect;\r\n Animate: BOOL;\r\n TmpMaxWidth: Integer;\r\n Pt: TPoint;\r\nbegin\r\n with FData do\r\n begin\r\n { Use defaults if necessairy: }\r\n if boUseDefaultHeader in Options then\r\n RUTF8Header := {$IFDEF RTL200_UP}UTF8Encode{$ELSE}WideStringToUTF8{$ENDIF RTL200_UP}(DefaultHeader);\r\n if boUseDefaultIcon in Options then\r\n RIconKind := DefaultIcon;\r\n if boUseDefaultImageIndex in Options then\r\n RImageIndex := DefaultImageIndex;\r\n RShowCloseBtn := boShowCloseBtn in Options;\r\n\r\n { Determine animation style }\r\n if not IsWinXP_UP then\r\n RAnimationStyle := atNone\r\n else\r\n if boCustomAnimation in Options then\r\n begin\r\n RAnimationStyle := FCustomAnimationStyle;\r\n RAnimationTime := FCustomAnimationTime;\r\n end\r\n else\r\n begin\r\n SystemParametersInfo(SPI_GETTOOLTIPANIMATION, 0, @Animate, 0);\r\n if Animate then\r\n begin\r\n SystemParametersInfo(SPI_GETTOOLTIPFADE, 0, @Animate, 0);\r\n if Animate then\r\n RAnimationStyle := atBlend\r\n else\r\n RAnimationStyle := atSlide;\r\n end\r\n else\r\n RAnimationStyle := atNone;\r\n RAnimationTime := 100;\r\n end;\r\n\r\n { Hook the anchor window }\r\n FActive := True;\r\n Hook;\r\n\r\n { Determine the size of the balloon rect, the stem point will be on\r\n position (0, 0) }\r\n if MaxWidth = 0 then\r\n TmpMaxWidth := Screen.Width\r\n else\r\n TmpMaxWidth := MaxWidth;\r\n Rect := FHint.CalcHintRectUTF8(TmpMaxWidth, RUTF8Hint, @FData);\r\n\r\n { Offset the rectangle to the anchor position }\r\n if Assigned(RAnchorWindow) then\r\n begin\r\n Pt := RAnchorWindow.ClientToScreen(RAnchorPosition);\r\n OffsetRect(Rect, Pt.X, Pt.Y)\r\n end\r\n else\r\n OffsetRect(Rect, RAnchorPosition.X, RAnchorPosition.Y);\r\n\r\n if boPlaySound in Options then\r\n GlobalCtrl.PlaySound(RIconKind);\r\n\r\n FHint.InternalActivateHint(Rect, {$IFDEF RTL200_UP}System.UTF8ToString{$ENDIF RTL200_UP}(RUTF8Hint));\r\n\r\n { Now we can determine the actual anchor & stempoint position: }\r\n if Assigned(RAnchorWindow) then\r\n begin\r\n RAnchorPosition := RAnchorWindow.ScreenToClient(Rect.TopLeft);\r\n RStemPointPosition := RAnchorWindow.ScreenToClient(FHint.StemPointPosition);\r\n end\r\n else\r\n begin\r\n RAnchorPosition := Rect.TopLeft;\r\n RStemPointPosition := FHint.StemPointPosition;\r\n end;\r\n\r\n { Last call because of possible CancelHint call in StartHintTimer }\r\n if RVisibleTime > 0 then\r\n StartHintTimer(RVisibleTime);\r\n {if GetCapture = 0 then\r\n SetCapture(FHint.Handle);\r\n ReleaseCapture;}\r\n end;\r\nend;\r\n\r\nprocedure TJvBalloonHint.Notification(AComponent: TComponent;\r\n Operation: TOperation);\r\nbegin\r\n inherited Notification(AComponent, Operation);\r\n if (Operation = opRemove) and (AComponent = Images) then\r\n Images := nil;\r\nend;\r\n\r\nprocedure TJvBalloonHint.SetImages(const Value: TCustomImageList);\r\nbegin\r\n ReplaceComponentReference(Self, Value, TComponent(FImages));\r\nend;\r\n\r\nprocedure TJvBalloonHint.SetOptions(const Value: TJvBalloonOptions);\r\nbegin\r\n if Value <> FOptions then\r\n FOptions := Value;\r\nend;\r\n\r\nprocedure TJvBalloonHint.SetUseBalloonAsApplicationHint(\r\n const Value: Boolean);\r\nbegin\r\n GlobalCtrl.UseBalloonAsApplicationHint := Value;\r\nend;\r\n\r\nprocedure TJvBalloonHint.StartHintTimer(Value: Integer);\r\nbegin\r\n StopHintTimer;\r\n if SetTimer(Handle, 1, Value, nil) = 0 then\r\n CancelHint\r\n else\r\n FTimerActive := True;\r\nend;\r\n\r\nprocedure TJvBalloonHint.StopHintTimer;\r\nbegin\r\n if FTimerActive then\r\n begin\r\n KillTimer(Handle, 1);\r\n FTimerActive := True;\r\n end;\r\nend;\r\n\r\nprocedure TJvBalloonHint.UnHook;\r\nbegin\r\n if Assigned(FData.RAnchorWindow) then\r\n UnRegisterWndProcHook(FData.RAnchorWindow, HookProc, hoBeforeMsg);\r\nend;\r\n\r\nprocedure TJvBalloonHint.WndProc(var Msg: TMessage);\r\nbegin\r\n with Msg do\r\n if Msg = WM_TIMER then\r\n try\r\n CancelHint;\r\n except\r\n if Assigned(ApplicationHandleException) then\r\n ApplicationHandleException(Self);\r\n end\r\n else\r\n Result := DefWindowProc(Handle, Msg, WParam, LParam);\r\nend;\r\n\r\n//=== { TGlobalCtrl } ========================================================\r\n\r\nconstructor TGlobalCtrl.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n\r\n FCtrls := TList.Create;\r\n\r\n if IsWinXP_UP then\r\n begin\r\n FDefaultImages := TImageList.Create(nil);\r\n { According to MSDN flag ILC_COLOR32 needs to be included (?) }\r\n FDefaultImages.Handle := ImageList_Create(16, 16, ILC_COLOR32 or ILC_MASK, 4, 4);\r\n end\r\n else\r\n FDefaultImages := TImageList.CreateSize(16, 16);\r\n\r\n { Only need to update the background color in XP when using pre v6.0 ComCtl32.dll\r\n image lists }\r\n FNeedUpdateBkColor := IsWinXP_UP and (GetComCtlVersion < $00060000);\r\n\r\n if FNeedUpdateBkColor then\r\n FDefaultImages.BkColor := Application.HintColor\r\n else\r\n FDefaultImages.BkColor := clNone;\r\n\r\n FBkColor := Application.HintColor;\r\n FUseBalloonAsApplicationHint := False;\r\n\r\n GetDefaultImages;\r\n GetDefaultSounds;\r\nend;\r\n\r\ndestructor TGlobalCtrl.Destroy;\r\nbegin\r\n FDefaultImages.Free;\r\n FCtrls.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TGlobalCtrl.Add(ABalloonHint: TJvBalloonHint);\r\nbegin\r\n FCtrls.Add(ABalloonHint);\r\n { Determine whether we are designing }\r\n if Assigned(ABalloonHint) then\r\n FDesigning := csDesigning in ABalloonHint.ComponentState;\r\nend;\r\n\r\nprocedure TGlobalCtrl.DrawHintImage(Canvas: TCanvas; X, Y: Integer; const ABkColor: TColor);\r\nbegin\r\n DrawHintImage(Canvas, X, Y, MainCtrl.DefaultIcon, MainCtrl.DefaultImageIndex, ABkColor);\r\nend;\r\n\r\nprocedure TGlobalCtrl.DrawHintImage(Canvas: TCanvas; X, Y: Integer;\r\n const AIconKind: TJvIconKind; const AImageIndex: TImageIndex; const ABkColor: TColor);\r\nconst\r\n cDefaultImages: array [TJvIconKind] of Integer = (-1, -1, 0, 1, 2, 3, 4);\r\nbegin\r\n case AIconKind of\r\n ikCustom:\r\n with MainCtrl do\r\n if not Assigned(Images) or (AImageIndex < 0) or (AImageIndex >= Images.Count) then\r\n begin\r\n BkColor := ABkColor;\r\n FDefaultImages.Draw(Canvas, X, Y, cDefaultImages[ikInformation]);\r\n end\r\n else\r\n Images.Draw(Canvas, X, Y, AImageIndex);\r\n ikNone:\r\n ;\r\n else\r\n BkColor := ABkColor;\r\n FDefaultImages.Draw(Canvas, X, Y, cDefaultImages[AIconKind]);\r\n end;\r\nend;\r\n\r\nprocedure TGlobalCtrl.GetDefaultImages;\r\ntype\r\n TPictureType = (ptXP, ptNormal, ptSimple);\r\nconst\r\n { Get the images:\r\n\r\n For From ID TJvIconKind Spec\r\n ---------------------------------------------------------------------------\r\n Windows XP User32.dll 100 ikApplication 16x16 32x32 48x48 1,4,8,32 bpp\r\n 101 ikWarning\r\n 102 ikQuestion\r\n 103 ikError\r\n 104 ikInformation\r\n 105 ikApplication\r\n All (?) comctl32.dll 20480 ikError 16x16 32x32 4 bpp\r\n 20481 ikInformation\r\n 20482 ikWarning\r\n }\r\n\r\n { ikApplication, ikError, ikInformation, ikQuestion, ikWarning }\r\n cIcons: array [TPictureType, ikApplication..ikWarning] of Integer =\r\n (\r\n (100, 103, 104, 102, 101), // XP\r\n (OIC_SAMPLE, 20480, 20481, OIC_QUES, 20482), // Normal\r\n (OIC_SAMPLE, OIC_HAND, OIC_NOTE, OIC_QUES, OIC_BANG) // Paranoid\r\n );\r\n cFlags: array [Boolean] of UINT = (0, LR_SHARED);\r\nvar\r\n IconKind: TJvIconKind;\r\n PictureType: TPictureType;\r\n IconHandle: THandle;\r\n Shared: Boolean;\r\n Modules: array [Boolean] of HMODULE;\r\nbegin\r\n PictureType := ptNormal;\r\n Modules[True] := 0;\r\n\r\n if IsWinXP_UP and (GetComCtlVersion >= ComCtlVersionIE6) then\r\n begin\r\n Modules[False] := GetModuleHandle('user32.dll');\r\n if Modules[False] <> 0 then\r\n PictureType := ptXP\r\n end;\r\n\r\n if PictureType = ptNormal then\r\n begin\r\n Modules[False] := GetModuleHandle('comctl32.dll');\r\n if Modules[False] = 0 then\r\n PictureType := ptSimple;\r\n end;\r\n\r\n { Now PictureType = ptXP -> Modules = (user32.dll handle, 0)\r\n PictureType = ptNormal -> Modules = (comctl32.dll handle, 0)\r\n PictureType = ptSimple -> Modules = (0, 0)\r\n }\r\n\r\n for IconKind := Low(cIcons[PictureType]) to High(cIcons[PictureType]) do\r\n begin\r\n Shared := (PictureType = ptSimple) or\r\n ((PictureType = ptNormal) and (IconKind in [ikApplication, ikQuestion]));\r\n IconHandle :=\r\n LoadImage(Modules[Shared], MakeIntResource(cIcons[PictureType, IconKind]),\r\n IMAGE_ICON, 16, 16, cFlags[Shared]);\r\n ImageList_AddIcon(FDefaultImages.Handle, IconHandle);\r\n { MSDN: Do not use DestroyIcon to destroy a shared icon. A shared icon is\r\n valid as long as the module from which it was loaded remains in memory }\r\n if not Shared then\r\n DestroyIcon(IconHandle);\r\n end;\r\nend;\r\n\r\nprocedure TGlobalCtrl.GetDefaultSounds;\r\n{ Taken from ActnMenus.pas }\r\nvar\r\n Registry: TRegistry;\r\n\r\n function ReadSoundSetting(KeyStr: string): string;\r\n var\r\n S: string;\r\n begin\r\n Registry.RootKey := HKEY_CURRENT_USER;\r\n Result := '';\r\n if Registry.OpenKeyReadOnly('\\AppEvents\\Schemes\\Apps\\.Default\\' + KeyStr) then\r\n try\r\n S := Registry.ReadString('');\r\n SetLength(Result, 4096);\r\n SetLength(Result, ExpandEnvironmentStrings(PChar(S), PChar(Result), 4096) - 1);\r\n finally\r\n Registry.CloseKey;\r\n end;\r\n end;\r\n\r\nbegin\r\n Registry := TRegistry.Create;\r\n try\r\n FSounds[ikCustom] := ReadSoundSetting('SystemNotification\\.Current');\r\n FSounds[ikNone] := FSounds[ikCustom];\r\n FSounds[ikApplication] := FSounds[ikCustom];\r\n FSounds[ikError] := ReadSoundSetting('SystemHand\\.Current');\r\n FSounds[ikInformation] := ReadSoundSetting('SystemAsterisk\\.Current');\r\n FSounds[ikQuestion] := ReadSoundSetting('SystemQuestion\\.Current');\r\n FSounds[ikWarning] := ReadSoundSetting('SystemExclamation\\.Current');\r\n finally\r\n Registry.Free;\r\n end;\r\nend;\r\n\r\nfunction TGlobalCtrl.GetMainCtrl: TJvBalloonHint;\r\nbegin\r\n if FCtrls.Count = 0 then\r\n begin\r\n if GMainCtrl = nil then\r\n GMainCtrl := TJvBalloonHint.Create(Self);\r\n Result := GMainCtrl;\r\n end\r\n else\r\n Result := TJvBalloonHint(FCtrls[0]);\r\nend;\r\n\r\nfunction TGlobalCtrl.HintImageSize: TSize;\r\nbegin\r\n Result := HintImageSize(MainCtrl.DefaultIcon, MainCtrl.DefaultImageIndex);\r\nend;\r\n\r\nfunction TGlobalCtrl.HintImageSize(const AIconKind: TJvIconKind;\r\n const AImageIndex: TImageIndex): TSize;\r\nbegin\r\n case AIconKind of\r\n ikCustom:\r\n with MainCtrl do\r\n if not Assigned(Images) or (AImageIndex < 0) or (AImageIndex >= Images.Count) then\r\n begin\r\n Result.cx := 16;\r\n Result.cy := 16;\r\n end\r\n else\r\n begin\r\n Result.cx := Images.Width;\r\n Result.cy := Images.Height;\r\n end;\r\n ikNone:\r\n begin\r\n Result.cx := 0;\r\n Result.cy := 0;\r\n end;\r\n else\r\n begin\r\n Result.cx := 16;\r\n Result.cy := 16;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TGlobalCtrl.PlaySound(const AIconKind: TJvIconKind);\r\nbegin\r\n if Length(FSounds[AIconKind]) > 0 then\r\n sndPlaySound(PChar(FSounds[AIconKind]), SND_NOSTOP or SND_ASYNC);\r\nend;\r\n\r\nprocedure TGlobalCtrl.Remove(ABalloonHint: TJvBalloonHint);\r\nvar\r\n I: Integer;\r\nbegin\r\n I := FCtrls.IndexOf(ABalloonHint);\r\n if I >= 0 then\r\n begin\r\n FCtrls.Delete(I);\r\n\r\n if FCtrls.Count = 0 then\r\n UseBalloonAsApplicationHint := False;\r\n end;\r\nend;\r\n\r\nprocedure TGlobalCtrl.SetBkColor(const Value: TColor);\r\nbegin\r\n if FNeedUpdateBkColor and (FBkColor <> Value) then\r\n begin\r\n { Icons in windows XP use an alpha channel to 'blend' with the background.\r\n If the background color changes, then the images must be redrawn,\r\n when using pre v6.0 ComCtl32.dll image lists\r\n }\r\n FBkColor := Value;\r\n FDefaultImages.Clear;\r\n FDefaultImages.BkColor := FBkColor;\r\n GetDefaultImages;\r\n end;\r\nend;\r\n\r\nprocedure TGlobalCtrl.SetUseBalloonAsApplicationHint(const Value: Boolean);\r\nbegin\r\n if FDesigning then\r\n FUseBalloonAsApplicationHint := Value\r\n else\r\n if Value <> FUseBalloonAsApplicationHint then\r\n begin\r\n FUseBalloonAsApplicationHint := Value;\r\n\r\n Application.CancelHint;\r\n\r\n if FUseBalloonAsApplicationHint then\r\n begin\r\n FOldHintWindowClass := HintWindowClass;\r\n HintWindowClass := TJvBalloonWindow;\r\n end\r\n else\r\n HintWindowClass := FOldHintWindowClass;\r\n end;\r\nend;\r\n\r\n//=== { TJvBalloonWindowEx } =================================================\r\n\r\nprocedure TJvBalloonWindowEx.ChangeCloseState(const AState: Cardinal);\r\nbegin\r\n if AState <> FCloseState then\r\n begin\r\n FCloseState := AState;\r\n InvalidateRect(Self.Handle, @FCloseBtnRect, True);\r\n end;\r\nend;\r\n\r\nfunction FormHasFocus(FormHandle: HWND): Boolean;\r\nvar\r\n H: HWND;\r\nbegin\r\n H := GetFocus;\r\n while IsWindow(H) and (H <> FormHandle) do\r\n H := GetParent(H);\r\n Result := H = FormHandle;\r\nend;\r\n\r\nprocedure TJvBalloonWindowEx.EnsureTopMost;\r\nbegin\r\n if not Assigned(FCtrl.FData.RAnchorWindow) then\r\n Exit;\r\n\r\n if not FormHasFocus(FCtrl.FData.RAnchorWindow.Handle) then\r\n { Current window is not focused, thus place the balloon behind the\r\n window that has focus }\r\n NormalizeTopMost\r\n else\r\n RestoreTopMost;\r\nend;\r\n\r\nprocedure TJvBalloonWindowEx.Init(AData: Pointer);\r\nbegin\r\n Canvas.Font := Screen.HintFont;\r\n Color := Application.HintColor;\r\n\r\n with PHintData(AData)^ do\r\n begin\r\n FImageIndex := RImageIndex;\r\n FIconKind := RIconKind;\r\n FHeader := {$IFDEF RTL200_UP}System.{$ENDIF RTL200_UP}UTF8ToWideString(RUTF8Header);\r\n if FHeader = '' then\r\n FHeader := WideString(RUTF8Header);\r\n\r\n FShowHeader := FHeader > '';\r\n FShowIcon := (FIconKind <> ikNone) and\r\n ((FIconKind <> ikCustom) or (FImageIndex <> -1));\r\n FShowCloseBtn := RShowCloseBtn;\r\n\r\n FAnimationTime := RAnimationTime;\r\n FAnimationStyle := RAnimationStyle;\r\n\r\n FSwitchHeight := RSwitchHeight;\r\n FIsAnchored := Assigned(RAnchorWindow);\r\n end;\r\n\r\n FImageSize := GlobalCtrl.HintImageSize(FIconKind, FImageIndex);\r\n FCurrentPosition := FCtrl.DefaultBalloonPosition;\r\nend;\r\n\r\nprocedure BoundRect(var ARect: TRect; const BoundingRect: TRect);\r\nbegin\r\n if BoundingRect.Left > ARect.Left then\r\n begin\r\n ARect.Right := ARect.Right + (BoundingRect.Left - ARect.Left);\r\n ARect.Left := BoundingRect.Left;\r\n end;\r\n if BoundingRect.Top > ARect.Top then\r\n begin\r\n ARect.Bottom := ARect.Bottom + (BoundingRect.Top - ARect.Top);\r\n ARect.Top := BoundingRect.Top;\r\n end;\r\n if BoundingRect.Right < ARect.Right then\r\n begin\r\n ARect.Left := ARect.Left - (ARect.Right - BoundingRect.Right);\r\n ARect.Right := BoundingRect.Right;\r\n end;\r\n if BoundingRect.Bottom < ARect.Bottom then\r\n begin\r\n ARect.Top := ARect.Top - (ARect.Bottom - BoundingRect.Bottom);\r\n ARect.Bottom := BoundingRect.Bottom;\r\n end;\r\nend;\r\n\r\nprocedure TJvBalloonWindowEx.InternalActivateHint(var Rect: TRect;\r\n const AHint: string);\r\nconst\r\n {TJvAnimationStyle = (atNone, atSlide, atRoll, atRollHorNeg, atRollHorPos, atRollVerNeg,\r\n atRollVerPos, atSlideHorNeg, atSlideHorPos, atSlideVerNeg, atSlideVerPos, atCenter, atBlend);}\r\n cAnimationStyle: array [TJvAnimationStyle] of Integer =\r\n (0, AW_SLIDE, 0, AW_HOR_NEGATIVE,\r\n AW_HOR_POSITIVE, AW_VER_NEGATIVE, AW_VER_POSITIVE, AW_HOR_NEGATIVE or AW_SLIDE,\r\n AW_HOR_POSITIVE or AW_SLIDE, AW_VER_NEGATIVE or AW_SLIDE, AW_VER_POSITIVE or AW_SLIDE,\r\n AW_CENTER, AW_BLEND);\r\nvar\r\n AutoValue: Integer;\r\nbegin\r\n FCloseState := DFCS_FLAT;\r\n CheckPosition(Rect);\r\n\r\n if HandleAllocated and IsWindowVisible(Handle) then\r\n begin\r\n Hide;\r\n if ParentWindow = 0 then\r\n ShowWindow(Handle, SW_HIDE);\r\n end;\r\n\r\n { This will prevent focusing/unfocusing of the application button on the\r\n taskbar when clicking on the balloon window }\r\n if FIsAnchored then\r\n { Application Handle, so we automatically get minimized/restored when the\r\n application minimizes/restores }\r\n ParentWindow := Application.Handle\r\n else\r\n ParentWindow := 0;\r\n\r\n BoundRect(Rect, DesktopRect);\r\n\r\n SetBounds(Rect.Left, Rect.Top, Rect.Right - Rect.Left, Rect.Bottom - Rect.Top);\r\n UpdateRegion;\r\n\r\n { Set the Z order of the balloon }\r\n if Assigned(FCtrl.FData.RAnchorWindow) then\r\n begin\r\n if not IsWindowVisible(FCtrl.FData.RAnchorWindow.Handle) or\r\n IsIconic(FCtrl.FData.RAnchorWindow.Handle) then\r\n { Current window is minimized, thus do not show the balloon }\r\n Exit\r\n else\r\n EnsureTopMost;\r\n end\r\n else\r\n RestoreTopMost;\r\n\r\n // can only blend on Vista\r\n if IsWinVista_UP and (GetComCtlVersion >= ComCtlVersionIE6) then\r\n if FAnimationStyle <> atNone then\r\n FAnimationStyle := atBlend;\r\n\r\n if (FAnimationStyle <> atNone) and IsWinXP_UP and (GetComCtlVersion >= ComCtlVersionIE6) and Assigned(AnimateWindowProc) then\r\n begin\r\n if FAnimationStyle in [atSlide, atRoll] then\r\n case FCurrentPosition of\r\n bpLeftDown, bpRightDown:\r\n AutoValue := AW_VER_POSITIVE;\r\n else {bpLeftUp, bpRightUp:}\r\n AutoValue := AW_VER_NEGATIVE;\r\n end\r\n else\r\n AutoValue := 0;\r\n { This function will fail on systems other than Windows XP,\r\n because of use of the window region: }\r\n AnimateWindowProc(Handle, FAnimationTime, cAnimationStyle[FAnimationStyle] or AutoValue);\r\n end;\r\n\r\n { Ensure property Visible is set to True: }\r\n Show;\r\n { If ParentWindow = 0, calling Show won't trigger the CM_SHOWINGCHANGED message\r\n thus ShowWindow/SetWindowPos isn't called. We do it ourselfs: }\r\n if ParentWindow = 0 then\r\n ShowWindow(Handle, SW_SHOWNOACTIVATE);\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvBalloonWindowEx.MoveWindow(NewPos: TPoint);\r\nbegin\r\n BoundsRect := Rect(NewPos.X, NewPos.Y, NewPos.X + Width, NewPos.Y + Height);\r\nend;\r\n\r\nprocedure TJvBalloonWindowEx.NormalizeTopMost;\r\nvar\r\n TopWindow: HWND;\r\nbegin\r\n if not Assigned(FCtrl.FData.RAnchorWindow) then\r\n Exit;\r\n\r\n { Retrieve the window below the anchor window in the Z order. }\r\n TopWindow := GetWindow(FCtrl.FData.RAnchorWindow.Handle, GW_HWNDPREV);\r\n if GetWindowLong(TopWindow, GWL_EXSTYLE) and WS_EX_TOPMOST <> 0 then\r\n TopWindow := HWND_NOTOPMOST;\r\n\r\n SetWindowPos(Handle, TopWindow, 0, 0, 0, 0,\r\n SWP_NOMOVE or SWP_NOSIZE or SWP_NOACTIVATE or SWP_NOOWNERZORDER);\r\nend;\r\n\r\nprocedure TJvBalloonWindowEx.Paint;\r\n{$IFDEF JVCLThemesEnabled}\r\nvar\r\n Details: TThemedElementDetails;\r\n Button: TThemedToolTip;\r\n{$ENDIF JVCLThemesEnabled}\r\nbegin\r\n if FShowIcon then\r\n with FIconPos do\r\n GlobalCtrl.DrawHintImage(Canvas, X, Y, FIconKind, FImageIndex, Color);\r\n\r\n if FShowCloseBtn then\r\n begin\r\n {$IFDEF JVCLThemesEnabled}\r\n if ThemeServices.{$IFDEF RTL230_UP}Enabled{$ELSE}ThemesEnabled{$ENDIF RTL230_UP} then\r\n begin\r\n if (FCloseState and DFCS_PUSHED > 0) and (FCloseState and DFCS_HOT = 0) then\r\n Button := tttCloseNormal\r\n else\r\n if FCloseState and DFCS_PUSHED > 0 then\r\n Button := tttClosePressed\r\n else\r\n if (FCloseState and DFCS_HOT > 0) and not (csDesigning in ComponentState) then\r\n Button := tttCloseHot\r\n else\r\n Button := tttCloseNormal;\r\n\r\n Details := ThemeServices.GetElementDetails(Button);\r\n ThemeServices.DrawElement(Canvas.Handle, Details, FCloseBtnRect);\r\n end\r\n else\r\n {$ENDIF JVCLThemesEnabled}\r\n DrawFrameControl(Canvas.Handle, FCloseBtnRect, DFC_CAPTION, DFCS_TRANSPARENT or\r\n DFCS_CAPTIONCLOSE or FCloseState);\r\n end;\r\n\r\n if FMsg > '' then\r\n begin\r\n GetHintMessageFont(Canvas.Font);\r\n DrawTextW(Canvas.Handle, FMsg, FMsgRect,\r\n DefaultTextFlags or DrawTextBiDiModeFlagsReadingOnly);\r\n end;\r\n\r\n if FShowHeader then\r\n begin\r\n GetHintTitleFont(Canvas.Font);\r\n DrawTextW(Canvas.Handle, FHeader, FHeaderRect,\r\n DefaultTextFlags or DrawTextBiDiModeFlagsReadingOnly);\r\n end;\r\nend;\r\n\r\nprocedure TJvBalloonWindowEx.RestoreTopMost;\r\nbegin\r\n SetWindowPos(Handle, HWND_TOPMOST, 0, 0, 0, 0,\r\n SWP_NOMOVE or SWP_NOSIZE or SWP_NOACTIVATE or SWP_NOOWNERZORDER);\r\nend;\r\n\r\nprocedure TJvBalloonWindowEx.WMActivateApp(var Msg: TWMActivateApp);\r\nbegin\r\n inherited;\r\n if Msg.Active then\r\n EnsureTopMost;\r\nend;\r\n\r\nprocedure TJvBalloonWindowEx.WMLButtonDown(var Msg: TWMLButtonDown);\r\nbegin\r\n inherited;\r\n if FShowCloseBtn then\r\n begin\r\n if PtInRect(FCloseBtnRect, SmallPointToPoint(Msg.Pos)) then\r\n begin\r\n {SetCapture(Handle);}// handled in inherited\r\n ChangeCloseState(FCloseState or DFCS_PUSHED);\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvBalloonWindowEx.WMLButtonUp(var Msg: TWMLButtonUp);\r\nbegin\r\n if FShowCloseBtn then\r\n begin\r\n if FCloseState and DFCS_PUSHED > 0 then\r\n begin\r\n {ReleaseCapture;}// handled in inherited\r\n ChangeCloseState(FCloseState and not DFCS_PUSHED);\r\n if PtInRect(FCloseBtnRect, SmallPointToPoint(Msg.Pos)) then\r\n begin\r\n { Prevent firing of OnClick event in inherited call }\r\n ControlState := ControlState - [csClicked];\r\n if FCtrl.HandleCloseBtnClick then\r\n FCtrl.CancelHint;\r\n end;\r\n end;\r\n end;\r\n inherited;\r\nend;\r\n\r\nprocedure TJvBalloonWindowEx.WMMouseMove(var Msg: TWMMouseMove);\r\nvar\r\n State: Cardinal;\r\nbegin\r\n inherited;\r\n if FShowCloseBtn then\r\n begin\r\n State := DFCS_FLAT;\r\n\r\n if PtInRect(FCloseBtnRect, SmallPointToPoint(Msg.Pos)) and\r\n not (csDesigning in ComponentState) then\r\n begin\r\n { Note: DFCS_HOT is not supported in windows 95 systems }\r\n State := State or DFCS_HOT;\r\n if FCloseState and DFCS_PUSHED > 0 then\r\n State := State or DFCS_PUSHED;\r\n end;\r\n ChangeCloseState(State);\r\n end;\r\nend;\r\n\r\nprocedure TJvBalloonWindowEx.WMNCHitTest(var Msg: TWMNCHitTest);\r\nbegin\r\n Msg.Result := HTCLIENT;\r\nend;\r\n\r\ninitialization\r\n {$IFDEF UNITVERSIONING}\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n {$ENDIF UNITVERSIONING}\r\n InitUnicodeWrap;\r\n\r\nfinalization\r\n FreeAndNil(GGlobalCtrl);\r\n {$IFDEF UNITVERSIONING}\r\n UnregisterUnitVersion(HInstance);\r\n {$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvBandForms.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: kvBandForms.PAS, released on 2001-07-10.\r\n\r\nThe Initial Developer of the Original Code is Chiang Seng Chang \r\nPortions created by Chiang Seng Chang are Copyright (C) 2001 Chiang Seng Chang.\r\nAll Rights Reserved.\r\n\r\nContributor(s): ______________________________________.\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI home page,\r\nlocated at http://www.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvBandForms.pas 13411 2012-09-07 22:31:43Z ahuser $\r\n\r\nunit JvBandForms;\r\n\r\n{$I jvcl.inc}\r\n{$I windowsonly.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, Messages, ComObj, Classes, Forms, Controls, Menus, JvComponent;\r\n\r\ntype\r\n {:Band object mode flag.\r\n @enum bmfVariableHeight Height of the band object can be changed.\r\n @enum bmfDebossed Band object displayed with a sunken appearance.\r\n @enum bmfBkColor Band object displayed with the background color specified in the band form's Color property.\r\n @seeAlso \r\n @seeAlso \r\n }\r\n TJvBandModeFlag = (bmfVariableHeight, bmfDebossed, bmfBkColor);\r\n\r\n {:Set of band object mode flags.\r\n @seeAlso \r\n }\r\n TJvBandModeFlags = set of TJvBandModeFlag;\r\n\r\n {:Event type for band form's OnBandGetXXXX events.\r\n @seeAlso \r\n @seeAlso \r\n @seeAlso \r\n @seeAlso \r\n }\r\n TzGetPointLEvent = function(Sender: TObject): TPointL of object;\r\n\r\n {:Base class for band forms.\r\n @cat JvBandFormComponents\r\n }\r\n TJvBandForm = class(TJvForm)\r\n private\r\n FBandObject: TComObject;\r\n FBandModeFlags: TJvBandModeFlags;\r\n FBandContextMenu: TPopupMenu;\r\n FBandIntegralX: Word;\r\n FBandIntegralY: Word;\r\n FOnGetMinSize: TzGetPointLEvent;\r\n FOnGetMaxSize: TzGetPointLEvent;\r\n FOnGetIntegral: TzGetPointLEvent;\r\n FOnGetActualSize: TzGetPointLEvent;\r\n function GetMinSize: TPointL;\r\n function GetMaxSize: TPointL;\r\n function GetIntegral: TPointL;\r\n function GetActualSize: TPointL;\r\n procedure SetContextMenu(const Value: TPopupMenu);\r\n protected\r\n procedure Notification(AComponent: TComponent;\r\n Operation: TOperation); override;\r\n property _BandObject: TComObject read FBandObject;\r\n public\r\n procedure AfterConstruction; override;\r\n procedure BeforeDestruction; override;\r\n\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n {:Band form constructor.\r\n Use this constructor to create a band form.
\r\n The band object wizard generates code which calls this constructor\r\n automatically.
\r\n When the band form is created, its ClientWidth and ClientHeight is\r\n set to the size of ParentWindow.

\r\n Note. This is a constructor, Time2Help (the help file generator)\r\n mislabelled this as a procedure !\r\n
\r\n @param ParentWindow The parent window of the band form.\r\n @param BandObject The band object associated with the band form.\r\n }\r\n constructor CreateBandForm(const ParentWindow: THandle; const BandObject: TComObject);\r\n constructor CreateNew(AOwner: TComponent; Dummy: Integer = 0); override;\r\n {:Returns the minimum size of the band form in a TPointL structure.\r\n Minimum size is obtained from in the properties Constraints.MinWidth and\r\n Constraints.MinHeight.
\r\n Use OnBandGetMinSize event to override this.\r\n @seeAlso \r\n @seeAlso \r\n @seeAlso \r\n }\r\n property BandMinSize: TPointL read GetMinSize;\r\n {:Returns the maximum size of the band form in a TPointL structure.\r\n Maximum size is obtained from the properties Constraints.MaxWidth and\r\n Constraints.MaxHeight.
\r\n Use OnBandGetMaxSize event to override this.\r\n @seeAlso \r\n @seeAlso \r\n @seeAlso \r\n }\r\n property BandMaxSize: TPointL read GetMaxSize;\r\n {:Returns the sizing step of the band form in a TPointL structure.\r\n Sizing step is obtained from the properties BandIntegralX and BandIntegralY.
\r\n Use OnBandGetIntegral event to override this.\r\n @seeAlso \r\n @seeAlso \r\n @seeAlso \r\n @seeAlso \r\n }\r\n property BandIntegral: TPointL read GetIntegral;\r\n {:Returns the actual size of the band form in a TPointL structure.\r\n Actual size is obtained from the properties ClientWidth and ClientHeight.
\r\n Use OnBandGetActualSize event to override this.\r\n @seeAlso \r\n @seeAlso \r\n @seeAlso \r\n @seeAlso \r\n }\r\n property BandActualSize: TPointL read GetActualSize;\r\n // Below are from TForm (Probably more properties should be hidden)\r\n // procedure ArrangeIcons;\r\n // procedure Cascade;\r\n // procedure Next;\r\n // procedure Previous;\r\n // procedure Tile;\r\n // property ActiveMDIChild;\r\n // property ClientHandle;\r\n property DockManager;\r\n // property MDIChildCount;\r\n // property MDIChildren;\r\n // property TileMode;\r\n published\r\n {:Specifies the band object's mode flags.\r\n Used by IDeskBand::GetBandInfo.\r\n @seeAlso \r\n }\r\n property BandModeFlags: TJvBandModeFlags read FBandModeFlags write FBandModeFlags default [bmfVariableHeight];\r\n {:Specifies the band object's X sizing step.\r\n @seeAlso \r\n @seeAlso \r\n }\r\n property BandIntegralX: Word read FBandIntegralX write FBandIntegralX default 1;\r\n {:Specifies the band object's Y sizing step.\r\n @seeAlso \r\n @seeAlso \r\n }\r\n property BandIntegralY: Word read FBandIntegralY write FBandIntegralY default 1;\r\n {:Specifies the band object's context menu.\r\n To integrate menuitems into the band window's context menu,\r\n drop a popup menu onto the band form and set this\r\n property to the popup menu.\r\n Note. Tool bands do not support context menu.\r\n @seeAlso \r\n @seeAlso \r\n @seeAlso \r\n }\r\n property BandContextMenu: TPopupMenu read FBandContextMenu write SetContextMenu;\r\n {:Occurs when the band form is queried for it's minimum size.\r\n @seeAlso \r\n }\r\n property OnBandGetMinSize: TzGetPointLEvent read FOnGetMinSize write FOnGetMinSize;\r\n {:Occurs when the band form is queried for it's maximum size.\r\n @seeAlso \r\n }\r\n property OnBandGetMaxSize: TzGetPointLEvent read FOnGetMaxSize write FOnGetMaxSize;\r\n {:Occurs when the band form is queried for it's sizing steps.\r\n @seeAlso \r\n }\r\n property OnBandGetIntegral: TzGetPointLEvent read FOnGetIntegral write FOnGetIntegral;\r\n {:Occurs when the band form is queried for it's actual size.\r\n @seeAlso \r\n }\r\n property OnBandGetActualSize: TzGetPointLEvent read FOnGetActualSize write FOnGetActualSize;\r\n // Below are from TForm (Probably more properties should be hidden)\r\n {: The band object's title.\r\n @seeAlso \r\n }\r\n property Caption;\r\n {: The band object's actual height.\r\n @seeAlso \r\n @seeAlso \r\n }\r\n property ClientHeight;\r\n {: The band object's actual width.\r\n @seeAlso \r\n @seeAlso \r\n }\r\n property ClientWidth;\r\n {: The band object's background color.\r\n @seeAlso \r\n }\r\n property Color;\r\n {: The band object's minimum and maximum sizes.\r\n @seeAlso \r\n @seeAlso \r\n }\r\n property Constraints;\r\n property Action;\r\n property ActiveControl;\r\n property Align;\r\n property Anchors;\r\n property AutoScroll;\r\n property AutoSize;\r\n property BiDiMode;\r\n // property BorderIcons;\r\n // property BorderStyle;\r\n // property BorderWidth;\r\n property UseDockManager;\r\n property DefaultMonitor;\r\n property DockSite;\r\n property DragKind;\r\n property DragMode;\r\n property Enabled;\r\n property ParentFont default False;\r\n property Font;\r\n // property FormStyle;\r\n property Height;\r\n property HelpFile;\r\n property HorzScrollBar;\r\n property Icon;\r\n property KeyPreview;\r\n property Menu;\r\n property OldCreateOrder;\r\n property ObjectMenuItem;\r\n property ParentBiDiMode;\r\n property PixelsPerInch;\r\n property PopupMenu;\r\n // property Position;\r\n property PrintScale;\r\n property Scaled;\r\n property ShowHint;\r\n property VertScrollBar;\r\n // property Visible;\r\n property Width;\r\n property WindowState;\r\n property WindowMenu;\r\n property OnActivate;\r\n property OnCanResize;\r\n property OnClick;\r\n property OnClose;\r\n // property OnCloseQuery;\r\n property OnConstrainedResize;\r\n property OnContextPopup;\r\n property OnCreate;\r\n property OnDblClick;\r\n property OnDestroy;\r\n property OnDeactivate;\r\n property OnDockDrop;\r\n property OnDockOver;\r\n property OnDragDrop;\r\n property OnDragOver;\r\n property OnEndDock;\r\n property OnGetSiteInfo;\r\n property OnHide;\r\n property OnHelp;\r\n property OnKeyDown;\r\n property OnKeyPress;\r\n property OnKeyUp;\r\n property OnMouseDown;\r\n property OnMouseMove;\r\n property OnMouseUp;\r\n property OnMouseWheel;\r\n property OnMouseWheelDown;\r\n property OnMouseWheelUp;\r\n property OnPaint;\r\n property OnResize;\r\n property OnShortCut;\r\n property OnShow;\r\n property OnStartDock;\r\n property OnUnDock;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvBandForms.pas $';\r\n Revision: '$Revision: 13411 $';\r\n Date: '$Date: 2012-09-08 00:31:43 +0200 (sam. 08 sept. 2012) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n SysUtils, JclIDEUtils, JvJCLUtils, JvJVCLUtils;\r\n\r\nvar\r\n GlobalBandFormMessageHook: HHook;\r\n GlobalBandForms: TList;\r\n\r\nprocedure InstallHook; forward;\r\nprocedure UninstallHook; forward;\r\n\r\n//=== { TJvBandForm } ========================================================\r\n\r\nprocedure TJvBandForm.AfterConstruction;\r\nbegin\r\n inherited AfterConstruction;\r\n GlobalBandForms.Add(Self);\r\n if (GlobalBandForms.Count = 1) and not (csDesigning in ComponentState) then\r\n InstallHook;\r\nend;\r\n\r\nprocedure TJvBandForm.BeforeDestruction;\r\nbegin\r\n GlobalBandForms.Remove(Self);\r\n if (GlobalBandForms.Count = 0) and not (csDesigning in ComponentState) then\r\n UninstallHook;\r\n inherited BeforeDestruction;\r\nend;\r\n\r\nconstructor TJvBandForm.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FBandModeFlags := [bmfVariableHeight];\r\n FBandIntegralX := 1;\r\n FBandIntegralY := 1;\r\n BorderIcons := [];\r\n BorderStyle := bsNone;\r\n BorderWidth := 0;\r\n FormStyle := fsNormal;\r\n Position := poDesigned;\r\n Visible := False;\r\n ParentFont := False;\r\nend;\r\n\r\nconstructor TJvBandForm.CreateBandForm(const ParentWindow: THandle; const BandObject: TComObject);\r\nvar\r\n Rect: TRect;\r\nbegin\r\n CreateParented(ParentWindow); // Band form should be a child window.\r\n FBandObject := BandObject;\r\n Windows.GetClientRect(ParentWindow, Rect);\r\n ClientWidth := Rect.Right - Rect.Left + 1;\r\n ClientHeight := Rect.Bottom - Rect.Top + 1;\r\nend;\r\n\r\nconstructor TJvBandForm.CreateNew(AOwner: TComponent; Dummy: Integer);\r\nbegin\r\n inherited CreateNew(AOwner);\r\n FBandModeFlags := [bmfVariableHeight];\r\n FBandIntegralX := 1;\r\n FBandIntegralY := 1;\r\n BorderStyle := bsNone;\r\n Visible := False;\r\nend;\r\n\r\ndestructor TJvBandForm.Destroy;\r\nbegin\r\n ControlStyle := ControlStyle + [csNoStdEvents];\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJvBandForm.GetMinSize: TPointL;\r\nbegin\r\n if Assigned(FOnGetMinSize) then\r\n Result := FOnGetMinSize(Self)\r\n else\r\n Result := PointL(Constraints.MinWidth, Constraints.MinHeight);\r\nend;\r\n\r\nfunction TJvBandForm.GetMaxSize: TPointL;\r\nbegin\r\n if Assigned(FOnGetMaxSize) then\r\n Result := FOnGetMaxSize(Self)\r\n else\r\n Result := PointL(iif(Constraints.MaxWidth = 0, -1, Constraints.MaxWidth),\r\n iif(Constraints.MaxHeight = 0, -1, Constraints.MaxHeight));\r\nend;\r\n\r\nfunction TJvBandForm.GetIntegral: TPointL;\r\nbegin\r\n if Assigned(FOnGetIntegral) then\r\n Result := FOnGetIntegral(Self)\r\n else\r\n Result := PointL(FBandIntegralX, FBandIntegralY);\r\nend;\r\n\r\nfunction TJvBandForm.GetActualSize: TPointL;\r\nbegin\r\n if Assigned(FOnGetActualSize) then\r\n Result := FOnGetActualSize(Self)\r\n else\r\n Result := PointL(ClientWidth, ClientHeight);\r\nend;\r\n\r\nprocedure TJvBandForm.SetContextMenu(const Value: TPopupMenu);\r\nbegin\r\n ReplaceComponentReference(Self, Value, TComponent(FBandContextMenu));\r\nend;\r\n\r\nprocedure TJvBandForm.Notification(AComponent: TComponent;\r\n Operation: TOperation);\r\nbegin\r\n inherited Notification(AComponent, Operation);\r\n case Operation of\r\n opRemove:\r\n if AComponent = FBandContextMenu then\r\n FBandContextMenu := nil;\r\n end;\r\nend;\r\n\r\n{$IFDEF RTL230_UP}\r\nfunction MsgHookProc(nCode: Integer; wParam: WPARAM; lParam: LPARAM): LRESULT; stdcall;\r\n{$ELSE}\r\nfunction MsgHookProc(nCode, wParam, lParam: Integer): Integer; stdcall;\r\n{$ENDIF RTL230_UP}\r\nvar\r\n lOk: Boolean;\r\n I: Integer;\r\n Msg: PMsg;\r\nbegin\r\n if nCode >= 0 then\r\n try\r\n lOk := False;\r\n Msg := PMsg(Pointer(lParam));\r\n if (((Msg^.message = WM_KEYDOWN) or (Msg^.message = WM_KEYUP)) and\r\n ((Msg^.wParam = VK_BACK))) then\r\n lOk := True\r\n else\r\n if Msg^.message = WM_MOUSEMOVE then //Enable Flat effects!\r\n Application.HandleMessage;\r\n if lOk then\r\n begin\r\n for I := 0 to GlobalBandForms.Count - 1 do\r\n if IsDialogMessage(TJvBandForm(GlobalBandForms.Items[I]).Handle, Msg^) then\r\n begin\r\n Msg^.message := WM_NULL;\r\n Break;\r\n end;\r\n end;\r\n except\r\n end;\r\n Result := CallNextHookEx(GlobalBandFormMessageHook, nCode, wParam, lParam);\r\nend;\r\n\r\nprocedure InstallHook;\r\nvar\r\n Installations: TJclBorRADToolInstallations;\r\n DelphiVersion: Integer;\r\n RunningInIDE: Boolean;\r\nbegin\r\n Installations := TJclBorRADToolInstallations.Create;\r\n try\r\n if CompilerVersion >= 21 then\r\n DelphiVersion := Trunc(CompilerVersion - 7)\r\n else if CompilerVersion = 18.5 then\r\n DelphiVersion := 11\r\n else\r\n DelphiVersion := Trunc(CompilerVersion - 8);\r\n\r\n RunningInIDE := SameText(ParamStr(0), Installations.DelphiInstallationFromVersion[DelphiVersion].IdeExeFileName);\r\n finally\r\n Installations.Free;\r\n end;\r\n\r\n // Only install hook if not in IDE so as not to introduce glitches in the IDE\r\n if not RunningInIDE then\r\n GlobalBandFormMessageHook := SetWindowsHookEx(WH_GETMESSAGE, MsgHookProc, HInstance, GetCurrentThreadID);\r\nend;\r\n\r\nprocedure UninstallHook;\r\nbegin\r\n if GlobalBandFormMessageHook <> 0 then\r\n begin\r\n UnhookWindowsHookEx(GlobalBandFormMessageHook);\r\n GlobalBandFormMessageHook := 0;\r\n end;\r\nend;\r\n\r\ninitialization\r\n {$IFDEF UNITVERSIONING}\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n {$ENDIF UNITVERSIONING}\r\n GlobalBandForms := TList.Create;\r\n\r\nfinalization\r\n GlobalBandForms.Free;\r\n {$IFDEF UNITVERSIONING}\r\n UnregisterUnitVersion(HInstance);\r\n {$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n\r\n" }, { "path": "External/Jedi/Jvcl/run/JvBandObject.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvBandObject.PAS, released on 2001-07-10.\r\n\r\nThe Initial Developer of the Original Code is Chiang Seng Chang \r\nPortions created by Chiang Seng Chang are Copyright (C) 2001 Chiang Seng Chang.\r\nAll Rights Reserved.\r\n\r\nContributor(s): ______________________________________.\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI home page,\r\nlocated at http://www.delphi-jedi.org\r\n\r\nDescription:\r\n Band objects wrapper classes.\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvBandObject.pas 13104 2011-09-07 06:50:43Z obones $\r\n\r\nunit JvBandObject;\r\n\r\n{$I jvcl.inc}\r\n{$I windowsonly.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, Messages, ComObj, ShlObj, ActiveX, Classes, Controls,\r\n JvBandForms;\r\n\r\nconst\r\n CATID_DESKBAND = '{00021492-0000-0000-C000-000000000046}';\r\n CATID_INFOBAND = '{00021493-0000-0000-C000-000000000046}';\r\n CATID_COMMBAND = '{00021494-0000-0000-C000-000000000046}';\r\n\r\ntype\r\n // Band Object Factory Classes\r\n TzCustomBandObjectFactory = class(TComObjectFactory)\r\n private\r\n function GetClassIDString: string;\r\n public\r\n property ClassIDString: string read GetClassIDString;\r\n end;\r\n\r\n TzToolBandObjectFactory = class(TzCustomBandObjectFactory)\r\n public\r\n procedure UpdateRegistry(Reg: Boolean); override;\r\n end;\r\n\r\n TzCatBandObjectFactory = class(TzCustomBandObjectFactory)\r\n protected\r\n function GetImplCatID: TGUID; virtual; abstract;\r\n public\r\n procedure UpdateRegistry(Reg: Boolean); override;\r\n end;\r\n\r\n TzDeskBandObjectFactory = class(TzCatBandObjectFactory)\r\n protected\r\n function GetImplCatID: TGUID; override;\r\n end;\r\n\r\n TzExplorerBarObjectFactory = class(TzCatBandObjectFactory)\r\n private\r\n function BarSize: string;\r\n protected\r\n function GetURL: string; virtual;\r\n function GetBarWidth: Word; virtual;\r\n function GetBarHeight: Word; virtual;\r\n public\r\n procedure UpdateRegistry(Reg: Boolean); override;\r\n end;\r\n\r\n TzInfoBandObjectFactory = class(TzExplorerBarObjectFactory)\r\n protected\r\n function GetImplCatID: TGUID; override;\r\n end;\r\n\r\n TzCommBandObjectFactory = class(TzExplorerBarObjectFactory)\r\n protected\r\n function GetImplCatID: TGUID; override;\r\n end;\r\n\r\n TzCustomBandObject = class(TComObject, IDeskBand, IObjectWithSite, IPersist, IPersistStream, IInputObject)\r\n private\r\n FBandForm: TJvBandForm;\r\n FBandID: DWORD;\r\n FViewMode: DWORD;\r\n FSite: IInputObjectSite;\r\n FOleCommandTarget: IOleCommandTarget;\r\n FSavedWndProc: TWndMethod;\r\n FHasFocus: Boolean;\r\n protected\r\n function CreateBandForm(const ParentWnd: THandle): TJvBandForm; virtual; abstract;\r\n procedure BandWndProc(var Msg: TMessage);\r\n procedure FocusChange(HasFocus: Boolean);\r\n public\r\n procedure AfterConstruction; override;\r\n procedure BeforeDestruction; override;\r\n function BandInfoChanged: HRESULT;\r\n function Maximize: HRESULT;\r\n function ShowAllBands: HRESULT;\r\n function HideAllBands: HRESULT;\r\n function ShowMeOnly: HRESULT;\r\n property BandID: DWORD read FBandID;\r\n property ViewMode: DWORD read FViewMode;\r\n property Site: IInputObjectSite read FSite;\r\n property OleCommandTarget: IOleCommandTarget read FOleCommandTarget;\r\n function GetBandInfo(BandID, ViewMode: DWORD;\r\n var Dbi: TDeskBandInfo): HRESULT; virtual; stdcall;\r\n function ShowDW(AShow: BOOL): HRESULT; virtual; stdcall;\r\n function CloseDW(dwReserved: DWORD): HRESULT; virtual; stdcall;\r\n function ResizeBorderDW(var Border: TRect;\r\n ToolbarSite: IUnknown; Reserved: BOOL): HRESULT; virtual; stdcall;\r\n\r\n // Note: this comes from IDeskBand but may not work under BCB, as it uses\r\n // the HWND type. See the compatibility guide for details.\r\n function GetWindow(out Wnd: HWND): HRESULT; virtual; stdcall;\r\n function ContextSensitiveHelp(EnterMode: BOOL): HRESULT; virtual; stdcall;\r\n function SetSite(const Site: IUnknown): HRESULT; virtual; stdcall;\r\n function GetSite(const Riid: TIID; out Site: IUnknown): HRESULT; virtual; stdcall;\r\n function IsDirty: HRESULT; virtual; stdcall;\r\n function Load(const Strm: IStream): HRESULT; virtual; stdcall;\r\n function Save(const Strm: IStream; ClearDirty: BOOL): HRESULT; virtual; stdcall;\r\n function GetSizeMax(out Size: Largeint): HRESULT; virtual; stdcall;\r\n function GetClassID(out ClassID: TCLSID): HRESULT; virtual; stdcall;\r\n function UIActivateIO(Activate: BOOL; var Msg: TMsg): HRESULT; virtual; stdcall;\r\n function HasFocusIO: HRESULT; virtual; stdcall;\r\n function TranslateAcceleratorIO(var Msg: TMsg): HRESULT; virtual; stdcall;\r\n end;\r\n\r\n TzToolBandObject = class(TzCustomBandObject)\r\n end;\r\n\r\n TzContextMenuBandObject = class(TzCustomBandObject, IContextMenu)\r\n public\r\n FMenuItemLink: TList;\r\n function QueryContextMenu(AMenu: HMENU;\r\n IndexMenu, idCmdFirst, idCmdLast, uFlags: UINT): HRESULT; virtual; stdcall;\r\n function InvokeCommand(var Ici: TCMInvokeCommandInfo): HRESULT; virtual; stdcall;\r\n {$IFDEF RTL230_UP}\r\n function GetCommandString(idCmd: UINT_PTR; uFlags: UINT; pwReserved: PUINT;\r\n pszName: LPSTR; cchMax: UINT): HRESULT; virtual; stdcall;\r\n {$ELSE ~RTL230_UP}\r\n function GetCommandString(idCmd, uType: UINT; pwReserved: PUINT;\r\n pszName: LPSTR; cchMax: UINT): HRESULT; virtual; stdcall;\r\n {$ENDIF ~RTL230_UP}\r\n end;\r\n\r\n TzDeskBandObject = class(TzContextMenuBandObject)\r\n end;\r\n\r\n TzInfoBandObject = class(TzContextMenuBandObject)\r\n end;\r\n\r\n TzCommBandObject = class(TzContextMenuBandObject)\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvBandObject.pas $';\r\n Revision: '$Revision: 13104 $';\r\n Date: '$Date: 2011-09-07 08:50:43 +0200 (mer. 07 sept. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n {$IFDEF DEBUGINFO_ON}\r\n //zTrace,\r\n {$ENDIF DEBUGINFO_ON}\r\n SysUtils, Registry, Math, Forms, Menus,\r\n JvConsts, JvJVCLUtils;\r\n\r\nconst\r\n cIERegistryBase = 'Software\\Microsoft\\Internet Explorer\\';\r\n cCLSID = 'CLSID\\';\r\n cBarSize = 'BarSize';\r\n cExplorerBars = 'Explorer Bars\\';\r\n cInstanceInitPropertyBagUrl = '\\Instance\\InitPropertyBag\\Url';\r\n cInstanceInitPropertyBag = '\\Instance\\InitPropertyBag';\r\n cInstanceCLSID = '\\Instance\\CLSID';\r\n cInstance = '\\Instance';\r\n\r\n{$IFDEF DEBUGINFO_ON}\r\n// (rom) debugging deactivated\r\nprocedure zTraceLog(const LogText: string);\r\nbegin\r\nend;\r\n{$ENDIF DEBUGINFO_ON}\r\n\r\nfunction MakeHResult(Sev, Fac, Code: LongWord): HRESULT;\r\nbegin\r\n Result := (Sev shl 31) or (Fac shl 16) or Code;\r\nend;\r\n\r\n//=== { TzCustomBandObjectFactory } ==========================================\r\n\r\nfunction TzCustomBandObjectFactory.GetClassIDString: string;\r\nbegin\r\n Result := GUIDToString(ClassID);\r\nend;\r\n\r\n//=== { TzToolBandObjectFactory } ============================================\r\n\r\nprocedure TzToolBandObjectFactory.UpdateRegistry(Reg: Boolean);\r\nvar\r\n ARegistry: TRegistry;\r\nbegin\r\n if Reg then\r\n inherited;\r\n ARegistry := TRegistry.Create;\r\n try\r\n ARegistry.RootKey := HKEY_LOCAL_MACHINE;\r\n if ARegistry.OpenKey(cIERegistryBase + 'Toolbar', True) then\r\n try\r\n if Reg then\r\n ARegistry.WriteString(ClassIDString, Description)\r\n else\r\n ARegistry.DeleteValue(ClassIDString);\r\n finally\r\n ARegistry.CloseKey;\r\n end;\r\n finally\r\n ARegistry.Free;\r\n end;\r\n if not Reg then\r\n inherited UpdateRegistry(Reg);\r\nend;\r\n\r\n//=== { TzCatBandObjectFactory } =============================================\r\n\r\nprocedure TzCatBandObjectFactory.UpdateRegistry(Reg: Boolean);\r\nvar\r\n CatRegister: ICatRegister;\r\n ImplCatID: TGUID;\r\nbegin\r\n if Reg then\r\n inherited;\r\n ImplCatID := GetImplCatID;\r\n CoInitialize(nil);\r\n CatRegister := ComObj.CreateComObject(CLSID_StdComponentCategoryMgr) as ICatRegister;\r\n if Reg then\r\n CatRegister.RegisterClassImplCategories(ClassID, 1, @ImplCatID)\r\n else\r\n begin\r\n CatRegister.UnregisterClassImplCategories(ClassID, 1, @ImplCatID);\r\n DeleteRegKey(cCLSID + ClassIDString + '\\Implemented Categories');\r\n end;\r\n CatRegister := nil;\r\n CoUninitialize;\r\n if not Reg then\r\n inherited UpdateRegistry(Reg);\r\nend;\r\n\r\n//=== { TzDeskBandObjectFactory } ============================================\r\n\r\nfunction TzDeskBandObjectFactory.GetImplCatID: TGUID;\r\nbegin\r\n Result := StringToGUID(CATID_DESKBAND);\r\nend;\r\n\r\n//=== { TzExplorerBarObjectFactory } =========================================\r\n\r\nfunction TzExplorerBarObjectFactory.BarSize: string;\r\nvar\r\n S: string;\r\nbegin\r\n S := Format('%.4x', [GetBarWidth]);\r\n Result := Copy(S, 3, 2) + ',' + Copy(S, 1, 2) + ',';\r\n S := Format('%.4x', [GetBarHeight]);\r\n Result := Result + Copy(S, 3, 2) + ',' + Copy(S, 1, 2) + ',00,00,00,00';\r\nend;\r\n\r\nfunction TzExplorerBarObjectFactory.GetBarHeight: Word;\r\nbegin\r\n Result := 0;\r\nend;\r\n\r\nfunction TzExplorerBarObjectFactory.GetBarWidth: Word;\r\nbegin\r\n Result := 0;\r\nend;\r\n\r\nfunction TzExplorerBarObjectFactory.GetURL: string;\r\nbegin\r\n Result := '';\r\nend;\r\n\r\nprocedure TzExplorerBarObjectFactory.UpdateRegistry(Reg: Boolean);\r\nvar\r\n ARegistry: TRegistry;\r\nbegin\r\n if Reg then\r\n begin\r\n inherited UpdateRegistry(Reg);\r\n if GetURL <> '' then\r\n begin\r\n CreateRegKey(cCLSID + ClassIDString + cInstanceCLSID, '', '{4D5C8C2A-D075-11D0-B416-00C04FB90376}');\r\n CreateRegKey(cCLSID + ClassIDString + cInstanceInitPropertyBagUrl, '', GetURL);\r\n end;\r\n if (GetBarWidth <> 0) or (GetBarHeight <> 0) then\r\n begin\r\n ARegistry := TRegistry.Create;\r\n try\r\n ARegistry.RootKey := HKEY_CURRENT_USER;\r\n if ARegistry.OpenKey(cIERegistryBase + cExplorerBars + ClassIDString, True) then\r\n try\r\n ARegistry.WriteString(cBarSize, BarSize)\r\n finally\r\n ARegistry.CloseKey;\r\n end;\r\n finally\r\n ARegistry.Free;\r\n end;\r\n end;\r\n end\r\n else\r\n begin\r\n ARegistry := TRegistry.Create;\r\n try\r\n ARegistry.RootKey := HKEY_CURRENT_USER;\r\n if ARegistry.OpenKey(cIERegistryBase + cExplorerBars + ClassIDString, True) then\r\n try\r\n ARegistry.DeleteValue(cBarSize);\r\n finally\r\n ARegistry.CloseKey;\r\n end;\r\n ARegistry.DeleteKey(cIERegistryBase + cExplorerBars + ClassIDString);\r\n finally\r\n ARegistry.Free;\r\n end;\r\n DeleteRegKey(cCLSID + ClassIDString + cInstanceInitPropertyBagUrl);\r\n DeleteRegKey(cCLSID + ClassIDString + cInstanceInitPropertyBag);\r\n DeleteRegKey(cCLSID + ClassIDString + cInstanceCLSID);\r\n DeleteRegKey(cCLSID + ClassIDString + cInstance);\r\n inherited UpdateRegistry(Reg);\r\n end;\r\nend;\r\n\r\n//=== { TzInfoBandObjectFactory } ============================================\r\n\r\nfunction TzInfoBandObjectFactory.GetImplCatID: TGUID;\r\nbegin\r\n Result := StringToGUID(CATID_INFOBAND);\r\nend;\r\n\r\n//=== { TzCommBandObjectFactory } ============================================\r\n\r\nfunction TzCommBandObjectFactory.GetImplCatID: TGUID;\r\nbegin\r\n Result := StringToGUID(CATID_COMMBAND);\r\nend;\r\n\r\n//=== { TzCustomBandObject } =================================================\r\n\r\nprocedure TzCustomBandObject.AfterConstruction;\r\nbegin\r\n {$IFDEF DEBUGINFO_ON}\r\n zTraceLog(ClassName + '.AfterConstruction()');\r\n {$ENDIF DEBUGINFO_ON}\r\n inherited AfterConstruction;\r\n FBandForm := nil;\r\n FSite := nil;\r\n FOleCommandTarget := nil;\r\nend;\r\n\r\nprocedure TzCustomBandObject.BeforeDestruction;\r\nbegin\r\n {$IFDEF DEBUGINFO_ON}\r\n zTraceLog(ClassName + '.BeforeDestruction()');\r\n {$ENDIF DEBUGINFO_ON}\r\n if Assigned(FSite) then\r\n FSite := nil; // implicit Release\r\n if Assigned(FOleCommandTarget) then\r\n FOleCommandTarget := nil; // implicit Release\r\n if Assigned(FBandForm) then\r\n FreeAndNil(FBandForm);\r\n {$IFDEF DEBUGINFO_ON}\r\n zTraceLog(ClassName + '.BeforeDestruction End()');\r\n {$ENDIF DEBUGINFO_ON}\r\n inherited BeforeDestruction;\r\nend;\r\n\r\nfunction TzCustomBandObject.BandInfoChanged: HRESULT;\r\nvar\r\n CGID_DeskBand: TGUID;\r\n vaIn, vaOut: OleVariant;\r\nbegin\r\n if not Assigned(OleCommandTarget) then\r\n begin\r\n Result := E_FAIL;\r\n Exit;\r\n end;\r\n CGID_DeskBand := IDeskBand;\r\n vaIn := OleVariant(BandID);\r\n Result := OleCommandTarget.Exec(@CGID_DeskBand, DBID_BANDINFOCHANGED,\r\n OLECMDEXECOPT_DODEFAULT, vaIn, vaOut);\r\nend;\r\n\r\nfunction TzCustomBandObject.Maximize: HRESULT;\r\nvar\r\n CGID_DeskBand: TGUID;\r\n vaIn, vaOut: OleVariant;\r\nbegin\r\n if not Assigned(OleCommandTarget) then\r\n begin\r\n Result := E_FAIL;\r\n Exit;\r\n end;\r\n CGID_DeskBand := IDeskBand;\r\n vaIn := OleVariant(BandID);\r\n Result := OleCommandTarget.Exec(@CGID_DeskBand, DBID_MAXIMIZEBAND,\r\n OLECMDEXECOPT_DODEFAULT, vaIn, vaOut);\r\nend;\r\n\r\nfunction TzCustomBandObject.HideAllBands: HRESULT;\r\nvar\r\n CGID_DeskBand: TGUID;\r\n vaIn, vaOut: OleVariant;\r\nbegin\r\n if not Assigned(OleCommandTarget) then\r\n begin\r\n Result := E_FAIL;\r\n Exit;\r\n end;\r\n CGID_DeskBand := IDeskBand;\r\n vaIn := 0;\r\n Result := OleCommandTarget.Exec(@CGID_DeskBand, DBID_SHOWONLY,\r\n OLECMDEXECOPT_DODEFAULT, vaIn, vaOut);\r\nend;\r\n\r\nfunction TzCustomBandObject.ShowAllBands: HRESULT;\r\nvar\r\n CGID_DeskBand: TGUID;\r\n vaIn, vaOut: OleVariant;\r\nbegin\r\n if not Assigned(OleCommandTarget) then\r\n begin\r\n Result := E_FAIL;\r\n Exit;\r\n end;\r\n CGID_DeskBand := IDeskBand;\r\n vaIn := 1;\r\n Result := OleCommandTarget.Exec(@CGID_DeskBand, DBID_SHOWONLY,\r\n OLECMDEXECOPT_DODEFAULT, vaIn, vaOut);\r\nend;\r\n\r\nfunction TzCustomBandObject.ShowMeOnly: HRESULT;\r\nvar\r\n CGID_DeskBand: TGUID;\r\n Unknown: IUnknown;\r\n vaIn, vaOut: OleVariant;\r\nbegin\r\n if not Assigned(OleCommandTarget) then\r\n begin\r\n Result := E_FAIL;\r\n Exit;\r\n end;\r\n CGID_DeskBand := IDeskBand;\r\n if Self.QueryInterface(IUnknown, Unknown) <> S_OK then\r\n begin\r\n Result := E_FAIL;\r\n Exit;\r\n end;\r\n try\r\n vaIn := Unknown;\r\n Result := OleCommandTarget.Exec(@CGID_DeskBand, DBID_SHOWONLY,\r\n OLECMDEXECOPT_DODEFAULT, vaIn, vaOut);\r\n finally\r\n Unknown := nil;\r\n end;\r\nend;\r\n\r\n// IDeskBand\r\n\r\nfunction TzCustomBandObject.GetBandInfo(BandID, ViewMode: DWORD;\r\n var Dbi: TDeskBandInfo): HRESULT;\r\nbegin\r\n {$IFDEF DEBUGINFO_ON}\r\n zTraceLog(ClassName + '.GetBandInfo()');\r\n zTraceLog(' BandID=' + Format('0x%x', [BandID]));\r\n zTraceLog(' ViewMode=' + Format('0x%x', [ViewMode]));\r\n zTraceLog(' Dbi=' + Format('0x%p', [@Dbi]));\r\n zTraceLog(' dwMask=' + Format('0x%x', [Dbi.dwMask]));\r\n {$ENDIF DEBUGINFO_ON}\r\n FBandID := BandID;\r\n FViewMode := ViewMode;\r\n if not Assigned(FBandForm) then\r\n begin\r\n Result := E_UNEXPECTED;\r\n Exit;\r\n end;\r\n\r\n if (Dbi.dwMask and DBIM_MINSIZE) <> 0 then\r\n begin\r\n Dbi.ptMinSize := FBandForm.BandMinSize;\r\n {$IFDEF DEBUGINFO_ON}\r\n zTraceLog(' Dbi.ptMinSize=' + Format('(%d,%d)', [Dbi.ptMinSize.x, Dbi.ptMinSize.y]));\r\n {$ENDIF DEBUGINFO_ON}\r\n end;\r\n if (Dbi.dwMask and DBIM_MAXSIZE) <> 0 then\r\n begin\r\n Dbi.ptMaxSize := FBandForm.BandMaxSize;\r\n {$IFDEF DEBUGINFO_ON}\r\n zTraceLog(' Dbi.ptMaxSize=' + Format('(%d,%d)', [Dbi.ptMaxSize.x, Dbi.ptMaxSize.y]));\r\n {$ENDIF DEBUGINFO_ON}\r\n end;\r\n if (Dbi.dwMask and DBIM_INTEGRAL) <> 0 then\r\n begin\r\n Dbi.ptIntegral := FBandForm.BandIntegral;\r\n {$IFDEF DEBUGINFO_ON}\r\n zTraceLog(' Dbi.ptIntegral=' + Format('(%d,%d)', [Dbi.ptIntegral.x, Dbi.ptIntegral.y]));\r\n {$ENDIF DEBUGINFO_ON}\r\n end;\r\n if (Dbi.dwMask and DBIM_ACTUAL) <> 0 then\r\n begin\r\n Dbi.ptActual := FBandForm.BandActualSize;\r\n {$IFDEF DEBUGINFO_ON}\r\n zTraceLog(' Dbi.ptActual=' + Format('(%d,%d)', [Dbi.ptActual.x, Dbi.ptActual.y]));\r\n {$ENDIF DEBUGINFO_ON}\r\n end;\r\n if (Dbi.dwMask and DBIM_TITLE) <> 0 then\r\n begin\r\n StringToWideChar(FBandForm.Caption, @Dbi.wszTitle[0], Length(Dbi.wszTitle));\r\n {$IFDEF DEBUGINFO_ON}\r\n zTraceLog(' Dbi.wszTitle=' + Format('%s', [FBandForm.Caption]));\r\n {$ENDIF DEBUGINFO_ON}\r\n end;\r\n if (Dbi.dwMask and DBIM_MODEFLAGS) <> 0 then\r\n begin\r\n Dbi.dwModeFlags := DBIMF_NORMAL;\r\n if bmfVariableHeight in FBandForm.BandModeFlags then\r\n Dbi.dwModeFlags := Dbi.dwModeFlags or DBIMF_VARIABLEHEIGHT;\r\n if bmfDebossed in FBandForm.BandModeFlags then\r\n Dbi.dwModeFlags := Dbi.dwModeFlags or DBIMF_DEBOSSED;\r\n if bmfBkColor in FBandForm.BandModeFlags then\r\n Dbi.dwModeFlags := Dbi.dwModeFlags or DBIMF_BKCOLOR;\r\n {$IFDEF DEBUGINFO_ON}\r\n zTraceLog(' Dbi.dwModeFlags=' + Format('0x%x', [Dbi.dwModeFlags]));\r\n {$ENDIF DEBUGINFO_ON}\r\n end;\r\n if (Dbi.dwMask and DBIM_BKCOLOR) <> 0 then\r\n begin\r\n Dbi.crBkgnd := FBandForm.Color;\r\n {$IFDEF DEBUGINFO_ON}\r\n zTraceLog(' Dbi.crBkgnd=' + Format('0x%x', [Dbi.crBkgnd]));\r\n {$ENDIF DEBUGINFO_ON}\r\n end;\r\n Result := NOERROR;\r\nend;\r\n\r\n// IDockingWindow\r\n\r\nfunction TzCustomBandObject.ShowDW(AShow: BOOL): HRESULT;\r\nbegin\r\n {$IFDEF DEBUGINFO_ON}\r\n zTraceLog(ClassName + '.ShowDW()');\r\n if AShow then\r\n zTraceLog(' Show=True')\r\n else\r\n zTraceLog(' Show=False');\r\n {$ENDIF DEBUGINFO_ON}\r\n Result := NOERROR;\r\n if not Assigned(FBandForm) then\r\n Exit;\r\n FHasFocus := AShow;\r\n if AShow then\r\n begin\r\n FBandForm.Show;\r\n FocusChange(AShow);\r\n end\r\n else\r\n FBandForm.Hide;\r\n {$IFDEF DEBUGINFO_ON}\r\n zTraceLog(ClassName + '.ShowDW() End');\r\n {$ENDIF DEBUGINFO_ON}\r\nend;\r\n\r\nfunction TzCustomBandObject.CloseDW(dwReserved: DWORD): HRESULT;\r\nbegin\r\n {$IFDEF DEBUGINFO_ON}\r\n zTraceLog(ClassName + '.CloseDW()');\r\n {$ENDIF DEBUGINFO_ON}\r\n Result := NOERROR;\r\n try\r\n try\r\n if not Assigned(FBandForm) then\r\n Exit;\r\n ShowDW(False);\r\n FBandForm.Free;\r\n finally\r\n FBandForm := nil;\r\n end;\r\n except\r\n end;\r\nend;\r\n\r\nfunction TzCustomBandObject.ResizeBorderDW(var Border: TRect;\r\n ToolbarSite: IUnknown; Reserved: BOOL): HRESULT;\r\nbegin\r\n {$IFDEF DEBUGINFO_ON}\r\n zTraceLog(ClassName + '.ResizeBorderDW()');\r\n {$ENDIF DEBUGINFO_ON}\r\n // Never called for band objects.\r\n Result := E_NOTIMPL;\r\nend;\r\n\r\n// IOleWindow\r\n\r\nfunction TzCustomBandObject.GetWindow(out Wnd: HWND): HRESULT;\r\nbegin\r\n {$IFDEF DEBUGINFO_ON}\r\n zTraceLog(ClassName + '.GetWindow()');\r\n {$ENDIF DEBUGINFO_ON}\r\n if Assigned(FBandForm) then\r\n Wnd := FBandForm.Handle\r\n else\r\n Wnd := 0;\r\n {$IFDEF DEBUGINFO_ON}\r\n zTraceLog(' Wnd=' + Format('0x%x', [Wnd]));\r\n {$ENDIF DEBUGINFO_ON}\r\n Result := S_OK;\r\nend;\r\n\r\nfunction TzCustomBandObject.ContextSensitiveHelp(EnterMode: BOOL): HRESULT;\r\nbegin\r\n {$IFDEF DEBUGINFO_ON}\r\n zTraceLog(ClassName + '.ContextSensitiveHelp()');\r\n {$ENDIF DEBUGINFO_ON}\r\n Result := E_NOTIMPL;\r\nend;\r\n\r\n// IObjectWithSite\r\n\r\nfunction TzCustomBandObject.SetSite(const Site: IUnknown): HRESULT;\r\nvar\r\n OleWindow: IOleWindow;\r\n ParentWnd: HWND;\r\nbegin\r\n {$IFDEF DEBUGINFO_ON}\r\n zTraceLog(ClassName + '.SetSite()');\r\n if Assigned(Site) then\r\n zTraceLog(' Site=not nil')\r\n else\r\n zTraceLog(' Site=nil');\r\n {$ENDIF DEBUGINFO_ON}\r\n if Assigned(FSite) then\r\n FSite := nil; // implicit Release\r\n if Assigned(FOleCommandTarget) then\r\n FOleCommandTarget := nil; // implicit Release\r\n if Assigned(Site) then\r\n begin\r\n if not Assigned(FBandForm) then\r\n begin\r\n if Site.QueryInterface(IOleWindow, OleWindow) <> S_OK then\r\n begin\r\n Result := E_FAIL;\r\n Exit;\r\n end;\r\n try\r\n OleWindow.GetWindow(ParentWnd);\r\n finally\r\n OleWindow := nil;\r\n end;\r\n {$IFDEF DEBUGINFO_ON}\r\n zTraceLog(' ParentWnd=' + Format('0x%x', [ParentWnd]));\r\n {$ENDIF DEBUGINFO_ON}\r\n if ParentWnd = 0 then\r\n begin\r\n Result := E_FAIL;\r\n Exit;\r\n end;\r\n FBandForm := CreateBandForm(ParentWnd);\r\n\r\n FSavedWndProc := FBandForm.WindowProc;\r\n FBandForm.WindowProc := BandWndProc;\r\n end;\r\n if Site.QueryInterface(IInputObjectSite, FSite) <> S_OK then // implicit FSite.AddRef;\r\n begin\r\n Result := E_FAIL;\r\n Exit;\r\n end;\r\n {$IFDEF DEBUGINFO_ON}\r\n zTraceLog(' FSite assigned.');\r\n {$ENDIF DEBUGINFO_ON}\r\n if FSite.QueryInterface(IOleCommandTarget, FOleCommandTarget) <> S_OK then\r\n FOleCommandTarget := nil;\r\n end;\r\n Result := S_OK;\r\nend;\r\n\r\nfunction TzCustomBandObject.GetSite(const Riid: TIID;\r\n out Site: IUnknown): HRESULT;\r\nbegin\r\n {$IFDEF DEBUGINFO_ON}\r\n zTraceLog(ClassName + '.GetSite()');\r\n zTraceLog(' Riid=' + GUIDToString(Riid));\r\n {$ENDIF DEBUGINFO_ON}\r\n if not Assigned(FSite) then\r\n begin\r\n Site := nil;\r\n Result := E_FAIL;\r\n Exit;\r\n end;\r\n Result := FSite.QueryInterface(Riid, Site);\r\n {$IFDEF DEBUGINFO_ON}\r\n zTraceLog(' Result=' + IntToStr(Result));\r\n {$ENDIF DEBUGINFO_ON}\r\nend;\r\n\r\n// IPersistStream\r\n\r\nfunction TzCustomBandObject.IsDirty: HRESULT;\r\nbegin\r\n {$IFDEF DEBUGINFO_ON}\r\n zTraceLog(ClassName + '.IsDirty()');\r\n {$ENDIF DEBUGINFO_ON}\r\n Result := S_FALSE;\r\nend;\r\n\r\nfunction TzCustomBandObject.Load(const Strm: IStream): HRESULT;\r\nbegin\r\n {$IFDEF DEBUGINFO_ON}\r\n zTraceLog(ClassName + '.Load()');\r\n {$ENDIF DEBUGINFO_ON}\r\n Result := S_OK;\r\nend;\r\n\r\nfunction TzCustomBandObject.Save(const Strm: IStream; ClearDirty: BOOL): HRESULT;\r\nbegin\r\n {$IFDEF DEBUGINFO_ON}\r\n zTraceLog(ClassName + '.Save()');\r\n {$ENDIF DEBUGINFO_ON}\r\n Result := S_OK;\r\nend;\r\n\r\nfunction TzCustomBandObject.GetSizeMax(out Size: Largeint): HRESULT;\r\nbegin\r\n {$IFDEF DEBUGINFO_ON}\r\n zTraceLog(ClassName + '.GetSizeMax()');\r\n {$ENDIF DEBUGINFO_ON}\r\n Size := 0;\r\n Result := S_OK;\r\nend;\r\n\r\n// IPersist\r\n\r\nfunction TzCustomBandObject.GetClassID(out ClassID: TCLSID): HRESULT;\r\nbegin\r\n {$IFDEF DEBUGINFO_ON}\r\n zTraceLog(ClassName + '.GetClassID()');\r\n {$ENDIF DEBUGINFO_ON}\r\n ClassID := Factory.ClassID;\r\n {$IFDEF DEBUGINFO_ON}\r\n zTraceLog(' ClassID=' + GUIDToString(ClassID));\r\n {$ENDIF DEBUGINFO_ON}\r\n Result := S_OK;\r\nend;\r\n\r\n// IInputObject\r\n\r\nfunction TzCustomBandObject.UIActivateIO(Activate: BOOL;\r\n var Msg: TMsg): HRESULT;\r\nbegin\r\n {$IFDEF DEBUGINFO_ON}\r\n zTraceLog(ClassName + '.UIActivateIO()');\r\n if Activate then\r\n zTraceLog(' Activate=True')\r\n else\r\n zTraceLog(' Activate=False');\r\n {$ENDIF DEBUGINFO_ON}\r\n Result := S_OK;\r\n FHasFocus := Activate;\r\n if not Assigned(FBandForm) then\r\n Exit;\r\n if Activate then\r\n FBandForm.SetFocus;\r\nend;\r\n\r\nfunction TzCustomBandObject.HasFocusIO: HRESULT;\r\nbegin\r\n {$IFDEF DEBUGINFO_ON}\r\n zTraceLog(ClassName + '.HasFocusIO()');\r\n {$ENDIF DEBUGINFO_ON}\r\n Result := Ord(not FHasFocus);\r\n// Result := iif(Assigned(FBandForm) and FBandForm.Focused,\r\n// S_OK, S_FALSE);\r\n {$IFDEF DEBUGINFO_ON}\r\n zTraceLog(' Result=' + IntToStr(Result));\r\n {$ENDIF DEBUGINFO_ON}\r\nend;\r\n\r\nfunction TzCustomBandObject.TranslateAcceleratorIO(var Msg: TMsg): HRESULT;\r\nbegin\r\n {$IFDEF DEBUGINFO_ON}\r\n zTraceLog(ClassName + '.TranslateAcceleratorIO()');\r\n {$ENDIF DEBUGINFO_ON}\r\n Result := S_FALSE;\r\nend;\r\n\r\nprocedure TzCustomBandObject.BandWndProc(var Msg: TMessage);\r\nbegin\r\n if Msg.Msg = WM_PARENTNOTIFY then\r\n begin\r\n FHasFocus := True;\r\n FocusChange(True);\r\n end;\r\n //if (Msg.Msg >= WM_KEYFIRST) and (Msg.Msg <= WM_KEYLAST) then\r\n // SendMessage(FBandForm.Handle, Msg.Msg, Msg.wParam, Msg.lParam);\r\n FSavedWndProc(Msg);\r\nend;\r\n\r\nprocedure TzCustomBandObject.FocusChange(HasFocus: Boolean);\r\nvar\r\n Obj: IUnknown;\r\nbegin\r\n if Site <> nil then\r\n begin\r\n if Supports(FBandForm, IUnknown, Obj) then\r\n Site.OnFocusChangeIS(Obj, HasFocus);\r\n end;\r\nend;\r\n\r\n//=== { TzContextMenuBandObject } ============================================\r\n\r\n// IContextMenu\r\n\r\nfunction GetContextMenuCaption(const MenuItem: TMenuItem): string;\r\nbegin\r\n Result := MenuItem.Caption;\r\n if MenuItem.Count > 0 then\r\n Exit;\r\n if (MenuItem.ShortCut <> scNone) and\r\n ((MenuItem.Parent = nil) or (MenuItem.Parent.Parent <> nil) or not (MenuItem.Parent.Owner is TMainMenu)) then\r\n Result := Result + Tab + ShortCutToText(MenuItem.ShortCut);\r\nend;\r\n\r\n(* make Delphi 5 compiler happy // andreas\r\nfunction AddContextMenuItem(const MenuItem: TMenuItem; const AMenu: HMENU;\r\n const idCmdFirst: UINT; ARightToLeft: Boolean; out idCMD : uInt): Boolean;\r\nconst\r\n RightToLeftMenuFlag = MFT_RIGHTORDER or MFT_RIGHTJUSTIFY;\r\n IBreaks: array [TMenuBreak] of DWORD = (MFT_STRING, MFT_MENUBREAK, MFT_MENUBARBREAK);\r\n IChecks: array [Boolean] of DWORD = (MFS_UNCHECKED, MFS_CHECKED);\r\n IDefaults: array [Boolean] of DWORD = (0, MFS_DEFAULT);\r\n IEnables: array [Boolean] of DWORD = (MFS_DISABLED or MFS_GRAYED, MFS_ENABLED);\r\n IRadios: array [Boolean] of DWORD = (MFT_STRING, MFT_RADIOCHECK);\r\n ISeparators: array [Boolean] of DWORD = (MFT_STRING, MFT_SEPARATOR);\r\n IRTL: array [Boolean] of DWORD = (0, RightToLeftMenuFlag);\r\n IOwnerDraw: array [Boolean] of DWORD = (MFT_STRING, MFT_OWNERDRAW);\r\nvar\r\n MenuItemInfo: TMenuItemInfo;\r\n IsOwnerDraw: Boolean;\r\n ParentMenu: TMenu;\r\n Count: Integer;\r\nbegin\r\n Result := False;\r\n if not MenuItem.Visible then\r\n Exit;\r\n MenuItemInfo.cbSize := SizeOf(TMenuItemInfo);\r\n MenuItemInfo.fMask := MIIM_CHECKMARKS or MIIM_DATA or MIIM_ID or\r\n MIIM_STATE or MIIM_SUBMENU or MIIM_TYPE;\r\n ParentMenu := MenuItem.GetParentMenu;\r\n IsOwnerDraw := Assigned(ParentMenu) and\r\n (ParentMenu.OwnerDraw or (MenuItem.GetImageList <> nil)) or\r\n Assigned(MenuItem.Bitmap) and not MenuItem.Bitmap.Empty;\r\n MenuItemInfo.fType := IRadios[MenuItem.RadioItem] or\r\n IBreaks[MenuItem.Break] or\r\n ISeparators[MenuItem.Caption = cLineCaption] or\r\n IRTL[ARightToLeft] or\r\n IOwnerDraw[IsOwnerDraw];\r\n MenuItemInfo.fState := IChecks[MenuItem.Checked] or\r\n IEnables[MenuItem.Enabled] or\r\n IDefaults[MenuItem.Default];\r\n MenuItemInfo.wID := MenuItem.Command + idCmdFirst;\r\n MenuItemInfo.hbmpChecked := 0;\r\n MenuItemInfo.hbmpUnchecked := 0;\r\n MenuItemInfo.dwTypeData := PChar(GetContextMenuCaption(MenuItem));\r\n if MenuItem.Count > 0 then\r\n MenuItemInfo.hSubMenu := MenuItem.Handle\r\n else\r\n begin\r\n MenuItemInfo.fMask := MenuItemInfo.fMask or MIIM_SUBMENU;\r\n MenuItemInfo.hSubMenu := CreateMenu;\r\n for Count := 0 to MenuItem.Count do\r\n if AddContextMenuItem(MenuItem[Count], MenuItemInfo.hSubMenu, idCmdFirst, ARightToLeft,idCMD) then\r\n idCmd := Max(idCmd, MenuItem[Count].Command);\r\n end;\r\n Result := InsertMenuItem(AMenu, DWORD(-1), True, MenuItemInfo);\r\n {$IFDEF DEBUGINFO_ON}\r\n if not Result then\r\n Exit;\r\n zTraceLog(' Menu item added, MenuItem.Command=' + IntToStr(MenuItem.Command));\r\n zTraceLog(' Count=' + IntToStr(MenuItem.Count));\r\n zTraceLog(' Handle=' + Format('0x%x', [MenuItemInfo.hSubMenu]));\r\n {$ENDIF DEBUGINFO_ON}\r\nend;\r\n*)\r\n\r\nfunction TzContextMenuBandObject.QueryContextMenu(AMenu: HMENU; IndexMenu,\r\n idCmdFirst, idCmdLast, uFlags: UINT): HRESULT;\r\n//var\r\n// idCmd: UINT;\r\n\r\n procedure SetItemParams(var ItemInfo: TMenuItemInfo; var MenuItem: TMenuItem);\r\n begin\r\n ItemInfo.fState := 0;\r\n if MenuItem.Checked then\r\n ItemInfo.fState := ItemInfo.fState or MFS_CHECKED\r\n else\r\n ItemInfo.fState := ItemInfo.fState or MFS_UNCHECKED;\r\n\r\n if MenuItem.Default then\r\n ItemInfo.fState := ItemInfo.fState or MFS_DEFAULT;\r\n if MenuItem.Enabled then\r\n ItemInfo.fState := ItemInfo.fState or MFS_ENABLED\r\n else\r\n ItemInfo.fState := ItemInfo.fState or MFS_DISABLED;\r\n\r\n ItemInfo.fType := 0;\r\n if MenuItem.Caption = '-' then\r\n ItemInfo.fType := ItemInfo.fType or MFT_SEPARATOR\r\n else\r\n begin\r\n ItemInfo.fType := ItemInfo.fType or MFT_STRING;\r\n ItemInfo.dwTypeData := PChar(MenuItem.Caption);\r\n ItemInfo.cch := Length(MenuItem.Caption);\r\n end;\r\n if MenuItem.RadioItem then\r\n ItemInfo.fType := ItemInfo.fType or MFT_RADIOCHECK;\r\n end;\r\n\r\n procedure InsertContextMenuItems(ThisMenu: HMENU; Items: PMenuItem; InsertIndex: Integer);\r\n var\r\n I: Integer;\r\n ItemInfo: TMenuItemInfo;\r\n TempItem: TMenuItem;\r\n begin\r\n for I := 0 to Items.Count - 1 do\r\n begin\r\n TempItem := Items^[I];\r\n if not TempItem.Visible then\r\n Continue;\r\n ItemInfo.cbSize := SizeOf(ItemInfo);\r\n ItemInfo.fMask := MIIM_DATA or MIIM_ID or MIIM_STATE or MIIM_TYPE;\r\n SetItemParams(ItemInfo, TempItem);\r\n ItemInfo.wID := idCmdFirst + Cardinal(FMenuItemLink.Count);\r\n if Items^[I].Count > 0 then\r\n begin\r\n ItemInfo.fMask := ItemInfo.fMask or MIIM_SUBMENU;\r\n ItemInfo.hSubMenu := CreateMenu;\r\n InsertContextMenuItems(ItemInfo.hSubMenu, @TempItem, 0);\r\n end;\r\n InsertMenuItem(ThisMenu, InsertIndex, True, ItemInfo);\r\n FMenuItemLink.Add(Pointer(Items^[I].ComponentIndex));\r\n InsertIndex := InsertIndex+1;\r\n end;\r\n end;\r\n\r\nbegin\r\n {$IFDEF DEBUGINFO_ON}\r\n zTraceLog(ClassName + '.QueryContextMenu()');\r\n zTraceLog(' IndexMenu: ' + IntToStr(IndexMenu));\r\n zTraceLog(' idCmdFirst: ' + IntToStr(idCmdFirst));\r\n zTraceLog(' idCmdLast: ' + IntToStr(idCmdLast));\r\n zTraceLog(' uFlags: ' + Format('0x%x', [uFlags]));\r\n {$ENDIF DEBUGINFO_ON}\r\n\r\n if not Assigned(FMenuItemLink) then\r\n FMenuItemLink := TList.Create;\r\n FMenuItemLink.Clear;\r\n if (CMF_DEFAULTONLY and uFlags) <> 0 then\r\n begin\r\n Result := MakeHResult(SEVERITY_SUCCESS, 0, 0);\r\n Exit;\r\n end;\r\n Result := MakeHResult(SEVERITY_SUCCESS, 0, 1);\r\n if not Assigned(FBandForm) then\r\n Exit;\r\n if not Assigned(FBandForm.BandContextMenu) then\r\n Exit;\r\n //idCmd := idCmdFirst;\r\n InsertContextMenuItems(AMenu, @FBandForm.BandContextMenu.Items, IndexMenu);\r\n Result := MakeResult(SEVERITY_SUCCESS, FACILITY_NULL, FMenuItemLink.Count);\r\nend;\r\n\r\nprocedure FindItem(Item: TMenuItem; SeekIndex: Integer; var CurrentIndex: Integer);\r\nvar\r\n Count: Integer;\r\nbegin\r\n if Item.Count > 0 then\r\n for Count := 0 to Item.Count-1 do\r\n begin\r\n if Item[Count].Count > 0 then\r\n FindItem(Item[Count], SeekIndex, CurrentIndex);\r\n\r\n if CurrentIndex = SeekIndex then\r\n Item[Count].Click;\r\n Inc(CurrentIndex);\r\n end;\r\nend;\r\n\r\nfunction TzContextMenuBandObject.InvokeCommand(var Ici: TCMInvokeCommandInfo): HRESULT;\r\nvar\r\n idCmd: UINT;\r\n ci: Integer;\r\nbegin\r\n {$IFDEF DEBUGINFO_ON}\r\n zTraceLog(ClassName + '.InvokeCommand()');\r\n {$ENDIF DEBUGINFO_ON}\r\n idCmd := LoWord(Ici.lpVerb);\r\n {$IFDEF DEBUGINFO_ON}\r\n zTraceLog(' idCmd=' + IntToStr(idCmd));\r\n {$ENDIF DEBUGINFO_ON}\r\n Result := E_INVALIDARG;\r\n if not Assigned(FBandForm) then\r\n Exit;\r\n if not Assigned(FBandForm.BandContextMenu) then\r\n Exit;\r\n FindItem(FBandForm.BandContextMenu.Items, idCmd, ci);\r\n //if BandContextMenu.DispatchCommand(idCmd) then\r\n // Result := NOERROR;\r\nend;\r\n\r\n{$IFDEF RTL230_UP}\r\nfunction TzContextMenuBandObject.GetCommandString(idCmd: UINT_PTR; uFlags: UINT;\r\n pwReserved: PUINT; pszName: LPSTR; cchMax: UINT): HRESULT;\r\n{$ELSE ~RTL230_UP}\r\nfunction TzContextMenuBandObject.GetCommandString(idCmd, uType: UINT;\r\n pwReserved: PUINT; pszName: LPSTR; cchMax: UINT): HRESULT;\r\n{$ENDIF ~RTL230_UP}\r\nvar\r\n MenuItem: TMenuItem;\r\nbegin\r\n {$IFDEF DEBUGINFO_ON}\r\n zTraceLog(ClassName + '.GetCommandString()');\r\n zTraceLog(' idCmd=' + IntToStr(idCmd));\r\n {$IFDEF RTL230_UP}\r\n zTraceLog(' uFlags=' + Format('0x%x', [uFlags]));\r\n {$ELSE ~RTL230_UP}\r\n zTraceLog(' uType=' + Format('0x%x', [uType]));\r\n {$ENDIF ~RTL230_UP}\r\n {$ENDIF DEBUGINFO_ON}\r\n Result := E_INVALIDARG;\r\n if not Assigned(FBandForm) then\r\n Exit;\r\n if not Assigned(FBandForm.BandContextMenu) then\r\n Exit;\r\n case {$IFDEF RTL230_UP}uFlags{$ELSE ~RTL230_UP}uType{$ENDIF ~RTL230_UP} of\r\n GCS_HELPTEXT:\r\n begin\r\n MenuItem := FBandForm.BandContextMenu.FindItem(idCmd, fkCommand);\r\n if MenuItem = nil then\r\n Exit;\r\n StrCopy(pszName, PAnsiChar(AnsiString(MenuItem.Hint))); // text lost here, unicode version should be considered\r\n end;\r\n GCS_VERB:\r\n begin\r\n MenuItem := FBandForm.BandContextMenu.FindItem(idCmd, fkCommand);\r\n if MenuItem = nil then\r\n Exit;\r\n StrCopy(pszName, PAnsiChar(AnsiString(GetContextMenuCaption(MenuItem)))); // text lost here, unicode version should be considered\r\n end;\r\n GCS_VALIDATE:\r\n Result := NOERROR;\r\n end;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n\r\n" }, { "path": "External/Jedi/Jvcl/run/JvBaseDBDialog.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvBaseDBLogonDialog.pas, released on 2006-07-21\r\n\r\nThe Initial Developer of the Original Code is Jens Fudickar\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvBaseDBDialog.pas 13413 2012-09-08 11:02:21Z ahuser $\r\n\r\nunit JvBaseDBDialog;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n{$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n{$ENDIF UNITVERSIONING}\r\n JvDynControlEngine,\r\n Windows, Classes, JvBaseDlg, JvAppStorage, Forms, Controls;\r\n\r\ntype\r\n TJvBaseDBDialog = class(TJvCommonDialog)\r\n private\r\n FAppStorage: TJvCustomAppStorage;\r\n FAppStoragePath: string;\r\n FDBDialog: TForm;\r\n FDynControlEngine: TJvDynControlEngine;\r\n FSession: TComponent;\r\n FParentWnd: HWND;\r\n function GetDynControlEngine: TJvDynControlEngine;\r\n protected\r\n function CreateForm: TForm; virtual;\r\n procedure CreateFormControls(aForm: TForm); virtual;\r\n procedure AfterCreateFormControls(aForm: TForm); virtual;\r\n procedure Notification(AComponent: TComponent; Operation: TOperation); override;\r\n procedure SetAppStorage(Value: TJvCustomAppStorage); virtual;\r\n procedure SetAppStoragePath(Value: string); virtual;\r\n procedure SetSession(const Value: TComponent); virtual;\r\n property AppStorage: TJvCustomAppStorage read FAppStorage write SetAppStorage;\r\n property AppStoragePath: string read FAppStoragePath write SetAppStoragePath;\r\n public\r\n function Execute(ParentWnd: HWND): Boolean; overload; override;\r\n function SessionIsConnected: Boolean; virtual;\r\n property DBDialog: TForm read FDBDialog ;\r\n property Session: TComponent read FSession write SetSession;\r\n published\r\n property DynControlEngine: TJvDynControlEngine read GetDynControlEngine write FDynControlEngine;\r\n end;\r\n\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvBaseDBDialog.pas $';\r\n Revision: '$Revision: 13413 $';\r\n Date: '$Date: 2012-09-08 13:02:21 +0200 (sam. 08 sept. 2012) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n SysUtils, Types,\r\n JvJCLUtils, // SetWindowLongPtr for older Delphi versions\r\n JvJVCLUtils;\r\n\r\nfunction TJvBaseDBDialog.CreateForm: TForm;\r\nbegin\r\n Result := TForm(DynControlEngine.CreateForm('', ''));\r\n CreateFormControls(Result);\r\n if FParentWnd <> 0 then\r\n SetWindowLongPtr(Result.Handle, GWL_HWNDPARENT, LONG_PTR(FParentWnd));\r\nend;\r\n\r\nprocedure TJvBaseDBDialog.CreateFormControls(aForm: TForm);\r\nbegin\r\nend;\r\n\r\nprocedure TJvBaseDBDialog.AfterCreateFormControls(aForm: TForm);\r\nbegin\r\nend;\r\n\r\nfunction TJvBaseDBDialog.Execute(ParentWnd: HWND): Boolean;\r\nbegin\r\n if not Assigned(Session) then\r\n Abort;\r\n FParentWnd := ParentWnd;\r\n FDBDialog := CreateForm;\r\n try\r\n AfterCreateFormControls(FDBDialog);\r\n FDBDialog.ShowModal;\r\n Result := FDBDialog.ModalResult = mrOk;\r\n finally\r\n FreeAndNil(FDBDialog);\r\n end;\r\nend;\r\n\r\nfunction TJvBaseDBDialog.GetDynControlEngine: TJvDynControlEngine;\r\nbegin\r\n if Assigned(FDynControlEngine) then\r\n Result := FDynControlEngine\r\n else\r\n Result := DefaultDynControlEngine;\r\nend;\r\n\r\nprocedure TJvBaseDBDialog.Notification(AComponent: TComponent; Operation:\r\n TOperation);\r\nbegin\r\n inherited Notification(AComponent, Operation);\r\n if (Operation = opRemove) then\r\n if (AComponent = FAppStorage) then\r\n FAppStorage := nil\r\n else if (AComponent = FSession) then\r\n FSession := nil\r\n else if (AComponent = FDBDialog) then\r\n FDBDialog := nil;\r\nend;\r\n\r\nfunction TJvBaseDBDialog.SessionIsConnected: Boolean;\r\nbegin\r\n Result := False;\r\nend;\r\n\r\nprocedure TJvBaseDBDialog.SetAppStorage(Value: TJvCustomAppStorage);\r\nbegin\r\n ReplaceComponentReference(Self, Value, TComponent(FAppStorage));\r\nend;\r\n\r\nprocedure TJvBaseDBDialog.SetAppStoragePath(Value: string);\r\nbegin\r\n if Value <> AppStoragePath then\r\n FAppStoragePath := Value;\r\nend;\r\n\r\nprocedure TJvBaseDBDialog.SetSession(const Value: TComponent);\r\nbegin\r\n ReplaceComponentReference(Self, Value, FSession);\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvBaseDBLogonDialog.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvBaseDBLogonDialog.pas, released on 2006-07-21\r\n\r\nThe Initial Developer of the Original Code is Jens Fudickar\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvBaseDBLogonDialog.pas 13406 2012-08-24 20:05:23Z jfudickar $\r\n\r\nunit JvBaseDBLogonDialog;\r\n\r\n{$I jvcl.inc}\r\n{$DEFINE CODESITE}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Classes, Forms, Controls, Menus,\r\n JvAppStorage, JvDynControlEngine, JvDynControlEngineIntf,\r\n JvPropertyStore, JvBaseDBDialog, JvBaseDBPasswordDialog, Graphics;\r\n\r\ntype\r\n TJvLogonDialogFillListEvent = procedure(List: TStringList) of object;\r\n TJvLogonDialogEncryptDecryptEvent = procedure(var Password: string) of object;\r\n TJvLogonDialogBaseSessionEvent = function(Session: TComponent): Boolean of object;\r\n\r\n TJvDBLogonDialogActivePage = (ldapConnectList, ldapUserTree, ldapDatabaseTree, ldapGroupTree);\r\n\r\n TJvBaseDBLogonDialogOptions = class(TPersistent)\r\n private\r\n FAddConnectionValuesToComboBox: Boolean;\r\n FAllowNullPasswords: Boolean;\r\n FAllowPasswordChange: Boolean;\r\n FDatabasenameCaseSensitive: Boolean;\r\n FPasswordChar: char;\r\n FPasswordDialogOptions: TJvBaseDBPasswordDialogOptions;\r\n FUsernameCaseSensitive: Boolean;\r\n FSaveLastConnect: Boolean;\r\n FSavePasswords: Boolean;\r\n FSetLastConnectToTop: Boolean;\r\n FShowAlias: Boolean;\r\n FShowColors: Boolean;\r\n FShowConnectGroup: Boolean;\r\n FShowConnectionsExport: Boolean;\r\n FShowSavePasswords: Boolean;\r\n FShowShortcuts: Boolean;\r\n public\r\n constructor Create; virtual;\r\n destructor Destroy; override;\r\n property AllowPasswordChange: Boolean read FAllowPasswordChange write FAllowPasswordChange;\r\n property PasswordDialogOptions: TJvBaseDBPasswordDialogOptions read FPasswordDialogOptions;\r\n published\r\n //1 Add each of the values from the connection list to the different comboboxes\r\n property AddConnectionValuesToComboBox: Boolean read FAddConnectionValuesToComboBox write\r\n FAddConnectionValuesToComboBox default true;\r\n property AllowNullPasswords: Boolean read FAllowNullPasswords write FAllowNullPasswords default False;\r\n //1 Group the Databasename casesensitive in the Databasename tree list\r\n property DatabasenameCaseSensitive: Boolean read FDatabasenameCaseSensitive write FDatabasenameCaseSensitive default\r\n False;\r\n property PasswordChar: char read FPasswordChar write FPasswordChar default '*';\r\n //1 Group the username casesensitive in the username tree list\r\n property UsernameCaseSensitive: Boolean read FUsernameCaseSensitive write FUsernameCaseSensitive default False;\r\n property SaveLastConnect: Boolean read FSaveLastConnect write FSaveLastConnect default True;\r\n property SavePasswords: Boolean read FSavePasswords write FSavePasswords default True;\r\n property SetLastConnectToTop: Boolean read FSetLastConnectToTop write FSetLastConnectToTop default True;\r\n property ShowAlias: Boolean read FShowAlias write FShowAlias default False;\r\n property ShowColors: Boolean read FShowColors write FShowColors default False;\r\n property ShowConnectGroup: Boolean read FShowConnectGroup write FShowConnectGroup default True;\r\n property ShowConnectionsExport: Boolean read FShowConnectionsExport write FShowConnectionsExport default True;\r\n property ShowSavePasswords: Boolean read FShowSavePasswords write FShowSavePasswords default False;\r\n property ShowShortcuts: Boolean read FShowShortcuts write FShowShortcuts default True;\r\n end;\r\n\r\n TJvBaseDBOracleLogonDialogOptions = class(TJvBaseDBLogonDialogOptions)\r\n private\r\n FShowConnectAs: Boolean;\r\n public\r\n constructor Create; override;\r\n published\r\n property ShowConnectAs: Boolean read FShowConnectAs write FShowConnectAs default True;\r\n end;\r\n\r\n TJvBaseDBLogonDialogOptionsClass = class of TJvBaseDBLogonDialogOptions;\r\n\r\n TJvBaseConnectionInfo = class(TJvCustomPropertyStore)\r\n private\r\n FAlias: String;\r\n FColor: TColor;\r\n FDatabase: string;\r\n FGroup: string;\r\n FPassword: string;\r\n FSavePassword: Boolean;\r\n FShortCut: Integer;\r\n FUsername: string;\r\n function GetShortCutText: string;\r\n procedure SetGroup(const Value: string);\r\n procedure SetSavePassword(const Value: Boolean);\r\n procedure SetShortCutText(const Value: string);\r\n protected\r\n function GetDatabaseEnabled: Boolean; virtual;\r\n function GetAliasEnabled: Boolean; virtual;\r\n function GetUsernameEnabled: Boolean; virtual;\r\n function GetPasswordEnabled: Boolean; virtual;\r\n //1 This function is to identify the connection info in the connection list\r\n function SearchName: String; virtual;\r\n procedure SetDatabase(Value: string);\r\n procedure SetUsername(Value: string);\r\n function TranslateUserName(iName: string): string; virtual;\r\n function TranslateDatabaseName(iName: string): string; virtual;\r\n function UseTranslateUserName: Boolean; virtual;\r\n function UseTranslateDatabaseName: Boolean; virtual;\r\n property DatabaseEnabled: Boolean read GetDatabaseEnabled;\r\n property AliasEnabled: Boolean read GetAliasEnabled;\r\n property UsernameEnabled: Boolean read GetUsernameEnabled;\r\n property PasswordEnabled: Boolean read GetPasswordEnabled;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n function IsConnectAllowed(AllowNullPasswords: Boolean): Boolean; virtual;\r\n function ConnectString: string; virtual;\r\n function DatabaseGroupIdentifier: string; virtual;\r\n property SavePassword: Boolean read FSavePassword write SetSavePassword;\r\n property ShortCut: Integer read FShortCut write FShortCut;\r\n published\r\n property Alias: String read FAlias write FAlias;\r\n property Color: TColor read FColor write FColor;\r\n property Database: string read FDatabase write SetDatabase;\r\n property Group: string read FGroup write SetGroup;\r\n property Password: string read FPassword write FPassword;\r\n property ShortCutText: string read GetShortCutText write SetShortCutText;\r\n property Username: string read FUsername write SetUsername;\r\n end;\r\n\r\n TJvBaseOracleConnectionInfo = class(TJvBaseConnectionInfo)\r\n private\r\n FConnectAs: string;\r\n procedure SetConnectAs(const Value: string);\r\n protected\r\n function GetConnectAsEnabled: Boolean; virtual;\r\n property ConnectAsEnabled: Boolean read GetConnectAsEnabled;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n function ConnectString: string; override;\r\n published\r\n property ConnectAs: string read FConnectAs write SetConnectAs;\r\n end;\r\n\r\n TJvLogonDialogConnectionInfoEvent = procedure(ConnectionInfo: TJvBaseConnectionInfo) of object;\r\n\r\n TJvBaseConnectionListClass = class of TJvBaseConnectionList;\r\n\r\n TJvBaseConnectionList = class(TJvCustomPropertyListStore)\r\n private\r\n FActivePage: TJvDBLogonDialogActivePage;\r\n FGroupByDatabase: Boolean;\r\n FGroupByUser: Boolean;\r\n FLastConnect: TJvBaseConnectionInfo;\r\n FSavePasswords: Boolean;\r\n procedure SetLastConnect(const Value: TJvBaseConnectionInfo);\r\n procedure SetSavePasswords(const Value: Boolean);\r\n protected\r\n procedure CopyContents(iConnectionList: TJvBaseConnectionList; iClearBefore: Boolean);\r\n function CreateObject: TPersistent; override;\r\n function GetConnection(I: Longint): TJvBaseConnectionInfo;\r\n procedure LoadData; override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n procedure AddConnection(ConnectionInfo: TJvBaseConnectionInfo);\r\n function CreateConnection: TJvBaseConnectionInfo;\r\n property Connection[I: Longint]: TJvBaseConnectionInfo read GetConnection;\r\n published\r\n //1 Stores the data of the last connection\r\n property LastConnect: TJvBaseConnectionInfo read FLastConnect write SetLastConnect;\r\n property ActivePage: TJvDBLogonDialogActivePage read FActivePage write FActivePage;\r\n property GroupByDatabase: Boolean read FGroupByDatabase write FGroupByDatabase;\r\n property GroupByUser: Boolean read FGroupByUser write FGroupByUser;\r\n property SavePasswords: Boolean read FSavePasswords write SetSavePasswords;\r\n end;\r\n\r\n TJvBaseOracleConnectionList = class(TJvBaseConnectionList)\r\n protected\r\n function CreateObject: TPersistent; override;\r\n end;\r\n\r\n TJvBaseDBLogonDialog = class(TJvBaseDBDialog)\r\n private\r\n AdditionalBtn: TWinControl;\r\n AdditionalPopupMenu: TPopupMenu;\r\n AddToListBtn: TWinControl;\r\n AliasPanel: TWinControl;\r\n ButtonPanel: TWinControl;\r\n CancelBtn: TWinControl;\r\n ColorBoxPanel: TWinControl;\r\n ConnectBtn: TWinControl;\r\n ConnectGroupPanel: TWinControl;\r\n ConnectListListBox: TWinControl;\r\n DatabaseComboBox: TWinControl;\r\n DatabasePanel: TWinControl;\r\n DatabaseTreeView: TWinControl;\r\n EditConnectionPanel: TWinControl;\r\n FAfterTransferSessionDataToConnectionInfo: TJvLogonDialogConnectionInfoEvent;\r\n FBeforeTransferConnectionInfoToSessionData: TJvLogonDialogConnectionInfoEvent;\r\n FConnectionList: TJvBaseConnectionList;\r\n FCurrentConnectionInfo: TJvBaseConnectionInfo;\r\n FGroupByDatabase: Boolean;\r\n fGroupByUser: Boolean;\r\n FOnDecryptPassword: TJvLogonDialogEncryptDecryptEvent;\r\n FOnEncryptPassword: TJvLogonDialogEncryptDecryptEvent;\r\n FOnFillDatabaseList: TJvLogonDialogFillListEvent;\r\n FOnFillShortcutList: TJvLogonDialogFillListEvent;\r\n FOnSessionConnect: TJvLogonDialogBaseSessionEvent;\r\n FOptions: TJvBaseDBLogonDialogOptions;\r\n GetFromListBtn: TWinControl;\r\n GroupByDatabaseCheckBox: TWinControl;\r\n GroupByUserCheckBox: TWinControl;\r\n GroupTreeView: TWinControl;\r\n IAliasEditData: IJvDynControlData;\r\n IColorComboBox: IJvDynControlColorComboBoxControl;\r\n IConnectGroupComboBoxData: IJvDynControlData;\r\n IConnectGroupComboBoxItems: IJvDynControlItems;\r\n IConnectionListPageControlTab: IJvDynControlTabControl;\r\n IConnectListListBoxData: IJvDynControlData;\r\n IConnectListListBoxItems: IJvDynControlItems;\r\n IDatabaseComboBoxData: IJvDynControlData;\r\n IDatabaseTreeView: IJvDynControlTreeView;\r\n IGroupByDatabaseCheckBox: IJvDynControlCheckBox;\r\n IGroupByUserCheckBox: IJvDynControlCheckBox;\r\n IGroupTreeView: IJvDynControlTreeView;\r\n IPasswordEditData: IJvDynControlData;\r\n ISavePasswordsCheckBox: IJvDynControlCheckBox;\r\n IShortCutComboBoxData: IJvDynControlData;\r\n IUserNameEditData: IJvDynControlData;\r\n IUserTreeView: IJvDynControlTreeView;\r\n LeftBottomPanel: TWinControl;\r\n LeftPanel: TWinControl;\r\n PasswordEdit: TWinControl;\r\n PasswordPanel: TWinControl;\r\n RemoveFromListBtn: TWinControl;\r\n SavePasswordsCheckBox: TWinControl;\r\n ShortCutPanel: TWinControl;\r\n UserNameEdit: TWinControl;\r\n UserNamePanel: TWinControl;\r\n UserTreeView: TWinControl;\r\n procedure AdditionalBtnClick(Sender: TObject);\r\n procedure AddToListBtnClick(Sender: TObject);\r\n function CalculatePanelHeight(iPanel: TWinControl): Integer;\r\n procedure CancelBtnClick(Sender: TObject);\r\n procedure ConnectBtnClick(Sender: TObject);\r\n procedure ConnectionListPageControlChange(Sender: TObject);\r\n procedure ConnectListListBoxClick(Sender: TObject);\r\n procedure ConnectListListBoxDblClick(Sender: TObject);\r\n procedure CreateUserTreeView;\r\n function DecryptPassword(const Value: string): string;\r\n function EncryptPassword(const Value: string): string;\r\n procedure FillAllConnectionLists;\r\n procedure FillConnectGroupComboBox;\r\n procedure FillConnectionList;\r\n procedure FillDatabaseTreeView;\r\n procedure FillGroupTreeView;\r\n procedure FillShortCutList(Items: TStringList);\r\n procedure FormClose(Sender: TObject; var Action: TCloseAction);\r\n procedure FormKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);\r\n procedure FormShow(Sender: TObject);\r\n function GetActivePage: TJvDBLogonDialogActivePage;\r\n function GetCurrentDialogListConnectionInfo: TJvBaseConnectionInfo;\r\n function GetDialogDatabase: string;\r\n function GetDialogPassword: string;\r\n function GetDialogUserName: string;\r\n procedure GetFromListBtnClick(Sender: TObject);\r\n procedure GroupByDatabaseCheckBoxClick(Sender: TObject);\r\n procedure GroupByUserCheckBoxClick(Sender: TObject);\r\n function ListConnectString(Connection: TJvBaseConnectionInfo; ShowShortCut, ShowConnectGroup: Boolean): string;\r\n procedure LoadSettings;\r\n procedure PasswordDialog_AfterTransferPasswordFromSession(var Password: string);\r\n procedure PasswordDialog_BeforeTransferPasswordToSession(var Password: string);\r\n procedure RearrangePanelControlsByTaborder(iPanel: TWinControl);\r\n procedure RemoveFromListBtnClick(Sender: TObject);\r\n procedure ResizeAllControls;\r\n procedure SetActivePage(const Value: TJvDBLogonDialogActivePage);\r\n procedure SetButtonState;\r\n procedure SetConnectionToTop(const SearchName: string);\r\n procedure SetDialogDatabase(const Value: string);\r\n procedure SetDialogPassword(const Value: string);\r\n procedure SetDialogUserName(const Value: string);\r\n procedure SetOptions(const Value: TJvBaseDBLogonDialogOptions);\r\n procedure StoreSettings;\r\n protected\r\n procedure ActivateDatabaseControl;\r\n procedure ActivatePasswordControl;\r\n procedure AlignControlTop(aControl, aPreviousControl: TControl);\r\n function ChangePassword: Boolean;\r\n procedure ClearControlInterfaceObjects; virtual;\r\n procedure ClearFormControls; virtual;\r\n procedure ConnectToSession;\r\n procedure CreateAdditionalConnectDialogControls(AOwner: TComponent;\r\n AParentControl: TWinControl); virtual;\r\n procedure CreateAdditionalConnectDialogEditPanel(AOwner: TComponent; AParentControl: TWinControl; const\r\n ControlBaseName, Caption: string; AControlType: TJvDynControlType; var oPanel, oEditControl: TWinControl; var\r\n oEditData: IJvDynControlData; onEditChange: TNotifyEvent = nil);\r\n procedure CreateFormControls(AForm: TForm); override;\r\n function CreatePasswordChangeDialog: TJvBaseDBPasswordDialog; virtual;\r\n procedure DefaultOnEditChange(Sender: TObject);\r\n procedure DoSessionConnect;\r\n procedure FillAdditionalPopupMenuEntries(APopupMenu: TPopupMenu); virtual;\r\n procedure FillAllComoboBoxes; virtual;\r\n procedure FillDatabaseComboBox;\r\n procedure FillDatabaseComboBoxValues(Items: TStrings); virtual;\r\n { Retrieve the class that holds the storage options and format settings. }\r\n class function GetDBLogonConnectionListClass: TJvBaseConnectionListClass; virtual;\r\n { Retrieve the class that holds the storage options and format settings. }\r\n class function GetDBLogonDialogOptionsClass: TJvBaseDBLogonDialogOptionsClass; virtual;\r\n function GetGroupByDatabase: Boolean;\r\n function GetGroupByUser: Boolean;\r\n procedure OnExportConnectionList(Sender: TObject);\r\n procedure OnImportConnectionList(Sender: TObject);\r\n procedure RearrangeEditPanel;\r\n procedure RearrangeEditPanelControlsByTaborder;\r\n procedure ResizeDialogClientHeight;\r\n procedure ResizeFormControls; virtual;\r\n function SavePasswords: Boolean;\r\n procedure SetAppStorage(Value: TJvCustomAppStorage); override;\r\n procedure SetAppStoragePath(Value: string); override;\r\n procedure SetEditPanelsTabOrder; virtual;\r\n procedure SetEditPanelsVisibility; virtual;\r\n procedure SetGroupByDatabase(Value: Boolean);\r\n procedure SetGroupByUser(Value: Boolean);\r\n procedure SetPanelHeight(iPanel: TWinControl);\r\n procedure SetPanelVisible(iPanel: TWinControl; iVisible: Boolean);\r\n procedure SetSession(const Value: TComponent); override;\r\n procedure TransferConnectionInfoFromDialog(ConnectionInfo: TJvBaseConnectionInfo); virtual;\r\n procedure TransferConnectionInfoToDialog(ConnectionInfo: TJvBaseConnectionInfo); virtual;\r\n procedure TransferSessionDataFromConnectionInfo(ConnectionInfo: TJvBaseConnectionInfo); virtual;\r\n procedure TransferSessionDataFromDialog;\r\n procedure TransferSessionDataToConnectionInfo(ConnectionInfo: TJvBaseConnectionInfo); virtual;\r\n procedure TransferSessionDataToDialog;\r\n procedure ValidateConnectBtnEnabled;\r\n property ActivePage: TJvDBLogonDialogActivePage read GetActivePage write SetActivePage;\r\n property ConnectionList: TJvBaseConnectionList read FConnectionList;\r\n property CurrentDialogListConnectionInfo: TJvBaseConnectionInfo read GetCurrentDialogListConnectionInfo;\r\n property DialogDatabase: string read GetDialogDatabase write SetDialogDatabase;\r\n property DialogPassword: string read GetDialogPassword write SetDialogPassword;\r\n property DialogUserName: string read GetDialogUserName write SetDialogUserName;\r\n property GroupByDatabase: Boolean read GetGroupByDatabase write SetGroupByDatabase;\r\n property GroupByUser: Boolean read GetGroupByUser write SetGroupByUser;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n procedure ConnectSession; virtual;\r\n function IsConnectAllowed: Boolean; virtual;\r\n property CurrentConnectionInfo: TJvBaseConnectionInfo read FCurrentConnectionInfo;\r\n published\r\n property AppStorage;\r\n property AppStoragePath;\r\n property Options: TJvBaseDBLogonDialogOptions read FOptions write SetOptions;\r\n //1 This events gives you the possibility to modify the connection data after receiving the data from the current session\r\n property AfterTransferSessionDataToConnectionInfo: TJvLogonDialogConnectionInfoEvent read\r\n FAfterTransferSessionDataToConnectionInfo write FAfterTransferSessionDataToConnectionInfo;\r\n //1 This Event gives you the possibility to modify the connection data before it is transfered to the current session\r\n property BeforeTransferConnectionInfoToSessionData:\r\n TJvLogonDialogConnectionInfoEvent read\r\n FBeforeTransferConnectionInfoToSessionData write\r\n FBeforeTransferConnectionInfoToSessionData;\r\n property OnDecryptPassword: TJvLogonDialogEncryptDecryptEvent read FOnDecryptPassword write FOnDecryptPassword;\r\n property OnEncryptPassword: TJvLogonDialogEncryptDecryptEvent read FOnEncryptPassword write FOnEncryptPassword;\r\n //1 Event for filling the database list\r\n property OnFillDatabaseList: TJvLogonDialogFillListEvent read FOnFillDatabaseList write FOnFillDatabaseList;\r\n //1 Event for customizing the shortcut list\r\n property OnFillShortcutList: TJvLogonDialogFillListEvent read FOnFillShortcutList write FOnFillShortcutList;\r\n property OnSessionConnect: TJvLogonDialogBaseSessionEvent read FOnSessionConnect write FOnSessionConnect;\r\n end;\r\n\r\n TJvBaseDBOracleLogonDialog = class(TJvBaseDBLogonDialog)\r\n private\r\n ConnectAsComboBox: TWinControl;\r\n ConnectAsPanel: TWinControl;\r\n IConnectAsComboBoxData: IJvDynControlData;\r\n function GetCurrentConnectionInfo: TJvBaseOracleConnectionInfo;\r\n function GetDialogConnectAs: string;\r\n function GetOptions: TJvBaseDBOracleLogonDialogOptions;\r\n procedure SetDialogConnectAs(const Value: string);\r\n procedure SetOptions(const Value: TJvBaseDBOracleLogonDialogOptions);\r\n protected\r\n procedure ClearFormControls; override;\r\n procedure CreateAdditionalConnectDialogControls(AOwner: TComponent; AParentControl: TWinControl); override;\r\n procedure CreateFormControls(AForm: TForm); override;\r\n { Retrieve the class that holds the storage options and format settings. }\r\n class function GetDBLogonConnectionListClass: TJvBaseConnectionListClass; override;\r\n { Retrieve the class that holds the storage options and format settings. }\r\n class function GetDBLogonDialogOptionsClass: TJvBaseDBLogonDialogOptionsClass; override;\r\n procedure SetEditPanelsTabOrder; override;\r\n procedure SetEditPanelsVisibility; override;\r\n procedure TransferConnectionInfoFromDialog(ConnectionInfo: TJvBaseConnectionInfo); override;\r\n procedure TransferConnectionInfoToDialog(ConnectionInfo: TJvBaseConnectionInfo); override;\r\n property DialogConnectAs: string read GetDialogConnectAs write SetDialogConnectAs;\r\n public\r\n procedure ClearControlInterfaceObjects; override;\r\n property CurrentConnectionInfo: TJvBaseOracleConnectionInfo read GetCurrentConnectionInfo;\r\n published\r\n property Options: TJvBaseDBOracleLogonDialogOptions read GetOptions write SetOptions;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvBaseDBLogonDialog.pas $';\r\n Revision: '$Revision: 13406 $';\r\n Date: '$Date: 2012-08-24 22:05:23 +0200 (ven. 24 août 2012) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nconst\r\n cDefaultColorComboBoxColor = clWindow;\r\n\r\nimplementation\r\n\r\nuses\r\n Windows, SysUtils, Types, ComCtrls, StdCtrls, Dialogs,\r\n {$IFDEF HAS_UNIT_CHARACTER}\r\n Character, \r\n {$ENDIF HAS_UNIT_CHARACTER}\r\n JvJCLUtils, //ToUpper and CharInSet\r\n JvAppIniStorage, JvAppXMLStorage, JvDSADialogs, JvResources, ExtCtrls;\r\n\r\n\r\n//=== { TJvBaseDBLogonDialog } ===============================================\r\n\r\nconstructor TJvBaseDBLogonDialog.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FOptions := GetDBLogonDialogOptionsClass.Create;\r\n FConnectionList := GetDBLogonConnectionListClass.Create(Self);\r\n FCurrentConnectionInfo := FConnectionList.CreateConnection;\r\nend;\r\n\r\ndestructor TJvBaseDBLogonDialog.Destroy;\r\nbegin\r\n FreeAndNil(FCurrentConnectionInfo);\r\n FreeAndNil(FConnectionList);\r\n FreeAndNil(FOptions);\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvBaseDBLogonDialog.ActivateDatabaseControl;\r\nbegin\r\n if Assigned(DatabaseComboBox) and Assigned(DBDialog) then\r\n DBDialog.ActiveControl := DatabaseComboBox;\r\nend;\r\n\r\nprocedure TJvBaseDBLogonDialog.ActivatePasswordControl;\r\nbegin\r\n if Assigned(DatabaseComboBox) and Assigned(DBDialog) then\r\n DBDialog.ActiveControl := PasswordEdit;\r\nend;\r\n\r\nprocedure TJvBaseDBLogonDialog.AdditionalBtnClick(Sender: TObject);\r\nvar\r\n P: TPoint;\r\nbegin\r\n P := AdditionalBtn.Parent.ClientToScreen(Point(AdditionalBtn.Left + AdditionalBtn.Width, AdditionalBtn.Top));\r\n AdditionalPopupMenu.Popup(P.X, P.Y);\r\nend;\r\n\r\nprocedure TJvBaseDBLogonDialog.AddToListBtnClick(Sender: TObject);\r\nvar\r\n ConnectionInfo: TJvBaseConnectionInfo;\r\nbegin\r\n ConnectionInfo := ConnectionList.CreateConnection;\r\n TransferConnectionInfoFromDialog(ConnectionInfo);\r\n ConnectionList.AddConnection(ConnectionInfo);\r\n FillAllConnectionLists;\r\nend;\r\n\r\nprocedure TJvBaseDBLogonDialog.AlignControlTop(aControl, aPreviousControl: TControl);\r\nbegin\r\n aControl.Align := alTop;\r\n if Assigned(aPreviousControl) then\r\n aControl.Top := aPreviousControl.Top + aPreviousControl.Height\r\n else\r\n aControl.Top := 0;\r\nend;\r\n\r\nfunction TJvBaseDBLogonDialog.CalculatePanelHeight(iPanel: TWinControl):\r\n Integer;\r\nvar\r\n i: Integer;\r\n t: Integer;\r\n h: Integer;\r\n Found : Boolean;\r\nbegin\r\n t := 99999;\r\n h := 0;\r\n Found := False;\r\n for i := 0 to iPanel.ControlCount - 1 do\r\n begin\r\n if not iPanel.Controls[i].Visible then\r\n Continue;\r\n Found := True;\r\n if iPanel.Controls[i].Top < t then\r\n t := iPanel.Controls[i].Top;\r\n if iPanel.Controls[i].Top+iPanel.Controls[i].Height > h then\r\n h := iPanel.Controls[i].Top+iPanel.Controls[i].Height;\r\n end;\r\n if found then\r\n Result := t+h+1\r\n else\r\n Result := 0;\r\nend;\r\n\r\nprocedure TJvBaseDBLogonDialog.CancelBtnClick(Sender: TObject);\r\nbegin\r\n DBDialog.ModalResult := mrCancel;\r\nend;\r\n\r\nfunction TJvBaseDBLogonDialog.ChangePassword: Boolean;\r\nvar\r\n PasswordDialog: TJvBaseDBPasswordDialog;\r\nbegin\r\n Result := False;\r\n if not Options.AllowPasswordChange then\r\n Exit;\r\n PasswordDialog := TJvBaseDBPasswordDialog(CreatePasswordChangeDialog);\r\n if Assigned(PasswordDialog) then\r\n try\r\n PasswordDialog.Session := Session;\r\n PasswordDialog.AfterTransferPasswordFromSession := PasswordDialog_AfterTransferPasswordFromSession;\r\n PasswordDialog.BeforeTransferPasswordToSession := PasswordDialog_BeforeTransferPasswordToSession;\r\n PasswordDialog.Options := Options.PasswordDialogOptions;\r\n Result := PasswordDialog.Execute;\r\n finally\r\n PasswordDialog.Free;\r\n end;\r\nend;\r\n\r\nprocedure TJvBaseDBLogonDialog.ClearControlInterfaceObjects;\r\nbegin\r\n IAliasEditData:= nil;\r\n IColorComboBox:= nil;\r\n IConnectGroupComboBoxData:= nil;\r\n IConnectGroupComboBoxItems:= nil;\r\n IConnectionListPageControlTab:= nil;\r\n IConnectListListBoxData:= nil;\r\n IConnectListListBoxItems:= nil;\r\n IDatabaseComboBoxData:= nil;\r\n IDatabaseTreeView:= nil;\r\n IGroupByDatabaseCheckBox:= nil;\r\n IGroupByUserCheckBox:= nil;\r\n IGroupTreeView:= nil;\r\n IPasswordEditData:= nil;\r\n ISavePasswordsCheckBox:= nil;\r\n IShortCutComboBoxData:= nil;\r\n IUserNameEditData:= nil;\r\n IUserTreeView:= nil;\r\nend;\r\n\r\nprocedure TJvBaseDBLogonDialog.ClearFormControls;\r\nbegin\r\n if Assigned(IUserNameEditData) then\r\n IUserNameEditData.ControlValue := '';\r\n if Assigned(IPasswordEditData) then\r\n IPasswordEditData.ControlValue := '';\r\n if Assigned(IDatabaseComboBoxData) then\r\n IDatabaseComboBoxData.ControlValue := '';\r\n if Assigned(IConnectGroupComboBoxData) then\r\n IConnectGroupComboBoxData.ControlValue := '';\r\n if Assigned(IShortCutComboBoxData) then\r\n IShortCutComboBoxData.ControlValue := '';\r\n if Assigned(IColorComboBox) then\r\n IColorComboBox.ControlSelectedColor := cDefaultColorComboBoxColor;\r\nend;\r\n\r\nprocedure TJvBaseDBLogonDialog.ConnectBtnClick(Sender: TObject);\r\nbegin\r\n if not ConnectBtn.Enabled then\r\n Exit;\r\n ConnectToSession;\r\nend;\r\n\r\nprocedure TJvBaseDBLogonDialog.ConnectionListPageControlChange(Sender: TObject);\r\nbegin\r\n SetButtonState;\r\nend;\r\n\r\nprocedure TJvBaseDBLogonDialog.ConnectListListBoxClick(Sender: TObject);\r\nbegin\r\n SetButtonState;\r\nend;\r\n\r\nprocedure TJvBaseDBLogonDialog.ConnectListListBoxDblClick(Sender: TObject);\r\nbegin\r\n if Assigned(CurrentDialogListConnectionInfo) then\r\n begin\r\n TransferConnectionInfoToDialog(CurrentDialogListConnectionInfo);\r\n ConnectToSession;\r\n end;\r\nend;\r\n\r\nprocedure TJvBaseDBLogonDialog.ConnectSession;\r\nbegin\r\nend;\r\n\r\nprocedure TJvBaseDBLogonDialog.ConnectToSession;\r\nbegin\r\n ValidateConnectBtnEnabled;\r\n if ConnectBtn.Enabled then\r\n DoSessionConnect\r\n else\r\n if DialogPassword = '' then\r\n PasswordEdit.SetFocus;\r\nend;\r\n\r\nprocedure TJvBaseDBLogonDialog.CreateAdditionalConnectDialogControls(AOwner: TComponent;\r\n AParentControl: TWinControl);\r\nbegin\r\nend;\r\n\r\nprocedure TJvBaseDBLogonDialog.CreateAdditionalConnectDialogEditPanel(AOwner: TComponent; AParentControl: TWinControl;\r\n const ControlBaseName, Caption: string; AControlType: TJvDynControlType; var oPanel, oEditControl: TWinControl; var\r\n oEditData: IJvDynControlData; onEditChange: TNotifyEvent = nil);\r\nvar\r\n LabelControl: TControl;\r\n IDynControlLabel: IJvDynControlLabel;\r\n IDynControlAutoSize: IJvDynControlAutoSize;\r\n IDynControl: IJvDynControl;\r\nbegin\r\n oPanel := DynControlEngine.CreatePanelControl(AOwner, AParentControl, ControlBaseName+'Panel', '', alTop);\r\n AlignControlTop(oPanel, nil);\r\n LabelControl := DynControlEngine.CreateLabelControl(AOwner, oPanel, ControlBaseName+'Label', Caption, nil);\r\n AlignControlTop(LabelControl, nil);\r\n oEditControl := TWinControl(DynControlEngine.CreateControl(AControlType, AOwner, oPanel, ControlBaseName+'Edit'));\r\n Supports(oEditControl, IJvDynControlData, oEditData);\r\n oEditData.ControlValue := '';\r\n oEditData.ControlSetOnChange(onEditChange);\r\n AlignControlTop(oEditControl, LabelControl);\r\n if Supports(oEditControl, IJvDynControl, IDynControl) then\r\n IDynControl.ControlSetOnClick(onEditChange);\r\n if Supports(LabelControl, IJvDynControlLabel, IDynControlLabel) then\r\n IDynControlLabel.ControlSetFocusControl(oEditControl);\r\n if Supports(LabelControl, IJvDynControlAutoSize,IDynControlAutoSize) then\r\n IDynControlAutoSize.ControlSetAutoSize(True);\r\n SetPanelHeight(oPanel);\r\nend;\r\n\r\nprocedure TJvBaseDBLogonDialog.CreateFormControls(AForm: TForm);\r\nvar\r\n MainPanel, ListPanel, ListBtnPanel, GroupListPanel: TWinControl;\r\n AliasEdit: TWinControl;\r\n ShortCutComboBox: TWinControl;\r\n ConnectGroupComboBox: TWinControl;\r\n ConnectionListPageControl: TWinControl;\r\n ColorComboBox: TWinControl;\r\n Items: TStringList;\r\n ITabControl: IJvDynControlTabControl;\r\n IDynControl: IJvDynControl;\r\n IDynControlAutoSize: IJvDynControlAutoSize;\r\n IDynControlDblClick: IJvDynControlDblClick;\r\n IDynControlReadOnly: IJvDynControlReadOnly;\r\n IDynControlPageControl: IJvDynControlPageControl;\r\n IDynControlBevelBorder: IJvDynControlBevelBorder;\r\n IDynControlComboBox: IJvDynControlComboBox;\r\n IDynControlEdit: IJvDynControlEdit;\r\n LabelControl: TControl;\r\n IDynControlLabel: IJvDynControlLabel;\r\n ConnectListLabel: TWinControl;\r\n IDynControlItems: IJvDynControlItems;\r\nbegin\r\n AForm.Name := 'DBDialog';\r\n// AForm.BorderIcons := [biSystemMenu, biMinimize, biMaximize, biHelp];\r\n AForm.BorderStyle := bsDialog;\r\n AForm.Caption := RsLogonToDatabase;\r\n AForm.ClientHeight := 440;\r\n AForm.ClientWidth := 680;\r\n AForm.Position := poScreenCenter;\r\n AForm.KeyPreview := True;\r\n AForm.OnClose := FormClose;\r\n AForm.OnKeyDown := FormKeyDown;\r\n AForm.OnShow := FormShow;\r\n\r\n ButtonPanel := DynControlEngine.CreatePanelControl(AForm, AForm, 'ButtonPanel', '', alBottom);\r\n ConnectBtn := DynControlEngine.CreateButton(AForm, ButtonPanel, 'ConnectBtn', RsBtnConnect, '', ConnectBtnClick, True, False);\r\n ConnectBtn.Left := 60;\r\n ConnectBtn.Top := 3;\r\n ConnectBtn.Width := 90;\r\n ConnectBtn.Height := 25;\r\n CancelBtn := DynControlEngine.CreateButton(AForm, ButtonPanel, 'CancelBtn', RsButtonCancelCaption, '', CancelBtnClick, False, True);\r\n CancelBtn.Left := 460;\r\n CancelBtn.Top := ConnectBtn.Top;\r\n CancelBtn.Width := 90;\r\n CancelBtn.Height := 25;\r\n\r\n AdditionalBtn := DynControlEngine.CreateButton(AForm, ButtonPanel, 'AdditionalBtn', RsBtnAdditional, '', AdditionalBtnClick, False, False);\r\n AdditionalBtn.Left := 460;\r\n AdditionalBtn.Top := ConnectBtn.Top;\r\n AdditionalBtn.Width := 100;\r\n AdditionalBtn.Height := 25;\r\n\r\n SetPanelHeight(ButtonPanel);\r\n\r\n AdditionalPopupMenu := TPopupMenu.Create(AForm);\r\n FillAdditionalPopupMenuEntries(AdditionalPopupMenu);\r\n\r\n AdditionalBtn.Visible := AdditionalPopupMenu.Items.Count > 0;\r\n\r\n MainPanel := DynControlEngine.CreatePanelControl(AForm, AForm, 'MainPanel', '', alClient);\r\n MainPanel.TabOrder := 0;\r\n if Supports(MainPanel, IJvDynControlBevelBorder, IDynControlBevelBorder) then\r\n IDynControlBevelBorder.ControlSetBorderWidth(5);\r\n if Supports(MainPanel, IJvDynControlBevelBorder, IDynControlBevelBorder) then\r\n IDynControlBevelBorder.ControlSetBevelOuter(bvNone);\r\n ListPanel := DynControlEngine.CreatePanelControl(AForm, MainPanel, 'ListPanel', '', alClient);\r\n ListPanel.Anchors := [akTop, akRight, akBottom];\r\n if Supports(ListPanel, IJvDynControlBevelBorder, IDynControlBevelBorder) then\r\n IDynControlBevelBorder.ControlSetBevelOuter(bvNone);\r\n ListPanel.TabOrder := 1;\r\n\r\n ConnectListLabel := DynControlEngine.CreateStaticTextControl(AForm, ListPanel, 'ConnectListLabel', 'Connection List');\r\n\r\n AlignControlTop(ConnectListLabel, nil);\r\n ConnectListLabel.Height := 18;\r\n\r\n ListBtnPanel := DynControlEngine.CreatePanelControl(AForm, MainPanel, 'ListBtnPanel', '', alLeft);\r\n ListBtnPanel.Width := 32;\r\n\r\n AddToListBtn := DynControlEngine.CreateButton(AForm, ListBtnPanel, 'AddToListBtn',\r\n '>', RsBtnHintAddDefinitionToList, AddToListBtnClick, False, False);\r\n AddToListBtn.Left := 4;\r\n AddToListBtn.Top := 45;\r\n AddToListBtn.Width := 23;\r\n AddToListBtn.Height := 22;\r\n GetFromListBtn := DynControlEngine.CreateButton(AForm, ListBtnPanel, 'GetFromListBtn',\r\n '<', RsBtnHintSelectDefinitionFromList, GetFromListBtnClick, False, False);\r\n GetFromListBtn.Left := 4;\r\n GetFromListBtn.Top := 85;\r\n GetFromListBtn.Width := 23;\r\n GetFromListBtn.Height := 22;\r\n RemoveFromListBtn := DynControlEngine.CreateButton(AForm, ListBtnPanel, 'RemoveFromListBtn',\r\n 'X', RsBtnHintDeleteDefinitionFromList, RemoveFromListBtnClick, False, False);\r\n RemoveFromListBtn.Left := 4;\r\n RemoveFromListBtn.Top := 125;\r\n RemoveFromListBtn.Width := 23;\r\n RemoveFromListBtn.Height := 22;\r\n\r\n Items := tStringList.Create;\r\n try\r\n Items.Add(RsPageDefaultList);\r\n Items.Add(RsPageByUser);\r\n Items.Add(RsPageByDatabase);\r\n Items.Add(RsPageByGroup);\r\n ConnectionListPageControl := DynControlEngine.CreatePageControlControl(AForm, ListPanel,\r\n 'ConnectionListPageControl', Items);\r\n finally\r\n Items.Free;\r\n end;\r\n\r\n ConnectionListPageControl.Align := alClient;\r\n Supports(ConnectionListPageControl, IJvDynControlTabControl, IConnectionListPageControlTab);\r\n if Supports(ConnectionListPageControl, IJvDynControlTabControl, ITabControl) then\r\n begin\r\n ITabControl.ControlSetOnChangeTab(ConnectionListPageControlChange);\r\n ITabControl.ControlSetMultiLine(True);\r\n ITabControl.ControlTabIndex := 2;\r\n end;\r\n\r\n ConnectListListBox := DynControlEngine.CreateListBoxControl(AForm, AForm, 'ConnectListListBox', nil);\r\n ConnectListListBox.Align := alClient;\r\n if Supports(ConnectionListPageControl, IJvDynControlPageControl, IDynControlPageControl) then\r\n ConnectListListBox.Parent := IDynControlPageControl.ControlGetPage(RsPageDefaultList);\r\n\r\n Supports(ConnectListListBox, IJvDynControlItems, IConnectListListBoxItems);\r\n Supports(ConnectListListBox, IJvDynControlData, IConnectListListBoxData);\r\n if Supports(ConnectListListBox, IJvDynControl, IDynControl) then\r\n IDynControl.ControlSetOnClick(ConnectListListBoxClick);\r\n if Supports(ConnectListListBox, IJvDynControlDblClick, IDynControlDblClick) then\r\n IDynControlDblClick.ControlSetOnDblClick(ConnectListListBoxDblClick);\r\n\r\n UserTreeView := DynControlEngine.CreateTreeViewControl(AForm, AForm, 'UserTreeView');\r\n UserTreeView.Align := alClient;\r\n if Supports(ConnectionListPageControl, IJvDynControlPageControl, IDynControlPageControl) then\r\n UserTreeView.Parent := IDynControlPageControl.ControlGetPage(RsPageByUser);\r\n if Supports(UserTreeView, IJvDynControl, IDynControl) then\r\n IDynControl.ControlSetOnClick(ConnectListListBoxClick);\r\n if Supports(UserTreeView, IJvDynControlDblClick, IDynControlDblClick) then\r\n IDynControlDblClick.ControlSetOnDblClick(ConnectListListBoxDblClick);\r\n if Supports(UserTreeView, IJvDynControlTreeView, IUserTreeView) then\r\n IUserTreeView.ControlSetSortType(stText);\r\n if Supports(UserTreeView, IJvDynControlReadOnly, IDynControlReadOnly) then\r\n IDynControlReadOnly.ControlSetReadOnly(True);\r\n DatabaseTreeView := DynControlEngine.CreateTreeViewControl(AForm, AForm, 'DatabaseTreeView');\r\n DatabaseTreeView.Align := alClient;\r\n if Supports(ConnectionListPageControl, IJvDynControlPageControl, IDynControlPageControl) then\r\n DatabaseTreeView.Parent := IDynControlPageControl.ControlGetPage(RsPageByDatabase);\r\n if Supports(DatabaseTreeView, IJvDynControl, IDynControl) then\r\n IDynControl.ControlSetOnClick(ConnectListListBoxClick);\r\n if Supports(DatabaseTreeView, IJvDynControlDblClick, IDynControlDblClick) then\r\n IDynControlDblClick.ControlSetOnDblClick(ConnectListListBoxDblClick);\r\n if Supports(DatabaseTreeView, IJvDynControlTreeView, IDatabaseTreeView) then\r\n IDatabaseTreeView.ControlSetSortType(stText);\r\n if Supports(DatabaseTreeView, IJvDynControlReadOnly, IDynControlReadOnly) then\r\n IDynControlReadOnly.ControlSetReadOnly(True);\r\n\r\n if Options.ShowConnectGroup then\r\n begin\r\n GroupTreeView := DynControlEngine.CreateTreeViewControl(AForm, AForm, 'GroupTreeView');\r\n GroupTreeView.Align := alClient;\r\n if Supports(ConnectionListPageControl, IJvDynControlPageControl, IDynControlPageControl) then\r\n GroupTreeView.Parent := IDynControlPageControl.ControlGetPage(RsPageByGroup);\r\n if Supports(GroupTreeView, IJvDynControl, IDynControl) then\r\n IDynControl.ControlSetOnClick(ConnectListListBoxClick);\r\n if Supports(GroupTreeView, IJvDynControlDblClick, IDynControlDblClick) then\r\n IDynControlDblClick.ControlSetOnDblClick(ConnectListListBoxDblClick);\r\n if Supports(GroupTreeView, IJvDynControlTreeView, IGroupTreeView) then\r\n IGroupTreeView.ControlSetSortType(stText);\r\n if Supports(GroupTreeView, IJvDynControlReadOnly, IDynControlReadOnly) then\r\n IDynControlReadOnly.ControlSetReadOnly(True);\r\n\r\n GroupListPanel := DynControlEngine.CreatePanelControl(AForm, AForm, 'GroupListPanel', '', alBottom);\r\n if Supports(ConnectionListPageControl, IJvDynControlPageControl, IDynControlPageControl) then\r\n GroupListPanel.Parent := IDynControlPageControl.ControlGetPage(RsPageByGroup);\r\n GroupListPanel.Height := 25;\r\n GroupListPanel.Align := alBottom;\r\n if Supports(GroupListPanel, IJvDynControlBevelBorder, IDynControlBevelBorder) then\r\n IDynControlBevelBorder.ControlSetBevelOuter(bvNone);\r\n\r\n GroupByDatabaseCheckBox := DynControlEngine.CreateCheckboxControl(AForm, GroupListPanel, 'GroupByDatabaseCheckBox',\r\n RsCheckBoxGroupByDatabase);\r\n GroupByDatabaseCheckBox.Left := 0;\r\n GroupByDatabaseCheckBox.Top := 5;\r\n GroupByDatabaseCheckBox.Width := 116;\r\n GroupByDatabaseCheckBox.Height := 17;\r\n GroupByDatabaseCheckBox.TabOrder := 0;\r\n if Supports(GroupByDatabaseCheckBox, IJvDynControl, IDynControl) then\r\n IDynControl.ControlSetOnClick(GroupByDatabaseCheckBoxClick);\r\n Supports(GroupByDatabaseCheckBox, IJvDynControlCheckBox, IGroupByDatabaseCheckBox);\r\n\r\n GroupByUserCheckBox := DynControlEngine.CreateCheckboxControl(AForm, GroupListPanel, 'GroupByUserCheckBox',\r\n RsCheckBoxGroupByUser);\r\n GroupByUserCheckBox.Left := 125;\r\n GroupByUserCheckBox.Top := 5;\r\n GroupByUserCheckBox.Width := 97;\r\n GroupByUserCheckBox.Height := 17;\r\n if Supports(GroupByUserCheckBox, IJvDynControl, IDynControl) then\r\n IDynControl.ControlSetOnClick(GroupByUserCheckBoxClick);\r\n Supports(GroupByUserCheckBox, IJvDynControlCheckBox, IGroupByUserCheckBox);\r\n end;\r\n\r\n SavePasswordsCheckBox := DynControlEngine.CreateCheckboxControl(AForm, ListPanel, 'SavePasswordsCheckBox', RsCheckboxSavePasswords);\r\n SavePasswordsCheckBox.Align := alBottom;\r\n Supports(SavePasswordsCheckBox, IJvDynControlCheckBox, ISavePasswordsCheckBox);\r\n SavePasswordsCheckBox.Visible := Options.ShowSavePasswords;\r\n\r\n LeftPanel := DynControlEngine.CreatePanelControl(AForm, MainPanel, 'LeftPanel', '', alLeft);\r\n LeftPanel.Width := 280;\r\n if Supports(LeftPanel, IJvDynControlBevelBorder, IDynControlBevelBorder) then\r\n IDynControlBevelBorder.ControlSetBevelOuter(bvNone);\r\n LeftPanel.TabOrder := 0;\r\n\r\n EditConnectionPanel := DynControlEngine.CreatePanelControl(AForm, LeftPanel, 'EditConnectionPanel', '', alTop);\r\n AlignControlTop(EditConnectionPanel,nil);\r\n if Supports(EditConnectionPanel, IJvDynControlBevelBorder, IDynControlBevelBorder) then\r\n IDynControlBevelBorder.ControlSetBevelOuter(bvNone);\r\n\r\n LeftBottomPanel := DynControlEngine.CreatePanelControl(AForm, LeftPanel, 'LeftBottomPanel', '', alTop);\r\n AlignControlTop(LeftBottomPanel,EditConnectionPanel);\r\n if Supports(LeftBottomPanel, IJvDynControlBevelBorder, IDynControlBevelBorder) then\r\n IDynControlBevelBorder.ControlSetBevelOuter(bvNone);\r\n\r\n CreateAdditionalConnectDialogEditPanel(AForm, EditConnectionPanel, 'UserName', RsUsername, jctEdit, UserNamePanel, UserNameEdit, IUsernameEditData, DefaultOnEditChange);\r\n\r\n CreateAdditionalConnectDialogEditPanel(AForm, EditConnectionPanel, 'Password', RsPassword, jctEdit, PasswordPanel, PasswordEdit, IPasswordEditData, DefaultOnEditChange);\r\n if Supports(PasswordEdit, IJvDynControlEdit, IDynControlEdit) then\r\n IDynControlEdit.ControlSetPasswordChar('*');\r\n\r\n CreateAdditionalConnectDialogEditPanel(AForm, EditConnectionPanel, 'Database', RsDatabase, jctComboBox, DatabasePanel, DatabaseComboBox, IDatabaseComboBoxData, DefaultOnEditChange);\r\n if Supports(DatabaseComboBox, IJvDynControl, IDynControl) then\r\n begin\r\n IDynControl.ControlSetOnClick(DefaultOnEditChange);\r\n IDynControl.ControlSetOnExit(DefaultOnEditChange); // Fix for the VCL/JVCL Controls which did not react on OnChange and OnClick\r\n end;\r\n\r\n CreateAdditionalConnectDialogEditPanel(AForm, EditConnectionPanel, 'Alias', RsAlias, jctEdit, AliasPanel, AliasEdit, IAliasEditData, DefaultOnEditChange);\r\n\r\n CreateAdditionalConnectDialogControls(AForm, EditConnectionPanel);\r\n\r\n CreateAdditionalConnectDialogEditPanel(AForm, LeftBottomPanel, 'ShortCut', RsShortCut, jctComboBox, ShortCutPanel, ShortCutComboBox, IShortCutComboBoxData, DefaultOnEditChange);\r\n if Supports(ShortCutComboBox, IJvDynControlComboBox, IDynControlComboBox) then\r\n IDynControlComboBox.ControlSetNewEntriesAllowed(False);\r\n Items := tStringList.Create;\r\n try\r\n FillShortCutList(Items);\r\n if Supports(ShortCutComboBox, IJvDynControlItems, IDynControlItems) then\r\n IDynControlItems.ControlItems.Assign(Items);\r\n finally\r\n Items.Free;\r\n end;\r\n ShortCutPanel.Visible := Options.ShowShortcuts;\r\n\r\n CreateAdditionalConnectDialogEditPanel(AForm, LeftBottomPanel, 'ConnectGroup', RsConnectGroup, jctComboBox, ConnectGroupPanel, ConnectGroupComboBox, IConnectGroupComboBoxData, DefaultOnEditChange);\r\n ConnectGroupPanel.Visible := Options.ShowConnectGroup;\r\n if Supports(ConnectGroupComboBox, IJvDynControl, IDynControl) then\r\n begin\r\n IDynControl.ControlSetOnClick(DefaultOnEditChange);\r\n IDynControl.ControlSetOnExit(DefaultOnEditChange); // Fix for the VCL/JVCL Controls which did not react on OnChange and OnClick\r\n end;\r\n Supports(ConnectGroupComboBox, IJvDynControlItems, IConnectGroupComboBoxItems);\r\n\r\n ColorBoxPanel := DynControlEngine.CreatePanelControl(AForm, LeftBottomPanel, 'ColorBoxPanel', '', alTop);\r\n AlignControlTop(ColorBoxPanel, ConnectGroupPanel);\r\n\r\n LabelControl := DynControlEngine.CreateLabelControl(AForm, ColorBoxPanel, 'ColorBoxLabel', 'Co&lor');\r\n AlignControlTop(LabelControl, nil);\r\n Items := tStringList.Create;\r\n try\r\n ColorComboBox := DynControlEngine.CreateColorComboBoxControl(AForm, ColorBoxPanel, 'ColorComboBox',\r\n cDefaultColorComboBoxColor);\r\n Supports(ColorComboBox, IJvDynControlColorComboBoxControl, IColorComboBox);\r\n AlignControlTop(ColorComboBox, LabelControl);\r\n finally\r\n Items.Free;\r\n end;\r\n if Supports(LabelControl, IJvDynControlLabel, IDynControlLabel) then\r\n IDynControlLabel.ControlSetFocusControl(ColorComboBox);\r\n if Supports(LabelControl, IJvDynControlAutoSize,IDynControlAutoSize) then\r\n IDynControlAutoSize.ControlSetAutoSize(True);\r\n ColorBoxPanel.Visible := Options.ShowColors;\r\n SetPanelHeight(ColorBoxPanel);\r\n\r\nend;\r\n\r\nfunction TJvBaseDBLogonDialog.CreatePasswordChangeDialog: TJvBaseDBPasswordDialog;\r\nbegin\r\n Result := nil;\r\nend;\r\n\r\nprocedure TJvBaseDBLogonDialog.CreateUserTreeView;\r\nvar\r\n i, j: Integer;\r\n Node: TTreeNode;\r\n Found: Boolean;\r\n s: string;\r\n Connection: TJvBaseConnectionInfo;\r\n Items: TTreeNodes;\r\nbegin\r\n Items := IUserTreeView.ControlItems;\r\n Items.Clear;\r\n for i := 0 to ConnectionList.Count - 1 do\r\n begin\r\n Connection := ConnectionList.Connection[i];\r\n s := ListConnectString(Connection, Options.ShowShortcuts, Options.ShowConnectGroup);\r\n\r\n Found := False;\r\n for j := 0 to Items.Count - 1 do\r\n if Items[j].Level = 0 then\r\n begin\r\n Node := Items[j];\r\n if Node.Text = Connection.Username then\r\n begin\r\n Node := Items.AddChild(Node, s);\r\n Node.Data := Connection;\r\n Found := True;\r\n break;\r\n end;\r\n end;\r\n if not Found then\r\n begin\r\n Node := Items.AddChild(nil, Connection.Username);\r\n Node := Items.AddChild(Node, s);\r\n Node.Data := Connection;\r\n end;\r\n end;\r\n IUserTreeView.ControlSortItems;\r\nend;\r\n\r\nfunction TJvBaseDBLogonDialog.DecryptPassword(const Value: string): string;\r\nbegin\r\n try\r\n Result := Value;\r\n if Assigned(FOnDecryptPassword) then\r\n FOnDecryptPassword(Result);\r\n except\r\n Result := '';\r\n end;\r\nend;\r\n\r\nprocedure TJvBaseDBLogonDialog.DefaultOnEditChange(Sender: TObject);\r\nbegin\r\n if csDestroying in ComponentState then\r\n Exit;\r\n TransferConnectionInfoFromDialog(CurrentConnectionInfo);\r\n ValidateConnectBtnEnabled;\r\nend;\r\n\r\nprocedure TJvBaseDBLogonDialog.DoSessionConnect;\r\nbegin\r\n TransferSessionDataFromDialog;\r\n if Options.SetLastConnectToTop then\r\n SetConnectionToTop(CurrentConnectionInfo.SearchName);\r\n if Assigned(OnSessionConnect) then\r\n OnSessionConnect(Session)\r\n else\r\n ConnectSession;\r\n if SessionIsConnected then\r\n DBDialog.ModalResult := mrok;\r\nend;\r\n\r\nfunction TJvBaseDBLogonDialog.EncryptPassword(const Value: string): string;\r\nbegin\r\n try\r\n Result := Value;\r\n if Assigned(FOnEncryptPassword) then\r\n FOnEncryptPassword(Result);\r\n except\r\n Result := '';\r\n end;\r\nend;\r\n\r\nprocedure TJvBaseDBLogonDialog.FillAdditionalPopupMenuEntries(APopupMenu: TPopupMenu);\r\nvar\r\n MenuItem: TMenuItem;\r\nbegin\r\n if Options.ShowConnectionsExport then\r\n begin\r\n MenuItem := TMenuItem.Create(APopupMenu.Owner);\r\n MenuItem.Caption := RSExportConnectionList;\r\n MenuItem.OnClick := OnExportConnectionList;\r\n APopupMenu.Items.Add(MenuItem);\r\n MenuItem := TMenuItem.Create(APopupMenu.Owner);\r\n MenuItem.Caption := RSImportConnectionList;\r\n MenuItem.OnClick := OnImportConnectionList;\r\n APopupMenu.Items.Add(MenuItem);\r\n end;\r\nend;\r\n\r\nprocedure TJvBaseDBLogonDialog.FillAllComoboBoxes;\r\nbegin\r\n FillDatabaseComboBox;\r\nend;\r\n\r\nprocedure TJvBaseDBLogonDialog.FillAllConnectionLists;\r\nbegin\r\n FillAllComoboBoxes;\r\n FillConnectionList;\r\n FillDatabaseTreeView;\r\n FillGroupTreeView;\r\n FillConnectGroupComboBox;\r\n CreateUserTreeView;\r\n SetButtonState;\r\nend;\r\n\r\nprocedure TJvBaseDBLogonDialog.FillConnectGroupComboBox;\r\nvar\r\n i: Integer;\r\n Connection: TJvBaseConnectionInfo;\r\n Items: TStringList;\r\nbegin\r\n if Assigned(IConnectGroupComboBoxItems) then\r\n begin\r\n Items := TStringList.Create;\r\n try\r\n Items.Sorted := True;\r\n for i := 0 to ConnectionList.Count - 1 do\r\n begin\r\n Connection := ConnectionList.Connection[i];\r\n if Connection.Group <> '' then\r\n if Items.IndexOf(Connection.Group) < 0 then\r\n Items.Add(Connection.Group);\r\n end;\r\n IConnectGroupComboBoxItems.ControlItems.Assign(Items);\r\n finally\r\n Items.Free;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvBaseDBLogonDialog.FillConnectionList;\r\nvar\r\n i: Integer;\r\n Connection: TJvBaseConnectionInfo;\r\n Items: TStrings;\r\nbegin\r\n if Assigned(IConnectListListBoxItems) then\r\n begin\r\n Items := IConnectListListBoxItems.ControlItems;\r\n Items.Clear;\r\n for i := 0 to ConnectionList.Count - 1 do\r\n begin\r\n Connection := ConnectionList.Connection[i];\r\n Items.AddObject(ListConnectString(Connection, Options.ShowShortCuts, Options.ShowConnectGroup), Connection);\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvBaseDBLogonDialog.FillDatabaseComboBox;\r\nvar\r\n Items: TStringList;\r\n IDynControlItems: IJvDynControlItems;\r\nbegin\r\n if Supports(DatabaseComboBox, IJvDynControlItems, IDynControlItems) then\r\n begin\r\n Items := TStringList.Create;\r\n try\r\n Items.Sorted := True;\r\n FillDatabaseComboBoxValues (Items);\r\n if Assigned(FOnFillDatabaseList) then\r\n FOnFillDatabaseList(Items);\r\n IDynControlItems.ControlItems.Assign(Items);\r\n finally\r\n Items.Free;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvBaseDBLogonDialog.FillDatabaseComboBoxValues(Items: TStrings);\r\nvar i : Integer;\r\n Connection: TJvBaseConnectionInfo;\r\nbegin\r\n if Options.AddConnectionValuesToComboBox then\r\n for i := 0 to ConnectionList.Count - 1 do\r\n begin\r\n Connection := ConnectionList.Connection[i];\r\n if Connection.Database <> '' then\r\n if Items.IndexOf(Connection.Database) < 0 then\r\n Items.Add(Connection.Database);\r\n end;\r\nend;\r\n\r\nprocedure TJvBaseDBLogonDialog.FillDatabaseTreeView;\r\nvar\r\n i, j: Integer;\r\n Node: TTreeNode;\r\n Found: Boolean;\r\n s: string;\r\n Connection: TJvBaseConnectionInfo;\r\n Items: TTreeNodes;\r\nbegin\r\n Items := IDatabaseTreeView.ControlItems;\r\n Items.Clear;\r\n for i := 0 to ConnectionList.Count - 1 do\r\n begin\r\n Connection := ConnectionList.Connection[i];\r\n s := ListConnectString(Connection, Options.ShowShortCuts, Options.ShowConnectGroup);\r\n Found := False;\r\n for j := 0 to Items.Count - 1 do\r\n if Items[j].Level = 0 then\r\n begin\r\n Node := Items[j];\r\n if Node.Text = Connection.DatabaseGroupIdentifier then\r\n begin\r\n Node := Items.AddChild(Node, s);\r\n Node.Data := Connection;\r\n Found := True;\r\n break;\r\n end;\r\n end;\r\n if not Found then\r\n begin\r\n Node := Items.AddChild(nil, Connection.DatabaseGroupIdentifier);\r\n Node := Items.AddChild(Node, s);\r\n Node.Data := Connection;\r\n end;\r\n end;\r\n IDatabaseTreeView.ControlSortItems;\r\nend;\r\n\r\nprocedure TJvBaseDBLogonDialog.FillGroupTreeView;\r\nvar\r\n i, j, k, g: Integer;\r\n Items: TTreeNodes;\r\n Node: TTreeNode;\r\n Node2: TTreeNode;\r\n Found: Boolean;\r\n s: string;\r\n gr: string;\r\n GroupList: TStringList;\r\n Connection: TJvBaseConnectionInfo;\r\nbegin\r\n if not Assigned(IGroupTreeView) then\r\n Exit;\r\n Items := IGroupTreeView.ControlItems;\r\n Items.Clear;\r\n for i := 0 to ConnectionList.Count - 1 do\r\n begin\r\n Connection := ConnectionList.Connection[i];\r\n GroupList := TStringList.Create;\r\n try\r\n {$IFDEF DELPHI2009_UP}\r\n GroupList.StrictDelimiter:=true;\r\n {$ENDIF DELPHI2009_UP}\r\n GroupList.Duplicates := dupIgnore;\r\n GroupList.Sorted := True;\r\n if (Pos(';',Connection.Group) >= 1) and (Pos(',',Connection.Group) < 1)then\r\n GroupList.Delimiter := ';'\r\n else\r\n GroupList.Delimiter := ',';\r\n GroupList.DelimitedText := Connection.Group;\r\n GroupList.Delimiter := ',';\r\n Connection.Group := GroupList.CommaText;\r\n if GroupList.CommaText = '' then\r\n GroupList.CommaText := RsGroupNameUndefined;\r\n\r\n for g := 0 to GroupList.Count - 1 do\r\n begin\r\n Gr := GroupList[g];\r\n if gr = '' then\r\n continue;\r\n s := ListConnectString(Connection, Options.ShowShortcuts, False);\r\n\r\n Found := False;\r\n for j := 0 to Items.Count - 1 do\r\n if Items[j].Level = 0 then\r\n begin\r\n Node := Items[j];\r\n if Node.Text = Gr then\r\n if GroupByDatabase then\r\n begin\r\n for k := 0 to Node.Count - 1 do\r\n begin\r\n Node2 := Node.Item[k];\r\n if Node2.Text = Connection.DatabaseGroupIdentifier then\r\n begin\r\n Node := Items.AddChild(Node2, s);\r\n Node.Data := Connection;\r\n Found := True;\r\n break;\r\n end;\r\n end;\r\n if not Found then\r\n begin\r\n Node := Items.AddChild(Node, Connection.DatabaseGroupIdentifier);\r\n Node := Items.AddChild(Node, s);\r\n Node.Data := Connection;\r\n Found := True;\r\n end;\r\n Break;\r\n end\r\n else\r\n if GroupByUser then\r\n begin\r\n for k := 0 to Node.Count - 1 do\r\n begin\r\n Node2 := Node.Item[k];\r\n if Node2.Text = Connection.Username then\r\n begin\r\n Node := Items.AddChild(Node2, s);\r\n Node.Data := Connection;\r\n Found := True;\r\n break;\r\n end;\r\n end;\r\n if not Found then\r\n begin\r\n Node := Items.AddChild(Node, Connection.Username);\r\n Node := Items.AddChild(Node, s);\r\n //Node.SelectedIndex := i;\r\n Node.Data := Connection;\r\n Found := True;\r\n end;\r\n Break;\r\n end\r\n else\r\n begin\r\n Node := Items.AddChild(Node, s);\r\n Node.Data := Connection;\r\n Found := True;\r\n break;\r\n end; {*** IF Node.Text = UpperCase(Databases[i]) THEN ***}\r\n end; {*** IF Items[i].Level = 0 THEN ***}\r\n if not Found then\r\n begin\r\n Node := Items.AddChild(nil, Gr);\r\n if GroupByDataBase then\r\n Node := Items.AddChild(Node, Connection.DatabaseGroupIdentifier)\r\n else\r\n if GroupByUser then\r\n Node := Items.AddChild(Node, Connection.Username);\r\n Node := Items.AddChild(Node, s);\r\n Node.Data := Connection;\r\n end;\r\n end;\r\n finally\r\n GroupList.Free;\r\n end;\r\n end;\r\n IGroupTreeView.ControlSortItems;\r\nend;\r\n\r\nprocedure TJvBaseDBLogonDialog.FillShortCutList(Items: TStringList);\r\nvar\r\n I: Integer;\r\nbegin\r\n Items.Add('');\r\n for I := 1 to 10 do\r\n Items.Add(ShortCutToText(ShortCut($30 + Ord('0') + (I mod 10), [ssCtrl])));\r\n for I := 1 to 10 do\r\n Items.Add(ShortCutToText(ShortCut($30 + Ord('0') + (I mod 10), [ssCtrl, ssShift])));\r\n for I := 1 to 10 do\r\n Items.Add(ShortCutToText(ShortCut($30 + Ord('0') + (I mod 10), [ssAlt, ssShift])));\r\n for I := 1 to 10 do\r\n Items.Add(ShortCutToText(ShortCut($30 + Ord('0') + (I mod 10), [ssAlt, ssCtrl])));\r\n for I := 1 to 10 do\r\n Items.Add(ShortCutToText(ShortCut($30 + Ord('0') + (I mod 10), [ssAlt, ssCtrl, ssShift])));\r\nend;\r\n\r\nprocedure TJvBaseDBLogonDialog.FormClose(Sender: TObject; var Action:TCloseAction);\r\nbegin\r\n if DBDialog.ModalResult = mrOk then\r\n begin\r\n if Options.SaveLastConnect then\r\n TransferConnectionInfoFromDialog(ConnectionList.LastConnect)\r\n else\r\n ConnectionList.LastConnect.Clear;\r\n StoreSettings;\r\n end;\r\n ClearControlInterfaceObjects;\r\n Action := caFree;\r\nend;\r\n\r\nprocedure TJvBaseDBLogonDialog.FormKeyDown(Sender: TObject; var Key: Word;\r\n Shift: TShiftState);\r\nvar\r\n i: Integer;\r\n Connection: TJvBaseConnectionInfo;\r\n sKey: Word;\r\n sShift: TShiftState;\r\nbegin\r\n for i := 0 to ConnectionList.Count - 1 do\r\n begin\r\n ShortCutToKey(ConnectionList.Connection[i].Shortcut, sKey, sShift);\r\n if (sKey = Key) and (sShift = Shift) then\r\n begin\r\n Connection := ConnectionList.Connection[i];\r\n TransferConnectionInfoToDialog(Connection);\r\n ConnectToSession;\r\n Exit;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvBaseDBLogonDialog.FormShow(Sender: TObject);\r\nbegin\r\n LoadSettings;\r\n ResizeAllControls;\r\n ClearFormControls;\r\n FillAllConnectionLists;\r\n TransferSessionDataToDialog;\r\n if Options.SaveLastConnect then\r\n begin\r\n if (ConnectionList.LastConnect.SearchName = CurrentConnectionInfo.SearchName) then\r\n ConnectionList.LastConnect.Password := CurrentConnectionInfo.Password;\r\n if ((DialogUserName = '') or\r\n (ConnectionList.LastConnect.SearchName = CurrentConnectionInfo.SearchName)) then\r\n TransferConnectionInfoToDialog(ConnectionList.LastConnect);\r\n end;\r\n ValidateConnectBtnEnabled;\r\nend;\r\n\r\nfunction TJvBaseDBLogonDialog.GetActivePage: TJvDBLogonDialogActivePage;\r\nbegin\r\n if IConnectionListPageControlTab.ControlTabIndex = 1 then\r\n Result := ldapUserTree\r\n else\r\n if IConnectionListPageControlTab.ControlTabIndex = 2 then\r\n Result := ldapDatabaseTree\r\n else\r\n if IConnectionListPageControlTab.ControlTabIndex = 3 then\r\n Result := ldapGroupTree\r\n else\r\n Result := ldapConnectList;\r\nend;\r\n\r\nfunction TJvBaseDBLogonDialog.GetCurrentDialogListConnectionInfo: TJvBaseConnectionInfo;\r\nbegin\r\n Result := nil;\r\n case ActivePage of\r\n ldapUserTree:\r\n if Assigned(IUserTreeView.ControlGetSelected) and\r\n (IUserTreeView.ControlGetSelected.Level > 0) then\r\n Result := IUserTreeView.ControlGetSelected.Data;\r\n ldapDatabaseTree:\r\n if Assigned(IDatabaseTreeView.ControlGetSelected) and\r\n (IDatabaseTreeView.ControlGetSelected.Level > 0) then\r\n Result := IDatabaseTreeView.ControlGetSelected.Data;\r\n ldapGroupTree:\r\n if Assigned(IGroupTreeView) and\r\n Assigned(IGroupTreeView.ControlGetSelected) and\r\n (IGroupTreeView.ControlGetSelected.Level > 0) then\r\n Result := IGroupTreeView.ControlGetSelected.Data;\r\n ldapConnectList:\r\n if (IConnectListListBoxItems.ControlItems.Count > 0) and\r\n (IConnectListListBoxData.ControlValue >= 0) and\r\n (IConnectListListBoxData.ControlValue <= IConnectListListBoxItems.ControlItems.Count - 1) then\r\n Result :=\r\n TJvBaseConnectionInfo(IConnectListListBoxItems.ControlItems.Objects[IConnectListListBoxData.ControlValue]);\r\n end;\r\nend;\r\n\r\nclass function TJvBaseDBLogonDialog.GetDBLogonConnectionListClass: TJvBaseConnectionListClass;\r\nbegin\r\n Result := TJvBaseConnectionList;\r\nend;\r\n\r\nclass function TJvBaseDBLogonDialog.GetDBLogonDialogOptionsClass: TJvBaseDBLogonDialogOptionsClass;\r\nbegin\r\n Result := TJvBaseDBLogonDialogOptions;\r\nend;\r\n\r\nfunction TJvBaseDBLogonDialog.GetDialogDatabase: string;\r\nbegin\r\n if Assigned(IDatabaseComboBoxData) then\r\n Result := IDatabaseComboBoxData.ControlValue\r\n else\r\n Result := '';\r\nend;\r\n\r\nfunction TJvBaseDBLogonDialog.GetDialogPassword: string;\r\nbegin\r\n if Assigned(IPasswordEditData) then\r\n Result := IPasswordEditData.ControlValue\r\n else\r\n Result := '';\r\nend;\r\n\r\nfunction TJvBaseDBLogonDialog.GetDialogUserName: string;\r\nbegin\r\n if Assigned(IUserNameEditData) then\r\n Result := IUserNameEditData.ControlValue\r\n else\r\n Result := '';\r\nend;\r\n\r\nprocedure TJvBaseDBLogonDialog.GetFromListBtnClick(Sender: TObject);\r\nbegin\r\n TransferConnectionInfoToDialog(CurrentDialogListConnectionInfo);\r\n ValidateConnectBtnEnabled;\r\nend;\r\n\r\nfunction TJvBaseDBLogonDialog.GetGroupByDatabase: Boolean;\r\nbegin\r\n Result := FGroupByDatabase;\r\nend;\r\n\r\nfunction TJvBaseDBLogonDialog.GetGroupByUser: Boolean;\r\nbegin\r\n Result := fGroupByUser;\r\nend;\r\n\r\nprocedure TJvBaseDBLogonDialog.GroupByDatabaseCheckBoxClick(Sender: TObject);\r\nbegin\r\n if Assigned(IGroupByDatabaseCheckBox) then\r\n GroupByDatabase := IGroupByDatabaseCheckBox.ControlState = cbChecked;\r\nend;\r\n\r\nprocedure TJvBaseDBLogonDialog.GroupByUserCheckBoxClick(Sender: TObject);\r\nbegin\r\n if Assigned(IGroupByUserCheckBox) then\r\n GroupByUser := IGroupByUserCheckBox.ControlState = cbChecked;\r\nend;\r\n\r\nfunction TJvBaseDBLogonDialog.IsConnectAllowed: Boolean;\r\nbegin\r\n Result:= CurrentConnectionInfo.IsConnectAllowed(Options.AllowNullPasswords);\r\nend;\r\n\r\nfunction TJvBaseDBLogonDialog.ListConnectString(Connection: TJvBaseConnectionInfo; ShowShortCut, ShowConnectGroup:\r\n Boolean): string;\r\nvar\r\n s: string;\r\nbegin\r\n if Not Assigned(Connection) then\r\n Exit;\r\n s := Connection.ConnectString;\r\n if ShowShortCut then\r\n if Connection.ShortCutText <> '' then\r\n Result := Result + ' (' + Connection.ShortCutText + ')';\r\n if ShowConnectGroup then\r\n if Connection.Group <> '' then\r\n Result := Result + ' - ' + Connection.Group;\r\n Result := s;\r\nend;\r\n\r\nprocedure TJvBaseDBLogonDialog.LoadSettings;\r\nbegin\r\n ConnectionList.SavePasswords := SavePasswords;\r\n ConnectionList.LoadProperties;\r\n if Options.ShowSavePasswords then\r\n if ConnectionList.SavePasswords then\r\n ISavePasswordsCheckBox.ControlState := cbChecked\r\n else\r\n ISavePasswordsCheckBox.ControlState := cbUnChecked;\r\n if Assigned(IGroupByDatabaseCheckBox) then\r\n if ConnectionList.GroupByDatabase then\r\n IGroupByDatabaseCheckBox.ControlState := cbChecked\r\n else\r\n IGroupByDatabaseCheckBox.ControlState := cbUnChecked;\r\n if Assigned(IGroupByUserCheckBox) then\r\n if ConnectionList.GroupByUser then\r\n IGroupByUserCheckBox.ControlState := cbChecked\r\n else\r\n IGroupByUserCheckBox.ControlState := cbUnChecked;\r\n ActivePage := ConnectionList.ActivePage;\r\nend;\r\n\r\nprocedure TJvBaseDBLogonDialog.OnExportConnectionList(Sender: TObject);\r\nvar\r\n Savedialog: TSaveDialog;\r\n TmpAppStorage: TJvCustomAppMemoryFileStorage;\r\n FileName: string;\r\n Extention: string;\r\n TmpConnectionList: TJvBaseConnectionList;\r\nbegin\r\n TmpAppStorage := nil;\r\n Savedialog := TSaveDialog.Create(Self);\r\n TmpConnectionList := GetDBLogonConnectionListClass.Create(Self);\r\n try\r\n TmpConnectionList.CopyContents(ConnectionList, True);\r\n SaveDialog.Filter := RsConnectionListExportImportFilter;\r\n SaveDialog.Name := 'SaveDialog';\r\n SaveDialog.DefaultExt := 'xml';\r\n SaveDialog.Options := [ofOverwritePrompt, ofHideReadOnly, ofPathMustExist, ofEnableSizing];\r\n if Savedialog.Execute then\r\n begin\r\n FileName := SaveDialog.FileName;\r\n Extention := ExtractFileExt(Filename);\r\n if UpperCase(extention) = '.INI' then\r\n begin\r\n TmpAppStorage := TJvAppIniFileStorage.Create(Self);\r\n // TJvAppIniFileStorage(TmpAppStorage).Section := 'Export/Import';\r\n end\r\n else\r\n begin\r\n TmpAppStorage := TJvAppXMLFileStorage.Create(Self);\r\n TJvAppXMLFileStorage(TMPAppStorage).StorageOptions.WhiteSpaceReplacement := '_';\r\n end;\r\n TmpAppStorage.FileName := Filename;\r\n TmpAppStorage.Location := flCustom;\r\n TmpConnectionList.AppStorage := TmpAppStorage;\r\n TmpConnectionList.AppStoragePath := ConnectionList.AppStoragePath;\r\n TmpConnectionList.SavePasswords := False;\r\n TmpConnectionList.StoreProperties;\r\n TmpAppStorage.Flush;\r\n end;\r\n finally\r\n if Assigned(TmpAppStorage) then\r\n FreeAndNil(TmpAppStorage);\r\n FreeAndNil(SaveDialog);\r\n FreeAndNIl(TmpConnectionList);\r\n end;\r\nend;\r\n\r\nprocedure TJvBaseDBLogonDialog.OnImportConnectionList(Sender: TObject);\r\nvar\r\n OpenDialog: TOpenDialog;\r\n TmpAppStorage: TJvCustomAppMemoryFileStorage;\r\n FileName: string;\r\n Extention: string;\r\n TmpConnectionList: TJvBaseConnectionList;\r\n ClearBefore: Boolean;\r\n Buttons: array[0..2] of string;\r\n Results: array[0..2] of Integer;\r\nbegin\r\n TmpAppStorage := nil;\r\n OpenDialog := TOpenDialog.Create(Self);\r\n TmpConnectionList := GetDBLogonConnectionListClass.Create(Self);\r\n try\r\n OpenDialog.Filter := RsConnectionListExportImportFilter;\r\n OpenDialog.Name := 'OpenDialog';\r\n OpenDialog.DefaultExt := 'xml';\r\n OpenDialog.Options := [ofHideReadOnly, ofExtensionDifferent, ofPathMustExist, ofFileMustExist, ofEnableSizing];\r\n if OpenDialog.Execute then\r\n begin\r\n FileName := OpenDialog.FileName;\r\n Extention := ExtractFileExt(Filename);\r\n if UpperCase(extention) = '.INI' then\r\n begin\r\n TmpAppStorage := TJvAppIniFileStorage.Create(Self);\r\n end\r\n else\r\n begin\r\n TmpAppStorage := TJvAppXMLFileStorage.Create(Self);\r\n TJvAppXMLFileStorage(TMPAppStorage).StorageOptions.WhiteSpaceReplacement := '_';\r\n end;\r\n TmpAppStorage.FileName := Filename;\r\n TmpAppStorage.Location := flCustom;\r\n TmpConnectionList.AppStorage := TmpAppStorage;\r\n TmpConnectionList.AppStoragePath := ConnectionList.AppStoragePath;\r\n TmpConnectionList.LoadProperties;\r\n if TmpConnectionList.Count <= 0 then\r\n begin\r\n JvDSADialogs.MessageDlg(RsNoConnectionEntriesFound, mtError, [mbok], 0, dckScreen,\r\n 0, mbDefault, mbDefault, mbDefault, DynControlEngine);\r\n exit;\r\n end;\r\n ClearBefore := True;\r\n if ConnectionList.Count > 0 then\r\n begin\r\n Buttons[0] := RsConnectionListImportAppend;\r\n Buttons[1] := RsConnectionListImportOverwrite;\r\n Buttons[2] := RsButtonCancelCaption;\r\n Results[0] := Integer(mrYes);\r\n Results[1] := Integer(mrNo);\r\n Results[2] := Integer(mrCancel);\r\n case JvDSADialogs.MessageDlgEx(RsConnectionListImportAppendOverwriteExistingEntries,\r\n mtConfirmation, Buttons, Results, 0, dckScreen, 0,\r\n 0, 2, -1, DynControlEngine) of\r\n mrYes:\r\n ClearBefore := False;\r\n mrNo:\r\n ClearBefore := True;\r\n else\r\n Exit;\r\n end;\r\n end;\r\n ConnectionList.CopyContents(TmpConnectionList, ClearBefore);\r\n FillAllConnectionLists\r\n end;\r\n finally\r\n if Assigned(TmpAppStorage) then\r\n FreeAndNil(TmpAppStorage);\r\n FreeAndNil(OpenDialog);\r\n FreeAndNIl(TmpConnectionList);\r\n end;\r\nend;\r\n\r\nprocedure TJvBaseDBLogonDialog.PasswordDialog_AfterTransferPasswordFromSession(var Password: string);\r\nvar\r\n Connection: TJvBaseConnectionInfo;\r\nbegin\r\n Connection := TJvBaseConnectionInfo.Create(nil);\r\n try\r\n Connection.Password := Password;\r\n if Assigned(AfterTransferSessionDataToConnectionInfo) then\r\n AfterTransferSessionDataToConnectionInfo(Connection);\r\n Password := Connection.Password;\r\n finally\r\n Connection.Free;\r\n end;\r\nend;\r\n\r\nprocedure TJvBaseDBLogonDialog.PasswordDialog_BeforeTransferPasswordToSession(var Password: string);\r\nvar\r\n Connection: TJvBaseConnectionInfo;\r\nbegin\r\n Connection := TJvBaseConnectionInfo.Create(nil);\r\n try\r\n Connection.Password := Password;\r\n if Assigned(BeforeTransferConnectionInfoToSessionData) then\r\n BeforeTransferConnectionInfoToSessionData(Connection);\r\n Password := Connection.Password;\r\n finally\r\n Connection.Free;\r\n end;\r\nend;\r\n\r\nprocedure TJvBaseDBLogonDialog.RearrangeEditPanel;\r\nbegin\r\n SetEditPanelsVisibility;\r\n RearrangeEditPanelControlsByTaborder;\r\n SetPanelHeight(EditConnectionPanel);\r\nend;\r\n\r\nprocedure TJvBaseDBLogonDialog.RearrangeEditPanelControlsByTaborder;\r\nbegin\r\n SetEditPanelsTabOrder;\r\n RearrangePanelControlsByTaborder(LeftBottomPanel);\r\n RearrangePanelControlsByTaborder(EditConnectionPanel);\r\nend;\r\n\r\nprocedure TJvBaseDBLogonDialog.RearrangePanelControlsByTaborder(iPanel: TWinControl);\r\nvar\r\n i: Integer;\r\n p: Integer;\r\n t: Integer;\r\n Ctrl: TWinControl;\r\nbegin\r\n t := 0;\r\n p := 0;\r\n while p < iPanel.ControlCount do\r\n begin\r\n for I := 0 to iPanel.ControlCount-1 do\r\n begin\r\n if not (iPanel.Controls[i] is TWinControl) then\r\n Continue;\r\n Ctrl := TWinControl(iPanel.Controls[i]);\r\n if not Ctrl.Visible then\r\n Continue;\r\n if Ctrl.TabOrder = p then\r\n begin\r\n Ctrl.Top := t;\r\n t := Ctrl.Top+Ctrl.Height+1;\r\n break;\r\n end;\r\n end;\r\n Inc(p);\r\n end;\r\nend;\r\n\r\nprocedure TJvBaseDBLogonDialog.RemoveFromListBtnClick(Sender: TObject);\r\nvar\r\n Index: Integer;\r\n Connection: TJvBaseConnectionInfo;\r\nbegin\r\n Connection := CurrentDialogListConnectionInfo;\r\n if Assigned(Connection) then\r\n begin\r\n Index := ConnectionList.Items.IndexOfObject(Connection);\r\n if (Index >= 0) and\r\n (Index < ConnectionList.Count) then\r\n begin\r\n ConnectionList.Items.delete(Index);\r\n FillAllConnectionLists;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvBaseDBLogonDialog.ResizeAllControls;\r\nbegin\r\n RearrangeEditPanel;\r\n ResizeFormControls;\r\n ResizeDialogClientHeight;\r\nend;\r\n\r\nprocedure TJvBaseDBLogonDialog.ResizeDialogClientHeight;\r\nvar\r\n m : Integer;\r\nbegin\r\n m := CalculatePanelHeight(LeftPanel)+10;\r\n if m > LeftPanel.Height then\r\n if m + ButtonPanel.Height > DBDialog.ClientHeight then\r\n begin\r\n DBDialog.ClientHeight := m + ButtonPanel.Height;\r\n DBDialog.Refresh;\r\n end;\r\nend;\r\n\r\nprocedure TJvBaseDBLogonDialog.ResizeFormControls;\r\nbegin\r\n SetPanelHeight(LeftBottomPanel);\r\n CancelBtn.Left := DBDialog.ClientWidth - CancelBtn.Width - 10;\r\n ConnectBtn.Left := CancelBtn.Left - ConnectBtn.Width - 5;\r\n AdditionalBtn.Left := 10;\r\n SetPanelHeight(ButtonPanel);\r\nend;\r\n\r\nfunction TJvBaseDBLogonDialog.SavePasswords: Boolean;\r\nbegin\r\n if not Options.SavePasswords then\r\n Result := False\r\n else\r\n if Options.ShowSavePasswords then\r\n Result := ISavePasswordsCheckBox.ControlState = cbChecked\r\n else\r\n Result := True;\r\nend;\r\n\r\nprocedure TJvBaseDBLogonDialog.SetActivePage(const Value: TJvDBLogonDialogActivePage);\r\nbegin\r\n case Value of\r\n ldapUserTree:\r\n IConnectionListPageControlTab.ControlTabIndex := 1;\r\n ldapDatabaseTree:\r\n IConnectionListPageControlTab.ControlTabIndex := 2;\r\n ldapGroupTree:\r\n IConnectionListPageControlTab.ControlTabIndex := 3;\r\n else\r\n IConnectionListPageControlTab.ControlTabIndex := 0;\r\n end;\r\nend;\r\n\r\nprocedure TJvBaseDBLogonDialog.SetAppStorage(Value: TJvCustomAppStorage);\r\nbegin\r\n if Value <> AppStorage then\r\n ConnectionList.AppStorage := Value;\r\n inherited SetAppStorage(Value);\r\nend;\r\n\r\nprocedure TJvBaseDBLogonDialog.SetAppStoragePath(Value: string);\r\nbegin\r\n if Value <> AppStoragePath then\r\n ConnectionList.AppStoragePath := Value;\r\n inherited SetAppStoragePath(Value);\r\nend;\r\n\r\nprocedure TJvBaseDBLogonDialog.SetButtonState;\r\nbegin\r\n if not Assigned(DBDialog) then\r\n Exit;\r\n GetFromListBtn.Enabled := Assigned(CurrentDialogListConnectionInfo);\r\n RemoveFromListBtn.Enabled := GetFromListBtn.Enabled;\r\nend;\r\n\r\nprocedure TJvBaseDBLogonDialog.SetConnectionToTop(const SearchName: string);\r\nvar\r\n p: Integer;\r\nbegin\r\n p := Connectionlist.IndexOf(SearchName);\r\n if p >= 0 then\r\n ConnectionList.Items.Move(p, 0);\r\nend;\r\n\r\nprocedure TJvBaseDBLogonDialog.SetDialogDatabase(const Value: string);\r\nbegin\r\n if Assigned(IDatabaseComboBoxData) then\r\n IDatabaseComboBoxData.ControlValue := Value;\r\nend;\r\n\r\nprocedure TJvBaseDBLogonDialog.SetDialogPassword(const Value: string);\r\nbegin\r\n if Assigned(IPasswordEditData) then\r\n IPasswordEditData.ControlValue := Value;\r\nend;\r\n\r\nprocedure TJvBaseDBLogonDialog.SetDialogUserName(const Value: string);\r\nbegin\r\n if Assigned(IUserNameEditData) then\r\n IUserNameEditData.ControlValue := Value;\r\nend;\r\n\r\nprocedure TJvBaseDBLogonDialog.SetEditPanelsTabOrder;\r\nbegin\r\n if Assigned(UsernamePanel) then\r\n UsernamePanel.TabOrder := 0;\r\n if Assigned(PasswordPanel) then\r\n PasswordPanel.TabOrder := 1;\r\n if Assigned(DataBasePanel) then\r\n DataBasePanel.TabOrder := 2;\r\nend;\r\n\r\nprocedure TJvBaseDBLogonDialog.SetEditPanelsVisibility;\r\nbegin\r\n SetPanelVisible(UsernamePanel, CurrentConnectionInfo.UsernameEnabled);\r\n SetPanelVisible(PasswordPanel, CurrentConnectionInfo.PasswordEnabled);\r\n SetPanelVisible(DataBasePanel, CurrentConnectionInfo.DatabaseEnabled);\r\n SetPanelVisible(AliasPanel, CurrentConnectionInfo.AliasEnabled and Options.ShowAlias);\r\nend;\r\n\r\nprocedure TJvBaseDBLogonDialog.SetGroupByDatabase(Value: Boolean);\r\nvar\r\n Change: Boolean;\r\nbegin\r\n Change := Value <> FGroupByDatabase;\r\n if Change then\r\n begin\r\n if Assigned(IGroupByDatabaseCheckBox) then\r\n if Value then\r\n IGroupByDatabaseCheckBox.ControlSetState(cbChecked)\r\n else\r\n IGroupByDatabaseCheckBox.ControlSetState(cbUnChecked);\r\n if Assigned(IGroupByUserCheckBox) then\r\n if Value and GroupByUser then\r\n IGroupByUserCheckBox.ControlSetState(cbUnChecked);\r\n end;\r\n FGroupByDatabase := Value;\r\n if Change then\r\n FillGroupTreeView;\r\nend;\r\n\r\nprocedure TJvBaseDBLogonDialog.SetGroupByUser(Value: Boolean);\r\nvar\r\n Change: Boolean;\r\nbegin\r\n Change := Value <> fGroupByUser;\r\n if Change then\r\n begin\r\n if Assigned(IGroupByUserCheckBox) then\r\n if Value then\r\n IGroupByUserCheckBox.ControlSetState(cbChecked)\r\n else\r\n IGroupByUserCheckBox.ControlSetState(cbUnChecked);\r\n if Assigned(IGroupByDatabaseCheckBox) then\r\n if Value and GroupByDatabase then\r\n IGroupByDatabaseCheckBox.ControlSetState(cbUnChecked);\r\n end;\r\n fGroupByUser := Value;\r\n if Change then\r\n FillGroupTreeView;\r\nend;\r\n\r\nprocedure TJvBaseDBLogonDialog.SetOptions(const Value: TJvBaseDBLogonDialogOptions);\r\nbegin\r\n FOptions.Assign(Value);\r\nend;\r\n\r\nprocedure TJvBaseDBLogonDialog.SetPanelHeight(iPanel: TWinControl);\r\nbegin\r\n if not Assigned(iPanel) then\r\n Exit;\r\n iPanel.Height := CalculatePanelHeight(iPanel);\r\nend;\r\n\r\nprocedure TJvBaseDBLogonDialog.SetPanelVisible(iPanel: TWinControl; iVisible: Boolean);\r\nbegin\r\n if not Assigned(iPanel) or (iPanel.Visible = iVisible) then\r\n Exit;\r\n iPanel.Visible := iVisible;\r\nend;\r\n\r\nprocedure TJvBaseDBLogonDialog.SetSession(const Value: TComponent);\r\nbegin\r\n inherited SetSession(Value);\r\n TransferSessionDataToDialog;\r\nend;\r\n\r\nprocedure TJvBaseDBLogonDialog.StoreSettings;\r\nbegin\r\n ConnectionList.GroupByDatabase := Assigned(IGroupByDatabaseCheckBox) and\r\n (IGroupByDatabaseCheckBox.ControlState = cbChecked);\r\n ConnectionList.GroupByUser := Assigned(IGroupByUserCheckBox) and\r\n (IGroupByUserCheckBox.ControlState = cbChecked);\r\n ConnectionList.ActivePage := ActivePage;\r\n ConnectionList.SavePasswords := SavePasswords;\r\n ConnectionList.StoreProperties;\r\nend;\r\n\r\nprocedure TJvBaseDBLogonDialog.TransferConnectionInfoFromDialog(ConnectionInfo: TJvBaseConnectionInfo);\r\nbegin\r\n if Assigned(ConnectionInfo) and Assigned(DBDialog) then\r\n begin\r\n if ConnectionInfo.UsernameEnabled then\r\n if Options.UsernameCaseSensitive then\r\n ConnectionInfo.Username := DialogUserName\r\n else\r\n ConnectionInfo.Username := UpperCase(DialogUserName)\r\n else\r\n ConnectionInfo.Username := '';\r\n if ConnectionInfo.PasswordEnabled then\r\n ConnectionInfo.Password := EncryptPassword(DialogPassword)\r\n else\r\n ConnectionInfo.Password := '';\r\n if ConnectionInfo.DatabaseEnabled then\r\n if Options.DatabasenameCaseSensitive then\r\n ConnectionInfo.Database := DialogDatabase\r\n else\r\n ConnectionInfo.Database := UpperCase(DialogDatabase)\r\n else\r\n ConnectionInfo.Database := '';\r\n if Options.ShowAlias and Assigned(IAliasEditData) and ConnectionInfo.AliasEnabled then\r\n ConnectionInfo.Alias := IAliasEditData.ControlValue;\r\n if Options.ShowConnectGroup and Assigned(IConnectGroupComboBoxData) then\r\n ConnectionInfo.Group := IConnectGroupComboBoxData.ControlValue;\r\n if Options.ShowColors and Assigned(IColorComboBox) then\r\n ConnectionInfo.Color := IColorComboBox.ControlSelectedColor;\r\n if Options.ShowShortcuts and Assigned(IShortCutComboBoxData) then\r\n ConnectionInfo.ShortCutText := IShortCutComboBoxData.ControlValue;\r\n end;\r\nend;\r\n\r\nprocedure TJvBaseDBLogonDialog.TransferConnectionInfoToDialog(ConnectionInfo: TJvBaseConnectionInfo);\r\nbegin\r\n if Assigned(ConnectionInfo) and Assigned(DBDialog) then\r\n begin\r\n DialogUserName := ConnectionInfo.Username;\r\n if SavePasswords then\r\n DialogPassword := DecryptPassword(ConnectionInfo.Password);\r\n DialogDatabase := ConnectionInfo.Database;\r\n if Options.ShowAlias and Assigned(IAliasEditData) then\r\n IAliasEditData.ControlValue := ConnectionInfo.Alias;\r\n if Options.ShowConnectGroup and Assigned(IConnectGroupComboBoxData) then\r\n IConnectGroupComboBoxData.ControlValue := ConnectionInfo.Group;\r\n if Options.ShowShortcuts and Assigned(IShortCutComboBoxData) then\r\n IShortCutComboBoxData.ControlValue := ConnectionInfo.ShortCutText;\r\n if Options.ShowColors and Assigned(IColorComboBox) then\r\n IColorComboBox.ControlSelectedColor := ConnectionInfo.Color;\r\n if (ConnectionInfo.Username = '') and Assigned(UserNameEdit) and UserNameEdit.CanFocus then\r\n UserNameEdit.SetFocus\r\n else\r\n if (ConnectionInfo.Password = '') and Assigned(PasswordEdit) and PasswordEdit.CanFocus then\r\n PasswordEdit.SetFocus\r\n else\r\n if (ConnectionInfo.Database = '') and Assigned(DatabaseComboBox) and DatabaseComboBox.CanFocus then\r\n DatabaseComboBox.SetFocus;\r\n end;\r\nend;\r\n\r\nprocedure TJvBaseDBLogonDialog.TransferSessionDataFromConnectionInfo(ConnectionInfo: TJvBaseConnectionInfo);\r\nbegin\r\nend;\r\n\r\nprocedure TJvBaseDBLogonDialog.TransferSessionDataFromDialog;\r\nvar\r\n tmpConnectionInfo: TJvBaseConnectionInfo;\r\nbegin\r\n if not Assigned(DBDialog) then\r\n Exit;\r\n tmpConnectionInfo := ConnectionList.CreateConnection;\r\n try\r\n TransferConnectionInfoFromDialog(tmpConnectionInfo);\r\n tmpConnectionInfo.Password := DecryptPassword(tmpConnectionInfo.Password);\r\n CurrentConnectionInfo.Assign(tmpConnectionInfo);\r\n if Assigned(BeforeTransferConnectionInfoToSessionData) then\r\n BeforeTransferConnectionInfoToSessionData(tmpConnectionInfo);\r\n TransferSessionDataFromConnectionInfo(tmpConnectionInfo);\r\n finally\r\n tmpConnectionInfo.Free;\r\n end;\r\nend;\r\n\r\nprocedure TJvBaseDBLogonDialog.TransferSessionDataToConnectionInfo(ConnectionInfo: TJvBaseConnectionInfo);\r\nbegin\r\nend;\r\n\r\nprocedure TJvBaseDBLogonDialog.TransferSessionDataToDialog;\r\nvar\r\n tmpConnectionInfo: TJvBaseConnectionInfo;\r\nbegin\r\n if not Assigned(DBDialog) then\r\n Exit;\r\n tmpConnectionInfo := ConnectionList.CreateConnection;\r\n try\r\n TransferSessionDataToConnectionInfo(tmpConnectionInfo);\r\n tmpConnectionInfo.Password := EncryptPassword(tmpConnectionInfo.Password);\r\n if Assigned(AfterTransferSessionDataToConnectionInfo) then\r\n AfterTransferSessionDataToConnectionInfo(tmpConnectionInfo);\r\n TransferConnectionInfoToDialog(tmpConnectionInfo);\r\n CurrentConnectionInfo.Assign(tmpConnectionInfo);\r\n ValidateConnectBtnEnabled;\r\n finally\r\n tmpConnectionInfo.Free;\r\n end;\r\nend;\r\n\r\nprocedure TJvBaseDBLogonDialog.ValidateConnectBtnEnabled;\r\nbegin\r\n ConnectBtn.Enabled := IsConnectAllowed;\r\n// AddToListBtn.Enabled := ConnectBtn.Enabled;\r\nend;\r\n\r\n//=== { TJvBaseDBLogonDialogOptions } ========================================\r\n\r\nconstructor TJvBaseDBLogonDialogOptions.Create;\r\nbegin\r\n inherited Create;\r\n FShowShortcuts := True;\r\n FShowConnectionsExport := True;\r\n FSavePasswords := True;\r\n FShowColors := False;\r\n FAddConnectionValuesToComboBox := True;\r\n FAllowNullPasswords := False;\r\n FSaveLastConnect := True;\r\n FSetLastConnectToTop := True;\r\n FShowConnectGroup := True;\r\n FShowSavePasswords := False;\r\n FUsernameCaseSensitive := False;\r\n FDatabasenameCaseSensitive := False;\r\n FPasswordChar := '*';\r\n FAllowPasswordChange := False;\r\n FPasswordDialogOptions := TJvBaseDBPasswordDialogOptions.Create;\r\n FShowAlias := false;\r\nend;\r\n\r\ndestructor TJvBaseDBLogonDialogOptions.Destroy;\r\nbegin\r\n FreeAndNil(FPasswordDialogOptions);\r\n inherited Destroy;\r\nend;\r\n\r\n//=== { TJvBaseDBOracleLogonDialogOptions } ==================================\r\n\r\nconstructor TJvBaseDBOracleLogonDialogOptions.Create;\r\nbegin\r\n inherited Create;\r\n FShowConnectAs := True;\r\nend;\r\n\r\nprocedure TJvBaseDBOracleLogonDialog.ClearControlInterfaceObjects;\r\nbegin\r\n inherited ClearControlInterfaceObjects;\r\n IConnectAsComboBoxData := nil;\r\nend;\r\n\r\nprocedure TJvBaseDBOracleLogonDialog.ClearFormControls;\r\nbegin\r\n inherited ClearFormControls;\r\n if Assigned(IConnectAsComboBoxData) then\r\n IConnectAsComboBoxData.ControlValue := 'NORMAL';\r\nend;\r\n\r\nprocedure TJvBaseDBOracleLogonDialog.CreateAdditionalConnectDialogControls(AOwner: TComponent; AParentControl:\r\n TWinControl);\r\nvar\r\n Items: TStringList;\r\n IDynControlComboBox: IJvDynControlComboBox;\r\n IDynControlItems: IJvDynControlItems;\r\nbegin\r\n CreateAdditionalConnectDialogEditPanel(AOwner, AParentControl, 'ConnectAs', RsConnectAs, jctComboBox, ConnectAsPanel, ConnectAsComboBox, IConnectAsComboBoxData, DefaultOnEditChange);\r\n Items := tStringList.Create;\r\n try\r\n Items.Add('NORMAL');\r\n Items.Add('SYSDBA');\r\n Items.Add('SYSOPER');\r\n Items.Add('SYSASM');\r\n if Supports(ConnectAsComboBox, IJvDynControlItems, IDynControlItems) then\r\n IDynControlItems.ControlItems.Assign(Items);\r\n if Supports(ConnectAsComboBox, IJvDynControlComboBox, IDynControlComboBox) then\r\n IDynControlComboBox.ControlSetNewEntriesAllowed(False);\r\n finally\r\n Items.Free;\r\n end;\r\n SetPanelHeight(ConnectAsPanel);\r\n ConnectAsPanel.Visible := Options.ShowConnectAs;\r\nend;\r\n\r\nprocedure TJvBaseDBOracleLogonDialog.CreateFormControls(AForm: TForm);\r\nbegin\r\n inherited CreateFormControls(AForm);\r\nend;\r\n\r\nfunction TJvBaseDBOracleLogonDialog.GetCurrentConnectionInfo: TJvBaseOracleConnectionInfo;\r\nbegin\r\n Result := TJvBaseOracleConnectionInfo(inherited CurrentConnectionInfo);\r\nend;\r\n\r\nclass function TJvBaseDBOracleLogonDialog.GetDBLogonConnectionListClass: TJvBaseConnectionListClass;\r\nbegin\r\n Result := TJvBaseOracleConnectionList;\r\nend;\r\n\r\nclass function TJvBaseDBOracleLogonDialog.GetDBLogonDialogOptionsClass: TJvBaseDBLogonDialogOptionsClass;\r\nbegin\r\n Result := TJvBaseDBOracleLogonDialogOptions;\r\nend;\r\n\r\nfunction TJvBaseDBOracleLogonDialog.GetDialogConnectAs: string;\r\nbegin\r\n if Assigned(IConnectAsComboBoxData) then\r\n Result := UpperCase(IConnectAsComboBoxData.ControlValue)\r\n else\r\n Result := '';\r\nend;\r\n\r\nfunction TJvBaseDBOracleLogonDialog.GetOptions: TJvBaseDBOracleLogonDialogOptions;\r\nbegin\r\n Result := TJvBaseDBOracleLogonDialogOptions(inherited Options);\r\nend;\r\n\r\nprocedure TJvBaseDBOracleLogonDialog.SetDialogConnectAs(const Value: string);\r\nbegin\r\n if Assigned(IConnectAsComboBoxData) then\r\n IConnectAsComboBoxData.ControlValue := Value;\r\nend;\r\n\r\nprocedure TJvBaseDBOracleLogonDialog.SetEditPanelsTabOrder;\r\nbegin\r\n inherited SetEditPanelsTabOrder;\r\n if Assigned(ConnectAsPanel) then\r\n ConnectAsPanel.TabOrder := 3;\r\nend;\r\n\r\nprocedure TJvBaseDBOracleLogonDialog.SetEditPanelsVisibility;\r\nbegin\r\n inherited SetEditPanelsVisibility;\r\n SetPanelVisible(ConnectAsPanel, CurrentConnectionInfo.ConnectAsEnabled and Options.ShowConnectAs);\r\nend;\r\n\r\nprocedure TJvBaseDBOracleLogonDialog.SetOptions(const Value: TJvBaseDBOracleLogonDialogOptions);\r\nbegin\r\n (inherited Options).Assign(Value);\r\nend;\r\n\r\nprocedure TJvBaseDBOracleLogonDialog.TransferConnectionInfoFromDialog(ConnectionInfo: TJvBaseConnectionInfo);\r\nbegin\r\n inherited TransferConnectionInfoFromDialog(ConnectionInfo);\r\n if Assigned(ConnectionInfo) and (ConnectionInfo is TJvBaseOracleConnectionInfo) and Assigned(IConnectAsComboBoxData) then\r\n begin\r\n if Options.ShowConnectAs then\r\n TJvBaseOracleConnectionInfo(ConnectionInfo).ConnectAs := IConnectAsComboBoxData.ControlValue;\r\n end;\r\nend;\r\n\r\nprocedure TJvBaseDBOracleLogonDialog.TransferConnectionInfoToDialog(ConnectionInfo: TJvBaseConnectionInfo);\r\nbegin\r\n inherited TransferConnectionInfoToDialog(ConnectionInfo);\r\n if Assigned(ConnectionInfo) and (ConnectionInfo is TJvBaseOracleConnectionInfo) and Assigned(IConnectAsComboBoxData) then\r\n begin\r\n if Options.ShowConnectAs then\r\n IConnectAsComboBoxData.ControlValue := TJvBaseOracleConnectionInfo(ConnectionInfo).ConnectAs;\r\n end;\r\nend;\r\n\r\nconstructor TJvBaseConnectionInfo.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FColor := cDefaultColorComboBoxColor;\r\nend;\r\n\r\n//=== { TJvBaseConnectionInfo } ==============================================\r\n\r\ndestructor TJvBaseConnectionInfo.Destroy;\r\nbegin\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJvBaseConnectionInfo.IsConnectAllowed(AllowNullPasswords: Boolean): Boolean;\r\nbegin\r\n if AllowNullPasswords then\r\n Result := (not UsernameEnabled or (UserName <> '')) and (not DatabaseEnabled or (Database <> ''))\r\n else\r\n Result := (not UsernameEnabled or (UserName <> '')) and (not PasswordEnabled or (Password <> '')) and (not DatabaseEnabled or (Database <> ''));\r\nend;\r\n\r\nfunction TJvBaseConnectionInfo.ConnectString: string;\r\nbegin\r\n if UsernameEnabled then\r\n Result := TranslateUserName(Username)\r\n else\r\n Result := '';\r\n if PasswordEnabled and (Password <> '') then\r\n Result := Result + '/*****';\r\n if AliasEnabled and (Alias <> '') then\r\n Result := Result + '@' + Alias\r\n else\r\n if DatabaseEnabled and (Database <> '') then\r\n Result := Result + '@' + TranslateDatabaseName(Database);\r\n if ShortCutText <> '' then\r\n Result := Result + ' ('+ShortCutText+')';\r\nend;\r\n\r\nfunction TJvBaseConnectionInfo.DatabaseGroupIdentifier: string;\r\nbegin\r\n if AliasEnabled and (Alias <> '') then\r\n Result := Alias\r\n else\r\n Result := TranslateDatabaseName(Database);\r\nend;\r\n\r\nfunction TJvBaseConnectionInfo.GetDatabaseEnabled: Boolean;\r\nbegin\r\n Result := True;\r\nend;\r\n\r\nfunction TJvBaseConnectionInfo.GetAliasEnabled: Boolean;\r\nbegin\r\n Result := DatabaseEnabled;\r\nend;\r\n\r\nfunction TJvBaseConnectionInfo.GetUsernameEnabled: Boolean;\r\nbegin\r\n Result := True;\r\nend;\r\n\r\nfunction TJvBaseConnectionInfo.GetPasswordEnabled: Boolean;\r\nbegin\r\n Result := True;\r\nend;\r\n\r\nfunction TJvBaseConnectionInfo.GetShortCutText: string;\r\nbegin\r\n Result := ShortCutToText(ShortCut);\r\nend;\r\n\r\nfunction TJvBaseConnectionInfo.SearchName: String;\r\nbegin\r\n Result := TranslateUserName(UserName)+'@'+TranslateDatabaseName(Database);\r\nend;\r\n\r\nprocedure TJvBaseConnectionInfo.SetDatabase(Value: string);\r\nbegin\r\n FDatabase := Trim(Value);\r\nend;\r\n\r\nprocedure TJvBaseConnectionInfo.SetGroup(const Value: string);\r\nbegin\r\n FGroup := Trim(Value);\r\nend;\r\n\r\nprocedure TJvBaseConnectionInfo.SetSavePassword(const Value: Boolean);\r\nconst\r\n cPassword = 'Password';\r\nbegin\r\n FSavePassword := Value;\r\n if Value then\r\n begin\r\n if IgnoreProperties.IndexOf(cPassword) >= 0 then\r\n IgnoreProperties.Delete(IgnoreProperties.IndexOf(cPassword))\r\n end\r\n else\r\n if IgnoreProperties.IndexOf(cPassword) < 0 then\r\n IgnoreProperties.Add(cPassword);\r\nend;\r\n\r\nprocedure TJvBaseConnectionInfo.SetShortCutText(const Value: string);\r\nbegin\r\n try\r\n ShortCut := TextToShortCut(Value);\r\n except\r\n ShortCut := 0;\r\n end;\r\nend;\r\n\r\nprocedure TJvBaseConnectionInfo.SetUsername(Value: string);\r\nbegin\r\n fUserName := Trim(Value);\r\nend;\r\n\r\nfunction TJvBaseConnectionInfo.TranslateUserName(iName: string): string;\r\n// CharIsUpper and CharIsLower are not allowed to use. Only basic ASCII characters are supported for database name generation without \"\r\nconst UpperChars : set of ansichar = ['A','B','C','D','E','F','G','H','I','J','K','L','M','N','O','P','Q','R','S','T','U','V','W','X','Y','Z',\r\n '0','1','2','3','4','5','6','7','8','9','_','$','#','@'];\r\nconst LowerChars : set of ansichar = ['a','b','c','d','e','f','g','h','i','j','k','l','m','n','o','p','q','r','s','t','u','v','w','x','y','z'];\r\nvar i : Integer;\r\n s : String;\r\nbegin\r\n s := trim(iName);\r\n if UseTranslateUserName and (s <> '') then\r\n if (s[1] <> '\"') or (s[length(s)] <> '\"') then\r\n for i := 1 to length(s) do\r\n begin\r\n if CharInSet(s[i], LowerChars) then\r\n s[i] := ToUpper(s[i])\r\n else if not CharInSet(s[i], UpperChars) then\r\n begin\r\n Result := trim(iName);\r\n Exit;\r\n end;\r\n end;\r\n Result := s;\r\nend;\r\n\r\nfunction TJvBaseConnectionInfo.TranslateDatabaseName(iName: string): string;\r\n// CharIsUpper and CharIsLower are not allowed to use. Only basic ASCII characters are supported for database name generation without \"\r\nconst UpperChars : set of ansichar = ['A','B','C','D','E','F','G','H','I','J','K','L','M','N','O','P','Q','R','S','T','U','V','W','X','Y','Z',\r\n '0','1','2','3','4','5','6','7','8','9','_','$','#','@','.'];\r\nconst LowerChars : set of ansichar = ['a','b','c','d','e','f','g','h','i','j','k','l','m','n','o','p','q','r','s','t','u','v','w','x','y','z'];\r\nvar i : Integer;\r\n s : String;\r\nbegin\r\n s := trim(iName);\r\n if UseTranslateDatabaseName and (s <> '') then\r\n if (s[1] <> '\"') or (s[length(s)] <> '\"') then\r\n for i := 1 to length(s) do\r\n begin\r\n if CharInSet(s[i], LowerChars) then\r\n s[i] := ToUpper(s[i])\r\n else if not CharInSet(s[i], UpperChars) then\r\n begin\r\n Result := trim(iName);\r\n Exit;\r\n end;\r\n end;\r\n Result := s;\r\nend;\r\n\r\nfunction TJvBaseConnectionInfo.UseTranslateUserName: Boolean;\r\nbegin\r\n Result := True;\r\nend;\r\n\r\nfunction TJvBaseConnectionInfo.UseTranslateDatabaseName: Boolean;\r\nbegin\r\n Result := True;\r\nend;\r\n\r\n//=== { TJvBaseOracleConnectionInfo } ========================================\r\n\r\nconstructor TJvBaseOracleConnectionInfo.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FConnectAs := 'NORMAL';\r\nend;\r\n\r\nfunction TJvBaseOracleConnectionInfo.ConnectString: string;\r\nbegin\r\n Result := inherited ConnectString;\r\n if ConnectAsEnabled and (ConnectAs <> 'NORMAL') then\r\n Result := Result + ' [' + ConnectAs + ']';\r\nend;\r\n\r\nfunction TJvBaseOracleConnectionInfo.GetConnectAsEnabled: Boolean;\r\nbegin\r\n Result := True;\r\nend;\r\n\r\nprocedure TJvBaseOracleConnectionInfo.SetConnectAs(const Value: string);\r\nbegin\r\n FConnectAs := Trim(UpperCase(Value));\r\nend;\r\n\r\n//=== { TJvBaseConnectionList } ==============================================\r\n\r\nconstructor TJvBaseConnectionList.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FLastConnect := TJvBaseConnectionInfo(CreateObject);\r\n FLastConnect.SavePassword := False;\r\n ItemName := RsConnectionListItemName;\r\nend;\r\n\r\ndestructor TJvBaseConnectionList.Destroy;\r\nbegin\r\n FreeAndNil(FLastConnect);\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvBaseConnectionList.AddConnection(ConnectionInfo: TJvBaseConnectionInfo);\r\nvar\r\n p, p2, i: Integer;\r\nbegin\r\n p := Items.IndexOf(ConnectionInfo.SearchName);\r\n while p <> -1 do\r\n begin\r\n Items.Delete(p);\r\n p := Items.IndexOf(ConnectionInfo.SearchName);\r\n end;\r\n p2 := Items.AddObject(ConnectionInfo.SearchName, ConnectionInfo);\r\n if ConnectionInfo.ShortCut > 0 then\r\n for i := 0 to Count - 1 do\r\n if i <> p2 then\r\n if Connection[i].ShortCut = ConnectionInfo.ShortCut then\r\n Connection[i].ShortCut := 0;\r\n Items.Move(p2, 0);\r\nend;\r\n\r\nprocedure TJvBaseConnectionList.CopyContents(iConnectionList: TJvBaseConnectionList; iClearBefore: Boolean);\r\nvar\r\n i: Integer;\r\n Connection: TJvBaseConnectionInfo;\r\nbegin\r\n if iClearBefore then\r\n Clear;\r\n if not Assigned(iConnectionList) then\r\n Exit;\r\n for i := 0 to iConnectionList.Items.Count - 1 do\r\n begin\r\n Connection := CreateConnection;\r\n Connection.Assign(iConnectionList.Connection[i]);\r\n AddConnection(Connection);\r\n end;\r\nend;\r\n\r\nfunction TJvBaseConnectionList.CreateConnection: TJvBaseConnectionInfo;\r\nbegin\r\n Result := TJvBaseConnectionInfo(CreateObject);\r\nend;\r\n\r\nfunction TJvBaseConnectionList.CreateObject: TPersistent;\r\nbegin\r\n Result := TJvBaseConnectionInfo.Create(Self);\r\nend;\r\n\r\nfunction TJvBaseConnectionList.GetConnection(I: Longint): TJvBaseConnectionInfo;\r\nbegin\r\n if (i >= 0) and (i < Count) then\r\n Result := TJvBaseConnectionInfo(Objects[i])\r\n else\r\n Result := nil;\r\nend;\r\n\r\nprocedure TJvBaseConnectionList.LoadData;\r\nvar\r\n i: Integer;\r\nbegin\r\n inherited LoadData;\r\n for i := 0 to Items.Count - 1 do\r\n Items[i] := Connection[i].SearchName;\r\nend;\r\n\r\nprocedure TJvBaseConnectionList.SetLastConnect(const Value: TJvBaseConnectionInfo);\r\nbegin\r\n FLastConnect := Value;\r\nend;\r\n\r\nprocedure TJvBaseConnectionList.SetSavePasswords(const Value: Boolean);\r\nvar\r\n i: Integer;\r\nbegin\r\n FSavePasswords := Value;\r\n for i := 0 to Count - 1 do\r\n Connection[i].SavePassword := Value;\r\nend;\r\n\r\nfunction TJvBaseOracleConnectionList.CreateObject: TPersistent;\r\nbegin\r\n Result := TJvBaseOracleConnectionInfo.Create(Self);\r\n TJvBaseOracleConnectionInfo(Result).SavePassword := SavePasswords;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvBaseDBPasswordDialog.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvBaseDBPasswordDialog.pas, released on 2006-07-21\r\n\r\nThe Initial Developer of the Original Code is Jens Fudickar\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvBaseDBPasswordDialog.pas 13138 2011-10-26 23:17:50Z jfudickar $\r\n\r\nunit JvBaseDBPasswordDialog;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n{$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n{$ENDIF UNITVERSIONING}\r\n JvDynControlEngine,\r\n Classes, Forms, Controls,\r\n JvBaseDBDialog, JvDynControlEngineIntf;\r\n\r\ntype\r\n TJvPasswordDialogModifyPasswordEvent = procedure(var Password: string) of object;\r\n\r\n TJvBaseDBPasswordDialogOptions = class(TPersistent)\r\n private\r\n FAllowedPasswordCharacters: string;\r\n FCheckOldPassword: Boolean;\r\n FMinPasswordLength: Integer;\r\n public\r\n constructor Create; virtual;\r\n procedure Assign(Source: TPersistent); override;\r\n published\r\n property AllowedPasswordCharacters: string read FAllowedPasswordCharacters\r\n write FAllowedPasswordCharacters;\r\n property CheckOldPassword: Boolean read FCheckOldPassword write\r\n FCheckOldPassword default True;\r\n property MinPasswordLength: Integer read FMinPasswordLength write\r\n FMinPasswordLength default 4;\r\n end;\r\n\r\n TJvBaseDBPasswordDialog = class(TJvBaseDBDialog)\r\n private\r\n ButtonPanel: TWinControl;\r\n CancelBtn: TWinControl;\r\n ChangeBtn: TWinControl;\r\n FAfterTransferPasswordFromSession: TJvPasswordDialogModifyPasswordEvent;\r\n FBeforeTransferPasswordToSession: TJvPasswordDialogModifyPasswordEvent;\r\n FOptions: TJvBaseDBPasswordDialogOptions;\r\n INewPasswordEditData: IJvDynControlData;\r\n INewPasswordRetypeEditData: IJvDynControlData;\r\n IOldPasswordEditData: IJvDynControlData;\r\n NewPasswordEdit: TWinControl;\r\n NewPasswordRetypeEdit: TWinControl;\r\n OldPasswordEdit: TWinControl;\r\n procedure CancelBtnClick(Sender: TObject);\r\n procedure ChangeBtnClick(Sender: TObject);\r\n procedure FormClose(Sender: TObject; var Action: TCloseAction);\r\n procedure FormShow(Sender: TObject);\r\n function GetNewPassword: string;\r\n function GetNewPasswordRetype: string;\r\n function GetOldPassword: string;\r\n procedure ResizeFormControls;\r\n procedure SetOptions(const Value: TJvBaseDBPasswordDialogOptions);\r\n protected\r\n function ChangePasswordInSession(NewPassword: string): Boolean; virtual;\r\n function CheckAllowedCharacters(const NewPassword: string): Boolean;\r\n procedure ClearControlInterfaceObjects; virtual;\r\n procedure CreateFormControls(aForm: TForm); override;\r\n function GetPasswordFromSession: string; virtual;\r\n property NewPassword: string read GetNewPassword;\r\n property NewPasswordRetype: string read GetNewPasswordRetype;\r\n property OldPassword: string read GetOldPassword;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n function ChangePassword: Boolean;\r\n published\r\n property Options: TJvBaseDBPasswordDialogOptions read FOptions write SetOptions;\r\n property AfterTransferPasswordFromSession: TJvPasswordDialogModifyPasswordEvent\r\n read FAfterTransferPasswordFromSession write\r\n FAfterTransferPasswordFromSession;\r\n property BeforeTransferPasswordToSession: TJvPasswordDialogModifyPasswordEvent\r\n read FBeforeTransferPasswordToSession write\r\n FBeforeTransferPasswordToSession;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvBaseDBPasswordDialog.pas $';\r\n Revision: '$Revision: 13138 $';\r\n Date: '$Date: 2011-10-27 01:17:50 +0200 (jeu. 27 oct. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n SysUtils, Types, JvResources, JvDSADialogs,\r\n Dialogs;\r\n\r\n\r\nconstructor TJvBaseDBPasswordDialog.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FOptions := TJvBaseDBPasswordDialogOptions.Create();\r\nend;\r\n\r\ndestructor TJvBaseDBPasswordDialog.Destroy;\r\nbegin\r\n FreeAndNil(FOptions);\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvBaseDBPasswordDialog.CancelBtnClick(Sender: TObject);\r\nbegin\r\n DBDialog.ModalResult := mrCancel;\r\nend;\r\n\r\nprocedure TJvBaseDBPasswordDialog.ChangeBtnClick(Sender: TObject);\r\nbegin\r\n if not ChangeBtn.Enabled then\r\n Exit;\r\n if not ChangePassword then\r\n DBDialog.ModalResult := mrNone\r\n else\r\n DBDialog.ModalResult := mrOk;\r\nend;\r\n\r\nfunction TJvBaseDBPasswordDialog.ChangePassword: Boolean;\r\nvar\r\n SessionPassword: string;\r\nbegin\r\n Result := False;\r\n try\r\n if Options.CheckOldPassword then\r\n begin\r\n SessionPassword := GetPasswordFromSession;\r\n if Assigned(AfterTransferPasswordFromSession) then\r\n AfterTransferPasswordFromSession(SessionPassword);\r\n if not (OldPassword = SessionPassword) then\r\n begin\r\n JvDSADialogs.MessageDlg(RsOldPasswordsMismatch, mtError, [mbok], 0, dckScreen,\r\n 0, mbDefault, mbDefault, mbDefault, DynControlEngine);\r\n exit;\r\n end;\r\n end;\r\n if not (NewPassword = NewPasswordRetype) then\r\n begin\r\n JvDSADialogs.MessageDlg(RsPasswordsMismatch, mtError, [mbok], 0, dckScreen,\r\n 0, mbDefault, mbDefault, mbDefault, DynControlEngine);\r\n Exit;\r\n end;\r\n if (Length(NewPassword) < Options.MinPasswordLength) then\r\n begin\r\n JvDSADialogs.MessageDlg(Format(RsPasswordLengthToShort, [Options.MinPasswordLength]), mtError, [mbok], 0,\r\n dckScreen,\r\n 0, mbDefault, mbDefault, mbDefault, DynControlEngine);\r\n exit;\r\n end;\r\n if not CheckAllowedCharacters(NewPassword) then\r\n begin\r\n JvDSADialogs.MessageDlg(Format(RsPasswordNotAllowedCharacters, [Options.MinPasswordLength]), mtError, [mbok], 0,\r\n dckScreen,\r\n 0, mbDefault, mbDefault, mbDefault, DynControlEngine);\r\n exit;\r\n end;\r\n\r\n if Assigned(BeforeTransferPasswordToSession) then\r\n BeforeTransferPasswordToSession(SessionPassword);\r\n Result := ChangePasswordInSession(NewPassword);\r\n if Result then\r\n JvDSADialogs.MessageDlg(RsPasswordChanged, mtInformation, [mbOK], 0, dckScreen,\r\n 0, mbDefault, mbDefault, mbDefault, DynControlEngine)\r\n else\r\n JvDSADialogs.MessageDlg(RsPasswordNotChanged, mtInformation, [mbOK], 0, dckScreen,\r\n 0, mbDefault, mbDefault, mbDefault, DynControlEngine);\r\n except\r\n on E: Exception do\r\n JvDSADialogs.MessageDlg(E.Message, mtError, [mbOK], 0, dckScreen,\r\n 0, mbDefault, mbDefault, mbDefault, DynControlEngine);\r\n end;\r\nend;\r\n\r\nfunction TJvBaseDBPasswordDialog.ChangePasswordInSession(NewPassword: string):\r\n Boolean;\r\nbegin\r\n Result := False;\r\nend;\r\n\r\nfunction TJvBaseDBPasswordDialog.CheckAllowedCharacters(const NewPassword:\r\n string): Boolean;\r\nvar\r\n I: Integer;\r\nbegin\r\n if Options.AllowedPasswordCharacters <> '' then\r\n begin\r\n Result := False;\r\n for I := 1 to Length(NewPassword) - 1 do\r\n if Pos(NewPassword[i], Options.AllowedPasswordCharacters) <= 0 then\r\n Exit;\r\n end;\r\n Result := True;\r\nend;\r\n\r\nprocedure TJvBaseDBPasswordDialog.ClearControlInterfaceObjects;\r\nbegin\r\n INewPasswordEditData := nil;\r\n INewPasswordRetypeEditData := nil;\r\n IOldPasswordEditData := nil;\r\nend;\r\n\r\nprocedure TJvBaseDBPasswordDialog.CreateFormControls(aForm: TForm);\r\nvar\r\n MainPanel: TWinControl;\r\n LabelControl: TControl;\r\n IDynControlLabel: IJvDynControlLabel;\r\n IDynControlBevelBorder: IJvDynControlBevelBorder;\r\n IDynControlEdit: IJvDynControlEdit;\r\nbegin\r\n\r\n aForm.Name := 'DBChangePasswordDialog';\r\n aForm.Left := 472;\r\n aForm.Top := 229;\r\n aForm.BorderIcons := [biSystemMenu, biMinimize, biMaximize, biHelp];\r\n aForm.BorderStyle := bsDialog;\r\n aForm.Caption := RsChangePassword;\r\n aForm.ClientHeight := 415;\r\n aForm.ClientWidth := 317;\r\n aForm.Position := poScreenCenter;\r\n aForm.OnClose := FormClose;\r\n aForm.OnShow := FormShow;\r\n\r\n ButtonPanel := DynControlEngine.CreatePanelControl(aForm, aForm, 'ButtonPanel', '', alBottom);\r\n ChangeBtn := DynControlEngine.CreateButton(AForm, ButtonPanel, 'ChangeBtn',\r\n RsChangeButtonCaption, '', ChangeBtnClick, True, False);\r\n ChangeBtn.Left := 60;\r\n ChangeBtn.Top := 4;\r\n ChangeBtn.Width := 90;\r\n ChangeBtn.Height := 25;\r\n CancelBtn := DynControlEngine.CreateButton(AForm, ButtonPanel, 'CancelBtn',\r\n RsButtonCancelCaption, '', CancelBtnClick, False, True);\r\n CancelBtn.Left := 460;\r\n CancelBtn.Top := 4;\r\n CancelBtn.Width := 90;\r\n CancelBtn.Height := 25;\r\n\r\n ButtonPanel.Height := CancelBtn.Height + 8;\r\n\r\n MainPanel := DynControlEngine.CreatePanelControl(aForm, aForm, 'MainPanel', '', alClient);\r\n MainPanel.TabOrder := 0;\r\n if Supports(MainPanel, IJvDynControlBevelBorder, IDynControlBevelBorder) then\r\n IDynControlBevelBorder.ControlSetBorderWidth(5);\r\n if Supports(MainPanel, IJvDynControlBevelBorder, IDynControlBevelBorder) then\r\n IDynControlBevelBorder.ControlSetBevelOuter(bvNone);\r\n\r\n if Options.CheckOldPassword then\r\n begin\r\n LabelControl := DynControlEngine.CreateLabelControl(aForm, MainPanel, 'OldPasswortLabel', RsOldPasswordLabel, nil);\r\n LabelControl.Align := alTop;\r\n OldPasswordEdit := DynControlEngine.CreateEditControl(aForm, MainPanel, 'OldPasswortEdit');\r\n OldPasswordEdit.Align := alTop;\r\n OldPasswordEdit.TabOrder := 0;\r\n Supports(OldPasswordEdit, IJvDynControlData, IOldPasswordEditData);\r\n IOldPasswordEditData.ControlValue := '';\r\n if Supports(OldPasswordEdit, IJvDynControlEdit, IDynControlEdit) then\r\n IDynControlEdit.ControlSetPasswordChar('*');\r\n if Supports(LabelControl, IJvDynControlLabel, IDynControlLabel) then\r\n IDynControlLabel.ControlSetFocusControl(OldPasswordEdit);\r\n end;\r\n LabelControl := DynControlEngine.CreateLabelControl(aForm, MainPanel, 'NewPasswortLabel', RsNewPasswordLabel, nil);\r\n LabelControl.Align := alTop;\r\n NewPasswordEdit := DynControlEngine.CreateEditControl(aForm, MainPanel, 'NewPasswortEdit');\r\n NewPasswordEdit.Align := alTop;\r\n NewPasswordEdit.TabOrder := 1;\r\n Supports(NewPasswordEdit, IJvDynControlData, INewPasswordEditData);\r\n INewPasswordEditData.ControlValue := '';\r\n if Supports(NewPasswordEdit, IJvDynControlEdit, IDynControlEdit) then\r\n IDynControlEdit.ControlSetPasswordChar('*');\r\n if Supports(LabelControl, IJvDynControlLabel, IDynControlLabel) then\r\n IDynControlLabel.ControlSetFocusControl(NewPasswordEdit);\r\n LabelControl := DynControlEngine.CreateLabelControl(aForm, MainPanel, 'NewPasswortLabelRetype',\r\n RsConfirmPasswordLabel, nil);\r\n LabelControl.Align := alTop;\r\n NewPasswordRetypeEdit := DynControlEngine.CreateEditControl(aForm, MainPanel, 'NewPasswortRetypeEdit');\r\n NewPasswordRetypeEdit.Align := alTop;\r\n NewPasswordRetypeEdit.TabOrder := 2;\r\n Supports(NewPasswordRetypeEdit, IJvDynControlData, INewPasswordRetypeEditData);\r\n INewPasswordRetypeEditData.ControlValue := '';\r\n if Supports(INewPasswordRetypeEditData, IJvDynControlEdit, IDynControlEdit) then\r\n IDynControlEdit.ControlSetPasswordChar('*');\r\n if Supports(LabelControl, IJvDynControlLabel, IDynControlLabel) then\r\n IDynControlLabel.ControlSetFocusControl(NewPasswordRetypeEdit);\r\nend;\r\n\r\nprocedure TJvBaseDBPasswordDialog.FormClose(Sender: TObject; var Action:\r\n TCloseAction);\r\nbegin\r\n ClearControlInterfaceObjects;\r\n Action := caFree;\r\nend;\r\n\r\nprocedure TJvBaseDBPasswordDialog.FormShow(Sender: TObject);\r\nbegin\r\n ResizeFormControls;\r\nend;\r\n\r\nfunction TJvBaseDBPasswordDialog.GetNewPassword: string;\r\nbegin\r\n Result := INewPasswordEditData.ControlValue;\r\nend;\r\n\r\nfunction TJvBaseDBPasswordDialog.GetNewPasswordRetype: string;\r\nbegin\r\n Result := INewPasswordRetypeEditData.ControlValue;\r\nend;\r\n\r\nfunction TJvBaseDBPasswordDialog.GetOldPassword: string;\r\nbegin\r\n if assigned(IOldPasswordEditData) then\r\n Result := IOldPasswordEditData.ControlValue\r\n else\r\n Result := '';\r\nend;\r\n\r\nfunction TJvBaseDBPasswordDialog.GetPasswordFromSession: string;\r\nbegin\r\n Result := '';\r\nend;\r\n\r\nprocedure TJvBaseDBPasswordDialog.ResizeFormControls;\r\nbegin\r\n if Assigned(DBDialog) then\r\n begin\r\n CancelBtn.Left := DBDialog.ClientWidth - CancelBtn.Width - 5;\r\n ChangeBtn.Left := CancelBtn.Left - ChangeBtn.Width - 5;\r\n DBDialog.ClientHeight := NewPasswordRetypeEdit.Top + NewPasswordRetypeEdit.Height + 2 + ButtonPanel.Height;\r\n end;\r\nend;\r\n\r\nprocedure TJvBaseDBPasswordDialog.SetOptions(const Value:\r\n TJvBaseDBPasswordDialogOptions);\r\nbegin\r\n FOptions.Assign(Value);\r\nend;\r\n\r\nconstructor TJvBaseDBPasswordDialogOptions.Create;\r\nbegin\r\n inherited Create;\r\n FCheckOldPassword := True;\r\n FMinPasswordLength := 4;\r\n FAllowedPasswordCharacters := 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz1234567890_#$';\r\nend;\r\n\r\nprocedure TJvBaseDBPasswordDialogOptions.Assign(Source: TPersistent);\r\nbegin\r\n if Source is TJvBaseDBPasswordDialogOptions then\r\n begin\r\n CheckOldPassword := TJvBaseDBPasswordDialogOptions(Source).CheckOldPassword;\r\n MinPasswordLength := TJvBaseDBPasswordDialogOptions(Source).MinPasswordLength;\r\n AllowedPasswordCharacters := TJvBaseDBPasswordDialogOptions(Source).AllowedPasswordCharacters;\r\n end\r\n else\r\n inherited Assign(Source);\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvBaseDBThreadedDataset.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvBaseDBThreadedDataset.PAS, released on 2002-05-26.\r\n\r\nThe Initial Developer of the Original Code is Jens Fudickar\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nDescription:\r\n Oracle Dataset with Threaded Functions\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvBaseDBThreadedDataset.pas 13138 2011-10-26 23:17:50Z jfudickar $\r\n\r\nunit JvBaseDBThreadedDataset;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n SysUtils, Classes, StdCtrls, Forms, Controls,\r\n DB,\r\n JvThread, JvThreadDialog, JvDynControlEngine;\r\n\r\ntype\r\n TJvThreadedDatasetOperation = (tdoOpen, tdoFetch, tdoLast, tdoRefresh, tdoNothing);\r\n TJvThreadedDatasetAction = (tdaOpen, tdaFetch, tdaNothing, tdaCancel);\r\n\r\n TJvThreadedDatasetFetchMode = (tdfmFetch, tdfmBreak, tdfmStop, tdfmNothing);\r\n\r\n TJvThreadedDatasetContinueCheckResult = (tdccrContinue, tdccrPause, tdccrStop, tdccrAll, tdccrCancel);\r\n\r\n TJvThreadedDatasetContinueAllowButton = (tdcaPause, tdcaStop, tdcaAll);\r\n TJvThreadedDatasetContinueAllowButtons = set of TJvThreadedDatasetContinueAllowButton;\r\n\r\n TJvBaseDatasetThreadHandler = class;\r\n\r\n TJvThreadedDatasetThreadEvent = procedure(DataSet: TDataSet;\r\n Operation: TJvThreadedDatasetOperation) of object;\r\n TJvThreadedDatasetThreadExceptionEvent = procedure(DataSet: TDataSet;\r\n Operation: TJvThreadedDatasetOperation; E: Exception) of object;\r\n\r\n\r\n TJvThreadedDatasetDialogOptions = class;\r\n TJvThreadedDatasetThreadOptions = class;\r\n\r\n IJvThreadedDatasetInterface = interface\r\n ['{220CC94D-AA41-4195-B90C-ECA24BAD3CDB}']\r\n procedure BreakExecution;\r\n procedure BringThreadDialogToFront;\r\n function CurrentFetchDuration: TDateTime;\r\n function CurrentOpenDuration: TDateTime;\r\n procedure DoInheritedInternalLast;\r\n procedure DoInheritedInternalRefresh;\r\n procedure DoInheritedSetActive(Active: Boolean);\r\n procedure DoInternalOpen;\r\n function IsThreadAllowed: Boolean;\r\n function ThreadIsActive: Boolean;\r\n procedure DoInheritedBeforeOpen;\r\n procedure DoInheritedAfterOpen;\r\n procedure DoInheritedBeforeRefresh;\r\n procedure DoInheritedAfterRefresh;\r\n procedure DoInheritedAfterScroll;\r\n function DoGetInheritedNextRecord : Boolean;\r\n function EofReached: Boolean;\r\n function ErrorException: Exception;\r\n function ErrorMessage: string;\r\n function GetAfterOpenFetch: TDataSetNotifyEvent;\r\n function GetAfterThreadExecution: TJvThreadedDatasetThreadEvent;\r\n function GetBeforeThreadExecution: TJvThreadedDatasetThreadEvent;\r\n function GetDatasetFetchAllRecords: Boolean;\r\n function GetDialogOptions: TJvThreadedDatasetDialogOptions;\r\n function GetOnThreadException: TJvThreadedDatasetThreadExceptionEvent;\r\n function GetThreadOptions: TJvThreadedDatasetThreadOptions;\r\n procedure SetAfterOpenFetch(const Value: TDataSetNotifyEvent);\r\n procedure SetAfterThreadExecution(const Value: TJvThreadedDatasetThreadEvent);\r\n procedure SetBeforeThreadExecution(const Value: TJvThreadedDatasetThreadEvent);\r\n procedure SetDatasetFetchAllRecords(const Value: Boolean);\r\n procedure SetDialogOptions(Value: TJvThreadedDatasetDialogOptions);\r\n procedure SetOnThreadException(const Value: TJvThreadedDatasetThreadExceptionEvent);\r\n procedure SetThreadOptions(const Value: TJvThreadedDatasetThreadOptions);\r\n property AfterThreadExecution: TJvThreadedDatasetThreadEvent read GetAfterThreadExecution write SetAfterThreadExecution;\r\n property BeforeThreadExecution: TJvThreadedDatasetThreadEvent read GetBeforeThreadExecution write\r\n SetBeforeThreadExecution;\r\n property OnThreadException: TJvThreadedDatasetThreadExceptionEvent read GetOnThreadException write SetOnThreadException;\r\n property AfterOpenFetch: TDataSetNotifyEvent read GetAfterOpenFetch write SetAfterOpenFetch;\r\n property DatasetFetchAllRecords: Boolean read GetDatasetFetchAllRecords write SetDatasetFetchAllRecords;\r\n property DialogOptions: TJvThreadedDatasetDialogOptions read GetDialogOptions write SetDialogOptions;\r\n property ThreadOptions: TJvThreadedDatasetThreadOptions read GetThreadOptions write SetThreadOptions;\r\n end;\r\n\r\n TJvThreadedDatasetDialogOptions = class(TJvCustomThreadDialogOptions)\r\n private\r\n FCaption: string;\r\n FDynControlEngine: TJvDynControlEngine;\r\n FEnableCancelButton: Boolean;\r\n FFormStyle: TFormStyle;\r\n FShowCancelButton: Boolean;\r\n FShowRowsLabel: Boolean;\r\n FShowTimeLabel: Boolean;\r\n procedure SetCaption(const Value: string);\r\n procedure SetDynControlEngine(const Value: TJvDynControlEngine);\r\n procedure SetEnableCancelButton(const Value: Boolean);\r\n procedure SetFormStyle(const Value: TFormStyle);\r\n procedure SetShowCancelButton(const Value: Boolean);\r\n procedure SetShowRowsLabel(const Value: Boolean);\r\n procedure SetShowTimeLabel(const Value: Boolean);\r\n public\r\n constructor Create(AOwner: TJvCustomThreadDialog); override;\r\n destructor Destroy; override;\r\n published\r\n property Caption: string read FCaption write SetCaption;\r\n property DynControlEngine: TJvDynControlEngine read FDynControlEngine write SetDynControlEngine;\r\n property EnableCancelButton: Boolean read FEnableCancelButton write SetEnableCancelButton default True;\r\n property FormStyle: TFormStyle read FFormStyle write SetFormStyle;\r\n property ShowCancelButton: Boolean read FShowCancelButton write SetShowCancelButton default True;\r\n property ShowRowsLabel: Boolean read FShowRowsLabel write SetShowRowsLabel default True;\r\n property ShowTimeLabel: Boolean read FShowTimeLabel write SetShowTimeLabel default True;\r\n end;\r\n\r\n TJvThreadedDatasetThreadOptions = class(TPersistent)\r\n private\r\n FLastInThread: Boolean;\r\n FOpenInThread: Boolean;\r\n FPriority: TThreadPriority;\r\n FRefreshInThread: Boolean;\r\n FShowExceptionMessage: Boolean;\r\n public\r\n constructor Create;\r\n published\r\n property LastInThread: Boolean read FLastInThread write FLastInThread default False;\r\n property OpenInThread: Boolean read FOpenInThread write FOpenInThread default False;\r\n property Priority: TThreadPriority read FPriority write FPriority default tpIdle;\r\n property RefreshInThread: Boolean read FRefreshInThread write FRefreshInThread default False;\r\n property ShowExceptionMessage: Boolean read FShowExceptionMessage write FShowExceptionMessage default True;\r\n end;\r\n\r\n TJvThreadedDatasetCapitalizeLabelOptions = class(TPersistent)\r\n private\r\n FAutoExecuteAfterOpen: Boolean;\r\n FTrimToFirstBlank: Boolean;\r\n public\r\n constructor Create; virtual;\r\n published\r\n property AutoExecuteAfterOpen: Boolean read FAutoExecuteAfterOpen write FAutoExecuteAfterOpen default False;\r\n property TrimToFirstBlank: Boolean read FTrimToFirstBlank write FTrimToFirstBlank default False;\r\n end;\r\n\r\n TJvBaseThreadedDatasetAllowedContinueRecordFetchOptions = class(TPersistent)\r\n private\r\n FAll: Boolean;\r\n FPause: Boolean;\r\n FCancel: Boolean;\r\n protected\r\n property Pause: Boolean read FPause write FPause default False;\r\n property Cancel: Boolean read FCancel write FCancel default False;\r\n property All: Boolean read FAll write FAll default False;\r\n public\r\n constructor Create; virtual;\r\n end;\r\n\r\n TJvBaseThreadedDatasetEnhancedOptions = class(TPersistent)\r\n private\r\n FAllowedContinueRecordFetchOptions: TJvBaseThreadedDatasetAllowedContinueRecordFetchOptions;\r\n FCapitalizeLabelOptions: TJvThreadedDatasetCapitalizeLabelOptions;\r\n FFetchRowsCheck: Integer;\r\n FFetchRowsFirst: Integer;\r\n FRefreshAsOpenClose: Boolean;\r\n FRefreshLastPosition: Boolean;\r\n procedure SetCapitalizeLabelOptions(const Value: TJvThreadedDatasetCapitalizeLabelOptions);\r\n procedure SetFetchRowsCheck(const Value: Integer);\r\n procedure SetFetchRowsFirst(const Value: Integer);\r\n procedure SetRefreshAsOpenClose(Value: Boolean);\r\n procedure SetRefreshLastPosition(const Value: Boolean);\r\n protected\r\n function CreateAllowedContinueRecordFetchOptions: TJvBaseThreadedDatasetAllowedContinueRecordFetchOptions; virtual;\r\n public\r\n constructor Create; virtual;\r\n destructor Destroy; override;\r\n published\r\n property AllowedContinueRecordFetchOptions: TJvBaseThreadedDatasetAllowedContinueRecordFetchOptions read\r\n FAllowedContinueRecordFetchOptions write FAllowedContinueRecordFetchOptions;\r\n property CapitalizeLabelOptions: TJvThreadedDatasetCapitalizeLabelOptions read FCapitalizeLabelOptions write\r\n SetCapitalizeLabelOptions;\r\n property FetchRowsCheck: Integer read FFetchRowsCheck write SetFetchRowsCheck default 2000;\r\n property FetchRowsFirst: Integer read FFetchRowsFirst write SetFetchRowsFirst default 1000;\r\n property RefreshAsOpenClose: Boolean read FRefreshAsOpenClose write SetRefreshAsOpenClose default False;\r\n property RefreshLastPosition: Boolean read FRefreshLastPosition write SetRefreshLastPosition default False;\r\n end;\r\n\r\n TJvDatasetThreadDialogForm = class(TJvDynControlEngineThreadDialogForm)\r\n private\r\n FRowsLabel: TControl;\r\n FTimeLabel: TControl;\r\n FRowsStaticText: TWinControl;\r\n FTimeStaticText: TWinControl;\r\n FCancelBtn: TButton;\r\n FCancelButtonPanel: TWinControl;\r\n FRowsPanel: TWinControl;\r\n FTimePanel: TWinControl;\r\n FDialogOptions: TJvThreadedDatasetDialogOptions;\r\n procedure CreateTextPanel(AOwner: TComponent; AParent: TWinControl; var Panel: TWinControl; var LabelCtrl: TControl;\r\n var StaticText: TWinControl; const BaseName: string);\r\n function GetConnectedDataset: TDataSet;\r\n function GetConnectedDatasetHandler: TJvBaseDatasetThreadHandler;\r\n function GetDialogOptions: TJvThreadedDatasetDialogOptions;\r\n procedure SetDialogOptions(const Value: TJvThreadedDatasetDialogOptions);\r\n protected\r\n procedure FillDialogData;\r\n procedure InitializeFormContents; override;\r\n procedure UpdateFormContents; override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n procedure CreateFormControls; override;\r\n procedure TransferDialogOptions; override;\r\n property ConnectedDataset: TDataSet read GetConnectedDataset;\r\n property ConnectedDatasetHandler: TJvBaseDatasetThreadHandler read GetConnectedDatasetHandler;\r\n published\r\n property DialogOptions: TJvThreadedDatasetDialogOptions read GetDialogOptions write SetDialogOptions;\r\n end;\r\n\r\n TJvDatasetThreadDialog = class(TJvCustomThreadDialog)\r\n private\r\n function GetDialogOptions: TJvThreadedDatasetDialogOptions;\r\n procedure SetDialogOptions(const Value: TJvThreadedDatasetDialogOptions);\r\n protected\r\n function CreateDialogOptions: TJvCustomThreadDialogOptions; override;\r\n public\r\n function CreateThreadDialogForm(ConnectedThread: TJvThread): TJvCustomThreadDialogForm; override;\r\n published\r\n property DialogOptions: TJvThreadedDatasetDialogOptions read GetDialogOptions write SetDialogOptions;\r\n end;\r\n\r\n TJvBaseDatasetThread = class(TJvThread)\r\n private\r\n FConnectedDataset: TDataSet;\r\n FConnectedDatasetInterface: IJvThreadedDatasetInterface;\r\n FConnectedDatasetThreadHandler: TJvBaseDatasetThreadHandler;\r\n procedure SetConnectedDataset(const Value: TDataSet);\r\n procedure SetConnectedDatasetThreadHandler(const Value: TJvBaseDatasetThreadHandler);\r\n protected\r\n procedure InternalAfterCreateDialogForm(DialogForm: TJvCustomThreadDialogForm); override;\r\n property ConnectedDatasetInterface: IJvThreadedDatasetInterface read FConnectedDatasetInterface;\r\n property ConnectedDataset: TDataSet read FConnectedDataset;\r\n public\r\n procedure CancelExecute; override;\r\n property ConnectedDatasetThreadHandler: TJvBaseDatasetThreadHandler read FConnectedDatasetThreadHandler write\r\n SetConnectedDatasetThreadHandler;\r\n end;\r\n\r\n TJvBaseDatasetThreadHandler = class(TComponent)\r\n private\r\n FAfterOpenFetch: TDataSetNotifyEvent;\r\n FAfterThreadExecution: TJvThreadedDatasetThreadEvent;\r\n FBeforeThreadExecution: TJvThreadedDatasetThreadEvent;\r\n FIntCurrentAction: TJvThreadedDatasetAction;\r\n FIntCurrentFetchDuration: TDateTime;\r\n FIntCurrentOpenDuration: TDateTime;\r\n FIntCurrentOperation: TJvThreadedDatasetOperation;\r\n FIntCurrentOperationStart: TDateTime;\r\n FCurrentRow: Integer;\r\n FDataset: TDataSet;\r\n FEnhancedOptions: TJvBaseThreadedDatasetEnhancedOptions;\r\n FErrorException: Exception;\r\n FErrorMessage: string;\r\n FExecuteThread: TJvBaseDatasetThread;\r\n FFetchMode: TJvThreadedDatasetFetchMode;\r\n FIntDatasetWasFiltered: Boolean;\r\n FIntDatasetFetchAllRecords: Boolean;\r\n FIntRowCheckEnabled: Boolean;\r\n FIThreadedDatasetInterface: IJvThreadedDatasetInterface;\r\n FLastRowChecked: Integer;\r\n FMaxRowChecked: Integer;\r\n FAfterOpenRecordPosition: Longint;\r\n FEofReached: Boolean;\r\n FOnThreadException: TJvThreadedDatasetThreadExceptionEvent;\r\n FOperationWasHandledInThread: Boolean;\r\n FSynchMessageDlgBtn: Word;\r\n FSynchMessageDlgMsg: string;\r\n FThreadDialog: TJvDatasetThreadDialog;\r\n FThreadOptions: TJvThreadedDatasetThreadOptions;\r\n IntThreadException: Exception;\r\n MessageDlgIsActive: Boolean;\r\n function GetCurrentAction: TJvThreadedDatasetAction;\r\n function GetCurrentFetchDuration: tDateTime;\r\n function GetCurrentOpenDuration: tDateTime;\r\n function GetIntCurrentAction: TJvThreadedDatasetAction;\r\n function GetIntCurrentFetchDuration: TDateTime;\r\n function GetIntCurrentOpenDuration: TDateTime;\r\n function GetCurrentOperation: TJvThreadedDatasetOperation;\r\n function GetIntCurrentOperation: TJvThreadedDatasetOperation;\r\n function GetCurrentOperationAction: string;\r\n function GetDatasetFetchAllRecords: Boolean;\r\n function GetDialogOptions: TJvThreadedDatasetDialogOptions;\r\n function GetFetchMode: TJvThreadedDatasetFetchMode;\r\n procedure HandleAfterOpenRefresh;\r\n procedure SetIntCurrentAction(const Value: TJvThreadedDatasetAction);\r\n procedure SetIntCurrentFetchDuration(const Value: TDateTime);\r\n procedure SetIntCurrentOpenDuration(const Value: TDateTime);\r\n procedure SetIntCurrentOperationStart(const Value: TDateTime);\r\n procedure SetDatasetFetchAllRecords(const Value: Boolean);\r\n procedure SetDialogOptions(Value: TJvThreadedDatasetDialogOptions);\r\n procedure SetEnhancedOptions(Value: TJvBaseThreadedDatasetEnhancedOptions);\r\n procedure SetEofReached(const Value: Boolean);\r\n procedure SetFetchMode(const Value: TJvThreadedDatasetFetchMode);\r\n procedure SetIntCurrentOperation(const Value: TJvThreadedDatasetOperation);\r\n procedure SetThreadOptions(const Value: TJvThreadedDatasetThreadOptions);\r\n procedure SynchAfterThreadExecution;\r\n procedure SynchBeforeThreadExecution;\r\n procedure SynchAfterOpenFetch;\r\n procedure SynchContinueFetchMessageDlg;\r\n procedure SynchErrorMessageDlg;\r\n procedure SynchOnThreadException;\r\n property IntCurrentOperationStart: TDateTime read FIntCurrentOperationStart write SetIntCurrentOperationStart;\r\n property DatasetFetchAllRecords: Boolean read GetDatasetFetchAllRecords write SetDatasetFetchAllRecords;\r\n property IntCurrentAction: TJvThreadedDatasetAction read GetIntCurrentAction write SetIntCurrentAction;\r\n property IntCurrentFetchDuration: TDateTime read GetIntCurrentFetchDuration write SetIntCurrentFetchDuration;\r\n property IntCurrentOpenDuration: TDateTime read GetIntCurrentOpenDuration write SetIntCurrentOpenDuration;\r\n property IntCurrentOperation: TJvThreadedDatasetOperation read GetIntCurrentOperation write SetIntCurrentOperation;\r\n property OperationWasHandledInThread: Boolean read FOperationWasHandledInThread\r\n write FOperationWasHandledInThread;\r\n protected\r\n function MaxRowCheckExceeded: Boolean;\r\n procedure BreakExecution;\r\n function CreateEnhancedOptions: TJvBaseThreadedDatasetEnhancedOptions; virtual;\r\n procedure DoThreadLast;\r\n procedure DoThreadOpen;\r\n procedure DoThreadRefresh;\r\n function ExecuteThreadIsActive: Boolean;\r\n procedure ExecuteThreadSynchronize(Method: TThreadMethod);\r\n procedure HandleAfterOpenRefreshThread;\r\n procedure HandleBeforeOpenRefresh;\r\n procedure InitOperation;\r\n procedure IntAfterThreadExecution(DataSet: TDataSet; Operation: TJvThreadedDatasetOperation);\r\n procedure IntAfterOpenFetch(DataSet: TDataSet);\r\n procedure IntBeforeThreadExecution(DataSet: TDataSet; Operation: TJvThreadedDatasetOperation);\r\n procedure IntOnThreadException(DataSet: TDataSet; Operation: TJvThreadedDatasetOperation; E: Exception);\r\n procedure IntSynchAfterOpen;\r\n procedure IntSynchAfterRefresh;\r\n procedure IntSynchBeforeOpen;\r\n procedure IntSynchBeforeRefresh;\r\n procedure MoveToRecordPositionAfterOpen;\r\n procedure SetError(const Msg: string = ''; Excep: Exception = nil);\r\n function SupportsBreakExecution: Boolean; virtual;\r\n procedure ThreadExecute(Sender: TObject; Params: Pointer);\r\n property ExecuteThread: TJvBaseDatasetThread read FExecuteThread;\r\n property FetchMode: TJvThreadedDatasetFetchMode read GetFetchMode write SetFetchMode;\r\n property IntRowCheckEnabled: Boolean read FIntRowCheckEnabled write FIntRowCheckEnabled;\r\n property IThreadedDatasetInterface: IJvThreadedDatasetInterface read FIThreadedDatasetInterface;\r\n property ThreadDialog: TJvDatasetThreadDialog read FThreadDialog;\r\n public\r\n constructor Create(AOwner: TComponent; ADataset: TDataSet); reintroduce; virtual;\r\n destructor Destroy; override;\r\n procedure AfterOpen; virtual;\r\n procedure AfterScroll; virtual;\r\n procedure AfterRefresh; virtual;\r\n procedure BeforeOpen; virtual;\r\n procedure BeforeRefresh; virtual;\r\n procedure BringDialogToFront;\r\n procedure CapitalizeDatasetLabels;\r\n function CheckContinueRecordFetch: TJvThreadedDatasetContinueCheckResult;\r\n function GetNextRecord: Boolean;\r\n procedure InternalLast; virtual;\r\n procedure InternalRefresh; virtual;\r\n procedure MoveTo(Position: Integer);\r\n procedure SetActive(Value: Boolean); virtual;\r\n function ThreadIsActive: Boolean;\r\n property CurrentAction: TJvThreadedDatasetAction read GetCurrentAction;\r\n property CurrentFetchDuration: tDateTime read GetCurrentFetchDuration;\r\n property CurrentOpenDuration: tDateTime read GetCurrentOpenDuration;\r\n property CurrentOperation: TJvThreadedDatasetOperation read GetCurrentOperation;\r\n property CurrentOperationAction: string read GetCurrentOperationAction;\r\n property CurrentRow: Integer read FCurrentRow;\r\n property Dataset: TDataSet read FDataset;\r\n property EofReached: Boolean read FEofReached write SetEofReached;\r\n property ErrorException: Exception read FErrorException;\r\n property ErrorMessage: string read FErrorMessage;\r\n published\r\n property AfterOpenFetch: TDataSetNotifyEvent read FAfterOpenFetch write FAfterOpenFetch;\r\n property DialogOptions: TJvThreadedDatasetDialogOptions read GetDialogOptions write SetDialogOptions;\r\n property EnhancedOptions: TJvBaseThreadedDatasetEnhancedOptions read FEnhancedOptions write SetEnhancedOptions;\r\n property ThreadOptions: TJvThreadedDatasetThreadOptions read FThreadOptions write SetThreadOptions;\r\n property AfterThreadExecution: TJvThreadedDatasetThreadEvent read FAfterThreadExecution write FAfterThreadExecution;\r\n property BeforeThreadExecution: TJvThreadedDatasetThreadEvent read FBeforeThreadExecution write FBeforeThreadExecution;\r\n property OnThreadException: TJvThreadedDatasetThreadExceptionEvent read FOnThreadException write FOnThreadException;\r\n end;\r\n\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvBaseDBThreadedDataset.pas $';\r\n Revision: '$Revision: 13138 $';\r\n Date: '$Date: 2011-10-27 01:17:50 +0200 (jeu. 27 oct. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n Dialogs,\r\n {$IFNDEF COMPILER12_UP}\r\n JvJCLUtils,\r\n {$ENDIF ~COMPILER12_UP}\r\n JvDynControlEngineIntf, JvDSADialogs, JvResources;\r\n\r\n//=== { TJvDatasetThreadDialog } =============================================\r\n\r\nfunction TJvDatasetThreadDialog.CreateDialogOptions: TJvCustomThreadDialogOptions;\r\nbegin\r\n Result := TJvThreadedDatasetDialogOptions.Create(Self);\r\nend;\r\n\r\nfunction TJvDatasetThreadDialog.CreateThreadDialogForm(ConnectedThread: TJvThread): TJvCustomThreadDialogForm;\r\nvar\r\n ThreadDialogForm: TJvDatasetThreadDialogForm;\r\nbegin\r\n if DialogOptions.ShowDialog then\r\n begin\r\n if Assigned(ConnectedThread.Owner) and (ConnectedThread.Owner is TWinControl) then\r\n ThreadDialogForm := TJvDatasetThreadDialogForm.CreateNewFormStyle(ConnectedThread,\r\n DialogOptions.FormStyle, TWinControl(ConnectedThread.Owner))\r\n else\r\n if Assigned(ConnectedThread.Owner) and Assigned(ConnectedThread.Owner.Owner) and\r\n (ConnectedThread.Owner.Owner is TWinControl) then\r\n ThreadDialogForm := TJvDatasetThreadDialogForm.CreateNewFormStyle(ConnectedThread,\r\n DialogOptions.FormStyle, TWinControl(ConnectedThread.Owner.Owner))\r\n else\r\n ThreadDialogForm := TJvDatasetThreadDialogForm.CreateNewFormStyle(ConnectedThread,\r\n DialogOptions.FormStyle);\r\n ThreadDialogForm.DialogOptions := DialogOptions;\r\n Result := ThreadDialogForm;\r\n end\r\n else\r\n Result := nil;\r\nend;\r\n\r\nfunction TJvDatasetThreadDialog.GetDialogOptions: TJvThreadedDatasetDialogOptions;\r\nbegin\r\n Result := TJvThreadedDatasetDialogOptions(inherited DialogOptions);\r\nend;\r\n\r\nprocedure TJvDatasetThreadDialog.SetDialogOptions(const Value: TJvThreadedDatasetDialogOptions);\r\nbegin\r\n inherited DialogOptions.Assign(Value);\r\nend;\r\n\r\n//=== { TJvDatasetThreadDialogForm } =========================================\r\n\r\nconstructor TJvDatasetThreadDialogForm.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n InternalTimerInterval := 250;\r\nend;\r\n\r\nprocedure TJvDatasetThreadDialogForm.CreateFormControls;\r\nvar\r\n MainPanel: TWinControl;\r\n ITmpPanel: IJvDynControlPanel;\r\n ITmpControl: IJvDynControlCaption;\r\nbegin\r\n Inherited CreateFormControls;\r\n MainPanel := DynControlEngine.CreatePanelControl(Self, Self, 'MainPanel', '', alClient);\r\n if not Supports(MainPanel, IJvDynControlPanel, ITmpPanel) then\r\n raise EIntfCastError.CreateRes(@RsEIntfCastError);\r\n ITmpPanel.ControlSetBorder(bvNone, bvNone, 0, bsNone, 5);\r\n\r\n CreateTextPanel(Self, MainPanel, FTimePanel, FTimeLabel, FTimeStaticText, 'Time');\r\n if Supports(FTimeLabel, IJvDynControlCaption, ITmpControl) then\r\n ITmpControl.ControlSetCaption(RsODSOpenFetch);\r\n CreateTextPanel(Self, MainPanel, FRowsPanel, FRowsLabel, FRowsStaticText, 'Rows');\r\n if Supports(FRowsLabel, IJvDynControlCaption, ITmpControl) then\r\n ITmpControl.ControlSetCaption(RsODSCurrentRecord);\r\n FCancelButtonPanel := DynControlEngine.CreatePanelControl(Self, MainPanel, 'ButtonPanel', '', alTop);\r\n FCancelBtn := DynControlEngine.CreateButton(Self, FCancelButtonPanel,\r\n 'CancelBtn', RsButtonCancelCaption, '', DefaultCancelBtnClick, True, True);\r\n FCancelBtn.Anchors := [akTop];\r\n FCancelBtn.Top := 2;\r\n FCancelButtonPanel.Height := FCancelBtn.Height + 3;\r\n\r\n BorderIcons := [];\r\n BorderStyle := bsDialog;\r\n if DialogOptions.Caption <> '' then\r\n Caption := DialogOptions.Caption\r\n else\r\n Caption := ' ';\r\n FormStyle := DialogOptions.FormStyle;\r\n OldCreateOrder := False;\r\n {$IFDEF COMPILER7_UP}\r\n Position := poOwnerFormCenter;\r\n {$ELSE}\r\n Position := poScreenCenter;\r\n {$ENDIF COMPILER7_UP}\r\n PixelsPerInch := 96;\r\nend;\r\n\r\nprocedure TJvDatasetThreadDialogForm.CreateTextPanel(AOwner: TComponent; AParent: TWinControl; var Panel: TWinControl;\r\n var LabelCtrl: TControl; var StaticText: TWinControl; const BaseName: string);\r\nvar\r\n ITmpPanel: IJvDynControlPanel;\r\n ITmpAutoSize: IJvDynControlAutoSize;\r\n ITmpAlignment: IJvDynControlAlignment;\r\nbegin\r\n Panel := DynControlEngine.CreatePanelControl(AOwner, AParent, BaseName + 'Panel', '', alTop);\r\n if not Supports(Panel, IJvDynControlPanel, ITmpPanel) then\r\n raise EIntfCastError.CreateRes(@RsEIntfCastError);\r\n ITmpPanel.ControlSetBorder(bvNone, bvNone, 0, bsNone, 3);\r\n LabelCtrl := DynControlEngine.CreateLabelControl(AOwner, Panel, BaseName + 'Label', '', nil);\r\n LabelCtrl.Top := 1;\r\n LabelCtrl.Left := 1;\r\n LabelCtrl.Width := 90;\r\n StaticText := DynControlEngine.CreateStaticTextControl(AOwner, Panel, BaseName + 'StaticText', '');\r\n if Supports(StaticText, IJvDynControlAutoSize, ITmpAutoSize) then\r\n ITmpAutoSize.ControlSetAutoSize(False);\r\n if Supports(StaticText, IJvDynControlAlignment, ITmpAlignment) then\r\n ITmpAlignment.ControlSetAlignment(taCenter);\r\n StaticText.Top := 1;\r\n StaticText.Left := 95;\r\n StaticText.Height := 18;\r\n Panel.Height := StaticText.Height + 6;\r\nend;\r\n\r\nprocedure TJvDatasetThreadDialogForm.FillDialogData;\r\nvar\r\n ITmpControl: IJvDynControlCaption;\r\nbegin\r\n if Assigned(ConnectedDatasetHandler) then\r\n begin\r\n if DialogOptions.Caption <> '' then\r\n Caption := DialogOptions.Caption +' - '+ConnectedDatasetHandler.CurrentOperationAction\r\n else\r\n Caption := ConnectedDatasetHandler.CurrentOperationAction ;\r\n if Supports(FRowsStaticText, IJvDynControlCaption, ITmpControl) then\r\n ITmpControl.ControlSetCaption(IntToStr(ConnectedDatasetHandler.CurrentRow));\r\n if Supports(FTimeStaticText, IJvDynControlCaption, ITmpControl) then\r\n ITmpControl.ControlSetCaption(\r\n FormatDateTime('hh:nn:ss', ConnectedDatasetHandler.CurrentOpenDuration) + ' / ' +\r\n FormatDateTime('hh:nn:ss', ConnectedDatasetHandler.CurrentFetchDuration));\r\n end\r\n else\r\n begin\r\n Caption := DialogOptions.Caption;\r\n if Supports(FRowsStaticText, IJvDynControl, ITmpControl) then\r\n ITmpControl.ControlSetCaption(IntToStr(0));\r\n if Supports(FTimeStaticText, IJvDynControl, ITmpControl) then\r\n ITmpControl.ControlSetCaption(\r\n FormatDateTime('hh:nn:ss', 0) + ' / ' +\r\n FormatDateTime('hh:nn:ss', 0));\r\n end;\r\n FRowsStaticText.Width:= FRowsPanel.Width - FRowsLabel.Width;\r\n FTimeStaticText.Width:= FTimePanel.Width - FTimeLabel.Width;\r\nend;\r\n\r\nfunction TJvDatasetThreadDialogForm.GetConnectedDataset: TDataSet;\r\nbegin\r\n if Assigned(ConnectedDatasetHandler) then\r\n Result := ConnectedDatasetHandler.Dataset\r\n else\r\n Result := nil;\r\nend;\r\n\r\nfunction TJvDatasetThreadDialogForm.GetConnectedDatasetHandler: TJvBaseDatasetThreadHandler;\r\nbegin\r\n if Assigned(ConnectedDataComponent) and (ConnectedDataComponent is TJvBaseDatasetThreadHandler) then\r\n Result := TJvBaseDatasetThreadHandler(ConnectedDataComponent)\r\n else\r\n Result := nil;\r\nend;\r\n\r\nfunction TJvDatasetThreadDialogForm.GetDialogOptions: TJvThreadedDatasetDialogOptions;\r\nbegin\r\n Result := FDialogOptions;\r\nend;\r\n\r\nprocedure TJvDatasetThreadDialogForm.InitializeFormContents;\r\nbegin\r\n if Assigned(ConnectedDatasetHandler) then\r\n ConnectedDatasetHandler.InitOperation;\r\nend;\r\n\r\nprocedure TJvDatasetThreadDialogForm.SetDialogOptions(const Value: TJvThreadedDatasetDialogOptions);\r\nbegin\r\n inherited DialogOptions := Value;\r\n FDialogOptions := Value;\r\n if Assigned(FDialogOptions) then\r\n DynControlEngine := DialogOptions.DynControlEngine\r\n else\r\n DynControlEngine := nil;\r\nend;\r\n\r\nprocedure TJvDatasetThreadDialogForm.TransferDialogOptions;\r\nvar\r\n H: Integer;\r\nbegin\r\n Inherited;\r\n ClientWidth := 220;\r\n FCancelButtonPanel.Visible := DialogOptions.ShowCancelButton;\r\n FCancelBtn.Enabled := DialogOptions.EnableCancelButton;\r\n FCancelBtn.Left := Round((FCancelButtonPanel.Width - FCancelBtn.Width) / 2);\r\n FRowsPanel.Visible := DialogOptions.ShowRowsLabel;\r\n FTimePanel.Visible := DialogOptions.ShowTimeLabel;\r\n H := 10;\r\n if FRowsPanel.Visible then\r\n H := H + FRowsPanel.Height;\r\n if FTimePanel.Visible then\r\n H := H + FTimePanel.Height;\r\n if FCancelButtonPanel.Visible then\r\n H := H + FCancelButtonPanel.Height;\r\n ClientHeight := H;\r\nend;\r\n\r\nprocedure TJvDatasetThreadDialogForm.UpdateFormContents;\r\nbegin\r\n inherited UpdateFormContents;\r\n FillDialogData;\r\nend;\r\n\r\n//=== { TJvThreadedDatasetDialogOptions } ====================================\r\n\r\nconstructor TJvThreadedDatasetDialogOptions.Create(AOwner: TJvCustomThreadDialog);\r\nbegin\r\n inherited Create(AOwner);\r\n FEnableCancelButton := True;\r\n FShowCancelButton := True;\r\n FShowRowsLabel := True;\r\n FShowTimeLabel := True;\r\nend;\r\n\r\ndestructor TJvThreadedDatasetDialogOptions.Destroy;\r\nbegin\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvThreadedDatasetDialogOptions.SetCaption(const Value: string);\r\nbegin\r\n FCaption := Value;\r\nend;\r\n\r\nprocedure TJvThreadedDatasetDialogOptions.SetDynControlEngine(const Value: TJvDynControlEngine);\r\nbegin\r\n FDynControlEngine := Value;\r\nend;\r\n\r\nprocedure TJvThreadedDatasetDialogOptions.SetEnableCancelButton(const Value: Boolean);\r\nbegin\r\n FEnableCancelButton := Value;\r\nend;\r\n\r\nprocedure TJvThreadedDatasetDialogOptions.SetFormStyle(const Value: TFormStyle);\r\nbegin\r\n FFormStyle := Value;\r\nend;\r\n\r\nprocedure TJvThreadedDatasetDialogOptions.SetShowCancelButton(const Value: Boolean);\r\nbegin\r\n FShowCancelButton := Value;\r\nend;\r\n\r\nprocedure TJvThreadedDatasetDialogOptions.SetShowRowsLabel(const Value: Boolean);\r\nbegin\r\n FShowRowsLabel := Value;\r\nend;\r\n\r\nprocedure TJvThreadedDatasetDialogOptions.SetShowTimeLabel(const Value: Boolean);\r\nbegin\r\n FShowTimeLabel := Value;\r\nend;\r\n\r\n//=== { TJvBaseDatasetThread } ===============================================\r\n\r\nprocedure TJvBaseDatasetThread.InternalAfterCreateDialogForm(DialogForm: TJvCustomThreadDialogForm);\r\nbegin\r\n DialogForm.ConnectedDataComponent := ConnectedDatasetThreadHandler;\r\nend;\r\n\r\nprocedure TJvBaseDatasetThread.CancelExecute;\r\nbegin\r\n if ConnectedDatasetThreadHandler.SupportsBreakExecution then\r\n ConnectedDatasetThreadHandler.BreakExecution\r\n else\r\n inherited CancelExecute;\r\nend;\r\n\r\nprocedure TJvBaseDatasetThread.SetConnectedDataset(const Value: TDataSet);\r\nbegin\r\n FConnectedDataset := Value;\r\n if Assigned(Value) then\r\n if not Supports(Value, IJvThreadedDatasetInterface, FConnectedDatasetInterface) then\r\n raise EIntfCastError.CreateRes(@RsEIntfCastError)\r\n else\r\n else\r\n FConnectedDatasetInterface := nil;\r\n\r\nend;\r\n\r\nprocedure TJvBaseDatasetThread.SetConnectedDatasetThreadHandler(const Value: TJvBaseDatasetThreadHandler);\r\nbegin\r\n FConnectedDatasetThreadHandler := Value;\r\n if Assigned(Value) then\r\n SetConnectedDataset (ConnectedDatasetThreadHandler.Dataset)\r\n else\r\n SetConnectedDataset (nil);\r\nend;\r\n\r\n//=== { TJvThreadedDatasetThreadOptions } ====================================\r\n\r\nconstructor TJvThreadedDatasetThreadOptions.Create;\r\nbegin\r\n inherited Create;\r\n FLastInThread := False;\r\n FOpenInThread := False;\r\n FPriority := tpIdle;\r\n FRefreshInThread := False;\r\n FShowExceptionMessage := True;\r\nend;\r\n\r\n//=== { TJvThreadedDatasetEnhancedOptions } ==================================\r\n\r\nconstructor TJvBaseThreadedDatasetEnhancedOptions.Create;\r\nbegin\r\n inherited Create;\r\n FRefreshAsOpenClose := False;\r\n FRefreshLastPosition := False;\r\n FCapitalizeLabelOptions := TJvThreadedDatasetCapitalizeLabelOptions.Create;\r\n FAllowedContinueRecordFetchOptions := CreateAllowedContinueRecordFetchOptions;\r\n FFetchRowsCheck := 2000;\r\n FFetchRowsFirst := 1000;\r\nend;\r\n\r\ndestructor TJvBaseThreadedDatasetEnhancedOptions.Destroy;\r\nbegin\r\n FreeAndNil(FAllowedContinueRecordFetchOptions);\r\n FreeAndNil(FCapitalizeLabelOptions);\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJvBaseThreadedDatasetEnhancedOptions.CreateAllowedContinueRecordFetchOptions:\r\n TJvBaseThreadedDatasetAllowedContinueRecordFetchOptions;\r\nbegin\r\n Result := TJvBaseThreadedDatasetAllowedContinueRecordFetchOptions.Create;\r\nend;\r\n\r\nprocedure TJvBaseThreadedDatasetEnhancedOptions.SetCapitalizeLabelOptions(const Value:\r\n TJvThreadedDatasetCapitalizeLabelOptions);\r\nbegin\r\n FCapitalizeLabelOptions.Assign(Value);\r\nend;\r\n\r\nprocedure TJvBaseThreadedDatasetEnhancedOptions.SetFetchRowsCheck(const Value: Integer);\r\nbegin\r\n FFetchRowsCheck := Value;\r\nend;\r\n\r\nprocedure TJvBaseThreadedDatasetEnhancedOptions.SetFetchRowsFirst(const Value: Integer);\r\nbegin\r\n FFetchRowsFirst := Value;\r\nend;\r\n\r\nprocedure TJvBaseThreadedDatasetEnhancedOptions.SetRefreshAsOpenClose(Value: Boolean);\r\nbegin\r\n FRefreshAsOpenClose := Value;\r\nend;\r\n\r\nprocedure TJvBaseThreadedDatasetEnhancedOptions.SetRefreshLastPosition(const Value: Boolean);\r\nbegin\r\n FRefreshLastPosition := Value;\r\nend;\r\n\r\n//=== { TJvThreadedDatasetCapitalizeLabelOptions } ===========================\r\n\r\nconstructor TJvThreadedDatasetCapitalizeLabelOptions.Create;\r\nbegin\r\n inherited Create;\r\n FAutoExecuteAfterOpen := False;\r\n FTrimToFirstBlank := False;\r\nend;\r\n\r\n//=== { TJvBaseDatasetThreadHandler } ========================================\r\n\r\nconstructor TJvBaseDatasetThreadHandler.Create(AOwner: TComponent; ADataset: TDataSet);\r\nbegin\r\n inherited Create (AOwner);\r\n FDataset := ADataset;\r\n if not Supports(ADataset, IJvThreadedDatasetInterface, FIThreadedDatasetInterface) then\r\n raise EIntfCastError.CreateRes(@RsEIntfCastError);\r\n\r\n FThreadOptions := TJvThreadedDatasetThreadOptions.Create;\r\n FExecuteThread := TJvBaseDatasetThread.Create(Self);\r\n FThreadDialog := TJvDatasetThreadDialog.Create(Self);\r\n FExecuteThread.Exclusive := True;\r\n FExecuteThread.OnExecute := ThreadExecute;\r\n FExecuteThread.ConnectedDatasetThreadHandler := Self;\r\n FExecuteThread.ThreadDialog := ThreadDialog;\r\n FEnhancedOptions := CreateEnhancedOptions;\r\n IntCurrentOperation := tdoNothing;\r\n MessageDlgIsActive := False;\r\nend;\r\n\r\ndestructor TJvBaseDatasetThreadHandler.Destroy;\r\nbegin\r\n FreeAndNil(FEnhancedOptions);\r\n FreeAndNil(FThreadDialog);\r\n FreeAndNil(FExecuteThread);\r\n FreeAndNil(FThreadOptions);\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvBaseDatasetThreadHandler.AfterOpen;\r\nbegin\r\n ExecuteThreadSynchronize(IntSynchAfterOpen);\r\n if not ExecuteThreadIsActive and not OperationWasHandledInThread and (IntCurrentOperation <> tdoRefresh) then\r\n HandleAfterOpenRefresh;\r\nend;\r\n\r\nprocedure TJvBaseDatasetThreadHandler.AfterScroll;\r\nbegin\r\n IThreadedDatasetInterface.DoInheritedAfterScroll;\r\n EofReached := EofReached or Dataset.Eof;\r\nend;\r\n\r\nprocedure TJvBaseDatasetThreadHandler.AfterRefresh;\r\nbegin\r\n if not ExecuteThreadIsActive and not OperationWasHandledInThread then\r\n HandleAfterOpenRefresh;\r\n ExecuteThreadSynchronize(IntSynchAfterRefresh);\r\nend;\r\n\r\nprocedure TJvBaseDatasetThreadHandler.BeforeOpen;\r\nbegin\r\n if (IntCurrentOperation <> tdoRefresh) then\r\n begin\r\n FAfterOpenRecordPosition := -1;\r\n HandleBeforeOpenRefresh;\r\n end;\r\n ExecuteThreadSynchronize(IntSynchBeforeOpen);\r\nend;\r\n\r\nprocedure TJvBaseDatasetThreadHandler.BeforeRefresh;\r\nbegin\r\n if EnhancedOptions.RefreshLastPosition then\r\n FAfterOpenRecordPosition := Dataset.RecNo\r\n else\r\n FAfterOpenRecordPosition := -1;\r\n HandleBeforeOpenRefresh;\r\n ExecuteThreadSynchronize(IntSynchBeforeRefresh);\r\nend;\r\n\r\nprocedure TJvBaseDatasetThreadHandler.BreakExecution;\r\nbegin\r\n IntCurrentAction := tdaCancel;\r\n if (FetchMode = tdfmFetch) and\r\n (EnhancedOptions.AllowedContinueRecordFetchOptions.Pause or\r\n EnhancedOptions.AllowedContinueRecordFetchOptions.Cancel) then\r\n if EnhancedOptions.AllowedContinueRecordFetchOptions.Pause then\r\n FetchMode := tdfmBreak\r\n else\r\n FetchMode := tdfmStop\r\n else\r\n begin\r\n IThreadedDatasetInterface.BreakExecution;\r\n FetchMode := tdfmStop;\r\n end;\r\n IntRowCheckEnabled := False;\r\nend;\r\n\r\nprocedure TJvBaseDatasetThreadHandler.BringDialogToFront;\r\nbegin\r\n if Assigned(ExecuteThread) and ExecuteThread.OneThreadIsRunning\r\n and Assigned(ExecuteThread.ThreadDialogForm)\r\n and not MessageDlgIsActive then\r\n ExecuteThread.ThreadDialogForm.BringToFront;\r\nend;\r\n\r\nprocedure TJvBaseDatasetThreadHandler.CapitalizeDatasetLabels;\r\nvar\r\n I, J: Integer;\r\n S: string;\r\n Upper: Boolean;\r\nbegin\r\n if Dataset.Active then\r\n for I := 0 to Dataset.FieldCount - 1 do\r\n begin\r\n S := LowerCase(Dataset.Fields[I].DisplayLabel);\r\n Upper := True;\r\n for J := 1 to Length(S) do\r\n if CharInSet(S[J], ['_', '$', ' ']) then\r\n begin\r\n Upper := True;\r\n S[J] := ' ';\r\n end\r\n else\r\n if Upper then\r\n begin\r\n S[J] := UpCase(S[J]);\r\n Upper := False;\r\n end;\r\n if EnhancedOptions.CapitalizeLabelOptions.TrimToFirstBlank then\r\n begin\r\n J := Pos(' ', S);\r\n if J > 0 then\r\n S := Copy(S, J + 1, Length(S) - J);\r\n end;\r\n Dataset.Fields[I].DisplayLabel := S;\r\n end;\r\nend;\r\n\r\nfunction TJvBaseDatasetThreadHandler.CheckContinueRecordFetch: TJvThreadedDatasetContinueCheckResult;\r\nbegin\r\n Result := tdccrContinue;\r\n FCurrentRow := Dataset.RecordCount;\r\n if MaxRowCheckExceeded or ((CurrentRow > fMaxRowChecked) and (fMaxRowChecked >0))then\r\n begin\r\n Result := tdccrPause;\r\n FetchMode := tdfmFetch;\r\n Exit;\r\n end;\r\n case FetchMode of\r\n tdfmBreak:\r\n begin\r\n Result := tdccrPause;\r\n FetchMode := tdfmFetch;\r\n Exit;\r\n end;\r\n tdfmStop:\r\n begin\r\n Result := tdccrStop;\r\n Exit;\r\n end;\r\n end;\r\n if IntRowCheckEnabled then\r\n begin\r\n if (fLastRowChecked = 0) and\r\n (CurrentRow >= EnhancedOptions.FetchRowsFirst) and\r\n (CurrentRow < FLastRowChecked + EnhancedOptions.FetchRowsCheck)then\r\n begin\r\n Result := tdccrContinue;\r\n if CurrentRow > 0 then\r\n Exit;\r\n end;\r\n if (EnhancedOptions.FetchRowsCheck > 0) and\r\n (CurrentRow >= FLastRowChecked + EnhancedOptions.FetchRowsCheck) then\r\n begin\r\n IntCurrentFetchDuration := IntCurrentFetchDuration + Now - IntCurrentOperationStart;\r\n IntCurrentAction := tdaNothing;\r\n FLastRowChecked := CurrentRow;\r\n FSynchMessageDlgMsg := Format(RsODSRowsFetchedContinue, [CurrentRow]);\r\n ExecuteThreadSynchronize(SynchContinueFetchMessageDlg);\r\n case FSynchMessageDlgBtn of\r\n mrYes:\r\n Result := tdccrContinue;\r\n mrAll:\r\n begin\r\n Result := tdccrContinue;\r\n IntRowCheckEnabled := False;\r\n end;\r\n mrAbort:\r\n Result := tdccrCancel;\r\n mrCancel:\r\n Result := tdccrPause;\r\n mrNo:\r\n Result := tdccrStop;\r\n else\r\n Result := tdccrStop;\r\n end;\r\n IntCurrentAction := tdaFetch;\r\n FetchMode := tdfmFetch;\r\n if Result = tdccrStop then\r\n fMaxRowChecked := CurrentRow;\r\n\r\n IntCurrentOperationStart := Now;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJvBaseDatasetThreadHandler.CreateEnhancedOptions: TJvBaseThreadedDatasetEnhancedOptions;\r\nbegin\r\n Result := TJvBaseThreadedDatasetEnhancedOptions.Create;\r\nend;\r\n\r\nprocedure TJvBaseDatasetThreadHandler.DoThreadLast;\r\nbegin\r\n IThreadedDatasetInterface.DoInheritedInternalLast;\r\nend;\r\n\r\nprocedure TJvBaseDatasetThreadHandler.DoThreadOpen;\r\nbegin\r\n try\r\n IThreadedDatasetInterface.DoInheritedSetActive(True);\r\n finally\r\n HandleAfterOpenRefreshThread;\r\n end;\r\nend;\r\n\r\nprocedure TJvBaseDatasetThreadHandler.DoThreadRefresh;\r\nbegin\r\n try\r\n if not EnhancedOptions.RefreshAsOpenClose then\r\n begin\r\n IThreadedDatasetInterface.DoInheritedInternalRefresh;\r\n end\r\n else\r\n begin\r\n if Dataset.Active then\r\n ExecuteThreadSynchronize(Dataset.Close);\r\n IThreadedDatasetInterface.DoInheritedSetActive(True);\r\n end;\r\n finally\r\n HandleAfterOpenRefreshThread;\r\n end;\r\nend;\r\n\r\nfunction TJvBaseDatasetThreadHandler.ExecuteThreadIsActive: Boolean;\r\nbegin\r\n Result := Not ExecuteThread.Terminated;\r\nend;\r\n\r\nprocedure TJvBaseDatasetThreadHandler.ExecuteThreadSynchronize(Method: TThreadMethod);\r\nbegin\r\n ExecuteThread.Synchronize(Method);\r\nend;\r\n\r\nfunction TJvBaseDatasetThreadHandler.GetCurrentAction: TJvThreadedDatasetAction;\r\nbegin\r\n Result := GetIntCurrentAction;\r\nend;\r\n\r\nfunction TJvBaseDatasetThreadHandler.GetCurrentFetchDuration: tDateTime;\r\nbegin\r\n Result := IntCurrentFetchDuration;\r\nend;\r\n\r\nfunction TJvBaseDatasetThreadHandler.GetCurrentOpenDuration: tDateTime;\r\nbegin\r\n Result := IntCurrentOpenDuration;\r\nend;\r\n\r\nfunction TJvBaseDatasetThreadHandler.GetIntCurrentAction: TJvThreadedDatasetAction;\r\nbegin\r\n Result := FIntCurrentAction;\r\nend;\r\n\r\nfunction TJvBaseDatasetThreadHandler.GetIntCurrentFetchDuration: TDateTime;\r\nbegin\r\n case IntCurrentAction of\r\n tdaOpen:\r\n Result := 0;\r\n tdaNothing, tdaCancel:\r\n Result := FIntCurrentFetchDuration;\r\n tdaFetch:\r\n Result := FIntCurrentFetchDuration + (Now - IntCurrentOperationStart);\r\n else\r\n Result := FIntCurrentFetchDuration;\r\n end;\r\nend;\r\n\r\nfunction TJvBaseDatasetThreadHandler.GetIntCurrentOpenDuration: TDateTime;\r\nbegin\r\n if IntCurrentAction = tdaOpen then\r\n Result := Now - IntCurrentOperationStart\r\n else\r\n Result := FIntCurrentOpenDuration;\r\nend;\r\n\r\nfunction TJvBaseDatasetThreadHandler.GetCurrentOperation:\r\n TJvThreadedDatasetOperation;\r\nbegin\r\n Result := IntCurrentOperation;\r\nend;\r\n\r\nfunction TJvBaseDatasetThreadHandler.GetIntCurrentOperation: TJvThreadedDatasetOperation;\r\nbegin\r\n Result := FIntCurrentOperation;\r\nend;\r\n\r\nfunction TJvBaseDatasetThreadHandler.GetCurrentOperationAction: string;\r\nbegin\r\n case IntCurrentOperation of\r\n tdoOpen:\r\n case IntCurrentAction of\r\n tdaOpen:\r\n Result := RsODSOpenQuery;\r\n tdaFetch:\r\n Result := RsODSOpenQueryFetchRecords;\r\n tdaCancel :\r\n Result := RsODSOpenQueryCancel;\r\n end;\r\n tdoRefresh:\r\n case IntCurrentAction of\r\n tdaOpen:\r\n Result := RsODSRefreshQuery;\r\n tdaFetch:\r\n Result := RsODSRefreshQueryFetchRecords;\r\n tdaCancel :\r\n Result := RsODSRefreshQueryCancel;\r\n end;\r\n tdoFetch:\r\n case IntCurrentAction of\r\n tdaFetch:\r\n Result := RsODSFetchRecords;\r\n tdaCancel :\r\n Result := RsODSFetchRecordsCancel;\r\n end;\r\n tdoLast:\r\n Result := RsODSGotoLastFetchRecords;\r\n end;\r\nend;\r\n\r\nfunction TJvBaseDatasetThreadHandler.GetDatasetFetchAllRecords: Boolean;\r\nbegin\r\n if Assigned(IThreadedDatasetInterface) then\r\n Result := IThreadedDatasetInterface.DatasetFetchAllRecords\r\n else\r\n Result := False;\r\nend;\r\n\r\nfunction TJvBaseDatasetThreadHandler.GetDialogOptions:\r\n TJvThreadedDatasetDialogOptions;\r\nbegin\r\n Result := ThreadDialog.DialogOptions;\r\nend;\r\n\r\nfunction TJvBaseDatasetThreadHandler.GetFetchMode: TJvThreadedDatasetFetchMode;\r\nbegin\r\n Result := FFetchMode;\r\nend;\r\n\r\nfunction TJvBaseDatasetThreadHandler.GetNextRecord: Boolean;\r\nbegin\r\n if MaxRowCheckExceeded then\r\n Result := False\r\n else\r\n Result := IThreadedDatasetInterface.DoGetInheritedNextRecord;\r\nend;\r\n\r\nprocedure TJvBaseDatasetThreadHandler.HandleAfterOpenRefresh;\r\nbegin\r\n try\r\n IntCurrentOpenDuration := Now - IntCurrentOperationStart;\r\n IntCurrentOperationStart := Now;\r\n DatasetFetchAllRecords := FIntDatasetFetchAllRecords;\r\n if (IntCurrentAction <> tdaCancel) and not (FetchMode in [tdfmBreak, tdfmStop]) then\r\n begin\r\n IntCurrentAction := tdaFetch;\r\n FetchMode := tdfmFetch;\r\n if Dataset.Active then\r\n begin\r\n Dataset.First;\r\n if DatasetFetchAllRecords then\r\n IThreadedDatasetInterface.DoInheritedInternalLast\r\n else\r\n if (EnhancedOptions.FetchRowsFirst > Dataset.RecordCount) or\r\n (FAfterOpenRecordPosition > Dataset.RecordCount) then\r\n begin\r\n if FAfterOpenRecordPosition > EnhancedOptions.FetchRowsFirst then\r\n Dataset.MoveBy(FAfterOpenRecordPosition - 1)\r\n else\r\n Dataset.MoveBy(EnhancedOptions.FetchRowsFirst - 1);\r\n EofReached := EofReached or Dataset.Eof;\r\n end;\r\n end;\r\n end;\r\n Dataset.Filtered := FIntDatasetWasFiltered;\r\n finally\r\n ExecuteThreadSynchronize(Dataset.EnableControls);\r\n IntCurrentAction := tdaNothing;\r\n end;\r\n if Dataset.Active and (IntCurrentAction <> tdaCancel) then\r\n begin\r\n ExecuteThreadSynchronize(MoveToRecordPositionAfterOpen);\r\n ExecuteThreadSynchronize(SynchAfterOpenFetch);\r\n end;\r\nend;\r\n\r\nprocedure TJvBaseDatasetThreadHandler.HandleAfterOpenRefreshThread;\r\nbegin\r\n HandleAfterOpenRefresh;\r\nend;\r\n\r\nprocedure TJvBaseDatasetThreadHandler.HandleBeforeOpenRefresh;\r\nbegin\r\n FEofReached := False;\r\n OperationWasHandledInThread := False;\r\n ExecuteThreadSynchronize(Dataset.DisableControls);\r\n IntCurrentOpenDuration := 0;\r\n IntCurrentFetchDuration := 0;\r\n IntRowCheckEnabled := True;\r\n FCurrentRow := 0;\r\n IntCurrentOperationStart := Now;\r\n IntCurrentAction := tdaOpen;\r\n FetchMode := tdfmNothing;\r\n FIntDatasetFetchAllRecords := DatasetFetchAllRecords;\r\n FLastRowChecked := 0;\r\n FMaxRowChecked := 0;\r\n FIntDatasetWasFiltered := Dataset.Filtered;\r\n Dataset.Filtered := False;\r\n DatasetFetchAllRecords := False;\r\nend;\r\n\r\nprocedure TJvBaseDatasetThreadHandler.InitOperation;\r\nbegin\r\n IntCurrentOperationStart := Now;\r\nend;\r\n\r\nprocedure TJvBaseDatasetThreadHandler.IntAfterThreadExecution(DataSet: TDataSet;\r\n Operation: TJvThreadedDatasetOperation);\r\nbegin\r\n if Assigned(FAfterThreadExecution) then\r\n FAfterThreadExecution(DataSet, Operation);\r\nend;\r\n\r\nprocedure TJvBaseDatasetThreadHandler.IntAfterOpenFetch(DataSet: TDataSet);\r\nbegin\r\n if Assigned(FAfterOpenFetch) then\r\n FAfterOpenFetch(DataSet);\r\nend;\r\n\r\nprocedure TJvBaseDatasetThreadHandler.IntBeforeThreadExecution(DataSet: TDataSet;\r\n Operation: TJvThreadedDatasetOperation);\r\nbegin\r\n if Assigned(FBeforeThreadExecution) then\r\n FBeforeThreadExecution(DataSet, Operation);\r\nend;\r\n\r\nprocedure TJvBaseDatasetThreadHandler.IntOnThreadException(DataSet: TDataSet; Operation: TJvThreadedDatasetOperation;\r\n E: Exception);\r\nbegin\r\n if Assigned(FOnThreadException) then\r\n FOnThreadException(DataSet, Operation, E);\r\nend;\r\n\r\nprocedure TJvBaseDatasetThreadHandler.InternalLast;\r\nvar\r\n ShowModal: Boolean;\r\nbegin\r\n if FIntCurrentOperation <> tdoNothing then\r\n Exit;\r\n IntCurrentOperation := tdoLast;\r\n if not ThreadOptions.LastInThread or ThreadIsActive or (csDesigning in ComponentState) then\r\n begin\r\n IThreadedDatasetInterface.DoInheritedInternalLast;\r\n IntCurrentOperation := tdoNothing;\r\n end\r\n else\r\n begin\r\n if Assigned(ExecuteThread.ThreadDialog) then\r\n begin\r\n showModal := ExecuteThread.ThreadDialog.DialogOptions.ShowModal;\r\n ExecuteThread.ThreadDialog.DialogOptions.ShowModal := True;\r\n end\r\n else\r\n ShowModal := False;\r\n ExecuteThread.ExecuteWithDialog(nil);\r\n if Assigned(ExecuteThread.ThreadDialog) then\r\n ExecuteThread.ThreadDialog.DialogOptions.ShowModal := showModal;\r\n end;\r\nend;\r\n\r\nprocedure TJvBaseDatasetThreadHandler.InternalRefresh;\r\nbegin\r\n if FIntCurrentOperation <> tdoNothing then\r\n Exit;\r\n IntCurrentOperation := tdoRefresh;\r\n if not ThreadOptions.RefreshInThread or not IThreadedDatasetInterface.IsThreadAllowed or\r\n ThreadIsActive or (csDesigning in ComponentState) then\r\n begin\r\n if not EnhancedOptions.RefreshAsOpenClose then\r\n IThreadedDatasetInterface.DoInheritedInternalRefresh\r\n else\r\n begin\r\n if Dataset.Active then\r\n SetActive(False);\r\n SetActive(True);\r\n end;\r\n IntCurrentOperation := tdoNothing;\r\n end\r\n else\r\n ExecuteThread.ExecuteWithDialog(nil);\r\nend;\r\n\r\nprocedure TJvBaseDatasetThreadHandler.IntSynchAfterOpen;\r\nbegin\r\n if EnhancedOptions.CapitalizeLabelOptions.AutoExecuteAfterOpen then\r\n CapitalizeDatasetLabels;\r\n IThreadedDatasetInterface.DoInheritedAfterOpen;\r\n if ExecuteThreadIsActive then\r\n begin\r\n // Added because in the afteropen event the filtered could be activated, and it should be deactivated for the dialog\r\n FIntDatasetWasFiltered := Dataset.Filtered or FIntDatasetWasFiltered;\r\n Dataset.Filtered := False;\r\n end;\r\nend;\r\n\r\nprocedure TJvBaseDatasetThreadHandler.IntSynchAfterRefresh;\r\nbegin\r\n IThreadedDatasetInterface.DoInheritedAfterRefresh;\r\nend;\r\n\r\nprocedure TJvBaseDatasetThreadHandler.IntSynchBeforeOpen;\r\nbegin\r\n IThreadedDatasetInterface.DoInheritedBeforeOpen;\r\nend;\r\n\r\nprocedure TJvBaseDatasetThreadHandler.IntSynchBeforeRefresh;\r\nbegin\r\n IThreadedDatasetInterface.DoInheritedBeforeRefresh;\r\nend;\r\n\r\nfunction TJvBaseDatasetThreadHandler.MaxRowCheckExceeded: Boolean;\r\nbegin\r\n Result :=(fMaxRowChecked > 0) and ((Dataset.RecNo >= fMaxRowChecked));\r\nend;\r\n\r\nprocedure TJvBaseDatasetThreadHandler.MoveTo(Position: Integer);\r\nbegin\r\n Dataset.MoveBy(Position - Dataset.RecNo);\r\n EofReached := EofReached or Dataset.Eof;\r\nend;\r\n\r\nprocedure TJvBaseDatasetThreadHandler.SetActive(Value: Boolean);\r\nbegin\r\n if not Value then\r\n begin\r\n IntCurrentOpenDuration := 0;\r\n IntCurrentFetchDuration := 0;\r\n IThreadedDatasetInterface.DoInheritedSetActive(Value);\r\n end\r\n else\r\n begin\r\n if (IntCurrentOperation <> tdoNothing) and\r\n (IntCurrentOperation <> tdoRefresh) then\r\n Exit;\r\n if IntCurrentOperation <> tdoRefresh then\r\n IntCurrentOperation := tdoOpen;\r\n if not ( (ThreadOptions.OpenInThread and (IntCurrentOperation = tdoOpen))\r\n or (ThreadOptions.RefreshInThread and (IntCurrentOperation = tdoRefresh))\r\n )\r\n or ThreadIsActive or (csDesigning in ComponentState) then\r\n begin\r\n try\r\n IThreadedDatasetInterface.DoInheritedSetActive(Value);\r\n finally\r\n if IntCurrentOperation <> tdoRefresh then\r\n IntCurrentOperation := tdoNothing;\r\n end;\r\n end\r\n else\r\n ExecuteThread.ExecuteWithDialog(nil);\r\n end;\r\nend;\r\n\r\nprocedure TJvBaseDatasetThreadHandler.SetIntCurrentAction(const Value: TJvThreadedDatasetAction);\r\nbegin\r\n FIntCurrentAction := Value;\r\nend;\r\n\r\nprocedure TJvBaseDatasetThreadHandler.SetIntCurrentFetchDuration(const Value: TDateTime);\r\nbegin\r\n FIntCurrentFetchDuration := Value;\r\nend;\r\n\r\nprocedure TJvBaseDatasetThreadHandler.SetIntCurrentOpenDuration(const Value: TDateTime);\r\nbegin\r\n FIntCurrentOpenDuration := Value;\r\nend;\r\n\r\nprocedure TJvBaseDatasetThreadHandler.SetIntCurrentOperationStart(const Value: TDateTime);\r\nbegin\r\n FIntCurrentOperationStart := Value;\r\nend;\r\n\r\nprocedure TJvBaseDatasetThreadHandler.SetDatasetFetchAllRecords(const Value: Boolean);\r\nbegin\r\n if Assigned(IThreadedDatasetInterface) then\r\n IThreadedDatasetInterface.DatasetFetchAllRecords := Value;\r\nend;\r\n\r\nprocedure TJvBaseDatasetThreadHandler.SetDialogOptions(Value: TJvThreadedDatasetDialogOptions);\r\nbegin\r\n ThreadDialog.DialogOptions.Assign(Value);\r\nend;\r\n\r\nprocedure TJvBaseDatasetThreadHandler.SetEnhancedOptions(Value: TJvBaseThreadedDatasetEnhancedOptions);\r\nbegin\r\n FEnhancedOptions.Assign(Value);\r\nend;\r\n\r\nprocedure TJvBaseDatasetThreadHandler.SetError(const Msg: string = ''; Excep:\r\n Exception = nil);\r\nbegin\r\n FErrorMessage := Msg;\r\n FErrorException := Excep;\r\nend;\r\n\r\nprocedure TJvBaseDatasetThreadHandler.SetFetchMode(const Value: TJvThreadedDatasetFetchMode);\r\nbegin\r\n FFetchMode := Value;\r\nend;\r\n\r\nprocedure TJvBaseDatasetThreadHandler.SetIntCurrentOperation(const Value: TJvThreadedDatasetOperation);\r\nbegin\r\n FIntCurrentOperation := Value;\r\nend;\r\n\r\nprocedure TJvBaseDatasetThreadHandler.SetThreadOptions(const Value: TJvThreadedDatasetThreadOptions);\r\nbegin\r\n FThreadOptions.Assign(Value);\r\nend;\r\n\r\nfunction TJvBaseDatasetThreadHandler.SupportsBreakExecution: Boolean;\r\nbegin\r\n Result := True;\r\nend;\r\n\r\nprocedure TJvBaseDatasetThreadHandler.SynchAfterThreadExecution;\r\nbegin\r\n IntAfterThreadExecution(Dataset, IntCurrentOperation);\r\nend;\r\n\r\nprocedure TJvBaseDatasetThreadHandler.SynchBeforeThreadExecution;\r\nbegin\r\n IntBeforeThreadExecution(Dataset, IntCurrentOperation);\r\nend;\r\n\r\nprocedure TJvBaseDatasetThreadHandler.SynchContinueFetchMessageDlg;\r\nvar\r\n Buttons: array of string;\r\n Results: array of Integer;\r\n L: Integer;\r\n\r\n procedure AddButton(Caption: string; ResultValue: Integer);\r\n begin\r\n Inc(L);\r\n SetLength (Buttons, L);\r\n SetLength (Results, L);\r\n Buttons[L-1] := Caption;\r\n Results[L-1] := ResultValue;\r\n end;\r\n\r\nbegin\r\n L := 0;\r\n AddButton(RsODSContinueYes, Integer(mrYes));\r\n if EnhancedOptions.AllowedContinueRecordFetchOptions.Pause then\r\n AddButton(RsODSContinuePause, Integer(mrCancel));\r\n AddButton(RsODSContinueNo, Integer(mrNo));\r\n if EnhancedOptions.AllowedContinueRecordFetchOptions.All then\r\n AddButton(RsODSContinueAll, Integer(mrAll));\r\n if EnhancedOptions.AllowedContinueRecordFetchOptions.Cancel then\r\n AddButton(RsODSContinueClose, Integer(mrAbort));\r\n MessageDlgIsActive := True;\r\n try\r\n FSynchMessageDlgBtn := JvDSADialogs.MessageDlgEx(FSynchMessageDlgMsg,\r\n mtConfirmation, Buttons, Results, 0, dckActiveForm, 0,\r\n 0, 1, -1, DialogOptions.DynControlEngine);\r\n finally\r\n MessageDlgIsActive := False;\r\n end;\r\nend;\r\n\r\nprocedure TJvBaseDatasetThreadHandler.SynchErrorMessageDlg;\r\nbegin\r\n FSynchMessageDlgBtn := JvDSADialogs.MessageDlg(FSynchMessageDlgMsg,\r\n mtError, [mbOK], 0, dckScreen, 0,\r\n mbDefault, mbDefault, mbHelp, DialogOptions.DynControlEngine);\r\nend;\r\n\r\nprocedure TJvBaseDatasetThreadHandler.SynchOnThreadException;\r\nbegin\r\n IntOnThreadException(Dataset, IntCurrentOperation, IntThreadException);\r\nend;\r\n\r\nprocedure TJvBaseDatasetThreadHandler.ThreadExecute(Sender: TObject; Params: Pointer);\r\nbegin\r\n OperationWasHandledInThread := True;\r\n ExecuteThread.ThreadDialogAllowed := True;\r\n try\r\n SetError('', nil);\r\n ExecuteThreadSynchronize(SynchBeforeThreadExecution);\r\n try\r\n case FIntCurrentOperation of\r\n tdoOpen:\r\n DoThreadOpen;\r\n tdoRefresh:\r\n DoThreadRefresh;\r\n tdoLast:\r\n DoThreadLast;\r\n end;\r\n except\r\n on E: Exception do\r\n begin\r\n SetError(E.Message, E);\r\n ExecuteThread.ThreadDialogAllowed := False;\r\n if Assigned(FOnThreadException) then\r\n begin\r\n IntThreadException := e;\r\n ExecuteThreadSynchronize(SynchOnThreadException);\r\n end;\r\n if ThreadOptions.ShowExceptionMessage then\r\n begin\r\n FSynchMessageDlgMsg := E.Message;\r\n ExecuteThreadSynchronize(SynchErrorMessageDlg);\r\n end;\r\n end;\r\n end;\r\n finally\r\n ExecuteThreadSynchronize(SynchAfterThreadExecution);\r\n IntCurrentOperation := tdoNothing;\r\n ExecuteThread.ThreadDialogAllowed := False;\r\n end;\r\nend;\r\n\r\nfunction TJvBaseDatasetThreadHandler.ThreadIsActive: Boolean;\r\nbegin\r\n Result := not ExecuteThread.Terminated;\r\nend;\r\n\r\nprocedure TJvBaseDatasetThreadHandler.MoveToRecordPositionAfterOpen;\r\nbegin\r\n if FAfterOpenRecordPosition > 0 then\r\n MoveTo(FAfterOpenRecordPosition)\r\n else\r\n Dataset.First;\r\nend;\r\n\r\nprocedure TJvBaseDatasetThreadHandler.SetEofReached(const Value: Boolean);\r\nbegin\r\n if FEofReached <> Value then\r\n FEofReached := Value;\r\nend;\r\n\r\nprocedure TJvBaseDatasetThreadHandler.SynchAfterOpenFetch;\r\nbegin\r\n IntAfterOpenFetch(Dataset);\r\nend;\r\n\r\n//=== { TJvBaseThreadedDatasetAllowedContinueRecordFetchOptions } ============\r\n\r\nconstructor TJvBaseThreadedDatasetAllowedContinueRecordFetchOptions.Create;\r\nbegin\r\n inherited Create;\r\n FAll := False;\r\n FCancel := False;\r\n FPause := False;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvBaseDlg.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvBaseDlg.PAS, released on 2001-02-28.\r\n\r\nThe Initial Developer of the Original Code is Sbastien Buysse [sbuysse att buypin dott com]\r\nPortions created by Sbastien Buysse are Copyright (C) 2001 Sbastien Buysse.\r\nAll Rights Reserved.\r\n\r\nContributor(s): Michael Beck [mbeck att bigfoot dott com].\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvBaseDlg.pas 13365 2012-06-18 21:39:36Z jfudickar $\r\n\r\nunit JvBaseDlg;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, Dialogs,\r\n JVCLVer;\r\n\r\ntype\r\n\r\n TJvCommonDialog = class(TCommonDialog)\r\n private\r\n FAboutJVCL: TJVCLAboutInfo;\r\n public\r\n {$IFNDEF RTL180_UP}\r\n function Execute: Boolean; overload; override;\r\n function Execute(ParentWnd: HWND): Boolean; reintroduce; overload; virtual; abstract;\r\n {$ENDIF ~RTL180_UP}\r\n published\r\n property AboutJVCL: TJVCLAboutInfo read FAboutJVCL write FAboutJVCL stored False;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvBaseDlg.pas $';\r\n Revision: '$Revision: 13365 $';\r\n Date: '$Date: 2012-06-18 23:39:36 +0200 (lun. 18 juin 2012) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n Controls, Forms;\r\n\r\n\r\n{ TJvCommonDialog }\r\n\r\n{$IFNDEF RTL180_UP}\r\nfunction TJvCommonDialog.Execute: Boolean;\r\nvar\r\n ParentWnd: HWND;\r\n F: TCustomForm;\r\nbegin\r\n ParentWnd := 0;\r\n if Owner is TControl then\r\n begin\r\n F := GetParentForm(TControl(Owner));\r\n if F <> nil then\r\n ParentWnd := F.Handle;\r\n end;\r\n if ParentWnd = 0 then\r\n ParentWnd := GetForegroundWindow;\r\n if ParentWnd = 0 then\r\n ParentWnd := GetDesktopWindow;\r\n\r\n Result := Execute(ParentWnd);\r\nend;\r\n{$ENDIF ~RTL180_UP}\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvBaseEdits.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvCurrEdit.PAS, released on 2002-07-04.\r\n\r\nThe Initial Developers of the Original Code are: Fedor Koshevnikov, Igor Pavluk and Serge Korolev\r\nCopyright (c) 1997, 1998 Fedor Koshevnikov, Igor Pavluk and Serge Korolev\r\nCopyright (c) 2001,2002 SGB Software\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\n Polaris Software\r\n Andreas Hausladen\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n (rb) Compare property names with those of TJvSpinEdit, JvValidateEdit, for\r\n example DecimalPlaces/Decimal, CheckMinValue (name indicates action?\r\n maybe better: TJvValidateEdit's HasMinValue) etc.\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvBaseEdits.pas 13415 2012-09-10 09:51:54Z obones $\r\n\r\nunit JvBaseEdits;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, Messages, Classes, Controls, ImgList,\r\n {$IFDEF HAS_UNIT_SYSTEM_UITYPES}\r\n System.UITypes,\r\n {$ENDIF HAS_UNIT_SYSTEM_UITYPES}\r\n JvToolEdit;\r\n\r\ntype\r\n TJvCustomNumEdit = class(TJvCustomComboEdit)\r\n private\r\n FCanvas: TControlCanvas; // asn: never created\r\n FAlignment: TAlignment;\r\n FFocused: Boolean;\r\n FValue: Extended;\r\n FMinValue: Extended;\r\n FMaxValue: Extended;\r\n FDecimalPlaces: Cardinal;\r\n FDecimalPlacesAlwaysShown: Boolean; // WAP Added. True means Use 0 instead of # in FormatFloat picture (ie 0.000 versus 0.####). NEW.\r\n FCheckOnExit: Boolean;\r\n FZeroEmpty: Boolean;\r\n FFormatOnEditing: Boolean;\r\n FFormatting: Boolean;\r\n FDisplayFormat: string;\r\n // Polaris\r\n FDecimalPlaceRound: Boolean;\r\n function GetEditFormat: string; // WAP added.\r\n procedure SetDecimalPlaceRound(Value: Boolean);\r\n procedure SetFocused(Value: Boolean);\r\n procedure SetAlignment(Value: TAlignment);\r\n procedure SetDisplayFormat(const Value: string);\r\n function GetDisplayFormat: string;\r\n procedure SetDecimalPlaces(Value: Cardinal);\r\n procedure SetDecimalPlacesAlwaysShown( Value:Boolean );\r\n function GetValue: Extended;\r\n procedure SetValue(AValue: Extended);\r\n function GetAsInteger: Longint;\r\n procedure SetAsInteger(AValue: Longint);\r\n procedure SetMaxValue(AValue: Extended);\r\n procedure SetMinValue(AValue: Extended);\r\n procedure SetZeroEmpty(Value: Boolean);\r\n procedure SetFormatOnEditing(Value: Boolean);\r\n function GetText: string;\r\n// function TextToValText(const AValue: string): string;\r\n //Polaris function CheckValue(NewValue: Extended; RaiseOnError: Boolean): Extended;\r\n function IsFormatStored: Boolean;\r\n procedure WMPaint(var Msg: TWMPaint); message WM_PAINT;\r\n protected\r\n procedure WMPaste(var Msg: TMessage); message WM_PASTE;\r\n procedure SetBeepOnError(Value: Boolean); override;\r\n procedure SetText(const AValue: string); virtual;\r\n procedure EnabledChanged; override;\r\n procedure DoEnter; override;\r\n procedure DoExit; override;\r\n procedure FontChanged; override;\r\n //Polaris up to protected\r\n function CheckValue(NewValue: Extended; RaiseOnError: Boolean): Extended;\r\n procedure AcceptValue(const Value: Variant); override;\r\n procedure Change; override;\r\n procedure ReformatEditText; dynamic;\r\n procedure DataChanged; virtual;\r\n function DefaultDisplayFormat: string; virtual;\r\n procedure KeyPress(var Key: Char); override;\r\n function IsValidChar(Key: Char): Boolean; virtual;\r\n function FormatDisplayText(Value: Extended): string;\r\n function GetDisplayText: string; virtual;\r\n procedure Reset; override;\r\n procedure CheckRange;\r\n procedure UpdateData;\r\n procedure UpdatePopup; virtual;\r\n property Formatting: Boolean read FFormatting;\r\n property Alignment: TAlignment read FAlignment write SetAlignment default taRightJustify;\r\n property CheckOnExit: Boolean read FCheckOnExit write FCheckOnExit default False;\r\n property ImageKind default ikDefault;\r\n property ButtonWidth default 21; //Polaris 20;\r\n property DecimalPlaces: Cardinal read FDecimalPlaces write SetDecimalPlaces default 2;\r\n // WAP Added. True means Use 0 instead of # in FormatFloat picture (ie 0.000 versus 0.####). NEW.\r\n property DecimalPlacesAlwaysShown: Boolean read FDecimalPlacesAlwaysShown write SetDecimalPlacesAlwaysShown;\r\n property DisplayFormat: string read GetDisplayFormat write SetDisplayFormat stored IsFormatStored;\r\n property MaxValue: Extended read FMaxValue write SetMaxValue;\r\n property MinValue: Extended read FMinValue write SetMinValue;\r\n property FormatOnEditing: Boolean read FFormatOnEditing write SetFormatOnEditing default False;\r\n property Text: string read GetText write SetText stored False;\r\n property MaxLength default 0;\r\n property ZeroEmpty: Boolean read FZeroEmpty write SetZeroEmpty default True;\r\n //Polaris\r\n property DecimalPlaceRound: Boolean read FDecimalPlaceRound write SetDecimalPlaceRound default False;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n class function DefaultImageIndex: TImageIndex; override;\r\n procedure Clear; override;\r\n property AsInteger: Longint read GetAsInteger write SetAsInteger;\r\n property DisplayText: string read GetDisplayText;\r\n property PopupVisible;\r\n property Value: Extended read GetValue write SetValue;\r\n end;\r\n\r\n TJvxCurrencyEdit = class(TJvCustomNumEdit)\r\n protected\r\n function DefaultDisplayFormat: string; override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n published\r\n property BiDiMode;\r\n property DragCursor;\r\n property DragKind;\r\n property Flat;\r\n property ImeMode;\r\n property ImeName;\r\n property ParentBiDiMode;\r\n property ParentCtl3D;\r\n property OnEndDock;\r\n property OnStartDock;\r\n property Align; //Polaris\r\n property Alignment;\r\n property Anchors;\r\n property AutoSelect;\r\n property AutoSize;\r\n property BeepOnError;\r\n property BorderStyle;\r\n property CheckOnExit;\r\n property ClipboardCommands; // RDB\r\n property Color;\r\n property Constraints;\r\n property DecimalPlaceRound; //Polaris\r\n property DecimalPlaces;\r\n property DisabledColor; // RDB\r\n property DisabledTextColor; // RDB\r\n property DisplayFormat;\r\n property DragMode;\r\n property Enabled;\r\n property Font;\r\n property FormatOnEditing;\r\n property HideSelection;\r\n property MaxLength;\r\n property MaxValue;\r\n property MinValue;\r\n property ParentColor;\r\n property ParentFont;\r\n property ParentShowHint;\r\n property PopupMenu;\r\n property ReadOnly;\r\n property ShowHint;\r\n property TabOrder;\r\n property TabStop;\r\n property Text;\r\n property Value;\r\n property Visible;\r\n property ZeroEmpty;\r\n property OnChange;\r\n property OnClick;\r\n property OnContextPopup;\r\n property OnDblClick;\r\n property OnDragDrop;\r\n property OnDragOver;\r\n property OnEndDrag;\r\n property OnEnter;\r\n property OnExit;\r\n property OnKeyDown;\r\n property OnKeyPress;\r\n property OnKeyUp;\r\n property OnMouseDown;\r\n property OnMouseMove;\r\n property OnMouseUp;\r\n property OnStartDrag;\r\n end;\r\n\r\n TJvCustomCalcEdit = class(TJvCustomNumEdit)\r\n private\r\n FEnablePopupChange: Boolean;\r\n protected\r\n procedure PopupChange; override;\r\n property EnablePopupChange: Boolean read FEnablePopupChange write FEnablePopupChange default False;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n end;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvCalcEdit = class(TJvCustomCalcEdit)\r\n published\r\n property BevelEdges;\r\n property BevelInner;\r\n property BevelKind default bkNone;\r\n property BevelOuter;\r\n property BiDiMode;\r\n property DragCursor;\r\n property DragKind;\r\n property Flat;\r\n property ParentBiDiMode;\r\n property ParentFlat;\r\n property ImeMode;\r\n property ImeName;\r\n property OnEndDock;\r\n property OnStartDock;\r\n property Action;\r\n property Align; //Polaris\r\n property Alignment;\r\n property AutoSelect;\r\n property AutoSize;\r\n property BeepOnError;\r\n property BorderStyle;\r\n property ButtonFlat;\r\n property ButtonHint;\r\n property CheckOnExit;\r\n property ClickKey;\r\n property Color;\r\n property DecimalPlaceRound; //Polaris\r\n property DecimalPlaces;\r\n property DirectInput;\r\n property DisplayFormat;\r\n property DragMode;\r\n property Enabled;\r\n property EnablePopupChange;\r\n property Font;\r\n property FormatOnEditing;\r\n property Glyph;\r\n property ImageIndex;\r\n property Images;\r\n property ImageKind;\r\n property ButtonWidth;\r\n property HideSelection;\r\n property Anchors;\r\n property Constraints;\r\n property MaxLength;\r\n property MaxValue;\r\n property MinValue;\r\n property NumGlyphs;\r\n property ParentColor;\r\n property ParentFont;\r\n property ParentShowHint;\r\n property PopupAlign;\r\n property PopupMenu;\r\n property ReadOnly;\r\n property ShowButton;\r\n property ShowHint;\r\n property TabOrder;\r\n property TabStop;\r\n property Text;\r\n property Value;\r\n property Visible;\r\n property ZeroEmpty;\r\n (* ++ RDB ++ *)\r\n property ClipboardCommands;\r\n property DisabledTextColor;\r\n property DisabledColor;\r\n (* -- RDB -- *)\r\n property DecimalPlacesAlwaysShown; {WAP Added.}\r\n property OnButtonClick;\r\n property OnChange;\r\n property OnClick;\r\n property OnDblClick;\r\n property OnDragDrop;\r\n property OnDragOver;\r\n property OnEndDrag;\r\n property OnEnter;\r\n property OnExit;\r\n property OnKeyDown;\r\n property OnKeyPress;\r\n property OnKeyUp;\r\n property OnMouseDown;\r\n property OnMouseMove;\r\n property OnMouseUp;\r\n property OnContextPopup;\r\n property OnStartDrag;\r\n property OnPopupHidden;\r\n property OnPopupShown;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvBaseEdits.pas $';\r\n Revision: '$Revision: 13415 $';\r\n Date: '$Date: 2012-09-10 11:51:54 +0200 (lun. 10 sept. 2012) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n SysUtils, Math, Graphics,\r\n JvJCLUtils, JvCalc, JvConsts, JvResources, JclSysUtils;\r\n\r\n{$R JvBaseEdits.Res}\r\n\r\nconst\r\n sCalcBmp = 'JvCustomNumEditBUTTONGLYPH'; { Numeric editor button glyph }\r\n\r\nvar\r\n GCalcImageIndex: TImageIndex = -1;\r\n\r\ntype\r\n TJvPopupWindowAccessProtected = class(TJvPopupWindow);\r\n\r\nfunction IsValidFloat(const Value: string; var RetValue: Extended): Boolean;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := False;\r\n for I := 1 to Length(Value) do\r\n if not CharInSet(Value[I], [JclFormatSettings.DecimalSeparator, '-', '+', '0'..'9', 'e', 'E']) then\r\n Exit;\r\n Result := TextToFloat(PChar(Value), RetValue, fvExtended);\r\nend;\r\n\r\nfunction FormatFloatStr(const S: string; Thousands: Boolean): string;\r\nvar\r\n I, MaxSym, MinSym, Group: Integer;\r\n IsSign: Boolean;\r\nbegin\r\n Result := '';\r\n MaxSym := Length(S);\r\n IsSign := (MaxSym > 0) and CharInSet(S[1], SignSymbols);\r\n if IsSign then\r\n MinSym := 2\r\n else\r\n MinSym := 1;\r\n I := Pos(JclFormatSettings.DecimalSeparator, S);\r\n if I > 0 then\r\n MaxSym := I - 1;\r\n I := Pos('E', AnsiUpperCase(S));\r\n if I > 0 then\r\n MaxSym := Min(I - 1, MaxSym);\r\n Result := Copy(S, MaxSym + 1, MaxInt);\r\n Group := 0;\r\n for I := MaxSym downto MinSym do\r\n begin\r\n Result := S[I] + Result;\r\n Inc(Group);\r\n if (Group = 3) and Thousands and (I > MinSym) then\r\n begin\r\n Group := 0;\r\n Result := JclFormatSettings.ThousandSeparator + Result;\r\n end;\r\n end;\r\n if IsSign then\r\n Result := S[1] + Result;\r\nend;\r\n\r\n//=== { TJvCustomNumEdit } ===================================================\r\n\r\nconstructor TJvCustomNumEdit.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n ControlStyle := ControlStyle - [csSetCaption];\r\n FDecimalPlaceRound := False; // Polaris\r\n MaxLength := 0;\r\n FAlignment := taRightJustify;\r\n FDisplayFormat := DefaultDisplayFormat;\r\n FDecimalPlaces := 2;\r\n FZeroEmpty := True;\r\n inherited Text := '';\r\n inherited Alignment := taLeftJustify;\r\n { forces update }\r\n DataChanged;\r\n ControlState := ControlState + [csCreating];\r\n try\r\n { TODO : Check }\r\n ImageKind := ikDefault;\r\n //Polaris ButtonWidth := 20;\r\n ButtonWidth := 21;\r\n finally\r\n ControlState := ControlState - [csCreating];\r\n end;\r\nend;\r\n\r\ndestructor TJvCustomNumEdit.Destroy;\r\nbegin\r\n FCanvas.Free;\r\n if FPopup <> nil then\r\n begin\r\n TJvPopupWindow(FPopup).OnCloseUp := nil;\r\n FPopup.Parent := nil;\r\n end;\r\n FreeAndNil(FPopup);\r\n inherited Destroy;\r\nend;\r\n\r\n//Polaris\r\n\r\nprocedure TJvCustomNumEdit.SetDecimalPlaceRound(Value: Boolean);\r\nbegin\r\n if FDecimalPlaceRound <> Value then\r\n begin\r\n FDecimalPlaceRound := Value;\r\n SetValue(CheckValue(FValue, False));\r\n Invalidate;\r\n ReformatEditText;\r\n end;\r\nend;\r\n\r\nfunction TJvCustomNumEdit.DefaultDisplayFormat: string;\r\nbegin\r\n Result := ',0.##';\r\nend;\r\n\r\nfunction TJvCustomNumEdit.IsFormatStored: Boolean;\r\nbegin\r\n Result := (DisplayFormat <> DefaultDisplayFormat);\r\nend;\r\n\r\n{ (rb) This function works NOT the same as JvJCLUtils.TextToValText; for example\r\n it does NOT remove 'a'..'z' chars.\r\n Couldn't come up with a good name, so feel free to change it\r\n}\r\nfunction xTextToValText(const AValue: string): string;\r\nbegin\r\n Result := DelRSpace(AValue);\r\n if AnsiChar(JclFormatSettings.DecimalSeparator) <> AnsiChar(JclFormatSettings.ThousandSeparator) then\r\n Result := DelChars(Result, JclFormatSettings.ThousandSeparator);\r\n if (JclFormatSettings.DecimalSeparator <> '.') and (JclFormatSettings.ThousandSeparator <> '.') then\r\n Result := ReplaceStr(Result, '.', JclFormatSettings.DecimalSeparator);\r\n if (JclFormatSettings.DecimalSeparator <> ',') and (JclFormatSettings.ThousandSeparator <> ',') then\r\n Result := ReplaceStr(Result, ',', JclFormatSettings.DecimalSeparator);\r\n if Result = '' then\r\n Result := '0'\r\n else\r\n if Result = '-' then\r\n Result := '-0';\r\nend;\r\n\r\nfunction TJvCustomNumEdit.IsValidChar(Key: Char): Boolean;\r\nvar\r\n S: string;\r\n SelStart, SelStop, DecPos: Integer;\r\n RetValue: Extended;\r\nbegin\r\n Result := False;\r\n S := EditText;\r\n GetSel(SelStart, SelStop);\r\n Delete(S, SelStart + 1, SelStop - SelStart);\r\n Insert(Key, S, SelStart + 1);\r\n S := xTextToValText(S);\r\n DecPos := Pos(JclFormatSettings.DecimalSeparator, S);\r\n if DecPos > 0 then\r\n begin\r\n SelStart := Pos('E', UpperCase(S));\r\n if SelStart > DecPos then\r\n DecPos := SelStart - DecPos\r\n else\r\n DecPos := Length(S) - DecPos;\r\n if DecPos > Integer(FDecimalPlaces) then\r\n Exit;\r\n end;\r\n Result := IsValidFloat(S, RetValue);\r\n if Result and (FMinValue >= 0) and (FMaxValue > 0) and (RetValue < 0) then\r\n Result := False;\r\nend;\r\n\r\nprocedure TJvCustomNumEdit.KeyPress(var Key: Char);\r\nbegin\r\n if PopupVisible and CharInSet(UpCase(Key),\r\n DigitSymbols +\r\n [JclFormatSettings.DecimalSeparator, '.', ',', '+', '-', '*', '/', '_', '=', 'C', 'R', 'Q', '%', Backspace, Cr] -\r\n [JclFormatSettings.ThousandSeparator]) then\r\n begin\r\n TJvPopupWindowAccessProtected(FPopup).KeyPress(Key);\r\n Key := #0;\r\n end;\r\n if CharInSet(Key, ['.', ','] - [JclFormatSettings.ThousandSeparator]) then\r\n Key := JclFormatSettings.DecimalSeparator;\r\n inherited KeyPress(Key);\r\n if CharInSet(Key, [#32..#255]) and not IsValidChar(Key) then\r\n begin\r\n DoBeepOnError;\r\n Key := #0;\r\n end\r\n else\r\n if Key = Esc then\r\n begin\r\n Reset;\r\n Key := #0;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomNumEdit.Reset;\r\nbegin\r\n DataChanged;\r\n SelectAll;\r\nend;\r\n\r\nprocedure TJvCustomNumEdit.SetZeroEmpty(Value: Boolean);\r\nbegin\r\n if FZeroEmpty <> Value then\r\n begin\r\n FZeroEmpty := Value;\r\n DataChanged;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomNumEdit.SetBeepOnError(Value: Boolean);\r\nbegin\r\n if BeepOnError <> Value then\r\n begin\r\n inherited SetBeepOnError(Value);\r\n UpdatePopup;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomNumEdit.SetAlignment(Value: TAlignment);\r\nbegin\r\n if FAlignment <> Value then\r\n begin\r\n FAlignment := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomNumEdit.SetDisplayFormat(const Value: string);\r\nbegin\r\n if DisplayFormat <> Value then\r\n begin\r\n FDisplayFormat := Value;\r\n Invalidate;\r\n DataChanged;\r\n end;\r\nend;\r\n\r\nfunction TJvCustomNumEdit.GetDisplayFormat: string;\r\nbegin\r\n Result := FDisplayFormat;\r\nend;\r\n\r\nprocedure TJvCustomNumEdit.SetFocused(Value: Boolean);\r\nbegin\r\n if FFocused <> Value then\r\n begin\r\n FFocused := Value;\r\n Invalidate;\r\n FFormatting := True;\r\n try\r\n DataChanged;\r\n finally\r\n FFormatting := False;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomNumEdit.SetFormatOnEditing(Value: Boolean);\r\nbegin\r\n if FFormatOnEditing <> Value then\r\n begin\r\n FFormatOnEditing := Value;\r\n if FFormatOnEditing then\r\n inherited Alignment := Alignment\r\n else\r\n inherited Alignment := taLeftJustify;\r\n if FFormatOnEditing and FFocused then\r\n ReformatEditText\r\n else\r\n if FFocused then\r\n begin\r\n UpdateData;\r\n DataChanged;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomNumEdit.SetDecimalPlaces(Value: Cardinal);\r\nbegin\r\n if FDecimalPlaces <> Value then\r\n begin\r\n FDecimalPlaces := Value;\r\n // WAP Added. Changes to decimal places formerly did not change\r\n // FDisplayFormat, which causes both designtime and runtime problems!\r\n SetDisplayFormat(GetEditFormat);\r\n SetValue(CheckValue(FValue, False)); // Polaris (?)\r\n DataChanged;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\n{WAP added this new property: Switches between using 0.000\r\n and 0.### as a FormatFloat picture. }\r\nprocedure TJvCustomNumEdit.SetDecimalPlacesAlwaysShown( Value:Boolean );\r\nbegin\r\n if FDecimalPlacesAlwaysShown <> Value then\r\n begin\r\n FDecimalPlacesAlwaysShown := Value;\r\n SetDisplayFormat(GetEditFormat); // Redo format picture\r\n SetValue(CheckValue(FValue, False)); // Polaris (?)\r\n DataChanged;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nfunction TJvCustomNumEdit.FormatDisplayText(Value: Extended): string;\r\nbegin\r\n if DisplayFormat <> '' then\r\n Result := FormatFloat(DisplayFormat, Value)\r\n else\r\n Result := FloatToStr(Value);\r\nend;\r\n\r\nfunction TJvCustomNumEdit.GetDisplayText: string;\r\nbegin\r\n Result := FormatDisplayText(FValue);\r\nend;\r\n\r\nprocedure TJvCustomNumEdit.Clear;\r\nbegin\r\n Text := '';\r\nend;\r\n\r\n{WAP added GetEditFormat, this code used to be ininline inside DataChanged.}\r\nfunction TJvCustomNumEdit.GetEditFormat:String;\r\nbegin\r\n Result := ',0'; // must put the thousands separator by default to allow direct edit of value (paste for example)\r\n if FDecimalPlaces > 0 then\r\n if FDecimalPlacesAlwaysShown then\r\n Result := Result + '.' + MakeStr('0', FDecimalPlaces)\r\n else\r\n Result := Result + '.' + MakeStr('#', FDecimalPlaces);\r\nend;\r\n\r\nprocedure TJvCustomNumEdit.DataChanged;\r\nvar\r\n EditFormat: string;\r\n WasModified: Boolean;\r\nbegin\r\n EditFormat := GetEditFormat;\r\n { Changing EditText sets Modified to false }\r\n WasModified := Modified;\r\n try\r\n if (FValue = 0.0) and FZeroEmpty then\r\n EditText := ''\r\n else\r\n EditText := FormatFloat(EditFormat, CheckValue(FValue, False));\r\n finally\r\n Modified := WasModified;\r\n end;\r\nend;\r\n\r\nfunction TJvCustomNumEdit.CheckValue(NewValue: Extended;\r\n RaiseOnError: Boolean): Extended;\r\nvar\r\n DP: Integer;\r\nbegin\r\n if FDecimalPlaceRound then\r\n begin //Polaris\r\n DP := FDecimalPlaces;\r\n { (rb) Probably: Round to the nearest, and if two are equally near, away from zero\r\n Ln, Exp are slow; make more generic (why only this one?), see\r\n http://www.merlyn.demon.co.uk/pas-chop.htm\r\n }\r\n NewValue := Int(NewValue * Exp(DP * Ln(10)) + Sign(NewValue) * 0.50000001) * Exp(-DP * Ln(10));\r\n end;\r\n Result := NewValue;\r\n if FMaxValue <> FMinValue then\r\n begin\r\n if FMaxValue > FMinValue then\r\n begin\r\n if NewValue < FMinValue then\r\n Result := FMinValue\r\n else\r\n if NewValue > FMaxValue then\r\n Result := FMaxValue;\r\n end\r\n else\r\n begin\r\n if FMaxValue = 0 then\r\n begin\r\n if NewValue < FMinValue then\r\n Result := FMinValue;\r\n end\r\n else\r\n if FMinValue = 0 then\r\n begin\r\n if NewValue > FMaxValue then\r\n Result := FMaxValue;\r\n end;\r\n end;\r\n if RaiseOnError and (Result <> NewValue) then\r\n raise ERangeError.CreateResFmt(@RsEOutOfRangeXFloat,\r\n [DecimalPlaces, FMinValue, DecimalPlaces, FMaxValue]);\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomNumEdit.CheckRange;\r\nbegin\r\n if not (csDesigning in ComponentState) and CheckOnExit then\r\n CheckValue(StrToFloat(TextToValText(EditText)), True);\r\nend;\r\n\r\nprocedure TJvCustomNumEdit.UpdateData;\r\nbegin\r\n ValidateEdit;\r\n FValue := CheckValue(StrToFloat(TextToValText(EditText)), False);\r\nend;\r\n\r\nprocedure TJvCustomNumEdit.UpdatePopup;\r\nbegin\r\n if FPopup <> nil then\r\n SetupPopupCalculator(FPopup, DefCalcPrecision, BeepOnError);\r\nend;\r\n\r\nfunction TJvCustomNumEdit.GetValue: Extended;\r\nbegin\r\n if not (csDesigning in ComponentState) then\r\n try\r\n UpdateData;\r\n except\r\n FValue := FMinValue;\r\n end;\r\n Result := FValue;\r\nend;\r\n\r\nprocedure TJvCustomNumEdit.SetValue(AValue: Extended);\r\nbegin\r\n FValue := CheckValue(AValue, False);\r\n DataChanged;\r\n Invalidate;\r\nend;\r\n\r\nfunction TJvCustomNumEdit.GetAsInteger: Longint;\r\nbegin\r\n Result := trunc(Value);\r\nend;\r\n\r\nprocedure TJvCustomNumEdit.SetAsInteger(AValue: Longint);\r\nbegin\r\n SetValue(AValue);\r\nend;\r\n\r\nprocedure TJvCustomNumEdit.SetMinValue(AValue: Extended);\r\nbegin\r\n if FMinValue <> AValue then\r\n begin\r\n FMinValue := AValue;\r\n Value := FValue;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomNumEdit.SetMaxValue(AValue: Extended);\r\nbegin\r\n if FMaxValue <> AValue then\r\n begin\r\n FMaxValue := AValue;\r\n Value := FValue;\r\n end;\r\nend;\r\n\r\nfunction TJvCustomNumEdit.GetText: string;\r\nbegin\r\n Result := inherited Text;\r\nend;\r\n\r\n(*\r\nfunction TJvCustomNumEdit.TextToValText(const AValue: string): string;\r\nvar\r\n I: Integer;\r\n X: Char;\r\nbegin\r\n Result := DelRSpace(AValue);\r\n if DecimalSeparator <> ThousandSeparator then\r\n Result := DelChars(Result, ThousandSeparator);\r\n if (DecimalSeparator <> '.') and (ThousandSeparator <> '.') then\r\n Result := ReplaceStr(Result, '.', DecimalSeparator);\r\n if (DecimalSeparator <> ',') and (ThousandSeparator <> ',') then\r\n Result := ReplaceStr(Result, ',', DecimalSeparator);\r\n\r\n// Aquarius\r\n I := 1;\r\n while I <= Length(Result) do\r\n begin\r\n X := Result[I];\r\n if (X = DecimalSeparator) or (X = '-') or (X in DigitSymbols) then\r\n begin\r\n I := I + 1;\r\n Continue;\r\n end\r\n else\r\n Result := Copy(Result, 1, I - 1) + Copy(Result, I + 1, Length(Result) - 1);\r\n end;\r\n\r\n if Result = '' then\r\n Result := '0'\r\n else\r\n if Result = '-' then\r\n Result := '-0';\r\nend;\r\n*)\r\n\r\nprocedure TJvCustomNumEdit.SetText(const AValue: string);\r\nbegin\r\n if not (csReading in ComponentState) then\r\n begin\r\n FValue := CheckValue(StrToFloat(TextToValText(AValue)), False);\r\n DataChanged;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomNumEdit.ReformatEditText;\r\nvar\r\n S: string;\r\n IsEmpty: Boolean;\r\n OldLen, SelStart, SelStop: Integer;\r\n WasModified: Boolean;\r\nbegin\r\n FFormatting := True;\r\n { Changing Text sets Modified to false }\r\n WasModified := Modified;\r\n try\r\n S := inherited Text;\r\n OldLen := Length(S);\r\n IsEmpty := (OldLen = 0) or (S = '-');\r\n if HandleAllocated then\r\n GetSel(SelStart, SelStop);\r\n if not IsEmpty then\r\n S := TextToValText(S);\r\n S := FormatFloatStr(S, Pos(',', DisplayFormat) > 0);\r\n inherited Text := S;\r\n if HandleAllocated and (GetFocus = Handle) and\r\n not (csDesigning in ComponentState) then\r\n begin\r\n Inc(SelStart, Length(S) - OldLen);\r\n SetCursor(SelStart);\r\n end;\r\n finally\r\n FFormatting := False;\r\n Modified := WasModified;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomNumEdit.Change;\r\nbegin\r\n if not FFormatting then\r\n begin\r\n if FFormatOnEditing and FFocused then\r\n ReformatEditText;\r\n inherited Change;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomNumEdit.AcceptValue(const Value: Variant);\r\nbegin\r\n inherited AcceptValue(Value);\r\n Self.Value := CheckValue(Value, False); //Polaris\r\nend;\r\n\r\nprocedure TJvCustomNumEdit.WMPaste(var Msg: TMessage);\r\nvar\r\n S: string;\r\n WasModified: Boolean;\r\nbegin\r\n WasModified := Modified;\r\n S := EditText;\r\n try\r\n inherited;\r\n UpdateData;\r\n except\r\n { Changing EditText sets Modified to false }\r\n EditText := S;\r\n Modified := WasModified;\r\n SelectAll;\r\n if CanFocus then\r\n SetFocus;\r\n DoBeepOnError;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomNumEdit.DoEnter;\r\nbegin\r\n SetFocused(True);\r\n if FFormatOnEditing then\r\n ReformatEditText;\r\n inherited DoEnter;\r\nend;\r\n\r\nprocedure TJvCustomNumEdit.DoExit;\r\nbegin\r\n try\r\n CheckRange;\r\n UpdateData;\r\n except\r\n SelectAll;\r\n if CanFocus then\r\n SetFocus;\r\n raise;\r\n end;\r\n SetFocused(False);\r\n SetCursor(0);\r\n inherited DoExit;\r\nend;\r\n\r\nprocedure TJvCustomNumEdit.EnabledChanged;\r\nbegin\r\n inherited EnabledChanged;\r\n if not FFocused then\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvCustomNumEdit.WMPaint(var Msg: TWMPaint);\r\nvar\r\n S: string;\r\nbegin\r\n if PopupVisible then\r\n S := TJvPopupWindow(FPopup).GetPopupText\r\n else\r\n S := GetDisplayText;\r\n if not PaintComboEdit(Self, S, FAlignment,\r\n FFocused and not PopupVisible, FCanvas, Msg) then\r\n inherited;\r\nend;\r\n\r\nprocedure TJvCustomNumEdit.FontChanged;\r\nbegin\r\n inherited FontChanged;\r\n Invalidate;\r\nend;\r\n\r\n//=== { TJvxCurrencyEdit } ===================================================\r\n\r\nconstructor TJvxCurrencyEdit.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n ControlState := ControlState + [csCreating];\r\n try\r\n ButtonWidth := 0;\r\n finally\r\n ControlState := ControlState - [csCreating];\r\n end;\r\nend;\r\n\r\nfunction TJvxCurrencyEdit.DefaultDisplayFormat: string;\r\nvar\r\n CurrStr: string;\r\n I: Integer;\r\n C: Char;\r\nbegin\r\n Result := ',0.' + MakeStr('0', JclFormatSettings.CurrencyDecimals);\r\n CurrStr := '';\r\n for I := 1 to Length(JclFormatSettings.CurrencyString) do\r\n begin\r\n C := JclFormatSettings.CurrencyString[I];\r\n if CharInSet(C, [',', '.']) then\r\n CurrStr := CurrStr + '''' + C + ''''\r\n else\r\n CurrStr := CurrStr + C;\r\n end;\r\n if Length(CurrStr) > 0 then\r\n case JclFormatSettings.CurrencyFormat of\r\n 0:\r\n Result := CurrStr + Result; { '$1' }\r\n 1:\r\n Result := Result + CurrStr; { '1$' }\r\n 2:\r\n Result := CurrStr + ' ' + Result; { '$ 1' }\r\n 3:\r\n Result := Result + ' ' + CurrStr; { '1 $' }\r\n end;\r\n Result := Format('%s;-%s', [Result, Result]);\r\nend;\r\n\r\n//=== { TJvCustomCalcEdit } ==================================================\r\n\r\nconstructor TJvCustomCalcEdit.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n ControlStyle := ControlStyle - [csAcceptsControls];\r\n ControlState := ControlState + [csCreating];\r\n try\r\n FPopup := TJvPopupWindow(CreatePopupCalculator(Self , BiDiMode ));\r\n TJvPopupWindow(FPopup).OnCloseUp := PopupCloseUp;\r\n UpdatePopup;\r\n finally\r\n ControlState := ControlState - [csCreating];\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomCalcEdit.PopupChange;\r\nbegin\r\n inherited PopupChange;\r\n if EnablePopupChange then\r\n DoChange;\r\nend;\r\n\r\nclass function TJvCustomNumEdit.DefaultImageIndex: TImageIndex;\r\nvar\r\n Bmp: TBitmap;\r\nbegin\r\n if GCalcImageIndex < 0 then\r\n begin\r\n Bmp := TBitmap.Create;\r\n try\r\n Bmp.LoadFromResourceName(HInstance, sCalcBmp);\r\n GCalcImageIndex := DefaultImages.AddMasked(Bmp, clFuchsia);\r\n finally\r\n Bmp.Free;\r\n end;\r\n end;\r\n\r\n Result := GCalcImageIndex;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvBaseThumbnail.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvBasethb.PAS, released on 2002-07-03.\r\n\r\nThe Initial Developer of the Original Code is John Kozikopulos [Stdreamer att Excite dott com]\r\nPortions created by John Kozikopulos are Copyright (C) 2002 John Kozikopulos.\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\n\r\nYou may Thumb the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n This file contains (most likely) greek comments.\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvBaseThumbnail.pas 13104 2011-09-07 06:50:43Z obones $\r\n\r\nunit JvBaseThumbnail;\r\n\r\n{$I jvcl.inc}\r\n{$I crossplatform.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, // TWin32FindData\r\n {$IFDEF HAS_UNIT_LIBC}\r\n Libc, // stat()\r\n {$ENDIF HAS_UNIT_LIBC}\r\n Messages, Classes, Graphics, Controls, Forms, ExtCtrls,\r\n JclBase,\r\n JvExForms, JvExExtCtrls;\r\n\r\n// (rom) TFileName is already declared in SysUtils\r\n\r\ntype\r\n { The TFileName object has been created to handle the first field of a Thumb\r\n Which is the Thumbs actual FileName complete with the Path because no\r\n duplicates are allowed in the final list.\r\n It Has the following properties\r\n 01) FileName : it keeps the filename as given by the user\r\n 02) LongName : it always returns the LongName of the file\r\n 03) ShortName: it always returns the short name of the file\r\n 04) Size : it returns the size in Bytes that it will occupy if saved in a stream\r\n 05) Length : the \"FileName\" property Length;\r\n and the following methods\r\n 01) LoadFromStream(AStream: TStream; APos: Integer); loads a filename from a stream\r\n if APos < 0 then don't change the cursor position in the stream\r\n else AStream.Seek(APos, 0);\r\n 02) SaveToStream(AStream: TStream; APos: Integer); Save the FileName to AStream\r\n if APos > -1 then AStream.Seek(APos, 0);\r\n SaveData;\r\n }\r\n TProgressNotify = procedure(Sender: TObject; Position: Integer; var Stop: Boolean) of object;\r\n TInvalidImageEvent = procedure(Sender: TObject; const AFileName: string) of object;\r\n // (rom) renamed\r\n TGRFKind = (grBMP, grJPG, grWMF, grEMF, grICO, grPNG); //,grPCX,grTGA);\r\n TPercent = -100..100;\r\n\r\n {$M+}\r\n TFileName = class(TObject)\r\n private\r\n FLongName: string;\r\n FShortName: string;\r\n FFileName: string;\r\n FCreated: TDateTime;\r\n FAccessed: TDateTime;\r\n FModified: TDateTime;\r\n FFileSize: Longint;\r\n protected\r\n procedure SetName(NewName: string); virtual;\r\n function GetLength: Integer;\r\n procedure SetLength(NewLength: Integer);\r\n procedure Init;\r\n public\r\n procedure LoadFromStream(AStream: TStream; APos: Integer); //Load From stream\r\n // both of this routines are inserting extract data to the stream its self\r\n // like a header and data end string;\r\n procedure SaveToStream(AStream: TStream; APos: Integer); // Save to a Stream\r\n // (rom) moved to public\r\n property LongName: string read FLongName; // The LongName of this filename\r\n property ShortName: string read FShortName; // shortname of this filename\r\n published\r\n property FileName: string read FFileName write SetName; // The FileName as given by the user\r\n property Length: Integer read GetLength write SetLength;\r\n end;\r\n {$M-}\r\n\r\n { The Following classes are declared here so I can handle interaction of the mouse\r\n between the three components.\r\n }\r\n TJvThumbTitle = class(TJvExPanel)\r\n protected\r\n function DoEraseBackground(Canvas: TCanvas; Param: LPARAM): Boolean; override;\r\n procedure Click; override;\r\n procedure DblClick; override;\r\n procedure MouseDown(Button: TMouseButton; Shift: TShiftState;\r\n X, Y: Integer); override;\r\n procedure MouseUp(Button: TMouseButton; Shift: TShiftState;\r\n X, Y: Integer); override;\r\n procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;\r\n function DoMouseWheel(Shift: TShiftState; WheelDelta: Integer; MousePos: TPoint): Boolean; override;\r\n function DoMouseWheelDown(Shift: TShiftState; MousePos: TPoint): Boolean; override;\r\n function DoMouseWheelUp(Shift: TShiftState; MousePos: TPoint): Boolean; override;\r\n procedure KeyDown(var Key: Word; Shift: TShiftState); override;\r\n procedure KeyUp(var Key: Word; Shift: TShiftState); override;\r\n procedure KeyPress(var Key: Char); override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n end;\r\n\r\n TJvBaseThumbImage = class(TJvExImage)\r\n private\r\n FIgnoreMouse: Boolean;\r\n protected\r\n function HitTest(X, Y: Integer): Boolean; override;\r\n procedure MouseDown(Button: TMouseButton; Shift: TShiftState;\r\n X, Y: Integer); override;\r\n procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;\r\n procedure MouseUp(Button: TMouseButton; Shift: TShiftState;\r\n X, Y: Integer); override;\r\n procedure Click; override;\r\n procedure DblClick; override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n published\r\n property IgnoreMouse: Boolean read FIgnoreMouse write FIgnoreMouse;\r\n end;\r\n\r\n TJvBaseThumbnail = class(TJvExPanel)\r\n protected\r\n function DoEraseBackground(Canvas: TCanvas; Param: LPARAM): Boolean; override;\r\n procedure MouseDown(Button: TMouseButton; Shift: TShiftState;\r\n X, Y: Integer); override;\r\n procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;\r\n procedure MouseUp(Button: TMouseButton; Shift: TShiftState;\r\n X, Y: Integer); override;\r\n procedure Click; override;\r\n procedure DblClick; override;\r\n function DoMouseWheel(Shift: TShiftState; WheelDelta: Integer; MousePos: TPoint): Boolean; override;\r\n function DoMouseWheelDown(Shift: TShiftState; MousePos: TPoint): Boolean; override;\r\n function DoMouseWheelUp(Shift: TShiftState; MousePos: TPoint): Boolean; override;\r\n procedure KeyDown(var Key: Word; Shift: TShiftState); override;\r\n procedure KeyUp(var Key: Word; Shift: TShiftState); override;\r\n procedure KeyPress(var Key: Char); override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n end;\r\n\r\n TJvBaseThumbView = class(TJvExScrollBox)\r\n protected\r\n // function DoEraseBackground(Canvas: TCanvas; Param: LPARAM): Boolean; override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n end;\r\n\r\nfunction BoundByte(Min, Max, Value: Integer): Byte;\r\nprocedure InsertStr(var Str: string; const NewStr: string; Pos: Longint);\r\nfunction ProportionalSize(PhysicalSize, NewSize: TPoint): TPoint;\r\nfunction ReplaceChar(const AStr: string; const CharToFind, NewChar: Char;\r\n ReplaceNo: Longint; CaseSensitive: Boolean): string;\r\nfunction JkCeil(I: Extended): Longint;\r\nfunction ReplaceAllStr(const Str, SearchFor, ReplaceWith: string;\r\n CaseSensitive: Boolean): string;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvBaseThumbnail.pas $';\r\n Revision: '$Revision: 13104 $';\r\n Date: '$Date: 2011-09-07 08:50:43 +0200 (mer. 07 sept. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n SysUtils,\r\n JvJCLUtils,\r\n JvThemes;\r\n\r\nfunction ReplaceAllStr(const Str, SearchFor, ReplaceWith: string;\r\n CaseSensitive: Boolean): string;\r\nvar\r\n Cnt: Integer;\r\n S1, S2, SF: string;\r\nbegin\r\n S1 := Str;\r\n if CaseSensitive then\r\n begin\r\n S2 := S1;\r\n SF := SearchFor;\r\n end\r\n else\r\n begin\r\n S2 := UpperCase(S1);\r\n SF := UpperCase(SearchFor);\r\n end;\r\n Result := '';\r\n repeat\r\n Cnt := Pos(SF, S2);\r\n if Cnt > 0 then\r\n begin\r\n Result := Result + Copy(S1, 1, Cnt - 1) + ReplaceWith;\r\n S1 := Copy(S1, Cnt + Length(SF), Length(S1));\r\n if CaseSensitive then\r\n S2 := S1\r\n else\r\n S2 := UpperCase(S1);\r\n end\r\n else\r\n Result := Result + S1;\r\n until Cnt <= 0;\r\nend;\r\n\r\nfunction JkCeil(I: Extended): Longint;\r\nvar\r\n T: Longint;\r\nbegin\r\n T := Trunc(I);\r\n if T <> I then\r\n if I > 0 then\r\n T := T + 1\r\n else\r\n T := T - 1;\r\n Result := T;\r\nend;\r\n\r\nfunction ReplaceChar(const AStr: string; const CharToFind, NewChar: Char;\r\n ReplaceNo: Longint; CaseSensitive: Boolean): string;\r\nvar\r\n Count: Longint;\r\n RepCount: Longint;\r\n Res: string;\r\nbegin\r\n Res := AStr;\r\n if ReplaceNo > 0 then\r\n RepCount := 0\r\n else\r\n RepCount := -1;\r\n Count := 1;\r\n if Length(Res) > 0 then\r\n repeat\r\n if Res[Count] = CharToFind then\r\n begin\r\n Res[Count] := NewChar;\r\n if RepCount >= 0 then\r\n Inc(RepCount, 1);\r\n end;\r\n Inc(Count, 1);\r\n until (Count > Length(Res)) or (RepCount >= ReplaceNo);\r\n Result := Res;\r\nend;\r\n\r\nfunction ProportionalSize(PhysicalSize, NewSize: TPoint): TPoint;\r\nvar\r\n Percent: Single;\r\n TempX, TempY: Single;\r\nbegin\r\n // \r\n // . [This seems to be greek, couldn't find translator]\r\n if PhysicalSize.X <> 0 then\r\n TempX := ((NewSize.X) / PhysicalSize.X) * 100.0\r\n else\r\n TempX := 0;\r\n if PhysicalSize.Y <> 0 then\r\n TempY := ((NewSize.Y) / PhysicalSize.Y) * 100.0\r\n else\r\n TempY := 0;\r\n // .\r\n // [this seems to be greek, couldn't find translator]\r\n if TempX <= TempY then\r\n Percent := TempX\r\n else\r\n Percent := TempY;\r\n //Fs.X:=round((PhysicalSize.X/100)*Percent);\r\n //Fs.Y:=round((PhysicalSize.Y/100)*Percent);\r\n Result.X := Trunc((PhysicalSize.X / 100.0) * Percent);\r\n Result.Y := Trunc((PhysicalSize.Y / 100.0) * Percent);\r\nend;\r\n\r\nprocedure InsertStr(var Str: string; const NewStr: string; Pos: Longint);\r\nbegin\r\n SetLength(Str, Length(Str) + Length(NewStr));\r\n MoveChar(Str, Pos, Str, Pos + Length(NewStr), Length(Str) - Pos - Length(NewStr));\r\n MoveChar(NewStr, 0, Str, Pos, Length(NewStr));\r\nend;\r\n\r\nfunction BoundByte(Min, Max, Value: Integer): Byte;\r\nbegin\r\n if Value < Min then\r\n Result := Min\r\n else\r\n if Value > Max then\r\n Result := Max\r\n else\r\n Result := Value;\r\nend;\r\n\r\n//=== { TJvThumbTitle } ======================================================\r\n\r\nconstructor TJvThumbTitle.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n if AOwner is TJvBaseThumbnail then\r\n ControlStyle := ControlStyle - [csSetCaption, csCaptureMouse, csClickEvents, csDoubleClicks]\r\n else\r\n ControlStyle := ControlStyle - [csSetCaption];\r\n IncludeThemeStyle(Self, [csNeedsBorderPaint]);\r\nend;\r\n\r\nfunction TJvThumbTitle.DoEraseBackground(Canvas: TCanvas; Param: LPARAM): Boolean;\r\nbegin\r\n inherited DoEraseBackground(Canvas, Param);\r\n Result := True;\r\nend;\r\n\r\nprocedure TJvThumbTitle.MouseDown(Button: TMouseButton; Shift: TShiftState;\r\n X, Y: Integer);\r\nbegin\r\n if Parent is TJvBaseThumbnail then\r\n TJvBaseThumbnail(Parent).MouseDown(Button, Shift, X + Left, Y + Top)\r\n else\r\n inherited MouseDown(Button, Shift, X, Y);\r\nend;\r\n\r\nprocedure TJvThumbTitle.MouseUp(Button: TMouseButton; Shift: TShiftState;\r\n X, Y: Integer);\r\nbegin\r\n if Parent is TJvBaseThumbnail then\r\n TJvBaseThumbnail(Parent).MouseUp(Button, Shift, X + Left, Y + Top)\r\n else\r\n inherited MouseUp(Button, Shift, X, Y);\r\nend;\r\n\r\nprocedure TJvThumbTitle.Click;\r\nbegin\r\n if Parent is TJvBaseThumbnail then\r\n TJvBaseThumbnail(Parent).Click\r\n else\r\n inherited Click;\r\nend;\r\n\r\nprocedure TJvThumbTitle.DblClick;\r\nbegin\r\n if Parent is TJvBaseThumbnail then\r\n TJvBaseThumbnail(Parent).DblClick\r\n else\r\n inherited DblClick;\r\nend;\r\n\r\nprocedure TJvThumbTitle.MouseMove(Shift: TShiftState; X, Y: Integer);\r\nbegin\r\n if Parent is TJvBaseThumbnail then\r\n TJvBaseThumbnail(Parent).MouseMove(Shift, X + Left, Y + Top)\r\n else\r\n inherited MouseMove(Shift, X, Y);\r\nend;\r\n\r\nfunction TJvThumbTitle.DoMouseWheel(Shift: TShiftState; WheelDelta: Integer; MousePos: TPoint): Boolean;\r\nbegin\r\n if Parent is TJvBaseThumbnail then\r\n Result := TJvBaseThumbnail(Parent).DoMouseWheel(Shift, WheelDelta, MousePos)\r\n else\r\n Result := inherited DoMouseWheel(Shift, WheelDelta, MousePos);\r\nend;\r\n\r\nfunction TJvThumbTitle.DoMouseWheelDown(Shift: TShiftState; MousePos: TPoint): Boolean;\r\nbegin\r\n if Parent is TJvBaseThumbnail then\r\n Result := TJvBaseThumbnail(Parent).DoMouseWheelDown(Shift, MousePos)\r\n else\r\n Result := inherited DoMouseWheelDown(Shift, MousePos);\r\nend;\r\n\r\nfunction TJvThumbTitle.DoMouseWheelUp(Shift: TShiftState; MousePos: TPoint): Boolean;\r\nbegin\r\n if Parent is TJvBaseThumbnail then\r\n Result := TJvBaseThumbnail(Parent).DoMouseWheelUp(Shift, MousePos)\r\n else\r\n Result := inherited DoMouseWheelUp(Shift, MousePos);\r\nend;\r\n\r\nprocedure TJvThumbTitle.KeyDown(var Key: Word; Shift: TShiftState);\r\nbegin\r\n if Parent is TJvBaseThumbnail then\r\n TJvBaseThumbnail(Parent).KeyDown(Key, Shift)\r\n else\r\n inherited KeyDown(Key, Shift);\r\nend;\r\n\r\nprocedure TJvThumbTitle.KeyUp(var Key: Word; Shift: TShiftState);\r\nbegin\r\n if Parent is TJvBaseThumbnail then\r\n TJvBaseThumbnail(Parent).KeyUp(Key, Shift)\r\n else\r\n inherited KeyUp(Key, Shift);\r\nend;\r\n\r\nprocedure TJvThumbTitle.KeyPress(var Key: Char);\r\nbegin\r\n if Parent is TJvBaseThumbnail then\r\n TJvBaseThumbnail(Parent).KeyPress(Key)\r\n else\r\n inherited KeyPress(Key);\r\nend;\r\n\r\n//=== { TJvBaseThumbImage } ==================================================\r\n\r\nconstructor TJvBaseThumbImage.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n ControlStyle := ControlStyle - [csSetCaption];\r\n { If AOwner is TJvBaseThumbnail then\r\n begin\r\n ControlStyle := ControlStyle - [csCaptureMouse];\r\n FIgnoreMouse := True;\r\n end\r\n else}\r\n FIgnoreMouse := False;\r\nend;\r\n\r\nprocedure TJvBaseThumbImage.MouseDown(Button: TMouseButton; Shift: TShiftState;\r\n X, Y: Integer);\r\nbegin\r\n if Parent is TJvBaseThumbnail then\r\n TJvBaseThumbnail(Parent).MouseDown(Button, Shift, X + Left, Y + Top)\r\n else\r\n inherited MouseDown(Button, Shift, X, Y);\r\nend;\r\n\r\nprocedure TJvBaseThumbImage.MouseUp(Button: TMouseButton; Shift: TShiftState;\r\n X, Y: Integer);\r\nbegin\r\n if Parent is TJvBaseThumbnail then\r\n TJvBaseThumbnail(Parent).MouseUp(Button, Shift, X + Left, Y + Top)\r\n else\r\n inherited MouseUp(Button, Shift, X, Y);\r\nend;\r\n\r\nprocedure TJvBaseThumbImage.MouseMove(Shift: TShiftState; X, Y: Integer);\r\nbegin\r\n if Parent is TJvBaseThumbnail then\r\n TJvBaseThumbnail(Parent).MouseMove(Shift, X + Left, Y + Top)\r\n else\r\n inherited MouseMove(Shift, X, Y);\r\nend;\r\n\r\nprocedure TJvBaseThumbImage.Click;\r\nbegin\r\n if Parent is TJvBaseThumbnail then\r\n TJvBaseThumbnail(Parent).Click\r\n else\r\n inherited Click;\r\nend;\r\n\r\nprocedure TJvBaseThumbImage.DblClick;\r\nbegin\r\n if Parent is TJvBaseThumbnail then\r\n TJvBaseThumbnail(Parent).DblClick\r\n else\r\n inherited DblClick;\r\nend;\r\n\r\nfunction TJvBaseThumbImage.HitTest(X, Y: Integer): Boolean;\r\n{const\r\n Hits: array [Boolean] of Longint = (HTCLIENT, HTNOWHERE);}\r\nbegin\r\n if csDesigning in ComponentState then\r\n Result := inherited HitTest(X, Y)\r\n else\r\n Result := not IgnoreMouse;\r\n //Msg.Result := Hits[IgnoreMouse];\r\nend;\r\n\r\n//=== { TJvBaseThumbnail } ===================================================\r\n\r\nconstructor TJvBaseThumbnail.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n if AOwner is TJvBaseThumbView then\r\n ControlStyle := ControlStyle - [csSetCaption, csCaptureMouse]\r\n // csClickEvents,csDoubleClicks]\r\n else\r\n ControlStyle := ControlStyle - [csSetCaption];\r\nend;\r\n\r\nprocedure TJvBaseThumbnail.MouseDown(Button: TMouseButton; Shift: TShiftState;\r\n X, Y: Integer);\r\nbegin\r\n if Parent is TJvBaseThumbView then\r\n TJvBaseThumbView(Parent).MouseDown(Button, Shift, Left + X, Top + Y)\r\n else\r\n inherited MouseDown(Button, Shift, X, Y);\r\nend;\r\n\r\nfunction TJvBaseThumbnail.DoEraseBackground(Canvas: TCanvas; Param: LPARAM): Boolean;\r\nbegin\r\n inherited DoEraseBackground(Canvas, Param);\r\n Result := True;\r\nend;\r\n\r\nprocedure TJvBaseThumbnail.MouseMove(Shift: TShiftState; X, Y: Integer);\r\nbegin\r\n if Parent is TJvBaseThumbView then\r\n TJvBaseThumbView(Parent).MouseMove(Shift, Left + X, Top + Y)\r\n else\r\n inherited MouseMove(Shift, X, Y);\r\nend;\r\n\r\nfunction TJvBaseThumbnail.DoMouseWheel(Shift: TShiftState; WheelDelta: Integer; MousePos: TPoint): Boolean;\r\nbegin\r\n if Parent is TJvBaseThumbView then\r\n Result := TJvBaseThumbView(Parent).DoMouseWheel(Shift, WheelDelta, MousePos)\r\n else\r\n Result := inherited DoMouseWheel(Shift, WheelDelta, MousePos);\r\nend;\r\n\r\nfunction TJvBaseThumbnail.DoMouseWheelDown(Shift: TShiftState; MousePos: TPoint): Boolean;\r\nbegin\r\n if Parent is TJvBaseThumbView then\r\n Result := TJvBaseThumbView(Parent).DoMouseWheelDown(Shift, MousePos)\r\n else\r\n Result := inherited DoMouseWheelDown(Shift, MousePos);\r\nend;\r\n\r\nfunction TJvBaseThumbnail.DoMouseWheelUp(Shift: TShiftState; MousePos: TPoint): Boolean;\r\nbegin\r\n if Parent is TJvBaseThumbView then\r\n Result := TJvBaseThumbView(Parent).DoMouseWheelUp(Shift, MousePos)\r\n else\r\n Result := inherited DoMouseWheelUp(Shift, MousePos);\r\nend;\r\n\r\nprocedure TJvBaseThumbnail.KeyDown(var Key: Word; Shift: TShiftState);\r\nbegin\r\n if Parent is TJvBaseThumbView then\r\n TJvBaseThumbView(Parent).KeyDown(Key, Shift)\r\n else\r\n inherited KeyDown(Key, Shift);\r\nend;\r\n\r\nprocedure TJvBaseThumbnail.KeyUp(var Key: Word; Shift: TShiftState);\r\nbegin\r\n if Parent is TJvBaseThumbView then\r\n TJvBaseThumbView(Parent).KeyUp(Key, Shift)\r\n else\r\n inherited KeyUp(Key, Shift);\r\nend;\r\n\r\nprocedure TJvBaseThumbnail.KeyPress(var Key: Char);\r\nbegin\r\n if Parent is TJvBaseThumbView then\r\n TJvBaseThumbView(Parent).KeyPress(Key)\r\n else\r\n inherited KeyPress(Key);\r\nend;\r\n\r\nprocedure TJvBaseThumbnail.MouseUp(Button: TMouseButton; Shift: TShiftState;\r\n X, Y: Integer);\r\nbegin\r\n if Parent is TJvBaseThumbView then\r\n TJvBaseThumbView(Parent).MouseUp(Button, Shift, Left + X, Top + Y)\r\n else\r\n inherited MouseUp(Button, Shift, X, Y);\r\nend;\r\n\r\nprocedure TJvBaseThumbnail.Click;\r\nbegin\r\n if Parent is TJvBaseThumbView then\r\n TJvBaseThumbView(Parent).Click\r\n else\r\n inherited Click;\r\nend;\r\n\r\nprocedure TJvBaseThumbnail.DblClick;\r\nbegin\r\n if Parent is TJvBaseThumbView then\r\n TJvBaseThumbView(Parent).DblClick\r\n else\r\n inherited DblClick;\r\nend;\r\n\r\n//=== { TJvBaseThumbView } ===================================================\r\n\r\nconstructor TJvBaseThumbView.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n ControlState := ControlState + [csFocusing];\r\n ControlStyle := ControlStyle + [csOpaque] - [csSetCaption];\r\n IncludeThemeStyle(Self, [csNeedsBorderPaint]);\r\nend;\r\n{\r\nfunction TJvBaseThumbView.DoEraseBackground(Canvas: TCanvas; Param: LPARAM): Boolean;\r\nbegin\r\n //Result :=\r\n inherited DoEraseBackground(Canvas, Param);\r\n Result := False;\r\nend;\r\n}\r\n//=== { TFileName } ==========================================================\r\n\r\nprocedure TFileName.SetName(NewName: string);\r\nbegin\r\n FFileName := NewName;\r\n if (NewName <> LongName) and (NewName <> ShortName) then\r\n Init;\r\nend;\r\n\r\nprocedure TFileName.Init;\r\nvar\r\n Dft: DWORD;\r\n Lft: TFileTime;\r\n sr: TSearchRec;\r\nbegin\r\n if FindFirst(FFileName, faAnyFile or faDirectory, sr) = 0 then\r\n begin\r\n FindClose(sr);\r\n\r\n FLongName := sr.FindData.cFileName;\r\n FShortName := sr.FindData.cAlternateFileName;\r\n if FLongName = '' then\r\n FLongName := FShortName;\r\n if FShortName = '' then\r\n FShortName := FLongName;\r\n //fdFileAccessed\r\n FileTimeToLocalFileTime(sr.FindData.ftLastAccessTime, Lft);\r\n FileTimeToDosDateTime(Lft, LongRec(Dft).Hi, LongRec(Dft).Lo);\r\n FAccessed := Dft;\r\n //fdFilechanged\r\n FileTimeToLocalFileTime(sr.FindData.ftLastwriteTime, Lft);\r\n FileTimeToDosDateTime(Lft, LongRec(Dft).Hi, LongRec(Dft).Lo);\r\n FModified := Dft;\r\n //fdFilecreated\r\n FileTimeToLocalFileTime(sr.FindData.ftCreationTime, Lft);\r\n FileTimeToDosDateTime(Lft, LongRec(Dft).Hi, LongRec(Dft).Lo);\r\n FCreated := Dft;\r\n FFileSize := (sr.FindData.nFileSizeHigh * MAXDWORD) + sr.FindData.nFileSizeLow;\r\n //FFileName:=NewName;\r\n end;\r\nend;\r\n\r\nprocedure TFileName.LoadFromStream(AStream: TStream; APos: Integer);\r\nbegin\r\n // Under Construction;\r\nend;\r\n\r\nprocedure TFileName.SaveToStream(AStream: TStream; APos: Integer);\r\nbegin\r\n //Under Construction\r\nend;\r\n\r\nfunction TFileName.GetLength: Integer;\r\nbegin\r\n Result := System.Length(FFileName);\r\nend;\r\n\r\nprocedure TFileName.SetLength(NewLength: Integer);\r\nbegin\r\n System.SetLength(FFileName, NewLength);\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvBdeUtils.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvBdeUtils.PAS, released on 2002-07-04.\r\n\r\nThe Initial Developers of the Original Code are: Fedor Koshevnikov, Igor Pavluk and Serge Korolev\r\nCopyright (c) 1997, 1998 Fedor Koshevnikov, Igor Pavluk and Serge Korolev\r\nCopyright (c) 2001,2002 SGB Software\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\nBurov Dmitry, translation of russian text.\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvBdeUtils.pas 13415 2012-09-10 09:51:54Z obones $\r\n\r\nunit JvBdeUtils;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, BDE, Classes, DB, DBTables,\r\n JvDBUtils;\r\n\r\ntype\r\n TJvDBLocate = class(TJvLocateObject)\r\n private\r\n function LocateCallback: Boolean;\r\n procedure RecordFilter(DataSet: TDataSet; var Accept: Boolean);\r\n protected\r\n function LocateFilter: Boolean; override;\r\n procedure CheckFieldType(Field: TField); override;\r\n function LocateKey: Boolean; override;\r\n function UseKey: Boolean; override;\r\n function FilterApplicable: Boolean; override;\r\n public\r\n destructor Destroy; override;\r\n end;\r\n\r\n TJvCloneDataset = class(TBDEDataSet)\r\n private\r\n FSourceHandle: HDBICur;\r\n FReadOnly: Boolean;\r\n procedure SetReadOnly(Value: Boolean);\r\n procedure SetSourceHandle(ASourceHandle: HDBICur);\r\n protected\r\n function CreateHandle: HDBICur; override;\r\n public\r\n property SourceHandle: HDBICur read FSourceHandle write SetSourceHandle;\r\n published\r\n property ReadOnly: Boolean read FReadOnly write SetReadOnly default False;\r\n end;\r\n\r\n TJvCloneDbDataset = class(TDBDataSet)\r\n private\r\n FSourceHandle: HDBICur;\r\n FReadOnly: Boolean;\r\n procedure SetReadOnly(Value: Boolean);\r\n procedure SetSourceHandle(ASourceHandle: HDBICur);\r\n protected\r\n function CreateHandle: HDBICur; override;\r\n public\r\n procedure InitFromDataSet(Source: TDBDataSet; Reset: Boolean);\r\n property SourceHandle: HDBICur read FSourceHandle write SetSourceHandle;\r\n published\r\n property ReadOnly: Boolean read FReadOnly write SetReadOnly default False;\r\n end;\r\n\r\n TJvCloneTable = class(TTable)\r\n private\r\n FSourceHandle: HDBICur;\r\n FReadOnly: Boolean;\r\n procedure SetReadOnly(Value: Boolean);\r\n procedure SetSourceHandle(ASourceHandle: HDBICur);\r\n protected\r\n function CreateHandle: HDBICur; override;\r\n public\r\n procedure InitFromTable(SourceTable: TTable; Reset: Boolean);\r\n published\r\n property ReadOnly: Boolean read FReadOnly write SetReadOnly default False;\r\n end;\r\n\r\n{ Utility routines }\r\n\r\nfunction CreateDbLocate: TJvLocateObject;\r\nprocedure FetchAllRecords(DataSet: TBDEDataSet);\r\nfunction TransActive(Database: TDatabase): Boolean;\r\nfunction AsyncQrySupported(Database: TDatabase): Boolean;\r\nfunction GetQuoteChar(Database: TDatabase): string;\r\nprocedure ExecuteQuery(const DbName, QueryText: string);\r\nprocedure ExecuteQueryEx(const SessName, DbName, QueryText: string);\r\nprocedure BdeTranslate(Locale: TLocale; Source, Dest: PAnsiChar; ToOem: Boolean);\r\nfunction FieldLogicMap(FldType: TFieldType): Integer;\r\nfunction FieldSubtypeMap(FldType: TFieldType): Integer;\r\nprocedure ConvertStringToLogicType(Locale: TLocale; FldLogicType: Integer;\r\n FldSize: Word; const FldName, Value: string; Buffer: Pointer);\r\nfunction GetAliasPath(const AliasName: string): string;\r\nfunction IsDirectory(const DatabaseName: string): Boolean;\r\nfunction GetBdeDirectory: string;\r\nfunction BdeErrorMsg(ErrorCode: DBIResult): string;\r\nfunction LoginToDatabase(Database: TDatabase; OnLogin: TDatabaseLoginEvent): Boolean;\r\nfunction DataSetFindValue(ADataSet: TBDEDataSet; const Value, FieldName: string): Boolean;\r\nfunction DataSetFindLike(ADataSet: TBDEDataSet; const Value, FieldName: string): Boolean;\r\nfunction DataSetRecNo(DataSet: TDataSet): Longint;\r\nfunction DataSetRecordCount(DataSet: TDataSet): Longint;\r\nfunction DataSetPositionStr(DataSet: TDataSet): string;\r\nprocedure DataSetShowDeleted(DataSet: TBDEDataSet; Show: Boolean);\r\nfunction CurrentRecordDeleted(DataSet: TBDEDataSet): Boolean;\r\nfunction IsFilterApplicable(DataSet: TDataSet): Boolean;\r\nfunction IsBookmarkStable(DataSet: TBDEDataSet): Boolean;\r\nfunction BookmarksCompare(DataSet: TBDEDataSet; Bookmark1,\r\n Bookmark2: TBookmark): Integer;\r\nfunction SetToBookmark(ADataSet: TDataSet; ABookmark: TBookmark): Boolean;\r\nprocedure SetIndex(Table: TTable; const IndexFieldNames: string);\r\nprocedure RestoreIndex(Table: TTable);\r\nprocedure DeleteRange(Table: TTable; IndexFields: array of const;\r\n FieldValues: array of const);\r\nprocedure PackTable(Table: TTable);\r\nprocedure ReindexTable(Table: TTable);\r\nprocedure BdeFlushBuffers;\r\nfunction GetNativeHandle(Database: TDatabase; Buffer: Pointer;\r\n BufSize: Integer): Pointer;\r\nprocedure ToggleDebugLayer(Active: Boolean; const DebugFile: string);\r\nprocedure DbNotSupported;\r\n\r\n{ Export/import DataSet routines }\r\n\r\nprocedure ExportDataSet(Source: TBDEDataSet; DestTable: TTable;\r\n TableType: TTableType; const AsciiCharSet: string;\r\n AsciiDelimited: Boolean; MaxRecordCount: Longint);\r\nprocedure ExportDataSetEx(Source: TBDEDataSet; DestTable: TTable;\r\n TableType: TTableType; const AsciiCharSet: string;\r\n AsciiDelimited: Boolean; AsciiDelimiter, AsciiSeparator: Char;\r\n MaxRecordCount: Longint);\r\nprocedure ImportDataSet(Source: TBDEDataSet; DestTable: TTable;\r\n MaxRecordCount: Longint; Mappings: TStrings; Mode: TBatchMode);\r\n\r\n{ ReportSmith initialization }\r\n\r\nprocedure InitRSRUN(Database: TDatabase; const ConName: string;\r\n ConType: Integer; const ConServer: string);\r\n\r\n{ begin JvDBUtil }\r\n{ ExecuteSQLScript executes SQL script }\r\n\r\nprocedure ExecuteSQLScript(Base: TDatabase; const Script: string; const Commit: TCommit; OnProgress: TJvDBProgressEvent; const UserData: Integer);\r\n\r\n{ GetQueryResult executes SQL Query and returns Result as Variant }\r\n\r\nfunction GetQueryResult(const DatabaseName, SQL: string): Variant;\r\n\r\n{ GetStoredProcResult executes SQL stored procedure and returns\r\n value of ResultName parameters as Variant }\r\n\r\nfunction GetStoredProcResult(const ADatabaseName, AStoredProcName: string; AParams: array of Variant;\r\n const AResultName: string): Variant;\r\n\r\n{ StrFieldDesc returns field description of given FLDDesc record }\r\n\r\nfunction StrFieldDesc(Field: FLDDesc): string;\r\n\r\nfunction Var2Type(V: Variant; const VarType: Integer): Variant;\r\n\r\nprocedure CopyRecord(DataSet: TDataSet);\r\n\r\n{ AddReference create reference for paradox table,\r\n RefField and MasterField are field numbers (first field has number 1)\r\n Tables allready must have indices for this fields }\r\n\r\nprocedure AddReference(Tbl: TTable; RefName: string; RefField: Word;\r\n MasterTable: string; MasterField: Word; ModOp, DelOp: RINTQual);\r\n\r\n{ AddMasterPassword extracted from \"bde.hlp\" file }\r\nprocedure AddMasterPassword(Table: TTable; pswd: string);\r\n\r\nprocedure PackEncryptedTable(Table: TTable; pswd: string);\r\n\r\nfunction EncodeQuotes(const S: string): string;\r\n\r\n{*********************** from JvStrUtil unit ***********************}\r\n\r\nfunction Cmp(const S1, S2: string): Boolean;\r\n\r\n{ SubStr returns substring from string, S,\r\n separated with Separator string}\r\n\r\nfunction SubStr(const S: string; const Index: Integer; const Separator: string): string;\r\n\r\n{ SubStrEnd same to previous function but Index numerated\r\n from the end of string }\r\n\r\nfunction SubStrEnd(const S: string; const Index: Integer; const Separator: string): string;\r\n\r\n{ ReplaceString searches for all substrings, OldPattern,\r\n in a string, S, and replaces them with NewPattern }\r\n\r\nfunction ReplaceString(S: string; const OldPattern, NewPattern: string): string;\r\n\r\n{ GetXYByPos is same to previous function, but\r\n returns X position in line too}\r\n\r\nprocedure GetXYByPos(const S: string; const Pos: Integer; var X, Y: Integer);\r\n\r\n{####################### from JvStrUtil unit #######################}\r\n\r\n{ end JvDBUtil }\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvBdeUtils.pas $';\r\n Revision: '$Revision: 13415 $';\r\n Date: '$Date: 2012-09-10 11:51:54 +0200 (lun. 10 sept. 2012) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n {$IFDEF HAS_UNIT_SYSTEM_UITYPES}\r\n System.UITypes,\r\n {$ENDIF}\r\n SysUtils, Registry, Forms, Controls, Dialogs, Math,\r\n IniFiles, DBConsts, bdeconst, Variants, RTLConsts,\r\n JvConsts, JvJVCLUtils, JvJCLUtils, JvResources;\r\n\r\n{ Utility routines }\r\n\r\nprocedure DBError(const Ident: string);\r\nbegin\r\n DatabaseError(Ident);\r\nend;\r\n\r\nfunction IsBookmarkStable(DataSet: TBDEDataSet): Boolean;\r\nvar\r\n Props: CURProps;\r\nbegin\r\n with DataSet do\r\n Result := Active and (DbiGetCursorProps(Handle, Props) = DBIERR_NONE) and\r\n Props.bBookMarkStable;\r\nend;\r\n\r\nfunction SetToBookmark(ADataSet: TDataSet; ABookmark: TBookmark): Boolean;\r\nbegin\r\n Result := False;\r\n with ADataSet do\r\n if Active and (ABookmark <> nil) and not (Bof and Eof) and\r\n BookmarkValid(ABookmark) then\r\n try\r\n ADataSet.GotoBookmark(ABookmark);\r\n Result := True;\r\n except\r\n end;\r\nend;\r\n\r\nfunction BookmarksCompare(DataSet: TBDEDataSet; Bookmark1, Bookmark2: TBookmark): Integer;\r\nconst\r\n RetCodes: array[Boolean, Boolean] of ShortInt =\r\n ((2, CMPLess), (CMPGtr, CMPEql));\r\nbegin\r\n Result := RetCodes[Bookmark1 = nil, Bookmark2 = nil];\r\n if Result = 2 then\r\n begin\r\n Check(DbiCompareBookmarks(DataSet.Handle, Bookmark1, Bookmark2,\r\n Result));\r\n if Result = CMPKeyEql then\r\n Result := CMPEql;\r\n end;\r\nend;\r\n\r\nfunction DBGetIntProp(const Handle: Pointer; PropName: Longint): Longint;\r\nvar\r\n Length: Word;\r\n Value: Longint;\r\nbegin\r\n Value := 0;\r\n Check(DbiGetProp(hDBIObj(Handle), PropName, @Value, SizeOf(Value), Length));\r\n Result := Value;\r\nend;\r\n\r\nfunction GetQuoteChar(Database: TDatabase): string;\r\nvar\r\n Q: Char;\r\n Len: Word;\r\nbegin\r\n Result := '';\r\n if Database.IsSQLBased then\r\n begin\r\n Q := #0;\r\n DbiGetProp(hDBIObj(Database.Handle), dbQUOTECHAR, @Q, SizeOf(Q), Len);\r\n if Q <> #0 then\r\n Result := Q;\r\n end\r\n else\r\n Result := '\"';\r\nend;\r\n\r\nfunction AsyncQrySupported(Database: TDatabase): Boolean;\r\nbegin\r\n Result := False;\r\n if Database.Connected then\r\n if Database.IsSQLBased then\r\n try\r\n Result := BOOL(DBGetIntProp(Database.Handle, dbASYNCSUPPORT));\r\n except\r\n end\r\n else\r\n Result := True;\r\nend;\r\n\r\nfunction FieldLogicMap(FldType: TFieldType): Integer;\r\nbegin\r\n Result := FldTypeMap[FldType];\r\nend;\r\n\r\nfunction FieldSubtypeMap(FldType: TFieldType): Integer;\r\nbegin\r\n Result := FldSubtypeMap[FldType];\r\nend;\r\n\r\n{ Routine for convert string to IDAPI logical field type }\r\n\r\nprocedure ConvertStringToLogicType(Locale: TLocale; FldLogicType: Integer;\r\n FldSize: Word; const FldName, Value: string; Buffer: Pointer);\r\nvar\r\n Allocate: Boolean;\r\n BCD: FMTBcd;\r\n E: Integer;\r\n L: Longint;\r\n B: WordBool;\r\n DateTime: TDateTime;\r\n D: Double;\r\n Data: Longint;\r\n TimeStamp: TTimeStamp;\r\nbegin\r\n if Buffer = nil then\r\n begin\r\n Buffer := AllocMem(FldSize);\r\n Allocate := Buffer <> nil;\r\n end\r\n else\r\n Allocate := False;\r\n try\r\n case FldLogicType of\r\n fldZSTRING:\r\n AnsiToNative(Locale, AnsiString(Value), PAnsiChar(Buffer), FldSize); // potential data loss under D2009 because of AnsiString cast\r\n fldBYTES, fldVARBYTES:\r\n Move(Value[1], Buffer^, Min(Length(Value) * SizeOf(Char), FldSize));\r\n fldINT16, fldINT32, fldUINT16, fldINT64:\r\n begin\r\n if Value = '' then\r\n FillChar(Buffer^, FldSize, 0)\r\n else\r\n begin\r\n Val(Value, L, E);\r\n if E <> 0 then\r\n DatabaseErrorFmt(SInvalidIntegerValue, [Value, FldName]);\r\n Move(L, Buffer^, FldSize);\r\n end;\r\n end;\r\n fldBOOL:\r\n begin\r\n L := Length(Value);\r\n if L = 0 then\r\n B := False\r\n else\r\n B := CharInSet(Value[1], ['Y', 'y', 'T', 't', '1']);\r\n Move(B, Buffer^, SizeOf(WordBool));\r\n end;\r\n fldFLOAT, fldBCD:\r\n begin\r\n if Value = '' then\r\n FillChar(Buffer^, FldSize, 0)\r\n else\r\n begin\r\n D := StrToFloat(Value);\r\n if FldLogicType <> fldBCD then\r\n Move(D, Buffer^, SizeOf(Double))\r\n else\r\n begin\r\n DbiBcdFromFloat(D, 32, FldSize, BCD);\r\n Move(BCD, Buffer^, SizeOf(BCD));\r\n end;\r\n end;\r\n end;\r\n fldDATE:\r\n begin\r\n if Value = '' then\r\n FillChar(Buffer^, FldSize, 0)\r\n else\r\n begin\r\n DateTime := StrToDate(Value);\r\n TimeStamp := DateTimeToTimeStamp(DateTime);\r\n Data := TimeStamp.Date;\r\n Move(Data, Buffer^, Min(FldSize, SizeOf(Data)));\r\n end;\r\n end;\r\n fldTIME:\r\n begin\r\n if Value = '' then\r\n FillChar(Buffer^, FldSize, 0)\r\n else\r\n begin\r\n DateTime := StrToTime(Value);\r\n TimeStamp := DateTimeToTimeStamp(DateTime);\r\n Data := TimeStamp.Time;\r\n Move(Data, Buffer^, Min(FldSize, SizeOf(Data)));\r\n end;\r\n end;\r\n fldTIMESTAMP:\r\n begin\r\n if Value = '' then\r\n FillChar(Buffer^, FldSize, 0)\r\n else\r\n begin\r\n DateTime := StrToDateTime(Value);\r\n TimeStamp := DateTimeToTimeStamp(DateTime);\r\n D := TimeStampToMSecs(DateTimeToTimeStamp(DateTime));\r\n Move(D, Buffer^, Min(FldSize, SizeOf(D)));\r\n end;\r\n end;\r\n else\r\n DbiError(DBIERR_INVALIDFLDTYPE);\r\n end;\r\n finally\r\n if Allocate then\r\n FreeMem(Buffer, FldSize);\r\n end;\r\nend;\r\n\r\n{ Execute Query routine }\r\n\r\nprocedure ExecuteQueryEx(const SessName, DbName, QueryText: string);\r\nbegin\r\n with TQuery.Create(Application) do\r\n try\r\n DatabaseName := DbName;\r\n SessionName := SessName;\r\n SQL.Add(QueryText);\r\n ExecSQL;\r\n finally\r\n Free;\r\n end;\r\nend;\r\n\r\nprocedure ExecuteQuery(const DbName, QueryText: string);\r\nbegin\r\n ExecuteQueryEx('', DbName, QueryText);\r\nend;\r\n\r\n{ Database Login routine }\r\n\r\nfunction LoginToDatabase(Database: TDatabase; OnLogin: TDatabaseLoginEvent): Boolean;\r\nvar\r\n EndLogin: Boolean;\r\nbegin\r\n Result := Database.Connected;\r\n if Result then\r\n Exit;\r\n Database.OnLogin := OnLogin;\r\n EndLogin := True;\r\n repeat\r\n try\r\n Database.Connected := True;\r\n EndLogin := True;\r\n except\r\n on E: EDbEngineError do\r\n begin\r\n EndLogin := (MessageDlg(E.Message + '. ' + RsRetryLogin,\r\n mtConfirmation, [mbYes, mbNo], 0) <> mrYes);\r\n end;\r\n on E: EDatabaseError do\r\n begin\r\n { User select \"Cancel\" in login dialog }\r\n MessageDlg(E.Message, mtError, [mbOk], 0);\r\n end;\r\n else\r\n raise;\r\n end;\r\n until EndLogin;\r\n Result := Database.Connected;\r\nend;\r\n\r\n{ ReportSmith runtime initialization routine }\r\n\r\nprocedure InitRSRUN(Database: TDatabase; const ConName: string;\r\n ConType: Integer; const ConServer: string);\r\nconst\r\n IniFileName = 'RPTSMITH.CON';\r\n scConNames = 'ConnectNamesSection';\r\n idConNames = 'ConnectNames';\r\n idType = 'Type';\r\n idServer = 'Server';\r\n idSQLDataFilePath = 'Database';\r\n idDataFilePath = 'DataFilePath';\r\n idSQLUserID = 'USERID';\r\nvar\r\n ParamList: TStringList;\r\n DBPath: string;\r\n TempStr, AppConName: string;\r\n UserName: string;\r\n ExeName: string;\r\n IniFile: TIniFile;\r\nbegin\r\n ParamList := TStringList.Create;\r\n try\r\n Database.Session.GetAliasParams(Database.AliasName, ParamList);\r\n if Database.IsSQLBased then\r\n DBPath := ParamList.Values['SERVER NAME']\r\n else\r\n DBPath := ParamList.Values['PATH'];\r\n UserName := ParamList.Values['USER NAME'];\r\n finally\r\n ParamList.Free;\r\n end;\r\n AppConName := ConName;\r\n if AppConName = '' then\r\n begin\r\n ExeName := ExtractFileName(Application.ExeName);\r\n AppConName := Copy(ExeName, 1, Pos('.', ExeName) - 1);\r\n end;\r\n IniFile := TIniFile.Create(IniFileName);\r\n try\r\n TempStr := IniFile.ReadString(scConNames, idConNames, '');\r\n if Pos(AppConName, TempStr) = 0 then\r\n begin\r\n if TempStr <> '' then\r\n TempStr := TempStr + ',';\r\n IniFile.WriteString(scConNames, idConNames, TempStr + AppConName);\r\n end;\r\n IniFile.WriteInteger(AppConName, idType, ConType);\r\n IniFile.WriteString(AppConName, idServer, ConServer);\r\n if Database.IsSQLBased then\r\n begin\r\n IniFile.WriteString(AppConName, idSQLDataFilePath, DBPath);\r\n IniFile.WriteString(AppConName, idSQLUserID, UserName);\r\n end\r\n else\r\n IniFile.WriteString(AppConName, idDataFilePath, DBPath);\r\n finally\r\n IniFile.Free;\r\n end;\r\nend;\r\n\r\n{ BDE aliases routines }\r\n\r\nfunction IsDirectory(const DatabaseName: string): Boolean;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := True;\r\n if (DatabaseName = '') then\r\n Exit;\r\n I := 1;\r\n while I <= Length(DatabaseName) do\r\n begin\r\n if CharInSet(DatabaseName[I], LeadBytes) then\r\n Inc(I)\r\n else\r\n if CharInSet(DatabaseName[I], [':', '\\']) then\r\n Exit;\r\n Inc(I);\r\n end;\r\n Result := False;\r\nend;\r\n\r\nfunction GetAliasPath(const AliasName: string): string;\r\nvar\r\n SAlias: DBINAME;\r\n Desc: DBDesc;\r\n Params: TStrings;\r\nbegin\r\n Result := '';\r\n StrPLCopy(SAlias, AnsiString(AliasName), SizeOf(SAlias) - 1);\r\n AnsiToOem(SAlias, SAlias);\r\n Check(DbiGetDatabaseDesc(SAlias, @Desc));\r\n if StrIComp(Desc.szDbType, szCFGDBSTANDARD) = 0 then\r\n begin\r\n OemToAnsi(Desc.szPhyName, Desc.szPhyName);\r\n Result := string(StrPas(Desc.szPhyName));\r\n end\r\n else\r\n begin\r\n Params := TStringList.Create;\r\n try\r\n Session.Active := True;\r\n Session.GetAliasParams(AliasName, Params);\r\n Result := Params.Values['SERVER NAME'];\r\n finally\r\n Params.Free;\r\n end;\r\n end;\r\nend;\r\n\r\n//=== { TJvCloneDataset } ====================================================\r\n\r\nprocedure TJvCloneDataset.SetSourceHandle(ASourceHandle: HDBICur);\r\nbegin\r\n if ASourceHandle <> FSourceHandle then\r\n begin\r\n Close;\r\n FSourceHandle := ASourceHandle;\r\n if FSourceHandle <> nil then\r\n Open;\r\n end;\r\nend;\r\n\r\nfunction TJvCloneDataset.CreateHandle: HDBICur;\r\nbegin\r\n Check(DbiCloneCursor(FSourceHandle, FReadOnly, False, Result));\r\nend;\r\n\r\nprocedure TJvCloneDataset.SetReadOnly(Value: Boolean);\r\nbegin\r\n CheckInactive;\r\n FReadOnly := Value;\r\nend;\r\n\r\n//=== { TJvCloneDbDataset } ==================================================\r\n\r\nprocedure TJvCloneDbDataset.InitFromDataSet(Source: TDBDataSet; Reset: Boolean);\r\nbegin\r\n with Source do\r\n begin\r\n Self.SessionName := SessionName;\r\n Self.DatabaseName := DatabaseName;\r\n SetSourceHandle(Handle);\r\n Self.Filter := Filter;\r\n Self.OnFilterRecord := OnFilterRecord;\r\n if not Reset then\r\n Self.Filtered := Filtered;\r\n end;\r\n if Reset then\r\n begin\r\n Filtered := False;\r\n First;\r\n end;\r\nend;\r\n\r\nprocedure TJvCloneDbDataset.SetSourceHandle(ASourceHandle: HDBICur);\r\nbegin\r\n if ASourceHandle <> FSourceHandle then\r\n begin\r\n Close;\r\n FSourceHandle := ASourceHandle;\r\n if FSourceHandle <> nil then\r\n Open;\r\n end;\r\nend;\r\n\r\nfunction TJvCloneDbDataset.CreateHandle: HDBICur;\r\nbegin\r\n Check(DbiCloneCursor(FSourceHandle, FReadOnly, False, Result));\r\nend;\r\n\r\nprocedure TJvCloneDbDataset.SetReadOnly(Value: Boolean);\r\nbegin\r\n CheckInactive;\r\n FReadOnly := Value;\r\nend;\r\n\r\n//=== { TJvCloneTable } ======================================================\r\n\r\nprocedure TJvCloneTable.InitFromTable(SourceTable: TTable; Reset: Boolean);\r\nbegin\r\n with SourceTable do\r\n begin\r\n Self.TableType := TableType;\r\n Self.TableName := TableName;\r\n Self.SessionName := SessionName;\r\n Self.DatabaseName := DatabaseName;\r\n if not Reset then\r\n begin\r\n if IndexName <> '' then\r\n Self.IndexName := IndexName\r\n else\r\n if IndexFieldNames <> '' then\r\n Self.IndexFieldNames := IndexFieldNames;\r\n end;\r\n SetSourceHandle(Handle);\r\n Self.Filter := Filter;\r\n Self.OnFilterRecord := OnFilterRecord;\r\n if not Reset then\r\n Self.Filtered := Filtered;\r\n end;\r\n if Reset then\r\n begin\r\n Filtered := False;\r\n DbiResetRange(Handle);\r\n IndexName := '';\r\n IndexFieldNames := '';\r\n First;\r\n end;\r\nend;\r\n\r\nprocedure TJvCloneTable.SetSourceHandle(ASourceHandle: HDBICur);\r\nbegin\r\n if ASourceHandle <> FSourceHandle then\r\n begin\r\n Close;\r\n FSourceHandle := ASourceHandle;\r\n if FSourceHandle <> nil then\r\n Open;\r\n end;\r\nend;\r\n\r\nprocedure TJvCloneTable.SetReadOnly(Value: Boolean);\r\nbegin\r\n CheckInactive;\r\n FReadOnly := Value;\r\nend;\r\n\r\nfunction TJvCloneTable.CreateHandle: HDBICur;\r\nbegin\r\n Check(DbiCloneCursor(FSourceHandle, FReadOnly, False, Result));\r\nend;\r\n\r\n//=== { TJvDBLocate } ========================================================\r\n\r\nfunction CreateDbLocate: TJvLocateObject;\r\nbegin\r\n Result := TJvDBLocate.Create;\r\nend;\r\n\r\ndestructor TJvDBLocate.Destroy;\r\nbegin\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvDBLocate.CheckFieldType(Field: TField);\r\nvar\r\n Locale: TLocale;\r\nbegin\r\n if not (Field.DataType in [ftDate, ftTime, ftDateTime]) then\r\n begin\r\n if DataSet is TBDEDataSet then\r\n Locale := TBDEDataSet(DataSet).Locale\r\n else\r\n Locale := Session.Locale;\r\n ConvertStringToLogicType(Locale, FieldLogicMap(Field.DataType),\r\n Field.DataSize, Field.FieldName, LookupValue, nil);\r\n end;\r\nend;\r\n\r\nfunction TJvDBLocate.UseKey: Boolean;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := False;\r\n if DataSet is TTable then\r\n with DataSet as TTable do\r\n begin\r\n if (not Self.LookupField.IsIndexField) and (not IndexSwitch or\r\n (not CaseSensitive and Database.IsSQLBased)) then\r\n Exit;\r\n if (not LookupExact) and (Self.LookupField.DataType <> ftString) then\r\n Exit;\r\n IndexDefs.Update;\r\n for I := 0 to IndexDefs.Count - 1 do\r\n with IndexDefs[I] do\r\n if not (ixExpression in Options) and\r\n ((ixCaseInsensitive in Options) or CaseSensitive) then\r\n if SameText(Fields, Self.LookupField.FieldName) then\r\n begin\r\n Result := True;\r\n Exit;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJvDBLocate.LocateKey: Boolean;\r\nvar\r\n Clone: TJvCloneTable;\r\n\r\n function LocateIndex(Table: TTable): Boolean;\r\n begin\r\n with Table do\r\n begin\r\n SetKey;\r\n FieldByName(Self.LookupField.FieldName).AsString := LookupValue;\r\n if LookupExact then\r\n Result := GotoKey\r\n else\r\n begin\r\n GotoNearest;\r\n Result := MatchesLookup(FieldByName(Self.LookupField.FieldName));\r\n end;\r\n end;\r\n end;\r\n\r\nbegin\r\n try\r\n TTable(DataSet).CheckBrowseMode;\r\n if TTable(DataSet).IndexFieldNames = LookupField.FieldName then\r\n Result := LocateIndex(TTable(DataSet))\r\n else\r\n begin\r\n Clone := TJvCloneTable.Create(DataSet);\r\n with Clone do\r\n try\r\n ReadOnly := True;\r\n InitFromTable(TTable(DataSet), True);\r\n IndexFieldNames := Self.LookupField.FieldName;\r\n Result := LocateIndex(Clone);\r\n if Result then\r\n begin\r\n Check(DbiSetToCursor(TTable(DataSet).Handle, Handle));\r\n DataSet.Resync([rmExact, rmCenter]);\r\n end;\r\n finally\r\n Free;\r\n end;\r\n end;\r\n except\r\n Result := False;\r\n end;\r\nend;\r\n\r\nfunction TJvDBLocate.FilterApplicable: Boolean;\r\nbegin\r\n Result := IsFilterApplicable(DataSet);\r\nend;\r\n\r\n\r\nfunction TJvDBLocate.LocateCallback: Boolean;\r\nvar\r\n Clone: TJvCloneDbDataset;\r\nbegin\r\n Result := False;\r\n try\r\n TBDEDataSet(DataSet).CheckBrowseMode;\r\n Clone := TJvCloneDbDataset.Create(DataSet);\r\n with Clone do\r\n try\r\n ReadOnly := True;\r\n InitFromDataSet(TDBDataSet(DataSet), True);\r\n OnFilterRecord := RecordFilter;\r\n Filtered := True;\r\n if not (Bof and Eof) then\r\n begin\r\n First;\r\n Result := True;\r\n end;\r\n if Result then\r\n begin\r\n Check(DbiSetToCursor(TBDEDataSet(DataSet).Handle, Handle));\r\n DataSet.Resync([rmExact, rmCenter]);\r\n end;\r\n finally\r\n Free;\r\n end;\r\n except\r\n Result := False;\r\n end;\r\nend;\r\n\r\nprocedure TJvDBLocate.RecordFilter(DataSet: TDataSet; var Accept: Boolean);\r\nbegin\r\n Accept := MatchesLookup(DataSet.FieldByName(LookupField.FieldName));\r\nend;\r\n\r\nfunction TJvDBLocate.LocateFilter: Boolean;\r\nvar\r\n SaveCursor: TCursor;\r\nbegin\r\n if LookupExact or (LookupField.DataType = ftString) or\r\n not (DataSet is TDBDataSet) then\r\n Result := inherited LocateFilter\r\n else\r\n begin\r\n SaveCursor := Screen.Cursor;\r\n Screen.Cursor := crHourGlass;\r\n try\r\n Result := LocateCallback;\r\n finally\r\n Screen.Cursor := SaveCursor;\r\n end;\r\n end;\r\nend;\r\n\r\n{ DataSet locate routines }\r\n\r\nfunction IsFilterApplicable(DataSet: TDataSet): Boolean;\r\nvar\r\n Status: DBIResult;\r\n Filter: hDBIFilter;\r\nbegin\r\n if DataSet is TBDEDataSet then\r\n begin\r\n Status := DbiAddFilter(TBDEDataSet(DataSet).Handle, 0, 0, False, nil,\r\n nil, Filter);\r\n Result := (Status = DBIERR_NONE) or (Status = DBIERR_INVALIDFILTER);\r\n if Result then\r\n DbiDropFilter(TBDEDataSet(DataSet).Handle, Filter);\r\n end\r\n else\r\n Result := True;\r\nend;\r\n\r\nfunction DataSetFindValue(ADataSet: TBDEDataSet; const Value,\r\n FieldName: string): Boolean;\r\nbegin\r\n with TJvDBLocate.Create do\r\n try\r\n DataSet := ADataSet;\r\n if ADataSet is TDBDataSet then\r\n IndexSwitch := not TDBDataSet(DataSet).Database.IsSQLBased;\r\n Result := Locate(FieldName, Value, True, False);\r\n finally\r\n Free;\r\n end;\r\nend;\r\n\r\nfunction DataSetFindLike(ADataSet: TBDEDataSet; const Value,\r\n FieldName: string): Boolean;\r\nbegin\r\n with TJvDBLocate.Create do\r\n try\r\n DataSet := ADataSet;\r\n if ADataSet is TDBDataSet then\r\n IndexSwitch := not TDBDataSet(DataSet).Database.IsSQLBased;\r\n Result := Locate(FieldName, Value, False, False);\r\n finally\r\n Free;\r\n end;\r\nend;\r\n\r\nvar\r\n SaveIndexFieldNames: TStringList = nil;\r\n\r\nprocedure UsesSaveIndexies;\r\nbegin\r\n if SaveIndexFieldNames = nil then\r\n SaveIndexFieldNames := TStringList.Create;\r\nend;\r\n\r\nprocedure ReleaseSaveIndices;\r\nbegin\r\n FreeAndNil(SaveIndexFieldNames);\r\nend;\r\n\r\nprocedure SetIndex(Table: TTable; const IndexFieldNames: string);\r\nvar\r\n IndexToSave: string;\r\nbegin\r\n IndexToSave := Table.IndexFieldNames;\r\n Table.IndexFieldNames := IndexFieldNames;\r\n UsesSaveIndexies;\r\n SaveIndexFieldNames.AddObject(IndexToSave, Table.MasterSource);\r\nend;\r\n\r\nprocedure RestoreIndex(Table: TTable);\r\nbegin\r\n if (SaveIndexFieldNames <> nil) and (SaveIndexFieldNames.Count > 0) then\r\n begin\r\n try\r\n Table.IndexFieldNames :=\r\n SaveIndexFieldNames[SaveIndexFieldNames.Count - 1];\r\n Table.MasterSource :=\r\n TDataSource(SaveIndexFieldNames.Objects[SaveIndexFieldNames.Count - 1]);\r\n finally\r\n SaveIndexFieldNames.Delete(SaveIndexFieldNames.Count - 1);\r\n if SaveIndexFieldNames.Count = 0 then\r\n ReleaseSaveIndices;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure DeleteRange(Table: TTable; IndexFields: array of const;\r\n FieldValues: array of const);\r\nvar\r\n I: Integer;\r\n NewIndex: string;\r\nbegin\r\n NewIndex := '';\r\n for I := Low(IndexFields) to High(IndexFields) do\r\n begin\r\n NewIndex := NewIndex + string(TVarRec(IndexFields[I]).VString^);\r\n if I <> High(IndexFields) then\r\n NewIndex := NewIndex + ';';\r\n end;\r\n SetIndex(Table, NewIndex);\r\n try\r\n Table.SetRange(FieldValues, FieldValues);\r\n try\r\n while not Table.Eof do\r\n Table.Delete;\r\n finally\r\n Table.CancelRange;\r\n end;\r\n finally\r\n RestoreIndex(Table);\r\n end;\r\nend;\r\n\r\nprocedure ReindexTable(Table: TTable);\r\nvar\r\n WasActive: Boolean;\r\n WasExclusive: Boolean;\r\nbegin\r\n with Table do\r\n begin\r\n WasActive := Active;\r\n WasExclusive := Exclusive;\r\n DisableControls;\r\n try\r\n if not (WasActive and WasExclusive) then\r\n Close;\r\n try\r\n Exclusive := True;\r\n Open;\r\n Check(dbiRegenIndexes(Handle));\r\n finally\r\n if not (WasActive and WasExclusive) then\r\n begin\r\n Close;\r\n Exclusive := WasExclusive;\r\n Active := WasActive;\r\n end;\r\n end;\r\n finally\r\n EnableControls;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure PackTable(Table: TTable);\r\n{ This routine copied and modified from demo unit TableEnh.pas\r\n from Borland Int. }\r\nvar\r\n { CurProp holds information about the structure of the table }\r\n CurProp: CURProps;\r\n { Specific information about the table structure, indexes, etc. }\r\n TblDesc: CRTblDesc;\r\n { Uses as a handle to the database }\r\n hDb: hDBIDb;\r\n { Path to the currently opened table }\r\n TablePath: array [0..dbiMaxPathLen] of AnsiChar;\r\n Exclusive: Boolean;\r\nbegin\r\n if not Table.Active then\r\n _DBError(SDataSetClosed);\r\n Check(DbiGetCursorProps(Table.Handle, CurProp));\r\n if StrComp(CurProp.szTableType, szPARADOX) = 0 then\r\n begin\r\n { Call DbiDoRestructure procedure if PARADOX table }\r\n hDb := nil;\r\n { Initialize the table descriptor }\r\n FillChar(TblDesc, SizeOf(CRTblDesc), 0);\r\n with TblDesc do\r\n begin\r\n { Place the table name in descriptor }\r\n StrPCopy(szTblName, AnsiString(Table.TableName));\r\n { Place the table type in descriptor }\r\n StrCopy(szTblType, CurProp.szTableType);\r\n bPack := True;\r\n bProtected := CurProp.bProtected;\r\n end;\r\n { Get the current table's directory. This is why the table MUST be\r\n opened until now }\r\n Check(DbiGetDirectory(Table.DBHandle, False, TablePath));\r\n { Close the table }\r\n Table.Close;\r\n try\r\n { NOW: since the DbiDoRestructure call needs a valid DB handle BUT the\r\n table cannot be opened, call DbiOpenDatabase to get a valid handle.\r\n Setting TTable.Active = False does not give you a valid handle }\r\n Check(DbiOpenDatabase(nil, szCFGDBSTANDARD, dbiReadWrite, dbiOpenExcl, nil,\r\n 0, nil, nil, hDb));\r\n { Set the table's directory to the old directory }\r\n Check(DbiSetDirectory(hDb, TablePath));\r\n { Pack the PARADOX table }\r\n Check(DbiDoRestructure(hDb, 1, @TblDesc, nil, nil, nil, False));\r\n { Close the temporary database handle }\r\n Check(DbiCloseDatabase(hDb));\r\n finally\r\n { Re-Open the table }\r\n Table.Open;\r\n end;\r\n end\r\n else\r\n if StrComp(CurProp.szTableType, szDBASE) = 0 then\r\n begin\r\n { Call DbiPackTable procedure if dBase table }\r\n Exclusive := Table.Exclusive;\r\n Table.Close;\r\n try\r\n Table.Exclusive := True;\r\n Table.Open;\r\n try\r\n Check(DbiPackTable(Table.DBHandle, Table.Handle, nil, nil, True));\r\n finally\r\n Table.Close;\r\n end;\r\n finally\r\n Table.Exclusive := Exclusive;\r\n Table.Open;\r\n end;\r\n end\r\n else\r\n DbiError(DBIERR_WRONGDRVTYPE);\r\nend;\r\n\r\nprocedure FetchAllRecords(DataSet: TBDEDataSet);\r\nbegin\r\n with DataSet do\r\n if not Eof then\r\n begin\r\n CheckBrowseMode;\r\n Check(DbiSetToEnd(Handle));\r\n Check(DbiGetPriorRecord(Handle, dbiNOLOCK, nil, nil));\r\n CursorPosChanged;\r\n UpdateCursorPos;\r\n end;\r\nend;\r\n\r\nprocedure BdeFlushBuffers;\r\nvar\r\n I, L: Integer;\r\n Session: TSession;\r\n J: Integer;\r\nbegin\r\n for J := 0 to Sessions.Count - 1 do\r\n begin\r\n Session := Sessions[J];\r\n if not Session.Active then\r\n Continue;\r\n for I := 0 to Session.DatabaseCount - 1 do\r\n begin\r\n with Session.Databases[I] do\r\n if Connected and not IsSQLBased then\r\n begin\r\n for L := 0 to DataSetCount - 1 do\r\n begin\r\n if DataSets[L].Active then\r\n DbiSaveChanges(DataSets[L].Handle);\r\n end;\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction DataSetRecordCount(DataSet: TDataSet): Longint;\r\nvar\r\n IsCount: Boolean;\r\nbegin\r\n if DataSet is TBDEDataSet then\r\n begin\r\n IsCount := (DbiGetExactRecordCount(TBDEDataSet(DataSet).Handle,\r\n Result) = DBIERR_NONE) or (DbiGetRecordCount(TBDEDataSet(DataSet).Handle,\r\n Result) = DBIERR_NONE);\r\n end\r\n else\r\n try\r\n Result := DataSet.RecordCount;\r\n IsCount := True;\r\n except\r\n IsCount := False;\r\n end;\r\n if not IsCount then\r\n Result := -1;\r\nend;\r\n\r\nfunction DataSetRecNo(DataSet: TDataSet): Longint;\r\nvar\r\n CurProp: CURProps;\r\n FRecProp: RECProps;\r\nbegin\r\n Result := -1;\r\n if (DataSet <> nil) and DataSet.Active and (DataSet.State in [dsBrowse,\r\n dsEdit]) then\r\n begin\r\n if not (DataSet is TBDEDataSet) then\r\n begin\r\n Result := DataSet.RecNo;\r\n Exit;\r\n end;\r\n if DbiGetCursorProps(TBDEDataSet(DataSet).Handle, CurProp) <> DBIERR_NONE then\r\n Exit;\r\n if (StrComp(CurProp.szTableType, szPARADOX) = 0) or\r\n (CurProp.iSeqNums = 1) then\r\n begin\r\n DataSet.GetCurrentRecord(nil);\r\n if DbiGetSeqNo(TBDEDataSet(DataSet).Handle, Result) <> DBIERR_NONE then\r\n Result := -1;\r\n end\r\n else\r\n if StrComp(CurProp.szTableType, szDBASE) = 0 then\r\n begin\r\n DataSet.GetCurrentRecord(nil);\r\n if DbiGetRecord(TBDEDataSet(DataSet).Handle, dbiNOLOCK, nil, @FRecProp) = DBIERR_NONE\r\n then\r\n Result := FRecProp.iPhyRecNum;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction DataSetPositionStr(DataSet: TDataSet): string;\r\nvar\r\n RecNo, RecCount: Longint;\r\nbegin\r\n try\r\n RecNo := DataSetRecNo(DataSet);\r\n except\r\n RecNo := -1;\r\n end;\r\n if RecNo >= 0 then\r\n begin\r\n RecCount := DataSetRecordCount(DataSet);\r\n if RecCount >= 0 then\r\n Result := Format('%d:%d', [RecNo, RecCount])\r\n else\r\n Result := IntToStr(RecNo);\r\n end\r\n else\r\n Result := '';\r\nend;\r\n\r\nfunction TransActive(Database: TDatabase): Boolean;\r\nvar\r\n Info: XInfo;\r\n S: hDBISes;\r\nbegin\r\n Result := False;\r\n if DbiGetCurrSession(S) <> DBIERR_NONE then\r\n Exit;\r\n Result := (Database.Handle <> nil) and\r\n (DbiGetTranInfo(Database.Handle, nil, @Info) = DBIERR_NONE) and\r\n (Info.exState = xsActive);\r\n DbiSetCurrSession(S);\r\nend;\r\n\r\nfunction GetBdeDirectory: string;\r\nconst\r\n Ident = 'DLLPATH';\r\nvar\r\n Ini: TRegistry;\r\nconst\r\n BdeKey = 'SOFTWARE\\Borland\\Database Engine';\r\nbegin\r\n Result := '';\r\n Ini := TRegistry.Create;\r\n try\r\n Ini.RootKey := HKEY_LOCAL_MACHINE;\r\n if Ini.OpenKey(BdeKey, False) then\r\n if Ini.ValueExists(Ident) then\r\n Result := Ini.ReadString(Ident);\r\n { Check for multiple directories, use only the first one }\r\n if Pos(';', Result) > 0 then\r\n Delete(Result, Pos(';', Result), MaxInt);\r\n if (Length(Result) > 2) and (Result[Length(Result)] <> '\\') then\r\n Result := Result + '\\';\r\n finally\r\n Ini.Free;\r\n end;\r\nend;\r\n\r\nprocedure ExportDataSetEx(Source: TBDEDataSet; DestTable: TTable;\r\n TableType: TTableType; const AsciiCharSet: string;\r\n AsciiDelimited: Boolean; AsciiDelimiter, AsciiSeparator: Char;\r\n MaxRecordCount: Longint);\r\n\r\n function ExportAsciiField(Field: TField): Boolean;\r\n begin\r\n Result := Field.Visible and not (Field.Calculated or Field.Lookup) and\r\n not (Field.DataType in ftNonTextTypes + [ftUnknown]);\r\n end;\r\n\r\nconst\r\n TextExt = '.TXT';\r\n SchemaExt = '.SCH';\r\nvar\r\n I: Integer;\r\n S, Path: string;\r\n BatchMove: TBatchMove;\r\n TablePath: array[0..dbiMaxPathLen] of AnsiChar;\r\nbegin\r\n if Source = nil then\r\n _DBError(SDataSetEmpty);\r\n if DestTable.Active then\r\n DestTable.Close;\r\n if Source is TDBDataSet then\r\n DestTable.SessionName := TDBDataSet(Source).SessionName;\r\n if (TableType = ttDefault) then\r\n begin\r\n if DestTable.TableType <> ttDefault then\r\n TableType := DestTable.TableType\r\n else\r\n if AnsiSameText(ExtractFileExt(DestTable.TableName), TextExt) then\r\n TableType := ttASCII;\r\n end;\r\n BatchMove := TBatchMove.Create(Application);\r\n try\r\n StartWait;\r\n try\r\n BatchMove.Mode := batCopy;\r\n BatchMove.Source := Source;\r\n BatchMove.Destination := DestTable;\r\n DestTable.TableType := TableType;\r\n BatchMove.Mappings.Clear;\r\n if (DestTable.TableType = ttASCII) then\r\n begin\r\n if AnsiSameText(ExtractFileExt(DestTable.TableName), SchemaExt) then\r\n DestTable.TableName := ChangeFileExt(DestTable.TableName, TextExt);\r\n with Source do\r\n for I := 0 to FieldCount - 1 do\r\n begin\r\n if ExportAsciiField(Fields[I]) then\r\n BatchMove.Mappings.Add(Format('%s=%0:s',\r\n [Fields[I].FieldName]));\r\n end;\r\n BatchMove.RecordCount := 1;\r\n end\r\n else\r\n BatchMove.RecordCount := MaxRecordCount;\r\n BatchMove.Execute;\r\n if DestTable.TableType = ttASCII then\r\n begin\r\n { ASCII table always created in \"fixed\" format with \"ascii\"\r\n character set }\r\n with BatchMove do\r\n begin\r\n Mode := batAppend;\r\n RecordCount := MaxRecordCount;\r\n end;\r\n S := ChangeFileExt(ExtractFileName(DestTable.TableName), '');\r\n Path := NormalDir(ExtractFilePath(DestTable.TableName));\r\n if Path = '' then\r\n begin\r\n DestTable.Open;\r\n try\r\n Check(DbiGetDirectory(DestTable.DBHandle, False, TablePath));\r\n Path := NormalDir(string(OemToAnsiStr(StrPas(TablePath))));\r\n finally\r\n DestTable.Close;\r\n end;\r\n end;\r\n with TIniFile.Create(ChangeFileExt(Path + S, SchemaExt)) do\r\n try\r\n if AsciiCharSet <> '' then\r\n WriteString(S, 'CharSet', AsciiCharSet)\r\n else\r\n WriteString(S, 'CharSet', 'ascii');\r\n if AsciiDelimited then\r\n begin { change ASCII-file format to CSV }\r\n WriteString(S, 'Filetype', 'VARYING');\r\n WriteString(S, 'Delimiter', AsciiDelimiter);\r\n WriteString(S, 'Separator', AsciiSeparator);\r\n end;\r\n finally\r\n Free;\r\n end;\r\n { clear previous output - overwrite existing file }\r\n S := Path + ExtractFileName(DestTable.TableName);\r\n if Length(ExtractFileExt(S)) < 2 then\r\n S := ChangeFileExt(S, TextExt);\r\n I := FileCreate(S);\r\n if I < 0 then\r\n raise EFCreateError.CreateResFmt(@SFCreateError, [S]);\r\n FileClose(I);\r\n BatchMove.Execute;\r\n end;\r\n finally\r\n StopWait;\r\n end;\r\n finally\r\n BatchMove.Free;\r\n end;\r\nend;\r\n\r\nprocedure ExportDataSet(Source: TBDEDataSet; DestTable: TTable;\r\n TableType: TTableType; const AsciiCharSet: string;\r\n AsciiDelimited: Boolean; MaxRecordCount: Longint);\r\nbegin\r\n ExportDataSetEx(Source, DestTable, TableType, AsciiCharSet,\r\n AsciiDelimited, '\"', ',', MaxRecordCount);\r\nend;\r\n\r\nprocedure ImportDataSet(Source: TBDEDataSet; DestTable: TTable;\r\n MaxRecordCount: Longint; Mappings: TStrings; Mode: TBatchMode);\r\nvar\r\n BatchMove: TBatchMove;\r\nbegin\r\n if Source = nil then\r\n _DBError(SDataSetEmpty);\r\n if (Source is TDBDataSet) and not Source.Active then\r\n TDBDataSet(Source).SessionName := DestTable.SessionName;\r\n BatchMove := TBatchMove.Create(Application);\r\n try\r\n StartWait;\r\n try\r\n BatchMove.Mode := Mode;\r\n BatchMove.Source := Source;\r\n BatchMove.Destination := DestTable;\r\n if Mappings.Count > 0 then\r\n BatchMove.Mappings.AddStrings(Mappings);\r\n BatchMove.RecordCount := MaxRecordCount;\r\n BatchMove.Execute;\r\n finally\r\n StopWait;\r\n end;\r\n finally\r\n BatchMove.Free;\r\n end;\r\nend;\r\n\r\nfunction GetNativeHandle(Database: TDatabase; Buffer: Pointer;\r\n BufSize: Integer): Pointer;\r\nvar\r\n Len: Word;\r\nbegin\r\n Result := nil;\r\n if Assigned(Database) and Database.Connected then\r\n begin\r\n if Database.IsSQLBased then\r\n begin\r\n Check(DbiGetProp(hDBIObj(Database.Handle), dbNATIVEHNDL,\r\n Buffer, BufSize, Len));\r\n Result := Buffer;\r\n end\r\n else\r\n DBError(RsELocalDatabase);\r\n end\r\n else\r\n _DBError(SDatabaseClosed);\r\nend;\r\n\r\nprocedure BdeTranslate(Locale: TLocale; Source, Dest: PAnsiChar; ToOem: Boolean);\r\nvar\r\n Len: Cardinal;\r\nbegin\r\n Len := StrLen(Source);\r\n if ToOem then\r\n AnsiToNativeBuf(Locale, Source, Dest, Len)\r\n else\r\n NativeToAnsiBuf(Locale, Source, Dest, Len);\r\n if Source <> Dest then\r\n Dest[Len] := #0;\r\nend;\r\n\r\nfunction TrimMessage(Msg: PAnsiChar): PAnsiChar;\r\nvar\r\n Blank: Boolean;\r\n Source, Dest: PAnsiChar;\r\nbegin\r\n Source := Msg;\r\n Dest := Msg;\r\n Blank := False;\r\n while Source^ <> #0 do\r\n begin\r\n if Source^ <= ' ' then\r\n Blank := True\r\n else\r\n begin\r\n if Blank then\r\n begin\r\n Dest^ := ' ';\r\n Inc(Dest);\r\n Blank := False;\r\n end;\r\n Dest^ := Source^;\r\n Inc(Dest);\r\n end;\r\n Inc(Source);\r\n end;\r\n if (Dest > Msg) and ((Dest - 1)^ = '.') then\r\n Dec(Dest);\r\n Dest^ := #0;\r\n Result := Msg;\r\nend;\r\n\r\nfunction BdeErrorMsg(ErrorCode: DBIResult): string;\r\nvar\r\n I: Integer;\r\n NativeError: Longint;\r\n Msg, LastMsg: DBIMSG;\r\nbegin\r\n I := 1;\r\n DbiGetErrorString(ErrorCode, Msg);\r\n TrimMessage(Msg);\r\n if Msg[0] = #0 then\r\n Result := Format(SBDEError, [ErrorCode])\r\n else\r\n Result := string(StrPas(Msg));\r\n while True do\r\n begin\r\n StrCopy(LastMsg, Msg);\r\n ErrorCode := DbiGetErrorEntry(I, NativeError, Msg);\r\n if (ErrorCode = DBIERR_NONE) or\r\n (ErrorCode = DBIERR_NOTINITIALIZED) then\r\n Break;\r\n TrimMessage(Msg);\r\n if (Msg[0] <> #0) and (StrComp(Msg, LastMsg) <> 0) then\r\n Result := Format('%s. %s', [Result, Msg]);\r\n Inc(I);\r\n end;\r\n for I := 1 to Length(Result) do\r\n if Result[I] < ' ' then\r\n Result[I] := ' ';\r\nend;\r\n\r\nprocedure DataSetShowDeleted(DataSet: TBDEDataSet; Show: Boolean);\r\nbegin\r\n with DataSet do\r\n begin\r\n CheckBrowseMode;\r\n Check(DbiValidateProp(hDBIObj(Handle), curSOFTDELETEON, True));\r\n DisableControls;\r\n try\r\n Check(DbiSetProp(hDBIObj(Handle), curSOFTDELETEON, Ord(Show)));\r\n finally\r\n EnableControls;\r\n end;\r\n if DataSet is TTable then\r\n TTable(DataSet).Refresh\r\n else\r\n begin\r\n CursorPosChanged;\r\n First;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction CurrentRecordDeleted(DataSet: TBDEDataSet): Boolean;\r\nvar\r\n FRecProp: RECProps;\r\nbegin\r\n Result := False;\r\n if (DataSet <> nil) and DataSet.Active then\r\n begin\r\n DataSet.GetCurrentRecord(nil);\r\n if DbiGetRecord(DataSet.Handle, dbiNOLOCK, nil, @FRecProp) = DBIERR_NONE\r\n then\r\n Result := FRecProp.bDeleteFlag;\r\n end;\r\nend;\r\n\r\nprocedure DbNotSupported;\r\nbegin\r\n DbiError(DBIERR_NOTSUPPORTED);\r\nend;\r\n\r\nprocedure ToggleDebugLayer(Active: Boolean; const DebugFile: string);\r\nconst\r\n Options: array[Boolean] of Longint = (0, DEBUGON or OUTPUTTOFILE or\r\n APPENDTOLOG);\r\nvar\r\n FileName: DBIPATH;\r\nbegin\r\n Check(DbiDebugLayerOptions(Options[Active], StrPLCopy(FileName,\r\n AnsiString(DebugFile), SizeOf(DBIPATH) - 1)));\r\nend;\r\n{ begin JvDBUtil }\r\n\r\nprocedure ExecuteSQLScript(Base: TDatabase; const Script: string; const Commit: TCommit; OnProgress: TJvDBProgressEvent; const UserData: Integer);\r\nvar\r\n N: Integer;\r\n Term: Char;\r\n\r\n function NextQuery: string;\r\n var\r\n C: Char;\r\n Rem: Boolean;\r\n begin\r\n Result := '';\r\n Rem := False;\r\n while Length(Script) >= N do\r\n begin\r\n C := Script[N];\r\n Inc(N);\r\n if (C = Term) and not Rem then\r\n Exit;\r\n Result := Result + C;\r\n if (C = '/') and (Length(Script) >= N) and (Script[N] = '*') then\r\n Rem := True;\r\n if (C = '*') and (Length(Script) >= N) and (Script[N] = '/') and Rem then\r\n Rem := False;\r\n end;\r\n Result := '';\r\n end;\r\n\r\n function SetTerm(S: string): Boolean;\r\n var\r\n Rem: Boolean;\r\n begin\r\n Rem := False;\r\n while (Length(S) > 0) do\r\n begin\r\n if CharInSet(S[1], [' ', Cr, Lf]) then\r\n Delete(S, 1, 1)\r\n else\r\n if Rem then\r\n if (S[1] = '*') and (Length(S) > 1) and (S[2] = '/') then\r\n begin\r\n Delete(S, 1, 2);\r\n Rem := False;\r\n end\r\n else\r\n Delete(S, 1, 1)\r\n else\r\n if (S[1] = '/') and (Length(S) > 1) and (S[2] = '*') then\r\n begin\r\n Delete(S, 1, 2);\r\n Rem := True;\r\n end\r\n else\r\n Break;\r\n end;\r\n Result := AnsiStrLIComp(PChar(S), 'set term', 8) = 0;\r\n if Result then\r\n begin\r\n S := Trim(Copy(S, 9, 1024));\r\n if Length(S) = 1 then\r\n Term := S[1]\r\n else\r\n EDatabaseError.Create('Bad term');\r\n Exit;\r\n end;\r\n Result := AnsiStrLIComp(PChar(S), 'commit work', 11) = 0;\r\n if Result then\r\n begin\r\n Base.Commit;\r\n Base.StartTransaction;\r\n Exit;\r\n end;\r\n end;\r\n\r\nvar\r\n Q: string;\r\n ErrPos: Integer;\r\n NBeg: Integer;\r\n X, Y, N2: Integer;\r\n S1: string;\r\n Query: TQuery;\r\n Stop: Boolean;\r\nbegin\r\n if Commit in [ctStep, ctAll] then\r\n Base.StartTransaction;\r\n Query := TQuery.Create(Application);\r\n try\r\n Query.DatabaseName := Base.DatabaseName;\r\n Query.ParamCheck := False;\r\n N := 1;\r\n Term := ';';\r\n Stop := False;\r\n NBeg := 1;\r\n try\r\n Q := NextQuery;\r\n while Q <> '' do\r\n begin\r\n if not SetTerm(Q) then\r\n begin\r\n if Assigned(OnProgress) then\r\n begin\r\n S1 := Q;\r\n N2 := 0;\r\n while (Length(S1) > 0) and CharInSet(S1[1], [' ', Cr, Lf]) do\r\n begin\r\n Delete(S1, 1, 1);\r\n Inc(N2);\r\n end;\r\n GetXYByPos(Script, NBeg + N2, X, Y);\r\n if Assigned(OnProgress) then\r\n OnProgress(UserData, Stop, Y)\r\n else\r\n // (rom) i do not like this\r\n Application.ProcessMessages;\r\n if Stop then\r\n SysUtils.Abort;\r\n end;\r\n Query.SQL.Text := Q;\r\n Query.ExecSQL;\r\n if Commit = ctStep then\r\n begin\r\n Base.Commit;\r\n Base.StartTransaction;\r\n end;\r\n Query.Close;\r\n end;\r\n NBeg := N + 1;\r\n Q := NextQuery;\r\n end;\r\n if Commit in [ctStep, ctAll] then\r\n Base.Commit;\r\n except\r\n on E: Exception do\r\n begin\r\n if Commit in [ctStep, ctAll] then\r\n Base.Rollback;\r\n if E is EDatabaseError then\r\n begin\r\n ErrPos := NBeg;\r\n //..\r\n raise EJvScriptError.Create(E.Message, ErrPos);\r\n end\r\n else\r\n raise;\r\n end;\r\n end;\r\n finally\r\n Query.Free;\r\n end;\r\nend;\r\n\r\nfunction GetQueryResult(const DatabaseName, SQL: string): Variant;\r\nvar\r\n Query: TQuery;\r\nbegin\r\n Query := TQuery.Create(Application);\r\n try\r\n Query.DatabaseName := DatabaseName;\r\n Query.ParamCheck := False;\r\n Query.SQL.Text := SQL;\r\n Query.Open;\r\n Result := Query.Fields[0].AsVariant;\r\n finally\r\n Query.Free;\r\n end;\r\nend;\r\n\r\nfunction GetStoredProcResult(const ADatabaseName, AStoredProcName: string; AParams: array of Variant;\r\n const AResultName: string): Variant;\r\nvar\r\n I: Integer;\r\nbegin\r\n with TStoredProc.Create(Application) do\r\n try\r\n DatabaseName := ADatabaseName;\r\n ParamBindMode := pbByNumber;\r\n StoredProcName := AStoredProcName;\r\n Prepare;\r\n for I := Low(AParams) to High(AParams) do\r\n Params[I].Value := AParams[I];\r\n ExecProc;\r\n Result := ParamByName(AResultName).Value;\r\n finally\r\n Free;\r\n end;\r\nend;\r\n\r\nfunction StrFieldDesc(Field: FLDDesc): string;\r\n\r\n function SUnits1: string;\r\n begin\r\n Result := IntToStr(Field.iUnits1);\r\n end;\r\n\r\n function SUnits2: string;\r\n begin\r\n if Field.iUnits2 < 0 then\r\n Result := IntToStr(-Field.iUnits2)\r\n else\r\n Result := IntToStr(Field.iUnits2);\r\n end;\r\n\r\nbegin\r\n with Field do\r\n case iFldType of\r\n fldUNKNOWN:\r\n Result := 'unknown';\r\n fldZSTRING:\r\n Result := 'string'; { Null terminated string }\r\n fldDATE:\r\n Result := 'date'; { Date (32 bit) }\r\n fldBLOB:\r\n Result := 'blob'; { Blob }\r\n fldBOOL:\r\n Result := 'boolean'; { Boolean (16 bit) }\r\n fldINT16:\r\n Result := 'integer'; { 16 bit signed number }\r\n fldINT32:\r\n Result := 'long integer'; { 32 bit signed number }\r\n\r\n fldFLOAT:\r\n Result := 'float'; { 64 bit floating point }\r\n fldBCD:\r\n Result := 'BCD'; { BCD }\r\n fldBYTES:\r\n Result := 'bytes'; { Fixed number of bytes }\r\n fldTIME:\r\n Result := 'time'; { Time (32 bit) }\r\n fldTIMESTAMP:\r\n Result := 'timestamp'; { Time-stamp (64 bit) }\r\n fldUINT16:\r\n Result := 'unsigned int'; { Unsigned 16 bit Integer }\r\n fldUINT32:\r\n Result := 'unsigned long int'; { Unsigned 32 bit Integer }\r\n\r\n fldFLOATIEEE:\r\n Result := 'float IEEE'; { 80-bit IEEE float }\r\n fldVARBYTES:\r\n Result := 'varbytes'; { Length prefixed var bytes }\r\n fldLOCKINFO:\r\n Result := 'lockinfo'; { Look for LOCKINFO typedef }\r\n fldCURSOR:\r\n Result := 'Oracle cursor'; { For Oracle Cursor type }\r\n\r\n { Paradox types (Physical) }\r\n fldPDXCHAR:\r\n Result := 'alpha(' + SUnits1 + ')'; { Alpha (string) }\r\n fldPDXNUM:\r\n Result := 'numeric(' + SUnits1 + ', ' + SUnits2 + ')'; { Numeric }\r\n\r\n fldPDXMONEY:\r\n Result := 'money'; { Money }\r\n fldPDXDATE:\r\n Result := 'date'; { Date }\r\n fldPDXSHORT:\r\n Result := 'smallint'; { Short }\r\n fldPDXMEMO:\r\n Result := 'memo blob'; { Text Memo (blob) }\r\n fldPDXBINARYBLOB:\r\n Result := 'binary blob'; { Binary data (blob) }\r\n fldPDXFMTMEMO:\r\n Result := 'formatted blob'; { Formatted text (blob) }\r\n fldPDXOLEBLOB:\r\n Result := 'OLE blob'; { OLE object (blob) }\r\n\r\n fldPDXGRAPHIC:\r\n Result := 'graphic blob'; { Graphics object (blob) }\r\n fldPDXLONG:\r\n Result := 'long integer'; { Long }\r\n fldPDXTIME:\r\n Result := 'time'; { Time }\r\n fldPDXDATETIME:\r\n Result := 'date time'; { Time Stamp }\r\n fldPDXBOOL:\r\n Result := 'boolean'; { Logical }\r\n fldPDXAUTOINC:\r\n Result := 'auto increment'; { Auto increment (long) }\r\n fldPDXBYTES:\r\n Result := 'bytes'; { Fixed number of bytes }\r\n\r\n fldPDXBCD:\r\n Result := 'BCD'; { BCD (32 digits) }\r\n\r\n { xBASE types (Physical) }\r\n fldDBCHAR:\r\n Result := 'character'; { Char string }\r\n fldDBNUM:\r\n Result := 'number'; { Number }\r\n fldDBMEMO:\r\n Result := 'memo blob'; { Memo (blob) }\r\n fldDBBOOL:\r\n Result := 'logical'; { Logical }\r\n fldDBDATE:\r\n Result := 'date'; { Date }\r\n fldDBFLOAT:\r\n Result := 'float'; { Float }\r\n\r\n fldDBLOCK:\r\n Result := 'LOCKINFO'; { Logical type is LOCKINFO }\r\n fldDBOLEBLOB:\r\n Result := 'OLE blob'; { OLE object (blob) }\r\n fldDBBINARY:\r\n Result := 'binary blob'; { Binary data (blob) }\r\n fldDBBYTES:\r\n Result := 'bytes'; { Only for TEMPORARY tables }\r\n fldDBLONG:\r\n Result := 'long integer'; { Long (Integer) }\r\n fldDBDATETIME:\r\n Result := 'date time'; { Time Stamp }\r\n fldDBDOUBLE:\r\n Result := 'double'; { Double }\r\n\r\n fldDBAUTOINC:\r\n Result := 'auto increment'; { Auto increment (long) }\r\n\r\n { InterBase types (Physical) }\r\n 1026:\r\n Result := 'integer';\r\n 1028:\r\n Result := 'numeric(' + SUnits1 + ', ' + SUnits2 + ')'; { Numeric }\r\n 1029:\r\n Result := 'char(' + SUnits1 + ')';\r\n 1031:\r\n Result := 'date'; { Date }\r\n else\r\n Result := 'unknown type';\r\n end;\r\nend;\r\n\r\n{************************ Variant conversion routines ************************}\r\n\r\nfunction Var2Type(V: Variant; const VarType: Integer): Variant;\r\nbegin\r\n if V = Null then\r\n begin\r\n case VarType of\r\n varString, varOleStr:\r\n Result := '';\r\n varInteger, varSmallint, varByte:\r\n Result := 0;\r\n varBoolean:\r\n Result := False;\r\n varSingle, varDouble, varCurrency, varDate:\r\n Result := 0.0;\r\n else\r\n Result := VarAsType(V, VarType);\r\n end;\r\n end\r\n else\r\n Result := VarAsType(V, VarType);\r\nend;\r\n\r\nprocedure CopyRecord(DataSet: TDataSet);\r\nvar\r\n I: Integer;\r\nbegin\r\n with DataSet, TStringList.Create do\r\n try\r\n for I := 0 to FieldCount - 1 do\r\n Add(Fields[I].AsString);\r\n DataSet.Append;\r\n for I := 0 to FieldCount - 1 do\r\n if Fields[I].IsNull then\r\n Fields[I].AsString := Strings[I];\r\n finally\r\n Free;\r\n end\r\nend;\r\n\r\nprocedure AddReference(Tbl: TTable; RefName: string; RefField: Word;\r\n MasterTable: string; MasterField: Word; ModOp, DelOp: RINTQual);\r\nvar\r\n hDb: hDBIDb;\r\n TblDesc: CRTblDesc;\r\n RInt: pRINTDesc;\r\n Dir: string;\r\n OpType: CROpType;\r\nbegin\r\n SetLength(Dir, dbiMaxNameLen + 1);\r\n Check(DbiGetDirectory(Tbl.DBHandle, False, PAnsiChar(AnsiString(Dir))));\r\n SetLength(Dir, StrLen(PChar(Dir)));\r\n RInt := AllocMem(SizeOf(RINTDesc));\r\n try\r\n FillChar(TblDesc, SizeOf(CRTblDesc), #0);\r\n Tbl.DisableControls;\r\n Tbl.Close;\r\n Check(DbiOpenDatabase(nil, nil, dbiReadWrite, dbiOpenExcl, nil, 0, nil, nil, hDb));\r\n Check(DbiSetDirectory(hDb, PAnsiChar(AnsiString(Dir))));\r\n with RInt^ do\r\n begin\r\n StrPCopy(szRintName, AnsiString(RefName));\r\n StrPCopy(szTblName, AnsiString(MasterTable));\r\n eType := rintDEPENDENT;\r\n eModOp := ModOp;\r\n eDelOp := DelOp;\r\n iFldCount := 1;\r\n aiThisTabFld[0] := RefField;\r\n aiOthTabFld[0] := MasterField;\r\n end;\r\n TblDesc.iRintCount := 1;\r\n TblDesc.pRINTDesc := RInt;\r\n OpType := crADD;\r\n TblDesc.pecrRintOp := @OpType;\r\n StrPCopy(TblDesc.szTblName, AnsiString(Tbl.TableName));\r\n StrCopy(TblDesc.szTblType, szPARADOX);\r\n Check(DbiDoRestructure(hDb, 1, @TblDesc, nil, nil, nil, False));\r\n finally\r\n Check(DbiCloseDatabase(hDb));\r\n FreeMem(RInt, SizeOf(RINTDesc));\r\n Tbl.EnableControls;\r\n Tbl.Open;\r\n end;\r\nend;\r\n\r\n{\r\nprocedure PackTable(Table: TTable);\r\nvar\r\n Props: CURProps;\r\n hDb: hDBIDb;\r\n TableDesc: CRTblDesc;\r\nbegin\r\n // Make sure the table is open exclusively so we can get the db handle...\r\n if not Table.Active then\r\n raise EDatabaseError.CreateRes(@STableNotOpen);\r\n if not Table.Exclusive then\r\n raise EDatabaseError.CreateRes(@STableNotOpenExclusively);\r\n\r\n // Get the table properties to determine table type...\r\n Check(DbiGetCursorProps(Table.Handle, Props));\r\n\r\n // If the table is a Paradox table, you must call DbiDoRestructure...\r\n if Props.szTableType = szPARADOX then\r\n begin\r\n // Blank out the structure...\r\n FillChar(TableDesc, SizeOf(TableDesc), 0);\r\n // Get the database handle from the table's cursor handle...\r\n\r\n Check(DbiGetObjFromObj(hDBIObj(Table.Handle), objDATABASE, hDBIObj(hDb)));\r\n // Put the table name in the table descriptor...\r\n StrPCopy(TableDesc.szTblName, Table.TableName);\r\n // Put the table type in the table descriptor...\r\n StrPCopy(TableDesc.szTblType, Props.szTableType);\r\n // Set the Pack option in the table descriptor to True...\r\n TableDesc.bPack := True;\r\n // Close the table so the restructure can complete...\r\n Table.Close;\r\n // Call DbiDoRestructure...\r\n Check(DbiDoRestructure(hDb, 1, @TableDesc, nil, nil, nil, False));\r\n end\r\n else\r\n // If the table is a dBASE table, simply call DbiPackTable...\r\n if (Props.szTableType = szDBASE) then\r\n Check(DbiPackTable(Table.DBHandle, Table.Handle, nil, szDBASE, True))\r\n else\r\n // Pack only works on Paradox or dBASE; nothing else...\r\n raise EDatabaseError.CreateRes(@SNoParadoxDBaseTable);\r\n Table.Open;\r\nend;\r\n}\r\n//Add a master password to a Paradox table.\r\n//This procedure uses the following input:\r\n//AddMasterPassword(Table1, 'MyNewPassword')\r\n\r\nprocedure AddMasterPassword(Table: TTable; pswd: string);\r\nconst\r\n RESTRUCTURE_TRUE = WordBool(1);\r\nvar\r\n TblDesc: CRTblDesc;\r\n hDb: hDBIDb;\r\nbegin\r\n { Make sure that the table is opened and is exclusive }\r\n if not Table.Active or not Table.Exclusive then\r\n raise EDatabaseError.CreateRes(@RsETableNotInExclusiveMode);\r\n { Initialize the table descriptor }\r\n FillChar(TblDesc, SizeOf(CRTblDesc), #0);\r\n with TblDesc do\r\n begin\r\n { Place the table name in descriptor }\r\n StrPCopy(szTblName, AnsiString(Table.TableName));\r\n { Place the table type in descriptor }\r\n StrCopy(szTblType, szPARADOX);\r\n { Master Password, Password }\r\n StrPCopy(szPassword, AnsiString(pswd));\r\n { Set bProtected to True }\r\n bProtected := RESTRUCTURE_TRUE;\r\n end;\r\n { Get the database handle from the cursor handle }\r\n Check(DbiGetObjFromObj(hDBIObj(Table.Handle), objDATABASE, hDBIObj(hDb)));\r\n { Close the table }\r\n Table.Close;\r\n\r\n { Add the master password to the Paradox table }\r\n Check(DbiDoRestructure(hDb, 1, @TblDesc, nil, nil, nil, False));\r\n { Add the new password to the session }\r\n Session.AddPassword(pswd);\r\n { Re-Open the table }\r\n Table.Open;\r\nend;\r\n\r\n// Pack a Paradox table with Password\r\n// The table must be opened execlusively before calling this function...\r\n\r\nprocedure PackEncryptedTable(Table: TTable; pswd: string);\r\nconst\r\n RESTRUCTURE_TRUE = WordBool(1);\r\nvar\r\n Props: CURProps;\r\n hDb: hDBIDb;\r\n TableDesc: CRTblDesc;\r\nbegin\r\n // Make sure the table is open exclusively so we can get the db handle...\r\n if not Table.Active then\r\n raise EDatabaseError.CreateRes(@RsETableNotOpen);\r\n if not Table.Exclusive then\r\n raise EDatabaseError.CreateRes(@RsETableNotOpenExclusively);\r\n\r\n // Get the table properties to determine table type...\r\n Check(DbiGetCursorProps(Table.Handle, Props));\r\n\r\n // If the table is a Paradox table, you must call DbiDoRestructure...\r\n if Props.szTableType = szPARADOX then\r\n begin\r\n // Blank out the structure...\r\n FillChar(TableDesc, SizeOf(TableDesc), 0);\r\n // Get the database handle from the table's cursor handle...\r\n Check(DbiGetObjFromObj(hDBIObj(Table.Handle), objDATABASE, hDBIObj(hDb)));\r\n // Put the table name in the table descriptor...\r\n StrPCopy(TableDesc.szTblName, AnsiString(Table.TableName));\r\n // Put the table type in the table descriptor...\r\n StrPCopy(TableDesc.szTblType, Props.szTableType);\r\n // Set the Pack option in the table descriptor to True...\r\n TableDesc.bPack := True;\r\n { Master Password, Password }\r\n StrPCopy(TableDesc.szPassword, AnsiString(pswd));\r\n { Set bProtected to True }\r\n TableDesc.bProtected := RESTRUCTURE_TRUE;\r\n // Close the table so the restructure can complete...\r\n Table.Close;\r\n // Call DbiDoRestructure...\r\n Check(DbiDoRestructure(hDb, 1, @TableDesc, nil, nil, nil, False));\r\n end\r\n else\r\n // If the table is a dBASE table, simply call DbiPackTable...\r\n if Props.szTableType = szDBASE then\r\n Check(DbiPackTable(Table.DBHandle, Table.Handle, nil, szDBASE, True))\r\n else\r\n // Pack only works on Paradox or dBASE; nothing else...\r\n raise EDatabaseError.CreateRes(@RsENoParadoxDBaseTable);\r\n Table.Open;\r\nend;\r\n\r\nfunction EncodeQuotes(const S: string): string;\r\nbegin\r\n Result := S;\r\n Result := ReplaceString(Result, CrLf, Cr);\r\n Result := ReplaceString(Result, Cr, '\\#13');\r\n Result := ReplaceString(Result, '\"', '\\#34');\r\n Result := ReplaceString(Result, ',', '\\#44');\r\nend;\r\n\r\n{*********************** from JvStrUtil unit ***********************}\r\n\r\nfunction SubStr(const S: string; const Index: Integer; const Separator: string): string;\r\n// { . Sep}\r\n{ SubStr returns substring from string, S, separated with Separator string [translated]}\r\nvar\r\n I: Integer;\r\n pB, pE: PChar;\r\nbegin\r\n Result := '';\r\n if ((Index < 0) or ((Index = 0) and (Length(S) > 0) and (S[1] = Separator))) or\r\n (Length(S) = 0) then\r\n Exit;\r\n pB := PChar(S);\r\n for I := 1 to Index do\r\n begin\r\n pB := StrPos(pB, PChar(Separator));\r\n if pB = nil then\r\n Exit;\r\n pB := pB + Length(Separator);\r\n if pB[0] = #0 then\r\n Exit;\r\n end;\r\n pE := StrPos(pB + 1, PChar(Separator));\r\n if pE = nil then\r\n pE := PChar(S) + Length(S);\r\n if AnsiStrLIComp(pB, PChar(Separator), Length(Separator)) <> 0 then\r\n SetString(Result, pB, pE - pB);\r\nend;\r\n\r\nfunction SubStrEnd(const S: string; const Index: Integer; const Separator: string): string;\r\nvar\r\n MaxIndex: Integer;\r\n pB: PChar;\r\nbegin\r\n// Not optimal implementation [translated]\r\n MaxIndex := 0;\r\n pB := StrPos(PChar(S), PChar(Separator));\r\n while pB <> nil do\r\n begin\r\n Inc(MaxIndex);\r\n pB := StrPos(pB + Length(Separator), PChar(Separator));\r\n end;\r\n Result := SubStr(S, MaxIndex - Index, Separator);\r\nend;\r\n\r\nfunction Cmp(const S1, S2: string): Boolean;\r\nbegin\r\n Result := AnsiStrIComp(PChar(S1), PChar(S2)) = 0;\r\nend;\r\n\r\n{ ReplaceString searches for all substrings, OldPattern,\r\n in a string, S, and replaces them with NewPattern }\r\n\r\nfunction ReplaceString(S: string; const OldPattern, NewPattern: string): string;\r\nvar\r\n LW: Integer;\r\n P: PChar;\r\n Sm: Integer;\r\nbegin\r\n LW := Length(OldPattern);\r\n P := StrPos(PChar(S), PChar(OldPattern));\r\n while P <> nil do\r\n begin\r\n Sm := P - PChar(S);\r\n S := Copy(S, 1, Sm) + NewPattern + Copy(S, Sm + LW + 1, Length(S));\r\n P := StrPos(PChar(S) + Sm + Length(NewPattern), PChar(OldPattern));\r\n end;\r\n Result := S;\r\nend;\r\n\r\n{ GetXYByPos is same to previous function, but\r\n returns X position in line too}\r\n\r\nprocedure GetXYByPos(const S: string; const Pos: Integer; var X, Y: Integer);\r\nvar\r\n I, IB: Integer;\r\nbegin\r\n X := -1;\r\n Y := -1;\r\n IB := 0;\r\n if (Length(S) >= Pos) and (Pos >= 0) then\r\n begin\r\n I := 1;\r\n Y := 0;\r\n while I <= Pos do\r\n begin\r\n if S[I] = Cr then\r\n begin\r\n Inc(Y);\r\n IB := I + 1\r\n end;\r\n Inc(I);\r\n end;\r\n X := Pos - IB;\r\n end;\r\nend;\r\n{####################### from JvStrUtil unit #######################}\r\n\r\ninitialization\r\n {$IFDEF UNITVERSIONING}\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n {$ENDIF UNITVERSIONING}\r\n JvDBUtils.CreateLocateObject := CreateDbLocate;\r\n\r\nfinalization\r\n ReleaseSaveIndices;\r\n // (rom) i tried deleting the elements created by CreateDbLocate\r\n // (rom) but that causes crashes\r\n {$IFDEF UNITVERSIONING}\r\n UnregisterUnitVersion(HInstance);\r\n {$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvBehaviorLabel.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvBehaviorLabel.PAS, released on 2003-03-24.\r\n\r\nThe Initial Developer of the Original Code is Peter Thrnqvist [peter3 at sourceforge dot net]\r\nPortions created by Peter Thrnqvist are Copyright (C) 2003 Peter Thrnqvist.\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\nSbastien Buysse [sbuysse att buypin dott com] - original author of the merged components\r\nMichael Beck [mbeck att bigfoot dott com].\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nDescription:\r\n* TJvBehaviorLabel is a merging of several label components in JVCL: JvSpecialLabel,\r\n JvRealLabel, JvBouncingLabel, JvBlinkingLabel and JvAppearingLabel\r\n* To change the way the label works, change the Behavior property: this in turn changes the\r\n BehaviorOptions property to show only options available for the current Behavior.\r\n* New behaviors can be added by creating a sub-class of TJvLabelBehavior, implement the\r\n functionality and register it with RegisterLabelBehaviorOptions.\r\n\r\nKnown Issues:\r\n* Changing Behavior at design-time does not update the BehaviorOptions property unless\r\n you collapse / expand the Options property in the OI manually. No known solution yet. SOLVED\r\n\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvBehaviorLabel.pas 13104 2011-09-07 06:50:43Z obones $\r\n\r\nunit JvBehaviorLabel;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Classes, Windows, Messages, Controls, ExtCtrls,\r\n JvExStdCtrls;\r\n\r\ntype\r\n TJvCustomBehaviorLabel = class;\r\n\r\n TJvLabelBehaviorName = string;\r\n TJvLabelScrollDirection = (sdLeftToRight, sdRightToLeft);\r\n TJvAppearDirection = (drFromLeft, drFromRight, drFromTop, drFromBottom);\r\n\r\n // TJvLabelBehavior is the base class for label behaviors\r\n // To create a new behavior, derive a new class from this base class,\r\n // add appropriate published properties, override the Start, Stop and possibly the OwnerResize methods.\r\n // Register the new behavior by calling RegisterLabelBehaviorOptions\r\n TJvLabelBehavior = class(TPersistent)\r\n private\r\n FLabel: TJvCustomBehaviorLabel;\r\n FTmpActive: Boolean;\r\n FActive: Boolean;\r\n FTemporary: Boolean;\r\n procedure SetActive(const Value: Boolean);\r\n protected\r\n // Call Suspend to store the current state of the Active property and\r\n // set Active to False. If the behavior was already inactive, Suspend does nothing\r\n procedure Suspend;\r\n // Call Resume to set the Active property to the state it was in before calling Suspend.\r\n // Resume sets Active to True if it was True when Suspend was called.\r\n // If Active was False before calling Suspend, Resume does nothing\r\n procedure Resume;\r\n // OwnerResize is called when the OwnerLabel is resized. Override this\r\n // method to do special processing when the OwnerLabel changes it's size or position.\r\n // OwnerResize does nothing in this class\r\n procedure OwnerResize; virtual;\r\n // Start is automatically called when Active is set to True\r\n // Override this method to take special action when the behavior is \"started\".\r\n // Start does nothing in this class\r\n procedure Start; virtual;\r\n // Stop is automatically called when Active is set to True\r\n // Override this method to take special action when the behavior is \"stopped\".\r\n // Stop does nothing in this class\r\n procedure Stop; virtual;\r\n // The label that the behavior is acting upon\r\n property OwnerLabel: TJvCustomBehaviorLabel read FLabel;\r\n public\r\n constructor Create(ALabel: TJvCustomBehaviorLabel); virtual;\r\n destructor Destroy; override;\r\n published\r\n // Set Active to True to enable the behavior and set it to False to disable it.\r\n // Active calls Start and Stop as appropriate\r\n property Active: Boolean read FActive write SetActive default False;\r\n end;\r\n\r\n // TJvLabelNone implements no special behavior\r\n TJvLabelNone = class(TJvLabelBehavior)\r\n published\r\n property Active;\r\n end;\r\n\r\n // TJvLabelBlink implements a blinking behavior\r\n TJvLabelBlink = class(TJvLabelBehavior)\r\n private\r\n FDelay: Cardinal;\r\n FInterval: Cardinal;\r\n FTimer: TTimer;\r\n FToggled: Boolean;\r\n procedure SetDelay(const Value: Cardinal);\r\n procedure SetInterval(const Value: Cardinal);\r\n procedure DoTimerEvent(Sender: TObject);\r\n protected\r\n procedure Start; override;\r\n procedure Stop; override;\r\n public\r\n constructor Create(ALabel: TJvCustomBehaviorLabel); override;\r\n published\r\n property Active;\r\n // Delay specifies the initial delay before the blinking starts. Delay is specified in milliseconds.\r\n property Delay: Cardinal read FDelay write SetDelay default 100;\r\n // Interval specifies the number f milliseconds that elapses between \"blinks\"\r\n property Interval: Cardinal read FInterval write SetInterval default 400;\r\n end;\r\n\r\n // TJvLabelBounce implements a bouncing label\r\n // NOTE that to use this behavior, the labels Align property should be set to alNone\r\n TJvLabelBounce = class(TJvLabelBehavior)\r\n private\r\n FOriginalRect: TRect;\r\n FInterval: Cardinal;\r\n FParent: TWinControl;\r\n FDirection: Integer;\r\n FTimer: TTimer;\r\n FPixels: Integer;\r\n procedure SetInterval(const Value: Cardinal);\r\n procedure SetPixels(const Value: Integer);\r\n procedure DoTimerEvent(Sender: TObject);\r\n protected\r\n procedure Start; override;\r\n procedure Stop; override;\r\n public\r\n constructor Create(ALabel: TJvCustomBehaviorLabel); override;\r\n published\r\n property Active;\r\n // Interval specifies the number of milliseconds that elapses between \"bounces\"\r\n // Lower values will make the label move faster\r\n property Interval: Cardinal read FInterval write SetInterval default 20;\r\n // Pixels specifes the number of pixels the label is moved at each bounce.\r\n // Lower values will make the label move slower and smoother. Compensate by decreasing the value of Interval\r\n property Pixels: Integer read FPixels write SetPixels default 6;\r\n end;\r\n\r\n // TJvLabelScroll implements a scrolling behavior, a behavior where the text is scrolled horizontally\r\n // This is sometimes also referred to as a \"marquee\"\r\n TJvLabelScroll = class(TJvLabelBehavior)\r\n private\r\n FInterval: Cardinal;\r\n FDirection: TJvLabelScrollDirection;\r\n FTimer: TTimer;\r\n FPadding: Boolean;\r\n procedure SetDirection(const Value: TJvLabelScrollDirection);\r\n procedure SetInterval(const Value: Cardinal);\r\n procedure DoTimerEvent(Sender: TObject);\r\n procedure SetPadding(Value: Boolean);\r\n protected\r\n procedure Start; override;\r\n procedure Stop; override;\r\n public\r\n constructor Create(ALabel: TJvCustomBehaviorLabel); override;\r\n published\r\n property Active;\r\n // Set Padding to True to simulate the Caption being scrolled \"around the Edge\" of the\r\n // label. This property is implemented such that the text is right-padded with spaces\r\n property Padding: Boolean read FPadding write SetPadding default False;\r\n // Interval specifies the number of milliseconds that elapses between each scroll\r\n // A lower Interval increases the speed of the scroll\r\n property Interval: Cardinal read FInterval write SetInterval default 50;\r\n // Direction specifies the direction of the scroll. Possible values are\r\n // sdLeftToRight - the text is scrolled from left to right\r\n // sdRightToLeft - the text is scrolled from right to left\r\n property Direction: TJvLabelScrollDirection read FDirection write SetDirection default sdLeftToRight;\r\n end;\r\n\r\n // TJvLabelAppear implements a behavior where the label appears\r\n // from one edge, moves across the form and stops at the other edge\r\n // NOTE that to use this behavior, the labels Align property should be set to alNone\r\n TJvLabelAppear = class(TJvLabelBehavior)\r\n private\r\n FParent: TWinControl;\r\n FDelay: Cardinal;\r\n FInterval: Cardinal;\r\n FPixels: Integer;\r\n FAppearFrom: TJvAppearDirection;\r\n FTimer: TTimer;\r\n FOriginalRect: TRect;\r\n FFirst: Boolean;\r\n procedure SetDelay(const Value: Cardinal);\r\n procedure SetInterval(const Value: Cardinal);\r\n procedure DoTimerEvent(Sender: TObject);\r\n protected\r\n procedure Start; override;\r\n procedure Stop; override;\r\n public\r\n constructor Create(ALabel: TJvCustomBehaviorLabel); override;\r\n published\r\n property Active;\r\n // Delay sets the initial delay before the label starts moving\r\n property Delay: Cardinal read FDelay write SetDelay default 100;\r\n // Interval sets the number of milliseconds that elapses between each move of the label\r\n property Interval: Cardinal read FInterval write SetInterval default 20;\r\n // Pixels sets number of piels the label moves at each interval\r\n property Pixels: Integer read FPixels write FPixels default 3;\r\n // AppearFrom sets the edge from which the label appears. It also specifies the direction the label moves in\r\n // Possible values for AppearFrom are:\r\n // drFromLeft - label appears from the parents left edge and moves to the right edge where it stops\r\n // drFromRight - label appears from the parents right edge and moves to the left edge where it stops\r\n // drFromTop - label appears from the parents top edge and moves to the bottom edge where it stops\r\n // drFromBottom - label appears from the parents bottom edge and moves to the top edge where it stops\r\n property AppearFrom: TJvAppearDirection read FAppearFrom write FAppearFrom default drFromRight;\r\n end;\r\n\r\n // TJvLabelTyping implements a behavior where the label's original Caption is typed\r\n // into the label character by character\r\n TJvLabelTyping = class(TJvLabelBehavior)\r\n private\r\n FMakeErrors: Boolean;\r\n FInterval: Cardinal;\r\n FTextPos: Integer;\r\n FTimer: TTimer;\r\n procedure SetInterval(const Value: Cardinal);\r\n procedure SetMakeErrors(const Value: Boolean);\r\n procedure DoTimerEvent(Sender: TObject);\r\n protected\r\n procedure Start; override;\r\n procedure Stop; override;\r\n public\r\n constructor Create(ALabel: TJvCustomBehaviorLabel); override;\r\n published\r\n property Active;\r\n // MakeErrors specifies whether the typing sometimes contains errors. Errors are\r\n // removed after a short delay and the correct characters are \"typed\" instead.\r\n property MakeErrors: Boolean read FMakeErrors write SetMakeErrors default True;\r\n // Interval sets the speed of the typing in milliseconds\r\n property Interval: Cardinal read FInterval write SetInterval default 100;\r\n end;\r\n\r\n // TJvLabelSpecial implements a behavior where each character of the Caption is\r\n // started at #32 (space) and automatically incremented up to it's final value.\r\n // When the final value is reached, the next character of the original Caption is\r\n // added and incremented. This proceeds until the entire original Caption is shown in the label.\r\n TJvLabelSpecial = class(TJvLabelBehavior)\r\n private\r\n FInterval: Cardinal;\r\n FTextPos: Integer;\r\n FCharValue: Integer;\r\n FTimer: TTimer;\r\n procedure SetInterval(const Value: Cardinal);\r\n procedure DoTimerEvent(Sender: TObject);\r\n protected\r\n procedure Start; override;\r\n procedure Stop; override;\r\n public\r\n constructor Create(ALabel: TJvCustomBehaviorLabel); override;\r\n published\r\n property Active;\r\n // Interval sets the number of milliseconds that elapses between increments\r\n property Interval: Cardinal read FInterval write SetInterval default 20;\r\n end;\r\n\r\n // TJvLabelCodeBreaker \"decodes\" the text in the label to the\r\n // text in DecodedText. Interval sets the number of milliseconds between\r\n // \"decode attempts\", i.e character changes\r\n TJvLabelCodeBreaker = class(TJvLabelBehavior)\r\n private\r\n FScratchPad: TCaption;\r\n FDecodedText: TCaption;\r\n FInterval: Integer;\r\n FCurrentPos: Integer;\r\n FTimer: TTimer;\r\n procedure SetInterval(const Value: Integer);\r\n procedure DoTimer(Sender: TObject);\r\n protected\r\n procedure Start; override;\r\n procedure Stop; override;\r\n public\r\n constructor Create(ALabel: TJvCustomBehaviorLabel); override;\r\n published\r\n property DecodedText: TCaption read FDecodedText write FDecodedText;\r\n property Interval: Integer read FInterval write SetInterval default 10;\r\n end;\r\n\r\n TJvLabelBehaviorOptionsClass = class of TJvLabelBehavior;\r\n\r\n TJvCustomBehaviorLabel = class(TJvExCustomLabel)\r\n private\r\n FBehavior: TJvLabelBehaviorName;\r\n FOptions: TJvLabelBehavior;\r\n FOnStart: TNotifyEvent;\r\n FOnStop: TNotifyEvent;\r\n FUseEffectText: Boolean;\r\n FEffectText: TCaption;\r\n function GetOptions: TJvLabelBehavior;\r\n function BehaviorStored: Boolean;\r\n procedure UpdateDesigner;\r\n procedure SetBehavior(const Value: TJvLabelBehaviorName);\r\n procedure SetOptions(const Value: TJvLabelBehavior);\r\n procedure SetUseEffectText(const Value: Boolean);\r\n protected\r\n procedure Loaded; override;\r\n procedure Resize; override;\r\n procedure DoStart; dynamic;\r\n procedure DoStop; dynamic;\r\n\r\n function GetLabelText: string; override;\r\n property Behavior: TJvLabelBehaviorName read FBehavior write SetBehavior stored BehaviorStored;\r\n property Caption;\r\n property BehaviorOptions: TJvLabelBehavior read GetOptions write SetOptions;\r\n property OnStart: TNotifyEvent read FOnStart write FOnStart;\r\n property OnStop: TNotifyEvent read FOnStop write FOnStop;\r\n public\r\n constructor Create(AComponent: TComponent); override;\r\n destructor Destroy; override;\r\n\r\n // do not make these published\r\n property EffectText: TCaption read FEffectText write FEffectText;\r\n property UseEffectText: Boolean read FUseEffectText write SetUseEffectText;\r\n end;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvBehaviorLabel = class(TJvCustomBehaviorLabel)\r\n published\r\n property BiDiMode;\r\n property DragCursor;\r\n property OnEndDock;\r\n property OnStartDock;\r\n property ParentBiDiMode;\r\n property Behavior;\r\n property BehaviorOptions;\r\n property OnMouseEnter;\r\n property OnMouseLeave;\r\n property OnParentColorChange;\r\n property OnStart;\r\n property OnStop;\r\n\r\n property Align;\r\n property Alignment;\r\n property Anchors;\r\n property AutoSize;\r\n property Caption;\r\n property Color;\r\n property Constraints;\r\n property OnEndDrag;\r\n property DragKind;\r\n property DragMode;\r\n property Enabled;\r\n property FocusControl;\r\n property Font;\r\n property ParentColor;\r\n property ParentFont;\r\n property ParentShowHint;\r\n property PopupMenu;\r\n property ShowAccelChar;\r\n property ShowHint;\r\n property Transparent;\r\n property Layout;\r\n property Visible;\r\n property WordWrap;\r\n property OnClick;\r\n property OnContextPopup;\r\n property OnDblClick;\r\n property OnDragDrop;\r\n property OnDragOver;\r\n property OnMouseDown;\r\n property OnMouseMove;\r\n property OnMouseUp;\r\n property OnStartDrag;\r\n end;\r\n\r\n // register a new behaviour\r\nprocedure RegisterLabelBehaviorOptions(const Name: TJvLabelBehaviorName; BehaviorOptionsClass:\r\n TJvLabelBehaviorOptionsClass);\r\n// returns the class of the behaviour named Name or TJvLabelBehavior if Name not registered\r\nfunction GetLabelBehaviorOptionsClass(const Name: TJvLabelBehaviorName): TJvLabelBehaviorOptionsClass;\r\n// returns the registered name of BehaviorOptionsClass or an empty string if BehaviorOptionsClass is not registered\r\nfunction GetLabelBehaviorName(BehaviorOptionsClass: TJvLabelBehaviorOptionsClass): string;\r\n// Copies the internal TStrings list to Strings where each Strings[] is the name of a\r\n// registered class and each Objects[] is a pointer to the corresponding class\r\nprocedure GetRegisteredLabelBehaviorOptions(Strings: TStrings);\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvBehaviorLabel.pas $';\r\n Revision: '$Revision: 13104 $';\r\n Date: '$Date: 2011-09-07 08:50:43 +0200 (mer. 07 sept. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n SysUtils, Forms,\r\n JvTypes, JvResources;\r\n\r\nvar\r\n AllBehaviorOptions: TStringList = nil;\r\n\r\nfunction GetLabelBehaviorOptionsClass(const Name: TJvLabelBehaviorName): TJvLabelBehaviorOptionsClass;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := TJvLabelBehavior;\r\n if AllBehaviorOptions <> nil then\r\n begin\r\n I := AllBehaviorOptions.IndexOf(Name);\r\n if I >= 0 then\r\n Result := TJvLabelBehaviorOptionsClass(AllBehaviorOptions.Objects[I]);\r\n end;\r\nend;\r\n\r\nfunction GetLabelBehaviorName(BehaviorOptionsClass: TJvLabelBehaviorOptionsClass): string;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := '';\r\n if AllBehaviorOptions <> nil then\r\n begin\r\n I := AllBehaviorOptions.IndexOfObject(TObject(BehaviorOptionsClass));\r\n if I >= 0 then\r\n Result := AllBehaviorOptions[I];\r\n end;\r\nend;\r\n\r\nprocedure GetRegisteredLabelBehaviorOptions(Strings: TStrings);\r\nbegin\r\n if Strings <> nil then\r\n Strings.Assign(AllBehaviorOptions);\r\nend;\r\n\r\nprocedure RegisterLabelBehaviorOptions(const Name: TJvLabelBehaviorName;\r\n BehaviorOptionsClass: TJvLabelBehaviorOptionsClass);\r\nbegin\r\n if AllBehaviorOptions = nil then\r\n begin\r\n AllBehaviorOptions := TStringList.Create;\r\n AllBehaviorOptions.Sorted := True;\r\n end;\r\n if AllBehaviorOptions.IndexOf(Name) >= 0 then\r\n Exit;\r\n // raise Exception.CreateFmt('Options %s already registered!',[Name]); // can't raise here: we are probably in an initialization section\r\n AllBehaviorOptions.AddObject(Name, TObject(BehaviorOptionsClass));\r\nend;\r\n\r\nprocedure NeedBehaviorLabel(const ClassName: string);\r\nbegin\r\n raise EJVCLException.CreateResFmt(@RsENeedBehaviorLabel, [ClassName]);\r\nend;\r\n\r\nprocedure NoOwnerLabelParent(const ClassName: string);\r\nbegin\r\n raise EJVCLException.CreateResFmt(@RsENoOwnerLabelParent, [ClassName]);\r\nend;\r\n\r\n//=== { TJvLabelBehavior } ===================================================\r\n\r\nconstructor TJvLabelBehavior.Create(ALabel: TJvCustomBehaviorLabel);\r\nbegin\r\n inherited Create;\r\n if ALabel = nil then\r\n NeedBehaviorLabel(ClassName);\r\n FLabel := ALabel;\r\n FActive := False;\r\nend;\r\n\r\ndestructor TJvLabelBehavior.Destroy;\r\nbegin\r\n FTemporary := True;\r\n Stop;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvLabelBehavior.OwnerResize;\r\nbegin\r\n //\r\nend;\r\n\r\nprocedure TJvLabelBehavior.Resume;\r\nbegin\r\n Active := FTmpActive;\r\n FTemporary := False;\r\nend;\r\n\r\nprocedure TJvLabelBehavior.SetActive(const Value: Boolean);\r\nbegin\r\n if FActive <> Value then\r\n begin\r\n if FActive then\r\n Stop;\r\n FActive := Value;\r\n if FActive then\r\n Start;\r\n end;\r\nend;\r\n\r\nprocedure TJvLabelBehavior.Start;\r\nbegin\r\n if not FTemporary then\r\n OwnerLabel.DoStart;\r\nend;\r\n\r\nprocedure TJvLabelBehavior.Stop;\r\nbegin\r\n if not FTemporary then\r\n OwnerLabel.DoStop;\r\nend;\r\n\r\nprocedure TJvLabelBehavior.Suspend;\r\nbegin\r\n FTmpActive := Active;\r\n FTemporary := True;\r\n Active := False;\r\nend;\r\n\r\n//=== { TJvCustomBehaviorLabel } =============================================\r\n\r\nconstructor TJvCustomBehaviorLabel.Create(AComponent: TComponent);\r\nbegin\r\n // registration\r\n if not Assigned(AllBehaviorOptions) then\r\n begin\r\n RegisterLabelBehaviorOptions(RsNoneCaption, TJvLabelNone);\r\n RegisterLabelBehaviorOptions('Blinking', TJvLabelBlink);\r\n RegisterLabelBehaviorOptions('Bouncing', TJvLabelBounce);\r\n RegisterLabelBehaviorOptions('Scrolling', TJvLabelScroll);\r\n RegisterLabelBehaviorOptions('Typing', TJvLabelTyping);\r\n RegisterLabelBehaviorOptions('Appearing', TJvLabelAppear);\r\n RegisterLabelBehaviorOptions('Special', TJvLabelSpecial);\r\n RegisterLabelBehaviorOptions('CodeBreaker', TJvLabelCodeBreaker);\r\n end;\r\n\r\n inherited Create(AComponent);\r\n FBehavior := RsNoneCaption;\r\n FUseEffectText := False;\r\n FEffectText := '';\r\nend;\r\n\r\ndestructor TJvCustomBehaviorLabel.Destroy;\r\nbegin\r\n FreeAndNil(FOptions);\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvCustomBehaviorLabel.DoStart;\r\nbegin\r\n if Assigned(FOnStart) then\r\n FOnStart(Self);\r\nend;\r\n\r\nprocedure TJvCustomBehaviorLabel.DoStop;\r\nbegin\r\n if Assigned(FOnStop) then\r\n FOnStop(Self);\r\nend;\r\n\r\n\r\nfunction TJvCustomBehaviorLabel.GetLabelText: string;\r\nbegin\r\n if UseEffectText then\r\n Result := EffectText\r\n else\r\n Result := inherited GetLabelText;\r\nend;\r\n\r\n\r\n\r\n\r\nfunction TJvCustomBehaviorLabel.BehaviorStored: Boolean;\r\nbegin\r\n Result := FBehavior <> RsNoneCaption;\r\nend;\r\n\r\nfunction TJvCustomBehaviorLabel.GetOptions: TJvLabelBehavior;\r\nbegin\r\n if FOptions = nil then\r\n begin\r\n // (p3) this doesn't update Options in the OI at DT (unless you collapse/expand the property)\r\n FOptions := GetLabelBehaviorOptionsClass(FBehavior).Create(Self);\r\n UpdateDesigner;\r\n end;\r\n Result := FOptions;\r\nend;\r\n\r\nprocedure TJvCustomBehaviorLabel.Loaded;\r\nbegin\r\n inherited Loaded;\r\n\r\n // Start method usually exits immediately when the component is loading.\r\n // As a result, when the component is loaded, we must start the behavior\r\n // or the user won't see anything (Mantis 4809)\r\n if BehaviorOptions.Active then\r\n BehaviorOptions.Start;\r\nend;\r\n\r\nprocedure TJvCustomBehaviorLabel.Resize;\r\nbegin\r\n inherited Resize;\r\n BehaviorOptions.OwnerResize;\r\nend;\r\n\r\nprocedure TJvCustomBehaviorLabel.SetBehavior(const Value: TJvLabelBehaviorName);\r\nvar\r\n S: TStringList;\r\nbegin\r\n if FBehavior <> Value then\r\n begin\r\n S := TStringList.Create;\r\n try\r\n GetRegisteredLabelBehaviorOptions(S);\r\n if S.IndexOf(Value) < 0 then\r\n Exit;\r\n finally\r\n S.Free;\r\n end;\r\n // (p3) this doesn't update Options in the OI at DT (unless you collapse/expand the property)\r\n FBehavior := Value;\r\n FreeAndNil(FOptions);\r\n UpdateDesigner;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomBehaviorLabel.SetOptions(const Value: TJvLabelBehavior);\r\nbegin\r\n if Value = nil then\r\n Behavior := ''\r\n else\r\n if (FOptions = nil) or (FOptions.ClassType <> Value.ClassType) then\r\n Behavior := GetLabelBehaviorName(TJvLabelBehaviorOptionsClass(Value.ClassType));\r\n UpdateDesigner;\r\nend;\r\n\r\nprocedure TJvCustomBehaviorLabel.SetUseEffectText(const Value: Boolean);\r\nbegin\r\n if Value <> FUseEffectText then\r\n begin\r\n FUseEffectText := Value;\r\n if ComponentState * [csLoading, csDestroying] = [] then\r\n Repaint;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomBehaviorLabel.UpdateDesigner;\r\nvar\r\n F: TCustomForm;\r\nbegin\r\n if csDesigning in ComponentState then\r\n begin\r\n F := GetParentForm(Self);\r\n if (F <> nil) and (F.Designer <> nil) then\r\n F.Designer.Modified;\r\n end;\r\nend;\r\n\r\n//=== { TJvLabelBlink } ======================================================\r\n\r\nconstructor TJvLabelBlink.Create(ALabel: TJvCustomBehaviorLabel);\r\nbegin\r\n inherited Create(ALabel);\r\n ALabel.EffectText := '';\r\n FDelay := 100;\r\n FInterval := 400;\r\nend;\r\n\r\nprocedure TJvLabelBlink.DoTimerEvent(Sender: TObject);\r\nbegin\r\n FTimer.Enabled := False;\r\n FTimer.Interval := FInterval;\r\n FToggled := not FToggled;\r\n OwnerLabel.UseEffectText := FToggled;\r\n FTimer.Enabled := FInterval > 0;\r\nend;\r\n\r\nprocedure TJvLabelBlink.SetDelay(const Value: Cardinal);\r\nbegin\r\n if FDelay <> Value then\r\n begin\r\n Suspend;\r\n FDelay := Value;\r\n Resume;\r\n end;\r\nend;\r\n\r\nprocedure TJvLabelBlink.SetInterval(const Value: Cardinal);\r\nbegin\r\n if FInterval <> Value then\r\n begin\r\n Suspend;\r\n FInterval := Value;\r\n Resume;\r\n end;\r\nend;\r\n\r\nprocedure TJvLabelBlink.Start;\r\nbegin\r\n inherited Start;\r\n if OwnerLabel.ComponentState * [csLoading, csDestroying] <> [] then\r\n Exit;\r\n if FTimer = nil then\r\n begin\r\n FTimer := TTimer.Create(nil);\r\n FTimer.Enabled := False;\r\n FTimer.OnTimer := DoTimerEvent;\r\n end;\r\n FTimer.Interval := FDelay;\r\n FToggled := False;\r\n if FDelay = 0 then\r\n FDelay := 1;\r\n FTimer.Enabled := True; // not (csDesigning in OwnerLabel.ComponentState);\r\nend;\r\n\r\nprocedure TJvLabelBlink.Stop;\r\nbegin\r\n if FTimer <> nil then\r\n begin\r\n FreeAndNil(FTimer);\r\n OwnerLabel.UseEffectText := False;\r\n end;\r\n inherited Stop;\r\nend;\r\n\r\n//=== { TJvLabelBounce } =====================================================\r\n\r\nconstructor TJvLabelBounce.Create(ALabel: TJvCustomBehaviorLabel);\r\nbegin\r\n inherited Create(ALabel);\r\n FInterval := 20;\r\n FPixels := 6;\r\nend;\r\n\r\nprocedure TJvLabelBounce.DoTimerEvent(Sender: TObject);\r\nbegin\r\n FTimer.Enabled := False;\r\n if Pixels = 0 then\r\n Pixels := Random(8);\r\n with OwnerLabel do\r\n case FDirection of\r\n 0:\r\n if (Left - Pixels <= 0) or (Top + Height + Pixels >= FParent.ClientHeight) then\r\n begin\r\n FDirection := Random(4);\r\n // Pixels := Random(8);\r\n end\r\n else\r\n begin\r\n Left := Left - Pixels;\r\n Top := Top + Pixels;\r\n end;\r\n 1:\r\n if (Top + Height + Pixels >= FParent.ClientHeight) or\r\n (Left + Width + Pixels >= FParent.ClientWidth) then\r\n begin\r\n FDirection := Random(4);\r\n // Pixels := Random(8);\r\n end\r\n else\r\n begin\r\n Top := Top + Pixels;\r\n Left := Left + Pixels;\r\n end;\r\n 2:\r\n if (Left - Pixels <= 0) or (Top - Pixels <= 0) then\r\n begin\r\n FDirection := Random(4);\r\n // Pixels := Random(8);\r\n end\r\n else\r\n begin\r\n Left := Left - Pixels;\r\n Top := Top - Pixels;\r\n end;\r\n 3:\r\n if (Left + Width + Pixels > FParent.ClientWidth) or (Top - Pixels <= 0) then\r\n begin\r\n FDirection := Random(4);\r\n // Pixels := Random(8);\r\n end\r\n else\r\n begin\r\n Left := Left + Pixels;\r\n Top := Top - Pixels;\r\n end;\r\n end;\r\n FTimer.Enabled := True;\r\nend;\r\n\r\nprocedure TJvLabelBounce.SetInterval(const Value: Cardinal);\r\nbegin\r\n if FInterval <> Value then\r\n begin\r\n Suspend;\r\n FInterval := Value;\r\n if FInterval <= 0 then\r\n FInterval := 20;\r\n Resume;\r\n end;\r\nend;\r\n\r\nprocedure TJvLabelBounce.SetPixels(const Value: Integer);\r\nbegin\r\n if FPixels <> Value then\r\n begin\r\n Suspend;\r\n FPixels := Value;\r\n if FPixels <= 0 then\r\n FPixels := 6;\r\n Resume;\r\n end;\r\nend;\r\n\r\nprocedure TJvLabelBounce.Start;\r\nbegin\r\n if OwnerLabel.ComponentState * [csLoading, csDestroying] <> [] then\r\n Exit;\r\n FParent := OwnerLabel.Parent;\r\n if FParent = nil then\r\n NoOwnerLabelParent(ClassName);\r\n inherited Start;\r\n FOriginalRect := OwnerLabel.BoundsRect;\r\n Randomize;\r\n if FTimer = nil then\r\n begin\r\n FTimer := TTimer.Create(nil);\r\n FTimer.Enabled := False;\r\n FTimer.OnTimer := DoTimerEvent;\r\n end;\r\n FTimer.Interval := Interval;\r\n FTimer.Enabled := True;\r\nend;\r\n\r\nprocedure TJvLabelBounce.Stop;\r\nbegin\r\n FreeAndNil(FTimer);\r\n if not IsRectEmpty(FOriginalRect) then\r\n OwnerLabel.BoundsRect := FOriginalRect;\r\n inherited Stop;\r\nend;\r\n\r\n//=== { TJvLabelScroll } =====================================================\r\n\r\nconstructor TJvLabelScroll.Create(ALabel: TJvCustomBehaviorLabel);\r\nbegin\r\n inherited Create(ALabel);\r\n FInterval := 50;\r\n FDirection := sdLeftToRight;\r\nend;\r\n\r\nprocedure TJvLabelScroll.DoTimerEvent(Sender: TObject);\r\nvar\r\n Tmp: TCaption;\r\nbegin\r\n FTimer.Enabled := False;\r\n if OwnerLabel.Caption <> '' then\r\n begin\r\n Tmp := OwnerLabel.EffectText;\r\n if FDirection = sdLeftToRight then\r\n Tmp := Tmp[Length(Tmp)] + Copy(Tmp, 1, Length(Tmp) - 1)\r\n else\r\n Tmp := Copy(Tmp, 2, Length(Tmp) - 1) + Tmp[1];\r\n OwnerLabel.EffectText := Tmp;\r\n OwnerLabel.Repaint;\r\n end;\r\n FTimer.Enabled := True;\r\nend;\r\n\r\nprocedure TJvLabelScroll.SetDirection(const Value: TJvLabelScrollDirection);\r\nbegin\r\n if FDirection <> Value then\r\n begin\r\n Suspend;\r\n FDirection := Value;\r\n Resume;\r\n end;\r\nend;\r\n\r\nprocedure TJvLabelScroll.SetInterval(const Value: Cardinal);\r\nbegin\r\n if FInterval <> Value then\r\n begin\r\n Suspend;\r\n FInterval := Value;\r\n Resume;\r\n end;\r\nend;\r\n\r\nprocedure TJvLabelScroll.SetPadding(Value: Boolean);\r\nvar\r\n Tmp: TCaption;\r\nbegin\r\n FPadding := Value;\r\n Tmp := '';\r\n while OwnerLabel.Canvas.TextWidth(Tmp) < OwnerLabel.Width do\r\n Tmp := Tmp + ' ';\r\n if Value then\r\n OwnerLabel.EffectText := OwnerLabel.Caption + Tmp\r\n else\r\n OwnerLabel.EffectText := OwnerLabel.Caption;\r\nend;\r\n\r\nprocedure TJvLabelScroll.Start;\r\nbegin\r\n inherited Start;\r\n if OwnerLabel.ComponentState * [csLoading, csDestroying] <> [] then\r\n Exit;\r\n if FTimer = nil then\r\n begin\r\n FTimer := TTimer.Create(nil);\r\n FTimer.Enabled := False;\r\n FTimer.OnTimer := DoTimerEvent;\r\n end;\r\n FTimer.Interval := Interval;\r\n SetPadding(Padding);\r\n OwnerLabel.UseEffectText := True;\r\n FTimer.Enabled := True;\r\nend;\r\n\r\nprocedure TJvLabelScroll.Stop;\r\nbegin\r\n FreeAndNil(FTimer);\r\n OwnerLabel.UseEffectText := False;\r\n inherited Stop;\r\nend;\r\n\r\n//=== { TJvLabelAppear } =====================================================\r\n\r\nconstructor TJvLabelAppear.Create(ALabel: TJvCustomBehaviorLabel);\r\nbegin\r\n inherited Create(ALabel);\r\n FDelay := 100;\r\n FInterval := 20;\r\n FPixels := 3;\r\n FAppearFrom := drFromRight;\r\nend;\r\n\r\nprocedure TJvLabelAppear.DoTimerEvent(Sender: TObject);\r\nvar\r\n FWidth, FHeight: Integer;\r\n FSuspend: Boolean;\r\nbegin\r\n FWidth := FOriginalRect.Right - FOriginalRect.Left;\r\n FHeight := FOriginalRect.Bottom - FOriginalRect.Top;\r\n FSuspend := False;\r\n if FFirst then\r\n begin\r\n case FAppearFrom of\r\n drFromRight:\r\n begin\r\n OwnerLabel.Left := FParent.ClientWidth;\r\n OwnerLabel.Width := 0;\r\n end;\r\n drFromLeft:\r\n OwnerLabel.Left := -OwnerLabel.Width;\r\n drFromTop:\r\n OwnerLabel.Top := -OwnerLabel.Height;\r\n drFromBottom:\r\n begin\r\n OwnerLabel.Top := FParent.ClientHeight;\r\n OwnerLabel.Height := 0;\r\n end;\r\n end;\r\n OwnerLabel.Visible := True;\r\n FFirst := False;\r\n end;\r\n\r\n case FAppearFrom of\r\n drFromRight:\r\n begin\r\n if Abs(OwnerLabel.Left - FOriginalRect.Left) < Pixels then\r\n begin\r\n OwnerLabel.Left := FOriginalRect.Left;\r\n FSuspend := True;\r\n end\r\n else\r\n OwnerLabel.Left := OwnerLabel.Left - Pixels;\r\n if OwnerLabel.Width <> FWidth then\r\n begin\r\n if OwnerLabel.Left + FWidth < FParent.ClientWidth then\r\n OwnerLabel.Width := FWidth\r\n else\r\n OwnerLabel.Width := FParent.ClientWidth - OwnerLabel.Left - 2;\r\n end;\r\n end;\r\n drFromLeft:\r\n if Abs(OwnerLabel.Left - FOriginalRect.Left) < Pixels then\r\n begin\r\n OwnerLabel.Left := FOriginalRect.Left;\r\n FSuspend := True;\r\n end\r\n else\r\n OwnerLabel.Left := OwnerLabel.Left + Pixels;\r\n drFromTop:\r\n if Abs(OwnerLabel.Top - FOriginalRect.Top) < Pixels then\r\n begin\r\n OwnerLabel.Top := FOriginalRect.Top;\r\n FSuspend := True;\r\n end\r\n else\r\n OwnerLabel.Top := OwnerLabel.Top + Pixels;\r\n drFromBottom:\r\n begin\r\n if Abs(OwnerLabel.Top - FOriginalRect.Top) < Pixels then\r\n begin\r\n OwnerLabel.Top := FOriginalRect.Top;\r\n FSuspend := True;\r\n end\r\n else\r\n OwnerLabel.Top := OwnerLabel.Top - Pixels;\r\n if OwnerLabel.Height <> FHeight then\r\n begin\r\n if OwnerLabel.Top + FHeight < FParent.ClientHeight then\r\n OwnerLabel.Height := FHeight\r\n else\r\n OwnerLabel.Height := FParent.ClientHeight - OwnerLabel.Top - 2;\r\n end;\r\n end;\r\n end;\r\n FTimer.Interval := Interval;\r\n if FSuspend then\r\n Active := False\r\n else\r\n FTimer.Enabled := True;\r\nend;\r\n\r\nprocedure TJvLabelAppear.SetDelay(const Value: Cardinal);\r\nbegin\r\n if FDelay <> Value then\r\n begin\r\n Suspend;\r\n FDelay := Value;\r\n Resume;\r\n end;\r\nend;\r\n\r\nprocedure TJvLabelAppear.SetInterval(const Value: Cardinal);\r\nbegin\r\n if FInterval <> Value then\r\n begin\r\n Suspend;\r\n FInterval := Value;\r\n Resume;\r\n end;\r\nend;\r\n\r\nprocedure TJvLabelAppear.Start;\r\nbegin\r\n if OwnerLabel.ComponentState * [csLoading, csDestroying] <> [] then\r\n Exit;\r\n FParent := OwnerLabel.Parent;\r\n if FParent = nil then\r\n NoOwnerLabelParent(ClassName);\r\n inherited Start;\r\n if FTimer = nil then\r\n begin\r\n FTimer := TTimer.Create(nil);\r\n FTimer.Enabled := False;\r\n FTimer.OnTimer := DoTimerEvent;\r\n end;\r\n FTimer.Interval := Delay;\r\n FFirst := True;\r\n FOriginalRect := OwnerLabel.BoundsRect;\r\n FTimer.Enabled := True;\r\nend;\r\n\r\nprocedure TJvLabelAppear.Stop;\r\nbegin\r\n FreeAndNil(FTimer);\r\n if not IsRectEmpty(FOriginalRect) then\r\n OwnerLabel.BoundsRect := FOriginalRect;\r\n inherited Stop;\r\nend;\r\n\r\n//=== { TJvLabelTyping } =====================================================\r\n\r\nconstructor TJvLabelTyping.Create(ALabel: TJvCustomBehaviorLabel);\r\nbegin\r\n inherited Create(ALabel);\r\n FInterval := 100;\r\n FMakeErrors := True;\r\nend;\r\n\r\nprocedure TJvLabelTyping.DoTimerEvent(Sender: TObject);\r\nvar\r\n Tmp: TCaption;\r\n I: Integer;\r\nbegin\r\n FTimer.Enabled := False;\r\n if FTextPos <= Length(OwnerLabel.Caption) then\r\n begin\r\n Tmp := Copy(OwnerLabel.Caption, 1, FTextPos - 1);\r\n I := Random(10);\r\n if (I = 7) and MakeErrors then\r\n Tmp := Tmp + Char(Ord(OwnerLabel.Caption[FTextPos]) - Random(10))\r\n else\r\n Tmp := Tmp + OwnerLabel.Caption[FTextPos];\r\n if (MakeErrors) and (I <> 7) then\r\n FTimer.Interval := Interval\r\n else\r\n FTimer.Interval := Interval * 2;\r\n OwnerLabel.EffectText := Tmp;\r\n OwnerLabel.Repaint;\r\n Inc(FTextPos);\r\n FTimer.Enabled := True;\r\n end\r\n else\r\n Active := False;\r\nend;\r\n\r\nprocedure TJvLabelTyping.SetInterval(const Value: Cardinal);\r\nbegin\r\n if FInterval <> Value then\r\n begin\r\n Suspend;\r\n FInterval := Value;\r\n Resume;\r\n end;\r\nend;\r\n\r\nprocedure TJvLabelTyping.SetMakeErrors(const Value: Boolean);\r\nbegin\r\n if FMakeErrors <> Value then\r\n begin\r\n Suspend;\r\n FMakeErrors := Value;\r\n Resume;\r\n end;\r\nend;\r\n\r\nprocedure TJvLabelTyping.Start;\r\nbegin\r\n inherited Start;\r\n if OwnerLabel.ComponentState * [csLoading, csDestroying] <> [] then\r\n Exit;\r\n if FTimer = nil then\r\n begin\r\n FTimer := TTimer.Create(nil);\r\n FTimer.Enabled := False;\r\n FTimer.OnTimer := DoTimerEvent;\r\n end;\r\n FTimer.Interval := Interval;\r\n Randomize;\r\n OwnerLabel.EffectText := '';\r\n OwnerLabel.UseEffectText := True;\r\n FTextPos := 1;\r\n FTimer.Enabled := True;\r\nend;\r\n\r\nprocedure TJvLabelTyping.Stop;\r\nbegin\r\n FreeAndNil(FTimer);\r\n OwnerLabel.UseEffectText := False;\r\n inherited Stop;\r\nend;\r\n\r\n//=== { TJvLabelSpecial } ====================================================\r\n\r\nconstructor TJvLabelSpecial.Create(ALabel: TJvCustomBehaviorLabel);\r\nbegin\r\n inherited Create(ALabel);\r\n FInterval := 20;\r\nend;\r\n\r\nprocedure TJvLabelSpecial.DoTimerEvent(Sender: TObject);\r\nbegin\r\n FTimer.Enabled := False;\r\n if FTextPos < Length(OwnerLabel.Caption) then\r\n begin\r\n if FCharValue > Ord(OwnerLabel.Caption[FTextPos]) then\r\n begin\r\n Inc(FTextPos);\r\n FCharValue := 32;\r\n end;\r\n OwnerLabel.EffectText := Copy(OwnerLabel.Caption, 1, FTextPos) + Char(FCharValue);\r\n OwnerLabel.Repaint;\r\n Inc(FCharValue);\r\n FTimer.Enabled := True;\r\n end\r\n else\r\n Active := False;\r\nend;\r\n\r\nprocedure TJvLabelSpecial.SetInterval(const Value: Cardinal);\r\nbegin\r\n if FInterval <> Value then\r\n begin\r\n Suspend;\r\n FInterval := Value;\r\n Resume;\r\n end;\r\nend;\r\n\r\nprocedure TJvLabelSpecial.Start;\r\nbegin\r\n inherited Start;\r\n if OwnerLabel.ComponentState * [csLoading, csDestroying] <> [] then\r\n Exit;\r\n if FTimer = nil then\r\n begin\r\n FTimer := TTimer.Create(nil);\r\n FTimer.Enabled := False;\r\n FTimer.OnTimer := DoTimerEvent;\r\n end;\r\n FTextPos := 1;\r\n FCharValue := 32;\r\n OwnerLabel.EffectText := '';\r\n OwnerLabel.UseEffectText := True;\r\n FTimer.Interval := Interval;\r\n FTimer.Enabled := True;\r\nend;\r\n\r\nprocedure TJvLabelSpecial.Stop;\r\nbegin\r\n FreeAndNil(FTimer);\r\n OwnerLabel.UseEffectText := False;\r\n inherited Stop;\r\nend;\r\n\r\n//=== { TJvLabelCodeBreaker } ================================================\r\n\r\nconstructor TJvLabelCodeBreaker.Create(ALabel: TJvCustomBehaviorLabel);\r\nbegin\r\n inherited Create(ALabel);\r\n FInterval := 10;\r\nend;\r\n\r\nprocedure TJvLabelCodeBreaker.DoTimer(Sender: TObject);\r\nbegin\r\n FTimer.Enabled := False;\r\n if (FCurrentPos > Length(FScratchPad)) or (FCurrentPos > Length(DecodedText)) then\r\n begin\r\n OwnerLabel.EffectText := DecodedText;\r\n OwnerLabel.Repaint;\r\n Active := False;\r\n OwnerLabel.UseEffectText := False;\r\n Exit;\r\n end\r\n else\r\n if FScratchPad[FCurrentPos] <> DecodedText[FCurrentPos] then\r\n begin\r\n FScratchPad[FCurrentPos] := Char(32 + Random(Ord(DecodedText[FCurrentPos]) + 10));\r\n // OwnerLabel.EffectText := Copy(OwnerLabel.Caption, 1, FCurrentPos - 1) +\r\n // FScratchPad[FCurrentPos] + Copy(OwnerLabel.Caption, FCurrentPos + 1, MaxInt);\r\n // (p3) this is the same without the copying...\r\n OwnerLabel.EffectText := FScratchPad;\r\n OwnerLabel.Repaint;\r\n end\r\n else\r\n Inc(FCurrentPos);\r\n // (p3) this seems unnecessary since we have an Interval property\r\n// Sleep(FInterval);\r\n FTimer.Enabled := True;\r\nend;\r\n\r\nprocedure TJvLabelCodeBreaker.SetInterval(const Value: Integer);\r\nbegin\r\n if FInterval <> Value then\r\n begin\r\n Suspend;\r\n FInterval := Value;\r\n Resume;\r\n end;\r\nend;\r\n\r\nprocedure TJvLabelCodeBreaker.Start;\r\nbegin\r\n inherited Start;\r\n FCurrentPos := 1;\r\n if (Interval > 0) and (OwnerLabel.Caption <> '') and (DecodedText <> '') then\r\n begin\r\n FScratchPad := OwnerLabel.Caption;\r\n FTimer := TTimer.Create(nil);\r\n FTimer.Enabled := False;\r\n FTimer.OnTimer := DoTimer;\r\n FTimer.Interval := Interval;\r\n FTimer.Enabled := True;\r\n OwnerLabel.UseEffectText := True;\r\n end\r\n else\r\n Active := False;\r\nend;\r\n\r\nprocedure TJvLabelCodeBreaker.Stop;\r\nbegin\r\n FreeAndNil(FTimer);\r\n OwnerLabel.Caption := OwnerLabel.EffectText;\r\n OwnerLabel.UseEffectText := False;\r\n inherited Stop;\r\nend;\r\n\r\ninitialization\r\n {$IFDEF UNITVERSIONING}\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n {$ENDIF UNITVERSIONING}\r\n // (ahuser) registration is done in the constructor the first time it is called\r\n\r\nfinalization\r\n FreeAndNil(AllBehaviorOptions);\r\n {$IFDEF UNITVERSIONING}\r\n UnregisterUnitVersion(HInstance);\r\n {$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvBevel.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvBevel.PAS, released on 2001-02-28.\r\n\r\nThe Initial Developer of the Original Code is Sbastien Buysse [sbuysse att buypin dott com]\r\nPortions created by Sbastien Buysse are Copyright (C) 2001 Sbastien Buysse.\r\nAll Rights Reserved.\r\n\r\nContributor(s): Michael Beck [mbeck att bigfoot dott com].\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvBevel.pas 13138 2011-10-26 23:17:50Z jfudickar $\r\n\r\nunit JvBevel;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n Types,\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, Messages, Classes, Controls, ExtCtrls, Graphics,\r\n JvThemes, JvExExtCtrls;\r\n\r\ntype\r\n TJvBevelLines = class;\r\n\r\n TJvBevelStyle = (bsLowered, bsRaised, bsCustomStyle);\r\n TJvBevelShape = (bsBox, bsFrame, bsTopLine, bsBottomLine, bsLeftLine,\r\n bsRightLine, bsSpacer, bsCustomShape);\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvBevel = class(TJvExBevel)\r\n private\r\n FStyle: TJvBevelStyle;\r\n FShape: TJvBevelShape;\r\n FOuter: TBevelCut;\r\n FInner: TBevelCut;\r\n FPenWidth: Integer;\r\n FPenStyle: TPenStyle;\r\n FBold: Boolean;\r\n FEdges: TBevelEdges;\r\n FVerticalLines: TJvBevelLines;\r\n FHorizontalLines: TJvBevelLines;\r\n FHorLines: TJvBevelLines;\r\n\r\n procedure ReadBevelInner(Reader: TReader);\r\n procedure ReadBevelOuter(Reader: TReader);\r\n procedure ReadBevelSides(Reader: TReader);\r\n procedure ReadBevelBold(Reader: TReader);\r\n procedure ReadBevelPenStyle(Reader: TReader);\r\n procedure ReadBevelPenWidth(Reader: TReader);\r\n procedure IgnoreValue(Reader: TReader);\r\n\r\n procedure LinesChange(Sender: TObject);\r\n\r\n procedure SetStyle(const Value: TJvBevelStyle);\r\n procedure SetShape(const Value: TJvBevelShape);\r\n procedure SetInner(const Value: TBevelCut);\r\n procedure SetOuter(const Value: TBevelCut);\r\n procedure SetPenWidth(const Value: Integer);\r\n procedure SetPenStyle(const Value: TPenStyle);\r\n procedure SetBold(const Value: Boolean);\r\n procedure SetEdges(const Value: TBevelEdges);\r\n procedure SetHorizontalLines(const Value: TJvBevelLines);\r\n procedure SetVerticalLines(const Value: TJvBevelLines);\r\n protected\r\n procedure DrawBevel(R: TRect; Cut: TBevelCut; EffectiveEdges: TBevelEdges);\r\n procedure DrawBold(R: TRect; Cut: TBevelCut; EffectiveEdges: TBevelEdges);\r\n procedure DrawLines(InnerRect: TRect; Lines: TJvBevelLines; Vertical: Boolean);\r\n procedure Paint; override;\r\n procedure DefineProperties(Filer: TFiler); override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n published\r\n property Bold: Boolean read FBold write SetBold default False;\r\n property Edges: TBevelEdges read FEdges write SetEdges default [beLeft, beTop, beRight, beBottom];\r\n property Inner: TBevelCut read FInner write SetInner default bvNone;\r\n property Outer: TBevelCut read FOuter write SetOuter default bvLowered;\r\n property PenStyle: TPenStyle read FPenStyle write SetPenStyle default psSolid;\r\n property PenWidth: Integer read FPenWidth write SetPenWidth default 1;\r\n property HintColor;\r\n property HorizontalLines: TJvBevelLines read FHorizontalLines write SetHorizontalLines;\r\n property Shape: TJvBevelShape read FShape write SetShape default bsBox;\r\n property Style: TJvBevelStyle read FStyle write SetStyle default bsLowered;\r\n property VerticalLines: TJvBevelLines read FVerticalLines write SetVerticalLines;\r\n\r\n property OnMouseEnter;\r\n property OnMouseLeave;\r\n property OnParentColorChange;\r\n property OnClick;\r\n property OnDblClick;\r\n property OnDragDrop;\r\n property OnDragOver;\r\n property OnEndDock;\r\n property OnStartDock;\r\n property OnEndDrag;\r\n property OnMouseDown;\r\n property OnMouseMove;\r\n property OnMouseUp;\r\n property OnResize;\r\n property OnStartDrag;\r\n end;\r\n\r\n TJvBevelLines = class(TPersistent)\r\n private\r\n FCount: Cardinal;\r\n FStyle: TBevelCut;\r\n FBold: Boolean;\r\n FThickness: Byte;\r\n FIgnoreBorder: Boolean;\r\n FOnChange: TNotifyEvent;\r\n procedure IgnoreValue(Reader: TReader);\r\n procedure SetBold(const Value: Boolean);\r\n procedure SetCount(const Value: Cardinal);\r\n procedure SetIgnoreBorder(const Value: Boolean);\r\n procedure SetStyle(const Value: TBevelCut);\r\n procedure SetThickness(const Value: Byte);\r\n protected\r\n procedure DoChange; virtual;\r\n procedure DefineProperties(Filer: TFiler); override;\r\n public\r\n constructor Create;\r\n procedure Assign(Source: TPersistent); override;\r\n property OnChange: TNotifyEvent read FOnChange write FOnChange;\r\n published\r\n property Count: Cardinal read FCount write SetCount default 0;\r\n property Style: TBevelCut read FStyle write SetStyle default bvLowered;\r\n property Bold: Boolean read FBold write SetBold default False;\r\n property Thickness: Byte read FThickness write SetThickness default 1;\r\n property IgnoreBorder: Boolean read FIgnoreBorder write SetIgnoreBorder default False;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvBevel.pas $';\r\n Revision: '$Revision: 13138 $';\r\n Date: '$Date: 2011-10-27 01:17:50 +0200 (jeu. 27 oct. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n SysUtils, TypInfo, RTLConsts;\r\n\r\ntype\r\n TReaderAccess = class(TReader);\r\n\r\n//=== { TJvBevel } ===========================================================\r\n\r\nconstructor TJvBevel.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n IncludeThemeStyle(Self, [csParentBackground]);\r\n\r\n FHorizontalLines := TJvBevelLines.Create;\r\n FVerticalLines := TJvBevelLines.Create;\r\n\r\n FHorLines := TJvBevelLines.Create;\r\n\r\n FHorizontalLines.OnChange := LinesChange;\r\n FVerticalLines.OnChange := LinesChange;\r\n\r\n FEdges := [beLeft, beTop, beRight, beBottom];\r\n FInner := bvNone;\r\n FOuter := bvLowered;\r\n FPenWidth := 1;\r\n FShape := bsBox;\r\n FStyle := bsLowered;\r\nend;\r\n\r\nprocedure TJvBevel.DefineProperties(Filer: TFiler);\r\nbegin\r\n // Required for silent migration from Globus' TJvgBevel\r\n Filer.DefineProperty('BevelInner', ReadBevelInner, nil, False);\r\n Filer.DefineProperty('BevelOuter', ReadBevelOuter, nil, False);\r\n Filer.DefineProperty('BevelSides', ReadBevelSides, nil, False);\r\n Filer.DefineProperty('BevelBold', ReadBevelBold, nil, False);\r\n Filer.DefineProperty('BevelPenStyle', ReadBevelPenStyle, nil, False);\r\n Filer.DefineProperty('BevelPenWidth', ReadBevelPenWidth, nil, False);\r\n Filer.DefineProperty('InteriorOffset', IgnoreValue, nil, False);\r\n\r\n inherited DefineProperties(Filer);\r\nend;\r\n\r\ndestructor TJvBevel.Destroy;\r\nbegin\r\n FHorizontalLines.Free;\r\n FVerticalLines.Free;\r\n\r\n FHorLines.Free;\r\n\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvBevel.DrawBevel(R: TRect; Cut: TBevelCut; EffectiveEdges: TBevelEdges);\r\nvar\r\n ColorTopLeft: TColor;\r\n ColorBottomRight: TColor;\r\nbegin\r\n ColorTopLeft := clNone;\r\n ColorBottomRight := clNone;\r\n case Cut of\r\n bvLowered:\r\n begin\r\n ColorTopLeft := clBtnShadow;\r\n ColorBottomRight := clBtnHighlight;\r\n end;\r\n bvRaised:\r\n begin\r\n ColorTopLeft := clBtnHighlight;\r\n ColorBottomRight := clBtnShadow;\r\n end;\r\n end;\r\n\r\n if ColorTopLeft <> clNone then\r\n begin\r\n Canvas.Pen.Color := ColorTopLeft;\r\n if beLeft in EffectiveEdges then\r\n begin\r\n Canvas.MoveTo(R.Left, R.Bottom - 1);\r\n Canvas.LineTo(R.Left, R.Top - 1);\r\n end;\r\n if beTop in EffectiveEdges then\r\n begin\r\n Canvas.MoveTo(R.Left, R.Top);\r\n Canvas.LineTo(R.Right, R.Top);\r\n end;\r\n end;\r\n\r\n if ColorBottomRight <> clNone then\r\n begin\r\n Canvas.Pen.Color := ColorBottomRight;\r\n if beRight in EffectiveEdges then\r\n begin\r\n Canvas.MoveTo(R.Right, R.Top);\r\n Canvas.LineTo(R.Right, R.Bottom);\r\n end;\r\n if beBottom in EffectiveEdges then\r\n begin\r\n Canvas.MoveTo(R.Right, R.Bottom);\r\n Canvas.LineTo(R.Left - 1, R.Bottom);\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvBevel.DrawBold(R: TRect; Cut: TBevelCut; EffectiveEdges: TBevelEdges);\r\nbegin\r\n Canvas.Pen.Color := cl3DDkShadow;\r\n\r\n if Cut = bvLowered then\r\n begin\r\n if beLeft in EffectiveEdges then\r\n begin\r\n Canvas.MoveTo(R.Left - 1, R.Bottom - 1);\r\n Canvas.LineTo(R.Left - 1, R.Top - 1);\r\n end;\r\n\r\n if beTop in EffectiveEdges then\r\n begin\r\n Canvas.MoveTo(R.Left - 1, R.Top - 1);\r\n Canvas.LineTo(R.Right, R.Top - 1);\r\n end;\r\n end;\r\n\r\n if Cut = bvRaised then\r\n begin\r\n if beBottom in EffectiveEdges then\r\n begin\r\n Canvas.MoveTo(R.Left, R.Bottom + 1);\r\n Canvas.LineTo(R.Right + 1, R.Bottom + 1);\r\n end;\r\n\r\n if beRight in EffectiveEdges then\r\n begin\r\n Canvas.MoveTo(R.Right + 1, R.Bottom + 1);\r\n Canvas.LineTo(R.Right + 1, R.Top - 1);\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvBevel.DrawLines(InnerRect: TRect; Lines: TJvBevelLines;\r\n Vertical: Boolean);\r\nvar\r\n EffectiveRect: TRect;\r\n LineRect: TRect;\r\n I: Integer;\r\n LineEdges: TBevelEdges;\r\nbegin\r\n if Lines.IgnoreBorder then\r\n EffectiveRect := Rect(0, 0, Width-1, Height-1)\r\n else\r\n EffectiveRect := Rect(InnerRect.Left+1, InnerRect.Top+1, InnerRect.Right-1, InnerRect.Bottom-1);\r\n\r\n if Lines.Style = bvSpace then\r\n LineEdges := [beLeft, beTop]\r\n else\r\n if Vertical then\r\n LineEdges := [beLeft, beRight]\r\n else\r\n LineEdges := [beTop, beBottom];\r\n\r\n for I := 1 to Lines.Count do\r\n begin\r\n LineRect := EffectiveRect;\r\n\r\n if Vertical then\r\n begin\r\n LineRect.Left := Muldiv(I, Width, Lines.Count + 1);\r\n LineRect.Right := LineRect.Left + Lines.Thickness + Ord(Lines.Bold);\r\n end\r\n else\r\n begin\r\n LineRect.Top := Muldiv(I, Height, Lines.Count + 1);\r\n LineRect.Bottom := LineRect.Top + Lines.Thickness + Ord(Lines.Bold);\r\n end;\r\n\r\n DrawBevel(LineRect, Lines.Style, LineEdges);\r\n end;\r\nend;\r\n\r\nprocedure TJvBevel.IgnoreValue(Reader: TReader);\r\nbegin\r\n TReaderAccess(Reader).SkipValue;\r\nend;\r\n\r\nprocedure TJvBevel.LinesChange(Sender: TObject);\r\nbegin\r\n Invalidate;\r\n Style := bsCustomStyle;\r\nend;\r\n\r\nprocedure TJvBevel.Paint;\r\nvar\r\n EffectiveOuterRect: TRect;\r\n EffectiveInnerRect: TRect;\r\nbegin\r\n if (Style = bsCustomStyle) or (Shape = bsCustomShape) then\r\n begin\r\n Canvas.Pen.Style := PenStyle;\r\n Canvas.Pen.Width := PenWidth;\r\n\r\n EffectiveOuterRect := Rect(0, 0, Width - 1, Height - 1);\r\n EffectiveInnerRect := Rect(1, 1, Width - 2, Height - 2);\r\n\r\n // Boldness adds a dark shadow line outside any border line that is\r\n // drawn in clBtnShadow. This effectively pushes the line inwards.\r\n // clBtnShadow is used at top left for bvLowered and at bottom right\r\n // for bvRaised. In these cases the place where the clBtnShadow line\r\n // is to be drawn has to be moved inward and a cl3DDkShadow drawn in\r\n // its place.\r\n if Bold then\r\n begin\r\n case Outer of\r\n bvLowered:\r\n begin\r\n Inc(EffectiveOuterRect.Left);\r\n Inc(EffectiveOuterRect.Top);\r\n Inc(EffectiveInnerRect.Left);\r\n Inc(EffectiveInnerRect.Top);\r\n end;\r\n bvRaised:\r\n begin\r\n Dec(EffectiveOuterRect.Right);\r\n Dec(EffectiveOuterRect.Bottom);\r\n Dec(EffectiveInnerRect.Right);\r\n Dec(EffectiveInnerRect.Bottom);\r\n end;\r\n end;\r\n\r\n case Inner of\r\n bvLowered:\r\n begin\r\n Inc(EffectiveInnerRect.Left);\r\n Inc(EffectiveInnerRect.Top);\r\n end;\r\n bvRaised:\r\n begin\r\n Dec(EffectiveInnerRect.Right);\r\n Dec(EffectiveInnerRect.Bottom);\r\n end;\r\n end;\r\n\r\n DrawBold(EffectiveOuterRect, Outer, Edges);\r\n DrawBold(EffectiveInnerRect, Inner, Edges);\r\n end;\r\n\r\n DrawBevel(EffectiveOuterRect, Outer, Edges);\r\n DrawBevel(EffectiveInnerRect, Inner, Edges);\r\n\r\n if Inner in [bvLowered, bvRaised] then\r\n begin\r\n DrawLines(EffectiveInnerRect, HorizontalLines, False);\r\n DrawLines(EffectiveInnerRect, VerticalLines, True);\r\n end\r\n else\r\n begin\r\n DrawLines(EffectiveOuterRect, HorizontalLines, False);\r\n DrawLines(EffectiveOuterRect, VerticalLines, True);\r\n end;\r\n end\r\n else\r\n begin\r\n inherited Paint;\r\n end;\r\nend;\r\n\r\nprocedure TJvBevel.ReadBevelBold(Reader: TReader);\r\nbegin\r\n Bold := Reader.ReadBoolean;\r\nend;\r\n\r\nprocedure TJvBevel.ReadBevelInner(Reader: TReader);\r\nbegin\r\n Inner := TBevelCut(GetEnumValue(TypeInfo(TBevelCut), Reader.ReadIdent));\r\nend;\r\n\r\nprocedure TJvBevel.ReadBevelOuter(Reader: TReader);\r\nbegin\r\n Outer := TBevelCut(GetEnumValue(TypeInfo(TBevelCut), Reader.ReadIdent));\r\nend;\r\n\r\nprocedure TJvBevel.ReadBevelPenStyle(Reader: TReader);\r\nbegin\r\n PenStyle := TPenStyle(GetEnumValue(TypeInfo(TPenStyle), Reader.ReadIdent));\r\nend;\r\n\r\nprocedure TJvBevel.ReadBevelPenWidth(Reader: TReader);\r\nbegin\r\n PenWidth := Reader.ReadInteger;\r\nend;\r\n\r\nprocedure TJvBevel.ReadBevelSides(Reader: TReader);\r\nvar\r\n EnumType: PTypeInfo;\r\n EnumName: string;\r\n Value: Integer;\r\nbegin\r\n // To allow for the Globus TglSide property to be read, we must read the\r\n // set ourselves, replacing the fsd prefix by be before reading the value\r\n try\r\n if Reader.ReadValue <> vaSet then\r\n raise EReadError.CreateRes(@SInvalidPropertyValue);\r\n\r\n EnumType := TypeInfo(TBevelEdge);\r\n Edges := [];\r\n while True do\r\n begin\r\n EnumName := Reader.ReadStr;\r\n if EnumName = '' then\r\n Break;\r\n\r\n EnumName := StringReplace(EnumName, 'fsd', 'be', []);\r\n Value := GetEnumValue(EnumType, EnumName);\r\n if Value = -1 then\r\n raise EReadError.CreateRes(@SInvalidPropertyValue);\r\n\r\n Include(FEdges, TBevelEdge(Value));\r\n end;\r\n except\r\n // Reader.SkipSetBody\r\n while Reader.ReadStr <> '' do\r\n ;\r\n raise;\r\n end;\r\nend;\r\n\r\nprocedure TJvBevel.SetBold(const Value: Boolean);\r\nbegin\r\n if FBold <> Value then\r\n begin\r\n FBold := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvBevel.SetEdges(const Value: TBevelEdges);\r\nbegin\r\n if FEdges <> Value then\r\n begin\r\n FEdges := Value;\r\n Shape := bsCustomShape;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvBevel.SetHorizontalLines(const Value: TJvBevelLines);\r\nbegin\r\n FHorizontalLines.Assign(Value);\r\nend;\r\n\r\nprocedure TJvBevel.SetInner(const Value: TBevelCut);\r\nbegin\r\n if FInner <> Value then\r\n begin\r\n FInner := Value;\r\n Style := bsCustomStyle;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvBevel.SetOuter(const Value: TBevelCut);\r\nbegin\r\n if FOuter <> Value then\r\n begin\r\n FOuter := Value;\r\n Style := bsCustomStyle;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvBevel.SetPenStyle(const Value: TPenStyle);\r\nbegin\r\n if FPenStyle <> Value then\r\n begin\r\n FPenStyle := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvBevel.SetPenWidth(const Value: Integer);\r\nbegin\r\n if FPenWidth <> Value then\r\n begin\r\n FPenWidth := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvBevel.SetShape(const Value: TJvBevelShape);\r\nbegin\r\n if FShape <> Value then\r\n begin\r\n FShape := Value;\r\n if FShape <> bsCustomShape then\r\n begin\r\n inherited Shape := TBevelShape(FShape);\r\n\r\n // Set the other properties so that should the style become\r\n // bsCustomStyle, the rendering is the closest it can be to\r\n // the one done in the ancestor.\r\n // Those next few lines define the most common properties.\r\n FEdges := [beTop, beLeft, beBottom, beRight];\r\n case Style of\r\n bsLowered:\r\n begin\r\n FInner := bvRaised;\r\n FOuter := bvLowered;\r\n end;\r\n bsRaised:\r\n begin\r\n FInner := bvLowered;\r\n FOuter := bvRaised;\r\n end;\r\n end;\r\n\r\n // And now we adjust.\r\n case FShape of\r\n bsBox:\r\n begin\r\n FInner := bvNone;\r\n case Style of\r\n bsLowered:\r\n FOuter := bvLowered;\r\n bsRaised:\r\n FOuter := bvRaised;\r\n end;\r\n end;\r\n bsTopLine:\r\n begin\r\n FEdges := [beTop];\r\n end;\r\n bsBottomLine:\r\n begin\r\n FEdges := [beBottom];\r\n end;\r\n bsLeftLine:\r\n begin\r\n FEdges := [beLeft];\r\n end;\r\n bsRightLine:\r\n begin\r\n FEdges := [beRight];\r\n end;\r\n bsSpacer:\r\n begin\r\n FInner := bvSpace;\r\n FOuter := bvSpace;\r\n FEdges := [];\r\n end;\r\n end;\r\n end;\r\n\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvBevel.SetStyle(const Value: TJvBevelStyle);\r\nbegin\r\n if Value <> FStyle then\r\n begin\r\n FStyle := Value;\r\n if FStyle <> bsCustomStyle then\r\n begin\r\n inherited Style := TBevelStyle(FStyle);\r\n\r\n // Set the other properties so that should the shape become\r\n // bsCustomShape, the rendering is the closest it can be to\r\n // the one done in the ancestor.\r\n // Those next few lines define the most common properties.\r\n case FStyle of\r\n bsLowered:\r\n begin\r\n FInner := bvRaised;\r\n FOuter := bvLowered;\r\n end;\r\n bsRaised:\r\n begin\r\n FInner := bvLowered;\r\n FOuter := bvRaised;\r\n end;\r\n end;\r\n\r\n // And now we adjust\r\n case Shape of\r\n bsBox:\r\n begin\r\n FInner := bvNone;\r\n case FStyle of\r\n bsLowered:\r\n FOuter := bvLowered;\r\n bsRaised:\r\n FOuter := bvRaised;\r\n end;\r\n end;\r\n bsSpacer:\r\n begin\r\n FInner := bvSpace;\r\n FOuter := bvSpace;\r\n end;\r\n end;\r\n end;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvBevel.SetVerticalLines(const Value: TJvBevelLines);\r\nbegin\r\n FVerticalLines.Assign(Value);\r\nend;\r\n\r\n//=== { TJvBevelLines } ======================================================\r\n\r\nconstructor TJvBevelLines.Create;\r\nbegin\r\n inherited Create;\r\n\r\n FStyle := bvLowered;\r\n FThickness := 1;\r\nend;\r\n\r\nprocedure TJvBevelLines.Assign(Source: TPersistent);\r\nbegin\r\n if Source is TJvBevelLines then\r\n begin\r\n FCount := (Source as TJvBevelLines).Count;\r\n FStyle := (Source as TJvBevelLines).Style;\r\n FBold := (Source as TJvBevelLines).Bold;\r\n FThickness := (Source as TJvBevelLines).Thickness;\r\n FIgnoreBorder := (Source as TJvBevelLines).IgnoreBorder;\r\n DoChange;\r\n end\r\n else\r\n begin\r\n inherited Assign(Source);\r\n end;\r\nend;\r\n\r\nprocedure TJvBevelLines.DefineProperties(Filer: TFiler);\r\nbegin\r\n Filer.DefineProperty('Step', IgnoreValue, nil, False);\r\n Filer.DefineProperty('Origin', IgnoreValue, nil, False);\r\n\r\n inherited DefineProperties(Filer);\r\nend;\r\n\r\nprocedure TJvBevelLines.DoChange;\r\nbegin\r\n if Assigned(FOnChange) then\r\n FOnChange(Self);\r\nend;\r\n\r\nprocedure TJvBevelLines.IgnoreValue(Reader: TReader);\r\nbegin\r\n TReaderAccess(Reader).SkipValue;\r\nend;\r\n\r\nprocedure TJvBevelLines.SetBold(const Value: Boolean);\r\nbegin\r\n if FBold <> Value then\r\n begin\r\n FBold := Value;\r\n DoChange;\r\n end;\r\nend;\r\n\r\nprocedure TJvBevelLines.SetCount(const Value: Cardinal);\r\nbegin\r\n if FCount <> Value then\r\n begin\r\n FCount := Value;\r\n DoChange;\r\n end;\r\nend;\r\n\r\nprocedure TJvBevelLines.SetIgnoreBorder(const Value: Boolean);\r\nbegin\r\n if FIgnoreBorder <> Value then\r\n begin\r\n FIgnoreBorder := Value;\r\n DoChange;\r\n end;\r\nend;\r\n\r\nprocedure TJvBevelLines.SetStyle(const Value: TBevelCut);\r\nbegin\r\n if FStyle <> Value then\r\n begin\r\n FStyle := Value;\r\n DoChange;\r\n end;\r\nend;\r\n\r\nprocedure TJvBevelLines.SetThickness(const Value: Byte);\r\nbegin\r\n if FThickness <> Value then\r\n begin\r\n FThickness := Value;\r\n DoChange;\r\n end;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvBitBtn.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvBitBtn.PAS, released on 2001-02-28.\r\n\r\nThe Initial Developer of the Original Code is Sbastien Buysse [sbuysse att buypin dott com]\r\nPortions created by Sbastien Buysse are Copyright (C) 2001 Sbastien Buysse.\r\nAll Rights Reserved.\r\n\r\nContributor(s): Michael Beck [mbeck att bigfoot dott com].\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvBitBtn.pas 13415 2012-09-10 09:51:54Z obones $\r\n\r\nunit JvBitBtn;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, Messages, Classes, Graphics, Controls, Menus, Types,\r\n JvTypes, JvExButtons;\r\n\r\ntype\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvBitBtn = class(TJvExBitBtn)\r\n private\r\n FHotTrack: Boolean;\r\n FHotTrackFont: TFont;\r\n FFontSave: TFont;\r\n FHotTrackFontOptions: TJvTrackFontOptions;\r\n FHotGlyph: TBitmap;\r\n FOldGlyph: TBitmap;\r\n FDropDown: TPopupMenu;\r\n FCanvas: TControlCanvas;\r\n FSimpleFrame: Boolean;\r\n function GetCanvas: TCanvas;\r\n procedure SetHotGlyph(Value: TBitmap);\r\n procedure SetHotTrackFont(const Value: TFont);\r\n procedure SetHotTrackFontOptions(const Value: TJvTrackFontOptions);\r\n procedure CNDrawItem(var Msg: TWMDrawItem); message CN_DRAWITEM;\r\n protected\r\n procedure MouseEnter(AControl: TControl); override;\r\n procedure MouseLeave(AControl: TControl); override;\r\n procedure FontChanged; override;\r\n procedure DrawItem(const DrawItemStruct: TDrawItemStruct); virtual;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n procedure Click; override;\r\n property Canvas: TCanvas read GetCanvas;\r\n published\r\n property DropDownMenu: TPopupMenu read FDropDown write FDropDown;\r\n property HintColor;\r\n property HotTrack: Boolean read FHotTrack write FHotTrack default False;\r\n property HotTrackFont: TFont read FHotTrackFont write SetHotTrackFont;\r\n property HotTrackFontOptions: TJvTrackFontOptions read FHotTrackFontOptions write SetHotTrackFontOptions default DefaultTrackFontOptions;\r\n property HotGlyph: TBitmap read FHotGlyph write SetHotGlyph;\r\n property OnMouseEnter;\r\n property OnMouseLeave;\r\n property OnParentColorChange;\r\n\r\n property SimpleFrame: Boolean read FSimpleFrame write FSimpleFrame default False;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvBitBtn.pas $';\r\n Revision: '$Revision: 13415 $';\r\n Date: '$Date: 2012-09-10 11:51:54 +0200 (lun. 10 sept. 2012) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n {$IFDEF HAS_UNIT_SYSTEM_UITYPES}\r\n System.UITypes,\r\n {$ENDIF HAS_UNIT_SYSTEM_UITYPES}\r\n JvJVCLUtils;\r\n\r\nconstructor TJvBitBtn.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FCanvas := TControlCanvas.Create;\r\n FCanvas.Control := Self;\r\n FHotTrack := False;\r\n FSimpleFrame := False;\r\n FHotTrackFont := TFont.Create;\r\n FFontSave := TFont.Create;\r\n FHotGlyph := TBitmap.Create;\r\n FOldGlyph := TBitmap.Create;\r\n FHotTrackFontOptions := DefaultTrackFontOptions;\r\nend;\r\n\r\ndestructor TJvBitBtn.Destroy;\r\nbegin\r\n FHotTrackFont.Free;\r\n FFontSave.Free;\r\n FHotGlyph.Free;\r\n FOldGlyph.Free;\r\n inherited Destroy;\r\n // (rom) destroy Canvas AFTER inherited Destroy\r\n FCanvas.Free;\r\nend;\r\n\r\nfunction TJvBitBtn.GetCanvas: TCanvas;\r\nbegin\r\n Result := FCanvas;\r\nend;\r\n\r\nprocedure TJvBitBtn.Click;\r\nbegin\r\n inherited Click;\r\n if FDropDown <> nil then\r\n begin\r\n FDropDown.Popup(GetClientOrigin.X, GetClientOrigin.Y + Height);\r\n MouseLeave(Self);\r\n end;\r\nend;\r\n\r\nprocedure TJvBitBtn.SetHotGlyph(Value: TBitmap);\r\nbegin\r\n FHotGlyph.Assign(Value);\r\nend;\r\n\r\nprocedure TJvBitBtn.SetHotTrackFont(const Value: TFont);\r\nbegin\r\n FHotTrackFont.Assign(Value);\r\nend;\r\n\r\nprocedure TJvBitBtn.SetHotTrackFontOptions(const Value: TJvTrackFontOptions);\r\nbegin\r\n if FHotTrackFontOptions <> Value then\r\n begin\r\n FHotTrackFontOptions := Value;\r\n UpdateTrackFont(HotTrackFont, Font, FHotTrackFontOptions);\r\n end;\r\nend;\r\n\r\nprocedure TJvBitBtn.MouseEnter(AControl: TControl);\r\nbegin\r\n if csDesigning in ComponentState then\r\n Exit;\r\n if not MouseOver then\r\n begin\r\n if not FHotGlyph.Empty then\r\n begin\r\n FOldGlyph.Assign(Glyph);\r\n Glyph.Assign(FHotGlyph);\r\n end;\r\n if FHotTrack then\r\n begin\r\n FFontSave.Assign(Font);\r\n Font.Assign(FHotTrackFont);\r\n end;\r\n inherited MouseEnter(AControl);\r\n end;\r\nend;\r\n\r\nprocedure TJvBitBtn.MouseLeave(AControl: TControl);\r\nbegin\r\n if MouseOver then\r\n begin\r\n if not FHotGlyph.Empty then\r\n Glyph.Assign(FOldGlyph);\r\n if FHotTrack then\r\n Font.Assign(FFontSave);\r\n inherited MouseLeave(AControl);\r\n end;\r\nend;\r\n\r\nprocedure TJvBitBtn.FontChanged;\r\nbegin\r\n inherited FontChanged;\r\n UpdateTrackFont(HotTrackFont, Font, HotTrackFontOptions);\r\nend;\r\n\r\nprocedure TJvBitBtn.CNDrawItem(var Msg: TWMDrawItem);\r\nbegin\r\n inherited;\r\n DrawItem(Msg.DrawItemStruct^);\r\nend;\r\n\r\nprocedure TJvBitBtn.DrawItem(const DrawItemStruct: TDrawItemStruct);\r\nvar\r\n IsDown: Boolean;\r\n R: TRect;\r\nbegin\r\n if (csDestroying in ComponentState) or not FSimpleFrame then\r\n Exit;\r\n FCanvas.Handle := DrawItemStruct.hDC;\r\n R := ClientRect;\r\n IsDown := DrawItemStruct.itemState and ODS_SELECTED <> 0;\r\n if not MouseOver and not IsDown then\r\n begin\r\n with FCanvas do\r\n begin\r\n if not Focused and not Default then\r\n begin\r\n Pen.Color := clBtnFace;\r\n MoveTo(R.Left + 1, R.Top + 1);\r\n LineTo(R.Right - 1, R.Top + 1);\r\n MoveTo(R.Left + 1, R.Top + 1);\r\n LineTo(R.Left + 1, R.Bottom - 1);\r\n\r\n Pen.Color := (Parent as TWinControl).Brush.Color;\r\n MoveTo(R.Left, R.Bottom - 1);\r\n LineTo(R.Right, R.Bottom - 1);\r\n MoveTo(R.Right - 1, R.Top);\r\n LineTo(R.Right - 1, R.Bottom);\r\n\r\n Pen.Color := clBtnShadow;\r\n MoveTo(R.Left - 2, R.Bottom - 2);\r\n LineTo(R.Right - 1, R.Bottom - 2);\r\n MoveTo(R.Right - 2, R.Top);\r\n LineTo(R.Right - 2, R.Bottom - 1);\r\n end\r\n else\r\n begin\r\n Brush.Color := clBtnFace;\r\n FrameRect(Rect(R.Left + 2, R.Top + 2, R.Right - 2, R.Bottom - 2));\r\n end;\r\n end;\r\n end;\r\n FCanvas.Handle := 0;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvBitmapButton.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvBitmapButton.PAS, released on 2002-06-15.\r\n\r\nThe Initial Developer of the Original Code is Jan Verhoeven [jan1 dott verhoeven att wxs dott nl]\r\nPortions created by Jan Verhoeven are Copyright (C) 2002 Jan Verhoeven.\r\nAll Rights Reserved.\r\n\r\nContributor(s): Robert Love [rlove att slcdug dott org].\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvBitmapButton.pas 13104 2011-09-07 06:50:43Z obones $\r\n\r\nunit JvBitmapButton;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, Messages, Types, Classes, Graphics, Controls,\r\n JvComponent, JvTypes;\r\n\r\ntype\r\n PJvRGBTriple = ^TJvRGBTriple;\r\n\r\n TPixelTransform = procedure(Dest, Source: PJvRGBTriple);\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvBitmapButton = class(TJvGraphicControl)\r\n private\r\n FBitmap: TBitmap;\r\n FLighter: TBitmap;\r\n FDarker: TBitmap;\r\n FNormal: TBitmap;\r\n FPushDown: Boolean;\r\n FMouseOver: Boolean;\r\n FLatching: Boolean;\r\n FDown: Boolean;\r\n FHotTrack: Boolean;\r\n FCaption: string;\r\n FFont: TFont;\r\n FCaptionLeft: Integer;\r\n FCaptionTop: Integer;\r\n FLighterFontColor: TColor;\r\n FDarkerFontColor: TColor;\r\n procedure SetBitmap(const Value: TBitmap);\r\n procedure MakeNormal;\r\n procedure MakeDarker;\r\n procedure MakeLighter;\r\n procedure MakeHelperBitmap(Target: TBitmap; Transform: TPixelTransform);\r\n procedure MakeCaption(Target: TBitmap; FontColor: TColor);\r\n procedure SetLatching(const Value: Boolean);\r\n procedure SetDown(const Value: Boolean);\r\n procedure SetHotTrack(const Value: Boolean);\r\n procedure SetCaption(const Value: string);\r\n procedure SetFont(const Value: TFont);\r\n procedure SetCaptionLeft(const Value: Integer);\r\n procedure SetCaptionTop(const Value: Integer);\r\n procedure UpdateBitmaps;\r\n procedure SetDarkerFontColor(const Value: TColor);\r\n procedure SetLighterFontColor(const Value: TColor);\r\n protected\r\n procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;\r\n procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;\r\n procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;\r\n procedure MouseLeave(AControl: TControl); override;\r\n procedure Click; override;\r\n procedure Loaded; override;\r\n procedure Resize; override;\r\n procedure Paint; override;\r\n procedure DoBitmapChange(Sender: TObject);\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n published\r\n property Bitmap: TBitmap read FBitmap write SetBitmap;\r\n property Caption: string read FCaption write SetCaption;\r\n property CaptionLeft: Integer read FCaptionLeft write SetCaptionLeft;\r\n property CaptionTop: Integer read FCaptionTop write SetCaptionTop;\r\n property DarkerFontColor: TColor read FDarkerFontColor write SetDarkerFontColor;\r\n property Down: Boolean read FDown write SetDown default False;\r\n property Font: TFont read FFont write SetFont;\r\n property HotTrack: Boolean read FHotTrack write SetHotTrack default True;\r\n property Height default 24;\r\n property Hint;\r\n property Latching: Boolean read FLatching write SetLatching default False;\r\n property LighterFontColor: TColor read FLighterFontColor write SetLighterFontColor;\r\n property ShowHint;\r\n property Width default 24;\r\n property OnClick;\r\n property OnMouseDown;\r\n property OnMouseUp;\r\n property Visible;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvBitmapButton.pas $';\r\n Revision: '$Revision: 13104 $';\r\n Date: '$Date: 2011-09-07 08:50:43 +0200 (mer. 07 sept. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\n\r\nconstructor TJvBitmapButton.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n Width := 24;\r\n Height := 24;\r\n FPushDown := False;\r\n FMouseOver := False;\r\n FLatching := False;\r\n FHotTrack := True;\r\n FDown := False;\r\n FBitmap := TBitmap.Create;\r\n FBitmap.Width := 24;\r\n FBitmap.Height := 24;\r\n FBitmap.PixelFormat := pf24bit;\r\n FBitmap.Canvas.Brush.Color := clGray;\r\n FBitmap.Canvas.FillRect(Rect(1, 1, 23, 23));\r\n FBitmap.OnChange := DoBitmapChange;\r\n FLighter := TBitmap.Create;\r\n FDarker := TBitmap.Create;\r\n FNormal := TBitmap.Create;\r\n FFont := TFont.Create;\r\nend;\r\n\r\ndestructor TJvBitmapButton.Destroy;\r\nbegin\r\n FBitmap.Free;\r\n FLighter.Free;\r\n FDarker.Free;\r\n FNormal.Free;\r\n FFont.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvBitmapButton.Click;\r\nbegin\r\n if FPushDown then\r\n if Assigned(OnClick) then\r\n inherited Click;\r\nend;\r\n\r\nprocedure TJvBitmapButton.MouseDown(Button: TMouseButton;\r\n Shift: TShiftState; X, Y: Integer);\r\nbegin\r\n FPushDown := not FBitmap.Transparent and\r\n (FBitmap.Canvas.Pixels[X, Y] <> FBitmap.Canvas.Pixels[0, FBitmap.Height - 1]);\r\n Repaint;\r\n inherited MouseDown(Button, Shift, X, Y);\r\nend;\r\n\r\nprocedure TJvBitmapButton.MouseUp(Button: TMouseButton;\r\n Shift: TShiftState; X, Y: Integer);\r\nbegin\r\n FPushDown := False;\r\n if Latching then\r\n FDown := not FDown\r\n else\r\n FDown := False;\r\n Repaint;\r\n inherited MouseUp(Button, Shift, X, Y);\r\nend;\r\n\r\nprocedure TJvBitmapButton.Paint;\r\nbegin\r\n inherited Paint;\r\n if Assigned(FBitmap) then\r\n begin\r\n if FPushDown then\r\n Canvas.Draw(1, 1, FDarker)\r\n else\r\n begin\r\n if Down then\r\n Canvas.Draw(1, 1, FDarker)\r\n else\r\n if FMouseOver and FHotTrack then\r\n Canvas.Draw(0, 0, FLighter)\r\n else\r\n Canvas.Draw(0, 0, FNormal);\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvBitmapButton.SetBitmap(const Value: TBitmap);\r\nbegin\r\n FBitmap.Assign(Value);\r\n FBitmap.Transparent := True;\r\nend;\r\n\r\nprocedure TJvBitmapButton.UpdateBitmaps;\r\nbegin\r\n MakeLighter;\r\n MakeDarker;\r\n MakeNormal;\r\n Repaint;\r\nend;\r\n\r\nprocedure LighterTransform(Dest, Source: PJvRGBTriple);\r\nbegin\r\n Dest.rgbBlue := $FF - Round(0.8 * Abs($FF - Source.rgbBlue));\r\n Dest.rgbGreen := $FF - Round(0.8 * Abs($FF - Source.rgbGreen));\r\n Dest.rgbRed := $FF - Round(0.8 * Abs($FF - Source.rgbRed));\r\nend;\r\n\r\nprocedure DarkerTransform(Dest, Source: PJvRGBTriple);\r\nbegin\r\n Dest.rgbBlue := Round(0.7 * Source.rgbBlue);\r\n Dest.rgbGreen := Round(0.7 * Source.rgbGreen);\r\n Dest.rgbRed := Round(0.7 * Source.rgbRed);\r\nend;\r\n\r\nprocedure TJvBitmapButton.MakeLighter;\r\nbegin\r\n MakeHelperBitmap(FLighter, LighterTransform);\r\n MakeCaption(FLighter, FLighterFontColor);\r\nend;\r\n\r\n\r\nprocedure TJvBitmapButton.MakeDarker;\r\nbegin\r\n MakeHelperBitmap(FDarker, DarkerTransform);\r\n MakeCaption(FDarker, FDarkerFontColor);\r\nend;\r\n\r\nprocedure TJvBitmapButton.MouseLeave(AControl: TControl);\r\nbegin\r\n FMouseOver := False;\r\n MakeDarker;\r\n MakeNormal;\r\n Repaint;\r\nend;\r\n\r\nprocedure TJvBitmapButton.Loaded;\r\nbegin\r\n inherited Loaded;\r\n if not FBitmap.Empty then\r\n begin\r\n MakeDarker;\r\n MakeLighter;\r\n MakeNormal;\r\n end;\r\n Resize;\r\nend;\r\n\r\nprocedure TJvBitmapButton.SetLatching(const Value: Boolean);\r\nbegin\r\n FLatching := Value;\r\n if not FLatching then\r\n begin\r\n FDown := False;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvBitmapButton.SetDown(const Value: Boolean);\r\nbegin\r\n if FLatching then\r\n FDown := Value\r\n else\r\n FDown := False;\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvBitmapButton.Resize;\r\nbegin\r\n inherited Resize;\r\n if Assigned(FBitmap) then\r\n begin\r\n Width := FBitmap.Width;\r\n Height := FBitmap.Height;\r\n end\r\n else\r\n begin\r\n Width := 24;\r\n Height := 24;\r\n end;\r\nend;\r\n\r\nprocedure TJvBitmapButton.SetHotTrack(const Value: Boolean);\r\nbegin\r\n FHotTrack := Value;\r\nend;\r\n\r\nprocedure TJvBitmapButton.MouseMove(Shift: TShiftState; X, Y: Integer);\r\nvar\r\n Value: Boolean;\r\nbegin\r\n inherited MouseMove(Shift, X, Y);\r\n Value := FBitmap.Canvas.Pixels[X, Y] <> FBitmap.Canvas.Pixels[0, FBitmap.Height - 1];\r\n if Value <> FMouseOver then\r\n begin\r\n FMouseOver := Value;\r\n Repaint;\r\n end;\r\nend;\r\n\r\nprocedure TJvBitmapButton.SetCaption(const Value: string);\r\nbegin\r\n if Value <> FCaption then\r\n begin\r\n FCaption := Value;\r\n UpdateBitmaps;\r\n end;\r\nend;\r\n\r\nprocedure TJvBitmapButton.SetFont(const Value: TFont);\r\nbegin\r\n if Value <> FFont then\r\n begin\r\n FFont := Value;\r\n Canvas.Font.Assign(FFont);\r\n UpdateBitmaps;\r\n end;\r\nend;\r\n\r\nprocedure TJvBitmapButton.SetCaptionLeft(const Value: Integer);\r\nbegin\r\n if Value <> FCaptionLeft then\r\n begin\r\n FCaptionLeft := Value;\r\n UpdateBitmaps;\r\n end;\r\nend;\r\n\r\nprocedure TJvBitmapButton.SetCaptionTop(const Value: Integer);\r\nbegin\r\n if Value <> FCaptionTop then\r\n begin\r\n FCaptionTop := Value;\r\n UpdateBitmaps;\r\n end;\r\nend;\r\n\r\nprocedure TJvBitmapButton.MakeNormal;\r\nbegin\r\n FNormal.Assign(FBitmap);\r\n MakeCaption(FNormal, Font.Color);\r\nend;\r\n\r\nprocedure TJvBitmapButton.SetDarkerFontColor(const Value: TColor);\r\nbegin\r\n if Value <> FDarkerFontColor then\r\n begin\r\n FDarkerFontColor := Value;\r\n UpdateBitmaps;\r\n end;\r\nend;\r\n\r\nprocedure TJvBitmapButton.SetLighterFontColor(const Value: TColor);\r\nbegin\r\n if Value <> FLighterFontColor then\r\n begin\r\n FLighterFontColor := Value;\r\n UpdateBitmaps;\r\n end;\r\nend;\r\n\r\nprocedure TJvBitmapButton.DoBitmapChange(Sender: TObject);\r\nbegin\r\n if FBitmap.PixelFormat <> pf24bit then\r\n begin\r\n FBitmap.OnChange := nil;\r\n try\r\n FBitmap.PixelFormat := pf24bit;\r\n finally\r\n FBitmap.OnChange := DoBitmapChange;\r\n end;\r\n end;\r\n Width := FBitmap.Width;\r\n Height := FBitmap.Height;\r\n UpdateBitmaps;\r\nend;\r\n\r\nprocedure TJvBitmapButton.MakeCaption(Target: TBitmap; FontColor: TColor);\r\nvar\r\n R: TRect;\r\nbegin\r\n if FCaption <> '' then\r\n with Target.Canvas do\r\n begin\r\n Brush.Style := bsClear;\r\n Font.Assign(FFont);\r\n Font.Color := FontColor;\r\n R := Rect(0, 0, Width, Height);\r\n TextRect(R, FCaptionLeft, FCaptionTop, FCaption);\r\n end;\r\nend;\r\n\r\nprocedure TJvBitmapButton.MakeHelperBitmap(Target: TBitmap; Transform: TPixelTransform);\r\nvar\r\n P1, P2: PJvRGBTriple;\r\n X, Y: Integer;\r\n RT, GT, BT: Byte;\r\n LColor: TColor;\r\nbegin\r\n Target.Width := FBitmap.Width;\r\n Target.Height := FBitmap.Height;\r\n Target.Transparent := FBitmap.Transparent;\r\n if FBitmap.Transparent then\r\n begin\r\n LColor := FBitmap.TransparentColor;\r\n Target.TransparentColor := LColor;\r\n end\r\n else\r\n LColor := clNone;\r\n RT := GetRValue(LColor);\r\n GT := GetGValue(LColor);\r\n BT := GetBValue(LColor);\r\n Target.PixelFormat := pf24bit;\r\n Assert(FBitmap.PixelFormat = pf24bit);\r\n for Y := 0 to FBitmap.Height - 1 do\r\n begin\r\n P1 := FBitmap.ScanLine[Y];\r\n P2 := Target.ScanLine[Y];\r\n for X := 1 to FBitmap.Width do\r\n begin\r\n if (LColor <> clNone) and\r\n (P1.rgbBlue = BT) and (P1.rgbGreen = GT) and (P1.rgbRed = RT) then\r\n P2^ := P1^\r\n else\r\n Transform(P2, P1);\r\n Inc(P1);\r\n Inc(P2);\r\n end;\r\n end;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvBmpAnimator.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvBmpAnim.PAS, released on 2002-05-26.\r\n\r\nThe Initial Developer of the Original Code is Peter Thrnqvist [peter3 at sourceforge dot net]\r\nPortions created by Peter Thrnqvist are Copyright (C) 2002 Peter Thrnqvist.\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nDescription:\r\n A bitmap animator: animates an imagelist consisting of multiple likesized bitmaps\r\n like the explorer logo in Internet Explorer or Netscape Navigator.\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvBmpAnimator.pas 13104 2011-09-07 06:50:43Z obones $\r\n\r\nunit JvBmpAnimator;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Classes, Windows, Messages, Graphics, Controls, ExtCtrls, ImgList,\r\n JvComponent;\r\n\r\ntype\r\n TJvAnimateDirection = (tdForward, tdBack, tdFwdBack, tdBackFwd);\r\n\r\n TJvCustomBmpAnimator = class(TJvGraphicControl)\r\n private\r\n FImageList: TCustomImageList;\r\n FTimer: TTimer;\r\n FIndex: Integer;\r\n FActive: Boolean;\r\n FWidth: Integer;\r\n FHeight: Integer;\r\n FNumGlyphs: Integer;\r\n FSpeed: Integer;\r\n FTransparent: Boolean;\r\n FAutoSize: Boolean;\r\n FStart: Integer;\r\n FStop: Integer;\r\n FPosition: Integer;\r\n FDirection: TJvAnimateDirection;\r\n FGoingUp: Boolean;\r\n FCenter: Boolean;\r\n FImageChangeLink: TChangeLink;\r\n procedure SetCenter(Value: Boolean);\r\n procedure SetDirection(Value: TJvAnimateDirection);\r\n procedure SetPosition(Value: Integer);\r\n procedure SetStart(Value: Integer);\r\n procedure SetStop(Value: Integer);\r\n procedure SetTransparent(Value: Boolean);\r\n procedure SetImage(Value: TCustomImageList);\r\n procedure SetActive(Value: Boolean);\r\n procedure SetNumGlyphs(Value: Integer);\r\n procedure SetSpeed(Value: Integer);\r\n procedure TimerEvent(Sender: TObject);\r\n procedure DoChange(Sender: TObject);\r\n protected\r\n procedure Paint; override;\r\n procedure SetAutoSize(Value: Boolean); override;\r\n property AutoSize: Boolean read FAutoSize write SetAutoSize default False;\r\n procedure Notification(AComponent: TComponent; AOperation: TOperation); override;\r\n property Centered: Boolean read FCenter write SetCenter;\r\n property Color default clBtnFace;\r\n property Direction: TJvAnimateDirection read FDirection write SetDirection;\r\n property Active: Boolean read FActive write SetActive default False;\r\n property Images: TCustomImageList read FImageList write SetImage;\r\n property NumFrames: Integer read FNumGlyphs write SetNumGlyphs default 0;\r\n property Position: Integer read FPosition write SetPosition default 0;\r\n property Speed: Integer read FSpeed write SetSpeed default 100;\r\n property Min: Integer read FStart write SetStart default 0;\r\n property Max: Integer read FStop write SetStop default 0;\r\n property Transparent: Boolean read FTransparent write SetTransparent default False;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n end;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvBmpAnimator = class(TJvCustomBmpAnimator)\r\n published\r\n property Active;\r\n property Align;\r\n property AutoSize;\r\n property Centered;\r\n property Color;\r\n property Direction;\r\n property Height;\r\n property Images;\r\n property Left;\r\n property Name;\r\n property NumFrames;\r\n property Position;\r\n property Speed;\r\n property Min;\r\n property Max;\r\n property Tag;\r\n property Top;\r\n property Transparent;\r\n property Width;\r\n property OnClick;\r\n property OnMouseDown;\r\n property OnMouseMove;\r\n property OnMouseUp;\r\n property OnDragDrop;\r\n property OnEndDrag;\r\n property OnStartDrag;\r\n property OnDragOver;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvBmpAnimator.pas $';\r\n Revision: '$Revision: 13104 $';\r\n Date: '$Date: 2011-09-07 08:50:43 +0200 (mer. 07 sept. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n JvJVCLUtils;\r\n\r\n\r\nconstructor TJvCustomBmpAnimator.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FImageChangeLink := TChangeLink.Create;\r\n FImageChangeLink.OnChange := DoChange;\r\n FWidth := 60;\r\n FHeight := 60;\r\n Width := FWidth;\r\n Height := FHeight;\r\n FTransparent := False;\r\n FAutoSize := False;\r\n FSpeed := 15;\r\n FNumGlyphs := 0;\r\n FIndex := 0;\r\n FStart := 0;\r\n FStop := 0;\r\n FPosition := 0;\r\n FActive := False;\r\n Color := clBtnFace;\r\n FTimer := TTimer.Create(nil);\r\n FTimer.OnTimer := TimerEvent;\r\n FTimer.Enabled := FActive;\r\n FTimer.Interval := 100;\r\n FDirection := tdForward;\r\n FGoingUp := True;\r\nend;\r\n\r\ndestructor TJvCustomBmpAnimator.Destroy;\r\nbegin\r\n FImageChangeLink.Free;\r\n FTimer.Enabled := False;\r\n FTimer.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvCustomBmpAnimator.DoChange(Sender: TObject);\r\nbegin\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvCustomBmpAnimator.TimerEvent(Sender: TObject);\r\nbegin\r\n if not Assigned(FImageList) then\r\n Exit;\r\n\r\n if not Active then\r\n FIndex := FPosition\r\n else\r\n case FDirection of\r\n tdForward:\r\n begin\r\n Inc(FIndex);\r\n if (FIndex > FNumGlyphs) or (FIndex > FStop) then\r\n FIndex := FStart;\r\n end;\r\n tdBack:\r\n begin\r\n Dec(FIndex);\r\n if (FIndex < 0) or (FIndex < FStart) then\r\n FIndex := FStop;\r\n end;\r\n tdFwdBack, tdBackFwd:\r\n begin\r\n if FGoingUp then\r\n begin\r\n if (FIndex >= FStop) then\r\n begin\r\n FGoingUp := False;\r\n Dec(FIndex);\r\n end\r\n else\r\n Inc(FIndex);\r\n end\r\n else\r\n begin\r\n if FIndex <= FStart then\r\n begin\r\n FGoingUp := True;\r\n Inc(FIndex);\r\n end\r\n else\r\n Dec(FIndex);\r\n end;\r\n end;\r\n end;\r\n Refresh;\r\nend;\r\n\r\nprocedure TJvCustomBmpAnimator.SetStart(Value: Integer);\r\nbegin\r\n if FStart <> Value then\r\n begin\r\n FStart := Value;\r\n if FStart > FStop then\r\n FStart := FStop;\r\n if FStart >= FNumGlyphs then\r\n FStart := FNumGlyphs - 1;\r\n if FStart < 0 then\r\n FStart := 0;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomBmpAnimator.SetStop(Value: Integer);\r\nbegin\r\n if FStop <> Value then\r\n begin\r\n FStop := Value;\r\n if FStop < FStart then\r\n FStop := FStart;\r\n if FStop >= FNumGlyphs then\r\n FStop := FNumGlyphs - 1;\r\n if FStop < 0 then\r\n FStop := 0;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomBmpAnimator.SetAutoSize(Value: Boolean);\r\nbegin\r\n if FAutoSize <> Value then\r\n begin\r\n FAutoSize := Value;\r\n if FAutoSize and Assigned(FImageList) then\r\n begin\r\n Width := FImageList.Width;\r\n Height := FImageList.Height;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomBmpAnimator.SetTransparent(Value: Boolean);\r\nbegin\r\n if FTransparent <> Value then\r\n begin\r\n FTransparent := Value;\r\n Repaint;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomBmpAnimator.Notification(AComponent: TComponent; AOperation: TOperation);\r\nbegin\r\n inherited Notification(AComponent, AOperation);\r\n if (AOperation = opRemove) and (AComponent = FImageList) then\r\n SetImage(nil);\r\nend;\r\n\r\nprocedure TJvCustomBmpAnimator.SetImage(Value: TCustomImageList);\r\nbegin\r\n if FImageList <> nil then\r\n SetNumGlyphs(0);\r\n\r\n ReplaceImageListReference(Self, Value, FImageList, FImageChangeLink);\r\n if FImageList <> nil then\r\n SetNumGlyphs(FImageList.Count)\r\n else\r\n Active := False;\r\n Repaint;\r\nend;\r\n\r\nprocedure TJvCustomBmpAnimator.SetActive(Value: Boolean);\r\nbegin\r\n{ if not Assigned(FImageList) then\r\n Value := False;}\r\n if FActive <> Value then\r\n begin\r\n FActive := Value;\r\n FTimer.Enabled := FActive;\r\n FIndex := FStart;\r\n end;\r\n Repaint;\r\nend;\r\n\r\nprocedure TJvCustomBmpAnimator.SetNumGlyphs(Value: Integer);\r\nbegin\r\n if FNumGlyphs <> Value then\r\n begin\r\n FNumGlyphs := Value;\r\n SetStop(FNumGlyphs - 1);\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomBmpAnimator.SetSpeed(Value: Integer);\r\nbegin\r\n if FSpeed <> Value then\r\n begin\r\n FSpeed := Value;\r\n FTimer.Interval := 1000 div FSpeed;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomBmpAnimator.SetCenter(Value: Boolean);\r\nbegin\r\n if FCenter <> Value then\r\n begin\r\n FCenter := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomBmpAnimator.SetDirection(Value: TJvAnimateDirection);\r\nbegin\r\n if FDirection <> Value then\r\n begin\r\n FDirection := Value;\r\n case FDirection of\r\n tdForward, tdFwdBack:\r\n begin\r\n FGoingUp := True;\r\n FIndex := FStart;\r\n end;\r\n tdBack, tdBackFwd:\r\n begin\r\n FGoingUp := False;\r\n FIndex := FStop;\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomBmpAnimator.SetPosition(Value: Integer);\r\nbegin\r\n FPosition := Value;\r\n if FPosition > FNumGlyphs - 1 then\r\n FPosition := FNumGlyphs - 1;\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvCustomBmpAnimator.Paint;\r\nvar\r\n dX, dY: Integer;\r\nbegin\r\n if Assigned(FImageList) then\r\n begin\r\n if FCenter then\r\n begin\r\n dX := (Width - FImageList.Width) div 2;\r\n dY := (Height - FImageList.Height) div 2;\r\n end\r\n else\r\n begin\r\n dX := 0;\r\n dY := 0;\r\n end;\r\n if not FTransparent then\r\n begin\r\n Canvas.Brush.Color := Color;\r\n Canvas.FillRect(ClientRect);\r\n end\r\n else\r\n Canvas.Brush.Style := bsClear;\r\n FImageList.Draw(Canvas, dX, dY, FIndex);\r\n\r\n if not Active then\r\n FIndex := FPosition;\r\n FImageList.Draw(Canvas, dX, dY, FIndex)\r\n end;\r\n if csDesigning in ComponentState then\r\n with Canvas do\r\n begin\r\n Brush.Color := clBlack;\r\n FrameRect( GetClientRect);\r\n end;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvBoxProcs.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvJvBoxProcs.PAS, released on 2002-07-04.\r\n\r\nThe Initial Developers of the Original Code are: Fedor Koshevnikov, Igor Pavluk and Serge Korolev\r\nCopyright (c) 1997, 1998 Fedor Koshevnikov, Igor Pavluk and Serge Korolev\r\nCopyright (c) 2001,2002 SGB Software\r\nAll Rights Reserved.\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvBoxProcs.pas 12461 2009-08-14 17:21:33Z obones $\r\n\r\nunit JvBoxProcs;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Types, Variants,\r\n Windows, Classes, Controls;\r\n\r\nprocedure BoxMoveSelectedItems(SrcList, DstList: TWinControl);\r\nprocedure BoxMoveAllItems(SrcList, DstList: TWinControl);\r\nprocedure BoxDragOver(List: TWinControl; Source: TObject;\r\n X, Y: Integer; State: TDragState; var Accept: Boolean; Sorted: Boolean);\r\nprocedure BoxMoveFocusedItem(List: TWinControl; DstIndex: Integer);\r\n\r\nprocedure BoxMoveSelected(List: TWinControl; Items: TStrings);\r\nprocedure BoxSetItem(List: TWinControl; Index: Integer);\r\nfunction BoxGetFirstSelection(List: TWinControl): Integer;\r\nfunction BoxCanDropItem(List: TWinControl; X, Y: Integer;\r\n var DragIndex: Integer): Boolean;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvBoxProcs.pas $';\r\n Revision: '$Revision: 12461 $';\r\n Date: '$Date: 2009-08-14 19:21:33 +0200 (ven. 14 août 2009) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n JvxCheckListBox,\r\n StdCtrls;\r\n\r\n\r\n\r\nfunction BoxItems(List: TWinControl): TStrings;\r\nbegin\r\n if List is TCustomListBox then\r\n Result := TCustomListBox(List).Items\r\n else\r\n if List is TJvxCustomListBox then\r\n Result := TJvxCustomListBox(List).Items\r\n else\r\n Result := nil;\r\nend;\r\n\r\nfunction BoxGetSelected(List: TWinControl; Index: Integer): Boolean;\r\nbegin\r\n if List is TCustomListBox then\r\n Result := TCustomListBox(List).Selected[Index]\r\n else\r\n if List is TJvxCustomListBox then\r\n Result := TJvxCustomListBox(List).Selected[Index]\r\n else\r\n Result := False;\r\nend;\r\n\r\nprocedure BoxSetSelected(List: TWinControl; Index: Integer; Value: Boolean);\r\nbegin\r\n if List is TCustomListBox then\r\n TCustomListBox(List).Selected[Index] := Value\r\n else\r\n if List is TJvxCustomListBox then\r\n TJvxCustomListBox(List).Selected[Index] := Value;\r\nend;\r\n\r\nfunction BoxGetItemIndex(List: TWinControl): Integer;\r\nbegin\r\n if List is TCustomListBox then\r\n Result := TCustomListBox(List).ItemIndex\r\n else\r\n if List is TJvxCustomListBox then\r\n Result := TJvxCustomListBox(List).ItemIndex\r\n else\r\n Result := LB_ERR;\r\nend;\r\n\r\nprocedure BoxSetItemIndex(List: TWinControl; Index: Integer);\r\nbegin\r\n if List is TCustomListBox then\r\n TCustomListBox(List).ItemIndex := Index\r\n else\r\n if List is TJvxCustomListBox then\r\n TJvxCustomListBox(List).ItemIndex := Index;\r\nend;\r\n\r\nfunction BoxMultiSelect(List: TWinControl): Boolean;\r\nbegin\r\n if List is TCustomListBox then\r\n Result := TListBox(List).MultiSelect\r\n else\r\n if List is TJvxCustomListBox then\r\n Result := TJvxCheckListBox(List).MultiSelect\r\n else\r\n Result := False;\r\nend;\r\n\r\nfunction BoxSelCount(List: TWinControl): Integer;\r\nbegin\r\n if List is TCustomListBox then\r\n Result := TCustomListBox(List).SelCount\r\n else\r\n if List is TJvxCustomListBox then\r\n Result := TJvxCustomListBox(List).SelCount\r\n else\r\n Result := 0;\r\nend;\r\n\r\nfunction BoxItemAtPos(List: TWinControl; Pos: TPoint;\r\n Existing: Boolean): Integer;\r\nbegin\r\n if List is TCustomListBox then\r\n Result := TCustomListBox(List).ItemAtPos(Pos, Existing)\r\n else\r\n if List is TJvxCustomListBox then\r\n Result := TJvxCustomListBox(List).ItemAtPos(Pos, Existing)\r\n else\r\n Result := LB_ERR;\r\nend;\r\n\r\nfunction BoxItemRect(List: TWinControl; Index: Integer): TRect;\r\nbegin\r\n if List is TCustomListBox then\r\n Result := TCustomListBox(List).ItemRect(Index)\r\n else\r\n if List is TJvxCustomListBox then\r\n Result := TJvxCustomListBox(List).ItemRect(Index)\r\n else\r\n Result := Rect(0, 0, 0, 0);\r\nend;\r\n\r\nprocedure BoxMoveSelected(List: TWinControl; Items: TStrings);\r\nvar\r\n I: Integer;\r\nbegin\r\n if BoxItems(List) = nil then\r\n Exit;\r\n I := 0;\r\n while I < BoxItems(List).Count do\r\n begin\r\n if BoxGetSelected(List, I) then\r\n begin\r\n Items.AddObject(BoxItems(List).Strings[I], BoxItems(List).Objects[I]);\r\n BoxItems(List).Delete(I);\r\n end\r\n else\r\n Inc(I);\r\n end;\r\nend;\r\n\r\nfunction BoxGetFirstSelection(List: TWinControl): Integer;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := LB_ERR;\r\n if BoxItems(List) = nil then\r\n Exit;\r\n for I := 0 to BoxItems(List).Count - 1 do\r\n begin\r\n if BoxGetSelected(List, I) then\r\n begin\r\n Result := I;\r\n Exit;\r\n end;\r\n end;\r\n Result := LB_ERR;\r\nend;\r\n\r\nprocedure BoxSetItem(List: TWinControl; Index: Integer);\r\nvar\r\n MaxIndex: Integer;\r\nbegin\r\n if BoxItems(List) = nil then\r\n Exit;\r\n with List do\r\n begin\r\n if CanFocus then\r\n SetFocus;\r\n MaxIndex := BoxItems(List).Count - 1;\r\n if Index = LB_ERR then\r\n Index := 0\r\n else\r\n if Index > MaxIndex then\r\n Index := MaxIndex;\r\n if Index >= 0 then\r\n if BoxMultiSelect(List) then\r\n BoxSetSelected(List, Index, True)\r\n else\r\n BoxSetItemIndex(List, Index);\r\n end;\r\nend;\r\n\r\nprocedure BoxMoveSelectedItems(SrcList, DstList: TWinControl);\r\nvar\r\n Index, I: Integer;\r\n NewIndex: Integer;\r\nbegin\r\n Index := BoxGetFirstSelection(SrcList);\r\n if Index <> LB_ERR then\r\n begin\r\n BoxItems(SrcList).BeginUpdate;\r\n BoxItems(DstList).BeginUpdate;\r\n try\r\n I := 0;\r\n while I < BoxItems(SrcList).Count do\r\n if BoxGetSelected(SrcList, I) then\r\n begin\r\n NewIndex := BoxItems(DstList).AddObject(BoxItems(SrcList).Strings[I],\r\n BoxItems(SrcList).Objects[I]);\r\n if (SrcList is TJvxCheckListBox) and (DstList is TJvxCheckListBox) then\r\n TJvxCheckListBox(DstList).State[NewIndex] :=\r\n TJvxCheckListBox(SrcList).State[I];\r\n BoxItems(SrcList).Delete(I);\r\n end\r\n else\r\n Inc(I);\r\n BoxSetItem(SrcList, Index);\r\n finally\r\n BoxItems(SrcList).EndUpdate;\r\n BoxItems(DstList).EndUpdate;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure BoxMoveAllItems(SrcList, DstList: TWinControl);\r\nvar\r\n I: Integer;\r\n NewIndex: Integer;\r\nbegin\r\n for I := 0 to BoxItems(SrcList).Count - 1 do\r\n begin\r\n NewIndex := BoxItems(DstList).AddObject(BoxItems(SrcList)[I],\r\n BoxItems(SrcList).Objects[I]);\r\n if (SrcList is TJvxCheckListBox) and (DstList is TJvxCheckListBox) then\r\n TJvxCheckListBox(DstList).State[NewIndex] :=\r\n TJvxCheckListBox(SrcList).State[I];\r\n end;\r\n BoxItems(SrcList).Clear;\r\n BoxSetItem(SrcList, 0);\r\nend;\r\n\r\nfunction BoxCanDropItem(List: TWinControl; X, Y: Integer;\r\n var DragIndex: Integer): Boolean;\r\nvar\r\n Focused: Integer;\r\nbegin\r\n Result := False;\r\n if (BoxSelCount(List) = 1) or (not BoxMultiSelect(List)) then\r\n begin\r\n Focused := BoxGetItemIndex(List);\r\n if Focused <> LB_ERR then\r\n begin\r\n DragIndex := BoxItemAtPos(List, Point(X, Y), True);\r\n if (DragIndex >= 0) and (DragIndex <> Focused) then\r\n Result := True;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure BoxDragOver(List: TWinControl; Source: TObject;\r\n X, Y: Integer; State: TDragState; var Accept: Boolean; Sorted: Boolean);\r\nvar\r\n DragIndex: Integer;\r\n R: TRect;\r\n\r\n procedure DrawItemFocusRect(Idx: Integer);\r\n var\r\n P: TPoint;\r\n DC: HDC;\r\n begin\r\n R := BoxItemRect(List, Idx);\r\n P := List.ClientToScreen(R.TopLeft);\r\n R := Bounds(P.X, P.Y, R.Right - R.Left, R.Bottom - R.Top);\r\n DC := GetDC(HWND_DESKTOP);\r\n DrawFocusRect(DC, R);\r\n ReleaseDC(HWND_DESKTOP, DC);\r\n end;\r\n\r\nbegin\r\n if Source <> List then\r\n Accept := (Source is TWinControl) or (Source is TJvxCustomListBox)\r\n else\r\n begin\r\n if Sorted then\r\n Accept := False\r\n else\r\n begin\r\n Accept := BoxCanDropItem(List, X, Y, DragIndex);\r\n if ((List.Tag - 1) = DragIndex) and (DragIndex >= 0) then\r\n begin\r\n if State = dsDragLeave then\r\n begin\r\n DrawItemFocusRect(List.Tag - 1);\r\n List.Tag := 0;\r\n end;\r\n end\r\n else\r\n begin\r\n if List.Tag > 0 then\r\n DrawItemFocusRect(List.Tag - 1);\r\n if DragIndex >= 0 then\r\n DrawItemFocusRect(DragIndex);\r\n List.Tag := DragIndex + 1;\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure BoxMoveFocusedItem(List: TWinControl; DstIndex: Integer);\r\nbegin\r\n if (DstIndex >= 0) and (DstIndex < BoxItems(List).Count) then\r\n if (DstIndex <> BoxGetItemIndex(List)) then\r\n begin\r\n BoxItems(List).Move(BoxGetItemIndex(List), DstIndex);\r\n BoxSetItem(List, DstIndex);\r\n end;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvBrowseFolder.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvBrowseFolder.PAS, released on 2001-02-28.\r\n\r\nThe Initial Developer of the Original Code is Sbastien Buysse [sbuysse att buypin dott com]\r\nPortions created by Sbastien Buysse are Copyright (C) 2001 Sbastien Buysse.\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\n Michael Beck [mbeck att bigfoot dott com]\r\n Roman Kovbasiouk [roko att users dott sourceforge dott net]\r\n Remko Bonte [remkobonte att myrealbox dott com]\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvBrowseFolder.pas 13352 2012-06-14 09:21:26Z obones $\r\n\r\nunit JvBrowseFolder;\r\n\r\n{$I jvcl.inc}\r\n{$I windowsonly.inc}\r\n\r\ninterface\r\n\r\n{$IFDEF BCB6}\r\n// BCB6 needs the shtypes.h file to be included\r\n{$HPPEMIT '#include '}\r\n{$ENDIF BCB6}\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, Messages, ShlObj, Classes,\r\n JvBaseDlg;\r\n\r\nconst\r\n { Interfaces from ShObjIdl.h }\r\n IID_IFolderFilterSite: TGUID = '{C0A651F5-B48B-11d2-B5ED-006097C686F6}';\r\n SID_IFolderFilterSite = '{C0A651F5-B48B-11d2-B5ED-006097C686F6}';\r\n\r\ntype\r\n IFolderFilterSite = interface(IUnknown)\r\n [SID_IFolderFilterSite]\r\n function SetFilter(punk: IUnknown): HResult; stdcall;\r\n end;\r\n\r\nconst\r\n IID_IFolderFilter: TGUID = '{9CC22886-DC8E-11d2-B1D0-00C04F8EEB3E}';\r\n SID_IFolderFilter = '{9CC22886-DC8E-11d2-B1D0-00C04F8EEB3E}';\r\n\r\ntype\r\n IFolderFilter = interface(IUnknown)\r\n [SID_IFolderFilter]\r\n function ShouldShow(psf: IShellFolder; pidlFolder, pidlItem: PItemIDList): HResult; stdcall;\r\n function GetEnumFlags(psf: IShellFolder; pidlFolder: PItemIDList; const phWnd: THandle;\r\n var pgrfFlags: DWORD): HResult; stdcall;\r\n end;\r\n\r\ntype\r\n { (rb) Stupid name, feel free to change :) }\r\n TJvBrowsableObjectClass = (\r\n ocFolders, //SHCONTF_FOLDERS,\r\n ocNonFolders, //SHCONTF_NONFOLDERS,\r\n ocIncludeHidden, //SHCONTF_INCLUDEHIDDEN,\r\n ocInitOnFirstNext, //SHCONTF_INIT_ON_FIRST_NEXT,\r\n ocNetPrinterSrch, //SHCONTF_NETPRINTERSRCH,\r\n ocSharable, //SHCONTF_SHAREABLE,\r\n ocStorage //SHCONTF_STORAGE\r\n );\r\n TJvBrowsableObjectClasses = set of TJvBrowsableObjectClass;\r\n\r\n TJvBrowseAcceptChange = procedure(Sender: TObject; const NewFolder: string;\r\n var Accept: Boolean) of object;\r\n TJvShouldShowEvent = procedure(Sender: TObject; const Item: string;\r\n var DoShow: Boolean) of object;\r\n TJvGetEnumFlagsEvent = procedure(Sender: TObject; const AFolder: string;\r\n var Flags: TJvBrowsableObjectClasses) of object;\r\n TJvDirChange = procedure(Sender: TObject; const Directory: string) of object;\r\n TJvValidateFailedEvent = procedure(Sender: TObject; const AEditText: string;\r\n var CanCloseDialog: Boolean) of object;\r\n\r\n TFromDirectory = (\r\n fdNoSpecialFolder, { 0 }\r\n fdRootFolder, { 0 }\r\n fdRecycleBin, { CSIDL_BITBUCKET }\r\n fdControlPanel, { CSIDL_CONTROLS }\r\n fdDesktop, { CSIDL_DESKTOP }\r\n fdDesktopDirectory, { CSIDL_DESKTOPDIRECTORY }\r\n fdMyComputer, { CSIDL_DRIVES }\r\n fdFonts, { CSIDL_FONTS }\r\n fdNetHood, { CSIDL_NETHOOD }\r\n fdNetwork, { CSIDL_NETWORK }\r\n fdPersonal, { CSIDL_PERSONAL }\r\n fdPrinters, { CSIDL_PRINTERS }\r\n fdPrograms, { CSIDL_PROGRAMS }\r\n fdRecent, { CSIDL_RECENT }\r\n fdSendTo, { CSIDL_SENDTO }\r\n fdStartMenu, { CSIDL_STARTMENU }\r\n fdStartup, { CSIDL_STARTUP }\r\n fdTemplates, { CSIDL_TEMPLATES }\r\n fdStartUpNonLocalized, { CSIDL_ALTSTARTUP }\r\n fdCommonStartUpNonLocalized, { CSIDL_COMMON_ALTSTARTUP }\r\n fdCommonDocuments, { CSIDL_COMMON_DOCUMENTS }\r\n fdCommonFavorites, { CSIDL_COMMON_FAVORITES }\r\n fdCommonPrograms, { CSIDL_COMMON_PROGRAMS }\r\n fdCommonStartUp, { CSIDL_COMMON_STARTUP }\r\n fdCommonTemplates, { CSIDL_COMMON_TEMPLATES }\r\n fdCookies, { CSIDL_COOKIES }\r\n fdFavorites, { CSIDL_FAVORITES }\r\n fdHistory, { CSIDL_HISTORY }\r\n fdInternet, { CSIDL_INTERNET }\r\n fdMyMusic, { CSIDL_MYMUSIC }\r\n fdPrinthood, { CSIDL_PRINTHOOD }\r\n fdConnections, { CSIDL_CONNECTIONS }\r\n\r\n { Version 4.71 }\r\n fdAppData, { CSIDL_APPDATA }\r\n\r\n { Version 4.72 }\r\n fdInternetCache, { CSIDL_INTERNET_CACHE }\r\n\r\n { Version 5.00 }\r\n fdAdminTools, { CSIDL_ADMINTOOLS }\r\n fdCommonAdminTools, { CSIDL_COMMON_ADMINTOOLS }\r\n fdCommonAppData, { CSIDL_COMMON_APPDATA }\r\n fdLocalAppData, { CSIDL_LOCAL_APPDATA }\r\n fdMyPictures, { CSIDL_MYPICTURES }\r\n fdProfile, { CSIDL_PROFILE }\r\n fdProgramFiles, { CSIDL_PROGRAM_FILES }\r\n fdProgramFilesCommon, { CSIDL_PROGRAM_FILES_COMMON }\r\n fdSystem, { CSIDL_SYSTEM }\r\n fdWindows, { CSIDL_WINDOWS }\r\n\r\n { Version 6.00 }\r\n fdCDBurnArea, { CSIDL_CDBURN_AREA }\r\n fdCommonMusic, { CSIDL_COMMON_MUSIC }\r\n fdCommonPictures, { CSIDL_COMMON_PICTURES }\r\n fdCommonVideo, { CSIDL_COMMON_VIDEO }\r\n fdMyDocuments, { CSIDL_MYDOCUMENTS }\r\n fdMyVideo, { CSIDL_MYVIDEO }\r\n fdProfiles, { CSIDL_PROFILES }\r\n\r\n { Unknown version }\r\n fdResources, { CSIDL_RESOURCES }\r\n fdResourcesLocalized,\r\n fdCommonOEMLinks, { CSIDL_COMMON_OEM_LINKS }\r\n fdComputersNearMe { CSIDL_COMPUTERSNEARME }\r\n );\r\n\r\n TJvFolderPos = (fpDefault, fpScreenCenter, fpFormCenter, fpTopLeft,\r\n fpTopRight, fpBottomLeft, fpBottomRight);\r\n TOptionsDirectory = (odBrowseForComputer, odOnlyDirectory, odOnlyPrinters,\r\n odNoBelowDomain, odSystemAncestorsOnly, odFileSystemDirectoryOnly,\r\n odStatusAvailable, odIncludeFiles, odIncludeUrls, odEditBox,\r\n odNewDialogStyle, odShareable, odUsageHint, odNoNewButtonFolder, odValidate);\r\n // (p3) shouldn't TOptionsDir be changed to T(Jv)OptionsDirectories?\r\n TOptionsDir = set of TOptionsDirectory;\r\n\r\nconst\r\n DefaultJvBrowseFolderDialogOptions = [odStatusAvailable, odNewDialogStyle];\r\n\r\ntype\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvBrowseForFolderDialog = class(TJvCommonDialog, IFolderFilter)\r\n private\r\n { Handle to the owner form of the dialog, used if Position = fpFormCenter }\r\n FOwnerWindow: THandle;\r\n { Handle to the MS \"Browse for folder\" dialog }\r\n FDialogWindow: THandle;\r\n FHelpContext: THelpContext;\r\n FTitle: string;\r\n FOptions: TOptionsDir;\r\n FUsedOptions: TOptionsDir;\r\n FDisplayName: string;\r\n FRootDirectory: TFromDirectory;\r\n FRootDirectoryPath: string;\r\n FDirectory: string;\r\n FPosition: TJvFolderPos;\r\n FPidl: PItemIDList;\r\n FStatusText: string;\r\n\r\n FHelpButtonHandle: THandle;\r\n FHelpButtonHeightDelta: Integer;\r\n\r\n FOnInit: TNotifyEvent;\r\n FOnChange: TJvDirChange;\r\n FOnAcceptChange: TJvBrowseAcceptChange;\r\n FOnShouldShow: TJvShouldShowEvent;\r\n FOnGetEnumFlags: TJvGetEnumFlagsEvent;\r\n FOnValidateFailed: TJvValidateFailedEvent;\r\n\r\n { For hooking the control }\r\n FDefWndProc: Pointer;\r\n FObjectInstance: Pointer;\r\n FPositionSet: Boolean;\r\n\r\n // (p3) updates the status text. NOTE: doesn't work if odNewDialogStyle is true (MS limitation)!!!\r\n procedure UpdateStatusText(AText: string);\r\n procedure WMShowWindow(var Msg: TMessage); message WM_SHOWWINDOW;\r\n procedure WMSize(var Msg: TWMSize); message WM_SIZE;\r\n function GetRootDirectoryPath: string;\r\n function IsRootDirectoryPathStored: Boolean;\r\n procedure SetRootDirectory(const Value: TFromDirectory);\r\n procedure SetRootDirectoryPath(const Value: string);\r\n procedure SetOptions(const Value: TOptionsDir);\r\n protected\r\n { Messages from the browser }\r\n procedure DoInitialized;\r\n procedure DoIUnknown(const Unknown: IUnknown);\r\n procedure DoSelChanged(IDList: PItemIDList);\r\n function DoValidateFailed(AEditText: string): Integer;\r\n function DoValidateFailedW(AEditText: WideString): Integer;\r\n function DoShouldShow(const AItem: string): Boolean;\r\n function DoGetEnumFlags(const AFolder: string; var Flags: TJvBrowsableObjectClasses): Boolean;\r\n\r\n procedure MainWndProc(var Msg: TMessage);\r\n procedure HookDialog;\r\n\r\n { IFolderFilter }\r\n function ShouldShow(psf: IShellFolder; pidlFolder, pidlItem: PItemIDList): HResult; stdcall;\r\n function GetEnumFlags(psf: IShellFolder; pidlFolder: PItemIDList; const phWnd: THandle;\r\n var pgrfFlags: DWORD): HResult; stdcall;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n\r\n procedure DefaultHandler(var Msg); override;\r\n { Messages to the browser }\r\n procedure SetSelection(const APath: string); overload;\r\n procedure SetSelection(IDList: PItemIDList); overload;\r\n procedure SetStatusText(const AText: string);\r\n procedure SetStatusTextW(const AText: WideString);\r\n procedure SetOKEnabled(const Value: Boolean);\r\n procedure SetOKText(const AText: string);\r\n procedure SetOKTextW(const AText: WideString);\r\n procedure SetExpanded(const APath: string); overload;\r\n procedure SetExpandedW(const APath: WideString);\r\n procedure SetExpanded(IDList: PItemIDList); overload;\r\n\r\n property Pidl: PItemIDList read FPidl;\r\n property Handle: THandle read FDialogWindow;\r\n\r\n function Execute(ParentWnd: HWND): Boolean; overload; override;\r\n published\r\n property Directory: string read FDirectory write FDirectory;\r\n property DisplayName: string read FDisplayName write FDisplayName stored False;\r\n property HelpContext: THelpContext read FHelpContext write FHelpContext default 0;\r\n property Options: TOptionsDir read FOptions write SetOptions default\r\n DefaultJvBrowseFolderDialogOptions;\r\n property Position: TJvFolderPos read FPosition write FPosition default fpScreenCenter;\r\n property RootDirectory: TFromDirectory read FRootDirectory write SetRootDirectory default fdNoSpecialFolder;\r\n property RootDirectoryPath: string read GetRootDirectoryPath write SetRootDirectoryPath\r\n stored IsRootDirectoryPathStored;\r\n property Title: string read FTitle write FTitle;\r\n property StatusText: string read FStatusText write FStatusText;\r\n property OnAcceptChange: TJvBrowseAcceptChange read FOnAcceptChange write FOnAcceptChange;\r\n property OnChange: TJvDirChange read FOnChange write FOnChange;\r\n property OnGetEnumFlags: TJvGetEnumFlagsEvent read FOnGetEnumFlags write FOnGetEnumFlags;\r\n property OnInitialized: TNotifyEvent read FOnInit write FOnInit;\r\n property OnShouldShow: TJvShouldShowEvent read FOnShouldShow write FOnShouldShow;\r\n property OnValidateFailed: TJvValidateFailedEvent read FOnValidateFailed write FOnValidateFailed;\r\n end;\r\n\r\nfunction BrowseForFolder(const ATitle: string; AllowCreate: Boolean;\r\n var ADirectory: string; AHelpContext: THelpContext = 0): Boolean;\r\nfunction BrowseForComputer(const ATitle: string; AllowCreate: Boolean;\r\n var ADirectory: string; AHelpContext: THelpContext = 0): Boolean;\r\n// (p3) moved from JvFileUtil, deprecated removed\r\nfunction BrowseDirectory(var AFolderName: string; const DlgText: string;\r\n AHelpContext: THelpContext): Boolean;\r\n// (p3) moved from JvFileUtil, deprecated removed\r\nfunction BrowseComputer(var AComputerName: string; const DlgText: string;\r\n AHelpContext: THelpContext): Boolean;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvBrowseFolder.pas $';\r\n Revision: '$Revision: 13352 $';\r\n Date: '$Date: 2012-06-14 11:21:26 +0200 (jeu. 14 juin 2012) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n SysUtils, ActiveX, Controls, Forms, Consts, Graphics,\r\n JclShell,\r\n JvJCLUtils, JvJVCLUtils, JvConsts, JvResources, JvTypes;\r\n\r\n\r\n\r\ntype\r\n TSHGetFolderPathProc = function(hWnd: HWND; CSIDL: Integer; hToken: THandle;\r\n dwFlags: DWORD; pszPath: PChar): HResult; stdcall;\r\n\r\nvar\r\n SHGetFolderPathProc: TSHGetFolderPathProc = nil;\r\n\r\nconst\r\n { Taken from ShlObj.h & ShObjIdl.h }\r\n BIF_RETURNFSANCESTORS = $0008;\r\n BIF_EDITBOX = $0010; // Add an editbox to the dialog\r\n BIF_VALIDATE = $0020; // insist on valid result (or CANCEL)\r\n BIF_NEWDIALOGSTYLE = $0040; // Use the new dialog layout with the ability to resize\r\n // Caller needs to call OleInitialize() before using this API\r\n BIF_BROWSEINCLUDEURLS = $0080; // Allow URLs to be displayed or entered. (Requires BIF_USENEWUI)\r\n BIF_UAHINT = $0100; // Add a UA hint to the dialog, in place of the edit box.\r\n // May not be combined with BIF_EDITBOX\r\n BIF_NONEWFOLDERBUTTON = $0200; // Do not add the \"New Folder\" button to the dialog.\r\n // Only applicable with BIF_NEWDIALOGSTYLE.\r\n BIF_BROWSEINCLUDEFILES = $4000; // Browsing for Everything\r\n BIF_SHAREABLE = $8000; // sharable resources displayed (remote shares, requires BIF_USENEWUI)\r\n\r\n SHCONTF_INIT_ON_FIRST_NEXT = $0100; // allow EnumObject() to return before validating enum\r\n SHCONTF_NETPRINTERSRCH = $0200; // hint that client is looking for printers\r\n SHCONTF_SHAREABLE = $0400; // hint that client is looking sharable resources (remote shares)\r\n SHCONTF_STORAGE = $0800; // include all items with accessible storage and their ancestors\r\n\r\n CSIDL_MYDOCUMENTS = $000C; // logical \"My Documents\" desktop icon\r\n CSIDL_MYMUSIC = $000D; // \"My Music\" folder\r\n CSIDL_MYVIDEO = $000E; // \"My Videos\" folder\r\n CSIDL_LOCAL_APPDATA = $001C; // \\Local Settings\\Applicaiton Data (non roaming)\r\n CSIDL_COMMON_APPDATA = $0023; // All Users\\Application Data\r\n CSIDL_WINDOWS = $0024; // GetWindowsDirectory()\r\n CSIDL_SYSTEM = $0025; // GetSystemDirectory()\r\n CSIDL_PROGRAM_FILES = $0026; // C:\\Program Files\r\n CSIDL_MYPICTURES = $0027; // C:\\Program Files\\My Pictures\r\n CSIDL_PROFILE = $0028; // USERPROFILE\r\n CSIDL_PROGRAM_FILES_COMMON = $002B; // C:\\Program Files\\Common\r\n CSIDL_COMMON_TEMPLATES = $002D; // All Users\\Templates\r\n CSIDL_COMMON_DOCUMENTS = $002E; // All Users\\Documents\r\n CSIDL_COMMON_ADMINTOOLS = $002F; // All Users\\Start Menu\\Programs\\Administrative Tools\r\n CSIDL_ADMINTOOLS = $0030; // \\Start Menu\\Programs\\Administrative Tools\r\n CSIDL_CONNECTIONS = $0031; // Network and Dial-up Connections\r\n CSIDL_COMMON_MUSIC = $0035; // All Users\\My Music\r\n CSIDL_COMMON_PICTURES = $0036; // All Users\\My Pictures\r\n CSIDL_COMMON_VIDEO = $0037; // All Users\\My Video\r\n CSIDL_RESOURCES = $0038; // Resource Direcotry\r\n CSIDL_RESOURCES_LOCALIZED = $0039; // Localized Resource Direcotry\r\n CSIDL_COMMON_OEM_LINKS = $003A; // Links to All Users OEM specific apps\r\n CSIDL_CDBURN_AREA = $003B; // USERPROFILE\\Local Settings\\Application Data\\Microsoft\\CD Burning\r\n CSIDL_COMPUTERSNEARME = $003D; // Computers Near Me (computered from Workgroup membership)\r\n CSIDL_PROFILES = $003E; // ??\r\n\r\n BFFM_SETOKTEXT = WM_USER + 105; // Unicode only\r\n BFFM_SETEXPANDED = WM_USER + 106; // Unicode only\r\n BFFM_IUNKNOWN = 5; // provides IUnknown to client. lParam: IUnknown*\r\n\r\n { TOptionsDirectory = (odBrowseForComputer, odOnlyDirectory, odOnlyPrinters,\r\n odNoBelowDomain, odSystemAncestorsOnly, odFileSystemDirectoryOnly,\r\n odStatusAvailable, odIncludeFiles, odIncludeUrls, odEditBox,\r\n odNewDialogStyle, odShareable, odUsageHint, odNoNewButtonFolder, odValidate);\r\n }\r\n\r\n { (rb) No idea why odOnlyDirectory is used? }\r\n\r\n COptionsDirectory: array [TOptionsDirectory] of Cardinal = (\r\n BIF_BROWSEFORCOMPUTER, 0, BIF_BROWSEFORPRINTER, BIF_DONTGOBELOWDOMAIN,\r\n BIF_RETURNFSANCESTORS, BIF_RETURNONLYFSDIRS, BIF_STATUSTEXT,\r\n BIF_BROWSEINCLUDEFILES, BIF_BROWSEINCLUDEURLS, BIF_EDITBOX,\r\n BIF_NEWDIALOGSTYLE, BIF_SHAREABLE, BIF_UAHINT, BIF_NONEWFOLDERBUTTON,\r\n BIF_VALIDATE);\r\n\r\n { TJvBrowseObjectClass = (ocFolders, ocNonFolders, ocIncludeHidden,\r\n ocInitOnFirstNext, ocNetPrinterSrch, ocSharable, ocStorage)\r\n }\r\n\r\n CBrowseObjectClasses: array [TJvBrowsableObjectClass] of Cardinal = (\r\n SHCONTF_FOLDERS, SHCONTF_NONFOLDERS, SHCONTF_INCLUDEHIDDEN,\r\n SHCONTF_INIT_ON_FIRST_NEXT, SHCONTF_NETPRINTERSRCH,\r\n SHCONTF_SHAREABLE, SHCONTF_STORAGE);\r\n\r\nfunction BrowseForFolder(const ATitle: string; AllowCreate: Boolean;\r\n var ADirectory: string; AHelpContext: THelpContext): Boolean;\r\nbegin\r\n with TJvBrowseForFolderDialog.Create(nil) do\r\n try\r\n Position := fpScreenCenter;\r\n Directory := ADirectory;\r\n Title := ATitle;\r\n HelpContext := AHelpContext;\r\n if AllowCreate then\r\n Options := Options + [odNewDialogStyle]\r\n else\r\n Options := Options - [odNewDialogStyle];\r\n Result := Execute;\r\n if Result then\r\n ADirectory := Directory;\r\n finally\r\n Free;\r\n end;\r\nend;\r\n\r\nfunction BrowseForComputer(const ATitle: string; AllowCreate: Boolean;\r\n var ADirectory: string; AHelpContext: THelpContext): Boolean;\r\nbegin\r\n with TJvBrowseForFolderDialog.Create(nil) do\r\n try\r\n Position := fpScreenCenter;\r\n Directory := ADirectory;\r\n Title := ATitle;\r\n HelpContext := AHelpContext;\r\n if AllowCreate then\r\n Options := Options + [odNewDialogStyle]\r\n else\r\n Options := Options - [odNewDialogStyle];\r\n Options := Options + [odBrowseForComputer];\r\n RootDirectory := fdNetwork;\r\n Result := Execute;\r\n if Result then\r\n ADirectory := Directory;\r\n finally\r\n Free;\r\n end;\r\nend;\r\n\r\nfunction BrowseDirectory(var AFolderName: string; const DlgText: string;\r\n AHelpContext: THelpContext): Boolean;\r\nbegin\r\n Result := BrowseForFolder(DlgText, True, AFolderName, AHelpContext);\r\nend;\r\n\r\nfunction BrowseComputer(var AComputerName: string; const DlgText: string;\r\n AHelpContext: THelpContext): Boolean;\r\nbegin\r\n Result := BrowseForComputer(DlgText, True, AComputerName, AHelpContext);\r\nend;\r\n\r\n{ From QDialogs.pas }\r\n\r\nfunction StrRetToString(PIDL: PItemIDList; StrRet: TStrRet): string;\r\nvar\r\n P: PChar;\r\nbegin\r\n case StrRet.uType of\r\n STRRET_CSTR:\r\n SetString(Result, StrRet.cStr, lStrLenA(StrRet.cStr));\r\n STRRET_OFFSET:\r\n begin\r\n P := @PIDL.mkid.abID[StrRet.uOffset - SizeOf(PIDL.mkid.cb)];\r\n SetString(Result, P, PIDL.mkid.cb - StrRet.uOffset);\r\n end;\r\n STRRET_WSTR:\r\n Result := StrRet.pOleStr;\r\n end;\r\nend;\r\n\r\ntype\r\n TFromDirectoryData = record\r\n CSIDL: Cardinal;\r\n MinVersion: Cardinal;\r\n OnlyNT: Boolean;\r\n CanSimulate: Boolean;\r\n Alternative: TFromDirectory;\r\n end;\r\n\r\nconst\r\n CSIDLLocations: array [TFromDirectory] of TFromDirectoryData = (\r\n { fdNoSpecialFolder }\r\n (CSIDL: 0; MinVersion: 0; OnlyNT: False;\r\n CanSimulate: False; Alternative: fdNoSpecialFolder),\r\n { fdRootFolder }\r\n (CSIDL: 0; MinVersion: 0; OnlyNT: False;\r\n CanSimulate: False; Alternative: fdNoSpecialFolder),\r\n { fdRecycleBin }\r\n (CSIDL: CSIDL_BITBUCKET; MinVersion: 0; OnlyNT: False;\r\n CanSimulate: False; Alternative: fdNoSpecialFolder),\r\n { fdControlPanel }\r\n (CSIDL: CSIDL_CONTROLS; MinVersion: 0; OnlyNT: False;\r\n CanSimulate: False; Alternative: fdNoSpecialFolder),\r\n { fdDesktop }\r\n (CSIDL: CSIDL_DESKTOP; MinVersion: 0; OnlyNT: False;\r\n CanSimulate: False; Alternative: fdNoSpecialFolder),\r\n { fdDesktopDirectory }\r\n (CSIDL: CSIDL_DESKTOPDIRECTORY; MinVersion: 0; OnlyNT: False;\r\n CanSimulate: False; Alternative: fdNoSpecialFolder),\r\n { fdMyComputer }\r\n (CSIDL: CSIDL_DRIVES; MinVersion: 0; OnlyNT: False;\r\n CanSimulate: False; Alternative: fdNoSpecialFolder),\r\n { fdFonts }\r\n (CSIDL: CSIDL_FONTS; MinVersion: 0; OnlyNT: False;\r\n CanSimulate: False; Alternative: fdNoSpecialFolder),\r\n { fdNetHood }\r\n (CSIDL: CSIDL_NETHOOD; MinVersion: 0; OnlyNT: False;\r\n CanSimulate: False; Alternative: fdNoSpecialFolder),\r\n { fdNetwork }\r\n (CSIDL: CSIDL_NETWORK; MinVersion: 0; OnlyNT: False;\r\n CanSimulate: False; Alternative: fdNoSpecialFolder),\r\n { fdPersonal }\r\n (CSIDL: CSIDL_PERSONAL; MinVersion: 0; OnlyNT: False;\r\n CanSimulate: True; Alternative: fdNoSpecialFolder),\r\n { fdPrinters }\r\n (CSIDL: CSIDL_PRINTERS; MinVersion: 0; OnlyNT: False;\r\n CanSimulate: False; Alternative: fdNoSpecialFolder),\r\n { fdPrograms }\r\n (CSIDL: CSIDL_PROGRAMS; MinVersion: 0; OnlyNT: False;\r\n CanSimulate: False; Alternative: fdNoSpecialFolder),\r\n { fdRecent }\r\n (CSIDL: CSIDL_RECENT; MinVersion: 0; OnlyNT: False;\r\n CanSimulate: False; Alternative: fdNoSpecialFolder),\r\n { fdSendTo }\r\n (CSIDL: CSIDL_SENDTO; MinVersion: 0; OnlyNT: False;\r\n CanSimulate: False; Alternative: fdNoSpecialFolder),\r\n { fdStartMenu }\r\n (CSIDL: CSIDL_STARTMENU; MinVersion: 0; OnlyNT: False;\r\n CanSimulate: False; Alternative: fdNoSpecialFolder),\r\n { fdStartup }\r\n (CSIDL: CSIDL_STARTUP; MinVersion: 0; OnlyNT: False;\r\n CanSimulate: False; Alternative: fdNoSpecialFolder),\r\n { fdTemplates }\r\n (CSIDL: CSIDL_TEMPLATES; MinVersion: 0; OnlyNT: False;\r\n CanSimulate: False; Alternative: fdNoSpecialFolder),\r\n { fdStartUpNonLocalized }\r\n (CSIDL: CSIDL_ALTSTARTUP; MinVersion: 0; OnlyNT: False;\r\n CanSimulate: False; Alternative: fdNoSpecialFolder),\r\n { fdCommonStartUpNonLocalized }\r\n (CSIDL: CSIDL_COMMON_ALTSTARTUP; MinVersion: 0; OnlyNT: True;\r\n CanSimulate: False; Alternative: fdNoSpecialFolder),\r\n { fdCommonDocuments }\r\n (CSIDL: CSIDL_COMMON_DOCUMENTS; MinVersion: 0; OnlyNT: False;\r\n CanSimulate: True; Alternative: fdNoSpecialFolder),\r\n { fdCommonFavorites }\r\n (CSIDL: CSIDL_COMMON_FAVORITES; MinVersion: 0; OnlyNT: True;\r\n CanSimulate: False; Alternative: fdNoSpecialFolder),\r\n { fdCommonPrograms }\r\n (CSIDL: CSIDL_COMMON_PROGRAMS; MinVersion: 0; OnlyNT: True;\r\n CanSimulate: False; Alternative: fdNoSpecialFolder),\r\n { fdCommonStartUp }\r\n (CSIDL: CSIDL_COMMON_STARTUP; MinVersion: 0; OnlyNT: True;\r\n CanSimulate: False; Alternative: fdNoSpecialFolder),\r\n { fdCommonTemplates }\r\n (CSIDL: CSIDL_COMMON_TEMPLATES; MinVersion: 0; OnlyNT: True;\r\n CanSimulate: False; Alternative: fdNoSpecialFolder),\r\n { fdCookies }\r\n (CSIDL: CSIDL_COOKIES; MinVersion: 0; OnlyNT: False;\r\n CanSimulate: True; Alternative: fdNoSpecialFolder),\r\n { fdFavorites }\r\n (CSIDL: CSIDL_FAVORITES; MinVersion: 0; OnlyNT: False;\r\n CanSimulate: False; Alternative: fdNoSpecialFolder),\r\n { fdHistory }\r\n (CSIDL: CSIDL_HISTORY; MinVersion: 0; OnlyNT: False;\r\n CanSimulate: True; Alternative: fdNoSpecialFolder),\r\n { fdInternet }\r\n (CSIDL: CSIDL_INTERNET; MinVersion: 0; OnlyNT: False;\r\n CanSimulate: False; Alternative: fdNoSpecialFolder),\r\n { fdMyMusic }\r\n (CSIDL: CSIDL_MYMUSIC; MinVersion: 0; OnlyNT: False;\r\n CanSimulate: False; Alternative: fdNoSpecialFolder),\r\n { fdPrinthood }\r\n (CSIDL: CSIDL_PRINTHOOD; MinVersion: 0; OnlyNT: False;\r\n CanSimulate: False; Alternative: fdNoSpecialFolder),\r\n { fdConnections }\r\n (CSIDL: CSIDL_CONNECTIONS; MinVersion: 0; OnlyNT: False;\r\n CanSimulate: False; Alternative: fdNoSpecialFolder),\r\n { fdAppData }\r\n (CSIDL: CSIDL_APPDATA; MinVersion: $00040071; OnlyNT: False;\r\n CanSimulate: True; Alternative: fdNoSpecialFolder),\r\n { fdInternetCache }\r\n (CSIDL: CSIDL_INTERNET_CACHE; MinVersion: $00040072; OnlyNT: False;\r\n CanSimulate: True; Alternative: fdNoSpecialFolder),\r\n { fdAdminTools }\r\n (CSIDL: CSIDL_ADMINTOOLS; MinVersion: $00050000; OnlyNT: False;\r\n CanSimulate: True; Alternative: fdNoSpecialFolder),\r\n { fdCommonAdminTools }\r\n (CSIDL: CSIDL_COMMON_ADMINTOOLS; MinVersion: $00050000; OnlyNT: False;\r\n CanSimulate: True; Alternative: fdNoSpecialFolder),\r\n { fdCommonAppData }\r\n (CSIDL: CSIDL_COMMON_APPDATA; MinVersion: $00050000; OnlyNT: False;\r\n CanSimulate: True; Alternative: fdNoSpecialFolder),\r\n { fdLocalAppData }\r\n (CSIDL: CSIDL_LOCAL_APPDATA; MinVersion: $00050000; OnlyNT: False;\r\n CanSimulate: True; Alternative: fdNoSpecialFolder),\r\n { fdMyPictures }\r\n (CSIDL: CSIDL_MYPICTURES; MinVersion: $00050000; OnlyNT: False;\r\n CanSimulate: True; Alternative: fdPersonal),\r\n { fdProfile }\r\n (CSIDL: CSIDL_PROFILE; MinVersion: $00050000; OnlyNT: False;\r\n CanSimulate: False; Alternative: fdNoSpecialFolder),\r\n { fdProgramFiles }\r\n (CSIDL: CSIDL_PROGRAM_FILES; MinVersion: $00050000; OnlyNT: False;\r\n CanSimulate: True; Alternative: fdNoSpecialFolder),\r\n { fdProgramFilesCommon }\r\n (CSIDL: CSIDL_PROGRAM_FILES_COMMON; MinVersion: $00050000; OnlyNT: True;\r\n CanSimulate: True; Alternative: fdNoSpecialFolder),\r\n { fdSystem }\r\n (CSIDL: CSIDL_SYSTEM; MinVersion: $00050000; OnlyNT: False;\r\n CanSimulate: True; Alternative: fdNoSpecialFolder),\r\n { fdWindows }\r\n (CSIDL: CSIDL_WINDOWS; MinVersion: $00050000; OnlyNT: False;\r\n CanSimulate: True; Alternative: fdNoSpecialFolder),\r\n { fdCDBurnArea }\r\n (CSIDL: CSIDL_CDBURN_AREA; MinVersion: $00060000; OnlyNT: False;\r\n CanSimulate: False; Alternative: fdNoSpecialFolder),\r\n { fdCommonMusic }\r\n (CSIDL: CSIDL_COMMON_MUSIC; MinVersion: $00060000; OnlyNT: False;\r\n CanSimulate: False; Alternative: fdCommonDocuments),\r\n { fdCommonPictures }\r\n (CSIDL: CSIDL_COMMON_PICTURES; MinVersion: $00060000; OnlyNT: False;\r\n CanSimulate: False; Alternative: fdCommonDocuments),\r\n { fdCommonVideo }\r\n (CSIDL: CSIDL_COMMON_VIDEO; MinVersion: $00060000; OnlyNT: False;\r\n CanSimulate: False; Alternative: fdCommonDocuments),\r\n { fdMyDocuments }\r\n (CSIDL: CSIDL_MYDOCUMENTS; MinVersion: $00060000; OnlyNT: False;\r\n CanSimulate: False; Alternative: fdPersonal),\r\n { fdMyVideo }\r\n (CSIDL: CSIDL_MYVIDEO; MinVersion: $00060000; OnlyNT: False;\r\n CanSimulate: False; Alternative: fdPersonal),\r\n { fdProfiles }\r\n (CSIDL: CSIDL_PROFILES; MinVersion: $00060000; OnlyNT: False;\r\n CanSimulate: False; Alternative: fdNoSpecialFolder),\r\n { fdResources }\r\n (CSIDL: CSIDL_RESOURCES; MinVersion: $00060000; OnlyNT: False;\r\n CanSimulate: False; Alternative: fdNoSpecialFolder),\r\n { fdResourcesLocalized }\r\n (CSIDL: CSIDL_RESOURCES_LOCALIZED; MinVersion: $00060000; OnlyNT: False;\r\n CanSimulate: False; Alternative: fdNoSpecialFolder),\r\n { fdCommonOEMLinks }\r\n (CSIDL: CSIDL_COMMON_OEM_LINKS; MinVersion: $00060000; OnlyNT: False;\r\n CanSimulate: False; Alternative: fdNoSpecialFolder),\r\n { fdComputersNearMe }\r\n (CSIDL: CSIDL_COMPUTERSNEARME; MinVersion: $00060000; OnlyNT: False;\r\n CanSimulate: False; Alternative: fdNoSpecialFolder)\r\n );\r\n\r\nprocedure InitSHFolder;\r\nconst\r\n SHFolderDll = 'SHFolder.dll';\r\nvar\r\n SHFolderHandle: HMODULE;\r\nbegin\r\n { You never know, maybe someone does not have SHFolder.dll, thus load on request }\r\n SHFolderHandle := GetModuleHandle(SHFolderDll);\r\n if SHFolderHandle <> 0 then\r\n {$IFDEF UNICODE}\r\n SHGetFolderPathProc := GetProcAddress(SHFolderHandle, 'SHGetFolderPathW');\r\n {$ELSE}\r\n SHGetFolderPathProc := GetProcAddress(SHFolderHandle, 'SHGetFolderPathA');\r\n {$ENDIF UNICODE}\r\nend;\r\n\r\nprocedure GetCSIDLLocation(const ASpecialDirectory: TFromDirectory;\r\n var CSIDL: Cardinal; var APath: string);\r\n{ This function is a bit overkill }\r\nvar\r\n LSpecialDirectory: TFromDirectory;\r\n Buffer: PChar;\r\n\r\n function IsOk: Boolean;\r\n begin\r\n with CSIDLLocations[LSpecialDirectory] do\r\n Result := (MinVersion <= GetShellVersion) and\r\n (not OnlyNT or (Win32Platform = VER_PLATFORM_WIN32_NT));\r\n end;\r\n\r\nbegin\r\n LSpecialDirectory := ASpecialDirectory;\r\n while (LSpecialDirectory <> fdNoSpecialFolder) and\r\n not CSIDLLocations[LSpecialDirectory].CanSimulate and not IsOk do\r\n LSpecialDirectory := CSIDLLocations[LSpecialDirectory].Alternative;\r\n\r\n if (LSpecialDirectory = fdNoSpecialFolder) or IsOk then\r\n begin\r\n CSIDL := CSIDLLocations[LSpecialDirectory].CSIDL;\r\n Exit;\r\n end;\r\n\r\n CSIDL := 0;\r\n GetMem(Buffer, MAX_PATH * SizeOf(Char));\r\n try\r\n if not Assigned(SHGetFolderPathProc) then\r\n InitSHFolder;\r\n if Assigned(SHGetFolderPathProc) and\r\n Succeeded(SHGetFolderPathProc(0, CSIDLLocations[LSpecialDirectory].CSIDL, 0, 0, Buffer)) then\r\n APath := Buffer\r\n else\r\n APath := '';\r\n finally\r\n FreeMem(Buffer);\r\n end;\r\nend;\r\n\r\nfunction CreateIDListFromPath(const APath: string): PItemIDList;\r\nvar\r\n WS: WideString;\r\n Eaten, Flags: LongWord;\r\n IDesktopFolder: IShellFolder;\r\nbegin\r\n { Returned value must be freed }\r\n\r\n Result := nil;\r\n\r\n if APath = '' then\r\n Exit;\r\n\r\n WS := APath;\r\n { MSDN : Since Flags is an in/out parameter, it should always be initialized }\r\n Flags := 0;\r\n\r\n if Failed(SHGetDesktopFolder(IDesktopFolder)) or\r\n Failed(IDesktopFolder.ParseDisplayName(0, nil, POleStr(WS), Eaten, Result, Flags)) then\r\n Result := nil;\r\nend;\r\n\r\nfunction CreateIDListFromCSIDL(const ASpecialDirectory: TFromDirectory): PItemIDList;\r\nvar\r\n CSIDL: Cardinal;\r\n Path: string;\r\nbegin\r\n { Returned value must be freed }\r\n\r\n Result := nil;\r\n\r\n if ASpecialDirectory = fdNoSpecialFolder then\r\n Exit;\r\n\r\n GetCSIDLLocation(ASpecialDirectory, CSIDL, Path);\r\n\r\n if CSIDL <> 0 then\r\n begin\r\n { MSDN: The calling application is responsible for freeing this pointer }\r\n { SHGetSpecialFolderLocation is shell v4.7 or later}\r\n if Failed(SHGetSpecialFolderLocation(0, CSIDL, Result)) then\r\n Result := nil;\r\n end\r\n else\r\n Result := CreateIDListFromPath(Path);\r\nend;\r\n\r\nfunction IDListToPath(IDList: PItemIDList): string;\r\nvar\r\n IDesktopFolder: IShellFolder;\r\n StrRet: TStrRet;\r\nbegin\r\n { Similar to SHGetPathFromIDList }\r\n if Succeeded(SHGetDesktopFolder(IDesktopFolder)) and\r\n Succeeded(IDesktopFolder.GetDisplayNameOf(IDList, SHGDN_NORMAL or SHGDN_FORPARSING, StrRet)) then\r\n\r\n { Result may be a GUID; Don't know whether these GUIDs are portable. Microsoft\r\n does recommend to return strings 'that are as close to the display names\r\n as possible'. But in this case display names aren't usable }\r\n Result := StrRetToString(IDList, StrRet)\r\n else\r\n Result := '';\r\n\r\n (* These GUID's seem pretty portable, you can enter them at RootDirectoryPath\r\n or Directory, ie the \"::{GUID}\" part (only tested on Windows XP).\r\n\r\n ::{00020D75-0000-0000-C000-000000000046} - Inbox\r\n ::{20D04FE0-3AEA-1069-A2D8-08002B30309D} - CSIDL_DRIVES\r\n ::{208D2C60-3AEA-1069-A2D7-08002B30309D} - CSIDL_NETWORK, CSIDL_NETHOOD\r\n ::{21EC2020-3AEA-1069-A2DD-08002B30309D} - CSIDL_CONTROLS\r\n ::{2227A280-3AEA-1069-A2DE-08002B30309D} - CSIDL_PRINTERS, CSIDL_PRINTHOOD\r\n ::{450D8FBA-AD25-11D0-98A8-0800361B1103} - CSIDL_PERSONAL\r\n ::{645FF040-5081-101B-9F08-00AA002F954E} - CSIDL_BITBUCKET\r\n ::{7007ACC7-3202-11D1-AAD2-00805FC1270E} - CSIDL_CONNECTIONS\r\n ::{871C5380-42A0-1069-A2EA-08002B30309D} - CSIDL_INTERNET\r\n ::{D6277990-4C6A-11CF-8D87-00AA0060F5BF} - Scheduled Tasks\r\n *)\r\nend;\r\n\r\nfunction CSIDLToPath(const ASpecialDirectory: TFromDirectory): string;\r\nvar\r\n CSIDL: Cardinal;\r\n IDList: PItemIDList;\r\n ShellMalloc: IMalloc;\r\nbegin\r\n if ASpecialDirectory = fdNoSpecialFolder then\r\n begin\r\n Result := '';\r\n Exit;\r\n end;\r\n\r\n GetCSIDLLocation(ASpecialDirectory, CSIDL, Result);\r\n\r\n if CSIDL = 0 then\r\n Exit;\r\n\r\n { SHGetSpecialFolderLocation is shell v4.7 or later}\r\n if Succeeded(SHGetSpecialFolderLocation(0, CSIDL, IDList)) then\r\n try\r\n Result := IDListToPath(IDList);\r\n finally\r\n if Succeeded(SHGetMalloc(ShellMalloc)) then\r\n ShellMalloc.Free(IDList);\r\n end\r\n else\r\n Result := '';\r\nend;\r\n\r\nprocedure SetDialogPos(AParentHandle, AWndHandle: THandle;\r\n Position: TJvFolderPos);\r\nvar\r\n R, SR: TRect;\r\nbegin\r\n if GetClientRect(AWndHandle, R) then\r\n begin\r\n //R.Right := R.Left + AWidth;\r\n //R.Bottom := R.Top + AHeight;\r\n SystemParametersInfo(SPI_GETWORKAREA, 0, @SR, 0);\r\n case Position of\r\n fpScreenCenter:\r\n begin\r\n R.Left := ((SR.Right - SR.Left - (R.Right - R.Left)) div 2);\r\n R.Top := (SR.Bottom - SR.Top - (R.Bottom - R.Top)) div 2;\r\n end;\r\n fpFormCenter:\r\n begin\r\n GetWindowRect(AParentHandle, SR);\r\n R.Left := SR.Left + ((SR.Right - SR.Left - (R.Right - R.Left)) div 2);\r\n R.Top := SR.Top + (SR.Bottom - SR.Top - (R.Bottom - R.Top)) div 2;\r\n end;\r\n fpTopLeft:\r\n begin\r\n R.Left := SR.Left;\r\n R.Top := SR.Top;\r\n end;\r\n fpTopRight:\r\n begin\r\n R.Top := SR.Top;\r\n R.Left := SR.Right - (R.Right - R.Left) -\r\n GetSystemMetrics(SM_CXFIXEDFRAME);\r\n end;\r\n fpBottomLeft:\r\n begin\r\n R.Top := SR.Bottom - (R.Bottom - R.Top) -\r\n GetSystemMetrics(SM_CYCAPTION) -\r\n -GetSystemMetrics(SM_CYFIXEDFRAME);\r\n R.Left := SR.Left;\r\n end;\r\n fpBottomRight:\r\n begin\r\n R.Top := SR.Bottom - (R.Bottom - R.Top) -\r\n GetSystemMetrics(SM_CYCAPTION) -\r\n GetSystemMetrics(SM_CYFIXEDFRAME);\r\n R.Left := SR.Right - (R.Right - R.Left) -\r\n GetSystemMetrics(SM_CXFIXEDFRAME);\r\n end;\r\n fpDefault:\r\n Exit;\r\n end;\r\n SetWindowPos(AWndHandle, 0, R.Left, R.Top, 0, 0,\r\n SWP_NOACTIVATE or SWP_NOSIZE or SWP_NOZORDER);\r\n end;\r\nend;\r\n\r\n//=== { TJvBrowseForFolderDialog } ===========================================\r\n\r\nfunction lpfnBrowseProc(Wnd: HWND; uMsg: UINT; lParam, lpData: LPARAM): Integer; stdcall;\r\nbegin\r\n Result := 0;\r\n\r\n with TJvBrowseForFolderDialog(lpData) do\r\n begin\r\n FDialogWindow := Wnd;\r\n case uMsg of\r\n BFFM_INITIALIZED:\r\n DoInitialized;\r\n BFFM_SELCHANGED:\r\n DoSelChanged(PItemIDList(lParam));\r\n BFFM_IUNKNOWN:\r\n DoIUnknown(IUnknown(lParam));\r\n BFFM_VALIDATEFAILEDA:\r\n Result := DoValidateFailed(PChar(lParam));\r\n BFFM_VALIDATEFAILEDW:\r\n Result := DoValidateFailedW(PWideChar(lParam));\r\n end;\r\n end;\r\nend;\r\n\r\nconstructor TJvBrowseForFolderDialog.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FOptions := DefaultJvBrowseFolderDialogOptions;\r\n FPosition := fpScreenCenter; // ahuser: changed from fpDefault - I think no one wants the dialog in the right bottom corner\r\n FRootDirectory := fdNoSpecialFolder;\r\n FObjectInstance := JvMakeObjectInstance(MainWndProc);\r\nend;\r\n\r\ndestructor TJvBrowseForFolderDialog.Destroy;\r\nbegin\r\n PidlFree(FPidl);\r\n JvFreeObjectInstance(FObjectInstance);\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvBrowseForFolderDialog.DefaultHandler(var Msg);\r\nbegin\r\n if FDialogWindow <> 0 then\r\n with TMessage(Msg) do\r\n Result := CallWindowProc(FDefWndProc, FDialogWindow, Msg, WParam, LParam)\r\n else\r\n inherited DefaultHandler(Msg);\r\nend;\r\n\r\nfunction TJvBrowseForFolderDialog.DoGetEnumFlags(const AFolder: string;\r\n var Flags: TJvBrowsableObjectClasses): Boolean;\r\nbegin\r\n { (rb) Always return True? }\r\n Result := True;\r\n if Assigned(FOnGetEnumFlags) then\r\n FOnGetEnumFlags(Self, AFolder, Flags);\r\nend;\r\n\r\nprocedure TJvBrowseForFolderDialog.DoInitialized;\r\nconst\r\n SBtn = 'BUTTON';\r\n HelpButtonId = $FFFF;\r\nvar\r\n BtnHandle, BtnFont: THandle;\r\n BtnSize, WindowSize: TRect;\r\nbegin\r\n { We can now change the position of the dialog - if it's not NewDialogStyle.. }\r\n FPositionSet := not (odNewDialogStyle in FUsedOptions);\r\n if FPositionSet then\r\n SetDialogPos(FOwnerWindow, FDialogWindow, Position);\r\n\r\n { ..Otherwise we have to delay the change until receive of WM_SHOWWINDOW,\r\n thus we need to hook the dialog; we also need to hook the dialog if there\r\n is a new help button on the dialog and the dialog is resizeable - ie\r\n NewDialogStyle }\r\n if not FPositionSet or ((FHelpContext <> 0) and (odNewDialogStyle in FUsedOptions)) then\r\n HookDialog;\r\n\r\n // [roko] Rx's code to insert Help button\r\n if FHelpContext <> 0 then\r\n begin\r\n { SomeBtnHandle is some button on the window; we need it to determine a\r\n useable height & width for the new help button }\r\n BtnHandle := FindWindowEx(FDialogWindow, 0, SBtn, nil);\r\n if BtnHandle <> 0 then\r\n begin\r\n GetWindowRect(BtnHandle, BtnSize);\r\n GetWindowRect(FDialogWindow, WindowSize);\r\n ScreenToClient(FDialogWindow, BtnSize.TopLeft);\r\n ScreenToClient(FDialogWindow, BtnSize.BottomRight);\r\n BtnFont := SendMessage(FDialogWindow, WM_GETFONT, 0, 0);\r\n { Note: BtnSize.Top = \"Window.Height\" - FHelpButtonHeightDelta, used in\r\n WM_SIZE }\r\n FHelpButtonHeightDelta := WindowSize.Bottom - WindowSize.Top - BtnSize.Top;\r\n { Remember the new buttons handle, because we need it, when the dialog\r\n is resized }\r\n FHelpButtonHandle := CreateWindow(SBtn, PChar(SHelpButton),\r\n WS_CHILD or WS_CLIPSIBLINGS or WS_VISIBLE or BS_PUSHBUTTON or WS_TABSTOP,\r\n 12, BtnSize.Top, BtnSize.Right - BtnSize.Left, BtnSize.Bottom - BtnSize.Top,\r\n FDialogWindow, HelpButtonId, HInstance, nil);\r\n if BtnFont <> 0 then\r\n SendMessage(FHelpButtonHandle, WM_SETFONT, BtnFont, MakeLParam(1, 0));\r\n UpdateWindow(FDialogWindow);\r\n end;\r\n end;\r\n\r\n { Change directory (if possible) }\r\n if FDirectory <> '' then\r\n SetSelection(FDirectory);\r\n UpdateStatusText(FDirectory);\r\n\r\n if Assigned(FOnInit) then\r\n FOnInit(Self);\r\nend;\r\n\r\nprocedure TJvBrowseForFolderDialog.DoIUnknown(const Unknown: IUnknown);\r\nvar\r\n FolderFilterSite: IFolderFilterSite;\r\nbegin\r\n if (Assigned(FOnGetEnumFlags) or Assigned(FOnShouldShow)) and\r\n Supports(Unknown, IID_IFolderFilterSite, FolderFilterSite) then\r\n begin\r\n FolderFilterSite.SetFilter(Self);\r\n FolderFilterSite := nil;\r\n end;\r\nend;\r\n\r\nprocedure TJvBrowseForFolderDialog.DoSelChanged(IDList: PItemIDList);\r\nvar\r\n // (p3) use buff array instead of string as this works better\r\n Buffer: array [0..MAX_PATH] of Char;\r\n Path: string;\r\n Accept: Boolean;\r\n SavePidl: PItemIDList;\r\nbegin\r\n { Note :\r\n * If the location specified by the pidl parameter is not part of the file\r\n system, this function will fail.\r\n * If the pidl parameter specifies a shortcut, the pszPath will contain the\r\n path to the shortcut, not to the shortcut's target. (if not win XP )\r\n\r\n Could also use IDListToPath\r\n }\r\n\r\n if SHGetPathFromIDList(IDList, Buffer) then\r\n Path := Buffer\r\n else\r\n Path := '';\r\n\r\n SavePidl := FPidl;\r\n FPidl := IDList;\r\n try\r\n if Assigned(FOnAcceptChange) then\r\n begin\r\n Accept := True;\r\n FOnAcceptChange(Self, Path, Accept);\r\n SetOKEnabled(Accept);\r\n end;\r\n\r\n UpdateStatusText(Path);\r\n\r\n if Assigned(FOnChange) then\r\n FOnChange(Self, Path);\r\n finally\r\n FPidl := SavePidl;\r\n end;\r\nend;\r\n\r\nfunction TJvBrowseForFolderDialog.DoShouldShow(const AItem: string): Boolean;\r\nbegin\r\n if Assigned(FOnShouldShow) then\r\n FOnShouldShow(Self, AItem, Result)\r\n else\r\n Result := True;\r\nend;\r\n\r\nfunction TJvBrowseForFolderDialog.DoValidateFailed(AEditText: string): Integer;\r\nvar\r\n CanClose: Boolean;\r\nbegin\r\n { Return zero to allow the dialog to be dismissed or nonzero to keep\r\n the dialog displayed. }\r\n if Assigned(FOnValidateFailed) then\r\n begin\r\n CanClose := True;\r\n FOnValidateFailed(Self, AEditText, CanClose);\r\n Result := Integer(not CanClose);\r\n end\r\n else\r\n Result := 0; // = Integer(False)\r\nend;\r\n\r\nfunction TJvBrowseForFolderDialog.DoValidateFailedW(AEditText: WideString): Integer;\r\nbegin\r\n { Explicit conversion }\r\n Result := DoValidateFailed(PChar(string(AEditText)));\r\nend;\r\n\r\nfunction TJvBrowseForFolderDialog.Execute(ParentWnd: HWND): Boolean;\r\nvar\r\n dspName: array [0..MAX_PATH] of Char;\r\n BrowseInfo: TBrowseInfo;\r\n ShellVersion: Cardinal;\r\n ActiveWindow: HWND;\r\n WindowList: Pointer;\r\n Option: TOptionsDirectory;\r\nbegin\r\n FOwnerWindow := ParentWnd;\r\n ShellVersion := GetShellVersion;\r\n if ShellVersion < $00040000 then\r\n raise EJVCLException.CreateRes(@RsEShellNotCompatible);\r\n\r\n FDialogWindow := 0;\r\n FPositionSet := False;\r\n FHelpButtonHandle := 0;\r\n FHelpButtonHeightDelta := 0;\r\n\r\n Result := False;\r\n\r\n FillChar(BrowseInfo, SizeOf(BrowseInfo), #0);\r\n\r\n { FUsedOptions is a subset of FOptions; the options that actually can be\r\n used because of shell version limitations }\r\n FUsedOptions := FOptions;\r\n if ShellVersion < $00060000 then\r\n FUsedOptions := FUsedOptions - [odNoNewButtonFolder, odUsageHint];\r\n if ShellVersion < $00050000 then\r\n FUsedOptions := FUsedOptions - [odIncludeUrls, odNewDialogStyle, odShareable];\r\n if ShellVersion < $00040071 then\r\n FUsedOptions := FUsedOptions - [odIncludeFiles, odEditBox, odValidate];\r\n\r\n for Option := Low(TOptionsDirectory) to High(TOptionsDirectory) do\r\n if Option in FUsedOptions then\r\n Inc(BrowseInfo.ulFlags, COptionsDirectory[Option]);\r\n\r\n BrowseInfo.hwndOwner := FOwnerWindow;\r\n BrowseInfo.pszDisplayName := dspName;\r\n BrowseInfo.lpfn := TFNBFFCallBack(@lpfnBrowseProc);\r\n BrowseInfo.lParam := LPARAM(Self);\r\n\r\n if (FStatusText = '') or not (odNewDialogStyle in FUsedOptions) then\r\n BrowseInfo.lpszTitle := Pointer(FTitle)\r\n else\r\n if FTitle = '' then\r\n BrowseInfo.lpszTitle := PChar(FStatusText)\r\n else\r\n BrowseInfo.lpszTitle := PChar(FTitle + Cr + FStatusText);\r\n\r\n if FRootDirectory = fdNoSpecialFolder then\r\n BrowseInfo.pidlRoot := CreateIDListFromPath(FRootDirectoryPath)\r\n else\r\n BrowseInfo.pidlRoot := CreateIDListFromCSIDL(FRootDirectory);\r\n\r\n try\r\n if odNewDialogStyle in FUsedOptions then\r\n CoInitialize(nil);\r\n try\r\n ActiveWindow := GetActiveWindow;\r\n WindowList := DisableTaskWindows(0);\r\n try\r\n if not PidlFree(FPidl) then\r\n begin\r\n Assert(False); // FPidl comes from shell, so PidlFree should never fail\r\n FPidl := nil; // in case building without assertions, need to ensure FPidl is nil\r\n end;\r\n FPidl := SHBrowseForFolder(BrowseInfo);\r\n finally\r\n EnableTaskWindows(WindowList);\r\n SetActiveWindow(ActiveWindow);\r\n end;\r\n\r\n Result := FPidl <> nil;\r\n if Result then\r\n begin\r\n FDisplayName := BrowseInfo.pszDisplayName;\r\n FDirectory := IDListToPath(FPidl);\r\n end;\r\n\r\n PidlFree(BrowseInfo.pidlRoot);\r\n finally\r\n FDialogWindow := 0;\r\n FOwnerWindow := 0;\r\n if odNewDialogStyle in FUsedOptions then\r\n CoUninitialize;\r\n end;\r\n except\r\n end;\r\nend;\r\n\r\nfunction TJvBrowseForFolderDialog.GetEnumFlags(psf: IShellFolder;\r\n pidlFolder: PItemIDList; const phWnd: THandle;\r\n var pgrfFlags: DWORD): HResult;\r\nvar\r\n Flags: TJvBrowsableObjectClasses;\r\n Obj: TJvBrowsableObjectClass;\r\nbegin\r\n { (rb) Don't know for sure if pgrfFlags is initialized }\r\n Flags := [];\r\n for Obj := Low(TJvBrowsableObjectClass) to High(TJvBrowsableObjectClass) do\r\n if pgrfFlags and CBrowseObjectClasses[Obj] = CBrowseObjectClasses[Obj] then\r\n Include(Flags, Obj);\r\n\r\n { This seems not to work ?? : }\r\n //if psf.GetDisplayNameOf(pidlFolder, SHGDN_NORMAL or SHGDN_FORPARSING, StrRet) <> S_OK then\r\n // Exit;\r\n try\r\n if DoGetEnumFlags(IDListToPath(pidlFolder), Flags) then\r\n Result := S_OK\r\n else\r\n Result := S_FALSE;\r\n except\r\n Result := E_UNEXPECTED;\r\n end;\r\n\r\n pgrfFlags := 0;\r\n for Obj := Low(TJvBrowsableObjectClass) to High(TJvBrowsableObjectClass) do\r\n if Obj in Flags then\r\n Inc(pgrfFlags, CBrowseObjectClasses[Obj]);\r\nend;\r\n\r\nfunction TJvBrowseForFolderDialog.GetRootDirectoryPath: string;\r\nbegin\r\n if FRootDirectory = fdNoSpecialFolder then\r\n Result := FRootDirectoryPath\r\n else\r\n Result := CSIDLToPath(FRootDirectory);\r\nend;\r\n\r\nprocedure TJvBrowseForFolderDialog.HookDialog;\r\nbegin\r\n if FDialogWindow <> 0 then\r\n FDefWndProc := Pointer(SetWindowLongPtr(FDialogWindow, GWL_WNDPROC, LONG_PTR(FObjectInstance)));\r\nend;\r\n\r\nfunction TJvBrowseForFolderDialog.IsRootDirectoryPathStored: Boolean;\r\nbegin\r\n Result := (RootDirectory = fdNoSpecialFolder) and (FRootDirectoryPath > '');\r\nend;\r\n\r\nprocedure TJvBrowseForFolderDialog.MainWndProc(var Msg: TMessage);\r\nbegin\r\n try\r\n Dispatch(Msg);\r\n except\r\n Application.HandleException(Self);\r\n end;\r\nend;\r\n\r\nprocedure TJvBrowseForFolderDialog.SetExpanded(const APath: string);\r\nbegin\r\n if FDialogWindow <> 0 then\r\n { Implicit conversion }\r\n SetExpandedW(APath);\r\nend;\r\n\r\nprocedure TJvBrowseForFolderDialog.SetExpanded(IDList: PItemIDList);\r\nbegin\r\n if FDialogWindow <> 0 then\r\n SendMessage(FDialogWindow, BFFM_SETEXPANDED, WPARAM(False), LPARAM(IDList));\r\nend;\r\n\r\nprocedure TJvBrowseForFolderDialog.SetExpandedW(const APath: WideString);\r\nbegin\r\n if FDialogWindow <> 0 then\r\n SendMessage(FDialogWindow, BFFM_SETEXPANDED, WPARAM(True), LPARAM(PWideChar(APath)));\r\nend;\r\n\r\nprocedure TJvBrowseForFolderDialog.SetOKEnabled(const Value: Boolean);\r\nbegin\r\n if FDialogWindow <> 0 then\r\n SendMessage(FDialogWindow, BFFM_ENABLEOK, 0, LPARAM(Value));\r\nend;\r\n\r\nprocedure TJvBrowseForFolderDialog.SetOKText(const AText: string);\r\nbegin\r\n if FDialogWindow <> 0 then\r\n { Implicit conversion }\r\n SetOKTextW(AText);\r\nend;\r\n\r\nprocedure TJvBrowseForFolderDialog.SetOKTextW(const AText: WideString);\r\nbegin\r\n if FDialogWindow <> 0 then\r\n SendMessage(FDialogWindow, BFFM_SETOKTEXT, 0, LPARAM(PWideChar(AText)));\r\nend;\r\n\r\nprocedure TJvBrowseForFolderDialog.SetOptions(const Value: TOptionsDir);\r\nvar\r\n AddedOptions, RemovedOptions: TOptionsDir;\r\nbegin\r\n if FOptions = Value then\r\n Exit;\r\n\r\n AddedOptions := Value - (FOptions * Value);\r\n RemovedOptions := FOptions - (FOptions * Value);\r\n\r\n FOptions := Value;\r\n\r\n { Force correct options }\r\n if odIncludeUrls in AddedOptions then\r\n FOptions := FOptions + [odEditBox, odNewDialogStyle, odIncludeFiles];\r\n if odShareable in AddedOptions then\r\n FOptions := FOptions + [odNewDialogStyle];\r\n if odUsageHint in AddedOptions then\r\n FOptions := FOptions + [odNewDialogStyle] - [odEditBox];\r\n if odValidate in AddedOptions then\r\n FOptions := FOptions + [odEditBox];\r\n if odEditBox in AddedOptions then\r\n FOptions := FOptions - [odUsageHint];\r\n\r\n if odEditBox in RemovedOptions then\r\n FOptions := FOptions - [odIncludeUrls, odValidate];\r\n if odNewDialogStyle in RemovedOptions then\r\n FOptions := FOptions - [odIncludeUrls, odShareable, odUsageHint];\r\n if odIncludeFiles in RemovedOptions then\r\n FOptions := FOptions - [odIncludeUrls];\r\n\r\n { Last check }\r\n if odEditBox in FOptions then\r\n FOptions := FOptions - [odUsageHint]\r\n else\r\n FOptions := FOptions - [odIncludeUrls, odValidate];\r\n if odUsageHint in FOptions then\r\n FOptions := FOptions - [odValidate, odEditBox];\r\nend;\r\n\r\nprocedure TJvBrowseForFolderDialog.SetRootDirectory(\r\n const Value: TFromDirectory);\r\nbegin\r\n if (Value = fdNoSpecialFolder) and (FRootDirectory <> fdNoSpecialFolder) then\r\n FRootDirectoryPath := GetRootDirectoryPath;\r\n\r\n FRootDirectory := Value;\r\nend;\r\n\r\nprocedure TJvBrowseForFolderDialog.SetRootDirectoryPath(\r\n const Value: string);\r\nbegin\r\n FRootDirectory := fdNoSpecialFolder;\r\n FRootDirectoryPath := Value;\r\nend;\r\n\r\nprocedure TJvBrowseForFolderDialog.SetSelection(const APath: string);\r\nbegin\r\n if FDialogWindow <> 0 then\r\n SendMessage(FDialogWindow, BFFM_SETSELECTION, WPARAM(True), LPARAM(Pointer(APath)));\r\nend;\r\n\r\nprocedure TJvBrowseForFolderDialog.SetSelection(IDList: PItemIDList);\r\nbegin\r\n if FDialogWindow <> 0 then\r\n SendMessage(FDialogWindow, BFFM_SETSELECTION, WPARAM(False), LPARAM(IDList));\r\nend;\r\n\r\nprocedure TJvBrowseForFolderDialog.SetStatusText(const AText: string);\r\nbegin\r\n if FDialogWindow <> 0 then\r\n SendMessage(FDialogWindow, BFFM_SETSTATUSTEXT, 0, LPARAM(Pointer(AText)));\r\nend;\r\n\r\nprocedure TJvBrowseForFolderDialog.SetStatusTextW(const AText: WideString);\r\nbegin\r\n if FDialogWindow <> 0 then\r\n SendMessage(FDialogWindow, BFFM_SETSTATUSTEXTW, 0, LPARAM(PWideChar(AText)));\r\nend;\r\n\r\nfunction TJvBrowseForFolderDialog.ShouldShow(psf: IShellFolder; pidlFolder,\r\n pidlItem: PItemIDList): HResult;\r\nvar\r\n StrRet: TStrRet;\r\nbegin\r\n psf.GetDisplayNameOf(pidlItem, SHGDN_NORMAL or SHGDN_FORPARSING, StrRet);\r\n\r\n try\r\n if DoShouldShow(StrRetToString(pidlItem, StrRet)) then\r\n Result := S_OK\r\n else\r\n Result := S_FALSE;\r\n except\r\n Result := E_UNEXPECTED;\r\n end;\r\nend;\r\n\r\nprocedure TJvBrowseForFolderDialog.UpdateStatusText(AText: string);\r\nconst\r\n cStatusLabel = $3743;\r\nvar\r\n WindowRect, ItemRect: TRect;\r\n ItemHandle: THandle;\r\n LCanvas: TCanvas;\r\nbegin\r\n if [odStatusAvailable, odNewDialogStyle] * FUsedOptions <> [odStatusAvailable] then\r\n Exit;\r\n\r\n if StatusText <> '' then\r\n AText := StatusText\r\n else\r\n begin\r\n ItemHandle := GetDlgItem(FDialogWindow, cStatusLabel);\r\n if ItemHandle <> 0 then\r\n begin\r\n GetWindowRect(FDialogWindow, WindowRect);\r\n GetWindowRect(ItemHandle, ItemRect);\r\n if Application.MainForm <> nil then\r\n LCanvas := Application.MainForm.Canvas\r\n else\r\n begin\r\n LCanvas := TCanvas.Create;\r\n LCanvas.Handle := GetDC(HWND_DESKTOP);\r\n end;\r\n AText := MinimizeFileName(AText, LCanvas,\r\n (WindowRect.Right - WindowRect.Left) - (ItemRect.Left - WindowRect.Left) * 2 - 8);\r\n if Application.MainForm = nil then\r\n LCanvas.Free;\r\n end;\r\n end;\r\n\r\n SetStatusText(AText);\r\nend;\r\n\r\nprocedure TJvBrowseForFolderDialog.WMShowWindow(var Msg: TMessage);\r\nbegin\r\n { If the dialog isn't resized, we won't get a WM_SIZE message. Thus we\r\n respond to the WM_SHOWWINDOW message }\r\n\r\n if not FPositionSet then\r\n SetDialogPos(FOwnerWindow, FDialogWindow, Position);\r\n FPositionSet := True;\r\n\r\n inherited;\r\nend;\r\n\r\nprocedure TJvBrowseForFolderDialog.WMSize(var Msg: TWMSize);\r\nvar\r\n BtnSize: TRect;\r\n WindowSize: TRect;\r\nbegin\r\n inherited;\r\n\r\n if FHelpButtonHandle <> 0 then\r\n begin\r\n GetWindowRect(FHelpButtonHandle, BtnSize);\r\n GetWindowRect(FDialogWindow, WindowSize);\r\n ScreenToClient(FDialogWindow, BtnSize.TopLeft);\r\n ScreenToClient(FDialogWindow, BtnSize.BottomRight);\r\n\r\n SetWindowPos(FHelpButtonHandle, 0, BtnSize.Left,\r\n WindowSize.Bottom - WindowSize.Top - FHelpButtonHeightDelta,\r\n BtnSize.Right - BtnSize.Left, BtnSize.Bottom - BtnSize.Top,\r\n SWP_NOZORDER + SWP_NOACTIVATE);\r\n end;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvButton.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvButton.PAS, released on 2001-02-28.\r\n\r\nThe Initial Developer of the Original Code is Sbastien Buysse [sbuysse att buypin dott com]\r\nPortions created by Sbastien Buysse are Copyright (C) 2001 Sbastien Buysse.\r\nAll Rights Reserved.\r\n\r\nContributor(s): Michael Beck [mbeck att bigfoot dott com].\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvButton.pas 13104 2011-09-07 06:50:43Z obones $\r\n\r\nunit JvButton;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, Messages, Classes, Graphics, Controls, Menus, Buttons,\r\n JvComponent, JvConsts, JvTypes, JvExStdCtrls;\r\n\r\ntype\r\n TJvButtonMouseState = (bsMouseInside, bsMouseDown);\r\n TJvButtonMouseStates = set of TJvButtonMouseState;\r\n\r\n TJvCustomGraphicButton = class(TJvGraphicControl)\r\n private\r\n FStates: TJvButtonMouseStates;\r\n FBuffer: TBitmap;\r\n FFlat: Boolean;\r\n FDropDownMenu: TPopupMenu;\r\n FDown: Boolean;\r\n FForceSameSize: Boolean;\r\n FAllowAllUp: Boolean;\r\n FGroupIndex: Integer;\r\n FHotTrack: Boolean;\r\n FHotFont: TFont;\r\n FHotTrackFontOptions: TJvTrackFontOptions;\r\n FOnDropDownMenu: TContextPopupEvent;\r\n FDropArrow: Boolean;\r\n FOnDropDownClose: TNotifyEvent;\r\n function GetPattern: TBitmap;\r\n procedure SetFlat(const Value: Boolean);\r\n procedure SetDown(Value: Boolean);\r\n\r\n procedure CMButtonPressed(var Msg: TCMButtonPressed); message CM_JVBUTTONPRESSED;\r\n procedure CMForceSize(var Msg: TCMForceSize); message CM_FORCESIZE;\r\n procedure CMSysColorChange(var Msg: TMessage); message CM_SYSCOLORCHANGE;\r\n procedure SetForceSameSize(const Value: Boolean);\r\n procedure SetAllowAllUp(const Value: Boolean);\r\n procedure SetGroupIndex(const Value: Integer);\r\n procedure SetHotFont(const Value: TFont);\r\n procedure SetHotTrackFontOptions(const Value: TJvTrackFontOptions);\r\n procedure SetDropArrow(const Value: Boolean);\r\n procedure SetDropDownMenu(const Value: TPopupMenu);\r\n protected\r\n procedure ButtonPressed(Sender: TJvCustomGraphicButton; AGroupIndex: Integer); virtual;\r\n procedure ForceSize(Sender: TControl; AWidth, AHeight: Integer);\r\n function DoDropDownMenu(Button: TMouseButton; Shift: TShiftState; X, Y: Integer): Boolean; virtual;\r\n procedure DropDownClose;\r\n procedure UpdateExclusive;\r\n procedure Notification(AComponent: TComponent; Operation: TOperation); override;\r\n procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;\r\n procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;\r\n procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;\r\n procedure MouseEnter(Control: TControl); override;\r\n procedure MouseLeave(Control: TControl); override;\r\n procedure Paint; override;\r\n procedure PaintButton(Canvas: TCanvas); virtual;\r\n procedure PaintFrame(Canvas: TCanvas); virtual;\r\n function InsideBtn(X, Y: Integer): Boolean; virtual;\r\n\r\n function WantKey(Key: Integer; Shift: TShiftState): Boolean; override;\r\n procedure EnabledChanged; override;\r\n procedure FontChanged; override;\r\n procedure RepaintBackground; virtual;\r\n procedure TextChanged; override;\r\n\r\n property AllowAllUp: Boolean read FAllowAllUp write SetAllowAllUp default False;\r\n property GroupIndex: Integer read FGroupIndex write SetGroupIndex default 0;\r\n\r\n property MouseStates: TJvButtonMouseStates read FStates write FStates default [];\r\n property ForceSameSize: Boolean read FForceSameSize write SetForceSameSize default False;\r\n property Pattern: TBitmap read GetPattern;\r\n property Flat: Boolean read FFlat write SetFlat default False;\r\n property HotTrack: Boolean read FHotTrack write FHotTrack default False;\r\n property HotTrackFont: TFont read FHotFont write SetHotFont;\r\n property HotTrackFontOptions: TJvTrackFontOptions read FHotTrackFontOptions write SetHotTrackFontOptions default\r\n DefaultTrackFontOptions;\r\n property Down: Boolean read FDown write SetDown default False;\r\n property DropDownMenu: TPopupMenu read FDropDownMenu write SetDropDownMenu;\r\n property DropArrow: Boolean read FDropArrow write SetDropArrow default False;\r\n property OnDropDownMenu: TContextPopupEvent read FOnDropDownMenu write FOnDropDownMenu;\r\n property OnDropDownClose: TNotifyEvent read FOnDropDownClose write FOnDropDownClose;\r\n public\r\n procedure Click; override;\r\n\r\n procedure SetBounds(ALeft, ATop, AWidth, AHeight: Integer); override;\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n procedure DrawDropArrow(Canvas: TCanvas; ArrowRect: TRect); virtual;\r\n end;\r\n\r\n TJvCustomButton = class(TJvExButton)\r\n private\r\n FDropDownMenu: TPopupMenu;\r\n FHotTrack: Boolean;\r\n FHotFont: TFont;\r\n FFontSave: TFont;\r\n FWordWrap: Boolean;\r\n FForceSameSize: Boolean;\r\n FHotTrackFontOptions: TJvTrackFontOptions;\r\n FOnDropDownMenu: TContextPopupEvent;\r\n FDropArrow: Boolean;\r\n procedure SetHotFont(const Value: TFont);\r\n procedure SetWordWrap(const Value: Boolean);\r\n procedure SetForceSameSize(const Value: Boolean);\r\n procedure CMForceSize(var Msg: TCMForceSize); message CM_FORCESIZE;\r\n procedure SetHotTrackFontOptions(const Value: TJvTrackFontOptions);\r\n procedure SetDropArrow(const Value: Boolean);\r\n procedure SetDropDownMenu(const Value: TPopupMenu);\r\n protected\r\n function DoDropDownMenu(X, Y: Integer): Boolean; virtual;\r\n procedure ForceSize(Sender: TControl; AWidth, AHeight: Integer);\r\n procedure MouseEnter(Control: TControl); override;\r\n procedure MouseLeave(Control: TControl); override;\r\n procedure FontChanged; override;\r\n procedure CreateParams(var Params: TCreateParams); override;\r\n function GetRealCaption: string; dynamic;\r\n procedure Notification(AComponent: TComponent; Operation: TOperation); override;\r\n property WordWrap: Boolean read FWordWrap write SetWordWrap default True;\r\n property ForceSameSize: Boolean read FForceSameSize write SetForceSameSize default False;\r\n property DropArrow: Boolean read FDropArrow write SetDropArrow default False;\r\n property DropDownMenu: TPopupMenu read FDropDownMenu write SetDropDownMenu;\r\n\r\n property HotTrack: Boolean read FHotTrack write FHotTrack default False;\r\n property HotTrackFont: TFont read FHotFont write SetHotFont;\r\n property HotTrackFontOptions: TJvTrackFontOptions read FHotTrackFontOptions write SetHotTrackFontOptions default\r\n DefaultTrackFontOptions;\r\n property HintColor;\r\n property OnParentColorChange;\r\n property OnDropDownMenu: TContextPopupEvent read FOnDropDownMenu write FOnDropDownMenu;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n procedure Click;override;\r\n procedure DrawDropArrow(Canvas: TCanvas; ArrowRect: TRect); virtual;\r\n procedure SetBounds(ALeft: Integer; ATop: Integer; AWidth: Integer; AHeight: Integer); override;\r\n\r\n end;\r\n\r\n // TJvDropDownButton draws a DropDown button with the DropDown glyph\r\n // (also themed). It ignores the properties Glyph and Flat\r\n TJvDropDownButton = class(TSpeedButton)\r\n protected\r\n procedure Paint; override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvButton.pas $';\r\n Revision: '$Revision: 13104 $';\r\n Date: '$Date: 2011-09-07 08:50:43 +0200 (mer. 07 sept. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n SysUtils, Forms, Types,\r\n JvJVCLUtils, JvThemes;\r\n\r\nconst\r\n JvBtnLineSeparator = '|';\r\n\r\nvar\r\n GlobalPattern: TBitmap = nil;\r\n\r\nfunction CreateBrushPattern: TBitmap;\r\nvar\r\n X, Y: Integer;\r\nbegin\r\n if GlobalPattern = nil then\r\n begin\r\n GlobalPattern := TBitmap.Create;\r\n try\r\n GlobalPattern.Width := 8; { must have this size }\r\n GlobalPattern.Height := 8;\r\n with GlobalPattern.Canvas do\r\n begin\r\n Brush.Style := bsSolid;\r\n Brush.Color := clBtnFace;\r\n FillRect(Rect(0, 0, GlobalPattern.Width, GlobalPattern.Height));\r\n for Y := 0 to 7 do\r\n for X := 0 to 7 do\r\n if (Y mod 2) = (X mod 2) then { toggles between even/odd pixels }\r\n Pixels[X, Y] := clWhite; { on even/odd rows }\r\n end;\r\n except\r\n FreeAndNil(GlobalPattern);\r\n end;\r\n end;\r\n Result := GlobalPattern;\r\nend;\r\n\r\n//=== { TJvCustomGraphicButton } =============================================\r\n\r\nconstructor TJvCustomGraphicButton.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n ControlStyle := ControlStyle -\r\n [csOpaque, csDoubleClicks ];\r\n FStates := [];\r\n SetBounds(0, 0, 40, 40);\r\n FBuffer := TBitmap.Create;\r\n FFlat := False;\r\n FDropArrow := False;\r\n FForceSameSize := False;\r\n FHotFont := TFont.Create;\r\n FHotTrackFontOptions := DefaultTrackFontOptions;\r\nend;\r\n\r\ndestructor TJvCustomGraphicButton.Destroy;\r\nbegin\r\n FBuffer.Free;\r\n FHotFont.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvCustomGraphicButton.DrawDropArrow(Canvas: TCanvas; ArrowRect: TRect);\r\nvar\r\n I: Integer;\r\nbegin\r\n if not Enabled then\r\n Canvas.Pen.Color := clInactiveCaption\r\n else\r\n Canvas.Pen.Color := clWindowText;\r\n for I := 0 to 3 do\r\n begin\r\n if ArrowRect.Left + I <= ArrowRect.Right - I then\r\n begin\r\n Canvas.MoveTo(ArrowRect.Left + I, ArrowRect.Top + I);\r\n Canvas.LineTo(ArrowRect.Right - I, ArrowRect.Top + I);\r\n end;\r\n end;\r\nend;\r\n\r\n{ Handle speedkeys (Alt + key) }\r\n\r\nfunction TJvCustomGraphicButton.WantKey(Key: Integer; Shift: TShiftState): Boolean;\r\nbegin\r\n Result := IsAccel(Key, Caption) and Enabled and (Shift * KeyboardShiftStates = [ssAlt]);\r\n if Result then\r\n Click\r\n else\r\n Result := inherited WantKey(Key, Shift);\r\nend;\r\n\r\nprocedure TJvCustomGraphicButton.EnabledChanged;\r\nbegin\r\n inherited EnabledChanged;\r\n if not Enabled then\r\n FStates := [];\r\n RepaintBackground;\r\nend;\r\n\r\nprocedure TJvCustomGraphicButton.MouseEnter(Control: TControl);\r\nbegin\r\n if csDesigning in ComponentState then\r\n Exit;\r\n if Enabled and not MouseOver then\r\n begin\r\n Include(FStates, bsMouseInside);\r\n inherited MouseEnter(Control);\r\n if Flat then\r\n RepaintBackground;\r\n if HotTrack then\r\n Repaint;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomGraphicButton.MouseLeave(Control: TControl);\r\nbegin\r\n if Enabled and MouseOver then\r\n begin\r\n Exclude(FStates, bsMouseInside);\r\n inherited MouseLeave(Control);\r\n if Flat then\r\n RepaintBackground;\r\n if HotTrack then\r\n Repaint;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomGraphicButton.Paint;\r\nvar\r\n ArrowRect: TRect;\r\nbegin\r\n// FBuffer.Width := Width;\r\n// FBuffer.Height := Height;\r\n PaintFrame(Canvas);\r\n PaintButton(Canvas);\r\n if DropArrow and Assigned(DropDownMenu) then\r\n begin\r\n ArrowRect := Rect(Width - 16, Height div 2, Width - 9, Height div 2 + 9);\r\n if bsMouseDown in FStates then\r\n OffsetRect(ArrowRect, 1, 1);\r\n DrawDropArrow(Canvas, ArrowRect);\r\n end;\r\n// BitBlt(Canvas.Handle, 0, 0, Width,Height, FBuffer.Canvas.Handle, 0, 0, SRCCOPY);\r\nend;\r\n\r\nprocedure TJvCustomGraphicButton.PaintFrame(Canvas: TCanvas);\r\nbegin\r\n // do nothing\r\nend;\r\n\r\nprocedure TJvCustomGraphicButton.PaintButton(Canvas: TCanvas);\r\nbegin\r\n if (bsMouseInside in FStates) and HotTrack then\r\n Canvas.Font := FHotFont\r\n else\r\n Canvas.Font := Font;\r\nend;\r\n\r\nfunction TJvCustomGraphicButton.InsideBtn(X, Y: Integer): Boolean;\r\nbegin\r\n Result := PtInRect(Rect(0, 0, Width, Height), Point(X, Y));\r\nend;\r\n\r\nprocedure TJvCustomGraphicButton.MouseDown(Button: TMouseButton;\r\n Shift: TShiftState; X, Y: Integer);\r\nvar\r\n Tmp: TPoint;\r\nbegin\r\n if not Enabled then\r\n Exit;\r\n\r\n inherited MouseDown(Button, Shift, X, Y);\r\n\r\n if InsideBtn(X, Y) then\r\n begin\r\n FStates := [bsMouseDown, bsMouseInside];\r\n RepaintBackground;\r\n end;\r\n SetCaptureControl(Self);\r\n Tmp := ClientToScreen(Point(0, Height));\r\n DoDropDownMenu(Button, Shift, Tmp.X, Tmp.Y);\r\nend;\r\n\r\nprocedure TJvCustomGraphicButton.MouseMove(Shift: TShiftState;\r\n X, Y: Integer);\r\nbegin\r\n inherited MouseMove(Shift, X, Y);\r\n if MouseCapture then\r\n begin\r\n if not InsideBtn(X, Y) then\r\n begin\r\n if bsMouseInside in FStates then\r\n begin\r\n Exclude(FStates, bsMouseInside);\r\n RepaintBackground;\r\n end;\r\n end\r\n else\r\n begin\r\n if not (bsMouseInside in FStates) then\r\n begin\r\n Include(FStates, bsMouseInside);\r\n RepaintBackground;\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomGraphicButton.MouseUp(Button: TMouseButton;\r\n Shift: TShiftState; X, Y: Integer);\r\nbegin\r\n if GetCaptureControl = Self then\r\n ReleaseCapture;\r\n if not Enabled then\r\n Exit;\r\n inherited MouseUp(Button, Shift, X, Y);\r\n Exclude(FStates, bsMouseDown);\r\n RepaintBackground;\r\nend;\r\n\r\nfunction TJvCustomGraphicButton.DoDropDownMenu(Button: TMouseButton; Shift: TShiftState; X, Y: Integer): Boolean;\r\nvar\r\n Msg: TMsg;\r\n Handled: Boolean;\r\nbegin\r\n Result := (Button = mbLeft) and (DropDownMenu <> nil);\r\n if Result then\r\n begin\r\n DropDownMenu.PopupComponent := Self;\r\n case DropDownMenu.Alignment of\r\n paRight:\r\n Inc(X, Width);\r\n paCenter:\r\n Inc(X, Width div 2);\r\n end;\r\n Handled := False;\r\n if Assigned(FOnDropDownMenu) then\r\n FOnDropDownMenu(Self, Point(X, Y), Handled);\r\n if not Handled then\r\n DropDownMenu.Popup(X, Y)\r\n else\r\n Exit;\r\n { wait 'til menu is done }\r\n while PeekMessage(Msg, 0, WM_MOUSEFIRST, WM_MOUSELAST, PM_REMOVE) do\r\n {nothing};\r\n { release button }\r\n MouseUp(Button, Shift, X, Y);\r\n DropDownClose;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomGraphicButton.SetFlat(const Value: Boolean);\r\nbegin\r\n if FFlat <> Value then\r\n begin\r\n FFlat := Value;\r\n if FFlat then\r\n ControlStyle := ControlStyle - [csOpaque]\r\n else\r\n ControlStyle := ControlStyle + [csOpaque];\r\n RepaintBackground;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomGraphicButton.Notification(AComponent: TComponent;\r\n Operation: TOperation);\r\nbegin\r\n inherited Notification(AComponent, Operation);\r\n if (Operation = opRemove) and (AComponent = DropDownMenu) then\r\n DropDownMenu := nil;\r\nend;\r\n\r\nprocedure TJvCustomGraphicButton.SetDown(Value: Boolean);\r\nbegin\r\n if GroupIndex = 0 then\r\n Value := False;\r\n if FDown <> Value then\r\n begin\r\n if FDown and not AllowAllUp then\r\n Exit;\r\n FDown := Value;\r\n UpdateExclusive;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomGraphicButton.SetForceSameSize(const Value: Boolean);\r\nbegin\r\n if FForceSameSize <> Value then\r\n begin\r\n FForceSameSize := Value;\r\n if FForceSameSize then\r\n SetBounds(Left, Top, Width, Height);\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomGraphicButton.SetBounds(ALeft, ATop, AWidth, AHeight: Integer);\r\nvar\r\n Form: TCustomForm;\r\n Msg: TCMForceSize;\r\nbegin\r\n inherited SetBounds(ALeft, ATop, AWidth, AHeight);\r\n if ForceSameSize then\r\n begin\r\n Form := GetParentForm(Self);\r\n if Assigned(Form) then\r\n begin\r\n Msg.Msg := CM_FORCESIZE;\r\n Msg.Sender := Self;\r\n Msg.NewSize.X := AWidth;\r\n Msg.NewSize.Y := AHeight;\r\n Form.Broadcast(Msg);\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomGraphicButton.CMForceSize(var Msg: TCMForceSize);\r\nbegin\r\n with Msg do\r\n ForceSize(Sender, NewSize.x, NewSize.y);\r\nend;\r\n\r\nfunction TJvCustomGraphicButton.GetPattern: TBitmap;\r\nbegin\r\n Result := CreateBrushPattern;\r\nend;\r\n\r\nprocedure TJvCustomGraphicButton.SetAllowAllUp(const Value: Boolean);\r\nbegin\r\n if FAllowAllUp <> Value then\r\n begin\r\n FAllowAllUp := Value;\r\n UpdateExclusive;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomGraphicButton.SetGroupIndex(const Value: Integer);\r\nbegin\r\n if FGroupIndex <> Value then\r\n begin\r\n FGroupIndex := Value;\r\n UpdateExclusive;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomGraphicButton.UpdateExclusive;\r\nvar\r\n Msg: TCMButtonPressed;\r\nbegin\r\n if (GroupIndex <> 0) and (Parent <> nil) then\r\n begin\r\n Msg.Msg := CM_JVBUTTONPRESSED;\r\n Msg.Index := GroupIndex;\r\n Msg.Control := Self;\r\n Msg.Result := 0;\r\n Parent.Broadcast(Msg);\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomGraphicButton.CMButtonPressed(var Msg: TCMButtonPressed);\r\nbegin\r\n ButtonPressed(TJvCustomGraphicButton(Msg.Control), Msg.Index);\r\nend;\r\n\r\nprocedure TJvCustomGraphicButton.SetHotFont(const Value: TFont);\r\nbegin\r\n FHotFont.Assign(Value);\r\nend;\r\n\r\nprocedure TJvCustomGraphicButton.SetHotTrackFontOptions(const Value: TJvTrackFontOptions);\r\nbegin\r\n if FHotTrackFontOptions <> Value then\r\n begin\r\n FHotTrackFontOptions := Value;\r\n UpdateTrackFont(HotTrackFont, Font, HotTrackFontOptions);\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomGraphicButton.SetDropArrow(const Value: Boolean);\r\nbegin\r\n if FDropArrow <> Value then\r\n begin\r\n FDropArrow := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomGraphicButton.SetDropDownMenu(const Value: TPopupMenu);\r\nbegin\r\n if ReplaceComponentReference(Self, Value, TComponent(FDropDownMenu)) then\r\n if DropArrow then\r\n Invalidate;\r\nend;\r\n\r\n\r\nprocedure TJvCustomGraphicButton.CMSysColorChange(var Msg: TMessage);\r\nbegin\r\n inherited;\r\n RepaintBackground;\r\nend;\r\n\r\n\r\nprocedure TJvCustomGraphicButton.FontChanged;\r\nbegin\r\n inherited FontChanged;\r\n UpdateTrackFont(HotTrackFont, Font, HotTrackFontOptions);\r\nend;\r\n\r\nprocedure TJvCustomGraphicButton.TextChanged;\r\nbegin\r\n inherited TextChanged;\r\n RepaintBackground;\r\nend;\r\n\r\nprocedure TJvCustomGraphicButton.Click;\r\nbegin\r\n if GroupIndex <> 0 then\r\n begin\r\n if AllowAllUp then\r\n Down := not Down\r\n else\r\n Down := True;\r\n end;\r\n try\r\n inherited Click;\r\n except\r\n // Mantis 3097: In case there is an exception, we ensure here that the\r\n // button is not left \"down\", and we reraise the exception as we can't\r\n // handle it and don't want to ignore it.\r\n Exclude(FStates, bsMouseDown);\r\n RepaintBackground;\r\n raise;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomGraphicButton.ButtonPressed(Sender: TJvCustomGraphicButton;\r\n AGroupIndex: Integer);\r\nbegin\r\n if AGroupIndex = GroupIndex then\r\n if Sender <> Self then\r\n begin\r\n if Sender.Down and Down then\r\n begin\r\n FDown := False;\r\n Exclude(FStates, bsMouseDown);\r\n RepaintBackground;\r\n end;\r\n FAllowAllUp := Sender.AllowAllUp;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomGraphicButton.ForceSize(Sender: TControl; AWidth, AHeight: Integer);\r\nbegin\r\n if Sender <> Self then\r\n inherited SetBounds(Left, Top, AWidth, AHeight);\r\nend;\r\n\r\n//=== { TJvCustomButton } ====================================================\r\n\r\nconstructor TJvCustomButton.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FDropArrow := False;\r\n FHotTrack := False;\r\n FHotFont := TFont.Create;\r\n FFontSave := TFont.Create;\r\n // ControlStyle := ControlStyle + [csAcceptsControls];\r\n FWordWrap := True;\r\n FForceSameSize := False;\r\n FHotTrackFontOptions := DefaultTrackFontOptions;\r\nend;\r\n\r\ndestructor TJvCustomButton.Destroy;\r\nbegin\r\n FHotFont.Free;\r\n FFontSave.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvCustomButton.Click;\r\nvar\r\n Tmp: TPoint;\r\nbegin\r\n // Call ClientToScreen before the inherited Click as the OnClick handler might\r\n // reset the parent, which is needed by ClientToScreen.\r\n Tmp := ClientToScreen(Point(0, Height));\r\n\r\n inherited Click;\r\n\r\n DoDropDownMenu(Tmp.X, Tmp.Y);\r\nend;\r\n\r\nprocedure TJvCustomButton.DrawDropArrow(Canvas: TCanvas; ArrowRect: TRect);\r\nvar\r\n I: Integer;\r\nbegin\r\n if not Enabled then\r\n Canvas.Pen.Color := clInactiveCaption\r\n else\r\n Canvas.Pen.Color := clWindowText;\r\n for I := 0 to (ArrowRect.Bottom - ArrowRect.Top) do\r\n begin\r\n if ArrowRect.Left + I <= ArrowRect.Right - I then\r\n begin\r\n Canvas.MoveTo(ArrowRect.Left + I, ArrowRect.Top + I);\r\n Canvas.LineTo(ArrowRect.Right - I, ArrowRect.Top + I);\r\n end;\r\n end;\r\nend;\r\n\r\n\r\n\r\nprocedure TJvCustomButton.CreateParams(var Params: TCreateParams);\r\nbegin\r\n inherited CreateParams(Params);\r\n Params.Style := Params.Style or BS_MULTILINE;\r\nend;\r\n\r\n\r\nprocedure TJvCustomButton.SetHotTrackFontOptions(const Value: TJvTrackFontOptions);\r\nbegin\r\n if FHotTrackFontOptions <> Value then\r\n begin\r\n FHotTrackFontOptions := Value;\r\n UpdateTrackFont(HotTrackFont, Font, HotTrackFontOptions);\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomButton.SetDropArrow(const Value: Boolean);\r\nbegin\r\n if FDropArrow <> Value then\r\n begin\r\n FDropArrow := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomButton.SetHotFont(const Value: TFont);\r\nbegin\r\n FHotFont.Assign(Value);\r\nend;\r\n\r\nprocedure TJvCustomButton.SetDropDownMenu(const Value: TPopupMenu);\r\nbegin\r\n if FDropDownMenu <> Value then\r\n begin\r\n FDropDownMenu := Value;\r\n if DropArrow then\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomButton.MouseEnter(Control: TControl);\r\nbegin\r\n if not MouseOver then\r\n begin\r\n if FHotTrack then\r\n begin\r\n FFontSave.Assign(Font);\r\n Font.Assign(FHotFont);\r\n end;\r\n inherited MouseEnter(Control);\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomButton.MouseLeave(Control: TControl);\r\nbegin\r\n if MouseOver then\r\n begin\r\n if FHotTrack then\r\n Font.Assign(FFontSave);\r\n inherited MouseLeave(Control);\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomButton.FontChanged;\r\nbegin\r\n inherited FontChanged;\r\n UpdateTrackFont(HotTrackFont, Font, HotTrackFontOptions);\r\nend;\r\n\r\nfunction TJvCustomButton.GetRealCaption: string;\r\nbegin\r\n if WordWrap then\r\n Result := StringReplace(Caption, JvBtnLineSeparator, Lf, [rfReplaceAll])\r\n else\r\n Result := Caption;\r\nend;\r\n\r\nprocedure TJvCustomButton.SetWordWrap(const Value: Boolean);\r\nbegin\r\n if FWordWrap <> Value then\r\n begin\r\n FWordWrap := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomButton.SetForceSameSize(const Value: Boolean);\r\nbegin\r\n if FForceSameSize <> Value then\r\n begin\r\n FForceSameSize := Value;\r\n if FForceSameSize then\r\n SetBounds(Left, Top, Width, Height);\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomButton.SetBounds(ALeft, ATop, AWidth, AHeight: Integer);\r\nvar\r\n Form: TCustomForm;\r\n Msg: TCMForceSize;\r\nbegin\r\n inherited SetBounds(ALeft, ATop, AWidth, AHeight);\r\n if ForceSameSize then\r\n begin\r\n Form := GetParentForm(Self);\r\n if Assigned(Form) then\r\n begin\r\n Msg.Msg := CM_FORCESIZE;\r\n Msg.Sender := Self;\r\n Msg.NewSize.X := AWidth;\r\n Msg.NewSize.Y := AHeight;\r\n Form.Broadcast(Msg);\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomButton.CMForceSize(var Msg: TCMForceSize);\r\nbegin\r\n with Msg do\r\n ForceSize(Sender, NewSize.x, NewSize.y);\r\nend;\r\n\r\nprocedure TJvCustomButton.Notification(AComponent: TComponent;\r\n Operation: TOperation);\r\nbegin\r\n inherited Notification(AComponent, Operation);\r\n if (Operation = opRemove) and (AComponent = FDropDownMenu) then\r\n DropDownMenu := nil;\r\nend;\r\n\r\nprocedure TJvCustomGraphicButton.RepaintBackground;\r\nvar\r\n R: TRect;\r\nbegin\r\n if (Parent <> nil) and Parent.HandleAllocated then\r\n begin\r\n R := BoundsRect;\r\n InvalidateRect(Parent.Handle, @R, True);\r\n end;\r\n Repaint;\r\nend;\r\n\r\nprocedure TJvCustomButton.ForceSize(Sender: TControl; AWidth, AHeight: Integer);\r\nbegin\r\n if Sender <> Self then\r\n inherited SetBounds(Left, Top, AWidth, AHeight);\r\nend;\r\n\r\nfunction TJvCustomButton.DoDropDownMenu(X, Y: Integer): Boolean;\r\nvar\r\n Msg: TMsg;\r\n Handled: Boolean;\r\nbegin\r\n Result := (DropDownMenu <> nil);\r\n if Result then\r\n begin\r\n DropDownMenu.PopupComponent := Self;\r\n case DropDownMenu.Alignment of\r\n paRight:\r\n Inc(X, Width);\r\n paCenter:\r\n Inc(X, Width div 2);\r\n end;\r\n Handled := False;\r\n if Assigned(FOnDropDownMenu) then\r\n FOnDropDownMenu(Self, Point(X, Y), Handled);\r\n if not Handled then\r\n DropDownMenu.Popup(X, Y)\r\n else\r\n Exit;\r\n { wait 'til menu is done }\r\n while PeekMessage(Msg, 0, WM_MOUSEFIRST, WM_MOUSELAST, PM_REMOVE) do\r\n {nothing};\r\n end;\r\nend;\r\n\r\n//=== { TJvDropDownButton } ==================================================\r\n\r\nconstructor TJvDropDownButton.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n Width := 16;\r\n Height := 16;\r\nend;\r\n\r\nprocedure TJvDropDownButton.Paint;\r\nvar\r\n PaintRect: TRect;\r\n DrawFlags: Integer;\r\n DC: HDC;\r\n Bmp: TBitmap;\r\nbegin\r\n // adjust FState and FDragging\r\n DC := Canvas.Handle;\r\n Bmp := TBitmap.Create;\r\n try\r\n Bmp.Width := 1;\r\n Bmp.Height := 1;\r\n Canvas.Handle := Bmp.Canvas.Handle;\r\n try\r\n inherited Paint;\r\n finally\r\n Canvas.Handle := DC;\r\n end;\r\n finally\r\n Bmp.Free;\r\n end;\r\n\r\n PaintRect := Rect(0, 0, Width, Height);\r\n DrawFlags := DFCS_SCROLLCOMBOBOX or DFCS_ADJUSTRECT;\r\n if FState in [bsDown, bsExclusive] then\r\n DrawFlags := DrawFlags or DFCS_PUSHED;\r\n\r\n DrawThemedFrameControl(Canvas.Handle, PaintRect, DFC_SCROLL, DrawFlags)\r\nend;\r\n\r\nprocedure TJvCustomGraphicButton.DropDownClose;\r\nbegin\r\n if Assigned(FOnDropDownClose) then\r\n FOnDropDownClose(Self);\r\nend;\r\n\r\ninitialization\r\n {$IFDEF UNITVERSIONING}\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n {$ENDIF UNITVERSIONING}\r\n\r\nfinalization\r\n FreeAndNil(GlobalPattern);\r\n {$IFDEF UNITVERSIONING}\r\n UnregisterUnitVersion(HInstance);\r\n {$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvButtonPersistent.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvButtonPersistent.PAS, released on 2001-02-28.\r\n\r\nThe Initial Developer of the Original Code is Sbastien Buysse [sbuysse att buypin dott com]\r\nPortions created by Sbastien Buysse are Copyright (C) 2001 Sbastien Buysse.\r\nAll Rights Reserved.\r\n\r\nContributor(s): Michael Beck [mbeck att bigfoot dott com]\r\n Dejoy\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvButtonPersistent.pas 12461 2009-08-14 17:21:33Z obones $\r\n\r\nunit JvButtonPersistent;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, Messages,\r\n Classes, Graphics, Controls,\r\n JvTypes, JvHotTrackPersistent;\r\n\r\ntype\r\n\r\n IJvControlProperty = interface(IInterface)\r\n ['{33316D29-0F86-41C4-8DB4-3FE9756158B5}']\r\n function GetCaption: string;\r\n function GetEnabled: Boolean;\r\n function GetFlat: Boolean;\r\n function GetHint: string;\r\n function GetShowHint: Boolean;\r\n function GetVisible: Boolean;\r\n procedure SetCaption(const Value: string);\r\n procedure SetEnabled(const Value: Boolean);\r\n procedure SetFlat(const Value: Boolean);\r\n procedure SetHint(const Value: string);\r\n procedure SetShowHint(const Value: Boolean);\r\n procedure SetVisible(const Value: Boolean);\r\n procedure Assign(Source: IJvControlProperty);\r\n\r\n property Caption: string read GetCaption write SetCaption;\r\n property Enabled: Boolean read GetEnabled write SetEnabled;\r\n property Flat: Boolean read GetFlat write SetFlat;\r\n property Hint: string read GetHint write SetHint;\r\n property ShowHint: Boolean read GetShowHint write SetShowHint;\r\n property Visible: Boolean read GetVisible write SetVisible;\r\n end;\r\n\r\n TJvButtonPersistent = class(TJvCustomHotTrackPersistent\r\n ,IJvControlProperty\r\n )\r\n private\r\n FVisible: Boolean;\r\n FFlat: Boolean;\r\n FEnabled: Boolean;\r\n FCaption: string;\r\n FHint: string;\r\n FShowHint: Boolean;\r\n {IJvControlProperty}\r\n function GetCaption: string;\r\n function GetEnabled: Boolean;\r\n function GetFlat: Boolean;\r\n function GetHint: string;\r\n function GetShowHint: Boolean;\r\n function GetVisible: Boolean;\r\n procedure SetCaption(const Value: string);\r\n procedure SetEnabled(const Value: Boolean);\r\n procedure SetFlat(const Value: Boolean);\r\n procedure SetVisible(const Value: Boolean);\r\n procedure SetHint(const Value: string);\r\n procedure SetShowHint(const Value: Boolean);\r\n\r\n procedure IJvControlProperty_Assign(Source: IJvControlProperty);\r\n procedure IJvControlProperty.Assign = IJvControlProperty_Assign;\r\n public\r\n procedure Assign(Source: TPersistent); override;\r\n procedure AssignTo(Sender: TPersistent); override;\r\n\r\n constructor Create(AOwner: TPersistent); override;\r\n destructor Destroy; override;\r\n published\r\n property Caption: string read GetCaption write SetCaption;\r\n property Enabled: Boolean read GetEnabled write SetEnabled default True;\r\n property Flat: Boolean read GetFlat write SetFlat default True;\r\n property Hint: string read GetHint write SetHint;\r\n property ShowHint: Boolean read GetShowHint write SetShowHint;\r\n property Visible: Boolean read GetVisible write SetVisible default True;\r\n\r\n property HotTrack default True;\r\n property HotTrackFont;\r\n property HotTrackFontOptions;\r\n property HotTrackOptions;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvButtonPersistent.pas $';\r\n Revision: '$Revision: 12461 $';\r\n Date: '$Date: 2009-08-14 19:21:33 +0200 (ven. 14 août 2009) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n SysUtils, StdCtrls, Buttons;\r\n\r\nconstructor TJvButtonPersistent.Create(AOwner: TPersistent);\r\nbegin\r\n inherited Create(AOwner);\r\n HotTrack := True;\r\n FEnabled := True;\r\n FFlat := True;\r\n FVisible := True;\r\nend;\r\n\r\ndestructor TJvButtonPersistent.Destroy;\r\nbegin\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvButtonPersistent.Assign(Source: TPersistent);\r\nvar\r\n intf: IJvControlProperty;\r\nbegin\r\n if Supports(Source, IJvControlProperty, intf) then\r\n IJvControlProperty(Self).Assign(intf);\r\n inherited Assign(Source);\r\nend;\r\n\r\nprocedure TJvButtonPersistent.AssignTo(Sender: TPersistent);\r\nvar\r\n intf : IJvHotTrack;\r\n intf2: IJvControlProperty;\r\nbegin\r\n if Sender is TButton then\r\n begin\r\n if Supports(Sender, IJvControlProperty, intf2) then\r\n intf2.Assign(Self)\r\n else\r\n begin\r\n TButton(Sender).Enabled := Enabled;\r\n TButton(Sender).Visible := Visible;\r\n TButton(Sender).Caption := Caption;\r\n TButton(Sender).Hint := Hint;\r\n TButton(Sender).ShowHint := ShowHint;\r\n end;\r\n if Supports(Sender, IJvHotTrack, intf) then\r\n begin\r\n intf.Assign(Self);\r\n end;\r\n end\r\n else\r\n if Sender is TSpeedButton then\r\n begin\r\n if Supports(Sender, IJvControlProperty, intf2) then\r\n intf2.Assign(Self)\r\n else \r\n begin\r\n TSpeedButton(Sender).Enabled := Enabled;\r\n TSpeedButton(Sender).Visible := Visible;\r\n TSpeedButton(Sender).Caption := Caption;\r\n TSpeedButton(Sender).Hint := Hint;\r\n TSpeedButton(Sender).ShowHint := ShowHint;\r\n TSpeedButton(Sender).Flat := Flat;\r\n end;\r\n if Supports(Sender, IJvHotTrack, intf) then\r\n begin\r\n intf.Assign(Self);\r\n end;\r\n end\r\n else\r\n inherited AssignTo(Sender);\r\nend;\r\n\r\nfunction TJvButtonPersistent.GetCaption: string;\r\nbegin\r\n Result := FCaption;\r\nend;\r\n\r\nfunction TJvButtonPersistent.GetEnabled: Boolean;\r\nbegin\r\n Result := FEnabled;\r\nend;\r\n\r\nfunction TJvButtonPersistent.GetFlat: Boolean;\r\nbegin\r\n Result := FFlat;\r\nend;\r\n\r\nfunction TJvButtonPersistent.GetHint: string;\r\nbegin\r\n Result := FHint;\r\nend;\r\n\r\nfunction TJvButtonPersistent.GetShowHint: Boolean;\r\nbegin\r\n Result := FShowHint;\r\nend;\r\n\r\nfunction TJvButtonPersistent.GetVisible: Boolean;\r\nbegin\r\n Result := FVisible;\r\nend;\r\n\r\nprocedure TJvButtonPersistent.SetCaption(const Value: string);\r\nbegin\r\n if FCaption <> Value then\r\n begin\r\n Changing;\r\n ChangingProperty('Caption');\r\n FCaption := Value;\r\n ChangedProperty('Caption');\r\n Changed;\r\n end;\r\nend;\r\n\r\nprocedure TJvButtonPersistent.SetEnabled(const Value: Boolean);\r\nbegin\r\n if FEnabled <> Value then\r\n begin\r\n Changing;\r\n ChangingProperty('Enabled');\r\n FEnabled := Value;\r\n ChangedProperty('Enabled');\r\n Changed;\r\n end;\r\nend;\r\n\r\nprocedure TJvButtonPersistent.SetFlat(const Value: Boolean);\r\nbegin\r\n if FFlat <> Value then\r\n begin\r\n Changing;\r\n ChangingProperty('Flat');\r\n FFlat := Value;\r\n ChangedProperty('Flat');\r\n Changed;\r\n end;\r\nend;\r\n\r\nprocedure TJvButtonPersistent.SetHint(const Value: string);\r\nbegin\r\n if FHint <> Value then\r\n begin\r\n Changing;\r\n ChangingProperty('Hint');\r\n FHint := Value;\r\n ChangedProperty('Hint');\r\n Changed;\r\n end;\r\nend;\r\n\r\nprocedure TJvButtonPersistent.SetShowHint(const Value: Boolean);\r\nbegin\r\n if FShowHint <> Value then\r\n begin\r\n Changing;\r\n ChangingProperty('ShowHint');\r\n FShowHint := Value;\r\n ChangedProperty('ShowHint');\r\n Changed;\r\n end;\r\nend;\r\n\r\nprocedure TJvButtonPersistent.SetVisible(const Value: Boolean);\r\nbegin\r\n if FVisible <> Value then\r\n begin\r\n Changing;\r\n ChangingProperty('Visible');\r\n FVisible := Value;\r\n ChangedProperty('Visible');\r\n Changed;\r\n end;\r\nend;\r\n\r\nprocedure TJvButtonPersistent.IJvControlProperty_Assign(\r\n Source: IJvControlProperty);\r\nbegin\r\n if (Source <> nil) and (IJvControlProperty(Self) <> Source) then\r\n begin\r\n BeginUpdate;\r\n try\r\n Caption := Source.Caption;\r\n Enabled := Source.Enabled;\r\n Flat := Source.Flat;\r\n Hint := Source.Hint;\r\n ShowHint := Source.ShowHint;\r\n Visible := Source.Visible;\r\n finally\r\n EndUpdate;\r\n end; \r\n end;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n\r\n" }, { "path": "External/Jedi/Jvcl/run/JvButtons.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvButtons.PAS, released on 2002-07-04.\r\n\r\nThe Initial Developers of the Original Code are: Andrei Prygounkov \r\nCopyright (c) 1999, 2002 Andrei Prygounkov\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\n Andreas Hausladen\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\n components : TJvaCaptionButton,\r\n TJvaColorButton,\r\n TJvNoFrameButton,\r\n TJvHTButton\r\n description : Buttons\r\n\r\nKnown Issues:\r\nMaciej Kaczkowski:\r\n [X] Height of JvHTComboBox - on design time you cannot use mouse for resize\r\n [X] alignment not work correctly on JvHTButtonGlyph\r\n [X] not tested on BCB & Kylix\r\n\r\nCreate label with caption:\r\nItem 1 bold underline
red green blue
Item 2 italic ITALIC strikeout STRIKEOUT

red with yellow background white navy\r\n\r\nSome information about coding:\r\n[?] If you want use few times function you must use before next \r\n function
\r\n[?] After
must be
\r\n\r\nChanges:\r\n========\r\nMaciej Kaczkowski:\r\n [+]
- new line\r\n [+]
- horizontal line\r\n [+] and - StrikeOut\r\n [+] Multiline for JvHTListBox, JvHTComboBox\r\n TJvHTButton\r\n [+] You can change Height of JvHTComboBox\r\n [+] Tags: & " ® © ™\r\n   < >\r\n [+] \r\n [*] was changed to ex.:\r\n \r\n \r\n [*] procedure ItemHtDrawEx - rewrited\r\n [*] function ItemHtPlain - optimized\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvButtons.pas 13260 2012-02-28 15:37:13Z obones $\r\n\r\nunit JvButtons;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, Messages,\r\n Classes, Graphics, Controls, Forms, Buttons, ExtCtrls,\r\n JvWndProcHook,\r\n JvJCLUtils, JvComponentBase, JvExButtons;\r\n\r\ntype\r\n { VCL Buttons unit does not publish TJvButtonGlyph class,\r\n so we do it for other programers (Delphi 3 version) }\r\n TJvButtonGlyph = class(TObject)\r\n private\r\n FGlyphList: TImageList;\r\n FIndexs: array [TButtonState] of Integer;\r\n FTransparentColor: TColor;\r\n FNumGlyphs: TNumGlyphs;\r\n FOnChange: TNotifyEvent;\r\n FColor: TColor;\r\n FBiDiMode: TBiDiMode; {o}\r\n FParentBiDiMode: Boolean;\r\n procedure SetBiDiMode(Value: TBiDiMode);\r\n procedure SetParentBiDiMode(Value: Boolean);\r\n procedure GlyphChanged(Sender: TObject);\r\n procedure SetGlyph(Value: TBitmap);\r\n procedure SetNumGlyphs(Value: TNumGlyphs);\r\n procedure SetColor(Value: TColor);\r\n procedure Invalidate;\r\n function CreateButtonGlyph(State: TButtonState): Integer;\r\n procedure DrawButtonGlyph(Canvas: TCanvas; const GlyphPos: TPoint;\r\n State: TButtonState; Transparent: Boolean);\r\n procedure DrawButtonText(Canvas: TCanvas; const Caption: string;\r\n TextBounds: TRect; State: TButtonState); virtual;\r\n procedure CalcButtonLayout(Canvas: TCanvas; const Client: TRect;\r\n const AOffset: TPoint; const Caption: string; Layout: TButtonLayout;\r\n Margin, Spacing: Integer; var GlyphPos: TPoint; var TextBounds: TRect);\r\n protected\r\n FOriginal: TBitmap;\r\n procedure CalcTextRect(Canvas: TCanvas; var TextRect: TRect; const Caption: string); virtual;\r\n public\r\n constructor Create;\r\n destructor Destroy; override;\r\n { return the text rectangle }\r\n function Draw(Canvas: TCanvas; const Client: TRect; const Offset: TPoint;\r\n const Caption: string; Layout: TButtonLayout; Margin, Spacing: Integer;\r\n State: TButtonState; Transparent: Boolean): TRect;\r\n { DrawExternal draws any glyph (not glyph property) -\r\n if you don't needed to save previous glyph set IgnoreOld to True -\r\n this increases performance }\r\n function DrawExternal(AGlyph: TBitmap; ANumGlyphs: TNumGlyphs; AColor: TColor; IgnoreOld: Boolean;\r\n Canvas: TCanvas; const Client: TRect; const Offset: TPoint; const Caption: string;\r\n Layout: TButtonLayout; Margin, Spacing: Integer; State: TButtonState; Transparent: Boolean): TRect;\r\n property BiDiMode: TBiDiMode read FBiDiMode write SetBiDiMode;\r\n property ParentBiDiMode: Boolean read FParentBiDiMode write SetParentBiDiMode;\r\n property Glyph: TBitmap read FOriginal write SetGlyph;\r\n property NumGlyphs: TNumGlyphs read FNumGlyphs write SetNumGlyphs;\r\n property Color: TColor read FColor write SetColor;\r\n property OnChange: TNotifyEvent read FOnChange write FOnChange;\r\n end;\r\n\r\n TJvHTButton = class;\r\n\r\n TJvHTButtonGlyph = class(TJvButtonGlyph)\r\n private\r\n FOwner: TJvHTButton;\r\n procedure DrawButtonText(Canvas: TCanvas; const Caption: string;\r\n TextBounds: TRect; State: TButtonState); override;\r\n protected\r\n procedure CalcTextRect(Canvas: TCanvas; var TextRect: TRect; const Caption: string); override;\r\n public\r\n constructor Create(AOwner: TJvHTButton); \r\n end;\r\n\r\n TJvaCaptionButton = class(TJvComponent)\r\n private\r\n FGlyph: TJvButtonGlyph;\r\n FCaption: string;\r\n FLayout: TButtonLayout;\r\n FSpacing: Integer;\r\n FMargin: Integer;\r\n FRect: TRect;\r\n FMouseLButtonDown: Boolean;\r\n FPress: Boolean;\r\n FOnClick: TNotifyEvent;\r\n FBPos: Integer;\r\n FWidth: Integer;\r\n WHook: TJvWindowHook;\r\n FActive: Boolean;\r\n FFont: TFont;\r\n FVisible: Boolean;\r\n procedure DoBeforeMsg(Sender: TObject; var Msg: TMessage; var Handled: Boolean);\r\n procedure DoAfterMsg(Sender: TObject; var Msg: TMessage; var Handled: Boolean);\r\n// procedure HookWndProc(var Msg: TMessage);\r\n procedure Draw;\r\n function MouseOnButton(X, Y: Integer): Boolean;\r\n procedure Resize;\r\n procedure GlyphChanged(Sender: TObject);\r\n\r\n function GetHeight: Integer;\r\n function GetWidth: Integer;\r\n function GetLeft: Integer;\r\n\r\n procedure SetCaption(Value: string);\r\n function IsCaptionStored: Boolean;\r\n function GetGlyph: TBitmap;\r\n procedure SetGlyph(Value: TBitmap);\r\n function GetNumGlyphs: TNumGlyphs;\r\n procedure SetNumGlyphs(Value: TNumGlyphs);\r\n procedure SetBPos(const Value: Integer);\r\n procedure SetLayout(Value: TButtonLayout);\r\n procedure SetSpacing(Value: Integer);\r\n procedure SetMargin(Value: Integer);\r\n procedure SetWidth(const Value: Integer);\r\n procedure SetFont(Value: TFont);\r\n procedure FontChange(Sender: TObject);\r\n procedure SetDown(const Value: Boolean);\r\n procedure SetVisible(const Value: Boolean);\r\n protected\r\n FState: TButtonState;\r\n function CalcOffset: TPoint;\r\n procedure Changed; dynamic;\r\n function BorderStyle: TFormBorderStyle;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n procedure Click; dynamic;\r\n procedure Update;\r\n published\r\n property Position: Integer read FBPos write SetBPos;\r\n property Spacing: Integer read FSpacing write SetSpacing default 4;\r\n property Layout: TButtonLayout read FLayout write SetLayout default blGlyphLeft;\r\n property Margin: Integer read FMargin write SetMargin default -1;\r\n property Caption: string read FCaption write SetCaption stored IsCaptionStored;\r\n property Width: Integer read FWidth write SetWidth default -1;\r\n property Font: TFont read FFont write SetFont;\r\n property Glyph: TBitmap read GetGlyph write SetGlyph;\r\n property NumGlyphs: TNumGlyphs read GetNumGlyphs write SetNumGlyphs default 1;\r\n property Down: Boolean read FPress write SetDown default False;\r\n property Visible: Boolean read FVisible write SetVisible default True;\r\n property OnClick: TNotifyEvent read FOnClick write FOnClick;\r\n end;\r\n\r\n TPaintButtonEvent = procedure(Sender: TObject; IsDown, IsDefault: Boolean; State: TButtonState) of object;\r\n\r\n TJvaColorButton = class(TJvExBitBtn)\r\n private\r\n FGlyphDrawer: TJvButtonGlyph;\r\n FOnPaint: TPaintButtonEvent;\r\n FCanvas: TControlCanvas ;\r\n function GetCanvas: TCanvas;\r\n procedure CNDrawItem(var Msg: TWMDrawItem); message CN_DRAWITEM;\r\n protected\r\n IsFocused: Boolean;\r\n procedure SetButtonStyle(ADefault: Boolean); override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n procedure DefaultDrawing(const IsDown, IsDefault: Boolean; const State: TButtonState);\r\n property Canvas: TCanvas read GetCanvas;\r\n published\r\n property Color;\r\n property ParentColor;\r\n property OnPaint: TPaintButtonEvent read FOnPaint write FOnPaint;\r\n end;\r\n\r\n TJvNoFrameButton = class(TJvExSpeedButton)\r\n private\r\n FGlyphDrawer: TJvButtonGlyph;\r\n FNoBorder: Boolean;\r\n FOnPaint: TPaintButtonEvent;\r\n FRepeatedClick: Boolean;\r\n FRepeatTimer: TTimer;\r\n FInitRepeatPause: Integer;\r\n FRepeatPause: Integer;\r\n FClicked: Boolean;\r\n procedure SetNoBorder(Value: Boolean);\r\n procedure TimerExpired(Sender: TObject);\r\n protected\r\n procedure Paint; override;\r\n procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X: Integer; Y: Integer); override;\r\n procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X: Integer; Y: Integer); override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n procedure DefaultDrawing(const IsDown: Boolean; const State: TButtonState);\r\n property Canvas;\r\n published\r\n property Color;\r\n property ParentColor;\r\n property NoBorder: Boolean read FNoBorder write SetNoBorder default True;\r\n property RepeatedClick: Boolean read FRepeatedClick write FRepeatedClick default False;\r\n property InitRepeatPause: Integer read FInitRepeatPause write FInitRepeatPause default 400;\r\n property RepeatPause: Integer read FRepeatPause write FRepeatPause default 100;\r\n property OnPaint: TPaintButtonEvent read FOnPaint write FOnPaint;\r\n end;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvHTButton = class(TJvaColorButton)\r\n private\r\n FSuperSubScriptRatio: Double;\r\n function ISuperSuperSubScriptRatioStored: Boolean;\r\n procedure SetSuperSubScriptRation(const Value: Double);\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n published\r\n property SuperSubScriptRatio: Double read FSuperSubScriptRatio write SetSuperSubScriptRation stored ISuperSuperSubScriptRatioStored;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvButtons.pas $';\r\n Revision: '$Revision: 13260 $';\r\n Date: '$Date: 2012-02-28 16:37:13 +0100 (mar. 28 févr. 2012) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n CommCtrl,\r\n SysUtils, Math,\r\n JvHtControls, JvDsgnIntf, JvConsts, JvResources, JvTypes, JvThemes;\r\n\r\ntype\r\n TJvGlyphList = class(TImageList)\r\n private\r\n FUsed: TBits;\r\n FCount: Integer;\r\n function AllocateIndex: Integer;\r\n public\r\n constructor CreateSize(AWidth, AHeight: Integer);\r\n destructor Destroy; override;\r\n function AddMasked(Image: TBitmap; MaskColor: TColor): Integer;\r\n procedure Delete(Index: Integer);\r\n property Count: Integer read FCount;\r\n end;\r\n\r\n TJvGlyphCache = class(TObject)\r\n private\r\n FGlyphLists: TList;\r\n public\r\n constructor Create;\r\n destructor Destroy; override;\r\n function GetList(AWidth, AHeight: Integer): TJvGlyphList;\r\n procedure ReturnList(List: TJvGlyphList);\r\n function Empty: Boolean;\r\n end;\r\n\r\n//=== { TJvGlyphList } =======================================================\r\n\r\nconstructor TJvGlyphList.CreateSize(AWidth, AHeight: Integer);\r\nbegin\r\n inherited CreateSize(AWidth, AHeight);\r\n FUsed := TBits.Create;\r\nend;\r\n\r\ndestructor TJvGlyphList.Destroy;\r\nbegin\r\n FUsed.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJvGlyphList.AllocateIndex: Integer;\r\nbegin\r\n Result := FUsed.OpenBit;\r\n if Result >= FUsed.Size then\r\n begin\r\n Result := inherited Add(nil, nil);\r\n FUsed.Size := Result + 1;\r\n end;\r\n FUsed[Result] := True;\r\nend;\r\n\r\nfunction TJvGlyphList.AddMasked(Image: TBitmap; MaskColor: TColor): Integer;\r\nbegin\r\n Result := AllocateIndex;\r\n ReplaceMasked(Result, Image, MaskColor);\r\n Inc(FCount);\r\nend;\r\n\r\nprocedure TJvGlyphList.Delete(Index: Integer);\r\nbegin\r\n if FUsed[Index] then\r\n begin\r\n Dec(FCount);\r\n FUsed[Index] := False;\r\n end;\r\nend;\r\n\r\n//=== { TJvGlyphCache } ======================================================\r\n\r\nconstructor TJvGlyphCache.Create;\r\nbegin\r\n inherited Create;\r\n FGlyphLists := TList.Create;\r\nend;\r\n\r\ndestructor TJvGlyphCache.Destroy;\r\nbegin\r\n FGlyphLists.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJvGlyphCache.GetList(AWidth, AHeight: Integer): TJvGlyphList;\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := FGlyphLists.Count - 1 downto 0 do\r\n begin\r\n Result := FGlyphLists[I];\r\n if (AWidth = Result.Width) and (AHeight = Result.Height) then\r\n Exit;\r\n end;\r\n Result := TJvGlyphList.CreateSize(AWidth, AHeight);\r\n FGlyphLists.Add(Result);\r\nend;\r\n\r\nprocedure TJvGlyphCache.ReturnList(List: TJvGlyphList);\r\nbegin\r\n if List = nil then\r\n Exit;\r\n if List.Count = 0 then\r\n begin\r\n FGlyphLists.Remove(List);\r\n List.Free;\r\n end;\r\nend;\r\n\r\nfunction TJvGlyphCache.Empty: Boolean;\r\nbegin\r\n Result := FGlyphLists.Count = 0;\r\nend;\r\n\r\n//=== { TJvButtonGlyph } =====================================================\r\n\r\nvar\r\n GlyphCache: TJvGlyphCache = nil;\r\n Pattern: TBitmap = nil;\r\n\r\nprocedure CreateBrushPattern(FaceColor, HighLightColor: TColor);\r\nvar\r\n X, Y: Integer;\r\nbegin\r\n Pattern := TBitmap.Create;\r\n Pattern.Width := 8;\r\n Pattern.Height := 8;\r\n with Pattern.Canvas do\r\n begin\r\n Brush.Style := bsSolid;\r\n Brush.Color := FaceColor; // clBtnFace\r\n FillRect(Rect(0, 0, Pattern.Width, Pattern.Height));\r\n for Y := 0 to 7 do\r\n for X := 0 to 7 do\r\n if (Y mod 2) = (X mod 2) then { toggles between even/odd pixels }\r\n Pixels[X, Y] := HighLightColor; {clBtnHighlight}; { on even/odd rows }\r\n end;\r\nend;\r\n\r\nconstructor TJvButtonGlyph.Create;\r\nvar\r\n I: TButtonState;\r\nbegin\r\n inherited Create;\r\n FOriginal := TBitmap.Create;\r\n FOriginal.OnChange := GlyphChanged;\r\n FTransparentColor := clOlive;\r\n FNumGlyphs := 1;\r\n for I := Low(I) to High(I) do\r\n FIndexs[I] := -1;\r\n if GlyphCache = nil then\r\n GlyphCache := TJvGlyphCache.Create;\r\nend;\r\n\r\ndestructor TJvButtonGlyph.Destroy;\r\nbegin\r\n FOriginal.Free;\r\n Invalidate;\r\n if Assigned(GlyphCache) and GlyphCache.Empty then\r\n begin\r\n GlyphCache.Free;\r\n GlyphCache := nil;\r\n end;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvButtonGlyph.Invalidate;\r\nvar\r\n I: TButtonState;\r\nbegin\r\n for I := Low(I) to High(I) do\r\n begin\r\n if FIndexs[I] <> -1 then\r\n TJvGlyphList(FGlyphList).Delete(FIndexs[I]);\r\n FIndexs[I] := -1;\r\n end;\r\n GlyphCache.ReturnList(TJvGlyphList(FGlyphList));\r\n FGlyphList := nil;\r\nend;\r\n\r\nprocedure TJvButtonGlyph.GlyphChanged(Sender: TObject);\r\nbegin\r\n if Sender = FOriginal then\r\n begin\r\n FTransparentColor := FOriginal.TransparentColor;\r\n Invalidate;\r\n if Assigned(FOnChange) then\r\n FOnChange(Self);\r\n end;\r\nend;\r\n\r\nprocedure TJvButtonGlyph.SetBiDiMode(Value: TBiDiMode);\r\nbegin\r\n if FBiDiMode <> Value then\r\n begin\r\n FBiDiMode := Value;\r\n FParentBiDiMode := False;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvButtonGlyph.SetParentBiDiMode(Value: Boolean);\r\nbegin\r\n if FParentBiDiMode <> Value then\r\n begin\r\n FParentBiDiMode := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvButtonGlyph.SetGlyph(Value: TBitmap);\r\nvar\r\n Glyphs: Integer;\r\nbegin\r\n Invalidate;\r\n FOriginal.Assign(Value);\r\n if (Value <> nil) and (Value.Height > 0) then\r\n begin\r\n FTransparentColor := Value.TransparentColor;\r\n if Value.Width mod Value.Height = 0 then\r\n begin\r\n Glyphs := Value.Width div Value.Height;\r\n if Glyphs > 4 then\r\n Glyphs := 1;\r\n SetNumGlyphs(Glyphs);\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvButtonGlyph.SetNumGlyphs(Value: TNumGlyphs);\r\nbegin\r\n if (Value <> FNumGlyphs) and (Value > 0) then\r\n begin\r\n Invalidate;\r\n FNumGlyphs := Value;\r\n GlyphChanged(Glyph);\r\n end;\r\nend;\r\n\r\nprocedure TJvButtonGlyph.SetColor(Value: TColor);\r\nbegin\r\n if FColor <> Value then\r\n begin\r\n FColor := Value;\r\n GlyphChanged(Glyph);\r\n end;\r\nend;\r\n\r\nfunction TJvButtonGlyph.CreateButtonGlyph(State: TButtonState): Integer;\r\nvar\r\n TmpImage, DDB, MonoBmp: TBitmap;\r\n IWidth, IHeight: Integer;\r\n IRect, ORect: TRect;\r\n I: TButtonState;\r\n DestDC: HDC;\r\nbegin\r\n if (State = bsDown) and (NumGlyphs < 3) then\r\n State := bsUp;\r\n Result := FIndexs[State];\r\n if Result <> -1 then\r\n Exit;\r\n if (FOriginal.Width or FOriginal.Height) = 0 then\r\n Exit;\r\n IWidth := FOriginal.Width div FNumGlyphs;\r\n IHeight := FOriginal.Height;\r\n if FGlyphList = nil then\r\n begin\r\n if GlyphCache = nil then\r\n GlyphCache := TJvGlyphCache.Create;\r\n FGlyphList := GlyphCache.GetList(IWidth, IHeight);\r\n end;\r\n TmpImage := TBitmap.Create;\r\n try\r\n TmpImage.Width := IWidth;\r\n TmpImage.Height := IHeight;\r\n IRect := Rect(0, 0, IWidth, IHeight);\r\n TmpImage.Canvas.Brush.Color := Color {clBtnFace};\r\n TmpImage.Palette := CopyPalette(FOriginal.Palette);\r\n I := State;\r\n if Ord(I) >= NumGlyphs then\r\n I := bsUp;\r\n ORect := Rect(Ord(I) * IWidth, 0, (Ord(I) + 1) * IWidth, IHeight);\r\n case State of\r\n bsUp, bsDown,\r\n bsExclusive:\r\n begin\r\n TmpImage.Canvas.CopyRect(IRect, FOriginal.Canvas, ORect);\r\n if FOriginal.TransparentMode = tmFixed then\r\n FIndexs[State] := TJvGlyphList(FGlyphList).AddMasked(TmpImage, FTransparentColor)\r\n else\r\n FIndexs[State] := TJvGlyphList(FGlyphList).AddMasked(TmpImage, clDefault);\r\n end;\r\n bsDisabled:\r\n begin\r\n MonoBmp := nil;\r\n DDB := nil;\r\n try\r\n MonoBmp := TBitmap.Create;\r\n DDB := TBitmap.Create;\r\n DDB.Assign(FOriginal);\r\n DDB.HandleType := bmDDB;\r\n if NumGlyphs > 1 then\r\n with TmpImage.Canvas do\r\n begin { Change white & gray to clBtnHighlight and clBtnShadow }\r\n CopyRect(IRect, DDB.Canvas, ORect);\r\n MonoBmp.Monochrome := True;\r\n MonoBmp.Width := IWidth;\r\n MonoBmp.Height := IHeight;\r\n\r\n { Convert white to clBtnHighlight }\r\n DDB.Canvas.Brush.Color := clWhite;\r\n MonoBmp.Canvas.CopyRect(IRect, DDB.Canvas, ORect);\r\n Brush.Color := clBtnHighlight;\r\n DestDC := Handle;\r\n SetTextColor(DestDC, clBlack);\r\n SetBkColor(DestDC, clWhite);\r\n BitBlt(DestDC, 0, 0, IWidth, IHeight,\r\n MonoBmp.Canvas.Handle, 0, 0, ROP_DSPDxax);\r\n\r\n { Convert gray to clBtnShadow }\r\n DDB.Canvas.Brush.Color := clGray;\r\n MonoBmp.Canvas.CopyRect(IRect, DDB.Canvas, ORect);\r\n Brush.Color := clBtnShadow;\r\n DestDC := Handle;\r\n SetTextColor(DestDC, clBlack);\r\n SetBkColor(DestDC, clWhite);\r\n BitBlt(DestDC, 0, 0, IWidth, IHeight,\r\n MonoBmp.Canvas.Handle, 0, 0, ROP_DSPDxax);\r\n\r\n { Convert transparent color to clBtnFace }\r\n DDB.Canvas.Brush.Color := ColorToRGB(FTransparentColor);\r\n MonoBmp.Canvas.CopyRect(IRect, DDB.Canvas, ORect);\r\n Brush.Color := Color {clBtnFace};\r\n DestDC := Handle;\r\n SetTextColor(DestDC, clBlack);\r\n SetBkColor(DestDC, clWhite);\r\n BitBlt(DestDC, 0, 0, IWidth, IHeight,\r\n MonoBmp.Canvas.Handle, 0, 0, ROP_DSPDxax);\r\n end\r\n else\r\n begin\r\n { Create a disabled version }\r\n with MonoBmp do\r\n begin\r\n Assign(FOriginal);\r\n HandleType := bmDDB;\r\n Canvas.Brush.Color := clBlack;\r\n Width := IWidth;\r\n if Monochrome then\r\n begin\r\n Canvas.Font.Color := clWhite;\r\n Monochrome := False;\r\n Canvas.Brush.Color := clWhite;\r\n end;\r\n Monochrome := True;\r\n end;\r\n with TmpImage.Canvas do\r\n begin\r\n Brush.Color := Color {clBtnFace};\r\n FillRect(IRect);\r\n Brush.Color := clBtnHighlight;\r\n SetTextColor(Handle, clBlack);\r\n SetBkColor(Handle, clWhite);\r\n BitBlt(Handle, 1, 1, IWidth, IHeight,\r\n MonoBmp.Canvas.Handle, 0, 0, ROP_DSPDxax);\r\n Brush.Color := clBtnShadow;\r\n SetTextColor(Handle, clBlack);\r\n SetBkColor(Handle, clWhite);\r\n BitBlt(Handle, 0, 0, IWidth, IHeight,\r\n MonoBmp.Canvas.Handle, 0, 0, ROP_DSPDxax);\r\n end;\r\n end;\r\n finally\r\n DDB.Free;\r\n MonoBmp.Free;\r\n end;\r\n FIndexs[State] := TJvGlyphList(FGlyphList).AddMasked(TmpImage, clDefault);\r\n end;\r\n end;\r\n finally\r\n TmpImage.Free;\r\n end;\r\n Result := FIndexs[State];\r\n FOriginal.Dormant;\r\nend;\r\n\r\nprocedure TJvButtonGlyph.DrawButtonGlyph(Canvas: TCanvas; const GlyphPos: TPoint;\r\n State: TButtonState; Transparent: Boolean);\r\nvar\r\n Index: Integer;\r\nbegin\r\n if FOriginal = nil then\r\n Exit;\r\n if (FOriginal.Width = 0) or (FOriginal.Height = 0) then\r\n Exit;\r\n Index := CreateButtonGlyph(State);\r\n if Transparent or (State = bsExclusive) then\r\n ImageList_DrawEx(FGlyphList.Handle, Index, Canvas.Handle, GlyphPos.X, GlyphPos.Y, 0, 0,\r\n clNone, clNone, ILD_Transparent)\r\n else\r\n ImageList_DrawEx(FGlyphList.Handle, Index, Canvas.Handle, GlyphPos.X, GlyphPos.Y, 0, 0,\r\n ColorToRGB(Color {clBtnFace}), clNone, ILD_Normal);\r\nend;\r\n\r\nprocedure TJvButtonGlyph.DrawButtonText(Canvas: TCanvas; const Caption: string;\r\n TextBounds: TRect; State: TButtonState);\r\nvar\r\n Flags: Longint;\r\nbegin\r\n Flags := 0;\r\n if FBiDiMode <> bdLeftToRight then\r\n Flags := DT_RTLREADING;\r\n with Canvas do\r\n begin\r\n Brush.Style := bsClear;\r\n if State = bsDisabled then\r\n begin\r\n OffsetRect(TextBounds, 1, 1);\r\n Font.Color := clBtnHighlight;\r\n DrawText(Canvas, Caption, Length(Caption), TextBounds, Flags);\r\n OffsetRect(TextBounds, -1, -1);\r\n Font.Color := clBtnShadow;\r\n DrawText(Canvas, Caption, Length(Caption), TextBounds, Flags);\r\n end\r\n else\r\n DrawText(Canvas, Caption, Length(Caption), TextBounds,\r\n DT_CENTER or DT_VCENTER or DT_SINGLELINE or Flags);\r\n end;\r\nend;\r\n\r\nprocedure TJvButtonGlyph.CalcButtonLayout(Canvas: TCanvas; const Client: TRect;\r\n const AOffset: TPoint; const Caption: string; Layout: TButtonLayout; Margin,\r\n Spacing: Integer; var GlyphPos: TPoint; var TextBounds: TRect);\r\nvar\r\n TextPos: TPoint;\r\n ClientSize, GlyphSize, TextSize: TPoint;\r\n TotalSize: TPoint;\r\nbegin\r\n { calculate the item sizes }\r\n ClientSize := Point(Client.Right - Client.Left, Client.Bottom - Client.Top);\r\n\r\n if FOriginal <> nil then\r\n GlyphSize := Point(FOriginal.Width div FNumGlyphs, FOriginal.Height)\r\n else\r\n GlyphSize := Point(0, 0);\r\n\r\n if Caption <> '' then\r\n begin\r\n CalcTextRect(Canvas, TextBounds, Caption);\r\n TextSize := Point(TextBounds.Right - TextBounds.Left, TextBounds.Bottom - TextBounds.Top);\r\n end\r\n else\r\n begin\r\n TextBounds := Rect(0, 0, 0, 0);\r\n TextSize := Point(0, 0);\r\n end;\r\n\r\n { If the layout has the glyph on the right or the left, then both the\r\n text and the glyph are centered vertically. If the glyph is on the top\r\n or the bottom, then both the text and the glyph are centered horizontally.}\r\n if Layout in [blGlyphLeft, blGlyphRight] then\r\n begin\r\n GlyphPos.Y := (ClientSize.Y - GlyphSize.Y + 1) div 2;\r\n TextPos.Y := (ClientSize.Y - TextSize.Y + 1) div 2;\r\n end\r\n else\r\n begin\r\n GlyphPos.X := (ClientSize.X - GlyphSize.X + 1) div 2;\r\n TextPos.X := (ClientSize.X - TextSize.X + 1) div 2;\r\n end;\r\n\r\n { if there is no text or no bitmap, then Spacing is irrelevant }\r\n if (TextSize.X = 0) or (GlyphSize.X = 0) then\r\n Spacing := 0;\r\n\r\n { adjust Margin and Spacing }\r\n if Margin = -1 then\r\n begin\r\n if Spacing = -1 then\r\n begin\r\n TotalSize := Point(GlyphSize.X + TextSize.X, GlyphSize.Y + TextSize.Y);\r\n if Layout in [blGlyphLeft, blGlyphRight] then\r\n Margin := (ClientSize.X - TotalSize.X) div 3\r\n else\r\n Margin := (ClientSize.Y - TotalSize.Y) div 3;\r\n Spacing := Margin;\r\n end\r\n else\r\n begin\r\n TotalSize := Point(GlyphSize.X + Spacing + TextSize.X, GlyphSize.Y + Spacing + TextSize.Y);\r\n if Layout in [blGlyphLeft, blGlyphRight] then\r\n Margin := (ClientSize.X - TotalSize.X + 1) div 2\r\n else\r\n Margin := (ClientSize.Y - TotalSize.Y + 1) div 2;\r\n end;\r\n end\r\n else\r\n begin\r\n if Spacing = -1 then\r\n begin\r\n TotalSize := Point(ClientSize.X - (Margin + GlyphSize.X), ClientSize.Y -\r\n (Margin + GlyphSize.Y));\r\n if Layout in [blGlyphLeft, blGlyphRight] then\r\n Spacing := (TotalSize.X - TextSize.X) div 2\r\n else\r\n Spacing := (TotalSize.Y - TextSize.Y) div 2;\r\n end;\r\n end;\r\n\r\n case Layout of\r\n blGlyphLeft:\r\n begin\r\n GlyphPos.X := Margin;\r\n TextPos.X := GlyphPos.X + GlyphSize.X + Spacing;\r\n end;\r\n blGlyphRight:\r\n begin\r\n GlyphPos.X := ClientSize.X - Margin - GlyphSize.X;\r\n TextPos.X := GlyphPos.X - Spacing - TextSize.X;\r\n end;\r\n blGlyphTop:\r\n begin\r\n GlyphPos.Y := Margin;\r\n TextPos.Y := GlyphPos.Y + GlyphSize.Y + Spacing;\r\n end;\r\n blGlyphBottom:\r\n begin\r\n GlyphPos.Y := ClientSize.Y - Margin - GlyphSize.Y;\r\n TextPos.Y := GlyphPos.Y - Spacing - TextSize.Y;\r\n end;\r\n end;\r\n\r\n { fixup the result variables }\r\n Inc(GlyphPos.X, Client.Left + AOffset.X);\r\n Inc(GlyphPos.Y, Client.Top + AOffset.Y);\r\n OffsetRect(TextBounds, TextPos.X + Client.Left + AOffset.X,\r\n TextPos.Y + Client.Top + AOffset.Y);\r\nend;\r\n\r\nfunction TJvButtonGlyph.Draw(Canvas: TCanvas; const Client: TRect;\r\n const Offset: TPoint; const Caption: string; Layout: TButtonLayout;\r\n Margin, Spacing: Integer; State: TButtonState; Transparent: Boolean): TRect;\r\nvar\r\n GlyphPos: TPoint;\r\nbegin\r\n CalcButtonLayout(Canvas, Client, Offset, Caption, Layout, Margin, Spacing,\r\n GlyphPos, Result);\r\n DrawButtonGlyph(Canvas, GlyphPos, State, Transparent);\r\n DrawButtonText(Canvas, Caption, Result, State);\r\nend;\r\n\r\nfunction TJvButtonGlyph.DrawExternal(AGlyph: TBitmap; ANumGlyphs: TNumGlyphs; AColor: TColor; IgnoreOld: Boolean;\r\n Canvas: TCanvas; const Client: TRect; const Offset: TPoint; const Caption: string;\r\n Layout: TButtonLayout; Margin, Spacing: Integer; State: TButtonState; Transparent: Boolean): TRect;\r\nvar\r\n OldGlyph: TBitmap;\r\n OldNumGlyphs: TNumGlyphs;\r\n OldColor: TColor;\r\nbegin\r\n OldGlyph := FOriginal;\r\n OldNumGlyphs := NumGlyphs;\r\n OldColor := FColor;\r\n try\r\n FOriginal := AGlyph;\r\n NumGlyphs := ANumGlyphs;\r\n FColor := AColor;\r\n GlyphChanged(FOriginal);\r\n Result := Draw(Canvas, Client, Offset, Caption, Layout, Margin,\r\n Spacing, State, Transparent);\r\n finally\r\n FOriginal := OldGlyph;\r\n NumGlyphs := OldNumGlyphs;\r\n FColor := OldColor;\r\n if not IgnoreOld then\r\n GlyphChanged(FOriginal);\r\n end;\r\nend;\r\n\r\nprocedure TJvButtonGlyph.CalcTextRect(Canvas: TCanvas; var TextRect: TRect; const Caption: string);\r\nbegin\r\n TextRect := Rect(0, 0, TextRect.Right - TextRect.Left, 0);\r\n DrawText(Canvas, Caption, Length(Caption), TextRect, DT_CALCRECT);\r\nend;\r\n\r\nconstructor TJvHTButtonGlyph.Create(AOwner: TJvHTButton);\r\nbegin\r\n inherited Create;\r\n\r\n FOwner := AOwner;\r\nend;\r\n\r\nprocedure TJvHTButtonGlyph.DrawButtonText(Canvas: TCanvas; const Caption: string;\r\n TextBounds: TRect; State: TButtonState);\r\nbegin\r\n with Canvas do\r\n begin\r\n Brush.Style := bsClear;\r\n if State = bsDisabled then\r\n begin\r\n OffsetRect(TextBounds, 1, 1);\r\n Font.Color := clBtnHighlight;\r\n ItemHtDraw(Canvas, TextBounds, [], Caption, FOwner.SuperSubScriptRatio);\r\n OffsetRect(TextBounds, -1, -1);\r\n Font.Color := clBtnShadow;\r\n ItemHtDraw(Canvas, TextBounds, [], Caption, FOwner.SuperSubScriptRatio);\r\n end\r\n else\r\n ItemHtDraw(Canvas, TextBounds, [], Caption, FOwner.SuperSubScriptRatio);\r\n end;\r\nend;\r\n\r\nprocedure TJvHTButtonGlyph.CalcTextRect(Canvas: TCanvas; var TextRect: TRect; const Caption: string);\r\nvar\r\n Size: TSize;\r\nbegin\r\n TextRect := Rect(0, 0, 0, 0);\r\n Size := ItemHTExtent(Canvas, TextRect, [], Caption, FOwner.SuperSubScriptRatio);\r\n TextRect := Rect(0, 0, Size.cx, Size.cy);\r\nend;\r\n\r\n//=== { TJvaCaptionButton } ==================================================\r\n\r\nconstructor TJvaCaptionButton.Create(AOwner: TComponent);\r\n\r\n function FindButtonPos: Integer;\r\n var\r\n I: Integer;\r\n B: TComponent;\r\n begin\r\n Result := 4;\r\n for I := 0 to Owner.ComponentCount - 1 do\r\n begin\r\n B := Owner.Components[I];\r\n if B is TJvaCaptionButton then\r\n Result := Max(Result, TJvaCaptionButton(B).FBPos + 1);\r\n end;\r\n end;\r\n\r\nbegin\r\n if not (AOwner is TForm) then\r\n raise EJVCLException.CreateResFmt(@RsEOwnerMustBeForm, [ClassName]);\r\n inherited Create(AOwner);\r\n\r\n FGlyph := TJvButtonGlyph.Create;\r\n TJvButtonGlyph(FGlyph).OnChange := GlyphChanged;\r\n FFont := TFont.Create;\r\n FFont.OnChange := FontChange;\r\n FBPos := FindButtonPos;\r\n FMouseLButtonDown := False;\r\n FPress := False;\r\n FWidth := -1;\r\n FMargin := -1;\r\n FVisible := True;\r\n WHook := TJvWindowHook.Create(nil);\r\n WHook.BeforeMessage := DoBeforeMsg;\r\n WHook.AfterMessage := DoAfterMsg;\r\n WHook.Control := (Owner as TForm);\r\n WHook.Active := True;\r\n Resize;\r\nend;\r\n\r\ndestructor TJvaCaptionButton.Destroy;\r\nbegin\r\n WHook.Free;\r\n if Owner <> nil then\r\n RedrawWindow((Owner as TForm).Handle, PRect(0), 0, RDW_FRAME or RDW_NOINTERNALPAINT or RDW_INVALIDATE);\r\n TJvButtonGlyph(FGlyph).Free;\r\n FFont.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJvaCaptionButton.BorderStyle: TFormBorderStyle;\r\nbegin\r\n if csDesigning in ComponentState then\r\n Result := bsSizeable\r\n else\r\n Result := (Owner as TForm).BorderStyle;\r\nend;\r\n\r\nfunction TJvaCaptionButton.GetHeight: Integer;\r\nbegin\r\n if BorderStyle in [bsSizeToolWin, bsToolWindow] then\r\n Result := GetSystemMetrics(SM_CYSMSIZE)\r\n else\r\n Result := GetSystemMetrics(SM_CYSIZE);\r\nend;\r\n\r\nfunction TJvaCaptionButton.GetWidth: Integer;\r\nbegin\r\n if FWidth <> -1 then\r\n Result := FWidth\r\n else\r\n if BorderStyle in [bsSizeToolWin, bsToolWindow] then\r\n Result := GetSystemMetrics(SM_CXSMSIZE)\r\n else\r\n Result := GetSystemMetrics(SM_CXSIZE);\r\nend;\r\n\r\nfunction TJvaCaptionButton.GetLeft: Integer;\r\nvar\r\n F: Integer;\r\n\r\n function FirstButtonPos: Integer;\r\n var\r\n I: Integer;\r\n B: TComponent;\r\n begin\r\n Result := FBPos;\r\n for I := 0 to Owner.ComponentCount - 1 do\r\n begin\r\n B := Owner.Components[I];\r\n if B is TJvaCaptionButton then\r\n Result := Min(Result, (B as TJvaCaptionButton).FBPos);\r\n end;\r\n end;\r\n\r\n function RightButtonWidth: Integer;\r\n var\r\n I: Integer;\r\n B: TComponent;\r\n begin\r\n Result := 0;\r\n for I := 0 to Owner.ComponentCount - 1 do\r\n begin\r\n B := Owner.Components[I];\r\n if (B is TJvaCaptionButton) and\r\n ((B as TJvaCaptionButton).FBPos <= FBPos) then\r\n Inc(Result, (B as TJvaCaptionButton).GetWidth);\r\n end;\r\n end;\r\n\r\nbegin\r\n if BorderStyle in [bsSizeToolWin, bsToolWindow] then\r\n F := GetSystemMetrics(SM_CXSMSIZE)\r\n else\r\n F := GetSystemMetrics(SM_CXSIZE);\r\n Result := (Owner as TForm).Width - CalcOffset.X * 2 - F * FirstButtonPos;\r\n Result := Result - RightButtonWidth;\r\n // Result := 100;\r\nend;\r\n\r\nprocedure TJvaCaptionButton.Resize;\r\nbegin\r\n FRect := Bounds(GetLeft, 0, GetWidth, GetHeight);\r\n RedrawWindow((Owner as TForm).Handle, PRect(0), 0, RDW_FRAME or RDW_NOINTERNALPAINT or RDW_INVALIDATE);\r\nend;\r\n\r\nfunction TJvaCaptionButton.CalcOffset: TPoint;\r\nbegin\r\n case BorderStyle of\r\n bsSingle:\r\n begin\r\n { Result.X := GetSystemMetrics(SM_CXBORDER) + 1;\r\n Result.Y := GetSystemMetrics(SM_CYBORDER) + 1; }\r\n Result.X := GetSystemMetrics(SM_CXDLGFRAME);\r\n Result.Y := GetSystemMetrics(SM_CYDLGFRAME);\r\n end;\r\n bsDialog:\r\n begin\r\n Result.X := GetSystemMetrics(SM_CXDLGFRAME) - 1 {?};\r\n Result.Y := GetSystemMetrics(SM_CYDLGFRAME);\r\n end;\r\n bsSizeable:\r\n begin\r\n Result.X := GetSystemMetrics(SM_CXFRAME);\r\n Result.Y := GetSystemMetrics(SM_CYFRAME);\r\n end;\r\n bsNone:\r\n begin\r\n Result.X := 0;\r\n Result.Y := 0;\r\n end;\r\n bsToolWindow:\r\n begin\r\n Result.X := GetSystemMetrics(SM_CXDLGFRAME);\r\n Result.Y := GetSystemMetrics(SM_CYDLGFRAME);\r\n end;\r\n bsSizeToolWin:\r\n begin\r\n Result.X := GetSystemMetrics(SM_CXFRAME);\r\n Result.Y := GetSystemMetrics(SM_CYFRAME);\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvaCaptionButton.Draw;\r\nvar\r\n DC: HDC;\r\n R: TRect;\r\n Canvas: TCanvas;\r\n Offset: TPoint;\r\nconst\r\n CaptionColor: array [Boolean] of TColor = (clInactiveCaption, clActiveCaption);\r\nbegin\r\n if not FVisible then\r\n Exit;\r\n Offset := CalcOffset;\r\n DC := GetWindowDC((Owner as TForm).Handle);\r\n Canvas := TCanvas.Create;\r\n Canvas.Font := FFont;\r\n try\r\n SetWindowOrgEx(DC, -Offset.X, -Offset.Y, nil);\r\n R := FRect;\r\n Canvas.Handle := DC;\r\n Canvas.Brush.Color := CaptionColor[FActive];\r\n //Canvas.FillRect(R); { commented for Windows98 gradient caption compatibility }\r\n Inc(R.Left, 2);\r\n Inc(R.Top, 2);\r\n Dec(R.Bottom, 2);\r\n if FPress then\r\n DrawThemedFrameControl(DC, R, DFC_BUTTON, DFCS_BUTTONPUSH or DFCS_PUSHED)\r\n else\r\n DrawThemedFrameControl(DC, R, DFC_BUTTON, DFCS_BUTTONPUSH);\r\n\r\n R := Rect(R.Left + 1, R.Top + 1, R.Right - 2, R.Bottom - 2);\r\n if FPress then\r\n OffsetRect(R, 1, 1);\r\n\r\n if FPress then\r\n TJvButtonGlyph(FGlyph).Draw(Canvas, R, Point(0, 0),\r\n FCaption, FLayout, FMargin, FSpacing, bsDown, True)\r\n else\r\n TJvButtonGlyph(FGlyph).Draw(Canvas, R, Point(0, 0),\r\n FCaption, FLayout, FMargin, FSpacing, bsUp, True);\r\n finally\r\n Canvas.Handle := 0;\r\n Canvas.Free;\r\n ReleaseDC((Owner as TForm).Handle, DC);\r\n end;\r\nend;\r\n\r\n(*\r\nprocedure TJvaCaptionButton.HookWndProc(var Msg: TMessage);\r\nvar\r\n P: TPoint;\r\n OldPress: Boolean;\r\nbegin\r\n if Owner = nil then\r\n Exit;\r\n case Msg.Msg of\r\n WM_NCACTIVATE: // after\r\n begin\r\n FActive := Boolean(Msg.wParam);\r\n WHook.CallOldProc(Msg);\r\n Draw;\r\n end;\r\n WM_SETTEXT, WM_NCPAINT: // after\r\n begin\r\n WHook.CallOldProc(Msg);\r\n Draw;\r\n end;\r\n WM_SIZE: // after\r\n begin\r\n WHook.CallOldProc(Msg);\r\n Resize;\r\n end;\r\n WM_NCLBUTTONDOWN: // before\r\n if FVisible and\r\n MouseOnButton(TWMNCHitMessage(Msg).XCursor, TWMNCHitMessage(Msg).YCursor) then\r\n begin\r\n SetCapture((Owner as TForm).Handle);\r\n FMouseLButtonDown := True;\r\n FPress := True;\r\n Draw;\r\n end\r\n else\r\n WHook.CallOldProc(Msg);\r\n WM_NCLBUTTONDBLCLK: // before\r\n if FVisible and\r\n MouseOnButton(TWMNCHitMessage(Msg).XCursor, TWMNCHitMessage(Msg).YCursor) then\r\n begin\r\n { FPress := True;\r\n Draw;\r\n FPress := False;\r\n Draw;}\r\n end\r\n else\r\n WHook.CallOldProc(Msg);\r\n WM_LBUTTONUP: // before\r\n if FVisible and FMouseLButtonDown then\r\n begin\r\n ReleaseCapture;\r\n FMouseLButtonDown := False;\r\n FPress := False;\r\n Draw;\r\n P := (Owner as TForm).ClientToScreen(Point(TWMNCHitMessage(Msg).XCursor, TWMNCHitMessage(Msg).YCursor));\r\n if MouseOnButton(P.X, P.Y) then\r\n Click;\r\n end\r\n else\r\n WHook.CallOldProc(Msg);\r\n WM_MOUSEMOVE: // before\r\n if FMouseLButtonDown then\r\n begin\r\n P := (Owner as TForm).ClientToScreen(Point(TWMNCHitMessage(Msg).XCursor, TWMNCHitMessage(Msg).YCursor));\r\n OldPress := FPress;\r\n FPress := MouseOnButton(P.X, P.Y);\r\n if OldPress <> FPress then\r\n Draw;\r\n end\r\n else\r\n WHook.CallOldProc(Msg);\r\n WM_NCHITTEST: // before\r\n if FVisible and\r\n MouseOnButton(TWMNCHitMessage(Msg).XCursor, TWMNCHitMessage(Msg).YCursor) then\r\n Msg.Result := HTBORDER\r\n else\r\n WHook.CallOldProc(Msg);\r\n WM_NCRBUTTONDOWN: // before\r\n { if FVisible and\r\n MouseOnButton(TWMNCHitMessage(Msg).XCursor, TWMNCHitMessage(Msg).YCursor) then\r\n WHook.CallOldProc(Msg)\r\n else} WHook.CallOldProc(Msg);\r\n WM_SETTINGCHANGE: // after\r\n begin\r\n WHook.CallOldProc(Msg);\r\n Changed;\r\n end;\r\n else\r\n WHook.CallOldProc(Msg);\r\n end;\r\nend;\r\n*)\r\n\r\nprocedure TJvaCaptionButton.Changed;\r\nvar\r\n I: Integer;\r\n B: TComponent;\r\nbegin\r\n for I := 0 to Owner.ComponentCount - 1 do\r\n begin\r\n B := Owner.Components[I];\r\n if (B is TJvaCaptionButton) then\r\n begin\r\n (B as TJvaCaptionButton).Resize;\r\n (B as TJvaCaptionButton).Draw;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJvaCaptionButton.MouseOnButton(X, Y: Integer): Boolean;\r\nbegin\r\n with (Owner as TForm) do\r\n Result := PtInRect(FRect, Point(X - Left - CalcOffset.X, Y - Top - CalcOffset.Y));\r\nend;\r\n\r\nprocedure TJvaCaptionButton.Click;\r\nbegin\r\n if csDesigning in ComponentState then\r\n DesignerSelectComponent(Self);\r\n if Assigned(FOnClick) then\r\n FOnClick(Self);\r\nend;\r\n\r\nprocedure TJvaCaptionButton.GlyphChanged(Sender: TObject);\r\nbegin\r\n Changed;\r\nend;\r\n\r\nprocedure TJvaCaptionButton.SetCaption(Value: string);\r\nbegin\r\n if FCaption <> Value then\r\n begin\r\n FCaption := Value;\r\n Changed;\r\n end;\r\nend;\r\n\r\nfunction TJvaCaptionButton.IsCaptionStored: Boolean;\r\nbegin\r\n Result := FCaption <> '';\r\nend;\r\n\r\nprocedure TJvaCaptionButton.SetFont(Value: TFont);\r\nbegin\r\n if FFont <> Value then\r\n begin\r\n FFont.Assign(Value);\r\n Changed;\r\n end;\r\nend;\r\n\r\nprocedure TJvaCaptionButton.FontChange(Sender: TObject);\r\nbegin\r\n Changed;\r\nend;\r\n\r\nfunction TJvaCaptionButton.GetGlyph: TBitmap;\r\nbegin\r\n Result := FGlyph.Glyph;\r\nend;\r\n\r\nprocedure TJvaCaptionButton.SetGlyph(Value: TBitmap);\r\nbegin\r\n if FGlyph.Glyph <> Value then\r\n begin\r\n FGlyph.Glyph := Value;\r\n Changed;\r\n end;\r\nend;\r\n\r\nfunction TJvaCaptionButton.GetNumGlyphs: TNumGlyphs;\r\nbegin\r\n Result := FGlyph.NumGlyphs;\r\nend;\r\n\r\nprocedure TJvaCaptionButton.SetNumGlyphs(Value: TNumGlyphs);\r\nbegin\r\n if Value < 0 then\r\n Value := 1\r\n else\r\n if Value > 4 then\r\n Value := 4;\r\n if Value <> FGlyph.NumGlyphs then\r\n begin\r\n FGlyph.NumGlyphs := Value;\r\n Changed;\r\n end;\r\nend;\r\n\r\nprocedure TJvaCaptionButton.SetBPos(const Value: Integer);\r\nbegin\r\n if FBPos <> Value then\r\n begin\r\n FBPos := Value;\r\n Changed;\r\n end;\r\nend;\r\n\r\nprocedure TJvaCaptionButton.SetLayout(Value: TButtonLayout);\r\nbegin\r\n if FLayout <> Value then\r\n begin\r\n FLayout := Value;\r\n Changed;\r\n end;\r\nend;\r\n\r\nprocedure TJvaCaptionButton.SetMargin(Value: Integer);\r\nbegin\r\n if (Value <> FMargin) and (Value >= -1) then\r\n begin\r\n FMargin := Value;\r\n Changed;\r\n end;\r\nend;\r\n\r\nprocedure TJvaCaptionButton.SetSpacing(Value: Integer);\r\nbegin\r\n if Value <> FSpacing then\r\n begin\r\n FSpacing := Value;\r\n Changed;\r\n end;\r\nend;\r\n\r\nprocedure TJvaCaptionButton.SetWidth(const Value: Integer);\r\nbegin\r\n if FWidth <> Value then\r\n begin\r\n FWidth := Value;\r\n Changed;\r\n end;\r\nend;\r\n\r\nprocedure TJvaCaptionButton.Update;\r\nbegin\r\n Draw;\r\nend;\r\n\r\nprocedure TJvaCaptionButton.SetDown(const Value: Boolean);\r\nbegin\r\n if FPress <> Value then\r\n begin\r\n FPress := Value;\r\n Changed;\r\n end;\r\nend;\r\n\r\nprocedure TJvaCaptionButton.SetVisible(const Value: Boolean);\r\nbegin\r\n if FVisible <> Value then\r\n begin\r\n FVisible := Value;\r\n Changed;\r\n end;\r\nend;\r\n\r\nprocedure TJvaCaptionButton.DoAfterMsg(Sender: TObject; var Msg: TMessage;\r\n var Handled: Boolean);\r\nbegin\r\n if Owner = nil then\r\n Exit;\r\n case Msg.Msg of\r\n WM_NCACTIVATE:\r\n begin\r\n FActive := Boolean(Msg.wParam);\r\n Draw;\r\n end;\r\n WM_SETTEXT, WM_NCPAINT:\r\n Draw;\r\n WM_SIZE:\r\n Resize;\r\n WM_SETTINGCHANGE:\r\n Changed;\r\n end;\r\nend;\r\n\r\nprocedure TJvaCaptionButton.DoBeforeMsg(Sender: TObject; var Msg: TMessage;\r\n var Handled: Boolean);\r\nvar\r\n P: TPoint;\r\n OldPress: Boolean;\r\nbegin\r\n if Owner = nil then\r\n Exit;\r\n case Msg.Msg of\r\n WM_NCLBUTTONDOWN:\r\n if FVisible and\r\n MouseOnButton(TWMNCHitMessage(Msg).XCursor, TWMNCHitMessage(Msg).YCursor) then\r\n begin\r\n SetCapture((Owner as TForm).Handle);\r\n FMouseLButtonDown := True;\r\n FPress := True;\r\n Handled := True;\r\n Draw;\r\n end;\r\n WM_NCLBUTTONDBLCLK:\r\n if FVisible and\r\n MouseOnButton(TWMNCHitMessage(Msg).XCursor, TWMNCHitMessage(Msg).YCursor) then\r\n begin\r\n { FPress := True;\r\n Draw;\r\n FPress := False;\r\n Draw;}\r\n Handled := True;\r\n end;\r\n WM_LBUTTONUP:\r\n if FVisible and FMouseLButtonDown then\r\n begin\r\n ReleaseCapture;\r\n FMouseLButtonDown := False;\r\n FPress := False;\r\n Draw;\r\n P := (Owner as TForm).ClientToScreen(Point(TWMNCHitMessage(Msg).XCursor, TWMNCHitMessage(Msg).YCursor));\r\n if MouseOnButton(P.X, P.Y) then\r\n Click;\r\n Handled := True;\r\n end;\r\n WM_MOUSEMOVE:\r\n if FMouseLButtonDown then\r\n begin\r\n P := (Owner as TForm).ClientToScreen(Point(TWMNCHitMessage(Msg).XCursor, TWMNCHitMessage(Msg).YCursor));\r\n OldPress := FPress;\r\n FPress := MouseOnButton(P.X, P.Y);\r\n if OldPress <> FPress then\r\n Draw;\r\n Handled := True;\r\n end;\r\n WM_NCHITTEST:\r\n if FVisible and\r\n MouseOnButton(TWMNCHitMessage(Msg).XCursor, TWMNCHitMessage(Msg).YCursor) then\r\n begin\r\n Msg.Result := HTBORDER;\r\n Handled := True;\r\n end;\r\n WM_NCRBUTTONDOWN:\r\n { if FVisible and\r\n MouseOnButton(TWMNCHitMessage(Msg).XCursor, TWMNCHitMessage(Msg).YCursor) then\r\n WHook.CallOldProc(Msg)\r\n else}\r\n ;\r\n end;\r\nend;\r\n\r\n//=== { TJvaColorButton } ====================================================\r\n\r\nconstructor TJvaColorButton.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FGlyphDrawer := TJvButtonGlyph.Create;\r\n FCanvas := TControlCanvas.Create;\r\n // (rom) destroy Canvas AFTER inherited Destroy\r\n FCanvas.Control := Self;\r\nend;\r\n\r\ndestructor TJvaColorButton.Destroy;\r\nbegin\r\n FreeAndNil(FGlyphDrawer);\r\n inherited Destroy;\r\n FreeAndNil(FCanvas);\r\nend;\r\n\r\nfunction TJvaColorButton.GetCanvas: TCanvas;\r\nbegin\r\n Result := FCanvas;\r\nend;\r\n\r\nprocedure TJvaColorButton.SetButtonStyle(ADefault: Boolean);\r\nbegin\r\n if ADefault <> IsFocused then\r\n IsFocused := ADefault;\r\n inherited SetButtonStyle(ADefault);\r\nend;\r\n\r\nprocedure TJvaColorButton.CNDrawItem(var Msg: TWMDrawItem);\r\nvar\r\n DrawItemStruct: TDrawItemStruct;\r\n IsDown, IsDefault: Boolean;\r\n State: TButtonState;\r\nbegin\r\n if csDestroying in ComponentState then\r\n Exit;\r\n DrawItemStruct := Msg.DrawItemStruct^;\r\n FCanvas.Handle := DrawItemStruct.hDC;\r\n with DrawItemStruct do\r\n begin\r\n IsDown := itemState and ODS_SELECTED <> 0;\r\n IsDefault := itemState and ODS_FOCUS <> 0;\r\n\r\n if not Enabled then\r\n State := bsDisabled\r\n else\r\n if IsDown then\r\n State := bsDown\r\n else\r\n State := bsUp;\r\n end;\r\n\r\n if Assigned(FOnPaint) then\r\n FOnPaint(Self, IsDown, IsDefault, State)\r\n else\r\n DefaultDrawing(IsDown, IsDefault, State);\r\n\r\n FCanvas.Handle := 0;\r\nend;\r\n\r\nprocedure TJvaColorButton.DefaultDrawing(const IsDown, IsDefault: Boolean; const State: TButtonState);\r\nvar\r\n R: TRect;\r\n Flags: Longint;\r\nbegin\r\n if (csDestroying in ComponentState) or (FCanvas.Handle = 0) then\r\n Exit;\r\n R := ClientRect;\r\n Flags := DFCS_BUTTONPUSH or DFCS_ADJUSTRECT;\r\n if IsDown then\r\n Flags := Flags or DFCS_PUSHED;\r\n if State = bsDisabled then\r\n Flags := Flags or DFCS_INACTIVE;\r\n\r\n {$IFDEF JVCLThemesEnabled}\r\n if ThemeServices.{$IFDEF RTL230_UP}Enabled{$ELSE}ThemesEnabled{$ENDIF RTL230_UP} then\r\n begin\r\n if IsFocused or IsDefault then\r\n Flags := Flags or DFCS_MONO; // mis-used\r\n if MouseOver and not (csDesigning in ComponentState) then\r\n Flags := Flags or DFCS_HOT;\r\n DrawThemedFrameControl(FCanvas.Handle, R, DFC_BUTTON, Flags);\r\n end\r\n else\r\n {$ENDIF JVCLThemesEnabled}\r\n begin\r\n { DrawFrameControl doesn't allow for drawing a button as the\r\n default button, so it must be done here. }\r\n if IsFocused or IsDefault then\r\n begin\r\n FCanvas.Pen.Color := clWindowFrame;\r\n FCanvas.Pen.Width := 1;\r\n FCanvas.Brush.Style := bsClear;\r\n FCanvas.Rectangle(R.Left, R.Top, R.Right, R.Bottom);\r\n\r\n { DrawFrameControl must draw within this border }\r\n InflateRect(R, -1, -1);\r\n end;\r\n\r\n { DrawFrameControl does not draw a pressed button correctly }\r\n if IsDown then\r\n begin\r\n FCanvas.Pen.Color := clBtnShadow;\r\n FCanvas.Pen.Width := 1;\r\n FCanvas.Brush.Color := Color {clBtnFace};\r\n FCanvas.Rectangle(R.Left, R.Top, R.Right, R.Bottom);\r\n InflateRect(R, -1, -1);\r\n end\r\n else\r\n begin\r\n DrawFrameControl(FCanvas.Handle, R, DFC_BUTTON, Flags);\r\n FCanvas.Pen.Style := psSolid;\r\n FCanvas.Pen.Color := Color {clBtnShadow};\r\n FCanvas.Pen.Width := 1;\r\n FCanvas.Brush.Color := Color;\r\n FCanvas.Rectangle(R.Left, R.Top, R.Right, R.Bottom);\r\n end;\r\n end;\r\n\r\n if IsFocused then\r\n begin\r\n R := ClientRect;\r\n InflateRect(R, -1, -1);\r\n end;\r\n\r\n FCanvas.Font := Self.Font;\r\n if IsDown then\r\n OffsetRect(R, 1, 1);\r\n\r\n FGlyphDrawer.DrawExternal(Glyph, NumGlyphs, Color, True, FCanvas, R, Point(0, 0), Caption, Layout, Margin,\r\n Spacing, State, False {True});\r\n\r\n {$IFDEF JVCLThemesEnabled}\r\n if not ThemeServices.{$IFDEF RTL230_UP}Enabled{$ELSE}ThemesEnabled{$ENDIF RTL230_UP} then\r\n {$ENDIF JVCLThemesEnabled}\r\n if IsFocused and IsDefault then\r\n begin\r\n R := ClientRect;\r\n InflateRect(R, -4, -4);\r\n FCanvas.Pen.Color := clWindowFrame;\r\n FCanvas.Brush.Color := Color; {clBtnFace}\r\n DrawFocusRect(FCanvas.Handle, R);\r\n end;\r\nend;\r\n\r\n//=== { TJvNoFrameButton } ===================================================\r\n\r\nconstructor TJvNoFrameButton.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FGlyphDrawer := TJvButtonGlyph.Create;\r\n FNoBorder := True;\r\n FInitRepeatPause := 400;\r\n FRepeatPause := 100;\r\nend;\r\n\r\ndestructor TJvNoFrameButton.Destroy;\r\nbegin\r\n FRepeatTimer.Free;\r\n FGlyphDrawer.Free;\r\n FGlyphDrawer := nil;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvNoFrameButton.MouseDown(Button: TMouseButton; Shift: TShiftState;\r\n X, Y: Integer);\r\nbegin\r\n inherited MouseDown(Button, Shift, X, Y);\r\n if (Button = mbLeft) and Enabled and RepeatedClick then\r\n begin\r\n if FRepeatTimer = nil then\r\n FRepeatTimer := TTimer.Create(Self);\r\n FRepeatTimer.OnTimer := TimerExpired;\r\n FRepeatTimer.Interval := InitRepeatPause;\r\n FRepeatTimer.Enabled := True;\r\n FClicked := False;\r\n end;\r\nend;\r\n\r\nprocedure TJvNoFrameButton.MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);\r\nvar\r\n OrgMouseUp: TMouseEvent;\r\nbegin\r\n if FClicked then\r\n begin\r\n // prevent the OnClick event to trigger again\r\n if Assigned(OnMouseUp) then\r\n OnMouseUp(Self, Button, Shift, X, Y);\r\n OrgMouseUp := OnMouseUp;\r\n try\r\n OnMouseUp := nil;\r\n inherited MouseUp(Button, Shift, -1, -1)\r\n finally\r\n OnMouseUp := OrgMouseUp;\r\n end;\r\n end\r\n else\r\n inherited MouseUp(Button, Shift, X, Y);\r\n FreeAndNil(FRepeatTimer);\r\nend;\r\n\r\nprocedure TJvNoFrameButton.TimerExpired(Sender: TObject);\r\nbegin\r\n FRepeatTimer.Interval := RepeatPause;\r\n if (FState = bsDown) and Enabled and MouseCapture then\r\n begin\r\n try\r\n FClicked := True;\r\n Click;\r\n except\r\n FRepeatTimer.Enabled := False;\r\n raise;\r\n end;\r\n end\r\n else\r\n FreeAndNil(FRepeatTimer);\r\nend;\r\n\r\nprocedure TJvNoFrameButton.Paint;\r\nbegin\r\n if not Enabled then\r\n begin\r\n FState := bsDisabled;\r\n // FDragging := False;\r\n end\r\n else\r\n if FState = bsDisabled then\r\n if Down and (GroupIndex <> 0) then\r\n FState := bsExclusive\r\n else\r\n FState := bsUp;\r\n if Assigned(FOnPaint) then\r\n FOnPaint(Self, Down, False, FState)\r\n else\r\n DefaultDrawing(Down, FState);\r\nend;\r\n\r\nprocedure TJvNoFrameButton.DefaultDrawing(const IsDown: Boolean; const State: TButtonState);\r\nconst\r\n DownStyles: array [Boolean] of Integer = (BDR_RAISEDINNER, BDR_SUNKENOUTER);\r\n FillStyles: array [Boolean] of Integer = (BF_MIDDLE, 0);\r\nvar\r\n PaintRect: TRect;\r\n Offset: TPoint;\r\nbegin\r\n if Flat and not NoBorder then\r\n inherited Paint\r\n else\r\n begin\r\n Canvas.Font := Self.Font;\r\n PaintRect := Rect(0, 0, Width, Height);\r\n if not NoBorder then\r\n begin\r\n DrawEdge(Canvas.Handle, PaintRect, DownStyles[FState in [bsDown, bsExclusive]],\r\n FillStyles[Transparent] or BF_RECT);\r\n InflateRect(PaintRect, -1, -1);\r\n end;\r\n Canvas.Brush.Style := bsSolid;\r\n Canvas.Brush.Color := Color;\r\n Canvas.FillRect(PaintRect);\r\n if NoBorder and (csDesigning in ComponentState) then\r\n DrawDesignFrame(Canvas, PaintRect);\r\n InflateRect(PaintRect, -1, -1);\r\n\r\n if FState in [bsDown, bsExclusive] then\r\n begin\r\n if (FState = bsExclusive) then\r\n begin\r\n if Pattern = nil then\r\n CreateBrushPattern(clBtnFace, clBtnHighlight);\r\n Canvas.Brush.Bitmap := Pattern;\r\n Canvas.FillRect(PaintRect);\r\n end;\r\n Offset.X := 1;\r\n Offset.Y := 1;\r\n end\r\n else\r\n begin\r\n Offset.X := 0;\r\n Offset.Y := 0;\r\n end;\r\n {O}\r\n FGlyphDrawer.BiDiMode := BiDiMode;\r\n FGlyphDrawer.DrawExternal(Glyph, NumGlyphs, Color, True, Canvas, PaintRect, Offset, Caption, Layout, Margin,\r\n Spacing, FState, False {True});\r\n end;\r\nend;\r\n\r\nprocedure TJvNoFrameButton.SetNoBorder(Value: Boolean);\r\nbegin\r\n if FNoBorder <> Value then\r\n begin\r\n FNoBorder := Value;\r\n Refresh;\r\n end;\r\nend;\r\n\r\n//=== { TJvHTButton } ========================================================\r\n\r\nconstructor TJvHTButton.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FGlyphDrawer.Free;\r\n FGlyphDrawer := TJvHTButtonGlyph.Create(Self);\r\n FSuperSubScriptRatio := DefaultSuperSubScriptRatio;\r\nend;\r\n\r\ndestructor TJvHTButton.Destroy;\r\nbegin\r\n TJvHTButtonGlyph(FGlyphDrawer).Free;\r\n FGlyphDrawer := nil;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJvHTButton.ISuperSuperSubScriptRatioStored: Boolean;\r\nbegin\r\n Result := FSuperSubScriptRatio <> DefaultSuperSubScriptRatio;\r\nend;\r\n\r\nprocedure TJvHTButton.SetSuperSubScriptRation(const Value: Double);\r\nbegin\r\n if FSuperSubScriptRatio <> Value then\r\n begin\r\n FSuperSubScriptRatio := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvCSVBaseControls.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvCSVBase.PAS, released on 2002-06-15.\r\n\r\nThe Initial Developer of the Original Code is Jan Verhoeven [jan1 dott verhoeven att wxs dott nl]\r\nPortions created by Jan Verhoeven are Copyright (C) 2002 Jan Verhoeven.\r\nAll Rights Reserved.\r\n\r\nContributor(s): Robert Love [rlove att slcdug dott org].\r\n Martin Cetkovsky [martin att alikuvkoutek dott cz]\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvCSVBaseControls.pas 13104 2011-09-07 06:50:43Z obones $\r\n\r\nunit JvCSVBaseControls;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, Classes, Controls, StdCtrls, Buttons,\r\n JvComponentBase, JvComponent;\r\n\r\ntype\r\n // NameValues: TStringList has changed to TStrings\r\n TCursorChangedEvent = procedure(Sender: TObject; NameValues: TStrings;\r\n FieldCount: Integer) of object;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvCSVBase = class(TJvComponent)\r\n private\r\n FDBOpen: Boolean;\r\n FDB: TStringList;\r\n FDBRecord: TStringList;\r\n FDBFields: TStringList;\r\n FDBCursor: Integer;\r\n FOnCursorChanged: TCursorChangedEvent;\r\n FCSVFileName: string;\r\n FCSVFieldNames: TStringList;\r\n procedure DoCursorChange;\r\n procedure SetCSVFileName(const Value: string);\r\n function GetCSVFieldNames: TStrings;\r\n procedure SetCSVFieldNames(const Value: TStrings);\r\n procedure DisplayFields(NameValues: TStrings);\r\n protected\r\n procedure DoCursorChanged(NameValues: TStrings; FieldCount: Integer); virtual;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n procedure DataBaseCreate(const AFile: string; FieldNames: TStrings;\r\n AChangeExt: Boolean = True; AAskIfExists: Boolean = True);\r\n procedure DataBaseOpen(const AFile: string);\r\n procedure DataBaseClose;\r\n procedure DataBaseRestructure(const AFile: string; FieldNames: TStrings);\r\n procedure RecordNew;\r\n procedure RecordGet(NameValues: TStrings; UseNames: Boolean = True);\r\n procedure RecordSet(NameValues: TStrings; UseNames: Boolean = True);\r\n procedure RecordDelete;\r\n function RecordNext: Boolean;\r\n function RecordPrevious: Boolean;\r\n function RecordFirst: Boolean;\r\n function RecordLast: Boolean;\r\n procedure RecordPost;\r\n function RecordFind(const AText: string): Boolean;\r\n procedure Display;\r\n published\r\n property CSVFileName: string read FCSVFileName write SetCSVFileName;\r\n property CSVFieldNames: TStrings read GetCSVFieldNames write SetCSVFieldNames;\r\n property OnCursorChanged: TCursorChangedEvent read FOnCursorChanged write FOnCursorChanged;\r\n end;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvCSVEdit = class(TEdit)\r\n private\r\n FCSVDataBase: TJvCSVBase;\r\n FCSVField: string;\r\n procedure SetCSVDataBase(const Value: TJvCSVBase);\r\n procedure SetCSVField(const Value: string);\r\n protected\r\n procedure Notification(AComponent: TComponent; Operation: TOperation); override;\r\n published\r\n property CSVDataBase: TJvCSVBase read FCSVDataBase write SetCSVDataBase;\r\n property CSVField: string read FCSVField write SetCSVField;\r\n end;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvCSVComboBox = class(TComboBox)\r\n private\r\n FCSVField: string;\r\n FCSVDataBase: TJvCSVBase;\r\n procedure SetCSVDataBase(const Value: TJvCSVBase);\r\n procedure SetCSVField(const Value: string);\r\n protected\r\n procedure Notification(AComponent: TComponent; Operation: TOperation); override;\r\n published\r\n property CSVDataBase: TJvCSVBase read FCSVDataBase write SetCSVDataBase;\r\n property CSVField: string read FCSVField write SetCSVField;\r\n end;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvCSVCheckBox = class(TCheckBox)\r\n private\r\n FCSVField: string;\r\n FCSVDataBase: TJvCSVBase;\r\n procedure SetCSVDataBase(const Value: TJvCSVBase);\r\n procedure SetCSVField(const Value: string);\r\n protected\r\n procedure Notification(AComponent: TComponent; Operation: TOperation); override;\r\n published\r\n property CSVDataBase: TJvCSVBase read FCSVDataBase write SetCSVDataBase;\r\n property CSVField: string read FCSVField write SetCSVField;\r\n end;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvCSVNavigator = class(TJvCustomControl)\r\n private\r\n FBtnFirst: TSpeedButton;\r\n FBtnPrevious: TSpeedButton;\r\n FBtnFind: TSpeedButton;\r\n FBtnNext: TSpeedButton;\r\n FBtnLast: TSpeedButton;\r\n FBtnAdd: TSpeedButton;\r\n FBtnDelete: TSpeedButton;\r\n FBtnPost: TSpeedButton;\r\n FBtnRefresh: TSpeedButton;\r\n FCSVDataBase: TJvCSVBase;\r\n procedure CreateButtons;\r\n procedure BtnFirstClick(Sender: TObject);\r\n procedure BtnPreviousClick(Sender: TObject);\r\n procedure BtnFindClick(Sender: TObject);\r\n procedure BtnNextClick(Sender: TObject);\r\n procedure BtnLastClick(Sender: TObject);\r\n procedure BtnAddClick(Sender: TObject);\r\n procedure BtnDeleteClick(Sender: TObject);\r\n procedure BtnPostClick(Sender: TObject);\r\n procedure BtnRefreshClick(Sender: TObject);\r\n procedure SetCSVDataBase(const Value: TJvCSVBase);\r\n protected\r\n procedure Notification(AComponent: TComponent; Operation: TOperation); override;\r\n procedure BoundsChanged; override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n procedure CreateWnd; override;\r\n published\r\n property CSVDataBase: TJvCSVBase read FCSVDataBase write SetCSVDataBase;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvCSVBaseControls.pas $';\r\n Revision: '$Revision: 13104 $';\r\n Date: '$Date: 2011-09-07 08:50:43 +0200 (mer. 07 sept. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n SysUtils, Forms, Dialogs,\r\n JvThemes, JvResources, JvJVCLUtils;\r\n\r\n{$R JvCSVBase.res}\r\n\r\n//=== { TJvCSVBase } =========================================================\r\n\r\nconstructor TJvCSVBase.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FDB := TStringList.Create;\r\n FDBRecord := TStringList.Create;\r\n FDBFields := TStringList.Create;\r\n FCSVFieldNames := TStringList.Create;\r\n FDBCursor := -1;\r\n FDBOpen := False;\r\nend;\r\n\r\ndestructor TJvCSVBase.Destroy;\r\nbegin\r\n FDB.Free;\r\n FDBRecord.Free;\r\n FDBFields.Free;\r\n FCSVFieldNames.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvCSVBase.DataBaseClose;\r\nbegin\r\n FCSVFileName := '';\r\n FDBCursor := -1;\r\n DoCursorChange;\r\nend;\r\n\r\nprocedure TJvCSVBase.DataBaseCreate(const AFile: string; FieldNames: TStrings;\r\n AChangeExt: Boolean = True; AAskIfExists: Boolean = True);\r\nvar\r\n NewFile: string;\r\n AList: TStrings;\r\nbegin\r\n if AChangeExt then\r\n NewFile := ChangeFileExt(AFile, '.csv') // do not localize\r\n else\r\n NewFile := AFile;\r\n if AAskIfExists and FileExists(newfile) then\r\n if MessageDlg(RsReplaceExistingDatabase, mtConfirmation, [mbYes, mbNo], 0) = mrNo then\r\n Exit;\r\n AList := TStringList.Create;\r\n try\r\n if (FieldNames <> nil) and (FieldNames.Count > 0) then\r\n AList.Text := FieldNames.CommaText;\r\n AList.SaveToFile(newfile);\r\n finally\r\n AList.Free;\r\n end;\r\nend;\r\n\r\nprocedure TJvCSVBase.DataBaseOpen(const AFile: string);\r\nbegin\r\n if not FileExists(AFile) then\r\n DataBaseCreate(AFile, nil);\r\n FCSVFileName := AFile;\r\n FDB.LoadFromFile(CSVFileName);\r\n FDBCursor := -1;\r\n FDBFields.Clear;\r\n FDBRecord.Clear;\r\n if FDB.Count > 0 then\r\n begin\r\n FDBCursor := 0;\r\n FDBFields.CommaText := FDB[0];\r\n FCSVFieldNames.CommaText := FDB[0];\r\n if FDB.Count > 1 then\r\n begin\r\n FDBCursor := 1;\r\n FDBRecord.CommaText := FDB[FDBCursor];\r\n DoCursorChange;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvCSVBase.DataBaseRestructure(const AFile: string; FieldNames: TStrings);\r\nvar\r\n OldBase: TStrings;\r\n OldRec: TStrings;\r\n OldFields: TStrings;\r\n NewBase: TStrings;\r\n NewRec: TStrings;\r\n NewFields: TStrings;\r\n Index, Rec, Fld: Integer;\r\nbegin\r\n DataBaseClose;\r\n if FieldNames.Count = 0 then\r\n raise Exception.CreateRes(@RsENoFieldsDefined);\r\n\r\n OldBase := TStringList.Create;\r\n OldRec := TStringList.Create;\r\n OldFields := TStringList.Create;\r\n NewBase := TStringList.Create;\r\n NewRec := TStringList.Create;\r\n NewFields := TStringList.Create;\r\n try\r\n OldBase.LoadFromFile(AFile);\r\n if OldBase.Count = 0 then\r\n begin\r\n NewFields.Assign(FieldNames);\r\n NewBase.Append(NewFields.CommaText);\r\n end\r\n else\r\n begin\r\n //restructure\r\n OldFields.CommaText := OldBase[0];\r\n NewFields.Assign(FieldNames);\r\n NewBase.Append(NewFields.CommaText);\r\n if OldBase.Count > 1 then\r\n for Rec := 1 to OldBase.Count - 1 do\r\n begin\r\n OldRec.CommaText := OldBase[Rec];\r\n NewRec.Clear;\r\n for Fld := 0 to NewFields.Count - 1 do\r\n begin\r\n Index := OldFields.IndexOf(NewFields[Fld]);\r\n if Index = -1 then\r\n NewRec.Append('-')\r\n else\r\n NewRec.Append(OldRec[Index]);\r\n end;\r\n NewBase.Append(NewRec.CommaText);\r\n end;\r\n end;\r\n NewBase.SaveToFile(AFile);\r\n finally\r\n OldBase.Free;\r\n OldRec.Free;\r\n OldFields.Free;\r\n NewBase.Free;\r\n NewRec.Free;\r\n NewFields.Free;\r\n end;\r\nend;\r\n\r\nprocedure TJvCSVBase.RecordNew;\r\nvar\r\n I: Integer;\r\nbegin\r\n if FDBCursor <> -1 then\r\n begin\r\n FDBRecord.Clear;\r\n for I := 0 to FDBFields.Count - 1 do\r\n FDBRecord.Append('-');\r\n FDB.Append(FDBRecord.CommaText);\r\n FDBCursor := FDB.Count - 1;\r\n FDB.SaveToFile(CSVFileName);\r\n DoCursorChange;\r\n end;\r\nend;\r\n\r\nprocedure TJvCSVBase.RecordDelete;\r\nbegin\r\n if FDBCursor > 0 then\r\n begin\r\n FDB.Delete(FDBCursor);\r\n if FDBCursor > (FDB.Count - 1) then\r\n Dec(FDBCursor);\r\n if FDBCursor > 0 then\r\n begin\r\n FDBRecord.CommaText := FDB[FDBCursor];\r\n FDB.SaveToFile(CSVFileName);\r\n end;\r\n DoCursorChange;\r\n end;\r\nend;\r\n\r\nfunction TJvCSVBase.RecordFind(const AText: string): Boolean;\r\nvar\r\n I, From: Integer;\r\n S: string;\r\nbegin\r\n Result := False;\r\n if FDBCursor < 1 then\r\n Exit;\r\n if FDBCursor < (FDB.Count - 1) then\r\n begin\r\n From := FDBCursor + 1;\r\n S := LowerCase(AText);\r\n for I := From to FDB.Count - 1 do\r\n if Pos(S, LowerCase(FDB[I])) > 0 then\r\n begin\r\n FDBCursor := I;\r\n FDBRecord.CommaText := FDB[FDBCursor];\r\n Result := True;\r\n DoCursorChange;\r\n Break;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJvCSVBase.RecordFirst: Boolean;\r\nbegin\r\n Result := False;\r\n if FDBCursor <> -1 then\r\n if FDB.Count > 1 then\r\n begin\r\n FDBCursor := 1;\r\n FDBRecord.CommaText := FDB[FDBCursor];\r\n Result := True;\r\n DoCursorChange;\r\n end;\r\nend;\r\n\r\nprocedure TJvCSVBase.RecordGet(NameValues: TStrings; UseNames: Boolean = True);\r\nvar\r\n I: Integer;\r\nbegin\r\n NameValues.Clear;\r\n if FDBCursor < 1 then\r\n Exit;\r\n for I := 0 to FDBFields.Count - 1 do\r\n if UseNames then\r\n NameValues.Append(FDBFields[I] + '=' + FDBRecord[I]) // do not localize\r\n else\r\n NameValues.Append(FDBRecord[I]);\r\nend;\r\n\r\nfunction TJvCSVBase.RecordLast: Boolean;\r\nbegin\r\n Result := False;\r\n if FDBCursor <> -1 then\r\n if FDB.Count > 1 then\r\n begin\r\n FDBCursor := FDB.Count - 1;\r\n FDBRecord.CommaText := FDB[FDBCursor];\r\n Result := True;\r\n DoCursorChange;\r\n end;\r\nend;\r\n\r\nfunction TJvCSVBase.RecordNext: Boolean;\r\nbegin\r\n Result := False;\r\n if FDBCursor <> -1 then\r\n begin\r\n if FDBCursor < (FDB.Count - 1) then\r\n begin\r\n Inc(FDBCursor);\r\n FDBRecord.CommaText := FDB[FDBCursor];\r\n Result := True;\r\n DoCursorChange;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJvCSVBase.RecordPrevious: Boolean;\r\nbegin\r\n Result := False;\r\n if FDBCursor <> -1 then\r\n begin\r\n if FDBCursor > 1 then\r\n begin\r\n Dec(FDBCursor);\r\n FDBRecord.CommaText := FDB[FDBCursor];\r\n Result := True;\r\n DoCursorChange;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvCSVBase.RecordSet(NameValues: TStrings; UseNames: Boolean = True);\r\nvar\r\n I, Index: Integer;\r\n FieldName: string;\r\nbegin\r\n if NameValues.Count > 0 then\r\n begin\r\n for I := 0 to NameValues.Count - 1 do\r\n begin\r\n if UseNames then\r\n begin\r\n FieldName := NameValues.Names[I];\r\n Index := FDBFields.IndexOf(FieldName);\r\n if Index <> -1 then\r\n FDBRecord[Index] := NameValues.Values[FieldName];\r\n end\r\n else\r\n FDBRecord[I] := NameValues[I];\r\n end;\r\n FDB[FDBCursor] := FDBRecord.CommaText;\r\n FDB.SaveToFile(CSVFileName);\r\n end;\r\nend;\r\n\r\nprocedure TJvCSVBase.DoCursorChanged(NameValues: TStrings; FieldCount: Integer);\r\nbegin\r\n if Assigned(OnCursorChanged) then\r\n OnCursorChanged(Self, NameValues, FieldCount);\r\nend;\r\n\r\nprocedure TJvCSVBase.DoCursorChange;\r\nvar\r\n NameValues: TStrings;\r\nbegin\r\n NameValues := TStringList.Create;\r\n try\r\n RecordGet(NameValues);\r\n DisplayFields(NameValues);\r\n DoCursorChanged(NameValues, NameValues.Count);\r\n finally\r\n NameValues.Free;\r\n end;\r\nend;\r\n\r\nprocedure TJvCSVBase.DisplayFields(NameValues: TStrings);\r\nvar\r\n AForm: TForm;\r\n I, Index: Integer;\r\n ed: TJvCSVEdit;\r\n cbo: TJvCSVComboBox;\r\n ck: TJvCSVCheckBox;\r\n AField: string;\r\nbegin\r\n AForm := TForm(Self.Owner);\r\n if AForm is TComponent then\r\n begin\r\n for I := 0 to AForm.ComponentCount - 1 do\r\n if AForm.Components[I] is TJvCSVEdit then\r\n begin\r\n ed := TJvCSVEdit(AForm.Components[I]);\r\n if ed.CSVDataBase = Self then\r\n begin\r\n AField := ed.CSVField;\r\n Index := CSVFieldNames.IndexOf(AField);\r\n if Index <> -1 then\r\n if FDBCursor > 0 then\r\n ed.Text := FDBRecord[Index]\r\n else\r\n ed.Text := '[' + AField + ']'; // do not localize\r\n end;\r\n end\r\n else\r\n if AForm.Components[I] is TJvCSVComboBox then\r\n begin\r\n cbo := TJvCSVComboBox(AForm.Components[I]);\r\n if cbo.CSVDataBase = Self then\r\n begin\r\n AField := cbo.CSVField;\r\n Index := CSVFieldNames.IndexOf(AField);\r\n if Index <> -1 then\r\n if FDBCursor > 0 then\r\n cbo.Text := FDBRecord[Index]\r\n else\r\n cbo.Text := '[' + AField + ']'; // do not localize\r\n end;\r\n end\r\n else\r\n if AForm.Components[I] is TJvCSVCheckBox then\r\n begin\r\n ck := TJvCSVCheckBox(AForm.Components[I]);\r\n if ck.CSVDataBase = Self then\r\n begin\r\n AField := ck.CSVField;\r\n Index := CSVFieldNames.IndexOf(AField);\r\n if Index <> -1 then\r\n if FDBCursor > 0 then\r\n ck.Checked := FDBRecord[Index] = 'True' // do not localize\r\n else\r\n ck.Checked := False;\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvCSVBase.SetCSVFileName(const Value: string);\r\nbegin\r\n if Value <> FCSVFileName then\r\n begin\r\n DataBaseClose;\r\n FCSVFileName := Value;\r\n if FileExists(CSVFileName) then\r\n DataBaseOpen(CSVFileName)\r\n else\r\n DataBaseCreate(CSVFileName, nil);\r\n end;\r\nend;\r\n\r\nprocedure TJvCSVBase.Display;\r\nbegin\r\n DoCursorChange;\r\nend;\r\n\r\nprocedure TJvCSVBase.RecordPost;\r\nvar\r\n AForm: TForm;\r\n I, Index: Integer;\r\n ed: TJvCSVEdit;\r\n cbo: TJvCSVComboBox;\r\n ck: TJvCSVCheckBox;\r\n AField: string;\r\nbegin\r\n if FDBCursor < 1 then\r\n Exit;\r\n AForm := TForm(Self.Owner);\r\n if AForm is TComponent then\r\n begin\r\n for I := 0 to AForm.ComponentCount - 1 do\r\n if AForm.Components[I] is TJvCSVEdit then\r\n begin\r\n ed := TJvCSVEdit(AForm.Components[I]);\r\n if ed.CSVDataBase = Self then\r\n begin\r\n AField := ed.CSVField;\r\n Index := CSVFieldNames.IndexOf(AField);\r\n if Index <> -1 then\r\n FDBRecord[Index] := ed.Text;\r\n end;\r\n end\r\n else\r\n if AForm.Components[I] is TJvCSVComboBox then\r\n begin\r\n cbo := TJvCSVComboBox(AForm.Components[I]);\r\n if cbo.CSVDataBase = Self then\r\n begin\r\n AField := cbo.CSVField;\r\n Index := CSVFieldNames.IndexOf(AField);\r\n if Index <> -1 then\r\n FDBRecord[Index] := cbo.Text;\r\n end;\r\n end\r\n else\r\n if AForm.Components[I] is TJvCSVCheckBox then\r\n begin\r\n ck := TJvCSVCheckBox(AForm.Components[I]);\r\n if ck.CSVDataBase = Self then\r\n begin\r\n AField := ck.CSVField;\r\n Index := CSVFieldNames.IndexOf(AField);\r\n if Index <> -1 then\r\n if ck.Checked then\r\n FDBRecord[Index] := 'True' // do not localize\r\n else\r\n FDBRecord[Index] := 'False'; // do not localize\r\n end;\r\n end;\r\n end;\r\n\r\n FDB[FDBCursor] := FDBRecord.CommaText;\r\n FDB.SaveToFile(CSVFileName);\r\nend;\r\n\r\nfunction TJvCSVBase.GetCSVFieldNames: TStrings;\r\nbegin\r\n Result := FCSVFieldNames;\r\nend;\r\n\r\nprocedure TJvCSVBase.SetCSVFieldNames(const Value: TStrings);\r\nvar\r\n OldFile: string;\r\nbegin\r\n if (CSVFileName <> '') and (Value.Count > 0) then\r\n begin\r\n OldFile := CSVFileName;\r\n DataBaseClose;\r\n FCSVFieldNames.Assign(Value);\r\n DataBaseRestructure(OldFile, Value);\r\n DataBaseOpen(OldFile);\r\n end;\r\nend;\r\n\r\n//=== { TJvCSVEdit } =========================================================\r\n\r\nprocedure TJvCSVEdit.Notification(AComponent: TComponent;\r\n Operation: TOperation);\r\nbegin\r\n inherited Notification(AComponent, Operation);\r\n if (Operation = opRemove) and (AComponent = FCSVDataBase) then\r\n begin\r\n FCSVDataBase := nil;\r\n FCSVField := '';\r\n end;\r\nend;\r\n\r\nprocedure TJvCSVEdit.SetCSVDataBase(const Value: TJvCSVBase);\r\nbegin\r\n ReplaceComponentReference(Self, Value, TComponent(FCSVDataBase));\r\nend;\r\n\r\nprocedure TJvCSVEdit.SetCSVField(const Value: string);\r\nbegin\r\n if Value <> FCSVField then\r\n begin\r\n FCSVField := Value;\r\n if Assigned(FCSVDataBase) then\r\n CSVDataBase.Display;\r\n end;\r\nend;\r\n\r\n//=== { TJvCSVNavigator } ====================================================\r\n\r\nconstructor TJvCSVNavigator.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n IncludeThemeStyle(Self, [csParentBackground]);\r\n Caption := '';\r\n Height := 24;\r\n Width := 217;\r\n CreateButtons;\r\nend;\r\n\r\nprocedure TJvCSVNavigator.BtnAddClick(Sender: TObject);\r\nbegin\r\n if Assigned(FCSVDataBase) then\r\n CSVDataBase.RecordNew;\r\nend;\r\n\r\nprocedure TJvCSVNavigator.BtnDeleteClick(Sender: TObject);\r\nbegin\r\n if Assigned(FCSVDataBase) then\r\n CSVDataBase.RecordDelete;\r\nend;\r\n\r\nprocedure TJvCSVNavigator.BtnFindClick(Sender: TObject);\r\nvar\r\n AText: string;\r\nbegin\r\n if Assigned(FCSVDataBase) then\r\n begin\r\n AText := inputbox(RsCVSDatabase, RsFindText, '');\r\n if AText <> '' then\r\n CSVDataBase.RecordFind(AText);\r\n end;\r\nend;\r\n\r\nprocedure TJvCSVNavigator.BtnFirstClick(Sender: TObject);\r\nbegin\r\n if Assigned(FCSVDataBase) then\r\n CSVDataBase.RecordFirst;\r\nend;\r\n\r\nprocedure TJvCSVNavigator.BtnLastClick(Sender: TObject);\r\nbegin\r\n if Assigned(FCSVDataBase) then\r\n CSVDataBase.RecordLast;\r\nend;\r\n\r\nprocedure TJvCSVNavigator.BtnNextClick(Sender: TObject);\r\nbegin\r\n if Assigned(FCSVDataBase) then\r\n CSVDataBase.RecordNext;\r\nend;\r\n\r\nprocedure TJvCSVNavigator.BtnPostClick(Sender: TObject);\r\nbegin\r\n if Assigned(FCSVDataBase) then\r\n CSVDataBase.RecordPost;\r\nend;\r\n\r\nprocedure TJvCSVNavigator.BtnPreviousClick(Sender: TObject);\r\nbegin\r\n if Assigned(FCSVDataBase) then\r\n CSVDataBase.RecordPrevious;\r\nend;\r\n\r\nprocedure TJvCSVNavigator.BtnRefreshClick(Sender: TObject);\r\nbegin\r\n if Assigned(FCSVDataBase) then\r\n CSVDataBase.Display;\r\nend;\r\n\r\nprocedure TJvCSVNavigator.CreateButtons;\r\n\r\n procedure InitButton(var Btn: TSpeedButton; ALeft: Integer; GlyphName: string;\r\n ClickEvent: TNotifyEvent; AHint: string);\r\n begin\r\n Btn := TSpeedButton.Create(Self);\r\n Btn.Width := 23;\r\n Btn.Height := 22;\r\n Btn.Flat := True;\r\n Btn.Top := 1;\r\n Btn.Left := ALeft;\r\n Btn.Glyph.LoadFromResourceName(HInstance, GlyphName);\r\n Btn.OnClick := ClickEvent;\r\n Btn.Hint := AHint;\r\n Btn.Parent := Self;\r\n end;\r\n\r\nbegin\r\n ShowHint := True;\r\n InitButton(FBtnFirst, 1, 'JVCSVFIRST', BtnFirstClick, RsFirstHint); // do not localize\r\n InitButton(FBtnPrevious, 25, 'JVCSVPREVIOUS', BtnPreviousClick, RsPreviousHint); // do not localize\r\n InitButton(FBtnFind, 49, 'JVCSVFIND', BtnFindClick, RsFindHint); // do not localize\r\n InitButton(FBtnNext, 73, 'JVCSVNEXT', BtnNextClick, RsNextHint); // do not localize\r\n InitButton(FBtnLast, 97, 'JVCSVLAST', BtnLastClick, RsLastHint); // do not localize\r\n InitButton(FBtnAdd, 121, 'JVCSVADD', BtnAddClick, RsAddHint); // do not localize\r\n InitButton(FBtnDelete, 145, 'JVCSVDELETE', BtnDeleteClick, RsDeleteHint); // do not localize\r\n InitButton(FBtnPost, 169, 'JVCSVPOST', BtnPostClick, RsPostHint); // do not localize\r\n InitButton(FBtnRefresh, 193, 'JVCSVREFRESH', BtnRefreshClick, RsRefreshHint); // do not localize\r\nend;\r\n\r\n\r\nprocedure TJvCSVNavigator.CreateWnd;\r\nbegin\r\n inherited CreateWnd;\r\n Caption := '';\r\nend;\r\n\r\n\r\nprocedure TJvCSVNavigator.Notification(AComponent: TComponent;\r\n Operation: TOperation);\r\nbegin\r\n inherited Notification(AComponent, Operation);\r\n if (Operation = opRemove) and (AComponent = FCSVDataBase) then\r\n FCSVDataBase := nil;\r\nend;\r\n\r\nprocedure TJvCSVNavigator.BoundsChanged;\r\nbegin\r\n Height := 24;\r\n if Width < 221 then\r\n Width := 221;\r\n inherited BoundsChanged;\r\nend;\r\n\r\nprocedure TJvCSVNavigator.SetCSVDataBase(const Value: TJvCSVBase);\r\nbegin\r\n ReplaceComponentReference(Self, Value, TComponent(FCSVDataBase));\r\nend;\r\n\r\n//=== { TJvCSVComboBox } =====================================================\r\n\r\nprocedure TJvCSVComboBox.Notification(AComponent: TComponent;\r\n Operation: TOperation);\r\nbegin\r\n inherited Notification(AComponent, Operation);\r\n if (Operation = opRemove) and (AComponent = FCSVDataBase) then\r\n begin\r\n FCSVDataBase := nil;\r\n FCSVField := '';\r\n end;\r\nend;\r\n\r\nprocedure TJvCSVComboBox.SetCSVDataBase(const Value: TJvCSVBase);\r\nbegin\r\n ReplaceComponentReference(Self, Value, TComponent(FCSVDataBase));\r\nend;\r\n\r\nprocedure TJvCSVComboBox.SetCSVField(const Value: string);\r\nbegin\r\n if Value <> FCSVField then\r\n begin\r\n FCSVField := Value;\r\n if Assigned(FCSVDataBase) then\r\n CSVDataBase.Display;\r\n end;\r\nend;\r\n\r\n//=== { TJvCSVCheckBox } =====================================================\r\n\r\nprocedure TJvCSVCheckBox.Notification(AComponent: TComponent;\r\n Operation: TOperation);\r\nbegin\r\n inherited Notification(AComponent, Operation);\r\n if (Operation = opRemove) and (AComponent = FCSVDataBase) then\r\n begin\r\n FCSVDataBase := nil;\r\n FCSVField := '';\r\n end;\r\nend;\r\n\r\nprocedure TJvCSVCheckBox.SetCSVDataBase(const Value: TJvCSVBase);\r\nbegin\r\n ReplaceComponentReference(Self, Value, TComponent(FCSVDataBase));\r\nend;\r\n\r\nprocedure TJvCSVCheckBox.SetCSVField(const Value: string);\r\nbegin\r\n if Value <> FCSVField then\r\n begin\r\n FCSVField := Value;\r\n if Assigned(FCSVDataBase) then\r\n CSVDataBase.Display;\r\n end;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend." }, { "path": "External/Jedi/Jvcl/run/JvCabFile.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvCABFile.PAS, released on 2001-02-28.\r\n\r\nThe Initial Developer of the Original Code is Sbastien Buysse [sbuysse att buypin dott com]\r\nPortions created by Sbastien Buysse are Copyright (C) 2001 Sbastien Buysse.\r\nAll Rights Reserved.\r\n\r\nContributor(s): Michael Beck [mbeck att bigfoot dott com].\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvCabFile.pas 13348 2012-06-13 14:09:21Z obones $\r\n\r\nunit JvCabFile;\r\n\r\n{$I jvcl.inc}\r\n{$I windowsonly.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, SysUtils, Classes,\r\n JvTypes, JvComponentBase;\r\n\r\ntype\r\n TCABInfo = record\r\n CabinetPath: string;\r\n CabinetFile: string;\r\n DiskName: string;\r\n Id: Shortint;\r\n CabinetNumber: Shortint;\r\n end;\r\n\r\n TOnCABInfo = procedure(Sender: TObject; CABInfo: TCABInfo) of object;\r\n TOnExtracted = procedure(Sender: TObject; Successed: Boolean; var Cont: Boolean;\r\n Source, Dest: string) of object;\r\n TOnExtractFile = procedure(Sender: TObject; FileName: string; DestPath: string) of object;\r\n TOnNeedNewCabinet = procedure(Sender: TObject; var Cont: Boolean; CABInfo: TCABInfo;\r\n var NewPath: string) of object;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvCABFile = class(TJvComponent)\r\n private\r\n FFileName: TFileName;\r\n FFiles: TStringList;\r\n FOnCABInfo: TOnCABInfo;\r\n FOnFiles: TNotifyEvent;\r\n FOnExtracted: TOnExtracted;\r\n FDestPath: string;\r\n FOnExtractFile: TOnExtractFile;\r\n FOnNeed: TOnNeedNewCabinet;\r\n FTmpString: string;\r\n function GetFiles: TStrings;\r\n procedure SetFileName(const Value: TFileName);\r\n procedure SetFiles(const Value: TStrings);\r\n procedure RefreshFiles;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n function ExtractAll(DestPath: string): Boolean;\r\n function ExtractFile(FileName: string; DestPath: string): Boolean;\r\n published\r\n property FileName: TFileName read FFileName write SetFileName;\r\n property Files: TStrings read GetFiles write SetFiles;\r\n property OnCABInfo: TOnCABInfo read FOnCABInfo write FOnCABInfo;\r\n property OnFilesListed: TNotifyEvent read FOnFiles write FOnFiles;\r\n property OnFileExtracted: TOnExtracted read FOnExtracted write FOnExtracted;\r\n property OnStartFileExtraction: TOnExtractFile read FOnExtractFile write FOnExtractFile;\r\n property OnNeedNewCabinet: TOnNeedNewCabinet read FOnNeed write FOnNeed;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvCabFile.pas $';\r\n Revision: '$Revision: 13348 $';\r\n Date: '$Date: 2012-06-13 16:09:21 +0200 (mer. 13 juin 2012) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n StrUtils, WinConvTypes, JvSetupAPI,\r\n JvConsts, JvResources;\r\n\r\nconstructor TJvCABFile.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FFiles := TStringList.Create;\r\n FFileName := '';\r\n LoadSetupApi;\r\n if not IsSetupApiLoaded then\r\n raise EJVCLException.CreateRes(@RsEErrorSetupDll);\r\nend;\r\n\r\ndestructor TJvCABFile.Destroy;\r\nbegin\r\n FFiles.Free;\r\n UnloadSetupApi;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvCABFile.SetFileName(const Value: TFileName);\r\nbegin\r\n FFileName := Value;\r\n RefreshFiles;\r\nend;\r\n\r\nfunction TJvCABFile.GetFiles: TStrings;\r\nbegin\r\n Result := FFiles;\r\nend;\r\n\r\nprocedure TJvCABFile.SetFiles(const Value: TStrings);\r\nbegin\r\n //do nothing !!!!\r\nend;\r\n\r\nfunction CBack(Context: Pointer; Notification: UINT; Param1, Param2: UINT_PTR): UINT; stdcall;\r\nvar\r\n CAB: PFileInCabinetInfo;\r\n Sender: TJvCABFile;\r\n CABInfo: TCABInfo;\r\n ParamInfo: PCabinetInfo;\r\nbegin\r\n Result := ERROR_BAD_COMMAND;\r\n if Context <> nil then\r\n Sender := TJvCABFile(Context^)\r\n else\r\n Exit;\r\n\r\n // this callback is only for listing files in a Cabinet ... pouet pouet !\r\n if Notification = SPFILENOTIFY_FILEINCABINET then // found a file in the Cabinet\r\n begin\r\n Result := FILEOP_SKIP;\r\n CAB := PFileInCabinetInfo(Param1);\r\n Sender.Files.Add(StrPas(CAB^.NameInCabinet));\r\n end\r\n else\r\n if Notification = SPFILENOTIFY_CABINETINFO then // give Cabinet info\r\n begin\r\n if Assigned(Sender.FOnCABInfo) and (Param1 <> 0) then\r\n begin\r\n ParamInfo := PCabinetInfo(Param1);\r\n CABInfo.CabinetPath := StrPas(ParamInfo^.CabinetPath);\r\n CABInfo.CabinetFile := StrPas(ParamInfo^.CabinetFile);\r\n CABInfo.DiskName := StrPas(ParamInfo^.DiskName);\r\n CABInfo.Id := ParamInfo^.SetId;\r\n CABInfo.CabinetNumber := ParamInfo^.CabinetNumber;\r\n Sender.FOnCABInfo(Sender, CABInfo);\r\n end;\r\n Result := 0;\r\n end;\r\nend;\r\n\r\nfunction CExtract(Context: Pointer; Notification: UINT; Param1, Param2: UINT_PTR): UINT; stdcall;\r\ntype\r\n PUINT_PTR = ^UINT_PTR;\r\nvar\r\n CAB: PFileInCabinetInfo;\r\n Sender: TJvCABFile;\r\n CABInfo: TCABInfo;\r\n Cont: Boolean;\r\n Pathes: TFilePaths;\r\n Path: string;\r\n I: Integer;\r\nbegin\r\n Result := ERROR_BAD_COMMAND;\r\n if Context <> nil then\r\n Sender := TJvCABFile(Context^)\r\n else\r\n Exit;\r\n\r\n // this callback is only for listing files in a Cabinet ...\r\n if Notification = SPFILENOTIFY_CABINETINFO then\r\n Result := 0\r\n else\r\n if Notification = SPFILENOTIFY_FILEINCABINET then // found a file in the Cabinet\r\n begin\r\n try\r\n Result := FILEOP_DOIT;\r\n CAB := PFileInCabinetInfo(Param1);\r\n\r\n if Sender.FDestPath[Length(Sender.FDestPath)] = '\\' then\r\n begin\r\n // extract all\r\n Path := Sender.FDestPath + StrPas(CAB^.NameInCabinet);\r\n for I := 1 to Length(Path) do\r\n CAB^.FullTargetName[I-1] := Path[I];\r\n CAB^.FullTargetName[Length(Path)] := #0;\r\n\r\n if Assigned(Sender.FOnExtractFile) then\r\n Sender.FOnExtractFile(Sender, CAB^.FullTargetName, Sender.FDestPath);\r\n end\r\n else\r\n begin\r\n // Extract specific file\r\n if AnsiEndsText(StrPas(CAB^.NameInCabinet), Sender.FDestPath) then\r\n begin\r\n Path := Sender.FDestPath;\r\n for I := 1 to Length(Path) do\r\n CAB^.FullTargetName[I-1] := Path[I];\r\n CAB^.FullTargetName[Length(Path)] := #0;\r\n if Assigned(Sender.FOnExtractFile) then\r\n Sender.FOnExtractFile(Sender, CAB^.FullTargetName, Sender.FDestPath);\r\n end\r\n else\r\n Result := FILEOP_SKIP;\r\n end;\r\n except\r\n Result := FILEOP_SKIP;\r\n end;\r\n end\r\n else\r\n if Notification = SPFILENOTIFY_FILEEXTRACTED then\r\n begin\r\n Cont := True;\r\n if Param1 <> 0 then\r\n Pathes := PFilePaths(Param1)^;\r\n if Assigned(Sender.FOnExtracted) then\r\n Sender.FOnExtracted(Sender, (Pathes.Win32Error = NO_ERROR), Cont,\r\n StrPas(Pathes.Source), StrPas(Pathes.Target));\r\n if Cont then\r\n Result := NO_ERROR\r\n else\r\n Result := ERROR_BAD_COMMAND;\r\n end\r\n else\r\n if Notification = SPFILENOTIFY_NEEDNEWCABINET then\r\n begin\r\n if Param1 <> 0 then\r\n begin\r\n CABInfo.CabinetPath := StrPas(PCabinetInfo(Param1)^.CabinetPath);\r\n CABInfo.CabinetFile := StrPas(PCabinetInfo(Param1)^.CabinetFile);\r\n CABInfo.DiskName := StrPas(PCabinetInfo(Param1)^.DiskName);\r\n CABInfo.Id := PCabinetInfo(Param1)^.SetId;\r\n CABInfo.CabinetNumber := PCabinetInfo(Param1)^.CabinetNumber;\r\n Cont := True;\r\n Path := '';\r\n if Assigned(Sender.FOnNeed) then\r\n begin\r\n Sender.FOnNeed(Sender, Cont, CABInfo, Path);\r\n Sender.FTmpString := Path;\r\n PUINT_PTR(Param2)^ := UINT_PTR(PChar(Sender.FTmpString));\r\n end\r\n else\r\n Result := ERROR_BAD_COMMAND;\r\n end\r\n else\r\n Result := ERROR_BAD_COMMAND;\r\n end;\r\nend;\r\n\r\nprocedure TJvCABFile.RefreshFiles;\r\nbegin\r\n Files.Clear;\r\n if SetupIterateCabinet(PChar(FFileName), 0, CBack, @Self) then\r\n if Assigned(FOnFiles) then\r\n FOnFiles(Self);\r\nend;\r\n\r\nfunction TJvCABFile.ExtractAll(DestPath: string): Boolean;\r\nbegin\r\n if DestPath[Length(DestPath)] <> PathDelim then\r\n DestPath := DestPath + PathDelim;\r\n FDestPath := DestPath;\r\n Result := SetupIterateCabinet(PChar(FFileName), 0, CExtract, @Self);\r\nend;\r\n\r\nfunction TJvCABFile.ExtractFile(FileName, DestPath: string): Boolean;\r\nbegin\r\n if DestPath[Length(DestPath)] <> PathDelim then\r\n DestPath := DestPath + PathDelim;\r\n FDestPath := DestPath + FileName;\r\n Result := SetupIterateCabinet(PChar(FFileName), 0, CExtract, @Self);\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvCalc.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvCalc.PAS, released on 2002-07-04.\r\n\r\nThe Initial Developers of the Original Code are: Fedor Koshevnikov, Igor Pavluk and Serge Korolev\r\nCopyright (c) 1997, 1998 Fedor Koshevnikov, Igor Pavluk and Serge Korolev\r\nCopyright (c) 2001,2002 SGB Software\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\n Polaris Software\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvCalc.pas 13413 2012-09-08 11:02:21Z ahuser $\r\n\r\nunit JvCalc;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, Messages, Classes, Controls, Forms, StdCtrls, Menus, ExtCtrls,\r\n JvBaseDlg, JvComponent;\r\n\r\nconst\r\n DefCalcPrecision = 15;\r\n\r\ntype\r\n TJvCalcState = (csFirst, csValid, csError);\r\n TJvCalculatorForm = class;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64 or pidOSX32)]\r\n {$ENDIF RTL230_UP}\r\n TJvCalculator = class(TJvCommonDialog)\r\n private\r\n FValue: Double;\r\n FMemory: Double;\r\n FTitle: string;\r\n FFlat: Boolean;\r\n FPrecision: Byte;\r\n FBeepOnError: Boolean;\r\n FHelpContext: THelpContext;\r\n FCalc: TJvCalculatorForm;\r\n FOnChange: TNotifyEvent;\r\n FOnCalcKey: TKeyPressEvent;\r\n FOnDisplayChange: TNotifyEvent;\r\n function GetDisplay: Double;\r\n function GetTitle: string;\r\n procedure SetTitle(const Value: string);\r\n function TitleStored: Boolean;\r\n procedure ReadCtl3D(Reader: TReader);\r\n protected\r\n procedure Change; dynamic;\r\n procedure CalcKey(var Key: Char); dynamic;\r\n procedure DisplayChange; dynamic;\r\n procedure DefineProperties(Filer: TFiler); override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n function Execute(ParentWnd: HWND): Boolean; overload; override;\r\n\r\n property CalcDisplay: Double read GetDisplay;\r\n property Memory: Double read FMemory;\r\n published\r\n property BeepOnError: Boolean read FBeepOnError write FBeepOnError default True;\r\n property HelpContext: THelpContext read FHelpContext write FHelpContext default 0;\r\n property Precision: Byte read FPrecision write FPrecision default DefCalcPrecision;\r\n property Title: string read GetTitle write SetTitle stored TitleStored;\r\n property Value: Double read FValue write FValue;\r\n property OnCalcKey: TKeyPressEvent read FOnCalcKey write FOnCalcKey;\r\n property OnChange: TNotifyEvent read FOnChange write FOnChange;\r\n property OnDisplayChange: TNotifyEvent read FOnDisplayChange write FOnDisplayChange;\r\n property Flat: Boolean read FFlat write FFlat default False;\r\n end;\r\n\r\n TJvCalculatorForm = class(TJvForm)\r\n private\r\n FMainPanel: TPanel;\r\n FCalcPanel: TPanel;\r\n FDisplayPanel: TPanel;\r\n FDisplayLabel: TLabel;\r\n FPasteItem: TMenuItem;\r\n FParentWnd: HWND;\r\n procedure FormKeyPress(Sender: TObject; var Key: Char);\r\n procedure PopupMenuPopup(Sender: TObject);\r\n procedure CopyItemClick(Sender: TObject);\r\n procedure PasteItemClick(Sender: TObject);\r\n procedure CMCtl3DChanged(var Msg: TMessage); message CM_CTL3DCHANGED;\r\n protected\r\n procedure OkClick(Sender: TObject);\r\n procedure CancelClick(Sender: TObject);\r\n procedure CalcKey(Sender: TObject; var Key: Char);\r\n procedure DisplayChange(Sender: TObject);\r\n procedure CreateParams(var Params: TCreateParams); override;\r\n public\r\n constructor Create(AOwner: TComponent); overload; override;\r\n constructor Create(AOwner: TComponent; AParentWnd: HWND); reintroduce; overload;\r\n end;\r\n\r\nfunction CreateCalculatorForm(AOwner: TComponent; AHelpContext: THelpContext; AOwnerWnd: HWND): TJvCalculatorForm;\r\nfunction CreatePopupCalculator(AOwner: TComponent; ABiDiMode: TBiDiMode = bdLeftToRight): TWinControl;\r\nprocedure SetupPopupCalculator(PopupCalc: TWinControl; APrecision: Byte; ABeepOnError: Boolean);\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvCalc.pas $';\r\n Revision: '$Revision: 13413 $';\r\n Date: '$Date: 2012-09-08 13:02:21 +0200 (sam. 08 sept. 2012) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n Variants, SysUtils, Math, Graphics, Buttons, Clipbrd,\r\n JvToolEdit, JvSpeedButton, JvExExtCtrls,\r\n JvJVCLUtils, JvJCLUtils, JvConsts, JvResources, JclSysUtils;\r\n\r\n{$R JvCalc.Res} // (ahuser) the filename should be fixed\r\n\r\ntype\r\n TCalcBtnKind =\r\n (cbNone, cbNum0, cbNum1, cbNum2, cbNum3, cbNum4, cbNum5, cbNum6,\r\n cbNum7, cbNum8, cbNum9, cbSgn, cbDcm, cbDiv, cbMul, cbSub,\r\n cbAdd, cbSqr, cbPcnt, cbRev, cbEql, cbBck, cbClr, cbMP,\r\n cbMS, cbMR, cbMC, cbOk, cbCancel);\r\n\r\n TCalcPanelLayout = (clDialog, clPopup);\r\n\r\n TCustomLabelAccessProtected = class(TCustomLabel);\r\n\r\n TJvCalcButton = class(TJvSpeedButton)\r\n private\r\n FKind: TCalcBtnKind;\r\n FFontChanging: Boolean;\r\n protected\r\n procedure ParentFontChanged; override;\r\n public\r\n constructor CreateKind(AOwner: TComponent; AKind: TCalcBtnKind);\r\n property Kind: TCalcBtnKind read FKind;\r\n end;\r\n\r\n TJvCalculatorPanel = class(TJvExPanel)\r\n private\r\n FText: string;\r\n FStatus: TJvCalcState;\r\n FOperator: Char;\r\n FOperand: Double;\r\n FMemory: Double;\r\n FPrecision: Byte;\r\n FBeepOnError: Boolean;\r\n FMemoryPanel: TPanel;\r\n FMemoryLabel: TLabel;\r\n FOnError: TNotifyEvent;\r\n FOnOk: TNotifyEvent;\r\n FOnCancel: TNotifyEvent;\r\n FOnResult: TNotifyEvent;\r\n FOnTextChange: TNotifyEvent;\r\n FOnCalcKey: TKeyPressEvent;\r\n FOnDisplayChange: TNotifyEvent;\r\n FControl: TControl;\r\n procedure SetText(const Value: string);\r\n procedure CheckFirst;\r\n procedure CalcKey(Key: Char);\r\n procedure Clear;\r\n procedure Error;\r\n procedure SetDisplay(R: Double);\r\n function GetDisplay: Double;\r\n procedure UpdateMemoryLabel;\r\n function FindButton(Key: Char): TJvSpeedButton;\r\n procedure CMCtl3DChanged(var Msg: TMessage); message CM_CTL3DCHANGED;\r\n procedure BtnClick(Sender: TObject);\r\n protected\r\n procedure TextChange; virtual;\r\n public\r\n constructor CreateLayout(AOwner: TComponent; ALayout: TCalcPanelLayout);\r\n procedure CalcKeyPress(Sender: TObject; var Key: Char);\r\n procedure Copy;\r\n procedure Paste;\r\n property DisplayValue: Double read GetDisplay write SetDisplay;\r\n property Text: string read FText;\r\n property OnOkClick: TNotifyEvent read FOnOk write FOnOk;\r\n property OnCancelClick: TNotifyEvent read FOnCancel write FOnCancel;\r\n property OnResultClick: TNotifyEvent read FOnResult write FOnResult;\r\n property OnError: TNotifyEvent read FOnError write FOnError;\r\n property OnTextChange: TNotifyEvent read FOnTextChange write FOnTextChange;\r\n property OnCalcKey: TKeyPressEvent read FOnCalcKey write FOnCalcKey;\r\n property OnDisplayChange: TNotifyEvent read FOnDisplayChange write FOnDisplayChange;\r\n end;\r\n\r\n TJvLocCalculator = class(TJvCalculatorPanel)\r\n protected\r\n procedure EnabledChanged; override;\r\n procedure CreateParams(var Params: TCreateParams); override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n end;\r\n\r\n TJvPopupCalculator = class(TJvPopupWindow)\r\n private\r\n FCalcPanel: TJvLocCalculator;\r\n procedure TextChange(Sender: TObject);\r\n procedure ResultClick(Sender: TObject);\r\n protected\r\n procedure KeyPress(var Key: Char); override;\r\n function GetValue: Variant; override;\r\n procedure SetValue(const Value: Variant); override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n function GetPopupText: string; override;\r\n end;\r\n\r\nconst\r\n BtnPos: array [TCalcPanelLayout, TCalcBtnKind] of TPoint =\r\n (((X: - 1; Y: - 1), (X: 47; Y: 104), (X: 47; Y: 80), (X: 85; Y: 80),\r\n (X: 123; Y: 80), (X: 47; Y: 56), (X: 85; Y: 56), (X: 123; Y: 56),\r\n (X: 47; Y: 32), (X: 85; Y: 32), (X: 123; Y: 32), (X: 85; Y: 104),\r\n (X: 123; Y: 104), (X: 161; Y: 32), (X: 161; Y: 56), (X: 161; Y: 80),\r\n (X: 161; Y: 104), (X: 199; Y: 32), (X: 199; Y: 56), (X: 199; Y: 80),\r\n (X: 199; Y: 104), (X: 145; Y: 6), (X: 191; Y: 6), (X: 5; Y: 104),\r\n (X: 5; Y: 80), (X: 5; Y: 56), (X: 5; Y: 32),\r\n (X: 47; Y: 6), (X: 85; Y: 6)),\r\n {PopUp}\r\n {cbNone cbNum0 cbNum1 cbNum2}\r\n ((X: - 1; Y: - 1), (X: 6; Y: 75), (X: 6; Y: 52), (X: 29; Y: 52),\r\n {cbNum3 cbNum4 cbNum5 cbNum6}\r\n (X: 52; Y: 52), (X: 6; Y: 29), (X: 29; Y: 29), (X: 52; Y: 29),\r\n {cbNum7 cbNum8 cbNum9 cbSgn}\r\n (X: 6; Y: 6), (X: 29; Y: 6), (X: 52; Y: 6), (X: 52; Y: 75),\r\n {cbDcm cbDiv cbMul cbSub}\r\n (X: 29; Y: 75), (X: 75; Y: 6), (X: 75; Y: 29), (X: 75; Y: 52),\r\n {cbAdd cbSqr cbPcnt cbRev}\r\n//Polaris (X: 75; Y: 75), (X: -1; Y: -1), (X: -1; Y: -1), (X: -1; Y: -1),\r\n (X: 75; Y: 75), (X: 98; Y: 6), (X: 98; Y: 29), (X: 98; Y: 52),\r\n {cbEql cbBck cbClr cbMP}\r\n//Polaris (X: 52; Y: 98), (X: 29; Y: 98), (X: 6; Y: 98), (X: -1; Y: -1),\r\n (X: 98; Y: 75), (X: 29; Y: 98), (X: 6; Y: 98), (X: - 1; Y: - 1),\r\n {cbMS cbMR cbMC}\r\n (X: - 1; Y: - 1), (X: - 1; Y: - 1), (X: - 1; Y: - 1),\r\n {cbOk cbCancel}\r\n (X: - 1; Y: - 1), (X: - 1; Y: - 1)));\r\n\r\n {((X: - 1; Y: - 1), (X: 6; Y: 75), (X: 6; Y: 52), (X: 29; Y: 52),\r\n (X: 52; Y: 52), (X: 6; Y: 29), (X: 29; Y: 29), (X: 52; Y: 29),\r\n (X: 6; Y: 6), (X: 29; Y: 6), (X: 52; Y: 6), (X: 52; Y: 75),\r\n (X: 29; Y: 75), (X: 75; Y: 6), (X: 75; Y: 29), (X: 75; Y: 52),\r\n (X: 75; Y: 75), (X: - 1; Y: - 1), (X: - 1; Y: - 1), (X: - 1; Y: - 1),\r\n (X: 52; Y: 98), (X: 29; Y: 98), (X: 6; Y: 98), (X: - 1; Y: - 1),\r\n (X: - 1; Y: - 1), (X: - 1; Y: - 1), (X: - 1; Y: - 1),\r\n (X: - 1; Y: - 1), (X: - 1; Y: - 1)));}\r\n\r\n ResultKeys = [Cr, '=', '%'];\r\n\r\n//=== Local procedures =======================================================\r\n\r\nprocedure SetDefaultFont(AFont: TFont; Layout: TCalcPanelLayout);\r\n\r\nvar\r\n NonClientMetrics: TNonClientMetrics;\r\n\r\nbegin\r\n {$IFDEF RTL210_UP}\r\n NonClientMetrics.cbSize := TNonClientMetrics.SizeOf;\r\n {$ELSE}\r\n NonClientMetrics.cbSize := SizeOf(NonClientMetrics);\r\n {$ENDIF RTL210_UP}\r\n if SystemParametersInfo(SPI_GETNONCLIENTMETRICS, NonClientMetrics.cbSize, @NonClientMetrics, 0) then\r\n AFont.Handle := CreateFontIndirect(NonClientMetrics.lfMessageFont)\r\n else\r\n begin\r\n AFont.Color := clWindowText;\r\n AFont.Name := 'MS Sans Serif';\r\n AFont.Size := 8;\r\n end;\r\n AFont.Style := [fsBold];\r\n {\r\n if Layout = clDialog then\r\n begin\r\n end\r\n else\r\n begin\r\n end;\r\n }\r\nend;\r\n\r\nfunction CreateCalcBtn(AParent: TWinControl; AKind: TCalcBtnKind;\r\n AOnClick: TNotifyEvent; ALayout: TCalcPanelLayout): TJvCalcButton;\r\nconst\r\n BtnCaptions: array [cbSgn..cbMC] of string =\r\n ('', ',', '/', '*', '-', '+', 'sqrt', '%', '1/x', '=', '<-', 'C',\r\n 'MP', 'MS', 'MR', 'MC');\r\nbegin\r\n Result := TJvCalcButton.CreateKind(AParent, AKind);\r\n with Result do\r\n try\r\n if Kind in [cbNum0..cbNum9] then\r\n Caption := IntToStr(Tag)\r\n else\r\n if Kind = cbDcm then\r\n Caption := JclFormatSettings.DecimalSeparator\r\n else\r\n if Kind in [cbSgn..cbMC] then\r\n Caption := BtnCaptions[Kind];\r\n Left := BtnPos[ALayout, Kind].X;\r\n Top := BtnPos[ALayout, Kind].Y;\r\n if ALayout = clDialog then\r\n begin\r\n Width := 36;\r\n Height := 22;\r\n end\r\n else\r\n begin\r\n Width := 21;\r\n Height := 21;\r\n end;\r\n Style := bsNew;\r\n OnClick := AOnClick;\r\n ParentFont := True;\r\n Parent := AParent;\r\n except\r\n Free;\r\n raise;\r\n end;\r\nend;\r\n\r\n//=== Global procedures ======================================================\r\n\r\nfunction CreateCalculatorForm(AOwner: TComponent; AHelpContext: THelpContext; AOwnerWnd: HWND): TJvCalculatorForm;\r\nbegin\r\n Result := TJvCalculatorForm.Create(AOwner, AOwnerWnd);\r\n with Result do\r\n try\r\n HelpContext := AHelpContext;\r\n if HelpContext <> 0 then\r\n BorderIcons := BorderIcons + [biHelp];\r\n if Screen.PixelsPerInch <> 96 then\r\n begin { scale to screen res }\r\n ScaleBy(Screen.PixelsPerInch, 96);\r\n SetDefaultFont(Font, clDialog);\r\n Left := (Screen.Width div 2) - (Width div 2);\r\n Top := (Screen.Height div 2) - (Height div 2);\r\n end;\r\n except\r\n Free;\r\n raise;\r\n end;\r\nend;\r\n\r\nfunction CreatePopupCalculator(AOwner: TComponent; ABiDiMode: TBiDiMode = bdLeftToRight): TWinControl;\r\nbegin\r\n Result := TJvPopupCalculator.Create(AOwner);\r\n // ahuser: reported as a bug (Mantis #2048)\r\n (*\r\n if (AOwner <> nil) and not (csDesigning in AOwner.ComponentState) and\r\n (Screen.PixelsPerInch <> 96) then\r\n begin { scale to screen res }\r\n Result.ScaleBy(Screen.PixelsPerInch, 96);\r\n { The ScaleBy method does not scale the font well, so set the\r\n font back to the original info. }\r\n TJvPopupCalculator(Result).FCalcPanel.ParentFont := True;\r\n SetDefaultFont(TJvPopupCalculator(Result).Font, clPopup);\r\n end;\r\n *)\r\n Result.BiDiMode := ABiDiMode;\r\nend;\r\n\r\nprocedure SetupPopupCalculator(PopupCalc: TWinControl; APrecision: Byte;\r\n ABeepOnError: Boolean);\r\nbegin\r\n if (PopupCalc <> nil) and (PopupCalc is TJvPopupCalculator) then\r\n if TJvPopupCalculator(PopupCalc).FCalcPanel <> nil then\r\n with TJvPopupCalculator(PopupCalc).FCalcPanel do\r\n begin\r\n FPrecision := Max(2, APrecision);\r\n FBeepOnError := ABeepOnError;\r\n end;\r\nend;\r\n\r\n//=== { TJvCalcButton } ======================================================\r\n\r\nconstructor TJvCalcButton.CreateKind(AOwner: TComponent; AKind: TCalcBtnKind);\r\nbegin\r\n inherited Create(AOwner);\r\n ControlStyle := ControlStyle + [csReplicatable];\r\n FKind := AKind;\r\n if FKind in [cbNum0..cbClr] then\r\n Tag := Ord(Kind) - 1\r\n else\r\n Tag := -1;\r\nend;\r\n\r\nprocedure TJvCalcButton.ParentFontChanged;\r\n\r\n function BtnColor(Kind: TCalcBtnKind): TColor;\r\n begin\r\n if Kind in [cbSqr, cbPcnt, cbRev, cbMP..cbMC] then\r\n Result := clNavy\r\n else\r\n if Kind in [cbDiv, cbMul, cbSub, cbAdd, cbEql] then\r\n Result := clPurple\r\n else\r\n if Kind in [cbBck, cbClr] then\r\n Result := clMaroon\r\n else\r\n Result := clBtnText;\r\n end;\r\n\r\nbegin\r\n if not FFontChanging then\r\n inherited;\r\n if ParentFont and not FFontChanging then\r\n begin\r\n FFontChanging := True;\r\n try\r\n Font.Color := BtnColor(FKind);\r\n ParentFont := True;\r\n finally\r\n FFontChanging := False;\r\n end;\r\n end;\r\nend;\r\n\r\n//=== { TJvCalculator } ======================================================\r\n\r\nconstructor TJvCalculator.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FTitle := RsCalculatorCaption;\r\n FFlat := False;\r\n FPrecision := DefCalcPrecision;\r\n FBeepOnError := True;\r\nend;\r\n\r\nprocedure TJvCalculator.DefineProperties(Filer: TFiler);\r\nbegin\r\n inherited DefineProperties(Filer);\r\n Filer.DefineProperty('Ctl3D', ReadCtl3D, nil, False);\r\nend;\r\n\r\ndestructor TJvCalculator.Destroy;\r\nbegin\r\n FOnChange := nil;\r\n FOnDisplayChange := nil;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvCalculator.CalcKey(var Key: Char);\r\nbegin\r\n if Assigned(FOnCalcKey) then\r\n FOnCalcKey(Self, Key);\r\nend;\r\n\r\nprocedure TJvCalculator.Change;\r\nbegin\r\n if Assigned(FOnChange) then\r\n FOnChange(Self);\r\nend;\r\n\r\nprocedure TJvCalculator.DisplayChange;\r\nbegin\r\n if Assigned(FOnDisplayChange) then\r\n FOnDisplayChange(Self);\r\nend;\r\n\r\nfunction TJvCalculator.Execute(ParentWnd: HWND): Boolean;\r\nbegin\r\n if csDesigning in ComponentState then\r\n FCalc := CreateCalculatorForm(Application, HelpContext, ParentWnd)\r\n else\r\n FCalc := CreateCalculatorForm(Self, HelpContext, ParentWnd);\r\n with FCalc do\r\n try\r\n Ctl3D := not FFlat;\r\n Caption := Self.Title;\r\n TJvCalculatorPanel(FCalcPanel).FMemory := Self.FMemory;\r\n TJvCalculatorPanel(FCalcPanel).UpdateMemoryLabel;\r\n TJvCalculatorPanel(FCalcPanel).FPrecision := Max(2, Self.Precision);\r\n TJvCalculatorPanel(FCalcPanel).FBeepOnError := Self.BeepOnError;\r\n if Self.FValue <> 0 then\r\n begin\r\n TJvCalculatorPanel(FCalcPanel).DisplayValue := Self.FValue;\r\n TJvCalculatorPanel(FCalcPanel).FStatus := csFirst;\r\n TJvCalculatorPanel(FCalcPanel).FOperator := '=';\r\n end;\r\n Result := ShowModal = mrOk;\r\n if Result then\r\n begin\r\n Self.FMemory := TJvCalculatorPanel(FCalcPanel).FMemory;\r\n if TJvCalculatorPanel(FCalcPanel).DisplayValue <> Self.FValue then\r\n begin\r\n Self.FValue := TJvCalculatorPanel(FCalcPanel).DisplayValue;\r\n Change;\r\n end;\r\n end;\r\n finally\r\n Free;\r\n FCalc := nil;\r\n end;\r\nend;\r\n\r\nfunction TJvCalculator.GetDisplay: Double;\r\nbegin\r\n if Assigned(FCalc) then\r\n Result := TJvCalculatorPanel(FCalc.FCalcPanel).GetDisplay\r\n else\r\n Result := FValue;\r\nend;\r\n\r\nfunction TJvCalculator.GetTitle: string;\r\nbegin\r\n Result := FTitle;\r\nend;\r\n\r\nprocedure TJvCalculator.ReadCtl3D(Reader: TReader);\r\nbegin\r\n Flat := not Reader.ReadBoolean;\r\nend;\r\n\r\nprocedure TJvCalculator.SetTitle(const Value: string);\r\nbegin\r\n FTitle := Value;\r\nend;\r\n\r\nfunction TJvCalculator.TitleStored: Boolean;\r\nbegin\r\n Result := Title <> RsCalculatorCaption;\r\nend;\r\n\r\n//=== { TJvCalculatorForm } ==================================================\r\n\r\nconstructor TJvCalculatorForm.Create(AOwner: TComponent);\r\nvar\r\n Control: TWinControl;\r\n Popup: TPopupMenu;\r\n Items: array [0..1] of TMenuItem;\r\nbegin\r\n inherited CreateNew(AOwner, 0); // for BCB\r\n BorderIcons := [biSystemMenu];\r\n BorderStyle := bsDialog;\r\n PixelsPerInch := 96;\r\n Caption := RsCalculatorCaption;\r\n ClientHeight := 159;\r\n ClientWidth := 242;\r\n SetDefaultFont(Font, clDialog);\r\n KeyPreview := True;\r\n Position := poScreenCenter;\r\n OnKeyPress := FormKeyPress;\r\n Items[0] := NewItem(RsCopyItem, scCtrl + VK_INSERT, False, True, CopyItemClick, 0, '');\r\n Items[1] := NewItem(RsPasteItem, scShift + VK_INSERT, False, True, PasteItemClick, 0, '');\r\n FPasteItem := Items[1];\r\n Popup := NewPopupMenu(Self, 'PopupMenu', paLeft, True, Items);\r\n Popup.OnPopup := PopupMenuPopup;\r\n { MainPanel }\r\n FMainPanel := TPanel.Create(Self);\r\n with FMainPanel do\r\n begin\r\n Align := alClient;\r\n Parent := Self;\r\n BevelOuter := bvLowered;\r\n ParentColor := True;\r\n PopupMenu := Popup;\r\n end;\r\n { DisplayPanel }\r\n FDisplayPanel := TPanel.Create(Self);\r\n with FDisplayPanel do\r\n begin\r\n SetBounds(6, 6, 230, 23);\r\n Parent := FMainPanel;\r\n BevelOuter := bvLowered;\r\n Color := clWindow;\r\n Ctl3D := False;\r\n end;\r\n Control := TPanel.Create(Self);\r\n with TPanel(Control) do\r\n begin\r\n SetBounds(1, 1, 228, 21);\r\n Align := alClient;\r\n Parent := FDisplayPanel;\r\n BevelOuter := bvNone;\r\n BorderStyle := bsSingle;\r\n Ctl3D := False;\r\n ParentCtl3D := False;\r\n ParentColor := True;\r\n end;\r\n FDisplayLabel := TLabel.Create(Self);\r\n with FDisplayLabel do\r\n begin\r\n AutoSize := False;\r\n Alignment := taRightJustify;\r\n SetBounds(5, 2, 217, 15);\r\n Parent := TPanel(Control);\r\n Caption := '0';\r\n end;\r\n { CalcPanel }\r\n FCalcPanel := TJvCalculatorPanel.CreateLayout(Self, clDialog);\r\n with TJvCalculatorPanel(FCalcPanel) do\r\n begin\r\n Align := alBottom;\r\n Parent := FMainPanel;\r\n OnOkClick := Self.OkClick;\r\n OnCancelClick := Self.CancelClick;\r\n OnCalcKey := Self.CalcKey;\r\n OnDisplayChange := Self.DisplayChange;\r\n FControl := FDisplayLabel;\r\n end;\r\nend;\r\n\r\nconstructor TJvCalculatorForm.Create(AOwner: TComponent; AParentWnd: HWND);\r\nbegin\r\n FParentWnd := AParentWnd;\r\n Create(AOwner);\r\nend;\r\n\r\nprocedure TJvCalculatorForm.CreateParams(var Params: TCreateParams);\r\nbegin\r\n inherited CreateParams(Params);\r\n if FParentWnd <> 0 then\r\n Params.WndParent := FParentWnd;\r\nend;\r\n\r\nprocedure TJvCalculatorForm.CalcKey(Sender: TObject; var Key: Char);\r\nbegin\r\n if (Owner <> nil) and (Owner is TJvCalculator) then\r\n TJvCalculator(Owner).CalcKey(Key);\r\nend;\r\n\r\nprocedure TJvCalculatorForm.CancelClick(Sender: TObject);\r\nbegin\r\n ModalResult := mrCancel;\r\nend;\r\n\r\n\r\nprocedure TJvCalculatorForm.CMCtl3DChanged(var Msg: TMessage);\r\nconst\r\n Ctl3DBevel: array [Boolean] of TPanelBevel = (bvNone, bvLowered);\r\nbegin\r\n inherited;\r\n if FDisplayPanel <> nil then\r\n FDisplayPanel.BevelOuter := Ctl3DBevel[Ctl3D];\r\n if FMainPanel <> nil then\r\n FMainPanel.BevelOuter := Ctl3DBevel[Ctl3D];\r\nend;\r\n\r\n\r\nprocedure TJvCalculatorForm.CopyItemClick(Sender: TObject);\r\nbegin\r\n TJvCalculatorPanel(FCalcPanel).Copy;\r\nend;\r\n\r\nprocedure TJvCalculatorForm.DisplayChange(Sender: TObject);\r\nbegin\r\n if (Owner <> nil) and (Owner is TJvCalculator) then\r\n TJvCalculator(Owner).DisplayChange;\r\nend;\r\n\r\nprocedure TJvCalculatorForm.FormKeyPress(Sender: TObject; var Key: Char);\r\nbegin\r\n TJvCalculatorPanel(FCalcPanel).CalcKeyPress(Sender, Key);\r\nend;\r\n\r\nprocedure TJvCalculatorForm.OkClick(Sender: TObject);\r\nbegin\r\n ModalResult := mrOk;\r\nend;\r\n\r\nprocedure TJvCalculatorForm.PasteItemClick(Sender: TObject);\r\nbegin\r\n TJvCalculatorPanel(FCalcPanel).Paste;\r\nend;\r\n\r\nprocedure TJvCalculatorForm.PopupMenuPopup(Sender: TObject);\r\nbegin\r\n FPasteItem.Enabled := Clipboard.HasFormat(CF_TEXT);\r\nend;\r\n\r\n//=== { TJvCalculatorPanel } =================================================\r\n\r\nconstructor TJvCalculatorPanel.CreateLayout(AOwner: TComponent;\r\n ALayout: TCalcPanelLayout);\r\nconst\r\n BtnGlyphs: array [cbSgn..cbCancel] of Integer = (2 {Sgn}, -1, -1, 3 {Mul},\r\n 4 {Sub}, 5 {Add}, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 1 {Ok}, 0 {Cancel});\r\nvar\r\n Bmp: TBitmap;\r\n I: TCalcBtnKind;\r\nbegin\r\n inherited Create(AOwner);\r\n if ALayout = clPopup then\r\n ControlStyle := ControlStyle + [csReplicatable];\r\n ParentColor := False;\r\n Color := clBtnFace;\r\n if ALayout = clDialog then\r\n begin\r\n Height := 129;\r\n Width := 240;\r\n end\r\n else\r\n begin\r\n Height := 124;\r\n // Width := 98;\r\n Width := 131; // Polaris\r\n end;\r\n SetDefaultFont(Font, ALayout);\r\n ParentFont := False;\r\n BevelOuter := bvNone;\r\n BevelInner := bvNone;\r\n ParentColor := True;\r\n ParentCtl3D := True;\r\n if ALayout = clDialog then\r\n Bmp := TBitmap.Create\r\n else\r\n Bmp := nil;\r\n try\r\n if Bmp <> nil then\r\n// Bmp.Handle := LoadBitmap(HInstance, 'JvCalculatorPanelBUTTONS');\r\n Bmp.LoadFromResourceName(HInstance, 'JvCalculatorPanelBUTTONS');\r\n for I := cbNum0 to cbCancel do\r\n begin\r\n if BtnPos[ALayout, I].X > 0 then\r\n with CreateCalcBtn(Self, I, BtnClick, ALayout) do\r\n begin\r\n if ALayout = clDialog then\r\n begin\r\n if (Kind in [cbBck, cbClr]) then\r\n Width := 44;\r\n if (Kind in [cbSgn..cbCancel]) then\r\n if BtnGlyphs[Kind] >= 0 then\r\n begin\r\n Caption := '';\r\n AssignBitmapCell(Bmp, Glyph, 6, 1, BtnGlyphs[Kind]);\r\n end;\r\n end\r\n else\r\n begin\r\n //Polaris if Kind in [cbEql] then Width := 44;\r\n case Kind of\r\n cbSqr..cbRev:\r\n Width := 31;\r\n cbAdd:\r\n Height := 44;\r\n cbEql:\r\n begin\r\n Height := 44;\r\n Width := 31;\r\n end;\r\n cbBck:\r\n Width := 44;\r\n end;\r\n end;\r\n end;\r\n end;\r\n if ALayout = clDialog then\r\n begin\r\n { Memory panel }\r\n FMemoryPanel := TPanel.Create(Self);\r\n with FMemoryPanel do\r\n begin\r\n SetBounds(6, 7, 34, 20);\r\n BevelInner := bvLowered;\r\n BevelOuter := bvNone;\r\n ParentColor := True;\r\n Parent := Self;\r\n end;\r\n FMemoryLabel := TLabel.Create(Self);\r\n with FMemoryLabel do\r\n begin\r\n SetBounds(3, 3, 26, 14);\r\n Alignment := taCenter;\r\n AutoSize := False;\r\n Parent := FMemoryPanel;\r\n Font.Style := [];\r\n end;\r\n end;\r\n finally\r\n Bmp.Free;\r\n end;\r\n FText := '0';\r\n FMemory := 0.0;\r\n FPrecision := DefCalcPrecision;\r\n FBeepOnError := True;\r\nend;\r\n\r\nprocedure TJvCalculatorPanel.BtnClick(Sender: TObject);\r\nbegin\r\n case TJvCalcButton(Sender).Kind of\r\n cbNum0..cbNum9:\r\n CalcKey(Char(TComponent(Sender).Tag + Ord('0')));\r\n cbSgn:\r\n CalcKey('_');\r\n cbDcm:\r\n CalcKey(JclFormatSettings.DecimalSeparator);\r\n cbDiv:\r\n CalcKey('/');\r\n cbMul:\r\n CalcKey('*');\r\n cbSub:\r\n CalcKey('-');\r\n cbAdd:\r\n CalcKey('+');\r\n cbSqr:\r\n CalcKey('Q');\r\n cbPcnt:\r\n CalcKey('%');\r\n cbRev:\r\n CalcKey('R');\r\n cbEql:\r\n CalcKey('=');\r\n cbBck:\r\n CalcKey(Backspace);\r\n cbClr:\r\n CalcKey('C');\r\n cbMP:\r\n if FStatus in [csValid, csFirst] then\r\n begin\r\n FStatus := csFirst;\r\n FMemory := FMemory + GetDisplay;\r\n UpdateMemoryLabel;\r\n end;\r\n cbMS:\r\n if FStatus in [csValid, csFirst] then\r\n begin\r\n FStatus := csFirst;\r\n FMemory := GetDisplay;\r\n UpdateMemoryLabel;\r\n end;\r\n cbMR:\r\n if FStatus in [csValid, csFirst] then\r\n begin\r\n FStatus := csFirst;\r\n CheckFirst;\r\n SetDisplay(FMemory);\r\n end;\r\n cbMC:\r\n begin\r\n FMemory := 0.0;\r\n UpdateMemoryLabel;\r\n end;\r\n cbOk:\r\n begin\r\n if FStatus <> csError then\r\n begin\r\n DisplayValue := DisplayValue; { to raise exception on error }\r\n if Assigned(FOnOk) then\r\n FOnOk(Self);\r\n end\r\n else\r\n if FBeepOnError then\r\n Beep;\r\n end;\r\n cbCancel:\r\n if Assigned(FOnCancel) then\r\n FOnCancel(Self);\r\n end;\r\nend;\r\n\r\nprocedure TJvCalculatorPanel.CalcKey(Key: Char);\r\nvar\r\n R: Double;\r\nbegin\r\n Key := UpCase(Key);\r\n if (FStatus = csError) and (Key <> 'C') then\r\n Key := #0;\r\n if Assigned(FOnCalcKey) then\r\n FOnCalcKey(Self, Key);\r\n if CharInSet(Key, [JclFormatSettings.DecimalSeparator, '.', ',']) then\r\n begin\r\n CheckFirst;\r\n if Pos(JclFormatSettings.DecimalSeparator, Text) = 0 then\r\n SetText(Text + JclFormatSettings.DecimalSeparator);\r\n Exit;\r\n end;\r\n case Key of\r\n 'R':\r\n if FStatus in [csValid, csFirst] then\r\n begin\r\n FStatus := csFirst;\r\n if GetDisplay = 0 then\r\n Error\r\n else\r\n SetDisplay(1.0 / GetDisplay);\r\n end;\r\n 'Q':\r\n if FStatus in [csValid, csFirst] then\r\n begin\r\n FStatus := csFirst;\r\n if GetDisplay < 0 then\r\n Error\r\n else\r\n SetDisplay(Sqrt(GetDisplay));\r\n end;\r\n '0'..'9':\r\n begin\r\n CheckFirst;\r\n if Text = '0' then\r\n SetText('');\r\n if Pos('E', Text) = 0 then\r\n begin\r\n if Length(Text) < Max(2, FPrecision) + Ord(Boolean(Pos('-', Text))) then\r\n SetText(Text + Key)\r\n else\r\n if FBeepOnError then\r\n Beep;\r\n end;\r\n end;\r\n Backspace:\r\n begin\r\n CheckFirst;\r\n if (Length(Text) = 1) or ((Length(Text) = 2) and (Text[1] = '-')) then\r\n SetText('0')\r\n else\r\n SetText(System.Copy(Text, 1, Length(Text) - 1));\r\n end;\r\n '_':\r\n SetDisplay(-GetDisplay);\r\n '+', '-', '*', '/', '=', '%', Cr:\r\n begin\r\n if FStatus = csValid then\r\n begin\r\n FStatus := csFirst;\r\n R := GetDisplay;\r\n if Key = '%' then\r\n case FOperator of\r\n '+', '-': R := FOperand * R / 100.0;\r\n '*', '/': R := R / 100.0;\r\n end;\r\n case FOperator of\r\n '+': SetDisplay(FOperand + R);\r\n '-': SetDisplay(FOperand - R);\r\n '*': SetDisplay(FOperand * R);\r\n '/':\r\n if R = 0 then\r\n Error\r\n else\r\n SetDisplay(FOperand / R);\r\n end;\r\n end;\r\n FOperator := Key;\r\n FOperand := GetDisplay;\r\n if CharInSet(Key, ResultKeys) then\r\n if Assigned(FOnResult) then\r\n FOnResult(Self);\r\n end;\r\n Esc, 'C':\r\n Clear;\r\n CtrlC:\r\n Copy;\r\n CtrlV:\r\n Paste;\r\n end;\r\nend;\r\n\r\nprocedure TJvCalculatorPanel.CalcKeyPress(Sender: TObject; var Key: Char);\r\nvar\r\n Btn: TJvSpeedButton;\r\nbegin\r\n Btn := FindButton(Key);\r\n if Btn <> nil then\r\n Btn.ButtonClick\r\n else\r\n CalcKey(Key);\r\nend;\r\n\r\nprocedure TJvCalculatorPanel.CheckFirst;\r\nbegin\r\n if FStatus = csFirst then\r\n begin\r\n FStatus := csValid;\r\n SetText('0');\r\n end;\r\nend;\r\n\r\nprocedure TJvCalculatorPanel.Clear;\r\nbegin\r\n FStatus := csFirst;\r\n SetDisplay(0.0);\r\n FOperator := '=';\r\nend;\r\n\r\n\r\nprocedure TJvCalculatorPanel.CMCtl3DChanged(var Msg: TMessage);\r\nconst\r\n Ctl3DStyle: array [Boolean] of TButtonStyle = (bsWin31, bsNew);\r\n Ctl3DBevel: array [Boolean] of TPanelBevel = (bvNone, bvLowered);\r\n Ctl3DBorder: array [Boolean] of TBorderStyle = (bsSingle, bsNone);\r\nvar\r\n I: Integer;\r\nbegin\r\n inherited;\r\n for I := 0 to ComponentCount - 1 do\r\n begin\r\n if Components[I] is TJvSpeedButton then\r\n TJvSpeedButton(Components[I]).Style := Ctl3DStyle[Ctl3D]\r\n else\r\n if Components[I] = FMemoryPanel then\r\n begin\r\n FMemoryPanel.BevelInner := Ctl3DBevel[Ctl3D];\r\n FMemoryPanel.BorderStyle := Ctl3DBorder[Ctl3D];\r\n end;\r\n end;\r\nend;\r\n\r\n\r\nprocedure TJvCalculatorPanel.Copy;\r\nbegin\r\n Clipboard.AsText := Text;\r\nend;\r\n\r\nprocedure TJvCalculatorPanel.Error;\r\nbegin\r\n FStatus := csError;\r\n SetText(RsError);\r\n if FBeepOnError then\r\n Beep;\r\n if Assigned(FOnError) then\r\n FOnError(Self);\r\nend;\r\n\r\nfunction TJvCalculatorPanel.FindButton(Key: Char): TJvSpeedButton;\r\nconst\r\n ButtonChars = '0123456789_./*-+Q%R='#8'C';\r\nvar\r\n I: Integer;\r\n BtnTag: Longint;\r\nbegin\r\n if CharInSet(Key, [JclFormatSettings.DecimalSeparator, '.', ',']) then\r\n Key := '.'\r\n else\r\n if Key = Cr then\r\n Key := '='\r\n else\r\n if Key = Esc then\r\n Key := 'C';\r\n BtnTag := Pos(UpCase(Key), ButtonChars) - 1;\r\n if BtnTag >= 0 then\r\n for I := 0 to ControlCount - 1 do\r\n begin\r\n if Controls[I] is TJvSpeedButton then\r\n begin\r\n Result := TJvSpeedButton(Controls[I]);\r\n if Result.Tag = BtnTag then\r\n Exit;\r\n end;\r\n end;\r\n Result := nil;\r\nend;\r\n\r\nfunction TJvCalculatorPanel.GetDisplay: Double;\r\nbegin\r\n if FStatus = csError then\r\n Result := 0.0\r\n else\r\n Result := StrToFloat(Trim(Text));\r\nend;\r\n\r\nprocedure TJvCalculatorPanel.Paste;\r\nbegin\r\n if Clipboard.HasFormat(CF_TEXT) then\r\n try\r\n SetDisplay(StrToFloat(Trim(ReplaceStr(Clipboard.AsText, JclFormatSettings.CurrencyString, ''))));\r\n except\r\n SetText('0');\r\n end;\r\nend;\r\n\r\nprocedure TJvCalculatorPanel.SetDisplay(R: Double);\r\nvar\r\n S: string;\r\nbegin\r\n S := FloatToStrF(R, ffGeneral, Max(2, FPrecision), 0);\r\n if Text <> S then\r\n begin\r\n SetText(S);\r\n if Assigned(FOnDisplayChange) then\r\n FOnDisplayChange(Self);\r\n end;\r\nend;\r\n\r\nprocedure TJvCalculatorPanel.SetText(const Value: string);\r\nbegin\r\n if FText <> Value then\r\n begin\r\n FText := Value;\r\n TextChange;\r\n end;\r\nend;\r\n\r\nprocedure TJvCalculatorPanel.TextChange;\r\nbegin\r\n if Assigned(FControl) then\r\n begin\r\n if FControl is TCustomLabel then\r\n TCustomLabelAccessProtected(FControl).Caption := Text\r\n else\r\n // Note that JvDBCalcEdit will not set its text if it is readonly\r\n if FControl is TCustomEdit then\r\n TCustomEdit(FControl).Text := Text;\r\n end;\r\n if Assigned(FOnTextChange) then\r\n FOnTextChange(Self);\r\nend;\r\n\r\nprocedure TJvCalculatorPanel.UpdateMemoryLabel;\r\nbegin\r\n if FMemoryLabel <> nil then\r\n if FMemory <> 0.0 then\r\n FMemoryLabel.Caption := 'M'\r\n else\r\n FMemoryLabel.Caption := '';\r\nend;\r\n\r\n//=== { TJvLocCalculator } ===================================================\r\n\r\nconstructor TJvLocCalculator.Create(AOwner: TComponent);\r\nbegin\r\n inherited CreateLayout(AOwner, clPopup);\r\n ControlStyle := [csCaptureMouse, csClickEvents, csDoubleClicks];\r\n ControlStyle := ControlStyle + [csReplicatable];\r\n Enabled := False;\r\n TabStop := False;\r\nend;\r\n\r\n\r\nprocedure TJvLocCalculator.CreateParams(var Params: TCreateParams);\r\nbegin\r\n inherited CreateParams(Params);\r\n with Params do\r\n begin\r\n Style := Style and not (WS_TABSTOP or WS_DISABLED);\r\n AddBiDiModeExStyle(ExStyle);\r\n end;\r\nend;\r\n\r\n\r\nprocedure TJvLocCalculator.EnabledChanged;\r\nbegin\r\n inherited EnabledChanged;\r\n if HandleAllocated and not (csDesigning in ComponentState) then\r\n EnableWindow(Handle, True);\r\nend;\r\n\r\n//=== { TJvPopupCalculator } =================================================\r\n\r\nconstructor TJvPopupCalculator.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n Height := 127;\r\n // Width := 104;\r\n Width := 137; // Polaris\r\n Color := clBtnFace;\r\n SetDefaultFont(Font, clPopup);\r\n if csDesigning in ComponentState then\r\n Exit;\r\n FCalcPanel := TJvLocCalculator.Create(Self);\r\n with FCalcPanel do\r\n begin\r\n Parent := Self;\r\n Align := alClient;\r\n BevelOuter := bvRaised;\r\n FPrecision := DefCalcPrecision;\r\n { (rb) Fix to update the text of a TJvCalcEdit }\r\n if AOwner is TControl then\r\n FControl := TControl(AOwner);\r\n Visible := True;\r\n OnTextChange := Self.TextChange;\r\n OnResultClick := Self.ResultClick;\r\n end;\r\nend;\r\n\r\nfunction TJvPopupCalculator.GetPopupText: string;\r\nbegin\r\n Result := FCalcPanel.Text;\r\nend;\r\n\r\nfunction TJvPopupCalculator.GetValue: Variant;\r\nbegin\r\n if csDesigning in ComponentState then\r\n Result := 0\r\n else\r\n begin\r\n if FCalcPanel.FStatus <> csError then\r\n begin\r\n { to raise exception on error }\r\n FCalcPanel.DisplayValue := FCalcPanel.DisplayValue;\r\n Result := FCalcPanel.DisplayValue;\r\n end\r\n else\r\n begin\r\n if FCalcPanel.FBeepOnError then\r\n Beep;\r\n Result := 0;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvPopupCalculator.KeyPress(var Key: Char);\r\nbegin\r\n if FCalcPanel <> nil then\r\n FCalcPanel.CalcKeyPress(Self, Key);\r\n inherited KeyPress(Key);\r\nend;\r\n\r\nprocedure TJvPopupCalculator.ResultClick(Sender: TObject);\r\nbegin\r\n if FCalcPanel.FStatus <> csError then\r\n begin\r\n FCalcPanel.DisplayValue := FCalcPanel.DisplayValue;\r\n CloseUp(True);\r\n end;\r\nend;\r\n\r\nprocedure TJvPopupCalculator.SetValue(const Value: Variant);\r\nbegin\r\n if not (csDesigning in ComponentState) then\r\n with FCalcPanel do\r\n begin\r\n try\r\n if VarIsNullEmpty(Value) then\r\n DisplayValue := 0\r\n else\r\n DisplayValue := Value;\r\n except\r\n DisplayValue := 0;\r\n end;\r\n FStatus := csFirst;\r\n FOperator := '=';\r\n end;\r\nend;\r\n\r\nprocedure TJvPopupCalculator.TextChange(Sender: TObject);\r\nbegin\r\n InvalidateEditor;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend." }, { "path": "External/Jedi/Jvcl/run/JvCalendar.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvCalendar.PAS, released on 2002-05-26.\r\n\r\nThe Initial Developer of the Original Code is Peter Thrnqvist [peter3 at sourceforge dot net]\r\nPortions created by Peter Thrnqvist are Copyright (C) 2002 Peter Thrnqvist.\r\nAll Rights Reserved.\r\n\r\nContributor(s): Oliver Giesen [ogware att gmx dott net]\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nDescription:\r\n A wrapper component for the MS MonthCal control available in\r\n ComCtl32.dll versions 4.70 and above.\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvCalendar.pas 13104 2011-09-07 06:50:43Z obones $\r\n\r\nunit JvCalendar;\r\n\r\n{$I jvcl.inc}\r\n{$I windowsonly.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, Messages, CommCtrl, Classes, Graphics, Controls, Forms,\r\n JvComponent, JvTypes, JvJCLUtils, JvExControls;\r\n\r\ntype\r\n EMonthCalError = class(EJVCLException);\r\n TJvMonthCalWeekDay = (mcLocale, mcMonday, mcTuesday, mcWednesday, mcThursday, mcFriday, mcSaturday, mcSunday);\r\n TJvMonthCalSelEvent = procedure(Sender: TObject; StartDate, EndDate: TDateTime) of object;\r\n TJvMonthCalStateEvent = procedure(Sender: TObject; Date: TDateTime; Count: Integer; var DayStateArray: array of\r\n TMonthDayState) of object;\r\n\r\n TJvCustomMonthCalendar = class;\r\n\r\n TJvMonthCalColors = class(TPersistent)\r\n private\r\n FCalendar: TJvCustomMonthCalendar;\r\n FBackColor: TColor;\r\n FTextColor: TColor;\r\n FTitleBackColor: TColor;\r\n FTitleTextColor: TColor;\r\n FMonthBackColor: TColor;\r\n FTrailingTextColor: TColor;\r\n procedure SetColor(Index: Integer; Value: TColor);\r\n function GetColor(Index: Integer): TColor;\r\n procedure SetAllColors;\r\n public\r\n constructor Create(AOwner: TJvCustomMonthCalendar);\r\n procedure Assign(Source: TPersistent); override;\r\n property Calendar: TJvCustomMonthCalendar read FCalendar;\r\n published\r\n property BackColor: TColor index 0 read GetColor write SetColor default clWindow;\r\n property TextColor: TColor index 1 read GetColor write SetColor default clWindowText;\r\n property TitleBackColor: TColor index 2 read GetColor write SetColor default clActiveCaption;\r\n property TitleTextColor: TColor index 3 read GetColor write SetColor default clWhite;\r\n property MonthBackColor: TColor index 4 read GetColor write SetColor default clWhite;\r\n property TrailingTextColor: TColor index 5 read GetColor write SetColor default clInactiveCaptionText;\r\n end;\r\n\r\n TJvMonthCalAppearance = class(TPersistent)\r\n private\r\n FCircleToday: Boolean;\r\n FShowToday: Boolean;\r\n FWeekNumbers: Boolean;\r\n FFirstDoW: TJvMonthCalWeekDay;\r\n FColors: TJvMonthCalColors;\r\n FBoldDays: TStrings;\r\n procedure SetColors(const AValue: TJvMonthCalColors);\r\n function GetBoldDays: TStrings;\r\n procedure SetBoldDays(AValue: TStrings);\r\n procedure SetCalendar(AValue: TJvCustomMonthCalendar);\r\n function GetCalendar: TJvCustomMonthCalendar;\r\n procedure SetCircleToday(const AValue: Boolean);\r\n procedure SetFirstDoW(const AValue: TJvMonthCalWeekDay);\r\n procedure SetShowToday(const AValue: Boolean);\r\n procedure SetWeekNumbers(const AValue: Boolean);\r\n public\r\n constructor Create;\r\n destructor Destroy; override;\r\n property Calendar: TJvCustomMonthCalendar read GetCalendar write SetCalendar;\r\n published\r\n property Colors: TJvMonthCalColors read FColors write SetColors;\r\n property CircleToday: Boolean read FCircleToday write SetCircleToday default True;\r\n property BoldDays: TStrings read GetBoldDays write SetBoldDays;\r\n property FirstDayOfWeek: TJvMonthCalWeekDay read FFirstDoW write SetFirstDoW default mcLocale;\r\n property ShowToday: Boolean read FShowToday write SetShowToday default True;\r\n property WeekNumbers: Boolean read FWeekNumbers write SetWeekNumbers default False;\r\n end;\r\n\r\n TMonthDayStateArray = array [0..11] of TMonthDayState;\r\n\r\n TJvCustomMonthCalendar = class(TJvWinControl)\r\n private\r\n FAppearance: TJvMonthCalAppearance;\r\n FOwnsAppearance: Boolean;\r\n FMultiSelect: Boolean;\r\n FMaxSelCount: Word;\r\n FMinDate: TDateTime;\r\n FMaxDate: TDateTime;\r\n FFirstSelDate: TDateTime;\r\n FLastSelDate: TDateTime;\r\n FMonthDelta: Integer;\r\n FToday: TDateTime;\r\n FBorderStyle: TBorderStyle;\r\n FOnSelect: TJvMonthCalSelEvent;\r\n FOnSelChange: TJvMonthCalSelEvent;\r\n FOnGetState: TJvMonthCalStateEvent;\r\n FOnKillFocus: TJvFocusChangeEvent;\r\n FOnSetFocus: TJvFocusChangeEvent;\r\n FLeaving: Boolean;\r\n FEntering: Boolean;\r\n procedure DoBoldDays;\r\n procedure SetColors(Value: TJvMonthCalColors);\r\n procedure SetBoldDays(Value: TStrings);\r\n procedure SetMultiSelect(Value: Boolean);\r\n procedure SetShowToday(Value: Boolean);\r\n procedure SetCircleToday(Value: Boolean);\r\n procedure SetWeekNumbers(Value: Boolean);\r\n procedure SetFirstDayOfWeek(Value: TJvMonthCalWeekDay);\r\n procedure SetMaxSelCount(Value: Word);\r\n procedure SetMinDate(Value: TDateTime);\r\n procedure SetMaxDate(Value: TDateTime);\r\n procedure SetFirstSelDate(Value: TDateTime);\r\n function GetFirstSelDate: TDateTime;\r\n function GetLastSelDate: TDateTime;\r\n procedure SetLastSelDate(Value: TDateTime);\r\n procedure SetSelectedDays(dFrom, dTo: TDateTime);\r\n procedure SetMonthDelta(Value: Integer);\r\n procedure SetToday(Value: TDateTime);\r\n procedure SetBorderStyle(Value: TBorderStyle);\r\n function GetTodayWidth: Integer;\r\n function GetMinSize: TRect;\r\n function IsBold(Year, Month, Day: Word): Boolean;\r\n procedure SetBold(Year, Month, Day: Word; Value: Boolean);\r\n\r\n function GetBoldDays: TStrings;\r\n function GetCircleToday: Boolean;\r\n function GetColors: TJvMonthCalColors;\r\n function GetFirstDayOfWeek: TJvMonthCalWeekDay;\r\n function GetShowToday: Boolean;\r\n function GetWeekNumbers: Boolean;\r\n\r\n function GetDays(Year, Month: Word): string;\r\n procedure SetDays(Year, Month: Word; Value: string);\r\n procedure CNNotify(var Msg: TWMNotify); message CN_NOTIFY;\r\n procedure WMLButtonDown(var Msg: TWMLButtonDown); message WM_LBUTTONDOWN;\r\n protected\r\n procedure GetDlgCode(var Code: TDlgCodes); override;\r\n procedure ColorChanged; override;\r\n procedure FontChanged; override;\r\n procedure ConstrainedResize(var MinWidth: Integer;\r\n var MinHeight: Integer; var MaxWidth: Integer;\r\n var MaxHeight: Integer); override;\r\n function CanAutoSize(var NewWidth, NewHeight: Integer): Boolean; override;\r\n procedure CheckDayState(Year, Month: Word; var DayState: TMonthDayState); virtual;\r\n procedure CreateParams(var Params: TCreateParams); override;\r\n procedure CreateWnd; override;\r\n procedure Change; virtual;\r\n procedure DoDateSelect(StartDate, EndDate: TDateTime); virtual;\r\n procedure DoDateSelChange(StartDate, EndDate: TDateTime); virtual;\r\n procedure DoGetDayState(var DayState: TNMDayState; var StateArray: TMonthDayStateArray); virtual;\r\n procedure FocusKilled(NextWnd: THandle); override;\r\n procedure FocusSet(PrevWnd: THandle); override;\r\n\r\n procedure DoFocusSet(const APreviousControl: TWinControl); virtual;\r\n procedure DoFocusKilled(const ANextControl: TWinControl); virtual;\r\n\r\n property MinSize: TRect read GetMinSize;\r\n property Bold[Year, Month, Day: Word]: Boolean read IsBold write SetBold;\r\n\r\n property BorderStyle: TBorderStyle read FBorderStyle write SetBorderStyle default bsNone;\r\n property BoldDays: TStrings read GetBoldDays write SetBoldDays;\r\n property CircleToday: Boolean read GetCircleToday write SetCircleToday default True;\r\n property Colors: TJvMonthCalColors read GetColors write SetColors;\r\n property DateFirst: TDateTime read GetFirstSelDate write SetFirstSelDate;\r\n property DateLast: TDateTime read GetLastSelDate write SetLastSelDate;\r\n property DateMax: TDateTime read FMaxDate write SetMaxDate;\r\n property DateMin: TDateTime read FMinDate write SetMinDate;\r\n property Days[Year, Month: Word]: string read GetDays write SetDays;\r\n property FirstDayOfWeek: TJvMonthCalWeekDay read GetFirstDayOfWeek write SetFirstDayOfWeek default mcLocale;\r\n property MaxSelCount: Word read FMaxSelCount write SetMaxSelCount default 7;\r\n property MonthDelta: Integer read FMonthDelta write SetMonthDelta default 1;\r\n property MultiSelect: Boolean read FMultiSelect write SetMultiSelect default False;\r\n property ShowToday: Boolean read GetShowToday write SetShowToday default True;\r\n property TodayWidth: Integer read GetTodayWidth;\r\n property WeekNumbers: Boolean read GetWeekNumbers write SetWeekNumbers default False;\r\n property Today: TDateTime read FToday write SetToday;\r\n property OnSelect: TJvMonthCalSelEvent read FOnSelect write FOnSelect;\r\n property OnSelChange: TJvMonthCalSelEvent read FOnSelChange write FOnSelChange;\r\n property OnGetDayState: TJvMonthCalStateEvent read FOnGetState write FOnGetState;\r\n property OnSetFocus: TJvFocusChangeEvent read FOnSetFocus write FOnSetFocus;\r\n property OnKillFocus: TJvFocusChangeEvent read FOnKillFocus write FOnKillFocus;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n constructor CreateWithAppearance(AOwner: TComponent; const AAppearance: TJvMonthCalAppearance; const\r\n AOwnsAppearance: Boolean = False);\r\n destructor Destroy; override;\r\n function FirstVisibleDate(Partial: Boolean): TDateTime;\r\n function LastVisibleDate(Partial: Boolean): TDateTime;\r\n function VisibleMonths: Integer;\r\n procedure SetDayStates(MonthCount: Integer; DayStates: array of TMonthDayState);\r\n\r\n property Entering: Boolean read FEntering;\r\n property Leaving: Boolean read FLeaving;\r\n end;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvMonthCalendar2 = class(TJvCustomMonthCalendar)\r\n public\r\n property MinSize;\r\n property Bold;\r\n property Days;\r\n published\r\n { inherited properties }\r\n property Action;\r\n property Align;\r\n property Anchors;\r\n property Constraints;\r\n property Height default 160;\r\n property Width default 190;\r\n property Enabled;\r\n property Font;\r\n property ParentColor;\r\n property ParentFont;\r\n property ParentShowHint;\r\n property TabStop;\r\n property TabOrder;\r\n property Visible;\r\n property OnClick;\r\n property OnDblClick;\r\n property OnEnter;\r\n property OnExit;\r\n property OnMouseDown;\r\n property OnMouseUp;\r\n property OnMouseMove;\r\n property OnKeyDown;\r\n property OnKeyUp;\r\n property OnKeyPress;\r\n property OnStartDrag;\r\n property OnDragOver;\r\n property OnDragDrop;\r\n property OnEndDrag;\r\n { new properties }\r\n property AutoSize;\r\n property BoldDays;\r\n property BorderStyle;\r\n property CircleToday;\r\n property Colors;\r\n property DateMin;\r\n property DateMax;\r\n property DateFirst;\r\n property DateLast;\r\n property FirstDayOfWeek;\r\n property MaxSelCount;\r\n property MonthDelta;\r\n property MultiSelect;\r\n property ShowToday;\r\n property WeekNumbers;\r\n property Today;\r\n property OnKillFocus;\r\n property OnSelect;\r\n property OnSetFocus;\r\n property OnSelChange;\r\n property OnGetDayState;\r\n end;\r\n\r\nfunction StringToDayStates(const S: string): TMonthDayState;\r\nfunction DayStatesToString(Days: TMonthDayState): string;\r\n// function GetDLLVersion(const DLLName: string; var pdwMajor, pdwMinor: Integer): Boolean;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvCalendar.pas $';\r\n Revision: '$Revision: 13104 $';\r\n Date: '$Date: 2011-09-07 08:50:43 +0200 (mer. 07 sept. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n SysUtils, ComCtrls, Types, // for inlining in D2007 and upper\r\n JvResources;\r\n\r\nconst\r\n MCM_GETMAXTODAYWIDTH = (MCM_FIRST + 21);\r\n MCS_NOTODAYCIRCLE = $0008;\r\n MCS_NOTODAY = $0010;\r\n ColorIndex: array [0..5] of Integer = (MCSC_BACKGROUND, MCSC_TEXT,\r\n MCSC_TITLEBK, MCSC_TITLETEXT, MCSC_MONTHBK, MCSC_TRAILINGTEXT);\r\n\r\n // IE3 and previous:\r\n // MCS_NOTODAY = $0008;\r\n\r\nfunction InitCommonControl(CC: Integer): Boolean;\r\nvar\r\n ICC: TInitCommonControlsEx;\r\nbegin\r\n ICC.dwSize := SizeOf(TInitCommonControlsEx);\r\n ICC.dwICC := CC;\r\n Result := InitCommonControlsEx(ICC);\r\n if not Result then\r\n InitCommonControls;\r\nend;\r\n\r\nfunction IsBlankDate(ST: TSystemTime): Boolean;\r\nbegin\r\n Result := (ST.wMonth = 0) and (ST.wDay = 0);\r\nend;\r\n\r\nfunction StringToDayStates(const S: string): TMonthDayState;\r\nvar\r\n P, L, I, R: Integer;\r\nbegin\r\n Result := 0;\r\n P := 1;\r\n L := Length(S);\r\n if L = 0 then\r\n Exit;\r\n while True do\r\n begin\r\n while (P <= L) and (S[P] = ',') do\r\n Inc(P);\r\n if P > L then\r\n Break;\r\n I := P;\r\n while (P <= L) and (S[P] <> ',') do\r\n Inc(P);\r\n R := StrToIntDef(Copy(S, I, P - I), 0);\r\n if R in [1..31] then\r\n Result := Result or (1 shl (R - 1));\r\n end;\r\nend;\r\n\r\ntype\r\n // (p3) from ShLwAPI\r\n TDLLVersionInfo = record\r\n cbSize: DWORD;\r\n dwMajorVersion: DWORD;\r\n dwMinorVersion: DWORD;\r\n dwBuildNumber: DWORD;\r\n dwPlatformID: DWORD;\r\n end;\r\n\r\n{\r\nfunction GetDLLVersion(const DLLName: string; var pdwMajor, pdwMinor: Integer): Boolean;\r\nvar\r\n hDLL, hr: THandle;\r\n pDllGetVersion: function(var dvi: TDLLVersionInfo): Integer; stdcall;\r\n dvi: TDLLVersionInfo;\r\nbegin\r\n hDLL := SafeLoadLibrary(DLLName);\r\n if hDLL <> 0 then\r\n begin\r\n Result := True;\r\n (* You must get this function explicitly\r\n because earlier versions of the DLL\r\n don't implement this function.\r\n That makes the lack of implementation\r\n of the function a version marker in itself. *)\r\n @pDllGetVersion := GetProcAddress(hDLL, PChar('DllGetVersion'));\r\n if Assigned(pDllGetVersion) then\r\n begin\r\n FillChar(dvi, SizeOf(dvi), #0);\r\n dvi.cbSize := SizeOf(dvi);\r\n hr := pDllGetVersion(dvi);\r\n if (hr = 0) then\r\n begin\r\n pdwMajor := dvi.dwMajorVersion;\r\n pdwMinor := dvi.dwMinorVersion;\r\n end;\r\n end\r\n else (* If GetProcAddress failed, the DLL is a version previous to the one shipped with IE 3.x. *)\r\n begin\r\n pdwMajor := 4;\r\n pdwMinor := 0;\r\n end;\r\n FreeLibrary(hDLL);\r\n Exit;\r\n end;\r\n Result := False;\r\nend;\r\n}\r\n\r\nfunction DayStatesToString(Days: TMonthDayState): string;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := '';\r\n if Days = 0 then\r\n Exit;\r\n for I := 0 to 30 do\r\n if (Days and (1 shl (I))) <> 0 then\r\n Result := Result + Format('%d,', [I + 1]);\r\n if Result <> '' then\r\n SetLength(Result, Length(Result) - 1);\r\nend;\r\n\r\n//=== { TJvMonthCalColors } ==================================================\r\n\r\nconstructor TJvMonthCalColors.Create(AOwner: TJvCustomMonthCalendar);\r\nbegin\r\n inherited Create;\r\n FCalendar := AOwner;\r\n FBackColor := clWindow;\r\n FTextColor := clWindowText;\r\n FTitleBackColor := clActiveCaption;\r\n FTitleTextColor := clWhite;\r\n FMonthBackColor := clWhite;\r\n FTrailingTextColor := clInactiveCaptionText;\r\nend;\r\n\r\nprocedure TJvMonthCalColors.Assign(Source: TPersistent);\r\nvar\r\n SourceName: string;\r\nbegin\r\n if Source = nil then\r\n SourceName := 'nil'\r\n else\r\n SourceName := Source.ClassName;\r\n if Source is TJvMonthCalColors then\r\n begin\r\n if Source <> Self then\r\n begin\r\n FBackColor := TJvMonthCalColors(Source).BackColor;\r\n FTextColor := TJvMonthCalColors(Source).TextColor;\r\n FTitleBackColor := TJvMonthCalColors(Source).TitleBackColor;\r\n FTitleTextColor := TJvMonthCalColors(Source).TitleTextColor;\r\n FMonthBackColor := TJvMonthCalColors(Source).MonthBackColor;\r\n FTrailingTextColor := TJvMonthCalColors(Source).TrailingTextColor;\r\n end;\r\n end\r\n else\r\n inherited Assign(Source);\r\nend;\r\n\r\nprocedure TJvMonthCalColors.SetColor(Index: Integer; Value: TColor);\r\nbegin\r\n if (Calendar <> nil) and Calendar.HandleAllocated then\r\n MonthCal_SetColor(Calendar.Handle, ColorIndex[Index], ColorToRGB(Value));\r\n case Index of\r\n 0:\r\n begin\r\n FBackColor := Value;\r\n if Calendar <> nil then\r\n Calendar.Color := FBackColor;\r\n end;\r\n 1:\r\n FTextColor := Value;\r\n 2:\r\n FTitleBackColor := Value;\r\n 3:\r\n FTitleTextColor := Value;\r\n 4:\r\n FMonthBackColor := Value;\r\n 5:\r\n FTrailingTextColor := Value;\r\n end;\r\nend;\r\n\r\nfunction TJvMonthCalColors.GetColor(Index: Integer): TColor;\r\nbegin\r\n case Index of\r\n 0:\r\n Result := FBackColor;\r\n 1:\r\n Result := FTextColor;\r\n 2:\r\n Result := FTitleBackColor;\r\n 3:\r\n Result := FTitleTextColor;\r\n 4:\r\n Result := FMonthBackColor;\r\n 5:\r\n Result := FTrailingTextColor;\r\n else\r\n Result := 0;\r\n end;\r\nend;\r\n\r\nprocedure TJvMonthCalColors.SetAllColors;\r\nbegin\r\n SetColor(0, FBackColor);\r\n SetColor(1, FTextColor);\r\n SetColor(2, FTitleBackColor);\r\n SetColor(3, FTitleTextColor);\r\n SetColor(4, FMonthBackColor);\r\n SetColor(5, FTrailingTextColor);\r\nend;\r\n\r\n//=== { TMonthCalStrings } ===================================================\r\n\r\ntype\r\n TMonthCalStrings = class(TStringList)\r\n private\r\n FCalendar: TJvCustomMonthCalendar;\r\n protected\r\n function GetDateIndex(Year, Month: Word): Integer; virtual;\r\n function GetBoldDays(Y, M: Word): string; virtual;\r\n procedure Changed; override;\r\n public\r\n constructor Create;\r\n function AddObject(const S: string; AObject: TObject): Integer; override;\r\n function IsBold(Year, Month, Day: Word): Boolean;\r\n procedure SetBold(Year, Month, Day: Word; Value: Boolean);\r\n function AddDays(Year, Month: Word; const Days: string): Integer; virtual;\r\n property Calendar: TJvCustomMonthCalendar read FCalendar;\r\n end;\r\n\r\nconstructor TMonthCalStrings.Create;\r\nbegin\r\n inherited Create;\r\n Sorted := True;\r\n Duplicates := dupIgnore;\r\nend;\r\n\r\n{ Days is a comma separated list of days to set as bold. If Days is empty, the\r\n line is removed (if found) }\r\n\r\nfunction TMonthCalStrings.AddDays(Year, Month: Word; const Days: string): Integer;\r\nbegin\r\n if Days = '' then\r\n begin\r\n Result := GetDateIndex(Year, Month);\r\n if Result > -1 then\r\n Delete(Result);\r\n end\r\n else\r\n Result := Add(Format('%.4d%.2d=%s', [Year, Month, Days]));\r\nend;\r\n\r\nfunction TMonthCalStrings.IsBold(Year, Month, Day: Word): Boolean;\r\nvar\r\n DayState: TMonthDayState;\r\nbegin\r\n DayState := StringToDayStates(GetBoldDays(Year, Month) + ',' + GetBoldDays(0, Month));\r\n Result := (DayState and (1 shl (Day - 1))) <> 0;\r\nend;\r\n\r\nprocedure TMonthCalStrings.SetBold(Year, Month, Day: Word; Value: Boolean);\r\nvar\r\n S: string;\r\n DayState: TMonthDayState;\r\nbegin\r\n if IsBold(Year, Month, Day) <> Value then\r\n begin\r\n S := GetBoldDays(Year, Month) + ',' + GetBoldDays(0, Month);\r\n if Value then\r\n begin\r\n if S = '' then\r\n S := IntToStr(Day)\r\n else\r\n S := S + Format('%d,', [Day]);\r\n AddDays(Year, Month, S);\r\n Exit;\r\n end;\r\n DayState := StringToDayStates(S);\r\n DayState := DayState and not (1 shl (Day - 1));\r\n AddDays(Year, Month, DayStatesToString(DayState));\r\n end;\r\nend;\r\n\r\n{ Note!\r\n This must be fully qualified, i.e. '199801=1,2,3,4,5' or '000012=25,31' etc\r\n}\r\n\r\nfunction TMonthCalStrings.AddObject(const S: string; AObject: TObject): Integer;\r\nbegin\r\n if AnsiPos('=', S) <> 7 then\r\n raise EMonthCalError.CreateResFmt(@RsEInvalidDateStr, [S]);\r\n\r\n BeginUpdate;\r\n try\r\n Result := IndexOfName(Copy(S, 1, 6));\r\n if Result >= 0 then\r\n begin\r\n { We can only set items when Sorted = False }\r\n Sorted := False;\r\n Strings[Result] := S;\r\n Objects[Result] := AObject;\r\n Sorted := True;\r\n end\r\n else\r\n Result := inherited AddObject(S, AObject);\r\n finally\r\n EndUpdate;\r\n end;\r\nend;\r\n\r\nfunction TMonthCalStrings.GetDateIndex(Year, Month: Word): Integer;\r\nvar\r\n S: string;\r\nbegin\r\n if Year = 0 then\r\n S := Format('0000%.2d', [Month])\r\n else\r\n S := Format('%.4d%.2d', [Year, Month]);\r\n\r\n for Result := 0 to Count - 1 do\r\n if AnsiSameText(Names[Result], S) then\r\n Exit;\r\n Result := -1;\r\nend;\r\n\r\nfunction TMonthCalStrings.GetBoldDays(Y, M: Word): string;\r\nvar\r\n S: string;\r\nbegin\r\n if Y = 0 then\r\n S := Format('0000%.2d', [M])\r\n else\r\n S := Format('%.4d%.2d', [Y, M]);\r\n Result := Values[S];\r\nend;\r\n\r\nprocedure TMonthCalStrings.Changed;\r\nbegin\r\n inherited Changed;\r\n if (UpdateCount = 0) and Assigned(Calendar) then\r\n Calendar.DoBoldDays;\r\nend;\r\n\r\n//=== { TJvCustomMonthCalendar } =============================================\r\n\r\nconstructor TJvCustomMonthCalendar.Create(AOwner: TComponent);\r\nbegin\r\n CreateWithAppearance(AOwner, TJvMonthCalAppearance.Create, True);\r\nend;\r\n\r\nconstructor TJvCustomMonthCalendar.CreateWithAppearance(AOwner: TComponent;\r\n const AAppearance: TJvMonthCalAppearance; const AOwnsAppearance: Boolean);\r\nbegin\r\n if not Assigned(AAppearance) then\r\n raise EMonthCalError.CreateRes(@RsEInvalidAppearance);\r\n CheckCommonControl(ICC_DATE_CLASSES);\r\n inherited Create(AOwner);\r\n FAppearance := AAppearance;\r\n FOwnsAppearance := AOwnsAppearance;\r\n\r\n ControlStyle := ControlStyle + [csOpaque, csCaptureMouse, csClickEvents, csDoubleClicks, csReflector];\r\n\r\n FAppearance.Calendar := Self;\r\n\r\n FMultiSelect := False;\r\n FMaxSelCount := 7;\r\n FMinDate := 0.0;\r\n FMaxDate := 0.0;\r\n FFirstSelDate := Date;\r\n FLastSelDate := 0.0;\r\n FMonthDelta := 1;\r\n FToday := Now;\r\n FBorderStyle := bsNone;\r\n FEntering := False;\r\n FLeaving := False;\r\n inherited Color := clWindow;\r\n ParentColor := False;\r\n TabStop := True;\r\n Width := MinSize.Right;\r\n Height := MinSize.Bottom;\r\nend;\r\n\r\ndestructor TJvCustomMonthCalendar.Destroy;\r\nbegin\r\n if FOwnsAppearance then\r\n FreeAndNil(FAppearance);\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvCustomMonthCalendar.CreateParams(var Params: TCreateParams);\r\nconst\r\n BorderStyles: array [TBorderStyle] of DWORD = (0, WS_BORDER);\r\n MultiSelects: array [Boolean] of DWORD = (0, MCS_MULTISELECT);\r\n NoTodays: array [Boolean] of DWORD = (MCS_NOTODAY, 0);\r\n NoCircles: array [Boolean] of DWORD = (MCS_NOTODAYCIRCLE, 0);\r\n Weeks: array [Boolean] of DWORD = (0, MCS_WEEKNUMBERS);\r\nbegin\r\n InitCommonControl(ICC_DATE_CLASSES);\r\n inherited CreateParams(Params);\r\n CreateSubClass(Params, MONTHCAL_CLASS);\r\n with Params do\r\n begin\r\n if GetComCtlVersion >= ComCtlVersionIE4 then\r\n Style := Style or BorderStyles[FBorderStyle] or MultiSelects[FMultiSelect] or\r\n NoTodays[FAppearance.ShowToday] or NoCircles[FAppearance.CircleToday] or\r\n Weeks[FAppearance.WeekNumbers] or MCS_DAYSTATE\r\n else\r\n // IE3 doesn't implement the NoTodayCircle style, instead it uses\r\n // the same constant for MCS_NOTODAY as IE4 does for MCS_NOTODAYCIRCLE ...\r\n Style := Style or BorderStyles[FBorderStyle] or MultiSelects[FMultiSelect] or\r\n NoCircles[FAppearance.ShowToday] or Weeks[FAppearance.WeekNumbers] or MCS_DAYSTATE;\r\n if FBorderStyle = bsSingle then\r\n begin\r\n Style := Style and not WS_BORDER;\r\n ExStyle := Params.ExStyle or WS_EX_CLIENTEDGE;\r\n end;\r\n WindowClass.Style := WindowClass.Style and not (CS_HREDRAW or CS_VREDRAW) or CS_DBLCLKS;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomMonthCalendar.SetColors(Value: TJvMonthCalColors);\r\nbegin\r\n FAppearance.Colors := Value;\r\nend;\r\n\r\nprocedure TJvCustomMonthCalendar.SetBoldDays(Value: TStrings);\r\nbegin\r\n FAppearance.BoldDays := Value;\r\nend;\r\n\r\nfunction TJvCustomMonthCalendar.IsBold(Year, Month, Day: Word): Boolean;\r\nbegin\r\n Result := TMonthCalStrings(FAppearance.BoldDays).IsBold(Year, Month, Day);\r\nend;\r\n\r\nfunction TJvCustomMonthCalendar.GetDays(Year, Month: Word): string;\r\nbegin\r\n Result := TMonthCalStrings(FAppearance.BoldDays).GetBoldDays(Year, Month);\r\nend;\r\n\r\nprocedure TJvCustomMonthCalendar.SetDays(Year, Month: Word; Value: string);\r\nbegin\r\n TMonthCalStrings(FAppearance.BoldDays).AddDays(Year, Month, Value);\r\nend;\r\n\r\nprocedure TJvCustomMonthCalendar.SetBold(Year, Month, Day: Word; Value: Boolean);\r\nbegin\r\n TMonthCalStrings(FAppearance.BoldDays).SetBold(Year, Month, Day, Value);\r\nend;\r\n\r\n{ gets the first visible calendar month }\r\n\r\nfunction TJvCustomMonthCalendar.FirstVisibleDate(Partial: Boolean): TDateTime;\r\nvar\r\n RGST: array [0..1] of TSystemTime;\r\n Flag: Integer;\r\nbegin\r\n Result := 0;\r\n if Partial then\r\n Flag := GMR_DAYSTATE\r\n else\r\n Flag := GMR_VISIBLE;\r\n if SendStructMessage(Handle, MCM_GETMONTHRANGE, Flag, RGST) <> 0 then\r\n with RGST[0] do\r\n Result := Trunc(EncodeDate(wYear, wMonth, wDay));\r\nend;\r\n\r\n{ gets the last visible calendar month }\r\n\r\nfunction TJvCustomMonthCalendar.LastVisibleDate(Partial: Boolean): TDateTime;\r\nconst\r\n IsPartial: array [Boolean] of Integer = (GMR_VISIBLE, GMR_DAYSTATE);\r\nvar\r\n RGST: array[0..1] of TSystemTime;\r\n Flag: Integer;\r\nbegin\r\n Result := 0;\r\n Flag := IsPartial[Partial];\r\n if SendStructMessage(Handle, MCM_GETMONTHRANGE, Flag, RGST) <> 0 then\r\n with RGST[1] do\r\n Result := Trunc(EncodeDate(wYear, wMonth, wDay));\r\nend;\r\n\r\n{ protected }\r\n\r\nprocedure TJvCustomMonthCalendar.Change;\r\nvar\r\n RGST: array [0..1] of TSystemTime;\r\n Y, M, D: Word;\r\n Flags: DWORD;\r\nbegin\r\n if not HandleAllocated then\r\n Exit;\r\n MonthCal_SetFirstDayOfWeek(Handle, Ord(FAppearance.FirstDayOfWeek) - 1);\r\n MonthCal_SetMaxSelCount(Handle, FMaxSelCount);\r\n\r\n MonthCal_SetMonthDelta(Handle, FMonthDelta);\r\n SetSelectedDays(FFirstSelDate, FLastSelDate);\r\n with RGST[0] do\r\n begin\r\n if FMinDate <> 0 then\r\n begin\r\n DecodeDate(FMinDate, Y, M, D);\r\n wYear := Y;\r\n wMonth := M;\r\n wDay := D;\r\n Flags := GDTR_MIN;\r\n end\r\n else\r\n begin\r\n wYear := 0;\r\n wMonth := 0;\r\n wDay := 0;\r\n Flags := 0;\r\n end;\r\n wDayOfWeek := 0;\r\n wHour := 0;\r\n wMinute := 0;\r\n wSecond := 0;\r\n wMilliseconds := 0;\r\n end;\r\n with RGST[1] do\r\n begin\r\n if FMaxDate <> 0 then\r\n begin\r\n DecodeDate(FMaxDate, Y, M, D);\r\n wYear := Y;\r\n wMonth := M;\r\n wDay := D;\r\n Flags := Flags or GDTR_MAX;\r\n end\r\n else\r\n begin\r\n wYear := 0;\r\n wMonth := 0;\r\n wDay := 0;\r\n end;\r\n wDayOfWeek := 0;\r\n wHour := 0;\r\n wMinute := 0;\r\n wSecond := 0;\r\n wMilliseconds := 0;\r\n end;\r\n MonthCal_SetRange(Handle, Flags, @RGST[0]);\r\n DecodeDate(FToday, Y, M, D);\r\n with RGST[0] do\r\n begin\r\n wYear := Y;\r\n wMonth := M;\r\n wDay := D;\r\n end;\r\n MonthCal_SetToday(Handle, RGST[0]);\r\nend;\r\n\r\nprocedure TJvCustomMonthCalendar.DoBoldDays;\r\nvar\r\n Y, M, D: Word;\r\n DayArray: TMonthDayStateArray;\r\n NMDayState: TNMDayState;\r\nbegin\r\n if not HandleAllocated then\r\n Exit;\r\n DecodeDate(FirstVisibleDate(True), Y, M, D);\r\n FillChar(DayArray, SizeOf(TMonthDayStateArray), 0);\r\n with NMDayState do\r\n begin\r\n stStart.wYear := Y;\r\n stStart.wMonth := M;\r\n stStart.wDay := D;\r\n cDayState := VisibleMonths;\r\n prgDayState := PMonthDayState(@DayArray);\r\n end;\r\n for D := 0 to VisibleMonths - 1 do\r\n begin\r\n CheckDayState(Y, M, DayArray[D]);\r\n Inc(M);\r\n if M > 12 then\r\n begin\r\n M := 1;\r\n Inc(Y);\r\n end;\r\n end;\r\n\r\n SendMessage(Handle, MCM_SETDAYSTATE, VisibleMonths, LPARAM(@DayArray));\r\n // MonthCal_SetDayState(Handle,VisibleMonths,aNMDayState);\r\nend;\r\n\r\nprocedure TJvCustomMonthCalendar.DoDateSelect(StartDate, EndDate: TDateTime);\r\nbegin\r\n if Assigned(FOnSelect) then\r\n FOnSelect(Self, StartDate, EndDate);\r\nend;\r\n\r\nprocedure TJvCustomMonthCalendar.DoDateSelChange(StartDate, EndDate: TDateTime);\r\nbegin\r\n if Assigned(FOnSelChange) then\r\n FOnSelChange(Self, StartDate, EndDate);\r\nend;\r\n\r\nprocedure TJvCustomMonthCalendar.CheckDayState(Year, Month: Word; var DayState: TMonthDayState);\r\nbegin\r\n DayState := StringToDayStates(\r\n TMonthCalStrings(FAppearance.BoldDays).GetBoldDays(Year, Month) + ',' +\r\n TMonthCalStrings(FAppearance.BoldDays).GetBoldDays(0, Month));\r\nend;\r\n\r\nprocedure TJvCustomMonthCalendar.DoGetDayState(var DayState: TNMDayState; var StateArray: TMonthDayStateArray);\r\nvar\r\n LDate: TDateTime;\r\n I: Integer;\r\n Y, M: Word;\r\nbegin\r\n FillChar(StateArray, SizeOf(TMonthDayStateArray), #0);\r\n with DayState.stStart do\r\n begin\r\n Y := wYear;\r\n M := wMonth;\r\n end;\r\n with DayState do\r\n for I := 0 to cDayState - 1 do\r\n begin\r\n CheckDayState(Y, M, StateArray[I]);\r\n Inc(M);\r\n if M > 12 then\r\n begin\r\n M := 1;\r\n Inc(Y);\r\n end;\r\n end;\r\n\r\n with DayState.stStart do\r\n LDate := Trunc(EncodeDate(wYear, wMonth, 1));\r\n\r\n if Assigned(FOnGetState) then\r\n with DayState do\r\n FOnGetState(Self, LDate, cDayState, StateArray);\r\n DayState.prgDayState := PMonthDayState(@StateArray);\r\nend;\r\n\r\nprocedure TJvCustomMonthCalendar.CreateWnd;\r\nbegin\r\n inherited CreateWnd;\r\n FAppearance.Colors.SetAllColors;\r\n Change;\r\nend;\r\n\r\nprocedure TJvCustomMonthCalendar.ColorChanged;\r\nbegin\r\n inherited ColorChanged;\r\n Windows.InvalidateRect(Handle, nil, True);\r\nend;\r\n\r\nprocedure TJvCustomMonthCalendar.FontChanged;\r\nbegin\r\n inherited FontChanged;\r\n// if HandleAllocated then\r\n// Perform(WM_SIZE,0,0);\r\n Windows.InvalidateRect(Handle, nil, True);\r\nend;\r\n\r\nprocedure TJvCustomMonthCalendar.SetMultiSelect(Value: Boolean);\r\nbegin\r\n if FMultiSelect <> Value then\r\n begin\r\n FMultiSelect := Value;\r\n RecreateWnd;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomMonthCalendar.SetShowToday(Value: Boolean);\r\nbegin\r\n FAppearance.ShowToday := Value;\r\nend;\r\n\r\nprocedure TJvCustomMonthCalendar.SetCircleToday(Value: Boolean);\r\nbegin\r\n FAppearance.CircleToday := Value;\r\nend;\r\n\r\nprocedure TJvCustomMonthCalendar.SetWeekNumbers(Value: Boolean);\r\nbegin\r\n FAppearance.WeekNumbers := Value;\r\nend;\r\n\r\nprocedure TJvCustomMonthCalendar.SetFirstDayOfWeek(Value: TJvMonthCalWeekDay);\r\nbegin\r\n FAppearance.FirstDayOfWeek := Value;\r\nend;\r\n\r\nprocedure TJvCustomMonthCalendar.SetMaxSelCount(Value: Word);\r\nbegin\r\n if FMaxSelCount <> Value then\r\n begin\r\n FMaxSelCount := Value;\r\n Change;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomMonthCalendar.SetMinDate(Value: TDateTime);\r\nbegin\r\n if FMinDate <> Value then\r\n begin\r\n FMinDate := Value;\r\n Change;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomMonthCalendar.SetMaxDate(Value: TDateTime);\r\nbegin\r\n if FMaxDate <> Value then\r\n begin\r\n FMaxDate := Value;\r\n Change;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomMonthCalendar.SetFirstSelDate(Value: TDateTime);\r\nbegin\r\n FFirstSelDate := Value;\r\n SetSelectedDays(FFirstSelDate, FLastSelDate);\r\nend;\r\n\r\nfunction TJvCustomMonthCalendar.GetFirstSelDate: TDateTime;\r\nvar\r\n RGST: array [0..1] of TSystemTime;\r\nbegin\r\n Result := FFirstSelDate;\r\n if not HandleAllocated then\r\n Exit;\r\n if FMultiSelect then\r\n MonthCal_GetSelRange(Handle, @RGST[0])\r\n else\r\n MonthCal_GetCurSel(Handle, RGST[0]);\r\n with RGST[0] do\r\n FFirstSelDate := EncodeDate(wYear, wMonth, wDay);\r\n Result := FFirstSelDate;\r\nend;\r\n\r\nprocedure TJvCustomMonthCalendar.SetLastSelDate(Value: TDateTime);\r\nbegin\r\n if FLastSelDate <> Value then\r\n begin\r\n FLastSelDate := Value;\r\n SetSelectedDays(FLastSelDate, FFirstSelDate);\r\n end;\r\nend;\r\n\r\nfunction TJvCustomMonthCalendar.GetLastSelDate: TDateTime;\r\nvar\r\n RGST: array [0..1] of TSystemTime;\r\nbegin\r\n Result := FLastSelDate;\r\n if not HandleAllocated then\r\n Exit;\r\n if not FMultiSelect then\r\n begin\r\n Result := FLastSelDate;\r\n Exit;\r\n end;\r\n if MonthCal_GetSelRange(Handle, @RGST[0]) then\r\n with RGST[1] do\r\n FLastSelDate := Trunc(EncodeDate(wYear, wMonth, wDay));\r\nend;\r\n\r\nprocedure TJvCustomMonthCalendar.SetSelectedDays(dFrom, dTo: TDateTime);\r\nvar\r\n RGST: array [0..1] of TSystemTime;\r\nbegin\r\n if not HandleAllocated then\r\n Exit;\r\n if FMultiSelect then\r\n begin\r\n if (dFrom <> 0) and (dTo <> 0) then\r\n begin\r\n with RGST[0] do\r\n DecodeDate(dFrom, wYear, wMonth, wDay);\r\n with RGST[1] do\r\n DecodeDate(dTo, wYear, wMonth, wDay);\r\n MonthCal_SetSelRange(Handle, @RGST[0]);\r\n end\r\n else\r\n MonthCal_SetSelRange(Handle, nil);\r\n end\r\n else\r\n begin\r\n with RGST[0] do\r\n DecodeDate(dFrom, wYear, wMonth, wDay);\r\n MonthCal_SetCurSel(Handle, RGST[0]);\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomMonthCalendar.SetMonthDelta(Value: Integer);\r\nbegin\r\n if FMonthDelta <> Value then\r\n begin\r\n FMonthDelta := Value;\r\n Change;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomMonthCalendar.SetToday(Value: TDateTime);\r\nbegin\r\n if FToday <> Value then\r\n begin\r\n FToday := Value;\r\n Change;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomMonthCalendar.SetBorderStyle(Value: TBorderStyle);\r\nbegin\r\n if FBorderStyle <> Value then\r\n begin\r\n FBorderStyle := Value;\r\n RecreateWnd;\r\n end;\r\nend;\r\n\r\nfunction TJvCustomMonthCalendar.GetTodayWidth: Integer;\r\nbegin\r\n Result := SendMessage(Handle, MCM_GETMAXTODAYWIDTH, 0, 0);\r\nend;\r\n\r\nfunction TJvCustomMonthCalendar.VisibleMonths: Integer;\r\nbegin\r\n Result := 1;\r\n if not HandleAllocated then\r\n Exit;\r\n Result := MonthCal_GetMonthRange(Handle, GMR_DAYSTATE, nil);\r\nend;\r\n\r\nprocedure TJvCustomMonthCalendar.SetDayStates(MonthCount: Integer; DayStates: array of TMonthDayState);\r\nvar\r\n Index: Integer;\r\nbegin\r\n if not HandleAllocated then\r\n Exit;\r\n Index := High(DayStates) - Low(DayStates);\r\n if (Index < MonthCount) or (Index < VisibleMonths) then\r\n raise EMonthCalError.CreateRes(@RsEInvalidArgumentToSetDayStates);\r\n SendMessage(Handle, MCM_SETDAYSTATE, MonthCount, LPARAM(@DayStates));\r\nend;\r\n\r\n// first default width = 166\r\n// next width = 334 (+ 168)\r\n// next width = 502 (+ 168)\r\n// next width = 670 (+ 168)\r\n// first default height = 157\r\n// next height = 299 (+ 142)\r\n// next height = 441 (+ 142)\r\n// next height = 583 (+ 142)\r\n\r\nfunction TJvCustomMonthCalendar.GetMinSize: TRect;\r\nbegin\r\n if HandleAllocated then\r\n begin\r\n SendMessage(Handle, MCM_GETMINREQRECT, 0, LPARAM(@Result));\r\n OffSetRect(Result, -Result.Left, -Result.Top);\r\n end\r\n else\r\n Result := Rect(0, 0, 191, 154);\r\nend;\r\n\r\nprocedure TJvCustomMonthCalendar.CNNotify(var Msg: TWMNotify);\r\nvar\r\n dFrom, dTo: TDateTime;\r\n StateArray: TMonthDayStateArray;\r\nbegin\r\n with Msg.NMHdr^ do\r\n case Code of\r\n MCN_GETDAYSTATE:\r\n DoGetDayState(PNMDayState(Msg.NMHdr)^, StateArray);\r\n MCN_SELCHANGE:\r\n begin\r\n if IsBlankDate(PNMSelChange(Msg.NMHdr)^.stSelStart) then\r\n Exit;\r\n with PNMSelChange(Msg.NMHdr)^.stSelStart do\r\n dFrom := Trunc(EncodeDate(wYear, wMonth, wDay));\r\n if IsBlankDate(PNMSelChange(Msg.NMHdr)^.stSelEnd) then\r\n dTo := dFrom\r\n else\r\n with PNMSelChange(Msg.NMHdr)^.stSelEnd do\r\n dTo := Trunc(EncodeDate(wYear, wMonth, wDay));\r\n DoDateSelChange(dFrom, dTo);\r\n end;\r\n MCN_SELECT:\r\n begin\r\n if IsBlankDate(PNMSelChange(Msg.NMHdr)^.stSelStart) then\r\n Exit;\r\n with PNMSelChange(Msg.NMHdr)^.stSelStart do\r\n dFrom := Trunc(EncodeDate(wYear, wMonth, wDay));\r\n if IsBlankDate(PNMSelChange(Msg.NMHdr)^.stSelEnd) then\r\n dTo := dFrom\r\n else\r\n with PNMSelChange(Msg.NMHdr)^.stSelEnd do\r\n dTo := Trunc(EncodeDate(wYear, wMonth, wDay));\r\n DoDateSelect(dFrom, dTo);\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomMonthCalendar.ConstrainedResize(var MinWidth, MinHeight,\r\n MaxWidth, MaxHeight: Integer);\r\nvar\r\n R: TRect;\r\n CtlMinWidth, CtlMinHeight: Integer;\r\nbegin\r\n if HandleAllocated then\r\n begin\r\n MonthCal_GetMinReqRect(Handle, R);\r\n CtlMinHeight := R.Bottom - R.Top;\r\n CtlMinWidth := R.Right - R.Left;\r\n if MinHeight < CtlMinHeight then\r\n MinHeight := CtlMinHeight;\r\n if MinWidth < CtlMinWidth then\r\n MinWidth := CtlMinWidth;\r\n end;\r\n inherited ConstrainedResize(MinWidth, MinHeight, MaxWidth, MaxHeight);\r\nend;\r\n\r\nfunction TJvCustomMonthCalendar.CanAutoSize(var NewWidth, NewHeight: Integer): Boolean;\r\nvar\r\n R: TRect;\r\nbegin\r\n if HandleAllocated then\r\n begin\r\n Result := True;\r\n R := MinSize;\r\n NewWidth := R.Right - R.Left + Ord(BorderStyle = bsSingle) * 2;\r\n NewHeight := R.Bottom - R.Top + Ord(BorderStyle = bsSingle) * 2;\r\n end\r\n else\r\n Result := False;\r\nend;\r\n\r\nprocedure TJvCustomMonthCalendar.GetDlgCode(var Code: TDlgCodes);\r\nbegin\r\n Code := [dcWantArrows];\r\nend;\r\n\r\nprocedure TJvCustomMonthCalendar.WMLButtonDown(var Msg: TWMLButtonDown);\r\nbegin\r\n SetFocus;\r\n inherited;\r\nend;\r\n\r\nfunction TJvCustomMonthCalendar.GetBoldDays: TStrings;\r\nbegin\r\n Result := FAppearance.BoldDays;\r\nend;\r\n\r\nfunction TJvCustomMonthCalendar.GetCircleToday: Boolean;\r\nbegin\r\n Result := FAppearance.CircleToday;\r\nend;\r\n\r\nfunction TJvCustomMonthCalendar.GetColors: TJvMonthCalColors;\r\nbegin\r\n Result := FAppearance.Colors;\r\nend;\r\n\r\nfunction TJvCustomMonthCalendar.GetShowToday: Boolean;\r\nbegin\r\n Result := FAppearance.ShowToday;\r\nend;\r\n\r\nfunction TJvCustomMonthCalendar.GetWeekNumbers: Boolean;\r\nbegin\r\n Result := FAppearance.WeekNumbers;\r\nend;\r\n\r\nfunction TJvCustomMonthCalendar.GetFirstDayOfWeek: TJvMonthCalWeekDay;\r\nbegin\r\n Result := FAppearance.FirstDayOfWeek;\r\nend;\r\n\r\nprocedure TJvCustomMonthCalendar.FocusKilled(NextWnd: THandle);\r\nbegin\r\n FLeaving := True;\r\n try\r\n inherited FocusKilled(NextWnd);\r\n DoFocusKilled(FindControl(NextWnd));\r\n finally\r\n FLeaving := False;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomMonthCalendar.FocusSet(PrevWnd: THandle);\r\nbegin\r\n FEntering := True;\r\n try\r\n inherited FocusSet(PrevWnd);\r\n if Screen.ActiveControl = Self then\r\n DoFocusSet(FindControl(PrevWnd));\r\n finally\r\n FEntering := False;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomMonthCalendar.DoFocusSet(const APreviousControl: TWinControl);\r\nbegin\r\n if Assigned(OnSetFocus) then\r\n OnSetFocus(Self, APreviousControl);\r\nend;\r\n\r\nprocedure TJvCustomMonthCalendar.DoFocusKilled(const ANextControl: TWinControl);\r\nbegin\r\n if Assigned(OnKillFocus) then\r\n OnKillFocus(Self, ANextControl);\r\nend;\r\n\r\n//=== { TJvMonthCalAppearance } ==============================================\r\n\r\nconstructor TJvMonthCalAppearance.Create;\r\nbegin\r\n inherited Create;\r\n FCircleToday := True;\r\n FColors := TJvMonthCalColors.Create(nil);\r\n FBoldDays := TMonthCalStrings.Create;\r\n FShowToday := True;\r\n FWeekNumbers := False;\r\n FFirstDoW := mcLocale;\r\nend;\r\n\r\ndestructor TJvMonthCalAppearance.Destroy;\r\nbegin\r\n FreeAndNil(FColors);\r\n FreeAndNil(FBoldDays);\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJvMonthCalAppearance.GetCalendar: TJvCustomMonthCalendar;\r\nbegin\r\n Result := FColors.Calendar;\r\nend;\r\n\r\nfunction TJvMonthCalAppearance.GetBoldDays: TStrings;\r\nbegin\r\n Result := FBoldDays;\r\nend;\r\n\r\nprocedure TJvMonthCalAppearance.SetBoldDays(AValue: TStrings);\r\nbegin\r\n FBoldDays.Assign(AValue);\r\nend;\r\n\r\nprocedure TJvMonthCalAppearance.SetCalendar(AValue: TJvCustomMonthCalendar);\r\nbegin\r\n FColors.FCalendar := AValue;\r\n TMonthCalStrings(FBoldDays).FCalendar := AValue;\r\nend;\r\n\r\nprocedure TJvMonthCalAppearance.SetCircleToday(const AValue: Boolean);\r\nbegin\r\n if FCircleToday <> AValue then\r\n begin\r\n FCircleToday := AValue;\r\n if Assigned(Calendar) then\r\n Calendar.RecreateWnd;\r\n end;\r\nend;\r\n\r\nprocedure TJvMonthCalAppearance.SetColors(const AValue: TJvMonthCalColors);\r\nbegin\r\n FColors.Assign(AValue);\r\nend;\r\n\r\nprocedure TJvMonthCalAppearance.SetFirstDoW(const AValue: TJvMonthCalWeekDay);\r\nbegin\r\n if FFirstDoW <> AValue then\r\n begin\r\n FFirstDoW := AValue;\r\n if Assigned(Calendar) then\r\n Calendar.Change;\r\n end;\r\nend;\r\n\r\nprocedure TJvMonthCalAppearance.SetShowToday(const AValue: Boolean);\r\nbegin\r\n if FShowToday <> AValue then\r\n begin\r\n FShowToday := AValue;\r\n if Assigned(Calendar) then\r\n Calendar.RecreateWnd;\r\n end;\r\nend;\r\n\r\nprocedure TJvMonthCalAppearance.SetWeekNumbers(const AValue: Boolean);\r\nbegin\r\n if FWeekNumbers <> AValue then\r\n begin\r\n FWeekNumbers := AValue;\r\n if Assigned(Calendar) then\r\n Calendar.RecreateWnd;\r\n end;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvCaptionButton.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvCaptionButton.PAS, released on 2002-05-26.\r\n\r\nThe Initial Developer of the Original Code is Peter Thrnqvist [peter3 at sourceforge dot net]\r\nPortions created by Peter Thrnqvist are Copyright (C) 2002 Peter Thrnqvist.\r\n\r\nThis unit is a merging of the original TJvCaptionButton, TJvaCaptionButton.\r\nMerging done 2003-06-12 by Remko Bonte [remkobonte at myrealbox dot com]\r\n\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\n Andrei Prygounkov , author of TJvaCaptionButton.\r\n Remko Bonte [remkobonte at myrealbox dot com], theme support, actions\r\n Olivier Sannier [obones att altern dott org], caption hints.\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nModified 2003-06-13 (p3):\r\n- Fixed MouseUp X,Y inconsistentcy (did not report the same values as MouseDown)\r\n- Added MouseMove handler\r\n- Added ShowHint, ParentShowHint\r\n- Fixed drawing of disabled MinimizeToTray icon as well as incorrect Font.Color in text drawing\r\n- Added Assign\r\n- Tested on W2k\r\n- Demo (examples\\CaptionBtn) updated and extended\r\n\r\nKnown Issues:\r\n\r\n * Msimg32.dll code should be moved to seperate import unit. Code is partly\r\n copied from JwaWinGDI.pas.\r\n * Button can disappear at design-time when switching themes.\r\n * With more buttons, button can appear hot while mouse is over another caption\r\n button.\r\n * Still some flicker while resizing due to wrong FButtonRect, see comment\r\n at HandleNCPaintBefore.\r\n * Buttons on small caption (BorderStyle in [bsSizeToolWin, bsToolWin]) looks\r\n ugly.\r\n\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvCaptionButton.pas 13415 2012-09-10 09:51:54Z obones $\r\n\r\nunit JvCaptionButton;\r\n\r\n{$I jvcl.inc}\r\n{$I windowsonly.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, Messages, Classes, Graphics, Controls, Forms, Types,\r\n ActnList, ImgList,\r\n {$IFDEF HAS_UNIT_SYSTEM_UITYPES}\r\n System.UITypes,\r\n {$ENDIF HAS_UNIT_SYSTEM_UITYPES}\r\n JvComponentBase, JvTypes;\r\n\r\ntype\r\n TJvStandardButton = (tsbNone, tsbClose, tsbHelp, tsbMax, tsbMin, tsbRestore,\r\n tsbMinimizeToTray); // a la e-Mule\r\n TJvCaptionButtonLayout = (cbImageLeft, cbImageRight);\r\n TJvRedrawKind = (rkDirect, rkIndirect, rkTotalCaptionBar);\r\n\r\n TJvCaptionButton = class;\r\n\r\n TJvCaptionButtonActionLink = class(TActionLink)\r\n protected\r\n FClient: TJvCaptionButton;\r\n procedure AssignClient(AClient: TObject); override;\r\n function IsCaptionLinked: Boolean; override;\r\n function IsEnabledLinked: Boolean; override;\r\n function IsHintLinked: Boolean; override;\r\n function IsImageIndexLinked: Boolean; override;\r\n function IsVisibleLinked: Boolean; override;\r\n function IsOnExecuteLinked: Boolean; override;\r\n\r\n procedure SetCaption(const Value: string); override;\r\n procedure SetEnabled(Value: Boolean); override;\r\n procedure SetHint(const Value: string); override;\r\n procedure SetImageIndex(Value: Integer); override;\r\n procedure SetVisible(Value: Boolean); override;\r\n procedure SetOnExecute(Value: TNotifyEvent); override;\r\n end;\r\n\r\n TJvCaptionButtonActionLinkClass = class of TJvCaptionButtonActionLink;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvCaptionButton = class(TJvComponent)\r\n private\r\n { Properties }\r\n FAlignment: TAlignment;\r\n FHeight: Integer;\r\n FLeft: Integer;\r\n FTop: Integer;\r\n FWidth: Integer;\r\n FCaption: string;\r\n FDown: Boolean;\r\n FEnabled: Boolean;\r\n FFont: TFont;\r\n FHint: string;\r\n FImageIndex: TImageIndex;\r\n FImages: TCustomImageList;\r\n FLayout: TJvCaptionButtonLayout;\r\n FMargin: Integer;\r\n FPosition: Integer;\r\n FSpacing: Integer;\r\n FStandard: TJvStandardButton;\r\n FToggle: Boolean;\r\n FVisible: Boolean;\r\n FOnClick: TNotifyEvent;\r\n FOnMouseUp: TMouseEvent;\r\n FOnMouseDown: TMouseEvent;\r\n FOnMouseMove: TMouseMoveEvent;\r\n\r\n FDefaultButtonLeft: Integer;\r\n FDefaultButtonTop: Integer;\r\n FDefaultButtonWidth: Integer;\r\n FDefaultButtonHeight: Integer;\r\n\r\n FActionLink: TJvCaptionButtonActionLink;\r\n FBuffer: TBitmap;\r\n FButtonRect: TRect;\r\n FCaptionHeight: Integer;\r\n FClickRect: TRect; // Clickable area is a bit bigger than the button\r\n FHasCaption: Boolean; // True, if the form has a caption\r\n FHasSmallCaption: Boolean; // True, if the form has BorderStyle bsToolWindow, bsSizeToolWin\r\n FImageChangeLink: TChangeLink;\r\n FMouseButtonDown: Boolean;\r\n FMouseInControl: Boolean;\r\n FNeedRecalculate: Boolean;\r\n FRgnChanged: Boolean;\r\n FSaveRgn: HRGN;\r\n FShowHint: Boolean;\r\n FParentShowHint: Boolean;\r\n {tool tip specific}\r\n FToolTipHandle: THandle;\r\n {tool tip specific end}\r\n FCurrentWindowState: TWindowState;\r\n\r\n {$IFDEF JVCLThemesEnabled}\r\n FCaptionActive: Boolean;\r\n FForceDrawSimple: Boolean;\r\n FForceRedraw: Boolean;\r\n function GetIsThemed: Boolean;\r\n procedure SetForceDrawSimple(const Value: Boolean);\r\n {$ENDIF JVCLThemesEnabled}\r\n function GetAction: TBasicAction;\r\n function GetIsImageVisible: Boolean;\r\n function GetParentForm: TCustomForm;\r\n function GetParentFormHandle: THandle;\r\n function IsCaptionStored: Boolean;\r\n function IsEnabledStored: Boolean;\r\n function IsHintStored: Boolean;\r\n function IsImageIndexStored: Boolean;\r\n procedure SetAction(const Value: TBasicAction);\r\n procedure SetAlignment(Value: TAlignment);\r\n procedure SetCaption(Value: string);\r\n procedure SetDown(const Value: Boolean);\r\n procedure SetEnabled(const Value: Boolean);\r\n procedure SetFont(Value: TFont);\r\n procedure SetHeight(Value: Integer);\r\n procedure SetImageIndex(const Value: TImageIndex);\r\n procedure SetImages(const Value: TCustomImageList);\r\n procedure SetLayout(const Value: TJvCaptionButtonLayout);\r\n procedure SetLeft(Value: Integer);\r\n procedure SetMargin(const Value: Integer);\r\n procedure SetMouseInControl(const Value: Boolean);\r\n procedure SetPosition(const Value: Integer);\r\n procedure SetSpacing(const Value: Integer);\r\n procedure SetStandard(Value: TJvStandardButton);\r\n procedure SetToggle(const Value: Boolean);\r\n procedure SetTop(Value: Integer);\r\n procedure SetVisible(const Value: Boolean);\r\n procedure SetWidth(Value: Integer);\r\n\r\n {tool tip handling}\r\n procedure CreateToolTip(Wnd: THandle);\r\n procedure DestroyToolTip;\r\n procedure HideToolTip;\r\n procedure ForwardToToolTip(Msg: TMessage);\r\n\r\n procedure Hook;\r\n procedure UnHook;\r\n function WndProcAfter(var Msg: TMessage): Boolean;\r\n function WndProcBefore(var Msg: TMessage): Boolean;\r\n\r\n procedure DrawButton(DC: HDC);\r\n {$IFDEF JVCLThemesEnabled}\r\n procedure DrawButtonBackground(ACanvas: TCanvas);\r\n {$ENDIF JVCLThemesEnabled}\r\n procedure DrawStandardButton(ACanvas: TCanvas);\r\n procedure DrawNonStandardButton(ACanvas: TCanvas);\r\n procedure DrawButtonImage(ACanvas: TCanvas; ImageBounds: TRect);\r\n procedure DrawButtonText(ACanvas: TCanvas; TextBounds: TRect);\r\n\r\n procedure Redraw(const AKind: TJvRedrawKind);\r\n procedure CalcDefaultButtonRect(Wnd: THandle);\r\n\r\n {Paint related messages}\r\n procedure HandleNCActivate(var Msg: TWMNCActivate);\r\n procedure HandleNCPaintAfter(Wnd: THandle; var Msg: TWMNCPaint);\r\n procedure HandleNCPaintBefore(Wnd: THandle; var Msg: TWMNCPaint);\r\n {Mouse down-related messages}\r\n function HandleButtonDown(var Msg: TWMNCHitMessage): Boolean;\r\n function HandleButtonUp(var Msg: TWMNCHitMessage): Boolean;\r\n function HandleHitTest(var Msg: TWMNCHitTest): Boolean;\r\n function HandleMouseMove(var Msg: TWMNCHitMessage): Boolean;\r\n procedure HandleNCMouseMove(var Msg: TWMNCHitMessage);\r\n {Other}\r\n function HandleNotify(var Msg: TWMNotify): Boolean;\r\n\r\n procedure ImageListChange(Sender: TObject);\r\n procedure DoActionChange(Sender: TObject);\r\n\r\n function MouseOnButton(X, Y: Integer; const TranslateToScreenCoord: Boolean): Boolean;\r\n procedure SetParentShowHint(const Value: Boolean);\r\n procedure SetShowHint(const Value: Boolean);\r\n protected\r\n procedure ActionChange(Sender: TObject; CheckDefaults: Boolean); dynamic;\r\n procedure CalcButtonParts(ACanvas: TCanvas; ButtonRect: TRect; var RectText, RectImage: TRect);\r\n function GetActionLinkClass: TJvCaptionButtonActionLinkClass; dynamic;\r\n procedure Loaded; override;\r\n procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); virtual;\r\n procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); virtual;\r\n procedure MouseMove(Shift: TShiftState; X, Y: Integer); virtual;\r\n procedure Notification(AComponent: TComponent; Operation: TOperation); override;\r\n procedure UpdateButtonRect(Wnd: THandle);\r\n\r\n property ActionLink: TJvCaptionButtonActionLink read FActionLink write FActionLink;\r\n property IsImageVisible: Boolean read GetIsImageVisible;\r\n {$IFDEF JVCLThemesEnabled}\r\n // The value of IsThemed stays the same until a WM_THEMECHANGED is received.\r\n property IsThemed: Boolean read GetIsThemed;\r\n {$ENDIF JVCLThemesEnabled}\r\n property MouseInControl: Boolean read FMouseInControl;\r\n property ParentFormHandle: THandle read GetParentFormHandle;\r\n property ParentForm: TCustomForm read GetParentForm;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n procedure Assign(Source: TPersistent); override;\r\n procedure InitiateAction; virtual;\r\n procedure ResetButton;\r\n procedure Click; dynamic;\r\n\r\n property DefaultButtonWidth: Integer read FDefaultButtonWidth;\r\n published\r\n property Action: TBasicAction read GetAction write SetAction;\r\n property Alignment: TAlignment read FAlignment write SetAlignment default taLeftJustify;\r\n property ButtonHeight: Integer read FHeight write SetHeight default 0;\r\n property ButtonLeft: Integer read FLeft write SetLeft default 0;\r\n property ButtonTop: Integer read FTop write SetTop default 0;\r\n property ButtonWidth: Integer read FWidth write SetWidth default 0;\r\n property Caption: string read FCaption write SetCaption stored IsCaptionStored;\r\n property Down: Boolean read FDown write SetDown default False;\r\n {$IFDEF JVCLThemesEnabled}\r\n property ForceDrawSimple: Boolean read FForceDrawSimple write SetForceDrawSimple default False;\r\n {$ENDIF JVCLThemesEnabled}\r\n property ShowHint: Boolean read FShowHint write SetShowHint default False;\r\n property ParentShowHint: Boolean read FParentShowHint write SetParentShowHint default True;\r\n property Enabled: Boolean read FEnabled write SetEnabled stored IsEnabledStored default True;\r\n property Font: TFont read FFont write SetFont;\r\n property Hint: string read FHint write FHint stored IsHintStored;\r\n property ImageIndex: TImageIndex read FImageIndex write SetImageIndex stored IsImageIndexStored default -1;\r\n property Images: TCustomImageList read FImages write SetImages;\r\n property Layout: TJvCaptionButtonLayout read FLayout write SetLayout default cbImageLeft;\r\n property Margin: Integer read FMargin write SetMargin default -1;\r\n property Position: Integer read FPosition write SetPosition default 0;\r\n property Spacing: Integer read FSpacing write SetSpacing default 4;\r\n property Standard: TJvStandardButton read FStandard write SetStandard default tsbNone;\r\n property Toggle: Boolean read FToggle write SetToggle default False;\r\n property Visible: Boolean read FVisible write SetVisible default True;\r\n property OnClick: TNotifyEvent read FOnClick write FOnClick;\r\n property OnMouseUp: TMouseEvent read FOnMouseUp write FOnMouseUp;\r\n property OnMouseDown: TMouseEvent read FOnMouseDown write FOnMouseDown;\r\n property OnMouseMove: TMouseMoveEvent read FOnMouseMove write FOnMouseMove;\r\n end;\r\n\r\nfunction TransparentBlt(hdcDest: HDC; nXOriginDest, nYOriginDest, nWidthDest, hHeightDest: Integer;\r\n hdcSrc: HDC; nXOriginSrc, nYOriginSrc, nWidthSrc, nHeightSrc: Integer;\r\n crTransparent: UINT): BOOL; stdcall;\r\nfunction AlphaBlend(hdcDest: HDC; nXOriginDest, nYOriginDest, nWidthDest,\r\n nHeightDest: Integer; hdcSrc: HDC; nXOriginSrc, nYOriginSrc, nWidthSrc,\r\n nHeightSrc: Integer; BlendFunction: BLENDFUNCTION): BOOL; stdcall;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvCaptionButton.pas $';\r\n Revision: '$Revision: 13415 $';\r\n Date: '$Date: 2012-09-10 11:51:54 +0200 (lun. 10 sept. 2012) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n CommCtrl, Buttons, SysUtils,\r\n JvThemes,\r\n {$IFDEF JVCLThemesEnabled}\r\n UxTheme,\r\n {$IFNDEF COMPILER7_UP}\r\n TmSchema,\r\n {$ENDIF !COMPILER7_UP}\r\n {$ENDIF JVCLThemesEnabled}\r\n JvDsgnIntf, JvJCLUtils, JvResources, JvWndProcHook, JvJVCLUtils;\r\n\r\nconst\r\n { Msimg32.dll is included in Windows 98 and later }\r\n Msimg32DLLName = 'Msimg32.dll';\r\n\r\n TransparentBltName = 'TransparentBlt';\r\n AlphaBlendName = 'AlphaBlend';\r\n\r\n htCaptionButton = HTSIZELAST + 1;\r\n Alignments: array [TAlignment] of Word = (DT_LEFT, DT_RIGHT, DT_CENTER);\r\n\r\nvar\r\n GMsimg32Handle: THandle = 0;\r\n GTriedLoadMsimg32Dll: Boolean = False;\r\n\r\n _AlphaBlend: function(hdcDest: HDC; nXOriginDest, nYOriginDest, nWidthDest,\r\n nHeightDest: Integer; hdcSrc: HDC; nXOriginSrc, nYOriginSrc, nWidthSrc,\r\n nHeightSrc: Integer; BlendFunction: BLENDFUNCTION): BOOL; stdcall;\r\n _TransparentBlt: function(hdcDest: HDC; nXOriginDest, nYOriginDest, nWidthDest, hHeightDest: Integer;\r\n hdcSrc: HDC; nXOriginSrc, nYOriginSrc, nWidthSrc, nHeightSrc: Integer;\r\n crTransparent: UINT): BOOL; stdcall;\r\n\r\n{$IFDEF JVCLThemesEnabled}\r\n\r\ntype\r\n { (rb) I couldn't get the alpha channel to work with the normal TBitmap so\r\n introduced TAlphaBitmap. TBitmapAdapter hides the implementation details\r\n of the TBitmap/TAlphaBitmap }\r\n\r\n TAlphaBitmap = class(TObject)\r\n private\r\n FHandle: HDC;\r\n FBitmapInfo: TBitmapInfo;\r\n FDIBHandle: HBitmap;\r\n FOldBitmap: HBitmap;\r\n FBitsMem: Pointer;\r\n FBitCount: Byte;\r\n FHasAlphaChannel: Boolean;\r\n function GetWidth: Integer;\r\n function GetHeight: Integer;\r\n protected\r\n procedure CreateHandle(AWidth, AHeight: Integer);\r\n function CreateDIB(ADC: HDC; AWidth, AHeight: Integer): HBitmap;\r\n procedure Duplicate(Src: HBitmap);\r\n procedure FreeHandle;\r\n procedure InitAlpha;\r\n public\r\n destructor Destroy; override;\r\n procedure Assign(Source: TPersistent);\r\n\r\n procedure LoadFromResourceID(Instance: THandle; ResID: Integer);\r\n procedure LoadFromResourceName(Instance: THandle; const ResName: string);\r\n\r\n property Handle: HDC read FHandle;\r\n property Width: Integer read GetWidth;\r\n property Height: Integer read GetHeight;\r\n property Data: Pointer read FBitsMem;\r\n property BitCount: Byte read FBitCount;\r\n property HasAlphaChannel: Boolean read FHasAlphaChannel;\r\n end;\r\n\r\n TBitmapAdapter = class(TObject)\r\n private\r\n FBitmap: TObject;\r\n FMargins: TMargins;\r\n FTransparentColor: TColorRef;\r\n function GetHeight: Integer;\r\n function GetWidth: Integer;\r\n function GetIsValid: Boolean;\r\n public\r\n constructor Create; virtual;\r\n destructor Destroy; override;\r\n procedure Clear;\r\n procedure Assign(Source: TPersistent);\r\n\r\n procedure LoadFromResourceName(Instance: THandle; const ResName: string);\r\n procedure LoadFromResourceID(Instance: THandle; ResID: Integer);\r\n\r\n function Draw(ACanvas: TCanvas; const Rect: TRect; AMargins: PMargins): Boolean;\r\n function DrawFixed(ACanvas: TCanvas; const X, Y: Integer): Boolean;\r\n function DrawFixedPart(ACanvas: TCanvas; const DestRect: TRect; const SrcX, SrcY: Integer): Boolean;\r\n function DrawPart(ACanvas: TCanvas; const SrcRect, DestRect: TRect; AMargins: PMargins): Boolean;\r\n\r\n property Margins: TMargins read FMargins write FMargins;\r\n property Width: Integer read GetWidth;\r\n property Height: Integer read GetHeight;\r\n property IsValid: Boolean read GetIsValid;\r\n property TransparentColor: TColorRef read FTransparentColor write FTransparentColor;\r\n end;\r\n\r\n TGlobalXPData = class(TObject)\r\n private\r\n FCaptionButtonHeight: Integer;\r\n FCaptionButtonCount: Integer;\r\n FCaptionButtons: TBitmapAdapter;\r\n\r\n FIsThemed: Boolean;\r\n FBitmapValid: Boolean;\r\n FClientCount: Integer;\r\n public\r\n constructor Create; virtual;\r\n destructor Destroy; override;\r\n\r\n procedure AddClient;\r\n procedure RemoveClient;\r\n\r\n procedure Update;\r\n procedure DrawSimple(ACanvas: TCanvas; State: Integer; const DrawRect: TRect);\r\n function Draw(ACanvas: TCanvas; State: Integer; const DrawRect: TRect): Boolean;\r\n property IsThemed: Boolean read FIsThemed;\r\n end;\r\n\r\nvar\r\n GGlobalXPData: TGlobalXPData;\r\n\r\n//=== Local procedures =======================================================\r\n\r\nfunction IsVistaOrNewer: Boolean;\r\nbegin\r\n Result := (Win32Platform = VER_PLATFORM_WIN32_NT) and CheckWin32Version(6, 0);\r\nend;\r\n\r\nfunction GlobalXPData: TGlobalXPData;\r\nbegin\r\n if not Assigned(GGlobalXPData) then\r\n GGlobalXPData := TGlobalXPData.Create;\r\n\r\n Result := GGlobalXPData;\r\nend;\r\n\r\nfunction TranslateBitmapFileName(const S: string): string;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := S;\r\n for I := 1 to Length(S) do\r\n case S[I] of\r\n 'A'..'Z', '0'..'9':\r\n {do nothing};\r\n 'a'..'z':\r\n Result[I] := UpCase(S[I]);\r\n else\r\n Result[I] := '_';\r\n end;\r\nend;\r\n\r\nprocedure DupBits(Src, Dst: HBitmap; Size: TPoint);\r\nvar\r\n MemDC: HDC;\r\n DesktopDC: HDC;\r\n OldBitmap: HBitmap;\r\nbegin\r\n OldBitmap := 0;\r\n DesktopDC := GetDC(GetDesktopWindow);\r\n MemDC := CreateCompatibleDC(DesktopDC);\r\n try\r\n OldBitmap := SelectObject(MemDC, Src);\r\n BitBlt(Dst, 0, 0, Size.X, Size.Y, MemDC, 0, 0, SRCCOPY);\r\n finally\r\n SelectObject(MemDC, OldBitmap);\r\n ReleaseDC(GetDesktopWindow, DesktopDC);\r\n DeleteDC(MemDC);\r\n end;\r\nend;\r\n\r\nfunction GetHasAlphaChannel(Data: PRGBQuad; Count: Integer): Boolean;\r\nbegin\r\n Result := False;\r\n\r\n while Count > 0 do\r\n begin\r\n Result := Data.rgbReserved <> 0;\r\n if Result then\r\n Break;\r\n Inc(Data);\r\n Dec(Count);\r\n end;\r\nend;\r\n\r\nprocedure PreMultiplyAlphaChannel(Data: PRGBQuad; Count: Integer);\r\nbegin\r\n while Count > 0 do\r\n begin\r\n with Data^ do\r\n begin\r\n rgbBlue := (rgbBlue * rgbReserved + 128) div 255;\r\n rgbGreen := (rgbGreen * rgbReserved + 128) div 255;\r\n rgbRed := (rgbRed * rgbReserved + 128) div 255;\r\n end;\r\n Inc(Data);\r\n Dec(Count);\r\n end;\r\nend;\r\n\r\n{$ENDIF JVCLThemesEnabled}\r\n\r\nprocedure UnloadMsimg32Dll;\r\nbegin\r\n @_TransparentBlt := nil;\r\n @_AlphaBlend := nil;\r\n if GMsimg32Handle > 0 then\r\n FreeLibrary(GMsimg32Handle);\r\n GMsimg32Handle := 0;\r\nend;\r\n\r\nprocedure LoadMsimg32Dll;\r\nbegin\r\n GTriedLoadMsimg32Dll := True;\r\n GMsimg32Handle := SafeLoadLibrary(Msimg32DLLName);\r\n if GMsimg32Handle <> 0 then\r\n begin\r\n @_TransparentBlt := GetProcAddress(GMsimg32Handle, TransparentBltName);\r\n @_AlphaBlend := GetProcAddress(GMsimg32Handle, AlphaBlendName);\r\n end;\r\nend;\r\n\r\n{$IFDEF JVCLThemesEnabled}\r\n\r\nfunction TransparentBltStretch(DestDC: HDC; const DestRect: TRect;\r\n SourceDC: HDC; const SourceRect: TRect; const SizingMargins: TMargins;\r\n const TransparentColor: TColor): Boolean;\r\nvar\r\n ESourceWidth, ESourceHeight: Integer;\r\n EDestWidth, EDestHeight: Integer;\r\n LastOriginSource: TPoint;\r\n LastOriginDest: TPoint;\r\nbegin\r\n { Source Dest\r\n\r\n |--------------| |--------------------|\r\n | A | B | C | | A | B | C |\r\n |-- |------|---| |-- |------------|---|\r\n | | | | | | | |\r\n | D | E | F | | | | |\r\n | | | | => | D | E | F |\r\n |---|------|---| | | | |\r\n | G | H | I | | | | |\r\n |--------------| |--------------------|\r\n | G | H | I |\r\n |-- |------------|---|\r\n }\r\n ESourceWidth := SourceRect.Right - SourceRect.Left - SizingMargins.cxLeftWidth - SizingMargins.cxRightWidth;\r\n ESourceHeight := SourceRect.Bottom - SourceRect.Top - SizingMargins.cyTopHeight - SizingMargins.cyBottomHeight;\r\n EDestWidth := DestRect.Right - DestRect.Left - SizingMargins.cxLeftWidth - SizingMargins.cxRightWidth;\r\n EDestHeight := DestRect.Bottom - DestRect.Top - SizingMargins.cyTopHeight - SizingMargins.cyBottomHeight;\r\n\r\n GetWindowOrgEx(SourceDC, LastOriginSource);\r\n SetWindowOrgEx(SourceDC, LastOriginSource.X - SourceRect.Left, LastOriginSource.Y - SourceRect.Top, nil);\r\n GetWindowOrgEx(DestDC, LastOriginDest);\r\n SetWindowOrgEx(DestDC, LastOriginDest.X - DestRect.Left, LastOriginDest.Y - DestRect.Top, nil);\r\n\r\n Result :=\r\n { A }\r\n TransparentBlt(\r\n DestDC,\r\n 0, 0, SizingMargins.cxLeftWidth, SizingMargins.cyTopHeight,\r\n SourceDC,\r\n 0, 0, SizingMargins.cxLeftWidth, SizingMargins.cyTopHeight,\r\n TransparentColor\r\n ) and\r\n\r\n { B }\r\n TransparentBlt(\r\n DestDC,\r\n SizingMargins.cxLeftWidth, 0, EDestWidth, SizingMargins.cyTopHeight,\r\n SourceDC,\r\n SizingMargins.cxLeftWidth, 0, ESourceWidth, SizingMargins.cyTopHeight,\r\n TransparentColor\r\n ) and\r\n\r\n { C }\r\n TransparentBlt(\r\n DestDC,\r\n EDestWidth + SizingMargins.cxLeftWidth, 0, SizingMargins.cxRightWidth, SizingMargins.cyTopHeight,\r\n SourceDC,\r\n ESourceWidth + SizingMargins.cxLeftWidth, 0, SizingMargins.cxRightWidth, SizingMargins.cyTopHeight,\r\n TransparentColor\r\n ) and\r\n\r\n { D }\r\n TransparentBlt(\r\n DestDC,\r\n 0, SizingMargins.cyTopHeight, SizingMargins.cxLeftWidth, EDestHeight,\r\n SourceDC,\r\n 0, SizingMargins.cyTopHeight, SizingMargins.cxLeftWidth, ESourceHeight,\r\n TransparentColor\r\n ) and\r\n\r\n { E }\r\n TransparentBlt(\r\n DestDC,\r\n SizingMargins.cxLeftWidth, SizingMargins.cyTopHeight, EDestWidth, EDestHeight,\r\n SourceDC,\r\n SizingMargins.cxLeftWidth, SizingMargins.cyTopHeight, ESourceWidth, ESourceHeight,\r\n TransparentColor\r\n ) and\r\n\r\n { F }\r\n TransparentBlt(\r\n DestDC,\r\n EDestWidth + SizingMargins.cxLeftWidth, SizingMargins.cyTopHeight, SizingMargins.cxRightWidth, EDestHeight,\r\n SourceDC,\r\n ESourceWidth + SizingMargins.cxLeftWidth, SizingMargins.cyTopHeight, SizingMargins.cxRightWidth, ESourceHeight,\r\n TransparentColor\r\n ) and\r\n\r\n { G }\r\n TransparentBlt(\r\n DestDC,\r\n 0, EDestHeight + SizingMargins.cyTopHeight, SizingMargins.cxLeftWidth, SizingMargins.cyBottomHeight,\r\n SourceDC,\r\n 0, ESourceHeight + SizingMargins.cyTopHeight, SizingMargins.cxLeftWidth, SizingMargins.cyBottomHeight,\r\n TransparentColor\r\n ) and\r\n\r\n { H }\r\n TransparentBlt(\r\n DestDC,\r\n SizingMargins.cxLeftWidth, EDestHeight + SizingMargins.cyTopHeight, EDestWidth, SizingMargins.cyBottomHeight,\r\n SourceDC,\r\n SizingMargins.cxLeftWidth, ESourceHeight + SizingMargins.cyTopHeight, ESourceWidth, SizingMargins.cyBottomHeight,\r\n TransparentColor\r\n ) and\r\n\r\n { I }\r\n TransparentBlt(\r\n DestDC,\r\n EDestWidth + SizingMargins.cxLeftWidth, EDestHeight + SizingMargins.cyTopHeight,\r\n SizingMargins.cxRightWidth, SizingMargins.cyBottomHeight,\r\n SourceDC,\r\n ESourceWidth + SizingMargins.cxLeftWidth, ESourceHeight + SizingMargins.cyTopHeight,\r\n SizingMargins.cxRightWidth, SizingMargins.cyBottomHeight,\r\n TransparentColor\r\n );\r\n\r\n SetWindowOrgEx(SourceDC, LastOriginSource.X, LastOriginSource.Y, nil);\r\n SetWindowOrgEx(DestDC, LastOriginDest.X, LastOriginDest.Y, nil);\r\nend;\r\n\r\nfunction GetXPCaptionButtonBitmap(ABitmap: TBitmapAdapter; out BitmapCount: Integer): Boolean;\r\nvar\r\n Handle: THandle;\r\n ThemeFileNameW, BitmapFileNameW: array [0..MAX_PATH] of WideChar;\r\n Details: TThemedElementDetails;\r\n Margins: TMargins;\r\nbegin\r\n ThemeFileNameW[MAX_PATH] := #0;\r\n BitmapFileNameW[MAX_PATH] := #0;\r\n\r\n Result := UxTheme.GetCurrentThemeName(ThemeFileNameW, MAX_PATH, nil, 0, nil, 0) = S_OK;\r\n if not Result then\r\n Exit;\r\n\r\n Details := ThemeServices.GetElementDetails(twMinButtonNormal);\r\n with Details do\r\n Result := GetThemeFilename(ThemeServices.Theme[Element], Part, State,\r\n TMT_IMAGEFILE, BitmapFileNameW, MAX_PATH) = S_OK;\r\n if not Result then\r\n Exit;\r\n\r\n with Details do\r\n Result := GetThemeInt(ThemeServices.Theme[Element], Part, State,\r\n TMT_IMAGECOUNT, BitmapCount) = S_OK;\r\n if not Result then\r\n Exit;\r\n\r\n Result := BitmapCount > 0;\r\n if not Result then\r\n Exit;\r\n\r\n with Details do\r\n if GetThemeMargins(ThemeServices.Theme[Element], 0, Part, State,\r\n TMT_SIZINGMARGINS, nil, Margins) <> S_OK then\r\n FillChar(Margins, SizeOf(Margins), 0);\r\n ABitmap.Margins := Margins;\r\n\r\n Handle := SafeLoadLibrary(ThemeFileNameW, SEM_NOOPENFILEERRORBOX or SEM_FAILCRITICALERRORS);\r\n if Handle <> 0 then\r\n try\r\n ABitmap.Assign(nil); // fixes GDI resource leak\r\n ABitmap.LoadFromResourceName(Handle, TranslateBitmapFileName(BitmapFileNameW));\r\n { (rb) can't determine actual transparent color? }\r\n ABitmap.TransparentColor := clFuchsia;\r\n\r\n Result := (ABitmap.Width > 0) and (ABitmap.Height > 0);\r\n finally\r\n FreeLibrary(Handle);\r\n end;\r\nend;\r\n\r\n{$ENDIF JVCLThemesEnabled}\r\n\r\n//=== Global procedures ======================================================\r\n\r\nfunction AlphaBlend(hdcDest: HDC; nXOriginDest, nYOriginDest, nWidthDest,\r\n nHeightDest: Integer; hdcSrc: HDC; nXOriginSrc, nYOriginSrc, nWidthSrc,\r\n nHeightSrc: Integer; BlendFunction: BLENDFUNCTION): BOOL; stdcall;\r\nbegin\r\n if not GTriedLoadMsimg32Dll then\r\n LoadMsimg32Dll;\r\n Result := Assigned(_AlphaBlend) and\r\n _AlphaBlend(hdcDest, nXOriginDest, nYOriginDest, nWidthDest, nHeightDest, hdcSrc,\r\n nXOriginSrc, nYOriginSrc, nWidthSrc, nHeightSrc, BlendFunction);\r\nend;\r\n\r\nfunction TransparentBlt(hdcDest: HDC; nXOriginDest, nYOriginDest, nWidthDest, hHeightDest: Integer;\r\n hdcSrc: HDC; nXOriginSrc, nYOriginSrc, nWidthSrc, nHeightSrc: Integer;\r\n crTransparent: UINT): BOOL; stdcall;\r\nbegin\r\n if not GTriedLoadMsimg32Dll then\r\n LoadMsimg32Dll;\r\n Result := Assigned(_TransparentBlt) and\r\n _TransparentBlt(hdcDest, nXOriginDest, nYOriginDest, nWidthDest, hHeightDest, hdcSrc,\r\n nXOriginSrc, nYOriginSrc, nWidthSrc, nHeightSrc, crTransparent);\r\nend;\r\n\r\n{$IFDEF JVCLThemesEnabled}\r\n\r\n//=== { TAlphaBitmap } =======================================================\r\n\r\ndestructor TAlphaBitmap.Destroy;\r\nbegin\r\n FreeHandle;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TAlphaBitmap.Assign(Source: TPersistent);\r\nbegin\r\n // What to do here when Source is not nil???\r\n if not Assigned(Source) then\r\n FreeHandle\r\n else\r\n ;\r\nend;\r\n\r\nfunction TAlphaBitmap.CreateDIB(ADC: HDC; AWidth, AHeight: Integer): HBitmap;\r\nbegin\r\n with FBitmapInfo.bmiHeader do\r\n begin\r\n biSize := SizeOf(FBitmapInfo.bmiHeader);\r\n biWidth := AWidth;\r\n biHeight := AHeight;\r\n biPlanes := 1;\r\n biBitCount := 32;\r\n biCompression := BI_RGB;\r\n biSizeImage := AWidth * AHeight * 4;\r\n end;\r\n // Create the DIB\r\n Result := CreateDIBSection(ADC, FBitmapInfo, DIB_RGB_COLORS, FBitsMem, 0, 0);\r\nend;\r\n\r\nprocedure TAlphaBitmap.CreateHandle(AWidth, AHeight: Integer);\r\nvar\r\n H: HBitmap;\r\nbegin\r\n FreeHandle;\r\n\r\n H := CreateScreenCompatibleDC;\r\n FDIBHandle := CreateDIB(H, AWidth, AHeight);\r\n if FDIBHandle <> 0 then\r\n FOldBitmap := SelectObject(H, FDIBHandle)\r\n else\r\n FOldBitmap := 0;\r\n FHandle := H;\r\nend;\r\n\r\nprocedure TAlphaBitmap.Duplicate(Src: HBitmap);\r\nvar\r\n Bitmap: Windows.TBitmap;\r\nbegin\r\n GetObject(Src, SizeOf(Bitmap), @Bitmap);\r\n CreateHandle(Bitmap.bmWidth, Bitmap.bmHeight);\r\n\r\n DupBits(Src, FHandle, Point(Bitmap.bmWidth, Bitmap.bmHeight));\r\nend;\r\n\r\nprocedure TAlphaBitmap.FreeHandle;\r\nbegin\r\n if FHandle <> 0 then\r\n begin\r\n if FDIBHandle <> 0 then\r\n begin\r\n if FOldBitmap <> 0 then\r\n SelectObject(FHandle, FOldBitmap);\r\n DeleteObject(FDIBHandle);\r\n end;\r\n DeleteDC(FHandle);\r\n end;\r\nend;\r\n\r\nfunction TAlphaBitmap.GetHeight: Integer;\r\nbegin\r\n Result := FBitmapInfo.bmiHeader.biHeight;\r\nend;\r\n\r\nfunction TAlphaBitmap.GetWidth: Integer;\r\nbegin\r\n Result := FBitmapInfo.bmiHeader.biWidth;\r\nend;\r\n\r\nprocedure TAlphaBitmap.InitAlpha;\r\nvar\r\n Count: Integer;\r\nbegin\r\n Count := Width * Height;\r\n if BitCount < 32 then\r\n FHasAlphaChannel := False\r\n else\r\n begin\r\n FHasAlphaChannel := GetHasAlphaChannel(Data, Count);\r\n\r\n if HasAlphaChannel then\r\n PreMultiplyAlphaChannel(Data, Count);\r\n end;\r\nend;\r\n\r\nprocedure TAlphaBitmap.LoadFromResourceID(Instance: THandle; ResID: Integer);\r\nvar\r\n Stream: TCustomMemoryStream;\r\n BitmapInfoHeader: TBitmapInfoHeader;\r\n BitmapHandle: HBitmap;\r\nbegin\r\n Stream := TResourceStream.CreateFromID(Instance, ResID, RT_BITMAP);\r\n try\r\n Stream.Read(BitmapInfoHeader, SizeOf(TBitmapInfoHeader));\r\n FBitCount := BitmapInfoHeader.biBitCount;\r\n finally\r\n Stream.Free;\r\n end;\r\n\r\n if FBitCount = 32 then\r\n begin\r\n BitmapHandle := LoadImage(Instance, PChar(ResID), IMAGE_BITMAP, 0, 0, LR_CREATEDIBSECTION);\r\n if BitmapHandle = 0 then\r\n Exit;\r\n\r\n Duplicate(BitmapHandle);\r\n DeleteObject(BitmapHandle);\r\n\r\n InitAlpha;\r\n end;\r\nend;\r\n\r\nprocedure TAlphaBitmap.LoadFromResourceName(Instance: THandle; const ResName: string);\r\nvar\r\n Stream: TCustomMemoryStream;\r\n BitmapInfoHeader: TBitmapInfoHeader;\r\n BitmapHandle: HBitmap;\r\nbegin\r\n Stream := TResourceStream.Create(Instance, ResName, RT_BITMAP);\r\n try\r\n Stream.Read(BitmapInfoHeader, SizeOf(TBitmapInfoHeader));\r\n FBitCount := BitmapInfoHeader.biBitCount;\r\n finally\r\n Stream.Free;\r\n end;\r\n\r\n if FBitCount = 32 then\r\n begin\r\n BitmapHandle := LoadImage(Instance, PChar(ResName), IMAGE_BITMAP, 0, 0, LR_CREATEDIBSECTION);\r\n if BitmapHandle = 0 then\r\n Exit;\r\n\r\n Duplicate(BitmapHandle);\r\n DeleteObject(BitmapHandle);\r\n\r\n InitAlpha;\r\n end;\r\nend;\r\n\r\n//=== { TBitmapAdapter } =====================================================\r\n\r\nconstructor TBitmapAdapter.Create;\r\nbegin\r\n inherited Create;\r\n FTransparentColor := clFuchsia;\r\nend;\r\n\r\ndestructor TBitmapAdapter.Destroy;\r\nbegin\r\n FBitmap.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TBitmapAdapter.Assign(Source: TPersistent);\r\nbegin\r\n if FBitmap is TBitmap then\r\n (FBitmap as TBitmap).Assign(Source)\r\n else\r\n if FBitmap is TAlphaBitmap then\r\n (FBitmap as TAlphaBitmap).Assign(Source);\r\nend;\r\n\r\nprocedure TBitmapAdapter.Clear;\r\nbegin\r\n FreeAndNil(FBitmap);\r\nend;\r\n\r\nfunction TBitmapAdapter.Draw(ACanvas: TCanvas; const Rect: TRect;\r\n AMargins: PMargins): Boolean;\r\nbegin\r\n if (Rect.Right - Rect.Left = Width) and (Rect.Bottom - Rect.Top = Height) then\r\n Result := DrawFixedPart(ACanvas, Rect, 0, 0)\r\n else\r\n begin\r\n if AMargins = nil then\r\n AMargins := @FMargins;\r\n\r\n if FBitmap is TAlphaBitmap then\r\n with TAlphaBitmap(FBitmap) do\r\n Result := TransparentBltStretch(ACanvas.Handle, Rect, Handle,\r\n Bounds(0, 0, Width, Height), AMargins^, FTransparentColor)\r\n else\r\n if FBitmap is TBitmap then\r\n with TBitmap(FBitmap) do\r\n Result := TransparentBltStretch(ACanvas.Handle, Rect, Canvas.Handle,\r\n Bounds(0, 0, Width, Height), AMargins^, FTransparentColor)\r\n else\r\n Result := False;\r\n end;\r\nend;\r\n\r\nfunction TBitmapAdapter.DrawFixed(ACanvas: TCanvas; const X, Y: Integer): Boolean;\r\nbegin\r\n Result := DrawFixedPart(ACanvas, Bounds(X, Y, Width, Height), 0, 0);\r\nend;\r\n\r\nfunction TBitmapAdapter.DrawFixedPart(ACanvas: TCanvas;\r\n const DestRect: TRect; const SrcX, SrcY: Integer): Boolean;\r\nvar\r\n BlendFunction: TBlendFunction;\r\n W, H: Integer;\r\nbegin\r\n W := DestRect.Right - DestRect.Left;\r\n H := DestRect.Bottom - DestRect.Top;\r\n\r\n if FBitmap is TAlphaBitmap then\r\n begin\r\n with TAlphaBitmap(FBitmap) do\r\n begin\r\n BlendFunction.BlendOp := AC_SRC_OVER;\r\n BlendFunction.BlendFlags := 0;\r\n BlendFunction.SourceConstantAlpha := $FF;\r\n BlendFunction.AlphaFormat := AC_SRC_ALPHA;\r\n\r\n Result := AlphaBlend(ACanvas.Handle, DestRect.Left, DestRect.Top, W, H,\r\n Handle, SrcX, SrcY, W, H, BlendFunction);\r\n end;\r\n end\r\n else\r\n if FBitmap is TBitmap then\r\n with TBitmap(FBitmap) do\r\n Result := TransparentBlt(ACanvas.Handle, DestRect.Left, DestRect.Top, W, H,\r\n Canvas.Handle, SrcX, SrcY, W, H, Self.TransparentColor)\r\n else\r\n Result := False;\r\nend;\r\n\r\nfunction TBitmapAdapter.DrawPart(ACanvas: TCanvas; const SrcRect,\r\n DestRect: TRect; AMargins: PMargins): Boolean;\r\nbegin\r\n // Same width/height?\r\n if (SrcRect.Right - SrcRect.Left = DestRect.Right - DestRect.Left) and\r\n (SrcRect.Bottom - SrcRect.Top = DestRect.Bottom - DestRect.Top) then\r\n Result := DrawFixedPart(ACanvas, DestRect, SrcRect.Left, SrcRect.Top)\r\n else\r\n begin\r\n if AMargins = nil then\r\n AMargins := @FMargins;\r\n\r\n if FBitmap is TAlphaBitmap then\r\n with TAlphaBitmap(FBitmap) do\r\n Result := TransparentBltStretch(ACanvas.Handle, DestRect, Handle, SrcRect,\r\n AMargins^, Self.TransparentColor)\r\n else\r\n if FBitmap is TBitmap then\r\n with TBitmap(FBitmap) do\r\n Result := TransparentBltStretch(ACanvas.Handle, DestRect, Canvas.Handle, SrcRect,\r\n AMargins^, Self.TransparentColor)\r\n else\r\n Result := False;\r\n end;\r\nend;\r\n\r\nfunction TBitmapAdapter.GetHeight: Integer;\r\nbegin\r\n if FBitmap is TAlphaBitmap then\r\n Result := TAlphaBitmap(FBitmap).Height\r\n else\r\n if FBitmap is TBitmap then\r\n Result := TBitmap(FBitmap).Height\r\n else\r\n Result := 0;\r\nend;\r\n\r\nfunction TBitmapAdapter.GetIsValid: Boolean;\r\nbegin\r\n Result := Assigned(FBitmap);\r\nend;\r\n\r\nfunction TBitmapAdapter.GetWidth: Integer;\r\nbegin\r\n if FBitmap is TAlphaBitmap then\r\n Result := TAlphaBitmap(FBitmap).Width\r\n else\r\n if FBitmap is TBitmap then\r\n Result := TBitmap(FBitmap).Width\r\n else\r\n Result := 0;\r\nend;\r\n\r\nprocedure TBitmapAdapter.LoadFromResourceID(Instance: THandle; ResID: Integer);\r\nvar\r\n AlphaBitmap: TAlphaBitmap;\r\nbegin\r\n Clear;\r\n\r\n AlphaBitmap := TAlphaBitmap.Create;\r\n try\r\n AlphaBitmap.LoadFromResourceID(Instance, ResID);\r\n if AlphaBitmap.BitCount < 32 then\r\n begin\r\n FBitmap := TBitmap.Create;\r\n TBitmap(FBitmap).LoadFromResourceID(Instance, ResID);\r\n end\r\n else\r\n begin\r\n FBitmap := AlphaBitmap;\r\n AlphaBitmap := nil;\r\n end;\r\n finally\r\n AlphaBitmap.Free;\r\n end;\r\nend;\r\n\r\nprocedure TBitmapAdapter.LoadFromResourceName(Instance: THandle; const ResName: string);\r\nvar\r\n AlphaBitmap: TAlphaBitmap;\r\nbegin\r\n Clear;\r\n\r\n AlphaBitmap := TAlphaBitmap.Create;\r\n try\r\n AlphaBitmap.LoadFromResourceName(Instance, ResName);\r\n if AlphaBitmap.BitCount < 32 then\r\n begin\r\n FBitmap := TBitmap.Create;\r\n TBitmap(FBitmap).LoadFromResourceName(Instance, ResName);\r\n end\r\n else\r\n begin\r\n FBitmap := AlphaBitmap;\r\n AlphaBitmap := nil;\r\n end;\r\n finally\r\n AlphaBitmap.Free;\r\n end;\r\nend;\r\n\r\n//=== { TGlobalXPData } ======================================================\r\n\r\nconstructor TGlobalXPData.Create;\r\nbegin\r\n inherited Create;\r\n Update;\r\nend;\r\n\r\ndestructor TGlobalXPData.Destroy;\r\nbegin\r\n FCaptionButtons.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TGlobalXPData.AddClient;\r\nbegin\r\n Inc(FClientCount);\r\nend;\r\n\r\nfunction TGlobalXPData.Draw(ACanvas: TCanvas; State: Integer;\r\n const DrawRect: TRect): Boolean;\r\nvar\r\n SrcRect: TRect;\r\nbegin\r\n Result := FBitmapValid;\r\n if not Result then\r\n Exit;\r\n\r\n { State is 1-based }\r\n if (State >= FCaptionButtonCount) and (State > 4) then\r\n State := ((State - 1) mod 4) + 1;\r\n if State > FCaptionButtonCount then\r\n State := FCaptionButtonCount;\r\n\r\n SrcRect := Bounds(0, FCaptionButtonHeight * (State - 1),\r\n FCaptionButtons.Width, FCaptionButtonHeight);\r\n\r\n Result := FCaptionButtons.DrawPart(ACanvas, SrcRect, DrawRect, nil);\r\nend;\r\n\r\nprocedure TGlobalXPData.DrawSimple(ACanvas: TCanvas; State: Integer;\r\n const DrawRect: TRect);\r\nconst\r\n // Normal, Hot, Pushed, Disabled,\r\n cCaptionButton: array [0..3] of TThemedWindow =\r\n (twMinButtonNormal, twMinButtonHot, twMinButtonPushed, twMinButtonDisabled);\r\n cNormalButton: array [0..3] of TThemedButton =\r\n (tbPushButtonNormal, tbPushButtonHot, tbPushButtonPressed, tbPushButtonDisabled);\r\nvar\r\n Details: TThemedElementDetails;\r\n DrawRgn: HRGN;\r\nbegin\r\n { Draw the button in 2 pieces, draw the edge of a caption button, and the\r\n inner of a normal button, because drawing a normal button looks ugly }\r\n\r\n // State = 1..8 -> State = 0..3\r\n State := (State - 1) mod 4;\r\n\r\n { 1a. Draw the outer bit as a caption button }\r\n Details := ThemeServices.GetElementDetails(cCaptionButton[State]);\r\n ThemeServices.DrawElement(ACanvas.Handle, Details, DrawRect);\r\n\r\n { 1b. Draw the inner bit as a normal button }\r\n DrawRgn := CreateRectRgn(DrawRect.Left + 1, DrawRect.Top + 1, DrawRect.Right - 1, DrawRect.Bottom - 1);\r\n try\r\n Details := ThemeServices.GetElementDetails(cNormalButton[State]);\r\n SelectClipRgn(ACanvas.Handle, DrawRgn);\r\n ThemeServices.DrawElement(ACanvas.Handle, Details, DrawRect);\r\n SelectClipRgn(ACanvas.Handle, 0);\r\n finally\r\n DeleteObject(DrawRgn);\r\n end;\r\nend;\r\n\r\nprocedure TGlobalXPData.RemoveClient;\r\nbegin\r\n Dec(FClientCount);\r\n if FClientCount = 0 then\r\n begin\r\n if Self = GGlobalXPData then\r\n GGlobalXPData := nil;\r\n Self.Free;\r\n end;\r\nend;\r\n\r\nprocedure TGlobalXPData.Update;\r\nbegin\r\n FIsThemed := StyleServices.Available and IsThemeActive and IsAppThemed;\r\n if not FIsThemed then\r\n Exit;\r\n\r\n if FCaptionButtons = nil then\r\n FCaptionButtons := TBitmapAdapter.Create;\r\n\r\n FBitmapValid := GetXPCaptionButtonBitmap(FCaptionButtons, FCaptionButtonCount);\r\n if FBitmapValid then\r\n FCaptionButtonHeight := FCaptionButtons.Height div FCaptionButtonCount\r\n else\r\n FreeAndNil(FCaptionButtons);\r\nend;\r\n\r\n{$ENDIF JVCLThemesEnabled}\r\n\r\n//=== { TJvCaptionButton } ===================================================\r\n\r\nconstructor TJvCaptionButton.Create(AOwner: TComponent);\r\nbegin\r\n if not (AOwner is TCustomForm) then\r\n raise EJVCLException.CreateRes(@RsEOwnerMustBeTCustomForm);\r\n\r\n inherited Create(AOwner);\r\n\r\n { Defaults }\r\n FAlignment := taLeftJustify;\r\n FHeight := 0;\r\n FLeft := 0;\r\n FTop := 0;\r\n FWidth := 0;\r\n FEnabled := True;\r\n FImageIndex := -1;\r\n FLayout := cbImageLeft;\r\n FMargin := -1;\r\n FPosition := 0;\r\n FSpacing := 4;\r\n FStandard := tsbNone;\r\n FToggle := False;\r\n FVisible := True;\r\n\r\n FNeedRecalculate := True;\r\n FCaption := '';\r\n FDown := False;\r\n FToolTipHandle := 0;\r\n\r\n FFont := TFont.Create;\r\n FBuffer := TBitmap.Create;\r\n\r\n FImageChangeLink := TChangeLink.Create;\r\n FImageChangeLink.OnChange := ImageListChange;\r\n FParentShowHint := True;\r\n\r\n FCurrentWindowState := TCustomForm(AOwner).WindowState;\r\n\r\n {$IFDEF JVCLThemesEnabled}\r\n GlobalXPData.AddClient;\r\n {$ENDIF JVCLThemesEnabled}\r\n\r\n {$IFDEF JVCLThemesEnabled}\r\n if IsVistaOrNewer and IsThemed then // Windows Vista\r\n FForceRedraw := True;\r\n {$ENDIF JVCLThemesEnabled}\r\n\r\n Hook;\r\nend;\r\n\r\ndestructor TJvCaptionButton.Destroy;\r\nbegin\r\n DestroyToolTip;\r\n\r\n UnHook;\r\n Redraw(rkTotalCaptionBar);\r\n\r\n FFont.Free;\r\n FBuffer.Free;\r\n\r\n FreeAndNil(FActionLink);\r\n FreeAndNil(FImageChangeLink);\r\n\r\n {$IFDEF JVCLThemesEnabled}\r\n GlobalXPData.RemoveClient;\r\n {$ENDIF JVCLThemesEnabled}\r\n\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvCaptionButton.ActionChange(Sender: TObject;\r\n CheckDefaults: Boolean);\r\nbegin\r\n if Sender is TCustomAction then\r\n with TCustomAction(Sender) do\r\n begin\r\n if not CheckDefaults or not Assigned(Self.Images) then\r\n Self.Images := ActionList.Images;\r\n if not CheckDefaults or (Self.Caption = '') then\r\n Self.Caption := Caption;\r\n if not CheckDefaults or Self.Enabled then\r\n Self.Enabled := Enabled;\r\n if not CheckDefaults or (Self.Hint = '') then\r\n Self.Hint := Hint;\r\n if not CheckDefaults or (Self.ImageIndex = -1) then\r\n Self.ImageIndex := ImageIndex;\r\n if not CheckDefaults or Self.Visible then\r\n Self.Visible := Visible;\r\n if not CheckDefaults or not Assigned(Self.OnClick) then\r\n Self.OnClick := OnExecute;\r\n end;\r\nend;\r\n\r\nprocedure TJvCaptionButton.Assign(Source: TPersistent);\r\nbegin\r\n if Source is TJvCaptionButton then\r\n begin\r\n Alignment := TJvCaptionButton(Source).Alignment;\r\n ButtonHeight := TJvCaptionButton(Source).ButtonHeight;\r\n ButtonLeft := TJvCaptionButton(Source).ButtonLeft;\r\n ButtonTop := TJvCaptionButton(Source).ButtonTop;\r\n ButtonWidth := TJvCaptionButton(Source).ButtonWidth;\r\n Caption := TJvCaptionButton(Source).Caption;\r\n ShowHint := TJvCaptionButton(Source).ShowHint;\r\n ParentShowHint := TJvCaptionButton(Source).ParentShowHint;\r\n Enabled := TJvCaptionButton(Source).Enabled;\r\n Font := TJvCaptionButton(Source).Font;\r\n Hint := TJvCaptionButton(Source).Hint;\r\n ImageIndex := TJvCaptionButton(Source).ImageIndex;\r\n Images := TJvCaptionButton(Source).Images;\r\n Layout := TJvCaptionButton(Source).Layout;\r\n Margin := TJvCaptionButton(Source).Margin;\r\n Position := TJvCaptionButton(Source).Position;\r\n Spacing := TJvCaptionButton(Source).Spacing;\r\n Standard := TJvCaptionButton(Source).Standard;\r\n // set toggle before down\r\n Toggle := TJvCaptionButton(Source).Toggle;\r\n Down := TJvCaptionButton(Source).Down;\r\n Visible := TJvCaptionButton(Source).Visible;\r\n end\r\n else\r\n inherited Assign(Source);\r\nend;\r\n\r\nprocedure TJvCaptionButton.CalcButtonParts(ACanvas: TCanvas;\r\n ButtonRect: TRect; var RectText, RectImage: TRect);\r\n// copied from TJvCustomImageButton\r\nconst\r\n CDefaultMargin = 4;\r\nvar\r\n BlockWidth, ButtonWidth, ButtonHeight, BlockMargin, InternalSpacing: Integer;\r\n LMargin: Integer;\r\n OldFont: TFont;\r\nbegin\r\n SetRect(RectText, 0, 0, 0, 0);\r\n OldFont := ACanvas.Font;\r\n ACanvas.Font := Font;\r\n DrawText(ACanvas, Caption, -1, RectText, DT_CALCRECT or Alignments[FAlignment]);\r\n ACanvas.Font := OldFont;\r\n if IsImageVisible then\r\n begin\r\n with Images do\r\n SetRect(RectImage, 0, 0, Width - 1, Height - 1);\r\n InternalSpacing := Spacing;\r\n end\r\n else\r\n begin\r\n SetRect(RectImage, 0, 0, 0, 0);\r\n InternalSpacing := 0;\r\n end;\r\n BlockWidth := RectImage.Right + InternalSpacing + RectText.Right;\r\n ButtonWidth := ButtonRect.Right - ButtonRect.Left;\r\n if Margin = -1 then\r\n LMargin := CDefaultMargin\r\n else\r\n LMargin := Margin;\r\n\r\n case Alignment of\r\n taLeftJustify:\r\n BlockMargin := LMargin;\r\n taRightJustify:\r\n BlockMargin := ButtonWidth - BlockWidth - LMargin - 1;\r\n else {taCenter}\r\n BlockMargin := (ButtonWidth - BlockWidth) div 2\r\n end;\r\n case Layout of\r\n cbImageLeft:\r\n begin\r\n OffsetRect(RectImage, BlockMargin, 0);\r\n OffsetRect(RectText, RectImage.Right + InternalSpacing, 0);\r\n end;\r\n cbImageRight:\r\n begin\r\n OffsetRect(RectText, BlockMargin, 0);\r\n OffsetRect(RectImage, RectText.Right + InternalSpacing, 0);\r\n end;\r\n end;\r\n ButtonHeight := ButtonRect.Bottom - ButtonRect.Top;\r\n OffsetRect(RectImage, ButtonRect.Left, (ButtonHeight - RectImage.Bottom) div 2 + ButtonRect.Top);\r\n OffsetRect(RectText, ButtonRect.Left, (ButtonHeight - RectText.Bottom) div 2 + ButtonRect.Top);\r\nend;\r\n\r\nprocedure TJvCaptionButton.CalcDefaultButtonRect(Wnd: THandle);\r\nconst\r\n CSpaceBetweenButtons = 2;\r\nvar\r\n Style: DWORD;\r\n ExStyle: DWORD;\r\n FrameSize: TSize;\r\n Placement: WindowPlacement;\r\nbegin\r\n if Wnd = 0 then\r\n Exit;\r\n\r\n { 0. Init some local vars }\r\n FNeedRecalculate := False;\r\n Style := GetWindowLong(Wnd, GWL_STYLE);\r\n FHasCaption := Style and WS_CAPTION = WS_CAPTION;\r\n if not FHasCaption then\r\n Exit;\r\n\r\n Placement.length := SizeOf(WindowPlacement);\r\n GetWindowPlacement(Wnd, @Placement);\r\n ExStyle := GetWindowLong(Wnd, GWL_EXSTYLE);\r\n FHasSmallCaption := ExStyle and WS_EX_TOOLWINDOW = WS_EX_TOOLWINDOW;\r\n {$IFDEF JVCLThemesEnabled}\r\n if not IsThemed and (Placement.showCmd = SW_SHOWMINIMIZED) then\r\n FHasSmallCaption := False;\r\n FCaptionActive := (GetActiveWindow = Wnd) and IsForegroundTask;\r\n {$ELSE}\r\n if Placement.showCmd = SW_SHOWMINIMIZED then\r\n FHasSmallCaption := False;\r\n {$ENDIF JVCLThemesEnabled}\r\n\r\n if (Style and WS_THICKFRAME = WS_THICKFRAME) and (Placement.showCmd <> SW_SHOWMINIMIZED) then\r\n begin\r\n FrameSize.cx := GetSystemMetrics(SM_CXSIZEFRAME);\r\n FrameSize.cy := GetSystemMetrics(SM_CYSIZEFRAME);\r\n end\r\n else\r\n begin\r\n FrameSize.cx := GetSystemMetrics(SM_CXFIXEDFRAME);\r\n FrameSize.cy := GetSystemMetrics(SM_CYFIXEDFRAME);\r\n end;\r\n\r\n { 1. Calc FDefaultButtonTop }\r\n FDefaultButtonTop := FrameSize.cy + 2;\r\n\r\n { 2. Calc FDefaultButtonHeight }\r\n if FHasSmallCaption then\r\n FCaptionHeight := GetSystemMetrics(SM_CYSMCAPTION)\r\n else\r\n FCaptionHeight := GetSystemMetrics(SM_CYCAPTION);\r\n FDefaultButtonHeight := FCaptionHeight - 5;\r\n\r\n { 3. Calc FDefaultButtonWidth }\r\n {$IFDEF JVCLThemesEnabled}\r\n if IsThemed then\r\n begin\r\n if IsVistaOrNewer then\r\n begin\r\n if FHasSmallCaption then\r\n begin\r\n FDefaultButtonWidth := GetSystemMetrics(SM_CXSMSIZE) - 4\r\n end\r\n else\r\n begin\r\n // This is not exactly correct but WM_GETTITLEBARINFOEX returns the coordinates\r\n // for the \"Glass\" style. But because we paint into the NC area, out window uses\r\n // the \"Basic\" style.\r\n FDefaultButtonWidth := GetSystemMetrics(SM_CXSIZE) - 4;\r\n end;\r\n\r\n // Adjust position\r\n FDefaultButtonTop := FDefaultButtonTop - 2;\r\n FDefaultButtonHeight := FCaptionHeight - 3;\r\n end\r\n else\r\n FDefaultButtonWidth := FDefaultButtonHeight;\r\n end\r\n else\r\n {$ENDIF JVCLThemesEnabled}\r\n if FHasSmallCaption then\r\n FDefaultButtonWidth := GetSystemMetrics(SM_CXSMSIZE) - CSpaceBetweenButtons\r\n else\r\n FDefaultButtonWidth := GetSystemMetrics(SM_CXSIZE) - CSpaceBetweenButtons;\r\n\r\n { 4. Calc FDefaultButtonLeft }\r\n FDefaultButtonLeft := FrameSize.cx;\r\n Inc(FDefaultButtonLeft, FDefaultButtonWidth + CSpaceBetweenButtons);\r\n\r\n if Style and WS_SYSMENU = WS_SYSMENU then\r\n begin\r\n { 4a. Avoid close button }\r\n Inc(FDefaultButtonLeft, FDefaultButtonWidth + CSpaceBetweenButtons);\r\n\r\n if not FHasSmallCaption then\r\n begin\r\n if (Style and WS_MAXIMIZEBOX = WS_MAXIMIZEBOX) or\r\n (Style and WS_MINIMIZEBOX = WS_MINIMIZEBOX) then\r\n begin\r\n {$IFDEF JVCLThemesEnabled}\r\n if IsThemed then\r\n { 4b. If it have Max or Min button, both are visible. When themed\r\n the CONTEXTHELP button is then never visible }\r\n Inc(FDefaultButtonLeft, 2 * (FDefaultButtonWidth + CSpaceBetweenButtons))\r\n else\r\n {$ENDIF JVCLThemesEnabled}\r\n begin\r\n { 4b. If it have Max or Min button, both are visible. }\r\n Inc(FDefaultButtonLeft, 2 * FDefaultButtonWidth + CSpaceBetweenButtons);\r\n\r\n { 4c. If it have CONTEXTHELP button, avoid it. }\r\n if ((Style and WS_MAXIMIZEBOX = 0) or (Style and WS_MINIMIZEBOX = 0)) and\r\n (ExStyle and WS_EX_CONTEXTHELP = WS_EX_CONTEXTHELP) then\r\n Inc(FDefaultButtonLeft, FDefaultButtonWidth + 2 * CSpaceBetweenButtons);\r\n end;\r\n end\r\n else\r\n { 4c. If it have CONTEXTHELP button, avoid it. }\r\n if ExStyle and WS_EX_CONTEXTHELP = WS_EX_CONTEXTHELP then\r\n Inc(FDefaultButtonLeft, FDefaultButtonWidth + CSpaceBetweenButtons);\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvCaptionButton.Click;\r\nbegin\r\n if csDesigning in ComponentState then\r\n DesignerSelectComponent(Self)\r\n else\r\n if Enabled then\r\n begin\r\n { Call OnClick if assigned and not equal to associated action's OnExecute.\r\n If associated action's OnExecute assigned then call it, otherwise, call\r\n OnClick. }\r\n if Assigned(FOnClick) and (Action <> nil) and (@FOnClick <> @Action.OnExecute) then\r\n FOnClick(Self)\r\n else\r\n if {not (csDesigning in ComponentState) and} Assigned(ActionLink) then\r\n FActionLink.Execute(Self)\r\n else\r\n if Assigned(FOnClick) then\r\n FOnClick(Self);\r\n end;\r\nend;\r\n\r\nprocedure TJvCaptionButton.CreateToolTip(Wnd: THandle);\r\nvar\r\n ToolInfo: TToolInfo;\r\nbegin\r\n if csDesigning in ComponentState then\r\n Exit;\r\n\r\n DestroyToolTip;\r\n\r\n if Wnd = 0 then\r\n Exit;\r\n\r\n FToolTipHandle := CreateWindowEx(0, TOOLTIPS_CLASS, nil, TTS_ALWAYSTIP,\r\n Integer(CW_USEDEFAULT), Integer(CW_USEDEFAULT),\r\n Integer(CW_USEDEFAULT), Integer(CW_USEDEFAULT),\r\n ParentForm.Handle, // Thus automatically destroyed if ParentForm handle is destroyed.\r\n 0, HInstance, nil);\r\n\r\n if FToolTipHandle = 0 then\r\n Exit;\r\n\r\n // initialize tooltip info\r\n ToolInfo.cbSize := SizeOf(TToolInfo);\r\n ToolInfo.uFlags := TTF_IDISHWND; { Thus ignores rect param }\r\n ToolInfo.hwnd := Wnd;\r\n ToolInfo.uId := Wnd;\r\n ToolInfo.lpszText := LPSTR_TEXTCALLBACK;\r\n\r\n // register button with tooltip\r\n SendMessage(FToolTipHandle, TTM_ADDTOOL, 0, LPARAM(@ToolInfo));\r\nend;\r\n\r\nprocedure TJvCaptionButton.DestroyToolTip;\r\nbegin\r\n if FToolTipHandle <> 0 then\r\n begin\r\n DestroyWindow(FToolTipHandle);\r\n FToolTipHandle := 0;\r\n end;\r\nend;\r\n\r\nprocedure TJvCaptionButton.DoActionChange(Sender: TObject);\r\nbegin\r\n if Sender = Action then\r\n ActionChange(Sender, False);\r\nend;\r\n\r\nprocedure TJvCaptionButton.DrawButton(DC: HDC);\r\nvar\r\n Canvas: TControlCanvas;\r\nbegin\r\n if not Visible or not FHasCaption or (csDestroying in ComponentState) then\r\n Exit;\r\n\r\n Canvas := TControlCanvas.Create;\r\n try\r\n Canvas.Handle := DC;\r\n\r\n UpdateButtonRect(ParentFormHandle);\r\n\r\n FBuffer.Width := FButtonRect.Right - FButtonRect.Left;\r\n FBuffer.Height := FButtonRect.Bottom - FButtonRect.Top;\r\n\r\n {$IFDEF JVCLThemesEnabled}\r\n DrawButtonBackground(FBuffer.Canvas);\r\n {$ENDIF JVCLThemesEnabled}\r\n\r\n { We do a buffered drawing, otherwise you get flickering on XP, and you\r\n have to hassle with the clipping rects. }\r\n if FStandard <> tsbNone then\r\n DrawStandardButton(FBuffer.Canvas)\r\n else\r\n DrawNonStandardButton(FBuffer.Canvas);\r\n\r\n Canvas.Draw(FButtonRect.Left, FButtonRect.Top, FBuffer);\r\n finally\r\n Canvas.Handle := 0;\r\n Canvas.Free;\r\n end;\r\nend;\r\n\r\n{$IFDEF JVCLThemesEnabled}\r\nprocedure TJvCaptionButton.DrawButtonBackground(ACanvas: TCanvas);\r\nconst\r\n CCaption: array [Boolean, Boolean] of TThemedWindow =\r\n (\r\n (twCaptionInactive, twCaptionActive),\r\n (twSmallCaptionInactive, twSmallCaptionActive)\r\n );\r\nvar\r\n Details: TThemedElementDetails;\r\n ClipRect: TRect;\r\n CaptionRect: TRect;\r\nbegin\r\n if not IsThemed or (csDestroying in ComponentState) then\r\n Exit;\r\n\r\n { We basically draw the background to display 4 pixels - the corners of the\r\n rect - correct . Don't know a better way to do this. }\r\n\r\n { Determine the rect of the caption }\r\n GetWindowRect(ParentFormHandle, CaptionRect);\r\n OffsetRect(CaptionRect, -CaptionRect.Left, -CaptionRect.Top);\r\n CaptionRect.Bottom := FCaptionHeight + 4;\r\n { Offset it so the place where the button is, is at (0, 0) }\r\n OffsetRect(CaptionRect, -FButtonRect.Left, -FButtonRect.Top);\r\n ClipRect := Rect(0, 0, FButtonRect.Right - FButtonRect.Left, FButtonRect.Bottom - FButtonRect.Top);\r\n\r\n Details := ThemeServices.GetElementDetails(CCaption[FHasSmallCaption, FCaptionActive]);\r\n ThemeServices.DrawElement(ACanvas.Handle, Details, CaptionRect, @ClipRect);\r\nend;\r\n{$ENDIF JVCLThemesEnabled}\r\n\r\nprocedure TJvCaptionButton.DrawButtonImage(ACanvas: TCanvas; ImageBounds: TRect);\r\nbegin\r\n if csDestroying in ComponentState then\r\n Exit;\r\n if IsImageVisible then\r\n Images.Draw(ACanvas, ImageBounds.Left, ImageBounds.Top, ImageIndex, Enabled);\r\nend;\r\n\r\nprocedure TJvCaptionButton.DrawButtonText(ACanvas: TCanvas; TextBounds: TRect);\r\nvar\r\n Flags: DWORD;\r\n OldFont: TFont;\r\nbegin\r\n Flags := DT_VCENTER or Alignments[FAlignment];\r\n with ACanvas do\r\n begin\r\n Brush.Style := bsClear;\r\n if not Enabled then\r\n begin\r\n OffsetRect(TextBounds, 1, 1);\r\n OldFont := Font;\r\n Font := Self.Font;\r\n Font.Color := clBtnHighlight;\r\n DrawText(ACanvas, Caption, Length(Caption), TextBounds, Flags);\r\n OffsetRect(TextBounds, -1, -1);\r\n Font.Color := clBtnShadow;\r\n DrawText(ACanvas, Caption, Length(Caption), TextBounds, Flags);\r\n Font := OldFont;\r\n end\r\n else\r\n begin\r\n OldFont := Font;\r\n Font := Self.Font;\r\n DrawText(ACanvas, Caption, Length(Caption), TextBounds, Flags);\r\n Font := OldFont;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvCaptionButton.DrawNonStandardButton(ACanvas: TCanvas);\r\n{$IFDEF JVCLThemesEnabled}\r\nconst\r\n cState_Normal = 1;\r\n cState_Hot = 2;\r\n cState_Pushed = 3;\r\n cState_Disabled = 4;\r\n{$ENDIF JVCLThemesEnabled}\r\nvar\r\n DrawRect: TRect;\r\n RectText, RectImage: TRect;\r\n {$IFDEF JVCLThemesEnabled}\r\n State: Integer;\r\n DrawRgn: HRGN;\r\n {$ENDIF JVCLThemesEnabled}\r\nbegin\r\n if csDestroying in ComponentState then\r\n Exit;\r\n DrawRect := Rect(0, 0, FButtonRect.Right - FButtonRect.Left, FButtonRect.Bottom - FButtonRect.Top);\r\n\r\n {$IFDEF JVCLThemesEnabled}\r\n // Satisfy the compiler\r\n DrawRgn := 0;\r\n\r\n { 1. Draw the button }\r\n if IsThemed then\r\n begin\r\n if not Enabled then\r\n State := 4\r\n else\r\n if FDown then\r\n State := 3\r\n else\r\n if FMouseInControl then\r\n State := 2\r\n else\r\n State := 1;\r\n\r\n { Special state for buttons drawn on a not active caption }\r\n if not FCaptionActive then\r\n Inc(State, 4);\r\n\r\n if ForceDrawSimple or not GlobalXPData.Draw(ACanvas, State, DrawRect) then\r\n GlobalXPData.DrawSimple(ACanvas, State, DrawRect)\r\n end\r\n else\r\n {$ENDIF JVCLThemesEnabled}\r\n DrawButtonFace(ACanvas, DrawRect, 1, bsAutoDetect, False, FDown, False);\r\n\r\n { 2. Draw the text & picture }\r\n {$IFDEF JVCLThemesEnabled}\r\n if IsThemed then\r\n begin\r\n { 2a. If themed, only draw in the inner bit of the button using a clip region }\r\n DrawRgn := CreateRectRgn(DrawRect.Left + 2, DrawRect.Top + 2, DrawRect.Right - 2, DrawRect.Bottom - 2);\r\n\r\n SelectClipRgn(ACanvas.Handle, DrawRgn);\r\n end;\r\n {$ENDIF JVCLThemesEnabled}\r\n\r\n if FDown then\r\n begin\r\n {$IFDEF JVCLThemesEnabled}\r\n if IsThemed then\r\n OffsetRect(DrawRect, 1, 0)\r\n else\r\n {$ENDIF JVCLThemesEnabled}\r\n OffsetRect(DrawRect, 1, 1);\r\n end;\r\n { 2b. Calc position and Draw the picture & text }\r\n CalcButtonParts(ACanvas, DrawRect, RectText, RectImage);\r\n DrawButtonText(ACanvas, RectText);\r\n DrawButtonImage(ACanvas, RectImage);\r\n { 2c. Clean up }\r\n {$IFDEF JVCLThemesEnabled}\r\n if IsThemed then\r\n begin\r\n SelectClipRgn(ACanvas.Handle, 0);\r\n DeleteObject(DrawRgn);\r\n end;\r\n {$ENDIF JVCLThemesEnabled}\r\nend;\r\n\r\nprocedure TJvCaptionButton.DrawStandardButton(ACanvas: TCanvas);\r\nconst\r\n {$IFDEF JVCLThemesEnabled}\r\n CElements: array [TJvStandardButton] of TThemedWindow =\r\n (twWindowDontCare, twCloseButtonNormal, twHelpButtonNormal, twMaxButtonNormal,\r\n twMinButtonNormal, twRestoreButtonNormal, twMinButtonNormal);\r\n {$ENDIF JVCLThemesEnabled}\r\n CDrawFlags: array [TJvStandardButton] of Word =\r\n (0, DFCS_CAPTIONCLOSE, DFCS_CAPTIONHELP, DFCS_CAPTIONMAX, DFCS_CAPTIONMIN,\r\n DFCS_CAPTIONRESTORE, 0);\r\n CDown: array [Boolean] of Word = (0, DFCS_PUSHED);\r\n CEnabled: array [Boolean] of Word = (DFCS_INACTIVE, 0);\r\nvar\r\n DrawRect: TRect;\r\n {$IFDEF JVCLThemesEnabled}\r\n Details: TThemedElementDetails;\r\n CaptionButton: TThemedWindow;\r\n {$ENDIF JVCLThemesEnabled}\r\nbegin\r\n if csDestroying in ComponentState then\r\n Exit;\r\n DrawRect := Rect(0, 0, FButtonRect.Right - FButtonRect.Left, FButtonRect.Bottom - FButtonRect.Top);\r\n\r\n {$IFDEF JVCLThemesEnabled}\r\n if IsThemed then\r\n begin\r\n CaptionButton := CElements[FStandard];\r\n { Note : There is only a small close button (??) }\r\n if FHasSmallCaption and (FStandard = tsbClose) then\r\n CaptionButton := twSmallCloseButtonNormal;\r\n\r\n if not Enabled then\r\n Inc(CaptionButton, 3)\r\n else\r\n if FDown then\r\n { If Down and inactive, draw inactive border }\r\n Inc(CaptionButton, 2)\r\n else\r\n if FMouseInControl then\r\n Inc(CaptionButton);\r\n\r\n Details := ThemeServices.GetElementDetails(CaptionButton);\r\n { Special state for buttons drawn on a not active caption }\r\n if not FCaptionActive and (Details.State = 1) then\r\n Details.State := 5;\r\n ThemeServices.DrawElement(ACanvas.Handle, Details, DrawRect)\r\n end\r\n else\r\n {$ENDIF JVCLThemesEnabled}\r\n if Standard = tsbMinimizeToTray then\r\n begin\r\n DrawButtonFace(ACanvas, DrawRect, 1, bsAutoDetect, False, FDown, False);\r\n if Enabled then\r\n ACanvas.Brush.Color := clWindowText\r\n else\r\n begin\r\n ACanvas.Brush.Color := clBtnHighlight;\r\n ACanvas.FillRect(Rect(DrawRect.Right - 6, DrawRect.Bottom - 4, DrawRect.Right - 3, DrawRect.Bottom - 2));\r\n ACanvas.Brush.Color := clBtnShadow;\r\n end;\r\n ACanvas.FillRect(Rect(DrawRect.Right - 7, DrawRect.Bottom - 5, DrawRect.Right - 4, DrawRect.Bottom - 3));\r\n end\r\n else\r\n DrawFrameControl(ACanvas.Handle, DrawRect, DFC_CAPTION, {DFCS_ADJUSTRECT or}\r\n CDrawFlags[Standard] or CDown[Down] or CEnabled[Enabled]);\r\nend;\r\n\r\nprocedure TJvCaptionButton.ForwardToToolTip(Msg: TMessage);\r\nvar\r\n ForwardMsg: TMsg;\r\nbegin\r\n if FToolTipHandle = 0 then\r\n Exit;\r\n\r\n // forward to tool tip\r\n ForwardMsg.lParam := Msg.LParam;\r\n ForwardMsg.wParam := Msg.WParam;\r\n ForwardMsg.message := Msg.Msg;\r\n ForwardMsg.hwnd := ParentFormHandle;\r\n SendMessage(FToolTipHandle, TTM_RELAYEVENT, 0, LPARAM(@ForwardMsg));\r\nend;\r\n\r\nfunction TJvCaptionButton.GetAction: TBasicAction;\r\nbegin\r\n if FActionLink <> nil then\r\n Result := FActionLink.Action\r\n else\r\n Result := nil;\r\nend;\r\n\r\nfunction TJvCaptionButton.GetActionLinkClass: TJvCaptionButtonActionLinkClass;\r\nbegin\r\n Result := TJvCaptionButtonActionLink;\r\nend;\r\n\r\nfunction TJvCaptionButton.GetIsImageVisible: Boolean;\r\nbegin\r\n Result := Assigned(Images) and (ImageIndex > -1) and (ImageIndex < Images.Count);\r\nend;\r\n\r\n{$IFDEF JVCLThemesEnabled}\r\nfunction TJvCaptionButton.GetIsThemed: Boolean;\r\nbegin\r\n Result := GlobalXPData.IsThemed;\r\nend;\r\n{$ENDIF JVCLThemesEnabled}\r\n\r\nfunction TJvCaptionButton.GetParentForm: TCustomForm;\r\nbegin\r\n if Owner is TControl then\r\n Result := Forms.GetParentForm(TControl(Owner))\r\n else\r\n Result := nil;\r\nend;\r\n\r\nfunction TJvCaptionButton.GetParentFormHandle: THandle;\r\nvar\r\n P: TCustomForm;\r\nbegin\r\n P := GetParentForm;\r\n if Assigned(P) and P.HandleAllocated then\r\n Result := P.Handle\r\n else\r\n Result := 0;\r\nend;\r\n\r\nfunction TJvCaptionButton.HandleButtonDown(var Msg: TWMNCHitMessage): Boolean;\r\nbegin\r\n Result := Visible and Enabled and (Msg.HitTest = htCaptionButton) and\r\n MouseOnButton(Msg.XCursor, Msg.YCursor, False);\r\n\r\n if Result then\r\n begin\r\n FMouseButtonDown := True;\r\n if Toggle then\r\n FDown := not FDown\r\n else\r\n FDown := True;\r\n with TWMMouse(Msg) do\r\n MouseDown(mbLeft, KeysToShiftState(Keys), XPos, YPos);\r\n {if not Toggle then}\r\n SetCapture(ParentFormHandle);\r\n Redraw(rkIndirect);\r\n\r\n { Note: If Toggle = False -> click event is fired in HandleButtonUp }\r\n if Toggle then\r\n Click;\r\n end\r\n else\r\n if FDown and not Toggle then\r\n begin\r\n FMouseButtonDown := False;\r\n FDown := False;\r\n Redraw(rkIndirect);\r\n end;\r\nend;\r\n\r\nfunction TJvCaptionButton.HandleButtonUp(var Msg: TWMNCHitMessage): Boolean;\r\nvar\r\n DoClick: Boolean;\r\n P: TPoint;\r\nbegin\r\n Result := False;\r\n\r\n if not FMouseButtonDown then\r\n Exit;\r\n\r\n Result := FDown and MouseOnButton(Msg.XCursor, Msg.YCursor, Msg.Msg = WM_LBUTTONUP);\r\n { Note: If Toggle = True -> click event is fired in HandleButtonDown }\r\n DoClick := Result and not Toggle;\r\n\r\n FMouseButtonDown := False;\r\n ReleaseCapture;\r\n\r\n if not Toggle then\r\n begin\r\n FDown := False;\r\n Redraw(rkIndirect);\r\n end;\r\n\r\n if DoClick then\r\n Click;\r\n\r\n //(p3) we need to convert MouseUp message because they are in client coordinates (MouseDown are already in screen coords, so no need to change)\r\n with TWMMouse(Msg) do\r\n begin\r\n P := Point(XPos, YPos);\r\n Assert(ParentForm <> nil, '');\r\n P := ParentForm.ClientToScreen(P);\r\n MouseUp(mbLeft, KeysToShiftState(Keys), P.X, P.Y);\r\n end;\r\nend;\r\n\r\nfunction TJvCaptionButton.HandleHitTest(var Msg: TWMNCHitTest): Boolean;\r\nvar\r\n CurPos: TPoint;\r\nbegin\r\n Result := Visible and MouseOnButton(Msg.XPos, Msg.YPos, False);\r\n if Result then\r\n Msg.Result := htCaptionButton;\r\n\r\n if not Result and Visible and MouseInControl then\r\n begin\r\n // We can get weird hittest values (probably from the hint window) so\r\n // double check that the mouse is not on the button.\r\n // Actually we wrongfully assumed that Msg represents the current mouse\r\n // position so we have to double check.\r\n GetCursorPos(CurPos);\r\n if not MouseOnButton(CurPos.X, CurPos.Y, False) then\r\n begin\r\n SetMouseInControl(False);\r\n Redraw(rkIndirect);\r\n end;\r\n end;\r\n\r\n //Result := False;\r\nend;\r\n\r\nfunction TJvCaptionButton.HandleMouseMove(var Msg: TWMNCHitMessage): Boolean;\r\nvar\r\n DoRedraw: Boolean;\r\n MouseWasInControl: Boolean;\r\nbegin\r\n Result := FMouseButtonDown;\r\n\r\n if Result then\r\n begin\r\n MouseWasInControl := FMouseInControl;\r\n SetMouseInControl(MouseOnButton(Msg.XCursor, Msg.YCursor, Msg.Msg = WM_MOUSEMOVE));\r\n DoRedraw := (FMouseInControl <> MouseWasInControl) or\r\n // User presses mouse button, but left the caption button\r\n (FDown and not Toggle and not FMouseInControl) or\r\n // User presses mouse button, and enters the caption button\r\n (not FDown and not Toggle and FMouseInControl);\r\n\r\n FDown := (FDown and Toggle) or\r\n (FMouseButtonDown and not Toggle and FMouseInControl);\r\n if DoRedraw then\r\n Redraw(rkIndirect);\r\n end;\r\n // (p3) don't handle mouse move here: it is triggered even if the mouse is outside the button\r\n // with TWMMouseMove(Msg) do\r\n // MouseMove(KeysToShiftState(Keys), XPos, YPos);\r\nend;\r\n\r\nprocedure TJvCaptionButton.HandleNCActivate(var Msg: TWMNCActivate);\r\nbegin\r\n {$IFDEF JVCLThemesEnabled}\r\n FCaptionActive := Msg.Active;\r\n {$ENDIF JVCLThemesEnabled}\r\n SetMouseInControl(MouseInControl and Msg.Active);\r\n\r\n Redraw(rkDirect);\r\nend;\r\n\r\nprocedure TJvCaptionButton.HandleNCMouseMove(var Msg: TWMNCHitMessage);\r\nvar\r\n IsOnButton: Boolean;\r\nbegin\r\n IsOnButton := MouseOnButton(Msg.XCursor, Msg.YCursor, False);\r\n if Visible then\r\n begin\r\n if (IsOnButton <> FMouseInControl) then\r\n begin\r\n SetMouseInControl(not FMouseInControl);\r\n if not Down then\r\n Redraw(rkIndirect);\r\n end;\r\n // (p3) only handle mouse move if we are inside the button or it will be triggered for the entire NC area\r\n if IsOnButton then\r\n with TWMMouseMove(Msg) do\r\n MouseMove(KeysToShiftState(Keys), XPos, YPos);\r\n end;\r\nend;\r\n\r\nprocedure TJvCaptionButton.HandleNCPaintAfter(Wnd: THandle; var Msg: TWMNCPaint);\r\nbegin\r\n if FRgnChanged then\r\n begin\r\n DeleteObject(Msg.RGN);\r\n Msg.RGN := FSaveRgn;\r\n FRgnChanged := False;\r\n end;\r\n\r\n Redraw(rkDirect);\r\nend;\r\n\r\nprocedure TJvCaptionButton.HandleNCPaintBefore(Wnd: THandle; var Msg: TWMNCPaint);\r\nvar\r\n WindowRect: TRect;\r\n DrawRgn: HRGN;\r\n LButtonRect: TRect;\r\nbegin\r\n { Note: There is one problem with this reduce flickering method: This\r\n function is executed before windows handles the WM_NCPAINT and\r\n HandleNCPaintAfter is executed after windows handles WM_NCPAINT.\r\n\r\n When you resize a form, the value returned by API GetWindowRect is\r\n adjusted when windows handles the WM_NCPAINT.\r\n\r\n Thus return value of GetWindowRect in HandleNCPaintBefore differs\r\n from return value of GetWindowRect in HandleNCPaintAfter.\r\n ->\r\n Thus value of FButtonRect in HandleNCPaintBefore differs\r\n from return value of FButtonRect in HandleNCPaintAfter.\r\n\r\n (Diff is typically 1 pixel)\r\n\r\n This causes a light flickering at the edge of the button when\r\n you resize the form.\r\n\r\n To see it, put Sleep(1000) or so, before and after the DrawButton call\r\n in HandleNCPaintAfter and resize the screen horizontally\r\n }\r\n if Wnd = 0 then\r\n Exit;\r\n\r\n FSaveRgn := Msg.RGN;\r\n FRgnChanged := False;\r\n { Calculate button rect in screen coordinates, put it in LButtonRect }\r\n UpdateButtonRect(Wnd);\r\n LButtonRect := FButtonRect;\r\n GetWindowRect(Wnd, WindowRect);\r\n OffsetRect(LButtonRect, WindowRect.Left, WindowRect.Top);\r\n { Check if button rect is in the to be updated region.. }\r\n if RectInRegion(FSaveRgn, LButtonRect)\r\n {$IFDEF JVCLThemesEnabled}\r\n or FForceRedraw\r\n {$ENDIF JVCLThemesEnabled}\r\n then\r\n begin\r\n {$IFDEF JVCLThemesEnabled}\r\n FForceRedraw := False;\r\n {$ENDIF JVCLThemesEnabled}\r\n { ..If so remove the button rectangle from the region (otherwise the caption\r\n background would be drawn over the button, which causes flicker) }\r\n DrawRgn := CreateRectRgn(LButtonRect.Left, LButtonRect.Top, LButtonRect.Right, LButtonRect.Bottom);\r\n try\r\n Msg.RGN := CreateRectRgn(0, 0, 1, 1);\r\n FRgnChanged := True;\r\n CombineRgn(Msg.RGN, FSaveRgn, DrawRgn, RGN_DIFF);\r\n finally\r\n DeleteObject(DrawRgn);\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJvCaptionButton.HandleNotify(var Msg: TWMNotify): Boolean;\r\nvar\r\n CurPos: TPoint;\r\n LButtonRect, WindowRect: TRect;\r\nbegin\r\n // if we receive a TTN_GETDISPINFO notification\r\n // and it is from the tooltip\r\n Result := (Msg.NMHdr.code = TTN_NEEDTEXT) and (Msg.NMHdr.hwndFrom = FToolTipHandle);\r\n\r\n if Result and (ShowHint or (ParentShowHint and ParentForm.ShowHint)) then\r\n begin\r\n // get cursor position\r\n GetCursorPos(CurPos);\r\n GetWindowRect(ParentFormHandle, WindowRect);\r\n LButtonRect := FButtonRect;\r\n OffsetRect(LButtonRect, WindowRect.Left, WindowRect.Top);\r\n\r\n // if the mouse is in the area of the button\r\n if PtInRect(LButtonRect, CurPos) then\r\n {$IFDEF SUPPORTS_UNICODE}\r\n if Msg.NMHdr.code = TTN_NEEDTEXTW then\r\n begin\r\n with PNMTTDispInfoW(Msg.NMHdr)^ do\r\n begin\r\n // then we return the hint\r\n lpszText := PChar(FHint); // we do loose text here, but unicode should have kicked in anyway\r\n hinst := 0;\r\n uFlags := TTF_IDISHWND;\r\n hdr.idFrom := ParentFormHandle;\r\n end;\r\n end\r\n else\r\n {$ENDIF SUPPORTS_UNICODE}\r\n if Msg.NMHdr.code = TTN_NEEDTEXTA then\r\n begin\r\n with PNMTTDispInfoA(Msg.NMHdr)^ do\r\n begin\r\n // then we return the hint\r\n lpszText := PAnsiChar(AnsiString(FHint)); // we do loose text here, but unicode should have kicked in anyway\r\n hinst := 0;\r\n uFlags := TTF_IDISHWND;\r\n hdr.idFrom := ParentFormHandle;\r\n end;\r\n end\r\n else\r\n with PNMTTDispInfoW(Msg.NMHdr)^ do\r\n begin\r\n // then we return the hint\r\n lpszText := PWideChar(WideString(FHint));\r\n hinst := 0;\r\n uFlags := TTF_IDISHWND;\r\n hdr.idFrom := ParentFormHandle;\r\n end\r\n else\r\n //else we hide the tooltip\r\n HideToolTip;\r\n end;\r\nend;\r\n\r\nprocedure TJvCaptionButton.HideToolTip;\r\nbegin\r\n if FToolTipHandle <> 0 then\r\n SendMessage(FToolTipHandle, TTM_POP, 0, 0);\r\nend;\r\n\r\nprocedure TJvCaptionButton.Hook;\r\nvar\r\n P: TCustomForm;\r\nbegin\r\n //if not Visible or not FHasCaption then\r\n // Exit;\r\n\r\n P := ParentForm;\r\n if Assigned(P) then\r\n begin\r\n RegisterWndProcHook(P, WndProcAfter, hoAfterMsg);\r\n RegisterWndProcHook(P, WndProcBefore, hoBeforeMsg);\r\n\r\n if P.HandleAllocated then\r\n CreateToolTip(P.Handle);\r\n end;\r\nend;\r\n\r\nprocedure TJvCaptionButton.ImageListChange(Sender: TObject);\r\nbegin\r\n if Sender = Images then\r\n Redraw(rkIndirect);\r\nend;\r\n\r\nprocedure TJvCaptionButton.InitiateAction;\r\nbegin\r\n if FActionLink <> nil then\r\n FActionLink.Update;\r\nend;\r\n\r\nfunction TJvCaptionButton.IsCaptionStored: Boolean;\r\nbegin\r\n Result := (ActionLink = nil) or not FActionLink.IsCaptionLinked;\r\nend;\r\n\r\nfunction TJvCaptionButton.IsEnabledStored: Boolean;\r\nbegin\r\n Result := (ActionLink = nil) or not FActionLink.IsEnabledLinked;\r\nend;\r\n\r\nfunction TJvCaptionButton.IsHintStored: Boolean;\r\nbegin\r\n Result := (ActionLink = nil) or not FActionLink.IsHintLinked;\r\nend;\r\n\r\nfunction TJvCaptionButton.IsImageIndexStored: Boolean;\r\nbegin\r\n Result := (ActionLink = nil) or not FActionLink.IsImageIndexLinked;\r\nend;\r\n\r\nprocedure TJvCaptionButton.Loaded;\r\nbegin\r\n inherited Loaded;\r\n\r\n CreateToolTip(ParentFormHandle);\r\n Redraw(rkTotalCaptionBar);\r\nend;\r\n\r\nprocedure TJvCaptionButton.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);\r\nbegin\r\n if Assigned(FOnMouseDown) then\r\n FOnMouseDown(Self, Button, Shift, X, Y);\r\nend;\r\n\r\nprocedure TJvCaptionButton.MouseMove(Shift: TShiftState; X, Y: Integer);\r\nbegin\r\n if Assigned(FOnMouseMove) then\r\n FOnMouseMove(Self, Shift, X, Y);\r\nend;\r\n\r\nfunction TJvCaptionButton.MouseOnButton(X, Y: Integer;\r\n const TranslateToScreenCoord: Boolean): Boolean;\r\nvar\r\n WindowRect: TRect;\r\n Wnd: THandle;\r\n P: TPoint;\r\nbegin\r\n Wnd := ParentFormHandle;\r\n Result := Wnd <> 0;\r\n if not Result then\r\n Exit;\r\n\r\n P := Point(X, Y);\r\n if TranslateToScreenCoord then\r\n Windows.ClientToScreen(Wnd, P);\r\n\r\n GetWindowRect(Wnd, WindowRect);\r\n Result := PtInRect(FClickRect, Point(P.X - WindowRect.Left, P.Y - WindowRect.Top));\r\nend;\r\n\r\nprocedure TJvCaptionButton.MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);\r\nbegin\r\n if Assigned(FOnMouseUp) then\r\n FOnMouseUp(Self, Button, Shift, X, Y);\r\nend;\r\n\r\nprocedure TJvCaptionButton.Notification(AComponent: TComponent;\r\n Operation: TOperation);\r\nbegin\r\n inherited Notification(AComponent, Operation);\r\n if (AComponent = Images) and (Operation = opRemove) then\r\n Images := nil;\r\nend;\r\n\r\nprocedure TJvCaptionButton.Redraw(const AKind: TJvRedrawKind);\r\nvar\r\n Wnd: THandle;\r\n DC: HDC;\r\nbegin\r\n if csLoading in ComponentState then\r\n Exit;\r\n\r\n Wnd := ParentFormHandle;\r\n if Wnd = 0 then\r\n Exit;\r\n\r\n case AKind of\r\n rkDirect:\r\n begin\r\n DC := GetWindowDC(Wnd);\r\n try\r\n DrawButton(DC);\r\n finally\r\n ReleaseDC(Wnd, DC);\r\n end;\r\n end;\r\n rkIndirect:\r\n begin\r\n UpdateButtonRect(Wnd);\r\n RedrawWindow(Wnd, @FButtonRect, 0, RDW_FRAME or RDW_INVALIDATE or RDW_ERASE);\r\n end;\r\n rkTotalCaptionBar:\r\n begin\r\n UpdateButtonRect(Wnd);\r\n RedrawWindow(Wnd, PRect(0), 0, RDW_FRAME or RDW_NOINTERNALPAINT or RDW_INVALIDATE);\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvCaptionButton.ResetButton;\r\nbegin\r\n UnHook;\r\n Hook;\r\n Redraw(rkTotalCaptionBar);\r\nend;\r\n\r\nprocedure TJvCaptionButton.SetAction(const Value: TBasicAction);\r\nbegin\r\n if (FActionLink <> nil) and (FActionLink.Action <> nil) then\r\n FActionLink.Action.RemoveFreeNotification(Self);\r\n if Value = nil then\r\n begin\r\n FActionLink.Free;\r\n FActionLink := nil;\r\n end\r\n else\r\n begin\r\n if FActionLink = nil then\r\n FActionLink := GetActionLinkClass.Create(Self);\r\n FActionLink.Action := Value;\r\n FActionLink.OnChange := DoActionChange;\r\n ActionChange(Value, csLoading in Value.ComponentState);\r\n Value.FreeNotification(Self);\r\n end;\r\nend;\r\n\r\nprocedure TJvCaptionButton.SetAlignment(Value: TAlignment);\r\nbegin\r\n if FAlignment <> Value then\r\n begin\r\n FAlignment := Value;\r\n if Standard = tsbNone then\r\n Redraw(rkIndirect);\r\n end;\r\nend;\r\n\r\nprocedure TJvCaptionButton.SetCaption(Value: string);\r\nbegin\r\n if FCaption <> Value then\r\n begin\r\n FCaption := Value;\r\n if Standard = tsbNone then\r\n Redraw(rkIndirect);\r\n end;\r\nend;\r\n\r\nprocedure TJvCaptionButton.SetDown(const Value: Boolean);\r\nbegin\r\n if (FDown <> Value) and Toggle then\r\n begin\r\n FDown := Value;\r\n Redraw(rkIndirect);\r\n end;\r\nend;\r\n\r\nprocedure TJvCaptionButton.SetEnabled(const Value: Boolean);\r\nbegin\r\n if FEnabled <> Value then\r\n begin\r\n FEnabled := Value;\r\n Redraw(rkIndirect);\r\n end;\r\nend;\r\n\r\nprocedure TJvCaptionButton.SetFont(Value: TFont);\r\nbegin\r\n if FFont <> Value then\r\n begin\r\n FFont.Assign(Value);\r\n if Standard = tsbNone then\r\n Redraw(rkIndirect);\r\n end;\r\nend;\r\n\r\n{$IFDEF JVCLThemesEnabled}\r\nprocedure TJvCaptionButton.SetForceDrawSimple(const Value: Boolean);\r\nbegin\r\n if FForceDrawSimple <> Value then\r\n begin\r\n FForceDrawSimple := Value;\r\n if IsThemed then\r\n Redraw(rkDirect);\r\n end;\r\nend;\r\n{$ENDIF JVCLThemesEnabled}\r\n\r\nprocedure TJvCaptionButton.SetHeight(Value: Integer);\r\nbegin\r\n if (FHeight <> Value) and (Value >= 0) then\r\n begin\r\n FHeight := Value;\r\n Redraw(rkTotalCaptionBar);\r\n end;\r\nend;\r\n\r\nprocedure TJvCaptionButton.SetImageIndex(const Value: TImageIndex);\r\nbegin\r\n if Value <> FImageIndex then\r\n begin\r\n FImageIndex := Value;\r\n if Standard = tsbNone then\r\n Redraw(rkIndirect);\r\n end;\r\nend;\r\n\r\nprocedure TJvCaptionButton.SetImages(const Value: TCustomImageList);\r\nbegin\r\n ReplaceImageListReference(Self, Value, FImages, FImageChangeLink);\r\n if Standard = tsbNone then\r\n Redraw(rkIndirect);\r\nend;\r\n\r\nprocedure TJvCaptionButton.SetLayout(const Value: TJvCaptionButtonLayout);\r\nbegin\r\n if FLayout <> Value then\r\n begin\r\n FLayout := Value;\r\n if (csDesigning in ComponentState) and (FAlignment <> taCenter) then\r\n case FLayout of\r\n cbImageLeft: FAlignment := taLeftJustify;\r\n cbImageRight: FAlignment := taRightJustify;\r\n end;\r\n if (Standard = tsbNone) and IsImageVisible then\r\n Redraw(rkIndirect);\r\n end;\r\nend;\r\n\r\nprocedure TJvCaptionButton.SetLeft(Value: Integer);\r\nbegin\r\n if FLeft <> Value then\r\n begin\r\n FLeft := Value;\r\n Redraw(rkTotalCaptionBar);\r\n end;\r\nend;\r\n\r\nprocedure TJvCaptionButton.SetMargin(const Value: Integer);\r\nbegin\r\n if (FMargin <> Value) and (Value >= -1) then\r\n begin\r\n FMargin := Value;\r\n if Standard = tsbNone then\r\n Redraw(rkIndirect);\r\n end;\r\nend;\r\n\r\nprocedure TJvCaptionButton.SetMouseInControl(const Value: Boolean);\r\nbegin\r\n if FMouseInControl <> Value then\r\n begin\r\n if not Value then\r\n HideToolTip;\r\n\r\n FMouseInControl := Value;\r\n end;\r\nend;\r\n\r\nprocedure TJvCaptionButton.SetParentShowHint(const Value: Boolean);\r\nbegin\r\n if FParentShowHint <> Value then\r\n begin\r\n FParentShowHint := Value;\r\n if FParentShowHint then\r\n FShowHint := ParentForm.ShowHint;\r\n end;\r\nend;\r\n\r\nprocedure TJvCaptionButton.SetPosition(const Value: Integer);\r\nbegin\r\n if FPosition <> Value then\r\n begin\r\n FPosition := Value;\r\n Redraw(rkTotalCaptionBar);\r\n end;\r\nend;\r\n\r\nprocedure TJvCaptionButton.SetShowHint(const Value: Boolean);\r\nbegin\r\n if FShowHint <> Value then\r\n begin\r\n FShowHint := Value;\r\n FParentShowHint := False;\r\n end;\r\nend;\r\n\r\nprocedure TJvCaptionButton.SetSpacing(const Value: Integer);\r\nbegin\r\n if FSpacing <> Value then\r\n begin\r\n FSpacing := Value;\r\n if Standard = tsbNone then\r\n Redraw(rkIndirect);\r\n end;\r\nend;\r\n\r\nprocedure TJvCaptionButton.SetStandard(Value: TJvStandardButton);\r\n{$IFDEF JVCLThemesEnabled}\r\nvar\r\n ButtonSizeChanged: Boolean;\r\n{$ENDIF JVCLThemesEnabled}\r\nbegin\r\n if FStandard <> Value then\r\n begin\r\n {$IFDEF JVCLThemesEnabled}\r\n ButtonSizeChanged := IsThemed and\r\n ((Value = tsbMinimizeToTray) or (FStandard = tsbMinimizeToTray));\r\n {$ENDIF JVCLThemesEnabled}\r\n FStandard := Value;\r\n\r\n {$IFDEF JVCLThemesEnabled}\r\n if ButtonSizeChanged then\r\n UpdateButtonRect(ParentFormHandle);\r\n\r\n if ButtonSizeChanged and (FStandard = tsbMinimizeToTray) then\r\n Redraw(rkTotalCaptionBar)\r\n else\r\n {$ENDIF JVCLThemesEnabled}\r\n Redraw(rkIndirect);\r\n end;\r\nend;\r\n\r\nprocedure TJvCaptionButton.SetToggle(const Value: Boolean);\r\nbegin\r\n if FToggle <> Value then\r\n begin\r\n FToggle := Value;\r\n if FDown and not FToggle and not (FMouseInControl and FMouseButtonDown) then\r\n begin\r\n FDown := False;\r\n Redraw(rkIndirect);\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvCaptionButton.SetTop(Value: Integer);\r\nbegin\r\n if FTop <> Value then\r\n begin\r\n FTop := Value;\r\n Redraw(rkTotalCaptionBar);\r\n end;\r\nend;\r\n\r\nprocedure TJvCaptionButton.SetVisible(const Value: Boolean);\r\nbegin\r\n if Value <> FVisible then\r\n begin\r\n FVisible := Value;\r\n { Caption, RedrawButton doesn't draw the caption itself }\r\n Redraw(rkTotalCaptionBar);\r\n end;\r\nend;\r\n\r\nprocedure TJvCaptionButton.SetWidth(Value: Integer);\r\nbegin\r\n if (FWidth <> Value) and (Value >= 0) then\r\n begin\r\n FWidth := Value;\r\n Redraw(rkTotalCaptionBar);\r\n end;\r\nend;\r\n\r\nprocedure TJvCaptionButton.UnHook;\r\nvar\r\n P: TCustomForm;\r\nbegin\r\n P := ParentForm;\r\n if Assigned(P) then\r\n begin\r\n DestroyToolTip;\r\n UnRegisterWndProcHook(P, WndProcAfter, hoAfterMsg);\r\n UnRegisterWndProcHook(P, WndProcBefore, hoBeforeMsg);\r\n end;\r\nend;\r\n\r\nprocedure TJvCaptionButton.UpdateButtonRect(Wnd: THandle);\r\nvar\r\n WindowRect: TRect;\r\n LButtonWidth: Integer;\r\n LButtonHeight: Integer;\r\nbegin\r\n if Wnd = 0 then\r\n Exit;\r\n\r\n if FNeedRecalculate then\r\n CalcDefaultButtonRect(Wnd);\r\n\r\n GetWindowRect(Wnd, WindowRect);\r\n\r\n if ButtonWidth <> 0 then\r\n LButtonWidth := ButtonWidth\r\n else\r\n LButtonWidth := FDefaultButtonWidth;\r\n\r\n if ButtonHeight <> 0 then\r\n LButtonHeight := ButtonHeight\r\n else\r\n LButtonHeight := FDefaultButtonHeight;\r\n\r\n FButtonRect := Bounds(\r\n WindowRect.Right - WindowRect.Left - FDefaultButtonLeft + ButtonLeft\r\n + FDefaultButtonWidth - LButtonWidth,\r\n FDefaultButtonTop + ButtonTop, LButtonWidth, LButtonHeight);\r\n\r\n OffsetRect(FButtonRect, -FPosition * (FDefaultButtonWidth + 2), 0);\r\n\r\n { Special }\r\n {$IFDEF JVCLThemesEnabled}\r\n if (FStandard = tsbMinimizeToTray) and IsThemed then\r\n Inc(FButtonRect.Top, 2);\r\n {$ENDIF JVCLThemesEnabled}\r\n\r\n { Click rect is a bit bigger }\r\n FClickRect := Rect(FButtonRect.Left - 2, FButtonRect.Top - 2, FButtonRect.Right + 1, FButtonRect.Bottom + 2);\r\nend;\r\n\r\nfunction TJvCaptionButton.WndProcAfter(var Msg: TMessage): Boolean;\r\nbegin\r\n { let others listen in too }\r\n Result := False;\r\n\r\n case Msg.Msg of\r\n {$IFDEF JVCLThemesEnabled}\r\n WM_THEMECHANGED,\r\n {$ENDIF JVCLThemesEnabled}\r\n CM_SYSCOLORCHANGE:\r\n begin\r\n FNeedRecalculate := True;\r\n {$IFDEF JVCLThemesEnabled}\r\n { force theme data refresh, needed when\r\n\r\n * Switching from 'windows classic' style to 'windows XP' style\r\n ( delphi 7 bug) }\r\n ThemeServices.UpdateThemes;\r\n GlobalXPData.Update;\r\n {$ENDIF JVCLThemesEnabled}\r\n end;\r\n CM_SYSFONTCHANGED:\r\n begin\r\n FNeedRecalculate := True;\r\n {$IFDEF JVCLThemesEnabled}\r\n { force theme data refresh, needed when\r\n\r\n * Non-themed application and switching system font size }\r\n if not StyleServices.Enabled then\r\n ThemeServices.UpdateThemes;\r\n {$ENDIF JVCLThemesEnabled}\r\n end;\r\n WM_SETTEXT:\r\n { Caption text may overwrite the button, so redraw }\r\n Redraw(rkIndirect);\r\n WM_NCPAINT:\r\n HandleNCPaintAfter(ParentFormHandle, TWMNCPaint(Msg));\r\n WM_NCACTIVATE:\r\n HandleNCActivate(TWMNCActivate(Msg));\r\n CM_RECREATEWND:\r\n begin\r\n CreateToolTip(ParentFormHandle);\r\n FNeedRecalculate := True;\r\n //CalcDefaultButtonRect(ParentFormHandle);\r\n Redraw(rkTotalCaptionBar);\r\n end;\r\n WM_LBUTTONDOWN, WM_NCLBUTTONUP, WM_LBUTTONUP, WM_NCMOUSEMOVE, WM_NCRBUTTONUP,\r\n WM_RBUTTONUP, WM_NCRBUTTONDOWN, WM_RBUTTONDOWN, WM_NCLBUTTONDOWN:\r\n ForwardToToolTip(Msg);\r\n end;\r\nend;\r\n\r\nfunction TJvCaptionButton.WndProcBefore(var Msg: TMessage): Boolean;\r\nbegin\r\n case Msg.Msg of\r\n CM_SHOWHINTCHANGED:\r\n begin\r\n if ParentShowHint then\r\n FShowHint := ParentForm.ShowHint;\r\n Result := False;\r\n end;\r\n CM_MOUSELEAVE, CM_MOUSEENTER:\r\n begin\r\n if FMouseInControl then\r\n begin\r\n SetMouseInControl(False);\r\n Redraw(rkIndirect);\r\n end;\r\n Result := False;\r\n end;\r\n WM_NCLBUTTONDOWN: //, WM_LBUTTONDOWN:\r\n begin\r\n Result := HandleButtonDown(TWMNCHitMessage(Msg));\r\n if Result then\r\n ForwardToToolTip(Msg);\r\n end;\r\n WM_NCLBUTTONUP, WM_LBUTTONUP:\r\n begin\r\n Result := HandleButtonUp(TWMNCHitMessage(Msg));\r\n if Result then\r\n ForwardToToolTip(Msg);\r\n end;\r\n WM_MOUSEMOVE:\r\n begin\r\n Result := HandleMouseMove(TWMNCHitMessage(Msg));\r\n if Result then\r\n ForwardToToolTip(Msg);\r\n end;\r\n WM_NCMOUSEMOVE:\r\n begin\r\n Result := False;\r\n HandleNCMouseMove(TWMNCHitMessage(Msg));\r\n end;\r\n WM_NCHITTEST:\r\n Result := HandleHitTest(TWMNCHitTest(Msg));\r\n WM_NCPAINT:\r\n begin\r\n Result := False;\r\n HandleNCPaintBefore(ParentFormHandle, TWMNCPaint(Msg));\r\n end;\r\n WM_DESTROY:\r\n begin\r\n Result := False;\r\n {DestroyToolTip;}\r\n // FToolTipHandle is automatically destroyed when ParentForm handle is destroyed.\r\n FToolTipHandle := 0;\r\n end;\r\n WM_NOTIFY:\r\n Result := HandleNotify(TWMNotify(Msg));\r\n WM_SIZE:\r\n begin\r\n if Assigned(ParentForm) and (FCurrentWindowState <> ParentForm.WindowState) then\r\n begin\r\n FNeedRecalculate := True;\r\n FCurrentWindowState := ParentForm.WindowState;\r\n RedrawWindow(ParentFormHandle, nil, 0, RDW_FRAME or RDW_INVALIDATE);\r\n end;\r\n Result := False;\r\n end;\r\n else\r\n Result := False;\r\n end;\r\nend;\r\n\r\n//=== { TJvCaptionButtonActionLink } =========================================\r\n\r\nprocedure TJvCaptionButtonActionLink.AssignClient(AClient: TObject);\r\nbegin\r\n FClient := AClient as TJvCaptionButton;\r\nend;\r\n\r\nfunction TJvCaptionButtonActionLink.IsCaptionLinked: Boolean;\r\nbegin\r\n Result := inherited IsCaptionLinked and\r\n AnsiSameText(FClient.Caption, (Action as TCustomAction).Caption);\r\nend;\r\n\r\nfunction TJvCaptionButtonActionLink.IsEnabledLinked: Boolean;\r\nbegin\r\n Result := inherited IsEnabledLinked and\r\n (FClient.Enabled = (Action as TCustomAction).Enabled);\r\nend;\r\n\r\nfunction TJvCaptionButtonActionLink.IsHintLinked: Boolean;\r\nbegin\r\n Result := inherited IsHintLinked and\r\n (FClient.Hint = (Action as TCustomAction).Hint);\r\nend;\r\n\r\nfunction TJvCaptionButtonActionLink.IsImageIndexLinked: Boolean;\r\nbegin\r\n Result := inherited IsImageIndexLinked and\r\n (FClient.ImageIndex = (Action as TCustomAction).ImageIndex);\r\nend;\r\n\r\nfunction TJvCaptionButtonActionLink.IsOnExecuteLinked: Boolean;\r\nbegin\r\n Result := inherited IsOnExecuteLinked and\r\n (@FClient.OnClick = @Action.OnExecute);\r\nend;\r\n\r\nfunction TJvCaptionButtonActionLink.IsVisibleLinked: Boolean;\r\nbegin\r\n Result := inherited IsVisibleLinked and\r\n (FClient.Visible = (Action as TCustomAction).Visible);\r\nend;\r\n\r\nprocedure TJvCaptionButtonActionLink.SetCaption(const Value: string);\r\nbegin\r\n if IsCaptionLinked then\r\n FClient.Caption := Value;\r\nend;\r\n\r\nprocedure TJvCaptionButtonActionLink.SetEnabled(Value: Boolean);\r\nbegin\r\n if IsEnabledLinked then\r\n FClient.Enabled := Value;\r\nend;\r\n\r\nprocedure TJvCaptionButtonActionLink.SetHint(const Value: string);\r\nbegin\r\n if IsHintLinked then\r\n FClient.Hint := Value;\r\nend;\r\n\r\nprocedure TJvCaptionButtonActionLink.SetImageIndex(Value: Integer);\r\nbegin\r\n if IsImageIndexLinked then\r\n FClient.ImageIndex := Value;\r\nend;\r\n\r\nprocedure TJvCaptionButtonActionLink.SetOnExecute(Value: TNotifyEvent);\r\nbegin\r\n if IsOnExecuteLinked then\r\n FClient.OnClick := Value;\r\nend;\r\n\r\nprocedure TJvCaptionButtonActionLink.SetVisible(Value: Boolean);\r\nbegin\r\n if IsVisibleLinked then\r\n FClient.Visible := Value;\r\nend;\r\n\r\ninitialization\r\n {$IFDEF UNITVERSIONING}\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n {$ENDIF UNITVERSIONING}\r\n\r\nfinalization\r\n UnloadMsimg32Dll;\r\n {$IFDEF UNITVERSIONING}\r\n UnregisterUnitVersion(HInstance);\r\n {$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvCaptionPanel.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvCaptionPanel.PAS, released on 2002-05-26.\r\n\r\nThe Initial Developer of the Original Code is Peter Thrnqvist [peter3 at sourceforge dot net]\r\nPortions created by Peter Thrnqvist are Copyright 1997-2002 Peter Thrnqvist.\r\nAll Rights Reserved.\r\n\r\nContributor(s): Michael Beck [mbeck att bigfoot dott com]\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nDescription:\r\n TJvCaptionPanel is a panel that looks like a form, with a Caption area,\r\n system buttons but is derived from a normal panel.\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvCaptionPanel.pas 13104 2011-09-07 06:50:43Z obones $\r\n\r\nunit JvCaptionPanel;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\n// Define JVCAPTIONPANEL_STD_BEHAVE to not use the previous undocumented WM_SYSCOMMAND with SC_DRAGMOVE but instead handle\r\n// the dragging \"manually\" within the control. Defining this means that you actually get the Mouse events\r\n// and the OnEndAutoDrag event. Additionally, the form displays scrollbars as expected when the component is dragged\r\n// The downside is that the control \"flashes\" more when it's dragged\r\n{$DEFINE JVCAPTIONPANEL_STD_BEHAVE}\r\n\r\n\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, Messages,\r\n SysUtils, Classes, Graphics, Controls, Forms, ExtCtrls,\r\n JvComponent, JvExtComponent, JvExControls;\r\n\r\ntype\r\n TJvCapBtnStyle = (capClose, capMax, capMin, capRestore, capHelp);\r\n TJvCapBtnStyles = set of TJvCapBtnStyle;\r\n TJvDrawPosition = (dpLeft, dpTop, dpRight, dpBottom);\r\n TJvCapBtnEvent = procedure(Sender: TObject; Button: TJvCapBtnStyle) of object;\r\n TJvAutoDragStartEvent = procedure(Sender: TObject; var AllowDrag: Boolean) of object;\r\n { internal class }\r\n\r\n TJvCapBtn = class(TJvGraphicControl)\r\n private\r\n FOwner: TComponent;\r\n FStyle: TJvCapBtnStyle;\r\n FMouseDown: Boolean;\r\n FDown: Boolean;\r\n FFlat: Boolean;\r\n FOver: Boolean;\r\n procedure SetFlat(Value: Boolean);\r\n procedure SetStyle(Value: TJvCapBtnStyle);\r\n procedure BtnClick;\r\n protected\r\n procedure Click; override;\r\n procedure Paint; override;\r\n procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;\r\n procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;\r\n procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;\r\n procedure MouseEnter(Control: TControl); override;\r\n procedure MouseLeave(Control: TControl); override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n property Style: TJvCapBtnStyle read FStyle write SetStyle default capClose;\r\n property Flat: Boolean read FFlat write SetFlat default False;\r\n property Visible default False;\r\n end;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvCaptionPanel = class(TJvCustomPanel, IJvDenySubClassing)\r\n private\r\n FButtonArray: array [TJvCapBtnStyle] of TJvCapBtn;\r\n FButtonClick: TJvCapBtnEvent;\r\n FCaptionPosition: TJvDrawPosition;\r\n FOffset: Integer;\r\n FButtons: TJvCapBtnStyles;\r\n FAutoDrag: Boolean;\r\n FMouseDown: Boolean;\r\n FCaptionRect: TRect;\r\n FCaption: string;\r\n FCaptionColor: TColor;\r\n FFlat: Boolean;\r\n FBevel: Integer;\r\n FDragging: Boolean;\r\n FEndDrag: TNotifyEvent;\r\n FCaptionFont: TFont;\r\n FOnStartAutoDrag: TJvAutoDragStartEvent;\r\n FOutlookLook: Boolean;\r\n FCaptionOffsetSmall: Integer;\r\n FCaptionOffsetLarge: Integer;\r\n FIcon: TIcon;\r\n {$IFDEF JVCAPTIONPANEL_STD_BEHAVE}\r\n FAnchorPos: TPoint;\r\n {$ENDIF JVCAPTIONPANEL_STD_BEHAVE}\r\n FResizable: Boolean;\r\n FCaptionHeight: Integer;\r\n procedure SetIcon(Value: TIcon);\r\n procedure SetCaptionFont(Value: TFont);\r\n procedure SetCaptionColor(Value: TColor);\r\n procedure SetFlat(Value: Boolean);\r\n procedure SetButtons(Value: TJvCapBtnStyles);\r\n procedure SetCaption(Value: string);\r\n procedure SetCaptionPosition(Value: TJvDrawPosition);\r\n procedure DrawRotatedText(Rotation: Integer);\r\n procedure DrawButtons;\r\n procedure WMNCLButtonUp(var Msg: TWMNCLButtonUp); message WM_NCLBUTTONUP;\r\n procedure SetResizable(const Value: Boolean);\r\n procedure SetOutlookLook(const Value: Boolean);\r\n procedure DoCaptionFontChange(Sender: TObject);\r\n procedure SetCaptionHeight(const Value: Integer);\r\n protected\r\n procedure Paint; override;\r\n procedure Resize; override;\r\n function GetEffectiveCaptionHeight: Integer;\r\n\r\n procedure AlignControls(AControl: TControl; var R: TRect); override;\r\n procedure CreateParams(var Params: TCreateParams); override;\r\n procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;\r\n procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;\r\n procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;\r\n procedure ClickButton(Button: TJvCapBtnStyle); virtual;\r\n function CanStartDrag: Boolean; virtual;\r\n procedure DoLeaveDrag; virtual;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n published\r\n property Align;\r\n property AutoDrag: Boolean read FAutoDrag write FAutoDrag default True;\r\n property Buttons: TJvCapBtnStyles read FButtons write SetButtons;\r\n property BorderStyle default bsSingle;\r\n property Caption: string read FCaption write SetCaption;\r\n property CaptionColor: TColor read FCaptionColor write SetCaptionColor default clActiveCaption;\r\n property CaptionPosition: TJvDrawPosition read FCaptionPosition write SetCaptionPosition default dpLeft;\r\n property CaptionFont: TFont read FCaptionFont write SetCaptionFont;\r\n property CaptionHeight: Integer read FCaptionHeight write SetCaptionHeight default 0;\r\n property Color;\r\n property Cursor;\r\n property DragCursor;\r\n property FullRepaint;\r\n property Locked;\r\n property DragMode;\r\n property Enabled;\r\n property FlatButtons: Boolean read FFlat write SetFlat default False;\r\n property Font;\r\n property Hint;\r\n property Icon: TIcon read FIcon write SetIcon;\r\n property OutlookLook: Boolean read FOutlookLook write SetOutlookLook;\r\n property ParentColor;\r\n property ParentFont;\r\n property ParentShowHint;\r\n property PopupMenu;\r\n property Resizable:Boolean read FResizable write SetResizable default True;\r\n property ShowHint;\r\n property TabOrder;\r\n property TabStop;\r\n property Visible;\r\n property OnButtonClick: TJvCapBtnEvent read FButtonClick write FButtonClick;\r\n property OnClick;\r\n property OnDblClick;\r\n property OnDragDrop;\r\n property OnDragOver;\r\n property OnEndDrag;\r\n property OnStartAutoDrag: TJvAutoDragStartEvent read FOnStartAutoDrag write FOnStartAutoDrag;\r\n property OnEndAutoDrag: TNotifyEvent read FEndDrag write FEndDrag;\r\n property OnEnter;\r\n property OnExit;\r\n property OnMouseDown;\r\n property OnMouseMove;\r\n property OnMouseUp;\r\n property OnStartDrag;\r\n property OnResize;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvCaptionPanel.pas $';\r\n Revision: '$Revision: 13104 $';\r\n Date: '$Date: 2011-09-07 08:50:43 +0200 (mer. 07 sept. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n JvJCLUtils;\r\n\r\n//=== { TJvCapBtn } ==========================================================\r\n\r\nconstructor TJvCapBtn.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FOwner := AOwner;\r\n Width := GetSystemMetrics(SM_CYCAPTION) - 3;\r\n Height := Width - 2;\r\n FStyle := capClose;\r\n Visible := False;\r\n FFlat := False;\r\nend;\r\n\r\nprocedure TJvCapBtn.BtnClick;\r\nbegin\r\n if FOwner is TJvCaptionPanel then\r\n TJvCaptionPanel(FOwner).ClickButton(Style);\r\nend;\r\n\r\nprocedure TJvCapBtn.SetFlat(Value: Boolean);\r\nbegin\r\n if FFlat <> Value then\r\n begin\r\n FFlat := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvCapBtn.SetStyle(Value: TJvCapBtnStyle);\r\nbegin\r\n if FStyle <> Value then\r\n begin\r\n FStyle := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvCapBtn.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);\r\nbegin\r\n if not Enabled then\r\n Exit;\r\n inherited MouseDown(Button, Shift, X, Y);\r\n if not FMouseDown then\r\n begin\r\n FMouseDown := True;\r\n FDown := True;\r\n Repaint;\r\n end;\r\nend;\r\n\r\nprocedure TJvCapBtn.Click;\r\nbegin\r\n inherited Click;\r\n BtnClick;\r\nend;\r\n\r\nprocedure TJvCapBtn.MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);\r\nbegin\r\n if not Enabled then\r\n Exit;\r\n inherited MouseUp(Button, Shift, X, Y);\r\n if FMouseDown then\r\n begin\r\n FMouseDown := False;\r\n FDown := False;\r\n Repaint;\r\n end;\r\nend;\r\n\r\nprocedure TJvCapBtn.MouseMove(Shift: TShiftState; X, Y: Integer);\r\nbegin\r\n inherited MouseMove(Shift, X, Y);\r\n if FMouseDown then\r\n begin\r\n FOver := PtInRect(ClientRect, Point(X, Y));\r\n if not FOver then\r\n begin\r\n if FDown then { mouse has slid off, so release }\r\n begin\r\n FDown := False;\r\n Repaint;\r\n end;\r\n end\r\n else\r\n begin\r\n if not FDown then { mouse has slid back on, so push }\r\n begin\r\n FDown := True;\r\n Repaint;\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvCapBtn.MouseEnter(Control: TControl);\r\nvar\r\n R: TRect;\r\nbegin\r\n if csDesigning in ComponentState then\r\n Exit;\r\n if not FOver then\r\n begin\r\n FOver := True;\r\n if FFlat then\r\n begin\r\n R := ClientRect;\r\n if FDown then\r\n Frame3D(Canvas, R, clBtnShadow, clBtnHighLight, 1)\r\n else\r\n Frame3D(Canvas, R, clBtnHighLight, clBtnShadow, 1);\r\n end;\r\n inherited MouseEnter(Control);\r\n end;\r\nend;\r\n\r\nprocedure TJvCapBtn.MouseLeave(Control: TControl);\r\nvar\r\n R: TRect;\r\nbegin\r\n if FOver then\r\n begin\r\n FOver := False;\r\n if FFlat then\r\n begin\r\n R := ClientRect;\r\n Frame3D(Canvas, R, clBtnFace, clBtnFace, 1);\r\n end;\r\n inherited MouseLeave(Control);\r\n end;\r\nend;\r\n\r\nprocedure TJvCapBtn.Paint;\r\nvar\r\n Flags: Integer;\r\n R: TRect;\r\nbegin\r\n if not Visible then\r\n Exit;\r\n Flags := 0;\r\n case FStyle of\r\n capClose:\r\n Flags := DFCS_CAPTIONCLOSE;\r\n capMax:\r\n Flags := DFCS_CAPTIONMAX;\r\n capMin:\r\n Flags := DFCS_CAPTIONMIN;\r\n capRestore:\r\n Flags := DFCS_CAPTIONRESTORE;\r\n capHelp:\r\n Flags := DFCS_CAPTIONHELP;\r\n end;\r\n\r\n if not Enabled then\r\n Flags := Flags or DFCS_INACTIVE\r\n else\r\n if FDown and FMouseDown and Enabled then\r\n Flags := Flags or DFCS_PUSHED;\r\n if FFlat then\r\n Flags := Flags or DFCS_FLAT;\r\n\r\n Canvas.Brush.Color := Color;\r\n SetBkMode(Canvas.Handle, TRANSPARENT);\r\n DrawFrameControl(Canvas.Handle, ClientRect, DFC_CAPTION, Flags);\r\n if FFlat then\r\n begin\r\n R := ClientRect;\r\n if FDown and FMouseDown then\r\n Frame3D(Canvas, R, clBtnShadow, clBtnHighLight, 1)\r\n else\r\n if FOver then\r\n Frame3D(Canvas, R, clBtnHighLight, clBtnShadow, 1)\r\n else\r\n Frame3D(Canvas, R, clBtnFace, clBtnFace, 1);\r\n end;\r\nend;\r\n\r\n//=== { TJvCaptionPanel } ====================================================\r\n\r\nconstructor TJvCaptionPanel.Create(AOwner: TComponent);\r\nvar\r\n I: TJvCapBtnStyle;\r\nbegin\r\n inherited Create(AOwner);\r\n DoubleBuffered := True;\r\n FCaptionFont := TFont.Create;\r\n FIcon := TIcon.Create;\r\n // (rom) Warning! This seems no standard Windows font\r\n// FCaptionFont.Name := 'MS Shell Dlg 2';\r\n FCaptionFont.Size := 10;\r\n FCaptionFont.Style := [fsBold];\r\n FCaptionFont.Color := clWhite;\r\n FCaptionFont.OnChange := DoCaptionFontChange;\r\n FCaptionPosition := dpLeft;\r\n FAutoDrag := True;\r\n FOffset := 8;\r\n FCaptionColor := clActiveCaption;\r\n FFlat := False;\r\n for I := Low(FButtonArray) to High(FButtonArray) do //Iterate\r\n begin\r\n FButtonArray[I] := TJvCapBtn.Create(Self);\r\n FButtonArray[I].Parent := Self;\r\n FButtonArray[I].Style := I;\r\n FButtonArray[I].Flat := FFlat;\r\n end;\r\n FButtons := [];\r\n BorderStyle := bsSingle;\r\n\r\n FCaptionOffsetSmall := 2;\r\n FCaptionOffsetLarge := 3;\r\n FOutlookLook := False;\r\n FResizable := True;\r\nend;\r\n\r\ndestructor TJvCaptionPanel.Destroy;\r\nbegin\r\n FIcon.Free;\r\n FCaptionFont.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvCaptionPanel.SetCaptionFont(Value: TFont);\r\nbegin\r\n FCaptionFont.Assign(Value);\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvCaptionPanel.SetCaptionHeight(const Value: Integer);\r\nbegin\r\n if FCaptionHeight <> Value then\r\n begin\r\n FCaptionHeight := Value;\r\n Invalidate;\r\n ReAlign;\r\n end;\r\nend;\r\n\r\nprocedure TJvCaptionPanel.SetCaption(Value: string);\r\nbegin\r\n FCaption := Value;\r\n inherited Caption := '';\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvCaptionPanel.SetCaptionColor(Value: TColor);\r\nbegin\r\n if FCaptionColor <> Value then\r\n begin\r\n FCaptionColor := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvCaptionPanel.SetFlat(Value: Boolean);\r\nvar\r\n I: TJvCapBtnStyle;\r\nbegin\r\n if FFlat <> Value then\r\n begin\r\n FFlat := Value;\r\n for I := Low(FButtonArray) to High(FButtonArray) do\r\n FButtonArray[I].Flat := FFlat;\r\n end;\r\nend;\r\n\r\nprocedure TJvCaptionPanel.SetButtons(Value: TJvCapBtnStyles);\r\nvar\r\n I: TJvCapBtnStyle;\r\nbegin\r\n if FButtons <> Value then\r\n begin\r\n FButtons := Value;\r\n for I := Low(FButtonArray) to High(FButtonArray) do\r\n FButtonArray[I].Visible := (I in FButtons);\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvCaptionPanel.SetCaptionPosition(Value: TJvDrawPosition);\r\nbegin\r\n if FCaptionPosition <> Value then\r\n begin\r\n FCaptionPosition := Value;\r\n RecreateWnd;\r\n end;\r\nend;\r\n\r\nprocedure TJvCaptionPanel.SetIcon(Value: TIcon);\r\nbegin\r\n FIcon.Assign(Value);\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvCaptionPanel.AlignControls(AControl: TControl; var R: TRect);\r\nbegin\r\n case FCaptionPosition of\r\n dpLeft:\r\n R := Rect(GetEffectiveCaptionHeight + FCaptionOffsetSmall, 0, ClientWidth, ClientHeight);\r\n dpTop:\r\n R := Rect(0, GetEffectiveCaptionHeight + FCaptionOffsetSmall, ClientWidth, ClientHeight);\r\n dpRight:\r\n R := Rect(0, 0, ClientWidth - GetEffectiveCaptionHeight - FCaptionOffsetSmall, ClientHeight);\r\n dpBottom:\r\n R := Rect(0, 0, ClientWidth, ClientHeight - GetEffectiveCaptionHeight - FCaptionOffsetSmall);\r\n end;\r\n inherited AlignControls(AControl, R);\r\nend;\r\n\r\n\r\nprocedure TJvCaptionPanel.CreateParams(var Params: TCreateParams);\r\nbegin\r\n inherited CreateParams(Params);\r\n if BorderStyle = bsSingle then\r\n with Params do\r\n begin\r\n if Resizable then\r\n Style := Style or WS_THICKFRAME\r\n else\r\n Style := Style or WS_DLGFRAME;\r\n ExStyle := ExStyle and not WS_EX_CLIENTEDGE;\r\n end;\r\nend;\r\n\r\n\r\nprocedure TJvCaptionPanel.Paint;\r\nvar\r\n Rotation: Integer;\r\n R: TRect;\r\n FlatOffset: Integer;\r\n AdjustedCaptionHeight: Integer;\r\nbegin\r\n R := ClientRect;\r\n Canvas.Brush.Color := Color;\r\n Canvas.FillRect(R);\r\n Canvas.Brush.Color := FCaptionColor;\r\n FBevel := FCaptionOffsetSmall;\r\n Rotation := 0;\r\n\r\n FlatOffset := Ord(FlatButtons);\r\n\r\n AdjustedCaptionHeight := GetEffectiveCaptionHeight;\r\n if FOutlookLook then\r\n begin\r\n if CaptionPosition = dpLeft then\r\n AdjustedCaptionHeight := AdjustedCaptionHeight - 3 + FlatOffset\r\n else\r\n if CaptionPosition = dpRight then\r\n AdjustedCaptionHeight := AdjustedCaptionHeight - 4 + FlatOffset\r\n else\r\n AdjustedCaptionHeight := AdjustedCaptionHeight - 5 + FlatOffset\r\n end;\r\n\r\n case FCaptionPosition of\r\n dpLeft:\r\n begin\r\n FCaptionRect := Rect(FBevel, FBevel, AdjustedCaptionHeight + FBevel, ClientHeight - FBevel);\r\n Rotation := 90;\r\n end;\r\n dpTop:\r\n FCaptionRect := Rect(FBevel, FBevel, ClientWidth - FBevel, AdjustedCaptionHeight + FBevel);\r\n dpRight:\r\n begin\r\n FCaptionRect := Rect(ClientWidth - AdjustedCaptionHeight - FBevel, FBevel, ClientWidth - FBevel, ClientHeight - FBevel);\r\n Rotation := -90;\r\n end;\r\n dpBottom:\r\n FCaptionRect := Rect(FBevel, ClientHeight - AdjustedCaptionHeight - FBevel, ClientWidth - FBevel, ClientHeight - FBevel);\r\n end; //case\r\n Canvas.FillRect(FCaptionRect);\r\n if not FIcon.Empty then\r\n begin\r\n case FCaptionPosition of\r\n dpRight:\r\n Canvas.Draw((FCaptionRect.Left + FCaptionRect.Right - FIcon.Width) div 2, FCaptionRect.Top + 1, FIcon);\r\n dpLeft:\r\n Canvas.Draw((FCaptionRect.Left + FCaptionRect.Right - FIcon.Width) div 2, FCaptionRect.Bottom - 1 - FIcon.Height, FIcon);\r\n dpBottom, dpTop:\r\n Canvas.Draw(FCaptionRect.Left + 1, (FCaptionRect.Top + FCaptionRect.Bottom - FIcon.Height) div 2 , FIcon);\r\n end;\r\n end;\r\n DrawRotatedText(Rotation);\r\n DrawButtons;\r\nend;\r\n\r\nprocedure TJvCaptionPanel.DrawRotatedText(Rotation: Integer);\r\nvar\r\n tH: Integer;\r\n tW: Integer;\r\n Lf: TLogFont;\r\n Tf: TFont;\r\n Flags: Integer;\r\n R: TRect;\r\nbegin\r\n if FCaption = '' then\r\n Exit;\r\n SetBkMode(Canvas.Handle, TRANSPARENT);\r\n with Canvas do\r\n begin\r\n Tf := TFont.Create;\r\n try\r\n Tf.Assign(CaptionFont);\r\n GetObject(Tf.Handle, SizeOf(Lf), @Lf);\r\n Lf.lfEscapement := Rotation * 10;\r\n Lf.lfOrientation := Rotation * 10;\r\n Lf.lfOutPrecision := OUT_TT_PRECIS;\r\n Tf.Handle := CreateFontIndirect(Lf);\r\n Canvas.Font.Assign(Tf);\r\n finally\r\n Tf.Free;\r\n end;\r\n R := FCaptionRect;\r\n tH := ((R.Bottom - R.Top) - Canvas.TextHeight(FCaption)) div 2;\r\n tW := ((R.Right - R.Left) - Canvas.TextHeight(FCaption)) div 2;\r\n if FOutlookLook then\r\n begin\r\n Dec(tH);\r\n Dec(tW);\r\n end;\r\n case FCaptionPosition of\r\n dpLeft:\r\n begin\r\n if not FIcon.Empty then\r\n Dec(R.Bottom, FIcon.Height + 2);\r\n R := Rect(R.Left, R.Bottom, R.Right, R.Top);\r\n OffsetRect(R, tW, -FOffset);\r\n end;\r\n dpTop, dpBottom:\r\n begin\r\n OffsetRect(R, FOffset, tH);\r\n if not FIcon.Empty then\r\n Inc(R.Left, FIcon.Width + 2);\r\n end;\r\n dpRight:\r\n begin\r\n if not FIcon.Empty then\r\n Inc(R.Top, FIcon.Height + 2);\r\n R := Rect(R.Right, R.Top, R.Left, R.Bottom);\r\n OffsetRect(R, -tW, FOffset);\r\n end;\r\n end;\r\n Flags := DT_NOPREFIX;\r\n if FCaptionPosition in [dpTop, dpBottom] then\r\n Flags := Flags or DT_VCENTER;\r\n if Win32Platform = VER_PLATFORM_WIN32_WINDOWS then\r\n Flags := Flags or DT_NOCLIP; { bug or feature? }\r\n DrawText(Canvas, Caption, -1, R, Flags);\r\n end;\r\nend;\r\n\r\nfunction TJvCaptionPanel.GetEffectiveCaptionHeight: Integer;\r\nbegin\r\n if FCaptionHeight = 0 then\r\n Result := GetSystemMetrics(SM_CYCAPTION)\r\n else\r\n Result := FCaptionHeight;\r\nend;\r\n\r\nprocedure TJvCaptionPanel.DrawButtons;\r\nvar\r\n R: TRect;\r\n FWidth, FHeight: Integer;\r\nbegin\r\n if FButtons = [] then\r\n Exit;\r\n\r\n FWidth := FButtonArray[capClose].Width;\r\n FHeight := FButtonArray[capClose].Height;\r\n if FFlat then\r\n begin\r\n Inc(FWidth);\r\n Inc(FHeight);\r\n end;\r\n\r\n case FCaptionPosition of\r\n dpLeft:\r\n R := Rect(FCaptionRect.Left + FCaptionOffsetSmall, FCaptionRect.Top + FCaptionOffsetSmall, 0, 0);\r\n dpTop:\r\n R := Rect(FCaptionRect.Right - FWidth - FCaptionOffsetSmall, FCaptionRect.Top + FCaptionOffsetLarge, 0, 0);\r\n dpRight:\r\n R := Rect(FCaptionRect.Left + FCaptionOffsetSmall, FCaptionRect.Bottom - FHeight - FCaptionOffsetSmall, 0, 0);\r\n dpBottom:\r\n R := Rect(FCaptionRect.Right - FWidth - FCaptionOffsetSmall, FCaptionRect.Top + FCaptionOffsetLarge, 0, 0);\r\n end;\r\n\r\n if capClose in FButtons then\r\n begin\r\n FButtonArray[capClose].Top := R.Top;\r\n FButtonArray[capClose].Left := R.Left;\r\n FButtonArray[capClose].Visible := True;\r\n case FCaptionPosition of\r\n dpLeft:\r\n OffsetRect(R, 0, FHeight + FCaptionOffsetSmall);\r\n dpTop:\r\n OffsetRect(R, -FWidth - FCaptionOffsetSmall, 0);\r\n dpRight:\r\n OffsetRect(R, 0, -FHeight - FCaptionOffsetSmall);\r\n dpBottom:\r\n OffsetRect(R, -FWidth - FCaptionOffsetSmall, 0);\r\n end;\r\n end\r\n else\r\n FButtonArray[capClose].Visible := False;\r\n\r\n if (capMax in FButtons) then\r\n begin\r\n FButtonArray[capMax].Top := R.Top;\r\n FButtonArray[capMax].Left := R.Left;\r\n FButtonArray[capMax].Visible := True;\r\n case FCaptionPosition of\r\n dpLeft:\r\n OffsetRect(R, 0, FHeight);\r\n dpTop:\r\n OffsetRect(R, -FWidth, 0);\r\n dpRight:\r\n OffsetRect(R, 0, -FHeight);\r\n dpBottom:\r\n OffsetRect(R, -FWidth, 0);\r\n end;\r\n end\r\n else\r\n FButtonArray[capMax].Visible := False;\r\n\r\n if capRestore in FButtons then\r\n begin\r\n FButtonArray[capRestore].Top := R.Top;\r\n FButtonArray[capRestore].Left := R.Left;\r\n FButtonArray[capRestore].Visible := True;\r\n case FCaptionPosition of\r\n dpLeft:\r\n OffsetRect(R, 0, FHeight);\r\n dpTop:\r\n OffsetRect(R, -FWidth, 0);\r\n dpRight:\r\n OffsetRect(R, 0, -FHeight);\r\n dpBottom:\r\n OffsetRect(R, -FWidth, 0);\r\n end;\r\n end\r\n else\r\n FButtonArray[capRestore].Visible := False;\r\n\r\n if capMin in FButtons then\r\n begin\r\n FButtonArray[capMin].Top := R.Top;\r\n FButtonArray[capMin].Left := R.Left;\r\n FButtonArray[capMin].Visible := True;\r\n case FCaptionPosition of\r\n dpLeft:\r\n OffsetRect(R, 0, FHeight);\r\n dpTop:\r\n OffsetRect(R, -FWidth, 0);\r\n dpRight:\r\n OffsetRect(R, 0, -FHeight);\r\n dpBottom:\r\n OffsetRect(R, -FWidth, 0);\r\n end;\r\n end\r\n else\r\n FButtonArray[capMin].Visible := False;\r\n\r\n if capHelp in FButtons then\r\n begin\r\n FButtonArray[capHelp].Top := R.Top;\r\n FButtonArray[capHelp].Left := R.Left;\r\n FButtonArray[capHelp].Visible := True;\r\n end\r\n else\r\n FButtonArray[capHelp].Visible := False;\r\nend;\r\n\r\n{ this method is called only by the caption buttons }\r\n\r\nprocedure TJvCaptionPanel.ClickButton(Button: TJvCapBtnStyle);\r\nbegin\r\n if Assigned(FButtonClick) then\r\n FButtonClick(Self, Button);\r\nend;\r\n\r\nprocedure TJvCaptionPanel.DoLeaveDrag;\r\nbegin\r\n if Assigned(FEndDrag) then\r\n FEndDrag(Self);\r\nend;\r\n\r\nprocedure TJvCaptionPanel.MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);\r\nbegin\r\n inherited MouseUp(Button, Shift, X, Y);\r\n if FDragging then\r\n begin\r\n {$IFDEF JVCAPTIONPANEL_STD_BEHAVE}\r\n ReleaseCapture;\r\n {$ENDIF JVCAPTIONPANEL_STD_BEHAVE}\r\n DoLeaveDrag;\r\n end;\r\n FDragging := False;\r\nend;\r\n\r\nprocedure TJvCaptionPanel.MouseMove(Shift: TShiftState; X, Y: Integer);\r\nbegin\r\n inherited MouseMove(Shift, X, Y);\r\n {$IFDEF JVCAPTIONPANEL_STD_BEHAVE}\r\n if FDragging then\r\n SetBounds(Left + X - FAnchorPos.X, Top + Y - FAnchorPos.Y, Width, Height);\r\n {$ENDIF JVCAPTIONPANEL_STD_BEHAVE}\r\nend;\r\n\r\nprocedure TJvCaptionPanel.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);\r\nbegin\r\n inherited MouseDown(Button, Shift, X, Y);\r\n\r\n FMouseDown := True;\r\n if not PtInRect(FCaptionRect, Point(X, Y)) then\r\n Exit;\r\n\r\n if FAutoDrag and CanStartDrag then\r\n begin\r\n SetZOrder(True);\r\n FDragging := True;\r\n ReleaseCapture;\r\n {$IFDEF JVCAPTIONPANEL_STD_BEHAVE}\r\n SetCapture(Handle);\r\n FAnchorPos := Point(X, Y);\r\n {$ELSE}\r\n Perform(WM_SYSCOMMAND, SC_DRAGMOVE, 0);\r\n {$ENDIF JVCAPTIONPANEL_STD_BEHAVE}\r\n end;\r\nend;\r\n\r\nprocedure TJvCaptionPanel.Resize;\r\nbegin\r\n inherited Resize;\r\n Repaint;\r\nend;\r\n\r\nfunction TJvCaptionPanel.CanStartDrag: Boolean;\r\nbegin\r\n Result := Align = alNone;\r\n if Assigned(FOnStartAutoDrag) then\r\n FOnStartAutoDrag(Self, Result);\r\nend;\r\n\r\n\r\nprocedure TJvCaptionPanel.WMNCLButtonUp(var Msg: TWMNCLButtonUp);\r\nbegin\r\n inherited;\r\n if FDragging then\r\n MouseUp(mbLeft, [], Msg.XCursor, Msg.YCursor);\r\nend;\r\n\r\nprocedure TJvCaptionPanel.SetResizable(const Value: Boolean);\r\nbegin\r\n if FResizable <> Value then\r\n begin\r\n FResizable := Value;\r\n RecreateWnd;\r\n end;\r\nend;\r\n\r\n\r\nprocedure TJvCaptionPanel.SetOutlookLook(const Value: Boolean);\r\nbegin\r\n FOutlookLook := Value;\r\n if FOutlookLook then\r\n begin\r\n FCaptionOffsetSmall := 0;\r\n FCaptionOffsetLarge := 0;\r\n end\r\n else\r\n begin\r\n FCaptionOffsetSmall := 2;\r\n FCaptionOffsetLarge := 3;\r\n end;\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvCaptionPanel.DoCaptionFontChange(Sender: TObject);\r\nbegin\r\n Invalidate;\r\nend;\r\n\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend." }, { "path": "External/Jedi/Jvcl/run/JvCaret.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvCaret.PAS, released on 2003-02-15.\r\n\r\nThe Initial Developer of the Original Code is Joe Doe .\r\nPortions created by Joe Doe are Copyright (C) 1999 Joe Doe.\r\nPortions created by XXXX Corp. are Copyright (C) 1998, 1999 XXXX Corp.\r\nAll Rights Reserved.\r\n\r\nContributor(s): ______________________________________.\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvCaret.pas 12461 2009-08-14 17:21:33Z obones $\r\n\r\nunit JvCaret;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n {$IFDEF MSWINDOWS}\r\n Windows,\r\n {$ENDIF MSWINDOWS}\r\n Classes, Controls, Graphics;\r\n\r\ntype\r\n { A caret can be specified either by giving a bitmap that defines its shape\r\n or by defining the caret width and height. If a bitmap is specified the\r\n other properties are set to 0, if width or height are specified the\r\n bitmap is not used. A change to the caret at runtime will only have an\r\n immediate effect if the control has focus. }\r\n\r\n TJvCaret = class(TPersistent)\r\n private\r\n FCaretBitmap: TBitmap;\r\n FCaretWidth: Integer;\r\n FCaretHeight: Integer;\r\n FGrayCaret: Boolean;\r\n FCaretOwner: TWinControl;\r\n FUpdateCount: Integer;\r\n FModified: Boolean;\r\n FOnChanged: TNotifyEvent;\r\n FCaretCreated: Boolean;\r\n procedure SetCaretBitmap(const Value: TBitmap);\r\n procedure SetCaretHeight(const Value: Integer);\r\n procedure SetCaretWidth(const Value: Integer);\r\n procedure SetGrayCaret(const Value: Boolean);\r\n procedure ReadBitmap(Stream: TStream);\r\n procedure WriteBitmap(Stream: TStream);\r\n protected\r\n procedure Changed; dynamic;\r\n function UsingBitmap: Boolean;\r\n function IsDefaultCaret: Boolean;\r\n procedure DefineProperties(Filer: TFiler); override;\r\n property CaretOwner: TWinControl read FCaretOwner;\r\n property UpdateCount: Integer read FUpdateCount;\r\n public\r\n constructor Create(Owner: TWinControl);\r\n destructor Destroy; override;\r\n procedure CreateCaret;\r\n procedure DestroyCaret;\r\n procedure Assign(Source: TPersistent); override;\r\n procedure BeginUpdate;\r\n procedure EndUpdate;\r\n property CaretCreated: Boolean read FCaretCreated;\r\n property OnChanged: TNotifyEvent read FOnChanged write FOnChanged;\r\n published\r\n { Note: streaming system does not deal properly with a published persistent\r\n property on another nested persistent. We use a pseudoproperty to save the\r\n bitmap. }\r\n property Bitmap: TBitmap read FCaretBitmap write SetCaretBitmap stored False;\r\n property Width: Integer read FCaretWidth write SetCaretWidth default 0;\r\n property Height: Integer read FCaretHeight write SetCaretHeight default 0;\r\n property Gray: Boolean read FGrayCaret write SetGrayCaret default False;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvCaret.pas $';\r\n Revision: '$Revision: 12461 $';\r\n Date: '$Date: 2009-08-14 19:21:33 +0200 (ven. 14 août 2009) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n JvJCLUtils, JvResources, JvTypes;\r\n\r\nconstructor TJvCaret.Create(Owner: TWinControl);\r\nbegin\r\n inherited Create;\r\n if not Assigned(Owner) then\r\n raise EJVCLException.CreateResFmt(@RsEInvalidCaretOwner, [ClassName]);\r\n FCaretOwner := Owner;\r\n FCaretBitmap := TBitmap.Create;\r\nend;\r\n\r\ndestructor TJvCaret.Destroy;\r\nbegin\r\n DestroyCaret;\r\n FCaretBitmap.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvCaret.Assign(Source: TPersistent);\r\nbegin\r\n if Source is TJvCaret then\r\n begin\r\n BeginUpdate;\r\n try\r\n FCaretWidth := TJvCaret(Source).Width;\r\n FCaretHeight := TJvCaret(Source).Height;\r\n FGrayCaret := TJvCaret(Source).Gray;\r\n Bitmap := TJvCaret(Source).Bitmap;\r\n finally\r\n EndUpdate;\r\n end;\r\n end\r\n else\r\n inherited Assign(Source);\r\nend;\r\n\r\nprocedure TJvCaret.BeginUpdate;\r\nbegin\r\n Inc(FUpdateCount);\r\nend;\r\n\r\nprocedure TJvCaret.Changed;\r\nbegin\r\n if FUpdateCount = 0 then\r\n begin\r\n FModified := False;\r\n if Assigned(FOnChanged) then\r\n FOnChanged(Self);\r\n end\r\n else\r\n FModified := True;\r\nend;\r\n\r\nfunction TJvCaret.UsingBitmap: Boolean;\r\nbegin\r\n Result := (Width = 0) and (Height = 0) and not Gray and not Bitmap.Empty;\r\nend;\r\n\r\nfunction TJvCaret.IsDefaultCaret: Boolean;\r\nbegin\r\n Result := (Width = 0) and (Height = 0) and not Gray and Bitmap.Empty;\r\nend;\r\n\r\nprocedure TJvCaret.CreateCaret;\r\nconst\r\n GrayHandles: array [Boolean] of THandle = (0, THandle(1));\r\nbegin\r\n if FCaretOwner.Focused and\r\n not (csDesigning in FCaretOwner.ComponentState) and not IsDefaultCaret then\r\n begin\r\n if UsingBitmap then\r\n OSCheck(Windows.CreateCaret(FCaretOwner.Handle, Bitmap.Handle, 0, 0))\r\n else\r\n { Gray carets seem to be unsupported on Win95 at least, so if the create\r\n failed for the gray caret, try again with a standard black caret }\r\n if not Windows.CreateCaret(FCaretOwner.Handle, GrayHandles[Gray], Width, Height) then\r\n OSCheck(Windows.CreateCaret(FCaretOwner.Handle, 0, Width, Height));\r\n FCaretCreated := True;\r\n ShowCaret(FCaretOwner.Handle);\r\n end;\r\nend;\r\n\r\nprocedure TJvCaret.DestroyCaret;\r\nbegin\r\n if CaretCreated and\r\n FCaretOwner.Focused and\r\n not (csDesigning in FCaretOwner.ComponentState) and\r\n not IsDefaultCaret then\r\n begin\r\n if Windows.DestroyCaret then\r\n FCaretCreated := False;\r\n end;\r\nend;\r\n\r\nprocedure TJvCaret.ReadBitmap(Stream: TStream);\r\nbegin\r\n FCaretBitmap.LoadFromStream(Stream);\r\nend;\r\n\r\nprocedure TJvCaret.WriteBitmap(Stream: TStream);\r\nbegin\r\n FCaretBitmap.SaveToStream(Stream);\r\nend;\r\n\r\nprocedure TJvCaret.DefineProperties(Filer: TFiler);\r\nbegin\r\n Filer.DefineBinaryProperty('CaretBitmap', ReadBitmap,\r\n WriteBitmap, not FCaretBitmap.Empty);\r\nend;\r\n\r\nprocedure TJvCaret.EndUpdate;\r\nbegin\r\n Dec(FUpdateCount);\r\n if (FUpdateCount = 0) and FModified then\r\n Changed;\r\nend;\r\n\r\nprocedure TJvCaret.SetCaretBitmap(const Value: TBitmap);\r\nbegin\r\n FCaretBitmap.Assign(Value);\r\n FCaretWidth := 0;\r\n FCaretHeight := 0;\r\n FGrayCaret := False;\r\n Changed;\r\nend;\r\n\r\nprocedure TJvCaret.SetCaretHeight(const Value: Integer);\r\nbegin\r\n if FCaretHeight <> Value then\r\n begin\r\n FCaretHeight := Value;\r\n Changed;\r\n end;\r\nend;\r\n\r\nprocedure TJvCaret.SetCaretWidth(const Value: Integer);\r\nbegin\r\n if FCaretWidth <> Value then\r\n begin\r\n FCaretWidth := Value;\r\n Changed;\r\n end;\r\nend;\r\n\r\nprocedure TJvCaret.SetGrayCaret(const Value: Boolean);\r\nbegin\r\n if FGrayCaret <> Value then\r\n begin\r\n FGrayCaret := Value;\r\n Changed;\r\n end;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend." }, { "path": "External/Jedi/Jvcl/run/JvChangeNotify.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvChangeNotify.PAS, released on 2002-05-26.\r\n\r\nThe Initial Developer of the Original Code is Peter Thrnqvist [peter3 at sourceforge dot net]\r\nPortions created by Peter Thrnqvist are Copyright (C) 2002 Peter Thrnqvist.\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nDescription:\r\n A wrapper for the Find[First/Next]ChangeNotification API calls.\r\n\r\nChanges:\r\n //dierk schmid 2004-4-28\r\n -- TJvChangeNotify: Put property \"active\" from public to published section\r\n (cause I always forget to set this property in runtime to true)\r\n -- TJvChangeNotify.SetActive: Exit if csDesigning in ComponentState (Active is now published)\r\n -- TJvChangeItem.SetDir: Exception not when csDesigning in ComponentState\r\n (cause, it was impossible to reset in designtime the directory property)\r\n -- Same TJvChangeNotify.CheckActive: Exception not when csDesigning+csloading in ComponentState\r\n -- added procedure TJvChangeNotify.Loaded; override;\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvChangeNotify.pas 13104 2011-09-07 06:50:43Z obones $\r\n\r\nunit JvChangeNotify;\r\n\r\ninterface\r\n\r\n{$I jvcl.inc}\r\n{$I windowsonly.inc}\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, Classes,\r\n JvComponentBase, JvTypes;\r\n\r\ntype\r\n TJvNotifyArray = array [0..MAXIMUM_WAIT_OBJECTS - 1] of THandle;\r\n TJvChangeAction = (caChangeFileName, caChangeDirName, caChangeAttributes, caChangeSize,\r\n caChangeLastWrite, caChangeSecurity);\r\n TJvChangeActions = set of TJvChangeAction;\r\n TJvNotifyEvent = procedure(Sender: TObject; Dir: string; Actions: TJvChangeActions) of object;\r\n TJvThreadNotifyEvent = procedure(Sender: TObject; Index: Integer) of object;\r\n TJvNotifyError = procedure(Sender: TObject; const Msg: string) of object;\r\n\r\n TJvChangeItems = class;\r\n TJvChangeNotify = class;\r\n\r\n // Exception used by NotifyError\r\n EJVCLChangeNotifyException = class(EJVCLException)\r\n private\r\n FErrorDirectory: string;\r\n public\r\n constructor Create(const AErrorMsg, AErrorDirectory: string);\r\n\r\n property ErrorDirectory: string read FErrorDirectory;\r\n end;\r\n\r\n TJvChangeItem = class(TCollectionItem)\r\n private\r\n FParent: TJvChangeItems;\r\n FActions: TJvChangeActions;\r\n FSubTrees: Boolean;\r\n FDir: string;\r\n FOnChange: TNotifyEvent;\r\n procedure SetSubTrees(const Value: Boolean);\r\n procedure SetDir(const Value: string);\r\n protected\r\n function GetDisplayName: string; override;\r\n procedure Change; virtual;\r\n public\r\n constructor Create(Collection: TCollection); override;\r\n procedure Assign(Source: TPersistent); override;\r\n published\r\n property Directory: string read FDir write SetDir;\r\n property Actions: TJvChangeActions read FActions write FActions default [caChangeFileName, caChangeDirName];\r\n property IncludeSubTrees: Boolean read FSubTrees write SetSubTrees default False;\r\n property OnChange: TNotifyEvent read FOnChange write FOnChange;\r\n end;\r\n\r\n TJvChangeItems = class(TCollection)\r\n protected\r\n FOwner: TJvChangeNotify;\r\n function GetItem(Index: Integer): TJvChangeItem;\r\n procedure SetItem(Index: Integer; Value: TJvChangeItem);\r\n function GetOwner: TPersistent; override;\r\n public\r\n constructor Create(AOwner: TJvChangeNotify);\r\n function Add: TJvChangeItem;\r\n procedure Assign(Source: TPersistent); override;\r\n property Items[Index: Integer]: TJvChangeItem read GetItem write SetItem; default;\r\n end;\r\n\r\n { WARNING: Do not call Thread.Terminate from user code. This will leave a\r\n dangling TJvChangeNotify.FThread reference which will cause an access\r\n violation at the next TJvChangeNotify.SetActive call. }\r\n TJvChangeThread = class(TJvCustomThread)\r\n private\r\n FNotifyArray: TJvNotifyArray;\r\n FCount: Integer;\r\n FIndex: Integer;\r\n FInterval: Integer;\r\n FNotify: TJvThreadNotifyEvent;\r\n procedure SynchChange;\r\n protected\r\n procedure Execute; override;\r\n public\r\n constructor Create(NotifyArray: TJvNotifyArray; Count, Interval: Integer; AFreeOnTerminate: Boolean);\r\n property OnChangeNotify: TJvThreadNotifyEvent read FNotify write FNotify;\r\n end;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvChangeNotify = class(TJvComponent)\r\n private\r\n FThread: TJvChangeThread;\r\n FActive: Boolean;\r\n FInterval: Integer;\r\n FCollection: TJvChangeItems;\r\n FNotify: TJvNotifyEvent;\r\n FNotifyArray: TJvNotifyArray;\r\n FFreeOnTerminate: Boolean;\r\n procedure SetCollection(const Value: TJvChangeItems);\r\n procedure SetInterval(const Value: Integer);\r\n procedure SetActive(const Value: Boolean);\r\n procedure CheckActive(const Name: string);\r\n procedure NotifyError(const Msg: string);\r\n procedure DoThreadChangeNotify(Sender: TObject; Index: Integer);\r\n procedure SetFreeOnTerminate(const Value: Boolean);\r\n protected\r\n procedure Change(Item: TJvChangeItem); virtual;\r\n procedure Loaded; override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n published\r\n property Active: Boolean read FActive write SetActive default False;\r\n property Notifications: TJvChangeItems read FCollection write SetCollection;\r\n property CheckInterval: Integer read FInterval write SetInterval default 100;\r\n // Set FreeOnTerminate to True if you want to be able to change the Active property\r\n // in the OnChangeNotify event.\r\n property FreeOnTerminate: Boolean read FFreeOnTerminate write SetFreeOnTerminate default True;\r\n property OnChangeNotify: TJvNotifyEvent read FNotify write FNotify;\r\n end;\r\n\r\nfunction ActionsToString(Actions: TJvChangeActions): string;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvChangeNotify.pas $';\r\n Revision: '$Revision: 13104 $';\r\n Date: '$Date: 2011-09-07 08:50:43 +0200 (mer. 07 sept. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n SysUtils,\r\n JvJCLUtils, JvResources;\r\n // JvJCLUtils for DirectoryExists\r\n\r\nfunction ActionsToString(Actions: TJvChangeActions): string;\r\nconst\r\n ActionStrings: array [TJvChangeAction] of string =\r\n (RsFileNameChange, RsDirectoryNameChange, RsAttributesChange,\r\n RsSizeChange, RsWriteChange, RsSecurityChange);\r\nvar\r\n I: TJvChangeAction;\r\nbegin\r\n Result := '';\r\n for I := Low(TJvChangeAction) to High(TJvChangeAction) do\r\n if I in Actions then\r\n if Result = '' then\r\n Result := ActionStrings[I]\r\n else\r\n Result := Result + ',' + ActionStrings[I];\r\nend;\r\n\r\n//=== { TJvChangeItem } ======================================================\r\n\r\nconstructor TJvChangeItem.Create(Collection: TCollection);\r\nbegin\r\n inherited Create(Collection);\r\n FParent := TJvChangeItems(Collection);\r\n FSubTrees := False;\r\n FActions := [caChangeFileName, caChangeDirName];\r\nend;\r\n\r\nprocedure TJvChangeItem.Assign(Source: TPersistent);\r\nbegin\r\n if Source is TJvChangeItem then\r\n begin\r\n Directory := TJvChangeItem(Source).Directory;\r\n Actions := TJvChangeItem(Source).Actions;\r\n IncludeSubTrees := TJvChangeItem(Source).IncludeSubTrees;\r\n end\r\n else\r\n inherited Assign(Source);\r\nend;\r\n\r\nprocedure TJvChangeItem.SetSubTrees(const Value: Boolean);\r\nbegin\r\n if FSubTrees <> Value then\r\n begin\r\n if csDesigning in FParent.FOwner.ComponentState then\r\n FSubTrees := Value\r\n else\r\n if Value then\r\n FSubTrees := Value and (Win32Platform = VER_PLATFORM_WIN32_NT)\r\n else\r\n FSubTrees := False;\r\n end;\r\nend;\r\n\r\nprocedure TJvChangeItem.SetDir(const Value: string);\r\nbegin\r\n if FDir <> Value then\r\n begin\r\n if not (csDesigning in FParent.FOwner.ComponentState) and\r\n ((Length(Value) = 0) or not DirectoryExists(Value)) then\r\n raise EJVCLException.CreateResFmt(@RsEFmtInvalidPath, [Value]);\r\n FDir := Value;\r\n end;\r\nend;\r\n\r\nfunction TJvChangeItem.GetDisplayName: string;\r\nbegin\r\n if FDir <> '' then\r\n Result := FDir\r\n else\r\n Result := inherited GetDisplayName;\r\nend;\r\n\r\nprocedure TJvChangeItem.Change;\r\nbegin\r\n if Assigned(FOnChange) then\r\n FOnChange(Self);\r\nend;\r\n\r\n//=== { TJvChangeItems } =====================================================\r\n\r\nconstructor TJvChangeItems.Create(AOwner: TJvChangeNotify);\r\nbegin\r\n inherited Create(TJvChangeItem);\r\n FOwner := AOwner;\r\nend;\r\n\r\nfunction TJvChangeItems.Add: TJvChangeItem;\r\nbegin\r\n if Count < MAXIMUM_WAIT_OBJECTS then\r\n Result := TJvChangeItem(inherited Add)\r\n else\r\n raise EJVCLException.CreateResFmt(@RsEFmtMaxCountExceeded, [MAXIMUM_WAIT_OBJECTS]);\r\nend;\r\n\r\nfunction TJvChangeItems.GetItem(Index: Integer): TJvChangeItem;\r\nbegin\r\n Result := TJvChangeItem(inherited GetItem(Index));\r\nend;\r\n\r\nprocedure TJvChangeItems.SetItem(Index: Integer; Value: TJvChangeItem);\r\nbegin\r\n inherited SetItem(Index, Value);\r\nend;\r\n\r\nfunction TJvChangeItems.GetOwner: TPersistent;\r\nbegin\r\n Result := FOwner;\r\nend;\r\n\r\nprocedure TJvChangeItems.Assign(Source: TPersistent);\r\nvar\r\n I: Integer;\r\nbegin\r\n if Source is TJvChangeItems then\r\n begin\r\n Clear;\r\n for I := 0 to TJvChangeItems(Source).Count - 1 do\r\n Add.Assign(TJvChangeItems(Source)[I]);\r\n end\r\n else\r\n inherited Assign(Source);\r\nend;\r\n\r\n//=== { TJvChangeNotify } ====================================================\r\n\r\nconstructor TJvChangeNotify.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FCollection := TJvChangeItems.Create(Self);\r\n FActive := False;\r\n FInterval := 100;\r\n FFreeOnTerminate := True;\r\nend;\r\n\r\ndestructor TJvChangeNotify.Destroy;\r\nbegin\r\n if Assigned(FThread) then\r\n FThread.FreeOnTerminate := False;\r\n FFreeOnTerminate := False; // do not call SetFreeOnTerminate here\r\n Active := False;\r\n FCollection.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvChangeNotify.CheckActive(const Name: string);\r\nbegin\r\n if Active and\r\n not ((csDesigning in ComponentState) or (csLoading in ComponentState)) then //active is now published\r\n raise EJVCLException.CreateResFmt(@RsEFmtCannotChangeName, [Name]);\r\nend;\r\n\r\nprocedure TJvChangeNotify.SetCollection(const Value: TJvChangeItems);\r\nbegin\r\n FCollection.Assign(Value);\r\nend;\r\n\r\nprocedure TJvChangeNotify.Change(Item: TJvChangeItem);\r\nbegin\r\n if Assigned(Item) then\r\n begin\r\n Item.Change;\r\n if Assigned(FNotify) then\r\n FNotify(Self, Item.Directory, Item.Actions);\r\n end;\r\nend;\r\n\r\nprocedure TJvChangeNotify.SetInterval(const Value: Integer);\r\nbegin\r\n CheckActive('Interval');\r\n if Value <= 0 then\r\n Exit;\r\n if FInterval <> Value then\r\n FInterval := Value;\r\nend;\r\n\r\nprocedure TJvChangeNotify.NotifyError(const Msg: string);\r\nvar\r\n ErrorMsg: string;\r\nbegin\r\n SetLength(ErrorMsg, 256);\r\n SetLength(ErrorMsg, FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM, nil,\r\n GetLastError, 0, PChar(ErrorMsg), Length(ErrorMsg), nil));\r\n raise EJVCLChangeNotifyException.Create(ErrorMsg, Msg);\r\nend;\r\n\r\nprocedure TJvChangeNotify.DoThreadChangeNotify(Sender: TObject; Index: Integer);\r\nbegin\r\n Change(Notifications[Index]);\r\nend;\r\n\r\nprocedure TJvChangeNotify.SetActive(const Value: Boolean);\r\nconst\r\n cActions: array [TJvChangeAction] of Cardinal =\r\n (FILE_NOTIFY_CHANGE_FILE_NAME, FILE_NOTIFY_CHANGE_DIR_NAME,\r\n FILE_NOTIFY_CHANGE_ATTRIBUTES, FILE_NOTIFY_CHANGE_SIZE,\r\n FILE_NOTIFY_CHANGE_LAST_WRITE, FILE_NOTIFY_CHANGE_SECURITY);\r\nvar\r\n cA: TJvChangeAction;\r\n Flags: Cardinal;\r\n I: Integer;\r\n J: Integer;\r\n S: string;\r\nbegin\r\n if FActive <> Value then\r\n begin\r\n FActive := Value;\r\n if csDesigning in ComponentState then\r\n Exit; //active is now published\r\n\r\n if FActive then\r\n begin\r\n if FCollection.Count > MAXIMUM_WAIT_OBJECTS then\r\n raise EJVCLException.CreateResFmt(@RsEFmtMaxCountExceeded,[MAXIMUM_WAIT_OBJECTS]);\r\n FillChar(FNotifyArray, SizeOf(TJvNotifyArray), INVALID_HANDLE_VALUE);\r\n for I := 0 to FCollection.Count - 1 do\r\n begin\r\n Flags := 0;\r\n { convert TJvChangeActions to bitfields }\r\n for cA := Low(TJvChangeAction) to High(TJvChangeAction) do\r\n if cA in FCollection[I].Actions then\r\n Flags := Flags or (cActions[cA]);\r\n S := FCollection[I].Directory;\r\n if (S = '') or not DirectoryExists(S) then\r\n raise EJVCLException.CreateResFmt(@RsEFmtInvalidPathAtIndex, [S, I]);\r\n FNotifyArray[I] := FindFirstChangeNotification(\r\n PChar(S),\r\n BOOL(FCollection[I].IncludeSubTrees), Flags);\r\n if FNotifyArray[I] = INVALID_HANDLE_VALUE then\r\n begin\r\n // Clean up before raising the exception\r\n for J := 0 to I - 1 do\r\n begin\r\n FindCloseChangeNotification(FNotifyArray[J]);\r\n FNotifyArray[J] := INVALID_HANDLE_VALUE;\r\n end;\r\n FActive := False;\r\n // Now raise the exception\r\n NotifyError(FCollection[I].Directory);\r\n end;\r\n end;\r\n if FThread <> nil then\r\n begin\r\n FThread.OnChangeNotify := nil;\r\n FThread.Terminate;\r\n if FThread.Suspended then\r\n FThread.{$IFDEF COMPILER14_UP}Start{$ELSE}Resume{$ENDIF COMPILER14_UP};\r\n if FreeOnTerminate then\r\n FThread := nil\r\n else\r\n begin\r\n FThread.WaitFor;\r\n FreeAndNil(FThread);\r\n end;\r\n end;\r\n FThread := TJvChangeThread.Create(FNotifyArray, FCollection.Count, FInterval, FFreeOnTerminate);\r\n FThread.OnChangeNotify := DoThreadChangeNotify;\r\n FThread.{$IFDEF COMPILER14_UP}Start{$ELSE}Resume{$ENDIF COMPILER14_UP};\r\n end\r\n else\r\n if FThread <> nil then\r\n begin\r\n FThread.OnChangeNotify := nil;\r\n FThread.Terminate;\r\n if FThread.Suspended then\r\n FThread.{$IFDEF COMPILER14_UP}Start{$ELSE}Resume{$ENDIF COMPILER14_UP};\r\n if FreeOnTerminate then\r\n FThread := nil\r\n else\r\n begin\r\n FThread.WaitFor;\r\n FreeAndNil(FThread);\r\n end;\r\n end;\r\n\r\n {\r\n while FActive do\r\n begin\r\n I := WaitForMultipleObjects(FCollection.Count, @FNotifyArray, False, FInterval);\r\n if (I >= 0) and (I < FCollection.Count) then\r\n begin\r\n try\r\n Change(FCollection.Items[I]);\r\n finally\r\n Assert(FindNextChangeNotification(FNotifyArray[I]));\r\n end;\r\n end\r\n else\r\n Application.ProcessMessages;\r\n end;\r\n for I := 0 to FCollection.Count - 1 do // Iterate\r\n FindCloseChangeNotification(FNotifyArray[I]);\r\n }\r\n end;\r\nend;\r\n\r\nprocedure TJvChangeNotify.Loaded;\r\nbegin\r\n inherited Loaded;\r\n if FActive then\r\n begin\r\n FActive := False;\r\n SetActive(True);\r\n end;\r\nend;\r\n\r\nprocedure TJvChangeNotify.SetFreeOnTerminate(const Value: Boolean);\r\nvar\r\n State: Boolean;\r\nbegin\r\n if csLoading in ComponentState then\r\n FFreeOnTerminate := Value\r\n else\r\n begin\r\n State := Active;\r\n try\r\n Active := False;\r\n FFreeOnTerminate := Value;\r\n finally\r\n Active := State;\r\n end;\r\n end;\r\nend;\r\n\r\n//=== { TJvChangeThread } ====================================================\r\n\r\nconstructor TJvChangeThread.Create(NotifyArray: TJvNotifyArray; Count, Interval: Integer; AFreeOnTerminate:Boolean);\r\nvar\r\n I: Integer;\r\nbegin\r\n inherited Create(True);\r\n FCount := Count;\r\n FInterval := Interval;\r\n FillChar(FNotifyArray, SizeOf(TJvNotifyArray), INVALID_HANDLE_VALUE);\r\n for I := 0 to FCount - 1 do\r\n FNotifyArray[I] := NotifyArray[I];\r\n FreeOnTerminate := AFreeOnTerminate;\r\nend;\r\n\r\nprocedure TJvChangeThread.Execute;\r\nvar\r\n I: Integer;\r\nbegin\r\n NameThread(ThreadName);\r\n // (rom) secure thread against exceptions (Delphi 5 needs it)\r\n try\r\n while not Terminated do\r\n begin\r\n I := WaitForMultipleObjects(FCount,\r\n @FNotifyArray[0],\r\n False, FInterval);\r\n if (I >= 0) and (I < FCount) and not Terminated then\r\n begin\r\n try\r\n FIndex := I;\r\n Synchronize(SynchChange);\r\n finally\r\n // (rom) raising an exception in a thread is not a good idea\r\n // (rom) Assert removed\r\n //Assert(FindNextChangeNotification(FNotifyArray[I]));\r\n FindNextChangeNotification(FNotifyArray[I]);\r\n end;\r\n end;\r\n end;\r\n if Terminated then\r\n for I := 0 to FCount - 1 do\r\n if FNotifyArray[I] <> INVALID_HANDLE_VALUE then\r\n begin\r\n FindCloseChangeNotification(FNotifyArray[I]);\r\n FNotifyArray[I] := INVALID_HANDLE_VALUE;\r\n end;\r\n except\r\n end;\r\nend;\r\n\r\nprocedure TJvChangeThread.SynchChange;\r\nbegin\r\n if Assigned(FNotify) then\r\n FNotify(Self, FIndex);\r\nend;\r\n\r\n{ EJVCLChangeNotifyException }\r\n\r\nconstructor EJVCLChangeNotifyException.Create(const AErrorMsg, AErrorDirectory: string);\r\nbegin\r\n // Note: CreateFmt is a class method and not a constructor in Delphi.NET }\r\n inherited Create(Format(RsENotifyErrorFmt, [AErrorMsg, AErrorDirectory]));\r\n FErrorDirectory := ErrorDirectory;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\n\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvCharMap.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvCharMap.PAS, released on 2003-11-03.\r\n\r\nThe Initial Developer of the Original Code is Peter Thornqvist \r\nPortions created by Peter Thornqvist are Copyright (c) 2003 Peter Thornqvist\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n* CharRange.Filter only works with contiguous ranges, so ufPrivateUse and ufSpecials\r\n only shows the first subrange\r\n\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvCharMap.pas 13145 2011-11-02 21:15:19Z ahuser $\r\n\r\nunit JvCharMap;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, Messages,\r\n Types, Classes, Graphics, Controls, Grids,\r\n JvComponent, JvExControls, JvExGrids;\r\n\r\ntype\r\n TJvCharMapValidateEvent = procedure(Sender: TObject; AChar: WideChar;\r\n var Valid: Boolean) of object;\r\n TJvCharMapSelectedEvent = procedure(Sender: TObject;\r\n AChar: WideChar) of object;\r\n TJvCharMapUnicodeFilter =\r\n (\r\n ufUndefined,\r\n ufBasicLatin,\r\n ufLatin1Supplement,\r\n ufLatinExtendedA,\r\n ufLatinExtendedB,\r\n ufIPAExtensions,\r\n ufSpacingModifierLetters,\r\n ufCombiningDiacriticalMarks,\r\n ufGreek,\r\n ufCyrillic,\r\n ufArmenian,\r\n ufHebrew,\r\n ufArabic,\r\n ufSyriac,\r\n ufThaana,\r\n ufDevanagari,\r\n ufBengali,\r\n ufGurmukhi,\r\n ufGujarati,\r\n ufOriya,\r\n ufTamil,\r\n ufTelugu,\r\n ufKannada,\r\n ufMalayalam,\r\n ufSinhala,\r\n ufThai,\r\n ufLao,\r\n ufTibetan,\r\n ufMyanmar,\r\n ufGeorgian,\r\n ufHangulJamo,\r\n ufEthiopic,\r\n ufCherokee,\r\n ufUnifiedCanadianAboriginalSyllabics,\r\n ufOgham,\r\n ufRunic,\r\n ufKhmer,\r\n ufMongolian,\r\n ufLatinExtendedAdditional,\r\n ufGreekExtended,\r\n ufGeneralPunctuation,\r\n ufSuperscriptsAndSubscripts,\r\n ufCurrencySymbols,\r\n ufCombiningMarksForSymbols,\r\n ufLetterlikeSymbols,\r\n ufNumberForms,\r\n ufArrows,\r\n ufMathematicalOperators,\r\n ufMiscellaneousTechnical,\r\n ufControlPictures,\r\n ufOpticalCharacterRecognition,\r\n ufEnclosedAlphanumerics,\r\n ufBoxDrawing,\r\n ufBlockElements,\r\n ufGeometricShapes,\r\n ufMiscellaneousSymbols,\r\n ufDingbats,\r\n ufBraillePatterns,\r\n ufCJKRadicalsSupplement,\r\n ufKangxiRadicals,\r\n ufIdeographicDescriptionCharacters,\r\n ufCJKSymbolsAndPunctuation,\r\n ufHiragana,\r\n ufKatakana,\r\n ufBopomofo,\r\n ufHangulCompatibilityJamo,\r\n ufKanbun,\r\n ufBopomofoExtended,\r\n ufEnclosedCJKLettersAndMonths,\r\n ufCJKCompatibility,\r\n ufCJKUnifiedIdeographsExtensionA,\r\n ufCJKUnifiedIdeographs,\r\n ufYiSyllables,\r\n ufYiRadicals,\r\n ufHangulSyllables,\r\n ufHighSurrogates,\r\n ufHighPrivateUseSurrogates,\r\n ufLowSurrogates,\r\n ufPrivateUse,\r\n ufCJKCompatibilityIdeographs,\r\n ufAlphabeticPresentationForms,\r\n ufArabicPresentationFormsA,\r\n ufCombiningHalfMarks,\r\n ufCJKCompatibilityForms,\r\n ufSmallFormVariants,\r\n ufArabicPresentationFormsB,\r\n ufSpecials,\r\n ufHalfwidthAndFullwidthForms,\r\n ufOldItalic,\r\n ufGothic,\r\n ufDeseret,\r\n ufByzantineMusicalSymbols,\r\n ufMusicalSymbols,\r\n ufMathematicalAlphanumericSymbols,\r\n ufCJKUnifiedIdeographsExtensionB,\r\n ufCJKCompatibilityIdeographsSupplement,\r\n ufTags\r\n );\r\n\r\n TJvCharMapRange = class(TPersistent)\r\n private\r\n FFilterStart: Cardinal;\r\n FFilterEnd: Cardinal;\r\n FStartChar: Cardinal;\r\n FEndChar: Cardinal;\r\n FOnChange: TNotifyEvent;\r\n FFilter: TJvCharMapUnicodeFilter;\r\n procedure SetFilter(const Value: TJvCharMapUnicodeFilter);\r\n procedure SetEndChar(const Value: Cardinal);\r\n procedure SetStartChar(const Value: Cardinal);\r\n procedure Change;\r\n procedure SetRange(AStart, AEnd: Cardinal);\r\n function GetEndChar: Cardinal;\r\n function GetStartChar: Cardinal;\r\n public\r\n constructor Create;\r\n published\r\n // Setting Filter to ufUndefined, resets StartChar and EndChar to their previous values\r\n property Filter: TJvCharMapUnicodeFilter read FFilter write SetFilter default ufUndefined;\r\n property StartChar: Cardinal read GetStartChar write SetStartChar default 33;\r\n property EndChar: Cardinal read GetEndChar write SetEndChar default 255;\r\n property OnChange: TNotifyEvent read FOnChange write FOnChange;\r\n end;\r\n\r\n TJvCustomCharMap = class(TJvExCustomDrawGrid)\r\n private\r\n FCharPanel: TCustomControl;\r\n FShowZoomPanel: Boolean;\r\n FMouseIsDown: Boolean;\r\n FCharRange: TJvCharMapRange;\r\n FAutoSizeHeight: Boolean;\r\n FAutoSizeWidth: Boolean;\r\n FDrawing: Boolean;\r\n FLocale: LCID;\r\n FOnValidateChar: TJvCharMapValidateEvent;\r\n FShowShadow: Boolean;\r\n FShadowSize: Integer;\r\n FOnSelectChar: TJvCharMapSelectedEvent;\r\n FHighlightInvalid: Boolean;\r\n procedure SetCharRange(const Value: TJvCharMapRange);\r\n procedure SetPanelVisible(Value: Boolean);\r\n function GetCharacter: WideChar;\r\n function GetColumns: Integer;\r\n procedure SetColumns(Value: Integer);\r\n procedure SetShowZoomPanel(Value: Boolean);\r\n function GetPanelVisible: Boolean;\r\n procedure SetAutoSizeHeight(Value: Boolean);\r\n procedure SetAutoSizeWidth(Value: Boolean);\r\n procedure SetLocale(const Value: LCID);\r\n procedure SetShowShadow(Value: Boolean);\r\n procedure SetShadowSize(Value: Integer);\r\n procedure SetHighlightInvalid(Value: Boolean);\r\n protected\r\n // The locale to use when looking up character info and translating codepages to Unicode.\r\n // Only effective on non-NT OS's (NT doesn't use codepages)\r\n property Locale: LCID read FLocale write SetLocale default LOCALE_USER_DEFAULT;\r\n // The currently selected character\r\n property Character: WideChar read GetCharacter;\r\n // Shows/Hides the zoom panel\r\n property PanelVisible: Boolean read GetPanelVisible write SetPanelVisible stored False;\r\n // Determines whether the zoom panel is automatically shown when the user clicks a cell in the grid\r\n // To actually show the zoom panel, set PanelVisible := True at run-time (or click a cell in the grid)\r\n property ShowZoomPanel: Boolean read FShowZoomPanel write SetShowZoomPanel default True;\r\n\r\n // Determines whether the zoom panel has a shadow or not\r\n property ShowShadow: Boolean read FShowShadow write SetShowShadow default True;\r\n // Determines the number of pixels the shadow is offset from the zoom panel.\r\n // On W2k/XP and with D6+, the shadow is alpha blended (semi-transparent)\r\n property ShadowSize: Integer read FShadowSize write SetShadowSize default 2;\r\n\r\n // The range of characters to dispay in the grid\r\n property CharRange: TJvCharMapRange read FCharRange write SetCharRange;\r\n // Determines whether the width of the grid is auto adjusted to it' s content\r\n property AutoSizeWidth: Boolean read FAutoSizeWidth write SetAutoSizeWidth default False;\r\n // Determines whether the height of the grid is auto adjusted to it' s content\r\n property AutoSizeHeight: Boolean read FAutoSizeHeight write SetAutoSizeHeight default False;\r\n // The number of columns in the grid. Rows are adjusted automatically. Min. value is 1\r\n property Columns: Integer read GetColumns write SetColumns default 20;\r\n property HighlightInvalid: Boolean read FHighlightInvalid write SetHighlightInvalid default True;\r\n // Event that is called every time the grid needs to check if a character is valid.\r\n // If the character is invalid, it won't be drawn\r\n property OnValidateChar: TJvCharMapValidateEvent read FOnValidateChar write FOnValidateChar;\r\n // Event that is called every time the selection has changed\r\n property OnSelectChar: TJvCharMapSelectedEvent read FOnSelectChar write FOnSelectChar;\r\n protected\r\n procedure ShowCharPanel(ACol, ARow: Integer); virtual;\r\n procedure RecalcCells; virtual;\r\n procedure AdjustSize; reintroduce;\r\n procedure CreateHandle; override;\r\n procedure DrawCell(ACol, ARow: Integer; ARect: TRect; AState: TGridDrawState); override;\r\n procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;\r\n procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;\r\n procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;\r\n\r\n procedure KeyDown(var Key: Word; Shift: TShiftState); override;\r\n function DoMouseWheelDown(Shift: TShiftState; MousePos: TPoint): Boolean; override;\r\n function DoMouseWheelUp(Shift: TShiftState; MousePos: TPoint): Boolean; override;\r\n function InCharRange(AChar: WideChar): Boolean; virtual;\r\n function InGridRange(ACol, ARow: Integer): Boolean; virtual;\r\n function SelectCell(ACol, ARow: Longint): Boolean; override;\r\n\r\n function GetChar(ACol, ARow: Integer): WideChar; virtual;\r\n function GetCharInfo(ACol, ARow: Integer; InfoType: Cardinal): Cardinal; overload; virtual;\r\n function GetCharInfo(AChar: WideChar; InfoType: Cardinal): Cardinal; overload; virtual;\r\n function IsValidChar(AChar: WideChar): Boolean; virtual;\r\n procedure WMVScroll(var Msg: TWMVScroll); message WM_VSCROLL;\r\n procedure WMHScroll(var Msg: TWMHScroll); message WM_HSCROLL;\r\n\r\n procedure FontChanged; override;\r\n procedure DoRangeChange(Sender: TObject);\r\n procedure DoSelectChar(AChar: WideChar); virtual;\r\n function DoEraseBackground(Canvas: TCanvas; Param: LPARAM): Boolean; override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n function CellSize: TSize;\r\n procedure SetBounds(ALeft, ATop, AWidth, AHeight: Integer); override;\r\n end;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvCharMap = class(TJvCustomCharMap)\r\n public\r\n property Character;\r\n property PanelVisible;\r\n property Locale;\r\n published\r\n property AutoSizeWidth;\r\n property AutoSizeHeight;\r\n property CharRange;\r\n property Col;\r\n property Columns;\r\n property HighlightInvalid;\r\n property Row;\r\n property ShowZoomPanel;\r\n property ShowShadow;\r\n property ShadowSize;\r\n\r\n property Align;\r\n property Anchors;\r\n property BiDiMode;\r\n property DragCursor;\r\n property DragKind;\r\n property DragMode;\r\n property ParentBiDiMode;\r\n property OnEndDock;\r\n property OnStartDock;\r\n property BorderStyle;\r\n property DoubleBuffered default True;\r\n property Color;\r\n property Constraints;\r\n property Enabled;\r\n property Font;\r\n property ParentColor;\r\n property ParentFont;\r\n property ParentShowHint;\r\n property PopupMenu;\r\n property ScrollBars;\r\n property ShowHint;\r\n property TabOrder;\r\n property Visible;\r\n\r\n property OnValidateChar;\r\n property OnSelectChar;\r\n\r\n property OnClick;\r\n property OnContextPopup;\r\n property OnDblClick;\r\n property OnDragDrop;\r\n property OnDragOver;\r\n property OnTopLeftChanged;\r\n property OnEndDrag;\r\n property OnEnter;\r\n property OnExit;\r\n property OnKeyDown;\r\n property OnKeyPress;\r\n property OnKeyUp;\r\n property OnMouseDown;\r\n property OnMouseMove;\r\n property OnMouseUp;\r\n property OnMouseWheel;\r\n property OnMouseWheelDown;\r\n property OnMouseWheelUp;\r\n property OnStartDrag;\r\n property OnResize;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvCharMap.pas $';\r\n Revision: '$Revision: 13145 $';\r\n Date: '$Date: 2011-11-02 22:15:19 +0100 (mer. 02 nov. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n SysUtils, Forms,\r\n JvConsts;\r\n\r\nconst\r\n cShadowAlpha = 100;\r\n\r\ntype\r\n TCanvasAccess = class(TCanvas);\r\n\r\n TShadowWindow = class(TJvCustomControl)\r\n private\r\n procedure WMNCHitTest(var Msg: TWMNCHitTest); message WM_NCHITTEST;\r\n protected\r\n procedure CreateParams(var Params: TCreateParams); override;\r\n procedure CreateHandle; override;\r\n procedure VisibleChanged; override;\r\n public\r\n property Visible default False;\r\n property Color default clBlack;\r\n constructor Create(AOwner: TComponent); override;\r\n end;\r\n \r\n TCharZoomPanel = class(TJvCustomControl)\r\n private\r\n FShadow: TShadowWindow;\r\n FCharacter: WideChar;\r\n FEndChar: Cardinal;\r\n FOldWndProc: TWndMethod;\r\n FWasVisible: Boolean;\r\n FShowShadow: Boolean;\r\n FShadowSize: Integer;\r\n procedure SetCharacter(const Value: WideChar);\r\n procedure FormWindowProc(var Msg: TMessage);\r\n procedure HookWndProc;\r\n procedure UnhookWndProc;\r\n procedure UpdateShadow;\r\n procedure SetShowShadow(const Value: Boolean);\r\n procedure SetShadowSize(const Value: Integer);\r\n protected\r\n procedure Paint; override;\r\n procedure KeyDown(var Key: Word; Shift: TShiftState); override;\r\n procedure CreateParams(var Params: TCreateParams); override;\r\n procedure WMNCHitTest(var Msg: TWMNCHitTest); message WM_NCHITTEST;\r\n procedure FocusSet(PrevWnd: THandle); override;\r\n procedure GetDlgCode(var Code: TDlgCodes); override;\r\n procedure VisibleChanged; override;\r\n procedure FontChanged; override;\r\n\r\n procedure CreateHandle; override;\r\n procedure WMWindowPosChanged(var Msg: TWMWindowPosChanged); message WM_WINDOWPOSCHANGED;\r\n procedure SetParent( AParent: TWinControl); override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n property Character: WideChar read FCharacter write SetCharacter;\r\n property ShowShadow: Boolean read FShowShadow write SetShowShadow default True;\r\n property ShadowSize: Integer read FShadowSize write SetShadowSize;\r\n end;\r\n\r\nprocedure WideDrawText(Canvas: TCanvas; const Text: WideString; ARect: TRect; uFormat: Cardinal);\r\nbegin\r\n with TCanvasAccess(Canvas) do\r\n begin\r\n Changing;\r\n RequiredState([csHandleValid, csFontValid, csBrushValid]);\r\n if CanvasOrientation = coRightToLeft then\r\n Inc(uFormat, DT_RTLREADING);\r\n DrawTextW(Handle, PWideChar(Text), Length(Text), ARect, uFormat);\r\n Changed;\r\n end;\r\nend;\r\n\r\n//=== { TShadowWindow } ======================================================\r\n\r\ntype\r\n TDynamicSetLayeredWindowAttributes = function(HWnd: THandle; crKey: COLORREF;\r\n bAlpha: Byte; dwFlags: DWORD): Boolean; stdcall;\r\n\r\nconstructor TShadowWindow.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n ControlStyle := [csFixedHeight, csFixedWidth, csNoDesignVisible, csNoStdEvents];\r\n Color := clBlack;\r\n Visible := False;\r\nend;\r\n\r\nprocedure TShadowWindow.CreateHandle;\r\nvar\r\n DynamicSetLayeredWindowAttributes: TDynamicSetLayeredWindowAttributes;\r\n\r\n procedure InitProcs;\r\n const\r\n sUser32 = 'User32.dll';\r\n var\r\n ModH: HMODULE;\r\n begin\r\n ModH := GetModuleHandle(sUser32);\r\n if ModH <> 0 then\r\n DynamicSetLayeredWindowAttributes := GetProcAddress(ModH, 'SetLayeredWindowAttributes')\r\n else\r\n DynamicSetLayeredWindowAttributes := nil;\r\n end;\r\n\r\nbegin\r\n inherited CreateHandle;\r\nend;\r\n\r\nprocedure TShadowWindow.CreateParams(var Params: TCreateParams);\r\nbegin\r\n inherited CreateParams(Params);\r\n with Params do\r\n begin\r\n Style := WS_POPUP;\r\n ExStyle := WS_EX_TOOLWINDOW;\r\n end;\r\nend;\r\n\r\nprocedure TShadowWindow.WMNCHitTest(var Msg: TWMNCHitTest);\r\nbegin\r\n Msg.Result := HTTRANSPARENT;\r\nend;\r\n\r\nprocedure TShadowWindow.VisibleChanged;\r\nbegin\r\n inherited VisibleChanged;\r\n // make sure shadow is beneath zoom panel\r\n if Visible and (Parent <> nil) then\r\n SetWindowPos(Handle, TWinControl(Owner).Handle, 0, 0, 0, 0,\r\n SWP_NOACTIVATE or SWP_NOMOVE or SWP_NOSIZE or SWP_NOOWNERZORDER);\r\nend;\r\n\r\n//=== { TJvCustomCharMap } ===================================================\r\n\r\nconstructor TJvCustomCharMap.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n DoubleBuffered := True;\r\n // DefaultDrawing := False;\r\n // VirtualView := True;\r\n\r\n FCharRange := TJvCharMapRange.Create;\r\n // FCharRange.Filter := ufUndefined;\r\n // FCharRange.SetRange($21, $FF);\r\n FCharRange.OnChange := DoRangeChange;\r\n FCharPanel := TCharZoomPanel.Create(Self);\r\n FCharPanel.Visible := False;\r\n FCharPanel.Parent := Self;\r\n\r\n Options := [goVertLine, goHorzLine, {goDrawFocusSelected, } goThumbTracking];\r\n FShowZoomPanel := True;\r\n DefaultRowHeight := Abs(Font.Height) + 12;\r\n DefaultColWidth := DefaultRowHeight - 5;\r\n FLocale := LOCALE_USER_DEFAULT;\r\n FShowShadow := True;\r\n FShadowSize := 2;\r\n FHighlightInvalid := True;\r\n Columns := 20;\r\nend;\r\n\r\ndestructor TJvCustomCharMap.Destroy;\r\nbegin\r\n FCharRange.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvCustomCharMap.AdjustSize;\r\nvar\r\n AWidth, AHeight: Integer;\r\nbegin\r\n if HandleAllocated and (ColCount > 0) and (RowCount > 0) then\r\n begin\r\n AWidth := DefaultColWidth * (ColCount) + ColCount;\r\n AHeight := DefaultRowHeight * (RowCount) + RowCount;\r\n if AutoSizeWidth and (ClientWidth <> AWidth) and\r\n (Align in [alNone, alLeft, alRight]) then\r\n ClientWidth := AWidth;\r\n if AutoSizeHeight and (ClientHeight <> AHeight) and\r\n (Align in [alNone, alTop, alBottom]) then\r\n ClientHeight := AHeight;\r\n end;\r\nend;\r\n\r\nfunction TJvCustomCharMap.CellSize: TSize;\r\nbegin\r\n Result.cx := DefaultColWidth;\r\n Result.cy := DefaultRowHeight;\r\nend;\r\n\r\nprocedure TJvCustomCharMap.FontChanged;\r\nbegin\r\n inherited FontChanged;\r\n if AutoSize then\r\n AdjustSize;\r\n RecalcCells;\r\nend;\r\n\r\nprocedure TJvCustomCharMap.CreateHandle;\r\nbegin\r\n inherited CreateHandle;\r\n RecalcCells;\r\nend;\r\n\r\nfunction TJvCustomCharMap.DoMouseWheelDown(Shift: TShiftState; MousePos: TPoint): Boolean;\r\nbegin\r\n // ignore the return value, because inherited always returns True\r\n inherited DoMouseWheelDown(Shift, MousePos);\r\n Result := PanelVisible and SelectCell(Col, Row);\r\n if Result then\r\n ShowCharPanel(Col, Row);\r\n Result := True;\r\nend;\r\n\r\nfunction TJvCustomCharMap.DoMouseWheelUp(Shift: TShiftState; MousePos: TPoint): Boolean;\r\nbegin\r\n // ignore the return value, because inherited always returns True\r\n inherited DoMouseWheelUp(Shift, MousePos);\r\n Result := PanelVisible and SelectCell(Col, Row);\r\n if Result then\r\n ShowCharPanel(Col, Row);\r\n Result := True;\r\nend;\r\n\r\nprocedure TJvCustomCharMap.DoRangeChange(Sender: TObject);\r\nbegin\r\n TCharZoomPanel(FCharPanel).FEndChar := CharRange.EndChar;\r\n RecalcCells;\r\nend;\r\n\r\nprocedure TJvCustomCharMap.DoSelectChar(AChar: WideChar);\r\nbegin\r\n if Assigned(FOnSelectChar) then\r\n FOnSelectChar(Self, AChar);\r\nend;\r\n\r\nprocedure TJvCustomCharMap.DrawCell(ACol, ARow: Integer; ARect: TRect;\r\n AState: TGridDrawState);\r\nvar\r\n AChar: WideChar;\r\n LineColor: TColor;\r\nbegin\r\n if FDrawing then\r\n Exit;\r\n FDrawing := True;\r\n try\r\n inherited DrawCell(ACol, ARow, ARect, AState);\r\n AChar := GetChar(ACol, ARow);\r\n Canvas.Brush.Color := Color;\r\n Canvas.Font := Font;\r\n Canvas.Pen.Color := Font.Color;\r\n if SelectCell(ACol, ARow) and IsValidChar(AChar) then\r\n begin\r\n if AState * [gdSelected, gdFocused] <> [] then\r\n begin\r\n Canvas.Pen.Color := Font.Color;\r\n if not ShowZoomPanel then\r\n begin\r\n Canvas.Brush.Color := clHighlight;\r\n Canvas.FillRect(ARect);\r\n end;\r\n InflateRect(ARect, -1, -1);\r\n Canvas.Rectangle(ARect);\r\n InflateRect(ARect, 1, 1);\r\n end\r\n else\r\n Canvas.FillRect(ARect);\r\n if not ShowZoomPanel and (AState * [gdSelected, gdFocused] <> []) then\r\n Canvas.Font.Color := clHighlightText;\r\n SetBkMode(Canvas.Handle, Windows.TRANSPARENT);\r\n WideDrawText(Canvas, AChar, ARect,\r\n DT_SINGLELINE or DT_CENTER or DT_VCENTER or DT_NOPREFIX);\r\n end\r\n else\r\n if HighlightInvalid then\r\n begin\r\n LineColor := clSilver;\r\n if ColorToRGB(Color) = clSilver then\r\n LineColor := clGray;\r\n Canvas.Pen.Color := Color;\r\n Canvas.Brush.Color := LineColor;\r\n Canvas.Brush.Style := bsBDiagonal;\r\n // InflateRect(ARect,1,1);\r\n Canvas.Rectangle(ARect);\r\n Canvas.Brush.Style := bsSolid;\r\n end;\r\n finally\r\n FDrawing := False;\r\n end;\r\nend;\r\n\r\nfunction TJvCustomCharMap.GetChar(ACol, ARow: Integer): WideChar;\r\nbegin\r\n if (ARow < 0) or (ACol < 0) then\r\n Result := WideChar(0)\r\n else\r\n Result := WideChar(CharRange.StartChar +\r\n Cardinal(ARow) * Cardinal(ColCount) + Cardinal(ACol));\r\nend;\r\n\r\nfunction TJvCustomCharMap.GetCharacter: WideChar;\r\nbegin\r\n Result := GetChar(Col, Row);\r\nend;\r\n\r\nfunction TJvCustomCharMap.GetCharInfo(ACol, ARow: Integer;\r\n InfoType: Cardinal): Cardinal;\r\nbegin\r\n Result := GetCharInfo(GetChar(ACol, ARow), InfoType);\r\nend;\r\n\r\nfunction TJvCustomCharMap.GetCharInfo(AChar: WideChar; InfoType: Cardinal): Cardinal;\r\nvar\r\n LLoc: Cardinal;\r\n LCharInfo: Cardinal;\r\nbegin\r\n if Win32Platform = VER_PLATFORM_WIN32_NT then\r\n LLoc := 0\r\n else\r\n LLoc := Locale;\r\n\r\n // Locale is ignored on NT platforms\r\n if GetStringTypeExW(LLoc, InfoType, @AChar, 1, LCharInfo) then\r\n begin\r\n Result := LCharInfo;\r\n end\r\n else\r\n Result := 0;\r\nend;\r\n\r\nfunction TJvCustomCharMap.GetColumns: Integer;\r\nbegin\r\n Result := ColCount;\r\nend;\r\n\r\nfunction TJvCustomCharMap.GetPanelVisible: Boolean;\r\nbegin\r\n if (FCharPanel <> nil) and (Parent <> nil) and\r\n not (csDesigning in ComponentState) then\r\n Result := FCharPanel.Visible\r\n else\r\n Result := False;\r\nend;\r\n\r\nfunction TJvCustomCharMap.IsValidChar(AChar: WideChar): Boolean;\r\nvar\r\n LCharInfo: Cardinal;\r\nbegin\r\n Result := False;\r\n if (AChar >= WideChar(CharRange.StartChar)) and\r\n (AChar <= WideChar(CharRange.EndChar)) then\r\n begin\r\n LCharInfo := GetCharInfo(AChar, CT_CTYPE1);\r\n Result := (LCharInfo <> 0); // and (LCharInfo and C1_CNTRL <> C1_CNTRL);\r\n end;\r\n\r\n if Assigned(FOnValidateChar) then\r\n FOnValidateChar(Self, AChar, Result);\r\nend;\r\n\r\nprocedure TJvCustomCharMap.KeyDown(var Key: Word; Shift: TShiftState);\r\nvar\r\n ACol, ARow: Integer;\r\nbegin\r\n // store previous location\r\n ACol := Col;\r\n ARow := Row;\r\n // update new location\r\n inherited KeyDown(Key, Shift);\r\n // (rom) only accept without Shift, Alt or Ctrl down\r\n if Shift * KeyboardShiftStates = [] then\r\n case Key of\r\n VK_RETURN:\r\n ShowCharPanel(Col, Row);\r\n VK_SPACE:\r\n PanelVisible := not PanelVisible;\r\n VK_ESCAPE:\r\n PanelVisible := False;\r\n VK_UP, VK_DOWN, VK_PRIOR, VK_NEXT, VK_HOME, VK_END:\r\n if PanelVisible then\r\n ShowCharPanel(Col, Row);\r\n VK_LEFT:\r\n begin\r\n if (ACol = 0) and (ARow > 0) then\r\n begin\r\n ACol := ColCount - 1;\r\n Dec(ARow);\r\n end\r\n else\r\n begin\r\n ACol := Col;\r\n ARow := Row;\r\n end;\r\n Col := ACol;\r\n Row := ARow;\r\n if PanelVisible then\r\n ShowCharPanel(ACol, ARow);\r\n end;\r\n VK_RIGHT:\r\n begin\r\n if (ACol = ColCount - 1) and (ARow < RowCount - 1) then\r\n begin\r\n ACol := 0;\r\n Inc(ARow);\r\n end\r\n else\r\n begin\r\n ACol := Col;\r\n ARow := Row;\r\n end;\r\n Col := ACol;\r\n Row := ARow;\r\n if PanelVisible then\r\n ShowCharPanel(ACol, ARow);\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomCharMap.MouseDown(Button: TMouseButton; Shift: TShiftState;\r\n X, Y: Integer);\r\nvar\r\n GC: TGridCoord;\r\n ACol, ARow: Integer;\r\nbegin\r\n inherited MouseDown(Button, Shift, X, Y);\r\n // MouseCapture := True;\r\n if Button = mbLeft then\r\n begin\r\n FMouseIsDown := True;\r\n GC := MouseCoord(X, Y);\r\n MouseToCell(X, Y, ACol, ARow);\r\n if SelectCell(ACol, ARow) then\r\n ShowCharPanel(ACol, ARow)\r\n else\r\n if SelectCell(Col, Row) then\r\n ShowCharPanel(Col, Row);\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomCharMap.MouseMove(Shift: TShiftState; X, Y: Integer);\r\n//var\r\n// ACol, ARow: Integer;\r\nbegin\r\n inherited MouseMove(Shift, X, Y);\r\n { if csLButtonDown in ControlState then\r\n begin\r\n MouseToCell(X, Y, ACol, ARow);\r\n if SelectCell(ACol, ARow) then\r\n ShowCharPanel(ACol, ARow);\r\n end;}\r\nend;\r\n\r\nprocedure TJvCustomCharMap.MouseUp(Button: TMouseButton; Shift: TShiftState;\r\n X, Y: Integer);\r\nvar\r\n ACol, ARow: Integer;\r\nbegin\r\n inherited MouseUp(Button, Shift, X, Y);\r\n if (Button = mbLeft) and FMouseIsDown then\r\n begin\r\n FMouseIsDown := False;\r\n MouseToCell(X, Y, ACol, ARow);\r\n if SelectCell(ACol, ARow) then\r\n ShowCharPanel(ACol, ARow)\r\n else\r\n if SelectCell(Col, Row) then\r\n ShowCharPanel(Col, Row);\r\n end;\r\nend;\r\n\r\nfunction TJvCustomCharMap.InCharRange(AChar: WideChar): Boolean;\r\nbegin\r\n Result := (AChar >= WideChar(CharRange.StartChar)) and (AChar <= WideChar(CharRange.EndChar));\r\nend;\r\n\r\nfunction TJvCustomCharMap.InGridRange(ACol, ARow: Integer): Boolean;\r\nbegin\r\n Result := (ACol >= 0) and (ARow >= 0) and (ACol < ColCount) and (ARow < RowCount);\r\nend;\r\n\r\nprocedure TJvCustomCharMap.RecalcCells;\r\nvar\r\n ACells, ARows: Integer;\r\nbegin\r\n if not HandleAllocated then\r\n Exit;\r\n FixedCols := 0;\r\n FixedRows := 0;\r\n ACells := Ord(CharRange.EndChar) - Ord(CharRange.StartChar);\r\n // ColCount := 20;\r\n ARows := ACells div ColCount + 1;\r\n RowCount := ARows;\r\n DefaultRowHeight := Abs(Font.Height) + 12;\r\n DefaultColWidth := DefaultRowHeight - 5;\r\n if AutoSizeWidth or AutoSizeHeight then\r\n AdjustSize;\r\n if PanelVisible then\r\n ShowCharPanel(Col, Row);\r\nend;\r\n\r\nfunction TJvCustomCharMap.SelectCell(ACol, ARow: Integer): Boolean;\r\nvar\r\n AChar, ANewChar: WideChar;\r\nbegin\r\n // get currently selected character\r\n AChar := GetChar(Col, Row);\r\n // can't use IsValidChar here since we need to be able to select invalid cells as well to be able to scroll\r\n ANewChar := WideChar(CharRange.StartChar + Cardinal(ARow) * Cardinal(ColCount) + Cardinal(ACol));\r\n Result := InGridRange(ACol,ARow) and InCharRange(ANewChar);\r\n\r\n if Result and not FDrawing then\r\n begin\r\n ANewChar := GetChar(ACol, ARow);\r\n if AChar <> ANewChar then\r\n DoSelectChar(ANewChar);\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomCharMap.SetAutoSizeHeight(Value: Boolean);\r\nbegin\r\n if FAutoSizeHeight <> Value then\r\n begin\r\n FAutoSizeHeight := Value;\r\n if FAutoSizeHeight then\r\n AdjustSize;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomCharMap.SetAutoSizeWidth(Value: Boolean);\r\nbegin\r\n if FAutoSizeWidth <> Value then\r\n begin\r\n FAutoSizeWidth := Value;\r\n if FAutoSizeWidth then\r\n AdjustSize;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomCharMap.SetBounds(ALeft, ATop, AWidth, AHeight: Integer);\r\nbegin\r\n inherited SetBounds(ALeft, ATop, AWidth, AHeight);\r\n RecalcCells;\r\n if HandleAllocated and PanelVisible and ((ClientHeight < DefaultRowHeight) or\r\n (ClientWidth < DefaultColWidth)) then\r\n PanelVisible := False;\r\nend;\r\n\r\nprocedure TJvCustomCharMap.SetCharRange(const Value: TJvCharMapRange);\r\nbegin\r\n // FCharRange := Value;\r\nend;\r\n\r\nprocedure TJvCustomCharMap.SetColumns(Value: Integer);\r\nvar\r\n CurCell: Integer;\r\nbegin\r\n if Value > 0 then\r\n begin\r\n // make sure the previous select character is also the new selected\r\n CurCell := Row * ColCount + Col;\r\n ColCount := Value;\r\n // Assert(ColCount > 0);\r\n Col := CurCell mod ColCount;\r\n Row := CurCell div ColCount;\r\n RecalcCells;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomCharMap.SetHighlightInvalid(Value: Boolean);\r\nbegin\r\n if FHighlightInvalid <> Value then\r\n begin\r\n FHighlightInvalid := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomCharMap.SetLocale(const Value: LCID);\r\nbegin\r\n if (FLocale <> Value) and IsValidLocale(Value, LCID_SUPPORTED) then\r\n begin\r\n FLocale := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomCharMap.SetPanelVisible(Value: Boolean);\r\nbegin\r\n if (PanelVisible <> Value) and not (csDesigning in ComponentState) then\r\n FCharPanel.Visible := Value;\r\nend;\r\n\r\nprocedure TJvCustomCharMap.SetShadowSize(Value: Integer);\r\nbegin\r\n if FShadowSize <> Value then\r\n begin\r\n FShadowSize := Value;\r\n if FCharPanel <> nil then\r\n TCharZoomPanel(FCharPanel).ShadowSize := Value;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomCharMap.SetShowShadow(Value: Boolean);\r\nbegin\r\n if FShowShadow <> Value then\r\n begin\r\n FShowShadow := Value;\r\n if FCharPanel <> nil then\r\n TCharZoomPanel(FCharPanel).ShowShadow := Value;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomCharMap.SetShowZoomPanel(Value: Boolean);\r\nbegin\r\n if FShowZoomPanel <> Value then\r\n begin\r\n FShowZoomPanel := Value;\r\n if not FShowZoomPanel then\r\n PanelVisible := False;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomCharMap.ShowCharPanel(ACol, ARow: Integer);\r\nvar\r\n R: TRect;\r\n P: TPoint;\r\nbegin\r\n if not ShowZoomPanel or not SelectCell(ACol, ARow) then\r\n begin\r\n PanelVisible := False;\r\n Exit;\r\n end;\r\n R := CellRect(ACol, ARow);\r\n Selection := TGridRect(Rect(ACol, ARow, ACol, ARow));\r\n FocusCell(ACol, ARow, False);\r\n TCharZoomPanel(FCharPanel).Character := GetChar(ACol, ARow);\r\n P.X := R.Left - (FCharPanel.Width - DefaultColWidth) div 2;\r\n P.Y := R.Top - (FCharPanel.Height - DefaultRowHeight) div 2;\r\n P := ClientToScreen(P);\r\n\r\n FCharPanel.Left := P.X;\r\n FCharPanel.Top := P.Y;\r\n if not PanelVisible then\r\n PanelVisible := True;\r\nend;\r\n\r\nfunction TJvCustomCharMap.DoEraseBackground(Canvas: TCanvas; Param: LPARAM): Boolean;\r\nbegin\r\n Result := True;\r\nend;\r\n\r\nprocedure TJvCustomCharMap.WMHScroll(var Msg: TWMHScroll);\r\nbegin\r\n inherited;\r\n if PanelVisible then\r\n begin\r\n if Col < LeftCol then\r\n ShowCharPanel(LeftCol, Row)\r\n else\r\n if Col >= LeftCol + VisibleColCount then\r\n ShowCharPanel(LeftCol + VisibleColCount - 1, Row)\r\n else\r\n ShowCharPanel(Col, Row);\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomCharMap.WMVScroll(var Msg: TWMVScroll);\r\nbegin\r\n inherited;\r\n if PanelVisible then\r\n begin\r\n if Row < TopRow then\r\n ShowCharPanel(Col, TopRow)\r\n else\r\n if Row >= TopRow + VisibleRowCount then\r\n ShowCharPanel(Col, TopRow + VisibleRowCount - 1)\r\n else\r\n ShowCharPanel(Col, Row);\r\n end;\r\nend;\r\n\r\n//=== { TCharZoomPanel } =====================================================\r\n\r\nconstructor TCharZoomPanel.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n ControlStyle := ControlStyle + [csNoDesignVisible, csOpaque];\r\n SetBounds(0, 0, 52, 48);\r\n FShadow := TShadowWindow.Create(AOwner);\r\n ShowShadow := True;\r\n FShadowSize := 2;\r\nend;\r\n\r\ndestructor TCharZoomPanel.Destroy;\r\nbegin\r\n UnhookWndProc;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TCharZoomPanel.FontChanged;\r\nbegin\r\n inherited FontChanged;\r\n // (p3) height should be quite larger than Font.Height and Width a little more than that\r\n Height := Abs(Font.Height) * 4;\r\n Width := MulDiv(Height, 110, 100);\r\nend;\r\n\r\nprocedure TCharZoomPanel.VisibleChanged;\r\nbegin\r\n inherited VisibleChanged;\r\n if Visible and CanFocus then\r\n SetFocus;\r\n if ShowShadow then\r\n FShadow.Visible := Visible\r\n else\r\n FShadow.Visible := False;\r\nend;\r\n\r\nprocedure TCharZoomPanel.CreateParams(var Params: TCreateParams);\r\nbegin\r\n inherited CreateParams(Params);\r\n with Params do\r\n begin\r\n Style := WS_BORDER or WS_POPUP;\r\n ExStyle := WS_EX_TOOLWINDOW;\r\n end;\r\nend;\r\n\r\nprocedure TCharZoomPanel.HookWndProc;\r\nvar\r\n F: TCustomForm;\r\nbegin\r\n if not (csDesigning in ComponentState) and not Assigned(FOldWndProc) then\r\n begin\r\n F := GetParentForm(Self);\r\n if F <> nil then\r\n begin\r\n FOldWndProc := F.WindowProc;\r\n F.WindowProc := FormWindowProc;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TCharZoomPanel.KeyDown(var Key: Word; Shift: TShiftState);\r\nbegin\r\n // (rom) only accept without Shift, Alt or Ctrl down\r\n if Shift * KeyboardShiftStates = [] then\r\n case Key of\r\n VK_ESCAPE:\r\n begin\r\n Visible := False;\r\n if Parent.CanFocus then\r\n Parent.SetFocus;\r\n end;\r\n VK_LEFT, VK_RIGHT, VK_UP, VK_DOWN:\r\n TJvCustomCharMap(Parent).KeyDown(Key, Shift);\r\n else\r\n inherited KeyDown(Key, Shift);\r\n end\r\n else\r\n inherited KeyDown(Key, Shift);\r\nend;\r\n\r\nprocedure TCharZoomPanel.FormWindowProc(var Msg: TMessage);\r\nbegin\r\n FOldWndProc(Msg);\r\n if not (csDestroying in ComponentState) then\r\n begin\r\n case Msg.Msg of\r\n WM_MOVE:\r\n if Visible or FWasVisible then\r\n with TJvCharMap(Parent) do\r\n ShowCharPanel(Col, Row);\r\n WM_SYSCOMMAND:\r\n case Msg.WParam and $FFF0 of\r\n SC_MINIMIZE:\r\n begin\r\n FWasVisible := Visible;\r\n Visible := False;\r\n end;\r\n SC_RESTORE, SC_MAXIMIZE:\r\n if (Visible or FWasVisible) and\r\n IsWindowVisible(GetParentForm(Self).Handle) then\r\n with TJvCharMap(Parent) do\r\n ShowCharPanel(Col, Row);\r\n end;\r\n WM_WINDOWPOSCHANGED:\r\n if (Visible or FWasVisible) and\r\n IsWindowVisible(GetParentForm(Self).Handle) then\r\n with TJvCharMap(Parent) do\r\n ShowCharPanel(Col, Row);\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TCharZoomPanel.Paint;\r\nvar\r\n R: TRect;\r\n AChar: WideChar;\r\nbegin\r\n // inherited Paint;\r\n Canvas.Font := Font;\r\n Canvas.Font.Height := ClientHeight - 4;\r\n // Canvas.Font.Style := [fsBold];\r\n Canvas.Brush.Color := Color;\r\n Canvas.Pen.Color := Font.Color;\r\n R := ClientRect;\r\n Canvas.Rectangle(R);\r\n\r\n // R := Rect(0,0,Width,Height);\r\n SetBkMode(Canvas.Handle, Windows.TRANSPARENT);\r\n AChar := Character;\r\n if TJvCustomCharMap(Parent).IsValidChar(AChar) then\r\n WideDrawText(Canvas, AChar, R,\r\n DT_SINGLELINE or DT_CENTER or DT_VCENTER or DT_NOPREFIX);\r\nend;\r\n\r\nprocedure TCharZoomPanel.SetCharacter(const Value: WideChar);\r\nbegin\r\n if FCharacter <> Value then\r\n begin\r\n FCharacter := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TCharZoomPanel.UnhookWndProc;\r\nvar\r\n F: TCustomForm;\r\nbegin\r\n if not (csDesigning in ComponentState) and Assigned(FOldWndProc) then\r\n begin\r\n F := GetParentForm(Self);\r\n if F <> nil then\r\n F.WindowProc := FOldWndProc;\r\n end;\r\nend;\r\n\r\nprocedure TCharZoomPanel.GetDlgCode(var Code: TDlgCodes);\r\nbegin\r\n Code := [dcWantArrows];\r\nend;\r\n\r\nprocedure TCharZoomPanel.WMNCHitTest(var Msg: TWMNCHitTest);\r\nbegin\r\n // pass mouse clicks to parent (the grid)\r\n Msg.Result := HTTRANSPARENT;\r\nend;\r\n\r\nprocedure TCharZoomPanel.FocusSet(PrevWnd: THandle);\r\nbegin\r\n inherited FocusSet(PrevWnd);\r\n if not (csDestroying in ComponentState) and Parent.CanFocus then\r\n Parent.SetFocus;\r\nend;\r\n\r\nprocedure TCharZoomPanel.CreateHandle;\r\nbegin\r\n inherited CreateHandle;\r\n HookWndProc;\r\nend;\r\n\r\nprocedure TCharZoomPanel.WMWindowPosChanged(var Msg: TWMWindowPosChanged);\r\nbegin\r\n inherited;\r\n UpdateShadow;\r\nend;\r\n\r\nprocedure TCharZoomPanel.SetParent( AParent: TWinControl);\r\nbegin\r\n inherited SetParent(AParent);\r\n if not (csDestroying in ComponentState) then\r\n begin\r\n if FShadow <> nil then\r\n FShadow.Parent := AParent;\r\n UpdateShadow;\r\n end;\r\nend;\r\n\r\nprocedure TCharZoomPanel.SetShowShadow(const Value: Boolean);\r\nbegin\r\n if FShowShadow <> Value then\r\n begin\r\n FShowShadow := Value;\r\n UpdateShadow;\r\n end;\r\nend;\r\n\r\nprocedure TCharZoomPanel.UpdateShadow;\r\nvar\r\n R: TRect;\r\nbegin\r\n if HandleAllocated and (FShadow <> nil) and (FShadow.Parent <> nil) then\r\n begin\r\n if ShowShadow then\r\n begin\r\n R := BoundsRect;\r\n OffsetRect(R, ShadowSize, ShadowSize);\r\n FShadow.BoundsRect := R;\r\n FShadow.Visible := Visible;\r\n end\r\n else\r\n FShadow.Visible := False;\r\n end;\r\nend;\r\n\r\nprocedure TCharZoomPanel.SetShadowSize(const Value: Integer);\r\nbegin\r\n if FShadowSize <> Value then\r\n begin\r\n FShadowSize := Value;\r\n UpdateShadow;\r\n end;\r\nend;\r\n\r\n//=== { TJvCharMapRange } ====================================================\r\n\r\nconstructor TJvCharMapRange.Create;\r\nbegin\r\n inherited Create;\r\n FFilter := ufUndefined;\r\n FStartChar := 33;\r\n FEndChar := 255;\r\nend;\r\n\r\nprocedure TJvCharMapRange.Change;\r\nbegin\r\n if Assigned(FOnChange) then\r\n FOnChange(Self);\r\nend;\r\n\r\nfunction TJvCharMapRange.GetEndChar: Cardinal;\r\nbegin\r\n if Filter = ufUndefined then\r\n Result := FEndChar\r\n else\r\n Result := FFilterEnd;\r\nend;\r\n\r\nfunction TJvCharMapRange.GetStartChar: Cardinal;\r\nbegin\r\n if Filter = ufUndefined then\r\n Result := FStartChar\r\n else\r\n Result := FFilterStart;\r\nend;\r\n\r\nprocedure TJvCharMapRange.SetEndChar(const Value: Cardinal);\r\nbegin\r\n if FEndChar <> Value then\r\n begin\r\n FEndChar := Value;\r\n if Filter = ufUndefined then\r\n Change;\r\n end;\r\nend;\r\n\r\nprocedure TJvCharMapRange.SetFilter(const Value: TJvCharMapUnicodeFilter);\r\nbegin\r\n if FFilter <> Value then\r\n begin\r\n FFilter := Value;\r\n case Value of\r\n ufBasicLatin:\r\n SetRange($0000, $007F);\r\n ufLatin1Supplement:\r\n SetRange($0080, $00FF);\r\n ufLatinExtendedA:\r\n SetRange($0100, $017F);\r\n ufLatinExtendedB:\r\n SetRange($0180, $024F);\r\n ufIPAExtensions:\r\n SetRange($0250, $02AF);\r\n ufSpacingModifierLetters:\r\n SetRange($02B0, $02FF);\r\n ufCombiningDiacriticalMarks:\r\n SetRange($0300, $036F);\r\n ufGreek:\r\n SetRange($0370, $03FF);\r\n ufCyrillic:\r\n SetRange($0400, $04FF);\r\n ufArmenian:\r\n SetRange($0530, $058F);\r\n ufHebrew:\r\n SetRange($0590, $05FF);\r\n ufArabic:\r\n SetRange($0600, $06FF);\r\n ufSyriac:\r\n SetRange($0700, $074F);\r\n ufThaana:\r\n SetRange($0780, $07BF);\r\n ufDevanagari:\r\n SetRange($0900, $097F);\r\n ufBengali:\r\n SetRange($0980, $09FF);\r\n ufGurmukhi:\r\n SetRange($0A00, $0A7F);\r\n ufGujarati:\r\n SetRange($0A80, $0AFF);\r\n ufOriya:\r\n SetRange($0B00, $0B7F);\r\n ufTamil:\r\n SetRange($0B80, $0BFF);\r\n ufTelugu:\r\n SetRange($0C00, $0C7F);\r\n ufKannada:\r\n SetRange($0C80, $0CFF);\r\n ufMalayalam:\r\n SetRange($0D00, $0D7F);\r\n ufSinhala:\r\n SetRange($0D80, $0DFF);\r\n ufThai:\r\n SetRange($0E00, $0E7F);\r\n ufLao:\r\n SetRange($0E80, $0EFF);\r\n ufTibetan:\r\n SetRange($0F00, $0FFF);\r\n ufMyanmar:\r\n SetRange($1000, $109F);\r\n ufGeorgian:\r\n SetRange($10A0, $10FF);\r\n ufHangulJamo:\r\n SetRange($1100, $11FF);\r\n ufEthiopic:\r\n SetRange($1200, $137F);\r\n ufCherokee:\r\n SetRange($13A0, $13FF);\r\n ufUnifiedCanadianAboriginalSyllabics:\r\n SetRange($1400, $167F);\r\n ufOgham:\r\n SetRange($1680, $169F);\r\n ufRunic:\r\n SetRange($16A0, $16FF);\r\n ufKhmer:\r\n SetRange($1780, $17FF);\r\n ufMongolian:\r\n SetRange($1800, $18AF);\r\n ufLatinExtendedAdditional:\r\n SetRange($1E00, $1EFF);\r\n ufGreekExtended:\r\n SetRange($1F00, $1FFF);\r\n ufGeneralPunctuation:\r\n SetRange($2000, $206F);\r\n ufSuperscriptsAndSubscripts:\r\n SetRange($2070, $209F);\r\n ufCurrencySymbols:\r\n SetRange($20A0, $20CF);\r\n ufCombiningMarksForSymbols:\r\n SetRange($20D0, $20FF);\r\n ufLetterlikeSymbols:\r\n SetRange($2100, $214F);\r\n ufNumberForms:\r\n SetRange($2150, $218F);\r\n ufArrows:\r\n SetRange($2190, $21FF);\r\n ufMathematicalOperators:\r\n SetRange($2200, $22FF);\r\n ufMiscellaneousTechnical:\r\n SetRange($2300, $23FF);\r\n ufControlPictures:\r\n SetRange($2400, $243F);\r\n ufOpticalCharacterRecognition:\r\n SetRange($2440, $245F);\r\n ufEnclosedAlphanumerics:\r\n SetRange($2460, $24FF);\r\n ufBoxDrawing:\r\n SetRange($2500, $257F);\r\n ufBlockElements:\r\n SetRange($2580, $259F);\r\n ufGeometricShapes:\r\n SetRange($25A0, $25FF);\r\n ufMiscellaneousSymbols:\r\n SetRange($2600, $26FF);\r\n ufDingbats:\r\n SetRange($2700, $27BF);\r\n ufBraillePatterns:\r\n SetRange($2800, $28FF);\r\n ufCJKRadicalsSupplement:\r\n SetRange($2E80, $2EFF);\r\n ufKangxiRadicals:\r\n SetRange($2F00, $2FDF);\r\n ufIdeographicDescriptionCharacters:\r\n SetRange($2FF0, $2FFF);\r\n ufCJKSymbolsAndPunctuation:\r\n SetRange($3000, $303F);\r\n ufHiragana:\r\n SetRange($3040, $309F);\r\n ufKatakana:\r\n SetRange($30A0, $30FF);\r\n ufBopomofo:\r\n SetRange($3100, $312F);\r\n ufHangulCompatibilityJamo:\r\n SetRange($3130, $318F);\r\n ufKanbun:\r\n SetRange($3190, $319F);\r\n ufBopomofoExtended:\r\n SetRange($31A0, $31BF);\r\n ufEnclosedCJKLettersAndMonths:\r\n SetRange($3200, $32FF);\r\n ufCJKCompatibility:\r\n SetRange($3300, $33FF);\r\n ufCJKUnifiedIdeographsExtensionA:\r\n SetRange($3400, $4DB5);\r\n ufCJKUnifiedIdeographs:\r\n SetRange($4E00, $9FFF);\r\n ufYiSyllables:\r\n SetRange($A000, $A48F);\r\n ufYiRadicals:\r\n SetRange($A490, $A4CF);\r\n ufHangulSyllables:\r\n SetRange($AC00, $D7A3);\r\n ufHighSurrogates:\r\n SetRange($D800, $DB7F);\r\n ufHighPrivateUseSurrogates:\r\n SetRange($DB80, $DBFF);\r\n ufLowSurrogates:\r\n SetRange($DC00, $DFFF);\r\n ufPrivateUse:\r\n SetRange($E000, $F8FF);\r\n // $E000..$F8FF, $F0000..$FFFFD, $100000..$10FFFD;\r\n ufCJKCompatibilityIdeographs:\r\n SetRange($F900, $FAFF);\r\n ufAlphabeticPresentationForms:\r\n SetRange($FB00, $FB4F);\r\n ufArabicPresentationFormsA:\r\n SetRange($FB50, $FDFF);\r\n ufCombiningHalfMarks:\r\n SetRange($FE20, $FE2F);\r\n ufCJKCompatibilityForms:\r\n SetRange($FE30, $FE4F);\r\n ufSmallFormVariants:\r\n SetRange($FE50, $FE6F);\r\n ufArabicPresentationFormsB:\r\n SetRange($FE70, $FEFE);\r\n ufSpecials:\r\n // $FEFF..$FEFF, $FFF0..$FFFD;\r\n SetRange($FFF0, $FFFD);\r\n ufHalfwidthAndFullwidthForms:\r\n SetRange($FF00, $FFEF);\r\n ufOldItalic:\r\n SetRange($10300, $1032F);\r\n ufGothic:\r\n SetRange($10330, $1034F);\r\n ufDeseret:\r\n SetRange($10400, $1044F);\r\n ufByzantineMusicalSymbols:\r\n SetRange($1D000, $1D0FF);\r\n ufMusicalSymbols:\r\n SetRange($1D100, $1D1FF);\r\n ufMathematicalAlphanumericSymbols:\r\n SetRange($1D400, $1D7FF);\r\n ufCJKUnifiedIdeographsExtensionB:\r\n SetRange($20000, $2A6D6);\r\n ufCJKCompatibilityIdeographsSupplement:\r\n SetRange($2F800, $2FA1F);\r\n ufTags:\r\n SetRange($E0000, $E007F);\r\n else\r\n SetRange(StartChar, EndChar);\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvCharMapRange.SetRange(AStart, AEnd: Cardinal);\r\nbegin\r\n FFilterStart := AStart;\r\n FFilterEnd := AEnd;\r\n Change;\r\nend;\r\n\r\nprocedure TJvCharMapRange.SetStartChar(const Value: Cardinal);\r\nbegin\r\n if FStartChar <> Value then\r\n begin\r\n FStartChar := Value;\r\n if Filter = ufUndefined then\r\n Change;\r\n end;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvChart.pas", "content": "{-----------------------------------------------------------------------------\r\nJvChart - TJvChart Component - 2009 Public\r\n\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvChart.PAS, released on 2003-09-30.\r\n\r\nThe Initial Developers of the Original Code are\r\n Warren Postma (TJvChart which was originally based on TAABGraph)\r\n Mrten Henrichson (TAABGraph)\r\n\r\nContributor(s):\r\n Warren Postma (warrenpstma att hotmail dott com)\r\n Mrten Henrichson/AABSoft (no email known)\r\n\r\n Contains some code which is\r\n (C) 1996-1998 AABsoft and Mrten Henrichson\r\n\r\n The rest is\r\n (C) 2003-2009 Warren Postma\r\n warren.postma att sympatico dott ca\r\n warrenpstma att hotmail dott com\r\n\r\nLast Modified:\r\n\r\n 2003-09-30 - (WP) - Alpha-Initial checkin of new component, into JVCL3 CVS tree.\r\n 2004-02-26 - (WP) - Pre-JVCL3.0-Has been substantially jedified, also new\r\n properties/events, and some renaming has occurred. See\r\n cvs logs. NEW: OnChartClick event.\r\n RENAME: Options.ThickLineWidth -> Options.PenLineWidth\r\n RENAME: Values -> ValueIndex\r\n 2004-04-10 - (WP) - Much improved Charting! Beta-Quality in most places.\r\n Significant property reorganization and renaming.\r\n Primary and Secondary Y (vertical) Axis support.\r\n 2004-07-06 - (WP)- Added events OnYAxisClick (Left margin click),\r\n OnXAxisClick (Bottom margin), OnAltYAxisClick (Right margin)\r\n and OnTitleClick (Top Margin).\r\n\r\n 2005-01-14 - (WP) - Floating Chart Markers added. Major changes to painting\r\n code to allow canvas as a parameter. This is in preparation\r\n for fixing up the printing code to allow printing to work\r\n once again, and because the floating objects require us to\r\n draw the chart into a bitmap, and then decorate the bitmap\r\n dynamically with the floating objects, different\r\n canvases are used to paint the bitmap, and to paint the\r\n floating layer on top, thus the need for the changes.\r\n\r\n 2005-04-15 - (WP) - Changed internal Data storage from Array of Array to\r\n simple single-dimension array. This has many benefits,\r\n and at least one drawback. The benefit is that much\r\n larger sets of pens/data values can be accomodated.\r\n The drawback is that you can't add a pen to an already displayed\r\n chart without regenerating all the data points in it.\r\n If you change the pen count you now MUST clear the data,\r\n and re-plot the chart. Any attempt to add a pen,\r\n write the new pen, and then plot without rewriting the other\r\n values will cause data to be displayed in a corrupt fashion.\r\n I think this obscure limitation is better to live with than\r\n the many alternatives. The problem I have is that the chart\r\n supports extremely large data sets, and clearing the data\r\n MULTIPLE times would be a huge performance penalty in\r\n any application. You can enable the OLD mode, with it's\r\n limitations, by defining TJVCHART_ARRAY_OF_ARRAY.\r\n\r\n 2007-04-26 - (WP) - Merged upstream changes.\r\n - Added gradients (TJvChartGradientBar)\r\n - Added new way of doing date/time markers (Options.XAxisDateTimeMode),\r\n GraphXAxisLegend, and JvChart.Data properties StartDateTime, EndDateTime.\r\n - Added vertical markers (AddVerticalBar)\r\n - Added horizontal bars (TJvChartHorizontalBar) ClearHorizontalBars\r\n - Added FloatingMarkerCount.\r\n - New property in jvfloatingMarker: CaptionColor\r\n - Added DeleteFloatingMarkerObj\r\n - Graphical glitches/chart-display-bug-fixes.\r\n 2007-04-27 - (WP) - Fixes\r\n - Calls only JclMath.IsNaN, not Math.IsNaN, which doesn't\r\n exist on older Delphi/BCB versions.\r\n - Added CopyFloatingMarkers (thought I did that yesterday but missed it)\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvChart.pas 13216 2012-02-24 10:09:08Z obones $\r\n\r\nunit JvChart;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, Messages, Classes,\r\n Types, Graphics, Controls, Contnrs,\r\n JvComponent;\r\n\r\nconst\r\n JvChartVersion = 300; // ie, version 3.00\r\n\r\n JvDefaultHintColor = TColor($00DDFBFA);\r\n JvDefaultAvgLineColor = TColor($00EEDDDD);\r\n JvDefaultDivisionLineColor = clLtGray; //NEW!\r\n JvDefaultShadowColor = clLtGray; //NEW!\r\n\r\n JvDefaultYLegends = 20;\r\n MaxShowXValueInLegends = 10;\r\n\r\n // Special indices to GetPenColor(Index)\r\n jvChartAverageLineColorIndex = -6;\r\n jvChartDivisionLineColorIndex = -5;\r\n jvChartShadowColorIndex = -4;\r\n jvChartAxisColorIndex = -3;\r\n jvChartHintColorIndex = -2;\r\n jvChartPaperColorIndex = -1;\r\n\r\n JvChartDefaultMarkerSize = 3;\r\n\r\ntype\r\n { CHART TYPES }\r\n TJvChartKind =\r\n (\r\n ckChartNone, // Blank graph.\r\n ckChartLine, // default type. Line and Marker plots.\r\n ckChartBar,\r\n ckChartStackedBar,\r\n ckChartBarAverage,\r\n ckChartStackedBarAverage,\r\n ckChartPieChart,\r\n //ckChartLineWithMarkers, // obsolete. use ckChartLine, and set PenMarkerKind to cmDiamond.\r\n ckChartMarkers,\r\n ckChartDeltaAverage\r\n );\r\n\r\n // ckChartLine can have a different pen type for each pen:\r\n\r\n TJvChartPenMarkerKind = (pmkNone, pmkDiamond, pmkCircle, pmkSquare, pmkCross);\r\n\r\n TJvChartGradientDirection = (grNone, grUp, grDown, grLeft, grRight); // WP\r\n\r\n TJvChartLegend = (clChartLegendNone, clChartLegendRight, clChartLegendBelow);\r\n\r\n {$IFDEF TJVCHART_ARRAY_OF_ARRAY}\r\n TJvChartDataArray = array of array of Double;\r\n {$ENDIF TJVCHART_ARRAY_OF_ARRAY}\r\n\r\n TJvChart = class;\r\n\r\n // TJvChartFloatingMarker.Caption position enumerator:\r\n TJvChartCaptionPosition =\r\n (\r\n cpMarker, // put right where the marker is\r\n cpXAxisBottom, // put below the symbol marker, in the bottom margin\r\n cpXAxisTop, // put above the symbol marker, in the top margin\r\n cpTitleArea\r\n );\r\n\r\n TJvChartFloatingMarker = class(TPersistent) // was from TObject\r\n private\r\n FOwner: TJvChart;\r\n procedure SetCaptionColor(const Value: TColor); // Which chart does it belong to?\r\n protected\r\n FRawXPosition: Integer; // raw pixel-based X position.\r\n FRawYPosition: Integer; // raw pixel-based Y position.\r\n FDragging: Boolean; // drag in progress!\r\n FVisible: Boolean; // Make chart marker object visible or invisible.\r\n FIndex: Integer; // Which marker is this?\r\n FTag: Integer; // User assignable Integer like TComponent.Tag\r\n FMarker: TJvChartPenMarkerKind; // What symbol to plot at this position?\r\n FMarkerColor: TColor; // Marker color.\r\n FXPosition: Integer; // Plot at same X co-ordinates as Data Sample X.\r\n FYPosition: Double; // Plot at Y height as data\r\n FXDraggable: Boolean; // Can marker be dragged horizontally?\r\n FXDragMin: Integer; // Minimum X Position that we can drag to.\r\n FXDragMax: Integer; // Maximum X Position that we can drag to.\r\n FYDraggable: Boolean; // Can marker be dragged vertically?\r\n //FYPositionToPen:Integer; // YPosition copied from Pen Values. (-1=disable feature, 0=first pen,1=second pen,...)\r\n FLineToMarker: Integer; // If -1 then none. Otherwise, index of another marker object\r\n FLineVertical: Boolean; // If true, then this object plots a vertical divider line.\r\n FLineStyle: TPenStyle; // Line style (solid,dashed,etc)\r\n FLineColor: TColor; // Line color.\r\n FLineWidth: Integer;\r\n FCaption: string; // Caption to print above the marker, or if no marker, then just this text is plotted.\r\n FCaptionColor: TColor; // New 2007 - WP - Color of floating marker caption\r\n FCaptionPosition: TJvChartCaptionPosition;\r\n FCaptionBoxed: Boolean; // Marker caption can have a box around it to make it more readable for some uses.\r\n\r\n //FCaptionBorderStyle:TPenStyle; // Style of border around caption, or psClear if no border.\r\n //FCaptionBorderColor:TColor; //\r\n\r\n //PROTECTED CONSTRUCTOR: Only TJvChart should create a new marker object:\r\n constructor Create(Owner: TJvChart);\r\n\r\n procedure SetCaption(ACaption: string);\r\n procedure SetXPosition(XPos: Integer); // should invalidate the chart (FOwner) if changed.\r\n procedure SetYPosition(YPos: Double); // should invalidate the chart (FOwner) if changed.\r\n\r\n procedure SetVisible(AVisible: Boolean);\r\n public\r\n property Index: Integer read FIndex;\r\n\r\n procedure Assign(Source: TPersistent); override; // Should be able to copy from one floating marker to another\r\n\r\n property Marker: TJvChartPenMarkerKind read FMarker write FMarker;\r\n property MarkerColor: TColor read FMarkerColor write FMarkerColor; // Marker color.\r\n property Visible: Boolean read FVisible write FVisible; // Make chart marker object visible or invisible.\r\n property XPosition: Integer read FXPosition write SetXPosition;\r\n property YPosition: Double read FYPosition write SetYPosition;\r\n property XDraggable: Boolean read FXDraggable write FXDraggable;\r\n property XDragMin: Integer read FXDragMin write FXDragMin;\r\n property XDragMax: Integer read FXDragMax write FXDragMax;\r\n property YDraggable: Boolean read FYDraggable write FYDraggable;\r\n //property YPositionToPen :Integer read FYPositionToPen write FYPositionToPen;\r\n property LineToMarker: Integer read FLineToMarker write FLineToMarker;\r\n property LineVertical: Boolean read FLineVertical write FLineVertical;\r\n property LineStyle: TPenStyle read FLineStyle write FLineStyle;\r\n property LineColor: TColor read FLineColor write FLineColor;\r\n property LineWidth: Integer read FLineWidth write FLineWidth;\r\n property Caption: string read FCaption write FCaption;\r\n property CaptionColor: TColor read FCaptionColor write SetCaptionColor;\r\n property CaptionPosition: TJvChartCaptionPosition read FCaptionPosition write FCaptionPosition;\r\n property CaptionBoxed: Boolean read FCaptionBoxed write FCaptionBoxed;\r\n\r\n property Tag: Integer read FTag write FTag; // User assignable Integer like TComponent.Tag\r\n\r\n //property CaptionBorderStyle :TPenStyle read FCaptionBorderStyle write FCaptionBorderStyle;\r\n //property CaptionBorderColor :TColor read FCaptionBorderColor write FCaptionBorderColor;\r\n end;\r\n\r\n TJvChartGradientBar = class(TObject) // NEW 2007\r\n private\r\n FOwner: TJvChart; // Which chart does it belongs to?\r\n FVisible: Boolean;\r\n //FRawRect: TRect; // raw pixel-based X position.\r\n FYTop, FYBottom: Double;\r\n FColor: TColor;\r\n FIndex: Integer;\r\n FGradDirection: TJvChartGradientDirection;\r\n FGradColor: TColor;\r\n FPenStyle:TPenStyle; // april 2009\r\n FPenColor:TColor; // april 2009\r\n protected\r\n constructor Create(Owner: TJvChart);\r\n procedure SetVisible(AVisible: Boolean);\r\n procedure SetColor(AColor: TColor);\r\n procedure SetGradientColor(AColor: TColor);\r\n procedure SetGradientType(AType: TJvChartGradientDirection);\r\n public\r\n property Visible: boolean read FVisible write SetVisible;\r\n property YTop: Double read FYTop write FYTop;\r\n property YBottom: Double read FYBottom write FYBottom;\r\n property Color: TColor read FColor write SetColor;\r\n property GradDirection: TJvChartGradientDirection read FGradDirection write FGradDirection;\r\n property GradColor: TColor read FGradColor write FGradColor;\r\n property PenStyle:TPenStyle read FPenStyle write FPenStyle; // april 2009\r\n property PenColor:TColor read FPenCOlor write FPenColor; // april 2009\r\n\r\n\r\n end;\r\n\r\n TJvChartHorizontalBar = class(TJvChartGradientBar) // NEW 2007\r\n private\r\n FYTop: Double;\r\n FYBottom: Double;\r\n protected\r\n constructor Create(Owner: TJvChart);\r\n public\r\n property YTop: Double read FYTop write FYTop;\r\n property YBottom: Double read FYBottom write FYBottom;\r\n end;\r\n\r\n TJvChartVerticalBar = class(TJvChartGradientBar) // NEW 2007\r\n private\r\n FXLeft: Integer;\r\n FXRight: Integer;\r\n protected\r\n constructor Create(Owner: TJvChart);\r\n public\r\n property XLeft: Integer read FXLeft write FXLeft;\r\n property XRight: Integer read FXRight write FXRight;\r\n end;\r\n\r\n { TJvChartData : Holds NxN array of Reals, Resizes automatically within preset\r\n limits. Provides a functionality mix of dynamic memory use, but with\r\n a memory cap, so we don't thrash the system or leak forever. -WAP.}\r\n TJvChartData = class(TObject)\r\n private\r\n {$IFDEF TJVCHART_ARRAY_OF_ARRAY}\r\n FData: TJvChartDataArray;\r\n {$ELSE}\r\n FData: array of Double;\r\n {$ENDIF TJVCHART_ARRAY_OF_ARRAY}\r\n\r\n FClearToValue: Double; // Typically either 0.0 or NaN\r\n FTimeStamp: array of TDateTime; // Time-series as a TDateTime\r\n // Dynamic array of dynamic array of Double.\r\n // is empty until data is stored in them.\r\n // *** Order of indexing: FData[ValueIndex,Pen] ***\r\n FDataAlloc: Integer; // Last Allocated Value.\r\n FValueCount: Integer; // Number of sample indices used\r\n FPenCount: Integer; // can't be changed without erasing all data!\r\n\r\n FStartDateTime: TDateTime; // needed for DateTime mode, and datetime axis labels! NEW 2007\r\n FEndDateTime: TDateTime;\r\n procedure SetEndDateTime(const Value: TDateTime);\r\n procedure SetStartDateTime(const Value: TDateTime);\r\n // needed for DateTime mode, and datetime axis labels! NEW 2007\r\n protected\r\n procedure Grow(Pen, ValueIndex: Integer);\r\n //GetValue/SetValue resizer, also throws exception if Pen,ValueIndex is negative or just way too big.\r\n function GetValue(Pen, ValueIndex: Integer): Double;\r\n procedure SetValue(Pen, ValueIndex: Integer; NewValue: Double);\r\n function GetTimestamp(ValueIndex: Integer): TDateTime;\r\n procedure SetTimestamp(ValueIndex: Integer; AValue: TDateTime);\r\n public\r\n constructor Create;\r\n destructor Destroy; override;\r\n\r\n procedure PreGrow(Pen, ValueIndex: Integer); // Advanced users. Allocate a large batch of memory in advance.\r\n\r\n function DebugStr(ValueIndex: Integer): string; // dump all pens for particular valueindex, as string.\r\n\r\n procedure Clear; // Resets All Data to zero.\r\n procedure ClearPenValues; // Clears all pen values to NaN but does not reset pen definitions etc.\r\n procedure Scroll;\r\n property Value[Pen, ValueIndex: Integer]: Double read GetValue write SetValue; default;\r\n property Timestamp[ValueIndex: Integer]: TDateTime read GetTimestamp write SetTimestamp;\r\n property ValueCount: Integer read FValueCount write FValueCount;\r\n property ClearToValue: Double read FClearToValue write FClearToValue; // Typically either 0.0 or NaN. default 0.0\r\n\r\n // NEW 2007 [for DateTimeMode XAxis Labels]\r\n property StartDateTime: TDateTime read FStartDateTime write SetStartDateTime;\r\n // needed for DateTime mode, and datetime axis labels! NEW 2007\r\n property EndDateTime: TDateTime read FEndDateTime write SetEndDateTime;\r\n // needed for DateTime mode, and datetime axis labels! NEW 2007\r\n end;\r\n\r\n TJvChartPaintEvent = procedure(Sender: TJvChart; ACanvas: TCanvas) of object;\r\n TJvChartEvent = procedure(Sender: TJvChart) of object;\r\n TJvChartFloatingMarkerDragEvent = procedure(Sender: TJvChart; FloatingMarker: TJvChartFloatingMarker) of object; {NEW}\r\n\r\n TJvChartClickEvent = procedure(Sender: TJvChart;\r\n Button: TMouseButton; { left/right mouse click?}\r\n Shift: TShiftState; { keyboard shift state?}\r\n X, Y: Integer; { mouse position}\r\n ChartValueIndex: Integer; { what value in the chart? }\r\n ChartPenIndex: Integer; { what pen was clicked? }\r\n { User modifiable return values for custom hinting! }\r\n var ShowHint, HintFirstLineBold: Boolean; HintStrs: TStrings) of object; {NEW}\r\n\r\n TJvChartOptions = class;\r\n\r\n { There are TWO Y Axis per graph, optionally:\r\n Chart.Options.PenAxis[I] -and-\r\n Chart.Options.SecondaryYAxisOne\r\n The primary one is displayed along the left side, and the one\r\n for the right side is only displayed if you need it.\r\n Properties for each side are grouped by the\r\n TJvChartYAxisOptions persistent-properties-object.\r\n }\r\n TJvChartYAxisOptions = class(TPersistent)\r\n private\r\n FOwner: TJvChartOptions;\r\n FActive: Boolean; // One or more pens use this Y Axis.\r\n protected\r\n FYMax: Double; // Y Scale value at the top left hand side of chart.\r\n FYMin: Double; // Y Scale value at the bottom left hand side of the chart (default 0)\r\n FYGap: Double; // Number of values per Y scale division\r\n FYGap1: Double; // Gap multiplication factor for value scaling.\r\n FMarkerValueDecimals: Integer; // Decimal places on marker-values (only applies to Marker Pens with Values)\r\n FYDivisions: Integer; // Number of vertical divisions in the chart. (default 10)\r\n FMaxYDivisions: Integer;\r\n FMinYDivisions: Integer;\r\n FYLegendDecimalPlaces: Integer;\r\n FYLegends: TStringList;\r\n FDefaultYLegends: Integer; // Number of default Y legends.\r\n FYPixelGap: Double;\r\n procedure SetYMax(NewYMax: Double);\r\n procedure SetYMin(NewYMin: Double);\r\n // procedure SetYGap(newYgap: Double);\r\n function GetYLegends: TStrings;\r\n procedure SetYLegends(Value: TStrings);\r\n procedure SetYDivisions(AValue: Integer);\r\n public\r\n constructor Create(Owner: TJvChartOptions); virtual;\r\n destructor Destroy; override;\r\n\r\n\r\n procedure Assign(Source:TPersistent); override;// Added Sept 2009 \r\n\r\n procedure Normalize;\r\n procedure Clear;\r\n // runtime only properties\r\n property YPixelGap: Double read FYPixelGap write FYPixelGap;\r\n property Active: Boolean read FActive;\r\n property YGap: Double read FYGap;\r\n property YGap1: Double read FYGap1; // Gap multiplication factor for value scaling.\r\n property YLegends: TStrings read GetYLegends write SetYLegends; { Y Axis Legends as Strings }\r\n published\r\n property YMax: Double read FYMax write SetYMax;\r\n property YMin: Double read FYMin write SetYMin;\r\n property YDivisions: Integer read FYDivisions write SetYDivisions default 10;\r\n // Number of vertical divisions in the chart\r\n // YDivisions->YDivisions\r\n property MaxYDivisions: Integer read FMaxYDivisions write FMaxYDivisions default 20;\r\n property MinYDivisions: Integer read FMinYDivisions write FMinYDivisions default 5;\r\n property MarkerValueDecimals: Integer read FMarkerValueDecimals write FMarkerValueDecimals default -1;\r\n // Decimal places on marker-values (only applies to Marker Pens with Values)\r\n property YLegendDecimalPlaces: Integer read FYLegendDecimalPlaces write FYLegendDecimalPlaces;\r\n property DefaultYLegends: Integer read FDefaultYLegends write FDefaultYLegends default JvDefaultYLegends;\r\n end;\r\n\r\n TJvChartOptions = class(TPersistent)\r\n private\r\n FOwner: TJvChart;\r\n {accessors}\r\n function GetAverageValue(Index: Integer): Double;\r\n procedure SetAverageValue(Index: Integer; AValue: Double);\r\n function GetPenColor(Index: Integer): TColor;\r\n procedure SetPenColor(Index: Integer; AColor: TColor);\r\n function GetPenStyle(Index: Integer): TPenStyle;\r\n procedure SetPenStyle(Index: Integer; APenStyle: TPenStyle);\r\n function GetPenMarkerKind(Index: Integer): TJvChartPenMarkerKind;\r\n procedure SetPenMarkerKind(Index: Integer; AMarkKind: TJvChartPenMarkerKind);\r\n procedure SetXStartOffset(Offset: Integer);\r\n function GetPenSecondaryAxisFlag(Index: Integer): Boolean;\r\n procedure SetPenSecondaryAxisFlag(Index: Integer; NewValue: Boolean);\r\n function GetPenValueLabels(Index: Integer): Boolean;\r\n procedure SetPenValueLabels(Index: Integer; NewValue: Boolean);\r\n procedure SetPenCount(Count: Integer);\r\n procedure SetChartKind(AKind: TJvChartKind);\r\n // TStrings<->TStringList transmogrifiers\r\n function GetPenLegends: TStrings;\r\n procedure SetPenLegends(Value: TStrings);\r\n function GetPenUnit: TStrings;\r\n procedure SetPenUnit(Value: TStrings);\r\n function GetXLegends: TStrings;\r\n procedure SetXLegends(Value: TStrings);\r\n procedure SetHeaderFont(AFont: TFont);\r\n procedure SetLegendFont(AFont: TFont);\r\n procedure SetAxisFont(AFont: TFont);\r\n procedure SetPaperColor(AColor: TColor);\r\n procedure SetPrimaryYAxis(AssignFrom: TJvChartYAxisOptions);\r\n procedure SetSecondaryYAxis(AssignFrom: TJvChartYAxisOptions);\r\n // Each pen can be associated with either the primary or secondary axis,\r\n // this function decides which axis to return depending on the pen configuration:\r\n function GetPenAxis(Index: Integer): TJvChartYAxisOptions;\r\n procedure SetXAxisDateTimeDivision(const Value: Double);\r\n protected\r\n FChartKind: TJvChartKind; // default JvChartLine\r\n {runtime pixel spacing multipliers}\r\n FXPixelGap: Double;\r\n {Fonts}\r\n FHeaderFont: TFont;\r\n FLegendFont: TFont;\r\n FAxisFont: TFont;\r\n FTitle: string;\r\n FNoDataMessage: string;\r\n FYAxisHeader: string;\r\n FYAxisDivisionMarkers: Boolean; // Do you want grid-paper look?\r\n FXAxisDivisionMarkers: Boolean; // Do you want grid-paper look?\r\n FXAxisHeader: string;\r\n FMarkerSize:Integer;\r\n FXLegends: TStringList; // Text labels.\r\n FXLegendMaxTextWidth: Integer; // runtime: display width (pixels) of widest string in FXLegends[1:X].\r\n FXAxisValuesPerDivision: Integer;\r\n // Number of Values (aka samples) in each vertical dotted lines that are divisision marker.\r\n FXAxisLegendSkipBy: Integer; //1=print every X axis label, 2=every other, and so on. default=1\r\n FXLegendHoriz: Integer; // Horizontally oriented GraphXAxisLegend ends at this X Point.\r\n FXAxisLabelAlignment: TAlignment; // New: Text alignment for X axis labels. Default is left alignment.\r\n FXAxisDateTimeMode: Boolean;\r\n // False=use custom text labels, True=Use Date/Time Stamps as X axis labels. [REWORKED LOGIC IN 2007!]\r\n FXAxisDateTimeDivision: Double; // NEW 2007 : What is the nominal date/time division (1.0=day, 1.0/24=1 hour)\r\n FXAxisDateTimeFormat: string; // Usually a short date-time label, hh:nn:ss is good.\r\n FDateTimeFormat: string;\r\n // Usually a long date-time label, ISO standard yyyy-mm-dd hh:nn:ss is fine, as is Windows locale defaults.\r\n FXValueCount: Integer;\r\n // Number of pens:\r\n FPenCount: Integer;\r\n // Per-pen array/list properties\r\n FPenColors: array of TColor;\r\n FPenStyles: array of TPenStyle; // solid, dotted\r\n FPenMarkerKind: array of TJvChartPenMarkerKind;\r\n FPenSecondaryAxisFlag: array of Boolean; // False=Primary Y Axis, True=Secondary Y Axis.\r\n FPenValueLabels: array of Boolean;\r\n FPenLegends: TStringList;\r\n FPenUnit: TStringList;\r\n FAverageValue: array of Double; // Used in averaging chart types only.\r\n FPrimaryYAxis: TJvChartYAxisOptions;\r\n FSecondaryYAxis: TJvChartYAxisOptions;\r\n FXGap: Double; // Number of pixels per X scale unit.\r\n FXOrigin: Integer; {which value corresponds to Origin}\r\n FYOrigin: Integer; // Vertical (Y) Position of the Origin point, and X axis.\r\n FXStartOffset: Longint; {margin} // Horizontal (X) Position of the Origin point, and Y Axis\r\n FYStartOffset: Longint; // height of the top margin above the charting area.\r\n FXEnd: Longint; { From top left of control, add XEnd to find where the right margin starts }\r\n FYEnd: Longint; { from top left of control, add YEnd to find where the below-the bottom margin starts }\r\n { more design time }\r\n FLegendWidth: Integer;\r\n FLegendRowCount: Integer; // Number of lines of text in legend.\r\n FAutoUpdateGraph: Boolean;\r\n FMouseEdit: Boolean;\r\n FMouseDragObjects: Boolean; // Can mouse drag floating objects?\r\n FMouseInfo: Boolean;\r\n FLegend: TJvChartLegend; // was FShowLegend, now Legend=clChartLegendRight\r\n FPenLineWidth: Integer;\r\n FAxisLineWidth: Integer;\r\n\r\n //COLORS:\r\n FPaperColor: TColor;\r\n FDivisionLineColor: TColor; // NEW! Division line\r\n FShadowColor: TColor; // NEW! Shadow color\r\n FAxisLineColor: TColor; // Color of box around chart plot area.\r\n FHintColor: TColor; // Hint box color\r\n FAverageLineColor: TColor; // Pen color for Charts with auto-average lines.\r\n FCursorColor: TColor; // Sample indicator Cursor color\r\n\r\n FCursorStyle: TPenStyle; // Cursor style.\r\n FGradientColor: TColor; // new 2007\r\n FGradientDirection: TJvChartGradientDirection; // new 2007\r\n\r\n // INTERNALS :NEW STUFF IN 2007\r\n FXAxisDateTimeFirstMarker: Integer; // at XValue initial offset NEW 2007\r\n FXAxisDateTimeSkipBy: Integer; // an XValue indexing multiplier NEW 2007\r\n FXAxisDateTimeLines: Integer; // number of lines we're displaying NEW 2007\r\n\r\n { event interface }\r\n procedure NotifyOptionsChange;\r\n public\r\n constructor Create(Owner: TJvChart); virtual;\r\n destructor Destroy; override;\r\n\r\n\r\n procedure Assign(Source:TPersistent); override;// Warren Added Sept 2009.\r\n\r\n { runtime properties }\r\n property AverageValue[Index: Integer]: Double read GetAverageValue write SetAverageValue;\r\n property PenAxis[Index: Integer]: TJvChartYAxisOptions read GetPenAxis;\r\n property XLegends: TStrings read GetXLegends write SetXLegends; { X Axis Legends as Strings }\r\n { plot-canvas size, depends on size of control }\r\n property XEnd: Longint read FXEnd write FXEnd;\r\n property YEnd: Longint read FYEnd write FYEnd;\r\n {Gradient NEW 2007 }\r\n property GradientColor: TColor read FGradientColor write FGradientColor; // new 2007\r\n property GradientDirection: TJvChartGradientDirection read FGradientDirection write FGradientDirection; // new 2007\r\n\r\n { pixel spacing : multipliers to scale real values into X/Y pixel amounts before plotting. CRITICALLY important. }\r\n property XPixelGap: Double read FXPixelGap write FXPixelGap;\r\n property XLegendMaxTextWidth: Integer read FXLegendMaxTextWidth write FXLegendMaxTextWidth;\r\n { Per Pen Array/List Properties -- settable at RUNTIME only. }\r\n property PenColor[Index: Integer]: TColor read GetPenColor write SetPenColor;\r\n property PenStyle[Index: Integer]: TPenStyle read GetPenStyle write SetPenStyle;\r\n property PenMarkerKind[Index: Integer]: TJvChartPenMarkerKind read GetPenMarkerKind write SetPenMarkerKind;\r\n property PenSecondaryAxisFlag[Index: Integer]: Boolean read GetPenSecondaryAxisFlag write SetPenSecondaryAxisFlag;\r\n property PenValueLabels[Index: Integer]: Boolean read GetPenValueLabels write SetPenValueLabels;\r\n published\r\n { design time}\r\n { Per Pen Array/List Properties - settable at DESIGNTIME. Others (color/style, marker) are runtime only. }\r\n property PenLegends: TStrings read GetPenLegends write SetPenLegends;\r\n property PenUnit: TStrings read GetPenUnit write SetPenUnit;\r\n property ChartKind: TJvChartKind read FChartKind write SetChartKind default ckChartLine;\r\n property Title: string read FTitle write FTitle;\r\n property NoDataMessage: string read FNoDataMessage write FNoDataMessage;\r\n //NEW! NOV 2004. Optionally display this instead of fixed resource string rsNoData\r\n\r\n { X Axis Properties }\r\n property YAxisHeader: string read FYAxisHeader write FYAxisHeader;\r\n property YAxisDivisionMarkers: Boolean read FYAxisDivisionMarkers write FYAxisDivisionMarkers default True;\r\n // Do you want grid-paper look?\r\n { X Axis Properties }\r\n property XAxisDivisionMarkers: Boolean read FXAxisDivisionMarkers write FXAxisDivisionMarkers default True;\r\n // Do you want grid-paper look?\r\n property XAxisValuesPerDivision: Integer read FXAxisValuesPerDivision write FXAxisValuesPerDivision;\r\n // Number of Values (aka samples) in each vertical dotted lines that are divisision marker.\r\n property XAxisLabelAlignment: TAlignment read FXAxisLabelAlignment write FXAxisLabelAlignment;\r\n // New: Text alignment for X axis labels. Default is left alignment.\r\n\r\n property XAxisDateTimeMode: Boolean read FXAxisDateTimeMode write FXAxisDateTimeMode;\r\n // REWORKED LOGIC NEW IN 2007! See GraphXAxisDivisionMarkers\r\n property XAxisDateTimeDivision: Double read FXAxisDateTimeDivision write SetXAxisDateTimeDivision;\r\n // NEW 2007 : What is the nominal date/time division (1.0=day, 1.0/24=1 hour)\r\n\r\n property XAxisDateTimeFormat: string read FXAxisDateTimeFormat write FXAxisDateTimeFormat;\r\n property XAxisHeader: string read FXAxisHeader write FXAxisHeader;\r\n property XAxisLegendSkipBy: Integer read FXAxisLegendSkipBy write FXAxisLegendSkipBy default 1;\r\n property DateTimeFormat: string read FDateTimeFormat write FDateTimeFormat;\r\n // Usually a long date-time label, ISO standard yyyy-mm-dd hh:nn:ss is fine, as is Windows locale defaults.\r\n property PenCount: Integer read FPenCount write SetPenCount default 1;\r\n property XGap: Double read FXGap write FXGap;\r\n property XOrigin: Integer read FXOrigin write FXOrigin;\r\n property YOrigin: Integer read FYOrigin write FYOrigin; // Position of bottom of chart (not always the zero origin)\r\n property XStartOffset: Longint read FXStartOffset write SetXStartOffset default 45;\r\n property YStartOffset: Longint read FYStartOffset write FYStartOffset default 10;\r\n { Y Range }\r\n { plotting markers }\r\n property MarkerSize: Integer read FMarkerSize write FMarkerSize default JvChartDefaultMarkerSize;\r\n { !! New: Primary (left side) Y axis, and Secondary (right side) Y Axis !!}\r\n property PrimaryYAxis: TJvChartYAxisOptions read FPrimaryYAxis write SetPrimaryYAxis;\r\n property SecondaryYAxis: TJvChartYAxisOptions read FSecondaryYAxis write SetSecondaryYAxis;\r\n //1=print every X axis label, 2=every other, and so on. default=1\r\n { vertical numeric decimal places }\r\n { more design time }\r\n property AutoUpdateGraph: Boolean read FAutoUpdateGraph write FAutoUpdateGraph default True;\r\n property MouseEdit: Boolean read FMouseEdit write FMouseEdit default True;\r\n property MouseDragObjects: Boolean read FMouseDragObjects write FMouseDragObjects;\r\n // Can mouse drag floating objects?\r\n property MouseInfo: Boolean read FMouseInfo write FMouseInfo default True;\r\n //OLD:property ShowLegend: Boolean read FShowLegend write FShowLegend default True;\r\n //CHANGEDTO:\r\n property Legend: TJvChartLegend read FLegend write FLegend default clChartLegendNone;\r\n property LegendRowCount: Integer read FLegendRowCount write FLegendRowCount;\r\n property LegendWidth: Integer read FLegendWidth write FLegendWidth default 150;\r\n property PenLineWidth: Integer read FPenLineWidth write FPenLineWidth default 1;\r\n property AxisLineWidth: Integer read FAxisLineWidth write FAxisLineWidth default 2;\r\n { more and more design time. these ones not sure about whether they are designtime or not.}\r\n property XValueCount: Integer read FXValueCount write FXValueCount default 10;\r\n {Font properties}\r\n property HeaderFont: TFont read FHeaderFont write SetHeaderFont;\r\n property LegendFont: TFont read FLegendFont write SetLegendFont;\r\n property AxisFont: TFont read FAxisFont write SetAxisFont;\r\n { Color properties}\r\n property DivisionLineColor: TColor read FDivisionLineColor write FDivisionLineColor default\r\n JvDefaultDivisionLineColor; // NEW! Division line\r\n property ShadowColor: TColor read FShadowColor write FShadowColor default JvDefaultShadowColor; // NEW! Shadow color\r\n\r\n property PaperColor: TColor read FPaperColor write SetPaperColor;\r\n property AxisLineColor: TColor read FAxisLineColor write FAxisLineColor;\r\n property HintColor: TColor read FHintColor write FHintColor default JvDefaultHintColor;\r\n property AverageLineColor: TColor read FAverageLineColor write FAverageLineColor default JvDefaultAvgLineColor;\r\n property CursorColor: TColor read FCursorColor write FCursorColor;\r\n property CursorStyle: TPenStyle read FCursorStyle write FCursorStyle;\r\n end;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvChart = class(TJvGraphicControl)\r\n private\r\n FUpdating: Boolean; // PREVENT ENDLESS EVENT LOOPING.\r\n FAutoPlotDone: Boolean; // If Options.AutoUpdateGraph is set, then has paint method called PlotGraph already?\r\n FPlotGraphCalled: Boolean; // Has bitmap ever been painted?\r\n FInPlotGraph: Boolean; // recursion blocker.\r\n\r\n // NEW: The component has always had a feature when you click on margin areas\r\n // that the user can enter a value (Y Axis Scale, title, and X header)\r\n // The right margin however didn't do anything. Now all four have a user\r\n // event that can be fired. If you don't want the default editor behaviours\r\n // turn off Options.MouseEdit to make it 100% user-defined what happens when\r\n // the user clicks on an area of the chart.\r\n FOnYAxisClick: TJvChartEvent; // Left margin (Primary Y Axis labels) click\r\n FOnXAxisClick: TJvChartEvent; // Bottom margin (X Axis Header) click\r\n FOnAltYAxisClick: TJvChartEvent; // Right margin click (Secondary Y Axis labels)\r\n FOnTitleClick: TJvChartEvent; // Title area click (Top margin)\r\n FOnChartClick: TJvChartClickEvent; // mouse click event\r\n\r\n FOnBeginFloatingMarkerDrag: TJvChartFloatingMarkerDragEvent;\r\n FOnEndFloatingMarkerDrag: TJvChartFloatingMarkerDragEvent;\r\n\r\n\r\n //FOnChartPaint: TJvChartPaintEvent; // wrong event. bugfix requires removal.\r\n\r\n\r\n FMouseDownShowHint: Boolean; // True=showing hint.\r\n FMouseDownHintBold: Boolean; // True=first line of hint is bold.\r\n FMouseDownHintStrs: TStringList;\r\n\r\n FExtPicture:TPicture; // An external image!\r\n\r\n { TImage stuff}\r\n FPicture: TPicture; // An image drawn via GDI primitives, saveable as\r\n // bitmap or WMF, or displayable to screen\r\n FData: TJvChartData;\r\n\r\n FDragFloatingMarker: TJvChartFloatingMarker; //Current object we are dragging ( nil=none )\r\n FFloatingMarker: TObjectList; // NEW: collection of TJvChartFloatingMarker objects.\r\n FHorizontalBars: TObjectList; // NEW 2007\r\n FVerticalBars: TObjectList; // NEW 2007\r\n\r\n FAverageData: TJvChartData;\r\n FBitmap: TBitmap;\r\n FOptions: TJvChartOptions; //^TOptions;\r\n //Options2 : ^TOptions2; // now FData\r\n PrintInSession: Boolean;\r\n FStartDrag: Boolean;\r\n FMouseLegend: Boolean;\r\n FContainsNegative: Boolean;\r\n { strColorFile: string;}// not used (ahuser)\r\n FOldYOrigin: Integer;\r\n FOldYGap: Double;\r\n FMouseDownX: Longint;\r\n FMouseDownY: Longint;\r\n FMouseValue: Integer;\r\n FMousePen: Integer;\r\n FYFont: TFont; // Delphi Font object wrapper.\r\n //NEW:\r\n FXOrigin: Double; {was in TJvChart.PlotGraph}\r\n FYOrigin: Double; {was in TJvChart.PlotGraph}\r\n FXAxisPosition: Integer; // how far down (in Y dimension) is the X axis?\r\n FOnOptionsChangeEvent: TJvChartEvent; { Component fires this event for when options change.}\r\n FOnPaint: TJvChartPaintEvent; {NEW JAN 2005: Custom paint event called from TjvChart.Paint.}\r\n\r\n FCursorPosition: Integer; // NEW: -1 means no visible cursor, 0..n means make\r\n // particular value highlighted. The highlight is painted\r\n // over top of the TImage, so that we can just restore the TImage\r\n // without replotting the whole chart.\r\n // Y Axis Vertical Font\r\n FYFontHandle: HFONT; // Y AXIS VERTICAL TEXT: Vertical Font Handle (remember to DeleteObject)\r\n FYLogFont: TLogFont; // Y AXIS VERTICAL TEXT: Logical Font Options Record\r\n procedure MakeVerticalFont; // Call GDI calls to get the Y Axis Vertical Font handle\r\n procedure MyGraphVertFont(ACanvas: TCanvas); // vertical font handle\r\n procedure PaintCursor; // called from Paint iif a Cursor is visible. does NOT modify FPicture!\r\n protected\r\n procedure DrawFloatingMarkers;\r\n procedure DrawHorizontalBars; // NEW 2007\r\n procedure DrawVerticalBars; // NEW 2007\r\n procedure DrawGradient; // NEW 2007\r\n\r\n procedure DrawChartLegendBelow(ACanvas: TCanvas); {accidentally deleted during Jedi_new to Jedi_2009 branch. Restored by WP Sept 2009}\r\n\r\n\r\n function GetFloatingMarker(Index: Integer): TJvChartFloatingMarker;\r\n function GetHorizontalBar(index:integer):TJvChartHorizontalBar; // new 2009\r\n function GetVerticalBar(index:integer):TJvChartVerticalBar; // new 2009\r\n\r\n\r\n\r\n { Right Side Legend showing Pen Names, and/or Data Descriptors }\r\n procedure GraphXAxisLegendMarker(ACanvas: TCanvas; MarkerKind: TJvChartPenMarkerKind; X, Y: Integer);\r\n procedure GraphXAxisLegend;\r\n procedure MyHeader(ACanvas: TCanvas; StrText: string);\r\n procedure MyXHeader(ACanvas: TCanvas; StrText: string);\r\n procedure MyYHeader(ACanvas: TCanvas; StrText: string); // NEW\r\n procedure MyHeaderFont(ACanvas: TCanvas);\r\n procedure MyAxisFont(ACanvas: TCanvas);\r\n procedure MySmallGraphFont(ACanvas: TCanvas);\r\n function MyTextHeight(ACanvas: TCanvas; StrText: string): Longint;\r\n { TEXTOUT stuff }\r\n procedure MyRightTextOut(ACanvas: TCanvas; X, Y: Integer; const Text: string); // RIGHT TEXT\r\n procedure MyCenterTextOut(ACanvas: TCanvas; X, Y: Integer; const Text: string); // CENTER TEXT\r\n procedure MyLeftTextOut(ACanvas: TCanvas; X, Y: Integer; const Text: string); // LEFT ALIGN TEXT\r\n\r\n // Use HintColor:\r\n procedure MyLeftTextOutHint(ACanvas: TCanvas; X, Y: Integer; const Text: string);\r\n\r\n { line, curve, rectangle stuff }\r\n procedure MyPenLineTo(ACanvas: TCanvas; X, Y: Integer);\r\n procedure MyAxisLineTo(ACanvas: TCanvas; X, Y: Integer);\r\n procedure MyRectangle(ACanvas: TCanvas; X, Y, X2, Y2: Integer);\r\n procedure MyColorRectangle(ACanvas: TCanvas; Pen: Integer; X, Y, X2, Y2: Integer);\r\n procedure MyPie(ACanvas: TCanvas; X1, Y1, X2, Y2, X3, Y3, X4, Y4: Longint); { pie chart segment }\r\n // procedure MyArc(X1, Y1, X2, Y2, X3, Y3, X4, Y4: Integer); { arc } // not used (ahuser)\r\n\r\n // procedure MyEllipse(X1, Y1, X2, Y2: Integer); // not used (ahuser)\r\n procedure MyDrawLine(ACanvas: TCanvas; X1, Y1, X2, Y2: Integer); // not used (ahuser)\r\n procedure MyDrawAxisMark(ACanvas: TCanvas; X1, Y1, X2, Y2: Integer); // solid line as a tick on an axis.\r\n procedure MyDrawDotLine(ACanvas: TCanvas; X1, Y1, X2, Y2: Integer);\r\n\r\n procedure EditXHeader;\r\n procedure EditYScale;\r\n procedure EditHeader;\r\n\r\n procedure SetSolidLines(ACanvas: TCanvas);\r\n procedure SetDotLines(ACanvas: TCanvas);\r\n\r\n procedure SetLineColor(ACanvas: TCanvas; Pen: Integer);\r\n procedure SetRectangleColor(ACanvas: TCanvas; Pen: Integer);\r\n procedure SetFontColor(ACanvas: TCanvas; Pen: Integer);\r\n procedure CountGraphAverage;\r\n procedure DrawPenColorBox(ACanvas: TCanvas; NColor, W, H, X, Y: Integer);\r\n { function GetDefaultColorString(nIndex: Integer): string;}// (rom) not used\r\n procedure MyPiePercentage(X1, Y1, W: Longint; NPercentage: Double);\r\n procedure GraphPieChart(NPen: Integer);\r\n procedure GraphDeltaAverage;\r\n procedure MyPieLegend(NPen: Integer);\r\n procedure ShowMouseMessage(X, Y: Integer);\r\n // marker symbols:\r\n procedure MyPolygon(ACanvas: TCanvas; Points: array of TPoint);\r\n procedure PlotCross(ACanvas: TCanvas; X, Y: Integer);\r\n procedure PlotDiamond(ACanvas: TCanvas; X, Y: Integer);\r\n procedure PlotFilledDiamond(ACanvas: TCanvas; X, Y: Integer);\r\n procedure PlotCircle(ACanvas: TCanvas; X, Y: Integer);\r\n procedure PlotSquare(ACanvas: TCanvas; X, Y: Integer);\r\n\r\n procedure PlotMarker(ACanvas: TCanvas; MarkerKind: TJvChartPenMarkerKind; X, Y: Integer);\r\n // Calls one of the Plot functions.\r\n\r\n procedure ClearScreen;\r\n // internal graphics methods\r\n procedure GraphSetup; // These set up variables used for all the rest of the plotting functions\r\n procedure GraphXAxis;\r\n procedure GraphYAxis;\r\n procedure GraphYAxisDivisionMarkers;\r\n procedure GraphXAxisDivisionMarkers; // new.\r\n procedure CalcYEnd; // Determine where the below-the bottom axis area starts\r\n\r\n function GetChartCanvas(isFloating:Boolean): TCanvas; // Get Picture.Bitmap Canvas.\r\n function GetChartCanvasWidth: Integer; //WP NEW 2007\r\n function GetChartCanvasHeight: Integer; //WP NEW 2007\r\n\r\n function DestRect: TRect; // from TImage\r\n procedure DesignModePaint; // Invoked by Paint method when we're in design mode.\r\n procedure Paint; override; // from TImage\r\n procedure Resize; override; // from TControl\r\n procedure Loaded; override;\r\n { draw dummy data for design mode}\r\n procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;\r\n procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;\r\n procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;\r\n\r\n procedure PrimaryYAxisLabels; // Put contents into Options.PrimaryYAxis.YLegends\r\n procedure NotifyOptionsChange; {NEW}\r\n\r\n procedure InternalPlotGraph; { internal version of _PlotGraph that doesn't call Invalidate. }\r\n\r\n { internal drawing properties, valid during Paint method invocations only }\r\n property XOrigin: Double read FXOrigin; {was in TJvChart.PlotGraph}\r\n property YOrigin: Double read FYOrigin; {was in TJvChart.PlotGraph}\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n\r\n // Get the X and Y Value for a particular Mouse location:\r\n function MouseToXValue(X: Integer): Integer;\r\n // convert X pixel mouse position to data index, ie Data.Values[..,].\r\n function MouseToYValue(Y: Integer): Double;\r\n // convert Y pixel mouse position to value in range Options.PrimaryYAxis.Min to Options.PrimaryYAxis.mAx\r\n\r\n {General procedures for the graph...}\r\n procedure ResetGraphModule; {Call this before totally new values and Pen}\r\n //procedure AutoFormatGraph; {XXX BAD CODE. TO BE DELETED. MAY BE REPLACED LATER BY NEW AutoRange FUNCTION!}\r\n\r\n procedure PlotGraph; {Update screen / draw graph to screen. calls Invalidate. Don't call from inside Paint code!}\r\n\r\n procedure PlotPicture( picture : TPicture; fontScaling:Double );\r\n\r\n procedure PrintGraph; {Send picture to printer; all printing done by component}\r\n procedure AddGraphToOpenPrintCanvas(XStartPos, YStartPos, GraphWidth, GraphHeight: Longint);\r\n {adds the graph to the \"OPEN\" printer canvas}\r\n {printing control=outside this component; add other text etc}\r\n procedure GraphToClipboard; {Puts picture on clipboard}\r\n procedure ResizeChartCanvas; {Call this after screen resize and after start up}\r\n procedure PivotData; { Pivot Table. Switches the x values with Pen! Resets AverageLine}\r\n procedure AutoHint; // Make the automatic hint message showing all pens and their values.\r\n procedure SetCursorPosition(Pos: Integer);\r\n procedure DisplayBars; // NEW 2007\r\n\r\n // FLOATING MARKERS: NEW JAN 2005. -WP\r\n function AddFloatingMarker: TJvChartFloatingMarker; // NEW Jan 2005!\r\n\r\n property FloatingMarker[Index: Integer]: TJvChartFloatingMarker read GetFloatingMarker; // NEW Jan 2005!\r\n property HorizontalBar[Index:Integer]:TJvChartHorizontalBar read GetHorizontalBar; // new 2009\r\n property VerticalBar[Index:Integer]:TJvChartVerticalBar read GetVerticalBar; // new 2009\r\n\r\n procedure DeleteFloatingMarker(Index: Integer); // NEW Jan 2005!\r\n\r\n // --NEW 2007 METHOD--\r\n\r\n procedure DeleteFloatingMarkerObj(Marker: TJvChartFloatingMarker); // NEW 2007\r\n procedure CopyFloatingMarkers(Source: TJvChart);\r\n procedure ClearFloatingMarkers;\r\n function FloatingMarkerCount: Integer; // NEW 2007\r\n\r\n function AddHorizontalBar: TJvChartHorizontalBar; // NEW 2007\r\n procedure ClearHorizontalBars; // NEW 2007\r\n function HorizontalBarsCount: Integer; // NEW 2007\r\n\r\n function AddVerticalBar: TJvChartVerticalBar; // NEW 2007\r\n procedure ClearVerticalBars; // NEW 2007\r\n function VerticalBarsCount: Integer; // NEW 2007\r\n\r\n // -- END NEW 2007 METHOD--\r\n\r\n property Data: TJvChartData read FData;\r\n property AverageData: TJvChartData read FAverageData;\r\n public\r\n {runtime only helper properties}\r\n { TImage-like stuff }\r\n property Picture: TPicture read FPicture; // write SetPicture;\r\n // NEW: Ability to highlight a particular sample by setting the Cursor position!\r\n property CursorPosition: Integer read FCursorPosition write SetCursorPosition;\r\n // procedure DataTests; // TESTING. WAP.\r\n published\r\n { Standard TControl Stuff}\r\n //property Color default clWindow;\r\n property Font;\r\n property Align;\r\n property Anchors;\r\n property Constraints;\r\n property OnDblClick; { TNotifyEvent from TControl }\r\n property AutoSize;\r\n property DragCursor;\r\n property DragKind;\r\n //property OnKeyDown; // Tried to add this, but it was too hard. -WP APril 2004.\r\n property DragMode;\r\n property Enabled;\r\n property ParentShowHint;\r\n property PopupMenu;\r\n property ShowHint;\r\n property Visible;\r\n { chart options}\r\n property Options: TJvChartOptions read FOptions write FOptions;\r\n { chart events}\r\n\r\n property OnChartClick: TJvChartClickEvent read FOnChartClick write FOnChartClick;\r\n\r\n property OnChartPaint: TJvChartPaintEvent read FOnPaint write FOnPaint; // Chart paint event fixed Sept 2009\r\n // After chart bitmap is painted onto control surface we can \"decorate\" it with owner-drawn extras.\r\n\r\n { Drag and Drop of Floating Marker Events - NEW Jan 2005 -WP}\r\n property OnBeginFloatingMarkerDrag: TJvChartFloatingMarkerDragEvent read FOnBeginFloatingMarkerDrag write\r\n FOnBeginFloatingMarkerDrag; // Drag/drop of floating markers beginning.\r\n property OnEndFloatingMarkerDrag: TJvChartFloatingMarkerDragEvent read FOnEndFloatingMarkerDrag write\r\n FOnEndFloatingMarkerDrag; // Drag/drop of floating markers ending.\r\n\r\n {\r\n Chart Margin Click Events - you can click on the four\r\n 'margin' areas (left,right,top,bottom) around the main chart\r\n area. The left and top margins have default behaviours\r\n which you can disable by turning off Options.MouseEdit.\r\n The other 2 margin areas are entirely up to the user to define.\r\n Clicking bottom or right margins does nothing by default.\r\n }\r\n property OnYAxisClick: TJvChartEvent read FOnYAxisClick write FOnYAxisClick;\r\n // When user clicks on Y axis, they can enter a new Y Scale value.\r\n property OnXAxisClick: TJvChartEvent read FOnXAxisClick write FOnXAxisClick;\r\n // Also allow user to define some optional action for clicking on the X axis.\r\n property OnAltYAxisClick: TJvChartEvent read FOnAltYAxisClick write FOnAltYAxisClick;\r\n // Right margin click (Secondary Y Axis labels)\r\n property OnTitleClick: TJvChartEvent read FOnTitleClick write FOnTitleClick; // Top margin area (Title area) click.\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvChart.pas $';\r\n Revision: '$Revision: 13216 $';\r\n Date: '$Date: 2012-02-24 11:09:08 +0100 (ven. 24 févr. 2012) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n SysUtils, Forms, Dialogs, Printers, Clipbrd,\r\n Math, // uses Ceil routine, also defines IsNaN on Delphi 6 and up.\r\n JvJCLUtils, // StrToFloatDef\r\n JvJVCLUtils, JvResources;\r\n\r\nconst\r\n {$IFDEF TJVCHART_ARRAY_OF_ARRAY}\r\n CHART_SANITY_LIMIT = 60000;\r\n {$ELSE}\r\n CHART_SANITY_LIMIT = 12000000;\r\n {$ENDIF TJVCHART_ARRAY_OF_ARRAY}\r\n\r\n // Any attempt to have more than CHART_SANITY_LIMIT elements in this\r\n // graph will be treated as an internal failure on our part. This prevents\r\n // ugly situations where we thrash because of excessive memory usage.\r\n // Better to set this than to have the system pig out when we\r\n // don't want it to. Set this very small when debugging,\r\n // large when releasing component, and don't remove it unless\r\n // you're absolutely sure. Increase it whenever necessary.\r\n // Remember, it's a debugging tool, here on purpose to help keep you\r\n // out of thrashing-virtual-memory-hell. You probably have a screen\r\n // to view the chart that is a maximum of 1600x1200, so more than 1600\r\n // samples will mean the data should be reduced before charting.\r\n\r\n MAX_VALUES = 20000;\r\n // Any attempt to exceed this values count will cause array size and performance problems, thus we limit it.\r\n MAX_PEN = 100;\r\n // Any attempt to exceed this pen count will cause array size and performance problems, thus we hardcode the pen limit to 100 pens.\r\n DEFAULT_PEN_COUNT = 16; // By Default TJvChartData's internal data structures have room for up to 16 pens\r\n MAX_X_LEGENDS = 50;\r\n MAX_GRAPH_LEGEND_LEN = 9;\r\n REALPREC = 7;\r\n DEFAULT_MARKER_SIZE = 3;\r\n DEFAULT_VALUE_COUNT = 100;\r\n // By Default TJvChartData holds 100 values per pen. Grows autofragellisticexpialidociously. :-)\r\n\r\n// NEW 2007:\r\n\r\n // HELPER FUNCTIONS - NEW 2007\r\n//-------------------Helper to draw a Gradient. Use it with TJvChartHorizontalBar, for example-------------------------\r\n\r\nprocedure GradHorizontal(Canvas: TCanvas; Rect: TRect; FromColor, ToColor: TColor); // NEW 2007\r\nvar\r\n X: Integer;\r\n dr, dg, DB: Extended;\r\n C1, C2: TColor;\r\n r1, r2, g1, g2, b1, b2: Byte;\r\n R, G, B: Byte;\r\n Cnt: Integer;\r\n XDelta: Integer;\r\nbegin\r\n C1 := FromColor;\r\n R1 := GetRValue(C1);\r\n G1 := GetGValue(C1);\r\n B1 := GetBValue(C1);\r\n\r\n C2 := ToColor;\r\n R2 := GetRValue(C2);\r\n G2 := GetGValue(C2);\r\n B2 := GetBValue(C2);\r\n\r\n XDelta := Rect.Right - Rect.Left;\r\n if XDelta <= 0 then\r\n Exit;\r\n\r\n dr := (R2 - R1) / XDelta;\r\n dg := (G2 - G1) / XDelta;\r\n DB := (B2 - B1) / XDelta;\r\n\r\n Cnt := 0;\r\n for X := Rect.Left to Rect.Right - 1 do\r\n begin\r\n R := R1 + Ceil(dr * Cnt); // uses Math.\r\n G := G1 + Ceil(dg * Cnt);\r\n B := B1 + Ceil(DB * Cnt);\r\n\r\n Canvas.Pen.Color := RGB(R, G, B);\r\n Canvas.MoveTo(X, Rect.Top);\r\n Canvas.LineTo(X, Rect.Bottom);\r\n Inc(Cnt);\r\n end;\r\nend;\r\n\r\nprocedure GradVertical(Canvas: TCanvas; Rect: TRect; FromColor, ToColor: TColor); // NEW 2007\r\nvar\r\n Y: Integer;\r\n dr, dg, DB: Extended;\r\n C1, C2: TColor;\r\n r1, r2, g1, g2, b1, b2: Byte;\r\n R, G, B: Byte;\r\n Cnt: Integer;\r\n YDelta: Integer;\r\nbegin\r\n C1 := FromColor;\r\n R1 := GetRValue(C1);\r\n G1 := GetGValue(C1);\r\n B1 := GetBValue(C1);\r\n\r\n C2 := ToColor;\r\n R2 := GetRValue(C2);\r\n G2 := GetGValue(C2);\r\n B2 := GetBValue(C2);\r\n\r\n YDelta := Rect.Bottom - Rect.Top;\r\n if YDelta <= 0 then\r\n Exit;\r\n dr := (R2 - R1) / YDelta;\r\n dg := (G2 - G1) / YDelta;\r\n DB := (B2 - B1) / YDelta;\r\n\r\n Cnt := 0;\r\n for Y := Rect.Top to Rect.Bottom - 1 do\r\n begin\r\n R := R1 + Ceil(dr * Cnt);\r\n G := G1 + Ceil(dg * Cnt);\r\n B := B1 + Ceil(DB * Cnt);\r\n\r\n Canvas.Pen.Color := RGB(R, G, B);\r\n Canvas.MoveTo(Rect.Left, Y);\r\n Canvas.LineTo(Rect.Right, Y);\r\n Inc(Cnt);\r\n end;\r\nend;\r\n\r\n//=== { TJvChartGradientBar } ================================================\r\n\r\nconstructor TJvChartGradientBar.Create(Owner: TJvChart);\r\nbegin\r\n inherited Create;\r\n FOwner := Owner;\r\n FVisible := false;\r\n FColor := clWhite;\r\n FGradDirection := grNone;\r\n FGradColor := FColor;\r\n FPenStyle := psClear;\r\n FPenColor := clNone;\r\nend;\r\n\r\nprocedure TJvChartGradientBar.SetVisible(AVisible: Boolean);\r\nbegin\r\n if AVisible <> FVisible then\r\n begin\r\n FVisible := AVisible;\r\n if Assigned(FOwner) and not FOwner.FUpdating then\r\n FOwner.Invalidate;\r\n end\r\nend;\r\n\r\nprocedure TJvChartGradientBar.SetColor(AColor: TColor);\r\nbegin\r\n if AColor <> FColor then\r\n begin\r\n FColor := AColor;\r\n if Assigned(FOwner) and not FOwner.FUpdating then\r\n FOwner.Invalidate;\r\n end\r\nend;\r\n\r\nprocedure TJvChartGradientBar.SetGradientColor(AColor: TColor);\r\nbegin\r\n if AColor <> FGradColor then\r\n begin\r\n FGradColor := AColor;\r\n if Assigned(FOwner) and not FOwner.FUpdating then\r\n FOwner.Invalidate;\r\n end\r\nend;\r\n\r\nprocedure TJvChartGradientBar.SetGradientType(AType: TJvChartGradientDirection);\r\nbegin\r\n if AType <> FGradDirection then\r\n begin\r\n FGradDirection := AType;\r\n if Assigned(FOwner) and not FOwner.FUpdating then\r\n FOwner.Invalidate;\r\n end\r\nend;\r\n\r\n//=== { TJvChartHorizontalBar } ==============================================\r\n\r\nconstructor TJvChartHorizontalBar.Create(Owner: TJvChart);\r\nbegin\r\n inherited Create(Owner);\r\n FYTop := 0;\r\n FYBottom := 0;\r\nend;\r\n\r\n//=== { TJvChartVerticalBar } ================================================\r\n\r\nconstructor TJvChartVerticalBar.Create(Owner: TJvChart);\r\nbegin\r\n inherited Create(Owner);\r\n FXLeft := 0;\r\n FXRight := 0;\r\nend;\r\n\r\n//=== {TJvChartFloatingMarker} ===============================================\r\n\r\nconstructor TJvChartFloatingMarker.Create(Owner: TJvChart);\r\nbegin\r\n inherited Create;\r\n FOwner := Owner;\r\n FVisible := False; // NOT visible by default.\r\n FIndex := -1; // not yet set.\r\n FLineToMarker := -1; // Don't draw a line to connect to another marker.\r\n //FYPositionToPen := -1; // Don't copy FYPosition from the pen values.\r\n FMarkerColor := clRed;\r\n FMarker := pmkDiamond; // default is diamond marker.\r\n FLineStyle := psDot;\r\n FLineColor := clBlue;\r\n //FCaptionBorderStyle := psClear;\r\n FXDragMin := -1; // no limit.\r\n FXDragMax := -1; // no limit.\r\n FRawXPosition := -1;\r\n FRawYPosition := -1;\r\n FLineWidth := 1;\r\n //FXPosition := 0;\r\n //FYPosition := 0.0;\r\nend;\r\n\r\nprocedure TJvChartFloatingMarker.Assign(Source: TPersistent); // NEW 2007.\r\nvar\r\n Src: TJvChartFloatingMarker;\r\nbegin\r\n // don't assign FOwner, FIndex, etc.\r\n //FRawXPosition {don't copy}\r\n //FRawYPosition {don't copy}\r\n if Source is TJvChartFloatingMarker then\r\n begin\r\n Src := TJvChartFloatingMarker(Source);\r\n\r\n FCaption := Src.Caption;\r\n FTag := Src.Tag;\r\n\r\n //FYPositionToPen := Src.YPositionToPen;\r\n FMarkerColor := Src.MarkerColor;\r\n FMarker := Src.Marker;\r\n FLineStyle := Src.LineStyle;\r\n FLineColor := Src.LineColor;\r\n //FCaptionBorderStyle := psClear;\r\n FXDragMin := Src.XDragMin;\r\n FXDragMax := Src.XDragMax;\r\n\r\n FLineWidth := Src.LineWidth;\r\n FLineToMarker := Src.LineToMarker;\r\n FLineVertical := Src.LineVertical;\r\n\r\n FCaptionColor := Src.CaptionColor;\r\n FCaptionPosition := Src.CaptionPosition;\r\n FCaptionBoxed := Src.CaptionBoxed;\r\n\r\n {don't use internal property set for these:}\r\n XPosition := Src.XPosition;\r\n YPosition := Src.YPosition;\r\n Visible := Src.Visible;\r\n end;\r\nend;\r\n\r\nprocedure TJvChartFloatingMarker.SetCaption(ACaption: string);\r\nbegin\r\n if ACaption <> FCaption then\r\n begin\r\n FCaption := ACaption;\r\n if Assigned(FOwner) and FVisible then\r\n if not FOwner.FUpdating then\r\n FOwner.Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvChartFloatingMarker.SetCaptionColor(const Value: TColor);\r\nbegin\r\n FCaptionColor := Value;\r\nend;\r\n\r\nprocedure TJvChartFloatingMarker.SetXPosition(XPos: Integer); // should invalidate the chart (FOwner) if changed.\r\nbegin\r\n if XPos <> FXPosition then\r\n begin\r\n FXPosition := XPos;\r\n if Assigned(FOwner) and FVisible then\r\n if not FOwner.FUpdating then\r\n FOwner.Invalidate;\r\n end\r\nend;\r\n\r\nprocedure TJvChartFloatingMarker.SetYPosition(YPos: Double); // should invalidate the chart (FOwner) if changed.\r\nbegin\r\n if YPos <> FYPosition then\r\n begin\r\n FYPosition := YPos;\r\n if Assigned(FOwner) and FVisible then\r\n if not FOwner.FUpdating then\r\n FOwner.Invalidate;\r\n end\r\nend;\r\n\r\nprocedure TJvChartFloatingMarker.SetVisible(AVisible: Boolean);\r\nbegin\r\n if AVisible <> FVisible then\r\n begin\r\n FVisible := AVisible;\r\n if Assigned(FOwner) then\r\n if not FOwner.FUpdating then\r\n FOwner.Invalidate;\r\n end\r\nend;\r\n\r\n//=== { TJvChartData } =======================================================\r\n\r\nconstructor TJvChartData.Create;\r\n{$IFDEF TJVCHART_ARRAY_OF_ARRAY}\r\nvar\r\n I: Integer;\r\n{$ENDIF TJVCHART_ARRAY_OF_ARRAY}\r\nbegin\r\n inherited Create;\r\n FPenCount := DEFAULT_PEN_COUNT; // Can never set less than one inside TJvChartData!\r\n {$IFDEF TJVCHART_ARRAY_OF_ARRAY}\r\n // FPenCount must be valid here:\r\n for I := 0 to DEFAULT_PEN_COUNT do\r\n Grow(I, DEFAULT_VALUE_COUNT);\r\n {$ELSE}\r\n Grow(DEFAULT_PEN_COUNT, DEFAULT_VALUE_COUNT);\r\n {$ENDIF TJVCHART_ARRAY_OF_ARRAY}\r\nend;\r\n\r\ndestructor TJvChartData.Destroy;\r\n{$IFDEF TJVCHART_ARRAY_OF_ARRAY}\r\nvar\r\n I: Integer;\r\n{$ENDIF TJVCHART_ARRAY_OF_ARRAY}\r\nbegin\r\n {$IFDEF TJVCHART_ARRAY_OF_ARRAY}\r\n for I := 0 to FDataAlloc - 1 do\r\n Finalize(FData[I]);\r\n {$ENDIF TJVCHART_ARRAY_OF_ARRAY}\r\n Finalize(FData); // Free array.\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJvChartData.GetValue(Pen, ValueIndex: Integer): Double;\r\n{$IFDEF TJVCHART_ARRAY_OF_ARRAY}\r\nbegin\r\n Assert(ValueIndex >= 0);\r\n Grow(Pen, ValueIndex);\r\n Result := FData[ValueIndex, Pen]; // This will raise EInvalidOP for NaN values.\r\nend;\r\n{$ELSE}\r\nvar\r\n Idx: Integer;\r\nbegin\r\n // Grow base array\r\n if (Pen < 0) or (Pen >= FPenCount) then\r\n Result := NaN\r\n else\r\n begin\r\n Assert(FPenCount > 0);\r\n Idx := (ValueIndex * FPenCount) + Pen;\r\n\r\n if (Idx < 0) or (Idx > CHART_SANITY_LIMIT) then // Sanity check!\r\n raise ERangeError.CreateRes(@RsEDataIndexTooLargeProbablyAnInternal);\r\n\r\n if Idx >= Length(FData) then\r\n Grow(Pen, ValueIndex);\r\n Result := FData[Idx];\r\n end;\r\nend;\r\n{$ENDIF TJVCHART_ARRAY_OF_ARRAY}\r\n\r\nprocedure TJvChartData.SetValue(Pen, ValueIndex: Integer; NewValue: Double);\r\n{$IFDEF TJVCHART_ARRAY_OF_ARRAY}\r\nbegin\r\n // Grow base array\r\n Grow(Pen, ValueIndex);\r\n FData[ValueIndex, Pen] := NewValue;\r\n if ValueIndex >= FValueCount then\r\n begin\r\n Grow(Pen, ValueIndex + 1);\r\n FData[ValueIndex + 1, Pen] := NewValue; // Workaround for a graphical bug. Sorry.\r\n FValueCount := ValueIndex + 1;\r\n end;\r\nend;\r\n{$ELSE}\r\nvar\r\n Idx: Integer;\r\nbegin\r\n Assert(FPenCount > 0);\r\n\r\n // Grow base array\r\n if (Pen < 0) or (Pen >= FPenCount) then\r\n raise ERangeError.CreateRes(@RsEPenIndexInvalid);\r\n\r\n Idx := (ValueIndex * FPenCount) + Pen;\r\n\r\n if (Idx < 0) or (Idx > CHART_SANITY_LIMIT) then // Sanity check!\r\n raise ERangeError.CreateRes(@RsEDataIndexTooLargeProbablyAnInternal);\r\n\r\n if Idx >= Length(FData) then\r\n Grow(Pen, ValueIndex);\r\n FData[Idx] := NewValue;\r\n\r\n if ValueIndex >= FValueCount then\r\n FValueCount := ValueIndex + 1;\r\nend;\r\n{$ENDIF TJVCHART_ARRAY_OF_ARRAY}\r\n\r\nfunction TJvChartData.GetTimestamp(ValueIndex: Integer): TDateTime;\r\nbegin\r\n if (ValueIndex < 0) or (ValueIndex >= Length(FTimeStamp)) then\r\n Result := 0.0 // null datetime\r\n else\r\n Result := FTimeStamp[ValueIndex];\r\nend;\r\n\r\nprocedure TJvChartData.SetEndDateTime(const Value: TDateTime);\r\nbegin\r\n FEndDateTime := Value;\r\nend;\r\n\r\nprocedure TJvChartData.SetStartDateTime(const Value: TDateTime);\r\nbegin\r\n FStartDateTime := Value;\r\nend;\r\n\r\nprocedure TJvChartData.SetTimestamp(ValueIndex: Integer; AValue: TDateTime);\r\nbegin\r\n if ValueIndex < 0 then\r\n Exit;\r\n if ValueIndex >= Length(FTimeStamp) then\r\n SetLength(FTimeStamp, ValueIndex + 1);\r\n FTimeStamp[ValueIndex] := AValue;\r\nend;\r\n\r\nprocedure TJvChartData.Scroll;\r\n{$IFDEF TJVCHART_ARRAY_OF_ARRAY}\r\nvar\r\n I, J: Integer;\r\nbegin\r\n if FValueCount < 2 then\r\n begin\r\n Clear;\r\n Exit;\r\n end;\r\n { ULTRA SLOW BUT NON-CRASHING Version }\r\n for I := 0 to FValueCount - 1 do\r\n begin\r\n for J := 0 to Length(FData[I]) - 1 do\r\n FData[I, J] := FData[I + 1, J];\r\n SetTimestamp(I, GetTimestamp(I + 1));\r\n end;\r\n FTimeStamp[FValueCount - 1] := 0;\r\n // Check we didn't Break the heap:\r\nend;\r\n{$ELSE}\r\nvar\r\n T: Integer;\r\n Idx: Integer;\r\nbegin\r\n if FValueCount > FPenCount then\r\n begin\r\n Assert(FPenCount > 0);\r\n Idx := FValueCount * FPenCount;\r\n\r\n // Yeah, I wish:\r\n //System.Move( {Source} FData[FPenCount], {Dest} FData[0], Idx-FPenCount);\r\n for T := 0 to Idx - FPenCount do\r\n FData[T] := FData[T + FPenCount];\r\n\r\n for T := Idx - FPenCount to Idx - 1 do\r\n begin\r\n if T > Length(FData) then\r\n Break;\r\n FData[T] := FClearToValue;\r\n end;\r\n //Dec(FValueCount,FPenCount);\r\n end\r\n else\r\n begin\r\n FPenCount := 0;\r\n Clear;\r\n end;\r\nend;\r\n{$ENDIF TJVCHART_ARRAY_OF_ARRAY}\r\n\r\nprocedure TJvChartData.PreGrow(Pen, ValueIndex: Integer);\r\n{$IFDEF TJVCHART_ARRAY_OF_ARRAY}\r\nvar\r\n T: Integer;\r\nbegin\r\n if Length(FData) < ValueIndex then\r\n SetLength(FData, ValueIndex);\r\n for T := 0 to ValueIndex - 1 do\r\n SetLength(FData[T], Pen);\r\n FDataAlloc := ValueIndex;\r\nend;\r\n{$ELSE}\r\nbegin\r\n if Pen > FPenCount then\r\n FPenCount := Pen;\r\n Grow(Pen, ValueIndex);\r\n FDataAlloc := ValueIndex;\r\nend;\r\n{$ENDIF TJVCHART_ARRAY_OF_ARRAY}\r\n\r\n{$IFDEF TJVCHART_ARRAY_OF_ARRAY}\r\nprocedure TJvChartData.Grow(Pen, ValueIndex: Integer);\r\nvar\r\n I, J, OldLength: Integer;\r\nbegin\r\n if (Pen < 0) or (ValueIndex < 0) then\r\n raise ERangeError.CreateRes(@RsEDataIndexCannotBeNegative);\r\n if (Pen > CHART_SANITY_LIMIT) or (ValueIndex > CHART_SANITY_LIMIT) then\r\n raise ERangeError.CreateRes(@RsEDataIndexTooLargeProbablyAnInternal);\r\n\r\n if ValueIndex >= FDataAlloc then\r\n begin\r\n //--------------------------------------------------------\r\n // Performance tweak: Uses more memory but makes JvChart\r\n // much faster!\r\n // We Double our allocation unit size\r\n // until we start to get Really Huge, then grow in chunks!\r\n //--------------------------------------------------------\r\n if ValueIndex < 640000 then\r\n FDataAlloc := ValueIndex * 2 // Double in size\r\n else\r\n FDataAlloc := ValueIndex + 64000;\r\n\r\n OldLength := Length(FData);\r\n SetLength(FData, FDataAlloc);\r\n\r\n // new: If we set FClearToValue to NaN, special handling in growing arrays:\r\n if IsNaN(FClearToValue) then\r\n for I := OldLength to FDataAlloc - 1 do\r\n for J := 0 to Length(FData[I]) - 1 do\r\n FData[I][J] := FClearToValue; // XXX Debug me!\r\n\r\n end;\r\n if Pen >= Length(FData[ValueIndex]) then\r\n begin\r\n OldLength := Length(FData[ValueIndex]);\r\n SetLength(FData[ValueIndex], Pen + 1);\r\n if IsNaN(FClearToValue) then\r\n begin\r\n for I := OldLength to FDataAlloc - 1 do\r\n begin\r\n Assert(Length(FData) > ValueIndex);\r\n if (Length(FData[ValueIndex]) < FDataAlloc) then\r\n SetLength(FData[ValueIndex], FDataAlloc); // Safety code!\r\n FData[ValueIndex][I] := FClearToValue; // XXX Debug me!\r\n end;\r\n end;\r\n end;\r\nend;\r\n{$ELSE}\r\nprocedure TJvChartData.Grow(Pen, ValueIndex: Integer);\r\nvar\r\n N, Idx: Integer;\r\n OldLen: Integer;\r\nbegin\r\n Assert(Assigned(Self));\r\n Assert(FPenCount > 0);\r\n Idx := (ValueIndex + 1) * FPenCount;\r\n OldLen := Length(FData);\r\n if Idx >= OldLen then\r\n begin\r\n Idx := Idx + 1024; // Add 1024 floats (8k) headroom.\r\n SetLength(FData, Idx + 1);\r\n for N := OldLen to Idx do\r\n FData[N] := FClearToValue;\r\n end;\r\n FDataAlloc := Length(FData);\r\nend;\r\n{$ENDIF TJVCHART_ARRAY_OF_ARRAY}\r\n\r\nfunction TJvChartData.DebugStr(ValueIndex: Integer): string; // dump all pens for particular valueindex, as string.\r\nvar\r\n S: string;\r\n I: Integer;\r\n LValue: Double;\r\nbegin\r\n if (ValueIndex < 0) or (ValueIndex >= FDataAlloc) then\r\n Exit;\r\n\r\n if Timestamp[ValueIndex] > 0.0 then\r\n S := FormatDateTime('hh:nn:ss ', Timestamp[ValueIndex]);\r\n for I := 0 to FPenCount - 1 do\r\n begin\r\n LValue := GetValue(I, ValueIndex);\r\n if IsNaN(LValue) then\r\n S := S + '-'\r\n else\r\n S := S + Format('%5.2f', [LValue]);\r\n\r\n if I < FPenCount - 1 then\r\n S := S + ', '\r\n end;\r\n Result := S;\r\nend;\r\n\r\nprocedure TJvChartData.Clear; // Resets FValuesCount/FPenCount to zero. Zeroes everything too, just for good luck.\r\n{$IFDEF TJVCHART_ARRAY_OF_ARRAY}\r\nvar\r\n I, J: Integer;\r\nbegin\r\n for I := 0 to FDataAlloc - 1 do\r\n for J := 0 to Length(FData[I]) - 1 do\r\n FData[I, J] := FClearToValue;\r\n FValueCount := 0;\r\nend;\r\n{$ELSE}\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := 0 to Length(FData) - 1 do\r\n FData[I] := FClearToValue;\r\nend;\r\n{$ENDIF TJVCHART_ARRAY_OF_ARRAY}\r\n\r\nprocedure TJvChartData.ClearPenValues; // Clears all pen values to NaN but does not reset pen definitions etc.\r\n{$IFDEF TJVCHART_ARRAY_OF_ARRAY}\r\nvar\r\n I, J: Integer;\r\nbegin\r\n for I := 0 to FDataAlloc - 1 do\r\n for J := 0 to Length(FData[I]) - 1 do\r\n FData[I, J] := ClearToValue; // 0.0;\r\nend;\r\n{$ELSE}\r\nbegin\r\n Clear;\r\nend;\r\n{$ENDIF TJVCHART_ARRAY_OF_ARRAY}\r\n\r\n//=== { TJvChartYAxisOptions } ===============================================\r\n\r\nconstructor TJvChartYAxisOptions.Create(Owner: TJvChartOptions);\r\nbegin\r\n inherited Create;\r\n FOwner := Owner;\r\n\r\n FMarkerValueDecimals := -1; // -1 = default (automatic decimals)\r\n\r\n FYLegends := TStringList.Create;\r\n FMaxYDivisions := 20;\r\n FMinYDivisions := 5;\r\n FYDivisions := 10;\r\n FDefaultYLegends := JvDefaultYLegends;\r\nend;\r\n\r\ndestructor TJvChartYAxisOptions.Destroy;\r\nbegin\r\n FYLegends.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvChartYAxisOptions.Clear;\r\nbegin\r\n YDivisions := DefaultYLegends;\r\n YLegends.Clear;\r\n Normalize;\r\nend;\r\n\r\n\r\nprocedure TJvChartYAxisOptions.Assign(Source:TPersistent);// Warren added sept 2009\r\nvar\r\n src:TJvChartYAxisOptions;\r\nbegin\r\n //inherited Assign(Source); //raises exception!\r\n if Source is TJvChartYAxisOptions then begin\r\n src := TJvChartYAxisOptions(Source);\r\n FYLegends.Assign(src.YLegends);\r\n\r\n FMarkerValueDecimals := src.MarkerValueDecimals;\r\n FYDivisions := src.YDivisions;\r\n FMaxYDivisions := src.MaxYDivisions;\r\n FMinYDivisions := src.MinYDivisions;\r\n FYLegendDecimalPlaces:= src.YLegendDecimalPlaces;\r\n FDefaultYLegends := src.DefaultYLegends;\r\n\r\n //FYGap : not copied!\r\n //FYGap1 : not copied!\r\n //FYPixelGap: not copied!\r\n YMin := src.YMin; // always first!\r\n YMax := src.YMax; // property set method calls Normalize!\r\n // Always set YMax last!\r\n\r\n end;\r\nend;\r\n\r\nprocedure TJvChartYAxisOptions.Normalize;\r\nvar\r\n // CheckYDivisions: Integer;\r\n VC: Integer;\r\nbegin\r\n if FYMax - FYMin < 0.00001 then // make sure that there is some difference here!\r\n FYMax := FYMin + 10;\r\n\r\n if (DefaultYLegends > 0) and (YDivisions = 0) then\r\n YDivisions := DefaultYLegends;\r\n\r\n // DON'T KNOW WHY WE NEEDED THIS. REMOVED IT.\r\n (*\r\nif (YGap>0.0) then\r\nbegin\r\n CheckYDivisions := Round((YMax + (YGap - 1)) / YGap);\r\n if CheckYDivisions<>YDivisions then\r\n YDivisions :=CheckYDivisions;\r\nend;*)\r\n\r\n VC := YDivisions;\r\n if VC < 1 then\r\n VC := 1;\r\n FYGap := (YMax - YMin) / VC;\r\n FYGap1 := ((YMax - YMin) + 1) / VC;\r\n\r\n YPixelGap := (FOwner.YEnd - 1) / VC; // Vertical Pixels Per Value Division counter.\r\n\r\n (*CheckYDivisions := Round(((YMax-YMin) + (YGap - 1)) / YGap);\r\n if CheckYDivisions <> YDivisions then\r\n YDivisions := CheckYDivisions; *)\r\n\r\n //---------------------------------------------------------------------\r\n // Here's the normalization section:\r\n // !!!The 10 and 20 here should be properties settable by the user!!!\r\n //---------------------------------------------------------------------\r\n if YDivisions < MinYDivisions then\r\n begin\r\n YDivisions := MinYDivisions;\r\n FYGap := (YMax - YMin) / YDivisions;\r\n end\r\n else\r\n if YDivisions > MaxYDivisions then\r\n begin\r\n YDivisions := MaxYDivisions;\r\n FYGap := (YMax - YMin) / YDivisions;\r\n end;\r\nend;\r\n\r\nprocedure TJvChartYAxisOptions.SetYMin(NewYMin: Double);\r\nbegin\r\n if IsNaN(NewYMin) then\r\n Exit;\r\n\r\n try\r\n if NewYMin = FYMin then\r\n Exit;\r\n except\r\n {$IFDEF DEBUGINFO_ON}\r\n OutputDebugString('TJvChartYAxisOptions.SetYMin-WTF?');\r\n {$ENDIF DEBUGINFO_ON}\r\n Exit;\r\n end;\r\n\r\n FYMin := NewYMin;\r\n\r\n if not Assigned(FOwner) then\r\n Exit;\r\n if not Assigned(FOwner.FOwner) then\r\n Exit;\r\n if csLoading in FOwner.FOwner.ComponentState then\r\n Exit;\r\n\r\n // Rework other values around new YMin:\r\n Normalize;\r\n FOwner.NotifyOptionsChange;\r\n {NEW: Auto-Regenerate Y Axis Labels}\r\n if Assigned(FYLegends) then\r\n if FYLegends.Count > 0 then\r\n begin\r\n FYLegends.Clear;\r\n FOwner.FOwner.PrimaryYAxisLabels;\r\n end;\r\nend;\r\n\r\nprocedure TJvChartYAxisOptions.SetYMax(NewYMax: Double);\r\nbegin\r\n if IsNaN(NewYMax) then\r\n Exit;\r\n\r\n if NewYMax = FYMax then\r\n Exit;\r\n\r\n FYMax := NewYMax;\r\n\r\n if not Assigned(FOwner) then\r\n Exit;\r\n if not Assigned(FOwner.FOwner) then\r\n Exit;\r\n if csLoading in FOwner.FOwner.ComponentState then\r\n Exit;\r\n\r\n // Rework other values around new YMax:\r\n Normalize;\r\n FOwner.NotifyOptionsChange;\r\n\r\n {NEW: Auto-Regenerate Y Axis Labels}\r\n if Assigned(FYLegends) then\r\n if FYLegends.Count > 0 then\r\n begin\r\n FYLegends.Clear;\r\n FOwner.FOwner.PrimaryYAxisLabels;\r\n end;\r\nend;\r\n\r\n(*procedure TJvChartYAxisOptions.SetYGap(newYgap: Double);\r\nbegin\r\n if (FYGap < 5.0) and (YMax>100) then\r\n begin\r\n OutputDebugString('Bug');\r\n end;\r\n\r\n FYGap := newYGap;\r\n // TODO: Fire event, and cause a refresh, recalculate other\r\n // dependant fields that are calculated from the YGap.\r\n FOwner.NotifyOptionsChange; // Fire event before we auto-format graph. Allows some customization to occur here.\r\nend;\r\n *)\r\n\r\nfunction TJvChartYAxisOptions.GetYLegends: TStrings;\r\nbegin\r\n Result := TStrings(FYLegends);\r\nend;\r\n\r\nprocedure TJvChartYAxisOptions.SetYLegends(Value: TStrings);\r\nbegin\r\n FYLegends.Assign(Value);\r\n if Assigned(FOwner) then\r\n FOwner.NotifyOptionsChange; // Fire event before we auto-format graph. Allows some customization to occur here.\r\nend;\r\n\r\nprocedure TJvChartYAxisOptions.SetYDivisions(AValue: Integer);\r\nbegin\r\n FYDivisions := AValue;\r\n\r\n if not Assigned(FOwner) then\r\n Exit;\r\n if not Assigned(FOwner.FOwner) then\r\n Exit;\r\n if csLoading in FOwner.FOwner.ComponentState then\r\n Exit;\r\n\r\n // Rework other values around new YMax:\r\n Normalize;\r\n FOwner.NotifyOptionsChange;\r\nend;\r\n\r\n//=== { TJvChartOptions } ====================================================\r\n\r\nconstructor TJvChartOptions.Create(Owner: TJvChart);\r\nbegin\r\n inherited Create;\r\n FOwner := Owner;\r\n\r\n FAutoUpdateGraph := True;\r\n\r\n FPrimaryYAxis := TJvChartYAxisOptions.Create(Self);\r\n FSecondaryYAxis := TJvChartYAxisOptions.Create(Self);\r\n\r\n FXAxisDivisionMarkers := True; //default property.\r\n FYAxisDivisionMarkers := True; //default property.\r\n\r\n SetLength(FPenColors, 12);\r\n FPenColors[0] := clLime;\r\n FPenColors[1] := clRed;\r\n FPenColors[2] := clBlue;\r\n FPenColors[3] := clYellow;\r\n FPenColors[4] := clMaroon;\r\n FPenColors[5] := clGreen;\r\n FPenColors[6] := clOlive;\r\n FPenColors[7] := clNavy;\r\n FPenColors[8] := clPurple;\r\n FPenColors[9] := clTeal;\r\n FPenColors[10] := clFuchsia;\r\n FPenColors[11] := clAqua;\r\n\r\n FChartKind := ckChartLine;\r\n\r\n FPenCount := 1;\r\n\r\n FLegend := clChartLegendNone; //default Legend is None.\r\n\r\n // Create TStringList property objects\r\n FXLegends := TStringList.Create;\r\n FPenLegends := TStringList.Create;\r\n FPenUnit := TStringList.Create;\r\n // dynamic array setup\r\n SetLength(FAverageValue, DEFAULT_VALUE_COUNT);\r\n\r\n // Defaults for Graph Options:\r\n\r\n FMarkerSize := JvChartDefaultMarkerSize;\r\n FXStartOffset := 45; {DEFAULT}\r\n FYStartOffset := 10;\r\n FTitle := '';\r\n // FXAxisHeader := 'X';\r\n // FYAxisHeader := 'Y';\r\n\r\n FPaperColor := clWhite;\r\n FAxisLineColor := clBlack;\r\n FAverageLineColor := JvDefaultAvgLineColor;\r\n FDivisionLineColor := JvDefaultDivisionLineColor; // NEW!\r\n FShadowColor := JvDefaultShadowColor; //NEW!\r\n\r\n FHeaderFont := TFont.Create;\r\n FLegendFont := TFont.Create;\r\n FAxisFont := TFont.Create;\r\n\r\n //FShowLegend := True;\r\n FMouseEdit := True;\r\n FMouseInfo := True;\r\n FLegendWidth := 150;\r\n FPenLineWidth := 1;\r\n FAxisLineWidth := 3;\r\n\r\n FXValueCount := 10;\r\n\r\n FXAxisLegendSkipBy := 1;\r\n FXLegendHoriz := 0;\r\n\r\n FHintColor := JvDefaultHintColor;\r\nend;\r\n\r\ndestructor TJvChartOptions.Destroy;\r\nbegin\r\n FreeAndNil(FPrimaryYAxis); //memory leak fix SEPT 21, 2004.WAP.\r\n FreeAndNil(FSecondaryYAxis); //memory leak fix SEPT 21, 2004. WAP.\r\n\r\n FreeAndNil(FXLegends);\r\n FreeAndNil(FPenLegends);\r\n FreeAndNil(FPenUnit);\r\n\r\n FreeAndNil(FHeaderFont);\r\n FreeAndNil(FLegendFont);\r\n FreeAndNil(FAxisFont);\r\n\r\n inherited Destroy;\r\nend;\r\n\r\n\r\nprocedure TJvChartOptions.Assign(Source: TPersistent); // Warren added sept 2009\r\nvar\r\n src:TJvChartOptions;\r\n t:Integer;\r\nbegin\r\n// inherited Assign(Source); {raises exception!}\r\n if (Source is TJvChartOptions) then begin\r\n src := Source as TJvChartOptions;\r\n\r\n\r\n FLegend := src.Legend;//: TJvChartLegend;\r\n\r\n FHeaderFont.Assign(src.HeaderFont);\r\n FLegendFont.Assign(src.LegendFont);\r\n FAxisFont.Assign(src.AxisFont);\r\n FPenLegends.Assign(src.PenLegends);\r\n FPenUnit.Assign(src.PenUnit);\r\n FXLegends.Assign(src.XLegends);\r\n\r\n FChartKind := src.ChartKind;\r\n FTitle := src.Title;\r\n FNoDataMessage := src.NoDataMessage;\r\n FYAxisHeader := src.YAxisHeader;\r\n FYAxisDivisionMarkers := src.YAxisDivisionMarkers;\r\n FXAxisDivisionMarkers := src.XAxisDivisionMarkers; \r\n FXAxisHeader := src.XAxisHeader;\r\n\r\n FXLegendMaxTextWidth := src.XLegendMaxTextWidth;\r\n FXAxisValuesPerDivision:= src.XAxisValuesPerDivision;\r\n FXAxisLegendSkipBy := src.XAxisLegendSkipBy;\r\n FXLegendHoriz := src.FXLegendHoriz;\r\n FXAxisLabelAlignment := src.XAxisLabelAlignment;\r\n FXAxisDateTimeMode := src.XAxisDateTimeMode;\r\n FXAxisDateTimeFormat := src.XAxisDateTimeFormat;\r\n FXAxisDateTimeDivision := src.XAxisDateTimeDivision;\r\n FDateTimeFormat := src.DateTimeFormat;\r\n FXValueCount := src.XValueCount;\r\n FPenCount := src.PenCount;\r\n\r\n // Array copies\r\n SetLength(FPenColors, Length(src.FPenColors));\r\n for t := 0 to Length(FPenColors)-1 do\r\n FPenColors[t] := src.FPenColors[t];\r\n\r\n SetLength(FPenStyles, Length(src.FPenStyles));\r\n for t := 0 to Length(FPenStyles)-1 do\r\n FPenStyles[t] := src.FPenStyles[t];\r\n\r\n SetLength(FPenMarkerKind, Length(src.FPenMarkerKind));\r\n for t := 0 to Length(FPenMarkerKind)-1 do\r\n FPenMarkerKind[t] := src.FPenMarkerKind[t];\r\n\r\n SetLength(FPenSecondaryAxisFlag, Length(src.FPenSecondaryAxisFlag));\r\n for t := 0 to Length(FPenSecondaryAxisFlag)-1 do\r\n FPenSecondaryAxisFlag[t] := src.FPenSecondaryAxisFlag[t];\r\n\r\n SetLength(FPenValueLabels, Length(src.FPenValueLabels));\r\n for t := 0 to Length(FPenValueLabels)-1 do\r\n FPenValueLabels[t] := src.FPenValueLabels[t];\r\n\r\n //SetLength(FAverageValue,Length(src.FAverageValue));\r\n // no copy of averages!\r\n\r\n FXOrigin := src.XOrigin;\r\n FYOrigin := src.YOrigin;\r\n FXStartOffset := src.XStartOffset;\r\n FYStartOffset := src.YStartOffset;\r\n FXEnd := src.XEnd;\r\n FYEnd := src.YEnd;\r\n FMarkerSize := src.MarkerSize;\r\n { more design time }\r\n FLegendWidth := src.LegendWidth;\r\n FLegendRowCount := src.LegendRowCount;\r\n FAutoUpdateGraph := src.AutoUpdateGraph;\r\n FMouseEdit := src.MouseEdit;\r\n FMouseDragObjects := src.MouseDragObjects;\r\n FMouseInfo := src.MouseInfo;\r\n\r\n FPenLineWidth := src.PenLineWidth;\r\n FAxisLineWidth := src.AxisLineWidth;\r\n\r\n //COLORS:\r\n FPaperColor := src.PaperColor;\r\n FDivisionLineColor := src.DivisionLineColor;\r\n FShadowColor := src.ShadowColor;\r\n FAxisLineColor := src.AxisLineColor;\r\n FHintColor := src.HintColor;\r\n FAverageLineColor := src.AverageLineColor;\r\n FCursorColor := src.CursorColor;\r\n\r\n FCursorStyle := src.CursorStyle;\r\n FGradientColor := src.GradientColor;\r\n FGradientDirection := src.GradientDirection;\r\n\r\n // more internal dynamically calculated stuff:\r\n //FXAxisDateTimeFirstMarker not copied\r\n //FXAxisDateTimeSkipBy not copied\r\n //FXAxisDateTimeLines not copied\r\n //FXGap,FYGap: not copied.\r\n\r\n\r\n\r\n // Second last:\r\n FSecondaryYAxis.Assign(src.SecondaryYAxis);\r\n\r\n // Last!\r\n FPrimaryYAxis.Assign(src.PrimaryYAxis);\r\n\r\n // re-plot chart:\r\n NotifyOptionsChange;\r\n end;\r\n\r\nend;\r\nprocedure TJvChartOptions.NotifyOptionsChange;\r\nbegin\r\n if Assigned(FOwner) then\r\n FOwner.NotifyOptionsChange;\r\nend;\r\n\r\n// Each pen can be associated with either the primary or secondary axis,\r\n// this function decides which axis to return depending on the pen configuration:\r\n\r\nfunction TJvChartOptions.GetPenAxis(Index: Integer): TJvChartYAxisOptions;\r\nbegin\r\n if (Index < 0) or (Index >= Length(FPenSecondaryAxisFlag)) then\r\n Result := FPrimaryYAxis // default\r\n else\r\n if FPenSecondaryAxisFlag[Index] then\r\n Result := FSecondaryYAxis // alternate!\r\n else\r\n Result := FPrimaryYAxis; // default\r\nend;\r\n\r\nprocedure TJvChartOptions.SetChartKind(AKind: TJvChartKind);\r\nbegin\r\n if AKind <> FChartKind then\r\n FChartKind := AKind;\r\nend;\r\n\r\nfunction TJvChartOptions.GetPenMarkerKind(Index: Integer): TJvChartPenMarkerKind;\r\nbegin\r\n if (Index >= 0) and (Index < Length(FPenMarkerKind)) then\r\n Result := FPenMarkerKind[Index]\r\n else\r\n Result := pmkNone;\r\nend;\r\n\r\nprocedure TJvChartOptions.SetPenMarkerKind(Index: Integer; AMarkKind: TJvChartPenMarkerKind);\r\nbegin\r\n if Index >= 0 then\r\n begin\r\n if Index >= Length(FPenMarkerKind) then\r\n SetLength(FPenMarkerKind, Index + 1);\r\n FPenMarkerKind[Index] := AMarkKind;\r\n end;\r\nend;\r\n\r\nfunction TJvChartOptions.GetPenColor(Index: Integer): TColor;\r\nbegin\r\n // Don't check for out of range values, since we use that on purpose in this\r\n // function. Okay, ugly, but it works. -WP.\r\n case Index of\r\n jvChartAverageLineColorIndex:\r\n Result := FAverageLineColor;\r\n jvChartDivisionLineColorIndex: // horizontal and vertical division line color\r\n Result := FDivisionLineColor;\r\n jvChartShadowColorIndex: // legend shadow (light gray)\r\n Result := FShadowColor;\r\n jvChartAxisColorIndex:\r\n Result := FAxisLineColor; // get property.\r\n jvChartHintColorIndex:\r\n Result := FHintColor; // Get property.\r\n jvChartPaperColorIndex:\r\n Result := FPaperColor; // Get property.\r\n else\r\n if Index < jvChartAverageLineColorIndex then\r\n Result := clBtnFace\r\n else\r\n if Index >= 0 then\r\n Result := FPenColors[Index]\r\n else\r\n Result := clNone; // I hope clNone is a good unknown value (ahuser). {{Good enough. -WP.}}\r\n end;\r\nend;\r\n\r\nprocedure TJvChartOptions.SetPenColor(Index: Integer; AColor: TColor);\r\nbegin\r\n if (Index < 0) or (Index >= MAX_PEN) then\r\n raise ERangeError.CreateRes(@RsEChartOptionsPenCountPenCountOutOf);\r\n\r\n if Index >= Length(FPenColors) then\r\n SetLength(FPenColors, Index + 1);\r\n FPenColors[Index] := AColor;\r\nend;\r\n\r\nprocedure TJvChartOptions.SetPenStyle(Index: Integer; APenStyle: TPenStyle);\r\nbegin\r\n if (Index < 0) or (Index >= MAX_PEN) then\r\n raise ERangeError.CreateRes(@RsEChartOptionsPenCountPenCountOutOf);\r\n\r\n if Index >= Length(FPenStyles) then\r\n SetLength(FPenStyles, Index + 1);\r\n FPenStyles[Index] := APenStyle;\r\nend;\r\n\r\nfunction TJvChartOptions.GetPenStyle(Index: Integer): TPenStyle;\r\nbegin\r\n if (Index >= 0) and (Index < Length(FPenStyles)) then\r\n Result := FPenStyles[Index]\r\n else\r\n Result := psSolid;\r\nend;\r\n\r\nfunction TJvChartOptions.GetAverageValue(Index: Integer): Double;\r\nbegin\r\n if Index < 0 then\r\n raise ERangeError.CreateRes(@RsEGetAverageValueIndexNegative);\r\n if Index >= Length(FAverageValue) then\r\n Result := 0.0\r\n else\r\n Result := FAverageValue[Index];\r\nend;\r\n\r\nprocedure TJvChartOptions.SetAverageValue(Index: Integer; AValue: Double);\r\nbegin\r\n if Index < 0 then\r\n raise ERangeError.CreateRes(@RsESetAverageValueIndexNegative);\r\n if Index >= Length(FAverageValue) then\r\n SetLength(FAverageValue, Index + 1);\r\n FAverageValue[Index] := AValue;\r\nend;\r\n\r\nfunction TJvChartOptions.GetPenSecondaryAxisFlag(Index: Integer): Boolean;\r\nbegin\r\n if (Index < 0) or (Index >= Length(FPenSecondaryAxisFlag)) then\r\n Result := False\r\n else\r\n Result := FPenSecondaryAxisFlag[Index];\r\nend;\r\n\r\nprocedure TJvChartOptions.SetPenSecondaryAxisFlag(Index: Integer; NewValue: Boolean);\r\nbegin\r\n if (Index < 0) or (Index >= MAX_PEN) then\r\n raise ERangeError.CreateRes(@RsEChartOptionsPenCountPenCountOutOf);\r\n if Index >= Length(FPenSecondaryAxisFlag) then\r\n SetLength(FPenSecondaryAxisFlag, Index + 1);\r\n FPenSecondaryAxisFlag[Index] := NewValue;\r\nend;\r\n\r\nfunction TJvChartOptions.GetPenValueLabels(Index: Integer): Boolean;\r\nbegin\r\n if (Index < 0) or (Index >= Length(FPenValueLabels)) then\r\n Result := False\r\n else\r\n Result := FPenValueLabels[Index];\r\nend;\r\n\r\nprocedure TJvChartOptions.SetPenValueLabels(Index: Integer; NewValue: Boolean);\r\nbegin\r\n if (Index < 0) or (Index >= MAX_PEN) then\r\n raise ERangeError.CreateRes(@RsEChartOptionsPenCountPenCountOutOf);\r\n\r\n if Index >= Length(FPenValueLabels) then\r\n SetLength(FPenValueLabels, Index + 1);\r\n FPenValueLabels[Index] := NewValue;\r\nend;\r\n\r\nprocedure TJvChartOptions.SetPenCount(Count: Integer);\r\nbegin\r\n if (Count < 0) or (Count >= MAX_PEN) then\r\n raise ERangeError.CreateRes(@RsEChartOptionsPenCountPenCountOutOf);\r\n FPenCount := Count;\r\n SetLength(FPenSecondaryAxisFlag, FPenCount + 1);\r\n // notify data object:\r\n NotifyOptionsChange;\r\nend;\r\n\r\nfunction TJvChartOptions.GetPenLegends: TStrings;\r\nbegin\r\n Result := TStrings(FPenLegends);\r\nend;\r\n\r\nprocedure TJvChartOptions.SetPenLegends(Value: TStrings);\r\nbegin\r\n FPenLegends.Assign(Value);\r\nend;\r\n\r\nfunction TJvChartOptions.GetPenUnit: TStrings;\r\nbegin\r\n Result := TStrings(FPenUnit);\r\nend;\r\n\r\nprocedure TJvChartOptions.SetPenUnit(Value: TStrings);\r\nbegin\r\n FPenUnit.Assign(Value);\r\nend;\r\n\r\nfunction TJvChartOptions.GetXLegends: TStrings;\r\nbegin\r\n Result := TStrings(FXLegends);\r\nend;\r\n\r\nprocedure TJvChartOptions.SetXAxisDateTimeDivision(const Value: Double);\r\nbegin\r\n FXAxisDateTimeDivision := Value;\r\nend;\r\n\r\nprocedure TJvChartOptions.SetXLegends(Value: TStrings);\r\nbegin\r\n FXLegends.Assign(Value);\r\nend;\r\n\r\nprocedure TJvChartOptions.SetHeaderFont(AFont: TFont);\r\nbegin\r\n FHeaderFont.Assign(AFont);\r\nend;\r\n\r\nprocedure TJvChartOptions.SetLegendFont(AFont: TFont);\r\nbegin\r\n FLegendFont.Assign(AFont);\r\nend;\r\n\r\nprocedure TJvChartOptions.SetAxisFont(AFont: TFont);\r\nbegin\r\n FAxisFont.Assign(AFont);\r\nend;\r\n\r\nprocedure TJvChartOptions.SetPrimaryYAxis(AssignFrom: TJvChartYAxisOptions);\r\nbegin\r\n FPrimaryYAxis.Assign(AssignFrom);\r\nend;\r\n\r\nprocedure TJvChartOptions.SetSecondaryYAxis(AssignFrom: TJvChartYAxisOptions);\r\nbegin\r\n FSecondaryYAxis.Assign(AssignFrom);\r\nend;\r\n\r\nprocedure TJvChartOptions.SetPaperColor(AColor: TColor);\r\nbegin\r\n if AColor <> FPaperColor then\r\n begin\r\n FPaperColor := AColor;\r\n if Assigned(FOwner) then\r\n FOwner.Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvChartOptions.SetXStartOffset(Offset: Integer);\r\nbegin\r\n //if not PrintInSession then\r\n // if (Offset < 10) or (Offset > (FOwner.Width div 2)) then\r\n // raise ERangeError.CreateRes(@RsEChartOptionsXStartOffsetValueOutO);\r\n FXStartOffset := Offset;\r\nend;\r\n\r\n//=== { TJvChart } ===========================================================\r\n\r\n{ GRAPH }\r\n{**************************************************************************}\r\n{ call this function : NEVER! }\r\n{**************************************************************************}\r\n\r\nconstructor TJvChart.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner); {by TImage...}\r\n\r\n ControlStyle := ControlStyle + [csOpaque];\r\n // XXX FLICKER REDUCTION: Set ControlStyle properly. -WP. APRIL 2004.\r\n\r\n FPicture := TPicture.Create;\r\n\r\n FCursorPosition := -1; // Invisible until CursorPosition is set >=0 to make it visible.\r\n\r\n FMouseDownHintStrs := TStringList.Create;\r\n\r\n { logical font used for rotating text to show vertical labels }\r\n\r\n FData := TJvChartData.Create;\r\n FAverageData := TJvChartData.Create;\r\n\r\n FFloatingMarker := TObjectList.Create; // NEW: collection of TJvChartFloatingMarker objects.\r\n FFloatingMarker.OwnsObjects := True;\r\n\r\n FHorizontalBars := TObjectList.Create; // NEW: collection of TJvChartFloatingMarker objects.\r\n FHorizontalBars.OwnsObjects := True;\r\n\r\n FVerticalBars := TObjectList.Create; // NEW: collection of TJvChartFloatingMarker objects.\r\n FVerticalBars.OwnsObjects := True;\r\n\r\n FOptions := TJvChartOptions.Create(Self);\r\n CalcYEnd;\r\n\r\n PrintInSession := False;\r\n\r\n FOldYGap := 1;\r\n FOldYOrigin := 0;\r\n FStartDrag := False;\r\n FMouseLegend := False;\r\n FContainsNegative := False;\r\n FMouseValue := 0;\r\n FMousePen := 0;\r\n\r\n {Set default values for component fields...}\r\n\r\n if csDesigning in ComponentState then\r\n begin\r\n // default height and width\r\n if not Assigned(Parent) then\r\n begin\r\n Width := 300;\r\n Height := 300;\r\n end;\r\n end;\r\nend;\r\n\r\n{**************************************************************************}\r\n{ call this function : NEVER! }\r\n{**************************************************************************}\r\n\r\ndestructor TJvChart.Destroy;\r\nbegin\r\n {Add code for destroying my own data...here}\r\n FBitmap.Free;\r\n if Ord(FYFontHandle) <> 0 then\r\n DeleteObject(FYFontHandle); // vertical font object\r\n FreeAndNil(FYFont);\r\n\r\n FreeAndNil(FPicture);\r\n FreeAndNil(FAverageData);\r\n FreeAndNil(FOptions);\r\n FreeAndNil(FData);\r\n\r\n FreeAndNil(FFloatingMarker); // Destroy collection of TJvChartFloatingMarker objects. Destroys contained objects also.\r\n FreeAndNil(FHorizontalBars); // NEW 2007\r\n FreeAndNil(FVerticalBars); // NEW 2007\r\n\r\n FreeAndNil(FMouseDownHintStrs); //new.\r\n\r\n inherited Destroy;\r\nend;\r\n\r\n{Paint helper}\r\n\r\nfunction TJvChart.DestRect: TRect;\r\nbegin\r\n Result.Left := 0;\r\n Result.Top := 0;\r\n Result.Right := GetChartCanvasWidth;\r\n Result.Bottom := GetChartCanvasHeight;\r\nend;\r\n\r\nprocedure TJvChart.Loaded;\r\nbegin\r\n inherited Loaded;\r\n ResizeChartCanvas;\r\nend;\r\n\r\nprocedure TJvChart.Resize;\r\nbegin\r\n inherited Resize;\r\n ResizeChartCanvas;\r\n // Invalidate already happens in ResizeChartCanvas.\r\nend;\r\n\r\n{ PAINT }\r\n\r\nprocedure TJvChart.DesignModePaint;\r\nvar\r\n DesignStr: string;\r\n TW, TH: Integer;\r\n LCanvas: TCanvas;\r\nbegin\r\n LCanvas := GetChartCanvas(false);\r\n\r\n LCanvas.Brush.Color := Options.PaperColor;\r\n LCanvas.Rectangle(0, 0, Width, Height);\r\n\r\n DesignStr := ClassName + RsChartDesigntimeLabel;\r\n\r\n if Options.PrimaryYAxis.YMin >= Options.PrimaryYAxis.YMax then\r\n begin\r\n if Options.PrimaryYAxis.YMax > 0 then\r\n Options.PrimaryYAxis.YMin := 0.0;\r\n end;\r\n\r\n if (Abs(Options.PrimaryYAxis.YMax) < 0.000001) and (Abs(Options.PrimaryYAxis.YMin) < 0.000001) then\r\n Options.PrimaryYAxis.YMax := 10.0; // Reasonable non-zero default, so that charting works!\r\n\r\n Options.PrimaryYAxis.Normalize;\r\n Options.SecondaryYAxis.Normalize;\r\n GraphSetup;\r\n\r\n DrawGradient;\r\n DisplayBars;\r\n\r\n PrimaryYAxisLabels;\r\n GraphXAxis;\r\n GraphXAxisDivisionMarkers;\r\n GraphYAxis;\r\n GraphYAxisDivisionMarkers;\r\n\r\n { designtime component label }\r\n TW := LCanvas.TextWidth(DesignStr);\r\n TH := LCanvas.TextHeight(DesignStr);\r\n\r\n LCanvas.Brush.Color := Options.PaperColor;\r\n LCanvas.Pen.Color := Color;\r\n\r\n //ACanvas.Pen.Style := psDot;\r\n //ACanvas.Rectangle( (width div 2) - (TW div 2), (height div 2) - (TH div 2), TW, TH);\r\n if (TW < Width) and (TH < Height) then\r\n LCanvas.TextOut((Width div 2) - (TW div 2), (Height div 2) - (TH div 2), DesignStr);\r\nend;\r\n\r\nprocedure TJvChart.Paint; { based on TImage.Paint }\r\nbegin\r\n if csDesigning in ComponentState then\r\n begin\r\n DesignModePaint;\r\n Exit;\r\n end;\r\n\r\n if Options.AutoUpdateGraph and not FAutoPlotDone then\r\n begin\r\n FAutoPlotDone := True;\r\n PlotGraph; // Makes sure something is visible in the TPicture.\r\n end;\r\n\r\n Assert(Assigned(FPicture));\r\n //inherited ACanvas.Lock;\r\n inherited Canvas.StretchDraw(DestRect, Picture.Graphic);\r\n\r\n // New: Draw custom moveable markers on TOP of base data pen layer:\r\n DrawFloatingMarkers;\r\n\r\n // Draw cursor (vertical dotted line) if present:\r\n if (FCursorPosition >= 0) and (FCursorPosition <= Options.XValueCount) then\r\n PaintCursor;\r\n\r\n // Allow end-user to custom paint on the Chart chanvas:\r\n if Assigned(FOnPaint) then\r\n FOnPaint(Self, Canvas);\r\nend;\r\n\r\n// Draw an oscilliscope-like cursor over the place where the current sample is in the chart.\r\n// This is very handy when you want to associate your table, grid, or other data source,\r\n// with the chart, and highlight one row in the chart.\r\n\r\nprocedure TJvChart.PaintCursor;\r\nvar\r\n X: Integer;\r\n XPixelGap: Double;\r\nbegin\r\n with inherited Canvas do\r\n begin\r\n Pen.Color := Options.CursorColor;\r\n Pen.Style := Options.CursorStyle;\r\n\r\n XPixelGap := ((Options.XEnd - 2) - Options.XStartOffset) / (Options.XValueCount - 1);\r\n\r\n X := Round(Options.XStartOffset + XPixelGap * FCursorPosition);\r\n\r\n // Vertical line along X position:\r\n MoveTo(X, Options.YStartOffset);\r\n LineTo(X, FXAxisPosition - 1);\r\n end;\r\nend;\r\n\r\n{device independent functions... no checking for printer / screen needed}\r\n\r\n{**************************************************************************}\r\n{ call this function : }\r\n{ a) before setting totally new values to the graph }\r\n{ b) note that any custom strings in the PrimaryYAxis.Legends or }\r\n{ SecondaryYAxis.Legends are CLEARED by this function. }\r\n{**************************************************************************}\r\n\r\nprocedure TJvChart.ResetGraphModule;\r\nbegin\r\n Data.Clear;\r\n\r\n FPlotGraphCalled := False;\r\n FContainsNegative := False;\r\n Options.Title := '';\r\n Options.PenCount := 1;\r\n Options.XValueCount := 0;\r\n\r\n Options.PrimaryYAxis.Clear;\r\n Options.SecondaryYAxis.Clear;\r\n\r\n Options.XOrigin := 0;\r\n Options.YOrigin := 0;\r\n Options.XGap := 1;\r\n\r\n Options.PenLegends.Clear;\r\n\r\n (* for I := 0 to MAX_VALUES-1 do\r\n begin\r\n Options.AverageValue[I] := 0;\r\n end; *)\r\n\r\n Data.Clear;\r\n AverageData.Clear;\r\n\r\n Options.XLegends.Clear;\r\nend;\r\n\r\nprocedure TJvChart.PrimaryYAxisLabels;\r\nvar\r\n I, J: Integer;\r\n YDivision: Double;\r\n FormatStr, YDivisionStr, PrevYDivisionStr: string;\r\n // left hand side, vertically ascending labels for scale of Y values.\r\n Decimals: Integer;\r\n Unique: Boolean;\r\nbegin\r\n Decimals := Options.PrimaryYAxis.YLegendDecimalPlaces;\r\n Unique := False; { Add Decimals until we get unique values }\r\n while not Unique do\r\n begin\r\n Unique := True;\r\n PrevYDivisionStr := '';\r\n Options.PrimaryYAxis.YLegends.Clear;\r\n FormatStr := '0.0';\r\n for J := 2 to Decimals do\r\n FormatStr := FormatStr + '0';\r\n for I := 0 to Options.PrimaryYAxis.YDivisions do // NOTE! Don't make this YDivisions-1 That'd be bad! !!!!\r\n begin\r\n YDivision := Options.PrimaryYAxis.YMin + (I * Options.PrimaryYAxis.YGap);\r\n if Decimals <= 0 then\r\n YDivisionStr := IntToStr(Round(YDivision)) // Whole Numbers Only.\r\n else\r\n YDivisionStr := FormatFloat(FormatStr, YDivision); // Variable Decimals\r\n if (PrevYDivisionStr = YDivisionStr) and (Decimals < 5) then\r\n begin\r\n Inc(Decimals);\r\n Unique := False; // Force repeat\r\n Break; // Exit for loop.\r\n end;\r\n Options.PrimaryYAxis.YLegends.Add(YDivisionStr);\r\n PrevYDivisionStr := YDivisionStr;\r\n end;\r\n end;\r\nend;\r\n\r\n{ Setup Graph Formatting Properties\r\n\r\n *** AutoFormatGraph CONSIDERED HARMFUL. REMOVED. ***\r\n This procedure does nothing helpful, and will be removed from CVS soon.\r\n What it *does* do is wildly screw up plotting of graphs with negative\r\n values in it.\r\n -Wpostma.\r\n}\r\n\r\n(* XXXX BAD CODE. TO BE DELETED SOON. Wpostma.\r\nprocedure TJvChart.AutoFormatGraph;\r\nvar\r\n V, NYMax, NYMin: Double;\r\n// NPen: Longint;\r\n I, J: Integer;\r\n// calcYGap: Double; // not used (ahuser)\r\n ATextWidth, SkipBy, MaxFit: Integer;\r\nbegin\r\n // nMaxXValue := 0;\r\n // NPen := 0;\r\n Options.PrimaryYAxis.Normalize;\r\n Options.SecondaryYAxis.Normalize;\r\n\r\n {Set graph type according to component property}\r\n\r\n if Options.PrimaryYAxis.YMax <= Options.PrimaryYAxis.YMin then\r\n begin\r\n {Analyse graph for max and min values...}\r\n NYMax := Low(Integer);\r\n NYMin := High(Integer);\r\n for I := 0 to Data.ValueCount - 1 do\r\n begin\r\n for J := 0 to Options.PenCount - 1 do\r\n begin\r\n if Options.PenAxis[J] <> Options.PrimaryYAxis then\r\n Continue; // XXX !!! AUTO SCALING ONLY ON PRIMARY AXIS, FOR NOW. !!!\r\n\r\n V := FData.Value[J, I];\r\n\r\n if IsNaN(V) then\r\n Continue;\r\n if NYMin > V then\r\n NYMin := V;\r\n //if (I>nMaxXValue) and (FData.Value[J,I]<>0) then\r\n //nMaxXValue := I;\r\n //if (J>NPen) and (FData.Value[J,I]<>0) then\r\n // NPen := J;\r\n if NYMax < FData.Value[J, I] then\r\n NYMax := FData.Value[J, I];\r\n end;\r\n if (NYMin > 0) and (Options.PrimaryYAxis.YMin = 0) then\r\n NYMin := 0;\r\n end;\r\n // Round up YMax so it's got some zeros after it:\r\n if NYMax > 5000 then\r\n NYMax := Trunc(Trunc(NYMax + 499) / 500) * 500\r\n else\r\n if NYMax > 1000 then\r\n NYMax := Trunc(Trunc(NYMax + 99) / 100) * 100\r\n else\r\n if NYMax > 10 then\r\n NYMax := Trunc(Trunc(NYMax + 9) / 10) * 10;\r\n\r\n // And now the really bad hack:\r\n Options.PrimaryYAxis.SetYMax(0);\r\n Options.PrimaryYAxis.SetYMax(NYMax);\r\n end\r\n else\r\n begin\r\n // !!!!!!!!!!!!! WARNING WARNING WARNING !!!!!!!!!!!!!!!!!!!!\r\n // The following line has been commented out because it triggers\r\n // a warning because NYMax is not used anywhere after the\r\n // setting of its value\r\n //NYMax := Options.PrimaryYAxis.YMax;\r\n\r\n NYMin := Options.PrimaryYAxis.YMin;\r\n end;\r\n\r\n // And some negative handling crap.\r\n FContainsNegative := False;\r\n if NYMin < 0 then\r\n begin\r\n FContainsNegative := True;\r\n\r\n// if Options.PrimaryYAxis.DefaultYLegends>0 then\r\n// Options.PrimaryYAxis.Normalize\r\n// else\r\n// Options.PrimaryYAxis.YGap := 1;\r\n\r\n// if Options.PrimaryYAxis.YGap <= 0 then {* XXX WORKAROUND A BUG. Better to have bad looking data than divide by zero exceptions. XXX *}\r\n// Options.PrimaryYAxis.YGap := 0.00001;\r\n\r\n Options.ChartKind := ckChartLine;\r\n Options.YOrigin := Round(-NYMin / Options.PrimaryYAxis.YGap);\r\n end;\r\n\r\n if Options.PrimaryYAxis.YDivisions = 0 then\r\n Options.PrimaryYAxis.YDivisions := 1;\r\n\r\n //Options.PenCount := NPen;\r\n if Options.XValueCount < Data.ValueCount then\r\n Options.XValueCount := Data.ValueCount;\r\n\r\n//XXX if Options.PrimaryYAxis.YDivisions < 3 then\r\n// Options.PrimaryYAxis.YDivisions := 3; // some labels\r\n\r\n // Primary Y Axis Labels. This version only supports 0,1,2 decimal places.\r\n PrimaryYAxisLabels;\r\n\r\n // XXX TODO: Draw secondary Y Axis labels, if enabled!\r\n\r\n // if we put too many labels on the bottom X axis, they crowd or overlap,\r\n // so this prevents that:\r\n\r\n for I := 0 to Options.XLegends.Count - 1 do\r\n begin\r\n ATextWidth := ChartCanvas.TextWidth(Options.XLegends[I]) + 10;\r\n\r\n if ATextWidth > Options.XLegendMaxTextWidth then\r\n Options.XLegendMaxTextWidth := ATextWidth;\r\n end;\r\n if Options.XLegendMaxTextWidth < 20 then\r\n Options.XLegendMaxTextWidth := 20;\r\n\r\n MaxFit := ((Width - (Options.XStartOffset * 2)) div\r\n (Options.XLegendMaxTextWidth + (Options.XLegendMaxTextWidth div 4)));\r\n if MaxFit < 1 then\r\n MaxFit := 1;\r\n\r\n SkipBy := Data.ValueCount div MaxFit;\r\n if SkipBy < 1 then\r\n SkipBy := 1;\r\n //if SkipBy > Options.XAxisLegendSkipBy then\r\n Options.XAxisLegendSkipBy := SkipBy;\r\n\r\n // Now do the graphing.\r\n CountGraphAverage;\r\n\r\n PlotGraph;\r\nend;\r\n XXX BAD CODE. READ WARNING ABOVE.\r\n*)\r\n\r\nprocedure TJvChart.CountGraphAverage;\r\nvar\r\n I, J: Integer;\r\nbegin\r\n if Options.ChartKind = ckChartLine then\r\n Exit; // no average needed.\r\n\r\n for I := 0 to Data.ValueCount - 1 do\r\n begin\r\n Options.AverageValue[I] := 0;\r\n for J := 0 to MAX_PEN - 1 do\r\n Options.AverageValue[I] := Options.AverageValue[I] + FData.Value[J, I];\r\n if Options.PenCount = 0 then\r\n Options.AverageValue[I] := 0\r\n else\r\n Options.AverageValue[I] := Options.AverageValue[I] / Options.PenCount;\r\n end;\r\nend;\r\n\r\n// These set up variables used for all the rest of the plotting functions.\r\n\r\nprocedure TJvChart.GraphSetup;\r\nvar\r\n X1, X2, Y1, Y2, PYVC, VC: Integer;\r\n ACanvas: TCanvas;\r\nbegin\r\n ACanvas := GetChartCanvas(false);\r\n\r\n ACanvas.Brush.Style := bsSolid;\r\n if FData.ValueCount > 0 then\r\n Options.XValueCount := FData.ValueCount;\r\n\r\n { Get X value count }\r\n VC := Options.XValueCount;\r\n if VC < 1 then\r\n VC := 1;\r\n\r\n { Get Y value count. First normalize. }\r\n Options.PrimaryYAxis.Normalize;\r\n Options.SecondaryYAxis.Normalize;\r\n PYVC := Options.PrimaryYAxis.YDivisions;\r\n if PYVC < 1 then\r\n PYVC := 1;\r\n\r\n Options.XPixelGap := ((Options.XEnd - 1) - Options.XStartOffset) / VC;\r\n\r\n FXOrigin := Options.XStartOffset + Options.XPixelGap * (Options.XOrigin);\r\n FYOrigin := Options.YStartOffset + Round(Options.PrimaryYAxis.YPixelGap * PYVC);\r\n\r\n ACanvas.Brush.Style := bsClear;\r\n\r\n { NEW: Box around entire chart area. }\r\n X1 := Round(XOrigin);\r\n X2 := Round(Options.XStartOffset + Options.XPixelGap * VC);\r\n Y1 := Options.YStartOffset - 1;\r\n Y2 := Round(YOrigin) + 1; // was YTempOrigin\r\n\r\n if Y2 > Height then\r\n begin\r\n // I suspect that the value of YPixelGap is too large in some cases.\r\n Options.PrimaryYAxis.Normalize;\r\n //OutputDebugString( PChar('Y2 is bogus. PYVC='+IntToStr(PYVC)) );\r\n end;\r\n MyRectangle(ACanvas, X1, Y1, X2, Y2);\r\n\r\n ACanvas.Brush.Style := bsSolid;\r\nend;\r\n\r\n// internal methods\r\n\r\nprocedure TJvChart.GraphYAxis;\r\nvar\r\n ACanvas: TCanvas;\r\nbegin\r\n ACanvas := GetChartCanvas(false);\r\n ACanvas.Pen.Style := psSolid;\r\n ACanvas.Pen.Color := Options.AxisLineColor;\r\n ACanvas.MoveTo(Round(XOrigin), Options.YStartOffset);\r\n MyAxisLineTo(ACanvas, Round(XOrigin),\r\n Round((Options.YStartOffset - 1) +\r\n Options.PrimaryYAxis.YPixelGap * (Options.PrimaryYAxis.YDivisions)));\r\nend;\r\n\r\n// internal methods\r\n\r\nprocedure TJvChart.GraphXAxis;\r\nvar\r\n LCanvas: TCanvas;\r\nbegin\r\n LCanvas := GetChartCanvas(false);\r\n\r\n LCanvas.Pen.Style := psSolid;\r\n LCanvas.Pen.Color := Options.AxisLineColor;\r\n LCanvas.Pen.Width := Options.AxisLineWidth; // was missing. Added Feb 2005. -WPostma.\r\n FXAxisPosition := Options.YStartOffset + Round(Options.PrimaryYAxis.YPixelGap * (Options.PrimaryYAxis.YDivisions));\r\n\r\n {Draw X-axis}\r\n LCanvas.MoveTo(Options.XStartOffset, FXAxisPosition);\r\n MyAxisLineTo(LCanvas, Round(Options.XStartOffset + Options.XPixelGap * Options.XValueCount), FXAxisPosition);\r\nend;\r\n\r\nprocedure TJvChart.GraphXAxisDivisionMarkers; // new.\r\nvar\r\n I, X: Integer;\r\n Lines: Integer;\r\n LCanvas: TCanvas;\r\n // these are used only in special XAxisDateTimeMode:\r\n TimePerXValue: Double;\r\n ElapsedTime: Double;\r\nbegin\r\n if not Enabled then\r\n Exit;\r\n if Options.XValueCount <= 0 then // NOT VISIBLE WHEN NO VALUES TO SHOW. NEW 2007\r\n Exit;\r\n if Options.XStartOffset <= 0 then // NOT VISIBLE WHEN NO ROOM TO SHOW IT. NEW 2007\r\n Exit;\r\n\r\n LCanvas := GetChartCanvas(false);\r\n\r\n if not Options.XAxisDivisionMarkers then\r\n Exit;\r\n if Options.XAxisValuesPerDivision <= 0 then\r\n Exit;\r\n\r\n //XAxisDateTimeMode: [NEW 2007]\r\n // Make charts with XAxis divisions synchronized\r\n // to some regular time division such as hourly periods.\r\n //\r\n // new mode! when looking at date/time charts\r\n // it's useful to be able to force the divisions to be\r\n // shown at hourly intervals, or if you're looking at a month of data\r\n // perhaps you might want to plot a division marker at midnight\r\n // or at weekly intervals.\r\n //\r\n if (Options.XAxisDateTimeMode) and\r\n (Options.XAxisDateTimeDivision > 0.000000001) and\r\n (FData.EndDateTime > FData.StartDateTime) then\r\n begin\r\n\r\n // How much time goes by in this chart? ( 1.0 = one day)\r\n ElapsedTime := FData.EndDateTime - FData.StartDateTime;\r\n\r\n // How far apart the bars are spaced is determined by\r\n // XAxisDateTimeDivision.\r\n // if we plot one day of values, and we want a marker every\r\n // hour, we want XAxisDateTimeDivision=(1.0/24).\r\n\r\n // Given the elapsed time in this chart, how many divisions\r\n // should we be showing?\r\n Options.FXAxisDateTimeLines := Round(ElapsedTime / Options.XAxisDateTimeDivision);\r\n if (Options.FXAxisDateTimeLines < 0) or (Options.FXAxisDateTimeLines > 10000) then // sanity check!\r\n Exit;\r\n\r\n // this value is to help us figure out how much time goes by\r\n // for each time we go from one X value to the next one.\r\n TimePerXValue := ElapsedTime / Options.XValueCount;\r\n\r\n // figure out how many divisions to move over for firstMarker\r\n // given TimePerXValue (1.0=one day) and StartDateTime and\r\n // XAxisDateTimeDivision.\r\n Options.FXAxisDateTimeFirstMarker := 0;\r\n // If XAxisDateTimeDivion=1.0, and TimePerXValue=0.25, then\r\n // we want a division marker for every 4th value\r\n Options.FXaxisDateTimeSkipBy := Round(Options.XAxisDateTimeDivision / TimePerXValue);\r\n\r\n for I := 0 to Options.FXAxisDateTimeLines - 1 do\r\n begin\r\n X := Round(Options.XStartOffset + (Options.XPixelGap * I * Options.FXaxisDateTimeSkipBy)) +\r\n Options.FXAxisDateTimeFirstMarker;\r\n if X > Options.XEnd then\r\n Break;\r\n // don't draw dotted line right at X Axis.\r\n if X <> Options.XStartOffset then\r\n begin\r\n LCanvas.Pen.Color := Options.GetPenColor(jvChartDivisionLineColorIndex);\r\n MyDrawDotLine(LCanvas, X, Options.YStartOffset + 1, X, FXAxisPosition - 1);\r\n end;\r\n end;\r\n\r\n // Note: datetime labels aren't drawn yet, they are drawn later,\r\n // see local procedure XAxisDateTimeModeLabels2 inside\r\n // GraphXAxisLegend, for the printing of the datetime labels!\r\n\r\n Exit; // done!\r\n end; // END OF NEW CODE IN 2007 FOR THIS METHOD. -WP-\r\n\r\n Lines := (((Options.XValueCount + (Options.XAxisValuesPerDivision div 2)) div Options.XAxisValuesPerDivision)) - 1;\r\n\r\n for I := 1 to Lines do\r\n begin\r\n X := Round(Options.XStartOffset + Options.XPixelGap * I * Options.XAxisValuesPerDivision);\r\n LCanvas.Pen.Color := Options.GetPenColor(jvChartDivisionLineColorIndex);\r\n MyDrawDotLine(LCanvas, X, Options.YStartOffset + 1, X, FXAxisPosition - 1);\r\n end;\r\nend;\r\n\r\nprocedure TJvChart.GraphYAxisDivisionMarkers;\r\nvar\r\n I, Y: Integer;\r\n LCanvas: TCanvas;\r\nbegin\r\n Assert(Assigned(Self));\r\n Assert(Assigned(Options));\r\n Assert(Assigned(Options.PrimaryYAxis));\r\n Assert(Options.PrimaryYAxis.YPixelGap > 0);\r\n LCanvas := GetChartCanvas(false);\r\n\r\n LCanvas.Font := Options.AxisFont;\r\n\r\n for I := 0 to Options.PrimaryYAxis.YDivisions do\r\n begin\r\n Y := Round(YOrigin - (Options.PrimaryYAxis.YPixelGap * ((I) - Options.YOrigin)));\r\n\r\n if I < Options.PrimaryYAxis.YLegends.Count then\r\n MyRightTextOut(LCanvas, Round(XOrigin - 3), Y, Options.PrimaryYAxis.YLegends[I]);\r\n\r\n Y := Round(YOrigin - (Options.PrimaryYAxis.YPixelGap * ((I) - Options.YOrigin)));\r\n if (I > 0) and (I < (Options.PrimaryYAxis.YDivisions)) and Options.YAxisDivisionMarkers then\r\n begin\r\n LCanvas.Pen.Color := Options.GetPenColor(jvChartDivisionLineColorIndex);\r\n MyDrawDotLine(LCanvas, Options.XStartOffset, Y,\r\n Round(Options.XStartOffset + Options.XPixelGap * Options.XValueCount) - 1, Y);\r\n end;\r\n if I > 0 then\r\n if Options.PrimaryYAxis.YPixelGap > 20 then\r\n begin // more than 20 pixels per major division?\r\n LCanvas.Pen.Color := Options.GetPenColor(jvChartAxisColorIndex);\r\n\r\n Y := Round(Y + (Options.PrimaryYAxis.YPixelGap / 2));\r\n MyDrawAxisMark(LCanvas, Options.XStartOffset, Y,\r\n Options.XStartOffset - 4, // Tick at halfway between major marks.\r\n Y);\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvChart.PlotMarker(ACanvas: TCanvas; MarkerKind: TJvChartPenMarkerKind; X, Y: Integer);\r\nbegin\r\n // Note: each drawing function below uses chart\r\n // Options.MarkerSize property to determine the\r\n // size of the markers! Future Idea: More flexible marker sizing\r\n // might be useful especially in the case of floating markers.\r\n case MarkerKind of\r\n pmkDiamond:\r\n PlotFilledDiamond(ACanvas, X, Y);\r\n pmkCircle:\r\n begin\r\n ACanvas.Brush.Style := bsClear;\r\n PlotCircle(ACanvas, X, Y);\r\n ACanvas.Brush.Style := bsSolid;\r\n end;\r\n pmkSquare:\r\n begin\r\n ACanvas.Brush.Style := bsClear;\r\n PlotSquare(ACanvas, X, Y);\r\n ACanvas.Brush.Style := bsSolid;\r\n end;\r\n pmkCross:\r\n PlotCross(ACanvas, X, Y);\r\n end;\r\nend;\r\n\r\n\r\n{ PlotPicture:\r\n New helper method helps us to print a prettier JvChart or save to disk,\r\n with higher resolution and larger fonts than the ones we can show on\r\n the on-screen form.\r\n }\r\nprocedure TJvChart.PlotPicture(picture:TPicture; fontScaling:Double);\r\nvar\r\n// oldfontsize:Integer;\r\n oldhdrfontsize:Integer;\r\n oldlgdfontsize:Integer;\r\n oldaxisfontsize:Integer;\r\n oldystartoffset:Integer;\r\n oldxstartoffset:Integer;\r\nbegin\r\n if picture.Graphic=nil then begin\r\n raise Exception.Create('JvChart.PlotToPicture: You must initialize picture.Graphic.Bitmap first');\r\n end;\r\n\r\n if not (picture.Graphic is TBitmap) then begin\r\n raise Exception.Create('JvChart.PlotToPicture: picture.Graphic.Bitmap must be type TBitmap.');\r\n end;\r\n\r\n\r\n //oldfontsize := Self.Font.Size;\r\n //Self.Font.Size := Self.Font.Size * fontScaling;\r\n\r\n oldystartoffset := Options.YStartOffset;\r\n Options.YStartOffset := Round(Options.YStartOffset * fontScaling);\r\n\r\n oldxstartoffset := Options.XStartOffset;\r\n Options.XStartOffset := Round(Options.XStartOffset * fontScaling);\r\n\r\n\r\n oldhdrfontsize := Options.HeaderFont.Size;\r\n Options.HeaderFont.Size := Round(Options.HeaderFont.Size * fontScaling);\r\n\r\n oldlgdfontsize := Options.LegendFont.Size;\r\n Options.LegendFont.Size := Round(Options.LegendFont.Size * fontScaling);\r\n\r\n oldaxisfontsize := Options.AxisFont.Size;\r\n Options.AxisFont.Size := Round(Options.AxisFont.Size * fontScaling);\r\n\r\n FExtPicture := picture;\r\n try\r\n ResizeChartCanvas; // Recovery. This shouldn't happen.\r\n PlotGraph;\r\n DrawFloatingMarkers;\r\n\r\n finally\r\n FExtPicture := nil;\r\n\r\n Options.YStartOffset := oldystartoffset;\r\n Options.XStartOffset := oldxstartoffset;\r\n Options.HeaderFont.Size := oldhdrfontsize;\r\n Options.LegendFont.Size := oldlgdfontsize;\r\n Options.AxisFont.Size := oldaxisfontsize;\r\n\r\n end;\r\n ResizeChartCanvas; // reset everything.\r\n Invalidate; // repaint.\r\n\r\nend;\r\n\r\n{**************************************************************************}\r\n{ call this function : }\r\n{ a) you want to show the graph stored in memory }\r\n{ b) you have changed single graph value (call AutoFormatGraph if all new)}\r\n{ c) you have changed the settings of the graph and if you do not use }\r\n{ FAutoUpdateGraph option }\r\n{**************************************************************************}\r\n\r\nprocedure TJvChart.PlotGraph;\r\nbegin\r\n Assert(Assigned(Options));\r\n\r\n // Sanity check on YEnd/XEnd:\r\n if (Options.YEnd <= 0) or (Options.XEnd <= 0) or\r\n (Options.YEnd > Height) or (Options.XEnd > Width) then\r\n begin\r\n FInPlotGraph := True; // recursion blocker.\r\n ResizeChartCanvas; // Recovery. This shouldn't happen.\r\n FInPlotGraph := False;\r\n end;\r\n\r\n InternalPlotGraph;\r\n Invalidate; // Force repaint.\r\nend;\r\n\r\nprocedure TJvChart.InternalPlotGraph;\r\nvar\r\n ACanvas: TCanvas;\r\n nStackGap: Integer;\r\n n100Sum: Double;\r\n // nOldY: Longint;\r\n YOldOrigin: Integer;\r\n nMaxTextHeight: Integer;\r\n // Rectangle plotting:\r\n X, Y, X2, Y2: Integer;\r\n\r\n aWidth:Integer;\r\n aHeight:Integer;\r\n { Here be lots of local functions }\r\n\r\n { Draw symbol markers and text labels on a chart... }\r\n\r\n procedure PlotGraphChartMarkers;\r\n var\r\n TW, TH, VC, I, J: Integer;\r\n PenAxisOpt: TJvChartYAxisOptions;\r\n V: Double;\r\n MaxV, MinV: array of Double;\r\n LineXPixelGap: Double;\r\n LastX, LastY: Integer;\r\n MinIndex, MaxIndex: array of Integer;\r\n Decimals: Integer;\r\n begin\r\n Assert(Assigned(ACanvas));\r\n Assert(Assigned(ACanvas.Brush));\r\n\r\n ACanvas.Brush.Color := Options.PaperColor;\r\n ACanvas.Pen.Style := psSolid;\r\n ACanvas.Pen.Color := Options.AxisLineColor;\r\n ACanvas.Brush.Style := bsSolid;\r\n\r\n VC := Options.XValueCount;\r\n LastX := Round(XOrigin);\r\n LastY := 0;\r\n\r\n if VC < 2 then\r\n VC := 2;\r\n LineXPixelGap := ((Options.XEnd - 2) - Options.XStartOffset) / (VC - 1);\r\n\r\n SetLength(MaxV, Options.PenCount);\r\n SetLength(MinV, Options.PenCount);\r\n SetLength(MinIndex, Options.PenCount);\r\n SetLength(MaxIndex, Options.PenCount);\r\n\r\n for I := 0 to Options.PenCount - 1 do\r\n begin\r\n if Options.PenMarkerKind[I] = pmkNone then\r\n Continue;\r\n PenAxisOpt := Options.PenAxis[I]; // Get whether this pen is plotted using the lefthand or righthand Y axis.\r\n MaxV[I] := PenAxisOpt.YMin;\r\n MinV[I] := PenAxisOpt.YMax;\r\n MinIndex[I] := -1;\r\n MaxIndex[I] := -1;\r\n\r\n for J := 0 to Options.XValueCount - 1 do\r\n begin\r\n V := FData.Value[I, J];\r\n if IsNaN(V) then\r\n Continue;\r\n //MaxFlag := False;\r\n //MinFlag := False;\r\n if V > MaxV[I] then\r\n begin\r\n MaxV[I] := V;\r\n MaxIndex[I] := J;\r\n end;\r\n\r\n if V < MinV[I] then\r\n begin\r\n MinV[I] := V;\r\n MinIndex[I] := J;\r\n end;\r\n\r\n // Calculate Marker position:\r\n X := Round(XOrigin + J * LineXPixelGap);\r\n\r\n //old:Y := Round(YOrigin - ((V / PenAxisOpt.YGap1) * PenAxisOpt.YPixelGap));\r\n Y := Round(YOrigin - (((V - PenAxisOpt.YMin) / PenAxisOpt.YGap) * PenAxisOpt.YPixelGap));\r\n SetLineColor(ACanvas, I);\r\n if Y < Options.YStartOffset then\r\n Y := Options.YStartOffset; // constrain Y to stay on chart.\r\n\r\n (*\r\n if MinFlag or MaxFlag then // local min/max markers!\r\n ACanvas.Pen.Width := 2\r\n else\r\n ACanvas.Pen.Width := 1;\r\n *)\r\n\r\n // Now plot the right kind of marker:\r\n PlotMarker(ACanvas, Options.PenMarkerKind[I], X, Y);\r\n end;\r\n end;\r\n\r\n { Now plot labels After all the markers. Looks nicer than doing\r\n it all together }\r\n for I := 0 to Options.PenCount - 1 do\r\n begin\r\n if not Options.PenValueLabels[I] then\r\n Continue;\r\n PenAxisOpt := Options.PenAxis[I]; // Get whether this pen is plotted using the lefthand or righthand Y axis.\r\n for J := 0 to Options.XValueCount - 1 do\r\n begin\r\n V := FData.Value[I, J];\r\n if IsNaN(V) then\r\n Continue;\r\n // Calculate Marker position:\r\n X := Round(XOrigin + J * LineXPixelGap);\r\n Y := Round(YOrigin - ((V / PenAxisOpt.YGap1) * PenAxisOpt.YPixelGap));\r\n if Y < (Options.YStartOffset + 10) then\r\n Y := (Options.YStartOffset + 10); // constrain Y to stay on chart.\r\n\r\n // Format with fixed number of decimal places (avoid screen clutter)\r\n Decimals := Options.PenAxis[I].MarkerValueDecimals;\r\n if Decimals < 0 then // auto\r\n if V < 100.0 then\r\n Decimals := 1 // handy automatic percentage mode.\r\n else\r\n Decimals := 0;\r\n Text := FloatToStrF(V, ffFixed, 16, Decimals);\r\n\r\n if Options.PenUnit.Count >= I then\r\n Text := Text + Options.PenUnit[I];\r\n\r\n TW := ACanvas.TextWidth(Text);\r\n TH := ACanvas.TextHeight(Text);\r\n\r\n if Options.GetPenValueLabels(I) and\r\n ((X > (LastX + (TW div 2))) or // Show if it's not going to collide\r\n ((Abs(Y - LastY) > (TH * 2)) and\r\n (X > LastX)) or\r\n ((J = MinIndex[I]) or (J = MaxIndex[I]))) then // Always show max/mins\r\n begin\r\n // TODO: EVENT FOR END-USER-CUSTOMIZED OR FORMATTED LABELS\r\n //if Assigned(FOnGetValueLabel) then\r\n // FOnGetValueLabel(Sender, {Pen}I, {Sample#}J, {Value}V, {var}Text );\r\n if Length(Text) > 0 then\r\n begin\r\n Dec(Y, 2);\r\n // nifty little bit to draw a box around min/max values.\r\n if (J = MinIndex[I]) or (J = MaxIndex[I]) then\r\n begin\r\n ACanvas.Pen.Style := psClear; //was psDot\r\n ACanvas.Brush.Color := Options.PaperColor; //was HintColor\r\n MyPolygon(ACanvas, [Point(X - ((TW div 2) + 2), Y - (TH + Options.MarkerSize + 2)),\r\n Point(X - ((TW div 2) + 2), Y - Options.MarkerSize),\r\n Point(X + (TW div 2) + 2, Y - Options.MarkerSize),\r\n Point(X + (TW div 2) + 2, Y - (TH + Options.MarkerSize + 2))]);\r\n ACanvas.Pen.Style := psSolid;\r\n end;\r\n\r\n if Y >= Options.YStartOffset + 20 then\r\n begin\r\n ACanvas.Brush.Style := bsSolid;\r\n MyCenterTextOut(ACanvas, X + 1, (Y - (Options.MarkerSize + TH)) - 1, Text);\r\n ACanvas.Brush.Color := Options.PaperColor;\r\n LastX := X + TW;\r\n LastY := Y;\r\n end;\r\n end;\r\n end;\r\n end;\r\n end;\r\n end;\r\n\r\n procedure PlotGraphStackedBar;\r\n var\r\n I, J: Integer;\r\n begin\r\n for J := 0 to Options.XValueCount - 1 do\r\n begin\r\n YOldOrigin := 0;\r\n for I := 0 to Options.PenCount - 1 do\r\n begin\r\n if Options.PenStyle[I] <> psClear then\r\n begin\r\n if Options.XPixelGap < 3.0 then\r\n ACanvas.Pen.Color := Options.PenColor[I]; // greek-out the borders\r\n MyColorRectangle(ACanvas, I,\r\n Round((XOrigin + J * Options.XPixelGap) + (Options.XPixelGap / 6)),\r\n Round(YOrigin - YOldOrigin),\r\n Round(XOrigin + (J + 1) * Options.XPixelGap - nStackGap),\r\n Round((YOrigin - YOldOrigin) -\r\n ((FData.Value[I, J] / Options.PenAxis[I].YGap) * Options.PrimaryYAxis.YPixelGap)));\r\n YOldOrigin := Round(YOldOrigin +\r\n ((FData.Value[I, J] / Options.PenAxis[I].YGap) * Options.PrimaryYAxis.YPixelGap));\r\n end;\r\n end;\r\n end;\r\n end;\r\n\r\n procedure PlotGraphBar;\r\n var\r\n I, J, N: Integer;\r\n BarCount: Double;\r\n V, BarGap: Double;\r\n YTempOrigin: Integer;\r\n\r\n function BarXPosition(Index: Integer): Integer;\r\n begin\r\n Result := Round(XOrigin + (Index * BarGap));\r\n end;\r\n\r\n begin\r\n YTempOrigin := Options.YStartOffset + Round(Options.PrimaryYAxis.YPixelGap * (Options.PrimaryYAxis.YDivisions));\r\n\r\n BarCount := Options.PenCount * Options.XValueCount;\r\n BarGap := (((Options.XEnd - 1) - Options.XStartOffset) / BarCount);\r\n\r\n for I := 0 to Options.PenCount - 1 do\r\n begin\r\n if Options.PenAxis[I].YGap = 0 then\r\n Continue; // Can't plot this one.\r\n for J := 0 to Options.XValueCount - 1 do\r\n begin\r\n N := (J * Options.PenCount) + I; // Which Bar Number!?\r\n // Plot a rectangle for each Bar in our bar chart...\r\n X := BarXPosition(N) + 1;\r\n // Make a space between groups, 4 pixels per XValue Index:\r\n //Dec(X,4);\r\n //Inc(X, 2*J);\r\n Y := YTempOrigin;\r\n Assert(Y < aHeight);\r\n Assert(Y > 0);\r\n Assert(X > 0);\r\n //if (X>=aWidth) then\r\n // OutputDebugString('foo!');\r\n Assert(X < aWidth);\r\n X2 := BarXPosition(N + 1) - 3;\r\n // Make a space between groups, 4 pixels per XValue Index:\r\n //Dec(X2,4);\r\n //Inc(X2, 2*J);\r\n V := FData.Value[I, J];\r\n if IsNaN(V) then\r\n Continue;\r\n Y2 := Round(YOrigin - ((V / Options.PenAxis[I].YGap) * Options.PrimaryYAxis.YPixelGap));\r\n //Assert(Y2 < aHeight);\r\n if Y2 < 0 then\r\n Y2 := -1; //clip extreme negatives.\r\n if Y2 >= Y then\r\n Y2 := Y - 1;\r\n Assert(Y2 < Y);\r\n Assert(X2 > 0);\r\n //if (X2X);\r\n if Options.PenCount > 1 then\r\n if X2 > X then\r\n Dec(X2); // Additional 1 pixel gap\r\n if Options.PenStyle[I] <> psClear then\r\n begin\r\n if (X2 - X) < 4 then // don't draw black line around bar if it is a very narrow bar.\r\n ACanvas.Pen.Style := psClear\r\n else\r\n ACanvas.Pen.Style := Options.PenStyle[I];\r\n MyColorRectangle(ACanvas, I, X, Y, X2, Y2);\r\n end;\r\n end;\r\n end;\r\n {add average line for the type...}\r\n if Options.ChartKind = ckChartBarAverage then\r\n begin\r\n SetLineColor(ACanvas, jvChartAverageLineColorIndex);\r\n ACanvas.MoveTo(Round(XOrigin + 1 * Options.XPixelGap),\r\n Round(YOrigin - ((Options.AverageValue[1] / Options.PrimaryYAxis.YGap) * Options.PrimaryYAxis.YPixelGap)));\r\n for J := 0 to Options.XValueCount do\r\n MyPenLineTo(ACanvas, Round(XOrigin + J * Options.XPixelGap),\r\n Round(YOrigin - ((Options.AverageValue[J] / Options.PrimaryYAxis.YGap) * Options.PrimaryYAxis.YPixelGap)));\r\n SetLineColor(ACanvas, jvChartAxisColorIndex);\r\n end;\r\n // NEW: Add markers to bar chart:\r\n PlotGraphChartMarkers;\r\n end;\r\n\r\n // Keep Y in visible chart range:\r\n\r\n function GraphConstrainedLineY(Pen, Sample: Integer): Double;\r\n var\r\n V: Double;\r\n PenAxisOpt: TJvChartYAxisOptions;\r\n begin\r\n V := FData.Value[Pen, Sample];\r\n PenAxisOpt := Options.PenAxis[Pen];\r\n if IsNaN(V) then\r\n begin\r\n Result := NaN; // blank placeholder value in chart!\r\n Exit;\r\n end;\r\n if PenAxisOpt.YGap < 0.0000001 then\r\n begin\r\n Result := 0.0; // can't chart! YGap is near zero, zero, or negative.\r\n Exit;\r\n end;\r\n Result := YOrigin - (((V - PenAxisOpt.YMin) / PenAxisOpt.YGap) * PenAxisOpt.YPixelGap);\r\n if Result >= YOrigin - 1 then\r\n Result := Round(YOrigin) - 1 // hit the top of the chart\r\n else\r\n if Result < Options.YStartOffset - 2 then\r\n Result := Options.YStartOffset - 2; // Not quite good enough, but better than before.\r\n end;\r\n\r\n procedure PlotGraphChartLine;\r\n var\r\n I, I2, J, Y1: Integer;\r\n V, LineXPixelGap: Double;\r\n NanFlag: Boolean;\r\n VC: Integer;\r\n // PenAxisOpt: TJvChartYAxisOptions;\r\n begin\r\n Assert(Assigned(ACanvas));\r\n Assert(Assigned(ACanvas.Brush));\r\n\r\n VC := Options.XValueCount;\r\n if VC < 2 then\r\n VC := 2;\r\n LineXPixelGap := ((Options.XEnd - 2) - Options.XStartOffset) / (VC - 1);\r\n\r\n ACanvas.Pen.Style := psSolid;\r\n for I := 0 to Options.PenCount - 1 do\r\n begin\r\n // PenAxisOpt := Options.PenAxis[I];\r\n // No line types?\r\n if Options.PenStyle[I] = psClear then\r\n Continue;\r\n SetLineColor(ACanvas, I);\r\n J := 0;\r\n V := GraphConstrainedLineY(I, J);\r\n NanFlag := IsNaN(V);\r\n if not NanFlag then\r\n begin\r\n Y := Round(V);\r\n ACanvas.MoveTo(Round(XOrigin), Y);\r\n end;\r\n\r\n for J := 1 to Options.XValueCount - 1 do\r\n begin\r\n V := GraphConstrainedLineY(I, J);\r\n if IsNaN(V) then\r\n begin\r\n NanFlag := True; // skip.\r\n ACanvas.MoveTo(Round(XOrigin + J * LineXPixelGap), 200); //DEBUG!\r\n end\r\n else\r\n begin\r\n if NanFlag then\r\n begin // resume, valid value.\r\n NanFlag := False;\r\n Y := Round(V);\r\n // pick up the pen and slide forward\r\n ACanvas.MoveTo(Round(XOrigin + J * LineXPixelGap), Y);\r\n end\r\n else\r\n begin\r\n Y := Round(V);\r\n ACanvas.Pen.Style := Options.PenStyle[I];\r\n if I > 0 then\r\n begin\r\n for I2 := 0 to I - 1 do\r\n begin\r\n V := GraphConstrainedLineY(I2, J);\r\n if IsNaN(V) then\r\n Continue;\r\n Y1 := Round(V);\r\n if Y1 = Y then\r\n begin\r\n Dec(Y); // Prevent line-overlap. Show dotted line above other line.\r\n if ACanvas.Pen.Style = psSolid then\r\n ACanvas.Pen.Style := psDot;\r\n end;\r\n end;\r\n end;\r\n MyPenLineTo(ACanvas, Round(XOrigin + J * LineXPixelGap), Y);\r\n //OldV := V; // keep track of last valid value, for handling gaps.\r\n end;\r\n end;\r\n end;\r\n end;\r\n PlotGraphChartMarkers;\r\n // MARKERS:\r\n SetLineColor(ACanvas, jvChartAxisColorIndex);\r\n end;\r\n\r\n procedure PlotGraphStackedBarAverage;\r\n var\r\n I, J: Integer;\r\n begin\r\n for J := 0 to Options.XValueCount - 1 do\r\n begin\r\n n100Sum := 0;\r\n for I := 0 to Options.PenCount - 1 do\r\n n100Sum := n100Sum + FData.Value[I, J];\r\n\r\n for I := 0 to Options.PenCount - 1 do\r\n if n100Sum <> 0 then\r\n AverageData.Value[I, J] := (FData.Value[I, J] / n100Sum) * 100\r\n else\r\n AverageData.Value[I, J] := 0;\r\n end;\r\n\r\n for J := 0 to Options.XValueCount - 1 do\r\n begin\r\n YOldOrigin := 0;\r\n for I := 0 to Options.PenCount - 1 do\r\n begin\r\n if I = Options.PenCount then {last one; draw it always to the top line}\r\n MyColorRectangle(ACanvas, I,\r\n Round(XOrigin + J * Options.XPixelGap + (Options.XPixelGap / 2)),\r\n Round(YOrigin - YOldOrigin),\r\n Round(XOrigin + (J + 1) * Options.XPixelGap + (Options.XPixelGap / 2) - nStackGap),\r\n Options.YStartOffset)\r\n else\r\n begin\r\n MyColorRectangle(ACanvas, I,\r\n Round(XOrigin + J * Options.XPixelGap + (Options.XPixelGap / 2)),\r\n Round(YOrigin - YOldOrigin),\r\n Round(XOrigin + (J + 1) * Options.XPixelGap + (Options.XPixelGap / 2) - nStackGap),\r\n Round((YOrigin - YOldOrigin) -\r\n ((AverageData.Value[I, J] / Options.PenAxis[I].YGap) * Options.PrimaryYAxis.YPixelGap)));\r\n YOldOrigin := YOldOrigin + Round((AverageData.Value[I, J] / Options.PenAxis[I].YGap) *\r\n Options.PrimaryYAxis.YPixelGap);\r\n end;\r\n end;\r\n end;\r\n end;\r\n\r\n procedure CheckYAxisFlags;\r\n var\r\n I: Integer;\r\n begin\r\n Options.PrimaryYAxis.FActive := True;\r\n Options.SecondaryYAxis.FActive := False;\r\n for I := 0 to Options.PenCount - 1 do\r\n if Options.PenSecondaryAxisFlag[I] then\r\n begin\r\n Options.SecondaryYAxis.FActive := True;\r\n Break;\r\n end;\r\n end;\r\n\r\nbegin { Enough local functions for ya? -WP }\r\n ACanvas := GetChartCanvas(false);\r\n aWidth := GetChartCanvasWidth;\r\n aHeight:= GetChartCanvasHeight;\r\n\r\n Assert(Assigned(ACanvas));\r\n Assert(Assigned(ACanvas.Brush));\r\n Assert(Assigned(ACanvas.Pen));\r\n\r\n FPlotGraphCalled := True;\r\n\r\n // refuse to refresh under these conditions:\r\n if not (Enabled and Visible) then\r\n Exit;\r\n if csDesigning in ComponentState then\r\n begin\r\n if not Assigned(Self.Parent) then\r\n Exit;\r\n if Self.Name = '' then\r\n Exit;\r\n end;\r\n\r\n // safety before we paint.\r\n Assert(Assigned(Self));\r\n Assert(Assigned(Data));\r\n Assert(Assigned(Options));\r\n Assert(Assigned(Options.PrimaryYAxis));\r\n Assert(Assigned(Options.SecondaryYAxis));\r\n Assert(Assigned(AverageData));\r\n\r\n // NEW: Primary Y axis is always shown, but secondary is only shown\r\n // if a pen is set up to plot on the secondary Y Axis scale.\r\n CheckYAxisFlags;\r\n\r\n ClearScreen;\r\n\r\n if Options.XValueCount > MAX_VALUES then\r\n Options.XValueCount := MAX_VALUES;\r\n if Options.PenCount > MAX_PEN then\r\n Options.PenCount := MAX_PEN;\r\n (*\r\n if Options.PrimaryYAxis.YGap = 0 then\r\n Options.PrimaryYAxis.YGap := 1;\r\n if Options.SecondaryYAxis.YGap = 0 then\r\n Options.SecondaryYAxis.YGap := 1;\r\n *)\r\n\r\n PrimaryYAxisLabels; // Make sure there are Y Axis labels!\r\n\r\n Assert(Assigned(ACanvas));\r\n Assert(Assigned(ACanvas.Brush));\r\n\r\n { Resize Header area according to HeaderFont size }\r\n if (not PrintInSession) and (Length(Options.XAxisHeader) > 0) then\r\n begin\r\n MyHeaderFont(ACanvas);\r\n // nOldY := Options.YStartOffset;\r\n nMaxTextHeight := CanvasMaxTextHeight(ACanvas) + 8;\r\n // Bump bottom margins if the fonts don't fit!\r\n if Options.YStartOffset < 2 * nMaxTextHeight then\r\n begin\r\n Options.YStartOffset := nMaxTextHeight * 2;\r\n //Options.YEnd := Options.YEnd + (nOldY - Options.YStartOffset);\r\n CalcYEnd;\r\n Options.PrimaryYAxis.Normalize;\r\n Options.SecondaryYAxis.Normalize;\r\n end;\r\n end;\r\n\r\n if (Options.ChartKind = ckChartStackedBar) or\r\n (Options.ChartKind = ckChartStackedBarAverage) then\r\n begin\r\n FOldYOrigin := Options.YOrigin;\r\n Options.YOrigin := 0;\r\n end\r\n else\r\n FOldYOrigin := Options.YOrigin;\r\n if Options.ChartKind = ckChartStackedBarAverage then\r\n FOldYGap := Options.PrimaryYAxis.YGap\r\n else\r\n FOldYGap := Options.PrimaryYAxis.YGap;\r\n\r\n { This effects only graph type: JvChartStackedBar(_100) }\r\n nStackGap := 1;\r\n if Options.XEnd > 200 then\r\n nStackGap := 3;\r\n\r\n MyAxisFont(ACanvas);\r\n\r\n YOldOrigin := Trunc(YOrigin);\r\n\r\n {Draw header and other stuff...}\r\n GraphSetup;\r\n\r\n // If FData.ValueCount is zero we can preview the visual appearance of the chart,\r\n // but there is no plotting of pens that can occur, so stop now...\r\n if FData.ValueCount = 0 then // EMPTY!\r\n begin\r\n { draw a blank chart. Component shouldn't just be a white square, it makes\r\n users think we're broken, when we're not, they just haven't given us any\r\n data.}\r\n Options.PrimaryYAxis.Normalize;\r\n Options.SecondaryYAxis.Normalize;\r\n GraphSetup;\r\n\r\n GraphXAxis;\r\n GraphXAxisDivisionMarkers;\r\n GraphYAxis;\r\n GraphYAxisDivisionMarkers;\r\n\r\n ACanvas.Font.Color := clRed;\r\n if Length(Options.NoDataMessage) = 0 then\r\n MyLeftTextOut(ACanvas, Round(XOrigin), Round(YOrigin) + 4, RsNoData)\r\n else\r\n MyLeftTextOut(ACanvas, Round(XOrigin), Round(YOrigin) + 4, Options.NoDataMessage); // NEW! NOV 2004. WP.\r\n\r\n Exit;\r\n end;\r\n\r\n DrawGradient; // NEW 2007\r\n DisplayBars; // NEW 2007\r\n\r\n {Y Axis}\r\n GraphYAxis;\r\n GraphYAxisDivisionMarkers; // dotted lines making graph-paper across graph\r\n\r\n {X Axis}\r\n GraphXAxis;\r\n GraphXAxisDivisionMarkers; // new.\r\n\r\n {X-axis legends...}\r\n GraphXAxisLegend;\r\n\r\n {Main Header}\r\n if Options.Title <> '' then\r\n MyHeader(ACanvas, Options.Title);\r\n\r\n {X axis header}\r\n if Options.XAxisHeader <> '' then\r\n MyXHeader(ACanvas, Options.XAxisHeader);\r\n\r\n {Create the actual graph...}\r\n case Options.ChartKind of\r\n ckChartBar, ckChartBarAverage:\r\n PlotGraphBar;\r\n ckChartStackedBar:\r\n PlotGraphStackedBar;\r\n ckChartLine: //, ckChartLineWithMarkers:\r\n PlotGraphChartLine;\r\n ckChartMarkers:\r\n PlotGraphChartMarkers;\r\n ckChartStackedBarAverage:\r\n PlotGraphStackedBarAverage;\r\n ckChartPieChart:\r\n GraphPieChart(1); { special types}\r\n ckChartDeltaAverage:\r\n GraphDeltaAverage; { special types}\r\n end;\r\n {Y axis header}\r\n MyYHeader(ACanvas, Options.YAxisHeader); // vertical text out on Y axis\r\nend;\r\n\r\n\r\n\r\nprocedure TJvChart.DrawChartLegendBelow(ACanvas: TCanvas); {accidentally deleted during Jedi_new to Jedi_2009 branch. Restored by WP June 2009}\r\nvar\r\n I,Y,nTextHeight:Integer;\r\n BoxWidth:Integer;\r\n LLabel:String;\r\nbegin\r\n\r\n if (Options.Legend <> clChartLegendBelow) then exit;\r\n\r\n if (Options.YStartOffset<=0) or (Options.XStartOffset<=0) then exit;\r\n\r\n // space-saving pen-legend below chart\r\n MySmallGraphFont(ACanvas);\r\n\r\n {10 % extra space for line height}\r\n nTextHeight := Round(CanvasMaxTextHeight(ACanvas) * 1.01);\r\n\r\n //BoxHeight := nTextHeight - 2;\r\n\r\n Options.FXLegendHoriz := Options.XStartOffset;\r\n for I := 0 to Options.PenCount - 1 do\r\n begin\r\n if Options.PenStyle[I] = psClear then\r\n if Options.GetPenMarkerKind(I) = pmkNone then\r\n Continue; // Skip invisible pens.\r\n\r\n Y := Options.YStartOffset + Options.YEnd + (nTextHeight div 2);\r\n\r\n // If chart has X legends:\r\n if (Options.XLegends.Count > 0) or Options.XAxisDateTimeMode then\r\n Y := Y + nTextHeight;\r\n\r\n if Options.PenStyle[I] = psClear then\r\n begin\r\n // For markers, draw marker:\r\n ACanvas.Pen.Color := Options.GetPenColor(I);\r\n GraphXAxisLegendMarker(ACanvas, Options.GetPenMarkerKind(I),\r\n Options.FXLegendHoriz, (Y + 8) - (Options.MarkerSize div 2));\r\n BoxWidth := Options.MarkerSize + 2;\r\n end\r\n else\r\n begin\r\n // For lines, draw a pen color box:\r\n BoxWidth := ACanvas.TextWidth('X') * 2 - 2;\r\n DrawPenColorBox(ACanvas, I, {pen#}\r\n BoxWidth - 2, {width}\r\n nTextHeight - 2, {height}\r\n Options.FXLegendHoriz, {X=}\r\n Y + 4); {Y=}\r\n end;\r\n\r\n //SetFontColor(ACanvas, jvChartAxisColorIndex); XXX\r\n ACanvas.Font.Color := Options.AxisFont.Color;\r\n\r\n // Draw the Pen Legend (WAP :add unit to legend. )\r\n if Options.PenLegends.Count > I then\r\n LLabel := Options.PenLegends[I]\r\n else\r\n LLabel := IntToStr(I + 1);\r\n\r\n // Put units in pen legends\r\n //\r\n // if ( Options.PenUnit.Count > I )\r\n // and ( Length( Options.PenUnit[I] ) > 0 ) then\r\n // myLabel := myLabel + ' ('+Options.PenUnit[I]+')';\r\n\r\n\r\n MyLeftTextOut(ACanvas, Options.FXLegendHoriz + BoxWidth + 3, Y, LLabel);\r\n Inc(Options.FXLegendHoriz, BoxWidth + ACanvas.TextWidth( LLabel) + 14);\r\n //Inc(VisiblePenCount);\r\n //end;\r\n end;\r\nend;{procedure}\r\n\r\n\r\n\r\n\r\nprocedure TJvChart.GraphXAxisLegendMarker(ACanvas: TCanvas; MarkerKind: TJvChartPenMarkerKind; X, Y: Integer);\r\nbegin\r\n case MarkerKind of\r\n pmkDiamond:\r\n PlotFilledDiamond(ACanvas, X, Y);\r\n pmkCircle:\r\n PlotCircle(ACanvas, X, Y);\r\n pmkSquare:\r\n PlotSquare(ACanvas, X, Y);\r\n pmkCross:\r\n PlotCross(ACanvas, X, Y);\r\n end;\r\nend;\r\n\r\nprocedure TJvChart.GraphXAxisLegend; // reworked in 2007.\r\nvar\r\n I: Integer;\r\n Timestamp: TDateTime;\r\n TimestampStr: string;\r\n XOverlap: Integer;\r\n ACanvas: TCanvas;\r\n\r\n { draw x axis text at various alignments:}\r\n function LeftXAxisText: Boolean;\r\n begin\r\n Result := True;\r\n // Don't exceed right margin - causes some undesirable clipping. removed. -wpostma.\r\n {if I < Options.XLegends.Count then\r\n if ACanvas.TextWidth(Options.XLegends[I]) + Options.FXLegendHoriz > (Width XEnd+10) then begin\r\n Result := False;\r\n Exit;\r\n end;}\r\n\r\n // Label X axis above or below?\r\n if FContainsNegative then\r\n begin\r\n if I < Options.XLegends.Count then\r\n begin // fix exception. June 23, 2004- WPostma.\r\n if Options.FXLegendHoriz < XOverlap then\r\n Exit; // would overlap, don't draw it.\r\n MyLeftTextOut(ACanvas, Options.FXLegendHoriz, Options.YEnd + 3, Options.XLegends[I]);\r\n XOverlap := Options.FXLegendHoriz + ACanvas.TextWidth(Options.XLegends[I]);\r\n end;\r\n end\r\n else\r\n if I < Options.XLegends.Count then\r\n begin\r\n if Options.FXLegendHoriz < XOverlap then\r\n Exit; // would overlap, don't draw it.\r\n MyLeftTextOut(ACanvas, Options.FXLegendHoriz,\r\n {bottom:}FXAxisPosition + Options.AxisLineWidth {top: Round(YTempOrigin - Options.PrimaryYAxis.YPixelGap)},\r\n Options.XLegends[I]);\r\n XOverlap := Options.FXLegendHoriz + ACanvas.TextWidth(Options.XLegends[I]);\r\n end\r\n else\r\n Result := False;\r\n end;\r\n\r\n function RightXAxisText: Boolean;\r\n begin\r\n Result := True;\r\n // Label X axis above or below?\r\n if FContainsNegative then\r\n begin\r\n if I < Options.XLegends.Count then // fix exception. June 23, 2004- WPostma.\r\n MyRightTextOut(ACanvas, Options.FXLegendHoriz, Options.YEnd + 3, Options.XLegends[I])\r\n end\r\n else\r\n if I < Options.XLegends.Count then\r\n MyRightTextOut(ACanvas, Options.FXLegendHoriz,\r\n {bottom:}FXAxisPosition + Options.AxisLineWidth {top: Round(YTempOrigin - Options.PrimaryYAxis.YPixelGap)},\r\n Options.XLegends[I])\r\n else\r\n Result := False;\r\n end;\r\n\r\n function CenterXAxisText: Boolean;\r\n begin\r\n Result := True;\r\n // Label X axis above or below?\r\n if FContainsNegative then\r\n begin\r\n if I < Options.XLegends.Count then // fix exception. June 23, 2004- WPostma.\r\n MyCenterTextOut(ACanvas, Options.FXLegendHoriz, Options.YEnd + 3, Options.XLegends[I])\r\n end\r\n else\r\n if I < Options.XLegends.Count then\r\n MyCenterTextOut(ACanvas, Options.FXLegendHoriz,\r\n {bottom:}FXAxisPosition + Options.AxisLineWidth {top: Round(YTempOrigin - Options.PrimaryYAxis.YPixelGap)},\r\n Options.XLegends[I])\r\n else\r\n Result := False;\r\n end;\r\n\r\n procedure XAxisDateTimeModeLabels1; // Classic mode [REFACTORED 2007]\r\n var\r\n L: Integer;\r\n begin\r\n // classic JvChart XAxisDateTime mode labels painting code.\r\n\r\n // if not Options.XAxisDivisionMarkers then Exit;\r\n if Options.XAxisValuesPerDivision <= 0 then\r\n Exit;\r\n if Options.XStartOffset <= 0 then\r\n Exit;\r\n\r\n for L := 1 to Options.XValueCount div Options.XAxisValuesPerDivision - 1 do\r\n begin\r\n Options.FXLegendHoriz := Round(Options.XStartOffset + Options.XPixelGap * L * Options.XAxisValuesPerDivision);\r\n\r\n Timestamp := FData.Timestamp[L * Options.XAxisValuesPerDivision - 1];\r\n if Timestamp < 0.0000001 then\r\n Continue;\r\n\r\n if Length(Options.FXAxisDateTimeFormat) = 0 then // not specified, means use Locale defaults\r\n TimestampStr := TimeToStr(Timestamp)\r\n else\r\n TimestampStr := FormatDateTime(Options.FXAxisDateTimeFormat, Timestamp);\r\n\r\n // Check if writing this label would collide with previous label, if not, plot it\r\n if (Options.FXLegendHoriz - (ACanvas.TextWidth(TimestampStr) div 2)) > XOverlap then\r\n begin\r\n MyCenterTextOut(ACanvas, Options.FXLegendHoriz,\r\n {bottom:}FXAxisPosition + Options.AxisLineWidth\r\n {top: Round(YTempOrigin - Options.PrimaryYAxis.YPixelGap)},\r\n TimestampStr);\r\n\r\n // draw a ticky-boo (technical term used by scientists the world over)\r\n // so that we can see where on the chart the X axis datetime is pointing to.\r\n ACanvas.Pen.Width := 1;\r\n ACanvas.MoveTo(Options.FXLegendHoriz, FXAxisPosition);\r\n ACanvas.LineTo(Options.FXLegendHoriz, FXAxisPosition + Options.AxisLineWidth + 2);\r\n\r\n XOverlap := Options.FXLegendHoriz + ACanvas.TextWidth(TimestampStr);\r\n end;\r\n end;\r\n\r\n end;\r\n\r\n //XAxisDateTimeModeLabels2: [NEW 2007]\r\n // make text labels line up with new division line drawing code\r\n // in GraphXAxisDivisionMarkers:\r\n\r\n procedure XAxisDateTimeModeLabels2; // [NEW 2007]\r\n var\r\n L: Integer;\r\n X: Integer;\r\n DivPixels: Integer;\r\n TextWidth: Integer;\r\n Modn: Integer;\r\n begin\r\n Assert(Options.FXAxisDateTimeSkipBy > 0);\r\n\r\n DivPixels := Round(Options.XPixelGap * Options.FXaxisDateTimeSkipBy);\r\n\r\n for L := 0 to FOptions.FXAxisDateTimeLines - 1 do\r\n begin\r\n Timestamp := FData.Timestamp[(L * Options.FXaxisDateTimeSkipBy)] + Options.FXAxisDateTimeFirstMarker;\r\n\r\n if Timestamp < 0.0000001 then\r\n Continue;\r\n\r\n if Length(Options.FXAxisDateTimeFormat) = 0 then // not specified, means use Locale defaults\r\n TimestampStr := TimeToStr(Timestamp)\r\n else\r\n TimestampStr := FormatDateTime(Options.FXAxisDateTimeFormat, Timestamp);\r\n\r\n TextWidth := ACanvas.TextWidth(TimeStampStr);\r\n if DivPixels > 0 then\r\n begin\r\n Modn := Trunc(TextWidth / DivPixels) + 1;\r\n if Modn > 1 then\r\n begin\r\n if (L mod Modn) <> 0 then\r\n Continue; // skip labels if they are too densely spaced.\r\n end;\r\n end;\r\n\r\n X := Round(Options.XStartOffset + (Options.XPixelGap * L * Options.FXaxisDateTimeSkipBy)) +\r\n Options.FXAxisDateTimeFirstMarker;\r\n if X > Options.XEnd then\r\n Break;\r\n if X = Options.XStartOffset then\r\n Continue; // don't draw dotted line right at X Axis.\r\n\r\n MyCenterTextOut(ACanvas, X,\r\n {bottom:}FXAxisPosition + Options.AxisLineWidth,\r\n TimestampStr);\r\n\r\n ACanvas.Pen.Color := Options.GetPenColor(jvChartDivisionLineColorIndex);\r\n MyDrawDotLine(ACanvas, X, Options.YStartOffset + 1, X, FXAxisPosition - 1);\r\n end;\r\n end;\r\n\r\n procedure DefaultXAxisLegendMode;\r\n var\r\n count:Integer;\r\n K:Integer;\r\n begin\r\n {default X axis legend mode: use text legends}\r\n if Options.FXAxisLegendSkipBy < 1 then\r\n Options.FXAxisLegendSkipBy := 1;\r\n\r\n Count := (Options.XValueCount + (Options.FXAxisLegendSkipBy - 1)) div Options.FXAxisLegendSkipBy;\r\n // Skip the first (Index 0) Axis Label, for visual reasons.\r\n for K := 0 to Count - 1 do\r\n begin\r\n I := K * Options.FXAxisLegendSkipBy;\r\n //Options.FXLegendHoriz := Round(Options.XStartOffset + (Options.XPixelGap * I));\r\n Options.FXLegendHoriz := Round(Options.XStartOffset + Options.XPixelGap * I );\r\n\r\n case Options.FXAxisLabelAlignment of\r\n taLeftJustify:\r\n if not leftXAxisText then break;\r\n taRightJustify:\r\n if not rightXAxisText then break;\r\n taCenter:\r\n if not centerXAxisText then break;\r\n end;\r\n end; {for K}\r\n end; {default mode}\r\n\r\nbegin\r\n {X-LEGEND: ...}\r\n if (Options.XStartOffset = 0) and (Options.YStartOffset = 0) then\r\n Exit;\r\n ACanvas := GetChartCanvas(false);\r\n\r\n XOverlap := 0; // XAxis Label Overlap protection checking variable.\r\n\r\n {Count how many characters to show in the separate legend}\r\n\r\n SetLineColor(ACanvas, jvChartAxisColorIndex);\r\n MyAxisFont(ACanvas);\r\n\r\n { datetime mode for X axis legends : follow the time division markers }\r\n if Options.XAxisDateTimeMode then\r\n begin { if DateTime mode then legends are painted where the division markers are painted }\r\n if (Data.EndDateTime > Data.StartDateTime) and (Options.XAxisDateTimeDivision > 0.00001) then\r\n XAxisDateTimeModeLabels2 // new mode! align division markers to even hour/day/etc boundaries!\r\n else\r\n XAxisDateTimeModeLabels1; // classic mode! let the labels displayed be any old time.\r\n end else\r\n if Options.XValueCount > 0 then // is there data to plot?\r\n begin\r\n DefaultXAxisLegendMode;\r\n end;\r\n DrawChartLegendBelow(ACanvas);\r\n\r\n\r\nend;\r\n\r\nprocedure TJvChart.DrawPenColorBox(ACanvas: TCanvas; NColor, W, H, X, Y: Integer);\r\nbegin\r\n MyColorRectangle(ACanvas, NColor, X, Y, X + W, Y + H);\r\n SetRectangleColor(ACanvas, jvChartPaperColorIndex);\r\nend;\r\n\r\n{**************************************************************************}\r\n{ call this function : }\r\n{ a) when you want to print the graph to Windows default printer }\r\n{**************************************************************************}\r\n\r\nprocedure TJvChart.PrintGraph;\r\nvar\r\n nXEnd, nYEnd: Longint;\r\n nXStart, nYStart: Longint;\r\n nLegendWidth: Longint;\r\nbegin\r\n {Save display values...}\r\n nXEnd := Options.XEnd;\r\n nYEnd := Options.YEnd;\r\n nXStart := Options.XStartOffset;\r\n nYStart := Options.YStartOffset;\r\n nLegendWidth := Options.LegendWidth;\r\n {Calculate new values for printer....}\r\n Options.LegendWidth := Round((Options.LegendWidth / (nXEnd + Options.LegendWidth)) * Printer.PageWidth);\r\n Options.XStartOffset := Round(Printer.PageWidth * 0.08); {8%}\r\n Options.YStartOffset := Round(Printer.PageHeight * 0.1); {10%}\r\n Options.XEnd := Round(Printer.PageWidth - (1.2 * Options.LegendWidth)) - Options.XStartOffset;\r\n Options.YEnd := Round(Printer.PageHeight * 0.75);\r\n if Options.YEnd > Options.XEnd then\r\n Options.YEnd := Options.XEnd;\r\n {Begin printing...}\r\n PrintInSession := True;\r\n Printer.BeginDoc;\r\n PlotGraph; {Here it goes!}\r\n Printer.EndDoc;\r\n PrintInSession := False;\r\n {Restore display values...}\r\n Options.XStartOffset := nXStart; {margin}\r\n Options.YStartOffset := nYStart;\r\n Options.XEnd := nXEnd;\r\n Options.YEnd := nYEnd;\r\n Options.LegendWidth := nLegendWidth;\r\nend;\r\n\r\n{**************************************************************************}\r\n{ call this function : }\r\n{ a) when you want to print the graph to Windows default printer }\r\n{ AND you add something else on the same paper. This function }\r\n{ will just add the chart to the OPEN printer canvas at given position }\r\n{**************************************************************************}\r\n\r\n// (rom) XStartPos, YStartPos unused\r\n\r\nprocedure TJvChart.AddGraphToOpenPrintCanvas(XStartPos, YStartPos, GraphWidth, GraphHeight: Longint);\r\nvar\r\n nXEnd, nYEnd: Longint;\r\n nXStart, nYStart: Longint;\r\n nLegendWidth: Longint;\r\nbegin\r\n {Save display values...}\r\n nXEnd := Options.XEnd;\r\n nYEnd := Options.YEnd;\r\n nXStart := Options.XStartOffset;\r\n nYStart := Options.YStartOffset;\r\n nLegendWidth := Options.LegendWidth;\r\n {Set new values for printing the graph at EXISTING print canvas....}\r\n Options.LegendWidth := Round((Options.LegendWidth / (nXEnd + Options.LegendWidth)) * GraphWidth);\r\n Options.XStartOffset := Round(GraphWidth * 0.08); {8%}\r\n Options.YStartOffset := Round(GraphHeight * 0.1); {10%}\r\n Options.XEnd := Round(GraphWidth - (1.2 * Options.LegendWidth)) - Options.XStartOffset;\r\n Options.YEnd := Round(GraphHeight * 0.75);\r\n {Begin printing...NOTICE BeginDoc And EndDoc must be done OUTSIDE this procedure call}\r\n PrintInSession := True;\r\n PlotGraph; {Here it goes!}\r\n PrintInSession := False;\r\n {Restore display values...}\r\n Options.XStartOffset := nXStart; {margin}\r\n Options.YStartOffset := nYStart;\r\n Options.XEnd := nXEnd;\r\n Options.YEnd := nYEnd;\r\n Options.LegendWidth := nLegendWidth;\r\nend;\r\n\r\n{NEW}\r\n{ when the user clicks the chart and changes the axis, we need a notification\r\n so we can save the new settings. }\r\n\r\nprocedure TJvChart.NotifyOptionsChange;\r\nbegin\r\n if FUpdating then\r\n Exit;\r\n if csDesigning in ComponentState then\r\n begin\r\n Invalidate;\r\n Exit;\r\n end;\r\n if csLoading in ComponentState then\r\n Exit; // Component properties being set at runtime.\r\n\r\n if Options.PenCount <> Self.Data.FPenCount then\r\n begin\r\n if Options.PenCount > 0 then { never set Data.FPenCount to zero internally! }\r\n Data.FPenCount := Options.PenCount;\r\n end;\r\n\r\n // Event fire:\r\n if Assigned(FOnOptionsChangeEvent) then\r\n FOnOptionsChangeEvent(Self);\r\n if Options.AutoUpdateGraph then\r\n begin\r\n FAutoPlotDone := False; // Next paint will also call PlotGraph\r\n Invalidate;\r\n end;\r\nend;\r\n\r\n{ Warren implemented TImage related code directly into TJvChart, to remove TImage as base class.}\r\n// (rom) simplified by returning the Printer ACanvas when printing\r\n\r\nfunction TJvChart.GetChartCanvas(isFloating:Boolean): TCanvas;\r\nvar\r\n Bitmap: TBitmap;\r\nbegin\r\n { designtime - draw directly to screen }\r\n if csDesigning in ComponentState then\r\n begin\r\n Result := Self.Canvas;\r\n Assert(Assigned(Result));\r\n Assert(Assigned(Result.Brush));\r\n Exit;\r\n end;\r\n\r\n // external picture mode?\r\n if Assigned(FExtPicture) and Assigned(FExtPicture.Graphic) then begin\r\n if FExtPicture.Graphic is TBitmap then begin\r\n result := TBitmap(FExtPicture.Graphic).Canvas;\r\n exit;\r\n end else begin\r\n raise EInvalidOperation.Create(RsEUnableToGetCanvas);\r\n end;\r\n end;\r\n\r\n\r\n { printer canvas }\r\n if PrintInSession then\r\n begin\r\n Result := Printer.Canvas;\r\n Assert(Assigned(Result));\r\n Assert(Assigned(Result.Brush));\r\n Exit;\r\n end;\r\n\r\n { Floating marker draw but not external picture mode:}\r\n if isFloating then begin\r\n Result := Self.Canvas;\r\n exit;\r\n end;\r\n\r\n\r\n { FPicture.Graphic -bitmap canvas - normal display method. }\r\n if FPicture.Graphic = nil then\r\n begin\r\n Bitmap := TBitmap.Create;\r\n try\r\n Bitmap.Width := Width;\r\n Bitmap.Height := Height;\r\n FPicture.Graphic := Bitmap;\r\n finally\r\n Bitmap.Free;\r\n end;\r\n end;\r\n if FPicture.Graphic is TBitmap then\r\n begin\r\n Result := TBitmap(FPicture.Graphic).Canvas;\r\n Assert(Assigned(Result));\r\n Assert(Assigned(Result.Brush));\r\n end\r\n else\r\n raise EInvalidOperation.CreateRes(@RsEUnableToGetCanvas);\r\nend;\r\n\r\nfunction TJvChart.GetChartCanvasWidth: Integer; // WP NEW 2007\r\nbegin\r\n { designtime - draw directly to screen }\r\n if csDesigning in ComponentState then\r\n begin\r\n Result := Width;\r\n Exit;\r\n end;\r\n if Assigned(FExtPicture) then begin\r\n result := FExtPicture.Graphic.Width;\r\n exit;\r\n end;\r\n if PrintInSession then\r\n begin\r\n Result := Printer.PageWidth;\r\n Exit;\r\n end;\r\n if Assigned(FPicture) then\r\n Result := FPicture.Width\r\n else\r\n Result := Width;\r\nend;\r\n\r\nfunction TJvChart.GetChartCanvasHeight: Integer; // WP NEW 2007\r\nbegin\r\n { designtime - draw directly to screen }\r\n if csDesigning in ComponentState then\r\n begin\r\n Result := Self.Height;\r\n Exit;\r\n end;\r\n if Assigned(FExtPicture) then begin\r\n result := FExtPicture.Graphic.Height;\r\n exit;\r\n end;\r\n\r\n { printer canvas }\r\n if PrintInSession then\r\n begin\r\n Result := Printer.PageHeight;\r\n Exit;\r\n end;\r\n\r\n { FPicture.Graphic -bitmap canvas - normal display method. }\r\n if Assigned(FPicture) then\r\n Result := FPicture.Height\r\n else\r\n Result := Self.Height;\r\nend;\r\n\r\nprocedure TJvChart.CalcYEnd;\r\nvar\r\n aHeight:Integer;\r\nbegin\r\n if Assigned(FExtPicture) then begin\r\n aHeight := FExtPicture.Bitmap.Height;\r\n end else begin\r\n if not Assigned(FBitmap) then exit;\r\n aHeight := FBitmap.Height;\r\n end;\r\n\r\n Options.YEnd := aHeight - 2 * Options.YStartOffset; {canvas size, excluding margin}\r\nend;\r\n{**************************************************************************}\r\n{ call this function : }\r\n{ a) when you resize the canvas for the AABsoftGraph }\r\n{ b) at program startup before drawing the first graph }\r\n{**************************************************************************}\r\n\r\n// ResizeChartCanvas/PlotGraph endless recursion loop fixed. --WP\r\n\r\nprocedure TJvChart.ResizeChartCanvas;\r\nvar\r\n awidth:Integer;\r\nbegin\r\n {Add code for my own data...here}\r\n if Assigned(FExtPicture) then begin\r\n awidth := FExtPicture.Graphic.Width;\r\n end else begin\r\n if not Assigned(FBitmap) then\r\n begin\r\n FBitmap := TBitmap.Create;\r\n FBitmap.Height := Height;\r\n FBitmap.Width := Width;\r\n FPicture.Graphic := FBitmap;\r\n end\r\n else\r\n begin\r\n FBitmap.Width := Width;\r\n FBitmap.Height := Height;\r\n FPicture.Graphic := FBitmap;\r\n end;\r\n awidth := Width;\r\n end;\r\n\r\n CalcYEnd; // YEnd depends on YStartOffset.\r\n\r\n if Options.Legend = clChartLegendRight then\r\n Options.XEnd := Round(((awidth - 2) - 1.5 * Options.XStartOffset) - Options.LegendWidth)\r\n else\r\n Options.XEnd := Round((awidth - 2) - 0.5 * Options.XStartOffset);\r\n\r\n if Options.XEnd < 10 then\r\n Options.XEnd := 10;\r\n if Options.YEnd < 10 then\r\n Options.YEnd := 10;\r\n\r\n if not Assigned(Data) then\r\n Exit; //safety.\r\n // if Data.ValueCount = 0 then\r\n // Exit; // no use, there's no data yet.\r\n\r\n Options.PrimaryYAxis.Normalize;\r\n Options.SecondaryYAxis.Normalize;\r\n\r\n if (not FInPlotGraph) and Visible {and (Data.ValueCount>0)} then // endless recursion protection.\r\n if Options.AutoUpdateGraph or FPlotGraphCalled then\r\n begin\r\n FInPlotGraph := True; // recursion blocker.\r\n InternalPlotGraph; { must not call Invalidate here, causes exceptions in some cases. }\r\n FInPlotGraph := False;\r\n end;\r\nend;\r\n\r\n{This procedure is called when user clicks on the main header}\r\n\r\nprocedure TJvChart.EditHeader;\r\nvar\r\n StrString: string;\r\nbegin\r\n StrString := Options.Title;\r\n if InputQuery(RsGraphHeader, Format(RsCurrentHeaders, [Options.Title]), StrString) then\r\n Options.Title := StrString;\r\n InternalPlotGraph;\r\n Invalidate;\r\n if Assigned(FOnTitleClick) then\r\n FOnTitleClick(Self);\r\nend;\r\n\r\n{This procedure is called when user clicks on the X-axis header}\r\n\r\nprocedure TJvChart.EditXHeader;\r\nvar\r\n StrString: string;\r\nbegin\r\n StrString := Options.XAxisHeader;\r\n if InputQuery(RsGraphHeader, Format(RsXAxisHeaders, [Options.XAxisHeader]), StrString) then\r\n Options.XAxisHeader := StrString;\r\n InternalPlotGraph;\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvChart.EditYScale;\r\nvar\r\n StrString: string;\r\nbegin\r\n StrString := FloatToStr(Options.PrimaryYAxis.YMax);\r\n\r\n // NOTE: StrToFloatDefIgnoreInvalidCharacters now called JvSafeStrToFloatDef:\r\n\r\n if InputQuery(RsGraphScale, Format(RsYAxisScales, [FloatToStr(Options.PrimaryYAxis.YMax)]), StrString) then\r\n Options.PrimaryYAxis.YMax := JvSafeStrToFloatDef(StrString, Options.PrimaryYAxis.YMax)\r\n else\r\n Exit;\r\n\r\n // Fire event so the application can save this new Options.PrimaryYAxis.YMax value\r\n if Assigned(FOnYAxisClick) then\r\n FOnYAxisClick(Self);\r\n\r\n //XXX AutoFormatGraph; BAD CODE REMOVED. Wpostma. Call PlotGraph instead.\r\n InternalPlotGraph;\r\n Invalidate;\r\nend;\r\n\r\n// NEW: X Axis Header has to move to make room if there is a horizontal\r\n// X axis legend:\r\n\r\nprocedure TJvChart.MyXHeader(ACanvas: TCanvas; StrText: string);\r\nvar\r\n X, Y, H: Integer;\r\nbegin\r\n H := ACanvas.TextHeight(StrText);\r\n MyAxisFont(ACanvas);\r\n Y := Options.YStartOffset + Options.YEnd + Round(1.6 * H);\r\n if Options.Legend = clChartLegendBelow then\r\n begin\r\n { left aligned X Axis Title, right after the legend itself}\r\n X := Options.FXLegendHoriz + 32;\r\n MyLeftTextOut(ACanvas, X, Y, StrText);\r\n end\r\n else\r\n begin\r\n X := Options.XStartOffset + (Options.XEnd div 2);\r\n MyCenterTextOut(ACanvas, X, Y, StrText);\r\n end;\r\nend;\r\n\r\nprocedure TJvChart.MyYHeader(ACanvas: TCanvas; StrText: string);\r\nvar\r\n {ht,}WD, Vert, Horiz: Integer; // not used (ahuser)\r\nbegin\r\n if Length(StrText) = 0 then\r\n Exit;\r\n ACanvas.Brush.Color := Color;\r\n { !!warning: uses Win32 only font-handle stuff!!}\r\n MyGraphVertFont(ACanvas); // Select Vertical Font Output.\r\n if Options.XStartOffset > 10 then\r\n begin\r\n {ht := MyTextHeight(StrText); }// not used (ahuser)\r\n WD := ACanvas.TextWidth(StrText);\r\n // Kindof a fudge, but we'll work out something better later... :-) -WAP.\r\n Vert := Options.YStartOffset * 2 + Height div 2 - WD div 2;\r\n if Vert < 0 then\r\n Vert := 0;\r\n Horiz := 2;\r\n // NOTE: Because of the logical font selected, this time TextOut goes vertical.\r\n // If this doesn't go vertical, it may be because the font selection above failed.\r\n MyLeftTextOut(ACanvas, Horiz, Vert, StrText);\r\n end;\r\n MyAxisFont(ACanvas);\r\n // Self.MyLeftTextOut(Horiz, Vert+50, '*');\r\nend;\r\n\r\n{***************************************************************************}\r\n{ MOUSE FUNCTIONS AND PROCEDURES }\r\n{***************************************************************************}\r\n\r\nfunction TJvChart.MouseToXValue(X: Integer): Integer;\r\nvar\r\n XPixelGap: Double;\r\nbegin\r\n XPixelGap := ((Options.XEnd - Options.XStartOffset) / Options.XValueCount);\r\n if XPixelGap > 0.001 then\r\n begin\r\n Result := Round(((X - 1) - Options.XStartOffset) / (XPixelGap));\r\n if (Result >= Data.ValueCount - 1) then\r\n Result := Data.ValueCount - 1\r\n else\r\n if Result < 0 then\r\n Result := 0;\r\n end\r\n else\r\n Result := 0; // can't figure it out.\r\nend;\r\n\r\nfunction TJvChart.MouseToYValue(Y: Integer): Double;\r\nbegin\r\n with FOptions.PrimaryYAxis do\r\n begin\r\n //Y = (YOrigin - (((Result - YMin) / YGap) * YPixelGap))\r\n\r\n Result := -1 * (((Y / YPixelGap) * YGap) - ((YOrigin / YPixelGap) * YGap) - YMin);\r\n\r\n if Result < YMin then\r\n Result := YMin\r\n else\r\n if Result > YMax then\r\n Result := YMax;\r\n end;\r\nend;\r\n\r\nprocedure TJvChart.MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);\r\nbegin\r\n Screen.Cursor := crDefault;\r\n inherited MouseUp(Button, Shift, X, Y);\r\n\r\n if Options.MouseDragObjects then\r\n begin\r\n if Assigned(FDragFloatingMarker) then\r\n begin\r\n FDragFloatingMarker.FDragging := False;\r\n // Solve for X Position etc.\r\n FDragFloatingMarker.XPosition := MouseToXValue(X);\r\n\r\n FDragFloatingMarker.YPosition := MouseToYValue(Y);\r\n //OutputDebugString(PChar( 'End Mouse Drag Floating Object at '+InTToStr(FDragFloatingMarker.XPosition)+','+FloatToStr(FDragFloatingMarker.YPosition)) );\r\n if Assigned(FOnEndFloatingMarkerDrag) then\r\n FOnEndFloatingMarkerDrag(Self, FDragFloatingMarker);\r\n\r\n FDragFloatingMarker := nil;\r\n Invalidate;\r\n Exit;\r\n end;\r\n end;\r\n\r\n if FStartDrag then\r\n begin\r\n Options.LegendWidth := Options.LegendWidth + (FMouseDownX - X);\r\n Options.XEnd := Options.XEnd - (FMouseDownX - X);\r\n InternalPlotGraph;\r\n end;\r\n if FMouseLegend then\r\n begin\r\n InternalPlotGraph;\r\n FMouseLegend := False;\r\n end;\r\n FStartDrag := False;\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvChart.MouseMove(Shift: TShiftState; X, Y: Integer); //override;\r\nbegin\r\n inherited MouseMove(Shift, X, Y);\r\n if Assigned(FDragFloatingMarker) then\r\n begin\r\n if FDragFloatingMarker.XDraggable then\r\n begin\r\n if X < Options.XStartOffset then\r\n X := Options.XStartOffset;\r\n if X > Options.XEnd then\r\n X := Options.XEnd;\r\n FDragFloatingMarker.FRawXPosition := X;\r\n end;\r\n if FDragFloatingMarker.YDraggable then\r\n if Y > FXAxisPosition then\r\n Y := FXAxisPosition;\r\n\r\n if Y < Options.YStartOffset then\r\n Y := Options.YStartOffset;\r\n\r\n FDragFloatingMarker.FRawYPosition := Y;\r\n\r\n Self.Invalidate; // Repaint control LATER ! .. like a PostMessage(WM_PAINT)\r\n //Self.Repaint; // much more CPU intensive, but smoother.\r\n end;\r\n\r\nend;\r\n\r\nprocedure TJvChart.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);\r\nvar\r\n XPixelGap: Double;\r\n I: Integer;\r\n // YPixelGap: Double; // not used (ahuser)\r\n Marker: TJvChartFloatingMarker;\r\nbegin\r\n inherited MouseDown(Button, Shift, X, Y);\r\n\r\n if Options.MouseDragObjects then\r\n begin\r\n if not Assigned(FDragFloatingMarker) then\r\n begin\r\n for I := 0 to FFloatingMarker.Count - 1 do\r\n begin\r\n Marker := GetFloatingMarker(I);\r\n if not Marker.Visible then\r\n Continue;\r\n if not (Marker.XDraggable or Marker.YDraggable) then\r\n Continue;\r\n if (Abs(X - Marker.FRawXPosition) < (Options.MarkerSize * 2)) and\r\n ((Marker.Marker = pmkNone) or (Abs(Y - Marker.FRawYPosition) < Options.MarkerSize * 2)) then\r\n begin\r\n FDragFloatingMarker := Marker;\r\n FDragFloatingMarker.FDragging := True;\r\n //OutputDebugString('Begin Mouse Drag Floating Object');\r\n if Assigned(FOnBeginFloatingMarkerDrag) then\r\n FOnBeginFloatingMarkerDrag(Self, FDragFloatingMarker);\r\n Exit;\r\n end;\r\n end;\r\n end;\r\n\r\n end;\r\n\r\n if Options.MouseEdit then\r\n begin\r\n if X < Options.XStartOffset then\r\n begin\r\n EditYScale;\r\n Exit;\r\n end\r\n else\r\n // New: Don't let end user mess with title, if we\r\n // provide our own way to set the title or title options,\r\n // however, if Options.MouseEdit is on, they can still set the\r\n // scale via mouse clicking.\r\n if (Y < Options.YStartOffset) and not Assigned(FOnTitleClick) then\r\n begin\r\n EditHeader;\r\n Exit;\r\n end;\r\n\r\n if (Y > Options.YStartOffset + Options.YEnd) and not Assigned(FOnXAxisClick) then\r\n begin\r\n EditXHeader;\r\n Exit;\r\n end;\r\n end;\r\n\r\n if X < Options.XStartOffset then\r\n begin\r\n // Just fire the Y axis clicked event, don't popup the editor\r\n if Assigned(FOnYAxisClick) then\r\n begin\r\n FOnYAxisClick(Self);\r\n Exit;\r\n end;\r\n end\r\n else\r\n if Y < Options.YStartOffset then\r\n if Assigned(FOnTitleClick) then\r\n FOnTitleClick(Self);\r\n // New: Click on bottom area of chart (X Axis) can be defined by\r\n // user of the component to do something.\r\n if Assigned(FOnXAxisClick) then\r\n if (Y > Options.YEnd) and (X > Options.XStartOffset) then\r\n begin\r\n FOnXAxisClick(Self);\r\n Exit;\r\n end;\r\n if Assigned(FOnAltYAxisClick) then\r\n if (Y < Options.YEnd) and (X > Options.XEnd) then\r\n FOnAltYAxisClick(Self);\r\n\r\n if Options.MouseInfo then\r\n begin\r\n FStartDrag := False;\r\n FMouseDownX := X;\r\n FMouseDownY := Y;\r\n if (Y > Options.YStartOffset) and\r\n (Y < Options.YStartOffset + Options.YEnd) and\r\n (X > Options.XStartOffset) and\r\n (X < Options.XStartOffset + Options.XEnd + 10) then\r\n begin\r\n {Legend resize...}\r\n if X > (Options.XStartOffset + Options.XEnd) - 5 then\r\n begin\r\n FStartDrag := True;\r\n Screen.Cursor := crSizeWE;\r\n end;\r\n {Inside the actual graph...}\r\n if (X <= (Options.XStartOffset + Options.XEnd) - 5) and\r\n (Options.ChartKind <> ckChartPieChart) and\r\n (Options.ChartKind <> ckChartDeltaAverage) then\r\n begin\r\n XPixelGap := ((Options.XEnd - Options.XStartOffset) / (Options.XValueCount + 1));\r\n //if XPixelGap <1 then\r\n // XPixelGal := 1;\r\n if XPixelGap > 0.001 then\r\n FMouseValue := Round((X - Options.XStartOffset) / (XPixelGap))\r\n else\r\n FMouseValue := 0; // can't figure it out.\r\n\r\n case Options.ChartKind of\r\n ckChartBar, ckChartBarAverage:\r\n if Options.PenCount = 1 then {check for Pen count}\r\n FMousePen := Round(((X + (XPixelGap / 2)) -\r\n (Options.XStartOffset +\r\n Options.XOrigin * XPixelGap +\r\n XPixelGap * FMouseValue)) /\r\n Round(XPixelGap / (Options.PenCount + 0.1)) + 0.1)\r\n else\r\n FMousePen := Round(((X + (XPixelGap / 2)) -\r\n (Options.XStartOffset +\r\n Options.XOrigin * XPixelGap +\r\n XPixelGap * FMouseValue)) /\r\n Round(XPixelGap / (Options.PenCount + 0.5)) + 0.5);\r\n ckChartStackedBar, ckChartLine, ckChartStackedBarAverage:\r\n FMousePen := 0;\r\n end;\r\n if (FMouseValue > Options.XValueCount) or (FMouseValue < 0) then\r\n FMouseValue := 0;\r\n if FMousePen > Options.PrimaryYAxis.YDivisions then\r\n FMousePen := 0;\r\n\r\n // New: Allow user to do custom hints, or else do other things\r\n // when a chart is clicked.\r\n if Assigned(FOnChartClick) then\r\n begin\r\n FMouseDownShowHint := False;\r\n FMouseDownHintBold := False;\r\n // This event can handle chart clicks on data area only.\r\n if X <= Options.XEnd then\r\n FOnChartClick(Self, Button, Shift, X, Y, FMouseValue,\r\n FMousePen, FMouseDownShowHint,\r\n FMouseDownHintBold, FMouseDownHintStrs);\r\n end\r\n else\r\n begin\r\n if Button = mbLeft then\r\n begin\r\n FMouseDownShowHint := True;\r\n FMouseDownHintBold := True;\r\n AutoHint;\r\n end\r\n else\r\n FMouseDownShowHint := False; { don't show }\r\n end;\r\n\r\n if (FMouseDownHintStrs.Count > 0) and FMouseDownShowHint then\r\n ShowMouseMessage(X, Y);\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvChart.SetCursorPosition(Pos: Integer);\r\nbegin\r\n FCursorPosition := Pos;\r\n Invalidate; // repaint!\r\nend;\r\n\r\nprocedure TJvChart.DisplayBars; // NEW 2007!\r\nbegin\r\n DrawHorizontalBars;\r\n DrawVerticalBars;\r\nend;\r\n\r\n{ make list of 'PenName=Value' strings for each pen.. }\r\n\r\nprocedure TJvChart.AutoHint; // Make the automatic hint message showing all pens and their values.\r\nvar\r\n I: Integer;\r\n Str: string;\r\n Val: Double;\r\nbegin\r\n FMouseDownHintStrs.Clear;\r\n\r\n if Options.XAxisDateTimeMode then\r\n begin\r\n if Length(Options.DateTimeFormat) = 0 then\r\n Str := DateTimeToStr(FData.GetTimestamp(FMouseValue))\r\n else\r\n Str := FormatDateTime(Options.DateTimeFormat, FData.GetTimestamp(FMouseValue));\r\n\r\n FMouseDownHintStrs.Add(Str);\r\n end\r\n else\r\n if Options.XLegends.Count > FMouseValue then\r\n FMouseDownHintStrs.Add(Options.XLegends[FMouseValue]);\r\n\r\n for I := 0 to Options.PenCount - 1 do\r\n begin\r\n if Options.PenLegends.Count <= I then\r\n Break; // Exception fixed. WP\r\n Str := Options.PenLegends[I];\r\n Val := FData.Value[I, FMouseValue];\r\n if Length(Str) = 0 then\r\n Str := IntToStr(I + 1);\r\n Str := Str + ' : ';\r\n if IsNaN(Val) then\r\n Str := Str + RsNA\r\n else\r\n begin\r\n Str := Str + FloatToStrF(Val, ffFixed, REALPREC, 3);\r\n if Options.PenUnit.Count > I then\r\n Str := Str + ' ' + Options.PenUnit[I];\r\n end;\r\n\r\n FMouseDownHintStrs.Add(Str);\r\n {$IFDEF DEBUGINFO_ON}\r\n OutputDebugString(PChar('TJvChart.AutoHint: ' + Str));\r\n {$ENDIF DEBUGINFO_ON}\r\n end;\r\nend;\r\n\r\n(* orphaned\r\n\r\n {We will show some Double values...}\r\nif FMousePen = 0 then\r\nbegin\r\n{show all values in the Pen...}\r\nnLineCount := Options.PenCount;\r\nnHeight := nLineH * (nLineCount + 2);\r\nif Options.XLegends.Count > FMouseValue then\r\nstrMessage1 := Options.XLegends[FMouseValue]\r\nelse\r\nstrMessage1 := '';\r\nstrMessage2 := '-';\r\nif nWidth < ChartCanvas.TextWidth(strMessage1) then\r\nnWidth := ChartCanvas.TextWidth(strMessage1);\r\nend\r\nelse\r\nbegin\r\nnLineCount := 1;\r\nnHeight := nLineH * (nLineCount + 2);\r\nstrMessage1 := Options.XLegends[FMouseValue];\r\nif nWidth < ChartCanvas.TextWidth(strMessage1) then\r\nnWidth := ChartCanvas.TextWidth(strMessage1);\r\nif FMousePen > 0 then\r\nstrMessage2 := Options.PenLegends[FMousePen];\r\nif ChartCanvas.TextWidth(strMessage2) > nWidth then\r\nnWidth := ChartCanvas.TextWidth(strMessage2);\r\nstrMessage3 := FloatToStrF(FData.Value[FMousePen, FMouseValue], ffFixed, REALPREC, 3);\r\nend;\r\n\r\n*)\r\n\r\n{ ShowMouseMessage can invoke an OnChartClick event, and/or\r\nshows hint boxes, etc. }\r\n\r\nprocedure TJvChart.ShowMouseMessage(X, Y: Integer);\r\nvar\r\n nWidth: Integer;\r\n nHeight: Integer;\r\n nLineH: Integer;\r\n nLineCount: Integer;\r\n I: Integer;\r\n StrWidth, StrHeight: Integer;\r\n ACanvas: TCanvas;\r\nbegin\r\n ACanvas := GetChartCanvas({floating}true);\r\n ACanvas.Font.Color := Font.Color; // March 2004 Fixed.\r\n\r\n // scan and set nWidth,nLineH\r\n nWidth := 100; // minimum 100 pixel hint box width.\r\n nLineH := 8; // minimum 8 pixel line height for hints.\r\n nLineCount := FMouseDownHintStrs.Count;\r\n\r\n for I := 0 to nLineCount - 1 do\r\n begin\r\n StrWidth := ACanvas.TextWidth(FMouseDownHintStrs[I]);\r\n if StrWidth > nWidth then\r\n nWidth := StrWidth;\r\n StrHeight := ACanvas.TextHeight(FMouseDownHintStrs[I]);\r\n if StrHeight > nLineH then\r\n nLineH := StrHeight;\r\n end;\r\n\r\n // bump height of text in hint box,\r\n // leaving a little extra pixel space between rows.\r\n nLineH := Round(nLineH * 1.07) + 1;\r\n\r\n {RsNoValuesHere}\r\n if FMouseDownHintStrs.Count = 0 then\r\n begin\r\n StrWidth := ACanvas.TextWidth(RsNoValuesHere);\r\n if StrWidth > nWidth then\r\n nWidth := StrWidth;\r\n MyColorRectangle(ACanvas, jvChartHintColorIndex, X + 3, Y + 3, X + nWidth + 3 + 5, Y + nLineH + 3);\r\n MyColorRectangle(ACanvas, jvChartPaperColorIndex, X, Y, X + nWidth + 5, Y + nLineH);\r\n ACanvas.Font.Color := Self.Font.Color;\r\n MyLeftTextOutHint(ACanvas, X + 2, Y, RsNoValuesHere);\r\n FMouseLegend := True;\r\n Exit;\r\n end;\r\n\r\n // Get hint box height/width, size to contents:\r\n nWidth := nWidth + 25;\r\n nHeight := nLineH * nLineCount + 8;\r\n\r\n // keep hint from clipping at bottom and right.\r\n if (Y + nHeight) > Self.Height then\r\n Y := (Self.Height - nHeight);\r\n if (X + nWidth) > Self.Width then\r\n X := (Self.Width - nWidth);\r\n\r\n // Draw hint box:\r\n MyColorRectangle(ACanvas, jvChartPaperColorIndex, X + 3, Y + 3, X + nWidth + 3, Y + nHeight + 3);\r\n MyColorRectangle(ACanvas, jvChartHintColorIndex, X, Y, X + nWidth, Y + nHeight);\r\n\r\n //MyLeftTextOut( ACanvas, X + 3, Y + 3, 'Foo');\r\n\r\n // Draw text inside the hint box:\r\n ACanvas.Font.Color := Self.Font.Color;\r\n //ACanvas.Font.Style :=\r\n\r\n if FMouseDownHintBold then\r\n ACanvas.Font.Style := [fsBold];\r\n\r\n for I := 0 to nLineCount - 1 do\r\n begin\r\n if (I = 1) and FMouseDownHintBold then\r\n ACanvas.Font.Style := [];\r\n MyLeftTextOutHint(ACanvas, X + 2, 4 + Y + (I * nLineH), FMouseDownHintStrs[I]); // draw text for each line.\r\n end;\r\n\r\n FMouseLegend := True;\r\n\r\n //Invalidate; //removed to solve painting glitch.\r\n //ResizeChartCanvas; // removed to solve painting glitch.\r\nend;\r\n\r\n{***************************************************************************}\r\n{ PIE FUNCTIONS AND PROCEDURES }\r\n{***************************************************************************}\r\n\r\nprocedure TJvChart.GraphPieChart(NPen: Integer);\r\nvar\r\n nSize: Integer;\r\n I: Integer;\r\n nLast: Integer;\r\n nXExtra: Integer;\r\n nSum: Double;\r\n n100Sum: Double;\r\n nP: Double;\r\n ACanvas: TCanvas;\r\nbegin\r\n ACanvas := GetChartCanvas(false);\r\n ClearScreen;\r\n\r\n {Main Header}\r\n MyHeader(ACanvas, Options.Title);\r\n MyPieLegend(NPen);\r\n if Options.XEnd < Options.YEnd then\r\n begin\r\n nSize := Options.XEnd;\r\n nXExtra := 0;\r\n end\r\n else\r\n begin\r\n nSize := Options.YEnd;\r\n nXExtra := Round((Options.XEnd - Options.YEnd) / 2);\r\n end;\r\n {Count total sum...}\r\n n100Sum := 0;\r\n for I := 1 to MAX_VALUES do\r\n n100Sum := n100Sum + FData.Value[NPen, I];\r\n {Show background pie....}\r\n SetRectangleColor(ACanvas, jvChartAxisColorIndex); {black...}\r\n MyPiePercentage(Options.XStartOffset + nXExtra + 2,\r\n Options.YStartOffset + 2, nSize, 100);\r\n {Show pie if not zero...}\r\n if n100Sum <> 0 then\r\n begin\r\n nSum := n100Sum;\r\n nLast := Options.XValueCount + 1;\r\n if nLast > MAX_VALUES then\r\n nLast := MAX_VALUES;\r\n for I := nLast downto 2 do\r\n begin\r\n nSum := nSum - FData.Value[NPen, I];\r\n nP := 100 * (nSum / n100Sum);\r\n SetRectangleColor(ACanvas, I - 1);\r\n MyPiePercentage(Options.XStartOffset + nXExtra,\r\n Options.YStartOffset, nSize, nP);\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvChart.MyPiePercentage(X1, Y1, W: Longint; NPercentage: Double);\r\nvar\r\n nOriginX, nOriginY: Longint;\r\n nGrade: Double;\r\n nStartGrade: Double;\r\n X, Y: Double;\r\n nLen: Double;\r\nbegin\r\n nOriginX := Round((W - 1.01) / 2) + X1;\r\n nOriginY := Round((W - 1.01) / 2) + Y1;\r\n nGrade := (NPercentage / 100) * 2 * Pi;\r\n nStartGrade := (2 / 8) * 2 * Pi;\r\n nLen := Round((W - 1) / 2);\r\n X := Cos(nStartGrade + nGrade) * nLen;\r\n Y := Sin(nStartGrade + nGrade) * nLen;\r\n MyPie(GetChartCanvas(false), X1, Y1, X1 + W, Y1 + W,\r\n nOriginX, Y1, nOriginX + Round(X), nOriginY - Round(Y));\r\nend;\r\n\r\nprocedure TJvChart.MyPieLegend(NPen: Integer);\r\nvar\r\n I: Integer;\r\n nTextHeight: Longint;\r\n {nChars: Integer;}// not used (ahuser)\r\n XLegendStr: string;\r\n ACanvas: TCanvas;\r\nbegin\r\n ACanvas := GetChartCanvas(false);\r\n {Count how many characters to show in the separate legend}\r\n {nChars := Round(Options.LegendWidth / ChartCanvas.TextWidth('1'));}// not used (ahuser)\r\n {Decrease the value due to the color box shown}\r\n {if (nChars>4) then nChars := nChars-4;}// not used (ahuser)\r\n\r\n MySmallGraphFont(ACanvas);\r\n nTextHeight := Round(CanvasMaxTextHeight(ACanvas) * 1.2);\r\n\r\n // Pie Chart Right Side Legend.\r\n if Options.Legend = clChartLegendRight then\r\n begin\r\n MyColorRectangle(ACanvas, 0,\r\n Options.XStartOffset + Options.XEnd + 6,\r\n Options.YStartOffset + 1 * nTextHeight + 6 + 4,\r\n Options.XStartOffset + Options.XEnd + Options.LegendWidth + 6,\r\n Options.YStartOffset + (Options.XValueCount + 1) * nTextHeight + 6 + 4);\r\n MyColorRectangle(ACanvas, jvChartPaperColorIndex,\r\n Options.XStartOffset + Options.XEnd + 3,\r\n Options.YStartOffset + 1 * nTextHeight + 3 + 4,\r\n Options.XStartOffset + Options.XEnd + Options.LegendWidth + 3,\r\n Options.YStartOffset + (Options.XValueCount + 1) * nTextHeight + 3 + 4);\r\n for I := 1 to Options.XValueCount do\r\n begin\r\n DrawPenColorBox(ACanvas, I, ACanvas.TextWidth('12') - 2, nTextHeight - 4,\r\n Options.XStartOffset + Options.XEnd + 7,\r\n Options.YStartOffset + I * nTextHeight + 9);\r\n SetFontColor(ACanvas, jvChartAxisColorIndex);\r\n if I - 1 < Options.XLegends.Count then\r\n XLegendStr := Options.XLegends[I - 1]\r\n else\r\n XLegendStr := IntToStr(I);\r\n MyLeftTextOut(ACanvas, Options.XStartOffset + Options.XEnd + 7 + ACanvas.TextWidth('12'),\r\n Options.YStartOffset + I * nTextHeight + 7,\r\n XLegendStr);\r\n end;\r\n end;\r\nend;\r\n\r\n// Used in line charting as a Marker kind:\r\n\r\nprocedure TJvChart.PlotSquare(ACanvas: TCanvas; X, Y: Integer);\r\nbegin\r\n MyPolygon(ACanvas, [Point(X - Options.MarkerSize, Y - Options.MarkerSize),\r\n Point(X + Options.MarkerSize, Y - Options.MarkerSize),\r\n Point(X + Options.MarkerSize, Y + Options.MarkerSize),\r\n Point(X - Options.MarkerSize, Y + Options.MarkerSize)]);\r\nend;\r\n\r\n// Used in line charting as a Marker kind:\r\n\r\nprocedure TJvChart.PlotDiamond(ACanvas: TCanvas; X, Y: Integer);\r\nbegin\r\n MyPolygon(ACanvas, [Point(X, Y - Options.MarkerSize),\r\n Point(X + Options.MarkerSize, Y),\r\n Point(X, Y + Options.MarkerSize),\r\n Point(X - Options.MarkerSize, Y)]);\r\nend;\r\n\r\nprocedure TJvChart.PlotFilledDiamond(ACanvas: TCanvas; X, Y: Integer);\r\nbegin\r\n with ACanvas.Brush do\r\n begin\r\n Style := bsSolid;\r\n Color := ACanvas.Pen.Color;\r\n PlotDiamond(ACanvas, X, Y);\r\n Style := bsClear;\r\n end;\r\nend;\r\n\r\n// Used in line charting as a Marker kind:\r\n\r\nprocedure TJvChart.PlotCircle(ACanvas: TCanvas; X, Y: Integer);\r\nbegin\r\n ACanvas.Pen.Style := psSolid;\r\n ACanvas.Ellipse(X - Options.MarkerSize,\r\n Y - Options.MarkerSize,\r\n X + Options.MarkerSize,\r\n Y + Options.MarkerSize); // Marker Circle radius 3.\r\nend;\r\n\r\n// Used in line charting as a Marker kind:\r\n\r\nprocedure TJvChart.PlotCross(ACanvas: TCanvas; X, Y: Integer);\r\nbegin\r\n MyDrawLine(ACanvas, X - Options.MarkerSize, Y, X + Options.MarkerSize, Y);\r\n MyDrawLine(ACanvas, X, Y - Options.MarkerSize, X, Y + Options.MarkerSize);\r\nend;\r\n\r\nprocedure TJvChart.ClearScreen;\r\nvar\r\n ACanvas: TCanvas;\r\nbegin\r\n ACanvas := GetChartCanvas(false);\r\n {Clear screen}\r\n SetLineColor(ACanvas, jvChartPaperColorIndex);\r\n // Fishy:\r\n MyColorRectangle(ACanvas, jvChartPaperColorIndex, 0, 0,\r\n // XXX The point here is to exceed the edges, wipe it all, thus the 3* and 5* multipliers.\r\n 3 * Options.XStartOffset + Options.XEnd + Options.LegendWidth,\r\n 5 * Options.YStartOffset + Options.YEnd);\r\n SetRectangleColor(ACanvas, jvChartAxisColorIndex);\r\n SetLineColor(ACanvas, jvChartAxisColorIndex);\r\nend;\r\n\r\n{NEW chart type!!!}\r\n\r\nprocedure TJvChart.GraphDeltaAverage;\r\nvar\r\n XPixelGap: Longint;\r\n YPixelGap: Longint;\r\n XOrigin: Longint;\r\n YOrigin: Longint;\r\n I, J: Longint;\r\n TempYOrigin: Longint;\r\n ACanvas: TCanvas;\r\nbegin\r\n ACanvas := GetChartCanvas(false);\r\n Assert(Assigned(ACanvas));\r\n Assert(Assigned(ACanvas.Brush));\r\n\r\n {new type of chart...}\r\n ClearScreen;\r\n\r\n {Check graph values and correct if wrong. Actually not needed if there are no bugs}\r\n// if (Options.PrimaryYAxis.YDivisions>MAX_Y_LEGENDS) then\r\n// Options.PrimaryYAxis.YDivisions := MAX_Y_LEGENDS;\r\n if Options.PrimaryYAxis.YDivisions = 0 then\r\n Options.PrimaryYAxis.YDivisions := 1;\r\n if Options.XValueCount > MAX_VALUES then\r\n Options.XValueCount := MAX_VALUES;\r\n if Options.XValueCount = 0 then\r\n Options.XValueCount := 1;\r\n if Options.PenCount > MAX_PEN then\r\n Options.PenCount := MAX_PEN;\r\n // if Options.PrimaryYAxis.YGap = 0 then\r\n // Options.PrimaryYAxis.YGap := 1;\r\n\r\n XPixelGap := Round((Options.YEnd - Options.YStartOffset) /\r\n (Options.XValueCount));\r\n YPixelGap := Round((Options.XEnd - Options.XStartOffset) /\r\n (Options.PrimaryYAxis.YDivisions + 1)); // SPECIALIZED.\r\n\r\n TempYOrigin := Options.YOrigin;\r\n Options.YOrigin := Options.PrimaryYAxis.YDivisions div 2;\r\n\r\n YOrigin := Options.XStartOffset + (YPixelGap * Options.YOrigin);\r\n XOrigin := Options.YStartOffset;\r\n\r\n {Create texts for Y-axis}\r\n// Options.PrimaryYAxis.YLegends.Clear;\r\n// for I := 0 to MAX_Y_LEGENDS-1 do\r\n // Options.PrimaryYAxis.YLegends.Add( IntToStr(Round(((I-1)-Options.YOrigin)*Options.PrimaryYAxis.YGap)) );\r\n\r\n {Y-axis legends and lines...}\r\n MyAxisFont(ACanvas);\r\n for I := 1 to Options.PrimaryYAxis.YDivisions + 1 do\r\n begin\r\n if I >= Options.PrimaryYAxis.YLegends.Count then\r\n Exit;\r\n MyLeftTextOut(ACanvas, YOrigin + (YPixelGap * ((I - 1) - Options.YOrigin)),\r\n XOrigin + XPixelGap * Options.XValueCount + 2,\r\n Options.PrimaryYAxis.YLegends[I]);\r\n MyDrawDotLine(ACanvas, YOrigin - (YPixelGap * ((I - 1) - Options.YOrigin)),\r\n XOrigin,\r\n YOrigin - (YPixelGap * ((I - 1) - Options.YOrigin)),\r\n XOrigin + (XPixelGap * (Options.XValueCount)));\r\n end;\r\n\r\n {Draw Y-axis}\r\n ACanvas.MoveTo(Options.XStartOffset, XOrigin);\r\n MyAxisLineTo(ACanvas, Options.XEnd, XOrigin);\r\n {Draw second Y-axis}\r\n ACanvas.MoveTo(Options.XStartOffset, XOrigin + XPixelGap * Options.XValueCount + 1);\r\n MyAxisLineTo(ACanvas, Options.XEnd, XOrigin + XPixelGap * Options.XValueCount + 1);\r\n {Draw X-axis}\r\n ACanvas.MoveTo(YOrigin, XOrigin);\r\n MyAxisLineTo(ACanvas, YOrigin, XOrigin + XPixelGap * Options.XValueCount + 1);\r\n\r\n {X-axis legends...}\r\n GraphXAxisLegend;\r\n\r\n {Main Header}\r\n MyHeader(ACanvas, Options.Title);\r\n\r\n {X axis header}\r\n MyXHeader(ACanvas, Options.XAxisHeader);\r\n\r\n // Now draw the delta average...\r\n for I := 0 to Options.PenCount - 1 do\r\n for J := 0 to Options.XValueCount - 1 do\r\n if Options.PenCount = 1 then\r\n MyColorRectangle(ACanvas, I,\r\n YOrigin,\r\n XOrigin + J * XPixelGap + (I) * Round(XPixelGap / (Options.PenCount + 0.1)) - XPixelGap,\r\n YOrigin + Round(((FData.Value[I, J] - Options.AverageValue[J]) /\r\n Options.PrimaryYAxis.YGap) * YPixelGap),\r\n XOrigin + J * XPixelGap + (I + 1) * Round(XPixelGap / (Options.PenCount + 0.1)) - XPixelGap)\r\n else\r\n MyColorRectangle(ACanvas, I,\r\n YOrigin,\r\n XOrigin + J * XPixelGap + (I) * Round(XPixelGap / (Options.PenCount + 0.5)) - XPixelGap,\r\n YOrigin + Round(((FData.Value[I, J] - Options.AverageValue[J]) /\r\n Options.PrimaryYAxis.YGap) * YPixelGap),\r\n XOrigin + J * XPixelGap + (I + 1) * Round(XPixelGap / (Options.PenCount + 0.5)) - XPixelGap);\r\n Options.YOrigin := TempYOrigin;\r\nend;\r\n\r\n{****************************************************************************}\r\n{ Device dependent functions for the rest of this module...check for printer }\r\n{ or check for metafile output! }\r\n{****************************************************************************}\r\n\r\n\r\n{ !!warning: uses Win32 only font-handle stuff!!}\r\nprocedure TJvChart.MakeVerticalFont;\r\nbegin\r\n if Ord(FYFontHandle) <> 0 then\r\n DeleteObject(FYFontHandle); // delete old object\r\n // Clear the contents of FLogFont\r\n FillChar(FYLogFont, SizeOf(TLogFont), 0);\r\n // Set the TLOGFONT's fields - Win32 Logical Font Details.\r\n with FYLogFont do\r\n begin\r\n lfHeight := Abs(Font.Height) + 2;\r\n lfWidth := 0; //Font.Width;\r\n lfEscapement := 900; // 90 degree vertical rotation\r\n lfOrientation := 900; // not used.\r\n lfWeight := FW_BOLD; //FW_HEAVY; // bold, etc\r\n lfItalic := 1; // no\r\n lfUnderline := 0; // no\r\n lfStrikeOut := 0; // no\r\n lfCharSet := ANSI_CHARSET; // or DEFAULT_CHARSET\r\n lfOutPrecision := OUT_TT_ONLY_PRECIS; //Require TrueType!\r\n // OUT_DEFAULT_PRECIS;\r\n // OUT_STRING_PRECIS, OUT_CHARACTER_PRECIS, OUT_STROKE_PRECIS,\r\n // OUT_TT_PRECIS, OUT_DEVICE_PRECIS, OUT_RASTER_PRECIS,\r\n // OUT_TT_ONLY_PRECIS\r\n\r\n lfClipPrecision := CLIP_DEFAULT_PRECIS;\r\n lfQuality := DEFAULT_QUALITY;\r\n lfPitchAndFamily := DEFAULT_PITCH or FF_DONTCARE;\r\n StrPCopy(lfFaceName, Font.Name);\r\n end;\r\n\r\n // Retrieve the requested font\r\n FYFontHandle := CreateFontIndirect(FYLogFont);\r\n Assert(Ord(FYFontHandle) <> 0);\r\n // Assign to the Font.Handle\r\n //Font.Handle := FYFont; // XXX DEBUG\r\n //pbxFont.Refresh;\r\n FYFont := TFont.Create;\r\n FYFont.Assign(Font);\r\n FYFont.Color := Options.AxisFont.Color;\r\n FYFont.Handle := FYFontHandle;\r\nend;\r\n\r\n\r\nprocedure TJvChart.MyHeader(ACanvas: TCanvas; StrText: string);\r\nbegin\r\n Assert(Assigned(ACanvas));\r\n Assert(Assigned(ACanvas.Brush));\r\n\r\n MyHeaderFont(ACanvas);\r\n MyCenterTextOut(ACanvas, Options.XStartOffset + Round(Options.XEnd / 2),\r\n (Options.YStartOffset div 2) - (MyTextHeight(ACanvas, StrText) div 2),\r\n StrText);\r\n MyAxisFont(ACanvas);\r\nend;\r\n\r\nprocedure TJvChart.MySmallGraphFont(ACanvas: TCanvas);\r\nbegin\r\n ACanvas.Brush.Color := Options.PaperColor; // was hard coded to clWhite.\r\n ACanvas.Font.Assign(Options.LegendFont);\r\nend;\r\n\r\nprocedure TJvChart.MyAxisFont(ACanvas: TCanvas);\r\nbegin\r\n Assert(Assigned(ACanvas));\r\n Assert(Assigned(ACanvas.Brush));\r\n Assert(Assigned(ACanvas.Font));\r\n Assert(Assigned(Options));\r\n ACanvas.Brush.Color := Options.PaperColor; // was hard coded to clWhite.\r\n ACanvas.Font.Assign(Options.AxisFont);\r\nend;\r\n\r\n\r\n{ !!warning: uses Win32 only font-handle stuff!!}\r\nprocedure TJvChart.MyGraphVertFont(ACanvas: TCanvas);\r\nbegin\r\n Assert(Assigned(ACanvas));\r\n Assert(Assigned(ACanvas.Brush));\r\n\r\n if Ord(FYFontHandle) = 0 then\r\n MakeVerticalFont;\r\n ACanvas.Font.Assign(FYFont); //Handle := FYFontHnd;\r\n if not PrintInSession then\r\n Assert(ACanvas.Font.Handle = FYFontHandle);\r\nend;\r\n\r\n\r\nprocedure TJvChart.MyHeaderFont(ACanvas: TCanvas);\r\nbegin\r\n Assert(Assigned(ACanvas));\r\n Assert(Assigned(ACanvas.Brush));\r\n Assert(Assigned(Options));\r\n ACanvas.Brush.Color := Options.PaperColor; //was clWhite;\r\n ACanvas.Font.Assign(Options.HeaderFont);\r\nend;\r\n\r\nprocedure TJvChart.MyPenLineTo(ACanvas: TCanvas; X, Y: Integer);\r\nbegin\r\n ACanvas.Pen.Width := Options.PenLineWidth;\r\n ACanvas.LineTo(X, Y);\r\n ACanvas.Pen.Width := 1;\r\nend;\r\n\r\nprocedure TJvChart.MyAxisLineTo(ACanvas: TCanvas; X, Y: Integer);\r\nbegin\r\n ACanvas.Pen.Width := Options.AxisLineWidth;\r\n ACanvas.LineTo(X, Y);\r\n ACanvas.Pen.Width := 1;\r\nend;\r\n\r\nfunction TJvChart.MyTextHeight(ACanvas: TCanvas; StrText: string): Longint;\r\nbegin\r\n Result := ACanvas.TextHeight(StrText);\r\nend;\r\n\r\n{ Text Left Aligned to X,Y boundary }\r\n\r\nprocedure TJvChart.MyLeftTextOut(ACanvas: TCanvas; X, Y: Integer; const Text: string);\r\nbegin\r\n Assert(Assigned(ACanvas));\r\n Assert(Assigned(ACanvas.Brush));\r\n ACanvas.Brush.Color := Options.PaperColor; // non default paper color.\r\n ACanvas.TextOut(X, Y + 1, Text);\r\nend;\r\n\r\nprocedure TJvChart.MyLeftTextOutHint(ACanvas: TCanvas; X, Y: Integer; const Text: string);\r\nbegin\r\n Assert(Assigned(ACanvas));\r\n Assert(Assigned(ACanvas.Brush));\r\n ACanvas.Brush.Color := Options.HintColor;\r\n ACanvas.TextOut(X, Y + 1, Text);\r\nend;\r\n\r\nprocedure TJvChart.MyCenterTextOut(ACanvas: TCanvas; X, Y: Integer; const Text: string);\r\nbegin\r\n Assert(Assigned(ACanvas));\r\n Assert(Assigned(ACanvas.Brush));\r\n ACanvas.Brush.Color := Options.PaperColor; // non default paper color.\r\n ACanvas.TextOut(X - Round(ACanvas.TextWidth(Text) / 2), Y + 1, Text);\r\nend;\r\n\r\nprocedure TJvChart.MyRightTextOut(ACanvas: TCanvas; X, Y: Integer; const Text: string);\r\nbegin\r\n Assert(Assigned(ACanvas));\r\n Assert(Assigned(ACanvas.Brush));\r\n ACanvas.Brush.Color := Options.PaperColor; // non default paper color.\r\n ACanvas.TextOut(X - ACanvas.TextWidth(Text),\r\n Y - Round(ACanvas.TextHeight(Text) / 2), Text);\r\nend;\r\n\r\nprocedure TJvChart.MyRectangle(ACanvas: TCanvas; X, Y, X2, Y2: Integer);\r\nbegin\r\n Assert(Assigned(ACanvas));\r\n Assert(Assigned(ACanvas.Brush));\r\n ACanvas.Rectangle(X, Y, X2, Y2);\r\nend;\r\n\r\n(*Procedure TJvChart.MyShadowRectangle(Pen : Integer; X, Y, X2, Y2: Integer);\r\nbegin\r\n SetRectangleColor(Shadow);\r\n ACanvas.Rectangle(X, Y, X2, Y2);\r\nend;*)\r\n\r\nprocedure TJvChart.MyColorRectangle(ACanvas: TCanvas; Pen: Integer; X, Y, X2, Y2: Integer);\r\nbegin\r\n Assert(Assigned(ACanvas));\r\n Assert(Assigned(ACanvas.Brush));\r\n SetRectangleColor(ACanvas, Pen);\r\n //OutputDebugString(PChar('MyColorRectangle X='+IntToStr(X)+' Y='+IntToStr(Y)+ ' X2='+IntToStr(X2)+ ' Y2='+IntToStr(Y2) ));\r\n ACanvas.Rectangle(X, Y, X2, Y2);\r\nend;\r\n\r\nprocedure TJvChart.MyPie(ACanvas: TCanvas; X1, Y1, X2, Y2, X3, Y3, X4, Y4: Longint);\r\nbegin\r\n Assert(Assigned(ACanvas));\r\n Assert(Assigned(ACanvas.Brush));\r\n ACanvas.Pie(X1, Y1, X2, Y2, X3, Y3, X4, Y4);\r\nend;\r\n\r\n{Procedure TJvChart.MyArc(X1, Y1, X2, Y2, X3, Y3, X4, Y4: Integer);\r\nbegin\r\n ACanvas.Arc(X1, Y1, X2, Y2, X3, Y3, X4, Y4);\r\nend;}// not used (ahuser)\r\n\r\nprocedure TJvChart.MyPolygon(ACanvas: TCanvas; Points: array of TPoint);\r\nbegin\r\n Assert(Assigned(ACanvas));\r\n Assert(Assigned(ACanvas.Brush));\r\n ACanvas.Polygon(Points);\r\nend;\r\n\r\n{Procedure TJvChart.MyEllipse(X1, Y1, X2, Y2: Integer);\r\nbegin\r\n ACanvas.Ellipse(X1, Y1, X2, Y2);\r\nend;}\r\n\r\nprocedure TJvChart.MyDrawLine(ACanvas: TCanvas; X1, Y1, X2, Y2: Integer);\r\nbegin\r\n Assert(Assigned(ACanvas));\r\n Assert(Assigned(ACanvas.Brush));\r\n ACanvas.MoveTo(X1, Y1);\r\n ACanvas.LineTo(X2, Y2);\r\nend;\r\n\r\nprocedure TJvChart.MyDrawAxisMark(ACanvas: TCanvas; X1, Y1, X2, Y2: Integer);\r\nbegin\r\n Assert(Assigned(ACanvas));\r\n Assert(Assigned(ACanvas.Brush));\r\n SetSolidLines(ACanvas);\r\n ACanvas.Pen.Width := 1; // always width 1\r\n ACanvas.MoveTo(X1, Y1);\r\n ACanvas.LineTo(X2, Y2);\r\nend;\r\n\r\nprocedure TJvChart.MyDrawDotLine(ACanvas: TCanvas; X1, Y1, X2, Y2: Integer);\r\nbegin\r\n Assert(Assigned(ACanvas));\r\n Assert(Assigned(ACanvas.Brush));\r\n SetDotLines(ACanvas);\r\n ACanvas.MoveTo(X1, Y1);\r\n ACanvas.LineTo(X2, Y2);\r\n SetSolidLines(ACanvas);\r\nend;\r\n\r\n{ (rom) not used\r\nfunction TJvChart.GetDefaultColorString(nIndex: Integer): string;\r\nbegin\r\n if nIndex <= 10 then\r\n case nIndex of\r\n -2:\r\n Result := 'clWhite'; // MouseDownBox\r\n -1:\r\n Result := 'clWhite';\r\n 0:\r\n Result := 'clBlack';\r\n 1:\r\n Result := 'clLime';\r\n 2:\r\n Result := 'clBlue';\r\n 3:\r\n Result := 'clRed';\r\n 4:\r\n Result := 'clGreen';\r\n 5:\r\n Result := 'clMaroon';\r\n 6:\r\n Result := 'clOlive';\r\n 7:\r\n Result := 'clSilver';\r\n 8:\r\n Result := 'clTeal';\r\n 9:\r\n Result := 'clBlack';\r\n 10:\r\n Result := 'clAqua';\r\n end\r\n else\r\n Result := '$00888888';\r\nend;\r\n}\r\n\r\nprocedure TJvChart.SetFontColor(ACanvas: TCanvas; Pen: Integer);\r\nbegin\r\n Assert(Assigned(ACanvas));\r\n Assert(Assigned(ACanvas.Brush));\r\n ACanvas.Font.Color := Options.PenColor[Pen];\r\nend;\r\n\r\nprocedure TJvChart.SetRectangleColor(ACanvas: TCanvas; Pen: Integer);\r\nbegin\r\n Assert(Assigned(ACanvas));\r\n Assert(Assigned(ACanvas.Brush));\r\n ACanvas.Brush.Color := Options.PenColor[Pen];\r\nend;\r\n\r\nprocedure TJvChart.SetLineColor(ACanvas: TCanvas; Pen: Integer);\r\nbegin\r\n Assert(Assigned(ACanvas));\r\n Assert(Assigned(ACanvas.Brush));\r\n Assert(Assigned(ACanvas.Pen));\r\n ACanvas.Pen.Color := Options.PenColor[Pen];\r\nend;\r\n\r\nprocedure TJvChart.SetDotLines(ACanvas: TCanvas);\r\nbegin\r\n Assert(Assigned(ACanvas));\r\n Assert(Assigned(ACanvas.Brush));\r\n Assert(Assigned(ACanvas.Pen));\r\n ACanvas.Pen.Style := psDot;\r\nend;\r\n\r\nprocedure TJvChart.SetSolidLines(ACanvas: TCanvas);\r\nbegin\r\n Assert(Assigned(ACanvas));\r\n Assert(Assigned(ACanvas.Brush));\r\n Assert(Assigned(ACanvas.Pen));\r\n ACanvas.Pen.Style := psSolid;\r\nend;\r\n\r\nprocedure TJvChart.GraphToClipboard;\r\nbegin\r\n {This works with bitmaps at least...how to do it as a metafile?}\r\n Clipboard.Assign(FPicture);\r\nend;\r\n\r\n{ PivotData: Pivot Data in Table. Formerly ChangeXValuesWithPen }\r\n\r\nprocedure TJvChart.PivotData;\r\nvar\r\n I, J: Integer;\r\n PenCount, XValueCount: Integer;\r\n TempData: TJvChartData;\r\n TempStrings: TStringList;\r\nbegin\r\n TempData := TJvChartData.Create;\r\n PenCount := Options.PenCount;\r\n XValueCount := Options.XValueCount;\r\n try\r\n { Move data to temp }\r\n for I := 0 to PenCount - 1 do\r\n for J := 0 to XValueCount - 1 do\r\n TempData.Value[I, J] := FData.Value[I, J];\r\n FData.Clear;\r\n { copy back, pivot X/Y axis }\r\n for I := 0 to PenCount - 1 do\r\n for J := 0 to XValueCount - 1 do\r\n TempData.Value[I, J] := FData.Value[J, I];\r\n\r\n {swap labels}\r\n TempStrings := Options.FXLegends;\r\n Options.FXLegends := Options.FPenLegends;\r\n Options.FPenLegends := TempStrings;\r\n\r\n Options.XValueCount := PenCount;\r\n Options.PenCount := XValueCount;\r\n\r\n {recalc average}\r\n CountGraphAverage;\r\n InternalPlotGraph;\r\n Invalidate;\r\n finally\r\n TempData.Free;\r\n end;\r\nend;\r\n\r\n{FLOATING MARKERS: new Jan 2005 by WP }\r\n\r\nprocedure TJvChart.DrawFloatingMarkers; { called from TJvChart.Paint! }\r\nvar\r\n Marker, Marker2: TJvChartFloatingMarker;\r\n LineXPixelGap: Double;\r\n CaptionYPosition, TextWidth, TextHeight, VC, I: Integer;\r\n ACanvas: TCanvas;\r\nbegin\r\n if csDesigning in ComponentState then\r\n Exit;\r\n if FFloatingMarker.Count = 0 then\r\n Exit;\r\n ACanvas := Self.GetChartCanvas({isFloating}true);\r\n\r\n VC := Options.XValueCount;\r\n if (VC < 2) then\r\n VC := 2;\r\n LineXPixelGap := ((Options.XEnd - 2) - Options.XStartOffset) / (VC - 1);\r\n\r\n {-- First loop through all and update their Raw X and Y Positions --}\r\n for I := 0 to FFloatingMarker.Count - 1 do\r\n begin\r\n Marker := GetFloatingMarker(I);\r\n if not Marker.Visible then\r\n Continue;\r\n if (Marker.XPosition < 0) or (Marker.XPosition >= VC) then\r\n Continue; // out of visible X range.\r\n\r\n // if following a pen, get the updated pen value:\r\n //if Marker.YPositionToPen>=0 then begin\r\n // Marker.YPosition := Self.Data.Value[Marker.YPositionToPen, Marker.XPosition];\r\n //end;\r\n\r\n // find Raw X,Y co-ordinates:\r\n if not Marker.FDragging then\r\n begin\r\n with FOptions.PrimaryYAxis do\r\n Marker.FRawYPosition := Trunc((YOrigin - (((Marker.YPosition - YMin) / YGap) * YPixelGap)));\r\n Marker.FRawXPosition := Round(XOrigin + Marker.XPosition * LineXPixelGap);\r\n end;\r\n end;\r\n\r\n {-- Now draw any connecting lines or vertical lines --}\r\n for I := 0 to FFloatingMarker.Count - 1 do\r\n begin\r\n Marker := GetFloatingMarker(I);\r\n if not Marker.Visible then\r\n Continue;\r\n if (Marker.XPosition < 0) or (Marker.XPosition >= VC) then\r\n Continue; // out of visible X range.\r\n\r\n // Draw connecting (rubberband) line:\r\n if (Marker.LineToMarker >= 0) and (Marker.FLineStyle <> psClear) then\r\n begin\r\n Marker2 := GetFloatingMarker(Marker.LineToMarker);\r\n ACanvas.Pen.Style := Marker.FLineStyle;\r\n ACanvas.Pen.Color := Marker.FLineColor;\r\n ACanvas.Pen.Width := Marker.FLineWidth;\r\n ACanvas.MoveTo(Marker.FRawXPosition, Marker.FRawYPosition);\r\n ACanvas.LineTo(Marker2.FRawXPosition, Marker2.FRawYPosition);\r\n end\r\n else\r\n if Marker.FLineVertical then\r\n begin\r\n // Vertical line along X position:\r\n ACanvas.Pen.Style := Marker.FLineStyle;\r\n ACanvas.Pen.Color := Marker.FLineColor;\r\n ACanvas.Pen.Width := Marker.FLineWidth;\r\n ACanvas.MoveTo(Marker.FRawXPosition, Options.YStartOffset);\r\n ACanvas.LineTo(Marker.FRawXPosition, FXAxisPosition - 1);\r\n end;\r\n end;\r\n\r\n {-- Now draw the markers themselves, we draw them LAST so they are ON TOP. --}\r\n MySmallGraphFont(ACanvas);\r\n for I := 0 to FFloatingMarker.Count - 1 do\r\n begin\r\n Marker := GetFloatingMarker(I);\r\n if not Marker.Visible then\r\n Continue;\r\n if (Marker.XPosition < 0) or (Marker.XPosition >= VC) then\r\n Continue; // out of visible X range.\r\n if Marker.Marker <> pmkNone then\r\n begin\r\n // Draw Marker:\r\n ACanvas.Pen.Color := Marker.FMarkerColor;\r\n PlotMarker(ACanvas, Marker.Marker, Marker.FRawXPosition, Marker.FRawYPosition);\r\n end;\r\n\r\n if Marker.Caption <> '' then\r\n begin\r\n TextHeight := ACanvas.TextHeight(Marker.Caption);\r\n\r\n CaptionYPosition := 0; // not used.\r\n case Marker.CaptionPosition of\r\n cpMarker:\r\n CaptionYPosition := Marker.FRawYPosition - Round(TextHeight * 1.4);\r\n cpXAxisBottom:\r\n CaptionYPosition := Options.YStartOffset + Options.YEnd + Round(TextHeight * 1.4);\r\n cpXAxisTop:\r\n CaptionYPosition := Trunc(XOrigin - Round(TextHeight * 1.4));\r\n cpTitleArea:\r\n CaptionYPosition := (Options.YStartOffset div 2) - (TextHeight div 2);\r\n end;\r\n\r\n if Marker.CaptionBoxed then\r\n begin\r\n TextWidth := ACanvas.TextWidth(Marker.Caption) + 10;\r\n\r\n ACanvas.Pen.Color := Marker.LineColor;\r\n ACanvas.Pen.Width := 1;\r\n ACanvas.Pen.Style := Marker.LineStyle;\r\n MyRectangle(ACanvas,\r\n Marker.FRawXPosition - TextWidth div 2,\r\n CaptionYPosition,\r\n Marker.FRawXPosition + TextWidth div 2,\r\n CaptionYPosition + TextHeight + TextHeight div 4);\r\n ACanvas.Pen.Style := psSolid;\r\n //MySmallGraphFont(ACanvas); <-redundant.\r\n //MyCenterTextOut(ACanvas, Marker.FRawXPosition, Options.FYStartOffset + Round(TextHeight / 4),\r\n // Marker.Caption);\r\n end;\r\n\r\n MyCenterTextOut(ACanvas, Marker.FRawXPosition, CaptionYPosition, Marker.Caption);\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJvChart.AddFloatingMarker: TJvChartFloatingMarker;\r\nbegin\r\n Assert(Assigned(FFloatingMarker));\r\n Result := TJvChartFloatingMarker.Create(Self);\r\n Result.FIndex := FFloatingMarker.Count;\r\n FFloatingMarker.Add(Result);\r\nend;\r\n\r\nprocedure TJvChart.DeleteFloatingMarker(Index: Integer);\r\nvar\r\n I: Integer;\r\nbegin\r\n Assert(Assigned(FFloatingMarker));\r\n if Assigned(FDragFloatingMarker) then\r\n FDragFloatingMarker := nil;\r\n\r\n FFloatingMarker.Delete(Index);\r\n for I := Index to FFloatingMarker.Count - 1 do\r\n with GetFloatingMarker(I) do\r\n begin\r\n FIndex := I; // update index.\r\n if LineToMarker = Index then\r\n LineToMarker := -1 // Disconnected now.\r\n else\r\n if LineToMarker > Index then\r\n LineToMarker := LineToMarker - 1; // Index changed.\r\n end;\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvChart.DeleteFloatingMarkerObj(Marker: TJvChartFloatingMarker); // NEW 2007\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := 0 to FFloatingMarker.Count - 1 do\r\n begin\r\n if TJvChartFloatingMarker(FFloatingMarker[I]) = Marker then\r\n begin\r\n DeletefloatingMarker(I);\r\n Exit;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvChart.CopyFloatingMarkers(Source: TJvChart);\r\nvar\r\n I: Integer;\r\n NewMarker: TJvChartFloatingMarker;\r\nbegin\r\n ClearFloatingMarkers;\r\n for I := 0 to Source.FloatingMarkerCount - 1 do\r\n begin\r\n NewMarker := Self.AddFloatingMarker;\r\n NewMarker.Assign(Source.GetFloatingMarker(I));\r\n end;\r\n Invalidate; // repaint!\r\nend;\r\n\r\nprocedure TJvChart.ClearFloatingMarkers;\r\nbegin\r\n if Assigned(FDragFloatingMarker) then\r\n FDragFloatingMarker := nil;\r\n FFloatingMarker.Clear;\r\nend;\r\n\r\nfunction TJvChart.GetFloatingMarker(Index: Integer): TJvChartFloatingMarker;\r\nbegin\r\n Assert(Assigned(FFloatingMarker));\r\n Result := TJvChartFloatingMarker(FFloatingMarker[Index]);\r\nend;\r\n\r\nfunction TJvChart.GetHorizontalBar(index: integer): TJvChartHorizontalBar;\r\nbegin\r\n // new 2009\r\n Assert(Assigned(FHorizontalBars));\r\n Result := TJvChartHorizontalBar(FHorizontalBars[Index]);\r\n\r\nend;\r\n\r\nfunction TJvChart.GetVerticalBar(index: integer): TJvChartVerticalBar;\r\nbegin\r\n// new 2009\r\n Assert(Assigned(FVerticalBars));\r\n Result := TJvChartVerticalBar(FVerticalBars[Index]);\r\nend;\r\n\r\nfunction TJvChart.FloatingMarkerCount: Integer;\r\nbegin\r\n Assert(Assigned(FFloatingMarker));\r\n Result := FFloatingMarker.Count;\r\nend;\r\n\r\n// NEW HORIZONTAL BAR AND VERTICAL BAR AND GRADIENT PAINTING METHODS (2007) - W.Postma.\r\n\r\nprocedure TJvChart.DrawGradient; // new 2007\r\nvar\r\n ACanvas: TCanvas;\r\n RawRect: TRect;\r\n VC: Integer;\r\nbegin\r\n if csDesigning in ComponentState then\r\n Exit;\r\n if (Options.FGradientDirection = grNone) or (Options.PaperColor = Options.FGradientColor) then\r\n Exit;\r\n ACanvas := GetChartCanvas(false);\r\n VC := Options.XValueCount;\r\n if VC < 1 then\r\n VC := 1;\r\n RawRect.Top := FOptions.YStartOffset;\r\n RawRect.Bottom := Trunc(YOrigin);\r\n RawRect.Left := Round(XOrigin);\r\n RawRect.Right := Round(Options.XStartOffset + Options.XPixelGap * VC) - 1;\r\n case Options.FGradientDirection of\r\n //grNone:\r\n // ;\r\n grUp:\r\n GradVertical(ACanvas, RawRect, Options.FGradientColor, Options.PaperColor);\r\n grDown:\r\n GradVertical(ACanvas, RawRect, Options.PaperColor, Options.FGradientColor);\r\n grLeft:\r\n GradHorizontal(ACanvas, RawRect, Options.PaperColor, Options.FGradientColor);\r\n grRight:\r\n GradHorizontal(ACanvas, RawRect, Options.FGradientColor, Options.PaperColor);\r\n end;\r\nend;\r\n\r\n{ Gradient bars - indicators on background of various vertical subranges }\r\n\r\nprocedure TJvChart.DrawHorizontalBars; // new 2007\r\nvar\r\n HB: TJvChartHorizontalBar;\r\n J: Integer;\r\n ACanvas: TCanvas;\r\n VC: Integer;\r\n RawRect: TRect;\r\n procedure CalcRawRect; // new april 2009\r\nbegin\r\n with FOptions.PrimaryYAxis do\r\n if (YGap <> 0) then\r\n begin\r\n if IsNaN(HB.FYTop) then\r\n RawRect.Top := FOptions.YStartOffset\r\n else\r\n begin\r\n RawRect.Top := Trunc((YOrigin - (((HB.FYTop - YMin) / YGap) * YPixelGap)));\r\n if RawRect.Top < 0 then\r\n RawRect.Top := FOptions.YStartOffset;\r\n end;\r\n\r\n if IsNaN(HB.FYBottom) then\r\n RawRect.Bottom := Trunc(YOrigin)\r\n else\r\n begin\r\n RawRect.Bottom := Trunc((YOrigin - (((HB.FYBottom - YMin) / YGap) * YPixelGap)));\r\n if (RawRect.Bottom < 0) or (RawRect.Bottom > YOrigin) then\r\n RawRect.Bottom := Trunc(YOrigin);\r\n end;\r\n\r\n RawRect.Left := Round(XOrigin);\r\n RawRect.Right := Round(Options.XStartOffset + Options.XPixelGap * VC) - 1;\r\n end;\r\n end;\r\nbegin\r\n if csDesigning in ComponentState then\r\n Exit;\r\n if FHorizontalBars.Count = 0 then\r\n Exit;\r\n ACanvas := GetChartCanvas(false);\r\n VC := Options.XValueCount;\r\n if VC < 1 then\r\n VC := 1;\r\n\r\n for J := 0 to FHorizontalBars.Count - 1 do\r\n begin\r\n HB := TJvChartHorizontalBar(FHorizontalBars[J]);\r\n if not HB.FVisible then\r\n Continue;\r\n\r\n CalcRawRect;\r\n\r\n ACanvas.Brush.Color := HB.FColor;\r\n ACanvas.Brush.Style := bsSolid;\r\n ACanvas.FillRect(RawRect);\r\n if HB.FColor <> HB.FGradColor then\r\n case HB.FGradDirection of\r\n //grNone:\r\n // ;\r\n grUp:\r\n GradVertical(ACanvas, RawRect, HB.FGradColor, HB.FColor);\r\n grDown:\r\n GradVertical(ACanvas, RawRect, HB.FColor, HB.FGradColor);\r\n end;\r\n end;\r\n\r\n {now draw outlines }\r\n // new april 2009\r\n for J := 0 to FHorizontalBars.Count - 1 do\r\n begin\r\n HB := TJvChartHorizontalBar(FHorizontalBars[J]);\r\n if not HB.FVisible then\r\n Continue;\r\n if HB.PenStyle<>psClear then begin\r\n CalcRawRect;\r\n ACanvas.Brush.Style := bsClear;\r\n ACanvas.Pen.Style := HB.PenStyle;\r\n ACAnvas.Pen.Color := HB.PenColor;\r\n ACanvas.Rectangle(RawRect);\r\n end;\r\n end;\r\n\r\n\r\nend;\r\n\r\nprocedure TJvChart.DrawVerticalBars; // new 2007\r\nvar\r\n VB: TJvChartVerticalBar;\r\n J: Integer;\r\n ACanvas: TCanvas;\r\n VC: Integer;\r\n RawRect: TRect;\r\n procedure CalcRawRect;\r\n begin\r\n RawRect.Top := FOptions.YStartOffset;\r\n RawRect.Bottom := Trunc(YOrigin);\r\n RawRect.Left := Round(Options.XStartOffset + Options.XPixelGap * VB.FXLeft);\r\n if RawRect.Left <= 0 then\r\n RawRect.Left := Round(XOrigin);\r\n RawRect.Right := Round(Options.XStartOffset + Options.XPixelGap * VB.FXRight);\r\n VC := Round(Options.XStartOffset + Options.XPixelGap * Options.XValueCount);\r\n if RawRect.Right > VC then\r\n RawRect.Right := VC;\r\n end;\r\n\r\nbegin\r\n if csDesigning in ComponentState then\r\n Exit;\r\n if FVerticalBars.Count = 0 then\r\n Exit;\r\n ACanvas := GetChartCanvas(false);\r\n {VC :=Options.XValueCount;\r\n if VC<1 then VC:=1;}\r\n\r\n for J := 0 to FVerticalBars.Count - 1 do\r\n begin\r\n VB := TJvChartVerticalBar(FVerticalBars[J]);\r\n if not VB.FVisible then\r\n Continue;\r\n\r\n CalcRawRect;\r\n\r\n ACanvas.Brush.Color := VB.FColor;\r\n ACanvas.Brush.Style := bsSolid;\r\n ACanvas.FillRect(RawRect);\r\n if VB.FColor <> VB.FGradColor then\r\n case VB.FGradDirection of\r\n //grNone:\r\n // ;\r\n grUp:\r\n GradVertical(ACanvas, RawRect, VB.FGradColor, VB.FColor);\r\n grDown:\r\n GradVertical(ACanvas, RawRect, VB.FColor, VB.FGradColor);\r\n grLeft:\r\n GradHorizontal(ACanvas, RawRect, VB.FColor, VB.FGradColor);\r\n grRight:\r\n GradHorizontal(ACanvas, RawRect, VB.FGradColor, VB.FColor);\r\n end;\r\n end;\r\n\r\n\r\n {now draw outlines. these are done last so we can properly paint overlaps }\r\n // new april 2009\r\n for J := 0 to FVerticalBars.Count - 1 do\r\n begin\r\n VB := TJvChartVerticalBar(FVerticalBars[J]);\r\n if not VB.FVisible then\r\n Continue;\r\n if VB.PenStyle<>psClear then begin\r\n CalcRawRect;\r\n ACanvas.Brush.Style := bsClear;\r\n ACanvas.Pen.Style := VB.PenStyle;\r\n ACAnvas.Pen.Color := VB.PenColor;\r\n ACanvas.Rectangle(RawRect);\r\n end;\r\n end;\r\n\r\nend;\r\n\r\nfunction TJvChart.AddHorizontalBar: TJvChartHorizontalBar; // NEW 2007\r\nbegin\r\n Assert(Assigned(FHorizontalBars));\r\n Result := TJvChartHorizontalBar.Create(Self);\r\n Result.FIndex := FHorizontalBars.Count;\r\n FHorizontalBars.Add(Result);\r\nend;\r\n\r\nfunction TJvChart.AddVerticalBar: TJvChartVerticalBar; // NEW 2007\r\nbegin\r\n Assert(Assigned(FVerticalBars));\r\n Result := TJvChartVerticalBar.Create(Self);\r\n Result.FIndex := FVerticalBars.Count;\r\n FVerticalBars.Add(Result);\r\nend;\r\n\r\nprocedure TJvChart.ClearHorizontalBars; // NEW 2007\r\nbegin\r\n FHorizontalBars.Clear;\r\nend;\r\n\r\nprocedure TJvChart.ClearVerticalBars; // NEW 2007\r\nbegin\r\n FVerticalBars.Clear;\r\nend;\r\n\r\nfunction TJvChart.HorizontalBarsCount: Integer; // NEW 2007\r\nbegin\r\n Result := FHorizontalBars.Count;\r\nend;\r\n\r\nfunction TJvChart.VerticalBarsCount: Integer; // NEW 2007\r\nbegin\r\n Result := FVerticalBars.Count;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvCheckBox.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvCheckBox.PAS, released on 2001-02-28.\r\n\r\nThe Initial Developer of the Original Code is Sbastien Buysse [sbuysse att buypin dott com]\r\nPortions created by Sbastien Buysse are Copyright (C) 2001 Sbastien Buysse.\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\nMichael Beck [mbeck att bigfoot dott com].\r\nAin Valtin - ReadOnly, Alignment, Layout, RightButton\r\nRobert Marquardt RightButton renamed to LeftText\r\nPeter Thrnqvist- added LinkedControls property\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvCheckBox.pas 13327 2012-06-12 14:03:23Z obones $\r\n\r\nunit JvCheckBox;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, Messages, Classes, Graphics, Controls, StdCtrls,\r\n JvTypes, JvExStdCtrls, JvLinkedControls, JvDataSourceIntf;\r\n\r\nconst\r\n DefaultValueChecked = '1';\r\n DefaultValueUnchecked = '0';\r\n\r\ntype\r\n TJvCheckBox = class;\r\n\r\n TJvCheckBoxDataConnector = class(TJvFieldDataConnector)\r\n private\r\n FCheckBox: TJvCheckBox;\r\n FValueChecked: string;\r\n FValueUnchecked: string;\r\n procedure SetValueChecked(const Value: string);\r\n procedure SetValueUnchecked(const Value: string);\r\n function IsValueCheckedStored: Boolean;\r\n function IsValueUncheckedStored: Boolean;\r\n protected\r\n procedure UpdateData; override;\r\n procedure RecordChanged; override;\r\n public\r\n constructor Create(ACheckBox: TJvCheckBox);\r\n procedure Assign(Source: TPersistent); override;\r\n published\r\n property ValueChecked: string read FValueChecked write SetValueChecked stored IsValueCheckedStored;\r\n property ValueUnchecked: string read FValueUnchecked write SetValueUnchecked stored IsValueUncheckedStored;\r\n end;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvCheckBox = class(TJvExCheckBox)\r\n private\r\n FHotTrack: Boolean;\r\n FHotTrackFont: TFont;\r\n FFontSave: TFont;\r\n FHotTrackFontOptions: TJvTrackFontOptions;\r\n FAutoSize: Boolean;\r\n FCanvas: TControlCanvas;\r\n FWordWrap: Boolean;\r\n FAlignment: TAlignment;\r\n FLayout: TTextLayout;\r\n FLeftText: Boolean;\r\n FReadOnly:Boolean;\r\n FLinkedControls: TJvLinkedControls;\r\n FDataConnector: TJvCheckBoxDataConnector;\r\n FCheckingLinkedControls: Boolean;\r\n function GetCanvas: TCanvas;\r\n procedure SetHotTrackFont(const Value: TFont);\r\n procedure SetHotTrackFontOptions(const Value: TJvTrackFontOptions);\r\n procedure SetWordWrap(const Value: Boolean);\r\n procedure SetAlignment(const Value: TAlignment);\r\n procedure SetLayout(const Value: TTextLayout);\r\n procedure SetLeftText(const Value: Boolean);\r\n procedure SetLinkedControls(const Value: TJvLinkedControls);\r\n procedure ReadAssociated(Reader: TReader);\r\n procedure SetDataConnector(const Value: TJvCheckBoxDataConnector);\r\n protected\r\n function CreateDataConnector: TJvCheckBoxDataConnector; virtual;\r\n procedure Notification(AComponent: TComponent; Operation: TOperation);override;\r\n procedure MouseEnter(AControl: TControl); override;\r\n procedure MouseLeave(AControl: TControl); override;\r\n procedure TextChanged; override;\r\n procedure FontChanged; override;\r\n procedure EnabledChanged;override;\r\n procedure CreateParams(var Params: TCreateParams); override;\r\n procedure SetAutoSize(Value: Boolean); override;\r\n procedure UpdateProperties;\r\n procedure CalcAutoSize; virtual;\r\n procedure Loaded; override;\r\n procedure LinkedControlsChange(Sender: TObject);\r\n procedure CheckLinkedControls; virtual;\r\n procedure DefineProperties(Filer: TFiler); override;\r\n procedure BmSetCheck(var Msg: TMessage); message BM_SETCHECK;\r\n procedure KeyPress(var Key: Char); override;\r\n procedure DoExit; override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n\r\n procedure Toggle; override;\r\n procedure SetFocus; override;\r\n\r\n property Canvas: TCanvas read GetCanvas;\r\n published\r\n property Alignment: TAlignment read FAlignment write SetAlignment default taLeftJustify;\r\n // link the enabled state of other controls to the checked and/or enabled state of this control\r\n property LinkedControls: TJvLinkedControls read FLinkedControls write SetLinkedControls;\r\n property AutoSize: Boolean read FAutoSize write SetAutoSize default True;\r\n property HintColor;\r\n property HotTrack: Boolean read FHotTrack write FHotTrack default False;\r\n property HotTrackFont: TFont read FHotTrackFont write SetHotTrackFont;\r\n property HotTrackFontOptions: TJvTrackFontOptions read FHotTrackFontOptions write SetHotTrackFontOptions\r\n default DefaultTrackFontOptions;\r\n property Layout: TTextLayout read FLayout write SetLayout default tlCenter;\r\n // show text to the left of the checkbox\r\n property LeftText: Boolean read FLeftText write SetLeftText default False;\r\n property ReadOnly: Boolean read FReadOnly write FReadOnly default False;\r\n property WordWrap: Boolean read FWordWrap write SetWordWrap default False;\r\n property OnMouseEnter;\r\n property OnMouseLeave;\r\n property OnParentColorChange;\r\n\r\n property DataConnector: TJvCheckBoxDataConnector read FDataConnector write SetDataConnector;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvCheckBox.pas $';\r\n Revision: '$Revision: 13327 $';\r\n Date: '$Date: 2012-06-12 16:03:23 +0200 (mar. 12 juin 2012) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n SysUtils,\r\n JvJCLUtils, JvJVCLUtils;\r\n\r\n//=== { TJvCheckBoxDataConnector } ===========================================\r\n\r\nconstructor TJvCheckBoxDataConnector.Create(ACheckBox: TJvCheckBox);\r\nbegin\r\n inherited Create;\r\n FCheckBox := ACheckBox;\r\n FValueChecked := DefaultValueChecked;\r\n FValueUnchecked := DefaultValueUnchecked;\r\nend;\r\n\r\nfunction TJvCheckBoxDataConnector.IsValueCheckedStored: Boolean;\r\nbegin\r\n Result := FValueChecked <> DefaultValueChecked;\r\nend;\r\n\r\nfunction TJvCheckBoxDataConnector.IsValueUncheckedStored: Boolean;\r\nbegin\r\n Result := FValueUnchecked <> DefaultValueUnchecked;\r\nend;\r\n\r\nprocedure TJvCheckBoxDataConnector.Assign(Source: TPersistent);\r\nbegin\r\n inherited Assign(Source);\r\n if Source is TJvCheckBoxDataConnector then\r\n begin\r\n FValueChecked := TJvCheckBoxDataConnector(Source).ValueChecked;\r\n FValueUnchecked := TJvCheckBoxDataConnector(Source).ValueUnchecked;\r\n Reset;\r\n end;\r\nend;\r\n\r\nprocedure TJvCheckBoxDataConnector.RecordChanged;\r\nbegin\r\n if Field.IsValid and (ValueChecked <> '') and (ValueUnchecked <> '') then\r\n begin\r\n if not (csDesigning in FCheckBox.ComponentState) then\r\n FCheckBox.ReadOnly := not Field.CanModify;\r\n if not Field.IsNull then\r\n FCheckBox.Checked := AnsiCompareText(Field.AsString, ValueUnchecked) <> 0\r\n else\r\n FCheckBox.State := cbGrayed;\r\n end\r\n else\r\n begin\r\n FCheckBox.State := cbGrayed;\r\n if not (csDesigning in FCheckBox.ComponentState) then\r\n FCheckBox.ReadOnly := True;\r\n end;\r\nend;\r\n\r\nprocedure TJvCheckBoxDataConnector.UpdateData;\r\nbegin\r\n if Field.CanModify and Field.IsValid and (ValueChecked <> '') and (ValueUnchecked <> '') then\r\n begin\r\n if FCheckBox.Checked then\r\n Field.AsString := ValueChecked\r\n else\r\n Field.AsString := ValueUnchecked;\r\n end;\r\nend;\r\n\r\nprocedure TJvCheckBoxDataConnector.SetValueChecked(const Value: string);\r\nbegin\r\n if Value <> FValueChecked then\r\n begin\r\n FValueChecked := Value;\r\n Reset;\r\n end;\r\nend;\r\n\r\nprocedure TJvCheckBoxDataConnector.SetValueUnchecked(const Value: string);\r\nbegin\r\n if Value <> FValueUnchecked then\r\n begin\r\n FValueUnchecked := Value;\r\n Reset;\r\n end;\r\nend;\r\n\r\n//=== { TJvCheckBox } ========================================================\r\n\r\nconstructor TJvCheckBox.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FDataConnector := CreateDataConnector;\r\n FCanvas := TControlCanvas.Create;\r\n FCanvas.Control := Self;\r\n FHotTrack := False;\r\n FHotTrackFont := TFont.Create;\r\n FFontSave := TFont.Create;\r\n FHotTrackFontOptions := DefaultTrackFontOptions;\r\n FAutoSize := True;\r\n FWordWrap := False;\r\n FAlignment := taLeftJustify;\r\n FLeftText := False;\r\n FLayout := tlCenter;\r\n FReadOnly := False;\r\n FLinkedControls := TJvLinkedControls.Create(Self);\r\n FLinkedControls.OnChange := LinkedControlsChange;\r\nend;\r\n\r\ndestructor TJvCheckBox.Destroy;\r\nbegin\r\n FHotTrackFont.Free;\r\n FFontSave.Free;\r\n FreeAndNil(FLinkedControls);\r\n FDataConnector.Free;\r\n inherited Destroy;\r\n // (rom) destroy Canvas AFTER inherited Destroy\r\n FCanvas.Free;\r\nend;\r\n\r\nprocedure TJvCheckBox.Loaded;\r\nbegin\r\n inherited Loaded;\r\n CheckLinkedControls;\r\n CalcAutoSize;\r\n DataConnector.Reset;\r\nend;\r\n\r\nfunction TJvCheckBox.CreateDataConnector: TJvCheckBoxDataConnector;\r\nbegin\r\n Result := TJvCheckBoxDataConnector.Create(Self);\r\nend;\r\n\r\nprocedure TJvCheckBox.CreateParams(var Params: TCreateParams);\r\nconst\r\n cAlign: array [TAlignment] of Word = (BS_LEFT, BS_RIGHT, BS_CENTER);\r\n cLeftText: array [Boolean] of Word = (0, BS_RIGHTBUTTON);\r\n cLayout: array [TTextLayout] of Word = (BS_TOP, BS_VCENTER, BS_BOTTOM);\r\n cWordWrap: array [Boolean] of Word = (0, BS_MULTILINE);\r\nbegin\r\n inherited CreateParams(Params);\r\n with Params do\r\n Style := Style or cAlign[Alignment] or cLayout[Layout] or\r\n cLeftText[LeftText] or cWordWrap[WordWrap];\r\nend;\r\n\r\nprocedure TJvCheckBox.UpdateProperties;\r\nbegin\r\n RecreateWnd;\r\nend;\r\n\r\nprocedure TJvCheckBox.KeyPress(var Key: Char);\r\nbegin\r\n inherited KeyPress(Key);\r\n case Key of\r\n #8, ' ':\r\n DataConnector.Modify;\r\n #27:\r\n DataConnector.Reset;\r\n end;\r\nend;\r\n\r\nprocedure TJvCheckBox.DoExit;\r\nbegin\r\n try\r\n DataConnector.UpdateRecord;\r\n except\r\n SetFocus;\r\n raise;\r\n end;\r\n inherited DoExit;\r\nend;\r\n\r\nprocedure TJvCheckBox.MouseEnter(AControl: TControl);\r\nbegin\r\n if csDesigning in ComponentState then\r\n Exit;\r\n if not MouseOver then\r\n begin\r\n if FHotTrack then\r\n begin\r\n FFontSave.Assign(Font);\r\n Font.Assign(FHotTrackFont);\r\n end;\r\n inherited MouseEnter(AControl);\r\n end;\r\nend;\r\n\r\nprocedure TJvCheckBox.MouseLeave(AControl: TControl);\r\nbegin\r\n if MouseOver then\r\n begin\r\n if FHotTrack then\r\n Font.Assign(FFontSave);\r\n inherited MouseLeave(AControl);\r\n end;\r\nend;\r\n\r\nprocedure TJvCheckBox.FontChanged;\r\nbegin\r\n inherited FontChanged;\r\n CalcAutoSize;\r\n UpdateTrackFont(HotTrackFont, Font, HotTrackFontOptions);\r\nend;\r\n\r\nprocedure TJvCheckBox.TextChanged;\r\nbegin\r\n inherited TextChanged;\r\n CalcAutoSize;\r\nend;\r\n\r\nprocedure TJvCheckBox.CalcAutoSize;\r\nconst\r\n Flags: array [Boolean] of Cardinal = (DT_SINGLELINE, DT_WORDBREAK);\r\nvar\r\n AWidth, AHeight: Integer;\r\n ASize: TSize;\r\n R: TRect;\r\nbegin\r\n if (Parent = nil) or not AutoSize or (csDestroying in ComponentState) or\r\n (csLoading in ComponentState) then\r\n Exit;\r\n ASize := GetDefaultCheckBoxSize;\r\n // add some spacing\r\n Inc(ASize.cy, 4);\r\n FCanvas.Font := Font;\r\n R := Rect(0, 0, ClientWidth, ClientHeight);\r\n // This is slower than GetTextExtentPoint but it does consider hotkeys\r\n if Caption <> '' then\r\n begin\r\n DrawText(FCanvas, Caption, -1, R,\r\n Flags[WordWrap] or DT_LEFT or DT_NOCLIP or DT_CALCRECT);\r\n AWidth := (R.Right - R.Left) + ASize.cx + 8;\r\n AHeight := R.Bottom - R.Top;\r\n end\r\n else\r\n begin\r\n AWidth := ASize.cx;\r\n AHeight := ASize.cy;\r\n end;\r\n if AWidth < ASize.cx then\r\n AWidth := ASize.cx;\r\n if AHeight < ASize.cy then\r\n AHeight := ASize.cy;\r\n ClientWidth := AWidth;\r\n ClientHeight := AHeight;\r\nend;\r\n\r\nprocedure TJvCheckBox.SetHotTrackFont(const Value: TFont);\r\nbegin\r\n FHotTrackFont.Assign(Value);\r\nend;\r\n\r\nprocedure TJvCheckBox.SetAutoSize(Value: Boolean);\r\nbegin\r\n if FAutoSize <> Value then\r\n begin\r\n //inherited SetAutoSize(Value);\r\n FAutoSize := Value;\r\n if Value then\r\n WordWrap := False;\r\n CalcAutoSize;\r\n end;\r\nend;\r\n\r\nfunction TJvCheckBox.GetCanvas: TCanvas;\r\nbegin\r\n Result := FCanvas;\r\nend;\r\n\r\nprocedure TJvCheckBox.SetHotTrackFontOptions(const Value: TJvTrackFontOptions);\r\nbegin\r\n if FHotTrackFontOptions <> Value then\r\n begin\r\n FHotTrackFontOptions := Value;\r\n UpdateTrackFont(HotTrackFont, Font, FHotTrackFontOptions);\r\n end;\r\nend;\r\n\r\nprocedure TJvCheckBox.SetWordWrap(const Value: Boolean);\r\nbegin\r\n if FWordWrap <> Value then\r\n begin\r\n FWordWrap := Value;\r\n if Value then\r\n AutoSize := False;\r\n UpdateProperties;\r\n end;\r\nend;\r\n\r\nprocedure TJvCheckBox.SetAlignment(const Value: TAlignment);\r\nbegin\r\n if FAlignment <> Value then\r\n begin\r\n FAlignment := Value;\r\n UpdateProperties;\r\n end;\r\nend;\r\n\r\nprocedure TJvCheckBox.SetLayout(const Value: TTextLayout);\r\nbegin\r\n if FLayout <> Value then\r\n begin\r\n FLayout := Value;\r\n UpdateProperties;\r\n end;\r\nend;\r\n\r\nprocedure TJvCheckBox.SetLeftText(const Value: Boolean);\r\nbegin\r\n if FLeftText <> Value then\r\n begin\r\n FLeftText := Value;\r\n UpdateProperties;\r\n end;\r\nend;\r\n\r\nprocedure TJvCheckBox.SetLinkedControls(const Value: TJvLinkedControls);\r\nbegin\r\n FLinkedControls.Assign(Value);\r\nend;\r\n\r\nprocedure TJvCheckBox.CheckLinkedControls;\r\nvar\r\n I: Integer;\r\nbegin\r\n if not FCheckingLinkedControls then // prevent an infinite recursion\r\n begin\r\n FCheckingLinkedControls := True;\r\n try\r\n if LinkedControls <> nil then\r\n for I := 0 to LinkedControls.Count - 1 do\r\n with LinkedControls[I] do\r\n if Control <> nil then\r\n Control.Enabled := CheckLinkControlEnabled(Self.Enabled, Self.Checked, Options);\r\n finally\r\n FCheckingLinkedControls := False;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvCheckBox.LinkedControlsChange(Sender: TObject);\r\nbegin\r\n CheckLinkedControls;\r\nend;\r\n\r\nprocedure TJvCheckBox.ReadAssociated(Reader: TReader);\r\nvar\r\n C: TComponent;\r\nbegin\r\n if Owner <> nil then\r\n C := Owner.FindComponent(Reader.ReadIdent)\r\n else\r\n C := nil;\r\n if (C is TControl) and (LinkedControls <> nil) then\r\n LinkedControls.Add.Control := TControl(C);\r\nend;\r\n\r\nprocedure TJvCheckBox.SetDataConnector(const Value: TJvCheckBoxDataConnector);\r\nbegin\r\n if Value <> FDataConnector then\r\n FDataConnector.Assign(Value);\r\nend;\r\n\r\ntype\r\n TWinControlAccess = class(TWinControl);\r\n\r\nprocedure TJvCheckBox.SetFocus;\r\nvar\r\n I: Integer;\r\n FocusLinkedControl: TControl;\r\nbegin\r\n inherited SetFocus;\r\n\r\n // we want to skip our own focus, either to our children or to a sibling\r\n // depending on the direction that the user asked for\r\n if GetKeyState(VK_SHIFT) >= 0 then\r\n begin\r\n FocusLinkedControl := nil;\r\n I := 0;\r\n while (I < LinkedControls.Count) and not Assigned(FocusLinkedControl) do\r\n begin\r\n if (loForceFocus in LinkedControls[I].Options) and (LinkedControls[I].Control is TWinControl) then\r\n FocusLinkedControl := LinkedControls[I].Control;\r\n\r\n Inc(I);\r\n end;\r\n if Assigned(FocusLinkedControl) and TWinControl(FocusLinkedControl).CanFocus then\r\n TWinControl(FocusLinkedControl).SetFocus;\r\n end\r\n else\r\n begin\r\n TWinControlAccess(Parent).SelectNext(Self, False, True);\r\n end;\r\nend;\r\n\r\nprocedure TJvCheckBox.DefineProperties(Filer: TFiler);\r\nbegin\r\n inherited DefineProperties(Filer);\r\n Filer.DefineProperty('Associated', ReadAssociated, nil, False);\r\nend;\r\n\r\nprocedure TJvCheckBox.BmSetCheck(var Msg: TMessage);\r\nbegin\r\n// if not ReadOnly then\r\n// begin\r\n inherited;\r\n CheckLinkedControls;\r\n// end;\r\nend;\r\n\r\nprocedure TJvCheckBox.EnabledChanged;\r\nbegin\r\n inherited EnabledChanged;\r\n CheckLinkedControls;\r\nend;\r\n\r\nprocedure TJvCheckBox.Notification(AComponent: TComponent;\r\n Operation: TOperation);\r\nbegin\r\n inherited Notification(AComponent, Operation);\r\n if Assigned(FLinkedControls) then\r\n LinkedControls.Notification(AComponent, Operation);\r\nend;\r\n\r\nprocedure TJvCheckBox.Toggle;\r\nbegin\r\n if not ReadOnly then\r\n begin\r\n inherited;\r\n CheckLinkedControls;\r\n if not (csLoading in ComponentState) then\r\n DataConnector.Modify;\r\n end;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvCheckListBox.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvCheckListBox.PAS, released on 2001-02-28.\r\n\r\nThe Initial Developer of the Original Code is Sbastien Buysse [sbuysse att buypin dott com]\r\nPortions created by Sbastien Buysse are Copyright (C) 2001 Sbastien Buysse.\r\nAll Rights Reserved.\r\n\r\nThis is a merging of the code in the original JvCheckListBox.pas and JvFixedCheckListBox.pas\r\nMerging done 2002-06-05 by Peter Thornqvist [peter3 at sourceforge dot net]\r\n\r\nContributor(s):\r\nMichael Beck [mbeck att bigfoot dott com].\r\nPeter Below <100113 dott 1101 att compuserve dott com>\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvCheckListBox.pas 13104 2011-09-07 06:50:43Z obones $\r\n\r\nunit JvCheckListBox;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, Messages, SysUtils, Classes, Contnrs, Controls, Graphics, StdCtrls,\r\n JvExCheckLst, JvDataSourceIntf;\r\n\r\nconst\r\n DefaultValueChecked = '1';\r\n DefaultValueUnchecked = '0';\r\n\r\ntype\r\n TJvCheckListBox = class;\r\n\r\n TJvCheckListBoxDataConnector = class(TJvLookupDataConnector)\r\n private\r\n FCheckListBox: TJvCheckListBox;\r\n FValueChecked: string;\r\n FValueUnchecked: string;\r\n FMap: TList;\r\n FRecNumMap: TBucketList;\r\n procedure SetValueChecked(const Value: string);\r\n procedure SetValueUnchecked(const Value: string);\r\n function IsValueCheckedStored: Boolean;\r\n function IsValueUncheckedStored: Boolean;\r\n protected\r\n procedure Popuplate; virtual;\r\n procedure ActiveChanged; override;\r\n procedure UpdateData; override;\r\n procedure RecordChanged; override;\r\n procedure GetKeyNames(out KeyName, ListKeyName: TDataFieldString);\r\n procedure GotoCurrent;\r\n public\r\n constructor Create(ACheckListBox: TJvCheckListBox);\r\n destructor Destroy; override;\r\n procedure Assign(Source: TPersistent); override;\r\n function IsValid: Boolean; virtual;\r\n published\r\n property ValueChecked: string read FValueChecked write SetValueChecked stored IsValueCheckedStored;\r\n property ValueUnchecked: string read FValueUnchecked write SetValueUnchecked stored IsValueUncheckedStored;\r\n end;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvCheckListBox = class(TJvExCheckListBox)\r\n private\r\n FHotTrack: Boolean;\r\n FOnSelectCancel: TNotifyEvent;\r\n FMaxWidth: Integer;\r\n FScroll: Boolean;\r\n FOnHScroll: TNotifyEvent;\r\n FOnVScroll: TNotifyEvent;\r\n procedure SetHScroll(const Value: Boolean);\r\n procedure WMHScroll(var Msg: TWMHScroll); message WM_HSCROLL;\r\n procedure WMVScroll(var Msg: TWMVScroll); message WM_VSCROLL;\r\n procedure CNDrawItem(var Msg: TWMDrawItem); message CN_DRAWITEM;\r\n procedure LBNSelCancel(var Msg: TMessage); message LBN_SELCANCEL;\r\n procedure RefreshH;\r\n procedure SetHotTrack(const Value: Boolean);\r\n protected\r\n procedure CreateParams(var Params: TCreateParams); override;\r\n procedure WndProc(var Msg: TMessage); override;\r\n procedure MouseEnter(Control: TControl); override;\r\n procedure MouseLeave(Control: TControl); override;\r\n private\r\n FDataConnector: TJvCheckListBoxDataConnector;\r\n FOnItemDrawing: TDrawItemEvent;\r\n procedure SetDataConnector(const Value: TJvCheckListBoxDataConnector);\r\n procedure CMChanged(var Msg: TMessage); message CM_CHANGED;\r\n protected\r\n function CreateDataConnector: TJvCheckListBoxDataConnector; virtual;\r\n procedure ClickCheck; override;\r\n procedure DrawItem(Index: Integer; Rect: TRect; State: TOwnerDrawState); override;\r\n procedure DoItemDrawing(Index: Integer; Rect: TRect; State: TOwnerDrawState);\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n function SearchExactString(Value: string; CaseSensitive: Boolean = True): Integer;\r\n function SearchPrefix(Value: string; CaseSensitive: Boolean = True): Integer;\r\n function SearchSubString(Value: string; CaseSensitive: Boolean = True): Integer;\r\n function DeleteExactString(Value: string; All: Boolean;\r\n CaseSensitive: Boolean = True): Integer;\r\n procedure SelectAll; override;\r\n procedure UnselectAll;\r\n procedure InvertSelection;\r\n procedure CheckAll;\r\n procedure UnCheckAll;\r\n procedure InvertCheck;\r\n function GetChecked: TStringList;\r\n function GetUnChecked: TStringList;\r\n procedure DeleteSelected; override;\r\n procedure SaveToFile(FileName: TFileName);\r\n procedure LoadFromFile(FileName: TFileName);\r\n procedure LoadFromStream(Stream: TStream);\r\n procedure SaveToStream(Stream: TStream);\r\n published\r\n property OnItemDrawing: TDrawItemEvent read FOnItemDrawing write FOnItemDrawing;\r\n\r\n property MultiSelect;\r\n property HintColor;\r\n property OnMouseEnter;\r\n property OnMouseLeave;\r\n property OnParentColorChange;\r\n property HotTrack: Boolean read FHotTrack write SetHotTrack default False;\r\n property HorScrollbar: Boolean read FScroll write SetHScroll default True;\r\n property OnSelectCancel: TNotifyEvent read FOnSelectCancel write FOnSelectCancel;\r\n property OnVerticalScroll: TNotifyEvent read FOnVScroll write FOnVScroll;\r\n property OnHorizontalScroll: TNotifyEvent read FOnHScroll write FOnHScroll;\r\n\r\n property DataConnector: TJvCheckListBoxDataConnector read FDataConnector write SetDataConnector;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvCheckListBox.pas $';\r\n Revision: '$Revision: 13104 $';\r\n Date: '$Date: 2011-09-07 08:50:43 +0200 (mer. 07 sept. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n {$IFDEF COMPILER10_UP}\r\n Types,\r\n {$ENDIF COMPILER10_UP}\r\n JvItemsSearchs, JvJCLUtils;\r\n\r\n//=== { TJvCheckListBoxDataConnector } =======================================\r\n\r\nconstructor TJvCheckListBoxDataConnector.Create(ACheckListBox: TJvCheckListBox);\r\nbegin\r\n inherited Create;\r\n FCheckListBox := ACheckListBox;\r\n FValueChecked := '1';\r\n FValueUnchecked := '0';\r\n FMap := TList.Create;\r\n FRecNumMap := TBucketList.Create(bl256);\r\nend;\r\n\r\ndestructor TJvCheckListBoxDataConnector.Destroy;\r\nbegin\r\n FMap.Free;\r\n FRecNumMap.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvCheckListBoxDataConnector.GetKeyNames(out KeyName,\r\n ListKeyName: TDataFieldString);\r\nbegin\r\n if List.Key.IsValid then\r\n ListKeyName := List.KeyField;\r\n if Key.IsValid then\r\n KeyName := KeyField;\r\n if ListKeyName = '' then\r\n ListKeyName := KeyName;\r\n if KeyName = '' then\r\n KeyName := ListKeyName;\r\nend;\r\n\r\nprocedure TJvCheckListBoxDataConnector.GotoCurrent;\r\nvar\r\n RecNo: Integer;\r\nbegin\r\n if IsValid then\r\n begin\r\n RecNo := Integer(FMap[FCheckListBox.ItemIndex]);\r\n if ListSource.RecNo <> RecNo then\r\n begin\r\n Active := False;\r\n try\r\n ListSource.RecNo := RecNo;\r\n finally\r\n Active := True;\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJvCheckListBoxDataConnector.IsValid: Boolean;\r\nbegin\r\n Result := List.DataSetConnected and List.Field.IsValid and\r\n DataSetConnected and Field.IsValid and\r\n (Key.IsValid or List.Key.IsValid or (ListSource.DataSet = DataSource.DataSet));\r\nend;\r\n\r\nfunction TJvCheckListBoxDataConnector.IsValueCheckedStored: Boolean;\r\nbegin\r\n Result := FValueChecked <> DefaultValueChecked;\r\nend;\r\n\r\nfunction TJvCheckListBoxDataConnector.IsValueUncheckedStored: Boolean;\r\nbegin\r\n Result := FValueUnchecked <> DefaultValueUnchecked;\r\nend;\r\n\r\nprocedure TJvCheckListBoxDataConnector.Popuplate;\r\nvar\r\n IsChecked: TList;\r\n ListKeyName, KeyName: TDataFieldString;\r\n I: Integer;\r\n Index: {$IFDEF RTL230_UP}NativeInt{$ELSE}Integer{$ENDIF};\r\nbegin\r\n FMap.Clear;\r\n FRecNumMap.Clear;\r\n\r\n FCheckListBox.Items.BeginUpdate;\r\n try\r\n FCheckListBox.Items.Clear;\r\n Index := -1;\r\n if IsValid then\r\n begin\r\n ListSource.BeginUpdate;\r\n try\r\n if DataSource.DataSet <> ListSource.DataSet then\r\n DataSource.BeginUpdate;\r\n try\r\n IsChecked := TList.Create;\r\n try\r\n ListSource.First;\r\n while not ListSource.Eof do\r\n begin\r\n Index := FCheckListBox.Items.Add(List.Field.AsString);\r\n FMap.Add(TObject(ListSource.RecNo));\r\n FRecNumMap.Add(TObject(ListSource.RecNo), TObject(Index));\r\n\r\n if ListSource.DataSet = DataSource.DataSet then\r\n IsChecked.Add(TObject(AnsiCompareText(Field.AsString, ValueUnchecked) <> 0))\r\n else\r\n begin\r\n GetKeyNames(KeyName, ListKeyName);\r\n if DataSource.Locate(KeyName, ListSource.FieldValue[ListSource.FieldByName(ListKeyName)], []) then\r\n IsChecked.Add(TObject(AnsiCompareText(Field.AsString, ValueUnchecked) <> 0))\r\n else\r\n IsChecked.Add(TObject(False));\r\n end;\r\n ListSource.Next;\r\n end;\r\n for I := 0 to IsChecked.Count - 1 do\r\n FCheckListBox.Checked[I] := Boolean(IsChecked[I]);\r\n finally\r\n IsChecked.Free;\r\n end;\r\n finally\r\n if DataSource.DataSet <> ListSource.DataSet then\r\n DataSource.EndUpdate;\r\n end;\r\n finally\r\n ListSource.EndUpdate;\r\n end;\r\n if not FRecNumMap.Find(TObject(ListSource.RecNo), Pointer(Index)) then\r\n Index := -1;\r\n end;\r\n FCheckListBox.ItemIndex := Index;\r\n finally\r\n FCheckListBox.Items.EndUpdate;\r\n end\r\nend;\r\n\r\nprocedure TJvCheckListBoxDataConnector.Assign(Source: TPersistent);\r\nbegin\r\n inherited Assign(Source);\r\n if Source is TJvCheckListBoxDataConnector then\r\n begin\r\n FValueChecked := TJvCheckListBoxDataConnector(Source).ValueChecked;\r\n FValueUnchecked := TJvCheckListBoxDataConnector(Source).ValueUnchecked;\r\n Reset;\r\n end;\r\nend;\r\n\r\nprocedure TJvCheckListBoxDataConnector.ActiveChanged;\r\nbegin\r\n Popuplate;\r\nend;\r\n\r\nprocedure TJvCheckListBoxDataConnector.RecordChanged;\r\nvar\r\n Index: {$IFDEF RTL230_UP}NativeInt{$ELSE}Integer{$ENDIF};\r\nbegin\r\n if IsValid then\r\n begin\r\n if ListSource.RecordCount <> FCheckListBox.Items.Count then\r\n Popuplate\r\n else\r\n if ListSource.RecNo <> -1 then\r\n begin\r\n if FRecNumMap.Find(TObject(ListSource.RecNo), Pointer(Index)) then\r\n begin\r\n FCheckListBox.Items[Index] := List.Field.AsString;\r\n FCheckListBox.Checked[Index] := AnsiCompareText(Field.AsString, ValueUnchecked) <> 0;\r\n if Index <> FCheckListBox.ItemIndex then\r\n FCheckListBox.ItemIndex := Index;\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvCheckListBoxDataConnector.UpdateData;\r\nvar\r\n KeyName, ListKeyName: TDataFieldString;\r\n Value: string;\r\nbegin\r\n if Field.CanModify and IsValid and (ValueChecked <> '') and (ValueUnchecked <> '') and\r\n (FCheckListBox.ItemIndex <> -1) then\r\n begin\r\n if FCheckListBox.Checked[FCheckListBox.ItemIndex] then\r\n Value := ValueChecked\r\n else\r\n Value := ValueUnchecked;\r\n\r\n GotoCurrent;\r\n DataSource.Edit;\r\n\r\n if ListSource.DataSet = DataSource.DataSet then\r\n Field.AsString := Value\r\n else\r\n begin\r\n GetKeyNames(KeyName, ListKeyName);\r\n DataSource.BeginUpdate;\r\n try\r\n if DataSource.Locate(KeyName, ListSource.FieldValue[ListSource.FieldByName(ListKeyName)], []) then\r\n Field.AsString := Value;\r\n finally\r\n DataSource.EndUpdate;\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvCheckListBoxDataConnector.SetValueChecked(const Value: string);\r\nbegin\r\n if Value <> FValueChecked then\r\n begin\r\n FValueChecked := Value;\r\n Reset;\r\n end;\r\nend;\r\n\r\nprocedure TJvCheckListBoxDataConnector.SetValueUnchecked(const Value: string);\r\nbegin\r\n if Value <> FValueUnchecked then\r\n begin\r\n FValueUnchecked := Value;\r\n Reset;\r\n end;\r\nend;\r\n\r\n//=== { TJvCheckListBox } ====================================================\r\n\r\ntype\r\n // Used for the load/save methods\r\n TCheckListRecord = record\r\n Checked: Boolean;\r\n StringSize: Integer;\r\n end;\r\n\r\nconstructor TJvCheckListBox.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FDataConnector := CreateDataConnector;\r\n FHotTrack := False;\r\n FMaxWidth := 0;\r\n FScroll := True;\r\n {$IFDEF COMPILER14_UP}\r\n ParentDoubleBuffered := False;\r\n {$ENDIF COMPILER14_UP}\r\n // ControlStyle := ControlStyle + [csAcceptsControls];\r\nend;\r\n\r\ndestructor TJvCheckListBox.Destroy;\r\nbegin\r\n FDataConnector.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJvCheckListBox.CreateDataConnector: TJvCheckListBoxDataConnector;\r\nbegin\r\n Result := TJvCheckListBoxDataConnector.Create(Self);\r\nend;\r\n\r\nprocedure TJvCheckListBox.ClickCheck;\r\nbegin\r\n inherited;\r\n if not (csLoading in ComponentState) then\r\n begin\r\n DataConnector.Modify;\r\n DataConnector.UpdateRecord;\r\n end;\r\nend;\r\n\r\nprocedure TJvCheckListBox.SetDataConnector(const Value: TJvCheckListBoxDataConnector);\r\nbegin\r\n if Value <> FDataConnector then\r\n FDataConnector.Assign(Value);\r\nend;\r\n\r\nprocedure TJvCheckListBox.CMChanged(var Msg: TMessage);\r\nbegin\r\n inherited;\r\n DataConnector.GotoCurrent;\r\nend;\r\n\r\nprocedure TJvCheckListBox.DoItemDrawing(Index: Integer; Rect: TRect; State: TOwnerDrawState);\r\nbegin\r\n if Assigned(OnItemDrawing) then\r\n OnItemDrawing(Self, Index, Rect, State);\r\nend;\r\n\r\nprocedure TJvCheckListBox.DrawItem(Index: Integer; Rect: TRect; State: TOwnerDrawState);\r\nbegin\r\n DoItemDrawing(Index, Rect, State);\r\n inherited DrawItem(Index, Rect, State);\r\nend;\r\n\r\nprocedure TJvCheckListBox.CheckAll;\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := 0 to Items.Count - 1 do\r\n Checked[I] := True;\r\nend;\r\n\r\nprocedure TJvCheckListBox.CreateParams(var Params: TCreateParams);\r\nbegin\r\n inherited CreateParams(Params);\r\n with Params do\r\n if FScroll then\r\n Style := Style or WS_HSCROLL\r\n else\r\n Style := Style and not WS_HSCROLL;\r\nend;\r\n\r\nfunction TJvCheckListBox.DeleteExactString(Value: string; All: Boolean;\r\n CaseSensitive: Boolean): Integer;\r\nbegin\r\n Result := TJvItemsSearchs.DeleteExactString(Items, Value, CaseSensitive);\r\nend;\r\n\r\nprocedure TJvCheckListBox.DeleteSelected;\r\nvar\r\n I: Integer;\r\nbegin\r\n if MultiSelect then\r\n begin\r\n for I := Items.Count - 1 downto 0 do\r\n if Selected[I] then\r\n Items.Delete(I);\r\n end\r\n else\r\n if ItemIndex <> -1 then\r\n begin\r\n I := ItemIndex;\r\n Items.Delete(I);\r\n if I > 0 then\r\n Dec(I);\r\n if Items.Count > 0 then\r\n ItemIndex := I;\r\n end;\r\nend;\r\n\r\nfunction TJvCheckListBox.GetChecked: TStringList;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := TStringList.Create;\r\n for I := 0 to Items.Count - 1 do\r\n if Checked[I] then\r\n Result.AddObject(Items[I], Items.Objects[I]);\r\nend;\r\n\r\nfunction TJvCheckListBox.GetUnChecked: TStringList;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := TStringList.Create;\r\n for I := 0 to Items.Count - 1 do\r\n if not Checked[I] then\r\n Result.AddObject(Items[I], Items.Objects[I]);\r\nend;\r\n\r\nprocedure TJvCheckListBox.InvertCheck;\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := 0 to Items.Count - 1 do\r\n Checked[I] := not Checked[I];\r\nend;\r\n\r\nprocedure TJvCheckListBox.InvertSelection;\r\nvar\r\n I: Integer;\r\nbegin\r\n if MultiSelect then\r\n for I := 0 to Items.Count - 1 do\r\n Selected[I] := not Selected[I];\r\nend;\r\n\r\nprocedure TJvCheckListBox.LBNSelCancel(var Msg: TMessage);\r\nbegin\r\n if Assigned(FOnSelectCancel) then\r\n FOnSelectCancel(Self);\r\nend;\r\n\r\nprocedure TJvCheckListBox.CNDrawItem(var Msg: TWMDrawItem);\r\nbegin\r\n if (Items.Count = 0) or (Msg.DrawItemStruct.itemID >= UINT(Items.Count)) then\r\n Exit;\r\n inherited;\r\nend;\r\n\r\nprocedure TJvCheckListBox.LoadFromFile(FileName: TFileName);\r\nvar\r\n Stream: TFileStream;\r\nbegin\r\n Stream := TFileStream.Create(FileName, fmOpenRead or fmShareDenyWrite);\r\n try\r\n LoadFromStream(Stream);\r\n finally\r\n Stream.Free;\r\n end;\r\nend;\r\n\r\nprocedure TJvCheckListBox.LoadFromStream(Stream: TStream);\r\nvar\r\n CheckLst: TCheckListRecord;\r\n UTF8Item: UTF8String;\r\nbegin\r\n Items.Clear;\r\n while Stream.Position + SizeOf(TCheckListRecord) <= Stream.Size do\r\n begin\r\n Stream.Read(CheckLst, SizeOf(TCheckListRecord));\r\n if Stream.Position + CheckLst.StringSize <= Stream.Size then\r\n begin\r\n SetLength(UTF8Item, CheckLst.StringSize);\r\n if CheckLst.StringSize > 0 then\r\n Stream.Read(PAnsiChar(UTF8Item)^, CheckLst.StringSize);\r\n Checked[Items.Add(UTF8ToString(UTF8Item))] := CheckLst.Checked;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvCheckListBox.MouseEnter(Control: TControl);\r\nbegin\r\n if csDesigning in ComponentState then\r\n Exit;\r\n if not MouseOver then\r\n begin\r\n if HotTrack then\r\n Ctl3D := True;\r\n inherited MouseEnter(Control);\r\n end;\r\nend;\r\n\r\nprocedure TJvCheckListBox.MouseLeave(Control: TControl);\r\nbegin\r\n if MouseOver then\r\n begin\r\n if HotTrack then\r\n Ctl3D := False;\r\n inherited MouseLeave(Control);\r\n end;\r\nend;\r\n\r\nprocedure TJvCheckListBox.RefreshH;\r\nvar\r\n I: Integer;\r\n ItemWidth: Word;\r\nbegin\r\n FMaxWidth := 0;\r\n for I := 0 to Items.Count - 1 do\r\n begin\r\n ItemWidth := Canvas.TextWidth(Items[I] + ' ');\r\n Inc(ItemWidth, GetCheckWidth);\r\n if FMaxWidth < ItemWidth then\r\n FMaxWidth := ItemWidth;\r\n end;\r\n SetHScroll(FScroll);\r\nend;\r\n\r\nprocedure TJvCheckListBox.SaveToFile(FileName: TFileName);\r\nvar\r\n Stream: TFileStream;\r\nbegin\r\n Stream := TFileStream.Create(FileName, fmCreate or fmShareExclusive);\r\n try\r\n SaveToStream(Stream);\r\n finally\r\n Stream.Free;\r\n end;\r\nend;\r\n\r\nprocedure TJvCheckListBox.SaveToStream(Stream: TStream);\r\nvar\r\n I: Integer;\r\n CheckLst: TCheckListRecord;\r\n UTF8Item: UTF8String;\r\nbegin\r\n for I := 0 to Items.Count - 1 do\r\n begin\r\n UTF8Item := UTF8Encode(Items[I]);\r\n CheckLst.Checked := Checked[I];\r\n CheckLst.StringSize := Length(UTF8Item);\r\n Stream.Write(CheckLst, SizeOf(TCheckListRecord));\r\n Stream.Write(PAnsiChar(UTF8Item)^, CheckLst.StringSize);\r\n end;\r\nend;\r\n\r\nfunction TJvCheckListBox.SearchExactString(Value: string;\r\n CaseSensitive: Boolean): Integer;\r\nbegin\r\n Result := TJvItemsSearchs.SearchExactString(Items, Value, CaseSensitive);\r\nend;\r\n\r\nfunction TJvCheckListBox.SearchPrefix(Value: string; CaseSensitive: Boolean): Integer;\r\nbegin\r\n Result := TJvItemsSearchs.SearchPrefix(Items, Value, CaseSensitive);\r\nend;\r\n\r\nfunction TJvCheckListBox.SearchSubString(Value: string;\r\n CaseSensitive: Boolean): Integer;\r\nbegin\r\n Result := TJvItemsSearchs.SearchSubString(Items, Value, CaseSensitive);\r\nend;\r\n\r\nprocedure TJvCheckListBox.SelectAll;\r\nvar\r\n I: Integer;\r\nbegin\r\n if MultiSelect then\r\n for I := 0 to Items.Count - 1 do\r\n Selected[I] := True;\r\nend;\r\n\r\nprocedure TJvCheckListBox.SetHotTrack(const Value: Boolean);\r\nbegin\r\n FHotTrack := Value;\r\n if FHotTrack then\r\n Ctl3D := False;\r\nend;\r\n\r\nprocedure TJvCheckListBox.SetHScroll(const Value: Boolean);\r\nbegin\r\n FScroll := Value;\r\n if FScroll then\r\n SendMessage(Handle, LB_SETHORIZONTALEXTENT, FMaxWidth, 0);\r\nend;\r\n\r\nprocedure TJvCheckListBox.UnCheckAll;\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := 0 to Items.Count - 1 do\r\n Checked[I] := False;\r\nend;\r\n\r\nprocedure TJvCheckListBox.UnselectAll;\r\nvar\r\n I: Integer;\r\nbegin\r\n if MultiSelect then\r\n for I := 0 to Items.Count - 1 do\r\n Selected[I] := False;\r\nend;\r\n\r\nprocedure TJvCheckListBox.WMHScroll(var Msg: TWMHScroll);\r\nvar\r\n ScrollPos: Integer;\r\n R: TRect;\r\nbegin\r\n inherited;\r\n // (p3) what does this code do, really?\r\n if Msg.ScrollCode <> SB_ENDSCROLL then\r\n begin\r\n ScrollPos := GetScrollPos(Handle, SB_HORZ);\r\n if ScrollPos < 20 then\r\n begin\r\n R := ClientRect;\r\n R.Right := R.Left + 20;\r\n Windows.InvalidateRect(Handle, @R, False);\r\n end;\r\n end;\r\n if Assigned(FOnHScroll) then\r\n FOnHScroll(Self);\r\nend;\r\n\r\nprocedure TJvCheckListBox.WMVScroll(var Msg: TWMVScroll);\r\nbegin\r\n inherited;\r\n if Assigned(FOnVScroll) then\r\n FOnVScroll(Self);\r\nend;\r\n\r\nprocedure TJvCheckListBox.WndProc(var Msg: TMessage);\r\nvar\r\n ItemWidth: Word;\r\nbegin\r\n case Msg.Msg of\r\n LB_ADDSTRING, LB_INSERTSTRING:\r\n begin\r\n ItemWidth := Canvas.TextWidth(StrPas(PChar(Msg.lParam)) + ' ');\r\n Inc(ItemWidth, GetCheckWidth);\r\n if FMaxWidth < ItemWidth then\r\n FMaxWidth := ItemWidth;\r\n SetHScroll(FScroll);\r\n end;\r\n LB_DELETESTRING:\r\n begin\r\n ItemWidth := Canvas.TextWidth(Items[Msg.wParam] + ' ');\r\n Inc(ItemWidth, GetCheckWidth);\r\n if ItemWidth = FMaxWidth then\r\n begin\r\n inherited WndProc(Msg);\r\n RefreshH;\r\n Exit;\r\n end;\r\n end;\r\n LB_RESETCONTENT:\r\n begin\r\n inherited WndProc(Msg);\r\n FMaxWidth := 0;\r\n SetHScroll(FScroll);\r\n Exit;\r\n end;\r\n WM_SETFONT:\r\n begin\r\n inherited WndProc(Msg);\r\n Canvas.Font.Assign(Font);\r\n RefreshH;\r\n Exit;\r\n end;\r\n end;\r\n inherited WndProc(Msg);\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend." }, { "path": "External/Jedi/Jvcl/run/JvCheckTreeView.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvCheckTreeView.PAS, released on 2003-06-22.\r\n\r\nThe Initial Developer of the Original Code is Peter Thrnqvist [peter3 at sourceforge dot net]\r\nPortions created by Peter Thrnqvist are Copyright (C) 2003 Peter Thrnqvist.\r\nAll Rights Reserved.\r\n\r\nContributor(s): Olivier Sannier\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvCheckTreeView.pas 13227 2012-02-24 15:22:50Z obones $\r\n\r\nunit JvCheckTreeView;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, Messages, Classes, Controls, ComCtrls,\r\n JvComCtrls, JvExComCtrls;\r\n\r\ntype\r\n TJvTVCheckBoxStyle = (cbsNone, cbsNative, cbsJVCL);\r\n TJvTVCascadeOption = (poOnCheck, poOnUnCheck);\r\n TJvTVCascadeOptions = set of TJvTVCascadeOption;\r\n\r\n TJvTreeViewCheckBoxOptions = class(TPersistent)\r\n private\r\n FTreeView: TJvTreeView;\r\n FImageIndices: array[0..3] of Integer;\r\n FStyle: TJvTVCheckBoxStyle;\r\n FCascadeLevels: Integer;\r\n FCascadeOptions: TJvTVCascadeOptions;\r\n function GetImageIndex(const Index: Integer): Integer;\r\n procedure SetImageIndex(const Index, Value: Integer);\r\n procedure ChangeImage(OldIndex, NewIndex: Integer);\r\n procedure SetStyle(const Value: TJvTVCheckBoxStyle);\r\n public\r\n procedure Assign(Source: TPersistent); override;\r\n constructor Create;\r\n property TreeView: TJvTreeView read FTreeView;\r\n published\r\n // Style determines what type of checkboxes/radioitems are displayed in the treeview. Style can have one of the following values:\r\n // cbsNone - no checkboxes or radiobuttons are displayed. Works like a normal treeview\r\n // cbsNative - use MS implementation of checkboxes. With this option you can only display\r\n // checkboxes and not radioitems. You can't set up your own images using the StateImages/StateIndex properties\r\n // of the treeview since this is overriden by the MS implementation\r\n // cbsJVCL - use the custom JVCL style. With this option you can display any type of images\r\n // by setting up your own StateImages ImageList and change the index properties below\r\n // (see CheckBoxUncheckedIndex etc)\r\n property Style: TJvTVCheckBoxStyle read FStyle write SetStyle;\r\n // CascadeLevels controls how many levels down a check or uncheck of a checkbox is propagated\r\n // If CascadeLevels is -1, checks and unchecks are cascaded to all children recursively regardless of depth.\r\n // If CascadeLevels is 0 (the default), no propagation takes place. If CascadeLevels > 0, the check/uncheck is\r\n // propagated that number of levels (i.e if CascadeLevels = 2, checks will propagate 2 levels below\r\n // the currently selected node)\r\n // Note that this only works if Style = cbsJVCL!\r\n property CascadeLevels: Integer read FCascadeLevels write FCascadeLevels default 0;\r\n // CascadeOptions determines how propagation of checks/unchecks are performed. CascadeOptions is a\r\n // set that can contain a combination of the following values:\r\n // cbOnCheck - the checkbox state is propagated when the node is checked\r\n // cbOnUnCheck - the checkbox state is propagated when the node is unchecked\r\n // If both values are set, the checkbox state is always propagated (unless CascadeLevels = 0, of course)\r\n // Setting this property to an empty set is equivalent to setting CascadeLevels := 0, i.e no propagation\r\n property CascadeOptions: TJvTVCascadeOptions read FCascadeOptions write FCascadeOptions\r\n default [poOnCheck, poOnUnCheck];\r\n\r\n // Use the properties below in combination with an imagelist assigned to the\r\n // Treeviews StateImages property to control what images are displayed for the various checkbox and radioitems states\r\n // The actual images used are of no significance. Rather, it is the index of the property that controls what happens when a node is\r\n // checked or unchecked: if the node has its StateIndex set to CheckBoxUncheckedIndex or CheckBoxCheckedIndex, it will be treated as\r\n // a checkbox, if the node has its StateIndex set to RadioUncheckedIndex or RadioCheckedIndex, it will be treated as a radioitem\r\n // Checkboxes are toggled on and off, possibly with propagation\r\n // RadioItems are only toggled on when \"checked\" and there is no propagation but all other radioitems on the same level will\r\n // automatically be toggled off. Note that if you don't set a specific radioitem on a level as checked, they will all be unhecked\r\n // until the user checks one of them\r\n // NB! the first used index in a StateImages imagelist is 1, not 0! The 0'th item is ignored by the underlying treeview, so\r\n // you will have to assign a dummy image as the first to make the imagelist work for you\r\n\r\n // CheckBoxUncheckedIndex is the index for the image in StateImages used for the unchecked checkbox state\r\n property CheckBoxUncheckedIndex: Integer index 0 read GetImageIndex write SetImageIndex default 1;\r\n // CheckBoxCheckedIndex is the index for the image in StateImages used for the checked checkbox state\r\n property CheckBoxCheckedIndex: Integer index 1 read GetImageIndex write SetImageIndex default 2;\r\n // RadioUncheckedIndex is the index for the image in StateImages used for the unchecked radioitem state\r\n property RadioUncheckedIndex: Integer index 2 read GetImageIndex write SetImageIndex default 3;\r\n // RadioCheckedIndex is the index for the image in StateImages used for the checked radioitem state\r\n property RadioCheckedIndex: Integer index 3 read GetImageIndex write SetImageIndex default 4;\r\n end;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvCheckTreeView = class(TJvTreeView)\r\n private\r\n FCheckBoxOptions: TJvTreeViewCheckBoxOptions;\r\n FOnToggled: TTVChangedEvent;\r\n FOnToggling: TTVChangingEvent;\r\n FNextItemRect: TRect;\r\n\r\n function GetCheckBox(Node: TTreeNode): Boolean;\r\n function GetChecked(Node: TTreeNode): Boolean;\r\n function GetRadioItem(Node: TTreeNode): Boolean;\r\n procedure SetCheckBox(Node: TTreeNode; const Value: Boolean);\r\n procedure SetChecked(Node: TTreeNode; const Value: Boolean);\r\n procedure SetRadioItem(Node: TTreeNode; const Value: Boolean);\r\n procedure SetCheckBoxOptions(const Value: TJvTreeViewCheckBoxOptions);\r\n procedure InternalSetChecked(Node: TTreeNode; const Value: Boolean; Levels: Integer);\r\n protected\r\n procedure TreeNodeCheckedChange(Sender: TObject); override;\r\n function ToggleNode(Node: TTreeNode) : Boolean; virtual;\r\n procedure Click; override;\r\n procedure KeyDown(var Key: Word; Shift: TShiftState); override;\r\n procedure DoToggled(Node: TTreeNode); dynamic;\r\n function DoToggling(Node: TTreeNode): Boolean; dynamic;\r\n function CreateNode: TTreeNode; override;\r\n procedure SetCheckBoxes(const Value: Boolean); override;\r\n\r\n procedure CNNotify(var Msg: TWMNotify); message CN_NOTIFY;\r\n procedure WMLButtonDown(var Message: TWMLButtonDown); message WM_LBUTTONDOWN;\r\n function GetCheckedFromState(Node: TTreeNode): Boolean; override;\r\n procedure SetCheckedInState(Node: TTreeNode; Value: Boolean); override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n\r\n // get / set whether Node is checked\r\n property Checked[Node: TTreeNode]: Boolean read GetChecked write SetChecked;\r\n // get / set whether Node is a checkbox\r\n property CheckBox[Node: TTreeNode]: Boolean read GetCheckBox write SetCheckBox;\r\n // get / set whether Node is a radioitem\r\n property RadioItem[Node: TTreeNode]: Boolean read GetRadioItem write SetRadioItem;\r\n published\r\n // CheckBoxOptions controls the behavior of the checbox/radioitems in the treeview\r\n property CheckBoxOptions: TJvTreeViewCheckBoxOptions read FCheckBoxOptions write SetCheckBoxOptions;\r\n // called just before a node is to be toggled\r\n // NB! If you have activated propagation, this event will be called for *all* nodes affected by the propagation\r\n property OnToggling: TTVChangingEvent read FOnToggling write FOnToggling;\r\n // called just after a node has been toggled\r\n // NB! If you have activated propagation, this event will be called for *all* nodes affected by the propagation\r\n property OnToggled: TTVChangedEvent read FOnToggled write FOnToggled;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvCheckTreeView.pas $';\r\n Revision: '$Revision: 13227 $';\r\n Date: '$Date: 2012-02-24 16:22:50 +0100 (ven. 24 févr. 2012) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n CommCtrl, SysUtils, Types,\r\n JvConsts;\r\n\r\nprocedure ToggleTreeViewCheckBoxes(Node: TTreeNode;\r\n AUnChecked, AChecked, ARadioUnchecked, ARadioChecked: Integer);\r\nvar\r\n Tmp: TTreeNode;\r\nbegin\r\n if Assigned(Node) then\r\n begin\r\n if Node.StateIndex = -1 then\r\n Node.StateIndex := AUnchecked;\r\n\r\n if Node.StateIndex = AUnChecked then\r\n begin\r\n Node.StateIndex := AChecked;\r\n (Node as TJvTreeNode).Checked := True;\r\n end\r\n else\r\n if Node.StateIndex = AChecked then\r\n begin\r\n Node.StateIndex := AUnChecked;\r\n (Node as TJvTreeNode).Checked := False;\r\n end\r\n else\r\n if Node.StateIndex = ARadioUnchecked then\r\n begin\r\n Tmp := Node.Parent;\r\n if not Assigned(Tmp) then\r\n Tmp := TTreeView(Node.TreeView).Items.GetFirstNode\r\n else\r\n Tmp := Tmp.getFirstChild;\r\n while Assigned(Tmp) do\r\n begin\r\n if Tmp.StateIndex in [ARadioUnchecked, ARadioChecked] then\r\n Tmp.StateIndex := ARadioUnchecked;\r\n Tmp := Tmp.getNextSibling;\r\n end;\r\n Node.StateIndex := ARadioChecked;\r\n (Node as TJvTreeNode).Checked := True;\r\n end;\r\n end;\r\nend;\r\n\r\n//=== { TJvTreeViewCheckBoxOptions } =========================================\r\n\r\nconstructor TJvTreeViewCheckBoxOptions.Create;\r\nvar\r\n I: Integer;\r\nbegin\r\n inherited Create;\r\n for I := Low(FImageIndices) to High(FImageIndices) do\r\n FImageIndices[I] := I+1;\r\n FCascadeLevels := 0;\r\n FCascadeOptions := [poOnCheck, poOnUnCheck]\r\nend;\r\n\r\nprocedure TJvTreeViewCheckBoxOptions.Assign(Source: TPersistent);\r\nbegin\r\n if (Source <> Self) and (Source is TJvTreeViewCheckBoxOptions) then\r\n begin\r\n Style := TJvTreeViewCheckBoxOptions(Source).Style;\r\n CascadeLevels := TJvTreeViewCheckBoxOptions(Source).CascadeLevels;\r\n CascadeOptions := TJvTreeViewCheckBoxOptions(Source).CascadeOptions;\r\n CheckBoxUncheckedIndex := TJvTreeViewCheckBoxOptions(Source).CheckBoxUncheckedIndex;\r\n CheckBoxCheckedIndex := TJvTreeViewCheckBoxOptions(Source).CheckBoxCheckedIndex;\r\n RadioUncheckedIndex := TJvTreeViewCheckBoxOptions(Source).RadioUncheckedIndex;\r\n RadioCheckedIndex := TJvTreeViewCheckBoxOptions(Source).RadioCheckedIndex;\r\n end\r\n else\r\n inherited Assign(Source);\r\nend;\r\n\r\nprocedure TJvTreeViewCheckBoxOptions.ChangeImage(OldIndex, NewIndex: Integer);\r\nvar\r\n N: TTreeNode;\r\nbegin\r\n if Assigned(FTreeView) then\r\n begin\r\n FTreeView.Items.BeginUpdate;\r\n try\r\n N := FTreeView.Items.GetFirstNode;\r\n while Assigned(N) do\r\n begin\r\n if N.StateIndex = OldIndex then\r\n N.StateIndex := NewIndex;\r\n N := N.GetNext;\r\n end;\r\n finally\r\n FTreeView.Items.EndUpdate;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJvTreeViewCheckBoxOptions.GetImageIndex(const Index: Integer): Integer;\r\nbegin\r\n if (Index >= 0) and (Index <= High(FImageIndices)) then\r\n Result := FImageIndices[Index]\r\n else\r\n Result := 0;\r\nend;\r\n\r\nprocedure TJvTreeViewCheckBoxOptions.SetImageIndex(const Index, Value: Integer);\r\nbegin\r\n if (Index >= 0) and (Index <= High(FImageIndices)) and (FImageIndices[Index] <> Value) then\r\n begin\r\n ChangeImage(FImageIndices[Index], Value);\r\n FImageIndices[Index] := Value;\r\n end;\r\nend;\r\n\r\nprocedure TJvTreeViewCheckBoxOptions.SetStyle(const Value: TJvTVCheckBoxStyle);\r\nbegin\r\n if FStyle <> Value then\r\n begin\r\n FStyle := Value;\r\n FTreeView.Checkboxes := FStyle <> cbsNone;\r\n end;\r\nend;\r\n\r\n//=== { TJvCheckTreeView } ===================================================\r\n\r\nprocedure TJvCheckTreeView.CNNotify(var Msg: TWMNotify);\r\nvar\r\n pnmtvA: PNMTREEVIEWA;\r\n pnmtvW: PNMTREEVIEWW;\r\nbegin\r\n inherited;\r\n\r\n case Msg.NMHdr.code of\r\n TVN_SELCHANGINGA:\r\n begin\r\n pnmtvA := PNMTREEVIEWA(Msg.NMHdr);\r\n TreeView_GetItemRect(Handle, pnmtvA.itemNew.hItem, FNextItemRect, False);\r\n end;\r\n TVN_SELCHANGINGW:\r\n begin\r\n pnmtvW := PNMTREEVIEWW(Msg.NMHdr);\r\n TreeView_GetItemRect(Handle, pnmtvW.itemNew.hItem, FNextItemRect, False);\r\n end;\r\n end;\r\nend;\r\n\r\nconstructor TJvCheckTreeView.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FCheckBoxOptions := TJvTreeViewCheckBoxOptions.Create;\r\n FCheckBoxOptions.FTreeView := Self;\r\nend;\r\n\r\nfunction TJvCheckTreeView.CreateNode: TTreeNode;\r\nbegin\r\n Result := inherited CreateNode;\r\n if CheckBoxes and (CheckBoxOptions.Style = cbsJVCL) then\r\n Result.StateIndex := CheckBoxOptions.CheckBoxUncheckedIndex;\r\nend;\r\n\r\ndestructor TJvCheckTreeView.Destroy;\r\nbegin\r\n FCheckBoxOptions.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvCheckTreeView.Click;\r\nvar\r\n P: TPoint;\r\n ItemHandle: HTREEITEM;\r\n ItemRect: TRect;\r\nbegin\r\n if (CheckBoxOptions.Style = cbsJVCL) and (csClicked in ControlState) then\r\n begin\r\n GetCursorPos(P);\r\n P := ScreenToClient(P);\r\n\r\n // Mantis 4316: An almost out of view item might have been moved when its\r\n // checkbox has been clicked. When this code executes, the item has already\r\n // been moved and as such the cursor is outside of it. But when the\r\n // selection was about to be changed, we stored the position of the item\r\n // at that time, and with this we can adjust the cursor position. This way\r\n // the adjusted position lies within the cursor mark and GetHitTestInfoAt\r\n // returns the expected value to trigger InternalSetChecked\r\n ItemHandle := TreeView_GetSelection(Handle);\r\n TreeView_GetItemRect(Handle, ItemHandle, ItemRect, False);\r\n\r\n P.X := P.X - (FNextItemRect.Left - ItemRect.Left);\r\n P.Y := P.Y - (FNextItemRect.Top - ItemRect.Top);\r\n\r\n if htOnStateIcon in GetHitTestInfoAt(P.X, P.Y) then\r\n InternalSetChecked(Selected, not Checked[Selected], CheckBoxOptions.CascadeLevels);\r\n end;\r\n inherited Click;\r\nend;\r\n\r\nprocedure TJvCheckTreeView.DoToggled(Node: TTreeNode);\r\nbegin\r\n if Assigned(FOnToggled) then\r\n FOnToggled(Self, Node);\r\nend;\r\n\r\nfunction TJvCheckTreeView.DoToggling(Node: TTreeNode): Boolean;\r\nbegin\r\n Result := True;\r\n if Assigned(FOnToggling) then\r\n FOnToggling(Self, Node, Result);\r\nend;\r\n\r\nfunction TJvCheckTreeView.GetCheckBox(Node: TTreeNode): Boolean;\r\nbegin\r\n with CheckBoxOptions do\r\n Result := (Node <> nil) and (Node.StateIndex in [CheckBoxUncheckedIndex, CheckBoxCheckedIndex]);\r\nend;\r\n\r\nfunction TJvCheckTreeView.GetChecked(Node: TTreeNode): Boolean;\r\nbegin\r\n with CheckBoxOptions do\r\n if Style = cbsJVCL then\r\n Result := (Node <> nil) and (Node.StateIndex in [RadioCheckedIndex, CheckBoxCheckedIndex])\r\n else\r\n Result := inherited Checked[Node];\r\nend;\r\n\r\nfunction TJvCheckTreeView.GetCheckedFromState(Node: TTreeNode): Boolean;\r\nvar\r\n Item: TTVItem;\r\nbegin\r\n with Item do\r\n begin\r\n mask := TVIF_STATE;\r\n hItem := Node.ItemId;\r\n if TreeView_GetItem(Handle, Item) then\r\n Result := (((Item.State and TVIS_STATEIMAGEMASK) or TVIS_CHECKED) = TVIS_CHECKED) or\r\n (((Item.State and TVIS_STATEIMAGEMASK) or TVIS_CHECKED shl 1) = TVIS_CHECKED shl 1)\r\n else\r\n Result := False;\r\n end;\r\nend;\r\n\r\nfunction TJvCheckTreeView.GetRadioItem(Node: TTreeNode): Boolean;\r\nbegin\r\n with CheckBoxOptions do\r\n Result := (Node <> nil) and (Node.StateIndex in [RadioCheckedIndex, RadioUncheckedIndex]);\r\nend;\r\n\r\nprocedure TJvCheckTreeView.KeyDown(var Key: Word; Shift: TShiftState);\r\nbegin\r\n inherited KeyDown(Key, Shift);\r\n if (CheckBoxOptions.Style = cbsJVCL) and Assigned(Selected) and\r\n (Key = VK_SPACE) and (Shift * KeyboardShiftStates = []) then\r\n begin\r\n InternalSetChecked(Selected, not Checked[Selected], CheckBoxOptions.CascadeLevels);\r\n Key := 0; // Otherwise the checkmark will be toggled back\r\n end;\r\nend;\r\n\r\nprocedure TJvCheckTreeView.SetCheckBox(Node: TTreeNode; const Value: Boolean);\r\nbegin\r\n with CheckBoxOptions do\r\n if (Node <> nil) and (Style = cbsJVCL) then\r\n if Value then\r\n begin\r\n if Checked[Node] then\r\n Node.StateIndex := CheckBoxCheckedIndex\r\n else\r\n Node.StateIndex := CheckBoxUncheckedIndex;\r\n end\r\n else\r\n Node.StateIndex := 0;\r\nend;\r\n\r\nprocedure TJvCheckTreeView.SetCheckBoxes(const Value: Boolean);\r\nvar\r\n I: Integer;\r\nbegin\r\n inherited SetCheckBoxes(Value);\r\n\r\n if CheckBoxes then\r\n begin\r\n // When dealing with checkboxes, the StateIndex is used to represent\r\n // what an item is (radio/checkbox) and its state. If left to -1, this\r\n // will prevent the rest of the code here from working properly.\r\n // Hence we take steps to ensure that every item with a state at -1 is\r\n // an unchecked checkbox\r\n for I := 0 to Items.Count - 1 do\r\n begin\r\n if Items[I].StateIndex = -1 then\r\n Items[I].StateIndex := CheckBoxOptions.CheckBoxUncheckedIndex;\r\n end;\r\n end\r\n else\r\n CheckBoxOptions.Style := cbsNone;\r\nend;\r\n\r\nprocedure TJvCheckTreeView.SetCheckBoxOptions(const Value: TJvTreeViewCheckBoxOptions);\r\nbegin\r\n FCheckBoxOptions.Assign(Value);\r\nend;\r\n\r\nprocedure TJvCheckTreeView.InternalSetChecked(Node: TTreeNode; const Value: Boolean; Levels: Integer);\r\nvar\r\n Tmp: TTreeNode;\r\n Toggled: Boolean;\r\nbegin\r\n Toggled := False;\r\n if Checked[Node] <> Value then\r\n Toggled := ToggleNode(Node);\r\n // Only cascade if the node has been toggled.\r\n if Toggled and (Levels <> 0) and CheckBox[Node] and\r\n ((Value and (poOnCheck in CheckBoxOptions.CascadeOptions)) or\r\n (not Value and (poOnUnCheck in CheckBoxOptions.CascadeOptions))) then\r\n begin\r\n Tmp := Node.getFirstChild;\r\n while Tmp <> nil do\r\n begin\r\n if CheckBox[Tmp] then\r\n InternalSetChecked(Tmp, Value, Levels - Ord(Levels > 0));\r\n Tmp := Tmp.getNextSibling;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvCheckTreeView.SetChecked(Node: TTreeNode; const Value: Boolean);\r\nbegin\r\n // Mantis 3608: We call inherited to be sure that the visual state is\r\n // updated according to the correct value.\r\n // Then if the style is JVCL, we work internally to update the StateIndex\r\n // of the node that is being modified.\r\n inherited Checked[Node] := Value;\r\n\r\n if CheckBoxOptions.Style = cbsJVCL then\r\n InternalSetChecked(Node, Value, CheckBoxOptions.CascadeLevels)\r\nend;\r\n\r\nprocedure TJvCheckTreeView.SetCheckedInState(Node: TTreeNode; Value: Boolean);\r\nvar\r\n Item: TTVItem;\r\nbegin\r\n FillChar(Item, SizeOf(Item), 0);\r\n with Item do\r\n begin\r\n hItem := Node.ItemId;\r\n mask := TVIF_STATE;\r\n StateMask := TVIS_STATEIMAGEMASK;\r\n TreeView_GetItem(Handle, Item);\r\n if Value then\r\n Item.State := Item.State + TVIS_CHECKED\r\n else\r\n Item.State := Item.State - TVIS_CHECKED;\r\n TreeView_SetItem(Handle, Item);\r\n end;\r\nend;\r\n\r\nprocedure TJvCheckTreeView.SetRadioItem(Node: TTreeNode; const Value: Boolean);\r\nvar\r\n B: Boolean;\r\nbegin\r\n with CheckBoxOptions do\r\n if (Node <> nil) and (Style = cbsJVCL) then\r\n begin\r\n if Value then\r\n begin\r\n B := Checked[Node];\r\n Node.StateIndex := RadioUncheckedIndex;\r\n // make sure to toggle the others on or off\r\n if B then\r\n ToggleNode(Node);\r\n end\r\n else\r\n Node.StateIndex := 0;\r\n end;\r\nend;\r\n\r\nfunction TJvCheckTreeView.ToggleNode(Node: TTreeNode) : Boolean;\r\nbegin\r\n Result := False;\r\n if DoToggling(Node) then\r\n begin\r\n with CheckBoxOptions do\r\n ToggleTreeViewCheckBoxes(Node,\r\n CheckBoxUncheckedIndex, CheckBoxCheckedIndex, RadioUncheckedIndex, RadioCheckedIndex);\r\n DoToggled(Node);\r\n Result := True;\r\n end;\r\nend;\r\n\r\nprocedure TJvCheckTreeView.TreeNodeCheckedChange(Sender: TObject);\r\nvar\r\n Node: TJvTreeNode;\r\nbegin\r\n inherited TreeNodeCheckedChange(Sender);\r\n\r\n if CheckBoxOptions.Style = cbsJVCL then\r\n begin\r\n Node := Sender as TJvTreeNode;\r\n InternalSetChecked(Node, Node.Checked, CheckBoxOptions.CascadeLevels)\r\n end;\r\nend;\r\n\r\nprocedure TJvCheckTreeView.WMLButtonDown(var Message: TWMLButtonDown);\r\nvar\r\n Node: TTreeNode;\r\n Item: TTVItem;\r\nbegin\r\n inherited;\r\n\r\n // Mantis 5629\r\n // For some reason yet to be fully understood, the VCL (or maybe the underlying windows API)\r\n // changes the Item.state value back to a value valid for checkboxes and not for\r\n // radio buttons if one continues to click on a radio button if it is already checked.\r\n // To fix this, we inspect the node under the mouse and if it's a radio item\r\n // that has its state image outside of the valid values, we restore the valid value.\r\n // This is not the most beautiful code in the world, but until someone understands\r\n // the root cause of this, this will suffice.\r\n //\r\n // --> Clues for someone willing to look:\r\n // The change happens when the inherited handler exists of the WM_NOTIFY management code\r\n // in TWinControl.MainWndProc. During the whole execution of that procedure, the\r\n // item.state value is valid, and as soon as one exits and comes back here, it is changed\r\n // Must be that a message is waiting to be processed and it gets so by calling any\r\n // TreeView function, but it's nearly impossible to track as it does not get passed\r\n // to us if we setup a TVM_GETITEM message handler... \r\n Node := GetNodeAt(Message.XPos, Message.YPos);\r\n if RadioItem[Node] then\r\n begin\r\n Item.hItem := Node.ItemId;\r\n Item.mask := TVIF_STATE;\r\n Item.StateMask := TVIS_STATEIMAGEMASK;\r\n TreeView_GetItem(Handle, Item);\r\n\r\n if ((Item.State and TVIS_STATEIMAGEMASK) <> Cardinal(IndexToStateImageMask(CheckBoxOptions.RadioUncheckedIndex))) and\r\n ((Item.State and TVIS_STATEIMAGEMASK) <> Cardinal(IndexToStateImageMask(CheckBoxOptions.RadioCheckedIndex))) then\r\n begin\r\n Item.mask := TVIF_STATE or TVIF_HANDLE;\r\n Item.stateMask := TVIS_STATEIMAGEMASK;\r\n Item.hItem := Node.ItemId;\r\n Item.state := IndexToStateImageMask(Node.StateIndex);\r\n TreeView_SetItem(Handle, Item);\r\n end;\r\n end;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvCheckedMaskEdit.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvCheckedMaskEdit, released on 2002-10-04.\r\n\r\nThe Initial Developer of the Original Code is Oliver Giesen [giesen att lucatec dott com]\r\nPortions created by Oliver Giesen are Copyright (C) 2002 Lucatec GmbH.\r\nAll Rights Reserved.\r\n\r\nContributor(s): ______________________________________.\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nDescription:\r\n A simple TCustomMaskEdit descendant with an optional checkbox control in front\r\n of the text area.\r\n\r\nKnown Issues:\r\n - BiDi support (checkbox should probably be on the right for RTL)\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvCheckedMaskEdit.pas 13104 2011-09-07 06:50:43Z obones $\r\n\r\nunit JvCheckedMaskEdit;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, Messages, Classes, Controls, StdCtrls, Types,\r\n JvMaskEdit;\r\n\r\ntype\r\n TJvCustomCheckedMaskEdit = class(TJvCustomMaskEdit)\r\n private\r\n FCheck: TCheckBox;\r\n { (rb) JvBaseEdits.pas name: FFormatting }\r\n FInternalChange: Boolean;\r\n FOnCheckClick: TNotifyEvent;\r\n procedure CheckClick(Sender: TObject);\r\n function GetShowCheckBox: Boolean;\r\n protected\r\n procedure DoCheckClick; dynamic;\r\n procedure DoKillFocus(const ANextControl: TWinControl); override;\r\n procedure EnabledChanged; override;\r\n\r\n function GetChecked: Boolean; virtual;\r\n procedure SetChecked(const AValue: Boolean); virtual;\r\n procedure SetShowCheckbox(const AValue: Boolean); virtual;\r\n\r\n procedure GetInternalMargins(var ALeft, ARight: Integer); override;\r\n\r\n procedure UpdateControls; override;\r\n procedure WMNCHitTest(var Msg: TWMNCHitTest); message WM_NCHITTEST;\r\n procedure Change; override;\r\n procedure BeginInternalChange;\r\n procedure EndInternalChange;\r\n function InternalChanging: Boolean;\r\n protected\r\n property AutoSize default False;\r\n property Checked: Boolean read GetChecked write SetChecked;\r\n property ShowCheckBox: Boolean read GetShowCheckBox write SetShowCheckbox default False;\r\n property OnCheckClick: TNotifyEvent read FOnCheckClick write FOnCheckClick;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n end;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvCheckedMaskEdit = class(TJvCustomCheckedMaskEdit)\r\n published\r\n property Action;\r\n property Align;\r\n property Anchors;\r\n property AutoSelect;\r\n property AutoSize;\r\n property BevelEdges;\r\n property BevelInner;\r\n property BevelKind default bkNone;\r\n property BevelOuter;\r\n property BorderStyle;\r\n property ButtonFlat;\r\n property ButtonHint;\r\n property ButtonWidth;\r\n property CharCase;\r\n property Checked;\r\n property ClipboardCommands;\r\n property ClickKey;\r\n property Color;\r\n property Constraints;\r\n property DisabledColor;\r\n property DisabledTextColor;\r\n property GroupIndex;\r\n {property BiDiMode;}\r\n property Caret;\r\n property DragCursor;\r\n property DragKind;\r\n property Flat;\r\n property HotTrack;\r\n property ImeMode;\r\n property ImeName;\r\n property OEMConvert;\r\n {property ParentBiDiMode;}\r\n property ParentFlat;\r\n property PasswordChar;\r\n property ProtectPassword;\r\n property OnKillFocus;\r\n property OnSetFocus;\r\n property OnEndDock;\r\n property OnStartDock;\r\n property DirectInput;\r\n property DragMode;\r\n property EditMask;\r\n property Enabled;\r\n property Font;\r\n property Glyph;\r\n property HideSelection;\r\n property HintColor;\r\n property ImageIndex;\r\n property ImageKind;\r\n property Images;\r\n property MaxLength;\r\n property NumGlyphs;\r\n property ParentColor;\r\n property ParentFont;\r\n property ParentShowHint;\r\n property PopupMenu;\r\n property ReadOnly;\r\n property ShowHint;\r\n property ShowCheckBox;\r\n property Text;\r\n property TabOrder;\r\n {property TabStop;} { (rb) Why disabled?}\r\n property Visible;\r\n property OnButtonClick;\r\n property OnChange;\r\n property OnClick;\r\n property OnCheckClick;\r\n property OnContextPopup;\r\n property OnDblClick;\r\n property OnDragDrop;\r\n property OnDragOver;\r\n property OnEnabledChanged;\r\n property OnEndDrag;\r\n property OnEnter;\r\n property OnExit;\r\n property OnKeyDown;\r\n property OnKeyPress;\r\n property OnKeyUp;\r\n property OnMouseDown;\r\n property OnMouseEnter;\r\n property OnMouseLeave;\r\n property OnMouseMove;\r\n property OnMouseUp;\r\n property OnParentColorChange;\r\n property OnStartDrag;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvCheckedMaskEdit.pas $';\r\n Revision: '$Revision: 13104 $';\r\n Date: '$Date: 2011-09-07 08:50:43 +0200 (mer. 07 sept. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n SysUtils, Forms,\r\n JvTypes, JvResources, JvThemes;\r\n\r\n//=== { TJvCustomCheckedMaskEdit } ===========================================\r\n\r\n{Begin/EndInternalChange and InternalChanging implement a simple locking\r\n mechanism to prevent change processing and display updates during internal\r\n operations. If descendants require nested calls to Begin/EndInternalChange they\r\n should override these methods to implement a better suited mechanism,\r\n e.g. a lock counter.}\r\n\r\nprocedure TJvCustomCheckedMaskEdit.BeginInternalChange;\r\nbegin\r\n if FInternalChange then\r\n raise EJVCLException.CreateRes(@RsEBeginUnsupportedNestedCall);\r\n FInternalChange := True;\r\nend;\r\n\r\nprocedure TJvCustomCheckedMaskEdit.Change;\r\nbegin\r\n {Overridden to suppress change handling during internal operations. If\r\n descendants override Change again it is their responsibility to repeat the\r\n check for InternalChanging.}\r\n if not InternalChanging then\r\n inherited Change;\r\nend;\r\n\r\nprocedure TJvCustomCheckedMaskEdit.CheckClick(Sender: TObject);\r\nbegin\r\n // call SetChecked to allow descendants to validate the new value:\r\n Checked := FCheck.Checked;\r\n DoCheckClick;\r\nend;\r\n\r\n{ TODO -oahuser -cCLX : Isn't that also something for VCL? }\r\n\r\n\r\nconstructor TJvCustomCheckedMaskEdit.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FCheck := nil;\r\n FInternalChange := False;\r\n\r\n AutoSize := False;\r\n Height := 21;\r\n { (rb) ?? }\r\n TabStop := True;\r\nend;\r\n\r\ndestructor TJvCustomCheckedMaskEdit.Destroy;\r\nbegin\r\n if ShowCheckBox then\r\n FCheck.OnClick := nil;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvCustomCheckedMaskEdit.DoCheckClick;\r\nbegin\r\n if Assigned(FOnCheckClick) then\r\n FOnCheckClick(Self);\r\nend;\r\n\r\nprocedure TJvCustomCheckedMaskEdit.DoKillFocus(const ANextControl: TWinControl);\r\nbegin\r\n if ANextControl <> FCheck then\r\n inherited DoKillFocus(ANextControl);\r\nend;\r\n\r\nprocedure TJvCustomCheckedMaskEdit.EnabledChanged;\r\nbegin\r\n { propagate to child controls: }\r\n if ShowCheckBox then\r\n FCheck.Enabled := Self.Enabled;\r\n inherited EnabledChanged;\r\nend;\r\n\r\nprocedure TJvCustomCheckedMaskEdit.EndInternalChange;\r\nbegin\r\n { TODO : if this assertion ever fails, it's time to switch to a counted locking scheme }\r\n if not FInternalChange then\r\n raise EJVCLException.CreateRes(@RsEEndUnsupportedNestedCall);\r\n FInternalChange := False;\r\nend;\r\n\r\nfunction TJvCustomCheckedMaskEdit.GetChecked: Boolean;\r\nbegin\r\n if ShowCheckBox then\r\n Result := FCheck.Checked\r\n else\r\n Result := False; // should this really be the default?\r\nend;\r\n\r\nprocedure TJvCustomCheckedMaskEdit.GetInternalMargins( var ALeft, ARight: Integer);\r\nbegin\r\n {This gets called by UpdateMargins and should be overridden by descendants\r\n that add additional child controls.}\r\n\r\n inherited GetInternalMargins(ALeft, ARight);\r\n\r\n if ShowCheckBox then\r\n begin\r\n ALeft := FCheck.Left + FCheck.Width;\r\n // ensure the text starts 2 points from the checkbox edge\r\n {$IFDEF JVCLThemesEnabled}\r\n if ThemeServices.{$IFDEF RTL230_UP}Enabled{$ELSE}ThemesEnabled{$ENDIF RTL230_UP} then\r\n ALeft := ALeft + 1;\r\n {$ENDIF JVCLThemesEnabled}\r\n if BorderStyle = bsNone then\r\n ALeft := ALeft + 1\r\n else\r\n if not Ctl3D then\r\n ALeft := ALeft - 1;\r\n end;\r\nend;\r\n\r\nfunction TJvCustomCheckedMaskEdit.GetShowCheckBox: Boolean;\r\nbegin\r\n Result := Assigned(FCheck);\r\nend;\r\n\r\nfunction TJvCustomCheckedMaskEdit.InternalChanging: Boolean;\r\nbegin\r\n Result := FInternalChange;\r\nend;\r\n\r\nprocedure TJvCustomCheckedMaskEdit.SetChecked(const AValue: Boolean);\r\nbegin\r\n if ShowCheckBox and (FCheck.Checked <> AValue) then\r\n begin\r\n FCheck.Checked := AValue;\r\n Change;\r\n end;\r\n {TODO : Maybe Checked should be accessible even without the checkbox.\r\n The value could be cached in a state field and applied when the\r\n checkbox is instantiated.}\r\nend;\r\n\r\nprocedure TJvCustomCheckedMaskEdit.SetShowCheckbox(const AValue: Boolean);\r\nbegin\r\n {The checkbox will only get instantiated when ShowCheckBox is set to True;\r\n setting it to false frees the checkbox.}\r\n if ShowCheckBox <> AValue then\r\n begin\r\n if AValue then\r\n begin\r\n FCheck := TCheckBox.Create(Self);\r\n FCheck.Parent := Self;\r\n // FCheck.Align := alLeft;\r\n if HotTrack then\r\n FCheck.Left := 1;\r\n FCheck.Top := 1;\r\n FCheck.Height := ClientHeight - 2;\r\n FCheck.Width := 15;\r\n FCheck.Anchors := [akLeft, akTop, akBottom];\r\n FCheck.Alignment := taLeftJustify;\r\n FCheck.TabStop := False;\r\n FCheck.OnClick := CheckClick;\r\n FCheck.Visible := True;\r\n FCheck.Enabled := Enabled;\r\n end\r\n else\r\n FreeAndNil(FCheck);\r\n\r\n UpdateControls;\r\n UpdateMargins;\r\n Repaint;\r\n end;\r\nend;\r\n\r\n\r\n\r\nprocedure TJvCustomCheckedMaskEdit.UpdateControls;\r\nbegin\r\n { delay until Loaded }\r\n if csLoading in ComponentState then\r\n Exit;\r\n\r\n inherited UpdateControls;\r\n\r\n { propagate to child controls: }\r\n if ShowCheckBox then\r\n begin\r\n FCheck.Ctl3D := Self.Ctl3D;\r\n\r\n { Adjust layout quirks:\r\n We want to place the checkbox 2 points from the edge\r\n\r\n BorderStyle\r\n bsNone bsSingle\r\n Ctl3d Yes: 0 0\r\n No : 0 1\r\n }\r\n if not Self.Ctl3D and (Self.BorderStyle = bsSingle) then\r\n FCheck.Left := 1\r\n else\r\n FCheck.Left := 0;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomCheckedMaskEdit.WMNCHitTest(var Msg: TWMNCHitTest);\r\nvar\r\n P: TPoint;\r\nbegin\r\n inherited;\r\n if (Msg.Result = HTCLIENT) and ShowCheckBox and not (csDesigning in ComponentState) then\r\n begin\r\n P := Point(FCheck.Left + FCheck.Width, FCheck.Top);\r\n Windows.ClientToScreen(FCheck.Handle, P);\r\n if Msg.XPos < P.X then\r\n Msg.Result := HTBORDER; {HTCAPTION;}\r\n end;\r\nend;\r\n\r\n\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend." }, { "path": "External/Jedi/Jvcl/run/JvCipher.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvCaesarCipher.PAS, JvXORCipher.PAS,\r\n JvVigenereCipher.PAS, released on 2001-02-28.\r\n\r\nThe Initial Developer of the Original Code is Sbastien Buysse [sbuysse att buypin dott com]\r\nPortions created by Sbastien Buysse are Copyright (C) 2001 Sbastien Buysse.\r\nAll Rights Reserved.\r\n\r\nContributor(s): Michael Beck [mbeck att bigfoot dott com].\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvCipher.pas 13104 2011-09-07 06:50:43Z obones $\r\n\r\nunit JvCipher;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Classes,\r\n JvComponentBase;\r\n\r\ntype\r\n // abstract base class for simple ciphers\r\n // which do not change the length of the data\r\n TJvCustomCipher = class(TJvComponent)\r\n private\r\n FEncoded: AnsiString;\r\n FKey: AnsiString;\r\n FIsStored: Boolean;\r\n function GetDecoded: AnsiString;\r\n procedure SetDecoded(const Value: AnsiString);\r\n function GetIsStored: Boolean;\r\n protected\r\n procedure Decode(const Key: AnsiString; Buf: PAnsiChar; Size: Cardinal); virtual; abstract;\r\n procedure Encode(const Key: AnsiString; Buf: PAnsiChar; Size: Cardinal); virtual; abstract;\r\n public\r\n { TODO -oahuser -cUnicode : Is there a TAnsStringList ? }\r\n procedure DecodeList(const Key: AnsiString; List: TStrings);\r\n procedure EncodeList(const Key: AnsiString; List: TStrings);\r\n procedure DecodeStream(const Key: AnsiString; Stream: TStream);\r\n procedure EncodeStream(const Key: AnsiString; Stream: TStream);\r\n procedure DecodeFile(const Key: AnsiString; const FileName: string);\r\n procedure EncodeFile(const Key: AnsiString; const FileName: string);\r\n function DecodeString(const Key: AnsiString; const Value: AnsiString): AnsiString;\r\n function EncodeString(const Key: AnsiString; const Value: AnsiString): AnsiString;\r\n constructor Create(AOwner: TComponent); override;\r\n published\r\n property Key: AnsiString read FKey write FKey stored GetIsStored;\r\n property Encoded: AnsiString read FEncoded write FEncoded stored GetIsStored;\r\n property Decoded: AnsiString read GetDecoded write SetDecoded stored False;\r\n property IsStored: Boolean read GetIsStored write FIsStored default True;\r\n end;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64 or pidOSX32)]\r\n {$ENDIF RTL230_UP}\r\n TJvCaesarCipher = class(TJvCustomCipher)\r\n public\r\n procedure Decode(const Key: AnsiString; Buf: PAnsiChar; Size: Cardinal); override;\r\n procedure Encode(const Key: AnsiString; Buf: PAnsiChar; Size: Cardinal); override;\r\n end;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64 or pidOSX32)]\r\n {$ENDIF RTL230_UP}\r\n TJvXORCipher = class(TJvCustomCipher)\r\n public\r\n procedure Decode(const Key: AnsiString; Buf: PAnsiChar; Size: Cardinal); override;\r\n procedure Encode(const Key: AnsiString; Buf: PAnsiChar; Size: Cardinal); override;\r\n end;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64 or pidOSX32)]\r\n {$ENDIF RTL230_UP}\r\n TJvVigenereCipher = class(TJvCustomCipher)\r\n private\r\n function Trans(Ch: AnsiChar; K: Byte): AnsiChar;\r\n public\r\n procedure Decode(const Key: AnsiString; Buf: PAnsiChar; Size: Cardinal); override;\r\n procedure Encode(const Key: AnsiString; Buf: PAnsiChar; Size: Cardinal); override;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvCipher.pas $';\r\n Revision: '$Revision: 13104 $';\r\n Date: '$Date: 2011-09-07 08:50:43 +0200 (mer. 07 sept. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n SysUtils;\r\n\r\n//=== { TJvCustomCipher } ====================================================\r\n\r\nconstructor TJvCustomCipher.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FIsStored := True;\r\nend;\r\n\r\nprocedure TJvCustomCipher.DecodeList(const Key: AnsiString; List: TStrings);\r\nvar\r\n I: Integer;\r\nbegin\r\n List.BeginUpdate;\r\n try\r\n for I := 0 to List.Count - 1 do\r\n if List[I] <> '' then\r\n Decode(Key, @(List[I])[1], Length(List[I]));\r\n finally\r\n List.EndUpdate;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomCipher.EncodeList(const Key: AnsiString; List: TStrings);\r\nvar\r\n I: Integer;\r\nbegin\r\n List.BeginUpdate;\r\n try\r\n for I := 0 to List.Count - 1 do\r\n if List[I] <> '' then\r\n Encode(Key, @(List[I])[1], Length(List[I]));\r\n finally\r\n List.EndUpdate;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomCipher.DecodeStream(const Key: AnsiString; Stream: TStream);\r\nvar\r\n MemStream: TMemoryStream;\r\n Count: Cardinal;\r\n Pos: Int64;\r\nbegin\r\n MemStream := TMemoryStream.Create;\r\n try\r\n Pos := Stream.Position;\r\n Count := Cardinal(Stream.Size - Pos);\r\n MemStream.SetSize(Count);\r\n if Count <> 0 then\r\n begin\r\n Stream.ReadBuffer(MemStream.Memory^, Count);\r\n Decode(Key, MemStream.Memory, Count);\r\n Stream.Position := Pos;\r\n Stream.WriteBuffer(MemStream.Memory^, Count);\r\n end;\r\n finally\r\n MemStream.Free;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomCipher.EncodeStream(const Key: AnsiString; Stream: TStream);\r\nvar\r\n MemStream: TMemoryStream;\r\n Count: Cardinal;\r\n Pos: Int64;\r\nbegin\r\n MemStream := TMemoryStream.Create;\r\n try\r\n Pos := Stream.Position;\r\n Count := Cardinal(Stream.Size - Pos);\r\n MemStream.SetSize(Count);\r\n if Count <> 0 then\r\n begin\r\n Stream.ReadBuffer(MemStream.Memory^, Count);\r\n Encode(Key, MemStream.Memory, Count);\r\n Stream.Position := Pos;\r\n Stream.WriteBuffer(MemStream.Memory^, Count);\r\n end;\r\n finally\r\n MemStream.Free;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomCipher.DecodeFile(const Key: AnsiString; const FileName: string);\r\nvar\r\n Stream: TFileStream;\r\nbegin\r\n Stream := TFileStream.Create(FileName, fmOpenReadWrite or fmShareExclusive);\r\n try\r\n DecodeStream(Key, Stream);\r\n finally\r\n Stream.Free;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomCipher.EncodeFile(const Key: AnsiString; const FileName: string);\r\nvar\r\n Stream: TFileStream;\r\nbegin\r\n Stream := TFileStream.Create(FileName, fmOpenReadWrite or fmShareExclusive);\r\n try\r\n EncodeStream(Key, Stream);\r\n finally\r\n Stream.Free;\r\n end;\r\nend;\r\n\r\nfunction TJvCustomCipher.GetDecoded: AnsiString;\r\nbegin\r\n Result := DecodeString(FKey, FEncoded);\r\nend;\r\n\r\nprocedure TJvCustomCipher.SetDecoded(const Value: AnsiString);\r\nbegin\r\n FEncoded := EncodeString(FKey, Value);\r\nend;\r\n\r\nfunction TJvCustomCipher.DecodeString(const Key, Value: AnsiString): AnsiString;\r\nvar\r\n Tmp: PAnsiChar;\r\nbegin\r\n GetMem(Tmp, Length(Value) + 1);\r\n try\r\n StrPCopy(Tmp, Value);\r\n Decode(Key, Tmp, Length(Value));\r\n SetString(Result, Tmp, Length(Value));\r\n finally\r\n FreeMem(Tmp);\r\n end;\r\nend;\r\n\r\nfunction TJvCustomCipher.EncodeString(const Key, Value: AnsiString): AnsiString;\r\nvar\r\n Tmp: PAnsiChar;\r\nbegin\r\n GetMem(Tmp, Length(Value) + 1);\r\n try\r\n StrPCopy(Tmp, Value);\r\n Encode(Key, Tmp, Length(Value));\r\n SetString(Result, Tmp, Length(Value));\r\n finally\r\n FreeMem(Tmp);\r\n end;\r\nend;\r\n\r\nfunction TJvCustomCipher.GetIsStored: Boolean;\r\nbegin\r\n Result := FIsStored;\r\nend;\r\n\r\n//=== { TJvCaesarCipher } ====================================================\r\n\r\nprocedure TJvCaesarCipher.Decode(const Key: AnsiString; Buf: PAnsiChar; Size: Cardinal);\r\nvar\r\n N: Integer;\r\n I: Cardinal;\r\nbegin\r\n if Size > 0 then\r\n begin\r\n N := StrToIntDef(string(Key), 13);\r\n if (N <= 0) or (N >= 256) then\r\n N := 13;\r\n for I := 0 to Size - 1 do\r\n Buf[I] := AnsiChar(Cardinal(Buf[I]) - Cardinal(N));\r\n end;\r\nend;\r\n\r\nprocedure TJvCaesarCipher.Encode(const Key: AnsiString; Buf: PAnsiChar; Size: Cardinal);\r\nvar\r\n N: Integer;\r\n I: Cardinal;\r\nbegin\r\n if Size > 0 then\r\n begin\r\n N := StrToIntDef(string(Key), 13);\r\n if (N <= 0) or (N >= 256) then\r\n N := 13;\r\n for I := 0 to Size - 1 do\r\n Buf[I] := AnsiChar(Cardinal(Buf[I]) + Cardinal(N));\r\n end;\r\nend;\r\n\r\n//=== { TJvXORCipher } =======================================================\r\n\r\nprocedure TJvXORCipher.Decode(const Key: AnsiString; Buf: PAnsiChar; Size: Cardinal);\r\nvar\r\n I: Cardinal;\r\n J: Cardinal;\r\nbegin\r\n if Key <> '' then\r\n begin\r\n J := 1;\r\n for I := 1 to Size do\r\n begin\r\n Buf[I-1] := AnsiChar(Ord(Buf[I-1]) xor Ord(Key[J]));\r\n J := (J mod Cardinal(Length(Key))) + 1;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvXORCipher.Encode(const Key: AnsiString; Buf: PAnsiChar; Size: Cardinal);\r\nbegin\r\n Decode(Key, Buf, Size);\r\nend;\r\n\r\n//=== { TJvVigenereCipher } ==================================================\r\n\r\nfunction TJvVigenereCipher.Trans(Ch: AnsiChar; K: Byte): AnsiChar;\r\nbegin\r\n Result := AnsiChar((256 + Ord(Ch) + K) mod 256);\r\nend;\r\n\r\nprocedure TJvVigenereCipher.Decode(const Key: AnsiString; Buf: PAnsiChar; Size: Cardinal);\r\nvar\r\n I: Cardinal;\r\n J: Cardinal;\r\nbegin\r\n if (Key <> '') and (Size > 0) then\r\n begin\r\n J := 1;\r\n for I := 0 to Size - 1 do\r\n begin\r\n Buf[I] := Trans(Buf[I], -Ord(Key[J]));\r\n J := (J mod Cardinal(Length(Key))) + 1;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvVigenereCipher.Encode(const Key: AnsiString; Buf: PAnsiChar; Size: Cardinal);\r\nvar\r\n I: Cardinal;\r\n J: Cardinal;\r\nbegin\r\n if (Key <> '') and (Size > 0) then\r\n begin\r\n J := 1;\r\n for I := 0 to Size - 1 do\r\n begin\r\n Buf[I] := Trans(Buf[I], Ord(Key[J]));\r\n J := (J mod Cardinal(Length(Key))) + 1;\r\n end;\r\n end;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvClipboardMonitor.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvClipMon.PAS, released on 2002-07-04.\r\n\r\nThe Initial Developers of the Original Code are: Fedor Koshevnikov, Igor Pavluk and Serge Korolev\r\nCopyright (c) 1997, 1998 Fedor Koshevnikov, Igor Pavluk and Serge Korolev\r\nCopyright (c) 2001,2002 SGB Software\r\nAll Rights Reserved.\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvClipboardMonitor.pas 13104 2011-09-07 06:50:43Z obones $\r\n\r\nunit JvClipboardMonitor;\r\n\r\n{$I jvcl.inc}\r\n{$I windowsonly.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, Messages,\r\n Clipbrd,\r\n Classes,\r\n JvComponentBase;\r\n\r\ntype\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvClipboardMonitor = class(TJvComponent)\r\n private\r\n FWindowHandle: THandle;\r\n FNextWindow: THandle;\r\n FEnabled: Boolean;\r\n FOnChange: TNotifyEvent;\r\n procedure ForwardMessage(var Msg: TMessage);\r\n procedure SetEnabled(Value: Boolean);\r\n procedure WndProc(var AMsg: TMessage);\r\n procedure ClipboardChanged;\r\n protected\r\n procedure Change; dynamic;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n published\r\n property Enabled: Boolean read FEnabled write SetEnabled default True;\r\n property OnChange: TNotifyEvent read FOnChange write FOnChange;\r\n end;\r\n\r\nprocedure SaveClipboardToStream(Format: Word; Stream: TStream);\r\nfunction LoadClipboardFromStream(Stream: TStream): Word;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvClipboardMonitor.pas $';\r\n Revision: '$Revision: 13104 $';\r\n Date: '$Date: 2011-09-07 08:50:43 +0200 (mer. 07 sept. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n Forms, JvJVCLUtils;\r\n\r\nprocedure SaveClipboardToStream(Format: Word; Stream: TStream);\r\nvar\r\n Buffer: Pointer;\r\n Data: THandle;\r\n Size: Longint;\r\nbegin\r\n Clipboard.Open;\r\n try\r\n Data := GetClipboardData(Format);\r\n if Data = 0 then\r\n Exit;\r\n Buffer := GlobalLock(Data);\r\n try\r\n // (rom) added handling of Format and Size!\r\n Size := GlobalSize(Data);\r\n Stream.Write(Format, SizeOf(Word));\r\n Stream.Write(Size, SizeOf(Longint));\r\n Stream.Write(Buffer^, Size);\r\n finally\r\n GlobalUnlock(Data);\r\n end;\r\n finally\r\n Clipboard.Close;\r\n end;\r\nend;\r\n\r\nfunction LoadClipboardFromStream(Stream: TStream): Word;\r\nvar\r\n Size: Longint;\r\n Buffer: Pointer;\r\n Data: THandle;\r\nbegin\r\n Result := 0;\r\n Clipboard.Open;\r\n try\r\n // (rom) added handling of Format and Size!\r\n if Stream.Read(Result, SizeOf(Word)) <> SizeOf(Word) then\r\n Exit;\r\n if Stream.Read(Size, SizeOf(Longint)) <> SizeOf(Longint) then\r\n Exit;\r\n Data := GlobalAlloc(HeapAllocFlags, Size);\r\n try\r\n if Data <> 0 then\r\n begin\r\n Buffer := GlobalLock(Data);\r\n try\r\n if Stream.Read(Buffer^, Size) <> Size then\r\n Exit;\r\n SetClipboardData(Result, Data);\r\n finally\r\n GlobalUnlock(Data);\r\n end;\r\n end;\r\n except\r\n GlobalFree(Data);\r\n raise;\r\n end;\r\n finally\r\n Clipboard.Close;\r\n end;\r\nend;\r\n\r\nconstructor TJvClipboardMonitor.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FWindowHandle := AllocateHWndEx(WndProc);\r\n Enabled := True;\r\nend;\r\n\r\ndestructor TJvClipboardMonitor.Destroy;\r\nbegin\r\n FOnChange := nil;\r\n Enabled := False;\r\n DeallocateHWndEx(FWindowHandle);\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvClipboardMonitor.ForwardMessage(var Msg: TMessage);\r\nbegin\r\n if FNextWindow <> 0 then\r\n with Msg do\r\n SendMessage(FNextWindow, Msg, WParam, LParam);\r\nend;\r\n\r\nprocedure TJvClipboardMonitor.WndProc(var AMsg: TMessage);\r\nbegin\r\n with AMsg do\r\n begin\r\n Result := 0;\r\n case Msg of\r\n WM_DESTROYCLIPBOARD:\r\n ClipboardChanged;\r\n WM_CHANGECBCHAIN:\r\n if HWND(WParam) = FNextWindow then\r\n FNextWindow := HWND(LParam)\r\n else\r\n ForwardMessage(AMsg);\r\n WM_DRAWCLIPBOARD:\r\n begin\r\n ForwardMessage(AMsg);\r\n ClipboardChanged;\r\n end;\r\n WM_DESTROY:\r\n Enabled := False;\r\n else\r\n Result := DefWindowProc(FWindowHandle, Msg, WParam, LParam);\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvClipboardMonitor.SetEnabled(Value: Boolean);\r\nbegin\r\n if FEnabled <> Value then\r\n begin\r\n if Value then\r\n FNextWindow := SetClipboardViewer(FWindowHandle)\r\n else\r\n begin\r\n ChangeClipboardChain(FWindowHandle, FNextWindow);\r\n FNextWindow := 0;\r\n end;\r\n FEnabled := Value;\r\n end;\r\nend;\r\n\r\nprocedure TJvClipboardMonitor.ClipboardChanged;\r\nbegin\r\n try\r\n Change;\r\n except\r\n Application.HandleException(Self);\r\n end;\r\nend;\r\n\r\nprocedure TJvClipboardMonitor.Change;\r\nbegin\r\n if Assigned(FOnChange) then\r\n FOnChange(Self);\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend." }, { "path": "External/Jedi/Jvcl/run/JvClipboardViewer.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvClipView.PAS, released on 2002-07-04.\r\n\r\nThe Initial Developers of the Original Code are: Fedor Koshevnikov, Igor Pavluk and Serge Korolev\r\nCopyright (c) 1997, 1998 Fedor Koshevnikov, Igor Pavluk and Serge Korolev\r\nCopyright (c) 2001,2002 SGB Software\r\nAll Rights Reserved.\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvClipboardViewer.pas 13104 2011-09-07 06:50:43Z obones $\r\n\r\nunit JvClipboardViewer;\r\n\r\n{$I jvcl.inc}\r\n{$I windowsonly.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, Messages, Classes, Graphics,\r\n JvExForms, JvJVCLUtils;\r\n\r\ntype\r\n TClipboardViewFormat = (cvDefault, cvEmpty, cvUnknown, cvText, cvBitmap,\r\n cvMetafile, cvPalette, cvOemText, cvPicture, cvComponent, cvIcon);\r\n TJvOnImageEvent = procedure(Sender: TObject; Image: TJvBitmap) of object;\r\n TJvOnTextEvent = procedure(Sender: TObject; AText: string) of object;\r\n\r\n TJvCustomClipboardViewer = class(TJvExScrollBox)\r\n private\r\n FWndNext: THandle;\r\n FChained: Boolean;\r\n FPaintControl: TComponent;\r\n FViewFormat: TClipboardViewFormat;\r\n FOnChange: TNotifyEvent;\r\n FOnImage: TJvOnImageEvent;\r\n FOnText: TJvOnTextEvent;\r\n function IsEmptyClipboard: Boolean;\r\n procedure ForwardMessage(var Msg: TMessage);\r\n procedure WMDestroyClipboard(var Msg: TMessage); message WM_DESTROYCLIPBOARD;\r\n procedure WMChangeCBChain(var Msg: TWMChangeCBChain); message WM_CHANGECBCHAIN;\r\n procedure WMDrawClipboard(var Msg: TMessage); message WM_DRAWCLIPBOARD;\r\n procedure WMNCDestroy(var Msg: TWMNCDestroy); message WM_NCDESTROY;\r\n procedure SetViewFormat(Value: TClipboardViewFormat);\r\n function GetClipboardFormatNames(Index: Integer): string;\r\n protected\r\n procedure Loaded; override;\r\n procedure Resize; override;\r\n procedure CreateWnd; override;\r\n procedure DestroyWindowHandle; override;\r\n procedure DoImage(Image: TJvBitmap); dynamic;\r\n procedure DoText(const AText: string); dynamic;\r\n procedure Change; dynamic;\r\n procedure CreatePaintControl; virtual;\r\n function GetDrawFormat: TClipboardViewFormat; virtual;\r\n function ValidFormat(Format: TClipboardViewFormat): Boolean; dynamic;\r\n property ViewFormat: TClipboardViewFormat read FViewFormat write SetViewFormat stored False;\r\n property OnChange: TNotifyEvent read FOnChange write FOnChange;\r\n property OnImage: TJvOnImageEvent read FOnImage write FOnImage;\r\n property OnText: TJvOnTextEvent read FOnText write FOnText;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n class function CanDrawFormat(ClipboardFormat: Word): Boolean;\r\n procedure EmptyClipboard;\r\n property ClipboardFormatNames[Index: Integer]: string read GetClipboardFormatNames;\r\n end;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvClipboardViewer = class(TJvCustomClipboardViewer)\r\n published\r\n property Anchors;\r\n property BiDiMode;\r\n property Color default clWindow;\r\n property Constraints;\r\n property DragKind;\r\n property ParentBiDiMode;\r\n property ParentColor default False;\r\n property ViewFormat;\r\n property OnImage;\r\n property OnText;\r\n property OnChange;\r\n property OnContextPopup;\r\n property OnStartDrag;\r\n property OnEndDock;\r\n property OnStartDock;\r\n end;\r\n\r\nfunction ClipboardFormatToView(Value: Word): TClipboardViewFormat;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvClipboardViewer.pas $';\r\n Revision: '$Revision: 13104 $';\r\n Date: '$Date: 2011-09-07 08:50:43 +0200 (mer. 07 sept. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n Math, Controls, Forms, StdCtrls, ExtCtrls, Grids, Clipbrd,\r\n JvExGrids, JvJCLUtils, JvResources;\r\n\r\n{ Utility routines }\r\n\r\nfunction ClipboardFormatName(Format: Word): string;\r\nvar\r\n Buffer: array [0..255] of Char;\r\nbegin\r\n SetString(Result, Buffer, GetClipboardFormatName(Format, Buffer, 255));\r\n if Result = '' then\r\n case Format of\r\n CF_TEXT:\r\n Result := 'Text';\r\n CF_BITMAP:\r\n Result := 'Bitmap';\r\n CF_METAFILEPICT:\r\n Result := 'Metafile Picture';\r\n CF_SYLK:\r\n Result := 'SYLK';\r\n CF_DIF:\r\n Result := 'DIF';\r\n CF_TIFF:\r\n Result := 'Tag Image';\r\n CF_OEMTEXT:\r\n Result := 'OEM Text';\r\n CF_DIB:\r\n Result := 'DIB Bitmap';\r\n CF_PALETTE:\r\n Result := 'Palette';\r\n CF_PENDATA:\r\n Result := 'Pen Data';\r\n CF_RIFF:\r\n Result := 'RIFF File';\r\n CF_WAVE:\r\n Result := 'Wave';\r\n // (rom) check for problems before uncomment\r\n //CF_UNICODETEXT:\r\n // Result := 'Unicode text';\r\n CF_ENHMETAFILE:\r\n Result := 'Enchanced Metafile';\r\n //CF_HDROP:\r\n // Result := 'Drop files';\r\n //CF_LOCALE:\r\n // Result := 'Locale data';\r\n end;\r\nend;\r\n\r\nfunction ViewToClipboardFormat(Value: TClipboardViewFormat): Word;\r\nbegin\r\n case Value of\r\n cvDefault, cvUnknown, cvEmpty:\r\n Result := 0;\r\n cvText:\r\n Result := CF_TEXT;\r\n cvBitmap:\r\n Result := CF_BITMAP;\r\n cvMetafile:\r\n Result := CF_METAFILEPICT;\r\n cvPalette:\r\n Result := CF_PALETTE;\r\n cvOemText:\r\n Result := CF_OEMTEXT;\r\n cvPicture:\r\n Result := CF_PICTURE; // CF_BITMAP, CF_METAFILEPICT\r\n cvComponent:\r\n Result := CF_COMPONENT; // CF_TEXT\r\n cvIcon:\r\n Result := CF_ICON; // CF_BITMAP\r\n else\r\n Result := 0;\r\n end;\r\nend;\r\n\r\nfunction ClipboardFormatToView(Value: Word): TClipboardViewFormat;\r\nbegin\r\n case Value of\r\n CF_TEXT:\r\n Result := cvText;\r\n CF_BITMAP:\r\n Result := cvBitmap;\r\n CF_METAFILEPICT:\r\n Result := cvMetafile;\r\n CF_ENHMETAFILE:\r\n Result := cvMetafile;\r\n CF_PALETTE:\r\n Result := cvPalette;\r\n CF_OEMTEXT:\r\n Result := cvOemText;\r\n else\r\n Result := cvDefault;\r\n end;\r\n if Value = CF_ICON then\r\n Result := cvIcon // CF_BITMAP\r\n else\r\n if Value = CF_PICTURE then\r\n Result := cvPicture // CF_BITMAP, CF_METAFILEPICT\r\n else\r\n if Value = CF_COMPONENT then\r\n Result := cvComponent; // CF_TEXT\r\nend;\r\n\r\nprocedure ComponentToStrings(Instance: TComponent; Text: TStrings);\r\nvar\r\n Mem, MemOut: TMemoryStream;\r\nbegin\r\n Text.BeginUpdate;\r\n Mem := TMemoryStream.Create;\r\n try\r\n Mem.WriteComponent(Instance);\r\n Mem.Position := 0;\r\n MemOut := TMemoryStream.Create;\r\n try\r\n ObjectBinaryToText(Mem, MemOut);\r\n MemOut.Position := 0;\r\n Text.LoadFromStream(MemOut);\r\n finally\r\n MemOut.Free;\r\n end;\r\n finally\r\n Mem.Free;\r\n Text.EndUpdate;\r\n end;\r\nend;\r\n\r\n//=== { TJvPaletteGrid } =====================================================\r\n\r\nconst\r\n NumPaletteEntries = 256;\r\n\r\ntype\r\n TJvPaletteGrid = class(TJvExDrawGrid)\r\n private\r\n FPaletteEntries: array [0..NumPaletteEntries - 1] of TPaletteEntry;\r\n FPalette: HPALETTE;\r\n FCount: Integer;\r\n FSizing: Boolean;\r\n procedure SetPalette(Value: HPALETTE);\r\n procedure UpdateSize;\r\n function CellColor(ACol, ARow: Longint): TColor;\r\n procedure DrawSquare(CellColor: TColor; CellRect: TRect; ShowSelector: Boolean);\r\n protected\r\n function GetPalette: HPALETTE; override;\r\n procedure DrawCell(ACol, ARow: Longint; ARect: TRect;\r\n AState: TGridDrawState); override;\r\n function SelectCell(ACol, ARow: Longint): Boolean; override;\r\n procedure Resize; override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n property Palette: HPALETTE read FPalette write SetPalette;\r\n end;\r\n\r\nfunction CopyPalette(Palette: HPALETTE): HPALETTE;\r\nvar\r\n PaletteSize: Integer;\r\n LogSize: Integer;\r\n LogPalette: PLogPalette;\r\nbegin\r\n Result := 0;\r\n if Palette = 0 then\r\n Exit;\r\n GetObject(Palette, SizeOf(PaletteSize), @PaletteSize);\r\n LogSize := SizeOf(TLogPalette) + (PaletteSize - 1) * SizeOf(TPaletteEntry);\r\n GetMem(LogPalette, LogSize);\r\n try\r\n with LogPalette^ do\r\n begin\r\n palVersion := $0300;\r\n palNumEntries := PaletteSize;\r\n GetPaletteEntries(Palette, 0, PaletteSize, palPalEntry);\r\n end;\r\n Result := CreatePalette(LogPalette^);\r\n finally\r\n FreeMem(LogPalette, LogSize);\r\n end;\r\nend;\r\n\r\nconstructor TJvPaletteGrid.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n DefaultColWidth := 20;\r\n DefaultRowHeight := 20;\r\n Options := [];\r\n GridLineWidth := 0;\r\n FixedCols := 0;\r\n FixedRows := 0;\r\n ColCount := 0;\r\n RowCount := 0;\r\n DefaultDrawing := False;\r\n ScrollBars := ssVertical;\r\nend;\r\n\r\ndestructor TJvPaletteGrid.Destroy;\r\nbegin\r\n if FPalette <> 0 then\r\n DeleteObject(FPalette);\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvPaletteGrid.UpdateSize;\r\nvar\r\n Rows: Integer;\r\nbegin\r\n if FSizing then\r\n Exit;\r\n FSizing := True;\r\n try\r\n ColCount := (ClientWidth - GetSystemMetrics(SM_CXVSCROLL)) div DefaultColWidth;\r\n Rows := FCount div ColCount;\r\n if FCount mod ColCount > 0 then\r\n Inc(Rows);\r\n RowCount := Max(1, Rows);\r\n ClientHeight := DefaultRowHeight * RowCount;\r\n finally\r\n FSizing := False;\r\n end;\r\nend;\r\n\r\nfunction TJvPaletteGrid.GetPalette: HPALETTE;\r\nbegin\r\n if FPalette <> 0 then\r\n Result := FPalette\r\n else\r\n Result := inherited GetPalette;\r\nend;\r\n\r\nprocedure TJvPaletteGrid.SetPalette(Value: HPALETTE);\r\nvar\r\n I: Integer;\r\n ParentForm: TCustomForm;\r\nbegin\r\n if FPalette <> 0 then\r\n DeleteObject(FPalette);\r\n FPalette := CopyPalette(Value);\r\n FCount := Min(PaletteEntries(FPalette), NumPaletteEntries);\r\n GetPaletteEntries(FPalette, 0, FCount, FPaletteEntries);\r\n for I := FCount to NumPaletteEntries - 1 do\r\n FillChar(FPaletteEntries[I], SizeOf(TPaletteEntry), $80);\r\n UpdateSize;\r\n if Visible and (not (csLoading in ComponentState)) then\r\n begin\r\n ParentForm := GetParentForm(Self);\r\n if Assigned(ParentForm) and ParentForm.Active and\r\n ParentForm.HandleAllocated then\r\n PostMessage(ParentForm.Handle, WM_QUERYNEWPALETTE, 0, 0);\r\n end;\r\nend;\r\n\r\nfunction TJvPaletteGrid.CellColor(ACol, ARow: Longint): TColor;\r\nvar\r\n PalIndex: Integer;\r\nbegin\r\n PalIndex := ACol + (ARow * ColCount);\r\n if PalIndex <= FCount - 1 then\r\n with FPaletteEntries[PalIndex] do\r\n Result := TColor(RGB(peRed, peGreen, peBlue))\r\n else\r\n Result := clNone;\r\nend;\r\n\r\nprocedure TJvPaletteGrid.DrawSquare(CellColor: TColor; CellRect: TRect;\r\n ShowSelector: Boolean);\r\nvar\r\n SavePal: HPALETTE;\r\nbegin\r\n Canvas.Pen.Color := clBtnFace;\r\n Canvas.Rectangle(CellRect.Left, CellRect.Top, CellRect.Right, CellRect.Bottom);\r\n InflateRect(CellRect, -1, -1);\r\n Frame3D(Canvas, CellRect, clBtnShadow, clBtnHighlight, 2);\r\n SavePal := 0;\r\n if FPalette <> 0 then\r\n begin\r\n SavePal := SelectPalette(Canvas.Handle, FPalette, False);\r\n RealizePalette(Canvas.Handle);\r\n end;\r\n try\r\n Canvas.Brush.Color := CellColor;\r\n Canvas.Pen.Color := CellColor;\r\n Canvas.Rectangle(CellRect.Left, CellRect.Top, CellRect.Right, CellRect.Bottom);\r\n finally\r\n if FPalette <> 0 then\r\n SelectPalette(Canvas.Handle, SavePal, True);\r\n end;\r\n if ShowSelector then\r\n begin\r\n Canvas.Brush.Color := Self.Color;\r\n Canvas.Pen.Color := Self.Color;\r\n InflateRect(CellRect, -1, -1);\r\n Canvas.DrawFocusRect(CellRect);\r\n end;\r\nend;\r\n\r\nfunction TJvPaletteGrid.SelectCell(ACol, ARow: Longint): Boolean;\r\nbegin\r\n Result := ((ACol = 0) and (ARow = 0)) or (CellColor(ACol, ARow) <> clNone);\r\nend;\r\n\r\nprocedure TJvPaletteGrid.DrawCell(ACol, ARow: Longint; ARect: TRect;\r\n AState: TGridDrawState);\r\nvar\r\n Color: TColor;\r\nbegin\r\n Color := CellColor(ACol, ARow);\r\n if Color <> clNone then\r\n DrawSquare(PaletteColor(Color), ARect, gdFocused in AState)\r\n else\r\n begin\r\n Canvas.Brush.Color := Self.Color;\r\n Canvas.FillRect(ARect);\r\n end;\r\nend;\r\n\r\nprocedure TJvPaletteGrid.Resize;\r\nbegin\r\n inherited Resize;\r\n UpdateSize;\r\nend;\r\n\r\n//=== { TJvCustomClipboardViewer } ===========================================\r\n\r\nconstructor TJvCustomClipboardViewer.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n ControlState := ControlState + [csCreating];\r\n FWndNext := 0;\r\n FPaintControl := nil;\r\n FViewFormat := cvDefault;\r\n ParentColor := False;\r\n Color := clWindow;\r\n ControlState := ControlState - [csCreating];\r\nend;\r\n\r\nprocedure TJvCustomClipboardViewer.ForwardMessage(var Msg: TMessage);\r\nbegin\r\n if FWndNext <> 0 then\r\n with Msg do\r\n SendMessage(FWndNext, Msg, WParam, LParam);\r\nend;\r\n\r\nprocedure TJvCustomClipboardViewer.CreateWnd;\r\nbegin\r\n inherited CreateWnd;\r\n if Handle <> 0 then\r\n begin\r\n FWndNext := SetClipboardViewer(Handle);\r\n FChained := True;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomClipboardViewer.DestroyWindowHandle;\r\nbegin\r\n if FChained then\r\n begin\r\n ChangeClipboardChain(Handle, FWndNext);\r\n FChained := False;\r\n end;\r\n FWndNext := 0;\r\n inherited DestroyWindowHandle;\r\nend;\r\n\r\nprocedure TJvCustomClipboardViewer.CreatePaintControl;\r\nvar\r\n Icon: TIcon;\r\n Format: TClipboardViewFormat;\r\n Instance: TComponent;\r\nbegin\r\n if csDesigning in ComponentState then\r\n Exit;\r\n FPaintControl.Free;\r\n FPaintControl := nil;\r\n if IsEmptyClipboard then\r\n Exit;\r\n Format := GetDrawFormat;\r\n if not ValidFormat(Format) then\r\n Format := cvUnknown;\r\n case Format of\r\n cvText, cvOemText, cvUnknown, cvDefault, cvEmpty:\r\n begin\r\n FPaintControl := TMemo.Create(Self);\r\n with TMemo(FPaintControl) do\r\n begin\r\n BorderStyle := bsNone;\r\n Parent := Self;\r\n Left := 0;\r\n Top := 0;\r\n ScrollBars := ssBoth;\r\n Align := alClient;\r\n if Format = cvOemText then\r\n begin\r\n ParentFont := False;\r\n Font.Name := 'Terminal';\r\n end;\r\n Visible := True;\r\n if Clipboard.HasFormat(CF_TEXT) then\r\n PasteFromClipboard\r\n else\r\n if (Format = cvText) and Clipboard.HasFormat(CF_COMPONENT) then\r\n begin\r\n Instance := Clipboard.GetComponent(Self, Self);\r\n try\r\n ComponentToStrings(Instance, Lines);\r\n finally\r\n Instance.Free;\r\n end;\r\n end\r\n else\r\n if IsEmptyClipboard then\r\n Text := RsClipboardEmpty\r\n else\r\n Text := RsClipboardUnknown;\r\n ReadOnly := True;\r\n end;\r\n end;\r\n cvPicture, cvMetafile, cvBitmap, cvIcon:\r\n begin\r\n FPaintControl := TImage.Create(Self);\r\n with TImage(FPaintControl) do\r\n begin\r\n Parent := Self;\r\n AutoSize := True;\r\n Left := 0;\r\n Top := 0;\r\n Visible := True;\r\n if Format = cvIcon then\r\n begin\r\n if Clipboard.HasFormat(CF_ICON) then\r\n begin\r\n Icon := CreateIconFromClipboard;\r\n try\r\n Picture.Icon := Icon;\r\n finally\r\n Icon.Free;\r\n end;\r\n end;\r\n end\r\n else\r\n if ((Format = cvBitmap) and Clipboard.HasFormat(CF_BITMAP)) or\r\n ((Format = cvMetafile) and (Clipboard.HasFormat(CF_METAFILEPICT)) or\r\n Clipboard.HasFormat(CF_ENHMETAFILE)) or\r\n ((Format = cvPicture) and Clipboard.HasFormat(CF_PICTURE)) then\r\n Picture.Assign(Clipboard);\r\n end;\r\n CenterControl(TImage(FPaintControl));\r\n end;\r\n cvComponent:\r\n begin\r\n Instance := Clipboard.GetComponent(Self, Self);\r\n FPaintControl := Instance;\r\n if FPaintControl is TControl then\r\n begin\r\n with TControl(FPaintControl) do\r\n begin\r\n Left := 1;\r\n Top := 1;\r\n Parent := Self;\r\n end;\r\n CenterControl(TControl(FPaintControl));\r\n end\r\n else\r\n begin\r\n FPaintControl := TMemo.Create(Self);\r\n try\r\n with TMemo(FPaintControl) do\r\n begin\r\n BorderStyle := bsNone;\r\n Parent := Self;\r\n Left := 0;\r\n Top := 0;\r\n ScrollBars := ssBoth;\r\n Align := alClient;\r\n ReadOnly := True;\r\n ComponentToStrings(Instance, Lines);\r\n Visible := True;\r\n end;\r\n finally\r\n Instance.Free;\r\n end;\r\n end;\r\n end;\r\n cvPalette:\r\n begin\r\n FPaintControl := TJvPaletteGrid.Create(Self);\r\n with TJvPaletteGrid(FPaintControl) do\r\n try\r\n BorderStyle := bsNone;\r\n Parent := Self;\r\n Ctl3D := False;\r\n Align := alClient;\r\n Clipboard.Open;\r\n try\r\n Palette := GetClipboardData(CF_PALETTE);\r\n finally\r\n Clipboard.Close;\r\n end;\r\n except\r\n FPaintControl.Free;\r\n raise;\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJvCustomClipboardViewer.GetClipboardFormatNames(Index: Integer): string;\r\nbegin\r\n Result := '';\r\n if Index < Clipboard.FormatCount then\r\n Result := ClipboardFormatName(Clipboard.Formats[Index]);\r\nend;\r\n\r\nprocedure TJvCustomClipboardViewer.Change;\r\nbegin\r\n if Assigned(FOnChange) then\r\n FOnChange(Self);\r\nend;\r\n\r\nprocedure TJvCustomClipboardViewer.Loaded;\r\nbegin\r\n inherited Loaded;\r\n Resize; // Resize is not called while csLoading in ComponentState\r\nend;\r\n\r\nprocedure TJvCustomClipboardViewer.Resize;\r\nbegin\r\n inherited Resize;\r\n if (FPaintControl <> nil) and (FPaintControl is TControl) then\r\n CenterControl(TControl(FPaintControl));\r\nend;\r\n\r\nprocedure TJvCustomClipboardViewer.WMChangeCBChain(var Msg: TWMChangeCBChain);\r\nbegin\r\n if Msg.Remove = FWndNext then\r\n FWndNext := Msg.Next\r\n else\r\n ForwardMessage(TMessage(Msg));\r\n inherited;\r\nend;\r\n\r\nprocedure TJvCustomClipboardViewer.WMNCDestroy(var Msg: TWMNCDestroy);\r\nbegin\r\n if FChained then\r\n begin\r\n ChangeClipboardChain(Handle, FWndNext);\r\n FChained := False;\r\n FWndNext := 0;\r\n end;\r\n inherited;\r\nend;\r\n\r\nprocedure TJvCustomClipboardViewer.WMDrawClipboard(var Msg: TMessage);\r\nvar\r\n Format: Word;\r\n B: TJvBitmap;\r\nbegin\r\n ForwardMessage(Msg);\r\n Format := ViewToClipboardFormat(ViewFormat);\r\n if IsEmptyClipboard then\r\n FViewFormat := cvEmpty\r\n else\r\n if not Clipboard.HasFormat(Format) then\r\n FViewFormat := cvDefault;\r\n if Clipboard.HasFormat(CF_BITMAP) then\r\n begin\r\n B := TJvBitmap.Create;\r\n try\r\n B.Assign(Clipboard);\r\n DoImage(B);\r\n finally\r\n B.Free;\r\n end;\r\n end;\r\n if Clipboard.HasFormat(CF_TEXT) then\r\n DoText(Clipboard.AsText);\r\n Change;\r\n DisableAlign;\r\n try\r\n CreatePaintControl;\r\n finally\r\n EnableAlign;\r\n end;\r\n inherited;\r\nend;\r\n\r\nprocedure TJvCustomClipboardViewer.WMDestroyClipboard(var Msg: TMessage);\r\nbegin\r\n FViewFormat := cvEmpty;\r\n Change;\r\n CreatePaintControl;\r\nend;\r\n\r\nfunction TJvCustomClipboardViewer.IsEmptyClipboard: Boolean;\r\nbegin\r\n Result := (Clipboard.FormatCount = 0);\r\nend;\r\n\r\nprocedure TJvCustomClipboardViewer.SetViewFormat(Value: TClipboardViewFormat);\r\nvar\r\n Format: Word;\r\nbegin\r\n if Value <> ViewFormat then\r\n begin\r\n Format := ViewToClipboardFormat(Value);\r\n if (Clipboard.HasFormat(Format) and ValidFormat(Value)) then\r\n FViewFormat := Value\r\n else\r\n FViewFormat := cvDefault;\r\n CreatePaintControl;\r\n end;\r\nend;\r\n\r\nfunction TJvCustomClipboardViewer.GetDrawFormat: TClipboardViewFormat;\r\n\r\n function DefaultFormat: TClipboardViewFormat;\r\n begin\r\n if Clipboard.HasFormat(CF_TEXT) then\r\n Result := cvText\r\n else\r\n if Clipboard.HasFormat(CF_OEMTEXT) then\r\n Result := cvOemText\r\n else\r\n if Clipboard.HasFormat(CF_BITMAP) then\r\n Result := cvBitmap\r\n else\r\n if Clipboard.HasFormat(CF_METAFILEPICT) then\r\n Result := cvMetafile\r\n else\r\n if Clipboard.HasFormat(CF_ENHMETAFILE) then\r\n Result := cvMetafile\r\n else\r\n if Clipboard.HasFormat(CF_ICON) then\r\n Result := cvIcon\r\n else\r\n if Clipboard.HasFormat(CF_PICTURE) then\r\n Result := cvPicture\r\n else\r\n if Clipboard.HasFormat(CF_COMPONENT) then\r\n Result := cvComponent\r\n else\r\n if Clipboard.HasFormat(CF_PALETTE) then\r\n Result := cvPalette\r\n else\r\n Result := cvUnknown;\r\n end;\r\n\r\nbegin\r\n if IsEmptyClipboard then\r\n Result := cvEmpty\r\n else\r\n begin\r\n Result := ViewFormat;\r\n if Result = cvDefault then\r\n Result := DefaultFormat;\r\n end;\r\nend;\r\n\r\nclass function TJvCustomClipboardViewer.CanDrawFormat(ClipboardFormat: Word): Boolean;\r\nbegin\r\n Result := ClipboardFormatToView(ClipboardFormat) <> cvUnknown;\r\nend;\r\n\r\nfunction TJvCustomClipboardViewer.ValidFormat(Format: TClipboardViewFormat): Boolean;\r\nbegin\r\n Result := (Format in [cvDefault, cvEmpty, cvUnknown]);\r\n if not Result then\r\n if Clipboard.HasFormat(ViewToClipboardFormat(Format)) then\r\n Result := True;\r\nend;\r\n\r\nprocedure TJvCustomClipboardViewer.DoImage(Image: TJvBitmap);\r\nbegin\r\n if Assigned(FOnImage) then\r\n FOnImage(Self, Image);\r\nend;\r\n\r\nprocedure TJvCustomClipboardViewer.DoText(const AText: string);\r\nbegin\r\n if Assigned(FOnText) then\r\n FOnText(Self, AText);\r\nend;\r\n\r\nprocedure TJvCustomClipboardViewer.EmptyClipboard;\r\nbegin\r\n OpenClipboard(Application.Handle);\r\n // (rom) added Windows. to avoid recursion\r\n Windows.EmptyClipboard;\r\n CloseClipboard;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvClipbrd.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvClipbrd.PAS, released on 2003-05-18.\r\n\r\nThe Initial Developer of the Original Code is Olivier Sannier\r\n [obones att altern dott org]\r\nPortions created by Olivier Sannier are Copyright (C) 2003 Olivier Sannier.\r\nAll Rights Reserved.\r\n\r\nContributor(s): none to date.\r\n\r\nYou may retrieve the latest version of this file at the Connection Manager\r\nhome page, located at http://cnxmanager.sourceforge.net\r\n\r\nKnown Issues: none to date.\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvClipbrd.pas 12567 2009-10-22 08:50:56Z outchy $\r\n\r\nunit JvClipbrd;\r\n\r\n{$I jvcl.inc}\r\n{$I windowsonly.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, Messages, Classes, Clipbrd;\r\n\r\ntype\r\n // the type of the event fired when a format has been added with delayed\r\n // rendering and needs rendering because an application asked for it.\r\n // Parameters are :\r\n // Sender The object triggering the event. Cleary, will always\r\n // be the value returned by JvClipboard, unless you\r\n // call the event yourself\r\n // Format The format needing rendering\r\n // buffer The buffer where the rendered data has to be or\r\n // has been put\r\n // You may change the value of the buffer parameter to\r\n // point on a memory that will survive the exit of your\r\n // handler. Clearly, you can't give a pointer to a local\r\n // variable or use a PChar() conversion.\r\n // Alternatively, you can allocate some memory with\r\n // GetMem(), copy your data in the buffer and set the\r\n // mustFree parameter to True to ask the clipboard to\r\n // free the memory for you (done using FreeMem)\r\n // Setting buffer to nil will make the system remove this\r\n // format from the clipboard, even if it is not a\r\n // documented behaviour\r\n // size the size in bytes of the data available in the buffer\r\n // Setting size to 0 will make the system remove this\r\n // format from the clipboard, even if it is not a\r\n // documented behaviour\r\n // mustFree set to False by default. If you set this to True, the\r\n // clipboard will call FreeMem(buffer) after having copied\r\n // the data in the system clipboard. This is useful only\r\n // if you allocated the buffer using GetMem()\r\n TJvRenderFormatEvent = procedure(Sender: TObject; Format: Word;\r\n var Buffer: Pointer; var Size: Cardinal; var MustFree: Boolean) of object;\r\n\r\n // the new clipboard object, with added power !\r\n // clearly, it now allows to use delayed rendering through the\r\n // OnRenderFormat event.\r\n // All methods have been overriden to allow specifying delayed\r\n // rendering. See their documentation for details.\r\n // However, SetAsHandle has not been overriden as it is enough\r\n // to set its second parameter to 0 to get delayed rendering\r\n TJvClipboard = class(TClipboard)\r\n private\r\n function GetAsWideText: WideString;\r\n procedure SetAsWideText(const Value: WideString);\r\n protected\r\n // the pointer to the user procedure to call for the event\r\n // see the declaration of TOnRenderFormat\r\n FOnRenderFormat: TJvRenderFormatEvent;\r\n\r\n // the list of formats that have been added using delayed rendering\r\n // we need to keep track of them because we must be able to render\r\n // them when the WM_RENDERALLFORMATS event is fired.\r\n // And we can't simply loop through the Formats property as this\r\n // is not a good thing to call RenderFormat for formats not put\r\n // by the user in the clipboard (for instance, adding CF_TEXT will\r\n // make the system add a CF_OEMTEXT and a CF_UNICODETEXT automatically)\r\n // Moreover, to ensure that the delayed rendering formats will\r\n // survive the death of the application, we must ask for their value\r\n // from the DestroyHandle method\r\n // If the formats are quite big, which may cause memory problems,\r\n // you should ask the user if he wants to keep them and if not,\r\n // call the clear method before destroying the handle\r\n // This list will actually only contain Words (Format Ids)\r\n FDelayedFormats: TList;\r\n\r\n // the handle to the window processing the messages\r\n FClipboardWindow: THandle;\r\n\r\n // This flag is used to determine wether or not the RenderFormat\r\n // method should be called as a result of the WM_RENDERALLFORMATS\r\n // message. It will be set to True from within DestroyHandle,\r\n // thus ensuring a delayed rendering format is only rendered once\r\n FFromDestroyHandle: Boolean;\r\n\r\n // overridden wndproc to handle WM_RENDERFORMAT and\r\n // WM_RENDERALLFORMATS messages\r\n procedure WndProc(var Message: TMessage); override;\r\n\r\n // This function calls the user event handler and does the\r\n // rendering the way windows expects it\r\n // it will trigger an exception if no OnRenderFormat event\r\n // handler is given\r\n procedure RenderFormat(Format: Word); virtual;\r\n\r\n // returns the window handle (the value of FClipboardWindow)\r\n function GetHandle: THandle;\r\n public\r\n // creates the list\r\n constructor Create; virtual;\r\n\r\n // destroys the list and the window (only if needed, see below)\r\n destructor Destroy; override;\r\n\r\n // To ensure that the formats using delayed rendering are\r\n // saved when the application terminates, it is necessary\r\n // that we get their values before actually destroying the\r\n // underlying window (which handle is given by the Handle property)\r\n // As a result, the OnRenderFormat event will be fired for every\r\n // format with delayed rendering still in the clipboard.\r\n // This could lead to memory problems if the format is quite big.\r\n // You should then asks the user if he wants to keep the big objects\r\n // available for other programs\r\n // If you don't call this method and some formats are in the\r\n // clipboard with delayed rendering, it will be called upon\r\n // destruction of the clipboard, which is likely to happen after the\r\n // destruction of the object where the event is set.\r\n // I let you imagine the consequences...\r\n // So you should call this function from the destructor (or the\r\n // OnDestroy event) of the component where the OnRenderFormat event\r\n // handler is set (eg, the main form) as this component is likely\r\n // to be destroyed before the clipboard itself.\r\n procedure DestroyHandle;\r\n\r\n // forced to override Open to be able to use our own\r\n // window handle\r\n procedure Open; override;\r\n\r\n // Close is overriden but simply calls the inherited Close\r\n // method. It is still there if you want to tweak around\r\n procedure Close; override;\r\n\r\n // forced to override Clear to keep track of the delayed\r\n // formats in the delayedFormats list\r\n procedure Clear; override;\r\n\r\n // registers a format of that name with the system and returns\r\n // its identifier. You may as well call RegisterClipboardFormat\r\n // directly\r\n function RegisterFormat(const Name: string): Word;\r\n\r\n // add a format that uses delayed rendering\r\n // if you do so, you MUST provide an OnRenderFormat event handler\r\n procedure AddDelayed(Format: Word);\r\n\r\n // overriden method to allow setting buffer to nil and thus\r\n // asking to use delayed rendering. If you do so, you MUST provide\r\n // an OnRenderFormat event handler\r\n // if buffer <> nil then the inherited method is called\r\n procedure SetBuffer(Format: Word; Buffer: Pointer; Size: Integer); overload;\r\n\r\n // get a buffer of the given format\r\n // the format must be present in the clipboard. If not the function\r\n // returns False.\r\n // The buffer and the size parameters must be set to the correct size\r\n // for the specified format. If they are too small, the data will be\r\n // truncated, resulting in corrupted values on your side (but you're\r\n // the one who knows what to do with that).\r\n // If they are too large, the application will crash as it will be\r\n // asking the system for more data than available\r\n // Returns True if data was successfuly retrieved, else use\r\n // Windows.GetLastError to get the error code\r\n function GetBuffer(Format: Word; Buffer: Pointer; Size: Cardinal): Boolean;\r\n\r\n // overloaded version of the same procedure in TClipboard that\r\n // now allows you to specify delayed rendering.\r\n // If delayed is set to False, the inherited method is called\r\n // else, the format is simply added in the clipboard and you MUST\r\n // provid an OnRenderFormat event;\r\n procedure SetComponent(Component: TComponent; Delayed: Boolean); overload;\r\n\r\n // overloaded version of the same procedure in TClipboard that\r\n // now allows you to specify delayed rendering.\r\n // If delayed is set to False, the inherited method is called\r\n // else, the format is simply added in the clipboard and you MUST\r\n // provid an OnRenderFormat event;\r\n procedure SetTextBuf(Buffer: PChar; Delayed: Boolean); overload;\r\n\r\n // the handle to the underlying window handling the delayed\r\n // rendering messages\r\n property Handle: THandle read GetHandle;\r\n published\r\n // the event fired when a format has been added with delayed\r\n // rendering and needs rendering because an application (or the\r\n // DestroyHandle method) asked for it\r\n property OnRenderFormat: TJvRenderFormatEvent read FOnRenderFormat\r\n write FOnRenderFormat;\r\n property AsWideText: WideString read GetAsWideText write SetAsWideText;\r\n end;\r\n\r\n// global function to get access to a TJvClipboard object\r\nfunction JvClipboard: TJvClipboard;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvClipbrd.pas $';\r\n Revision: '$Revision: 12567 $';\r\n Date: '$Date: 2009-10-22 10:50:56 +0200 (jeu. 22 oct. 2009) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n SysUtils, Consts,\r\n JvTypes, JvJVCLUtils, JvResources;\r\n\r\nconstructor TJvClipboard.Create;\r\nbegin\r\n inherited Create;\r\n // create the list used to keep track of delayed formats\r\n // in the clipboard\r\n FDelayedFormats := TList.Create;\r\n\r\n // if a WM_RENDERALLFORMATS message is fired, then\r\n // it is not yet as a result of a call to DestroyHandle\r\n FFromDestroyHandle := False;\r\nend;\r\n\r\ndestructor TJvClipboard.Destroy;\r\nbegin\r\n // ensure handle is destroyed, but see remark where\r\n // DestroyHandle is declared\r\n DestroyHandle;\r\n\r\n // free the list\r\n FDelayedFormats.Free;\r\n\r\n // and let the rest be done\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvClipboard.Clear;\r\nbegin\r\n // call the inherited method, will do its job\r\n inherited Clear;\r\n // no more delayed formats available\r\n FDelayedFormats.Clear;\r\nend;\r\n\r\nfunction TJvClipboard.GetBuffer(Format: Word; Buffer: Pointer;\r\n Size: Cardinal): Boolean;\r\nvar\r\n Data: THandle;\r\n DataPtr: Pointer;\r\nbegin\r\n // retrieve data of the given format\r\n\r\n // first, open clipoard\r\n Open;\r\n\r\n // ask for data\r\n Data := GetClipboardData(Format);\r\n\r\n // was data retrieved ?\r\n if Data <> 0 then\r\n begin\r\n // if some data retrieved, get a Pointer to it\r\n DataPtr := GlobalLock(Data);\r\n\r\n // did we get a valid Pointer ?\r\n if DataPtr <> nil then\r\n begin\r\n // if yes, copy from global pointer to user supplied pointer\r\n CopyMemory(Buffer, DataPtr, Size);\r\n // and retrieval was a success\r\n Result := True;\r\n end\r\n else\r\n begin\r\n // else, retrieval has failed\r\n Result := False;\r\n end;\r\n\r\n // unlock global memory\r\n GlobalUnlock(Data);\r\n end\r\n else\r\n begin\r\n // if no data retrieved, then retrieval failed\r\n Result := False;\r\n end;\r\n\r\n // finally, close clipoard\r\n Close;\r\nend;\r\n\r\nprocedure TJvClipboard.Open;\r\nbegin\r\n // call the inherited open method to force the inherited\r\n // private FOpenRefCount to be greater than 0. This is the\r\n // result of a bad design, because FOpenRefCount should be\r\n // protected in the TClipboard class, allowing us to access\r\n // it directly, rather than tweaking around\r\n // Having the inherited FOpenRefCount greater than 0 is\r\n // required for the inherited method that put data in the\r\n // clipboard to work. Indeed, they call the private method\r\n // Adding which calls Clear only if FOpenRefCount is not 0.\r\n // And calling Clear is required for the window to get the\r\n // clipboard ownership.\r\n // Another good decision would have been to make the Adding\r\n // method protected rather than private. This would have\r\n // allowed to easily add other methods to put other types\r\n // in the clipboard.\r\n // But it seems the people in charge of that part didn't\r\n // have reusability in mind when they designed the\r\n // TClipboard class\r\n inherited Open;\r\n\r\n // if we were just opened (the inherited FOpenRefCount\r\n // just turned to 1)\r\n if OpenRefCount = 1 then\r\n begin\r\n // then, if we need a window to handle delayed rendering\r\n if FClipboardWindow = 0 then\r\n begin\r\n // then we create one, passing MainWndProc rather than\r\n // WndProc as MainWndProc will call WndProc but in a\r\n // try except statement ensuring good exception handling\r\n FClipboardWindow := AllocateHWndEx(MainWndProc);\r\n end;\r\n\r\n // we must now close the clipboard as it was opened\r\n // with an incorrect window handle (most likely the\r\n // application window handle)\r\n CloseClipboard;\r\n\r\n // and we finally open the clipboard with our window handle\r\n // to ensure that we can process delayed rendering messages\r\n if not OpenClipboard(FClipboardWindow) then\r\n raise EJVCLException.CreateRes(@SCannotOpenClipboard);\r\n end;\r\nend;\r\n\r\nprocedure TJvClipboard.Close;\r\nbegin\r\n // call the inherited close method to force update of the\r\n // inherited FOpenRefCount and to close the clipboard if\r\n // needed\r\n inherited Close;\r\nend;\r\n\r\nfunction TJvClipboard.RegisterFormat(const Name: string): Word;\r\nbegin\r\n Result := RegisterClipboardFormat(PChar(Name));\r\nend;\r\n\r\nprocedure TJvClipboard.RenderFormat(Format: Word);\r\nvar\r\n Buffer: Pointer;\r\n Size: Cardinal;\r\n hglb: HGLOBAL;\r\n GlobalPtr: Pointer;\r\n MustFree: Boolean;\r\nbegin\r\n // by default, we must not free the given buffer\r\n MustFree := False;\r\n\r\n // if user gave us an event\r\n if Assigned(FOnRenderFormat) then\r\n // then ask user to render the format\r\n FOnRenderFormat(Self, Format, Buffer, Size, MustFree)\r\n else\r\n // else, trigger an exception, how could we guess the\r\n // size and data to put in the buffer ?\r\n raise EJVCLException.CreateRes(@RsENoRenderFormatEventGiven);\r\n\r\n // now render the way windows wants it\r\n\r\n // first allocate a global memory\r\n hglb := GlobalAlloc(GMEM_DDESHARE or GMEM_MOVEABLE, Size);\r\n if hglb <> 0 then\r\n begin\r\n // if allocation was successful\r\n // then lock global memory to get access to it\r\n GlobalPtr := GlobalLock(hglb);\r\n\r\n // copy user supplied data\r\n CopyMemory(GlobalPtr, Buffer, Size);\r\n\r\n // unlock global memory\r\n GlobalUnlock(hglb);\r\n\r\n // finally, place the content in the clipboard\r\n SetClipboardData(Format, hglb);\r\n end;\r\n\r\n // if user asked us to free his buffer\r\n if MustFree then\r\n // then we free it\r\n FreeMem(Buffer);\r\nend;\r\n\r\nprocedure TJvClipboard.WndProc(var Message: TMessage);\r\nvar\r\n I: Integer;\r\nbegin\r\n case Message.Msg of\r\n // if asked to render a particular format\r\n WM_RENDERFORMAT:\r\n begin\r\n // then render it\r\n RenderFormat(Message.WParam);\r\n // and tell windows so\r\n Message.Result := 0;\r\n end;\r\n // if asked to render all available formats\r\n WM_RENDERALLFORMATS:\r\n begin\r\n // then if it is not the result of a call\r\n // to DestroyHandle\r\n if not FFromDestroyHandle then\r\n begin\r\n // then we render all the delayed formats\r\n // we are aware of\r\n for I := 0 to FDelayedFormats.Count - 1 do\r\n RenderFormat(Word(FDelayedFormats[I]));\r\n end;\r\n // tell windows we handled the message\r\n Message.Result := 0;\r\n end;\r\n end;\r\n\r\n // in any case let the ancestor do its stuff\r\n inherited WndProc(Message);\r\nend;\r\n\r\nprocedure TJvClipboard.DestroyHandle;\r\nvar\r\n I: Integer;\r\n Format: Word;\r\n Buffer: Char;\r\nbegin\r\n // if we have a window handle, hence, meaning that it is\r\n // the first time DestroyHandle is called\r\n if FClipboardWindow <> 0 then\r\n begin\r\n // to ensure persistance of the private formats, we\r\n // must get them before destroying the window\r\n // this is rather strange as destroying the window fires\r\n // the WM_RENDERALLFORMATS message but it seems the system\r\n // forgets the results.\r\n // so we do the job ourselves and ask for the data\r\n // Of course, this will not work for formats that the user\r\n // put in the clipboard using delayed rendering through direct\r\n // API calls\r\n for I := 0 to FDelayedFormats.Count - 1 do\r\n begin\r\n // get the format id\r\n Format := Word(FDelayedFormats[I]);\r\n\r\n // ask to get this format from the clipboard, will\r\n // in turn trigger a WM_RENDERFORMAT message\r\n // we only ask for one byte as we don't know what to\r\n // do with the format and clearly won't use it\r\n // Asking for one byte ensures that windows will\r\n // effectively give us something\r\n GetBuffer(Format, @Buffer, 1);\r\n end;\r\n\r\n // Having done that will not prevent the WM_RENDERALLFORMATS\r\n // message from being fired so me must ensure the RenderFormat\r\n // method is not called twice for all delayed rendering formats\r\n FFromDestroyHandle := True;\r\n\r\n // we can now safely destroy the window\r\n DeallocateHWndEx(FClipboardWindow);\r\n\r\n // and we no longer have a window\r\n FClipboardWindow := 0;\r\n end;\r\nend;\r\n\r\nfunction TJvClipboard.GetHandle: THandle;\r\nbegin\r\n Result := FClipboardWindow;\r\nend;\r\n\r\nprocedure TJvClipboard.SetComponent(Component: TComponent; Delayed: Boolean);\r\nbegin\r\n if Delayed then\r\n // add as delayed\r\n AddDelayed(CF_COMPONENT)\r\n else\r\n inherited SetComponent(Component);\r\nend;\r\n\r\nprocedure TJvClipboard.SetTextBuf(Buffer: PChar; Delayed: Boolean);\r\nbegin\r\n if Delayed then\r\n // add as delayed\r\n AddDelayed(CF_TEXT)\r\n else\r\n inherited SetTextBuf(Buffer);\r\nend;\r\n\r\nprocedure TJvClipboard.SetBuffer(Format: Word; Buffer: Pointer; Size: Integer);\r\nbegin\r\n // if buffer is nil\r\n if Buffer = nil then\r\n // then add the format using delayed rendering\r\n AddDelayed(Format)\r\n else\r\n begin\r\n // else call inherited method\r\n inherited SetBuffer(Format, Buffer^, Size);\r\n end;\r\nend;\r\n\r\nprocedure TJvClipboard.AddDelayed(Format: Word);\r\nbegin\r\n // add as delayed\r\n inherited SetAsHandle(Format, 0);\r\n // and we keep track of that format\r\n FDelayedFormats.Add(Pointer(Format));\r\nend;\r\n\r\nfunction TJvClipboard.GetAsWideText: WideString;\r\nvar\r\n Data: THandle;\r\nbegin\r\n Open;\r\n Data := GetClipboardData(CF_UNICODETEXT);\r\n try\r\n if Data <> 0 then\r\n Result := PWideChar(GlobalLock(Data))\r\n else\r\n Result := '';\r\n finally\r\n if Data <> 0 then\r\n GlobalUnlock(Data);\r\n Close;\r\n end;\r\n if (Data = 0) or (Result = '') then\r\n Result := AsText\r\nend;\r\n\r\nprocedure TJvClipboard.SetAsWideText(const Value: WideString);\r\nbegin\r\n Open;\r\n try\r\n AsText := Value; {Ensures ANSI compatiblity across platforms.}\r\n SetBuffer(CF_UNICODETEXT, PWideChar(Value)^, (Length(Value) + 1) * SizeOf(WideChar));\r\n finally\r\n Close;\r\n end;\r\nend;\r\n\r\nvar\r\n GlobalClipboard: TJvClipboard;\r\n\r\n// global function to call to get access to the clipboard\r\n\r\nfunction JvClipboard: TJvClipboard;\r\nbegin\r\n if GlobalClipboard = nil then\r\n GlobalClipboard := TJvClipboard.Create;\r\n Result := GlobalClipboard;\r\nend;\r\n\r\ninitialization\r\n {$IFDEF UNITVERSIONING}\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n {$ENDIF UNITVERSIONING}\r\n\r\nfinalization\r\n FreeAndNil(GlobalClipboard);\r\n {$IFDEF UNITVERSIONING}\r\n UnregisterUnitVersion(HInstance);\r\n {$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n\r\n" }, { "path": "External/Jedi/Jvcl/run/JvClock.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvClock.PAS, released on 2002-07-04.\r\n\r\nThe Initial Developers of the Original Code are: Fedor Koshevnikov, Igor Pavluk and Serge Korolev\r\nCopyright (c) 1997, 1998 Fedor Koshevnikov, Igor Pavluk and Serge Korolev\r\nCopyright (c) 2001,2002 SGB Software\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\n Polaris Software\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvClock.pas 13363 2012-06-18 12:28:20Z obones $\r\n\r\nunit JvClock;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, Messages, Classes, Graphics, Controls,\r\n JvJCLUtils, JvTimer, JvExtComponent, JvExControls;\r\n\r\ntype\r\n TShowClock = (scDigital, scAnalog);\r\n TPaintMode = (pmPaintAll, pmHandPaint);\r\n\r\n TJvClockTime = packed record\r\n Hour: Word;\r\n Minute: Word;\r\n Second: Word;\r\n end;\r\n\r\n TJvGetTimeEvent = procedure(Sender: TObject; var ATime: TDateTime) of object;\r\n TJvGetDateEvent = TJvGetTimeEvent;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvClock = class(TJvCustomPanel, IJvDenySubClassing)\r\n private\r\n FTimer: TJvTimer;\r\n FAutoSize: Boolean;\r\n FShowMode: TShowClock;\r\n FTwelveHour: Boolean;\r\n FLeadingZero: Boolean;\r\n FShowSeconds: Boolean;\r\n FAlarm: TDateTime;\r\n FAlarmEnabled: Boolean;\r\n FHooked: Boolean;\r\n FDotsColor: TColor;\r\n FAlarmWait: Boolean;\r\n FDisplayTime: TJvClockTime;\r\n FClockRect: TRect;\r\n FClockRadius: Longint;\r\n FClockCenter: TPoint;\r\n FOnGetTime: TJvGetTimeEvent;\r\n FOnAlarm: TNotifyEvent;\r\n FShowDate: Boolean;\r\n FOnGetDate: TJvGetDateEvent;\r\n FDateFormat: string;\r\n FFixedTime: TDateTime;\r\n FFixedTimeStored: Boolean;\r\n FSecondsHandColor: TColor;\r\n FMinutesHandColor: TColor;\r\n FHoursHandColor: TColor;\r\n procedure TimerExpired(Sender: TObject);\r\n procedure GetTime(var T: TJvClockTime);\r\n function IsAlarmTime(ATime: TDateTime): Boolean;\r\n procedure SetShowMode(Value: TShowClock);\r\n function GetAlarmElement(Index: Integer): Byte;\r\n procedure SetAlarmElement(Index: Integer; Value: Byte);\r\n procedure SetDotsColor(Value: TColor);\r\n procedure SetTwelveHour(Value: Boolean);\r\n procedure SetLeadingZero(Value: Boolean);\r\n procedure SetShowSeconds(Value: Boolean);\r\n procedure PaintAnalogClock(PaintMode: TPaintMode);\r\n procedure Paint3DFrame(var Rect: TRect);\r\n procedure DrawAnalogFace;\r\n procedure CircleClock(MaxWidth, MaxHeight: Integer);\r\n procedure DrawSecondHand(Pos: Integer);\r\n procedure DrawFatHand(Pos: Integer; HourHand: Boolean);\r\n procedure PaintTimeStr(var Rect: TRect; FullTime: Boolean);\r\n procedure ResizeFont(const Rect: TRect);\r\n procedure ResetAlarm;\r\n procedure CheckAlarm;\r\n procedure SetFixedTime(const Value: TDateTime);\r\n function FormatSettingsChange(var Msg: TMessage): Boolean;\r\n procedure CMCtl3DChanged(var Msg: TMessage); message CM_CTL3DCHANGED;\r\n procedure WMTimeChange(var Msg: TMessage); message WM_TIMECHANGE;\r\n procedure SetShowDate(const Value: Boolean);\r\n procedure SetDateFormat(const Value: string);\r\n procedure CMEnabledChanged(var Message: TMessage); message CM_ENABLEDCHANGED;\r\n procedure SetHoursHandColor(const Value: TColor);\r\n procedure SetMinutesHandColor(const Value: TColor);\r\n procedure SetSecondsHandColor(const Value: TColor);\r\n protected\r\n procedure TextChanged; override;\r\n procedure FontChanged; override;\r\n procedure SetAutoSize(Value: Boolean); override;\r\n procedure Alarm; dynamic;\r\n procedure AlignControls(AControl: TControl; var Rect: TRect); override;\r\n procedure CreateWnd; override;\r\n procedure DestroyWindowHandle; override;\r\n procedure Loaded; override;\r\n procedure Paint; override;\r\n function GetSystemTime: TDateTime; virtual;\r\n function GetSystemDate: TDateTime; virtual;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n procedure SetAlarmTime(AlarmTime: TDateTime);\r\n procedure UpdateClock;\r\n published\r\n property AlarmEnabled: Boolean read FAlarmEnabled write FAlarmEnabled default False;\r\n property AlarmHour: Byte index 1 read GetAlarmElement write SetAlarmElement default 0;\r\n property AlarmMinute: Byte index 2 read GetAlarmElement write SetAlarmElement default 0;\r\n property AlarmSecond: Byte index 3 read GetAlarmElement write SetAlarmElement default 0;\r\n property AutoSize: Boolean read FAutoSize write SetAutoSize default False;\r\n property BevelInner default bvLowered;\r\n property BevelOuter default bvRaised;\r\n property DotsColor: TColor read FDotsColor write SetDotsColor default clTeal;\r\n property DateFormat: string read FDateFormat write SetDateFormat;\r\n property FixedTime: TDateTime read FFixedTime write SetFixedTime stored FFixedTimeStored;\r\n property HoursHandColor: TColor read FHoursHandColor write SetHoursHandColor default clBlack;\r\n property MinutesHandColor: TColor read FMinutesHandColor write SetMinutesHandColor default clBlack;\r\n property SecondsHandColor: TColor read FSecondsHandColor write SetSecondsHandColor default clBlack;\r\n property ShowMode: TShowClock read FShowMode write SetShowMode default scDigital;\r\n property ShowSeconds: Boolean read FShowSeconds write SetShowSeconds default True;\r\n property ShowDate: Boolean read FShowDate write SetShowDate default False;\r\n property TwelveHour: Boolean read FTwelveHour write SetTwelveHour default False;\r\n property LeadingZero: Boolean read FLeadingZero write SetLeadingZero default True;\r\n property Align;\r\n property BevelWidth;\r\n property BorderWidth;\r\n property BorderStyle;\r\n property Anchors;\r\n property Constraints;\r\n property UseDockManager default True;\r\n property DockSite;\r\n property DragKind;\r\n property DragCursor;\r\n property FullRepaint;\r\n property Color;\r\n property Cursor;\r\n property DragMode;\r\n property Enabled;\r\n property Font;\r\n property ParentColor;\r\n property ParentFont;\r\n property ParentShowHint;\r\n property PopupMenu;\r\n property ShowHint;\r\n property Visible;\r\n property OnAlarm: TNotifyEvent read FOnAlarm write FOnAlarm;\r\n property OnGetTime: TJvGetTimeEvent read FOnGetTime write FOnGetTime;\r\n property OnGetDate: TJvGetDateEvent read FOnGetDate write FOnGetDate;\r\n property OnClick;\r\n property OnDblClick;\r\n property OnMouseMove;\r\n property OnMouseDown;\r\n property OnMouseUp;\r\n property OnDragOver;\r\n property OnDragDrop;\r\n property OnEndDrag;\r\n property OnResize;\r\n property OnContextPopup;\r\n property OnStartDrag;\r\n property OnConstrainedResize;\r\n property OnCanResize;\r\n property OnDockDrop;\r\n property OnDockOver;\r\n property OnEndDock;\r\n property OnGetSiteInfo;\r\n property OnStartDock;\r\n property OnUnDock;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvClock.pas $';\r\n Revision: '$Revision: 13363 $';\r\n Date: '$Date: 2012-06-18 14:28:20 +0200 (lun. 18 juin 2012) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n RTLConsts,\r\n {$IFDEF COMPILER7_UP}\r\n SysConst,\r\n {$ENDIF COMPILER7_UP}\r\n SysUtils, Forms, ExtCtrls,\r\n JvThemes, JclSysUtils;\r\n\r\nvar\r\n Registered: Boolean = False;\r\n\r\ntype\r\n PPointArray = ^TPointArray;\r\n TPointArray = array [0..60 * 2 - 1] of TSmallPoint;\r\n\r\nconst\r\n ClockData: array [0..60 * 4 - 1] of Byte = (\r\n $00, $00, $C1, $E0, $44, $03, $EC, $E0, $7F, $06, $6F, $E1,\r\n $A8, $09, $48, $E2, $B5, $0C, $74, $E3, $9F, $0F, $F0, $E4,\r\n $5E, $12, $B8, $E6, $E9, $14, $C7, $E8, $39, $17, $17, $EB,\r\n $48, $19, $A2, $ED, $10, $1B, $60, $F0, $8C, $1C, $4B, $F3,\r\n $B8, $1D, $58, $F6, $91, $1E, $81, $F9, $14, $1F, $BC, $FC,\r\n $40, $1F, $00, $00, $14, $1F, $44, $03, $91, $1E, $7F, $06,\r\n $B8, $1D, $A8, $09, $8C, $1C, $B5, $0C, $10, $1B, $A0, $0F,\r\n $48, $19, $5E, $12, $39, $17, $E9, $14, $E9, $14, $39, $17,\r\n $5E, $12, $48, $19, $9F, $0F, $10, $1B, $B5, $0C, $8C, $1C,\r\n $A8, $09, $B8, $1D, $7F, $06, $91, $1E, $44, $03, $14, $1F,\r\n $00, $00, $3F, $1F, $BC, $FC, $14, $1F, $81, $F9, $91, $1E,\r\n $58, $F6, $B8, $1D, $4B, $F3, $8C, $1C, $60, $F0, $10, $1B,\r\n $A2, $ED, $48, $19, $17, $EB, $39, $17, $C7, $E8, $E9, $14,\r\n $B8, $E6, $5E, $12, $F0, $E4, $9F, $0F, $74, $E3, $B5, $0C,\r\n $48, $E2, $A8, $09, $6F, $E1, $7F, $06, $EC, $E0, $44, $03,\r\n $C1, $E0, $00, $00, $EC, $E0, $BC, $FC, $6F, $E1, $81, $F9,\r\n $48, $E2, $58, $F6, $74, $E3, $4B, $F3, $F0, $E4, $60, $F0,\r\n $B8, $E6, $A2, $ED, $C7, $E8, $17, $EB, $17, $EB, $C7, $E8,\r\n $A2, $ED, $B8, $E6, $61, $F0, $F0, $E4, $4B, $F3, $74, $E3,\r\n $58, $F6, $48, $E2, $81, $F9, $6F, $E1, $BC, $FC, $EC, $E0);\r\n\r\nconst\r\n AlarmSecDelay = 60; { seconds for try alarm event after alarm time occured }\r\n MaxDotWidth = 25; { maximum Hour-marking dot width }\r\n MinDotWidth = 2; { minimum Hour-marking dot width }\r\n MinDotHeight = 1; { minimum Hour-marking dot height }\r\n\r\n { distance from the center of the clock to... }\r\n HourSide = 7; { ...either side of the Hour hand }\r\n MinuteSide = 5; { ...either side of the Minute hand }\r\n HourTip = 60; { ...the tip of the Hour hand }\r\n MinuteTip = 80; { ...the tip of the Minute hand }\r\n SecondTip = 80; { ...the tip of the Second hand }\r\n HourTail = 15; { ...the tail of the Hour hand }\r\n MinuteTail = 20; { ...the tail of the Minute hand }\r\n\r\n { conversion factors }\r\n CirTabScale = 8000; { circle table values scale down value }\r\n MmPerDm = 100; { millimeters per decimeter }\r\n\r\n { number of hand positions on... }\r\n HandPositions = 60; { ...entire clock }\r\n SideShift = (HandPositions div 4); { ...90 degrees of clock }\r\n TailShift = (HandPositions div 2); { ...180 degrees of clock }\r\n\r\nvar\r\n CircleTab: PPointArray;\r\n HRes: Integer; { width of the display (in pixels) }\r\n VRes: Integer; { height of the display (in raster lines) }\r\n AspectH: Longint; { number of pixels per decimeter on the display }\r\n AspectV: Longint; { number of raster lines per decimeter on the display }\r\n\r\n{ Exception routine }\r\n\r\nprocedure InvalidTime(Hour, Min, Sec: Word);\r\nvar\r\n sTime: string;\r\nbegin\r\n sTime := IntToStr(Hour) + JclFormatSettings.TimeSeparator + IntToStr(Min) +\r\n JclFormatSettings.TimeSeparator + IntToStr(Sec);\r\n raise EConvertError.CreateResFmt(@SInvalidTime, [sTime]);\r\nend;\r\n\r\nfunction VertEquiv(L: Integer): Integer;\r\nbegin\r\n VertEquiv := Longint(L) * AspectV div AspectH;\r\nend;\r\n\r\nfunction HorzEquiv(L: Integer): Integer;\r\nbegin\r\n HorzEquiv := Longint(L) * AspectH div AspectV;\r\nend;\r\n\r\nfunction LightColor(Color: TColor): TColor;\r\nvar\r\n L: Longint;\r\n C: array [1..3] of Byte;\r\n I: Byte;\r\nbegin\r\n L := ColorToRGB(Color);\r\n C[1] := GetRValue(L);\r\n C[2] := GetGValue(L);\r\n C[3] := GetBValue(L);\r\n for I := 1 to 3 do\r\n begin\r\n if C[I] = $FF then\r\n begin\r\n Result := clBtnHighlight;\r\n Exit;\r\n end;\r\n if C[I] <> 0 then\r\n if C[I] = $C0 then\r\n C[I] := $FF\r\n else\r\n C[I] := C[I] + $7F;\r\n end;\r\n Result := TColor(RGB(C[1], C[2], C[3]));\r\nend;\r\n\r\nprocedure ClockInit;\r\nvar\r\n Pos: Integer; { hand position Index into the circle table }\r\n vSize: Integer; { height of the display in millimeters }\r\n hSize: Integer; { width of the display in millimeters }\r\n DC: HDC;\r\nbegin\r\n DC := GetDC(HWND_DESKTOP);\r\n try\r\n VRes := GetDeviceCaps(DC, VERTRES);\r\n HRes := GetDeviceCaps(DC, HORZRES);\r\n vSize := GetDeviceCaps(DC, VERTSIZE);\r\n hSize := GetDeviceCaps(DC, HORZSIZE);\r\n finally\r\n ReleaseDC(HWND_DESKTOP, DC);\r\n end;\r\n AspectV := (Longint(VRes) * MmPerDm) div Longint(vSize);\r\n AspectH := (Longint(HRes) * MmPerDm) div Longint(hSize);\r\n CircleTab := PPointArray(@ClockData);\r\n for Pos := 0 to HandPositions - 1 do\r\n CircleTab[Pos].Y := VertEquiv(CircleTab[Pos].Y);\r\nend;\r\n\r\nfunction HourHandPos(T: TJvClockTime): Integer;\r\nbegin\r\n // When drawing the hour hand, only 12 hours are shown, hence the need\r\n // to adjust the time if it goes above, or the hand would not be drawn\r\n // correctly.\r\n if T.Hour >= 12 then\r\n Dec(T.Hour, 12);\r\n\r\n Result := (T.Hour * 5) + (T.Minute div 12);\r\nend;\r\n\r\n{ Digital clock font routine }\r\n\r\nprocedure SetNewFontSize(Canvas: TCanvas; const Text: string;\r\n MaxH, MaxW: Integer);\r\nconst\r\n FHeight = 1000;\r\nvar\r\n Font: TFont;\r\n NewH: Integer;\r\nbegin\r\n Font := Canvas.Font;\r\n { empiric calculate character height by cell height }\r\n MaxH := MulDiv(MaxH, 4, 5);\r\n with Font do\r\n begin\r\n Height := -FHeight;\r\n NewH := MulDiv(FHeight, MaxW, Canvas.TextWidth(Text));\r\n if NewH > MaxH then\r\n NewH := MaxH;\r\n Height := -NewH;\r\n end;\r\nend;\r\n\r\nconstructor TJvClock.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n if not Registered then\r\n begin\r\n ClockInit;\r\n Registered := True;\r\n end;\r\n Caption := TimeToStr(Time);\r\n ControlStyle := ControlStyle - [csSetCaption] - [csReplicatable];\r\n IncludeThemeStyle(Self, [csNeedsBorderPaint, csParentBackground]);\r\n BevelInner := bvLowered;\r\n BevelOuter := bvRaised;\r\n FFixedTimeStored := False;\r\n FTimer := TJvTimer.Create(nil);\r\n FTimer.Interval := 450; { every second }\r\n FTimer.OnTimer := TimerExpired;\r\n FDotsColor := clTeal;\r\n FHoursHandColor := clBlack;\r\n FMinutesHandColor := clBlack;\r\n FSecondsHandColor := clBlack;\r\n FShowSeconds := True;\r\n FLeadingZero := True;\r\n FShowDate := False;\r\n FDateFormat := JclFormatSettings.ShortDateFormat;\r\n GetTime(FDisplayTime);\r\n if FDisplayTime.Hour >= 12 then\r\n Dec(FDisplayTime.Hour, 12);\r\n FAlarmWait := True;\r\n FAlarm := EncodeTime(0, 0, 0, 0);\r\nend;\r\n\r\ndestructor TJvClock.Destroy;\r\nbegin\r\n if FHooked then\r\n begin\r\n Application.UnhookMainWindow(FormatSettingsChange);\r\n FHooked := False;\r\n end;\r\n FTimer.Enabled := True;\r\n FTimer.Free;\r\n\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvClock.Loaded;\r\nbegin\r\n inherited Loaded;\r\n ResetAlarm;\r\nend;\r\n\r\n\r\n\r\nprocedure TJvClock.CreateWnd;\r\nbegin\r\n inherited CreateWnd;\r\n if not (csDesigning in ComponentState) and not (IsLibrary or FHooked) then\r\n begin\r\n Application.HookMainWindow(FormatSettingsChange);\r\n FHooked := True;\r\n end;\r\nend;\r\n\r\nprocedure TJvClock.DestroyWindowHandle;\r\nbegin\r\n if FHooked then\r\n begin\r\n Application.UnhookMainWindow(FormatSettingsChange);\r\n FHooked := False;\r\n end;\r\n inherited DestroyWindowHandle;\r\nend;\r\n\r\nprocedure TJvClock.CMCtl3DChanged(var Msg: TMessage);\r\nbegin\r\n inherited;\r\n if ShowMode = scAnalog then\r\n Invalidate;\r\nend;\r\n\r\n\r\n\r\nprocedure TJvClock.TextChanged;\r\nbegin\r\n { Skip this message, no repaint }\r\nend;\r\n\r\nprocedure TJvClock.FontChanged;\r\nbegin\r\n inherited FontChanged;\r\n Invalidate;\r\n if AutoSize then\r\n Realign;\r\nend;\r\n\r\n\r\n\r\nprocedure TJvClock.WMTimeChange(var Msg: TMessage);\r\nbegin\r\n inherited;\r\n Invalidate;\r\n CheckAlarm;\r\nend;\r\n\r\nfunction TJvClock.FormatSettingsChange(var Msg: TMessage): Boolean;\r\nbegin\r\n Result := False;\r\n case Msg.Msg of\r\n WM_WININICHANGE:\r\n begin\r\n Invalidate;\r\n if AutoSize then\r\n Realign;\r\n end;\r\n end;\r\nend;\r\n\r\n\r\n\r\nfunction TJvClock.GetSystemTime: TDateTime;\r\nbegin\r\n if Enabled then\r\n Result := SysUtils.Time\r\n else\r\n Result := FixedTime;\r\n if Assigned(FOnGetTime) then\r\n FOnGetTime(Self, Result);\r\nend;\r\n\r\nfunction TJvClock.GetSystemDate: TDateTime;\r\nbegin\r\n Result := SysUtils.Date;\r\n if Assigned(FOnGetDate) then\r\n FOnGetDate(Self, Result);\r\nend;\r\n\r\nprocedure TJvClock.GetTime(var T: TJvClockTime);\r\nvar\r\n MSec: Word;\r\nbegin\r\n DecodeTime(GetSystemTime, T.Hour, T.Minute, T.Second, MSec);\r\nend;\r\n\r\nprocedure TJvClock.UpdateClock;\r\nbegin\r\n Invalidate;\r\n if AutoSize then\r\n Realign;\r\n Update;\r\nend;\r\n\r\nprocedure TJvClock.ResetAlarm;\r\nbegin\r\n FAlarmWait := (FAlarm > GetSystemTime) or (FAlarm = 0);\r\nend;\r\n\r\nfunction TJvClock.IsAlarmTime(ATime: TDateTime): Boolean;\r\nvar\r\n Hour, Min, Sec, MSec: Word;\r\n AHour, AMin, ASec: Word;\r\nbegin\r\n DecodeTime(FAlarm, Hour, Min, Sec, MSec);\r\n DecodeTime(ATime, AHour, AMin, ASec, MSec);\r\n Result := {FAlarmWait and} (Hour = AHour) and (Min = AMin) and\r\n (ASec >= Sec) and (ASec <= Sec + AlarmSecDelay);\r\nend;\r\n\r\nprocedure TJvClock.ResizeFont(const Rect: TRect);\r\nvar\r\n H, W: Integer;\r\n DC: HDC;\r\n TimeStr: string;\r\nbegin\r\n H := Rect.Bottom - Rect.Top - 4;\r\n W := (Rect.Right - Rect.Left - 30);\r\n if (H <= 0) or (W <= 0) then\r\n Exit;\r\n DC := GetDC(HWND_DESKTOP);\r\n try\r\n Canvas.Handle := DC;\r\n Canvas.Font := Font;\r\n TimeStr := '88888';\r\n if FShowSeconds then\r\n TimeStr := TimeStr + '888';\r\n if FTwelveHour then\r\n begin\r\n if Canvas.TextWidth(JclFormatSettings.TimeAMString) > Canvas.TextWidth(JclFormatSettings.TimePMString) then\r\n TimeStr := TimeStr + ' ' + JclFormatSettings.TimeAMString\r\n else\r\n TimeStr := TimeStr + ' ' + JclFormatSettings.TimePMString;\r\n end;\r\n SetNewFontSize(Canvas, TimeStr, H, W);\r\n Font := Canvas.Font;\r\n finally\r\n Canvas.Handle := 0;\r\n ReleaseDC(HWND_DESKTOP, DC);\r\n end;\r\nend;\r\n\r\nprocedure TJvClock.AlignControls(AControl: TControl; var Rect: TRect);\r\nvar\r\n InflateWidth: Integer;\r\nbegin\r\n inherited AlignControls(AControl, Rect);\r\n FClockRect := Rect;\r\n InflateWidth := BorderWidth + 1;\r\n if BevelOuter <> bvNone then\r\n Inc(InflateWidth, BevelWidth);\r\n if BevelInner <> bvNone then\r\n Inc(InflateWidth, BevelWidth);\r\n InflateRect(FClockRect, -InflateWidth, -InflateWidth);\r\n CircleClock(FClockRect.Right - FClockRect.Left, FClockRect.Bottom - FClockRect.Top);\r\n if AutoSize then\r\n ResizeFont(Rect);\r\nend;\r\n\r\nprocedure TJvClock.Alarm;\r\nbegin\r\n if Assigned(FOnAlarm) then\r\n FOnAlarm(Self);\r\nend;\r\n\r\nprocedure TJvClock.SetAutoSize(Value: Boolean);\r\nbegin\r\n inherited SetAutoSize(Value);\r\n FAutoSize := Value;\r\n if FAutoSize then\r\n begin\r\n Invalidate;\r\n Realign;\r\n end;\r\nend;\r\n\r\nprocedure TJvClock.SetTwelveHour(Value: Boolean);\r\nbegin\r\n if FTwelveHour <> Value then\r\n begin\r\n FTwelveHour := Value;\r\n Invalidate;\r\n if AutoSize then\r\n Realign;\r\n end;\r\nend;\r\n\r\nprocedure TJvClock.SetLeadingZero(Value: Boolean);\r\nbegin\r\n if FLeadingZero <> Value then\r\n begin\r\n FLeadingZero := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvClock.SetMinutesHandColor(const Value: TColor);\r\nbegin\r\n if FMinutesHandColor <> Value then\r\n begin\r\n FMinutesHandColor := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvClock.SetShowSeconds(Value: Boolean);\r\nbegin\r\n if FShowSeconds <> Value then\r\n begin\r\n {if FShowSeconds and (ShowMode = scAnalog) then\r\n DrawSecondHand(FDisplayTime.Second);}\r\n FShowSeconds := Value;\r\n Invalidate;\r\n if AutoSize then\r\n Realign;\r\n end;\r\nend;\r\n\r\nprocedure TJvClock.SetDotsColor(Value: TColor);\r\nbegin\r\n if Value <> FDotsColor then\r\n begin\r\n FDotsColor := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvClock.SetFixedTime(const Value: TDateTime);\r\nbegin\r\n if FFixedTime <> Value then\r\n begin\r\n // Fixed time is stored if not zero\r\n FFixedTime := Value;\r\n FFixedTimeStored := FFixedTime <> 0;\r\n\r\n // Disable us and ensure the display time is accurate\r\n Enabled := False;\r\n GetTime(FDisplayTime);\r\n\r\n // Force entire redraw.\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvClock.SetHoursHandColor(const Value: TColor);\r\nbegin\r\n if FHoursHandColor <> Value then\r\n begin\r\n FHoursHandColor := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvClock.SetShowMode(Value: TShowClock);\r\nbegin\r\n if FShowMode <> Value then\r\n begin\r\n FShowMode := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvClock.SetSecondsHandColor(const Value: TColor);\r\nbegin\r\n if FSecondsHandColor <> Value then\r\n begin\r\n FSecondsHandColor := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvClock.SetShowDate(const Value: Boolean);\r\nbegin\r\n if FShowDate <> Value then\r\n begin\r\n FShowDate := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvClock.SetDateFormat(const Value: string);\r\nbegin\r\n if FDateFormat <> Value then\r\n begin\r\n FDateFormat := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nfunction TJvClock.GetAlarmElement(Index: Integer): Byte;\r\nvar\r\n Hour, Min, Sec, MSec: Word;\r\nbegin\r\n DecodeTime(FAlarm, Hour, Min, Sec, MSec);\r\n case Index of\r\n 1:\r\n Result := Hour;\r\n 2:\r\n Result := Min;\r\n 3:\r\n Result := Sec;\r\n else\r\n Result := 0;\r\n end;\r\nend;\r\n\r\nprocedure TJvClock.SetAlarmElement(Index: Integer; Value: Byte);\r\nvar\r\n Hour, Min, Sec, MSec: Word;\r\nbegin\r\n DecodeTime(FAlarm, Hour, Min, Sec, MSec);\r\n case Index of\r\n 1:\r\n Hour := Value;\r\n 2:\r\n Min := Value;\r\n 3:\r\n Sec := Value;\r\n else\r\n Exit;\r\n end;\r\n if (Hour < 24) and (Min < 60) and (Sec < 60) then\r\n begin\r\n FAlarm := EncodeTime(Hour, Min, Sec, 0);\r\n ResetAlarm;\r\n end\r\n else\r\n InvalidTime(Hour, Min, Sec);\r\nend;\r\n\r\nprocedure TJvClock.SetAlarmTime(AlarmTime: TDateTime);\r\nvar\r\n Hour, Min, Sec, MSec: Word;\r\nbegin\r\n DecodeTime(FAlarm, Hour, Min, Sec, MSec);\r\n if (Hour < 24) and (Min < 60) and (Sec < 60) then\r\n begin\r\n FAlarm := Frac(AlarmTime);\r\n ResetAlarm;\r\n end\r\n else\r\n InvalidTime(Hour, Min, Sec);\r\nend;\r\n\r\nprocedure TJvClock.TimerExpired(Sender: TObject);\r\nvar\r\n DC: HDC;\r\n Rect: TRect;\r\n InflateWidth: Integer;\r\nbegin\r\n DC := GetDC(Handle);\r\n try\r\n Canvas.Handle := DC;\r\n Canvas.Brush.Color := Color;\r\n Canvas.Font := Font;\r\n Canvas.Pen.Color := Font.Color;\r\n if FShowMode = scAnalog then\r\n PaintAnalogClock(pmHandPaint)\r\n else\r\n begin\r\n Rect := GetClientRect;\r\n InflateWidth := BorderWidth;\r\n if BevelOuter <> bvNone then\r\n Inc(InflateWidth, BevelWidth);\r\n if BevelInner <> bvNone then\r\n Inc(InflateWidth, BevelWidth);\r\n InflateRect(Rect, -InflateWidth, -InflateWidth);\r\n PaintTimeStr(Rect, False);\r\n end;\r\n finally\r\n Canvas.Handle := NullHandle;\r\n ReleaseDC(Handle, DC);\r\n end;\r\n CheckAlarm;\r\nend;\r\n\r\nprocedure TJvClock.CheckAlarm;\r\nbegin\r\n if FAlarmEnabled and IsAlarmTime(GetSystemTime) then\r\n begin\r\n if FAlarmWait then\r\n begin\r\n FAlarmWait := False;\r\n Alarm;\r\n end;\r\n end\r\n else\r\n ResetAlarm;\r\nend;\r\n\r\nprocedure TJvClock.DrawAnalogFace;\r\nvar\r\n Pos, DotHeight, DotWidth: Integer;\r\n DotCenter: TPoint;\r\n R: TRect;\r\n SaveBrush, SavePen: TColor;\r\n MinDots: Boolean;\r\nbegin\r\n DotWidth := (MaxDotWidth * Longint(FClockRect.Right - FClockRect.Left)) div HRes;\r\n DotHeight := VertEquiv(DotWidth);\r\n if DotHeight < MinDotHeight then\r\n DotHeight := MinDotHeight;\r\n if DotWidth < MinDotWidth then\r\n DotWidth := MinDotWidth;\r\n DotCenter.X := DotWidth div 2;\r\n DotCenter.Y := DotHeight div 2;\r\n InflateRect(FClockRect, -DotCenter.Y, -DotCenter.X);\r\n FClockRadius := ((FClockRect.Right - FClockRect.Left) div 2);\r\n FClockCenter.X := FClockRect.Left + FClockRadius;\r\n FClockCenter.Y := FClockRect.Top + ((FClockRect.Bottom - FClockRect.Top) div 2);\r\n InflateRect(FClockRect, DotCenter.Y, DotCenter.X);\r\n SaveBrush := Canvas.Brush.Color;\r\n SavePen := Canvas.Pen.Color;\r\n try\r\n Canvas.Brush.Color := Canvas.Pen.Color;\r\n MinDots := ((DotWidth > MinDotWidth) and (DotHeight > MinDotHeight));\r\n for Pos := 0 to HandPositions - 1 do\r\n begin\r\n R.Top := (CircleTab[Pos].Y * FClockRadius) div CirTabScale + FClockCenter.Y;\r\n R.Left := (CircleTab[Pos].X * FClockRadius) div CirTabScale + FClockCenter.X;\r\n if (Pos mod 5) <> 0 then\r\n begin\r\n if MinDots then\r\n begin\r\n if Ctl3D then\r\n begin\r\n Canvas.Brush.Color := clBtnShadow;\r\n OffsetRect(R, -1, -1);\r\n R.Right := R.Left + 2;\r\n R.Bottom := R.Top + 2;\r\n Canvas.FillRect(R);\r\n Canvas.Brush.Color := clBtnHighlight;\r\n OffsetRect(R, 1, 1);\r\n Canvas.FillRect(R);\r\n Canvas.Brush.Color := Self.Color;\r\n end;\r\n R.Right := R.Left + 1;\r\n R.Bottom := R.Top + 1;\r\n DrawThemedBackground(Self, Canvas, R);\r\n end;\r\n end\r\n else\r\n begin\r\n R.Right := R.Left + DotWidth;\r\n R.Bottom := R.Top + DotHeight;\r\n OffsetRect(R, -DotCenter.X, -DotCenter.Y);\r\n if Ctl3D and MinDots then\r\n with Canvas do\r\n begin\r\n Brush.Color := FDotsColor;\r\n Brush.Style := bsSolid;\r\n DrawThemedBackground(Self, Canvas, R);\r\n Frame3D(Canvas, R, LightColor(FDotsColor), clWindowFrame, 1);\r\n end;\r\n Canvas.Brush.Color := Canvas.Pen.Color;\r\n if not (Ctl3D and MinDots) then\r\n DrawThemedBackground(Self, Canvas, R);\r\n end;\r\n end;\r\n finally\r\n Canvas.Brush.Color := SaveBrush;\r\n Canvas.Pen.Color := SavePen;\r\n end;\r\nend;\r\n\r\nprocedure TJvClock.CircleClock(MaxWidth, MaxHeight: Integer);\r\nvar\r\n ClockHeight: Integer;\r\n ClockWidth: Integer;\r\nbegin\r\n if MaxWidth > HorzEquiv(MaxHeight) then\r\n begin\r\n ClockWidth := HorzEquiv(MaxHeight);\r\n FClockRect.Left := FClockRect.Left + ((MaxWidth - ClockWidth) div 2);\r\n FClockRect.Right := FClockRect.Left + ClockWidth;\r\n end\r\n else\r\n begin\r\n ClockHeight := VertEquiv(MaxWidth);\r\n FClockRect.Top := FClockRect.Top + ((MaxHeight - ClockHeight) div 2);\r\n FClockRect.Bottom := FClockRect.Top + ClockHeight;\r\n end;\r\nend;\r\n\r\nprocedure TJvClock.CMEnabledChanged(var Message: TMessage);\r\nbegin\r\n if FTimer.Enabled <> Enabled then\r\n begin\r\n FTimer.Enabled := Enabled;\r\n if not Enabled and not FFixedTimeStored then\r\n FFixedTime := Now;\r\n\r\n // Ensure the display time is accurate and force redraw\r\n GetTime(FDisplayTime);\r\n Invalidate;\r\n end;\r\n\r\n inherited;\r\nend;\r\n\r\nprocedure TJvClock.DrawSecondHand(Pos: Integer);\r\nvar\r\n Radius: Longint;\r\n SaveMode: TPenMode;\r\nbegin\r\n Radius := (FClockRadius * SecondTip) div 100;\r\n SaveMode := Canvas.Pen.Mode;\r\n try\r\n Canvas.Pen.Mode := pmCopy;\r\n Canvas.MoveTo(FClockCenter.X, FClockCenter.Y);\r\n Canvas.LineTo(FClockCenter.X + ((CircleTab[Pos].X * Radius) div\r\n CirTabScale), FClockCenter.Y + ((CircleTab[Pos].Y * Radius) div\r\n CirTabScale));\r\n finally\r\n Canvas.Pen.Mode := SaveMode;\r\n end;\r\nend;\r\n\r\nprocedure TJvClock.DrawFatHand(Pos: Integer; HourHand: Boolean);\r\nvar\r\n ptSide, ptTail, ptTip: TPoint;\r\n Index, Hand: Integer;\r\n Scale: Longint;\r\n SaveMode: TPenMode;\r\nbegin\r\n if HourHand then\r\n Hand := HourSide\r\n else\r\n Hand := MinuteSide;\r\n\r\n Scale := (FClockRadius * Hand) div 100;\r\n Index := (Pos + SideShift) mod HandPositions;\r\n ptSide.Y := (CircleTab[Index].Y * Scale) div CirTabScale;\r\n ptSide.X := (CircleTab[Index].X * Scale) div CirTabScale;\r\n if HourHand then\r\n Hand := HourTip\r\n else\r\n Hand := MinuteTip;\r\n Scale := (FClockRadius * Hand) div 100;\r\n ptTip.Y := (CircleTab[Pos].Y * Scale) div CirTabScale;\r\n ptTip.X := (CircleTab[Pos].X * Scale) div CirTabScale;\r\n if HourHand then\r\n Hand := HourTail\r\n else\r\n Hand := MinuteTail;\r\n Scale := (FClockRadius * Hand) div 100;\r\n Index := (Pos + TailShift) mod HandPositions;\r\n ptTail.Y := (CircleTab[Index].Y * Scale) div CirTabScale;\r\n ptTail.X := (CircleTab[Index].X * Scale) div CirTabScale;\r\n with Canvas do\r\n begin\r\n SaveMode := Pen.Mode;\r\n Pen.Mode := pmCopy;\r\n try\r\n MoveTo(FClockCenter.X + ptSide.X, FClockCenter.Y + ptSide.Y);\r\n LineTo(FClockCenter.X + ptTip.X, FClockCenter.Y + ptTip.Y);\r\n MoveTo(FClockCenter.X - ptSide.X, FClockCenter.Y - ptSide.Y);\r\n LineTo(FClockCenter.X + ptTip.X, FClockCenter.Y + ptTip.Y);\r\n MoveTo(FClockCenter.X + ptSide.X, FClockCenter.Y + ptSide.Y);\r\n LineTo(FClockCenter.X + ptTail.X, FClockCenter.Y + ptTail.Y);\r\n MoveTo(FClockCenter.X - ptSide.X, FClockCenter.Y - ptSide.Y);\r\n LineTo(FClockCenter.X + ptTail.X, FClockCenter.Y + ptTail.Y);\r\n finally\r\n Pen.Mode := SaveMode;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvClock.PaintAnalogClock(PaintMode: TPaintMode);\r\nvar\r\n NewTime: TJvClockTime;\r\nbegin\r\n Canvas.Pen.Color := Font.Color;\r\n Canvas.Brush.Color := Color;\r\n SetBkMode(Canvas.Handle, TRANSPARENT);\r\n if PaintMode = pmPaintAll then\r\n begin\r\n with Canvas do\r\n begin\r\n DrawThemedBackground(Self, Canvas, FClockRect);\r\n Pen.Color := Self.Font.Color;\r\n DrawAnalogFace;\r\n Pen.Color := HoursHandColor;\r\n DrawFatHand(HourHandPos(FDisplayTime), True);\r\n Pen.Color := MinutesHandColor;\r\n DrawFatHand(FDisplayTime.Minute, False);\r\n Pen.Color := Brush.Color;\r\n if ShowSeconds then\r\n begin\r\n Pen.Color := SecondsHandColor;\r\n DrawSecondHand(FDisplayTime.Second);\r\n end;\r\n end;\r\n end\r\n else\r\n begin\r\n with Canvas do\r\n begin\r\n GetTime(NewTime);\r\n\r\n if NewTime.Hour >= 12 then\r\n Dec(NewTime.Hour, 12);\r\n\r\n // Erase seconds if needed\r\n Pen.Color := Brush.Color;\r\n if (NewTime.Second <> FDisplayTime.Second) then\r\n if ShowSeconds then\r\n DrawSecondHand(FDisplayTime.Second);\r\n\r\n // Erase minutes and hours if needed\r\n if ((NewTime.Minute <> FDisplayTime.Minute) or\r\n (NewTime.Hour <> FDisplayTime.Hour)) then\r\n begin\r\n DrawFatHand(FDisplayTime.Minute, False);\r\n DrawFatHand(HourHandPos(FDisplayTime), True);\r\n end;\r\n\r\n // Draw minutes and hours if at least something changed so that we avoid\r\n // drawing on top of the seconds hand if it has not changed position.\r\n if ((NewTime.Minute <> FDisplayTime.Minute) or\r\n (NewTime.Hour <> FDisplayTime.Hour) or\r\n (NewTime.Second <> FDisplayTime.Second)) then\r\n begin\r\n Pen.Color := MinutesHandColor;\r\n DrawFatHand(NewTime.Minute, False);\r\n Pen.Color := HoursHandColor;\r\n DrawFatHand(HourHandPos(NewTime), True);\r\n end;\r\n\r\n // Draw seconds if required\r\n Pen.Color := Brush.Color;\r\n if (NewTime.Second <> FDisplayTime.Second) then\r\n begin\r\n if ShowSeconds then\r\n begin\r\n Pen.Color := SecondsHandColor;\r\n DrawSecondHand(NewTime.Second);\r\n end;\r\n FDisplayTime := NewTime;\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvClock.PaintTimeStr(var Rect: TRect; FullTime: Boolean);\r\nvar\r\n FontHeight, FontWidth, FullWidth, I, L, H: Integer;\r\n TimeStr, DateStr, SAmPm: string;\r\n NewTime: TJvClockTime;\r\n\r\n function IsPartSym(Idx, Num: Byte): Boolean;\r\n var\r\n TwoSymHour: Boolean;\r\n begin\r\n TwoSymHour := (H >= 10) or FLeadingZero;\r\n case Idx of\r\n 1: {hours}\r\n Result := True;\r\n 2: {minutes}\r\n if TwoSymHour then\r\n Result := (Num in [4, 5])\r\n else\r\n Result := (Num in [3, 4]);\r\n 3: {seconds}\r\n if TwoSymHour then\r\n Result := FShowSeconds and (Num in [7, 8])\r\n else\r\n Result := FShowSeconds and (Num in [6, 7]);\r\n else\r\n Result := False;\r\n end;\r\n end;\r\n\r\n procedure DrawSym(Sym: Char; Num: Byte);\r\n begin\r\n if FullTime or\r\n ((NewTime.Second <> FDisplayTime.Second) and IsPartSym(3, Num)) or\r\n ((NewTime.Minute <> FDisplayTime.Minute) and IsPartSym(2, Num)) or\r\n (NewTime.Hour <> FDisplayTime.Hour) then\r\n begin\r\n DrawThemedBackground(Self, Canvas, Rect);\r\n SetBkMode(Canvas.Handle, Windows.TRANSPARENT);\r\n DrawText(Canvas, Sym, 1, Rect, DT_EXPANDTABS or\r\n DT_VCENTER or DT_CENTER or DT_NOCLIP or DT_SINGLELINE);\r\n end;\r\n end;\r\n\r\nbegin\r\n GetTime(NewTime);\r\n H := NewTime.Hour;\r\n if NewTime.Hour >= 12 then\r\n Dec(NewTime.Hour, 12);\r\n if FTwelveHour then\r\n begin\r\n if H > 12 then\r\n Dec(H, 12)\r\n else\r\n if H = 0 then\r\n H := 12;\r\n end;\r\n if (not FullTime) and (NewTime.Hour <> FDisplayTime.Hour) then\r\n begin\r\n Repaint;\r\n Exit;\r\n end;\r\n if FLeadingZero then\r\n TimeStr := 'hh:mm'\r\n else\r\n TimeStr := 'h:mm';\r\n if FShowSeconds then\r\n TimeStr := TimeStr + ':ss';\r\n if FTwelveHour then\r\n TimeStr := TimeStr + ' am/pm';\r\n TimeStr := FormatDateTime(TimeStr, GetSystemTime);\r\n if (H >= 10) or FLeadingZero then\r\n L := 5\r\n else\r\n L := 4;\r\n if FShowSeconds then\r\n Inc(L, 3);\r\n SAmPm := Copy(TimeStr, L + 1, MaxInt);\r\n with Canvas do\r\n begin\r\n Font := Self.Font;\r\n FontHeight := TextHeight('8');\r\n FontWidth := TextWidth('8');\r\n FullWidth := TextWidth(SAmPm) + (L * FontWidth);\r\n if ShowDate then\r\n FullWidth := FullWidth + (Length(DateFormat) + 1) * FontWidth;\r\n Rect.Left := ((Rect.Right + Rect.Left) - FullWidth) div 2;\r\n Rect.Right := Rect.Left + FullWidth;\r\n Rect.Top := ((Rect.Bottom + Rect.Top) - FontHeight) div 2;\r\n Rect.Bottom := Rect.Top + FontHeight;\r\n Brush.Color := Color;\r\n if ShowDate then\r\n begin\r\n DateStr := FormatDateTime(DateFormat + ' ', GetSystemDate);\r\n DrawText(Canvas, PChar(DateStr), Length(DateStr), Rect,\r\n DT_EXPANDTABS or DT_VCENTER or DT_NOCLIP or DT_SINGLELINE);\r\n Inc(Rect.Left, Length(DateFormat) * FontWidth);\r\n end;\r\n for I := 1 to L do\r\n begin\r\n Rect.Right := Rect.Left + FontWidth;\r\n DrawSym(TimeStr[I], I);\r\n Inc(Rect.Left, FontWidth);\r\n end;\r\n if FullTime or (NewTime.Hour <> FDisplayTime.Hour) then\r\n begin\r\n Rect.Right := Rect.Left + TextWidth(SAmPm);\r\n DrawText(Canvas, PChar(SAmPm), Length(SAmPm), Rect,\r\n DT_EXPANDTABS or DT_VCENTER or DT_NOCLIP or DT_SINGLELINE);\r\n end;\r\n end;\r\n FDisplayTime := NewTime;\r\nend;\r\n\r\nprocedure TJvClock.Paint3DFrame(var Rect: TRect);\r\nvar\r\n TopColor, BottomColor: TColor;\r\n\r\n procedure AdjustColors(Bevel: TPanelBevel);\r\n begin\r\n TopColor := clBtnHighlight;\r\n if Bevel = bvLowered then\r\n TopColor := clBtnShadow;\r\n BottomColor := clBtnShadow;\r\n if Bevel = bvLowered then\r\n BottomColor := clBtnHighlight;\r\n end;\r\n\r\nbegin\r\n Rect := GetClientRect;\r\n with Canvas do\r\n begin\r\n Brush.Color := Color;\r\n DrawThemedBackground(Self, Canvas, Rect);\r\n end;\r\n if BevelOuter <> bvNone then\r\n begin\r\n AdjustColors(BevelOuter);\r\n Frame3D(Canvas, Rect, TopColor, BottomColor, BevelWidth);\r\n end;\r\n InflateRect(Rect, -BorderWidth, -BorderWidth);\r\n if BevelInner <> bvNone then\r\n begin\r\n AdjustColors(BevelInner);\r\n Frame3D(Canvas, Rect, TopColor, BottomColor, BevelWidth);\r\n end;\r\nend;\r\n\r\nprocedure TJvClock.Paint;\r\nvar\r\n R: TRect;\r\nbegin\r\n Paint3DFrame(R);\r\n case FShowMode of\r\n scDigital:\r\n PaintTimeStr(R, True);\r\n scAnalog:\r\n PaintAnalogClock(pmPaintAll);\r\n end;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvColorBox.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvColorBox.PAS, released on 2002-05-26.\r\n\r\nThe Initial Developer of the Original Code is Peter Thrnqvist [peter3 at sourceforge dot net]\r\nPortions created by Peter Thrnqvist are Copyright (C) 2002 Peter Thrnqvist.\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nDescription:\r\n TJvColorBox:\r\n A color selectionbox that works just like the one in Win95/NT 4.0\r\n\r\n TJvDropButton:\r\n A CustomControl with droparrow:\r\n assign a TPopUpMenu to the DropDown property and the menu will be shown when the\r\n button is clicked\r\n\r\n ...combine the two and you get:\r\n\r\n TColorButton:\r\n A button that looks and behaves like the one in Win95 / NT 4.0\r\n -> this has been moved to another unit, ColorBtn\r\n\r\n only the TColorButton is installed, but changing the Register procedure\r\n would allow for the others to be installed too\r\n It's your choice...\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvColorBox.pas 13104 2011-09-07 06:50:43Z obones $\r\n\r\nunit JvColorBox;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, Messages, Classes, Graphics, Controls, Forms, Menus, Types,\r\n JvComponent;\r\n\r\ntype\r\n TJvColorClickEvent = procedure(Sender: TObject; Button: TMouseButton;\r\n Shift: TShiftState; Color: TColor) of object;\r\n\r\n { a square with a sunken frame and a color, sets Color when clicked\r\n draws a frame when active (MouseEnter) }\r\n TJvColorSquare = class(TJvGraphicControl)\r\n private\r\n FInside: Boolean;\r\n FBorderStyle: TBorderStyle;\r\n FOnChange: TNotifyEvent;\r\n FColorClick: TJvColorClickEvent;\r\n procedure SetBorderStyle(Value: TBorderStyle);\r\n protected\r\n procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;\r\n procedure MouseEnter(Control: TControl); override;\r\n procedure MouseLeave(Control: TControl); override;\r\n procedure ColorChanged; override;\r\n procedure Paint; override;\r\n procedure DrawFocusFrame;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n published\r\n property Color default clWhite;\r\n property BorderStyle: TBorderStyle read FBorderStyle write SetBorderStyle;\r\n property OnChange: TNotifyEvent read FOnChange write FOnChange;\r\n property OnColorClick: TJvColorClickEvent read FColorClick write FColorClick;\r\n property OnClick;\r\n property OnDblClick;\r\n property OnMouseDown;\r\n property OnMouseMove;\r\n property OnMouseUp;\r\n end;\r\n\r\n { a window with 20 Color squares and a button that activates a TColorDialog... }\r\n TJvColorBox = class(TJvCustomControl)\r\n private\r\n FColorClick: TJvColorClickEvent;\r\n FBorderStyle: TBorderStyle;\r\n FSquares: array [1..20] of TJvColorSquare;\r\n procedure SetBorderStyle(Value: TBorderStyle);\r\n procedure DrawColorBoxes;\r\n protected\r\n procedure Paint; override;\r\n procedure ColorClicked(Sender: TObject; Button: TMouseButton; Shift: TShiftState; Color: TColor);\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n published\r\n property Align;\r\n property BorderStyle: TBorderStyle read FBorderStyle write SetBorderStyle default bsSingle;\r\n property Visible;\r\n property Top;\r\n property Width default 78;\r\n property Height default 96;\r\n property Left;\r\n property Enabled;\r\n property OnEnter;\r\n property OnExit;\r\n property OnClick;\r\n property OnColorClick: TJvColorClickEvent read FColorClick write FColorClick;\r\n property OnKeyDown;\r\n property OnKeyUp;\r\n end;\r\n\r\n TJvCustomDropButton = class(TJvCustomControl)\r\n private\r\n FDropDown: TPopupMenu;\r\n FIsDown: Boolean;\r\n FArrowWidth: Integer;\r\n procedure SetArrowWidth(Value: Integer);\r\n procedure SetDropDown(Value: TPopupMenu);\r\n procedure CMSysColorChange(var Msg: TMessage); message CM_SYSCOLORCHANGE;\r\n protected\r\n procedure Resize; override;\r\n procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;\r\n procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;\r\n procedure MouseEnter(Control: TControl); override;\r\n procedure MouseLeave(Control: TControl); override;\r\n procedure EnabledChanged; override;\r\n procedure Paint; override;\r\n property DropDown: TPopupMenu read FDropDown write SetDropDown;\r\n property ArrowWidth: Integer read FArrowWidth write SetArrowWidth default 13;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n end;\r\n\r\n TJvDropButton = class(TJvCustomDropButton)\r\n published\r\n property ArrowWidth;\r\n property DropDown;\r\n property OnEnter;\r\n property OnExit;\r\n property OnClick;\r\n property OnDblClick;\r\n property OnMouseDown;\r\n property OnMouseMove;\r\n property OnMouseUp;\r\n property OnKeyDown;\r\n property OnKeyUp;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvColorBox.pas $';\r\n Revision: '$Revision: 13104 $';\r\n Date: '$Date: 2011-09-07 08:50:43 +0200 (mer. 07 sept. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n ExtCtrls, Buttons,\r\n JvThemes;\r\n\r\nconst\r\n // (rom) nonstandard colors renamed\r\n clPrivateBeige = TColor($C6DEC6);\r\n clPrivateSky = TColor($F7CEA5);\r\n clPrivateCream = TColor($F7FFFF);\r\n\r\n Colors: array [1..20] of TColor =\r\n (clWhite, clBlack, clSilver, clDkGray,\r\n clRed, clMaroon, clYellow, clOlive,\r\n clLime, clGreen, clAqua, clTeal,\r\n clBlue, clNavy, clFuchsia, clPurple,\r\n clPrivateBeige, clPrivateSky, clPrivateCream, clGray);\r\n\r\nprocedure DrawLine(Canvas: TCanvas; X, Y, X2, Y2: Integer);\r\nbegin\r\n Canvas.MoveTo(X, Y);\r\n Canvas.LineTo(X2, Y2);\r\nend;\r\n\r\n//=== { TJvColorSquare } =====================================================\r\n\r\nconstructor TJvColorSquare.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FBorderStyle := bsSingle;\r\n Color := clWhite;\r\n Width := 18;\r\n Height := 18;\r\n FInside := False;\r\nend;\r\n\r\nprocedure TJvColorSquare.SetBorderStyle(Value: TBorderStyle);\r\nbegin\r\n if FBorderStyle <> Value then\r\n begin\r\n FBorderStyle := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvColorSquare.Paint;\r\nvar\r\n Rect: TRect;\r\nbegin\r\n Rect := ClientRect;\r\n if FBorderStyle = bsSingle then\r\n begin\r\n Frame3D(Canvas, Rect, clBtnFace, clBtnFace, 1);\r\n Frame3D(Canvas, Rect, clBtnShadow, clBtnHighLight, 1);\r\n Frame3D(Canvas, Rect, cl3DDkShadow, clBtnFace, 1);\r\n end;\r\n\r\n with Canvas do\r\n begin\r\n Brush.Color := Self.Color;\r\n Brush.Style := bsSolid;\r\n FillRect(Rect);\r\n end;\r\n DrawFocusFrame;\r\nend;\r\n\r\nprocedure TJvColorSquare.DrawFocusFrame;\r\nvar\r\n Rect: TRect;\r\nbegin\r\n if FInside and Enabled then\r\n begin\r\n Rect := ClientRect;\r\n Frame3D(Canvas, Rect, cl3DDkShadow, cl3DDkShadow, 1);\r\n Frame3D(Canvas, Rect, clBtnHighLight, clBtnHighLight, 1);\r\n Frame3D(Canvas, Rect, cl3DDkShadow, cl3DDkShadow, 1);\r\n end;\r\nend;\r\n\r\nprocedure TJvColorSquare.MouseEnter(Control: TControl);\r\nbegin\r\n inherited MouseEnter(Control);\r\n FInside := True;\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvColorSquare.MouseLeave(Control: TControl);\r\nbegin\r\n inherited MouseLeave(Control);\r\n FInside := False;\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvColorSquare.MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);\r\nbegin\r\n inherited MouseUp(Button, Shift, X, Y);\r\n if Assigned(FColorClick) then\r\n FColorClick(Self, Button, Shift, Color);\r\nend;\r\n\r\n//=== { TJvColorBox } ========================================================\r\n\r\nconstructor TJvColorBox.Create(AOwner: TComponent);\r\nvar\r\n I: Integer;\r\nbegin\r\n inherited Create(AOwner);\r\n Width := 78;\r\n Height := 96;\r\n FBorderStyle := bsSingle;\r\n\r\n for I := Low(FSquares) to High(FSquares) do\r\n begin\r\n FSquares[I] := TJvColorSquare.Create(Self);\r\n FSquares[I].BorderStyle := FBorderStyle;\r\n FSquares[I].Parent := Self;\r\n FSquares[I].OnColorClick := ColorClicked;\r\n FSquares[I].Color := Colors[I];\r\n end;\r\nend;\r\n\r\nprocedure TJvColorBox.DrawColorBoxes;\r\nvar\r\n I, X, Y, W, H: Integer;\r\nconst\r\n Offset = 3;\r\nbegin\r\n X := Offset;\r\n Y := Offset;\r\n W := (Width - 4) div 4;\r\n H := (Height - 4) div 5;\r\n for I := 1 to 20 do\r\n begin\r\n FSquares[I].SetBounds(X, Y, W, H);\r\n Inc(X, W);\r\n if I mod 4 = 0 then\r\n begin\r\n Inc(Y, H);\r\n X := Offset;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvColorBox.ColorClicked(Sender: TObject; Button: TMouseButton;\r\n Shift: TShiftState; Color: TColor);\r\nbegin\r\n if Assigned(FColorClick) then\r\n FColorClick(Self, Button, Shift, Color);\r\nend;\r\n\r\nprocedure TJvColorBox.SetBorderStyle(Value: TBorderStyle);\r\nvar\r\n I: Integer;\r\nbegin\r\n if FBorderStyle <> Value then\r\n begin\r\n FBorderStyle := Value;\r\n for I := Low(FSquares) to High(FSquares) do\r\n FSquares[I].BorderStyle := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvColorBox.Paint;\r\nvar\r\n Rect: TRect;\r\nbegin\r\n Rect := ClientRect;\r\n { frame }\r\n if FBorderStyle = bsSingle then\r\n begin\r\n Frame3D(Canvas, Rect, clBtnFace, cl3DDkShadow, 1);\r\n Frame3D(Canvas, Rect, clBtnHighLight, clBtnShadow, 1);\r\n Frame3D(Canvas, Rect, clBtnFace, clBtnFace, 1);\r\n end\r\n else\r\n begin\r\n Frame3D(Canvas, Rect, clBtnFace, clBtnFace, 1);\r\n Frame3D(Canvas, Rect, clBtnShadow, clBtnHighLight, 1);\r\n Frame3D(Canvas, Rect, cl3DDkShadow, clBtnFace, 1);\r\n end;\r\n\r\n { color squares }\r\n DrawColorBoxes;\r\nend;\r\n\r\n//=== { TJvCustomDropButton } ================================================\r\n\r\nconstructor TJvCustomDropButton.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n ControlStyle := ControlStyle + [csSetCaption];\r\n IncludeThemeStyle(Self, [csParentBackground]);\r\n FArrowWidth := 13;\r\n Width := 42;\r\n Height := 21;\r\nend;\r\n\r\nprocedure TJvCustomDropButton.MouseDown(Button: TMouseButton; Shift: TShiftState;\r\n X, Y: Integer);\r\nbegin\r\n FIsDown := True;\r\n inherited MouseDown(Button, Shift, X, Y);\r\nend;\r\n\r\nprocedure TJvCustomDropButton.MouseUp(Button: TMouseButton; Shift: TShiftState;\r\n X, Y: Integer);\r\nvar\r\n Pt: TPoint;\r\nbegin\r\n FIsDown := False;\r\n inherited MouseUp(Button, Shift, X, Y);\r\n if Assigned(FDropDown) then\r\n begin\r\n Pt := ClientToScreen(Point(0, Height));\r\n FDropDown.Popup(Pt.X, Pt.Y);\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomDropButton.SetArrowWidth(Value: Integer);\r\nbegin\r\n if FArrowWidth <> Value then\r\n begin\r\n FArrowWidth := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomDropButton.SetDropDown(Value: TPopupMenu);\r\nbegin\r\n FDropDown := Value;\r\nend;\r\n\r\nprocedure TJvCustomDropButton.MouseEnter(Control: TControl);\r\nbegin\r\n inherited MouseEnter(Control);\r\n {$IFDEF JVCLThemesEnabled}\r\n if ThemeServices.{$IFDEF RTL230_UP}Enabled{$ELSE}ThemesEnabled{$ENDIF RTL230_UP} and Enabled and not (csDesigning in ComponentState) then\r\n Invalidate;\r\n {$ENDIF JVCLThemesEnabled}\r\nend;\r\n\r\nprocedure TJvCustomDropButton.MouseLeave(Control: TControl);\r\nbegin\r\n inherited MouseLeave(Control);\r\n {$IFDEF JVCLThemesEnabled}\r\n if ThemeServices.{$IFDEF RTL230_UP}Enabled{$ELSE}ThemesEnabled{$ENDIF RTL230_UP} and Enabled and not (csDesigning in ComponentState) then\r\n Invalidate;\r\n {$ENDIF JVCLThemesEnabled}\r\nend;\r\n\r\nprocedure TJvCustomDropButton.Paint;\r\nvar\r\n Rec: TRect;\r\n Increment: Integer;\r\nbegin\r\n { Draw the button face }\r\n DrawThemedButtonFace(Self, Canvas, ClientRect, 1, bsAutoDetect, False,\r\n FIsDown, Focused, IsMouseOver(Self) and not (csDesigning in ComponentState));\r\n\r\n Increment := Ord(FIsDown);\r\n Rec := ClientRect;\r\n Rec.Left := Width - FArrowWidth;\r\n OffsetRect(Rec, Increment, Increment);\r\n\r\n { Draw vertical 'bar' }\r\n Canvas.Pen.Color := clBtnShadow;\r\n DrawLine(Canvas, Rec.Left, Rec.Top + 4, Rec.Left, Rec.Bottom - 4);\r\n Canvas.Pen.Color := clBtnHighlight;\r\n DrawLine(Canvas, Rec.Left + 1, Rec.Top + 4, Rec.Left + 1, Rec.Bottom - 4);\r\n\r\n { Draw arrow }\r\n if not Enabled then\r\n Canvas.Pen.Color := clBtnShadow\r\n else\r\n Canvas.Pen.Color := clWindowText; // cl3DDkShadow\r\n\r\n Rec.Bottom := (Height div 2) + Increment - 1;\r\n InflateRect(Rec, -4, 0);\r\n\r\n while Rec.Left < Rec.Right + 1 do\r\n begin\r\n DrawLine(Canvas, Rec.Left, Rec.Bottom, Rec.Right, Rec.Bottom);\r\n InflateRect(Rec, -1, 1);\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomDropButton.EnabledChanged;\r\nbegin\r\n inherited EnabledChanged;\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvCustomDropButton.CMSysColorChange(var Msg: TMessage);\r\nbegin\r\n inherited;\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvCustomDropButton.Resize;\r\nbegin\r\n inherited Resize;\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvColorSquare.ColorChanged;\r\nbegin\r\n inherited ColorChanged;\r\n if Assigned(FOnChange) then\r\n FOnChange(Self);\r\n Invalidate;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvColorButton.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvColorBtn.PAS, released on 2002-05-26.\r\n\r\nThe Initial Developer of the Original Code is Peter Thrnqvist [peter3 at sourceforge dot net]\r\nPortions created by Peter Thrnqvist are Copyright (C) 2002 Peter Thrnqvist.\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nDescription:\r\n A color selection button that mimicks the one on the 'Display Properties' page in Win95/NT4\r\n\r\nKnown Issues:\r\n If the OtherCaption is set to an empty string, the default '&Other..' magically appears.\r\n Solution: Set OtherCaption to ' ' instead\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvColorButton.pas 13358 2012-06-18 09:33:44Z obones $\r\n\r\nunit JvColorButton;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, Messages, Classes, Graphics, Controls, Forms, Dialogs,\r\n JvConsts, JvColorBox, JvComponent;\r\n\r\ntype\r\n TJvColorButtonPaletteShowing = procedure(var CanShowPalette: Boolean) of object;\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvColorButton = class(TJvCustomDropButton)\r\n private\r\n FColorForm: TJvForm;\r\n FIsDown: Boolean;\r\n FOtherCaption: string;\r\n FOnChange: TNotifyEvent;\r\n FCustomColors: TStringList;\r\n FEdgeWidth: Integer;\r\n FColor: TColor;\r\n FButtonShowsPalette: Boolean;\r\n FOnPaletteShowing: TJvColorButtonPaletteShowing;\r\n protected\r\n FOptions: TColorDialogOptions;\r\n procedure SetOptions(Value: TColorDialogOptions);\r\n function GetCustomColors: TStrings;\r\n procedure SetEdgeWidth(Value: Integer);\r\n procedure SetCustomColors(Value: TStrings);\r\n procedure SetOtherCaption(Value: string);\r\n procedure SetColor(const Value: TColor);\r\n protected\r\n procedure CMPopupCloseUp(var Msg: TMessage); message CM_POPUPCLOSEUP;\r\n procedure CMCancelMode(var Msg: TCMCancelMode); message CM_CANCELMODE;\r\n procedure KeyDown(var Key: Word; Shift: TShiftState); override;\r\n procedure KeyUp(var Key: Word; Shift: TShiftState); override;\r\n procedure MouseDown(Button: TMouseButton; Shift: TShiftState;\r\n X, Y: Integer); override;\r\n procedure MouseUp(Button: TMouseButton; Shift: TShiftState;\r\n X, Y: Integer); override;\r\n procedure Paint; override;\r\n procedure ShowColorPopup(Button: TMouseButton; Shift: TShiftState;\r\n X, Y: Integer); virtual;\r\n procedure PopupCloseUp; dynamic;\r\n procedure FocusKilled(NextWnd: THandle); override;\r\n procedure DoPaletteShowing(var CanShowPalette: Boolean);\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n published\r\n property ArrowWidth;\r\n property OtherCaption: string read FOtherCaption write SetOtherCaption;\r\n property EdgeWidth: Integer read FEdgeWidth write SetEdgeWidth default 4;\r\n property ButtonShowsPalette: Boolean read FButtonShowsPalette write FButtonShowsPalette default True;\r\n property Options: TColorDialogOptions read FOptions write SetOptions;\r\n property CustomColors: TStrings read GetCustomColors write SetCustomColors;\r\n property Color: TColor read FColor write SetColor default clBlack;\r\n property Height default 21;\r\n property Width default 42;\r\n property OnChange: TNotifyEvent read FOnChange write FOnChange;\r\n property OnPaletteShowing: TJvColorButtonPaletteShowing read FOnPaletteShowing write FOnPaletteShowing;\r\n\r\n property Action;\r\n property Align;\r\n property Anchors;\r\n property Constraints;\r\n property DragCursor;\r\n property DragKind;\r\n property DragMode;\r\n property Enabled;\r\n property ParentBiDiMode;\r\n property ParentShowHint;\r\n property PopupMenu;\r\n property ShowHint;\r\n property TabOrder;\r\n property TabStop default True;\r\n property Visible;\r\n property OnClick;\r\n property OnContextPopup;\r\n property OnDblClick;\r\n property OnDragDrop;\r\n property OnDragOver;\r\n property OnEndDock;\r\n property OnEndDrag;\r\n property OnEnter;\r\n property OnExit;\r\n property OnKeyDown;\r\n property OnKeyPress;\r\n property OnKeyUp;\r\n property OnMouseDown;\r\n property OnMouseEnter;\r\n property OnMouseLeave;\r\n property OnMouseMove;\r\n property OnMouseUp;\r\n property OnStartDock;\r\n property OnStartDrag;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvColorButton.pas $';\r\n Revision: '$Revision: 13358 $';\r\n Date: '$Date: 2012-06-18 11:33:44 +0200 (lun. 18 juin 2012) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n SysUtils, ExtCtrls,\r\n JvColorForm, JvResources;\r\n\r\nconstructor TJvColorButton.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n TabStop := True;\r\n FOptions := [];\r\n FCustomColors := TStringList.Create;\r\n Color := clBlack;\r\n FEdgeWidth := 4;\r\n Width := 42;\r\n Height := 21;\r\n FButtonShowsPalette := True;\r\n FColorForm := TJvColorForm.CreateNew(Self);\r\n TJvColorForm(FColorForm).SetButton(Self);\r\n FOtherCaption := RsOtherCaption;\r\n FColorForm.Visible := False;\r\nend;\r\n\r\ndestructor TJvColorButton.Destroy;\r\nbegin\r\n FCustomColors.Free;\r\n FreeAndNil(FColorForm);\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvColorButton.DoPaletteShowing(var CanShowPalette: Boolean);\r\nbegin\r\n if Assigned(OnPaletteShowing) then\r\n OnPaletteShowing(CanShowPalette);\r\nend;\r\n\r\nprocedure TJvColorButton.FocusKilled(NextWnd: THandle);\r\nvar\r\n Sender: TWinControl;\r\n Focused: Boolean;\r\nbegin\r\n inherited FocusKilled(NextWnd);\r\n Focused := Screen.ActiveControl <> Self;\r\n if not Focused then\r\n begin\r\n Sender := FindControl(NextWnd);\r\n if (Sender <> Self) and (Sender <> FColorForm) and\r\n Assigned(FColorForm) and not FColorForm.ContainsControl(Sender) then\r\n begin\r\n { MSDN : While processing this message (WM_KILLFOCUS), do not make any\r\n function calls that display or activate a window.\r\n }\r\n PostMessage(Handle, CM_POPUPCLOSEUP, 0, 0);\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvColorButton.MouseDown(Button: TMouseButton; Shift: TShiftState;\r\n X, Y: Integer);\r\nvar\r\n CanShowPalette: Boolean;\r\nbegin\r\n SetFocus;\r\n inherited MouseDown(Button, Shift, X, Y);\r\n if FButtonShowsPalette or (X > Width - ArrowWidth) then\r\n begin\r\n CanShowPalette := True;\r\n DoPaletteShowing(CanShowPalette);\r\n if CanShowPalette then\r\n begin\r\n ShowColorPopup(Button, Shift, X, Y);\r\n FIsDown := True;\r\n end;\r\n end;\r\n Repaint;\r\nend;\r\n\r\nprocedure TJvColorButton.MouseUp(Button: TMouseButton; Shift: TShiftState;\r\n X, Y: Integer);\r\nbegin\r\n inherited MouseUp(Button, Shift, X, Y);\r\n FIsDown := False;\r\n Repaint;\r\nend;\r\n\r\nprocedure TJvColorButton.CMCancelMode(var Msg: TCMCancelMode);\r\nbegin\r\n if (Msg.Sender <> Self) and (Msg.Sender <> FColorForm) and\r\n Assigned(FColorForm) and not FColorForm.ContainsControl(Msg.Sender) then\r\n PopupCloseUp;\r\nend;\r\n\r\nprocedure TJvColorButton.CMPopupCloseUp(var Msg: TMessage);\r\nbegin\r\n PopupCloseUp;\r\nend;\r\n\r\nprocedure TJvColorButton.PopupCloseUp;\r\nbegin\r\n FColorForm.Hide;\r\nend;\r\n\r\nprocedure TJvColorButton.ShowColorPopup(Button: TMouseButton; Shift: TShiftState;\r\n X, Y: Integer);\r\nbegin\r\n if (Button <> mbLeft) or not Enabled or not Assigned(FColorForm) then\r\n Exit;\r\n with TJvColorForm(FColorForm) do\r\n begin\r\n ColorDialog.Options := FOptions;\r\n OtherBtn.Caption := FOtherCaption;\r\n ColorDialog.Color := FColor;\r\n ColorDialog.CustomColors.Assign(FCustomColors);\r\n if ArrowWidth = 0 then\r\n begin\r\n if ColorDialog.Execute then\r\n begin\r\n FColor := ColorDialog.Color;\r\n FCustomColors.Assign(ColorDialog.CustomColors);\r\n end;\r\n MouseUp(mbLeft, [], X, Y);\r\n end\r\n else\r\n if not FColorForm.Visible then\r\n FColorForm.ShowNoActivate(True)\r\n else\r\n FColorForm.Hide;\r\n // ColorSquare21.Color := Self.Color;\r\n end;\r\nend;\r\n\r\nprocedure TJvColorButton.Paint;\r\nvar\r\n Rec: TRect;\r\nbegin\r\n inherited Paint;\r\n { draw the colorsquare }\r\n Rec := ClientRect;\r\n Rec.Right := Rec.Right - ArrowWidth;\r\n InflateRect(Rec, -FEdgeWidth, -FEdgeWidth);\r\n if FIsDown then\r\n OffsetRect(Rec, 1, 1);\r\n\r\n if Enabled then\r\n Frame3D(Canvas, Rec, cl3DDkShadow, cl3DDkShadow, 1)\r\n else\r\n begin\r\n Frame3D(Canvas, Rec, clBtnShadow, clBtnHighLight, 1);\r\n Canvas.Brush.Style := bsBDiagonal;\r\n end;\r\n Canvas.Brush.Color := FColor;\r\n Canvas.FillRect(Rec);\r\nend;\r\n\r\nprocedure TJvColorButton.SetEdgeWidth(Value: Integer);\r\nbegin\r\n if FEdgeWidth <> Value then\r\n begin\r\n FEdgeWidth := Value;\r\n Repaint;\r\n end;\r\nend;\r\n\r\n\r\nprocedure TJvColorButton.SetOptions(Value: TColorDialogOptions);\r\nbegin\r\n if FOptions <> Value then\r\n FOptions := Value;\r\nend;\r\n\r\n\r\nfunction TJvColorButton.GetCustomColors: TStrings;\r\nbegin\r\n Result := FCustomColors;\r\nend;\r\n\r\nprocedure TJvColorButton.SetCustomColors(Value: TStrings);\r\nbegin\r\n FCustomColors.Assign(Value);\r\nend;\r\n\r\nprocedure TJvColorButton.SetOtherCaption(Value: string);\r\nbegin\r\n FOtherCaption := Value;\r\n Repaint;\r\nend;\r\n\r\nprocedure TJvColorButton.KeyDown(var Key: Word; Shift: TShiftState);\r\nbegin\r\n case Key of\r\n VK_RETURN, VK_SPACE:\r\n // (rom) accept Shift key pressed at max\r\n if Shift * KeyboardShiftStates <= [ssShift] then\r\n MouseDown(mbLeft, [], 0, 0);\r\n VK_ESCAPE:\r\n // (rom) only accept without Shift, Alt or Ctrl down\r\n if Shift * KeyboardShiftStates = [] then\r\n begin\r\n FColorForm.Hide;\r\n Key := 0;\r\n end;\r\n end;\r\n inherited KeyDown(Key, Shift);\r\nend;\r\n\r\nprocedure TJvColorButton.KeyUp(var Key: Word; Shift: TShiftState);\r\nbegin\r\n case Key of\r\n VK_RETURN, VK_SPACE:\r\n // (rom) accept Shift key pressed at max\r\n if Shift * KeyboardShiftStates <= [ssShift] then\r\n MouseUp(mbLeft, [], 0, 0);\r\n end;\r\n inherited KeyUp(Key, Shift);\r\nend;\r\n\r\nprocedure TJvColorButton.SetColor(const Value: TColor);\r\nbegin\r\n if Value <> FColor then\r\n begin\r\n FColor := Value;\r\n if Assigned(FOnChange) then\r\n FOnChange(Self);\r\n Repaint;\r\n end;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvColorCombo.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvColorCombo.PAS, released on 2002-05-26.\r\n\r\nThe Initial Developer of the Original Code is Peter Thrnqvist [peter3 at sourceforge dot net]\r\nPortions created by Peter Thrnqvist are Copyright (C) 2002 Peter Thrnqvist.\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\nBrian Cook (borland.public.vcl.components.writing)\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nDescription:\r\n Comboboxes for displaying colors and fonts\r\n\r\nKnown Issues:\r\n If you set AutoComplete in TJvColorComboBox to True and use the same text for\r\n all Custom colors, the inherited Change behaviour from TJvComboBox makes the *first*\r\n custom color selected, not the last added as it should be thus AutoComplete is\r\n set to default to False. (p3)\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvColorCombo.pas 13173 2011-11-19 12:43:58Z ahuser $\r\n\r\nunit JvColorCombo;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, Messages,\r\n Classes, Controls, Dialogs, Graphics,\r\n JvCombobox;\r\n\r\ntype\r\n TJvNewColorEvent = procedure(Sender: TObject; Color: TColor; var DisplayName: string;\r\n var AllowAdd: Boolean) of object;\r\n TJvGetColorNameEvent = procedure(Sender: TObject; Index: Integer; Color: TColor;\r\n var DisplayName: string) of object;\r\n TJvColorComboOption = (coText, coHex, coRGB, coStdColors, coSysColors, coCustomColors);\r\n TJvColorComboOptions = set of TJvColorComboOption;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvColorComboBox = class(TJvCustomComboBox)\r\n private\r\n FColorValue: TColor;\r\n FCustomColorCount: Integer;\r\n FHiliteColor: TColor;\r\n FHiliteText: TColor;\r\n FOptions: TJvColorComboOptions;\r\n FNewColorText: string;\r\n FColorDialogText: string;\r\n FColorWidth, FUpdateCount: Integer;\r\n FExecutingDialog: Boolean;\r\n FNewColor: TJvNewColorEvent;\r\n FOnGetDisplayName: TJvGetColorNameEvent;\r\n FColorNameMap: TStringList;\r\n FOnInsertColor: TJvNewColorEvent;\r\n FOnBeforeCustom: TNotifyEvent;\r\n FCustomColors: TStrings;\r\n procedure SetOptions(Value: TJvColorComboOptions);\r\n procedure SetColorDialogText(Value: string);\r\n procedure SetColorWidth(Value: Integer);\r\n procedure SetColorValue(Value: TColor);\r\n procedure ResetItemHeight;\r\n procedure CNDrawItem(var Msg: TWMDrawItem); message CN_DRAWITEM;\r\n function GetColorNameMap: TStrings;\r\n procedure SetColorNameMap(const Value: TStrings);\r\n procedure InitColorNames;\r\n function GetDropDownWidth: Integer;\r\n procedure SetDropDownWidth(const Value: Integer);\r\n function GetColor(Index: Integer): TColor;\r\n protected\r\n procedure FontChanged; override;\r\n procedure DrawItem(Index: Integer; R: TRect; State: TOwnerDrawState); override;\r\n procedure Click; override;\r\n\r\n function GetColorName(AColor: TColor; const Default: string): string;\r\n function DoNewColor(Color: TColor; var DisplayName: string): Boolean; virtual;\r\n procedure DoGetDisplayName(Index: Integer; AColor: TColor; var DisplayName: string); virtual;\r\n function DoInsertColor(AIndex: Integer; AColor: TColor; var DisplayName: string): Boolean; virtual;\r\n procedure DoBeforeCustom;\r\n procedure InternalInsertColor(AIndex: Integer; AColor: TColor; const DisplayName: string); virtual;\r\n procedure DoNameMapChange(Sender: TObject);\r\n procedure SetParent(AParent: TWinControl); override;\r\n procedure Loaded; override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n function BeginUpdate: Integer;\r\n function EndUpdate: Integer;\r\n procedure GetColors; virtual;\r\n function GetCustomColorsStrings: TStrings;\r\n procedure SetCustomColorsStrings(const Value: TStrings);\r\n procedure GetCustomColors(AList: TList);\r\n procedure SetCustomColors(AList: TList);\r\n // Returns the current name for AColor. Note that this implicitly might call the\r\n // OnGetDisplayName event if the protected GetColorName returns an empty string\r\n function ColorName(AColor: TColor): string;\r\n // returns the index of a specific color or -1 if not found\r\n function FindColor(AColor: TColor): Integer;\r\n\r\n procedure AddColor(AColor: TColor; const DisplayName: string);\r\n procedure ChangeColor(AIndex: Integer; AColor: TColor; const DisplayName: string);\r\n procedure InsertColor(AIndex: Integer; AColor: TColor; const DisplayName: string);\r\n property Text;\r\n property CustomColorCount: Integer read FCustomColorCount;\r\n property CustomColors: TStrings read GetCustomColorsStrings write SetCustomColorsStrings;\r\n\r\n property Colors[Index: Integer]: TColor read GetColor;\r\n published\r\n property Anchors;\r\n property AutoComplete default False;\r\n property AutoDropDown;\r\n property BevelEdges;\r\n property BevelInner;\r\n property BevelKind;\r\n property BevelOuter;\r\n property BiDiMode;\r\n property Constraints;\r\n // color name map is a TStrings property that can contain name/value mappings on the form\r\n // ColorName=DisplayName\r\n // If the component finds a matching mapping, it will substitute the default value\r\n // with the value in the list, otherwise the default value wil be used\r\n // Example:\r\n // clBlack=Black\r\n property ColorNameMap: TStrings read GetColorNameMap write SetColorNameMap;\r\n property ColorValue: TColor read FColorValue write SetColorValue default clBlack;\r\n property ColorDialogText: string read FColorDialogText write SetColorDialogText;\r\n property ColorWidth: Integer read FColorWidth write SetColorWidth default 21;\r\n property DroppedDownWidth: Integer read GetDropDownWidth write SetDropDownWidth;\r\n property HiliteColor: TColor read FHiliteColor write FHiliteColor default clHighlight;\r\n property HiliteText: TColor read FHiliteText write FHiliteText default clHighlightText;\r\n property NewColorText: string read FNewColorText write FNewColorText;\r\n property Options: TJvColorComboOptions read FOptions write SetOptions default [coText, coStdColors];\r\n // called before a new color is inserted as a result of displaying the Custom Colors dialog\r\n property OnNewColor: TJvNewColorEvent read FNewColor write FNewColor;\r\n // called before any color is inserted\r\n property OnInsertColor: TJvNewColorEvent read FOnInsertColor write FOnInsertColor;\r\n // called whenever the displayname of an item is needed\r\n property OnGetDisplayName: TJvGetColorNameEvent read FOnGetDisplayName write FOnGetDisplayName;\r\n // called just before the '(Other)' item is added at the bottom of the list\r\n property OnBeforeCustom: TNotifyEvent read FOnBeforeCustom write FOnBeforeCustom;\r\n\r\n property Color;\r\n property DragMode;\r\n property DragCursor;\r\n property Enabled;\r\n property Font;\r\n property ImeMode;\r\n property ImeName;\r\n property ParentColor;\r\n property ParentFont;\r\n property ParentShowHint;\r\n property PopupMenu;\r\n property ShowHint;\r\n property Sorted;\r\n property TabOrder;\r\n property TabStop;\r\n property Visible;\r\n property OnChange;\r\n property OnClick;\r\n property OnDblClick;\r\n property OnDragDrop;\r\n property OnDragOver;\r\n property OnDropDown;\r\n property OnEndDrag;\r\n property OnEnter;\r\n property OnExit;\r\n property OnKeyDown;\r\n property OnKeyPress;\r\n property OnKeyUp;\r\n property OnStartDrag;\r\n end;\r\n\r\n // TFontDialogDevice = (fdScreen, fdPrinter, fdBoth); { already in Dialogs }\r\n TJvFontComboOption = (foAnsiOnly, foTrueTypeOnly, foFixedPitchOnly,\r\n foNoOEMFonts, foOEMFontsOnly, foScalableOnly, foWysiWyg, foDisableVerify,\r\n foPreviewFont, foMRU);\r\n // foDisableVerify: if True, allows you to insert a font name that doesn't exist (by assigning to FontName)\r\n TJvFontComboOptions = set of TJvFontComboOption;\r\n TJvDrawPreviewEvent = procedure(Sender: TObject; const AFontName: string;\r\n var APreviewText: string; ATextWidth: Integer; var DrawPreview: Boolean) of object;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvFontComboBox = class(TJvCustomComboBox)\r\n private\r\n FTrueTypeBmp: TBitmap;\r\n FFixBmp: TBitmap;\r\n FDeviceBmp: TBitmap;\r\n FDevice: TFontDialogDevice;\r\n FHiliteColor: TColor;\r\n FHiliteText: TColor;\r\n FUseImages: Boolean;\r\n FOptions: TJvFontComboOptions;\r\n FMRUCount: Integer;\r\n FWasMouse: Boolean;\r\n FShowMRU: Boolean;\r\n FMaxMRUCount, FUpdateCount: Integer;\r\n FOnDrawPreviewEvent: TJvDrawPreviewEvent;\r\n FFontSizes:TStrings;\r\n FEnumeratorDC:HDC;\r\n FSampleText: string;\r\n procedure SetUseImages(Value: Boolean);\r\n procedure SetDevice(Value: TFontDialogDevice);\r\n procedure SetOptions(Value: TJvFontComboOptions);\r\n procedure ResetItemHeight;\r\n procedure Reset;\r\n // (ahuser) why both WM_FONTCHANGE and CM_FONTCHANGED ?\r\n //procedure WMFontChange(var Msg: TMessage); message WM_FONTCHANGE;\r\n function GetFontName: string;\r\n procedure SetFontName(const Value: string);\r\n function GetSorted: Boolean;\r\n procedure SetSorted(const Value: Boolean);\r\n function GetDropDownWidth: Integer;\r\n procedure SetDropDownWidth(const Value: Integer);\r\n procedure SetShowMRU(const Value: Boolean);\r\n procedure SetMaxMRUCount(const Value: Integer);\r\n function GetFontSizes: TStrings;\r\n procedure SetSampleText(const Value: string);\r\n function GetSampleTextStored: Boolean;\r\n protected\r\n procedure FontChanged; override;\r\n procedure Loaded; override;\r\n procedure GetFonts; virtual;\r\n procedure CNDrawItem(var Msg: TWMDrawItem); message CN_DRAWITEM;\r\n procedure DrawItem(Index: Integer; R: TRect; State: TOwnerDrawState); override;\r\n procedure MouseDown(Button: TMouseButton; Shift: TShiftState;\r\n X: Integer; Y: Integer); override;\r\n procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X: Integer;\r\n Y: Integer); override;\r\n procedure CloseUp; override;\r\n procedure KeyDown(var Key: Word; Shift: TShiftState); override;\r\n procedure SetParent(AParent: TWinControl); override;\r\n function DoDrawPreview(const AFontName: string; var APreviewText: string;\r\n ATextWidth: Integer): Boolean; virtual;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n function AddToMRU: Integer;\r\n procedure ClearMRU;\r\n procedure Click; override;\r\n function BeginUpdate: Integer;\r\n function EndUpdate: Integer;\r\n function FontSubstitute(const AFontName: string): string;\r\n procedure FontSizeList(SizeList: TList);\r\n function IsTrueType: Boolean;\r\n property Text;\r\n property MRUCount: Integer read FMRUCount;\r\n // returns the supported font sizes or a set of default sizes for TrueType fonts\r\n property FontSizes: TStrings read GetFontSizes;\r\n published\r\n property Anchors;\r\n property AutoComplete default False;\r\n property AutoDropDown;\r\n property BevelEdges;\r\n property BevelInner;\r\n property BevelKind;\r\n property BevelOuter;\r\n property BiDiMode;\r\n property Constraints;\r\n property Color;\r\n property DroppedDownWidth: Integer read GetDropDownWidth write SetDropDownWidth;\r\n property MaxMRUCount: Integer read FMaxMRUCount write SetMaxMRUCount;\r\n property FontName: string read GetFontName write SetFontName;\r\n property Device: TFontDialogDevice read FDevice write SetDevice default fdScreen;\r\n property DragMode;\r\n property DragCursor;\r\n property Enabled;\r\n property Font;\r\n property ItemIndex;\r\n property HiliteColor: TColor read FHiliteColor write FHiliteColor default clHighlight;\r\n property HiliteText: TColor read FHiliteText write FHiliteText default clHighlightText;\r\n property Options: TJvFontComboOptions read FOptions write SetOptions default [];\r\n property UseImages: Boolean read FUseImages write SetUseImages default True;\r\n property ImeMode;\r\n property ImeName;\r\n property ParentColor;\r\n property ParentFont;\r\n property ParentShowHint;\r\n property PopupMenu;\r\n property ShowHint;\r\n property Sorted: Boolean read GetSorted write SetSorted;\r\n property TabOrder;\r\n property TabStop;\r\n property Visible;\r\n property OnChange;\r\n property OnClick;\r\n property OnDblClick;\r\n property OnDragDrop;\r\n property OnDragOver;\r\n property OnDropDown;\r\n property OnEndDrag;\r\n property OnEnter;\r\n property OnExit;\r\n property OnKeyDown;\r\n property OnKeyPress;\r\n property OnKeyUp;\r\n property OnStartDrag;\r\n property SampleText: string read FSampleText write SetSampleText stored GetSampleTextStored;\r\n property OnDrawPreviewEvent: TJvDrawPreviewEvent read FOnDrawPreviewEvent write FOnDrawPreviewEvent;\r\n end;\r\n\r\n {$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvColorCombo.pas $';\r\n Revision: '$Revision: 13173 $';\r\n Date: '$Date: 2011-11-19 13:43:58 +0100 (sam. 19 nov. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n {$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n SysUtils, Math, StdCtrls, Printers,\r\n JvConsts, JvResources, JvTypes, System.UITypes;\r\n\r\nconst\r\n DefaultSampleText = 'AbCdEfGhIj';\r\n\r\n{$R JvColorCombo.res}\r\n\r\nfunction LoadInternalBitmap(ResName: string): TBitmap;\r\nbegin\r\n Result := TBitmap.Create;\r\n Result.Handle := LoadBitmap(HInstance, PChar(ResName));\r\nend;\r\n\r\nfunction GetItemHeight(Font: TFont): Integer;\r\nvar\r\n DC: HDC;\r\n AFont: HFONT;\r\n TM: TTextMetric;\r\nbegin\r\n DC := GetDC(HWND_DESKTOP);\r\n try\r\n AFont := SelectObject(DC, Font.Handle);\r\n GetTextMetrics(DC, TM);\r\n SelectObject(DC, AFont);\r\n finally\r\n ReleaseDC(HWND_DESKTOP, DC);\r\n end;\r\n Result := TM.tmHeight + 1;\r\nend;\r\n\r\nfunction IncludeFont(Options: TJvFontComboOptions; LogFont: TLogFont; FontType: Integer): Boolean;\r\nbegin\r\n Result := True;\r\n if foAnsiOnly in Options then\r\n Result := Result and (LogFont.lfCharSet = ANSI_CHARSET);\r\n if foTrueTypeOnly in Options then\r\n Result := Result and (FontType and TRUETYPE_FONTTYPE > 0);\r\n if foFixedPitchOnly in Options then\r\n Result := Result and (LogFont.lfPitchAndFamily and FIXED_PITCH > 0);\r\n if foOEMFontsOnly in Options then\r\n Result := Result and (LogFont.lfCharSet = OEM_CHARSET);\r\n if foNoOEMFonts in Options then\r\n Result := Result and (LogFont.lfCharSet <> OEM_CHARSET);\r\n if foScalableOnly in Options then\r\n Result := Result and (FontType and RASTER_FONTTYPE = 0);\r\nend;\r\n\r\nfunction EnumFontsProc(var LogFont: TLogFont; var TextMetric: TTextMetric;\r\n FontType: DWORD; FontCombo: TJvFontComboBox): Integer; stdcall;\r\nbegin\r\n Result := 0;\r\n if FontCombo = nil then\r\n Exit;\r\n if IncludeFont(FontCombo.Options, LogFont, FontType) then\r\n begin\r\n if FontCombo.Items.IndexOf(string(LogFont.lfFaceName)) = -1 then\r\n FontCombo.Items.AddObject(string(LogFont.lfFaceName), TObject(FontType));\r\n end;\r\n Result := 1;\r\nend;\r\n\r\nfunction ItemStateToOwnerDrawState(State: Integer): TOwnerDrawState;\r\nbegin\r\n Result := [];\r\n if (State and ODS_CHECKED) <> 0 then\r\n Include(Result, odChecked);\r\n if (State and ODS_COMBOBOXEDIT) <> 0 then\r\n Include(Result, odComboBoxEdit);\r\n if (State and ODS_DEFAULT) <> 0 then\r\n Include(Result, odDefault);\r\n if (State and ODS_DISABLED) <> 0 then\r\n Include(Result, odDisabled);\r\n if (State and ODS_FOCUS) <> 0 then\r\n Include(Result, odFocused);\r\n if (State and ODS_GRAYED) <> 0 then\r\n Include(Result, odGrayed);\r\n if (State and ODS_SELECTED) <> 0 then\r\n Include(Result, odSelected);\r\nend;\r\n\r\n//=== { TJvColorComboBox } ===================================================\r\n\r\nconstructor TJvColorComboBox.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FCustomColors := TStringList.Create;\r\n FColorNameMap := TStringList.Create;\r\n Style := csOwnerDrawFixed;\r\n FColorValue := clBlack;\r\n FColorWidth := 21;\r\n FNewColorText := RsNewColorPrefix;\r\n FColorDialogText := RsCustomCaption;\r\n FOptions := [coText, coStdColors];\r\n FHiliteColor := clHighlight;\r\n FHiliteText := clHighlightText;\r\n AutoComplete := False;\r\n // make sure that if this is the first time the component is dropped on the form,\r\n // the default Name/Value map is created (thanks to Brian Cook on the borland NG's):\r\n if (Owner <> nil) and ([csDesigning, csLoading] * Owner.ComponentState = [csDesigning]) then\r\n InitColorNames;\r\n FColorNameMap.OnChange := DoNameMapChange;\r\nend;\r\n\r\ndestructor TJvColorComboBox.Destroy;\r\nbegin\r\n FColorNameMap.Free;\r\n FCustomColors.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJvColorComboBox.BeginUpdate: Integer;\r\nbegin\r\n Inc(FUpdateCount);\r\n Result := FUpdateCount;\r\nend;\r\n\r\nfunction TJvColorComboBox.EndUpdate: Integer;\r\nbegin\r\n Dec(FUpdateCount);\r\n if FUpdateCount = 0 then\r\n GetColors\r\n else\r\n if FUpdateCount < 0 then\r\n FUpdateCount := 0;\r\n Result := FUpdateCount;\r\nend;\r\n\r\nprocedure TJvColorComboBox.GetColors;\r\nvar\r\n I: Integer;\r\n ColorName: string;\r\nbegin\r\n if FUpdateCount = 0 then\r\n begin\r\n Items.BeginUpdate;\r\n try\r\n Clear;\r\n FCustomColorCount := 0;\r\n if coStdColors in FOptions then\r\n for I := Low(ColorValues) to High(ColorValues) do\r\n begin\r\n ColorName := GetColorName(ColorValues[I].Value, '');\r\n InternalInsertColor(Items.Count, ColorValues[I].Value, ColorName);\r\n end;\r\n if coSysColors in FOptions then\r\n for I := Low(SysColorValues) to High(SysColorValues) do\r\n begin\r\n ColorName := GetColorName(SysColorValues[I].Value, '');\r\n InternalInsertColor(Items.Count, SysColorValues[I].Value, ColorName);\r\n end;\r\n DoBeforeCustom;\r\n if coCustomColors in FOptions then\r\n InternalInsertColor(Items.Count, $000001, FColorDialogText);\r\n if Items.Count > 0 then\r\n SetColorValue(FColorValue);\r\n finally\r\n Items.EndUpdate;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvColorComboBox.SetOptions(Value: TJvColorComboOptions);\r\nbegin\r\n if FOptions <> Value then\r\n begin\r\n FOptions := Value;\r\n GetColors;\r\n end;\r\nend;\r\n\r\nprocedure TJvColorComboBox.SetColorDialogText(Value: string);\r\nvar\r\n I: Integer;\r\nbegin\r\n if FColorDialogText <> Value then\r\n begin\r\n I := Items.IndexOf(FColorDialogText);\r\n while I > -1 do\r\n begin\r\n Items[I] := Value;\r\n I := Items.IndexOf(FColorDialogText);\r\n end;\r\n FColorDialogText := Value;\r\n end;\r\nend;\r\n\r\nprocedure TJvColorComboBox.SetColorWidth(Value: Integer);\r\nbegin\r\n if FColorWidth <> Value then\r\n begin\r\n FColorWidth := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvColorComboBox.SetColorValue(Value: TColor);\r\nvar\r\n I: Integer;\r\nbegin\r\n I := FindColor(Value);\r\n if I >= 0 then\r\n begin\r\n FColorValue := Value;\r\n if ItemIndex <> I then\r\n begin\r\n ItemIndex := I;\r\n Change;\r\n end;\r\n Exit;\r\n end\r\n else\r\n if coCustomColors in Options then\r\n begin\r\n InsertColor(Items.Count - 1, Value, Format(FNewColorText, [FCustomColorCount]));\r\n // If we are executing the dialog, the FCustomColorCount value has already been incremented (see the Click method)\r\n if not FExecutingDialog then\r\n Inc(FCustomColorCount);\r\n FColorValue := Value;\r\n ItemIndex := Items.Count - 2;\r\n end\r\n else\r\n begin\r\n AddColor(Value, Format(FNewColorText, [FCustomColorCount]));\r\n FColorValue := Value;\r\n ItemIndex := Items.Count - 1;\r\n Change;\r\n end;\r\nend;\r\n\r\nfunction TJvColorComboBox.DoNewColor(Color: TColor; var DisplayName: string): Boolean;\r\nbegin\r\n Result := FindColor(Color) = -1;\r\n if Assigned(FNewColor) then\r\n FNewColor(Self, Color, DisplayName, Result);\r\nend;\r\n\r\nprocedure TJvColorComboBox.CNDrawItem(var Msg: TWMDrawItem);\r\nvar\r\n State: TOwnerDrawState;\r\nbegin\r\n with Msg.DrawItemStruct^ do\r\n begin\r\n State := ItemStateToOwnerDrawState(itemState);\r\n Canvas.Handle := hDC;\r\n Canvas.Font := Font;\r\n Canvas.Brush := Brush;\r\n if (Integer(itemID) >= 0) and (odSelected in State) then\r\n begin\r\n Canvas.Brush.Color := FHiliteColor;\r\n Canvas.Font.Color := FHiliteText;\r\n end;\r\n if Integer(itemID) >= 0 then\r\n DrawItem(itemID, rcItem, State)\r\n else\r\n Canvas.FillRect(rcItem);\r\n Canvas.Handle := 0;\r\n end;\r\nend;\r\n\r\nprocedure TJvColorComboBox.DrawItem(Index: Integer; R: TRect;\r\n State: TOwnerDrawState);\r\nvar\r\n LRect: TRect;\r\n AColor: TColor;\r\n S: string;\r\nbegin\r\n if Index >= Items.Count then\r\n Exit;\r\n LRect := R;\r\n Inc(LRect.Top, 2);\r\n Inc(LRect.Left, 2);\r\n Dec(LRect.Bottom, 2);\r\n if (coText in FOptions) or (coHex in FOptions) or (coRGB in FOptions) or\r\n ((coCustomColors in FOptions) and (Index = Items.Count - 1)) then\r\n LRect.Right := LRect.Left + FColorWidth\r\n\r\n else\r\n Dec(LRect.Right, 3);\r\n\r\n with Canvas do\r\n begin\r\n AColor := Brush.Color;\r\n Brush.Color := Color;\r\n FillRect(R);\r\n Brush.Color := clGray;\r\n OffsetRect(LRect, 2, 2);\r\n FillRect(LRect);\r\n OffsetRect(LRect, -2, -2);\r\n Brush.Color := TColor(Items.Objects[Index]);\r\n try\r\n Rectangle(LRect);\r\n finally\r\n Brush.Style := bsSolid;\r\n Brush.Color := AColor;\r\n end;\r\n if (coCustomColors in FOptions) and (Index = Items.Count - 1) then\r\n begin\r\n S := FColorDialogText;\r\n DoGetDisplayName(Index, TColor(Items.Objects[Index]), S);\r\n Brush.Color := Self.Color;\r\n FillRect(R);\r\n R.Left := R.Left + 2;\r\n R.Right := R.Left + TextWidth(S) + 2;\r\n Brush.Color := AColor;\r\n if AColor = clNone then\r\n Brush.Style := bsFDiagonal\r\n else\r\n if AColor = clDefault then\r\n Brush.Style := bsBDiagonal;\r\n FillRect(R);\r\n SetBkMode(Canvas.Handle, TRANSPARENT);\r\n DrawText(Canvas.Handle, PChar(S), Length(S), R, DT_SINGLELINE or DT_VCENTER or DT_NOPREFIX);\r\n end\r\n else\r\n if (coText in FOptions) or (coHex in FOptions) or (coRGB in FOptions) then\r\n begin\r\n S := Items[Index];\r\n DoGetDisplayName(Index, TColor(Items.Objects[Index]), S);\r\n if S <> FColorDialogText then\r\n begin\r\n if coHex in FOptions then\r\n S := Format('0x%.6x', [ColorToRGB(TColor(Items.Objects[Index]))])\r\n else\r\n if coRGB in FOptions then\r\n S := Format('(%d,%d,%d)', [GetRValue(TColor(Items.Objects[Index])),\r\n GetGValue(TColor(Items.Objects[Index])), GetBValue(TColor(Items.Objects[Index]))]);\r\n end;\r\n R.Left := R.Left + FColorWidth + 6;\r\n R.Right := R.Left + TextWidth(S) + 6;\r\n if AColor = clNone then\r\n Brush.Style := bsFDiagonal\r\n else\r\n if AColor = clDefault then\r\n Brush.Style := bsBDiagonal;\r\n FillRect(R);\r\n OffsetRect(R, 2, 0);\r\n SetBkMode(Canvas.Handle, TRANSPARENT);\r\n DrawText(Canvas.Handle, PChar(S), Length(S), R, DT_SINGLELINE or DT_VCENTER or DT_NOPREFIX);\r\n OffsetRect(R, -2, 0);\r\n end\r\n else\r\n FrameRect(R);\r\n if odSelected in State then\r\n DrawFocusRect(R);\r\n end;\r\nend;\r\n\r\nprocedure TJvColorComboBox.Click;\r\nvar\r\n S, Tmp: string;\r\n CD: TColorDialog;\r\nbegin\r\n if FExecutingDialog then\r\n Exit;\r\n try\r\n if (ItemIndex = Items.Count - 1) and (coCustomColors in FOptions) then\r\n begin\r\n FExecutingDialog := True;\r\n CD := TColorDialog.Create(Self);\r\n with CD do\r\n try\r\n CD.Color := ColorValue;\r\n CD.CustomColors := Self.CustomColors;\r\n Options := Options + [cdFullOpen, cdPreventFullOpen];\r\n S := FNewColorText;\r\n if Execute then\r\n begin\r\n Self.CustomColors := CD.CustomColors;\r\n if DoNewColor(CD.Color, S) then\r\n Inc(FCustomColorCount);\r\n Tmp := FNewColorText;\r\n try\r\n FNewColorText := S;\r\n ColorValue := CD.Color;\r\n finally\r\n FNewColorText := Tmp;\r\n end;\r\n Change;\r\n end\r\n else\r\n ItemIndex := Items.Count - 2;\r\n finally\r\n Free;\r\n end;\r\n end\r\n else\r\n if ItemIndex >= 0 then\r\n ColorValue := TColor(Items.Objects[ItemIndex]);\r\n inherited Click;\r\n finally\r\n FExecutingDialog := False;\r\n end;\r\nend;\r\n\r\nprocedure TJvColorComboBox.FontChanged;\r\nbegin\r\n inherited FontChanged;\r\n ResetItemHeight;\r\n RecreateWnd;\r\nend;\r\n\r\nprocedure TJvColorComboBox.ResetItemHeight;\r\nbegin\r\n ItemHeight := Max(GetItemHeight(Font), 9);\r\nend;\r\n\r\nprocedure TJvColorComboBox.AddColor(AColor: TColor; const DisplayName: string);\r\nvar\r\n S: string;\r\nbegin\r\n S := DisplayName;\r\n if DoNewColor(AColor, S) then\r\n begin\r\n if coCustomColors in Options then\r\n Inc(FCustomColorCount);\r\n InternalInsertColor(Items.Count - Ord(coCustomColors in Options), AColor, S);\r\n if ItemIndex < 0 then ItemIndex := 0;\r\n end;\r\nend;\r\n\r\nprocedure TJvColorComboBox.DoGetDisplayName(Index: Integer; AColor: TColor;\r\n var DisplayName: string);\r\nbegin\r\n if Assigned(FOnGetDisplayName) then\r\n FOnGetDisplayName(Self, Index, AColor, DisplayName)\r\n else\r\n DisplayName := GetColorName(AColor, DisplayName);\r\nend;\r\n\r\nprocedure TJvColorComboBox.InsertColor(AIndex: Integer; AColor: TColor;\r\n const DisplayName: string);\r\nvar\r\n S: string;\r\nbegin\r\n S := DisplayName;\r\n if DoInsertColor(AIndex, AColor, S) then\r\n InternalInsertColor(AIndex, AColor, S);\r\nend;\r\n\r\nfunction TJvColorComboBox.GetColorNameMap: TStrings;\r\nbegin\r\n Result := FColorNameMap;\r\nend;\r\n\r\nfunction TJvColorComboBox.GetColor(Index: Integer): TColor;\r\nbegin\r\n Result := TColor(Items.Objects[Index]);\r\nend;\r\n\r\nprocedure TJvColorComboBox.SetColorNameMap(const Value: TStrings);\r\nbegin\r\n FColorNameMap.Assign(Value);\r\n Invalidate;\r\nend;\r\n\r\nfunction TJvColorComboBox.GetColorName(AColor: TColor; const Default: string): string;\r\nvar\r\n Tmp: string;\r\nbegin\r\n Tmp := ColorToString(AColor);\r\n Result := FColorNameMap.Values[Tmp];\r\n if Result = '' then\r\n Result := FColorNameMap.Values['cl' + Tmp];\r\n if Result = '' then\r\n begin\r\n if Default = '' then\r\n begin\r\n if (Length(Tmp) > 1) and AnsiSameText(Tmp[1], 'c') and AnsiSameText(Tmp[2], 'l') then\r\n Result := Copy(Tmp, 3, MaxInt)\r\n else\r\n Result := Tmp;\r\n end\r\n else\r\n Result := Default;\r\n end;\r\nend;\r\n\r\nprocedure TJvColorComboBox.InitColorNames;\r\nvar\r\n I: Integer;\r\nbegin\r\n FColorNameMap.BeginUpdate;\r\n try\r\n FColorNameMap.Clear;\r\n for I := Low(ColorValues) to High(ColorValues) do\r\n FColorNameMap.Add(ColorValues[I].Constant + '=' + ColorValues[I].Description);\r\n for I := Low(SysColorValues) to High(SysColorValues) do\r\n FColorNameMap.Add(SysColorValues[I].Constant + '=' + SysColorValues[I].Description);\r\n finally\r\n FColorNameMap.EndUpdate;\r\n end;\r\nend;\r\n\r\nfunction TJvColorComboBox.DoInsertColor(AIndex: Integer; AColor: TColor;\r\n var DisplayName: string): Boolean;\r\nbegin\r\n Result := True;\r\n if Assigned(FOnInsertColor) then\r\n FOnInsertColor(Self, AColor, DisplayName, Result);\r\nend;\r\n\r\nprocedure TJvColorComboBox.DoBeforeCustom;\r\nbegin\r\n if Assigned(FOnBeforeCustom) then\r\n FOnBeforeCustom(Self);\r\nend;\r\n\r\nprocedure TJvColorComboBox.ChangeColor(AIndex: Integer; AColor: TColor;\r\n const DisplayName: string);\r\nbegin\r\n // raise Exception ?\r\n if (AIndex >= 0) and (AIndex < Items.Count - Ord(coCustomColors in Options)) then\r\n begin\r\n Items[AIndex] := DisplayName;\r\n Items.Objects[AIndex] := TObject(AColor);\r\n end;\r\nend;\r\n\r\nfunction TJvColorComboBox.ColorName(AColor: TColor): string;\r\nbegin\r\n Result := GetColorName(AColor, '');\r\n if Result = '' then\r\n DoGetDisplayName(-1, AColor, Result);\r\nend;\r\n\r\nfunction TJvColorComboBox.FindColor(AColor: TColor): Integer;\r\nbegin\r\n Result := Items.IndexOfObject(TObject(AColor));\r\n if (coCustomColors in Options) and (Result = Items.Count - 1) then\r\n Result := -1;\r\nend;\r\n\r\nprocedure TJvColorComboBox.GetCustomColors(AList: TList);\r\nvar\r\n I, J: Integer;\r\nbegin\r\n if AList = nil then\r\n Exit;\r\n Items.BeginUpdate;\r\n try\r\n J := Ord((coCustomColors in Options));\r\n for I := Items.Count - (CustomColorCount + J) to pred(Items.Count - J) do\r\n AList.Add(Items.Objects[I]);\r\n finally\r\n Items.EndUpdate;\r\n end;\r\nend;\r\n\r\nprocedure TJvColorComboBox.SetCustomColors(AList: TList);\r\nvar\r\n I: Integer;\r\n AColor: TColor;\r\n S: string;\r\nbegin\r\n if AList = nil then\r\n Exit;\r\n Items.BeginUpdate;\r\n try\r\n for I := 0 to AList.Count - 1 do\r\n begin\r\n AColor := TColor(AList[I]);\r\n if AColor <> -1 then\r\n begin\r\n S := FNewColorText;\r\n if DoNewColor(AColor, S) then\r\n begin\r\n InsertColor(Items.Count - 1, AColor, Format(S, [FCustomColorCount]));\r\n Inc(FCustomColorCount);\r\n end;\r\n end;\r\n end;\r\n finally\r\n Items.EndUpdate;\r\n end;\r\nend;\r\n\r\nfunction TJvColorComboBox.GetCustomColorsStrings: TStrings;\r\nvar\r\n AList: TList;\r\n I: Integer;\r\nbegin\r\n AList := TList.Create;\r\n FCustomColors.BeginUpdate;\r\n try\r\n FCustomColors.Clear;\r\n GetCustomColors(AList);\r\n for I := 0 to AList.Count - 1 do\r\n FCustomColors.Values['Color' + Char(Ord('A') + I)] := Format('%.6x', [Integer(AList[I])]);\r\n finally\r\n AList.Free;\r\n FCustomColors.EndUpdate;\r\n end;\r\n Result := FCustomColors;\r\nend;\r\n\r\nprocedure TJvColorComboBox.SetCustomColorsStrings(const Value: TStrings);\r\nvar\r\n AList: TList;\r\n AValue: string;\r\n I: Integer;\r\nbegin\r\n FCustomColors.Assign(Value);\r\n AList := TList.Create;\r\n FCustomColors.BeginUpdate;\r\n try\r\n for I := 0 to FCustomColors.Count - 1 do\r\n begin\r\n AValue := FCustomColors.Values['Color' + Char(Ord('A') + I)];\r\n if (AValue <> '') and (AValue <> 'FFFFFF') then\r\n AList.Add(Pointer(StrToInt('$' + AValue)));\r\n end;\r\n SetCustomColors(AList);\r\n finally\r\n AList.Free;\r\n FCustomColors.EndUpdate;\r\n end;\r\nend;\r\n\r\nprocedure TJvColorComboBox.InternalInsertColor(AIndex: Integer;\r\n AColor: TColor; const DisplayName: string);\r\nbegin\r\n Items.InsertObject(AIndex, DisplayName, TObject(AColor));\r\nend;\r\n\r\nprocedure TJvColorComboBox.DoNameMapChange(Sender: TObject);\r\nbegin\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvColorComboBox.Loaded;\r\nbegin\r\n inherited Loaded;\r\n HandleNeeded;\r\n if HandleAllocated then\r\n GetColors;\r\nend;\r\n\r\nfunction TJvColorComboBox.GetDropDownWidth: Integer;\r\nbegin\r\n Result := SendMessage(Handle, CB_GETDROPPEDWIDTH, 0, 0);\r\nend;\r\n\r\nprocedure TJvColorComboBox.SetDropDownWidth(const Value: Integer);\r\nbegin\r\n SendMessage(Handle, CB_SETDROPPEDWIDTH, Value, 0);\r\nend;\r\n\r\nprocedure TJvColorComboBox.SetParent(AParent: TWinControl);\r\nbegin\r\n inherited SetParent(AParent);\r\n if (Parent <> nil) and HandleAllocated then\r\n GetColors;\r\nend;\r\n\r\n//=== { TJvFontComboBox } ====================================================\r\n\r\nconstructor TJvFontComboBox.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FTrueTypeBmp := LoadInternalBitmap('JvFontComboBoxTTF');\r\n FFixBmp := LoadInternalBitmap('JvFontComboBoxFIX');\r\n FDeviceBmp := LoadInternalBitmap('JvFontComboBoxPRN');\r\n FSampleText := DefaultSampleText;\r\n FHiliteColor := clHighlight;\r\n FHiliteText := clHighlightText;\r\n FDevice := fdScreen;\r\n FUseImages := True;\r\n Style := csOwnerDrawFixed;\r\n AutoComplete := False;\r\n ResetItemHeight;\r\nend;\r\n\r\ndestructor TJvFontComboBox.Destroy;\r\nbegin\r\n FTrueTypeBmp.Free;\r\n FDeviceBmp.Free;\r\n FFixBmp.Free;\r\n FFontSizes.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvFontComboBox.GetFonts;\r\nvar\r\n DC: HDC;\r\n MRUItems: TStringList;\r\n I: Integer;\r\nbegin\r\n if FUpdateCount = 0 then\r\n begin\r\n HandleNeeded;\r\n if not HandleAllocated then\r\n Exit;\r\n Items.BeginUpdate;\r\n MRUItems := TStringList.Create;\r\n try\r\n if FShowMRU then\r\n for I := 0 to MRUCount - 1 do\r\n MRUItems.AddObject(Items[I], Items.Objects[I]);\r\n Clear;\r\n DC := GetDC(HWND_DESKTOP);\r\n try\r\n if FDevice in [fdScreen, fdBoth] then\r\n EnumFonts(DC, nil, @EnumFontsProc, Pointer(Self));\r\n if FDevice in [fdPrinter, fdBoth] then\r\n try\r\n EnumFonts(Printer.Handle, nil, @EnumFontsProc, Pointer(Self));\r\n except\r\n // (p3) exception might be raised if no printer is installed, but ignore it here\r\n end;\r\n finally\r\n ReleaseDC(HWND_DESKTOP, DC);\r\n end;\r\n if FShowMRU then\r\n for I := MRUCount - 1 downto 0 do\r\n begin\r\n Items.InsertObject(0, MRUItems[I], MRUItems.Objects[I]);\r\n end;\r\n finally\r\n MRUItems.Free;\r\n Items.EndUpdate;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvFontComboBox.SetOptions(Value: TJvFontComboOptions);\r\nbegin\r\n if Value <> Options then\r\n begin\r\n FOptions := Value;\r\n if (foPreviewFont in FOptions) then\r\n Exclude(FOptions, foWysiWyg);\r\n SetShowMRU(foMRU in FOptions);\r\n Reset;\r\n end;\r\nend;\r\n\r\nprocedure TJvFontComboBox.SetUseImages(Value: Boolean);\r\nbegin\r\n if FUseImages <> Value then\r\n begin\r\n FUseImages := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvFontComboBox.SetDevice(Value: TFontDialogDevice);\r\nbegin\r\n if Value <> FDevice then\r\n begin\r\n FDevice := Value;\r\n Reset;\r\n end;\r\nend;\r\n\r\nprocedure TJvFontComboBox.CNDrawItem(var Msg: TWMDrawItem);\r\nvar\r\n State: TOwnerDrawState;\r\nbegin\r\n with Msg.DrawItemStruct^ do\r\n begin\r\n State := ItemStateToOwnerDrawState(itemState);\r\n Canvas.Handle := hDC;\r\n Canvas.Font := Font;\r\n Canvas.Brush := Brush;\r\n if (Integer(itemID) >= 0) and (odSelected in State) then\r\n begin\r\n Canvas.Brush.Color := FHiliteColor;\r\n Canvas.Font.Color := FHiliteText;\r\n end;\r\n if Integer(itemID) >= 0 then\r\n DrawItem(itemID, rcItem, State)\r\n else\r\n Canvas.FillRect(rcItem);\r\n Canvas.Handle := 0;\r\n end;\r\nend;\r\n\r\nfunction TJvFontComboBox.DoDrawPreview(const AFontName: string;\r\n var APreviewText: string; ATextWidth: Integer): Boolean;\r\nbegin\r\n Result := ATextWidth < ClientWidth;\r\n if Assigned(FOnDrawPreviewEvent) then\r\n FOnDrawPreviewEvent(Self, AFontName, APreviewText, ATextWidth, Result);\r\nend;\r\n\r\nprocedure TJvFontComboBox.DrawItem(Index: Integer; R: TRect;\r\n State: TOwnerDrawState);\r\nvar\r\n ABmp: TBitmap;\r\n AColor: TColor;\r\n AWidth: Integer;\r\n TmpRect: TRect;\r\n S, AName: string;\r\nbegin\r\n with Canvas do\r\n begin\r\n AColor := Brush.Color;\r\n Brush.Color := Color;\r\n Pen.Color := Font.Color;\r\n FillRect(R);\r\n Inc(R.Top);\r\n // AWidth := 20;\r\n if (Integer(Items.Objects[Index]) and TRUETYPE_FONTTYPE) <> 0 then\r\n ABmp := FTrueTypeBmp\r\n else\r\n if (Integer(Items.Objects[Index]) and DEVICE_FONTTYPE) <> 0 then\r\n ABmp := FDeviceBmp\r\n else\r\n ABmp := FFixBmp;\r\n if not FUseImages then\r\n ABmp := nil;\r\n\r\n if ABmp <> nil then\r\n begin\r\n AWidth := ABmp.Width;\r\n BrushCopy(Bounds(R.Left + 2, (R.Top + R.Bottom - ABmp.Height) div 2,\r\n ABmp.Width, ABmp.Height), ABmp, Bounds(0, 0, ABmp.Width, ABmp.Height), clFuchsia);\r\n R.Left := R.Left + AWidth + 6;\r\n end\r\n else\r\n AWidth := 4;\r\n Brush.Color := AColor;\r\n AName := Canvas.Font.Name;\r\n if foWysiWyg in FOptions then\r\n begin\r\n if (foPreviewFont in Options) then\r\n Canvas.Font.Name := Self.Font.Name\r\n else\r\n Canvas.Font.Name := Items[Index];\r\n end;\r\n if not (foPreviewFont in Options) then\r\n R.Right := R.Left + TextWidth(Items[Index]) + 6;\r\n FillRect(R);\r\n OffsetRect(R, 2, 0);\r\n DrawText(Canvas.Handle, PChar(Items[Index]), -1, R, DT_SINGLELINE or DT_VCENTER or DT_NOPREFIX);\r\n if (foPreviewFont in Options) then\r\n begin\r\n Inc(AWidth, TextWidth(Items[Index]) + 36);\r\n Canvas.Font.Name := Items[Index];\r\n S := FSampleText;\r\n Inc(AWidth, TextWidth(S));\r\n if DoDrawPreview(Items[Index], S, AWidth) then\r\n begin\r\n TmpRect := R;\r\n TmpRect.Left := 0;\r\n TmpRect.Right := ClientWidth - (GetSystemMetrics(SM_CXVSCROLL) + 8);\r\n R.Right := ClientWidth;\r\n DrawText(Canvas.Handle, PChar(S), -1, TmpRect, DT_SINGLELINE or DT_VCENTER or DT_RIGHT or DT_NOPREFIX);\r\n end;\r\n end;\r\n Canvas.Font.Name := AName;\r\n OffsetRect(R, -2, 0);\r\n if odSelected in State then\r\n DrawFocusRect(R);\r\n if FShowMRU and not (odComboBoxEdit in State) then\r\n begin\r\n // draw MRU separator\r\n Dec(R.Top);\r\n if (Index = MRUCount - 1) then\r\n begin\r\n Canvas.Pen.Color := clGray;\r\n Canvas.Pen.Width := 1;\r\n Canvas.MoveTo(0, R.Bottom - 1);\r\n Canvas.LineTo(ClientWidth, R.Bottom - 1);\r\n end\r\n else\r\n if (Index = MRUCount) and (Index > 0) then\r\n begin\r\n Canvas.Pen.Color := clGray;\r\n Canvas.Pen.Width := 1;\r\n Canvas.MoveTo(0, R.Top + 1);\r\n Canvas.LineTo(ClientWidth, R.Top + 1);\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\n{procedure TJvFontComboBox.WMFontChange(var Msg: TMessage);\r\nbegin\r\n inherited;\r\n Reset;\r\nend;}\r\n\r\nprocedure TJvFontComboBox.FontChanged;\r\nbegin\r\n inherited FontChanged;\r\n ResetItemHeight;\r\n RecreateWnd;\r\nend;\r\n\r\nprocedure TJvFontComboBox.ResetItemHeight;\r\nbegin\r\n ItemHeight := Max(GetItemHeight(Font), FTrueTypeBmp.Height);\r\nend;\r\n\r\nfunction TJvFontComboBox.BeginUpdate: Integer;\r\nbegin\r\n Inc(FUpdateCount);\r\n Result := FUpdateCount;\r\nend;\r\n\r\nfunction TJvFontComboBox.EndUpdate: Integer;\r\nbegin\r\n Dec(FUpdateCount);\r\n if FUpdateCount = 0 then\r\n GetFonts\r\n else\r\n if FUpdateCount < 0 then\r\n FUpdateCount := 0;\r\n Result := FUpdateCount;\r\nend;\r\n\r\nprocedure TJvFontComboBox.Click;\r\nbegin\r\n inherited Click;\r\n Change;\r\n if FShowMRU and FWasMouse and not DroppedDown then\r\n begin\r\n ItemIndex := AddToMRU;\r\n FWasMouse := False;\r\n end;\r\nend;\r\n\r\nprocedure TJvFontComboBox.Reset;\r\nvar\r\n S: string;\r\nbegin\r\n HandleNeeded;\r\n if HandleAllocated then\r\n begin\r\n FreeAndNil(FFontSizes);\r\n S := FontName;\r\n GetFonts;\r\n if S <> '' then\r\n FontName := S\r\n else\r\n FontName := Font.Name;\r\n end;\r\nend;\r\n\r\nfunction TJvFontComboBox.GetFontName: string;\r\nbegin\r\n Result := inherited Text;\r\nend;\r\n\r\nprocedure TJvFontComboBox.SetFontName(const Value: string);\r\nbegin\r\n HandleNeeded;\r\n if HandleAllocated and (Value <> '') then\r\n begin\r\n if Items.Count = 0 then\r\n GetFonts;\r\n ItemIndex := Items.IndexOf(Value);\r\n if ItemIndex = -1 then // try to find the font substitute name\r\n ItemIndex := Items.IndexOf(FontSubstitute(Value));\r\n if (ItemIndex = -1) and (foDisableVerify in Options) then // add if allowed to\r\n ItemIndex := Items.AddObject(Value, TObject(TRUETYPE_FONTTYPE));\r\n FreeAndNil(FFontSizes);\r\n end;\r\nend;\r\n\r\nprocedure TJvFontComboBox.Loaded;\r\nbegin\r\n inherited Loaded;\r\n Reset;\r\nend;\r\n\r\nfunction TJvFontComboBox.GetSampleTextStored: Boolean;\r\nbegin\r\n result := FSampleText <> DefaultSampleText;\r\nend;\r\n\r\nfunction TJvFontComboBox.GetSorted: Boolean;\r\nbegin\r\n Result := inherited Sorted;\r\nend;\r\n\r\nprocedure TJvFontComboBox.SetSorted(const Value: Boolean);\r\nvar\r\n S: string;\r\nbegin\r\n if Value <> inherited Sorted then\r\n begin\r\n S := FontName;\r\n if not FShowMRU then\r\n inherited Sorted := Value\r\n else\r\n inherited Sorted := False;\r\n FontName := S;\r\n end;\r\nend;\r\n\r\nfunction TJvFontComboBox.FontSubstitute(const AFontName: string): string;\r\nvar\r\n Size: DWORD;\r\n AKey: HKey;\r\nbegin\r\n Result := AFontName;\r\n if AFontName = '' then\r\n Exit;\r\n if RegOpenKeyEx(HKEY_LOCAL_MACHINE, 'SOFTWARE\\Microsoft\\Windows NT\\CurrentVersion\\FontSubstitutes',\r\n 0, KEY_QUERY_VALUE, AKey) = ERROR_SUCCESS then\r\n try\r\n if (RegQueryValueEx(AKey, PChar(AFontName), nil, nil, nil, @Size) = ERROR_SUCCESS) and\r\n (Size > 0) then\r\n begin\r\n SetLength(Result, Size);\r\n if RegQueryValueEx(AKey, PChar(AFontName), nil, nil, PByte(@Result[1]), @Size) = ERROR_SUCCESS then\r\n Result := string(Result)\r\n else\r\n Result := AFontName;\r\n end;\r\n finally\r\n RegCloseKey(AKey);\r\n end\r\n else\r\n Result := AFontName;\r\nend;\r\n\r\nfunction TJvFontComboBox.GetDropDownWidth: Integer;\r\nbegin\r\n Result := SendMessage(Handle, CB_GETDROPPEDWIDTH, 0, 0);\r\nend;\r\n\r\nprocedure TJvFontComboBox.SetDropDownWidth(const Value: Integer);\r\nbegin\r\n SendMessage(Handle, CB_SETDROPPEDWIDTH, Value, 0);\r\nend;\r\n\r\nprocedure TJvFontComboBox.SetSampleText(const Value: string);\r\nbegin\r\n if value <> FSampleText then\r\n begin\r\n FSampleText := value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvFontComboBox.SetShowMRU(const Value: Boolean);\r\nbegin\r\n if FShowMRU <> Value then\r\n begin\r\n if FShowMRU then\r\n ClearMRU;\r\n FShowMRU := Value;\r\n if FShowMRU and Sorted then\r\n Sorted := False;\r\n end;\r\nend;\r\n\r\nvar\r\n FPixelsPerInch: Integer = 96;\r\n\r\nfunction GetFontSizesEnum(var lpelf: TEnumLogFont; var lpntm: TNewTextMetric;\r\n FontType: Integer; lParam: Integer): Integer; stdcall;\r\nvar\r\n aSize: Integer;\r\nbegin\r\n aSize := MulDiv(lpelf.elfLogFont.lfHeight, 72, FPixelsPerInch);\r\n if TList(lParam).IndexOf(Pointer(aSize)) < 0 then\r\n TList(lParam).Add(Pointer(aSize));\r\n Result := 1;\r\nend;\r\n\r\nfunction SizeSort(Item1, Item2: Pointer): Integer;\r\nbegin\r\n Result := Integer(Item1) - Integer(Item2);\r\nend;\r\n\r\nfunction TJvFontComboBox.IsTrueType: Boolean;\r\nbegin\r\n if ItemIndex >= 0 then\r\n Result := (Integer(Items.Objects[ItemIndex]) and TRUETYPE_FONTTYPE) <> 0\r\n else\r\n Result := False;\r\nend;\r\n\r\nprocedure TJvFontComboBox.FontSizeList(SizeList: TList);\r\nconst\r\n cTTSizes: array [0..15] of Integer =\r\n (8, 9, 10, 11, 12, 14, 16, 18, 20, 22, 24, 26, 28, 36, 48, 72);\r\nvar\r\n DC: HDC;\r\n I:Integer;\r\nbegin\r\n if SizeList = nil then\r\n Exit;\r\n SizeList.Clear;\r\n if IsTrueType then\r\n begin\r\n // fill in constant sizes for true type fonts\r\n SizeList.Clear;\r\n for I := Low(cTTSizes) to High(cTTSizes) do\r\n SizeList.Add(Pointer(cTTSizes[I]));\r\n end\r\n else\r\n begin\r\n DC := GetDC(HWND_DESKTOP);\r\n try\r\n FPixelsPerInch := GetDeviceCaps(DC, LOGPIXELSY);\r\n EnumFontFamilies(DC, PChar(FontName), @GetFontSizesEnum, LPARAM(SizeList));\r\n SizeList.Sort(SizeSort);\r\n finally\r\n ReleaseDC(HWND_DESKTOP, DC);\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJvFontComboBox.AddToMRU: Integer;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := ItemIndex;\r\n if csDesigning in ComponentState then\r\n Exit;\r\n if (MaxMRUCount = 0) or (MaxMRUCount > MRUCount) then\r\n begin\r\n I := Items.IndexOf(Text);\r\n if (I > MRUCount - 1) and (I >= 0) then\r\n begin\r\n Items.InsertObject(0, Items[I], Items.Objects[I]);\r\n Inc(FMRUCount);\r\n end\r\n else\r\n if I < 0 then\r\n begin\r\n Items.InsertObject(0, Text, TObject(TRUETYPE_FONTTYPE));\r\n Inc(FMRUCount);\r\n end;\r\n Result := 0;\r\n end\r\n else\r\n if (MRUCount > 0) and (ItemIndex > 0) then\r\n begin\r\n Items[0] := Items[ItemIndex];\r\n Items.Objects[0] := Items.Objects[ItemIndex];\r\n Result := 0;\r\n end;\r\nend;\r\n\r\nprocedure TJvFontComboBox.MouseDown(Button: TMouseButton;\r\n Shift: TShiftState; X, Y: Integer);\r\nbegin\r\n FWasMouse := False;\r\n inherited MouseDown(Button, Shift, X, Y);\r\nend;\r\n\r\nprocedure TJvFontComboBox.MouseUp(Button: TMouseButton; Shift: TShiftState;\r\n X, Y: Integer);\r\nbegin\r\n FWasMouse := True;\r\n inherited MouseUp(Button, Shift, X, Y);\r\nend;\r\n\r\nprocedure TJvFontComboBox.CloseUp;\r\nbegin\r\n inherited CloseUp;\r\n if FShowMRU then\r\n begin\r\n AddToMRU;\r\n ItemIndex := Items.IndexOf(Text);\r\n FWasMouse := False;\r\n end;\r\nend;\r\n\r\nprocedure TJvFontComboBox.ClearMRU;\r\nbegin\r\n while FMRUCount > 0 do\r\n begin\r\n Items.Delete(0);\r\n Dec(FMRUCount);\r\n end;\r\nend;\r\n\r\nprocedure TJvFontComboBox.KeyDown(var Key: Word; Shift: TShiftState);\r\nbegin\r\n // (rom) only accept without Shift, Alt or Ctrl down\r\n if (Shift * KeyboardShiftStates = []) and\r\n (Key = VK_RETURN) and FShowMRU then\r\n ItemIndex := AddToMRU;\r\n inherited KeyDown(Key, Shift);\r\nend;\r\n\r\nprocedure TJvFontComboBox.SetMaxMRUCount(const Value: Integer);\r\nvar\r\n S: string;\r\nbegin\r\n if FMaxMRUCount <> Value then\r\n begin\r\n FMaxMRUCount := Value;\r\n if (FMaxMRUCount > 0) and (FMRUCount > 0) then\r\n begin\r\n S := Text;\r\n while FMRUCount > FMaxMRUCount do\r\n begin\r\n Items.Delete(0);\r\n Dec(FMRUCount);\r\n end;\r\n ItemIndex := Items.IndexOf(S);\r\n if ItemIndex < 0 then\r\n ItemIndex := 0;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvFontComboBox.SetParent(AParent: TWinControl);\r\nbegin\r\n inherited SetParent(AParent);\r\n if (Parent <> nil) then\r\n FontName := Font.Name;\r\nend;\r\n\r\nfunction EnumFontSizeProc(var LogFont: TLogFont; var TextMetric: TTextMetric;\r\n FontType: Integer; FontCombo: TJvFontComboBox): Integer; stdcall;\r\nvar\r\n tmp: Integer;\r\nbegin\r\n if FontType and TRUETYPE_FONTTYPE <> TRUETYPE_FONTTYPE then // TTF's don't have size info\r\n begin\r\n tmp := Round(((TextMetric.tmHeight - TextMetric.tmInternalLeading) * 72) / GetDeviceCaps(FontCombo.FEnumeratorDC, LOGPIXELSY));\r\n FontCombo.FFontSizes.AddObject(IntToStr(tmp), TObject(tmp));\r\n Result := 1;\r\n end\r\n else\r\n Result := 0;\r\nend;\r\n\r\nfunction IntegerSort(List: TStringList; Index1, Index2: Integer): Integer;\r\nbegin\r\n Result := StrToIntDef(List[Index1], 0) - StrToIntDef(List[Index2], 0);\r\nend;\r\n\r\nfunction TJvFontComboBox.GetFontSizes: TStrings;\r\nbegin\r\n if FFontSizes = nil then\r\n FFontSizes := TStringlist.Create;\r\n FFontSizes.Clear;\r\n TStringList(FFontSizes).Sorted := True;\r\n\r\n FEnumeratorDC := GetDC(HWND_DESKTOP);\r\n try\r\n if FDevice in [fdScreen, fdBoth] then\r\n EnumFonts(FEnumeratorDC, PChar(FontName), @EnumFontSizeProc, Pointer(Self));\r\n finally\r\n ReleaseDC(HWND_DESKTOP, FEnumeratorDC);\r\n end;\r\n if FDevice in [fdPrinter, fdBoth] then\r\n try\r\n FEnumeratorDC := Printer.Handle;\r\n EnumFonts(FEnumeratorDC, PChar(FontName), @EnumFontSizeProc, Pointer(Self));\r\n except\r\n // ignore exceptions (printer may not be installed)\r\n end;\r\n\r\n TStringlist(FFontSizes).Sorted := False;\r\n if FFontSizes.Count > 1 then\r\n TStringList(FFontSizes).CustomSort(IntegerSort)\r\n else // true type font or font with only one size, so fake it:\r\n begin\r\n FFontSizes.Clear;\r\n FFontSizes.AddObject('8', TObject(8));\r\n FFontSizes.AddObject('9', TObject(9));\r\n FFontSizes.AddObject('10', TObject(10));\r\n FFontSizes.AddObject('11', TObject(11));\r\n FFontSizes.AddObject('12', TObject(12));\r\n FFontSizes.AddObject('14', TObject(14));\r\n FFontSizes.AddObject('16', TObject(16));\r\n FFontSizes.AddObject('18', TObject(18));\r\n FFontSizes.AddObject('20', TObject(20));\r\n FFontSizes.AddObject('22', TObject(22));\r\n FFontSizes.AddObject('24', TObject(24));\r\n FFontSizes.AddObject('26', TObject(26));\r\n FFontSizes.AddObject('28', TObject(28));\r\n FFontSizes.AddObject('36', TObject(36));\r\n FFontSizes.AddObject('48', TObject(48));\r\n FFontSizes.AddObject('72', TObject(72));\r\n end;\r\n Result := FFontSizes;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\n\r\n\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n {$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n\r\n" }, { "path": "External/Jedi/Jvcl/run/JvColorForm.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvColorForm.PAS, released on 2002-05-26.\r\n\r\nThe Initial Developer of the Original Code is Peter Thrnqvist [peter3 at sourceforge dot net]\r\nPortions created by Peter Thrnqvist are Copyright (C) 2002 Peter Thrnqvist.\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nDescription:\r\n Color form for the @link(TJvColorButton) component\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvColorForm.pas 13350 2012-06-13 14:54:41Z obones $\r\n\r\nunit JvColorForm;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, Messages,\r\n Classes, Graphics, Controls, Forms, Buttons, Dialogs,\r\n JvConsts,\r\n JvColorBox, JvComponent;\r\n\r\nconst\r\n cButtonWidth = 22;\r\n\r\ntype\r\n // (ahuser) TJvColorDialog is not registered as component\r\n TJvColorDialog = class(TColorDialog)\r\n published\r\n property OnShow;\r\n property OnClose;\r\n end;\r\n\r\n TJvColorForm = class(TJvForm)\r\n OtherBtn: TSpeedButton;\r\n procedure OtherBtnClick(Sender: TObject);\r\n procedure DoColorClick(Sender: TObject);\r\n procedure DoColorChange(Sender: TObject);\r\n procedure FormKeyUp(Sender: TObject; var Key: Word; Shift: TShiftState);\r\n procedure FormClose(Sender: TObject; var Action: TCloseAction);\r\n procedure FormActivate(Sender: TObject);\r\n procedure FormDeactivate(Sender: TObject);\r\n private\r\n FOwner: TControl;\r\n FCDVisible: Boolean;\r\n FCS: TJvColorSquare;\r\n FButtonSize: Integer;\r\n FColorDialog: TJvColorDialog;\r\n FSelectedColor: TColor;\r\n protected\r\n procedure ShowCD(Sender: TObject);\r\n procedure HideCD(Sender: TObject);\r\n procedure WMActivate(var Msg: TWMActivate); message WM_ACTIVATE;\r\n procedure SetButtonSize(const Value: Integer);\r\n protected\r\n procedure CreateParams(var Params: TCreateParams); override;\r\n procedure UpdateSize; virtual;\r\n public\r\n constructor CreateNew(AOwner: TComponent; Dummy: Integer = 0); override;\r\n procedure MakeColorButtons;\r\n procedure SetButton(Button: TControl);\r\n property ButtonSize: Integer read FButtonSize write SetButtonSize default cButtonWidth;\r\n property ColorDialog: TJvColorDialog read FColorDialog write FColorDialog;\r\n property SelectedColor: TColor read FSelectedColor write FSelectedColor default clBlack;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvColorForm.pas $';\r\n Revision: '$Revision: 13350 $';\r\n Date: '$Date: 2012-06-13 16:54:41 +0200 (mer. 13 juin 2012) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n ExtCtrls,\r\n JvColorButton;\r\n\r\nconstructor TJvColorForm.CreateNew(AOwner: TComponent; Dummy: Integer);\r\nbegin\r\n inherited CreateNew(AOwner, Dummy);\r\n// IsPopupWindow := True;\r\n FButtonSize := cButtonWidth;\r\n FSelectedColor := clBlack;\r\n BorderIcons := [];\r\n BorderStyle := bsDialog;\r\n // (rom) this is not a standard Windows font\r\n// Font.Name := 'MS Shell Dlg 2';\r\n// FormStyle := fsStayOnTop;\r\n KeyPreview := True;\r\n OnActivate := FormActivate;\r\n OnClose := FormClose;\r\n OnKeyUp := FormKeyUp;\r\n\r\n FColorDialog := TJvColorDialog.Create(Self);\r\n FCDVisible := False;\r\n FColorDialog.OnShow := ShowCD;\r\n FColorDialog.OnClose := HideCD;\r\n MakeColorButtons;\r\n IsFocusable := False;\r\nend;\r\n\r\nprocedure TJvColorForm.SetButton(Button: TControl);\r\nbegin\r\n FOwner := Button;\r\nend;\r\n\r\nprocedure TJvColorForm.ShowCD(Sender: TObject);\r\nbegin\r\n FCDVisible := True;\r\nend;\r\n\r\nprocedure TJvColorForm.HideCD(Sender: TObject);\r\nbegin\r\n FCDVisible := False;\r\nend;\r\n\r\nprocedure TJvColorForm.OtherBtnClick(Sender: TObject);\r\nbegin\r\n if Assigned(FOwner) and (FOwner is TJvColorButton) then\r\n TJvColorButton(FOwner).Color := SelectedColor;\r\n FColorDialog.Color := SelectedColor;\r\n if FColorDialog.Execute then\r\n begin\r\n FCS.Color := FColorDialog.Color;\r\n if FOwner is TJvColorButton then\r\n begin\r\n TJvColorButton(FOwner).CustomColors.Assign(FColorDialog.CustomColors);\r\n TJvColorButton(FOwner).Color := SelectedColor;\r\n end;\r\n ModalResult := mrOK;\r\n end\r\n else\r\n ModalResult := mrCancel;\r\n Hide;\r\nend;\r\n\r\nprocedure TJvColorForm.FormDeactivate(Sender: TObject);\r\nbegin\r\n if not FCDVisible then\r\n begin\r\n if Visible then\r\n Hide;\r\n ModalResult := mrCancel;\r\n end;\r\nend;\r\n\r\n\r\n\r\nprocedure TJvColorForm.WMActivate(var Msg: TWMActivate);\r\nbegin\r\n inherited;\r\n if Msg.Active = WA_INACTIVE then\r\n FormDeactivate(Self);\r\nend;\r\n\r\nprocedure TJvColorForm.CreateParams(var Params: TCreateParams);\r\nbegin\r\n inherited CreateParams(Params);\r\n Params.Style := Params.Style and not WS_CAPTION;\r\nend;\r\n\r\n\r\n\r\n\r\n\r\nprocedure TJvColorForm.DoColorClick(Sender: TObject);\r\nbegin\r\n if Sender is TJvColorSquare then\r\n SelectedColor := (Sender as TJvColorSquare).Color;\r\n Hide;\r\n if Assigned(FOwner) and (FOwner is TJvColorButton) then\r\n TJvColorButton(FOwner).Color := SelectedColor;\r\n ModalResult := mrOK;\r\nend;\r\n\r\nprocedure TJvColorForm.DoColorChange(Sender: TObject);\r\nbegin\r\n SelectedColor := FCS.Color;\r\n if Assigned(FOwner) and (FOwner is TJvColorButton) then\r\n TJvColorButton(FOwner).Color := SelectedColor;\r\nend;\r\n\r\nprocedure TJvColorForm.FormKeyUp(Sender: TObject; var Key: Word;\r\n Shift: TShiftState);\r\nbegin\r\n if (Key = VK_ESCAPE) and (Shift * KeyboardShiftStates = []) then\r\n begin\r\n Hide;\r\n ModalResult := mrCancel;\r\n end;\r\nend;\r\n\r\nprocedure TJvColorForm.FormClose(Sender: TObject; var Action: TCloseAction);\r\nbegin\r\n Action := caFree;\r\nend;\r\n\r\nprocedure TJvColorForm.FormActivate(Sender: TObject);\r\nvar\r\n R: TRect;\r\n Pt: TPoint;\r\nbegin\r\n { set placement }\r\n if Assigned(FOwner) then\r\n begin\r\n R := FOwner.ClientRect;\r\n Pt.X := R.Left;\r\n Pt.Y := R.Top + R.Bottom;\r\n Pt := FOwner.ClientToScreen(Pt);\r\n Left := Pt.X;\r\n Top := Pt.Y;\r\n if FOwner is TJvColorButton then\r\n SelectedColor := TJvColorButton(FOwner).Color;\r\n end;\r\n UpdateSize;\r\nend;\r\n\r\nprocedure TJvColorForm.MakeColorButtons;\r\nconst\r\n cColorArray: array [0..19] of TColor =\r\n (clWhite, clBlack, clSilver, clGray,\r\n clRed, clMaroon, clYellow, clOlive,\r\n clLime, clGreen, clAqua, clTeal,\r\n clBlue, clNavy, clFuchsia, clPurple,\r\n clMoneyGreen, clSkyBlue, clCream, clMedGray);\r\nvar\r\n I, X, Y: Integer;\r\n ParentControl: TWinControl;\r\n Offset: Integer;\r\nbegin\r\n for I := ControlCount - 1 downto 0 do\r\n if (Controls[I] is TJvColorSquare) or (Controls[I] is TBevel) then\r\n Controls[I].Free;\r\n\r\n ParentControl := Self;\r\n Offset := 0;\r\n\r\n X := Offset;\r\n Y := Offset;\r\n for I := 0 to 19 do\r\n begin\r\n FCS := TJvColorSquare.Create(Self);\r\n FCS.SetBounds(X, Y, FButtonSize, FButtonSize);\r\n FCS.Color := cColorArray[I];\r\n FCS.OnClick := DoColorClick;\r\n FCS.Parent := ParentControl;\r\n FCS.BorderStyle := bsSingle;\r\n Inc(X, FButtonSize);\r\n if (I + 1) mod 4 = 0 then\r\n begin\r\n Inc(Y, FButtonSize);\r\n X := Offset;\r\n end;\r\n end;\r\n if OtherBtn = nil then\r\n OtherBtn := TSpeedButton.Create(Self);\r\n with OtherBtn do\r\n begin\r\n SetBounds(Offset, Y + 6, FButtonSize * 3, FButtonSize);\r\n Parent := ParentControl;\r\n// Caption := SOtherCaption;\r\n OnClick := OtherBtnClick;\r\n end;\r\n FCS := TJvColorSquare.Create(Self);\r\n FCS.Color := cColorArray[0];\r\n FCS.OnClick := DoColorClick;\r\n FCS.OnChange := DoColorChange;\r\n FCS.Parent := ParentControl;\r\n FCS.BorderStyle := bsSingle;\r\n FCS.SetBounds(Offset + FButtonSize * 3, Y + 6, FButtonSize, FButtonSize);\r\n UpdateSize;\r\n with TBevel.Create(Self) do\r\n begin\r\n Parent := ParentControl;\r\n Shape := bsTopLine;\r\n SetBounds(2, Y, Self.Width - 4, 4);\r\n Anchors := [akLeft, akBottom, akRight];\r\n end;\r\nend;\r\n\r\nprocedure TJvColorForm.UpdateSize;\r\nbegin\r\n Height := OtherBtn.Top + OtherBtn.Height + 8;\r\n ClientWidth := FCS.Left + FCS.Width;\r\nend;\r\n\r\nprocedure TJvColorForm.SetButtonSize(const Value: Integer);\r\nbegin\r\n if FButtonSize <> Value then\r\n begin\r\n FButtonSize := Value;\r\n MakeColorButtons;\r\n end;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvColorProvider.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvColorProvider.pas, released on 2003-07-18.\r\n\r\nThe Initial Developer of the Original Code is Marcel Bestebroer\r\nPortions created by Marcel Bestebroer are Copyright (C) 2002 - 2003 Marcel\r\nBestebroer\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvColorProvider.pas 13138 2011-10-26 23:17:50Z jfudickar $\r\n\r\nunit JvColorProvider;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, Classes, Contnrs, Graphics, Dialogs,\r\n JclBase,\r\n JvDataProvider, JvDataProviderIntf, JvTypes;\r\n\r\ntype\r\n TJvColorProvider = class;\r\n TJvColorProviderNameMappings = class;\r\n TJvColorProviderNameMapping = class;\r\n IJvColorProvider = interface;\r\n\r\n TColorItem = record\r\n Value: TColor;\r\n Names: TDynStringArray;\r\n end;\r\n\r\n TColorItems = array of TColorItem;\r\n TJvColorProviderMapping = type Integer;\r\n TJvColorProviderAddItemLocation = (ailUseHeader, ailTop, ailBottom);\r\n TJvColorProviderAddColorStyle = type Integer;\r\n TColorGroupHeaderAlign = (ghaLeft, ghaCenter, ghaColorText);\r\n TColorGroupHeaderStyle = (ghsBoldFont, ghsSingleCenterLine, ghsDoubleCenterLine);\r\n TColorGroupHeaderStyles = set of TColorGroupHeaderStyle;\r\n\r\n TJvColorProviderColorAdder = procedure(Provider: IJvColorProvider; ColorType: TColorType;\r\n var Color: TColor; var DoAdd: Boolean);\r\n TJvColorProviderAddColorEvent = procedure(Provider: TJvColorProvider; ColorType: TColorType;\r\n var Color: TColor; var DoAdd: Boolean) of object;\r\n\r\n IJvColorProvider = interface\r\n ['{3DF32721-553B-4759-A628-35F5CA62F3D5}']\r\n procedure DoAddColor(ColorType: TColorType; var Color: TColor; var DoAdd: Boolean);\r\n function AddColor(ColorType: TColorType; Color: TColor): Boolean;\r\n function IndexOfMapping(Mapping: TJvColorProviderNameMapping): Integer;\r\n function IndexOfMappingName(Name: string): Integer;\r\n function Get_MappingCount: Integer;\r\n function Get_Mapping(Index: Integer): TJvColorProviderNameMapping;\r\n function AddMapping(AName: string): Integer;\r\n function NewMapping: Integer;\r\n procedure DeleteMapping(Index: Integer);\r\n function GetStandardCount: Integer;\r\n function GetSystemCount: Integer;\r\n function GetCustomCount: Integer;\r\n function GetStandardColor(Index: Integer; out Value: TColor; out Name: string): Boolean;\r\n function GetSystemColor(Index: Integer; out Value: TColor; out Name: string): Boolean;\r\n function GetCustomColor(Index: Integer; out Value: TColor; out Name: string): Boolean;\r\n function FindColor(Value: TColor; out ColorType: TColorType; out Index: Integer): Boolean;\r\n procedure SetStandardColorName(Index: Integer; NewName: string);\r\n procedure SetSystemColorName(Index: Integer; NewName: string);\r\n procedure SetCustomColorName(Index: Integer; NewName: string);\r\n function AddStdColor(Value: TColor): Boolean;\r\n procedure DeleteStdColor(Value: TColor);\r\n procedure DeleteStdColorAt(Index: Integer);\r\n procedure ClearStdColorList;\r\n function AddSysColor(Value: TColor): Boolean;\r\n procedure DeleteSysColor(Value: TColor);\r\n procedure DeleteSysColorAt(Index: Integer);\r\n procedure ClearSysColorList;\r\n function AddCstColor(Value: TColor): Boolean;\r\n procedure DeleteCstColor(Value: TColor);\r\n procedure DeleteCstColorAt(Index: Integer);\r\n procedure ClearCstColorList;\r\n\r\n property MappingCount: Integer read Get_MappingCount;\r\n property Mappings[Index: Integer]: TJvColorProviderNameMapping read Get_Mapping;\r\n end;\r\n\r\n IJvColorMappingProvider = interface\r\n ['{B6BA8036-8ECF-463B-BAD3-6855D4845F3F}']\r\n function Get_ClientProvider: IJvColorProvider;\r\n procedure Set_ClientProvider(Value: IJvColorProvider);\r\n\r\n property ClientProvider: IJvColorProvider read Get_ClientProvider write Set_ClientProvider;\r\n end;\r\n\r\n IJvColorItem = interface\r\n ['{ED95EC41-EEE2-4E14-ABF6-5B7B5EA47FFF}']\r\n function Get_Color: TColor;\r\n\r\n property Color: TColor read Get_Color;\r\n end;\r\n\r\n IJvColorMapItem = interface\r\n ['{8906A180-71C0-4DF6-9029-5513B341541E}']\r\n function Get_NameMapping: TJvColorProviderNameMapping;\r\n\r\n property NameMapping: TJvColorProviderNameMapping read Get_NameMapping;\r\n end;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64 or pidOSX32)]\r\n {$ENDIF RTL230_UP}\r\n TJvColorProvider = class(TJvCustomDataProvider, IJvColorProvider)\r\n private\r\n FColorList: TColorItems; // all colors the provider knows about\r\n FStdColors: array of TDynIntegerArray; // list of standard colors for each context\r\n FSysColors: array of TDynIntegerArray; // list of system colors for each context\r\n FCstColors: array of TDynIntegerArray; // list of custom colors for each context\r\n FMappings: TJvColorProviderNameMappings;\r\n FColorListChanged: Boolean; // Flag to keep track of changes in FColorList w/resp. to the default\r\n FOnAddColor: TJvColorProviderAddColorEvent;\r\n protected\r\n { Notify any registered notifiers something is changing. For each notifier that is also a\r\n consumer, that consumer will only be notified if it has the proper context. The settings\r\n determine if either the GroupedItem or RootItem is specified as the Source. Any non-consumer\r\n or consumers without a context or settings interface will receive the GroupedItem as the\r\n Source parameter. }\r\n procedure NotifyChanging(Reason: TDataProviderChangeReason; ContextIndex: Integer; GroupedItem,\r\n RootItem: IUnknown);\r\n { Notify any registered notifiers something has changed. For each notifier that is also a\r\n consumer, that consumer will only be notified if it has the proper context. The settings\r\n determine if either the GroupedItem or RootItem is specified as the Source. Any non-consumer\r\n or consumers without a context or settings interface will receive the GroupedItem as the\r\n Source parameter. }\r\n procedure NotifyChanged(Reason: TDataProviderChangeReason; ContextIndex: Integer; GroupedItem,\r\n RootItem: IUnknown);\r\n { Notify all registered notifiers a color is being added to the specified group. }\r\n procedure NotifyColorAdding(ColorType: TColorType; ContextIndex: Integer = -1);\r\n { Notify all registered notifiers a color has been added to the specified group. }\r\n procedure NotifyColorAdded(ColorType: TColorType; ListIndex: Integer; ContextIndex: Integer = -1);\r\n { Notify all registered notifiers a color is being removed from the specified group. }\r\n procedure NotifyColorDeleting(ColorType: TColorType; ListIndex: Integer; ContextIndex: Integer = -1);\r\n { Notify all registered notifiers a color has been removed to the specified group. }\r\n procedure NotifyColorDeleted(ColorType: TColorType; ContextIndex: Integer = -1);\r\n { Notify all registered notifiers a color is being removed from the specified group. }\r\n procedure NotifyColorsUpdating(ColorType: TColorType; ContextIndex: Integer = -1);\r\n { Notify all registered notifiers a color has been removed to the specified group. }\r\n procedure NotifyColorsUpdated(ColorType: TColorType; ContextIndex: Integer = -1);\r\n\r\n procedure DoAddColor(ColorType: TColorType; var Color: TColor; var DoAdd: Boolean);\r\n function AddInternalColor(Color: TColor; AddToCustomDefaultList: Boolean): Integer;\r\n function AddColor(var List: TDynIntegerArray; Color: TColor;\r\n ColorType: TColorType; Context: Integer): Integer; overload;\r\n function AddColor(var List: TDynIntegerArray; Color: TColor; ColorType: TColorType;\r\n Context: Integer; out Added: Boolean): Integer; overload;\r\n procedure DeleteColor(var List: TDynIntegerArray; Index: Integer; ColorType: TColorType;\r\n Context: Integer);\r\n procedure RemoveContextList(Index: Integer); virtual;\r\n function IndexOfColor(Color: TColor): Integer;\r\n function IndexOfColIdx(const List: TDynIntegerArray; ColorIndex: Integer): Integer;\r\n procedure CopyFromDefCtx(const TargetContextIndex: Integer);\r\n function SelectedContextIndex: Integer;\r\n class function ItemsClass: TJvDataItemsClass; override;\r\n class function ContextsClass: TJvDataContextsClass; override;\r\n class function ContextsManagerClass: TJvDataContextsManagerClass; override;\r\n function ConsumerClasses: TClassArray; override;\r\n procedure ContextAdded(Context: IJvDataContext); override;\r\n procedure ContextDestroying(Context: IJvDataContext); override;\r\n procedure InsertMapping(var Strings: TDynStringArray; Index: Integer);\r\n procedure DeleteMapping(var Strings: TDynStringArray; Index: Integer); overload;\r\n procedure MappingAdding;\r\n procedure MappingAdded(Index: Integer);\r\n procedure MappingDestroying(Index: Integer);\r\n procedure MappingDestroyed;\r\n function GetColor(List, Index: Integer; out Value: TColor; out Name: string): Boolean;\r\n procedure SetColorName(List, Index: Integer; const NewName: string);\r\n function GetColorCount(List: Integer): Integer;\r\n procedure GenDelphiConstantMapping;\r\n procedure GenEnglishMapping;\r\n procedure InitColorList(var List: TDynIntegerArray; const Definitions: array of TDefColorItem;\r\n ColorType: TColorType);\r\n procedure InitColors;\r\n function GetMappings: TJvColorProviderNameMappings;\r\n procedure DefineProperties(Filer: TFiler); override;\r\n procedure ReadColors(Reader: TReader);\r\n procedure WriteColors(Writer: TWriter);\r\n procedure ReadMappings(Reader: TReader);\r\n procedure WriteMappings(Writer: TWriter);\r\n procedure ReadMapping(Reader: TReader);\r\n procedure WriteMapping(Writer: TWriter; Index: Integer);\r\n function GetColorItem(ColorType: TColorType; Index: Integer): IJvDataItem;\r\n function GetColorItemByValue(ColorType: TColorType; Color: TColor): IJvDataItem;\r\n\r\n property ColorListChanged: Boolean read FColorListChanged;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n function AddColor(ColorType: TColorType; Color: TColor): Boolean; overload;\r\n function IndexOfMapping(Mapping: TJvColorProviderNameMapping): Integer;\r\n function IndexOfMappingName(Name: string): Integer;\r\n function Get_MappingCount: Integer;\r\n function Get_Mapping(Index: Integer): TJvColorProviderNameMapping;\r\n function AddMapping(AName: string): Integer;\r\n function NewMapping: Integer;\r\n procedure DeleteMapping(Index: Integer); overload;\r\n function GetStandardCount: Integer;\r\n function GetSystemCount: Integer;\r\n function GetCustomCount: Integer;\r\n function GetStandardColor(Index: Integer; out Value: TColor; out Name: string): Boolean;\r\n function GetSystemColor(Index: Integer; out Value: TColor; out Name: string): Boolean;\r\n function GetCustomColor(Index: Integer; out Value: TColor; out Name: string): Boolean;\r\n function FindColor(Value: TColor; out ColorType: TColorType; out Index: Integer): Boolean;\r\n procedure SetStandardColorName(Index: Integer; NewName: string);\r\n procedure SetSystemColorName(Index: Integer; NewName: string);\r\n procedure SetCustomColorName(Index: Integer; NewName: string);\r\n function AddStdColor(Value: TColor): Boolean;\r\n procedure DeleteStdColor(Value: TColor);\r\n procedure DeleteStdColorAt(Index: Integer);\r\n procedure ClearStdColorList;\r\n function AddSysColor(Value: TColor): Boolean;\r\n procedure DeleteSysColor(Value: TColor);\r\n procedure DeleteSysColorAt(Index: Integer);\r\n procedure ClearSysColorList;\r\n function AddCstColor(Value: TColor): Boolean;\r\n procedure DeleteCstColor(Value: TColor);\r\n procedure DeleteCstColorAt(Index: Integer);\r\n procedure ClearCstColorList;\r\n\r\n property Mappings: TJvColorProviderNameMappings read GetMappings;\r\n published\r\n property OnAddColor: TJvColorProviderAddColorEvent read FOnAddColor write FOnAddColor;\r\n end;\r\n\r\n TJvColorProviderNameMappings = class(TObjectList)\r\n private\r\n FProvider: TJvColorProvider;\r\n protected\r\n function GetItem(Index: Integer): TJvColorProviderNameMapping;\r\n procedure SetItem(Index: Integer; AObject: TJvColorProviderNameMapping);\r\n\r\n property Provider: TJvColorProvider read FProvider;\r\n public\r\n constructor Create(AProvider: TJvColorProvider);\r\n function Add(Item: TJvColorProviderNameMapping): Integer;\r\n procedure Clear; override;\r\n procedure Delete(Index: Integer);\r\n property Items[Index: Integer]: TJvColorProviderNameMapping read GetItem write SetItem; default;\r\n end;\r\n\r\n TJvColorProviderNameMapping = class(TObject)\r\n private\r\n FName: string;\r\n FOwner: TJvColorProviderNameMappings;\r\n protected\r\n property Owner: TJvColorProviderNameMappings read FOwner;\r\n public\r\n constructor Create(AOwner: TJvColorProviderNameMappings; AName: string);\r\n\r\n property Name: string read FName write FName;\r\n end;\r\n\r\n TJvColorProviderSubSettings = class(TPersistent)\r\n private\r\n FActive: Boolean;\r\n FConsumerServiceExt: TJvDataConsumerAggregatedObject;\r\n protected\r\n procedure Changed; virtual;\r\n procedure ViewChanged; virtual;\r\n procedure SetActive(Value: Boolean); virtual;\r\n property Active: Boolean read FActive write SetActive;\r\n property ConsumerServiceExt: TJvDataConsumerAggregatedObject read FConsumerServiceExt;\r\n public\r\n constructor Create(AConsumerService: TJvDataConsumerAggregatedObject);\r\n end;\r\n\r\n TJvColorProviderColorBoxSettings = class(TJvColorProviderSubSettings)\r\n private\r\n FHeight: Integer;\r\n FMargin: Integer;\r\n FShadowed: Boolean;\r\n FShadowSize: Integer;\r\n FSpacing: Integer;\r\n FWidth: Integer;\r\n protected\r\n procedure SetHeight(Value: Integer); virtual;\r\n procedure SetMargin(Value: Integer); virtual;\r\n procedure SetShadowed(Value: Boolean); virtual;\r\n procedure SetShadowSize(Value: Integer); virtual;\r\n procedure SetSpacing(Value: Integer); virtual;\r\n procedure SetWidth(Value: Integer); virtual;\r\n public\r\n constructor Create(AConsumerService: TJvDataConsumerAggregatedObject);\r\n published\r\n property Active default True;\r\n property Height: Integer read FHeight write SetHeight default 13;\r\n property Margin: Integer read FMargin write SetMargin default 2;\r\n property Shadowed: Boolean read FShadowed write SetShadowed default True;\r\n property ShadowSize: Integer read FShadowSize write SetShadowSize default 2;\r\n property Spacing: Integer read FSpacing write SetSpacing default 4;\r\n property Width: Integer read FWidth write SetWidth default 21;\r\n end;\r\n\r\n TJvColorProviderTextSettings = class(TJvColorProviderSubSettings)\r\n private\r\n FShowHex: Boolean;\r\n FShowName: Boolean;\r\n FShowRGB: Boolean;\r\n protected\r\n procedure SetShowHex(Value: Boolean); virtual;\r\n procedure SetShowName(Value: Boolean); virtual;\r\n procedure SetShowRGB(Value: Boolean); virtual;\r\n public\r\n constructor Create(AConsumerService: TJvDataConsumerAggregatedObject);\r\n published\r\n property Active default True;\r\n property ShowHex: Boolean read FShowHex write SetShowHex;\r\n property ShowName: Boolean read FShowName write SetShowName default True;\r\n property ShowRGB: Boolean read FShowRGB write SetShowRGB;\r\n end;\r\n\r\n TJvColorProviderGroupingSettings = class(TJvColorProviderSubSettings)\r\n private\r\n FFlatList: Boolean;\r\n FHeaderAlign: TColorGroupHeaderAlign;\r\n FHeaderStyle: TColorGroupHeaderStyles;\r\n protected\r\n FActiveChanging: Boolean;\r\n procedure SetActive(Value: Boolean); override;\r\n procedure Changed; override;\r\n procedure SetFlatList(Value: Boolean); virtual;\r\n procedure SetHeaderAlign(Value: TColorGroupHeaderAlign); virtual;\r\n procedure SetHeaderStyle(Value: TColorGroupHeaderStyles); virtual;\r\n public\r\n constructor Create(AConsumerService: TJvDataConsumerAggregatedObject);\r\n published\r\n property Active default True;\r\n property FlatList: Boolean read FFlatList write SetFlatList default True;\r\n property HeaderAlign: TColorGroupHeaderAlign read FHeaderAlign write SetHeaderAlign\r\n default ghaLeft;\r\n property HeaderStyle: TColorGroupHeaderStyles read FHeaderStyle write SetHeaderStyle\r\n default [ghsBoldFont, ghsSingleCenterLine];\r\n end;\r\n\r\n TJvColorProviderColorGroupSettings = class(TJvColorProviderSubSettings)\r\n private\r\n FCaption: string;\r\n FShowHeader: Boolean;\r\n protected\r\n FActiveChanging: Boolean;\r\n procedure SetActive(Value: Boolean); override;\r\n procedure Changed; override;\r\n procedure SetCaption(Value: string); virtual;\r\n procedure SetShowHeader(Value: Boolean); virtual;\r\n public\r\n constructor Create(AConsumerService: TJvDataConsumerAggregatedObject; ACaption: string);\r\n published\r\n property Active default True;\r\n property Caption: string read FCaption write SetCaption;\r\n property ShowHeader: Boolean read FShowHeader write SetShowHeader default False;\r\n end;\r\n\r\n TJvColorProviderAddColorSettings = class(TJvColorProviderSubSettings)\r\n private\r\n FLocation: TJvColorProviderAddItemLocation;\r\n FCaption: string;\r\n FStyle: Integer;\r\n protected\r\n procedure SetLocation(Value: TJvColorProviderAddItemLocation); virtual;\r\n procedure SetCaption(Value: string); virtual;\r\n function GetStyle: TJvColorProviderAddColorStyle; virtual;\r\n procedure SetStyle(Value: TJvColorProviderAddColorStyle); virtual;\r\n public\r\n constructor Create(AConsumerService: TJvDataConsumerAggregatedObject);\r\n destructor Destroy; override;\r\n published\r\n property Active;\r\n property Location: TJvColorProviderAddItemLocation read FLocation write SetLocation\r\n default ailBottom;\r\n property Caption: string read FCaption write SetCaption;\r\n property Style: TJvColorProviderAddColorStyle read GetStyle write SetStyle;\r\n end;\r\n\r\n TJvColorProviderCustomColorGroupSettings = class(TJvColorProviderColorGroupSettings)\r\n private\r\n FAddColorSettings: TJvColorProviderAddColorSettings;\r\n protected\r\n procedure SetAddColorSettings(Value: TJvColorProviderAddColorSettings); virtual;\r\n public\r\n constructor Create(AConsumerService: TJvDataConsumerAggregatedObject; ACaption: string);\r\n destructor Destroy; override;\r\n published\r\n property AddColorSettings: TJvColorProviderAddColorSettings read FAddColorSettings\r\n write SetAddColorSettings;\r\n end;\r\n\r\n IJvColorProviderSettings = interface\r\n ['{5381D2E0-D8EA-46E7-A3C6-42B5353B896B}']\r\n function Get_ColorBoxSettings: TJvColorProviderColorBoxSettings;\r\n function Get_CustomColorSettings: TJvColorProviderCustomColorGroupSettings;\r\n function Get_GroupingSettings: TJvColorProviderGroupingSettings;\r\n function Get_NameMapping: TJvColorProviderNameMapping;\r\n function Get_NameMappingIndex: Integer;\r\n function Get_StandardColorSettings: TJvColorProviderColorGroupSettings;\r\n function Get_SystemColorSettings: TJvColorProviderColorGroupSettings;\r\n function Get_TextSettings: TJvColorProviderTextSettings;\r\n procedure Set_NameMapping(Value: TJvColorProviderNameMapping);\r\n procedure Set_NameMappingIndex(Value: Integer);\r\n procedure MappingAdding;\r\n procedure MappingAdded(Index: Integer; Mapping: TJvColorProviderNameMapping);\r\n procedure MappingDestroying(Index: Integer; Mapping: TJvColorProviderNameMapping);\r\n procedure MappingDestroyed;\r\n\r\n property ColorBoxSettings: TJvColorProviderColorBoxSettings read Get_ColorBoxSettings;\r\n property CustomColorSettings: TJvColorProviderCustomColorGroupSettings\r\n read Get_CustomColorSettings;\r\n property GroupingSettings: TJvColorProviderGroupingSettings read Get_GroupingSettings;\r\n property NameMapping: TJvColorProviderNameMapping read Get_NameMapping write Set_NameMapping;\r\n property NameMappingIndex: Integer read Get_NameMappingIndex write Set_NameMappingIndex;\r\n property StandardColorSettings: TJvColorProviderColorGroupSettings\r\n read Get_StandardColorSettings;\r\n property SystemColorSettings: TJvColorProviderColorGroupSettings read Get_SystemColorSettings;\r\n property TextSettings: TJvColorProviderTextSettings read Get_TextSettings;\r\n end;\r\n\r\n { Provider containing the available name mappings of a color provider. }\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64 or pidOSX32)]\r\n {$ENDIF RTL230_UP}\r\n TJvColorMappingProvider = class(TJvCustomDataProvider, IJvColorMappingProvider)\r\n function IJvColorMappingProvider.Get_ClientProvider = GetColorProviderIntf;\r\n procedure IJvColorMappingProvider.Set_ClientProvider = SetColorProviderIntf;\r\n private\r\n function GetColorProviderIntf: IJvColorProvider;\r\n procedure SetColorProviderIntf(Value: IJvColorProvider);\r\n protected\r\n class function ItemsClass: TJvDataItemsClass; override;\r\n function ConsumerClasses: TClassArray; override;\r\n public\r\n property ProviderIntf: IJvColorProvider read GetColorProviderIntf write SetColorProviderIntf;\r\n published\r\n property Provider: IJvColorProvider read GetColorProviderIntf write SetColorProviderIntf;\r\n end;\r\n\r\n TJvColorProviderServerNotify = class(TJvDataConsumerServerNotify)\r\n protected\r\n procedure ItemSelected(Value: IJvDataItem); override;\r\n function IsValidClient(Client: IJvDataConsumerClientNotify): Boolean; override;\r\n end;\r\n\r\n TJvColorProviderColorAdderRegister = class(TObject)\r\n private\r\n FDefaultAdder: Integer;\r\n FList: TStringList;\r\n FMinimumKeep: Integer;\r\n FDefaultAfterClear: Integer;\r\n FNotifiers: TList;\r\n protected\r\n procedure RegisterNotify(Value: TJvColorProviderAddColorSettings);\r\n procedure UnregisterNotify(Value: TJvColorProviderAddColorSettings);\r\n public\r\n constructor Create;\r\n destructor Destroy; override;\r\n\r\n function Add(Name: string; Callback: TJvColorProviderColorAdder): Integer;\r\n procedure Delete(Callback: TJvColorProviderColorAdder); overload;\r\n procedure Delete(Index: Integer); overload;\r\n procedure Delete(Name: string); overload;\r\n procedure Clear;\r\n function IndexOf(Name: string): Integer; overload;\r\n function IndexOf(Callback: TJvColorProviderColorAdder): Integer; overload;\r\n\r\n function Count: Integer;\r\n function Names(Index: Integer): string;\r\n function Callbacks(Index: Integer): TJvColorProviderColorAdder;\r\n\r\n property DefaultAdder: Integer read FDefaultAdder write FDefaultAdder;\r\n end;\r\n\r\nconst\r\n cColorItemIDPrefix = 'TCOLOR=';\r\n cColorProviderGroupHeaderID = 'ColorGroupHeader_';\r\n cColorProviderAddItemID = 'CP_ADDITEM';\r\n cColorProviderColorMapItemID = 'COLMAP:';\r\n ColorProvider_NotAColor = TColor($EFFFFFFF);\r\n\r\nfunction ColorProviderColorAdderRegister: TJvColorProviderColorAdderRegister;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvColorProvider.pas $';\r\n Revision: '$Revision: 13138 $';\r\n Date: '$Date: 2011-10-27 01:17:50 +0200 (jeu. 27 oct. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n SysUtils, RTLConsts, Controls,\r\n JclStrings,\r\n JvJVCLUtils, JvJCLUtils, JvResources;\r\n\r\nconst\r\n aisPrvEvt = 'aisPrvEvt';\r\n aisStdDlg = 'aisStdDlg';\r\n\r\ntype\r\n TWriterAccessProtected = class(TWriter);\r\n\r\nfunction GetItemColorValue(Item: IJvDataItem; out Color: TColor): Boolean;\r\nvar\r\n S: string;\r\nbegin\r\n S := Item.GetID;\r\n Result := Copy(S, 1, 7) = cColorItemIDPrefix;\r\n if Result then\r\n begin\r\n Color := StrToInt('$0' + Copy(S, 8, 8));\r\n {$IFDEF COMPILER7_UP}\r\n if (Color and $80000000) <> 0 then\r\n Color := Color or TColor(clSystemColor);\r\n {$ENDIF COMPILER7_UP}\r\n end;\r\nend;\r\n\r\nfunction GetUniqueMappingName(Mappings: TJvColorProviderNameMappings; Prefix: string): string;\r\nvar\r\n PrefixLen: Integer;\r\n SuffixNum: Int64;\r\n MapIdx: Integer;\r\n TmpNum: Int64;\r\nbegin\r\n PrefixLen := Length(Prefix);\r\n SuffixNum := 1;\r\n for MapIdx := 0 to Mappings.Count - 1 do\r\n if AnsiSameStr(Prefix, Copy(Mappings[MapIdx].Name, 1, PrefixLen)) then\r\n with Mappings[MapIdx] do\r\n begin\r\n if StrIsSubset(Copy(Name, PrefixLen + 1, Length(Name) - PrefixLen), CharIsDigit) then\r\n begin\r\n TmpNum := StrToInt64(Copy(Name, PrefixLen + 1, Length(Name) - PrefixLen));\r\n if TmpNum >= SuffixNum then\r\n SuffixNum := TmpNum + 1;\r\n end;\r\n end;\r\n Result := Prefix + IntToStr(SuffixNum);\r\nend;\r\n\r\n//=== Color provider color adding methods ====================================\r\n\r\nprocedure AddColorProviderEvent(Provider: IJvColorProvider; ColorType: TColorType;\r\n var Color: TColor; var DoAdd: Boolean);\r\nbegin\r\n Provider.DoAddColor(ColorType, Color, DoAdd);\r\nend;\r\n\r\nprocedure AddColorColorDialog(Provider: IJvColorProvider; ColorType: TColorType; var AColor: TColor;\r\n var DoAdd: Boolean);\r\nbegin\r\n with TColorDialog.Create(nil) do\r\n try\r\n DoAdd := Execute;\r\n AColor := Color;\r\n finally\r\n Free;\r\n end;\r\nend;\r\n\r\n//=== Color provider color adding methods registration =======================\r\n\r\nvar\r\n AdderReg: TJvColorProviderColorAdderRegister;\r\n\r\nfunction ColorProviderColorAdderRegister: TJvColorProviderColorAdderRegister;\r\nbegin\r\n if AdderReg = nil then\r\n begin\r\n AdderReg := TJvColorProviderColorAdderRegister.Create;\r\n AdderReg.Add(aisPrvEvt, AddColorProviderEvent);\r\n AdderReg.DefaultAdder := AdderReg.Add(aisStdDlg, AddColorColorDialog);\r\n AdderReg.FMinimumKeep := AdderReg.Count;\r\n AdderReg.FDefaultAfterClear := AdderReg.DefaultAdder;\r\n end;\r\n Result := AdderReg;\r\nend;\r\n\r\nvar\r\n MasterColorConsumer: IJvDataConsumer;\r\n\r\ntype\r\n TJvColorItems = class(TJvBaseDataItems)\r\n private\r\n FColorProvider: IJvColorProvider;\r\n protected\r\n function GetColorSettings: IJvColorProviderSettings;\r\n function GetCount: Integer; override;\r\n function GetItem(I: Integer): IJvDataItem; override;\r\n procedure InitImplementers; override;\r\n procedure InternalAdd(Item: IJvDataItem); override;\r\n procedure InternalDelete(Index: Integer); override;\r\n procedure InternalMove(OldIndex, NewIndex: Integer); override;\r\n\r\n property ColorProvider: IJvColorProvider read FColorProvider write FColorProvider;\r\n public\r\n procedure AfterConstruction; override;\r\n end;\r\n\r\n TJvColorItemsList = class(TJvColorItems)\r\n private\r\n FListNum: Integer;\r\n protected\r\n function GetCount: Integer; override;\r\n function GetItem(I: Integer): IJvDataItem; override;\r\n\r\n property ListNum: Integer read FListNum write FListNum;\r\n public\r\n procedure AfterConstruction; override;\r\n end;\r\n\r\n TJvColorItem = class(TJvBaseDataItem, IJvDataItemText, IJvColorItem)\r\n private\r\n FListNumber: Integer; // 0 = StdColors, 1 = SysColors, 2 = CstColors\r\n FListIndex: Integer; // Index in color list\r\n protected\r\n function GetText: string;\r\n procedure SetText(const Value: string);\r\n function Editable: Boolean;\r\n function Get_Color: TColor;\r\n procedure InitID; override;\r\n property ListNumber: Integer read FListNumber;\r\n property ListIndex: Integer read FListIndex;\r\n public\r\n constructor Create(AOwner: IJvDataItems; AListNumber, AListIndex: Integer);\r\n end;\r\n\r\n TJvColorHeaderItem = class(TJvBaseDataItem, IJvDataItemText)\r\n private\r\n FListNumber: Integer; // 0 = StdColors, 1 = SysColors, 2 = CstColors\r\n protected\r\n function GetText: string;\r\n procedure SetText(const Value: string);\r\n function Editable: Boolean;\r\n procedure InitID; override;\r\n procedure InitImplementers; override;\r\n function IsDeletable: Boolean; override;\r\n property ListNumber: Integer read FListNumber;\r\n public\r\n constructor Create(AOwner: IJvDataItems; AListNumber: Integer);\r\n end;\r\n\r\n TJvColorAddItem = class(TJvBaseDataItem, IJvDataItemText)\r\n protected\r\n function GetText: string;\r\n procedure SetText(const Value: string);\r\n function Editable: Boolean;\r\n procedure InitID; override;\r\n procedure InitImplementers; override;\r\n end;\r\n\r\n TJvColorItemAddExecute = class(TJvDataItemAggregatedObject, IJvDataItemBasicAction)\r\n protected\r\n function Execute(Sender: TObject): Boolean;\r\n end;\r\n\r\n TJvColorItemsRenderer = class(TJvCustomDataItemsRenderer)\r\n protected\r\n CurrentCanvas: TCanvas;\r\n CurrentRect: TRect;\r\n CurrentItem: IJvDataItem;\r\n CurrentState: TProviderDrawStates;\r\n CurrentSettings: IJvColorProviderSettings;\r\n CurrentItemIsColorItem: Boolean;\r\n CurrentColorValue: TColor;\r\n function GetRenderText: string;\r\n procedure RenderColorBox;\r\n procedure RenderColorText;\r\n procedure RenderGroupHeader;\r\n procedure MeasureColorBox(var Size: TSize);\r\n procedure MeasureColorText(var Size: TSize);\r\n procedure DoDrawItem(ACanvas: TCanvas; var ARect: TRect; Item: IJvDataItem;\r\n State: TProviderDrawStates); override;\r\n function DoMeasureItem(ACanvas: TCanvas; Item: IJvDataItem): TSize; override;\r\n function AvgItemSize(ACanvas: TCanvas): TSize; override;\r\n function GetConsumerSettings: IJvColorProviderSettings;\r\n end;\r\n\r\n TJvDataConsumerAggregatedObjectAccessProtected = class(TJvDataConsumerAggregatedObject);\r\n TJvColorProviderSettings = class;\r\n\r\n TJvColorMappingChangeEvent = procedure(Sender: TJvColorProviderSettings; Index: Integer;\r\n Mapping: TJvColorProviderNameMapping) of object;\r\n\r\n TJvColorProviderSettings = class(TJvDataConsumerAggregatedObject, IJvColorProviderSettings)\r\n private\r\n FColorBoxSettings: TJvColorProviderColorBoxSettings;\r\n FCustomColorSettings: TJvColorProviderCustomColorGroupSettings;\r\n FGroupingSettings: TJvColorProviderGroupingSettings;\r\n FStandardColorSettings: TJvColorProviderColorGroupSettings;\r\n FSystemColorSettings: TJvColorProviderColorGroupSettings;\r\n FTextSettings: TJvColorProviderTextSettings;\r\n FMapping: Integer;\r\n FOnMappingAdding: TNotifyEvent;\r\n FOnMappingAdded: TJvColorMappingChangeEvent;\r\n FOnMappingDestroying: TJvColorMappingChangeEvent;\r\n FOnMappingDestroyed: TNotifyEvent;\r\n protected\r\n function Get_ColorBoxSettings: TJvColorProviderColorBoxSettings;\r\n function Get_CustomColorSettings: TJvColorProviderCustomColorGroupSettings;\r\n function Get_GroupingSettings: TJvColorProviderGroupingSettings;\r\n function Get_NameMapping: TJvColorProviderNameMapping;\r\n function Get_NameMappingIndex: Integer;\r\n function Get_StandardColorSettings: TJvColorProviderColorGroupSettings;\r\n function Get_SystemColorSettings: TJvColorProviderColorGroupSettings;\r\n function Get_TextSettings: TJvColorProviderTextSettings;\r\n procedure Set_ColorBoxSettings(Value: TJvColorProviderColorBoxSettings);\r\n procedure Set_CustomColorSettings(Value: TJvColorProviderCustomColorGroupSettings);\r\n procedure Set_GroupingSettings(Value: TJvColorProviderGroupingSettings);\r\n procedure Set_NameMapping(Value: TJvColorProviderNameMapping);\r\n procedure Set_NameMappingIndex(Value: Integer);\r\n procedure Set_StandardColorSettings(Value: TJvColorProviderColorGroupSettings);\r\n procedure Set_SystemColorSettings(Value: TJvColorProviderColorGroupSettings);\r\n procedure Set_TextSettings(Value: TJvColorProviderTextSettings);\r\n procedure MappingAdding;\r\n procedure MappingAdded(Index: Integer; Mapping: TJvColorProviderNameMapping);\r\n procedure MappingDestroying(Index: Integer; Mapping: TJvColorProviderNameMapping);\r\n procedure MappingDestroyed;\r\n function GetNameMappingIndex: TJvColorProviderMapping;\r\n procedure SetNameMappingIndex(Value: TJvColorProviderMapping);\r\n public\r\n constructor Create(AOwner: TExtensibleInterfacedPersistent); override;\r\n destructor Destroy; override;\r\n property OnMappingAdding: TNotifyEvent read FOnMappingAdding write FOnMappingAdding;\r\n property OnMappingAdded: TJvColorMappingChangeEvent read FOnMappingAdded write FOnMappingAdded;\r\n property OnMappingDestroying: TJvColorMappingChangeEvent read FOnMappingDestroying\r\n write FOnMappingDestroying;\r\n property OnMappingDestroyed: TNotifyEvent read FOnMappingDestroyed write FOnMappingDestroyed;\r\n published\r\n property ColorBoxSettings: TJvColorProviderColorBoxSettings read Get_ColorBoxSettings\r\n write Set_ColorBoxSettings;\r\n property CustomColorSettings: TJvColorProviderCustomColorGroupSettings\r\n read Get_CustomColorSettings write Set_CustomColorSettings;\r\n property TextSettings: TJvColorProviderTextSettings read Get_TextSettings\r\n write Set_TextSettings;\r\n property StandardColorSettings: TJvColorProviderColorGroupSettings\r\n read Get_StandardColorSettings write Set_StandardColorSettings;\r\n property SystemColorSettings: TJvColorProviderColorGroupSettings read Get_SystemColorSettings\r\n write Set_SystemColorSettings;\r\n property GroupingSettings: TJvColorProviderGroupingSettings read Get_GroupingSettings\r\n write Set_GroupingSettings;\r\n property Mapping: TJvColorProviderMapping read GetNameMappingIndex write SetNameMappingIndex\r\n default -1;\r\n end;\r\n\r\n TJvColorContextsManager = class(TJvBaseDataContextsManager)\r\n protected\r\n function New: IJvDataContext; override;\r\n end;\r\n\r\n TJvColorContext = class(TJvDataContext, IJvDataContextManager)\r\n protected\r\n function IsDeletable: Boolean; override;\r\n function IsStreamable: Boolean; override;\r\n procedure DefineProperties(Filer: TFiler); override;\r\n procedure ReadStdColors(Reader: TReader);\r\n procedure WriteStdColors(Writer: TWriter);\r\n procedure ReadSysColors(Reader: TReader);\r\n procedure WriteSysColors(Writer: TWriter);\r\n procedure ReadCstColors(Reader: TReader);\r\n procedure WriteCstColors(Writer: TWriter);\r\n procedure ReadCtxList(Reader: TReader; var List: TDynIntegerArray);\r\n procedure WriteCtxList(Writer: TWriter; const List: TDynIntegerArray);\r\n end;\r\n\r\n TJvColorMapItems = class(TJvBaseDataItems)\r\n private\r\n FConsumer: TJvDataConsumer;\r\n FItemInstances: TList;\r\n function GetClientProvider: IJvDataProvider;\r\n procedure SetClientProvider(Value: IJvDataProvider);\r\n procedure DataProviderChanging(ADataProvider: IJvDataProvider;\r\n AReason: TDataProviderChangeReason; Source: IUnknown);\r\n procedure DataProviderChanged(ADataProvider: IJvDataProvider;\r\n AReason: TDataProviderChangeReason; Source: IUnknown);\r\n procedure SubServiceCreated(Sender: TJvDataConsumer; SubSvc: TJvDataConsumerAggregatedObject);\r\n procedure ConsumerChanged(Sender: TJvDataConsumer; Reason: TJvDataConsumerChangeReason);\r\n procedure MappingAdding(Sender: TObject);\r\n procedure MappingAdded(Sender: TJvColorProviderSettings; Index: Integer;\r\n Mapping: TJvColorProviderNameMapping);\r\n procedure MappingDestroying(Sender: TJvColorProviderSettings; Index: Integer;\r\n Mapping: TJvColorProviderNameMapping);\r\n procedure MappingDestroyed(Sender: TObject);\r\n protected\r\n function GetCount: Integer; override;\r\n function GetItem(I: Integer): IJvDataItem; override;\r\n procedure InitImplementers; override;\r\n\r\n property Consumer: TJvDataConsumer read FConsumer;\r\n public\r\n constructor Create; override;\r\n destructor Destroy; override;\r\n procedure AfterConstruction; override;\r\n\r\n property ClientProvider: IJvDataProvider read GetClientProvider write SetClientProvider;\r\n end;\r\n\r\n TJvColorMapItem = class(TJvBaseDataItem, IJvDataItemText, IJvColorMapItem)\r\n private\r\n FIndex: Integer;\r\n protected\r\n function GetText: string;\r\n procedure SetText(const Value: string);\r\n function Editable: Boolean;\r\n function Get_NameMapping: TJvColorProviderNameMapping;\r\n procedure InitID; override;\r\n property Index: Integer read FIndex;\r\n public\r\n constructor Create(AOwner: IJvDataItems; AIndex: Integer);\r\n destructor Destroy; override;\r\n end;\r\n\r\n TJvColorMapItemsManager = class(TJvBaseDataItemsManagement)\r\n protected\r\n { IJvDataItemManagement methods }\r\n function Add(Item: IJvDataItem): IJvDataItem; override;\r\n function New: IJvDataItem; override;\r\n procedure Clear; override;\r\n procedure Delete(Index: Integer); override;\r\n procedure Remove(var Item: IJvDataItem); override;\r\n end;\r\n\r\n TJvColorConsumer = class(TInterfacedObject, IJvDataConsumer)\r\n protected\r\n { IJvDataConsumer methods }\r\n function VCLComponent: TComponent;\r\n function AttributeApplies(Attr: Integer): Boolean;\r\n end;\r\n\r\n//=== { TJvColorProviderNameMapping } ========================================\r\n\r\nconstructor TJvColorProviderNameMapping.Create(AOwner: TJvColorProviderNameMappings; AName: string);\r\nbegin\r\n inherited Create;\r\n FOwner := AOwner;\r\n FName := AName;\r\nend;\r\n\r\n//=== { TJvColorProviderSubSettings } ========================================\r\n\r\nconstructor TJvColorProviderSubSettings.Create(AConsumerService: TJvDataConsumerAggregatedObject);\r\nbegin\r\n inherited Create;\r\n FConsumerServiceExt := AConsumerService;\r\nend;\r\n\r\nprocedure TJvColorProviderSubSettings.Changed;\r\nbegin\r\n TJvDataConsumerAggregatedObjectAccessProtected(ConsumerServiceExt).Changed(ccrOther);\r\nend;\r\n\r\nprocedure TJvColorProviderSubSettings.ViewChanged;\r\nbegin\r\n TJvDataConsumerAggregatedObjectAccessProtected(ConsumerServiceExt).NotifyViewChanged;\r\nend;\r\n\r\nprocedure TJvColorProviderSubSettings.SetActive(Value: Boolean);\r\nbegin\r\n if Value <> Active then\r\n begin\r\n FActive := Value;\r\n Changed;\r\n end;\r\nend;\r\n\r\n//=== { TJvColorProviderColorBoxSettings } ===================================\r\n\r\nconstructor TJvColorProviderColorBoxSettings.Create(AConsumerService: TJvDataConsumerAggregatedObject);\r\nbegin\r\n inherited Create(AConsumerService);\r\n FActive := True;\r\n FHeight := 13;\r\n FMargin := 2;\r\n FShadowed := True;\r\n FShadowSize := 2;\r\n FSpacing := 4;\r\n FWidth := 21;\r\nend;\r\n\r\nprocedure TJvColorProviderColorBoxSettings.SetHeight(Value: Integer);\r\nbegin\r\n if Value <> Height then\r\n begin\r\n FHeight := Value;\r\n Changed;\r\n end;\r\nend;\r\n\r\nprocedure TJvColorProviderColorBoxSettings.SetMargin(Value: Integer);\r\nbegin\r\n if Value <> Margin then\r\n begin\r\n FMargin := Value;\r\n Changed;\r\n end;\r\nend;\r\n\r\nprocedure TJvColorProviderColorBoxSettings.SetShadowed(Value: Boolean);\r\nbegin\r\n if Value <> Shadowed then\r\n begin\r\n FShadowed := Value;\r\n Changed;\r\n end;\r\nend;\r\n\r\nprocedure TJvColorProviderColorBoxSettings.SetShadowSize(Value: Integer);\r\nbegin\r\n if Value <> ShadowSize then\r\n begin\r\n FShadowSize := Value;\r\n Changed;\r\n end;\r\nend;\r\n\r\nprocedure TJvColorProviderColorBoxSettings.SetSpacing(Value: Integer);\r\nbegin\r\n if Value <> Spacing then\r\n begin\r\n FSpacing := Value;\r\n Changed;\r\n end;\r\nend;\r\n\r\nprocedure TJvColorProviderColorBoxSettings.SetWidth(Value: Integer);\r\nbegin\r\n if Value <> Width then\r\n begin\r\n FWidth := Value;\r\n Changed;\r\n end;\r\nend;\r\n\r\n//=== { TJvColorProviderTextSettings } =======================================\r\n\r\nconstructor TJvColorProviderTextSettings.Create(AConsumerService: TJvDataConsumerAggregatedObject);\r\nbegin\r\n inherited Create(AConsumerService);\r\n FActive := True;\r\n FShowName := True;\r\nend;\r\n\r\nprocedure TJvColorProviderTextSettings.SetShowHex(Value: Boolean);\r\nbegin\r\n if Value <> ShowHex then\r\n begin\r\n FShowHex := Value;\r\n Changed;\r\n end;\r\nend;\r\n\r\nprocedure TJvColorProviderTextSettings.SetShowName(Value: Boolean);\r\nbegin\r\n if Value <> ShowName then\r\n begin\r\n FShowName := Value;\r\n Changed;\r\n end;\r\nend;\r\n\r\nprocedure TJvColorProviderTextSettings.SetShowRGB(Value: Boolean);\r\nbegin\r\n if Value <> ShowRGB then\r\n begin\r\n FShowRGB := Value;\r\n Changed;\r\n end;\r\nend;\r\n\r\n//=== { TJvColorProviderGroupingSettings } ===================================\r\n\r\nconstructor TJvColorProviderGroupingSettings.Create(AConsumerService: TJvDataConsumerAggregatedObject);\r\nbegin\r\n inherited Create(AConsumerService);\r\n FActive := True;\r\n FFlatList := True;\r\n FHeaderAlign := ghaLeft;\r\n FHeaderStyle := [ghsBoldFont, ghsSingleCenterLine];\r\nend;\r\n\r\nprocedure TJvColorProviderGroupingSettings.SetActive(Value: Boolean);\r\nbegin\r\n if Value <> Active then\r\n begin\r\n FActiveChanging := True;\r\n inherited SetActive(Value);\r\n FActiveChanging := False;\r\n end;\r\nend;\r\n\r\nprocedure TJvColorProviderGroupingSettings.Changed;\r\nbegin\r\n if FActiveChanging then\r\n ViewChanged;\r\n inherited Changed;\r\nend;\r\n\r\nprocedure TJvColorProviderGroupingSettings.SetFlatList(Value: Boolean);\r\nbegin\r\n if Value <> FlatList then\r\n begin\r\n FFlatList := Value;\r\n ViewChanged;\r\n Changed;\r\n end;\r\nend;\r\n\r\nprocedure TJvColorProviderGroupingSettings.SetHeaderAlign(Value: TColorGroupHeaderAlign);\r\nbegin\r\n if Value <> HeaderAlign then\r\n begin\r\n FHeaderAlign := Value;\r\n Changed;\r\n end;\r\nend;\r\n\r\nprocedure TJvColorProviderGroupingSettings.SetHeaderStyle(Value: TColorGroupHeaderStyles);\r\nbegin\r\n if (ghsSingleCenterLine in Value) and not (ghsSingleCenterLine in HeaderStyle) then\r\n Exclude(Value, ghsDoubleCenterLine)\r\n else\r\n if (ghsDoubleCenterLine in Value) and not (ghsDoubleCenterLine in HeaderStyle) then\r\n Exclude(Value, ghsSingleCenterLine);\r\n if Value <> HeaderStyle then\r\n begin\r\n FHeaderStyle := Value;\r\n Changed;\r\n end;\r\nend;\r\n\r\n//=== { TJvColorProviderColorGroupSettings } =================================\r\n\r\nconstructor TJvColorProviderColorGroupSettings.Create(AConsumerService: TJvDataConsumerAggregatedObject;\r\n ACaption: string);\r\nbegin\r\n inherited Create(AConsumerService);\r\n FActive := True;\r\n FCaption := ACaption;\r\nend;\r\n\r\nprocedure TJvColorProviderColorGroupSettings.SetActive(Value: Boolean);\r\nbegin\r\n if Value <> Active then\r\n begin\r\n FActiveChanging := True;\r\n inherited SetActive(Value);\r\n FActiveChanging := False;\r\n end;\r\nend;\r\n\r\nprocedure TJvColorProviderColorGroupSettings.Changed;\r\nbegin\r\n if FActiveChanging then\r\n ViewChanged;\r\n inherited Changed;\r\nend;\r\n\r\nprocedure TJvColorProviderColorGroupSettings.SetCaption(Value: string);\r\nbegin\r\n if Value <> Caption then\r\n begin\r\n FCaption := Value;\r\n Changed;\r\n end;\r\nend;\r\n\r\nprocedure TJvColorProviderColorGroupSettings.SetShowHeader(Value: Boolean);\r\nbegin\r\n if Value <> ShowHeader then\r\n begin\r\n FShowHeader := Value;\r\n Changed;\r\n ViewChanged;\r\n end;\r\nend;\r\n\r\n//=== { TJvColorProviderAddColorSettings } ===================================\r\n\r\nconstructor TJvColorProviderAddColorSettings.Create(AConsumerService: TJvDataConsumerAggregatedObject);\r\nbegin\r\n inherited Create(AConsumerService);\r\n FLocation := ailBottom;\r\n FStyle := ColorProviderColorAdderRegister.DefaultAdder;\r\n ColorProviderColorAdderRegister.RegisterNotify(Self);\r\nend;\r\n\r\ndestructor TJvColorProviderAddColorSettings.Destroy;\r\nbegin\r\n ColorProviderColorAdderRegister.UnregisterNotify(Self);\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvColorProviderAddColorSettings.SetLocation(Value: TJvColorProviderAddItemLocation);\r\nbegin\r\n if Value <> Location then\r\n begin\r\n FLocation := Value;\r\n Changed;\r\n ViewChanged;\r\n end;\r\nend;\r\n\r\nprocedure TJvColorProviderAddColorSettings.SetCaption(Value: string);\r\nbegin\r\n if Value <> Caption then\r\n begin\r\n FCaption := Value;\r\n Changed;\r\n end;\r\nend;\r\n\r\nfunction TJvColorProviderAddColorSettings.GetStyle: TJvColorProviderAddColorStyle;\r\nbegin\r\n Result := FStyle;\r\nend;\r\n\r\nprocedure TJvColorProviderAddColorSettings.SetStyle(Value: TJvColorProviderAddColorStyle);\r\nbegin\r\n if Value <> Style then\r\n begin\r\n FStyle := Value;\r\n Changed;\r\n end;\r\nend;\r\n\r\n//=== { TJvColorProviderCustomColorGroupSettings } ===========================\r\n\r\nconstructor TJvColorProviderCustomColorGroupSettings.Create(AConsumerService: TJvDataConsumerAggregatedObject;\r\n ACaption: string);\r\nbegin\r\n inherited Create(AConsumerService, ACaption);\r\n FAddColorSettings := TJvColorProviderAddColorSettings.Create(AConsumerService);\r\nend;\r\n\r\ndestructor TJvColorProviderCustomColorGroupSettings.Destroy;\r\nbegin\r\n FreeAndNil(FAddColorSettings);\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvColorProviderCustomColorGroupSettings.SetAddColorSettings(\r\n Value: TJvColorProviderAddColorSettings);\r\nbegin\r\nend;\r\n\r\n//=== { TJvColorMappingProvider } ============================================\r\n\r\nfunction TJvColorMappingProvider.GetColorProviderIntf: IJvColorProvider;\r\nbegin\r\n Result := TJvColorMapItems(DataItemsImpl).ClientProvider as IJvColorProvider;\r\nend;\r\n\r\nprocedure TJvColorMappingProvider.SetColorProviderIntf(Value: IJvColorProvider);\r\nbegin\r\n TJvColorMapItems(DataItemsImpl).ClientProvider := (Value as IJvDataProvider);\r\nend;\r\n\r\nclass function TJvColorMappingProvider.ItemsClass: TJvDataItemsClass;\r\nbegin\r\n Result := TJvColorMapItems;\r\nend;\r\n\r\nfunction TJvColorMappingProvider.ConsumerClasses: TClassArray;\r\nbegin\r\n Result := inherited ConsumerClasses;\r\n AddToArray(Result, TJvColorProviderServerNotify);\r\nend;\r\n\r\n//=== { TJvColorProviderServerNotify } =======================================\r\n\r\nprocedure TJvColorProviderServerNotify.ItemSelected(Value: IJvDataItem);\r\nvar\r\n MapItem: IJvColorMapItem;\r\n Mapping: TJvColorProviderNameMapping;\r\n I: Integer;\r\n ConSet: IJvColorProviderSettings;\r\nbegin\r\n inherited ItemSelected(Value);\r\n if Supports(Value, IJvColorMapItem, MapItem) then\r\n begin\r\n Mapping := MapItem.NameMapping;\r\n for I := 0 to Clients.Count - 1 do\r\n if Supports(Clients[I], IJvColorProviderSettings, ConSet) then\r\n ConSet.NameMapping := Mapping;\r\n end;\r\nend;\r\n\r\nfunction TJvColorProviderServerNotify.IsValidClient(Client: IJvDataConsumerClientNotify): Boolean;\r\nvar\r\n ClientProv: IJvDataProvider;\r\n ConsumerProv: IJvDataConsumerProvider;\r\nbegin\r\n { Only allow client consumers who's Provider points to the ColorProvider of the mapping\r\n provider this consumer is linked to. }\r\n ClientProv := (ConsumerImpl.ProviderIntf as IJvColorMappingProvider).ClientProvider as\r\n IJvDataProvider;\r\n Result := Supports(Client, IJvDataConsumerProvider, ConsumerProv) and\r\n (ConsumerProv.GetProvider = ClientProv);\r\nend;\r\n\r\n//=== { TJvColorProviderColorAdderRegister } =================================\r\n\r\nconstructor TJvColorProviderColorAdderRegister.Create;\r\nbegin\r\n inherited Create;\r\n FList := TStringList.Create;\r\n FNotifiers := TList.Create;\r\nend;\r\n\r\ndestructor TJvColorProviderColorAdderRegister.Destroy;\r\nbegin\r\n FreeAndNil(FNotifiers);\r\n FreeAndNil(FList);\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvColorProviderColorAdderRegister.RegisterNotify(Value: TJvColorProviderAddColorSettings);\r\nbegin\r\n if FNotifiers.IndexOf(Value) = -1 then\r\n FNotifiers.Add(Value);\r\nend;\r\n\r\nprocedure TJvColorProviderColorAdderRegister.UnregisterNotify(Value: TJvColorProviderAddColorSettings);\r\nbegin\r\n FNotifiers.Remove(Value);\r\nend;\r\n\r\nfunction TJvColorProviderColorAdderRegister.Add(Name: string;\r\n Callback: TJvColorProviderColorAdder): Integer;\r\nbegin\r\n Result := IndexOf(Name);\r\n if Result = -1 then\r\n Result := FList.AddObject(Name, TObject(@Callback))\r\n else\r\n if @Callbacks(Result) <> @Callback then\r\n raise EJVCLException.CreateResFmt(@RsEAlreadyRegistered, [Name]);\r\nend;\r\n\r\nprocedure TJvColorProviderColorAdderRegister.Delete(Callback: TJvColorProviderColorAdder);\r\nvar\r\n Idx: Integer;\r\nbegin\r\n Idx := IndexOf(Callback);\r\n if Idx > -1 then\r\n Delete(Idx);\r\nend;\r\n\r\nprocedure TJvColorProviderColorAdderRegister.Delete(Index: Integer);\r\nvar\r\n I: Integer;\r\nbegin\r\n FList.Delete(Index);\r\n if Index < DefaultAdder then\r\n Dec(FDefaultAdder)\r\n else\r\n if Index = DefaultAdder then\r\n begin\r\n if Count > 0 then\r\n FDefaultAdder := 0\r\n else\r\n FDefaultAdder := -1;\r\n end;\r\n for I := 0 to FNotifiers.Count -1 do\r\n with TJvColorProviderAddColorSettings(FNotifiers[I]) do\r\n if Style > Index then\r\n Dec(FStyle)\r\n else\r\n if Style = Index then\r\n FStyle := DefaultAdder;\r\nend;\r\n\r\nprocedure TJvColorProviderColorAdderRegister.Delete(Name: string);\r\nvar\r\n Idx: Integer;\r\nbegin\r\n Idx := IndexOf(Name);\r\n if Idx > -1 then\r\n Delete(Idx);\r\nend;\r\n\r\nprocedure TJvColorProviderColorAdderRegister.Clear;\r\nvar\r\n I: Integer;\r\nbegin\r\n while FList.Count > FMinimumKeep do\r\n FList.Delete(FList.Count);\r\n DefaultAdder := FDefaultAfterClear;\r\n for I := 0 to FNotifiers.Count - 1 do\r\n with TJvColorProviderAddColorSettings(FNotifiers[I]) do\r\n if Style >= FMinimumKeep then\r\n FStyle := DefaultAdder;\r\nend;\r\n\r\nfunction TJvColorProviderColorAdderRegister.IndexOf(Name: string): Integer;\r\nbegin\r\n Result := FList.IndexOf(Name);\r\nend;\r\n\r\nfunction TJvColorProviderColorAdderRegister.IndexOf(Callback: TJvColorProviderColorAdder): Integer;\r\nbegin\r\n Result := FList.IndexOfObject(TObject(@Callback));\r\nend;\r\n\r\nfunction TJvColorProviderColorAdderRegister.Count: Integer;\r\nbegin\r\n Result := FList.Count;\r\nend;\r\n\r\nfunction TJvColorProviderColorAdderRegister.Names(Index: Integer): string;\r\nbegin\r\n Result := FList[Index];\r\nend;\r\n\r\nfunction TJvColorProviderColorAdderRegister.Callbacks(Index: Integer): TJvColorProviderColorAdder;\r\nbegin\r\n Result := TJvColorProviderColorAdder(FList.Objects[Index]);\r\nend;\r\n\r\n//=== { TJvColorItems } ======================================================\r\n\r\nfunction TJvColorItems.GetColorSettings: IJvColorProviderSettings;\r\nbegin\r\n if GetProvider = nil then\r\n Result := nil\r\n else\r\n Supports(GetProvider.SelectedConsumer, IJvColorProviderSettings, Result);\r\nend;\r\n\r\nfunction TJvColorItems.GetCount: Integer;\r\nvar\r\n Settings: IJvColorProviderSettings;\r\nbegin\r\n Settings := GetColorSettings;\r\n Result := 0;\r\n if Settings = nil then\r\n Exit;\r\n if Settings.GroupingSettings.Active and not Settings.GroupingSettings.FlatList then\r\n begin\r\n Inc(Result, Ord(Settings.StandardColorSettings.Active) +\r\n Ord(Settings.SystemColorSettings.Active) + Ord(Settings.CustomColorSettings.Active));\r\n end\r\n else\r\n begin\r\n if Settings.StandardColorSettings.Active then\r\n Inc(Result, ColorProvider.GetStandardCount +\r\n Ord(Settings.StandardColorSettings.ShowHeader and Settings.GroupingSettings.Active));\r\n if Settings.SystemColorSettings.Active then\r\n Inc(Result, ColorProvider.GetSystemCount +\r\n Ord(Settings.SystemColorSettings.ShowHeader and Settings.GroupingSettings.Active));\r\n if Settings.CustomColorSettings.Active then\r\n Inc(Result, ColorProvider.GetCustomCount +\r\n Ord(Settings.CustomColorSettings.ShowHeader and Settings.GroupingSettings.Active) +\r\n Ord(Settings.CustomColorSettings.AddColorSettings.Active and\r\n (Settings.CustomColorSettings.ShowHeader and Settings.GroupingSettings.Active or\r\n (Settings.CustomColorSettings.AddColorSettings.Location <> ailUseHeader))));\r\n end;\r\nend;\r\n\r\nfunction TJvColorItems.GetItem(I: Integer): IJvDataItem;\r\nvar\r\n OrgIdx: Integer;\r\n Settings: IJvColorProviderSettings;\r\n ListNum: Integer;\r\nbegin\r\n if I < 0 then\r\n TList.Error(SListIndexError, I);\r\n OrgIdx := I;\r\n Settings := GetColorSettings;\r\n if Settings = nil then\r\n Exit;\r\n ListNum := -1;\r\n if Settings.GroupingSettings.Active and not Settings.GroupingSettings.FlatList then\r\n begin\r\n if Settings.StandardColorSettings.Active then\r\n Dec(I);\r\n if I < 0 then\r\n ListNum := 0;\r\n if (ListNum < 0) and Settings.SystemColorSettings.Active then\r\n begin\r\n Dec(I);\r\n if I < 0 then\r\n ListNum := 1;\r\n end;\r\n if (ListNum < 0) and Settings.CustomColorSettings.Active then\r\n begin\r\n Dec(I);\r\n if I < 0 then\r\n ListNum := 2;\r\n end;\r\n end\r\n else\r\n begin\r\n if Settings.StandardColorSettings.Active then\r\n begin\r\n if Settings.StandardColorSettings.ShowHeader and Settings.GroupingSettings.Active then\r\n Dec(I);\r\n if I < ColorProvider.GetStandardCount then\r\n ListNum := 0\r\n else\r\n Dec(I, ColorProvider.GetStandardCount);\r\n end;\r\n if (ListNum < 0) and Settings.SystemColorSettings.Active then\r\n begin\r\n if Settings.SystemColorSettings.ShowHeader and Settings.GroupingSettings.Active then\r\n Dec(I);\r\n if I < ColorProvider.GetSystemCount then\r\n ListNum := 1\r\n else\r\n Dec(I, ColorProvider.GetSystemCount);\r\n end;\r\n if (ListNum < 0) and Settings.CustomColorSettings.Active then\r\n begin\r\n if Settings.CustomColorSettings.ShowHeader and Settings.GroupingSettings.Active then\r\n Dec(I);\r\n with Settings.CustomColorSettings.AddColorSettings do\r\n if Active and (Location = ailTop) and (I = 0) then\r\n I := -2;\r\n if I < ColorProvider.GetCustomCount then\r\n ListNum := 2\r\n else\r\n begin\r\n Dec(I, ColorProvider.GetCustomCount);\r\n with Settings.CustomColorSettings.AddColorSettings do\r\n if (I = 0) and Active and ((Location = ailBottom) or ((Location = ailUseHeader) and\r\n not (Settings.CustomColorSettings.ShowHeader and Settings.GroupingSettings.Active))) then\r\n begin\r\n ListNum := 2;\r\n I := -2;\r\n end;\r\n end;\r\n end;\r\n end;\r\n if ListNum < 0 then\r\n TList.Error(SListIndexError, OrgIdx);\r\n if I = -1 then\r\n Result := TJvColorHeaderItem.Create(Self, ListNum)\r\n else\r\n if I = -2 then\r\n Result := TJvColorAddItem.Create(Self)\r\n else\r\n if I >= 0 then\r\n Result := TJvColorItem.Create(Self, ListNum, I);\r\nend;\r\n\r\nprocedure TJvColorItems.InitImplementers;\r\nbegin\r\n inherited InitImplementers;\r\n if GetParent = nil then\r\n TJvColorItemsRenderer.Create(Self);\r\nend;\r\n\r\nprocedure TJvColorItems.InternalAdd(Item: IJvDataItem);\r\nbegin\r\n // do nothing; this method is never called anyway\r\nend;\r\n\r\nprocedure TJvColorItems.InternalDelete(Index: Integer);\r\nbegin\r\n // do nothing; this method is never called anyway\r\nend;\r\n\r\nprocedure TJvColorItems.InternalMove(OldIndex, NewIndex: Integer);\r\nbegin\r\n // do nothing; this method is never called anyway\r\nend;\r\n\r\nprocedure TJvColorItems.AfterConstruction;\r\nbegin\r\n inherited AfterConstruction;\r\n Supports(GetProvider, IJvColorProvider, FColorProvider);\r\nend;\r\n\r\n//=== { TJvColorItemsList } ==================================================\r\n\r\nfunction TJvColorItemsList.GetCount: Integer;\r\nbegin\r\n case ListNum of\r\n 0:\r\n Result := ColorProvider.GetStandardCount;\r\n 1:\r\n Result := ColorProvider.GetSystemCount;\r\n 2:\r\n Result := ColorProvider.GetCustomCount;\r\n else\r\n Result := 0;\r\n end;\r\nend;\r\n\r\nfunction TJvColorItemsList.GetItem(I: Integer): IJvDataItem;\r\nbegin\r\n if I < 0 then\r\n TList.Error(SListIndexError, I);\r\n case ListNum of\r\n 0:\r\n begin\r\n if I >= ColorProvider.GetStandardCount then\r\n TList.Error(SListIndexError, I)\r\n else\r\n Result := TJvColorItem.Create(Self, 0, I);\r\n end;\r\n 1:\r\n begin\r\n if I >= ColorProvider.GetSystemCount then\r\n TList.Error(SListIndexError, I)\r\n else\r\n Result := TJvColorItem.Create(Self, 1, I);\r\n end;\r\n 2:\r\n begin\r\n if I >= ColorProvider.GetCustomCount then\r\n TList.Error(SListIndexError, I)\r\n else\r\n Result := TJvColorItem.Create(Self, 2, I);\r\n end;\r\n else\r\n TList.Error(SListIndexError, I);\r\n end;\r\nend;\r\n\r\nprocedure TJvColorItemsList.AfterConstruction;\r\nbegin\r\n inherited AfterConstruction;\r\n ListNum := TJvColorHeaderItem(GetParent.GetImplementer).ListNumber;\r\nend;\r\n\r\n//=== { TJvColorItem } =======================================================\r\n\r\nconstructor TJvColorItem.Create(AOwner: IJvDataItems; AListNumber, AListIndex: Integer);\r\nbegin\r\n inherited Create(AOwner);\r\n FListNumber := AListNumber;\r\n FListIndex := AListIndex;\r\nend;\r\n\r\nfunction TJvColorItem.GetText: string;\r\nvar\r\n ColorFound: Boolean;\r\n ColorValue: TColor;\r\nbegin\r\n case ListNumber of\r\n 0:\r\n ColorFound := (GetItems.GetProvider as IJvColorProvider).GetStandardColor(ListIndex, ColorValue, Result);\r\n 1:\r\n ColorFound := (GetItems.GetProvider as IJvColorProvider).GetSystemColor(ListIndex, ColorValue, Result);\r\n 2:\r\n ColorFound := (GetItems.GetProvider as IJvColorProvider).GetCustomColor(ListIndex, ColorValue, Result);\r\n else\r\n begin\r\n ColorFound := False;\r\n Result := '';\r\n end;\r\n end;\r\n if (Result = '') and ColorFound then\r\n ColorToIdent(ColorValue, Result);\r\nend;\r\n\r\nprocedure TJvColorItem.SetText(const Value: string);\r\nbegin\r\n case ListNumber of\r\n 0:\r\n (GetItems.GetProvider as IJvColorProvider).SetStandardColorName(ListIndex, Value);\r\n 1:\r\n (GetItems.GetProvider as IJvColorProvider).SetSystemColorName(ListIndex, Value);\r\n 2:\r\n (GetItems.GetProvider as IJvColorProvider).SetCustomColorName(ListIndex, Value);\r\n end;\r\nend;\r\n\r\nfunction TJvColorItem.Editable: Boolean;\r\nbegin\r\n Result := True;\r\nend;\r\n\r\nfunction TJvColorItem.Get_Color: TColor;\r\nbegin\r\n if not GetItemColorValue(Self, Result) then\r\n Result := ColorProvider_NotAColor;\r\nend;\r\n\r\nprocedure TJvColorItem.InitID;\r\nvar\r\n ColorFound: Boolean;\r\n ColorValue: TColor;\r\n ColorName: string;\r\nbegin\r\n case ListNumber of\r\n 0:\r\n ColorFound := (GetItems.GetProvider as IJvColorProvider).GetStandardColor(ListIndex, ColorValue, ColorName);\r\n 1:\r\n ColorFound := (GetItems.GetProvider as IJvColorProvider).GetSystemColor(ListIndex, ColorValue, ColorName);\r\n 2:\r\n ColorFound := (GetItems.GetProvider as IJvColorProvider).GetCustomColor(ListIndex, ColorValue, ColorName);\r\n else\r\n begin\r\n ColorFound := False;\r\n ColorValue := -1;\r\n end;\r\n end;\r\n if ColorFound then\r\n begin\r\n {$IFDEF COMPILER7_UP}\r\n if (ColorValue and clSystemColor) = clSystemColor then\r\n ColorValue := ColorValue and $80FFFFFF;\r\n {$ENDIF COMPILER7_UP}\r\n SetID(cColorItemIDPrefix + IntToHex(ColorValue, 8));\r\n end\r\n else\r\n SetID('Item' + IntToStr(ListNumber) + '.' + IntToStr(ListIndex));\r\nend;\r\n\r\n//=== { TJvColorHeaderItem } =================================================\r\n\r\nconstructor TJvColorHeaderItem.Create(AOwner: IJvDataItems; AListNumber: Integer);\r\nbegin\r\n inherited Create(AOwner);\r\n FListNumber := AListNumber;\r\nend;\r\n\r\nfunction TJvColorHeaderItem.GetText: string;\r\nvar\r\n Settings: IJvColorProviderSettings;\r\nbegin\r\n Supports(GetItems.GetProvider.SelectedConsumer, IJvColorProviderSettings, Settings);\r\n if Settings = nil then\r\n Result := RsNoSettings\r\n else\r\n case ListNumber of\r\n 0:\r\n Result := Settings.StandardColorSettings.Caption;\r\n 1:\r\n Result := Settings.SystemColorSettings.Caption;\r\n 2:\r\n Result := Settings.CustomColorSettings.Caption;\r\n end;\r\nend;\r\n\r\nfunction TJvColorHeaderItem.Editable: Boolean;\r\nbegin\r\n Result := False;\r\nend;\r\n\r\nprocedure TJvColorHeaderItem.SetText(const Value: string);\r\nbegin\r\nend;\r\n\r\nprocedure TJvColorHeaderItem.InitID;\r\nbegin\r\n SetID(cColorProviderGroupHeaderID + IntToStr(ListNumber));\r\nend;\r\n\r\nprocedure TJvColorHeaderItem.InitImplementers;\r\nvar\r\n Settings: IJvColorProviderSettings;\r\nbegin\r\n inherited InitImplementers;\r\n if GetItems.GetProvider.SelectedConsumer = MasterColorConsumer then\r\n TJvColorItemsList.Create(Self)\r\n else\r\n if Supports(GetItems.GetProvider.SelectedConsumer, IJvColorProviderSettings, Settings) then\r\n begin\r\n if not Settings.GroupingSettings.FlatList then\r\n TJvColorItemsList.Create(Self);\r\n if (FListNumber = 2) and Settings.CustomColorSettings.AddColorSettings.Active and\r\n (Settings.CustomColorSettings.AddColorSettings.Location = ailUseHeader) then\r\n TJvColorItemAddExecute.Create(Self);\r\n end;\r\nend;\r\n\r\nfunction TJvColorHeaderItem.IsDeletable: Boolean;\r\nbegin\r\n Result := False;\r\nend;\r\n\r\n//=== { TJvColorAddItem } ====================================================\r\n\r\nfunction TJvColorAddItem.GetText: string;\r\nvar\r\n Settings: IJvColorProviderSettings;\r\nbegin\r\n Supports(GetItems.GetProvider.SelectedConsumer, IJvColorProviderSettings, Settings);\r\n if Settings = nil then\r\n Result := RsNoSettings\r\n else\r\n Result := Settings.CustomColorSettings.AddColorSettings.Caption;\r\nend;\r\n\r\nprocedure TJvColorAddItem.SetText(const Value: string);\r\nbegin\r\nend;\r\n\r\nfunction TJvColorAddItem.Editable: Boolean;\r\nbegin\r\n Result := False;\r\nend;\r\n\r\nprocedure TJvColorAddItem.InitID;\r\nbegin\r\n SetID(cColorProviderAddItemID);\r\nend;\r\n\r\nprocedure TJvColorAddItem.InitImplementers;\r\nbegin\r\n inherited InitImplementers;\r\n TJvColorItemAddExecute.Create(Self);\r\nend;\r\n\r\n//=== { TJvColorItemAddExecute } =============================================\r\n\r\nfunction TJvColorItemAddExecute.Execute(Sender: TObject): Boolean;\r\nvar\r\n ColorSettings: IJvColorProviderSettings;\r\n StyleIdx: Integer;\r\n Color: TColor;\r\n DoAdd: Boolean;\r\n Callback: TJvColorProviderColorAdder;\r\nbegin\r\n Result := Supports(Item.Items.Provider.SelectedConsumer, IJvColorProviderSettings, ColorSettings);\r\n if Result then\r\n begin\r\n StyleIdx := ColorSettings.CustomColorSettings.AddColorSettings.Style;\r\n Color := ColorProvider_NotAColor;\r\n DoAdd := False;\r\n Callback := ColorProviderColorAdderRegister.Callbacks(StyleIdx);\r\n if Assigned(Callback) then\r\n Callback(Item.Items.Provider as IJvColorProvider, ctCustom, Color, DoAdd);\r\n if DoAdd then\r\n (Item.Items.Provider as IJvColorProvider).AddColor(ctCustom, Color);\r\n end;\r\nend;\r\n\r\n//=== { TJvColorProvider } ===================================================\r\n\r\nconstructor TJvColorProvider.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FMappings := TJvColorProviderNameMappings.Create(Self);\r\n GenDelphiConstantMapping;\r\n GenEnglishMapping;\r\n (DataContextsImpl as IJvDataContextsManager).Add(TJvColorContext.Create(DataContextsImpl, 'Default'));\r\n InitColors;\r\n FColorListChanged := False;\r\nend;\r\n\r\ndestructor TJvColorProvider.Destroy;\r\nbegin\r\n FreeAndNil(FMappings);\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvColorProvider.NotifyChanging(Reason: TDataProviderChangeReason; ContextIndex: Integer;\r\n GroupedItem, RootItem: IUnknown);\r\nvar\r\n I: Integer;\r\n Consumer: IJvDataConsumer;\r\n ConCtx: IJvDataConsumerContext;\r\n Settings: IJvColorProviderSettings;\r\n CtxIdx: Integer;\r\nbegin\r\n if ContextIndex = -1 then\r\n ContextIndex := SelectedContextIndex;\r\n SelectContext((DataContextsImpl as IJvDataContexts).GetContext(ContextIndex));\r\n try\r\n for I := 0 to GetNotifierCount - 1 do\r\n begin\r\n if Supports(GetNotifier(I), IJvDataConsumer, Consumer) and\r\n Supports(Consumer, IJvDataConsumerContext, ConCtx) and\r\n Supports(Consumer, IJvColorProviderSettings, Settings) then\r\n begin\r\n CtxIdx := ConCtx.GetContext.Contexts.IndexOf(ConCtx.GetContext);\r\n if (CtxIdx = ContextIndex) or ((CtxIdx = -1) and (ContextIndex = 0)) then\r\n begin\r\n if Settings.GroupingSettings.Active and not Settings.GroupingSettings.FlatList then\r\n GetNotifier(I).DataProviderChanging(Self, Reason, GroupedItem)\r\n else\r\n GetNotifier(I).DataProviderChanging(Self, Reason, RootItem);\r\n end;\r\n end\r\n else\r\n { No consumer, contextless consumer or no color settings. Hand over the grouped item as it\r\n is more specific. }\r\n GetNotifier(I).DataProviderChanging(Self, pcrAdd, GroupedItem);\r\n end;\r\n finally\r\n ReleaseContext;\r\n end;\r\nend;\r\n\r\nprocedure TJvColorProvider.NotifyChanged(Reason: TDataProviderChangeReason; ContextIndex: Integer;\r\n GroupedItem, RootItem: IUnknown);\r\nvar\r\n I: Integer;\r\n Consumer: IJvDataConsumer;\r\n ConCtx: IJvDataConsumerContext;\r\n Settings: IJvColorProviderSettings;\r\n CtxIdx: Integer;\r\nbegin\r\n if ContextIndex = -1 then\r\n ContextIndex := SelectedContextIndex;\r\n SelectConsumer(MasterColorConsumer);\r\n try\r\n SelectContext((DataContextsImpl as IJvDataContexts).GetContext(ContextIndex));\r\n try\r\n for I := 0 to GetNotifierCount - 1 do\r\n begin\r\n if Supports(GetNotifier(I), IJvDataConsumer, Consumer) and\r\n Supports(Consumer, IJvDataConsumerContext, ConCtx) and\r\n Supports(Consumer, IJvColorProviderSettings, Settings) then\r\n begin\r\n CtxIdx := ConCtx.GetContext.Contexts.IndexOf(ConCtx.GetContext);\r\n if (CtxIdx = ContextIndex) or ((CtxIdx = -1) and (ContextIndex = 0)) then\r\n begin\r\n if Settings.GroupingSettings.Active and not Settings.GroupingSettings.FlatList then\r\n GetNotifier(I).DataProviderChanged(Self, Reason, GroupedItem)\r\n else\r\n GetNotifier(I).DataProviderChanged(Self, Reason, RootItem);\r\n end;\r\n end\r\n else\r\n { No consumer, contextless consumer or no color settings. Hand over the grouped item as it\r\n is more specific. }\r\n GetNotifier(I).DataProviderChanged(Self, pcrAdd, GroupedItem);\r\n end;\r\n finally\r\n ReleaseContext;\r\n end;\r\n finally\r\n ReleaseConsumer;\r\n end;\r\nend;\r\n\r\nprocedure TJvColorProvider.NotifyColorAdding(ColorType: TColorType; ContextIndex: Integer);\r\nbegin\r\n if ContextIndex = -1 then\r\n ContextIndex := SelectedContextIndex;\r\n SelectConsumer(MasterColorConsumer);\r\n try\r\n SelectContext((DataContextsImpl as IJvDataContexts).GetContext(ContextIndex));\r\n try\r\n NotifyChanging(pcrAdd, ContextIndex, TJvColorHeaderItem.Create(GetItems, Ord(ColorType)).Items,\r\n GetItems);\r\n finally\r\n ReleaseContext;\r\n end;\r\n finally\r\n ReleaseConsumer;\r\n end;\r\nend;\r\n\r\nprocedure TJvColorProvider.NotifyColorAdded(ColorType: TColorType; ListIndex: Integer;\r\n ContextIndex: Integer);\r\nvar\r\n Grouped: IJvDataItem;\r\n Rooted: IJvDataItem;\r\nbegin\r\n if ContextIndex = -1 then\r\n ContextIndex := SelectedContextIndex;\r\n SelectConsumer(MasterColorConsumer);\r\n try\r\n SelectContext((DataContextsImpl as IJvDataContexts).GetContext(ContextIndex));\r\n try\r\n Grouped := TJvColorItem.Create(\r\n TJvColorHeaderItem.Create(GetItems, Ord(ColorType)) as IJvDataItems, Ord(ColorType),\r\n ListIndex);\r\n Rooted := TJvColorItem.Create(GetItems, Ord(ColorType), ListIndex);\r\n NotifyChanged(pcrAdd, ContextIndex,\r\n Grouped, Rooted);\r\n finally\r\n ReleaseContext;\r\n end;\r\n finally\r\n ReleaseConsumer;\r\n end;\r\nend;\r\n\r\nprocedure TJvColorProvider.NotifyColorDeleting(ColorType: TColorType; ListIndex: Integer; ContextIndex: Integer);\r\nbegin\r\n if ContextIndex = -1 then\r\n ContextIndex := SelectedContextIndex;\r\n SelectConsumer(MasterColorConsumer);\r\n try\r\n SelectContext((DataContextsImpl as IJvDataContexts).GetContext(ContextIndex));\r\n try\r\n NotifyChanging(pcrDelete, ContextIndex, TJvColorItem.Create(\r\n TJvColorHeaderItem.Create(GetItems, Ord(ColorType)) as IJvDataItems, Ord(ColorType),\r\n ListIndex),\r\n TJvColorItem.Create(GetItems, Ord(ColorType), ListIndex));\r\n finally\r\n ReleaseContext;\r\n end;\r\n finally\r\n ReleaseConsumer;\r\n end;\r\nend;\r\n\r\nprocedure TJvColorProvider.NotifyColorDeleted(ColorType: TColorType; ContextIndex: Integer);\r\nbegin\r\n if ContextIndex = -1 then\r\n ContextIndex := SelectedContextIndex;\r\n SelectConsumer(MasterColorConsumer);\r\n try\r\n SelectContext((DataContextsImpl as IJvDataContexts).GetContext(ContextIndex));\r\n try\r\n NotifyChanged(pcrDelete, ContextIndex,\r\n TJvColorHeaderItem.Create(GetItems, Ord(ColorType)).Items, GetItems);\r\n finally\r\n ReleaseContext;\r\n end;\r\n finally\r\n ReleaseConsumer;\r\n end;\r\nend;\r\n\r\nprocedure TJvColorProvider.NotifyColorsUpdating(ColorType: TColorType; ContextIndex: Integer);\r\nbegin\r\n if ContextIndex = -1 then\r\n ContextIndex := SelectedContextIndex;\r\n SelectConsumer(MasterColorConsumer);\r\n try\r\n SelectContext((DataContextsImpl as IJvDataContexts).GetContext(ContextIndex));\r\n try\r\n NotifyChanging(pcrUpdateItems, ContextIndex,\r\n TJvColorHeaderItem.Create(GetItems, Ord(ColorType)) as IJvDataItems, GetItems);\r\n finally\r\n ReleaseContext;\r\n end;\r\n finally\r\n ReleaseConsumer;\r\n end;\r\nend;\r\n\r\nprocedure TJvColorProvider.NotifyColorsUpdated(ColorType: TColorType; ContextIndex: Integer);\r\nbegin\r\n if ContextIndex = -1 then\r\n ContextIndex := SelectedContextIndex;\r\n SelectConsumer(MasterColorConsumer);\r\n try\r\n SelectContext((DataContextsImpl as IJvDataContexts).GetContext(ContextIndex));\r\n try\r\n NotifyChanged(pcrUpdateItems, ContextIndex,\r\n TJvColorHeaderItem.Create(GetItems, Ord(ColorType)) as IJvDataItems, GetItems);\r\n finally\r\n ReleaseContext;\r\n end;\r\n finally\r\n ReleaseConsumer;\r\n end;\r\nend;\r\n\r\nprocedure TJvColorProvider.DoAddColor(ColorType: TColorType; var Color: TColor; var DoAdd: Boolean);\r\nbegin\r\n if Assigned(FOnAddColor) then\r\n OnAddColor(Self, ColorType, Color, DoAdd);\r\nend;\r\n\r\nfunction TJvColorProvider.AddInternalColor(Color: TColor; AddToCustomDefaultList: Boolean): Integer;\r\nbegin\r\n Result := IndexOfColor(Color);\r\n if Result = -1 then\r\n begin\r\n Result := Length(FColorList);\r\n SetLength(FColorList, Result + 1);\r\n FColorList[Result].Value := Color;\r\n SetLength(FColorList[Result].Names, Mappings.Count);\r\n if Mappings.Count > 0 then\r\n FColorList[Result].Names[0] := Format('%s%.8x', [HexDisplayPrefix, Color]);\r\n FColorListChanged := True;\r\n if AddToCustomDefaultList then\r\n begin\r\n NotifyColorAdding(ctCustom, 0);\r\n SetLength(FCstColors[0], Length(FCstColors[0]) + 1);\r\n FCstColors[0][High(FCstColors[0])] := Result;\r\n NotifyColorAdded(ctCustom, High(FCstColors[0]), 0);\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJvColorProvider.AddColor(var List: TDynIntegerArray; Color: TColor;\r\n ColorType: TColorType; Context: Integer): Integer;\r\nvar\r\n Temp: Boolean;\r\nbegin\r\n Result := AddColor(List, Color, ColorType, Context, Temp);\r\nend;\r\n\r\nfunction TJvColorProvider.AddColor(var List: TDynIntegerArray; Color: TColor; ColorType: TColorType;\r\n Context: Integer; out Added: Boolean): Integer;\r\nvar\r\n ColorIdx: Integer;\r\nbegin\r\n ColorIdx := AddInternalColor(Color, (List <> FStdColors[0]) and (List <> FSysColors[0]) and\r\n (List <> FCstColors[0]));\r\n Result := IndexOfColIdx(List, ColorIdx);\r\n if Result = -1 then\r\n begin\r\n NotifyColorAdding(ColorType, Context);\r\n if (List <> FStdColors[0]) and (List <> FSysColors[0]) then\r\n FColorListChanged := True;\r\n Result := Length(List);\r\n SetLength(List, Result + 1);\r\n List[Result] := ColorIdx;\r\n NotifyColorAdded(ColorType, Result, Context);\r\n end;\r\nend;\r\n\r\nprocedure TJvColorProvider.DeleteColor(var List: TDynIntegerArray; Index: Integer;\r\n ColorType: TColorType; Context: Integer);\r\nbegin\r\n NotifyColorDeleting(ColorType, Index, Context);\r\n if (List <> FStdColors[0]) and (List <> FSysColors[0]) then\r\n FColorListChanged := True;\r\n if (Index < High(List)) then\r\n Move(List[Index + 1], List[Index], SizeOf(List[0]) * (High(List) - Index));\r\n SetLength(List, High(List));\r\n NotifyColorDeleted(ColorType, Context);\r\nend;\r\n\r\nprocedure TJvColorProvider.RemoveContextList(Index: Integer);\r\nbegin\r\n if (Index > -1) and (Index < Length(FStdColors)) then\r\n begin\r\n FColorListChanged := True;\r\n SetLength(FStdColors[Index], 0);\r\n SetLength(FSysColors[Index], 0);\r\n SetLength(FCstColors[Index], 0);\r\n\r\n if Index < High(FStdColors) then\r\n begin\r\n Move(FStdColors[Index + 1], FStdColors[Index], SizeOf(FStdColors[0]) * (High(FStdColors) - Index));\r\n Move(FSysColors[Index + 1], FSysColors[Index], SizeOf(FSysColors[0]) * (High(FSysColors) - Index));\r\n Move(FCstColors[Index + 1], FCstColors[Index], SizeOf(FCstColors[0]) * (High(FCstColors) - Index));\r\n FillChar(FStdColors[High(FStdColors)], SizeOf(FStdColors[High(FStdColors)]), 0);\r\n FillChar(FSysColors[High(FSysColors)], SizeOf(FSysColors[High(FSysColors)]), 0);\r\n FillChar(FCstColors[High(FCstColors)], SizeOf(FCstColors[High(FCstColors)]), 0);\r\n end;\r\n SetLength(FStdColors, High(FStdColors));\r\n end;\r\nend;\r\n\r\nfunction TJvColorProvider.IndexOfColor(Color: TColor): Integer;\r\nbegin\r\n Result := High(FColorList);\r\n while (Result >= 0) and (FColorList[Result].Value <> Color) do\r\n Dec(Result);\r\nend;\r\n\r\nfunction TJvColorProvider.IndexOfColIdx(const List: TDynIntegerArray; ColorIndex: Integer): Integer;\r\nbegin\r\n Result := High(List);\r\n while (Result >= 0) and (List[Result] <> ColorIndex) do\r\n Dec(Result);\r\nend;\r\n\r\nprocedure TJvColorProvider.CopyFromDefCtx(const TargetContextIndex: Integer);\r\nbegin\r\n if Length(FStdColors) > TargetContextIndex then\r\n begin\r\n SetLength(FStdColors[TargetContextIndex], Length(FStdColors[0]));\r\n Move(FStdColors[0][0], FStdColors[TargetContextIndex][0],\r\n SizeOf(FStdColors[0]) * Length(FStdColors[0]));\r\n end;\r\n if Length(FSysColors) > TargetContextIndex then\r\n begin\r\n SetLength(FSysColors[TargetContextIndex], Length(FSysColors[0]));\r\n Move(FSysColors[0][0], FSysColors[TargetContextIndex][0],\r\n SizeOf(FSysColors[0]) * Length(FSysColors[0]));\r\n end;\r\nend;\r\n\r\nfunction TJvColorProvider.SelectedContextIndex: Integer;\r\nbegin\r\n if SelectedContext = nil then\r\n Result := 0\r\n else\r\n Result := (DataContextsImpl as IJvDataContexts).IndexOf(SelectedContext);\r\n if Result < 0 then\r\n Result := 0;\r\nend;\r\n\r\nclass function TJvColorProvider.ItemsClass: TJvDataItemsClass;\r\nbegin\r\n Result := TJvColorItems;\r\nend;\r\n\r\nclass function TJvColorProvider.ContextsClass: TJvDataContextsClass;\r\nbegin\r\n Result := TJvDataContexts;\r\nend;\r\n\r\nclass function TJvColorProvider.ContextsManagerClass: TJvDataContextsManagerClass;\r\nbegin\r\n Result := TJvColorContextsManager;\r\nend;\r\n\r\nfunction TJvColorProvider.ConsumerClasses: TClassArray;\r\nbegin\r\n Result := inherited ConsumerClasses;\r\n AddToArray(Result, TJvColorProviderSettings);\r\nend;\r\n\r\nprocedure TJvColorProvider.ContextAdded(Context: IJvDataContext);\r\nvar\r\n Idx: Integer;\r\nbegin\r\n inherited ContextAdded(Context);\r\n Idx := (DataContextsImpl as IJvDataContexts).IndexOf(Context);\r\n if Idx > -1 then\r\n begin\r\n FColorListChanged := True;\r\n SetLength(FStdColors, Length(FStdColors) + 1);\r\n SetLength(FSysColors, Length(FSysColors) + 1);\r\n SetLength(FCstColors, Length(FCstColors) + 1);\r\n if Idx < High(FStdColors) then\r\n begin\r\n Move(FStdColors[Idx], FStdColors[Idx + 1], SizeOf(FStdColors[0]) * (High(FStdColors) - Idx));\r\n Move(FSysColors[Idx], FSysColors[Idx + 1], SizeOf(FSysColors[0]) * (High(FSysColors) - Idx));\r\n Move(FCstColors[Idx], FCstColors[Idx + 1], SizeOf(FCstColors[0]) * (High(FCstColors) - Idx));\r\n end;\r\n FillChar(FStdColors[Idx], SizeOf(FStdColors[Idx]), 0);\r\n FillChar(FSysColors[Idx], SizeOf(FSysColors[Idx]), 0);\r\n FillChar(FCstColors[Idx], SizeOf(FCstColors[Idx]), 0);\r\n end;\r\nend;\r\n\r\nprocedure TJvColorProvider.ContextDestroying(Context: IJvDataContext);\r\nvar\r\n Idx: Integer;\r\nbegin\r\n inherited ContextDestroying(Context);\r\n Idx := (DataContextsImpl as IJvDataContexts).IndexOf(Context);\r\n if Idx > -1 then\r\n RemoveContextList(Idx);\r\nend;\r\n\r\nprocedure TJvColorProvider.InsertMapping(var Strings: TDynStringArray; Index: Integer);\r\nbegin\r\n SetLength(Strings, Length(Strings) + 1);\r\n if Index < High(Strings) then\r\n Move(Strings[Index], Strings[Index + 1], (High(Strings) - Index) * SizeOf(string));\r\n FillChar(Strings[Index], 0, SizeOf(string));\r\n FColorListChanged := True;\r\nend;\r\n\r\nprocedure TJvColorProvider.DeleteMapping(var Strings: TDynStringArray; Index: Integer);\r\nbegin\r\n Strings[Index] := '';\r\n if Index < High(Strings) then\r\n begin\r\n Move(Strings[Index + 1], Strings[Index], (High(Strings) - Index) * SizeOf(string));\r\n FillChar(Strings[High(Strings)], 0, SizeOf(string));\r\n end;\r\n SetLength(Strings, High(Strings));\r\n FColorListChanged := True;\r\nend;\r\n\r\nprocedure TJvColorProvider.MappingAdding;\r\nvar\r\n I: Integer;\r\n ColorSettings: IJvColorProviderSettings;\r\nbegin\r\n { Iterate all consumers and notify them of the addition. }\r\n for I := GetNotifierCount - 1 downto 0 do\r\n if Supports(GetNotifier(I).Consumer, IJvColorProviderSettings, ColorSettings) then\r\n ColorSettings.MappingAdding;\r\nend;\r\n\r\nprocedure TJvColorProvider.MappingAdded(Index: Integer);\r\nvar\r\n Instance: TJvColorProviderNameMapping;\r\n I: Integer;\r\n ColorSettings: IJvColorProviderSettings;\r\nbegin\r\n Instance := Mappings[Index];\r\n { Iterate all consumers and notify them of the addition. }\r\n for I := GetNotifierCount - 1 downto 0 do\r\n if Supports(GetNotifier(I).Consumer, IJvColorProviderSettings, ColorSettings) then\r\n ColorSettings.MappingAdded(Index, Instance);\r\n { Iterate the colors list and insert the new mapping. }\r\n for I := 0 to High(FColorList) do\r\n InsertMapping(FColorList[I].Names, Index);\r\nend;\r\n\r\nprocedure TJvColorProvider.MappingDestroying(Index: Integer);\r\nvar\r\n Instance: TJvColorProviderNameMapping;\r\n I: Integer;\r\n ColorSettings: IJvColorProviderSettings;\r\nbegin\r\n if not (csDestroying in ComponentState) then\r\n begin\r\n Instance := Mappings[Index];\r\n { Iterate all consumers and notify them of the removal of that mapping. }\r\n for I := GetNotifierCount - 1 downto 0 do\r\n if Supports(GetNotifier(I).Consumer, IJvColorProviderSettings, ColorSettings) then\r\n ColorSettings.MappingDestroying(Index, Instance);\r\n { Iterate the colors list and delete the mapping. }\r\n for I := 0 to High(FColorList) do\r\n DeleteMapping(FColorList[I].Names, Index);\r\n end;\r\nend;\r\n\r\nprocedure TJvColorProvider.MappingDestroyed;\r\nvar\r\n I: Integer;\r\n ColorSettings: IJvColorProviderSettings;\r\nbegin\r\n { Iterate all consumers and notify them of the removal. }\r\n for I := GetNotifierCount - 1 downto 0 do\r\n if Supports(GetNotifier(I).Consumer, IJvColorProviderSettings, ColorSettings) then\r\n ColorSettings.MappingDestroyed;\r\nend;\r\n\r\nfunction TJvColorProvider.GetColor(List, Index: Integer; out Value: TColor;\r\n out Name: string): Boolean;\r\nvar\r\n CtxIdx: Integer;\r\n ColorIdx: Integer;\r\n ColorSettings: IJvColorProviderSettings;\r\n MapIdx: Integer;\r\nbegin\r\n CtxIdx := SelectedContextIndex;\r\n ColorIdx := -1;\r\n case List of\r\n 0:\r\n begin\r\n Result := (Index >= 0) and (Index < Length(FStdColors[CtxIdx]));\r\n if Result then\r\n ColorIdx := FStdColors[CtxIdx][Index];\r\n end;\r\n 1:\r\n begin\r\n Result := (Index >= 0) and (Index < Length(FSysColors[CtxIdx]));\r\n if Result then\r\n ColorIdx := FSysColors[CtxIdx][Index];\r\n end;\r\n 2:\r\n begin\r\n Result := (Index >= 0) and (Index < Length(FCstColors[CtxIdx]));\r\n if Result then\r\n ColorIdx := FCstColors[CtxIdx][Index];\r\n end;\r\n else\r\n Result := False;\r\n end;\r\n if Result then\r\n begin\r\n Value := FColorList[ColorIdx].Value;\r\n Name := '';\r\n if Mappings.Count > 0 then\r\n begin\r\n if Supports(SelectedConsumer, IJvColorProviderSettings, ColorSettings) then\r\n MapIdx := ColorSettings.NameMappingIndex\r\n else\r\n MapIdx := 0;\r\n if MapIdx = -1 then\r\n MapIdx := 0;\r\n Name := FColorList[ColorIdx].Names[MapIdx];\r\n if (Name = '') and (MapIdx <> 0) then\r\n Name := FColorList[ColorIdx].Names[0];\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvColorProvider.SetColorName(List, Index: Integer; const NewName: string);\r\nvar\r\n ValidIndex: Boolean;\r\n CtxIdx: Integer;\r\n ColorIdx: Integer;\r\n ColorSettings: IJvColorProviderSettings;\r\n MapIdx: Integer;\r\nbegin\r\n CtxIdx := SelectedContextIndex;\r\n ColorIdx := -1;\r\n case List of\r\n 0:\r\n begin\r\n ValidIndex := (Index >= 0) and (Index < Length(FStdColors[CtxIdx]));\r\n if ValidIndex then\r\n ColorIdx := FStdColors[CtxIdx][Index];\r\n end;\r\n 1:\r\n begin\r\n ValidIndex := (Index >= 0) and (Index < Length(FSysColors[CtxIdx]));\r\n if ValidIndex then\r\n ColorIdx := FSysColors[CtxIdx][Index];\r\n end;\r\n 2:\r\n begin\r\n ValidIndex := (Index >= 0) and (Index < Length(FCstColors[CtxIdx]));\r\n if ValidIndex then\r\n ColorIdx := FCstColors[CtxIdx][Index];\r\n end;\r\n else\r\n ValidIndex := False;\r\n end;\r\n if ValidIndex and (Mappings.Count > 0) then\r\n begin\r\n if Supports(SelectedConsumer, IJvColorProviderSettings, ColorSettings) then\r\n MapIdx := ColorSettings.NameMappingIndex\r\n else\r\n MapIdx := 0;\r\n if MapIdx = -1 then\r\n MapIdx := 0;\r\n FColorList[ColorIdx].Names[MapIdx] := NewName;\r\n end;\r\nend;\r\n\r\nfunction TJvColorProvider.GetColorCount(List: Integer): Integer;\r\nvar\r\n CtxIdx: Integer;\r\nbegin\r\n CtxIdx := SelectedContextIndex;\r\n case List of\r\n 0:\r\n Result := Length(FStdColors[CtxIdx]);\r\n 1:\r\n Result := Length(FSysColors[CtxIdx]);\r\n 2:\r\n Result := Length(FCstColors[CtxIdx]);\r\n else\r\n Result := 0;\r\n end;\r\nend;\r\n\r\nprocedure TJvColorProvider.GenDelphiConstantMapping;\r\nbegin\r\n Mappings.Add(TJvColorProviderNameMapping.Create(Mappings, RsDelphiConstantNames));\r\nend;\r\n\r\nprocedure TJvColorProvider.GenEnglishMapping;\r\nbegin\r\n Mappings.Add(TJvColorProviderNameMapping.Create(Mappings, RsEnglishNames));\r\nend;\r\n\r\nprocedure TJvColorProvider.InitColorList(var List: TDynIntegerArray;\r\n const Definitions: array of TDefColorItem; ColorType: TColorType);\r\nvar\r\n I: Integer;\r\n LstIdx: Integer;\r\n ColIdx: Integer;\r\nbegin\r\n for I := 0 to High(Definitions) do\r\n begin\r\n LstIdx := AddColor(List, Definitions[I].Value, ColorType, 0);\r\n ColIdx := List[LstIdx];\r\n FColorList[ColIdx].Names[0] := Definitions[I].Constant;\r\n FColorList[ColIdx].Names[1] := Definitions[I].Description;\r\n end;\r\nend;\r\n\r\nprocedure TJvColorProvider.InitColors;\r\nbegin\r\n InitColorList(FStdColors[0], ColorValues, ctStandard);\r\n InitColorList(FSysColors[0], SysColorValues, ctSystem);\r\nend;\r\n\r\nfunction TJvColorProvider.GetMappings: TJvColorProviderNameMappings;\r\nbegin\r\n Result := FMappings;\r\nend;\r\n\r\nprocedure TJvColorProvider.DefineProperties(Filer: TFiler);\r\nbegin\r\n { The color list and name mappings must be written first, before the contexts, as the context\r\n will read in the context specific lists, based on the complete color list. }\r\n Filer.DefineProperty('Colors', ReadColors, WriteColors, FColorListChanged);\r\n Filer.DefineProperty('Mappings', ReadMappings, WriteMappings, FColorListChanged);\r\n inherited DefineProperties(Filer);\r\nend;\r\n\r\nprocedure TJvColorProvider.ReadColors(Reader: TReader);\r\nbegin\r\n Reader.ReadListBegin;\r\n SetLength(FColorList, 0);\r\n FColorListChanged := True; // Make sure it will write the list next time.\r\n { Since mappings will be read next, clear the list now to save some time when colors are added as\r\n well as when the mappings are read later. }\r\n Mappings.Clear;\r\n while not Reader.EndOfList do\r\n AddInternalColor(TColor(Reader.ReadInteger), False);\r\n Reader.ReadListEnd;\r\nend;\r\n\r\nprocedure TJvColorProvider.WriteColors(Writer: TWriter);\r\nvar\r\n I: Integer;\r\nbegin\r\n Writer.WriteListBegin;\r\n for I := 0 to High(FColorList) do\r\n Writer.WriteInteger(FColorList[I].Value);\r\n Writer.WriteListEnd;\r\nend;\r\n\r\nprocedure TJvColorProvider.ReadMappings(Reader: TReader);\r\nbegin\r\n if Reader.ReadValue <> vaCollection then\r\n raise EReadError.CreateRes(@RsEMappingCollectionExpected);\r\n Mappings.Clear;\r\n while not Reader.EndOfList do\r\n ReadMapping(Reader);\r\n Reader.ReadListEnd;\r\nend;\r\n\r\nprocedure TJvColorProvider.WriteMappings(Writer: TWriter);\r\nvar\r\n I: Integer;\r\nbegin\r\n TWriterAccessProtected(Writer).WriteValue(vaCollection);\r\n for I := 0 to Mappings.Count - 1 do\r\n WriteMapping(Writer, I);\r\n Writer.WriteListEnd;\r\nend;\r\n\r\nprocedure TJvColorProvider.ReadMapping(Reader: TReader);\r\nvar\r\n Index: Integer;\r\n I: Integer;\r\n S: string;\r\n IEqualPos: Integer;\r\nbegin\r\n Reader.ReadListBegin;\r\n if not AnsiSameStr(Reader.ReadStr, 'Name') then\r\n raise EReadError.CreateRes(@RsEExpectedMappingName);\r\n Index := AddMapping(Reader.ReadString);\r\n if not AnsiSameStr(Reader.ReadStr, 'Names') then\r\n raise EReadError.CreateRes(@RsEExpectedNameMappings);\r\n Reader.ReadListBegin;\r\n while not Reader.EndOfList do\r\n begin\r\n S := Reader.ReadString;\r\n IEqualPos := Pos('=', S);\r\n if IEqualPos < 1 then\r\n raise EReadError.CreateRes(@RsEInvalidNameMappingSpecification);\r\n I := IndexOfColor(StrToInt(Trim(Copy(S, 1, IEqualPos - 1))));\r\n if I < 0 then\r\n raise EReadError.CreateResFmt(@RsEUnknownColor, [Trim(Copy(S, 1, IEqualPos - 1))]);\r\n FColorList[I].Names[Index] := Trim(Copy(S, IEqualPos + 1, Length(S) - IEqualPos));\r\n end;\r\n Reader.ReadListEnd;\r\n Reader.ReadListEnd;\r\nend;\r\n\r\nprocedure TJvColorProvider.WriteMapping(Writer: TWriter; Index: Integer);\r\nvar\r\n I: Integer;\r\nbegin\r\n Writer.WriteListBegin;\r\n Writer.WriteStr('Name');\r\n Writer.WriteString(Mappings[Index].Name);\r\n Writer.WriteStr('Names');\r\n Writer.WriteListBegin;\r\n for I := 0 to High(FColorList) do\r\n begin\r\n if FColorList[I].Names[Index] <> '' then\r\n Writer.WriteString(HexDisplayPrefix + IntToHex(FColorList[I].Value, 8) + ' = ' +\r\n FColorList[I].Names[Index]);\r\n end;\r\n Writer.WriteListEnd;\r\n Writer.WriteListEnd;\r\nend;\r\n\r\nfunction TJvColorProvider.GetColorItem(ColorType: TColorType; Index: Integer): IJvDataItem;\r\nvar\r\n Settings: IJvColorProviderSettings;\r\n ItemList: IJvDataItems;\r\nbegin\r\n if Supports(SelectedConsumer, IJvColorProviderSettings, Settings) then\r\n begin\r\n if Settings.GroupingSettings.Active and not Settings.GroupingSettings.FlatList then\r\n ItemList := TJvColorHeaderItem.Create(GetItems, Ord(ColorType)).Items\r\n else\r\n ItemList := GetItems;\r\n end\r\n else\r\n ItemList := GetItems;\r\n Result := TJvColorItem.Create(ItemList, Ord(ColorType), Index);\r\nend;\r\n\r\nfunction TJvColorProvider.GetColorItemByValue(ColorType: TColorType; Color: TColor): IJvDataItem;\r\nvar\r\n Idx: Integer;\r\nbegin\r\n Idx := IndexOfColor(Color);\r\n if Idx > -1 then\r\n begin\r\n case ColorType of\r\n ctStandard:\r\n Idx := IndexOfColIdx(FStdColors[SelectedContextIndex], Idx);\r\n ctSystem:\r\n Idx := IndexOfColIdx(FSysColors[SelectedContextIndex], Idx);\r\n ctCustom:\r\n Idx := IndexOfColIdx(FCstColors[SelectedContextIndex], Idx);\r\n else\r\n Idx := -1;\r\n end;\r\n end;\r\n if Idx > -1 then\r\n Result := GetColorItem(ColorType, Idx)\r\n else\r\n Result := nil;\r\nend;\r\n\r\nfunction TJvColorProvider.AddColor(ColorType: TColorType; Color: TColor): Boolean;\r\nbegin\r\n case ColorType of\r\n ctStandard:\r\n Result := AddStdColor(Color);\r\n ctSystem:\r\n Result := AddSysColor(Color);\r\n ctCustom:\r\n Result := AddCstColor(Color);\r\n else\r\n Result := False;\r\n end;\r\nend;\r\n\r\nfunction TJvColorProvider.IndexOfMapping(Mapping: TJvColorProviderNameMapping): Integer;\r\nbegin\r\n Result := Mappings.IndexOf(Mapping);\r\nend;\r\n\r\nfunction TJvColorProvider.IndexOfMappingName(Name: string): Integer;\r\nbegin\r\n Result := 0;\r\n while (Result < Get_MappingCount) and not AnsiSameText(Mappings[Result].Name, Name) do\r\n Inc(Result);\r\n if Result > Get_MappingCount then\r\n Result := -1;\r\nend;\r\n\r\nfunction TJvColorProvider.Get_MappingCount: Integer;\r\nbegin\r\n Result := Mappings.Count;\r\nend;\r\n\r\nfunction TJvColorProvider.Get_Mapping(Index: Integer): TJvColorProviderNameMapping;\r\nbegin\r\n Result := TJvColorProviderNameMapping(Mappings[Index]);\r\nend;\r\n\r\nfunction TJvColorProvider.AddMapping(AName: string): Integer;\r\nbegin\r\n Result := FMappings.Add(TJvColorProviderNameMapping.Create(FMappings, AName));\r\nend;\r\n\r\nfunction TJvColorProvider.NewMapping: Integer;\r\nbegin\r\n Result := AddMapping(GetUniqueMappingName(FMappings, 'Mapping '));\r\nend;\r\n\r\nprocedure TJvColorProvider.DeleteMapping(Index: Integer);\r\nbegin\r\n FMappings.Delete(Index);\r\nend;\r\n\r\nfunction TJvColorProvider.GetStandardCount: Integer;\r\nbegin\r\n Result := GetColorCount(0);\r\nend;\r\n\r\nfunction TJvColorProvider.GetSystemCount: Integer;\r\nbegin\r\n Result := GetColorCount(1);\r\nend;\r\n\r\nfunction TJvColorProvider.GetCustomCount: Integer;\r\nbegin\r\n Result := GetColorCount(2);\r\nend;\r\n\r\nfunction TJvColorProvider.GetStandardColor(Index: Integer; out Value: TColor; out Name: string): Boolean;\r\nbegin\r\n Result := GetColor(0, Index, Value, Name);\r\nend;\r\n\r\nfunction TJvColorProvider.GetSystemColor(Index: Integer; out Value: TColor; out Name: string): Boolean;\r\nbegin\r\n Result := GetColor(1, Index, Value, Name);\r\nend;\r\n\r\nfunction TJvColorProvider.GetCustomColor(Index: Integer; out Value: TColor; out Name: string): Boolean;\r\nbegin\r\n Result := GetColor(2, Index, Value, Name);\r\nend;\r\n\r\nfunction TJvColorProvider.FindColor(Value: TColor; out ColorType: TColorType; out Index: Integer): Boolean;\r\nvar\r\n CtxIdx: Integer;\r\n ColIdx: Integer;\r\nbegin\r\n CtxIdx := SelectedContextIndex;\r\n ColIdx := IndexOfColor(Value);\r\n\r\n Index := IndexOfColIdx(FStdColors[CtxIdx], ColIdx);\r\n if Index > -1 then\r\n ColorType := ctStandard\r\n else\r\n begin\r\n Index := IndexOfColIdx(FSysColors[CtxIdx], ColIdx);\r\n if Index > -1 then\r\n ColorType := ctSystem\r\n else\r\n begin\r\n Index := IndexOfColIdx(FCstColors[CtxIdx], ColIdx);\r\n if Index > -1 then\r\n ColorType := ctCustom;\r\n end;\r\n end;\r\n Result := Index >= 0;\r\nend;\r\n\r\nprocedure TJvColorProvider.SetStandardColorName(Index: Integer; NewName: string);\r\nbegin\r\n SetColorName(0, Index, NewName);\r\nend;\r\n\r\nprocedure TJvColorProvider.SetSystemColorName(Index: Integer; NewName: string);\r\nbegin\r\n SetColorName(1, Index, NewName);\r\nend;\r\n\r\nprocedure TJvColorProvider.SetCustomColorName(Index: Integer; NewName: string);\r\nbegin\r\n SetColorName(2, Index, NewName);\r\nend;\r\n\r\nfunction TJvColorProvider.AddStdColor(Value: TColor): Boolean;\r\nvar\r\n CtxIdx: Integer;\r\nbegin\r\n CtxIdx := SelectedContextIndex;\r\n if CtxIdx > -1 then\r\n AddColor(FStdColors[CtxIdx], Value, ctStandard, CtxIdx, Result);\r\nend;\r\n\r\nprocedure TJvColorProvider.DeleteStdColor(Value: TColor);\r\nvar\r\n ColIdx: Integer;\r\n CtxIdx: Integer;\r\n ItemIdx: Integer;\r\nbegin\r\n ColIdx := IndexOfColor(Value);\r\n if ColIdx > -1 then\r\n begin\r\n CtxIdx := SelectedContextIndex;\r\n if CtxIdx > -1 then\r\n begin\r\n ItemIdx := IndexOfColIdx(FStdColors[CtxIdx], ColIdx);\r\n if ItemIdx > -1 then\r\n DeleteColor(FStdColors[CtxIdx], ItemIdx, ctStandard, CtxIdx);\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvColorProvider.DeleteStdColorAt(Index: Integer);\r\nvar\r\n CtxIdx: Integer;\r\nbegin\r\n CtxIdx := SelectedContextIndex;\r\n if CtxIdx > -1 then\r\n DeleteColor(FStdColors[CtxIdx], Index, ctStandard, CtxIdx);\r\nend;\r\n\r\nprocedure TJvColorProvider.ClearStdColorList;\r\nvar\r\n CtxIdx: Integer;\r\nbegin\r\n CtxIdx := SelectedContextIndex;\r\n if CtxIdx > -1 then\r\n begin\r\n NotifyColorsUpdating(ctStandard, CtxIdx);\r\n SetLength(FStdColors[CtxIdx], 0);\r\n NotifyColorsUpdated(ctStandard, CtxIdx);\r\n end;\r\nend;\r\n\r\nfunction TJvColorProvider.AddSysColor(Value: TColor): Boolean;\r\nvar\r\n CtxIdx: Integer;\r\nbegin\r\n CtxIdx := SelectedContextIndex;\r\n if CtxIdx > -1 then\r\n AddColor(FSysColors[CtxIdx], Value, ctSystem, CtxIdx, Result);\r\nend;\r\n\r\nprocedure TJvColorProvider.DeleteSysColor(Value: TColor);\r\nvar\r\n ColIdx: Integer;\r\n CtxIdx: Integer;\r\n ItemIdx: Integer;\r\nbegin\r\n ColIdx := IndexOfColor(Value);\r\n if ColIdx > -1 then\r\n begin\r\n CtxIdx := SelectedContextIndex;\r\n if CtxIdx > -1 then\r\n begin\r\n ItemIdx := IndexOfColIdx(FSysColors[CtxIdx], ColIdx);\r\n if ItemIdx > -1 then\r\n DeleteColor(FSysColors[CtxIdx], ItemIdx, ctSystem, CtxIdx);\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvColorProvider.DeleteSysColorAt(Index: Integer);\r\nvar\r\n CtxIdx: Integer;\r\nbegin\r\n CtxIdx := SelectedContextIndex;\r\n if CtxIdx > -1 then\r\n DeleteColor(FSysColors[CtxIdx], Index, ctSystem, CtxIdx);\r\nend;\r\n\r\nprocedure TJvColorProvider.ClearSysColorList;\r\nvar\r\n CtxIdx: Integer;\r\nbegin\r\n CtxIdx := SelectedContextIndex;\r\n if CtxIdx > -1 then\r\n begin\r\n NotifyColorsUpdating(ctSystem, CtxIdx);\r\n SetLength(FSysColors[CtxIdx], 0);\r\n NotifyColorsUpdated(ctSystem, CtxIdx);\r\n end;\r\nend;\r\n\r\nfunction TJvColorProvider.AddCstColor(Value: TColor): Boolean;\r\nvar\r\n CtxIdx: Integer;\r\nbegin\r\n CtxIdx := SelectedContextIndex;\r\n if CtxIdx > -1 then\r\n AddColor(FCstColors[CtxIdx], Value, ctCustom, CtxIdx, Result);\r\nend;\r\n\r\nprocedure TJvColorProvider.DeleteCstColor(Value: TColor);\r\nvar\r\n ColIdx: Integer;\r\n CtxIdx: Integer;\r\n ItemIdx: Integer;\r\nbegin\r\n ColIdx := IndexOfColor(Value);\r\n if ColIdx > -1 then\r\n begin\r\n CtxIdx := SelectedContextIndex;\r\n if CtxIdx > -1 then\r\n begin\r\n ItemIdx := IndexOfColIdx(FCstColors[CtxIdx], ColIdx);\r\n if ItemIdx > -1 then\r\n DeleteColor(FCstColors[CtxIdx], ItemIdx, ctCustom, CtxIdx);\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvColorProvider.DeleteCstColorAt(Index: Integer);\r\nvar\r\n CtxIdx: Integer;\r\nbegin\r\n CtxIdx := SelectedContextIndex;\r\n if CtxIdx > -1 then\r\n DeleteColor(FCstColors[CtxIdx], Index, ctCustom, CtxIdx);\r\nend;\r\n\r\nprocedure TJvColorProvider.ClearCstColorList;\r\nvar\r\n CtxIdx: Integer;\r\nbegin\r\n CtxIdx := SelectedContextIndex;\r\n if CtxIdx > -1 then\r\n begin\r\n NotifyColorsUpdating(ctCustom, CtxIdx);\r\n SetLength(FCstColors[CtxIdx], 0);\r\n NotifyColorsUpdated(ctCustom, CtxIdx);\r\n end;\r\nend;\r\n\r\n//=== { TJvColorProviderNameMappings } =======================================\r\n\r\nconstructor TJvColorProviderNameMappings.Create(AProvider: TJvColorProvider);\r\nbegin\r\n inherited Create(True);\r\n FProvider := AProvider;\r\nend;\r\n\r\nfunction TJvColorProviderNameMappings.GetItem(Index: Integer): TJvColorProviderNameMapping;\r\nbegin\r\n Result := TJvColorProviderNameMapping(inherited GetItem(Index));\r\nend;\r\n\r\nprocedure TJvColorProviderNameMappings.SetItem(Index: Integer;\r\n AObject: TJvColorProviderNameMapping);\r\nbegin\r\n inherited SetItem(Index, AObject);\r\nend;\r\n\r\nfunction TJvColorProviderNameMappings.Add(Item: TJvColorProviderNameMapping): Integer;\r\nbegin\r\n Provider.MappingAdding;\r\n Result := inherited Add(Item);\r\n Provider.MappingAdded(Result);\r\nend;\r\n\r\nprocedure TJvColorProviderNameMappings.Clear;\r\nvar\r\n I: Integer;\r\nbegin\r\n I := Count - 1;\r\n while I >= 0 do\r\n begin\r\n Delete(I);\r\n Dec(I);\r\n end;\r\nend;\r\n\r\nprocedure TJvColorProviderNameMappings.Delete(Index: Integer);\r\nbegin\r\n if (Index >= 0) and (Index < Count) then\r\n begin\r\n Provider.MappingDestroying(Index);\r\n inherited Delete(Index);\r\n Provider.MappingDestroyed;\r\n end;\r\nend;\r\n\r\n//=== { TJvColorItemsRenderer } ==============================================\r\n\r\nfunction TJvColorItemsRenderer.GetRenderText: string;\r\nvar\r\n ItemText: IJvDataItemText;\r\nbegin\r\n with CurrentSettings.TextSettings do\r\n begin\r\n if Active or (CurrentItemIsColorItem and (CurrentColorValue >= clNone)) then\r\n begin\r\n if ShowName and Supports(CurrentItem, IJvDataItemText, ItemText) then\r\n Result := ItemText.Text\r\n else\r\n Result := '';\r\n if CurrentItemIsColorItem then\r\n begin\r\n if ShowHex or (Result = '') then\r\n begin\r\n if Result <> '' then\r\n Result := Result + Format(' (%s%.8x)', [HexDisplayPrefix, CurrentColorValue])\r\n else\r\n Result := Format('%s%.8x', [HexDisplayPrefix, CurrentColorValue]);\r\n end;\r\n if ShowRGB then\r\n begin\r\n if Result <> '' then\r\n Result := Result + Format(' (%d, %d, %d)', [\r\n GetRValue(ColorToRGB(CurrentColorValue)),\r\n GetGValue(ColorToRGB(CurrentColorValue)),\r\n GetBValue(ColorToRGB(CurrentColorValue))])\r\n else\r\n Result := Format('(%d, %d, %d)', [\r\n GetRValue(ColorToRGB(CurrentColorValue)),\r\n GetGValue(ColorToRGB(CurrentColorValue)),\r\n GetBValue(ColorToRGB(CurrentColorValue))]);\r\n end;\r\n end;\r\n end\r\n else\r\n if not CurrentItemIsColorItem then\r\n begin\r\n if Supports(CurrentItem, IJvDataItemText, ItemText) then\r\n Result := ItemText.Text\r\n else\r\n Result := RsDataItemRenderHasNoText;\r\n end\r\n else\r\n Result := '';\r\n end;\r\nend;\r\n\r\nprocedure TJvColorItemsRenderer.RenderColorBox;\r\nvar\r\n Margin: Integer;\r\n BoxW: Integer;\r\n BoxH: Integer;\r\n ShadowSize: Integer;\r\n R: TRect;\r\n SaveColor: TColor;\r\nbegin\r\n if CurrentSettings.ColorBoxSettings.Active then\r\n begin\r\n Margin := CurrentSettings.ColorBoxSettings.Margin;\r\n if CurrentSettings.TextSettings.Active then\r\n BoxW := CurrentSettings.ColorBoxSettings.Width\r\n else\r\n BoxW := CurrentRect.Right - CurrentRect.Left - (2 * Margin);\r\n BoxH := CurrentSettings.ColorBoxSettings.Height;\r\n if CurrentSettings.ColorBoxSettings.Shadowed then\r\n ShadowSize := CurrentSettings.ColorBoxSettings.ShadowSize\r\n else\r\n ShadowSize := 0;\r\n R := CurrentRect;\r\n OffsetRect(R, Margin, Margin);\r\n R.Right := R.Left + BoxW - ShadowSize;\r\n R.Bottom := R.Top + BoxH - ShadowSize;\r\n if (CurrentItemIsColorItem) and (CurrentColorValue < clNone) then\r\n with CurrentCanvas do\r\n begin\r\n SaveColor := Brush.Color;\r\n try\r\n Brush.Color := CurrentColorValue;\r\n FillRect(R);\r\n if CurrentSettings.ColorBoxSettings.Shadowed then\r\n begin\r\n Brush.Color := clGray;\r\n OffsetRect(R, ShadowSize, ShadowSize);\r\n FillRect(R);\r\n OffsetRect(R, -ShadowSize, -ShadowSize);\r\n end;\r\n Brush.Color := CurrentColorValue;\r\n Rectangle(R);\r\n finally\r\n Brush.Color := SaveColor;\r\n end;\r\n end;\r\n if CurrentSettings.TextSettings.Active then\r\n CurrentRect.Left := R.Right + CurrentSettings.ColorBoxSettings.Spacing;\r\n end;\r\nend;\r\n\r\nprocedure TJvColorItemsRenderer.RenderColorText;\r\nvar\r\n S: string;\r\n R: TRect;\r\n OldBkMode: Integer;\r\nbegin\r\n if CurrentSettings.TextSettings.Active or (CurrentColorValue >= clNone) then\r\n begin\r\n S := GetRenderText;\r\n R := CurrentRect;\r\n OldBkMode := SetBkMode(CurrentCanvas.Handle, TRANSPARENT);\r\n try\r\n DrawText(CurrentCanvas, S, Length(S), R, DT_SINGLELINE or DT_END_ELLIPSIS or\r\n DT_VCENTER or DT_NOPREFIX);\r\n finally\r\n SetBkMode(CurrentCanvas.Handle, OldBkMode);\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvColorItemsRenderer.RenderGroupHeader;\r\nvar\r\n S: string;\r\n OldFont: TFont;\r\n R: TRect;\r\n ha: TColorGroupHeaderAlign;\r\n RWidth: Integer;\r\n RVCenter: Integer;\r\n OldBkMode: Integer;\r\nbegin\r\n S := GetRenderText;\r\n OldFont := TFont.Create;\r\n try\r\n OldFont.Assign(CurrentCanvas.Font);\r\n try\r\n if ghsBoldFont in CurrentSettings.GroupingSettings.HeaderStyle then\r\n CurrentCanvas.Font.Style := CurrentCanvas.Font.Style + [fsBold];\r\n R := CurrentRect;\r\n Dec(R.Right, 2);\r\n if not CurrentSettings.GroupingSettings.FlatList then\r\n ha := ghaLeft\r\n else\r\n ha := CurrentSettings.GroupingSettings.HeaderAlign;\r\n case ha of\r\n ghaLeft:\r\n Inc(R.Left, 2);\r\n ghaColorText:\r\n begin\r\n if not CurrentSettings.TextSettings.Active or not CurrentSettings.ColorBoxSettings.Active then\r\n Inc(R.Left, 2)\r\n else\r\n with CurrentSettings.ColorBoxSettings do\r\n Inc(R.Left, Margin + Width + Spacing);\r\n end;\r\n ghaCenter:\r\n begin\r\n R.Left := 0;\r\n DrawText(CurrentCanvas.Handle, PChar(S), Length(S), R, DT_SINGLELINE or DT_NOPREFIX or\r\n DT_CALCRECT);\r\n RWidth := R.Right;\r\n R := CurrentRect;\r\n Inc(R.Left, 2);\r\n Dec(R.Right, 2);\r\n if RWidth < (R.Right - R.Left) then\r\n begin\r\n R.Left := R.Left + ((R.Right - R.Left - RWidth) div 2);\r\n R.Right := R.Left + RWidth;\r\n end;\r\n end;\r\n end;\r\n OldBkMode := SetBkMode(CurrentCanvas.Handle, TRANSPARENT);\r\n try\r\n DrawText(CurrentCanvas.Handle, PChar(S), Length(S), R, DT_SINGLELINE or DT_END_ELLIPSIS or\r\n DT_VCENTER or DT_NOPREFIX);\r\n finally\r\n SetBkMode(CurrentCanvas.Handle, OldBkMode);\r\n end;\r\n with CurrentSettings.GroupingSettings do\r\n if ([ghsSingleCenterLine, ghsDoubleCenterLine] * HeaderStyle) <> [] then\r\n begin\r\n RVCenter := CurrentRect.Top + (CurrentRect.Bottom - CurrentRect.Top) div 2;\r\n if R.Left > (CurrentRect.Left + 6) then\r\n begin\r\n if ghsSingleCenterLine in HeaderStyle then\r\n begin\r\n CurrentCanvas.MoveTo(CurrentRect.Left + 2, RVCenter);\r\n CurrentCanvas.LineTo(R.Left - 1, RVCenter);\r\n end\r\n else\r\n begin\r\n CurrentCanvas.MoveTo(CurrentRect.Left + 2, RVCenter - 1);\r\n CurrentCanvas.LineTo(R.Left - 1, RVCenter - 1);\r\n CurrentCanvas.MoveTo(CurrentRect.Left + 2, RVCenter + 1);\r\n CurrentCanvas.LineTo(R.Left - 1, RVCenter + 1);\r\n end\r\n end;\r\n DrawText(CurrentCanvas.Handle, PChar(S), Length(S), R, DT_SINGLELINE or DT_CALCRECT or\r\n DT_NOPREFIX);\r\n if R.Right < (CurrentRect.Right - 6) then\r\n begin\r\n if ghsSingleCenterLine in HeaderStyle then\r\n begin\r\n CurrentCanvas.MoveTo(R.Right + 2, RVCenter);\r\n CurrentCanvas.LineTo(CurrentRect.Right - 1, RVCenter);\r\n end\r\n else\r\n begin\r\n CurrentCanvas.MoveTo(R.Right + 2, RVCenter - 1);\r\n CurrentCanvas.LineTo(CurrentRect.Right - 1, RVCenter - 1);\r\n CurrentCanvas.MoveTo(R.Right + 2, RVCenter + 1);\r\n CurrentCanvas.LineTo(CurrentRect.Right - 1, RVCenter + 1);\r\n end;\r\n end;\r\n end;\r\n finally\r\n CurrentCanvas.Font.Assign(OldFont);\r\n end;\r\n finally\r\n OldFont.Free;\r\n end;\r\nend;\r\n\r\nprocedure TJvColorItemsRenderer.MeasureColorBox(var Size: TSize);\r\nvar\r\n Margin: Integer;\r\n BoxW: Integer;\r\n BoxH: Integer;\r\n XSize: Integer;\r\n YSize: Integer;\r\nbegin\r\n if CurrentSettings.ColorBoxSettings.Active then\r\n begin\r\n Margin := CurrentSettings.ColorBoxSettings.Margin;\r\n if CurrentSettings.TextSettings.Active then\r\n BoxW := CurrentSettings.ColorBoxSettings.Width\r\n else\r\n BoxW := CurrentSettings.ColorBoxSettings.Width + Margin;\r\n BoxH := CurrentSettings.ColorBoxSettings.Height;\r\n\r\n XSize := Margin + BoxW;\r\n YSize := 2 * Margin + BoxH;\r\n if Size.cx < XSize then\r\n Size.cx := XSize;\r\n if Size.cy < YSize then\r\n Size.cy := YSize;\r\n end;\r\nend;\r\n\r\nprocedure TJvColorItemsRenderer.MeasureColorText(var Size: TSize);\r\nvar\r\n XAdd: Integer;\r\n S: string;\r\n R: TRect;\r\nbegin\r\n if CurrentSettings.TextSettings.Active then\r\n begin\r\n XAdd := Size.cx;\r\n if XAdd > 0 then\r\n Inc(XAdd, CurrentSettings.ColorBoxSettings.Spacing);\r\n S := GetRenderText;\r\n R := Rect(0, 0, 0, 0);\r\n DrawText(CurrentCanvas.Handle, PChar(S), Length(S), R, DT_SINGLELINE or DT_NOPREFIX or\r\n DT_CALCRECT);\r\n Inc(R.Right, XAdd);\r\n if R.Right > Size.cx then\r\n Size.cx := R.Right;\r\n if R.Bottom > Size.cy then\r\n Size.cy := R.Bottom;\r\n end;\r\nend;\r\n\r\nprocedure TJvColorItemsRenderer.DoDrawItem(ACanvas: TCanvas; var ARect: TRect; Item: IJvDataItem;\r\n State: TProviderDrawStates);\r\nbegin\r\n // setup protected fields\r\n CurrentCanvas := ACanvas;\r\n CurrentRect := ARect;\r\n CurrentItem := Item;\r\n try\r\n CurrentState := State;\r\n CurrentSettings := GetConsumerSettings;\r\n try\r\n CurrentItemIsColorItem := GetItemColorValue(Item, CurrentColorValue);\r\n if CurrentItemIsColorItem then\r\n begin\r\n // render the color box and/or text\r\n RenderColorBox;\r\n RenderColorText;\r\n end\r\n else\r\n if AnsiSameText(Item.GetID, cColorProviderAddItemID) then\r\n begin\r\n CurrentColorValue := clNone;\r\n RenderColorBox;\r\n RenderColorText;\r\n end\r\n else\r\n RenderGroupHeader;\r\n finally\r\n CurrentSettings := nil;\r\n end;\r\n finally\r\n CurrentItem := nil;\r\n end;\r\nend;\r\n\r\nfunction TJvColorItemsRenderer.DoMeasureItem(ACanvas: TCanvas; Item: IJvDataItem): TSize;\r\nbegin\r\n // setup protected fields\r\n CurrentCanvas := ACanvas;\r\n CurrentItem := Item;\r\n try\r\n CurrentSettings := GetConsumerSettings;\r\n try\r\n CurrentItemIsColorItem := GetItemColorValue(Item, CurrentColorValue);\r\n Result.cx := 0;\r\n Result.cy := 0;\r\n MeasureColorBox(Result);\r\n MeasureColorText(Result);\r\n finally\r\n CurrentSettings := nil;\r\n end;\r\n finally\r\n CurrentItem := nil;\r\n end;\r\nend;\r\n\r\nfunction TJvColorItemsRenderer.AvgItemSize(ACanvas: TCanvas): TSize;\r\nvar\r\n ChHeight: Integer;\r\n Metrics: TTextMetric;\r\n ChWdth: Integer;\r\nbegin\r\n CurrentSettings := GetConsumerSettings;\r\n try\r\n Result.cx := 0;\r\n Result.cy := 0;\r\n MeasureColorBox(Result);\r\n if CurrentSettings.TextSettings.Active then\r\n begin\r\n ChHeight := CanvasMaxTextHeight(ACanvas);\r\n if ChHeight > Result.cy then\r\n Result.cy := ChHeight;\r\n GetTextMetrics(ACanvas.Handle, Metrics);\r\n ChWdth := Metrics.tmAveCharWidth;\r\n if CurrentSettings.ColorBoxSettings.Active then\r\n Result.cx := Result.cx + CurrentSettings.ColorBoxSettings.Spacing + (10 * ChWdth)\r\n else\r\n Result.cx := 10 * ChWdth;\r\n end;\r\n finally\r\n CurrentSettings := nil;\r\n end;\r\nend;\r\n\r\nfunction TJvColorItemsRenderer.GetConsumerSettings: IJvColorProviderSettings;\r\nbegin\r\n Supports(Items.GetProvider.SelectedConsumer, IJvColorProviderSettings, Result);\r\nend;\r\n\r\n//=== { TJvColorProviderSettings } ===========================================\r\n\r\nconstructor TJvColorProviderSettings.Create(AOwner: TExtensibleInterfacedPersistent);\r\nbegin\r\n inherited Create(AOwner);\r\n Changing(ccrViewChange);\r\n FColorBoxSettings := TJvColorProviderColorBoxSettings.Create(Self);\r\n FCustomColorSettings := TJvColorProviderCustomColorGroupSettings.Create(Self, RsCustomColors);\r\n FGroupingSettings := TJvColorProviderGroupingSettings.Create(Self);\r\n FTextSettings := TJvColorProviderTextSettings.Create(Self);\r\n FStandardColorSettings := TJvColorProviderColorGroupSettings.Create(Self, RsStandardColors);\r\n FSystemColorSettings := TJvColorProviderColorGroupSettings.Create(Self, RsSystemColors);\r\n FMapping := -1;\r\n Changed(ccrViewChange);\r\nend;\r\n\r\ndestructor TJvColorProviderSettings.Destroy;\r\nbegin\r\n FreeAndNil(FColorBoxSettings);\r\n FreeAndNil(FCustomColorSettings);\r\n FreeAndNil(FGroupingSettings);\r\n FreeAndNil(FTextSettings);\r\n FreeAndNil(FStandardColorSettings);\r\n FreeAndNil(FSystemColorSettings);\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJvColorProviderSettings.Get_ColorBoxSettings: TJvColorProviderColorBoxSettings;\r\nbegin\r\n Result := FColorBoxSettings;\r\nend;\r\n\r\nfunction TJvColorProviderSettings.Get_CustomColorSettings: TJvColorProviderCustomColorGroupSettings;\r\nbegin\r\n Result := FCustomColorSettings;\r\nend;\r\n\r\nfunction TJvColorProviderSettings.Get_GroupingSettings: TJvColorProviderGroupingSettings;\r\nbegin\r\n Result := FGroupingSettings;\r\nend;\r\n\r\nfunction TJvColorProviderSettings.Get_NameMapping: TJvColorProviderNameMapping;\r\nvar\r\n ColorProvider: IJvColorProvider;\r\nbegin\r\n if (FMapping > -1) and Supports(ConsumerImpl.ProviderIntf, IJvColorProvider, ColorProvider) then\r\n Result := ColorProvider.Mappings[FMapping]\r\n else\r\n Result := nil;\r\nend;\r\n\r\nfunction TJvColorProviderSettings.Get_NameMappingIndex: Integer;\r\nbegin\r\n Result := FMapping;\r\nend;\r\n\r\nfunction TJvColorProviderSettings.Get_StandardColorSettings: TJvColorProviderColorGroupSettings;\r\nbegin\r\n Result := FStandardColorSettings;\r\nend;\r\n\r\nfunction TJvColorProviderSettings.Get_SystemColorSettings: TJvColorProviderColorGroupSettings;\r\nbegin\r\n Result := FSystemColorSettings;\r\nend;\r\n\r\nfunction TJvColorProviderSettings.Get_TextSettings: TJvColorProviderTextSettings;\r\nbegin\r\n Result := FTextSettings;\r\nend;\r\n\r\nprocedure TJvColorProviderSettings.Set_ColorBoxSettings(Value: TJvColorProviderColorBoxSettings);\r\nbegin\r\nend;\r\n\r\nprocedure TJvColorProviderSettings.Set_CustomColorSettings(\r\n Value: TJvColorProviderCustomColorGroupSettings);\r\nbegin\r\nend;\r\n\r\nprocedure TJvColorProviderSettings.Set_GroupingSettings(Value: TJvColorProviderGroupingSettings);\r\nbegin\r\nend;\r\n\r\nprocedure TJvColorProviderSettings.Set_NameMapping(Value: TJvColorProviderNameMapping);\r\nvar\r\n Idx: Integer;\r\n ColorProvider: IJvColorProvider;\r\nbegin\r\n if Value = nil then\r\n Idx := -2\r\n else\r\n begin\r\n if Supports(ConsumerImpl.ProviderIntf, IJvColorProvider, ColorProvider) then\r\n Idx := ColorProvider.IndexOfMapping(Value)\r\n else\r\n Idx := -1;\r\n end;\r\n if Idx <> -1 then\r\n begin\r\n if Idx < 0 then\r\n Idx := -1;\r\n Set_NameMappingIndex(Idx);\r\n end\r\n else\r\n raise EJVCLDataConsumer.CreateRes(@RsESpecifiedMappingError);\r\nend;\r\n\r\nprocedure TJvColorProviderSettings.Set_NameMappingIndex(Value: Integer);\r\nbegin\r\n if FMapping <> Value then\r\n begin\r\n FMapping := Value;\r\n Changed(ccrOther);\r\n end;\r\nend;\r\n\r\nprocedure TJvColorProviderSettings.Set_StandardColorSettings(\r\n Value: TJvColorProviderColorGroupSettings);\r\nbegin\r\nend;\r\n\r\nprocedure TJvColorProviderSettings.Set_SystemColorSettings(\r\n Value: TJvColorProviderColorGroupSettings);\r\nbegin\r\nend;\r\n\r\nprocedure TJvColorProviderSettings.Set_TextSettings(Value: TJvColorProviderTextSettings);\r\nbegin\r\nend;\r\n\r\nprocedure TJvColorProviderSettings.MappingAdding;\r\nbegin\r\n if Assigned(FOnMappingAdding) then\r\n FOnMappingAdding(Self);\r\nend;\r\n\r\nprocedure TJvColorProviderSettings.MappingAdded(Index: Integer; Mapping: TJvColorProviderNameMapping);\r\nbegin\r\n if FMapping >= Index then\r\n begin\r\n Inc(FMapping);\r\n Changed(ccrOther);\r\n end;\r\n if Assigned(FOnMappingAdded) then\r\n FOnMappingAdded(Self, Index, Mapping);\r\nend;\r\n\r\nprocedure TJvColorProviderSettings.MappingDestroying(Index: Integer;\r\n Mapping: TJvColorProviderNameMapping);\r\nbegin\r\n if Assigned(FOnMappingDestroying) then\r\n FOnMappingDestroying(Self, Index, Mapping);\r\n if FMapping = Index then\r\n begin\r\n FMapping := -1;\r\n Changed(ccrOther);\r\n end\r\n else\r\n if FMapping > Index then\r\n begin\r\n Dec(FMapping);\r\n Changed(ccrOther);\r\n end;\r\nend;\r\n\r\nprocedure TJvColorProviderSettings.MappingDestroyed;\r\nbegin\r\n if Assigned(FOnMappingDestroyed) then\r\n FOnMappingDestroyed(Self);\r\nend;\r\n\r\nfunction TJvColorProviderSettings.GetNameMappingIndex: TJvColorProviderMapping;\r\nbegin\r\n Result := Get_NameMappingIndex;\r\nend;\r\n\r\nprocedure TJvColorProviderSettings.SetNameMappingIndex(Value: TJvColorProviderMapping);\r\nbegin\r\n Set_NameMappingIndex(Value);\r\nend;\r\n\r\n//=== { TJvColorContextsManager } ============================================\r\n\r\nfunction TJvColorContextsManager.New: IJvDataContext;\r\nbegin\r\n Result := Add(TJvColorContext.Create(ContextsImpl, GetUniqueCtxName(ContextsImpl, 'Context')));\r\nend;\r\n\r\n//=== { TJvColorContext } ====================================================\r\n\r\nfunction TJvColorContext.IsDeletable: Boolean;\r\nbegin\r\n Result := Contexts.IndexOf(Self) > 0;\r\nend;\r\n\r\nfunction TJvColorContext.IsStreamable: Boolean;\r\nbegin\r\n Result := True;\r\nend;\r\n\r\nprocedure TJvColorContext.DefineProperties(Filer: TFiler);\r\nvar\r\n CPImpl: TJvColorProvider;\r\nbegin\r\n inherited DefineProperties(Filer);\r\n CPImpl := Contexts.Provider.GetImplementer as TJvColorProvider;\r\n Filer.DefineProperty('StdColors', ReadStdColors, WriteStdColors, IsDeletable or\r\n CPImpl.FColorListChanged);\r\n Filer.DefineProperty('SysColors', ReadSysColors, WriteSysColors, IsDeletable or\r\n CPImpl.FColorListChanged);\r\n Filer.DefineProperty('CstColors', ReadCstColors, WriteCstColors, True);\r\nend;\r\n\r\nprocedure TJvColorContext.ReadStdColors(Reader: TReader);\r\nbegin\r\n ReadCtxList(Reader,\r\n TJvColorProvider(Contexts.Provider.GetImplementer).FStdColors[Contexts.IndexOf(Self)]);\r\nend;\r\n\r\nprocedure TJvColorContext.WriteStdColors(Writer: TWriter);\r\nbegin\r\n WriteCtxList(Writer,\r\n TJvColorProvider(Contexts.Provider.GetImplementer).FStdColors[Contexts.IndexOf(Self)]);\r\nend;\r\n\r\nprocedure TJvColorContext.ReadSysColors(Reader: TReader);\r\nbegin\r\n ReadCtxList(Reader,\r\n TJvColorProvider(Contexts.Provider.GetImplementer).FSysColors[Contexts.IndexOf(Self)]);\r\nend;\r\n\r\nprocedure TJvColorContext.WriteSysColors(Writer: TWriter);\r\nbegin\r\n WriteCtxList(Writer,\r\n TJvColorProvider(Contexts.Provider.GetImplementer).FSysColors[Contexts.IndexOf(Self)]);\r\nend;\r\n\r\nprocedure TJvColorContext.ReadCstColors(Reader: TReader);\r\nbegin\r\n ReadCtxList(Reader,\r\n TJvColorProvider(Contexts.Provider.GetImplementer).FCstColors[Contexts.IndexOf(Self)]);\r\nend;\r\n\r\nprocedure TJvColorContext.WriteCstColors(Writer: TWriter);\r\nbegin\r\n WriteCtxList(Writer,\r\n TJvColorProvider(Contexts.Provider.GetImplementer).FCstColors[Contexts.IndexOf(Self)]);\r\nend;\r\n\r\nprocedure TJvColorContext.ReadCtxList(Reader: TReader; var List: TDynIntegerArray);\r\nvar\r\n CPImpl: TJvColorProvider;\r\n Color: Integer;\r\n ColIdx: Integer;\r\nbegin\r\n Reader.ReadListBegin;\r\n CPImpl := Contexts.Provider.GetImplementer as TJvColorProvider;\r\n SetLength(List, 0);\r\n while not Reader.EndOfList do\r\n begin\r\n Color := Reader.ReadInteger;\r\n ColIdx := CPImpl.IndexOfColor(Color);\r\n if ColIdx < 0 then\r\n raise EReadError.CreateResFmt(@RsEInvalidColor, [Color]);\r\n if CPImpl.IndexOfColIdx(List, ColIdx) < 0 then\r\n begin\r\n SetLength(List, Length(List) + 1);\r\n List[High(List)] := ColIdx;\r\n end;\r\n end;\r\n Reader.ReadListEnd;\r\nend;\r\n\r\nprocedure TJvColorContext.WriteCtxList(Writer: TWriter; const List: TDynIntegerArray);\r\nvar\r\n CPImpl: TJvColorProvider;\r\n I: Integer;\r\nbegin\r\n CPImpl := Contexts.Provider.GetImplementer as TJvColorProvider;\r\n Writer.WriteListBegin;\r\n for I := 0 to High(List) do\r\n Writer.WriteInteger(CPImpl.FColorList[List[I]].Value);\r\n Writer.WriteListEnd;\r\nend;\r\n\r\n//=== { TJvColorMapItems } ===================================================\r\n\r\nconstructor TJvColorMapItems.Create;\r\nbegin\r\n inherited Create;\r\n FItemInstances := TList.Create;\r\nend;\r\n\r\ndestructor TJvColorMapItems.Destroy;\r\nbegin\r\n FreeAndNil(FConsumer);\r\n FreeAndNil(FItemInstances);\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJvColorMapItems.GetClientProvider: IJvDataProvider;\r\nbegin\r\n Result := FConsumer.ProviderIntf;\r\nend;\r\n\r\nprocedure TJvColorMapItems.SetClientProvider(Value: IJvDataProvider);\r\nbegin\r\n if Value <> ClientProvider then\r\n begin\r\n GetProvider.Changing(pcrFullRefresh, nil);\r\n FConsumer.SetProviderIntf(Value);\r\n ClearIntfImpl;\r\n if Value <> nil then\r\n InitImplementers;\r\n GetProvider.Changed(pcrFullRefresh, nil);\r\n end;\r\nend;\r\n\r\nprocedure TJvColorMapItems.DataProviderChanging(ADataProvider: IJvDataProvider;\r\n AReason: TDataProviderChangeReason; Source: IUnknown);\r\nbegin\r\n if AReason = pcrDestroy then\r\n ClientProvider := nil;\r\nend;\r\n\r\nprocedure TJvColorMapItems.DataProviderChanged(ADataProvider: IJvDataProvider;\r\n AReason: TDataProviderChangeReason; Source: IUnknown);\r\nbegin\r\nend;\r\n\r\nprocedure TJvColorMapItems.SubServiceCreated(Sender: TJvDataConsumer;\r\n SubSvc: TJvDataConsumerAggregatedObject);\r\nbegin\r\n if SubSvc is TJvColorProviderSettings then\r\n with TJvColorProviderSettings(SubSvc) do\r\n begin\r\n OnMappingAdding := Self.MappingAdding;\r\n OnMappingAdded := Self.MappingAdded;\r\n OnMappingDestroying := Self.MappingDestroying;\r\n OnMappingDestroyed := Self.MappingDestroyed;\r\n end;\r\nend;\r\n\r\nprocedure TJvColorMapItems.ConsumerChanged(Sender: TJvDataConsumer;\r\n Reason: TJvDataConsumerChangeReason);\r\nbegin\r\nend;\r\n\r\nprocedure TJvColorMapItems.MappingAdding(Sender: TObject);\r\nbegin\r\n GetProvider.Changing(pcrAdd, Self);\r\nend;\r\n\r\nprocedure TJvColorMapItems.MappingAdded(Sender: TJvColorProviderSettings; Index: Integer;\r\n Mapping: TJvColorProviderNameMapping);\r\nvar\r\n I: Integer;\r\nbegin\r\n // Iterate instance list and update item indices...\r\n for I := 0 to FItemInstances.Count - 1 do\r\n if TJvColorMapItem(FItemInstances[I]).FIndex >= Index then\r\n Inc(TJvColorMapItem(FItemInstances[I]).FIndex);\r\n GetProvider.Changed(pcrAdd, GetItem(Index));\r\nend;\r\n\r\nprocedure TJvColorMapItems.MappingDestroying(Sender: TJvColorProviderSettings; Index: Integer;\r\n Mapping: TJvColorProviderNameMapping);\r\nvar\r\n I: Integer;\r\nbegin\r\n GetProvider.Changing(pcrDelete, GetItem(Index));\r\n // Iterate instance list and update item indices...\r\n for I := 0 to FItemInstances.Count - 1 do\r\n if TJvColorMapItem(FItemInstances[I]).FIndex = Index then\r\n TJvColorMapItem(FItemInstances[I]).FIndex := -1\r\n else\r\n if TJvColorMapItem(FItemInstances[I]).FIndex > Index then\r\n Dec(TJvColorMapItem(FItemInstances[I]).FIndex);\r\nend;\r\n\r\nprocedure TJvColorMapItems.MappingDestroyed(Sender: TObject);\r\nbegin\r\n GetProvider.Changed(pcrDelete, Self);\r\nend;\r\n\r\nfunction TJvColorMapItems.GetCount: Integer;\r\nvar\r\n ColProv: IJvColorProvider;\r\nbegin\r\n if Supports(ClientProvider, IJvColorProvider, ColProv) then\r\n Result := ColProv.MappingCount\r\n else\r\n Result := 0;\r\nend;\r\n\r\nfunction TJvColorMapItems.GetItem(I: Integer): IJvDataItem;\r\nvar\r\n InstIdx: Integer;\r\nbegin\r\n InstIdx := FItemInstances.Count - 1;\r\n while (InstIdx >= 0) and (TJvColorMapItem(FItemInstances[InstIdx]).Index <> I) do\r\n Dec(InstIdx);\r\n if InstIdx > -1 then\r\n Result := TJvColorMapItem(FItemInstances[InstIdx])\r\n else\r\n begin\r\n Result := TJvColorMapItem.Create(Self, I);\r\n FItemInstances.Add(Result.GetImplementer);\r\n end;\r\nend;\r\n\r\nprocedure TJvColorMapItems.InitImplementers;\r\nbegin\r\n inherited InitImplementers;\r\n TJvColorMapItemsManager.Create(Self);\r\nend;\r\n\r\nprocedure TJvColorMapItems.AfterConstruction;\r\nvar\r\n ICR: IInterfaceComponentReference;\r\nbegin\r\n inherited AfterConstruction;\r\n if Supports(GetProvider, IInterfaceComponentReference, ICR) then\r\n FConsumer := TJvDataConsumer.Create(ICR.GetComponent, [])\r\n else\r\n FConsumer := TJvDataConsumer.Create(nil, []);\r\n FConsumer.OnProviderChanging := DataProviderChanging;\r\n FConsumer.OnProviderChanged := DataProviderChanged;\r\n FConsumer.AfterCreateSubSvc := SubServiceCreated;\r\n FConsumer.OnChanged := ConsumerChanged;\r\nend;\r\n\r\n//=== { TJvColorMapItem } ====================================================\r\n\r\nconstructor TJvColorMapItem.Create(AOwner: IJvDataItems; AIndex: Integer);\r\nbegin\r\n inherited Create(AOwner);\r\n FIndex := AIndex;\r\nend;\r\n\r\ndestructor TJvColorMapItem.Destroy;\r\nbegin\r\n TJvColorMapItems(GetItems.GetImplementer).FItemInstances.Remove(Self);\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJvColorMapItem.GetText: string;\r\nbegin\r\n Result := Get_NameMapping.Name;\r\nend;\r\n\r\nprocedure TJvColorMapItem.SetText(const Value: string);\r\nbegin\r\n Get_NameMapping.Name := Value;\r\nend;\r\n\r\nfunction TJvColorMapItem.Editable: Boolean;\r\nbegin\r\n Result := True;\r\nend;\r\n\r\nfunction TJvColorMapItem.Get_NameMapping: TJvColorProviderNameMapping;\r\nbegin\r\n Result := (TJvColorMapItems(GetItems.GetImplementer).ClientProvider as\r\n IJvColorProvider).Mappings[Index];\r\nend;\r\n\r\nprocedure TJvColorMapItem.InitID;\r\nbegin\r\n SetID(cColorProviderColorMapItemID + IntToStr(Index));\r\nend;\r\n\r\n//=== { TJvColorMapItemsManager } ============================================\r\n\r\nfunction TJvColorMapItemsManager.Add(Item: IJvDataItem): IJvDataItem;\r\nbegin\r\n { Any item that comes through this method is always referencing an existing mapping. Since\r\n duplicate mappings are not allowed, we can just ignore the add and return the same item. }\r\n Result := Item;\r\nend;\r\n\r\nfunction TJvColorMapItemsManager.New: IJvDataItem;\r\nvar\r\n ColProv: IJvColorProvider;\r\n MapIdx: Integer;\r\nbegin\r\n if Supports(TJvColorMapItems(ItemsImpl).ClientProvider, IJvColorProvider, ColProv) then\r\n begin\r\n MapIdx := ColProv.NewMapping;\r\n Result := Items.GetItem(MapIdx);\r\n end;\r\nend;\r\n\r\nprocedure TJvColorMapItemsManager.Clear;\r\nvar\r\n ColProv: IJvColorProvider;\r\nbegin\r\n if Supports(TJvColorMapItems(ItemsImpl).ClientProvider, IJvColorProvider, ColProv) then\r\n while ColProv.MappingCount > 0 do\r\n ColProv.DeleteMapping(0);\r\nend;\r\n\r\nprocedure TJvColorMapItemsManager.Delete(Index: Integer);\r\nvar\r\n ColProv: IJvColorProvider;\r\nbegin\r\n if Supports(TJvColorMapItems(ItemsImpl).ClientProvider, IJvColorProvider, ColProv) then\r\n ColProv.DeleteMapping(Index);\r\nend;\r\n\r\nprocedure TJvColorMapItemsManager.Remove(var Item: IJvDataItem);\r\nvar\r\n MapItem: IJvColorMapItem;\r\n ColProv: IJvColorProvider;\r\n MapIdx: Integer;\r\nbegin\r\n if Supports(Item, IJvColorMapItem, MapItem) then\r\n begin\r\n if Supports(TJvColorMapItems(ItemsImpl).ClientProvider, IJvColorProvider, ColProv) then\r\n begin\r\n MapIdx := ColProv.IndexOfMapping(MapItem.NameMapping);\r\n if MapIdx > -1 then\r\n begin\r\n Item := nil;\r\n MapItem := nil;\r\n Delete(MapIdx);\r\n end\r\n else\r\n raise EJVCLDataItems.CreateRes(@RsEItemNotForList);\r\n end\r\n else\r\n raise EJVCLDataItems.CreateRes(@RsEItemNotForList);\r\n end\r\n else\r\n raise EJVCLDataItems.CreateRes(@RsEItemNotForList);\r\nend;\r\n\r\n//=== { TJvColorConsumer } ===================================================\r\n\r\nfunction TJvColorConsumer.VCLComponent: TComponent;\r\nbegin\r\n Result := nil;\r\nend;\r\n\r\nfunction TJvColorConsumer.AttributeApplies(Attr: Integer): Boolean;\r\nbegin\r\n Result := False;\r\nend;\r\n\r\ninitialization\r\n {$IFDEF UNITVERSIONING}\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n {$ENDIF UNITVERSIONING}\r\n RegisterClasses([TJvColorProviderSettings, TJvColorProviderServerNotify, TJvColorContext]);\r\n MasterColorConsumer := TJvColorConsumer.Create;\r\n\r\nfinalization\r\n MasterColorConsumer := nil;\r\n {$IFDEF UNITVERSIONING}\r\n UnregisterUnitVersion(HInstance);\r\n {$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvColorTrackbar.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvColorBar.PAS, released on 2004-03-15.\r\n\r\nThe Initial Developer of the Original Code is Stefano Pessina [stefano dott pessina sanbiagiomonza dott it]\r\nPortions created by Stefano Pessina are Copyright (C) 2004 Stefano Pessina.\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvColorTrackbar.pas 13121 2011-09-21 12:31:58Z obones $\r\n\r\nunit JvColorTrackbar;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, Messages, Types, Classes, Controls, Graphics, Forms,\r\n JvComponent, JvJVCLUtils;\r\n\r\ntype\r\n TControlBorderStyle = bsNone..bsSingle;\r\n TJvColorTrackBarIndicator = (tbiArrow, tbiLine);\r\n TJvColorTrackBarIndicators = set of TJvColorTrackBarIndicator;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvColorTrackBar = class(TJvGraphicControl)\r\n private\r\n //FShowValue: Boolean;\r\n FPosition, FMin, FMax: Integer;\r\n FButtonDown: Boolean;\r\n FOnPosChanged: TNotifyEvent;\r\n FBmpImage: TBitmap;\r\n FColorFrom: TColor;\r\n FColorTo: TColor;\r\n FArrowColor: TColor;\r\n FOnMaxChange: TNotifyEvent;\r\n FOnMinChange: TNotifyEvent;\r\n FBorderStyle: TControlBorderStyle;\r\n FReadOnly: Boolean;\r\n FIndicators: TJvColorTrackBarIndicators;\r\n FFillDirection: TFillDirection;\r\n procedure SetPosition(const Value: Integer);\r\n procedure SetMax(const Value: Integer);\r\n procedure SetMin(const Value: Integer);\r\n procedure SetColorFrom(const Value: TColor);\r\n procedure SetColorTo(const Value: TColor);\r\n procedure SetArrowColor(const Value: TColor);\r\n procedure SetBorderStyle(const Value: TControlBorderStyle);\r\n procedure SetIndicators(const Value: TJvColorTrackBarIndicators);\r\n procedure SetFillDirection(const Value: TFillDirection);\r\n protected\r\n procedure Changed; virtual;\r\n procedure MinChanged; virtual;\r\n procedure MaxChanged; virtual;\r\n procedure Paint; override;\r\n public\r\n property Canvas;\r\n procedure UpdateGradient;\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n procedure Resize; override;\r\n procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;\r\n procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;\r\n procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;\r\n function WindowToPos(WindowCoord: Integer): Integer;\r\n function PosToWindow(APos: Integer): Integer;\r\n published\r\n property Indicators: TJvColorTrackBarIndicators read FIndicators write SetIndicators default [tbiArrow, tbiLine];\r\n property ArrowColor: TColor read FArrowColor write SetArrowColor default clBlack;\r\n\r\n property BorderStyle: TControlBorderStyle read FBorderStyle write SetBorderStyle;\r\n\r\n property ColorFrom: TColor read FColorFrom write SetColorFrom default clBlack;\r\n property ColorTo: TColor read FColorTo write SetColorTo default clBlue;\r\n property FillDirection: TFillDirection read FFillDirection write SetFillDirection default fdLeftToRight;\r\n property Min: Integer read FMin write SetMin default 0;\r\n property Max: Integer read FMax write SetMax default 100;\r\n property Position: Integer read FPosition write SetPosition default 0;\r\n property ReadOnly: Boolean read FReadOnly write FReadOnly default False;\r\n property OnPosChange: TNotifyEvent read FOnPosChanged write FOnPosChanged;\r\n property OnMinChange: TNotifyEvent read FOnMinChange write FOnMinChange;\r\n property OnMaxChange: TNotifyEvent read FOnMaxChange write FOnMaxChange;\r\n\r\n property Align;\r\n property Anchors;\r\n property Color;\r\n property Constraints;\r\n property DragKind;\r\n property DragCursor;\r\n property OnCanResize;\r\n property OnEndDock;\r\n property OnStartDock;\r\n property DragMode;\r\n property Hint;\r\n property ParentColor;\r\n property PopupMenu;\r\n property ParentShowHint;\r\n property ShowHint;\r\n property Height default 24;\r\n property Width default 120;\r\n property OnClick;\r\n property OnConstrainedResize;\r\n property OnContextPopup;\r\n property OnDblClick;\r\n property OnDragDrop;\r\n property OnDragOver;\r\n property OnEndDrag;\r\n property OnMouseDown;\r\n property OnMouseMove;\r\n property OnMouseUp;\r\n property OnMouseWheel;\r\n property OnMouseWheelDown;\r\n property OnMouseWheelUp;\r\n property OnStartDrag;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvColorTrackbar.pas $';\r\n Revision: '$Revision: 13121 $';\r\n Date: '$Date: 2011-09-21 14:31:58 +0200 (mer. 21 sept. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nconst\r\n ArrowOffset = 8;\r\n BitmapOffset = 4;\r\n\r\nconstructor TJvColorTrackBar.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n ControlStyle := ControlStyle + [csOpaque];\r\n FBmpImage := TBitmap.Create;\r\n FMin := 0;\r\n FMax := 100;\r\n FPosition := 0;\r\n FColorFrom := clBlack;\r\n FColorTo := clBlue;\r\n FArrowColor := clBlack;\r\n FBorderStyle := bsSingle;\r\n FIndicators := [tbiArrow, tbiLine];\r\n Height := 24;\r\n Width := 120;\r\n FFillDirection := fdLeftToRight;\r\n UpdateGradient;\r\nend;\r\n\r\ndestructor TJvColorTrackBar.Destroy;\r\nbegin\r\n FBmpImage.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvColorTrackBar.UpdateGradient;\r\nvar\r\n R: TRect;\r\nbegin\r\n if Parent = nil then\r\n Exit;\r\n FBmpImage.PixelFormat := pf24bit;\r\n if (FillDirection=fdTopToBottom) or (FillDirection=fdBottomToTop) then\r\n begin\r\n FBmpImage.Width := Width - ArrowOffset;\r\n FBmpImage.Height := Height - BitmapOffset;\r\n end else\r\n begin\r\n FBmpImage.Width := Width - BitmapOffset;\r\n FBmpImage.Height := Height - ArrowOffset;\r\n end;\r\n R := Rect(0, 0, FBmpImage.Width, FBmpImage.Height);\r\n\r\n GradientFillRect(FBmpImage.Canvas, R, ColorFrom, ColorTo, FillDirection, 255);\r\n if BorderStyle = bsSingle then\r\n DrawEdge(FBmpImage.Canvas.Handle, R, EDGE_SUNKEN, BF_TOP or BF_RIGHT or BF_BOTTOM or BF_LEFT);\r\nend;\r\n\r\nprocedure TJvColorTrackBar.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);\r\nbegin\r\n if Button = mbLeft then\r\n begin\r\n FButtonDown := not ReadOnly;\r\n if (FillDirection=fdTopToBottom) or (FillDirection=fdBottomToTop) then\r\n Position := WindowToPos(Y)\r\n else\r\n Position := WindowToPos(X);\r\n end;\r\n if Assigned(OnMouseDown) then\r\n OnMouseDown(Self, Button, Shift, X, Y);\r\nend;\r\n\r\nprocedure TJvColorTrackBar.MouseMove(Shift: TShiftState; X, Y: Integer);\r\nbegin\r\n if FButtonDown then\r\n begin\r\n if (FillDirection=fdTopToBottom) or (FillDirection=fdBottomToTop) then\r\n Position := WindowToPos(Y)\r\n else\r\n Position := WindowToPos(X);\r\n end;\r\n if Assigned(OnMouseMove) then\r\n OnMouseMove(Self, Shift, X, Y);\r\nend;\r\n\r\nprocedure TJvColorTrackBar.MouseUp(Button: TMouseButton; Shift: TShiftState;\r\n X, Y: Integer);\r\nbegin\r\n if (Button = mbLeft) and FButtonDown then\r\n begin\r\n if (FillDirection=fdTopToBottom) or (FillDirection=fdBottomToTop) then\r\n Position := WindowToPos(Y)\r\n else\r\n Position := WindowToPos(X);\r\n end;\r\n FButtonDown := False;\r\n if Assigned(OnMouseUp) then\r\n OnMouseUp(Self, Button, Shift, X, Y);\r\nend;\r\n\r\nprocedure TJvColorTrackBar.Paint;\r\nvar\r\n ArrowPosition: Integer;\r\n N: Integer;\r\n R: TRect;\r\n P: array [0..2] of TPoint;\r\n AHorizontalOffset, AVerticalOffset: Integer;\r\nbegin\r\n if Parent = nil then\r\n Exit;\r\n\r\n if (FillDirection=fdTopToBottom) or (FillDirection=fdBottomToTop) then\r\n begin\r\n AVerticalOffset := BitmapOffset;\r\n AHorizontalOffset := ArrowOffset;\r\n end else\r\n begin\r\n AVerticalOffset := ArrowOffset;\r\n AHorizontalOffset := BitmapOffset;\r\n end;\r\n if (Width - AHorizontalOffset <> FBmpImage.Width) or (Height <> FBmpImage.Height - AVerticalOffset) then\r\n UpdateGradient;\r\n\r\n Canvas.Pen.Color := Color;\r\n Canvas.Brush.Color := Color;\r\n if (FillDirection=fdTopToBottom) or (FillDirection=fdBottomToTop) then\r\n BitBlt(Canvas.Handle, ArrowOffset, BitmapOffset div 2, Width, Height, FBmpImage.Canvas.Handle, 0, 0, SrcCopy)\r\n else\r\n BitBlt(Canvas.Handle, BitmapOffset div 2, ArrowOffset, Width, Height, FBmpImage.Canvas.Handle, 0, 0, SrcCopy);\r\n if (FillDirection=fdTopToBottom) or (FillDirection=fdBottomToTop) then\r\n R := Rect(0, 0, ArrowOffset, Height)\r\n else\r\n R := Rect(0, 0, Width, ArrowOffset);\r\n Canvas.FillRect(R);\r\n ArrowPosition := PosToWindow(Position);\r\n if tbiArrow in Indicators then\r\n begin\r\n Canvas.Pen.Color := ArrowColor;\r\n Canvas.Brush.Color := ArrowColor;\r\n if (FillDirection=fdTopToBottom) or (FillDirection=fdBottomToTop) then\r\n begin\r\n P[0] := Point(0, ArrowPosition - 5);\r\n P[1] := Point(5, ArrowPosition);\r\n P[2] := Point(0, ArrowPosition + 5);\r\n end else\r\n begin\r\n P[0] := Point(ArrowPosition - 5, 0);\r\n P[1] := Point(ArrowPosition, 5);\r\n P[2] := Point(ArrowPosition + 5, 0);\r\n end;\r\n Canvas.Polygon(P);\r\n end;\r\n if tbiLine in Indicators then\r\n with Canvas do\r\n begin\r\n N := Ord(BorderStyle = bsSingle) * 2;\r\n if (FillDirection=fdTopToBottom) or (FillDirection=fdBottomToTop) then\r\n begin\r\n Pen.Color := Pixels[ArrowOffset + 4, ArrowPosition] xor clWhite;\r\n MoveTo(ArrowOffset + N, ArrowPosition - 1);\r\n LineTo(Width - N, ArrowPosition - 1);\r\n MoveTo(ArrowOffset + N, ArrowPosition);\r\n LineTo(Width - N, ArrowPosition);\r\n MoveTo(ArrowOffset + N, ArrowPosition + 1);\r\n LineTo(Width - N, ArrowPosition + 1);\r\n end else\r\n begin\r\n Pen.Color := Pixels[ArrowPosition, ArrowOffset + 4] xor clWhite;\r\n MoveTo(ArrowPosition - 1, ArrowOffset + N);\r\n LineTo(ArrowPosition - 1, Height - N);\r\n MoveTo(ArrowPosition, ArrowOffset + N);\r\n LineTo(ArrowPosition, Height - N);\r\n MoveTo(ArrowPosition + 1, ArrowOffset + N);\r\n LineTo(ArrowPosition + 1, Height - N);\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvColorTrackBar.Resize;\r\nbegin\r\n inherited Resize;\r\n UpdateGradient;\r\nend;\r\n\r\nprocedure TJvColorTrackBar.SetMax(const Value: Integer);\r\nbegin\r\n if Value > Min then\r\n begin\r\n FMax := Value;\r\n if FMax < Position then\r\n Position := FMax;\r\n Invalidate;\r\n MaxChanged;\r\n end;\r\nend;\r\n\r\nprocedure TJvColorTrackBar.SetMin(const Value: Integer);\r\nbegin\r\n if Value < Max then\r\n begin\r\n FMin := Value;\r\n if FMin > Position then\r\n Position := FMin;\r\n Invalidate;\r\n MinChanged;\r\n end;\r\nend;\r\n\r\nprocedure TJvColorTrackBar.SetPosition(const Value: Integer);\r\nbegin\r\n if (Value >= Min) and (Value <= Max) and (Value <> FPosition) then\r\n begin\r\n FPosition := Value;\r\n Invalidate;\r\n Changed;\r\n end;\r\nend;\r\n\r\nprocedure TJvColorTrackBar.Changed;\r\nbegin\r\n if Assigned(FOnPosChanged) then\r\n FOnPosChanged(Self);\r\nend;\r\n\r\nprocedure TJvColorTrackBar.SetColorFrom(const Value: TColor);\r\nbegin\r\n if FColorFrom <> Value then\r\n begin\r\n FColorFrom := Value;\r\n UpdateGradient;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvColorTrackBar.SetColorTo(const Value: TColor);\r\nbegin\r\n if FColorTo <> Value then\r\n begin\r\n FColorTo := Value;\r\n UpdateGradient;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nfunction TJvColorTrackBar.WindowToPos(WindowCoord: Integer): Integer;\r\nvar\r\n MaxWindowCoord: Integer;\r\nbegin\r\n if (FillDirection=fdTopToBottom) or (FillDirection=fdBottomToTop) then\r\n MaxWindowCoord := Height\r\n else\r\n MaxWindowCoord := Width;\r\n if (Max - Min > 0) and (MaxWindowCoord - BitmapOffset > 0) then\r\n begin\r\n Result := WindowCoord * (Max - Min) div (MaxWindowCoord - BitmapOffset);\r\n if (FillDirection=fdRightToLeft) or (FillDirection=fdBottomToTop) then\r\n Result := Max - Result\r\n else\r\n Result := Result + Min;\r\n end\r\n else\r\n Result := Min;\r\n if Result < Min then\r\n Result := Min;\r\n if Result > Max then\r\n Result := Max;\r\nend;\r\n\r\nfunction TJvColorTrackBar.PosToWindow(APos: Integer): Integer;\r\nvar\r\n MaxWindowCoord: Integer;\r\nbegin\r\n if (FillDirection=fdTopToBottom) or (FillDirection=fdBottomToTop) then\r\n MaxWindowCoord := Height\r\n else\r\n MaxWindowCoord := Width;\r\n if (Max - Min > 0) and (MaxWindowCoord > 0) then\r\n Result := MaxWindowCoord * (APos - Min) div (Max - Min)\r\n else\r\n Result := BitmapOffset;\r\n if Result < BitmapOffset * 2 then\r\n Result := BitmapOffset * 2;\r\n if Result > MaxWindowCoord - BitmapOffset * 2 then\r\n Result := MaxWindowCoord - BitmapOffset * 2;\r\n if (FillDirection=fdRightToLeft) or (FillDirection=fdBottomToTop) then\r\n Result := MaxWindowCoord - Result;\r\nend;\r\n\r\nprocedure TJvColorTrackBar.SetArrowColor(const Value: TColor);\r\nbegin\r\n if FArrowColor <> Value then\r\n begin\r\n FArrowColor := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvColorTrackBar.MaxChanged;\r\nbegin\r\n if Assigned(FOnMaxChange) then\r\n FOnMaxChange(Self);\r\nend;\r\n\r\nprocedure TJvColorTrackBar.MinChanged;\r\nbegin\r\n if Assigned(FOnMinChange) then\r\n FOnMinChange(Self);\r\nend;\r\n\r\nprocedure TJvColorTrackBar.SetBorderStyle(const Value: TControlBorderStyle);\r\nbegin\r\n if FBorderStyle <> Value then\r\n begin\r\n FBorderStyle := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvColorTrackBar.SetIndicators(const Value: TJvColorTrackBarIndicators);\r\nbegin\r\n if FIndicators <> Value then\r\n begin\r\n FIndicators := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvColorTrackBar.SetFillDirection(const Value: TFillDirection);\r\nbegin\r\n if FFillDirection <> Value then\r\n begin\r\n FFillDirection := Value;\r\n UpdateGradient;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\n\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvComCtrls.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvComCtrls.PAS, released Oct 10, 1999.\r\n\r\nThe Initial Developer of the Original Code is Petr Vones (petr dott v att mujmail dott cz)\r\nPortions created by Petr Vones are Copyright (C) 1999 Petr Vones.\r\nPortions created by Microsoft are Copyright (C) 1998, 1999 Microsoft Corp.\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\nPeter Below [100113 dott 1101 att compuserve dott com] - alternate TJvPageControl.OwnerDraw routine\r\nPeter Thrnqvist [peter3 at sourceforge dot net] added TJvIPAddress.AddressValues and TJvPageControl.ReduceMemoryUse\r\nAlfi [alioscia_alessi att onde dott net] alternate TJvPageControl.OwnerDraw routine\r\nRudy Velthuis - ShowRange in TJvTrackBar\r\nAndreas Hausladen - TJvIPAddress designtime bug, components changed to JvExVCL\r\nKai Gossens - TJvIPAddress: changing Color, drawing bug on XP (fat frame on edits removed)\r\ndejoy - TJvTreeView.MoveUp/MoveDown\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n TJvTreeView:\r\n When dragging an item and MultiSelect is True droptarget node is not painted\r\n correctly.\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvComCtrls.pas 13415 2012-09-10 09:51:54Z obones $\r\n\r\nunit JvComCtrls;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, Messages, Graphics, Controls, Forms,\r\n Classes,\r\n Menus, ComCtrls, ImgList, Buttons, Types, CommCtrl,\r\n JvJVCLUtils, JvComponentBase, JvComponent, JvExControls, JvExComCtrls, JvWin32,\r\n JvDataSourceIntf;\r\n\r\nconst\r\n JvDefPageControlBorder = 4;\r\n JvDefaultInactiveColorFrom = TColor($D7D7D7);\r\n JvDefaultInactiveColorTo = TColor($ADADAD);\r\n\r\n WM_CHECKSTATECHANGED = WM_USER + 1;\r\n\r\n JvDefaultTreeViewMultiSelectStyle = [msControlSelect, msShiftSelect, msVisibleOnly];\r\n\r\n JvIP4_127_0_0_1 = 2130706433;\r\n\r\ntype\r\n TJvIPAddress = class;\r\n\r\n TJvIPAddressMinMax = record\r\n Min: Byte;\r\n Max: Byte;\r\n end;\r\n\r\n TJvIPEditControlHelper = class(TObject)\r\n private\r\n FHandle: THandle;\r\n FInstance: TFNWndProc;\r\n FIPAddress: TJvIPAddress;\r\n FOrgWndProc: TFarProc;\r\n procedure SetHandle(const Value: THandle);\r\n protected\r\n procedure WndProc(var Msg: TMessage); virtual;\r\n property Handle: THandle read FHandle write SetHandle;\r\n public\r\n constructor Create(AIPAddress: TJvIPAddress);\r\n destructor Destroy; override;\r\n\r\n procedure SetFocus;\r\n function Focused: Boolean;\r\n procedure DefaultHandler(var Msg); override;\r\n end;\r\n\r\n TJvIPAddressComponentIndex = 1..4; // Numeration is backward, according to intel bytes order and MSDN FIRST_IPADDRESS\r\n\r\n TJvIPAddressRange = class(TPersistent)\r\n private\r\n FControl: TWinControl;\r\n FRange: array [0..3] of TJvIPAddressMinMax;\r\n function GetMaxRange(Index: Integer): Byte; {$IFDEF SUPPORTS_INLINE}inline;{$ENDIF}\r\n function GetMinRange(Index: Integer): Byte; {$IFDEF SUPPORTS_INLINE}inline;{$ENDIF}\r\n procedure SetMaxRange(const Index: Integer; const Value: Byte);\r\n procedure SetMinRange(const Index: Integer; const Value: Byte);\r\n {$IFOPT R+}\r\n procedure CheckIndex(const I: TJvIPAddressComponentIndex);\r\n {$ENDIF}\r\n function GetCheckedMaxRange(I: TJvIPAddressComponentIndex): Byte; {$IFOPT R-}{$IFDEF SUPPORTS_INLINE}inline;{$ENDIF}{$ENDIF}\r\n function GetCheckedMinRange(I: TJvIPAddressComponentIndex): Byte; {$IFOPT R-}{$IFDEF SUPPORTS_INLINE}inline;{$ENDIF}{$ENDIF}\r\n procedure SetCheckedMaxRange(I: TJvIPAddressComponentIndex; const Value: Byte); {$IFOPT R-}{$IFDEF SUPPORTS_INLINE}inline;{$ENDIF}{$ENDIF}\r\n procedure SetCheckedMinRange(I: TJvIPAddressComponentIndex; const Value: Byte); {$IFOPT R-}{$IFDEF SUPPORTS_INLINE}inline;{$ENDIF}{$ENDIF}\r\n protected\r\n procedure AssignTo(Dest: TPersistent); override;\r\n procedure Change(Index: Integer);\r\n\r\n public\r\n constructor Create(Control: TWinControl);\r\n property Min[I: TJvIPAddressComponentIndex]: Byte read GetCheckedMinRange write SetCheckedMinRange;\r\n property Max[I: TJvIPAddressComponentIndex]: Byte read GetCheckedMaxRange write SetCheckedMaxRange;\r\n published\r\n property Field1Min: Byte index 0 read GetMinRange write SetMinRange default 0;\r\n property Field1Max: Byte index 0 read GetMaxRange write SetMaxRange default 255;\r\n property Field2Min: Byte index 1 read GetMinRange write SetMinRange default 0;\r\n property Field2Max: Byte index 1 read GetMaxRange write SetMaxRange default 255;\r\n property Field3Min: Byte index 2 read GetMinRange write SetMinRange default 0;\r\n property Field3Max: Byte index 2 read GetMaxRange write SetMaxRange default 255;\r\n property Field4Min: Byte index 3 read GetMinRange write SetMinRange default 0;\r\n property Field4Max: Byte index 3 read GetMaxRange write SetMaxRange default 255;\r\n end;\r\n\r\n TJvIpAddrFieldChangeEvent = procedure(Sender: TJvIPAddress; FieldIndex: Integer;\r\n FieldRange: TJvIPAddressMinMax; var Value: Integer) of object;\r\n TJvIPAddressChanging = procedure(Sender: TObject; Index: Integer; Value: Byte; var AllowChange: Boolean) of object;\r\n\r\n TJvIPAddressValues = class(TObject)\r\n private\r\n FOnChange: TNotifyEvent;\r\n FOnChanging: TJvIPAddressChanging;\r\n FOwner: TJvIPAddress;\r\n\r\n function GetAddress: Cardinal;\r\n procedure SetAddress(const AValue: Cardinal);\r\n procedure SetValues(Index: Integer; Value: Byte);\r\n function GetValues(Index: Integer): Byte;\r\n protected\r\n procedure Change;\r\n function Changing(Index: Integer; Value: Byte): Boolean;\r\n public\r\n constructor Create(AOwner: TJvIpAddress);\r\n\r\n property OnChange: TNotifyEvent read FOnChange write FOnChange;\r\n property OnChanging: TJvIPAddressChanging read FOnChanging write FOnChanging;\r\n\r\n property Address: Cardinal read GetAddress write SetAddress;\r\n property Value1: Byte index 0 read GetValues write SetValues;\r\n property Value2: Byte index 1 read GetValues write SetValues;\r\n property Value3: Byte index 2 read GetValues write SetValues;\r\n property Value4: Byte index 3 read GetValues write SetValues;\r\n end;\r\n \r\n TJvIPAddressDataConnector = class(TJvFieldDataConnector)\r\n private\r\n FEditControl: TJvIPAddress;\r\n protected\r\n procedure RecordChanged; override;\r\n procedure UpdateData; override;\r\n property EditControl: TJvIPAddress read FEditControl;\r\n public\r\n constructor Create(AEditControl: TJvIPAddress);\r\n end;\r\n\r\n // declare externally to avoid Code Completion going crazy\r\n TJvIPAddressDual = packed record\r\n case byte of\r\n 0: (Address: LongWord);\r\n 1: (Comps: array[TJvIPAddressComponentIndex] of Byte);\r\n end;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvIPAddress = class(TJvCustomControl)\r\n private\r\n FEditControls: array [0..3] of TJvIPEditControlHelper;\r\n FEditControlCount: Integer;\r\n\r\n FAddress: TJvIPAddressDual;\r\n FRange: TJvIPAddressRange;\r\n FAddressValues: TJvIPAddressValues;\r\n FChanging: Boolean;\r\n FSaveBlank: Boolean;\r\n FTabThroughFields: Boolean;\r\n FLocalFont: HFONT;\r\n FOnFieldChange: TJvIpAddrFieldChangeEvent;\r\n FOnChange: TNotifyEvent;\r\n FFocusFromField: Boolean;\r\n FDataConnector: TJvIPAddressDataConnector;\r\n\r\n procedure SetDataConnector(const Value: TJvIPAddressDataConnector);\r\n procedure ClearEditControls;\r\n procedure DestroyLocalFont;\r\n procedure SetAddress(const Value: LongWord);\r\n procedure SetAddressValues(const Value: TJvIPAddressValues);\r\n procedure CNCommand(var Msg: TWMCommand); message CN_COMMAND;\r\n procedure CMEnabledChanged(var Message: TMessage); message CM_ENABLEDCHANGED;\r\n procedure CNNotify(var Msg: TWMNotify); message CN_NOTIFY;\r\n procedure WMDestroy(var Msg: TWMNCDestroy); message WM_DESTROY;\r\n procedure WMParentNotify(var Msg: TWMParentNotify); message WM_PARENTNOTIFY;\r\n procedure WMSetFont(var Msg: TWMSetFont); message WM_SETFONT;\r\n procedure WMSetFocus(var Msg: TWMSetFocus); message WM_SETFOCUS;\r\n procedure WMSetText(var Msg: TWMSetText); message WM_SETTEXT;\r\n procedure WMGetText(var Msg: TWMGetText); message WM_GETTEXT;\r\n procedure WMCtlColorEdit(var Msg: TWMCtlColorEdit); message WM_CTLCOLOREDIT;\r\n procedure WMKeyDown(var Msg: TWMKeyDown); message WM_KEYDOWN;\r\n procedure WMKeyUp(var Msg: TWMKeyUp); message WM_KEYUP;\r\n procedure SelectTabControl(Previous: Boolean);\r\n procedure SetBlank(const Value: Boolean);\r\n procedure DFMSkipLegacyAddressValues(Reader: TReader);\r\n procedure DoNotSetRange(const Value: TJvIPAddressRange);\r\n protected\r\n procedure GetDlgCode(var Code: TDlgCodes); override;\r\n procedure EnabledChanged; override;\r\n procedure ColorChanged; override;\r\n procedure FontChanged; override;\r\n function DoEraseBackground(Canvas: TCanvas; Param: LPARAM): Boolean; override;\r\n procedure AdjustHeight;\r\n function GetControlExtents: TRect; override;\r\n procedure CreateParams(var Params: TCreateParams); override;\r\n procedure CreateWnd; override;\r\n procedure DefineProperties(Filer: TFiler); override;\r\n procedure DoChange; dynamic;\r\n procedure Paint; override;\r\n\r\n procedure DoAddressChange(Sender: TObject); virtual;\r\n procedure DoAddressChanging(Sender: TObject; Index: Integer; Value: Byte; var AllowChange: Boolean); virtual;\r\n procedure DoFieldChange(FieldIndex: Integer; var FieldValue: Integer); dynamic;\r\n procedure PushAddressToWindows; {$IFDEF SUPPORTS_INLINE}inline;{$ENDIF}\r\n\r\n procedure UpdateValuesFromString(S: string);\r\n function GetAddressValue(Component: TJvIPAddressComponentIndex): Byte; {$IFDEF SUPPORTS_INLINE}inline;{$ENDIF}\r\n procedure SetAddressValue(Component: TJvIPAddressComponentIndex; const Value: Byte);\r\n\r\n procedure KeyPress(var Key: Char); override;\r\n procedure DoExit; override;\r\n function CreateDataConnector: TJvIPAddressDataConnector; virtual;\r\n function IsNotBlank: Boolean; {$IFDEF SUPPORTS_INLINE}inline;{$ENDIF} // for DFM storage\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n\r\n procedure ClearAddress;\r\n function IsBlank: Boolean;\r\n property AddressValue[Component: TJvIPAddressComponentIndex]: Byte read GetAddressValue write SetAddressValue;\r\n\r\n // this property is only here for bacwkard compatibility, please use .AddressValue[Index] and .Address instead\r\n property AddressValues: TJvIPAddressValues read FAddressValues write SetAddressValues stored False;\r\n published\r\n property Address: LongWord read FAddress.Address write SetAddress stored IsNotBlank default JvIP4_127_0_0_1;\r\n property AddressIsBlank: boolean read IsBlank write SetBlank default false;\r\n property Anchors;\r\n property AutoSize;\r\n property Color;\r\n property Constraints;\r\n property BevelEdges;\r\n property BevelInner;\r\n property BevelKind default bkNone;\r\n property BevelOuter;\r\n property DataConnector: TJvIPAddressDataConnector read FDataConnector write SetDataConnector;\r\n property DragCursor;\r\n property DragKind;\r\n property OnStartDock;\r\n property OnEndDock;\r\n property DragMode;\r\n property Enabled;\r\n property Font;\r\n property ParentColor;\r\n property ParentFont;\r\n property ParentShowHint;\r\n property PopupMenu;\r\n property Range: TJvIPAddressRange read FRange write DoNotSetRange {To make DFM store vaules};\r\n property ShowHint;\r\n property TabOrder;\r\n property TabStop default True;\r\n property TabThroughFields: Boolean read FTabThroughFields write FTabThroughFields default True;\r\n property Text stored false; // duplicate of Address\r\n property Visible;\r\n property OnChange: TNotifyEvent read FOnChange write FOnChange;\r\n property OnContextPopup;\r\n property OnDblClick;\r\n property OnDragDrop;\r\n property OnDragOver;\r\n property OnEndDrag;\r\n property OnEnter;\r\n property OnExit;\r\n property OnFieldChange: TJvIpAddrFieldChangeEvent read FOnFieldChange write FOnFieldChange; // user change, not programming change\r\n property OnKeyDown;\r\n property OnKeyPress;\r\n property OnKeyUp;\r\n property OnStartDrag;\r\n end;\r\n\r\n // TJvHintSource is a hint enumeration type to describe how to display hints for\r\n // controls that have hint properties both for the main control as well as\r\n // for it's subitems (like a PageControl)\r\n // TODO: (p3) this should really be moved to JvTypes or something...\r\n TJvHintSource =\r\n (\r\n hsDefault, // use default hint behaviour (i.e as regular control)\r\n hsForceMain, // use the main hint even if subitems have hints\r\n hsForceChildren, // always use subitems hints even if empty\r\n hsPreferMain, // use main control hint unless empty then use subitems hints\r\n hsPreferChildren // use subitems hints unless empty then use main control hint\r\n );\r\n\r\n // painters that can be used to draw the tabs of a TPageControl or TTabControl\r\n TJvTabControlPainter = class(TJvComponent)\r\n private\r\n FClients: TList;\r\n protected\r\n // descendants must override and implement this method\r\n procedure DrawTab(AControl: TCustomTabControl; Canvas: TCanvas;\r\n Images: TCustomImageList; ImageIndex: Integer; const Caption: string;\r\n const Rect: TRect; Active, Enabled: Boolean); virtual; abstract;\r\n procedure Change; virtual;\r\n\r\n procedure RegisterChange(AControl: TCustomTabControl);\r\n procedure UnRegisterChange(AControl: TCustomTabControl);\r\n procedure Notification(AComponent: TComponent; Operation: TOperation);\r\n override;\r\n public\r\n destructor Destroy; override;\r\n end;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvTabDefaultPainter = class(TJvTabControlPainter)\r\n private\r\n FActiveFont: TFont;\r\n FDisabledFont: TFont;\r\n FInactiveFont: TFont;\r\n FInactiveColorTo: TColor;\r\n FActiveColorTo: TColor;\r\n FDisabledColorTo: TColor;\r\n FInactiveColorFrom: TColor;\r\n FActiveColorFrom: TColor;\r\n FDisabledColorFrom: TColor;\r\n FActiveGradientDirection: TFillDirection;\r\n FInactiveGradientDirection: TFillDirection;\r\n FDisabledGradientDirection: TFillDirection;\r\n FGlyphLayout: TButtonLayout;\r\n FDivider: Boolean;\r\n FShowFocus: Boolean;\r\n procedure SetActiveFont(const Value: TFont);\r\n procedure SetDisabledFont(const Value: TFont);\r\n procedure SetInactiveFont(const Value: TFont);\r\n procedure SetActiveColorFrom(const Value: TColor);\r\n procedure SetActiveColorTo(const Value: TColor);\r\n procedure SetActiveGradientDirection(const Value: TFillDirection);\r\n procedure SetDisabledColorFrom(const Value: TColor);\r\n procedure SetDisabledColorTo(const Value: TColor);\r\n procedure SetDisabledGradientDirection(const Value: TFillDirection);\r\n procedure SetInactiveColorFrom(const Value: TColor);\r\n procedure SetInactiveColorTo(const Value: TColor);\r\n procedure SetInactiveGradientDirection(const Value: TFillDirection);\r\n function IsActiveFontStored: Boolean;\r\n function IsInactiveFontStored: Boolean;\r\n function IsDisabledFontStored: Boolean;\r\n procedure SetGlyphLayout(const Value: TButtonLayout);\r\n procedure SetDivider(const Value: Boolean);\r\n procedure SetShowFocus(const Value: Boolean);\r\n protected\r\n procedure DrawTab(AControl: TCustomTabControl; Canvas: TCanvas;\r\n Images: TCustomImageList; ImageIndex: Integer; const Caption: string;\r\n const Rect: TRect; Active, Enabled: Boolean); override;\r\n procedure DoFontChange(Sender: TObject);\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n published\r\n property ActiveFont: TFont read FActiveFont write SetActiveFont stored IsActiveFontStored;\r\n property ActiveColorFrom: TColor read FActiveColorFrom write SetActiveColorFrom default clWhite;\r\n property ActiveColorTo: TColor read FActiveColorTo write SetActiveColorTo default clBtnFace;\r\n property ActiveGradientDirection: TFillDirection read FActiveGradientDirection write SetActiveGradientDirection default fdTopToBottom;\r\n property InactiveFont: TFont read FInactiveFont write SetInactiveFont stored IsInactiveFontStored;\r\n property InactiveColorFrom: TColor read FInactiveColorFrom write SetInactiveColorFrom default JvDefaultInactiveColorFrom;\r\n property InactiveColorTo: TColor read FInactiveColorTo write SetInactiveColorTo default JvDefaultInactiveColorTo;\r\n property InactiveGradientDirection: TFillDirection read FInactiveGradientDirection write SetInactiveGradientDirection default fdTopToBottom;\r\n property DisabledFont: TFont read FDisabledFont write SetDisabledFont stored IsDisabledFontStored;\r\n property DisabledColorFrom: TColor read FDisabledColorFrom write SetDisabledColorFrom default clBtnFace;\r\n property DisabledColorTo: TColor read FDisabledColorTo write SetDisabledColorTo default clBtnFace;\r\n property DisabledGradientDirection: TFillDirection read FDisabledGradientDirection write SetDisabledGradientDirection default fdTopToBottom;\r\n property GlyphLayout: TButtonLayout read FGlyphLayout write SetGlyphLayout default blGlyphLeft;\r\n property Divider: Boolean read FDivider write SetDivider default False;\r\n property ShowFocus: Boolean read FShowFocus write SetShowFocus default False;\r\n end;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvTabControl = class(TJvExTabControl)\r\n private\r\n FTabPainter: TJvTabControlPainter;\r\n FRightClickSelect: Boolean;\r\n procedure CMDialogKey(var Msg: TWMKey); message CM_DIALOGKEY;\r\n procedure WMRButtonDown(var Msg: TWMRButtonDown); message WM_RBUTTONDOWN;\r\n procedure SetTabPainter(const Value: TJvTabControlPainter); // not WantKeys\r\n protected\r\n procedure DrawTab(TabIndex: Integer; const Rect: TRect; Active: Boolean); override;\r\n procedure Notification(AComponent: TComponent; Operation: TOperation); override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n published\r\n property RightClickSelect: Boolean read FRightClickSelect write FRightClickSelect default False;\r\n property TabPainter: TJvTabControlPainter read FTabPainter write SetTabPainter;\r\n property HintColor;\r\n property OnMouseEnter;\r\n property OnMouseLeave;\r\n property OnParentColorChange;\r\n property Color;\r\n end;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvPageControl = class(TJvExPageControl)\r\n private\r\n FClientBorderWidth: TBorderWidth;\r\n FHideAllTabs: Boolean;\r\n FHandleGlobalTab: Boolean;\r\n FHintSource: TJvHintSource;\r\n FReduceMemoryUse: Boolean;\r\n FTabPainter: TJvTabControlPainter;\r\n FRightClickSelect: Boolean;\r\n procedure SetClientBorderWidth(const Value: TBorderWidth);\r\n procedure TCMAdjustRect(var Msg: TMessage); message TCM_ADJUSTRECT;\r\n procedure SetHideAllTabs(const Value: Boolean);\r\n function FormKeyPreview: Boolean;\r\n procedure SetReduceMemoryUse(const Value: Boolean);\r\n procedure SetTabPainter(const Value: TJvTabControlPainter);\r\n protected\r\n function HintShow(var HintInfo: {$IFDEF RTL200_UP}Controls.{$ENDIF RTL200_UP}THintInfo): Boolean; override;\r\n function WantKey(Key: Integer; Shift: TShiftState): Boolean; override;\r\n\r\n procedure Loaded; override;\r\n function CanChange: Boolean; override;\r\n procedure Notification(AComponent: TComponent; Operation: TOperation); override;\r\n procedure DrawTab(TabIndex: Integer; const Rect: TRect; Active: Boolean); override;\r\n procedure WMLButtonDown(var Msg: TWMLButtonDown); message WM_LBUTTONDOWN;\r\n procedure WMRButtonDown(var Msg: TWMRButtonDown); message WM_RBUTTONDOWN;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n procedure UpdateTabImages;\r\n published\r\n property TabPainter: TJvTabControlPainter read FTabPainter write SetTabPainter;\r\n property HintSource: TJvHintSource read FHintSource write FHintSource default hsDefault;\r\n property HandleGlobalTab: Boolean read FHandleGlobalTab write FHandleGlobalTab default False;\r\n property ClientBorderWidth: TBorderWidth read FClientBorderWidth write SetClientBorderWidth default JvDefPageControlBorder;\r\n property ParentColor;\r\n property RightClickSelect: Boolean read FRightClickSelect write FRightClickSelect default False;\r\n property ReduceMemoryUse: Boolean read FReduceMemoryUse write SetReduceMemoryUse default False;\r\n property HideAllTabs: Boolean read FHideAllTabs write SetHideAllTabs default False;\r\n property HintColor;\r\n property OnMouseEnter;\r\n property OnMouseLeave;\r\n property OnParentColorChange;\r\n property Color;\r\n end;\r\n\r\n TJvTrackToolTipSide = (tsLeft, tsTop, tsRight, tsBottom);\r\n TJvTrackToolTipEvent = procedure(Sender: TObject; var ToolTipText: string) of object;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvTrackBar = class(TJvExTrackBar)\r\n private\r\n FOnChanged: TNotifyEvent;\r\n FShowRange: Boolean;\r\n FToolTips: Boolean;\r\n FToolTipSide: TJvTrackToolTipSide;\r\n FToolTipText: WideString;\r\n FOnToolTip: TJvTrackToolTipEvent;\r\n procedure SetToolTips(const Value: Boolean);\r\n procedure SetToolTipSide(const Value: TJvTrackToolTipSide);\r\n procedure WMNotify(var Msg: TWMNotify); message WM_NOTIFY;\r\n procedure CNHScroll(var Msg: TWMHScroll); message CN_HSCROLL;\r\n procedure CNVScroll(var Msg: TWMVScroll); message CN_VSCROLL;\r\n procedure SetShowRange(const Value: Boolean);\r\n protected\r\n procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;\r\n procedure CreateParams(var Params: TCreateParams); override;\r\n procedure CreateWnd; override;\r\n procedure InternalSetToolTipSide;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n published\r\n property ShowRange: Boolean read FShowRange write SetShowRange default True;\r\n property ToolTips: Boolean read FToolTips write SetToolTips default False;\r\n property ToolTipSide: TJvTrackToolTipSide read FToolTipSide write SetToolTipSide default tsLeft;\r\n property HintColor;\r\n property OnMouseEnter;\r\n property OnMouseLeave;\r\n property OnParentColorChange;\r\n property OnChanged: TNotifyEvent read FOnChanged write FOnChanged;\r\n property Color;\r\n property OnMouseDown;\r\n property OnMouseMove;\r\n property OnMouseUp;\r\n property OnToolTip: TJvTrackToolTipEvent read FOnToolTip write FOnToolTip;\r\n end;\r\n\r\n\r\n TJvTreeNode = class(TTreeNode)\r\n private\r\n FBold: Boolean;\r\n FChecked: Boolean;\r\n FPopupMenu: TPopupMenu;\r\n FFont: TFont;\r\n FBrush: TBrush;\r\n FOnCheckedChange: TNotifyEvent;\r\n function GetChecked: Boolean;\r\n procedure SetChecked(Value: Boolean);\r\n function GetBold: Boolean;\r\n procedure SetBold(const Value: Boolean);\r\n procedure SetPopupMenu(const Value: TPopupMenu);\r\n procedure SetFont(const Value: TFont);\r\n function GetFont: TFont;\r\n function GetBrush: TBrush;\r\n procedure SetBrush(const Value: TBrush);\r\n protected\r\n procedure Reinitialize; virtual;\r\n procedure DoCheckedChange;\r\n public\r\n class function CreateEnh(AOwner: TTreeNodes): TJvTreeNode;\r\n\r\n constructor Create(AOwner: TTreeNodes); {$IFDEF RTL200_UP}override{$ELSE}virtual{$ENDIF RTL200_UP};\r\n destructor Destroy; override;\r\n\r\n procedure MoveTo(Destination: TTreeNode; Mode: TNodeAttachMode); override;\r\n\r\n procedure Assign(Source: TPersistent); override;\r\n property Checked: Boolean read GetChecked write SetChecked;\r\n property Bold: Boolean read GetBold write SetBold;\r\n property Font: TFont read GetFont write SetFont;\r\n property Brush: TBrush read GetBrush write SetBrush;\r\n property PopupMenu: TPopupMenu read FPopupMenu write SetPopupMenu;\r\n\r\n property OnCheckedChange: TNotifyEvent read FOnCheckedChange write FOnCheckedChange;\r\n end;\r\n\r\n TJvNodeSelectCause = (nscUnknown = TVC_UNKNOWN, nscMouse = TVC_BYMOUSE, nscKeyboard = TVC_BYKEYBOARD);\r\n\r\n TPageChangedEvent = procedure(Sender: TObject; Item: TTreeNode; Page: TTabSheet) of object;\r\n TJvTreeViewComparePageEvent = procedure(Sender: TObject; Page: TTabSheet;\r\n Node: TTreeNode; var Matches: Boolean) of object;\r\n TJvTreeViewNodeCheckedChange = procedure(Sender: TObject; Node: TJvTreeNode) of object;\r\n TJvTreeViewSelectionChangingEvent = procedure(Sender: TObject; OldNode, NewNode: TJvTreeNode;\r\n Cause: TJvNodeSelectCause; var Allow: Boolean) of object;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvTreeView = class(TJvExTreeView)\r\n private\r\n FAutoDragScroll: Boolean;\r\n FScrollDirection: Integer;\r\n FOnCustomDrawItem: TTVCustomDrawItemEvent;\r\n FOnEditCancelled: TNotifyEvent;\r\n FOnSelectionChange: TNotifyEvent;\r\n FOnSelectionChanging: TJvTreeViewSelectionChangingEvent;\r\n FCheckBoxes: Boolean;\r\n FOnHScroll: TNotifyEvent;\r\n FOnVScroll: TNotifyEvent;\r\n FPageControl: TPageControl;\r\n FOnPage: TPageChangedEvent;\r\n FOnComparePage: TJvTreeViewComparePageEvent;\r\n FMenu: TMenu;\r\n FOldMenuChange: TMenuChangeEvent;\r\n FMenuDblClick: Boolean;\r\n FReinitializeTreeNode: Boolean;\r\n FOnNodeCheckedChange: TJvTreeViewNodeCheckedChange;\r\n FCheckEventsDisabled: Boolean;\r\n FRecreateCheckedState: array of Boolean;\r\n FForceClickSelect: Boolean;\r\n\r\n procedure InternalCustomDrawItem(Sender: TCustomTreeView;\r\n Node: TTreeNode; State: TCustomDrawState; var DefaultDraw: Boolean);\r\n function GetSelectedCount: Integer;\r\n function GetSelectedItem(Index: Integer): TTreeNode;\r\n procedure SetScrollDirection(const Value: Integer);\r\n procedure WMTimer(var Msg: TWMTimer); message WM_TIMER;\r\n procedure WMHScroll(var Msg: TWMHScroll); message WM_HSCROLL;\r\n procedure WMVScroll(var Msg: TWMVScroll); message WM_VSCROLL;\r\n procedure WMCheckStateChanged(var Msg: TMessage); message WM_CHECKSTATECHANGED;\r\n function GetItemHeight: Integer;\r\n procedure SetItemHeight(Value: Integer);\r\n function GetInsertMarkColor: TColor;\r\n procedure SetInsertMarkColor(Value: TColor);\r\n function GetLineColor: TColor;\r\n procedure SetLineColor(Value: TColor);\r\n function GetMaxScrollTime: Integer;\r\n procedure SetMaxScrollTime(const Value: Integer);\r\n function GetUseUnicode: Boolean;\r\n procedure SetUseUnicode(const Value: Boolean);\r\n procedure SetMenu(const Value: TMenu);\r\n procedure DoMenuChange(Sender: TObject; Source: TMenuItem; Rebuild: Boolean);\r\n procedure SetPageControl(const Value: TPageControl);\r\n function GetItemIndex: Integer;\r\n procedure SetItemIndex(const Value: Integer);\r\n procedure PostCheckStateChanged(Node: TTreeNode);\r\n protected\r\n procedure DoNodeCheckedChange(Node: TJvTreeNode);\r\n procedure TreeNodeCheckedChange(Sender: TObject); virtual;\r\n procedure SetCheckBoxes(const Value: Boolean); virtual;\r\n\r\n procedure RebuildFromMenu; virtual;\r\n function IsMenuItemClick(Node: TTreeNode): Boolean;\r\n function DoComparePage(Page: TTabSheet; Node: TTreeNode): Boolean; virtual;\r\n function CreateNode: TTreeNode; override;\r\n procedure CreateParams(var Params: TCreateParams); override;\r\n procedure CreateWnd; override;\r\n procedure DestroyWnd; override;\r\n procedure CNNotify(var Msg: TWMNotify); message CN_NOTIFY;\r\n procedure WMPaint(var Msg: TMessage); message WM_PAINT;\r\n procedure Change(Node: TTreeNode); override;\r\n procedure DoEditCancelled; dynamic;\r\n procedure DoEnter; override;\r\n procedure DoExit; override;\r\n procedure DoEndDrag(Target: TObject; X, Y: Integer); override;\r\n procedure DoSelectionChange; dynamic;\r\n function DoSelectionChanging(OldNode, NewNode: TJvTreeNode; Cause: TJvNodeSelectCause): Boolean; virtual;\r\n procedure DragOver(Source: TObject; X, Y: Integer; State: TDragState;\r\n var Accept: Boolean); override;\r\n procedure Edit(const Item: TTVItem); override;\r\n procedure InvalidateNode(Node: TTreeNode);\r\n procedure KeyDown(var Key: Word; Shift: TShiftState); override;\r\n procedure KeyPress(var Key: Char); override;\r\n procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X: Integer; Y: Integer); override;\r\n {$IFNDEF COMPILER15_UP} // Delphi XE fixed the OnAddition/OnDeletion bug\r\n procedure Added(Node: TTreeNode); override;\r\n procedure Delete(Node: TTreeNode); override;\r\n {$ENDIF ~COMPILER15_UP}\r\n property ScrollDirection: Integer read FScrollDirection write SetScrollDirection;\r\n procedure Notification(AComponent: TComponent; Operation: TOperation); override;\r\n procedure DblClick; override;\r\n function GetCheckedFromState(Node: TTreeNode): Boolean; virtual;\r\n procedure SetCheckedInState(Node: TTreeNode; Value: Boolean); virtual;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n function IsNodeSelected(Node: TTreeNode): Boolean;\r\n procedure Select(Node: TTreeNode; ShiftState: TShiftState = []); override;\r\n procedure InvalidateNodeIcon(Node: TTreeNode);\r\n procedure InvalidateSelectedItems;\r\n procedure SelectItem(Node: TTreeNode; Unselect: Boolean = False);\r\n function GetBold(Node: TTreeNode): Boolean;\r\n procedure SetBold(Node: TTreeNode; Value: Boolean);\r\n function GetChecked(Node: TTreeNode): Boolean;\r\n procedure SetChecked(Node: TTreeNode; Value: Boolean);\r\n procedure SetNodePopup(Node: TTreeNode; Value: TPopupMenu);\r\n function GetNodePopup(Node: TTreeNode): TPopupMenu;\r\n procedure InsertMark(Node: TTreeNode; MarkAfter: Boolean); // TVM_SETINSERTMARK\r\n procedure RemoveMark;\r\n\r\n { Move up the display order }\r\n function MoveUp(AAbsoluteIndex: Integer; Focus: Boolean = True): Integer;\r\n { move down the display order }\r\n function MoveDown(AAbsoluteIndex: Integer; Focus: Boolean = True): Integer;\r\n\r\n { Backward compatibility }\r\n property SelectedItems[Index: Integer]: TTreeNode read GetSelectedItem; // deprecated 'use Selections[]'\r\n property SelectedCount: Integer read GetSelectedCount; // deprecated 'use SelectionCount'\r\n\r\n property InsertMarkColor: TColor read GetInsertMarkColor write SetInsertMarkColor;\r\n property Checked[Node: TTreeNode]: Boolean read GetChecked write SetChecked;\r\n property MaxScrollTime: Integer read GetMaxScrollTime write SetMaxScrollTime;\r\n // UseUnicode should only be changed on Win95 and Win98 that has IE5 or later installed\r\n property UseUnicode: Boolean read GetUseUnicode write SetUseUnicode default False;\r\n published\r\n property LineColor: TColor read GetLineColor write SetLineColor default clDefault;\r\n property ItemHeight: Integer read GetItemHeight write SetItemHeight default 16;\r\n property Menu: TMenu read FMenu write SetMenu;\r\n property MenuDblClick: Boolean read FMenuDblClick write FMenuDblClick default False;\r\n property ForceClickSelect: Boolean read FForceClickSelect write FForceClickSelect default True;\r\n property HintColor;\r\n property ItemIndex: Integer read GetItemIndex write SetItemIndex stored False;\r\n property Checkboxes: Boolean read FCheckBoxes write SetCheckBoxes default False;\r\n property PageControl: TPageControl read FPageControl write SetPageControl;\r\n property AutoDragScroll: Boolean read FAutoDragScroll write FAutoDragScroll default False;\r\n property CheckEventsDisabled: Boolean read FCheckEventsDisabled write FCheckEventsDisabled default False;\r\n property MultiSelectStyle default JvDefaultTreeViewMultiSelectStyle;\r\n property OnVerticalScroll: TNotifyEvent read FOnVScroll write FOnVScroll;\r\n property OnHorizontalScroll: TNotifyEvent read FOnHScroll write FOnHScroll;\r\n property OnPageChanged: TPageChangedEvent read FOnPage write FOnPage;\r\n property OnComparePage: TJvTreeViewComparePageEvent read FOnComparePage write FOnComparePage;\r\n property OnMouseEnter;\r\n property OnMouseLeave;\r\n property OnParentColorChange;\r\n property OnCustomDrawItem: TTVCustomDrawItemEvent read FOnCustomDrawItem write FOnCustomDrawItem;\r\n property OnEditCancelled: TNotifyEvent read FOnEditCancelled write FOnEditCancelled;\r\n property OnSelectionChange: TNotifyEvent read FOnSelectionChange write FOnSelectionChange;\r\n property OnSelectionChanging: TJvTreeViewSelectionChangingEvent read FOnSelectionChanging write FOnSelectionChanging;\r\n property OnNodeCheckedChange: TJvTreeViewNodeCheckedChange read FOnNodeCheckedChange write FOnNodeCheckedChange;\r\n end;\r\n\r\nconst\r\n TVIS_CHECKED = $2000;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvComCtrls.pas $';\r\n Revision: '$Revision: 13415 $';\r\n Date: '$Date: 2012-09-10 11:51:54 +0200 (lun. 10 sept. 2012) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n {$IFDEF HAS_UNIT_SYSTEM_UITYPES}\r\n System.UITypes,\r\n {$ENDIF HAS_UNIT_SYSTEM_UITYPES}\r\n SysUtils, Math, StrUtils,\r\n JclStrings,\r\n JvConsts, JvThemes, JvJCLUtils;\r\n\r\nfunction NeedCheckStateEmulation(): Boolean; // ComCtrls 6+ under Vista+\r\n{$IFNDEF COMPILER7_UP}\r\nconst\r\n ComCtlVersionIE6 = $00060000;\r\n{$ENDIF ~COMPILER7_UP}\r\nbegin\r\n Result := (GetComCtlVersion < ComCtlVersionIE6) or not CheckWin32Version(6, 0);\r\nend;\r\n\r\n//=== { TJvIPAddressRange } ==================================================\r\n\r\nconstructor TJvIPAddressRange.Create(Control: TWinControl);\r\nvar\r\n I: Integer;\r\nbegin\r\n inherited Create;\r\n FControl := Control;\r\n for I := Low(FRange) to High(FRange) do\r\n begin\r\n FRange[I].Min := 0;\r\n FRange[I].Max := 255;\r\n end;\r\nend;\r\n\r\nprocedure TJvIPAddressRange.AssignTo(Dest: TPersistent);\r\nbegin\r\n if Dest is TJvIPAddressRange then\r\n with TJvIPAddressRange(Dest) do\r\n begin\r\n FRange := Self.FRange;\r\n Change(-1);\r\n end\r\n else\r\n inherited AssignTo(Dest);\r\nend;\r\n\r\nprocedure TJvIPAddressRange.Change(Index: Integer);\r\n\r\n procedure ChangeRange(FieldIndex: Integer);\r\n begin\r\n with FRange[FieldIndex] do\r\n FControl.Perform(IPM_SETRANGE, FieldIndex, MAKEIPRANGE(Min, Max));\r\n end;\r\n\r\nvar\r\n I: Integer;\r\nbegin\r\n if not FControl.HandleAllocated then\r\n Exit;\r\n if Index = -1 then\r\n for I := Low(FRange) to High(FRange) do\r\n ChangeRange(I)\r\n else\r\n ChangeRange(Index);\r\nend;\r\n\r\n{$IFOPT R+}\r\nprocedure TJvIPAddressRange.CheckIndex(const I: TJvIPAddressComponentIndex);\r\nbegin\r\n if (I > High(TJvIPAddressComponentIndex)) or (I < Low(TJvIPAddressComponentIndex)) then\r\n raise ERangeError.Create(Self.ClassName + ' range error: ' + IntToStr(I));\r\nend;\r\n{$ENDIF}\r\n\r\nfunction TJvIPAddressRange.GetCheckedMaxRange(I: TJvIPAddressComponentIndex): Byte;\r\nbegin\r\n {$IFOPT R+}\r\n CheckIndex(I);\r\n {$ENDIF}\r\n Result := GetMaxRange(I - 1);\r\nend;\r\n\r\nfunction TJvIPAddressRange.GetCheckedMinRange(I: TJvIPAddressComponentIndex): Byte;\r\nbegin\r\n {$IFOPT R+}\r\n CheckIndex(I);\r\n {$ENDIF}\r\n Result := GetMinRange(I - 1);\r\nend;\r\n\r\nfunction TJvIPAddressRange.GetMaxRange(Index: Integer): Byte;\r\nbegin\r\n Result := FRange[Index].Max;\r\nend;\r\n\r\nfunction TJvIPAddressRange.GetMinRange(Index: Integer): Byte;\r\nbegin\r\n Result := FRange[Index].Min;\r\nend;\r\n\r\nprocedure TJvIPAddressRange.SetCheckedMaxRange(I: TJvIPAddressComponentIndex;\r\n const Value: Byte);\r\nbegin\r\n {$IFOPT R+}\r\n CheckIndex(I);\r\n {$ENDIF}\r\n SetMaxRange(I - 1, Value);\r\nend;\r\n\r\nprocedure TJvIPAddressRange.SetCheckedMinRange(I: TJvIPAddressComponentIndex;\r\n const Value: Byte);\r\nbegin\r\n {$IFOPT R+}\r\n CheckIndex(I);\r\n {$ENDIF}\r\n SetMinRange(I - 1, Value);\r\nend;\r\n\r\nprocedure TJvIPAddressRange.SetMaxRange(const Index: Integer; const Value: Byte);\r\nvar\r\n Range: TJvIPAddressMinMax;\r\nbegin\r\n Range := FRange[Index];\r\n Range.Max := Value;\r\n if Range.Min > Value then\r\n Range.Min := Value;\r\n\r\n Change(Index);\r\nend;\r\n\r\nprocedure TJvIPAddressRange.SetMinRange(const Index: Integer; const Value: Byte);\r\nvar\r\n Range: TJvIPAddressMinMax;\r\nbegin\r\n Range := FRange[Index];\r\n Range.Min := Value;\r\n if Range.Max < Value then\r\n Range.Max := Value;\r\n\r\n Change(Index);\r\nend;\r\n\r\n//=== { TJvIPEditControlHelper } =============================================\r\n\r\nconstructor TJvIPEditControlHelper.Create(AIPAddress: TJvIPAddress);\r\nbegin\r\n inherited Create;\r\n FHandle := 0;\r\n FIPAddress := AIPAddress;\r\n FInstance := MakeObjectInstance(WndProc);\r\nend;\r\n\r\ndestructor TJvIPEditControlHelper.Destroy;\r\nbegin\r\n Handle := 0;\r\n if Assigned(FInstance) then\r\n FreeObjectInstance(FInstance);\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvIPEditControlHelper.SetFocus;\r\nbegin\r\n if FHandle <> 0 then\r\n begin\r\n Windows.SetFocus(FHandle);\r\n SendMessage(FHandle, EM_SETSEL, 0, MaxInt);\r\n end;\r\nend;\r\n\r\nfunction TJvIPEditControlHelper.Focused: Boolean;\r\nbegin\r\n if FHandle <> 0 then\r\n Result := THandle(Windows.GetFocus) = FHandle\r\n else\r\n Result := False;\r\nend;\r\n\r\nprocedure TJvIPEditControlHelper.DefaultHandler(var Msg);\r\nbegin\r\n with TMessage(Msg) do\r\n Result := CallWindowProc(FOrgWndProc, FHandle, Msg, WParam, LParam);\r\nend;\r\n\r\nprocedure TJvIPEditControlHelper.SetHandle(const Value: THandle);\r\nbegin\r\n if Value <> FHandle then\r\n begin\r\n if FHandle <> 0 then\r\n SetWindowLongPtr(FHandle, GWL_WNDPROC, LONG_PTR(FOrgWndProc));\r\n\r\n FHandle := Value;\r\n\r\n if FHandle <> 0 then\r\n FOrgWndProc := Pointer(SetWindowLongPtr(FHandle, GWL_WNDPROC, LONG_PTR(FInstance)));\r\n end;\r\nend;\r\n\r\nprocedure TJvIPEditControlHelper.WndProc(var Msg: TMessage);\r\nbegin\r\n case Msg.Msg of\r\n WM_ENABLE:\r\n if csDesigning in FIPAddress.ComponentState then\r\n Exit\r\n else\r\n begin\r\n {$IFDEF JVCLThemesEnabled}\r\n if not FIPAddress.Enabled and ThemeServices.{$IFDEF RTL230_UP}Enabled{$ELSE}ThemesEnabled{$ENDIF RTL230_UP} then\r\n begin\r\n EnableWindow(Handle, True);\r\n Exit;\r\n end;\r\n {$ENDIF JVCLThemesEnabled}\r\n end;\r\n WM_DESTROY:\r\n Handle := 0;\r\n WM_KEYFIRST..WM_KEYLAST:\r\n begin\r\n FIPAddress.Dispatch(Msg);\r\n if Msg.WParam = VK_TAB then\r\n Exit;\r\n end;\r\n // mouse messages are sent through TJvIPAddress.WMParentNotify\r\n end;\r\n\r\n Dispatch(Msg);\r\nend;\r\n\r\n//=== { TJvIPAddressDataConnector } ==========================================\r\n\r\nconstructor TJvIPAddressDataConnector.Create(AEditControl: TJvIPAddress);\r\nbegin\r\n inherited Create;\r\n FEditControl := AEditControl;\r\nend;\r\n\r\nprocedure TJvIPAddressDataConnector.RecordChanged;\r\nbegin\r\n if Field.IsValid then\r\n begin\r\n FEditControl.Enabled := Field.CanModify;\r\n FEditControl.Text := Field.AsString;\r\n end\r\n else\r\n begin\r\n FEditControl.Text := '';\r\n FEditControl.Enabled := False;\r\n end;\r\nend;\r\n\r\nprocedure TJvIPAddressDataConnector.UpdateData;\r\nbegin\r\n Field.AsString := FEditControl.Text;\r\n FEditControl.Text := Field.AsString; // update to stored value\r\nend;\r\n\r\n//=== { TJvIPAddress } =======================================================\r\n\r\nconstructor TJvIPAddress.Create(AOwner: TComponent);\r\nvar\r\n I: Integer;\r\nbegin\r\n CheckCommonControl(ICC_INTERNET_CLASSES);\r\n inherited Create(AOwner);\r\n ControlStyle := ControlStyle + [csFixedHeight, csReflector];\r\n FDataConnector := TJvIPAddressDataConnector.Create(Self);\r\n\r\n FRange := TJvIPAddressRange.Create(Self);\r\n FAddressValues := TJvIPAddressValues.Create(Self);\r\n FAddressValues.OnChange := DoAddressChange;\r\n FAddressValues.OnChanging := DoAddressChanging;\r\n FTabThroughFields := True;\r\n\r\n Color := clWindow;\r\n ParentColor := False;\r\n TabStop := True;\r\n Width := 150;\r\n AdjustHeight;\r\n\r\n for I := 0 to High(FEditControls) do\r\n FEditControls[I] := TJvIPEditControlHelper.Create(Self);\r\n\r\n FAddress.Address := JvIP4_127_0_0_1;\r\nend;\r\n\r\ntype\r\n TReaderCracker = class (TReader)\r\n public property PropName;\r\n end;\r\n\r\nprocedure TJvIPAddress.DFMSkipLegacyAddressValues(Reader: TReader);\r\nbegin\r\n Reader.SkipValue;\r\nend;\r\n\r\nprocedure TJvIPAddress.DefineProperties(Filer: TFiler);\r\nbegin\r\n inherited;\r\n if Filer is TReader then\r\n begin\r\n { We do not care about writing, but should not break upon legacy triply redundant DFMs\r\n If in some future Delphi, TReader cracking became impossible, properties will have to be skipped one by one\r\n Legacy DFM extract sample (all those just duplicate direct .Address property):\r\n AddressValues.Address = 16980708\r\n AddressValues.Value1 = 1\r\n AddressValues.Value2 = 3\r\n AddressValues.Value3 = 26\r\n AddressValues.Value4 = 228\r\n }\r\n if Pos('AddressValues.', TReaderCracker(Filer).PropName) = 1 then\r\n Filer.DefineProperty(TReaderCracker(Filer).PropName, DFMSkipLegacyAddressValues, nil,false);\r\n end;\r\nend;\r\n\r\ndestructor TJvIPAddress.Destroy;\r\nvar\r\n I: Integer;\r\nbegin\r\n FreeAndNil(FRange);\r\n FreeAndNil(FAddressValues);\r\n FDataConnector.Free;\r\n inherited Destroy;\r\n // (ahuser) I don't know why but TWinControl.DestroyWindowHandle raises an AV\r\n // when FEditControls are released before inherited Destroy.\r\n for I := 0 to High(FEditControls) do\r\n FEditControls[I].Free;\r\nend;\r\n\r\nprocedure TJvIPAddress.CreateParams(var Params: TCreateParams);\r\nbegin\r\n InitCommonControl(ICC_INTERNET_CLASSES);\r\n inherited CreateParams(Params);\r\n CreateSubClass(Params, WC_IPADDRESS);\r\n with Params do\r\n begin\r\n Style := Style or WS_CHILD;\r\n WindowClass.style := WindowClass.style and not (CS_HREDRAW or CS_VREDRAW);\r\n end;\r\nend;\r\n\r\nprocedure TJvIPAddress.CreateWnd;\r\nvar\r\n EditHandle: THandle;\r\n Msg: TWMParentNotify;\r\nbegin\r\n ClearEditControls;\r\n FChanging := True;\r\n try\r\n inherited CreateWnd;\r\n FRange.Change(-1);\r\n if FSaveBlank then\r\n ClearAddress\r\n else\r\n PushAddressToWindows;\r\n \r\n if (FEditControlCount = 0) and (csDesigning in ComponentState) then\r\n begin\r\n // WM_PARENTNOTIFY messages are captured by the IDE starting when\r\n // CreateWnd is called the second time. So we must find the edit controls\r\n // ourself and simulate a WM_PARENTNOTIFY by a direct function call.\r\n EditHandle := 0;\r\n repeat\r\n EditHandle := FindWindowEx(Handle, EditHandle, 'EDIT', nil);\r\n if EditHandle <> 0 then\r\n begin\r\n Msg.Msg := WM_PARENTNOTIFY;\r\n Msg.Event := WM_CREATE;\r\n Msg.ChildID := GetDlgCtrlID(EditHandle);\r\n Msg.ChildWnd := EditHandle;\r\n WMParentNotify(Msg); // IDE captures WM_PARENTNOTIFY\r\n end;\r\n until EditHandle = 0;\r\n end;\r\n finally\r\n FChanging := False;\r\n end;\r\nend;\r\n\r\nprocedure TJvIPAddress.DestroyLocalFont;\r\nbegin\r\n if FLocalFont <> 0 then\r\n begin\r\n OSCheck(DeleteObject(FLocalFont));\r\n FLocalFont := 0;\r\n end;\r\nend;\r\n\r\n// Type used to get access to FindNextControl outside Forms.pas\r\n// This allows to fix Mantis 2812\r\ntype\r\n TWinControlAccess = class(TWinControl)\r\n public\r\n function FindNextControl(CurControl: TWinControl;\r\n GoForward, CheckTabStop, CheckParent: Boolean): TWinControl;\r\n end;\r\n\r\nfunction TWinControlAccess.FindNextControl(CurControl: TWinControl;\r\n GoForward, CheckTabStop, CheckParent: Boolean): TWinControl;\r\nbegin\r\n Result := inherited FindNextControl(CurControl, GoForward, CheckTabStop, CheckParent);\r\nend;\r\n\r\nprocedure TJvIPAddress.SelectTabControl(Previous: Boolean);\r\nvar\r\n Control: TWinControl;\r\n ParentForm: TCustomForm;\r\nbegin\r\n ParentForm := GetParentForm(Self);\r\n if Assigned(ParentForm) then\r\n begin\r\n // Must use GetParentForm to fix Mantis 2812, where it wasn't possible\r\n // to tab outside the control\r\n Control := TWinControlAccess(ParentForm).FindNextControl(Self, not Previous, True, False);\r\n if Control <> nil then\r\n Control.SetFocus;\r\n end;\r\nend;\r\n\r\nprocedure TJvIPAddress.WMKeyDown(var Msg: TWMKeyDown);\r\nvar\r\n I, FocusIndex: Integer;\r\nbegin\r\n if Msg.CharCode = VK_TAB then\r\n begin\r\n FocusIndex := -1;\r\n for I := 0 to FEditControlCount - 1 do\r\n begin\r\n if FEditControls[I].Focused then\r\n begin\r\n FocusIndex := I;\r\n Break;\r\n end;\r\n end;\r\n\r\n if GetKeyState(VK_SHIFT) < 0 then\r\n Dec(FocusIndex)\r\n else\r\n Inc(FocusIndex);\r\n\r\n if FocusIndex >= 0 then\r\n begin\r\n if FocusIndex < FEditControlCount then\r\n FEditControls[FocusIndex].SetFocus\r\n else\r\n SelectTabControl(False);\r\n end\r\n else\r\n if FocusIndex = -1 then\r\n SelectTabControl(True);\r\n end\r\n else\r\n inherited;\r\nend;\r\n\r\nprocedure TJvIPAddress.WMKeyUp(var Msg: TWMKeyUp);\r\nbegin\r\n if Msg.CharCode = VK_TAB then\r\n Msg.Result := 0\r\n else\r\n inherited;\r\nend;\r\n\r\nfunction TJvIPAddress.DoEraseBackground(Canvas: TCanvas; Param: LPARAM): Boolean;\r\nbegin\r\n Canvas.Brush.Color := Color;\r\n Canvas.FillRect(ClientRect);\r\n Result := True;\r\nend;\r\n\r\nprocedure TJvIPAddress.Paint;\r\nvar\r\n I: Integer;\r\n R1, R2: TRect;\r\n X, Y: Integer;\r\n Pt: TPoint;\r\nbegin\r\n { We paint the '.' ourself so we can also paint the control's background in\r\n DoEraseBackground what would be impossible without self-painting because\r\n the IP-Control always paints a clWindow background in WM_PAINT. }\r\n for I := 0 to (FEditControlCount - 1) - 1 do\r\n begin\r\n GetWindowRect(FEditControls[I].Handle, R1);\r\n GetWindowRect(FEditControls[I + 1].Handle, R2);\r\n X := R1.Right + (R2.Left - R1.Right) div 2;\r\n Y := R1.Top;\r\n Pt := ScreenToClient(Point(X, Y));\r\n Canvas.Font.Color := Font.Color;\r\n Canvas.Brush.Color := Color;\r\n Canvas.TextOut(Pt.X, Pt.Y, '.');\r\n end;\r\nend;\r\n\r\nprocedure TJvIPAddress.AdjustHeight;\r\nvar\r\n DC: HDC;\r\n SaveFont: HFONT;\r\n // I: Integer;\r\n // R: TRect;\r\n Metrics: TTextMetric;\r\nbegin\r\n DC := GetDC(HWND_DESKTOP);\r\n SaveFont := SelectObject(DC, Font.Handle);\r\n GetTextMetrics(DC, Metrics);\r\n SelectObject(DC, SaveFont);\r\n ReleaseDC(HWND_DESKTOP, DC);\r\n Height := Metrics.tmHeight + (GetSystemMetrics(SM_CYBORDER) * 8);\r\n { for I := 0 to FEditControlCount - 1 do\r\n begin\r\n GetWindowRect(FEditControls[I].Handle, R);\r\n R.TopLeft := ScreenToClient(R.TopLeft);\r\n R.BottomRight := ScreenToClient(R.BottomRight);\r\n OffsetRect(R, -R.Left, -R.Top);\r\n R.Bottom := ClientHeight;\r\n SetWindowPos(FEditControls[I].Handle, 0, 0, 0, R.Right, R.Bottom,\r\n SWP_NOMOVE or SWP_NOZORDER or SWP_NOACTIVATE);\r\n end;}\r\nend;\r\n\r\nprocedure TJvIPAddress.ClearEditControls;\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := 0 to High(FEditControls) do\r\n if FEditControls[I] <> nil then\r\n FEditControls[I].Handle := 0;\r\n FEditControlCount := 0;\r\nend;\r\n\r\nprocedure TJvIPAddress.CMEnabledChanged(var Message: TMessage);\r\nbegin\r\n inherited;\r\n\r\n if not Enabled then\r\n begin\r\n Color := clBtnFace;\r\n Font.Color := clBtnShadow;\r\n end\r\n else\r\n begin\r\n Color := clWindow;\r\n Font.Color := clWindowText;\r\n end;\r\nend;\r\n\r\nprocedure TJvIPAddress.ColorChanged;\r\nbegin\r\n inherited ColorChanged;\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvIPAddress.FontChanged;\r\nbegin\r\n inherited FontChanged;\r\n AdjustHeight;\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvIPAddress.EnabledChanged;\r\nvar\r\n I: Integer;\r\nbegin\r\n inherited EnabledChanged;\r\n for I := 0 to High(FEditControls) do\r\n if (FEditControls[I] <> nil) and (FEditControls[I].Handle <> 0) then\r\n EnableWindow(FEditControls[I].Handle, Enabled and not (csDesigning in ComponentState));\r\nend;\r\n\r\nprocedure TJvIPAddress.PushAddressToWindows;\r\nbegin // expected to be single point for this for possible platform updates/ports\r\n if HandleAllocated then\r\n Perform(IPM_SETADDRESS, 0, FAddress.Address);\r\nend;\r\n\r\nprocedure TJvIPAddress.CNCommand(var Msg: TWMCommand);\r\nbegin\r\n with Msg do\r\n case NotifyCode of\r\n EN_CHANGE:\r\n if not FChanging then\r\n begin\r\n Perform(IPM_GETADDRESS, 0, LPARAM(@FAddress.Address));\r\n DoChange;\r\n end;\r\n EN_KILLFOCUS:\r\n begin\r\n FChanging := True;\r\n try\r\n if IsNotBlank then\r\n PushAddressToWindows;\r\n finally\r\n FChanging := False;\r\n end;\r\n end;\r\n EN_SETFOCUS:\r\n begin\r\n FFocusFromField := True;\r\n try\r\n // Mantis 2599: Send a WM_SETFOCUS to self so that the\r\n // OnEnter event (and the other control's OnExit) works.\r\n // We simply take the precaution to indicate it comes\r\n // from a field. See WMSetFocus for details\r\n Perform(WM_SETFOCUS, 0, 0);\r\n finally\r\n FFocusFromField := False;\r\n end;\r\n end;\r\n end;\r\n inherited;\r\nend;\r\n\r\nprocedure TJvIPAddress.WMSetFocus(var Msg: TWMSetFocus);\r\nbegin\r\n // if we receive the focus from a field, then it's because\r\n // of a mouse click. Thus we do nothing or it would prevent\r\n // the focus from being directly set to the field. Note that\r\n // doing this does not prevent OnFocus from running, which\r\n // is what we want.\r\n if not FFocusFromField then\r\n inherited;\r\nend;\r\n\r\nprocedure TJvIPAddress.CNNotify(var Msg: TWMNotify);\r\nbegin\r\n with Msg, NMHdr^ do\r\n if code = IPN_FIELDCHANGED then\r\n with PNMIPAddress(NMHdr)^ do\r\n DoFieldChange(iField, iValue);\r\n inherited;\r\nend;\r\n\r\nprocedure TJvIPAddress.DoAddressChange(Sender: TObject);\r\nbegin\r\n Address := FAddressValues.Address;\r\nend;\r\n\r\nprocedure TJvIPAddress.DoAddressChanging(Sender: TObject; Index: Integer; Value: Byte; var AllowChange: Boolean);\r\nbegin\r\n AllowChange := (Index > -1) and (Index < 4) and\r\n (Value >= FRange.FRange[Index].Min) and (Value <= FRange.FRange[Index].Max);\r\nend;\r\n\r\nprocedure TJvIPAddress.DoChange;\r\nbegin\r\n DataConnector.Modify;\r\n if Assigned(FOnChange) then\r\n FOnChange(Self);\r\nend;\r\n\r\nprocedure TJvIPAddress.DoFieldChange(FieldIndex: Integer; var FieldValue: Integer);\r\nbegin\r\n if Assigned(FOnFieldChange) then\r\n FOnFieldChange(Self, FieldIndex, FRange.FRange[FieldIndex], FieldValue);\r\nend;\r\n\r\nprocedure TJvIPAddress.DoNotSetRange(const Value: TJvIPAddressRange);\r\nbegin // do nothing, or maybe exception\r\nend;\r\n\r\nfunction TJvIPAddress.IsNotBlank: Boolean; // for DFM storage\r\nbegin\r\n Result := not IsBlank;\r\nend;\r\n\r\nfunction TJvIPAddress.IsBlank: Boolean;\r\nbegin\r\n if HandleAllocated then\r\n Result := SendMessage(Handle, IPM_ISBLANK, 0, 0) <> 0\r\n else\r\n Result := FSaveBlank;\r\nend;\r\n\r\nprocedure TJvIPAddress.ClearAddress;\r\nbegin\r\n if HandleAllocated then\r\n Perform(IPM_CLEARADDRESS, 0, 0);\r\n FSaveBlank := True;\r\nend;\r\n\r\nprocedure TJvIPAddress.SetBlank(const Value: boolean);\r\nbegin\r\n if Value <> IsBlank then\r\n begin\r\n FSaveBlank := Value;\r\n if Value then\r\n ClearAddress\r\n else\r\n PushAddressToWindows;\r\n end;\r\nend;\r\n\r\nfunction TJvIPAddress.CreateDataConnector: TJvIPAddressDataConnector;\r\nbegin\r\n Result := TJvIPAddressDataConnector.Create(Self);\r\nend;\r\n\r\nprocedure TJvIPAddress.SetDataConnector(const Value: TJvIPAddressDataConnector);\r\nbegin\r\n if Value <> FDataConnector then\r\n FDataConnector.Assign(Value);\r\nend;\r\n\r\nprocedure TJvIPAddress.DoExit;\r\nbegin\r\n DataConnector.UpdateRecord;\r\n inherited DoExit;\r\nend;\r\n\r\nprocedure TJvIPAddress.KeyPress(var Key: Char);\r\nbegin\r\n inherited KeyPress(Key);\r\n if (Key = #27) and DataConnector.Active then\r\n begin\r\n DataConnector.Reset;\r\n Key := #0;\r\n end;\r\nend;\r\n\r\nprocedure TJvIPAddress.SetAddress(const Value: LongWord);\r\nbegin\r\n if AddressIsBlank or (FAddress.Address <> Value) then\r\n begin\r\n FAddress.Address := Value;\r\n FSaveBlank := False;\r\n PushAddressToWindows;\r\n // on Windows re-querying result is not needed,\r\n // GDI will automatically send EN_Change notification after applying range\r\n end;\r\nend;\r\n\r\nprocedure TJvIPAddress.SetAddressValues(const Value: TJvIPAddressValues);\r\nbegin\r\n // (p3) do nothing\r\nend;\r\n\r\nprocedure TJvIPAddress.UpdateValuesFromString(S: string);\r\nbegin\r\n S := Trim(s);\r\n AddressValue[1] := StrToIntDef(StrToken(S, '.'), 0);\r\n AddressValue[2] := StrToIntDef(StrToken(S, '.'), 0);\r\n AddressValue[3] := StrToIntDef(StrToken(S, '.'), 0);\r\n AddressValue[4] := StrToIntDef(S, 0);\r\nend;\r\n\r\n{ Added 03/05/2004 by Kai Gossens }\r\n\r\nprocedure TJvIPAddress.WMCtlColorEdit(var Msg: TWMCtlColorEdit);\r\nvar\r\n DC: HDC;\r\nbegin\r\n inherited;\r\n DC := GetDC(Handle);\r\n try\r\n Brush.Color := ColorToRGB(Color);\r\n Brush.Style := bsSolid;\r\n SetTextColor(DC, ColorToRGB(Font.Color));\r\n SetBkColor(DC, ColorToRGB(Brush.Color));\r\n SetTextColor(Msg.ChildDC, ColorToRGB(Font.Color));\r\n SetBkColor(Msg.ChildDC, ColorToRGB(Brush.Color));\r\n finally\r\n ReleaseDC(Handle, DC);\r\n end;\r\n Msg.Result := Brush.Handle;\r\nend;\r\n\r\nprocedure TJvIPAddress.WMDestroy(var Msg: TWMNCDestroy);\r\nbegin\r\n DestroyLocalFont;\r\n inherited;\r\nend;\r\n\r\nfunction TJvIPAddress.GetAddressValue(Component: TJvIPAddressComponentIndex): Byte;\r\nbegin\r\n Result := FAddress.Comps[5-Component];\r\nend;\r\n\r\nprocedure TJvIPAddress.SetAddressValue(Component: TJvIPAddressComponentIndex;\r\n const Value: Byte);\r\nvar\r\n AllowChange: Boolean;\r\n Index: Integer;\r\nbegin\r\n if AddressValue[Component] <> Value then\r\n begin\r\n Component := 5 - Component; // reversing to intel byte order\r\n Index := Component - 1;\r\n AllowChange := (Component >= Low(Component)) and (Component <= High(Component)) and\r\n (Value >= FRange.FRange[Index].Min) and (Value <= FRange.FRange[Index].Max);\r\n\r\n if AllowChange then\r\n begin\r\n FAddress.Comps[Component] := Value;\r\n PushAddressToWindows;\r\n FSaveBlank := False;\r\n end;\r\n end;\r\nend;\r\n\r\n\r\nfunction TJvIPAddress.GetControlExtents: TRect;\r\nvar\r\n ClientRect: TRect;\r\n Extents: TRect;\r\nbegin\r\n if ControlCount = 0 then\r\n begin\r\n // to avoid resizing to zero size when setting AutoSize to True\r\n Result := GetClientRect;\r\n end\r\n else\r\n begin\r\n // If the control has children, then resize to the union of both possible rectangles\r\n Extents := inherited GetControlExtents;\r\n ClientRect := GetClientRect;\r\n UnionRect(Result, Extents, ClientRect);\r\n end;\r\nend;\r\n\r\nprocedure TJvIPAddress.GetDlgCode(var Code: TDlgCodes);\r\nbegin\r\n Include(Code, dcWantArrows);\r\n if FTabThroughFields then\r\n Include(Code, dcWantTab);\r\n Exclude(Code, dcNative); // prevent inherited call\r\nend;\r\n\r\nprocedure TJvIPAddress.WMSetText(var Msg: TWMSetText);\r\nbegin\r\n // Update the internal values from the message's text\r\n UpdateValuesFromString(Msg.Text);\r\n\r\n // really long values for the text crashes the program (try: 127.0.0.8787787878787878), so we limit it here before it is set\r\n Msg.Text := PChar(Format('%d.%d.%d.%d', [AddressValue[1], AddressValue[2], AddressValue[3], AddressValue[4]]));\r\n\r\n inherited;\r\nend;\r\n\r\nprocedure TJvIPAddress.WMGetText(var Msg: TWMGetText);\r\nbegin\r\n inherited;\r\n\r\n // Here, we are sure to have the text inside the Text member.\r\n // It has been retrieved by the intricate message handling of the windows\r\n // API, we simply use it to update the values of the AddressValues property\r\n // If we did not do this, then those values would not get updated as reported\r\n // in Mantis 2986.\r\n UpdateValuesFromString(Msg.Text);\r\nend;\r\n\r\nprocedure TJvIPAddress.WMParentNotify(var Msg: TWMParentNotify);\r\nbegin\r\n with Msg do\r\n case Event of\r\n WM_CREATE:\r\n if (FEditControlCount <= Length(FEditControls)) and\r\n (FEditControls[FEditControlCount] <> nil) then\r\n begin\r\n FEditControls[FEditControlCount].Handle := ChildWnd;\r\n EnableWindow(ChildWnd, Enabled and not (csDesigning in ComponentState));\r\n Inc(FEditControlCount);\r\n end;\r\n WM_DESTROY:\r\n ClearEditControls;\r\n // (p3) this code prevents the user from dblclicking on any edit field\r\n // to select it (the first edit is always selected). I don't know if removing\r\n // it has any side-effects but I haven't noticed anything\r\n// WM_LBUTTONDOWN, WM_MBUTTONDOWN, WM_RBUTTONDOWN:\r\n// Perform(Event, Value, LPARAM(SmallPoint(XPos, YPos)));\r\n end;\r\n inherited;\r\nend;\r\n\r\nprocedure TJvIPAddress.WMSetFont(var Msg: TWMSetFont);\r\nvar\r\n LF: TLogFont;\r\nbegin\r\n try\r\n OSCheck(GetObject(Font.Handle, SizeOf(LF), @LF) > 0);\r\n DestroyLocalFont;\r\n FLocalFont := CreateFontIndirect(LF);\r\n Msg.Font := FLocalFont;\r\n inherited;\r\n except\r\n Application.HandleException(Self);\r\n end;\r\nend;\r\n\r\n//=== { TJvTabControlPainter } ===============================================\r\n\r\ndestructor TJvTabControlPainter.Destroy;\r\nbegin\r\n if FClients <> nil then\r\n while FClients.Count > 0 do\r\n UnRegisterChange(TCustomTabControl(FClients.Last));\r\n FreeAndNil(FClients);\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvTabControlPainter.Change;\r\nvar\r\n I: Integer;\r\nbegin\r\n if FClients <> nil then\r\n for I := 0 to FClients.Count - 1 do\r\n TCustomTabControl(FClients[I]).Invalidate;\r\nend;\r\n\r\nprocedure TJvTabControlPainter.Notification(AComponent: TComponent;\r\n Operation: TOperation);\r\nbegin\r\n inherited Notification(AComponent, Operation);\r\n if (Operation = opRemove) and (AComponent is TCustomTabControl) and (FClients <> nil) then\r\n FClients.Remove(AComponent);\r\nend;\r\n\r\nprocedure TJvTabControlPainter.RegisterChange(AControl: TCustomTabControl);\r\nbegin\r\n if FClients = nil then\r\n FClients := TList.Create;\r\n if AControl <> nil then\r\n begin\r\n FClients.Add(AControl);\r\n AControl.FreeNotification(Self);\r\n AControl.Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvTabControlPainter.UnRegisterChange(AControl: TCustomTabControl);\r\nbegin\r\n if FClients <> nil then\r\n begin\r\n FClients.Remove(AControl);\r\n if (AControl <> nil) and not (csDestroying in AControl.ComponentState) then\r\n AControl.Invalidate;\r\n end;\r\nend;\r\n\r\n//=== { TJvTabDefaultPainter } ===============================================\r\n\r\nconstructor TJvTabDefaultPainter.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FActiveFont := TFont.Create;\r\n if Owner is TForm then\r\n FActiveFont.Assign(TForm(Owner).Font)\r\n else\r\n FActiveFont.Assign(Screen.IconFont);\r\n FActiveFont.Color := clHighlight;\r\n FActiveFont.OnChange := DoFontChange;\r\n FActiveColorFrom := clWhite;\r\n FActiveColorTo := clBtnFace;\r\n FActiveGradientDirection := fdTopToBottom;\r\n\r\n FDisabledFont := TFont.Create;\r\n if Owner is TForm then\r\n FDisabledFont.Assign(TForm(Owner).Font)\r\n else\r\n FDisabledFont.Assign(Screen.IconFont);\r\n FDisabledFont.Color := clGrayText;\r\n FDisabledFont.OnChange := DoFontChange;\r\n FDisabledColorFrom := clBtnFace;\r\n FDisabledColorTo := clBtnFace;\r\n FDisabledGradientDirection := fdTopToBottom;\r\n\r\n FInactiveFont := TFont.Create;\r\n if Owner is TForm then\r\n FInactiveFont.Assign(TForm(Owner).Font)\r\n else\r\n FInactiveFont.Assign(Screen.IconFont);\r\n FInactiveFont.OnChange := DoFontChange;\r\n FInactiveColorFrom := JvDefaultInactiveColorFrom;\r\n FInactiveColorTo := JvDefaultInactiveColorTo;\r\n FInactiveGradientDirection := fdTopToBottom;\r\n FGlyphLayout := blGlyphLeft;\r\nend;\r\n\r\ndestructor TJvTabDefaultPainter.Destroy;\r\nbegin\r\n FActiveFont.Free;\r\n FDisabledFont.Free;\r\n FInactiveFont.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvTabDefaultPainter.DoFontChange(Sender: TObject);\r\nbegin\r\n Change;\r\nend;\r\n\r\ntype\r\n TCustomTabControlAccess = class(TCustomTabControl)\r\n end;\r\n\r\nprocedure TJvTabDefaultPainter.DrawTab(AControl: TCustomTabControl;\r\n Canvas: TCanvas; Images: TCustomImageList; ImageIndex: Integer;\r\n const Caption: string; const Rect: TRect; Active, Enabled: Boolean);\r\nvar\r\n TextRect, ImageRect: TRect;\r\n SaveState: Integer;\r\n Bmp: TBitmap;\r\n DrawRect: TRect;\r\n Points: array [0..2] of TPoint;\r\n TextRectWidth: Integer;\r\n TextRectHeight: Integer;\r\n\r\n procedure DrawDivider(X, Y, X1, Y1: Integer);\r\n begin\r\n Canvas.Pen.Color := clBtnShadow;\r\n Canvas.MoveTo(X, Y);\r\n Canvas.LineTo(X1, Y1);\r\n Canvas.Pen.Color := clHighlightText;\r\n Canvas.MoveTo(X + 1, Y + 1);\r\n Canvas.LineTo(X1 + 1, Y1 + 1);\r\n end;\r\nbegin\r\n TextRect := Rect;\r\n ImageRect := Rect;\r\n if not Enabled then\r\n begin\r\n GradientFillRect(Canvas, TextRect, DisabledColorFrom, DisabledColorTo, DisabledGradientDirection, 255);\r\n Canvas.Font := DisabledFont;\r\n end\r\n else\r\n if Active then\r\n begin\r\n GradientFillRect(Canvas, TextRect, ActiveColorFrom, ActiveColorTo, ActiveGradientDirection, 255);\r\n Canvas.Font := ActiveFont;\r\n end\r\n else\r\n begin\r\n GradientFillRect(Canvas, TextRect, InactiveColorFrom, InactiveColorTo, InactiveGradientDirection, 255);\r\n Canvas.Font := InactiveFont;\r\n end;\r\n if Assigned(Images) and (ImageIndex >= 0) and (ImageIndex < Images.Count) then\r\n begin // GlyphLayout is only used if we have images\r\n case GlyphLayout of\r\n blGlyphLeft:\r\n begin\r\n Inc(ImageRect.Left, 4);\r\n ImageRect.Right := ImageRect.Left + Images.Width + 4;\r\n TextRect.Left := ImageRect.Right;\r\n end;\r\n blGlyphRight:\r\n begin\r\n Dec(ImageRect.Right, 4);\r\n ImageRect.Left := ImageRect.Right - Images.Width - 4;\r\n TextRect.Right := ImageRect.Left;\r\n end;\r\n blGlyphTop:\r\n begin\r\n Dec(ImageRect.Bottom, RectHeight(Rect) div 2);\r\n TextRect.Top := ImageRect.Bottom;\r\n if Divider and (Caption <> '') then\r\n DrawDivider(Rect.Left + 4 + Ord(Active), Rect.Top + RectHeight(Rect) div 2, Rect.Right - 4 - Ord(Active), Rect.Top + RectHeight(Rect) div 2);\r\n end;\r\n blGlyphBottom:\r\n begin\r\n Inc(ImageRect.Top, RectHeight(Rect) div 2);\r\n TextRect.Bottom := ImageRect.Top;\r\n if Divider and (Caption <> '') then\r\n DrawDivider(Rect.Left + 4 + Ord(Active), Rect.Top + RectHeight(Rect) div 2, Rect.Right - 4 - Ord(Active), Rect.Top + RectHeight(Rect) div 2);\r\n end;\r\n end;\r\n InflateRect(ImageRect, -(RectWidth(ImageRect) - Images.Width) div 2, -(RectHeight(ImageRect) - Images.Height) div 2);\r\n SaveState := SaveDC(Canvas.Handle);\r\n try\r\n Images.Draw(Canvas, ImageRect.Left, ImageRect.Top, ImageIndex,\r\n Enabled);\r\n finally\r\n RestoreDC(Canvas.Handle, SaveState);\r\n end;\r\n end;\r\n if Caption <> '' then\r\n begin\r\n if TCustomTabControlAccess(AControl).TabPosition in [tpTop, tpBottom] then\r\n begin\r\n SetBkMode(Canvas.Handle, TRANSPARENT);\r\n DrawText(Canvas, Caption, Length(Caption), TextRect, DT_SINGLELINE or DT_CENTER or DT_VCENTER);\r\n end\r\n else\r\n begin\r\n Bmp := TBitmap.Create;\r\n try\r\n TextRectWidth := TextRect.Right - TextRect.Left + 1;\r\n TextRectHeight := TextRect.Bottom - TextRect.Top + 1;\r\n\r\n Bmp.Transparent := True;\r\n Bmp.Canvas.Font := Canvas.Font;\r\n Bmp.Height := Max(TextRectWidth, TextRectHeight);\r\n Bmp.Width := Bmp.Height;\r\n\r\n DrawRect := Classes.Rect(0, 0, Bmp.Width, Bmp.Height);\r\n\r\n DrawText(Bmp.Canvas, Caption, Length(Caption), DrawRect, DT_SINGLELINE or DT_CENTER or DT_VCENTER);\r\n\r\n case TCustomTabControlAccess(AControl).TabPosition of\r\n tpLeft:\r\n begin\r\n // Rotate left by 90\r\n Points[0].X := 0;\r\n Points[0].Y := Bmp.Height - 1;\r\n Points[1].X := 0;\r\n Points[1].Y := 0;\r\n Points[2].X := Bmp.Width - 1;\r\n Points[2].Y := Bmp.Height - 1;\r\n end;\r\n tpRight:\r\n begin\r\n // Rotate right by 90\r\n Points[0].X := Bmp.Width - 1;\r\n Points[0].Y := 0;\r\n Points[1].X := Bmp.Width - 1;\r\n Points[1].Y := Bmp.Height - 1;\r\n Points[2].X := 0;\r\n Points[2].Y := 0;\r\n end;\r\n end;\r\n\r\n if TextRectWidth < TextRectHeight then\r\n begin\r\n Dec(Points[0].X, (Bmp.Width - TextRectWidth + 1) div 2);\r\n Dec(Points[1].X, (Bmp.Width - TextRectWidth + 1) div 2);\r\n Dec(Points[2].X, (Bmp.Width - TextRectWidth + 1) div 2);\r\n end\r\n else if TextRectWidth > TextRectHeight then\r\n begin\r\n Dec(Points[0].Y, (Bmp.Height - TextRectHeight + 1) div 2);\r\n Dec(Points[1].Y, (Bmp.Height - TextRectHeight + 1) div 2);\r\n Dec(Points[2].Y, (Bmp.Height - TextRectHeight + 1) div 2);\r\n end;\r\n\r\n // Rotate and translate to the right place\r\n PlgBlt(Bmp.Canvas.Handle, Points, Bmp.Canvas.Handle, 0, 0, Bmp.Width, Bmp.Height, 0, 0, 0);\r\n\r\n // Erase left overs\r\n Bmp.Canvas.FillRect(Classes.Rect(TextRectWidth, 0, Bmp.Width + 1, Bmp.Height));\r\n Bmp.Canvas.FillRect(Classes.Rect(0, TextRectHeight, Bmp.Width, Bmp.Height + 1));\r\n\r\n // Copy to the final canvas\r\n Canvas.Draw(TextRect.Left, TextRect.Top, Bmp);\r\n finally\r\n Bmp.Free;\r\n end;\r\n end;\r\n end;\r\n if Active and ShowFocus then\r\n begin\r\n TextRect := Rect;\r\n InflateRect(TextRect, -3, -3);\r\n Canvas.DrawFocusRect(TextRect);\r\n end;\r\nend;\r\n\r\nprocedure TJvTabDefaultPainter.SetActiveColorFrom(const Value: TColor);\r\nbegin\r\n if FActiveColorFrom <> Value then\r\n begin\r\n FActiveColorFrom := Value;\r\n Change;\r\n end;\r\nend;\r\n\r\nprocedure TJvTabDefaultPainter.SetActiveFont(const Value: TFont);\r\nbegin\r\n FActiveFont.Assign(Value);\r\nend;\r\n\r\nprocedure TJvTabDefaultPainter.SetActiveColorTo(const Value: TColor);\r\nbegin\r\n if FActiveColorTo <> Value then\r\n begin\r\n FActiveColorTo := Value;\r\n Change;\r\n end;\r\nend;\r\n\r\nprocedure TJvTabDefaultPainter.SetActiveGradientDirection(\r\n const Value: TFillDirection);\r\nbegin\r\n if FActiveGradientDirection <> Value then\r\n begin\r\n FActiveGradientDirection := Value;\r\n Change;\r\n end;\r\nend;\r\n\r\nprocedure TJvTabDefaultPainter.SetDisabledColorFrom(const Value: TColor);\r\nbegin\r\n if FDisabledColorFrom <> Value then\r\n begin\r\n FDisabledColorFrom := Value;\r\n Change;\r\n end;\r\nend;\r\n\r\nprocedure TJvTabDefaultPainter.SetDisabledColorTo(const Value: TColor);\r\nbegin\r\n if FDisabledColorTo <> Value then\r\n begin\r\n FDisabledColorTo := Value;\r\n Change;\r\n end;\r\nend;\r\n\r\nprocedure TJvTabDefaultPainter.SetDisabledFont(const Value: TFont);\r\nbegin\r\n FDisabledFont.Assign(Value);\r\nend;\r\n\r\nprocedure TJvTabDefaultPainter.SetDisabledGradientDirection(\r\n const Value: TFillDirection);\r\nbegin\r\n if FDisabledGradientDirection <> Value then\r\n begin\r\n FDisabledGradientDirection := Value;\r\n Change;\r\n end;\r\nend;\r\n\r\nprocedure TJvTabDefaultPainter.SetInactiveColorFrom(const Value: TColor);\r\nbegin\r\n if FInactiveColorFrom <> Value then\r\n begin\r\n FInactiveColorFrom := Value;\r\n Change;\r\n end;\r\nend;\r\n\r\nprocedure TJvTabDefaultPainter.SetInactiveColorTo(const Value: TColor);\r\nbegin\r\n if FInactiveColorTo <> Value then\r\n begin\r\n FInactiveColorTo := Value;\r\n Change;\r\n end;\r\nend;\r\n\r\nprocedure TJvTabDefaultPainter.SetInactiveFont(const Value: TFont);\r\nbegin\r\n FInactiveFont.Assign(Value);\r\nend;\r\n\r\nprocedure TJvTabDefaultPainter.SetInactiveGradientDirection(const Value: TFillDirection);\r\nbegin\r\n if FInactiveGradientDirection <> Value then\r\n begin\r\n FInactiveGradientDirection := Value;\r\n Change;\r\n end;\r\nend;\r\n\r\nfunction TJvTabDefaultPainter.IsActiveFontStored: Boolean;\r\nbegin\r\n Result := True;\r\nend;\r\n\r\nfunction TJvTabDefaultPainter.IsDisabledFontStored: Boolean;\r\nbegin\r\n Result := True;\r\nend;\r\n\r\nfunction TJvTabDefaultPainter.IsInactiveFontStored: Boolean;\r\nbegin\r\n Result := True;\r\nend;\r\n\r\nprocedure TJvTabDefaultPainter.SetGlyphLayout(const Value: TButtonLayout);\r\nbegin\r\n if FGlyphLayout <> Value then\r\n begin\r\n FGlyphLayout := Value;\r\n Change;\r\n end;\r\nend;\r\n\r\nprocedure TJvTabDefaultPainter.SetDivider(const Value: Boolean);\r\nbegin\r\n if FDivider <> Value then\r\n begin\r\n FDivider := Value;\r\n Change;\r\n end;\r\nend;\r\n\r\nprocedure TJvTabDefaultPainter.SetShowFocus(const Value: Boolean);\r\nbegin\r\n if FShowFocus <> Value then\r\n begin\r\n FShowFocus := Value;\r\n Change;\r\n end;\r\nend;\r\n\r\n//=== { TJvTabControl } ======================================================\r\n\r\nconstructor TJvTabControl.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\nend;\r\n\r\nprocedure TJvTabControl.CMDialogKey(var Msg: TWMKey);\r\nbegin\r\n if (Msg.CharCode = VK_TAB) and (GetKeyState(VK_CONTROL) < 0) and\r\n IsChild(Handle, Windows.GetFocus) then\r\n begin\r\n if GetKeyState(VK_SHIFT) < 0 then\r\n begin\r\n if TabIndex = 0 then\r\n TabIndex := Tabs.Count - 1\r\n else\r\n TabIndex := TabIndex - 1;\r\n end\r\n else\r\n TabIndex := (TabIndex + 1) mod Tabs.Count;\r\n Msg.Result := 1;\r\n end\r\n else\r\n inherited;\r\nend;\r\n\r\nprocedure TJvTabControl.WMRButtonDown(var Msg: TWMRButtonDown);\r\nvar\r\n I: Integer;\r\n R: TRect;\r\n P: TPoint;\r\nbegin\r\n if RightClickSelect then\r\n begin\r\n with Msg do\r\n P := SmallPointToPoint(SmallPoint(XPos,YPos));\r\n for I := 0 to Tabs.Count -1 do\r\n begin\r\n R := TabRect(I);\r\n if PtInRect(R, P) then\r\n begin\r\n if (TabIndex <> I) and CanChange then\r\n begin\r\n TabIndex := I;\r\n Change;\r\n end;\r\n Break;\r\n end;\r\n end;\r\n end;\r\n inherited;\r\nend;\r\n\r\nprocedure TJvTabControl.DrawTab(TabIndex: Integer; const Rect: TRect; Active: Boolean);\r\nbegin\r\n if Assigned(TabPainter) then\r\n TabPainter.DrawTab(Self, Canvas, Images, GetImageIndex(TabIndex), Tabs[TabIndex], Rect, TabIndex = Self.TabIndex, Enabled)\r\n else\r\n inherited DrawTab(TabIndex, Rect, Active);\r\nend;\r\n\r\nprocedure TJvTabControl.Notification(AComponent: TComponent;\r\n Operation: TOperation);\r\nbegin\r\n inherited Notification(AComponent, Operation);\r\n if (Operation = opRemove) and (AComponent = TabPainter) then\r\n TabPainter := nil;\r\nend;\r\n\r\nprocedure TJvTabControl.SetTabPainter(const Value: TJvTabControlPainter);\r\nbegin\r\n if FTabPainter <> Value then\r\n begin\r\n if FTabPainter <> nil then\r\n begin\r\n FTabPainter.RemoveFreeNotification(Self);\r\n FTabPainter.UnRegisterChange(Self);\r\n end;\r\n FTabPainter := Value;\r\n if FTabPainter <> nil then\r\n begin\r\n FTabPainter.FreeNotification(Self);\r\n FTabPainter.RegisterChange(Self);\r\n OwnerDraw := True;\r\n end\r\n else\r\n begin\r\n OwnerDraw := False;\r\n end;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\n//=== { TJvPageControl } =====================================================\r\n\r\nconstructor TJvPageControl.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FClientBorderWidth := JvDefPageControlBorder;\r\n FHintSource := hsDefault;\r\nend;\r\n\r\nfunction TJvPageControl.FormKeyPreview: Boolean;\r\nvar\r\n F: TCustomForm;\r\nbegin\r\n F := GetParentForm(Self);\r\n if F <> nil then\r\n Result := F.KeyPreview\r\n else\r\n Result := False;\r\nend;\r\n\r\nfunction TJvPageControl.WantKey(Key: Integer; Shift: TShiftState): Boolean;\r\nvar\r\n ThisTab, Tab: TTabSheet;\r\n Forwrd: Boolean;\r\nbegin\r\n Result := False;\r\n if HandleGlobalTab and not FormKeyPreview and\r\n (Key = VK_TAB) and (Shift * KeyboardShiftStates >= [ssCtrl]) then\r\n begin\r\n ThisTab := ActivePage;\r\n Forwrd := (Shift * KeyboardShiftStates >= [ssShift]);\r\n Tab := ThisTab;\r\n repeat\r\n Tab := FindNextPage(Tab, Forwrd, True);\r\n until (Tab = nil) or Tab.Enabled or (Tab = ThisTab);\r\n if Tab <> ThisTab then\r\n begin\r\n if CanChange then\r\n begin\r\n ActivePage := Tab;\r\n Result := True;\r\n Change;\r\n end;\r\n Exit;\r\n end;\r\n end;\r\n Result := inherited WantKey(Key, Shift);\r\nend;\r\n\r\nprocedure TJvPageControl.DrawTab(TabIndex: Integer; const Rect: TRect; Active: Boolean);\r\nvar\r\n I, RealIndex: Integer;\r\nbegin\r\n if TabPainter <> nil then\r\n begin\r\n RealIndex := 0;\r\n I := 0;\r\n while I <= TabIndex + RealIndex do\r\n begin\r\n if not Pages[I].TabVisible then\r\n Inc(RealIndex);\r\n Inc(I);\r\n end;\r\n RealIndex := RealIndex + TabIndex;\r\n if RealIndex < PageCount then\r\n TabPainter.DrawTab(Self, Canvas, Images, Pages[RealIndex].ImageIndex, Pages[RealIndex].Caption, Rect, Active, Pages[RealIndex].Enabled);\r\n end\r\n else\r\n inherited DrawTab(TabIndex, Rect, Active);\r\nend;\r\n\r\nprocedure TJvPageControl.Loaded;\r\nbegin\r\n inherited Loaded;\r\n HideAllTabs := FHideAllTabs;\r\nend;\r\n\r\nprocedure TJvPageControl.SetClientBorderWidth(const Value: TBorderWidth);\r\nbegin\r\n if FClientBorderWidth <> Value then\r\n begin\r\n FClientBorderWidth := Value;\r\n RecreateWnd;\r\n end;\r\nend;\r\n\r\nprocedure TJvPageControl.SetHideAllTabs(const Value: Boolean);\r\nvar\r\n I: Integer;\r\n SaveActivePage: TTabSheet;\r\nbegin\r\n FHideAllTabs := Value;\r\n if (csDesigning in ComponentState) then\r\n Exit;\r\n if HandleAllocated then\r\n begin\r\n SaveActivePage := ActivePage;\r\n for I := 0 to PageCount - 1 do\r\n Pages[I].TabVisible := Pages[I].TabVisible and not FHideAllTabs;\r\n ActivePage := SaveActivePage;\r\n if FHideAllTabs and (SaveActivePage <> nil) then\r\n SaveActivePage.TabStop := False;\r\n end;\r\nend;\r\n\r\nprocedure TJvPageControl.TCMAdjustRect(var Msg: TMessage);\r\nvar\r\n Offset: Integer;\r\nbegin\r\n inherited;\r\n if (Msg.WParam = 0) and (FClientBorderWidth <> JvDefPageControlBorder) then\r\n begin\r\n Offset := JvDefPageControlBorder - FClientBorderWidth;\r\n InflateRect(PRect(Msg.LParam)^, Offset, Offset);\r\n end;\r\nend;\r\n\r\nprocedure TJvPageControl.UpdateTabImages;\r\nbegin\r\n inherited UpdateTabImages;\r\nend;\r\n\r\nprocedure TJvPageControl.WMLButtonDown(var Msg: TWMLButtonDown);\r\nvar\r\n hi: TTCHitTestInfo;\r\n I, TabIndex, RealIndex: Integer;\r\nbegin\r\n if csDesigning in ComponentState then\r\n begin\r\n inherited;\r\n Exit;\r\n end;\r\n hi.pt.X := Msg.XPos;\r\n hi.pt.Y := Msg.YPos;\r\n hi.flags := 0;\r\n TabIndex := Perform(TCM_HITTEST, 0, LPARAM(@hi));\r\n I := 0;\r\n RealIndex := 0;\r\n while I <= TabIndex + RealIndex do\r\n begin\r\n if not Pages[I].TabVisible then\r\n Inc(RealIndex);\r\n Inc(I);\r\n end;\r\n RealIndex := RealIndex + TabIndex;\r\n if (RealIndex < PageCount) and (RealIndex >= 0) and ((hi.flags and TCHT_ONITEM) <> 0) then\r\n if not Pages[RealIndex].Enabled then\r\n begin\r\n Msg.Result := 0;\r\n Exit;\r\n end;\r\n inherited;\r\nend;\r\n\r\nprocedure TJvPageControl.WMRButtonDown(var Msg: TWMRButtonDown);\r\nvar\r\n I: Integer;\r\n R: TRect;\r\n P: TPoint;\r\nbegin\r\n if RightClickSelect then\r\n begin\r\n with Msg do\r\n P := SmallPointToPoint(SmallPoint(XPos, YPos));\r\n for I := 0 to PageCount -1 do\r\n begin\r\n R := TabRect(I);\r\n if PtInRect(R, P) then\r\n begin\r\n if (ActivePageIndex <> I) and CanChange then\r\n begin\r\n ActivePageIndex := I;\r\n Change;\r\n end;\r\n Break;\r\n end;\r\n end;\r\n end;\r\n inherited;\r\nend;\r\n\r\nfunction TJvPageControl.HintShow(var HintInfo: {$IFDEF RTL200_UP}Controls.{$ENDIF RTL200_UP}THintInfo): Boolean;\r\nvar\r\n TabNo: Integer;\r\n Tab: TTabSheet;\r\nbegin\r\n Result := inherited HintShow(HintInfo);\r\n\r\n if (FHintSource = hsDefault) or Result or (Self <> HintInfo.HintControl) then\r\n Exit;\r\n\r\n (*\r\n hsDefault, // use default hint behaviour (i.e as regular control)\r\n hsForceMain, // use the main controls hint even if subitems have hints\r\n hsForceChildren, // always use subitems hints even if empty and main control has hint\r\n hsPreferMain, // use main control hint unless empty then use subitems hints\r\n hsPreferChildren // use subitems hints unless empty then use main control hint\r\n );\r\n *)\r\n\r\n with HintInfo.CursorPos do\r\n TabNo := IndexOfTabAt(X, Y); // X&Y are expected in Client coordinates\r\n\r\n if (TabNo >= 0) and (TabNo < PageCount) then\r\n Tab := Pages[TabNo]\r\n else\r\n Tab := nil;\r\n if (FHintSource = hsForceMain) or ((FHintSource = hsPreferMain) and (GetShortHint(Hint) <> '')) then\r\n HintInfo.HintStr := GetShortHint(Self.Hint)\r\n else\r\n if (Tab <> nil) and\r\n ((FHintSource = hsForceChildren) or ((FHintSource = hsPreferChildren) and (GetShortHint(Tab.Hint) <> '')) or\r\n ((FHintSource = hsPreferMain) and (GetShortHint(Hint) = ''))) then\r\n begin\r\n HintInfo.HintStr := GetShortHint(Tab.Hint);\r\n HintInfo.CursorRect := TabRect(TabNo);\r\n end;\r\nend;\r\n\r\ntype\r\n TAccessTabSheet = class(TTabSheet);\r\n\r\nfunction TJvPageControl.CanChange: Boolean;\r\nbegin\r\n Result := inherited CanChange;\r\n if Result and (ActivePage <> nil) and ReduceMemoryUse then\r\n TAccessTabSheet(ActivePage).DestroyHandle;\r\nend;\r\n\r\nprocedure TJvPageControl.SetReduceMemoryUse(const Value: Boolean);\r\nbegin\r\n FReduceMemoryUse := Value;\r\nend;\r\n\r\nprocedure TJvPageControl.SetTabPainter(const Value: TJvTabControlPainter);\r\nbegin\r\n if FTabPainter <> Value then\r\n begin\r\n if FTabPainter <> nil then\r\n begin\r\n FTabPainter.RemoveFreeNotification(Self);\r\n FTabPainter.UnRegisterChange(Self);\r\n end;\r\n FTabPainter := Value;\r\n if FTabPainter <> nil then\r\n begin\r\n FTabPainter.FreeNotification(Self);\r\n FTabPainter.RegisterChange(Self);\r\n OwnerDraw := True;\r\n end\r\n else\r\n begin\r\n OwnerDraw := False;\r\n end;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvPageControl.Notification(AComponent: TComponent;\r\n Operation: TOperation);\r\nbegin\r\n inherited Notification(AComponent, Operation);\r\n if (Operation = opRemove) and (AComponent = TabPainter) then\r\n TabPainter := nil;\r\nend;\r\n\r\n//=== { TJvTrackBar } ========================================================\r\n\r\nconstructor TJvTrackBar.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n // ControlStyle := ControlStyle + [csAcceptsControls];\r\n FToolTipSide := tsLeft;\r\n FShowRange := True;\r\nend;\r\n\r\nprocedure TJvTrackBar.CNHScroll(var Msg: TWMHScroll);\r\nbegin\r\n if Msg.ScrollCode <> SB_ENDSCROLL then\r\n inherited;\r\nend;\r\n\r\nprocedure TJvTrackBar.CNVScroll(var Msg: TWMVScroll);\r\nbegin\r\n if Msg.ScrollCode <> SB_ENDSCROLL then\r\n inherited;\r\nend;\r\n\r\nprocedure TJvTrackBar.CreateParams(var Params: TCreateParams);\r\nbegin\r\n inherited CreateParams(Params);\r\n with Params do\r\n begin\r\n if FToolTips and (GetComCtlVersion >= ComCtlVersionIE3) then\r\n Style := Style or TBS_TOOLTIPS;\r\n // (p3) this stolen from Rudy Velthuis's ExTrackBar\r\n if not ShowRange then\r\n Style := Style and not TBS_ENABLESELRANGE;\r\n end;\r\nend;\r\n\r\nprocedure TJvTrackBar.CreateWnd;\r\nbegin\r\n inherited CreateWnd;\r\n InternalSetToolTipSide;\r\nend;\r\n\r\nprocedure TJvTrackBar.InternalSetToolTipSide;\r\nconst\r\n ToolTipSides: array [TJvTrackToolTipSide] of DWORD =\r\n (TBTS_LEFT, TBTS_TOP, TBTS_RIGHT, TBTS_BOTTOM);\r\nbegin\r\n if HandleAllocated and (GetComCtlVersion >= ComCtlVersionIE3) then\r\n SendMessage(Handle, TBM_SETTIPSIDE, ToolTipSides[FToolTipSide], 0);\r\nend;\r\n\r\nprocedure TJvTrackBar.MouseUp(Button: TMouseButton; Shift: TShiftState;\r\n X, Y: Integer);\r\nbegin\r\n inherited MouseUp(Button, Shift, X, Y);\r\n if Assigned(FOnChanged) then\r\n FOnChanged(Self);\r\nend;\r\n\r\nprocedure TJvTrackBar.SetShowRange(const Value: Boolean);\r\nbegin\r\n if FShowRange <> Value then\r\n begin\r\n FShowRange := Value;\r\n RecreateWnd;\r\n end;\r\nend;\r\n\r\nprocedure TJvTrackBar.SetToolTips(const Value: Boolean);\r\nbegin\r\n if FToolTips <> Value then\r\n begin\r\n FToolTips := Value;\r\n RecreateWnd;\r\n end;\r\nend;\r\n\r\nprocedure TJvTrackBar.SetToolTipSide(const Value: TJvTrackToolTipSide);\r\nbegin\r\n if FToolTipSide <> Value then\r\n begin\r\n FToolTipSide := Value;\r\n InternalSetToolTipSide;\r\n end;\r\nend;\r\n\r\nprocedure TJvTrackBar.WMNotify(var Msg: TWMNotify);\r\nvar\r\n ToolTipTextLocal: string;\r\nbegin\r\n if (Msg.NMHdr.code = TTN_NEEDTEXTW) and Assigned(FOnToolTip) then\r\n begin\r\n with PNMTTDispInfoW(Msg.NMHdr)^ do\r\n begin\r\n hinst := 0;\r\n ToolTipTextLocal := IntToStr(Position);\r\n FOnToolTip(Self, ToolTipTextLocal);\r\n FToolTipText := ToolTipTextLocal;\r\n lpszText := PWideChar(FToolTipText);\r\n FillChar(szText, SizeOf(szText), #0);\r\n Msg.Result := 1;\r\n end;\r\n end\r\n else\r\n inherited;\r\nend;\r\n\r\n//=== { TJvTreeNode } ========================================================\r\n\r\nclass function TJvTreeNode.CreateEnh(AOwner: TTreeNodes): TJvTreeNode;\r\nbegin\r\n Result := Create(AOwner);\r\n\r\n// (obones): There is no need to create a popup for every single node, it even\r\n// triggers Mantis 2582\r\n// Result.FPopupMenu := TPopupMenu.Create(AOwner.Owner);\r\nend;\r\n\r\nconstructor TJvTreeNode.Create(AOwner: TTreeNodes);\r\nbegin\r\n inherited Create(AOwner);\r\n\r\n FFont := nil;\r\n FBrush := nil;\r\nend;\r\n\r\ndestructor TJvTreeNode.Destroy;\r\nbegin\r\n FFont.Free;\r\n FBrush.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvTreeNode.DoCheckedChange;\r\nbegin\r\n if Assigned(OnCheckedChange) then\r\n OnCheckedChange(Self);\r\nend;\r\n\r\nprocedure TJvTreeNode.Assign(Source: TPersistent);\r\nbegin\r\n inherited Assign(Source);\r\n if Source is TJvTreeNode then\r\n begin\r\n Checked := TJvTreeNode(Source).Checked;\r\n Bold := TJvTreeNode(Source).Bold;\r\n PopupMenu := TJvTreeNode(Source).PopupMenu;\r\n Brush := TJvTreeNode(Source).Brush;\r\n Font := TJvTreeNode(Source).Font;\r\n end;\r\nend;\r\n\r\nprocedure TJvTreeNode.SetPopupMenu(const Value: TPopupMenu);\r\nbegin\r\n FPopupMenu := Value;\r\nend;\r\n\r\nprocedure TJvTreeNode.SetFont(const Value: TFont);\r\nbegin\r\n Font.Assign(Value);\r\nend;\r\n\r\nfunction TJvTreeNode.GetFont: TFont;\r\nbegin\r\n if not Assigned(FFont) then\r\n begin\r\n FFont := TFont.Create;\r\n if Assigned(Owner) and (TreeView is TJvExTreeView) then\r\n FFont.Assign(TJvExTreeView(TreeView).Font);\r\n end;\r\n Result := FFont;\r\nend;\r\n\r\nfunction TJvTreeNode.GetBrush: TBrush;\r\nbegin\r\n if not Assigned(FBrush) then\r\n begin\r\n FBrush := TBrush.Create;\r\n if Assigned(Owner) and (TreeView is TJvExTreeView) then\r\n FBrush.Assign(TJvExTreeView(TreeView).Brush);\r\n end;\r\n Result := FBrush;\r\nend;\r\n\r\nprocedure TJvTreeNode.SetBrush(const Value: TBrush);\r\nbegin\r\n Brush.Assign(Value);\r\nend;\r\n\r\nfunction TJvTreeNode.GetBold: Boolean;\r\nvar\r\n Item: TTVItem;\r\nbegin\r\n with Item do\r\n begin\r\n mask := TVIF_STATE;\r\n hItem := ItemId;\r\n if TreeView_GetItem(Handle, Item) then\r\n Result := ((Item.State and TVIS_BOLD) = TVIS_BOLD)\r\n else\r\n Result := False;\r\n end;\r\nend;\r\n\r\nfunction TJvTreeNode.GetChecked: Boolean;\r\nvar\r\n Item: TTVItem;\r\nbegin\r\n if Owner.Owner is TJvTreeView then\r\n begin\r\n Result := TJvTreeView(Owner.Owner).GetCheckedFromState(Self);\r\n end\r\n else\r\n begin\r\n with Item do\r\n begin\r\n mask := TVIF_STATE;\r\n hItem := ItemId;\r\n if TreeView_GetItem(Handle, Item) then\r\n Result := ((Item.State and TVIS_CHECKED) = TVIS_CHECKED)\r\n else\r\n Result := False;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvTreeNode.SetBold(const Value: Boolean);\r\nvar\r\n Item: TTVItem;\r\nbegin\r\n if Value <> FBold then\r\n begin\r\n FBold := Value;\r\n FillChar(Item, SizeOf(Item), 0);\r\n with Item do\r\n begin\r\n mask := TVIF_STATE;\r\n hItem := ItemId;\r\n StateMask := TVIS_BOLD;\r\n if Value then\r\n Item.State := TVIS_BOLD\r\n else\r\n Item.State := 0;\r\n TreeView_SetItem(Handle, Item);\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvTreeNode.SetChecked(Value: Boolean);\r\nvar\r\n Item: TTVItem;\r\nbegin\r\n if Value <> GetChecked then\r\n begin\r\n FChecked := Value;\r\n if Owner.Owner is TJvTreeView then\r\n begin\r\n TJvTreeView(Owner.Owner).SetCheckedInState(Self, FChecked);\r\n end\r\n else\r\n begin\r\n FillChar(Item, SizeOf(Item), 0);\r\n with Item do\r\n begin\r\n hItem := ItemId;\r\n mask := TVIF_STATE;\r\n StateMask := TVIS_STATEIMAGEMASK;\r\n if Value then\r\n Item.State := TVIS_CHECKED\r\n else\r\n Item.State := TVIS_CHECKED shr 1;\r\n TreeView_SetItem(Handle, Item);\r\n end;\r\n end;\r\n DoCheckedChange;\r\n end;\r\nend;\r\n\r\nprocedure TJvTreeNode.MoveTo(Destination: TTreeNode;\r\n Mode: TNodeAttachMode);\r\nvar\r\n SaveItem, Item: TTVItem;\r\nbegin\r\n // Mantis 3028: We need to save the state of he item as the\r\n // inherited MoveTo calls Assign on a newly created TVItem.\r\n // Hence, the state is reset and lost, putting Bold and Checked\r\n // to False. We could save those two properties, but it's better\r\n // to save the state, because we may have other properties inside\r\n // it in the future.\r\n FillChar(SaveItem, SizeOf(SaveItem), 0);\r\n SaveItem.hItem := ItemId;\r\n SaveItem.mask := TVIF_STATE;\r\n TreeView_GetItem(Handle, SaveItem);\r\n\r\n inherited MoveTo(Destination, Mode);\r\n\r\n FillChar(Item, SizeOf(Item), 0);\r\n Item.hItem := ItemId;\r\n Item.mask := TVIF_STATE;\r\n Item.stateMask := TVIS_STATEIMAGEMASK;\r\n Item.state := SaveItem.state;\r\n TreeView_SetItem(Handle, Item);\r\nend;\r\n\r\nprocedure TJvTreeNode.Reinitialize;\r\nbegin\r\n if FChecked <> GetChecked then\r\n begin\r\n FChecked := not FChecked;\r\n SetChecked(not FChecked);\r\n end;\r\nend;\r\n\r\n//=== { TJvTreeView } ========================================================\r\n\r\nconst\r\n AutoScrollMargin = 20;\r\n AutoScrollTimerID = 100;\r\n\r\nconstructor TJvTreeView.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FCheckBoxes := False;\r\n MultiSelectStyle := JvDefaultTreeViewMultiSelectStyle;\r\n FForceClickSelect := True; // to keep the backward compatibility as default\r\n\r\n // Since IsCustomDrawn method is not virtual we have to assign ancestor's\r\n // OnCustomDrawItem event to enable custom drawing\r\n if not (csDesigning in ComponentState) then\r\n inherited OnCustomDrawItem := InternalCustomDrawItem;\r\nend;\r\n\r\nprocedure TJvTreeView.Change(Node: TTreeNode);\r\nbegin\r\n inherited Change(Node);\r\n if not MenuDblClick and IsMenuItemClick(Node) then\r\n TMenuItem(Node.Data).OnClick(TMenuItem(Node.Data));\r\nend;\r\n\r\nfunction TJvTreeView.CreateNode: TTreeNode;\r\nbegin\r\n Result := TJvTreeNode.CreateEnh(Items);\r\n (Result as TJvTreeNode).OnCheckedChange := TreeNodeCheckedChange;\r\nend;\r\n\r\nprocedure TJvTreeView.CreateParams(var Params: TCreateParams);\r\nbegin\r\n inherited CreateParams(Params);\r\n\r\n // Mantis 3351: Recreating the window for adding the TVS_CHECKBOXES\r\n // parameter seems to trigger a bug in ComCtrl where it will show a\r\n // scroll bar that has nothing to do here. Setting the GWL_STYLE window\r\n // long shows the checkboxes and does not trigger this bug.\r\n {if FCheckBoxes then\r\n Params.Style := Params.Style or TVS_CHECKBOXES;}\r\nend;\r\n\r\nprocedure TJvTreeView.CreateWnd;\r\nvar\r\n I: Integer;\r\nbegin\r\n FReinitializeTreeNode := True;\r\n inherited CreateWnd;\r\n // Mantis 3351: Recreating the window for adding the TVS_CHECKBOXES\r\n // parameter seems to trigger a bug in ComCtrl where it will show a\r\n // scroll bar that has nothing to do here. Setting the GWL_STYLE window\r\n // long shows the checkboxes and does not trigger this bug.\r\n if FCheckBoxes then\r\n begin\r\n SetWindowLong(Handle, GWL_STYLE, GetWindowLong(Handle, GWL_STYLE) or TVS_CHECKBOXES);\r\n // After a recreate we must set our saved checked state\r\n if FRecreateCheckedState <> nil then\r\n begin\r\n for I := 0 to Min(Length(FRecreateCheckedState), Items.Count) - 1 do\r\n TJvTreeNode(Items[I]).FChecked := FRecreateCheckedState[I];\r\n FRecreateCheckedState := nil;\r\n end;\r\n // Mantis #4715. We must set the StateImages image list after changing TVS_CHECKBOXES\r\n // because changing TVS_CHECKBOXES disables the TVSIL_STATE imagelist.\r\n if (StateImages <> nil) and StateImages.HandleAllocated then\r\n TreeView_SetImageList(Handle, StateImages.Handle, TVSIL_STATE);\r\n end;\r\nend;\r\n\r\nprocedure TJvTreeView.DestroyWnd;\r\nvar\r\n I: Integer;\r\nbegin\r\n // update the FChecked field with the current data\r\n if not (csDestroying in ComponentState) then\r\n begin\r\n SetLength(FRecreateCheckedState, Items.Count);\r\n for I := 0 to Items.Count - 1 do\r\n begin\r\n TJvTreeNode(Items[I]).FChecked := TJvTreeNode(Items[I]).Checked;\r\n FRecreateCheckedState[I] := TJvTreeNode(Items[I]).FChecked;\r\n end;\r\n end;\r\n inherited DestroyWnd;\r\nend;\r\n\r\nprocedure TJvTreeView.DoEditCancelled;\r\nbegin\r\n if Assigned(FOnEditCancelled) then\r\n FOnEditCancelled(Self);\r\nend;\r\n\r\nprocedure TJvTreeView.DoEndDrag(Target: TObject; X, Y: Integer);\r\nbegin\r\n ScrollDirection := 0;\r\n inherited DoEndDrag(Target, X, Y);\r\nend;\r\n\r\nprocedure TJvTreeView.DoEnter;\r\nbegin\r\n InvalidateSelectedItems;\r\n inherited DoEnter;\r\nend;\r\n\r\nprocedure TJvTreeView.DoExit;\r\nbegin\r\n InvalidateSelectedItems;\r\n inherited DoExit;\r\nend;\r\n\r\nprocedure TJvTreeView.DoSelectionChange;\r\nbegin\r\n if Assigned(FOnSelectionChange) then\r\n FOnSelectionChange(Self);\r\nend;\r\n\r\nfunction TJvTreeView.DoSelectionChanging(OldNode, NewNode: TJvTreeNode; Cause: TJvNodeSelectCause): Boolean;\r\nbegin\r\n Result := True;\r\n if Assigned(FOnSelectionChanging) then\r\n FOnSelectionChanging(Self, OldNode, NewNode, Cause, Result);\r\nend;\r\n\r\nprocedure TJvTreeView.DragOver(Source: TObject; X, Y: Integer;\r\n State: TDragState; var Accept: Boolean);\r\nbegin\r\n inherited DragOver(Source, X, Y, State, Accept);\r\n if not FAutoDragScroll then\r\n Exit;\r\n if Y < AutoScrollMargin then\r\n ScrollDirection := -1\r\n else\r\n if Y > ClientHeight - AutoScrollMargin then\r\n ScrollDirection := 1\r\n else\r\n ScrollDirection := 0;\r\nend;\r\n\r\nprocedure TJvTreeView.Edit(const Item: TTVItem);\r\nbegin\r\n inherited Edit(Item);\r\n if Item.pszText = nil then\r\n DoEditCancelled;\r\nend;\r\n\r\nfunction TJvTreeView.GetBold(Node: TTreeNode): Boolean;\r\nbegin\r\n Result := TJvTreeNode(Node).Bold;\r\nend;\r\n\r\nfunction TJvTreeView.GetChecked(Node: TTreeNode): Boolean;\r\nbegin\r\n Result := TJvTreeNode(Node).Checked;\r\nend;\r\n\r\nfunction TJvTreeView.GetCheckedFromState(Node: TTreeNode): Boolean;\r\nvar\r\n Item: TTVItem;\r\nbegin\r\n with Item do\r\n begin\r\n mask := TVIF_STATE;\r\n hItem := Node.ItemId;\r\n if TreeView_GetItem(Handle, Item) then\r\n Result := ((Item.State and TVIS_CHECKED) = TVIS_CHECKED)\r\n else\r\n Result := False;\r\n end;\r\nend;\r\n\r\nfunction TJvTreeView.GetNodePopup(Node: TTreeNode): TPopupMenu;\r\nbegin\r\n Result := TJvTreeNode(Node).PopupMenu;\r\nend;\r\n\r\nfunction TJvTreeView.GetSelectedCount: Integer;\r\nbegin\r\n Result := SelectionCount;\r\nend;\r\n\r\nfunction TJvTreeView.GetSelectedItem(Index: Integer): TTreeNode;\r\nbegin\r\n Result := Selections[Index];\r\nend;\r\n\r\nfunction TJvTreeView.GetItemIndex: Integer;\r\nbegin\r\n Result := -1;\r\n if Assigned(Selected) and (Items.Count>0) then\r\n begin\r\n Result := 0;\r\n while (Result Selected) do\r\n Inc(Result);\r\n end;\r\nend;\r\n\r\nprocedure TJvTreeView.InternalCustomDrawItem(Sender: TCustomTreeView;\r\n Node: TTreeNode; State: TCustomDrawState; var DefaultDraw: Boolean);\r\nbegin\r\n if (State = []) or (State = [cdsDefault]) or (State = [cdsSelected]) then\r\n begin\r\n // Mantis #5450: If HideSelection is false the node is painted as it wouldn't be\r\n // selected because State = [].\r\n if not (not HideSelection and Node.Selected and not Focused) then\r\n begin\r\n Canvas.Font := TJvTreeNode(Node).Font;\r\n Canvas.Brush := TJvTreeNode(Node).Brush;\r\n end;\r\n end;\r\n if Assigned(FOnCustomDrawItem) then\r\n FOnCustomDrawItem(Self, Node, State, DefaultDraw);\r\nend;\r\n\r\nprocedure TJvTreeView.InvalidateNode(Node: TTreeNode);\r\nvar\r\n R: TRect;\r\nbegin\r\n if Assigned(Node) and Node.IsVisible then\r\n begin\r\n R := Node.DisplayRect(True);\r\n Windows.InvalidateRect(Handle, @R, False);\r\n end;\r\nend;\r\n\r\nprocedure TJvTreeView.InvalidateNodeIcon(Node: TTreeNode);\r\nvar\r\n R: TRect;\r\nbegin\r\n if Assigned(Node) and Assigned(Images) and Node.IsVisible then\r\n begin\r\n R := Node.DisplayRect(True);\r\n R.Right := R.Left;\r\n R.Left := R.Left - Images.Width * 3;\r\n Windows.InvalidateRect(Handle, @R, True);\r\n end;\r\nend;\r\n\r\nprocedure TJvTreeView.InvalidateSelectedItems;\r\nvar\r\n I: Integer;\r\nbegin\r\n if HandleAllocated then\r\n for I := 0 to SelectedCount - 1 do\r\n InvalidateNode(SelectedItems[I]);\r\nend;\r\n\r\nfunction TJvTreeView.IsNodeSelected(Node: TTreeNode): Boolean;\r\nbegin\r\n Result := (Node <> nil) and Node.Selected;\r\nend;\r\n\r\nprocedure TJvTreeView.KeyDown(var Key: Word; Shift: TShiftState);\r\nbegin\r\n if Checkboxes and NeedCheckStateEmulation() and (Key = VK_SPACE) then // emulate missing notify message\r\n PostCheckStateChanged(Selected);\r\n\r\n inherited KeyDown(Key, Shift);\r\n\r\n if ((Key = VK_SPACE) or (Key = VK_RETURN)) and MenuDblClick and IsMenuItemClick(Selected) then\r\n TMenuItem(Selected.Data).OnClick(TMenuItem(Selected.Data));\r\nend;\r\n\r\nprocedure TJvTreeView.KeyPress(var Key: Char);\r\nbegin\r\n if MultiSelect and (Key = ' ') and not IsEditing then\r\n Key := #0\r\n else\r\n inherited KeyPress(Key);\r\nend;\r\n\r\nprocedure TJvTreeView.SetItemIndex(const Value: Integer);\r\nbegin\r\n if Value = -1 then\r\n Selected := nil\r\n else\r\n Selected := Items[Value];\r\nend;\r\n\r\nprocedure TJvTreeView.SelectItem(Node: TTreeNode; Unselect: Boolean);\r\nbegin\r\n if Unselect then\r\n Deselect(Node)\r\n else\r\n Select(Node);\r\nend;\r\n\r\nprocedure TJvTreeView.SetBold(Node: TTreeNode; Value: Boolean);\r\nbegin\r\n TJvTreeNode(Node).Bold := Value;\r\nend;\r\n\r\nprocedure TJvTreeView.DoNodeCheckedChange(Node: TJvTreeNode);\r\nbegin\r\n if Assigned(OnNodeCheckedChange) then\r\n OnNodeCheckedChange(Self, Node);\r\nend;\r\n\r\nprocedure TJvTreeView.TreeNodeCheckedChange(Sender: TObject);\r\nbegin\r\n if not FCheckEventsDisabled then\r\n DoNodeCheckedChange(Sender as TJvTreeNode);\r\nend;\r\n\r\nprocedure TJvTreeView.SetCheckBoxes(const Value: Boolean);\r\nvar\r\n CurStyle: Integer;\r\nbegin\r\n if FCheckBoxes <> Value then\r\n begin\r\n FCheckBoxes := Value;\r\n if HandleAllocated then\r\n begin\r\n // Mantis 3351: Recreating the window for adding the TVS_CHECKBOXES\r\n // parameter seems to trigger a bug in ComCtrl where it will show a\r\n // scroll bar that has nothing to do here. Setting the GWL_STYLE window\r\n // long shows the checkboxes and does not trigger this bug.\r\n //RecreateWnd;\r\n HandleNeeded;\r\n CurStyle := GetWindowLong(Handle, GWL_STYLE);\r\n if FCheckBoxes then\r\n SetWindowLong(Handle, GWL_STYLE, CurStyle or TVS_CHECKBOXES)\r\n else\r\n SetWindowLong(Handle, GWL_STYLE, CurStyle and not TVS_CHECKBOXES);\r\n Invalidate;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvTreeView.SetChecked(Node: TTreeNode; Value: Boolean);\r\nbegin\r\n TJvTreeNode(Node).Checked := Value;\r\nend;\r\n\r\nprocedure TJvTreeView.SetCheckedInState(Node: TTreeNode; Value: Boolean);\r\nvar\r\n Item: TTVItem;\r\nbegin\r\n FillChar(Item, SizeOf(Item), 0);\r\n with Item do\r\n begin\r\n hItem := Node.ItemId;\r\n mask := TVIF_STATE;\r\n StateMask := TVIS_STATEIMAGEMASK;\r\n if Value then\r\n Item.State := TVIS_CHECKED\r\n else\r\n Item.State := TVIS_CHECKED shr 1;\r\n TreeView_SetItem(Handle, Item);\r\n end;\r\nend;\r\n\r\nprocedure TJvTreeView.SetNodePopup(Node: TTreeNode; Value: TPopupMenu);\r\nbegin\r\n TJvTreeNode(Node).PopupMenu := Value;\r\nend;\r\n\r\nprocedure TJvTreeView.SetScrollDirection(const Value: Integer);\r\nbegin\r\n if FScrollDirection <> Value then\r\n begin\r\n if Value = 0 then\r\n KillTimer(Handle, AutoScrollTimerID)\r\n else\r\n if (Value <> 0) and (FScrollDirection = 0) then\r\n SetTimer(Handle, AutoScrollTimerID, 200, nil);\r\n FScrollDirection := Value;\r\n end;\r\nend;\r\n\r\nprocedure TJvTreeView.WMHScroll(var Msg: TWMHScroll);\r\nbegin\r\n inherited;\r\n if Assigned(FOnHScroll) then\r\n FOnHScroll(Self);\r\nend;\r\n\r\nprocedure TJvTreeView.WMPaint(var Msg: TMessage);\r\nvar\r\n I: Integer;\r\nbegin\r\n inherited;\r\n { The tree node's checked property is reset at the first WM_PAINT.\r\n So we must set it here again, but only the first time. }\r\n if FReinitializeTreeNode then\r\n begin\r\n FReinitializeTreeNode := False;\r\n for I := 0 to Items.Count - 1 do\r\n TJvTreeNode(Items[I]).Reinitialize;\r\n end;\r\nend;\r\n\r\nprocedure TJvTreeView.CNNotify(var Msg: TWMNotify);\r\n{$IF not declared(NM_TVSTATEIMAGECHANGING)}\r\nconst\r\n NM_TVSTATEIMAGECHANGING = NM_FIRST - 24;\r\ntype\r\n { For IE >= 0x0600 }\r\n tagNMTVSTATEIMAGECHANGING = packed record\r\n hdr: NMHDR;\r\n hti: HTREEITEM;\r\n iOldStateImageIndex: Integer;\r\n iNewStateImageIndex: Integer;\r\n end;\r\n PNMTVStateImageChanging = ^TNMTVStateImageChanging;\r\n TNMTVStateImageChanging = tagNMTVSTATEIMAGECHANGING;\r\n{$IFEND}\r\nvar\r\n Node: TTreeNode;\r\n Point: TPoint;\r\n I, J: Integer;\r\nbegin\r\n inherited;\r\n if Windows.GetCursorPos(Point) then // prevent AV after \"computer locked\" dialog\r\n begin\r\n Point := ScreenToClient(Point);\r\n case Msg.NMHdr.code of\r\n NM_TVSTATEIMAGECHANGING: // ComCtrls 6+ and WinVer >= 6.0\r\n begin\r\n if CheckBoxes and not NeedCheckStateEmulation() then\r\n begin\r\n Node := Items.GetNode(PNMTVStateImageChanging(Msg.NMHdr).hti);\r\n PostCheckStateChanged(Node);\r\n end;\r\n end;\r\n NM_CLICK, NM_RCLICK:\r\n begin\r\n Node := GetNodeAt(Point.X, Point.Y);\r\n if Assigned(Node) and ForceClickSelect and not MultiSelect then\r\n Selected := Node;\r\n\r\n if (Node <> nil) and (Msg.NMHdr.code = NM_RCLICK) then\r\n if Assigned(TJvTreeNode(Node).PopupMenu) then // Popup menu may not be assigned\r\n TJvTreeNode(Node).PopupMenu.Popup(Mouse.CursorPos.X, Mouse.CursorPos.Y);\r\n\r\n if Checkboxes and NeedCheckStateEmulation() and (Node <> nil) and // emulate missing notify message\r\n (htOnStateIcon in GetHitTestInfoAt(Point.X, Point.Y)) then\r\n PostCheckStateChanged(Node);\r\n end;\r\n TVN_SELCHANGEDA, TVN_SELCHANGEDW:\r\n begin\r\n DoSelectionChange;\r\n\r\n if Assigned(FPageControl) then\r\n if Selected <> nil then\r\n begin\r\n //Search for the correct page\r\n J := -1;\r\n for I := 0 to FPageControl.PageCount - 1 do\r\n if DoComparePage(FPageControl.Pages[I], Selected) then\r\n J := I;\r\n if J <> -1 then\r\n begin\r\n FPageControl.ActivePage := FPageControl.Pages[J];\r\n if Assigned(FOnPage) then\r\n FOnPage(Self, Selected, FPageControl.Pages[J]);\r\n end;\r\n end;\r\n end;\r\n TVN_SELCHANGINGA, TVN_SELCHANGINGW:\r\n Msg.Result := Ord(not DoSelectionChanging(Items.GetNode(PNMTreeView(Msg.NMHdr).itemOld.hItem) as TJvTreeNode,\r\n Items.GetNode(PNMTreeView(Msg.NMHdr).itemNew.hItem) as TJvTreeNode,\r\n TJvNodeSelectCause(PNMTreeView(Msg.NMHdr).action)));\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvTreeView.WMCheckStateChanged(var Msg: TMessage);\r\nvar\r\n Node: TTreeNode;\r\nbegin\r\n Node := Items.GetNode(HTREEITEM(Msg.LParam));\r\n if Node <> nil then\r\n if WPARAM(Ord(TJvTreeNode(Node).Checked)) <> Msg.WParam then // do not trigger if nothing was changed\r\n TJvTreeNode(Node).DoCheckedChange;\r\nend;\r\n\r\nfunction TJvTreeView.DoComparePage(Page: TTabSheet; Node: TTreeNode): Boolean;\r\nbegin\r\n if Assigned(FOnComparePage) then\r\n FOnComparePage(Self, Page, Node, Result)\r\n else\r\n Result := AnsiSameText(Page.Caption, Node.Text);\r\nend;\r\n\r\nprocedure TJvTreeView.WMTimer(var Msg: TWMTimer);\r\nvar\r\n DragImages: TDragImageList;\r\nbegin\r\n if Msg.TimerID = AutoScrollTimerID then\r\n begin\r\n DragImages := GetDragImages;\r\n if Assigned(DragImages) then\r\n DragImages.HideDragImage;\r\n case FScrollDirection of\r\n -1:\r\n SendMessage(Handle, WM_VSCROLL, SB_LINEUP, 0);\r\n 1:\r\n SendMessage(Handle, WM_VSCROLL, SB_LINEDOWN, 0);\r\n end;\r\n if Assigned(DragImages) then\r\n DragImages.ShowDragImage;\r\n Msg.Result := 1;\r\n end\r\n else\r\n inherited;\r\nend;\r\n\r\nprocedure TJvTreeView.WMVScroll(var Msg: TWMVScroll);\r\nbegin\r\n inherited;\r\n if Assigned(FOnVScroll) then\r\n FOnVScroll(Self);\r\nend;\r\n\r\nfunction TJvTreeView.GetItemHeight: Integer;\r\nbegin\r\n if HandleAllocated then\r\n Result := SendMessage(Handle, TVM_GETITEMHEIGHT, 0, 0)\r\n else\r\n Result := 16;\r\nend;\r\n\r\nprocedure TJvTreeView.SetItemHeight(Value: Integer);\r\nbegin\r\n if Value <= 0 then\r\n Value := 16;\r\n if HandleAllocated then\r\n SendMessage(Handle, TVM_SETITEMHEIGHT, Value, 0);\r\nend;\r\n\r\nfunction TJvTreeView.GetInsertMarkColor: TColor;\r\nbegin\r\n if HandleAllocated then\r\n Result := SendMessage(Handle, TVM_GETINSERTMARKCOLOR, 0, 0)\r\n else\r\n Result := clDefault;\r\nend;\r\n\r\nprocedure TJvTreeView.SetInsertMarkColor(Value: TColor);\r\nbegin\r\n if HandleAllocated then\r\n begin\r\n if Value = clDefault then\r\n Value := Font.Color;\r\n SendMessage(Handle, TVM_SETINSERTMARKCOLOR, 0, ColorToRGB(Value));\r\n end;\r\nend;\r\n\r\nprocedure TJvTreeView.InsertMark(Node: TTreeNode; MarkAfter: Boolean);\r\nbegin\r\n if HandleAllocated then\r\n if Node = nil then\r\n RemoveMark\r\n else\r\n SendMessage(Handle, TVM_SETINSERTMARK, WPARAM(MarkAfter), LPARAM(Node.ItemId));\r\nend;\r\n\r\nprocedure TJvTreeView.RemoveMark;\r\nbegin\r\n if HandleAllocated then\r\n SendMessage(Handle, TVM_SETINSERTMARK, 0, 0);\r\nend;\r\n\r\nfunction TJvTreeView.GetLineColor: TColor;\r\nbegin\r\n if HandleAllocated then\r\n Result := SendMessage(Handle, TVM_GETLINECOLOR, 0, 0)\r\n else\r\n Result := clDefault;\r\nend;\r\n\r\n{$IFNDEF COMPILER15_UP} // Delphi XE fixed the OnAddition/OnDeletion bug\r\nprocedure TJvTreeView.Added(Node: TTreeNode);\r\nvar\r\n OrgOnAddition: TTVExpandedEvent;\r\nbegin\r\n OrgOnAddition := OnAddition;\r\n if CreateWndRestores and\r\n {$IFDEF COMPILER170_UP}\r\n (csRecreating in ControlState)\r\n {$ELSE}\r\n not (csDestroying in ComponentState)\r\n {$ENDIF}\r\n then\r\n OnAddition := nil;\r\n try\r\n inherited Added(Node);\r\n finally\r\n if Assigned(OrgOnAddition) then\r\n OnAddition := OrgOnAddition;\r\n end;\r\nend;\r\n\r\nprocedure TJvTreeView.Delete(Node: TTreeNode);\r\nvar\r\n OrgOnDeletion: TTVExpandedEvent;\r\nbegin\r\n OrgOnDeletion := OnDeletion;\r\n if CreateWndRestores and\r\n {$IFDEF COMPILER10_UP}\r\n (csRecreating in ControlState)\r\n {$ELSE}\r\n not (csDestroying in ComponentState)\r\n {$ENDIF}\r\n then\r\n OnDeletion := nil;\r\n try\r\n inherited Delete(Node);\r\n finally\r\n if Assigned(OrgOnDeletion) then\r\n OnDeletion := OrgOnDeletion;\r\n end;\r\nend;\r\n{$ENDIF ~COMPILER15_UP}\r\n\r\nprocedure TJvTreeView.Select(Node: TTreeNode; ShiftState: TShiftState);\r\nvar\r\n WasSelected: Boolean;\r\nbegin\r\n WasSelected := (Node <> nil) and Node.Selected;\r\n inherited Select(Node, ShiftState);\r\n if WasSelected <> ((Node <> nil) and Node.Selected) then\r\n DoSelectionChange; // trigger the missing OnSelectionChange event\r\nend;\r\n\r\nfunction TJvTreeView.MoveUp(AAbsoluteIndex: Integer; Focus: Boolean): Integer;\r\nvar\r\n lNode, lNode2: TTreeNode;\r\nbegin\r\n Result := AAbsoluteIndex;\r\n if (AAbsoluteIndex > 0) and (AAbsoluteIndex < Items.Count) then\r\n begin\r\n lNode := Items[AAbsoluteIndex];\r\n\r\n //if not lnode.IsFirstNode then // Delphi 7+\r\n if not (not lnode.Deleting and (lnode.Parent = nil) and (lnode.GetPrevSibling = nil)) then\r\n begin\r\n lNode2 := lNode.getPrevSibling;\r\n if lNode2 <> nil then\r\n lNode.MoveTo(lNode2, naInsert);\r\n end;\r\n if Focus then\r\n begin\r\n lNode.Selected := True;\r\n lNode.Focused := True;\r\n end;\r\n Result := lNode.AbsoluteIndex;\r\n end;\r\nend;\r\n\r\nprocedure TJvTreeView.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);\r\nvar\r\n Node: TTreeNode;\r\n SelCount: Cardinal;\r\nbegin\r\n if (Button = mbLeft) and MultiSelect then\r\n begin\r\n Node := GetNodeAt(X, Y);\r\n if (Node <> nil) and (htOnItem in GetHitTestInfoAt(X, Y)) then\r\n begin\r\n SelCount := SelectionCount;\r\n // The VCL doesn't do this but it's standard Windows behavior to select only the clicked\r\n // item if you click on it without pressing Ctrl/Shift.\r\n if (SelCount > 1) and (Node <> nil) and Node.Selected and ([ssShift, ssCtrl] * Shift = []) then\r\n ClearSelection(True);\r\n\r\n inherited MouseDown(Button, Shift, X, Y);\r\n if SelCount <> SelectionCount then\r\n DoSelectionChange; // trigger the missing OnSelectionChange event\r\n Exit;\r\n end;\r\n end;\r\n inherited MouseDown(Button, Shift, X, Y);\r\nend;\r\n\r\nfunction TJvTreeView.MoveDown(AAbsoluteIndex: Integer; Focus: Boolean): Integer;\r\nvar\r\n lNode, lNode2: TTreeNode;\r\nbegin\r\n Result := AAbsoluteIndex;\r\n if (AAbsoluteIndex >= 0) and (AAbsoluteIndex < Items.Count - 1) then\r\n begin\r\n lNode := Items[AAbsoluteIndex];\r\n\r\n if not (not lNode.Deleting and (lNode.Parent = nil) and (lNode.getNextSibling = nil)) then\r\n begin\r\n lNode2 := lNode.getNextSibling;\r\n if lNode2 <> nil then\r\n lNode2.MoveTo(lNode, naInsert);\r\n end;\r\n if Focus then\r\n begin\r\n lNode.Selected := True;\r\n lNode.Focused := True;\r\n end;\r\n Result := lNode.AbsoluteIndex;\r\n end;\r\nend;\r\n\r\nprocedure TJvTreeView.SetLineColor(Value: TColor);\r\nbegin\r\n if HandleAllocated then\r\n begin\r\n if Value = clDefault then\r\n Value := Font.Color;\r\n SendMessage(Handle, TVM_SETLINECOLOR, 0, ColorToRGB(Value));\r\n end;\r\nend;\r\n\r\nfunction TJvTreeView.GetMaxScrollTime: Integer;\r\nbegin\r\n if HandleAllocated then\r\n Result := SendMessage(Handle, TVM_GETSCROLLTIME, 0, 0)\r\n else\r\n Result := -1;\r\nend;\r\n\r\nprocedure TJvTreeView.SetMaxScrollTime(const Value: Integer);\r\nbegin\r\n if HandleAllocated then\r\n SendMessage(Handle, TVM_SETSCROLLTIME, Value, 0);\r\nend;\r\n\r\nfunction TJvTreeView.GetUseUnicode: Boolean;\r\nbegin\r\n if HandleAllocated then\r\n Result := Boolean(SendMessage(Handle, TVM_GETUNICODEFORMAT, 0, 0))\r\n else\r\n Result := False;\r\nend;\r\n\r\nprocedure TJvTreeView.SetUseUnicode(const Value: Boolean);\r\nbegin\r\n // only try to change value if not running on NT platform\r\n // (see MSDN: CCM_SETUNICODEFORMAT explanation for details)\r\n if HandleAllocated and (Win32Platform <> VER_PLATFORM_WIN32_NT) then\r\n SendMessage(Handle, TVM_SETUNICODEFORMAT, WPARAM(Value), 0);\r\nend;\r\n\r\ntype\r\n TMenuAccessProtected = class(TMenu);\r\n\r\nprocedure TJvTreeView.SetMenu(const Value: TMenu);\r\nbegin\r\n if FMenu <> Value then\r\n begin\r\n if (FMenu <> nil) then\r\n begin\r\n FMenu.RemoveFreeNotification(Self);\r\n if not (csDesigning in ComponentState) then\r\n TMenuAccessProtected(FMenu).OnChange := FOldMenuChange;\r\n end;\r\n FMenu := Value;\r\n if FMenu <> nil then\r\n begin\r\n FMenu.FreeNotification(Self);\r\n if not (csDesigning in ComponentState) then\r\n begin\r\n FOldMenuChange := TMenuAccessProtected(FMenu).OnChange;\r\n TMenuAccessProtected(FMenu).OnChange := DoMenuChange;\r\n end;\r\n end;\r\n RebuildFromMenu;\r\n end;\r\nend;\r\n\r\nprocedure TJvTreeView.DoMenuChange(Sender: TObject; Source: TMenuItem;\r\n Rebuild: Boolean);\r\nbegin\r\n if Assigned(FOldMenuChange) then\r\n FOldMenuChange(Sender, Source, Rebuild);\r\n RebuildFromMenu;\r\nend;\r\n\r\nprocedure TJvTreeView.RebuildFromMenu;\r\nvar\r\n I: Integer;\r\n\r\n procedure MakeSubMenu(AParent: TTreeNode; AMenuItem: TMenuItem);\r\n var\r\n I: Integer;\r\n ANode: TTreeNode;\r\n begin\r\n if (AMenuItem.Caption <> '-') and (AMenuItem.Caption <> '') then\r\n begin\r\n ANode := Items.AddChildObject(AParent, StripHotKey(AMenuItem.Caption), TObject(AMenuItem));\r\n ANode.ImageIndex := AMenuItem.ImageIndex;\r\n ANode.SelectedIndex := AMenuItem.ImageIndex;\r\n for I := 0 to AMenuItem.Count - 1 do\r\n MakeSubMenu(ANode, AMenuItem.Items[I]);\r\n end;\r\n end;\r\n\r\nbegin\r\n Items.BeginUpdate;\r\n try\r\n Items.Clear;\r\n if Menu <> nil then\r\n begin\r\n for I := 0 to Menu.Items.Count - 1 do\r\n MakeSubMenu(nil, Menu.Items[I]);\r\n end;\r\n finally\r\n Items.EndUpdate;\r\n end;\r\nend;\r\n\r\nprocedure TJvTreeView.Notification(AComponent: TComponent;\r\n Operation: TOperation);\r\nbegin\r\n inherited Notification(AComponent, Operation);\r\n if Operation = opRemove then\r\n begin\r\n if AComponent = FMenu then\r\n Menu := nil\r\n else\r\n if AComponent = FPageControl then\r\n PageControl := nil;\r\n end;\r\nend;\r\n\r\nprocedure TJvTreeView.PostCheckStateChanged(Node: TTreeNode);\r\nbegin\r\n if Node <> nil then\r\n PostMessage(Handle, WM_CHECKSTATECHANGED, Ord(TJvTreeNode(Node).Checked), LPARAM(Node.ItemId));\r\nend;\r\n\r\nprocedure TJvTreeView.DblClick;\r\nbegin\r\n inherited DblClick;\r\n if MenuDblClick and IsMenuItemClick(Selected) then\r\n TMenuItem(Selected.Data).OnClick(TMenuItem(Selected.Data));\r\nend;\r\n\r\nfunction TJvTreeView.IsMenuItemClick(Node: TTreeNode): Boolean;\r\nbegin\r\n Result := Assigned(Menu) and Assigned(Node) and Assigned(Node.Data) and\r\n (TObject(Node.Data) is TMenuItem) and Assigned(TMenuItem(Node.Data).OnClick);\r\nend;\r\n\r\nprocedure TJvTreeView.SetPageControl(const Value: TPageControl);\r\nbegin\r\n if FPageControl <> Value then\r\n begin\r\n if FPageControl <> nil then\r\n FPageControl.RemoveFreeNotification(Self);\r\n FPageControl := Value;\r\n if FPageControl <> nil then\r\n FPageControl.FreeNotification(Self);\r\n end;\r\nend;\r\n\r\n\r\n{ TJvIPAddressValues }\r\n\r\nprocedure TJvIPAddressValues.Change;\r\nbegin\r\n if Assigned(FOnChange) then\r\n FOnChange(Self);\r\nend;\r\n\r\nfunction TJvIPAddressValues.Changing(Index: Integer; Value: Byte): Boolean;\r\nbegin\r\n Result := True;\r\n if Assigned(FOnChanging) then\r\n FOnChanging(Self, Index, Value, Result);\r\nend;\r\n\r\nconstructor TJvIPAddressValues.Create(AOwner: TJvIpAddress);\r\nbegin\r\n inherited Create;\r\n\r\n FOwner := AOwner; \r\nend;\r\n\r\nfunction TJvIPAddressValues.GetAddress: Cardinal;\r\nbegin\r\n Result := FOwner.Address;\r\nend;\r\n\r\nfunction TJvIPAddressValues.GetValues(Index: Integer): Byte;\r\nbegin\r\n Result := FOwner.AddressValue[Index + 1];\r\nend;\r\n\r\nprocedure TJvIPAddressValues.SetAddress(const AValue: Cardinal);\r\nbegin\r\n FOwner.Address := AValue;\r\nend;\r\n\r\nprocedure TJvIPAddressValues.SetValues(Index: Integer; Value: Byte);\r\nbegin\r\n if Changing(Index, Value) then\r\n begin\r\n FOwner.AddressValue[Index + 1] := Value;\r\n Change;\r\n end;\r\nend;\r\n\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvComboListBox.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvComboListBox.PAS, released on 2003-10-07.\r\n\r\nThe Initial Developer of the Original Code is Peter Thornqvist \r\nPortions created by Sbastien Buysse are Copyright (C) 2003 Peter Thornqvist .\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\n dejoy(dejoy att ynl dott gov dott cn)\r\n tsoyran(tsoyran att otenet dott gr), Jan Verhoeven, Kyriakos Tasos,\r\n Andreas Hausladen .\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n\r\nDescription:\r\n A listbox that displays a combo box overlay on the selected item. Assign a\r\n TPopupMenu to the DropdownMenu property and it will be shown when the user clicks the\r\n combobox button.\r\n\r\nHistory:\r\n 2004-07-23: Added TJvCheckedComboBox.\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvComboListBox.pas 13138 2011-10-26 23:17:50Z jfudickar $\r\n\r\nunit JvComboListBox;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, Messages,\r\n Classes, Graphics, Controls, Forms, StdCtrls,\r\n JvListBox,\r\n Menus;\r\n\r\ntype\r\n // (p3) these types should *not* be moved to JvTypes (they are only used here)!\r\n TJvComboListBoxDrawStyle = (dsOriginal, dsStretch, dsProportional);\r\n TJvComboListDropDownEvent = procedure(Sender: TObject; Index: Integer;\r\n X, Y: Integer; var AllowDrop: Boolean) of object;\r\n TJvComboListDrawTextEvent = procedure(Sender: TObject; Index: Integer;\r\n const AText: string; R: TRect; var DefaultDraw: Boolean) of object;\r\n TJvComboListDrawImageEvent = procedure(Sender: TObject; Index: Integer;\r\n const APicture: TPicture; R: TRect; var DefaultDraw: Boolean) of object;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvComboListBox = class(TJvCustomListBox)\r\n private\r\n FMouseOver: Boolean;\r\n FPushed: Boolean;\r\n FDropdownMenu: TPopupMenu;\r\n FDrawStyle: TJvComboListBoxDrawStyle;\r\n FOnDrawImage: TJvComboListDrawImageEvent;\r\n FOnDrawText: TJvComboListDrawTextEvent;\r\n FButtonWidth: Integer;\r\n FHotTrackCombo: Boolean;\r\n FLastHotTrack: Integer;\r\n FOnDropDown: TJvComboListDropDownEvent;\r\n procedure SetDrawStyle(const Value: TJvComboListBoxDrawStyle);\r\n function DestRect(Picture: TPicture; ARect: TRect): TRect;\r\n function GetOffset(OrigRect, ImageRect: TRect): TRect;\r\n procedure SetButtonWidth(const Value: Integer);\r\n procedure SetDropdownMenu(const Value: TPopupMenu);\r\n procedure SetHotTrackCombo(const Value: Boolean);\r\n protected\r\n procedure InvalidateItem(Index: Integer);\r\n procedure DrawComboArrow(Canvas: TCanvas; R: TRect; Highlight, Pushed: Boolean);\r\n procedure DrawItem(Index: Integer; ARect: TRect; State: TOwnerDrawState); override;\r\n procedure Resize; override;\r\n procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;\r\n procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;\r\n procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;\r\n procedure MouseLeave(Control: TControl); override;\r\n procedure Notification(AComponent: TComponent; Operation: TOperation); override;\r\n function DoDrawImage(Index: Integer; APicture: TPicture; R: TRect): Boolean; virtual;\r\n function DoDrawText(Index: Integer; const AText: string; R: TRect): Boolean; virtual;\r\n function DoDropDown(Index, X, Y: Integer): Boolean; virtual;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n function AddText(const S: string): Integer;\r\n procedure InsertText(Index: Integer; const S: string);\r\n // helper functions: makes sure the internal TPicture object is created and freed as necessary\r\n function AddImage(P: TPicture): Integer;\r\n procedure InsertImage(Index: Integer; P: TPicture);\r\n procedure Delete(Index: Integer);\r\n published\r\n property ButtonWidth: Integer read FButtonWidth write SetButtonWidth default 20;\r\n property HotTrackCombo: Boolean read FHotTrackCombo write SetHotTrackCombo default False;\r\n property DropdownMenu: TPopupMenu read FDropdownMenu write SetDropdownMenu;\r\n property DrawStyle: TJvComboListBoxDrawStyle read FDrawStyle write SetDrawStyle default dsOriginal;\r\n property OnDrawText: TJvComboListDrawTextEvent read FOnDrawText write FOnDrawText;\r\n property OnDrawImage: TJvComboListDrawImageEvent read FOnDrawImage write FOnDrawImage;\r\n property OnDropDown: TJvComboListDropDownEvent read FOnDropDown write FOnDropDown;\r\n property Align;\r\n property Anchors;\r\n property BiDiMode;\r\n property DragCursor;\r\n property DragKind;\r\n property ImeMode;\r\n property ImeName;\r\n property IntegralHeight;\r\n property ParentBiDiMode;\r\n property OnEndDock;\r\n property OnStartDock;\r\n property HotTrack;\r\n property ScrollBars;\r\n property TabWidth;\r\n property OnGetText;\r\n property OnSelectCancel;\r\n property OnVerticalScroll;\r\n property OnHorizontalScroll;\r\n property BorderStyle;\r\n property Color;\r\n property Columns;\r\n property Constraints;\r\n property DragMode;\r\n property Enabled;\r\n property ExtendedSelect;\r\n property Font;\r\n property HintColor;\r\n property ItemHeight default 21;\r\n property ItemIndex default -1;\r\n property Items;\r\n property MultiSelect;\r\n property ParentColor;\r\n property ParentFont;\r\n property ParentShowHint;\r\n property PopupMenu;\r\n property ShowHint;\r\n property TabOrder;\r\n property TabStop;\r\n property Visible;\r\n property OnClick;\r\n property OnContextPopup;\r\n property OnDblClick;\r\n property OnDragDrop;\r\n property OnDragOver;\r\n property OnDrawItem;\r\n property OnEndDrag;\r\n property OnEnter;\r\n property OnExit;\r\n property OnKeyDown;\r\n property OnKeyPress;\r\n property OnKeyUp;\r\n property OnMeasureItem;\r\n property OnMouseDown;\r\n property OnMouseMove;\r\n property OnMouseUp;\r\n property OnStartDrag;\r\n property OnMouseEnter;\r\n property OnMouseLeave;\r\n property OnParentColorChange;\r\n// property OnChange; // not supported for listboxes\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvComboListBox.pas $';\r\n Revision: '$Revision: 13138 $';\r\n Date: '$Date: 2011-10-27 01:17:50 +0200 (jeu. 27 oct. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n Math, JvJVCLUtils;\r\n\r\nconstructor TJvComboListBox.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n Style := lbOwnerDrawFixed;\r\n ScrollBars := ssVertical;\r\n FDrawStyle := dsOriginal;\r\n FButtonWidth := 20;\r\n FLastHotTrack := -1;\r\n ItemHeight := 21;\r\n // ControlStyle := ControlStyle + [csCaptureMouse];\r\nend;\r\n\r\nfunction TJvComboListBox.AddImage(P: TPicture): Integer;\r\nbegin\r\n Result := Items.Count;\r\n InsertImage(Result, P);\r\nend;\r\n\r\nfunction TJvComboListBox.AddText(const S: string): Integer;\r\nbegin\r\n Result := Items.Add(S);\r\nend;\r\n\r\nprocedure TJvComboListBox.MouseLeave(Control: TControl);\r\nbegin\r\n if csDesigning in ComponentState then\r\n Exit;\r\n inherited MouseLeave(Control);\r\n if FMouseOver then\r\n begin\r\n InvalidateItem(ItemIndex);\r\n FMouseOver := False;\r\n end;\r\n if HotTrackCombo and (FLastHotTrack > -1) then\r\n begin\r\n InvalidateItem(FLastHotTrack);\r\n FLastHotTrack := -1;\r\n end;\r\nend;\r\n\r\nprocedure TJvComboListBox.Delete(Index: Integer);\r\nvar\r\n P: TPicture;\r\nbegin\r\n P := TPicture(Items.Objects[Index]);\r\n Items.Delete(Index);\r\n P.Free;\r\nend;\r\n\r\nfunction TJvComboListBox.DestRect(Picture: TPicture; ARect: TRect): TRect;\r\nvar\r\n W, H, CW, CH: Integer;\r\n XYAspect: Double;\r\n\r\nbegin\r\n W := Picture.Width;\r\n H := Picture.Height;\r\n CW := ARect.Right - ARect.Left;\r\n CH := ARect.Bottom - ARect.Top;\r\n if (DrawStyle = dsStretch) or ((DrawStyle = dsProportional) and ((W > CW) or (H > CH))) then\r\n begin\r\n if (DrawStyle = dsProportional) and (W > 0) and (H > 0) then\r\n begin\r\n XYAspect := W / H;\r\n if W > H then\r\n begin\r\n W := CW;\r\n H := Trunc(CW / XYAspect);\r\n if H > CH then // woops, too big\r\n begin\r\n H := CH;\r\n W := Trunc(CH * XYAspect);\r\n end;\r\n end\r\n else\r\n begin\r\n H := CH;\r\n W := Trunc(CH * XYAspect);\r\n if W > CW then // woops, too big\r\n begin\r\n W := CW;\r\n H := Trunc(CW / XYAspect);\r\n end;\r\n end;\r\n end\r\n else\r\n begin\r\n W := CW;\r\n H := CH;\r\n end;\r\n end;\r\n\r\n Result.Left := 0;\r\n Result.Top := 0;\r\n Result.Right := W;\r\n Result.Bottom := H;\r\n\r\n OffsetRect(Result, (CW - W) div 2, (CH - H) div 2);\r\nend;\r\n\r\nfunction TJvComboListBox.DoDrawImage(Index: Integer; APicture: TPicture; R: TRect): Boolean;\r\nbegin\r\n Result := True;\r\n if Assigned(FOnDrawImage) then\r\n FOnDrawImage(Self, Index, APicture, R, Result);\r\nend;\r\n\r\nfunction TJvComboListBox.DoDrawText(Index: Integer; const AText: string; R: TRect): Boolean;\r\nbegin\r\n Result := True;\r\n if Assigned(FOnDrawText) then\r\n FOnDrawText(Self, Index, AText, R, Result);\r\nend;\r\n\r\nfunction TJvComboListBox.DoDropDown(Index, X, Y: Integer): Boolean;\r\nbegin\r\n Result := True;\r\n if Assigned(FOnDropDown) then\r\n FOnDropDown(Self, Index, X, Y, Result);\r\nend;\r\n\r\nprocedure TJvComboListBox.DrawComboArrow(Canvas: TCanvas; R: TRect; Highlight, Pushed: Boolean);\r\nvar\r\n uState: Cardinal;\r\nbegin\r\n// Canvas.Font.Style := [];\r\n (*\r\n Canvas.Font.Name := 'Marlett';\r\n if ButtonWidth > Font.Size + 5 then\r\n Canvas.Font.Size := Font.Size + 3\r\n else\r\n Canvas.Font.Size := ButtonWidth;\r\n Canvas.Font.Color := clWindowText;\r\n S := 'u';\r\n SetBkMode(Canvas.Handle, Transparent);\r\n DrawText(Canvas.Handle, PChar(S), Length(S), R, DT_VCENTER or DT_CENTER or DT_SINGLELINE);\r\n *)\r\n uState := DFCS_SCROLLDOWN;\r\n if not Highlight then\r\n Inc(uState, DFCS_FLAT);\r\n if Pushed then\r\n Inc(uState, DFCS_PUSHED);\r\n DrawFrameControl(Canvas.Handle, R, DFC_SCROLL, uState or DFCS_ADJUSTRECT);\r\nend;\r\n\r\n\r\nprocedure TJvComboListBox.DrawItem(Index: Integer; ARect: TRect;\r\n State: TOwnerDrawState);\r\n\r\n\r\nvar\r\n P: TPicture;\r\n B: TBitmap;\r\n Points: array[0..4] of TPoint;\r\n TmpRect: TRect;\r\n Pt: TPoint;\r\n I: Integer;\r\n AText: string;\r\nbegin\r\n if (Index < 0) or (Index >= Items.Count) or Assigned(OnDrawItem) then\r\n Exit;\r\n Canvas.Lock;\r\n try\r\n Canvas.Font := Font;\r\n Canvas.Brush.Color := Self.Color;\r\n if State * [odSelected, odFocused] <> [] then\r\n begin\r\n Canvas.Brush.Color := clHighlight;\r\n Canvas.Font.Color := clHighlightText;\r\n end;\r\n\r\n if Items.Objects[Index] is TPicture then\r\n P := TPicture(Items.Objects[Index])\r\n else\r\n P := nil;\r\n if (P = nil) or (DrawStyle <> dsStretch) then\r\n Canvas.FillRect(ARect);\r\n if (P <> nil) and (P.Graphic <> nil) then\r\n begin\r\n TmpRect := Rect(0, 0, P.Graphic.Width, P.Graphic.Height);\r\n if DoDrawImage(Index, P, ARect) then\r\n begin\r\n case DrawStyle of\r\n dsOriginal:\r\n begin\r\n B := TBitmap.Create;\r\n try\r\n B.Assign(P.Bitmap);\r\n TmpRect := GetOffset(ARect, Rect(0, 0, B.Width, B.Height));\r\n B.Width := Min(B.Width,TmpRect.Right - TmpRect.Left);\r\n B.Height := Min(B.Height,TmpRect.Bottom - TmpRect.Top);\r\n Canvas.Draw(TmpRect.Left, TmpRect.Top, B);\r\n finally\r\n B.Free;\r\n end;\r\n end;\r\n dsStretch, dsProportional:\r\n begin\r\n TmpRect := DestRect(P, ARect);\r\n OffsetRect(TmpRect, ARect.Left, ARect.Top);\r\n Canvas.StretchDraw(TmpRect, P.Graphic);\r\n end;\r\n end;\r\n end;\r\n end\r\n else\r\n begin\r\n TmpRect := ARect;\r\n InflateRect(TmpRect, -2, -2);\r\n if DoDrawText(Index, Items[Index], TmpRect) then\r\n begin\r\n AText := Items[Index];\r\n DoGetText(Index, AText);\r\n DrawText(Canvas.Handle, PChar(AText), Length(AText),\r\n TmpRect, DT_WORDBREAK or DT_LEFT or DT_TOP or DT_EDITCONTROL or DT_NOPREFIX or DT_END_ELLIPSIS);\r\n end;\r\n end;\r\n\r\n // draw the combo button\r\n GetCursorPos(Pt);\r\n Pt := ScreenToClient(Pt);\r\n I := ItemAtPos(Pt, True);\r\n if (not HotTrackCombo and (State * [odSelected, odFocused] <> [])) or (HotTrackCombo and (I = Index)) then\r\n begin\r\n // draw frame\r\n Canvas.Brush.Style := bsClear;\r\n Canvas.Pen.Color := clHighlight;\r\n Canvas.Pen.Width := 1 + Ord(not HotTrackCombo);\r\n\r\n Points[0] := Point(ARect.Left, ARect.Top);\r\n Points[1] := Point(ARect.Right - 2, ARect.Top);\r\n Points[2] := Point(ARect.Right - 2, ARect.Bottom - 2);\r\n Points[3] := Point(ARect.Left, ARect.Bottom - 2);\r\n Points[4] := Point(ARect.Left, ARect.Top);\r\n Canvas.Polygon(Points);\r\n\r\n // draw button body\r\n if ButtonWidth > 2 then // 2 because Pen.Width is 2\r\n begin\r\n TmpRect := Rect(ARect.Right - ButtonWidth - 1,\r\n ARect.Top + 1, ARect.Right - 2 - Ord(FPushed), ARect.Bottom - 2 - Ord(FPushed));\r\n DrawComboArrow(Canvas, TmpRect, FMouseOver and Focused, FPushed);\r\n end;\r\n Canvas.Brush.Style := bsSolid;\r\n end\r\n else\r\n if odFocused in State then\r\n Canvas.DrawFocusRect(ARect);\r\n\r\n Canvas.Pen.Color := clBtnShadow;\r\n Canvas.Pen.Width := 1;\r\n Canvas.MoveTo(ARect.Left, ARect.Bottom - 1);\r\n Canvas.LineTo(ARect.Right, ARect.Bottom - 1);\r\n Canvas.MoveTo(ARect.Right - 1, ARect.Top);\r\n Canvas.LineTo(ARect.Right - 1, ARect.Bottom - 1);\r\n finally\r\n Canvas.Unlock;\r\n end;\r\nend;\r\n\r\n\r\n\r\nfunction TJvComboListBox.GetOffset(OrigRect, ImageRect: TRect): TRect;\r\nvar\r\n W, H, W2, H2: Integer;\r\nbegin\r\n Result := OrigRect;\r\n W := ImageRect.Right - ImageRect.Left;\r\n H := ImageRect.Bottom - ImageRect.Top;\r\n W2 := OrigRect.Right - OrigRect.Left;\r\n H2 := OrigRect.Bottom - OrigRect.Top;\r\n if W2 > W then\r\n OffsetRect(Result, (W2 - W) div 2, 0);\r\n if H2 > H then\r\n OffsetRect(Result, 0, (H2 - H) div 2);\r\nend;\r\n\r\nprocedure TJvComboListBox.InsertImage(Index: Integer; P: TPicture);\r\nvar\r\n P2: TPicture;\r\nbegin\r\n P2 := TPicture.Create;\r\n P2.Assign(P);\r\n Items.InsertObject(Index, '', P2);\r\nend;\r\n\r\nprocedure TJvComboListBox.InsertText(Index: Integer; const S: string);\r\nbegin\r\n Items.Insert(Index, S);\r\nend;\r\n\r\nprocedure TJvComboListBox.InvalidateItem(Index: Integer);\r\nvar\r\n R, R2: TRect;\r\nbegin\r\n if Index < 0 then\r\n Index := ItemIndex;\r\n R := ItemRect(Index);\r\n R2 := R;\r\n // we only want to redraw the combo button\r\n if not IsRectEmpty(R) then\r\n begin\r\n R.Right := R.Right - ButtonWidth;\r\n // don't redraw content, just button\r\n ExcludeClipRect(Canvas.Handle, R.Left, R.Top, R.Right, R.Bottom);\r\n Windows.InvalidateRect(Handle, @R2, False);\r\n end;\r\nend;\r\n\r\nprocedure TJvComboListBox.MouseDown(Button: TMouseButton; Shift: TShiftState;\r\n X, Y: Integer);\r\nvar\r\n I: Integer;\r\n R: TRect;\r\n P: TPoint;\r\n Msg: TMsg;\r\nbegin\r\n inherited MouseDown(Button, Shift, X, Y);\r\n if ItemIndex > -1 then\r\n begin\r\n P := Point(X, Y);\r\n I := ItemAtPos(P, True);\r\n R := ItemRect(I);\r\n if (I = ItemIndex) and (X >= R.Right - ButtonWidth) and (X <= R.Right) then\r\n begin\r\n FMouseOver := True;\r\n FPushed := True;\r\n InvalidateItem(I);\r\n if (DropdownMenu <> nil) and DoDropDown(I, X, Y) then\r\n begin\r\n case DropdownMenu.Alignment of\r\n paRight:\r\n P.X := R.Right;\r\n paLeft:\r\n P.X := R.Left;\r\n paCenter:\r\n P.X := R.Left + (R.Right - R.Left) div 2;\r\n end;\r\n P.Y := R.Top + ItemHeight;\r\n P := ClientToScreen(P);\r\n DropdownMenu.PopupComponent := Self;\r\n DropdownMenu.Popup(P.X, P.Y);\r\n // wait for popup to disappear\r\n while PeekMessage(Msg, 0, WM_MOUSEFIRST, WM_MOUSELAST, PM_REMOVE) do\r\n ;\r\n end;\r\n MouseUp(Button, Shift, X, Y);\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvComboListBox.MouseMove(Shift: TShiftState; X, Y: Integer);\r\nvar\r\n P: TPoint;\r\n I: Integer;\r\n R: TRect;\r\nbegin\r\n if (DropdownMenu <> nil) or HotTrackCombo then\r\n begin\r\n P := Point(X, Y);\r\n I := ItemAtPos(P, True);\r\n R := ItemRect(I);\r\n if HotTrackCombo and (I <> FLastHotTrack) then\r\n begin\r\n if FLastHotTrack > -1 then\r\n InvalidateItem(FLastHotTrack);\r\n FLastHotTrack := I;\r\n if FLastHotTrack > -1 then\r\n InvalidateItem(FLastHotTrack);\r\n end;\r\n if ((I = ItemIndex) or HotTrackCombo) and (X >= R.Right - ButtonWidth) and (X <= R.Right) then\r\n begin\r\n if not FMouseOver then\r\n begin\r\n FMouseOver := True;\r\n InvalidateItem(I);\r\n end;\r\n end\r\n else\r\n if FMouseOver then\r\n begin\r\n FMouseOver := False;\r\n InvalidateItem(I);\r\n end;\r\n end;\r\n inherited MouseMove(Shift, X, Y);\r\nend;\r\n\r\nprocedure TJvComboListBox.MouseUp(Button: TMouseButton; Shift: TShiftState;\r\n X, Y: Integer);\r\nbegin\r\n inherited MouseUp(Button, Shift, X, Y);\r\n if FPushed then\r\n begin\r\n FPushed := False;\r\n InvalidateItem(ItemIndex);\r\n end;\r\nend;\r\n\r\nprocedure TJvComboListBox.Notification(AComponent: TComponent;\r\n Operation: TOperation);\r\nbegin\r\n inherited Notification(AComponent, Operation);\r\n if (Operation = opRemove) and (AComponent = DropdownMenu) then\r\n DropdownMenu := nil;\r\nend;\r\n\r\nprocedure TJvComboListBox.SetButtonWidth(const Value: Integer);\r\nbegin\r\n if FButtonWidth <> Value then\r\n begin\r\n FButtonWidth := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvComboListBox.SetDrawStyle(const Value: TJvComboListBoxDrawStyle);\r\nbegin\r\n if FDrawStyle <> Value then\r\n begin\r\n FDrawStyle := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvComboListBox.SetHotTrackCombo(const Value: Boolean);\r\nbegin\r\n if FHotTrackCombo <> Value then\r\n begin\r\n FHotTrackCombo := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvComboListBox.Resize;\r\nbegin\r\n inherited Resize;\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvComboListBox.SetDropdownMenu(const Value: TPopupMenu);\r\nbegin\r\n ReplaceComponentReference(Self, Value, TComponent(FDropdownMenu));\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n\r\n" }, { "path": "External/Jedi/Jvcl/run/JvCombobox.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvCombobox.PAS, released on 2001-02-28.\r\n\r\nThe Initial Developer of the Original Code is Sbastien Buysse [sbuysse att buypin dott com]\r\nPortions created by Sbastien Buysse are Copyright (C) 2001 Sbastien Buysse.\r\nAll Rights Reserved.\r\n\r\nContributor(s): Michael Beck [mbeck att bigfoot dott com].\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvCombobox.pas 13415 2012-09-10 09:51:54Z obones $\r\n\r\nunit JvCombobox;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, Messages, Classes, Graphics, Controls, Forms, StdCtrls, Menus,\r\n JvCheckListBox, JvExStdCtrls, JvDataProvider, JvMaxPixel,\r\n JvToolEdit;\r\n\r\ntype\r\n TJvCustomComboBox = class;\r\n\r\n { This class will be used for the Items property of the combo box.\r\n\r\n If a provider is active at the combo box, this list will keep the strings stored in an internal\r\n list.\r\n\r\n Whenever an item is added to the list the provider will be deactivated and the list will be\r\n handled by the combo box as usual. }\r\n TJvComboBoxStrings = class(TCustomComboBoxStrings)\r\n private\r\n FInternalList: TStringList;\r\n FUseInternal: Boolean;\r\n FUpdating: Boolean;\r\n FDestroyCnt: Integer;\r\n function GetInternalList: TStrings;\r\n protected\r\n function Get(Index: Integer): string; override;\r\n function GetCount: Integer; override;\r\n function GetObject(Index: Integer): TObject; override;\r\n procedure PutObject(Index: Integer; AObject: TObject); override;\r\n procedure SetUpdateState(Updating: Boolean); override;\r\n procedure SetWndDestroying(Destroying: Boolean);\r\n function GetComboBox: TJvCustomComboBox;\r\n procedure SetComboBox(Value: TJvCustomComboBox);\r\n property ComboBox: TJvCustomComboBox read GetComboBox write SetComboBox;\r\n property InternalList: TStrings read GetInternalList;\r\n property UseInternal: Boolean read FUseInternal write FUseInternal;\r\n property Updating: Boolean read FUpdating;\r\n property DestroyCount: Integer read FDestroyCnt;\r\n public\r\n constructor Create; {$IFDEF RTL200_UP}override;{$ENDIF RTL200_UP}\r\n destructor Destroy; override;\r\n function Add(const S: string): Integer; override;\r\n procedure Clear; override;\r\n procedure Delete(Index: Integer); override;\r\n function IndexOf(const S: string): Integer; override;\r\n procedure Insert(Index: Integer; const S: string); override;\r\n procedure MakeListInternal; virtual;\r\n procedure ActivateInternal; virtual;\r\n end;\r\n\r\n TJvComboBoxStringsClass = class of TJvComboBoxStrings;\r\n\r\n TJvComboBoxMeasureStyle = (cmsStandard, cmsAfterCreate, cmsBeforeDraw);\r\n\r\n TJvCustomComboBox = class(TJvExCustomComboBox)\r\n private\r\n FMaxPixel: TJvMaxPixel;\r\n FReadOnly: Boolean;\r\n FConsumerSvc: TJvDataConsumer;\r\n FProviderToggle: Boolean;\r\n FProviderIsActive: Boolean;\r\n FIsFixedHeight: Boolean;\r\n FMeasureStyle: TJvComboBoxMeasureStyle;\r\n FLastSetItemHeight: Integer;\r\n FEmptyValue: string;\r\n FIsEmptyValue: Boolean;\r\n FEmptyFontColor: TColor;\r\n FOldFontColor: TColor;\r\n FDropDownWidth: Integer;\r\n procedure SetEmptyValue(const Value: string);\r\n procedure MaxPixelChanged(Sender: TObject);\r\n procedure SetReadOnly(const Value: Boolean);\r\n procedure ReadCtl3D(Reader: TReader);\r\n procedure ReadParentCtl3D(Reader: TReader);\r\n procedure CNCommand(var Msg: TWMCommand); message CN_COMMAND;\r\n procedure CNMeasureItem(var Msg: TWMMeasureItem); message CN_MEASUREITEM;\r\n procedure WMInitDialog(var Msg: TWMInitDialog); message WM_INITDIALOG;\r\n procedure WMLButtonDown(var Msg: TWMLButtonDown); message WM_LBUTTONDOWN;\r\n procedure WMLButtonDblClk(var Msg: TWMLButtonDblClk); message WM_LBUTTONDBLCLK;\r\n function GetFlat: Boolean;\r\n function GetParentFlat: Boolean;\r\n procedure SetFlat(const Value: Boolean);\r\n procedure SetParentFlat(const Value: Boolean);\r\n procedure SetDropDownWidth(Value: Integer);\r\n protected\r\n function IsItemHeightStored: Boolean; {$IFDEF COMPILER14_UP} override; {$ENDIF}\r\n function GetText: TCaption; virtual;\r\n procedure SetText(const Value: TCaption); reintroduce; virtual;\r\n procedure DoEnter; override;\r\n procedure DoExit; override;\r\n procedure DoEmptyValueEnter; virtual;\r\n procedure DoEmptyValueExit; virtual;\r\n procedure CreateWnd; override;\r\n function GetItemsClass: TCustomComboBoxStringsClass; override;\r\n procedure KeyPress(var Key: Char); override;\r\n procedure SetItemHeight(Value: Integer); override;\r\n function GetMeasureStyle: TJvComboBoxMeasureStyle;\r\n procedure SetMeasureStyle(Value: TJvComboBoxMeasureStyle);\r\n procedure PerformMeasure;\r\n procedure PerformMeasureItem(Index: Integer; var Height: Integer); virtual;\r\n procedure DrawItem(Index: Integer; Rect: TRect; State: TOwnerDrawState); override;\r\n procedure MeasureItem(Index: Integer; var Height: Integer); override;\r\n function IsProviderSelected: Boolean;\r\n procedure DeselectProvider;\r\n procedure UpdateItemCount;\r\n function HandleFindString(StartIndex: Integer; Value: string; ExactMatch: Boolean): Integer;\r\n procedure Loaded; override;\r\n procedure SetConsumerService(Value: TJvDataConsumer);\r\n procedure ConsumerServiceChanged(Sender: TJvDataConsumer; Reason: TJvDataConsumerChangeReason);\r\n procedure ConsumerSubServiceCreated(Sender: TJvDataConsumer; SubSvc: TJvDataConsumerAggregatedObject);\r\n property Provider: TJvDataConsumer read FConsumerSvc write SetConsumerService;\r\n property IsFixedHeight: Boolean read FIsFixedHeight;\r\n property MeasureStyle: TJvComboBoxMeasureStyle read GetMeasureStyle write SetMeasureStyle\r\n default cmsStandard;\r\n property MaxPixel: TJvMaxPixel read FMaxPixel write FMaxPixel;\r\n property ReadOnly: Boolean read FReadOnly write SetReadOnly default False;\r\n property Text: TCaption read GetText write SetText;\r\n property EmptyValue: string read FEmptyValue write SetEmptyValue;\r\n property EmptyFontColor: TColor read FEmptyFontColor write FEmptyFontColor default clGrayText;\r\n property Flat: Boolean read GetFlat write SetFlat default False;\r\n property ParentFlat: Boolean read GetParentFlat write SetParentFlat default True;\r\n property DropDownWidth: Integer read FDropDownWidth write SetDropDownWidth default 0;\r\n property ItemHeight stored IsItemHeightStored;\r\n\r\n procedure CreateParams(var Params: TCreateParams); override;\r\n procedure DestroyWnd; override;\r\n procedure WndProc(var Msg: TMessage); override;\r\n function GetItemCount: Integer; override; \r\n procedure DefineProperties(Filer: TFiler);override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n\r\n function GetItemText(Index: Integer): string; virtual;\r\n function SearchExactString(const Value: string; CaseSensitive: Boolean = True): Integer;\r\n function SearchPrefix(const Value: string; CaseSensitive: Boolean = True): Integer;\r\n function SearchSubString(const Value: string; CaseSensitive: Boolean = True): Integer;\r\n function DeleteExactString(const Value: string; All: Boolean; CaseSensitive: Boolean = True): Integer;\r\n end;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvComboBox = class(TJvCustomComboBox)\r\n published\r\n property Align;\r\n property HintColor;\r\n property MaxPixel;\r\n property AutoComplete default True;\r\n property AutoDropDown default False;\r\n property BevelEdges;\r\n property BevelInner;\r\n property BevelKind default bkNone;\r\n property BevelOuter;\r\n property Style; {Must be published before Items}\r\n property Anchors;\r\n property BiDiMode;\r\n property CharCase;\r\n property Color;\r\n property Constraints;\r\n property DragCursor;\r\n property DragKind;\r\n property DragMode;\r\n property DropDownCount;\r\n property Enabled;\r\n property EmptyValue;\r\n property EmptyFontColor;\r\n property Flat;\r\n property Font;\r\n property ImeMode;\r\n property ImeName;\r\n property ItemHeight;\r\n property MaxLength;\r\n property MeasureStyle;\r\n property ParentBiDiMode;\r\n property ParentColor;\r\n property ParentFlat;\r\n property ParentFont;\r\n property ParentShowHint;\r\n property Provider;\r\n property PopupMenu;\r\n property ReadOnly;\r\n property ShowHint;\r\n property Sorted;\r\n property TabOrder;\r\n property TabStop;\r\n property Text;\r\n property Visible;\r\n property OnChange;\r\n property OnClick;\r\n property OnCloseUp;\r\n property OnContextPopup;\r\n property OnDblClick;\r\n property OnDragDrop;\r\n property OnDragOver;\r\n property OnDrawItem;\r\n property OnDropDown;\r\n property OnEndDock;\r\n property OnEndDrag;\r\n property OnEnter;\r\n property OnExit;\r\n property OnKeyDown;\r\n property OnKeyPress;\r\n property OnKeyUp;\r\n property OnMeasureItem;\r\n property OnSelect;\r\n property OnStartDock;\r\n property OnStartDrag;\r\n property Items; { Must be published after OnMeasureItem }\r\n property ItemIndex default -1; { Must be published after Items (see Mantis 3512) }\r\n property DropDownWidth;\r\n property OnMouseEnter;\r\n property OnMouseLeave;\r\n property OnParentColorChange;\r\n end;\r\n\r\n TJvCHBQuoteStyle = (qsNone, qsSingle, qsDouble);\r\n\r\n TJvCustomCheckedComboBox = class(TJvCustomComboEdit)\r\n private\r\n FCapSelAll: string;\r\n FCapDeselAll: string;\r\n FCapInvertAll: string;\r\n FListBox: TJvCheckListBox;\r\n FSelectAll: TMenuItem;\r\n FDeselectAll: TMenuItem;\r\n FInvertAll: TMenuItem;\r\n FNoFocusColor: TColor;\r\n FSorted: Boolean;\r\n FQuoteStyle: TJvCHBQuoteStyle;\r\n FCheckedCount: Integer;\r\n FCheckedCountValid: Boolean;\r\n FColumns: Integer;\r\n FDropDownLines: Integer;\r\n FDelimiter: Char;\r\n FIgnoreChange: Boolean;\r\n FOrderedText: Boolean;\r\n FOrgListBoxWndProc: TWndMethod;\r\n FUpdateCheckedTextSent: Boolean;\r\n FKeepCheckedState: Boolean;\r\n procedure SetItems(AItems: TStrings);\r\n procedure ToggleOnOff(Sender: TObject);\r\n procedure KeyListBox(Sender: TObject; var Key: Word; Shift: TShiftState);\r\n procedure ContextListBox(Sender: TObject; MousePos: TPoint; var Handled: Boolean);\r\n procedure ListBoxWndProc(var Msg: TMessage);\r\n procedure ItemsChange;\r\n procedure SetSorted(Value: Boolean);\r\n procedure AdjustHeight;\r\n procedure SetNoFocusColor(Value: TColor);\r\n procedure SetColumns(Value: Integer);\r\n procedure SetChecked(Index: Integer; Checked: Boolean);\r\n procedure SetDropDownLines(Value: Integer);\r\n function GetChecked(Index: Integer): Boolean;\r\n function GetItemEnabled(Index: Integer): Boolean;\r\n procedure SetItemEnabled(Index: Integer; const Value: Boolean);\r\n function GetState(Index: Integer): TCheckBoxState;\r\n procedure SetState(Index: Integer; const Value: TCheckBoxState);\r\n procedure SetDelimiter(const Value: Char);\r\n function IsStoredCapDeselAll: Boolean;\r\n function IsStoredCapSelAll: Boolean;\r\n procedure ChangeText(const NewText: string);\r\n procedure SetOrderedText(const Value: Boolean);\r\n function GetOrderedTextValue: string;\r\n function GetItems: TStrings;\r\n function GetCheckedCount: Integer;\r\n protected\r\n procedure DoEnter; override;\r\n procedure DoExit; override;\r\n procedure AdjustSize; override;\r\n procedure CreatePopup; override;\r\n procedure Change; override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n procedure Clear; override;\r\n procedure SetUnCheckedAll(Sender: TObject = nil);\r\n procedure SetCheckedAll(Sender: TObject = nil);\r\n procedure SetInvertAll(Sender: TObject = nil);\r\n function IsChecked(Index: Integer): Boolean;\r\n function GetText: string;\r\n property Checked[Index: Integer]: Boolean read GetChecked write SetChecked;\r\n property CheckedCount: Integer read GetCheckedCount;\r\n property ItemEnabled[Index: Integer]: Boolean read GetItemEnabled write SetItemEnabled;\r\n property State[Index: Integer]: TCheckBoxState read GetState write SetState;\r\n\r\n property Items: TStrings read GetItems write SetItems;\r\n property CapSelectAll: string read FCapSelAll write FCapSelAll stored IsStoredCapSelAll;\r\n property CapDeSelectAll: string read FCapDeselAll write FCapDeselAll stored IsStoredCapDeselAll;\r\n property CapInvertAll: string read FCapInvertAll write FCapInvertAll;\r\n property NoFocusColor: TColor read FNoFocusColor write SetNoFocusColor;\r\n property Sorted: Boolean read FSorted write SetSorted default False;\r\n property QuoteStyle: TJvCHBQuoteStyle read FQuoteStyle write FQuoteStyle default qsNone;\r\n property Columns: Integer read FColumns write SetColumns default 0;\r\n property DropDownLines: Integer read FDropDownLines write SetDropDownLines default 6;\r\n property Delimiter: Char read FDelimiter write SetDelimiter default ',';\r\n property OrderedText: Boolean read FOrderedText write SetOrderedText default False;\r\n property KeepCheckedState: Boolean read FKeepCheckedState write FKeepCheckedState default False;\r\n end;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvCheckedComboBox = class(TJvCustomCheckedComboBox)\r\n published\r\n property Items;\r\n property CapSelectAll;\r\n property CapDeSelectAll;\r\n property CapInvertAll;\r\n property NoFocusColor default clWindow;\r\n property Sorted;\r\n property QuoteStyle;\r\n property Columns;\r\n property DropDownLines;\r\n property Delimiter;\r\n\r\n property Align;\r\n property HintColor;\r\n property BevelEdges;\r\n property BevelInner;\r\n property BevelKind default bkNone;\r\n property BevelOuter;\r\n property Anchors;\r\n property BiDiMode;\r\n property CharCase;\r\n property Color default clWindow;\r\n property Constraints;\r\n property Cursor;\r\n property DragCursor;\r\n property DragKind;\r\n property DragMode;\r\n property Enabled;\r\n property Flat;\r\n property Font;\r\n property ImeMode;\r\n property ImeName;\r\n property MaxLength;\r\n property ParentBiDiMode;\r\n property ParentColor;\r\n property ParentFlat;\r\n property ParentFont;\r\n property ParentShowHint;\r\n property PopupMenu;\r\n property ReadOnly default True;\r\n property ShowHint;\r\n property TabOrder;\r\n property TabStop;\r\n property Visible;\r\n property OnChange;\r\n property OnClick;\r\n property OnContextPopup;\r\n property OnDblClick;\r\n property OnDragDrop;\r\n property OnDragOver;\r\n property OnEndDock;\r\n property OnEndDrag;\r\n property OnEnter;\r\n property OnExit;\r\n property OnKeyDown;\r\n property OnKeyPress;\r\n property OnKeyUp;\r\n property OnResize;\r\n property OnStartDock;\r\n property OnStartDrag;\r\n property OnMouseEnter;\r\n property OnMouseLeave;\r\n property OnParentColorChange;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvCombobox.pas $';\r\n Revision: '$Revision: 13415 $';\r\n Date: '$Date: 2012-09-10 11:51:54 +0200 (lun. 10 sept. 2012) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n Types, SysUtils, Consts, RTLConsts, Variants,\r\n JvDataProviderIntf, JvItemsSearchs, JvConsts, JvResources;\r\n\r\nconst\r\n MinDropLines = 2;\r\n MaxDropLines = 50;\r\n WM_UPDATECHECKEDTEXT = WM_USER + 102;\r\n\r\ntype\r\n TJvPrivForm = class(TJvPopupWindow)\r\n protected\r\n function GetValue: Variant; override;\r\n procedure SetValue(const Value: Variant); override;\r\n end;\r\n\r\n\r\n//=== Local procedures =======================================================\r\n\r\n// examines if string (part) exist in string (source)\r\n// where source is in format part1[,part2]\r\n\r\nfunction PartExist(const Part, Source: string; Delimiter: Char): Boolean;\r\nvar\r\n M: Integer;\r\n Temp1, Temp2: string;\r\nbegin\r\n Temp1 := Source;\r\n Result := Part = Temp1;\r\n while not Result do\r\n begin\r\n M := Pos(Delimiter, Temp1);\r\n if M > 0 then\r\n Temp2 := Copy(Temp1, 1, M - 1)\r\n else\r\n Temp2 := Temp1;\r\n Result := Part = Temp2;\r\n if Result or (M = 0) then\r\n Break;\r\n Delete(Temp1, 1, M);\r\n end;\r\nend;\r\n\r\n// removes a string (part) from another string (source)\r\n// when source is in format part1[,part2]\r\n\r\nfunction RemovePart(const Part, Source: string; Delimiter: Char): string;\r\nvar\r\n Len, P: Integer;\r\n S1, S2: string;\r\nbegin\r\n Result := Source;\r\n S1 := Delimiter + Part + Delimiter;\r\n S2 := Delimiter + Source + Delimiter;\r\n P := Pos(S1, S2);\r\n if P > 0 then\r\n begin\r\n Len := Length(Part);\r\n if P = 1 then\r\n Result := Copy(Source, P + Len + 1, MaxInt)\r\n else\r\n begin\r\n Result := Copy(S2, 2, P - 1) + Copy(S2, P + Len + 2, MaxInt);\r\n SetLength(Result, Length(Result) - 1);\r\n end;\r\n end;\r\nend;\r\n\r\nfunction Add(const Sub: string; var Str: string; Delimiter: Char): Boolean;\r\nbegin\r\n Result := False;\r\n if Str = '' then\r\n begin\r\n Str := Sub;\r\n Result := True;\r\n end\r\n else\r\n if not PartExist(Sub, Str, Delimiter) then\r\n begin\r\n Str := Str + Delimiter + Sub;\r\n Result := True;\r\n end;\r\nend;\r\n\r\nfunction Remove(const Sub: string; var Str: string; Delimiter: Char): Boolean;\r\nvar\r\n Temp: string;\r\nbegin\r\n Result := False;\r\n if Str <> '' then\r\n begin\r\n Temp := RemovePart(Sub, Str, Delimiter);\r\n if Temp <> Str then\r\n begin\r\n Str := Temp;\r\n Result := True;\r\n end;\r\n end;\r\nend;\r\n\r\n// added 2000/04/08\r\n\r\nfunction GetFormattedText(Kind: TJvCHBQuoteStyle; const Str: string; Delimiter: Char): string;\r\nvar\r\n S: string;\r\nbegin\r\n Result := Str;\r\n if Str <> '' then\r\n begin\r\n S := Str;\r\n case Kind of\r\n qsSingle:\r\n Result := '''' + StringReplace(S, Delimiter, '''' + Delimiter + '''', [rfReplaceAll]) + '''';\r\n qsDouble:\r\n Result := '\"' + StringReplace(S, Delimiter, '\"' + Delimiter + '\"', [rfReplaceAll]) + '\"';\r\n end;\r\n end;\r\nend;\r\n\r\n//=== { TJvCustomCheckedComboBox } ===========================================\r\n\r\nconstructor TJvCustomCheckedComboBox.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FDropDownLines := 6;\r\n FDelimiter := ',';\r\n FColumns := 0;\r\n FQuoteStyle := qsNone;\r\n FCheckedCount := 0;\r\n FNoFocusColor := clWindow;\r\n Caption := '';\r\n FCapSelAll := RsCapSelAll;\r\n FCapDeselAll := RsCapDeselAll;\r\n FCapInvertAll := RsCapInvertAll;\r\n Height := 24;\r\n Width := 121;\r\n\r\n Color := clWindow;\r\n ReadOnly := True;\r\n\r\n ShowButton := True;\r\n ImageKind := ikDropDown;\r\n AlwaysEnableButton := True;\r\n AlwaysShowPopup := True;\r\n\r\n Text := '';\r\n\r\n // Create a form with its contents\r\n FPopup := TJvPrivForm.Create(Self);\r\n TJvPrivForm(FPopup).OnCloseUp := PopupCloseUp;\r\n TJvPrivForm(FPopup).FIsFocusable := True;\r\n\r\n // Create CheckListBox\r\n FListBox := TJvCheckListBox.Create(FPopup);\r\n FListBox.Parent := FPopup;\r\n FListBox.BorderStyle := bsNone;\r\n FListBox.Ctl3D := False;\r\n FListBox.Columns := FColumns;\r\n FListBox.Align := alClient;\r\n FListBox.OnClickCheck := ToggleOnOff;\r\n FListBox.OnKeyDown := KeyListBox;\r\n FListBox.OnContextPopup := ContextListBox;\r\n FOrgListBoxWndProc := FListBox.WindowProc;\r\n FListBox.WindowProc := ListBoxWndProc;\r\n TJvPrivForm(FPopup).FActiveControl := FListBox;\r\n\r\n // Create PopUp\r\n FListBox.PopupMenu := TPopupMenu.Create(FPopup);\r\n FSelectAll := TMenuItem.Create(FListBox.PopupMenu);\r\n FSelectAll.Caption := FCapSelAll;\r\n FSelectAll.OnClick := SetCheckedAll;\r\n FListBox.PopupMenu.Items.Insert(0, FSelectAll);\r\n FDeselectAll := TMenuItem.Create(FListBox.PopupMenu);\r\n FDeselectAll.Caption := FCapDeselAll;\r\n FDeselectAll.OnClick := SetUnCheckedAll;\r\n FListBox.PopupMenu.Items.Insert(1, FDeselectAll);\r\n\r\n FInvertAll := TMenuItem.Create(FListBox.PopupMenu);\r\n FInvertAll.Caption := FCapInvertAll;\r\n FInvertAll.OnClick := SetInvertAll;\r\n FListBox.PopupMenu.Items.Insert(2, FInvertAll);\r\nend;\r\n\r\ndestructor TJvCustomCheckedComboBox.Destroy;\r\nbegin\r\n FPopup.Free;\r\n FPopup := nil;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvCustomCheckedComboBox.AdjustHeight;\r\nvar\r\n DC: HDC;\r\n SaveFont: HFont;\r\n I: Integer;\r\n SysMetrics, Metrics: TTextMetric;\r\nbegin\r\n DC := GetDC(HWND_DESKTOP);\r\n GetTextMetrics(DC, SysMetrics);\r\n SaveFont := SelectObject(DC, Font.Handle);\r\n GetTextMetrics(DC, Metrics);\r\n SelectObject(DC, SaveFont);\r\n ReleaseDC(HWND_DESKTOP, DC);\r\n if Ctl3D then\r\n I := 8\r\n else\r\n I := 6;\r\n I := GetSystemMetrics(SM_CYBORDER) * I;\r\n Height := Metrics.tmHeight + I;\r\nend;\r\n\r\nprocedure TJvCustomCheckedComboBox.AdjustSize;\r\nbegin\r\n inherited AdjustSize;\r\n AdjustHeight;\r\nend;\r\n\r\nprocedure TJvCustomCheckedComboBox.Clear;\r\nbegin\r\n FListBox.Clear;\r\n inherited Clear;\r\nend;\r\n\r\nprocedure TJvCustomCheckedComboBox.ContextListBox(Sender: TObject;\r\n MousePos: TPoint; var Handled: Boolean);\r\nvar\r\n PopupMenu: TPopupMenu;\r\nbegin\r\n { We basically need this code because the standard Delphi code sends a\r\n SendCancelMode(nil) that will close the popup if the popup has not the focus.\r\n But this also gives us a change to position the popup when Shift + F10\r\n is used (Thus if InvalidPoint(MousePos) = true)\r\n }\r\n PopupMenu := FListBox.PopupMenu;\r\n if (PopupMenu <> nil) and PopupMenu.AutoPopup then\r\n begin\r\n SendCancelMode(FListBox);\r\n PopupMenu.PopupComponent := FListBox;\r\n if (MousePos.X = -1) and (MousePos.Y = -1) then // ahuser: InvalidPoint is not supported by Delphi 5\r\n with FListBox do\r\n if ItemIndex >= 0 then\r\n MousePos := Point(Width div 2, ItemHeight * (ItemIndex + 1))\r\n else\r\n MousePos := Point(Width div 2, Height div 2);\r\n\r\n MousePos := FListBox.ClientToScreen(MousePos);\r\n PopupMenu.Popup(MousePos.X, MousePos.Y);\r\n Handled := True;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomCheckedComboBox.CreatePopup;\r\nvar\r\n DisplayDropDownLines: Integer;\r\nbegin\r\n //Click;\r\n if fColumns > 1 then\r\n // determine the real lines needed if FColumns > 1\r\n DisplayDropDownLines := FListBox.Items.Count div FColumns + 1\r\n else\r\n // determine the real lines needed if FColumns = 1\r\n DisplayDropDownLines := FListBox.Items.Count + 1;\r\n\r\n if DisplayDropDownLines > FDropDownLines then\r\n // If the actual lines > value of property \"DropDownLines\", revert to property value\r\n DisplayDropDownLines := FDropDownLines;\r\n\r\n // adjust \"DisplayDropDownLines\" according to Min and Max values\r\n if DisplayDropDownLines < MinDropLines then\r\n DisplayDropDownLines := MinDropLines;\r\n if DisplayDropDownLines > MaxDropLines then\r\n DisplayDropDownLines := MaxDropLines;\r\n\r\n FSelectAll.Caption := FCapSelAll;\r\n FDeselectAll.Caption := FCapDeselAll;\r\n FInvertAll.Caption := FCapInvertAll;\r\n\r\n with TJvPrivForm(FPopup) do\r\n begin\r\n Font := Self.Font;\r\n Width := Self.Width;\r\n // use the current \"DisplayDropDownLines\" to determine height of window\r\n Height := (DisplayDropDownLines * FListBox.ItemHeight + 4 { FEdit.Height });\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomCheckedComboBox.Change;\r\nbegin\r\n if not FIgnoreChange then\r\n begin\r\n DoChange;\r\n FListBox.Refresh;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomCheckedComboBox.DoEnter;\r\nbegin\r\n Color := clWindow;\r\n inherited DoEnter;\r\nend;\r\n\r\nprocedure TJvCustomCheckedComboBox.DoExit;\r\nbegin\r\n Color := FNoFocusColor;\r\n inherited DoExit;\r\nend;\r\n\r\nfunction TJvCustomCheckedComboBox.GetChecked(Index: Integer): Boolean;\r\nbegin\r\n Result := FListBox.Checked[Index];\r\nend;\r\n\r\nfunction TJvCustomCheckedComboBox.GetItemEnabled(Index: Integer): Boolean;\r\nbegin\r\n Result := FListBox.ItemEnabled[Index];\r\nend;\r\n\r\nfunction TJvCustomCheckedComboBox.GetItems: TStrings;\r\nbegin\r\n Result := FListBox.Items;\r\nend;\r\n\r\nfunction TJvCustomCheckedComboBox.GetState(Index: Integer): TCheckBoxState;\r\nbegin\r\n Result := FListBox.State[Index];\r\nend;\r\n\r\nfunction TJvCustomCheckedComboBox.GetText: string;\r\nbegin\r\n if FQuoteStyle = qsNone then\r\n Result := Text\r\n else\r\n Result := GetFormattedText(FQuoteStyle, Text, Delimiter);\r\nend;\r\n\r\nfunction TJvCustomCheckedComboBox.GetOrderedTextValue: string;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := '';\r\n for I := 0 to FListBox.Count - 1 do\r\n begin\r\n if FListBox.Checked[I] then\r\n begin\r\n if Result <> '' then\r\n Result := Result + FDelimiter;\r\n Result := Result + FListBox.Items[I];\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJvCustomCheckedComboBox.IsChecked(Index: Integer): Boolean;\r\nbegin\r\n Result := FListBox.Checked[Index];\r\nend;\r\n\r\nfunction TJvCustomCheckedComboBox.IsStoredCapDeselAll: Boolean;\r\nbegin\r\n Result := FCapDeselAll <> RsCapSelAll;\r\nend;\r\n\r\nfunction TJvCustomCheckedComboBox.IsStoredCapSelAll: Boolean;\r\nbegin\r\n Result := FCapSelAll <> RsCapDeselAll;\r\nend;\r\n\r\nfunction TJvCustomCheckedComboBox.GetCheckedCount: Integer;\r\nvar\r\n I, Count: Integer;\r\nbegin\r\n if not FCheckedCountValid then\r\n begin\r\n FCheckedCountValid := True;\r\n Count := 0;\r\n for I := 0 to Items.Count - 1 do\r\n if Checked[I] then\r\n Inc(Count);\r\n FCheckedCount := Count;\r\n end;\r\n Result := FCheckedCount;\r\nend;\r\n\r\nprocedure TJvCustomCheckedComboBox.ItemsChange;\r\nbegin\r\n FCheckedCountValid := False;\r\n if KeepCheckedState then\r\n begin\r\n if not FUpdateCheckedTextSent then\r\n begin\r\n FUpdateCheckedTextSent := True;\r\n PostMessage(FListBox.Handle, WM_UPDATECHECKEDTEXT, 0, 0);\r\n end;\r\n end\r\n else\r\n begin // old behavior\r\n if FCheckedCount > 0 then\r\n SetUnCheckedAll\r\n else\r\n ChangeText('');\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomCheckedComboBox.ListBoxWndProc(var Msg: TMessage);\r\nbegin\r\n FOrgListBoxWndProc(Msg);\r\n case Msg.Msg of\r\n WM_PAINT, WM_UPDATECHECKEDTEXT:\r\n begin\r\n if FUpdateCheckedTextSent then\r\n begin\r\n FUpdateCheckedTextSent := False;\r\n ChangeText(GetOrderedTextValue);\r\n end;\r\n end;\r\n LB_ADDSTRING, LB_DELETESTRING, LB_INSERTSTRING, LB_RESETCONTENT:\r\n ItemsChange;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomCheckedComboBox.KeyListBox(Sender: TObject; var Key: Word;\r\n Shift: TShiftState);\r\nbegin\r\n if (Key = VK_ESCAPE) and (Shift * KeyboardShiftStates = []) then\r\n begin\r\n PopupCloseUp(Self, False);\r\n Key := 0;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomCheckedComboBox.SetChecked(Index: Integer; Checked: Boolean);\r\nvar\r\n S: string;\r\n ChangeData: Boolean;\r\n WasChecked: Boolean;\r\nbegin\r\n WasChecked := FListBox.Checked[Index]; // throws EListError if Index is invalid\r\n S := Text;\r\n ChangeData := False;\r\n if not WasChecked and Checked then\r\n begin\r\n if Add(FListBox.Items[Index], S, Delimiter) then\r\n ChangeData := True;\r\n end\r\n else\r\n if WasChecked and not Checked then\r\n if Remove(FListBox.Items[Index], S, Delimiter) then\r\n ChangeData := True;\r\n\r\n if WasChecked <> Checked then\r\n if Checked then\r\n FCheckedCount := FCheckedCount + 1\r\n else\r\n FCheckedCount := FCheckedCount - 1;\r\n\r\n if ChangeData then\r\n begin\r\n FListBox.Checked[Index] := Checked;\r\n ChangeText(S);\r\n end;\r\n\r\n if WasChecked <> Checked then\r\n Change;\r\nend;\r\n\r\nprocedure TJvCustomCheckedComboBox.SetCheckedAll(Sender: TObject);\r\nvar\r\n I: Integer;\r\n S: string;\r\nbegin\r\n S := '';\r\n for I := 0 to FListBox.Items.Count - 1 do\r\n begin\r\n if not FListBox.Checked[I] then\r\n FListBox.Checked[I] := True;\r\n\r\n if I = 0 then\r\n S := FListBox.Items[I]\r\n else\r\n S := S + Delimiter + FListBox.Items[I];\r\n end;\r\n ChangeText(S);\r\n FCheckedCount := FListBox.Items.Count;\r\n Repaint;\r\n Change;\r\nend;\r\n\r\nprocedure TJvCustomCheckedComboBox.SetInvertAll(Sender: TObject);\r\nvar\r\n I: Integer;\r\n S: string;\r\n NewCheckedCount: Integer;\r\nbegin\r\n S := '';\r\n NewCheckedCount := 0;\r\n for I := 0 to FListBox.Items.Count - 1 do\r\n begin\r\n FListBox.Checked[I] := not FListBox.Checked[I];\r\n\r\n if FListBox.Checked[I] then\r\n begin\r\n Inc(NewCheckedCount);\r\n\r\n if S = '' then \r\n S := FListBox.Items[I]\r\n else\r\n S := S + Delimiter + FListBox.Items[I];\r\n end;\r\n end;\r\n ChangeText(S);\r\n\r\n FCheckedCount := NewCheckedCount;\r\n Repaint;\r\n Change;\r\nend;\r\n\r\nprocedure TJvCustomCheckedComboBox.SetColumns(Value: Integer);\r\nbegin\r\n if FColumns <> Value then\r\n begin\r\n FColumns := Value;\r\n FListBox.Columns := FColumns;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomCheckedComboBox.SetDelimiter(const Value: Char);\r\nvar\r\n I: Integer;\r\n S: string;\r\nbegin\r\n if Value <> FDelimiter then\r\n begin\r\n FDelimiter := Value;\r\n Text := '';\r\n S := '';\r\n for I := 0 to FListBox.Items.Count - 1 do\r\n if FListBox.Checked[I] then\r\n if I = 0 then\r\n S := FListBox.Items[I]\r\n else\r\n S := S + Delimiter + FListBox.Items[I];\r\n ChangeText(S);\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomCheckedComboBox.SetDropDownLines(Value: Integer);\r\nbegin\r\n if FDropDownLines <> Value then\r\n if (Value >= MinDropLines) and (Value <= MaxDropLines) then\r\n FDropDownLines := Value;\r\nend;\r\n\r\nprocedure TJvCustomCheckedComboBox.SetItemEnabled(Index: Integer; const Value: Boolean);\r\nbegin\r\n FListBox.ItemEnabled[Index] := Value;\r\nend;\r\n\r\nprocedure TJvCustomCheckedComboBox.SetItems(AItems: TStrings);\r\nbegin\r\n FListBox.Items.Assign(AItems);\r\nend;\r\n\r\nprocedure TJvCustomCheckedComboBox.SetNoFocusColor(Value: TColor);\r\nbegin\r\n if FNoFocusColor <> Value then\r\n begin\r\n FNoFocusColor := Value;\r\n Color := Value;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomCheckedComboBox.SetOrderedText(const Value: Boolean);\r\nbegin\r\n if FOrderedText <> Value then\r\n begin\r\n FOrderedText := Value;\r\n\r\n if FOrderedText then\r\n ChangeText(GetOrderedTextValue);\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomCheckedComboBox.SetSorted(Value: Boolean);\r\nbegin\r\n if FSorted <> Value then\r\n begin\r\n FSorted := Value;\r\n FListBox.Sorted := FSorted;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomCheckedComboBox.SetState(Index: Integer; const Value: TCheckBoxState);\r\nbegin\r\n FListBox.State[Index] := Value;\r\nend;\r\n\r\nprocedure TJvCustomCheckedComboBox.SetUnCheckedAll(Sender: TObject);\r\nvar\r\n I: Integer;\r\nbegin\r\n FCheckedCount := 0;\r\n for I := 0 to FListBox.Items.Count - 1 do\r\n FListBox.Checked[I] := False;\r\n ChangeText('');\r\n Change;\r\nend;\r\n\r\nprocedure TJvCustomCheckedComboBox.ToggleOnOff(Sender: TObject);\r\nvar\r\n S: string;\r\nbegin\r\n if FListBox.ItemIndex = -1 then\r\n Exit;\r\n S := Text;\r\n if FListBox.Checked[FListBox.ItemIndex] then\r\n begin\r\n FCheckedCount := FCheckedCount + 1;\r\n if not PartExist(FListBox.Items[FListBox.ItemIndex], S, Delimiter) then\r\n begin\r\n if not OrderedText then\r\n Add(FListBox.Items[FListBox.ItemIndex], S, Delimiter)\r\n else\r\n S := GetOrderedTextValue;\r\n end;\r\n end\r\n else\r\n begin\r\n FCheckedCount := FCheckedCount - 1;\r\n Remove(FListBox.Items[FListBox.ItemIndex], S, Delimiter);\r\n end;\r\n ChangeText(S);\r\n Change;\r\nend;\r\n\r\nprocedure TJvCustomCheckedComboBox.ChangeText(const NewText: string);\r\nbegin\r\n FIgnoreChange := True;\r\n try\r\n Text := NewText;\r\n finally\r\n FIgnoreChange := False;\r\n end;\r\nend;\r\n\r\n//=== { TJvComboBoxStrings } =================================================\r\n\r\nconstructor TJvComboBoxStrings.Create;\r\nbegin\r\n inherited Create;\r\n FInternalList := TStringList.Create;\r\nend;\r\n\r\ndestructor TJvComboBoxStrings.Destroy;\r\nbegin\r\n FreeAndNil(FInternalList);\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvComboBoxStrings.ActivateInternal;\r\nvar\r\n S: string;\r\n Obj: TObject;\r\n Index: Integer;\r\nbegin\r\n SendMessage(ComboBox.Handle, WM_SETREDRAW, Ord(False), 0);\r\n try\r\n InternalList.BeginUpdate;\r\n try\r\n SendMessage(ComboBox.Handle, CB_RESETCONTENT, 0, 0);\r\n while InternalList.Count > 0 do\r\n begin\r\n S := InternalList[0];\r\n Obj := InternalList.Objects[0];\r\n Index := SendMessage(ComboBox.Handle, CB_ADDSTRING, 0, LPARAM(PChar(S)));\r\n if Index < 0 then\r\n raise EOutOfResources.CreateRes(@SInsertLineError);\r\n SendMessage(ComboBox.Handle, CB_SETITEMDATA, Index, LPARAM(Obj));\r\n InternalList.Delete(0);\r\n end;\r\n finally\r\n InternalList.EndUpdate;\r\n end;\r\n finally\r\n if not Updating then\r\n SendMessage(ComboBox.Handle, WM_SETREDRAW, Ord(True), 0);\r\n UseInternal := False;\r\n end;\r\nend;\r\n\r\nfunction TJvComboBoxStrings.Add(const S: string): Integer;\r\nbegin\r\n if (csLoading in ComboBox.ComponentState) and UseInternal then\r\n Result := InternalList.Add(S)\r\n else\r\n begin\r\n ComboBox.DeselectProvider;\r\n Result := SendMessage(ComboBox.Handle, CB_ADDSTRING, 0, LPARAM(PChar(S)));\r\n if Result < 0 then\r\n raise EOutOfResources.CreateRes(@SInsertLineError);\r\n end;\r\nend;\r\n\r\nprocedure TJvComboBoxStrings.Clear;\r\nvar\r\n S: string;\r\nbegin\r\n if (FDestroyCnt <> 0) and UseInternal then\r\n Exit;\r\n if (csLoading in ComboBox.ComponentState) and UseInternal then\r\n InternalList.Clear\r\n else\r\n begin\r\n S := ComboBox.Text;\r\n ComboBox.DeselectProvider;\r\n SendMessage(ComboBox.Handle, CB_RESETCONTENT, 0, 0);\r\n ComboBox.Text := S;\r\n ComboBox.Update;\r\n end;\r\nend;\r\n\r\nprocedure TJvComboBoxStrings.Delete(Index: Integer);\r\nbegin\r\n if (csLoading in ComboBox.ComponentState) and UseInternal then\r\n InternalList.Delete(Index)\r\n else\r\n begin\r\n ComboBox.DeselectProvider;\r\n SendMessage(ComboBox.Handle, CB_DELETESTRING, Index, 0);\r\n end;\r\nend;\r\n\r\nfunction TJvComboBoxStrings.Get(Index: Integer): string;\r\nvar\r\n Text: array [0..4095] of Char;\r\n Len: Integer;\r\nbegin\r\n if UseInternal then\r\n Result := InternalList[Index]\r\n else\r\n begin\r\n Len := SendMessage(ComboBox.Handle, CB_GETLBTEXT, Index, LPARAM(@Text));\r\n if Len = CB_ERR then //Len := 0;\r\n Error(SListIndexError, Index);\r\n SetString(Result, Text, Len);\r\n end;\r\nend;\r\n\r\nfunction TJvComboBoxStrings.GetComboBox: TJvCustomComboBox;\r\nbegin\r\n Result := TJvCustomComboBox(inherited ComboBox);\r\nend;\r\n\r\nfunction TJvComboBoxStrings.GetCount: Integer;\r\nbegin\r\n if (DestroyCount > 0) and UseInternal then\r\n Result := 0\r\n else\r\n begin\r\n if UseInternal then\r\n begin\r\n Result := InternalList.Count\r\n end\r\n else\r\n Result := SendMessage(ComboBox.Handle, CB_GETCOUNT, 0, 0);\r\n end;\r\nend;\r\n\r\nfunction TJvComboBoxStrings.GetInternalList: TStrings;\r\nbegin\r\n Result := FInternalList;\r\nend;\r\n\r\nfunction TJvComboBoxStrings.GetObject(Index: Integer): TObject;\r\nbegin\r\n if UseInternal then\r\n Result := InternalList.Objects[Index]\r\n else\r\n begin\r\n Result := TObject(SendMessage(ComboBox.Handle, CB_GETITEMDATA, Index, 0));\r\n if (LPARAM(Result) = LPARAM(CB_ERR)) and ((Count = 0) or (Index < 0) or (Index > Count)) then\r\n Error(SListIndexError, Index);\r\n end;\r\nend;\r\n\r\nfunction TJvComboBoxStrings.IndexOf(const S: string): Integer;\r\nbegin\r\n if UseInternal then\r\n Result := InternalList.IndexOf(S)\r\n else\r\n Result := SendMessage(ComboBox.Handle, CB_FINDSTRINGEXACT, -1, LPARAM(PChar(S)));\r\nend;\r\n\r\nprocedure TJvComboBoxStrings.Insert(Index: Integer; const S: string);\r\nbegin\r\n if (csLoading in ComboBox.ComponentState) and UseInternal then\r\n InternalList.Insert(Index, S)\r\n else\r\n begin\r\n ComboBox.DeselectProvider;\r\n if SendMessage(ComboBox.Handle, CB_INSERTSTRING, Index, LPARAM(PChar(S))) < 0 then\r\n raise EOutOfResources.CreateRes(@SInsertLineError);\r\n end;\r\nend;\r\n\r\n{ Copies the strings at the combo box to the InternalList. To minimize the memory usage when a\r\n large list is used, each item copied is immediately removed from the combo box list. }\r\n\r\nprocedure TJvComboBoxStrings.MakeListInternal;\r\nvar\r\n Cnt: Integer;\r\n Text: array [0..4095] of Char;\r\n Len: Integer;\r\n S: string;\r\n Obj: TObject;\r\nbegin\r\n SendMessage(ComboBox.Handle, WM_SETREDRAW, Ord(False), 0);\r\n try\r\n InternalList.Clear;\r\n Cnt := SendMessage(ComboBox.Handle, CB_GETCOUNT, 0, 0);\r\n while Cnt > 0 do\r\n begin\r\n Len := SendMessage(ComboBox.Handle, CB_GETLBTEXT, 0, LPARAM(@Text));\r\n SetString(S, Text, Len);\r\n Obj := TObject(SendMessage(ComboBox.Handle, CB_GETITEMDATA, 0, 0));\r\n SendMessage(ComboBox.Handle, CB_DELETESTRING, 0, 0);\r\n InternalList.AddObject(S, Obj);\r\n Dec(Cnt);\r\n end;\r\n finally\r\n UseInternal := True;\r\n if not Updating then\r\n SendMessage(ComboBox.Handle, WM_SETREDRAW, Ord(True), 0);\r\n end;\r\nend;\r\n\r\nprocedure TJvComboBoxStrings.PutObject(Index: Integer; AObject: TObject);\r\nbegin\r\n if UseInternal then\r\n InternalList.Objects[Index] := AObject\r\n else\r\n SendMessage(ComboBox.Handle, CB_SETITEMDATA, Index, LPARAM(AObject));\r\nend;\r\n\r\nprocedure TJvComboBoxStrings.SetComboBox(Value: TJvCustomComboBox);\r\nbegin\r\n inherited ComboBox := Value;\r\nend;\r\n\r\nprocedure TJvComboBoxStrings.SetUpdateState(Updating: Boolean);\r\nbegin\r\n FUpdating := Updating;\r\n SendMessage(ComboBox.Handle, WM_SETREDRAW, Ord(not Updating), 0);\r\n if not Updating then\r\n ComboBox.Refresh;\r\nend;\r\n\r\nprocedure TJvComboBoxStrings.SetWndDestroying(Destroying: Boolean);\r\nbegin\r\n if Destroying then\r\n Inc(FDestroyCnt)\r\n else\r\n if FDestroyCnt > 0 then\r\n Dec(FDestroyCnt);\r\nend;\r\n\r\n//=== { TJvCustomComboBox } ==================================================\r\n\r\nconstructor TJvCustomComboBox.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FConsumerSvc := TJvDataConsumer.Create(Self, [DPA_RenderDisabledAsGrayed,\r\n DPA_ConsumerDisplaysList]);\r\n FConsumerSvc.OnChanged := ConsumerServiceChanged;\r\n FConsumerSvc.AfterCreateSubSvc := ConsumerSubServiceCreated;\r\n FMaxPixel := TJvMaxPixel.Create(Self);\r\n FMaxPixel.OnChanged := MaxPixelChanged;\r\n FEmptyFontColor := clGrayText;\r\nend;\r\n\r\ndestructor TJvCustomComboBox.Destroy;\r\nbegin\r\n FMaxPixel.Free;\r\n FreeAndNil(FConsumerSvc);\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvCustomComboBox.CNCommand(var Msg: TWMCommand);\r\nvar\r\n VL: IJvDataConsumerViewList;\r\n Item: IJvDataItem;\r\n ItemText: IJvDataItemText;\r\nbegin\r\n case Msg.NotifyCode of\r\n CBN_SELCHANGE:\r\n begin\r\n if IsProviderSelected then\r\n begin\r\n Provider.Enter;\r\n try\r\n if Supports(Provider as IJvDataConsumer, IJvDataConsumerViewList, VL) then\r\n begin\r\n Item := VL.Item(ItemIndex);\r\n if Supports(Item, IJvDataItemText, ItemText) then\r\n Text := ItemText.Text\r\n else\r\n Text := '';\r\n end\r\n else\r\n begin\r\n Item := nil;\r\n Text := '';\r\n end;\r\n Click;\r\n Select;\r\n Provider.ItemSelected(Item);\r\n finally\r\n Provider.Leave;\r\n end;\r\n end\r\n else\r\n inherited;\r\n end;\r\n else\r\n inherited;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomComboBox.CNMeasureItem(var Msg: TWMMeasureItem);\r\nbegin\r\n inherited; // Normal behavior, specifically setting correct ItemHeight\r\n { Call MeasureItem if a provider is selected and the style is not csOwnerDrawVariable.\r\n if Style is set to csOwnerDrawVariable Measure will have been called already. }\r\n if (Style <> csOwnerDrawVariable) and IsProviderSelected then\r\n with Msg.MeasureItemStruct^ do\r\n MeasureItem(itemID, Integer(itemHeight));\r\nend;\r\n\r\nprocedure TJvCustomComboBox.ConsumerServiceChanged(Sender: TJvDataConsumer;\r\n Reason: TJvDataConsumerChangeReason);\r\nbegin\r\n if (Reason = ccrProviderSelect) and not IsProviderSelected and not FProviderToggle then\r\n begin\r\n TJvComboBoxStrings(Items).MakeListInternal;\r\n FProviderIsActive := True;\r\n FProviderToggle := True;\r\n RecreateWnd;\r\n end\r\n else\r\n if (Reason = ccrProviderSelect) and IsProviderSelected and not FProviderToggle then\r\n begin\r\n TJvComboBoxStrings(Items).ActivateInternal; // apply internal string list to combo box\r\n FProviderIsActive := False;\r\n FProviderToggle := True;\r\n RecreateWnd;\r\n end;\r\n if not FProviderToggle or (Reason = ccrProviderSelect) then\r\n begin\r\n UpdateItemCount;\r\n Refresh;\r\n end;\r\n if FProviderToggle and (Reason = ccrProviderSelect) then\r\n FProviderToggle := False;\r\nend;\r\n\r\nprocedure TJvCustomComboBox.ConsumerSubServiceCreated(Sender: TJvDataConsumer;\r\n SubSvc: TJvDataConsumerAggregatedObject);\r\nvar\r\n VL: IJvDataConsumerViewList;\r\nbegin\r\n if SubSvc.GetInterface(IJvDataConsumerViewList, VL) then\r\n begin\r\n VL.ExpandOnNewItem := True;\r\n VL.AutoExpandLevel := -1;\r\n VL.RebuildView;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomComboBox.CreateParams(var Params: TCreateParams);\r\nbegin\r\n inherited CreateParams(Params);\r\n if IsProviderSelected then\r\n begin\r\n Params.Style := Params.Style and not (CBS_SORT or CBS_HASSTRINGS);\r\n if Params.Style and (CBS_OWNERDRAWVARIABLE or CBS_OWNERDRAWFIXED) = 0 then\r\n Params.Style := Params.Style or CBS_OWNERDRAWFIXED;\r\n end;\r\n FIsFixedHeight := (Params.Style and CBS_OWNERDRAWVARIABLE) = 0;\r\nend;\r\n\r\nprocedure TJvCustomComboBox.CreateWnd;\r\nbegin\r\n inherited CreateWnd;\r\n SendMessage(EditHandle, EM_SETREADONLY, Ord(ReadOnly), 0);\r\n if (FDropDownWidth > 0) and not (csDesigning in ComponentState) then\r\n SendMessage(Handle, CB_SETDROPPEDWIDTH, FDropDownWidth, 0);\r\n UpdateItemCount;\r\n if Focused then\r\n DoEmptyValueEnter\r\n else\r\n DoEmptyValueExit;\r\nend;\r\n\r\nprocedure TJvCustomComboBox.DefineProperties(Filer: TFiler);\r\nbegin\r\n inherited DefineProperties(Filer);\r\n\r\n Filer.DefineProperty('Ctl3D', ReadCtl3D, nil, False);\r\n Filer.DefineProperty('ParentCtl3D', ReadParentCtl3D, nil, False);\r\nend;\r\n\r\nfunction TJvCustomComboBox.DeleteExactString(const Value: string; All: Boolean;\r\n CaseSensitive: Boolean): Integer;\r\nbegin\r\n Result := TJvItemsSearchs.DeleteExactString(Items, Value, CaseSensitive);\r\nend;\r\n\r\nprocedure TJvCustomComboBox.DeselectProvider;\r\nbegin\r\n Provider.Provider := nil;\r\nend;\r\n\r\nprocedure TJvCustomComboBox.DestroyWnd;\r\nbegin\r\n if IsProviderSelected then\r\n TJvComboBoxStrings(Items).SetWndDestroying(True);\r\n try\r\n inherited DestroyWnd;\r\n finally\r\n if IsProviderSelected then\r\n TJvComboBoxStrings(Items).SetWndDestroying(False);\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomComboBox.DoEmptyValueEnter;\r\nbegin\r\n if EmptyValue <> '' then\r\n begin\r\n if FIsEmptyValue then\r\n begin\r\n Text := '';\r\n FIsEmptyValue := False;\r\n if not (csDesigning in ComponentState) then\r\n Font.Color := FOldFontColor;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomComboBox.DoEmptyValueExit;\r\nbegin\r\n if EmptyValue <> '' then\r\n begin\r\n if Text = '' then\r\n begin\r\n Text := EmptyValue;\r\n FIsEmptyValue := True;\r\n if not (csDesigning in ComponentState) then\r\n begin\r\n FOldFontColor := Font.Color;\r\n Font.Color := FEmptyFontColor;\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomComboBox.DoEnter;\r\nbegin\r\n inherited DoEnter;\r\n DoEmptyValueEnter;\r\nend;\r\n\r\nprocedure TJvCustomComboBox.DoExit;\r\nbegin\r\n inherited DoExit;\r\n DoEmptyValueExit;\r\nend;\r\n\r\nprocedure TJvCustomComboBox.DrawItem(Index: Integer; Rect: TRect; State: TOwnerDrawState);\r\nvar\r\n HeightIndex: Integer;\r\n NewHeight: Integer;\r\n InvokeOrgRender: Boolean;\r\n VL: IJvDataConsumerViewList;\r\n Item: IJvDataItem;\r\n ItemsRenderer: IJvDataItemsRenderer;\r\n ItemRenderer: IJvDataItemRenderer;\r\n ItemText: IJvDataItemText;\r\n DrawState: TProviderDrawStates;\r\nbegin\r\n if csDestroying in ComponentState then\r\n Exit;\r\n TControlCanvas(Canvas).UpdateTextFlags;\r\n if (MeasureStyle = cmsBeforeDraw) and not FIsFixedHeight then\r\n begin\r\n NewHeight := FLastSetItemHeight;\r\n if odComboBoxEdit in State then\r\n HeightIndex := -1\r\n else\r\n HeightIndex := Index;\r\n PerformMeasureItem(HeightIndex, NewHeight);\r\n Perform(CB_SETITEMHEIGHT, HeightIndex, NewHeight);\r\n end;\r\n // (rom) Strange, this is already the overridden implementor of OnDrawItem\r\n if Assigned(OnDrawItem) and (Style in [csOwnerDrawFixed, csOwnerDrawVariable]) then\r\n OnDrawItem(Self, Index, Rect, State)\r\n else\r\n begin\r\n InvokeOrgRender := False;\r\n DrawState := DP_OwnerDrawStateToProviderDrawState(State);\r\n if not Enabled then\r\n DrawState := DrawState + [pdsDisabled, pdsGrayed];\r\n if IsProviderSelected then\r\n begin\r\n Provider.Enter;\r\n try\r\n if Supports(Provider as IJvDataConsumer, IJvDataConsumerViewList, VL) then\r\n begin\r\n Item := VL.Item(Index);\r\n if Item <> nil then\r\n begin\r\n Inc(Rect.Left, VL.ItemLevel(Index) * VL.LevelIndent);\r\n Canvas.Font := Font;\r\n if odSelected in State then\r\n begin\r\n Canvas.Brush.Color := clHighlight;\r\n Canvas.Font.Color := clHighlightText;\r\n end\r\n else\r\n Canvas.Brush.Color := Color;\r\n Canvas.FillRect(Rect);\r\n if Supports(Item, IJvDataItemRenderer, ItemRenderer) then\r\n ItemRenderer.Draw(Canvas, Rect, DrawState)\r\n else\r\n if DP_FindItemsRenderer(Item, ItemsRenderer) then\r\n ItemsRenderer.DrawItem(Canvas, Rect, Item, DrawState)\r\n else\r\n if Supports(Item, IJvDataItemText, ItemText) then\r\n Canvas.TextRect(Rect, Rect.Left, Rect.Top, ItemText.Text)\r\n else\r\n Canvas.TextRect(Rect, Rect.Left, Rect.Top, RsDataItemRenderHasNoText);\r\n end\r\n else\r\n InvokeOrgRender := True;\r\n end\r\n else\r\n InvokeOrgRender := True;\r\n finally\r\n Provider.Leave;\r\n end;\r\n end\r\n else\r\n InvokeOrgRender := True;\r\n if InvokeOrgRender then\r\n begin\r\n Canvas.FillRect(Rect);\r\n if (Index >= 0) and (Index <= Items.Count) then\r\n Canvas.TextOut(Rect.Left + 2, Rect.Top, GetItemText(Index));\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJvCustomComboBox.GetItemCount: Integer;\r\nvar\r\n VL: IJvDataConsumerViewList;\r\nbegin\r\n if IsProviderSelected then\r\n begin\r\n Provider.Enter;\r\n try\r\n if Supports(Provider as IJvDataConsumer, IJvDataConsumerViewList, VL) then\r\n Result := VL.Count\r\n else\r\n Result := 0;\r\n finally\r\n Provider.Leave;\r\n end;\r\n end\r\n else\r\n Result := inherited GetItemCount;\r\nend;\r\n\r\nfunction TJvCustomComboBox.GetItemsClass: TCustomComboBoxStringsClass;\r\nbegin\r\n Result := TJvComboBoxStrings;\r\nend;\r\n\r\nfunction TJvCustomComboBox.GetItemText(Index: Integer): string;\r\nvar\r\n VL: IJvDataConsumerViewList;\r\n Item: IJvDataItem;\r\n ItemText: IJvDataItemText;\r\nbegin\r\n if IsProviderSelected then\r\n begin\r\n if Supports(Provider as IJvDataConsumer, IJvDataConsumerViewList, VL) then\r\n begin\r\n Provider.Enter;\r\n try\r\n if (Index >= 0) and (Index < VL.Count) then\r\n begin\r\n Item := VL.Item(Index);\r\n if Supports(Item, IJvDataItemText, ItemText) then\r\n Result := ItemText.Text\r\n else\r\n Result := RsDataItemRenderHasNoText;\r\n end\r\n else\r\n TJvComboBoxStrings(Items).Error(SListIndexError, Index);\r\n finally\r\n Provider.Leave;\r\n end;\r\n end\r\n else\r\n Result := '';\r\n// TJvComboBoxStrings(Items).Error(SListIndexError, Index);\r\n end\r\n else\r\n Result := Items[Index];\r\nend;\r\n\r\nfunction TJvCustomComboBox.GetMeasureStyle: TJvComboBoxMeasureStyle;\r\nbegin\r\n Result := FMeasureStyle;\r\nend;\r\n\r\nfunction TJvCustomComboBox.GetText: TCaption;\r\nbegin\r\n if FIsEmptyValue then\r\n Result := ''\r\n else\r\n Result := inherited Text;\r\nend;\r\n\r\nfunction TJvCustomComboBox.HandleFindString(StartIndex: Integer; Value: string;\r\n ExactMatch: Boolean): Integer;\r\nvar\r\n VL: IJvDataConsumerViewList;\r\n HasLooped: Boolean;\r\n Item: IJvDataItem;\r\n ItemText: IJvDataItemText;\r\nbegin\r\n if IsProviderSelected and\r\n Supports(Provider as IJvDataConsumer, IJvDataConsumerViewList, VL) then\r\n begin\r\n Provider.Enter;\r\n try\r\n HasLooped := False;\r\n Result := StartIndex + 1;\r\n while True do\r\n begin\r\n Item := VL.Item(Result);\r\n if Supports(Item, IJvDataItemText, ItemText) then\r\n begin\r\n if ExactMatch then\r\n begin\r\n if AnsiSameText(Value, ItemText.Text) then\r\n Break;\r\n end\r\n else\r\n if AnsiStrLIComp(PChar(Value), PChar(ItemText.Text), Length(Value)) = 0 then\r\n Break;\r\n end;\r\n Inc(Result);\r\n if Result >= VL.Count then\r\n begin\r\n Result := 0;\r\n HasLooped := True;\r\n end;\r\n if (Result > StartIndex) and HasLooped then\r\n begin\r\n Result := -1;\r\n Exit;\r\n end;\r\n end;\r\n finally\r\n Provider.Leave;\r\n end;\r\n end\r\n else\r\n Result := -1;\r\nend;\r\n\r\nfunction TJvCustomComboBox.IsItemHeightStored: Boolean;\r\nvar\r\n Value: Integer;\r\nbegin\r\n Value := ItemHeight;\r\n Result := (Value <> 16) and (Value <> 0);\r\nend;\r\n\r\nfunction TJvCustomComboBox.IsProviderSelected: Boolean;\r\nbegin\r\n Result := FProviderIsActive;\r\nend;\r\n\r\nprocedure TJvCustomComboBox.KeyPress(var Key: Char);\r\nbegin\r\n if (ReadOnly) and (Key = Chr(VK_BACK)) then\r\n Key := #0;\r\n inherited KeyPress(Key);\r\nend;\r\n\r\nprocedure TJvCustomComboBox.Loaded;\r\nbegin\r\n inherited Loaded;\r\n RecreateWnd; // Force measuring at the correct moment\r\nend;\r\n\r\nprocedure TJvCustomComboBox.MaxPixelChanged(Sender: TObject);\r\nvar\r\n St: string;\r\nbegin\r\n if Style <> csDropDownList then\r\n begin\r\n St := Text;\r\n FMaxPixel.Test(St, Font);\r\n if Text <> St then\r\n Text := St;\r\n SelStart := Length(Text);\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomComboBox.MeasureItem(Index: Integer; var Height: Integer);\r\nbegin\r\n if not (csLoading in ComponentState) and\r\n (MeasureStyle = cmsStandard) and not IsProviderSelected then\r\n PerformMeasureItem(Index, Height);\r\nend;\r\n\r\nprocedure TJvCustomComboBox.PerformMeasure;\r\nvar\r\n MaxCnt: Integer;\r\n Index: Integer;\r\n NewHeight: Integer;\r\nbegin\r\n if FIsFixedHeight then\r\n MaxCnt := 0\r\n else\r\n MaxCnt := GetItemCount - 1;\r\n for Index := -1 to MaxCnt do\r\n begin\r\n NewHeight := FLastSetItemHeight;\r\n PerformMeasureItem(Index, NewHeight);\r\n Perform(CB_SETITEMHEIGHT, Index, NewHeight);\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomComboBox.PerformMeasureItem(Index: Integer; var Height: Integer);\r\nvar\r\n TmpSize: TSize;\r\n VL: IJvDataConsumerViewList;\r\n Item: IJvDataItem;\r\n ItemsRenderer: IJvDataItemsRenderer;\r\n ItemRenderer: IJvDataItemRenderer;\r\nbegin\r\n if Assigned(OnMeasureItem) and (Style in [csOwnerDrawFixed, csOwnerDrawVariable]) then\r\n OnMeasureItem(Self, Index, Height)\r\n else\r\n begin\r\n TmpSize.cy := Height;\r\n if IsProviderSelected then\r\n begin\r\n Provider.Enter;\r\n try\r\n if ((Index = -1) or IsFixedHeight or not HandleAllocated) and\r\n Supports(Provider.ProviderIntf, IJvDataItemsRenderer, ItemsRenderer) then\r\n TmpSize := ItemsRenderer.AvgItemSize(Canvas)\r\n else\r\n if (Index <> -1) and not IsFixedHeight and HandleAllocated then\r\n begin\r\n if Supports(Provider as IJvDataConsumer, IJvDataConsumerViewList, VL) then\r\n begin\r\n Item := VL.Item(Index);\r\n if Supports(Item, IJvDataItemRenderer, ItemRenderer) then\r\n TmpSize := ItemRenderer.Measure(Canvas)\r\n else\r\n if DP_FindItemsRenderer(Item, ItemsRenderer) then\r\n TmpSize := ItemsRenderer.MeasureItem(Canvas, Item);\r\n end;\r\n end;\r\n if TmpSize.cy > Height then\r\n Height := TmpSize.cy;\r\n finally\r\n Provider.Leave;\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomComboBox.ReadCtl3D(Reader: TReader);\r\nbegin\r\n Flat := not Reader.ReadBoolean;\r\nend;\r\n\r\nprocedure TJvCustomComboBox.ReadParentCtl3D(Reader: TReader);\r\nbegin\r\n ParentFlat := Reader.ReadBoolean;\r\nend;\r\n\r\nfunction TJvCustomComboBox.SearchExactString(const Value: string;\r\n CaseSensitive: Boolean): Integer;\r\nbegin\r\n Result := TJvItemsSearchs.SearchExactString(Items, Value, CaseSensitive);\r\nend;\r\n\r\nfunction TJvCustomComboBox.SearchPrefix(const Value: string;\r\n CaseSensitive: Boolean): Integer;\r\nbegin\r\n Result := TJvItemsSearchs.SearchPrefix(Items, Value, CaseSensitive);\r\nend;\r\n\r\nfunction TJvCustomComboBox.SearchSubString(const Value: string;\r\n CaseSensitive: Boolean): Integer;\r\nbegin\r\n Result := TJvItemsSearchs.SearchSubString(Items, Value, CaseSensitive);\r\nend;\r\n\r\nprocedure TJvCustomComboBox.SetConsumerService(Value: TJvDataConsumer);\r\nbegin\r\nend;\r\n\r\nprocedure TJvCustomComboBox.SetDropDownWidth(Value: Integer);\r\nbegin\r\n if Value < 0 then\r\n Value := 0;\r\n if Value <> FDropDownWidth then\r\n begin\r\n FDropDownWidth := Value;\r\n if HandleAllocated and not (csDesigning in ComponentState) then\r\n SendMessage(Handle, CB_SETDROPPEDWIDTH, Value, 0);\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomComboBox.SetEmptyValue(const Value: string);\r\nbegin\r\n FEmptyValue := Value;\r\n if HandleAllocated then\r\n if Focused then\r\n DoEmptyValueEnter\r\n else\r\n DoEmptyValueExit;\r\nend;\r\n\r\nprocedure TJvCustomComboBox.SetItemHeight(Value: Integer);\r\nbegin\r\n FLastSetItemHeight := Value;\r\n inherited SetItemHeight(Value);\r\nend;\r\n\r\nprocedure TJvCustomComboBox.SetMeasureStyle(Value: TJvComboBoxMeasureStyle);\r\nbegin\r\n if Value <> MeasureStyle then\r\n begin\r\n FMeasureStyle := Value;\r\n RecreateWnd;\r\n end;\r\nend;\r\n\r\nfunction TJvCustomComboBox.GetFlat: Boolean;\r\nbegin\r\n Result := not Ctl3D;\r\nend;\r\n\r\nfunction TJvCustomComboBox.GetParentFlat: Boolean;\r\nbegin\r\n Result := ParentCtl3D;\r\nend;\r\n\r\nprocedure TJvCustomComboBox.SetFlat(const Value: Boolean);\r\nbegin\r\n Ctl3D := not Value;\r\nend;\r\n\r\nprocedure TJvCustomComboBox.SetParentFlat(const Value: Boolean);\r\nbegin\r\n ParentCtl3D := Value;\r\nend;\r\n\r\nprocedure TJvCustomComboBox.SetReadOnly(const Value: Boolean);\r\nbegin\r\n if FReadOnly <> Value then\r\n begin\r\n FReadOnly := Value;\r\n SendMessage(EditHandle, EM_SETREADONLY, Ord(Value), 0);\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomComboBox.SetText(const Value: TCaption);\r\nbegin\r\n inherited Text := Value;\r\nend;\r\n\r\nprocedure TJvCustomComboBox.UpdateItemCount;\r\nvar\r\n VL: IJvDataConsumerViewList;\r\n Cnt: Integer;\r\n EmptyChr: Char;\r\nbegin\r\n if HandleAllocated and IsProviderSelected and\r\n Supports(Provider as IJvDataConsumer, IJvDataConsumerViewList, VL) then\r\n begin\r\n Cnt := VL.Count - SendMessage(Handle, CB_GETCOUNT, 0, 0);\r\n EmptyChr := #0;\r\n while Cnt > 0 do\r\n begin\r\n SendMessage(Handle, CB_ADDSTRING, 0, LPARAM(@EmptyChr));\r\n Dec(Cnt);\r\n end;\r\n while Cnt < 0 do\r\n begin\r\n SendMessage(Handle, CB_DELETESTRING, 0, 0);\r\n Inc(Cnt);\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomComboBox.WMInitDialog(var Msg: TWMInitDialog);\r\nbegin\r\n inherited;\r\n if (MeasureStyle = cmsAfterCreate) or\r\n (IsProviderSelected and ((MeasureStyle <> cmsBeforeDraw) or FIsFixedHeight)) then\r\n PerformMeasure;\r\nend;\r\n\r\nprocedure TJvCustomComboBox.WMLButtonDblClk(var Msg: TWMLButtonDblClk);\r\nbegin\r\n if not ReadOnly then\r\n inherited;\r\nend;\r\n\r\nprocedure TJvCustomComboBox.WMLButtonDown(var Msg: TWMLButtonDown);\r\nbegin\r\n if ReadOnly then\r\n SetFocus\r\n else\r\n inherited;\r\nend;\r\n\r\nprocedure TJvCustomComboBox.WndProc(var Msg: TMessage);\r\nbegin\r\n if ReadOnly and not (csDesigning in ComponentState) then\r\n begin\r\n case Msg.Msg of\r\n WM_KEYDOWN:\r\n if Integer(Msg.WParam) in [VK_DOWN, VK_UP, VK_RIGHT, VK_LEFT, VK_F4] then\r\n begin\r\n // (rom) please english comments\r\n // see keelab aktiivse itemi vahetamise nooleklahvidega DDL kui CB on aktiivne\r\n Msg.Result := 0;\r\n Exit;\r\n end;\r\n WM_CHAR:\r\n begin\r\n // DDL trykkides ei aktiveeriks selle tahega algavat itemit\r\n Msg.Result := 0;\r\n Exit;\r\n end;\r\n WM_SYSKEYDOWN:\r\n if (Msg.WParam = VK_DOWN) or (Msg.WParam = VK_UP) then\r\n begin\r\n // see keelab Ald+Down listi avamise fookuses DDL CB-l\r\n Msg.Result := 0;\r\n Exit;\r\n end;\r\n WM_COMMAND:\r\n // DD editis nooleklahviga vahetamise valtimiseks kui fookuses\r\n if HiWord(Msg.WParam) = CBN_SELCHANGE then\r\n begin\r\n Msg.Result := 0;\r\n Exit;\r\n end;\r\n // (rom) these values need an explanation\r\n WM_USER + $B900:\r\n if Msg.WParam = VK_F4 then\r\n begin\r\n // DD F4 ei avaks\r\n Msg.Result := 1;\r\n Exit;\r\n end;\r\n WM_USER + $B904:\r\n if (Msg.WParam = VK_DOWN) or (Msg.WParam = VK_UP) then\r\n begin\r\n // DD Alt+ down ei avaks\r\n Msg.Result := 1;\r\n Exit;\r\n end;\r\n end;\r\n end;\r\n if IsProviderSelected then\r\n case Msg.Msg of\r\n CB_FINDSTRING:\r\n begin\r\n Msg.Result := HandleFindString(Msg.WParam, PChar(Msg.LParam), False);\r\n if Msg.Result < 0 then\r\n Msg.Result := CB_ERR;\r\n Exit;\r\n end;\r\n CB_SELECTSTRING:\r\n begin\r\n Msg.Result := HandleFindString(Msg.WParam, PChar(Msg.LParam), False);\r\n if Msg.Result < 0 then\r\n Msg.Result := CB_ERR\r\n else\r\n Perform(CB_SETCURSEL, Msg.Result, 0);\r\n Exit;\r\n end;\r\n CB_FINDSTRINGEXACT:\r\n begin\r\n Msg.Result := HandleFindString(Msg.WParam, PChar(Msg.LParam), True);\r\n if Msg.Result < 0 then\r\n Msg.Result := CB_ERR;\r\n Exit;\r\n end;\r\n end;\r\n inherited WndProc(Msg);\r\nend;\r\n\r\n//=== { TJvPrivForm } ========================================================\r\n\r\nfunction TJvPrivForm.GetValue: Variant;\r\nbegin\r\n Result := '';\r\nend;\r\n\r\nprocedure TJvPrivForm.SetValue(const Value: Variant);\r\nbegin\r\n {Nothing}\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvCommStatus.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvCommStatus.PAS, released on 2001-02-28.\r\n\r\nThe Initial Developer of the Original Code is Sbastien Buysse [sbuysse att buypin dott com]\r\nPortions created by Sbastien Buysse are Copyright (C) 2001 Sbastien Buysse.\r\nAll Rights Reserved.\r\n\r\nContributor(s): Michael Beck [mbeck att bigfoot dott com].\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvCommStatus.pas 13104 2011-09-07 06:50:43Z obones $\r\n\r\nunit JvCommStatus;\r\n\r\n{$I jvcl.inc}\r\n{$I windowsonly.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, Classes,\r\n JvComponentBase, JvThread;\r\n\r\ntype\r\n TJvCommPort = 0..8;\r\n\r\n TJvCommWatcher = class(TJvPausableThread)\r\n private\r\n FHandle: THandle;\r\n FStat: Cardinal;\r\n FOnChange: TNotifyEvent;\r\n procedure Changed;\r\n protected\r\n procedure Execute; override;\r\n end;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvCommStatus = class(TJvComponent)\r\n private\r\n FClearToSend: Boolean;\r\n FDataSetReady: Boolean;\r\n FRing: Boolean;\r\n FReceiveLine: Boolean;\r\n FHandle: THandle;\r\n FWatcher: TJvCommWatcher;\r\n FDummy: Boolean;\r\n FComm: TJvCommPort;\r\n FOnChanged: TNotifyEvent;\r\n procedure SetComm(const Value: TJvCommPort);\r\n procedure OnChange(Sender: TObject);\r\n procedure UpdateStates(State: Cardinal);\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n published\r\n { Do not store dummies }\r\n property ClearToSend: Boolean read FClearToSend write FDummy stored False;\r\n property DataSetReady: Boolean read FDataSetReady write FDummy stored False;\r\n property Ring: Boolean read FRing write FDummy stored False;\r\n property ReceiveLine: Boolean read FReceiveLine write FDummy stored False;\r\n property Comm: TJvCommPort read FComm write SetComm default 0;\r\n property OnChanged: TNotifyEvent read FOnChanged write FOnChanged;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvCommStatus.pas $';\r\n Revision: '$Revision: 13104 $';\r\n Date: '$Date: 2011-09-07 08:50:43 +0200 (mer. 07 sept. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n SysUtils;\r\n\r\n//=== { TJvCommStatus } ======================================================\r\n\r\nconstructor TJvCommStatus.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FComm := 0;\r\n FHandle := 0;\r\n\r\n if not (csDesigning in ComponentState) then\r\n begin\r\n FWatcher := TJvCommWatcher.Create(True);\r\n FWatcher.FreeOnTerminate := True;\r\n\r\n FWatcher.FHandle := FHandle;\r\n FWatcher.FStat := 0;\r\n FWatcher.FOnChange := OnChange;\r\n\r\n FWatcher.{$IFDEF COMPILER14_UP}Start{$ELSE}Resume{$ENDIF COMPILER14_UP};\r\n end\r\n else\r\n FWatcher := nil;\r\n\r\n SetComm(FComm);\r\nend;\r\n\r\ndestructor TJvCommStatus.Destroy;\r\nbegin\r\n if FWatcher <> nil then\r\n begin\r\n FWatcher.Terminate;\r\n FWatcher := nil;\r\n end;\r\n if FHandle <> 0 then\r\n CloseHandle(FHandle);\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvCommStatus.UpdateStates(State: Cardinal);\r\nbegin\r\n FClearToSend := (State and MS_CTS_ON) <> 0;\r\n FDataSetReady := (State and MS_DSR_ON) <> 0;\r\n FRing := (State and MS_RING_ON) <> 0;\r\n FReceiveLine := (State and MS_RLSD_ON) <> 0;\r\nend;\r\n\r\nprocedure TJvCommStatus.OnChange(Sender: TObject);\r\nbegin\r\n if (FWatcher <> nil) and (FHandle <> 0) then\r\n UpdateStates(FWatcher.FStat)\r\n else\r\n UpdateStates(0);\r\n if Assigned(FOnChanged) then\r\n FOnChanged(Self);\r\nend;\r\n\r\nprocedure TJvCommStatus.SetComm(const Value: TJvCommPort);\r\nvar\r\n Stat: Cardinal;\r\n CommName: string;\r\nbegin\r\n if FWatcher <> nil then\r\n FWatcher.FHandle := 0;\r\n if FHandle <> 0 then\r\n CloseHandle(FHandle);\r\n FHandle := 0;\r\n FComm := Value;\r\n // (rom) simplified through better TJvCommPort\r\n if FComm <> 0 then\r\n begin\r\n CommName := 'COM' + IntToStr(FComm);\r\n FHandle := CreateFile(PChar(CommName), 0, FILE_SHARE_READ or FILE_SHARE_WRITE, nil, OPEN_EXISTING, 0, 0);\r\n end;\r\n\r\n if GetCommModemStatus(FHandle, Stat) then\r\n UpdateStates(Stat)\r\n else\r\n UpdateStates(0);\r\n\r\n if FWatcher <> nil then\r\n begin\r\n FWatcher.FHandle := FHandle;\r\n FWatcher.FStat := 0;\r\n FWatcher.Paused := FHandle = 0;\r\n end;\r\n OnChange(Self);\r\nend;\r\n\r\n//=== { TJvCommWatcher } =====================================================\r\n\r\nprocedure TJvCommWatcher.Changed;\r\nbegin\r\n FOnChange(nil);\r\nend;\r\n\r\nprocedure TJvCommWatcher.Execute;\r\nvar\r\n Mask: Cardinal;\r\nbegin\r\n NameThread(ThreadName);\r\n // (rom) secure thread against exceptions\r\n try\r\n while not Terminated do\r\n begin\r\n EnterUnpauseableSection;\r\n try\r\n if Terminated then\r\n Exit;\r\n\r\n if FHandle <> 0 then\r\n begin\r\n GetCommModemStatus(FHandle, Mask);\r\n if Mask <> FStat then\r\n begin\r\n FStat := Mask;\r\n Synchronize(Changed);\r\n end;\r\n end;\r\n finally\r\n LeaveUnpauseableSection;\r\n end;\r\n Sleep(50);\r\n end;\r\n except\r\n end;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvCommonExecDlg.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvCommonExecDlg.PAS, released on 2001-02-28.\r\n\r\nThe Initial Developer of the Original Code is Sbastien Buysse [sbuysse att buypin dott com]\r\nPortions created by Sbastien Buysse are Copyright (C) 2001 Sbastien Buysse.\r\nAll Rights Reserved.\r\n\r\nContributor(s): Michael Beck [mbeck att bigfoot dott com].\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvCommonExecDlg.pas 13351 2012-06-13 15:16:00Z obones $\r\n\r\nunit JvCommonExecDlg;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, Classes,\r\n JvBaseDlg;\r\n\r\ntype\r\n TJvCommonExecDialog = class(TJvCommonDialog)\r\n private\r\n FOwnerWindow: THandle;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n property OwnerWindow: THandle read FOwnerWindow;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvCommonExecDlg.pas $';\r\n Revision: '$Revision: 13351 $';\r\n Date: '$Date: 2012-06-13 17:16:00 +0200 (mer. 13 juin 2012) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n Controls;\r\n\r\nconstructor TJvCommonExecDialog.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n if AOwner is TWinControl then\r\n FOwnerWindow := (AOwner as TWinControl).Handle\r\n else\r\n FOwnerWindow := HWND_DESKTOP;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvComponent.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvComponent.PAS, released on 2000-09-22.\r\n\r\nThe Initial Developer of the Original Code is Joe Doe .\r\nPortions created by Joe Doe are Copyright (C) 1999 Joe Doe.\r\nPortions created by XXXX Corp. are Copyright (C) 1998, 1999 XXXX Corp.\r\nAll Rights Reserved.\r\n\r\nContributor(s): -\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvComponent.pas 13173 2011-11-19 12:43:58Z ahuser $\r\n\r\nunit JvComponent;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Classes,\r\n {$IFDEF USE_DXGETTEXT}\r\n JvGnugettext,\r\n {$ENDIF USE_DXGETTEXT}\r\n Windows, Messages, Controls, Forms,\r\n JvConsts,\r\n JvExControls, JvExForms, JvExStdCtrls;\r\n\r\ntype\r\n TJvGraphicControl = TJvExGraphicControl;\r\n TJvPubGraphicControl = TJvExPubGraphicControl;\r\n TJvCustomControl = TJvExCustomControl;\r\n TJvWinControl = TJvExWinControl;\r\n\r\n TJvForm = class(TJvExForm)\r\n private\r\n FIsFocusable: Boolean;\r\n {$IFNDEF DELPHI2009_UP}\r\n procedure CMShowingChanged(var Message: TMessage); message CM_SHOWINGCHANGED;\r\n {$ENDIF ~DELPHI2009_UP}\r\n procedure WMMouseActivate(var Msg: TMessage); message WM_MOUSEACTIVATE;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n constructor CreateNew(AOwner: TComponent; Dummy: Integer = 0); override;\r\n {$IFDEF USE_DXGETTEXT}\r\n procedure RefreshTranslation; virtual;\r\n {$ENDIF USE_DXGETTEXT}\r\n\r\n function ShowModal: Integer; override;\r\n { ShowNoActivate() shows the form but does not activate it. }\r\n procedure ShowNoActivate(CallActivate: Boolean = False);\r\n published\r\n property IsFocusable: Boolean read FIsFocusable write FIsFocusable default True;\r\n end;\r\n\r\n//=== { TJvPopupListBox } ====================================================\r\n\r\ntype\r\n TJvPopupListBox = class(TJvExCustomListBox)\r\n private\r\n FSearchText: string;\r\n FSearchTickCount: Longint;\r\n protected\r\n procedure CreateParams(var Params: TCreateParams); override;\r\n procedure CreateWnd; override;\r\n procedure KeyPress(var Key: Char); override;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvComponent.pas $';\r\n Revision: '$Revision: 13173 $';\r\n Date: '$Date: 2011-11-19 13:43:58 +0100 (sam. 19 nov. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n RTLConsts;\r\n\r\n{$IFDEF USE_DXGETTEXT}\r\nconst\r\n cDomainName = 'jvcl';\r\n{$ENDIF USE_DXGETTEXT}\r\n\r\n//=== { TJvForm } ============================================================\r\n\r\nconstructor TJvForm.Create(AOwner: TComponent);\r\nbegin\r\n// inherited Create(AOwner);\r\n CreateNew(AOwner, 0);\r\n GlobalNameSpace.BeginWrite;\r\n try\r\n if (ClassType <> TJvForm) and not (csDesigning in ComponentState) then\r\n begin\r\n Include(FFormState, fsCreating);\r\n try\r\n if not InitInheritedComponent(Self, TJvForm) then\r\n raise EResNotFound.CreateResFmt(@SResNotFound, [ClassName]);\r\n\r\n {$IFDEF USE_DXGETTEXT}\r\n TranslateComponent(Self, cDomainName);\r\n {$ENDIF USE_DXGETTEXT}\r\n finally\r\n Exclude(FFormState, fsCreating);\r\n end;\r\n if OldCreateOrder then\r\n DoCreate;\r\n end;\r\n finally\r\n GlobalNameSpace.EndWrite;\r\n end;\r\nend;\r\n\r\nconstructor TJvForm.CreateNew(AOwner: TComponent; Dummy: Integer);\r\nbegin\r\n inherited CreateNew(AOwner, Dummy);\r\n FIsFocusable := True;\r\nend;\r\n\r\n{$IFDEF USE_DXGETTEXT}\r\n\r\nprocedure TJvForm.RefreshTranslation;\r\nbegin\r\n ReTranslateComponent(Self, cDomainName);\r\nend;\r\n\r\n{$ENDIF USE_DXGETTEXT}\r\n\r\n{$IFNDEF COMPILER12_UP}\r\nprocedure TJvForm.CMShowingChanged(var Message: TMessage);\r\nvar\r\n NewParent: HWND;\r\nbegin\r\n if Showing and (FormStyle <> fsMDIChild) then\r\n begin\r\n if FormStyle = fsStayOnTop then\r\n begin\r\n // restore StayOnTop\r\n NewParent := Application.Handle;\r\n if HWND(GetWindowLong(Handle, GWL_HWNDPARENT)) <> NewParent then\r\n SetWindowLong(Handle, GWL_HWNDPARENT, Longint(NewParent));\r\n SetWindowPos(Handle, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOSIZE or SWP_NOMOVE or SWP_NOACTIVATE);\r\n end\r\n else\r\n begin\r\n // Fixing the Window Ghosting \"bug\", only for forms that don't have a parent assigned (Mantis 4032)\r\n if not Assigned(Parent) then\r\n begin\r\n NewParent := 0;\r\n if Assigned(Screen.ActiveForm) and (Screen.ActiveForm <> Self) then\r\n begin\r\n if fsModal in Screen.ActiveForm.FormState then\r\n NewParent := Screen.ActiveForm.Handle;\r\n end;\r\n if (NewParent = 0) and Assigned(Application.MainForm) and (Application.MainForm <> Self) then\r\n NewParent := Application.MainForm.Handle;\r\n if NewParent = 0 then\r\n NewParent := Application.Handle;\r\n if HWND(GetWindowLong(Handle, GWL_HWNDPARENT)) <> NewParent then\r\n SetWindowLong(Handle, GWL_HWNDPARENT, Longint(NewParent));\r\n end;\r\n end;\r\n end;\r\n inherited;\r\nend;\r\n{$ENDIF ~COMPILER12_UP}\r\n\r\nfunction TJvForm.ShowModal: Integer;\r\nvar\r\n Msg: TMsg;\r\nbegin\r\n while PeekMessage(Msg, 0, WM_ENABLE, WM_ENABLE, PM_REMOVE) do\r\n DispatchMessage(Msg);\r\n Result := inherited ShowModal;\r\nend;\r\n\r\nprocedure TJvForm.WMMouseActivate(var Msg: TMessage);\r\nbegin\r\n if IsFocusable then\r\n inherited\r\n else\r\n Msg.Result := MA_NOACTIVATE;\r\nend;\r\n\r\nprocedure TJvForm.ShowNoActivate(CallActivate: Boolean);\r\nbegin\r\n if CallActivate then\r\n Activate;\r\n SetWindowPos(Handle, HWND_TOP, 0, 0, 0, 0, SWP_NOMOVE or SWP_NOSIZE or SWP_SHOWWINDOW or SWP_NOACTIVATE);\r\n Visible := True;\r\nend;\r\n\r\n//=== { TJvPopupListBox } ====================================================\r\n\r\nprocedure TJvPopupListBox.CreateParams(var Params: TCreateParams);\r\nbegin\r\n inherited CreateParams(Params);\r\n with Params do\r\n begin\r\n Style := Style or WS_BORDER;\r\n ExStyle := WS_EX_TOOLWINDOW or WS_EX_TOPMOST;\r\n AddBiDiModeExStyle(ExStyle);\r\n WindowClass.Style := CS_SAVEBITS;\r\n end;\r\nend;\r\n\r\nprocedure TJvPopupListBox.CreateWnd;\r\nbegin\r\n inherited CreateWnd;\r\n Windows.SetParent(Handle, 0);\r\n CallWindowProc(DefWndProc, Handle, WM_SETFOCUS, 0, 0);\r\nend;\r\n\r\nprocedure TJvPopupListBox.KeyPress(var Key: Char);\r\nvar\r\n TickCount: Int64;\r\nbegin\r\n case Key of\r\n BackSpace, Esc:\r\n FSearchText := '';\r\n #32..#255:\r\n begin\r\n TickCount := GetTickCount;\r\n if TickCount < FSearchTickCount then\r\n Inc(TickCount, $100000000); // (ahuser) reduces the overflow\r\n if TickCount - FSearchTickCount >= 4000 then\r\n FSearchText := '';\r\n FSearchTickCount := TickCount;\r\n if Length(FSearchText) < 32 then\r\n FSearchText := FSearchText + Key;\r\n SendMessage(Handle, LB_SELECTSTRING, -1, LPARAM(PChar(FSearchText)));\r\n Key := #0;\r\n end;\r\n end;\r\n inherited KeyPress(Key);\r\nend;\r\n\r\ninitialization\r\n {$IFDEF UNITVERSIONING}\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n {$ENDIF UNITVERSIONING}\r\n {$IFDEF USE_DXGETTEXT}\r\n AddDomainForResourceString(cDomainName);\r\n {$ENDIF USE_DXGETTEXT}\r\n\r\n{$IFDEF UNITVERSIONING}\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvComponentBase.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvComponent.PAS, released on 2000-09-22.\r\n\r\nThe Initial Developer of the Original Code is Joe Doe .\r\nPortions created by Joe Doe are Copyright (C) 1999 Joe Doe.\r\nPortions created by XXXX Corp. are Copyright (C) 1998, 1999 XXXX Corp.\r\nAll Rights Reserved.\r\n\r\nContributor(s): -\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvComponentBase.pas 13145 2011-11-02 21:15:19Z ahuser $\r\n\r\nunit JvComponentBase;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Classes,\r\n {$IFDEF USE_DXGETTEXT}\r\n JvGnugettext,\r\n {$ENDIF USE_DXGETTEXT}\r\n JVCLVer;\r\n\r\ntype\r\n TJvComponent = class(TComponent)\r\n private\r\n FAboutJVCL: TJVCLAboutInfo;\r\n published\r\n property AboutJVCL: TJVCLAboutInfo read FAboutJVCL write FAboutJVCL stored False;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvComponentBase.pas $';\r\n Revision: '$Revision: 13145 $';\r\n Date: '$Date: 2011-11-02 22:15:19 +0100 (mer. 02 nov. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend." }, { "path": "External/Jedi/Jvcl/run/JvComponentPanel.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvComponentPanel.PAS, released on 2002-07-04.\r\n\r\nThe Initial Developers of the Original Code are: Andrei Prygounkov \r\nCopyright (c) 1999, 2002 Andrei Prygounkov\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\n Andreas Hausladen\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\ncomponents : TJvComponentPanel\r\ndescription: Component panel for GUI developers\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvComponentPanel.pas 13104 2011-09-07 06:50:43Z obones $\r\n\r\nunit JvComponentPanel;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, Messages,\r\n Classes, Controls, Buttons, Forms,\r\n JvButtons, JvExtComponent, JvExButtons;\r\n\r\ntype\r\n TButtonClick = procedure(Sender: TObject; Button: Integer) of object;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvComponentPanel = class(TJvCustomPanel)\r\n private\r\n FButtonWidth: Integer;\r\n FButtonHeight: Integer;\r\n FButtons: TList;\r\n FOnClick: TButtonClick;\r\n FOnDblClick: TButtonClick;\r\n FButtonPointer: TJvExSpeedButton;\r\n FButtonLeft: TJvNoFrameButton;\r\n FButtonRight: TJvNoFrameButton;\r\n FFirstVisible: Integer;\r\n FLockUpdate: Integer;\r\n FSelectButton: TJvExSpeedButton;\r\n function GetButton(Index: Integer): TJvExSpeedButton;\r\n function GetButtonCount: Integer;\r\n procedure SetButtonCount(AButtonCount: Integer);\r\n procedure SetButtonWidth(AButtonWidth: Integer);\r\n procedure SetButtonHeight(AButtonHeight: Integer);\r\n procedure SetFirstVisible(AButton: Integer);\r\n procedure BtnClick(Sender: TObject);\r\n procedure BtnDblClick(Sender: TObject);\r\n procedure MoveClick(Sender: TObject);\r\n function GetVisibleCount: Integer;\r\n procedure SetSelectedButton(Value: Integer);\r\n function GetSelectedButton: Integer;\r\n procedure WMSetText(var Msg: TWMSetText); message WM_SETTEXT;\r\n protected\r\n procedure Resize; override;\r\n function DoMouseWheel(Shift: TShiftState; WheelDelta: Integer; MousePos: TPoint): Boolean; override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n procedure RecreateButtons;\r\n procedure SetMainButton;\r\n procedure Invalidate; override;\r\n procedure BeginUpdate;\r\n procedure EndUpdate;\r\n property Buttons[Index: Integer]: TJvExSpeedButton read GetButton; default;\r\n property FirstVisible: Integer read FFirstVisible write SetFirstVisible;\r\n property ButtonLeft: TJvNoFrameButton read FButtonLeft;\r\n property ButtonRight: TJvNoFrameButton read FButtonRight;\r\n property VisibleCount: Integer read GetVisibleCount;\r\n property SelectedButton: Integer read GetSelectedButton write SetSelectedButton;\r\n published\r\n property Align;\r\n property OnClick: TButtonClick read FOnClick write FOnClick;\r\n property OnDblClick: TButtonClick read FOnDblClick write FOnDblClick;\r\n property ButtonWidth: Integer read FButtonWidth write SetButtonWidth default 28;\r\n property ButtonHeight: Integer read FButtonHeight write SetButtonHeight default 28;\r\n property ButtonCount: Integer read GetButtonCount write SetButtonCount default 0;\r\n property Anchors;\r\n property Constraints;\r\n property AutoSize;\r\n property BiDiMode;\r\n property UseDockManager default True;\r\n property DockSite;\r\n property ParentBiDiMode;\r\n property DragKind;\r\n property OnDockDrop;\r\n property OnDockOver;\r\n property OnEndDock;\r\n property OnGetSiteInfo;\r\n property OnStartDock;\r\n property OnUnDock;\r\n property OnCanResize;\r\n property OnConstrainedResize;\r\n property OnPaintContent;\r\n property PopupMenu;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvComponentPanel.pas $';\r\n Revision: '$Revision: 13104 $';\r\n Date: '$Date: 2011-09-07 08:50:43 +0200 (mer. 07 sept. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\n{$R JvComponentPanel.res}\r\n\r\nconstructor TJvComponentPanel.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n DoubleBuffered := True;\r\n BevelOuter := bvNone;\r\n FButtons := TList.Create;\r\n FFirstVisible := 0;\r\n FButtonWidth := 28;\r\n FButtonHeight := 28;\r\n FButtonLeft := TJvNoFrameButton.Create(Self);\r\n FButtonLeft.RepeatedClick := True;\r\n FButtonRight := TJvNoFrameButton.Create(Self);\r\n FButtonRight.RepeatedClick := True;\r\n FButtonPointer := TJvExSpeedButton.Create(Self);\r\n with FButtonLeft do\r\n begin\r\n Parent := Self;\r\n Tag := 0;\r\n Width := 12;\r\n Top := 0;\r\n Glyph.LoadFromResourceName(HInstance, 'JvComponentPanelLEFT');\r\n NumGlyphs := 2;\r\n OnClick := MoveClick;\r\n end;\r\n with FButtonRight do\r\n begin\r\n Parent := Self;\r\n Tag := 1;\r\n Width := 12;\r\n Top := 0;\r\n Glyph.LoadFromResourceName(HInstance, 'JvComponentPanelRIGHT');\r\n NumGlyphs := 2;\r\n OnClick := MoveClick;\r\n end;\r\n with FButtonPointer do\r\n begin\r\n Flat := True;\r\n Parent := Self;\r\n Top := 0;\r\n Glyph.LoadFromResourceName(HInstance, 'JvComponentPanelPOINTER');\r\n GroupIndex := 1;\r\n OnClick := BtnClick;\r\n end;\r\n SetMainButton;\r\nend;\r\n\r\ndestructor TJvComponentPanel.Destroy;\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := 0 to FButtons.Count - 1 do\r\n TSpeedButton(FButtons[I]).Free;\r\n FButtons.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvComponentPanel.Invalidate;\r\nbegin\r\n if FLockUpdate = 0 then\r\n inherited Invalidate;\r\nend;\r\n\r\nprocedure TJvComponentPanel.RecreateButtons;\r\nvar\r\n I: Integer;\r\n TmpNum: Integer;\r\nbegin\r\n TmpNum := FButtons.Count;\r\n for I := 0 to FButtons.Count - 1 do\r\n TSpeedButton(FButtons[I]).Free;\r\n FButtons.Clear;\r\n FFirstVisible := 0;\r\n ButtonCount := TmpNum;\r\nend;\r\n\r\nprocedure TJvComponentPanel.SetMainButton;\r\nbegin\r\n FButtonPointer.Down := True;\r\n FSelectButton := FButtonPointer;\r\nend;\r\n\r\nprocedure TJvComponentPanel.SetSelectedButton(Value: Integer);\r\nbegin\r\n if (Value <> GetSelectedButton) and (Value >= -1) and (Value < ButtonCount) then\r\n begin\r\n if Value = -1 then\r\n SetMainButton\r\n else\r\n begin\r\n FSelectButton := Buttons[Value];\r\n FSelectButton.Down := True;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJvComponentPanel.GetSelectedButton: Integer;\r\nbegin\r\n if FSelectButton <> nil then\r\n begin\r\n for Result := 0 to ButtonCount - 1 do\r\n if Buttons[Result] = FSelectButton then\r\n Exit;\r\n end;\r\n Result := -1;\r\nend;\r\n\r\nfunction TJvComponentPanel.GetButton(Index: Integer): TJvExSpeedButton;\r\nbegin\r\n if (Index < 0) or (Index > FButtons.Count - 1) then\r\n Result := nil\r\n else\r\n Result := TJvExSpeedButton(FButtons[Index]);\r\nend;\r\n\r\nfunction TJvComponentPanel.GetButtonCount: Integer;\r\nbegin\r\n Result := FButtons.Count;\r\nend;\r\n\r\nfunction TJvComponentPanel.GetVisibleCount: Integer;\r\nbegin\r\n Result := (Width - (12 + 12 + FButtonWidth)) div FButtonWidth;\r\nend;\r\n\r\nprocedure TJvComponentPanel.SetButtonCount(AButtonCount: Integer);\r\nvar\r\n TmpButton: TJvExSpeedButton;\r\nbegin\r\n if AButtonCount < 0 then\r\n Exit;\r\n BeginUpdate;\r\n try\r\n SetMainButton;\r\n while FButtons.Count > AButtonCount do\r\n begin\r\n TSpeedButton(FButtons[FButtons.Count - 1]).Free;\r\n FButtons.Delete(FButtons.Count - 1);\r\n end;\r\n while FButtons.Count < AButtonCount do\r\n begin\r\n TmpButton := TJvExSpeedButton.Create(Self);\r\n with TmpButton do\r\n begin\r\n Flat := True;\r\n Top := 0;\r\n GroupIndex := 1;\r\n HintWindowClass := Self.HintWindowClass;\r\n Parent := Self;\r\n OnClick := BtnClick;\r\n OnDblClick := BtnDblClick;\r\n end;\r\n FButtons.Add(TmpButton);\r\n end;\r\n finally\r\n EndUpdate;\r\n end;\r\nend;\r\n\r\nprocedure TJvComponentPanel.SetButtonWidth(AButtonWidth: Integer);\r\nbegin\r\n if FButtonWidth <> AButtonWidth then\r\n begin\r\n FButtonWidth := AButtonWidth;\r\n Resize;\r\n end;\r\nend;\r\n\r\nprocedure TJvComponentPanel.SetButtonHeight(AButtonHeight: Integer);\r\nbegin\r\n if FButtonHeight <> AButtonHeight then\r\n begin\r\n FButtonHeight := AButtonHeight;\r\n Resize;\r\n end;\r\nend;\r\n\r\nprocedure TJvComponentPanel.MoveClick(Sender: TObject);\r\nbegin\r\n case TSpeedButton(Sender).Tag of\r\n 0:\r\n if FFirstVisible > 0 then\r\n Dec(FFirstVisible);\r\n 1:\r\n if FButtons.Count > FFirstVisible + VisibleCount then\r\n Inc(FFirstVisible);\r\n end;\r\n Resize;\r\nend;\r\n\r\nprocedure TJvComponentPanel.BtnClick(Sender: TObject);\r\nbegin\r\n if FSelectButton <> Sender then\r\n begin\r\n FSelectButton := TJvExSpeedButton(Sender);\r\n if Assigned(FOnClick) then\r\n FOnClick(Sender, FButtons.IndexOf(FSelectButton));\r\n end;\r\nend;\r\n\r\nprocedure TJvComponentPanel.BtnDblClick(Sender: TObject);\r\nbegin\r\n if Assigned(FOnDblClick) then\r\n FOnDblClick(Sender, FButtons.IndexOf(Sender));\r\nend;\r\n\r\n\r\nprocedure TJvComponentPanel.WMSetText(var Msg: TWMSetText);\r\nbegin\r\n inherited;\r\n Caption := '';\r\nend;\r\n\r\n\r\n\r\n\r\nprocedure TJvComponentPanel.Resize;\r\nvar\r\n I: Integer;\r\nbegin\r\n Height := FButtonHeight;\r\n if FButtonPointer = nil then\r\n Exit; // asn: for visualclx\r\n DisableAlign;\r\n try\r\n FButtonPointer.Height := FButtonHeight;\r\n FButtonPointer.Width := FButtonWidth;\r\n FButtonLeft.Height := FButtonHeight;\r\n FButtonRight.Height := FButtonHeight;\r\n FButtonPointer.Left := 0;\r\n FButtonLeft.Left := FButtonWidth + 6;\r\n FButtonRight.Left := (FButtonWidth + 12 + 6) + VisibleCount * FButtonWidth;\r\n FButtonLeft.Enabled := FFirstVisible > 0;\r\n FButtonRight.Enabled := FButtons.Count > FFirstVisible + VisibleCount;\r\n for I := 0 to FButtons.Count - 1 do\r\n begin\r\n if (I >= FFirstVisible) and (I < FFirstVisible + VisibleCount) then\r\n TSpeedButton(FButtons[I]).SetBounds((FButtonWidth + 12 + 6) + (I - FFirstVisible) * FButtonWidth, 0, FButtonWidth, FButtonHeight)\r\n else\r\n TSpeedButton(FButtons[I]).SetBounds(-100, 0, FButtonWidth, FButtonHeight);\r\n end;\r\n finally\r\n ControlState := ControlState - [csAlignmentNeeded];\r\n EnableAlign;\r\n end;\r\nend;\r\n\r\nfunction TJvComponentPanel.DoMouseWheel(Shift: TShiftState; WheelDelta: Integer;\r\n MousePos: TPoint): Boolean;\r\nbegin\r\n Result := inherited DoMouseWheel(Shift, WheelDelta, MousePos);\r\n if not Result then\r\n begin\r\n Result := True;\r\n\r\n WheelDelta := WheelDelta div WHEEL_DELTA;\r\n while WheelDelta <> 0 do\r\n begin\r\n if WheelDelta < 0 then\r\n begin\r\n if ButtonRight.Enabled then\r\n ButtonRight.Click\r\n else\r\n Break;\r\n end\r\n else\r\n begin\r\n if ButtonLeft.Enabled then\r\n ButtonLeft.Click\r\n else\r\n Break;\r\n end;\r\n\r\n if WheelDelta < 0 then\r\n Inc(WheelDelta)\r\n else\r\n Dec(WheelDelta);\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvComponentPanel.SetFirstVisible(AButton: Integer);\r\nbegin\r\n if AButton >= ButtonCount then\r\n AButton := ButtonCount - 1;\r\n if AButton < 0 then\r\n AButton := 0;\r\n if FFirstVisible <> AButton then\r\n begin\r\n FFirstVisible := AButton;\r\n Resize;\r\n end;\r\nend;\r\n\r\nprocedure TJvComponentPanel.BeginUpdate;\r\nbegin\r\n Inc(FLockUpdate);\r\n DisableAlign;\r\nend;\r\n\r\nprocedure TJvComponentPanel.EndUpdate;\r\nbegin\r\n Dec(FLockUpdate);\r\n if FLockUpdate = 0 then\r\n begin\r\n Resize;\r\n ControlState := ControlState - [csAlignmentNeeded];\r\n EnableAlign;\r\n end;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend." }, { "path": "External/Jedi/Jvcl/run/JvComputerInfoEx.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvComputerInfoEx.PAS, released on 2004-03-07.\r\n\r\nThe Initial Developer of the Original Code is Peter Thrnqvist [peter3 at sourceforge dot net]\r\nPortions created by Peter Thrnqvist are Copyright (C) 2004 Peter Thrnqvist.\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\nAndr?nepvangers - better TimeRunning\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nDescription\r\n A read-only computer info component. Subproperties are created as needed so loading\r\n at run-time should be pretty fast.\r\n\r\n This component replaces JvComputerInfo, JvKeyboardStates, JvDeviceChanged, JvDirectories\r\n and JvSystemColors.\r\n\r\nKnown Issues:\r\n * ADO version info might not be correct/available on all systems (depending on the ADO version installed)\r\n * ResetSystemIcons only tested on W2k\r\n\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvComputerInfoEx.pas 13397 2012-08-16 17:23:19Z ahuser $\r\n\r\nunit JvComputerInfoEx;\r\n\r\n{$I jvcl.inc}\r\n{$I windowsonly.inc}\r\n\r\n{$HPPEMIT '#pragma link \"wininet.lib\"'}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, Messages, SysUtils, ShlObj, ShellAPI,\r\n Classes, Graphics, Controls,\r\n JclWin32, JclSysInfo,\r\n JvJVCLUtils, JvComponentBase, JvTypes;\r\n\r\n{$HPPEMIT '#include '}\r\n// these are defined here to avoid including DBT.pas\r\nconst\r\n {$EXTERNALSYM DBT_DEVICEARRIVAL}\r\n DBT_DEVICEARRIVAL = $8000; { system detected a new device }\r\n {$EXTERNALSYM DBT_DEVICEREMOVECOMPLETE}\r\n DBT_DEVICEREMOVECOMPLETE = $8004; { device is gone }\r\n {$EXTERNALSYM DBT_DEVTYP_VOLUME}\r\n DBT_DEVTYP_VOLUME = $00000002; { logical volume }\r\n {$EXTERNALSYM DBTF_MEDIA}\r\n DBTF_MEDIA = $0001; { media comings and goings }\r\n\r\n // new params for SystemParametersInfo not defined in Windows\r\n SPI_GETDESKWALLPAPER = $0073;\r\n {$EXTERNALSYM SPI_GETDESKWALLPAPER}\r\n SPI_GETMOUSESONAR = $101C;\r\n {$EXTERNALSYM SPI_GETMOUSESONAR}\r\n SPI_SETMOUSESONAR = $101D;\r\n {$EXTERNALSYM SPI_SETMOUSESONAR}\r\n SPI_GETMOUSECLICKLOCK = $101E;\r\n {$EXTERNALSYM SPI_GETMOUSECLICKLOCK}\r\n SPI_SETMOUSECLICKLOCK = $101F;\r\n {$EXTERNALSYM SPI_SETMOUSECLICKLOCK}\r\n SPI_GETMOUSEVANISH = $1020;\r\n {$EXTERNALSYM SPI_GETMOUSEVANISH}\r\n SPI_SETMOUSEVANISH = $1021;\r\n {$EXTERNALSYM SPI_SETMOUSEVANISH}\r\n SPI_GETFLATMENU = $1022;\r\n {$EXTERNALSYM SPI_GETFLATMENU}\r\n SPI_SETFLATMENU = $1023;\r\n {$EXTERNALSYM SPI_SETFLATMENU}\r\n SPI_GETDROPSHADOW = $1024;\r\n {$EXTERNALSYM SPI_GETDROPSHADOW}\r\n SPI_SETDROPSHADOW = $1025;\r\n {$EXTERNALSYM SPI_SETDROPSHADOW}\r\n\r\n SPI_GETFOREGROUNDLOCKTIMEOUT = $2000;\r\n {$EXTERNALSYM SPI_GETFOREGROUNDLOCKTIMEOUT}\r\n SPI_SETFOREGROUNDLOCKTIMEOUT = $2001;\r\n {$EXTERNALSYM SPI_SETFOREGROUNDLOCKTIMEOUT}\r\n SPI_GETACTIVEWNDTRKTIMEOUT = $2002;\r\n {$EXTERNALSYM SPI_GETACTIVEWNDTRKTIMEOUT}\r\n SPI_SETACTIVEWNDTRKTIMEOUT = $2003;\r\n {$EXTERNALSYM SPI_SETACTIVEWNDTRKTIMEOUT}\r\n SPI_GETFOREGROUNDFLASHCOUNT = $2004;\r\n {$EXTERNALSYM SPI_GETFOREGROUNDFLASHCOUNT}\r\n SPI_SETFOREGROUNDFLASHCOUNT = $2005;\r\n {$EXTERNALSYM SPI_SETFOREGROUNDFLASHCOUNT}\r\n SPI_GETCARETWIDTH = $2006;\r\n {$EXTERNALSYM SPI_GETCARETWIDTH}\r\n SPI_SETCARETWIDTH = $2007;\r\n {$EXTERNALSYM SPI_SETCARETWIDTH}\r\n\r\n SPI_GETMOUSECLICKLOCKTIME = $2008;\r\n {$EXTERNALSYM SPI_GETMOUSECLICKLOCKTIME}\r\n SPI_SETMOUSECLICKLOCKTIME = $2009;\r\n {$EXTERNALSYM SPI_SETMOUSECLICKLOCKTIME}\r\n SPI_GETFONTSMOOTHINGTYPE = $200A;\r\n {$EXTERNALSYM SPI_GETFONTSMOOTHINGTYPE}\r\n SPI_SETFONTSMOOTHINGTYPE = $200B;\r\n {$EXTERNALSYM SPI_SETFONTSMOOTHINGTYPE}\r\n\r\n { constants for SPI_GETFONTSMOOTHINGTYPE and SPI_SETFONTSMOOTHINGTYPE: }\r\n FE_FONTSMOOTHINGSTANDARD = $0001;\r\n {$EXTERNALSYM FE_FONTSMOOTHINGSTANDARD}\r\n FE_FONTSMOOTHINGCLEARTYPE = $0002;\r\n {$EXTERNALSYM FE_FONTSMOOTHINGCLEARTYPE}\r\n FE_FONTSMOOTHINGDOCKING = $8000;\r\n {$EXTERNALSYM FE_FONTSMOOTHINGDOCKING}\r\n\r\n SPI_GETFONTSMOOTHINGCONTRAST = $200C;\r\n {$EXTERNALSYM SPI_GETFONTSMOOTHINGCONTRAST}\r\n SPI_SETFONTSMOOTHINGCONTRAST = $200D;\r\n {$EXTERNALSYM SPI_SETFONTSMOOTHINGCONTRAST}\r\n\r\n SPI_GETFOCUSBORDERWIDTH = $200E;\r\n {$EXTERNALSYM SPI_GETFOCUSBORDERWIDTH}\r\n SPI_SETFOCUSBORDERWIDTH = $200F;\r\n {$EXTERNALSYM SPI_SETFOCUSBORDERWIDTH}\r\n SPI_GETFOCUSBORDERHEIGHT = $2010;\r\n {$EXTERNALSYM SPI_GETFOCUSBORDERHEIGHT}\r\n SPI_SETFOCUSBORDERHEIGHT = $2011;\r\n {$EXTERNALSYM SPI_SETFOCUSBORDERHEIGHT}\r\n\r\ntype\r\n EJVCLComputerInfoEx = class(EJVCLException);\r\n\r\n {$EXTERNALSYM PDevBroadcastHdr}\r\n PDevBroadcastHdr = ^TDevBroadcastHdr;\r\n {$EXTERNALSYM DEV_BROADCAST_HDR}\r\n DEV_BROADCAST_HDR = packed record\r\n dbch_size: DWORD;\r\n dbch_devicetype: DWORD;\r\n dbch_reserved: DWORD;\r\n end;\r\n TDevBroadcastHdr = DEV_BROADCAST_HDR;\r\n\r\n {$EXTERNALSYM PDevBroadcastVolume}\r\n PDevBroadcastVolume = ^TDevBroadcastVolume;\r\n {$EXTERNALSYM DEV_BROADCAST_VOLUME}\r\n DEV_BROADCAST_VOLUME = packed record\r\n dbcv_size: DWORD;\r\n dbcv_devicetype: DWORD;\r\n dbcv_reserved: DWORD;\r\n dbcv_unitmask: DWORD;\r\n dbcv_flags: Word;\r\n end;\r\n TDevBroadcastVolume = DEV_BROADCAST_VOLUME;\r\n\r\n TWMDeviceChange = record\r\n Msg: Cardinal;\r\n {$IFDEF COMPILER16_UP}\r\n MsgFiller: TDWordFiller;\r\n {$ENDIF COMPILER16_UP}\r\n Event: WPARAM;\r\n dwData: Pointer;\r\n Result: LRESULT;\r\n end;\r\n\r\n // TJvReadOnlyInfo doesn't have any writeable properties\r\n TJvReadOnlyInfo = class(TPersistent);\r\n\r\n // TJvWriteableInfo have at least one writeable property\r\n // and also have a ReadOnly property that controls whether the properties\r\n // are allowed to change\r\n TJvWriteableInfo = class(TPersistent)\r\n private\r\n FReadOnly: Boolean;\r\n protected\r\n property ReadOnly: Boolean read FReadOnly write FReadOnly default True;\r\n public\r\n constructor Create;\r\n end;\r\n\r\n TJvAPMInfo = class(TJvReadOnlyInfo)\r\n private\r\n function GetAPMBatteryFlag: TAPMBatteryFlag;\r\n function GetAPMBatteryFullLifeTime: DWORD;\r\n function GetAPMBatteryLifePercent: Integer;\r\n function GetAPMBatteryLifeTime: DWORD;\r\n function GetAPMLineStatus: TAPMLineStatus;\r\n procedure SetAPMBatteryFlag(const Value: TAPMBatteryFlag);\r\n procedure SetAPMBatteryFullLifeTime(const Value: DWORD);\r\n procedure SetAPMBatteryLifePercent(const Value: Integer);\r\n procedure SetAPMBatteryLifeTime(const Value: DWORD);\r\n procedure SetAPMLineStatus(const Value: TAPMLineStatus);\r\n published\r\n property LineStatus: TAPMLineStatus read GetAPMLineStatus write SetAPMLineStatus stored False;\r\n property BatteryFlag: TAPMBatteryFlag read GetAPMBatteryFlag write SetAPMBatteryFlag stored False;\r\n property BatteryLifePercent: Integer read GetAPMBatteryLifePercent write SetAPMBatteryLifePercent stored False;\r\n property BatteryLifeTime: DWORD read GetAPMBatteryLifeTime write SetAPMBatteryLifeTime stored False;\r\n property BatteryFullLifeTime: DWORD read GetAPMBatteryFullLifeTime write SetAPMBatteryFullLifeTime stored False;\r\n end;\r\n\r\n TJvOSVersionInfo = class(TJvReadOnlyInfo)\r\n private\r\n function GetProductType: TNtProductType;\r\n function GetWinProductID: string;\r\n function GetWinProductName: string;\r\n function GetWinVersionBuild: DWORD;\r\n function GetWinVersionMajor: DWORD;\r\n function GetWinVersionMinor: DWORD;\r\n function GetWinVersionCSDString: string;\r\n procedure SetProductType(const Value: TNtProductType);\r\n procedure SetWinProductID(const Value: string);\r\n procedure SetWinProductName(const Value: string);\r\n procedure SetWinVersionBuild(const Value: DWORD);\r\n procedure SetWinVersionMajor(const Value: DWORD);\r\n procedure SetWinVersionMinor(const Value: DWORD);\r\n procedure SetWinVersionCSDString(const Value: string);\r\n function GetWinServicePackVersion: DWORD;\r\n procedure SetWinServicePackVersion(const Value: DWORD);\r\n function GetOSVersion: TWindowsVersion;\r\n procedure SetOSVersion(const Value: TWindowsVersion);\r\n published\r\n property OSVersion: TWindowsVersion read GetOSVersion write SetOSVersion stored False;\r\n property ProductType: TNtProductType read GetProductType write SetProductType stored False;\r\n property ProductID: string read GetWinProductID write SetWinProductID stored False;\r\n property ProductName: string read GetWinProductName write SetWinProductName stored False;\r\n property ServicePackVersion: DWORD read GetWinServicePackVersion write SetWinServicePackVersion stored False;\r\n property VersionBuild: DWORD read GetWinVersionBuild write SetWinVersionBuild stored False;\r\n property VersionMajor: DWORD read GetWinVersionMajor write SetWinVersionMajor stored False;\r\n property VersionMinor: DWORD read GetWinVersionMinor write SetWinVersionMinor stored False;\r\n property VersionCSDString: string read GetWinVersionCSDString write SetWinVersionCSDString stored False;\r\n end;\r\n\r\n TJvCPUType = (cpuUnknown, cpuIntel, cpuCyrix, cpuAMD, cpuCrusoe);\r\n\r\n TJvCPUInfo = class(TJvReadOnlyInfo)\r\n private\r\n function GetCPUInfo: TCPUInfo;\r\n function GetCPUSpeed: TFreqInfo;\r\n function GetCPUName: string;\r\n function GetCPUType: TJvCPUType;\r\n function GetExTicks: Cardinal;\r\n function GetFamily: Byte;\r\n function GetFeatures: Cardinal;\r\n function GetHasCacheInfo: Boolean;\r\n function GetHasExtendedInfo: Boolean;\r\n function GetHasInstruction: Boolean;\r\n function GetInCycles: Cardinal;\r\n function GetIsFDIVOK: Boolean;\r\n function GetManufacturer: string;\r\n function GetMMX: Boolean;\r\n function GetSSE: TSSESupports;\r\n function GetModel: Byte;\r\n function GetNormFreq: Int64;\r\n function GetRawFreq: Int64;\r\n function GetStepping: Byte;\r\n function GetVendorIDString: string;\r\n function GetProcessorCount: Integer;\r\n function Get3DNow: Boolean;\r\n function GetEx3DNow: Boolean;\r\n function GetExMMX: Boolean;\r\n function GetIs64Bits: Boolean;\r\n function GetL1CodeCache: Cardinal;\r\n function GetL1DataCache: Cardinal;\r\n function GetL2Cache: Cardinal;\r\n function GetL3Cache: Cardinal;\r\n function GetDEPCapable: Boolean;\r\n function GetLogicalCore: Byte;\r\n function GetPhysicalCore: Byte;\r\n function GetHyperThreadingTechnology: Boolean;\r\n procedure SetCPUName(const Value: string);\r\n procedure SetCPUType(const Value: TJvCPUType);\r\n procedure SetExTicks(const Value: Cardinal);\r\n procedure SetFamily(const Value: Byte);\r\n procedure SetFeatures(const Value: Cardinal);\r\n procedure SetHasCacheInfo(const Value: Boolean);\r\n procedure SetHasExtendedInfo(const Value: Boolean);\r\n procedure SetHasInstruction(const Value: Boolean);\r\n procedure SetInCycles(const Value: Cardinal);\r\n procedure SetIsFDIVOK(const Value: Boolean);\r\n procedure SetManufacturer(const Value: string);\r\n procedure SetMMX(const Value: Boolean);\r\n procedure SetSSE(const Value: TSSESupports);\r\n procedure SetModel(const Value: Byte);\r\n procedure SetNormFreq(const Value: Int64);\r\n procedure SetRawFreq(const Value: Int64);\r\n procedure SetStepping(const Value: Byte);\r\n procedure SetVendorIDString(const Value: string);\r\n procedure SetProcessorCount(const Value: Integer);\r\n procedure Set3DNow(const Value: Boolean);\r\n procedure SetEx3DNow(const Value: Boolean);\r\n procedure SetExMMX(const Value: Boolean);\r\n procedure SetIs64Bits(const Value: Boolean);\r\n procedure SetL1CodeCache(const Value: Cardinal);\r\n procedure SetL1DataCache(const Value: Cardinal);\r\n procedure SetL2Cache(const Value: Cardinal);\r\n procedure SetL3Cache(const Value: Cardinal);\r\n procedure SetDEPCapable(const Value: Boolean);\r\n procedure SetLogicalCore(const Value: Byte);\r\n procedure SetPhysicalCore(const Value: Byte);\r\n procedure SetHyperThreadingTechnology(const Value: Boolean);\r\n public\r\n function IntelSpecific: TIntelSpecific;\r\n function CyrixSpecific: TCyrixSpecific;\r\n function AMDSpecific: TAMDSpecific;\r\n function TransmetaSpecific: TTransmetaSpecific;\r\n function ViaSpecific: TViaSpecific;\r\n public\r\n property Features: Cardinal read GetFeatures write SetFeatures stored False;\r\n property TotalCycles: Cardinal read GetInCycles write SetInCycles stored False;\r\n property TotalTicks: Cardinal read GetExTicks write SetExTicks stored False;\r\n published\r\n // CPUInfo\r\n property HasInstruction: Boolean read GetHasInstruction write SetHasInstruction stored False;\r\n property MMX: Boolean read GetMMX write SetMMX stored False;\r\n property SSE: TSSESupports read GetSSE write SetSSE stored False;\r\n property IsFDIVOK: Boolean read GetIsFDIVOK write SetIsFDIVOK stored False;\r\n property HasCacheInfo: Boolean read GetHasCacheInfo write SetHasCacheInfo stored False;\r\n property HasExtendedInfo: Boolean read GetHasExtendedInfo write SetHasExtendedInfo stored False;\r\n property CPUType: TJvCPUType read GetCPUType write SetCPUType stored False;\r\n property Family: Byte read GetFamily write SetFamily stored False;\r\n property Model: Byte read GetModel write SetModel stored False;\r\n property Stepping: Byte read GetStepping write SetStepping stored False;\r\n property VendorIDString: string read GetVendorIDString write SetVendorIDString stored False;\r\n property Manufacturer: string read GetManufacturer write SetManufacturer stored False;\r\n property Name: string read GetCPUName write SetCPUName stored False;\r\n property ProcessorCount: Integer read GetProcessorCount write SetProcessorCount stored False;\r\n property Is64Bits: Boolean read GetIs64Bits write SetIs64Bits stored False;\r\n property ExMMX: Boolean read GetExMMX write SetExMMX stored False;\r\n property _3DNow: Boolean read Get3DNow write Set3DNow stored False;\r\n property Ex3DNow: Boolean read GetEx3DNow write SetEx3DNow stored False;\r\n property L1DataCache: Cardinal read GetL1DataCache write SetL1DataCache stored False;\r\n property L1CodeCache: Cardinal read GetL1CodeCache write SetL1CodeCache stored False;\r\n property L2Cache: Cardinal read GetL2Cache write SetL2Cache stored False;\r\n property L3Cache: Cardinal read GetL3Cache write SetL3Cache stored False;\r\n // FreqInfo\r\n property RawFreq: Int64 read GetRawFreq write SetRawFreq stored False;\r\n property NormFreq: Int64 read GetNormFreq write SetNormFreq stored False;\r\n property DEPCapable: Boolean read GetDEPCapable write SetDEPCapable stored False;\r\n property PhysicalCore: Byte read GetPhysicalCore write SetPhysicalCore stored False;\r\n property LogicalCore: Byte read GetLogicalCore write SetLogicalCore stored False;\r\n property HyperThreadingTechnology: Boolean read GetHyperThreadingTechnology write SetHyperThreadingTechnology stored False;\r\n end;\r\n\r\n TJvBIOSInfo = class(TJvReadOnlyInfo)\r\n private\r\n function GetBIOSCopyright: string;\r\n function GetBIOSDate: TDateTime;\r\n function GetBIOSExtendedInfo: string;\r\n function GetBIOSName: string;\r\n procedure SetBIOSCopyright(const Value: string);\r\n procedure SetBIOSDate(const Value: TDateTime);\r\n procedure SetBIOSExtendedInfo(const Value: string);\r\n procedure SetBIOSName(const Value: string);\r\n published\r\n property Name: string read GetBIOSName write SetBIOSName stored False;\r\n property Copyright: string read GetBIOSCopyright write SetBIOSCopyright stored False;\r\n property ExtendedInfo: string read GetBIOSExtendedInfo write SetBIOSExtendedInfo stored False;\r\n property Date: TDateTime read GetBIOSDate write SetBIOSDate stored False;\r\n end;\r\n\r\n TJvSystemFolders = class(TJvWriteableInfo)\r\n // writeable: Current\r\n private\r\n FTrailingPathDelimiter: Boolean;\r\n function GetCurrent: string;\r\n function Get(const Index: Integer): string;\r\n function GetProgramFiles: string;\r\n function GetWindows: string;\r\n function GetSystem: string;\r\n function GetTemp: string;\r\n procedure SetCommonFiles(const Value: string);\r\n procedure SetCurrent(const Value: string);\r\n procedure Put(const Index: Integer; const Value: string);\r\n procedure SetProgramFiles(const Value: string);\r\n procedure SetWindows(const Value: string);\r\n procedure SetSystem(const Value: string);\r\n procedure SetTemp(const Value: string);\r\n function GetCommonFiles: string;\r\n function AdjustPathDelimiter(const S: string): string;\r\n published\r\n property TrailingPathDelimiter: Boolean read FTrailingPathDelimiter write FTrailingPathDelimiter default False;\r\n property CommonFiles: string read GetCommonFiles write SetCommonFiles stored False;\r\n property Current: string read GetCurrent write SetCurrent stored False;\r\n property ProgramFiles: string read GetProgramFiles write SetProgramFiles stored False;\r\n property Windows: string read GetWindows write SetWindows stored False;\r\n property System: string read GetSystem write SetSystem stored False;\r\n property Temp: string read GetTemp write SetTemp stored False;\r\n property Desktop: string index CSIDL_DESKTOP read Get write Put stored False;\r\n property Programs: string index CSIDL_PROGRAMS read Get write Put stored False;\r\n property Personal: string index CSIDL_PERSONAL read Get write Put stored False;\r\n property Favorites: string index CSIDL_FAVORITES read Get write Put stored False;\r\n property Startup: string index CSIDL_STARTUP read Get write Put stored False;\r\n property Recent: string index CSIDL_RECENT read Get write Put stored False;\r\n property SendTo: string index CSIDL_SENDTO read Get write Put stored False;\r\n property StartMenu: string index CSIDL_STARTMENU read Get write Put stored False;\r\n property DesktopDirectory: string index CSIDL_DESKTOPDIRECTORY read Get write Put stored False;\r\n property Nethood: string index CSIDL_NETHOOD read Get write Put stored False;\r\n property Fonts: string index CSIDL_FONTS read Get write Put stored False;\r\n property CommonStartmenu: string index CSIDL_COMMON_STARTMENU read Get write Put stored False;\r\n property CommonPrograms: string index CSIDL_COMMON_PROGRAMS read Get write Put stored False;\r\n property CommonStartup: string index CSIDL_COMMON_STARTUP read Get write Put stored False;\r\n property CommonDesktopDirectory: string index CSIDL_COMMON_DESKTOPDIRECTORY read Get write Put stored False;\r\n property CommonAppData: string index CSIDL_COMMON_APPDATA read Get write Put stored False;\r\n property AppData: string index CSIDL_APPDATA read Get write Put stored False;\r\n property Printhood: string index CSIDL_PRINTHOOD read Get write Put stored False;\r\n property CommonFavorites: string index CSIDL_COMMON_FAVORITES read Get write Put stored False;\r\n property Templates: string index CSIDL_TEMPLATES read Get write Put stored False;\r\n property InternetCache: string index CSIDL_INTERNET_CACHE read Get write Put stored False;\r\n property Cookies: string index CSIDL_COOKIES read Get write Put stored False;\r\n property History: string index CSIDL_HISTORY read Get write Put stored False;\r\n property Profile: string index CSIDL_PROFILE read Get write Put stored False;\r\n end;\r\n\r\n TJvMemInfo = class(TJvReadOnlyInfo)\r\n private\r\n function GetFreePageFileMemory: Int64;\r\n function GetFreePhysicalMemory: Int64;\r\n function GetFreeVirtualMemory: Int64;\r\n function GetMaxAppAddress: Integer;\r\n function GetMemoryLoad: Int64;\r\n function GetMinAppAddress: Integer;\r\n function GetSwapFileSize: Int64;\r\n function GetSwapFileUsage: Integer;\r\n function GetTotalPageFileMemory: Int64;\r\n function GetTotalPhysicalMemory: Int64;\r\n function GetTotalVirtualMemory: Int64;\r\n procedure SetFreePageFileMemory(const Value: Int64);\r\n procedure SetFreePhysicalMemory(const Value: Int64);\r\n procedure SetFreeVirtualMemory(const Value: Int64);\r\n procedure SetMaxAppAddress(const Value: Integer);\r\n procedure SetMemoryLoad(const Value: Int64);\r\n procedure SetMinAppAddress(const Value: Integer);\r\n procedure SetSwapFileSize(const Value: Int64);\r\n procedure SetSwapFileUsage(const Value: Integer);\r\n procedure SetTotalPageFileMemory(const Value: Int64);\r\n procedure SetTotalPhysicalMemory(const Value: Int64);\r\n procedure SetTotalVirtualMemory(const Value: Int64);\r\n published\r\n property MaxAppAddress: Integer read GetMaxAppAddress write SetMaxAppAddress stored False;\r\n property MinAppAddress: Integer read GetMinAppAddress write SetMinAppAddress stored False;\r\n property MemoryLoad: Int64 read GetMemoryLoad write SetMemoryLoad stored False;\r\n property SwapFileSize: Int64 read GetSwapFileSize write SetSwapFileSize stored False;\r\n property SwapFileUsage: Integer read GetSwapFileUsage write SetSwapFileUsage stored False;\r\n property TotalPhysicalMemory: Int64 read GetTotalPhysicalMemory write SetTotalPhysicalMemory stored False;\r\n property FreePhysicalMemory: Int64 read GetFreePhysicalMemory write SetFreePhysicalMemory stored False;\r\n property TotalPageFileMemory: Int64 read GetTotalPageFileMemory write SetTotalPageFileMemory stored False;\r\n property FreePageFileMemory: Int64 read GetFreePageFileMemory write SetFreePageFileMemory stored False;\r\n property TotalVirtualMemory: Int64 read GetTotalVirtualMemory write SetTotalVirtualMemory stored False;\r\n property FreeVirtualMemory: Int64 read GetFreeVirtualMemory write SetFreeVirtualMemory stored False;\r\n end;\r\n\r\n TJvKeyInfo = class(TJvWriteableInfo)\r\n // writeable: KeyState[], NumLock, ScrollLock, CapsLock\r\n private\r\n function GetCapsLockKeyState: Boolean;\r\n function GetKeyState(const VirtualKey: Cardinal): Boolean;\r\n function GetNumLockKeyState: Boolean;\r\n function GetScrollLockKeyState: Boolean;\r\n procedure SetCapsLockKeyState(const Value: Boolean);\r\n procedure SetKeyState(const VirtualKey: Cardinal; const Value: Boolean);\r\n procedure SetNumLockKeyState(const Value: Boolean);\r\n procedure SetScrollLockKeyState(const Value: Boolean);\r\n public\r\n property KeyState[const VirtualKey: Cardinal]: Boolean read GetKeyState write SetKeyState;\r\n published\r\n property NumLock: Boolean read GetNumLockKeyState write SetNumLockKeyState stored False;\r\n property ScrollLock: Boolean read GetScrollLockKeyState write SetScrollLockKeyState stored False;\r\n property CapsLock: Boolean read GetCapsLockKeyState write SetCapsLockKeyState stored False;\r\n end;\r\n\r\n TJvIdentification = class(TJvWriteableInfo)\r\n // writeable: ComputerName (reboot needed), RegisteredCompany, RegisteredOwner, Comment (Win95, 98 and XP only)\r\n private\r\n function GetDomainName: string;\r\n function GetLocalComputerName: string;\r\n function GetLocalUserName: string;\r\n function GetLocalWorkgroup: string;\r\n function GetRegisteredCompany: string;\r\n function GetRegisteredOwner: string;\r\n function GetHostIPAddress(const HostName: string): string;\r\n function GetUserDomainName(const CurUser: string): string;\r\n function GetVolumeFileSystem(const Drive: string): string;\r\n function GetVolumeName(const Drive: string): string;\r\n function GetVolumeSerialNumber(const Drive: string): string;\r\n function GetIPAddress: string;\r\n procedure SetDomainName(const Value: string);\r\n procedure SetLocalComputerName(const Value: string);\r\n procedure SetLocalUserName(const Value: string);\r\n procedure SetLocalWorkgroup(const Value: string);\r\n procedure SetRegisteredCompany(const Value: string);\r\n procedure SetRegisteredOwner(const Value: string);\r\n procedure SetIPAddress(const Value: string);\r\n function GetComment: string;\r\n procedure SetComment(const Value: string);\r\n public\r\n property VolumeName[const Drive: string]: string read GetVolumeName;\r\n property VolumeSerialNumber[const Drive: string]: string read GetVolumeSerialNumber;\r\n property VolumeFileSystem[const Drive: string]: string read GetVolumeFileSystem;\r\n property HostIPAddress[const HostName: string]: string read GetHostIPAddress;\r\n property UserDomainName[const CurUser: string]: string read GetUserDomainName;\r\n published\r\n property IPAddress: string read GetIPAddress write SetIPAddress;\r\n property LocalComputerName: string read GetLocalComputerName write SetLocalComputerName stored False;\r\n property LocalUserName: string read GetLocalUserName write SetLocalUserName stored False;\r\n property LocalWorkgroup: string read GetLocalWorkgroup write SetLocalWorkgroup stored False;\r\n property DomainName: string read GetDomainName write SetDomainName stored False;\r\n property RegisteredCompany: string read GetRegisteredCompany write SetRegisteredCompany stored False;\r\n property RegisteredOwner: string read GetRegisteredOwner write SetRegisteredOwner stored False;\r\n // NB!!! \"Comment\" property only supported on Win95, 96 and some NT OS's!\r\n property Comment: string read GetComment write SetComment stored False;\r\n end;\r\n\r\n TJvDisplayFlags = set of (dmGrayScale, dmInterlaced);\r\n TJvScreenMode = class(TJvReadOnlyInfo)\r\n private\r\n FHz: DWORD;\r\n FBitsPerPixel: DWORD;\r\n FWidth: Integer;\r\n FHeight: Integer;\r\n FFlags: TJvDisplayFlags;\r\n procedure SetBitsPerPixel(const Value: DWORD);\r\n procedure SetFlags(const Value: TJvDisplayFlags);\r\n procedure SetHeight(const Value: Integer);\r\n procedure SetHz(const Value: DWORD);\r\n procedure SetWidth(const Value: Integer);\r\n published\r\n property Width: Integer read FWidth write SetWidth;\r\n property Height: Integer read FHeight write SetHeight;\r\n property BitsPerPixel: DWORD read FBitsPerPixel write SetBitsPerPixel;\r\n property Hz: DWORD read FHz write SetHz;\r\n property Flags: TJvDisplayFlags read FFlags write SetFlags;\r\n end;\r\n\r\n TJvScreenModes = class(TJvReadOnlyInfo)\r\n private\r\n FItems: TList;\r\n FDefaultMode: TJvScreenMode;\r\n function GetItems(Index: Integer): TJvScreenMode;\r\n procedure SetItems(Index: Integer; const Value: TJvScreenMode);\r\n function GetCount: Integer;\r\n protected\r\n procedure Clear;\r\n public\r\n constructor Create;\r\n destructor Destroy; override;\r\n procedure Refresh;\r\n property Items[Index: Integer]: TJvScreenMode read GetItems write SetItems; default;\r\n property Count: Integer read GetCount;\r\n end;\r\n\r\n TJvScreenInfo = class(TJvWriteableInfo)\r\n // writeable: BitsPerPixel, Flags, Width, Height, Hz\r\n private\r\n FScreenModes: TJvScreenModes;\r\n function GetBitsPerPixel: DWORD;\r\n function GetScreenResolution: TPoint;\r\n function GetScreenFrequency: DWORD;\r\n function GetScreenHeight: DWORD;\r\n function GetScreenWidth: DWORD;\r\n procedure SetBitsPerPixel(const Value: DWORD);\r\n procedure SetScreenResolution(const Value: TPoint);\r\n procedure SetScreenFrequency(const Value: DWORD);\r\n procedure SetScreenHeight(const Value: DWORD);\r\n procedure SetScreenWidth(const Value: DWORD);\r\n function GetFlags: TJvDisplayFlags;\r\n procedure SetFlags(const Value: TJvDisplayFlags);\r\n function GetScreenModes: TJvScreenModes;\r\n procedure SetScreenModes(const Value: TJvScreenModes);\r\n protected\r\n function GetCurrentMode: TDeviceMode;\r\n procedure SetCurrentMode(ADeviceMode: TDeviceMode; Flags: DWORD);\r\n public\r\n destructor Destroy; override;\r\n property ScreenResolution: TPoint read GetScreenResolution write SetScreenResolution stored False;\r\n property ScreenModes: TJvScreenModes read GetScreenModes write SetScreenModes stored False;\r\n published\r\n property BitsPerPixel: DWORD read GetBitsPerPixel write SetBitsPerPixel stored False;\r\n property Flags: TJvDisplayFlags read GetFlags write SetFlags;\r\n property Width: DWORD read GetScreenWidth write SetScreenWidth stored False;\r\n property Height: DWORD read GetScreenHeight write SetScreenHeight stored False;\r\n property Hz: DWORD read GetScreenFrequency write SetScreenFrequency stored False;\r\n end;\r\n\r\n TJvAppVersions = class(TJvReadOnlyInfo)\r\n private\r\n function GetADOVersion: string;\r\n function GetBDELocation: string;\r\n function GetBDEVersion: string;\r\n function GetIEVersion: string;\r\n function GetOpenGLVersion: string;\r\n function GetDirectXVersion: string;\r\n procedure SetADOVersion(const Value: string);\r\n procedure SetBDEVersion(const Value: string);\r\n procedure SetIEVersion(const Value: string);\r\n procedure SetOpenGLVersion(const Value: string);\r\n procedure SetDirectXVersion(const Value: string);\r\n published\r\n property DirectX: string read GetDirectXVersion write SetDirectXVersion stored False;\r\n property OpenGL: string read GetOpenGLVersion write SetOpenGLVersion stored False;\r\n property BDE: string read GetBDEVersion write SetBDEVersion stored False;\r\n property ADO: string read GetADOVersion write SetADOVersion stored False;\r\n property InternetExplorer: string read GetIEVersion write SetIEVersion stored False;\r\n end;\r\n\r\n TJvHWDockInfo = set of (diDocked, diUndocked, diUserSupplied, diUserDocked, diUserUndocked);\r\n\r\n TJvHardwareProfile = class(TJvReadOnlyInfo)\r\n private\r\n function GetDockInfo: TJvHWDockInfo;\r\n function GetGUID: string;\r\n function GetName: string;\r\n function GetNativeType: HW_PROFILE_INFO;\r\n procedure SetDockInfo(const Value: TJvHWDockInfo);\r\n procedure SetGUID(const Value: string);\r\n procedure SetName(const Value: string);\r\n public\r\n property NativeType: HW_PROFILE_INFO read GetNativeType;\r\n published\r\n property GUID: string read GetGUID write SetGUID stored False;\r\n property Name: string read GetName write SetName stored False;\r\n property DockInfo: TJvHWDockInfo read GetDockInfo write SetDockInfo stored False;\r\n end;\r\n\r\n TJvWallpaperStyle = (wsCenter, wsUnused, wsStretch);\r\n TJvMiscInfo = class(TJvWriteableInfo)\r\n // writeable: ScreenSaver, Pattern, Wallpaper, WallpaperStyle, WallpaperTiled\r\n // CurrentColorScheme\r\n private\r\n FVersions: TJvAppVersions;\r\n FHardwareProfile: TJvHardwareProfile;\r\n FColorSchemes: TStrings;\r\n function GetIsOnline: Boolean;\r\n function GetScreenSaver: string;\r\n function GetDVDRegion: Integer;\r\n function GetTimeRunning: Int64;\r\n function GetTimeRunningAsString: string;\r\n function GetNetBIOS: Boolean;\r\n function GetVersions: TJvAppVersions;\r\n function GetHardwareProfile: TJvHardwareProfile;\r\n function GetPattern: string;\r\n function GetWallpaper: string;\r\n function GetWallpaperStyle: TJvWallpaperStyle;\r\n function GetWallpaperTiled: Boolean;\r\n function GetColorSchemes: TStrings;\r\n function GetCurrentColorScheme: string;\r\n procedure SetIsOnline(const Value: Boolean);\r\n procedure SetScreenSaver(const Value: string);\r\n procedure SetDVDRegion(const Value: Integer);\r\n procedure SetTimeRunning(const Value: Int64);\r\n procedure SetTimeRunningAsString(const Value: string);\r\n procedure SetNetBIOS(const Value: Boolean);\r\n procedure SetVersions(const Value: TJvAppVersions);\r\n procedure SetHardwareProfile(const Value: TJvHardwareProfile);\r\n procedure SetPattern(const Value: string);\r\n procedure SetWallpaper(const Value: string);\r\n procedure SetWallpaperStyle(const Value: TJvWallpaperStyle);\r\n procedure SetWallpaperTiled(const Value: Boolean);\r\n procedure SetColorSchemes(const Value: TStrings);\r\n procedure SetCurrentColorScheme(const Value: string);\r\n public\r\n destructor Destroy; override;\r\n published\r\n property TimeRunning: Int64 read GetTimeRunning write SetTimeRunning stored False;\r\n property TimeRunningAsString: string read GetTimeRunningAsString write SetTimeRunningAsString stored False;\r\n property Online: Boolean read GetIsOnline write SetIsOnline stored False;\r\n property ScreenSaver: string read GetScreenSaver write SetScreenSaver stored False;\r\n property DVDRegion: Integer read GetDVDRegion write SetDVDRegion stored False;\r\n property NetBIOS: Boolean read GetNetBIOS write SetNetBIOS stored False;\r\n property WallpaperTiled: Boolean read GetWallpaperTiled write SetWallpaperTiled stored False;\r\n property Wallpaper: string read GetWallpaper write SetWallpaper stored False;\r\n property WallpaperStyle: TJvWallpaperStyle read GetWallpaperStyle write SetWallpaperStyle stored False;\r\n property Pattern: string read GetPattern write SetPattern stored False;\r\n property ColorSchemes: TStrings read GetColorSchemes write SetColorSchemes stored False;\r\n property CurrentColorScheme: string read GetCurrentColorScheme write SetCurrentColorScheme stored False;\r\n\r\n property Versions: TJvAppVersions read GetVersions write SetVersions stored False;\r\n property HardwareProfile: TJvHardwareProfile read GetHardwareProfile write SetHardwareProfile stored False;\r\n end;\r\n\r\n TJvCleanBoot = (cbNormal, cbFailSafe, cbFailSafeNetwork);\r\n TJvWindowsArrange = set of (waDown, waLeft, waRight, waUp, waBottomLeft,\r\n waBottomRight, waHide, waTopLeft, waTopRight);\r\n\r\n TJvMetricsInfo = class(TJvWriteableInfo)\r\n // writeable: CursorX, CursorY, CaretX, CaretY\r\n private\r\n function GetBoolMetrics(const Index: Integer): Boolean;\r\n function GetMetrics(const Index: Integer): Integer;\r\n function GetArrange: TJvWindowsArrange;\r\n function GetCleanBoot: TJvCleanBoot;\r\n function GetCaretBlinkTime: DWORD;\r\n function GetCaretPos(const Index: Integer): Integer;\r\n function GetCursorPos(const Index: Integer): Integer;\r\n procedure SetBoolMetrics(const Index: Integer; const Value: Boolean);\r\n procedure SetMetrics(const Index, Value: Integer);\r\n procedure SetArrange(const Value: TJvWindowsArrange);\r\n procedure SetCleanBoot(const Value: TJvCleanBoot);\r\n procedure SetCaretBlinkTime(const Value: DWORD);\r\n procedure SetCaretPos(const Index, Value: Integer);\r\n procedure SetCursorPos(const Index, Value: Integer);\r\n function GetDialogBaseUnits: Integer;\r\n procedure SetDialogBaseUnits(const Value: Integer);\r\n function GetACP: Integer;\r\n function GetDoubleClickTime: Integer;\r\n function GetOEMCP: Integer;\r\n procedure SetACP(const Value: Integer);\r\n procedure SetDoubleClickTime(const Value: Integer);\r\n procedure SetOEMCP(const Value: Integer);\r\n published\r\n property Arrange: TJvWindowsArrange read GetArrange write SetArrange stored False;\r\n property CleanBoot: TJvCleanBoot read GetCleanBoot write SetCleanBoot stored False;\r\n property MouseButtons: Integer index SM_CMOUSEBUTTONS read GetMetrics write SetMetrics stored False;\r\n property BorderWidth: Integer index SM_CXBORDER read GetMetrics write SetMetrics stored False;\r\n property BorderHeight: Integer index SM_CYBORDER read GetMetrics write SetMetrics stored False;\r\n property CursorWidth: Integer index SM_CXCURSOR read GetMetrics write SetMetrics stored False;\r\n property CursorHeight: Integer index SM_CYCURSOR read GetMetrics write SetMetrics stored False;\r\n property CaretBlinkTime: LongWord read GetCaretBlinkTime write SetCaretBlinkTime stored False;\r\n property CaretX: Integer index 0 read GetCaretPos write SetCaretPos stored False;\r\n property CaretY: Integer index 1 read GetCaretPos write SetCaretPos stored False;\r\n property CursorX: Integer index 0 read GetCursorPos write SetCursorPos stored False;\r\n property CursorY: Integer index 1 read GetCursorPos write SetCursorPos stored False;\r\n property CodePageANSI: Integer read GetACP write SetACP stored False;\r\n property CodePageOEM: Integer read GetOEMCP write SetOEMCP stored False;\r\n property DialogBaseUnits: Integer read GetDialogBaseUnits write SetDialogBaseUnits stored False;\r\n property DialogFrameWidth: Integer index SM_CXDLGFRAME read GetMetrics write SetMetrics stored False;\r\n property DialogFrameHeight: Integer index SM_CYDLGFRAME read GetMetrics write SetMetrics stored False;\r\n property DoubleClickWidth: Integer index SM_CXDOUBLECLK read GetMetrics write SetMetrics stored False;\r\n property DoubleClickHeight: Integer index SM_CYDOUBLECLK read GetMetrics write SetMetrics stored False;\r\n property DoubleClickTime: Integer read GetDoubleClickTime write SetDoubleClickTime stored False;\r\n property DragWidth: Integer index SM_CXDRAG read GetMetrics write SetMetrics stored False;\r\n property DragHeight: Integer index SM_CYDRAG read GetMetrics write SetMetrics stored False;\r\n property EdgeWidth: Integer index SM_CXEDGE read GetMetrics write SetMetrics stored False;\r\n property EdgeHeight: Integer index SM_CYEDGE read GetMetrics write SetMetrics stored False;\r\n property FixedFrameWidth: Integer index SM_CXFIXEDFRAME read GetMetrics write SetMetrics stored False;\r\n property FixedFrameHeight: Integer index SM_CYFIXEDFRAME read GetMetrics write SetMetrics stored False;\r\n property FrameWidth: Integer index SM_CXFRAME read GetMetrics write SetMetrics stored False;\r\n property FrameHeight: Integer index SM_CYFRAME read GetMetrics write SetMetrics stored False;\r\n property ScreenClientWidth: Integer index SM_CXFULLSCREEN read GetMetrics write SetMetrics stored False;\r\n property ScreenClientHeight: Integer index SM_CYFULLSCREEN read GetMetrics write SetMetrics stored False;\r\n property ScreenWidth: Integer index SM_CXSCREEN read GetMetrics write SetMetrics stored False;\r\n property ScreenHeight: Integer index SM_CYSCREEN read GetMetrics write SetMetrics stored False;\r\n property ScrollArrowWidth: Integer index SM_CXHSCROLL read GetMetrics write SetMetrics stored False;\r\n property ScrollArrowHeight: Integer index SM_CYHSCROLL read GetMetrics write SetMetrics stored False;\r\n property ScrollThumbWidth: Integer index SM_CXHTHUMB read GetMetrics write SetMetrics stored False;\r\n property ScrollThumbHeight: Integer index SM_CYVTHUMB read GetMetrics write SetMetrics stored False;\r\n property ScrollWidth: Integer index SM_CXVSCROLL read GetMetrics write SetMetrics stored False;\r\n property ScrollHeight: Integer index SM_CYVSCROLL read GetMetrics write SetMetrics stored False;\r\n property IconWidth: Integer index SM_CXICON read GetMetrics write SetMetrics stored False;\r\n property IconHeight: Integer index SM_CYICON read GetMetrics write SetMetrics stored False;\r\n property SmallIconWidth: Integer index SM_CXSMICON read GetMetrics write SetMetrics stored False;\r\n property SmallIconHeight: Integer index SM_CYSMICON read GetMetrics write SetMetrics stored False;\r\n property IconSpacingWidth: Integer index SM_CXICONSPACING read GetMetrics write SetMetrics stored False;\r\n property IconSpacingHeight: Integer index SM_CYICONSPACING read GetMetrics write SetMetrics stored False;\r\n property MaximizedWindowWidth: Integer index SM_CXMAXIMIZED read GetMetrics write SetMetrics stored False;\r\n property MaximizedWindowHeight: Integer index SM_CYMAXIMIZED read GetMetrics write SetMetrics stored False;\r\n property MinimizedWindowWidth: Integer index SM_CXMINIMIZED read GetMetrics write SetMetrics stored False;\r\n property MinimizedWindowHeight: Integer index SM_CYMINIMIZED read GetMetrics write SetMetrics stored False;\r\n property MaxDragWindowWidth: Integer index SM_CXMAXTRACK read GetMetrics write SetMetrics stored False;\r\n property MaxDragWindowHeight: Integer index SM_CYMAXTRACK read GetMetrics write SetMetrics stored False;\r\n property MinDragWindowWidth: Integer index SM_CXMINTRACK read GetMetrics write SetMetrics stored False;\r\n property MinDragWindowHeight: Integer index SM_CYMINTRACK read GetMetrics write SetMetrics stored False;\r\n property MinWindowWidth: Integer index SM_CXMIN read GetMetrics write SetMetrics stored False;\r\n property MinWindowHeight: Integer index SM_CYMIN read GetMetrics write SetMetrics stored False;\r\n property MenuCheckWidth: Integer index SM_CXMENUCHECK read GetMetrics write SetMetrics stored False;\r\n property MenuCheckHeight: Integer index SM_CYMENUCHECK read GetMetrics write SetMetrics stored False;\r\n property MenuButtonWidth: Integer index SM_CXMENUSIZE read GetMetrics write SetMetrics stored False;\r\n property MenuButtonHeight: Integer index SM_CYMENUSIZE read GetMetrics write SetMetrics stored False;\r\n property MinimizedWindowSpacingWidth: Integer index SM_CXMINSPACING read GetMetrics write SetMetrics stored False;\r\n property MinimizedWindowSpacingHeight: Integer index SM_CYMINSPACING read GetMetrics write SetMetrics stored False;\r\n property CaptionButtonWidth: Integer index SM_CXSIZE read GetMetrics write SetMetrics stored False;\r\n property CaptionButtonheight: Integer index SM_CYSIZE read GetMetrics write SetMetrics stored False;\r\n property ResizeBorderWidth: Integer index SM_CXSIZEFRAME read GetMetrics write SetMetrics stored False;\r\n property ResizeBorderHeight: Integer index SM_CYSIZEFRAME read GetMetrics write SetMetrics stored False;\r\n property SmallCaptionButtonWidth: Integer index SM_CXSMSIZE read GetMetrics write SetMetrics stored False;\r\n property SmallCaptionButtonHeight: Integer index SM_CYSMSIZE read GetMetrics write SetMetrics stored False;\r\n property WindowCaptionHeight: Integer index SM_CYCAPTION read GetMetrics write SetMetrics stored False;\r\n property SmallWindowCaptionHeight: Integer index SM_CYSMCAPTION read GetMetrics write SetMetrics stored False;\r\n property KanjiWindowHeight: Integer index SM_CYKANJIWINDOW read GetMetrics write SetMetrics stored False;\r\n property MenuItemHeight: Integer index SM_CYMENU read GetMetrics write SetMetrics stored False;\r\n property DBCSEnabled: Boolean index SM_DBCSENABLED read GetBoolMetrics write SetBoolMetrics stored False;\r\n property Debug: Boolean index SM_DEBUG read GetBoolMetrics write SetBoolMetrics stored False;\r\n property MenuRightAligned: Boolean index SM_MENUDROPALIGNMENT read GetBoolMetrics write SetBoolMetrics stored False;\r\n property MidEastEnabled: Boolean index SM_MIDEASTENABLED read GetBoolMetrics write SetBoolMetrics stored False;\r\n property MousePresent: Boolean index SM_MOUSEPRESENT read GetBoolMetrics write SetBoolMetrics stored False;\r\n property MouseWheelPresent: Boolean index SM_MOUSEWHEELPRESENT read GetBoolMetrics write SetBoolMetrics stored\r\n False;\r\n property Networked: Boolean index SM_NETWORK read GetBoolMetrics write SetBoolMetrics stored False;\r\n property PenWindows: Boolean index SM_PENWINDOWS read GetBoolMetrics write SetBoolMetrics stored False;\r\n property Secure: Boolean index SM_SECURE read GetBoolMetrics write SetBoolMetrics stored False;\r\n property ShowSounds: Boolean index SM_SHOWSOUNDS read GetBoolMetrics write SetBoolMetrics stored False;\r\n property SlowMachine: Boolean index SM_SLOWMACHINE read GetBoolMetrics write SetBoolMetrics stored False;\r\n property MouseButtonsSwapped: Boolean index SM_SWAPBUTTON read GetBoolMetrics write SetBoolMetrics stored False;\r\n end;\r\n\r\n TJvAccessTimeOutFlags = set of (atfOnOffFeedback, atfTimeOutOn);\r\n\r\n TJvAccessTimeOut = class(TJvWriteableInfo)\r\n // writeable: all (using NativeType recommended)\r\n private\r\n function GetFlags: TJvAccessTimeOutFlags;\r\n function GetNativeType: ACCESSTIMEOUT;\r\n function GetTimeOutMS: DWORD;\r\n procedure SetFlags(const Value: TJvAccessTimeOutFlags);\r\n procedure SetTimeOutMS(const Value: DWORD);\r\n procedure SetNativeType(Value: ACCESSTIMEOUT);\r\n public\r\n property NativeType: ACCESSTIMEOUT read GetNativeType write SetNativeType;\r\n published\r\n property TimeOutMS: DWORD read GetTimeOutMS write SetTimeOutMS stored False;\r\n property Flags: TJvAccessTimeOutFlags read GetFlags write SetFlags stored False;\r\n end;\r\n\r\n TJvFilterKeyFlags = set of (fkfAvailable, fkfClickOn, fkfFilterKeysOn, fkfHotkeyActive,\r\n fkfHotkeySound, fkfConfirmHotkey, fkfIndicator);\r\n\r\n TJvFilterKeys = class(TJvWriteableInfo)\r\n // writeable: all (using NativeType recommended)\r\n private\r\n function GetBounceMSec: DWORD;\r\n function GetDelayMSec: DWORD;\r\n function GetFlags: TJvFilterKeyFlags;\r\n function GetNativeType: FILTERKEYS;\r\n function GetRepeatMSec: DWORD;\r\n function GetWaitMSec: DWORD;\r\n procedure SetBounceMSec(const Value: DWORD);\r\n procedure SetDelayMSec(const Value: DWORD);\r\n procedure SetFlags(const Value: TJvFilterKeyFlags);\r\n procedure SetNativeType(Value: FILTERKEYS);\r\n procedure SetRepeatMSec(const Value: DWORD);\r\n procedure SetWaitMSec(const Value: DWORD);\r\n public\r\n property NativeType: FILTERKEYS read GetNativeType write SetNativeType;\r\n published\r\n property Flags: TJvFilterKeyFlags read GetFlags write SetFlags stored False;\r\n property WaitMSec: DWORD read GetWaitMSec write SetWaitMSec stored False;\r\n property DelayMSec: DWORD read GetDelayMSec write SetDelayMSec stored False;\r\n property RepeatMSec: DWORD read GetRepeatMSec write SetRepeatMSec stored False;\r\n property BounceMSec: DWORD read GetBounceMSec write SetBounceMSec stored False;\r\n end;\r\n\r\n TJvHighContrastFlags = set of (hcfAvailable, hcfConfirmHotKey, hcfHighContrastOn,\r\n hcfHotkeyActive, hcfHotkeyAvailable, hcfHotkeySound, hcfIndicator);\r\n\r\n TJvHighContrast = class(TJvWriteableInfo)\r\n // writeable: all (using NativeType recommended)\r\n private\r\n function GetDefaultScheme: string;\r\n function GetFlags: TJvHighContrastFlags;\r\n function GetNativeType: HIGHCONTRAST;\r\n procedure SetDefaultScheme(const Value: string);\r\n procedure SetFlags(const Value: TJvHighContrastFlags);\r\n procedure SetNativeType(Value: HIGHCONTRAST);\r\n public\r\n property NativeType: HIGHCONTRAST read GetNativeType write SetNativeType;\r\n published\r\n property Flags: TJvHighContrastFlags read GetFlags write SetFlags stored False;\r\n property DefaultScheme: string read GetDefaultScheme write SetDefaultScheme stored False;\r\n end;\r\n\r\n TJvIconMetrics = class(TJvWriteableInfo)\r\n // writeable: all (using NativeType recommended)\r\n private\r\n FFont: TFont;\r\n function GetFont: TFont;\r\n function GetHorzSpacing: Integer;\r\n function GetNativeType: ICONMETRICS;\r\n function GetTitleWrap: Boolean;\r\n function GetVertSpacing: Integer;\r\n procedure SetFont(const Value: TFont);\r\n procedure SetHorzSpacing(const Value: Integer);\r\n procedure SetNativeType(Value: ICONMETRICS);\r\n procedure SetTitleWrap(const Value: Boolean);\r\n procedure SetVertSpacing(const Value: Integer);\r\n public\r\n destructor Destroy; override;\r\n property NativeType: ICONMETRICS read GetNativeType write SetNativeType;\r\n published\r\n property VertSpacing: Integer read GetVertSpacing write SetVertSpacing stored False;\r\n property HorzSpacing: Integer read GetHorzSpacing write SetHorzSpacing stored False;\r\n property TitleWrap: Boolean read GetTitleWrap write SetTitleWrap stored False;\r\n property Font: TFont read GetFont write SetFont stored False;\r\n end;\r\n\r\n TJvMinimizedMetrics = class(TJvWriteableInfo)\r\n // writeable: all (using NativeType recommended)\r\n private\r\n function GetArrange: TJvWindowsArrange;\r\n function GetHorzGap: Integer;\r\n function GetNativeType: MINIMIZEDMETRICS;\r\n function GetVertGap: Integer;\r\n function GetWidth: Integer;\r\n procedure SetArrange(const Value: TJvWindowsArrange);\r\n procedure SetHorzGap(const Value: Integer);\r\n procedure SetNativeType(Value: MINIMIZEDMETRICS);\r\n procedure SetVertGap(const Value: Integer);\r\n procedure SetWidth(const Value: Integer);\r\n public\r\n property NativeType: MINIMIZEDMETRICS read GetNativeType write SetNativeType;\r\n published\r\n property Width: Integer read GetWidth write SetWidth stored False;\r\n property HorzGap: Integer read GetHorzGap write SetHorzGap stored False;\r\n property VertGap: Integer read GetVertGap write SetVertGap stored False;\r\n property Arrange: TJvWindowsArrange read GetArrange write SetArrange stored False;\r\n end;\r\n\r\n TJvMouseKeysFlags = set of (mkfAvailable, mkfConfirmHotKey, mkfHotkeyActive, mkfHotkeySound, mkfIndicator,\r\n mkfMouseKeysOn, mkfModifiers, mkfReplaceNumbers);\r\n\r\n TJvMouseKeys = class(TJvWriteableInfo)\r\n // writeable: all (using NativeType recommended)\r\n private\r\n function GetCtrlSpeed: DWORD;\r\n function GetFlags: TJvMouseKeysFlags;\r\n function GetMaxSpeed: DWORD;\r\n function GetNativeType: MOUSEKEYS;\r\n function GetTimeToMaxSpeed: DWORD;\r\n procedure SetCtrlSpeed(const Value: DWORD);\r\n procedure SetFlags(const Value: TJvMouseKeysFlags);\r\n procedure SetMaxSpeed(const Value: DWORD);\r\n procedure SetNativeType(Value: MOUSEKEYS);\r\n procedure SetTimeToMaxSpeed(const Value: DWORD);\r\n public\r\n property NativeType: MOUSEKEYS read GetNativeType write SetNativeType;\r\n published\r\n property Flags: TJvMouseKeysFlags read GetFlags write SetFlags stored False;\r\n property MaxSpeed: DWORD read GetMaxSpeed write SetMaxSpeed stored False;\r\n property TimeToMaxSpeed: DWORD read GetTimeToMaxSpeed write SetTimeToMaxSpeed stored False;\r\n property CtrlSpeed: DWORD read GetCtrlSpeed write SetCtrlSpeed stored False;\r\n end;\r\n\r\n TJvNonClientMetrics = class(TJvWriteableInfo)\r\n // writeable: all (using NativeType recommended)\r\n private\r\n FCaptionFont: TFont;\r\n FMenuFont: TFont;\r\n FMessageFont: TFont;\r\n FStatusFont: TFont;\r\n FSmallCaptionFont: TFont;\r\n function GetBorderWidth: Integer;\r\n function GetCaptionFont: TFont;\r\n function GetCaptionHeight: Integer;\r\n function GetCaptionWidth: Integer;\r\n function GetMenuFont: TFont;\r\n function GetMenuHeight: Integer;\r\n function GetMenuWidth: Integer;\r\n function GetMessageFont: TFont;\r\n function GetNativeType: NONCLIENTMETRICS;\r\n function GetScrollHeight: Integer;\r\n function GetScrollWidth: Integer;\r\n function GetSmallCaptionFont: TFont;\r\n function GetSmallCaptionHeight: Integer;\r\n function GetSmallCaptionWidth: Integer;\r\n function GetStatusFont: TFont;\r\n procedure SetBorderWidth(const Value: Integer);\r\n procedure SetCaptionFont(const Value: TFont);\r\n procedure SetCaptionHeight(const Value: Integer);\r\n procedure SetCaptionWidth(const Value: Integer);\r\n procedure SetMenuFont(const Value: TFont);\r\n procedure SetMenuHeight(const Value: Integer);\r\n procedure SetMenuWidth(const Value: Integer);\r\n procedure SetMessageFont(const Value: TFont);\r\n procedure SetNativeType(Value: NONCLIENTMETRICS);\r\n procedure SetScrollHeight(const Value: Integer);\r\n procedure SetScrollWidth(const Value: Integer);\r\n procedure SetSmallCaptionFont(const Value: TFont);\r\n procedure SetSmallCaptionHeight(const Value: Integer);\r\n procedure SetSmallCaptionWidth(const Value: Integer);\r\n procedure SetStatusFont(const Value: TFont);\r\n public\r\n property NativeType: NONCLIENTMETRICS read GetNativeType write SetNativeType;\r\n destructor Destroy; override;\r\n published\r\n property BorderWidth: Integer read GetBorderWidth write SetBorderWidth stored False;\r\n property ScrollWidth: Integer read GetScrollWidth write SetScrollWidth stored False;\r\n property ScrollHeight: Integer read GetScrollHeight write SetScrollHeight stored False;\r\n property CaptionWidth: Integer read GetCaptionWidth write SetCaptionWidth stored False;\r\n property CaptionHeight: Integer read GetCaptionHeight write SetCaptionHeight stored False;\r\n property CaptionFont: TFont read GetCaptionFont write SetCaptionFont stored False;\r\n property SmallCaptionWidth: Integer read GetSmallCaptionWidth write SetSmallCaptionWidth stored False;\r\n property SmallCaptionHeight: Integer read GetSmallCaptionHeight write SetSmallCaptionHeight stored False;\r\n property SmallCaptionFont: TFont read GetSmallCaptionFont write SetSmallCaptionFont stored False;\r\n property MenuWidth: Integer read GetMenuWidth write SetMenuWidth stored False;\r\n property MenuHeight: Integer read GetMenuHeight write SetMenuHeight stored False;\r\n property MenuFont: TFont read GetMenuFont write SetMenuFont stored False;\r\n property StatusFont: TFont read GetStatusFont write SetStatusFont stored False;\r\n property MessageFont: TFont read GetMessageFont write SetMessageFont stored False;\r\n end;\r\n\r\n TJvSerialKeysFlags = set of (serkfAvailable, serkfIndicator, serkfSerialKeysOn);\r\n TJvSerialKeysPortState = (psSerialKeysIgnored, psSerialKeysAware, psSerialKeysAlways);\r\n TJvSerialKeys = class(TJvWriteableInfo)\r\n // writeable: all (using NativeType recommended)\r\n private\r\n function GetActivePort: string;\r\n function GetBaudRate: DWORD;\r\n function GetFlags: TJvSerialKeysFlags;\r\n function GetNativeType: SERIALKEYS;\r\n function GetPortState: TJvSerialKeysPortState;\r\n procedure SetActivePort(const Value: string);\r\n procedure SetBaudRate(const Value: DWORD);\r\n procedure SetFlags(const Value: TJvSerialKeysFlags);\r\n procedure SetNativeType(Value: SERIALKEYS);\r\n procedure SetPortState(const Value: TJvSerialKeysPortState);\r\n function GetPort: string;\r\n procedure SetPort(const Value: string);\r\n function GetActive: Boolean;\r\n procedure SetActive(const Value: Boolean);\r\n public\r\n property NativeType: SERIALKEYS read GetNativeType write SetNativeType;\r\n published\r\n property Active: Boolean read GetActive write SetActive stored False;\r\n property Flags: TJvSerialKeysFlags read GetFlags write SetFlags stored False;\r\n property ActivePort: string read GetActivePort write SetActivePort stored False;\r\n property Port: string read GetPort write SetPort stored False;\r\n property BaudRate: DWORD read GetBaudRate write SetBaudRate stored False;\r\n property PortState: TJvSerialKeysPortState read GetPortState write SetPortState stored False;\r\n end;\r\n\r\n TJvSoundSentryFlags = set of (ssfAvailable, ssfSoundSentryOn, ssfIndicator);\r\n TJvSoundSentryTextEffect = (sstfNone, sstfChars, sstfBorder, sstfDisplay);\r\n TJvSoundSentryGrafEffect = (ssgfNone, ssgfDisplay);\r\n TJvSoundSentryWindowsEffect = (sswfNone, sswfTitle, sswfWindow, sswfDisplay, sswfCustom);\r\n\r\n TJvSoundSentry = class(TJvWriteableInfo)\r\n // writeable: all (using NativeType recommended)\r\n private\r\n function GetFlags: TJvSoundSentryFlags;\r\n function GetGrafEffect: TJvSoundSentryGrafEffect;\r\n function GetGrafEffectColor: TColor;\r\n function GetGrafEffectMSec: DWORD;\r\n function GetNativeType: SOUNDSENTRY;\r\n function GetTextEffect: TJvSoundSentryTextEffect;\r\n function GetTextEffectColor: TColor;\r\n function GetTextEffectMSec: DWORD;\r\n function GetWindowsEffect: TJvSoundSentryWindowsEffect;\r\n function GetWindowsEffectDLL: string;\r\n function GetWindowsEffectMSec: DWORD;\r\n procedure SetFlags(const Value: TJvSoundSentryFlags);\r\n procedure SetGrafEffect(const Value: TJvSoundSentryGrafEffect);\r\n procedure SetGrafEffectColor(const Value: TColor);\r\n procedure SetGrafEffectMSec(const Value: DWORD);\r\n procedure SetNativeType(Value: SOUNDSENTRY);\r\n procedure SetTextEffect(const Value: TJvSoundSentryTextEffect);\r\n procedure SetTextEffectColor(const Value: TColor);\r\n procedure SetTextEffectMSec(const Value: DWORD);\r\n procedure SetWindowsEffect(const Value: TJvSoundSentryWindowsEffect);\r\n procedure SetWindowsEffectDLL(const Value: string);\r\n procedure SetWindowsEffectMSec(const Value: DWORD);\r\n public\r\n property NativeType: SOUNDSENTRY read GetNativeType write SetNativeType;\r\n published\r\n property Flags: TJvSoundSentryFlags read GetFlags write SetFlags stored False;\r\n property TextEffect: TJvSoundSentryTextEffect read GetTextEffect write SetTextEffect stored False;\r\n property TextEffectMSec: DWORD read GetTextEffectMSec write SetTextEffectMSec stored False;\r\n property TextEffectColor: TColor read GetTextEffectColor write SetTextEffectColor stored False;\r\n property GrafEffect: TJvSoundSentryGrafEffect read GetGrafEffect write SetGrafEffect stored False;\r\n property GrafEffectMSec: DWORD read GetGrafEffectMSec write SetGrafEffectMSec stored False;\r\n property GrafEffectColor: TColor read GetGrafEffectColor write SetGrafEffectColor stored False;\r\n property WindowsEffect: TJvSoundSentryWindowsEffect read GetWindowsEffect write SetWindowsEffect stored False;\r\n property WindowsEffectMSec: DWORD read GetWindowsEffectMSec write SetWindowsEffectMSec stored False;\r\n property WindowsEffectDLL: string read GetWindowsEffectDLL write SetWindowsEffectDLL stored False;\r\n end;\r\n\r\n TJvStickyKeysFlags = set of (skfStickyKeysOn, skfAvailable, skfHotkeyActive, skfConfirmHotkey,\r\n skfHotkeySound, skfIndicator, skfAudibleFeedback, skfTriState, skfTwoKeysOff,\r\n skfLeftAltLatched, skfLeftCtrlLatched, skfLeftShiftLatched,\r\n skfRightAltLatched, skfRightCtrlLatched, skfRightShiftLatched,\r\n skfLeftWinLatched, skfRightWinLatched,\r\n skfLeftAltLocked, skfLeftCtrlLocked, skfLeftShiftLocked,\r\n skfRightAltLocked, skfRightCtrlLocked, skfRightShiftLocked,\r\n skfLeftWinLocked, skfRightWinLocked\r\n );\r\n TJvToggleKeysFlags = set of (tkfAvailable, tkfConfirmHotkey, tkfHotkeyActive, tkfHotkeySound, tkfToggleKeysOn);\r\n TJvFontSmoothingType = (fstStandard, fstClearType, fstDocking);\r\n\r\n TJvSystemParametersInfo = class(TJvWriteableInfo)\r\n // writeable: all except ScreenSaverRunning, WindowsExtension\r\n private\r\n FAccessTimeOut: TJvAccessTimeOut;\r\n FFilterKeys: TJvFilterKeys;\r\n FHighContrast: TJvHighContrast;\r\n FIconMetrics: TJvIconMetrics;\r\n FMinimizedMetrics: TJvMinimizedMetrics;\r\n FMouseKeys: TJvMouseKeys;\r\n FNonClientMetrics: TJvNonClientMetrics;\r\n FSerialKeys: TJvSerialKeys;\r\n FSoundSentry: TJvSoundSentry;\r\n FIconTitleFont: TFont;\r\n FWorkArea: TJvRect;\r\n FMap: array of TPoint;\r\n function GetAccessTimeOut: TJvAccessTimeOut;\r\n function GetFilterKeys: TJvFilterKeys;\r\n function GetHighContrast: TJvHighContrast;\r\n function GetIconMetrics: TJvIconMetrics;\r\n function GetIconTitleFont: TFont;\r\n function GetMinimizedMetrics: TJvMinimizedMetrics;\r\n function GetMouseKeys: TJvMouseKeys;\r\n function GetNonClientMetrics: TJvNonClientMetrics;\r\n function GetSerialKeys: TJvSerialKeys;\r\n function GetSoundSentry: TJvSoundSentry;\r\n function GetStickyKeys: TJvStickyKeysFlags;\r\n function GetToggleKeys: TJvToggleKeysFlags;\r\n function GetWorkArea: TJvRect;\r\n function GetIntInfo(const Index: Integer): Integer;\r\n function GetBoolInfo(const Index: Integer): Boolean;\r\n function GetMouseInfo(const Index: Integer): Integer;\r\n function GetAnimationInfo: Boolean;\r\n function GetKeyboardLayoutName: string;\r\n function GetDeskWallpaper: string;\r\n function GetFontSmoothingType: TJvFontSmoothingType;\r\n function GetIconSpacing(const Index: Integer): Integer;\r\n procedure SetBoolInfo(const Index: Integer; const Value: Boolean);\r\n procedure SetIntInfo(const Index, Value: Integer);\r\n procedure SetAccessTimeOut(const Value: TJvAccessTimeOut);\r\n procedure SetFilterKeys(const Value: TJvFilterKeys);\r\n procedure SetHighContrast(const Value: TJvHighContrast);\r\n procedure SetIconMetrics(const Value: TJvIconMetrics);\r\n procedure SetIconTitleFont(const Value: TFont);\r\n procedure SetMinimizedMetrics(const Value: TJvMinimizedMetrics);\r\n procedure SetMouseKeys(const Value: TJvMouseKeys);\r\n procedure SetNonClientMetrics(const Value: TJvNonClientMetrics);\r\n procedure SetSerialKeys(const Value: TJvSerialKeys);\r\n procedure SetSoundSentry(const Value: TJvSoundSentry);\r\n procedure SetStickyKeys(const Value: TJvStickyKeysFlags);\r\n procedure SetToggleKeys(const Value: TJvToggleKeysFlags);\r\n procedure SetWorkArea(const Value: TJvRect);\r\n procedure SetMouseInfo(const Index, Value: Integer);\r\n procedure SetAnimationInfo(const Value: Boolean);\r\n procedure SetKeyboardLayoutName(const Value: string);\r\n procedure SetDeskWallpaper(const Value: string);\r\n procedure SetFontSmoothingType(const Value: TJvFontSmoothingType);\r\n procedure SetIconSpacing(const Index, Value: Integer);\r\n procedure InitMap;\r\n function MapToSet(Index: Integer): Integer;\r\n public\r\n constructor Create;\r\n destructor Destroy; override;\r\n published\r\n property AccessTimeOut: TJvAccessTimeOut read GetAccessTimeOut write SetAccessTimeOut stored False;\r\n property Animation: Boolean read GetAnimationInfo write SetAnimationInfo stored False;\r\n property Beep: Boolean index SPI_GETBEEP read GetBoolInfo write SetBoolInfo stored False;\r\n property BorderMultiplier: Integer index SPI_GETBORDER read GetIntInfo write SetIntInfo stored False;\r\n property DefaultInputLanguage: Integer index SPI_GETDEFAULTINPUTLANG read GetIntInfo write SetIntInfo stored False;\r\n property DragFullWindows: Boolean index SPI_GETDRAGFULLWINDOWS read GetBoolInfo write SetBoolInfo stored False;\r\n property FilterKeys: TJvFilterKeys read GetFilterKeys write SetFilterKeys stored False;\r\n property FontSmoothing: Boolean index SPI_GETFONTSMOOTHING read GetBoolInfo write SetBoolInfo stored False;\r\n property GridGranularity: Integer index SPI_GETGRIDGRANULARITY read GetIntInfo write SetIntInfo stored False;\r\n property HighContrast: TJvHighContrast read GetHighContrast write SetHighContrast stored False;\r\n property IconMetrics: TJvIconMetrics read GetIconMetrics write SetIconMetrics stored False;\r\n property IconTitleFont: TFont read GetIconTitleFont write SetIconTitleFont stored False;\r\n property IconTitleWrap: Boolean index SPI_GETICONTITLEWRAP read GetBoolInfo write SetBoolInfo stored False;\r\n property KeyboardDelay: Integer index SPI_GETKEYBOARDDELAY read GetIntInfo write SetIntInfo stored False;\r\n property KeyboardPreferred: Boolean index SPI_GETKEYBOARDPREF read GetBoolInfo write SetBoolInfo stored False;\r\n property KeyboardSpeed: Integer index SPI_GETKEYBOARDSPEED read GetIntInfo write SetIntInfo stored False;\r\n property KeyboardLayoutName: string read GetKeyboardLayoutName write SetKeyboardLayoutName stored False;\r\n property LowPowerActive: Boolean index SPI_GETLOWPOWERACTIVE read GetBoolInfo write SetBoolInfo stored False;\r\n property LowPowerTimeOut: Integer index SPI_GETLOWPOWERTIMEOUT read GetIntInfo write SetIntInfo stored False;\r\n property MenuLeftAligned: Boolean index SPI_GETMENUDROPALIGNMENT read GetBoolInfo write SetBoolInfo stored False;\r\n property MinimizedMetrics: TJvMinimizedMetrics read GetMinimizedMetrics write SetMinimizedMetrics stored False;\r\n property MouseSpeed: Integer index SPI_GETMOUSESPEED read GetIntInfo write SetIntInfo stored False;\r\n property MouseThreshold1: Integer index 0 read GetMouseInfo write SetMouseInfo stored False;\r\n property MouseThreshold2: Integer index 1 read GetMouseInfo write SetMouseInfo stored False;\r\n property MouseHoverHeight: Integer index SPI_GETMOUSEHOVERHEIGHT read GetIntInfo write SetIntInfo stored False;\r\n property MouseHoverTime: Integer index SPI_GETMOUSEHOVERTIME read GetIntInfo write SetIntInfo stored False;\r\n property MouseHoverWidth: Integer index SPI_GETMOUSEHOVERWIDTH read GetIntInfo write SetIntInfo stored False;\r\n property MouseKeys: TJvMouseKeys read GetMouseKeys write SetMouseKeys stored False;\r\n property MouseTrails: Integer index SPI_GETMOUSETRAILS read GetIntInfo write SetIntInfo stored False;\r\n property NonClientMetrics: TJvNonClientMetrics read GetNonClientMetrics write SetNonClientMetrics stored False;\r\n property PowerOffActive: Boolean index SPI_GETPOWEROFFACTIVE read GetBoolInfo write SetBoolInfo stored False;\r\n property PowerOffTimeout: Integer index SPI_GETPOWEROFFTIMEOUT read GetIntInfo write SetIntInfo stored False;\r\n property ScreenReader: Boolean index SPI_GETSCREENREADER read GetBoolInfo write SetBoolInfo stored False;\r\n property ScreenSaverActive: Boolean index SPI_GETSCREENSAVEACTIVE read GetBoolInfo write SetBoolInfo stored False;\r\n property ScreenSaveTimeOut: Integer index SPI_GETSCREENSAVETIMEOUT read GetIntInfo write SetIntInfo stored False;\r\n property SerialKeys: TJvSerialKeys read GetSerialKeys write SetSerialKeys stored False;\r\n property ShowSounds: Boolean index SPI_GETSHOWSOUNDS read GetBoolInfo write SetBoolInfo stored False;\r\n property SnapToDefaultButton: Boolean index SPI_GETSNAPTODEFBUTTON read GetBoolInfo write SetBoolInfo stored False;\r\n property SoundSentry: TJvSoundSentry read GetSoundSentry write SetSoundSentry stored False;\r\n property StickyKeys: TJvStickyKeysFlags read GetStickyKeys write SetStickyKeys stored False;\r\n property ToggleKeys: TJvToggleKeysFlags read GetToggleKeys write SetToggleKeys stored False;\r\n property WheelScrollLines: Integer index SPI_GETWHEELSCROLLLINES read GetIntInfo write SetIntInfo stored False;\r\n property WindowsExtensions: Boolean index SPI_GETWINDOWSEXTENSION read GetBoolInfo write SetBoolInfo stored False;\r\n property WorkArea: TJvRect read GetWorkArea write SetWorkArea stored False;\r\n property ScreenSaverRunning: Boolean index SPI_GETSCREENSAVERRUNNING read GetBoolInfo write SetBoolInfo stored\r\n False;\r\n // New (W2k, XP and up)\r\n property FocusBorderHeight: Integer index SPI_GETFOCUSBORDERHEIGHT read GetIntInfo write SetIntInfo stored False;\r\n property FocusBorderWidth: Integer index SPI_GETFOCUSBORDERWIDTH read GetIntInfo write SetIntInfo stored False;\r\n property MouseClickLock: Boolean index SPI_GETMOUSECLICKLOCK read GetBoolInfo write SetBoolInfo stored False;\r\n property MouseClickLockTime: Integer index SPI_GETMOUSECLICKLOCKTIME read GetIntInfo write SetIntInfo stored False;\r\n property MouseSonar: Boolean index SPI_GETMOUSESONAR read GetBoolInfo write SetBoolInfo stored False;\r\n property MouseVanish: Boolean index SPI_GETMOUSEVANISH read GetBoolInfo write SetBoolInfo stored False;\r\n property DeskWallpaper: string read GetDeskWallpaper write SetDeskWallpaper stored False;\r\n property DropShadow: Boolean index SPI_GETDROPSHADOW read GetBoolInfo write SetBoolInfo stored False;\r\n property FlatMenu: Boolean index SPI_GETFLATMENU read GetBoolInfo write SetBoolInfo stored False;\r\n property FontSmoothingContrast: Integer index SPI_GETFONTSMOOTHINGCONTRAST read GetIntInfo write SetIntInfo stored\r\n False;\r\n property FontSmoothingType: TJvFontSmoothingType read GetFontSmoothingType write SetFontSmoothingType stored False;\r\n property MenuShowDelay: Integer index SPI_GETMENUSHOWDELAY read GetIntInfo write SetIntInfo stored False;\r\n property ShowIMEUI: Boolean index SPI_GETSHOWIMEUI read GetBoolInfo write SetBoolInfo stored False;\r\n property ActiveWindowTracking: Boolean index SPI_GETACTIVEWINDOWTRACKING read GetBoolInfo write SetBoolInfo stored\r\n False;\r\n property MenuAnimation: Boolean index SPI_GETMENUANIMATION read GetBoolInfo write SetBoolInfo stored False;\r\n property ComboboxAnimation: Boolean index SPI_GETCOMBOBOXANIMATION read GetBoolInfo write SetBoolInfo stored False;\r\n property ListboxSmoothScrolling: Boolean index SPI_GETLISTBOXSMOOTHSCROLLING read GetBoolInfo write SetBoolInfo\r\n stored False;\r\n property GradientCaptions: Boolean index SPI_GETGRADIENTCAPTIONS read GetBoolInfo write SetBoolInfo stored False;\r\n property MenuUnderLines: Boolean index SPI_GETMENUUNDERLINES read GetBoolInfo write SetBoolInfo stored False;\r\n property ActiveWindowTrackZOrder: Boolean index SPI_GETACTIVEWNDTRKZORDER read GetBoolInfo write SetBoolInfo stored\r\n False;\r\n property HotTracking: Boolean index SPI_GETHOTTRACKING read GetBoolInfo write SetBoolInfo stored False;\r\n property MenuFade: Boolean index SPI_GETMENUFADE read GetBoolInfo write SetBoolInfo stored False;\r\n property SelectionFade: Boolean index SPI_GETSELECTIONFADE read GetBoolInfo write SetBoolInfo stored False;\r\n property ToolTipAnimation: Boolean index SPI_GETTOOLTIPANIMATION read GetBoolInfo write SetBoolInfo stored False;\r\n property ToolTipFade: Boolean index SPI_GETTOOLTIPFADE read GetBoolInfo write SetBoolInfo stored False;\r\n property CursorShadow: Boolean index SPI_GETCURSORSHADOW read GetBoolInfo write SetBoolInfo stored False;\r\n property UIEffects: Boolean index SPI_GETUIEFFECTS read GetBoolInfo write SetBoolInfo stored False;\r\n property ForegroundLockTimeOut: Integer index SPI_GETFOREGROUNDLOCKTIMEOUT read GetIntInfo write SetIntInfo stored\r\n False;\r\n property ActiveWindowTrackTimeOut: Integer index SPI_GETACTIVEWNDTRKTIMEOUT read GetIntInfo write SetIntInfo stored\r\n False;\r\n property ForegroundFlashCount: Integer index SPI_GETFOREGROUNDFLASHCOUNT read GetIntInfo write SetIntInfo stored\r\n False;\r\n property CaretWidth: Integer index SPI_GETCARETWIDTH read GetIntInfo write SetIntInfo stored False;\r\n property IconHorizontalSpacing: Integer index 0 read GetIconSpacing write SetIconSpacing stored False;\r\n property IconVerticalSpacing: Integer index 1 read GetIconSpacing write SetIconSpacing stored False;\r\n end;\r\n\r\n TJvSystemColorsInfo = class(TJvWriteableInfo)\r\n // writeable: all\r\n private\r\n procedure SetColor(Index: Integer; Value: TColor);\r\n function GetColor(Index: Integer): TColor;\r\n published\r\n property Color3DHighlight: TColor index COLOR_3DHILIGHT read GetColor write SetColor stored False;\r\n property Color3DLight: TColor index COLOR_3DLIGHT read GetColor write SetColor stored False;\r\n property Color3DShadow: TColor index COLOR_3DSHADOW read GetColor write SetColor stored False;\r\n property Color3DDarkShadow: TColor index COLOR_3DDKSHADOW read GetColor write SetColor stored False;\r\n property Color3DFace: TColor index COLOR_3DFACE read GetColor write SetColor stored False;\r\n property ColorActiveBorder: TColor index COLOR_ACTIVEBORDER read GetColor write SetColor stored False;\r\n property ColorActiveCaption: TColor index COLOR_ACTIVECAPTION read GetColor write SetColor stored False;\r\n property ColorAppWorkspace: TColor index COLOR_APPWORKSPACE read GetColor write SetColor stored False;\r\n property ColorBackground: TColor index COLOR_BACKGROUND read GetColor write SetColor stored False;\r\n property ColorBtnFace: TColor index COLOR_BTNFACE read GetColor write SetColor stored False;\r\n property ColorBtnText: TColor index COLOR_BTNTEXT read GetColor write SetColor stored False;\r\n property ColorCaptionText: TColor index COLOR_CAPTIONTEXT read GetColor write SetColor stored False;\r\n property ColorGrayText: TColor index COLOR_GRAYTEXT read GetColor write SetColor stored False;\r\n property ColorHighlight: TColor index COLOR_HIGHLIGHT read GetColor write SetColor stored False;\r\n property ColorHighlightText: TColor index COLOR_HIGHLIGHTTEXT read GetColor write SetColor stored False;\r\n property ColorInactiveBorder: TColor index COLOR_INACTIVEBORDER read GetColor write SetColor stored False;\r\n property ColorInactiveCaption: TColor index COLOR_INACTIVECAPTION read GetColor write SetColor stored False;\r\n property ColorInactiveCaptionText: TColor index COLOR_INACTIVECAPTIONTEXT read GetColor write SetColor stored False;\r\n property ColorInfoBk: TColor index COLOR_INFOBK read GetColor write SetColor stored False;\r\n property ColorInfoText: TColor index COLOR_INFOTEXT read GetColor write SetColor stored False;\r\n property ColorMenu: TColor index COLOR_MENU read GetColor write SetColor stored False;\r\n property ColorMenuText: TColor index COLOR_MENUTEXT read GetColor write SetColor stored False;\r\n property ColorScrollBar: TColor index COLOR_SCROLLBAR read GetColor write SetColor stored False;\r\n property ColorWindow: TColor index COLOR_WINDOW read GetColor write SetColor stored False;\r\n property ColorWindowFrame: TColor index COLOR_WINDOWFRAME read GetColor write SetColor stored False;\r\n property ColorWindowText: TColor index COLOR_WINDOWTEXT read GetColor write SetColor stored False;\r\n property ColorHotLight: TColor index COLOR_HOTLIGHT read GetColor write SetColor stored False;\r\n property ColorGradientActiveCaption: TColor index COLOR_GRADIENTACTIVECAPTION read GetColor write SetColor stored\r\n False;\r\n property ColorGradientInactiveCaption: TColor index COLOR_GRADIENTINACTIVECAPTION read GetColor write SetColor stored\r\n False;\r\n property ColorMenuHighlight: TColor index COLOR_MENUHILIGHT read GetColor write SetColor stored False;\r\n property ColorMenuBar: TColor index COLOR_MENUBAR read GetColor write SetColor stored False;\r\n end;\r\n\r\n TJvExeType = (etNone, etMSDos, etWin16, etWin32, etConsole);\r\n TJvIconModifier = (imNormal, imOverlay, imSelected, imOpen, imShellSize, imSmall);\r\n TJvIconModifiers = set of TJvIconModifier;\r\n\r\n TJvFileInfo = class(TJvWriteableInfo)\r\n // writeable: FileName, Modifier\r\n private\r\n FLargeImages: TImageList;\r\n FSmallImages: TImageList;\r\n FFileName: TFileName;\r\n FModifiers: TJvIconModifiers;\r\n FIcon: TIcon;\r\n function GetSmallImages: TImageList;\r\n function GetLargeImages: TImageList;\r\n procedure SetExeDummy(const Value: TJvExeType);\r\n procedure SetIconDummy(const Value: TIcon);\r\n procedure SetIntDummy(const Value: Integer);\r\n procedure SetStrDummy(const Value: string);\r\n protected\r\n function GetIconIndex: Integer;\r\n function GetDisplayName: string;\r\n function GetExeType: TJvExeType;\r\n function GetAttributes: Integer;\r\n function GetIconLocation: string;\r\n function GetTypeString: string;\r\n function GetIconHandle: THandle;\r\n function GetAttrString: string;\r\n procedure SetFileName(Value: TFileName);\r\n procedure SetModifiers(Value: TJvIconModifiers);\r\n public\r\n property LargeImages: TImageList read FLargeImages;\r\n property SmallImages: TImageList read FSmallImages;\r\n property IconHandle: THandle read GetIconHandle stored False;\r\n property Attributes: Integer read GetAttributes stored False;\r\n function GetFileInfo(const FileName: string; Attributes: Cardinal; out Info: ShFileInfo; Flags: Cardinal): Cardinal;\r\n published\r\n constructor Create;\r\n destructor Destroy; override;\r\n property FileName: TFileName read FFileName write SetFileName stored False;\r\n property Modifiers: TJvIconModifiers read FModifiers write SetModifiers default [imNormal];\r\n property IconIndex: Integer read GetIconIndex write SetIntDummy stored False;\r\n property DisplayName: string read GetDisplayName write SetStrDummy stored False;\r\n property ExeType: TJvExeType read GetExeType write SetExeDummy stored False;\r\n property AttrString: string read GetAttrString write SetStrDummy stored False;\r\n property IconLocation: string read GetIconLocation write SetStrDummy stored False;\r\n property TypeString: string read GetTypeString write SetStrDummy stored False;\r\n property Icon: TIcon read FIcon write SetIconDummy stored False;\r\n end;\r\n\r\n TJvDriveChangeEvent = procedure(Sender: TObject; Drive: Char) of object;\r\n TJvCompactingEvent = procedure(Sender: TObject; Ratio: Integer) of object;\r\n TJvPowerBroadcastEvent = procedure(Sender: TObject; Event, Data: Integer) of object;\r\n TJvDeviceChangeEvent = procedure(Sender: TObject; Event: UINT; Data: Pointer) of object;\r\n TJvDevModeChangeEvent = procedure(Sender: TObject; Device: string) of object;\r\n TJvDisplayChangeEvent = procedure(Sender: TObject; BitsPerPixel, ScreenWidth, ScreenHeight: Integer) of object;\r\n TJvSettingChangeEvent = procedure(Sender: TObject; Flag: Integer; const Section: string) of object;\r\n TJvSpoolerChangeEvent = procedure(Sender: TObject; JobStatus, JobsLeft: Integer) of object;\r\n TJvPaletteChangeEvent = procedure(Sender: TObject; Wnd: THandle) of object;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvComputerInfoEx = class(TJvComponent)\r\n private\r\n FAPMInfo: TJvAPMInfo;\r\n FBIOSInfo: TJvBIOSInfo;\r\n FCPUInfo: TJvCPUInfo;\r\n FIdentification: TJvIdentification;\r\n FKeyInfo: TJvKeyInfo;\r\n FMemoryInfo: TJvMemInfo;\r\n FMiscInfo: TJvMiscInfo;\r\n FOSVersionInfo: TJvOSVersionInfo;\r\n FScreenInfo: TJvScreenInfo;\r\n FSystemFolders: TJvSystemFolders;\r\n FDeviceHandle: Integer;\r\n FOnDeviceAdded: TJvDriveChangeEvent;\r\n FOnDeviceRemoved: TJvDriveChangeEvent;\r\n FMetrics: TJvMetricsInfo;\r\n FSystem: TJvSystemParametersInfo;\r\n FColors: TJvSystemColorsInfo;\r\n FOnSettingChange: TJvSettingChangeEvent;\r\n FOnCompacting: TJvCompactingEvent;\r\n FOnPowerBroadcast: TJvPowerBroadcastEvent;\r\n FOnUserChanged: TNotifyEvent;\r\n FOnDeviceChange: TJvDeviceChangeEvent;\r\n FOnDeviceModeChange: TJvDevModeChangeEvent;\r\n FOnDisplayChange: TJvDisplayChangeEvent;\r\n FOnTimeChange: TNotifyEvent;\r\n FOnFontChange: TNotifyEvent;\r\n FOnSysColorChange: TNotifyEvent;\r\n FOnSpoolerStatusChange: TJvSpoolerChangeEvent;\r\n FOnPaletteChanging: TJvPaletteChangeEvent;\r\n FOnPaletteChanged: TJvPaletteChangeEvent;\r\n FReadOnly: Boolean;\r\n FFileInfo: TJvFileInfo;\r\n procedure SetAPMInfo(const Value: TJvAPMInfo);\r\n procedure SetBIOSInfo(const Value: TJvBIOSInfo);\r\n procedure SetCPUInfo(const Value: TJvCPUInfo);\r\n procedure SetIdentification(const Value: TJvIdentification);\r\n procedure SetKeyInfo(const Value: TJvKeyInfo);\r\n procedure SetMemoryInfo(const Value: TJvMemInfo);\r\n procedure SetMiscInfo(const Value: TJvMiscInfo);\r\n procedure SetOSVersionInfo(const Value: TJvOSVersionInfo);\r\n procedure SetScreenInfo(const Value: TJvScreenInfo);\r\n procedure SetSystemFolders(const Value: TJvSystemFolders);\r\n procedure SetMetrics(const Value: TJvMetricsInfo);\r\n procedure SetSystem(const Value: TJvSystemParametersInfo);\r\n procedure SetColors(const Value: TJvSystemColorsInfo);\r\n procedure SetReadOnly(const Value: Boolean);\r\n procedure SetFileInfo(const Value: TJvFileInfo);\r\n function GetAPMInfo: TJvAPMInfo;\r\n function GetBIOSInfo: TJvBIOSInfo;\r\n function GetCPUInfo: TJvCPUInfo;\r\n function GetIdentification: TJvIdentification;\r\n function GetKeyInfo: TJvKeyInfo;\r\n function GetMemoryInfo: TJvMemInfo;\r\n function GetMetrics: TJvMetricsInfo;\r\n function GetMiscInfo: TJvMiscInfo;\r\n function GetOSVersionInfo: TJvOSVersionInfo;\r\n function GetScreenInfo: TJvScreenInfo;\r\n function GetSystem: TJvSystemParametersInfo;\r\n function GetSystemFolders: TJvSystemFolders;\r\n function GetColors: TJvSystemColorsInfo;\r\n function GetFileInfo: TJvFileInfo;\r\n protected\r\n function FirstDrive(AMask: Longint): Char;\r\n procedure WMDeviceChange(var Msg: TWMDeviceChange);\r\n procedure WMDisplayChange(var Msg: TWMDisplayChange);\r\n procedure DoSettingChange(Flag: Integer; Section: string); dynamic;\r\n procedure DoDriveChange(Drive: Char; Removed: Boolean); dynamic;\r\n procedure DoCompacting(Ratio: Integer); dynamic;\r\n procedure DoPowerBroadcast(Event, Data: Integer); dynamic;\r\n procedure DoUserChanged; dynamic;\r\n procedure DoDeviceChange(Event: UINT; dwData: Pointer); dynamic;\r\n procedure DoDevModeChange(const Device: PChar); dynamic;\r\n procedure DoTimeChange; dynamic;\r\n procedure DoFontChange; dynamic;\r\n procedure DoSysColorChange; dynamic;\r\n procedure DoSpoolerStatus(JobStatus, JobsLeft: Integer); dynamic;\r\n procedure DoPaletteChanging(Wnd: THandle); dynamic;\r\n procedure DoPaletteChanged(Wnd: THandle); dynamic;\r\n procedure WndProc(var Message: TMessage);\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n function ResetSystemCursors: Boolean;\r\n function ResetSystemIcons: Boolean;\r\n published\r\n property APM: TJvAPMInfo read GetAPMInfo write SetAPMInfo stored False;\r\n property BIOS: TJvBIOSInfo read GetBIOSInfo write SetBIOSInfo stored False;\r\n property Colors: TJvSystemColorsInfo read GetColors write SetColors stored False;\r\n property CPU: TJvCPUInfo read GetCPUInfo write SetCPUInfo stored False;\r\n property FileInfo: TJvFileInfo read GetFileInfo write SetFileInfo stored False;\r\n property Folders: TJvSystemFolders read GetSystemFolders write SetSystemFolders; // stored False; // Mantis 3808: store the Folders so that TrailingPathDelimiter can be stored.\r\n property Identification: TJvIdentification read GetIdentification write SetIdentification stored False;\r\n property Keyboard: TJvKeyInfo read GetKeyInfo write SetKeyInfo stored False;\r\n property Memory: TJvMemInfo read GetMemoryInfo write SetMemoryInfo stored False;\r\n property Metrics: TJvMetricsInfo read GetMetrics write SetMetrics;\r\n property Misc: TJvMiscInfo read GetMiscInfo write SetMiscInfo stored False;\r\n property OS: TJvOSVersionInfo read GetOSVersionInfo write SetOSVersionInfo stored False;\r\n property ReadOnly: Boolean read FReadOnly write SetReadOnly default True;\r\n property Screen: TJvScreenInfo read GetScreenInfo write SetScreenInfo stored False;\r\n property System: TJvSystemParametersInfo read GetSystem write SetSystem stored False;\r\n property OnDeviceAdded: TJvDriveChangeEvent read FOnDeviceAdded write FOnDeviceAdded;\r\n property OnDeviceRemoved: TJvDriveChangeEvent read FOnDeviceRemoved write FOnDeviceRemoved;\r\n property OnSettingChange: TJvSettingChangeEvent read FOnSettingChange write FOnSettingChange;\r\n property OnCompacting: TJvCompactingEvent read FOnCompacting write FOnCompacting;\r\n property OnPowerBroadcast: TJvPowerBroadcastEvent read FOnPowerBroadcast write FOnPowerBroadcast;\r\n property OnUserChanged: TNotifyEvent read FOnUserChanged write FOnUserChanged;\r\n property OnDeviceChange: TJvDeviceChangeEvent read FOnDeviceChange write FOnDeviceChange;\r\n property OnDeviceModeChange: TJvDevModeChangeEvent read FOnDeviceModeChange write FOnDeviceModeChange;\r\n property OnDisplayChange: TJvDisplayChangeEvent read FOnDisplayChange write FOnDisplayChange;\r\n property OnTimeChange: TNotifyEvent read FOnTimeChange write FOnTimeChange;\r\n property OnFontChange: TNotifyEvent read FOnFontChange write FOnFontChange;\r\n property OnSysColorChange: TNotifyEvent read FOnSysColorChange write FOnSysColorChange;\r\n property OnSpoolerStatusChange: TJvSpoolerChangeEvent read FOnSpoolerStatusChange write FOnSpoolerStatusChange;\r\n property OnPaletteChanging: TJvPaletteChangeEvent read FOnPaletteChanging write FOnPaletteChanging;\r\n property OnPaletteChanged: TJvPaletteChangeEvent read FOnPaletteChanged write FOnPaletteChanged;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvComputerInfoEx.pas $';\r\n Revision: '$Revision: 13397 $';\r\n Date: '$Date: 2012-08-16 19:23:19 +0200 (jeu. 16 août 2012) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n Registry,\r\n JclShell, JclRegistry, JclFileUtils,\r\n JvJCLUtils, // Include/ExcludeTrailingPathDelimiter\r\n JvResources, System.UITypes, System.Types;\r\n\r\nvar\r\n IsDesigning: Boolean = False;\r\n\r\nconst\r\n DEFAULT_SPIF_SENDCHANGE = SPIF_UPDATEINIFILE or SPIF_SENDCHANGE;\r\n\r\nprocedure UpdateFromLogFont(AFont: TFont; const LogFont: TLogFont);\r\nvar\r\n Style: TFontStyles;\r\nbegin\r\n with LogFont do\r\n begin\r\n AFont.Name := lfFaceName;\r\n AFont.Height := lfHeight;\r\n AFont.Charset := TFontCharset(lfCharSet);\r\n Style := [];\r\n if lfWeight > FW_REGULAR then\r\n Include(Style, fsBold);\r\n if lfItalic <> 0 then\r\n Include(Style, fsItalic);\r\n if lfUnderline <> 0 then\r\n Include(Style, fsUnderline);\r\n if lfStrikeOut <> 0 then\r\n Include(Style, fsStrikeOut);\r\n AFont.Style := Style;\r\n end;\r\nend;\r\n\r\nprocedure UpdateToLogFont(AFont: TFont; var LogFont: TLogFont);\r\nbegin\r\n with LogFont do\r\n begin\r\n StrCopy(lfFaceName, PChar(AFont.Name));\r\n lfHeight := AFont.Height;\r\n lfCharSet := AFont.Charset;\r\n if fsBold in AFont.Style then\r\n lfWeight := FW_BOLD\r\n else\r\n lfWeight := FW_NORMAL;\r\n lfItalic := Ord(fsItalic in AFont.Style);\r\n lfUnderline := Ord(fsUnderline in AFont.Style);\r\n lfStrikeOut := Ord(fsStrikeOut in AFont.Style);\r\n end;\r\nend;\r\n\r\nprocedure RaiseReadOnly(AlwaysRaise: Boolean = False);\r\nbegin\r\n if not IsDesigning or AlwaysRaise then\r\n raise EJVCLComputerInfoEx.CreateRes(@RsEReadOnlyProperty);\r\nend;\r\n\r\nfunction ArrangeToWindowsArrange(Value: DWORD): TJvWindowsArrange;\r\nbegin\r\n Result := [];\r\n if Value and ARW_HIDE = ARW_HIDE then\r\n Include(Result, waHide)\r\n else\r\n if Value and ARW_BOTTOMLEFT = ARW_BOTTOMLEFT then\r\n begin\r\n Include(Result, waBottomLeft);\r\n if Value and ARW_UP = ARW_UP then\r\n Include(Result, waUp)\r\n else\r\n Include(Result, waRight);\r\n end\r\n else\r\n if Value and ARW_BOTTOMRIGHT = ARW_BOTTOMRIGHT then\r\n begin\r\n Include(Result, waBottomRight);\r\n if Value and ARW_UP = ARW_UP then\r\n Include(Result, waUp)\r\n else\r\n Include(Result, waLeft);\r\n end\r\n else\r\n if Value and ARW_TOPLEFT = ARW_TOPLEFT then\r\n begin\r\n Include(Result, waTopLeft);\r\n if Value and ARW_DOWN = ARW_DOWN then\r\n Include(Result, waDown)\r\n else\r\n Include(Result, waRight);\r\n end\r\n else\r\n if Value and ARW_TOPRIGHT = ARW_TOPRIGHT then\r\n begin\r\n Include(Result, waTopRight);\r\n if Value and ARW_DOWN = ARW_DOWN then\r\n Include(Result, waDown)\r\n else\r\n Include(Result, waLeft);\r\n end;\r\nend;\r\n\r\nfunction WindowsArrangeToArrange(Value: TJvWindowsArrange): DWORD;\r\nbegin\r\n Result := 0;\r\n // NB! no error checking - trust the user (bad idea?)\r\n if waHide in Value then\r\n Result := Result or ARW_HIDE;\r\n if waBottomLeft in Value then\r\n Result := Result or ARW_BOTTOMLEFT;\r\n if waBottomRight in Value then\r\n Result := Result or ARW_BOTTOMRIGHT;\r\n if waUp in Value then\r\n Result := Result or ARW_UP;\r\n if waTopLeft in Value then\r\n Result := Result or ARW_TOPLEFT;\r\n if waDown in Value then\r\n Result := Result or ARW_DOWN;\r\n if waTopRight in Value then\r\n Result := Result or ARW_TOPRIGHT;\r\nend;\r\n\r\nfunction RegNativeReadStringDef(const RootKey: DelphiHKEY; const Key, Name: string; Def: string): string;\r\nvar\r\n LastAccess: TJclRegWOW64Access;\r\nbegin\r\n LastAccess := RegGetWOW64AccessMode;\r\n try\r\n RegSetWOW64AccessMode(raNative);\r\n Result := RegReadStringDef(RootKey, Key, Name, Def);\r\n finally\r\n RegSetWOW64AccessMode(LastAccess);\r\n end;\r\nend;\r\n\r\nprocedure RegNativeWriteString(const RootKey: DelphiHKEY; const Key, Name, Value: string);\r\nvar\r\n LastAccess: TJclRegWOW64Access;\r\nbegin\r\n LastAccess := RegGetWOW64AccessMode;\r\n try\r\n RegSetWOW64AccessMode(raNative);\r\n RegWriteString(RootKey, Key, Name, Value);\r\n finally\r\n RegSetWOW64AccessMode(LastAccess);\r\n end;\r\nend;\r\n\r\nfunction RegNativeReadIntegerDef(const RootKey: DelphiHKEY; const Key, Name: string; Def: Integer): Integer;\r\nvar\r\n LastAccess: TJclRegWOW64Access;\r\nbegin\r\n LastAccess := RegGetWOW64AccessMode;\r\n try\r\n RegSetWOW64AccessMode(raNative);\r\n Result := RegReadIntegerDef(RootKey, Key, Name, Def);\r\n finally\r\n RegSetWOW64AccessMode(LastAccess);\r\n end;\r\nend;\r\n\r\n//=== { TJvWriteableInfo } ===================================================\r\n\r\nconstructor TJvWriteableInfo.Create;\r\nbegin\r\n inherited Create;\r\n FReadOnly := True;\r\nend;\r\n\r\n//=== { TJvAPMInfo } =========================================================\r\n\r\nfunction TJvAPMInfo.GetAPMBatteryFlag: TAPMBatteryFlag;\r\nbegin\r\n Result := JclSysInfo.GetAPMBatteryFlag;\r\nend;\r\n\r\nfunction TJvAPMInfo.GetAPMBatteryFullLifeTime: DWORD;\r\nbegin\r\n if BatteryFlag = abfNoBattery then\r\n Result := 0\r\n else\r\n Result := JclSysInfo.GetAPMBatteryFullLifeTime;\r\nend;\r\n\r\nfunction TJvAPMInfo.GetAPMBatteryLifePercent: Integer;\r\nbegin\r\n if BatteryFlag = abfNoBattery then\r\n Result := 0\r\n else\r\n Result := JclSysInfo.GetAPMBatteryLifePercent;\r\nend;\r\n\r\nfunction TJvAPMInfo.GetAPMBatteryLifeTime: DWORD;\r\nbegin\r\n if BatteryFlag = abfNoBattery then\r\n Result := 0\r\n else\r\n Result := JclSysInfo.GetAPMBatteryLifeTime;\r\nend;\r\n\r\nfunction TJvAPMInfo.GetAPMLineStatus: TAPMLineStatus;\r\nbegin\r\n if BatteryFlag = abfNoBattery then\r\n Result := alsUnknown\r\n else\r\n Result := JclSysInfo.GetAPMLineStatus;\r\nend;\r\n\r\nprocedure TJvAPMInfo.SetAPMBatteryFlag(const Value: TAPMBatteryFlag);\r\nbegin\r\n RaiseReadOnly;\r\nend;\r\n\r\nprocedure TJvAPMInfo.SetAPMBatteryFullLifeTime(const Value: DWORD);\r\nbegin\r\n RaiseReadOnly;\r\nend;\r\n\r\nprocedure TJvAPMInfo.SetAPMBatteryLifePercent(const Value: Integer);\r\nbegin\r\n RaiseReadOnly;\r\nend;\r\n\r\nprocedure TJvAPMInfo.SetAPMBatteryLifeTime(const Value: DWORD);\r\nbegin\r\n RaiseReadOnly;\r\nend;\r\n\r\nprocedure TJvAPMInfo.SetAPMLineStatus(const Value: TAPMLineStatus);\r\nbegin\r\n RaiseReadOnly;\r\nend;\r\n\r\n//=== { TJvOSVersionInfo } ===================================================\r\n\r\nconst\r\n HKLM_CURRENT_VERSION_WINDOWS = 'Software\\Microsoft\\Windows\\CurrentVersion';\r\n HKLM_CURRENT_VERSION_NT = 'Software\\Microsoft\\Windows NT\\CurrentVersion';\r\n\r\nfunction REG_CURRENT_VERSION: string;\r\nbegin\r\n if IsWinNT then\r\n Result := HKLM_CURRENT_VERSION_NT\r\n else\r\n Result := HKLM_CURRENT_VERSION_WINDOWS;\r\nend;\r\n\r\nfunction TJvOSVersionInfo.GetOSVersion: TWindowsVersion;\r\nbegin\r\n Result := JclSysInfo.GetWindowsVersion;\r\nend;\r\n\r\nfunction TJvOSVersionInfo.GetProductType: TNtProductType;\r\nbegin\r\n Result := JclSysInfo.NtProductType;\r\nend;\r\n\r\nfunction TJvOSVersionInfo.GetWinProductID: string;\r\nbegin\r\n Result := RegNativeReadStringDef(HKLM, REG_CURRENT_VERSION, 'ProductID', '');\r\nend;\r\n\r\nfunction TJvOSVersionInfo.GetWinProductName: string;\r\nbegin\r\n Result := RegNativeReadStringDef(HKLM, REG_CURRENT_VERSION, 'ProductName', '');\r\nend;\r\n\r\nfunction TJvOSVersionInfo.GetWinServicePackVersion: DWORD;\r\nbegin\r\n Result := JclSysInfo.GetWindowsServicePackVersion;\r\nend;\r\n\r\nfunction TJvOSVersionInfo.GetWinVersionBuild: DWORD;\r\nbegin\r\n Result := Win32BuildNumber;\r\nend;\r\n\r\nfunction TJvOSVersionInfo.GetWinVersionMajor: DWORD;\r\nbegin\r\n Result := Win32MajorVersion;\r\nend;\r\n\r\nfunction TJvOSVersionInfo.GetWinVersionMinor: DWORD;\r\nbegin\r\n Result := Win32MinorVersion;\r\nend;\r\n\r\nfunction TJvOSVersionInfo.GetWinVersionCSDString: string;\r\nbegin\r\n Result := Win32CSDVersion;\r\nend;\r\n\r\nprocedure TJvOSVersionInfo.SetOSVersion(const Value: TWindowsVersion);\r\nbegin\r\n RaiseReadOnly;\r\nend;\r\n\r\nprocedure TJvOSVersionInfo.SetProductType(const Value: TNtProductType);\r\nbegin\r\n RaiseReadOnly;\r\nend;\r\n\r\nprocedure TJvOSVersionInfo.SetWinProductID(const Value: string);\r\nbegin\r\n RaiseReadOnly;\r\nend;\r\n\r\nprocedure TJvOSVersionInfo.SetWinProductName(const Value: string);\r\nbegin\r\n RaiseReadOnly;\r\nend;\r\n\r\nprocedure TJvOSVersionInfo.SetWinServicePackVersion(const Value: DWORD);\r\nbegin\r\n RaiseReadOnly;\r\nend;\r\n\r\nprocedure TJvOSVersionInfo.SetWinVersionBuild(const Value: DWORD);\r\nbegin\r\n RaiseReadOnly;\r\nend;\r\n\r\nprocedure TJvOSVersionInfo.SetWinVersionMajor(const Value: DWORD);\r\nbegin\r\n RaiseReadOnly;\r\nend;\r\n\r\nprocedure TJvOSVersionInfo.SetWinVersionMinor(const Value: DWORD);\r\nbegin\r\n RaiseReadOnly;\r\nend;\r\n\r\nprocedure TJvOSVersionInfo.SetWinVersionCSDString(const Value: string);\r\nbegin\r\n RaiseReadOnly;\r\nend;\r\n\r\n//=== { TJvCPUInfo } =========================================================\r\n\r\nfunction TJvCPUInfo.AMDSpecific: TAMDSpecific;\r\nvar\r\n ACpuInfo: TCpuInfo;\r\nbegin\r\n ACpuInfo := GetCPUInfo;\r\n if (ACpuInfo.CpuType = CPU_TYPE_AMD)\r\n then Result := ACpuInfo.AMDSpecific\r\n else FillChar(Result,SizeOf(Result),0);\r\nend;\r\n\r\nfunction TJvCPUInfo.CyrixSpecific: TCyrixSpecific;\r\nvar\r\n ACpuInfo: TCpuInfo;\r\nbegin\r\n ACpuInfo := GetCPUInfo;\r\n if (ACpuInfo.CpuType = CPU_TYPE_CYRIX)\r\n then Result := ACpuInfo.CyrixSpecific\r\n else FillChar(Result,SizeOf(Result),0);\r\nend;\r\n\r\nfunction TJvCPUInfo.Get3DNow: Boolean;\r\nbegin\r\n Result := GetCPUInfo._3DNow;\r\nend;\r\n\r\nfunction TJvCPUInfo.GetCPUInfo: TCPUInfo;\r\nbegin\r\n JclSysInfo.GetCPUInfo(Result);\r\nend;\r\n\r\nfunction TJvCPUInfo.GetCPUName: string;\r\nbegin\r\n Result := string(GetCPUInfo.CpuName);\r\nend;\r\n\r\nfunction TJvCPUInfo.GetCPUSpeed: TFreqInfo;\r\nbegin\r\n Result := GetCPUInfo.FrequencyInfo;\r\nend;\r\n\r\nfunction TJvCPUInfo.GetCPUType: TJvCPUType;\r\nbegin\r\n Result := TJvCPUType(GetCPUInfo.CpuType);\r\nend;\r\n\r\nfunction TJvCPUInfo.GetDEPCapable: Boolean;\r\nbegin\r\n Result := GetCPUInfo.DEPCapable;\r\nend;\r\n\r\nfunction TJvCPUInfo.GetEx3DNow: Boolean;\r\nbegin\r\n Result := GetCPUInfo.Ex3DNow;\r\nend;\r\n\r\nfunction TJvCPUInfo.GetExMMX: Boolean;\r\nbegin\r\n Result := GetCPUInfo.ExMMX;\r\nend;\r\n\r\nfunction TJvCPUInfo.GetExTicks: Cardinal;\r\nbegin\r\n Result := GetCPUSpeed.ExTicks;\r\nend;\r\n\r\nfunction TJvCPUInfo.GetFamily: Byte;\r\nbegin\r\n Result := GetCPUInfo.Family;\r\nend;\r\n\r\nfunction TJvCPUInfo.GetFeatures: Cardinal;\r\nbegin\r\n Result := GetCPUInfo.Features;\r\nend;\r\n\r\nfunction TJvCPUInfo.GetHasCacheInfo: Boolean;\r\nbegin\r\n Result := GetCPUInfo.HasCacheInfo;\r\nend;\r\n\r\nfunction TJvCPUInfo.GetHasExtendedInfo: Boolean;\r\nbegin\r\n Result := GetCPUInfo.HasExtendedInfo;\r\nend;\r\n\r\nfunction TJvCPUInfo.GetHasInstruction: Boolean;\r\nbegin\r\n Result := GetCPUInfo.HasInstruction;\r\nend;\r\n\r\nfunction TJvCPUInfo.GetHyperThreadingTechnology: Boolean;\r\nbegin\r\n Result := GetCPUInfo.HyperThreadingTechnology;\r\nend;\r\n\r\nfunction TJvCPUInfo.GetInCycles: Cardinal;\r\nbegin\r\n Result := GetCPUSpeed.InCycles;\r\nend;\r\n\r\nfunction TJvCPUInfo.GetIs64Bits: Boolean;\r\nbegin\r\n Result := GetCPUInfo.Is64Bits;\r\nend;\r\n\r\nfunction TJvCPUInfo.GetIsFDIVOK: Boolean;\r\nbegin\r\n Result := GetCPUInfo.IsFDIVOK;\r\nend;\r\n\r\nfunction TJvCPUInfo.GetL1CodeCache: Cardinal;\r\nbegin\r\n Result := GetCPUInfo.L1InstructionCacheSize;\r\nend;\r\n\r\nfunction TJvCPUInfo.GetL1DataCache: Cardinal;\r\nbegin\r\n Result := GetCPUInfo.L1DataCacheSize;\r\nend;\r\n\r\nfunction TJvCPUInfo.GetL2Cache: Cardinal;\r\nbegin\r\n Result := GetCPUInfo.L2CacheSize;\r\nend;\r\n\r\nfunction TJvCPUInfo.GetL3Cache: Cardinal;\r\nbegin\r\n Result := GetCPUInfo.L3CacheSize;\r\nend;\r\n\r\nfunction TJvCPUInfo.GetLogicalCore: Byte;\r\nbegin\r\n Result := GetCPUInfo.LogicalCore;\r\nend;\r\n\r\nfunction TJvCPUInfo.GetManufacturer: string;\r\nbegin\r\n Result := string(GetCPUInfo.Manufacturer);\r\nend;\r\n\r\nfunction TJvCPUInfo.GetMMX: Boolean;\r\nbegin\r\n Result := GetCPUInfo.MMX;\r\nend;\r\n\r\nfunction TJvCPUInfo.GetModel: Byte;\r\nbegin\r\n Result := GetCPUInfo.Model;\r\nend;\r\n\r\nfunction TJvCPUInfo.GetNormFreq: Int64;\r\nbegin\r\n Result := GetCPUSpeed.NormFreq;\r\nend;\r\n\r\nfunction TJvCPUInfo.GetPhysicalCore: Byte;\r\nbegin\r\n Result := GetCPUInfo.PhysicalCore;\r\nend;\r\n\r\nfunction TJvCPUInfo.GetProcessorCount: Integer;\r\nbegin\r\n Result := JclSysInfo.ProcessorCount;\r\nend;\r\n\r\nfunction TJvCPUInfo.GetRawFreq: Int64;\r\nbegin\r\n Result := GetCPUSpeed.RawFreq;\r\nend;\r\n\r\nfunction TJvCPUInfo.GetSSE: TSSESupports;\r\nbegin\r\n Result := GetCPUInfo.SSE;\r\nend;\r\n\r\nfunction TJvCPUInfo.GetStepping: Byte;\r\nbegin\r\n Result := GetCPUInfo.Stepping;\r\nend;\r\n\r\nfunction TJvCPUInfo.GetVendorIDString: string;\r\nbegin\r\n Result := string(GetCPUInfo.VendorIDString);\r\nend;\r\n\r\nfunction TJvCPUInfo.IntelSpecific: TIntelSpecific;\r\nvar\r\n ACpuInfo: TCpuInfo;\r\nbegin\r\n ACpuInfo := GetCPUInfo;\r\n if (ACpuInfo.CpuType = CPU_TYPE_INTEL)\r\n then Result := ACpuInfo.IntelSpecific\r\n else FillChar(Result,SizeOf(Result),0);\r\nend;\r\n\r\nprocedure TJvCPUInfo.Set3DNow(const Value: Boolean);\r\nbegin\r\n RaiseReadOnly;\r\nend;\r\n\r\nprocedure TJvCPUInfo.SetCPUName(const Value: string);\r\nbegin\r\n RaiseReadOnly;\r\nend;\r\n\r\nprocedure TJvCPUInfo.SetCPUType(const Value: TJvCPUType);\r\nbegin\r\n RaiseReadOnly;\r\nend;\r\n\r\nprocedure TJvCPUInfo.SetDEPCapable(const Value: Boolean);\r\nbegin\r\n RaiseReadOnly;\r\nend;\r\n\r\nprocedure TJvCPUInfo.SetEx3DNow(const Value: Boolean);\r\nbegin\r\n RaiseReadOnly;\r\nend;\r\n\r\nprocedure TJvCPUInfo.SetExMMX(const Value: Boolean);\r\nbegin\r\n RaiseReadOnly;\r\nend;\r\n\r\nprocedure TJvCPUInfo.SetExTicks(const Value: Cardinal);\r\nbegin\r\n RaiseReadOnly;\r\nend;\r\n\r\nprocedure TJvCPUInfo.SetFamily(const Value: Byte);\r\nbegin\r\n RaiseReadOnly;\r\nend;\r\n\r\nprocedure TJvCPUInfo.SetFeatures(const Value: Cardinal);\r\nbegin\r\n RaiseReadOnly;\r\nend;\r\n\r\nprocedure TJvCPUInfo.SetHasCacheInfo(const Value: Boolean);\r\nbegin\r\n RaiseReadOnly;\r\nend;\r\n\r\nprocedure TJvCPUInfo.SetHasExtendedInfo(const Value: Boolean);\r\nbegin\r\n RaiseReadOnly;\r\nend;\r\n\r\nprocedure TJvCPUInfo.SetHasInstruction(const Value: Boolean);\r\nbegin\r\n RaiseReadOnly;\r\nend;\r\n\r\nprocedure TJvCPUInfo.SetHyperThreadingTechnology(const Value: Boolean);\r\nbegin\r\n RaiseReadOnly;\r\nend;\r\n\r\nprocedure TJvCPUInfo.SetInCycles(const Value: Cardinal);\r\nbegin\r\n RaiseReadOnly;\r\nend;\r\n\r\nprocedure TJvCPUInfo.SetIs64Bits(const Value: Boolean);\r\nbegin\r\n RaiseReadOnly;\r\nend;\r\n\r\nprocedure TJvCPUInfo.SetIsFDIVOK(const Value: Boolean);\r\nbegin\r\n RaiseReadOnly;\r\nend;\r\n\r\nprocedure TJvCPUInfo.SetL1CodeCache(const Value: Cardinal);\r\nbegin\r\n RaiseReadOnly;\r\nend;\r\n\r\nprocedure TJvCPUInfo.SetL1DataCache(const Value: Cardinal);\r\nbegin\r\n RaiseReadOnly;\r\nend;\r\n\r\nprocedure TJvCPUInfo.SetL2Cache(const Value: Cardinal);\r\nbegin\r\n RaiseReadOnly;\r\nend;\r\n\r\nprocedure TJvCPUInfo.SetL3Cache(const Value: Cardinal);\r\nbegin\r\n RaiseReadOnly;\r\nend;\r\n\r\nprocedure TJvCPUInfo.SetLogicalCore(const Value: Byte);\r\nbegin\r\n RaiseReadOnly;\r\nend;\r\n\r\nprocedure TJvCPUInfo.SetManufacturer(const Value: string);\r\nbegin\r\n RaiseReadOnly;\r\nend;\r\n\r\nprocedure TJvCPUInfo.SetMMX(const Value: Boolean);\r\nbegin\r\n RaiseReadOnly;\r\nend;\r\n\r\nprocedure TJvCPUInfo.SetModel(const Value: Byte);\r\nbegin\r\n RaiseReadOnly;\r\nend;\r\n\r\nprocedure TJvCPUInfo.SetNormFreq(const Value: Int64);\r\nbegin\r\n RaiseReadOnly;\r\nend;\r\n\r\nprocedure TJvCPUInfo.SetPhysicalCore(const Value: Byte);\r\nbegin\r\n RaiseReadOnly;\r\nend;\r\n\r\nprocedure TJvCPUInfo.SetProcessorCount(const Value: Integer);\r\nbegin\r\n RaiseReadOnly;\r\nend;\r\n\r\nprocedure TJvCPUInfo.SetRawFreq(const Value: Int64);\r\nbegin\r\n RaiseReadOnly;\r\nend;\r\n\r\nprocedure TJvCPUInfo.SetSSE(const Value: TSSESupports);\r\nbegin\r\n RaiseReadOnly;\r\nend;\r\n\r\nprocedure TJvCPUInfo.SetStepping(const Value: Byte);\r\nbegin\r\n RaiseReadOnly;\r\nend;\r\n\r\nprocedure TJvCPUInfo.SetVendorIDString(const Value: string);\r\nbegin\r\n RaiseReadOnly;\r\nend;\r\n\r\nfunction TJvCPUInfo.TransmetaSpecific: TTransmetaSpecific;\r\nvar\r\n ACpuInfo: TCpuInfo;\r\nbegin\r\n ACpuInfo := GetCPUInfo;\r\n if (ACpuInfo.CpuType = CPU_TYPE_TRANSMETA)\r\n then Result := ACpuInfo.TransmetaSpecific\r\n else FillChar(Result,SizeOf(Result),0);\r\nend;\r\n\r\nfunction TJvCPUInfo.ViaSpecific: TViaSpecific;\r\nvar\r\n ACpuInfo: TCpuInfo;\r\nbegin\r\n ACpuInfo := GetCPUInfo;\r\n if (ACpuInfo.CpuType = CPU_TYPE_VIA)\r\n then Result := ACpuInfo.ViaSpecific\r\n else FillChar(Result,SizeOf(Result),0);\r\nend;\r\n\r\n//=== { TJvBIOSInfo } ========================================================\r\n\r\nfunction TJvBIOSInfo.GetBIOSCopyright: string;\r\nbegin\r\n Result := JclSysInfo.GetBIOSCopyright;\r\nend;\r\n\r\nfunction TJvBIOSInfo.GetBIOSDate: TDateTime;\r\nbegin\r\n Result := JclSysInfo.GetBIOSDate;\r\nend;\r\n\r\nfunction TJvBIOSInfo.GetBIOSExtendedInfo: string;\r\nbegin\r\n Result := JclSysInfo.GetBIOSExtendedInfo;\r\nend;\r\n\r\nfunction TJvBIOSInfo.GetBIOSName: string;\r\nbegin\r\n Result := JclSysInfo.GetBIOSName;\r\nend;\r\n\r\nprocedure TJvBIOSInfo.SetBIOSCopyright(const Value: string);\r\nbegin\r\n RaiseReadOnly;\r\nend;\r\n\r\nprocedure TJvBIOSInfo.SetBIOSDate(const Value: TDateTime);\r\nbegin\r\n RaiseReadOnly;\r\nend;\r\n\r\nprocedure TJvBIOSInfo.SetBIOSExtendedInfo(const Value: string);\r\nbegin\r\n RaiseReadOnly;\r\nend;\r\n\r\nprocedure TJvBIOSInfo.SetBIOSName(const Value: string);\r\nbegin\r\n RaiseReadOnly;\r\nend;\r\n\r\n//=== { TJvSystemFolders } ===================================================\r\n\r\nfunction TJvSystemFolders.AdjustPathDelimiter(const S: string): string;\r\nbegin\r\n if TrailingPathDelimiter then\r\n Result := IncludeTrailingPathDelimiter(S)\r\n else\r\n Result := ExcludeTrailingPathDelimiter(S);\r\nend;\r\n\r\nfunction TJvSystemFolders.GetCommonFiles: string;\r\nbegin\r\n Result := AdjustPathDelimiter(JclSysInfo.GetCommonFilesFolder);\r\nend;\r\n\r\nfunction TJvSystemFolders.GetCurrent: string;\r\nbegin\r\n Result := AdjustPathDelimiter(JclSysInfo.GetCurrentFolder);\r\nend;\r\n\r\nfunction TJvSystemFolders.Get(const Index: Integer): string;\r\nbegin\r\n Result := AdjustPathDelimiter(JclShell.GetSpecialFolderLocation(Index));\r\nend;\r\n\r\nfunction TJvSystemFolders.GetProgramFiles: string;\r\nbegin\r\n Result := AdjustPathDelimiter(JclSysInfo.GetProgramFilesFolder);\r\nend;\r\n\r\nfunction TJvSystemFolders.GetWindows: string;\r\nbegin\r\n Result := AdjustPathDelimiter(JclSysInfo.GetWindowsFolder);\r\nend;\r\n\r\nfunction TJvSystemFolders.GetSystem: string;\r\nbegin\r\n Result := AdjustPathDelimiter(JclSysInfo.GetWindowsSystemFolder);\r\nend;\r\n\r\nfunction TJvSystemFolders.GetTemp: string;\r\nbegin\r\n if not GetEnvironmentVar('TMP', Result, False) or not GetEnvironmentVar('TEMP', Result, False) then\r\n Result := GetCurrentDir;\r\n if Result <> '' then\r\n // the temp folder is usually in 8.3 format, so try to convert\r\n Result := AdjustPathDelimiter(PathGetLongName(Result));\r\nend;\r\n\r\nprocedure TJvSystemFolders.SetCommonFiles(const Value: string);\r\nbegin\r\n RaiseReadOnly;\r\nend;\r\n\r\nprocedure TJvSystemFolders.SetCurrent(const Value: string);\r\nbegin\r\n if not IsDesigning and not ReadOnly then\r\n SetCurrentDir(Value)\r\n else\r\n RaiseReadOnly;\r\nend;\r\n\r\nprocedure TJvSystemFolders.Put(const Index: Integer; const Value: string);\r\nbegin\r\n RaiseReadOnly;\r\nend;\r\n\r\nprocedure TJvSystemFolders.SetProgramFiles(const Value: string);\r\nbegin\r\n RaiseReadOnly;\r\nend;\r\n\r\nprocedure TJvSystemFolders.SetWindows(const Value: string);\r\nbegin\r\n RaiseReadOnly;\r\nend;\r\n\r\nprocedure TJvSystemFolders.SetSystem(const Value: string);\r\nbegin\r\n RaiseReadOnly;\r\nend;\r\n\r\nprocedure TJvSystemFolders.SetTemp(const Value: string);\r\nbegin\r\n RaiseReadOnly;\r\nend;\r\n\r\n//=== { TJvMemInfo } =========================================================\r\n\r\nfunction TJvMemInfo.GetFreePageFileMemory: Int64;\r\nbegin\r\n Result := JclSysInfo.GetFreePageFileMemory;\r\nend;\r\n\r\nfunction TJvMemInfo.GetFreePhysicalMemory: Int64;\r\nbegin\r\n Result := JclSysInfo.GetFreePhysicalMemory;\r\nend;\r\n\r\nfunction TJvMemInfo.GetFreeVirtualMemory: Int64;\r\nbegin\r\n Result := JclSysInfo.GetFreeVirtualMemory;\r\nend;\r\n\r\nfunction TJvMemInfo.GetMaxAppAddress: Integer;\r\nbegin\r\n Result := JclSysInfo.GetMaxAppAddress;\r\nend;\r\n\r\nfunction TJvMemInfo.GetMemoryLoad: Int64;\r\nbegin\r\n Result := JclSysInfo.GetMemoryLoad;\r\nend;\r\n\r\nfunction TJvMemInfo.GetMinAppAddress: Integer;\r\nbegin\r\n Result := JclSysInfo.GetMinAppAddress;\r\nend;\r\n\r\nfunction TJvMemInfo.GetSwapFileSize: Int64;\r\nbegin\r\n Result := JclSysInfo.GetSwapFileSize;\r\nend;\r\n\r\nfunction TJvMemInfo.GetSwapFileUsage: Integer;\r\nbegin\r\n Result := JclSysInfo.GetSwapFileUsage;\r\nend;\r\n\r\nfunction TJvMemInfo.GetTotalPageFileMemory: Int64;\r\nbegin\r\n Result := JclSysInfo.GetTotalPageFileMemory;\r\nend;\r\n\r\nfunction TJvMemInfo.GetTotalPhysicalMemory: Int64;\r\nbegin\r\n Result := JclSysInfo.GetTotalPhysicalMemory;\r\nend;\r\n\r\nfunction TJvMemInfo.GetTotalVirtualMemory: Int64;\r\nbegin\r\n Result := JclSysInfo.GetTotalVirtualMemory;\r\nend;\r\n\r\nprocedure TJvMemInfo.SetFreePageFileMemory(const Value: Int64);\r\nbegin\r\n RaiseReadOnly;\r\nend;\r\n\r\nprocedure TJvMemInfo.SetFreePhysicalMemory(const Value: Int64);\r\nbegin\r\n RaiseReadOnly;\r\nend;\r\n\r\nprocedure TJvMemInfo.SetFreeVirtualMemory(const Value: Int64);\r\nbegin\r\n RaiseReadOnly;\r\nend;\r\n\r\nprocedure TJvMemInfo.SetMaxAppAddress(const Value: Integer);\r\nbegin\r\n RaiseReadOnly;\r\nend;\r\n\r\nprocedure TJvMemInfo.SetMemoryLoad(const Value: Int64);\r\nbegin\r\n RaiseReadOnly;\r\nend;\r\n\r\nprocedure TJvMemInfo.SetMinAppAddress(const Value: Integer);\r\nbegin\r\n RaiseReadOnly;\r\nend;\r\n\r\nprocedure TJvMemInfo.SetSwapFileSize(const Value: Int64);\r\nbegin\r\n RaiseReadOnly;\r\nend;\r\n\r\nprocedure TJvMemInfo.SetSwapFileUsage(const Value: Integer);\r\nbegin\r\n RaiseReadOnly;\r\nend;\r\n\r\nprocedure TJvMemInfo.SetTotalPageFileMemory(const Value: Int64);\r\nbegin\r\n RaiseReadOnly;\r\nend;\r\n\r\nprocedure TJvMemInfo.SetTotalPhysicalMemory(const Value: Int64);\r\nbegin\r\n RaiseReadOnly;\r\nend;\r\n\r\nprocedure TJvMemInfo.SetTotalVirtualMemory(const Value: Int64);\r\nbegin\r\n RaiseReadOnly;\r\nend;\r\n\r\n//=== { TJvKeyInfo } =========================================================\r\n\r\nfunction TJvKeyInfo.GetCapsLockKeyState: Boolean;\r\nbegin\r\n Result := JclSysInfo.GetCapsLockKeyState;\r\nend;\r\n\r\nfunction TJvKeyInfo.GetKeyState(const VirtualKey: Cardinal): Boolean;\r\nbegin\r\n Result := JclSysInfo.GetKeyState(VirtualKey);\r\nend;\r\n\r\nfunction TJvKeyInfo.GetNumLockKeyState: Boolean;\r\nbegin\r\n Result := JclSysInfo.GetNumLockKeyState;\r\nend;\r\n\r\nfunction TJvKeyInfo.GetScrollLockKeyState: Boolean;\r\nbegin\r\n Result := JclSysInfo.GetScrollLockKeyState;\r\nend;\r\n\r\nprocedure TJvKeyInfo.SetCapsLockKeyState(const Value: Boolean);\r\nvar\r\n Keys: TKeyboardState;\r\nbegin\r\n if not IsDesigning and not ReadOnly then\r\n begin\r\n GetKeyboardState(Keys);\r\n Keys[VK_CAPITAL] := Ord(Value);\r\n SetKeyboardState(Keys);\r\n end\r\n else\r\n RaiseReadOnly;\r\nend;\r\n\r\nprocedure TJvKeyInfo.SetKeyState(const VirtualKey: Cardinal; const Value: Boolean);\r\nvar\r\n Keys: TKeyboardState;\r\nbegin\r\n if not IsDesigning and not ReadOnly then\r\n begin\r\n GetKeyboardState(Keys);\r\n Keys[VirtualKey] := Ord(Value) * $80;\r\n SetKeyboardState(Keys);\r\n end\r\n else\r\n RaiseReadOnly;\r\nend;\r\n\r\nprocedure TJvKeyInfo.SetNumLockKeyState(const Value: Boolean);\r\nvar\r\n Keys: TKeyboardState;\r\nbegin\r\n if not IsDesigning and not ReadOnly then\r\n begin\r\n GetKeyboardState(Keys);\r\n Keys[VK_NUMLOCK] := Ord(Value);\r\n SetKeyboardState(Keys);\r\n end\r\n else\r\n RaiseReadOnly;\r\nend;\r\n\r\nprocedure TJvKeyInfo.SetScrollLockKeyState(const Value: Boolean);\r\nvar\r\n Keys: TKeyboardState;\r\nbegin\r\n if not IsDesigning and not ReadOnly then\r\n begin\r\n GetKeyboardState(Keys);\r\n Keys[VK_SCROLL] := Ord(Value);\r\n SetKeyboardState(Keys);\r\n end\r\n else\r\n RaiseReadOnly;\r\nend;\r\n\r\n//=== { TJvIdentification } ==================================================\r\n\r\nconst\r\n cCommentRegPath = 'System\\CurrentControlSet\\Services\\VxD\\VNETSUP';\r\n cCommentRegPathNT = 'SYSTEM\\CurrentControlSet\\Services\\lanmanserver\\parameters';\r\n\r\nfunction TJvIdentification.GetComment: string;\r\nbegin\r\n if IsWinNT then\r\n // (p3) should return empty string on unsupported NT OS's\r\n Result := RegNativeReadStringDef(HKLM, cCommentRegPathNT, 'srvcomment', '')\r\n else\r\n Result := RegNativeReadStringDef(HKLM, cCommentRegPath, 'Comment', '')\r\nend;\r\n\r\nfunction TJvIdentification.GetDomainName: string;\r\nbegin\r\n Result := JclSysInfo.GetDomainName;\r\nend;\r\n\r\nfunction TJvIdentification.GetHostIPAddress(const HostName: string): string;\r\nbegin\r\n Result := JclSysInfo.GetIPAddress(HostName);\r\nend;\r\n\r\nfunction TJvIdentification.GetIPAddress: string;\r\nbegin\r\n Result := HostIPAddress[''];\r\nend;\r\n\r\nfunction TJvIdentification.GetLocalComputerName: string;\r\nbegin\r\n Result := JclSysInfo.GetLocalComputerName;\r\nend;\r\n\r\nfunction TJvIdentification.GetLocalUserName: string;\r\nbegin\r\n Result := JclSysInfo.GetLocalUserName;\r\nend;\r\n\r\n// avoid using LM.pas\r\ntype\r\n PWkstaInfo100 = ^TWkstaInfo100;\r\n _WKSTA_INFO_100 = record\r\n wki100_platform_id: DWORD;\r\n wki100_computername: LPWSTR;\r\n wki100_langroup: LPWSTR;\r\n wki100_ver_major: DWORD;\r\n wki100_ver_minor: DWORD;\r\n end;\r\n {$EXTERNALSYM _WKSTA_INFO_100}\r\n TWkstaInfo100 = _WKSTA_INFO_100;\r\n\r\nconst\r\n netapi32lib = 'netapi32.dll';\r\n\r\nvar\r\n _NetWkstaGetInfo: function(servername: LPWSTR; level: DWORD; bufptr: Pointer): DWORD; stdcall = nil;\r\n _NetApiBufferFree: function(Buffer: Pointer): DWORD; stdcall = nil;\r\n LibHandle: Cardinal = 0;\r\n\r\nfunction LoadNetLib: Boolean;\r\nbegin\r\n if LibHandle = 0 then\r\n begin\r\n LibHandle := SafeLoadLibrary(netapi32lib);\r\n if LibHandle <> 0 then\r\n begin\r\n @_NetWkstaGetInfo := GetProcAddress(LibHandle, 'NetWkstaGetInfo');\r\n @_NetApiBufferFree := GetProcAddress(LibHandle, 'NetApiBufferFree');\r\n end;\r\n end;\r\n Result := LibHandle <> 0;\r\nend;\r\n\r\nprocedure UnloadNetLib;\r\nbegin\r\n if LibHandle <> 0 then\r\n FreeLibrary(LibHandle);\r\n LibHandle := 0;\r\nend;\r\n\r\nfunction NetApiBufferFree(Buffer: Pointer): DWORD; stdcall;\r\nbegin\r\n if LoadNetLib and Assigned(_NetApiBufferFree) then\r\n Result := _NetApiBufferFree(Buffer)\r\n else\r\n Result := ERROR_CALL_NOT_IMPLEMENTED;\r\nend;\r\n\r\nfunction NetWkstaGetInfo(servername: LPWSTR; level: DWORD; bufptr: Pointer): DWORD;\r\nbegin\r\n if LoadNetLib and Assigned(_NetWkstaGetInfo) then\r\n Result := _NetWkstaGetInfo(servername, level, bufptr)\r\n else\r\n Result := ERROR_CALL_NOT_IMPLEMENTED;\r\nend;\r\n\r\nfunction TJvIdentification.GetLocalWorkgroup: string;\r\nvar\r\n LanInfo: PWkstaInfo100;\r\nbegin\r\n Result := RegNativeReadStringDef(HKLM, 'System\\CurrentControlSet\\Services\\Vxd\\VNETSUP', 'Workgroup', '');\r\n if (Result = '') and IsWinNT then\r\n begin\r\n LanInfo := nil;\r\n if (NetWkstaGetInfo(nil, 100, @LanInfo) = 0) and (LanInfo <> nil) then\r\n begin\r\n Result := LanInfo^.wki100_langroup;\r\n NetApiBufferFree(LanInfo);\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJvIdentification.GetRegisteredCompany: string;\r\nbegin\r\n Result := JclSysInfo.GetRegisteredCompany;\r\nend;\r\n\r\nfunction TJvIdentification.GetRegisteredOwner: string;\r\nbegin\r\n Result := JclSysInfo.GetRegisteredOwner;\r\nend;\r\n\r\nfunction TJvIdentification.GetUserDomainName(const CurUser: string): string;\r\nbegin\r\n Result := JclSysInfo.GetUserDomainName(CurUser);\r\nend;\r\n\r\nfunction TJvIdentification.GetVolumeFileSystem(const Drive: string): string;\r\nbegin\r\n Result := JclSysInfo.GetVolumeFileSystem(Drive);\r\nend;\r\n\r\nfunction TJvIdentification.GetVolumeName(const Drive: string): string;\r\nbegin\r\n Result := JclSysInfo.GetVolumeName(Drive);\r\nend;\r\n\r\nfunction TJvIdentification.GetVolumeSerialNumber(const Drive: string): string;\r\nbegin\r\n Result := JclSysInfo.GetVolumeSerialNumber(Drive);\r\nend;\r\n\r\nprocedure TJvIdentification.SetComment(const Value: string);\r\nbegin\r\n if not IsDesigning and not ReadOnly then\r\n begin\r\n // (p3) implementation dilemma: either allow the user to write the value regardless of\r\n // whether the OS supports it or not, or only write value if it is known to be supported?\r\n // Currently, only allow to write if known to be supported and raise error if not supported,\r\n // but maybe that's a bad idea?\r\n if IsWinXP then // \"srvcomment\" property only supported on WinXP AFAIK\r\n RegNativeWriteString(HKLM, cCommentRegPathNT, 'srvcomment', Value)\r\n else\r\n if not IsWinNT then\r\n // Win95/98 both support Comment\r\n RegWriteString(HKLM, cCommentRegPath, 'Comment', Value)\r\n else\r\n RaiseReadOnly; // ?? - or just let it pass unnoticed?\r\n end\r\n else\r\n RaiseReadOnly;\r\nend;\r\n\r\nprocedure TJvIdentification.SetDomainName(const Value: string);\r\nbegin\r\n RaiseReadOnly;\r\nend;\r\n\r\nprocedure TJvIdentification.SetIPAddress(const Value: string);\r\nbegin\r\n RaiseReadOnly;\r\nend;\r\n\r\nprocedure TJvIdentification.SetLocalComputerName(const Value: string);\r\nbegin\r\n if not IsDesigning and not ReadOnly then\r\n begin\r\n if not SetComputerName(PChar(Value)) then\r\n RaiseLastOSError;\r\n end\r\n else\r\n RaiseReadOnly;\r\nend;\r\n\r\nprocedure TJvIdentification.SetLocalUserName(const Value: string);\r\nbegin\r\n RaiseReadOnly;\r\nend;\r\n\r\nprocedure TJvIdentification.SetLocalWorkgroup(const Value: string);\r\nbegin\r\n RaiseReadOnly;\r\nend;\r\n\r\nprocedure TJvIdentification.SetRegisteredCompany(const Value: string);\r\nbegin\r\n if not IsDesigning and not ReadOnly then\r\n RegNativeWriteString(HKLM, REG_CURRENT_VERSION, 'RegisteredOrganization', Value)\r\n else\r\n RaiseReadOnly;\r\nend;\r\n\r\nprocedure TJvIdentification.SetRegisteredOwner(const Value: string);\r\nbegin\r\n if not IsDesigning and not ReadOnly then\r\n RegNativeWriteString(HKLM, REG_CURRENT_VERSION, 'RegisteredOwner', Value)\r\n else\r\n RaiseReadOnly;\r\nend;\r\n\r\n//=== { TJvScreenMode } ======================================================\r\n\r\nfunction DisplayFlagsToSet(Flags: DWORD): TJvDisplayFlags;\r\nbegin\r\n Result := [];\r\n if Flags and DM_GRAYSCALE = DM_GRAYSCALE then\r\n Include(Result, dmGrayScale);\r\n if Flags and DM_INTERLACED = DM_INTERLACED then\r\n Include(Result, dmInterlaced);\r\nend;\r\n\r\nfunction SetToDisplayFlags(Value: TJvDisplayFlags): DWORD;\r\nbegin\r\n Result := 0;\r\n if dmGrayScale in Value then\r\n Result := Result or DM_GRAYSCALE;\r\n if dmInterlaced in Value then\r\n Result := Result or DM_INTERLACED;\r\nend;\r\n\r\nprocedure TJvScreenMode.SetBitsPerPixel(const Value: DWORD);\r\nbegin\r\n RaiseReadOnly;\r\nend;\r\n\r\nprocedure TJvScreenMode.SetFlags(const Value: TJvDisplayFlags);\r\nbegin\r\n RaiseReadOnly;\r\nend;\r\n\r\nprocedure TJvScreenMode.SetHeight(const Value: Integer);\r\nbegin\r\n RaiseReadOnly;\r\nend;\r\n\r\nprocedure TJvScreenMode.SetHz(const Value: DWORD);\r\nbegin\r\n RaiseReadOnly;\r\nend;\r\n\r\nprocedure TJvScreenMode.SetWidth(const Value: Integer);\r\nbegin\r\n RaiseReadOnly;\r\nend;\r\n\r\n//=== { TJvScreenInfo } ======================================================\r\n\r\ndestructor TJvScreenInfo.Destroy;\r\nbegin\r\n FScreenModes.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJvScreenInfo.GetCurrentMode: TDeviceMode;\r\nconst\r\n cCurrentSettings = $FFFFFFFE;\r\nbegin\r\n Result.dmSize := SizeOf(Result);\r\n EnumDisplaySettings(nil, cCurrentSettings, Result);\r\nend;\r\n\r\nfunction TJvScreenInfo.GetBitsPerPixel: DWORD;\r\nbegin\r\n Result := GetCurrentMode.dmBitsPerPel; // ( 2^Result = number of colors\r\nend;\r\n\r\nfunction TJvScreenInfo.GetScreenFrequency: DWORD;\r\nbegin\r\n Result := GetCurrentMode.dmDisplayFrequency;\r\n if Result in [0, 1] then\r\n Result := 60; // - default screen frequency but don't know how to get it...\r\nend;\r\n\r\nfunction TJvScreenInfo.GetScreenHeight: DWORD;\r\nbegin\r\n Result := ScreenResolution.Y;\r\nend;\r\n\r\nfunction TJvScreenInfo.GetScreenResolution: TPoint;\r\nbegin\r\n with GetCurrentMode do\r\n Result := Point(dmPelsWidth, dmPelsHeight);\r\nend;\r\n\r\nfunction TJvScreenInfo.GetScreenWidth: DWORD;\r\nbegin\r\n Result := ScreenResolution.X;\r\nend;\r\n\r\nprocedure TJvScreenInfo.SetBitsPerPixel(const Value: DWORD);\r\nvar\r\n DevMode: TDeviceMode;\r\nbegin\r\n if not IsDesigning and not ReadOnly then\r\n begin\r\n DevMode := GetCurrentMode;\r\n if DevMode.dmBitsPerPel <> Value then\r\n DevMode.dmBitsPerPel := Value;\r\n DevMode.dmFields := DM_BITSPERPEL;\r\n SetCurrentMode(DevMode, CDS_UPDATEREGISTRY);\r\n end\r\n else\r\n RaiseReadOnly;\r\nend;\r\n\r\nprocedure TJvScreenInfo.SetScreenFrequency(const Value: DWORD);\r\nvar\r\n DevMode: TDeviceMode;\r\nbegin\r\n if not IsDesigning and not ReadOnly then\r\n begin\r\n DevMode := GetCurrentMode;\r\n if DevMode.dmDisplayFrequency <> Value then\r\n DevMode.dmDisplayFrequency := Value;\r\n DevMode.dmFields := DM_DISPLAYFREQUENCY;\r\n SetCurrentMode(DevMode, CDS_UPDATEREGISTRY);\r\n end\r\n else\r\n RaiseReadOnly;\r\nend;\r\n\r\nprocedure TJvScreenInfo.SetScreenHeight(const Value: DWORD);\r\nvar\r\n DevMode: TDeviceMode;\r\nbegin\r\n if not IsDesigning and not ReadOnly then\r\n begin\r\n DevMode := GetCurrentMode;\r\n if DevMode.dmPelsHeight <> Value then\r\n DevMode.dmPelsHeight := Value;\r\n DevMode.dmFields := DM_PELSHEIGHT;\r\n SetCurrentMode(DevMode, CDS_UPDATEREGISTRY);\r\n end\r\n else\r\n RaiseReadOnly;\r\nend;\r\n\r\nprocedure TJvScreenInfo.SetScreenResolution(const Value: TPoint);\r\nbegin\r\n RaiseReadOnly;\r\nend;\r\n\r\nprocedure TJvScreenInfo.SetScreenWidth(const Value: DWORD);\r\nvar\r\n DevMode: TDeviceMode;\r\nbegin\r\n if not IsDesigning and not ReadOnly then\r\n begin\r\n DevMode := GetCurrentMode;\r\n if DevMode.dmPelsWidth <> Value then\r\n DevMode.dmPelsWidth := Value;\r\n DevMode.dmFields := DM_PELSWIDTH;\r\n SetCurrentMode(DevMode, CDS_UPDATEREGISTRY);\r\n end\r\n else\r\n RaiseReadOnly;\r\nend;\r\n\r\nfunction TJvScreenInfo.GetFlags: TJvDisplayFlags;\r\nbegin\r\n Result := DisplayFlagsToSet(GetCurrentMode.dmDisplayFlags);\r\nend;\r\n\r\nprocedure TJvScreenInfo.SetFlags(const Value: TJvDisplayFlags);\r\nvar\r\n DevMode: TDeviceMode;\r\n Flags: DWORD;\r\nbegin\r\n if not IsDesigning and not ReadOnly then\r\n begin\r\n Flags := SetToDisplayFlags(Value);\r\n DevMode := GetCurrentMode;\r\n if DevMode.dmDisplayFlags <> Flags then\r\n DevMode.dmDisplayFlags := Flags;\r\n DevMode.dmFields := DM_DISPLAYFLAGS;\r\n SetCurrentMode(DevMode, CDS_UPDATEREGISTRY);\r\n end\r\n else\r\n RaiseReadOnly;\r\nend;\r\n\r\nfunction TJvScreenInfo.GetScreenModes: TJvScreenModes;\r\nbegin\r\n if FScreenModes = nil then\r\n FScreenModes := TJvScreenModes.Create;\r\n FScreenModes.Refresh;\r\n Result := FScreenModes;\r\nend;\r\n\r\nprocedure TJvScreenInfo.SetScreenModes(const Value: TJvScreenModes);\r\nbegin\r\n //\r\nend;\r\n\r\nprocedure TJvScreenInfo.SetCurrentMode(ADeviceMode: TDeviceMode; Flags: DWORD);\r\nbegin\r\n if not IsDesigning and not ReadOnly then\r\n begin\r\n if ChangeDisplaySettings(ADeviceMode, CDS_TEST) = DISP_CHANGE_SUCCESSFUL then\r\n ChangeDisplaySettings(ADeviceMode, Flags);\r\n // else\r\n // RaiseLastOSError;\r\n end\r\n else\r\n RaiseReadOnly;\r\nend;\r\n\r\n//=== { TJvAppVersions } =====================================================\r\n\r\nfunction TJvAppVersions.GetADOVersion: string;\r\nbegin\r\n Result := RegNativeReadStringDef(HKLM, '\\SOFTWARE\\Microsoft\\DataAccess', 'Version', '');\r\nend;\r\n\r\nfunction TJvAppVersions.GetBDELocation: string;\r\nbegin\r\n Result := ExcludeTrailingPathDelimiter(RegReadStringDef(HKLM,\r\n '\\SOFTWARE\\Borland\\Database Engine', 'DLLPATH', ''));\r\nend;\r\n\r\nfunction TJvAppVersions.GetBDEVersion: string;\r\nbegin\r\n Result := IncludeTrailingPathDelimiter(GetBDELocation) + 'idapi32.dll';\r\n if not VersionResourceAvailable(Result) then\r\n Result := IncludeTrailingPathDelimiter(GetBDELocation) + 'bdeadmin.exe';\r\n\r\n if VersionResourceAvailable(Result) then\r\n begin\r\n with TJclFileVersionInfo.Create(Result) do\r\n try\r\n Result := FileVersion;\r\n finally\r\n Free;\r\n end;\r\n end\r\n else\r\n Result := '';\r\nend;\r\n\r\nfunction TJvAppVersions.GetIEVersion: string;\r\nbegin\r\n Result := RegNativeReadStringDef(HKLM, '\\SOFTWARE\\Microsoft\\Internet Explorer', 'Version', '');\r\nend;\r\n\r\nfunction TJvAppVersions.GetOpenGLVersion: string;\r\nvar\r\n AVendor: AnsiString;\r\n ASResult: AnsiString;\r\nbegin\r\n if not JclSysInfo.GetOpenGLVersion(GetActiveWindow, ASResult, AVendor) then\r\n Result := ''\r\n else\r\n Result := string(ASResult);\r\nend;\r\n\r\nfunction TJvAppVersions.GetDirectXVersion: string;\r\nbegin\r\n Result := RegNativeReadStringDef(HKLM, '\\SOFTWARE\\Microsoft\\DirectX', 'Version', '');\r\nend;\r\n\r\nprocedure TJvAppVersions.SetADOVersion(const Value: string);\r\nbegin\r\n RaiseReadOnly;\r\nend;\r\n\r\nprocedure TJvAppVersions.SetBDEVersion(const Value: string);\r\nbegin\r\n RaiseReadOnly;\r\nend;\r\n\r\nprocedure TJvAppVersions.SetIEVersion(const Value: string);\r\nbegin\r\n RaiseReadOnly;\r\nend;\r\n\r\nprocedure TJvAppVersions.SetOpenGLVersion(const Value: string);\r\nbegin\r\n RaiseReadOnly;\r\nend;\r\n\r\nprocedure TJvAppVersions.SetDirectXVersion(const Value: string);\r\nbegin\r\n RaiseReadOnly;\r\nend;\r\n\r\n//=== { TJvHardwareProfile } =================================================\r\n\r\nfunction TJvHardwareProfile.GetDockInfo: TJvHWDockInfo;\r\nvar\r\n Flags: DWORD;\r\nbegin\r\n Flags := NativeType.dwDockInfo;\r\n Result := [];\r\n if Flags and DOCKINFO_DOCKED = DOCKINFO_DOCKED then\r\n Include(Result, diDocked);\r\n if Flags and DOCKINFO_UNDOCKED = DOCKINFO_UNDOCKED then\r\n Include(Result, diUndocked);\r\n if Flags and DOCKINFO_USER_SUPPLIED = DOCKINFO_USER_SUPPLIED then\r\n Include(Result, diUserSupplied);\r\n if Flags and DOCKINFO_USER_DOCKED = DOCKINFO_USER_DOCKED then\r\n Include(Result, diUserDocked);\r\n if Flags and DOCKINFO_USER_UNDOCKED = DOCKINFO_USER_UNDOCKED then\r\n Include(Result, diUserUndocked);\r\nend;\r\n\r\nfunction TJvHardwareProfile.GetGUID: string;\r\nbegin\r\n Result := NativeType.szHwProfileGuid;\r\nend;\r\n\r\nfunction TJvHardwareProfile.GetName: string;\r\nbegin\r\n Result := NativeType.szHwProfileName;\r\nend;\r\n\r\nfunction TJvHardwareProfile.GetNativeType: HW_PROFILE_INFO;\r\ntype\r\n GetCurrentHwProfileFunc = function(var lpHwProfileInfo: HW_PROFILE_INFO): BOOL; stdcall;\r\nvar\r\n GetCurrentHwProfile: GetCurrentHwProfileFunc;\r\n LibHandle: THandle;\r\nbegin\r\n FillChar(Result, SizeOf(Result), 0);\r\n // GetCurrentHwProfile is not available on all Win95's\r\n LibHandle := SafeLoadLibrary('advapi32.dll');\r\n if LibHandle <> 0 then\r\n try\r\n {$IFDEF UNICODE}\r\n @GetCurrentHwProfile := GetProcAddress(LibHandle, 'GetCurrentHwProfileW');\r\n {$ELSE}\r\n @GetCurrentHwProfile := GetProcAddress(LibHandle, 'GetCurrentHwProfileA');\r\n {$ENDIF UNICODE}\r\n if Assigned(GetCurrentHwProfile) then\r\n GetCurrentHwProfile(Result);\r\n finally\r\n FreeLibrary(LibHandle);\r\n end;\r\nend;\r\n\r\nprocedure TJvHardwareProfile.SetDockInfo(const Value: TJvHWDockInfo);\r\nbegin\r\n RaiseReadOnly;\r\nend;\r\n\r\nprocedure TJvHardwareProfile.SetGUID(const Value: string);\r\nbegin\r\n RaiseReadOnly;\r\nend;\r\n\r\nprocedure TJvHardwareProfile.SetName(const Value: string);\r\nbegin\r\n RaiseReadOnly;\r\nend;\r\n\r\n//=== { TJvScreenModes } =====================================================\r\n\r\nconstructor TJvScreenModes.Create;\r\nbegin\r\n FItems := TList.Create;\r\n FDefaultMode := TJvScreenMode.Create;\r\nend;\r\n\r\ndestructor TJvScreenModes.Destroy;\r\nbegin\r\n Clear;\r\n FItems.Free;\r\n FDefaultMode.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvScreenModes.Clear;\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := 0 to FItems.Count - 1 do\r\n TObject(FItems[I]).Free;\r\n FItems.Clear;\r\nend;\r\n\r\nfunction TJvScreenModes.GetCount: Integer;\r\nbegin\r\n Result := FItems.Count;\r\nend;\r\n\r\nfunction TJvScreenModes.GetItems(Index: Integer): TJvScreenMode;\r\nbegin\r\n if Index < 0 then\r\n Result := FDefaultMode\r\n else\r\n if (Index >= 0) and (Index < Count) then\r\n Result := TJvScreenMode(FItems[Index])\r\n else\r\n Result := nil;\r\nend;\r\n\r\nprocedure TJvScreenModes.Refresh;\r\nconst\r\n cCurrentSettings = $FFFFFFFE;\r\nvar\r\n I: Integer;\r\n DevMode: TDeviceMode;\r\n Item: TJvScreenMode;\r\nbegin\r\n FItems.Clear;\r\n DevMode.dmSize := SizeOf(DevMode);\r\n I := 0;\r\n EnumDisplaySettings(nil, cCurrentSettings, DevMode);\r\n if DevMode.dmDisplayFrequency < 2 then\r\n FDefaultMode.FHz := 60\r\n else\r\n FDefaultMode.FHz := DevMode.dmDisplayFrequency;\r\n FDefaultMode.FWidth := DevMode.dmPelsWidth;\r\n FDefaultMode.FHeight := DevMode.dmPelsHeight;\r\n FDefaultMode.FBitsPerPixel := DevMode.dmBitsPerPel;\r\n FDefaultMode.FFlags := DisplayFlagsToSet(DevMode.dmDisplayFlags);\r\n\r\n while EnumDisplaySettings(nil, I, DevMode) do\r\n begin\r\n Item := TJvScreenMode.Create;\r\n if DevMode.dmDisplayFrequency < 2 then\r\n Item.FHz := 60 // pure guess work\r\n else\r\n Item.FHz := DevMode.dmDisplayFrequency;\r\n Item.FWidth := DevMode.dmPelsWidth;\r\n Item.FHeight := DevMode.dmPelsHeight;\r\n Item.FBitsPerPixel := DevMode.dmBitsPerPel;\r\n Item.FFlags := DisplayFlagsToSet(DevMode.dmDisplayFlags);\r\n FItems.Add(Item);\r\n Inc(I);\r\n end;\r\nend;\r\n\r\nprocedure TJvScreenModes.SetItems(Index: Integer; const Value: TJvScreenMode);\r\nbegin\r\n RaiseReadOnly;\r\nend;\r\n\r\n//=== { TJvMiscInfo } ========================================================\r\n\r\nconst\r\n HKCU_CONTROL_PANEL_DESKTOP = '\\Control Panel\\Desktop';\r\n\r\ndestructor TJvMiscInfo.Destroy;\r\nbegin\r\n FVersions.Free;\r\n FColorSchemes.Free;\r\n FHardwareProfile.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJvMiscInfo.GetColorSchemes: TStrings;\r\nvar\r\n Reg: TRegistry;\r\nbegin\r\n if FColorSchemes = nil then\r\n FColorSchemes := TStringlist.Create;\r\n FColorSchemes.Clear;\r\n Reg := TRegistry.Create(KEY_READ);\r\n try\r\n if Reg.OpenKeyReadOnly('\\Control Panel\\Appearance\\Schemes') then\r\n Reg.GetValueNames(FColorSchemes);\r\n finally\r\n Reg.Free;\r\n end;\r\n TStringlist(FColorSchemes).Sort;\r\n Result := FColorSchemes;\r\nend;\r\n\r\nfunction TJvMiscInfo.GetCurrentColorScheme: string;\r\nbegin\r\n Result := RegReadStringDef(HKCU, '\\Control Panel\\Current', 'Color Schemes', '');\r\nend;\r\n\r\nfunction TJvMiscInfo.GetDVDRegion: Integer;\r\nbegin\r\n Result := RegNativeReadIntegerDef(HKLM, REG_CURRENT_VERSION, 'DVD_Region', -1);\r\nend;\r\n\r\nfunction TJvMiscInfo.GetHardwareProfile: TJvHardwareProfile;\r\nbegin\r\n if FHardwareProfile = nil then\r\n FHardwareProfile := TJvHardwareProfile.Create;\r\n Result := FHardwareProfile;\r\nend;\r\n\r\nfunction TJvMiscInfo.GetIsOnline: Boolean;\r\nconst\r\n INTERNET_CONNECTION_OFFLINE = $20;\r\ntype\r\n TInternetGetConnectedStateFunc = function (lpdwFlags: LPDWORD;\r\n dwReserved: DWORD): BOOL; stdcall;\r\nvar\r\n ConnectFlag: DWORD;\r\n LibraryHandle: THandle;\r\n InternetGetConnectedStateFunc: TInternetGetConnectedStateFunc;\r\nbegin\r\n LibraryHandle := SafeLoadLibrary('wininet.dll'); { Do not localize }\r\n try\r\n InternetGetConnectedStateFunc := GetProcAddress(LibraryHandle, 'InternetGetConnectedState'); { Do not localize }\r\n Result := Assigned(InternetGetConnectedStateFunc) and InternetGetConnectedStateFunc(@ConnectFlag, 0) and\r\n (ConnectFlag <> INTERNET_CONNECTION_OFFLINE);\r\n finally\r\n FreeLibrary(LibraryHandle);\r\n end;\r\n //Result := InternetGetConnectedState(@ConnectFlag, 0) and (ConnectFlag <> INTERNET_CONNECTION_OFFLINE);\r\nend;\r\n\r\nfunction TJvMiscInfo.GetNetBIOS: Boolean;\r\ntype\r\n _NCB64 = record\r\n ncb_command: UCHAR; // command code\r\n ncb_retcode: UCHAR; // return code\r\n ncb_lsn: UCHAR; // local session number\r\n ncb_num: UCHAR; // number of our network name\r\n ncb_buffer: PUCHAR; // address of message buffer\r\n ncb_length: Word; // size of message buffer\r\n ncb_callname: array [0..NCBNAMSZ - 1] of UCHAR; // blank-padded name of remote\r\n ncb_name: array [0..NCBNAMSZ - 1] of UCHAR; // our blank-padded netname\r\n ncb_rto: UCHAR; // rcv timeout/retry count\r\n ncb_sto: UCHAR; // send timeout/sys timeout\r\n ncb_post: TNcbPost; // POST routine address\r\n ncb_lana_num: UCHAR; // lana (adapter) number\r\n ncb_cmd_cplt: UCHAR; // 0xff => commmand pending\r\n ncb_reserve: array [0..17] of UCHAR; // reserved, used by BIOS\r\n ncb_event: THandle; // HANDLE to Win32 event which\r\n // will be set to the signalled\r\n // state when an ASYNCH command\r\n // completes\r\n end;\r\n\r\nvar\r\n P: _NCB64; // 64bit structure is larger than the 32bit structure\r\nbegin\r\n FillChar(P, SizeOf(P), 0);\r\n P.ncb_command := NCBASTAT;\r\n Result := RtdlNetBios(@P) <> NRC_OPENERR;\r\nend;\r\n\r\nfunction TJvMiscInfo.GetPattern: string;\r\nbegin\r\n Result := RegReadStringDef(HKCU, HKCU_CONTROL_PANEL_DESKTOP, 'Pattern', '');\r\nend;\r\n\r\nfunction TJvMiscInfo.GetScreenSaver: string;\r\nbegin\r\n Result := RegReadStringDef(HKCU, HKCU_CONTROL_PANEL_DESKTOP, 'SCRNSAVE.EXE', '');\r\n if Result <> '' then\r\n // screen saver is usually returned in 8.3 format\r\n Result := PathGetLongName(Result);\r\nend;\r\n\r\nfunction TJvMiscInfo.GetTimeRunning: Int64;\r\nbegin\r\n Result := GetTickCount64;\r\nend;\r\n(*\r\nAdded to JvJVCLUtils:\r\n\r\nfunction GetTickCount64: Int64;\r\nvar\r\n QFreq, QCount:Int64;\r\nbegin\r\n Result := GetTickCount;\r\n if QueryPerformanceFrequency(QFreq) then\r\n begin\r\n QueryPerformanceCounter(QCount);\r\n if QFreq <> 0 then\r\n Result := (QCount div QFreq) * 1000;\r\n end;\r\nend;\r\n*)\r\n\r\nfunction TJvMiscInfo.GetTimeRunningAsString: string;\r\nvar\r\n DateTime: TDateTime;\r\nbegin\r\n DateTime := GetTimeRunning / 86400000;\r\n Result := Format('%d %s', [Trunc(DateTime), TimeToStr(DateTime)]);\r\nend;\r\n\r\nfunction TJvMiscInfo.GetVersions: TJvAppVersions;\r\nbegin\r\n if FVersions = nil then\r\n FVersions := TJvAppVersions.Create;\r\n Result := FVersions;\r\nend;\r\n\r\nfunction TJvMiscInfo.GetWallpaper: string;\r\nbegin\r\n Result := RegReadStringDef(HKCU, HKCU_CONTROL_PANEL_DESKTOP, 'Wallpaper', '');\r\nend;\r\n\r\nfunction TJvMiscInfo.GetWallpaperStyle: TJvWallpaperStyle;\r\nbegin\r\n Result := TJvWallpaperStyle(StrToInt(RegReadStringDef(HKCU, HKCU_CONTROL_PANEL_DESKTOP, 'WallpaperStyle', '0')));\r\nend;\r\n\r\nfunction TJvMiscInfo.GetWallpaperTiled: Boolean;\r\nbegin\r\n Result := RegReadStringDef(HKCU, HKCU_CONTROL_PANEL_DESKTOP, 'TileWallpaper', '0') <> '0';\r\nend;\r\n\r\nprocedure TJvMiscInfo.SetColorSchemes(const Value: TStrings);\r\nbegin\r\n RaiseReadOnly;\r\nend;\r\n\r\nprocedure TJvMiscInfo.SetCurrentColorScheme(const Value: string);\r\nbegin\r\n if not IsDesigning and not ReadOnly then\r\n RegWriteString(HKCU, '\\Control Panel\\Current', 'Color Schemes', Value)\r\n else\r\n RaiseReadOnly;\r\nend;\r\n\r\nprocedure TJvMiscInfo.SetDVDRegion(const Value: Integer);\r\nbegin\r\n RaiseReadOnly;\r\nend;\r\n\r\nprocedure TJvMiscInfo.SetHardwareProfile(const Value: TJvHardwareProfile);\r\nbegin\r\n //\r\nend;\r\n\r\nprocedure TJvMiscInfo.SetIsOnline(const Value: Boolean);\r\nbegin\r\n RaiseReadOnly;\r\nend;\r\n\r\nprocedure TJvMiscInfo.SetNetBIOS(const Value: Boolean);\r\nbegin\r\n RaiseReadOnly;\r\nend;\r\n\r\nprocedure TJvMiscInfo.SetPattern(const Value: string);\r\nbegin\r\n if not IsDesigning and not ReadOnly then\r\n RegWriteString(HKCU, HKCU_CONTROL_PANEL_DESKTOP, 'Pattern', Value)\r\n else\r\n RaiseReadOnly;\r\nend;\r\n\r\nprocedure TJvMiscInfo.SetScreenSaver(const Value: string);\r\nbegin\r\n if not IsDesigning and not ReadOnly then\r\n RegWriteString(HKCU, HKCU_CONTROL_PANEL_DESKTOP, 'SCRSAVE.EXE', Value)\r\n else\r\n RaiseReadOnly;\r\nend;\r\n\r\nprocedure TJvMiscInfo.SetTimeRunning(const Value: Int64);\r\nbegin\r\n RaiseReadOnly;\r\nend;\r\n\r\nprocedure TJvMiscInfo.SetTimeRunningAsString(const Value: string);\r\nbegin\r\n RaiseReadOnly;\r\nend;\r\n\r\nprocedure TJvMiscInfo.SetVersions(const Value: TJvAppVersions);\r\nbegin\r\n //\r\nend;\r\n\r\nprocedure TJvMiscInfo.SetWallpaper(const Value: string);\r\nbegin\r\n if not IsDesigning and not ReadOnly then\r\n RegWriteString(HKCU, HKCU_CONTROL_PANEL_DESKTOP, 'Wallpaper', Value)\r\n else\r\n RaiseReadOnly;\r\nend;\r\n\r\nprocedure TJvMiscInfo.SetWallpaperStyle(const Value: TJvWallpaperStyle);\r\nbegin\r\n if not IsDesigning and not ReadOnly then\r\n begin\r\n if Value <> wsUnused then\r\n RegWriteString(HKCU, HKCU_CONTROL_PANEL_DESKTOP, 'WallpaperStyle', IntToStr(Ord(Value)));\r\n end\r\n else\r\n RaiseReadOnly;\r\nend;\r\n\r\nprocedure TJvMiscInfo.SetWallpaperTiled(const Value: Boolean);\r\nbegin\r\n if not IsDesigning and not ReadOnly then\r\n RegWriteString(HKCU, HKCU_CONTROL_PANEL_DESKTOP, 'TileWallpaper', IntToStr(Ord(Value)))\r\n else\r\n RaiseReadOnly;\r\nend;\r\n\r\n//=== { TJvMetricsInfo } =====================================================\r\n\r\nfunction TJvMetricsInfo.GetACP: Integer;\r\nbegin\r\n Result := Windows.GetACP;\r\nend;\r\n\r\nfunction TJvMetricsInfo.GetArrange: TJvWindowsArrange;\r\nbegin\r\n Result := ArrangeToWindowsArrange(GetSystemMetrics(SM_ARRANGE));\r\nend;\r\n\r\nfunction TJvMetricsInfo.GetBoolMetrics(const Index: Integer): Boolean;\r\nbegin\r\n Result := GetSystemMetrics(Index) <> 0;\r\nend;\r\n\r\nfunction TJvMetricsInfo.GetCaretBlinkTime: DWORD;\r\nbegin\r\n Result := Windows.GetCaretBlinkTime;\r\nend;\r\n\r\nfunction TJvMetricsInfo.GetCaretPos(const Index: Integer): Integer;\r\nvar\r\n P: TPoint;\r\nbegin\r\n Result := -1;\r\n if not Windows.GetCaretPos(P) then\r\n P := Point(-1, -1);\r\n case Index of\r\n 0:\r\n Result := P.X;\r\n 1:\r\n Result := P.Y;\r\n end;\r\nend;\r\n\r\nfunction TJvMetricsInfo.GetCleanBoot: TJvCleanBoot;\r\nbegin\r\n Result := TJvCleanBoot(GetSystemMetrics(SM_CLEANBOOT));\r\nend;\r\n\r\nfunction TJvMetricsInfo.GetCursorPos(const Index: Integer): Integer;\r\nvar\r\n P: TPoint;\r\nbegin\r\n Result := -1;\r\n if not Windows.GetCursorPos(P) then\r\n P := Point(-1, -1);\r\n case Index of\r\n 0:\r\n Result := P.X;\r\n 1:\r\n Result := P.Y;\r\n end;\r\nend;\r\n\r\nfunction TJvMetricsInfo.GetDialogBaseUnits: Integer;\r\nbegin\r\n Result := Windows.GetDialogBaseUnits;\r\nend;\r\n\r\nfunction TJvMetricsInfo.GetDoubleClickTime: Integer;\r\nbegin\r\n Result := Windows.GetDoubleClickTime;\r\nend;\r\n\r\nfunction TJvMetricsInfo.GetMetrics(const Index: Integer): Integer;\r\nbegin\r\n Result := GetSystemMetrics(Index);\r\nend;\r\n\r\nfunction TJvMetricsInfo.GetOEMCP: Integer;\r\nbegin\r\n Result := Windows.GetOEMCP;\r\nend;\r\n\r\nprocedure TJvMetricsInfo.SetACP(const Value: Integer);\r\nbegin\r\n RaiseReadOnly;\r\nend;\r\n\r\nprocedure TJvMetricsInfo.SetArrange(const Value: TJvWindowsArrange);\r\nbegin\r\n RaiseReadOnly;\r\nend;\r\n\r\nprocedure TJvMetricsInfo.SetBoolMetrics(const Index: Integer;\r\n const Value: Boolean);\r\nbegin\r\n RaiseReadOnly;\r\nend;\r\n\r\nprocedure TJvMetricsInfo.SetCaretBlinkTime(const Value: DWORD);\r\nbegin\r\n if not IsDesigning and not ReadOnly then\r\n Windows.SetCaretBlinkTime(Value)\r\n else\r\n RaiseReadOnly;\r\nend;\r\n\r\nprocedure TJvMetricsInfo.SetCaretPos(const Index, Value: Integer);\r\nvar\r\n P: TPoint;\r\nbegin\r\n if not IsDesigning and not ReadOnly then\r\n begin\r\n Windows.GetCaretPos(P);\r\n case Index of\r\n 0:\r\n P.X := Value;\r\n 1:\r\n P.Y := Value;\r\n end;\r\n Windows.SetCaretPos(P.X, P.Y);\r\n end\r\n else\r\n RaiseReadOnly;\r\nend;\r\n\r\nprocedure TJvMetricsInfo.SetCleanBoot(const Value: TJvCleanBoot);\r\nbegin\r\n RaiseReadOnly;\r\nend;\r\n\r\nprocedure TJvMetricsInfo.SetCursorPos(const Index, Value: Integer);\r\nvar\r\n P: TPoint;\r\nbegin\r\n if not IsDesigning and not ReadOnly then\r\n begin\r\n Windows.GetCursorPos(P);\r\n case Index of\r\n 0:\r\n P.X := Value;\r\n 1:\r\n P.Y := Value;\r\n end;\r\n Windows.SetCursorPos(P.X, P.Y);\r\n end\r\n else\r\n RaiseReadOnly;\r\nend;\r\n\r\nprocedure TJvMetricsInfo.SetDialogBaseUnits(const Value: Integer);\r\nbegin\r\n RaiseReadOnly;\r\nend;\r\n\r\nprocedure TJvMetricsInfo.SetDoubleClickTime(const Value: Integer);\r\nbegin\r\n\r\nend;\r\n\r\nprocedure TJvMetricsInfo.SetMetrics(const Index, Value: Integer);\r\nbegin\r\n RaiseReadOnly;\r\nend;\r\n\r\nprocedure TJvMetricsInfo.SetOEMCP(const Value: Integer);\r\nbegin\r\n RaiseReadOnly;\r\nend;\r\n\r\n//=== { TJvAccessTimeOut } ===================================================\r\n\r\nfunction TJvAccessTimeOut.GetFlags: TJvAccessTimeOutFlags;\r\nvar\r\n Flags: DWORD;\r\nbegin\r\n Flags := NativeType.dwFlags;\r\n Result := [];\r\n if Flags and ATF_ONOFFFEEDBACK = ATF_ONOFFFEEDBACK then\r\n Include(Result, atfOnOffFeedback);\r\n if Flags and ATF_TIMEOUTON = ATF_TIMEOUTON then\r\n Include(Result, atfTimeOutOn);\r\nend;\r\n\r\nfunction TJvAccessTimeOut.GetNativeType: ACCESSTIMEOUT;\r\nbegin\r\n Result.cbSize := SizeOf(Result);\r\n if not SystemParametersInfo(SPI_GETACCESSTIMEOUT, SizeOf(Result), @Result, 0) then\r\n begin\r\n Result.dwFlags := 0;\r\n Result.iTimeOutMSec := 0;\r\n end;\r\nend;\r\n\r\nfunction TJvAccessTimeOut.GetTimeOutMS: DWORD;\r\nbegin\r\n Result := NativeType.iTimeOutMSec;\r\nend;\r\n\r\nprocedure TJvAccessTimeOut.SetFlags(const Value: TJvAccessTimeOutFlags);\r\nvar\r\n Native: ACCESSTIMEOUT;\r\n Flags: DWORD;\r\nbegin\r\n Flags := 0;\r\n if atfOnOffFeedback in Value then\r\n Flags := Flags or ATF_ONOFFFEEDBACK;\r\n if atfTimeOutOn in Value then\r\n Flags := Flags or ATF_TIMEOUTON;\r\n Native := NativeType;\r\n if Native.dwFlags <> Flags then\r\n begin\r\n Native.dwFlags := Flags;\r\n NativeType := Native;\r\n end;\r\nend;\r\n\r\nprocedure TJvAccessTimeOut.SetNativeType(Value: ACCESSTIMEOUT);\r\nbegin\r\n if not IsDesigning and not ReadOnly then\r\n begin\r\n Value.cbSize := SizeOf(Value);\r\n SystemParametersInfo(SPI_SETACCESSTIMEOUT, SizeOf(Value), @Value, DEFAULT_SPIF_SENDCHANGE);\r\n end\r\n else\r\n RaiseReadOnly;\r\nend;\r\n\r\nprocedure TJvAccessTimeOut.SetTimeOutMS(const Value: DWORD);\r\nvar\r\n Native: ACCESSTIMEOUT;\r\nbegin\r\n Native := NativeType;\r\n if Native.iTimeOutMSec <> Value then\r\n begin\r\n Native.iTimeOutMSec := Value;\r\n NativeType := Native;\r\n end;\r\nend;\r\n\r\n//=== { TJvFilterKeys } ======================================================\r\n\r\nfunction TJvFilterKeys.GetBounceMSec: DWORD;\r\nbegin\r\n Result := NativeType.iBounceMSec\r\nend;\r\n\r\nfunction TJvFilterKeys.GetDelayMSec: DWORD;\r\nbegin\r\n Result := NativeType.iDelayMSec;\r\nend;\r\n\r\nfunction TJvFilterKeys.GetFlags: TJvFilterKeyFlags;\r\nvar\r\n Flags: DWORD;\r\nbegin\r\n Flags := NativeType.dwFlags;\r\n Result := [];\r\n if Flags and FKF_AVAILABLE = FKF_AVAILABLE then\r\n Include(Result, fkfAvailable);\r\n if Flags and FKF_CLICKON = FKF_CLICKON then\r\n Include(Result, fkfClickOn);\r\n if Flags and FKF_FILTERKEYSON = FKF_FILTERKEYSON then\r\n Include(Result, fkfFilterKeysOn);\r\n if Flags and FKF_HOTKEYACTIVE = FKF_HOTKEYACTIVE then\r\n Include(Result, fkfHotkeyActive);\r\n if Flags and FKF_HOTKEYSOUND = FKF_HOTKEYSOUND then\r\n Include(Result, fkfHotkeySound);\r\n if Flags and FKF_CONFIRMHOTKEY = FKF_CONFIRMHOTKEY then\r\n Include(Result, fkfConfirmHotkey);\r\n if Flags and FKF_INDICATOR = FKF_INDICATOR then\r\n Include(Result, fkfIndicator);\r\nend;\r\n\r\nfunction TJvFilterKeys.GetNativeType: FILTERKEYS;\r\nbegin\r\n Result.cbSize := SizeOf(Result);\r\n if not SystemParametersInfo(SPI_GETFILTERKEYS, SizeOf(Result), @Result, 0) then\r\n begin\r\n Result.dwFlags := 0;\r\n Result.iWaitMSec := 0;\r\n Result.iDelayMSec := 0;\r\n Result.iRepeatMSec := 0;\r\n Result.iBounceMSec := 0;\r\n end;\r\nend;\r\n\r\nfunction TJvFilterKeys.GetRepeatMSec: DWORD;\r\nbegin\r\n Result := NativeType.iRepeatMSec;\r\nend;\r\n\r\nfunction TJvFilterKeys.GetWaitMSec: DWORD;\r\nbegin\r\n Result := NativeType.iWaitMSec;\r\nend;\r\n\r\nprocedure TJvFilterKeys.SetBounceMSec(const Value: DWORD);\r\nvar\r\n Native: FILTERKEYS;\r\nbegin\r\n Native := NativeType;\r\n if NativeType.iBounceMSec <> Value then\r\n begin\r\n Native.iBounceMSec := Value;\r\n NativeType := Native;\r\n end;\r\nend;\r\n\r\nprocedure TJvFilterKeys.SetDelayMSec(const Value: DWORD);\r\nvar\r\n Native: FILTERKEYS;\r\nbegin\r\n Native := NativeType;\r\n if NativeType.iDelayMSec <> Value then\r\n begin\r\n Native.iDelayMSec := Value;\r\n NativeType := Native;\r\n end;\r\nend;\r\n\r\nprocedure TJvFilterKeys.SetFlags(const Value: TJvFilterKeyFlags);\r\nvar\r\n Native: FILTERKEYS;\r\n Flags: DWORD;\r\nbegin\r\n Flags := 0;\r\n if fkfAvailable in Value then\r\n Flags := Flags or FKF_AVAILABLE;\r\n if fkfClickOn in Value then\r\n Flags := Flags or FKF_CLICKON;\r\n if fkfFilterKeysOn in Value then\r\n Flags := Flags or FKF_FILTERKEYSON;\r\n if fkfHotkeyActive in Value then\r\n Flags := Flags or FKF_HOTKEYACTIVE;\r\n if fkfHotkeySound in Value then\r\n Flags := Flags or FKF_HOTKEYSOUND;\r\n if fkfConfirmHotkey in Value then\r\n Flags := Flags or FKF_CONFIRMHOTKEY;\r\n if fkfIndicator in Value then\r\n Flags := Flags or FKF_INDICATOR;\r\n Native := NativeType;\r\n if Native.dwFlags <> Flags then\r\n begin\r\n Native.dwFlags := Flags;\r\n NativeType := Native;\r\n end;\r\nend;\r\n\r\nprocedure TJvFilterKeys.SetNativeType(Value: FILTERKEYS);\r\nbegin\r\n if not IsDesigning and not ReadOnly then\r\n begin\r\n Value.cbSize := SizeOf(Value);\r\n SystemParametersInfo(SPI_SETFILTERKEYS, SizeOf(Value), @Value, DEFAULT_SPIF_SENDCHANGE);\r\n end\r\n else\r\n RaiseReadOnly;\r\nend;\r\n\r\nprocedure TJvFilterKeys.SetRepeatMSec(const Value: DWORD);\r\nvar\r\n Native: FILTERKEYS;\r\nbegin\r\n Native := NativeType;\r\n if NativeType.iRepeatMSec <> Value then\r\n begin\r\n Native.iRepeatMSec := Value;\r\n NativeType := Native;\r\n end;\r\nend;\r\n\r\nprocedure TJvFilterKeys.SetWaitMSec(const Value: DWORD);\r\nvar\r\n Native: FILTERKEYS;\r\nbegin\r\n Native := NativeType;\r\n if NativeType.iWaitMSec <> Value then\r\n begin\r\n Native.iWaitMSec := Value;\r\n NativeType := Native;\r\n end;\r\nend;\r\n\r\n//=== { TJvHighContrast } ====================================================\r\n\r\nfunction TJvHighContrast.GetDefaultScheme: string;\r\nbegin\r\n Result := NativeType.lpszDefaultScheme;\r\nend;\r\n\r\nfunction TJvHighContrast.GetFlags: TJvHighContrastFlags;\r\nvar\r\n Flags: DWORD;\r\nbegin\r\n Flags := NativeType.dwFlags;\r\n Result := [];\r\n if Flags and HCF_AVAILABLE = HCF_AVAILABLE then\r\n Include(Result, hcfAvailable);\r\n if Flags and HCF_CONFIRMHOTKEY = HCF_CONFIRMHOTKEY then\r\n Include(Result, hcfConfirmHotKey);\r\n if Flags and HCF_HIGHCONTRASTON = HCF_HIGHCONTRASTON then\r\n Include(Result, hcfHighContrastOn);\r\n if Flags and HCF_HOTKEYACTIVE = HCF_HOTKEYACTIVE then\r\n Include(Result, hcfHotkeyActive);\r\n if Flags and HCF_HOTKEYAVAILABLE = HCF_HOTKEYAVAILABLE then\r\n Include(Result, hcfHotkeyAvailable);\r\n if Flags and HCF_HOTKEYSOUND = HCF_HOTKEYSOUND then\r\n Include(Result, hcfHotkeySound);\r\n if Flags and HCF_INDICATOR = HCF_INDICATOR then\r\n Include(Result, hcfIndicator);\r\nend;\r\n\r\nfunction TJvHighContrast.GetNativeType: HIGHCONTRAST;\r\nbegin\r\n Result.cbSize := SizeOf(Result);\r\n if not SystemParametersInfo(SPI_GETHIGHCONTRAST, SizeOf(Result), @Result, 0) then\r\n begin\r\n Result.dwFlags := 0;\r\n Result.lpszDefaultScheme := '';\r\n end;\r\nend;\r\n\r\nprocedure TJvHighContrast.SetDefaultScheme(const Value: string);\r\nvar\r\n Native: HIGHCONTRAST;\r\nbegin\r\n Native := NativeType;\r\n if not AnsiSameText(Native.lpszDefaultScheme, Value) then\r\n begin\r\n Native.lpszDefaultScheme := PChar(Value);\r\n NativeType := Native;\r\n end;\r\nend;\r\n\r\nprocedure TJvHighContrast.SetFlags(const Value: TJvHighContrastFlags);\r\nvar\r\n Native: HIGHCONTRAST;\r\n Flags: DWORD;\r\nbegin\r\n Flags := 0;\r\n if hcfAvailable in Value then\r\n Flags := Flags or HCF_AVAILABLE;\r\n if hcfConfirmHotKey in Value then\r\n Flags := Flags or HCF_CONFIRMHOTKEY;\r\n if hcfHighContrastOn in Value then\r\n Flags := Flags or HCF_HIGHCONTRASTON;\r\n if hcfHotkeyActive in Value then\r\n Flags := Flags or HCF_HOTKEYACTIVE;\r\n if hcfHotkeyAvailable in Value then\r\n Flags := Flags or HCF_HOTKEYAVAILABLE;\r\n if hcfHotkeySound in Value then\r\n Flags := Flags or HCF_HOTKEYSOUND;\r\n if hcfIndicator in Value then\r\n Flags := Flags or HCF_INDICATOR;\r\n Native := NativeType;\r\n if Native.dwFlags <> Flags then\r\n begin\r\n Native.dwFlags := Flags;\r\n NativeType := Native;\r\n end;\r\nend;\r\n\r\nprocedure TJvHighContrast.SetNativeType(Value: HIGHCONTRAST);\r\nbegin\r\n if not IsDesigning and not ReadOnly then\r\n begin\r\n Value.cbSize := SizeOf(Value);\r\n SystemParametersInfo(SPI_SETHIGHCONTRAST, SizeOf(Value), @Value, DEFAULT_SPIF_SENDCHANGE);\r\n end\r\n else\r\n RaiseReadOnly;\r\nend;\r\n\r\n//=== { TJvIconMetrics } =====================================================\r\n\r\ndestructor TJvIconMetrics.Destroy;\r\nbegin\r\n FFont.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJvIconMetrics.GetFont: TFont;\r\nbegin\r\n if FFont = nil then\r\n FFont := TFont.Create;\r\n UpdateFromLogFont(FFont, NativeType.lfFont);\r\n Result := FFont;\r\nend;\r\n\r\nfunction TJvIconMetrics.GetHorzSpacing: Integer;\r\nbegin\r\n Result := NativeType.iHorzSpacing;\r\nend;\r\n\r\nfunction TJvIconMetrics.GetNativeType: ICONMETRICS;\r\nbegin\r\n Result.cbSize := SizeOf(Result);\r\n if not SystemParametersInfo(SPI_GETICONMETRICS, SizeOf(Result), @Result, 0) then\r\n begin\r\n Result.iHorzSpacing := 0;\r\n Result.iVertSpacing := 0;\r\n Result.iTitleWrap := 0;\r\n // Result.lfFont := ?:\r\n end;\r\nend;\r\n\r\nfunction TJvIconMetrics.GetTitleWrap: Boolean;\r\nbegin\r\n Result := NativeType.iTitleWrap <> 0;\r\nend;\r\n\r\nfunction TJvIconMetrics.GetVertSpacing: Integer;\r\nbegin\r\n Result := NativeType.iVertSpacing;\r\nend;\r\n\r\nprocedure TJvIconMetrics.SetFont(const Value: TFont);\r\nvar\r\n Native: ICONMETRICS;\r\nbegin\r\n Native := NativeType;\r\n UpdateToLogFont(Value, Native.lfFont);\r\n NativeType := Native;\r\nend;\r\n\r\nprocedure TJvIconMetrics.SetHorzSpacing(const Value: Integer);\r\nvar\r\n Native: ICONMETRICS;\r\nbegin\r\n Native := NativeType;\r\n if Native.iHorzSpacing <> Value then\r\n begin\r\n Native.iHorzSpacing := Value;\r\n NativeType := Native;\r\n end;\r\nend;\r\n\r\nprocedure TJvIconMetrics.SetNativeType(Value: ICONMETRICS);\r\nbegin\r\n if not IsDesigning and not ReadOnly then\r\n begin\r\n Value.cbSize := SizeOf(Value);\r\n SystemParametersInfo(SPI_SETICONMETRICS, SizeOf(Value), @Value, DEFAULT_SPIF_SENDCHANGE);\r\n end\r\n else\r\n RaiseReadOnly;\r\nend;\r\n\r\nprocedure TJvIconMetrics.SetTitleWrap(const Value: Boolean);\r\nvar\r\n Native: ICONMETRICS;\r\nbegin\r\n Native := NativeType;\r\n if Native.iTitleWrap <> Ord(Value) then\r\n begin\r\n Native.iTitleWrap := Ord(Value);\r\n NativeType := Native;\r\n end;\r\nend;\r\n\r\nprocedure TJvIconMetrics.SetVertSpacing(const Value: Integer);\r\nvar\r\n Native: ICONMETRICS;\r\nbegin\r\n Native := NativeType;\r\n if Native.iVertSpacing <> Value then\r\n begin\r\n Native.iVertSpacing := Value;\r\n NativeType := Native;\r\n end;\r\nend;\r\n\r\n//=== { TJvMinimizedMetrics } ================================================\r\n\r\nfunction TJvMinimizedMetrics.GetArrange: TJvWindowsArrange;\r\nbegin\r\n Result := ArrangeToWindowsArrange(NativeType.iArrange);\r\nend;\r\n\r\nfunction TJvMinimizedMetrics.GetHorzGap: Integer;\r\nbegin\r\n Result := NativeType.iHorzGap;\r\nend;\r\n\r\nfunction TJvMinimizedMetrics.GetNativeType: MINIMIZEDMETRICS;\r\nbegin\r\n Result.cbSize := SizeOf(Result);\r\n if not SystemParametersInfo(SPI_GETMINIMIZEDMETRICS, SizeOf(Result), @Result, 0) then\r\n begin\r\n Result.iWidth := 0;\r\n Result.iHorzGap := 0;\r\n Result.iVertGap := 0;\r\n Result.iArrange := 0;\r\n end;\r\nend;\r\n\r\nfunction TJvMinimizedMetrics.GetVertGap: Integer;\r\nbegin\r\n Result := NativeType.iVertGap;\r\nend;\r\n\r\nfunction TJvMinimizedMetrics.GetWidth: Integer;\r\nbegin\r\n Result := NativeType.iWidth;\r\nend;\r\n\r\nprocedure TJvMinimizedMetrics.SetArrange(const Value: TJvWindowsArrange);\r\nvar\r\n Native: MINIMIZEDMETRICS;\r\n WArrange: Integer;\r\nbegin\r\n Native := NativeType;\r\n WArrange := WindowsArrangeToArrange(Value);\r\n if Native.iArrange <> WArrange then\r\n begin\r\n Native.iArrange := WArrange;\r\n NativeType := Native;\r\n end;\r\nend;\r\n\r\nprocedure TJvMinimizedMetrics.SetHorzGap(const Value: Integer);\r\nvar\r\n Native: MINIMIZEDMETRICS;\r\nbegin\r\n Native := NativeType;\r\n if Native.iHorzGap <> Value then\r\n begin\r\n Native.iHorzGap := Value;\r\n NativeType := Native;\r\n end;\r\nend;\r\n\r\nprocedure TJvMinimizedMetrics.SetNativeType(Value: MINIMIZEDMETRICS);\r\nbegin\r\n if not IsDesigning and not ReadOnly then\r\n begin\r\n Value.cbSize := SizeOf(Value);\r\n SystemParametersInfo(SPI_SETMINIMIZEDMETRICS, SizeOf(Value), @Value, DEFAULT_SPIF_SENDCHANGE);\r\n end\r\n else\r\n RaiseReadOnly;\r\nend;\r\n\r\nprocedure TJvMinimizedMetrics.SetVertGap(const Value: Integer);\r\nvar\r\n Native: MINIMIZEDMETRICS;\r\nbegin\r\n Native := NativeType;\r\n if Native.iVertGap <> Value then\r\n begin\r\n Native.iVertGap := Value;\r\n NativeType := Native;\r\n end;\r\nend;\r\n\r\nprocedure TJvMinimizedMetrics.SetWidth(const Value: Integer);\r\nvar\r\n Native: MINIMIZEDMETRICS;\r\nbegin\r\n Native := NativeType;\r\n if Native.iWidth <> Value then\r\n begin\r\n Native.iWidth := Value;\r\n NativeType := Native;\r\n end;\r\nend;\r\n\r\n//=== { TJvMouseKeys } =======================================================\r\n\r\nfunction TJvMouseKeys.GetCtrlSpeed: DWORD;\r\nbegin\r\n Result := NativeType.iCtrlSpeed;\r\nend;\r\n\r\nfunction TJvMouseKeys.GetFlags: TJvMouseKeysFlags;\r\nvar\r\n Flags: DWORD;\r\nbegin\r\n Flags := NativeType.dwFlags;\r\n Result := [];\r\n if Flags and MKF_AVAILABLE = MKF_AVAILABLE then\r\n Include(Result, mkfAvailable);\r\n if Flags and MKF_CONFIRMHOTKEY = MKF_CONFIRMHOTKEY then\r\n Include(Result, mkfConfirmHotKey);\r\n if Flags and MKF_HOTKEYACTIVE = MKF_HOTKEYACTIVE then\r\n Include(Result, mkfHotkeyActive);\r\n if Flags and MKF_HOTKEYSOUND = MKF_HOTKEYSOUND then\r\n Include(Result, mkfHotkeySound);\r\n if Flags and MKF_INDICATOR = MKF_INDICATOR then\r\n Include(Result, mkfIndicator);\r\n if Flags and MKF_MOUSEKEYSON = MKF_MOUSEKEYSON then\r\n Include(Result, mkfMouseKeysOn);\r\n if Flags and MKF_MODIFIERS = MKF_MODIFIERS then\r\n Include(Result, mkfModifiers);\r\n if Flags and MKF_REPLACENUMBERS = MKF_REPLACENUMBERS then\r\n Include(Result, mkfReplaceNumbers);\r\nend;\r\n\r\nfunction TJvMouseKeys.GetMaxSpeed: DWORD;\r\nbegin\r\n Result := NativeType.iMaxSpeed;\r\nend;\r\n\r\nfunction TJvMouseKeys.GetNativeType: MOUSEKEYS;\r\nbegin\r\n Result.cbSize := SizeOf(Result);\r\n if not SystemParametersInfo(SPI_GETMOUSEKEYS, SizeOf(Result), @Result, 0) then\r\n begin\r\n Result.dwFlags := 0;\r\n Result.iMaxSpeed := 0;\r\n Result.iTimeToMaxSpeed := 0;\r\n Result.iCtrlSpeed := 0;\r\n Result.dwReserved1 := 0;\r\n Result.dwReserved2 := 0;\r\n end;\r\nend;\r\n\r\nfunction TJvMouseKeys.GetTimeToMaxSpeed: DWORD;\r\nbegin\r\n Result := NativeType.iTimeToMaxSpeed;\r\nend;\r\n\r\nprocedure TJvMouseKeys.SetCtrlSpeed(const Value: DWORD);\r\nvar\r\n Native: MOUSEKEYS;\r\nbegin\r\n Native := NativeType;\r\n if Native.iCtrlSpeed <> Value then\r\n begin\r\n Native.iCtrlSpeed := Value;\r\n NativeType := Native;\r\n end;\r\nend;\r\n\r\nprocedure TJvMouseKeys.SetFlags(const Value: TJvMouseKeysFlags);\r\nvar\r\n Native: MOUSEKEYS;\r\n Flags: DWORD;\r\nbegin\r\n Flags := 0;\r\n if mkfAvailable in Value then\r\n Flags := Flags or MKF_AVAILABLE;\r\n if mkfConfirmHotKey in Value then\r\n Flags := Flags or MKF_CONFIRMHOTKEY;\r\n if mkfHotkeyActive in Value then\r\n Flags := Flags or MKF_HOTKEYACTIVE;\r\n if mkfHotkeySound in Value then\r\n Flags := Flags or MKF_HOTKEYSOUND;\r\n if mkfIndicator in Value then\r\n Flags := Flags or MKF_INDICATOR;\r\n if mkfMouseKeysOn in Value then\r\n Flags := Flags or MKF_MOUSEKEYSON;\r\n if mkfModifiers in Value then\r\n Flags := Flags or MKF_MODIFIERS;\r\n if mkfReplaceNumbers in Value then\r\n Flags := Flags or MKF_REPLACENUMBERS;\r\n Native := NativeType;\r\n if Native.dwFlags <> Flags then\r\n begin\r\n Native.dwFlags := Flags;\r\n NativeType := Native;\r\n end;\r\nend;\r\n\r\nprocedure TJvMouseKeys.SetMaxSpeed(const Value: DWORD);\r\nvar\r\n Native: MOUSEKEYS;\r\nbegin\r\n Native := NativeType;\r\n if Native.iMaxSpeed <> Value then\r\n begin\r\n Native.iMaxSpeed := Value;\r\n NativeType := Native;\r\n end;\r\nend;\r\n\r\nprocedure TJvMouseKeys.SetNativeType(Value: MOUSEKEYS);\r\nbegin\r\n if not IsDesigning and not ReadOnly then\r\n begin\r\n Value.cbSize := SizeOf(Value);\r\n SystemParametersInfo(SPI_SETMOUSEKEYS, SizeOf(Value), @Value, DEFAULT_SPIF_SENDCHANGE);\r\n end\r\n else\r\n RaiseReadOnly;\r\nend;\r\n\r\nprocedure TJvMouseKeys.SetTimeToMaxSpeed(const Value: DWORD);\r\nvar\r\n Native: MOUSEKEYS;\r\nbegin\r\n Native := NativeType;\r\n if Native.iTimeToMaxSpeed <> Value then\r\n begin\r\n Native.iTimeToMaxSpeed := Value;\r\n NativeType := Native;\r\n end;\r\nend;\r\n\r\n//=== { TJvNonClientMetrics } ================================================\r\n\r\ndestructor TJvNonClientMetrics.Destroy;\r\nbegin\r\n FCaptionFont.Free;\r\n FMenuFont.Free;\r\n FMessageFont.Free;\r\n FSmallCaptionFont.Free;\r\n FStatusFont.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJvNonClientMetrics.GetBorderWidth: Integer;\r\nbegin\r\n Result := NativeType.iBorderWidth;\r\nend;\r\n\r\nfunction TJvNonClientMetrics.GetCaptionFont: TFont;\r\nbegin\r\n if FCaptionFont = nil then\r\n FCaptionFont := TFont.Create;\r\n UpdateFromLogFont(FCaptionFont, NativeType.lfCaptionFont);\r\n Result := FCaptionFont;\r\nend;\r\n\r\nfunction TJvNonClientMetrics.GetCaptionHeight: Integer;\r\nbegin\r\n Result := NativeType.iCaptionHeight;\r\nend;\r\n\r\nfunction TJvNonClientMetrics.GetCaptionWidth: Integer;\r\nbegin\r\n Result := NativeType.iCaptionWidth;\r\nend;\r\n\r\nfunction TJvNonClientMetrics.GetMenuFont: TFont;\r\nbegin\r\n if FMenuFont = nil then\r\n FMenuFont := TFont.Create;\r\n UpdateFromLogFont(FMenuFont, NativeType.lfMenuFont);\r\n Result := FMenuFont;\r\nend;\r\n\r\nfunction TJvNonClientMetrics.GetMenuHeight: Integer;\r\nbegin\r\n Result := NativeType.iMenuHeight;\r\nend;\r\n\r\nfunction TJvNonClientMetrics.GetMenuWidth: Integer;\r\nbegin\r\n Result := NativeType.iMenuWidth;\r\nend;\r\n\r\nfunction TJvNonClientMetrics.GetMessageFont: TFont;\r\nbegin\r\n if FMessageFont = nil then\r\n FMessageFont := TFont.Create;\r\n UpdateFromLogFont(FMessageFont, NativeType.lfMessageFont);\r\n Result := FMessageFont;\r\nend;\r\n\r\nfunction TJvNonClientMetrics.GetNativeType: NONCLIENTMETRICS;\r\nbegin\r\n {$IFDEF RTL210_UP}\r\n Result.cbSize := TNonClientMetrics.SizeOf;\r\n {$ELSE}\r\n Result.cbSize := SizeOf(Result);\r\n {$ENDIF RTL210_UP}\r\n if not SystemParametersInfo(SPI_GETNONCLIENTMETRICS, Result.cbSize, @Result, 0) then\r\n begin\r\n Result.iBorderWidth := 0;\r\n Result.iScrollWidth := 0;\r\n Result.iScrollHeight := 0;\r\n Result.iCaptionWidth := 0;\r\n Result.iCaptionHeight := 0;\r\n // Result.lfCaptionFont := ?:\r\n Result.iSmCaptionWidth := 0;\r\n Result.iSmCaptionHeight := 0;\r\n // Result.lfSmCaptionFont := ?:\r\n Result.iMenuWidth := 0;\r\n Result.iMenuHeight := 0;\r\n // Result.lfMenuFont := ?:\r\n // Result.lfStatusFont := ?;\r\n // Result.lfMessageFont := ?;\r\n end;\r\nend;\r\n\r\nfunction TJvNonClientMetrics.GetScrollHeight: Integer;\r\nbegin\r\n Result := NativeType.iScrollHeight;\r\nend;\r\n\r\nfunction TJvNonClientMetrics.GetScrollWidth: Integer;\r\nbegin\r\n Result := NativeType.iScrollWidth;\r\nend;\r\n\r\nfunction TJvNonClientMetrics.GetSmallCaptionFont: TFont;\r\nbegin\r\n if FSmallCaptionFont = nil then\r\n FSmallCaptionFont := TFont.Create;\r\n UpdateFromLogFont(FSmallCaptionFont, NativeType.lfSmCaptionFont);\r\n Result := FSmallCaptionFont;\r\nend;\r\n\r\nfunction TJvNonClientMetrics.GetSmallCaptionHeight: Integer;\r\nbegin\r\n Result := NativeType.iSmCaptionHeight;\r\nend;\r\n\r\nfunction TJvNonClientMetrics.GetSmallCaptionWidth: Integer;\r\nbegin\r\n Result := NativeType.iSmCaptionWidth;\r\nend;\r\n\r\nfunction TJvNonClientMetrics.GetStatusFont: TFont;\r\nbegin\r\n if FStatusFont = nil then\r\n FStatusFont := TFont.Create;\r\n UpdateFromLogFont(FStatusFont, NativeType.lfStatusFont);\r\n Result := FStatusFont;\r\nend;\r\n\r\nprocedure TJvNonClientMetrics.SetBorderWidth(const Value: Integer);\r\nvar\r\n Native: NONCLIENTMETRICS;\r\nbegin\r\n Native := NativeType;\r\n if Native.iBorderWidth <> Value then\r\n begin\r\n Native.iBorderWidth := Value;\r\n NativeType := Native;\r\n end;\r\nend;\r\n\r\nprocedure TJvNonClientMetrics.SetCaptionFont(const Value: TFont);\r\nvar\r\n Native: NONCLIENTMETRICS;\r\nbegin\r\n Native := NativeType;\r\n UpdateToLogFont(Value, Native.lfCaptionFont);\r\n NativeType := Native;\r\nend;\r\n\r\nprocedure TJvNonClientMetrics.SetCaptionHeight(const Value: Integer);\r\nvar\r\n Native: NONCLIENTMETRICS;\r\nbegin\r\n Native := NativeType;\r\n if Native.iCaptionHeight <> Value then\r\n begin\r\n Native.iCaptionHeight := Value;\r\n NativeType := Native;\r\n end;\r\nend;\r\n\r\nprocedure TJvNonClientMetrics.SetCaptionWidth(const Value: Integer);\r\nvar\r\n Native: NONCLIENTMETRICS;\r\nbegin\r\n Native := NativeType;\r\n if Native.iCaptionWidth <> Value then\r\n begin\r\n Native.iCaptionWidth := Value;\r\n NativeType := Native;\r\n end;\r\nend;\r\n\r\nprocedure TJvNonClientMetrics.SetMenuFont(const Value: TFont);\r\nvar\r\n Native: NONCLIENTMETRICS;\r\nbegin\r\n Native := NativeType;\r\n UpdateToLogFont(Value, Native.lfMenuFont);\r\n NativeType := Native;\r\nend;\r\n\r\nprocedure TJvNonClientMetrics.SetMenuHeight(const Value: Integer);\r\nvar\r\n Native: NONCLIENTMETRICS;\r\nbegin\r\n Native := NativeType;\r\n if Native.iMenuHeight <> Value then\r\n begin\r\n Native.iMenuHeight := Value;\r\n NativeType := Native;\r\n end;\r\nend;\r\n\r\nprocedure TJvNonClientMetrics.SetMenuWidth(const Value: Integer);\r\nvar\r\n Native: NONCLIENTMETRICS;\r\nbegin\r\n Native := NativeType;\r\n if Native.iMenuWidth <> Value then\r\n begin\r\n Native.iMenuWidth := Value;\r\n NativeType := Native;\r\n end;\r\nend;\r\n\r\nprocedure TJvNonClientMetrics.SetMessageFont(const Value: TFont);\r\nvar\r\n Native: NONCLIENTMETRICS;\r\nbegin\r\n Native := NativeType;\r\n UpdateToLogFont(Value, Native.lfMessageFont);\r\n NativeType := Native;\r\nend;\r\n\r\nprocedure TJvNonClientMetrics.SetNativeType(Value: NONCLIENTMETRICS);\r\nbegin\r\n if not IsDesigning and not ReadOnly then\r\n begin\r\n {$IFDEF RTL210_UP}\r\n Value.cbSize := NONCLIENTMETRICS.SizeOf;\r\n {$ELSE}\r\n Value.cbSize := SizeOf(Value);\r\n {$ENDIF RTL210_UP}\r\n SystemParametersInfo(SPI_SETNONCLIENTMETRICS, Value.cbSize, @Value, DEFAULT_SPIF_SENDCHANGE);\r\n end\r\n else\r\n RaiseReadOnly;\r\nend;\r\n\r\nprocedure TJvNonClientMetrics.SetScrollHeight(const Value: Integer);\r\nvar\r\n Native: NONCLIENTMETRICS;\r\nbegin\r\n Native := NativeType;\r\n if Native.iScrollHeight <> Value then\r\n begin\r\n Native.iScrollHeight := Value;\r\n NativeType := Native;\r\n end;\r\nend;\r\n\r\nprocedure TJvNonClientMetrics.SetScrollWidth(const Value: Integer);\r\nvar\r\n Native: NONCLIENTMETRICS;\r\nbegin\r\n Native := NativeType;\r\n if Native.iScrollWidth <> Value then\r\n begin\r\n Native.iScrollWidth := Value;\r\n NativeType := Native;\r\n end;\r\nend;\r\n\r\nprocedure TJvNonClientMetrics.SetSmallCaptionFont(const Value: TFont);\r\nvar\r\n Native: NONCLIENTMETRICS;\r\nbegin\r\n Native := NativeType;\r\n UpdateToLogFont(Value, Native.lfSmCaptionFont);\r\n NativeType := Native;\r\nend;\r\n\r\nprocedure TJvNonClientMetrics.SetSmallCaptionHeight(const Value: Integer);\r\nvar\r\n Native: NONCLIENTMETRICS;\r\nbegin\r\n Native := NativeType;\r\n if Native.iSmCaptionHeight <> Value then\r\n begin\r\n Native.iSmCaptionHeight := Value;\r\n NativeType := Native;\r\n end;\r\nend;\r\n\r\nprocedure TJvNonClientMetrics.SetSmallCaptionWidth(const Value: Integer);\r\nvar\r\n Native: NONCLIENTMETRICS;\r\nbegin\r\n Native := NativeType;\r\n if Native.iSmCaptionWidth <> Value then\r\n begin\r\n Native.iSmCaptionWidth := Value;\r\n NativeType := Native;\r\n end;\r\nend;\r\n\r\nprocedure TJvNonClientMetrics.SetStatusFont(const Value: TFont);\r\nvar\r\n Native: NONCLIENTMETRICS;\r\nbegin\r\n Native := NativeType;\r\n UpdateToLogFont(Value, Native.lfStatusFont);\r\n NativeType := Native;\r\nend;\r\n\r\n//== TJvSerialKeys ===========================================================\r\n\r\nfunction TJvSerialKeys.GetActive: Boolean;\r\nbegin\r\n Result := NativeType.iActive <> 0;\r\nend;\r\n\r\nfunction TJvSerialKeys.GetActivePort: string;\r\nbegin\r\n Result := NativeType.lpszActivePort;\r\nend;\r\n\r\nfunction TJvSerialKeys.GetBaudRate: DWORD;\r\nbegin\r\n Result := NativeType.iBaudRate;\r\nend;\r\n\r\nfunction TJvSerialKeys.GetFlags: TJvSerialKeysFlags;\r\nvar\r\n Flags: DWORD;\r\nbegin\r\n Flags := NativeType.dwFlags;\r\n Result := [];\r\n if Flags and SERKF_AVAILABLE = SERKF_AVAILABLE then\r\n Include(Result, serkfAvailable);\r\n if Flags and SERKF_INDICATOR = SERKF_INDICATOR then\r\n Include(Result, serkfIndicator);\r\n if Flags and SERKF_SERIALKEYSON = SERKF_SERIALKEYSON then\r\n Include(Result, serkfSerialKeysOn);\r\nend;\r\n\r\nfunction TJvSerialKeys.GetNativeType: SERIALKEYS;\r\nbegin\r\n Result.cbSize := SizeOf(Result);\r\n if not SystemParametersInfo(SPI_GETSERIALKEYS, SizeOf(Result), @Result, 0) then\r\n begin\r\n Result.lpszActivePort := '';\r\n Result.lpszPort := '';\r\n Result.dwFlags := 0;\r\n Result.iBaudRate := 0;\r\n Result.iPortState := 0;\r\n Result.iActive := 0;\r\n end;\r\nend;\r\n\r\nfunction TJvSerialKeys.GetPort: string;\r\nbegin\r\n Result := NativeType.lpszPort;\r\nend;\r\n\r\nfunction TJvSerialKeys.GetPortState: TJvSerialKeysPortState;\r\nbegin\r\n Result := TJvSerialKeysPortState(NativeType.iPortState);\r\nend;\r\n\r\nprocedure TJvSerialKeys.SetActive(const Value: Boolean);\r\nvar\r\n Native: SERIALKEYS;\r\nbegin\r\n Native := NativeType;\r\n if Integer(Native.iActive) <> Ord(Value) then\r\n begin\r\n Native.iActive := Ord(Value);\r\n NativeType := Native;\r\n end;\r\nend;\r\n\r\nprocedure TJvSerialKeys.SetActivePort(const Value: string);\r\nvar\r\n Native: SERIALKEYS;\r\nbegin\r\n Native := NativeType;\r\n if not AnsiSameText(Native.lpszActivePort, Value) then\r\n begin\r\n Native.lpszActivePort := PChar(Value);\r\n NativeType := Native;\r\n end;\r\nend;\r\n\r\nprocedure TJvSerialKeys.SetBaudRate(const Value: DWORD);\r\nvar\r\n Native: SERIALKEYS;\r\nbegin\r\n Native := NativeType;\r\n if Native.iBaudRate <> Value then\r\n begin\r\n Native.iBaudRate := Value;\r\n NativeType := Native;\r\n end;\r\nend;\r\n\r\nprocedure TJvSerialKeys.SetFlags(const Value: TJvSerialKeysFlags);\r\nvar\r\n Native: SERIALKEYS;\r\n Flags: DWORD;\r\nbegin\r\n Flags := 0;\r\n if serkfAvailable in Value then\r\n Flags := Flags or SERKF_AVAILABLE;\r\n if serkfIndicator in Value then\r\n Flags := Flags or SERKF_INDICATOR;\r\n if serkfSerialKeysOn in Value then\r\n Flags := Flags or SERKF_SERIALKEYSON;\r\n Native := NativeType;\r\n if Native.dwFlags <> Flags then\r\n begin\r\n Native.dwFlags := Flags;\r\n NativeType := Native;\r\n end;\r\nend;\r\n\r\nprocedure TJvSerialKeys.SetNativeType(Value: SERIALKEYS);\r\nbegin\r\n if not IsDesigning and not ReadOnly then\r\n begin\r\n Value.cbSize := SizeOf(Value);\r\n SystemParametersInfo(SPI_SETSERIALKEYS, SizeOf(Value), @Value, DEFAULT_SPIF_SENDCHANGE);\r\n end\r\n else\r\n RaiseReadOnly;\r\nend;\r\n\r\nprocedure TJvSerialKeys.SetPort(const Value: string);\r\nvar\r\n Native: SERIALKEYS;\r\nbegin\r\n Native := NativeType;\r\n if not AnsiSameText(Native.lpszPort, Value) then\r\n begin\r\n Native.lpszPort := PChar(Value);\r\n NativeType := Native;\r\n end;\r\nend;\r\n\r\nprocedure TJvSerialKeys.SetPortState(const Value: TJvSerialKeysPortState);\r\nvar\r\n Native: SERIALKEYS;\r\nbegin\r\n Native := NativeType;\r\n if Integer(Native.iPortState) <> Ord(Value) then\r\n begin\r\n Native.iPortState := Ord(Value);\r\n NativeType := Native;\r\n end;\r\nend;\r\n\r\n//=== { TJvSoundSentry } =====================================================\r\n\r\nfunction TJvSoundSentry.GetFlags: TJvSoundSentryFlags;\r\nvar\r\n Flags: DWORD;\r\nbegin\r\n Flags := NativeType.dwFlags;\r\n Result := [];\r\n if Flags and SSF_AVAILABLE = SSF_AVAILABLE then\r\n Include(Result, ssfAvailable);\r\n if Flags and SSF_SOUNDSENTRYON = SSF_SOUNDSENTRYON then\r\n Include(Result, ssfSoundSentryOn);\r\n if Flags and SSF_INDICATOR = SSF_INDICATOR then\r\n Include(Result, ssfIndicator);\r\nend;\r\n\r\nfunction TJvSoundSentry.GetGrafEffect: TJvSoundSentryGrafEffect;\r\nbegin\r\n if NativeType.iFSGrafEffect = 3 then\r\n Result := ssgfDisplay\r\n else\r\n Result := ssgfNone;\r\nend;\r\n\r\nfunction TJvSoundSentry.GetGrafEffectColor: TColor;\r\nbegin\r\n Result := TColor(NativeType.iFSGrafEffectColor);\r\nend;\r\n\r\nfunction TJvSoundSentry.GetGrafEffectMSec: DWORD;\r\nbegin\r\n Result := NativeType.iFSGrafEffectMSec;\r\nend;\r\n\r\nfunction TJvSoundSentry.GetNativeType: SOUNDSENTRY;\r\nbegin\r\n Result.cbSize := SizeOf(Result);\r\n if not SystemParametersInfo(SPI_GETSOUNDSENTRY, SizeOf(Result), @Result, 0) then\r\n begin\r\n Result.dwFlags := 0;\r\n Result.iFSTextEffect := 0;\r\n Result.iFSTextEffectMSec := 0;\r\n Result.iFSTextEffectColorBits := 0;\r\n Result.iFSGrafEffect := 0;\r\n Result.iFSGrafEffectMSec := 0;\r\n Result.iFSGrafEffectColor := 0;\r\n Result.iWindowsEffect := 0;\r\n Result.iWindowsEffectMSec := 0;\r\n Result.lpszWindowsEffectDLL := '';\r\n Result.iWindowsEffectOrdinal := 0;\r\n end;\r\nend;\r\n\r\nfunction TJvSoundSentry.GetTextEffect: TJvSoundSentryTextEffect;\r\nbegin\r\n Result := TJvSoundSentryTextEffect(NativeType.iFSTextEffect);\r\nend;\r\n\r\nfunction TJvSoundSentry.GetTextEffectColor: TColor;\r\nbegin\r\n Result := TColor(NativeType.iFSTextEffectColorBits);\r\nend;\r\n\r\nfunction TJvSoundSentry.GetTextEffectMSec: DWORD;\r\nbegin\r\n Result := NativeType.iFSTextEffectMSec;\r\nend;\r\n\r\nfunction TJvSoundSentry.GetWindowsEffect: TJvSoundSentryWindowsEffect;\r\nbegin\r\n Result := TJvSoundSentryWindowsEffect(NativeType.iWindowsEffect);\r\nend;\r\n\r\nfunction TJvSoundSentry.GetWindowsEffectDLL: string;\r\nbegin\r\n Result := NativeType.lpszWindowsEffectDLL;\r\nend;\r\n\r\nfunction TJvSoundSentry.GetWindowsEffectMSec: DWORD;\r\nbegin\r\n Result := NativeType.iWindowsEffectMSec;\r\nend;\r\n\r\nprocedure TJvSoundSentry.SetFlags(const Value: TJvSoundSentryFlags);\r\nvar\r\n Flags: DWORD;\r\n Native: SOUNDSENTRY;\r\nbegin\r\n Flags := 0;\r\n if ssfAvailable in Value then\r\n Flags := Flags or SSF_AVAILABLE;\r\n if ssfSoundSentryOn in Value then\r\n Flags := Flags or SSF_SOUNDSENTRYON;\r\n if ssfIndicator in Value then\r\n Flags := Flags or SSF_INDICATOR;\r\n Native := NativeType;\r\n if Native.dwFlags <> Flags then\r\n begin\r\n Native.dwFlags := Flags;\r\n NativeType := Native;\r\n end;\r\nend;\r\n\r\nprocedure TJvSoundSentry.SetGrafEffect(const Value: TJvSoundSentryGrafEffect);\r\nvar\r\n Native: SOUNDSENTRY;\r\nbegin\r\n Native := NativeType;\r\n if Native.iFSGrafEffect <> DWORD(Value) then\r\n begin\r\n Native.iFSGrafEffect := DWORD(Value);\r\n NativeType := Native;\r\n end;\r\nend;\r\n\r\nprocedure TJvSoundSentry.SetGrafEffectColor(const Value: TColor);\r\nvar\r\n Native: SOUNDSENTRY;\r\nbegin\r\n Native := NativeType;\r\n if Native.iFSGrafEffectColor <> DWORD(Value) then\r\n begin\r\n Native.iFSGrafEffectColor := DWORD(Value);\r\n NativeType := Native;\r\n end;\r\nend;\r\n\r\nprocedure TJvSoundSentry.SetGrafEffectMSec(const Value: DWORD);\r\nvar\r\n Native: SOUNDSENTRY;\r\nbegin\r\n Native := NativeType;\r\n if Native.iFSGrafEffectMSec <> Value then\r\n begin\r\n Native.iFSGrafEffectMSec := Value;\r\n NativeType := Native;\r\n end;\r\nend;\r\n\r\nprocedure TJvSoundSentry.SetNativeType(Value: SOUNDSENTRY);\r\nbegin\r\n if not IsDesigning and not ReadOnly then\r\n begin\r\n Value.cbSize := SizeOf(Value);\r\n SystemParametersInfo(SPI_SETSOUNDSENTRY, SizeOf(Value), @Value, 0);\r\n end\r\n else\r\n RaiseReadOnly;\r\nend;\r\n\r\nprocedure TJvSoundSentry.SetTextEffect(const Value: TJvSoundSentryTextEffect);\r\nvar\r\n Native: SOUNDSENTRY;\r\nbegin\r\n Native := NativeType;\r\n if Native.iFSTextEffect <> DWORD(Value) then\r\n begin\r\n Native.iFSTextEffect := DWORD(Value);\r\n NativeType := Native;\r\n end;\r\nend;\r\n\r\nprocedure TJvSoundSentry.SetTextEffectColor(const Value: TColor);\r\nvar\r\n Native: SOUNDSENTRY;\r\nbegin\r\n Native := NativeType;\r\n if Native.iFSTextEffectColorBits <> DWORD(Value) then\r\n begin\r\n Native.iFSTextEffectColorBits := DWORD(Value);\r\n NativeType := Native;\r\n end;\r\nend;\r\n\r\nprocedure TJvSoundSentry.SetTextEffectMSec(const Value: DWORD);\r\nvar\r\n Native: SOUNDSENTRY;\r\nbegin\r\n Native := NativeType;\r\n if Native.iFSTextEffectMSec <> Value then\r\n begin\r\n Native.iFSTextEffectMSec := Value;\r\n NativeType := Native;\r\n end;\r\nend;\r\n\r\nprocedure TJvSoundSentry.SetWindowsEffect(const Value: TJvSoundSentryWindowsEffect);\r\nvar\r\n Native: SOUNDSENTRY;\r\nbegin\r\n Native := NativeType;\r\n if Native.iWindowsEffect <> DWORD(Value) then\r\n begin\r\n Native.iWindowsEffect := Ord(Value);\r\n NativeType := Native;\r\n end;\r\nend;\r\n\r\nprocedure TJvSoundSentry.SetWindowsEffectDLL(const Value: string);\r\nvar\r\n Native: SOUNDSENTRY;\r\nbegin\r\n Native := NativeType;\r\n if not AnsiSameText(Native.lpszWindowsEffectDLL, Value) then\r\n begin\r\n Native.lpszWindowsEffectDLL := PChar(Value);\r\n NativeType := Native;\r\n end;\r\nend;\r\n\r\nprocedure TJvSoundSentry.SetWindowsEffectMSec(const Value: DWORD);\r\nvar\r\n Native: SOUNDSENTRY;\r\nbegin\r\n Native := NativeType;\r\n if Native.iWindowsEffectMSec <> Value then\r\n begin\r\n Native.iWindowsEffectMSec := Value;\r\n NativeType := Native;\r\n end;\r\nend;\r\n\r\n//=== { TJvSystemParametersInfo } ============================================\r\n\r\nconstructor TJvSystemParametersInfo.Create;\r\nbegin\r\n inherited Create;\r\n FWorkArea := TJvRect.Create;\r\nend;\r\n\r\ndestructor TJvSystemParametersInfo.Destroy;\r\nbegin\r\n FAccessTimeOut.Free;\r\n FFilterKeys.Free;\r\n FHighContrast.Free;\r\n FIconMetrics.Free;\r\n FIconTitleFont.Free;\r\n FMinimizedMetrics.Free;\r\n FMouseKeys.Free;\r\n FNonClientMetrics.Free;\r\n FSerialKeys.Free;\r\n FSoundSentry.Free;\r\n FWorkArea.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvSystemParametersInfo.InitMap;\r\nbegin\r\n { TODO: make this a hash table for faster access? }\r\n if Length(FMap) > 0 then\r\n Exit;\r\n SetLength(FMap, 96);\r\n FMap[0] := Point(SPI_GETBEEP, SPI_SETBEEP);\r\n FMap[1] := Point(SPI_GETMOUSE, SPI_SETMOUSE);\r\n FMap[2] := Point(SPI_GETBORDER, SPI_SETBORDER);\r\n FMap[3] := Point(SPI_GETKEYBOARDSPEED, SPI_SETKEYBOARDSPEED);\r\n FMap[4] := Point(-1, SPI_LANGDRIVER);\r\n FMap[5] := Point(SPI_ICONHORIZONTALSPACING, SPI_ICONHORIZONTALSPACING);\r\n FMap[6] := Point(SPI_GETSCREENSAVETIMEOUT, SPI_SETSCREENSAVETIMEOUT);\r\n FMap[7] := Point(SPI_GETSCREENSAVEACTIVE, SPI_SETSCREENSAVEACTIVE);\r\n FMap[8] := Point(SPI_GETGRIDGRANULARITY, SPI_SETGRIDGRANULARITY);\r\n FMap[9] := Point(-1, SPI_SETDESKPATTERN);\r\n FMap[10] := Point(SPI_GETKEYBOARDDELAY, SPI_SETKEYBOARDDELAY);\r\n FMap[11] := Point(SPI_ICONVERTICALSPACING, SPI_ICONVERTICALSPACING);\r\n FMap[12] := Point(SPI_GETICONTITLEWRAP, SPI_SETICONTITLEWRAP);\r\n FMap[13] := Point(SPI_GETMENUDROPALIGNMENT, SPI_SETMENUDROPALIGNMENT);\r\n FMap[14] := Point(-1, SPI_SETDOUBLECLKWIDTH);\r\n FMap[15] := Point(-1, SPI_SETDOUBLECLKHEIGHT);\r\n FMap[16] := Point(SPI_GETICONTITLELOGFONT, SPI_SETICONTITLELOGFONT);\r\n FMap[17] := Point(-1, SPI_SETDOUBLECLICKTIME);\r\n FMap[18] := Point(-1, SPI_SETMOUSEBUTTONSWAP);\r\n FMap[19] := Point(-1, SPI_SETDRAGWIDTH);\r\n FMap[20] := Point(-1, SPI_SETDRAGHEIGHT);\r\n FMap[21] := Point(-1, SPI_SETHANDHELD);\r\n FMap[22] := Point(SPI_GETFASTTASKSWITCH, SPI_SETFASTTASKSWITCH);\r\n FMap[23] := Point(SPI_GETDRAGFULLWINDOWS, SPI_SETDRAGFULLWINDOWS);\r\n FMap[24] := Point(SPI_GETNONCLIENTMETRICS, SPI_SETNONCLIENTMETRICS);\r\n FMap[25] := Point(SPI_GETMINIMIZEDMETRICS, SPI_SETMINIMIZEDMETRICS);\r\n FMap[26] := Point(SPI_GETICONMETRICS, SPI_SETICONMETRICS);\r\n FMap[27] := Point(SPI_GETWORKAREA, SPI_SETWORKAREA);\r\n FMap[28] := Point(-1, SPI_SETPENWINDOWS);\r\n FMap[29] := Point(SPI_GETHIGHCONTRAST, SPI_SETHIGHCONTRAST);\r\n FMap[30] := Point(SPI_GETKEYBOARDPREF, SPI_SETKEYBOARDPREF);\r\n FMap[31] := Point(SPI_GETSCREENREADER, SPI_SETSCREENREADER);\r\n FMap[32] := Point(SPI_GETANIMATION, SPI_SETANIMATION);\r\n FMap[33] := Point(SPI_GETFONTSMOOTHING, SPI_SETFONTSMOOTHING);\r\n FMap[34] := Point(SPI_GETLOWPOWERTIMEOUT, SPI_SETPOWEROFFTIMEOUT);\r\n FMap[35] := Point(SPI_GETPOWEROFFTIMEOUT, SPI_SETLOWPOWERTIMEOUT);\r\n FMap[36] := Point(SPI_GETLOWPOWERACTIVE, SPI_SETLOWPOWERACTIVE);\r\n FMap[37] := Point(SPI_GETPOWEROFFACTIVE, SPI_SETPOWEROFFACTIVE);\r\n FMap[38] := Point(-1, SPI_SETCURSORS);\r\n FMap[39] := Point(-1, SPI_SETICONS);\r\n FMap[40] := Point(SPI_GETDEFAULTINPUTLANG, SPI_SETDEFAULTINPUTLANG);\r\n FMap[41] := Point(-1, SPI_SETLANGTOGGLE);\r\n FMap[42] := Point(SPI_GETWINDOWSEXTENSION, -1);\r\n FMap[43] := Point(SPI_GETMOUSETRAILS, SPI_SETMOUSETRAILS);\r\n FMap[44] := Point(SPI_SCREENSAVERRUNNING, -1);\r\n FMap[45] := Point(SPI_GETFILTERKEYS, SPI_SETFILTERKEYS);\r\n FMap[46] := Point(SPI_GETTOGGLEKEYS, SPI_SETTOGGLEKEYS);\r\n FMap[47] := Point(SPI_GETMOUSEKEYS, SPI_SETMOUSEKEYS);\r\n FMap[48] := Point(SPI_GETSHOWSOUNDS, SPI_SETSHOWSOUNDS);\r\n FMap[49] := Point(SPI_GETSTICKYKEYS, SPI_SETSTICKYKEYS);\r\n FMap[50] := Point(SPI_GETACCESSTIMEOUT, SPI_SETACCESSTIMEOUT);\r\n FMap[51] := Point(SPI_GETSERIALKEYS, SPI_SETSERIALKEYS);\r\n FMap[52] := Point(SPI_GETSOUNDSENTRY, SPI_SETSOUNDSENTRY);\r\n FMap[53] := Point(SPI_GETSNAPTODEFBUTTON, SPI_SETSNAPTODEFBUTTON);\r\n FMap[54] := Point(SPI_GETMOUSEHOVERWIDTH, SPI_SETMOUSEHOVERWIDTH);\r\n FMap[55] := Point(SPI_GETMOUSEHOVERHEIGHT, SPI_SETMOUSEHOVERHEIGHT);\r\n FMap[56] := Point(SPI_GETMOUSEHOVERTIME, SPI_SETMOUSEHOVERTIME);\r\n FMap[57] := Point(SPI_GETWHEELSCROLLLINES, SPI_SETWHEELSCROLLLINES);\r\n FMap[58] := Point(SPI_GETMENUSHOWDELAY, SPI_SETMENUSHOWDELAY);\r\n FMap[59] := Point(SPI_GETSHOWIMEUI, SPI_SETSHOWIMEUI);\r\n FMap[60] := Point(SPI_GETMOUSESPEED, SPI_SETMOUSESPEED);\r\n FMap[61] := Point(SPI_GETSCREENSAVERRUNNING, -1);\r\n FMap[62] := Point(SPI_GETACTIVEWINDOWTRACKING, SPI_SETACTIVEWINDOWTRACKING);\r\n FMap[63] := Point(SPI_GETMENUANIMATION, SPI_SETMENUANIMATION);\r\n FMap[64] := Point(SPI_GETCOMBOBOXANIMATION, SPI_SETCOMBOBOXANIMATION);\r\n FMap[65] := Point(SPI_GETLISTBOXSMOOTHSCROLLING, SPI_SETLISTBOXSMOOTHSCROLLING);\r\n FMap[66] := Point(SPI_GETGRADIENTCAPTIONS, SPI_SETGRADIENTCAPTIONS);\r\n FMap[67] := Point(SPI_GETKEYBOARDCUES, SPI_SETKEYBOARDCUES);\r\n FMap[68] := Point(SPI_GETMENUUNDERLINES, SPI_SETMENUUNDERLINES);\r\n FMap[69] := Point(SPI_GETACTIVEWNDTRKZORDER, SPI_SETACTIVEWNDTRKZORDER);\r\n FMap[70] := Point(SPI_GETHOTTRACKING, SPI_SETHOTTRACKING);\r\n FMap[71] := Point(SPI_GETMENUFADE, SPI_SETMENUFADE);\r\n FMap[72] := Point(SPI_GETSELECTIONFADE, SPI_SETSELECTIONFADE);\r\n FMap[73] := Point(SPI_GETTOOLTIPANIMATION, SPI_SETTOOLTIPANIMATION);\r\n FMap[74] := Point(SPI_GETTOOLTIPFADE, SPI_SETTOOLTIPFADE);\r\n FMap[75] := Point(SPI_GETCURSORSHADOW, SPI_SETCURSORSHADOW);\r\n FMap[76] := Point(SPI_GETUIEFFECTS, SPI_SETUIEFFECTS);\r\n FMap[77] := Point(SPI_GETFOREGROUNDLOCKTIMEOUT, SPI_SETFOREGROUNDLOCKTIMEOUT);\r\n FMap[78] := Point(SPI_GETACTIVEWNDTRKTIMEOUT, SPI_SETACTIVEWNDTRKTIMEOUT);\r\n FMap[79] := Point(SPI_GETFOREGROUNDFLASHCOUNT, SPI_SETFOREGROUNDFLASHCOUNT);\r\n FMap[80] := Point(SPI_GETCARETWIDTH, SPI_SETCARETWIDTH);\r\n FMap[81] := Point(SPI_GETDESKWALLPAPER, SPI_SETDESKWALLPAPER);\r\n FMap[82] := Point(SPI_GETMOUSESONAR, SPI_SETMOUSESONAR);\r\n FMap[83] := Point(SPI_GETMOUSECLICKLOCK, SPI_SETMOUSECLICKLOCK);\r\n FMap[84] := Point(SPI_GETMOUSEVANISH, SPI_SETMOUSEVANISH);\r\n FMap[85] := Point(SPI_GETFLATMENU, SPI_SETFLATMENU);\r\n FMap[86] := Point(SPI_GETDROPSHADOW, SPI_SETDROPSHADOW);\r\n FMap[87] := Point(SPI_GETFOREGROUNDLOCKTIMEOUT, SPI_SETFOREGROUNDLOCKTIMEOUT);\r\n FMap[88] := Point(SPI_GETACTIVEWNDTRKTIMEOUT, SPI_SETACTIVEWNDTRKTIMEOUT);\r\n FMap[89] := Point(SPI_GETFOREGROUNDFLASHCOUNT, SPI_SETFOREGROUNDFLASHCOUNT);\r\n FMap[90] := Point(SPI_GETCARETWIDTH, SPI_SETCARETWIDTH);\r\n FMap[91] := Point(SPI_GETMOUSECLICKLOCKTIME, SPI_SETMOUSECLICKLOCKTIME);\r\n FMap[92] := Point(SPI_GETFONTSMOOTHINGTYPE, SPI_SETFONTSMOOTHINGTYPE);\r\n FMap[93] := Point(SPI_GETFONTSMOOTHINGCONTRAST, SPI_SETFONTSMOOTHINGCONTRAST);\r\n FMap[94] := Point(SPI_GETFOCUSBORDERWIDTH, SPI_SETFOCUSBORDERWIDTH);\r\n FMap[95] := Point(SPI_GETFOCUSBORDERHEIGHT, SPI_SETFOCUSBORDERHEIGHT);\r\nend;\r\n\r\nfunction TJvSystemParametersInfo.MapToSet(Index: Integer): Integer;\r\nvar\r\n I: Integer;\r\nbegin\r\n InitMap;\r\n for I := 0 to Length(FMap) - 1 do\r\n if FMap[I].X = Index then\r\n begin\r\n Result := FMap[I].Y;\r\n Exit;\r\n end;\r\n Result := -1;\r\nend;\r\n\r\n{ (ahuser) make Delphi 5 Compiler happy\r\nfunction MapToGet(Index: Integer): Integer;\r\nvar\r\n I: Integer;\r\nbegin\r\n InitMap;\r\n for I := 0 to Length(FMap) - 1 do\r\n if FMap[I].X = Index then\r\n begin\r\n Result := FMap[I].Y;\r\n Exit;\r\n end;\r\n Result := -1;\r\nend;}\r\n\r\nfunction TJvSystemParametersInfo.GetAccessTimeOut: TJvAccessTimeOut;\r\nbegin\r\n if FAccessTimeOut = nil then\r\n FAccessTimeOut := TJvAccessTimeOut.Create;\r\n Result := FAccessTimeOut;\r\nend;\r\n\r\nfunction TJvSystemParametersInfo.GetAnimationInfo: Boolean;\r\nvar\r\n Info: ANIMATIONINFO;\r\nbegin\r\n if SystemParametersInfo(SPI_GETANIMATION, SizeOf(Info), @Info, 0) then\r\n Result := Info.iMinAnimate <> 0\r\n else\r\n Result := False;\r\nend;\r\n\r\nfunction TJvSystemParametersInfo.GetBoolInfo(const Index: Integer): Boolean;\r\nvar\r\n Value: Integer;\r\nbegin\r\n if SystemParametersInfo(Index, 0, @Value, 0) then\r\n Result := Value <> 0\r\n else\r\n Result := False;\r\nend;\r\n\r\nfunction TJvSystemParametersInfo.GetDeskWallpaper: string;\r\nbegin\r\n // doesn't work\r\n // SetLength(Result, MAX_PATH);\r\n // SystemParametersInfo(SPI_GETDESKWALLPAPER, Length(Result), @Result[1], 0);\r\n Result := '';\r\nend;\r\n\r\nfunction TJvSystemParametersInfo.GetFilterKeys: TJvFilterKeys;\r\nbegin\r\n if FFilterKeys = nil then\r\n FFilterKeys := TJvFilterKeys.Create;\r\n Result := FFilterKeys;\r\nend;\r\n\r\nfunction TJvSystemParametersInfo.GetFontSmoothingType: TJvFontSmoothingType;\r\nvar\r\n Value: Integer;\r\nbegin\r\n Result := fstStandard;\r\n if SystemParametersInfo(SPI_GETFONTSMOOTHINGTYPE, 0, @Value, 0) then\r\n case Value of\r\n // FE_FONTSMOOTHINGSTANDARD: Result := fstStandard;\r\n FE_FONTSMOOTHINGCLEARTYPE:\r\n Result := fstClearType;\r\n FE_FONTSMOOTHINGDOCKING:\r\n Result := fstDocking;\r\n end;\r\nend;\r\n\r\nfunction TJvSystemParametersInfo.GetHighContrast: TJvHighContrast;\r\nbegin\r\n if FHighContrast = nil then\r\n FHighContrast := TJvHighContrast.Create;\r\n Result := FHighContrast;\r\nend;\r\n\r\nfunction TJvSystemParametersInfo.GetIconMetrics: TJvIconMetrics;\r\nbegin\r\n if FIconMetrics = nil then\r\n FIconMetrics := TJvIconMetrics.Create;\r\n Result := FIconMetrics;\r\nend;\r\n\r\nfunction TJvSystemParametersInfo.GetIconSpacing(const Index: Integer): Integer;\r\nconst\r\n cIconSpacing: array [0..1] of DWORD = (SPI_ICONHORIZONTALSPACING, SPI_ICONVERTICALSPACING);\r\nbegin\r\n SystemParametersInfo(cIconSpacing[Index], 0, @Result, 0);\r\nend;\r\n\r\nfunction TJvSystemParametersInfo.GetIconTitleFont: TFont;\r\nvar\r\n ALogFont: TLogFont;\r\nbegin\r\n if FIconTitleFont = nil then\r\n FIconTitleFont := TFont.Create;\r\n SystemParametersInfo(SPI_GETICONTITLELOGFONT, SizeOf(ALogFont), @ALogFont, 0);\r\n UpdateFromLogFont(FIconTitleFont, ALogFont);\r\n Result := FIconTitleFont;\r\nend;\r\n\r\nfunction TJvSystemParametersInfo.GetIntInfo(const Index: Integer): Integer;\r\nbegin\r\n if not SystemParametersInfo(Index, 0, @Result, 0) then\r\n Result := 0;\r\nend;\r\n\r\nfunction TJvSystemParametersInfo.GetKeyboardLayoutName: string;\r\nvar\r\n Buf: array [0..8] of Char;\r\nbegin\r\n if Windows.GetKeyboardLayoutName(Buf) then\r\n Result := Buf\r\n else\r\n Result := '';\r\nend;\r\n\r\nfunction TJvSystemParametersInfo.GetMinimizedMetrics: TJvMinimizedMetrics;\r\nbegin\r\n if FMinimizedMetrics = nil then\r\n FMinimizedMetrics := TJvMinimizedMetrics.Create;\r\n Result := FMinimizedMetrics;\r\nend;\r\n\r\nfunction TJvSystemParametersInfo.GetMouseInfo(const Index: Integer): Integer;\r\nvar\r\n Mouse: array [0..2] of Integer;\r\nbegin\r\n if (Index in [0..2]) and SystemParametersInfo(SPI_GETMOUSE, SizeOf(Mouse), @Mouse, 0) then\r\n Result := Mouse[Index]\r\n else\r\n Result := 0;\r\nend;\r\n\r\nfunction TJvSystemParametersInfo.GetMouseKeys: TJvMouseKeys;\r\nbegin\r\n if FMouseKeys = nil then\r\n FMouseKeys := TJvMouseKeys.Create;\r\n Result := FMouseKeys;\r\nend;\r\n\r\nfunction TJvSystemParametersInfo.GetNonClientMetrics: TJvNonClientMetrics;\r\nbegin\r\n if FNonClientMetrics = nil then\r\n FNonClientMetrics := TJvNonClientMetrics.Create;\r\n Result := FNonClientMetrics;\r\nend;\r\n\r\nfunction TJvSystemParametersInfo.GetSerialKeys: TJvSerialKeys;\r\nbegin\r\n if FSerialKeys = nil then\r\n FSerialKeys := TJvSerialKeys.Create;\r\n Result := FSerialKeys;\r\nend;\r\n\r\nfunction TJvSystemParametersInfo.GetSoundSentry: TJvSoundSentry;\r\nbegin\r\n if FSoundSentry = nil then\r\n FSoundSentry := TJvSoundSentry.Create;\r\n Result := FSoundSentry;\r\nend;\r\n\r\nfunction TJvSystemParametersInfo.GetStickyKeys: TJvStickyKeysFlags;\r\nvar\r\n StickyKeys: TStickyKeys;\r\n Flags: DWORD;\r\nbegin\r\n StickyKeys.cbSize := SizeOf(StickyKeys);\r\n if SystemParametersInfo(SPI_GETSTICKYKEYS, SizeOf(StickyKeys), @StickyKeys, 0) then\r\n Flags := StickyKeys.dwFlags\r\n else\r\n Flags := 0;\r\n Result := [];\r\n if Flags and SKF_AUDIBLEFEEDBACK = SKF_AUDIBLEFEEDBACK then\r\n Include(Result, skfAudibleFeedback);\r\n if Flags and SKF_AVAILABLE = SKF_AVAILABLE then\r\n Include(Result, skfAvailable);\r\n if Flags and SKF_CONFIRMHOTKEY = SKF_CONFIRMHOTKEY then\r\n Include(Result, skfConfirmHotkey);\r\n if Flags and SKF_HOTKEYACTIVE = SKF_HOTKEYACTIVE then\r\n Include(Result, skfHotkeyActive);\r\n if Flags and SKF_HOTKEYSOUND = SKF_HOTKEYSOUND then\r\n Include(Result, skfHotkeySound);\r\n if Flags and SKF_INDICATOR = SKF_INDICATOR then\r\n Include(Result, skfIndicator);\r\n if Flags and SKF_STICKYKEYSON = SKF_STICKYKEYSON then\r\n Include(Result, skfStickyKeysOn);\r\n if Flags and SKF_TRISTATE = SKF_TRISTATE then\r\n Include(Result, skfTriState);\r\n if Flags and SKF_TWOKEYSOFF = SKF_TWOKEYSOFF then\r\n Include(Result, skfTwoKeysOff);\r\n if Flags and SKF_LALTLATCHED = SKF_LALTLATCHED then\r\n Include(Result, skfLeftAltLatched);\r\n if Flags and SKF_LCTLLATCHED = SKF_LCTLLATCHED then\r\n Include(Result, skfLeftCtrlLatched);\r\n if Flags and SKF_LSHIFTLATCHED = SKF_LSHIFTLATCHED then\r\n Include(Result, skfLeftShiftLatched);\r\n if Flags and SKF_RALTLATCHED = SKF_RALTLATCHED then\r\n Include(Result, skfRightAltLatched);\r\n if Flags and SKF_RCTLLATCHED = SKF_RCTLLATCHED then\r\n Include(Result, skfRightCtrlLatched);\r\n if Flags and SKF_RSHIFTLATCHED = SKF_RSHIFTLATCHED then\r\n Include(Result, skfRightShiftLatched);\r\n if Flags and SKF_LWINLATCHED = SKF_LWINLATCHED then\r\n Include(Result, skfLeftWinLatched);\r\n if Flags and SKF_RWINLATCHED = SKF_RWINLATCHED then\r\n Include(Result, skfRightWinLatched);\r\n if Flags and SKF_LALTLOCKED = SKF_LALTLOCKED then\r\n Include(Result, skfLeftAltLocked);\r\n if Flags and SKF_LCTLLOCKED = SKF_LCTLLOCKED then\r\n Include(Result, skfLeftCtrlLocked);\r\n if Flags and SKF_LSHIFTLOCKED = SKF_LSHIFTLOCKED then\r\n Include(Result, skfLeftShiftLocked);\r\n if Flags and SKF_RALTLOCKED = SKF_RALTLOCKED then\r\n Include(Result, skfRightAltLocked);\r\n if Flags and SKF_RCTLLOCKED = SKF_RCTLLOCKED then\r\n Include(Result, skfRightCtrlLocked);\r\n if Flags and SKF_RSHIFTLOCKED = SKF_RSHIFTLOCKED then\r\n Include(Result, skfRightShiftLocked);\r\n if Flags and SKF_LWINLOCKED = SKF_LWINLOCKED then\r\n Include(Result, skfLeftWinLocked);\r\n if Flags and SKF_RWINLOCKED = SKF_RWINLOCKED then\r\n Include(Result, skfRightWinLocked);\r\nend;\r\n\r\nfunction TJvSystemParametersInfo.GetToggleKeys: TJvToggleKeysFlags;\r\nvar\r\n ToggleKeys: TToggleKeys;\r\n Flags: DWORD;\r\nbegin\r\n ToggleKeys.cbSize := SizeOf(ToggleKeys);\r\n if SystemParametersInfo(SPI_GETTOGGLEKEYS, SizeOf(ToggleKeys), @ToggleKeys, 0) then\r\n Flags := ToggleKeys.dwFlags\r\n else\r\n Flags := 0;\r\n Result := [];\r\n if Flags and TKF_AVAILABLE = TKF_AVAILABLE then\r\n Include(Result, tkfAvailable);\r\n if Flags and TKF_CONFIRMHOTKEY = TKF_CONFIRMHOTKEY then\r\n Include(Result, tkfConfirmHotkey);\r\n if Flags and TKF_HOTKEYACTIVE = TKF_HOTKEYACTIVE then\r\n Include(Result, tkfHotkeyActive);\r\n if Flags and TKF_HOTKEYSOUND = TKF_HOTKEYSOUND then\r\n Include(Result, tkfHotkeySound);\r\n if Flags and TKF_TOGGLEKEYSON = TKF_TOGGLEKEYSON then\r\n Include(Result, tkfToggleKeysOn);\r\nend;\r\n\r\nfunction TJvSystemParametersInfo.GetWorkArea: TJvRect;\r\nvar\r\n Value: TRect;\r\nbegin\r\n if not SystemParametersInfo(SPI_GETWORKAREA, 0, @Value, 0) then\r\n Value := Rect(0, 0, 0, 0);\r\n\r\n FWorkArea.Top := Value.Top;\r\n FWorkArea.Left := Value.Left;\r\n FWorkArea.Bottom := Value.Bottom;\r\n FWorkArea.Right := Value.Right;\r\n Result := FWorkArea;\r\nend;\r\n\r\nprocedure TJvSystemParametersInfo.SetAccessTimeOut(const Value: TJvAccessTimeOut);\r\nbegin\r\n //\r\nend;\r\n\r\nprocedure TJvSystemParametersInfo.SetAnimationInfo(const Value: Boolean);\r\nvar\r\n Info: ANIMATIONINFO;\r\nbegin\r\n if not IsDesigning and not ReadOnly then\r\n begin\r\n Info.cbSize := SizeOf(Info);\r\n Info.iMinAnimate := Ord(Value);\r\n SystemParametersInfo(SPI_SETANIMATION, SizeOf(Info), @Info, 0);\r\n end\r\n else\r\n RaiseReadOnly;\r\nend;\r\n\r\nprocedure TJvSystemParametersInfo.SetBoolInfo(const Index: Integer;\r\n const Value: Boolean);\r\nbegin\r\n if not IsDesigning and not ReadOnly and (Index <> SPI_GETSCREENSAVERRUNNING) then\r\n begin\r\n if Index >= SPI_GETACTIVEWINDOWTRACKING then // new values use new style\r\n SystemParametersInfo(MapToSet(Index), 0, @Value, DEFAULT_SPIF_SENDCHANGE)\r\n else\r\n SystemParametersInfo(MapToSet(Index), Ord(Value), nil, DEFAULT_SPIF_SENDCHANGE);\r\n end\r\n else\r\n RaiseReadOnly;\r\nend;\r\n\r\nprocedure TJvSystemParametersInfo.SetDeskWallpaper(const Value: string);\r\nbegin\r\n if not IsDesigning and not ReadOnly then\r\n SystemParametersInfo(SPI_SETDESKWALLPAPER, Length(Value), Pointer(Value), 0)\r\n else\r\n RaiseReadOnly;\r\nend;\r\n\r\nprocedure TJvSystemParametersInfo.SetFilterKeys(const Value: TJvFilterKeys);\r\nbegin\r\n //\r\nend;\r\n\r\nprocedure TJvSystemParametersInfo.SetFontSmoothingType(const Value: TJvFontSmoothingType);\r\nvar\r\n Smoothing: Integer;\r\nbegin\r\n if not IsDesigning and not ReadOnly then\r\n begin\r\n case Value of\r\n fstClearType:\r\n Smoothing := FE_FONTSMOOTHINGCLEARTYPE;\r\n fstDocking:\r\n Smoothing := FE_FONTSMOOTHINGDOCKING;\r\n else\r\n Smoothing := FE_FONTSMOOTHINGSTANDARD;\r\n end;\r\n SystemParametersInfo(SPI_SETFONTSMOOTHINGTYPE, Smoothing, nil, DEFAULT_SPIF_SENDCHANGE);\r\n end\r\n else\r\n RaiseReadOnly;\r\nend;\r\n\r\nprocedure TJvSystemParametersInfo.SetHighContrast(const Value: TJvHighContrast);\r\nbegin\r\n //\r\nend;\r\n\r\nprocedure TJvSystemParametersInfo.SetIconMetrics(const Value: TJvIconMetrics);\r\nbegin\r\n //\r\nend;\r\n\r\nprocedure TJvSystemParametersInfo.SetIconSpacing(const Index, Value: Integer);\r\nconst\r\n cIconSpacing: array [0..1] of DWORD =\r\n (SPI_ICONHORIZONTALSPACING, SPI_ICONVERTICALSPACING);\r\nbegin\r\n if not IsDesigning and not ReadOnly then\r\n SystemParametersInfo(cIconSpacing[Index], Value, nil, 0)\r\n else\r\n RaiseReadOnly;\r\nend;\r\n\r\nprocedure TJvSystemParametersInfo.SetIconTitleFont(const Value: TFont);\r\nvar\r\n ALogFont: TLogFont;\r\nbegin\r\n if not IsDesigning and not ReadOnly then\r\n begin\r\n UpdateToLogFont(Value, ALogFont);\r\n SystemParametersInfo(SPI_SETICONTITLELOGFONT, SizeOf(ALogFont), @ALogFont, 0);\r\n end\r\n else\r\n RaiseReadOnly;\r\nend;\r\n\r\nprocedure TJvSystemParametersInfo.SetIntInfo(const Index, Value: Integer);\r\nbegin\r\n if not IsDesigning and not ReadOnly and (Index <> SPI_GETSCREENSAVERRUNNING) then\r\n begin\r\n if Index >= SPI_GETACTIVEWINDOWTRACKING then // new values use new style\r\n SystemParametersInfo(MapToSet(Index), 0, @Value, DEFAULT_SPIF_SENDCHANGE)\r\n else\r\n SystemParametersInfo(MapToSet(Index), Value, nil, DEFAULT_SPIF_SENDCHANGE);\r\n end\r\n else\r\n RaiseReadOnly;\r\nend;\r\n\r\nprocedure TJvSystemParametersInfo.SetKeyboardLayoutName(const Value: string);\r\nbegin\r\n if not IsDesigning and not ReadOnly then\r\n LoadKeyboardLayout(PChar(Value), KLF_ACTIVATE)\r\n else\r\n RaiseReadOnly;\r\nend;\r\n\r\nprocedure TJvSystemParametersInfo.SetMinimizedMetrics(const Value: TJvMinimizedMetrics);\r\nbegin\r\n //\r\nend;\r\n\r\nprocedure TJvSystemParametersInfo.SetMouseInfo(const Index, Value: Integer);\r\nvar\r\n Mouse: array [0..2] of Integer;\r\nbegin\r\n if not IsDesigning and not ReadOnly then\r\n begin\r\n if (Index in [0..2]) and SystemParametersInfo(SPI_GETMOUSE, SizeOf(Mouse), @Mouse, 0) then\r\n begin\r\n Mouse[Index] := Value;\r\n SystemParametersInfo(SPI_SETMOUSE, SizeOf(Mouse), @Mouse, DEFAULT_SPIF_SENDCHANGE);\r\n end;\r\n end\r\n else\r\n RaiseReadOnly;\r\nend;\r\n\r\nprocedure TJvSystemParametersInfo.SetMouseKeys(const Value: TJvMouseKeys);\r\nbegin\r\n //\r\nend;\r\n\r\nprocedure TJvSystemParametersInfo.SetNonClientMetrics(const Value: TJvNonClientMetrics);\r\nbegin\r\n //\r\nend;\r\n\r\nprocedure TJvSystemParametersInfo.SetSerialKeys(const Value: TJvSerialKeys);\r\nbegin\r\n //\r\nend;\r\n\r\nprocedure TJvSystemParametersInfo.SetSoundSentry(const Value: TJvSoundSentry);\r\nbegin\r\n //\r\nend;\r\n\r\nprocedure TJvSystemParametersInfo.SetStickyKeys(const Value: TJvStickyKeysFlags);\r\nvar\r\n StickyKeys: TStickyKeys;\r\n Flags: DWORD;\r\nbegin\r\n if not IsDesigning and not ReadOnly then\r\n begin\r\n Flags := 0;\r\n if skfAudibleFeedback in Value then\r\n Flags := Flags or SKF_AUDIBLEFEEDBACK;\r\n if skfAvailable in Value then\r\n Flags := Flags or SKF_AVAILABLE;\r\n if skfConfirmHotkey in Value then\r\n Flags := Flags or SKF_CONFIRMHOTKEY;\r\n if skfHotkeyActive in Value then\r\n Flags := Flags or SKF_HOTKEYACTIVE;\r\n if skfHotkeySound in Value then\r\n Flags := Flags or SKF_HOTKEYSOUND;\r\n if skfIndicator in Value then\r\n Flags := Flags or SKF_INDICATOR;\r\n if skfStickyKeysOn in Value then\r\n Flags := Flags or SKF_STICKYKEYSON;\r\n if skfTriState in Value then\r\n Flags := Flags or SKF_TRISTATE;\r\n if skfTwoKeysOff in Value then\r\n Flags := Flags or SKF_TWOKEYSOFF;\r\n if skfAudibleFeedback in Value then\r\n Flags := Flags or SKF_AUDIBLEFEEDBACK;\r\n if skfAvailable in Value then\r\n Flags := Flags or SKF_AVAILABLE;\r\n if skfConfirmHotkey in Value then\r\n Flags := Flags or SKF_CONFIRMHOTKEY;\r\n if skfHotkeyActive in Value then\r\n Flags := Flags or SKF_HOTKEYACTIVE;\r\n if skfHotkeySound in Value then\r\n Flags := Flags or SKF_HOTKEYSOUND;\r\n if skfIndicator in Value then\r\n Flags := Flags or SKF_INDICATOR;\r\n if skfStickyKeysOn in Value then\r\n Flags := Flags or SKF_STICKYKEYSON;\r\n if skfTriState in Value then\r\n Flags := Flags or SKF_TRISTATE;\r\n if skfTwoKeysOff in Value then\r\n Flags := Flags or SKF_TWOKEYSOFF;\r\n if skfLeftAltLatched in Value then\r\n Flags := Flags or SKF_LALTLATCHED;\r\n if skfLeftCtrlLatched in Value then\r\n Flags := Flags or SKF_LCTLLATCHED;\r\n if skfLeftShiftLatched in Value then\r\n Flags := Flags or SKF_LSHIFTLATCHED;\r\n if skfRightAltLatched in Value then\r\n Flags := Flags or SKF_RALTLATCHED;\r\n if skfRightCtrlLatched in Value then\r\n Flags := Flags or SKF_RCTLLATCHED;\r\n if skfRightShiftLatched in Value then\r\n Flags := Flags or SKF_RSHIFTLATCHED;\r\n if skfLeftWinLatched in Value then\r\n Flags := Flags or SKF_LWINLATCHED;\r\n if skfRightWinLatched in Value then\r\n Flags := Flags or SKF_RWINLATCHED;\r\n if skfLeftAltLocked in Value then\r\n Flags := Flags or SKF_LALTLOCKED;\r\n if skfLeftCtrlLocked in Value then\r\n Flags := Flags or SKF_LCTLLOCKED;\r\n if skfLeftShiftLocked in Value then\r\n Flags := Flags or SKF_LSHIFTLOCKED;\r\n if skfRightAltLocked in Value then\r\n Flags := Flags or SKF_RALTLOCKED;\r\n if skfRightCtrlLocked in Value then\r\n Flags := Flags or SKF_RCTLLOCKED;\r\n if skfRightShiftLocked in Value then\r\n Flags := Flags or SKF_RSHIFTLOCKED;\r\n if skfLeftWinLocked in Value then\r\n Flags := Flags or SKF_LWINLOCKED;\r\n if skfRightWinLocked in Value then\r\n Flags := Flags or SKF_RWINLOCKED;\r\n StickyKeys.cbSize := SizeOf(StickyKeys);\r\n StickyKeys.dwFlags := Flags;\r\n SystemParametersInfo(SPI_SETSTICKYKEYS, SizeOf(StickyKeys), @StickyKeys, DEFAULT_SPIF_SENDCHANGE);\r\n end\r\n else\r\n RaiseReadOnly;\r\nend;\r\n\r\nprocedure TJvSystemParametersInfo.SetToggleKeys(const Value: TJvToggleKeysFlags);\r\nvar\r\n ToggleKeys: TToggleKeys;\r\n Flags: DWORD;\r\nbegin\r\n if not IsDesigning and not ReadOnly then\r\n begin\r\n Flags := 0;\r\n if tkfAvailable in Value then\r\n Flags := Flags or TKF_AVAILABLE;\r\n if tkfConfirmHotkey in Value then\r\n Flags := Flags or TKF_CONFIRMHOTKEY;\r\n if tkfHotkeyActive in Value then\r\n Flags := Flags or TKF_HOTKEYACTIVE;\r\n if tkfHotkeySound in Value then\r\n Flags := Flags or TKF_HOTKEYSOUND;\r\n if tkfToggleKeysOn in Value then\r\n Flags := Flags or TKF_TOGGLEKEYSON;\r\n ToggleKeys.cbSize := SizeOf(ToggleKeys);\r\n ToggleKeys.dwFlags := Flags;\r\n SystemParametersInfo(SPI_SETTOGGLEKEYS, SizeOf(ToggleKeys), @ToggleKeys, DEFAULT_SPIF_SENDCHANGE);\r\n end\r\n else\r\n RaiseReadOnly;\r\nend;\r\n\r\nprocedure TJvSystemParametersInfo.SetWorkArea(const Value: TJvRect);\r\nbegin\r\n RaiseReadOnly;\r\nend;\r\n\r\nprocedure TJvSystemColorsInfo.SetColor(Index: Integer; Value: TColor);\r\nbegin\r\n if not IsDesigning and not ReadOnly then\r\n SetSysColors(1, Index, Value)\r\n else\r\n RaiseReadOnly;\r\nend;\r\n\r\nfunction TJvSystemColorsInfo.GetColor(Index: Integer): TColor;\r\nbegin\r\n Result := GetSysColor(Index);\r\nend;\r\n\r\n//=== { TJvFileInfo } ========================================================\r\n\r\nconstructor TJvFileInfo.Create;\r\nbegin\r\n inherited Create;\r\n FIcon := TIcon.Create;\r\n FModifiers := [imNormal];\r\n GetLargeImages;\r\n GetSmallImages;\r\nend;\r\n\r\ndestructor TJvFileInfo.Destroy;\r\nbegin\r\n FLargeImages.Free;\r\n FSmallImages.Free;\r\n FIcon.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJvFileInfo.GetLargeImages: TImageList;\r\nvar\r\n SysIL: THandle;\r\n sfi: TSHFileInfo;\r\nbegin\r\n if not Assigned(FLargeImages) then\r\n FLargeImages := TImageList.Create(nil);\r\n SysIL := GetFileInfo('', 0, sfi, SHGFI_SYSICONINDEX or SHGFI_LARGEICON);\r\n if SysIL <> 0 then\r\n FLargeImages.Handle := SysIL;\r\n FLargeImages.ShareImages := True;\r\n Result := FLargeImages;\r\nend;\r\n\r\nfunction TJvFileInfo.GetSmallImages: TImageList;\r\nvar\r\n SysIL: THandle;\r\n sfi: TSHFileInfo;\r\nbegin\r\n if not Assigned(FSmallImages) then\r\n FSmallImages := TImageList.Create(nil);\r\n SysIL := GetFileInfo('', 0, sfi, SHGFI_SYSICONINDEX or SHGFI_SMALLICON);\r\n if SysIL <> 0 then\r\n FSmallImages.Handle := SysIL;\r\n FSmallImages.ShareImages := True;\r\n Result := FSmallImages;\r\nend;\r\n\r\nprocedure TJvFileInfo.SetModifiers(Value: TJvIconModifiers);\r\nbegin\r\n if FModifiers <> Value then\r\n begin\r\n FModifiers := Value;\r\n Include(FModifiers, imNormal); // imNormal can never be removed (equals 0)\r\n GetIconHandle;\r\n end;\r\nend;\r\n\r\nprocedure TJvFileInfo.SetFileName(Value: TFileName);\r\nbegin\r\n FFileName := Value;\r\n GetIconHandle;\r\nend;\r\n\r\nprocedure TJvFileInfo.SetExeDummy(const Value: TJvExeType);\r\nbegin\r\n RaiseReadOnly;\r\nend;\r\n\r\nprocedure TJvFileInfo.SetIconDummy(const Value: TIcon);\r\nbegin\r\n RaiseReadOnly;\r\nend;\r\n\r\nprocedure TJvFileInfo.SetIntDummy(const Value: Integer);\r\nbegin\r\n RaiseReadOnly;\r\nend;\r\n\r\nprocedure TJvFileInfo.SetStrDummy(const Value: string);\r\nbegin\r\n RaiseReadOnly;\r\nend;\r\n\r\n{ returns index of icon for filename in the systemlist }\r\n\r\nfunction TJvFileInfo.GetIconIndex: Integer;\r\nvar\r\n sfi: TSHFileInfo;\r\nbegin\r\n GetFileInfo(FFileName, 0, sfi, SHGFI_SYSICONINDEX);\r\n Result := sfi.iIcon;\r\nend;\r\n\r\nfunction TJvFileInfo.GetDisplayName: string;\r\nvar\r\n sfi: TSHFileInfo;\r\nbegin\r\n GetFileInfo(FFileName, 0, sfi, SHGFI_DISPLAYNAME);\r\n Result := sfi.szDisplayName;\r\nend;\r\n\r\nfunction TJvFileInfo.GetExeType: TJvExeType;\r\nvar\r\n sfi: TSHFileInfo;\r\n Res: Integer;\r\nbegin\r\n Result := etNone;\r\n\r\n Res := GetFileInfo(FFileName, 0, sfi, SHGFI_EXETYPE);\r\n if Res = 0 then\r\n Exit;\r\n case Lo(Res) of\r\n 77:\r\n Result := etMSDos;\r\n 78:\r\n Result := etWin16;\r\n 80:\r\n Result := etWin32;\r\n else\r\n Result := etConsole; { ? }\r\n end;\r\nend;\r\n\r\nfunction TJvFileInfo.GetAttributes: Integer;\r\n// var sfi: TSHFileInfo;\r\nbegin\r\n{ this doesn't work, use \"old\" method instead }\r\n{\r\n GetFileInfo(FFileName, 0, sfi, SHGFI_ATTRIBUTES);\r\n Result := sfi.dwAttributes;}\r\n Result := GetFileAttributes(PChar(FFileName));\r\nend;\r\n\r\nfunction TJvFileInfo.GetAttrString: string;\r\nvar\r\n I: Integer;\r\nbegin\r\n I := GetAttributes;\r\n Result := '';\r\n if (I and FILE_ATTRIBUTE_NORMAL) <> 0 then\r\n Exit; { no attributes }\r\n if (I and FILE_ATTRIBUTE_ARCHIVE) <> 0 then\r\n Result := Result + RsAttrArchiveShortString;\r\n if (I and FILE_ATTRIBUTE_COMPRESSED) <> 0 then\r\n Result := Result + RsAttrCompressedShortString;\r\n if (I and FILE_ATTRIBUTE_DIRECTORY) <> 0 then\r\n Result := Result + RsAttrDirectoryShortString;\r\n if (I and FILE_ATTRIBUTE_HIDDEN) <> 0 then\r\n Result := Result + RsAttrHiddenShortString;\r\n if (I and FILE_ATTRIBUTE_READONLY) <> 0 then\r\n Result := Result + RsAttrReadOnlyShortString;\r\n if (I and FILE_ATTRIBUTE_SYSTEM) <> 0 then\r\n Result := Result + RsAttrSystemShortString;\r\nend;\r\n\r\nfunction StrTrimAll(const S: string; const Chars: TSysCharSet): string;\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := 1 to Length(S) do\r\n if not CharInSet(S[I], Chars) then\r\n Result := Result + S[I];\r\nend;\r\n\r\nfunction AddDot(S: string): string;\r\nbegin\r\n Result := S;\r\n if (Length(Result) > 0) and (Result[1] <> '.') then\r\n Result := '.' + Result;\r\nend;\r\n\r\nfunction ExpandEnvVar(const Value: string): string;\r\nvar\r\n Dest: array [0..MAX_PATH] of Char;\r\nbegin\r\n ExpandEnvironmentStrings(PChar(Value), Dest, MAX_PATH - 1);\r\n Result := Dest;\r\nend;\r\n\r\nfunction GetAdvancedIconLocation(const FileName: string; var iIcon: Integer): string;\r\nvar\r\n Reg: TRegistry;\r\n Ext, sPath, Tmp: string;\r\n I: Integer;\r\n sfi: TSHFileInfo;\r\nbegin\r\n // first try the easy way:\r\n SHGetFileInfo(PChar(FileName), 0, sfi, SizeOf(sfi), SHGFI_ICON or SHGFI_ICONLOCATION);\r\n Result := sfi.szDisplayName;\r\n if Result <> '' then\r\n begin\r\n iIcon := sfi.iIcon;\r\n Exit;\r\n end;\r\n\r\n if Pos('.', FileName) > 0 then\r\n Ext := ExtractFileExt(StrTrimAll(FileName, ['\"', '''']))\r\n else\r\n Ext := AddDot(FileName);\r\n\r\n if Length(Ext) = 0 then\r\n Exit;\r\n Reg := TRegistry.Create;\r\n try\r\n Reg.RootKey := HKEY_CLASSES_ROOT;\r\n // is the key present ?\r\n if Reg.OpenKey(Ext, False) then\r\n // get ID to associated program:\r\n Result := Reg.ReadString('');\r\n if Reg.OpenKey('\\' + Result + '\\DefaultIcon', False) then\r\n Result := Reg.ReadString(''); // path (and possibly index) to icon location\r\n if Length(Result) > 0 then\r\n begin\r\n if Pos('%1', Result) > 0 then\r\n Result := FileName; // instance specific icon\r\n I := Pos(',', Result);\r\n sPath := '';\r\n if I > 0 then\r\n begin\r\n sPath := Copy(Result, I + 1, MaxInt);\r\n Result := Copy(Result, 1, I - 1);\r\n end;\r\n Tmp := '';\r\n for I := 1 to Length(sPath) do\r\n if not CharInSet(sPath[I], ['-', '0'..'9']) then\r\n Continue\r\n else\r\n Tmp := Tmp + sPath[I];\r\n iIcon := Abs(StrToIntDef(Tmp, 0)); // convert to positive index\r\n end\r\n finally\r\n Reg.Free;\r\n end;\r\n Result := ExpandEnvVar(Result); // replace any environment variables in path (like %systemroot%)\r\nend;\r\n\r\nfunction TJvFileInfo.GetIconLocation: string;\r\nvar\r\n sfi: TSHFileInfo;\r\n iIcon: Integer;\r\nbegin\r\n { this doesn't seem to work on files, only on directories (always returns an empty string)... }\r\n GetFileInfo(FFileName, 0, sfi, SHGFI_ICONLOCATION);\r\n Result := sfi.szDisplayName;\r\n if Result = '' then\r\n Result := StrTrimAll(GetAdvancedIconLocation(FFileName, iIcon), ['\"']);\r\nend;\r\n\r\nfunction TJvFileInfo.GetTypeString: string;\r\nvar\r\n sfi: TSHFileInfo;\r\nbegin\r\n GetFileInfo(FFileName, 0, sfi, SHGFI_TYPENAME);\r\n Result := sfi.szTypeName;\r\n if Result = '' then\r\n Result := Format(RsFileTypeString,[AnsiUpperCase(Copy(ExtractFileExt(FFileName), 2, MaxInt))]);\r\nend;\r\n\r\nfunction TJvFileInfo.GetIconHandle: THandle;\r\nconst\r\n Modifier: array [TJvIconModifier] of Integer =\r\n (0, SHGFI_LINKOVERLAY, SHGFI_SELECTED, SHGFI_OPENICON, SHGFI_SHELLICONSIZE, SHGFI_SMALLICON);\r\nvar\r\n sfi: TSHFileInfo;\r\n Flags: Integer;\r\n I: TJvIconModifier;\r\nbegin\r\n Flags := 0;\r\n for I := Low(TJvIconModifier) to High(TJvIconModifier) do\r\n if I in Modifiers then\r\n Flags := Flags or Modifier[I];\r\n GetFileInfo(FFileName, 0, sfi, SHGFI_SYSICONINDEX or SHGFI_ICON or Flags);\r\n Result := sfi.hIcon;\r\n FIcon.Handle := sfi.hIcon;\r\nend;\r\n\r\nfunction TJvFileInfo.GetFileInfo(const FileName: string; Attributes: Cardinal; out Info: ShFileInfo; Flags: Cardinal):\r\n Cardinal;\r\nbegin\r\n FillChar(Info, SizeOf(Info), 0);\r\n Result := SHGetFileInfo(PChar(FileName), Attributes, Info, SizeOf(Info), Flags);\r\nend;\r\n\r\n//=== { TJvComputerInfoEx } ==================================================\r\n\r\nconstructor TJvComputerInfoEx.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n IsDesigning := csDesigning in ComponentState;\r\n FReadOnly := True;\r\n if not IsDesigning then\r\n FDeviceHandle := AllocateHWndEx(WndProc);\r\nend;\r\n\r\ndestructor TJvComputerInfoEx.Destroy;\r\nbegin\r\n FAPMInfo.Free;\r\n FBIOSInfo.Free;\r\n FColors.Free;\r\n FCPUInfo.Free;\r\n FIdentification.Free;\r\n FKeyInfo.Free;\r\n FMemoryInfo.Free;\r\n FMiscInfo.Free;\r\n FOSVersionInfo.Free;\r\n FScreenInfo.Free;\r\n FSystemFolders.Free;\r\n FMetrics.Free;\r\n FSystem.Free;\r\n FFileInfo.Free;\r\n if not IsDesigning and (FDeviceHandle <> 0) then\r\n DeallocateHWndEx(FDeviceHandle);\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvComputerInfoEx.DoDriveChange(Drive: Char; Removed: Boolean);\r\nbegin\r\n if Removed then\r\n begin\r\n if Assigned(FOnDeviceRemoved) then\r\n FOnDeviceRemoved(Self, Drive);\r\n end\r\n else\r\n if Assigned(FOnDeviceAdded) then\r\n FOnDeviceAdded(Self, Drive);\r\nend;\r\n\r\nfunction TJvComputerInfoEx.FirstDrive(AMask: Integer): Char;\r\nvar\r\n Drive: Shortint;\r\nbegin\r\n Drive := Ord('A');\r\n while (AMask and 1) = 0 do\r\n begin\r\n AMask := AMask shr 1;\r\n Inc(Drive);\r\n end;\r\n Result := Char(Drive);\r\nend;\r\n\r\nfunction TJvComputerInfoEx.GetAPMInfo: TJvAPMInfo;\r\nbegin\r\n if FAPMInfo = nil then\r\n FAPMInfo := TJvAPMInfo.Create;\r\n Result := FAPMInfo;\r\nend;\r\n\r\nfunction TJvComputerInfoEx.GetBIOSInfo: TJvBIOSInfo;\r\nbegin\r\n if FBIOSInfo = nil then\r\n FBIOSInfo := TJvBIOSInfo.Create;\r\n Result := FBIOSInfo;\r\nend;\r\n\r\nfunction TJvComputerInfoEx.GetColors: TJvSystemColorsInfo;\r\nbegin\r\n if FColors = nil then\r\n begin\r\n FColors := TJvSystemColorsInfo.Create;\r\n FColors.ReadOnly := ReadOnly;\r\n end;\r\n Result := FColors;\r\nend;\r\n\r\nfunction TJvComputerInfoEx.GetCPUInfo: TJvCPUInfo;\r\nbegin\r\n if FCPUInfo = nil then\r\n FCPUInfo := TJvCPUInfo.Create;\r\n Result := FCPUInfo;\r\nend;\r\n\r\nfunction TJvComputerInfoEx.GetIdentification: TJvIdentification;\r\nbegin\r\n if FIdentification = nil then\r\n begin\r\n FIdentification := TJvIdentification.Create;\r\n FIdentification.ReadOnly := ReadOnly;\r\n end;\r\n Result := FIdentification;\r\nend;\r\n\r\nfunction TJvComputerInfoEx.GetKeyInfo: TJvKeyInfo;\r\nbegin\r\n if FKeyInfo = nil then\r\n begin\r\n FKeyInfo := TJvKeyInfo.Create;\r\n FKeyInfo.ReadOnly := ReadOnly;\r\n end;\r\n Result := FKeyInfo;\r\nend;\r\n\r\nfunction TJvComputerInfoEx.GetMemoryInfo: TJvMemInfo;\r\nbegin\r\n if FMemoryInfo = nil then\r\n FMemoryInfo := TJvMemInfo.Create;\r\n Result := FMemoryInfo;\r\nend;\r\n\r\nfunction TJvComputerInfoEx.GetMetrics: TJvMetricsInfo;\r\nbegin\r\n if FMetrics = nil then\r\n FMetrics := TJvMetricsInfo.Create;\r\n Result := FMetrics;\r\nend;\r\n\r\nfunction TJvComputerInfoEx.GetMiscInfo: TJvMiscInfo;\r\nbegin\r\n if FMiscInfo = nil then\r\n begin\r\n FMiscInfo := TJvMiscInfo.Create;\r\n FMiscInfo.ReadOnly := ReadOnly;\r\n end;\r\n Result := FMiscInfo;\r\nend;\r\n\r\nfunction TJvComputerInfoEx.GetOSVersionInfo: TJvOSVersionInfo;\r\nbegin\r\n if FOSVersionInfo = nil then\r\n FOSVersionInfo := TJvOSVersionInfo.Create;\r\n Result := FOSVersionInfo;\r\nend;\r\n\r\nfunction TJvComputerInfoEx.GetScreenInfo: TJvScreenInfo;\r\nbegin\r\n if FScreenInfo = nil then\r\n begin\r\n FScreenInfo := TJvScreenInfo.Create;\r\n FScreenInfo.ReadOnly := ReadOnly;\r\n end;\r\n Result := FScreenInfo;\r\nend;\r\n\r\nfunction TJvComputerInfoEx.GetSystem: TJvSystemParametersInfo;\r\nbegin\r\n if FSystem = nil then\r\n begin\r\n FSystem := TJvSystemParametersInfo.Create;\r\n FSystem.ReadOnly := ReadOnly;\r\n end;\r\n Result := FSystem;\r\nend;\r\n\r\nfunction TJvComputerInfoEx.GetSystemFolders: TJvSystemFolders;\r\nbegin\r\n if FSystemFolders = nil then\r\n FSystemFolders := TJvSystemFolders.Create;\r\n Result := FSystemFolders;\r\nend;\r\n\r\nfunction TJvComputerInfoEx.GetFileInfo: TJvFileInfo;\r\nbegin\r\n if FFileInfo = nil then\r\n FFileInfo := TJvFileInfo.Create;\r\n Result := FFileInfo;\r\nend;\r\n\r\nprocedure TJvComputerInfoEx.SetAPMInfo(const Value: TJvAPMInfo);\r\nbegin\r\n //\r\nend;\r\n\r\nprocedure TJvComputerInfoEx.SetBIOSInfo(const Value: TJvBIOSInfo);\r\nbegin\r\n //\r\nend;\r\n\r\nprocedure TJvComputerInfoEx.SetColors(const Value: TJvSystemColorsInfo);\r\nbegin\r\n //\r\nend;\r\n\r\nprocedure TJvComputerInfoEx.SetCPUInfo(const Value: TJvCPUInfo);\r\nbegin\r\n //\r\nend;\r\n\r\nprocedure TJvComputerInfoEx.SetIdentification(const Value: TJvIdentification);\r\nbegin\r\n //\r\nend;\r\n\r\nprocedure TJvComputerInfoEx.SetKeyInfo(const Value: TJvKeyInfo);\r\nbegin\r\n //\r\nend;\r\n\r\nprocedure TJvComputerInfoEx.SetMemoryInfo(const Value: TJvMemInfo);\r\nbegin\r\n //\r\nend;\r\n\r\nprocedure TJvComputerInfoEx.SetMetrics(const Value: TJvMetricsInfo);\r\nbegin\r\n //\r\nend;\r\n\r\nprocedure TJvComputerInfoEx.SetMiscInfo(const Value: TJvMiscInfo);\r\nbegin\r\n //\r\nend;\r\n\r\nprocedure TJvComputerInfoEx.SetOSVersionInfo(const Value: TJvOSVersionInfo);\r\nbegin\r\n //\r\nend;\r\n\r\nprocedure TJvComputerInfoEx.SetScreenInfo(const Value: TJvScreenInfo);\r\nbegin\r\n //\r\nend;\r\n\r\nprocedure TJvComputerInfoEx.SetSystem(const Value: TJvSystemParametersInfo);\r\nbegin\r\n //\r\nend;\r\n\r\nprocedure TJvComputerInfoEx.SetSystemFolders(const Value: TJvSystemFolders);\r\nbegin\r\n //\r\nend;\r\n\r\nprocedure TJvComputerInfoEx.SetFileInfo(const Value: TJvFileInfo);\r\nbegin\r\n //\r\nend;\r\n\r\nprocedure TJvComputerInfoEx.DoSettingChange(Flag: Integer; Section: string);\r\nbegin\r\n if Assigned(FOnSettingChange) then\r\n FOnSettingChange(Self, Flag, Section);\r\nend;\r\n\r\nprocedure TJvComputerInfoEx.WMDeviceChange(var Msg: TWMDeviceChange);\r\nvar\r\n lpdb: PDevBroadcastHdr;\r\n lpdbv: PDevBroadcastVolume;\r\nbegin\r\n lpdb := PDevBroadcastHdr(Msg.dwData);\r\n case Msg.Event of\r\n DBT_DEVICEARRIVAL:\r\n if lpdb^.dbch_devicetype = DBT_DEVTYP_VOLUME then\r\n begin\r\n lpdbv := PDevBroadcastVolume(Msg.dwData);\r\n if (lpdbv^.dbcv_flags and DBTF_MEDIA) = 1 then\r\n DoDriveChange(FirstDrive(lpdbv^.dbcv_unitmask), False);\r\n end;\r\n DBT_DEVICEREMOVECOMPLETE:\r\n if lpdb^.dbch_devicetype = DBT_DEVTYP_VOLUME then\r\n begin\r\n lpdbv := PDevBroadcastVolume(Msg.dwData);\r\n if (lpdbv^.dbcv_flags and DBTF_MEDIA) = 1 then\r\n DoDriveChange(FirstDrive(lpdbv^.dbcv_unitmask), True);\r\n end;\r\n // (rom) one of the rare occasions where ; before else is correct\r\n else\r\n with Msg do\r\n DoDeviceChange(Event, dwData);\r\n end\r\nend;\r\n\r\nprocedure TJvComputerInfoEx.DoCompacting(Ratio: Integer);\r\nbegin\r\n if Assigned(FOnCompacting) then\r\n FOnCompacting(Self, Ratio);\r\nend;\r\n\r\nprocedure TJvComputerInfoEx.DoPowerBroadcast(Event, Data: Integer);\r\nbegin\r\n if Assigned(FOnPowerBroadcast) then\r\n FOnPowerBroadcast(Self, Event, Data);\r\nend;\r\n\r\nprocedure TJvComputerInfoEx.DoUserChanged;\r\nbegin\r\n if Assigned(FOnUserChanged) then\r\n FOnUserChanged(Self);\r\nend;\r\n\r\nprocedure TJvComputerInfoEx.WndProc(var Message: TMessage);\r\nbegin\r\n with Message do\r\n begin\r\n case Msg of\r\n WM_DISPLAYCHANGE:\r\n WMDisplayChange(TWMDisplayChange(Message));\r\n WM_DEVMODECHANGE:\r\n DoDevModeChange(TWMDevModeChange(Message).Device);\r\n WM_SETTINGCHANGE:\r\n with TWMSettingChange(Message) do\r\n DoSettingChange(Flag, Section);\r\n WM_DEVICECHANGE:\r\n WMDeviceChange(TWMDeviceChange(Message));\r\n WM_COMPACTING:\r\n DoCompacting(wParam);\r\n WM_POWER, WM_POWERBROADCAST:\r\n DoPowerBroadcast(wParam, lParam);\r\n WM_USERCHANGED:\r\n DoUserChanged;\r\n WM_TIMECHANGE:\r\n DoTimeChange;\r\n WM_FONTCHANGE:\r\n DoFontChange;\r\n WM_SYSCOLORCHANGE:\r\n DoSysColorChange;\r\n WM_SPOOLERSTATUS:\r\n with TWMSpoolerStatus(Message) do\r\n DoSpoolerStatus(JobStatus, JobsLeft);\r\n WM_PALETTEISCHANGING:\r\n with TWMPaletteIsChanging(Message) do\r\n DoPaletteChanging(Realize);\r\n WM_PALETTECHANGED:\r\n with TWMPaletteChanged(Message) do\r\n DoPaletteChanged(PalChg);\r\n end;\r\n Result := DefWindowProc(FDeviceHandle, Msg, wParam, lParam);\r\n end;\r\nend;\r\n\r\nprocedure TJvComputerInfoEx.DoDevModeChange(const Device: PChar);\r\nbegin\r\n if Assigned(FOnDeviceModeChange) then\r\n FOnDeviceModeChange(Self, Device);\r\nend;\r\n\r\nprocedure TJvComputerInfoEx.WMDisplayChange(var Msg: TWMDisplayChange);\r\nbegin\r\n if Assigned(FOnDisplayChange) then\r\n FOnDisplayChange(Self, Msg.BitsPerPixel, Msg.Width, Msg.Height);\r\nend;\r\n\r\nprocedure TJvComputerInfoEx.DoDeviceChange(Event: UINT; dwData: Pointer);\r\nbegin\r\n if Assigned(FOnDeviceChange) then\r\n FOnDeviceChange(Self, Event, dwData);\r\nend;\r\n\r\nprocedure TJvComputerInfoEx.DoTimeChange;\r\nbegin\r\n if Assigned(FOnTimeChange) then\r\n FOnTimeChange(Self);\r\nend;\r\n\r\nprocedure TJvComputerInfoEx.DoFontChange;\r\nbegin\r\n if Assigned(FOnFontChange) then\r\n FOnFontChange(Self);\r\nend;\r\n\r\nprocedure TJvComputerInfoEx.DoSysColorChange;\r\nbegin\r\n if Assigned(FOnSysColorChange) then\r\n FOnSysColorChange(Self);\r\nend;\r\n\r\nprocedure TJvComputerInfoEx.DoSpoolerStatus(JobStatus, JobsLeft: Integer);\r\nbegin\r\n if Assigned(FOnSpoolerStatusChange) then\r\n FOnSpoolerStatusChange(Self, JobStatus, JobsLeft);\r\nend;\r\n\r\nprocedure TJvComputerInfoEx.DoPaletteChanging(Wnd: THandle);\r\nbegin\r\n if Assigned(FOnPaletteChanging) then\r\n FOnPaletteChanging(Self, Wnd);\r\nend;\r\n\r\nprocedure TJvComputerInfoEx.DoPaletteChanged(Wnd: THandle);\r\nbegin\r\n if Assigned(FOnPaletteChanged) then\r\n FOnPaletteChanged(Self, Wnd);\r\nend;\r\n\r\nprocedure TJvComputerInfoEx.SetReadOnly(const Value: Boolean);\r\nbegin\r\n if FReadOnly <> Value then\r\n begin\r\n FReadOnly := Value;\r\n if FColors <> nil then\r\n FColors.ReadOnly := FReadOnly;\r\n if FIdentification <> nil then\r\n FIdentification.ReadOnly := FReadOnly;\r\n if FKeyInfo <> nil then\r\n FKeyInfo.ReadOnly := FReadOnly;\r\n if FMiscInfo <> nil then\r\n FMiscInfo.ReadOnly := FReadOnly;\r\n if FScreenInfo <> nil then\r\n FScreenInfo.ReadOnly := FReadOnly;\r\n if FSystem <> nil then\r\n FSystem.ReadOnly := FReadOnly;\r\n end;\r\nend;\r\n\r\nfunction TJvComputerInfoEx.ResetSystemCursors: Boolean;\r\nbegin\r\n Result := SystemParametersInfo(SPI_SETCURSORS, 0, nil, SPIF_SENDCHANGE);\r\nend;\r\n\r\nfunction TJvComputerInfoEx.ResetSystemIcons: Boolean;\r\nconst\r\n HKCU_WINDOWMETRICS = '\\Control Panel\\Desktop\\WindowMetrics';\r\n cShellIconSize = 'Shell Icon Size';\r\nvar\r\n DefaultValue: Integer;\r\nbegin\r\n // Result := SystemParametersInfo(SPI_SETICONS, 0, nil, SPIF_SENDCHANGE);\r\n // I stole the idea for this from the TortoiseCVS guys (thanks!)\r\n DefaultValue := StrToIntDef(RegReadStringDef(HKCU, HKCU_WINDOWMETRICS, cShellIconSize, '0'), 0);\r\n Result := DefaultValue <> 0;\r\n if Result then\r\n begin\r\n RegWriteString(HKCU, HKCU_WINDOWMETRICS, cShellIconSize, IntToStr(Succ(DefaultValue)));\r\n SendMessage(HWND_BROADCAST, WM_SETTINGCHANGE, SPI_SETNONCLIENTMETRICS, 0);\r\n RegWriteString(HKCU, HKCU_WINDOWMETRICS, cShellIconSize, IntToStr(DefaultValue));\r\n SendMessage(HWND_BROADCAST, WM_SETTINGCHANGE, SPI_SETNONCLIENTMETRICS, 0);\r\n end;\r\nend;\r\n\r\ninitialization\r\n {$IFDEF UNITVERSIONING}\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n {$ENDIF UNITVERSIONING}\r\n\r\nfinalization\r\n UnloadNetLib;\r\n {$IFDEF UNITVERSIONING}\r\n UnregisterUnitVersion(HInstance);\r\n {$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvConnectNetwork.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvConnectNetwork.PAS, released on 2001-02-28.\r\n\r\nThe Initial Developer of the Original Code is Sbastien Buysse [sbuysse att buypin dott com]\r\nPortions created by Sbastien Buysse are Copyright (C) 2001 Sbastien Buysse.\r\nAll Rights Reserved.\r\n\r\nContributor(s): Michael Beck [mbeck att bigfoot dott com].\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvConnectNetwork.pas 13352 2012-06-14 09:21:26Z obones $\r\n\r\nunit JvConnectNetwork;\r\n\r\n{$I jvcl.inc}\r\n{$I windowsonly.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, Classes,\r\n JvBaseDlg;\r\n\r\ntype\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvConnectNetwork = class(TJvCommonDialog)\r\n public\r\n function Execute(ParentWnd: HWND): Boolean; overload; override;\r\n end;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvDisconnectNetwork = class(TJvCommonDialog)\r\n public\r\n function Execute(ParentWnd: HWND): Boolean; overload; override;\r\n end;\r\n\r\n TJvNetworkConnect = class(TJvCommonDialog)\r\n private\r\n FConnect: Boolean;\r\n public\r\n property Connect: Boolean read FConnect write FConnect;\r\n function Execute(ParentWnd: HWND): Boolean; overload; override;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvConnectNetwork.pas $';\r\n Revision: '$Revision: 13352 $';\r\n Date: '$Date: 2012-06-14 11:21:26 +0200 (jeu. 14 juin 2012) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\n\r\nfunction TJvConnectNetwork.Execute(ParentWnd: HWND): Boolean;\r\nbegin\r\n Result := WNetConnectionDialog(ParentWnd, RESOURCETYPE_DISK) = NO_ERROR;\r\nend;\r\n\r\nfunction TJvDisconnectNetwork.Execute(ParentWnd: HWND): Boolean;\r\nbegin\r\n Result := WNetDisconnectDialog(ParentWnd, RESOURCETYPE_DISK) = NO_ERROR;\r\nend;\r\n\r\nfunction TJvNetworkConnect.Execute(ParentWnd: HWND): Boolean;\r\nbegin\r\n if FConnect then\r\n Result := WNetConnectionDialog(ParentWnd, RESOURCETYPE_DISK) = NO_ERROR\r\n else\r\n Result := WNetDisconnectDialog(ParentWnd, RESOURCETYPE_DISK) = NO_ERROR;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvConsts.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvConst.PAS, released on 2002-07-04.\r\n\r\nThe Initial Developers of the Original Code are: Fedor Koshevnikov, Igor Pavluk and Serge Korolev\r\nCopyright (c) 1997, 1998 Fedor Koshevnikov, Igor Pavluk and Serge Korolev\r\nCopyright (c) 2001,2002 SGB Software\r\nAll Rights Reserved.\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvConsts.pas 13415 2012-09-10 09:51:54Z obones $\r\n\r\nunit JvConsts;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n SysUtils, Classes, Forms, Controls, Graphics, Windows, TypInfo;\r\n\r\nconst\r\n { JvEditor }\r\n JvEditorCompletionChars = #8'0123456789QWERTYUIOPASDFGHJKLZXCVBNMqwertyuiopasdfghjklzxcvbnm';\r\n\r\n { Various units }\r\n DigitSymbols = ['0'..'9'];\r\n SignSymbols = ['+', '-'];\r\n IdentifierUppercaseLetters = ['A'..'Z'];\r\n IdentifierLowercaseLetters = ['a'..'z'];\r\n HexadecimalUppercaseLetters = ['A'..'F'];\r\n HexadecimalLowercaseLetters = ['a'..'f'];\r\n IdentifierLetters = IdentifierUppercaseLetters + IdentifierLowercaseLetters;\r\n IdentifierFirstSymbols = ['_'] + IdentifierLetters;\r\n IdentifierSymbols = IdentifierFirstSymbols + DigitSymbols;\r\n HexadecimalSymbols = DigitSymbols + HexadecimalUppercaseLetters + HexadecimalLowercaseLetters;\r\n\r\n {$IFDEF DELPHI6}\r\n SDelphiKey = 'Software\\Borland\\Delphi\\6.0';\r\n {$ENDIF DELPHI6}\r\n {$IFDEF BCB6}\r\n SDelphiKey = 'Software\\Borland\\C++Builder\\6.0';\r\n {$ENDIF BCB6}\r\n {$IFDEF DELPHI7}\r\n SDelphiKey = 'Software\\Borland\\Delphi\\7.0';\r\n {$ENDIF DELPHI7}\r\n {$IFDEF DELPHI8}\r\n SDelphiKey = 'Software\\Borland\\BDS\\2.0';\r\n {$ENDIF DELPHI8}\r\n {$IFDEF DELPHI9}\r\n SDelphiKey = 'Software\\Borland\\BDS\\3.0';\r\n {$ENDIF DELPHI9}\r\n {$IFDEF DELPHI10}\r\n SDelphiKey = 'Software\\Borland\\BDS\\4.0';\r\n {$ENDIF DELPHI10}\r\n {$IFDEF DELPHI11}\r\n SDelphiKey = 'Software\\Borland\\BDS\\5.0';\r\n {$ENDIF DELPHI11}\r\n {$IFDEF DELPHI12}\r\n SDelphiKey = 'Software\\CodeGear\\BDS\\6.0';\r\n {$ENDIF DELPHI12}\r\n {$IFDEF DELPHI14}\r\n SDelphiKey = 'Software\\CodeGear\\BDS\\7.0';\r\n {$ENDIF DELPHI14}\r\n {$IFDEF DELPHI15}\r\n SDelphiKey = 'Software\\Embarcadero\\BDS\\8.0';\r\n {$ENDIF DELPHI15}\r\n {$IFDEF DELPHI16}\r\n SDelphiKey = 'Software\\Embarcadero\\BDS\\9.0';\r\n {$ENDIF DELPHI16}\r\n {$IFDEF DELPHI17}\r\n SDelphiKey = 'Software\\Embarcadero\\BDS\\10.0';\r\n {$ENDIF DELPHI17}\r\n { JvDataProvider constants }\r\n { Consumer attributes }\r\n DPA_RenderDisabledAsGrayed = 1;\r\n DPA_RendersSingleItem = 2;\r\n DPA_ConsumerDisplaysList = 3;\r\n\r\n { Command message constants. Define the JVCL base at 512 from the command message base. This gives the VCL room to\r\n grow another 430 or so messages before interfering with us. It will give us room for 512 constants before we'd\r\n interfere with the action manager constants. }\r\n CM_JVBASE = CM_BASE + $0200;\r\n\r\n { Define command message that did not exist in earlier VCL versions }\r\n {$IFNDEF COMPILER9_UP}\r\n CM_INVALIDATEDOCKHOST = CM_BASE + 70;\r\n {$ENDIF !COMPILER9_UP}\r\n\r\n { Command message for JvSpeedbar editor }\r\n CM_SPEEDBARCHANGED = CM_JVBASE + $000;\r\n { Command message for TJvSpeedButton }\r\n CM_JVBUTTONPRESSED = CM_JVBASE + $001;\r\n { Command messages for TJvBackground }\r\n CM_RECREATEWINDOW = CM_JVBASE + $002;\r\n CM_RELEASECLIENTLINK = CM_JVBASE + $003;\r\n { Command message used in JvProgressComponent }\r\n CM_SHOWEVENT = CM_JVBASE + $004;\r\n CM_CLOSEEVENT = CM_JVBASE + $005;\r\n { Command messages used in TJvColorButton, TJvOfficeColorButton and TJvCustomComboEdit }\r\n CM_POPUPCLOSEUP = CM_JVBASE + $006;\r\n CM_FIXCARETPOSITION = CM_JVBASE + $007;\r\n { Command messages used in JvButton }\r\n CM_FORCESIZE = CM_JVBASE + $008;\r\n { Command message used in JvEditorCommon }\r\n CM_RESETCAPTURECONTROL = CM_JVBASE + $009;\r\n { Command messages used in JvExControls }\r\n CM_PERFORM = CM_JVBASE + $00A; // LParam: \"Msg: ^TMessage\"\r\n CM_SETAUTOSIZE = CM_JVBASE + $00B; // WParam: \"Value: Boolean\"\r\n { Command messages used in JvLookOut }\r\n CM_IMAGESIZECHANGED = CM_JVBASE + $00C;\r\n CM_LEAVEBUTTON = CM_JVBASE + $00D;\r\n { Command messages used in JvNavigationPane }\r\n CM_PARENTSTYLEMANAGERCHANGE = CM_JVBASE + $00E;\r\n CM_PARENTSTYLEMANAGERCHANGED = CM_JVBASE + $00F;\r\n { Command messages used in JvOutlookBar }\r\n CM_CAPTION_EDITING = CM_JVBASE + $010;\r\n CM_CAPTION_EDIT_ACCEPT = CM_JVBASE + $011;\r\n CM_CAPTION_EDIT_CANCEL = CM_JVBASE + $012;\r\n { Command message used in JvTimeLine }\r\n CM_MOVEDRAGLINE = CM_JVBASE + $013;\r\n\r\n { Values for WParam for CM_SPEEDBARCHANGED message }\r\n SBR_CHANGED = 0; { change buttons properties }\r\n SBR_DESTROYED = 1; { destroy SpeedBar }\r\n SBR_BTNSELECT = 2; { select button in SpeedBar }\r\n SBR_BTNSIZECHANGED = 3; { button size changed }\r\n\r\n { TBitmap.GetTransparentColor from GRAPHICS.PAS use this value }\r\n PaletteMask = $02000000;\r\n\r\n // (outchy) now used\r\n {$IFDEF COMPILER7_UP}\r\n // (outchy) it was defined as $000000FF\r\n DEFAULT_SYSCOLOR_MASK = clSystemColor; // $FF000000\r\n {$ELSE}\r\n DEFAULT_SYSCOLOR_MASK = $80000000;\r\n {$ENDIF COMPILER7_UP}\r\n\r\n sLineBreakStr = string(sLineBreak); // \"native string\" line break constant\r\n sLineBreakLen = Length(sLineBreak);\r\n\r\n CrLf = #13#10;\r\n Cr = #13;\r\n Lf = #10;\r\n Backspace = #8;\r\n Tab = #9;\r\n Esc = #27;\r\n Del = #127;\r\n CtrlC = ^C;\r\n CtrlH = ^H;\r\n CtrlI = ^I;\r\n CtrlJ = ^J;\r\n CtrlM = ^M;\r\n CtrlV = ^V;\r\n CtrlX = ^X;\r\n {$IFDEF MSWINDOWS}\r\n RegPathDelim = '\\';\r\n PathDelim = '\\';\r\n DriveDelim = ':';\r\n PathSep = ';';\r\n AllFilePattern = '*.*';\r\n {$ENDIF MSWINDOWS}\r\n {$IFDEF UNIX}\r\n RegPathDelim = '_';\r\n PathDelim = '/';\r\n AllFilePattern = '*';\r\n {$ENDIF UNIX}\r\n\r\n {const Separators is used in GetWordOnPos, JvUtils.ReplaceStrings and SubWord}\r\n Separators: TSysCharSet = [#00, ' ', '-', #13, #10, '.', ',', '/', '\\', '#', '\"', '''',\r\n ':', '+', '%', '*', '(', ')', ';', '=', '{', '}', '[', ']', '{', '}', '<', '>'];\r\n\r\n DigitChars = ['0'..'9'];\r\n\r\nvar\r\n crJVCLFirst: TCursor = 368;\r\n crMultiDragLink: TCursor = 368;\r\n crDragAlt: TCursor = 369;\r\n crMultiDragAlt: TCursor = 370;\r\n crMultiDragLinkAlt: TCursor = 371;\r\n crHand: TCursor = 372;\r\n crDragHand: TCursor = 373;\r\n // this should be incremented to always contain the last default JVCL cursor index\r\n crJVCLLast: TCursor = 373;\r\n\r\nconst\r\n ROP_DSPDxax = $00E20746;\r\n\r\nconst\r\n FOURCC_ACON = 'ACON';\r\n FOURCC_IART = 'IART';\r\n FOURCC_INAM = 'INAM';\r\n FOURCC_INFO = 'INFO';\r\n FOURCC_LIST = 'LIST';\r\n FOURCC_RIFF = 'RIFF';\r\n FOURCC_anih = 'anih';\r\n FOURCC_fram = 'fram';\r\n FOURCC_icon = 'icon';\r\n FOURCC_rate = 'rate';\r\n FOURCC_seq = 'seq ';\r\n\r\n AF_ICON = $00000001;\r\n AF_SEQUENCE = $00000002;\r\n\r\nconst\r\n KeyboardShiftStates = [ssShift, ssAlt, ssCtrl];\r\n MouseShiftStates = [ssLeft, ssRight, ssMiddle, ssDouble];\r\n tkStrings: set of TTypeKind = [tkString, tkLString, {$IFDEF UNICODE} tkUString, {$ENDIF} tkWString];\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvConsts.pas $';\r\n Revision: '$Revision: 13415 $';\r\n Date: '$Date: 2012-09-10 11:51:54 +0200 (lun. 10 sept. 2012) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n\r\n" }, { "path": "External/Jedi/Jvcl/run/JvContentScroller.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvCntScr.PAS, released on 2002-05-26.\r\n\r\nThe Initial Developer of the Original Code is Peter Thrnqvist [peter3 at sourceforge dot net]\r\nPortions created by Peter Thrnqvist are Copyright (C) 2002 Peter Thrnqvist.\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nDescription:\r\n A TCustomPanel descendant that can scroll its content.\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvContentScroller.pas 13104 2011-09-07 06:50:43Z obones $\r\n\r\nunit JvContentScroller;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n SysUtils, Classes, ExtCtrls,\r\n JvExtComponent;\r\n\r\ntype\r\n TJvContentScrollDirection = (sdUp, sdDown, sdLeft, sdRight);\r\n TJvScrollAmount = 1..MaxInt;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvContentScroller = class(TJvCustomPanel)\r\n private\r\n FTimer: TTimer;\r\n FActive: Boolean;\r\n FYPosition: Integer;\r\n FXPosition: Integer;\r\n FScrollAmount: TJvScrollAmount;\r\n FScrollIntervall: TJvScrollAmount;\r\n FMediaFile: TFileName;\r\n FOnBeforeScroll: TNotifyEvent;\r\n FOnAfterScroll: TNotifyEvent;\r\n FLoopMedia: Boolean;\r\n FScrollLength: TJvScrollAmount;\r\n FScrollDirection: TJvContentScrollDirection;\r\n FLoopCount: Integer;\r\n FCurLoop: Integer;\r\n // FScrollStart: Integer;\r\n procedure SetActive(Value: Boolean);\r\n procedure SetScrollAmount(Value: TJvScrollAmount);\r\n procedure SetScrollIntervall(Value: TJvScrollAmount);\r\n procedure SetMediaFile(Value: TFileName);\r\n procedure DoTimer(Sender: TObject);\r\n procedure CreateTimer;\r\n procedure FreeTimer;\r\n procedure SetLoopMedia(Value: Boolean);\r\n procedure SetScrollLength(Value: TJvScrollAmount);\r\n procedure SetScrollDirection(Value: TJvContentScrollDirection);\r\n procedure SetLoopCount(Value: Integer);\r\n protected\r\n procedure Paint; override;\r\n procedure DoBeforeScroll; dynamic;\r\n procedure DoAfterScroll; dynamic;\r\n procedure CreateWnd; override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n procedure ScrollContent(Amount: TJvScrollAmount);\r\n published\r\n property Active: Boolean read FActive write SetActive;\r\n property ScrollAmount: TJvScrollAmount read FScrollAmount write SetScrollAmount default 10;\r\n property ScrollIntervall: TJvScrollAmount read FScrollIntervall write SetScrollIntervall default 50;\r\n property ScrollLength: TJvScrollAmount read FScrollLength write SetScrollLength default 250;\r\n property ScrollDirection: TJvContentScrollDirection read FScrollDirection write SetScrollDirection default sdUp;\r\n {$IFDEF MSWINDOWS}\r\n property MediaFile: TFileName read FMediaFile write SetMediaFile;\r\n property LoopMedia: Boolean read FLoopMedia write SetLoopMedia default True;\r\n property LoopCount: Integer read FLoopCount write SetLoopCount default -1;\r\n {$ENDIF MSWINDOWS}\r\n property BiDiMode;\r\n property DockSite;\r\n property DragKind;\r\n property FullRepaint;\r\n property ParentBiDiMode;\r\n property UseDockManager;\r\n property DragCursor;\r\n property OnCanResize;\r\n property OnDockDrop;\r\n property OnDockOver;\r\n property OnEndDock;\r\n property OnGetSiteInfo;\r\n property OnStartDock;\r\n property OnUnDock;\r\n property Action;\r\n property Anchors;\r\n property Constraints;\r\n property Align;\r\n property BorderStyle;\r\n property BorderWidth;\r\n property DragMode;\r\n property Enabled;\r\n property HelpContext;\r\n property Hint;\r\n property Color;\r\n property Cursor;\r\n property ParentColor;\r\n property ParentShowHint;\r\n property PopupMenu;\r\n property ShowHint;\r\n property TabOrder;\r\n property TabStop;\r\n property Tag;\r\n property Visible;\r\n property OnAfterScroll: TNotifyEvent read FOnAfterScroll write FOnAfterScroll;\r\n property OnBeforeScroll: TNotifyEvent read FOnBeforeScroll write FOnBeforeScroll;\r\n property OnConstrainedResize;\r\n property OnClick;\r\n property OnDblClick;\r\n property OnDragDrop;\r\n property OnDragOver;\r\n property OnEndDrag;\r\n property OnEnter;\r\n property OnExit;\r\n property OnKeyDown;\r\n property OnKeyUp;\r\n property OnKeyPress;\r\n property OnMouseMove;\r\n property OnMouseDown;\r\n property OnMouseUp;\r\n property OnResize;\r\n property OnStartDrag;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvContentScroller.pas $';\r\n Revision: '$Revision: 13104 $';\r\n Date: '$Date: 2011-09-07 08:50:43 +0200 (mer. 07 sept. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n {$IFDEF MSWINDOWS}\r\n MMSystem,\r\n {$ENDIF MSWINDOWS}\r\n Graphics, Controls;\r\n\r\nconstructor TJvContentScroller.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n BevelInner := bvNone;\r\n BevelOuter := bvNone;\r\n ParentColor := True;\r\n FScrollAmount := 10;\r\n FScrollIntervall := 50;\r\n FScrollLength := 250;\r\n FScrollDirection := sdUp;\r\n FLoopMedia := True;\r\n FLoopCount := -1;\r\nend;\r\n\r\ndestructor TJvContentScroller.Destroy;\r\nbegin\r\n FreeTimer;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvContentScroller.CreateTimer;\r\nvar\r\n Flag: Integer;\r\nbegin\r\n if not Assigned(FTimer) then\r\n FTimer := TTimer.Create(nil);\r\n\r\n FYPosition := 0;\r\n FXPosition := 0;\r\n FTimer.Enabled := False;\r\n FTimer.OnTimer := DoTimer;\r\n FTimer.Interval := ScrollIntervall;\r\n FTimer.Enabled := True;\r\n {$IFDEF MSWINDOWS}\r\n Flag := SND_ASYNC or SND_FILENAME;\r\n if FLoopMedia then\r\n Flag := Flag or SND_LOOP;\r\n if FileExists(FMediaFile) then\r\n PlaySound(PChar(FMediaFile), 0, Flag);\r\n {$ENDIF MSWINDOWS}\r\n FCurLoop := FLoopCount;\r\nend;\r\n\r\nprocedure TJvContentScroller.FreeTimer;\r\nbegin\r\n if Assigned(FTimer) then\r\n begin\r\n FTimer.Enabled := False;\r\n FTimer.OnTimer := nil;\r\n FTimer.Free;\r\n FTimer := nil;\r\n end;\r\n\r\n case FScrollDirection of\r\n sdUp:\r\n ScrollBy(0, FYPosition);\r\n sdDown:\r\n ScrollBy(0, -FYPosition);\r\n sdLeft:\r\n ScrollBy(FXPosition, 0);\r\n sdRight:\r\n ScrollBy(-FXPosition, 0);\r\n end;\r\n\r\n FYPosition := 0;\r\n FXPosition := 0;\r\n {$IFDEF MSWINDOWS}\r\n if FileExists(FMediaFile) then\r\n PlaySound(nil, 0, SND_ASYNC);\r\n {$ENDIF MSWINDOWS}\r\nend;\r\n\r\nprocedure TJvContentScroller.DoTimer(Sender: TObject);\r\nvar\r\n B: Boolean;\r\nbegin\r\n B := FTimer.Enabled;\r\n FTimer.Enabled := False;\r\n try\r\n FTimer.Interval := ScrollIntervall;\r\n DoBeforeScroll;\r\n ScrollContent(FScrollAmount);\r\n DoAfterScroll;\r\n finally\r\n if Assigned(FTimer) then\r\n FTimer.Enabled := B;\r\n end;\r\nend;\r\n\r\nprocedure TJvContentScroller.DoAfterScroll;\r\nbegin\r\n if Assigned(FOnAfterScroll) then\r\n FOnAfterScroll(Self);\r\nend;\r\n\r\nprocedure TJvContentScroller.DoBeforeScroll;\r\nbegin\r\n if Assigned(FOnBeforeScroll) then\r\n FOnBeforeScroll(Self);\r\nend;\r\n\r\nprocedure TJvContentScroller.ScrollContent(Amount: TJvScrollAmount);\r\nvar\r\n DeltaY: Integer;\r\n DeltaX: Integer;\r\nbegin\r\n DisableAlign;\r\n try\r\n if ((FScrollDirection in [sdUp, sdDown]) and (FYPosition = 0)) or \r\n ((FScrollDirection in [sdLeft, sdRight]) and (FXPosition = 0)) then\r\n begin\r\n if FCurLoop = 0 then\r\n Active := False\r\n else\r\n if FCurLoop > 0 then\r\n Dec(FCurLoop);\r\n end;\r\n\r\n // Set to 0 to avoid warning\r\n DeltaX := 0;\r\n DeltaY := 0;\r\n case FScrollDirection of\r\n sdUp:\r\n begin\r\n if FYPosition >= FScrollLength then\r\n begin\r\n DeltaY := FScrollLength + Height;\r\n FYPosition := -Height;\r\n ScrollBy(0, DeltaY);\r\n end;\r\n DeltaY := -Amount;\r\n end;\r\n sdDown:\r\n begin\r\n if FYPosition >= Height then\r\n begin\r\n DeltaY := -FYPosition - FScrollLength;\r\n FYPosition := -FScrollLength;\r\n ScrollBy(0, DeltaY);\r\n end;\r\n DeltaY := Amount;\r\n end;\r\n sdLeft:\r\n begin\r\n if FXPosition >= FScrollLength then\r\n begin\r\n DeltaX := FScrollLength + Width;\r\n FXPosition := -Width;\r\n ScrollBy(DeltaX, 0);\r\n end;\r\n DeltaX := -Amount;\r\n end;\r\n sdRight:\r\n begin\r\n if FXPosition >= Width then\r\n begin\r\n DeltaX := -FXPosition - FScrollLength;\r\n FXPosition := -FScrollLength;\r\n ScrollBy(DeltaX, 0);\r\n end;\r\n DeltaX := Amount;\r\n end;\r\n end;\r\n\r\n if Active then\r\n begin\r\n ScrollBy(DeltaX, DeltaY);\r\n \r\n FXPosition := FXPosition + Abs(DeltaX);\r\n FYPosition := FYPosition + Abs(DeltaY);\r\n end;\r\n finally\r\n EnableAlign;\r\n end;\r\nend;\r\n\r\nprocedure TJvContentScroller.SetActive(Value: Boolean);\r\nbegin\r\n if FActive <> Value then\r\n begin\r\n FActive := Value;\r\n if not FActive then\r\n FreeTimer\r\n else\r\n CreateTimer;\r\n end;\r\nend;\r\n\r\nprocedure TJvContentScroller.SetScrollAmount(Value: TJvScrollAmount);\r\nbegin\r\n FScrollAmount := Value;\r\nend;\r\n\r\nprocedure TJvContentScroller.SetScrollIntervall(Value: TJvScrollAmount);\r\nbegin\r\n FScrollIntervall := Value;\r\nend;\r\n\r\nprocedure TJvContentScroller.SetMediaFile(Value: TFileName);\r\nbegin\r\n FMediaFile := Value;\r\nend;\r\n\r\nprocedure TJvContentScroller.SetLoopMedia(Value: Boolean);\r\nbegin\r\n FLoopMedia := Value;\r\nend;\r\n\r\nprocedure TJvContentScroller.SetScrollLength(Value: TJvScrollAmount);\r\nbegin\r\n FScrollLength := Value;\r\nend;\r\n\r\nprocedure TJvContentScroller.SetScrollDirection(Value: TJvContentScrollDirection);\r\nbegin\r\n if (FScrollDirection <> Value) then\r\n begin\r\n case FScrollDirection of\r\n sdUp: \r\n if Value = sdDown then\r\n FYPosition := -FYPosition;\r\n sdDown:\r\n if Value = sdUp then\r\n FYPosition := -FYPosition;\r\n sdLeft:\r\n if Value = sdRight then\r\n FXPosition := -FXPosition;\r\n sdRight:\r\n if Value = sdLeft then\r\n FXPosition := -FXPosition;\r\n end;\r\n \r\n FScrollDirection := Value;\r\n end;\r\nend;\r\n\r\nprocedure TJvContentScroller.SetLoopCount(Value: Integer);\r\nbegin\r\n if FLoopCount <> Value then\r\n begin\r\n FLoopCount := Value;\r\n if (FLoopCount > -1) and (FScrollLength mod FScrollAmount <> 0) then\r\n FScrollLength := FScrollLength - (FScrollLength mod FScrollAmount) + FScrollAmount;\r\n end;\r\nend;\r\n\r\n\r\nprocedure TJvContentScroller.CreateWnd;\r\nbegin\r\n inherited CreateWnd;\r\n Caption := '';\r\nend;\r\n\r\nprocedure TJvContentScroller.Paint;\r\nbegin\r\n inherited Paint;\r\n if csDesigning in ComponentState then\r\n with Canvas do\r\n begin\r\n Pen.Style := psDash;\r\n Brush.Style := bsClear;\r\n Rectangle(0, 0, Width, Height);\r\n end;\r\nend;\r\n\r\n\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvContextProvider.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvContextProvider.pas, released on 2003-07-18.\r\n\r\nThe Initial Developer of the Original Code is Marcel Bestebroer\r\nPortions created by Marcel Bestebroer are Copyright (C) 2002 - 2003 Marcel\r\nBestebroer\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvContextProvider.pas 13104 2011-09-07 06:50:43Z obones $\r\n\r\nunit JvContextProvider;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Classes,\r\n JvDataProvider, JvDataProviderIntf;\r\n\r\ntype\r\n { Context provider related interfaces. }\r\n IJvDataContextProvider = interface\r\n ['{78EB1037-11A5-4871-8115-4AE1AC60B59C}']\r\n function Get_ClientProvider: IJvDataProvider;\r\n procedure Set_ClientProvider(Value: IJvDataProvider);\r\n property ClientProvider: IJvDataProvider read Get_ClientProvider write Set_ClientProvider;\r\n end;\r\n\r\n IJvDataContextSearch = interface\r\n ['{C8513B84-FAA0-4794-A4A9-B2899797F52B}']\r\n function Find(Context: IJvDataContext; const Recursive: Boolean = False): IJvDataItem;\r\n function FindByName(Name: string; const Recursive: Boolean = False): IJvDataItem;\r\n end;\r\n\r\n IJvDataContextItems = interface\r\n ['{3303276D-2596-4FDB-BA1C-CE6E043BEB7A}']\r\n function GetContexts: IJvDataContexts;\r\n end;\r\n\r\n IJvDataContextItem = interface\r\n ['{7156CAC8-0DB9-43B7-96C5-5A56723C5158}']\r\n function GetContext: IJvDataContext;\r\n end;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64 or pidOSX32)]\r\n {$ENDIF RTL230_UP}\r\n TJvContextProvider = class(TJvCustomDataProvider, IJvDataContextProvider)\r\n function IJvDataContextProvider.Get_ClientProvider = GetProviderIntf;\r\n procedure IJvDataContextProvider.Set_ClientProvider = SetProviderIntf;\r\n private\r\n function GetProviderIntf: IJvDataProvider;\r\n procedure SetProviderIntf(Value: IJvDataProvider);\r\n function GetProviderComp: TComponent;\r\n procedure SetProviderComp(Value: TComponent);\r\n protected\r\n class function ItemsClass: TJvDataItemsClass; override;\r\n function ConsumerClasses: TClassArray; override;\r\n public\r\n property ProviderComp: TComponent read GetProviderComp write SetProviderComp;\r\n property ProviderIntf: IJvDataProvider read GetProviderIntf write SetProviderIntf;\r\n published\r\n property Provider: IJvDataProvider read GetProviderIntf write SetProviderIntf;\r\n end;\r\n\r\n TJvContextProviderServerNotify = class(TJvDataConsumerServerNotify)\r\n protected\r\n procedure ItemSelected(Value: IJvDataItem); override;\r\n function IsValidClient(Client: IJvDataConsumerClientNotify): Boolean; override;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvContextProvider.pas $';\r\n Revision: '$Revision: 13104 $';\r\n Date: '$Date: 2011-09-07 08:50:43 +0200 (mer. 07 sept. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n SysUtils,\r\n JvTypes, JvResources;\r\n\r\ntype\r\n TContextItems = class;\r\n TContextRootItems = class;\r\n TContextItem = class;\r\n TContextItemsManager = class;\r\n\r\n TContextItems = class(TJvBaseDataItems, IJvDataContextItems, IJvDataContextSearch)\r\n protected\r\n function GetContexts: IJvDataContexts; virtual;\r\n function Find(Context: IJvDataContext; const Recursive: Boolean = False): IJvDataItem;\r\n function FindByName(Name: string; const Recursive: Boolean = False): IJvDataItem;\r\n procedure InitImplementers; override;\r\n function GetCount: Integer; override;\r\n function GetItem(I: Integer): IJvDataItem; override;\r\n end;\r\n\r\n TContextRootItems = class(TContextItems)\r\n private\r\n FClientProvider: IJvDataProvider;\r\n FNotifier: TJvProviderNotification;\r\n procedure SetClientProvider(Value: IJvDataProvider);\r\n procedure DataProviderChanging(ADataProvider: IJvDataProvider;\r\n AReason: TDataProviderChangeReason; Source: IUnknown);\r\n procedure DataProviderChanged(ADataProvider: IJvDataProvider;\r\n AReason: TDataProviderChangeReason; Source: IUnknown);\r\n protected\r\n function GetContexts: IJvDataContexts; override;\r\n public\r\n constructor Create; override;\r\n destructor Destroy; override;\r\n property ClientProvider: IJvDataProvider read FClientProvider write SetClientProvider;\r\n end;\r\n\r\n TContextItem = class(TJvBaseDataItem, IJvDataItemText, IJvDataContextItem)\r\n private\r\n FContext: IJvDataContext;\r\n { IContextItem methods }\r\n function GetContext: IJvDataContext;\r\n { IJvDataItemText methods }\r\n function GetText: string;\r\n procedure SetText(const Value: string);\r\n function Editable: Boolean;\r\n protected\r\n procedure InitID; override;\r\n function IsDeletable: Boolean; override;\r\n constructor CreateCtx(AOwner: IJvDataItems; AContext: IJvDataContext);\r\n public\r\n property Context: IJvDataContext read GetContext;\r\n end;\r\n\r\n TContextItemsManager = class(TJvBaseDataItemsManagement)\r\n protected\r\n function GetContexts: IJvDataContexts;\r\n { IJvDataItemManagement methods }\r\n function Add(Item: IJvDataItem): IJvDataItem; override;\r\n function New: IJvDataItem; override;\r\n procedure Clear; override;\r\n procedure Delete(Index: Integer); override;\r\n procedure Remove(var Item: IJvDataItem); override;\r\n end;\r\n\r\n//=== { TContextItems } ======================================================\r\n\r\nfunction TContextItems.GetContexts: IJvDataContexts;\r\nvar\r\n ParentCtx: IJvDataContext;\r\nbegin\r\n if GetParent <> nil then\r\n begin\r\n if Supports(GetParent, IJvDataContext, ParentCtx) then\r\n Supports(ParentCtx, IJvDataContexts, Result);\r\n end\r\n else\r\n Result := nil;\r\nend;\r\n\r\nfunction TContextItems.Find(Context: IJvDataContext; const Recursive: Boolean = False): IJvDataItem;\r\nvar\r\n CtxStack: array of IJvDataContext;\r\n CtxIdx: Integer;\r\nbegin\r\n if Context <> nil then\r\n begin\r\n if Context.Contexts = GetContexts then\r\n Result := TContextItem.CreateCtx(Self, Context)\r\n else\r\n if Recursive then\r\n begin\r\n SetLength(CtxStack, 128); // reserve some space; should be enough for most situations\r\n CtxIdx := 0;\r\n while (Context <> nil) and (Context.Contexts <> GetContexts) do\r\n begin\r\n if CtxIdx = Length(CtxStack) then\r\n SetLength(CtxStack, CtxIdx + 128);\r\n CtxStack[CtxIdx] := Context;\r\n Inc(CtxIdx);\r\n Context := Context.Contexts.Ancestor;\r\n end;\r\n if Context <> nil then\r\n begin\r\n // unwind the stack to create the actual data item\r\n Result := TContextItem.CreateCtx(Self, Context);\r\n Dec(CtxIdx);\r\n while (CtxIdx >= 0) do\r\n begin\r\n Result := TContextItem.CreateCtx(Result.GetItems, CtxStack[CtxIdx]);\r\n Dec(CtxIdx);\r\n end;\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TContextItems.FindByName(Name: string; const Recursive: Boolean = False): IJvDataItem;\r\nvar\r\n CtxList: IJvDataContexts;\r\n Ctx: IJvDataContext;\r\n I: Integer;\r\n CtxSubList: IJvDataContexts;\r\nbegin\r\n //TODO: Recursive only checks one level deep!!\r\n CtxList := GetContexts;\r\n if CtxList <> nil then\r\n begin\r\n Ctx := CtxList.GetContextByName(Name);\r\n if (Ctx = nil) and (Recursive) then\r\n begin\r\n I := 0;\r\n while I <= CtxList.GetCount do\r\n begin\r\n Ctx := CtxList.GetContext(I);\r\n if Supports(Ctx, IJvDataContexts, CtxSubList) then\r\n begin\r\n Ctx := CtxSubList.GetContextByName(Name);\r\n if Ctx <> nil then\r\n Break;\r\n end\r\n else\r\n Ctx := nil;\r\n Inc(I);\r\n end;\r\n end;\r\n if Ctx <> nil then\r\n Result := TContextItem.CreateCtx(Self, Ctx);\r\n end;\r\nend;\r\n\r\nprocedure TContextItems.InitImplementers;\r\nvar\r\n CtxList: IJvDataContexts;\r\n CtxMan: IJvDataContextsManager;\r\nbegin\r\n CtxList := GetContexts;\r\n if (CtxList <> nil) and Supports(CtxList, IJvDataContextsManager, CtxMan) then\r\n TContextItemsManager.Create(Self);\r\nend;\r\n\r\nfunction TContextItems.GetCount: Integer;\r\nvar\r\n ParentCtxList: IJvDataContexts;\r\nbegin\r\n ParentCtxList := GetContexts;\r\n if ParentCtxList <> nil then\r\n Result := ParentCtxList.GetCount\r\n else\r\n Result := 0;\r\nend;\r\n\r\nfunction TContextItems.GetItem(I: Integer): IJvDataItem;\r\nvar\r\n CtxList: IJvDataContexts;\r\nbegin\r\n CtxList := GetContexts;\r\n if CtxList <> nil then\r\n Result := TContextItem.CreateCtx(Self, CtxList.GetContext(I));\r\nend;\r\n\r\n//=== { TContextRootItems } ==================================================\r\n\r\nconstructor TContextRootItems.Create;\r\nbegin\r\n inherited Create;\r\n FNotifier := TJvProviderNotification.Create;\r\n FNotifier.OnChanging := DataProviderChanging;\r\n FNotifier.OnChanged := DataProviderChanged;\r\nend;\r\n\r\ndestructor TContextRootItems.Destroy;\r\nbegin\r\n FreeAndNil(FNotifier);\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TContextRootItems.SetClientProvider(Value: IJvDataProvider);\r\nbegin\r\n if Value <> FClientProvider then\r\n begin\r\n GetProvider.Changing(pcrFullRefresh, nil);\r\n FClientProvider := Value;\r\n FNotifier.Provider := Value;\r\n ClearIntfImpl;\r\n if Value <> nil then\r\n InitImplementers;\r\n GetProvider.Changed(pcrFullRefresh, nil);\r\n end;\r\nend;\r\n\r\nprocedure TContextRootItems.DataProviderChanging(ADataProvider: IJvDataProvider;\r\n AReason: TDataProviderChangeReason; Source: IUnknown);\r\nvar\r\n CtxItem: IJvDataItem;\r\n ParentList: IJvDataItems;\r\nbegin\r\n case AReason of\r\n pcrDestroy:\r\n ClientProvider := nil;\r\n pcrContextAdd:\r\n begin\r\n { Source contains the IJvDataContext where the context is added to or nil if the new\r\n context is added to the root. }\r\n if Source <> nil then\r\n begin\r\n CtxItem := Find(IJvDataContext(Source), True);\r\n if CtxItem <> nil then\r\n begin\r\n if not Supports(CtxItem, IJvDataItems, ParentList) then\r\n ParentList := Self;\r\n end\r\n else\r\n ParentList := Self;\r\n end\r\n else\r\n ParentList := Self;\r\n GetProvider.Changing(pcrAdd, ParentList);\r\n end;\r\n pcrContextDelete:\r\n begin\r\n { Source is the IJvDataContext that is about to be destroyed. }\r\n CtxItem := Find(IJvDataContext(Source), True);\r\n GetProvider.Changing(pcrDelete, CtxItem);\r\n end;\r\n pcrContextUpdate:\r\n begin\r\n { Source is the IJvDataContext that is about to be changed. }\r\n CtxItem := Find(IJvDataContext(Source), True);\r\n GetProvider.Changing(pcrUpdateItem, CtxItem);\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TContextRootItems.DataProviderChanged(ADataProvider: IJvDataProvider;\r\n AReason: TDataProviderChangeReason; Source: IUnknown);\r\nvar\r\n CtxItem: IJvDataItem;\r\n ParentList: IJvDataItems;\r\nbegin\r\n case AReason of\r\n pcrContextAdd:\r\n begin\r\n { Source contains the IJvDataContext that was just added. }\r\n CtxItem := Find(IJvDataContext(Source), True);\r\n GetProvider.Changed(pcrAdd, CtxItem);\r\n end;\r\n pcrContextDelete:\r\n begin\r\n { Source is the IJvDataContext from which the item was just removed or nil if the removed\r\n context was at the root. }\r\n if Source <> nil then\r\n begin\r\n CtxItem := Find(IJvDataContext(Source), True);\r\n if CtxItem <> nil then\r\n begin\r\n if not Supports(CtxItem, IJvDataItems, ParentList) then\r\n ParentList := Self;\r\n end\r\n else\r\n ParentList := Self;\r\n end\r\n else\r\n ParentList := Self;\r\n GetProvider.Changed(pcrDelete, ParentList);\r\n end;\r\n pcrContextUpdate:\r\n begin\r\n { Source is the IJvDataContext that has changed. }\r\n CtxItem := Find(IJvDataContext(Source), True);\r\n GetProvider.Changed(pcrUpdateItem, CtxItem);\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TContextRootItems.GetContexts: IJvDataContexts;\r\nvar\r\n ParentCtx: IJvDataContext;\r\nbegin\r\n if GetParent <> nil then\r\n begin\r\n if Supports(GetParent, IJvDataContext, ParentCtx) then\r\n Supports(ParentCtx, IJvDataContexts, Result);\r\n end\r\n else\r\n Supports(ClientProvider, IJvDataContexts, Result);\r\nend;\r\n\r\n//=== { TContextItem } =======================================================\r\n\r\nconstructor TContextItem.CreateCtx(AOwner: IJvDataItems; AContext: IJvDataContext);\r\nbegin\r\n Create(AOwner);\r\n FContext := AContext;\r\nend;\r\n\r\nfunction TContextItem.GetContext: IJvDataContext;\r\nbegin\r\n Result := FContext;\r\nend;\r\n\r\nfunction TContextItem.GetText: string;\r\nbegin\r\n if Context <> nil then\r\n Result := Context.Name\r\n else\r\n Result := RsContextItemEmptyCaption;\r\nend;\r\n\r\nprocedure TContextItem.SetText(const Value: string);\r\nvar\r\n CtxMan: IJvDataContextManager;\r\nbegin\r\n if Context <> nil then\r\n begin\r\n if Supports(Context, IJvDataContextManager, CtxMan) then\r\n begin\r\n if Context.Name <> Value then\r\n begin\r\n GetItems.GetProvider.Changing(pcrUpdateItem, Self as IJvDataItem);\r\n CtxMan.SetName(Value);\r\n GetItems.GetProvider.Changed(pcrUpdateItem, Self as IJvDataItem);\r\n end;\r\n end;\r\n end\r\n else\r\n raise EJVCLException.CreateRes(@RsENoContextAssigned);\r\nend;\r\n\r\nfunction TContextItem.Editable: Boolean;\r\nbegin\r\n Result := True;\r\nend;\r\n\r\nprocedure TContextItem.InitID;\r\nvar\r\n S: string;\r\n Ctx: IJvDataContext;\r\nbegin\r\n S := GetContext.Name;\r\n Ctx := GetContext.Contexts.Ancestor;\r\n while Ctx <> nil do\r\n begin\r\n S := Ctx.Name + '\\' + S;\r\n Ctx := Ctx.Contexts.Ancestor;\r\n end;\r\n SetID('CTX:' + S);\r\nend;\r\n\r\nfunction TContextItem.IsDeletable: Boolean;\r\nbegin\r\n if GetContext <> nil then\r\n Result := GetContext.IsDeletable\r\n else\r\n Result := True;\r\nend;\r\n\r\n//=== { TContextItemsManager } ===============================================\r\n\r\nfunction TContextItemsManager.GetContexts: IJvDataContexts;\r\nvar\r\n ICI: IJvDataContextItems;\r\nbegin\r\n if Supports(Items, IJvDataContextItems, ICI) then\r\n Result := ICI.GetContexts\r\n else\r\n Result := nil;\r\nend;\r\n\r\nfunction TContextItemsManager.Add(Item: IJvDataItem): IJvDataItem;\r\nvar\r\n Contexts: IJvDataContexts;\r\n Mngr: IJvDataContextsManager;\r\n CtxItem: IJvDataContextItem;\r\nbegin\r\n Contexts := GetContexts;\r\n if (Contexts <> nil) and Supports(Contexts, IJvDataContextsManager, Mngr) then\r\n begin\r\n if Supports(Item, IJvDataContextItem, CtxItem) then\r\n Result := Item\r\n else\r\n raise EJVCLException.CreateRes(@RsENoContextItem);\r\n end;\r\nend;\r\n\r\nfunction TContextItemsManager.New: IJvDataItem;\r\nvar\r\n Contexts: IJvDataContexts;\r\n Mngr: IJvDataContextsManager;\r\nbegin\r\n Contexts := GetContexts;\r\n if (Contexts <> nil) and Supports(Contexts, IJvDataContextsManager, Mngr) then\r\n Result := Add(TContextItem.CreateCtx(Items, Mngr.New));\r\nend;\r\n\r\nprocedure TContextItemsManager.Clear;\r\nvar\r\n Contexts: IJvDataContexts;\r\n Mngr: IJvDataContextsManager;\r\nbegin\r\n Contexts := GetContexts;\r\n if (Contexts <> nil) and Supports(Contexts, IJvDataContextsManager, Mngr) then\r\n Mngr.Clear;\r\nend;\r\n\r\nprocedure TContextItemsManager.Delete(Index: Integer);\r\nvar\r\n Item: IJvDataItem;\r\nbegin\r\n Item := Items.GetItem(Index);\r\n if Item <> nil then\r\n Remove(Item);\r\nend;\r\n\r\nprocedure TContextItemsManager.Remove(var Item: IJvDataItem);\r\nvar\r\n Contexts: IJvDataContexts;\r\n Mngr: IJvDataContextsManager;\r\n CtxItem: IJvDataContextItem;\r\n Ctx: IJvDataContext;\r\nbegin\r\n Contexts := GetContexts;\r\n if (Contexts <> nil) and Supports(Contexts, IJvDataContextsManager, Mngr) then\r\n begin\r\n if Supports(Item, IJvDataContextItem, CtxItem) then\r\n begin\r\n Ctx := CtxItem.GetContext;\r\n Item := nil;\r\n CtxItem := nil;\r\n Mngr.Delete(Ctx);\r\n end;\r\n end;\r\nend;\r\n\r\n//=== { TJvContextProvider } =================================================\r\n\r\nfunction TJvContextProvider.GetProviderIntf: IJvDataProvider;\r\nbegin\r\n Result := TContextRootItems(DataItemsImpl).ClientProvider;\r\nend;\r\n\r\nprocedure TJvContextProvider.SetProviderIntf(Value: IJvDataProvider);\r\nbegin\r\n if Value <> ProviderIntf then\r\n TContextRootItems(DataItemsImpl).ClientProvider := Value;\r\nend;\r\n\r\nfunction TJvContextProvider.GetProviderComp: TComponent;\r\nvar\r\n ICR: IInterfaceComponentReference;\r\nbegin\r\n if Supports(ProviderIntf, IInterfaceComponentReference, ICR) then\r\n Result := ICR.GetComponent\r\n else\r\n Result := nil;\r\nend;\r\n\r\nprocedure TJvContextProvider.SetProviderComp(Value: TComponent);\r\nvar\r\n PI: IJvDataProvider;\r\n ICR: IInterfaceComponentReference;\r\nbegin\r\n if (Value = nil) or Supports(Value, IJvDataProvider, PI) then\r\n begin\r\n if (Value = nil) or Supports(Value, IInterfaceComponentReference, ICR) then\r\n ProviderIntf := PI\r\n else\r\n raise EJVCLException.CreateRes(@RsENotSupportedIInterfaceComponentReference);\r\n end\r\n else\r\n raise EJVCLException.CreateRes(@RsENotSupportedIJvDataProvider);\r\nend;\r\n\r\nclass function TJvContextProvider.ItemsClass: TJvDataItemsClass;\r\nbegin\r\n Result := TContextRootItems;\r\nend;\r\n\r\nfunction TJvContextProvider.ConsumerClasses: TClassArray;\r\nbegin\r\n Result := inherited ConsumerClasses;\r\n AddToArray(Result, TJvContextProviderServerNotify);\r\nend;\r\n\r\n//=== { TJvContextProviderServerNotify } =====================================\r\n\r\nprocedure TJvContextProviderServerNotify.ItemSelected(Value: IJvDataItem);\r\nvar\r\n CtxItem: IJvDataContextItem;\r\n Ctx: IJvDataContext;\r\n I: Integer;\r\n ConCtx: IJvDataConsumerContext;\r\nbegin\r\n // First we allow the default behavior to take place\r\n inherited ItemSelected(Value);\r\n // Now we find out which context is selected and update the linked client consumers accordingly.\r\n if Supports(Value, IJvDataContextItem, CtxItem) then\r\n Ctx := CtxItem.GetContext\r\n else\r\n Ctx := nil;\r\n for I := 0 to Clients.Count - 1 do\r\n if Supports(Clients[I], IJvDataConsumerContext, ConCtx) then\r\n ConCtx.SetContext(Ctx);\r\nend;\r\n\r\nfunction TJvContextProviderServerNotify.IsValidClient(Client: IJvDataConsumerClientNotify): Boolean;\r\nvar\r\n ClientProv: IJvDataProvider;\r\n ConsumerProv: IJvDataConsumerProvider;\r\nbegin\r\n { Only allow client consumers whose Provider points to the ClientProvider of the context\r\n provider this consumer is linked to. }\r\n ClientProv := (ConsumerImpl.ProviderIntf as IJvDataContextProvider).ClientProvider;\r\n Result := Supports(Client, IJvDataConsumerProvider, ConsumerProv) and\r\n (ConsumerProv.GetProvider = ClientProv);\r\nend;\r\n\r\ninitialization\r\n {$IFDEF UNITVERSIONING}\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n {$ENDIF UNITVERSIONING}\r\n RegisterClasses([TJvContextProviderServerNotify]);\r\n\r\n\r\n{$IFDEF UNITVERSIONING}\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend." }, { "path": "External/Jedi/Jvcl/run/JvControlActions.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvDBActions.Pas, released on 2007-03-11.\r\n\r\nThe Initial Developer of the Original Code is Jens Fudickar [jens dott fudicker att oratool dott de]\r\nPortions created by Jens Fudickar are Copyright (C) 2002 Jens Fudickar.\r\nAll Rights Reserved.\r\n\r\nContributor(s): -\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvControlActions.pas 13138 2011-10-26 23:17:50Z jfudickar $\r\n\r\nunit JvControlActions;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n {$IFDEF MSWINDOWS}\r\n Windows, ActnList, Graphics,\r\n {$ENDIF MSWINDOWS}\r\n {$IFDEF UNIX}\r\n QActnList, QWindows, QImgList, QGraphics,\r\n {$ENDIF UNIX}\r\n Forms, Controls, Classes, JvActionsEngine, JvControlActionsEngine;\r\n\r\n\r\ntype\r\n\r\n TJvControlActionExecuteEvent = procedure(Sender: TObject; const aOperation: TJvControlActionOperation; const\r\n aActionControl: TControl) of object;\r\n\r\n TJvControlActionCheckEnabledEvent = procedure(aActionControl : TControl; aControlOperation: TJvControlActionOperation;\r\n var aEnabled : Boolean) of object;\r\n\r\n TJvControlBaseAction = class(TJvActionEngineBaseAction)\r\n private\r\n FControlOperation: TJvControlActionOperation;\r\n FOnCheckEnabled: TJvControlActionCheckEnabledEvent;\r\n FOnExecute: TJvControlActionExecuteEvent;\r\n FAfterExecute: TJvControlActionExecuteEvent;\r\n function GetActionControl: TControl;\r\n function GetControlEngine: TJvControlActionEngine;\r\n procedure SetActionControl(const Value: TControl); virtual;\r\n procedure SetControlOperation(const Value: TJvControlActionOperation);\r\n protected\r\n procedure CheckEnabled(var AEnabled: Boolean); override;\r\n function GetEngineList: TJvActionEngineList; override;\r\n procedure SetActionComponent(const Value: TComponent); override;\r\n property ControlEngine: TJvControlActionEngine read GetControlEngine;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n function Execute: Boolean; override;\r\n procedure UpdateTarget(Target: TObject); override;\r\n function HandlesTarget(Target: TObject): Boolean; override;\r\n procedure ExecuteTarget(Target: TObject); override;\r\n property ActionControl: TControl read GetActionControl write SetActionControl;\r\n property ControlOperation: TJvControlActionOperation read FControlOperation write SetControlOperation;\r\n published\r\n property OnCheckEnabled: TJvControlActionCheckEnabledEvent read FOnCheckEnabled write FOnCheckEnabled;\r\n property OnExecute: TJvControlActionExecuteEvent read FOnExecute write FOnExecute;\r\n property AfterExecute: TJvControlActionExecuteEvent read FAfterExecute write FAfterExecute;\r\n end;\r\n\r\n TJvControlCommonAction = class(TJvControlBaseAction)\r\n published\r\n property ControlOperation;\r\n end;\r\n\r\n TJvControlCollapseAction = class (TJvControlBaseAction)\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n published\r\n end;\r\n\r\ntype\r\n TJvControlExpandAction = class(TJvControlBaseAction)\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n published\r\n end;\r\n\r\ntype\r\n TJvControlExportAction = class(TJvControlBaseAction)\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n published\r\n end;\r\n\r\ntype\r\n TJvControlOptimizeColumnsAction = class(TJvControlBaseAction)\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n published\r\n end;\r\n\r\ntype\r\n TJvControlCustomizeColumnsAction = class(TJvControlBaseAction)\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n published\r\n end;\r\n\r\ntype\r\n TJvControlPrintAction = class(TJvControlBaseAction)\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n published\r\n end;\r\n\r\ntype\r\n TJvControlCustomizeAction = class(TJvControlBaseAction)\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n published\r\n end;\r\n\r\ntype\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64 or pidOSX32)]\r\n {$ENDIF RTL230_UP}\r\n TJvControlActionList = class(TJvActionBaseActionList)\r\n //The idea of the Action Classes is to work different type of controls.\r\n //\r\n //Then we have a list of ActionEngines which have the availability to\r\n //validate find for a Component if it is supported or not.\r\n //For each new type of controls with specific need of handles a new Engine\r\n //must be created and registered. An example for these engines can be found\r\n //in \"JvDBActionsEngineControlCxGrid.pas\".\r\n //\r\n //When a ActionComponent is assigned the action tries to find the correct\r\n //engine based on the component and uses the engine for all further operations.\r\n //\r\n //There are two ways to assign a ActionComponent:\r\n //1. Assigning the component to the action list, then all actions in\r\n // this list (which are based on TJvActionEngineBaseAction class)\r\n // gets the ActionComponent assigned also.\r\n //2. Using the active control, like the normal action handling.\r\n published\r\n property ActionComponent;\r\n property OnChangeActionComponent;\r\n end;\r\n\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvControlActions.pas $';\r\n Revision: '$Revision: 13138 $';\r\n Date: '$Date: 2011-10-27 01:17:50 +0200 (jeu. 27 oct. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n SysUtils, Variants, Dialogs;\r\n\r\n//=== { TJvControlBaseAction } ==============================================\r\n\r\nconstructor TJvControlBaseAction.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\nend;\r\n\r\nprocedure TJvControlBaseAction.CheckEnabled(var AEnabled: Boolean);\r\nbegin\r\n if Assigned(fOnCheckEnabled) then\r\n fOnCheckEnabled (ActionControl, ControlOperation, aEnabled);\r\nend;\r\n\r\nfunction TJvControlBaseAction.Execute: Boolean;\r\nbegin\r\n Result := inherited Execute;\r\n if Result and Assigned(FAfterExecute) then\r\n FAfterExecute(Self, ControlOperation, ActionControl)\r\nend;\r\n\r\nprocedure TJvControlBaseAction.ExecuteTarget(Target: TObject);\r\nbegin\r\n if Assigned(FOnExecute) then\r\n FOnExecute(Self, ControlOperation, ActionControl)\r\n else\r\n if Assigned(ControlEngine) then\r\n ControlEngine.ExecuteOperation(ControlOperation, ActionControl)\r\n else\r\n inherited ExecuteTarget(Target);\r\nend;\r\n\r\nfunction TJvControlBaseAction.GetActionControl: TControl;\r\nbegin\r\n Result := TControl(ActionComponent);\r\nend;\r\n\r\nfunction TJvControlBaseAction.GetControlEngine: TJvControlActionEngine;\r\nbegin\r\n Result := TJvControlActionEngine(inherited ControlEngine);\r\nend;\r\n\r\nfunction TJvControlBaseAction.GetEngineList: TJvActionEngineList;\r\nbegin\r\n Result := RegisteredControlActionEngineList;\r\nend;\r\n\r\nfunction TJvControlBaseAction.HandlesTarget(Target: TObject): Boolean;\r\nbegin\r\n if (Target is TWinControl) and TWinControl(Target).Focused then\r\n Result := inherited HandlesTarget(Target)\r\n else\r\n Result := False;\r\nend;\r\n\r\nprocedure TJvControlBaseAction.SetActionComponent(const Value: TComponent);\r\nbegin\r\n inherited SetActionComponent(Value);\r\nend;\r\n\r\nprocedure TJvControlBaseAction.SetActionControl(const Value: TControl);\r\nbegin\r\n ActionComponent := Value;\r\nend;\r\n\r\nprocedure TJvControlBaseAction.SetControlOperation(const Value: TJvControlActionOperation);\r\nbegin\r\n if FControlOperation <> Value then\r\n begin\r\n FControlOperation := Value;\r\n DetectControlEngine(ActionComponent);\r\n end;\r\nend;\r\n\r\nprocedure TJvControlBaseAction.UpdateTarget(Target: TObject);\r\nbegin\r\n Inherited UpdateTarget(Target);\r\n if Assigned(ControlEngine) then\r\n SetEnabled(True)\r\n else\r\n SetEnabled(False);\r\nend;\r\n\r\nconstructor TJvControlCollapseAction.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n ControlOperation := caoCollapse;\r\nend;\r\n\r\nconstructor TJvControlExpandAction.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n ControlOperation := caoExpand;\r\nend;\r\n\r\nconstructor TJvControlExportAction.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n ControlOperation := caoExport;\r\nend;\r\n\r\nconstructor TJvControlOptimizeColumnsAction.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n ControlOperation := caoOptimizeColumns;\r\nend;\r\n\r\nconstructor TJvControlCustomizeColumnsAction.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n ControlOperation := caoCustomizeColumns;\r\nend;\r\n\r\nconstructor TJvControlPrintAction.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n ControlOperation := caoPrint;\r\nend;\r\n\r\nconstructor TJvControlCustomizeAction.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n ControlOperation := caoCustomize;\r\nend;\r\n\r\n\r\ninitialization\r\n {$IFDEF UNITVERSIONING}\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n {$ENDIF UNITVERSIONING}\r\n\r\nfinalization\r\n {$IFDEF UNITVERSIONING}\r\n UnregisterUnitVersion(HInstance);\r\n {$ENDIF UNITVERSIONING}\r\n\r\nend." }, { "path": "External/Jedi/Jvcl/run/JvControlActionsEngine.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvControlActionsEngine.Pas, released on 2007-03-11.\r\n\r\nThe Initial Developer of the Original Code is Jens Fudickar [jens dott fudicker att oratool dott de]\r\nPortions created by Jens Fudickar are Copyright (C) 2002 Jens Fudickar.\r\nAll Rights Reserved.\r\n\r\nContributor(s): -\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvControlActionsEngine.pas 13138 2011-10-26 23:17:50Z jfudickar $\r\n\r\nunit JvControlActionsEngine;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n {$IFDEF MSWINDOWS}\r\n Windows, Graphics,\r\n {$ENDIF MSWINDOWS}\r\n {$IFDEF UNIX}\r\n QActnList, QWindows, QImgList, QGraphics,\r\n {$ENDIF UNIX}\r\n Forms, Controls, Classes, JvActionsEngine;\r\n\r\ntype\r\n TJvControlActionOperation = (caoCollapse, caoExpand, caoExport, caoOptimizeColumns, caoCustomize, caoPrint,\r\n caoCustomizeColumns);\r\n TJvControlActionOperations = set of TJvControlActionOperation;\r\n TJvControlActionEngine = class(TJvActionBaseEngine)\r\n protected\r\n function GetEngineList: TJvActionEngineList; virtual; abstract;\r\n function GetSupportedOperations: TJvControlActionOperations; virtual; abstract;\r\n property EngineList: TJvActionEngineList read GetEngineList;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n function ExecuteOperation(const aOperation: TJvControlActionOperation; const aActionControl: TControl): Boolean; virtual;\r\n function SupportsAction(AAction: TJvActionEngineBaseAction): Boolean; override;\r\n property SupportedOperations: TJvControlActionOperations read GetSupportedOperations;\r\n end;\r\n\r\n TJvControlActionEngineClass = class of TJvControlActionEngine;\r\n TJvControlActionEngineList = class(TJvActionEngineList)\r\n public\r\n procedure RegisterEngine(AEngineClass: TJvControlActionEngineClass);\r\n end;\r\n\r\nprocedure RegisterControlActionEngine(AEngineClass: TJvControlActionEngineClass);\r\n\r\nfunction RegisteredControlActionEngineList: TJvControlActionEngineList;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvControlActionsEngine.pas $';\r\n Revision: '$Revision: 13138 $';\r\n Date: '$Date: 2011-10-27 01:17:50 +0200 (jeu. 27 oct. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n SysUtils, Variants,\r\n Dialogs,\r\n JvControlActions;\r\n\r\n\r\nvar\r\n IntRegisteredActionEngineList: TJvControlActionEngineList;\r\n\r\nprocedure RegisterControlActionEngine(AEngineClass: TJvControlActionEngineClass);\r\nbegin\r\n if Assigned(IntRegisteredActionEngineList) then\r\n IntRegisteredActionEngineList.RegisterEngine(AEngineClass);\r\nend;\r\n\r\nfunction RegisteredControlActionEngineList: TJvControlActionEngineList;\r\nbegin\r\n Result := IntRegisteredActionEngineList;\r\nend;\r\n\r\nprocedure CreateActionEngineList;\r\nbegin\r\n IntRegisteredActionEngineList := TJvControlActionEngineList.Create;\r\nend;\r\n\r\nprocedure DestroyActionEngineList;\r\nbegin\r\n IntRegisteredActionEngineList.Free;\r\n IntRegisteredActionEngineList := nil;\r\nend;\r\n\r\nprocedure InitActionEngineList;\r\nbegin\r\n CreateActionEngineList;\r\nend;\r\n\r\nconstructor TJvControlActionEngine.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\nend;\r\n\r\nfunction TJvControlActionEngine.ExecuteOperation(const aOperation: TJvControlActionOperation; const aActionControl:\r\n TControl): Boolean;\r\nbegin\r\n Result := False;\r\nend;\r\n\r\nfunction TJvControlActionEngine.SupportsAction(AAction: TJvActionEngineBaseAction): Boolean;\r\nbegin\r\n Result := (AAction is TJvControlBaseAction) and\r\n (TJvControlBaseAction(AAction).ControlOperation in SupportedOperations);\r\nend;\r\n\r\n\r\nprocedure TJvControlActionEngineList.RegisterEngine(AEngineClass: TJvControlActionEngineClass);\r\nbegin\r\n Add(AEngineClass.Create(nil));\r\nend;\r\n\r\n\r\ninitialization\r\n {$IFDEF UNITVERSIONING}\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n {$ENDIF UNITVERSIONING}\r\n InitActionEngineList;\r\n\r\nfinalization\r\n DestroyActionEngineList;\r\n {$IFDEF UNITVERSIONING}\r\n UnregisterUnitVersion(HInstance);\r\n {$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvControlActionsEngineCxEditors.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvDBActions.Pas, released on 2007-03-11.\r\n\r\nThe Initial Developer of the Original Code is Jens Fudickar [jens dott fudicker att oratool dott de]\r\nPortions created by Jens Fudickar are Copyright (C) 2002 Jens Fudickar.\r\nAll Rights Reserved.\r\n\r\nContributor(s): -\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvControlActionsEngineCxEditors.pas 13104 2011-09-07 06:50:43Z obones $\r\n\r\nunit JvControlActionsEngineCxEditors;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Forms, Controls, Classes,\r\n {$IFDEF USE_3RDPARTY_DEVEXPRESS_CXEDITOR}\r\n cxTreeView,\r\n {$ENDIF}\r\n JvControlActionsEngine;\r\n\r\n{$IFDEF USE_3RDPARTY_DEVEXPRESS_CXEDITOR}\r\ntype\r\n TJvControlActioncxTreeViewEngine = class(TJvControlActionEngine)\r\n protected\r\n function GetSupportedOperations: TJvControlActionOperations; override;\r\n public\r\n function ExecuteOperation(const aOperation: TJvControlActionOperation; const aActionControl: TControl): Boolean; override;\r\n function SupportsComponent(aActionComponent: TComponent): Boolean; override;\r\n end;\r\n{$ENDIF}\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvControlActionsEngineCxEditors.pas $';\r\n Revision: '$Revision: 13104 $';\r\n Date: '$Date: 2011-09-07 08:50:43 +0200 (mer. 07 sept. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n SysUtils, Grids, TypInfo, StrUtils, Variants, Dialogs, StdCtrls, Clipbrd;\r\n\r\n{$IFDEF USE_3RDPARTY_DEVEXPRESS_CXEDITOR}\r\nprocedure InitActionEngineList;\r\nbegin\r\n RegisterControlActionEngine (TJvControlActioncxTreeViewEngine);\r\nend;\r\n\r\nfunction TJvControlActioncxTreeViewEngine.ExecuteOperation(const aOperation: TJvControlActionOperation; const\r\n aActionControl: TControl): Boolean;\r\nbegin\r\n Result := true;\r\n if Assigned(aActionControl) and (aActionControl is TcxCustomTreeView) then\r\n Case aOperation of\r\n caoCollapse : TcxCustomTreeView(aActionControl).FullCollapse;\r\n caoExpand : TcxCustomTreeView(aActionControl).FullExpand;\r\n else\r\n Result := false;\r\n End\r\n else\r\n Result := false;\r\nend;\r\n\r\nfunction TJvControlActioncxTreeViewEngine.GetSupportedOperations:\r\n TJvControlActionOperations;\r\nbegin\r\n Result := [caoCollapse, caoExpand];\r\nend;\r\n\r\nfunction TJvControlActioncxTreeViewEngine.SupportsComponent(aActionComponent:\r\n TComponent): Boolean;\r\nbegin\r\n Result := aActionComponent is TcxCustomTreeView;\r\nend;\r\n{$ENDIF}\r\n\r\n{$IFDEF USE_3RDPARTY_DEVEXPRESS_CXEDITOR}\r\ninitialization\r\n {$IFDEF UNITVERSIONING}\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n {$ENDIF UNITVERSIONING}\r\n InitActionEngineList;\r\n\r\nfinalization\r\n {$IFDEF UNITVERSIONING}\r\n UnregisterUnitVersion(HInstance);\r\n {$ENDIF UNITVERSIONING}\r\n{$ENDIF}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvControlActionsEngineCxGrid.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvDBActionsEngineControlCxGrid.Pas, released on 2004-12-30.\r\n\r\nThe Initial Developer of the Original Code is Jens Fudickar [jens dott fudicker att oratool dott de]\r\nPortions created by Jens Fudickar are Copyright (C) 2002 Jens Fudickar.\r\nAll Rights Reserved.\r\n\r\nContributor(s): -\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvControlActionsEngineCxGrid.pas 13099 2011-09-02 21:51:31Z jfudickar $\r\n\r\nunit JvControlActionsEngineCxGrid;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n{$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n{$ENDIF UNITVERSIONING}\r\n Forms, Controls, Classes, DB,\r\n{$IFDEF USE_3RDPARTY_DEVEXPRESS_CXGRID}\r\n cxGridCustomTableView, cxDBData, cxGridCustomView, cxGrid, cxGridChartView,\r\n{$ENDIF USE_3RDPARTY_DEVEXPRESS_CXGRID}\r\n JvControlActionsEngine, JvActionsEngine;\r\n\r\n{$IFDEF USE_3RDPARTY_DEVEXPRESS_CXGRID}\r\ntype\r\n TJvControlActioncxGridEngine = class(TJvControlActionEngine)\r\n private\r\n procedure ExportChartViewToImage(aExtension, aFileName: string; aChartView: TcxGridChartView);\r\n protected\r\n procedure ExportGrid(aGrid: TcxGrid);\r\n function GetGridTableView(AActionComponent: TComponent): TcxCustomGridTableView;\r\n function GetGridView(AActionComponent: TComponent): TcxCustomGridView;\r\n function GetGrid(AActionComponent: TComponent): TcxGrid;\r\n function GetSupportedOperations: TJvControlActionOperations; override;\r\n public\r\n function ExecuteOperation(const aOperation: TJvControlActionOperation; const aActionControl: TControl): Boolean; override;\r\n function SupportsComponent(aActionComponent: TComponent): Boolean; override;\r\n function UpdateAction(Action: TBasicAction): boolean; override;\r\n end;\r\n\r\n{$ENDIF USE_3RDPARTY_DEVEXPRESS_CXGRID}\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile:\r\n '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvControlActionsEngineCxGrid.pas $';\r\n Revision: '$Revision: 13099 $';\r\n Date: '$Date: 2011-09-02 23:51:31 +0200 (ven. 02 sept. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n{$IFDEF USE_3RDPARTY_DEVEXPRESS_CXGRID}\r\n cxGridDBDataDefinitions, cxControls,\r\n cxCustomData, cxGridExportLink,\r\n {$IFDEF DELPHI12_UP}\r\n pngimage, jpeg,\r\n {$ENDIf}\r\n{$ENDIF USE_3RDPARTY_DEVEXPRESS_CXGRID}\r\n Graphics, Variants, SysUtils, Dialogs, JvControlActions;\r\n\r\n//=== { TJvDatabaseActionDevExpCxGridControlEngine } =========================\r\n\r\n{$IFDEF USE_3RDPARTY_DEVEXPRESS_CXGRID}\r\n\r\nfunction TJvControlActioncxGridEngine.ExecuteOperation(const aOperation: TJvControlActionOperation; const\r\n aActionControl: TControl): Boolean;\r\nbegin\r\n Result := true;\r\n case aOperation of\r\n caoCollapse:\r\n if Assigned(GetGridTableView(aActionControl)) then\r\n GetGridTableView(aActionControl).Datacontroller.Groups.FullCollapse\r\n else\r\n Result := false;\r\n caoExpand:\r\n if Assigned(GetGridTableView(aActionControl)) then\r\n GetGridTableView(aActionControl).Datacontroller.Groups.FullExpand\r\n else\r\n Result := false;\r\n caoOptimizeColumns:\r\n if Assigned(GetGridTableView(aActionControl)) then\r\n GetGridTableView(aActionControl).ApplyBestFit\r\n else\r\n Result := false;\r\n caoExport:\r\n if Assigned(GetGridView(aActionControl)) then\r\n ExportGrid(GetGrid(aActionControl))\r\n else\r\n Result := false;\r\n caoCustomizeColumns:\r\n if Assigned(GetGridView(aActionControl)) then\r\n GetGridView(aActionControl).Controller.Customization := not GetGridView(aActionControl).Controller.Customization\r\n else\r\n Result := false;\r\n else\r\n Result := False\r\n end;\r\nend;\r\n\r\nprocedure TJvControlActioncxGridEngine.ExportChartViewToImage(aExtension, aFileName: string; aChartView:\r\n TcxGridChartView);\r\nvar\r\n AGraphic: TGraphic;\r\n TmpGraphic: TGraphic;\r\nbegin\r\n if (aExtension = '.WMF') or (aExtension = '.EMF') then\r\n begin\r\n AGraphic := AChartView.CreateImage(TMetaFile);\r\n TMetaFile(AGraphic).Enhanced := aExtension = '.EMF';\r\n end\r\n else\r\n AGraphic := AChartView.CreateImage(TBitmap);\r\n {$IFDEF DELPHI12_UP}\r\n if aExtension = '.PNG' then\r\n TMPGraphic := TPNGImage.Create\r\n else if aExtension = '.JPG' then\r\n TMPGraphic := TJPEGImage.Create\r\n else\r\n TMPGraphic := nil;\r\n if Assigned(TMPGraphic) then\r\n begin\r\n TMPGraphic.Assign(AGraphic);\r\n TMPGraphic.SaveToFile(aFileName);\r\n TMPGraphic.Free;\r\n end\r\n else\r\n {$ENDIF}\r\n AGraphic.SaveToFile(aFileName);\r\n AGraphic.Free;\r\nend;\r\n\r\nprocedure TJvControlActioncxGridEngine.ExportGrid(aGrid: TcxGrid);\r\nvar\r\n SaveDialog: TSaveDialog;\r\n Extension: String;\r\n FileName: String;\r\nbegin\r\n if not Assigned(aGrid) then\r\n Exit;\r\n SaveDialog := TSaveDialog.Create(Self);\r\n try\r\n SaveDialog.Name := 'SaveDialog';\r\n SaveDialog.DefaultExt := 'XLS';\r\n SaveDialog.Filter :=\r\n 'MS-Excel-Files (*.XLS;*.XLSX)|*.XLS;*.XLSX|XML-Files (*.XML)|*.XML|HTML-Files (*.HTM;*.HTML)|*.HTM;*.HTML|Text-Files (*.TXT)|*.TXT';\r\n if GetGridView(aGrid) is TcxGridChartView then\r\n {$IFDEF DELPHI12_UP}\r\n SaveDialog.Filter := SaveDialog.Filter+'|Image-Files (*.PNG;*.JPG;*.BMP)|*.PNG;*.JPG;*.BMP|Metafile-Graphics (*.WMF;*.EMF)|*.WMF;*.EMF';\r\n {$ELSE}\r\n SaveDialog.Filter := SaveDialog.Filter+'|Image-Files (*.BMP)|*.BMP|Metafile-Graphics (*.WMF;*.EMF)|*.WMF;*.EMF';\r\n {$ENDIF}\r\n SaveDialog.Filter := SaveDialog.Filter+'|All Files (*.*)|*.*';\r\n SaveDialog.Options := [ofOverwritePrompt, ofHideReadOnly, ofPathMustExist];\r\n if SaveDialog.Execute then\r\n if SaveDialog.FileName <> '' then\r\n begin\r\n FileName := SaveDialog.Filename;\r\n Extension := Uppercase(ExtractFileExt(FileName));\r\n if Extension = '.XLS' then\r\n ExportGridToExcel(Filename, aGrid)\r\n else if Extension = '.XLSX' then\r\n ExportGridToXLSX(Filename, aGrid)\r\n else if ((Extension = '.BMP') or (Extension = '.JPG') or (Extension = '.PNG') or\r\n (Extension = '.WMF') or (Extension = '.EMF'))\r\n and (GetGridView(aGrid) is TcxGridChartView) then\r\n ExportChartViewToImage(Extension, Filename, TcxGridChartView(GetGridView(aGrid)))\r\n else if Extension = 'XML' then\r\n ExportGridToXML(Filename, aGrid)\r\n else if (Extension = '.HTM') or (Extension = '.HTML') then\r\n ExportGridToHTML(Filename, aGrid)\r\n else\r\n ExportGridToText(Filename, aGrid);\r\n end;\r\n finally\r\n SaveDialog.Free;\r\n end;\r\nend;\r\n\r\nfunction TJvControlActioncxGridEngine.GetGridTableView(AActionComponent: TComponent): TcxCustomGridTableView;\r\nvar GridView : TcxCustomGridView;\r\nbegin\r\n GridView := GetGridView(AActionComponent);\r\n if GridView is TcxCustomGridTableView then\r\n Result := TcxCustomGridTableView(GridView)\r\n else\r\n Result := nil;\r\nend;\r\n\r\nfunction TJvControlActioncxGridEngine.GetGridView(AActionComponent: TComponent): TcxCustomGridView;\r\nbegin\r\n if Assigned(AActionComponent) then\r\n if AActionComponent is TcxGridSite then\r\n Result := TcxGridSite(AActionComponent).GridView\r\n else\r\n if AActionComponent is TcxGrid then\r\n Result := TcxGrid(AActionComponent).ActiveView\r\n else\r\n Result := nil\r\n else\r\n Result := nil;\r\nend;\r\n\r\nfunction TJvControlActioncxGridEngine.GetGrid(AActionComponent: TComponent): TcxGrid;\r\nbegin\r\n if Assigned(AActionComponent) then\r\n if AActionComponent is TcxGridSite then\r\n Result := TcxGrid(TcxGridSite(AActionComponent).Container)\r\n else\r\n if AActionComponent is TcxGrid then\r\n Result := TcxGrid(AActionComponent)\r\n else\r\n Result := nil\r\n else\r\n Result := nil;\r\nend;\r\n\r\nfunction TJvControlActioncxGridEngine.GetSupportedOperations:\r\n TJvControlActionOperations;\r\nbegin\r\n Result := [caoCollapse, caoExpand, caoOptimizeColumns, caoExport, caoCustomizeColumns];\r\nend;\r\n\r\nfunction TJvControlActioncxGridEngine.SupportsComponent(aActionComponent:\r\n TComponent): Boolean;\r\nbegin\r\n Result := Assigned(GetGridView(AActionComponent));\r\nend;\r\n\r\nfunction TJvControlActioncxGridEngine.UpdateAction(Action: TBasicAction): boolean;\r\nbegin\r\n Result := Inherited UpdateAction(Action);\r\n if Assigned(Action) and (Action is TJvControlBaseAction) and\r\n Assigned(GetGridView(TJvControlBaseAction(Action).ActionComponent)) and (TJvControlBaseAction(Action).ControlOperation = caoCustomizeColumns) then\r\n TJvControlBaseAction(Action).SetChecked(GetGridView(TJvControlBaseAction(Action).ActionComponent).Controller.Customization);\r\nend;\r\n\r\n{$ENDIF USE_3RDPARTY_DEVEXPRESS_CXGRID}\r\n\r\nprocedure InitActionEngineList;\r\nbegin\r\n{$IFDEF USE_3RDPARTY_DEVEXPRESS_CXGRID}\r\n RegisterControlActionEngine(TJvControlActioncxGridEngine);\r\n{$ENDIF USE_3RDPARTY_DEVEXPRESS_CXGRID}\r\nend;\r\n\r\ninitialization\r\n{$IFDEF UNITVERSIONING}\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n{$ENDIF UNITVERSIONING}\r\n InitActionEngineList;\r\n\r\nfinalization\r\n{$IFDEF UNITVERSIONING}\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvControlActionsEngineCxPivotGrid.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvDBActionsEngineControlCxGrid.Pas, released on 2004-12-30.\r\n\r\nThe Initial Developer of the Original Code is Jens Fudickar [jens dott fudicker att oratool dott de]\r\nPortions created by Jens Fudickar are Copyright (C) 2002 Jens Fudickar.\r\nAll Rights Reserved.\r\n\r\nContributor(s): -\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvControlActionsEngineCxPivotGrid.pas 13099 2011-09-02 21:51:31Z jfudickar $\r\n\r\nunit JvControlActionsEngineCxPivotGrid;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Forms, Controls, Classes, DB,\r\n {$IFDEF USE_3RDPARTY_DEVEXPRESS_CXPIVOTGRID}\r\n cxCustomPivotGrid,\r\n {$ENDIF USE_3RDPARTY_DEVEXPRESS_CXPIVOTGRID}\r\n JvControlActionsEngine, JvActionsEngine;\r\n\r\n{$IFDEF USE_3RDPARTY_DEVEXPRESS_CXPIVOTGRID}\r\ntype\r\n TJvControlActioncxPivotGridEngine = class(TJvControlActionEngine)\r\n private\r\n protected\r\n procedure ExportGrid(aGrid: TcxCustomPivotGrid);\r\n function GetPivotGrid(AActionComponent: TComponent): TcxCustomPivotGrid;\r\n function GetSupportedOperations: TJvControlActionOperations; override;\r\n public\r\n function ExecuteOperation(const aOperation: TJvControlActionOperation; const aActionControl: TControl): Boolean; override;\r\n function SupportsComponent(aActionComponent: TComponent): Boolean; override;\r\n function UpdateAction(Action: TBasicAction): boolean; override;\r\n end;\r\n\r\n{$ENDIF USE_3RDPARTY_DEVEXPRESS_CXPIVOTGRID}\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvControlActionsEngineCxPivotGrid.pas $';\r\n Revision: '$Revision: 13099 $';\r\n Date: '$Date: 2011-09-02 23:51:31 +0200 (ven. 02 sept. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n {$IFDEF USE_3RDPARTY_DEVEXPRESS_CXPIVOTGRID}\r\n cxExportPivotGridLink,\r\n {$ENDIF USE_3RDPARTY_DEVEXPRESS_CXPIVOTGRID}\r\n Variants, SysUtils, Dialogs, JvControlActions;\r\n\r\n//=== { TJvDatabaseActionDevExpCxGridControlEngine } =========================\r\n\r\n{$IFDEF USE_3RDPARTY_DEVEXPRESS_CXPIVOTGRID}\r\n\r\nfunction TJvControlActioncxPivotGridEngine.ExecuteOperation(const aOperation: TJvControlActionOperation; const\r\n aActionControl: TControl): Boolean;\r\n\r\nvar\r\n PivotGrid : TcxCustomPivotGrid;\r\n i : Integer;\r\nbegin\r\n Result := false;\r\n PivotGrid := GetPivotGrid(aActionControl);\r\n if Assigned(PivotGrid) then\r\n Case aOperation of\r\n caoCollapse :\r\n for I := 0 to PivotGrid.Groups.Count - 1 do\r\n PivotGrid.Groups[i].FullCollapse;\r\n caoExpand :\r\n for I := 0 to PivotGrid.Groups.Count - 1 do\r\n PivotGrid.Groups[i].FullExpand;\r\n caoOptimizeColumns : PivotGrid.ApplyBestFit;\r\n caoExport : ExportGrid (PivotGrid);\r\n caoCustomizeColumns : PivotGrid.Customization.Visible := not PivotGrid.Customization.Visible;\r\n End;\r\nend;\r\n\r\nprocedure TJvControlActioncxPivotGridEngine.ExportGrid(aGrid: TcxCustomPivotGrid);\r\nvar\r\n SaveDialog: TSaveDialog;\r\nbegin\r\n if not Assigned(aGrid) then\r\n Exit;\r\n SaveDialog := TSaveDialog.Create(Self);\r\n try\r\n SaveDialog.Name := 'SaveDialog';\r\n SaveDialog.DefaultExt := 'XLS';\r\n SaveDialog.Filter := 'MS-Excel-Files (*.XLS)|*.XLS|XML-Files (*.XML)|*.HTM|HTML-Files (*.HTM)|*.HTM|Text-Files (*.TXT)|*.TXT|All Files (*.*)|*.*';\r\n SaveDialog.Options := [ofOverwritePrompt, ofHideReadOnly, ofPathMustExist];\r\n if SaveDialog.Execute then\r\n if SaveDialog.FileName <> '' then\r\n begin\r\n if (Pos('.XLS', UpperCase(SaveDialog.FileName)) = Length(SaveDialog.FileName) - 3) then\r\n cxExportPivotGridToExcel(SaveDialog.FileName, aGrid)\r\n else if (Pos('.XML', UpperCase(SaveDialog.FileName)) = Length(SaveDialog.FileName) - 3) then\r\n cxExportPivotGridToXML(SaveDialog.FileName, aGrid)\r\n else if ((Pos('.HTM', UpperCase(SaveDialog.FileName)) = Length(SaveDialog.FileName) - 3) or\r\n (Pos('.HTML', UpperCase(SaveDialog.FileName)) = Length(SaveDialog.FileName) - 4)) then\r\n cxExportPivotGridToHTML(SaveDialog.FileName, aGrid)\r\n else\r\n cxExportPivotGridToText(SaveDialog.FileName, aGrid);\r\n end;\r\n finally\r\n SaveDialog.Free;\r\n end;\r\nend;\r\n\r\nfunction TJvControlActioncxPivotGridEngine.GetPivotGrid(AActionComponent: TComponent): TcxCustomPivotGrid;\r\nbegin\r\n if Assigned(AActionComponent) then\r\n if AActionComponent is TcxCustomPivotGrid then\r\n Result := TcxCustomPivotGrid(AActionComponent)\r\n else\r\n Result := nil\r\n else\r\n Result := nil;\r\nend;\r\n\r\nfunction TJvControlActioncxPivotGridEngine.GetSupportedOperations: TJvControlActionOperations;\r\nbegin\r\n Result := [{caoCollapse, caoExpand,} caoOptimizeColumns, caoExport, caoCustomizeColumns];\r\nend;\r\n\r\nfunction TJvControlActioncxPivotGridEngine.SupportsComponent(aActionComponent: TComponent): Boolean;\r\nbegin\r\n Result := Assigned(GetPivotGrid(AActionComponent));\r\nend;\r\n\r\nfunction TJvControlActioncxPivotGridEngine.UpdateAction(Action: TBasicAction): boolean;\r\nbegin\r\n Result := Inherited UpdateAction(Action);\r\n if Assigned(Action) and (Action is TJvControlBaseAction) and\r\n Assigned(GetPivotGrid(TJvControlBaseAction(action).ActionComponent)) and (TJvControlBaseAction(action).ControlOperation = caoCustomizeColumns) then\r\n TJvControlBaseAction(action).SetChecked(GetPivotGrid(TJvControlBaseAction(action).ActionComponent).Customization.Visible);\r\nend;\r\n\r\n{$ENDIF USE_3RDPARTY_DEVEXPRESS_CXPIVOTGRID}\r\n\r\nprocedure InitActionEngineList;\r\nbegin\r\n {$IFDEF USE_3RDPARTY_DEVEXPRESS_CXPIVOTGRID}\r\n RegisterControlActionEngine(TJvControlActioncxPivotGridEngine);\r\n {$ENDIF USE_3RDPARTY_DEVEXPRESS_CXPIVOTGRID}\r\nend;\r\n\r\n\r\ninitialization\r\n {$IFDEF UNITVERSIONING}\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n {$ENDIF UNITVERSIONING}\r\n InitActionEngineList;\r\n\r\nfinalization\r\n {$IFDEF UNITVERSIONING}\r\n UnregisterUnitVersion(HInstance);\r\n {$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvControlActionsEngineCxTreeList.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvDBActionsEngineControlcxTreeList.Pas, released on 2004-12-30.\r\n\r\nThe Initial Developer of the Original Code is Jens Fudickar [jens dott fudicker att oratool dott de]\r\nPortions created by Jens Fudickar are Copyright (C) 2002 Jens Fudickar.\r\nAll Rights Reserved.\r\n\r\nContributor(s): -\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvControlActionsEngineCxTreeList.pas 13099 2011-09-02 21:51:31Z jfudickar $\r\n\r\nunit JvControlActionsEngineCxTreeList;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Forms, Controls, Classes, DB,\r\n {$IFDEF USE_3RDPARTY_DEVEXPRESS_CXTREELIST}\r\n cxTL,\r\n {$ENDIF USE_3RDPARTY_DEVEXPRESS_CXTREELIST}\r\n JvControlActionsEngine, JvActionsEngine;\r\n\r\n{$IFDEF USE_3RDPARTY_DEVEXPRESS_CXTREELIST}\r\ntype\r\n TJvControlActioncxTreeListEngine = class(TJvControlActionEngine)\r\n private\r\n protected\r\n procedure ExportTreeList(aTreeList: TcxCustomTreeList);\r\n function GetSupportedOperations: TJvControlActionOperations; override;\r\n function GetTreeList(AActionComponent: TComponent): TcxCustomTreeList;\r\n public\r\n function ExecuteOperation(const aOperation: TJvControlActionOperation; const aActionControl: TControl): Boolean; override;\r\n function SupportsComponent(aActionComponent: TComponent): Boolean; override;\r\n function UpdateAction(Action: TBasicAction): boolean; override;\r\n end;\r\n\r\n{$ENDIF USE_3RDPARTY_DEVEXPRESS_CXTREELIST}\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvControlActionsEngineCxTreeList.pas $';\r\n Revision: '$Revision: 13099 $';\r\n Date: '$Date: 2011-09-02 23:51:31 +0200 (ven. 02 sept. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n {$IFDEF USE_3RDPARTY_DEVEXPRESS_CXTREELIST}\r\n cxTLExportLink,\r\n {$ENDIF USE_3RDPARTY_DEVEXPRESS_CXTREELIST}\r\n Variants, SysUtils, Grids, Dialogs, JvControlActions;\r\n\r\n//=== { TJvDatabaseActionDevExpcxTreeListControlEngine } =========================\r\n\r\n{$IFDEF USE_3RDPARTY_DEVEXPRESS_CXTREELIST}\r\n\r\nfunction TJvControlActioncxTreeListEngine.ExecuteOperation(const aOperation: TJvControlActionOperation; const\r\n aActionControl: TControl): Boolean;\r\nbegin\r\n Result := false;\r\n if Assigned(GetTreeList(aActionControl)) then\r\n Case aOperation of\r\n caoCollapse : GetTreeList(aActionControl).FullCollapse;\r\n caoExpand : GetTreeList(aActionControl).FullExpand;\r\n caoOptimizeColumns : GetTreeList(aActionControl).ApplyBestFit;\r\n caoCustomizeColumns : GetTreeList(aActionControl).Customizing.Visible := not GetTreeList(aActionControl).Customizing.Visible;\r\n caoExport : ExportTreeList(GetTreeList(aActionControl));\r\n End;\r\nend;\r\n\r\nprocedure TJvControlActioncxTreeListEngine.ExportTreeList(aTreeList: TcxCustomTreeList);\r\nvar\r\n SaveDialog: TSaveDialog;\r\nbegin\r\n if not Assigned(aTreeList) then\r\n Exit;\r\n SaveDialog := TSaveDialog.Create(Self);\r\n try\r\n SaveDialog.Name := 'SaveDialog';\r\n SaveDialog.DefaultExt := 'XLS';\r\n SaveDialog.Filter := 'MS-Excel-Files (*.XLS)|*.XLS|XML-Files (*.XML)|*.HTM|HTML-Files (*.HTM)|*.HTM|Text-Files (*.TXT)|*.TXT|All Files (*.*)|*.*';\r\n SaveDialog.Options := [ofOverwritePrompt, ofHideReadOnly, ofPathMustExist];\r\n if SaveDialog.Execute then\r\n if SaveDialog.FileName <> '' then\r\n begin\r\n if (Pos('.XLS', UpperCase(SaveDialog.FileName)) = Length(SaveDialog.FileName) - 3) then\r\n cxExportTLToExcel(SaveDialog.FileName, aTreeList)\r\n else if (Pos('.XML', UpperCase(SaveDialog.FileName)) = Length(SaveDialog.FileName) - 3) then\r\n cxExportTLToXML(SaveDialog.FileName, aTreeList)\r\n else if ((Pos('.HTM', UpperCase(SaveDialog.FileName)) = Length(SaveDialog.FileName) - 3) or\r\n (Pos('.HTML', UpperCase(SaveDialog.FileName)) = Length(SaveDialog.FileName) - 4)) then\r\n cxExportTLToHTML(SaveDialog.FileName, aTreeList)\r\n else\r\n cxExportTLToText(SaveDialog.FileName, aTreeList);\r\n end;\r\n finally\r\n SaveDialog.Free;\r\n end;\r\nend;\r\n\r\nfunction TJvControlActioncxTreeListEngine.GetSupportedOperations: TJvControlActionOperations;\r\nbegin\r\n Result := [caoExport, caoCollapse, caoExpand, caoOptimizeColumns, caoCustomizeColumns];\r\nend;\r\n\r\nfunction TJvControlActioncxTreeListEngine.GetTreeList(AActionComponent: TComponent): TcxCustomTreeList;\r\nbegin\r\n if Assigned(AActionComponent) and (AActionComponent is TcxCustomTreeList) then\r\n Result := TcxCustomTreeList(AActionComponent)\r\n else\r\n Result := nil;\r\nend;\r\n\r\nfunction TJvControlActioncxTreeListEngine.SupportsComponent(aActionComponent: TComponent): Boolean;\r\nbegin\r\n Result := Assigned(GetTreeList(AActionComponent));\r\nend;\r\n\r\nfunction TJvControlActioncxTreeListEngine.UpdateAction(Action: TBasicAction): boolean;\r\nbegin\r\n Result := Inherited UpdateAction(Action);\r\n if Assigned(Action) and (Action is TJvControlBaseAction) and\r\n Assigned(GetTreeList(TJvControlBaseAction(Action).ActionComponent)) and (TJvControlBaseAction(Action).ControlOperation = caoCustomizeColumns) then\r\n TJvControlBaseAction(Action).SetChecked(GetTreeList(TJvControlBaseAction(Action).ActionComponent).Customizing.Visible);\r\nend;\r\n\r\n{$ENDIF USE_3RDPARTY_DEVEXPRESS_CXTREELIST}\r\n\r\nprocedure InitActionEngineList;\r\nbegin\r\n {$IFDEF USE_3RDPARTY_DEVEXPRESS_CXTREELIST}\r\n RegisterControlActionEngine(TJvControlActioncxTreeListEngine);\r\n {$ENDIF USE_3RDPARTY_DEVEXPRESS_CXTREELIST}\r\nend;\r\n\r\n\r\ninitialization\r\n {$IFDEF UNITVERSIONING}\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n {$ENDIF UNITVERSIONING}\r\n InitActionEngineList;\r\n\r\nfinalization\r\n {$IFDEF UNITVERSIONING}\r\n UnregisterUnitVersion(HInstance);\r\n {$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvControlActionsEngineCxVerticalGrid.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvDBActionsEngineControlcxVerticalGrid.Pas, released on 2004-12-30.\r\n\r\nThe Initial Developer of the Original Code is Jens Fudickar [jens dott fudicker att oratool dott de]\r\nPortions created by Jens Fudickar are Copyright (C) 2002 Jens Fudickar.\r\nAll Rights Reserved.\r\n\r\nContributor(s): -\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvControlActionsEngineCxVerticalGrid.pas 12461 2009-08-14 17:21:33Z obones $\r\n\r\nunit JvControlActionsEngineCxVerticalGrid;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Forms, Controls, Classes, DB,\r\n {$IFDEF USE_3RDPARTY_DEVEXPRESS_CXVERTICALGRID}\r\n cxVGrid,\r\n {$ENDIF USE_3RDPARTY_DEVEXPRESS_CXVERTICALGRID}\r\n JvControlActionsEngine;\r\n\r\n{$IFDEF USE_3RDPARTY_DEVEXPRESS_CXVERTICALGRID}\r\ntype\r\n TJvControlActioncxVerticalGridEngine = class(TJvControlActionEngine)\r\n private\r\n protected\r\n procedure ExportGrid(aGrid: TcxVerticalGrid);\r\n function GetGrid(AActionComponent: TComponent): TcxVerticalGrid;\r\n function GetSupportedOperations: TJvControlActionOperations; override;\r\n public\r\n function ExecuteOperation(const aOperation: TJvControlActionOperation; const\r\n aActionControl: TControl): Boolean; override;\r\n function SupportsComponent(aActionComponent: TComponent): Boolean; override;\r\n end;\r\n\r\n{$ENDIF USE_3RDPARTY_DEVEXPRESS_CXVERTICALGRID}\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvControlActionsEngineCxVerticalGrid.pas $';\r\n Revision: '$Revision: 12461 $';\r\n Date: '$Date: 2009-08-14 19:21:33 +0200 (ven. 14 août 2009) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n {$IFDEF USE_3RDPARTY_DEVEXPRESS_CXVERTICALGRID}\r\n cxCustomData, cxExportVGLink,\r\n {$ENDIF USE_3RDPARTY_DEVEXPRESS_CXVERTICALGRID}\r\n Variants, SysUtils, Dialogs;\r\n\r\n//=== { TJvDatabaseActionDevExpcxVerticalGridControlEngine } =========================\r\n\r\n{$IFDEF USE_3RDPARTY_DEVEXPRESS_CXVERTICALGRID}\r\n\r\nfunction TJvControlActioncxVerticalGridEngine.ExecuteOperation(const aOperation:\r\n TJvControlActionOperation; const aActionControl: TControl): Boolean;\r\nbegin\r\n Result := false;\r\n if Assigned(GetGrid(aActionControl)) then\r\n Case aOperation of\r\n caoCollapse : GetGrid(aActionControl).FullCollapse;\r\n caoExpand : GetGrid(aActionControl).FullExpand;\r\n caoExport : ExportGrid(GetGrid(aActionControl));\r\n caoCustomize : GetGrid(aActionControl).Customizing.Visible := Not GetGrid(aActionControl).Customizing.Visible; \r\n End;\r\nend;\r\n\r\nprocedure TJvControlActioncxVerticalGridEngine.ExportGrid(aGrid: TcxVerticalGrid);\r\nvar\r\n SaveDialog: TSaveDialog;\r\nbegin\r\n if not Assigned(aGrid) then\r\n Exit;\r\n SaveDialog := TSaveDialog.Create(Self);\r\n try\r\n SaveDialog.Name := 'SaveDialog';\r\n SaveDialog.DefaultExt := 'XLS';\r\n SaveDialog.Filter := 'MS-Excel-Files (*.XLS)|*.XLS|XML-Files (*.XML)|*.HTM|HTML-Files (*.HTM)|*.HTM|Text-Files (*.TXT)|*.TXT|All Files (*.*)|*.*';\r\n SaveDialog.Options := [ofOverwritePrompt, ofHideReadOnly, ofPathMustExist];\r\n if SaveDialog.Execute then\r\n if SaveDialog.FileName <> '' then\r\n begin\r\n if (Pos('.XLS', UpperCase(SaveDialog.FileName)) = Length(SaveDialog.FileName) - 3) then\r\n cxExportVGToExcel(SaveDialog.FileName, aGrid)\r\n else if (Pos('.XML', UpperCase(SaveDialog.FileName)) = Length(SaveDialog.FileName) - 3) then\r\n cxExportVGToXML(SaveDialog.FileName, aGrid)\r\n else if ((Pos('.HTM', UpperCase(SaveDialog.FileName)) = Length(SaveDialog.FileName) - 3) or\r\n (Pos('.HTML', UpperCase(SaveDialog.FileName)) = Length(SaveDialog.FileName) - 4)) then\r\n cxExportVGToHTML(SaveDialog.FileName, aGrid)\r\n else\r\n cxExportVGToText(SaveDialog.FileName, aGrid);\r\n end;\r\n finally\r\n SaveDialog.Free;\r\n end;\r\nend;\r\n\r\nfunction TJvControlActioncxVerticalGridEngine.GetGrid(AActionComponent: TComponent):\r\n TcxVerticalGrid;\r\nbegin\r\n if Assigned(AActionComponent) then\r\n if AActionComponent is TcxVerticalGrid then\r\n Result := TcxVerticalGrid(AActionComponent)\r\n else\r\n Result := nil\r\n else\r\n Result := nil;\r\nend;\r\n\r\nfunction TJvControlActioncxVerticalGridEngine.GetSupportedOperations:\r\n TJvControlActionOperations;\r\nbegin\r\n Result := [caoCollapse, caoExpand, caoCustomize, caoExport];\r\nend;\r\n\r\nfunction TJvControlActioncxVerticalGridEngine.SupportsComponent(aActionComponent:\r\n TComponent): Boolean;\r\nbegin\r\n Result := Assigned(GetGrid(AActionComponent));\r\nend;\r\n\r\n{$ENDIF USE_3RDPARTY_DEVEXPRESS_CXVERTICALGRID}\r\n\r\nprocedure InitActionEngineList;\r\nbegin\r\n {$IFDEF USE_3RDPARTY_DEVEXPRESS_CXVERTICALGRID}\r\n RegisterControlActionEngine(TJvControlActioncxVerticalGridEngine);\r\n {$ENDIF USE_3RDPARTY_DEVEXPRESS_CXVERTICALGRID}\r\nend;\r\n\r\n\r\ninitialization\r\n {$IFDEF UNITVERSIONING}\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n {$ENDIF UNITVERSIONING}\r\n InitActionEngineList;\r\n\r\nfinalization\r\n {$IFDEF UNITVERSIONING}\r\n UnregisterUnitVersion(HInstance);\r\n {$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvControlActionsEngineDBGrid.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvDBActions.Pas, released on 2007-03-11.\r\n\r\nThe Initial Developer of the Original Code is Jens Fudickar [jens dott fudicker att oratool dott de]\r\nPortions created by Jens Fudickar are Copyright (C) 2002 Jens Fudickar.\r\nAll Rights Reserved.\r\n\r\nContributor(s): -\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvControlActionsEngineDBGrid.pas 12461 2009-08-14 17:21:33Z obones $\r\n\r\nunit JvControlActionsEngineDBGrid;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n {$IFDEF MSWINDOWS}\r\n Windows, ImgList, Graphics, ComCtrls,\r\n {$ENDIF MSWINDOWS}\r\n {$IFDEF UNIX}\r\n QWindows, QImgList, QGraphics, QComCtrls,\r\n {$ENDIF UNIX}\r\n Forms, Controls, Classes, JvControlActionsEngine, DBGrids;\r\n\r\ntype\r\n\r\n TJvControlActionDBGridEngine = class(TJvControlActionEngine)\r\n private\r\n FNoOfRowsForOptimize: Integer;\r\n protected\r\n function GetGrid(AActionComponent: TComponent): TCustomDBGrid;\r\n function GetSupportedOperations: TJvControlActionOperations; override;\r\n public\r\n function ExecuteOperation(const aOperation: TJvControlActionOperation; const\r\n aActionControl: TControl): Boolean; override;\r\n procedure OptimizeColumns(DBGrid: TCustomDBGrid);\r\n function SupportsComponent(aActionComponent: TComponent): Boolean; override;\r\n //1 Number of rows which should be used for column optimization\r\n property NoOfRowsForOptimize: Integer read FNoOfRowsForOptimize write\r\n FNoOfRowsForOptimize default 0;\r\n end;\r\n\r\n {$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile:\r\n '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvControlActionsEngineDBGrid.pas $';\r\n Revision: '$Revision: 12461 $';\r\n Date: '$Date: 2009-08-14 19:21:33 +0200 (ven. 14 août 2009) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n {$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n SysUtils, Grids, TypInfo, StrUtils,\r\n Variants, Clipbrd, DB;\r\n\r\nType TAccessCustomDBGrid = class(TCustomDBGrid);\r\n\r\nprocedure InitActionEngineList;\r\nbegin\r\n RegisterControlActionEngine(TJvControlActionDBGridEngine);\r\nend;\r\n\r\nfunction TJvControlActionDBGridEngine.ExecuteOperation(const aOperation:\r\n TJvControlActionOperation; const aActionControl: TControl): Boolean;\r\nbegin\r\n Result := true;\r\n if Assigned(aActionControl) and (aActionControl is TCustomDBGrid) then\r\n Case aOperation of\r\n caoOptimizeColumns: OptimizeColumns(GetGrid(aActionControl));\r\n else\r\n Result := false;\r\n End\r\n else\r\n Result := false;\r\nend;\r\n\r\nfunction TJvControlActionDBGridEngine.GetGrid(AActionComponent: TComponent):\r\n TCustomDBGrid;\r\nbegin\r\n if Assigned(AActionComponent) then\r\n if AActionComponent is TCustomDBGrid then\r\n Result := TCustomDBGrid(AActionComponent)\r\n else\r\n Result := nil\r\n else\r\n Result := nil;\r\nend;\r\n\r\nfunction TJvControlActionDBGridEngine.GetSupportedOperations:\r\n TJvControlActionOperations;\r\nbegin\r\n Result := [caoOptimizeColumns];\r\nend;\r\n\r\nprocedure TJvControlActionDBGridEngine.OptimizeColumns(DBGrid: TCustomDBGrid);\r\nvar\r\n Bookmark: TBookmark;\r\n Row: Integer;\r\n Col: Integer;\r\n DataSet: TDataset;\r\n Column: TColumn;\r\nbegin\r\n if not Assigned(DBGrid) or not Assigned(DBgrid.Datasource) or not Assigned(DBgrid.Datasource.Dataset) then\r\n Exit;\r\n Dataset := DBgrid.Datasource.Dataset;\r\n if not DataSet.Active then\r\n Exit;\r\n BookMark := DataSet.GetBookmark;\r\n try\r\n DataSet.DisableControls;\r\n TAccessCustomDBGrid(DBGrid).BeginUpdate;\r\n for Col := 0 to TAccessCustomDBGrid(DBGrid).Columns.Count - 1 do\r\n begin\r\n Column := TAccessCustomDBGrid(DBGrid).Columns[Col];\r\n if Assigned(Column.Field) and Column.Field.Visible and Column.Visible then\r\n Column.Width := TAccessCustomDBGrid(DBGrid).Canvas.TextWidth(Column.Title.Caption + ' ')\r\n end; {*** FOR Spalte := 0 TO DataSet.FieldCount-1 DO ***}\r\n Row := 0;\r\n while ((Row <= NoOfRowsForOptimize) or (NoOfRowsForOptimize <= 0))and not DataSet.EoF do\r\n begin\r\n for Col := 0 to TAccessCustomDBGrid(DBGrid).Columns.Count - 1 do\r\n begin\r\n Column := TAccessCustomDBGrid(DBGrid).Columns[Col];\r\n if Assigned(Column.Field) then\r\n if Column.Field.DataType in [ftString, ftSmallint, ftInteger, ftWord, ftBoolean,\r\n ftFloat, ftCurrency, ftBCD, ftDate, ftTime, ftDateTime,\r\n ftBytes, ftVarBytes, ftAutoInc, ftMemo, ftFmtMemo\r\n {$IFDEF COMPILER10_UP}, ftOraTimestamp, ftWideMemo, ftFixedWideChar{$ENDIF COMPILER10_UP}\r\n {$IFDEF COMPILER12_UP}, ftLongWord, ftShortint, ftByte, ftExtended{$ENDIF COMPILER12_UP}] then\r\n if Column.Field.Visible and Column.Visible and not Column.Field.IsNull then\r\n if TAccessCustomDBGrid(DBGrid).Canvas.TextWidth(Column.Field.AsString + ' ') > Column.Width then\r\n Column.Width := TAccessCustomDBGrid(DBGrid).Canvas.TextWidth(Column.Field.AsString + ' ');\r\n end; {*** FOR Spalte := 0 TO DataSet.FieldCount-1 DO ***}\r\n DataSet.Next;\r\n Inc(Row);\r\n end; {*** WHILE (Row < 10) AND NOT DataSet.EoF DO ***}\r\n finally\r\n if Assigned(Bookmark) then\r\n begin\r\n DataSet.GotoBookmark(Bookmark);\r\n DataSet.FreeBookmark(Bookmark);\r\n end; {*** IF Assigned (Bookmark) THEN ***}\r\n DataSet.EnableControls;\r\n TAccessCustomDBGrid(DBGrid).EndUpdate;\r\n end;\r\nend; {*** procedure TxSQLGrid.OptimizeColumns; ***}\r\n\r\nfunction TJvControlActionDBGridEngine.SupportsComponent(aActionComponent:\r\n TComponent): Boolean;\r\nbegin\r\n Result := aActionComponent is TCustomDBGrid;\r\nend;\r\n\r\ninitialization\r\n {$IFDEF UNITVERSIONING}\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n {$ENDIF UNITVERSIONING}\r\n InitActionEngineList;\r\n\r\nfinalization\r\n {$IFDEF UNITVERSIONING}\r\n UnregisterUnitVersion(HInstance);\r\n {$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvControlActionsEngineStringGrid.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvDBActions.Pas, released on 2007-03-11.\r\n\r\nThe Initial Developer of the Original Code is Jens Fudickar [jens dott fudicker att oratool dott de]\r\nPortions created by Jens Fudickar are Copyright (C) 2002 Jens Fudickar.\r\nAll Rights Reserved.\r\n\r\nContributor(s): -\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvControlActionsEngineStringGrid.pas 13138 2011-10-26 23:17:50Z jfudickar $\r\n\r\nunit JvControlActionsEngineStringGrid;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n {$IFDEF MSWINDOWS}\r\n Windows, Graphics,\r\n {$ENDIF MSWINDOWS}\r\n {$IFDEF UNIX}\r\n QWindows, QImgList, QGraphics, QComCtrls,\r\n {$ENDIF UNIX}\r\n Forms, Controls, Classes, Grids, JvControlActionsEngine;\r\n\r\ntype\r\n\r\n\r\n TJvControlActionStringGridEngine = class(TJvControlActionEngine)\r\n private\r\n protected\r\n function GetGrid(AActionComponent: TComponent): TStringGrid;\r\n function GetSupportedOperations: TJvControlActionOperations; override;\r\n public\r\n function ExecuteOperation(const aOperation: TJvControlActionOperation; const\r\n aActionControl: TControl): Boolean; override;\r\n procedure OptimizeColumns(Grid: TStringGrid);\r\n function SupportsComponent(aActionComponent: TComponent): Boolean; override;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvControlActionsEngineStringGrid.pas $';\r\n Revision: '$Revision: 13138 $';\r\n Date: '$Date: 2011-10-27 01:17:50 +0200 (jeu. 27 oct. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n SysUtils, Variants;\r\n\r\nType TAccessStringGrid = class(TStringGrid);\r\n\r\nprocedure InitActionEngineList;\r\nbegin\r\n RegisterControlActionEngine (TJvControlActionStringGridEngine);\r\nend;\r\n\r\nfunction TJvControlActionStringGridEngine.ExecuteOperation(const aOperation:\r\n TJvControlActionOperation; const aActionControl: TControl): Boolean;\r\nbegin\r\n Result := true;\r\n if Assigned(aActionControl) and (aActionControl is TStringGrid) then\r\n Case aOperation of\r\n caoOptimizeColumns: OptimizeColumns(GetGrid(aActionControl));\r\n else\r\n Result := false;\r\n End\r\n else\r\n Result := false;\r\nend;\r\n\r\nfunction TJvControlActionStringGridEngine.GetGrid(AActionComponent:\r\n TComponent): TStringGrid;\r\nbegin\r\n if Assigned(AActionComponent) then\r\n if AActionComponent is TStringGrid then\r\n Result := TStringGrid(AActionComponent)\r\n else\r\n Result := nil\r\n else\r\n Result := nil;\r\nend;\r\n\r\nfunction TJvControlActionStringGridEngine.GetSupportedOperations:\r\n TJvControlActionOperations;\r\nbegin\r\n Result := [caoOptimizeColumns];\r\nend;\r\n\r\nprocedure TJvControlActionStringGridEngine.OptimizeColumns(Grid: TStringGrid);\r\nvar\r\n Row: Integer;\r\n Col: Integer;\r\nbegin\r\n if not Assigned(Grid) then\r\n Exit;\r\n try\r\n for Col := 0 to Grid.ColCount - 1 do\r\n begin\r\n TAccessStringGrid(Grid).ColWidths[Col] := 0;\r\n for Row := 0 to Grid.RowCount - 1 do\r\n begin\r\n if TAccessStringGrid(Grid).Canvas.TextWidth(Grid.Cells[Col, Row] + ' ') > TAccessStringGrid(Grid).ColWidths[Col] then\r\n TAccessStringGrid(Grid).ColWidths[Col] := TAccessStringGrid(Grid).Canvas.TextWidth(Grid.Cells[Col, Row] + ' ')\r\n end; {*** FOR Spalte := 0 TO DataSet.FieldCount-1 DO ***}\r\n end;\r\n finally\r\n end;\r\nend; {*** procedure TxSQLGrid.OptimizeColumns; ***}\r\n\r\nfunction TJvControlActionStringGridEngine.SupportsComponent(aActionComponent:\r\n TComponent): Boolean;\r\nbegin\r\n Result := aActionComponent is TStringGrid;\r\nend;\r\n\r\ninitialization\r\n {$IFDEF UNITVERSIONING}\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n {$ENDIF UNITVERSIONING}\r\n InitActionEngineList;\r\n\r\nfinalization\r\n {$IFDEF UNITVERSIONING}\r\n UnregisterUnitVersion(HInstance);\r\n {$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvControlActionsEngineTreeView.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvDBActions.Pas, released on 2007-03-11.\r\n\r\nThe Initial Developer of the Original Code is Jens Fudickar [jens dott fudicker att oratool dott de]\r\nPortions created by Jens Fudickar are Copyright (C) 2002 Jens Fudickar.\r\nAll Rights Reserved.\r\n\r\nContributor(s): -\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvControlActionsEngineTreeView.pas 13138 2011-10-26 23:17:50Z jfudickar $\r\n\r\nunit JvControlActionsEngineTreeView;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n {$IFDEF MSWINDOWS}\r\n Windows, Graphics, ComCtrls,\r\n {$ENDIF MSWINDOWS}\r\n {$IFDEF UNIX}\r\n QWindows, QImgList, QGraphics, QComCtrls,\r\n {$ENDIF UNIX}\r\n Forms, Controls, Classes, JvControlActionsEngine;\r\n\r\ntype\r\n\r\n\r\n TJvControlActionTreeViewEngine = class(TJvControlActionEngine)\r\n private\r\n protected\r\n function GetSupportedOperations: TJvControlActionOperations; override;\r\n public\r\n function ExecuteOperation(const aOperation: TJvControlActionOperation; const\r\n aActionControl: TControl): Boolean; override;\r\n function SupportsComponent(aActionComponent: TComponent): Boolean; override;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvControlActionsEngineTreeView.pas $';\r\n Revision: '$Revision: 13138 $';\r\n Date: '$Date: 2011-10-27 01:17:50 +0200 (jeu. 27 oct. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n SysUtils, Variants, Dialogs;\r\n\r\n\r\nprocedure InitActionEngineList;\r\nbegin\r\n RegisterControlActionEngine (TJvControlActionTreeViewEngine);\r\nend;\r\n\r\nfunction TJvControlActionTreeViewEngine.ExecuteOperation(const aOperation:\r\n TJvControlActionOperation; const aActionControl: TControl): Boolean;\r\nbegin\r\n Result := true;\r\n if Assigned(aActionControl) and (aActionControl is TCustomTreeView) then\r\n Case aOperation of\r\n caoCollapse : TCustomTreeView(aActionControl).FullCollapse;\r\n caoExpand : TCustomTreeView(aActionControl).FullExpand;\r\n else\r\n Result := false;\r\n End\r\n else\r\n Result := false;\r\nend;\r\n\r\nfunction TJvControlActionTreeViewEngine.GetSupportedOperations:\r\n TJvControlActionOperations;\r\nbegin\r\n Result := [caoCollapse, caoExpand];\r\nend;\r\n\r\nfunction TJvControlActionTreeViewEngine.SupportsComponent(aActionComponent:\r\n TComponent): Boolean;\r\nbegin\r\n Result := aActionComponent is TCustomTreeView;\r\nend;\r\n\r\ninitialization\r\n {$IFDEF UNITVERSIONING}\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n {$ENDIF UNITVERSIONING}\r\n InitActionEngineList;\r\n\r\nfinalization\r\n {$IFDEF UNITVERSIONING}\r\n UnregisterUnitVersion(HInstance);\r\n {$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvControlBar.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvControlBar.PAS, released on 2001-02-28.\r\n\r\nThe Initial Developer of the Original Code is Sbastien Buysse [sbuysse att buypin dott com]\r\nPortions created by Sbastien Buysse are Copyright (C) 2001 Sbastien Buysse.\r\nAll Rights Reserved.\r\n\r\nContributor(s): Michael Beck [mbeck att bigfoot dott com].\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvControlBar.pas 13104 2011-09-07 06:50:43Z obones $\r\n\r\nunit JvControlBar;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, Classes, Graphics, Controls, Menus,\r\n JvExControls, JvExExtCtrls, JvAppStorage;\r\n\r\ntype\r\n TPopupNames = (pnHint, pnName);\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvControlBar = class(TJvExControlBar, IJvDenySubClassing,\r\n IJvAppStorageHandler, IJvAppStoragePublishedProps)\r\n private\r\n FPopupControl: Boolean;\r\n FPopup: TPopupMenu;\r\n FPopupNames: TPopupNames;\r\n FList: TList;\r\n protected\r\n procedure ReadFromAppStorage(AppStorage: TJvCustomAppStorage; const BasePath: string); virtual;\r\n procedure WriteToAppStorage(AppStorage: TJvCustomAppStorage; const BasePath: string); virtual;\r\n function DoEraseBackground(Canvas: TCanvas; Param: LPARAM): Boolean; override;\r\n procedure DoAddDockClient(Client: TControl; const ARect: TRect); override;\r\n procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;\r\n procedure PopupMenuClick(Sender: TObject);\r\n procedure Loaded; override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n procedure LoadPositions(const Value: string);\r\n function SavePositions: string;\r\n published\r\n property HintColor;\r\n {$IFDEF JVCLThemesEnabled}\r\n property ParentBackground;\r\n {$ENDIF JVCLThemesEnabled}\r\n property PopupControl: Boolean read FPopupControl write FPopupControl default True;\r\n property PopupNames: TPopupNames read FPopupNames write FPopupNames default pnHint;\r\n property OnMouseEnter;\r\n property OnMouseLeave;\r\n property OnParentColorChange;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvControlBar.pas $';\r\n Revision: '$Revision: 13104 $';\r\n Date: '$Date: 2011-09-07 08:50:43 +0200 (mer. 07 sept. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n SysUtils,\r\n JvThemes;\r\n\r\nconst\r\n cFalse = 'false';\r\n cTrue = 'true';\r\n cUndocked = 'undocked';\r\n\r\nconstructor TJvControlBar.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FList := TList.Create;\r\n FPopupControl := True;\r\n FPopupNames := pnHint;\r\n ControlStyle := ControlStyle + [csAcceptsControls];\r\n IncludeThemeStyle(Self, [csParentBackground]);\r\nend;\r\n\r\ndestructor TJvControlBar.Destroy;\r\nbegin\r\n FList.Free;\r\n FPopup.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJvControlBar.DoEraseBackground(Canvas: TCanvas; Param: LPARAM): Boolean;\r\nbegin\r\n if Picture.Graphic <> nil then\r\n Result := inherited DoEraseBackground(Canvas, Param)\r\n else\r\n begin\r\n DrawThemedBackground(Self, Canvas.Handle, ClientRect, Parent.Brush.Handle);\r\n Result := True;\r\n end;\r\nend;\r\n\r\nprocedure TJvControlBar.MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);\r\n\r\n procedure DoAddControl(const AControl: TControl; const Index: Integer);\r\n var\r\n It: TMenuItem;\r\n begin\r\n It := TMenuItem.Create(FPopup);\r\n if PopupNames = pnHint then\r\n It.Caption := AControl.Hint\r\n else\r\n It.Caption := AControl.Name;\r\n It.AutoCheck := True;\r\n It.Tag := Index;\r\n It.OnClick := PopupMenuClick;\r\n It.Checked := AControl.Visible;\r\n FPopup.Items.Add(It);\r\n end;\r\n\r\nvar\r\n I: Integer;\r\n Pt: TPoint;\r\nbegin\r\n inherited MouseUp(Button, Shift, X, Y);\r\n if PopupControl and (Button = mbRight) then\r\n begin\r\n if FPopup <> nil then\r\n FPopup.Items.Clear\r\n else\r\n FPopup := TPopupMenu.Create(Self);\r\n for I := 0 to FList.Count - 1 do\r\n DoAddControl(TControl(FList[I]), I);\r\n Pt := ClientToScreen(Point(X, Y));\r\n FPopup.Popup(Pt.X, Pt.Y);\r\n end;\r\nend;\r\n\r\nprocedure TJvControlBar.PopupMenuClick(Sender: TObject);\r\nbegin\r\n with Sender as TMenuItem do\r\n begin\r\n if (Tag >= 0) and (Tag < FList.Count) then\r\n TControl(FList[Tag]).Visible := Checked;\r\n end;\r\nend;\r\n\r\nprocedure TJvControlBar.LoadPositions(const Value: string);\r\nvar\r\n St, St2: string;\r\n I, J: Integer;\r\n LLeft, LTop: Integer;\r\n LDocked: Boolean;\r\nbegin\r\n St := Value;\r\n J := 0;\r\n while (Length(St) > 1) and (J < FList.Count) do\r\n begin\r\n I := Pos(';', St);\r\n if I = 0 then\r\n begin\r\n St2 := St;\r\n St := '';\r\n end\r\n else\r\n begin\r\n St2 := Copy(St, 1, I - 1);\r\n St := Copy(St, I + 1, Length(St));\r\n end;\r\n\r\n I := Pos(',', St2);\r\n if I <> 0 then\r\n begin\r\n TControl(FList[J]).Visible := Pos(cTrue, St2) = 1;\r\n St2 := Copy(St2, I + 1, Length(St2));\r\n I := Pos(',', St2);\r\n if I <> 0 then\r\n begin\r\n LLeft := StrToIntDef(Copy(St2, 1, I - 1), TControl(FList[J]).Left);\r\n LDocked := True;\r\n St2 := Copy(St2, I + 1, Length(St2));\r\n I := Pos(',', St2);\r\n if I <> 0 then\r\n begin\r\n if Pos(cUndocked, St2) <> 0 then\r\n LDocked := False;\r\n St2 := Copy(St2, 1, I - 1);\r\n end;\r\n if LDocked and (TControl(FList[J]).Parent <> Self) then\r\n TControl(FList[J]).ManualDock(Self)\r\n else\r\n if (not LDocked) and (TControl(FList[J]).Parent = Self) then\r\n TControl(FList[J]).ManualDock(nil);\r\n LTop := StrToIntDef(St2, TControl(FList[J]).Top);\r\n\r\n if ControlAtPos(Point(LLeft, TControl(FList[J]).Top), True) <> nil then\r\n begin\r\n TControl(FList[J]).Left := LLeft;\r\n TControl(FList[J]).Top := LTop;\r\n end\r\n else\r\n begin\r\n TControl(FList[J]).Top := LTop;\r\n TControl(FList[J]).Left := LLeft;\r\n end;\r\n end;\r\n end;\r\n Inc(J);\r\n end;\r\nend;\r\n\r\nfunction TJvControlBar.SavePositions: string;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := '';\r\n for I := 0 to FList.Count - 1 do\r\n begin\r\n if TControl(FList[I]).Visible then\r\n Result := Result + cTrue + ','\r\n else\r\n Result := Result + cFalse + ',';\r\n Result := Result + IntToStr(TControl(FList[I]).Left) + ',' +\r\n IntToStr(TControl(FList[I]).Top);\r\n if TControl(FList[I]).Parent <> Self then\r\n Result := Result + ',' + cUndocked;\r\n Result := Result + ';';\r\n end;\r\nend;\r\n\r\nprocedure TJvControlBar.Loaded;\r\nvar\r\n I: Integer;\r\nbegin\r\n inherited Loaded;\r\n for I := 0 to ControlCount - 1 do\r\n FList.Add(Controls[I]);\r\nend;\r\n\r\n\r\nprocedure TJvControlBar.DoAddDockClient(Client: TControl; const ARect: TRect);\r\nbegin\r\n inherited DoAddDockClient(Client, ARect);\r\n if FList.IndexOf(Client) = -1 then\r\n FList.Add(Client);\r\nend;\r\n\r\n\r\nprocedure TJvControlBar.ReadFromAppStorage(AppStorage: TJvCustomAppStorage; const BasePath: string);\r\nbegin\r\n LoadPositions(AppStorage.ReadString(BasePath));\r\nend;\r\n\r\nprocedure TJvControlBar.WriteToAppStorage(AppStorage: TJvCustomAppStorage; const BasePath: string);\r\nbegin\r\n AppStorage.WriteString(BasePath, SavePositions);\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvControlComponent.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp:{www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvControlComponent.pas, released on 2004-09-21\r\n\r\nThe Initial Developer of the Original Code is Andr Snepvangers [ASnepvangers att users.sourceforge.net]\r\nPortions created by Andr Snepvangers are Copyright (C) 2004 Andr Snepvangers.\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http:{jvcl.sourceforge.net\r\n\r\nKnown Issues:\r\n It is still possible to move the component in IDE outside the parent.\r\n It could also be called as a feature. Object Treeview shows the\r\n correct parent.\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvControlComponent.pas 12337 2009-06-11 10:42:10Z ahuser $\r\n\r\nunit JvControlComponent;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n SysUtils, Classes, Windows, Messages, Controls, Forms,\r\n JvComponentBase;\r\n\r\ntype\r\n TJvCustomControlComponent = class(TJvComponent)\r\n private\r\n FActive: Boolean;\r\n FParent: TWinControl;\r\n function GetDesignInfo: Longint;\r\n procedure SetDesignInfo(Value: Longint);\r\n protected\r\n procedure SetParent(const Value: TWinControl); virtual;\r\n function GetParent: TWinControl; virtual;\r\n procedure Loaded; override;\r\n procedure SetParentComponent(Value: TComponent); override;\r\n property Active: Boolean read FActive write FActive;\r\n public\r\n function GetParentComponent: TComponent; override;\r\n property DesignInfo: Longint read GetDesignInfo write SetDesignInfo;\r\n property Parent: TWinControl read GetParent write SetParent;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvControlComponent.pas $';\r\n Revision: '$Revision: 12337 $';\r\n Date: '$Date: 2009-06-11 12:42:10 +0200 (jeu. 11 juin 2009) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nprocedure TJvCustomControlComponent.SetParentComponent(Value: TComponent);\r\nbegin\r\n SetParent(TWinControl(Value));\r\nend;\r\n\r\nprocedure TJvCustomControlComponent.SetParent(const Value: TWinControl);\r\nbegin\r\n if Value <> Parent then\r\n FParent := Value;\r\nend;\r\n\r\nfunction TJvCustomControlComponent.GetParentComponent: TComponent;\r\nbegin\r\n Result := GetParent;\r\nend;\r\n\r\nfunction TJvCustomControlComponent.GetParent: TWinControl;\r\nbegin\r\n Result := FParent;\r\nend;\r\n\r\nprocedure TJvCustomControlComponent.Loaded;\r\nbegin\r\n inherited Loaded;\r\n if not (csDesigning in ComponentState) and Assigned(Parent) and (Parent <> Owner) then\r\n begin\r\n { Changing the owner to the parent, has the advantage that\r\n it gets destroyed by the Parent. At the right time thus.\r\n To access a component with the Object Inspector\r\n Owner property should remain unchanged.\r\n }\r\n if Assigned(Owner) then\r\n Owner.RemoveComponent(Self);\r\n Parent.InsertComponent(Self); { owner := parent }\r\n end;\r\nend;\r\n\r\nfunction TJvCustomControlComponent.GetDesignInfo: Longint;\r\nbegin\r\n Result := inherited DesignInfo;\r\nend;\r\n\r\nprocedure TJvCustomControlComponent.SetDesignInfo(Value: Longint);\r\nvar\r\n Pos: TPoint;\r\n FControl: TControl;\r\nbegin\r\n if (csDesigning in ComponentState) and (Owner is TWinControl) then\r\n begin\r\n Pos.X := TSmallPoint(Value).X; { left }\r\n Pos.Y := TSmallPoint(Value).Y; { top }\r\n if not Assigned(Parent) or (Parent = Owner) then { find the TWinControl where it is dropped }\r\n begin\r\n FControl := TWinControl(Owner).ControlAtPos(Pos, True, True);\r\n if not Assigned(FControl) then\r\n Parent := TWinControl(Owner)\r\n else\r\n if FControl is TControl then\r\n Parent := FControl.Parent\r\n else\r\n Parent := TWinControl(Parent);\r\n end;\r\n end;\r\n inherited DesignInfo := Value;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvControlPanelButton.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvControlPanel.PAS, released on 2001-02-28.\r\n\r\nThe Initial Developer of the Original Code is Sbastien Buysse [sbuysse att buypin dott com]\r\nPortions created by Sbastien Buysse are Copyright (C) 2001 Sbastien Buysse.\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\nMichael Beck [mbeck att bigfoot dott com].\r\nPeter Thrnqvist[peter3 at users dot sourceforge dot net]\r\nRemko Bonte [remkobonte att myrealbox dott com]\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvControlPanelButton.pas 13155 2011-11-06 12:31:20Z ahuser $\r\n\r\nunit JvControlPanelButton;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, Classes, Controls, Menus, ImgList,\r\n JvTypes, JvButton, JvComputerInfoEx;\r\n\r\ntype\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvControlPanelButton = class(TJvCustomButton)\r\n private\r\n FPopup: TPopupMenu;\r\n FDirs: TJvSystemFolders;\r\n FOnLinkClick: TJvLinkClickEvent;\r\n FImages: TCustomImageList;\r\n procedure AddToPopup(Item: TMenuItem; Path: string);\r\n procedure SetImages(const Value: TCustomImageList);\r\n protected\r\n procedure DoLinkClick(Sender: TObject);\r\n procedure Notification(AComponent: TComponent; Operation: TOperation); override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n procedure CreateParams(var Params: TCreateParams); override;\r\n procedure Click; override;\r\n procedure Refresh;\r\n published\r\n property Images: TCustomImageList read FImages write SetImages;\r\n property OnLinkClick: TJvLinkClickEvent read FOnLinkClick write FOnLinkClick;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvControlPanelButton.pas $';\r\n Revision: '$Revision: 13155 $';\r\n Date: '$Date: 2011-11-06 13:31:20 +0100 (dim. 06 nov. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n Graphics,\r\n JvJVCLUtils;\r\n\r\nconstructor TJvControlPanelButton.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FDirs := TJvSystemFolders.Create;\r\n FPopup := TPopupMenu.Create(Self);\r\nend;\r\n\r\ndestructor TJvControlPanelButton.Destroy;\r\nvar\r\n I: Integer;\r\nbegin\r\n FDirs.Free;\r\n if Images = nil then\r\n for I := 0 to FPopup.Items.Count - 1 do\r\n FPopup.Items[I].Bitmap.FreeImage;\r\n FPopup.Free;\r\n inherited Destroy;\r\nend;\r\n\r\n// (rom) a strange place for doing this\r\n\r\nprocedure TJvControlPanelButton.CreateParams(var Params: TCreateParams);\r\nbegin\r\n inherited CreateParams(Params);\r\n if not (csDesigning in ComponentState) then\r\n Refresh;\r\nend;\r\n\r\nprocedure TJvControlPanelButton.AddToPopup(Item: TMenuItem; Path: string);\r\nvar\r\n I: Integer;\r\n It: TMenuItem;\r\n S: TStringList;\r\n B: TBitmap;\r\nbegin\r\n S := TStringList.Create;\r\n try\r\n GetControlPanelApplets(Path, '*.cpl', S, Images);\r\n S.Sort;\r\n for I := 0 to S.Count - 1 do\r\n begin\r\n It := TMenuItem.Create(Self);\r\n It.Caption := S.Names[I];\r\n It.OnClick := DoLinkClick;\r\n It.Hint := S.Values[S.Names[I]];\r\n if Images <> nil then\r\n It.ImageIndex := Integer(S.Objects[I])\r\n else\r\n begin\r\n B := TBitmap(S.Objects[I]);\r\n It.Bitmap.Assign(B);\r\n B.Free;\r\n end;\r\n Item.Add(It);\r\n // (rom) seems of no use\r\n //Application.ProcessMessages;\r\n end;\r\n finally\r\n S.Free;\r\n end;\r\nend;\r\n\r\nprocedure TJvControlPanelButton.Click;\r\nvar\r\n P: TPoint;\r\nbegin\r\n inherited Click;\r\n if Parent <> nil then\r\n begin\r\n P := Parent.ClientToScreen(Point(Left, Top + Height));\r\n FPopup.Popup(P.X, P.Y);\r\n end;\r\nend;\r\n\r\nprocedure TJvControlPanelButton.Notification(AComponent: TComponent;\r\n Operation: TOperation);\r\nbegin\r\n inherited Notification(AComponent, Operation);\r\n if (Operation = opRemove) and (AComponent = FImages) then\r\n Images := nil; // (p3) calls Refresh\r\nend;\r\n\r\nprocedure TJvControlPanelButton.Refresh;\r\nvar\r\n St: string;\r\nbegin\r\n while FPopup.Items.Count > 0 do\r\n FPopup.Items.Delete(0);\r\n St := FDirs.System;\r\n if St[Length(St)] <> '\\' then\r\n St := St + '\\';\r\n FPopup.Images := Images;\r\n AddToPopup(TMenuItem(FPopup.Items), St);\r\n PopupMenu := FPopup;\r\nend;\r\n\r\nprocedure TJvControlPanelButton.SetImages(const Value: TCustomImageList);\r\nbegin\r\n if ReplaceComponentReference(Self, Value, TComponent(FImages)) then\r\n Refresh;\r\nend;\r\n\r\nprocedure TJvControlPanelButton.DoLinkClick(Sender: TObject);\r\nbegin\r\n if Assigned(FOnLinkClick) then\r\n FOnLinkClick(Self, (Sender as TMenuItem).Hint);\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvConverter.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvDataConv.PAS, released on 2002-07-04.\r\n\r\nThe Initial Developers of the Original Code are: Fedor Koshevnikov, Igor Pavluk and Serge Korolev\r\nCopyright (c) 1997, 1998 Fedor Koshevnikov, Igor Pavluk and Serge Korolev\r\nCopyright (c) 2001,2002 SGB Software\r\nAll Rights Reserved.\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvConverter.pas 13104 2011-09-07 06:50:43Z obones $\r\n\r\nunit JvConverter;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Classes, SysUtils,\r\n JvComponentBase, JvTypes;\r\n\r\ntype\r\n\r\n TDataType =\r\n (dtString, dtInteger, dtFloat, dtDateTime, dtDate, dtTime, dtBoolean);\r\n\r\n TTimeFormat = (tfHHMMSS, tfHMMSS, tfHHMM, tfHMM);\r\n\r\n TJvDateTimeFormat = class(TPersistent)\r\n private\r\n FAMString: string;\r\n FPMString: string;\r\n FDateOrder: TDateOrder;\r\n FTimeFormat: TTimeFormat;\r\n FTimeSeparator: Char;\r\n FDateSeparator: Char;\r\n FLongDate: Boolean;\r\n FFourDigitYear: Boolean;\r\n FLeadingZero: Boolean;\r\n function GetAMString: string;\r\n procedure SetAMString(const Value: string);\r\n function GetPMString: string;\r\n procedure SetPMString(const Value: string);\r\n protected\r\n function GetDateMask: string; virtual;\r\n function GetTimeMask: string; virtual;\r\n function GetMask: string; virtual;\r\n public\r\n constructor Create;\r\n procedure Assign(Source: TPersistent); override;\r\n procedure ResetDefault; virtual;\r\n property DateMask: string read GetDateMask;\r\n property TimeMask: string read GetTimeMask;\r\n property Mask: string read GetMask;\r\n published\r\n property AMString: string read GetAMString write SetAMString;\r\n property PMString: string read GetPMString write SetPMString;\r\n property DateOrder: TDateOrder read FDateOrder write FDateOrder;\r\n property TimeFormat: TTimeFormat read FTimeFormat write FTimeFormat;\r\n property TimeSeparator: Char read FTimeSeparator write FTimeSeparator;\r\n property DateSeparator: Char read FDateSeparator write FDateSeparator;\r\n property LongDate: Boolean read FLongDate write FLongDate default False;\r\n property FourDigitYear: Boolean read FFourDigitYear write FFourDigitYear default True;\r\n property LeadingZero: Boolean read FLeadingZero write FLeadingZero default False;\r\n end;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64 or pidOSX32)]\r\n {$ENDIF RTL230_UP}\r\n TJvConverter = class(TJvComponent)\r\n private\r\n FData: string;\r\n FTextValues: array [Boolean] of string;\r\n FDataType: TDataType;\r\n FDateTimeFormat: TJvDateTimeFormat;\r\n FFloatFormat: TFloatFormat;\r\n FDigits: Integer;\r\n FPrecision: Integer;\r\n FRaiseOnError: Boolean;\r\n FOnChange: TNotifyEvent;\r\n procedure SetDataType(Value: TDataType);\r\n procedure SetDateTimeFormat(Value: TJvDateTimeFormat);\r\n function GetDateTimeFormat: TJvDateTimeFormat;\r\n function GetString: string;\r\n procedure SetString(const Value: string);\r\n function GetDateTime: TDateTime;\r\n function GetBoolValues(Index: Integer): string;\r\n procedure SetBoolValues(Index: Integer; const Value: string);\r\n procedure CheckDataType;\r\n function BoolToStr(Value: Boolean): string;\r\n function FloatToString(Value: Double): string;\r\n function DateTimeToString(Value: TDateTime): string;\r\n protected\r\n procedure Change; dynamic;\r\n function GetAsBoolean: Boolean; virtual;\r\n function GetAsDateTime: TDateTime; virtual;\r\n function GetAsDate: TDateTime; virtual;\r\n function GetAsTime: TDateTime; virtual;\r\n function GetAsFloat: Double; virtual;\r\n function GetAsInteger: Longint; virtual;\r\n function GetAsString: string; virtual;\r\n procedure SetAsBoolean(Value: Boolean); virtual;\r\n procedure SetAsDateTime(Value: TDateTime); virtual;\r\n procedure SetAsDate(Value: TDateTime); virtual;\r\n procedure SetAsTime(Value: TDateTime); virtual;\r\n procedure SetAsFloat(Value: Double); virtual;\r\n procedure SetAsInteger(Value: Longint); virtual;\r\n procedure SetAsString(const Value: string); virtual;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n procedure Clear;\r\n function IsValidChar(Ch: Char): Boolean; virtual;\r\n property AsBoolean: Boolean read GetAsBoolean write SetAsBoolean;\r\n property AsDateTime: TDateTime read GetAsDateTime write SetAsDateTime;\r\n property AsDate: TDateTime read GetAsDate write SetAsDate;\r\n property AsTime: TDateTime read GetAsTime write SetAsTime;\r\n property AsFloat: Double read GetAsFloat write SetAsFloat;\r\n property AsInteger: Longint read GetAsInteger write SetAsInteger;\r\n property AsString: string read GetAsString write SetAsString;\r\n published\r\n property DataType: TDataType read FDataType write SetDataType default dtString;\r\n property DateTimeFormat: TJvDateTimeFormat read GetDateTimeFormat write SetDateTimeFormat;\r\n property Digits: Integer read FDigits write FDigits default 2;\r\n property DisplayFalse: string index 0 read GetBoolValues write SetBoolValues;\r\n property DisplayTrue: string index 1 read GetBoolValues write SetBoolValues;\r\n property FloatFormat: TFloatFormat read FFloatFormat write FFloatFormat default ffGeneral;\r\n property Precision: Integer read FPrecision write FPrecision default 15;\r\n property RaiseOnError: Boolean read FRaiseOnError write FRaiseOnError default False;\r\n property Text: string read GetString write SetAsString;\r\n property OnChange: TNotifyEvent read FOnChange write FOnChange;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvConverter.pas $';\r\n Revision: '$Revision: 13104 $';\r\n Date: '$Date: 2011-09-07 08:50:43 +0200 (mer. 07 sept. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n {$IFNDEF COMPILER12_UP}\r\n JvJCLUtils,\r\n {$ENDIF ~COMPILER12_UP}\r\n JvConsts, JvResources, JclSysUtils;\r\n\r\n//=== { TJvDateTimeFormat } ==================================================\r\n\r\nconstructor TJvDateTimeFormat.Create;\r\nbegin\r\n inherited Create;\r\n ResetDefault;\r\nend;\r\n\r\nprocedure TJvDateTimeFormat.ResetDefault;\r\nbegin\r\n FAMString := JclFormatSettings.TimeAMString;\r\n FPMString := JclFormatSettings.TimePMString;\r\n FTimeSeparator := JclFormatSettings.TimeSeparator;\r\n FDateSeparator := JclFormatSettings.DateSeparator;\r\n FDateOrder := doDMY;\r\n FTimeFormat := tfHHMMSS;\r\n FLongDate := False;\r\n FFourDigitYear := True;\r\n FLeadingZero := False;\r\nend;\r\n\r\nprocedure TJvDateTimeFormat.Assign(Source: TPersistent);\r\nbegin\r\n if Source is TJvDateTimeFormat then\r\n begin\r\n FAMString := TJvDateTimeFormat(Source).AMString;\r\n FPMString := TJvDateTimeFormat(Source).PMString;\r\n FDateOrder := TJvDateTimeFormat(Source).DateOrder;\r\n FTimeFormat := TJvDateTimeFormat(Source).TimeFormat;\r\n FTimeSeparator := TJvDateTimeFormat(Source).TimeSeparator;\r\n FDateSeparator := TJvDateTimeFormat(Source).DateSeparator;\r\n FLongDate := TJvDateTimeFormat(Source).LongDate;\r\n FFourDigitYear := TJvDateTimeFormat(Source).FourDigitYear;\r\n FLeadingZero := TJvDateTimeFormat(Source).LeadingZero;\r\n end\r\n else\r\n inherited Assign(Source);\r\nend;\r\n\r\nfunction TJvDateTimeFormat.GetAMString: string;\r\nbegin\r\n Result := FAMString;\r\nend;\r\n\r\nprocedure TJvDateTimeFormat.SetAMString(const Value: string);\r\nbegin\r\n if Value = '' then\r\n FAMString := JclFormatSettings.TimeAMString\r\n else\r\n FAMString := Value;\r\nend;\r\n\r\nfunction TJvDateTimeFormat.GetPMString: string;\r\nbegin\r\n Result := FPMString;\r\nend;\r\n\r\nprocedure TJvDateTimeFormat.SetPMString(const Value: string);\r\nbegin\r\n if Value = '' then\r\n FPMString := JclFormatSettings.TimePMString\r\n else\r\n FPMString := Value;\r\nend;\r\n\r\nfunction TJvDateTimeFormat.GetDateMask: string;\r\nvar\r\n S: array [1..3] of string;\r\n Separator: string;\r\nbegin\r\n Result := '';\r\n if LeadingZero then\r\n begin\r\n S[1] := 'dd';\r\n S[2] := 'mm';\r\n end\r\n else\r\n begin\r\n S[1] := 'd';\r\n S[2] := 'm';\r\n end;\r\n if LongDate then\r\n begin\r\n S[2] := 'mmmm';\r\n Separator := ' ';\r\n end\r\n else\r\n Separator := '\"' + DateSeparator + '\"';\r\n if FourDigitYear then\r\n S[3] := 'yyyy'\r\n else\r\n S[3] := 'yy';\r\n case DateOrder of\r\n doDMY:\r\n Result := S[1] + Separator + S[2] + Separator + S[3];\r\n doMDY:\r\n Result := S[2] + Separator + S[1] + Separator + S[3];\r\n doYMD:\r\n Result := S[3] + Separator + S[2] + Separator + S[1];\r\n end;\r\nend;\r\n\r\nfunction TJvDateTimeFormat.GetTimeMask: string;\r\nvar\r\n S: array [1..3] of string;\r\n Separator: string;\r\n AMPM: string;\r\nbegin\r\n Separator := '\"' + TimeSeparator + '\"';\r\n AMPM := ' ' + AMString + '/' + PMString;\r\n if LeadingZero then\r\n begin\r\n S[1] := 'hh';\r\n S[2] := 'nn';\r\n S[3] := 'ss';\r\n end\r\n else\r\n begin\r\n S[1] := 'h';\r\n S[2] := 'n';\r\n S[3] := 's';\r\n end;\r\n case TimeFormat of\r\n tfHHMMSS:\r\n Result := S[1] + Separator + S[2] + Separator + S[3];\r\n tfHMMSS:\r\n Result := S[1] + Separator + S[2] + Separator + S[3] + AMPM;\r\n tfHHMM:\r\n Result := S[1] + Separator + S[2];\r\n tfHMM:\r\n Result := S[1] + Separator + S[2] + AMPM;\r\n end;\r\nend;\r\n\r\nfunction TJvDateTimeFormat.GetMask: string;\r\nbegin\r\n Result := GetDateMask + ' ' + GetTimeMask;\r\nend;\r\n\r\n//=== { TJvConverter } =======================================================\r\n\r\nconstructor TJvConverter.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FData := '';\r\n FDataType := dtString;\r\n FPrecision := 15;\r\n FDigits := 2;\r\n FDateTimeFormat := TJvDateTimeFormat.Create;\r\n FTextValues[False] := RsFalse;\r\n FTextValues[True] := RsTrue;\r\n FRaiseOnError := False;\r\nend;\r\n\r\ndestructor TJvConverter.Destroy;\r\nbegin\r\n FDataType := dtString;\r\n //if (FData <> nil) and (FData^ <> '') then Dispose(FData);\r\n FDateTimeFormat.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvConverter.Clear;\r\nbegin\r\n //if (FData <> nil) and (FData^ <> '') then Dispose(FData);\r\n FData := '';\r\n Change;\r\nend;\r\n\r\nprocedure TJvConverter.Change;\r\nbegin\r\n if Assigned(FOnChange) then\r\n FOnChange(Self);\r\nend;\r\n\r\nfunction TJvConverter.GetString: string;\r\nbegin\r\n Result := FData;\r\nend;\r\n\r\nprocedure TJvConverter.SetString(const Value: string);\r\nbegin\r\n FData := Value;\r\nend;\r\n\r\nfunction TJvConverter.GetDateTimeFormat: TJvDateTimeFormat;\r\nbegin\r\n Result := FDateTimeFormat;\r\nend;\r\n\r\nprocedure TJvConverter.SetDateTimeFormat(Value: TJvDateTimeFormat);\r\nbegin\r\n FDateTimeFormat.Assign(Value);\r\nend;\r\n\r\nfunction TJvConverter.GetBoolValues(Index: Integer): string;\r\nbegin\r\n Result := FTextValues[Boolean(Index)];\r\nend;\r\n\r\nprocedure TJvConverter.SetBoolValues(Index: Integer; const Value: string);\r\nbegin\r\n FTextValues[Index <> 0] := Value;\r\nend;\r\n\r\nfunction TJvConverter.BoolToStr(Value: Boolean): string;\r\nbegin\r\n Result := GetBoolValues(Ord(Value));\r\nend;\r\n\r\nfunction TJvConverter.FloatToString(Value: Double): string;\r\nbegin\r\n Result := FloatToStrF(Value, FloatFormat, Precision, Digits);\r\nend;\r\n\r\nfunction TJvConverter.DateTimeToString(Value: TDateTime): string;\r\nbegin\r\n case FDataType of\r\n dtDate:\r\n Result := FormatDateTime(DateTimeFormat.DateMask, Value);\r\n dtTime:\r\n Result := FormatDateTime(DateTimeFormat.TimeMask, Value);\r\n else\r\n Result := FormatDateTime(DateTimeFormat.Mask, Value);\r\n end;\r\nend;\r\n\r\nprocedure TJvConverter.SetDataType(Value: TDataType);\r\nbegin\r\n if Value <> FDataType then\r\n begin\r\n FDataType := Value;\r\n try\r\n CheckDataType;\r\n Change;\r\n except\r\n Clear;\r\n if RaiseOnError then\r\n raise;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJvConverter.IsValidChar(Ch: Char): Boolean;\r\nbegin\r\n case FDataType of\r\n dtString:\r\n Result := True;\r\n dtInteger:\r\n Result := CharInSet(Ch, DigitSymbols + SignSymbols);\r\n dtFloat:\r\n Result := CharInSet(Ch, DigitSymbols + SignSymbols + [JclFormatSettings.DecimalSeparator, 'E', 'e']);\r\n dtDateTime, dtDate, dtTime:\r\n Result := True;\r\n dtBoolean:\r\n Result := True;\r\n else\r\n Result := False;\r\n end;\r\nend;\r\n\r\nprocedure TJvConverter.CheckDataType;\r\nbegin\r\n case FDataType of\r\n dtInteger, dtFloat:\r\n StrToFloat(GetString);\r\n dtDateTime, dtDate, dtTime:\r\n GetDateTime;\r\n end;\r\nend;\r\n\r\nfunction TJvConverter.GetAsBoolean: Boolean;\r\nvar\r\n S: string;\r\nbegin\r\n S := GetString;\r\n Result := (Length(S) > 0) and (CharInSet(S[1], ['T', 't', 'Y', 'y']) or\r\n (S = FTextValues[True]));\r\nend;\r\n\r\nfunction TJvConverter.GetDateTime: TDateTime;\r\nvar\r\n S: string;\r\n I: Integer;\r\n DateS, TimeS: TCharSet;\r\nbegin\r\n S := GetString;\r\n DateS := ['/', '.'] + [AnsiChar(DateTimeFormat.DateSeparator)] -\r\n [AnsiChar(DateTimeFormat.TimeSeparator)];\r\n TimeS := [':', '-'] - [AnsiChar(DateTimeFormat.DateSeparator)] +\r\n [AnsiChar(DateTimeFormat.TimeSeparator)];\r\n for I := 1 to Length(S) do\r\n begin\r\n if CharInSet(S[I], DateS) then\r\n S[I] := JclFormatSettings.DateSeparator\r\n else\r\n if CharInSet(S[I], TimeS) then\r\n S[I] := JclFormatSettings.TimeSeparator;\r\n end;\r\n Result := StrToDateTime(S);\r\nend;\r\n\r\nfunction TJvConverter.GetAsDateTime: TDateTime;\r\nbegin\r\n try\r\n Result := GetDateTime;\r\n except\r\n Result := NullDate;\r\n end;\r\nend;\r\n\r\nfunction TJvConverter.GetAsDate: TDateTime;\r\nvar\r\n Year, Month, Day: Word;\r\nbegin\r\n try\r\n Result := GetAsDateTime;\r\n DecodeDate(Result, Year, Month, Day);\r\n Result := EncodeDate(Year, Month, Day);\r\n except\r\n Result := NullDate;\r\n end;\r\nend;\r\n\r\nfunction TJvConverter.GetAsTime: TDateTime;\r\nvar\r\n Hour, Min, Sec, MSec: Word;\r\nbegin\r\n try\r\n Result := GetAsDateTime;\r\n DecodeTime(Result, Hour, Min, Sec, MSec);\r\n Result := EncodeTime(Hour, Min, Sec, MSec);\r\n except\r\n Result := NullDate;\r\n end;\r\nend;\r\n\r\nfunction TJvConverter.GetAsFloat: Double;\r\nbegin\r\n try\r\n case FDataType of\r\n dtDateTime:\r\n Result := GetAsDateTime;\r\n dtDate:\r\n Result := GetAsDate;\r\n dtTime:\r\n Result := GetAsTime;\r\n else\r\n Result := StrToFloat(GetString);\r\n end;\r\n except\r\n Result := 0.0;\r\n end;\r\nend;\r\n\r\nfunction TJvConverter.GetAsInteger: Longint;\r\nbegin\r\n Result := Round(GetAsFloat);\r\nend;\r\n\r\nfunction TJvConverter.GetAsString: string;\r\nbegin\r\n case FDataType of\r\n dtString:\r\n Result := GetString;\r\n dtInteger:\r\n Result := IntToStr(GetAsInteger);\r\n dtFloat:\r\n Result := FloatToString(GetAsFloat);\r\n dtDateTime:\r\n Result := DateTimeToString(GetAsDateTime);\r\n dtDate:\r\n Result := DateTimeToString(GetAsDate);\r\n dtTime:\r\n Result := DateTimeToString(GetAsTime);\r\n dtBoolean:\r\n Result := BoolToStr(GetAsBoolean);\r\n end;\r\nend;\r\n\r\nprocedure TJvConverter.SetAsBoolean(Value: Boolean);\r\nbegin\r\n SetAsString(BoolToStr(Value));\r\nend;\r\n\r\nprocedure TJvConverter.SetAsDateTime(Value: TDateTime);\r\nbegin\r\n SetAsString(DateTimeToStr(Value));\r\nend;\r\n\r\nprocedure TJvConverter.SetAsDate(Value: TDateTime);\r\nbegin\r\n SetAsDateTime(Value);\r\nend;\r\n\r\nprocedure TJvConverter.SetAsTime(Value: TDateTime);\r\nbegin\r\n SetAsDateTime(Value);\r\nend;\r\n\r\nprocedure TJvConverter.SetAsFloat(Value: Double);\r\nbegin\r\n if FDataType in [dtDateTime, dtDate, dtTime] then\r\n SetAsDateTime(Value)\r\n else\r\n SetAsString(FloatToStr(Value));\r\nend;\r\n\r\nprocedure TJvConverter.SetAsInteger(Value: Longint);\r\nbegin\r\n if FDataType = dtInteger then\r\n SetAsString(IntToStr(Value))\r\n else\r\n SetAsFloat(Value);\r\nend;\r\n\r\nprocedure TJvConverter.SetAsString(const Value: string);\r\nvar\r\n S: string;\r\nbegin\r\n S := GetString;\r\n SetString(Value);\r\n try\r\n CheckDataType;\r\n Change;\r\n except\r\n SetString(S);\r\n if RaiseOnError then\r\n raise;\r\n end;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvCoolBar.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvCoolBar.PAS, released on 2001-02-28.\r\n\r\nThe Initial Developer of the Original Code is Sbastien Buysse [sbuysse att buypin dott com]\r\nPortions created by Sbastien Buysse are Copyright (C) 2001 Sbastien Buysse.\r\nAll Rights Reserved.\r\n\r\nContributor(s): Michael Beck [mbeck att bigfoot dott com].\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvCoolBar.pas 13155 2011-11-06 12:31:20Z ahuser $\r\n\r\nunit JvCoolBar;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, Messages, Classes, Controls,\r\n JvExComCtrls;\r\n\r\ntype\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvCoolBar = class(TJvExCoolBar)\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n published\r\n property HintColor;\r\n property OnMouseEnter;\r\n property OnMouseLeave;\r\n property OnParentColorChange;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvCoolBar.pas $';\r\n Revision: '$Revision: 13155 $';\r\n Date: '$Date: 2011-11-06 13:31:20 +0100 (dim. 06 nov. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\n\r\nconstructor TJvCoolBar.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n ControlStyle := ControlStyle + [csAcceptsControls];\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend." }, { "path": "External/Jedi/Jvcl/run/JvCopyError.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvCopyError.PAS, released on 2001-02-28.\r\n\r\nThe Initial Developer of the Original Code is Sbastien Buysse [sbuysse att buypin dott com]\r\nPortions created by Sbastien Buysse are Copyright (C) 2001 Sbastien Buysse.\r\nAll Rights Reserved.\r\n\r\nContributor(s): Michael Beck [mbeck att bigfoot dott com].\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvCopyError.pas 13351 2012-06-13 15:16:00Z obones $\r\n\r\nunit JvCopyError;\r\n\r\n{$I jvcl.inc}\r\n{$I windowsonly.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, Classes,\r\n JvCustomFileMessageDialog, JvTypes;\r\n\r\ntype\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvCopyError = class(TJvCustomFileMessageDialog)\r\n private\r\n FPathToSource: string;\r\n FNewPath: string;\r\n FDiskName: string;\r\n FStyle: TJvDiskStyles;\r\n FWin32ErrorCode: Integer;\r\n FTargetFile: string;\r\n FSourceFile: string;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n function Execute: TJvDiskRes; override;\r\n published\r\n property DiskName: string read FDiskName write FDiskName;\r\n property PathToSource: string read FPathToSource write FPathToSource;\r\n property NewPath: string read FNewPath write FNewPath;\r\n property SourceFile: string read FSourceFile write FSourceFile;\r\n property TargetFile: string read FTargetFile write FTargetFile;\r\n property Win32ErrorCode: Integer read FWin32ErrorCode write FWin32ErrorCode default 0;\r\n property Style: TJvDiskStyles read FStyle write FStyle default [];\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvCopyError.pas $';\r\n Revision: '$Revision: 13351 $';\r\n Date: '$Date: 2012-06-13 17:16:00 +0200 (mer. 13 juin 2012) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n JclSysUtils,\r\n JvSetupApi;\r\n\r\nconstructor TJvCopyError.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FDiskName := '';\r\n FPathToSource := '';\r\n FNewPath := '';\r\n FStyle := [];\r\n FSourceFile := '';\r\n FTargetFile := '';\r\n FWin32ErrorCode := 0;\r\nend;\r\n\r\nfunction TJvCopyError.Execute: TJvDiskRes;\r\nvar\r\n Required: DWORD;\r\n Res: array [0..255] of Char;\r\nbegin\r\n case SetupCopyError(OwnerWindow, PCharOrNil(Title), PCharOrNil(DiskName),\r\n PChar(PathToSource), PChar(SourceFile), PCharOrNil(TargetFile),\r\n FWin32ErrorCode, JvDiskStylesToDWORD(Style), Res, SizeOf(Res), @Required) of\r\n DPROMPT_SUCCESS:\r\n begin\r\n FNewPath := Res;\r\n Result := dsSuccess;\r\n end;\r\n DPROMPT_CANCEL:\r\n Result := dsCancel;\r\n DPROMPT_SKIPFILE:\r\n Result := dsSkipfile;\r\n else\r\n Result := dsError;\r\n end;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvCpuUsage.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvCpuUsage.PAS, released on 2001-02-28.\r\n\r\nThe Initial Developer of the Original Code is Sbastien Buysse [sbuysse att buypin dott com]\r\nPortions created by Sbastien Buysse are Copyright (C) 2001 Sbastien Buysse.\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\n Michael Beck [mbeck att bigfoot dott com]\r\n Olivier Sannier [obones att altern dott org]\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvCpuUsage.pas 12677 2010-01-14 12:39:56Z obones $\r\n\r\nunit JvCpuUsage;\r\n\r\n{$I jvcl.inc}\r\n{$I windowsonly.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, Classes, Registry,\r\n JvComponentBase;\r\n\r\ntype\r\n TJvCpuUsage = class(TJvComponent)\r\n private\r\n // Used with GetSystemTimes\r\n FPrevIdleTimeGST: TDateTime;\r\n FPrevSystemTimeGST: TDateTime;\r\n\r\n // Used with NtQuerySystemInformation (because GetSystemTimes is not available)\r\n FPrevIdleTimeNQSI: LARGE_INTEGER;\r\n FPrevSystemTimeNQSI: LARGE_INTEGER;\r\n\r\n // Used when neither NtQuerySystemInformation nor GetSystemTimes are available\r\n FRegistry: TRegistry;\r\n\r\n function GetUsage: Double;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n published\r\n property Usage: Double read GetUsage;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvCpuUsage.pas $';\r\n Revision: '$Revision: 12677 $';\r\n Date: '$Date: 2010-01-14 13:39:56 +0100 (jeu. 14 janv. 2010) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n Math, SysUtils, JclDateTime;\r\n\r\nconst\r\n RC_CpuUsageKey = 'KERNEL\\CPUUsage';\r\n RC_PerfStart = 'PerfStats\\StartStat';\r\n RC_PerfStop = 'PerfStats\\StopStat';\r\n RC_PerfStat = 'PerfStats\\StatData';\r\n\r\nconst\r\n SystemBasicInformation = 0;\r\n SystemPerformanceInformation = 2;\r\n SystemTimeInformation = 3;\r\n\r\ntype\r\n TPDWord = ^DWORD;\r\n\r\n TSystem_Basic_Information = packed record\r\n dwUnknown1: DWORD;\r\n uKeMaximumIncrement: ULONG;\r\n uPageSize: ULONG;\r\n uMmNumberOfPhysicalPages: ULONG;\r\n uMmLowestPhysicalPage: ULONG;\r\n uMmHighestPhysicalPage: ULONG;\r\n uAllocationGranularity: ULONG;\r\n pLowestUserAddress: Pointer;\r\n pMmHighestUserAddress: Pointer;\r\n uKeActiveProcessors: ULONG;\r\n bKeNumberProcessors: byte;\r\n bUnknown2: byte;\r\n wUnknown3: word;\r\n end;\r\n\r\ntype\r\n TSystem_Performance_Information = packed record\r\n liIdleTime: LARGE_INTEGER; {LARGE_INTEGER}\r\n dwSpare: array[0..75] of DWORD;\r\n end;\r\n\r\ntype\r\n TSystem_Time_Information = packed record\r\n liKeBootTime: LARGE_INTEGER;\r\n liKeSystemTime: LARGE_INTEGER;\r\n liExpTimeZoneBias: LARGE_INTEGER;\r\n uCurrentTimeZoneId: ULONG;\r\n dwReserved: DWORD;\r\n end;\r\n\r\ntype\r\n TNtQuerySystemInformation = function(infoClass: DWORD;\r\n buffer: Pointer;\r\n bufSize: DWORD;\r\n returnSize: TPDword): DWORD; stdcall;\r\n\r\nvar\r\n NtQuerySystemInformation: TNtQuerySystemInformation;\r\n\r\n\r\ntype\r\n TGetSystemTimes = function (var lpIdleTime, lpKernelTime, lpUserTime: TFileTime): BOOL; stdcall;\r\n\r\nvar\r\n GetSystemTimes: TGetSystemTimes; \r\n\r\nfunction Li2Double(Value: LARGE_INTEGER): Double;\r\nbegin\r\n Result := (Value.HighPart * IntPower(2, 32)) + Value.LowPart;\r\nend;\r\n\r\nfunction GetCPUUsageNQSI(var PrevIdleTime: LARGE_INTEGER; var PrevSystemTime: LARGE_INTEGER): Double;\r\nvar\r\n SysBaseInfo: TSystem_Basic_Information;\r\n SysPerfInfo: TSystem_Performance_Information;\r\n SysTimeInfo: TSystem_Time_Information;\r\n Status: Integer;\r\n SystemTime: Double;\r\n IdleTime: Double;\r\nbegin\r\n Result := 0;\r\n\r\n if not Assigned(NtQuerySystemInformation) then\r\n Exit;\r\n\r\n Status := NtQuerySystemInformation(SystemBasicInformation, @SysBaseInfo, SizeOf(SysBaseInfo), nil);\r\n if Status <> 0 then\r\n Exit;\r\n\r\n // get new system time\r\n Status := NtQuerySystemInformation(SystemTimeInformation, @SysTimeInfo, SizeOf(SysTimeInfo), Nil);\r\n if Status <> 0 then\r\n Exit;\r\n\r\n // get new CPU's idle time\r\n Status := NtQuerySystemInformation(SystemPerformanceInformation, @SysPerfInfo, SizeOf(SysPerfInfo), nil);\r\n if Status <> 0 then\r\n Exit;\r\n\r\n // if it's a first call - skip it\r\n if (PrevIdleTime.QuadPart <> 0) then\r\n begin\r\n // CurrentValue = NewValue - OldValue\r\n IdleTime := Li2Double(SysPerfInfo.liIdleTime) - Li2Double(PrevIdleTime);\r\n SystemTime := Li2Double(SysTimeInfo.liKeSystemTime) - Li2Double(PrevSystemTime);\r\n\r\n // CurrentCpuIdle = IdleTime / SystemTime\r\n IdleTime := IdleTime / SystemTime;\r\n\r\n // CurrentCpuUsage% = 100 - (CurrentCpuIdle * 100) / NumberOfProcessors\r\n IdleTime := 100.0 - IdleTime * 100.0 / SysBaseInfo.bKeNumberProcessors + 0.5;\r\n\r\n // Show Percentage\r\n Result := IdleTime;\r\n if Result > 100 then\r\n Result := 100;\r\n end;\r\n\r\n // store new CPU's idle and system time\r\n PrevIdleTime := SysPerfInfo.liIdleTime;\r\n PrevSystemTime := SysTimeInfo.liKeSystemTime;\r\nend;\r\n\r\nfunction GetCPUUsageGST(var PrevIdleTime: TDateTime; var PrevSystemTime: TDateTime): Double;\r\nvar\r\n ProcessorsCount: Integer;\r\n\r\n TmpNewIdleTime: TFileTime;\r\n TmpNewKernelTime: TFileTime;\r\n TmpNewUserTime: TFileTime;\r\n\r\n NewIdleTime: TDateTime;\r\n\r\n NewSystemTime: TDateTime;\r\n IdleTimeDiff: TDateTime;\r\n SystemTimeDiff: TDateTime;\r\n SysInfo: TSystemInfo;\r\nbegin\r\n Result := 0;\r\n \r\n if not Assigned(GetSystemTimes) then\r\n Exit;\r\n \r\n // Get number of CPUs\r\n GetSystemInfo(SysInfo);\r\n ProcessorsCount := SysInfo.dwNumberOfProcessors;\r\n\r\n // Get system times\r\n if not GetSystemTimes(TmpNewIdleTime, TmpNewKernelTime, TmpNewUserTime) then\r\n Exit;\r\n NewSystemTime := Now;\r\n NewIdleTime := FileTimeToDateTime(TmpNewIdleTime);\r\n\r\n // compute the CPU usage but skip if it's a first call\r\n if PrevIdleTime <> 0 then\r\n begin\r\n IdleTimeDiff := NewIdleTime - PrevIdleTime;\r\n SystemTimeDiff := NewSystemTime - PrevSystemTime;\r\n\r\n Result := 100.0 - ((IdleTimeDiff) * 100) / (SystemTimeDiff) / ProcessorsCount;\r\n\r\n if Result > 100 then\r\n Result := 100;\r\n end;\r\n\r\n PrevIdleTime := NewIdleTime;\r\n PrevSystemTime := NewSystemTime;\r\nend;\r\n\r\n\r\nconstructor TJvCpuUsage.Create(AOwner: TComponent);\r\nvar\r\n CurValue: Cardinal;\r\nbegin\r\n inherited Create(AOwner);\r\n\r\n if not Assigned(@NtQuerySystemInformation) then\r\n begin\r\n FRegistry := TRegistry.Create;\r\n\r\n FRegistry.RootKey := HKEY_DYN_DATA;\r\n FRegistry.OpenKey(RC_PerfStart, False);\r\n FRegistry.ReadBinaryData(RC_CpuUsageKey, CurValue, SizeOf(CurValue));\r\n end;\r\nend;\r\n\r\ndestructor TJvCpuUsage.Destroy;\r\nvar\r\n CurValue: Cardinal;\r\nbegin\r\n if not Assigned(@NtQuerySystemInformation) then\r\n begin\r\n FRegistry.OpenKey(RC_PerfStop, False);\r\n FRegistry.ReadBinaryData(RC_CpuUsageKey, CurValue, SizeOf(CurValue));\r\n FRegistry.CloseKey;\r\n\r\n FRegistry.Free;\r\n end;\r\n\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJvCpuUsage.GetUsage: Double;\r\nvar\r\n CurValue: Cardinal;\r\nbegin\r\n if Assigned(@GetSystemTimes) then\r\n begin\r\n Result := GetCPUUsageGST(FPrevIdleTimeGST, FPrevSystemTimeGST);\r\n end\r\n else\r\n if Assigned(@NtQuerySystemInformation) then\r\n begin\r\n Result := GetCPUUsageNQSI(FPrevIdleTimeNQSI, FPrevSystemTimeNQSI);\r\n end\r\n else\r\n begin\r\n FRegistry.OpenKey(RC_PerfStat, False);\r\n FRegistry.ReadBinaryData(RC_CpuUsageKey, CurValue, SizeOf(CurValue));\r\n FRegistry.CloseKey;\r\n\r\n Result := CurValue;\r\n end;\r\nend;\r\n\r\ninitialization\r\n NtQuerySystemInformation := GetProcAddress(GetModuleHandle('ntdll.dll'), 'NtQuerySystemInformation');\r\n GetSystemTimes := GetProcAddress(GetModuleHandle('kernel32.dll'), 'GetSystemTimes');\r\n{$IFDEF UNITVERSIONING}\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nfinalization\r\n{$IFDEF UNITVERSIONING}\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvCreateProcess.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvSysComp.PAS, released Dec 26, 1999.\r\n\r\nThe Initial Developer of the Original Code is Petr Vones (petr dott v att mujmail dott cz)\r\nPortions created by Petr Vones are Copyright (C) 1999 Petr Vones.\r\nPortions created by Microsoft are Copyright (C) 1998, 1999 Microsoft Corp.\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\n Marcel van Brakel .\r\n Remko Bonte (redirect console output)\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvCreateProcess.pas 13336 2012-06-12 15:57:56Z obones $\r\n\r\nunit JvCreateProcess;\r\n\r\n{$I jvcl.inc}\r\n{$I windowsonly.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, Messages, SysUtils, Classes,\r\n ShellAPI, SyncObjs,\r\n JvComponentBase, JvTypes;\r\n\r\nconst\r\n CCPS_BufferSize = 1024;\r\n CCPS_MaxBufferSize = 65536;\r\n\r\ntype\r\n EJvProcessError = EJVCLException;\r\n\r\n TJvProcessPriority = (ppIdle, ppNormal, ppHigh, ppRealTime, ppBelowNormal, ppAboveNormal);\r\n\r\n TJvConsoleOption = (coOwnerData, coRedirect, coSeparateError);\r\n TJvConsoleOptions = set of TJvConsoleOption;\r\n\r\n TJvCPSRawReadEvent = procedure(Sender: TObject; const S: string) of object;\r\n TJvCPSReadEvent = procedure(Sender: TObject; const S: string; const StartsOnNewLine: Boolean) of object;\r\n TJvCPSTerminateEvent = procedure(Sender: TObject; ExitCode: DWORD) of object;\r\n\r\n TJvProcessEntry = class(TObject)\r\n private\r\n FFileName: TFileName;\r\n FProcessID: DWORD;\r\n FProcessName: string;\r\n function GetSystemIconIndex(IconType: Integer): Integer;\r\n function GetPriority: TJvProcessPriority;\r\n procedure SetPriority(const Value: TJvProcessPriority);\r\n public\r\n constructor Create(AProcessID: DWORD; const AFileName: TFileName; const AProcessName: string);\r\n function Close(UseQuit: Boolean = False): Boolean;\r\n class function PriorityText(Priority: TJvProcessPriority): string;\r\n function Terminate: Boolean;\r\n property FileName: TFileName read FFileName;\r\n property LargeIconIndex: Integer index SHGFI_LARGEICON read GetSystemIconIndex;\r\n property Priority: TJvProcessPriority read GetPriority write SetPriority;\r\n property ProcessID: DWORD read FProcessID;\r\n property ProcessName: string read FProcessName;\r\n property SmallIconIndex: Integer index SHGFI_SMALLICON read GetSystemIconIndex;\r\n end;\r\n\r\n TJvCPSBuffer = array [0..CCPS_BufferSize - 1] of AnsiChar;\r\n TJvCPSState = (psReady, psRunning, psWaiting);\r\n TJvCPSFlag = (cfDefaultErrorMode, cfNewConsole, cfNewProcGroup, cfSeparateWdm,\r\n cfSharedWdm, cfSuspended, cfUnicode, cfDetached);\r\n TJvCPSFlags = set of TJvCPSFlag;\r\n TJvCPSShowWindow = (swHide, swMinimize, swMaximize, swNormal);\r\n\r\n TJvCPSStartupInfo = class(TPersistent)\r\n private\r\n FDesktop: string;\r\n FTitle: string;\r\n FDefaultPosition: Boolean;\r\n FDefaultWindowState: Boolean;\r\n FDefaultSize: Boolean;\r\n FHeight: Integer;\r\n FLeft: Integer;\r\n FWidth: Integer;\r\n FShowWindow: TJvCPSShowWindow;\r\n FTop: Integer;\r\n FForceOnFeedback: Boolean;\r\n FForceOffFeedback: Boolean;\r\n function GetStartupInfo: TStartupInfo;\r\n protected\r\n procedure AssignTo(Dest: TPersistent); override;\r\n public\r\n constructor Create;\r\n property StartupInfo: TStartupInfo read GetStartupInfo;\r\n published\r\n property Desktop: string read FDesktop write FDesktop;\r\n property Title: string read FTitle write FTitle;\r\n property Left: Integer read FLeft write FLeft default 0;\r\n property Top: Integer read FTop write FTop default 0;\r\n property DefaultPosition: Boolean read FDefaultPosition write FDefaultPosition default True;\r\n property Width: Integer read FWidth write FWidth default 0;\r\n property Height: Integer read FHeight write FHeight default 0;\r\n property DefaultSize: Boolean read FDefaultSize write FDefaultSize default True;\r\n property ShowWindow: TJvCPSShowWindow read FShowWindow write FShowWindow default swNormal;\r\n property DefaultWindowState: Boolean read FDefaultWindowState write FDefaultWindowState default True;\r\n property ForceOnFeedback: Boolean read FForceOnFeedback write FForceOnFeedback default False;\r\n property ForceOffFeedback: Boolean read FForceOffFeedback write FForceOffFeedback default False;\r\n end;\r\n\r\n TJvCreateProcess = class;\r\n\r\n {$M+}\r\n TJvBaseReader = class(TObject)\r\n private\r\n FCreateProcess: TJvCreateProcess;\r\n FConsoleOutput: TStringList;\r\n FOnRawRead: TJvCPSRawReadEvent;\r\n FOnRead: TJvCPSReadEvent;\r\n function GetConsoleOutput: TStrings;\r\n public\r\n constructor Create(ACreateProcess: TJvCreateProcess); virtual;\r\n destructor Destroy; override;\r\n\r\n property ConsoleOutput: TStrings read GetConsoleOutput;\r\n published\r\n property OnRead: TJvCPSReadEvent read FOnRead write FOnRead;\r\n property OnRawRead: TJvCPSRawReadEvent read FOnRawRead write FOnRawRead;\r\n end;\r\n {$M-}\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64 or pidOSX32)]\r\n {$ENDIF RTL230_UP}\r\n TJvCreateProcess = class(TJvComponent)\r\n private\r\n FApplicationName: string;\r\n FCommandLine: string;\r\n FCreationFlags: TJvCPSFlags;\r\n FCurrentDirectory: string;\r\n FEnvironment: TStringList;\r\n FState: TJvCPSState;\r\n FStartupInfo: TJvCPSStartupInfo;\r\n FPriority: TJvProcessPriority;\r\n FProcessInfo: TProcessInformation;\r\n FWaitForTerminate: Boolean;\r\n FConsoleOptions: TJvConsoleOptions;\r\n FOnTerminate: TJvCPSTerminateEvent;\r\n FWaitThread: TThread;\r\n FInputReader: TJvBaseReader;\r\n FErrorReader: TJvBaseReader;\r\n FHandle: THandle;\r\n FExitCode: Cardinal;\r\n FRunningThreadCount: Integer;\r\n function GetConsoleOutput: TStrings;\r\n function GetEnvironment: TStrings;\r\n procedure SetWaitForTerminate(const Value: Boolean);\r\n procedure WaitThreadTerminated(Sender: TObject);\r\n procedure SetEnvironment(const Value: TStrings);\r\n function GetHandle: THandle;\r\n\r\n function GetOnErrorRawRead: TJvCPSRawReadEvent;\r\n function GetOnErrorRead: TJvCPSReadEvent;\r\n function GetOnRawRead: TJvCPSRawReadEvent;\r\n function GetOnRead: TJvCPSReadEvent;\r\n procedure SetOnErrorRawRead(const Value: TJvCPSRawReadEvent);\r\n procedure SetOnErrorRead(const Value: TJvCPSReadEvent);\r\n procedure SetOnRawRead(const Value: TJvCPSRawReadEvent);\r\n procedure SetOnRead(const Value: TJvCPSReadEvent);\r\n procedure SetStartupInfo(Value: TJvCPSStartupInfo);\r\n\r\n procedure GotoReadyState;\r\n procedure GotoWaitState(const AThreadCount: Integer);\r\n procedure GotoRunningState;\r\n procedure SetCommandLine(const Value: string);\r\n protected\r\n procedure CheckReady;\r\n procedure CheckRunning;\r\n procedure CheckNotWaiting;\r\n procedure CloseProcessHandles;\r\n procedure TerminateWaitThread;\r\n procedure HandleReadEvent(Sender: TObject);\r\n procedure HandleThreadTerminated;\r\n procedure WndProc(var Msg: TMessage);\r\n property Handle: THandle read GetHandle;\r\n procedure CloseRead;\r\n procedure CloseWrite;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n function CloseApplication(SendQuit: Boolean = False): Boolean;\r\n procedure Run;\r\n procedure StopWaiting;\r\n procedure Terminate;\r\n procedure TerminateTree;\r\n function Write(const S: AnsiString): Boolean;\r\n function WriteLn(const S: AnsiString): Boolean;\r\n property ProcessInfo: TProcessInformation read FProcessInfo;\r\n property State: TJvCPSState read FState;\r\n property ConsoleOutput: TStrings read GetConsoleOutput;\r\n property InputReader: TJvBaseReader read FInputReader;\r\n property ErrorReader: TJvBaseReader read FErrorReader;\r\n published\r\n property ApplicationName: string read FApplicationName write FApplicationName;\r\n property CommandLine: string read FCommandLine write SetCommandLine;\r\n property CreationFlags: TJvCPSFlags read FCreationFlags write FCreationFlags default [{$IFDEF UNICODE}cfUnicode{$ENDIF UNICODE}];\r\n property CurrentDirectory: string read FCurrentDirectory write FCurrentDirectory;\r\n property Environment: TStrings read GetEnvironment write SetEnvironment;\r\n property Priority: TJvProcessPriority read FPriority write FPriority default ppNormal;\r\n property StartupInfo: TJvCPSStartupInfo read FStartupInfo write SetStartupInfo;\r\n property WaitForTerminate: Boolean read FWaitForTerminate write SetWaitForTerminate default True;\r\n property ConsoleOptions: TJvConsoleOptions read FConsoleOptions write FConsoleOptions default [coOwnerData];\r\n property OnTerminate: TJvCPSTerminateEvent read FOnTerminate write FOnTerminate;\r\n property OnRead: TJvCPSReadEvent read GetOnRead write SetOnRead;\r\n property OnRawRead: TJvCPSRawReadEvent read GetOnRawRead write SetOnRawRead;\r\n property OnErrorRead: TJvCPSReadEvent read GetOnErrorRead write SetOnErrorRead;\r\n property OnErrorRawRead: TJvCPSRawReadEvent read GetOnErrorRawRead write SetOnErrorRawRead;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvCreateProcess.pas $';\r\n Revision: '$Revision: 13336 $';\r\n Date: '$Date: 2012-06-12 17:57:56 +0200 (mar. 12 juin 2012) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n Math,\r\n JclStrings,\r\n JvJCLUtils, JvJVCLUtils, JvConsts, JvResources, TlHelp32;\r\n\r\nconst\r\n CM_READ = WM_USER + 1;\r\n CM_THREADTERMINATED = WM_USER + 2;\r\n\r\n BELOW_NORMAL_PRIORITY_CLASS = $00004000;\r\n ABOVE_NORMAL_PRIORITY_CLASS = $00008000;\r\n\r\n //MaxProcessCount = 4096;\r\n ProcessPriorities: array [TJvProcessPriority] of DWORD =\r\n (IDLE_PRIORITY_CLASS, NORMAL_PRIORITY_CLASS, HIGH_PRIORITY_CLASS, REALTIME_PRIORITY_CLASS,\r\n BELOW_NORMAL_PRIORITY_CLASS, ABOVE_NORMAL_PRIORITY_CLASS);\r\n\r\ntype\r\n { Threads which monitor the created process }\r\n\r\n TJvWaitForProcessThread = class(TJvCustomThread)\r\n private\r\n FExitCode: DWORD;\r\n FCloseEvent: THandle;\r\n FProcessHandle: THandle;\r\n protected\r\n procedure Execute; override;\r\n public\r\n constructor Create(ProcessHandle: DWORD);\r\n destructor Destroy; override;\r\n procedure TerminateThread;\r\n end;\r\n\r\n TJvConsoleThread = class(TJvWaitForProcessThread)\r\n private\r\n // Write end of the pipe\r\n FWriteHandle: THandle;\r\n FWriteEvent: THandle;\r\n // Critical sections to synchronize access to the buffers\r\n FWriteLock: TCriticalSection;\r\n // Fixed size buffer; maybe change to sizeable\r\n FOutputBuffer: TJvCPSBuffer;\r\n FOutputBufferEnd: Cardinal;\r\n protected\r\n procedure Execute; override;\r\n function TryWrite: Boolean;\r\n public\r\n constructor Create(ProcessHandle: DWORD; AWriteHandle: THandle);\r\n destructor Destroy; override;\r\n function Write(const S: AnsiString): Boolean;\r\n procedure CloseWrite;\r\n end;\r\n\r\n TJvReadThread = class(TThread)\r\n private\r\n FOwner: TObject;\r\n // Read end of the pipe\r\n FReadHandle: THandle;\r\n // Critical sections to synchronize access to the buffers\r\n FReadLock: TCriticalSection;\r\n // Handle to the TJvCreateProcess\r\n FDestHandle: THandle;\r\n FPreBuffer: PAnsiChar;\r\n FInputBuffer: PAnsiChar;\r\n FInputBufferSize: Cardinal;\r\n FInputBufferEnd: Cardinal;\r\n protected\r\n procedure CopyToBuffer(Buffer: PAnsiChar; ASize: Cardinal);\r\n procedure Execute; override;\r\n public\r\n constructor Create(AOwner: TObject; AReadHandle, ADestHandle: THandle);\r\n destructor Destroy; override;\r\n procedure CloseRead;\r\n function ReadBuffer(var ABuffer: TJvCPSBuffer; out ABufferSize: Cardinal): Boolean;\r\n procedure TerminateThread;\r\n end;\r\n\r\n TJvReader = class(TJvBaseReader)\r\n private\r\n FThread: TJvReadThread;\r\n FCurrentLine: AnsiString; // Last output of the console with no #10 char.\r\n FCursorPosition: Integer; // Position of the cursor on FCurrentLine\r\n FStartsOnNewLine: Boolean;\r\n FParseBuffer: TJvCPSBuffer;\r\n procedure ThreadTerminated(Sender: TObject);\r\n protected\r\n procedure DoReadEvent(const EndsWithNewLine: Boolean);\r\n procedure DoRawReadEvent(Data: PAnsiChar; const ASize: Cardinal);\r\n procedure ParseConsoleOutput(Data: PAnsiChar; ASize: Cardinal);\r\n procedure HandleReadEvent;\r\n public\r\n procedure CreateThread(const AReadHandle: THandle);\r\n procedure CloseRead;\r\n procedure Terminate;\r\n end;\r\n\r\n//=== Local procedures =======================================================\r\n\r\nvar\r\n GWinSrvHandle: HMODULE;\r\n GTriedLoadWinSrvDll: Boolean;\r\n\r\nconst\r\n WinSrvDllName = 'WINSRV.DLL';\r\n\r\nfunction WinSrvHandle: HMODULE;\r\nbegin\r\n if not GTriedLoadWinSrvDll then\r\n begin\r\n GTriedLoadWinSrvDll := True;\r\n\r\n GWinSrvHandle := SafeLoadLibrary(WinSrvDllName);\r\n if GWinSrvHandle <> 0 then\r\n FreeLibrary(GWinSrvHandle);\r\n end;\r\n Result := GWinSrvHandle;\r\nend;\r\n\r\nfunction IsConsoleWindow(AHandle: THandle): Boolean;\r\nbegin\r\n Result := THandle(GetWindowLongPtr(AHandle, GWL_HINSTANCE)) = WinSrvHandle;\r\nend;\r\n\r\ntype\r\n PEnumWinRec = ^TEnumWinRec;\r\n TEnumWinRec = record\r\n ProcessID: DWORD;\r\n PostQuit: Boolean;\r\n FoundWin: Boolean;\r\n end;\r\n\r\nfunction EnumWinProc(Wnd: HWND; Param: PEnumWinRec): BOOL; stdcall;\r\nvar\r\n PID, TID: DWORD;\r\nbegin\r\n TID := GetWindowThreadProcessId(Wnd, @PID);\r\n if PID = Param.ProcessID then\r\n begin\r\n if Param.PostQuit then\r\n PostThreadMessage(TID, WM_QUIT, 0, 0)\r\n else\r\n if IsWindowVisible(Wnd) or IsConsoleWindow(Wnd) then\r\n PostMessage(Wnd, WM_CLOSE, 0, 0);\r\n Param.FoundWin := True;\r\n end;\r\n Result := True;\r\nend;\r\n\r\nfunction InternalCloseApp(ProcessID: DWORD; UseQuit: Boolean): Boolean;\r\nvar\r\n EnumWinRec: TEnumWinRec;\r\nbegin\r\n EnumWinRec.ProcessID := ProcessID;\r\n EnumWinRec.PostQuit := UseQuit;\r\n EnumWinRec.FoundWin := False;\r\n EnumWindows(@EnumWinProc, LPARAM(@EnumWinRec));\r\n Result := EnumWinRec.FoundWin;\r\nend;\r\n\r\nfunction InternalTerminateProcess(ProcessID: DWORD): Boolean;\r\nvar\r\n ProcessHandle: THandle;\r\nbegin\r\n ProcessHandle := OpenProcess(PROCESS_TERMINATE, False, ProcessID);\r\n OSCheck(ProcessHandle <> 0);\r\n Result := TerminateProcess(ProcessHandle, 0);\r\n CloseHandle(ProcessHandle);\r\nend;\r\n\r\ntype\r\n TProcessArray = array of DWORD;\r\n\r\nfunction InternalTerminateProcessTree(ProcessID: DWORD): Boolean;\r\n\r\n function GetChildrenProcesses(const Process: DWORD; const IncludeParent: Boolean): TProcessArray;\r\n var\r\n Snapshot: Cardinal;\r\n ProcessList: PROCESSENTRY32;\r\n Current: Integer;\r\n begin\r\n Current := 0;\r\n SetLength(Result, 1);\r\n Result[0] := Process;\r\n repeat\r\n ProcessList.dwSize := SizeOf(PROCESSENTRY32);\r\n Snapshot := CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0);\r\n if (Snapshot = INVALID_HANDLE_VALUE) or not Process32First(Snapshot, ProcessList) then\r\n Continue;\r\n repeat\r\n if ProcessList.th32ParentProcessID = Result[Current] then\r\n begin\r\n SetLength(Result, Length(Result) + 1);\r\n Result[Length(Result) - 1] := ProcessList.th32ProcessID;\r\n end;\r\n until Process32Next(Snapshot, ProcessList) = False;\r\n Inc(Current);\r\n until Current >= Length(Result);\r\n if not IncludeParent then\r\n Result := Copy(Result, 2, Length(Result));\r\n end;\r\n\r\nvar\r\n Handle: THandle;\r\n List: TProcessArray;\r\n I: Integer;\r\nbegin\r\n Result := True;\r\n List := GetChildrenProcesses(ProcessID, True);\r\n for I := Length(List) - 1 downto 0 do\r\n if Result then\r\n begin\r\n Handle := OpenProcess(PROCESS_TERMINATE, false, List[I]);\r\n Result := (Handle <> 0) and TerminateProcess(Handle, 0) and CloseHandle(Handle);\r\n end;\r\nend;\r\n\r\nfunction SafeCloseHandle(var H: THandle): Boolean;\r\nbegin\r\n if H <> 0 then\r\n begin\r\n Result := CloseHandle(H);\r\n if Result then\r\n H := 0;\r\n end\r\n else\r\n Result := True;\r\nend;\r\n\r\ntype\r\n { TJvRWEHandles: A simple class that maintains at most 3 handles. When the\r\n class is destroyed, the handles it maintains are closed. By calling Extract..\r\n you remove the handle from the class so you have to close it yourself.\r\n Assumed is that the 3 handles are not the same or 0.\r\n }\r\n\r\n TJvRWEHandles = class(TObject)\r\n private\r\n FHandle: array [0..2] of THandle;\r\n function GetHandle(const Index: Integer): THandle;\r\n procedure SetHandle(const Index: Integer; const Value: THandle);\r\n function ExtractHandle(const Index: Integer): THandle;\r\n public\r\n destructor Destroy; override;\r\n procedure Clear;\r\n\r\n property ExtractRead: THandle index 0 read ExtractHandle;\r\n property ExtractWrite: THandle index 1 read ExtractHandle;\r\n property ExtractError: THandle index 2 read ExtractHandle;\r\n\r\n property Read: THandle index 0 read GetHandle write SetHandle;\r\n property Write: THandle index 1 read GetHandle write SetHandle;\r\n property Error: THandle index 2 read GetHandle write SetHandle;\r\n end;\r\n\r\n TCreateDuplicateKind = (cdkInheritable_KeepSourceOpen, cdkNotInheritable_CloseSource);\r\n\r\nfunction CreateDuplicate(AHandle: THandle; const Kind: TCreateDuplicateKind): THandle;\r\nconst\r\n cCloseAction: array [TCreateDuplicateKind] of DWORD = (0, DUPLICATE_CLOSE_SOURCE);\r\nbegin\r\n OSCheck(DuplicateHandle(GetCurrentProcess, AHandle,\r\n GetCurrentProcess,\r\n @Result, // Address of new handle.\r\n 0, Kind = cdkInheritable_KeepSourceOpen,\r\n DUPLICATE_SAME_ACCESS or cCloseAction[Kind]));\r\nend;\r\n\r\nprocedure ConstructPipe(LocalHandles, ConsoleHandles: TJvRWEHandles; const SeparateError: Boolean);\r\nvar\r\n Sa: TSecurityAttributes;\r\n Sd: TSecurityDescriptor;\r\n ReadHandle, WriteHandle: THandle;\r\nbegin\r\n { http://support.microsoft.com/default.aspx?scid=KB;EN-US;q190351& }\r\n { http://community.borland.com/article/0,1410,10387,00.html }\r\n\r\n // Set up the security attributes struct.\r\n FillChar(Sa, SizeOf(TSecurityAttributes), 0);\r\n Sa.nLength := SizeOf(TSecurityAttributes);\r\n\r\n if Win32Platform = VER_PLATFORM_WIN32_NT then\r\n begin\r\n // Initialize security descriptor (Windows NT)\r\n InitializeSecurityDescriptor(@Sd, SECURITY_DESCRIPTOR_REVISION);\r\n SetSecurityDescriptorDacl(@Sd, True, nil, False);\r\n Sa.lpSecurityDescriptor := @Sd;\r\n end\r\n else\r\n Sa.lpSecurityDescriptor := nil;\r\n Sa.bInheritHandle := True;\r\n\r\n if ConsoleHandles.Write = 0 then\r\n begin\r\n // Create the child output pipe.\r\n OSCheck(CreatePipe(ReadHandle, WriteHandle, @Sa, 0));\r\n\r\n // Create new output read handle. Set bInheritHandle to False. Otherwise,\r\n // the child inherits the properties and, as a result, non-closeable handles\r\n // to the pipes are created (cdkNOTINHERITABLE_CloseSource)\r\n\r\n // Close inheritable copies of the handles you do not want to be\r\n // inherited (cdkNotInheritable_CLOSESOURCE)\r\n\r\n // CreateDuplicate may raise an exception, so call it last otherwise WriteHandle\r\n // is not closed.\r\n ConsoleHandles.Write := WriteHandle;\r\n LocalHandles.Read := CreateDuplicate(ReadHandle, cdkNotInheritable_CloseSource);\r\n end;\r\n\r\n if ConsoleHandles.Error = 0 then\r\n begin\r\n if SeparateError then\r\n begin\r\n // Create the child input pipe.\r\n OSCheck(CreatePipe(ReadHandle, WriteHandle, @Sa, 0));\r\n\r\n ConsoleHandles.Error := WriteHandle;\r\n LocalHandles.Error := CreateDuplicate(ReadHandle, cdkNotInheritable_CloseSource);\r\n end\r\n else\r\n begin\r\n // Create a duplicate of the output write handle for the std error\r\n // write handle. This is necessary in case the child application\r\n // closes one of its std output handles.\r\n ConsoleHandles.Error := CreateDuplicate(ConsoleHandles.Write, cdkInheritable_KeepSourceOpen);\r\n end;\r\n end;\r\n\r\n if ConsoleHandles.Read = 0 then\r\n begin\r\n // Create the child input pipe.\r\n OSCheck(CreatePipe(ReadHandle, WriteHandle, @Sa, 0));\r\n\r\n ConsoleHandles.Read := ReadHandle;\r\n LocalHandles.Write := CreateDuplicate(WriteHandle, cdkNotInheritable_CloseSource);\r\n end;\r\nend;\r\n\r\n//=== { TJvBaseReader } ======================================================\r\n\r\nconstructor TJvBaseReader.Create(ACreateProcess: TJvCreateProcess);\r\nbegin\r\n inherited Create;\r\n FCreateProcess := ACreateProcess;\r\n FConsoleOutput := TStringList.Create;\r\nend;\r\n\r\ndestructor TJvBaseReader.Destroy;\r\nbegin\r\n FConsoleOutput.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJvBaseReader.GetConsoleOutput: TStrings;\r\nbegin\r\n Result := FConsoleOutput;\r\nend;\r\n\r\n//=== { TJvProcessEntry } ====================================================\r\n\r\nconstructor TJvProcessEntry.Create(AProcessID: DWORD;\r\n const AFileName: TFileName; const AProcessName: string);\r\nbegin\r\n inherited Create;\r\n FFileName := AFileName;\r\n FProcessID := AProcessID;\r\n FProcessName := AProcessName;\r\nend;\r\n\r\nfunction TJvProcessEntry.Close(UseQuit: Boolean): Boolean;\r\nbegin\r\n Result := InternalCloseApp(ProcessID, UseQuit);\r\nend;\r\n\r\nfunction TJvProcessEntry.GetPriority: TJvProcessPriority;\r\nvar\r\n ProcessHandle: THandle;\r\n PriorityClass: DWORD;\r\nbegin\r\n if ProcessID = 0 then\r\n Result := ppNormal\r\n else\r\n begin\r\n ProcessHandle := OpenProcess(PROCESS_ALL_ACCESS, False, ProcessID);\r\n OSCheck(ProcessHandle <> 0);\r\n try\r\n PriorityClass := GetPriorityClass(ProcessHandle);\r\n OSCheck(PriorityClass <> 0);\r\n case PriorityClass of\r\n NORMAL_PRIORITY_CLASS:\r\n Result := ppNormal;\r\n IDLE_PRIORITY_CLASS:\r\n Result := ppIdle;\r\n HIGH_PRIORITY_CLASS:\r\n Result := ppHigh;\r\n REALTIME_PRIORITY_CLASS:\r\n Result := ppRealTime;\r\n BELOW_NORMAL_PRIORITY_CLASS:\r\n Result := ppBelowNormal;\r\n ABOVE_NORMAL_PRIORITY_CLASS:\r\n Result := ppAboveNormal;\r\n else\r\n Result := ppNormal;\r\n end;\r\n finally\r\n CloseHandle(ProcessHandle);\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJvProcessEntry.GetSystemIconIndex(IconType: Integer): Integer;\r\nvar\r\n FileInfo: TSHFileInfo;\r\nbegin\r\n FillChar(FileInfo, SizeOf(FileInfo), #0);\r\n SHGetFileInfo(PChar(FileName), 0, FileInfo, SizeOf(FileInfo),\r\n SHGFI_SYSICONINDEX or IconType);\r\n Result := FileInfo.iIcon;\r\nend;\r\n\r\nclass function TJvProcessEntry.PriorityText(Priority: TJvProcessPriority): string;\r\nbegin\r\n case Priority of\r\n ppIdle:\r\n Result := RsIdle;\r\n ppNormal:\r\n Result := RsNormal;\r\n ppHigh:\r\n Result := RsHigh;\r\n ppRealTime:\r\n Result := RsRealTime;\r\n ppBelowNormal:\r\n Result := RsBelowNormal;\r\n ppAboveNormal:\r\n Result := RsAboveNormal;\r\n end;\r\nend;\r\n\r\nprocedure TJvProcessEntry.SetPriority(const Value: TJvProcessPriority);\r\nvar\r\n ProcessHandle: THandle;\r\nbegin\r\n ProcessHandle := OpenProcess(PROCESS_SET_INFORMATION, False, ProcessID);\r\n OSCheck(ProcessHandle <> 0);\r\n try\r\n OSCheck(SetPriorityClass(ProcessHandle, ProcessPriorities[Value]));\r\n finally\r\n CloseHandle(ProcessHandle);\r\n end;\r\nend;\r\n\r\nfunction TJvProcessEntry.Terminate: Boolean;\r\nbegin\r\n Result := InternalTerminateProcess(FProcessID);\r\nend;\r\n\r\n//=== { TJvCPSStartupInfo } ==================================================\r\n\r\nconstructor TJvCPSStartupInfo.Create;\r\nbegin\r\n inherited Create;\r\n FDefaultSize := True;\r\n FDefaultPosition := True;\r\n FDefaultWindowState := True;\r\n FShowWindow := swNormal;\r\nend;\r\n\r\nprocedure TJvCPSStartupInfo.AssignTo(Dest: TPersistent);\r\nbegin\r\n if Dest is TJvCPSStartupInfo then\r\n with TJvCPSStartupInfo(Dest) do\r\n begin\r\n FDesktop := Self.FDesktop;\r\n FTitle := Self.FTitle;\r\n FLeft := Self.FLeft;\r\n FTop := Self.FTop;\r\n FDefaultPosition := Self.FDefaultPosition;\r\n FWidth := Self.FWidth;\r\n FHeight := Self.FHeight;\r\n FDefaultSize := Self.FDefaultSize;\r\n FShowWindow := Self.FShowWindow;\r\n FDefaultWindowState := Self.FDefaultWindowState;\r\n FForceOnFeedback := Self.FForceOnFeedback;\r\n FForceOffFeedback := Self.FForceOffFeedback;\r\n end\r\n else\r\n inherited AssignTo(Dest);\r\nend;\r\n\r\nfunction TJvCPSStartupInfo.GetStartupInfo: TStartupInfo;\r\nconst\r\n ShowWindowValues: array [TJvCPSShowWindow] of DWORD =\r\n (SW_HIDE, SW_SHOWMINIMIZED, SW_SHOWMAXIMIZED, SW_SHOWNORMAL);\r\nbegin\r\n FillChar(Result, SizeOf(TStartupInfo), #0);\r\n with Result do\r\n begin\r\n cb := SizeOf(TStartupInfo);\r\n if Length(FDesktop) > 0 then\r\n lpDesktop := PChar(FDesktop);\r\n if Length(FTitle) > 0 then\r\n lpTitle := PChar(Title);\r\n if not FDefaultPosition then\r\n begin\r\n dwX := FLeft;\r\n dwY := FTop;\r\n Inc(dwFlags, STARTF_USEPOSITION);\r\n end;\r\n if not FDefaultSize then\r\n begin\r\n dwXSize := FWidth;\r\n dwYSize := FHeight;\r\n Inc(dwFlags, STARTF_USESIZE);\r\n end;\r\n if not FDefaultWindowState then\r\n begin\r\n wShowWindow := ShowWindowValues[FShowWindow];\r\n Inc(dwFlags, STARTF_USESHOWWINDOW);\r\n end;\r\n if FForceOnFeedback then\r\n Inc(dwFlags, STARTF_FORCEONFEEDBACK);\r\n if FForceOffFeedback then\r\n Inc(dwFlags, STARTF_FORCEOFFFEEDBACK);\r\n end;\r\nend;\r\n\r\n//=== { TJvWaitForProcessThread } ============================================\r\n\r\nconstructor TJvWaitForProcessThread.Create(ProcessHandle: DWORD);\r\nbegin\r\n inherited Create(True);\r\n FreeOnTerminate := True;\r\n Priority := tpLower;\r\n FCloseEvent := CreateEvent(nil, True, False, nil);\r\n FProcessHandle := ProcessHandle;\r\nend;\r\n\r\ndestructor TJvWaitForProcessThread.Destroy;\r\nbegin\r\n SafeCloseHandle(FCloseEvent);\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvWaitForProcessThread.Execute;\r\nvar\r\n WaitHandles: array [0..1] of THandle;\r\nbegin\r\n NameThread(ThreadName);\r\n WaitHandles[0] := FCloseEvent;\r\n WaitHandles[1] := FProcessHandle;\r\n WaitForInputIdle(FProcessHandle, INFINITE);\r\n case WaitForMultipleObjects(2, PWOHandleArray(@WaitHandles[0]), False, INFINITE) of\r\n WAIT_OBJECT_0:\r\n FExitCode := MAXDWORD;\r\n WAIT_OBJECT_0 + 1:\r\n GetExitCodeProcess(FProcessHandle, FExitCode);\r\n else\r\n RaiseLastOSError;\r\n end;\r\nend;\r\n\r\nprocedure TJvWaitForProcessThread.TerminateThread;\r\nbegin\r\n Terminate;\r\n SetEvent(FCloseEvent);\r\nend;\r\n\r\n//=== { TJvReadThread } ======================================================\r\n\r\nconstructor TJvReadThread.Create(AOwner: TObject; AReadHandle, ADestHandle: THandle);\r\nbegin\r\n inherited Create(True);\r\n\r\n FOwner := AOwner;\r\n FreeOnTerminate := True;\r\n Priority := tpLower;\r\n\r\n FReadLock := TCriticalSection.Create;\r\n\r\n // Note: TJvReadThread is responsible for closing the FReadHandle\r\n FReadHandle := AReadHandle;\r\n FDestHandle := ADestHandle;\r\n\r\n FInputBuffer := nil;\r\n FInputBufferSize := CCPS_BufferSize;\r\n FInputBufferEnd := 0;\r\n ReallocMem(FInputBuffer, FInputBufferSize * SizeOf(Byte));\r\n GetMem(FPreBuffer, CCPS_BufferSize);\r\nend;\r\n\r\ndestructor TJvReadThread.Destroy;\r\nbegin\r\n SafeCloseHandle(FReadHandle);\r\n inherited Destroy;\r\n { It is (theoretically) possible that the inherited Destroy triggers an\r\n OnTerminate event and the following fields can be accessed in the handler,\r\n thus free them after the destroy.\r\n }\r\n FreeMem(FInputBuffer);\r\n FReadLock.Free;\r\n FreeMem(FPreBuffer);\r\nend;\r\n\r\nprocedure TJvReadThread.CloseRead;\r\nbegin\r\n FReadLock.Acquire;\r\n try\r\n SafeCloseHandle(FReadHandle);\r\n finally\r\n FReadLock.Release;\r\n end;\r\nend;\r\n\r\nprocedure TJvReadThread.CopyToBuffer(Buffer: PAnsiChar; ASize: Cardinal);\r\n// Copy data in Buffer (with size ASize) to FInputBuffer.\r\nbegin\r\n FReadLock.Acquire;\r\n try\r\n if FInputBufferEnd + ASize > FInputBufferSize then\r\n begin\r\n // Safety check..\r\n if FInputBufferSize > CCPS_MaxBufferSize then\r\n // ..main thread seems to be blocked; flush the input buffer\r\n FInputBufferEnd := 0\r\n else\r\n begin\r\n // Need to upscale FInputBuffer\r\n FInputBufferSize := FInputBufferSize * 2;\r\n ReallocMem(FInputBuffer, FInputBufferSize * SizeOf(Byte));\r\n end;\r\n end;\r\n\r\n // Do the copy\r\n Move(Buffer[0], FInputBuffer[FInputBufferEnd], ASize);\r\n Inc(FInputBufferEnd, ASize);\r\n finally\r\n FReadLock.Release;\r\n end;\r\n\r\n // Notify TJvCreateProcess that data has been read from the pipe\r\n PostMessage(FDestHandle, CM_READ, WPARAM(FOwner), 0);\r\nend;\r\n\r\nprocedure TJvReadThread.Execute;\r\n// Read data from the pipe (FReadHandle) to FPreBuffer\r\nvar\r\n BytesRead: Cardinal;\r\nbegin\r\n while not Terminated do\r\n begin\r\n { ReadFile will block until *some* data is available on the pipe }\r\n if not ReadFile(FReadHandle, FPreBuffer[0], CCPS_BufferSize, BytesRead, nil) then\r\n begin\r\n // Only exit if last error is ERROR_BROKEN_PIPE, thus ignore other errors\r\n if GetLastError = ERROR_BROKEN_PIPE then\r\n // pipe done - normal exit path.\r\n Exit;\r\n end\r\n else\r\n CopyToBuffer(FPreBuffer, BytesRead);\r\n end;\r\nend;\r\n\r\nfunction TJvReadThread.ReadBuffer(var ABuffer: TJvCPSBuffer;\r\n out ABufferSize: Cardinal): Boolean;\r\n// Copy FInputBuffer to ABuffer.\r\n// This function is executed in the context of the main thread;\r\n// FReadLock is for synchronization with the read thread.\r\nbegin\r\n FReadLock.Acquire;\r\n try\r\n Result := FInputBufferEnd > 0;\r\n if not Result then\r\n Exit;\r\n\r\n ABufferSize := Min(FInputBufferEnd, CCPS_BufferSize);\r\n\r\n // Copy the data from FInputBuffer to ABuffer.\r\n Move(FInputBuffer[0], ABuffer[0], ABufferSize * SizeOf(Byte));\r\n\r\n // If not all data in FInputBuffer is copied to ABuffer, then place\r\n // the data not copied at the begin of FInputBuffer.\r\n if FInputBufferEnd > ABufferSize then\r\n Move(FInputBuffer[ABufferSize], FInputBuffer[0],\r\n (FInputBufferEnd - ABufferSize) * SizeOf(Byte));\r\n\r\n Dec(FInputBufferEnd, ABufferSize);\r\n finally\r\n FReadLock.Release;\r\n end;\r\nend;\r\n\r\nprocedure TJvReadThread.TerminateThread;\r\nbegin\r\n Terminate;\r\n CloseRead;\r\nend;\r\n\r\n//=== { TJvConsoleThread } ===================================================\r\n\r\nconstructor TJvConsoleThread.Create(ProcessHandle: DWORD;\r\n AWriteHandle: THandle);\r\nbegin\r\n inherited Create(ProcessHandle);\r\n\r\n FWriteLock := TCriticalSection.Create;\r\n\r\n // Note: TJvConsoleThread is responsible for closing the FWriteHandle\r\n FWriteHandle := AWriteHandle;\r\n\r\n FWriteEvent := CreateEvent(\r\n nil, // No security attributes\r\n True, // Manual reset\r\n False, // Initial state\r\n nil // No name\r\n );\r\nend;\r\n\r\ndestructor TJvConsoleThread.Destroy;\r\nbegin\r\n SafeCloseHandle(FWriteHandle);\r\n SafeCloseHandle(FWriteEvent);\r\n inherited Destroy;\r\n { It is (theoretically) possible that the inherited Destroy triggers an\r\n OnTerminate event and the following fields can be accessed in the handler,\r\n thus free them after the destroy.\r\n }\r\n FWriteLock.Free;\r\nend;\r\n\r\nprocedure TJvConsoleThread.CloseWrite;\r\nbegin\r\n FWriteLock.Acquire;\r\n try\r\n SafeCloseHandle(FWriteHandle);\r\n finally\r\n FWriteLock.Release;\r\n end;\r\nend;\r\n\r\nprocedure TJvConsoleThread.Execute;\r\nvar\r\n WaitHandles: array [0..2] of THandle;\r\n HandleCount: Cardinal;\r\nbegin\r\n WaitHandles[0] := FCloseEvent;\r\n WaitHandles[1] := FProcessHandle;\r\n WaitHandles[2] := FWriteEvent;\r\n HandleCount := 3;\r\n\r\n WaitForInputIdle(FProcessHandle, INFINITE);\r\n\r\n while not Terminated do\r\n case WaitForMultipleObjects(HandleCount, PWOHandleArray(@WaitHandles[0]), False, INFINITE) of\r\n WAIT_OBJECT_0:\r\n begin\r\n // Close event fired; exit\r\n FExitCode := MAXDWORD;\r\n Exit;\r\n end;\r\n WAIT_OBJECT_0 + 1:\r\n begin\r\n // process ended; exit\r\n GetExitCodeProcess(FProcessHandle, FExitCode);\r\n Exit;\r\n end;\r\n WAIT_OBJECT_0 + 2:\r\n // Write event fired; try to write\r\n if not TryWrite then\r\n // No longer respond when write event fires\r\n HandleCount := 2;\r\n else\r\n Exit;\r\n end;\r\nend;\r\n\r\nfunction TJvConsoleThread.TryWrite: Boolean;\r\n// Write data in FOutputBuffer to the pipe (FWriteHandle)\r\n// Result = False; if console or user has closed the pipe.\r\nvar\r\n BytesWritten: Cardinal;\r\n BytesToWrite: Cardinal;\r\nbegin\r\n Result := True;\r\n\r\n FWriteLock.Acquire;\r\n try\r\n try\r\n { Check handle inside lock, because it can be closed by another thread, by\r\n calling CloseWrite }\r\n if FWriteHandle = 0 then\r\n Exit;\r\n\r\n if FOutputBufferEnd <= 0 then\r\n Exit;\r\n\r\n BytesToWrite := FOutputBufferEnd;\r\n\r\n if not WriteFile(FWriteHandle, FOutputBuffer, BytesToWrite, BytesWritten, nil) then\r\n begin\r\n { WriteFile documentation on MSDN states that WriteFile returns\r\n ERROR_BROKEN_PIPE if the console closes it's read handle, but that\r\n seems incorrect; check it anyway }\r\n if (GetLastError = ERROR_NO_DATA) or (GetLastError = ERROR_BROKEN_PIPE) then\r\n // Pipe was closed (normal exit path).\r\n SafeCloseHandle(FWriteHandle);\r\n Exit;\r\n end;\r\n\r\n if BytesWritten <= 0 then\r\n Exit;\r\n\r\n if BytesWritten < BytesToWrite then\r\n // Move unwritten tail to the begin of the buffer\r\n Move(FOutputBuffer[BytesWritten], FOutputBuffer[0], BytesToWrite - BytesWritten);\r\n\r\n Dec(FOutputBufferEnd, BytesWritten);\r\n finally\r\n Result := FWriteHandle <> 0;\r\n if FOutputBufferEnd = 0 then\r\n ResetEvent(FWriteEvent);\r\n end;\r\n finally\r\n FWriteLock.Release;\r\n end;\r\nend;\r\n\r\nfunction TJvConsoleThread.Write(const S: AnsiString): Boolean;\r\n// Add S to FOutputBuffer; actual writing is done in TryWrite.\r\n// This function is executed in the context of the main thread;\r\n// FWriteLock is for synchronization with the write thread.\r\nbegin\r\n if Length(S) <= 0 then\r\n begin\r\n Result := True;\r\n Exit;\r\n end;\r\n\r\n FWriteLock.Acquire;\r\n try\r\n Result := FWriteHandle <> 0;\r\n if not Result then\r\n Exit;\r\n\r\n Result := Cardinal(Length(S)) + FOutputBufferEnd <= CCPS_BufferSize;\r\n if not Result then\r\n Exit;\r\n\r\n Move(PAnsiChar(S)^, FOutputBuffer[FOutputBufferEnd], Length(S));\r\n Inc(FOutputBufferEnd, Length(S));\r\n\r\n if FOutputBufferEnd > 0 then\r\n // Notify the TJvConsoleThread that there is some data to write\r\n SetEvent(FWriteEvent);\r\n finally\r\n FWriteLock.Release;\r\n end;\r\nend;\r\n\r\n//=== { TJvCreateProcess } ===================================================\r\n\r\nconstructor TJvCreateProcess.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FCreationFlags := [{$IFDEF UNICODE}cfUnicode{$ENDIF UNICODE}];\r\n FEnvironment := TStringList.Create;\r\n FPriority := ppNormal;\r\n FState := psReady;\r\n FWaitForTerminate := True;\r\n FStartupInfo := TJvCPSStartupInfo.Create;\r\n FConsoleOptions := [coOwnerData];\r\n FErrorReader := TJvReader.Create(Self);\r\n FInputReader := TJvReader.Create(Self);\r\nend;\r\n\r\ndestructor TJvCreateProcess.Destroy;\r\nbegin\r\n TerminateWaitThread;\r\n FErrorReader.Free;\r\n FInputReader.Free;\r\n FreeAndNil(FEnvironment);\r\n FreeAndNil(FStartupInfo);\r\n if FHandle <> 0 then\r\n DeallocateHWndEx(FHandle);\r\n CloseProcessHandles;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvCreateProcess.CheckNotWaiting;\r\nbegin\r\n if (FState = psWaiting) and (FRunningThreadCount > 0) then\r\n raise EJvProcessError.CreateRes(@RsEProcessIsRunning);\r\nend;\r\n\r\nprocedure TJvCreateProcess.CheckReady;\r\nbegin\r\n if FState <> psReady then\r\n raise EJvProcessError.CreateRes(@RsEProcessIsRunning);\r\nend;\r\n\r\nprocedure TJvCreateProcess.CheckRunning;\r\nbegin\r\n if FState = psReady then\r\n raise EJvProcessError.CreateRes(@RsEProcessNotRunning);\r\nend;\r\n\r\nfunction TJvCreateProcess.CloseApplication(SendQuit: Boolean): Boolean;\r\nbegin\r\n CheckRunning;\r\n Result := InternalCloseApp(ProcessInfo.dwProcessId, SendQuit);\r\nend;\r\n\r\nprocedure TJvCreateProcess.CloseProcessHandles;\r\nbegin\r\n OSCheck(SafeCloseHandle(FProcessInfo.hProcess));\r\n OSCheck(SafeCloseHandle(FProcessInfo.hThread));\r\nend;\r\n\r\nprocedure TJvCreateProcess.CloseRead;\r\nbegin\r\n TJvReader(FInputReader).CloseRead;\r\n TJvReader(FErrorReader).CloseRead;\r\nend;\r\n\r\nprocedure TJvCreateProcess.CloseWrite;\r\nbegin\r\n if FWaitThread is TJvConsoleThread then\r\n TJvConsoleThread(FWaitThread).CloseWrite;\r\nend;\r\n\r\nprocedure TJvCreateProcess.HandleThreadTerminated;\r\nbegin\r\n if FState = psWaiting then\r\n begin\r\n Dec(FRunningThreadCount);\r\n if FRunningThreadCount = 0 then\r\n begin\r\n GotoReadyState;\r\n if Assigned(FOnTerminate) then\r\n FOnTerminate(Self, FExitCode);\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJvCreateProcess.GetConsoleOutput: TStrings;\r\nbegin\r\n Result := FInputReader.ConsoleOutput;\r\nend;\r\n\r\nfunction TJvCreateProcess.GetEnvironment: TStrings;\r\nbegin\r\n Result := FEnvironment;\r\nend;\r\n\r\nfunction TJvCreateProcess.GetHandle: THandle;\r\nbegin\r\n if FHandle = 0 then\r\n FHandle := AllocateHWndEx(WndProc);\r\n Result := FHandle;\r\nend;\r\n\r\nfunction TJvCreateProcess.GetOnErrorRawRead: TJvCPSRawReadEvent;\r\nbegin\r\n Result := FErrorReader.OnRawRead;\r\nend;\r\n\r\nfunction TJvCreateProcess.GetOnErrorRead: TJvCPSReadEvent;\r\nbegin\r\n Result := FErrorReader.OnRead;\r\nend;\r\n\r\nfunction TJvCreateProcess.GetOnRawRead: TJvCPSRawReadEvent;\r\nbegin\r\n Result := FInputReader.OnRawRead;\r\nend;\r\n\r\nfunction TJvCreateProcess.GetOnRead: TJvCPSReadEvent;\r\nbegin\r\n Result := FInputReader.OnRead;\r\nend;\r\n\r\nprocedure TJvCreateProcess.GotoReadyState;\r\nbegin\r\n CheckNotWaiting;\r\n FState := psReady;\r\n CloseProcessHandles;\r\n FRunningThreadCount := 0;\r\nend;\r\n\r\nprocedure TJvCreateProcess.GotoRunningState;\r\nbegin\r\n CheckReady;\r\n FState := psRunning;\r\n CloseProcessHandles;\r\nend;\r\n\r\nprocedure TJvCreateProcess.GotoWaitState(const AThreadCount: Integer);\r\nbegin\r\n CheckReady;\r\n FState := psWaiting;\r\n FRunningThreadCount := AThreadCount;\r\nend;\r\n\r\nprocedure TJvCreateProcess.HandleReadEvent(Sender: TObject);\r\nbegin\r\n TJvReader(Sender).HandleReadEvent;\r\nend;\r\n\r\nprocedure TJvCreateProcess.Run;\r\nconst\r\n CreationFlagsValues: array [TJvCPSFlag] of DWORD =\r\n (CREATE_DEFAULT_ERROR_MODE, CREATE_NEW_CONSOLE, CREATE_NEW_PROCESS_GROUP,\r\n CREATE_SEPARATE_WOW_VDM, CREATE_SHARED_WOW_VDM, CREATE_SUSPENDED,\r\n CREATE_UNICODE_ENVIRONMENT, DETACHED_PROCESS);\r\nvar\r\n ConsoleHandles: TJvRWEHandles; // Will be used by the console\r\n LocalHandles: TJvRWEHandles; // Will be used by TJvCreateProcess\r\n LStartupInfo: TStartupInfo;\r\n Flags: DWORD;\r\n F: TJvCPSFlag;\r\n AppName, CurrDir: PChar;\r\n EnvironmentData: PChar;\r\nbegin\r\n GotoReadyState;\r\n\r\n FillChar(FProcessInfo, SizeOf(FProcessInfo), #0);\r\n\r\n Flags := ProcessPriorities[FPriority];\r\n for F := Low(TJvCPSFlag) to High(TJvCPSFlag) do\r\n if F in FCreationFlags then\r\n Inc(Flags, CreationFlagsValues[F]);\r\n AppName := Pointer(Trim(FApplicationName));\r\n CurrDir := Pointer(Trim(FCurrentDirectory));\r\n if Environment.Count = 0 then\r\n EnvironmentData := nil\r\n else\r\n StringsToMultiSz(EnvironmentData, Environment);\r\n\r\n LocalHandles := TJvRWEHandles.Create;\r\n ConsoleHandles := TJvRWEHandles.Create;\r\n try\r\n LStartupInfo := FStartupInfo.GetStartupInfo;\r\n\r\n if coRedirect in ConsoleOptions then\r\n begin\r\n ConstructPipe(LocalHandles, ConsoleHandles, coSeparateError in ConsoleOptions);\r\n\r\n with LStartupInfo do\r\n begin\r\n dwFlags := dwFlags or STARTF_USESTDHANDLES;\r\n hStdOutput := ConsoleHandles.Write;\r\n hStdInput := ConsoleHandles.Read;\r\n hStdError := ConsoleHandles.Error;\r\n end;\r\n end;\r\n\r\n if not CreateProcess(AppName, PChar(FCommandLine), nil, nil, coRedirect in ConsoleOptions,\r\n Flags, EnvironmentData, CurrDir, LStartupInfo, FProcessInfo) then\r\n begin\r\n CloseProcessHandles;\r\n RaiseLastOSError;\r\n end;\r\n\r\n if coRedirect in ConsoleOptions then\r\n begin\r\n { We use a counter to determine whether all threads are done.\r\n This counter must be set before a thread is created, because some\r\n consoles are so short living that for example the wait thread (FWaitThread)\r\n is terminated before the read thread (FInputReader) is created.\r\n See Mantis #1393.\r\n }\r\n\r\n if coSeparateError in ConsoleOptions then\r\n GotoWaitState(3)\r\n else\r\n GotoWaitState(2);\r\n\r\n FWaitThread := TJvConsoleThread.Create(FProcessInfo.hProcess, LocalHandles.ExtractWrite);\r\n FWaitThread.OnTerminate := WaitThreadTerminated;\r\n FWaitThread.{$IFDEF COMPILER14_UP}Start{$ELSE}Resume{$ENDIF COMPILER14_UP};\r\n\r\n TJvReader(FInputReader).CreateThread(LocalHandles.ExtractRead);\r\n\r\n if coSeparateError in ConsoleOptions then\r\n TJvReader(FErrorReader).CreateThread(LocalHandles.ExtractError);\r\n end\r\n else\r\n if WaitForTerminate then\r\n begin\r\n GotoWaitState(1);\r\n\r\n FWaitThread := TJvWaitForProcessThread.Create(FProcessInfo.hProcess);\r\n FWaitThread.OnTerminate := WaitThreadTerminated;\r\n FWaitThread.{$IFDEF COMPILER14_UP}Start{$ELSE}Resume{$ENDIF COMPILER14_UP};\r\n end\r\n else\r\n begin\r\n { http://support.microsoft.com/default.aspx?scid=kb;en-us;124121 }\r\n WaitForInputIdle(FProcessInfo.hProcess, INFINITE);\r\n GotoRunningState;\r\n end;\r\n finally\r\n { Close pipe handles (do not continue to modify the parent).\r\n You need to make sure that no handles to the write end of the\r\n output pipe are maintained in this process or else the pipe will\r\n not close when the child process exits and the ReadFile will hang.\r\n }\r\n ConsoleHandles.Free;\r\n LocalHandles.Free;\r\n FreeMultiSz(EnvironmentData);\r\n end;\r\nend;\r\n\r\nprocedure TJvCreateProcess.SetCommandLine(const Value: string);\r\nbegin\r\n FCommandLine := Value;\r\n {$IFDEF UNICODE}\r\n { A constant string will cause an access violation in CreateProcessW }\r\n if StringRefCount(FCommandLine) = -1 then\r\n FCommandLine := Copy(FCommandLine, 1, MaxInt);\r\n {$ENDIF UNICODE}\r\nend;\r\n\r\nprocedure TJvCreateProcess.SetEnvironment(const Value: TStrings);\r\nbegin\r\n FEnvironment.Assign(Value);\r\nend;\r\n\r\nprocedure TJvCreateProcess.SetOnErrorRawRead(\r\n const Value: TJvCPSRawReadEvent);\r\nbegin\r\n FErrorReader.OnRawRead := Value;\r\nend;\r\n\r\nprocedure TJvCreateProcess.SetOnErrorRead(const Value: TJvCPSReadEvent);\r\nbegin\r\n FErrorReader.OnRead := Value;\r\nend;\r\n\r\nprocedure TJvCreateProcess.SetOnRawRead(const Value: TJvCPSRawReadEvent);\r\nbegin\r\n FInputReader.OnRawRead := Value;\r\nend;\r\n\r\nprocedure TJvCreateProcess.SetOnRead(const Value: TJvCPSReadEvent);\r\nbegin\r\n FInputReader.OnRead := Value;\r\nend;\r\n\r\nprocedure TJvCreateProcess.SetStartupInfo(Value: TJvCPSStartupInfo);\r\nbegin\r\n FStartupInfo.Assign(Value);\r\nend;\r\n\r\nprocedure TJvCreateProcess.SetWaitForTerminate(const Value: Boolean);\r\nbegin\r\n GotoReadyState;\r\n FWaitForTerminate := Value;\r\nend;\r\n\r\nprocedure TJvCreateProcess.StopWaiting;\r\nbegin\r\n TerminateWaitThread;\r\nend;\r\n\r\nprocedure TJvCreateProcess.Terminate;\r\nbegin\r\n CheckRunning;\r\n InternalTerminateProcess(FProcessInfo.dwProcessId);\r\nend;\r\n\r\nprocedure TJvCreateProcess.TerminateTree;\r\nbegin\r\n CheckRunning;\r\n InternalTerminateProcessTree(FProcessInfo.dwProcessId);\r\nend;\r\n\r\nprocedure TJvCreateProcess.TerminateWaitThread;\r\nbegin\r\n { This is a dangerous function; because the read thread uses a blocking\r\n function there's no way we can stop it (normally); just signal the\r\n thread that is has to end;\r\n\r\n Note that thus it's the user responsibility to ensure that the console\r\n will end. If the console ends, the read thread will end also.\r\n\r\n An console can (always?) be ended by calling 'TJvCreateProcess.Terminate'\r\n }\r\n if FState = psWaiting then\r\n begin\r\n if Assigned(FWaitThread) then\r\n begin\r\n FWaitThread.OnTerminate := nil;\r\n TJvWaitForProcessThread(FWaitThread).TerminateThread;\r\n FWaitThread := nil;\r\n end;\r\n TJvReader(FInputReader).Terminate;\r\n TJvReader(FErrorReader).Terminate;\r\n\r\n FRunningThreadCount := 0;\r\n GotoReadyState;\r\n end;\r\nend;\r\n\r\nprocedure TJvCreateProcess.WaitThreadTerminated(Sender: TObject);\r\nbegin\r\n FExitCode := TJvWaitForProcessThread(Sender).FExitCode;\r\n FWaitThread := nil;\r\n\r\n // The user must be able to throw an exception in his OnTerminate handler.\r\n // But, if we call the OnTerminate handler now, and an exception is thrown\r\n // the application will halt:\r\n // Because DoThreadTerminated is called by a thread via Synchronize,\r\n // exceptions are handled by the thread, which will halt the execution of\r\n // the whole program. See mantis #3617\r\n\r\n // Another reason to use messages is that the threads can end almost\r\n // simultanious; without messages we should have used critical sections\r\n // to determine whether the last thread has ended.\r\n\r\n PostMessage(Handle, CM_THREADTERMINATED, 0, 0);\r\nend;\r\n\r\nprocedure TJvCreateProcess.WndProc(var Msg: TMessage);\r\nbegin\r\n try\r\n with Msg do\r\n case Msg of\r\n CM_READ: HandleReadEvent(TObject(WParam));\r\n CM_THREADTERMINATED: HandleThreadTerminated;\r\n else\r\n Result := DefWindowProc(Handle, Msg, WParam, LParam);\r\n end;\r\n except\r\n if Assigned(ApplicationHandleException) then\r\n ApplicationHandleException(Self);\r\n end;\r\nend;\r\n\r\nfunction TJvCreateProcess.Write(const S: AnsiString): Boolean;\r\nbegin\r\n Result := (FWaitThread is TJvConsoleThread) and\r\n TJvConsoleThread(FWaitThread).Write(S);\r\nend;\r\n\r\nfunction TJvCreateProcess.WriteLn(const S: AnsiString): Boolean;\r\nbegin\r\n Result := Write(S + sLineBreak);\r\nend;\r\n\r\n\r\n//=== { TJvReader } ==========================================================\r\n\r\nprocedure TJvReader.CloseRead;\r\nbegin\r\n if Assigned(FThread) then\r\n FThread.CloseRead;\r\nend;\r\n\r\nprocedure TJvReader.CreateThread(const AReadHandle: THandle);\r\nbegin\r\n FStartsOnNewLine := True;\r\n FCurrentLine := '';\r\n FCursorPosition := 0;\r\n\r\n FThread := TJvReadThread.Create(Self, AReadHandle, FCreateProcess.Handle);\r\n FThread.OnTerminate := ThreadTerminated;\r\n FThread.{$IFDEF COMPILER14_UP}Start{$ELSE}Resume{$ENDIF COMPILER14_UP};\r\nend;\r\n\r\nprocedure TJvReader.DoRawReadEvent(Data: PAnsiChar; const ASize: Cardinal);\r\nvar\r\n S: AnsiString;\r\nbegin\r\n if Assigned(FOnRawRead) then\r\n begin\r\n // Do copy because of possible #0's etc.\r\n SetString(S, Data, ASize);\r\n FOnRawRead(FCreateProcess, string(S));\r\n end;\r\nend;\r\n\r\nprocedure TJvReader.DoReadEvent(const EndsWithNewLine: Boolean);\r\nbegin\r\n // Notify user and update current line & cursor\r\n if not (coOwnerData in FCreateProcess.ConsoleOptions) then\r\n begin\r\n if FStartsOnNewLine or (ConsoleOutput.Count = 0) then\r\n ConsoleOutput.Add(string(FCurrentLine))\r\n else\r\n ConsoleOutput[ConsoleOutput.Count - 1] := string(FCurrentLine);\r\n end;\r\n if Assigned(FOnRead) then\r\n FOnRead(FCreateProcess, string(FCurrentLine), FStartsOnNewLine);\r\n if EndsWithNewLine then\r\n begin\r\n FCurrentLine := '';\r\n FCursorPosition := 0;\r\n end;\r\n FStartsOnNewLine := EndsWithNewLine;\r\nend;\r\n\r\nprocedure TJvReader.HandleReadEvent;\r\nvar\r\n ASize: Cardinal;\r\nbegin\r\n { Copy the data from the read thread to the this (main) thread and\r\n parse the console output }\r\n\r\n while Assigned(FThread) and FThread.ReadBuffer(FParseBuffer, ASize) do\r\n ParseConsoleOutput(FParseBuffer, ASize);\r\nend;\r\n\r\nprocedure TJvReader.ParseConsoleOutput(Data: PAnsiChar; ASize: Cardinal);\r\nvar\r\n P, Q: PAnsiChar;\r\n\r\n procedure DoOutput;\r\n { Copy chunk [Q..P) to the current line & Update cursor position }\r\n var\r\n ChunkSize: Integer;\r\n begin\r\n ChunkSize := P - Q;\r\n if ChunkSize <= 0 then\r\n Exit;\r\n\r\n // Does the chunck fit on the current line..\r\n if Length(FCurrentLine) < FCursorPosition + ChunkSize then\r\n // .. if not resize current line\r\n SetLength(FCurrentLine, FCursorPosition + ChunkSize);\r\n\r\n // Move the chunk to the current line\r\n Move(Q^, (PAnsiChar(FCurrentLine) + FCursorPosition)^, ChunkSize);\r\n\r\n // Update the cursor\r\n Inc(FCursorPosition, ChunkSize);\r\n end;\r\n\r\n procedure DoTab;\r\n begin\r\n // Does the chunck (8 spaces) fit on the current line..\r\n if Length(FCurrentLine) < FCursorPosition + 8 then\r\n // .. if not resize current line }\r\n SetLength(FCurrentLine, FCursorPosition + 8);\r\n\r\n // Fill 8 spaces on the currentline at the cursor position\r\n FillChar((PAnsiChar(FCurrentLine) + FCursorPosition)^, 8, #32);\r\n\r\n // Update the cursor\r\n Inc(FCursorPosition, 8);\r\n end;\r\n\r\nbegin\r\n DoRawReadEvent(Data, ASize);\r\n\r\n P := Data;\r\n Q := Data;\r\n\r\n while Cardinal(P - Data) < ASize do\r\n case P^ of\r\n #0, #7: // NULL and BELL\r\n begin\r\n // Replace with space\r\n P^ := #32;\r\n Inc(P);\r\n end;\r\n Backspace:\r\n begin\r\n DoOutput;\r\n Dec(FCursorPosition);\r\n if FCursorPosition < 0 then\r\n FCursorPosition := 0;\r\n Inc(P);\r\n Q := P;\r\n end;\r\n Tab:\r\n begin\r\n // Replace with 8 spaces\r\n DoOutput;\r\n DoTab;\r\n Inc(P);\r\n Q := P;\r\n end;\r\n Lf:\r\n begin\r\n DoOutput;\r\n DoReadEvent(True);\r\n Inc(P);\r\n Q := P;\r\n end;\r\n Cr:\r\n begin\r\n DoOutput;\r\n FCursorPosition := 0;\r\n Inc(P);\r\n Q := P;\r\n end;\r\n else\r\n Inc(P);\r\n end;\r\n DoOutput;\r\n DoReadEvent(False);\r\nend;\r\n\r\nprocedure TJvReader.Terminate;\r\nbegin\r\n if Assigned(FThread) then\r\n begin\r\n FThread.OnTerminate := nil;\r\n FThread.TerminateThread;\r\n FThread := nil;\r\n end;\r\nend;\r\n\r\nprocedure TJvReader.ThreadTerminated(Sender: TObject);\r\nbegin\r\n // Read for the last time data from the read thread\r\n HandleReadEvent;\r\n if FCurrentLine <> '' then\r\n DoReadEvent(False);\r\n\r\n FThread := nil;\r\n\r\n PostMessage(FCreateProcess.Handle, CM_THREADTERMINATED, 0, 0);\r\nend;\r\n\r\n//=== { TJvRWEHandles } ======================================================\r\n\r\ndestructor TJvRWEHandles.Destroy;\r\nbegin\r\n Clear;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvRWEHandles.Clear;\r\nbegin\r\n Read := 0;\r\n Write := 0;\r\n Error := 0;\r\nend;\r\n\r\nfunction TJvRWEHandles.ExtractHandle(const Index: Integer): THandle;\r\nbegin\r\n Result := FHandle[Index];\r\n FHandle[Index] := 0;\r\nend;\r\n\r\nfunction TJvRWEHandles.GetHandle(const Index: Integer): THandle;\r\nbegin\r\n Result := FHandle[Index];\r\nend;\r\n\r\nprocedure TJvRWEHandles.SetHandle(const Index: Integer;\r\n const Value: THandle);\r\nbegin\r\n if Value <> FHandle[Index] then\r\n begin\r\n if FHandle[Index] <> 0 then\r\n CloseHandle(FHandle[Index]);\r\n FHandle[Index] := Value;\r\n end;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvCsvData.pas", "content": "{-----------------------------------------------------------------------------\r\nJvCsvDataSet\r\n\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is by Warren Postma.\r\n\r\nContributor(s): Warren Postma (warrenpstma att hotmail dott com)\r\n\r\n2003-07-29 Warren Postma - New features (Sorting, Indexing, UserData)\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\nii\r\n\r\nDescription:\r\n TJvCsvDataSet in-memory-dataset component usable by any\r\n VCL Data Aware Controls.\r\n TJvCsvDataSet appears in the 'Jv Data Access' tab of the\r\n Component Palette.\r\n\r\n USAGE:\r\n Drop this component onto a form, connect it to\r\n a standard VCL DataSource, then connect any\r\n data aware control to that datasource, using\r\n the standard method you would use if you were\r\n using any other data aware components.\r\n\r\n KEY PROPERTIES:\r\n You must set the filename to a valid CSV FileName\r\n such as \"MyCsvFile.csv\", and you must define the\r\n CSV Fields, using the CSVFieldDef property.\r\n If you don't set those properties, the component\r\n won't work. It is also *recommended* but not\r\n required to right-click on the component and\r\n let the Delphi IDE define the field objects\r\n so that you can access them in your program.\r\n\r\n MORE HELP, DOCUMENTATION:\r\n This object works just like the VCL BDE TTable,\r\n so consult\r\n the Delphi help file about TTable if you want\r\n more information.\r\n\r\nKnown Issues and Updates:\r\n Sept 3, 2009 - Delphi 2009 Version\r\n - New Streams based file-I/O system\r\n - Flexible record size (instead of fixed record size)\r\n - Can now handle carriage-return and linefeed characters\r\n inside quotes. This allows multi-line TMemo fields to work\r\n properly when attached to JvCsvDataset.\r\n\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvCsvData.pas 13419 2012-09-10 11:07:42Z obones $\r\n\r\n\r\n\r\n//------------------------------------------------------------------------\r\n//\r\n// TJvCSVDataSet\r\n//\r\n// An in-memory TDataSet component similar to TTable but with optional\r\n// saving to CSV file, and which, unlike using TTable in CSV mode, does not\r\n// utilize the BDE, or any external database access layers to do its work.\r\n//\r\n// Since this component inherits from TDataSource, you can use it with any\r\n// standard VCL data aware components. Remember to link to a DataSource,\r\n// before you can link this to any data aware controls!\r\n//\r\n//\r\n// TJvCustomCsvDataSet\r\n//\r\n// Internally, we first define a TJvCustomCsvDataSet a base class.\r\n// Nothing published. This exists so you can easily inherit from it\r\n// and define your own version of the component, and publish whatever\r\n// properties and methods you wish to publish, and you can hide or\r\n// override any other elements you don't wish to publish.\r\n//\r\n// How To Use:\r\n// For most users it is important to first set up the important Property\r\n// called CsvFieldDef which describes the expected fields and their types\r\n// since the CSV file itself contains insufficient information to guess the\r\n// field types. Also, if you want to create new files, starting from a blank\r\n// file, you absolutely must set up CsvFieldDef first!\r\n// If you insist on using a fly-by-the-seat-of-your-pants approach (not setting\r\n// CsvFieldDef), the component will just read the first line of whatever CSV file\r\n// you give it, and then assume string field type for all columns, which is\r\n// fine for some people since the CSV file really is just strings. This can\r\n// be handy if you want to write a tool that can open ANY csv file no matter\r\n// what column names or how many columns it contains.\r\n//\r\n// Example CsvFieldDef string:\r\n// ABC:$80,DEFG:$140,HIJKLMN:%,OPQRST:@\r\n//\r\n// $ = string (ftString) - also used if no character is given.\r\n// % = whole Integer value (ftInteger)\r\n// & = floating point value (ftFloat)\r\n// @ = Ascii datetime value (ftDateTime) as YYYY/MM/DD HH:MM:SS (Component Specific)\r\n// # = Hex-Ascii Timestamp (A93F38C9) seconds since Jan 1, 1970 GMT (Component Specific)\r\n// ^ = Hex-Ascii Timestamp (A93F38CP) corrected to local timezone (Component Specific)\r\n// ! = Boolean Field (0 in csv file=false, not 0 = true, blank = NULL)\r\n// ~ = UTF8 CSV Field (ftWideString) [currently implemented on Delphi 2009 only]\r\n//\r\n// NOTE: YOU SHOULD PROBABLY JUST USE THE BUILT-IN CsvFieldDef PROPERTY EDITOR\r\n// (CLICK the '...' button in the properties inspector beside CsvFieldDef)\r\n// INSTEAD OF MEMORIZING ALL THIS FIELD TYPE STUFF.\r\n//\r\n// Originally written by Warren Postma\r\n// Contact: warren.postma _@_ gmail _D0T_ com\r\n//\r\n// Donated to the Delphi JEDI Project.\r\n// All Copyrights and Ownership donated to the Delphi JEDI Project.\r\n//------------------------------------------------------------------------\r\n\r\nunit JvCsvData;\r\n{$M+} // REQUIRED in D2007.\r\n\r\n{$I jvcl.inc}\r\n\r\n{$R-} // YOU CANNOT ENABLE RANGE CHECKING IN THIS UNIT! WE DO MANY DYNAMIC-ALLOCATED-MEMORY TECHNIQUES AND\r\n // GROWABLE-DATA-STRUCTURES AT RUNTIME THAT ARE INCOMPATIBLE WITH DELPHI'S RANGE CHECKING TECHNIQUES.\r\n // YOU ALSO PROBABLY CAN'T CONVERT THIS UNIT TO DOTNET IN ANY REASONABLE OR EASY WAY. THERE ARE A TON\r\n // OF UNSAFE LOW LEVEL MEMORY AND POINTER ACTIVITIES IN THIS UNIT!\r\n\r\ninterface\r\n\r\n{$IFDEF COMPILER7_UP}\r\n// The WideString field code will COMPILE on Delphi 7, but the WideString field only WORKS\r\n// on Delphi 2007 and up.\r\n{$DEFINE JVCSV_WIDESTRING}\r\n{$ENDIF COMPILER7_UP}\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows,\r\n Classes,\r\n {$IFDEF UNICODE}\r\n JclBase, // now BOM constants are in JclBase formerly in JclUnicode\r\n {$ENDIF UNICODE}\r\n JvJCLUtils, // some constants needed.\r\n SysUtils,\r\n DB;\r\n\r\n{$IFNDEF UNICODE}\r\ntype\r\n RawByteString = AnsiString;\r\n{$ENDIF ~UNICODE}\r\n\r\nconst\r\n JvCsvRowMagic = $91AF9823;\r\n JvCsvRowMagic2 = $91AF9824;\r\n JvCsvQuote = #34;\r\n JvCsvLf = #10;\r\n JvCsvCR = #13;\r\n\r\n JvCsv_MaxCalcDataOffset = 256; // # bytes per record for Calculated Field Data.\r\n\r\n JvCsv_MAXCOLUMNS = 120;\r\n JvCsv_MAXLINELENGTH = 16384;\r\n JvCsv_DEFAULT_CSV_STR_FIELD = 80; // If CsvFieldDef doesn't have :123 suffix specifying numeric field length, then default to 80 chars.\r\n JvCsv_MINLINELENGTH = 10;\r\n JvCsv_COLUMN_ENDMARKER = $FFFF;\r\n JvCsv_ON_BOF_CRACK = -1;\r\n JvCsv_ON_EOF_CRACK = -2;\r\n\r\n\r\n RowAlreadySaved=0;\r\n RowNeedsSaving=1;\r\n { return values from CompareBookmarks: }\r\n Bookmark_Less = -1; // b1 < b2\r\n Bookmark_Gtr = 1; // b1 > b2\r\n Bookmark_Eql = 0; // b1 = b2\r\n\r\n {these values can be changed at runtime, but not at design time,and should only\r\n be changed before the dataset is opened or any rows are created:}\r\n JvCsvDefaultTextBufferSize = 2048; // Default memory allocation sizes are the same as before.\r\n JvCsvDefaultMarginSize = 2; // Two bytes of margin. Remove at your own risk!\r\n\r\n\r\n { fmJVCSV__xxx constants: }\r\n { File stream mode flags used setting the mode of TJvCsvStream. }\r\n { These bits must be in the high-word, because the Least }\r\n { Significant 16 bits are reserved for standard file stream mode bits. }\r\n { Standard system values like fmOpenReadWrite are in SysUtils. }\r\n fmJVCSV_APPEND_FLAG = $20000;\r\n fmJVCSV_REWRITE_FLAG = $10000;\r\n fmJVCSV_Append = fmOpenReadWrite or fmJVCSV_APPEND_FLAG;\r\n fmJVCSV_OpenReadShared = fmOpenRead or fmShareDenyWrite;// or fmShareDenyNone; // yet another friendly mode constant\r\n fmJVCSV_OpenRewrite = fmOpenReadWrite or fmJVCSV_REWRITE_FLAG; // yet another friendly mode constant.\r\n fmJVCSV_Truncate = fmCreate or fmJVCSV_REWRITE_FLAG; // yet another friendly mode constant.\r\n fmJVCSV_Rewrite = fmCreate or fmJVCSV_REWRITE_FLAG; // yet another friendly mode constant.\r\n\r\n JvCsvStreamReadChunkSize = 8192; // 8k chunk reads.\r\n\r\ntype\r\n EJvCsvDataSetError = class(EDatabaseError);\r\n // Subclass DB.EDatabaseError so we can work nicely with existing Delphi apps.\r\n\r\n EJvCsvKeyError = class(EDatabaseError); // Key Uniqueness or Key Problem\r\n\r\n {$IFDEF RTL240_UP}\r\n PJvMemBuffer = PByte;\r\n TJvRecordBuffer = TRecordBuffer;\r\n TJvValueBuffer = TValueBuffer;\r\n TJvBookmark = TBookmark;\r\n {$ELSE}\r\n {$IFDEF UNICODE}\r\n PJvMemBuffer = PByte;\r\n {$ELSE}\r\n PJvMemBuffer = PAnsiChar;\r\n {$ENDIF UNICODE}\r\n TJvRecordBuffer = Pointer;\r\n TJvValueBuffer = Pointer;\r\n TJvBookmark = Pointer;\r\n {$ENDIF RTL240_UP}\r\n\r\n { Special Event Types }\r\n TJvCsvOnSpecialData = procedure(Sender: TObject; Index: Integer; NonCsvData: RawByteString) of object;\r\n\r\n TJvCsvOnGetFieldData = procedure(Sender: TObject; UserTag: Integer; UserData: Pointer; FieldName: string;\r\n var Value: string) of object;\r\n TJvCsvOnSetFieldData = procedure(Sender: TObject; UserTag: Integer; UserData: Pointer; FieldName: string;\r\n Value: string) of object;\r\n\r\n { SPECIAL TYPES OF DATABASE COLUMNS FOR THIS COMPONENT }\r\n { Columns are numeric, text, or one of two kinds of Specially Encoded date/time formats: }\r\n TJvCsvColumnFlag = (\r\n jcsvNull, // means not a valid type\r\n jcsvString,\r\n jcsvNumeric, // Integer or Float (% or &)\r\n jcsvAsciiDateTime,\r\n jcsvGMTDateTime,\r\n jcsvTZDateTime,\r\n jcsvAsciiDate,\r\n jcsvAsciiTime,\r\n jcsvStringUTF8 // special NEW column type (~) - september 2008\r\n );\r\n\r\n // SetFilterNum takes one of these as a compareOperator:\r\n // utility function JvCsvNumCondition uses this too.\r\n TJvCsvFilterNumCompare = (jfIntEqual, jfIntNotEqual, jfLessThan, jfGreaterThan);\r\n { pointer to special CSV COLUMN }\r\n PCsvColumn = ^TJvCsvColumn;\r\n // PFieldDef = ^TFieldDef;\r\n\r\n TJvCsvColumn = record\r\n FFlag: TJvCsvColumnFlag; // Column CSV Format Flags\r\n FKeyFlag: Boolean; // This column is part of the primary key! (new May 2003-WP)\r\n FPhysical: Integer; // Physical Column Ordering\r\n FFieldDef: TFieldDef; // Associated FieldDef\r\n end;\r\n\r\n { CSV COLUMNS are stored in a TList-Collection }\r\n TJvCsvColumns = class(TList)\r\n public\r\n procedure AddColumn(Item: PCsvColumn);\r\n function FindByFieldNo(FieldNo: Integer): PCsvColumn;\r\n procedure Clear; override;\r\n function FindByName(const FieldName: string): PCsvColumn;\r\n end;\r\n\r\n TJvCsvBookmark = record\r\n Flag: TBookmarkFlag;\r\n Data: Integer;\r\n end;\r\n\r\n { CSV Data File Row is not very dynamic in this version: }\r\n PtrToPtrToCsvRow = ^PCsvRow; // bookmark Data = Double pointer indirection! Fun fun fun!\r\n PCsvRow = ^TJvCsvRow; // a pointer to a record\r\n\r\n\r\n { Memory usage by JvCsvDataSet:\r\n\r\n A row is an allocated BLOCK of memory grabbed by ALLOCMEM and it must be copyable\r\n as a flat record type, so there can be NO ABSOLUTE POINTER REFERENCES only lookups\r\n to various points within this current block.\r\n\r\n First we have a JvCsvRow, then at some point after that, a JvCsvRowWordFields record\r\n is placed, which we must know how to locate by knowing what the effective size of\r\n the variable length JvCsvRow.Text field is. After the JvCsvRowWordFields record which is\r\n also variable length is stored the calculated field data.\r\n }\r\n TJvCsvRow = record { this MUST be a record, not a class, and must be a flag Data record type }\r\n Magic: Cardinal; // This is expected to be a magic value. If it's not, then the CSV data set is corrupt!\r\n AllocSize: Integer; // Size of this record. You can't copy CSV records between two CSV data sets if their sizes or separators differ!\r\n IsDirty: Byte; // record is dirty (needs to be written to disk)\r\n Separator: AnsiChar; // CSV Separator Character\r\n Columns: Integer;\r\n Index: Integer; // FData Index (-1 means not in FData)\r\n Bookmark: TJvCsvBookmark;\r\n Filtered: Boolean; // row is hidden from view right now.\r\n RecursionFlag: Boolean; // helps us fix endless recursion bug in GetFieldData callbacks.\r\n WordFieldsAddr: Integer; // 0 or -1 means WordFieldsAddr not allocated yet! 1..n means how many bytes after first byte of TJvCsvRow is the TJvCsvRowWordFields record.\r\n TextMaxLen: Integer; // Max size of Text area!\r\n _Text: array [0..JvCsv_MINLINELENGTH] of AnsiChar; // at least 10 characters of storage. typically MUCH MUCH more (ie 2k typical)\r\n end;\r\n\r\n TJvCsvRowWordFields = record\r\n Magic2: Cardinal; // Another magic value.\r\n WordField: array [0..JvCsv_MAXCOLUMNS + 1] of Word; // Contains a 15 bit offset value in range 0..37267 maximum,\r\n // the 16th (high bit) reserved as a this-column-dirty-bit!\r\n end;\r\n\r\n PJvCsvRowWordFields = ^TJvCsvRowWordFields;\r\n\r\n { Row collection }\r\n TJvCsvRows = class(TList)\r\n private\r\n FEnquoteBackslash: Boolean;\r\n FBackslashCrLf: Boolean; // Are CR/LFs changed to \\r and \\n?\r\n FRecordsValid: Boolean;\r\n // Optional user Data (only allocated if used, how efficient is that, eh.)\r\n FUserData: array of Pointer;\r\n FUserTag: array of Integer;\r\n FUserLength: Integer;\r\n // new dynamic-allocation-sizing fields:\r\n FTextBufferSize : Integer; // How big is TJvCsvRow.Text effectively?\r\n FMarginSize : Integer; // How much margin space after the calculated fields?\r\n\r\n FSeparator: Char;\r\n FDecimalSeparator: Char; { NOTE: DEFAULT value for historical backwards compatibilty reasons is the USA default of '.' }\r\n FFilteredCount: Integer; // number of records that are filtered\r\n\r\n function GetUserTag(Index: Integer): Integer;\r\n procedure SetUserTag(Index, Value: Integer);\r\n function GetUserData(Index: Integer): Pointer;\r\n procedure SetUserData(Index: Integer; Value: Pointer);\r\n\r\n function GetRowAllocSize: Integer;\r\n function RecordSize: Word;\r\n procedure InternalInitRecord(Buffer: TJvRecordBuffer);\r\n protected\r\n { note these are not intended to be used outside this unit, so they are protected.\r\n access these throught the CsvDataSet class public or published properties only. }\r\n property DecimalSeparator : Char read FDecimalSeparator write FDecimalSeparator default USDecimalSeparator;\r\n property Separator : Char read FSeparator write FSeparator;\r\n public\r\n constructor Create;\r\n\r\n procedure AddRow(Item: PCsvRow);\r\n function AllocRecordBuffer: PJvMemBuffer; { was PChar, now in tiburon it is PByte }\r\n\r\n procedure InsertRow(const Position: Integer; Item: PCsvRow);\r\n procedure AddRowStr(const Item: string); // convert string->TJvCsvRow\r\n function GetRowPtr(const RowIndex: Integer): PCsvRow;\r\n function GetRowAnsiStr(const RowIndex: Integer): string;\r\n procedure SetRowStr(const RowIndex: Integer; Value: string);\r\n procedure DeleteRow(const RowIndex: Integer);\r\n procedure SetARowItem(const RowIndex, ColumnIndex: Integer; Value: string);\r\n function GetARowItem(const RowIndex, ColumnIndex: Integer): string;\r\n procedure Clear; override;\r\n property EnquoteBackslash: Boolean read FEnquoteBackslash write FEnquoteBackslash;\r\n property BackslashCrLf:Boolean read FBackslashCrLf write FBackslashCrLf; // Are CR/LFs changed to \\r and \\n?\r\n property UserTag[Index: Integer]: Integer read GetUserTag write SetUserTag;\r\n property UserData[Index: Integer]: Pointer read GetUserData write SetUserData;\r\n\r\n property FilteredCount: Integer read FFilteredCount;\r\n\r\n { these properties should ONLY be set before any actual rows have been allocated. }\r\n property TextBufferSize: Integer read FTextBufferSize write FTextBufferSize; // How big is TJvCsvRow.Text effectively?\r\n property MarginSize: Integer read FMarginSize write FMarginSize; // How much margin space after the calculated fields? (typically 2 bytes)\r\n end;\r\n\r\n TArrayOfPCsvColumn = array of PCsvColumn;\r\n\r\n { TJvCustomCsvDataSetFilterFunction: Defines callback function to be passed to CustomFilter routine }\r\n TJvCustomCsvDataSetFilterFunction = function(RecNo: Integer): Boolean of object;\r\n\r\n\r\n //-------------------------------------------------------------------------\r\n // TJvCsvStream:\r\n //\r\n // Csv File Reader/Writer Class. Contains a JclFileStream.\r\n // Encapsulates reading/writing of CSV files. This version works\r\n // only with ASCII files but the plan is to extend it to work with UTF8.\r\n //\r\n // TJvCsvStream contains an internal TFileStream instead of a JCL Stream because it\r\n // is higher performance, do NOT replace the TFileStream below with a JCL\r\n // stream.\r\n //-------------------------------------------------------------------------\r\n TJvCsvStream = class(TObject)\r\n private\r\n FStream: TFileStream; // Tried TJclFileStream also but it was too slow! Do NOT use JCL streams here. -wpostma.\r\n FFilename: string;\r\n FStreamBuffer: PAnsiChar;\r\n FStreamIndex: Integer;\r\n FStreamSize: Integer;\r\n FLastReadFlag: Boolean;\r\n\r\n procedure _StreamReadBufInit;\r\n public\r\n function ReadLine: RawByteString; { read a string, one per line, wow. Text files. Cool eh?}\r\n\r\n procedure Append;\r\n procedure Rewrite;\r\n\r\n procedure Write(const s: RawByteString); {write a string. wow, eh? }\r\n procedure WriteLine(const s: RawByteString); {write string followed by Cr+Lf }\r\n\r\n procedure WriteChar(c: AnsiChar);\r\n\r\n procedure WriteCrLf;\r\n //procedure Write(const s: string);\r\n\r\n function Eof: Boolean; {is at end of file? }\r\n\r\n { MODE is typically a fmJVCSV_xxx constant thatimplies a default set of stream mode bits plus some extended bit flags that are specific to this stream type.}\r\n constructor Create(const FileName: string; Mode: DWORD = fmJVCSV_OpenReadShared; Rights: Cardinal = 0); reintroduce; virtual;\r\n destructor Destroy; override;\r\n\r\n function Size: Int64; //override; // sanity\r\n\r\n { read-only properties at runtime}\r\n property Filename: string read FFilename;\r\n property Stream: TFileStream read FStream; { Get at the underlying stream object}\r\n end;\r\n\r\n\r\n //-------------------------------------------------------------------------\r\n // TJvCustomCsvDataSet: BASE CLASS.\r\n // Easily Customizeable DataSet descendant our CSV handler and\r\n // any other variants we create:\r\n //-------------------------------------------------------------------------\r\n TJvCustomCsvDataSet = class(TDataSet)\r\n private\r\n FOpenFileName: string; // This is the Fully Qualified path and filename expanded from the FTableName property when InternalOpen was last called.\r\n FValidateHeaderRow: Boolean;\r\n FExtendedHeaderInfo: Boolean;\r\n FCreatePaths: Boolean;\r\n FFormatSettings: TFormatSettings;\r\n\r\n procedure SetSeparator(const Value: Char);\r\n procedure InternalQuickSort(SortList: PPointerList; L, R: Integer;\r\n const SortColumns: TArrayOfPCsvColumn; ACount: Integer; const SortAscending: array of Boolean);\r\n\r\n procedure QuickSort(AList: TList; const SortColumns: TArrayOfPCsvColumn; ACount: Integer;\r\n const SortAscending: array of Boolean);\r\n procedure AutoCreateDir(const FileName: string);\r\n function GetEnquoteBackslash: Boolean;\r\n procedure SetEnquoteBackslash(const Value: Boolean);\r\n function GetSeparator: Char;\r\n function GetMarginSize: Integer;\r\n function GetTextBufferSize: Integer;\r\n procedure SetMarginSize(const Value: Integer);\r\n procedure SetTextBufferSize(const Value: Integer);\r\n function GetBackslashCrLf: Boolean;\r\n procedure SetBackslashCrLf(const Value: Boolean);\r\n function GetDecimalSeparator: Char;\r\n // ----------- THIS IS A DUMMY FUNCTION, DON'T USE IT!:\r\n function LocateRecord(const KeyFields: string; const KeyValues: Variant; Options: TLocateOptions): Boolean;\r\n procedure SetDecimalSeparator(const Value: Char);\r\n\r\n function _CsvFloatToStr(Value: Double): string;\r\n\r\n procedure SetRowFiltered(ARow: PCsvRow; AFiltered: Boolean);\r\n protected\r\n // (rom) inacceptable names. Probably most of this should be private.\r\n FTempBuffer: TJvRecordBuffer; // Allocated on first access to field variable data only!\r\n FInitialWorkingDirectory: string; // Current working dir may change in a delphi app, causing us trouble.\r\n FStoreDefs: Boolean;\r\n FTimeZoneCorrection: Integer; // defaults to 0 (none)\r\n FFileDirty: Boolean; // file needs to be written back to disk?\r\n\r\n FDefaultCsvFieldDefs: Boolean; // True if the CsvFieldDefs come from the file\r\n FCsvFieldDef: string; // Our own \"Csv Field Definition String\"\r\n FCsvKeyDef: string; // CSV Key Definition string. Required if FCsvUniqueKeys is True\r\n FCsvKeyCount: Integer; // Set by parsing FCsvKeyDef\r\n FAscending: array of Boolean;\r\n\r\n FCsvKeyFields: TArrayOfPCsvColumn;\r\n\r\n FCsvUniqueKeys: Boolean;\r\n // CSV Key Uniqueness option. Also requires that all fields that are part of the Unique Key be Non Null.\r\n FCsvCaseInsensitiveComparison: Boolean;\r\n // CSV Key Uniqueness and Key Comparisons - case insensitive mode if True, else case sensitive.\r\n\r\n FIsFiltered: Boolean; // Filter conditions have been set.\r\n\r\n FEmptyRowStr: string; // A string of just separators (used to add a new empty row)\r\n FHeaderRow: string; // first row of CSV file.\r\n FPendingCsvHeaderParse: Boolean; // NEW FEB 2004 WP.\r\n FTableName: string; // CSV File Name\r\n FAppendedFieldCount: Integer; // Number of fields not in the file on disk, appended to file as NULLs during import.\r\n FRecordPos: Integer;\r\n\r\n FCursorOpen: Boolean;\r\n FFilterBuffer: TJvRecordBuffer; // used when we implement filtering (later)\r\n FReadOnly: Boolean;\r\n FLoadsFromFile: Boolean;\r\n FHasHeaderRow: Boolean;\r\n FSavesChanges: Boolean;\r\n FAutoBackupCount: Integer; // Keep Last N Copies the Old Csv File, updated before each save?\r\n FInsertBlocked: Boolean; // internal way to block new records but allows editing of existing ones!\r\n FPostBlocked: Boolean; // internal way to block posting of changes, but allows inserting of new ones!\r\n\r\n { Data record holder }\r\n FCsvColumns: TJvCsvColumns; // Column information\r\n FData: TJvCsvRows; // Rows are a Collection of Data pointers.\r\n\r\n { temporary holding space only, for a TStringList of the file contents }\r\n //FCsvFileAsStrings: TStringList; // Can't handle embedded cr/lfs in CSV records. So we replace with our own reader.\r\n FCsvFileTopLine: string; // similar to FHeaderRow, but blank unless we actually loaded from a real CSV file on disk.\r\n FCsvFileLoaded: Boolean; // Did InternalFileOpen already load the file? (makes it so that Duplicate calls don't re-load the entire file.)\r\n FCsvStream: TJvCsvStream;\r\n {$IFDEF UNICODE}\r\n FUtf8Detected: Boolean;\r\n {$ENDIF UNICODE}\r\n\r\n FSpecialDataMarker: RawByteString; // Unless defined, OnSpecialData won't ever be called.\r\n\r\n { event pointers }\r\n FOnSpecialData: TJvCsvOnSpecialData; // XXX Deprecated feature - suggest removal. -Wpostma.\r\n FOnGetFieldData: TJvCsvOnGetFieldData;\r\n // Helps to allow you to update the contents of your CSV Data from some other object in memory.\r\n FOnSetFieldData: TJvCsvOnSetFieldData;\r\n // Helps to keep some other thing in sync with the contents of a changing CSV file.\r\n\r\n FAlwaysEnquoteStrings: Boolean; // Always put Double quotes around strings (for some CSV file reading software this is required.)\r\n FAlwaysEnquoteFloats: Boolean; // Always put Double quotes around floating point values (useful when DecimalSeparator==CsvSeparator)\r\n FUseSystemDecimalSeparator: Boolean; // Default is false which always uses US mode.\r\n FAppendOnly: Boolean; // If true, we don't load the entire content of the CSV from disk, only the last row, and every time we append and write, we only maintain the last row in memory (saves a lot of RAM.)\r\n\r\n procedure SetActive(Value: Boolean); override;\r\n\r\n // Internal Use Only Protected Methods\r\n // function GetDataFileSize: Integer; virtual;\r\n function GetActiveRecordBuffer: TJvRecordBuffer; virtual;\r\n procedure CsvRowInit(RowPtr: PCsvRow);\r\n\r\n //NEW and very handy dandy!\r\n function GetFieldValueAsVariant(CsvColumnData: PCsvColumn; Field: TField; RecordIndex: Integer): Variant;\r\n\r\n // New filtering on cursor (GetRecord advances the cursor past\r\n // any hidden rows using InternalSkipForward).\r\n function InternalSkipFiltered(DefaultResult: TGetResult; ForwardBackwardMode: Boolean): TGetResult;\r\n\r\n function ReadCsvFileStream: Boolean;\r\n function WriteCsvFileStream: Boolean;\r\n\r\n // Internal methods used by sorting:\r\n function InternalFieldCompare(Column: PCsvColumn; Left, Right: PCsvRow): Integer;\r\n function InternalCompare(const SortColumns: TArrayOfPCsvColumn; SortColumnCount: Integer;\r\n Left, Right: PCsvRow; const SortAscending: array of Boolean): Integer;\r\n\r\n // key uniqueness needs this:\r\n function InternalFindByKey(Row: PCsvRow): Integer;\r\n\r\n // Each ROW Record has an internal Data pointer (similar to the\r\n // user-accessible 'Data: Pointer' stored in treeviews, etc)\r\n function GetRowUserData: Pointer;\r\n procedure SetRowUserData(UserData: Pointer);\r\n\r\n function GetRowTag: Integer;\r\n procedure SetRowTag(TagValue: Integer);\r\n\r\n // protected TDataSet base METHODS:\r\n procedure SetTableName(const Value: string); virtual;\r\n function FieldDefsStored: Boolean; virtual;\r\n function GetCanModify: Boolean; override; //already virtual!\r\n\r\n // internal calls:\r\n //procedure AppendPlaceHolderCommasToAllRows(Strings: TStrings); // Add placeholders to end of a csv file.\r\n procedure ProcessCsvHeaderRow;\r\n procedure ProcessCsvDataRow(const DataRow: string; Index: Integer);\r\n procedure SetCsvFieldDef(const Value: string);\r\n\r\n { Mandatory VCL TDataSet Overrides - Pure Virtual Methods of Base Class }\r\n function AllocRecordBuffer: PJvMemBuffer; override;\r\n procedure FreeRecordBuffer(var Buffer: PJvMemBuffer); override;\r\n procedure InternalInitRecord(Buffer: PJvMemBuffer); override;\r\n function GetRecord(Buffer: PJvMemBuffer; GetMode: TGetMode;\r\n DoCheck: Boolean): TGetResult; override;\r\n\r\n function GetRecordSize: Word; override;\r\n procedure SetFieldData(Field: TField; Buffer: TJvValueBuffer); override;\r\n procedure ClearCalcFields(Buffer: PJvMemBuffer); override;\r\n\r\n // Bookmark methods:\r\n procedure GetBookmarkData(Buffer: PJvMemBuffer; Data: TJvBookmark); override;\r\n function GetBookmarkFlag(Buffer: PJvMemBuffer): TBookmarkFlag; override;\r\n procedure InternalGotoBookmark(Bookmark: TJvBookmark); override;\r\n procedure InternalSetToRecord(Buffer: PJvMemBuffer); override; // on Insertion???\r\n procedure SetBookmarkFlag(Buffer: PJvMemBuffer; Value: TBookmarkFlag); override;\r\n procedure SetBookmarkData(Buffer: PJvMemBuffer; Data: TJvBookmark); override;\r\n\r\n // Navigational methods:\r\n procedure InternalFirst; override;\r\n procedure InternalLast; override;\r\n // Editing methods:\r\n procedure InternalAddRecord(Buffer: TJvRecordBuffer; Append: Boolean); override;\r\n procedure InternalDelete; override;\r\n procedure InternalPost; override;\r\n { procedure InternalInsert; override; }{not needed.}\r\n\r\n // Misc methods:\r\n procedure InternalClose; override;\r\n // procedure DestroyFields; override;\r\n\r\n procedure InternalHandleException; override;\r\n procedure InternalInitFieldDefs; override;\r\n procedure InternalOpen; override;\r\n\r\n function GetFileName: string; // used by InternalOpen, and Flush.\r\n\r\n function IsCursorOpen: Boolean; override;\r\n { Optional overrides }\r\n function GetRecordCount: Integer; override;\r\n function GetRecNo: Integer; override;\r\n procedure SetRecNo(Value: Integer); override;\r\n\r\n { dataset designer calls these }\r\n procedure DefChanged(Sender: TObject); override;\r\n\r\n // handling functions for enquoting,dequoting string fields in csv files.\r\n // handles using the default Excel method which is to Double the quotes inside\r\n // quotes.\r\n\r\n // (rom) inacceptable names\r\n function _Enquote(const StrVal: string): string; virtual;\r\n // puts whole string in quotes, escapes embedded separators and quote characters!\r\n function _Dequote(const StrVal: string): string; virtual; // removes quotes\r\n\r\n property Separator: Char read GetSeparator write SetSeparator default ',';\r\n property DecimalSeparator: Char read GetDecimalSeparator write SetDecimalSeparator default ' '; // space means system default.\r\n\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n function BookmarkValid(Bookmark: TBookmark): Boolean; override;\r\n function GetFieldData(Field: TField; Buffer: TJvValueBuffer): Boolean; override;\r\n\r\n\r\n function _AllocateRow: PCsvRow; // Don't try to create your own CsvRow Objects outside JvCsvDataSet by just allocating a TJvCsvDataRow object. Call this instead.\r\n\r\n // Autoincrement feature: Get next available auto-incremented value for numbered/indexed autoincrementing fields.\r\n function GetAutoincrement(const FieldName: string): Integer;\r\n\r\n // NEW: COPY FROM ANOTHER TDATASET (TTable, TADOTable, TQuery, or whatever)\r\n function CopyFromDataset(DataSet: TDataSet): Integer;\r\n\r\n // SELECT * FROM TABLE WHERE LIKE :\r\n procedure SetFilter(const FieldName: string; Pattern: string); // Make Rows Visible Only if they match filterString\r\n procedure SetFilterNum(const FieldName: string; CompareOperator: TJvCsvFilterNumCompare; NumValue: Double);\r\n\r\n // SELECT * FROM TABLE WHERE IS :\r\n procedure SetFilterOnNull(const FieldName: string; NullFlag: Boolean);\r\n\r\n\r\n procedure ClearFilter; // Clear all previous SetFilters, shows All Rows. Refresh screen.\r\n procedure ClearPreviousFilter; // Clear Previous Filtering. DOES NOT REFRESH SCREEN.\r\n\r\n\r\n procedure CustomFilter(FilterCallback: TJvCustomCsvDataSetFilterFunction); {NEW:APRIL 2004-WP}\r\n\r\n function Locate(const KeyFields: string; const KeyValues: Variant; Options: TLocateOptions): Boolean; override;\r\n //------------\r\n\r\n /// procedure FilteredDeletion(Inverted: Boolean); /// XXX TODO?\r\n /// procedure DeleteRowsMatchingFilter; /// XXX TODO?\r\n /// procedure DeleteRowsNotMatchingFilter; /// XXX TODO?\r\n\r\n // this is necessary to make bookmarks work as well:\r\n function CompareBookmarks(Bookmark1, Bookmark2: TBookmark): Integer; override;\r\n\r\n // Additional procedures\r\n procedure EmptyTable;\r\n\r\n // Tells controls to redraw.\r\n procedure Refresh;\r\n\r\n // Clone current row/record from one CsvDataSet to another (primitive synchronization/copying ability).\r\n procedure CloneRow(DataSet: TJvCustomCsvDataSet);\r\n\r\n // TODO: Implement row/record copy from ANY dataset.\r\n\r\n // A fast row lookup function specific to this CSV table object.\r\n function FindByCsvKey(const Key: string): Boolean;\r\n\r\n // Sort the table:\r\n procedure Sort(const SortFields: string; Ascending: Boolean);\r\n\r\n // All rows have a UserData and UserTag property, these\r\n // next two functions quickly set all the userdata and usertag\r\n // values for all rows, which is a good way to set defaults\r\n // without having to iterate through the dataset.\r\n procedure SetAllUserData(Data: Pointer);\r\n procedure SetAllUserTags(TagValue: Integer);\r\n\r\n // The UserData/UserTag properties apply to the row that the\r\n // cursor is sitting on. Without visibly moving the cursor,\r\n // its handy to get/set the usertag and Data values.\r\n function GetUserTag(RecNo: Integer): Integer;\r\n procedure SetUserTag(RecNo, NewValue: Integer);\r\n\r\n function GetUserData(RecNo: Integer): Pointer;\r\n procedure SetUserData(RecNo: Integer; NewValue: Pointer);\r\n\r\n function GetCsvHeader: string; // NEW FEB 2004 WP\r\n\r\n { Additional Public methods }\r\n procedure OpenWith(Strings: TStrings); virtual;\r\n\r\n procedure AppendWith(Strings: TStrings); virtual;\r\n\r\n { Special declarations }\r\n // as long as the field names and positions have not changed.\r\n procedure AssignFromStrings(Strings: TStrings); virtual; // update string Data directly.\r\n procedure AssignToStrings(Strings: TStrings); virtual;\r\n\r\n procedure DeleteRows(FromRow, ToRow: Integer); // NEW: Quickly zap a bunch of rows:\r\n procedure ExportRows(const FileName: string; FromRow, ToRow: Integer); // NEW: Quickly save a bunch of rows:\r\n\r\n procedure ExportCsvFile(const FileName: string); virtual;\r\n // save out to a file. does NOT keep backups! If file exists, it will be\r\n // overwritten, and NO backups are made!\r\n\r\n procedure Flush; virtual; // Save CSV file to disk if file has changed and SavesChanges is True.\r\n // Note: FLUSH will make backup copies if FAutoBackupCount>0!!!\r\n\r\n function GetAsString(const Row, Column: Integer): string; virtual;\r\n\r\n { Row Access as string }\r\n function GetRowAsString(const Index: Integer): string; virtual;\r\n function GetRowAsAnsiString(const Index: Integer): AnsiString; virtual;\r\n\r\n function CurrentRowAsString: string; virtual; // Return any row by index, special: -1 means last row NEW.\r\n\r\n // Return any row by index, special: -1 means last row\r\n function GetColumnsAsString: string; virtual;\r\n { Row Append one string }\r\n procedure AppendRowString(const RowAsString: string); // Along with GetRowAsString, easy way to copy a dataset to another dataset!\r\n procedure CreateFields; override;\r\n\r\n function IsKeyUnique: Boolean; // Checks current row's key uniqueness. Note that FCsvKeyDef MUST be set!\r\n procedure SaveToFile(const FileName: string);\r\n procedure LoadFromFile(const FileName: string);\r\n\r\n procedure DeleteCsvColumn(const AFieldName: string); // must be done when not Active! [NEW 2007!]\r\n function Lookup(const KeyFields: string; const KeyValues: Variant; const ResultFields: string): Variant; override;\r\n {These are made protected so that you can write another derived component which has access to various protected fields }\r\n protected\r\n property InternalData: TJvCsvRows read FData write FData;\r\n property AppendedFieldCount: Integer read FAppendedFieldCount;\r\n // Number of fields not in the file on disk, appended to file as NULLs during import.\r\n // Per-Record user-Data fields:\r\n // Each record can have a pointer (for associating each row with an object)\r\n property UserData: Pointer read GetRowUserData write SetRowUserData;\r\n // Each record can have a tag (Integer) (for help in marking rows as Selected/Unselected or some other\r\n // end user task)\r\n property UserTag: Integer read GetRowTag write SetRowTag;\r\n\r\n property FileName: string read FTableName write SetTableName;\r\n property ReadOnly: Boolean read FReadOnly write FReadOnly default False;\r\n property Changed: Boolean read FFileDirty write FFileDirty default False;\r\n // property DataFileSize: Integer read GetDataFileSize;\r\n\r\n // if HasHeaderRow is True, validate that it conforms to CvsFieldDef\r\n property ValidateHeaderRow: Boolean read FValidateHeaderRow write FValidateHeaderRow default True;\r\n property ExtendedHeaderInfo: Boolean read FExtendedHeaderInfo write FExtendedHeaderInfo default False;\r\n\r\n property CaseInsensitive: Boolean read FCsvCaseInsensitiveComparison write FCsvCaseInsensitiveComparison default False;\r\n\r\n // Properties for Automatically Loading/Saving CSV file when Active property is set True/False:\r\n property LoadsFromFile: Boolean read FLoadsFromFile write FLoadsFromFile default True;\r\n property AutoBackupCount: Integer read FAutoBackupCount write FAutoBackupCount;\r\n // >0 means Keep Last N Copies the Old Csv File, updated before each save?\r\n\r\n // Do field definitions \"persist\"?\r\n // Ie: do they get stored in DFM Form file along with the component\r\n property StoreDefs: Boolean read FStoreDefs write FStoreDefs default False;\r\n\r\n { value in seconds : to do GMT to EST (ie GMT-5) use value of (-3600*5)\r\n This is only useful if you use the Hex encoded date-time fields.\r\n }\r\n property TimeZoneCorrection: Integer read FTimeZoneCorrection write FTimeZoneCorrection default 0;\r\n { If False (default) we use the more normal CSV rendering of quotes, which is to Double them in\r\n the csv file, but if this property is True, we use backslash-quote to render quotes in the file,\r\n which has the side-effect of also requiring all backslashes to themself be escaped by a backslash.\r\n So filenames would have to be in the form \"c:\\\\directory\\\\names\\\\like\\\\c\\\\programmers\\\\do\\\\it\".\r\n Not recommended behaviour, except when absolutely necessary! }\r\n property EnquoteBackslash: Boolean read GetEnquoteBackslash write SetEnquoteBackslash default False;\r\n property BackslashCrLf:Boolean read GetBackslashCrLf write SetBackslashCrLf; // Are CR/LFs changed to \\r and \\n?\r\n\r\n\r\n {new}\r\n property CreatePaths: Boolean read FCreatePaths write FCreatePaths default True; // When saving, create subdirectories/paths if it doesn't exist?\r\n\r\n property SpecialDataMarker: RawByteString read FSpecialDataMarker write FSpecialDataMarker; // Unless defined, OnSpecialData won't ever be called. If you have NON-CSV data being parsed/ignored when a certain marker/prefix is found, set it up here.\r\n\r\n { Additional Events }\r\n property OnSpecialData: TJvCsvOnSpecialData read FOnSpecialData write FOnSpecialData;\r\n property OnGetFieldData: TJvCsvOnGetFieldData read FOnGetFieldData write FOnGetFieldData;\r\n property OnSetFieldData: TJvCsvOnSetFieldData read FOnSetFieldData write FOnSetFieldData;\r\n public\r\n { these MUST be available at runtime even when the object is of the Custom base class type\r\n This enables interoperability at design time between non-visual helper components\r\n and user-derived CsvDataSet descendants }\r\n // CSV Table definition properties:\r\n property CsvFieldDef: string read FCsvFieldDef write SetCsvFieldDef; // Our own \"Csv Field Definition String\"\r\n property CsvKeyDef: string read FCsvKeyDef write FCsvKeyDef; // Primary key definition.\r\n property CsvUniqueKeys: Boolean read FCsvUniqueKeys write FCsvUniqueKeys default False; // Rows must be unique on the primary key.\r\n // not currently valuable, but maybe soon:\r\n //property CsvColumns: TJvCsvColumns read FCsvColumns;\r\n\r\n property OpenFileName: string read FOpenFileName; // Set in InternalOpen, used elsewhere.\r\n property FieldDefs stored FieldDefsStored;\r\n property TableName: string read FTableName; // Another name, albeit read only, for the FileName property!\r\n property HasHeaderRow: Boolean read FHasHeaderRow write FHasHeaderRow default True;\r\n property HeaderRow: string read FHeaderRow; // first row of CSV file.\r\n property SavesChanges: Boolean read FSavesChanges write FSavesChanges default True;\r\n\r\n property AlwaysEnquoteStrings: Boolean read FAlwaysEnquoteStrings write FAlwaysEnquoteStrings default False; // Always put Double quotes around strings (for some CSV file reading software this is required.)\r\n property AlwaysEnquoteFloats: Boolean read FAlwaysEnquoteFloats write FAlwaysEnquoteFloats default False; // Always put Double quotes around floating point values (useful when DecimalSeparator==CsvSeparator)\r\n property UseSystemDecimalSeparator: Boolean read FUseSystemDecimalSeparator write FUseSystemDecimalSeparator default False; // Default is false which always uses US mode. Must be false by default because of existing code assuming this behaviour.\r\n\r\n property AppendOnly: Boolean read FAppendOnly write FAppendOnly default False; // If true, we don't load the entire content of the CSV from disk, only the last row, and every time we append and write, we only maintain the last row in memory (saves a lot of RAM.)\r\n\r\n property TextBufferSize: Integer read GetTextBufferSize write SetTextBufferSize default JvCsvDefaultTextBufferSize; // How big is TJvCsvRow.Text effectively?\r\n property MarginSize: Integer read GetMarginSize write SetMarginSize default JvCsvDefaultMarginSize; // How much margin space after the calculated fields? (typically 2 bytes)\r\n end;\r\n\r\n // TJvCsvDataSet is just a TJvCustomCsvDataSet with all properties and events exposed:\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvCsvDataSet = class(TJvCustomCsvDataSet)\r\n public\r\n property TableName;\r\n property UserData;\r\n property UserTag;\r\n property DecimalSeparator;\r\n published\r\n property FieldDefs;\r\n property Active;\r\n property BufferCount;\r\n property FileName;\r\n property ReadOnly;\r\n property BeforeOpen;\r\n property AfterOpen;\r\n property BeforeClose;\r\n property AfterClose;\r\n property BeforeInsert;\r\n property AfterInsert;\r\n property BeforeEdit;\r\n property AfterEdit;\r\n property BeforePost;\r\n property AfterPost;\r\n property BeforeCancel;\r\n property AfterCancel;\r\n property BeforeDelete;\r\n property AfterDelete;\r\n property BeforeScroll;\r\n property AfterScroll;\r\n property OnDeleteError;\r\n property OnEditError;\r\n property OnCalcFields;\r\n property AutoCalcFields; // TDataSet property!\r\n property Changed;\r\n property CsvFieldDef;\r\n property CsvKeyDef;\r\n property CsvUniqueKeys;\r\n property HasHeaderRow;\r\n property ValidateHeaderRow;\r\n property ExtendedHeaderInfo;\r\n property CaseInsensitive;\r\n property Separator;\r\n property LoadsFromFile;\r\n property SavesChanges;\r\n property AutoBackupCount;\r\n property StoreDefs;\r\n property OnSpecialData;\r\n property OnGetFieldData;\r\n property OnSetFieldData;\r\n property TimeZoneCorrection;\r\n property EnquoteBackslash;\r\n property HeaderRow;\r\n property AlwaysEnquoteStrings;\r\n property AlwaysEnquoteFloats;\r\n property UseSystemDecimalSeparator;\r\n property AppendOnly; \r\n end;\r\n\r\n{ CSV string Processing Functions }\r\nprocedure JvCsvRowToAnsiString(RowItem: PCsvRow; var RowString: AnsiString);\r\nprocedure JvCsvRowToString(RowItem: PCsvRow; var RowString: string);\r\n\r\n{ modified! }\r\nprocedure JvStringToCsvRow(const RowString: string; Separator: Char;\r\n RowItem: PCsvRow; PermitEscapeSequences, EnquoteBackslash: Boolean);\r\n\r\nfunction CsvRowItemCopy(Source, Dest: PCsvRow; FieldIndex, FieldSize: Integer): Boolean;\r\nprocedure SetCsvRowItem(PItem: PCsvRow; ColumnIndex: Integer; const NewValue: string);\r\nprocedure SetCsvRowItemData(PItem: PCsvRow; ColumnIndex: Integer; const NewValue: RawByteString);\r\nfunction GetCsvRowItem(PItem: PCsvRow; ColumnIndex: Integer): string;\r\nfunction GetCsvRowItemData(PItem: PCsvRow; ColumnIndex: Integer): RawByteString;\r\nprocedure CsvRowSetDirtyBit(Row: PCsvRow; ColumnIndex: Integer);\r\nprocedure CsvRowClearDirtyBit(Row: PCsvRow; ColumnIndex: Integer);\r\nfunction CsvRowGetDirtyBit(Row: PCsvRow; ColumnIndex: Integer): Boolean;\r\nprocedure CsvRowSetColumnMarker(Row: PCsvRow; ColumnIndex: Integer; ColumnMarker: Integer);\r\nfunction CsvRowGetColumnMarker(Row: PCsvRow; ColumnIndex: Integer): Integer;\r\n\r\n{ Date/Time string decoding functions }\r\n\r\n// Decides a TIME_T (A common standard-C-library way of encoding date time values\r\n// as a number of seconds since 12:00 AM Jan 1, 1970 UTC) which is stored in Hex\r\n// in the CSV file.\r\nfunction JvTimeTHexToDateTime(const HexStr: string; TimeZoneCorrection: Integer): TDateTime;\r\n\r\nfunction JvIsoDateTimeStrToDateTime(const AsciiDateTimeStr: string): TDateTime; // [formerly TimeTAsciiToDateTime]\r\nfunction JvIsoDateStrToDate(const AsciiDateStr: string): TDateTime; // new.\r\nfunction JvIsoTimeStrToTime(const AsciiTimeStr: string): TDateTime; // new. If INVALID value: returns -1.0\r\n\r\n{ Date/Time string encoding functions }\r\nfunction JvDateTimeIsoStr(ADateTime: TDateTime): string; // renamed! formerly DateTimeToTimeToIsoAscii\r\n\r\n// new: JvDateIsoStr [support function for new Date ASCII CSV column type]\r\nfunction JvDateIsoStr(ADateTime: TDateTime): string;\r\n\r\n// new: JvTimeIsoStr [support function for new Date ASCII CSV column type]\r\nfunction JvTimeIsoStr(ADateTime: TDateTime): string;\r\n\r\n\r\nfunction JvDateTimeToTimeTHex(ADateTime: TDateTime; TimeZoneCorrection: Integer): string;\r\n\r\n{ Routine to keep backup copies of old Data files around }\r\nfunction JvCsvBackupPreviousFiles(const FileName: string; MaxFiles: Integer): Boolean;\r\n\r\n//JvCsvWildcardMatch:\r\n// Recursive wildcard (%=AnyString, ?=SingleChar) matching function with\r\n// Boolean sub expressions (|=or, &=and).\r\nfunction JvCsvWildcardMatch(Data, Pattern: string): Boolean;\r\n\r\n// numeric filter helper function:\r\nfunction JvCsvNumCondition(FieldValue: Double; CompareOperator: TJvCsvFilterNumCompare; NumValue: Double): Boolean;\r\n\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvCsvData.pas $';\r\n Revision: '$Revision: 13419 $';\r\n Date: '$Date: 2012-09-10 13:07:42 +0200 (lun. 10 sept. 2012) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\n//var\r\n// DebugPJvCsvRowWordFields : PJvCsvRowWordFields; // XXX debug code\r\n \r\nimplementation\r\n\r\nuses\r\n Variants, Controls, Forms,\r\n JvCsvParse, JvConsts, JvResources, JclSysUtils;\r\n\r\nconst\r\n // These characters cannot be used for separator for various reasons:\r\n // Either they are used as field type specifiers, break lines or are used to\r\n // delimit field content\r\n cInvalidSeparators = [#0, Backspace, Lf, #12, Cr, #39, '\"', '\\',\r\n '$', '%', '&', '@', '#', '^', '!', '-', '/', '*' ];\r\n\r\nvar\r\n// These arrays are needed by the string-input validation routines\r\n// that validate the ascii input for ISO date/time formats:\r\n\r\n //YYYY MM DD HH NN SS\r\n AsciiTime_MinValue: array [1..6] of Integer = (1900, 1, 1, 0, 0, 0);\r\n AsciiTime_MaxValue: array [1..6] of Integer = (3999, 12, 31, 23, 59, 59);\r\n AsciiTime_ExpectLengths: array [1..6] of Integer = ( 4, 2, 2, 2, 2, 2);\r\n\r\n\r\nfunction StrLLen(P: PAnsiChar; MaxLen: Integer): Integer;\r\nbegin\r\n for Result := 0 to MaxLen - 1 do\r\n if P[Result] = #0 then\r\n Exit;\r\n Result := MaxLen;\r\nend;\r\n\r\nprocedure JvCsvDatabaseError(const TableName, Msg: string);\r\nbegin\r\n raise EJvCsvDataSetError.CreateResFmt(@RsECsvErrFormat, [TableName, Msg]);\r\nend;\r\n\r\nprocedure JvCsvDatabaseError2(const TableName, Msg: string; Code: Integer);\r\nbegin\r\n raise EJvCsvDataSetError.CreateResFmt(@RsECsvErrFormat2, [TableName, Msg, Code]);\r\nend;\r\n\r\nfunction JvCsvStrToFloatDef(const StrValue: string; DefValue: Double; ASeparator: Char): Double;\r\nbegin\r\n { does not raise exceptions}\r\n Result := JvSafeStrToFloatDef(StrValue, DefValue, ASeparator); // JvJCLUtils\r\nend;\r\n\r\nfunction JvCsvStrToFloat(const StrValue: string; ASeparator: Char): Double;\r\nbegin\r\n { raises EConvertError exception }\r\n Result := JvSafeStrToFloat(StrValue, ASeparator); // JvJCLUtils\r\nend;\r\n\r\n{ Trim TRAILING CrLf but not leading, or middle, or spaces }\r\nfunction JvTrimAnsiStringCrLf(const S: RawByteString): RawByteString;\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := Length(S) downto 1 do\r\n begin\r\n if (S[I] <> #10) and (S[I] <> #13) then\r\n begin\r\n Result := Copy(S, 1, I);\r\n Exit;\r\n end;\r\n end;\r\n Result := S;\r\nend;\r\n\r\nfunction JvTrimStringCrLf(const S: string): string;\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := Length(S) downto 1 do\r\n begin\r\n if (S[I] <> #10) and (S[I] <> #13) then\r\n begin\r\n Result := Copy(S, 1, I);\r\n Exit;\r\n end;\r\n end;\r\n Result := S;\r\nend;\r\n\r\n{Word fields are fixed size, but variable location, so we need to FIND them.}\r\nfunction GetWordFields(RowItem: PCsvRow): PJvCsvRowWordFields;\r\nvar\r\n P: PAnsiChar;\r\n Magic: Cardinal;\r\nbegin\r\n Assert(Assigned(RowItem));\r\n\r\n if RowItem^.Magic <> JvCsvRowMagic then\r\n raise EJvCsvDataSetError.Create('Internal error. Memory corruption suspected in CsvRow memory area');\r\n Assert(RowItem^.WordFieldsAddr > 0);\r\n P := Pointer(RowItem);\r\n Inc(P, RowItem.WordFieldsAddr);\r\n\r\n Result := PJvCsvRowWordFields(P);\r\n Magic := Result^.Magic2;\r\n if Magic <> JvCsvRowMagic2 then\r\n raise EJvCsvDataSetError.Create('Memory Corruption Suspected in WordFields area of CsvRow memory'); // memory corruption check!\r\nend;\r\n\r\n{Calculated data area is now after the word fields, and we need to locate the area } \r\nfunction GetCalcDataOffset(RowItem:PCsvRow):Integer;\r\nbegin\r\n Assert(Assigned(RowItem));\r\n Assert(RowItem^.Magic = JvCsvRowMagic);\r\n Assert(RowItem^.AllocSize>0);\r\n Assert(RowItem^.WordFieldsAddr > 0);\r\n\r\n Result := RowItem^.WordFieldsAddr + SizeOf(TJvCsvRowWordFields);\r\n\r\n Assert(Result < RowItem^.AllocSize);\r\nend;\r\n\r\n//-------------------------------------------------------------------------\r\n// TJvCsvStream METHODS\r\n//-------------------------------------------------------------------------\r\nfunction GetFileSizeEx(h: HFILE; FileSize: PULargeInteger): BOOL; stdcall;\r\n external Kernel32;\r\n\r\nprocedure TJvCsvStream.Append; \r\nbegin\r\n Stream.Seek(0, soFromEnd);\r\nend;\r\n\r\nconstructor TJvCsvStream.Create(const FileName: string; Mode: DWORD; Rights: Cardinal);\r\nvar\r\n IsAppend: Boolean;\r\n IsRewrite: Boolean;\r\nbegin\r\n inherited Create;\r\n FFilename := FileName;\r\n\r\n FLastReadFlag := False;\r\n IsAppend := (Mode and fmJVCSV_APPEND_FLAG) <> 0;\r\n IsRewrite := (Mode and fmJVCSV_REWRITE_FLAG) <> 0;\r\n\r\n FStream := TFileStream.Create(Filename, {16 lower bits only}Word(Mode), Rights);\r\n\r\n //Stream := FStream; { this makes everything in the base class actually work if we inherited from Easy Stream}\r\n\r\n if IsAppend then\r\n Self.Append // seek to the end.\r\n else\r\n Stream.Position := 0;\r\n\r\n if IsRewrite then\r\n Rewrite;\r\n\r\n _StreamReadBufInit;\r\nend;\r\n\r\ndestructor TJvCsvStream.Destroy;\r\nbegin\r\n if Assigned(FStream) then\r\n FStream.Position := 0; // avoid nukage\r\n FreeAndNil(FStream);\r\n FreeMem(FStreamBuffer); // Buffered reads for speed.\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJvCsvStream.Eof: Boolean;\r\nbegin\r\n if not Assigned(FStream) then\r\n Result := False\r\n //Result := True\r\n else\r\n Result := FLastReadFlag and (FStreamIndex >= FStreamSize);\r\n //Result := FStream.Position >= FStream.Size;\r\nend;\r\n\r\n{ TJvCsvStream.ReadLine:\r\n This reads a line of text, normally terminated by carriage return and/or linefeed\r\n but it is a bit special, and adapted for CSV usage because CR/LF characters\r\n inside quotes are read as a single line.\r\n\r\n This is a VERY PERFORMANCE CRITICAL function. We loop tightly inside here.\r\n So there should be as few procedure-calls inside the repeat loop as possible.\r\n\r\n This code is entirely new in JVCL 3.36 or later, added in September 2008.\r\n}\r\nfunction TJvCsvStream.ReadLine: RawByteString;\r\nvar\r\n Buf: array of AnsiChar;\r\n n: Integer;\r\n QuoteFlag: Boolean;\r\n LStreamBuffer: PAnsiChar;\r\n LStreamSize: Integer;\r\n LStreamIndex: Integer;\r\n\r\n procedure FillStreamBuffer;\r\n begin\r\n FStreamSize := Stream.Read(LStreamBuffer[0], JvCsvStreamReadChunkSize);\r\n LStreamSize := FStreamSize;\r\n if LStreamSize = 0 then\r\n begin\r\n if FStream.Position >= FStream.Size then\r\n FLastReadFlag := True\r\n else\r\n raise EJvCsvDataSetError.CreateResFmt(@RsECannotReadCsvFile, [FFilename]);\r\n end\r\n else\r\n if LStreamSize < JvCsvStreamReadChunkSize then\r\n FLastReadFlag := True;\r\n FStreamIndex := 0;\r\n LStreamIndex := 0;\r\n end;\r\n\r\nbegin\r\n { Ignore linefeeds, read until carriage return, strip carriage return, and return it }\r\n SetLength(Buf, 150);\r\n\r\n n := 0;\r\n QuoteFlag := False;\r\n\r\n LStreamBuffer := FStreamBuffer;\r\n LStreamSize := FStreamSize;\r\n LStreamIndex := FStreamIndex;\r\n while True do\r\n begin\r\n if n >= Length(Buf) then\r\n SetLength(Buf, n + 100);\r\n\r\n if LStreamIndex >= LStreamSize then\r\n FillStreamBuffer;\r\n\r\n if LStreamIndex >= LStreamSize then\r\n Break;\r\n\r\n Buf[n] := LStreamBuffer[LStreamIndex];\r\n Inc(LStreamIndex);\r\n\r\n case Buf[n] of\r\n JvCsvQuote: {34} // quote\r\n QuoteFlag := not QuoteFlag;\r\n JvCsvLf: {10} // linefeed\r\n if not QuoteFlag then\r\n Break;\r\n JvCsvCR: {13} // carriage return\r\n begin\r\n if not QuoteFlag then\r\n begin\r\n { If it is a CRLF we must skip the LF. Otherwise the next call to ReadLine\r\n would return an empty line. }\r\n if LStreamIndex >= LStreamSize then\r\n FillStreamBuffer;\r\n if LStreamBuffer[LStreamIndex] = JvCsvLf then\r\n Inc(LStreamIndex);\r\n\r\n Break;\r\n end;\r\n end\r\n end;\r\n Inc(n);\r\n end;\r\n FStreamIndex := LStreamIndex;\r\n\r\n SetString(Result, PAnsiChar(@Buf[0]), n);\r\nend;\r\n\r\nprocedure TJvCsvStream.Rewrite;\r\nbegin\r\n if Assigned(FStream) then\r\n FStream.Size := 0;// truncate!\r\nend;\r\n\r\nfunction TJvCsvStream.Size: Int64; { Get file size }\r\nbegin\r\n if Assigned(FStream) then\r\n GetFileSizeEx(FStream.Handle, PULargeInteger(@Result)) {int64 Result}\r\n else\r\n Result := 0;\r\nend;\r\n\r\n{ Look at this. A stream that can handle a string parameter. What will they think of next? }\r\nprocedure TJvCsvStream.Write(const s: RawByteString);\r\nbegin\r\n Stream.Write(s[1], Length(s)); {The author of TStreams would like you not to be able to just write Stream.Write(s). Weird. }\r\nend;\r\n\r\nprocedure TJvCsvStream.WriteChar(c: AnsiChar);\r\nbegin\r\n Stream.Write(c, SizeOf(AnsiChar));\r\nend;\r\n\r\nprocedure TJvCsvStream.WriteCrLf;\r\nbegin\r\n WriteChar(#13);\r\n WriteChar(#10);\r\nend;\r\n\r\nprocedure TJvCsvStream.WriteLine(const s: RawByteString);\r\nbegin\r\n Write(s);\r\n WriteCrLf;\r\nend;\r\n\r\nprocedure TJvCsvStream._StreamReadBufInit;\r\nbegin\r\n if not Assigned(FStreamBuffer) then\r\n begin\r\n //FStreamBuffer := AllocMem(JvCsvStreamReadChunkSize);\r\n GetMem(FStreamBuffer, JvCsvStreamReadChunkSize);\r\n end;\r\nend;\r\n\r\n//-------------------------------------------------------------------------\r\n// TJvCustomCsvDataSet METHODS\r\n//-------------------------------------------------------------------------\r\n\r\nconstructor TJvCustomCsvDataSet.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n\r\n FData := TJvCsvRows.Create;\r\n\r\n { this is updated later, to modify to have custom DecimalSeparator }\r\n {$IFDEF RTL220_UP}\r\n FFormatSettings := FormatSettings.Create;\r\n {$ELSE ~RTL220_UP}\r\n {$IFDEF RTL150_UP}\r\n GetLocaleFormatSettings(LOCALE_SYSTEM_DEFAULT, FFormatSettings);\r\n {$ELSE ~RTL150_UP}\r\n FFormatSettings.DecimalSeparator := DecimalSeparator;\r\n {$ENDIF ~RTL150_UP}\r\n {$ENDIF ~RTL220_UP}\r\n\r\n Separator := ','; // set After creating FData!\r\n\r\n FCreatePaths := True; // Creates subdirectories automatically when saving.\r\n\r\n FInitialWorkingDirectory := GetCurrentDir; // from SysUtils;\r\n\r\n FReadOnly := False;\r\n FCursorOpen := False;\r\n FRecordPos := JvCsv_ON_BOF_CRACK;\r\n FLoadsFromFile := True;\r\n FSavesChanges := True;\r\n FHasHeaderRow := True;\r\n FValidateHeaderRow := True;\r\n\r\n { Additional initialization }\r\n FCsvColumns := TJvCsvColumns.Create;\r\n\r\n// FData.EnquoteBackslash := FEnquoteBackslash;\r\n //FCsvFileAsStrings := TStringList.Create;\r\nend;\r\n\r\ndestructor TJvCustomCsvDataSet.Destroy;\r\nbegin\r\n //FCsvFileAsStrings.Free;\r\n FreeMem(FTempBuffer); // Free the memory we allocated.\r\n FreeAndNil(FCsvStream);\r\n FTempBuffer := nil;\r\n\r\n try\r\n if FCursorOpen then\r\n InternalClose;\r\n except\r\n end;\r\n if Assigned(FCsvColumns) then\r\n begin\r\n FCsvColumns.Clear;\r\n FCsvColumns.Free;\r\n end;\r\n if Assigned(FData) then\r\n begin\r\n FData.Clear;\r\n FData.Free;\r\n end;\r\n inherited Destroy;\r\nend;\r\n\r\n// Each ROW Record has an internal Data pointer (similar to the\r\n// user-accessible 'Data: Pointer' stored in treeviews, etc)\r\n\r\nfunction TJvCustomCsvDataSet.GetRowUserData: Pointer;\r\nvar\r\n RecNo: Integer;\r\nbegin\r\n RecNo := GetRecNo;\r\n Result := FData.GetUserData(RecNo);\r\nend;\r\n\r\nfunction TJvCustomCsvDataSet.GetSeparator: Char;\r\nbegin\r\n Assert(Assigned(FData));\r\n Result := FData.Separator;\r\nend;\r\n\r\nfunction TJvCustomCsvDataSet._CsvFloatToStr(Value: Double): string;\r\nbegin\r\n // raises exception EJvConvertError (same as EConvertError)\r\n FFormatSettings.DecimalSeparator := GetDecimalSeparator;\r\n Result := FloatToStr(Value{$IFDEF RTL150_UP}, FFormatSettings{$ENDIF RTL150_UP});\r\nend;\r\n\r\nfunction TJvCustomCsvDataSet.GetTextBufferSize: Integer;\r\nbegin\r\n Assert(Assigned(FData));\r\n Result := FData.TextBufferSize;\r\nend;\r\n\r\nprocedure TJvCustomCsvDataSet.SetRowUserData(UserData: Pointer);\r\nvar\r\n RecNo: Integer;\r\nbegin\r\n RecNo := GetRecNo;\r\n FData.SetUserData(RecNo, UserData);\r\nend;\r\n\r\nfunction TJvCustomCsvDataSet.GetRowTag: Integer;\r\nvar\r\n RecNo: Integer;\r\nbegin\r\n RecNo := GetRecNo;\r\n Result := FData.GetUserTag(RecNo);\r\nend;\r\n\r\nprocedure TJvCustomCsvDataSet.SetRowFiltered(ARow: PCsvRow; AFiltered: Boolean);\r\nbegin\r\n if ARow^.Filtered <> AFiltered then\r\n begin\r\n if AFiltered then\r\n Inc(FData.FFilteredCount)\r\n else\r\n Dec(FData.FFilteredCount);\r\n ARow^.Filtered := AFiltered;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomCsvDataSet.SetRowTag(TagValue: Integer);\r\nvar\r\n RecNo: Integer;\r\nbegin\r\n RecNo := GetRecNo;\r\n FData.SetUserTag(RecNo, TagValue);\r\nend;\r\n\r\n{ Filtering via wildcards requires the following helper function: }\r\nfunction _WildcardsMatchBoolOp(const Data, Pattern: string; BoolOp: Char): Boolean;\r\nvar\r\n SubPattern: array [0..20] of string;\r\n I, Count: Integer;\r\nbegin\r\n Count := JvStrSplit(Pattern, BoolOp, {Chr(0)=No Quoting} Chr(0), SubPattern, 20);\r\n if Count > 0 then\r\n begin\r\n for I := 0 to Count - 1 do\r\n begin\r\n Result := JvCsvWildcardMatch(Data, SubPattern[I]);\r\n // If ANY OR True return True;\r\n // if ANY AND False return False;\r\n if (BoolOp = '|') = Result then\r\n Exit;\r\n end;\r\n end\r\n else\r\n begin // split failed...\r\n Result := False;\r\n Exit;\r\n end;\r\n // if we get here, no short circuit was possible.\r\n if BoolOp = '|' then\r\n Result := False // NONE of the OR conditions were met!\r\n else\r\n Result := True; // ALL of the AND condition were met!\r\nend;\r\n\r\nprocedure TJvCustomCsvDataSet.SetAllUserTags(TagValue: Integer);\r\nvar\r\n I: Integer;\r\nbegin\r\n FData.SetUserTag(FData.Count - 1, TagValue);\r\n for I := 0 to FData.Count - 2 do\r\n FData.SetUserTag(I, TagValue);\r\nend;\r\n\r\nprocedure TJvCustomCsvDataSet.SetActive(Value: Boolean);\r\nbegin\r\n inherited;\r\n FFileDirty := False;\r\n if FUseSystemDecimalSeparator then\r\n FData.DecimalSeparator := JclFormatSettings.DecimalSeparator;\r\nend;\r\n\r\nprocedure TJvCustomCsvDataSet.SetAllUserData(Data: Pointer);\r\nvar\r\n I: Integer;\r\nbegin\r\n FData.SetUserData(FData.Count - 1, Data); // Optimization. Ensures we only call SetLength ONCE!\r\n for I := 0 to FData.Count - 2 do\r\n FData.SetUserData(I, Data);\r\nend;\r\n\r\nfunction TJvCustomCsvDataSet.GetUserTag(RecNo: Integer): Integer;\r\nbegin\r\n Result := FData.GetUserTag(RecNo);\r\nend;\r\n\r\nprocedure TJvCustomCsvDataSet.SetUserTag(RecNo, NewValue: Integer);\r\nbegin\r\n FData.SetUserTag(RecNo, NewValue);\r\nend;\r\n\r\nfunction TJvCustomCsvDataSet.GetUserData(RecNo: Integer): Pointer;\r\nbegin\r\n Result := FData.GetUserData(RecNo);\r\nend;\r\n\r\nprocedure TJvCustomCsvDataSet.SetUserData(RecNo: Integer; NewValue: Pointer);\r\nbegin\r\n FData.SetUserData(RecNo, NewValue);\r\nend;\r\n\r\n// JvCsv Numeric filtering helper function:\r\nfunction JvCsvNumCondition(FieldValue: Double; CompareOperator: TJvCsvFilterNumCompare; NumValue: Double): Boolean;\r\nbegin\r\n case CompareOperator of\r\n jfIntEqual:\r\n Result := Trunc(FieldValue) = Trunc(NumValue);\r\n\r\n jfIntNotEqual:\r\n Result := Trunc(FieldValue) <> Trunc(NumValue);\r\n\r\n jfLessThan:\r\n Result := FieldValue < NumValue;\r\n\r\n jfGreaterThan:\r\n Result := FieldValue > NumValue;\r\n else\r\n Result := False;\r\n end;\r\nend;\r\n\r\n// Recursive wildcard matching function\r\nfunction JvCsvWildcardMatch(Data, Pattern: string): Boolean;\r\nvar\r\n I: Integer;\r\n FirstWildcard: Integer;\r\n DataLength, PatternLength, DataPosition, PatternPosition: Integer;\r\n FirstBoolCondition: Integer;\r\nbegin\r\n Result := True;\r\n PatternLength := Length(Pattern);\r\n if PatternLength = 0 then\r\n Exit;\r\n // no Data?\r\n DataLength := Length(Data);\r\n if DataLength = 0 then\r\n begin\r\n Result := (Pattern = '%') or (Pattern = '');\r\n Exit; // definitely no match.\r\n end;\r\n // replace all '%%' -> '%' (don't put duplicate wildcards in)\r\n I := 1;\r\n while I < PatternLength do\r\n begin\r\n if (Pattern[I] = '%') and (Pattern[I + 1] = '%') then\r\n begin\r\n Pattern := Copy(Pattern, 1, I) + Copy(Pattern, I + 2, PatternLength);\r\n PatternLength := Length(Pattern);\r\n end\r\n else\r\n Inc(I);\r\n end;\r\n // find any | and split into two or more strings, and run ORs on them\r\n FirstBoolCondition := Pos('&', Pattern);\r\n if FirstBoolCondition > 0 then\r\n begin\r\n Result := _WildcardsMatchBoolOp(Data, Pattern, '&');\r\n Exit;\r\n end;\r\n FirstBoolCondition := Pos('|', Pattern);\r\n if FirstBoolCondition > 0 then\r\n begin\r\n Result := _WildcardsMatchBoolOp(Data, Pattern, '|');\r\n Exit;\r\n end;\r\n\r\n FirstWildcard := Pos('%', Pattern); // wildcards?\r\n if FirstWildcard = 0 then\r\n FirstWildcard := Pos('?', Pattern); // other wildcard.\r\n\r\n if FirstWildcard <= 0 then\r\n begin // no wildcard case.\r\n if Data = Pattern then\r\n Result := True\r\n else\r\n Result := False;\r\n Exit; // simple match returns immediately.\r\n end;\r\n // wildcard tail?\r\n if (FirstWildcard = PatternLength) and (Pattern[1] <> '?') then\r\n begin // prefix match\r\n if Copy(Data, 1, PatternLength - 1) = Copy(Pattern, 1, PatternLength - 1) then\r\n Result := True\r\n else\r\n Result := False;\r\n Exit; // tail case is easy!\r\n end;\r\n // match literal characters until we hit wildcards,\r\n // then search for a wildcard resync, which continues\r\n // recursively.\r\n Result := True;\r\n DataPosition := 1;\r\n PatternPosition := 1;\r\n while (DataPosition <= DataLength) and (PatternPosition <= PatternLength) do\r\n begin\r\n // WILDCARD HANDLER\r\n if Pattern[PatternPosition] = '?' then\r\n begin // match any one character or nothing.\r\n Inc(PatternPosition);\r\n Inc(DataPosition);\r\n end\r\n else\r\n if Pattern[PatternPosition] = '%' then\r\n begin\r\n if PatternPosition = PatternLength then\r\n begin // last byte!\r\n Result := True;\r\n Exit;\r\n end;\r\n // Resync after %:\r\n I := Pos(Pattern[PatternPosition + 1], Data);\r\n while I > 0 do\r\n begin // possible resync point!\r\n Result := JvCsvWildcardMatch(Copy(Data, I, Length(Data)),\r\n Copy(Pattern, PatternPosition + 1, PatternLength));\r\n if Result then\r\n Exit; // found a resync, and rest of strings match\r\n Data := Copy(Data, I + 1, DataLength);\r\n DataLength := Length(Data);\r\n // DataPosition := 0;\r\n if DataLength = 0 then\r\n begin\r\n Result := False;\r\n Exit;\r\n end;\r\n I := Pos(Pattern[PatternPosition + 1], Data);\r\n end;\r\n // failed to resync\r\n Result := False;\r\n Exit;\r\n end\r\n else\r\n begin // NORMAL CHARACTER\r\n if Data[DataPosition] <> Pattern[PatternPosition] then\r\n begin\r\n Result := False; // failed.\r\n Exit;\r\n end;\r\n Inc(DataPosition);\r\n Inc(PatternPosition);\r\n end;\r\n end;\r\n if (DataPosition <= DataLength) and (PatternPosition <= PatternLength) then\r\n Result := False; // there is pattern left over, or Data left over.\r\nend;\r\n\r\n// NEW: TJvCustomCsvDataSet.SetFilter\r\n//\r\n// XXX Simplest possible filtering routine. Not very flexible.\r\n// XXX Todo: Make this more flexible.\r\n// XXX Users can also subclass and write their own filter.\r\n// XXX Perhaps a OnFilter event should be provided, and SetCustomFilter\r\n// XXX method would allow us to do a row by row filtering scan, and then\r\n// XXX hide rows that the user sets HideRow := True in the event handler.\r\n// XXX\r\n\r\n{ New: Custom Filtering }\r\nprocedure TJvCustomCsvDataSet.CustomFilter(FilterCallback: TJvCustomCsvDataSetFilterFunction);\r\nvar\r\n I: Integer;\r\n PRow: PCsvRow;\r\nbegin\r\n Assert(Assigned(FilterCallback));\r\n // Now check if field value matches given pattern for this row.\r\n for I := 0 to FData.Count - 1 do\r\n begin\r\n PRow := PCsvRow(FData[I]);\r\n Assert(Assigned(PRow));\r\n // if custom function returns False, hide the row.\r\n SetRowFiltered(PRow, not FilterCallback(I));\r\n end;\r\n FIsFiltered := True;\r\n if Active then\r\n First;\r\nend;\r\n\r\nprocedure TJvCustomCsvDataSet.SetFilterOnNull(const FieldName: string; NullFlag: Boolean);\r\nvar\r\n I: Integer;\r\n PRow: PCsvRow;\r\n FieldRec: PCsvColumn;\r\n FieldIndex: Integer;\r\n FieldValue: string;\r\nbegin\r\n FieldRec := FCsvColumns.FindByName(FieldName);\r\n\r\n if not Assigned(FieldRec) then\r\n Exit;\r\n FieldIndex := FieldRec^.FPhysical;\r\n\r\n // Now filter out if IsNull matches NullFlag\r\n for I := 0 to FData.Count - 1 do\r\n begin\r\n PRow := PCsvRow(FData[I]);\r\n if not PRow^.Filtered then\r\n begin\r\n FieldValue := FData.GetARowItem(I, FieldIndex);\r\n if (Length(FieldValue) > 0) = NullFlag then\r\n SetRowFiltered(PRow, True);\r\n end;\r\n end;\r\n FIsFiltered := True;\r\n if Active then\r\n First;\r\nend;\r\n\r\nprocedure TJvCustomCsvDataSet.SetMarginSize(const Value: Integer);\r\nbegin\r\n if Active then\r\n raise Exception.Create('Can''t change memory properties on an active data set');\r\n\r\n Assert(Assigned(FData));\r\n FData.MarginSize := Value;\r\nend;\r\n\r\n// Numeric Filtering: Make Rows Visible Only if they match an Integer or floating point numeric comparison operator.\r\n// evaluate condition:\r\n// [FieldName] [numericoperator: < > = <> ] [Numeric Value Parameter]\r\nprocedure TJvCustomCsvDataSet.SetFilterNum(const FieldName: string; CompareOperator: TJvCsvFilterNumCompare;\r\n NumValue: Double);\r\nvar\r\n I: Integer;\r\n PRow: PCsvRow;\r\n FieldRec: PCsvColumn;\r\n FieldIndex: Integer;\r\n sFieldValue: string;\r\n FieldValue: Double;\r\nbegin\r\n FieldRec := FCsvColumns.FindByName(FieldName);\r\n if not Assigned(FieldRec) then\r\n Exit;\r\n FieldIndex := FieldRec^.FPhysical;\r\n\r\n // Now check if field value matches given pattern for this row.\r\n for I := 0 to FData.Count - 1 do\r\n begin\r\n PRow := PCsvRow(FData[I]);\r\n if not PRow^.Filtered then\r\n begin\r\n sFieldValue := FData.GetARowItem(I, FieldIndex);\r\n if (Length(sFieldValue) > 0) and (sFieldValue[1] = '\"') then\r\n sFieldValue := _Dequote(sFieldValue); // remove quotes.\r\n try\r\n FieldValue := JvCsvStrToFloat(sFieldValue, GetDecimalSeparator); // remember, this baby throws EConvertError on exception!\r\n\r\n // if { FieldValue [ = <> > < ] NumValue } then....\r\n if JvCsvNumCondition(FieldValue, CompareOperator, NumValue) then // hide row if not same prefix\r\n begin\r\n // Inc(stillVisible) // count the number that are still visible.\r\n end\r\n else\r\n SetRowFiltered(PRow, True)\r\n except\r\n on E: EConvertError do\r\n SetRowFiltered(PRow, True); // hide error rows.\r\n end;\r\n end;{if not already hidden!}\r\n end;{ for loop}\r\n FIsFiltered := True;\r\n if Active then\r\n First;\r\nend;\r\n\r\n// string Filtering: Make Rows Visible Only if they match filterString\r\nprocedure TJvCustomCsvDataSet.SetFilter(const FieldName: string; Pattern: string);\r\nvar\r\n ValueLen, I: Integer;\r\n PRow: PCsvRow;\r\n FieldRec: PCsvColumn;\r\n FieldIndex: Integer;\r\n FieldValue: string;\r\nbegin\r\n FieldRec := FCsvColumns.FindByName(FieldName);\r\n if not Assigned(FieldRec) then\r\n Exit;\r\n FieldIndex := FieldRec^.FPhysical;\r\n ValueLen := Length(Pattern); // if valuelen is zero then we are searching for blank or nulls\r\n Pattern := {Ansi}UpperCase(Pattern); // make value case insensitive.\r\n\r\n // Now check if field value matches given pattern for this row.\r\n for I := 0 to FData.Count - 1 do\r\n begin\r\n PRow := PCsvRow(FData[I]);\r\n if not PRow^.Filtered then\r\n begin\r\n FieldValue := FData.GetARowItem(I, FieldIndex);\r\n if (Length(FieldValue) > 0) and (FieldValue[1] = '\"') then\r\n FieldValue := _Dequote(FieldValue); // remove quotes.\r\n if ValueLen = 0 then\r\n begin\r\n if FieldValue <> '' then // if not empty, hide row.\r\n SetRowFiltered(PRow, True);\r\n end\r\n else\r\n begin\r\n FieldValue := {Ansi}UpperCase(FieldValue);\r\n\r\n if JvCsvWildcardMatch(FieldValue, Pattern) then // hide row if not same prefix\r\n begin\r\n // Inc(stillVisible) // count the number that are still visible.\r\n end\r\n else\r\n SetRowFiltered(PRow, True);\r\n end;\r\n end\r\n end;\r\n FIsFiltered := True;\r\n if Active then\r\n First;\r\nend;\r\n\r\n{ Some advanced JvCsvData set users, like WP himself, the original component\r\n author need to create and modify CSV records directly. For example, a query\r\n engine constructed using JvCsvDataSet, may wish to move tuples (row memory objects)\r\n directly from one dataset to another, not value-by-value but the whole row\r\n at once. }\r\nfunction TJvCustomCsvDataSet._AllocateRow: PCsvRow;\r\nbegin\r\n Result := PCsvRow(AllocMem(FData.GetRowAllocSize));\r\n FData.InternalInitRecord(TJvRecordBuffer(Result)); // {was PChar(Result) }\r\nend;\r\n\r\nprocedure TJvCustomCsvDataSet.ClearPreviousFilter; // Clear Previous Filtering.\r\nvar\r\n I: Integer;\r\n PRow: PCsvRow;\r\nbegin\r\n for I := 0 to FData.Count - 1 do\r\n begin\r\n PRow := PCsvRow(FData[I]);\r\n if Assigned(PRow) then\r\n SetRowFiltered(PRow, False); // clear all filter bits.\r\n end;\r\n FIsFiltered := False;\r\nend;\r\n\r\nprocedure TJvCustomCsvDataSet.ClearFilter; // Clear Previous Filtering.\r\nvar\r\n M: TBookmark;\r\nbegin\r\n M := GetBookmark;\r\n try\r\n ClearPreviousFilter;\r\n // Update screen.\r\n if Active then\r\n if Assigned(M) then\r\n GotoBookmark(M)\r\n else\r\n First;\r\n finally\r\n FreeBookmark(M);\r\n end;\r\nend;\r\n\r\nfunction TJvCustomCsvDataSet.BookmarkValid(Bookmark: TBookmark): Boolean;\r\nbegin\r\n Result := (Bookmark <> nil) and (PInteger(Bookmark)^ >= 0) and (PInteger(Bookmark)^ < FData.Count);\r\nend;\r\n\r\n{ You shouldn't create a \"TJvCsvRow-memory-buffer-record-aggregate\" anywhere else than here. }\r\nfunction TJvCustomCsvDataSet.AllocRecordBuffer: PJvMemBuffer;\r\nbegin\r\n Assert(Assigned(FData));\r\n Result := FData.AllocRecordBuffer;\r\nend;\r\n\r\n{ calc fields support }\r\n\r\nprocedure TJvCustomCsvDataSet.ClearCalcFields(Buffer: PJvMemBuffer);\r\nbegin\r\n // Assumes that our buffer is a TJvCsvRow followed by\r\n // a dynamically resized buffer used for calculated field\r\n // storage:\r\n FillChar(Buffer[GetCalcDataOffset(PCsvRow(Buffer))], JvCsv_MaxCalcDataOffset{CalcFieldsSize}, {initbytevalue}0);\r\nend;\r\n\r\n{ calc fields support and buffer support }\r\n\r\nfunction TJvCustomCsvDataSet.GetActiveRecordBuffer: TJvRecordBuffer;\r\nbegin\r\n case State of\r\n dsBrowse:\r\n if IsEmpty then\r\n Result := nil\r\n else\r\n Result := ActiveBuffer;\r\n dsCalcFields:\r\n Result := CalcBuffer;\r\n dsFilter:\r\n Result := FFilterBuffer;\r\n dsEdit, dsInsert:\r\n Result := ActiveBuffer;\r\n else\r\n Result := nil;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomCsvDataSet.SetCsvFieldDef(const Value: string);\r\nbegin\r\n if FCsvFieldDef <> Value then\r\n begin\r\n CheckInactive;\r\n FCsvFieldDef := Value;\r\n FDefaultCsvFieldDefs := False;\r\n FHeaderRow := '';\r\n FieldDefs.Clear; // Clear VCL Database field definitions\r\n FCsvColumns.Clear; // Clear our own CSV related field Data\r\n FData.Clear; // Clear out Data\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomCsvDataSet.SetDecimalSeparator(const Value: Char);\r\nbegin\r\n FData.DecimalSeparator := Value;\r\nend;\r\n\r\nprocedure TJvCustomCsvDataSet.SetEnquoteBackslash(const Value: Boolean);\r\nbegin\r\n Assert(Assigned(FData));\r\n FData.FEnquoteBackslash := Value;\r\nend;\r\n\r\nfunction TJvCustomCsvDataSet.GetEnquoteBackslash: Boolean;\r\nbegin\r\n Assert(Assigned(FData));\r\n Result := FData.FEnquoteBackslash;\r\nend;\r\n\r\nprocedure TJvCustomCsvDataSet.FreeRecordBuffer(var Buffer: PJvMemBuffer);\r\nbegin\r\n if Buffer <> nil then\r\n FreeMem(Buffer);\r\nend;\r\n\r\n{ called after the record is allocated }\r\n\r\nprocedure TJvCustomCsvDataSet.InternalInitRecord(Buffer: PJvMemBuffer);\r\nvar\r\n RowPtr: PCsvRow;\r\nbegin\r\n //Trace( 'InternalInitRecord '+IntToHex(Integer(Buffer),8) );\r\n Assert(Assigned(FData));\r\n FData.InternalInitRecord(Buffer);\r\n RowPtr := PCsvRow(Buffer); // Zero out the buffer.\r\n CsvRowInit(RowPtr);\r\nend;\r\n\r\n// CsvRowInit\r\n//\r\n// Internal handy dandy function to set up a new csv row.\r\n// which is intially full of just commas.\r\n//\r\nprocedure TJvCustomCsvDataSet.CsvRowInit(RowPtr: PCsvRow);\r\nvar\r\n I: Integer;\r\n ColCount: Integer;\r\n RowPtrText: PAnsiChar;\r\nbegin\r\n RowPtr^.Index := -1; // Not Yet Indexed\r\n RowPtr^.IsDirty := RowAlreadySaved;\r\n \r\n RowPtr^.Bookmark.Flag := bfEOF;\r\n RowPtr^.Bookmark.Data := JvCsv_ON_BOF_CRACK; // no index into FData yet.\r\n CsvRowSetColumnMarker(RowPtr, {column} 0, {marker value} 0);\r\n\r\n ColCount := FCsvColumns.Count;\r\n if ColCount <= 0 then\r\n ColCount := 10;\r\n\r\n RowPtrText := @RowPtr^._Text[0];\r\n for I := 1 to ColCount do\r\n begin // create an empty line of just commas\r\n if I < ColCount then\r\n RowPtrText[I - 1] := AnsiChar(Separator)\r\n else\r\n RowPtrText[I - 1] := #0;\r\n RowPtrText[I] := #0;\r\n CsvRowSetColumnMarker(RowPtr, {column} I - 1, {marker value} I - 1);\r\n CsvRowSetColumnMarker(RowPtr, {column} I, {marker value} JvCsv_COLUMN_ENDMARKER);\r\n end;\r\nend;\r\n\r\nfunction TJvCustomCsvDataSet.IsKeyUnique: Boolean;\r\n // Checks current row's key uniqueness. Note that FCsvKeyDef MUST be set!\r\nbegin\r\n Result := False; // not yet implemented! XXX\r\nend;\r\n\r\nfunction TJvCustomCsvDataSet.GetFieldValueAsVariant(CsvColumnData: PCsvColumn;\r\n Field: TField; RecordIndex: Integer): Variant;\r\nvar\r\n RowPtr: PCsvRow;\r\n TempString: string;\r\n PhysicalLocation: Integer;\r\n L: Integer;\r\nbegin\r\n Assert(Assigned(FCsvColumns));\r\n\r\n if not Assigned(CsvColumnData) then\r\n begin\r\n JvCsvDatabaseError(FTableName, Format(RsEUnableToLocateCSVFileInfo, [Field.Name]));\r\n Exit;\r\n end;\r\n\r\n PhysicalLocation := CsvColumnData^.FPhysical;\r\n\r\n if (PhysicalLocation < 0) and FPendingCsvHeaderParse then\r\n begin\r\n FPendingCsvHeaderParse := False;\r\n ProcessCsvHeaderRow;\r\n PhysicalLocation := CsvColumnData^.FPhysical;\r\n end;\r\n\r\n if PhysicalLocation < 0 then\r\n begin\r\n JvCsvDatabaseError(FTableName, Format(RsEPhysicalLocationOfCSVField, [Field.FieldName]));\r\n Exit;\r\n end;\r\n\r\n RowPtr := FData[RecordIndex];\r\n TempString := GetCsvRowItem(RowPtr, PhysicalLocation);\r\n\r\n // Strip quotes first (Both floating point and string fields can get enquoted on us)\r\n if Field.DataType in [ftString, ftFloat] then\r\n begin\r\n L := Length(TempString);\r\n if L >= 2 then\r\n if (TempString[1] = '\"') and (TempString[L] = '\"') then\r\n TempString := _Dequote(TempString); // quoted string or floating point value.\r\n end;\r\n\r\n try\r\n case Field.DataType of\r\n ftString:\r\n Result := TempString;\r\n ftInteger:\r\n Result := StrToInt(TempString);\r\n ftFloat:\r\n { Default CLASSIC behaviour of this component is to encode outgoing data in US\r\n format regardless of system regional settings. This has become more flexible now,\r\n but we still default at designtime-defaults to using a DOT. }\r\n Result := JvCsvStrToFloat(TempString, GetDecimalSeparator);\r\n\r\n ftBoolean:\r\n Result := StrToIntDef(TempString, 0) <> 0;\r\n ftDateTime:\r\n { one of three different datetime formats}\r\n if TempString <> '' then\r\n case CsvColumnData^.FFlag of\r\n jcsvAsciiTime:\r\n Result := JvIsoDateTimeStrToDateTime(TempString);\r\n jcsvAsciiDate:\r\n Result := JvIsoDateTimeStrToDateTime(TempString);\r\n jcsvAsciiDateTime:\r\n Result := JvIsoDateTimeStrToDateTime(TempString);\r\n jcsvGMTDateTime:\r\n Result := JvTimeTHexToDateTime(TempString, 0);\r\n jcsvTZDateTime:\r\n Result := JvTimeTHexToDateTime(TempString, FTimeZoneCorrection);\r\n end;\r\n end;\r\n except\r\n Result := Unassigned; // No value.\r\n end;\r\nend;\r\n\r\n// Auto-increment\r\n\r\nfunction TJvCustomCsvDataSet.GetAutoincrement(const FieldName: string): Integer;\r\nvar\r\n RecIndex: Integer;\r\n FieldLookup: TField;\r\n CsvColumnData: PCsvColumn;\r\n Max, Value: Integer;\r\n RowPtr: PCsvRow;\r\nbegin\r\n Result := -1; // failed.\r\n FieldLookup := FieldByName(FieldName);\r\n if FieldLookup.DataType <> ftInteger then\r\n Exit; // failed. Can only auto increment on Integer fields!\r\n\r\n if not Assigned(FieldLookup) then\r\n Exit; //failed.\r\n\r\n CsvColumnData := FCsvColumns.FindByFieldNo(FieldLookup.FieldNo);\r\n Max := -1;\r\n for RecIndex := 0 to FData.Count - 1 do\r\n try\r\n // skip filtered rows:\r\n RowPtr := FData[RecIndex];\r\n Assert(Assigned(RowPtr)); // FData should never contain nils!\r\n if not RowPtr^.Filtered then // skip filtered row!\r\n begin\r\n Value := GetFieldValueAsVariant(CsvColumnData, FieldLookup, RecIndex);\r\n if Value > Max then\r\n Max := Value; // keep maximum.\r\n end;\r\n except\r\n on E: EVariantError do\r\n Exit; // failed.\r\n end;\r\n\r\n if Max < 0 then\r\n Result := 0 // autoincrement starts at zero\r\n else\r\n Result := Max + 1; // count upwards.\r\nend;\r\n\r\n\r\n// XXX TODO: REMOVE HARD CODED LIMIT OF 20 FIELDS SEARCHABLE!!!\r\nfunction TJvCustomCsvDataSet.LocateRecord(const KeyFields: string; const KeyValues: Variant; Options: TLocateOptions):\r\n Boolean;\r\n // Options is [loCaseInsensitive]\r\n // or [loPartialKey]\r\n // or [loPartialKey,loCaseInsensitive]\r\n // or [] {none}\r\nvar\r\n StrValueA: string;\r\n StrValueB: string;\r\n KeyFieldArray: array [0..20] of string;\r\n FieldLookup: array [0..20] of TField;\r\n CsvColumnData: array [0..20] of PCsvColumn;\r\n FieldIndex: array [0..20] of Integer;\r\n RecIndex, I, Lo, Hi, Count, VarCount: Integer;\r\n Value: Variant;\r\n MatchCount: Integer;\r\n CompareResult: Boolean;\r\nbegin\r\n Result := False;\r\n Lo := -1;\r\n// Hi := -1; // Value is never used\r\n\r\n if not Active then\r\n Exit;\r\n if Pos(',', KeyFields) > 0 then\r\n Count := JvStrSplit(KeyFields, ',', #0, KeyFieldArray, 20)\r\n else\r\n Count := JvStrSplit(KeyFields, ';', #0, KeyFieldArray, 20);\r\n\r\n // Single value need not be an array type!\r\n if (VarType(KeyValues) and VarArray) > 0 then\r\n begin\r\n Lo := VarArrayLowBound(KeyValues, 1);\r\n Hi := VarArrayHighBound(KeyValues, 1);\r\n VarCount := (Hi - Lo) + 1;\r\n end\r\n else\r\n VarCount := 1;\r\n if (VarCount <> Count) or (Count = 0) or (KeyFieldArray[0] = '') then\r\n Exit;\r\n for I := 0 to 20 do\r\n begin\r\n if I < Count then\r\n begin\r\n FieldLookup[I] := FieldByName(KeyFieldArray[I]);\r\n CsvColumnData[I] := FCsvColumns.FindByFieldNo(FieldLookup[I].FieldNo);\r\n if not Assigned(FieldLookup[I]) then\r\n Exit;\r\n FieldIndex[I] := FieldLookup[I].Index;\r\n end\r\n else\r\n begin\r\n FieldLookup[I] := nil;\r\n FieldIndex[I] := -1;\r\n end;\r\n end;\r\n\r\n // Now search\r\n for RecIndex := 0 to FData.Count - 1 do\r\n begin\r\n if not PCsvRow(FData.Items[RecIndex])^.Filtered then // Mantis #5108: Don't need to trap filtered records\r\n begin\r\n MatchCount := 0;\r\n for I := 0 to Count - 1 do\r\n begin\r\n Value := GetFieldValueAsVariant(CsvColumnData[I], FieldLookup[I], RecIndex);\r\n if Lo < 0 then // non-vararray!\r\n CompareResult := Value = KeyValues\r\n else // vararray!\r\n CompareResult := Value = KeyValues[I + Lo];\r\n\r\n if CompareResult then\r\n Inc(MatchCount)\r\n else\r\n if Options <> [] then\r\n begin\r\n if VarIsStr(Value) then\r\n begin\r\n StrValueA := Value;\r\n StrValueB := KeyValues[I + Lo];\r\n if loCaseInsensitive in Options then\r\n CompareResult := {Ansi}CompareText(StrValueA, StrValueB) = 0\r\n else\r\n CompareResult := StrValueA = StrValueB;\r\n\r\n if CompareResult then\r\n Inc(MatchCount)\r\n else\r\n begin\r\n if loPartialKey in Options then\r\n begin\r\n if loCaseInsensitive in Options then\r\n begin\r\n StrValueA := {Ansi}UpperCase(StrValueA);\r\n StrValueB := {Ansi}UpperCase(StrValueB);\r\n end;\r\n if Pos(StrValueB, StrValueA) = 1 then\r\n Inc(MatchCount);\r\n end;\r\n end;\r\n end;\r\n end;\r\n end;\r\n\r\n if MatchCount = Count then\r\n begin\r\n RecNo := RecIndex; // Move cursor position.\r\n Result := True;\r\n Exit;\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJvCustomCsvDataSet.InternalSkipFiltered(DefaultResult: TGetResult;\r\n ForwardBackwardMode: Boolean): TGetResult;\r\nvar\r\n LimitReached: Boolean;\r\n RowPtr: PCsvRow;\r\nbegin\r\n Result := DefaultResult;\r\n if FRecordPos < 0 then\r\n Exit;\r\n LimitReached := False; // hit BOF or EOF?\r\n while not LimitReached do\r\n begin\r\n { no skippage required }\r\n RowPtr := PCsvRow(FData.GetRowPtr(FRecordPos));\r\n if not RowPtr^.Filtered then\r\n Exit;\r\n { skippage ensues }\r\n if ForwardBackwardMode then\r\n begin // ForwardSkip mode\r\n Inc(FRecordPos);\r\n if FRecordPos >= FData.Count then\r\n begin\r\n FRecordPos := JvCsv_ON_EOF_CRACK;\r\n Result := grEOF;\r\n Exit;\r\n end;\r\n end\r\n else\r\n begin // BackwardSkip mode\r\n Dec(FRecordPos);\r\n if FRecordPos < 0 then\r\n begin // hit BOF_CRACK\r\n FRecordPos := JvCsv_ON_BOF_CRACK;\r\n Result := grBOF;\r\n Exit;\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJvCustomCsvDataSet.GetRecord(Buffer: PJvMemBuffer; GetMode: TGetMode;\r\n DoCheck: Boolean): TGetResult;\r\nvar\r\n RowPtr: PCsvRow;\r\nbegin\r\n AnsiChar(Buffer[0]) := #0;\r\n Result := grEOF;\r\n if FData.Count < 1 then\r\n begin\r\n //Trace(' GetRecord - called when Data buffer empty.');\r\n Exit;\r\n end;\r\n case GetMode of\r\n gmPrior:\r\n begin\r\n //Trace(' GetRecord(Buffer, gmPrior, DoCheck)');\r\n if FRecordPos = JvCsv_ON_BOF_CRACK then\r\n Result := grBOF\r\n else\r\n if FRecordPos = JvCsv_ON_EOF_CRACK then\r\n begin\r\n FRecordPos := FData.Count - 1;\r\n\r\n // NEW FILTERING\r\n if FIsFiltered then\r\n Result := InternalSkipFiltered(grOK, False) // skipping backwards.\r\n else\r\n Result := grOK;\r\n end\r\n else\r\n if FRecordPos > 0 then\r\n begin\r\n Dec(FRecordPos);\r\n\r\n // NEW FILTERING\r\n if FIsFiltered then\r\n Result := InternalSkipFiltered(grOK, False) // skipping backwards.\r\n else\r\n Result := grOK;\r\n end\r\n else\r\n Result := grBOF;\r\n end;\r\n gmCurrent:\r\n begin\r\n //Trace(' GetRecord(Buffer, gmCurrent, DoCheck)');\r\n if FRecordPos < 0 then // BOF Crack or EOF Crack?\r\n Result := grError\r\n else\r\n Result := grOK;\r\n\r\n // NEW FILTERING\r\n if FIsFiltered then\r\n Result := InternalSkipFiltered(Result, True); // skipping forwards.\r\n end;\r\n gmNext:\r\n begin\r\n //Trace(' GetRecord(Buffer, gmNext, DoCheck)');\r\n if FRecordPos = JvCsv_ON_EOF_CRACK then\r\n Result := grEOF\r\n else\r\n begin\r\n Inc(FRecordPos);\r\n\r\n if FRecordPos >= FData.Count then\r\n begin\r\n FRecordPos := JvCsv_ON_EOF_CRACK;\r\n Result := grEOF\r\n end\r\n else\r\n begin\r\n // NEW FILTERING\r\n if FIsFiltered then\r\n Result := InternalSkipFiltered(grOK, True) // skipping forwards.\r\n else\r\n Result := grOK;\r\n end;\r\n end;\r\n end;\r\n else\r\n JvCsvDatabaseError(FTableName, RsEGetMode);\r\n end;\r\n\r\n if Result = grOK then\r\n begin\r\n //Trace( ' GetRecord FRecordPos='+IntToStr(FRecordPos)+'Result=grOk' );\r\n try\r\n { get a record into a buffer }\r\n RowPtr := PCsvRow(Buffer); // Cast to a Row Data Structure to our own type.\r\n Move(FData.GetRowPtr(FRecordPos)^, RowPtr^, FData.GetRowAllocSize);\r\n RowPtr^.Bookmark.Flag := bfCurrent;\r\n RowPtr^.Bookmark.Data := FRecordPos;\r\n\r\n // Update calculated fields for this row:\r\n ClearCalcFields(Buffer);\r\n GetCalcFields(Buffer);\r\n except\r\n on E: EJvCsvDataSetError do\r\n raise; // pass our error through.\r\n on E: Exception do\r\n JvCsvDatabaseError(FTableName, Format(RsEProblemReadingRow, [FRecordPos]) +' ' + E.Message);\r\n end;\r\n end\r\n else\r\n begin\r\n // fudge: Get bookmark into a record for BOF and EOF records:\r\n { if RowPtr <> NIL then\r\n RowPtr^.bookmark.Data := FRecordPos;}\r\n\r\n if (Result = grError) and DoCheck then\r\n JvCsvDatabaseError(FTableName, RsENoRecord);\r\n end;\r\n\r\n// if (Result = grError) then\r\n //Trace(' GetRecord Result = grError');\r\n// if (Result = grEof) then\r\n //Trace(' GetRecord Result = grEof');\r\n// if (Result = grBof) then\r\n //Trace(' GetRecord Result = grBof');\r\nend;\r\n\r\n// puts whole string in quotes, escapes embedded commas and quote characters!\r\n// Can optionally deal with newlines also.\r\n\r\nfunction TJvCustomCsvDataSet._Enquote(const StrVal: string): string;\r\nvar\r\n S: string;\r\n I, L: Integer;\r\n Ch: Char;\r\n LocalEnquoteBackslash: Boolean;\r\nbegin\r\n LocalEnquoteBackslash := GetEnquoteBackslash; // can force on, or let it turn on automatically.\r\n\r\n if Pos(StrVal, Cr) > 0 then // we are going to need to enquote the backslashes\r\n LocalEnquoteBackslash := True; // absolutely need it in just this case.\r\n if Pos(StrVal, Lf) > 0 then\r\n LocalEnquoteBackslash := True; // absolutely need it in just this case.\r\n\r\n S := '\"';\r\n L := Length(StrVal);\r\n for I := 1 to L do\r\n begin\r\n Ch := StrVal[I];\r\n if (Ch = Cr) and (BackslashCrLf) then\r\n // slighlty unstandard csv behavior, hopefully transparently interoperable with other apps that read CSVs\r\n S := S + '\\r'\r\n else\r\n if (Ch = Lf) and (BackslashCrLf) then // replace linefeed with \\n. slightly nonstandard csv behavior.\r\n S := S + '\\n'\r\n else\r\n if LocalEnquoteBackslash and (Ch = '\\') then\r\n begin // it would be ambiguous not to escape this in this case!\r\n S := S + '\\\\';\r\n EnquoteBackslash := True; // XXX This is a lurking bug. Some day we'll get bit by it.\r\n end\r\n else\r\n if Ch = '\"' then // always escape quotes by doubling them, since this is standard CSV behaviour\r\n S := S + '\"\"'\r\n else\r\n if Ch = Tab then\r\n S := S + Ch // keep tabs! NEW Sept 2004! WP.\r\n else\r\n //if (Ch >= ' ') then // we used to strip any other low-ascii-unprintables but we don't anymore!\r\n S := S + Ch;\r\n end;\r\n S := S + '\"'; // end quote.\r\n Result := S;\r\nend;\r\n\r\nfunction TJvCustomCsvDataSet.GetRecordSize: Word;\r\nbegin\r\n Result := FData.RecordSize;\r\nend;\r\n\r\nprocedure TJvCustomCsvDataSet.SetFieldData(Field: TField; Buffer: TJvValueBuffer);\r\nvar\r\n RowPtr: PCsvRow;\r\n NewVal: string;\r\n CP, PhysicalLocation: Integer;\r\n PDestination: PJvMemBuffer;\r\n CsvColumnData: PCsvColumn;\r\n DT: TDateTime;\r\n ATimeStamp: TTimeStamp;\r\n {$IFDEF JVCSV_WIDESTRING}\r\n {$IFDEF COMPILER12_UP}\r\n NewUniVal: UnicodeString;\r\n {$ELSE}\r\n NewUniVal: WideString;\r\n {$ENDIF COMPILER12_UP}\r\n {$ENDIF JVCSV_WIDESTRINGS}\r\nbegin\r\n //Trace( 'SetFieldData '+Field.FieldName );\r\n PDestination := GetActiveRecordBuffer;\r\n RowPtr := PCsvRow(PDestination);\r\n Assert(RowPtr.Magic = JvCsvRowMagic, 'Internal data corruption detected in JvCustomCsvDataSet.SetFieldData');\r\n\r\n // Dynamic CSV Column Ordering: If we didn't start by\r\n // assigning column orders when we opened the table,\r\n // we've now GOT to assume a physical ordering:\r\n if FHeaderRow = '' then\r\n begin\r\n FHeaderRow := GetColumnsAsString;\r\n ProcessCsvHeaderRow; // process FHeaderRow\r\n end;\r\n\r\n // If this is a calculated field or lookup field then...\r\n if (Field.FieldKind = fkCalculated) or (Field.FieldKind = fkLookup) then\r\n begin\r\n if (Field.Offset < 0) or (Field.Offset + Field.DataSize > JvCsv_MaxCalcDataOffset) then\r\n Exit;\r\n Inc(PDestination, GetCalcDataOffset(RowPtr) + Field.Offset);\r\n\r\n PDestination[0] := {$IFNDEF RTL200_UP}AnsiChar{$ENDIF RTL200_UP}(Ord(Buffer <> nil));\r\n\r\n if AnsiChar(PDestination[0]) <> #0 then\r\n Move({$IFDEF RTL240_UP}PByte(@Buffer[0]){$ELSE}Buffer{$ENDIF RTL240_UP}^, PDestination[1], Field.DataSize);\r\n //Result := True; {there is no return value, oops}\r\n // Notify controls of a field change:\r\n DataEvent(deFieldChange, NativeInt(Field));\r\n Exit;\r\n end;\r\n\r\n // If we get here, we are dealing with a physical record:\r\n\r\n // Set a field Data, taking the physical to logical ordering translation into\r\n // account:\r\n CsvColumnData := FCsvColumns.FindByFieldNo(Field.FieldNo);\r\n if not Assigned(CsvColumnData) then\r\n begin\r\n {$IFDEF DEBUGINFO_ON}\r\n OutputDebugString('JvCsvData.pas: Column data corrupt or missing.');\r\n {$ENDIF DEBUGINFO_ON}\r\n Exit;\r\n end;\r\n\r\n PhysicalLocation := CsvColumnData^.FPhysical;\r\n // ----- BUG FIX FEB 2004 WP (Location #1 of 2)\r\n if (PhysicalLocation < 0) and FPendingCsvHeaderParse then\r\n begin\r\n FPendingCsvHeaderParse := False; // Just-in-time-CSV-header-parsing fixes a long standing bug.\r\n ProcessCsvHeaderRow;\r\n PhysicalLocation := CsvColumnData^.FPhysical;\r\n end;\r\n // ----- end\r\n\r\n if PhysicalLocation < 0 then\r\n Exit;\r\n\r\n if Buffer = nil then\r\n NewVal := ''\r\n else\r\n case Field.DataType of\r\n {$IFDEF JVCSV_WIDESTRING}\r\n ftWideString:\r\n { New and only working in Delphi 2009.\r\n Private-Convention-Warning: Wide fields ALWAYS enquoted.\r\n }\r\n begin\r\n {$IFDEF COMPILER12_UP}\r\n NewUniVal := UnicodeString(PWideChar(Buffer));\r\n NewVal := _Enquote(NewUniVal);\r\n {$ELSE}\r\n { NOTE: This dies on Delphi 7, because Buffer was never initialized!}\r\n NewUniVal := WideString(PWideChar(Buffer));\r\n //NewUniVal := PWideString(Buffer)^; {doesn't work either}\r\n NewVal := _Enquote(Utf8Encode(NewUniVal));\r\n {$ENDIF COMPILER12_UP}\r\n end;\r\n {$ENDIF JVCSV_WIDESTRING}\r\n ftString:\r\n begin\r\n // ftString appears to be limited to ANSI Strings even in Delphi 2009.\r\n CP := StrLLen(PAnsiChar(Buffer), Field.Size);\r\n SetString(NewVal, PAnsiChar(Buffer), CP);\r\n //----------------------------------------------------------------------------------------------------\r\n // string ENQUOTING IN CSV: If user displayed value contains a comma, a backslash, or a Double quote character\r\n // then we MUST encode the whole string as a string literal in quotes with the embeddded quotes\r\n // and backslashes preceded by a backslash character.\r\n //----------------------------------------------------------------------------------------------------\r\n if AlwaysEnquoteStrings\r\n or (Pos(Separator, NewVal) > 0)\r\n or (Pos(Cr, NewVal) > 0)\r\n or (Pos(Lf, NewVal) > 0)\r\n or (Pos('\"', NewVal) > 0)\r\n or ((Pos('\\', NewVal) > 0) and EnquoteBackslash)\r\n then\r\n NewVal := _Enquote(NewVal); // puts whole string in quotes, escapes embedded commas and quote characters!\r\n end;\r\n ftInteger:\r\n begin\r\n NewVal := IntToStr(PInteger(Buffer)^);\r\n end;\r\n\r\n ftFloat:\r\n begin\r\n NewVal := _CsvFloatToStr(PDouble(Buffer)^);\r\n if AlwaysEnquoteFloats or (Separator = GetDecimalSeparator) then\r\n NewVal := _Enquote(NewVal); // puts whole string in quotes, escapes embedded commas and quote characters!\r\n end;\r\n\r\n ftBoolean:\r\n NewVal := IntToStr(Ord(PWordBool(Buffer)^)); // bugfix May 26, 2003 - WP\r\n\r\n // There are two ways of handling date and time:\r\n ftDate: // NEW: TDateField support!\r\n if (CsvColumnData^.FFlag = jcsvAsciiDate) then\r\n begin\r\n ATimeStamp.Time := 0;\r\n ATimeStamp.Date := Integer({$IFDEF RTL240_UP}PInteger(@Buffer[0]){$ELSE}Buffer{$ENDIF RTL240_UP}^);\r\n DT := TimeStampToDateTime(ATimeStamp);\r\n NewVal := JvDateIsoStr(DT);\r\n end\r\n else\r\n JvCsvDatabaseError2(FTableName, RsEFieldTypeNotHandled, Ord(CsvColumnData^.FFlag));\r\n ftTime: // NEW: TTimeField support!\r\n if CsvColumnData^.FFlag = jcsvAsciiTime then\r\n begin\r\n ATimeStamp.Time := LongInt({$IFDEF RTL240_UP}PLongInt(@Buffer[0]){$ELSE}Buffer{$ENDIF RTL240_UP}^);\r\n ATimeStamp.Date := DateDelta;\r\n DT := TimeStampToDateTime(ATimeStamp);\r\n NewVal := JvTimeIsoStr(DT);\r\n end\r\n else\r\n JvCsvDatabaseError2(FTableName, RsEFieldTypeNotHandled, Ord(CsvColumnData^.FFlag));\r\n ftDateTime:\r\n case CsvColumnData^.FFlag of\r\n // Localized date only (no time) in Ascii\r\n jcsvAsciiDate:\r\n begin\r\n DT := TimeStampToDateTime(MSecsToTimeStamp(Double({$IFDEF RTL240_UP}PDouble(@Buffer[0]){$ELSE}Buffer{$ENDIF RTL240_UP}^)));\r\n NewVal := JvDateIsoStr(DT);\r\n end;\r\n // Localized time only (no date) in Ascii\r\n jcsvAsciiTime:\r\n begin\r\n DT := TimeStampToDateTime(MSecsToTimeStamp(Double({$IFDEF RTL240_UP}PDouble(@Buffer[0]){$ELSE}Buffer{$ENDIF RTL240_UP}^)));\r\n NewVal := JvTimeIsoStr(DT);\r\n end;\r\n // Localized date+time in Ascii\r\n jcsvAsciiDateTime:\r\n begin\r\n DT := TimeStampToDateTime(MSecsToTimeStamp(Double({$IFDEF RTL240_UP}PDouble(@Buffer[0]){$ELSE}Buffer{$ENDIF RTL240_UP}^)));\r\n NewVal := JvDateTimeIsoStr(DT);\r\n end;\r\n // GMT Times are stored in HEX\r\n jcsvGMTDateTime:\r\n begin\r\n DT := TimeStampToDateTime(MSecsToTimeStamp(Double({$IFDEF RTL240_UP}PDouble(@Buffer[0]){$ELSE}Buffer{$ENDIF RTL240_UP}^)));\r\n NewVal := JvDateTimeToTimeTHex(DT, 0);\r\n end;\r\n jcsvTZDateTime: // Move a GMT time into a timezone:\r\n begin\r\n DT := TimeStampToDateTime(MSecsToTimeStamp(Double({$IFDEF RTL240_UP}PDouble(@Buffer[0]){$ELSE}Buffer{$ENDIF RTL240_UP}^)));\r\n NewVal := JvDateTimeToTimeTHex(DT, FTimeZoneCorrection);\r\n end;\r\n else\r\n JvCsvDatabaseError2(FTableName, RsETimeTConvError, Ord(CsvColumnData^.FFlag));\r\n end;\r\n else\r\n JvCsvDatabaseError2(FTableName, RsEFieldTypeNotHandled, Ord(CsvColumnData^.FFlag));\r\n end;\r\n\r\n // Set new Data value (NewVal = string)\r\n SetCsvRowItem(RowPtr, PhysicalLocation, NewVal);\r\n if Assigned(FOnSetFieldData) and (RowPtr^.Index >= 0) then\r\n FOnSetFieldData(Self, FData.GetUserTag(RowPtr^.Index), FData.GetUserData(RowPtr^.Index), Field.FieldName, NewVal);\r\n\r\n // Set a dirty bit so we remember to write this later:\r\n CsvRowSetDirtyBit(PCsvRow(PDestination), PhysicalLocation);\r\n\r\n // Set the file-wide dirty bit:\r\n FFileDirty := True;\r\n\r\n // Notify controls of a field change:\r\n DataEvent(deFieldChange, NativeInt(Field));\r\nend;\r\n\r\n// Removes first and last character of the string (assumes they are quotes,\r\n// to be called byGetFieldData only!)\r\n\r\nfunction TJvCustomCsvDataSet._Dequote(const StrVal: string): string;\r\nvar\r\n S: string;\r\n I, L: Integer;\r\n Ch: Char;\r\n SkipFlag: Boolean;\r\nbegin\r\n L := Length(StrVal);\r\n SkipFlag := False;\r\n S := '';\r\n if Length(StrVal) < 2 then\r\n begin\r\n Result := S;\r\n Exit;\r\n end;\r\n\r\n for I := 2 to L - 1 do\r\n begin\r\n Ch := StrVal[I];\r\n if EnquoteBackslash then\r\n begin\r\n if not SkipFlag and (Ch = '\\') then\r\n begin\r\n SkipFlag := True; // whatever is after the backslash is an escaped literal character.\r\n Continue;\r\n end\r\n else\r\n begin\r\n // backslashed escape codes for carriage return, linefeed.\r\n if SkipFlag then\r\n begin\r\n case Ch of\r\n 'r':\r\n Ch := Cr;\r\n 's':\r\n Ch := #32;\r\n 't':\r\n Ch := Tab;\r\n 'n':\r\n Ch := Lf;\r\n end;\r\n end;\r\n SkipFlag := False;\r\n end;\r\n end\r\n else\r\n begin\r\n if not SkipFlag and (Ch = '\"') and (I < (L - 1)) and (StrVal[I + 1] = '\"') then\r\n begin\r\n SkipFlag := True;\r\n Continue; // skip first of the doubled quote characters.\r\n end\r\n else\r\n SkipFlag := False;\r\n end;\r\n S := S + Ch;\r\n end;\r\n Result := S;\r\nend;\r\n\r\n// Tells controls to redraw.\r\n\r\nprocedure TJvCustomCsvDataSet.Refresh;\r\nvar\r\n M: TBookmark;\r\nbegin\r\n if State <> dsBrowse then\r\n Exit;\r\n DisableControls;\r\n try\r\n M := GetBookmark; // This appears a bit silly but it works very well.\r\n try\r\n First; // Redraws all controls once to relocate to top.\r\n GotoBookmark(M); // Go back where we were. This could Result in some odd scrolling behaviour but I haven't seen it yet.\r\n finally\r\n FreeBookmark(M);\r\n end;\r\n finally\r\n EnableControls;\r\n end;\r\nend;\r\n\r\nfunction TJvCustomCsvDataSet.GetFieldData(Field: TField; Buffer: TJvValueBuffer): Boolean;\r\nvar\r\n RowPtr: PCsvRow;\r\n PSource: PJvMemBuffer;\r\n UserString, TempString: string;\r\n AnsiStr: AnsiString;\r\n PhysicalLocation: Integer;\r\n CsvColumnData: PCsvColumn;\r\n ADateTime: TDateTime;\r\n length_n: Integer;\r\n ts: TTimeStamp;\r\n {$IFDEF JVCSV_WIDESTRING}\r\n {$IFDEF COMPILER12_UP}\r\n GetUniValue: UnicodeString;\r\n {$ELSE}\r\n GetUniValue: WideString;\r\n {$ENDIF COMPILER12_UP}\r\n {$ENDIF JVCSV_WIDESTRING}\r\nbegin\r\n Result := False;\r\n\r\n //Trace( 'GetFieldData '+Field.FieldName );\r\n\r\n if not FCursorOpen or (Field = nil) then\r\n Exit;\r\n\r\n // Dynamic CSV Column Ordering: If we didn't start by\r\n // assigning column orders when we opened the table,\r\n // we've now GOT to assume a physical ordering:\r\n if FHeaderRow = '' then\r\n begin\r\n FHeaderRow := GetColumnsAsString;\r\n ProcessCsvHeaderRow; // process FHeaderRow\r\n end;\r\n\r\n PSource := GetActiveRecordBuffer; // This should not be nil EXCEPT if table is Empty or Closed.\r\n\r\n if PSource = nil then\r\n begin\r\n // It is possible we could raise an exception here:\r\n // \"GetActiveRecordBuffer is nil but table is not empty. (Internal Fault Condition).\"\r\n Exit;\r\n end;\r\n\r\n RowPtr := PCsvRow(PSource);\r\n\r\n //------------------------------------------------------------------------\r\n // Calculated and Lookup Field Handling\r\n //\r\n // direct memory copy into calculated field or lookup field Data area\r\n //------------------------------------------------------------------------\r\n if (Field.FieldKind = fkCalculated) or (Field.FieldKind = fkLookup) then\r\n begin\r\n if (Field.Offset < 0) or (Field.Offset + Field.DataSize > JvCsv_MaxCalcDataOffset) then\r\n begin\r\n //It is possible we could raise an exception here:\r\n //Invalid field.Offset in Calculated or Lookup field\r\n Exit;\r\n end;\r\n\r\n\r\n Inc(PSource, GetCalcDataOffset(RowPtr) + Field.Offset);\r\n if Buffer = nil then\r\n begin\r\n // NULL CHECK MEANS THAT SOMEONE IS ASKING IF THIS FIELD HAS A VALUE. RETURN True.\r\n Result := (Field.DataSize > 0); // Yes, we could read this field if you asked us to!\r\n Exit;\r\n end;\r\n\r\n if Field.DataSize <= 0 then\r\n PAnsiChar(Buffer)[0] := Chr(0)\r\n else // Get the field Data from the buffer:\r\n CopyMemory(Buffer, @PSource[1], Field.DataSize);\r\n\r\n if (Buffer <> nil) and (Field.DataSize > 0) then\r\n Result := True;\r\n Exit;\r\n end;\r\n\r\n //------------------------------------------------------------------------\r\n // If we get here we must be dealing with a real column of Data\r\n // that is part of the CSV file rather than a calculated or lookup\r\n // field that is just in internal-memory:\r\n //------------------------------------------------------------------------\r\n\r\n CsvColumnData := FCsvColumns.FindByFieldNo(Field.FieldNo);\r\n if not Assigned(CsvColumnData) then\r\n begin\r\n JvCsvDatabaseError(FTableName, Format(RsEUnableToLocateCSVFileInfo, [Field.Name]));\r\n Exit;\r\n end;\r\n PhysicalLocation := CsvColumnData^.FPhysical;\r\n // ----- BUG FIX FEB 2004 WP (Location #2 of 2)\r\n if (PhysicalLocation < 0) and FPendingCsvHeaderParse then\r\n begin\r\n FPendingCsvHeaderParse := False; // Just In Time!\r\n ProcessCsvHeaderRow;\r\n PhysicalLocation := CsvColumnData^.FPhysical;\r\n end;\r\n // ---\r\n\r\n if PhysicalLocation < 0 then\r\n begin // does it really exist in the CSV Row?\r\n JvCsvDatabaseError(FTableName, Format(RsEPhysicalLocationOfCSVField, [Field.FieldName]));\r\n Exit;\r\n end;\r\n\r\n //------------------------------------------------------------------------\r\n // All items in the CSV table are natively stored as strings. Note that\r\n // an empty string is considered to be a NULL if the field type is anything\r\n // other than a ftString. There are no NULLs in ftString fields because\r\n // a CSV file can store an empty string but has no way of indicating a NULL.\r\n //------------------------------------------------------------------------\r\n\r\n\r\n if Field.Offset + Field.DataSize > JvCsv_MAXLINELENGTH then\r\n Exit;\r\n\r\n TempString := GetCsvRowItem(RowPtr, PhysicalLocation);\r\n\r\n // Strip quotes first!\r\n if Field.DataType = ftString then\r\n begin\r\n length_n := Length(TempString);\r\n if length_n >= 2 then\r\n if (TempString[1] = '\"') and (TempString[length_n] = '\"') then\r\n // quoted string!\r\n TempString := _Dequote(TempString);\r\n end;\r\n\r\n // Custom Get Method allows us to create a \"Virtual DataSet\" where the Data\r\n // in the CSV rows is really just a mirror which can be updated when displayed\r\n // but which we really are fetching from somewhere else.\r\n if Assigned(FOnGetFieldData) and (RowPtr^.Index >= 0) and (not RowPtr^.RecursionFlag) then\r\n begin\r\n RowPtr^.RecursionFlag := True;\r\n UserString := TempString;\r\n FOnGetFieldData(Self, FData.GetUserTag(RowPtr^.Index),\r\n FData.GetUserData(RowPtr^.Index), Field.FieldName, UserString);\r\n if UserString <> TempString then\r\n begin\r\n // Write changed value back to row:\r\n SetCsvRowItem(RowPtr, PhysicalLocation, UserString);\r\n TempString := UserString;\r\n // Notify controls of a field change:\r\n //DataEvent(deFieldChange, NativeInt(Field));\r\n // XXX Doesn't do what I needed. left here commented out\r\n // in case I ever go back and try to get something like this\r\n // working again.\r\n end;\r\n RowPtr^.RecursionFlag := False;\r\n end;\r\n\r\n // NULL: There are no \"Real\" NULLS in an ASCII flat file, however for anything\r\n // other than a string field, we will return \"NULL\" to indicate there is an\r\n // empty string in the field.\r\n if Field.DataType <> ftString then\r\n if TempString = '' then\r\n Exit; // NULL field.\r\n\r\n { If buffer is nil, then we are being asked to do a null check only.}\r\n if Buffer = nil then\r\n begin\r\n if TempString = '' then\r\n Result := False\r\n else\r\n Result := True;\r\n Exit; { cannot actually copy Data into nil buffer, so returns now. }\r\n end;\r\n\r\n //------------------------------------------------------------------------\r\n // If we get here Buffer must NOT be nil. Now we handle\r\n // some csv to TField conversions:\r\n //------------------------------------------------------------------------\r\n try\r\n case Field.DataType of\r\n {$IFDEF JVCSV_WIDESTRING}\r\n ftWideString:\r\n begin\r\n {$IFDEF COMPILER12_UP}\r\n GetUniValue := _Dequote(TempString);\r\n {$ELSE}\r\n GetUniValue := UTF8Decode(_Dequote(TempString));\r\n {$ENDIF COMPILER12_UP}\r\n length_n := Length(GetUniValue) * SizeOf(WideChar);\r\n if (length_n > FData.FTextBufferSize) then\r\n length_n := FData.FTextBufferSize;\r\n if (length_n > Field.Size * SizeOf(WideChar)) then\r\n length_n := Field.Size * SizeOf(WideChar);\r\n MoveMemory({dest} Buffer, {src} PWideChar(GetUniValue), {count} length_n);\r\n PWideChar({$IFDEF RTL240_UP}PByte(@Buffer[0]){$ELSE}Buffer{$ENDIF RTL240_UP})[Length(GetUniValue)] := WideChar(0); { wide terminal }\r\n end;\r\n {$ENDIF JVCSV_WIDESTRING}\r\n\r\n // Basic string copy, convert from string to fixed-length\r\n // buffer, padded with NUL i.e. Chr(0):\r\n ftString:\r\n begin\r\n AnsiStr := AnsiString(TempString);\r\n length_n := Length(AnsiStr);\r\n if (length_n > FData.FTextBufferSize) then\r\n length_n := FData.FTextBufferSize;\r\n if (length_n > Field.Size) then\r\n length_n := Field.Size;\r\n\r\n MoveMemory({dest} Buffer, {src} PAnsiChar(AnsiStr), {count} length_n);\r\n PAnsiChar({$IFDEF RTL240_UP}PByte(@Buffer[0]){$ELSE}Buffer{$ENDIF RTL240_UP})[length_n] := #0;\r\n end;\r\n // Standard Integer conversion:\r\n ftInteger:\r\n PInteger({$IFDEF RTL240_UP}PInteger(@Buffer[0]){$ELSE}Buffer{$ENDIF RTL240_UP})^ := StrToInt(TempString);\r\n // Standard Double-precision Float conversion:\r\n ftFloat:\r\n PDouble({$IFDEF RTL240_UP}PByte(@Buffer[0]){$ELSE}Buffer{$ENDIF RTL240_UP})^ := JvCsvStrToFloat(TempString, GetDecimalSeparator); // was StrToFloatUS\r\n ftBoolean:\r\n if TempString = '' then\r\n PInteger({$IFDEF RTL240_UP}PByte(@Buffer[0]){$ELSE}Buffer{$ENDIF RTL240_UP})^ := 0\r\n else\r\n PWordBool({$IFDEF RTL240_UP}PByte(@Buffer[0]){$ELSE}Buffer{$ENDIF RTL240_UP})^ := StrToIntDef(TempString, 0) <> 0; // bugfix May 26, 2003 - WP\r\n\r\n ftDate:\r\n if CsvColumnData^.FFlag = jcsvAsciiDate then\r\n // Ascii Date yyyy/mm/ddd\r\n begin\r\n ADateTime := JvIsoDateStrToDate(TempString);\r\n if ADateTime <= 1.0 then\r\n begin\r\n Result := False; { field is NULL, no date/time value }\r\n Exit;\r\n end;\r\n // XXX Delphi Weirdness Ahead. Read docs before you try to\r\n // understand this. The data in Buffer^ is an Integer timestamp\r\n Integer({$IFDEF RTL240_UP}PInteger(@Buffer[0]){$ELSE}Buffer{$ENDIF RTL240_UP}^) := DateTimeToTimeStamp(ADateTime).Date;\r\n end else\r\n JvCsvDatabaseError(FTableName, RsETimeTConvError);\r\n\r\n ftTime:\r\n if CsvColumnData^.FFlag = jcsvAsciiTime then\r\n begin\r\n ADateTime := JvIsoTimeStrToTime(TempString);\r\n if ADateTime < 0.0 then\r\n begin\r\n Result := False; { field is NULL, no date/time value }\r\n Exit;\r\n end;\r\n // The data in Buffer^ is an Integer timestamp\r\n Integer({$IFDEF RTL240_UP}PInteger(@Buffer[0]){$ELSE}Buffer{$ENDIF RTL240_UP}^) := DateTimeToTimeStamp(ADateTime).Time;\r\n end else\r\n JvCsvDatabaseError(FTableName, RsETimeTConvError);\r\n\r\n ftDateTime:\r\n case CsvColumnData^.FFlag of\r\n // Ascii Date yyyy/mm/ddd\r\n jcsvAsciiDate:\r\n begin\r\n ADateTime := JvIsoDateStrToDate(TempString);\r\n if ADateTime <= 1.0 then\r\n begin\r\n Result := False; { field is NULL, no date/time value }\r\n Exit;\r\n end;\r\n ts := DateTimeToTimeStamp(ADateTime);\r\n if (ts.Time = 0) and (ts.Date = 0) then\r\n Exit;\r\n // XXX Delphi Weirdness Ahead. Read docs before you try to\r\n // understand this. We want to store 8 bytes at Buffer^, this\r\n // is how we do it.\r\n Double({$IFDEF RTL240_UP}PDouble(@Buffer[0]){$ELSE}Buffer{$ENDIF RTL240_UP}^) := TimeStampToMSecs(DateTimeToTimeStamp(ADateTime));\r\n end;\r\n\r\n // Ascii Time 08:23:15\r\n jcsvAsciiTime:\r\n begin\r\n ADateTime := JvIsoTimeStrToTime(TempString);\r\n if ADateTime <= 1.0 then\r\n begin\r\n Result := False; { field is NULL, no date/time value }\r\n Exit;\r\n end;\r\n ts := DateTimeToTimeStamp(ADateTime);\r\n if (ts.Time = 0) and (ts.Date = 0) then\r\n Exit;\r\n // XXX Delphi Weirdness Ahead. Read docs before you try to\r\n // understand this. We want to store 8 bytes at Buffer^, this\r\n // is how we do it.\r\n Double({$IFDEF RTL240_UP}PDouble(@Buffer[0]){$ELSE}Buffer{$ENDIF RTL240_UP}^) := TimeStampToMSecs(DateTimeToTimeStamp(ADateTime));\r\n end;\r\n\r\n\r\n // Ascii Date 1999/03/05 08:23:15\r\n jcsvAsciiDateTime:\r\n begin\r\n ADateTime := JvIsoDateTimeStrToDateTime(TempString);\r\n if ADateTime <= 1.0 then\r\n begin\r\n Result := False; { field is NULL, no date/time value }\r\n Exit;\r\n end;\r\n ts := DateTimeToTimeStamp(ADateTime);\r\n if (ts.Time = 0) and (ts.Date = 0) then\r\n Exit;\r\n // XXX Delphi Weirdness Ahead. Read docs before you try to\r\n // understand this. We want to store 8 bytes at Buffer^, this\r\n // is how we do it.\r\n Double({$IFDEF RTL240_UP}PDouble(@Buffer[0]){$ELSE}Buffer{$ENDIF RTL240_UP}^) := TimeStampToMSecs(DateTimeToTimeStamp(ADateTime));\r\n end;\r\n\r\n // GMT Times are Stored in HEX:\r\n jcsvGMTDateTime:\r\n Double({$IFDEF RTL240_UP}PDouble(@Buffer[0]){$ELSE}Buffer{$ENDIF RTL240_UP}^) := TimeStampToMSecs(DateTimeToTimeStamp(JvTimeTHexToDateTime(TempString, 0)));\r\n // Move GMT into a Timezone:\r\n jcsvTZDateTime:\r\n Double({$IFDEF RTL240_UP}PDouble(@Buffer[0]){$ELSE}Buffer{$ENDIF RTL240_UP}^) := TimeStampToMSecs(DateTimeToTimeStamp(JvTimeTHexToDateTime(TempString,\r\n FTimeZoneCorrection)));\r\n else\r\n JvCsvDatabaseError(FTableName, RsETimeTConvError);\r\n end;\r\n else // not a valid ftXXXX type for this TDataSet descendant!?\r\n JvCsvDatabaseError2(FTableName, RsEFieldTypeNotHandled, Ord(Field.DataType));\r\n end\r\n except\r\n on E: EConvertError do\r\n begin\r\n Result := False; // return a NULL.\r\n Exit;\r\n end;\r\n end;\r\n // All is Well.\r\n Result := True;\r\nend;\r\n\r\n// Our bookmark Data is a pointer to a PCsvData\r\n\r\nfunction TJvCustomCsvDataSet.GetBackslashCrLf: Boolean;\r\nbegin\r\n if Assigned(FData) then\r\n Result := FData.BackslashCrLf\r\n else\r\n Result := False;\r\nend;\r\n\r\nprocedure TJvCustomCsvDataSet.GetBookmarkData(Buffer: PJvMemBuffer; Data: TJvBookmark);\r\nbegin\r\n PInteger(Data)^ := PCsvRow(Buffer)^.Bookmark.Data;\r\nend;\r\n\r\nfunction TJvCustomCsvDataSet.GetBookmarkFlag(Buffer: PJvMemBuffer): TBookmarkFlag;\r\nbegin\r\n Result := PCsvRow(Buffer)^.Bookmark.Flag;\r\nend;\r\n\r\n// nobody mentioned that I needed this to be overloaded, but I only found\r\n// out when I found that DBGrid and other controls that compare bookmarks\r\n// won't function if you don't provide a non-default implementation of this.\r\n\r\nfunction TJvCustomCsvDataSet.CompareBookmarks(Bookmark1, Bookmark2: TBookmark): Integer;\r\nvar\r\n V1, V2: Integer;\r\nbegin\r\n // (rom) fixed implementation.\r\n V1 := -MaxInt;\r\n V2 := -MaxInt;\r\n if Bookmark1 <> nil then\r\n V1 := PInteger(Bookmark1)^;\r\n if Bookmark2 <> nil then\r\n V2 := PInteger(Bookmark2)^;\r\n Result := Bookmark_Eql;\r\n if V1 < V2 then\r\n Result := Bookmark_Less\r\n else\r\n if V1 > V2 then\r\n Result := Bookmark_Gtr;\r\nend;\r\n\r\nprocedure TJvCustomCsvDataSet.SetBookmarkFlag(Buffer: PJvMemBuffer; Value: TBookmarkFlag);\r\nbegin\r\n PCsvRow(Buffer)^.Bookmark.Flag := Value;\r\nend;\r\n\r\nprocedure TJvCustomCsvDataSet.InternalGotoBookmark(Bookmark: TJvBookmark);\r\nbegin\r\n {Bookmark is just pointer to Integer}\r\n FRecordPos := PInteger(Bookmark)^;\r\nend;\r\n\r\nprocedure TJvCustomCsvDataSet.InternalSetToRecord(Buffer: PJvMemBuffer);\r\nbegin\r\n FRecordPos := PCsvRow(Buffer)^.Bookmark.Data; // Look up index from the record.\r\n// Resync([]);\r\nend;\r\n\r\n// Also used when inserting:\r\n\r\nprocedure TJvCustomCsvDataSet.SetBackslashCrLf(const Value: Boolean);\r\nbegin\r\n if Assigned(FData) then\r\n FData.BackslashCrLf := Value;\r\nend;\r\n\r\nprocedure TJvCustomCsvDataSet.SetBookmarkData(Buffer: PJvMemBuffer; Data: TJvBookmark);\r\nbegin\r\n PCsvRow(Buffer)^.Bookmark.Data := PInteger(Data)^;\r\nend;\r\n\r\nprocedure TJvCustomCsvDataSet.InternalFirst;\r\nbegin\r\n FRecordPos := JvCsv_ON_BOF_CRACK;\r\nend;\r\n\r\n// CsvFieldDef:\r\n//\r\n// A property of our Data Set called CsvFieldDef is treated as\r\n// declaration of the fields in the CSV table.\r\n//\r\n// ,,...,\r\n// = columname:\r\n//\r\n// See comments at the top of this unit for a discussion of the\r\n// various VCL DB field types like Integer and string, and how\r\n// they map to the special \"FieldTypeChar\" values defined here.\r\nprocedure TJvCustomCsvDataSet.InternalInitFieldDefs;\r\nvar\r\n CsvFieldOption : string;\r\n CsvFieldName : string;\r\n aCsvFieldDef : string;\r\n CsvKeys : array of string;\r\n\r\n CsvFieldRec : PCsvRow; //record type.\r\n PCsvFieldDef : PCsvColumn;\r\n\r\n I : Integer;\r\n ColNum : Integer;\r\n Pos1 : Integer;\r\n SymbolOrdinal : Integer;\r\n FieldTypeChar : Char; // field options (%=Integer, etc)\r\n VclFieldType : TFieldType; // official VCL field type\r\n FieldLen : Integer;\r\n FieldType : TJvCsvColumnFlag;\r\n CsvMaxLen : Integer; // Safety!\r\nbegin\r\n CsvMaxLen := 0;\r\n CsvFieldRec := PCsvRow(FData.AllocRecordBuffer);\r\n try\r\n FieldType := jcsvString;\r\n VclFieldType := ftString;\r\n\r\n // create FieldDefs which map to each field in the Data record\r\n FieldDefs.Clear; // Clear VCL Database field definitions\r\n FCsvColumns.Clear; // Clear our own CSV related field Data\r\n\r\n FDefaultCsvFieldDefs := False;\r\n aCsvFieldDef := CsvFieldDef;\r\n if aCsvFieldDef = '' then\r\n begin\r\n if FHasHeaderRow and ReadCsvFileStream then\r\n begin\r\n aCsvFieldDef := FCsvFileTopLine;\r\n {$IFDEF DEBUGINFO_ON}\r\n if aCsvFieldDef = '' then\r\n OutputDebugString('Top line of file empty. CsvFieldDef not provided either.');\r\n {$ENDIF DEBUGINFO_ON}\r\n end;\r\n\r\n if ExtendedHeaderInfo then\r\n CsvFieldDef := aCsvFieldDef;\r\n FDefaultCsvFieldDefs := True;\r\n end;\r\n\r\n if aCsvFieldDef <> '' then\r\n begin\r\n if (Separator <> ',') and (Pos(Separator, aCsvFieldDef) = 0) then\r\n JvStringToCsvRow(aCsvFieldDef, ',', CsvFieldRec, False, False) { workaround for serious annoyance }\r\n else\r\n JvStringToCsvRow(aCsvFieldDef, Separator, CsvFieldRec, False, False);\r\n\r\n ColNum := 0;\r\n while CsvRowGetColumnMarker(CsvFieldRec, ColNum) <> JvCsv_COLUMN_ENDMARKER do\r\n begin\r\n FieldLen := 80; // default.\r\n CsvFieldOption := GetCsvRowItem(CsvFieldRec, ColNum); // get a string in the format COLUMNAME:Options\r\n\r\n // Look for Colon or Semicolon:\r\n Pos1 := Pos(':', CsvFieldOption);\r\n if Pos1 <= 0 then\r\n Pos1 := Pos(';', CsvFieldOption);\r\n\r\n if Pos1 <= 0 then\r\n begin\r\n CsvFieldName := CsvFieldOption;\r\n CsvFieldOption := '$';\r\n FieldTypeChar := '$';\r\n end\r\n else\r\n begin\r\n // extract field name:\r\n CsvFieldName := Copy(CsvFieldOption, 1, Pos1 - 1);\r\n // If character after the colon is a symbol character, grab\r\n // it, otherwise default to '$'. New ~ tilda character ordinal is 126.\r\n // Other symbols are all less than 65 (capital A).\r\n SymbolOrdinal := Ord(CsvFieldOption[Pos1 + 1]);\r\n if (SymbolOrdinal < Ord('A')) or (SymbolOrdinal >= Ord('~')) then\r\n begin\r\n FieldTypeChar := CsvFieldOption[Pos1 + 1];\r\n CsvFieldOption := Copy(CsvFieldOption, Pos1 + 2, 80);\r\n end\r\n else\r\n begin\r\n FieldTypeChar := '$';\r\n CsvFieldOption := Copy(CsvFieldOption, Pos1 + 1, 80);\r\n end;\r\n FieldLen := StrToIntDef(CsvFieldOption, JvCsv_DEFAULT_CSV_STR_FIELD);\r\n\r\n end;\r\n case FieldTypeChar of\r\n '$':\r\n begin // $=string\r\n CsvMaxLen := CsvMaxLen + FieldLen;\r\n VclFieldType := ftString;\r\n FieldType := jcsvString;\r\n end;\r\n '%':\r\n begin // %=Integervalue\r\n VclFieldType := ftInteger;\r\n FieldType := jcsvNumeric;\r\n FieldLen := 0; // automatic.\r\n CsvMaxLen := CsvMaxLen + 5;\r\n end;\r\n '&':\r\n begin // &=Float value\r\n VclFieldType := ftFloat;\r\n FieldType := jcsvNumeric;\r\n FieldLen := 0; // automatic.\r\n CsvMaxLen := CsvMaxLen + 5;\r\n end;\r\n '@':\r\n begin // @=Datetime as Ascii YYYY/MM/DD HH:MM:SS\r\n VclFieldType := ftDateTime;\r\n FieldType := jcsvAsciiDateTime;\r\n FieldLen := 0; // automatic.\r\n CsvMaxLen := CsvMaxLen + 20;\r\n end;\r\n '/':\r\n begin // /=date only as ascii YYYY/MM/DD\r\n VclFieldType := ftDate;\r\n FieldType := jcsvAsciiDate;\r\n FieldLen := 0; // automatic.\r\n CsvMaxLen := CsvMaxLen + 10;\r\n end;\r\n '*':\r\n begin // *=time only as HH:MM:SS\r\n VclFieldType := ftTime;\r\n FieldType := jcsvAsciiTime;\r\n FieldLen := 0; // automatic.\r\n CsvMaxLen := CsvMaxLen + 10;\r\n end;\r\n '!':\r\n begin // != Boolean field True/False\r\n VclFieldType := ftBoolean; // Boolean field in dataset\r\n FieldType := jcsvNumeric; // numeric field in file\r\n FieldLen := 0; // automatic.\r\n CsvMaxLen := CsvMaxLen + 1;\r\n end;\r\n '#':\r\n begin // #=Datetime as Seconds since 1970 stored in HEX\r\n VclFieldType := ftDateTime;\r\n FieldType := jcsvGMTDateTime;\r\n FieldLen := 0; // automatic.\r\n CsvMaxLen := CsvMaxLen + 10;\r\n end;\r\n '-':\r\n begin // -=Datetime as Seconds since 1970 stored in HEX\r\n VclFieldType := ftDateTime;\r\n FieldType := jcsvTZDateTime;\r\n FieldLen := 0; // automatic.\r\n CsvMaxLen := CsvMaxLen + 10;\r\n end;\r\n {$IFDEF JVCSV_WIDESTRING}\r\n '~':\r\n begin // New UTF8 string type. [ Delphi 2009 only ]\r\n CsvMaxLen := CsvMaxLen + FieldLen;\r\n VclFieldType := ftWideString;\r\n FieldType := jcsvStringUTF8;\r\n end\r\n {$ENDIF JVCSV_WIDESTRING}\r\n else\r\n JvCsvDatabaseError(FTableName, Format(RsEInvalidFieldTypeCharacter, [FieldTypeChar]));\r\n end;\r\n\r\n if CsvFieldName = '' then\r\n begin\r\n JvCsvDatabaseError(FTableName, RsEUnexpectedError);\r\n Break;\r\n end;\r\n\r\n // sometime later: unpack the rest of the string\r\n // and declare ftString,ftFloat,ftInteger,ftDateTime, etc.\r\n // now add the field:\r\n Inc(ColNum);\r\n\r\n if (CsvMaxLen > FData.TextBufferSize) then\r\n raise Exception.Create('Too many fields, or too many long string fields in this record. You must increase the internal record size of the CsvDataSet');\r\n\r\n // This may throw an exception. but we'll just allow\r\n // that as necessary:\r\n\r\n //Was: TFieldDef.Create(FieldDefs, ...., ColNum);\r\n FieldDefs.Add(CsvFieldName, VclFieldType, FieldLen, False);\r\n\r\n // Now create our internal field Data structure:\r\n PCsvFieldDef := AllocMem(SizeOf(TJvCsvColumn) {+ 8 BIGFudge});\r\n PCsvFieldDef^.FFlag := FieldType; {such as jcsvString}\r\n PCsvFieldDef^.FFieldDef := FieldDefs.Find(CsvFieldName);\r\n\r\n // Note: field order is established when we open the file (later)\r\n PCsvFieldDef^.FPhysical := -1; // not yet located in the physical file!\r\n FCsvColumns.AddColumn(PCsvFieldDef);\r\n end;\r\n\r\n // if the file doesn't contain this and we haven't\r\n // generated it yet, generate the header row:\r\n if not FHasHeaderRow and (FHeaderRow = '') then\r\n FHeaderRow := GetColumnsAsString;\r\n\r\n if FHeaderRow <> '' then\r\n ProcessCsvHeaderRow; // process FHeaderRow\r\n end\r\n else\r\n JvCsvDatabaseError(FTableName, RsEFieldDefinitionError);\r\n\r\n if FCsvKeyDef = '' then\r\n FCsvKeyCount := 0\r\n else\r\n begin\r\n SetLength(CsvKeys, FCsvColumns.Count);\r\n FCsvKeyCount := JvStrSplit(FCsvKeyDef, Separator, {Chr(0)=No Quoting} #0, CsvKeys, FCsvColumns.Count);\r\n SetLength(FCsvKeyFields, FCsvKeyCount);\r\n if (FCsvKeyCount < 1) or (FCsvKeyCount > FCsvColumns.Count) then\r\n JvCsvDatabaseError(FTableName, RsEInvalidCsvKeyDef);\r\n for I := 0 to FCsvKeyCount - 1 do\r\n begin\r\n if CsvKeys[I] = '' then\r\n JvCsvDatabaseError(FTableName, RsEInternalErrorParsingCsvKeyDef);\r\n PCsvFieldDef := FCsvColumns.FindByName(string(CsvKeys[I]));\r\n if not Assigned(PCsvFieldDef) then\r\n JvCsvDatabaseError(FTableName, Format(RsEContainsField, [CsvKeys[I]]))\r\n else\r\n begin\r\n PCsvFieldDef^.FKeyFlag := True;\r\n FCsvKeyFields[I] := PCsvFieldDef;\r\n end;\r\n end;\r\n end;\r\n // New:Array of Booleans used for ascending order on primary key sorting!\r\n SetLength(FAscending, FCsvKeyCount + 1);\r\n for I := 0 to Length(FAscending) - 1 do\r\n FAscending[I] := True;\r\n finally\r\n FreeMem(CsvFieldRec);\r\n end;\r\nend;\r\n\r\n{ set our position onto the EOF Crack }\r\n\r\nprocedure TJvCustomCsvDataSet.InternalLast;\r\nbegin\r\n// Eof := True;\r\n FRecordPos := JvCsv_ON_EOF_CRACK; // FData.Count;\r\nend;\r\n\r\n// At shutdown or on user-calling this method, check if Data has changed,\r\n// and write changes to the file.\r\nprocedure TJvCustomCsvDataSet.Flush;\r\nvar\r\n n: Integer;\r\n CsvLine: AnsiString;\r\nbegin\r\n if FFileDirty and FSavesChanges then\r\n begin\r\n if FTableName = '' then\r\n raise EJvCsvDataSetError.CreateRes(@RsETableNameNotSet);\r\n\r\n // Make backup first, if enabled (>2)\r\n if FAutoBackupCount > 0 then\r\n begin\r\n if FAutoBackupCount < 10 then\r\n FAutoBackupCount := 10; // can't be between 1 and 9, must be at least 10.\r\n JvCsvBackupPreviousFiles(FOpenFileName, FAutoBackupCount);\r\n end;\r\n // Now write new file.\r\n // creates a TStringList: old method: ExportCsvFile(FOpenFileName);\r\n\r\n if not WriteCsvFileStream then\r\n raise EJvCsvDataSetError.CreateFmt('Unable to write to csv file %s', [FTableName]);\r\n\r\n if FHasHeaderRow then\r\n FCsvStream.WriteLine(AnsiString(FHeaderRow));\r\n\r\n for n := 0 to RecordCount-1 do\r\n begin\r\n CsvLine := JvTrimAnsiStringCrLf(GetRowAsAnsiString(n));\r\n FCsvStream.WriteLine(CsvLine);\r\n end;\r\n FreeAndNil(FCsvStream);\r\n FFileDirty := False;\r\n end;\r\nend;\r\n\r\n{procedure TJvCustomCsvDataSet.DestroyFields;\r\nbegin\r\n inherited DestroyFields;\r\n // Clear out local TCsvFieldDefs.\r\n FCsvColumns.Clear;\r\nend;}\r\n\r\nprocedure TJvCustomCsvDataSet.InternalClose;\r\nbegin\r\n if not FCursorOpen then\r\n Exit;\r\n\r\n Flush;\r\n BindFields(False);\r\n if DefaultFields then\r\n DestroyFields;\r\n FData.Clear;\r\n FCursorOpen := False;\r\n FRecordPos := JvCsv_ON_BOF_CRACK;\r\n FOpenFileName := '';\r\n FCsvFileLoaded := False;\r\n FData.FRecordsValid := False;\r\n if FDefaultCsvFieldDefs then\r\n begin\r\n FCsvFieldDef := '';\r\n FHeaderRow := '';\r\n FieldDefs.Clear;\r\n Fields.Clear;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomCsvDataSet.InternalHandleException;\r\nbegin\r\n // standard implementation for this method:\r\n if Application <> nil then\r\n Application.HandleException(Self);\r\nend;\r\n\r\nprocedure TJvCustomCsvDataSet.InternalDelete;\r\nbegin\r\n if (FRecordPos >= 0) and (FRecordPos < FData.Count) then\r\n // FreeMem performed inside DeleteRow!\r\n FData.DeleteRow(FRecordPos);\r\n\r\n if FRecordPos >= FData.Count then\r\n FRecordPos := FData.Count - 1;\r\n\r\n FFileDirty := True;\r\nend;\r\n\r\n{ returns -1 if not found, else returns record index }\r\n\r\nfunction TJvCustomCsvDataSet.InternalFindByKey(Row: PCsvRow): Integer;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := -1;\r\n for I := 0 to FData.Count - 1 do\r\n if InternalCompare(FCsvKeyFields, FCsvKeyCount, {Left} Row, {Right} FData.Items[I], FAscending) = 0 then\r\n begin\r\n Result := I;\r\n Break;\r\n end;\r\nend;\r\n\r\nfunction TJvCustomCsvDataSet.FindByCsvKey(const Key: string): Boolean;\r\nvar\r\n LogicalRow, PhysicalRow: PCsvRow;\r\n I, RecNo: Integer;\r\n aStr: string;\r\nbegin\r\n Result := False;\r\n LogicalRow := PCsvRow(FData.AllocRecordBuffer);\r\n PhysicalRow := PCsvRow(FData.AllocRecordBuffer);\r\n try\r\n JvStringToCsvRow(Key + Separator, Separator, LogicalRow, False, False); // initialize row and put items in their logical order.\r\n CsvRowInit(PhysicalRow);\r\n // Move from Logical (TFieldDef order) to their physical (As found in CSV file) ordering:\r\n for I := 0 to FCsvKeyCount - 1 do\r\n begin\r\n aStr := GetCsvRowItem(LogicalRow, I);\r\n SetCsvRowItem(PhysicalRow, FCsvKeyFields[I].FPhysical, aStr);\r\n end;\r\n RecNo := InternalFindByKey(PhysicalRow);\r\n if RecNo < 0 then\r\n Exit;\r\n\r\n FRecordPos := RecNo;\r\n Resync([]);\r\n Result := True;\r\n finally\r\n FreeMem(LogicalRow);\r\n FreeMem(PhysicalRow);\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomCsvDataSet.InternalAddRecord(Buffer: TJvRecordBuffer; Append: Boolean);\r\nvar\r\n RecPos: Integer;\r\n PAddRec: PCsvRow;\r\n// KeyIndex: Integer;\r\n RowPtrText: PAnsiChar;\r\nbegin\r\n if FInsertBlocked then\r\n begin\r\n JvCsvDatabaseError(FTableName, RsEInsertBlocked);\r\n Exit;\r\n end;\r\n\r\n if FRecordPos = JvCsv_ON_BOF_CRACK then\r\n FRecordPos := 0;\r\n if FRecordPos = JvCsv_ON_EOF_CRACK then\r\n FRecordPos := FData.Count;\r\n\r\n PAddRec := PCsvRow(AllocMem(FData.GetRowAllocSize));\r\n\r\n\r\n if Buffer <> nil then\r\n Move(PCsvRow(Buffer)^, PAddRec^, FData.GetRowAllocSize)\r\n else\r\n FData.InternalInitRecord(TJvRecordBuffer(PAddRec));\r\n\r\n RowPtrText := @PAddRec^._Text[0];\r\n if RowPtrText[0] = #0 then\r\n JvStringToCsvRow(FEmptyRowStr, Separator, PAddRec, False, False); // initialize row.\r\n\r\n PAddRec^.IsDirty := RowNeedsSaving;\r\n\r\n PAddRec^.Index := -1; // Was not loaded from the file!\r\n\r\n// FData.EnquoteBackslash := EnquoteBackslash; // {finally stupidity like this is solved}\r\n\r\n FFileDirty := True;\r\n if Append then\r\n begin //this is the parameter not a TDataSet method invocation!\r\n PAddRec^.Index := FData.Count;\r\n FData.AddRow(PAddRec);\r\n InternalLast;\r\n end\r\n else\r\n begin\r\n if (FRecordPos = JvCsv_ON_EOF_CRACK) or (FRecordPos = JvCsv_ON_BOF_CRACK) then\r\n begin\r\n PAddRec^.Index := FData.Count;\r\n FData.AddRow(PAddRec);\r\n InternalLast;\r\n end\r\n else\r\n begin\r\n RecPos := FRecordPos;\r\n PAddRec^.Index := RecPos;\r\n FData.Insert(RecPos, Pointer(PAddRec));\r\n // XXX Renumber everything else.\r\n end;\r\n end;\r\nend;\r\n\r\n{ During the parsing stage only, we have the contents of the file loaded in memory\r\n as a TString LIst. This creates that TString List. }\r\n\r\nfunction TJvCustomCsvDataSet.GetFileName: string;\r\nbegin\r\n // If FTableName is not set, you can't save or load a file, fire an exception:\r\n Assert(Length(FTableName) <> 0, RsEInvalidTableName);\r\n\r\n if (Length(FTableName) > 2) and (FTableName[1] = '.') and\r\n IsPathDelimiter(FTableName, 2) then // reasonably portable, okay?\r\n // Design-time local paths that don't move if the current working\r\n // directory moves. These paths reference the directory the program\r\n // starts in. To use this at design time you have to enter the\r\n // table name as '.\\Subdirectory\\FileName.csv' (or './subdir/...' on Kylix)\r\n Result := IncludeTrailingPathDelimiter(FInitialWorkingDirectory) + FTableName // SPECIAL CASE.\r\n else\r\n Result := ExpandUNCFilename(FTableName); // Expand using current working directory to full path name. DEFAULT BEHAVIOR.\r\nend;\r\n\r\nfunction TJvCustomCsvDataSet.GetMarginSize: Integer;\r\nbegin\r\n Assert(Assigned(FData));\r\n Result := FData.MarginSize;\r\nend;\r\n\r\n{ ReadCsvFileStream:\r\n formerly InternalLoadFileStrings, which used to use a TStringLIst to load CSVs.\r\n WHich is fine for toy use, but not for real world cases like when CR/LF characters\r\n are embedded. Also, it's wasteful of memory to create a giant in-memory TStringList and then\r\n copy it to our table record objects, so now we read the disk file, and create our\r\n single set of objects, saving memory, and maybe even being faster, especially when memory\r\n is not plentiful or the CSV file being loaded is very large. }\r\nfunction TJvCustomCsvDataSet.ReadCsvFileStream: Boolean;\r\nvar\r\n Line: RawByteString;\r\nbegin\r\n Result := False;\r\n if (FTableName = '') or not FileExists(FTableName) then\r\n Exit; // We can return immediately ONLY if there is no file to load,\r\n // otherwise this routine is parsing already-loaded Data, and we should NOT\r\n // return, or we won't get our Data in the table. -WP.\r\n\r\n if FCsvFileLoaded then\r\n begin\r\n Result := True; //loaded already! just return true and quit.\r\n Exit; // don't repeat!\r\n end;\r\n\r\n FCsvFileLoaded := True;\r\n\r\n if FLoadsFromFile then \r\n begin\r\n if not Assigned(FCsvStream) then\r\n FCsvStream := TJvCsvStream.Create(FOpenFileName)\r\n else\r\n FCsvStream.Stream.Position := 0; // rewind.\r\n\r\n if FHasHeaderRow then\r\n Line := JvTrimAnsiStringCrLf(FCsvStream.ReadLine);\r\n\r\n {$IFDEF UNICODE}\r\n //-------------------------------------------------------------------------\r\n // This is the first unicode-friendly feature in JvCsvDataSet...\r\n // We can at least still open UTF8 files if they are really just ASCII\r\n // files plus a BOM marker like Windows notepad and some other apps add.\r\n //-------------------------------------------------------------------------\r\n FUtf8Detected := False; {Future.}\r\n if Length(Line) > 3 then\r\n begin\r\n // JvCsvData can detect the standard UTF-8 mark and work anyways when it is present\r\n // but cannot yet decode any special characters. This is a step on the route to proper\r\n // UTF-8 support. [uses JclUnicode.BOM_UTF8 to detect.]\r\n if (BOM_UTF8[0] = Ord(Line[1])) and\r\n (BOM_UTF8[1] = Ord(Line[2])) and\r\n (BOM_UTF8[2] = Ord(Line[3])) then\r\n begin\r\n // strip UTF-8 marker:\r\n FCsvFileTopLine := Utf8ToAnsi(Copy(Line, 4, Length(Line)));\r\n FUtf8Detected := True; {future.}\r\n end\r\n else\r\n FCsvFileTopLine := string(AnsiString(Line));\r\n end\r\n else\r\n {$ENDIF UNICODE}\r\n FCsvFileTopLine := string(AnsiString(Line));\r\n\r\n Result := True; // it worked!\r\n end;\r\nend;\r\n\r\nfunction TJvCustomCsvDataSet.WriteCsvFileStream: Boolean;\r\nbegin\r\n Result := False;\r\n if FTableName = '' then\r\n Exit; // We can return immediately ONLY if there is no file to load,\r\n // otherwise this routine is parsing already-loaded Data, and we should NOT\r\n // return, or we won't get our Data in the table. -WP.\r\n FreeAndNil(FCsvStream);\r\n FCsvStream := TJvCsvStream.Create(FOpenFileName, fmJVCSV_Truncate);\r\n Result := True; // it worked!\r\nend;\r\n\r\n\r\n{\r\nXXXX TODO: FIX ME ! XXXX\r\n\r\nDuring the parsing stage only, we have the contents of the file loaded in memory\r\n as a TString LIst. This cleans up that TString List.\r\n\r\n NOTE: After removing the TStringLIst.LoadFromFile method of loading\r\n up the CSV Data Set, this code was not needed,but at some point I need to\r\n reimplement it, which is why I didn't delete this block of commented out code.\r\n\r\n There are cases where a user of this CSV Data Set component will add fields\r\n to his CSV component, then open an old CSV file, and we want a transparent\r\n upgrade of the customer/end-user's CSV file to contain the new CSV commas. Perhaps\r\n the CSV parser/stream readline component needs to have a fixup mode?\r\n }\r\n\r\n\r\n// Add 1+ commas to FCsvFileAsStrings[1 .. Count-1]\r\n\r\n(*procedure TJvCustomCsvDataSet.AppendPlaceHolderCommasToAllRows(Strings: TStrings);\r\nvar\r\n Commas: string;\r\n I: Integer;\r\nbegin\r\n for I := 1 to AppendedFieldCount do\r\n Commas := Commas + Separator;\r\n\r\n Strings.BeginUpdate;\r\n try\r\n for I := 1 to Strings.Count - 1 do\r\n Strings[I] := Strings[I] + Commas;\r\n finally\r\n Strings.EndUpdate;\r\n end;\r\nend; *)\r\n\r\nprocedure TJvCustomCsvDataSet.InternalOpen;\r\nvar\r\n AppendStr: string;\r\n CsvLine: RawByteString;\r\n Counter: Integer;\r\n csvFileExists: Boolean;\r\nbegin\r\n if FCursorOpen then\r\n InternalClose; // close first!\r\n\r\n Counter := 0;\r\n\r\n FFileDirty := False;\r\n if FLoadsFromFile then\r\n begin\r\n if FTableName = '' then\r\n JvCsvDatabaseError(RsENoTableName, RsETableNameRequired);\r\n\r\n FOpenFileName := GetFileName; // Always use the same file name to save as you did to load!!! MARCH 2004.WP\r\n end\r\n else\r\n FOpenFileName := '';\r\n\r\n // Create TField components when no persistent fields have been created\r\n if DefaultFields then\r\n CreateFields // InternalInitFieldDefs is called inside\r\n else\r\n InternalInitFieldDefs; // initialize FieldDef objects.\r\n\r\n BindFields(True); // bind FieldDefs to actual Data\r\n\r\n if FCsvColumns.Count > 1 then\r\n begin\r\n // Create a null terminated string which is just a bunch of commas:\r\n SetLength(FEmptyRowStr, FCsvColumns.Count - 1);\r\n // When adding an empty row, we add this string as the ascii equivalent:\r\n FillNativeChar(FEmptyRowStr[1], FCsvColumns.Count - 1, Separator);\r\n end\r\n else\r\n FEmptyRowStr := ''; // nothing.\r\n\r\n FRecordPos := JvCsv_ON_BOF_CRACK; // initial record pos before BOF\r\n BookmarkSize := SizeOf(Integer);\r\n // initialize bookmark size for VCL (Integer uses 4 bytes on 32 bit operating systems)\r\n\r\n csvFileExists := False;\r\n try\r\n if FLoadsFromFile then // ReadCsvFileStream:Creates file stream and start reading it. Sets FCsvFileTopLine.\r\n csvFileExists := ReadCsvFileStream;\r\n\r\n if FHasHeaderRow then\r\n begin\r\n if csvFileExists and not ExtendedHeaderInfo and (FCsvFileTopLine <> '') then\r\n FHeaderRow := FCsvFileTopLine\r\n else\r\n begin\r\n FHeaderRow := GetColumnsAsString; // creating a new file! set up HeaderRow\r\n FCsvFileTopLine := FHeaderRow;\r\n end;\r\n\r\n if FHeaderRow <> '' then\r\n try\r\n ProcessCsvHeaderRow;\r\n except\r\n FHeaderRow := '';\r\n FreeAndNil(FCsvStream);\r\n raise;\r\n end;\r\n\r\n if FAppendedFieldCount > 0 then\r\n begin\r\n SetLength(AppendStr, FAppendedFieldCount);\r\n FillNativeChar(AppendStr[1], FAppendedFieldCount, Separator);\r\n end;\r\n end;\r\n\r\n // Load rows from disk to memory, using Stream object to read line by line.\r\n if FLoadsFromFile and Assigned(FCsvStream) then\r\n begin\r\n while not FCsvStream.Eof do\r\n begin\r\n CsvLine := JvTrimAnsiStringCrLf(FCsvStream.ReadLine);// leading space, trailing space and crlf are removed by Trim!\r\n if CsvLine <> '' then\r\n begin\r\n if (FSpecialDataMarker <> '')\r\n and (Pos(FSpecialDataMarker, CsvLine) = 1)\r\n and Assigned(FOnSpecialData) then\r\n begin\r\n // This very rarely used feature should\r\n // probably be removed from the JVCL? -WPostma.\r\n FOnSpecialData(Self, Counter, CsvLine);\r\n end\r\n else\r\n begin\r\n // Process the row:\r\n {$IFDEF UNICODE}\r\n if FUtf8Detected then\r\n ProcessCsvDataRow(Utf8ToAnsi(CsvLine), Counter)\r\n else\r\n {$ENDIF UNICODE}\r\n ProcessCsvDataRow(string(AnsiString(CsvLine)), Counter);\r\n Inc(Counter);\r\n end;\r\n end;\r\n end; {while}\r\n end;{if}\r\n if Active then\r\n First;\r\n FCursorOpen := True;\r\n except\r\n FCsvFileLoaded := False;\r\n raise;\r\n end;\r\n\r\n { clean up stream object }\r\n FreeAndNil(FCsvStream);\r\nend;\r\n\r\nprocedure TJvCustomCsvDataSet.InternalPost;\r\nvar\r\n PInsertRec: PCsvRow;\r\n RecPos: Integer;\r\n KeyIndex: Integer; // If unique key enforcement is on, this is the key search Result.\r\nbegin\r\n if FRecordPos = JvCsv_ON_BOF_CRACK then\r\n FRecordPos := 0;\r\n if FRecordPos = JvCsv_ON_EOF_CRACK then\r\n FRecordPos := FData.Count;\r\n\r\n if FPostBlocked then\r\n begin\r\n JvCsvDatabaseError(FTableName, RsEPostingHasBeenBlocked);\r\n Exit;\r\n end;\r\n\r\n { Unique Key Enforcement : WARNING This doesn't exactly work correctly right now! - WP APRIL 2004.}\r\n if FCsvUniqueKeys then\r\n begin\r\n KeyIndex := InternalFindByKey(PCsvRow(ActiveBuffer));\r\n // If posting an update, KeyIndex better be <0 or else equal to FRecordPos!\r\n // Otherwise, if adding, KeyIndex better be <0.\r\n\r\n if KeyIndex >= 0 then\r\n if ((State = dsInsert) and {XXX NEW}(FRecordPos < RecordCount)) or\r\n ((State = dsEdit) and (KeyIndex <> FRecordPos)) then\r\n begin\r\n raise EJvCsvKeyError.CreateResFmt(@RsEKeyNotUnique, [FTableName]);\r\n end;\r\n end;\r\n\r\n if State = dsEdit then\r\n begin\r\n FFileDirty := True;\r\n RecPos := FRecordPos;\r\n Move(PCsvRow(ActiveBuffer)^, FData.GetRowPtr(RecPos)^, FData.GetRowAllocSize);\r\n FData.GetRowPtr(RecPos)^.IsDirty := RowNeedsSaving;\r\n end\r\n else\r\n if State = dsInsert then\r\n begin\r\n if FInsertBlocked then\r\n begin\r\n JvCsvDatabaseError(FTableName, RsECannotInsertNewRow);\r\n Exit;\r\n end;\r\n FFileDirty := True;\r\n PInsertRec := PCsvRow(AllocRecordBuffer);\r\n Move(PCsvRow(ActiveBuffer)^, PInsertRec^, FData.GetRowAllocSize);\r\n PInsertRec^.IsDirty := RowNeedsSaving;\r\n FData.Insert(FRecordPos, Pointer(PInsertRec));\r\n FRecordPos := FData.IndexOf(Pointer(PInsertRec));\r\n PInsertRec^.Bookmark.Data := FRecordPos;\r\n end\r\n else\r\n JvCsvDatabaseError(FTableName, RsECannotPost);\r\nend;\r\n\r\nfunction TJvCustomCsvDataSet.IsCursorOpen: Boolean;\r\nbegin\r\n // \"Cursor\" is open if Data file is open. File is open if FDataFile's\r\n // Mode includes the FileMode in which the file was open.\r\n { Result := TFileRec(FDataFile).Mode <> 0; }\r\n Result := FCursorOpen; // bogus value: Valid field definition\r\nend;\r\n\r\nfunction TJvCustomCsvDataSet.GetRecordCount: Integer;\r\nbegin\r\n if FData.Count > 0 then\r\n Result := FData.Count - FData.FilteredCount\r\n else\r\n Result := 0;\r\nend;\r\n\r\nfunction TJvCustomCsvDataSet.GetRecNo: Integer; {RecNo := FRecordPos+1}\r\nvar\r\n BufPtr: PJvMemBuffer;\r\nbegin\r\n CheckActive;\r\n\r\n // UpdateCursorPos; {FUDGE!?}\r\n\r\n{\r\n UpdateCursorPos;\r\n if (FRecordPos = -1) and (RecordCount > 0) then\r\n Result := 0 // 1 //FUDGE!?\r\n else\r\n Result := FRecordPos + 1;\r\n }\r\n\r\n if Assigned(FData) and (FData.FRecordsValid) then\r\n begin\r\n if State = dsCalcFields then\r\n BufPtr := CalcBuffer\r\n else\r\n BufPtr := ActiveBuffer;\r\n Result := (PCsvRow(BufPtr)^.Bookmark.Data); // Record number.\r\n end\r\n else\r\n Result := 0;\r\nend;\r\n\r\nprocedure TJvCustomCsvDataSet.SetRecNo(Value: Integer);\r\nbegin\r\n if (Value >= 0) and (Value <= FData.Count - 1) then\r\n begin\r\n FRecordPos := Value; {-1 XXXXXX }\r\n if RecordCount > 0 then\r\n Resync([]);\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomCsvDataSet.SetTableName(const Value: string);\r\nbegin\r\n CheckInactive; // NOTE: TABLE MUST BE *CLOSED* TO CHANGE THE NAME! WE RAISE EXCEPTION HERE IF OPEN.\r\n\r\n FTableName := Value;\r\n// if (ExtractFileExt(FTableName) = '') and (FTableName <> '') then\r\n// FTableName := ChangeFileExt(FTableName,'.csv');\r\n\r\n { update internal filename table }\r\n// FBmkFileName := ChangeFileExt(FTableName, '.bmk'); // bookmark file\r\nend;\r\n\r\nprocedure TJvCustomCsvDataSet.SetTextBufferSize(const Value: Integer);\r\nbegin\r\n if Active then\r\n raise Exception.Create('Can''t change memory properties on an active data set');\r\n Assert(Assigned(FData));\r\n FData.TextBufferSize := Value;\r\nend;\r\n\r\nprocedure TJvCustomCsvDataSet.EmptyTable;\r\nbegin\r\n // Erase Rows.\r\n while (FData.Count > 0) do\r\n FData.DeleteRow(FData.Count - 1);\r\n // Refresh controls.\r\n First;\r\n if FSavesChanges then\r\n DeleteFile(FOpenFileName);\r\nend;\r\n\r\n// InternalCompare of two records, of a specific field index.\r\n// INTERNAL USE ONLY METHOD:\r\n// Record comparison between two PCsvRows:\r\n// Returns 0 if Left=Right, 1 if Left>Right, -1 if Left 0.02 then\r\n Result := 1\r\n else\r\n Result := 0; // For our purposes, .02 difference or less is a match.\r\n end;\r\n else\r\n if FCsvCaseInsensitiveComparison then\r\n Result := {Ansi}CompareText(StrLeft, StrRight)\r\n else\r\n Result := CompareStr(StrLeft, StrRight);\r\n end;\r\nend;\r\n\r\n// InternalCompare of multiple fields.\r\n// INTERNAL USE ONLY METHOD:\r\n// Record comparison between two PCsvRows:\r\n// Returns 0 if Left=Right, 1 if Left>Right, -1 if Left= SortColumnCount);\r\n\r\n // null check, raise exception\r\n if (not Assigned(Left)) or (not Assigned(Right)) then\r\n JvCsvDatabaseError(FTableName, RsEInternalCompare);\r\n // now check each field:\r\n for I := 0 to SortColumnCount - 1 do\r\n begin\r\n if not Assigned(SortColumns[I]) then\r\n JvCsvDatabaseError(FTableName, RsEInternalCompare); // raise exception\r\n Result := InternalFieldCompare(SortColumns[I], Left, Right);\r\n if Result <> 0 then\r\n begin\r\n if not SortAscending[I] then // inverts comparison Result when Descending!\r\n Result := -Result;\r\n // XXX REPEAT Result := InternalFieldCompare(SortColumns[I],Left,Right);\r\n Exit; // found greater or less than condition\r\n end;\r\n end;\r\n // now we have compared all fields, and if we get here, they were all\r\n // equal, and Result is already set to 0.\r\nend;\r\n\r\nprocedure TJvCustomCsvDataSet.InternalQuickSort(SortList: PPointerList;\r\n L, R: Integer; const SortColumns: TArrayOfPCsvColumn; ACount: Integer; const SortAscending: array of Boolean);\r\nvar\r\n I, J: Integer;\r\n P, T: Pointer;\r\nbegin\r\n // TODO: optimization (median of three, insertion sort when Count < 20 etc)\r\n repeat\r\n I := L;\r\n J := R;\r\n P := SortList^[(L + R) shr 1];\r\n repeat\r\n while InternalCompare(SortColumns, ACount, SortList^[I], P, SortAscending) < 0 do\r\n Inc(I);\r\n while InternalCompare(SortColumns, ACount, SortList^[J], P, SortAscending) > 0 do\r\n Dec(J);\r\n if I <= J then\r\n begin\r\n if I <> J then\r\n begin\r\n T := SortList^[I];\r\n SortList^[I] := SortList^[J];\r\n SortList^[J] := T;\r\n end;\r\n Inc(I);\r\n Dec(J);\r\n end;\r\n until I > J;\r\n if L < J then\r\n InternalQuickSort(SortList, L, J, SortColumns, ACount, SortAscending);\r\n L := I;\r\n until I >= R;\r\nend;\r\n\r\nprocedure TJvCustomCsvDataSet.QuickSort(AList: TList; const SortColumns: TArrayOfPCsvColumn;\r\n ACount: Integer; const SortAscending: array of Boolean);\r\nbegin\r\n if (AList <> nil) and (AList.Count > 1) then\r\n InternalQuickSort({$IFDEF RTL230_UP}@{$ENDIF RTL230_UP}AList.List, 0, AList.Count - 1, SortColumns, ACount, SortAscending);\r\nend;\r\n\r\nprocedure TJvCustomCsvDataSet.Sort(const SortFields: string; Ascending: Boolean);\r\nvar\r\n// Index: array of Pointer;\r\n// swap: Pointer;\r\n SortFieldNames: array of string;\r\n SortAscending: array of Boolean;\r\n SortColumns: TArrayOfPCsvColumn;\r\n SortColumnCount: Integer;\r\n// comparison, I, U, L: Integer;\r\n I: Integer;\r\nbegin\r\n // Create an indexed list which can be sorted more easily than\r\n // doing an item swap:\r\n// L := FData.Count;\r\n// SetLength(Index, L);\r\n// for I := 0 to L - 1 do\r\n// begin\r\n// Index[I] := FData.Items[I]; // Initial values.\r\n// end;\r\n\r\n SetLength(SortFieldNames, FCsvColumns.Count);\r\n SetLength(SortAscending, FCsvColumns.Count);\r\n SortColumnCount := JvStrSplit(SortFields, Separator, {Chr(0)=No Quoting} #0, SortFieldNames, FCsvColumns.Count);\r\n SetLength(SortColumns, SortColumnCount);\r\n if (SortFields = '') or (SortColumnCount = 0) then\r\n JvCsvDatabaseError(FTableName, RsESortFailedCommaSeparated);\r\n\r\n // Now check if the fields exist, and find the pointers to the fields\r\n for I := 0 to SortColumnCount - 1 do\r\n begin\r\n SortAscending[I] := Ascending;\r\n if SortFieldNames[I] = '' then\r\n JvCsvDatabaseError(FTableName, RsESortFailedFieldNames);\r\n if SortFieldNames[I][1] = '!' then\r\n begin\r\n SortAscending[I] := not SortAscending[I];\r\n SortFieldNames[I] := Copy(SortFieldNames[I],2,Length(SortFieldNames[I]));\r\n end;\r\n SortColumns[I] := FCsvColumns.FindByName(string(SortFieldNames[I]));\r\n if not Assigned(SortColumns[I]) then\r\n JvCsvDatabaseError(FTableName, Format(RsESortFailedInvalidFieldNameInList, [SortFieldNames[I]]));\r\n end;\r\n QuickSort(FData, SortColumns, SortColumnCount, SortAscending);\r\n FFileDirty := True;\r\n First; // reposition!\r\nend;\r\n\r\n{ Support Delphi VCL TDataSetDesigner's field persistence }\r\n\r\nprocedure TJvCustomCsvDataSet.DefChanged(Sender: TObject);\r\nbegin\r\n FStoreDefs := True;\r\nend;\r\n\r\n{ Support Delphi VCL TDataSetDesigner's field persistence }\r\n\r\nfunction TJvCustomCsvDataSet.FieldDefsStored: Boolean;\r\nbegin\r\n Result := FStoreDefs and (FieldDefs.Count > 0);\r\nend;\r\n\r\nfunction TJvCustomCsvDataSet.GetCanModify: Boolean;\r\nbegin\r\n Result := not FReadOnly; // You can modify if it's NOT read only.\r\nend;\r\n\r\n{ CsvColumns dynamic array of pointers }\r\n\r\nprocedure TJvCsvColumns.AddColumn(Item: PCsvColumn);\r\nbegin\r\n Add(Pointer(Item));\r\nend;\r\n\r\nfunction TJvCsvColumns.FindByName(const FieldName: string): PCsvColumn;\r\nvar\r\n I: Integer;\r\nbegin\r\n try\r\n for I := 0 to Count - 1 do\r\n begin\r\n Result := PCsvColumn(Get(I));\r\n if Assigned(Result.FFieldDef) then\r\n // Case insensitive field name matching:\r\n if SameText(Result.FFieldDef.Name, FieldName) then\r\n Exit; //return that field was found!\r\n end;\r\n except\r\n // ignore exceptions\r\n end;\r\n Result := nil;\r\nend;\r\n\r\nfunction TJvCsvColumns.FindByFieldNo(FieldNo: Integer): PCsvColumn;\r\nvar\r\n I: Integer;\r\nbegin\r\n try\r\n for I := 0 to Count - 1 do\r\n begin\r\n Result := PCsvColumn(Get(I));\r\n if Assigned(Result) then\r\n if Assigned(Result^.FFieldDef) then\r\n if Result^.FFieldDef.FieldNo = FieldNo then\r\n Exit; //return that field was found!\r\n end;\r\n except\r\n // ignore exceptions\r\n end;\r\n Result := nil;\r\nend;\r\n\r\nprocedure TJvCsvColumns.Clear;\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := 0 to Count - 1 do\r\n FreeMem(Items[I]);\r\n inherited Clear;\r\nend;\r\n\r\n{ CsvRows: dynamic array of pointers }\r\n\r\nconstructor TJvCsvRows.Create;\r\nbegin\r\n FTextBufferSize := JvCsvDefaultTextBufferSize;\r\n FMarginSize := JvCsvDefaultMarginSize;\r\n\r\n{ DecimalSeparator:\r\n This 'US' constant value is important for backwards compatibility.\r\n DO NOT CHANGE this default, it would break people's code.\r\n}\r\n FDecimalSeparator := USDecimalSeparator;\r\nend;\r\n\r\nfunction TJvCsvRows.GetUserTag(Index: Integer): Integer;\r\nbegin\r\n if (Index < 0) or (Index >= FUserLength) then\r\n Result := 0\r\n else\r\n Result := FUserTag[Index];\r\nend;\r\n\r\nprocedure TJvCsvRows.SetUserTag(Index, Value: Integer);\r\nbegin\r\n if (Index < 0) or (Index >= Count) then\r\n Exit;\r\n\r\n if Index >= FUserLength then\r\n begin\r\n FUserLength := Index + 1;\r\n SetLength(FUserTag, FUserLength);\r\n SetLength(FUserData, FUserLength);\r\n end;\r\n FUserTag[Index] := Value;\r\nend;\r\n\r\nfunction TJvCsvRows.GetUserData(Index: Integer): Pointer;\r\nbegin\r\n if (Index < 0) or (Index >= FUserLength) then\r\n Result := nil\r\n else\r\n Result := FUserData[Index];\r\nend;\r\n\r\nprocedure TJvCsvRows.SetUserData(Index: Integer; Value: Pointer);\r\nbegin\r\n if (Index < 0) or (Index >= Count) then\r\n Exit;\r\n if Index >= FUserLength then\r\n begin\r\n FUserLength := Index + 1;\r\n SetLength(FUserTag, FUserLength);\r\n SetLength(FUserData, FUserLength);\r\n end;\r\n FUserData[Index] := Value;\r\nend;\r\n\r\nprocedure TJvCsvRows.AddRow(Item: PCsvRow);\r\nbegin\r\n Add(Pointer(Item));\r\n if Item.Filtered then\r\n Inc(FFilteredCount);\r\nend;\r\n\r\nprocedure TJvCsvRows.InsertRow(const Position: Integer; Item: PCsvRow);\r\nbegin\r\n Insert(Position, Pointer(Item));\r\n if Item.Filtered then\r\n Inc(FFilteredCount);\r\nend;\r\n\r\nprocedure TJvCsvRows.InternalInitRecord(Buffer: TJvRecordBuffer);\r\nvar\r\n RowPtr: PCsvRow;\r\n P: PByte;\r\nbegin\r\n RowPtr := PCsvRow(Buffer);\r\n RowPtr.Magic := JvCsvRowMagic;\r\n RowPtr.TextMaxLen := FTextBufferSize;\r\n RowPtr.WordFieldsAddr := (SizeOf(TJvCsvRow) - JvCsv_MINLINELENGTH) + FTextBufferSize;\r\n RowPtr.AllocSize := GetRowAllocSize;\r\n RowPtr.Separator := AnsiChar(Separator);\r\n\r\n // initialize magic in WordFields:\r\n P := Buffer;\r\n Inc(P, RowPtr.WordFieldsAddr);\r\n PJvCsvRowWordFields(P)^.Magic2 := JvCsvRowMagic2;\r\n //DebugPJvCsvRowWordFields := PJvCsvRowWordFields(P);\r\n\r\n FRecordsValid := True;\r\nend;\r\n\r\nfunction TJvCsvRows.RecordSize: Word;\r\nbegin\r\n Result := GetRowAllocSize; { - BookmarkSize??? }\r\nend;\r\n\r\nprocedure TJvCsvRows.AddRowStr(const Item: string); // convert string->TJvCsvRow\r\nvar\r\n PNewItem: PCsvRow;\r\nbegin\r\n PNewItem := PCsvRow(AllocRecordBuffer);\r\n JvStringToCsvRow(Item, Separator, PNewItem, True, FEnquoteBackslash); // decode a csv line that can contain escape sequences\r\n AddRow(PNewItem);\r\nend;\r\n\r\nfunction TJvCsvRows.AllocRecordBuffer: PJvMemBuffer;\r\nbegin\r\n Assert(FTextBufferSize >= JvCsv_MINLINELENGTH);\r\n Result := AllocMem(GetRowAllocSize); {was SizeOf(TJvCsvRow)}\r\n InternalInitRecord(Result);\r\nend;\r\n\r\nfunction TJvCsvRows.GetRowAllocSize: Integer;\r\nbegin\r\n Assert(FTextBufferSize >= JvCsv_MINLINELENGTH);\r\n Result := (SizeOf(TJvCsvRow) - JvCsv_MINLINELENGTH) + FTextBufferSize + SizeOf(TJvCsvRowWordFields) + JvCsv_MaxCalcDataOffset + FMarginSize;\r\nend;\r\n\r\nfunction TJvCsvRows.GetRowPtr(const RowIndex: Integer): PCsvRow;\r\nbegin\r\n if (RowIndex >= 0) and (RowIndex < Count) then\r\n Result := PCsvRow(Get(RowIndex)) // return pointer to a row item.\r\n else\r\n raise EJvCsvDataSetError.CreateRes(@RsECsvNoRecord); { NO Such Record }\r\nend;\r\n\r\nfunction TJvCsvRows.GetRowAnsiStr(const RowIndex: Integer): string;\r\nbegin\r\n JvCsvRowToString(GetRowPtr(RowIndex), Result);\r\nend;\r\n\r\nprocedure TJvCsvRows.SetRowStr(const RowIndex: Integer; Value: string);\r\nbegin\r\n JvStringToCsvRow(Value, Separator, GetRowPtr(RowIndex), True, FEnquoteBackslash);\r\nend;\r\n\r\nprocedure TJvCsvRows.DeleteRow(const RowIndex: Integer);\r\nvar\r\n P: Pointer;\r\nbegin\r\n if (RowIndex >= 0) and (RowIndex < Count) then\r\n begin\r\n if PCsvRow(List{$IFNDEF RTL230_UP}^{$ENDIF !RTL230_UP}[RowIndex]).Filtered then\r\n Dec(FFilteredCount);\r\n P := Items[RowIndex];\r\n if P <> nil then\r\n FreeMem(P);\r\n end;\r\n Delete(RowIndex);\r\nend;\r\n\r\nprocedure TJvCsvRows.SetARowItem(const RowIndex, ColumnIndex: Integer; Value: string);\r\nbegin\r\n SetCsvRowItem(GetRowPtr(RowIndex), ColumnIndex, Value);\r\nend;\r\n\r\nfunction TJvCsvRows.GetARowItem(const RowIndex, ColumnIndex: Integer): string;\r\nbegin\r\n Result := GetCsvRowItem(GetRowPtr(RowIndex), ColumnIndex);\r\nend;\r\n\r\nprocedure TJvCsvRows.Clear;\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := 0 to Count - 1 do\r\n FreeMem(Items[I]);\r\n FFilteredCount := 0;\r\n inherited Clear;\r\nend;\r\n\r\n{ Call this one first, then AssignFromStrings on subsequent updates only.}\r\n\r\nprocedure TJvCustomCsvDataSet.OpenWith(Strings: TStrings);\r\nbegin\r\n Active := False;\r\n if FHasHeaderRow then\r\n FHeaderRow := Strings[0];\r\n AssignFromStrings(Strings); // parse strings\r\nend;\r\n\r\nprocedure TJvCustomCsvDataSet.AppendWith(Strings: TStrings);\r\nbegin\r\n //Active := False;\r\n if FHasHeaderRow then\r\n begin\r\n FHeaderRow := Strings[0];\r\n FPendingCsvHeaderParse := True; // NEW: Just-in-time-CSV-header-parsing.\r\n end;\r\n\r\n AssignFromStrings(Strings); // parse strings\r\n // Refresh.\r\n // DataEvent(deDataSetChange, 0);\r\n // DataEvent(deRecordChange, 0);\r\n Resync([]);\r\n // DataEvent(deUpdateState, 0);\r\n if Active then\r\n Last;\r\nend;\r\n\r\n{ Additional Custom Methods - internal use }\r\n\r\nprocedure TJvCustomCsvDataSet.AssignFromStrings(Strings: TStrings);\r\nvar\r\n // HeaderRowFound: Boolean;\r\n I: Integer;\r\n StartIndex, IndexCounter: Integer;\r\nbegin\r\n // CheckInactive; // NO! DON'T DO THIS!\r\n // if NOT FFieldsInitialized then\r\n // InternalInitFieldDefs; // must know about field definitions first.\r\n if Strings = nil then\r\n Exit;\r\n// FData.EnquoteBackslash := FEnquoteBackslash; {stupidity solved}\r\n\r\n IndexCounter := 0;\r\n // Skip first Row:\r\n if FHasHeaderRow then\r\n StartIndex := 1\r\n else\r\n StartIndex := 0;\r\n\r\n for I := StartIndex to Strings.Count - 1 do\r\n begin\r\n if Assigned(FOnSpecialData) and (FSpecialDataMarker <> '') and\r\n (Pos(FSpecialDataMarker, AnsiString(Strings[I])) = 1) then\r\n begin\r\n // XXX Deprecated feature\r\n FOnSpecialData(Self, I, AnsiString(Strings[I]));\r\n end\r\n else\r\n begin\r\n // Process the row normally:\r\n ProcessCsvDataRow(Strings[I], IndexCounter);\r\n Inc(IndexCounter);\r\n end;\r\n end;\r\n if Active then\r\n First;\r\nend;\r\n\r\nprocedure TJvCustomCsvDataSet.AssignToStrings(Strings: TStrings);\r\nvar\r\n I: Integer;\r\n Line: string;\r\nbegin\r\n Strings.BeginUpdate;\r\n try\r\n // copy out the current Data set to a TStringList.\r\n Strings.Clear;\r\n\r\n { Save header row with Data rows? }\r\n if FHasHeaderRow then\r\n if ExtendedHeaderInfo then\r\n Strings.Add(CsvFieldDef)\r\n else\r\n Strings.Add(GetColumnsAsString);\r\n\r\n for I := 0 to FData.Count - 1 do\r\n begin\r\n JvCsvRowToString(FData.GetRowPtr(I), Line);\r\n Strings.Add(Line);\r\n end;\r\n finally\r\n Strings.EndUpdate;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomCsvDataSet.AppendRowString(const RowAsString: string);\r\nbegin\r\n if not Active then\r\n JvCsvDatabaseError(FTableName, RsEDataSetNotOpen);\r\n ProcessCsvDataRow(RowAsString, FData.Count);\r\n FFileDirty := True; // added row, make sure it gets saved!\r\n Last;\r\nend;\r\n\r\nfunction TJvCustomCsvDataSet.GetAsString(const Row, Column: Integer): string;\r\nvar\r\n GetIndex: Integer;\r\nbegin\r\n if Row < 0 then {lastrow}\r\n GetIndex := FData.Count - 1\r\n else\r\n GetIndex := Row; { actual index specified }\r\n\r\n { return string}\r\n Result := GetCsvRowItem(FData.GetRowPtr(GetIndex), Column);\r\nend;\r\n\r\nfunction TJvCustomCsvDataSet.CurrentRowAsString: string;\r\nbegin\r\n Result := GetRowAsString(RecNo);\r\nend;\r\n\r\nfunction TJvCustomCsvDataSet.GetRowAsString(const Index: Integer): string;\r\nvar\r\n GetIndex: Integer;\r\nbegin\r\n if Index < 0 then {lastrow}\r\n GetIndex := FData.Count - 1\r\n else\r\n GetIndex := Index; { actual index specified }\r\n\r\n { return string }\r\n JvCsvRowToString(FData.GetRowPtr(GetIndex), Result);\r\nend;\r\n\r\nfunction TJvCustomCsvDataSet.GetRowAsAnsiString(const Index: Integer): AnsiString;\r\nbegin\r\n Result := AnsiString(GetRowAsString(Index));\r\nend;\r\n\r\n// Get names of all the columns as a comma-separated string:\r\n\r\nfunction TJvCustomCsvDataSet.GetColumnsAsString: string;\r\nvar\r\n I: Integer;\r\nbegin\r\n // ColCount:\r\n if FCsvColumns.Count = 0 then\r\n begin\r\n Result := '';\r\n Exit;\r\n end;\r\n // Build a list of column names: , ,....,\r\n Result := FieldDefs[0].Name;\r\n for I := 1 to FCsvColumns.Count - 1 do\r\n Result := Result + string(Separator) + FieldDefs[I].Name;\r\nend;\r\n\r\n{ protected internal procedure - now that we have a list of fields that\r\n are supposed to exist in this dataset we have a real CSV header which we\r\n are hoping contains header information }\r\n\r\nprocedure TJvCustomCsvDataSet.ProcessCsvHeaderRow;\r\nvar\r\n CsvFieldRec: PCsvRow; // CSV Field record type.\r\n PtrCsvColumn: PCsvColumn;\r\n CsvFieldName: string;\r\n ColNum, I: Integer;\r\n ColonPos: Integer;\r\nbegin\r\n CsvFieldRec := PCsvRow(FData.AllocRecordBuffer);\r\n try\r\n if not ValidateHeaderRow then\r\n begin\r\n for I := 0 to FCsvColumns.Count - 1 do\r\n PCsvColumn(FCsvColumns[I])^.FPhysical := I;\r\n Exit;\r\n end;\r\n FAppendedFieldCount := 0;\r\n // Columns Not Yet Found:\r\n for I := 0 to FCsvColumns.Count - 1 do\r\n PCsvColumn(FCsvColumns[I])^.FPhysical := -1;\r\n\r\n // Do initial parse.\r\n JvStringToCsvRow(FHeaderRow, Separator, CsvFieldRec, False, False);\r\n ColNum := 0;\r\n while CsvRowGetColumnMarker(CsvFieldRec, ColNum) <> JvCsv_COLUMN_ENDMARKER do\r\n begin\r\n // Get a string in the format COLUMNAME:Options\r\n CsvFieldName := JvTrimStringCrLf(StrEatWhiteSpace(GetCsvRowItem(CsvFieldRec, ColNum))); // Where did #A come from?\r\n\r\n // Mantis 3192: Remove the options from the field name or FindByName will\r\n // never find the column which will lead to a Database error being triggered\r\n ColonPos := Pos(':', CsvFieldName);\r\n if (ColonPos > 0) then\r\n CsvFieldName := Copy(CsvFieldName, 1, ColonPos - 1);\r\n\r\n if CsvFieldName = '' then\r\n JvCsvDatabaseError(FTableName, RsEErrorProcessingFirstLine);\r\n\r\n PtrCsvColumn := FCsvColumns.FindByName(CsvFieldName);\r\n\r\n if PtrCsvColumn = nil then\r\n begin // raise database exception:\r\n JvCsvDatabaseError(FTableName, Format(RsEFieldInFileButNotInDefinition, [CsvFieldName]));\r\n Exit;\r\n end;\r\n\r\n try\r\n PtrCsvColumn^.FPhysical := ColNum; // numbered from 0.\r\n except\r\n JvCsvDatabaseError(FTableName, Format(RsECsvFieldLocationError, [CsvFieldName]));\r\n Break;\r\n end;\r\n Inc(ColNum);\r\n end; // loop for each column in the physical file's header row.\r\n\r\n // Check that everything was found and physically given a location\r\n // in the CSV file:\r\n for I := 0 to FCsvColumns.Count - 1 do\r\n begin\r\n PtrCsvColumn := PCsvColumn(FCsvColumns[I]);\r\n if PtrCsvColumn^.FPhysical < 0 then\r\n begin\r\n if not FHasHeaderRow then\r\n begin\r\n // If there is no header row we can't cope with fields that aren't in the file\r\n // because FCsvHeader is not written into the file, so we can't just go expanding\r\n // what goes into that file.\r\n JvCsvDatabaseError(FTableName, Format(RsEFieldNotFound, [PtrCsvColumn^.FFieldDef.Name]));\r\n Exit;\r\n // Now go fix the CSV file by hand until it matches your new CSVFieldDef.\r\n // Sounds like not much fun, eh?\r\n end\r\n else\r\n begin\r\n //-------------------------------------------------------\r\n // New HANDY DANDY Instant Import Feature\r\n // APPEND-NEW-FIELDS-to-Existing-CSV file BEHAVIOUR.\r\n // When Triggered, the end user can tell because we have a\r\n // new property AppendedFieldCount which will be nonzero.\r\n // If we continue, we can use this opportunity to\r\n // import an existing CSV file that can now 'upgraded'\r\n // in memory (to contain new fields we just added to our\r\n // field definitions).\r\n //-------------------------------------------------------\r\n PtrCsvColumn^.FPhysical := ColNum;\r\n Inc(ColNum);\r\n CsvFieldName := PtrCsvColumn^.FFieldDef.Name;\r\n FHeaderRow := FHeaderRow + Separator + CsvFieldName;\r\n Inc(FAppendedFieldCount);\r\n end;\r\n end;\r\n end;\r\n finally\r\n FreeMem(CsvFieldRec);\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomCsvDataSet.ProcessCsvDataRow(const DataRow: string; Index: Integer);\r\nvar\r\n PNewRow: PCsvRow;\r\nbegin\r\n if DataRow = '' then\r\n Exit;\r\n if Length(DataRow) >= JvCsv_MAXLINELENGTH - 1 then\r\n raise EJvCsvDataSetError.CreateResFmt(@RsECsvStringTooLong, [Copy(DataRow, 1, 40)]);\r\n PNewRow := PCsvRow(AllocRecordBuffer);\r\n JvStringToCsvRow(DataRow, Separator, PNewRow, True, EnquoteBackslash);\r\n PNewRow^.Index := Index;\r\n FData.AddRow(PNewRow);\r\nend;\r\n\r\nprocedure TJvCustomCsvDataSet.AutoCreateDir(const FileName: string);\r\nvar\r\n Path: string;\r\nbegin\r\n if CreatePaths then\r\n begin\r\n Path := ExtractFilePath(FileName);\r\n if Path <> '' then\r\n if not DirectoryExists(Path) then\r\n ForceDirectories(Path);\r\n end;\r\nend;\r\n\r\n{ This function is handy to save a portion of a csv table that has\r\ngrown too large into a file, and then DeleteRows can be called to remove\r\nthat section of the file. }\r\n\r\nprocedure TJvCustomCsvDataSet.ExportRows(const FileName: string; FromRow, ToRow: Integer);\r\nvar\r\n I: Integer;\r\n StrList: TStringList;\r\nbegin\r\n StrList := TStringList.Create;\r\n StrList.Add(string(FHeaderRow));\r\n try\r\n for I := FromRow to ToRow do\r\n StrList.Add(string(FData.GetRowAnsiStr(I)));\r\n AutoCreateDir(FileName);\r\n StrList.SaveToFile(FileName);\r\n finally\r\n StrList.Free;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomCsvDataSet.DeleteRows(FromRow, ToRow: Integer);\r\nvar\r\n Count: Integer;\r\nbegin\r\n Count := (ToRow - FromRow) + 1;\r\n while Count > 0 do\r\n begin\r\n if FromRow < FData.Count then\r\n FData.DeleteRow(FromRow) // Everything moves down one every time we do this.\r\n else\r\n Break;\r\n Dec(Count);\r\n end;\r\n // Force Redraw of Data Controls:\r\n if FRecordPos >= FData.Count then\r\n begin\r\n FRecordPos := FData.Count - 1;\r\n Last;\r\n end\r\n else\r\n First;\r\n FFileDirty := True;\r\nend;\r\n\r\nprocedure TJvCustomCsvDataSet.ExportCsvFile(const FileName: string); // save out to a file.\r\nvar\r\n Strings: TStringList;\r\nbegin\r\n Strings := TStringList.Create;\r\n try\r\n AssignToStrings(Strings);\r\n AutoCreateDir(FileName);\r\n Strings.SaveToFile(FileName);\r\n finally\r\n Strings.Free;\r\n end;\r\nend;\r\n\r\n{ GetCsvHeader:\r\n\r\n XXX Normally you don't need to call this function, if you\r\n have already opened the file, then use the HeaderRow\r\n property instead!\r\n\r\n This routine loads just the first line of a CSV file\r\n from the disk. This way you can peek at a CSV file, get\r\n the first line, parse it or do something else with it, before\r\n you decide if you want this component to open the rest\r\n of the file.\r\n}\r\nfunction TJvCustomCsvDataSet.GetCsvHeader: string;\r\nvar\r\n F: Text;\r\n FirstLine: string;\r\nbegin\r\n if not FLoadsFromFile or not FHasHeaderRow or not FileExists(FTableName) then\r\n begin\r\n Result := '';\r\n Exit;\r\n end;\r\n\r\n { XXX THIS Set of code sometimes FAILS randomly on Delphi 2007\r\n when applications are running on Vista. TODO: REWRITE using\r\n streams, get rid of all AssignFile/Reset/ReadLn(file) code! }\r\n { How's this for an ancient Pascal code sequence, AssignFile+Reset is approximately equal to a C fopen() call }\r\n AssignFile(F, FTableName);\r\n Reset(F);\r\n { ReadLn is approximately a gets() call }\r\n ReadLn(F, FirstLine);\r\n { And finally, the pascal file close procedure }\r\n CloseFile(F);\r\n\r\n // return the first line of the file, without the junk\r\n Result := JvStrStrip(FirstLine); // in JvCsvParse.pas\r\nend;\r\n\r\nfunction TJvCustomCsvDataSet.GetDecimalSeparator: Char;\r\nbegin\r\n Result := FData.DecimalSeparator;\r\nend;\r\n\r\n{ PROCEDURES: }\r\n\r\n// convert CSV Row buffer to a single-byte AnsiString\r\nprocedure JvCsvRowToAnsiString(RowItem: PCsvRow; var RowString: AnsiString);\r\nvar\r\n RowStr: string;\r\nbegin\r\n JvCsvRowToString(RowItem, RowStr);\r\n RowString := AnsiString(RowStr);\r\nend;\r\n\r\nprocedure JvCsvRowToString(RowItem: PCsvRow; var RowString: string);\r\nvar\r\n P: PAnsiChar;\r\nbegin\r\n p := @RowItem^._Text[0];\r\n {$IFDEF COMPILER12_UP}\r\n RowString := Utf8ToAnsi(P);\r\n {$ELSE}\r\n RowString := P;\r\n {$ENDIF COMPILER12_UP}\r\nend;\r\n\r\n//JvCsvRowDeleteColumn: NEW 2007\r\n// used by TJvCustomCsvDataSet.DeleteCsvColumn...\r\n// delete a column from a PCsvRow object:\r\nfunction JvCsvRowDeleteColumn(RowItem: PCsvRow; Column, Count: Integer): RawByteString;\r\nvar\r\n From1, From2: Integer;\r\n To1, To2: Integer;\r\n RowItemText: PAnsiChar;\r\nbegin\r\n Assert(Column >= 0);\r\n RowItemText := @RowItem^._Text[0];\r\n if (Column > 0) and (Column < Count - 1) then\r\n begin\r\n { del middle Column}\r\n From1 := 0;\r\n To1 := CsvRowGetColumnMarker(RowItem, Column) - 1; //RowItem^.WordField[Column];\r\n From2 := CsvRowGetColumnMarker(RowItem, Column + 1); //RowItem^.WordField[Column];\r\n To2 := CsvRowGetColumnMarker(RowItem, Count);\r\n\r\n Result := Copy(RowItemText, From1, To1) + Copy(RowItemText, From2, To2);\r\n end else\r\n if Column= Count - 1 then\r\n begin\r\n {del last Column}\r\n From1 := 0;\r\n To1 := CsvRowGetColumnMarker(RowItem, Column)-1;\r\n Result := Copy(RowItemText,From1,To1);\r\n end else\r\n begin\r\n {del first Column }\r\n From1 := CsvRowGetColumnMarker(RowItem, Column + 1) + 1; //RowItem^.WordField[Column];\r\n To1 := CsvRowGetColumnMarker(RowItem, Count);\r\n Result := Copy(RowItemText, From1, To1);\r\n end;\r\nend;\r\n\r\n// convert string into a CSV Row buffer\r\nprocedure JvAnsiStringToCsvRow(const RowString: RawByteString; Separator: AnsiChar;\r\n RowItem: PCsvRow; PermitEscapeSequences, EnquoteBackslash: Boolean);\r\nvar\r\n I, L, Col: Integer;\r\n QuoteFlag: Boolean;\r\n SkipFlag: Boolean;\r\n// CharsInColumn: Integer; { was part of validating that row did not exceed limits}\r\n WordFields: PJvCsvRowWordFields;\r\n RowItemText: PAnsiChar;\r\nbegin\r\n Assert(Assigned(RowItem));\r\n Assert(RowItem^.Magic = JvCsvRowMagic, 'Internal data corruption in JvCsvRow data storage area');\r\n Col := 0;\r\n WordFields := GetWordFields(RowItem);\r\n WordFields.WordField[0] := 0; // zero out column marker and dirty bit!\r\n// CharsInColumn := 0;\r\n QuoteFlag := False;\r\n SkipFlag := False;\r\n L := Length(RowString);\r\n for I := 1 to L do\r\n begin\r\n //Inc(CharsInColumn);\r\n if QuoteFlag then\r\n begin\r\n // backslash permitted only if specifically enabled by FEnquoteBackslash:\r\n if PermitEscapeSequences and not SkipFlag and EnquoteBackslash and (RowString[I] = '\\') then\r\n begin\r\n SkipFlag := True;\r\n Continue;\r\n end;\r\n // doubled quotes handling:\r\n if PermitEscapeSequences and not SkipFlag and (RowString[I] = '\"') and\r\n (I < L) and (RowString[I + 1] = '\"') then\r\n begin\r\n SkipFlag := True;\r\n Continue;\r\n end;\r\n // now if either of the above set the SkipFlag True previously, we ALWAYS skip the next character here\r\n // and turn SkipFlag back off\r\n if PermitEscapeSequences and SkipFlag then\r\n begin // skip next character, regardless.\r\n SkipFlag := False;\r\n Continue; // by skipping escaped quotes, we don't turn off QuoteFlag in the middle of a string!\r\n end;\r\n end;\r\n // Now we know if we get this far, we are NOT dealing with any escaped characters\r\n // Any quotes we see here will turn on/off quote mode directly!\r\n if RowString[I] = '\"' then\r\n if PermitEscapeSequences then\r\n QuoteFlag := not QuoteFlag;\r\n\r\n if (RowString[I] = Separator) and not QuoteFlag then\r\n begin\r\n Inc(Col);\r\n // implicitly set Length (low 15 bits) and clear dirty bit (high bit):\r\n WordFields.WordField[Col] := (Word(I) and $7FFF); {note that we're going from 1..length }\r\n //CharsInColumn := 0;\r\n end;\r\n if (Col >= JvCsv_MAXCOLUMNS) or (I >= JvCsv_MAXLINELENGTH) then\r\n raise ERangeError.CreateResFmt(@RsEInternalLimit, [JvCsv_MAXCOLUMNS]);\r\n end; // end of string, new flag:\r\n Inc(Col);\r\n\r\n { if we were tracking it, we could check CharsInColumn not too large, here? }\r\n\r\n WordFields.WordField[Col] := JvCsv_COLUMN_ENDMARKER; // last one has no end marker\r\n RowItemText := @RowItem._Text[0];\r\n StrLCopy(RowItemText, PAnsiChar(RowString), RowItem.TextMaxLen);\r\n\r\n RowItem.Columns := Col; // Check this later!\r\nend;\r\n\r\nprocedure JvStringToCsvRow(const RowString: string; Separator: Char;\r\n RowItem: PCsvRow; PermitEscapeSequences, EnquoteBackslash: Boolean);\r\nbegin\r\n {$IFDEF COMPILER12_UP}\r\n JvAnsiStringToCsvRow(AnsiToUtf8(RowString), AnsiChar(Separator), RowItem, PermitEscapeSequences, EnquoteBackslash);\r\n {$ELSE}\r\n JvAnsiStringToCsvRow(RowString, Separator, RowItem, PermitEscapeSequences, EnquoteBackslash);\r\n {$ENDIF COMPILER12_UP}\r\nend;\r\n\r\n// Copy a single column from one row buffer to another row buffer:\r\n\r\nfunction CsvRowItemCopy(Source, Dest: PCsvRow; FieldIndex, FieldSize: Integer): Boolean;\r\nvar\r\n TempStr: RawByteString;\r\nbegin\r\n TempStr := GetCsvRowItemData(Source, FieldIndex);\r\n // length limiting feature:\r\n if FieldSize > 0 then\r\n if Length(TempStr) > FieldSize then\r\n TempStr := Copy(TempStr, 1, FieldSize);\r\n SetCsvRowItemData(Dest, FieldIndex, TempStr);\r\n Result := True;\r\nend;\r\n\r\n// Copy an item into a csv row buffer:\r\n\r\nprocedure SetCsvRowItem(PItem: PCsvRow; ColumnIndex: Integer; const NewValue: string);\r\nbegin\r\n {$IFDEF COMPILER12_UP}\r\n SetCsvRowItemData(PItem, ColumnIndex, AnsiToUtf8(NewValue));\r\n {$ELSE}\r\n SetCsvRowItemData(PItem, ColumnIndex, AnsiString(NewValue));\r\n {$ENDIF COMPILER12_UP}\r\nend;\r\n\r\nprocedure SetCsvRowItemData(PItem: PCsvRow; ColumnIndex: Integer; const NewValue: RawByteString);\r\nvar\r\n TempBuf, RowItemText: PAnsiChar;\r\n Copy1, Copy2: Integer;\r\n Diff, I, Old: Integer;\r\nbegin\r\n Assert(Assigned(PItem));\r\n Assert(PItem^.Magic = JvCsvRowMagic);\r\n Assert(PItem^.TextMaxLen>0);\r\n Assert(PItem^.Separator<>Chr(0));\r\n Diff := 0;\r\n if (ColumnIndex < 0) or (ColumnIndex > JvCsv_MAXCOLUMNS) then\r\n Exit;\r\n RowItemText := @PItem^._Text[0];\r\n Copy1 := CsvRowGetColumnMarker(PItem, ColumnIndex);\r\n if Copy1 = JvCsv_COLUMN_ENDMARKER then\r\n begin\r\n // Fix CSV damage:\r\n StrLCat(RowItemText, @(PItem^.Separator), Length(RowItemText) + 1); // XXX todo later: Make sure we add however many commas or whatever are needed!\r\n Copy1 := StrLen(RowItemText);\r\n CsvRowSetColumnMarker(PItem, ColumnIndex, Copy1);\r\n end;\r\n // Update new rows: FIX previous fix!\r\n if (ColumnIndex >= PItem^.Columns) then\r\n PItem^.Columns := ColumnIndex+1;\r\n\r\n if Copy1 > JvCsv_MAXLINELENGTH then\r\n Exit;\r\n // copy initial part of the csv row:\r\n\r\n TempBuf := AllocMem(PItem^.TextMaxLen + 1);\r\n try\r\n if Copy1 > 0 then\r\n begin\r\n StrLCopy(TempBuf, RowItemText, Copy1);\r\n StrLCat(TempBuf, PAnsiChar(NewValue), PItem^.TextMaxLen);\r\n end\r\n else\r\n StrLCopy(TempBuf, PAnsiChar(NewValue), PItem^.TextMaxLen);\r\n\r\n Copy2 := CsvRowGetColumnMarker(PItem, ColumnIndex + 1);\r\n if Copy2 <> JvCsv_COLUMN_ENDMARKER then\r\n begin\r\n // difference in length:\r\n Dec(Copy2); // subtract one.\r\n if Copy2 < 0 then\r\n Exit;\r\n if Length(NewValue) = Copy2 - Copy1 then\r\n Diff := 0\r\n else\r\n Diff := Length(NewValue) - (Copy2 - Copy1);\r\n StrLCat(TempBuf, RowItemText + Copy2, PItem^.TextMaxLen);\r\n end;\r\n\r\n // Copy over the old memory buffer:\r\n StrLCopy(RowItemText, TempBuf, PItem^.TextMaxLen);\r\n\r\n // Now that we've copied a new item of a different length into the place of the old one\r\n // we have to update the positions of the columns after ColumnIndex:\r\n if Diff <> 0 then\r\n for I := ColumnIndex + 1 to JvCsv_MAXCOLUMNS do\r\n begin\r\n Old := CsvRowGetColumnMarker(PItem, I);\r\n if Old = JvCsv_COLUMN_ENDMARKER then\r\n Exit;\r\n CsvRowSetColumnMarker(PItem, I, Old + Diff);\r\n end;\r\n\r\n finally\r\n FreeMem(TempBuf);\r\n end;\r\nend;\r\n\r\n// Copy an item out of a csv row buffer:\r\n\r\nfunction GetCsvRowItem(PItem: PCsvRow; ColumnIndex: Integer): string;\r\nbegin\r\n {$IFDEF COMPILER12_UP}\r\n Result := Utf8ToAnsi(GetCsvRowItemData(PItem, ColumnIndex));\r\n {$ELSE}\r\n Result := GetCsvRowItemData(PItem, ColumnIndex);\r\n {$ENDIF COMPILER12_UP}\r\nend;\r\n\r\nfunction GetCsvRowItemData(PItem: PCsvRow; ColumnIndex: Integer): RawByteString;\r\nvar\r\n TempBuf: PAnsiChar;\r\n Copy1, Copy2: Integer;\r\n OutText: PAnsiChar;\r\nbegin\r\n Result := '';\r\n if (ColumnIndex < 0) or (ColumnIndex > JvCsv_MAXCOLUMNS) then\r\n Result := AnsiString(RsErrorRowItem)\r\n else\r\n if ColumnIndex < PItem^.Columns then\r\n begin\r\n Copy1 := CsvRowGetColumnMarker(PItem, ColumnIndex);\r\n Copy2 := CsvRowGetColumnMarker(PItem, ColumnIndex + 1);\r\n if (Copy1 <> JvCsv_COLUMN_ENDMARKER) and (Copy1 > Copy2) then\r\n raise Exception.Create('GetCsvRowItemData: Column index values are corrupt.');\r\n\r\n if Copy1 <> JvCsv_COLUMN_ENDMARKER then\r\n begin\r\n if Copy2 = JvCsv_COLUMN_ENDMARKER then // copy the rest of the line\r\n Copy2 := JvCsv_MAXLINELENGTH - Copy1 // All the characters left in the buffer\r\n else\r\n Dec(Copy2);\r\n\r\n if (Copy1 <= JvCsv_MAXLINELENGTH) and (Copy2 <= JvCsv_MAXLINELENGTH) then\r\n begin\r\n // Copy out just one column from the string:\r\n TempBuf := AllocMem(PItem^.TextMaxLen);\r\n try\r\n OutText := @PItem^._Text[0];\r\n Inc(OutText, Copy1);\r\n StrLCopy(TempBuf, OutText, Copy2 - Copy1);\r\n JvEatWhitespaceChars(PAnsiChar(@TempBuf[0]));\r\n Result := TempBuf;\r\n finally\r\n FreeMem(TempBuf);\r\n end;\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\n{new}\r\n\r\nprocedure CsvRowSetDirtyBit(Row: PCsvRow; ColumnIndex: Integer);\r\nvar\r\n WordFields:PJvCsvRowWordFields;\r\nbegin\r\n if Row = nil then\r\n Exit;\r\n if (ColumnIndex < 0) or (ColumnIndex >= JvCsv_MAXCOLUMNS) then\r\n Exit;\r\n WordFields := GetWordFields(Row);\r\n Row^.IsDirty := RowNeedsSaving; // triggers search for 'dirty bit' in columns\r\n WordFields.WordField[ColumnIndex] := (WordFields.WordField[ColumnIndex] or $8000);\r\nend;\r\n\r\nprocedure CsvRowClearDirtyBit(Row: PCsvRow; ColumnIndex: Integer);\r\nvar\r\n WordFields:PJvCsvRowWordFields;\r\nbegin\r\n if Row = nil then\r\n Exit;\r\n if (ColumnIndex < 0) or (ColumnIndex >= JvCsv_MAXCOLUMNS) then\r\n Exit;\r\n WordFields := GetWordFields(Row);\r\n WordFields.WordField[ColumnIndex] := (WordFields.WordField[ColumnIndex] and $7FFF);\r\nend;\r\n\r\nfunction CsvRowGetDirtyBit(Row: PCsvRow; ColumnIndex: Integer): Boolean;\r\nvar\r\n WordFields:PJvCsvRowWordFields;\r\nbegin\r\n Result := False;\r\n if Row = nil then\r\n Exit;\r\n if (ColumnIndex < 0) or (ColumnIndex >= JvCsv_MAXCOLUMNS) then\r\n Exit;\r\n WordFields := GetWordFields(Row);\r\n if WordFields.WordField[ColumnIndex] = JvCsv_COLUMN_ENDMARKER then\r\n Exit;\r\n Result := (WordFields.WordField[ColumnIndex] and $8000) <> 0;\r\nend;\r\n\r\nprocedure CsvRowSetColumnMarker(Row: PCsvRow; ColumnIndex: Integer; ColumnMarker: Integer);\r\nvar\r\n Old: Word;\r\n WordFields:PJvCsvRowWordFields;\r\nbegin\r\n if Row = nil then\r\n Exit;\r\n if (ColumnIndex < 0) or (ColumnIndex >= JvCsv_MAXCOLUMNS) then\r\n Exit;\r\n if ColumnMarker < 0 then\r\n Exit;\r\n WordFields := GetWordFields(Row);\r\n\r\n if ColumnMarker = JvCsv_COLUMN_ENDMARKER then\r\n WordFields.WordField[ColumnIndex] := JvCsv_COLUMN_ENDMARKER\r\n else\r\n begin\r\n Old := WordFields.WordField[ColumnIndex];\r\n if Old = JvCsv_COLUMN_ENDMARKER then\r\n WordFields.WordField[ColumnIndex] := ColumnMarker and $7FFF // auto-clear Dirty bit\r\n else\r\n WordFields.WordField[ColumnIndex] := (Old and $8000) or // Keep Old Dirty Bit\r\n (Word(ColumnMarker) and $7FFF); // new value.\r\n end;\r\n //DebugPJvCsvRowWordFields := WordFields;\r\nend;\r\n\r\nfunction CsvRowGetColumnMarker(Row: PCsvRow; ColumnIndex: Integer): Integer;\r\nvar\r\n W: Word;\r\n WordFields:PJvCsvRowWordFields;\r\nbegin\r\n Result := -1;\r\n if Row = nil then\r\n Exit;\r\n if (ColumnIndex < 0) or (ColumnIndex >= JvCsv_MAXCOLUMNS) then\r\n Exit;\r\n WordFields := GetWordFields(Row);\r\n W := WordFields^.WordField[ColumnIndex];\r\n if W = JvCsv_COLUMN_ENDMARKER then\r\n Result := JvCsv_COLUMN_ENDMARKER\r\n else\r\n Result := Integer(W and $7FFF);\r\nend;\r\n\r\n{endnew}\r\n\r\n //------------------------------------------------------------------------------\r\n // TimeTHexToDateTime\r\n //\r\n // The Delphi TDateTime format is a whole number representing days since Dec 30, 1899.\r\n // Whereas the TIME_T type is a standard C library time representing seconds since\r\n // 12:00 UTC on Jan 1 1970.\r\n //\r\n // We accept the hex encoded TIME_T and convert it to a TDateTime by getting\r\n // the base date (Jan 1, 1970) and adding 1 for every day since then, and\r\n // a fractional part representing the seconds. By dividing the seconds\r\n // by the number of seconds in a day (24*24*60=86400) we obtain this Result.\r\n //\r\n // The incoming value in hex will roll over in mid-Janary 2038, and\r\n // hopefully by then this code won't be in use any more! :-)\r\n //\r\n // Note: TDateTime is really a Double floating-point and zero is considered\r\n // an invalidate date indicator. (on screen this appears as 1899/nn/nn\r\n //------------------------------------------------------------------------------\r\n\r\nfunction JvTimeTHexToDateTime(const HexStr: string; TimeZoneCorrection: Integer): TDateTime;\r\nvar\r\n SecondsSince1970: Double;\r\n Base: TDateTime;\r\n { DateTimeAsStr: string; //debug Code.}\r\nbegin\r\n Result := 0.0;\r\n SecondsSince1970 := StrToIntDef('$' + HexStr, 0) + TimeZoneCorrection;\r\n if SecondsSince1970 <= 0.0 then\r\n Exit;\r\n Base := EncodeDate(1970, 1, 1);\r\n Base := Base + (SecondsSince1970 / 86400.0);\r\n { DateTimeAsStr := FormatDateTime('yyyy/mm/dd hh:nn:ss',Base);}\r\n // Inc(CallCount);\r\n Result := Base;\r\nend;\r\n\r\n// JvIsoDateTimeStrToDateTime [formerly TimeTAsciiToDateTime]\r\nfunction JvIsoDateTimeStrToDateTime(const AsciiDateTimeStr: string): TDateTime;\r\nconst\r\n Separators = '// ::'; // separators in yyyy/mm/dd hh:mm:ss\r\n Separators2 = '-- --'; // separators in yyyy/mm/dd hh:mm:ss\r\nvar\r\n Values: array [1..6] of Integer; //year,month,day,hour,minute,second in that order.\r\n Ch: Char;\r\n I, U, Len, Index: Integer;\r\nbegin\r\n Result := 0.0; // default Result.\r\n Len := Length(AsciiDateTimeStr);\r\n\r\n // validate ranges:\r\n for I := 1 to 6 do\r\n Values[I] := 0;\r\n\r\n // T loops through each value we are looking for (1..6):\r\n Index := 1; // what character in AsciiDateTimeStr are we looking at?\r\n for I := 1 to 6 do\r\n begin\r\n if (I >= 3) and (Index >= Len) then\r\n Break; // as long as we at least got the date, we can continue.\r\n for U := 1 to AsciiTime_ExpectLengths[I] do\r\n begin\r\n if Index > Len then\r\n Break;\r\n Ch := AsciiDateTimeStr[Index];\r\n if not ((Ch <= #255) and (AnsiChar(Ch) in DigitSymbols)) then\r\n begin\r\n //could raise exception here:\r\n //illegal character in datetime string\r\n Exit; // failed: invalid character.\r\n end;\r\n Values[I] := (Values[I] * 10) + (Ord(Ch) - Ord('0'));\r\n Inc(Index);\r\n\r\n if Index > Len then\r\n Break;\r\n end;\r\n\r\n // if we haven't reached the end of the string, then\r\n // check for a valid separator character:\r\n if Index < Len then\r\n if (AsciiDateTimeStr[Index] <> Separators[I]) and\r\n (AsciiDateTimeStr[Index] <> Separators2[I]) then\r\n begin\r\n Exit;\r\n end;\r\n\r\n // validate ranges:\r\n if (Values[I] < AsciiTime_MinValue[I]) or (Values[I] > AsciiTime_MaxValue[I]) then\r\n Exit; // a value is out of range.\r\n\r\n Inc(Index);\r\n end;\r\n\r\n // Now that we probably have a valid value we will try to encode it.\r\n // EncodeData will catch any invalid date values we have let slip through\r\n // such as trying to encode February 29 on a non-leap year, or the 31st\r\n // day of a month with only 30 days, etc.\r\n try\r\n Result := EncodeDate({year}Values[1], {month} Values[2], {day} Values[3]) +\r\n EncodeTime({hour}Values[4], {minute} Values[5], {second} Values[6], {msec} 0);\r\n except\r\n on E: EConvertError do\r\n Result := 0.0; // catch any other conversion errors and just return 0.\r\n end;\r\nend;\r\n\r\nfunction JvIsoDateStrToDate(const AsciiDateStr: string): TDateTime; // new.\r\nconst\r\n Separators = '//'; // separators in yyyy/mm/dd [a custom nearly-ISO-compliant format]\r\n Separators2 = '--'; // separators in yyyy-mm-dd [the real ISO date format uses dashes as separators]\r\nvar\r\n Values: array [1..3] of Integer; //year,month,day\r\n Ch: Char;\r\n I, U, Len, Index: Integer;\r\nbegin\r\n Result := 0.0; // default Result.\r\n Len := Length(AsciiDateStr);\r\n\r\n // validate ranges:\r\n for I := 1 to 3 do\r\n Values[I] := 0;\r\n\r\n // T loops through each value we are looking for (1..6):\r\n Index := 1; // what character in AsciiDateStr are we looking at?\r\n for I := 1 to 3 do\r\n begin\r\n //if (I >= 3) and (Index >= Len) then\r\n // Break; // as long as we at least got the date, we can continue.\r\n for U := 1 to AsciiTime_ExpectLengths[I] do\r\n begin\r\n if Index > Len then\r\n Break;\r\n Ch := AsciiDateStr[Index];\r\n if not ((Ch <= #255) and (AnsiChar(Ch) in DigitSymbols)) then\r\n Exit; // failed: invalid character.\r\n\r\n Values[I] := (Values[I] * 10) + (Ord(Ch) - Ord('0'));\r\n Inc(Index);\r\n\r\n if Index > Len then\r\n Break;\r\n end;\r\n\r\n // if we haven't reached the end of the string, then\r\n // check for a valid separator character:\r\n if Index < Len then\r\n if (AsciiDateStr[Index] <> Separators[I]) and\r\n (AsciiDateStr[Index] <> Separators2[I]) then\r\n begin\r\n Exit; // illegal separator character\r\n end;\r\n\r\n // validate ranges:\r\n if (Values[I] < AsciiTime_MinValue[I]) or (Values[I] > AsciiTime_MaxValue[I]) then\r\n begin\r\n Exit; // a value is out of range.\r\n end;\r\n Inc(Index);\r\n end;\r\n\r\n // Now that we probably have a valid value we will try to encode it.\r\n // EncodeData will catch any invalid date values we have let slip through\r\n // such as trying to encode February 29 on a non-leap year, or the 31st\r\n // day of a month with only 30 days, etc.\r\n try\r\n Result := EncodeDate({year}Values[1], {month} Values[2], {day} Values[3]);\r\n except\r\n on E: EConvertError do\r\n Result := 0.0; // catch any other conversion errors and just return 0.\r\n end;\r\nend;\r\n\r\nfunction JvIsoTimeStrToTime(const AsciiTimeStr: string): TDateTime; // new.\r\nconst\r\n Separators = '::'; // separators hh:mm:ss\r\n Separators2 = '--'; // separators hh-mm-ss\r\nvar\r\n Values: array [1..3] of Integer; //year,month,day,hour,minute,second in that order.\r\n Ch: Char;\r\n I, U, Len, Index: Integer;\r\nbegin\r\n Result := -1.0; // default Result. (flag for invalid time. 0.0 is a VALID time = midnight!)\r\n Len := Length(AsciiTimeStr);\r\n\r\n // validate ranges:\r\n for I := 1 to 3 do\r\n Values[I] := 0;\r\n\r\n // T loops through each value we are looking for (1..6):\r\n Index := 1; // what character in AsciiTimeStr are we looking at?\r\n for I := 1 to 6 do\r\n begin\r\n if (I >= 3) and (Index >= Len) then\r\n Break; // as long as we at least got the date, we can continue.\r\n\r\n {Note: AsciiTime_ExpectLengths[ 3+I]:skip to the ISO time fields widths!}\r\n for U := 1 to AsciiTime_ExpectLengths[3+I] do\r\n begin\r\n if Index > Len then\r\n Break;\r\n Ch := AsciiTimeStr[Index];\r\n if not ((Ch <= #255) and (AnsiChar(Ch) in DigitSymbols)) then\r\n Exit; // failed: invalid character.\r\n Values[I] := (Values[I] * 10) + (Ord(Ch) - Ord('0'));\r\n Inc(Index);\r\n\r\n if Index > Len then\r\n Break;\r\n end;\r\n\r\n // if we haven't reached the end of the string, then\r\n // check for a valid separator character:\r\n if Index < Len then\r\n if (AsciiTimeStr[Index] <> Separators[I]) and\r\n (AsciiTimeStr[Index] <> Separators2[I]) then\r\n Exit;\r\n\r\n // validate ranges:\r\n if (Values[I] < AsciiTime_MinValue[3+I]) or (Values[I] > AsciiTime_MaxValue[3+I]) then\r\n Exit; // a value is out of range.\r\n\r\n Inc(Index);\r\n end;\r\n\r\n // Now that we probably have a valid value we will try to encode it.\r\n // EncodeData will catch any invalid date values we have let slip through\r\n // such as trying to encode February 29 on a non-leap year, or the 31st\r\n // day of a month with only 30 days, etc.\r\n try\r\n Result := EncodeTime({hour}Values[1], {minute} Values[2], {second} Values[3], {msec} 0);\r\n except\r\n on E: EConvertError do\r\n Result := -1.0; // catch any other conversion errors and just return 0. //ahuser: ??? -1.0 is not 0.0\r\n end;\r\nend;\r\n\r\nfunction JvDateTimeToTimeTHex(ADateTime: TDateTime; TimeZoneCorrection: Integer): string;\r\nvar\r\n Base: TDateTime;\r\n { DateTimeAsStr: string; //debug Code. }\r\n SecondsSince1970: Integer;\r\nbegin\r\n try\r\n Base := EncodeDate(1970, 1, 1);\r\n SecondsSince1970 := Trunc((ADateTime - Base) * 86400.0);\r\n Result := IntToHex(SecondsSince1970 - TimeZoneCorrection, 8);\r\n except\r\n // Catch Failures!\r\n Result := '';\r\n end;\r\nend;\r\n\r\n// JvDateTimeIsoStr [formerly called DateTimeToTimeToIsoAscii]\r\n// [support function for DateTime ASCII CSV column type]\r\n// Name changed by Warren. Only used internally here. The name was misleading,\r\n// complex, and bizarre. It had to change. Curse me or Thank me as you like. :-)\r\nfunction JvDateTimeIsoStr(ADateTime: TDateTime): string;\r\nbegin\r\n // ISO DATETIME FORMAT:\r\n Result := FormatDateTime('yyyy-mm-dd hh:nn:ss', ADateTime);\r\nend;\r\n\r\n// new: JvDateIsoStr - support function for ASCII DATE csv column type\r\nfunction JvDateIsoStr(ADateTime: TDateTime): string;\r\nbegin\r\n // ISO DATE FORMAT:\r\n Result := FormatDateTime('yyyy-mm-dd', ADateTime);\r\nend;\r\n\r\n// new: JvTimeIsoStr - support function for ASCII TIME csv column type\r\nfunction JvTimeIsoStr(ADateTime: TDateTime): string;\r\nbegin\r\n // ISO DATE FORMAT:\r\n Result := FormatDateTime('hh:nn:ss', ADateTime);\r\nend;\r\n\r\nfunction JvFilePathSplit(FileName: string; var Path, FilenameOnly: string): Boolean;\r\nvar\r\n Len, I: Integer;\r\nbegin\r\n Len := Length(FileName);\r\n Result := False;\r\n Path := '';\r\n FilenameOnly := '';\r\n for I := Len downto 1 do\r\n if FileName[I] = PathDelim then\r\n begin\r\n Path := Copy(FileName, 1, I);\r\n FilenameOnly := Copy(FileName, I + 1, Len);\r\n if (Length(FilenameOnly) > 0) and (Length(Path) > 0) and DirectoryExists(Path) then\r\n Result := True;\r\n Exit;\r\n end;\r\nend;\r\n\r\n{ Routine to keep backup copies of old Data files around }\r\n\r\nfunction JvCsvBackupPreviousFiles(const FileName: string; MaxFiles: Integer): Boolean;\r\nvar\r\n BackupFolder, FilenameOnly, BackupFilename, RemoveFile: string;\r\n I: Integer;\r\n Found: Boolean;\r\n\r\n function MakeFilename(Index: Integer): string;\r\n begin\r\n Result := BackupFolder + FilenameOnly + '.' + IntToStr(Index) + '.bak';\r\n end;\r\n\r\nbegin\r\n Result := False;\r\n\r\n if not FileExists(FileName) then\r\n Exit; // failed.\r\n if not JvFilePathSplit(FileName, BackupFolder, FilenameOnly) then\r\n begin\r\n FilenameOnly := FileName;\r\n GetDir(0, BackupFolder);\r\n BackupFolder := BackupFolder + PathDelim;\r\n end;\r\n BackupFolder := BackupFolder + 'Backup'+ PathDelim;\r\n if not DirectoryExists(BackupFolder) then\r\n ForceDirectories(BackupFolder);\r\n Found := False;\r\n for I := 0 to MaxFiles - 1 do\r\n begin\r\n BackupFilename := MakeFilename(I);\r\n if not FileExists(BackupFilename) then\r\n begin\r\n RemoveFile := MakeFilename((I + 1) mod MaxFiles);\r\n Found := True;\r\n Break;\r\n end;\r\n end;\r\n\r\n if not Found then\r\n begin\r\n I := 1;\r\n BackupFilename := MakeFilename(I);\r\n RemoveFile := MakeFilename((I + 1) mod MaxFiles);\r\n end;\r\n\r\n // We remove an old backup if necessary so that the next time we run\r\n // we will find the gap and know where to write the next numbered\r\n // backup. That means that anywhere from zero to 998 backups could exist\r\n // in a circular fashion. Without this logic, we wouldn't know the next\r\n // extension number to use.\r\n if FileExists(RemoveFile) then\r\n DeleteFile(RemoveFile);\r\n\r\n\r\n Windows.CopyFile(PChar(FileName), PChar(BackupFilename), False);\r\n Result := True;\r\nend;\r\n\r\nprocedure TJvCustomCsvDataSet.SetSeparator(const Value: Char);\r\nvar\r\n S: string;\r\nbegin\r\n if Separator <> Value then\r\n begin\r\n if (Value <= #255) and (AnsiChar(Value) in cInvalidSeparators) then\r\n begin\r\n case Value of\r\n #32..#255:\r\n S := Value\r\n else\r\n S := Format('#%.2d',[Ord(Value)]);\r\n raise EJvCsvDataSetError.CreateResFmt(@RsECsvInvalidSeparatorFmt,[S]);\r\n end;\r\n end;\r\n FData.Separator := Value;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomCsvDataSet.LoadFromFile(const FileName: string);\r\nvar\r\n Tmp: Boolean;\r\nbegin\r\n Close;\r\n Tmp := LoadsFromFile;\r\n try\r\n LoadsFromFile := True;\r\n Self.FileName := FileName;\r\n Open;\r\n finally\r\n LoadsFromFile := Tmp;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomCsvDataSet.SaveToFile(const FileName: string);\r\nbegin\r\n ExportCsvFile(FileName);\r\nend;\r\n\r\n{ Extremely ugly hack to copy a JvCsvRow binary record from\r\n one dataset to another }\r\n\r\nprocedure TJvCustomCsvDataSet.CloneRow(DataSet: TJvCustomCsvDataSet);\r\nbegin\r\n if not FCursorOpen then\r\n Exit;\r\n {basic sanity checks}\r\n\r\n { make sure the range is valid and that the csv schema is the same }\r\n if (RecNo < 0) or (RecNo >= FData.Count) then\r\n raise EJvCsvDataSetError.CreateResFmt(@RsEProblemReadingRow, [RecNo]);\r\n if FCsvFieldDef <> DataSet.FCsvFieldDef then\r\n raise EJvCsvDataSetError.CreateResFmt(@RsEProblemReadingRow, [RecNo]);\r\n\r\n if (DataSet.FData.GetRowAllocSize <> FData.GetRowAllocSize) then\r\n raise EJvCsvDataSetError.Create('TJvCustomCsvDataSet Internal Error. GetRowAllocSize mismatch.'); // TODO Add to resources!\r\n\r\n {copy the memory record }\r\n CopyMemory(FData[RecNo], DataSet.FData[DataSet.RecNo], FData.GetRowAllocSize);\r\n\r\n PCsvRow(FData[RecNo])^.IsDirty := RowNeedsSaving;\r\n FFileDirty := True;\r\n\r\n //DataSet.Last; // Force update of screen.\r\n\r\n Resync([]); // Update Data aware controls.\r\nend;\r\n\r\n// get contents of one dataset into this dataset. copies only fields that\r\n// match. Raises an exception if an error occurs. returns # of rows copied.\r\n\r\nfunction TJvCustomCsvDataSet.CopyFromDataset(DataSet: TDataSet): Integer;\r\nvar\r\n I, MatchFieldCount: Integer;\r\n StrValue, FieldName: string;\r\n MatchSourceField: array of TField;\r\n MatchDestField: array of TField;\r\nbegin\r\n // Result := -1;\r\n SetLength(MatchSourceField, FieldCount);\r\n SetLength(MatchDestField, FieldCount);\r\n MatchFieldCount := 0;\r\n for I := 0 to DataSet.FieldCount-1 do\r\n begin\r\n MatchSourceField[MatchFieldCount] := DataSet.Fields[I];\r\n Assert(Assigned(MatchSourceField[MatchFieldCount]));\r\n FieldName := MatchSourceField[MatchFieldCount].FieldName;\r\n try\r\n MatchDestField[MatchFieldCount] := FieldByName(FieldName);\r\n Assert(Assigned(MatchDestField[MatchFieldCount]));\r\n Inc(MatchFieldCount);\r\n except\r\n on E: EDatabaseError do\r\n begin\r\n // ignore it.\r\n end;\r\n end;\r\n end;\r\n if MatchFieldCount = 0 then\r\n JvCsvDatabaseError(DataSet.Name, RsENoFieldNamesMatch);\r\n Result := 0;\r\n DataSet.First;\r\n if not Active and not LoadsFromFile then\r\n Active := True;\r\n\r\n while not DataSet.Eof do\r\n begin\r\n Append;\r\n for I := 0 to MatchFieldCount-1 do\r\n if MatchSourceField[I].DataType=ftString then\r\n begin\r\n if MatchSourceField[I].IsNull then\r\n StrValue := ''\r\n else\r\n StrValue := MatchSourceField[I].Value;\r\n MatchDestField[I].Value := StrValue;\r\n end\r\n else\r\n MatchDestField[I].Value := MatchSourceField[I].Value;\r\n Post;\r\n DataSet.Next;\r\n Inc(Result);\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomCsvDataSet.CreateFields;\r\nbegin\r\n InternalInitFieldDefs;\r\n inherited CreateFields;\r\nend;\r\n\r\n//-------------------------------------------------------------------------\r\n//DeleteCsvColumn\r\n//\r\n// When JvCsvDataSet can't open a file, because it contains a\r\n// column in the file that is not defined in our CsvFieldDef, this can\r\n// create a difficult-to-solve problem. If we drop an obsolete or pointless\r\n// CSV field from our CsvFieldDef, and we have stuff out there in the\r\n// field that contains that data, new versions of our program won't read\r\n// the files anymore.\r\n//\r\n// CSV file editing is not for the faint of heart, and so this method\r\n// is considered less destructive than requiring users to repair\r\n// their files manually.\r\n//\r\n// To use this method:\r\n// Create a CsvDataSet object with a CsvFieldDef='' (empty)\r\n//\r\n// Set the Filename property to a fully qualified filename, that\r\n// must exist, set Active to true, then to False, so we've read\r\n// the column definitions!\r\n//\r\n// Call this method, specify a column name that must be removed.\r\n// The saved file won't contain the column you've removed.\r\n//\r\n// Of course, this method is inherently destructive of of your data.\r\n// Be careful. Make your own backup before you use this method.\r\n//-------------------------------------------------------------------------\r\nprocedure TJvCustomCsvDataSet.DeleteCsvColumn(const AFieldName: string);\r\nvar\r\n CsvCol: PCsvColumn;\r\n ColNum: Integer;\r\n I: Integer;\r\n PTempRow: PCsvRow;\r\n DataRow: AnsiString;\r\n NewDataRow: AnsiString;\r\nbegin\r\n // filename must be set for this method to work\r\n Assert(FileName <> '');\r\n Assert(FileExists(Filename)); // ahuser: Wouldn't it be better to use a normal exception for this?\r\n\r\n // you should set the filename, but not the CsvFieldDef in this case,\r\n // because in this mode, the CsvDataSet is supposed to be able to open\r\n // ANY csv file. This is the idea. Open the file, browse it, close it,\r\n // do some modifications like adding or removing columns, then save those\r\n // changes, then re-open the csv file to view the change.\r\n if (FCsvFieldDef <> '') or Active then\r\n raise Exception.Create('This special method DeleteCsvColumn cannot be called except when CsvFieldDef is not set, and no table is currently open!');\r\n\r\n PTempRow := PCsvRow(AllocRecordBuffer);\r\n try\r\n // begin an internal load:\r\n FOpenFileName := GetFileName; // Always use the same file name to save as you did to load!!! MARCH 2004.WP\r\n\r\n InternalInitFieldDefs; // also loads entire file!\r\n InternalOpen;\r\n\r\n Assert(FCsvColumns.Count > 1); // why delete last column in an empty file? besides, it would die later on anyways, opening the empty file.\r\n\r\n CsvCol := FCsvColumns.FindByName(AFieldName);\r\n if not Assigned(CsvCol) then\r\n JvCsvDatabaseError(FTableName, Format(RsEFieldNotFound, [AFieldName]));\r\n\r\n ColNum := CsvCol.FPhysical;\r\n\r\n if not WriteCsvFileStream then\r\n raise Exception.Create('Unable to write to CSV file.');\r\n\r\n Assert(Assigned(FCsvStream));\r\n\r\n {Write header row minus column}\r\n if FHasHeaderRow then\r\n begin\r\n // ahuser: DataRow is not initialized and so it is '', is this right?\r\n JvAnsiStringToCsvRow(DataRow, AnsiChar(Separator), PTempRow, True, EnquoteBackslash);\r\n NewDataRow := JvCsvRowDeleteColumn(PTempRow, ColNum, FCsvColumns.Count);\r\n FCsvStream.WriteLine(NewDataRow);\r\n end;\r\n\r\n {Write data rows minus column}\r\n for I := 0 to RecordCount - 1 do\r\n begin\r\n DataRow := AnsiString(GetRowAsString(I));\r\n if Length(DataRow) >= JvCsv_MAXLINELENGTH - 1 then\r\n raise EJvCsvDataSetError.CreateResFmt(@RsECsvStringTooLong, [Copy(DataRow, 1, 40)]);\r\n JvAnsiStringToCsvRow(DataRow, AnsiChar(Separator), PTempRow, True, EnquoteBackslash);\r\n\r\n // delete column:\r\n NewDataRow := JvCsvRowDeleteColumn(PTempRow, ColNum, FCsvColumns.Count);\r\n FCsvStream.WriteLine(NewDataRow);\r\n end;\r\n\r\n FreeAndNil(FCsvStream); // close and finalize stream.\r\n\r\n //InternalClearFileStrings;\r\n\r\n Self.FieldDefs.Clear;\r\n Assert(FieldDefs.Count = 0);\r\n Self.Fields.Clear;\r\n Assert(Fields.Count = 0);\r\n\r\n FHeaderRow := ''; // clear header row\r\n FData.Clear;\r\n finally\r\n FreeMem(PTempRow);\r\n end;\r\nend;\r\n\r\nfunction TJvCustomCsvDataSet.Locate(const KeyFields: string; const KeyValues: Variant; Options: TLocateOptions):\r\n Boolean;\r\nbegin\r\n DoBeforeScroll;\r\n Result := LocateRecord(KeyFields, KeyValues, Options);\r\n if Result then\r\n begin\r\n Resync([rmExact, rmCenter]);\r\n DoAfterScroll;\r\n end;\r\nend;\r\n\r\nfunction TJvCustomCsvDataSet.Lookup(const KeyFields: string; const KeyValues: Variant;\r\n const ResultFields: string): Variant;\r\nbegin\r\n Result := Null;\r\n if LocateRecord(KeyFields, KeyValues, []) then\r\n Result := FieldValues[ResultFields];\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvCsvParse.pas", "content": "{-----------------------------------------------------------------------------\r\n **** TIBURON AnsiChar/AnsiString VERSION 3.5 ****\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvaDsgn.PAS, released on 2002-07-04.\r\n\r\nThe Initial Developers of the Original Code are: Andrei Prygounkov \r\nCopyright (c) 1999, 2002 Andrei Prygounkov\r\nAll Rights Reserved.\r\n\r\nContributor(s): Warren Postma (warrenpstma att hotmail dott com)\r\n\r\n Changed StrSplit Function (has one new parameter).\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nDescription:\r\n Internal pchar-manipulation functions required by TJvCsvDataSet data access component.\r\n\r\n Useful extra functions for parsing strings using pascal,\r\n not present in your basic vanilla Pascal/Delphi standard\r\n libraries.\r\n\r\n MOST use PChars and char buffers, not the String type.\r\n\r\n These functions are used to implement the\r\n CsvDataSource component but are generally reuseable in\r\n any AnsiString parsing code.\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvCsvParse.pas 12461 2009-08-14 17:21:33Z obones $\r\n\r\nunit JvCsvParse;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Classes;\r\n\r\nconst\r\n MaxInitStrNum = 9;\r\n\r\n{ String Class Functions - uses Delphi String objects instead of Pascal PChars }\r\n\r\nfunction JvAnsiStrSplit(const InString: AnsiString; const SplitChar, QuoteChar: AnsiChar;\r\n var OutStrings: array of AnsiString; MaxSplit: Integer): Integer;\r\nfunction JvStrSplit(const InString: string; const SplitChar, QuoteChar: Char;\r\n var OutStrings: array of string; MaxSplit: Integer): Integer;\r\n\r\nfunction JvAnsiStrSplitStrings(const InString: AnsiString; const SplitChar, QuoteChar: AnsiChar; OutStrings: TStrings): Integer;\r\n\r\n{ circa 1998-2001 classic functions }\r\nfunction JvAnsiStrStrip(S: AnsiString): AnsiString; // Strip whitespace, carriage returns, linefeeds.\r\nfunction JvStrStrip(S: string): string; // Strip whitespace, carriage returns, linefeeds.\r\nfunction GetString(var Source: AnsiString; const Separator: AnsiString): AnsiString;\r\n// Iteratively split off a piece of a AnsiString. Modifies original AnsiString.\r\nfunction PadString(const S: AnsiString; Len: Integer; PadChar: AnsiChar): AnsiString;\r\n//procedure Gibble(var S: AnsiString); // Deprecated. With a name like Gibble, are you surprised?\r\nfunction BuildPathName(const PathName, FileName: AnsiString): AnsiString;\r\nfunction StrEatWhiteSpace(const S: string): string;\r\nfunction HexToAscii(const S: AnsiString): AnsiString;\r\nfunction AsciiToHex(const S: AnsiString): AnsiString;\r\nfunction StripQuotes(const S1: AnsiString): AnsiString;\r\n\r\n{ TStrings helper functions }\r\n(*function GetIntValueFromResultString(const VarName: AnsiString; ResultStrings: TStrings;\r\n DefVal: Integer): Integer;\r\nfunction GetValueFromResultString(const VarName: AnsiString; ResultStrings: TStrings): AnsiString;\r\n*)\r\n\r\n{ Pascal Low Level PAnsiChar Functions }\r\nfunction ValidNumericLiteral(S1: PAnsiChar): Boolean;\r\nfunction ValidIntLiteral(S1: PAnsiChar): Boolean;\r\nfunction ValidHexLiteral(S1: PAnsiChar): Boolean;\r\nfunction HexPCharToInt(S1: PAnsiChar): Integer;\r\nfunction ValidStringLiteral(S1: PAnsiChar): Boolean;\r\nfunction StripPCharQuotes(S1: PAnsiChar): AnsiString;\r\n\r\nfunction JvValidIdentifierAnsi(S1: PAnsiChar): Boolean;\r\nfunction JvValidIdentifier(S1:String):Boolean;\r\nfunction JvEndChar(X: AnsiChar): Boolean;\r\nprocedure JvGetToken(S1, S2: PAnsiChar);\r\nfunction IsExpressionKeyword(S1: PAnsiChar): Boolean;\r\nfunction IsKeyword(S1: PAnsiChar): Boolean;\r\nfunction JvValidVarReference(S1: PAnsiChar): Boolean;\r\nfunction GetParenthesis(S1, S2: PAnsiChar): Boolean;\r\nprocedure JvGetVarReference(S1, S2, SIdx: PAnsiChar);\r\nprocedure JvEatWhitespaceChars(S1: PAnsiChar); overload;\r\n\r\n{$IFDEF COMPILER12_UP}\r\nprocedure JvEatWhitespaceChars(S1: PWideChar); overload;\r\n{$ENDIF COMPILER12_UP}\r\n\r\n{ Debugging functions related to JvGetToken function. }\r\nfunction GetTokenCount: Integer;\r\nprocedure ResetTokenCount;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvCsvParse.pas $';\r\n Revision: '$Revision: 12461 $';\r\n Date: '$Date: 2009-08-14 19:21:33 +0200 (ven. 14 août 2009) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n SysUtils,\r\n {$IFNDEF COMPILER12_UP}\r\n JvJCLUtils, // CharInSet() and other future friendly bits\r\n {$ENDIF ~COMPILER12_UP}\r\n JvTypes, JvConsts, JvResources;\r\n\r\nvar\r\n TokenCount: Integer = 0;\r\n\r\n{ Returns true for literals like '123.456', '78', or '-35.1231231' }\r\n\r\nfunction ValidNumericLiteral(S1: PAnsiChar): Boolean;\r\nvar\r\n L, X, X1: Integer;\r\n DecimalFlag: Boolean;\r\nbegin\r\n L := StrLen(S1);\r\n DecimalFlag := False;\r\n X1 := 0;\r\n\r\n if L <= 0 then\r\n begin\r\n Result := False;\r\n Exit;\r\n end;\r\n\r\n { detect leading minus }\r\n if S1[0] = '-' then\r\n Inc(X1); // skip the minus, as it's okay as a leading character\r\n\r\n { Detect a decimal number or integer number }\r\n for X := X1 to L - 1 do\r\n if S1[X] = '.' then\r\n begin\r\n if DecimalFlag then\r\n begin\r\n Result := False; // two decimal places is invalid.\r\n Exit;\r\n end;\r\n DecimalFlag := True;\r\n end\r\n else\r\n if not CharInSet(S1[X], DigitSymbols) then // native in Delphi2009, otherwise Jcl Util unit.\r\n begin\r\n Result := False;\r\n Exit;\r\n end;\r\n Result := True;\r\nend;\r\n\r\n{ Returns true for integer literals only, like -35 or 199, but not\r\n for values like '123.45' }\r\n\r\nfunction ValidIntLiteral(S1: PAnsiChar): Boolean;\r\nvar\r\n L, X, X1: Integer;\r\nbegin\r\n L := StrLen(S1);\r\n X1 := 0;\r\n if L <= 0 then\r\n begin\r\n Result := False;\r\n Exit;\r\n end;\r\n { detect leading minus }\r\n if S1[0] = '-' then\r\n Inc(X1); // skip the minus, as it's okay as a leading character\r\n\r\n { Detect a decimal number or integer number }\r\n for X := X1 to L - 1 do\r\n if not CharInSet(S1[X], DigitSymbols) then\r\n begin\r\n Result := False;\r\n Exit;\r\n end;\r\n Result := True;\r\nend;\r\n\r\n{ Returns true for integer literals only, like -35 or 199, but not\r\n for values like '123.45' }\r\n\r\nfunction ValidHexLiteral(S1: PAnsiChar): Boolean;\r\nvar\r\n L, X: Integer;\r\nbegin\r\n L := StrLen(S1);\r\n // X1 := 0;\r\n\r\n { detect hex code type indicator }\r\n if (L < 2) or (S1[0] <> '$') then\r\n begin\r\n Result := False;\r\n Exit;\r\n end;\r\n\r\n { Detect hex digits }\r\n for X := 1 to L - 2 do\r\n if not CharInSet(S1[X], HexadecimalSymbols) then\r\n begin\r\n Result := False;\r\n Exit;\r\n end;\r\n Result := True;\r\nend;\r\n\r\nfunction HexPCharToInt(S1: PAnsiChar): Integer;\r\nvar\r\n X, L: Integer;\r\n Digit, Val: Integer;\r\nbegin\r\n L := StrLen(S1);\r\n if (L < 2) or (L > 9) then\r\n raise EJVCLException.CreateRes(@RsEInvalidHexLiteral);\r\n if S1[0] <> '$' then\r\n raise EJVCLException.CreateRes(@RsEInvalidHexLiteral);\r\n Val := 0;\r\n for X := 1 to L - 2 do\r\n begin\r\n Val := Val * 16; { shift right four bits at a time }\r\n if CharInSet(S1[X], DigitSymbols) then\r\n Digit := Ord(S1[X]) - Ord('0')\r\n else\r\n if CharInSet(S1[X], HexadecimalLowercaseLetters) then\r\n Digit := Ord(S1[X]) - Ord('a') + 10\r\n else\r\n if CharInSet(S1[X], HexadecimalUppercaseLetters) then\r\n Digit := Ord(S1[X]) - Ord('A') + 10\r\n else\r\n raise EJVCLException.CreateRes(@RsEInvalidHexLiteral);\r\n Val := Val + Digit;\r\n end;\r\n Result := Val;\r\nend;\r\n\r\nfunction ValidStringLiteral(S1: PAnsiChar): Boolean;\r\nbegin\r\n Result := (S1[0] = '\"') and (S1[StrLen(S1) - 1] = '\"');\r\nend;\r\n\r\n{ Strip quotes and return as a real Delphi String }\r\n\r\nfunction StripQuotes(const S1: AnsiString): AnsiString;\r\nbegin\r\n if ValidStringLiteral(PAnsiChar(S1)) then\r\n Result := Copy(S1, 2, Length(S1) - 2)\r\n else\r\n Result := S1;\r\nend;\r\n\r\n// This function is limited to 1 to 254 characters:\r\n\r\nfunction StripPCharQuotes(S1: PAnsiChar): AnsiString;\r\nvar\r\n TempBuf: array [0..256] of AnsiChar;\r\n L: Integer;\r\nbegin\r\n L := StrLen(S1);\r\n if L > 255 then\r\n L := 255;\r\n if ValidStringLiteral(S1) then\r\n StrLCopy(TempBuf, S1 + 1, L - 2);\r\n Result := AnsiString(TempBuf);\r\nend;\r\n\r\n{ Prevent confusion between expression-keywords and variable identifiers }\r\n\r\nfunction IsExpressionKeyword(S1: PAnsiChar): Boolean;\r\nbegin\r\n if StrIComp(S1, 'AND') = 0 then\r\n Result := True\r\n else\r\n if StrIComp(S1, 'OR') = 0 then\r\n Result := True\r\n else\r\n if StrIComp(S1, 'XOR') = 0 then\r\n Result := True\r\n else\r\n if StrIComp(S1, 'NOT') = 0 then\r\n Result := True\r\n else\r\n if StrIComp(S1, 'DIV') = 0 then\r\n Result := True\r\n else\r\n if StrIComp(S1, 'SHR') = 0 then\r\n Result := True\r\n else\r\n if StrIComp(S1, 'SHL') = 0 then\r\n Result := True\r\n else\r\n Result := False;\r\nend;\r\n\r\nfunction IsKeyword(S1: PAnsiChar): Boolean;\r\nbegin\r\n Result := (StrIComp(S1, 'SET') = 0) or (StrIComp(S1, 'LET') = 0) or\r\n (StrIComp(S1, 'DIM') = 0) or (StrIComp(S1, 'ARRAYCOPY') = 0) or\r\n (StrIComp(S1, 'STRCOPY') = 0) or (StrIComp(S1, 'STRPAD') = 0) or\r\n (StrIComp(S1, 'STRSTRIP') = 0) or (StrIComp(S1, 'END') = 0) or\r\n (StrIComp(S1, 'INC') = 0) or (StrIComp(S1, 'DEC') = 0) or\r\n (StrIComp(S1, 'PARAM') = 0) or (StrIComp(S1, 'JUMP') = 0) or\r\n (StrIComp(S1, 'SLEEP') = 0) or (StrIComp(S1, 'GOTO') = 0) or\r\n (StrIComp(S1, 'IF') = 0) or (StrIComp(S1, 'CALL') = 0) or\r\n (StrIComp(S1, 'STOP') = 0) or (StrIComp(S1, 'CONST') = 0);\r\nend;\r\n\r\n{ JvValidIdentifier:\r\n\r\n Valid identifier must start with a-z or A-Z or _, and can have alphanumeric or underscore(_)\r\n as subsequent characters, no spaces, punctuation, or other characters allowed. Same rules as\r\n most programming languages, Cobol being one particularly nasty exception! \r\n\r\n --Warren.\r\n}\r\n\r\n\r\nfunction JvValidIdentifier(S1:String):Boolean;\r\nvar\r\n convertedString:AnsiString;\r\nbegin\r\n convertedString := AnsiString(S1);\r\n result := JvValidIdentifierAnsi(PAnsiChar(convertedString));\r\nend;\r\n\r\nfunction JvValidIdentifierAnsi(S1: PAnsiChar): Boolean;\r\nvar\r\n X, Y: Integer;\r\n Pass: Boolean;\r\nbegin\r\n Pass := True;\r\n\r\n if IsExpressionKeyword(S1) then\r\n begin\r\n Result := False;\r\n Exit;\r\n end;\r\n\r\n X := StrLen(S1);\r\n if (X < 1) or (X > 32) then\r\n begin\r\n Result := False;\r\n Exit;\r\n end;\r\n\r\n if not CharInSet(S1[0], IdentifierFirstSymbols) then\r\n Pass := False;\r\n\r\n if Pass and (X > 1) then\r\n for Y := 1 to X - 1 do\r\n if not CharInSet(S1[Y], IdentifierSymbols) then\r\n begin\r\n Pass := False;\r\n Result := Pass;\r\n Exit;\r\n end;\r\n\r\n Result := Pass;\r\nend;\r\n\r\nfunction JvEndChar(X: AnsiChar): Boolean;\r\nbegin\r\n Result := (X = ',') or (X = ';') or (X = ':') or (X = '[') or (X = ']') or\r\n (X = '(') or (X = ')') or (X = '#') or (X = '<') or (X = '>') or (X = '=') or\r\n (X = '*') or (X = '/') or (X = '+') or (X = Chr(0));\r\nend;\r\n\r\nprocedure JvGetToken(S1, S2: PAnsiChar);\r\nvar\r\n W, X, Y: Integer;\r\n InQuotes: Boolean;\r\nbegin\r\n X := 0;\r\n W := 0;\r\n\r\n { Empty in, Empty Out }\r\n if StrLen(S1) = 0 then\r\n S2[0] := Chr(0);\r\n\r\n InQuotes := False;\r\n\r\n { skip leading space }\r\n while (S1[X] = ' ') or (S1[X] = Tab) do\r\n Inc(X);\r\n\r\n while True do\r\n begin\r\n if JvEndChar(S1[X]) and not InQuotes then\r\n begin\r\n { return punctuation one symbol at a time }\r\n if W < 1 then\r\n begin\r\n S2[W] := S1[X];\r\n Inc(W);\r\n Inc(X);\r\n end;\r\n Break;\r\n end;\r\n\r\n if S1[X] = '\"' then\r\n InQuotes := not InQuotes;\r\n\r\n { Break if space found and not in quotes }\r\n if (S1[X] = ' ') and not InQuotes then\r\n Break\r\n else\r\n begin\r\n S2[W] := S1[X];\r\n Inc(W);\r\n end;\r\n\r\n Inc(X);\r\n end;\r\n // S2[X] := Chr(0);\r\n\r\n { detect not-equal, less-than-or-equal and greater-than-or-equal operators }\r\n if W = 1 then\r\n if (S2[0] = '<') and (S1[X] = '>') then\r\n begin\r\n S2[W] := '>';\r\n Inc(X);\r\n Inc(W); // char literal\r\n end\r\n else\r\n if (S2[0] = '<') and (S1[X] = '=') then\r\n begin\r\n S2[W] := '=';\r\n Inc(X);\r\n Inc(W);\r\n end\r\n else\r\n if (S2[0] = '>') and (S1[X] = '=') then\r\n begin\r\n S2[W] := '=';\r\n Inc(X);\r\n Inc(W);\r\n end;\r\n\r\n { remove token from initial buffer, move to second buffer }\r\n Y := Integer(StrLen(S1)) - X;\r\n if Y > 0 then\r\n StrLCopy(S1, S1 + X, Y) { copy remaining characters }\r\n else\r\n S1[0] := Chr(0); { just erase all of old AnsiString }\r\n\r\n S2[W] := Chr(0); { Terminate new AnsiString }\r\n Inc(TokenCount);\r\nend;\r\n\r\nfunction StrEatWhiteSpace(const S: string): string;\r\nvar\r\n Buf: array [0..1024] of Char;\r\nbegin\r\n if Length(S) > 1024 then\r\n begin\r\n Result := S;\r\n Exit;\r\n end;\r\n StrCopy(Buf, PChar(S));\r\n JvEatWhitespaceChars(Buf);\r\n Result := string(Buf);\r\nend;\r\n\r\n{ strip whitespace from pchar - space or tab }\r\n\r\nprocedure JvEatWhitespaceChars(S1: PAnsiChar);\r\nvar\r\n T, U, L: Integer;\r\nbegin\r\n L := StrLen(S1);\r\n // U := L;\r\n if L <= 0 then\r\n Exit;\r\n { skip spaces starting at the beginning }\r\n for T := 0 to L do\r\n if (S1[T] <> ' ') and (S1[T] <> Tab) then\r\n Break;\r\n { skip spaces starting at the end }\r\n for U := L - 1 downto T do\r\n if (S1[U] <> ' ') and (S1[U] <> Tab) then\r\n Break;\r\n if (T > 0) or (U < L - 1) then\r\n if T > U then // was T>=U (test me!)\r\n S1[0] := Chr(0)\r\n else\r\n StrLCopy(S1, S1 + T, (U - T) + 1);\r\nend;\r\n\r\n{$IFDEF COMPILER12_UP}\r\nprocedure JvEatWhitespaceChars(S1: PWideChar);\r\nvar\r\n T, U, L: Integer;\r\nbegin\r\n L := StrLen(S1);\r\n // U := L;\r\n if L <= 0 then\r\n Exit;\r\n { skip spaces starting at the beginning }\r\n for T := 0 to L do\r\n if (S1[T] <> ' ') and (S1[T] <> Tab) then\r\n Break;\r\n { skip spaces starting at the end }\r\n for U := L - 1 downto T do\r\n if (S1[U] <> ' ') and (S1[U] <> Tab) then\r\n Break;\r\n if (T > 0) or (U < L - 1) then\r\n if T > U then // was T>=U (test me!)\r\n S1[0] := Chr(0)\r\n else\r\n StrLCopy(S1, S1 + T, (U - T) + 1);\r\nend;\r\n{$ENDIF COMPILER12_UP}\r\n\r\nfunction GetParenthesis(S1, S2: PAnsiChar): Boolean;\r\nvar\r\n Token, TempBuf: array [0..128] of AnsiChar;\r\n Brackets: Integer;\r\nbegin\r\n { make temporary copy of S1, check for parenthesis }\r\n StrCopy(TempBuf, S1);\r\n JvGetToken(TempBuf, S2);\r\n if StrComp(S2, '(') = 0 then\r\n begin\r\n Brackets := 1;\r\n S2[0] := Chr(0);\r\n repeat\r\n JvGetToken(TempBuf, Token);\r\n if StrComp(Token, ')') = 0 then\r\n Dec(Brackets);\r\n if Brackets > 0 then\r\n begin\r\n StrCat(S2, Token);\r\n StrCat(S2, ' ');\r\n end;\r\n if StrComp(Token, '(') = 0 then\r\n Inc(Brackets);\r\n until (StrLen(S1) = 0) or (Brackets = 0);\r\n if Brackets <> 0 then\r\n begin\r\n S2[0] := Chr(0);\r\n Result := False;\r\n Exit;\r\n end;\r\n StrCopy(S1, TempBuf); { remainder back into S1 }\r\n Result := True;\r\n end\r\n else\r\n begin { not parenthesis }\r\n S2[0] := Chr(0);\r\n Result := False;\r\n Exit;\r\n end;\r\nend;\r\n\r\n{ Gets a single token like ABC, or gets ABC[X] type reference if present }\r\n\r\nprocedure JvGetVarReference(S1, S2, SIdx: PAnsiChar);\r\nvar\r\n TempBuf: array [0..128] of AnsiChar;\r\n Brackets: Integer;\r\nbegin\r\n JvGetToken(S1, S2);\r\n SIdx[0] := Chr(0);\r\n JvEatWhitespaceChars(S1);\r\n if S1[0] = '[' then\r\n begin\r\n Brackets := 0;\r\n repeat\r\n JvGetToken(S1, TempBuf);\r\n StrCat(SIdx, TempBuf);\r\n if StrComp(TempBuf, ']') = 0 then\r\n Dec(Brackets);\r\n if StrComp(TempBuf, '[') = 0 then\r\n Inc(Brackets);\r\n\r\n if StrLen(S1) = 0 then\r\n Break;\r\n until Brackets <= 0;\r\n\r\n { Remove outermost brackets }\r\n StrLCopy(SIdx, SIdx + 1, StrLen(SIdx) - 2);\r\n end;\r\nend;\r\n\r\n{ Expects ABC or ABC[X] type of reference }\r\n\r\nfunction JvValidVarReference(S1: PAnsiChar): Boolean;\r\nvar\r\n Len1: Integer;\r\n TempBuf1, TempBuf2: array [0..128] of AnsiChar;\r\nbegin\r\n StrCopy(S1, TempBuf1);\r\n JvGetToken(TempBuf1, TempBuf2);\r\n if StrLen(TempBuf1) = 0 then\r\n Result := JvValidIdentifierAnsi(S1)\r\n else\r\n begin\r\n Len1 := StrLen(TempBuf1);\r\n if (TempBuf1[0] = '[') and (TempBuf1[Len1 - 1] = ']') then\r\n Result := JvValidIdentifierAnsi(S1)\r\n else\r\n Result := False;\r\n end;\r\nend;\r\n\r\n{ debugging and performance tuning information }\r\n\r\nfunction GetTokenCount: Integer;\r\nbegin\r\n Result := TokenCount;\r\nend;\r\n\r\nprocedure ResetTokenCount;\r\nbegin\r\n TokenCount := 0;\r\nend;\r\n\r\nfunction PadString(const S: AnsiString; Len: Integer; PadChar: AnsiChar): AnsiString;\r\nbegin\r\n Result := S;\r\n while Length(Result) < Len do\r\n Result := Result + PadChar;\r\nend;\r\n\r\n{ Encoding function named in honor of Dennis Forbes' favourite word }\r\n{procedure Gibble(var S: AnsiString);\r\nvar\r\n I, L, c1: Integer;\r\n lo, hi: Byte;\r\n X: array [0..255] of AnsiChar;\r\nbegin\r\n L := Length(S);\r\n for I:= 0 to L-1 do\r\n begin\r\n c1 := Ord(S[I+1] );\r\n if (c1 >= 32 ) AND (c1 <= 231) then\r\n begin\r\n c1 := c1 - 32;\r\n lo := (c1 MOD 25);\r\n hi := c1 div 25;\r\n lo := 24-lo;\r\n c1 := ((hi*25)+lo ) +32;\r\n X[I] := Chr(c1);\r\n end\r\n else\r\n X[I] := Chr(c1);\r\n end;\r\n X[L] := Chr(0);\r\n S := String(X);\r\nend;\r\n }\r\n\r\nfunction BuildPathName(const PathName, FileName: AnsiString): AnsiString;\r\nvar\r\n L: Integer;\r\nbegin\r\n L := Length(PathName);\r\n if L = 0 then\r\n Result := FileName\r\n else\r\n if PathName[L] = PathDelim then\r\n Result := PathName + FileName\r\n else\r\n Result := PathName + PathDelim + FileName;\r\nend;\r\n\r\nfunction HexDigitVal(C: AnsiChar): Integer;\r\nbegin\r\n if CharInSet(C, DigitSymbols) then\r\n Result := Ord(C) - Ord('0')\r\n else\r\n if CharInSet(C, HexadecimalLowercaseLetters) then\r\n Result := Ord(C) - Ord('a') + 10\r\n else\r\n if CharInSet(C, HexadecimalUppercaseLetters) then\r\n Result := Ord(C) - Ord('A') + 10\r\n else\r\n Result := 0;\r\nend;\r\n\r\nfunction HexToAscii(const S: AnsiString): AnsiString;\r\nvar\r\n I, Y, L: Integer;\r\n C: array [0..256] of AnsiChar;\r\nbegin\r\n L := Length(S) div 2;\r\n for I := 0 to L - 1 do\r\n begin\r\n Y := (I * 2) + 1;\r\n C[I] := AnsiChar(HexDigitVal(S[Y]) * 16 + HexDigitVal(S[Y + 1]));\r\n end;\r\n C[L] := Chr(0);\r\n Result := C;\r\nend;\r\n\r\nfunction AsciiToHex(const S: AnsiString): AnsiString;\r\nvar\r\n I: Integer;\r\n S2: AnsiString;\r\nbegin\r\n for I := 1 to Length(S) do\r\n S2 := S2 + AnsiString( IntToHex(Ord(S[I]), 2) );\r\n Result := S2;\r\nend;\r\n\r\n//-----------------------------------------------------------------------------\r\n// GetIntValueFromResultString\r\n//\r\n// Retrieve an integer value from a result AnsiString, Formats that are valid\r\n// include:\r\n//\r\n// VariableName: Value - usual format for status results\r\n// VariableName = Value - usual format in ini files\r\n// Label Name = Value - labels names can contain spaces.\r\n//-----------------------------------------------------------------------------\r\n\r\n(*\r\nfunction GetIntValueFromResultString(const VarName: AnsiString;\r\n ResultStrings: TStrings; DefVal: Integer): Integer;\r\nvar\r\n S: AnsiString;\r\nbegin\r\n S := GetValueFromResultString(VarName, ResultStrings);\r\n Result := AnsiString( StrToIntDef(S, DefVal));\r\nend;*)\r\n\r\n//-----------------------------------------------------------------------------\r\n// GetValueFromResultString\r\n//\r\n// Retrieve a value from a result AnsiString, Formats that are valid include:\r\n// VariableName: Value - usual format for status results\r\n// VariableName = Value - usual format in ini files\r\n// Label Name = Value - labels names can contain spaces.\r\n//-----------------------------------------------------------------------------\r\n\r\n(*\r\nfunction GetValueFromResultString(const VarName: AnsiString; ResultStrings: TStrings): AnsiString;\r\nvar\r\n Label1, Value1: AnsiString;\r\n Len1, Pos1, I, Count: Integer;\r\nbegin\r\n if not Assigned(ResultStrings) then\r\n begin\r\n Result := 'NIL';\r\n Exit;\r\n end;\r\n\r\n Count := ResultStrings.Count;\r\n for I := 0 to Count - 1 do\r\n begin\r\n Len1 := Length(ResultStrings[I]);\r\n Pos1 := Pos(':', ResultStrings[I]);\r\n if Pos1 = 0 then\r\n Pos1 := Pos('=', ResultStrings[I]);\r\n // found a value to extract:\r\n if Pos1 > 0 then\r\n begin\r\n Label1 := Copy(ResultStrings[I], 1, Pos1 - 1);\r\n Value1 := Copy(ResultStrings[I], Pos1 + 1, Len1);\r\n\r\n if VarName = Label1 then\r\n begin // found it!\r\n Result := Value1;\r\n Exit;\r\n end;\r\n end;\r\n end;\r\nend;\r\n*)\r\n\r\nfunction JvAnsiStrStrip(S: AnsiString): AnsiString;\r\nbegin\r\n Result := AnsiString(JvStrStrip(string(S)));\r\nend;\r\n\r\nfunction JvStrStrip(S: string): string;\r\nvar\r\n Len, I: Integer;\r\nbegin\r\n Len := Length(S);\r\n I := 1;\r\n while (Len >= I) and ((S[I] = ' ') or (S[I] = Tab)) do\r\n I := I + 1;\r\n if I > Len then\r\n begin\r\n Result := '';\r\n Exit;\r\n end;\r\n S := Copy(S, I, Len);\r\n Len := Len - I + 1;\r\n I := Len;\r\n while (I > 0) and ((S[I] = ' ') or (S[I] = Tab)) do\r\n I := I - 1;\r\n Result := Copy(S, 1, I);\r\nend;\r\n\r\nfunction GetString(var Source: AnsiString; const Separator: AnsiString): AnsiString;\r\nvar\r\n I, J, Len: Integer;\r\nbegin\r\n //Source := JvAnsiStrStrip(Source);\r\n Len := Length(Source);\r\n I := 0;\r\n for J := 1 to Len do\r\n if Pos(Source[J], Separator) > 0 then\r\n begin\r\n I := J;\r\n Break;\r\n end;\r\n if I > 0 then\r\n begin\r\n Result := JvAnsiStrStrip(Copy(Source, 1, I - 1));\r\n Source := Copy(Source, I + 1, Length(Source) - I);\r\n //Source:=JvAnsiStrStrip(source); //???\r\n end\r\n else\r\n begin\r\n Result := JvAnsiStrStrip(Source);\r\n Source := '';\r\n end;\r\nend;\r\n\r\n//------------------------------------------------------------------------------------------\r\n// JvAnsiStrSplit [ was 'StrSplit' ]\r\n// Given aString='Blah,Blah,Blah', SplitChar=',', writes to OutStrings an Array\r\n// ie ('blah','blah','blah ) and returns the integer count of how many items are in\r\n// the resulting array, or -1 if more than MaxSplit items were found in the input\r\n// AnsiString.\r\n//\r\n// XXX READ THESE NOTES! XXX\r\n//\r\n// XXX DOES NOT HANDLE QUOTING (YOU CAN'T HAVE A COMMA INSIDE QUOTES, AT LEAST NOT YET.) XXX\r\n//\r\n// XXX OutStrings array must be dimensioned to start at element ZERO,\r\n// if it starts at element 1, then you'll get exceptions XXX\r\n//------------------------------------------------------------------------------------------\r\n\r\nfunction JvAnsiStrSplit(const InString: AnsiString; const SplitChar, QuoteChar: AnsiChar;\r\n var OutStrings: array of AnsiString; MaxSplit: Integer): Integer;\r\nvar\r\n Tmp: array of string;\r\n I: Integer;\r\nbegin\r\n SetLength(Tmp, Length(OutStrings));\r\n\r\n Result := JvStrSplit(string(InString), Char(SplitChar), Char(QuoteChar), Tmp, MaxSplit);\r\n\r\n for I := Low(OutStrings) to High(OutStrings) do\r\n OutStrings[I] := AnsiString(Tmp[I]);\r\nend;\r\n\r\nfunction JvStrSplit(const InString: string; const SplitChar, QuoteChar: Char;\r\n var OutStrings: array of string; MaxSplit: Integer): Integer;\r\nvar\r\n I, Len, SplitCounter: Integer;\r\n Ch: Char;\r\n InQuotes: Boolean;\r\nbegin\r\n InQuotes := False;\r\n Len := Length(InString);\r\n for I := Low(OutStrings) to High(OutStrings) do // clear array that is passed in!\r\n OutStrings[I] := '';\r\n\r\n SplitCounter := 0; // ALWAYS ASSUME THAT ZERO IS VALID IN THE OUTGOING ARRAY.\r\n\r\n for I := 1 to Len do\r\n begin\r\n Ch := InString[I];\r\n if (Ch = SplitChar) and not InQuotes then\r\n begin\r\n Inc(SplitCounter);\r\n if SplitCounter > MaxSplit then\r\n begin\r\n Result := -1; // Error!\r\n Exit;\r\n end;\r\n end\r\n else\r\n begin\r\n OutStrings[SplitCounter] := OutStrings[SplitCounter] + Ch;\r\n if Ch = QuoteChar then\r\n InQuotes := not InQuotes;\r\n end;\r\n end;\r\n Inc(SplitCounter);\r\n Result := SplitCounter;\r\nend;\r\n\r\n// NEW 2004 WP\r\n// JvAnsiStrSplitStrings: was StrSplitStrings.\r\nfunction JvAnsiStrSplitStrings(const InString: AnsiString; const SplitChar, QuoteChar: AnsiChar; OutStrings: TStrings): Integer;\r\nvar\r\n I, Len, SplitCounter: Integer;\r\n Ch: AnsiChar;\r\n InQuotes: Boolean;\r\n OutString: AnsiString;\r\nbegin\r\n InQuotes := False;\r\n Len := Length(InString);\r\n OutStrings.Clear;\r\n SplitCounter := 0; // ALWAYS ASSUME THAT ZERO IS VALID IN THE OUTGOING ARRAY.\r\n\r\n for I := 1 to Len do\r\n begin\r\n Ch := InString[I];\r\n if (Ch = SplitChar) and not InQuotes then\r\n begin\r\n OutStrings.Add(String(OutString));\r\n OutString := '';\r\n Inc(SplitCounter);\r\n end\r\n else\r\n begin\r\n OutString := OutString + Ch;\r\n if Ch = QuoteChar then\r\n InQuotes := not InQuotes;\r\n end;\r\n end;\r\n OutStrings.Add(String(OutString));\r\n Inc(SplitCounter);\r\n Result := SplitCounter;\r\nend;\r\n\r\n//--end NEW--\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvCtrls.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvCtrls.PAS, released May 13, 2000.\r\n\r\nThe Initial Developer of the Original Code is Petr Vones (petr dott v att mujmail dott cz)\r\nPortions created by Petr Vones are Copyright (C) 2000 Petr Vones.\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\n tetardd\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvCtrls.pas 13415 2012-09-10 09:51:54Z obones $\r\n\r\nunit JvCtrls;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Types, Windows, Messages, Classes, Graphics, Controls, StdCtrls, ImgList,\r\n {$IFDEF HAS_UNIT_SYSTEM_UITYPES}\r\n System.UITypes,\r\n {$ENDIF HAS_UNIT_SYSTEM_UITYPES}\r\n JvButton;\r\n\r\n\r\n\r\ntype\r\n TJvImgBtnLayout = (blImageLeft, blImageRight);\r\n\r\n TJvImgBtnKind = (bkCustom, bkOK, bkCancel, bkHelp, bkYes, bkNo, bkClose,\r\n bkAbort, bkRetry, bkIgnore, bkAll);\r\n\r\n TJvCustomImageButton = class;\r\n\r\n TJvImgBtnActionLink = class(TButtonActionLink)\r\n protected\r\n FClient: TJvCustomImageButton;\r\n procedure AssignClient(AClient: TObject); override;\r\n function IsImageIndexLinked: Boolean; override;\r\n procedure SetImageIndex(Value: Integer); override;\r\n end;\r\n\r\n TJvImgBtnDrawEvent = procedure(Sender: TObject; const DrawItemStruct: TDrawItemStruct) of object;\r\n TJvImgBtnAnimIndexEvent = procedure(Sender: TObject; CurrentAnimateFrame: Byte;\r\n var ImageIndex: Integer) of object;\r\n\r\n TJvCustomImageButton = class(TJvCustomButton)\r\n private\r\n FAlignment: TAlignment;\r\n FAnimate: Boolean;\r\n FAnimateFrames: Integer;\r\n FAnimateInterval: Cardinal;\r\n FAnimating: Boolean;\r\n FCanvas: TCanvas;\r\n FCurrentAnimateFrame: Byte;\r\n FImageIndex: TImageIndex;\r\n FImages: TCustomImageList;\r\n FImageChangeLink: TChangeLink;\r\n FIsFocused: Boolean;\r\n FKind: TJvImgBtnKind;\r\n FLayout: TJvImgBtnLayout;\r\n FOwnerDraw: Boolean;\r\n FSpacing: Integer;\r\n FMargin: Integer;\r\n FMouseInControl: Boolean;\r\n FOnButtonDraw: TJvImgBtnDrawEvent;\r\n FOnGetAnimateIndex: TJvImgBtnAnimIndexEvent;\r\n FImageVisible: Boolean;\r\n FFlat: Boolean;\r\n FMustDrawFocusRect: Boolean;\r\n FMustDrawButtonFrame: Boolean;\r\n FDisableDrawDown: Boolean;\r\n procedure ImageListChange(Sender: TObject);\r\n procedure SetAlignment(const Value: TAlignment);\r\n procedure SetAnimate(const Value: Boolean);\r\n procedure SetAnimateFrames(const Value: Integer);\r\n procedure SetAnimateInterval(const Value: Cardinal);\r\n procedure SetImageIndex(const Value: TImageIndex);\r\n procedure SetImages(const Value: TCustomImageList);\r\n procedure SetImageVisible(const Value: Boolean);\r\n procedure SetKind(const Value: TJvImgBtnKind);\r\n procedure SetLayout(const Value: TJvImgBtnLayout);\r\n procedure SetOwnerDraw(const Value: Boolean);\r\n procedure SetMargin(const Value: Integer);\r\n procedure SetSpacing(const Value: Integer);\r\n procedure SetFlat(const Value: Boolean);\r\n procedure SetMustDrawButtonFrame(const Value: Boolean);\r\n procedure SetMustDrawFocusRect(const Value: Boolean);\r\n procedure CNDrawItem(var Msg: TWMDrawItem); message CN_DRAWITEM;\r\n procedure CNMeasureItem(var Msg: TWMMeasureItem); message CN_MEASUREITEM;\r\n procedure WMDestroy(var Msg: TWMDestroy); message WM_DESTROY;\r\n procedure WMLButtonDblClk(var Msg: TWMLButtonDblClk); message WM_LBUTTONDBLCLK;\r\n procedure WMTimer(var Msg: TWMTimer); message WM_TIMER;\r\n protected\r\n procedure Notification(AComponent: TComponent; Operation: TOperation); override;\r\n procedure ActionChange(Sender: TObject; CheckDefaults: Boolean); override;\r\n procedure CalcButtonParts(ButtonRect: TRect; var RectText, RectImage: TRect); virtual;\r\n procedure CreateParams(var Params: TCreateParams); override;\r\n procedure CreateWnd; override;\r\n procedure DrawItem(const DrawItemStruct: TDrawItemStruct); dynamic;\r\n function GetActionLinkClass: TControlActionLinkClass; override;\r\n function GetCustomCaption: string; dynamic;\r\n function GetImageIndex: Integer;\r\n function GetImageList: TCustomImageList;\r\n function GetKindImageIndex: Integer;\r\n function GetRealCaption: string; override;\r\n procedure InvalidateImage;\r\n function IsImageVisible: Boolean;\r\n procedure Loaded; override;\r\n procedure SetButtonStyle(ADefault: Boolean); override;\r\n procedure ShowNextFrame;\r\n procedure StartAnimate;\r\n procedure StopAnimate;\r\n procedure RestartAnimate;\r\n procedure MouseEnter(Control: TControl); override;\r\n procedure MouseLeave(Control: TControl); override;\r\n procedure EnabledChanged; override;\r\n procedure FontChanged; override;\r\n class procedure InitializeDefaultImageList;\r\n property Alignment: TAlignment read FAlignment write SetAlignment default taCenter;\r\n property Animate: Boolean read FAnimate write SetAnimate default False;\r\n property AnimateFrames: Integer read FAnimateFrames write SetAnimateFrames default 0;\r\n property AnimateInterval: Cardinal read FAnimateInterval write SetAnimateInterval default 200;\r\n property Color default clBtnFace;\r\n property DisableDrawDown: Boolean read FDisableDrawDown write FDisableDrawDown default False;\r\n property Images: TCustomImageList read FImages write SetImages;\r\n property ImageIndex: TImageIndex read FImageIndex write SetImageIndex default -1;\r\n property ImageVisible: Boolean read FImageVisible write SetImageVisible default True;\r\n property Kind: TJvImgBtnKind read FKind write SetKind default bkCustom;\r\n property Flat: Boolean read FFlat write SetFlat default False;\r\n property Layout: TJvImgBtnLayout read FLayout write SetLayout default blImageLeft;\r\n property Margin: Integer read FMargin write SetMargin default -1;\r\n property MustDrawFocusRect: Boolean read FMustDrawFocusRect write SetMustDrawFocusRect default True;\r\n property MustDrawButtonFrame: Boolean read FMustDrawButtonFrame write SetMustDrawButtonFrame default True;\r\n property OwnerDraw: Boolean read FOwnerDraw write SetOwnerDraw default False;\r\n property Spacing: Integer read FSpacing write SetSpacing default 4;\r\n\r\n property OnButtonDraw: TJvImgBtnDrawEvent read FOnButtonDraw write FOnButtonDraw;\r\n property OnGetAnimateIndex: TJvImgBtnAnimIndexEvent read FOnGetAnimateIndex write FOnGetAnimateIndex;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n procedure Click; override;\r\n procedure DrawButtonImage(ImageBounds: TRect); virtual;\r\n procedure DrawButtonFocusRect(const RectContent: TRect); virtual;\r\n procedure DrawButtonFrame(const DrawItemStruct: TDrawItemStruct; var RectContent: TRect); virtual;\r\n procedure DrawButtonText(TextBounds: TRect; TextEnabled: Boolean); virtual;\r\n property Canvas: TCanvas read FCanvas;\r\n property CurrentAnimateFrame: Byte read FCurrentAnimateFrame;\r\n property MouseInControl: Boolean read FMouseInControl;\r\n end;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvImgBtn = class(TJvCustomImageButton)\r\n published\r\n property Alignment;\r\n property Animate;\r\n property AnimateFrames;\r\n property AnimateInterval;\r\n property Color;\r\n property DisableDrawDown;\r\n property DropDownMenu;\r\n property DropArrow;\r\n property Flat;\r\n property HotTrack;\r\n property HotTrackFont;\r\n property HotTrackFontOptions;\r\n property HintColor;\r\n property Images;\r\n property ImageIndex;\r\n property ImageVisible;\r\n property Kind;\r\n property Layout;\r\n property Margin;\r\n property MustDrawFocusRect;\r\n property MustDrawButtonFrame;\r\n property OwnerDraw;\r\n property Spacing;\r\n property WordWrap;\r\n\r\n property OnMouseEnter;\r\n property OnMouseLeave;\r\n property OnParentColorChange;\r\n property OnButtonDraw;\r\n property OnDropDownMenu;\r\n property OnGetAnimateIndex;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvCtrls.pas $';\r\n Revision: '$Revision: 13415 $';\r\n Date: '$Date: 2012-09-10 11:51:54 +0200 (lun. 10 sept. 2012) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n Consts, SysUtils, Forms, ActnList, ExtCtrls,\r\n JvJCLUtils, JvJVCLUtils, JvThemes;\r\n\r\n{$R JvCtrls.res}\r\n\r\nconst\r\n JvImgBtnModalResults: array [TJvImgBtnKind] of TModalResult =\r\n (mrNone, mrOk, mrCancel, mrNone, mrYes, mrNo, mrNone,\r\n mrAbort, mrRetry, mrIgnore, mrAll);\r\n\r\n Alignments: array [TAlignment] of Word = (DT_LEFT, DT_RIGHT, DT_CENTER);\r\n\r\nvar\r\n DefaultImgBtnImagesList: TImageList = nil;\r\n\r\n//=== { TJvImgBtnActionLink } ================================================\r\n\r\nprocedure TJvImgBtnActionLink.AssignClient(AClient: TObject);\r\nbegin\r\n inherited AssignClient(AClient);\r\n FClient := AClient as TJvCustomImageButton;\r\nend;\r\n\r\nfunction TJvImgBtnActionLink.IsImageIndexLinked: Boolean;\r\nbegin\r\n Result := inherited IsImageIndexLinked and\r\n (FClient.ImageIndex = (Action as TCustomAction).ImageIndex);\r\nend;\r\n\r\nprocedure TJvImgBtnActionLink.SetImageIndex(Value: Integer);\r\nbegin\r\n if IsImageIndexLinked then\r\n FClient.ImageIndex := Value;\r\nend;\r\n\r\n//=== { TJvCustomImageButton } ===============================================\r\n\r\nconstructor TJvCustomImageButton.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FFlat := False;\r\n FCanvas := TCanvas.Create;\r\n FAlignment := taCenter;\r\n FAnimateInterval := 200;\r\n FImageChangeLink := TChangeLink.Create;\r\n FImageChangeLink.OnChange := ImageListChange;\r\n FImageIndex := -1;\r\n FImageVisible := True;\r\n FKind := bkCustom;\r\n FLayout := blImageLeft;\r\n FMargin := -1;\r\n FSpacing := 4;\r\n FMustDrawFocusRect := True;\r\n FMustDrawButtonFrame := True;\r\n Color := clBtnFace;\r\n InitializeDefaultImageList;\r\nend;\r\n\r\ndestructor TJvCustomImageButton.Destroy;\r\nbegin\r\n FreeAndNil(FImageChangeLink);\r\n inherited Destroy;\r\n // (rom) destroy Canvas AFTER inherited Destroy\r\n FreeAndNil(FCanvas);\r\nend;\r\n\r\nprocedure TJvCustomImageButton.Notification(AComponent: TComponent;\r\n Operation: TOperation);\r\nbegin\r\n inherited Notification(AComponent, Operation);\r\n if (Operation = opRemove) and (AComponent = Images) then\r\n Images := nil;\r\nend;\r\n\r\nprocedure TJvCustomImageButton.CreateParams(var Params: TCreateParams);\r\nbegin\r\n inherited CreateParams(Params);\r\n with Params do\r\n Style := Style or BS_OWNERDRAW;\r\nend;\r\n\r\nprocedure TJvCustomImageButton.CreateWnd;\r\nbegin\r\n inherited CreateWnd;\r\n if FAnimate then\r\n StartAnimate;\r\nend;\r\n\r\nprocedure TJvCustomImageButton.ActionChange(Sender: TObject; CheckDefaults: Boolean);\r\nbegin\r\n inherited ActionChange(Sender, CheckDefaults);\r\n if Sender is TCustomAction then\r\n with TCustomAction(Sender) do\r\n begin\r\n if ActionList <> nil then\r\n Self.SetImages(ActionList.Images);\r\n Self.SetImageIndex(ImageIndex);\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomImageButton.CalcButtonParts(ButtonRect: TRect; var RectText, RectImage: TRect);\r\nvar\r\n BlockWidth, ButtonWidth, ButtonHeight, BlockMargin, InternalSpacing: Integer;\r\n Flags: Integer;\r\nbegin\r\n if IsImageVisible then\r\n begin\r\n with GetImageList do\r\n SetRect(RectImage, 0, 0, Width - 1, Height - 1);\r\n InternalSpacing := Spacing;\r\n end\r\n else\r\n begin\r\n SetRect(RectImage, 0, 0, 0, 0);\r\n InternalSpacing := 0;\r\n end;\r\n\r\n // In order to take WordWrap into account, we MUST pass a non zero rectangle\r\n // to DrawText and so we must calculate a original bounding rectangle\r\n SetRect(RectText, 0, 0, 0, 0);\r\n RectText.Right := ButtonRect.Right - ButtonRect.Left - (RectImage.Right - RectImage.Left);\r\n RectText.Bottom := ButtonRect.Bottom;\r\n if FAlignment <> taCenter then\r\n begin\r\n if RectText.Right < Width - RectImage.Right - 18 then\r\n RectText.Right := Width - RectImage.Right - 18;\r\n end;\r\n Flags := DT_CALCRECT or Alignments[FAlignment];\r\n if WordWrap then\r\n Flags := Flags or DT_WORDBREAK;\r\n DrawText(Canvas, PChar(GetRealCaption), -1, RectText, Flags);\r\n\r\n // Now offset the rectangles according to layout and spacings\r\n BlockWidth := RectImage.Right + InternalSpacing + RectText.Right;\r\n ButtonWidth := ButtonRect.Right - ButtonRect.Left;\r\n if (Margin = -1) or (Alignment = taCenter) then\r\n begin\r\n BlockMargin := (ButtonWidth - BlockWidth) div 2\r\n end\r\n else\r\n begin\r\n if Alignment = taRightJustify then\r\n BlockMargin := ButtonWidth - BlockWidth - Margin\r\n else\r\n BlockMargin := Margin;\r\n end;\r\n\r\n case Layout of\r\n blImageLeft:\r\n begin\r\n OffsetRect(RectImage, BlockMargin, 0);\r\n OffsetRect(RectText, RectImage.Right + InternalSpacing, 0);\r\n end;\r\n blImageRight:\r\n begin\r\n OffsetRect(RectImage, ButtonWidth - BlockMargin - RectImage.Right, 0);\r\n OffsetRect(RectText, ButtonWidth - BlockWidth - BlockMargin, 0);\r\n end;\r\n end;\r\n ButtonHeight := ButtonRect.Bottom - ButtonRect.Top;\r\n OffsetRect(RectImage, ButtonRect.Left, (ButtonHeight - RectImage.Bottom) div 2 + ButtonRect.Top);\r\n OffsetRect(RectText, ButtonRect.Left, (ButtonHeight - RectText.Bottom) div 2 + ButtonRect.Top);\r\nend;\r\n\r\nprocedure TJvCustomImageButton.Click;\r\nvar\r\n Form: TCustomForm;\r\n Control: TWinControl;\r\nbegin\r\n case FKind of\r\n bkClose:\r\n begin\r\n Form := GetParentForm(Self);\r\n if Form <> nil then\r\n Form.Close\r\n else\r\n inherited Click;\r\n end;\r\n bkHelp:\r\n begin\r\n Control := Self;\r\n while (Control <> nil) and (Control.HelpContext = 0) do\r\n Control := Control.Parent;\r\n if Control <> nil then\r\n Application.HelpContext(Control.HelpContext)\r\n else\r\n inherited Click;\r\n end;\r\n else\r\n inherited Click;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomImageButton.EnabledChanged;\r\nbegin\r\n inherited EnabledChanged;\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvCustomImageButton.FontChanged;\r\nbegin\r\n inherited FontChanged;\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvCustomImageButton.MouseEnter(Control: TControl);\r\nbegin\r\n if csDesigning in ComponentState then\r\n Exit;\r\n if not FMouseInControl and Enabled and (GetCapture = NullHandle) then\r\n begin\r\n FMouseInControl := True;\r\n inherited MouseEnter(Control);\r\n {$IFDEF JVCLThemesEnabled}\r\n if ThemeServices.{$IFDEF RTL230_UP}Enabled{$ELSE}ThemesEnabled{$ENDIF RTL230_UP} then\r\n Repaint\r\n else\r\n {$ENDIF JVCLThemesEnabled}\r\n if Flat then\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomImageButton.MouseLeave(Control: TControl);\r\nbegin\r\n if csDesigning in ComponentState then\r\n Exit;\r\n if FMouseInControl and Enabled and not Dragging then\r\n begin\r\n FMouseInControl := False;\r\n inherited MouseLeave(Control);\r\n {$IFDEF JVCLThemesEnabled}\r\n if ThemeServices.{$IFDEF RTL230_UP}Enabled{$ELSE}ThemesEnabled{$ENDIF RTL230_UP} then\r\n Repaint\r\n else\r\n {$ENDIF JVCLThemesEnabled}\r\n if Flat then\r\n Invalidate;\r\n end;\r\nend;\r\n\r\n\r\n\r\nprocedure TJvCustomImageButton.CNDrawItem(var Msg: TWMDrawItem);\r\nbegin\r\n if csDestroying in ComponentState then\r\n Exit;\r\n FCanvas.Handle := Msg.DrawItemStruct.hDC;\r\n try\r\n FCanvas.Font := Font;\r\n if FOwnerDraw and Assigned(FOnButtonDraw) then\r\n FOnButtonDraw(Self, Msg.DrawItemStruct^)\r\n else\r\n DrawItem(Msg.DrawItemStruct^);\r\n finally\r\n FCanvas.Handle := 0;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomImageButton.CNMeasureItem(var Msg: TWMMeasureItem);\r\nbegin\r\n with Msg.MeasureItemStruct^ do\r\n begin\r\n itemWidth := Width;\r\n itemHeight := Height;\r\n end;\r\nend;\r\n\r\n\r\n\r\n\r\n\r\nprocedure TJvCustomImageButton.DrawButtonFocusRect(const RectContent: TRect);\r\nbegin\r\n if FMustDrawFocusRect and FIsFocused and not (csDestroying in ComponentState) then\r\n begin\r\n FCanvas.Pen.Color := clWindowFrame;\r\n FCanvas.Brush.Color := clBtnFace;\r\n DrawFocusRect(FCanvas.Handle, RectContent);\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomImageButton.DrawButtonFrame(const DrawItemStruct: TDrawItemStruct; var RectContent: TRect);\r\nvar\r\n IsDown, IsEnabled, IsDefault: Boolean;\r\n R: TRect;\r\n Flags: DWORD;\r\n {$IFDEF JVCLThemesEnabled}\r\n Details: TThemedElementDetails;\r\n Button: TThemedButton;\r\n {$ENDIF JVCLThemesEnabled}\r\nbegin\r\n if csDestroying in ComponentState then\r\n Exit;\r\n with DrawItemStruct do\r\n begin\r\n IsEnabled := itemState and ODS_DISABLED = 0;\r\n IsDown := (itemState and ODS_SELECTED <> 0) and IsEnabled;\r\n IsDefault := itemState and ODS_FOCUS <> 0;\r\n end;\r\n\r\n {$IFDEF JVCLThemesEnabled}\r\n if ThemeServices.{$IFDEF RTL230_UP}Enabled{$ELSE}ThemesEnabled{$ENDIF RTL230_UP} then\r\n begin\r\n if not IsEnabled then\r\n Button := tbPushButtonDisabled\r\n else\r\n if IsDown then\r\n Button := tbPushButtonPressed\r\n else\r\n if FMouseInControl then\r\n Button := tbPushButtonHot\r\n else\r\n if IsDefault then\r\n Button := tbPushButtonDefaulted\r\n else\r\n Button := tbPushButtonNormal;\r\n\r\n Details := ThemeServices.GetElementDetails(Button);\r\n // Parent background.\r\n ThemeServices.DrawParentBackground(Handle, DrawItemStruct.hDC, @Details, True);\r\n // Button shape.\r\n if FMustDrawButtonFrame then\r\n ThemeServices.DrawElement(DrawItemStruct.hDC, Details, DrawItemStruct.rcItem);\r\n // Return content rect\r\n ThemeServices.GetElementContentRect(FCanvas.Handle, Details, DrawItemStruct.rcItem, RectContent);\r\n end\r\n else\r\n {$ENDIF JVCLThemesEnabled}\r\n begin\r\n R := ClientRect;\r\n\r\n if Flat then\r\n begin\r\n FCanvas.Brush.Color := Color;\r\n FCanvas.FillRect(R); // (p3) TWinControls don't support Transparent anyway\r\n if FMustDrawButtonFrame and\r\n (FMouseInControl or FIsFocused or (csDesigning in ComponentState)) then\r\n begin\r\n if IsDown then\r\n Frame3D(FCanvas, R, clBtnShadow, clBtnHighlight, 1)\r\n else\r\n Frame3D(FCanvas, R, clBtnHighlight, clBtnShadow, 1);\r\n end;\r\n end\r\n else\r\n begin\r\n Flags := DFCS_BUTTONPUSH or DFCS_ADJUSTRECT;\r\n if IsDown then\r\n Flags := Flags or DFCS_PUSHED;\r\n if not IsEnabled then\r\n Flags := Flags or DFCS_INACTIVE;\r\n\r\n if FIsFocused or IsDefault then\r\n begin\r\n if FMustDrawButtonFrame then\r\n begin\r\n if not IsEnabled then\r\n FCanvas.Pen.Color := clInactiveCaption\r\n else\r\n FCanvas.Pen.Color := clWindowFrame;\r\n end\r\n else\r\n FCanvas.Pen.Color := Color;\r\n FCanvas.Pen.Width := 1;\r\n FCanvas.Brush.Style := bsClear;\r\n FCanvas.Rectangle(R.Left, R.Top, R.Right, R.Bottom);\r\n InflateRect(R, -1, -1);\r\n end;\r\n\r\n if IsDown then\r\n begin\r\n if FMustDrawButtonFrame then\r\n FCanvas.Pen.Color := clBtnShadow\r\n else\r\n FCanvas.Pen.Color := Color;\r\n FCanvas.Pen.Width := 1;\r\n FCanvas.Brush.Color := clBtnFace;\r\n FCanvas.Rectangle(R.Left, R.Top, R.Right, R.Bottom);\r\n InflateRect(R, -1, -1);\r\n end\r\n else\r\n begin\r\n if FMustDrawButtonFrame Then\r\n DrawFrameControl(FCanvas.Handle, R, DFC_BUTTON, Flags);\r\n end;\r\n FCanvas.Brush.Color := Color;\r\n FCanvas.FillRect(R);\r\n end;\r\n\r\n // Return content rect\r\n RectContent := ClientRect;\r\n InflateRect(RectContent, -4, -4);\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomImageButton.DrawButtonImage(ImageBounds: TRect);\r\nbegin\r\n if not (csDestroying in ComponentState) then\r\n begin\r\n if IsImageVisible then\r\n if Assigned(FImages) then\r\n FImages.Draw(FCanvas, ImageBounds.Left, ImageBounds.Top, GetImageIndex, Enabled)\r\n else\r\n DefaultImgBtnImagesList.Draw(FCanvas, ImageBounds.Left, ImageBounds.Top, GetKindImageIndex, Enabled);\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomImageButton.DrawButtonText(TextBounds: TRect; TextEnabled: Boolean);\r\nvar\r\n Flags: DWORD;\r\n RealCaption: string;\r\nbegin\r\n Flags := DrawTextBiDiModeFlags(DT_VCENTER or Alignments[FAlignment]);\r\n if WordWrap then\r\n Flags := Flags or DT_WORDBREAK;\r\n\r\n RealCaption := GetRealCaption;\r\n with Canvas do\r\n begin\r\n Brush.Style := bsClear;\r\n if not TextEnabled then\r\n begin\r\n OffsetRect(TextBounds, 1, 1);\r\n Font.Color := clBtnHighlight;\r\n DrawText(Canvas, RealCaption, Length(RealCaption), TextBounds, Flags);\r\n OffsetRect(TextBounds, -1, -1);\r\n Font.Color := clBtnShadow;\r\n DrawText(Canvas, RealCaption, Length(RealCaption), TextBounds, Flags);\r\n end\r\n else\r\n DrawText(Canvas, RealCaption, Length(RealCaption), TextBounds, Flags);\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomImageButton.DrawItem(const DrawItemStruct: TDrawItemStruct);\r\nvar\r\n R, RectContent, RectText, RectImage, RectArrow: TRect;\r\nbegin\r\n DrawButtonFrame(DrawItemStruct, RectContent);\r\n\r\n //R := ClientRect;\r\n //InflateRect(R, -4, -4);\r\n R := RectContent;\r\n if not FDisableDrawDown and (DrawItemStruct.itemState and ODS_SELECTED <> 0) and Enabled then\r\n begin\r\n {$IFDEF JVCLThemesEnabled}\r\n if ThemeServices.{$IFDEF RTL230_UP}Enabled{$ELSE}ThemesEnabled{$ENDIF RTL230_UP} then\r\n OffsetRect(R, 1, 0)\r\n else\r\n {$ENDIF JVCLThemesEnabled}\r\n OffsetRect(R, 1, 1);\r\n end;\r\n\r\n CalcButtonParts(R, RectText, RectImage);\r\n if DropArrow and Assigned(DropDownMenu) then\r\n begin\r\n RectArrow := Rect(Width - 16, Height div 2, Width - 9, Height div 2 + 7);\r\n if (DrawItemStruct.itemState and ODS_SELECTED <> 0) then\r\n OffsetRect(RectArrow, 1, 1);\r\n DrawDropArrow(FCanvas, RectArrow);\r\n if (DrawItemStruct.itemState and ODS_SELECTED <> 0) then\r\n OffsetRect(RectContent, 1, -1)\r\n end;\r\n DrawButtonText(RectText, Enabled);\r\n DrawButtonImage(RectImage);\r\n DrawButtonFocusRect(RectContent);\r\nend;\r\n\r\nfunction TJvCustomImageButton.GetActionLinkClass: TControlActionLinkClass;\r\nbegin\r\n Result := TJvImgBtnActionLink;\r\nend;\r\n\r\nfunction TJvCustomImageButton.GetCustomCaption: string;\r\nconst\r\n Captions: array [TJvImgBtnKind] of string =\r\n ('', SOKButton, SCancelButton, SHelpButton, SYesButton, SNoButton,\r\n SCloseButton, SAbortButton, SRetryButton, SIgnoreButton, SAllButton);\r\nbegin\r\n Result := Captions[FKind];\r\nend;\r\n\r\nfunction TJvCustomImageButton.GetImageIndex: Integer;\r\nbegin\r\n if FAnimating then\r\n begin\r\n Result := FImageIndex + FCurrentAnimateFrame - 1;\r\n if Assigned(FOnGetAnimateIndex) then\r\n FOnGetAnimateIndex(Self, FCurrentAnimateFrame, Result);\r\n end\r\n else\r\n Result := FImageIndex;\r\nend;\r\n\r\nfunction TJvCustomImageButton.GetImageList: TCustomImageList;\r\nbegin\r\n if Assigned(FImages) then\r\n Result := FImages\r\n else\r\n Result := DefaultImgBtnImagesList;\r\nend;\r\n\r\nfunction TJvCustomImageButton.GetKindImageIndex: Integer;\r\nconst\r\n ImageKindIndexes: array [TJvImgBtnKind] of Integer =\r\n (-1, 2, 4, 0, 3, 1, 5, 8, 6, 9, 7);\r\nbegin\r\n Result := ImageKindIndexes[FKind];\r\nend;\r\n\r\nfunction TJvCustomImageButton.GetRealCaption: string;\r\nbegin\r\n if (FKind <> bkCustom) and (Caption = '') then\r\n Result := GetCustomCaption\r\n else\r\n Result := inherited GetRealCaption;\r\nend;\r\n\r\nprocedure TJvCustomImageButton.ImageListChange(Sender: TObject);\r\nbegin\r\n InvalidateImage;\r\nend;\r\n\r\nclass procedure TJvCustomImageButton.InitializeDefaultImageList;\r\nbegin\r\n if not Assigned(DefaultImgBtnImagesList) then\r\n begin\r\n DefaultImgBtnImagesList := TImageList.CreateSize(18, 18);\r\n DefaultImgBtnImagesList.ResourceLoad(rtBitmap, 'JvCustomImageButtonDEFAULT', clOlive);\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomImageButton.InvalidateImage;\r\nbegin\r\n Invalidate;\r\nend;\r\n\r\nfunction TJvCustomImageButton.IsImageVisible: Boolean;\r\nbegin\r\n Result := FImageVisible and\r\n ((Assigned(FImages) and (GetImageIndex <> -1)) or\r\n (not Assigned(FImages) and (FKind <> bkCustom)));\r\nend;\r\n\r\nprocedure TJvCustomImageButton.Loaded;\r\nbegin\r\n inherited Loaded;\r\n if FAnimate then\r\n StartAnimate;\r\nend;\r\n\r\nprocedure TJvCustomImageButton.RestartAnimate;\r\nbegin\r\n if FAnimating then\r\n begin\r\n StopAnimate;\r\n StartAnimate;\r\n InvalidateImage;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomImageButton.SetAlignment(const Value: TAlignment);\r\nbegin\r\n if FAlignment <> Value then\r\n begin\r\n FAlignment := Value;\r\n\r\n // For the alignment to be taken into account, the Margin value must\r\n // not be equal to -1. A change of Alignment indicates that the user\r\n // does not want the -1 margin value to take precedence\r\n if Margin = -1 then\r\n FMargin := 0;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomImageButton.SetAnimate(const Value: Boolean);\r\nbegin\r\n if FAnimate <> Value then\r\n begin\r\n FAnimate := Value;\r\n if Value then\r\n StartAnimate\r\n else\r\n StopAnimate;\r\n InvalidateImage;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomImageButton.SetAnimateFrames(const Value: Integer);\r\nbegin\r\n if FAnimateFrames <> Value then\r\n begin\r\n FAnimateFrames := Value;\r\n RestartAnimate;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomImageButton.SetAnimateInterval(const Value: Cardinal);\r\nbegin\r\n if FAnimateInterval <> Value then\r\n begin\r\n FAnimateInterval := Value;\r\n RestartAnimate;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomImageButton.SetButtonStyle(ADefault: Boolean);\r\nbegin\r\n if ADefault <> FIsFocused then\r\n begin\r\n FIsFocused := ADefault;\r\n Refresh;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomImageButton.SetImageIndex(const Value: TImageIndex);\r\nbegin\r\n if FImageIndex <> Value then\r\n begin\r\n FImageIndex := Value;\r\n InvalidateImage;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomImageButton.SetImages(const Value: TCustomImageList);\r\nbegin\r\n ReplaceImageListReference(Self, Value, FImages, FImageChangeLink);\r\n if FImages = nil then\r\n SetImageIndex(-1);\r\n InvalidateImage;\r\nend;\r\n\r\nprocedure TJvCustomImageButton.SetImageVisible(const Value: Boolean);\r\nbegin\r\n if FImageVisible <> Value then\r\n begin\r\n FImageVisible := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomImageButton.SetKind(const Value: TJvImgBtnKind);\r\nbegin\r\n if FKind <> Value then\r\n begin\r\n if Value <> bkCustom then\r\n begin\r\n Default := Value in [bkOK, bkYes];\r\n Cancel := Value in [bkCancel, bkNo];\r\n if not (csLoading in ComponentState) and (FKind = bkCustom) then\r\n begin\r\n Caption := '';\r\n Images := nil;\r\n end;\r\n end;\r\n ModalResult := JvImgBtnModalResults[Value];\r\n FKind := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomImageButton.SetLayout(const Value: TJvImgBtnLayout);\r\nbegin\r\n if FLayout <> Value then\r\n begin\r\n FLayout := Value;\r\n if (csDesigning in ComponentState) and (FAlignment <> taCenter) then\r\n case FLayout of\r\n blImageLeft: FAlignment := taLeftJustify;\r\n blImageRight: FAlignment := taRightJustify;\r\n end;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomImageButton.SetMargin(const Value: Integer);\r\nbegin\r\n if (FMargin <> Value) and (Value >= -1) then\r\n begin\r\n FMargin := Value;\r\n\r\n // Setting the value to -1 indicates that the user wants the alignment\r\n // to be centered, so we force the value. This ensure coherence between\r\n // this property and the Alignment property.\r\n if (Value = -1) and (Alignment <> taCenter) then\r\n FAlignment := taCenter;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomImageButton.SetOwnerDraw(const Value: Boolean);\r\nbegin\r\n if FOwnerDraw <> Value then\r\n begin\r\n FOwnerDraw := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomImageButton.SetSpacing(const Value: Integer);\r\nbegin\r\n if FSpacing <> Value then\r\n begin\r\n FSpacing := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomImageButton.SetFlat(const Value: Boolean);\r\nbegin\r\n if FFlat <> Value then\r\n begin\r\n FFlat := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomImageButton.SetMustDrawButtonFrame(const Value: Boolean);\r\nbegin\r\n if FMustDrawButtonFrame <> Value Then\r\n begin\r\n FMustDrawButtonFrame := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomImageButton.SetMustDrawFocusRect(const Value: Boolean);\r\nbegin\r\n if FMustDrawFocusRect <> Value Then\r\n begin\r\n FMustDrawFocusRect := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomImageButton.ShowNextFrame;\r\nbegin\r\n Inc(FCurrentAnimateFrame);\r\n if FCurrentAnimateFrame > FAnimateFrames then\r\n FCurrentAnimateFrame := 1;\r\n InvalidateImage;\r\nend;\r\n\r\nprocedure TJvCustomImageButton.StartAnimate;\r\nbegin\r\n if ComponentState * [csDesigning, csLoading] = [] then\r\n begin\r\n DoubleBuffered := True;\r\n FCurrentAnimateFrame := 0;\r\n ShowNextFrame;\r\n OSCheck(SetTimer(Handle, 1, FAnimateInterval, nil) <> 0);\r\n FAnimating := True;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomImageButton.StopAnimate;\r\nbegin\r\n if FAnimating then\r\n begin\r\n KillTimer(Handle, 1);\r\n FCurrentAnimateFrame := 0;\r\n DoubleBuffered := False;\r\n {$IFDEF COMPILER12_UP}\r\n ParentDoubleBuffered := False;\r\n {$ENDIF COMPILER12_UP}\r\n FAnimating := False;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomImageButton.WMDestroy(var Msg: TWMDestroy);\r\nbegin\r\n StopAnimate;\r\n inherited;\r\nend;\r\n\r\nprocedure TJvCustomImageButton.WMLButtonDblClk(var Msg: TWMLButtonDblClk);\r\nbegin\r\n Perform(WM_LBUTTONDOWN, Msg.Keys, {$IFDEF RTL230_UP}PointToLParam{$ELSE}LPARAM{$ENDIF RTL230_UP}(Msg.Pos));\r\nend;\r\n\r\nprocedure TJvCustomImageButton.WMTimer(var Msg: TWMTimer);\r\nbegin\r\n if Msg.TimerID = 1 then\r\n begin\r\n ShowNextFrame;\r\n Msg.Result := 1;\r\n end\r\n else\r\n inherited;\r\nend;\r\n\r\ninitialization\r\n {$IFDEF UNITVERSIONING}\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n {$ENDIF UNITVERSIONING}\r\n\r\nfinalization\r\n FreeAndNil(DefaultImgBtnImagesList);\r\n {$IFDEF UNITVERSIONING}\r\n UnregisterUnitVersion(HInstance);\r\n {$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvCursor.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvCursor.PAS, released on 2004-03-14.\r\n\r\nThe Initial Developer of the Original Code is Peter Thornqvist\r\nPortions created by Peter Thornqvist are Copyright (C) 2004 Peter Thornqvist.\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n\r\nDescription:\r\n A TGraphic that can display cursors\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvCursor.pas 12461 2009-08-14 17:21:33Z obones $\r\n\r\nunit JvCursor;\r\n\r\n{$I jvcl.inc}\r\n{$I windowsonly.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, Classes, Graphics;\r\n\r\ntype\r\n TJvCursorImage = class(TGraphic)\r\n private\r\n FHandle: HCURSOR;\r\n protected\r\n procedure Draw(ACanvas: TCanvas; const Rect: TRect); override;\r\n function GetEmpty: Boolean; override;\r\n function GetHeight: Integer; override;\r\n function GetWidth: Integer; override;\r\n procedure SetHeight(Value: Integer); override;\r\n procedure SetWidth(Value: Integer); override;\r\n procedure AssignTo(Dest: TPersistent); override;\r\n public\r\n procedure Assign(Source: TPersistent); override;\r\n destructor Destroy; override;\r\n procedure LoadFromClipboardFormat(AFormat: Word; AData: THandle; APalette: HPALETTE); override;\r\n procedure LoadFromFile(const FileName: string); override;\r\n procedure LoadFromStream(Stream: TStream); override;\r\n procedure LoadFromResourceID(Instance: THandle; ResID: Integer); virtual;\r\n procedure LoadFromResourceName(Instance: THandle; const ResName: string); virtual;\r\n procedure SaveToClipboardFormat(var AFormat: Word; var AData: THandle; var APalette: HPALETTE); override;\r\n procedure SaveToStream(Stream: TStream); override;\r\n property Handle: HCURSOR read FHandle;\r\n end;\r\n\r\nvar\r\n CF_CURSOR: UINT; { Clipboard format for cursor }\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvCursor.pas $';\r\n Revision: '$Revision: 12461 $';\r\n Date: '$Date: 2009-08-14 19:21:33 +0200 (ven. 14 août 2009) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n SysUtils, Consts,\r\n JvResources;\r\n\r\nfunction CopyCursor(pcur: HCURSOR): HCURSOR;\r\nbegin\r\n Result := HCURSOR(CopyIcon(HICON(pcur)));\r\nend;\r\n\r\nprocedure DestroyAndNilCursor(var AHandle: HCURSOR);\r\nbegin\r\n if AHandle <> 0 then\r\n DestroyCursor(AHandle);\r\n AHandle := 0;\r\nend;\r\n\r\ndestructor TJvCursorImage.Destroy;\r\nbegin\r\n DestroyAndNilCursor(FHandle);\r\n inherited Destroy;\r\nend;\r\n\r\n// Cursor are *not* always transparent: it depends on how you draw them ;)\r\n\r\nprocedure TJvCursorImage.Draw(ACanvas: TCanvas; const Rect: TRect);\r\nconst\r\n cTransparent: array [Boolean] of DWORD = (DI_IMAGE, DI_NORMAL);\r\nbegin\r\n with Rect do\r\n DrawIconEx(ACanvas.Handle, Left, Top, Handle, Right - Left, Bottom - Top,\r\n 0, 0, cTransparent[Transparent]);\r\nend;\r\n\r\nfunction TJvCursorImage.GetEmpty: Boolean;\r\nbegin\r\n Result := (FHandle = 0);\r\nend;\r\n\r\nfunction TJvCursorImage.GetHeight: Integer;\r\nbegin\r\n Result := GetSystemMetrics(SM_CYCURSOR);\r\nend;\r\n\r\nfunction TJvCursorImage.GetWidth: Integer;\r\nbegin\r\n Result := GetSystemMetrics(SM_CXCURSOR);\r\nend;\r\n\r\nprocedure TJvCursorImage.LoadFromClipboardFormat(AFormat: Word; AData: THandle; APalette: HPALETTE);\r\nvar\r\n Hnd: HCURSOR;\r\nbegin\r\n if AFormat <> CF_CURSOR then\r\n raise EInvalidGraphic.CreateRes(@SUnknownClipboardFormat);\r\n Hnd := CopyCursor(AData);\r\n if Hnd <> 0 then\r\n begin\r\n DestroyAndNilCursor(FHandle);\r\n FHandle := Hnd;\r\n end;\r\nend;\r\n\r\nprocedure TJvCursorImage.LoadFromFile(const FileName: string);\r\nvar\r\n Hnd: HCURSOR;\r\nbegin\r\n Hnd := LoadCursorFromFile(PChar(FileName));\r\n if Hnd <> 0 then\r\n begin\r\n DestroyAndNilCursor(FHandle);\r\n FHandle := Hnd;\r\n end;\r\nend;\r\n\r\nprocedure TJvCursorImage.LoadFromStream(Stream: TStream);\r\nbegin\r\n raise Exception.CreateRes(@RsECursorLoadFromStream);\r\nend;\r\n\r\nprocedure TJvCursorImage.LoadFromResourceID(Instance: THandle; ResID: Integer);\r\nvar\r\n Hnd: HCURSOR;\r\nbegin\r\n Hnd := LoadCursor(Instance, PChar(ResID));\r\n if Hnd <> 0 then\r\n begin\r\n DestroyAndNilCursor(FHandle);\r\n FHandle := Hnd;\r\n end;\r\nend;\r\n\r\nprocedure TJvCursorImage.LoadFromResourceName(Instance: THandle; const ResName: string);\r\nvar\r\n Hnd: HCURSOR;\r\nbegin\r\n Hnd := LoadCursor(Instance, PChar(ResName));\r\n if Hnd <> 0 then\r\n begin\r\n DestroyAndNilCursor(FHandle);\r\n FHandle := Hnd;\r\n end;\r\nend;\r\n\r\nprocedure TJvCursorImage.SaveToClipboardFormat(var AFormat: Word;\r\n var AData: THandle; var APalette: HPALETTE);\r\nbegin\r\n if Handle <> 0 then\r\n begin\r\n AFormat := CF_CURSOR;\r\n APalette := 0;\r\n AData := CopyCursor(Handle);\r\n end;\r\nend;\r\n\r\nprocedure TJvCursorImage.SaveToStream(Stream: TStream);\r\nbegin\r\n raise Exception.CreateRes(@RsECursorSaveToStream);\r\nend;\r\n\r\nprocedure TJvCursorImage.SetHeight(Value: Integer);\r\nbegin\r\n // just ignore\r\nend;\r\n\r\nprocedure TJvCursorImage.SetWidth(Value: Integer);\r\nbegin\r\n // just ignore\r\nend;\r\n\r\nprocedure TJvCursorImage.Assign(Source: TPersistent);\r\nbegin\r\n if Source = nil then\r\n DestroyAndNilCursor(FHandle)\r\n else\r\n if Source is TJvCursorImage then\r\n begin\r\n DestroyAndNilCursor(FHandle);\r\n if TJvCursorImage(Source).Handle <> 0 then\r\n FHandle := CopyImage(TJvCursorImage(Source).Handle, IMAGE_CURSOR, Width, Height, 0);\r\n end\r\n else\r\n inherited Assign(Source);\r\nend;\r\n\r\nprocedure TJvCursorImage.AssignTo(Dest: TPersistent);\r\nbegin\r\n if Dest is TIcon then\r\n begin\r\n TIcon(Dest).ReleaseHandle;\r\n if Handle <> 0 then\r\n TIcon(Dest).Handle := CopyImage(Handle, IMAGE_CURSOR, Width, Height, 0);\r\n end\r\n else\r\n if Dest is TBitmap then\r\n with TBitmap(Dest) do\r\n begin\r\n Width := Self.Width;\r\n Height := Self.Height;\r\n Transparent := Self.Transparent;\r\n Draw(Canvas, Rect(0, 0, Width, Height));\r\n end\r\n else\r\n inherited AssignTo(Dest);\r\nend;\r\n\r\ninitialization\r\n {$IFDEF UNITVERSIONING}\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n {$ENDIF UNITVERSIONING}\r\n RegisterClass(TJvCursorImage);\r\n CF_CURSOR := RegisterClipboardFormat(PChar(RsCursor));\r\n TPicture.RegisterFileFormat(RsCurExtension, RsCurDescription, TJvCursorImage);\r\n TPicture.RegisterClipboardFormat(CF_CURSOR, TJvCursorImage);\r\n\r\nfinalization\r\n TPicture.UnregisterGraphicClass(TJvCursorImage);\r\n {$IFDEF UNITVERSIONING}\r\n UnregisterUnitVersion(HInstance);\r\n {$ENDIF UNITVERSIONING}\r\n\r\nend." }, { "path": "External/Jedi/Jvcl/run/JvCustomFileMessageDialog.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvCommonDialogD.PAS, released on 2001-02-28.\r\n\r\nThe Initial Developer of the Original Code is Sbastien Buysse [sbuysse att buypin dott com]\r\nPortions created by Sbastien Buysse are Copyright (C) 2001 Sbastien Buysse.\r\nAll Rights Reserved.\r\n\r\nContributor(s): Michael Beck [mbeck att bigfoot dott com].\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvCustomFileMessageDialog.pas 13351 2012-06-13 15:16:00Z obones $\r\n\r\nunit JvCustomFileMessageDialog;\r\n\r\n{$I jvcl.inc}\r\n{$I windowsonly.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, Classes,\r\n Controls,\r\n JvTypes, JvComponentBase;\r\n\r\ntype\r\n TJvCustomFileMessageDialog = class(TJvComponent)\r\n private\r\n FTitle: string;\r\n FOwnerWindow: THandle;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n function Execute: TJvDiskRes; virtual; abstract;\r\n property OwnerWindow: THandle read FOwnerWindow write FOwnerWindow stored False;\r\n published\r\n property Title: string read FTitle write FTitle;\r\n end;\r\n\r\nfunction JvDiskStylesToDWORD(const Style: TJvDiskStyles): DWORD;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvCustomFileMessageDialog.pas $';\r\n Revision: '$Revision: 13351 $';\r\n Date: '$Date: 2012-06-13 17:16:00 +0200 (mer. 13 juin 2012) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n JvSetupApi,\r\n JvResources;\r\n\r\nconst\r\n IDF_NOBROWSE = $00000001;\r\n IDF_NOSKIP = $00000002;\r\n IDF_NODETAILS = $00000004;\r\n IDF_NOCOMPRESSED = $00000008;\r\n IDF_CHECKFIRST = $00000100;\r\n IDF_NOBEEP = $00000200;\r\n IDF_NOFOREGROUND = $00000400;\r\n IDF_WARNIFSKIP = $00000800;\r\n IDF_OEMDISK = DWORD($80000000);\r\n\r\nfunction JvDiskStylesToDWORD(const Style: TJvDiskStyles): DWORD;\r\nbegin\r\n Result := 0;\r\n if idfCheckFirst in Style then\r\n Result := Result or IDF_CHECKFIRST;\r\n if idfNoBeep in Style then\r\n Result := Result or IDF_NOBEEP;\r\n if idfNoBrowse in Style then\r\n Result := Result or IDF_NOBROWSE;\r\n if idfNoCompressed in Style then\r\n Result := Result or IDF_NOCOMPRESSED;\r\n if idfNoDetails in Style then\r\n Result := Result or IDF_NODETAILS;\r\n if idfNoForeground in Style then\r\n Result := Result or IDF_NOFOREGROUND;\r\n if idfNoSkip in Style then\r\n Result := Result or IDF_NOSKIP;\r\n if idfOemDisk in Style then\r\n Result := Result or IDF_OEMDISK;\r\n if idfWarnIfSkip in Style then\r\n Result := Result or IDF_WARNIFSKIP;\r\nend;\r\n\r\n//=== { TJvCustomFileMessageDialog } ===================================================\r\n\r\nconstructor TJvCustomFileMessageDialog.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FTitle := '';\r\n if Owner is TWinControl then\r\n FOwnerWindow := (AOwner as TWinControl).Handle\r\n else\r\n FOwnerWindow := HWND_DESKTOP;\r\n LoadSetupApi;\r\n if not IsSetupApiLoaded then\r\n raise EJVCLException.CreateRes(@RsEErrorSetupDll);\r\nend;\r\n\r\ndestructor TJvCustomFileMessageDialog.Destroy;\r\nbegin\r\n UnloadSetupApi;\r\n inherited Destroy;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend." }, { "path": "External/Jedi/Jvcl/run/JvCustomItemViewer.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvCustomItemViewer.PAS, released on 2003-12-01.\r\n\r\nThe Initial Developer of the Original Code is: Peter Thrnqvist\r\nAll Rights Reserved.\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n TODO:\r\n * keyboard multiselect (ctrl+space)\r\n * caption editing\r\n * drag'n'drop insertion mark\r\n * text for imagelist viewer - DONE\r\n * text layout support (top, bottom) - DONE\r\n * drag'n'drop edge scrolling - DONE (almost, needs some tweaks to look good as well)\r\n * icons don't scale, should be handled differently - DONE (explicitly calls DrawIconEx)\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvCustomItemViewer.pas 13104 2011-09-07 06:50:43Z obones $\r\n\r\nunit JvCustomItemViewer;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Contnrs,\r\n Windows, Messages, Classes, Graphics, Controls, Forms, StdCtrls, ComCtrls,\r\n ExtCtrls,\r\n JvConsts, // for clSkyBlue\r\n JvExControls, JvExForms;\r\n\r\nconst\r\n CM_UNSELECTITEMS = WM_USER + 1;\r\n CM_DELETEITEM = WM_USER + 2;\r\n\r\ntype\r\n TJvItemViewerScrollBar = (tvHorizontal, tvVertical);\r\n TJvCustomItemViewer = class;\r\n\r\n TJvBrushPattern = class(TPersistent)\r\n private\r\n FPattern: TBitmap;\r\n FOddColor: TColor;\r\n FEvenColor: TColor;\r\n FActive: Boolean;\r\n procedure SetEvenColor(const Value: TColor);\r\n procedure SetOddColor(const Value: TColor);\r\n public\r\n function GetBitmap: TBitmap;\r\n constructor Create;\r\n destructor Destroy; override;\r\n\r\n published\r\n property Active: Boolean read FActive write FActive default True;\r\n property EvenColor: TColor read FEvenColor write SetEvenColor default clWhite;\r\n property OddColor: TColor read FOddColor write SetOddColor default clSkyBlue;\r\n end;\r\n\r\n // Base viewer options class. Derive from this when you need to add your own properties\r\n // to a viewer or publish the available ones. Declare a new Options property in\r\n // the viewer class (that only needs to call the inherited Options)\r\n // and override GetOptionsClass to return the property class type\r\n TJvCustomItemViewerOptions = class(TPersistent)\r\n private\r\n FVertSpacing: Integer;\r\n FHorzSpacing: Integer;\r\n FHeight: Integer;\r\n FWidth: Integer;\r\n FScrollBar: TJvItemViewerScrollBar;\r\n FOwner: TJvCustomItemViewer;\r\n FAutoCenter: Boolean;\r\n FSmooth: Boolean;\r\n FTracking: Boolean;\r\n FHotTrack: Boolean;\r\n FMultiSelect: Boolean;\r\n FBrushPattern: TJvBrushPattern;\r\n FLazyRead: Boolean;\r\n FAlignment: TAlignment;\r\n FLayout: TTextLayout;\r\n FShowCaptions: Boolean;\r\n FRightClickSelect: Boolean;\r\n FReduceMemoryUsage: Boolean;\r\n FDragAutoScroll: Boolean;\r\n procedure SetRightClickSelect(const Value: Boolean);\r\n procedure SetShowCaptions(const Value: Boolean);\r\n procedure SetAlignment(const Value: TAlignment);\r\n procedure SetLayout(const Value: TTextLayout);\r\n procedure SetHeight(const Value: Integer);\r\n procedure SetHorzSpacing(const Value: Integer);\r\n procedure SetScrollBar(const Value: TJvItemViewerScrollBar);\r\n procedure SetVertSpacing(const Value: Integer);\r\n procedure SetWidth(const Value: Integer);\r\n procedure SetAutoCenter(const Value: Boolean);\r\n procedure SetSmooth(const Value: Boolean);\r\n procedure SetTracking(const Value: Boolean);\r\n procedure SetHotTrack(const Value: Boolean);\r\n procedure SetMultiSelect(const Value: Boolean);\r\n procedure SetBrushPattern(const Value: TJvBrushPattern);\r\n procedure SetLazyRead(const Value: Boolean);\r\n procedure SetReduceMemoryUsage(const Value: Boolean);\r\n protected\r\n procedure Change; virtual;\r\n public\r\n constructor Create(AOwner: TJvCustomItemViewer); virtual;\r\n destructor Destroy; override;\r\n procedure Assign(Source: TPersistent); override;\r\n protected\r\n property Owner: TJvCustomItemViewer read FOwner;\r\n property Alignment: TAlignment read FAlignment write SetAlignment default taCenter;\r\n property DragAutoScroll: Boolean read FDragAutoScroll write FDragAutoScroll default True;\r\n property Layout: TTextLayout read FLayout write SetLayout default tlBottom;\r\n property Width: Integer read FWidth write SetWidth default 120;\r\n property Height: Integer read FHeight write SetHeight default 120;\r\n property VertSpacing: Integer read FVertSpacing write SetVertSpacing default 4;\r\n property HorzSpacing: Integer read FHorzSpacing write SetHorzSpacing default 4;\r\n property ScrollBar: TJvItemViewerScrollBar read FScrollBar write SetScrollBar default tvVertical;\r\n property ShowCaptions: Boolean read FShowCaptions write SetShowCaptions default True;\r\n property LazyRead: Boolean read FLazyRead write SetLazyRead default True;\r\n property ReduceMemoryUsage: Boolean read FReduceMemoryUsage write SetReduceMemoryUsage default False;\r\n property AutoCenter: Boolean read FAutoCenter write SetAutoCenter;\r\n property Smooth: Boolean read FSmooth write SetSmooth default False;\r\n property Tracking: Boolean read FTracking write SetTracking default True;\r\n property HotTrack: Boolean read FHotTrack write SetHotTrack;\r\n property MultiSelect: Boolean read FMultiSelect write SetMultiSelect;\r\n property BrushPattern: TJvBrushPattern read FBrushPattern write SetBrushPattern;\r\n property RightClickSelect: Boolean read FRightClickSelect write SetRightClickSelect default False;\r\n end;\r\n\r\n TJvItemViewerOptionsClass = class of TJvCustomItemViewerOptions;\r\n\r\n TJvViewerItem = class(TPersistent)\r\n private\r\n FOwner: TJvCustomItemViewer;\r\n FData: Pointer;\r\n FState: TCustomDrawState;\r\n FDeleting: Boolean;\r\n FHint: string;\r\n procedure SetData(const Value: Pointer);\r\n procedure SetState(const Value: TCustomDrawState);\r\n protected\r\n function Changing: Boolean; virtual;\r\n procedure Changed; virtual;\r\n procedure ReduceMemoryUsage; virtual;\r\n public\r\n constructor Create(AOwner: TJvCustomItemViewer); virtual;\r\n procedure Delete;\r\n protected\r\n property Deleting: Boolean read FDeleting;\r\n property Owner: TJvCustomItemViewer read FOwner;\r\n public\r\n property State: TCustomDrawState read FState write SetState;\r\n property Hint: string read FHint write FHint;\r\n property Data: Pointer read FData write SetData;\r\n end;\r\n\r\n TJvViewerItemList = class(TObjectList)\r\n private\r\n function GetItem(Index: Integer): TJvViewerItem;\r\n procedure SetItem(Index: Integer; const Value: TJvViewerItem);\r\n public\r\n property Items[Index: Integer]: TJvViewerItem read GetItem write SetItem; default;\r\n end;\r\n\r\n TJvViewerItemClass = class of TJvViewerItem;\r\n\r\n // TODO\r\n TJvViewerDrawStage = (vdsBeforePaint, vdsAfterPaint);\r\n TJvViewerAdvancedDrawEvent = procedure(Sender: TObject; Stage: TJvViewerDrawStage;\r\n Canvas: TCanvas; R: TRect; var DefaultDraw: Boolean) of object;\r\n TJvViewerAdvancedItemDrawEvent = procedure(Sender: TObject; Stage: TJvViewerDrawStage;\r\n Index: Integer; State: TCustomDrawState; Canvas: TCanvas; ItemRect, TextRect: TRect;\r\n var DefaultDraw: Boolean) of object;\r\n\r\n TJvViewerItemDrawEvent = procedure(Sender: TObject; Index: Integer; State: TCustomDrawState;\r\n Canvas: TCanvas; ItemRect, TextRect: TRect) of object;\r\n TJvViewerItemChangingEvent = procedure(Sender: TObject; Item: TJvViewerItem; var Allow: Boolean) of object;\r\n TJvViewerItemChangedEvent = procedure(Sender: TObject; Item: TJvViewerItem) of object;\r\n TJvViewerItemHintEvent = procedure(Sender: TObject; Index: Integer;\r\n var HintInfo: {$IFDEF RTL200_UP}Controls.{$ENDIF RTL200_UP}THintInfo; var Handled: Boolean) of object;\r\n\r\n TJvCustomItemViewer = class(TJvExScrollingWinControl)\r\n private\r\n FCanvas: TCanvas;\r\n FItems: TJvViewerItemList;\r\n FOptions: TJvCustomItemViewerOptions;\r\n FTopLeft: TPoint;\r\n FItemSize: TSize;\r\n FOnDrawItem: TJvViewerItemDrawEvent;\r\n FDragImages: TDragImageList;\r\n FUpdateCount, FCols, FRows, FTempSelected, FSelectedIndex, FLastHotTrack: Integer;\r\n FBorderStyle: TBorderStyle;\r\n FTopLeftIndex: Integer;\r\n FBottomRightIndex: Integer;\r\n FOnScroll: TNotifyEvent;\r\n FOnOptionsChanged: TNotifyEvent;\r\n FOnItemChanged: TJvViewerItemChangedEvent;\r\n FOnItemChanging: TJvViewerItemChangingEvent;\r\n FScrollTimer: TTimer;\r\n ScrollEdge: Integer;\r\n FOnDeletion: TJvViewerItemChangedEvent;\r\n FOnInsertion: TJvViewerItemChangedEvent;\r\n FOnItemHint: TJvViewerItemHintEvent;\r\n procedure DoScrollTimer(Sender: TObject);\r\n\r\n procedure WMHScroll(var Msg: TWMHScroll); message WM_HSCROLL;\r\n procedure WMVScroll(var Msg: TWMVScroll); message WM_VSCROLL;\r\n procedure WMNCPaint(var Messages: TWMNCPaint); message WM_NCPAINT;\r\n procedure WMPaint(var Msg: TWMPaint); message WM_PAINT;\r\n procedure WMNCHitTest(var Msg: TMessage); message WM_NCHITTEST;\r\n procedure WMCancelMode(var Msg: TWMCancelMode); message WM_CANCELMODE;\r\n\r\n procedure CMUnselectItem(var Msg: TMessage); message CM_UNSELECTITEMS;\r\n procedure CMDeleteItem(var Msg: TMessage); message CM_DELETEITEM;\r\n procedure CMCtl3DChanged(var Msg: TMessage); message CM_CTL3DCHANGED;\r\n\r\n procedure SetOptions(const Value: TJvCustomItemViewerOptions);\r\n function GetItems(Index: Integer): TJvViewerItem;\r\n procedure SetItems(Index: Integer; const Value: TJvViewerItem);\r\n procedure SetSelectedIndex(const Value: Integer);\r\n procedure SetBorderStyle(const Value: TBorderStyle);\r\n function GetCount: Integer;\r\n procedure SetCount(const Value: Integer);\r\n function GetSelected(Item: TJvViewerItem): Boolean;\r\n procedure SetSelected(Item: TJvViewerItem; const Value: Boolean);\r\n procedure StopScrollTimer;\r\n protected\r\n procedure MouseLeave(Control: TControl); override;\r\n procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;\r\n procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;\r\n\r\n procedure GetDlgCode(var Code: TDlgCodes); override;\r\n procedure BoundsChanged; override;\r\n procedure FocusSet(PrevWnd: THandle); override;\r\n\r\n procedure DragOver(Source: TObject; X, Y: Integer; State: TDragState; var Accept: Boolean); override;\r\n procedure DoEndDrag(Sender: TObject; X, Y: Integer); override;\r\n procedure DragCanceled; override;\r\n\r\n procedure DoUnSelectItems(ExcludeIndex: Integer);\r\n procedure ToggleSelection(Index: Integer; SetSelection: Boolean);\r\n procedure ShiftSelection(Index: Integer; SetSelection: Boolean);\r\n function FindFirstSelected: Integer;\r\n function FindLastSelected: Integer;\r\n procedure UpdateAll;\r\n procedure UpdateOffset;\r\n procedure CalcIndices;\r\n procedure DoReduceMemory;\r\n\r\n procedure CheckHotTrack;\r\n procedure InvalidateClipRect(R: TRect);\r\n function ItemRect(Index: Integer; IncludeSpacing: Boolean): TRect;\r\n function ColRowToIndex(ACol, ARow: Integer): Integer;\r\n procedure OptionsChanged;\r\n procedure Changed;\r\n\r\n function GetTextRect(const S: WideString; var ItemRect: TRect): TRect; virtual;\r\n function GetTextHeight: Integer; virtual;\r\n function GetDragImages: TDragImageList; override;\r\n function DoMouseWheel(Shift: TShiftState; WheelDelta: Integer;\r\n MousePos: TPoint): Boolean; override;\r\n procedure KeyDown(var Key: Word; Shift: TShiftState); override;\r\n procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;\r\n procedure Paint; virtual;\r\n procedure PaintWindow(DC: HDC); override;\r\n procedure CreateParams(var Params: TCreateParams); override;\r\n procedure IndexToColRow(Index: Integer; var ACol, ARow: Integer);\r\n procedure DrawItem(Index: Integer; State: TCustomDrawState; Canvas: TCanvas; ItemRect, TextRect: TRect); virtual;\r\n function GetItemClass: TJvViewerItemClass; virtual;\r\n function GetOptionsClass: TJvItemViewerOptionsClass; virtual;\r\n function GetItemState(Index: Integer): TCustomDrawState; virtual;\r\n procedure Inserted(Item: TJvViewerItem); virtual;\r\n procedure Deleted(Item: TJvViewerItem); virtual;\r\n procedure ItemChanging(Item: TJvViewerItem; var AllowChange: Boolean); virtual;\r\n procedure ItemChanged(Item: TJvViewerItem); virtual;\r\n function HintShow(var HintInfo: {$IFDEF RTL200_UP}Controls.{$ENDIF RTL200_UP}THintInfo): Boolean; override;\r\n function DoItemHint(Index: Integer; var HintInfo: {$IFDEF RTL200_UP}Controls.{$ENDIF RTL200_UP}THintInfo): Boolean; virtual;\r\n procedure CustomSort(Compare:TListSortCompare);virtual;\r\n\r\n property TopLeftIndex: Integer read FTopLeftIndex;\r\n property BottomRightIndex: Integer read FBottomRightIndex;\r\n property UpdateCount: Integer read FUpdateCount;\r\n\r\n property BorderStyle: TBorderStyle read FBorderStyle write SetBorderStyle default bsSingle;\r\n property ParentColor default False;\r\n property SelectedIndex: Integer read FSelectedIndex write SetSelectedIndex;\r\n property Selected[Item: TJvViewerItem]: Boolean read GetSelected write SetSelected;\r\n property Canvas: TCanvas read FCanvas;\r\n property Options: TJvCustomItemViewerOptions read FOptions write SetOptions;\r\n property Count: Integer read GetCount write SetCount;\r\n property Items[Index: Integer]: TJvViewerItem read GetItems write SetItems;\r\n property ItemSize: TSize read FItemSize;\r\n property OnDrawItem: TJvViewerItemDrawEvent read FOnDrawItem write FOnDrawItem;\r\n property OnScroll: TNotifyEvent read FOnScroll write FOnScroll;\r\n property OnOptionsChanged: TNotifyEvent read FOnOptionsChanged write FOnOptionsChanged;\r\n property OnItemChanging: TJvViewerItemChangingEvent read FOnItemChanging write FOnItemChanging;\r\n property OnItemChanged: TJvViewerItemChangedEvent read FOnItemChanged write FOnItemChanged;\r\n property OnInsertion: TJvViewerItemChangedEvent read FOnInsertion write FOnInsertion;\r\n property OnDeletion: TJvViewerItemChangedEvent read FOnDeletion write FOnDeletion;\r\n property OnItemHint: TJvViewerItemHintEvent read FOnItemHint write FOnItemHint;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n procedure ScrollBy(DeltaX, DeltaY: Integer);\r\n procedure ScrollIntoView(Index: Integer);\r\n procedure BeginUpdate;\r\n procedure EndUpdate;\r\n procedure SelectAll;\r\n procedure SelectItems(StartIndex, EndIndex: Integer; AppendSelection: Boolean);\r\n procedure UnselectItems(StartIndex, EndIndex: Integer);\r\n procedure Clear;\r\n function Add(AItem: TJvViewerItem): Integer;\r\n procedure Insert(Index: Integer; AItem: TJvViewerItem);\r\n procedure Delete(Index: Integer);\r\n function IndexOf(Item: TJvViewerItem): Integer;\r\n function ItemAtPos(X, Y: Integer; Existing: Boolean): Integer; virtual;\r\n end;\r\n\r\n// Creates a 8x8 brush pattern with alternate odd and even colors\r\n// If the pattern already exists, no new pattern is created. Instead, the previous pattern is resued.\r\n// NB! Do *not* free the returned TBitmap! It is freed when the unit is finalized or when ClearBrushPatterns\r\n// is called\r\nfunction CreateBrushPattern(const EvenColor: TColor = clWhite; const OddColor: TColor = clBtnFace): TBitmap;\r\n// Decrements the reference count for a particular brush pattern. When the ref\r\n// count reaches 0, the pattern is released\r\nprocedure ReleasePattern(EvenColor, OddColor: TColor);\r\n\r\n// Clears the internal list of brush patterns.\r\n// You don't have to call this procedure unless your program uses a lot of brush patterns\r\n// that are only used short times\r\nprocedure ClearBrushPatterns;\r\n\r\nfunction ViewerDrawText(Canvas: TCanvas; S: WideString; aLength: Integer;\r\n var R: TRect; Format: Cardinal; Alignment: TAlignment; Layout: TTextLayout; WordWrap: Boolean): Integer;\r\nfunction CenterRect(InnerRect, OuterRect: TRect): TRect;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvCustomItemViewer.pas $';\r\n Revision: '$Revision: 13104 $';\r\n Date: '$Date: 2011-09-07 08:50:43 +0200 (mer. 07 sept. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n SysUtils, Math,\r\n JvJCLUtils, JvJVCLUtils, JvThemes;\r\n\r\nconst\r\n cScrollDelay = 400;\r\n cScrollIntervall = 30;\r\n\r\ntype\r\n TScrollEdge = (seNone, seLeft, seTop, seRight, seBottom);\r\n TColorPattern = record\r\n EvenColor: TColor;\r\n OddColor: TColor;\r\n UsageCount: Integer;\r\n Bitmap: TBitmap;\r\n end;\r\n\r\n TViewerDrawImageList = class(TDragImageList)\r\n protected\r\n procedure Initialize; override;\r\n end;\r\n\r\nvar\r\n GlobalPatterns: array of TColorPattern = nil;\r\n FirstGlobalPatterns: Boolean = True;\r\n\r\nprocedure ReleasePattern(EvenColor, OddColor: TColor);\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := 0 to Length(GlobalPatterns) - 1 do\r\n if (GlobalPatterns[I].EvenColor = EvenColor) and (GlobalPatterns[I].OddColor = OddColor) then\r\n begin\r\n if GlobalPatterns[I].UsageCount > 0 then\r\n Dec(GlobalPatterns[I].UsageCount);\r\n if GlobalPatterns[I].UsageCount = 0 then\r\n FreeAndNil(GlobalPatterns[I].Bitmap);\r\n Break;\r\n end;\r\nend;\r\n\r\nprocedure ClearBrushPatterns;\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := 0 to Length(GlobalPatterns) - 1 do\r\n GlobalPatterns[I].Bitmap.Free;\r\n SetLength(GlobalPatterns, 0);\r\nend;\r\n\r\nfunction CreateBrushPattern(const EvenColor: TColor = clWhite; const OddColor: TColor = clBtnFace):\r\n TBitmap;\r\nvar\r\n I, X, Y: Integer;\r\n Found: Boolean;\r\nbegin\r\n Found := False;\r\n Result := nil;\r\n for I := 0 to Length(GlobalPatterns) - 1 do\r\n if (GlobalPatterns[I].EvenColor = EvenColor) and (GlobalPatterns[I].OddColor = OddColor) then\r\n begin\r\n Result := GlobalPatterns[I].Bitmap;\r\n Found := True;\r\n Break;\r\n end;\r\n\r\n if not Found then\r\n begin\r\n I := Length(GlobalPatterns);\r\n if FirstGlobalPatterns then\r\n FirstGlobalPatterns := False;\r\n SetLength(GlobalPatterns, I + 1);\r\n end;\r\n if Result = nil then\r\n begin\r\n Result := TBitmap.Create;\r\n Result.Dormant; // preserve some DDB handles, use more memory\r\n Result.Width := 8; { must have this size }\r\n Result.Height := 8;\r\n with Result.Canvas do\r\n begin\r\n Brush.Style := bsSolid;\r\n Brush.Color := EvenColor;\r\n FillRect(Rect(0, 0, Result.Width, Result.Height));\r\n for Y := 0 to 7 do\r\n for X := 0 to 7 do\r\n if (Y mod 2) = (X mod 2) then { toggles between even/odd pixles }\r\n Pixels[X, Y] := OddColor; { on even/odd rows }\r\n end;\r\n GlobalPatterns[I].EvenColor := EvenColor;\r\n GlobalPatterns[I].OddColor := OddColor;\r\n GlobalPatterns[I].Bitmap := Result;\r\n end;\r\n Inc(GlobalPatterns[I].UsageCount);\r\nend;\r\n\r\nfunction ViewerDrawText(Canvas: TCanvas; S: WideString; aLength: Integer;\r\n var R: TRect; Format: Cardinal; Alignment: TAlignment; Layout: TTextLayout; WordWrap: Boolean): Integer;\r\nconst\r\n Alignments: array [TAlignment] of Cardinal = (DT_LEFT, DT_RIGHT, DT_CENTER);\r\n Layouts: array [TTextLayout] of Cardinal = (DT_TOP, DT_VCENTER, DT_BOTTOM);\r\n WordWraps: array [Boolean] of Cardinal = (DT_SINGLELINE, DT_WORDBREAK);\r\nvar\r\n Flags: Cardinal;\r\nbegin\r\n Flags := Format or Alignments[Alignment] or Layouts[Layout] or WordWraps[WordWrap];\r\n // (p3) Do we need BiDi support here?\r\n if Win32Platform = VER_PLATFORM_WIN32_NT then\r\n Result := DrawTextW(Canvas, PWideChar(S), aLength, R, Flags)\r\n else\r\n Result := DrawText(Canvas, PChar(string(S)), aLength, R, Flags);\r\nend;\r\n\r\nfunction CenterRect(InnerRect, OuterRect: TRect): TRect;\r\nbegin\r\n OffsetRect(InnerRect, -InnerRect.Left + OuterRect.Left + (RectWidth(OuterRect) - RectWidth(InnerRect)) div 2,\r\n -InnerRect.Top + OuterRect.Top + (RectHeight(OuterRect) - RectHeight(InnerRect)) div 2);\r\n Result := InnerRect;\r\nend;\r\n\r\n//=== { TJvBrushPattern } ====================================================\r\n\r\nconstructor TJvBrushPattern.Create;\r\nbegin\r\n inherited Create;\r\n FEvenColor := clWhite;\r\n FOddColor := clSkyBlue;\r\n FActive := True;\r\nend;\r\n\r\ndestructor TJvBrushPattern.Destroy;\r\nbegin\r\n if FPattern <> nil then\r\n ReleasePattern(EvenColor, OddColor);\r\n FPattern := nil;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJvBrushPattern.GetBitmap: TBitmap;\r\nbegin\r\n if Active then\r\n begin\r\n if FPattern = nil then\r\n FPattern := CreateBrushPattern(EvenColor, OddColor);\r\n end\r\n else\r\n begin\r\n if FPattern <> nil then\r\n ReleasePattern(EvenColor, OddColor);\r\n FPattern := nil;\r\n end;\r\n Result := FPattern;\r\nend;\r\n\r\nprocedure TJvBrushPattern.SetEvenColor(const Value: TColor);\r\nbegin\r\n if FEvenColor <> Value then\r\n begin\r\n if FPattern <> nil then\r\n ReleasePattern(EvenColor, OddColor);\r\n FEvenColor := Value;\r\n FPattern := nil;\r\n end;\r\nend;\r\n\r\nprocedure TJvBrushPattern.SetOddColor(const Value: TColor);\r\nbegin\r\n if FOddColor <> Value then\r\n begin\r\n if FPattern <> nil then\r\n ReleasePattern(EvenColor, OddColor);\r\n FOddColor := Value;\r\n FPattern := nil;\r\n end;\r\nend;\r\n\r\n//=== { TJvCustomItemViewerOptions } =========================================\r\n\r\nconstructor TJvCustomItemViewerOptions.Create(AOwner: TJvCustomItemViewer);\r\nbegin\r\n inherited Create;\r\n FOwner := AOwner;\r\n FWidth := 120;\r\n FHeight := 120;\r\n FVertSpacing := 4;\r\n FHorzSpacing := 4;\r\n FScrollBar := tvVertical;\r\n FSmooth := False;\r\n FTracking := True;\r\n FLazyRead := True;\r\n FShowCaptions := False;\r\n FAlignment := taCenter;\r\n FLayout := tlBottom;\r\n FDragAutoScroll := True;\r\n FBrushPattern := TJvBrushPattern.Create;\r\nend;\r\n\r\ndestructor TJvCustomItemViewerOptions.Destroy;\r\nbegin\r\n FBrushPattern.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvCustomItemViewerOptions.Assign(Source: TPersistent);\r\nbegin\r\n if Source is TJvCustomItemViewerOptions then\r\n begin\r\n if Source <> Self then\r\n begin\r\n FWidth := TJvCustomItemViewerOptions(Source).Width;\r\n FHeight := TJvCustomItemViewerOptions(Source).Height;\r\n FVertSpacing := TJvCustomItemViewerOptions(Source).VertSpacing;\r\n FHorzSpacing := TJvCustomItemViewerOptions(Source).HorzSpacing;\r\n FScrollBar := TJvCustomItemViewerOptions(Source).ScrollBar;\r\n FAutoCenter := TJvCustomItemViewerOptions(Source).AutoCenter;\r\n FSmooth := TJvCustomItemViewerOptions(Source).Smooth;\r\n FTracking := TJvCustomItemViewerOptions(Source).Tracking;\r\n FHotTrack := TJvCustomItemViewerOptions(Source).HotTrack;\r\n FMultiSelect := TJvCustomItemViewerOptions(Source).MultiSelect;\r\n BrushPattern.FEvenColor := BrushPattern.EvenColor;\r\n BrushPattern.FOddColor := BrushPattern.OddColor;\r\n BrushPattern.FActive := BrushPattern.Active;\r\n Change;\r\n end;\r\n end\r\n else\r\n inherited Assign(Source);\r\nend;\r\n\r\nprocedure TJvCustomItemViewerOptions.Change;\r\nbegin\r\n if FOwner <> nil then\r\n FOwner.OptionsChanged;\r\nend;\r\n\r\nprocedure TJvCustomItemViewerOptions.SetAlignment(const Value: TAlignment);\r\nbegin\r\n if FAlignment <> Value then\r\n begin\r\n FAlignment := Value;\r\n if ShowCaptions then\r\n Change;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomItemViewerOptions.SetAutoCenter(const Value: Boolean);\r\nbegin\r\n if FAutoCenter <> Value then\r\n begin\r\n FAutoCenter := Value;\r\n Change;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomItemViewerOptions.SetBrushPattern(const Value: TJvBrushPattern);\r\nbegin\r\n // FBrushPattern := Value;\r\nend;\r\n\r\nprocedure TJvCustomItemViewerOptions.SetHeight(const Value: Integer);\r\nbegin\r\n if FHeight <> Value then\r\n begin\r\n FHeight := Value;\r\n Change;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomItemViewerOptions.SetHorzSpacing(const Value: Integer);\r\nbegin\r\n if FHorzSpacing <> Value then\r\n begin\r\n FHorzSpacing := Value;\r\n Change;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomItemViewerOptions.SetHotTrack(const Value: Boolean);\r\nbegin\r\n if FHotTrack <> Value then\r\n begin\r\n FHotTrack := Value;\r\n Change;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomItemViewerOptions.SetLayout(const Value: TTextLayout);\r\nbegin\r\n if FLayout <> Value then\r\n begin\r\n FLayout := Value;\r\n if ShowCaptions then\r\n Change;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomItemViewerOptions.SetLazyRead(const Value: Boolean);\r\nbegin\r\n if LazyRead <> Value then\r\n begin\r\n FLazyRead := Value;\r\n if not FLazyRead then\r\n FReduceMemoryUsage := False;\r\n Change;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomItemViewerOptions.SetMultiSelect(const Value: Boolean);\r\nbegin\r\n if FMultiSelect <> Value then\r\n begin\r\n FMultiSelect := Value;\r\n Change;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomItemViewerOptions.SetReduceMemoryUsage(const Value: Boolean);\r\nbegin\r\n if FReduceMemoryUsage <> Value then\r\n begin\r\n FReduceMemoryUsage := Value;\r\n if FReduceMemoryUsage then\r\n begin\r\n FLazyRead := True;\r\n FOwner.DoReduceMemory;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomItemViewerOptions.SetRightClickSelect(const Value: Boolean);\r\nbegin\r\n FRightClickSelect := Value;\r\n // no need to tell owner\r\nend;\r\n\r\nprocedure TJvCustomItemViewerOptions.SetScrollBar(const Value: TJvItemViewerScrollBar);\r\nbegin\r\n if FScrollBar <> Value then\r\n begin\r\n FScrollBar := Value;\r\n Change;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomItemViewerOptions.SetShowCaptions(const Value: Boolean);\r\nbegin\r\n if FShowCaptions <> Value then\r\n begin\r\n FShowCaptions := Value;\r\n Change;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomItemViewerOptions.SetSmooth(const Value: Boolean);\r\nbegin\r\n if FSmooth <> Value then\r\n begin\r\n FSmooth := Value;\r\n Change;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomItemViewerOptions.SetTracking(const Value: Boolean);\r\nbegin\r\n if FTracking <> Value then\r\n begin\r\n FTracking := Value;\r\n Change;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomItemViewerOptions.SetVertSpacing(const Value: Integer);\r\nbegin\r\n if FVertSpacing <> Value then\r\n begin\r\n FVertSpacing := Value;\r\n Change;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomItemViewerOptions.SetWidth(const Value: Integer);\r\nbegin\r\n if FWidth <> Value then\r\n begin\r\n FWidth := Value;\r\n Change;\r\n end;\r\nend;\r\n\r\n//=== { TJvViewerItem } ======================================================\r\n\r\nconstructor TJvViewerItem.Create(AOwner: TJvCustomItemViewer);\r\nbegin\r\n inherited Create;\r\n FOwner := AOwner;\r\nend;\r\n\r\nprocedure TJvViewerItem.Changed;\r\nbegin\r\n if FOwner <> nil then\r\n FOwner.ItemChanged(Self);\r\nend;\r\n\r\nfunction TJvViewerItem.Changing: Boolean;\r\nbegin\r\n Result := True;\r\n if FOwner <> nil then\r\n FOwner.ItemChanging(Self, Result);\r\nend;\r\n\r\nprocedure TJvViewerItem.Delete;\r\nbegin\r\n if FOwner <> nil then\r\n begin\r\n FDeleting := True;\r\n PostMessage(FOwner.Handle, CM_DELETEITEM, WPARAM(Self), 0);\r\n end;\r\nend;\r\n\r\nprocedure TJvViewerItem.ReduceMemoryUsage;\r\nbegin\r\n // override to perform whatever you can to reduce the memory usage\r\nend;\r\n\r\nprocedure TJvViewerItem.SetData(const Value: Pointer);\r\nbegin\r\n if (FData <> Value) and Changing then\r\n begin\r\n FData := Value;\r\n Changed;\r\n end;\r\nend;\r\n\r\nprocedure TJvViewerItem.SetState(const Value: TCustomDrawState);\r\nbegin\r\n if (FState <> Value) and Changing then\r\n begin\r\n FState := Value;\r\n Changed;\r\n end;\r\nend;\r\n\r\n//=== { TJvCustomItemViewer } ================================================\r\n\r\nconstructor TJvCustomItemViewer.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n ParentColor := False;\r\n ControlStyle := [csCaptureMouse, csDisplayDragImage, csClickEvents, csOpaque, csDoubleClicks];\r\n FItems := TJvViewerItemList.Create;\r\n FOptions := GetOptionsClass.Create(Self);\r\n FCanvas := TControlCanvas.Create;\r\n TControlCanvas(FCanvas).Control := Self;\r\n FSelectedIndex := -1;\r\n FLastHotTrack := -1;\r\n AutoScroll := False;\r\n HorzScrollBar.Smooth := Options.Smooth;\r\n HorzScrollBar.Tracking := Options.Tracking;\r\n VertScrollBar.Smooth := Options.Smooth;\r\n VertScrollBar.Tracking := Options.Tracking;\r\n DoubleBuffered := True;\r\n FBorderStyle := bsSingle;\r\n Width := 185;\r\n Height := 150;\r\n TabStop := True;\r\nend;\r\n\r\ndestructor TJvCustomItemViewer.Destroy;\r\nbegin\r\n StopScrollTimer;\r\n Clear;\r\n FItems.Free;\r\n FOptions.Free;\r\n inherited Destroy;\r\n // (rom) destroy Canvas always after inherited\r\n FreeAndNil(FCanvas);\r\nend;\r\n\r\nfunction TJvCustomItemViewer.Add(AItem: TJvViewerItem): Integer;\r\nbegin\r\n Insert(FItems.Count, AItem);\r\n Result := FItems.Count - 1;\r\nend;\r\n\r\nprocedure TJvCustomItemViewer.BeginUpdate;\r\nbegin\r\n Inc(FUpdateCount);\r\nend;\r\n\r\nprocedure TJvCustomItemViewer.CalcIndices;\r\nbegin\r\n FTopLeftIndex := ItemAtPos(0, 0, True);\r\n FBottomRightIndex := ItemAtPos(ClientWidth, ClientHeight, True);\r\n if FBottomRightIndex < 0 then\r\n FBottomRightIndex := ItemAtPos(ClientWidth, ClientHeight, False) - 1;\r\n if FTopLeftIndex < 0 then\r\n FTopLeftIndex := 0;\r\n if FTopLeftIndex >= Count then\r\n FTopLeftIndex := Count - 1;\r\n if FBottomRightIndex < 0 then\r\n FBottomRightIndex := 0;\r\n if FBottomRightIndex >= Count then\r\n FBottomRightIndex := Count - 1;\r\n DoReduceMemory;\r\nend;\r\n\r\nprocedure TJvCustomItemViewer.OptionsChanged;\r\nbegin\r\n Changed;\r\n if Assigned(FOnOptionsChanged) then\r\n FOnOptionsChanged(Self);\r\nend;\r\n\r\nprocedure TJvCustomItemViewer.CheckHotTrack;\r\nvar\r\n P: TPoint;\r\n I: Integer;\r\nbegin\r\n if Options.HotTrack and GetCursorPos(P) then\r\n begin\r\n P := ScreenToClient(P);\r\n if not PtInRect(ClientRect, P) then\r\n I := -1\r\n else\r\n I := ItemAtPos(P.X, P.Y, True);\r\n // remove hot track state from previous item\r\n if (FLastHotTrack >= 0) and (FLastHotTrack < Count) and (I <> FLastHotTrack) then\r\n Items[FLastHotTrack].State := Items[FLastHotTrack].State - [cdsHot];\r\n if (I >= 0) and (I < Count) then\r\n begin\r\n Items[I].State := Items[I].State + [cdsHot];\r\n FLastHotTrack := I;\r\n end\r\n else\r\n FLastHotTrack := -1;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomItemViewer.Clear;\r\nbegin\r\n BeginUpdate;\r\n try\r\n FItems.Clear;\r\n finally\r\n EndUpdate;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomItemViewer.CMCtl3DChanged(var Msg: TMessage);\r\nbegin\r\n if FBorderStyle = bsSingle then\r\n RecreateWnd;\r\n inherited;\r\nend;\r\n\r\nprocedure TJvCustomItemViewer.CMDeleteItem(var Msg: TMessage);\r\nvar\r\n I: Integer;\r\nbegin\r\n I := FItems.IndexOf(TObject(Msg.WParam));\r\n if (I >= 0) and (I < Count) then\r\n begin\r\n Delete(I);\r\n InvalidateClipRect(ClientRect);\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomItemViewer.MouseLeave(Control: TControl);\r\nbegin\r\n if csDesigning in ComponentState then\r\n Exit;\r\n inherited MouseLeave(Control);\r\n CheckHotTrack;\r\nend;\r\n\r\nprocedure TJvCustomItemViewer.CMUnselectItem(var Msg: TMessage);\r\nvar\r\n I: Integer;\r\nbegin\r\n if Msg.WParam = WPARAM(Self) then\r\n begin\r\n BeginUpdate;\r\n try\r\n for I := 0 to Count - 1 do\r\n if (Integer(Items[I]) <> Msg.LParam) and\r\n (cdsSelected in Items[I].State) then\r\n Items[I].State := Items[I].State - [cdsSelected];\r\n finally\r\n EndUpdate;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJvCustomItemViewer.ColRowToIndex(ACol, ARow: Integer): Integer;\r\nbegin\r\n Result := ACol + ARow * FCols\r\nend;\r\n\r\nprocedure TJvCustomItemViewer.CreateParams(var Params: TCreateParams);\r\nconst\r\n BorderStyles: array [TBorderStyle] of DWORD = (0, WS_BORDER);\r\nbegin\r\n inherited CreateParams(Params);\r\n with Params do\r\n begin\r\n Style := Style or BorderStyles[BorderStyle];\r\n if Ctl3D and (BorderStyle = bsSingle) then\r\n begin\r\n Style := Style and not WS_BORDER;\r\n ExStyle := ExStyle or WS_EX_CLIENTEDGE;\r\n end;\r\n end;\r\n with Params.WindowClass do\r\n Style := Style or (CS_HREDRAW or CS_VREDRAW); { or CS_SAVEBITS}\r\nend;\r\n\r\nprocedure TJvCustomItemViewer.Delete(Index: Integer);\r\nbegin\r\n Deleted(Items[Index]);\r\n FItems.Delete(Index);\r\n if SelectedIndex >= Count then\r\n SelectedIndex := Count - 1;\r\nend;\r\n\r\nfunction TJvCustomItemViewer.DoMouseWheel(Shift: TShiftState;\r\n WheelDelta: Integer; MousePos: TPoint): Boolean;\r\nvar\r\n WD: Integer;\r\nbegin\r\n if not inherited DoMouseWheel(Shift, WheelDelta, MousePos) then\r\n begin\r\n if Shift * KeyboardShiftStates = [ssShift] then\r\n WD := WheelDelta * 3\r\n else\r\n WD := WheelDelta;\r\n if Options.ScrollBar = tvHorizontal then\r\n HorzScrollBar.Position := HorzScrollBar.Position - WD\r\n else\r\n VertScrollBar.Position := VertScrollBar.Position - WD;\r\n UpdateOffset;\r\n Invalidate;\r\n end;\r\n Result := True;\r\nend;\r\n\r\nprocedure TJvCustomItemViewer.DoReduceMemory;\r\nvar\r\n I: Integer;\r\nbegin\r\n if Options.ReduceMemoryUsage then\r\n begin\r\n for I := 0 to FTopLeftIndex - 1 do\r\n if FItems[I] <> nil then\r\n Items[I].ReduceMemoryUsage;\r\n for I := FBottomRightIndex + 1 to Count - 1 do\r\n if FItems[I] <> nil then\r\n Items[I].ReduceMemoryUsage;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomItemViewer.DrawItem(Index: Integer; State: TCustomDrawState;\r\n Canvas: TCanvas; ItemRect, TextRect: TRect);\r\nbegin\r\n if Assigned(FOnDrawItem) then\r\n FOnDrawItem(Self, Index, State, Canvas, ItemRect, TextRect);\r\nend;\r\n\r\nprocedure TJvCustomItemViewer.EndUpdate;\r\nbegin\r\n Dec(FUpdateCount);\r\n if FUpdateCount <= 0 then\r\n begin\r\n FUpdateCount := 0;\r\n UpdateAll;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nfunction TJvCustomItemViewer.FindFirstSelected: Integer;\r\nbegin\r\n for Result := 0 to Count - 1 do\r\n if cdsSelected in Items[Result].State then\r\n Exit;\r\n Result := -1;\r\nend;\r\n\r\nfunction TJvCustomItemViewer.FindLastSelected: Integer;\r\nbegin\r\n for Result := Count - 1 downto 0 do\r\n if cdsSelected in Items[Result].State then\r\n Exit;\r\n Result := -1;\r\nend;\r\n\r\nfunction TJvCustomItemViewer.GetCount: Integer;\r\nbegin\r\n Result := FItems.Count;\r\nend;\r\n\r\nfunction TJvCustomItemViewer.GetDragImages: TDragImageList;\r\nvar\r\n B: TBitmap;\r\n P: TPoint;\r\n I: Integer;\r\n ItemRect, TextRect: TRect;\r\nbegin\r\n GetCursorPos(P);\r\n P := ScreenToClient(P);\r\n I := ItemAtPos(P.X, P.Y, True);\r\n // create an image of the currently selected item\r\n if I >= 0 then\r\n begin\r\n if FDragImages = nil then\r\n FDragImages := TViewerDrawImageList.Create(Self);\r\n FDragImages.Clear;\r\n ItemRect := Rect(0, 0, ItemSize.cx, ItemSize.cy);\r\n InflateRect(ItemRect, -Options.HorzSpacing, -Options.VertSpacing);\r\n B := TBitmap.Create;\r\n try\r\n B.Width := ItemSize.cx;\r\n B.Height := ItemSize.cy;\r\n if Options.ShowCaptions then\r\n TextRect := GetTextRect('Wg', ItemRect)\r\n else\r\n TextRect := Rect(0, 0, 0, 0);\r\n DrawItem(I, Items[I].State + [cdsSelected, cdsFocused, cdsHot], B.Canvas, ItemRect, TextRect);\r\n FDragImages.Width := ItemSize.cx;\r\n FDragImages.Height := ItemSize.cy;\r\n FDragImages.AddMasked(B, B.TransparentColor);\r\n finally\r\n B.Free;\r\n end;\r\n // FDragImages.SetDragImage(0, 0, 0);\r\n ItemRect := Self.ItemRect(I, True);\r\n FDragImages.SetDragImage(0, P.X - ItemRect.Left, P.Y - ItemRect.Top);\r\n Result := FDragImages;\r\n SelectedIndex := I;\r\n Paint;\r\n end\r\n else\r\n Result := inherited GetDragImages;\r\nend;\r\n\r\nfunction TJvCustomItemViewer.GetItemClass: TJvViewerItemClass;\r\nbegin\r\n Result := TJvViewerItem;\r\nend;\r\n\r\nfunction TJvCustomItemViewer.GetItems(Index: Integer): TJvViewerItem;\r\nbegin\r\n Result := FItems[Index];\r\n if Result = nil then\r\n begin\r\n Result := GetItemClass.Create(Self);\r\n FItems[Index] := Result;\r\n end;\r\nend;\r\n\r\nfunction TJvCustomItemViewer.GetItemState(Index: Integer): TCustomDrawState;\r\nbegin\r\n // (p3) safer than calling Items[Index].State directly\r\n if (Index >= 0) and (Index < Count) then\r\n Result := Items[Index].State\r\n else\r\n Result := [];\r\nend;\r\n\r\nfunction TJvCustomItemViewer.GetOptionsClass: TJvItemViewerOptionsClass;\r\nbegin\r\n Result := TJvCustomItemViewerOptions;\r\nend;\r\n\r\nfunction TJvCustomItemViewer.GetSelected(Item: TJvViewerItem): Boolean;\r\nbegin\r\n Result := (Item <> nil) and (cdsSelected in Item.State);\r\nend;\r\n\r\nfunction TJvCustomItemViewer.GetTextHeight: Integer;\r\nvar\r\n R: TRect;\r\n S: WideString;\r\nbegin\r\n S := 'Wg';\r\n R := Rect(0, 0, 100, 100);\r\n Result := ViewerDrawText(Canvas, PWideChar(S), Length(S),\r\n R, DT_END_ELLIPSIS or DT_CALCRECT, taCenter, tlTop, False) + 4;\r\n // Result := Canvas.TextHeight('Wg');\r\nend;\r\n\r\nfunction TJvCustomItemViewer.GetTextRect(const S: WideString; var ItemRect: TRect): TRect;\r\nvar\r\n TextHeight: Integer;\r\nbegin\r\n TextHeight := GetTextHeight;\r\n\r\n case Options.Layout of\r\n tlTop:\r\n begin\r\n Result := Rect(ItemRect.Left, ItemRect.Top, ItemRect.Right, ItemRect.Top + TextHeight);\r\n ItemRect.Top := Result.Top + TextHeight;\r\n end;\r\n tlBottom:\r\n begin\r\n Result := Rect(ItemRect.Left, ItemRect.Bottom - TextHeight,\r\n ItemRect.Right, ItemRect.Bottom);\r\n ItemRect.Bottom := Result.Top;\r\n end;\r\n tlCenter:\r\n begin\r\n Result := Rect(ItemRect.Left, ItemRect.Top + (RectHeight(ItemRect) - TextHeight) div 2 + 1,\r\n ItemRect.Right, 0);\r\n Result.Bottom := Result.Top + TextHeight;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJvCustomItemViewer.IndexOf(Item: TJvViewerItem): Integer;\r\nbegin\r\n // (p3) need to do it like this because items aren't created until Items[] is called\r\n for Result := 0 to Count - 1 do\r\n if Items[Result] = Item then\r\n Exit;\r\n Result := -1;\r\nend;\r\n\r\nprocedure TJvCustomItemViewer.IndexToColRow(Index: Integer; var ACol, ARow: Integer);\r\nbegin\r\n Assert(FCols > 0);\r\n ACol := Index mod FCols;\r\n ARow := Index div FCols;\r\nend;\r\n\r\nprocedure TJvCustomItemViewer.Insert(Index: Integer; AItem: TJvViewerItem);\r\nbegin\r\n Assert(AItem is GetItemClass);\r\n FItems.Insert(Index,AItem);\r\n Inserted(AItem);\r\nend;\r\n\r\nprocedure TJvCustomItemViewer.InvalidateClipRect(R: TRect);\r\nbegin\r\n if IsRectEmpty(R) then\r\n R := Canvas.ClipRect;\r\n Windows.InvalidateRect(Handle, @R, True);\r\nend;\r\n\r\nfunction TJvCustomItemViewer.ItemAtPos(X, Y: Integer; Existing: Boolean): Integer;\r\nvar\r\n ARow, ACol: Integer;\r\nbegin\r\n Result := -1;\r\n if (FItemSize.cx < 1) or (FItemSize.cy < 1) then\r\n Exit;\r\n Dec(X, FTopLeft.X);\r\n Dec(Y, FTopLeft.Y);\r\n ACol := X div FItemSize.cx;\r\n ARow := Y div FItemSize.cy;\r\n if ((ACol < 0) or (ARow < 0) or (ACol >= FCols) or (ARow >= FRows)) and Existing then\r\n Exit;\r\n Result := ColRowToIndex(ACol, ARow);\r\n if (Result >= Count) and Existing then\r\n Result := -1;\r\nend;\r\n\r\nprocedure TJvCustomItemViewer.ItemChanged(Item: TJvViewerItem);\r\nvar\r\n I: Integer;\r\nbegin\r\n if FUpdateCount <> 0 then\r\n Exit;\r\n if (Item <> nil) then\r\n begin\r\n I := FItems.IndexOf(Item);\r\n if I > -1 then\r\n begin\r\n if (cdsSelected in Item.State) and not Options.MultiSelect then\r\n FSelectedIndex := I;\r\n InvalidateClipRect(ItemRect(I, True));\r\n end;\r\n end\r\n else\r\n Changed;\r\n if Assigned(FOnItemChanged) then\r\n FOnItemChanged(Self, Item);\r\nend;\r\n\r\nprocedure TJvCustomItemViewer.ItemChanging(Item: TJvViewerItem;\r\n var AllowChange: Boolean);\r\nbegin\r\n AllowChange := True;\r\n if Assigned(FOnItemChanging) then\r\n FOnItemChanging(Self, Item, AllowChange);\r\nend;\r\n\r\nfunction TJvCustomItemViewer.ItemRect(Index: Integer; IncludeSpacing: Boolean): TRect;\r\nvar\r\n ACol, ARow: Integer;\r\nbegin\r\n IndexToColRow(Index, ACol, ARow);\r\n if (Index < 0) or (Index >= Count) then\r\n begin\r\n Result := Rect(0, 0, 0, 0);\r\n Exit;\r\n end;\r\n Result := Rect(0, 0, FItemSize.cx, FItemSize.cy);\r\n OffsetRect(Result, FTopLeft.X + FItemSize.cx * ACol,\r\n FTopLeft.Y + FItemSize.cy * ARow);\r\n if not IncludeSpacing then\r\n InflateRect(Result, -Options.HorzSpacing, -Options.VertSpacing);\r\nend;\r\n\r\nprocedure TJvCustomItemViewer.KeyDown(var Key: Word; Shift: TShiftState);\r\nvar\r\n LIndex: Integer;\r\nbegin\r\n inherited KeyDown(Key, Shift);\r\n LIndex := -1;\r\n if Focused and (Shift * KeyboardShiftStates = []) then\r\n case Key of\r\n VK_UP:\r\n LIndex := SelectedIndex - FCols;\r\n VK_DOWN:\r\n LIndex := SelectedIndex + FCols;\r\n VK_LEFT:\r\n LIndex := SelectedIndex - 1;\r\n VK_RIGHT:\r\n LIndex := SelectedIndex + 1;\r\n VK_SPACE:\r\n Click;\r\n end;\r\n if (LIndex >= 0) and (LIndex < Count) then\r\n begin\r\n if Options.MultiSelect then\r\n DoUnSelectItems(LIndex);\r\n SelectedIndex := LIndex;\r\n ScrollIntoView(LIndex);\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomItemViewer.MouseMove(Shift: TShiftState; X, Y: Integer);\r\nbegin\r\n inherited MouseMove(Shift, X, Y);\r\n CheckHotTrack;\r\nend;\r\n\r\nprocedure TJvCustomItemViewer.Paint;\r\nvar\r\n I: Integer;\r\n ItemRect, TextRect, AClientRect: TRect;\r\n\r\n function IsRectVisible(const R: TRect): Boolean;\r\n begin\r\n Result := (R.Top < AClientRect.Bottom) and (R.Bottom > AClientRect.Top) and\r\n (R.Left < AClientRect.Right) and (R.Right > AClientRect.Left)\r\n end;\r\n\r\nbegin\r\n // inherited Paint;\r\n if FUpdateCount <> 0 then\r\n Exit;\r\n AClientRect := ClientRect;\r\n Canvas.Brush.Color := Color;\r\n Canvas.Pen.Color := Font.Color;\r\n Canvas.Font := Font;\r\n // Canvas.FillRect(Canvas.ClipRect);\r\n if (FUpdateCount <> 0) or (Count = 0) or\r\n (ClientWidth <= 0) or (ClientHeight <= 0) or\r\n (FItemSize.cx <= 0) or (FItemSize.cy <= 0) then\r\n Exit;\r\n ItemRect := Rect(0, 0, ItemSize.cx, ItemSize.cy);\r\n InflateRect(ItemRect, -Options.HorzSpacing, -Options.VertSpacing);\r\n if Options.ShowCaptions then\r\n begin\r\n TextRect := GetTextRect('Wg', ItemRect);\r\n OffsetRect(TextRect, FTopLeft.X, FTopLeft.Y);\r\n end\r\n else\r\n TextRect := Rect(0, 0, 0, 0);\r\n OffsetRect(ItemRect, FTopLeft.X, FTopLeft.Y);\r\n // Canvas.FillRect(Rect(Left, Top, Width, Height));\r\n for I := 0 to Count - 1 do\r\n if not Items[I].Deleting then\r\n begin\r\n if not Options.LazyRead or IsRectVisible(ItemRect) then\r\n DrawItem(I, GetItemState(I), Canvas, ItemRect, TextRect);\r\n if (I + 1) mod FCols = 0 then\r\n begin\r\n OffsetRect(ItemRect, -ItemRect.Left + Options.HorzSpacing + FTopLeft.X, ItemSize.cy);\r\n if Options.ShowCaptions then\r\n OffsetRect(TextRect, -TextRect.Left + Options.HorzSpacing + FTopLeft.X, ItemSize.cy);\r\n end\r\n else\r\n begin\r\n OffsetRect(ItemRect, ItemSize.cx, 0);\r\n if Options.ShowCaptions then\r\n OffsetRect(TextRect, ItemSize.cx, 0);\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomItemViewer.PaintWindow(DC: HDC);\r\nbegin\r\n if FUpdateCount <> 0 then Exit;\r\n FCanvas.Lock;\r\n try\r\n FCanvas.Handle := DC;\r\n try\r\n TControlCanvas(FCanvas).UpdateTextFlags;\r\n Paint;\r\n finally\r\n FCanvas.Handle := 0;\r\n end;\r\n finally\r\n FCanvas.Unlock;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomItemViewer.ScrollIntoView(Index: Integer);\r\nvar\r\n Rect: TRect;\r\nbegin\r\n Rect := ItemRect(Index, True);\r\n Dec(Rect.Left, HorzScrollBar.Margin);\r\n Inc(Rect.Right, HorzScrollBar.Margin);\r\n Dec(Rect.Top, VertScrollBar.Margin);\r\n Inc(Rect.Bottom, VertScrollBar.Margin);\r\n if Rect.Left < 0 then\r\n with HorzScrollBar do\r\n Position := Position + Rect.Left\r\n else\r\n if Rect.Right > ClientWidth then\r\n begin\r\n if Rect.Right - Rect.Left > ClientWidth then\r\n Rect.Right := Rect.Left + ClientWidth;\r\n with HorzScrollBar do\r\n Position := Position + Rect.Right - ClientWidth;\r\n end;\r\n if Rect.Top < 0 then\r\n VertScrollBar.Position := VertScrollBar.Position + Rect.Top\r\n else\r\n if Rect.Bottom > ClientHeight then\r\n begin\r\n if Rect.Bottom - Rect.Top > ClientHeight then\r\n Rect.Bottom := Rect.Top + ClientHeight;\r\n VertScrollBar.Position := VertScrollBar.Position + Rect.Bottom - ClientHeight;\r\n end;\r\n UpdateAll;\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvCustomItemViewer.SetBorderStyle(const Value: TBorderStyle);\r\nbegin\r\n if Value <> FBorderStyle then\r\n begin\r\n FBorderStyle := Value;\r\n RecreateWnd;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomItemViewer.SetCount(const Value: Integer);\r\nbegin\r\n if Value <> Count then\r\n begin\r\n BeginUpdate;\r\n try\r\n FItems.Count := Value;\r\n if FSelectedIndex >= Value then\r\n FSelectedIndex := -1;\r\n finally\r\n EndUpdate;\r\n UpdateAll;\r\n if HandleAllocated then\r\n InvalidateClipRect(Canvas.ClipRect);\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomItemViewer.SetItems(Index: Integer;\r\n const Value: TJvViewerItem);\r\nvar\r\n Item: TJvViewerItem;\r\nbegin\r\n Item := FItems[Index];\r\n if Item <> Value then\r\n begin\r\n if Item = nil then\r\n Item := GetItemClass.Create(Self);\r\n Item.Assign(Value);\r\n FItems[Index] := Item;\r\n Changed;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomItemViewer.SetOptions(const Value: TJvCustomItemViewerOptions);\r\nbegin\r\n FOptions.Assign(Value);\r\n Changed;\r\nend;\r\n\r\nprocedure TJvCustomItemViewer.SetSelected(Item: TJvViewerItem;\r\n const Value: Boolean);\r\nbegin\r\n if (Item <> nil) and not (cdsSelected in Item.State) then\r\n Item.State := Item.State + [cdsSelected];\r\nend;\r\n\r\nprocedure TJvCustomItemViewer.SetSelectedIndex(const Value: Integer);\r\nbegin\r\n // if (FSelectedIndex <> Value) then\r\n begin\r\n if (FSelectedIndex >= 0) and (FSelectedIndex < Count) and (cdsSelected in Items[FSelectedIndex].State) then\r\n Items[FSelectedIndex].State := Items[FSelectedIndex].State - [cdsSelected];\r\n\r\n FSelectedIndex := Value;\r\n\r\n if (Value >= 0) and (Value < Count) and not (cdsSelected in Items[Value].State) then\r\n Items[Value].State := Items[Value].State + [cdsSelected];\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomItemViewer.ToggleSelection(Index: Integer;\r\n SetSelection: Boolean);\r\nbegin\r\n if cdsSelected in Items[Index].State then\r\n begin\r\n Items[Index].State := Items[Index].State - [cdsSelected];\r\n if Index = SelectedIndex then\r\n SelectedIndex := FindFirstSelected;\r\n end\r\n else\r\n begin\r\n Items[Index].State := Items[Index].State + [cdsSelected];\r\n if SetSelection then\r\n FSelectedIndex := Index;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomItemViewer.ShiftSelection(Index: Integer; SetSelection: Boolean);\r\nvar\r\n I: Integer;\r\n AFromCol, AFromRow: Integer;\r\n AToCol, AToRow: Integer;\r\n ACurrCol, ACurrRow: Integer;\r\n\r\n function InRange(Value, Min, Max: Integer): Boolean;\r\n begin\r\n Result := (Value >= Min) and (Value <= Max);\r\n end;\r\n\r\n procedure Swap(var X, Y: Integer);\r\n var\r\n I: Integer;\r\n begin\r\n I := X;\r\n X := Y;\r\n Y := I;\r\n end;\r\n\r\nbegin\r\n BeginUpdate;\r\n try\r\n if SelectedIndex < 0 then\r\n SelectedIndex := 0;\r\n IndexToColRow(SelectedIndex, AFromCol, AFromRow);\r\n IndexToColRow(Index, AToCol, AToRow);\r\n if AFromCol > AToCol then\r\n Swap(AFromCol, AToCol);\r\n if AFromRow > AToRow then\r\n Swap(AFromRow, AToRow);\r\n for I := 0 to Count - 1 do\r\n begin\r\n IndexToColRow(I, ACurrCol, ACurrRow);\r\n // access private variables so we don't trigger any OnChange event(s) by accident\r\n if InRange(ACurrCol, AFromCol, AToCol) and InRange(ACurrRow, AFromRow, AToRow) then\r\n Items[I].FState := Items[I].FState + [cdsSelected]\r\n else\r\n Items[I].FState := Items[I].FState - [cdsSelected];\r\n end;\r\n finally\r\n EndUpdate;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomItemViewer.DoUnSelectItems(ExcludeIndex: Integer);\r\nvar\r\n Item: TJvViewerItem;\r\nbegin\r\n if (ExcludeIndex >= 0) and (ExcludeIndex < Count) then\r\n Item := Items[ExcludeIndex]\r\n else\r\n Item := nil;\r\n PostMessage(Handle, CM_UNSELECTITEMS, WPARAM(Self), LPARAM(Item));\r\nend;\r\n\r\nprocedure TJvCustomItemViewer.UpdateAll;\r\nbegin\r\n if (csDestroying in ComponentState) or (Parent = nil) then\r\n Exit;\r\n HandleNeeded;\r\n if not HandleAllocated then\r\n Exit;\r\n\r\n HorzScrollBar.Smooth := Options.Smooth;\r\n VertScrollBar.Smooth := Options.Smooth;\r\n HorzScrollBar.Tracking := Options.Tracking;\r\n VertScrollBar.Tracking := Options.Tracking;\r\n\r\n FItemSize.cx := Options.Width + Options.HorzSpacing;\r\n FItemSize.cy := Options.Height + Options.VertSpacing;\r\n if Options.ShowCaptions then\r\n Inc(FItemSize.cy, GetTextHeight);\r\n if (FItemSize.cy < 1) or (FItemSize.cx < 1) or (Count < 1) then\r\n Exit;\r\n if Options.ScrollBar = tvHorizontal then\r\n begin\r\n if Options.AutoCenter then\r\n FRows := ClientHeight div FItemSize.cy\r\n else\r\n FRows := (Height + FItemSize.cy div 3) div FItemSize.cy;\r\n if FRows > Count then\r\n FRows := Count;\r\n if FRows < 1 then\r\n FRows := 1;\r\n // if (ClientHeight mod FItemSize.cy > FItemSize.cy div 2) then\r\n // Inc(FRows);\r\n FCols := Count div FRows;\r\n if FCols < 1 then\r\n FCols := 1;\r\n while (FRows * FCols) < Count do\r\n Inc(FCols);\r\n HorzScrollBar.Visible := True;\r\n VertScrollBar.Visible := False;\r\n end\r\n else\r\n begin\r\n if Options.AutoCenter then\r\n FCols := ClientWidth div FItemSize.cx\r\n else\r\n FCols := (Width + FItemSize.cx div 3) div FItemSize.cx;\r\n if FCols > Count then\r\n FCols := Count;\r\n if FCols < 1 then\r\n FCols := 1;\r\n // if (ClientWidth mod FItemSize.cx > FItemSize.cx div 2) then\r\n // Inc(FCols);\r\n FRows := Count div FCols;\r\n if FRows < 1 then\r\n FRows := 1;\r\n while (FRows * FCols) < Count do\r\n Inc(FRows);\r\n HorzScrollBar.Visible := False;\r\n VertScrollBar.Visible := True;\r\n end;\r\n HorzScrollBar.Range := FCols * FItemSize.cx;\r\n VertScrollBar.Range := FRows * FItemSize.cy;\r\n UpdateOffset;\r\n CalcIndices;\r\n CheckHotTrack;\r\nend;\r\n\r\nprocedure TJvCustomItemViewer.UpdateOffset;\r\nbegin\r\n if Options.AutoCenter then\r\n begin\r\n FTopLeft.X := (ClientWidth - FCols * FItemSize.cx) div 2;\r\n FTopLeft.Y := (ClientHeight - FRows * FItemSize.cy) div 2;\r\n end\r\n else\r\n begin\r\n FTopLeft.X := Options.HorzSpacing div 2;\r\n FTopLeft.Y := Options.VertSpacing div 2;\r\n end;\r\n if FTopLeft.X < Options.HorzSpacing div 2 then\r\n FTopLeft.X := Options.HorzSpacing div 2;\r\n if FTopLeft.Y < Options.VertSpacing div 2 then\r\n FTopLeft.Y := Options.VertSpacing div 2;\r\n if HorzScrollBar.Visible then\r\n Dec(FTopLeft.X, HorzScrollBar.Position);\r\n if VertScrollBar.Visible then\r\n Dec(FTopLeft.Y, VertScrollBar.Position);\r\nend;\r\n\r\nprocedure TJvCustomItemViewer.GetDlgCode(var Code: TDlgCodes);\r\nbegin\r\n Code := [dcWantArrows];\r\nend;\r\n\r\nprocedure TJvCustomItemViewer.WMHScroll(var Msg: TWMHScroll);\r\nbegin\r\n inherited;\r\n UpdateAll;\r\n InvalidateClipRect(ClientRect);\r\n if Assigned(FOnScroll) then\r\n FOnScroll(Self);\r\nend;\r\n\r\nprocedure TJvCustomItemViewer.MouseDown(Button: TMouseButton; Shift: TShiftState;\r\n X, Y: Integer);\r\nbegin\r\n if Button = mbLeft then\r\n begin\r\n FTempSelected := ItemAtPos(X, Y, True);\r\n if CanFocus then\r\n SetFocus;\r\n end\r\n else\r\n if Button = mbRight then\r\n begin\r\n StopScrollTimer;\r\n if Options.RightClickSelect then\r\n begin\r\n FTempSelected := ItemAtPos(X, Y, True);\r\n if CanFocus then\r\n SetFocus;\r\n SelectedIndex := FTempSelected;\r\n Invalidate;\r\n end;\r\n end;\r\n inherited MouseDown(Button, Shift, X, Y);\r\nend;\r\n\r\nprocedure TJvCustomItemViewer.MouseUp(Button: TMouseButton; Shift: TShiftState;\r\n X, Y: Integer);\r\nvar\r\n I: Integer;\r\nbegin\r\n if Button = mbLeft then\r\n begin\r\n I := ItemAtPos(X, Y, True);\r\n if (I = FTempSelected) and (I >= 0) and (I < Count) then\r\n begin\r\n if Options.MultiSelect then\r\n begin\r\n if (Shift * KeyboardShiftStates = [ssCtrl]) then\r\n ToggleSelection(FTempSelected, True)\r\n else\r\n if Shift * KeyboardShiftStates = [ssShift] then\r\n ShiftSelection(FTempSelected, True)\r\n else\r\n begin\r\n DoUnSelectItems(FTempSelected);\r\n SelectedIndex := FTempSelected;\r\n Invalidate;\r\n end;\r\n end\r\n else\r\n SelectedIndex := FTempSelected;\r\n end\r\n else\r\n if I < 0 then\r\n // begin\r\n DoUnSelectItems(-1);\r\n // SelectedIndex := -1;\r\n // end;\r\n FTempSelected := -1;\r\n end;\r\n inherited MouseUp(Button, Shift, X, Y);\r\nend;\r\n\r\nprocedure TJvCustomItemViewer.WMNCHitTest(var Msg: TMessage);\r\nbegin\r\n // enable scroll bars at design-time\r\n DefaultHandler(Msg);\r\nend;\r\n\r\nprocedure TJvCustomItemViewer.WMPaint(var Msg: TWMPaint);\r\nbegin\r\n ControlState := ControlState + [csCustomPaint];\r\n inherited;\r\n ControlState := ControlState - [csCustomPaint];\r\nend;\r\n\r\nprocedure TJvCustomItemViewer.WMVScroll(var Msg: TWMVScroll);\r\nbegin\r\n inherited;\r\n UpdateAll;\r\n InvalidateClipRect(ClientRect);\r\n if Assigned(FOnScroll) then\r\n FOnScroll(Self);\r\nend;\r\n\r\nprocedure TJvCustomItemViewer.WMCancelMode(var Msg: TWMCancelMode);\r\nbegin\r\n inherited;\r\n StopScrollTimer;\r\nend;\r\n\r\nprocedure TJvCustomItemViewer.FocusSet(PrevWnd: THandle);\r\nbegin\r\n inherited FocusSet(PrevWnd);\r\n if PrevWnd = Handle then\r\n begin\r\n if SelectedIndex >= 0 then\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomItemViewer.BoundsChanged;\r\nbegin\r\n UpdateAll;\r\n if HandleAllocated then\r\n InvalidateClipRect(ClientRect);\r\n inherited BoundsChanged;\r\nend;\r\n\r\nprocedure TJvCustomItemViewer.Changed;\r\nbegin\r\n inherited Changed;\r\n if (FUpdateCount = 0) and HandleAllocated then\r\n begin\r\n UpdateAll;\r\n if not Options.MultiSelect then\r\n DoUnSelectItems(SelectedIndex);\r\n InvalidateClipRect(ClientRect);\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomItemViewer.DoScrollTimer(Sender: TObject);\r\nvar\r\n DoInvalidate: Boolean;\r\n P: TPoint;\r\nbegin\r\n FScrollTimer.Enabled := False;\r\n FScrollTimer.Interval := cScrollIntervall;\r\n DoInvalidate := False;\r\n GetCursorPos(P);\r\n if FDragImages <> nil then\r\n FDragImages.HideDragImage;\r\n case TScrollEdge(ScrollEdge) of\r\n seLeft:\r\n if (Options.ScrollBar = tvHorizontal) and HorzScrollBar.Visible and (HorzScrollBar.Position > 0) then\r\n DoInvalidate := PostMessage(Handle, WM_HSCROLL, SB_LINELEFT, 0);\r\n seTop:\r\n if (Options.ScrollBar = tvVertical) and VertScrollBar.Visible and (VertScrollBar.Position > 0) then\r\n DoInvalidate := PostMessage(Handle, WM_VSCROLL, SB_LINELEFT, 0);\r\n seRight:\r\n if (Options.ScrollBar = tvHorizontal) and HorzScrollBar.Visible and (HorzScrollBar.Position < HorzScrollBar.Range)\r\n then\r\n DoInvalidate := PostMessage(Handle, WM_HSCROLL, SB_LINERIGHT, 0);\r\n seBottom:\r\n if (Options.ScrollBar = tvVertical) and VertScrollBar.Visible and (VertScrollBar.Position < VertScrollBar.Range)\r\n then\r\n DoInvalidate := PostMessage(Handle, WM_VSCROLL, SB_LINERIGHT, 0);\r\n end;\r\n if FDragImages <> nil then\r\n FDragImages.ShowDragImage;\r\n if (ScrollEdge <> Ord(seNone)) and DoInvalidate then\r\n Invalidate;\r\n // UpdateWindow(Handle);\r\n FScrollTimer.Enabled := True;\r\nend;\r\n\r\nprocedure TJvCustomItemViewer.DragOver(Source: TObject; X, Y: Integer;\r\n State: TDragState; var Accept: Boolean);\r\nconst\r\n cEdgeSize = 4;\r\nbegin\r\n inherited DragOver(Source, X, Y, State, Accept);\r\n if Accept and Options.DragAutoScroll then\r\n begin\r\n if X <= cEdgeSize then\r\n ScrollEdge := Ord(seLeft)\r\n else\r\n if X >= ClientWidth - cEdgeSize then\r\n ScrollEdge := Ord(seRight)\r\n else\r\n if Y <= cEdgeSize then\r\n ScrollEdge := Ord(seTop)\r\n else\r\n if Y >= ClientHeight - cEdgeSize then\r\n ScrollEdge := Ord(seBottom)\r\n else\r\n ScrollEdge := Ord(seNone);\r\n if (ScrollEdge = Ord(seNone)) and Assigned(FScrollTimer) then\r\n StopScrollTimer\r\n else\r\n if (ScrollEdge <> Ord(seNone)) and not Assigned(FScrollTimer) then\r\n begin\r\n FScrollTimer := TTimer.Create(nil);\r\n FScrollTimer.Enabled := False;\r\n FScrollTimer.Interval := cScrollDelay;\r\n FScrollTimer.OnTimer := DoScrollTimer;\r\n FScrollTimer.Enabled := True;\r\n end;\r\n end\r\n else\r\n StopScrollTimer;\r\nend;\r\n\r\nprocedure TJvCustomItemViewer.DragCanceled;\r\nbegin\r\n inherited DragCanceled;\r\n StopScrollTimer;\r\nend;\r\n\r\nprocedure TJvCustomItemViewer.DoEndDrag(Sender: TObject; X, Y: Integer);\r\nbegin\r\n inherited DoEndDrag(Sender, X, Y);\r\n StopScrollTimer;\r\nend;\r\n\r\nprocedure TJvCustomItemViewer.StopScrollTimer;\r\nbegin\r\n if FScrollTimer <> nil then\r\n begin\r\n FreeAndNil(FScrollTimer);\r\n UpdateWindow(Handle);\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomItemViewer.SelectAll;\r\nbegin\r\n SelectItems(0, Count - 1, True);\r\nend;\r\n\r\nprocedure TJvCustomItemViewer.SelectItems(StartIndex, EndIndex: Integer;\r\n AppendSelection: Boolean);\r\nvar\r\n I, AIndex: Integer;\r\nbegin\r\n AIndex := SelectedIndex;\r\n BeginUpdate;\r\n if not AppendSelection then\r\n DoUnSelectItems(-1);\r\n try\r\n for I := Max(StartIndex, 0) to Min(Count - 1, EndIndex) do\r\n Items[I].FState := Items[I].FState + [cdsSelected];\r\n if (AIndex >= StartIndex) and (AIndex <= EndIndex) then\r\n FSelectedIndex := AIndex\r\n else\r\n FSelectedIndex := StartIndex;\r\n finally\r\n EndUpdate;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomItemViewer.UnselectItems(StartIndex, EndIndex: Integer);\r\nvar\r\n I: Integer;\r\nbegin\r\n BeginUpdate;\r\n try\r\n for I := Max(0, StartIndex) to Min(EndIndex, Count - 1) do\r\n Items[I].FState := Items[I].FState - [cdsSelected];\r\n if (SelectedIndex >= StartIndex) and (SelectedIndex <= EndIndex) then\r\n FSelectedIndex := FindFirstSelected;\r\n finally\r\n EndUpdate;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomItemViewer.WMNCPaint(var Messages: TWMNCPaint);\r\nbegin\r\n inherited;\r\n {$IFDEF JVCLThemesEnabled}\r\n if ThemeServices.{$IFDEF RTL230_UP}Enabled{$ELSE}ThemesEnabled{$ENDIF RTL230_UP} then\r\n ThemeServices.PaintBorder(TWinControl(Self), False)\r\n {$ENDIF JVCLThemesEnabled}\r\nend;\r\n\r\nfunction TJvCustomItemViewer.HintShow(var HintInfo: {$IFDEF RTL200_UP}Controls.{$ENDIF RTL200_UP}THintInfo): Boolean;\r\nvar\r\n I: Integer;\r\nbegin\r\n I := ItemAtPos(HintInfo.CursorPos.X, HintInfo.CursorPos.Y, True);\r\n if I >= 0 then\r\n begin\r\n HintInfo.HintStr := Items[I].Hint;\r\n HintInfo.CursorRect := ItemRect(I, True);\r\n DoItemHint(I, HintInfo);\r\n end;\r\n if HintInfo.HintStr = '' then\r\n HintInfo.HintStr := Hint;\r\n Result := False;\r\nend;\r\n\r\nprocedure TJvCustomItemViewer.Deleted(Item: TJvViewerItem);\r\nbegin\r\n if Assigned(FOnDeletion) then\r\n FOnDeletion(Self, Item);\r\nend;\r\n\r\nprocedure TJvCustomItemViewer.Inserted(Item: TJvViewerItem);\r\nbegin\r\n if Assigned(FOnInsertion) then\r\n FOnInsertion(Self, Item);\r\nend;\r\n\r\nfunction TJvCustomItemViewer.DoItemHint(Index: Integer;\r\n var HintInfo: {$IFDEF RTL200_UP}Controls.{$ENDIF RTL200_UP}THintInfo): Boolean;\r\nbegin\r\n Result := False;\r\n if Assigned(FOnItemHint) then\r\n FOnItemHint(Self, Index, HintInfo, Result);\r\nend;\r\n\r\nprocedure TJvCustomItemViewer.ScrollBy(DeltaX, DeltaY: Integer);\r\nbegin\r\n if DeltaX <> 0 then\r\n HorzScrollBar.Position := HorzScrollBar.Position + DeltaX;\r\n if DeltaY <> 0 then\r\n VertScrollBar.Position := VertScrollBar.Position + DeltaY;\r\n UpdateAll;\r\nend;\r\n\r\nprocedure TJvCustomItemViewer.CustomSort(Compare: TListSortCompare);\r\nbegin\r\n FItems.Sort(Compare);\r\nend;\r\n\r\n//=== { TViewerDrawImageList } ===============================================\r\n\r\nprocedure TViewerDrawImageList.Initialize;\r\nbegin\r\n inherited Initialize;\r\n DragCursor := crArrow;\r\nend;\r\n\r\n{ TJvViewerItemList }\r\n\r\nfunction TJvViewerItemList.GetItem(Index: Integer): TJvViewerItem;\r\nbegin\r\n Result := inherited Items[Index] as TJvViewerItem;\r\nend;\r\n\r\nprocedure TJvViewerItemList.SetItem(Index: Integer; const Value: TJvViewerItem);\r\nbegin\r\n inherited Items[Index] := Value;\r\nend;\r\n\r\ninitialization\r\n {$IFDEF UNITVERSIONING}\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n {$ENDIF UNITVERSIONING}\r\n LoadOLEDragCursors;\r\n\r\nfinalization\r\n ClearBrushPatterns;\r\n {$IFDEF UNITVERSIONING}\r\n UnregisterUnitVersion(HInstance);\r\n {$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvDBActions.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvDBActions.Pas, released on 2004-12-30.\r\n\r\nThe Initial Developer of the Original Code is Jens Fudickar [jens dott fudicker att oratool dott de]\r\nPortions created by Jens Fudickar are Copyright (C) 2002 Jens Fudickar.\r\nAll Rights Reserved.\r\n\r\nContributor(s): -\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvDBActions.pas 13415 2012-09-10 09:51:54Z obones $\r\n\r\nunit JvDBActions;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, ActnList, Graphics,\r\n Forms, Controls, Classes, DB,\r\n {$IFDEF USE_3RDPARTY_DEVEXPRESS_CXGRID}\r\n cxGridCustomTableView,\r\n {$ENDIF USE_3RDPARTY_DEVEXPRESS_CXGRID}\r\n {$IFDEF USE_3RDPARTY_SMEXPORT}\r\n SMEWIZ, ExportDS, SMEEngine,\r\n {$ENDIF USE_3RDPARTY_SMEXPORT}\r\n {$IFDEF USE_3RDPARTY_SMIMPORT}\r\n SMIWiz, SMIBase,\r\n {$ENDIF USE_3RDPARTY_SMIMPORT}\r\n DBGrids, JvActionsEngine, JvDBActionsEngine, JvDynControlEngineDBTools,\r\n JvDynControlEngineDB, JvParameterListParameter;\r\n\r\ntype\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvDatabaseActionList = class(TJvActionBaseActionList)\r\n //The idea of the Action Classes is to work with any databased enabled control.\r\n //But not all of this controls already have a dataset or datasource control.\r\n //\r\n //So the connection is made by the \"DataComponent\".\r\n //Datacomponent can be any type of TComponent. TDatasource, TDataset, TDBGrid,\r\n //TDBEdit, also for examle the DevExpress Controls.\r\n //\r\n //Then we have a list of DatabaseControlEngines which have the availability to\r\n //find for a Component the based Dataset and Datasource Controls (if they exist).\r\n //For each new type of controls with specific need of handles a new Engine\r\n //must be created and registered. An example for these engines can be found\r\n //in \"JvDBActionsEngineControlCxGrid.pas\".\r\n //\r\n //When a datacomponent is assigned the action tries to find the correct\r\n //engine based on the component and uses the engine for all further operations.\r\n //\r\n //There are two ways to assign a datacomponent:\r\n //1. Assigning the component to the action list, then all actions in\r\n // this list (which are based on TJvDatabaseBaseAction class)\r\n // gets the datacomponent assigned also.\r\n //2. Using the active control, like the normal action handling.\r\n private\r\n function GetDataComponent: TComponent;\r\n function GetOnChangeDataComponent: TJvChangeActionComponent;\r\n procedure SetOnChangeDataComponent(const Value: TJvChangeActionComponent);\r\n procedure SetDataComponent(Value: TComponent);\r\n published\r\n property DataComponent: TComponent read GetDataComponent write SetDataComponent;\r\n property OnChangeDataComponent: TJvChangeActionComponent read GetOnChangeDataComponent write SetOnChangeDataComponent;\r\n end;\r\n\r\n TJvDatabaseActionBaseEngineClass = class of TJvDatabaseActionBaseControlEngine;\r\n\r\n TJvDatabaseBeforeExecuteEvent = procedure(Sender: TObject; ControlEngine: TJvDatabaseActionBaseControlEngine;\r\n DataComponent: TComponent; var ContinueExecute: Boolean) of object;\r\n TJvDatabaseExecuteEvent = procedure(Sender: TObject; ControlEngine: TJvDatabaseActionBaseControlEngine;\r\n DataComponent: TComponent) of object;\r\n TJvDatabaseExecuteDataSourceEvent = procedure(Sender: TObject; DataSource: TDataSource) of object;\r\n\r\n TJvDatabaseActionCheckEnabledEvent = procedure(aDataset : TDataset;aDataComponent : TComponent; aDatabaseControlEngine:\r\n TJvDatabaseActionBaseControlEngine; var aEnabled : Boolean) of object;\r\n\r\n TJvDatabaseBaseAction = class(TJvActionEngineBaseAction)\r\n private\r\n FDatabaseControlEngine: TJvDatabaseActionBaseControlEngine;\r\n FOnExecute: TJvDatabaseExecuteEvent;\r\n FOnExecuteDataSource: TJvDatabaseExecuteDataSourceEvent;\r\n fAfterExecute: TJvDatabaseExecuteEvent;\r\n FBeforeExecute: TJvDatabaseBeforeExecuteEvent;\r\n FDatasetEngine: TJvDatabaseActionBaseDatasetEngine;\r\n FOnCheckEnabled: TJvDatabaseActionCheckEnabledEvent;\r\n function GetOnChangeDataComponent: TJvChangeActionComponent;\r\n procedure SetOnChangeDataComponent(const Value: TJvChangeActionComponent);\r\n protected\r\n //1 This Procedure is called when the ActionComponent is changed\r\n procedure ChangeActionComponent(const AActionComponent: TComponent); override;\r\n procedure CheckEnabled(var AEnabled: Boolean); override;\r\n function GetDataComponent: TComponent;\r\n procedure SetDataComponent(Value: TComponent);\r\n function GetDataSet: TDataSet;\r\n function GetDataSource: TDataSource;\r\n function EngineIsActive: Boolean;\r\n function EngineHasData: Boolean;\r\n function EngineFieldCount: Integer;\r\n function EngineRecordCount: Integer;\r\n function EngineRecNo: Integer;\r\n function EngineCanInsert: Boolean;\r\n function EngineCanUpdate: Boolean;\r\n function EngineCanDelete: Boolean;\r\n function EngineEof: Boolean;\r\n function EngineBof: Boolean;\r\n function EngineCanNavigate: Boolean;\r\n function EngineCanRefresh: Boolean;\r\n function EngineCanRefreshRecord: Boolean;\r\n function EngineControlsDisabled: Boolean;\r\n function EngineEditModeActive: Boolean;\r\n function EngineSelectedRowsCount: Integer;\r\n function GetEngineList: TJvActionEngineList; override;\r\n property DatabaseControlEngine: TJvDatabaseActionBaseControlEngine read FDatabaseControlEngine;\r\n property DatasetEngine: TJvDatabaseActionBaseDatasetEngine read FDatasetEngine;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n function Execute: Boolean; override;\r\n procedure UpdateTarget(Target: TObject); override;\r\n function HandlesTarget(Target: TObject): Boolean; override;\r\n procedure ExecuteTarget(Target: TObject); override;\r\n property DataSource: TDataSource read GetDataSource;\r\n property DataSet: TDataSet read GetDataSet;\r\n published\r\n property OnChangeDataComponent: TJvChangeActionComponent read GetOnChangeDataComponent write SetOnChangeDataComponent;\r\n property OnCheckEnabled: TJvDatabaseActionCheckEnabledEvent read FOnCheckEnabled write FOnCheckEnabled;\r\n property OnExecute: TJvDatabaseExecuteEvent read FOnExecute write FOnExecute;\r\n property AfterExecute: TJvDatabaseExecuteEvent read FAfterExecute write FAfterExecute;\r\n property BeforeExecute: TJvDatabaseBeforeExecuteEvent read FBeforeExecute write FBeforeExecute;\r\n property OnExecuteDataSource: TJvDatabaseExecuteDataSourceEvent read FOnExecuteDataSource write FOnExecuteDataSource;\r\n property DataComponent: TComponent read GetDataComponent write SetDataComponent;\r\n end;\r\n\r\n TJvDatabaseSimpleAction = class(TJvDatabaseBaseAction)\r\n private\r\n FIsActive: Boolean;\r\n FHasData: Boolean;\r\n FCanInsert: Boolean;\r\n FCanUpdate: Boolean;\r\n FCanDelete: Boolean;\r\n FEditModeActive: Boolean;\r\n FManualEnabled: Boolean;\r\n procedure SetManualEnabled(const Value: Boolean);\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n procedure UpdateTarget(Target: TObject); override;\r\n published\r\n // If this paramater is active, the Action will be enabled if for the datacomponent-dataset is active\r\n property IsActive: Boolean read FIsActive write FIsActive default True;\r\n // If this paramater is active, the Action will be enabled if for the datacomponent-dataset contains records\r\n property HasData: Boolean read FHasData write FHasData default True;\r\n // If this paramater is active, the Action will be enabled if insert is allowed for the datacomponent-dataset\r\n property CanInsert: Boolean read FCanInsert write FCanInsert default False;\r\n // If this paramater is active, the Action will be enabled if update is allowed for the datacomponent-dataset\r\n property CanUpdate: Boolean read FCanUpdate write FCanUpdate default False;\r\n // If this paramater is active, the Action will be enabled if delete is allowed for the datacomponent-dataset\r\n property CanDelete: Boolean read FCanDelete write FCanDelete default False;\r\n // If this paramater is active, the Action will be enabled if the datacomponent-dataset is in edit mode\r\n property EditModeActive: Boolean read FEditModeActive write FEditModeActive default False;\r\n // This property allows you enable / disable the action independently from the\r\n // automatic handling by IsActive, HasData, CanInsert, CanUpdate, EditModeActive\r\n property ManualEnabled: Boolean read FManualEnabled write SetManualEnabled default True;\r\n end;\r\n\r\n TJvDatabaseBaseActiveAction = class(TJvDatabaseBaseAction)\r\n public\r\n procedure UpdateTarget(Target: TObject); override;\r\n end;\r\n\r\n TJvDatabaseBaseEditAction = class(TJvDatabaseBaseActiveAction)\r\n public\r\n procedure UpdateTarget(Target: TObject); override;\r\n end;\r\n\r\n TJvDatabaseBaseNavigateAction = class(TJvDatabaseBaseActiveAction)\r\n end;\r\n\r\n TJvDatabaseFirstAction = class(TJvDatabaseBaseNavigateAction)\r\n public\r\n procedure UpdateTarget(Target: TObject); override;\r\n procedure ExecuteTarget(Target: TObject); override;\r\n end;\r\n\r\n TJvDatabaseLastAction = class(TJvDatabaseBaseNavigateAction)\r\n public\r\n procedure UpdateTarget(Target: TObject); override;\r\n procedure ExecuteTarget(Target: TObject); override;\r\n end;\r\n\r\n TJvDatabasePriorAction = class(TJvDatabaseBaseNavigateAction)\r\n public\r\n procedure UpdateTarget(Target: TObject); override;\r\n procedure ExecuteTarget(Target: TObject); override;\r\n end;\r\n\r\n TJvDatabaseNextAction = class(TJvDatabaseBaseNavigateAction)\r\n public\r\n procedure UpdateTarget(Target: TObject); override;\r\n procedure ExecuteTarget(Target: TObject); override;\r\n end;\r\n\r\n TJvDatabasePriorBlockAction = class(TJvDatabaseBaseNavigateAction)\r\n public\r\n FBlockSize: Integer;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n procedure UpdateTarget(Target: TObject); override;\r\n procedure ExecuteTarget(Target: TObject); override;\r\n published\r\n property BlockSize: Integer read FBlockSize write FBlockSize default 50;\r\n end;\r\n\r\n TJvDatabaseNextBlockAction = class(TJvDatabaseBaseNavigateAction)\r\n private\r\n FBlockSize: Integer;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n procedure UpdateTarget(Target: TObject); override;\r\n procedure ExecuteTarget(Target: TObject); override;\r\n published\r\n property BlockSize: Integer read FBlockSize write FBlockSize default 50;\r\n end;\r\n\r\n TJvDatabaseRefreshAction = class(TJvDatabaseBaseActiveAction)\r\n private\r\n FRefreshLastPosition: Boolean;\r\n FRefreshAsOpenClose: Boolean;\r\n protected\r\n procedure Refresh;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n procedure ExecuteTarget(Target: TObject); override;\r\n procedure UpdateTarget(Target: TObject); override;\r\n published\r\n property RefreshLastPosition: Boolean read FRefreshLastPosition write FRefreshLastPosition default True;\r\n property RefreshAsOpenClose: Boolean read FRefreshAsOpenClose write FRefreshAsOpenClose default False;\r\n end;\r\n\r\n TJvDatabasePositionAction = class(TJvDatabaseBaseNavigateAction)\r\n private\r\n FMinCountSelectedRows: Integer;\r\n FShowSelectedRows: Boolean;\r\n protected\r\n procedure SetCaption(Value: string); {$IFDEF RTL240_UP}reintroduce;{$ENDIF RTL240_UP}\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n procedure ShowPositionDialog;\r\n procedure UpdateTarget(Target: TObject); override;\r\n procedure ExecuteTarget(Target: TObject); override;\r\n published\r\n property MinCountSelectedRows: Integer read FMinCountSelectedRows write FMinCountSelectedRows default 2;\r\n property ShowSelectedRows: Boolean read FShowSelectedRows write FShowSelectedRows default True;\r\n end;\r\n\r\n TJvDatabaseInsertType = ( itInsert, itAppend);\r\n\r\n TJvDatabaseSingleRecordWindowAction = class;\r\n\r\n TJvDatabaseInsertAction = class(TJvDatabaseBaseEditAction)\r\n private\r\n FInsertType: TJvDatabaseInsertType;\r\n FSingleRecordWindowAction: TJvDatabaseSingleRecordWindowAction;\r\n procedure SetSingleRecordWindowAction(const Value: TJvDatabaseSingleRecordWindowAction);\r\n procedure SingleRecordOnFormShowEvent(ADatacomponent : TComponent; ADynControlEngineDB: TJvDynControlEngineDB);\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n procedure UpdateTarget(Target: TObject); override;\r\n procedure ExecuteTarget(Target: TObject); override;\r\n procedure Notification(AComponent: TComponent; Operation: TOperation); override;\r\n published\r\n //1 The property defines that the new record is created via the insert or the append method\r\n property InsertType: TJvDatabaseInsertType read FInsertType write FInsertType default itInsert;\r\n //1 Use this property to show a single record window after inserting a new record\r\n property SingleRecordWindowAction: TJvDatabaseSingleRecordWindowAction read FSingleRecordWindowAction write\r\n SetSingleRecordWindowAction;\r\n end;\r\n\r\n TJvDatabaseOnCopyRecord = procedure(Field: TField; OldValue: Variant) of object;\r\n TJvDatabaseBeforeCopyRecord = procedure(DataSet: TDataSet; var RefreshAllowed: Boolean) of object;\r\n TJvDatabaseAfterCopyRecord = procedure(DataSet: TDataSet) of object;\r\n\r\n TJvDatabaseCopyAction = class(TJvDatabaseBaseEditAction)\r\n private\r\n FBeforeCopyRecord: TJvDatabaseBeforeCopyRecord;\r\n FAfterCopyRecord: TJvDatabaseAfterCopyRecord;\r\n FInsertType: TJvDatabaseInsertType;\r\n FOnCopyRecord: TJvDatabaseOnCopyRecord;\r\n FSingleRecordWindowAction: TJvDatabaseSingleRecordWindowAction;\r\n procedure SetSingleRecordWindowAction(const Value: TJvDatabaseSingleRecordWindowAction);\r\n procedure SingleRecordOnFormShowEvent(ADatacomponent : TComponent; ADynControlEngineDB: TJvDynControlEngineDB);\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n procedure CopyRecord;\r\n procedure UpdateTarget(Target: TObject); override;\r\n procedure ExecuteTarget(Target: TObject); override;\r\n procedure Notification(AComponent: TComponent; Operation: TOperation); override;\r\n published\r\n //1 The property defines that the new record is created via the insert or the append method\r\n property InsertType: TJvDatabaseInsertType read FInsertType write FInsertType default itInsert;\r\n //1 Use this property to show a single record window after inserting a new record\r\n property SingleRecordWindowAction: TJvDatabaseSingleRecordWindowAction read FSingleRecordWindowAction write\r\n SetSingleRecordWindowAction;\r\n property BeforeCopyRecord: TJvDatabaseBeforeCopyRecord read FBeforeCopyRecord write FBeforeCopyRecord;\r\n property AfterCopyRecord: TJvDatabaseAfterCopyRecord read FAfterCopyRecord write FAfterCopyRecord;\r\n property OnCopyRecord: TJvDatabaseOnCopyRecord read FOnCopyRecord write FOnCopyRecord;\r\n end;\r\n\r\n TJvDatabaseEditAction = class(TJvDatabaseBaseEditAction)\r\n private\r\n FSingleRecordWindowAction: TJvDatabaseSingleRecordWindowAction;\r\n procedure SetSingleRecordWindowAction(const Value: TJvDatabaseSingleRecordWindowAction);\r\n procedure SingleRecordOnFormShowEvent(ADatacomponent : TComponent; ADynControlEngineDB: TJvDynControlEngineDB);\r\n public\r\n procedure UpdateTarget(Target: TObject); override;\r\n procedure ExecuteTarget(Target: TObject); override;\r\n procedure Notification(AComponent: TComponent; Operation: TOperation); override;\r\n published\r\n //1 Use this property to show a single record window after inserting a new record\r\n property SingleRecordWindowAction: TJvDatabaseSingleRecordWindowAction read FSingleRecordWindowAction write\r\n SetSingleRecordWindowAction;\r\n end;\r\n\r\n TJvDatabaseDeleteAction = class(TJvDatabaseBaseEditAction)\r\n public\r\n procedure UpdateTarget(Target: TObject); override;\r\n procedure ExecuteTarget(Target: TObject); override;\r\n end;\r\n\r\n TJvDatabasePostAction = class(TJvDatabaseBaseEditAction)\r\n public\r\n procedure UpdateTarget(Target: TObject); override;\r\n procedure ExecuteTarget(Target: TObject); override;\r\n end;\r\n\r\n TJvDatabaseCancelAction = class(TJvDatabaseBaseEditAction)\r\n public\r\n procedure UpdateTarget(Target: TObject); override;\r\n procedure ExecuteTarget(Target: TObject); override;\r\n end;\r\n\r\n TJvDatabaseSingleRecordWindowAction = class(TJvDatabaseBaseActiveAction)\r\n private\r\n FOnCreateDataControlsEvent: TJvDataSourceEditDialogCreateDataControlsEvent;\r\n FOptions: TJvShowSingleRecordWindowOptions;\r\n protected\r\n FOnFormShow: TJvDataSourceEditDialogOnFormShowEvent;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n procedure ExecuteTarget(Target: TObject); override;\r\n procedure ShowSingleRecordWindow;\r\n property OnFormShow: TJvDataSourceEditDialogOnFormShowEvent read FOnFormShow write FOnFormShow;\r\n published\r\n property OnCreateDataControlsEvent: TJvDataSourceEditDialogCreateDataControlsEvent read FOnCreateDataControlsEvent\r\n write FOnCreateDataControlsEvent;\r\n property Options: TJvShowSingleRecordWindowOptions read FOptions write FOptions;\r\n end;\r\n\r\n TJvDatabaseOpenAction = class(TJvDatabaseBaseActiveAction)\r\n public\r\n procedure UpdateTarget(Target: TObject); override;\r\n procedure ExecuteTarget(Target: TObject); override;\r\n end;\r\n\r\n TJvDatabaseCloseAction = class(TJvDatabaseBaseActiveAction)\r\n public\r\n procedure UpdateTarget(Target: TObject); override;\r\n procedure ExecuteTarget(Target: TObject); override;\r\n end;\r\n\r\n {$IFDEF USE_3RDPARTY_SMEXPORT}\r\n\r\n TJvDatabaseSMExportOptions = class(TPersistent)\r\n private\r\n FOnAfterExecuteExport: TNotifyEvent;\r\n FOnBeforeExecuteExport: TNotifyEvent;\r\n FHelpContext: THelpContext;\r\n FFormats: TExportFormatTypes;\r\n FTitle: TCaption;\r\n FDefaultOptionsDirectory: string;\r\n FKeyGenerator: string;\r\n FOptions: TSMOptions;\r\n procedure SetDefaultOptionsDirectory(const Value: string);\r\n public\r\n constructor Create;\r\n destructor Destroy; override;\r\n procedure SMEWizardDlgGetCellParams(Sender: TObject; Field: TField; var Text: TSMEString; AFont: TFont; var Alignment:\r\n TAlignment; var Background: TColor; var CellType: TCellType);\r\n procedure SMEWizardDlgOnBeforeExecute(Sender: TObject);\r\n published\r\n property HelpContext: THelpContext read FHelpContext write FHelpContext;\r\n property Formats: TExportFormatTypes read FFormats write FFormats;\r\n property Title: TCaption read FTitle write FTitle;\r\n property DefaultOptionsDirectory: string read FDefaultOptionsDirectory write SetDefaultOptionsDirectory;\r\n property KeyGenerator: string read FKeyGenerator write FKeyGenerator;\r\n property Options: TSMOptions read FOptions write FOptions;\r\n property OnAfterExecuteExport: TNotifyEvent read FOnAfterExecuteExport write FOnAfterExecuteExport;\r\n property OnBeforeExecuteExport: TNotifyEvent read FOnBeforeExecuteExport write FOnBeforeExecuteExport;\r\n end;\r\n\r\n TJvDatabaseSMExportAction = class(TJvDatabaseBaseActiveAction)\r\n private\r\n FOptions: TJvDatabaseSMExportOptions;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n procedure ExecuteTarget(Target: TObject); override;\r\n procedure ExportData;\r\n published\r\n property Options: TJvDatabaseSMExportOptions read FOptions write FOptions;\r\n end;\r\n\r\n {$ENDIF USE_3RDPARTY_SMEXPORT}\r\n\r\n {$IFDEF USE_3RDPARTY_SMIMPORT}\r\n\r\n TJvDatabaseSMImportOptions = class(TPersistent)\r\n private\r\n FHelpContext: THelpContext;\r\n FFormats: TImportFormatTypes;\r\n FTitle: TCaption;\r\n FDefaultOptionsDirectory: string;\r\n FOptions: TSMIOptions;\r\n FWizardStyle: TSMIWizardStyle;\r\n procedure SetDefaultOptionsDirectory(const Value: string);\r\n public\r\n constructor Create;\r\n published\r\n property HelpContext: THelpContext read FHelpContext write FHelpContext;\r\n property Formats: TImportFormatTypes read FFormats write FFormats;\r\n property Title: TCaption read FTitle write FTitle;\r\n property DefaultOptionsDirectory: string read FDefaultOptionsDirectory write SetDefaultOptionsDirectory;\r\n property Options: TSMIOptions read FOptions write FOptions;\r\n property WizardStyle: TSMIWizardStyle read FWizardStyle write FWizardStyle;\r\n end;\r\n\r\n TJvDatabaseSMImportAction = class(TJvDatabaseBaseEditAction)\r\n private\r\n FOptions: TJvDatabaseSMImportOptions;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n procedure ExecuteTarget(Target: TObject); override;\r\n procedure ImportData;\r\n published\r\n property Options: TJvDatabaseSMImportOptions read FOptions write FOptions;\r\n end;\r\n\r\n {$ENDIF USE_3RDPARTY_SMIMPORT}\r\n\r\n TJvDatabaseModifyAllAction = class(TJvDatabaseBaseEditAction)\r\n private\r\n FEnabledOnlyIfSelectedRows: Boolean;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n procedure ExecuteTarget(Target: TObject); override;\r\n procedure ModifyAll;\r\n procedure UpdateTarget(Target: TObject); override;\r\n published\r\n property EnabledOnlyIfSelectedRows: Boolean read FEnabledOnlyIfSelectedRows write FEnabledOnlyIfSelectedRows default\r\n True;\r\n end;\r\n\r\n TJvDatabaseShowSQLStatementAction = class(TJvDatabaseBaseActiveAction)\r\n private\r\n FWordWrap: Boolean;\r\n MemoParameter: TJvMemoParameter;\r\n CheckBoxParameter : TJvCheckBoxParameter;\r\n FShowWordWrapCheckBox: Boolean;\r\n procedure CheckBoxOnChange(Sender: TObject);\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n procedure ExecuteTarget(Target: TObject); override;\r\n procedure ShowSQLStatement;\r\n procedure UpdateTarget(Target: TObject); override;\r\n published\r\n //1 Defines if there is a visible checkbox to customize the word wrap behaviour of the memo control\r\n property ShowWordWrapCheckBox: Boolean read FShowWordWrapCheckBox write FShowWordWrapCheckBox default False;\r\n //1 Defines if the memo for the sql-statement is word-wrapped\r\n property WordWrap: Boolean read FWordWrap write FWordWrap default True;\r\n end;\r\n\r\ntype\r\n TJvDatabaseRefreshRecordAction = class(TJvDatabaseBaseActiveAction)\r\n public\r\n procedure ExecuteTarget(Target: TObject); override;\r\n procedure UpdateTarget(Target: TObject); override;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvDBActions.pas $';\r\n Revision: '$Revision: 13415 $';\r\n Date: '$Date: 2012-09-10 11:51:54 +0200 (lun. 10 sept. 2012) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n SysUtils, StrUtils,\r\n {$IFDEF USE_3RDPARTY_DEVEXPRESS_CXGRID}\r\n cxGrid,\r\n {$ENDIF USE_3RDPARTY_DEVEXPRESS_CXGRID}\r\n {$IFDEF USE_3RDPARTY_SMEXPORT}\r\n {$IFDEF USE_3RDPARTY_DEVEXPRESS_CXGRID}\r\n SMEEngCx,\r\n {$ENDIF USE_3RDPARTY_DEVEXPRESS_CXGRID}\r\n sme2sql,\r\n {$ENDIF USE_3RDPARTY_SMEXPORT}\r\n JvResources, JvParameterList, JvDSADialogs,\r\n Variants, Dialogs, StdCtrls, Clipbrd, JvJVCLUtils, JclFileUtils;\r\n\r\nfunction TJvDatabaseActionList.GetDataComponent: TComponent;\r\nbegin\r\n Result := ActionComponent;\r\nend;\r\n\r\nfunction TJvDatabaseActionList.GetOnChangeDataComponent: TJvChangeActionComponent;\r\nbegin\r\n Result := OnChangeActionComponent;\r\nend;\r\n\r\n//=== { TJvDatabaseActionList } ==============================================\r\n\r\nprocedure TJvDatabaseActionList.SetDataComponent(Value: TComponent);\r\nbegin\r\n ActionComponent := Value;\r\nend;\r\n\r\nprocedure TJvDatabaseActionList.SetOnChangeDataComponent(const Value: TJvChangeActionComponent);\r\nbegin\r\n OnChangeActionComponent := Value;\r\nend;\r\n\r\n//=== { TJvDatabaseBaseAction } ==============================================\r\n\r\nconstructor TJvDatabaseBaseAction.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FDatabaseControlEngine := Nil;\r\nend;\r\n\r\n//=== { TJvActionEngineBaseAction } ========================================\r\n\r\nprocedure TJvDatabaseBaseAction.ChangeActionComponent(const AActionComponent: TComponent);\r\nbegin\r\n inherited ChangeActionComponent(AActionComponent);\r\n if Assigned(ControlEngine) and (ControlEngine is TJvDatabaseActionBaseControlEngine) then\r\n FDatabaseControlEngine := TJvDatabaseActionBaseControlEngine(ControlEngine)\r\n else\r\n FDatabaseControlEngine := Nil;\r\n if Assigned(Dataset) then\r\n begin\r\n if Assigned(EngineList) and (EngineList is TJvDatabaseActionEngineList) then\r\n FDatasetEngine := TJvDatabaseActionEngineList(EngineList).GetDatasetEngine(Dataset)\r\n else\r\n FDatasetEngine := Nil;\r\n end\r\n else\r\n FDatasetEngine := nil;\r\nend;\r\n\r\nprocedure TJvDatabaseBaseAction.CheckEnabled(var AEnabled: Boolean);\r\nbegin\r\n if Assigned(fOnCheckEnabled) then\r\n fOnCheckEnabled (DataSet, DataComponent, DatabaseControlEngine, aEnabled);\r\nend;\r\n\r\nfunction TJvDatabaseBaseAction.GetDataSet: TDataSet;\r\nbegin\r\n if Assigned(DatabaseControlEngine) then\r\n Result := DatabaseControlEngine.DataSet(ActionComponent)\r\n else\r\n Result := nil;\r\nend;\r\n\r\nfunction TJvDatabaseBaseAction.GetDataSource: TDataSource;\r\nbegin\r\n if Assigned(DatabaseControlEngine) then\r\n Result := DatabaseControlEngine.DataSource(ActionComponent)\r\n else\r\n Result := nil;\r\nend;\r\n\r\nprocedure TJvDatabaseBaseAction.SetDataComponent(Value: TComponent);\r\nbegin\r\n ActionComponent := Value;\r\nend;\r\n\r\nfunction TJvDatabaseBaseAction.EngineIsActive: Boolean;\r\nbegin\r\n if Assigned(DatabaseControlEngine) then\r\n Result := DatabaseControlEngine.IsActive (DataComponent)\r\n else\r\n Result := False;\r\nend;\r\n\r\nfunction TJvDatabaseBaseAction.EngineHasData: Boolean;\r\nbegin\r\n if Assigned(DatabaseControlEngine) then\r\n Result := DatabaseControlEngine.HasData (DataComponent)\r\n else\r\n Result := False;\r\nend;\r\n\r\nfunction TJvDatabaseBaseAction.EngineFieldCount: Integer;\r\nbegin\r\n if Assigned(DatabaseControlEngine) then\r\n Result := DatabaseControlEngine.FieldCount (DataComponent)\r\n else\r\n Result := -1;\r\nend;\r\n\r\nfunction TJvDatabaseBaseAction.EngineRecordCount: Integer;\r\nbegin\r\n if Assigned(DatabaseControlEngine) then\r\n Result := DatabaseControlEngine.RecordCount (DataComponent)\r\n else\r\n Result := -1;\r\nend;\r\n\r\nfunction TJvDatabaseBaseAction.EngineRecNo: Integer;\r\nbegin\r\n if Assigned(DatabaseControlEngine) then\r\n Result := DatabaseControlEngine.RecNo (DataComponent)\r\n else\r\n Result := -1;\r\nend;\r\n\r\nfunction TJvDatabaseBaseAction.EngineCanInsert: Boolean;\r\nbegin\r\n if Assigned(DatabaseControlEngine) then\r\n Result := DatabaseControlEngine.CanInsert (DataComponent)\r\n else\r\n Result := False;\r\nend;\r\n\r\nfunction TJvDatabaseBaseAction.EngineCanUpdate: Boolean;\r\nbegin\r\n if Assigned(DatabaseControlEngine) then\r\n Result := DatabaseControlEngine.CanUpdate (DataComponent)\r\n else\r\n Result := False;\r\nend;\r\n\r\nfunction TJvDatabaseBaseAction.EngineCanDelete: Boolean;\r\nbegin\r\n if Assigned(DatabaseControlEngine) then\r\n Result := DatabaseControlEngine.CanDelete (DataComponent)\r\n else\r\n Result := False;\r\nend;\r\n\r\nfunction TJvDatabaseBaseAction.EngineEof: Boolean;\r\nbegin\r\n if Assigned(DatabaseControlEngine) then\r\n Result := DatabaseControlEngine.EOF (DataComponent)\r\n else\r\n Result := False;\r\nend;\r\n\r\nfunction TJvDatabaseBaseAction.EngineBof: Boolean;\r\nbegin\r\n if Assigned(DatabaseControlEngine) then\r\n Result := DatabaseControlEngine.Bof (DataComponent)\r\n else\r\n Result := False;\r\nend;\r\n\r\nfunction TJvDatabaseBaseAction.EngineCanNavigate: Boolean;\r\nbegin\r\n if Assigned(DatabaseControlEngine) then\r\n Result := DatabaseControlEngine.CanNavigate (DataComponent)\r\n else\r\n Result := False;\r\nend;\r\n\r\nfunction TJvDatabaseBaseAction.EngineCanRefresh: Boolean;\r\nbegin\r\n if Assigned(DatabaseControlEngine) then\r\n Result := DatabaseControlEngine.CanRefresh (DataComponent)\r\n else\r\n Result := False;\r\nend;\r\n\r\nfunction TJvDatabaseBaseAction.EngineCanRefreshRecord: Boolean;\r\nbegin\r\n if Assigned(DatabaseControlEngine) then\r\n Result := DatabaseControlEngine.CanRefreshRecord (DataComponent)\r\n else\r\n Result := False;\r\nend;\r\n\r\nfunction TJvDatabaseBaseAction.EngineControlsDisabled: Boolean;\r\nbegin\r\n if Assigned(DatabaseControlEngine) then\r\n Result := DatabaseControlEngine.ControlsDisabled (DataComponent)\r\n else\r\n Result := False;\r\nend;\r\n\r\nfunction TJvDatabaseBaseAction.EngineEditModeActive: Boolean;\r\nbegin\r\n if Assigned(DatabaseControlEngine) then\r\n Result := DatabaseControlEngine.EditModeActive (DataComponent)\r\n else\r\n Result := False;\r\nend;\r\n\r\nfunction TJvDatabaseBaseAction.EngineSelectedRowsCount: Integer;\r\nbegin\r\n if Assigned(DatabaseControlEngine) then\r\n Result := DatabaseControlEngine.SelectedRowsCount (DataComponent)\r\n else\r\n Result := -1;\r\nend;\r\n\r\nfunction TJvDatabaseBaseAction.Execute: Boolean;\r\nvar\r\n ContinueExecute: Boolean;\r\nbegin\r\n Result := False;\r\n if Assigned(FBeforeExecute) then\r\n FBeforeExecute(Self, DatabaseControlEngine, DataComponent, ContinueExecute)\r\n else\r\n ContinueExecute := True;\r\n if ContinueExecute then\r\n begin\r\n Result := inherited Execute;\r\n if Result and Assigned(FAfterExecute) then\r\n FAfterExecute(Self, DatabaseControlEngine, DataComponent)\r\n end;\r\nend;\r\n\r\nfunction TJvDatabaseBaseAction.HandlesTarget(Target: TObject): Boolean;\r\nbegin\r\n // Result := inherited HandlesTarget(Target);\r\n Result := Assigned(ControlEngine);\r\nend;\r\n\r\nprocedure TJvDatabaseBaseAction.UpdateTarget(Target: TObject);\r\nbegin\r\n if Assigned(DataSet) and not EngineControlsDisabled then\r\n SetEnabled(True)\r\n else\r\n SetEnabled(False);\r\nend;\r\n\r\nprocedure TJvDatabaseBaseAction.ExecuteTarget(Target: TObject);\r\nbegin\r\n if Assigned(FOnExecute) then\r\n FOnExecute(Self, DatabaseControlEngine, DataComponent)\r\n else\r\n if Assigned(FOnExecuteDataSource) then\r\n FOnExecuteDataSource(Self, DataSource)\r\n else\r\n inherited ExecuteTarget(Target);\r\nend;\r\n\r\nfunction TJvDatabaseBaseAction.GetDataComponent: TComponent;\r\nbegin\r\n Result := ActionComponent;\r\nend;\r\n\r\nfunction TJvDatabaseBaseAction.GetEngineList: TJvActionEngineList;\r\nbegin\r\n Result := RegisteredDatabaseActionEngineList;\r\nend;\r\n\r\nfunction TJvDatabaseBaseAction.GetOnChangeDataComponent: TJvChangeActionComponent;\r\nbegin\r\n Result := OnChangeActionComponent;\r\nend;\r\n\r\nprocedure TJvDatabaseBaseAction.SetOnChangeDataComponent(const Value: TJvChangeActionComponent);\r\nbegin\r\n OnChangeActionComponent := Value;\r\nend;\r\n\r\n//=== { TJvDatabaseSimpleAction } ============================================\r\n\r\nconstructor TJvDatabaseSimpleAction.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FIsActive := True;\r\n FHasData := True;\r\n FCanInsert := False;\r\n FCanUpdate := False;\r\n FCanDelete := False;\r\n FEditModeActive := False;\r\n FManualEnabled := True;\r\nend;\r\n\r\nprocedure TJvDatabaseSimpleAction.SetManualEnabled(const Value: Boolean);\r\nbegin\r\n FManualEnabled := Value;\r\n UpdateTarget(Self);\r\nend;\r\n\r\nprocedure TJvDatabaseSimpleAction.UpdateTarget(Target: TObject);\r\nvar\r\n Res: Boolean;\r\nbegin\r\n if Assigned(DataSet) and not EngineControlsDisabled then\r\n begin\r\n Res := ManualEnabled;\r\n if IsActive then\r\n Res := Res and EngineIsActive;\r\n if HasData then\r\n Res := Res and EngineHasData;\r\n if CanInsert then\r\n Res := Res and EngineCanInsert;\r\n if CanUpdate then\r\n Res := Res and EngineCanUpdate;\r\n if CanDelete then\r\n Res := Res and EngineCanDelete;\r\n if EditModeActive then\r\n Res := Res and EngineEditModeActive;\r\n SetEnabled(Res);\r\n end\r\n else\r\n SetEnabled(False);\r\nend;\r\n\r\n//=== { TJvDatabaseBaseActiveAction } ========================================\r\n\r\nprocedure TJvDatabaseBaseActiveAction.UpdateTarget(Target: TObject);\r\nbegin\r\n SetEnabled(Assigned(DataSet) and not EngineControlsDisabled and EngineIsActive);\r\nend;\r\n\r\n//=== { TJvDatabaseBaseEditAction } ==========================================\r\n\r\nprocedure TJvDatabaseBaseEditAction.UpdateTarget(Target: TObject);\r\nbegin\r\n SetEnabled(Assigned(DataSet) and not EngineControlsDisabled and EngineIsActive and\r\n (EngineCanInsert or EngineCanUpdate or EngineCanDelete));\r\nend;\r\n\r\n//=== { TJvDatabaseFirstAction } =============================================\r\n\r\nprocedure TJvDatabaseFirstAction.UpdateTarget(Target: TObject);\r\nbegin\r\n SetEnabled(Assigned(DatabaseControlEngine) and not EngineControlsDisabled and EngineIsActive and\r\n not EngineBof and EngineCanNavigate);\r\nend;\r\n\r\nprocedure TJvDatabaseFirstAction.ExecuteTarget(Target: TObject);\r\nbegin\r\n inherited ExecuteTarget(Target);\r\n DatabaseControlEngine.First (DataComponent);\r\nend;\r\n\r\n//=== { TJvDatabaseLastAction } ==============================================\r\n\r\nprocedure TJvDatabaseLastAction.UpdateTarget(Target: TObject);\r\nbegin\r\n SetEnabled(Assigned(DatabaseControlEngine) and not EngineControlsDisabled and EngineIsActive and\r\n not EngineEof and EngineCanNavigate);\r\nend;\r\n\r\nprocedure TJvDatabaseLastAction.ExecuteTarget(Target: TObject);\r\nbegin\r\n inherited ExecuteTarget(Target);\r\n DatabaseControlEngine.Last (DataComponent);\r\nend;\r\n\r\n//=== { TJvDatabasePriorAction } =============================================\r\n\r\nprocedure TJvDatabasePriorAction.UpdateTarget(Target: TObject);\r\nbegin\r\n SetEnabled(Assigned(DatabaseControlEngine) and not EngineControlsDisabled and EngineIsActive and\r\n not EngineBof and EngineCanNavigate);\r\nend;\r\n\r\nprocedure TJvDatabasePriorAction.ExecuteTarget(Target: TObject);\r\nbegin\r\n inherited ExecuteTarget(Target);\r\n DatabaseControlEngine.MoveBy(DataComponent,-1);\r\nend;\r\n\r\n//=== { TJvDatabaseNextAction } ==============================================\r\n\r\nprocedure TJvDatabaseNextAction.UpdateTarget(Target: TObject);\r\nbegin\r\n SetEnabled(Assigned(DatabaseControlEngine) and not EngineControlsDisabled and EngineIsActive and\r\n not EngineEof and EngineCanNavigate);\r\nend;\r\n\r\nprocedure TJvDatabaseNextAction.ExecuteTarget(Target: TObject);\r\nbegin\r\n inherited ExecuteTarget(Target);\r\n DatabaseControlEngine.MoveBy(DataComponent,1);\r\nend;\r\n\r\n//=== { TJvDatabasePriorBlockAction } ========================================\r\n\r\nconstructor TJvDatabasePriorBlockAction.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FBlockSize := 50;\r\nend;\r\n\r\nprocedure TJvDatabasePriorBlockAction.UpdateTarget(Target: TObject);\r\nbegin\r\n SetEnabled(Assigned(DatabaseControlEngine) and not EngineControlsDisabled and EngineIsActive and\r\n not EngineBof and EngineCanNavigate);\r\nend;\r\n\r\nprocedure TJvDatabasePriorBlockAction.ExecuteTarget(Target: TObject);\r\nbegin\r\n inherited ExecuteTarget(Target);\r\n try\r\n DatabaseControlEngine.DisableControls(DataComponent);\r\n DatabaseControlEngine.MoveBy(DataComponent, -BlockSize);\r\n finally\r\n DatabaseControlEngine.EnableControls(DataComponent);\r\n end;\r\nend;\r\n\r\n//=== { TJvDatabaseNextBlockAction } =========================================\r\n\r\nconstructor TJvDatabaseNextBlockAction.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FBlockSize := 50;\r\nend;\r\n\r\nprocedure TJvDatabaseNextBlockAction.UpdateTarget(Target: TObject);\r\nbegin\r\n SetEnabled(Assigned(DatabaseControlEngine) and not EngineControlsDisabled and EngineIsActive and\r\n not EngineEof and EngineCanNavigate);\r\nend;\r\n\r\nprocedure TJvDatabaseNextBlockAction.ExecuteTarget(Target: TObject);\r\nbegin\r\n inherited ExecuteTarget(Target);\r\n try\r\n DatabaseControlEngine.DisableControls(DataComponent);\r\n DatabaseControlEngine.MoveBy(DataComponent, BlockSize);\r\n finally\r\n DatabaseControlEngine.EnableControls(DataComponent);\r\n end;\r\nend;\r\n\r\n//=== { TJvDatabaseRefreshAction } ===========================================\r\n\r\nconstructor TJvDatabaseRefreshAction.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FRefreshLastPosition := True;\r\n FRefreshAsOpenClose := False;\r\nend;\r\n\r\nprocedure TJvDatabaseRefreshAction.ExecuteTarget(Target: TObject);\r\nbegin\r\n inherited ExecuteTarget(Target);\r\n Refresh;\r\nend;\r\n\r\nprocedure TJvDatabaseRefreshAction.Refresh;\r\nvar\r\n MyBookmark: TBookmark;\r\nbegin\r\n if Assigned(Dataset) then\r\n begin\r\n MyBookmark := nil;\r\n if RefreshLastPosition then\r\n MyBookmark := Dataset.GetBookmark;\r\n\r\n try\r\n if RefreshAsOpenClose then\r\n begin\r\n Dataset.Close;\r\n Dataset.Open;\r\n end\r\n else\r\n Dataset.Refresh;\r\n\r\n if RefreshLastPosition then\r\n if Dataset.Active then\r\n if Assigned(MyBookmark) then\r\n if Dataset.BookmarkValid(MyBookmark) then\r\n try\r\n Dataset.GotoBookmark(MyBookmark);\r\n except\r\n end;\r\n finally\r\n if RefreshLastPosition then\r\n Dataset.FreeBookmark(MyBookmark);\r\n end;\r\n end;\r\nend;\r\n\r\n//=== { TJvDatabaseBaseActiveAction } ========================================\r\n\r\nprocedure TJvDatabaseRefreshAction.UpdateTarget(Target: TObject);\r\nbegin\r\n SetEnabled(Assigned(DataSet) and not EngineControlsDisabled and EngineIsActive and EngineCanRefresh);\r\nend;\r\n\r\n//=== { TJvDatabasePositionAction } ==========================================\r\n\r\nconstructor TJvDatabasePositionAction.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FShowSelectedRows := True;\r\n FMinCountSelectedRows := 2;\r\nend;\r\n\r\nprocedure TJvDatabasePositionAction.UpdateTarget(Target: TObject);\r\nconst\r\n cFormat = ' %3d / %3d ';\r\n cFormatSelected = ' %3d / %3d (%d)';\r\nvar\r\n RecCount : Integer;\r\n SelCount : Integer;\r\nbegin\r\n SetEnabled(Assigned(DataSet) and not EngineControlsDisabled and\r\n EngineIsActive and EngineHasData and EngineCanNavigate);\r\n try\r\n if not EngineIsActive then\r\n SetCaption(Format(cFormat, [0, 0]))\r\n else\r\n begin\r\n RecCount := EngineRecordCount;\r\n if RecCount = 0 then\r\n SetCaption(Format(cFormat, [0, 0]))\r\n else\r\n begin\r\n SelCount := EngineSelectedRowsCount;\r\n if ShowSelectedRows and (SelCount >= MinCountSelectedRows) then\r\n SetCaption(Format(cFormatSelected, [EngineRecNo, RecCount, SelCount]))\r\n else\r\n SetCaption(Format(cFormat, [EngineRecNo, RecCount]));\r\n end;\r\n end;\r\n except\r\n SetCaption(Format(cFormat, [0, 0]));\r\n end;\r\nend;\r\n\r\nprocedure TJvDatabasePositionAction.ExecuteTarget(Target: TObject);\r\nbegin\r\n inherited ExecuteTarget(Target);\r\n ShowPositionDialog;\r\nend;\r\n\r\nprocedure TJvDatabasePositionAction.SetCaption(Value: string);\r\nbegin\r\n if Value <> Caption then\r\n {$IFDEF RTL240_UP}\r\n inherited SetCaption (Value);\r\n {$ELSE}\r\n Caption := Value;\r\n {$ENDIF RTL240_UP}\r\nend;\r\n\r\nprocedure TJvDatabasePositionAction.ShowPositionDialog;\r\nconst\r\n cCurrentPosition = 'CurrentPosition';\r\n cNewPosition = 'NewPosition';\r\n cKind = 'Kind';\r\nvar\r\n ParameterList: TJvParameterList;\r\n Parameter: TJvBaseParameter;\r\n S: string;\r\n Kind: Integer;\r\nbegin\r\n if not Assigned(DataSet) then\r\n Exit;\r\n ParameterList := TJvParameterList.Create(Self);\r\n try\r\n Parameter := TJvBaseParameter(TJvEditParameter.Create(ParameterList));\r\n Parameter.SearchName := cCurrentPosition;\r\n Parameter.ReadOnly := True;\r\n Parameter.Caption := RsDBPosCurrentPosition;\r\n Parameter.AsString := IntToStr(EngineRecNo + 1) + ' / ' + IntToStr(EngineRecordCount);\r\n Parameter.Width := 150;\r\n TJvEditParameter(Parameter).LabelWidth := 80;\r\n Parameter.Enabled := False;\r\n ParameterList.AddParameter(Parameter);\r\n Parameter := TJvBaseParameter(TJvEditParameter.Create(ParameterList));\r\n Parameter.Caption := RsDBPosNewPosition;\r\n Parameter.SearchName := cNewPosition;\r\n Parameter.Width := 150;\r\n TJvEditParameter(Parameter).LabelWidth := 80;\r\n ParameterList.AddParameter(Parameter);\r\n Parameter := TJvBaseParameter(TJvRadioGroupParameter.Create(ParameterList));\r\n Parameter.Caption := RsDBPosMovementType;\r\n Parameter.SearchName := cKind;\r\n Parameter.Width := 305;\r\n Parameter.Height := 54;\r\n TJvRadioGroupParameter(Parameter).Columns := 2;\r\n TJvRadioGroupParameter(Parameter).ItemList.Add(RsDBPosAbsolute);\r\n TJvRadioGroupParameter(Parameter).ItemList.Add(RsDBPosForward);\r\n TJvRadioGroupParameter(Parameter).ItemList.Add(RsDBPosBackward);\r\n TJvRadioGroupParameter(Parameter).ItemList.Add(RsDBPosPercental);\r\n TJvRadioGroupParameter(Parameter).ItemIndex := 0;\r\n ParameterList.AddParameter(Parameter);\r\n ParameterList.ArrangeSettings.WrapControls := True;\r\n ParameterList.ArrangeSettings.MaxWidth := 350;\r\n ParameterList.Messages.Caption := RsDBPosDialogCaption;\r\n if ParameterList.ShowParameterDialog then\r\n begin\r\n S := ParameterList.ParameterByName(cNewPosition).AsString;\r\n if S = '' then\r\n Exit;\r\n Kind := TJvRadioGroupParameter(ParameterList.ParameterByName(cKind)).ItemIndex;\r\n DataSet.DisableControls;\r\n try\r\n case Kind of\r\n 0:\r\n begin\r\n DataSet.First;\r\n DataSet.MoveBy(StrToInt(S) - 1);\r\n end;\r\n 1:\r\n DataSet.MoveBy(StrToInt(S));\r\n 2:\r\n DataSet.MoveBy(StrToInt(S) * -1);\r\n 3:\r\n begin\r\n DataSet.First;\r\n DataSet.MoveBy(Round((EngineRecordCount / 100.0) * StrToInt(S)) - 1);\r\n end;\r\n end;\r\n finally\r\n DataSet.EnableControls;\r\n end;\r\n end;\r\n finally\r\n ParameterList.Free;\r\n end;\r\nend;\r\n\r\n//=== { TJvDatabaseInsertAction } ============================================\r\n\r\nconstructor TJvDatabaseInsertAction.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FInsertType := itInsert;\r\nend;\r\n\r\nprocedure TJvDatabaseInsertAction.UpdateTarget(Target: TObject);\r\nbegin\r\n SetEnabled(Assigned(DataSet) and not EngineControlsDisabled and\r\n EngineIsActive and EngineCanInsert and not EngineEditModeActive);\r\nend;\r\n\r\nprocedure TJvDatabaseInsertAction.ExecuteTarget(Target: TObject);\r\nbegin\r\n inherited ExecuteTarget(Target);\r\n if Assigned(SingleRecordWindowAction) then\r\n begin\r\n try\r\n FSingleRecordWindowAction.OnFormShow := SingleRecordOnFormShowEvent;\r\n FSingleRecordWindowAction.Execute;\r\n finally\r\n FSingleRecordWindowAction.OnFormShow := nil;\r\n end;\r\n end\r\n else\r\n SingleRecordOnFormShowEvent(nil, nil);\r\nend;\r\n\r\nprocedure TJvDatabaseInsertAction.Notification(AComponent: TComponent;\r\n Operation: TOperation);\r\nbegin\r\n inherited Notification(AComponent, Operation);\r\n if Operation = opRemove then\r\n if AComponent = FSingleRecordWindowAction then\r\n SingleRecordWindowAction := nil;\r\nend;\r\n\r\nprocedure TJvDatabaseInsertAction.SetSingleRecordWindowAction(const Value: TJvDatabaseSingleRecordWindowAction);\r\nbegin\r\n ReplaceComponentReference(Self, Value, TComponent(FSingleRecordWindowAction));\r\nend;\r\n\r\nprocedure TJvDatabaseInsertAction.SingleRecordOnFormShowEvent(ADatacomponent : TComponent; ADynControlEngineDB:\r\n TJvDynControlEngineDB);\r\nbegin\r\n if InsertType = itAppend then\r\n DataSet.Append\r\n else\r\n DataSet.Insert;\r\nend;\r\n\r\n//=== { TJvDatabaseCopyAction } ==============================================\r\n\r\nconstructor TJvDatabaseCopyAction.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FInsertType := itInsert;\r\nend;\r\n\r\nprocedure TJvDatabaseCopyAction.UpdateTarget(Target: TObject);\r\nbegin\r\n SetEnabled(Assigned(DataSet) and not EngineControlsDisabled and EngineIsActive and\r\n EngineCanInsert and EngineHasData and not EngineEditModeActive);\r\nend;\r\n\r\nprocedure TJvDatabaseCopyAction.ExecuteTarget(Target: TObject);\r\nbegin\r\n inherited ExecuteTarget(Target);\r\n if Assigned(SingleRecordWindowAction) then\r\n begin\r\n try\r\n FSingleRecordWindowAction.OnFormShow := SingleRecordOnFormShowEvent;\r\n FSingleRecordWindowAction.Execute;\r\n finally\r\n FSingleRecordWindowAction.OnFormShow := nil;\r\n end;\r\n end\r\n else\r\n SingleRecordOnFormShowEvent(nil, nil);\r\nend;\r\n\r\nprocedure TJvDatabaseCopyAction.CopyRecord;\r\nvar\r\n Values: array of Variant;\r\n I: Integer;\r\n Value: Variant;\r\n Allowed: Boolean;\r\nbegin\r\n if not DataSet.Active then\r\n Exit;\r\n if DataSet.State in [dsInsert, dsEdit] then\r\n DataSet.Post;\r\n if DataSet.State <> dsBrowse then\r\n Exit;\r\n Allowed := True;\r\n if Assigned(FBeforeCopyRecord) then\r\n FBeforeCopyRecord(DataSet, Allowed);\r\n if not Allowed then\r\n Exit;\r\n SetLength(Values, DataSet.FieldCount);\r\n for I := 0 to DataSet.FieldCount - 1 do\r\n Values[I] := DataSet.Fields[I].AsVariant;\r\n if InsertType = itAppend then\r\n DataSet.Append\r\n else\r\n DataSet.Insert;\r\n if Assigned(FOnCopyRecord) then\r\n for I := 0 to DataSet.FieldCount - 1 do\r\n begin\r\n Value := Values[I];\r\n FOnCopyRecord(DataSet.Fields[I], Value);\r\n end\r\n else\r\n for I := 0 to DataSet.FieldCount - 1 do\r\n if (Dataset.Fields[i].FieldName <> 'ROWID') and\r\n not Dataset.Fields[i].ReadOnly then\r\n DataSet.Fields[I].AsVariant := Values[I];\r\n if Assigned(FAfterCopyRecord) then\r\n FAfterCopyRecord(DataSet);\r\nend;\r\n\r\nprocedure TJvDatabaseCopyAction.Notification(AComponent: TComponent; Operation:\r\n TOperation);\r\nbegin\r\n inherited Notification(AComponent, Operation);\r\n if Operation = opRemove then\r\n if AComponent = FSingleRecordWindowAction then\r\n SingleRecordWindowAction := nil;\r\nend;\r\n\r\nprocedure TJvDatabaseCopyAction.SetSingleRecordWindowAction(const Value: TJvDatabaseSingleRecordWindowAction);\r\nbegin\r\n ReplaceComponentReference(Self, Value, TComponent(FSingleRecordWindowAction));\r\nend;\r\n\r\nprocedure TJvDatabaseCopyAction.SingleRecordOnFormShowEvent(ADatacomponent : TComponent; ADynControlEngineDB:\r\n TJvDynControlEngineDB);\r\nbegin\r\n CopyRecord;\r\nend;\r\n\r\n//=== { TJvDatabaseEditAction } ==============================================\r\n\r\nprocedure TJvDatabaseEditAction.UpdateTarget(Target: TObject);\r\nbegin\r\n SetEnabled(Assigned(DataSet) and not EngineControlsDisabled and EngineIsActive and\r\n EngineCanUpdate and EngineHasData and not EngineEditModeActive);\r\nend;\r\n\r\nprocedure TJvDatabaseEditAction.ExecuteTarget(Target: TObject);\r\nbegin\r\n inherited ExecuteTarget(Target);\r\n if Assigned(SingleRecordWindowAction) then\r\n begin\r\n try\r\n FSingleRecordWindowAction.OnFormShow := SingleRecordOnFormShowEvent;\r\n FSingleRecordWindowAction.Execute;\r\n finally\r\n FSingleRecordWindowAction.OnFormShow := nil;\r\n end;\r\n end\r\n else\r\n SingleRecordOnFormShowEvent(nil, nil);\r\nend;\r\n\r\nprocedure TJvDatabaseEditAction.Notification(AComponent: TComponent; Operation: TOperation);\r\nbegin\r\n inherited Notification(AComponent, Operation);\r\n if Operation = opRemove then\r\n if AComponent = FSingleRecordWindowAction then\r\n SingleRecordWindowAction := nil;\r\nend;\r\n\r\nprocedure TJvDatabaseEditAction.SetSingleRecordWindowAction(const Value: TJvDatabaseSingleRecordWindowAction);\r\nbegin\r\n ReplaceComponentReference(Self, Value, TComponent(FSingleRecordWindowAction));\r\nend;\r\n\r\nprocedure TJvDatabaseEditAction.SingleRecordOnFormShowEvent(ADatacomponent : TComponent; ADynControlEngineDB:\r\n TJvDynControlEngineDB);\r\nbegin\r\n DataSet.Edit;\r\nend;\r\n\r\n//=== { TJvDatabaseDeleteAction } ============================================\r\n\r\nprocedure TJvDatabaseDeleteAction.UpdateTarget(Target: TObject);\r\nbegin\r\n SetEnabled(Assigned(DataSet) and not EngineControlsDisabled and EngineIsActive and\r\n EngineCanDelete and EngineHasData and not EngineEditModeActive);\r\nend;\r\n\r\nprocedure TJvDatabaseDeleteAction.ExecuteTarget(Target: TObject);\r\nbegin\r\n inherited ExecuteTarget(Target);\r\n DataSet.Delete;\r\nend;\r\n\r\n//=== { TJvDatabasePostAction } ==============================================\r\n\r\nprocedure TJvDatabasePostAction.UpdateTarget(Target: TObject);\r\nbegin\r\n SetEnabled(Assigned(DataSet) and not EngineControlsDisabled and EngineIsActive and EngineEditModeActive);\r\nend;\r\n\r\nprocedure TJvDatabasePostAction.ExecuteTarget(Target: TObject);\r\nbegin\r\n inherited ExecuteTarget(Target);\r\n DataSet.Post;\r\nend;\r\n\r\n//=== { TJvDatabaseCancelAction } ============================================\r\n\r\nprocedure TJvDatabaseCancelAction.UpdateTarget(Target: TObject);\r\nbegin\r\n SetEnabled(Assigned(DataSet) and not EngineControlsDisabled and EngineIsActive and EngineEditModeActive);\r\nend;\r\n\r\nprocedure TJvDatabaseCancelAction.ExecuteTarget(Target: TObject);\r\nbegin\r\n inherited ExecuteTarget(Target);\r\n DataSet.Cancel;\r\nend;\r\n\r\n//=== { TJvDatabaseSingleRecordWindowAction } ================================\r\n\r\nconstructor TJvDatabaseSingleRecordWindowAction.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FOptions := TJvShowSingleRecordWindowOptions.Create;\r\nend;\r\n\r\ndestructor TJvDatabaseSingleRecordWindowAction.Destroy;\r\nbegin\r\n FOptions.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvDatabaseSingleRecordWindowAction.ExecuteTarget(Target: TObject);\r\nbegin\r\n inherited ExecuteTarget(Target);\r\n ShowSingleRecordWindow;\r\nend;\r\n\r\nprocedure TJvDatabaseSingleRecordWindowAction.ShowSingleRecordWindow;\r\nbegin\r\n DatabaseControlEngine.ShowSingleRecordWindow(DataComponent, Options, onCreateDataControlsEvent, OnFormShow);\r\nend;\r\n\r\n//=== { TJvDatabaseOpenAction } ==============================================\r\n\r\nprocedure TJvDatabaseOpenAction.UpdateTarget(Target: TObject);\r\nbegin\r\n SetEnabled(Assigned(DataSet) and not EngineIsActive);\r\nend;\r\n\r\nprocedure TJvDatabaseOpenAction.ExecuteTarget(Target: TObject);\r\nbegin\r\n inherited ExecuteTarget(Target);\r\n DataSet.Open;\r\nend;\r\n\r\n//=== { TJvDatabaseCloseAction } =============================================\r\n\r\nprocedure TJvDatabaseCloseAction.UpdateTarget(Target: TObject);\r\nbegin\r\n SetEnabled(Assigned(DataSet) and EngineIsActive and not EngineEditModeActive);\r\nend;\r\n\r\nprocedure TJvDatabaseCloseAction.ExecuteTarget(Target: TObject);\r\nbegin\r\n inherited ExecuteTarget(Target);\r\n DataSet.Close;\r\nend;\r\n\r\n{$IFDEF USE_3RDPARTY_SMEXPORT}\r\n\r\n//=== { TJvDatabaseSMExportOptions } =========================================\r\n\r\nconstructor TJvDatabaseSMExportOptions.Create;\r\nvar\r\n Fmt: TTableTypeExport;\r\n Option: TSMOption;\r\nbegin\r\n inherited Create;\r\n FFormats := [];\r\n for Fmt := Low(Fmt) to High(Fmt) do\r\n FFormats := FFormats + [Fmt];\r\n FOptions := [];\r\n for Option := Low(Option) to High(Option) do\r\n FOptions := FOptions + [Option];\r\n // FDataFormats := TSMEDataFormats.Create;\r\nend;\r\n\r\ndestructor TJvDatabaseSMExportOptions.Destroy;\r\nbegin\r\n // FreeAndNil(FDataFormats);\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvDatabaseSMExportOptions.SetDefaultOptionsDirectory(const Value: string);\r\nbegin\r\n FDefaultOptionsDirectory := trim(Value);\r\n if (FDefaultOptionsDirectory <> '') then\r\n FDefaultOptionsDirectory := PathAddSeparator(FDefaultOptionsDirectory);\r\nend;\r\n\r\nprocedure TJvDatabaseSMExportOptions.SMEWizardDlgGetCellParams(Sender: TObject; Field: TField; var Text: TSMEString;\r\n AFont: TFont; var Alignment: TAlignment; var Background: TColor; var CellType: TCellType);\r\nconst\r\n SToDateFormatLong = 'TO_DATE(''%s'', ''DD.MM.YYYY HH24:MI:SS'')';\r\n SToDateFormatShort = 'TO_DATE(''%s'', ''DD.MM.YYYY'')';\r\n SFormatLong = 'dd.mm.yyyy hh:nn:ss';\r\n SFormatShort = 'dd.mm.yyyy';\r\n SNull = 'NULL';\r\nvar\r\n DT: TDateTime;\r\nbegin\r\n if Sender is TSMExportToSQL then\r\n if Assigned(Field) then\r\n begin\r\n if Field.IsNull or (Field.AsString = '') then\r\n begin\r\n Text := SNull;\r\n CellType := ctBlank;\r\n end\r\n else\r\n case Field.DataType of\r\n ftFloat, ftBCD, ftCurrency:\r\n Text := AnsiReplaceStr(Text, ',', '.');\r\n ftDate, ftDateTime:\r\n begin\r\n DT := Field.AsDateTime;\r\n if DT <= 0 then\r\n Text := SNull\r\n else\r\n if DT = Trunc(DT) then\r\n Text := Format(SToDateFormatShort, [FormatDateTime(SFormatShort, DT)])\r\n else\r\n Text := Format(StoDateFormatLong, [FormatDateTime(SFormatLong, DT)]);\r\n CellType := ctBlank;\r\n end;\r\n end;\r\n end\r\n else\r\n if Text = '' then\r\n begin\r\n Text := SNull;\r\n CellType := ctBlank;\r\n end\r\n else\r\n case CellType of\r\n ctDouble, ctCurrency:\r\n Text := AnsiReplaceStr(Text, ',', '.');\r\n ctDateTime, ctDate, ctTime:\r\n begin\r\n try\r\n DT := VarToDateTime(Text);\r\n if DT <= 0 then\r\n Text := SNull\r\n else\r\n if DT = Trunc(DT) then\r\n Text := Format(SToDateFormatShort, [FormatDateTime(SFormatShort, DT)])\r\n else\r\n Text := Format(StoDateFormatLong, [FormatDateTime(SFormatLong, DT)]);\r\n except\r\n Text := Format(StoDateFormatLong, [Text]);\r\n end;\r\n CellType := ctBlank;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvDatabaseSMExportOptions.SMEWizardDlgOnBeforeExecute(Sender: TObject);\r\nbegin\r\n if Assigned(FOnBeforeExecuteExport) then\r\n FOnBeforeExecuteExport(Sender)\r\n else\r\n if Sender is TSMExportToSQL then\r\n TSMExportToSQL(Sender).SQLQuote := '''';\r\nend;\r\n\r\n//=== { TJvDatabaseSMExportAction } ==========================================\r\n\r\nconstructor TJvDatabaseSMExportAction.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FOptions := TJvDatabaseSMExportOptions.Create;\r\nend;\r\n\r\ndestructor TJvDatabaseSMExportAction.Destroy;\r\nbegin\r\n FOptions.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvDatabaseSMExportAction.ExecuteTarget(Target: TObject);\r\nbegin\r\n inherited ExecuteTarget(Target);\r\n ExportData;\r\nend;\r\n\r\nprocedure TJvDatabaseSMExportAction.ExportData;\r\nconst\r\n cLastExport = '\\Last Export.SME';\r\nvar\r\n SMEWizardDlg: TSMEWizardDlg;\r\n {$IFDEF USE_3RDPARTY_DEVEXPRESS_CXGRID}\r\n SMEEngineCx: TSMEcxCustomGridTableViewDataEngine;\r\n {$ENDIF USE_3RDPARTY_DEVEXPRESS_CXGRID}\r\nbegin\r\n {$IFDEF USE_3RDPARTY_DEVEXPRESS_CXGRID}\r\n SMEEngineCx := nil;\r\n {$ENDIF USE_3RDPARTY_DEVEXPRESS_CXGRID}\r\n SMEWizardDlg := TSMEWizardDlg.Create(Self);\r\n try\r\n SMEWizardDlg.ColumnSource := csDataSet;\r\n SMEWizardDlg.OnGetCellParams := Options.SMEWizardDlgGetCellParams;\r\n SMEWizardDlg.OnBeforeExecute := Options.SMEWizardDlgOnBeforeExecute;\r\n SMEWizardDlg.OnAfterExecute := Options.OnAfterExecuteExport;\r\n SMEWizardDlg.DataSet := DataSource.DataSet;\r\n SMEWizardDlg.Title := Options.Title;\r\n SMEWizardDlg.KeyGenerator := Options.Title;\r\n SMEWizardDlg.WizardStyle := smewiz.wsWindows2000;\r\n if (Options.DefaultOptionsDirectory <> '') and DirectoryExists(Options.DefaultOptionsDirectory) then\r\n SMEWizardDlg.SpecificationDir := ExcludeTrailingPathDelimiter(Options.DefaultOptionsDirectory)\r\n else\r\n SMEWizardDlg.SpecificationDir := GetCurrentDir;\r\n if DataComponent is TCustomDBGrid then\r\n begin\r\n SMEWizardDlg.DBGrid := TCustomControl(DataComponent);\r\n SMEWizardDlg.ColumnSource := csDBGrid;\r\n end\r\n {$IFDEF USE_3RDPARTY_DEVEXPRESS_CXGRID}\r\n else\r\n if (DataComponent is TcxGrid) and (TcxGrid(DataComponent).FocusedView is TcxCustomGridTableView) then\r\n begin\r\n SMEEnginecx := TSMEcxCustomGridTableViewDataEngine.Create(Self);\r\n SMEEngineCx.cxCustomGridTableView := TcxCustomGridTableView(TcxGrid(DataComponent).FocusedView);\r\n SMEWizardDlg.DataEngine := SMEEngineCx;\r\n SMEWizardDlg.ColumnSource := csDataEngine;\r\n end\r\n else\r\n if DataComponent is TcxCustomGridTableView then\r\n begin\r\n SMEEnginecx := TSMEcxCustomGridTableViewDataEngine.Create(Self);\r\n SMEEngineCx.cxCustomGridTableView := TcxCustomGridTableView(DataComponent);\r\n SMEWizardDlg.DataEngine := SMEEngineCx;\r\n SMEWizardDlg.ColumnSource := csDataEngine;\r\n end\r\n {$ENDIF USE_3RDPARTY_DEVEXPRESS_CXGRID}\r\n else\r\n begin\r\n SMEWizardDlg.DataSet := DataSet;\r\n SMEWizardDlg.ColumnSource := csDataSet;\r\n end;\r\n\r\n SMEWizardDlg.Formats := Options.Formats;\r\n SMEWizardDlg.Options := Options.Options;\r\n SMEWizardDlg.HelpContext := Options.HelpContext;\r\n if FileExists(SMEWizardDlg.SpecificationDir + cLastExport) then\r\n SMEWizardDlg.LoadSpecification(SMEWizardDlg.SpecificationDir + cLastExport);\r\n SMEWizardDlg.Execute;\r\n SMEWizardDlg.SaveSpecification('Last Export', SMEWizardDlg.SpecificationDir + cLastExport, False);\r\n finally\r\n {$IFDEF USE_3RDPARTY_DEVEXPRESS_CXGRID}\r\n FreeAndNil(SMEEngineCx);\r\n {$ENDIF USE_3RDPARTY_DEVEXPRESS_CXGRID}\r\n FreeAndNil(SMEWizardDlg);\r\n end;\r\nend;\r\n\r\n{$ENDIF USE_3RDPARTY_SMEXPORT}\r\n\r\n{$IFDEF USE_3RDPARTY_SMIMPORT}\r\n\r\n//=== { TJvDatabaseSMImportOptions } =========================================\r\n\r\nconstructor TJvDatabaseSMImportOptions.Create;\r\nvar\r\n Fmt: TTableTypeImport;\r\n Option: TSMIOption;\r\nbegin\r\n inherited Create;\r\n FFormats := [];\r\n for Fmt := Low(Fmt) to High(Fmt) do\r\n FFormats := FFormats + [Fmt];\r\n FOptions := [];\r\n for Option := Low(Option) to High(Option) do\r\n FOptions := FOptions + [Option];\r\nend;\r\n\r\nprocedure TJvDatabaseSMImportOptions.SetDefaultOptionsDirectory(const Value: string);\r\nbegin\r\n FDefaultOptionsDirectory := trim(Value);\r\n if (FDefaultOptionsDirectory <> '') then\r\n FDefaultOptionsDirectory := PathAddSeparator(FDefaultOptionsDirectory);\r\nend;\r\n\r\n//=== { TJvDatabaseSMImportAction } ==========================================\r\n\r\nconstructor TJvDatabaseSMImportAction.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FOptions := TJvDatabaseSMImportOptions.Create;\r\nend;\r\n\r\ndestructor TJvDatabaseSMImportAction.Destroy;\r\nbegin\r\n FOptions.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvDatabaseSMImportAction.ExecuteTarget(Target: TObject);\r\nbegin\r\n inherited ExecuteTarget(Target);\r\n ImportData;\r\nend;\r\n\r\nprocedure TJvDatabaseSMImportAction.ImportData;\r\nvar\r\n SMIWizardDlg: TSMIWizardDlg;\r\nbegin\r\n SMIWizardDlg := TSMIWizardDlg.Create(Self);\r\n try\r\n // SMIWizardDlg.OnGetSpecifications := Options.SMIWizardDlgGetSpecifications;\r\n if (Options.DefaultOptionsDirectory <> '') and DirectoryExists(Options.DefaultOptionsDirectory) then\r\n SMIWizardDlg.SpecificationDir := ExcludeTrailingPathDelimiter(Options.DefaultOptionsDirectory)\r\n else\r\n SMIWizardDlg.SpecificationDir := GetCurrentDir;\r\n SMIWizardDlg.DataSet := DataSource.DataSet;\r\n SMIWizardDlg.Title := Options.Title;\r\n SMIWizardDlg.Formats := Options.Formats;\r\n SMIWizardDlg.HelpContext := Options.HelpContext;\r\n SMIWizardDlg.WizardStyle := Options.WizardStyle;\r\n SMIWizardDlg.Options := Options.Options;\r\n // IF FileExists (Options.DefaultOptionsDirectory+'\\Last Import.SMI') THEN\r\n // SMIWizardDlg.LoadSpecification(Options.DefaultOptionsDirectory+'\\Last Import.SMI');\r\n SMIWizardDlg.Execute;\r\n SMIWizardDlg.SaveSpecification('Last Import', SMIWizardDlg.SpecificationDir + '\\Last Import.SMI', False);\r\n finally\r\n FreeAndNil(SMIWizardDlg);\r\n end;\r\nend;\r\n\r\n{$ENDIF USE_3RDPARTY_SMIMPORT}\r\n\r\n//=== { TJvDatabaseModifyAllAction } =========================================\r\n\r\nconstructor TJvDatabaseModifyAllAction.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FEnabledOnlyIfSelectedRows := True;\r\nend;\r\n\r\nprocedure TJvDatabaseModifyAllAction.ExecuteTarget(Target: TObject);\r\nbegin\r\n ModifyAll;\r\nend;\r\n\r\nprocedure TJvDatabaseModifyAllAction.ModifyAll;\r\nvar\r\n JvParameterList: TJvParameterList;\r\n Parameter: TJvBaseParameter;\r\n I: Integer;\r\n Field: TField;\r\n FieldName: string;\r\n ChangeTo: string;\r\n ClearField: Boolean;\r\n OnlyIfNull: Boolean;\r\nbegin\r\n if not Assigned(DatabaseControlEngine) then\r\n Exit;\r\n JvParameterList := TJvParameterList.Create(Self);\r\n try\r\n JvParameterList.Messages.Caption := SModifyAllCaption;\r\n JvParameterList.Messages.OkButton := SModifyAllOkButton;\r\n Parameter := TJvBaseParameter(TJvComboBoxParameter.Create(JvParameterList));\r\n TJvComboBoxParameter(Parameter).LabelArrangeMode := lamAbove;\r\n Parameter.SearchName := 'ModifyField';\r\n Parameter.Caption := SModifyAllModifyField;\r\n Parameter.Width := 330;\r\n for I := 0 to EngineFieldCount - 1 do\r\n begin\r\n Field := DatabaseControlEngine.FieldById(DataComponent, I);\r\n if Assigned(Field) then\r\n if not DatabaseControlEngine.IsFieldReadOnly(DataComponent,Field.FieldName) and\r\n DatabaseControlEngine.IsFieldVisible(DataComponent,Field.FieldName) then\r\n TJvComboBoxParameter(Parameter).ItemList.Add(Field.FieldName);\r\n if Assigned(DatabaseControlEngine.SelectedField(DataComponent)) then\r\n TJvComboBoxParameter(Parameter).ItemIndex :=\r\n TJvComboBoxParameter(Parameter).ItemList.IndexOf(DatabaseControlEngine.SelectedField(DataComponent).FieldName);\r\n if (TJvComboBoxParameter(Parameter).ItemIndex < 0) or\r\n (TJvComboBoxParameter(Parameter).ItemIndex >= TJvComboBoxParameter(Parameter).ItemList.Count) then\r\n TJvComboBoxParameter(Parameter).ItemIndex := 0;\r\n end;\r\n JvParameterList.AddParameter(Parameter);\r\n Parameter := TJvCheckBoxParameter.Create(JvParameterList);\r\n Parameter.SearchName := 'ClearFieldValues';\r\n Parameter.Caption := SModifyAllClearFieldValues;\r\n Parameter.Width := 150;\r\n JvParameterList.AddParameter(Parameter);\r\n Parameter := TJvEditParameter.Create(JvParameterList);\r\n Parameter.SearchName := 'ChangeTo';\r\n Parameter.Caption := SModifyAllChangeTo;\r\n Parameter.Width := 330;\r\n TJvEditParameter(Parameter).LabelArrangeMode := lamAbove;\r\n Parameter.DisableReasons.AddReason('ClearFieldValues', True);\r\n JvParameterList.AddParameter(Parameter);\r\n Parameter := TJvCheckBoxParameter.Create(JvParameterList);\r\n Parameter.SearchName := 'OnlyIfNull';\r\n Parameter.Caption := SModifyAllOnlyIfNull;\r\n Parameter.Width := 150;\r\n Parameter.DisableReasons.AddReason('ClearFieldValues', True);\r\n JvParameterList.AddParameter(Parameter);\r\n JvParameterList.MaxWidth := 360;\r\n if JvParameterList.ShowParameterDialog then\r\n begin\r\n FieldName := JvParameterList.ParameterByName('ModifyField').AsString;\r\n ClearField := JvParameterList.ParameterByName('ClearFieldValues').AsBoolean;\r\n OnlyIfNull := JvParameterList.ParameterByName('OnlyIfNull').AsBoolean;\r\n ChangeTo := JvParameterList.ParameterByName('ChangeTo').AsString;\r\n Field := DatabaseControlEngine.FieldByName(DataComponent, FieldName);\r\n if Assigned(Field) then\r\n try\r\n DatabaseControlEngine.DisableControls(DataComponent);\r\n for I := 0 to DatabaseControlEngine.SelectedRowsCount(DataComponent) - 1 do\r\n if DatabaseControlEngine.GotoSelectedRow(DataComponent,I) then\r\n begin\r\n try\r\n if (ClearField and not Field.IsNull) or\r\n not (OnlyIfNull and not Field.IsNull) then\r\n begin\r\n DatabaseControlEngine.Dataset(DataComponent).Edit;\r\n if ClearField then\r\n Field.Clear\r\n else\r\n Field.AsString := ChangeTo;\r\n if Assigned(DatabaseControlEngine.Dataset(DataComponent)) then\r\n DatabaseControlEngine.Dataset(DataComponent).Post;\r\n end;\r\n except\r\n on E: Exception do\r\n begin\r\n if Assigned(DatabaseControlEngine.Dataset(DataComponent)) then\r\n DatabaseControlEngine.Dataset(DataComponent).Cancel;\r\n JvDSADialogs.MessageDlg(E.Message, mtError, [mbOK], 0);\r\n end;\r\n end;\r\n end;\r\n finally\r\n DatabaseControlEngine.EnableControls(DataComponent);\r\n end;\r\n end;\r\n finally\r\n FreeAndNil(JvParameterList);\r\n end;\r\nend;\r\n\r\nprocedure TJvDatabaseModifyAllAction.UpdateTarget(Target: TObject);\r\nbegin\r\n SetEnabled(Assigned(DataSet) and not EngineControlsDisabled and\r\n EngineIsActive and EngineCanUpdate and not EngineEditModeActive and\r\n (not EnabledOnlyIfSelectedRows or (EngineSelectedRowsCount > 1)));\r\nend;\r\n\r\n//=== { TJvDatabaseShowSQLStatementAction } ==================================\r\n\r\nconstructor TJvDatabaseShowSQLStatementAction.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FWordWrap := True;\r\n FShowWordWrapCheckBox := False;\r\n CheckBoxParameter := nil;\r\n MemoParameter := nil;\r\nend;\r\n\r\nprocedure TJvDatabaseShowSQLStatementAction.CheckBoxOnChange(Sender: TObject);\r\nbegin\r\n if Assigned(MemoParameter) and Assigned(CheckBoxParameter) then\r\n begin\r\n CheckBoxParameter.GetData;\r\n MemoParameter.WordWrap := CheckBoxParameter.AsBoolean;\r\n if CheckBoxParameter.AsBoolean then\r\n MemoParameter.ScrollBars := ssVertical\r\n else\r\n MemoParameter.ScrollBars := ssBoth;\r\n end;\r\nend;\r\n\r\nprocedure TJvDatabaseShowSQLStatementAction.ExecuteTarget(Target: TObject);\r\nbegin\r\n ShowSQLStatement;\r\nend;\r\n\r\nprocedure TJvDatabaseShowSQLStatementAction.ShowSQLStatement;\r\nvar\r\n ParameterList: TJvParameterList;\r\nbegin\r\n if not Assigned(DatasetEngine) then\r\n Exit;\r\n ParameterList := TJvParameterList.Create(Self);\r\n try\r\n MemoParameter := TJvMemoParameter.Create(ParameterList);\r\n MemoParameter.SearchName := 'SQLStatement';\r\n if Self.WordWrap then\r\n MemoParameter.ScrollBars := ssVertical\r\n else\r\n MemoParameter.ScrollBars := ssBoth;\r\n MemoParameter.WordWrap := Self.WordWrap;\r\n MemoParameter.ReadOnly := True;\r\n MemoParameter.AsString := DatasetEngine.GetSQL(DataSet);\r\n MemoParameter.Width := 450;\r\n MemoParameter.Height := 350;\r\n ParameterList.AddParameter(MemoParameter);\r\n if ShowWordWrapCheckBox then\r\n begin\r\n CheckboxParameter := TJvCheckboxParameter.Create(ParameterList);\r\n CheckboxParameter.SearchName := 'CheckBox';\r\n CheckBoxParameter.AsBoolean := Self.WordWrap;\r\n CheckboxParameter.Width:= 300;\r\n CheckboxParameter.OnChange := CheckboxOnChange;\r\n CheckBoxParameter.Caption := SSQLStatementWordWrapped;\r\n ParameterList.AddParameter(CheckboxParameter);\r\n end;\r\n ParameterList.ArrangeSettings.WrapControls := True;\r\n ParameterList.ArrangeSettings.MaxWidth := 650;\r\n ParameterList.MaxHeight := 650;\r\n ParameterList.Messages.Caption := SShowSQLStatementCaption;\r\n ParameterList.Messages.OkButton := SSQLStatementClipboardButton;\r\n if ParameterList.ShowParameterDialog then\r\n ClipBoard.AsText := MemoParameter.AsString;\r\n finally\r\n FreeAndNil(ParameterList);\r\n CheckBoxParameter := nil;\r\n MemoParameter := nil;\r\n end;\r\nend;\r\n\r\nprocedure TJvDatabaseShowSQLStatementAction.UpdateTarget(Target: TObject);\r\nbegin\r\n SetEnabled(Assigned(DataSet) and Assigned(DatasetEngine) and DatasetEngine.SupportsGetSQL(DataComponent));\r\nend;\r\n\r\nprocedure TJvDatabaseRefreshRecordAction.ExecuteTarget(Target: TObject);\r\nbegin\r\n inherited ExecuteTarget(Target);\r\n if Assigned(DatasetEngine) then\r\n DatasetEngine.RefreshRecord (DataSet);\r\nend;\r\n\r\n//=== { TJvDatabaseBaseActiveAction } ========================================\r\n\r\nprocedure TJvDatabaseRefreshRecordAction.UpdateTarget(Target: TObject);\r\nbegin\r\n SetEnabled(Assigned(DataSet) and not EngineControlsDisabled and EngineIsActive and EngineCanRefreshRecord);\r\nend;\r\n\r\ninitialization\r\n {$IFDEF UNITVERSIONING}\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n {$ENDIF UNITVERSIONING}\r\n\r\nfinalization\r\n {$IFDEF UNITVERSIONING}\r\n UnregisterUnitVersion(HInstance);\r\n {$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvDBActionsEngine.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvDBActionsEngine.Pas, released on 2004-12-30.\r\n\r\nThe Initial Developer of the Original Code is Jens Fudickar [jens dott fudicker att oratool dott de]\r\nPortions created by Jens Fudickar are Copyright (C) 2002 Jens Fudickar.\r\nAll Rights Reserved.\r\n\r\nContributor(s): -\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvDBActionsEngine.pas 13138 2011-10-26 23:17:50Z jfudickar $\r\n\r\nunit JvDBActionsEngine;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, Graphics,\r\n Forms, Controls, Classes, DB,\r\n JvActionsEngine,\r\n DBGrids, JvPanel, JvDynControlEngineDB, JvDynControlEngineDBTools;\r\n\r\ntype\r\n TJvDatabaseActionBaseEngine = class(TJvActionBaseEngine)\r\n private\r\n public\r\n end;\r\n\r\n TJvDatabaseActionBaseDatasetEngine = class(TJvDatabaseActionBaseEngine)\r\n private\r\n protected\r\n public\r\n function GetDataset(aActionComponent: TComponent): TDataset; virtual;\r\n function GetSQL(aActionComponent: TComponent): string; virtual;\r\n procedure RefreshRecord(AActionComponent : TComponent); virtual;\r\n procedure SetSQL(aActionComponent: TComponent); virtual;\r\n function SupportsComponent(aActionComponent: TComponent): Boolean; override;\r\n function SupportsGetSQL(aActionComponent: TComponent): Boolean; virtual;\r\n function SupportsRefreshRecord(aActionComponent: TComponent): Boolean; virtual;\r\n function SupportsSetSQL(aActionComponent: TComponent): Boolean; virtual;\r\n end;\r\n\r\n TJvShowSingleRecordWindowOptions = class(TPersistent)\r\n private\r\n FDialogCaption: string;\r\n FPostButtonCaption: string;\r\n FCancelButtonCaption: string;\r\n FCloseButtonCaption: string;\r\n FBorderStyle: TFormBorderStyle;\r\n FPosition: TPosition;\r\n FTop: Integer;\r\n FLeft: Integer;\r\n FWidth: Integer;\r\n FHeight: Integer;\r\n FArrangeConstraints: TSizeConstraints;\r\n FArrangeSettings: TJvArrangeSettings;\r\n FFieldCreateOptions: TJvCreateDBFieldsOnControlOptions;\r\n FIncludeNavigator: Boolean;\r\n protected\r\n procedure SetArrangeSettings(Value: TJvArrangeSettings);\r\n procedure SetArrangeConstraints(Value: TSizeConstraints);\r\n procedure SetFieldCreateOptions(Value: TJvCreateDBFieldsOnControlOptions);\r\n public\r\n constructor Create;\r\n destructor Destroy; override;\r\n procedure SetOptionsToDialog(ADialog: TJvDynControlDataSourceEditDialog);\r\n published\r\n property DialogCaption: string read FDialogCaption write FDialogCaption;\r\n property PostButtonCaption: string read FPostButtonCaption write FPostButtonCaption;\r\n property CancelButtonCaption: string read FCancelButtonCaption write FCancelButtonCaption;\r\n property CloseButtonCaption: string read FCloseButtonCaption write FCloseButtonCaption;\r\n property BorderStyle: TFormBorderStyle read FBorderStyle write FBorderStyle default bsDialog;\r\n property Position: TPosition read FPosition write FPosition default poScreenCenter;\r\n property Top: Integer read FTop write FTop default 0;\r\n property Left: Integer read FLeft write FLeft default 0;\r\n property Width: Integer read FWidth write FWidth default 640;\r\n property Height: Integer read FHeight write FHeight default 480;\r\n property ArrangeConstraints: TSizeConstraints read FArrangeConstraints write SetArrangeConstraints;\r\n property ArrangeSettings: TJvArrangeSettings read FArrangeSettings write SetArrangeSettings;\r\n property FieldCreateOptions: TJvCreateDBFieldsOnControlOptions read FFieldCreateOptions\r\n write SetFieldCreateOptions;\r\n property IncludeNavigator: Boolean read FIncludeNavigator write\r\n FIncludeNavigator default false;\r\n end;\r\n\r\n TJvDatabaseActionBaseControlEngine = class(TJvDatabaseActionBaseEngine)\r\n protected\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n function Bof(aActionComponent: TComponent): Boolean; virtual;\r\n function CanDelete(aActionComponent: TComponent): Boolean; virtual;\r\n function CanInsert(aActionComponent: TComponent): Boolean; virtual;\r\n function CanNavigate(aActionComponent: TComponent): Boolean; virtual;\r\n function CanRefresh(aActionComponent: TComponent): Boolean; virtual;\r\n function CanRefreshRecord(aActionComponent: TComponent): Boolean; virtual;\r\n function CanUpdate(aActionComponent: TComponent): Boolean; virtual;\r\n function ControlsDisabled(aActionComponent: TComponent): Boolean; virtual;\r\n procedure DisableControls(aActionComponent: TComponent); virtual;\r\n function EditModeActive(aActionComponent: TComponent): Boolean; virtual;\r\n procedure EnableControls(aActionComponent: TComponent); virtual;\r\n function EOF(aActionComponent: TComponent): Boolean; virtual;\r\n function FieldById(aActionComponent: TComponent; const FieldId: Integer): TField; virtual;\r\n function FieldByName(aActionComponent: TComponent; const FieldName: string): TField; virtual;\r\n function FieldCount(aActionComponent: TComponent): Integer; virtual;\r\n procedure FillFieldList(aActionComponent: TComponent; var AFieldList: TStrings; const AOnlyVisible: Boolean); virtual;\r\n procedure First(aActionComponent: TComponent); virtual;\r\n function DataSet(aActionComponent: TComponent): TDataSet; virtual;\r\n function DataSource(aActionComponent: TComponent): TDataSource; virtual;\r\n function GotoSelectedRow(aActionComponent: TComponent;const ASelectedRow: Integer): Boolean; virtual;\r\n function HasData(aActionComponent: TComponent): Boolean; virtual;\r\n function IsActive(aActionComponent: TComponent): Boolean; virtual;\r\n function IsFieldReadOnly(aActionComponent: TComponent;const AFieldName: string): Boolean; virtual;\r\n function IsFieldVisible(aActionComponent: TComponent; const AFieldName: string): Boolean; virtual;\r\n procedure Last(aActionComponent: TComponent); virtual;\r\n procedure MoveBy(aActionComponent: TComponent; Distance: Integer); virtual;\r\n function RecNo(aActionComponent: TComponent): Integer; virtual;\r\n function RecordCount(aActionComponent: TComponent): Integer; virtual;\r\n function SelectedField(aActionComponent: TComponent): TField; virtual;\r\n function SelectedRowsCount(aActionComponent: TComponent): Integer; virtual;\r\n procedure ShowSingleRecordWindow(aActionComponent: TComponent; AOptions: TJvShowSingleRecordWindowOptions;\r\n ACreateDataControlsEvent: TJvDataSourceEditDialogCreateDataControlsEvent = nil; AOnFormShowEvent:\r\n TJvDataSourceEditDialogOnFormShowEvent = nil); virtual;\r\n function SupportsAction(AAction: TJvActionEngineBaseAction): Boolean; override;\r\n function SupportsComponent(aActionComponent: TComponent): Boolean; override;\r\n end;\r\n\r\n TJvDatabaseActionBaseEngineClass = class of TJvDatabaseActionBaseEngine;\r\n\r\n TJvDatabaseActionDBGridControlEngine = class(TJvDatabaseActionBaseControlEngine)\r\n private\r\n protected\r\n function CustomDBGrid(aActionComponent: TComponent): TCustomDBGrid; virtual;\r\n procedure OnCreateDataControls(ADatacomponent: TComponent; ADynControlEngineDB:\r\n TJvDynControlEngineDB; AParentControl: TWinControl; AFieldCreateOptions:\r\n TJvCreateDBFieldsOnControlOptions);\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n function DataSource(aActionComponent: TComponent): TDataSource; override;\r\n function GotoSelectedRow(aActionComponent: TComponent; const ASelectedRow:\r\n Integer): Boolean; override;\r\n function SelectedField(aActionComponent: TComponent): TField; override;\r\n function SelectedRowsCount(aActionComponent: TComponent): Integer; override;\r\n function SupportsComponent(aActionComponent: TComponent): Boolean; override;\r\n procedure ShowSingleRecordWindow(aActionComponent: TComponent; AOptions:\r\n TJvShowSingleRecordWindowOptions; ACreateDataControlsEvent:\r\n TJvDataSourceEditDialogCreateDataControlsEvent = nil; AOnFormShowEvent:\r\n TJvDataSourceEditDialogOnFormShowEvent = nil); override;\r\n end;\r\n\r\n TJvDatabaseActionEngineList = class(TJvActionEngineList)\r\n public\r\n procedure RegisterEngine(AEngineClass: TJvDatabaseActionBaseEngineClass);\r\n function GetDatasetEngine(AComponent: TComponent): TJvDatabaseActionBaseDatasetEngine;\r\n function GetDatabaseControlEngine(AComponent: TComponent):\r\n TJvDatabaseActionBaseControlEngine;\r\n function SupportsDataset(AComponent: TComponent): Boolean;\r\n end;\r\n\r\nprocedure RegisterDatabaseActionEngine(AEngineClass:\r\n TJvDatabaseActionBaseEngineClass);\r\n\r\nfunction RegisteredDatabaseActionEngineList: TJvDatabaseActionEngineList;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvDBActionsEngine.pas $';\r\n Revision: '$Revision: 13138 $';\r\n Date: '$Date: 2011-10-27 01:17:50 +0200 (jeu. 27 oct. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n SysUtils, Grids, TypInfo,\r\n JvResources,\r\n Variants, JvDBActions, Dialogs;\r\n\r\nvar\r\n IntRegisteredActionEngineList: TJvDatabaseActionEngineList;\r\n\r\nconstructor TJvDatabaseActionBaseControlEngine.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\nend;\r\n\r\nfunction TJvDatabaseActionBaseControlEngine.Bof(aActionComponent: TComponent): Boolean;\r\nbegin\r\n if Assigned(DataSet(aActionComponent)) then\r\n Result := DataSet(aActionComponent).Bof\r\n else\r\n Result := False;\r\nend;\r\n\r\nfunction TJvDatabaseActionBaseControlEngine.CanDelete(aActionComponent: TComponent): Boolean;\r\nbegin\r\n if Assigned(DataSet(aActionComponent)) then\r\n Result := DataSet(aActionComponent).CanModify\r\n else\r\n Result := False;\r\nend;\r\n\r\nfunction TJvDatabaseActionBaseControlEngine.CanInsert(aActionComponent: TComponent): Boolean;\r\nbegin\r\n if Assigned(DataSet(aActionComponent)) then\r\n Result := DataSet(aActionComponent).CanModify\r\n else\r\n Result := False;\r\nend;\r\n\r\nfunction TJvDatabaseActionBaseControlEngine.CanNavigate(aActionComponent: TComponent): Boolean;\r\nbegin\r\n Result := Assigned(DataSet(aActionComponent));\r\nend;\r\n\r\nfunction TJvDatabaseActionBaseControlEngine.CanRefresh(aActionComponent: TComponent): Boolean;\r\nbegin\r\n Result := Assigned(DataSet(aActionComponent));\r\nend;\r\n\r\nfunction TJvDatabaseActionBaseControlEngine.CanRefreshRecord(aActionComponent: TComponent): Boolean;\r\nbegin\r\n Result := Assigned(DataSet(aActionComponent));\r\nend;\r\n\r\nfunction TJvDatabaseActionBaseControlEngine.CanUpdate(aActionComponent: TComponent): Boolean;\r\nbegin\r\n if Assigned(DataSet(aActionComponent)) then\r\n Result := DataSet(aActionComponent).CanModify\r\n else\r\n Result := False;\r\nend;\r\n\r\nfunction TJvDatabaseActionBaseControlEngine.ControlsDisabled(aActionComponent: TComponent): Boolean;\r\nbegin\r\n if Assigned(DataSet(aActionComponent)) then\r\n Result := DataSet(aActionComponent).ControlsDisabled\r\n else\r\n Result := False;\r\nend;\r\n\r\nprocedure TJvDatabaseActionBaseControlEngine.DisableControls(aActionComponent: TComponent);\r\nbegin\r\n if Assigned(DataSet(aActionComponent)) then\r\n DataSet(aActionComponent).DisableControls;\r\nend;\r\n\r\nfunction TJvDatabaseActionBaseControlEngine.EditModeActive(aActionComponent: TComponent): Boolean;\r\nbegin\r\n if Assigned(DataSet(aActionComponent)) then\r\n Result := DataSet(aActionComponent).State in [dsInsert, dsEdit]\r\n else\r\n Result := False;\r\nend;\r\n\r\nprocedure TJvDatabaseActionBaseControlEngine.EnableControls(aActionComponent: TComponent);\r\nbegin\r\n if Assigned(DataSet(aActionComponent)) then\r\n DataSet(aActionComponent).EnableControls;\r\nend;\r\n\r\nfunction TJvDatabaseActionBaseControlEngine.EOF(aActionComponent: TComponent): Boolean;\r\nbegin\r\n if Assigned(DataSet(aActionComponent)) then\r\n Result := DataSet(aActionComponent).EOF\r\n else\r\n Result := False;\r\nend;\r\n\r\nfunction TJvDatabaseActionBaseControlEngine.FieldById(aActionComponent: TComponent; const FieldId: Integer): TField;\r\nbegin\r\n if Assigned(DataSet(aActionComponent)) then\r\n Result := DataSet(aActionComponent).Fields[FieldId]\r\n else\r\n Result := nil;\r\nend;\r\n\r\nfunction TJvDatabaseActionBaseControlEngine.FieldByName(aActionComponent: TComponent; const FieldName: string): TField;\r\nbegin\r\n if Assigned(DataSet(aActionComponent)) then\r\n Result := DataSet(aActionComponent).FieldByName(FieldName)\r\n else\r\n Result := nil;\r\nend;\r\n\r\nfunction TJvDatabaseActionBaseControlEngine.FieldCount(aActionComponent: TComponent): Integer;\r\nbegin\r\n if Assigned(DataSet(aActionComponent)) then\r\n Result := DataSet(aActionComponent).FieldCount\r\n else\r\n Result := -1;\r\nend;\r\n\r\nprocedure TJvDatabaseActionBaseControlEngine.FillFieldList(aActionComponent: TComponent; var AFieldList: TStrings;\r\n const AOnlyVisible: Boolean);\r\nvar\r\n I: Integer;\r\n ds : TDataset;\r\nbegin\r\n AFieldList.Clear;\r\n ds := DataSet(aActionComponent);\r\n if Assigned(ds) then\r\n begin\r\n for I := 0 to ds.Fields.Count - 1 do\r\n if not AOnlyVisible or IsFieldVisible(aActionComponent,ds.Fields[I].FieldName) then\r\n AFieldList.Add(ds.Fields[I].FieldName);\r\n end;\r\nend;\r\n\r\nprocedure TJvDatabaseActionBaseControlEngine.First(aActionComponent: TComponent);\r\nbegin\r\n if Assigned(DataSet(aActionComponent)) then\r\n DataSet(aActionComponent).First;\r\nend;\r\n\r\nfunction TJvDatabaseActionBaseControlEngine.DataSet(aActionComponent: TComponent): TDataSet;\r\nbegin\r\n if Assigned(DataSource(aActionComponent)) then\r\n Result := DataSource(aActionComponent).DataSet\r\n else if Assigned(aActionComponent) and (aActionComponent is TDataSet) then\r\n Result := TDataSet(aActionComponent)\r\n else\r\n Result := nil;\r\nend;\r\n\r\nfunction TJvDatabaseActionBaseControlEngine.DataSource(aActionComponent: TComponent): TDataSource;\r\nbegin\r\n if Assigned(aActionComponent) and (aActionComponent is TDataSource) then\r\n Result := TDataSource(aActionComponent)\r\n else\r\n Result := nil;\r\nend;\r\n\r\nfunction TJvDatabaseActionBaseControlEngine.GotoSelectedRow(aActionComponent: TComponent;const ASelectedRow: Integer):\r\n Boolean;\r\nbegin\r\n Result := False;\r\nend;\r\n\r\nfunction TJvDatabaseActionBaseControlEngine.HasData(aActionComponent: TComponent): Boolean;\r\nbegin\r\n if Assigned(DataSet(aActionComponent)) then\r\n Result := DataSet(aActionComponent).RecordCount > 0\r\n else\r\n Result := False;\r\nend;\r\n\r\nfunction TJvDatabaseActionBaseControlEngine.IsActive(aActionComponent: TComponent): Boolean;\r\nbegin\r\n if Assigned(DataSet(aActionComponent)) then\r\n Result := DataSet(aActionComponent).Active\r\n else\r\n Result := False;\r\nend;\r\n\r\nfunction TJvDatabaseActionBaseControlEngine.IsFieldReadOnly(aActionComponent: TComponent;const AFieldName: string):\r\n Boolean;\r\nvar\r\n Field: TField;\r\nbegin\r\n Field := FieldByName(aActionComponent, aFieldName);\r\n if Assigned(Field) then\r\n Result := Field.ReadOnly\r\n else\r\n Result := False;\r\nend;\r\n\r\nfunction TJvDatabaseActionBaseControlEngine.IsFieldVisible(aActionComponent: TComponent; const AFieldName: string):\r\n Boolean;\r\nvar\r\n Field: TField;\r\nbegin\r\n Field := FieldByName(aActionComponent, AFieldName);\r\n if Assigned(Field) then\r\n Result := Field.Visible\r\n else\r\n Result := False;\r\nend;\r\n\r\nprocedure TJvDatabaseActionBaseControlEngine.Last(aActionComponent: TComponent);\r\nbegin\r\n if Assigned(DataSet(aActionComponent)) then\r\n DataSet(aActionComponent).Last;\r\nend;\r\n\r\nprocedure TJvDatabaseActionBaseControlEngine.MoveBy(aActionComponent: TComponent; Distance: Integer);\r\nbegin\r\n if Assigned(DataSet(aActionComponent)) then\r\n DataSet(aActionComponent).MoveBy(Distance);\r\nend;\r\n\r\nfunction TJvDatabaseActionBaseControlEngine.RecNo(aActionComponent: TComponent): Integer;\r\nbegin\r\n if Assigned(DataSet(aActionComponent)) then\r\n Result := DataSet(aActionComponent).RecNo\r\n else\r\n Result := -1;\r\nend;\r\n\r\nfunction TJvDatabaseActionBaseControlEngine.RecordCount(aActionComponent: TComponent): Integer;\r\nbegin\r\n if Assigned(DataSet(aActionComponent)) then\r\n Result := DataSet(aActionComponent).RecordCount\r\n else\r\n Result := -1;\r\nend;\r\n\r\nfunction TJvDatabaseActionBaseControlEngine.SelectedField(aActionComponent: TComponent): TField;\r\nbegin\r\n Result := nil;\r\nend;\r\n\r\nfunction TJvDatabaseActionBaseControlEngine.SelectedRowsCount(aActionComponent: TComponent): Integer;\r\nbegin\r\n Result := 0;\r\nend;\r\n\r\nprocedure TJvDatabaseActionBaseControlEngine.ShowSingleRecordWindow(aActionComponent: TComponent; AOptions:\r\n TJvShowSingleRecordWindowOptions; ACreateDataControlsEvent: TJvDataSourceEditDialogCreateDataControlsEvent = nil;\r\n AOnFormShowEvent: TJvDataSourceEditDialogOnFormShowEvent = nil);\r\nvar\r\n Dialog: TJvDynControlDataSourceEditDialog;\r\nbegin\r\n Dialog := TJvDynControlDataSourceEditDialog.Create(Self);\r\n try\r\n if Dialog.DynControlEngineDB.SupportsDataComponent(aActionComponent) then\r\n Dialog.DataComponent := aActionComponent\r\n else\r\n Dialog.DataComponent := DataSource(aActionComponent);\r\n Dialog.OnCreateDataControlsEvent := ACreateDataControlsEvent;\r\n Dialog.OnFormShowEvent := AOnFormShowEvent;\r\n AOptions.SetOptionsToDialog(Dialog);\r\n if Assigned(Dialog.DataComponent) then\r\n Dialog.ShowDialog;\r\n finally\r\n Dialog.Free;\r\n end;\r\nend;\r\n\r\nfunction TJvDatabaseActionBaseControlEngine.SupportsAction(AAction: TJvActionEngineBaseAction): Boolean;\r\nbegin\r\n Result := (AAction is TJvDatabaseBaseAction) ;\r\nend;\r\n\r\nfunction TJvDatabaseActionBaseControlEngine.SupportsComponent(aActionComponent: TComponent): Boolean;\r\nbegin\r\n Result := Assigned(aActionComponent) and (aActionComponent is TDataSource);\r\nend;\r\n\r\nfunction TJvDatabaseActionDBGridControlEngine.DataSource(aActionComponent:\r\n TComponent): TDataSource;\r\nbegin\r\n if Assigned(aActionComponent) and (aActionComponent is TCustomDBGrid) then\r\n Result := TCustomDBGrid(aActionComponent).DataSource\r\n else\r\n Result := nil;\r\nend;\r\n\r\ntype\r\n TAccessCustomDBGrid = class(TCustomDBGrid);\r\n TAccessCustomControl = class(TCustomControl);\r\n\r\nconstructor TJvDatabaseActionDBGridControlEngine.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\nend;\r\n\r\nfunction TJvDatabaseActionDBGridControlEngine.CustomDBGrid(aActionComponent:\r\n TComponent): TCustomDBGrid;\r\nbegin\r\n if Assigned(aActionComponent) and (aActionComponent is TCustomDBGrid) then\r\n Result := TCustomDBGrid(aActionComponent)\r\n else\r\n Result := nil;\r\nend;\r\n\r\nfunction TJvDatabaseActionDBGridControlEngine.GotoSelectedRow(aActionComponent:\r\n TComponent; const ASelectedRow: Integer): Boolean;\r\nvar\r\n ds : TDataSet;\r\nbegin\r\n ds := Dataset(aActionComponent);\r\n if (ASelectedRow >= 0) and (ASelectedRow < SelectedRowsCount(aActionComponent)) and\r\n Assigned(ds) and ds.Active then\r\n begin\r\n ds.GotoBookmark(Pointer(TAccessCustomDBGrid(CustomDBGrid(aActionComponent)).SelectedRows[ASelectedRow]));\r\n Result := True;\r\n end\r\n else\r\n Result := False;\r\nend;\r\n\r\nprocedure TJvDatabaseActionDBGridControlEngine.OnCreateDataControls(\r\n ADatacomponent: TComponent; ADynControlEngineDB: TJvDynControlEngineDB;\r\n AParentControl: TWinControl; AFieldCreateOptions:\r\n TJvCreateDBFieldsOnControlOptions);\r\nvar\r\n I: Integer;\r\n ds: TDataSource;\r\n Field: TField;\r\n LabelControl: TControl;\r\n Control: TWinControl;\r\n Column: TColumn;\r\n grid : TCustomDBGrid;\r\nbegin\r\n grid := CustomDBGrid(ADatacomponent);\r\n if Assigned(grid) then\r\n begin\r\n ds := grid.DataSource;\r\n// with AFieldCreateOptions do\r\n for I := 0 to TAccessCustomDBGrid(grid).ColCount - 2 do\r\n begin\r\n Column := TAccessCustomDBGrid(grid).Columns[I];\r\n if Column.Visible or AFieldCreateOptions.ShowInvisibleFields then\r\n begin\r\n Field := Column.Field;\r\n Control := ADynControlEngineDB.CreateDBFieldControl(Field, AParentControl, AParentControl, '', ds);\r\n Control.Enabled := Field.CanModify;\r\n if AFieldCreateOptions.FieldDefaultWidth > 0 then\r\n Control.Width := AFieldCreateOptions.FieldDefaultWidth\r\n else\r\n begin\r\n if AFieldCreateOptions.UseFieldSizeForWidth then\r\n if Field.Size > 0 then\r\n Control.Width :=\r\n TAccessCustomControl(AParentControl).Canvas.TextWidth('X') * Field.Size\r\n else\r\n begin\r\n if (ADynControlEngineDB.GetFieldControlType(Field)= jctDBMemo) and\r\n (AFieldCreateOptions.FieldMaxWidth > 0) then\r\n Control.Width := AFieldCreateOptions.FieldMaxWidth;\r\n end\r\n else\r\n if Field.DisplayWidth > 0 then\r\n Control.Width :=\r\n TAccessCustomControl(AParentControl).Canvas.TextWidth('X') * Field.DisplayWidth;\r\n if (AFieldCreateOptions.FieldMaxWidth > 0) and (Control.Width > AFieldCreateOptions.FieldMaxWidth) then\r\n Control.Width := AFieldCreateOptions.FieldMaxWidth\r\n else\r\n if (AFieldCreateOptions.FieldMinWidth > 0) and (Control.Width < AFieldCreateOptions.FieldMinWidth) then\r\n Control.Width := AFieldCreateOptions.FieldMinWidth;\r\n end;\r\n if AFieldCreateOptions.UseParentColorForReadOnly then\r\n if (Assigned(ds.DataSet) and not ds.DataSet.CanModify) or not Field.CanModify then\r\n if isPublishedProp(Control, 'ParentColor') then\r\n SetOrdProp(Control, 'ParentColor', Ord(True));\r\n LabelControl := ADynControlEngineDB.DynControlEngine.CreateLabelControlPanel(AParentControl,\r\n AParentControl, '', '&' + Column.Title.Caption, Control, True, 0);\r\n if AFieldCreateOptions.FieldWidthStep > 0 then\r\n if (LabelControl.Width mod AFieldCreateOptions.FieldWidthStep) <> 0 then\r\n LabelControl.Width := ((LabelControl.Width div AFieldCreateOptions.FieldWidthStep) + 1) * AFieldCreateOptions.FieldWidthStep;\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJvDatabaseActionDBGridControlEngine.SelectedField(aActionComponent:\r\n TComponent): TField;\r\nbegin\r\n if Assigned(CustomDBGrid(aActionComponent)) then\r\n Result := CustomDBGrid(aActionComponent).SelectedField\r\n else\r\n Result := nil;\r\nend;\r\n\r\nfunction TJvDatabaseActionDBGridControlEngine.SelectedRowsCount(\r\n aActionComponent: TComponent): Integer;\r\nbegin\r\n if Assigned(CustomDBGrid(aActionComponent)) then\r\n Result := TAccessCustomDBGrid(CustomDBGrid(aActionComponent)).SelectedRows.Count\r\n else\r\n Result := 0;\r\nend;\r\n\r\nfunction TJvDatabaseActionDBGridControlEngine.SupportsComponent(\r\n aActionComponent: TComponent): Boolean;\r\nbegin\r\n Result := Assigned(aActionComponent) and (aActionComponent is TCustomDBGrid);\r\nend;\r\n\r\nprocedure TJvDatabaseActionDBGridControlEngine.ShowSingleRecordWindow(\r\n aActionComponent: TComponent; AOptions: TJvShowSingleRecordWindowOptions;\r\n ACreateDataControlsEvent: TJvDataSourceEditDialogCreateDataControlsEvent =\r\n nil; AOnFormShowEvent: TJvDataSourceEditDialogOnFormShowEvent = nil);\r\nvar\r\n Dialog: TJvDynControlDataSourceEditDialog;\r\nbegin\r\n Dialog := TJvDynControlDataSourceEditDialog.Create(self);\r\n try\r\n AOptions.SetOptionsToDialog(Dialog);\r\n if Dialog.DynControlEngineDB.SupportsDataComponent(aActionComponent) then\r\n Dialog.DataComponent := aActionComponent\r\n else\r\n Dialog.DataComponent := DataSource(aActionComponent);\r\n if Assigned(Dialog.DataComponent) then\r\n begin\r\n if not Assigned(ACreateDataControlsEvent) then\r\n Dialog.OnCreateDataControlsEvent := OnCreateDataControls\r\n else\r\n Dialog.OnCreateDataControlsEvent := ACreateDataControlsEvent;\r\n Dialog.OnFormShowEvent := AOnFormShowEvent;\r\n Dialog.ShowDialog;\r\n end;\r\n finally\r\n Dialog.Free;\r\n end;\r\nend;\r\n\r\nprocedure TJvDatabaseActionEngineList.RegisterEngine(AEngineClass: TJvDatabaseActionBaseEngineClass);\r\nbegin\r\n Add(AEngineClass.Create(nil));\r\nend;\r\n\r\nfunction TJvDatabaseActionEngineList.GetDatasetEngine(AComponent: TComponent): TJvDatabaseActionBaseDatasetEngine;\r\nvar\r\n Ind: Integer;\r\nbegin\r\n Result := nil;\r\n for Ind := 0 to Count - 1 do\r\n if Engine[Ind] is TJvDatabaseActionBaseDatasetEngine then\r\n if TJvDatabaseActionBaseDatasetEngine(Engine[Ind]).SupportsComponent(AComponent) then\r\n begin\r\n Result := TJvDatabaseActionBaseDatasetEngine(Engine[Ind]);\r\n Break;\r\n end;\r\nend;\r\n\r\nfunction TJvDatabaseActionEngineList.GetDatabaseControlEngine(AComponent:\r\n TComponent): TJvDatabaseActionBaseControlEngine;\r\nvar\r\n Ind: Integer;\r\nbegin\r\n Result := nil;\r\n for Ind := 0 to Count - 1 do\r\n if Engine[Ind] is TJvDatabaseActionBaseControlEngine then\r\n if TJvDatabaseActionBaseControlEngine(Engine[Ind]).SupportsComponent(AComponent) then\r\n begin\r\n Result := TJvDatabaseActionBaseControlEngine(Engine[Ind]);\r\n Break;\r\n end;\r\nend;\r\n\r\nfunction TJvDatabaseActionEngineList.SupportsDataset(AComponent: TComponent): Boolean;\r\nbegin\r\n Result := Assigned(GetDatasetEngine(AComponent));\r\nend;\r\n\r\nfunction TJvDatabaseActionBaseDatasetEngine.GetDataset(aActionComponent:\r\n TComponent): TDataset;\r\nbegin\r\n if aActionComponent is TDataset then\r\n Result := TDataset(aActionComponent)\r\n else\r\n Result := NIL;\r\nend;\r\n\r\nfunction TJvDatabaseActionBaseDatasetEngine.GetSQL(aActionComponent:\r\n TComponent): string;\r\nbegin\r\n Result := '';\r\nend;\r\n\r\nprocedure TJvDatabaseActionBaseDatasetEngine.RefreshRecord(AActionComponent :\r\n TComponent);\r\nbegin\r\n \r\nend;\r\n\r\nprocedure TJvDatabaseActionBaseDatasetEngine.SetSQL(aActionComponent:\r\n TComponent);\r\nbegin\r\n\r\nend;\r\n\r\nfunction TJvDatabaseActionBaseDatasetEngine.SupportsComponent(aActionComponent:\r\n TComponent): Boolean;\r\nbegin\r\n Result := False;\r\nend;\r\n\r\nfunction TJvDatabaseActionBaseDatasetEngine.SupportsGetSQL(aActionComponent:\r\n TComponent): Boolean;\r\nbegin\r\n Result := False;\r\nend;\r\n\r\nfunction TJvDatabaseActionBaseDatasetEngine.SupportsRefreshRecord(\r\n aActionComponent: TComponent): Boolean;\r\nbegin\r\n Result := False;\r\nend;\r\n\r\nfunction TJvDatabaseActionBaseDatasetEngine.SupportsSetSQL(aActionComponent:\r\n TComponent): Boolean;\r\nbegin\r\n Result := False;\r\nend;\r\n\r\nconstructor TJvShowSingleRecordWindowOptions.Create;\r\nbegin\r\n inherited Create;\r\n FDialogCaption := '';\r\n FPostButtonCaption := RsSRWPostButtonCaption;\r\n FCancelButtonCaption := RsSRWCancelButtonCaption;\r\n FCloseButtonCaption := RsSRWCloseButtonCaption;\r\n FBorderStyle := bsDialog;\r\n FTop := 0;\r\n FLeft := 0;\r\n FWidth := 640;\r\n FHeight := 480;\r\n FPosition := poScreenCenter;\r\n FArrangeSettings := TJvArrangeSettings.Create(Self);\r\n with FArrangeSettings do\r\n begin\r\n AutoSize := asBoth;\r\n DistanceHorizontal := 3;\r\n DistanceVertical := 3;\r\n BorderLeft := 3;\r\n BorderTop := 3;\r\n WrapControls := True;\r\n end;\r\n FArrangeConstraints := TSizeConstraints.Create(nil);\r\n FArrangeConstraints.MaxHeight := 480;\r\n FArrangeConstraints.MaxWidth := 640;\r\n FFieldCreateOptions := TJvCreateDBFieldsOnControlOptions.Create;\r\n FIncludeNavigator := false;\r\nend;\r\n\r\ndestructor TJvShowSingleRecordWindowOptions.Destroy;\r\nbegin\r\n FFieldCreateOptions.Free;\r\n FArrangeConstraints.Free;\r\n FArrangeSettings.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvShowSingleRecordWindowOptions.SetArrangeSettings(Value: TJvArrangeSettings);\r\nbegin\r\n FArrangeSettings.Assign(Value);\r\nend;\r\n\r\nprocedure TJvShowSingleRecordWindowOptions.SetArrangeConstraints(Value: TSizeConstraints);\r\nbegin\r\n FArrangeConstraints.Assign(Value);\r\nend;\r\n\r\nprocedure TJvShowSingleRecordWindowOptions.SetFieldCreateOptions(Value: TJvCreateDBFieldsOnControlOptions);\r\nbegin\r\n FFieldCreateOptions.Assign(Value);\r\nend;\r\n\r\nprocedure TJvShowSingleRecordWindowOptions.SetOptionsToDialog(ADialog: TJvDynControlDataSourceEditDialog);\r\nbegin\r\n if Assigned(ADialog) then\r\n begin\r\n ADialog.DialogCaption := DialogCaption;\r\n ADialog.PostButtonCaption := PostButtonCaption;\r\n ADialog.CancelButtonCaption := CancelButtonCaption;\r\n ADialog.CloseButtonCaption := CloseButtonCaption;\r\n ADialog.Position := Position;\r\n ADialog.BorderStyle := BorderStyle;\r\n ADialog.Top := Top;\r\n ADialog.Left := Left;\r\n ADialog.Width := Width;\r\n ADialog.Height := Height;\r\n ADialog.ArrangeConstraints := ArrangeConstraints;\r\n ADialog.ArrangeSettings := ArrangeSettings;\r\n ADialog.FieldCreateOptions := FieldCreateOptions;\r\n ADialog.IncludeNavigator := IncludeNavigator;\r\n end;\r\nend;\r\n\r\nfunction RegisteredDatabaseActionEngineList: TJvDatabaseActionEngineList;\r\nbegin\r\n Result := IntRegisteredActionEngineList;\r\nend;\r\n\r\nprocedure RegisterDatabaseActionEngine(AEngineClass:\r\n TJvDatabaseActionBaseEngineClass);\r\nbegin\r\n if Assigned(IntRegisteredActionEngineList) then\r\n IntRegisteredActionEngineList.RegisterEngine(AEngineClass);\r\nend;\r\n\r\nprocedure CreateActionEngineList;\r\nbegin\r\n IntRegisteredActionEngineList := TJvDatabaseActionEngineList.Create;\r\nend;\r\n\r\nprocedure DestroyActionEngineList;\r\nbegin\r\n IntRegisteredActionEngineList.Free;\r\n IntRegisteredActionEngineList := nil;\r\nend;\r\n\r\nprocedure InitActionEngineList;\r\nbegin\r\n CreateActionEngineList;\r\n RegisterDatabaseActionEngine(TJvDatabaseActionBaseControlEngine);\r\n RegisterDatabaseActionEngine(TJvDatabaseActionDBGridControlEngine);\r\nend;\r\n\r\ninitialization\r\n {$IFDEF UNITVERSIONING}\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n {$ENDIF UNITVERSIONING}\r\n InitActionEngineList;\r\n\r\nfinalization\r\n DestroyActionEngineList;\r\n {$IFDEF UNITVERSIONING}\r\n UnregisterUnitVersion(HInstance);\r\n {$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n\r\n" }, { "path": "External/Jedi/Jvcl/run/JvDBActionsEngineControlCxGrid.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvDBActionsEngineControlCxGrid.Pas, released on 2004-12-30.\r\n\r\nThe Initial Developer of the Original Code is Jens Fudickar [jens dott fudicker att oratool dott de]\r\nPortions created by Jens Fudickar are Copyright (C) 2002 Jens Fudickar.\r\nAll Rights Reserved.\r\n\r\nContributor(s): -\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvDBActionsEngineControlCxGrid.pas 12461 2009-08-14 17:21:33Z obones $\r\n\r\nunit JvDBActionsEngineControlCxGrid;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Forms, Controls, Classes, DB,\r\n {$IFDEF USE_3RDPARTY_DEVEXPRESS_CXGRID}\r\n cxGridCustomTableView, cxDBData, cxGridCustomView,\r\n {$ENDIF USE_3RDPARTY_DEVEXPRESS_CXGRID}\r\n JvDBActionsEngine;\r\n\r\n{$IFDEF USE_3RDPARTY_DEVEXPRESS_CXGRID}\r\ntype\r\n TJvDatabaseActionDevExpCxGridControlEngine = class(TJvDatabaseActionBaseControlEngine)\r\n private\r\n function DBDataController(AActionComponent: TComponent): TcxDBDataController;\r\n protected\r\n function GridView(AActionComponent: TComponent): TcxCustomGridView;\r\n function GridTableView(AActionComponent: TComponent): TcxCustomGridTableView;\r\n function IsGridMode(AActionComponent: TComponent): Boolean;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n function Bof(AActionComponent: TComponent): Boolean; override;\r\n function RecNo(AActionComponent: TComponent): Integer; override;\r\n function RecordCount(AActionComponent: TComponent): Integer; override;\r\n function CanInsert(AActionComponent: TComponent): Boolean; override;\r\n function CanUpdate(AActionComponent: TComponent): Boolean; override;\r\n function CanDelete(AActionComponent: TComponent): Boolean; override;\r\n function CanNavigate(AActionComponent: TComponent): Boolean; override;\r\n function DataSource(AActionComponent: TComponent): TDataSource; override;\r\n procedure First(AActionComponent: TComponent); override;\r\n function GotoSelectedRow(AActionComponent: TComponent; const ASelectedRow:\r\n Integer): Boolean; override;\r\n procedure Last(AActionComponent: TComponent); override;\r\n procedure MoveBy(AActionComponent: TComponent; Distance: Integer); override;\r\n function SelectedField(AActionComponent: TComponent): TField; override;\r\n function SelectedRowsCount(AActionComponent: TComponent): Integer; override;\r\n function SupportsComponent(AActionComponent: TComponent): Boolean; override;\r\n end;\r\n\r\n {$ENDIF USE_3RDPARTY_DEVEXPRESS_CXGRID}\r\n\r\n {$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile:\r\n '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvDBActionsEngineControlCxGrid.pas $';\r\n Revision: '$Revision: 12461 $';\r\n Date: '$Date: 2009-08-14 19:21:33 +0200 (ven. 14 août 2009) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n {$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n {$IFDEF USE_3RDPARTY_DEVEXPRESS_CXGRID}\r\n cxGrid, cxGridDBDataDefinitions, cxGridDBChartView,\r\n cxCustomData, cxGridTableView,\r\n {$ENDIF USE_3RDPARTY_DEVEXPRESS_CXGRID}\r\n Variants, SysUtils, Grids;\r\n\r\n//=== { TJvDatabaseActionDevExpCxGridControlEngine } =========================\r\n\r\n{$IFDEF USE_3RDPARTY_DEVEXPRESS_CXGRID}\r\n\r\nconstructor TJvDatabaseActionDevExpCxGridControlEngine.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n Name := 'TJvDatabaseActionDevExpCxGridControlEngine';\r\nend;\r\n\r\nfunction TJvDatabaseActionDevExpCxGridControlEngine.GridView(AActionComponent:\r\n TComponent): TcxCustomGridView;\r\nbegin\r\n if Assigned(AActionComponent) then\r\n if AActionComponent is TcxGrid then\r\n if TcxGrid(AActionComponent).FocusedView is TcxCustomGridView then\r\n Result := TcxCustomGridView(TcxGrid(AActionComponent).FocusedView)\r\n else\r\n Result := nil\r\n else if AActionComponent is TcxCustomGridView then\r\n Result := TcxCustomGridView(AActionComponent)\r\n else\r\n Result := nil\r\n else\r\n Result := nil;\r\nend;\r\n\r\nfunction TJvDatabaseActionDevExpCxGridControlEngine.GridTableView(\r\n AActionComponent: TComponent): TcxCustomGridTableView;\r\nbegin\r\n if Assigned(AActionComponent) then\r\n if AActionComponent is TcxGrid then\r\n if TcxGrid(AActionComponent).FocusedView is TcxCustomGridTableView then\r\n Result := TcxCustomGridTableView(TcxGrid(AActionComponent).FocusedView)\r\n else\r\n Result := nil\r\n else if AActionComponent is TcxCustomGridTableView then\r\n Result := TcxCustomGridTableView(AActionComponent)\r\n else\r\n Result := nil\r\n else\r\n Result := nil;\r\nend;\r\n\r\nfunction TJvDatabaseActionDevExpCxGridControlEngine.DataSource(\r\n AActionComponent: TComponent): TDataSource;\r\nbegin\r\n if Assigned(DBDataController(AActionComponent)) then\r\n Result := DBDataController(AActionComponent).DataSource\r\n else\r\n Result := inherited DataSource(AActionComponent)\r\nend;\r\n\r\nfunction TJvDatabaseActionDevExpCxGridControlEngine.SupportsComponent(\r\n AActionComponent: TComponent): Boolean;\r\nbegin\r\n Result := Assigned(GridView(AActionComponent));\r\nend;\r\n\r\nfunction TJvDatabaseActionDevExpCxGridControlEngine.Bof(AActionComponent:\r\n TComponent): Boolean;\r\nbegin\r\n if Assigned(GridView(AActionComponent)) then\r\n Result := GridView(AActionComponent).DataController.FocusedRowIndex = 0\r\n else\r\n Result := inherited Bof(AActionComponent);\r\nend;\r\n\r\nfunction TJvDatabaseActionDevExpCxGridControlEngine.RecNo(AActionComponent:\r\n TComponent): Integer;\r\nbegin\r\n if Assigned(GridView(AActionComponent)) then\r\n if GridView(AActionComponent).DataController.IsGridMode then\r\n Result := inherited RecNo(AActionComponent)\r\n else\r\n Result := GridView(AActionComponent).DataController.FocusedRowIndex + 1\r\n else\r\n Result := inherited RecNo(AActionComponent);\r\nend;\r\n\r\nfunction TJvDatabaseActionDevExpCxGridControlEngine.RecordCount(\r\n AActionComponent: TComponent): Integer;\r\nbegin\r\n if Assigned(GridView(AActionComponent)) then\r\n if GridView(AActionComponent).DataController.IsGridMode then\r\n Result := inherited RecordCount(AActionComponent)\r\n else\r\n Result := GridView(AActionComponent).DataController.FilteredRecordCount\r\n else\r\n Result := inherited RecordCount(AActionComponent);\r\nend;\r\n\r\nfunction TJvDatabaseActionDevExpCxGridControlEngine.CanInsert(AActionComponent:\r\n TComponent): Boolean;\r\nbegin\r\n if Assigned(GridTableView(AActionComponent)) then\r\n Result := GridTableView(AActionComponent).OptionsData.Inserting and inherited\r\n CanInsert(AActionComponent)\r\n else if Assigned(GridView(AActionComponent)) then\r\n Result := False // GridView must be a ChartView, and then Insert makes no sense\r\n else\r\n Result := inherited CanInsert(AActionComponent);\r\nend;\r\n\r\nfunction TJvDatabaseActionDevExpCxGridControlEngine.CanUpdate(AActionComponent:\r\n TComponent): Boolean;\r\nbegin\r\n if Assigned(GridTableView(AActionComponent)) then\r\n Result := GridTableView(AActionComponent).OptionsData.Editing and inherited\r\n CanUpdate(AActionComponent)\r\n else if Assigned(GridView(AActionComponent)) then\r\n Result := False // GridView must be a ChartView, and then Update makes no sense\r\n else\r\n Result := inherited CanUpdate(AActionComponent);\r\nend;\r\n\r\nfunction TJvDatabaseActionDevExpCxGridControlEngine.CanDelete(AActionComponent:\r\n TComponent): Boolean;\r\nbegin\r\n if Assigned(GridTableView(AActionComponent)) then\r\n Result := GridTableView(AActionComponent).OptionsData.Deleting and inherited\r\n CanDelete(AActionComponent)\r\n else if Assigned(GridView(AActionComponent)) then\r\n Result := False // GridView must be a ChartView, and then Delete makes no sense\r\n else\r\n Result := inherited CanDelete(AActionComponent);\r\nend;\r\n\r\nfunction TJvDatabaseActionDevExpCxGridControlEngine.CanNavigate(\r\n AActionComponent: TComponent): Boolean;\r\nbegin\r\n Result := Assigned(GridTableView(AActionComponent));\r\nend;\r\n\r\nprocedure TJvDatabaseActionDevExpCxGridControlEngine.First(AActionComponent:\r\n TComponent);\r\nbegin\r\n if Assigned(GridTableView(AActionComponent)) then\r\n GridTableView(AActionComponent).DataController.GotoFirst\r\n else\r\n inherited First(AActionComponent);\r\nend;\r\n\r\nfunction TJvDatabaseActionDevExpCxGridControlEngine.DBDataController(\r\n AActionComponent: TComponent): TcxDBDataController;\r\n\r\nbegin\r\n if Assigned(GridView(AActionComponent)) and (GridView(AActionComponent).DataController is\r\n TcxDBDataController) then\r\n Result := TcxDBDataController(GridView(AActionComponent).DataController)\r\n else\r\n Result := nil;\r\nend;\r\n\r\nfunction TJvDatabaseActionDevExpCxGridControlEngine.GotoSelectedRow(\r\n AActionComponent: TComponent; const ASelectedRow: Integer): Boolean;\r\nvar\r\n Bkm: {$IFDEF RTL200_UP}TBookmark{$ELSE}TBookmarkStr{$ENDIF RTL200_UP};\r\n RecIdx: Integer;\r\n RecID: Variant;\r\nbegin\r\n if Assigned(DBDataController(AActionComponent)) and Assigned(Dataset(AActionComponent)) and\r\n Assigned(GridTableView(AActionComponent)) then\r\n try\r\n if IsGridMode(AActionComponent) then\r\n begin\r\n Bkm := DBDataController(AActionComponent).GetSelectedBookmark(ASelectedRow);\r\n if Dataset(AActionComponent).BookmarkValid(TBookmark(Bkm)) then\r\n begin\r\n Dataset(AActionComponent).Bookmark := Bkm;\r\n Result := True;\r\n end\r\n else\r\n Result := False;\r\n end\r\n else\r\n begin\r\n RecIdx :=\r\n GridTableView(AActionComponent).Controller.SelectedRecords[ASelectedRow].RecordIndex;\r\n RecID := GridTableView(AActionComponent).DataController.GetRecordId(RecIdx);\r\n Result :=\r\n Dataset(AActionComponent).Locate(DBDataController(AActionComponent).KeyFieldNames, RecID,\r\n [loPartialKey]);\r\n end;\r\n except\r\n Result := False;\r\n end\r\n else\r\n Result := False;\r\nend;\r\n\r\nfunction TJvDatabaseActionDevExpCxGridControlEngine.IsGridMode(AActionComponent\r\n : TComponent): Boolean;\r\nbegin\r\n if Assigned(DBDataController(AActionComponent)) then\r\n Result := DBDataController(AActionComponent).DataModeController.GridMode\r\n else\r\n Result := True;\r\nend;\r\n\r\nprocedure TJvDatabaseActionDevExpCxGridControlEngine.Last(AActionComponent:\r\n TComponent);\r\nbegin\r\n if Assigned(GridView(AActionComponent)) then\r\n GridView(AActionComponent).DataController.GotoLast\r\n else\r\n inherited Last(AActionComponent);\r\nend;\r\n\r\nprocedure TJvDatabaseActionDevExpCxGridControlEngine.MoveBy(AActionComponent:\r\n TComponent; Distance: Integer);\r\nbegin\r\n if Assigned(GridView(AActionComponent)) then\r\n GridView(AActionComponent).DataController.MoveBy(Distance)\r\n else\r\n inherited MoveBy(AActionComponent, Distance);\r\nend;\r\n\r\nfunction TJvDatabaseActionDevExpCxGridControlEngine.SelectedField(\r\n AActionComponent: TComponent): TField;\r\nvar Item : TcxCustomGridTableItem;\r\nbegin\r\n Result := nil;\r\n if GridView(AActionComponent).Controller is TcxCustomGridTableController then\r\n begin\r\n Item := TcxCustomGridTableController(GridView(AActionComponent).Controller).FocusedItem;\r\n if Assigned(Item) and\r\n (Item is TcxGridColumn) and\r\n (Item.DataBinding is TcxGridItemDBDataBinding) then\r\n Result := TcxGridItemDBDataBinding(Item.DataBinding).Field;\r\n end;\r\nend;\r\n\r\nfunction TJvDatabaseActionDevExpCxGridControlEngine.SelectedRowsCount(\r\n AActionComponent: TComponent): Integer;\r\nbegin\r\n if Assigned(GridView(AActionComponent)) then\r\n Result := GridView(AActionComponent).DataController.GetSelectedCount\r\n else\r\n Result := inherited SelectedRowsCount(AActionComponent);\r\nend;\r\n\r\n{$ENDIF USE_3RDPARTY_DEVEXPRESS_CXGRID}\r\n\r\nprocedure InitActionEngineList;\r\nbegin\r\n {$IFDEF USE_3RDPARTY_DEVEXPRESS_CXGRID}\r\n RegisterDatabaseActionEngine(TJvDatabaseActionDevExpCxGridControlEngine);\r\n {$ENDIF USE_3RDPARTY_DEVEXPRESS_CXGRID}\r\nend;\r\n\r\ninitialization\r\n {$IFDEF UNITVERSIONING}\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n {$ENDIF UNITVERSIONING}\r\n InitActionEngineList;\r\n\r\nfinalization\r\n {$IFDEF UNITVERSIONING}\r\n UnregisterUnitVersion(HInstance);\r\n {$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvDBActionsEngineControlCxPivotGrid.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvDBActionsEngineControlCxPivotGrid.Pas, released on 2004-12-30.\r\n\r\nThe Initial Developer of the Original Code is Jens Fudickar [jens dott fudicker att oratool dott de]\r\nPortions created by Jens Fudickar are Copyright (C) 2002 Jens Fudickar.\r\nAll Rights Reserved.\r\n\r\nContributor(s): -\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvDBActionsEngineControlCxPivotGrid.pas 12461 2009-08-14 17:21:33Z obones $\r\n\r\nunit JvDBActionsEngineControlCxPivotGrid;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Forms, Controls, Classes, DB,\r\n {$IFDEF USE_3RDPARTY_DEVEXPRESS_CXPIVOTGRID}\r\n cxDBPivotGrid, cxDBData,\r\n {$ENDIF USE_3RDPARTY_DEVEXPRESS_CXPIVOTGRID}\r\n JvDBActionsEngine;\r\n\r\n{$IFDEF USE_3RDPARTY_DEVEXPRESS_CXPIVOTGRID}\r\ntype\r\n TJvDatabaseActionDevExpCxPivotGridControlEngine = class(TJvDatabaseActionBaseControlEngine)\r\n private\r\n function DBDataController(AActionComponent: TComponent): TcxDBDataController;\r\n protected\r\n function PivotGrid(AActionComponent: TComponent): TcxCustomDBPivotGrid;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n function CanInsert(aActionComponent: TComponent): Boolean; override;\r\n function CanUpdate(aActionComponent: TComponent): Boolean; override;\r\n function CanDelete(aActionComponent: TComponent): Boolean; override;\r\n function CanNavigate(aActionComponent: TComponent): Boolean; override;\r\n function DataSource(AActionComponent: TComponent): TDataSource; override;\r\n function SupportsComponent(AActionComponent: TComponent): Boolean; override;\r\n end;\r\n\r\n{$ENDIF USE_3RDPARTY_DEVEXPRESS_CXPIVOTGRID}\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvDBActionsEngineControlCxPivotGrid.pas $';\r\n Revision: '$Revision: 12461 $';\r\n Date: '$Date: 2009-08-14 19:21:33 +0200 (ven. 14 août 2009) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n {$IFDEF USE_3RDPARTY_DEVEXPRESS_CXPIVOTGRID}\r\n {$ENDIF USE_3RDPARTY_DEVEXPRESS_CXPIVOTGRID}\r\n Variants, SysUtils;\r\n\r\n//=== { TJvDatabaseActionDevExpCxPivotGridControlEngine } =========================\r\n\r\n{$IFDEF USE_3RDPARTY_DEVEXPRESS_CXPIVOTGRID}\r\n\r\nconstructor TJvDatabaseActionDevExpCxPivotGridControlEngine.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n Name := 'TJvDatabaseActionDevExpCxPivotGridControlEngine';\r\nend;\r\n\r\nfunction TJvDatabaseActionDevExpCxPivotGridControlEngine.PivotGrid(\r\n AActionComponent: TComponent): TcxCustomDBPivotGrid;\r\nbegin\r\n if Assigned(AActionComponent) then\r\n if AActionComponent is TcxCustomDBPivotGrid then\r\n Result := TcxCustomDBPivotGrid(AActionComponent)\r\n else\r\n Result := nil\r\n else\r\n Result := nil;\r\nend;\r\n\r\nfunction TJvDatabaseActionDevExpCxPivotGridControlEngine.DataSource(\r\n AActionComponent: TComponent): TDataSource;\r\nbegin\r\n if Assigned(DBDataController(AActionComponent)) then\r\n Result := DBDataController(AActionComponent).DataSource\r\n else\r\n Result := inherited DataSource(AActionComponent)\r\nend;\r\n\r\nfunction TJvDatabaseActionDevExpCxPivotGridControlEngine.SupportsComponent(\r\n AActionComponent: TComponent): Boolean;\r\nbegin\r\n Result := Assigned(PivotGrid(AActionComponent));\r\nend;\r\n\r\nfunction TJvDatabaseActionDevExpCxPivotGridControlEngine.CanInsert(aActionComponent:\r\n TComponent): Boolean;\r\nbegin\r\n Result := False;\r\nend;\r\n\r\nfunction TJvDatabaseActionDevExpCxPivotGridControlEngine.CanUpdate(aActionComponent:\r\n TComponent): Boolean;\r\nbegin\r\n Result := False;\r\nend;\r\n\r\nfunction TJvDatabaseActionDevExpCxPivotGridControlEngine.CanDelete(aActionComponent:\r\n TComponent): Boolean;\r\nbegin\r\n Result := False;\r\nend;\r\n\r\nfunction TJvDatabaseActionDevExpCxPivotGridControlEngine.CanNavigate(\r\n aActionComponent: TComponent): Boolean;\r\nbegin\r\n Result := False;\r\nend;\r\n\r\nfunction TJvDatabaseActionDevExpCxPivotGridControlEngine.DBDataController(\r\n AActionComponent: TComponent): TcxDBDataController;\r\n\r\nbegin\r\n if Assigned(PivotGrid(aActionComponent)) and (PivotGrid(aActionComponent).DataController is TcxDBDataController) then\r\n Result := TcxDBDataController(PivotGrid(aActionComponent).DataController)\r\n else\r\n Result := nil;\r\nend;\r\n\r\n{$ENDIF USE_3RDPARTY_DEVEXPRESS_CXPIVOTGRID}\r\n\r\nprocedure InitActionEngineList;\r\nbegin\r\n {$IFDEF USE_3RDPARTY_DEVEXPRESS_CXPIVOTGRID}\r\n RegisterDatabaseActionEngine(TJvDatabaseActionDevExpCxPivotGridControlEngine);\r\n {$ENDIF USE_3RDPARTY_DEVEXPRESS_CXPIVOTGRID}\r\nend;\r\n\r\ninitialization\r\n {$IFDEF UNITVERSIONING}\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n {$ENDIF UNITVERSIONING}\r\n InitActionEngineList;\r\n\r\nfinalization\r\n {$IFDEF UNITVERSIONING}\r\n UnregisterUnitVersion(HInstance);\r\n {$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvDBActionsEngineControlCxTreeList.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvDBActionsEngineControlCxTreeList.Pas, released on 2004-12-30.\r\n\r\nThe Initial Developer of the Original Code is Jens Fudickar [jens dott fudicker att oratool dott de]\r\nPortions created by Jens Fudickar are Copyright (C) 2002 Jens Fudickar.\r\nAll Rights Reserved.\r\n\r\nContributor(s): -\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvDBActionsEngineControlCxTreeList.pas 12998 2011-03-06 22:24:57Z jfudickar $\r\n\r\nunit JvDBActionsEngineControlCxTreeList;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Forms, Controls, Classes, DB,\r\n {$IFDEF USE_3RDPARTY_DEVEXPRESS_CXTREELIST}\r\n cxTL, cxDBTL,\r\n {$ENDIF USE_3RDPARTY_DEVEXPRESS_CXTREELIST}\r\n JvDBActionsEngine;\r\n\r\n{$IFDEF USE_3RDPARTY_DEVEXPRESS_CXTREELIST}\r\ntype\r\n TJvDatabaseActionDevExpCxTreeListControlEngine = class(TJvDatabaseActionBaseControlEngine)\r\n private\r\n function DBDataController(AActionComponent: TComponent): TcxDBTreeListDataController;\r\n protected\r\n function TreeList(AActionComponent: TComponent): TcxCustomTreeList;\r\n function DBTreeList(AActionComponent: TComponent): TcxDBTreeList;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n function Bof(AActionComponent: TComponent): Boolean; override;\r\n function RecNo(AActionComponent: TComponent): Integer; override;\r\n function RecordCount(AActionComponent: TComponent): Integer; override;\r\n function CanInsert(AActionComponent: TComponent): Boolean; override;\r\n function CanUpdate(AActionComponent: TComponent): Boolean; override;\r\n function CanDelete(AActionComponent: TComponent): Boolean; override;\r\n function CanNavigate(AActionComponent: TComponent): Boolean; override;\r\n function DataSource(AActionComponent: TComponent): TDataSource; override;\r\n procedure First(AActionComponent: TComponent); override;\r\n procedure Last(AActionComponent: TComponent); override;\r\n procedure MoveBy(AActionComponent: TComponent; Distance: Integer); override;\r\n function SelectedField(AActionComponent: TComponent): TField; override;\r\n function SupportsComponent(AActionComponent: TComponent): Boolean; override;\r\n end;\r\n\r\n {$ENDIF USE_3RDPARTY_DEVEXPRESS_CXTREELIST}\r\n\r\n {$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile:\r\n '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvDBActionsEngineControlCxTreeList.pas $';\r\n Revision: '$Revision: 12998 $';\r\n Date: '$Date: 2011-03-06 23:24:57 +0100 (dim. 06 mars 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n {$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n Variants, SysUtils, Grids;\r\n\r\n//=== { TJvDatabaseActionDevExpCxTreeListControlEngine } =========================\r\n\r\n{$IFDEF USE_3RDPARTY_DEVEXPRESS_CXTREELIST}\r\n\r\nconstructor TJvDatabaseActionDevExpCxTreeListControlEngine.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n Name := 'TJvDatabaseActionDevExpCxTreeListControlEngine';\r\nend;\r\n\r\nfunction TJvDatabaseActionDevExpCxTreeListControlEngine.DataSource(AActionComponent: TComponent): TDataSource;\r\nbegin\r\n if Assigned(DBDataController(AActionComponent)) then\r\n Result := DBDataController(AActionComponent).DataSource\r\n else\r\n Result := inherited DataSource(AActionComponent)\r\nend;\r\n\r\nfunction TJvDatabaseActionDevExpCxTreeListControlEngine.SupportsComponent(AActionComponent: TComponent): Boolean;\r\nbegin\r\n Result := Assigned(DBTreeList(AActionComponent));\r\nend;\r\n\r\nfunction TJvDatabaseActionDevExpCxTreeListControlEngine.Bof(AActionComponent: TComponent): Boolean;\r\nbegin\r\n if Assigned(DBTreeList(AActionComponent)) then\r\n Result := DBTreeList(AActionComponent).DataController.FocusedRowIndex = 0\r\n else\r\n Result := inherited Bof(AActionComponent);\r\nend;\r\n\r\nfunction TJvDatabaseActionDevExpCxTreeListControlEngine.RecNo(AActionComponent: TComponent): Integer;\r\nbegin\r\n if Assigned(TreeList(AActionComponent)) then\r\n if Assigned(TreeList(AActionComponent).FocusedNode) then\r\n Result := TreeList(AActionComponent).FocusedNode.AbsoluteIndex+1\r\n else\r\n Result := inherited RecNo(AActionComponent)\r\n else\r\n Result := inherited RecNo(AActionComponent);\r\nend;\r\n\r\nfunction TJvDatabaseActionDevExpCxTreeListControlEngine.RecordCount(AActionComponent: TComponent): Integer;\r\nbegin\r\n if Assigned(TreeList(AActionComponent)) then\r\n if Assigned(TreeList(AActionComponent).FocusedNode) then\r\n Result := TreeList(AActionComponent).AbsoluteCount\r\n else\r\n Result := inherited RecordCount(AActionComponent)\r\n else\r\n Result := inherited RecordCount(AActionComponent);\r\nend;\r\n\r\nfunction TJvDatabaseActionDevExpCxTreeListControlEngine.CanInsert(AActionComponent: TComponent): Boolean;\r\nbegin\r\n if Assigned(DBTreeList(AActionComponent)) then\r\n Result := DBTreeList(AActionComponent).OptionsData.Inserting and inherited CanInsert(AActionComponent)\r\n else\r\n Result := inherited CanInsert(AActionComponent);\r\nend;\r\n\r\nfunction TJvDatabaseActionDevExpCxTreeListControlEngine.CanUpdate(AActionComponent: TComponent): Boolean;\r\nbegin\r\n if Assigned(DBTreeList(AActionComponent)) then\r\n Result := DBTreeList(AActionComponent).OptionsData.Editing and inherited CanUpdate(AActionComponent)\r\n else\r\n Result := inherited CanUpdate(AActionComponent);\r\nend;\r\n\r\nfunction TJvDatabaseActionDevExpCxTreeListControlEngine.CanDelete(AActionComponent: TComponent): Boolean;\r\nbegin\r\n if Assigned(DBTreeList(AActionComponent)) then\r\n Result := DBTreeList(AActionComponent).OptionsData.Deleting and inherited CanDelete(AActionComponent)\r\n else\r\n Result := inherited CanDelete(AActionComponent);\r\nend;\r\n\r\nfunction TJvDatabaseActionDevExpCxTreeListControlEngine.CanNavigate(AActionComponent: TComponent): Boolean;\r\nbegin\r\n Result := Assigned(DBTreeList(AActionComponent));\r\nend;\r\n\r\nprocedure TJvDatabaseActionDevExpCxTreeListControlEngine.First(AActionComponent: TComponent);\r\nbegin\r\n if Assigned(DBTreeList(AActionComponent)) then\r\n DBTreeList(AActionComponent).DataController.GotoFirst\r\n else\r\n inherited First(AActionComponent);\r\nend;\r\n\r\nfunction TJvDatabaseActionDevExpCxTreeListControlEngine.DBDataController(AActionComponent: TComponent):\r\n TcxDBTreeListDataController;\r\n\r\nbegin\r\n if Assigned(DBTreeList(AActionComponent)) then\r\n Result := DBTreeList(AActionComponent).DataController\r\n else\r\n Result := nil;\r\nend;\r\n\r\nfunction TJvDatabaseActionDevExpCxTreeListControlEngine.TreeList(AActionComponent: TComponent): TcxCustomTreeList;\r\nbegin\r\n if Assigned(AActionComponent) and (AActionComponent is TcxCustomTreeList) then\r\n Result := TcxCustomTreeList(AActionComponent)\r\n else\r\n Result := nil;\r\nend;\r\n\r\nfunction TJvDatabaseActionDevExpCxTreeListControlEngine.DBTreeList(AActionComponent: TComponent): TcxDBTreeList;\r\nbegin\r\n if Assigned(AActionComponent) and (AActionComponent is TcxDBTreeList) then\r\n Result := TcxDBTreeList(AActionComponent)\r\n else\r\n Result := nil;\r\nend;\r\n\r\nprocedure TJvDatabaseActionDevExpCxTreeListControlEngine.Last(AActionComponent: TComponent);\r\nbegin\r\n if Assigned(DBTreeList(AActionComponent)) then\r\n DBTreeList(AActionComponent).DataController.GotoLast\r\n else\r\n inherited Last(AActionComponent);\r\nend;\r\n\r\nprocedure TJvDatabaseActionDevExpCxTreeListControlEngine.MoveBy(AActionComponent: TComponent; Distance: Integer);\r\nbegin\r\n if Assigned(DBTreeList(AActionComponent)) then\r\n DBTreeList(AActionComponent).DataController.MoveBy(Distance)\r\n else\r\n inherited MoveBy(AActionComponent, Distance);\r\nend;\r\n\r\nfunction TJvDatabaseActionDevExpCxTreeListControlEngine.SelectedField(AActionComponent: TComponent): TField;\r\nvar Column : TcxTreeListColumn;\r\nbegin\r\n Result := nil;\r\n if Assigned(DBTreeList(AActionComponent)) then\r\n begin\r\n Column := DBTreeList(AActionComponent).FocusedColumn;\r\n if Assigned(Column) and (Column is TCxDBTreeListColumn) then\r\n Result := TCxDBTreeListColumn(Column).DataBinding.Field;\r\n end;\r\nend;\r\n\r\n{$ENDIF USE_3RDPARTY_DEVEXPRESS_CXTREELIST}\r\n\r\nprocedure InitActionEngineList;\r\nbegin\r\n {$IFDEF USE_3RDPARTY_DEVEXPRESS_CXTREELIST}\r\n RegisterDatabaseActionEngine(TJvDatabaseActionDevExpCxTreeListControlEngine);\r\n {$ENDIF USE_3RDPARTY_DEVEXPRESS_CXTREELIST}\r\nend;\r\n\r\ninitialization\r\n {$IFDEF UNITVERSIONING}\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n {$ENDIF UNITVERSIONING}\r\n InitActionEngineList;\r\n\r\nfinalization\r\n {$IFDEF UNITVERSIONING}\r\n UnregisterUnitVersion(HInstance);\r\n {$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvDBActionsEngineDatasetAdo.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvDBActionsEngineDatasetAdo.Pas, released on 2004-12-30.\r\n\r\nThe Initial Developer of the Original Code is Jens Fudickar [jens dott fudicker att oratool dott de]\r\nPortions created by Jens Fudickar are Copyright (C) 2002 Jens Fudickar.\r\nAll Rights Reserved.\r\n\r\nContributor(s): -\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvDBActionsEngineDatasetAdo.pas 13075 2011-06-27 22:56:21Z jfudickar $\r\n\r\nunit JvDBActionsEngineDatasetAdo;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Classes, DB,\r\n JvDBActionsEngine;\r\n\r\ntype\r\n TJvDatabaseActionAdoDatasetEngine = class(TJvDatabaseActionBaseDatasetEngine)\r\n public\r\n function GetSQL(AActionComponent : TComponent): string; override;\r\n function SupportsComponent(AActionComponent : TComponent): Boolean; override;\r\n function SupportsGetSQL(AActionComponent : TComponent): Boolean; override;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvDBActionsEngineDatasetAdo.pas $';\r\n Revision: '$Revision: 13075 $';\r\n Date: '$Date: 2011-06-28 00:56:21 +0200 (mar. 28 juin 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n ADODB;\r\n\r\nfunction TJvDatabaseActionAdoDatasetEngine.GetSQL(AActionComponent :\r\n TComponent): string;\r\nbegin\r\n if AActionComponent is TADOQuery then\r\n Result := TADOQuery(AActionComponent).SQL.Text\r\n else\r\n if AActionComponent is TAdoTable then\r\n Result := 'SELECT * FROM ' + TADOTable(AActionComponent).TableName;\r\nend;\r\n\r\nfunction TJvDatabaseActionAdoDatasetEngine.SupportsComponent(AActionComponent :\r\n TComponent): Boolean;\r\nbegin\r\n Result := (AActionComponent is TADOQuery) or (AActionComponent is TADOTable);\r\nend;\r\n\r\nfunction TJvDatabaseActionAdoDatasetEngine.SupportsGetSQL(AActionComponent :\r\n TComponent): Boolean;\r\nbegin\r\n Result := True;\r\nend;\r\n\r\nprocedure InitActionEngineList;\r\nbegin\r\n RegisterDatabaseActionEngine(TJvDatabaseActionAdoDatasetEngine);\r\nend;\r\n\r\ninitialization\r\n {$IFDEF UNITVERSIONING}\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n {$ENDIF UNITVERSIONING}\r\n InitActionEngineList;\r\n\r\nfinalization\r\n {$IFDEF UNITVERSIONING}\r\n UnregisterUnitVersion(HInstance);\r\n {$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvDBActionsEngineDatasetCSVDataset.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvDBActionsEngineDatasetCSVDataset.Pas, released on 2004-12-30.\r\n\r\nThe Initial Developer of the Original Code is Jens Fudickar [jens dott fudicker att oratool dott de]\r\nPortions created by Jens Fudickar are Copyright (C) 2002 Jens Fudickar.\r\nAll Rights Reserved.\r\n\r\nContributor(s): -\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvDBActionsEngineDatasetCSVDataset.pas 13138 2011-10-26 23:17:50Z jfudickar $\r\n\r\nunit JvDBActionsEngineDatasetCSVDataset;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Classes,\r\n JvDBActionsEngine;\r\n\r\ntype\r\n TJvDatabaseActionCSVDatasetEngine = class(TJvDatabaseActionBaseDatasetEngine)\r\n public\r\n function GetSQL(AActionComponent : TComponent): string; override;\r\n function SupportsComponent(AActionComponent : TComponent): Boolean; override;\r\n function SupportsGetSQL(AActionComponent : TComponent): Boolean; override;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvDBActionsEngineDatasetCSVDataset.pas $';\r\n Revision: '$Revision: 13138 $';\r\n Date: '$Date: 2011-10-27 01:17:50 +0200 (jeu. 27 oct. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n JvCsvData;\r\n\r\nfunction TJvDatabaseActionCSVDatasetEngine.GetSQL(AActionComponent :\r\n TComponent): string;\r\nbegin\r\n if Assigned(GetDataset(AActionComponent)) then\r\n Result := 'SELECT '+TJvCsvDataSet(GetDataset(AActionComponent)).CsvFieldDef+#13#10+\r\n ' FROM '+TJvCsvDataSet(GetDataset(AActionComponent)).filename;\r\nend;\r\n\r\nfunction TJvDatabaseActionCSVDatasetEngine.SupportsComponent(AActionComponent\r\n : TComponent): Boolean;\r\nbegin\r\n Result := (GetDataset(AActionComponent) is TJvCsvDataSet);\r\nend;\r\n\r\nfunction TJvDatabaseActionCSVDatasetEngine.SupportsGetSQL(AActionComponent :\r\n TComponent): Boolean;\r\nbegin\r\n Result := True;\r\nend;\r\n\r\n\r\nprocedure InitActionEngineList;\r\nbegin\r\n RegisterDatabaseActionEngine(TJvDatabaseActionCSVDatasetEngine);\r\nend;\r\n\r\ninitialization\r\n {$IFDEF UNITVERSIONING}\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n {$ENDIF UNITVERSIONING}\r\n InitActionEngineList;\r\n\r\nfinalization\r\n {$IFDEF UNITVERSIONING}\r\n UnregisterUnitVersion(HInstance);\r\n {$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvDBActionsEngineDatasetDBExpress.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvDBActionsEngineDatasetDBExpress.Pas, released on 2004-12-30.\r\n\r\nThe Initial Developer of the Original Code is Jens Fudickar [jens dott fudicker att oratool dott de]\r\nPortions created by Jens Fudickar are Copyright (C) 2002 Jens Fudickar.\r\nAll Rights Reserved.\r\n\r\nContributor(s): -\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvDBActionsEngineDatasetDBExpress.pas 12461 2009-08-14 17:21:33Z obones $\r\n\r\nunit JvDBActionsEngineDatasetDBExpress;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Controls, Classes, DB,\r\n JvDBActionsEngine;\r\n\r\ntype\r\n TJvDatabaseActionDBExpressDatasetEngine = class(TJvDatabaseActionBaseDatasetEngine)\r\n public\r\n function GetSQL(AActionComponent: TComponent): string; override;\r\n function SupportsComponent(AActionComponent: TComponent): Boolean; override;\r\n function SupportsGetSQL(AActionComponent: TComponent): Boolean; override;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvDBActionsEngineDatasetDBExpress.pas $';\r\n Revision: '$Revision: 12461 $';\r\n Date: '$Date: 2009-08-14 19:21:33 +0200 (ven. 14 août 2009) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n SqlExpr;\r\n\r\nfunction TJvDatabaseActionDBExpressDatasetEngine.GetSQL(AActionComponent:\r\n TComponent): string;\r\nbegin\r\n Result := TSQLQuery(AActionComponent).SQL.Text;\r\nend;\r\n\r\nfunction TJvDatabaseActionDBExpressDatasetEngine.SupportsComponent(\r\n AActionComponent: TComponent): Boolean;\r\nbegin\r\n Result := (AActionComponent is TSQLQuery);\r\nend;\r\n\r\nfunction TJvDatabaseActionDBExpressDatasetEngine.SupportsGetSQL(\r\n AActionComponent: TComponent): Boolean;\r\nbegin\r\n Result := True;\r\nend;\r\n\r\nprocedure InitActionEngineList;\r\nbegin\r\n RegisterDatabaseActionEngine(TJvDatabaseActionDBExpressDatasetEngine);\r\nend;\r\n\r\ninitialization\r\n {$IFDEF UNITVERSIONING}\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n {$ENDIF UNITVERSIONING}\r\n InitActionEngineList;\r\n\r\nfinalization\r\n {$IFDEF UNITVERSIONING}\r\n UnregisterUnitVersion(HInstance);\r\n {$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvDBActionsEngineDatasetDevart.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvDBActionsEngineDatasetOdac.Pas, released on 2004-12-30.\r\n\r\nThe Initial Developer of the Original Code is Jens Fudickar [jens dott fudicker att oratool dott de]\r\nPortions created by Jens Fudickar are Copyright (C) 2002 Jens Fudickar.\r\nAll Rights Reserved.\r\n\r\nContributor(s): -\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvDBActionsEngineDatasetOdac.pas 13371 2012-06-23 15:46:57Z jfudickar $\r\n\r\nunit JvDBActionsEngineDatasetDevart;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Classes, DB,\r\n JvDBActionsEngine;\r\n\r\n{$IFDEF USE_3RDPARTY_DEVART_DAC}\r\ntype\r\n TJvDatabaseActionDevartDatasetEngine = class(TJvDatabaseActionBaseDatasetEngine)\r\n public\r\n function GetSQL(AActionComponent : TComponent): string; override;\r\n procedure RefreshRecord(AActionComponent : TComponent); override;\r\n function SupportsComponent(AActionComponent : TComponent): Boolean; override;\r\n function SupportsGetSQL(AActionComponent : TComponent): Boolean; override;\r\n function SupportsRefreshRecord(AActionComponent : TComponent): Boolean; override;\r\n end;\r\n{$ENDIF USE_3RDPARTY_DEVART_DAC}\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/trunk/jvcl/run/JvDBActionsEngineDatasetOdac.pas $';\r\n Revision: '$Revision: 13371 $';\r\n Date: '$Date: 2012-06-23 17:46:57 +0200 (Sa, 23 Jun 2012) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\n{$IFDEF USE_3RDPARTY_DEVART_DAC}\r\n\r\nuses\r\n DBAccess, SysUtils, Variants;\r\n\r\nfunction TJvDatabaseActionDevartDatasetEngine.GetSQL(AActionComponent :\r\n TComponent): string;\r\nvar Dataset : TCustomDADataSet;\r\n s : String;\r\n i : integer;\r\nbegin\r\n if GetDataset(AActionComponent) is TCustomDADataSet then\r\n Begin\r\n Dataset := TCustomDADataSet(GetDataset(AActionComponent));\r\n Result := TCustomDADataSet(GetDataset(AActionComponent)).FinalSQL;\r\n if Dataset.ParamCount > 0 then\r\n Result := Result + #13#10+#13#10+'Bind Variables : ';\r\n for i := 0 to Dataset.ParamCount - 1 do\r\n begin\r\n Result := Result + #13#10' :'+Dataset.Params[i].Name+' : ';\r\n if Dataset.Params[i].isNull then\r\n Result := Result + 'NULL'\r\n else\r\n begin\r\n Result := Result +''''+Dataset.Params[i].AsString+'''';\r\n case Dataset.Params[i].DataType of\r\n ftDate,\r\n ftDateTime,\r\n ftTimeStamp,\r\n ftOraTimeStamp :\r\n begin\r\n DateTimeToString(s, 'dd.mm.yyyy hh:nn:ss', Dataset.Params[i].AsDateTime);\r\n Result := Result + ' - TO_DATE('''+s+''', ''DD.MM.YYYY HH24:MI:SS'')';\r\n end;\r\n end;\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvDatabaseActionDevartDatasetEngine.RefreshRecord(AActionComponent :\r\n TComponent);\r\nbegin\r\n inherited;\r\n if GetDataset(AActionComponent) is TCustomDADataSet then\r\n TCustomDADataSet(GetDataset(AActionComponent)).RefreshRecord;\r\nend;\r\n\r\nfunction TJvDatabaseActionDevartDatasetEngine.SupportsComponent(AActionComponent\r\n : TComponent): Boolean;\r\nbegin\r\n Result := (GetDataset(AActionComponent) is TCustomDADataSet);\r\nend;\r\n\r\nfunction TJvDatabaseActionDevartDatasetEngine.SupportsGetSQL(AActionComponent :\r\n TComponent): Boolean;\r\nbegin\r\n Result := True;\r\nend;\r\n\r\nfunction TJvDatabaseActionDevartDatasetEngine.SupportsRefreshRecord(AActionComponent : TComponent): Boolean;\r\nbegin\r\n Result := True;\r\nend;\r\n\r\n{$ENDIF USE_3RDPARTY_DEVART_DAC}\r\n\r\nprocedure InitActionEngineList;\r\nbegin\r\n {$IFDEF USE_3RDPARTY_DEVART_DAC}\r\n RegisterDatabaseActionEngine(TJvDatabaseActionDevartDatasetEngine);\r\n {$ENDIF USE_3RDPARTY_DEVART_DAC}\r\nend;\r\n\r\ninitialization\r\n {$IFDEF UNITVERSIONING}\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n {$ENDIF UNITVERSIONING}\r\n InitActionEngineList;\r\n\r\nfinalization\r\n {$IFDEF UNITVERSIONING}\r\n UnregisterUnitVersion(HInstance);\r\n {$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvDBActionsEngineDatasetDoa.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvDBActionsEngineDatasetDoa.Pas, released on 2004-12-30.\r\n\r\nThe Initial Developer of the Original Code is Jens Fudickar [jens dott fudicker att oratool dott de]\r\nPortions created by Jens Fudickar are Copyright (C) 2002 Jens Fudickar.\r\nAll Rights Reserved.\r\n\r\nContributor(s): -\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvDBActionsEngineDatasetDoa.pas 12461 2009-08-14 17:21:33Z obones $\r\n\r\nunit JvDBActionsEngineDatasetDoa;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Classes, DB,\r\n JvDBActionsEngine;\r\n\r\n{$IFDEF USE_3RDPARTY_DOA}\r\ntype\r\n TJvDatabaseActionDoaDatasetEngine = class(TJvDatabaseActionBaseDatasetEngine)\r\n public\r\n function GetSQL(AActionComponent : TComponent): string; override;\r\n function SupportsComponent(AActionComponent : TComponent): Boolean; override;\r\n function SupportsGetSQL(AActionComponent : TComponent): Boolean; override;\r\n end;\r\n{$ENDIF USE_3RDPARTY_DOA}\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvDBActionsEngineDatasetDoa.pas $';\r\n Revision: '$Revision: 12461 $';\r\n Date: '$Date: 2009-08-14 19:21:33 +0200 (ven. 14 août 2009) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\n{$IFDEF USE_3RDPARTY_DOA}\r\nuses\r\n OracleData;\r\n{$ENDIF USE_3RDPARTY_DOA}\r\n\r\n{$IFDEF USE_3RDPARTY_DOA}\r\n\r\nfunction TJvDatabaseActionDoaDatasetEngine.GetSQL(AActionComponent :\r\n TComponent): string;\r\nbegin\r\n Result := TOracleDataset(AActionComponent).SQL.Text;\r\nend;\r\n\r\nfunction TJvDatabaseActionDoaDatasetEngine.SupportsComponent(AActionComponent :\r\n TComponent): Boolean;\r\nbegin\r\n Result := (AActionComponent is TOracleDataset);\r\nend;\r\n\r\nfunction TJvDatabaseActionDoaDatasetEngine.SupportsGetSQL(AActionComponent :\r\n TComponent): Boolean;\r\nbegin\r\n Result := True;\r\nend;\r\n\r\n{$ENDIF USE_3RDPARTY_DOA}\r\n\r\nprocedure InitActionEngineList;\r\nbegin\r\n {$IFDEF USE_3RDPARTY_DOA}\r\n RegisterDatabaseActionEngine(TJvDatabaseActionDoaDatasetEngine);\r\n {$ENDIF USE_3RDPARTY_DOA}\r\nend;\r\n\r\ninitialization\r\n {$IFDEF UNITVERSIONING}\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n {$ENDIF UNITVERSIONING}\r\n InitActionEngineList;\r\n\r\nfinalization\r\n {$IFDEF UNITVERSIONING}\r\n UnregisterUnitVersion(HInstance);\r\n {$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvDBCheckBox.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvDBCheckBox.pas, released on 2007-06-28.\r\n\r\nThe Initial Developer of the Original Code is Andreas Hausladen [andreas dott hausladen att gmx dott de]\r\nPortions created by Andreas Hausladen are Copyright (C) 2007 Andreas Hausladen.\r\nAll Rights Reserved.\r\n\r\nContributor(s): -\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvDBCheckBox.pas 13138 2011-10-26 23:17:50Z jfudickar $\r\n\r\nunit JvDBCheckBox;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, Messages, SysUtils, Classes, Controls, DB, DBCtrls;\r\n\r\ntype\r\n TJvDBCheckBoxChangingEvent = procedure(Sender: TObject; var Allow: Boolean) of object;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvDBCheckBox = class(TDBCheckBox)\r\n private\r\n FDirectEdit: Boolean;\r\n FOnChange: TNotifyEvent;\r\n FOnChanging: TJvDBCheckBoxChangingEvent;\r\n FOrgDataChange: TNotifyEvent;\r\n FDataChanging: Integer;\r\n FToggling: Integer;\r\n FOldValue: Variant;\r\n\r\n procedure CMExit(var Message: TCMExit); message CM_EXIT;\r\n function GetDataLink: TFieldDataLink;\r\n protected\r\n procedure DataChange(Sender: TObject);\r\n\r\n procedure Toggle; override;\r\n function DoChanging: Boolean; virtual;\r\n procedure DoChange; virtual;\r\n procedure KeyPress(var Key: Char); override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n published\r\n property DirectEdit: Boolean read FDirectEdit write FDirectEdit default True;\r\n property OnChanging: TJvDBCheckBoxChangingEvent read FOnChanging write FOnChanging;\r\n property OnChange: TNotifyEvent read FOnChange write FOnChange;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvDBCheckBox.pas $';\r\n Revision: '$Revision: 13138 $';\r\n Date: '$Date: 2011-10-27 01:17:50 +0200 (jeu. 27 oct. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\n{ TJvDBCheckBox }\r\n\r\nconstructor TJvDBCheckBox.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FDirectEdit := True;\r\n FOrgDataChange := GetDataLink.OnDataChange;\r\n GetDataLink.OnDataChange := DataChange;\r\nend;\r\n\r\nprocedure TJvDBCheckBox.CMExit(var Message: TCMExit);\r\nbegin\r\n if DirectEdit then\r\n begin\r\n if GetDataLink.Active and (Field <> nil) then\r\n FOldValue := Field.Value;\r\n DoExit // TWinControl behaviour\r\n end\r\n else\r\n inherited;\r\nend;\r\n\r\nprocedure TJvDBCheckBox.DoChange;\r\nbegin\r\n if Assigned(FOnChange) then\r\n FOnChange(Self);\r\nend;\r\n\r\nprocedure TJvDBCheckBox.Toggle;\r\nbegin\r\n if FDataChanging = 0 then\r\n begin\r\n if not DoChanging then\r\n Exit;\r\n end;\r\n\r\n Inc(FToggling);\r\n try\r\n inherited Toggle;\r\n if DirectEdit and (FDataChanging = 0) and GetDataLink.Active and GetDataLink.Editing then\r\n GetDataLink.UpdateRecord;\r\n finally\r\n Dec(FToggling);\r\n end;\r\n\r\n if FDataChanging = 0 then\r\n DoChange;\r\nend;\r\n\r\nfunction TJvDBCheckBox.DoChanging: Boolean;\r\nbegin\r\n Result := True;\r\n if Assigned(FOnChanging) then\r\n FOnChanging(Self, Result);\r\nend;\r\n\r\nfunction TJvDBCheckBox.GetDataLink: TFieldDataLink;\r\nbegin\r\n Result := TFieldDataLink(Perform(CM_GETDATALINK, 0, 0));\r\nend;\r\n\r\nprocedure TJvDBCheckBox.KeyPress(var Key: Char);\r\nbegin\r\n case Key of\r\n #27:\r\n if (Field <> nil) and (DataSource <> nil) and (DataSource.State in [dsEdit, dsInsert]) then\r\n Field.Value := FOldValue;\r\n end;\r\n inherited KeyPress(Key);\r\nend;\r\n\r\nprocedure TJvDBCheckBox.DataChange(Sender: TObject);\r\nbegin\r\n if (FToggling = 0) and DirectEdit and (Field <> nil) then\r\n FOldValue := Field.Value;\r\n\r\n Inc(FDataChanging);\r\n try\r\n FOrgDataChange(Sender);\r\n finally\r\n Dec(FDataChanging);\r\n end;\r\nend;\r\n\r\ninitialization\r\n {$IFDEF UNITVERSIONING}\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n {$ENDIF UNITVERSIONING}\r\n\r\nfinalization\r\n {$IFDEF UNITVERSIONING}\r\n UnregisterUnitVersion(HInstance);\r\n {$ENDIF UNITVERSIONING}\r\n\r\nend." }, { "path": "External/Jedi/Jvcl/run/JvDBCombobox.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvDBComb.PAS, released on 2002-07-04.\r\n\r\nThe Initial Developers of the Original Code are: Fedor Koshevnikov, Igor Pavluk and Serge Korolev\r\nCopyright (c) 1997, 1998 Fedor Koshevnikov, Igor Pavluk and Serge Korolev\r\nCopyright (c) 2001,2002 SGB Software\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\n Polaris Software\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvDBCombobox.pas 13104 2011-09-07 06:50:43Z obones $\r\n\r\nunit JvDBCombobox;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, Messages,\r\n Variants, Classes, Graphics, Controls, StdCtrls, DB, DBCtrls,\r\n JvExStdCtrls, JvDBUtils, JvCombobox;\r\n\r\ntype\r\n TJvCustomDBComboBox = class;\r\n TJvDBComboBox = class;\r\n\r\n TJvComboBoxFilterEvent = procedure(Sender: TObject; DataSet: TDataSet; var Accept: Boolean) of object;\r\n\r\n TJvDBComboBoxListDataLink = class(TDataLink)\r\n private\r\n FOnReload: TNotifyEvent;\r\n protected\r\n procedure DataEvent(Event: TDataEvent; Info: {$IFDEF RTL230_UP}NativeInt{$ELSE}Integer{$ENDIF}); override;\r\n public\r\n property OnReload: TNotifyEvent read FOnReload write FOnReload;\r\n end;\r\n\r\n TJvDBComboBoxListSettings = class(TPersistent)\r\n private\r\n FListDataLink: TJvDBComboBoxListDataLink;\r\n FFilter: string;\r\n FKeyField: string;\r\n FDisplayField: string;\r\n FOnFilter: TJvComboBoxFilterEvent;\r\n FShowOutfilteredValue: Boolean;\r\n FOutfilteredValueFont: TFont;\r\n FComboBox: TJvCustomDBComboBox;\r\n procedure SetDataSource(const Value: TDataSource);\r\n procedure SetFilter(Value: string);\r\n function GetDataSource: TDataSource;\r\n procedure SetDisplayField(const Value: string);\r\n procedure SetKeyField(const Value: string);\r\n procedure SetShowOutfilteredValue(const Value: Boolean);\r\n procedure SetOutfilteredValueFont(const Value: TFont);\r\n protected\r\n procedure ListDataChange(Sender: TObject);\r\n procedure FontChange(Sender: TObject);\r\n procedure Notification(AComponent: TComponent; Operation: TOperation);\r\n\r\n property ComboBox: TJvCustomDBComboBox read FComboBox;\r\n public\r\n constructor Create(AComboBox: TJvCustomDBComboBox);\r\n destructor Destroy; override;\r\n procedure Assign(Source: TPersistent); override;\r\n\r\n function IsValid: Boolean;\r\n published\r\n { ShowOutfilteredValue: Shows the value/item if the field value is not in the\r\n filtered dataset but in the unfiltered dataset. }\r\n property ShowOutfilteredValue: Boolean read FShowOutfilteredValue write SetShowOutfilteredValue default False;\r\n { OutfilteredValueFont: The font that is used to paint the out-filtered value/item. }\r\n property OutfilteredValueFont: TFont read FOutfilteredValueFont write SetOutfilteredValueFont;\r\n\r\n { Filter: Is used to filter the dataset. It is compatible to the TClientDataSet.Filter }\r\n property Filter: string read FFilter write SetFilter;\r\n { KeyField: The field that is used for the ComboBox.Values list. }\r\n property KeyField: string read FKeyField write SetKeyField;\r\n { DisplayField: The field that is used for the ComboBox.Items list. }\r\n property DisplayField: string read FDisplayField write SetDisplayField;\r\n { DataSource: The records of the data source are filtered and added to the\r\n ComboBox.Values/Items list. }\r\n property DataSource: TDataSource read GetDataSource write SetDataSource;\r\n\r\n { OnFilter is triggered for every record before the Filter property is applied. }\r\n property OnFilter: TJvComboBoxFilterEvent read FOnFilter write FOnFilter;\r\n end;\r\n\r\n TJvCustomDBComboBox = class(TJvCustomComboBox, IJvDataControl)\r\n private\r\n FDataLink: TFieldDataLink;\r\n FPaintControl: TPaintControl;\r\n FBeepOnError: Boolean;\r\n FResetValue: Boolean;\r\n FUpdateFieldImmediatelly: Boolean;\r\n FListSettings: TJvDBComboBoxListSettings;\r\n FValues: TStringList;\r\n FEnableValues: Boolean;\r\n procedure SetEnableValues(Value: Boolean);\r\n function GetValues: TStrings;\r\n procedure SetValues(Value: TStrings);\r\n procedure ValuesChanged(Sender: TObject);\r\n procedure DataChange(Sender: TObject);\r\n procedure EditingChange(Sender: TObject);\r\n function GetDataField: string;\r\n function GetDataSource: TDataSource;\r\n function GetField: TField;\r\n function GetReadOnly: Boolean;\r\n procedure SetDataField(const Value: string);\r\n procedure SetDataSource(Value: TDataSource);\r\n procedure SetEditReadOnly;\r\n procedure SetReadOnly(Value: Boolean);\r\n procedure UpdateData(Sender: TObject);\r\n function GetComboText: string;\r\n procedure SetComboText(const Value: string);\r\n procedure CMGetDataLink(var Msg: TMessage); message CM_GETDATALINK;\r\n procedure WMPaint(var Msg: TWMPaint); message WM_PAINT;\r\n procedure SetListSettings(const Value: TJvDBComboBoxListSettings);\r\n protected\r\n function GetDataLink: TDataLink;\r\n\r\n procedure DoExit; override;\r\n procedure Change; override;\r\n procedure Click; override;\r\n procedure Reset;\r\n\r\n // This may cause trouble with BCB because it uses a HWND parameter\r\n // but as it is defined in the VCL itself, we can't do much.\r\n procedure ComboWndProc(var Msg: TMessage; ComboWnd: HWND; ComboProc: Pointer); override;\r\n\r\n procedure CreateWnd; override;\r\n function GetPaintText: string; virtual;\r\n procedure KeyDown(var Key: Word; Shift: TShiftState); override;\r\n procedure KeyPress(var Key: Char); override;\r\n procedure Loaded; override;\r\n procedure Notification(AComponent: TComponent; Operation: TOperation); override;\r\n procedure SetStyle(Value: TComboBoxStyle); override;\r\n function FilterAccepted: Boolean; virtual;\r\n\r\n procedure SetItems(const Value: TStrings); override;\r\n procedure WndProc(var Msg: TMessage); override;\r\n property BeepOnError: Boolean read FBeepOnError write FBeepOnError default False;\r\n property ComboText: string read GetComboText write SetComboText;\r\n property DataField: string read GetDataField write SetDataField;\r\n property DataSource: TDataSource read GetDataSource write SetDataSource;\r\n property ReadOnly: Boolean read GetReadOnly write SetReadOnly default False;\r\n property ListSettings: TJvDBComboBoxListSettings read FListSettings write SetListSettings;\r\n property Values: TStrings read GetValues write SetValues;\r\n property EnableValues: Boolean read FEnableValues write SetEnableValues default True;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n\r\n procedure UpdateDropDownItems; virtual;\r\n function ExecuteAction(Action: TBasicAction): Boolean; override;\r\n function UpdateAction(Action: TBasicAction): Boolean; override;\r\n function UseRightToLeftAlignment: Boolean; override;\r\n\r\n property Field: TField read GetField;\r\n property Items write SetItems;\r\n property Text;\r\n property UpdateFieldImmediatelly: Boolean read FUpdateFieldImmediatelly write FUpdateFieldImmediatelly default False;\r\n end;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvDBComboBox = class(TJvCustomDBComboBox)\r\n private\r\n { The \"AutoSize\" property was published what it never should have been. TComboBox doesn't\r\n support it and TJvCustomComboBox/TJvDBCustomComboBox do not support it either. }\r\n procedure ReadIgnoredBoolean(Reader: TReader);\r\n protected\r\n procedure DefineProperties(Filer: TFiler); override;\r\n published\r\n property Align;\r\n property Style default csDropDownList; { must be published before Items }\r\n property BeepOnError;\r\n property BevelEdges;\r\n property BevelInner;\r\n property BevelKind default bkNone;\r\n property BevelOuter;\r\n property Color;\r\n property DataField;\r\n property DataSource;\r\n property DragMode;\r\n property DragCursor;\r\n property DropDownCount;\r\n property DropDownWidth;\r\n property Enabled;\r\n property EnableValues;\r\n property Font;\r\n property Anchors;\r\n property BiDiMode;\r\n property Constraints;\r\n property DragKind;\r\n property ParentBiDiMode;\r\n property ImeMode;\r\n property ImeName;\r\n property ItemHeight;\r\n property Items;\r\n property ParentColor;\r\n property ParentFont;\r\n property ParentShowHint;\r\n property PopupMenu;\r\n property ReadOnly;\r\n property ShowHint;\r\n property Sorted;\r\n property TabOrder;\r\n property TabStop;\r\n property UpdateFieldImmediatelly;\r\n property Values;\r\n property Visible;\r\n property ListSettings; { should be published after Items and Values }\r\n property OnChange;\r\n property OnClick;\r\n property OnCloseUp;\r\n property OnDblClick;\r\n property OnDragDrop;\r\n property OnDragOver;\r\n property OnDrawItem;\r\n property OnDropDown;\r\n property OnEndDrag;\r\n property OnEnter;\r\n property OnExit;\r\n property OnKeyDown;\r\n property OnKeyPress;\r\n property OnKeyUp;\r\n property OnMeasureItem;\r\n property OnStartDrag;\r\n property OnContextPopup;\r\n property OnEndDock;\r\n property OnStartDock;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvDBCombobox.pas $';\r\n Revision: '$Revision: 13104 $';\r\n Date: '$Date: 2011-09-07 08:50:43 +0200 (mer. 07 sept. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n VDBConsts,\r\n {$IFNDEF COMPILER12_UP}\r\n JvJCLUtils,\r\n {$ENDIF ~COMPILER12_UP}\r\n SysUtils,\r\n JvDBFilterExpr,\r\n JvConsts;\r\n\r\ntype\r\n TDataSetAccess = class(TDataSet);\r\n\r\n//=== { TJvCustomDBComboBox } ================================================\r\n\r\nconstructor TJvCustomDBComboBox.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n ControlStyle := ControlStyle + [csReplicatable];\r\n FDataLink := TFieldDataLink.Create;\r\n FDataLink.Control := Self;\r\n FDataLink.OnDataChange := DataChange;\r\n FDataLink.OnUpdateData := UpdateData;\r\n FDataLink.OnEditingChange := EditingChange;\r\n FPaintControl := TPaintControl.Create(Self, 'COMBOBOX');\r\n FBeepOnError := False;\r\n\r\n FListSettings := TJvDBComboBoxListSettings.Create(Self);\r\n FValues := TStringList.Create;\r\n FValues.OnChange := ValuesChanged;\r\n FEnableValues := True;\r\n Style := csDropDownList;\r\nend;\r\n\r\ndestructor TJvCustomDBComboBox.Destroy;\r\nbegin\r\n FPaintControl.Free;\r\n FDataLink.OnDataChange := nil;\r\n FDataLink.OnUpdateData := nil;\r\n FDataLink.Free;\r\n FDataLink := nil;\r\n FreeAndNil(FListSettings);\r\n FValues.OnChange := nil;\r\n FValues.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvCustomDBComboBox.Loaded;\r\nbegin\r\n inherited Loaded;\r\n if csDesigning in ComponentState then\r\n DataChange(Self);\r\n UpdateDropDownItems;\r\nend;\r\n\r\nprocedure TJvCustomDBComboBox.Notification(AComponent: TComponent;\r\n Operation: TOperation);\r\nbegin\r\n inherited Notification(AComponent, Operation);\r\n if (Operation = opRemove) and (FDataLink <> nil) and (AComponent = DataSource) then\r\n DataSource := nil;\r\n\r\n if FListSettings <> nil then\r\n FListSettings.Notification(AComponent, Operation);\r\nend;\r\n\r\nprocedure TJvCustomDBComboBox.CreateWnd;\r\nbegin\r\n inherited CreateWnd;\r\n SetEditReadOnly;\r\n DataChange(Self);\r\nend;\r\n\r\nprocedure TJvCustomDBComboBox.DataChange(Sender: TObject);\r\nbegin\r\n if not HandleAllocated or (DroppedDown and not FResetValue) then\r\n Exit;\r\n if FDataLink.Field <> nil then\r\n SetComboText(FDataLink.Field.AsString)\r\n else\r\n if csDesigning in ComponentState then\r\n ComboText := Name\r\n else\r\n if FDataLink <> nil then\r\n FDataLink.UpdateRecord\r\n else\r\n ComboText := '';\r\nend;\r\n\r\nprocedure TJvCustomDBComboBox.UpdateData(Sender: TObject);\r\nbegin\r\n FDataLink.Field.AsString := ComboText;\r\nend;\r\n\r\nprocedure TJvCustomDBComboBox.SetComboText(const Value: string);\r\nvar\r\n I: Integer;\r\n Redraw: Boolean;\r\nbegin\r\n if Value <> ComboText then\r\n begin\r\n if Style <> csDropDown then\r\n begin\r\n Redraw := (Style <> csSimple) and HandleAllocated;\r\n if Redraw then\r\n SendMessage(Handle, WM_SETREDRAW, 0, 0);\r\n try\r\n if Value = '' then\r\n I := -1\r\n else\r\n begin\r\n I := Items.IndexOf(Value);\r\n if (I = -1) and FEnableValues then\r\n I := Values.IndexOf(Value);\r\n end;\r\n if I >= Items.Count then\r\n I := -1;\r\n ItemIndex := I;\r\n finally\r\n if Redraw then\r\n begin\r\n SendMessage(Handle, WM_SETREDRAW, 1, 0);\r\n Invalidate;\r\n end;\r\n end;\r\n if I >= 0 then\r\n Exit;\r\n end;\r\n if Style in [csDropDown, csSimple] then\r\n Text := Value;\r\n end;\r\nend;\r\n\r\nfunction TJvCustomDBComboBox.GetComboText: string;\r\nvar\r\n I: Integer;\r\nbegin\r\n if (Style in [csDropDown, csSimple]) and not FEnableValues then\r\n Result := Text\r\n else\r\n begin\r\n I := ItemIndex;\r\n if (I < 0) or (FEnableValues and (FValues.Count < I + 1)) then\r\n Result := ''\r\n else\r\n if FEnableValues then\r\n Result := FValues[I]\r\n else\r\n Result := Items[I];\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomDBComboBox.Change;\r\nbegin\r\n FDataLink.Edit;\r\n if UpdateFieldImmediatelly then\r\n FDataLink.UpdateRecord;\r\n inherited Change;\r\n FDataLink.Modified;\r\nend;\r\n\r\nprocedure TJvCustomDBComboBox.Click;\r\nbegin\r\n FDataLink.Edit;\r\n if UpdateFieldImmediatelly then\r\n FDataLink.UpdateRecord;\r\n inherited Click;\r\n FDataLink.Modified;\r\nend;\r\n\r\nfunction TJvCustomDBComboBox.GetDataSource: TDataSource;\r\nbegin\r\n Result := FDataLink.DataSource;\r\nend;\r\n\r\nprocedure TJvCustomDBComboBox.SetDataSource(Value: TDataSource);\r\nbegin\r\n if not (FDataLink.DataSourceFixed and (csLoading in ComponentState)) then\r\n begin\r\n if FDataLink.DataSource <> nil then\r\n FDataLink.DataSource.RemoveFreeNotification(Self);\r\n FDataLink.DataSource := Value;\r\n end;\r\n if Value <> nil then\r\n Value.FreeNotification(Self);\r\nend;\r\n\r\nfunction TJvCustomDBComboBox.GetDataField: string;\r\nbegin\r\n Result := FDataLink.FieldName;\r\nend;\r\n\r\nprocedure TJvCustomDBComboBox.SetDataField(const Value: string);\r\nbegin\r\n FDataLink.FieldName := Value;\r\nend;\r\n\r\nfunction TJvCustomDBComboBox.GetReadOnly: Boolean;\r\nbegin\r\n Result := FDataLink.ReadOnly;\r\nend;\r\n\r\nprocedure TJvCustomDBComboBox.SetReadOnly(Value: Boolean);\r\nbegin\r\n FDataLink.ReadOnly := Value;\r\nend;\r\n\r\nfunction TJvCustomDBComboBox.GetField: TField;\r\nbegin\r\n Result := FDataLink.Field;\r\nend;\r\n\r\nprocedure TJvCustomDBComboBox.KeyDown(var Key: Word; Shift: TShiftState);\r\nbegin\r\n inherited KeyDown(Key, Shift);\r\n if Key in [VK_BACK, VK_DELETE, VK_UP, VK_DOWN, 32..255] then\r\n if not FDataLink.Edit and (Key in [VK_UP, VK_DOWN]) then\r\n Key := 0;\r\nend;\r\n\r\nprocedure TJvCustomDBComboBox.KeyPress(var Key: Char);\r\nbegin\r\n inherited KeyPress(Key);\r\n if CharInSet(Key, [#32..#255]) and (FDataLink.Field <> nil) and\r\n not FDataLink.Field.IsValidChar(Key) then\r\n begin\r\n if BeepOnError then\r\n SysUtils.Beep;\r\n Key := #0;\r\n end;\r\n case Key of\r\n CtrlH, CtrlV, CtrlX, #32..#255:\r\n FDataLink.Edit;\r\n Esc:\r\n begin\r\n FDataLink.Reset;\r\n if UpdateFieldImmediatelly and (FDataLink.Field <> nil) and FDataLink.Editing then\r\n FDataLink.Field.Value := FDataLink.Field.OldValue;\r\n SelectAll;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomDBComboBox.EditingChange(Sender: TObject);\r\nbegin\r\n SetEditReadOnly;\r\nend;\r\n\r\nprocedure TJvCustomDBComboBox.SetEditReadOnly;\r\nbegin\r\n if (Style in [csDropDown, csSimple]) and HandleAllocated then\r\n SendMessage(EditHandle, EM_SETREADONLY, Ord(not FDataLink.Editing), 0);\r\nend;\r\n\r\nprocedure TJvCustomDBComboBox.Reset;\r\nbegin\r\n FResetValue := True;\r\n try\r\n DataChange(Self); {Restore text}\r\n finally\r\n FResetValue := False;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomDBComboBox.WndProc(var Msg: TMessage);\r\nbegin\r\n if not (csDesigning in ComponentState) then\r\n case Msg.Msg of\r\n WM_COMMAND:\r\n if TWMCommand(Msg).NotifyCode = CBN_SELCHANGE then\r\n begin\r\n try\r\n if not FDataLink.Edit then\r\n begin\r\n if Style <> csSimple then\r\n PostMessage(Handle, CB_SHOWDROPDOWN, 0, 0);\r\n Exit;\r\n end;\r\n except\r\n Reset;\r\n raise;\r\n end;\r\n end;\r\n CB_SHOWDROPDOWN:\r\n if Msg.WParam <> 0 then\r\n begin\r\n try\r\n FDataLink.Edit;\r\n except\r\n Reset;\r\n raise;\r\n end;\r\n end\r\n else\r\n if not FDataLink.Editing then\r\n Reset;\r\n WM_CREATE, WM_WINDOWPOSCHANGED, CM_FONTCHANGED:\r\n FPaintControl.DestroyHandle;\r\n end;\r\n inherited WndProc(Msg);\r\nend;\r\n\r\nprocedure TJvCustomDBComboBox.ComboWndProc(var Msg: TMessage; ComboWnd: HWND; ComboProc: Pointer);\r\nbegin\r\n if not (csDesigning in ComponentState) then\r\n case Msg.Msg of\r\n WM_LBUTTONDOWN:\r\n if (Style = csSimple) and (ComboWnd <> EditHandle) then\r\n if not FDataLink.Edit then\r\n Exit;\r\n end;\r\n inherited ComboWndProc(Msg, ComboWnd, ComboProc);\r\nend;\r\n\r\nprocedure TJvCustomDBComboBox.DoExit;\r\nbegin\r\n try\r\n FDataLink.UpdateRecord;\r\n except\r\n SelectAll;\r\n if CanFocus then\r\n SetFocus;\r\n raise;\r\n end;\r\n inherited DoExit;\r\n if ListSettings.IsValid and ListSettings.ShowOutfilteredValue and (ItemIndex = -1) then\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvCustomDBComboBox.CMGetDataLink(var Msg: TMessage);\r\nbegin\r\n Msg.Result := LRESULT(FDataLink);\r\nend;\r\n\r\nfunction TJvCustomDBComboBox.GetDataLink: TDataLink;\r\nbegin\r\n Result := FDataLink;\r\nend;\r\n\r\nprocedure TJvCustomDBComboBox.WMPaint(var Msg: TWMPaint);\r\n\r\n procedure DefaultPaint;\r\n var\r\n S: string;\r\n R: TRect;\r\n P: TPoint;\r\n Child: HWND;\r\n begin\r\n if csPaintCopy in ControlState then\r\n begin\r\n S := GetPaintText;\r\n if Style = csDropDown then\r\n begin\r\n SendMessage(FPaintControl.Handle, WM_SETTEXT, 0, LPARAM(PChar(S)));\r\n SendMessage(FPaintControl.Handle, WM_PAINT, Msg.DC, 0);\r\n Child := GetWindow(FPaintControl.Handle, GW_CHILD);\r\n if Child <> 0 then\r\n begin\r\n Windows.GetClientRect(Child, R);\r\n Windows.MapWindowPoints(Child, FPaintControl.Handle, R.TopLeft, 2);\r\n GetWindowOrgEx(Msg.DC, P);\r\n SetWindowOrgEx(Msg.DC, P.X - R.Left, P.Y - R.Top, nil);\r\n IntersectClipRect(Msg.DC, 0, 0, R.Right - R.Left, R.Bottom - R.Top);\r\n SendMessage(Child, WM_PAINT, Msg.DC, 0);\r\n end;\r\n end\r\n else\r\n begin\r\n SendMessage(FPaintControl.Handle, CB_RESETCONTENT, 0, 0);\r\n if Items.IndexOf(S) <> -1 then\r\n begin\r\n SendMessage(FPaintControl.Handle, CB_ADDSTRING, 0, LPARAM(PChar(S)));\r\n SendMessage(FPaintControl.Handle, CB_SETCURSEL, 0, 0);\r\n end;\r\n SendMessage(FPaintControl.Handle, WM_PAINT, Msg.DC, 0);\r\n end;\r\n end\r\n else\r\n inherited;\r\n end;\r\n\r\nvar\r\n S: string;\r\n R: TRect;\r\n PaintStruct: TPaintStruct;\r\n DC: HDC;\r\n OldFont: HFONT;\r\nbegin\r\n { If the field value is not part of the DataSource }\r\n if (Style in [csDropDownList, csOwnerDrawFixed, csOwnerDrawVariable]) and\r\n ListSettings.ShowOutfilteredValue and (ItemIndex = -1) and\r\n FDataLink.Active and (FDataLink.Field <> nil) and not FDataLink.Field.IsNull and\r\n ListSettings.IsValid then\r\n begin\r\n if ListSettings.DisplayField <> '' then\r\n S := VarToStr(ListSettings.DataSource.DataSet.Lookup(ListSettings.KeyField, FDataLink.Field.AsVariant, ListSettings.DisplayField))\r\n else\r\n S := FDataLink.Field.Text;\r\n\r\n if Trim(S) = '' then\r\n begin\r\n DefaultPaint;\r\n Exit;\r\n end;\r\n\r\n DC := Msg.DC;\r\n if DC = 0 then\r\n DC := BeginPaint(Handle, PaintStruct);\r\n try\r\n Msg.DC := DC;\r\n DefaultPaint;\r\n\r\n R := ClientRect;\r\n InflateRect(R, -1, -1);\r\n Inc(R.Left, 3);\r\n SetTextColor(DC, ColorToRGB(ListSettings.OutfilteredValueFont.Color));\r\n SetBkMode(DC, TRANSPARENT);\r\n OldFont := SelectObject(DC, ListSettings.OutfilteredValueFont.Handle);\r\n if Style = csDropDownList then\r\n DrawText(DC, PChar(S), Length(S), R, DT_VCENTER or DT_END_ELLIPSIS or DT_SINGLELINE or DT_NOPREFIX)\r\n else\r\n begin\r\n Inc(R.Left);\r\n R.Top := 3;\r\n DrawText(DC, PChar(S), Length(S), R, DT_END_ELLIPSIS or DT_SINGLELINE or DT_NOPREFIX)\r\n end;\r\n SelectObject(DC, OldFont);\r\n finally\r\n if PaintStruct.hdc <> 0 then\r\n EndPaint(Handle, PaintStruct);\r\n end;\r\n end\r\n else\r\n DefaultPaint;\r\nend;\r\n\r\nfunction TJvCustomDBComboBox.GetPaintText: string;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := '';\r\n if FDataLink.Field <> nil then\r\n begin\r\n if FEnableValues then\r\n begin\r\n I := Values.IndexOf(FDataLink.Field.AsString);\r\n if I >= 0 then\r\n Result := Items.Strings[I];\r\n end\r\n else\r\n Result := FDataLink.Field.Text;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomDBComboBox.SetItems(const Value: TStrings);\r\nbegin\r\n inherited SetItems(Value);\r\n DataChange(Self);\r\nend;\r\n\r\nprocedure TJvCustomDBComboBox.SetStyle(Value: TComboBoxStyle);\r\nbegin\r\n if (Value in [csSimple, csDropDown]) and FEnableValues then\r\n FEnableValues := False;\r\n\r\n if (Value = csSimple) and Assigned(FDataLink) and FDataLink.DataSourceFixed then\r\n _DBError(SNotReplicatable);\r\n inherited SetStyle(Value);\r\nend;\r\n\r\nfunction TJvCustomDBComboBox.UseRightToLeftAlignment: Boolean;\r\nbegin\r\n Result := DBUseRightToLeftAlignment(Self, Field);\r\nend;\r\n\r\nfunction TJvCustomDBComboBox.ExecuteAction(Action: TBasicAction): Boolean;\r\nbegin\r\n Result := inherited ExecuteAction(Action) or (FDataLink <> nil) and\r\n FDataLink.ExecuteAction(Action);\r\nend;\r\n\r\nfunction TJvCustomDBComboBox.UpdateAction(Action: TBasicAction): Boolean;\r\nbegin\r\n Result := inherited UpdateAction(Action) or (FDataLink <> nil) and\r\n FDataLink.UpdateAction(Action);\r\nend;\r\n\r\nprocedure TJvCustomDBComboBox.ValuesChanged(Sender: TObject);\r\nbegin\r\n if FEnableValues then\r\n DataChange(Self);\r\nend;\r\n\r\nprocedure TJvCustomDBComboBox.SetEnableValues(Value: Boolean);\r\nbegin\r\n if FEnableValues <> Value then\r\n begin\r\n if Value and (Style in [csDropDown, csSimple]) then\r\n Style := csDropDownList;\r\n FEnableValues := Value;\r\n DataChange(Self);\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomDBComboBox.SetListSettings(const Value: TJvDBComboBoxListSettings);\r\nbegin\r\n if Value <> FListSettings then\r\n FListSettings.Assign(Value);\r\nend;\r\n\r\nfunction TJvCustomDBComboBox.GetValues: TStrings;\r\nbegin\r\n Result := FValues;\r\nend;\r\n\r\nprocedure TJvCustomDBComboBox.SetValues(Value: TStrings);\r\nbegin\r\n FValues.Assign(Value);\r\nend;\r\n\r\nfunction TJvCustomDBComboBox.FilterAccepted: Boolean;\r\nbegin\r\n Result := True;\r\n with ListSettings do\r\n if Assigned(FOnFilter) and (DataSource <> nil) and (DataSource.DataSet <> nil) then\r\n FOnFilter(Self, DataSource.DataSet, Result);\r\nend;\r\n\r\nprocedure TJvCustomDBComboBox.UpdateDropDownItems;\r\nvar\r\n Bookmark: TBookmark;\r\n FilterExpr: TJvDBFilterExpression;\r\n LKeyField, LDisplayField: TField;\r\n DataSet: TDataSet;\r\n LastText: string;\r\nbegin\r\n if ([csDesigning, csLoading, csDestroying] * ComponentState = []) and\r\n (ListSettings.DataSource <> nil) and (ListSettings.DataSource.DataSet <> nil) and\r\n (ListSettings.DataSource.State = dsBrowse) then\r\n begin\r\n { Component is in the ListDataSet mode }\r\n Items.BeginUpdate;\r\n Values.BeginUpdate;\r\n try\r\n LastText := GetComboText();\r\n Items.Clear;\r\n Values.Clear;\r\n if ListSettings.IsValid and ListSettings.DataSource.DataSet.Active and (ListSettings.KeyField <> '') then\r\n begin\r\n DataSet := ListSettings.DataSource.DataSet;\r\n LKeyField := DataSet.FieldByName(ListSettings.KeyField);\r\n if ListSettings.DisplayField = '' then\r\n LDisplayField := LKeyField\r\n else\r\n LDisplayField := DataSet.FieldByName(ListSettings.DisplayField);\r\n\r\n DataSet.DisableControls;\r\n try\r\n Bookmark := DataSet.GetBookmark;\r\n try\r\n FilterExpr := nil;\r\n if ListSettings.Filter <> '' then\r\n FilterExpr := TJvDBFilterExpression.Create(DataSet, ListSettings.Filter, []);\r\n try\r\n DataSet.First;\r\n while not DataSet.Eof do\r\n begin\r\n if FilterAccepted\r\n and ((FilterExpr = nil) or FilterExpr.Evaluate) \r\n then\r\n begin\r\n Items.Add(LDisplayField.AsString);\r\n Values.Add(LKeyField.AsString);\r\n end;\r\n DataSet.Next;\r\n end;\r\n finally\r\n FilterExpr.Free;\r\n end;\r\n finally\r\n if Bookmark <> nil then\r\n begin\r\n DataSet.GotoBookmark(Bookmark);\r\n DataSet.FreeBookmark(Bookmark);\r\n end;\r\n end;\r\n finally\r\n //DataSet.EnableControls;\r\n TDataSetAccess(DataSet).RestoreState(DataSet.State); // do not trigger a refresh\r\n end;\r\n end;\r\n finally\r\n Items.EndUpdate;\r\n Values.EndUpdate;\r\n end;\r\n SetComboText(LastText);\r\n end;\r\nend;\r\n\r\n{ TJvDBComboBoxListDataLink }\r\n\r\nprocedure TJvDBComboBoxListDataLink.DataEvent(Event: TDataEvent; Info: {$IFDEF RTL230_UP}NativeInt{$ELSE}Integer{$ENDIF});\r\nbegin\r\n inherited DataEvent(Event, Info);\r\n if Assigned(FOnReload) then\r\n begin\r\n case Event of\r\n deFieldListChange,\r\n deDataSetChange:\r\n FOnReload(Self);\r\n end;\r\n end;\r\nend;\r\n\r\n{ TJvDBComboBoxListSettings }\r\n\r\nconstructor TJvDBComboBoxListSettings.Create(AComboBox: TJvCustomDBComboBox);\r\nbegin\r\n inherited Create;\r\n FComboBox := AComboBox;\r\n FListDataLink := TJvDBComboBoxListDataLink.Create;\r\n FListDataLink.OnReload := ListDataChange;\r\n FShowOutfilteredValue := False;\r\n FOutfilteredValueFont := TFont.Create;\r\n FOutfilteredValueFont.Color := clRed;\r\n FOutfilteredValueFont.OnChange := FontChange;\r\nend;\r\n\r\ndestructor TJvDBComboBoxListSettings.Destroy;\r\nbegin\r\n SetDataSource(nil);\r\n FOutfilteredValueFont.Free;\r\n FListDataLink.OnReload := nil;\r\n FListDataLink.Free;\r\n FListDataLink := nil;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvDBComboBoxListSettings.FontChange(Sender: TObject);\r\nbegin\r\n ComboBox.Invalidate;\r\nend;\r\n\r\nprocedure TJvDBComboBoxListSettings.Assign(Source: TPersistent);\r\nvar\r\n Src: TJvDBComboBoxListSettings;\r\nbegin\r\n if Source is TJvDBComboBoxListSettings then\r\n begin\r\n Src := TJvDBComboBoxListSettings(Source);\r\n FShowOutfilteredValue := Src.FShowOutfilteredValue;\r\n FOutfilteredValueFont.Assign(Src.FOutfilteredValueFont);\r\n FFilter := Src.FFilter;\r\n FKeyField := Src.FKeyField;\r\n FDisplayField := Src.FDisplayField;\r\n SetDataSource(Src.DataSource);\r\n FOnFilter := Src.FOnFilter;\r\n\r\n ComboBox.UpdateDropDownItems;\r\n ComboBox.Invalidate;\r\n end\r\n else\r\n inherited Assign(Source);\r\nend;\r\n\r\nprocedure TJvDBComboBoxListSettings.Notification(AComponent: TComponent; Operation: TOperation);\r\nbegin\r\n if Operation = opRemove then\r\n if AComponent = DataSource then\r\n SetDataSource(nil);\r\nend;\r\n\r\nprocedure TJvDBComboBoxListSettings.SetDataSource(const Value: TDataSource);\r\nbegin\r\n if Value <> DataSource then\r\n begin\r\n if DataSource <> nil then\r\n begin\r\n DataSource.RemoveFreeNotification(ComboBox);\r\n FListDataLink.DataSource := nil;\r\n end;\r\n FListDataLink.DataSource := Value;\r\n if DataSource <> nil then\r\n DataSource.FreeNotification(ComboBox);\r\n ComboBox.UpdateDropDownItems;\r\n end;\r\nend;\r\n\r\nprocedure TJvDBComboBoxListSettings.SetDisplayField(const Value: string);\r\nbegin\r\n if Value <> FDisplayField then\r\n begin\r\n FDisplayField := Value;\r\n ComboBox.UpdateDropDownItems;\r\n end;\r\nend;\r\n\r\nprocedure TJvDBComboBoxListSettings.SetFilter(Value: string);\r\nbegin\r\n Value := Trim(Value);\r\n if Value <> FFilter then\r\n begin\r\n FFilter := Value;\r\n ComboBox.UpdateDropDownItems;\r\n if ComboBox.UpdateFieldImmediatelly then\r\n ComboBox.DataChange(Self);\r\n end;\r\nend;\r\n\r\nprocedure TJvDBComboBoxListSettings.SetKeyField(const Value: string);\r\nbegin\r\n if Value <> FKeyField then\r\n begin\r\n FKeyField := Value;\r\n ComboBox.UpdateDropDownItems;\r\n end;\r\nend;\r\n\r\nprocedure TJvDBComboBoxListSettings.SetOutfilteredValueFont(const Value: TFont);\r\nbegin\r\n if Value <> FOutfilteredValueFont then\r\n begin\r\n FOutfilteredValueFont.Assign(Value);\r\n ComboBox.Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvDBComboBoxListSettings.SetShowOutfilteredValue(const Value: Boolean);\r\nbegin\r\n if Value <> FShowOutfilteredValue then\r\n begin\r\n FShowOutfilteredValue := Value;\r\n ComboBox.Invalidate;\r\n end;\r\nend;\r\n\r\nfunction TJvDBComboBoxListSettings.GetDataSource: TDataSource;\r\nbegin\r\n if FListDataLink <> nil then\r\n Result := FListDataLink.DataSource\r\n else\r\n Result := nil;\r\nend;\r\n\r\nfunction TJvDBComboBoxListSettings.IsValid: Boolean;\r\nbegin\r\n Result := (DataSource <> nil) and (DataSource.DataSet <> nil) and DataSource.DataSet.Active and\r\n (KeyField <> '');\r\nend;\r\n\r\nprocedure TJvDBComboBoxListSettings.ListDataChange(Sender: TObject);\r\nbegin\r\n if FListDataLink.Active and (DataSource.State = dsBrowse) then\r\n begin\r\n ComboBox.UpdateDropDownItems;\r\n if ComboBox.UpdateFieldImmediatelly then\r\n ComboBox.DataChange(Self);\r\n end;\r\nend;\r\n\r\n{ TJvDBComboBox }\r\n\r\nprocedure TJvDBComboBox.ReadIgnoredBoolean(Reader: TReader);\r\nbegin\r\n Reader.ReadBoolean;\r\nend;\r\n\r\nprocedure TJvDBComboBox.DefineProperties(Filer: TFiler);\r\nbegin\r\n inherited DefineProperties(Filer);\r\n Filer.DefineProperty('AutoSize', ReadIgnoredBoolean, nil, False);\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvDBControls.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvDBCtrl.PAS, released on 2002-07-04.\r\n\r\nThe Initial Developers of the Original Code are: Fedor Koshevnikov, Igor Pavluk and Serge Korolev\r\nCopyright (c) 1997, 1998 Fedor Koshevnikov, Igor Pavluk and Serge Korolev\r\nCopyright (c) 2001,2002 SGB Software\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\n Polaris Software\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n\r\n === NEW IN JVCL 3.0 ==\r\n TJvDBMaskEdit is a new control, added by Warren Postma.\r\n\r\n Major Issues:\r\n EditMask property enables operation as masked edit, which doesn't\r\n work properly in a Control Grid, yet, if you set the EditMask.\r\n You can use it as a generic editor control inside a control grid.\r\n -- Warren Postma (warrenpstma att hotmail dott com)\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvDBControls.pas 13329 2012-06-12 14:28:33Z obones $\r\n\r\nunit JvDBControls;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows,\r\n Messages,\r\n Classes, Graphics, Controls, StdCtrls, DBCtrls, DB,\r\n JvSecretPanel, JvLabel, JvToolEdit, JvMaskEdit, JvBaseEdits;\r\n\r\ntype\r\n { NEW VALIDATION EVENT }\r\n TJvDBAcceptValueEvent = procedure(Sender: TObject; OldValue: string;\r\n var NewValue: string; var Accept, Post: Boolean) of object;\r\n\r\n {NEW IN JVCL3.0 - Enhanced DBEdit/DBMaskEdit }\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvDBMaskEdit = class(TJvCustomMaskEdit) // same base as TJvMaskEdit, plus data aware.\r\n private\r\n {Standard data-aware crap}\r\n FDataLink: TFieldDataLink;\r\n FCanvas: TControlCanvas;\r\n FFocused: Boolean;\r\n\r\n {new: Specific to this component}\r\n // value of text in the edit control at the time\r\n // that keyboard focus enters the control:\r\n FOriginalValue: string;\r\n // Validation/event.\r\n FOnAcceptNewValue: TJvDBAcceptValueEvent;\r\n FDefaultMask: Boolean;\r\n procedure ActiveChange(Sender: TObject);\r\n procedure DataChange(Sender: TObject);\r\n procedure EditingChange(Sender: TObject);\r\n function GetCanvas: TCanvas;\r\n function GetDataField: string;\r\n function GetDataSource: TDataSource;\r\n function GetField: TField;\r\n procedure ResetMaxLength;\r\n procedure SetDataField(const Value: string);\r\n procedure SetDataSource(Value: TDataSource);\r\n procedure SetFocused(Value: Boolean);\r\n procedure UpdateData(Sender: TObject);\r\n procedure CMGetDataLink(var Msg: TMessage); message CM_GETDATALINK;\r\n function GetReadOnly: Boolean; reintroduce;\r\n procedure SetReadOnly(Value: Boolean); reintroduce;\r\n function GetEditMask: string;\r\n procedure SetEditMask(const AValue: string);\r\n protected\r\n procedure DoEnter; override;\r\n procedure DoExit; override;\r\n procedure WMCut(var Msg: TMessage); message WM_CUT;\r\n procedure WMPaste(var Msg: TMessage); message WM_PASTE;\r\n procedure WMUndo(var Msg: TMessage); message WM_UNDO;\r\n procedure Change; override;\r\n function EditCanModify: Boolean; override;\r\n procedure KeyDown(var Key: Word; Shift: TShiftState); override;\r\n procedure KeyPress(var Key: Char); override;\r\n procedure Loaded; override;\r\n procedure Notification(AComponent: TComponent; Operation: TOperation); override;\r\n procedure Reset; override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n function ExecuteAction(Action: TBasicAction): Boolean; override;\r\n function UpdateAction(Action: TBasicAction): Boolean; override;\r\n function UseRightToLeftAlignment: Boolean; override;\r\n property Field: TField read GetField;\r\n property Canvas: TCanvas read GetCanvas;\r\n published\r\n property Alignment;\r\n property Anchors;\r\n property AutoSelect;\r\n property AutoSize;\r\n property BevelEdges;\r\n property BevelInner;\r\n property BevelOuter;\r\n property BevelKind;\r\n property BevelWidth;\r\n property BiDiMode;\r\n property BorderStyle;\r\n property CharCase;\r\n property ClickKey;\r\n property ClipboardCommands;\r\n property Color;\r\n property Constraints;\r\n property DataField: string read GetDataField write SetDataField;\r\n property DataSource: TDataSource read GetDataSource write SetDataSource;\r\n property DisabledColor;\r\n property DisabledTextColor;\r\n property DragCursor;\r\n property DragKind;\r\n property DragMode;\r\n property Enabled;\r\n property Flat;\r\n property ParentFlat;\r\n property Font;\r\n property ImeMode;\r\n property ImeName;\r\n property MaxLength;\r\n property ParentBiDiMode;\r\n property ParentColor;\r\n property ParentFont;\r\n property ParentShowHint;\r\n property PasswordChar;\r\n property PopupMenu;\r\n property ReadOnly: Boolean read GetReadOnly write SetReadOnly default False;\r\n property ShowHint;\r\n property TabOrder;\r\n property TabStop;\r\n property Visible;\r\n {Common JEDI Niceties}\r\n property BeepOnError;\r\n { designtime properties SPECIFIC to only JvDBMaskEdit: }\r\n property EditMask: string read GetEditMask write SetEditMask;\r\n property OnChange;\r\n property OnClick;\r\n property OnContextPopup;\r\n property OnDblClick;\r\n property OnDragDrop;\r\n property OnDragOver;\r\n property OnEndDock;\r\n property OnEndDrag;\r\n property OnEnter;\r\n property OnExit;\r\n property OnKeyDown;\r\n property OnKeyPress;\r\n property OnKeyUp;\r\n property OnMouseDown;\r\n property OnMouseMove;\r\n property OnMouseUp;\r\n property OnStartDock;\r\n property OnStartDrag;\r\n {new event}\r\n // This event is fired when a new value has been entered, and the Enter key is\r\n // hit, and the mask checking worked, and we are asking the user\r\n // for whether to accept the entry, or not, and if so, the end\r\n // user may also want to automatically set a flag to cause an automatic Post\r\n // after the db control does a write to the fieldlink.\r\n property OnAcceptNewValue: TJvDBAcceptValueEvent read FOnAcceptNewValue write FOnAcceptNewValue;\r\n end;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvDBComboEdit = class(TJvCustomComboEdit)\r\n private\r\n FDataLink: TFieldDataLink;\r\n FCanvas: TControlCanvas;\r\n FFocused: Boolean;\r\n procedure DataChange(Sender: TObject);\r\n procedure EditingChange(Sender: TObject);\r\n function GetCanvas: TCanvas;\r\n function GetDataField: string;\r\n function GetDataSource: TDataSource;\r\n function GetField: TField;\r\n procedure SetDataField(const Value: string);\r\n procedure SetDataSource(Value: TDataSource);\r\n procedure SetFocused(Value: Boolean);\r\n procedure UpdateData(Sender: TObject);\r\n procedure CMGetDataLink(var Msg: TMessage); message CM_GETDATALINK;\r\n procedure WMPaint(var Msg: TWMPaint); message WM_PAINT;\r\n function GetReadOnly: Boolean; reintroduce;\r\n procedure SetReadOnly(Value: Boolean); reintroduce;\r\n protected\r\n procedure DoEnter; override;\r\n procedure DoExit; override;\r\n procedure WMCut(var Msg: TMessage); message WM_CUT;\r\n procedure WMPaste(var Msg: TMessage); message WM_PASTE;\r\n procedure Change; override;\r\n function EditCanModify: Boolean; override;\r\n procedure KeyDown(var Key: Word; Shift: TShiftState); override;\r\n procedure KeyPress(var Key: Char); override;\r\n procedure Loaded; override;\r\n procedure Notification(AComponent: TComponent; Operation: TOperation); override;\r\n procedure Reset; override;\r\n property AlwaysEnableButton default True;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n function ExecuteAction(Action: TBasicAction): Boolean; override;\r\n function UpdateAction(Action: TBasicAction): Boolean; override;\r\n function UseRightToLeftAlignment: Boolean; override;\r\n property Button;\r\n property Field: TField read GetField;\r\n property Canvas: TCanvas read GetCanvas;\r\n published\r\n property AlwaysShowPopup default False;\r\n property Alignment;\r\n property Align;\r\n property Action;\r\n property AutoSelect;\r\n property AutoSize;\r\n property BeepOnError;\r\n property BevelEdges;\r\n property BevelInner;\r\n property BevelKind default bkNone;\r\n property BevelOuter;\r\n property BorderStyle;\r\n property ButtonFlat;\r\n property ButtonHint;\r\n property CharCase;\r\n property ClickKey;\r\n property Color;\r\n property DataField: string read GetDataField write SetDataField;\r\n property DataSource: TDataSource read GetDataSource write SetDataSource;\r\n property DirectInput;\r\n property DragCursor;\r\n property DragMode;\r\n property Enabled;\r\n property Flat;\r\n property ParentFlat;\r\n property Font;\r\n property Glyph;\r\n property ImageIndex;\r\n property Images;\r\n property ImageKind;\r\n property ButtonWidth;\r\n property HideSelection;\r\n property Anchors;\r\n property BiDiMode;\r\n property Constraints;\r\n property DragKind;\r\n property ParentBiDiMode;\r\n property ImeMode;\r\n property ImeName;\r\n property MaxLength;\r\n property NumGlyphs;\r\n property ParentColor;\r\n property ParentFont;\r\n property ParentShowHint;\r\n property PopupMenu;\r\n property ReadOnly: Boolean read GetReadOnly write SetReadOnly default False;\r\n property ShowHint;\r\n property TabOrder;\r\n property TabStop;\r\n property Visible;\r\n property OnButtonClick;\r\n property OnChange;\r\n property OnClick;\r\n property OnDblClick;\r\n property OnDragDrop;\r\n property OnDragOver;\r\n property OnEndDrag;\r\n property OnEnter;\r\n property OnExit;\r\n property OnKeyDown;\r\n property OnKeyPress;\r\n property OnKeyUp;\r\n property OnMouseDown;\r\n property OnMouseMove;\r\n property OnMouseUp;\r\n property OnStartDrag;\r\n property OnContextPopup;\r\n property OnEndDock;\r\n property OnStartDock;\r\n (* ++ RDB ++ *)\r\n property ClipboardCommands;\r\n property DisabledTextColor;\r\n property DisabledColor;\r\n (* -- RDB -- *)\r\n end;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvDBDateEdit = class(TJvCustomDateEdit)\r\n private\r\n FInReset: Boolean; // Polaris\r\n FDataLink: TFieldDataLink;\r\n FCanvas: TControlCanvas;\r\n procedure DataChange(Sender: TObject);\r\n procedure EditingChange(Sender: TObject);\r\n function GetCanvas: TCanvas;\r\n function GetDataField: string;\r\n function GetDataSource: TDataSource;\r\n function GetField: TField;\r\n procedure SetDataField(const Value: string);\r\n procedure SetDataSource(Value: TDataSource);\r\n procedure UpdateData(Sender: TObject);\r\n procedure AfterPopup(Sender: TObject; var Date: TDateTime; var Action: Boolean);\r\n procedure CMGetDataLink(var Msg: TMessage); message CM_GETDATALINK;\r\n procedure WMPaint(var Msg: TWMPaint); message WM_PAINT;\r\n function GetReadOnly: Boolean; reintroduce;\r\n procedure SetReadOnly(Value: Boolean); reintroduce;\r\n protected\r\n procedure DoExit; override;\r\n procedure WMCut(var Msg: TMessage); message WM_CUT;\r\n procedure WMPaste(var Msg: TMessage); message WM_PASTE;\r\n procedure AcceptValue(const Value: Variant); override;\r\n procedure ApplyDate(Value: TDateTime); override;\r\n procedure Change; override;\r\n function EditCanModify: Boolean; override;\r\n procedure KeyDown(var Key: Word; Shift: TShiftState); override;\r\n procedure KeyPress(var Key: Char); override;\r\n procedure Notification(AComponent: TComponent; Operation: TOperation); override;\r\n procedure Reset; override;\r\n function DisplayNullDateAsEmptyText: Boolean; override;\r\n // Polaris\r\n procedure SetDate(Value: TDateTime); override;\r\n function IsValidDate(Value: TDateTime): Boolean;\r\n // Polaris\r\n procedure PopupDropDown(DisableEdit: Boolean); override;\r\n property AlwaysEnableButton default True;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n procedure UpdateMask; override;\r\n function ExecuteAction(Action: TBasicAction): Boolean; override;\r\n function UpdateAction(Action: TBasicAction): Boolean; override;\r\n function UseRightToLeftAlignment: Boolean; override;\r\n property Field: TField read GetField;\r\n property Canvas: TCanvas read GetCanvas;\r\n published\r\n property AlwaysShowPopup default False;\r\n property DateAutoBetween;\r\n property MinDate;\r\n property MaxDate;\r\n property Align;\r\n property Alignment;\r\n property Action;\r\n property AutoSize;\r\n property BeepOnError;\r\n property DataField: string read GetDataField write SetDataField;\r\n property DataSource: TDataSource read GetDataSource write SetDataSource;\r\n property ReadOnly: Boolean read GetReadOnly write SetReadOnly default False;\r\n property AutoSelect;\r\n property BlanksChar;\r\n property BorderStyle;\r\n property ButtonHint;\r\n property ButtonFlat;\r\n property CalendarHints;\r\n property CheckOnExit;\r\n property ClickKey;\r\n property Color;\r\n property DefaultToday;\r\n property DialogTitle;\r\n property DirectInput;\r\n property DragCursor;\r\n property BevelEdges;\r\n property BevelInner;\r\n property BevelKind default bkNone;\r\n property BevelOuter;\r\n property BiDiMode;\r\n property DragKind;\r\n property Flat;\r\n property ParentBiDiMode;\r\n property ParentFlat;\r\n property ImeMode;\r\n property ImeName;\r\n property OnEndDock;\r\n property OnStartDock;\r\n property DragMode;\r\n property Enabled;\r\n property Font;\r\n property Glyph;\r\n property GroupIndex;\r\n property ImageIndex;\r\n property Images;\r\n property ImageKind;\r\n property NumGlyphs;\r\n property ButtonWidth;\r\n property HideSelection;\r\n property Anchors;\r\n property Constraints;\r\n property MaxLength;\r\n property ParentColor;\r\n property ParentFont;\r\n property ParentShowHint;\r\n property PopupAlign;\r\n property PopupColor;\r\n property PopupMenu;\r\n property ShowHint;\r\n property CalendarStyle;\r\n property ShowNullDate;\r\n property StartOfWeek;\r\n property Weekends;\r\n property WeekendColor;\r\n property YearDigits;\r\n property TabOrder;\r\n property TabStop;\r\n property Visible;\r\n property OnButtonClick;\r\n property OnChange;\r\n property OnClick;\r\n property OnDblClick;\r\n property OnDragDrop;\r\n property OnDragOver;\r\n property OnEndDrag;\r\n property OnEnter;\r\n property OnExit;\r\n property OnKeyPress;\r\n property OnKeyUp;\r\n property OnMouseDown;\r\n property OnMouseMove;\r\n property OnMouseUp;\r\n property OnStartDrag;\r\n property OnContextPopup;\r\n property ClipboardCommands; // RDB\r\n property DisabledTextColor; // RDB\r\n property DisabledColor; // RDB\r\n property OnKeyDown; // RDB\r\n property OnPopupHidden;\r\n property OnPopupShown;\r\n end;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvDBCalcEdit = class(TJvCalcEdit)\r\n private\r\n FDataLink: TFieldDataLink;\r\n FDefaultParams: Boolean;\r\n //Polaris\r\n FLEmptyIsNull: Boolean;\r\n FEmptyIsNull: Boolean;\r\n procedure SetEmptyIsNull(Value: Boolean);\r\n function GetZeroEmpty: Boolean;\r\n procedure SetZeroEmpty(Value: Boolean);\r\n function StoreEmptyIsNull: Boolean;\r\n //Polaris\r\n procedure DataChange(Sender: TObject);\r\n procedure EditingChange(Sender: TObject);\r\n function GetDataField: string;\r\n function GetDataSource: TDataSource;\r\n function GetField: TField;\r\n procedure SetDataField(const Value: string);\r\n procedure SetDataSource(Value: TDataSource);\r\n procedure SetDefaultParams(Value: Boolean);\r\n procedure UpdateFieldData(Sender: TObject);\r\n procedure CMGetDataLink(var Msg: TMessage); message CM_GETDATALINK;\r\n function GetReadOnly: Boolean; reintroduce;\r\n procedure SetReadOnly(Value: Boolean); reintroduce;\r\n protected\r\n procedure DoExit; override;\r\n procedure WMCut(var Msg: TMessage); message WM_CUT;\r\n procedure WMPaste(var Msg: TMessage); message WM_PASTE;\r\n procedure AcceptValue(const Value: Variant); override;\r\n function GetDisplayText: string; override;\r\n procedure Change; override;\r\n procedure SetText(const AValue: string); override;\r\n\r\n procedure DataChanged; override; //Polaris\r\n\r\n function EditCanModify: Boolean; override;\r\n function IsValidChar(Key: Char): Boolean; override;\r\n procedure KeyDown(var Key: Word; Shift: TShiftState); override;\r\n procedure KeyPress(var Key: Char); override;\r\n procedure Notification(AComponent: TComponent; Operation: TOperation); override;\r\n procedure Reset; override;\r\n procedure UpdatePopup; override;\r\n //Polaris\r\n procedure Loaded; override;\r\n //Polaris\r\n procedure PopupDropDown(DisableEdit: Boolean); override;\r\n property AlwaysEnableButton default True;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n procedure UpdateFieldParams;\r\n function ExecuteAction(Action: TBasicAction): Boolean; override;\r\n function UpdateAction(Action: TBasicAction): Boolean; override;\r\n function UseRightToLeftAlignment: Boolean; override;\r\n property Field: TField read GetField;\r\n property Value;\r\n published\r\n property AlwaysShowPopup default False;\r\n property Align;\r\n property DecimalPlaceRound;\r\n\r\n property Action;\r\n property AutoSize;\r\n property DataField: string read GetDataField write SetDataField;\r\n property DataSource: TDataSource read GetDataSource write SetDataSource;\r\n property DefaultParams: Boolean read FDefaultParams write SetDefaultParams default False;\r\n property ReadOnly: Boolean read GetReadOnly write SetReadOnly default False;\r\n property Alignment;\r\n property AutoSelect;\r\n property BeepOnError;\r\n property BorderStyle;\r\n property ButtonHint;\r\n property ButtonFlat;\r\n property CheckOnExit;\r\n property ClickKey;\r\n property Color;\r\n property DecimalPlaces;\r\n property DirectInput;\r\n property DisplayFormat;\r\n property DragCursor;\r\n property DragMode;\r\n property Enabled;\r\n property Font;\r\n property FormatOnEditing;\r\n property ImageIndex;\r\n property Images;\r\n property ImageKind;\r\n property ButtonWidth;\r\n property HideSelection;\r\n property Anchors;\r\n property BevelEdges;\r\n property BevelInner;\r\n property BevelKind default bkNone;\r\n property BevelOuter;\r\n property BiDiMode;\r\n property Constraints;\r\n property DragKind;\r\n property ParentBiDiMode;\r\n property ImeMode;\r\n property ImeName;\r\n property MaxLength;\r\n property MaxValue;\r\n property MinValue;\r\n property ParentColor;\r\n property ParentFont;\r\n property ParentShowHint;\r\n property PopupAlign;\r\n property PopupMenu;\r\n property ShowHint;\r\n property TabOrder;\r\n property TabStop;\r\n property Visible;\r\n //Polaris\r\n property EmptyIsNull: Boolean read FEmptyIsNull write SetEmptyIsNull stored StoreEmptyIsNull;\r\n property ZeroEmpty: Boolean read GetZeroEmpty write SetZeroEmpty default True;\r\n //Polaris\r\n property OnButtonClick;\r\n property OnChange;\r\n property OnClick;\r\n property OnDblClick;\r\n property OnDragDrop;\r\n property OnDragOver;\r\n property OnEndDrag;\r\n property OnEnter;\r\n property OnExit;\r\n property OnKeyDown;\r\n property OnKeyPress;\r\n property OnKeyUp;\r\n property OnMouseDown;\r\n property OnMouseMove;\r\n property OnMouseUp;\r\n property OnStartDrag;\r\n property OnContextPopup;\r\n property OnEndDock;\r\n property OnStartDock;\r\n property OnPopupHidden; // RH: Added - issue 5726\r\n property OnPopupShown; // RH: Added - issue 5726\r\n (* ++ RDB ++ *)\r\n property ClipboardCommands;\r\n property DisabledTextColor;\r\n property DisabledColor;\r\n (* -- RDB -- *)\r\n end;\r\n\r\n TGetStringEvent = function(Sender: TObject): string of object;\r\n TDataValueEvent = procedure(Sender: TObject; DataSet: TDataSet; var Value: Longint) of object;\r\n TDBLabelStyle = (lsState, lsRecordNo, lsRecordSize);\r\n TGlyphAlign = glGlyphLeft..glGlyphRight;\r\n TDBStatusKind = dsInactive..dsCalcFields;\r\n TDBLabelOptions = (doCaption, doGlyph, doBoth);\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvDBStatusLabel = class(TJvCustomLabel)\r\n private\r\n FDataSetName: string;\r\n FStyle: TDBLabelStyle;\r\n FEditColor: TColor;\r\n FCalcCount: Boolean;\r\n FCaptions: TStringList;\r\n FGlyph: TBitmap;\r\n FCell: TBitmap;\r\n FGlyphAlign: TGlyphAlign;\r\n FOnGetDataName: TGetStringEvent;\r\n FOnGetRecNo: TDataValueEvent;\r\n FOnGetRecordCount: TDataValueEvent;\r\n function GetStatusKind(State: TDataSetState): TDBStatusKind;\r\n procedure CaptionsChanged(Sender: TObject);\r\n function GetDataSetName: string;\r\n procedure SetDataSetName(Value: string);\r\n function GetDataSource: TDataSource;\r\n procedure SetDataSource(Value: TDataSource);\r\n function GetDatasetState: TDataSetState;\r\n procedure SetEditColor(Value: TColor);\r\n procedure SetStyle(Value: TDBLabelStyle);\r\n procedure SetShowOptions(Value: TDBLabelOptions);\r\n procedure SetGlyphAlign(Value: TGlyphAlign);\r\n function GetCaptions: TStrings;\r\n procedure SetCaptions(Value: TStrings);\r\n procedure SetCalcCount(Value: Boolean);\r\n protected\r\n FDataLink: TDataLink;\r\n FRecordCount: Longint;\r\n FRecordNo: Longint;\r\n FShowOptions: TDBLabelOptions;\r\n procedure Loaded; override;\r\n function GetDefaultFontColor: TColor; override;\r\n function GetLabelCaption: string; override;\r\n function GetCaption(State: TDataSetState): string; virtual;\r\n procedure Notification(AComponent: TComponent; Operation: TOperation); override;\r\n procedure Paint; override;\r\n procedure SetName(const Value: TComponentName); override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n procedure UpdateData; virtual;\r\n procedure UpdateStatus; virtual;\r\n property Caption;\r\n property DatasetState: TDataSetState read GetDatasetState;\r\n published\r\n property DataSetName: string read GetDataSetName write SetDataSetName;\r\n property DataSource: TDataSource read GetDataSource write SetDataSource;\r\n property EditColor: TColor read FEditColor write SetEditColor default clRed;\r\n property Captions: TStrings read GetCaptions write SetCaptions;\r\n property Style: TDBLabelStyle read FStyle write SetStyle default lsState;\r\n property CalcRecCount: Boolean read FCalcCount write SetCalcCount default False;\r\n property ShowOptions: TDBLabelOptions read FShowOptions write SetShowOptions default doCaption;\r\n property GlyphAlign: TGlyphAlign read FGlyphAlign write SetGlyphAlign default glGlyphLeft;\r\n property Layout default tlCenter;\r\n property ShadowSize default 0;\r\n property Align;\r\n property Alignment;\r\n property AutoSize;\r\n property Color;\r\n property DragCursor;\r\n property DragMode;\r\n property Font;\r\n property Anchors;\r\n property BiDiMode;\r\n property Constraints;\r\n property DragKind;\r\n property ParentBiDiMode;\r\n property ParentColor;\r\n property ParentFont;\r\n property ParentShowHint;\r\n property PopupMenu;\r\n property ShadowColor;\r\n property ShadowPos;\r\n property ShowHint;\r\n property Transparent;\r\n property Visible;\r\n property WordWrap;\r\n property OnGetDataName: TGetStringEvent read FOnGetDataName write FOnGetDataName;\r\n property OnGetRecordCount: TDataValueEvent read FOnGetRecordCount write FOnGetRecordCount;\r\n property OnGetRecNo: TDataValueEvent read FOnGetRecNo write FOnGetRecNo;\r\n property OnClick;\r\n property OnDblClick;\r\n property OnDragDrop;\r\n property OnDragOver;\r\n property OnEndDrag;\r\n property OnMouseDown;\r\n property OnMouseMove;\r\n property OnMouseUp;\r\n property OnMouseEnter;\r\n property OnMouseLeave;\r\n property OnStartDrag;\r\n property OnContextPopup;\r\n property OnEndDock;\r\n property OnStartDock;\r\n end;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvDBNavigator = class(TDBNavigator)\r\n private\r\n FTransparent: Boolean;\r\n procedure SetTransparent(Value: Boolean);\r\n protected\r\n procedure Paint; override;\r\n procedure WMEraseBkgnd(var Msg: TWMEraseBkgnd); message WM_ERASEBKGND;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n published\r\n property Transparent: Boolean read FTransparent write SetTransparent default True;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvDBControls.pas $';\r\n Revision: '$Revision: 13329 $';\r\n Date: '$Date: 2012-06-12 16:28:33 +0200 (mar. 12 juin 2012) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n FMTBcd,\r\n Variants, SysUtils, Math, Forms,\r\n JvJCLUtils, JvJVCLUtils, JvCalc, JvTypes, JvConsts, JvResources, JclSysUtils;\r\n\r\n{$R JvDBControls.res}\r\n\r\nfunction IsNullOrEmptyStringField(Field: TField): Boolean;\r\nbegin\r\n Result := Field.IsNull or ((Field is TStringField) and (Trim(Field.AsString) = ''));\r\nend;\r\n\r\n//=== { TJvDBMaskEdit } ======================================================\r\n\r\nconstructor TJvDBMaskEdit.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n ControlStyle := ControlStyle + [csReplicatable];\r\n FCanvas := TControlCanvas.Create;\r\n FCanvas.Control := Self;\r\n FDataLink := TFieldDataLink.Create;\r\n FDataLink.Control := Self;\r\n FDataLink.OnDataChange := DataChange;\r\n FDataLink.OnEditingChange := EditingChange;\r\n FDataLink.OnUpdateData := UpdateData;\r\n FDataLink.OnActiveChange := ActiveChange;\r\n // new stuff that isn't in the VCL version.\r\n inherited ReadOnly := True;\r\nend;\r\n\r\ndestructor TJvDBMaskEdit.Destroy;\r\nbegin\r\n FDataLink.Free;\r\n FDataLink := nil;\r\n inherited Destroy;\r\n // (rom) destroy Canvas AFTER inherited Destroy\r\n FCanvas.Free;\r\nend;\r\n\r\nprocedure TJvDBMaskEdit.Loaded;\r\nbegin\r\n inherited Loaded;\r\n FDefaultMask := (inherited EditMask = '');\r\n ResetMaxLength;\r\n if csDesigning in ComponentState then\r\n DataChange(Self);\r\nend;\r\n\r\nprocedure TJvDBMaskEdit.ResetMaxLength;\r\nvar\r\n F: TField;\r\nbegin\r\n if (MaxLength > 0) and Assigned(DataSource) and Assigned(DataSource.DataSet) then\r\n begin\r\n F := DataSource.DataSet.FindField(DataField);\r\n if Assigned(F) and (F.DataType in [ftString, ftWideString]) and (F.Size = MaxLength) then\r\n MaxLength := 0;\r\n end;\r\nend;\r\n\r\nprocedure TJvDBMaskEdit.Notification(AComponent: TComponent;\r\n Operation: TOperation);\r\nbegin\r\n inherited Notification(AComponent, Operation);\r\n if (Operation = opRemove) and (FDataLink <> nil) and\r\n (AComponent = DataSource) then\r\n DataSource := nil;\r\nend;\r\n\r\nfunction TJvDBMaskEdit.UseRightToLeftAlignment: Boolean;\r\nbegin\r\n Result := DBUseRightToLeftAlignment(Self, Field);\r\nend;\r\n\r\nprocedure TJvDBMaskEdit.KeyDown(var Key: Word; Shift: TShiftState);\r\nbegin\r\n inherited KeyDown(Key, Shift);\r\n if ((Key = VK_DELETE) and (Shift * KeyboardShiftStates = [])) or\r\n ((Key = VK_INSERT) and (Shift * KeyboardShiftStates = [ssShift])) then\r\n FDataLink.Edit;\r\nend;\r\n\r\nprocedure TJvDBMaskEdit.KeyPress(var Key: Char);\r\nbegin\r\n inherited KeyPress(Key);\r\n if CharInSet(Key, [#32..#255]) and (FDataLink.Field <> nil) and\r\n not FDataLink.Field.IsValidChar(Key) then\r\n begin\r\n DoBeepOnError;\r\n Key := #0;\r\n end;\r\n case Key of\r\n CtrlH, CtrlV, CtrlX, #32..#255:\r\n FDataLink.Edit;\r\n Esc:\r\n begin\r\n FDataLink.Reset;\r\n SelectAll;\r\n Key := #0;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJvDBMaskEdit.EditCanModify: Boolean;\r\nbegin\r\n Result := FDataLink.Edit;\r\nend;\r\n\r\nprocedure TJvDBMaskEdit.Reset;\r\nbegin\r\n FDataLink.Reset;\r\n SelectAll;\r\nend;\r\n\r\nprocedure TJvDBMaskEdit.SetFocused(Value: Boolean);\r\nbegin\r\n if FFocused <> Value then\r\n begin\r\n FFocused := Value;\r\n if (Alignment <> taLeftJustify) and not IsMasked then\r\n Invalidate;\r\n FDataLink.Reset;\r\n end;\r\nend;\r\n\r\nprocedure TJvDBMaskEdit.Change;\r\nbegin\r\n FDataLink.Modified;\r\n inherited Change;\r\nend;\r\n\r\nfunction TJvDBMaskEdit.GetDataSource: TDataSource;\r\nbegin\r\n Result := FDataLink.DataSource;\r\nend;\r\n\r\nprocedure TJvDBMaskEdit.SetDataSource(Value: TDataSource);\r\nbegin\r\n if not (FDataLink.DataSourceFixed and (csLoading in ComponentState)) then\r\n begin\r\n if FDataLink.DataSource <> nil then\r\n FDataLink.DataSource.RemoveFreeNotification(Self);\r\n FDataLink.DataSource := Value;\r\n end;\r\n if Value <> nil then\r\n Value.FreeNotification(Self);\r\nend;\r\n\r\nfunction TJvDBMaskEdit.GetDataField: string;\r\nbegin\r\n Result := FDataLink.FieldName;\r\nend;\r\n\r\nprocedure TJvDBMaskEdit.SetDataField(const Value: string);\r\nbegin\r\n if not (csDesigning in ComponentState) then\r\n ResetMaxLength;\r\n FDataLink.FieldName := Value;\r\nend;\r\n\r\nfunction TJvDBMaskEdit.GetCanvas: TCanvas;\r\nbegin\r\n Result := FCanvas;\r\nend;\r\n\r\nfunction TJvDBMaskEdit.GetReadOnly: Boolean;\r\nbegin\r\n Result := FDataLink.ReadOnly;\r\nend;\r\n\r\nprocedure TJvDBMaskEdit.SetReadOnly(Value: Boolean);\r\nbegin\r\n FDataLink.ReadOnly := Value;\r\nend;\r\n\r\nfunction TJvDBMaskEdit.GetEditMask: string;\r\nbegin\r\n if FDefaultMask then\r\n Result := ''\r\n else\r\n Result := inherited EditMask;\r\nend;\r\n\r\nprocedure TJvDBMaskEdit.SetEditMask(const AValue: string);\r\nbegin\r\n inherited EditMask := AValue;\r\n FDefaultMask := False;\r\nend;\r\n\r\nfunction TJvDBMaskEdit.GetField: TField;\r\nbegin\r\n Result := FDataLink.Field;\r\nend;\r\n\r\nprocedure TJvDBMaskEdit.ActiveChange(Sender: TObject);\r\nbegin\r\n ResetMaxLength;\r\nend;\r\n\r\nprocedure TJvDBMaskEdit.DataChange(Sender: TObject);\r\nbegin\r\n if FDataLink.Field <> nil then\r\n begin\r\n if Alignment <> FDataLink.Field.Alignment then\r\n begin\r\n EditText := ''; {forces update}\r\n Alignment := FDataLink.Field.Alignment;\r\n end;\r\n if EditMask = '' then\r\n begin\r\n inherited EditMask := FDataLink.Field.EditMask;\r\n FDefaultMask := True;\r\n end;\r\n if not (csDesigning in ComponentState) then\r\n if (FDataLink.Field.DataType in [ftString, ftWideString]) and (MaxLength = 0) then\r\n MaxLength := FDataLink.Field.Size;\r\n if FFocused and FDataLink.CanModify then\r\n Text := FDataLink.Field.Text\r\n else\r\n begin\r\n EditText := FDataLink.Field.DisplayText;\r\n if FDataLink.Editing {and FDataLink.FModified XXX } then\r\n Modified := True;\r\n end;\r\n end\r\n else\r\n begin\r\n Alignment := taLeftJustify;\r\n //EditMask := '';\r\n if csDesigning in ComponentState then\r\n EditText := Name\r\n else\r\n EditText := '';\r\n end;\r\nend;\r\n\r\nprocedure TJvDBMaskEdit.EditingChange(Sender: TObject);\r\nbegin\r\n inherited ReadOnly := not FDataLink.Editing;\r\nend;\r\n\r\nprocedure TJvDBMaskEdit.UpdateData(Sender: TObject);\r\nvar\r\n OrgDefaultMask: Boolean;\r\n OrgMask: string;\r\nbegin\r\n ValidateEdit;\r\n if IsMasked then\r\n begin\r\n OrgDefaultMask := FDefaultMask;\r\n OrgMask := inherited EditMask;\r\n try\r\n EditMask := '';\r\n if Text = '' then\r\n begin\r\n FDataLink.Field.Clear;\r\n Exit;\r\n end;\r\n finally\r\n FDefaultMask := OrgDefaultMask;\r\n EditMask := OrgMask;\r\n end;\r\n end;\r\n FDataLink.Field.Text := Text;\r\nend;\r\n\r\nprocedure TJvDBMaskEdit.WMUndo(var Msg: TMessage);\r\nbegin\r\n FDataLink.Edit;\r\n inherited;\r\nend;\r\n\r\nprocedure TJvDBMaskEdit.WMPaste(var Msg: TMessage);\r\nbegin\r\n FDataLink.Edit;\r\n inherited;\r\nend;\r\n\r\nprocedure TJvDBMaskEdit.WMCut(var Msg: TMessage);\r\nbegin\r\n FDataLink.Edit;\r\n inherited;\r\nend;\r\n\r\nprocedure TJvDBMaskEdit.DoEnter;\r\nbegin\r\n FOriginalValue := Self.Text;\r\n SetFocused(True);\r\n inherited DoEnter;\r\n if SysLocale.FarEast and FDataLink.CanModify then\r\n inherited ReadOnly := False;\r\nend;\r\n\r\nprocedure TJvDBMaskEdit.DoExit;\r\nvar\r\n NewValue: string;\r\n Accept, Post: Boolean;\r\nbegin\r\n Accept := True;\r\n Post := False;\r\n NewValue := Text;\r\n // When we hit enter, check if there was a change, and if so,\r\n // we can fire the confirmation event.\r\n if FOriginalValue <> NewValue then\r\n if Assigned(FOnAcceptNewValue) then\r\n begin\r\n FOnAcceptNewValue(Self, FOriginalValue, NewValue, Accept, Post);\r\n if not Accept then\r\n Text := FOriginalValue;\r\n end;\r\n try\r\n if Accept then\r\n FDataLink.UpdateRecord;\r\n except\r\n SelectAll;\r\n SetFocus;\r\n raise;\r\n end;\r\n SetFocused(False);\r\n CheckCursor;\r\n if Accept then\r\n inherited DoExit;\r\n\r\n { A nifty little way to keep simple database applications happy.\r\n Just set POST flag in your validation, and the dataset is updated.\r\n If you don't like this feature, just DON'T set Post to true, it\r\n defaults to false.\r\n }\r\n if (Accept and Post) and (Assigned(DataSource)) then\r\n if Assigned(DataSource.DataSet) and (DataSource.DataSet.Active) then\r\n if DataSource.DataSet.State = dsEdit then\r\n DataSource.DataSet.Post;\r\nend;\r\n\r\nprocedure TJvDBMaskEdit.CMGetDataLink(var Msg: TMessage);\r\nbegin\r\n Msg.Result := LRESULT(FDataLink);\r\nend;\r\n\r\nfunction TJvDBMaskEdit.ExecuteAction(Action: TBasicAction): Boolean;\r\nbegin\r\n Result := inherited ExecuteAction(Action) or (FDataLink <> nil) and\r\n FDataLink.ExecuteAction(Action);\r\nend;\r\n\r\nfunction TJvDBMaskEdit.UpdateAction(Action: TBasicAction): Boolean;\r\nbegin\r\n Result := inherited UpdateAction(Action) or (FDataLink <> nil) and\r\n FDataLink.UpdateAction(Action);\r\nend;\r\n\r\n//=== { TJvDBComboEdit } =====================================================\r\n\r\nprocedure ResetMaxLength(DBEdit: TJvDBComboEdit);\r\nvar\r\n F: TField;\r\nbegin\r\n with DBEdit do\r\n if (MaxLength > 0) and (DataSource <> nil) and\r\n (DataSource.DataSet <> nil) then\r\n begin\r\n F := DataSource.DataSet.FindField(DataField);\r\n if Assigned(F) and (F.DataType = ftString) and\r\n (F.Size = MaxLength) then\r\n MaxLength := 0;\r\n end;\r\nend;\r\n\r\nconstructor TJvDBComboEdit.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n ControlStyle := ControlStyle + [csReplicatable];\r\n FCanvas := TControlCanvas.Create;\r\n FCanvas.Control := Self;\r\n FDataLink := TFieldDataLink.Create;\r\n FDataLink.Control := Self;\r\n FDataLink.OnDataChange := DataChange;\r\n FDataLink.OnEditingChange := EditingChange;\r\n FDataLink.OnUpdateData := UpdateData;\r\n inherited ReadOnly := True;\r\n AlwaysEnableButton := True;\r\n AlwaysShowPopup := False;\r\nend;\r\n\r\ndestructor TJvDBComboEdit.Destroy;\r\nbegin\r\n FDataLink.Free;\r\n FDataLink := nil;\r\n inherited Destroy;\r\n // (rom) destroy Canvas AFTER inherited Destroy\r\n FCanvas.Free;\r\nend;\r\n\r\nprocedure TJvDBComboEdit.Loaded;\r\nbegin\r\n inherited Loaded;\r\n ResetMaxLength(Self);\r\n if csDesigning in ComponentState then\r\n DataChange(Self);\r\nend;\r\n\r\nprocedure TJvDBComboEdit.Notification(AComponent: TComponent;\r\n Operation: TOperation);\r\nbegin\r\n inherited Notification(AComponent, Operation);\r\n if (Operation = opRemove) and (FDataLink <> nil) and (AComponent = DataSource) then\r\n DataSource := nil;\r\nend;\r\n\r\nprocedure TJvDBComboEdit.KeyDown(var Key: Word; Shift: TShiftState);\r\nbegin\r\n inherited KeyDown(Key, Shift);\r\n if ((Key = VK_DELETE) and (Shift * KeyboardShiftStates = [])) or\r\n ((Key = VK_INSERT) and (Shift * KeyboardShiftStates = [ssShift])) then\r\n FDataLink.Edit;\r\nend;\r\n\r\nprocedure TJvDBComboEdit.KeyPress(var Key: Char);\r\nbegin\r\n inherited KeyPress(Key);\r\n if CharInSet(Key, [#32..#255]) and (FDataLink.Field <> nil) and\r\n not FDataLink.Field.IsValidChar(Key) then\r\n begin\r\n DoBeepOnError;\r\n Key := #0;\r\n end;\r\n case Key of\r\n CtrlH, CtrlV, CtrlX, #32..#255:\r\n FDataLink.Edit;\r\n Esc:\r\n begin\r\n FDataLink.Reset;\r\n SelectAll;\r\n Key := #0;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJvDBComboEdit.EditCanModify: Boolean;\r\nbegin\r\n Result := FDataLink.Edit;\r\nend;\r\n\r\nprocedure TJvDBComboEdit.Reset;\r\nbegin\r\n FDataLink.Reset;\r\n SelectAll;\r\nend;\r\n\r\nprocedure TJvDBComboEdit.SetFocused(Value: Boolean);\r\nbegin\r\n if FFocused <> Value then\r\n begin\r\n FFocused := Value;\r\n if (Alignment <> taLeftJustify) and not IsMasked then\r\n Invalidate;\r\n FDataLink.Reset;\r\n end;\r\nend;\r\n\r\nprocedure TJvDBComboEdit.Change;\r\nbegin\r\n FDataLink.Modified;\r\n inherited Change;\r\nend;\r\n\r\nfunction TJvDBComboEdit.GetCanvas: TCanvas;\r\nbegin\r\n Result := FCanvas;\r\nend;\r\n\r\nfunction TJvDBComboEdit.GetDataSource: TDataSource;\r\nbegin\r\n Result := FDataLink.DataSource;\r\nend;\r\n\r\nprocedure TJvDBComboEdit.SetDataSource(Value: TDataSource);\r\nbegin\r\n if not (FDataLink.DataSourceFixed and (csLoading in ComponentState)) then\r\n begin\r\n if FDataLink.DataSource <> nil then\r\n FDataLink.DataSource.RemoveFreeNotification(Self);\r\n FDataLink.DataSource := Value;\r\n end;\r\n if Value <> nil then\r\n Value.FreeNotification(Self);\r\nend;\r\n\r\nfunction TJvDBComboEdit.GetDataField: string;\r\nbegin\r\n Result := FDataLink.FieldName;\r\nend;\r\n\r\nprocedure TJvDBComboEdit.SetDataField(const Value: string);\r\nbegin\r\n if not (csDesigning in ComponentState) then\r\n ResetMaxLength(Self);\r\n FDataLink.FieldName := Value;\r\nend;\r\n\r\nfunction TJvDBComboEdit.GetReadOnly: Boolean;\r\nbegin\r\n if FDataLink <> nil then\r\n Result := FDataLink.ReadOnly\r\n else\r\n Result := True;\r\nend;\r\n\r\nprocedure TJvDBComboEdit.SetReadOnly(Value: Boolean);\r\nbegin\r\n if FDataLink <> nil then\r\n FDataLink.ReadOnly := Value;\r\nend;\r\n\r\nfunction TJvDBComboEdit.GetField: TField;\r\nbegin\r\n Result := FDataLink.Field;\r\nend;\r\n\r\nprocedure TJvDBComboEdit.DataChange(Sender: TObject);\r\nbegin\r\n if FDataLink.Field <> nil then\r\n begin\r\n if Alignment <> FDataLink.Field.Alignment then\r\n begin\r\n EditText := ''; {forces update}\r\n Alignment := FDataLink.Field.Alignment;\r\n end;\r\n EditMask := FDataLink.Field.EditMask;\r\n if not (csDesigning in ComponentState) then\r\n if (FDataLink.Field.DataType = ftString) and (MaxLength = 0) then\r\n MaxLength := FDataLink.Field.Size;\r\n if FFocused and FDataLink.CanModify then\r\n Text := FDataLink.Field.Text\r\n else\r\n begin\r\n EditText := FDataLink.Field.DisplayText;\r\n {if FDataLink.Editing then Modified := True;}\r\n end;\r\n end\r\n else\r\n begin\r\n Alignment := taLeftJustify;\r\n EditMask := '';\r\n if csDesigning in ComponentState then\r\n EditText := Name\r\n else\r\n EditText := '';\r\n end;\r\nend;\r\n\r\nprocedure TJvDBComboEdit.EditingChange(Sender: TObject);\r\nbegin\r\n inherited ReadOnly := not FDataLink.Editing;\r\nend;\r\n\r\nprocedure TJvDBComboEdit.UpdateData(Sender: TObject);\r\nbegin\r\n ValidateEdit;\r\n FDataLink.Field.Text := Text;\r\nend;\r\n\r\nprocedure TJvDBComboEdit.WMPaste(var Msg: TMessage);\r\nbegin\r\n FDataLink.Edit;\r\n inherited;\r\nend;\r\n\r\nprocedure TJvDBComboEdit.WMCut(var Msg: TMessage);\r\nbegin\r\n FDataLink.Edit;\r\n inherited;\r\nend;\r\n\r\nprocedure TJvDBComboEdit.DoEnter;\r\nbegin\r\n SetFocused(True);\r\n inherited DoEnter;\r\n if SysLocale.FarEast and FDataLink.CanModify then\r\n inherited ReadOnly := False;\r\nend;\r\n\r\nprocedure TJvDBComboEdit.DoExit;\r\nbegin\r\n try\r\n FDataLink.UpdateRecord;\r\n except\r\n SelectAll;\r\n if CanFocus then\r\n SetFocus;\r\n raise;\r\n end;\r\n SetFocused(False);\r\n CheckCursor;\r\n inherited DoExit;\r\nend;\r\n\r\nprocedure TJvDBComboEdit.WMPaint(var Msg: TWMPaint);\r\nvar\r\n S: string;\r\nbegin\r\n if csDestroying in ComponentState then\r\n Exit;\r\n if (csPaintCopy in ControlState) and (FDataLink.Field <> nil) then\r\n begin\r\n S := FDataLink.Field.DisplayText;\r\n case CharCase of\r\n ecUpperCase:\r\n S := AnsiUpperCase(S);\r\n ecLowerCase:\r\n S := AnsiLowerCase(S);\r\n end;\r\n end\r\n else\r\n S := EditText;\r\n if not PaintComboEdit(Self, S, Alignment, True, FCanvas, Msg) then\r\n inherited;\r\nend;\r\n\r\nprocedure TJvDBComboEdit.CMGetDataLink(var Msg: TMessage);\r\nbegin\r\n Msg.Result := LRESULT(FDataLink);\r\nend;\r\n\r\nfunction TJvDBComboEdit.UseRightToLeftAlignment: Boolean;\r\nbegin\r\n Result := DBUseRightToLeftAlignment(Self, Field);\r\nend;\r\n\r\nfunction TJvDBComboEdit.ExecuteAction(Action: TBasicAction): Boolean;\r\nbegin\r\n Result := inherited ExecuteAction(Action) or (FDataLink <> nil) and\r\n FDataLink.ExecuteAction(Action);\r\nend;\r\n\r\nfunction TJvDBComboEdit.UpdateAction(Action: TBasicAction): Boolean;\r\nbegin\r\n Result := inherited UpdateAction(Action) or (FDataLink <> nil) and\r\n FDataLink.UpdateAction(Action);\r\nend;\r\n\r\n//=== { TJvDBDateEdit } ======================================================\r\n\r\nconstructor TJvDBDateEdit.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n ControlStyle := ControlStyle + [csReplicatable];\r\n FCanvas := TControlCanvas.Create;\r\n FCanvas.Control := Self;\r\n FInReset := False; // Polaris\r\n FDataLink := TFieldDataLink.Create;\r\n FDataLink.Control := Self;\r\n FDataLink.OnDataChange := DataChange;\r\n FDataLink.OnEditingChange := EditingChange;\r\n FDataLink.OnUpdateData := UpdateData;\r\n Self.OnAcceptDate := AfterPopup;\r\n AlwaysEnableButton := True;\r\n AlwaysShowPopup := False;\r\n inherited ReadOnly := True;\r\n UpdateMask;\r\nend;\r\n\r\ndestructor TJvDBDateEdit.Destroy;\r\nbegin\r\n FDataLink.Free;\r\n FDataLink := nil;\r\n inherited Destroy;\r\n // (rom) destroy Canvas AFTER inherited Destroy\r\n FCanvas.Free;\r\nend;\r\n\r\nfunction TJvDBDateEdit.DisplayNullDateAsEmptyText: Boolean;\r\nbegin\r\n Result := inherited DisplayNullDateAsEmptyText;\r\n \r\n if FDataLink.Field <> nil then\r\n if FDataLink.Field.IsNull then\r\n Result := True;\r\nend;\r\n\r\nprocedure TJvDBDateEdit.AfterPopup(Sender: TObject; var Date: TDateTime;\r\n var Action: Boolean);\r\nbegin\r\n Action := Action and (DataSource <> nil) and (DataSource.DataSet <> nil) and\r\n DataSource.DataSet.CanModify;\r\n if Action then\r\n Action := EditCanModify;\r\nend;\r\n\r\nprocedure TJvDBDateEdit.Notification(AComponent: TComponent;\r\n Operation: TOperation);\r\nbegin\r\n inherited Notification(AComponent, Operation);\r\n if (Operation = opRemove) and (FDataLink <> nil) and\r\n (AComponent = DataSource) then\r\n DataSource := nil;\r\nend;\r\n\r\nprocedure TJvDBDateEdit.KeyDown(var Key: Word; Shift: TShiftState);\r\nbegin\r\n inherited KeyDown(Key, Shift);\r\n if not ReadOnly and\r\n ((Key = VK_DELETE) and (Shift * KeyboardShiftStates = [])) or\r\n ((Key = VK_INSERT) and (Shift * KeyboardShiftStates = [ssShift])) then\r\n FDataLink.Edit;\r\nend;\r\n\r\nprocedure TJvDBDateEdit.KeyPress(var Key: Char);\r\nbegin\r\n inherited KeyPress(Key);\r\n if CharInSet(Key, [#32..#255]) and (FDataLink.Field <> nil) and\r\n not CharInSet(Key, DigitChars) and (Key <> JclFormatSettings.DateSeparator) then\r\n begin\r\n DoBeepOnError;\r\n Key := #0;\r\n end;\r\n case Key of\r\n CtrlH, CtrlV, CtrlX, '0'..'9':\r\n FDataLink.Edit;\r\n Esc:\r\n begin\r\n Reset;\r\n Key := #0;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJvDBDateEdit.EditCanModify: Boolean;\r\nbegin\r\n Result := FDataLink.Edit;\r\nend;\r\n\r\nprocedure TJvDBDateEdit.Reset;\r\nbegin\r\n FInReset := True; // Polaris\r\n try\r\n FDataLink.Reset;\r\n SelectAll;\r\n finally\r\n FInReset := False; // Polaris\r\n end;\r\nend;\r\n\r\n// Polaris begin\r\n\r\nfunction TJvDBDateEdit.IsValidDate(Value: TDateTime): Boolean;\r\nbegin\r\n Result := FDateAutoBetween;\r\n if not Result then\r\n if not FInReset and FDataLink.Editing then\r\n try\r\n if Value <> NullDate then\r\n begin\r\n if (MinDate <> NullDate) and (MaxDate <> NullDate) and\r\n ((Value < MinDate) or (Value > MaxDate)) then\r\n raise EJVCLException.CreateResFmt(@RsEDateOutOfRange, [FormatDateTime(GetDateFormat, Value),\r\n FormatDateTime(GetDateFormat, MinDate), FormatDateTime(GetDateFormat, MaxDate)])\r\n else\r\n if (MinDate <> NullDate) and (Value < MinDate) then\r\n raise EJVCLException.CreateResFmt(@RsEDateOutOfMin, [FormatDateTime(GetDateFormat, Value),\r\n FormatDateTime(GetDateFormat, MinDate)])\r\n else\r\n if (MaxDate <> NullDate) and (Value > MaxDate) then\r\n raise EJVCLException.CreateResFmt(@RsEDateOutOfMax, [FormatDateTime(GetDateFormat, Value),\r\n FormatDateTime(GetDateFormat, MaxDate)]);\r\n end;\r\n Result := True;\r\n except\r\n Reset;\r\n raise;\r\n end;\r\nend;\r\n\r\nprocedure TJvDBDateEdit.SetDate(Value: TDateTime);\r\nbegin\r\n IsValidDate(Value);\r\n inherited SetDate(Value);\r\nend;\r\n\r\n// Polaris end\r\n\r\nprocedure TJvDBDateEdit.Change;\r\nbegin\r\n if not Formatting then\r\n FDataLink.Modified;\r\n inherited Change;\r\nend;\r\n\r\nprocedure TJvDBDateEdit.PopupDropDown(DisableEdit: Boolean);\r\nbegin\r\n {if not ReadOnly then} // checked in FDataLink.Edit via CanModify\r\n if AlwaysShowPopup or FDataLink.Edit then\r\n inherited PopupDropDown(DisableEdit);\r\nend;\r\n\r\nfunction TJvDBDateEdit.GetCanvas: TCanvas;\r\nbegin\r\n Result := FCanvas;\r\nend;\r\n\r\nfunction TJvDBDateEdit.GetDataSource: TDataSource;\r\nbegin\r\n Result := FDataLink.DataSource;\r\nend;\r\n\r\nprocedure TJvDBDateEdit.SetDataSource(Value: TDataSource);\r\nbegin\r\n if not (FDataLink.DataSourceFixed and (csLoading in ComponentState)) then\r\n begin\r\n if FDataLink.DataSource <> nil then\r\n FDataLink.DataSource.RemoveFreeNotification(Self);\r\n FDataLink.DataSource := Value;\r\n end;\r\n if Value <> nil then\r\n Value.FreeNotification(Self);\r\nend;\r\n\r\nfunction TJvDBDateEdit.GetDataField: string;\r\nbegin\r\n Result := FDataLink.FieldName;\r\nend;\r\n\r\nprocedure TJvDBDateEdit.SetDataField(const Value: string);\r\nbegin\r\n FDataLink.FieldName := Value;\r\nend;\r\n\r\nfunction TJvDBDateEdit.GetReadOnly: Boolean;\r\nbegin\r\n Result := FDataLink.ReadOnly;\r\nend;\r\n\r\nprocedure TJvDBDateEdit.SetReadOnly(Value: Boolean);\r\nbegin\r\n FDataLink.ReadOnly := Value;\r\nend;\r\n\r\nfunction TJvDBDateEdit.GetField: TField;\r\nbegin\r\n Result := FDataLink.Field;\r\nend;\r\n\r\nprocedure TJvDBDateEdit.UpdateMask;\r\nbegin\r\n UpdateFormat;\r\n UpdatePopup;\r\n DataChange(nil);\r\nend;\r\n\r\nprocedure TJvDBDateEdit.DataChange(Sender: TObject);\r\nbegin\r\n if FDataLink.Field <> nil then\r\n begin\r\n EditMask := GetDateMask;\r\n if IsNullOrEmptyStringField(FDataLink.Field) then\r\n inherited SetDate(NullDate)\r\n else\r\n inherited SetDate(FDataLink.Field.AsDateTime);\r\n end\r\n else\r\n begin\r\n if csDesigning in ComponentState then\r\n begin\r\n EditMask := '';\r\n EditText := Name;\r\n end\r\n else\r\n begin\r\n EditMask := GetDateMask;\r\n if DefaultToday then\r\n Date := SysUtils.Date\r\n else\r\n Date := NullDate;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvDBDateEdit.EditingChange(Sender: TObject);\r\nbegin\r\n inherited ReadOnly := not FDataLink.Editing;\r\n if FDataLink.Editing and DefaultToday and (FDataLink.Field <> nil) and\r\n (IsNullOrEmptyStringField(FDataLink.Field) or (FDataLink.Field.AsDateTime = NullDate)) then\r\n FDataLink.Field.AsDateTime := SysUtils.Now;\r\nend;\r\n\r\nprocedure TJvDBDateEdit.UpdateData(Sender: TObject);\r\nvar\r\n D: TDateTime;\r\nbegin\r\n ValidateEdit;\r\n D := Self.Date;\r\n if D <> NullDate then\r\n begin\r\n if Int(FDataLink.Field.AsDateTime) <> D then\r\n FDataLink.Field.AsDateTime := D + Frac(FDataLink.Field.AsDateTime);\r\n end\r\n else\r\n FDataLink.Field.Clear;\r\nend;\r\n\r\nprocedure TJvDBDateEdit.CMGetDataLink(var Msg: TMessage);\r\nbegin\r\n Msg.Result := LRESULT(FDataLink);\r\nend;\r\n\r\nprocedure TJvDBDateEdit.WMPaint(var Msg: TWMPaint);\r\nvar\r\n S: string;\r\nbegin\r\n if csDestroying in ComponentState then\r\n Exit;\r\n if (csPaintCopy in ControlState) and (FDataLink.Field <> nil) then\r\n begin\r\n if FDataLink.Field.IsNull then\r\n begin\r\n S := GetDateFormat;\r\n S := ReplaceStr(ReplaceStr(ReplaceStr(ReplaceStr(S, '/', JclFormatSettings.DateSeparator),\r\n 'Y', ' '), 'M', ' '), 'D', ' ');\r\n end\r\n else\r\n S := FormatDateTime(GetDateFormat, FDataLink.Field.AsDateTime);\r\n end\r\n else\r\n S := EditText;\r\n if not PaintComboEdit(Self, S, Alignment, True, FCanvas, Msg) then\r\n inherited;\r\nend;\r\n\r\nprocedure TJvDBDateEdit.AcceptValue(const Value: Variant);\r\nbegin\r\n if VarIsNullEmpty(Value) then\r\n FDataLink.Field.Clear\r\n else\r\n FDataLink.Field.AsDateTime :=\r\n VarToDateTime(Value) + Frac(FDataLink.Field.AsDateTime);\r\n DoChange;\r\nend;\r\n\r\nprocedure TJvDBDateEdit.ApplyDate(Value: TDateTime);\r\nbegin\r\n FDataLink.Edit;\r\n inherited ApplyDate(Value);\r\nend;\r\n\r\nprocedure TJvDBDateEdit.WMPaste(var Msg: TMessage);\r\nbegin\r\n FDataLink.Edit;\r\n inherited;\r\nend;\r\n\r\nprocedure TJvDBDateEdit.WMCut(var Msg: TMessage);\r\nbegin\r\n FDataLink.Edit;\r\n inherited;\r\nend;\r\n\r\nprocedure TJvDBDateEdit.DoExit;\r\nbegin\r\n try\r\n if not (csDesigning in ComponentState) and CheckOnExit then\r\n CheckValidDate;\r\n FDataLink.UpdateRecord;\r\n except\r\n SelectAll;\r\n if CanFocus then\r\n SetFocus;\r\n raise;\r\n end;\r\n CheckCursor;\r\n inherited DoExit;\r\nend;\r\n\r\nfunction TJvDBDateEdit.UseRightToLeftAlignment: Boolean;\r\nbegin\r\n Result := DBUseRightToLeftAlignment(Self, Field);\r\nend;\r\n\r\nfunction TJvDBDateEdit.ExecuteAction(Action: TBasicAction): Boolean;\r\nbegin\r\n Result := inherited ExecuteAction(Action) or (FDataLink <> nil) and\r\n FDataLink.ExecuteAction(Action);\r\nend;\r\n\r\nfunction TJvDBDateEdit.UpdateAction(Action: TBasicAction): Boolean;\r\nbegin\r\n Result := inherited UpdateAction(Action) or (FDataLink <> nil) and\r\n FDataLink.UpdateAction(Action);\r\nend;\r\n\r\n//Polaris\r\n\r\n//=== { TJvDBCalcEdit } ======================================================\r\n\r\nconstructor TJvDBCalcEdit.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n ControlStyle := ControlStyle + [csReplicatable];\r\n //Polaris\r\n FEmptyIsNull := ZeroEmpty;\r\n FLEmptyIsNull := True;\r\n //Polaris\r\n FDataLink := TFieldDataLink.Create;\r\n FDataLink.Control := Self;\r\n FDataLink.OnDataChange := DataChange;\r\n FDataLink.OnEditingChange := EditingChange;\r\n FDataLink.OnUpdateData := UpdateFieldData;\r\n inherited ReadOnly := True;\r\n AlwaysShowPopup := False;\r\n AlwaysEnableButton := True;\r\nend;\r\n\r\ndestructor TJvDBCalcEdit.Destroy;\r\nbegin\r\n FDataLink.Free;\r\n FDataLink := nil;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvDBCalcEdit.Loaded;\r\nbegin\r\n inherited Loaded;\r\n FLEmptyIsNull := True;\r\nend;\r\n\r\nprocedure TJvDBCalcEdit.SetEmptyIsNull(Value: Boolean);\r\nbegin\r\n if Value <> FEmptyIsNull then\r\n begin\r\n FEmptyIsNull := Value;\r\n if csLoading in ComponentState then\r\n FLEmptyIsNull := False;\r\n end;\r\nend;\r\n\r\nfunction TJvDBCalcEdit.GetZeroEmpty: Boolean;\r\nbegin\r\n Result := inherited ZeroEmpty;\r\nend;\r\n\r\nprocedure TJvDBCalcEdit.SetZeroEmpty(Value: Boolean);\r\nbegin\r\n inherited ZeroEmpty := Value;\r\n if FLEmptyIsNull then\r\n SetEmptyIsNull(ZeroEmpty)\r\nend;\r\n\r\nfunction TJvDBCalcEdit.StoreEmptyIsNull: Boolean;\r\nbegin\r\n Result := FEmptyIsNull <> ZeroEmpty;\r\nend;\r\n\r\n//Polaris\r\n\r\nprocedure TJvDBCalcEdit.Notification(AComponent: TComponent;\r\n Operation: TOperation);\r\nbegin\r\n inherited Notification(AComponent, Operation);\r\n if (Operation = opRemove) and (FDataLink <> nil) and\r\n (AComponent = DataSource) then\r\n DataSource := nil;\r\nend;\r\n\r\nprocedure TJvDBCalcEdit.KeyDown(var Key: Word; Shift: TShiftState);\r\nbegin\r\n inherited KeyDown(Key, Shift);\r\n if not ReadOnly and\r\n ((Key = VK_DELETE) and (Shift * KeyboardShiftStates = [])) or\r\n ((Key = VK_INSERT) and (Shift * KeyboardShiftStates = [ssShift])) then\r\n FDataLink.Edit;\r\nend;\r\n\r\nprocedure TJvDBCalcEdit.KeyPress(var Key: Char);\r\nbegin\r\n inherited KeyPress(Key);\r\n case Key of\r\n CtrlH, CtrlV, CtrlX, #32..#255:\r\n if not PopupVisible then\r\n FDataLink.Edit;\r\n Esc:\r\n begin\r\n FDataLink.Reset;\r\n SelectAll;\r\n Key := #0;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJvDBCalcEdit.IsValidChar(Key: Char): Boolean;\r\nbegin\r\n Result := inherited IsValidChar(Key);\r\n if Result and (FDataLink.Field <> nil) then\r\n Result := FDataLink.Field.IsValidChar(Key);\r\nend;\r\n\r\nprocedure TJvDBCalcEdit.UpdatePopup;\r\nvar\r\n Precision: Byte;\r\nbegin\r\n Precision := DefCalcPrecision;\r\n if (FDataLink <> nil) and (FDataLink.Field <> nil) and\r\n (FDataLink.Field is TFloatField) then\r\n Precision := TFloatField(FDataLink.Field).Precision;\r\n if FPopup <> nil then\r\n SetupPopupCalculator(FPopup, Precision, BeepOnError);\r\nend;\r\n\r\nprocedure TJvDBCalcEdit.PopupDropDown(DisableEdit: Boolean);\r\nbegin\r\n {if not ReadOnly then} // checked in FDataLink.Edit via CanModify\r\n if AlwaysShowPopup or FDataLink.Edit then\r\n inherited PopupDropDown(DisableEdit);\r\nend;\r\n\r\nfunction TJvDBCalcEdit.EditCanModify: Boolean;\r\nbegin\r\n Result := FDataLink.Edit;\r\nend;\r\n\r\nfunction TJvDBCalcEdit.GetDisplayText: string;\r\nvar\r\n E: Extended;\r\nbegin\r\n if (csPaintCopy in ControlState) and (FDataLink.Field <> nil) then\r\n begin\r\n if FDataLink.Field.IsNull then\r\n E := 0.0\r\n else\r\n if FDataLink.Field.DataType in [ftSmallint, ftInteger, ftWord] then\r\n E := FDataLink.Field.AsInteger\r\n else\r\n if FDataLink.Field.DataType = ftBoolean then\r\n E := Ord(FDataLink.Field.AsBoolean)\r\n else\r\n if FDataLink.Field is TLargeintField then\r\n E := TLargeintField(FDataLink.Field).AsLargeInt\r\n else\r\n E := FDataLink.Field.AsFloat;\r\n if FDataLink.Field.IsNull then\r\n Result := ''\r\n else\r\n Result := FormatDisplayText(E);\r\n end\r\n else\r\n begin\r\n if FDataLink.Field = nil then\r\n begin\r\n if csDesigning in ComponentState then\r\n Result := Format('(%s)', [Name])\r\n else\r\n Result := '';\r\n end\r\n else\r\n //Polaris Result := inherited GetDisplayText;\r\n if FDataLink.Field.IsNull then\r\n Result := ''\r\n else\r\n Result := inherited GetDisplayText;\r\n //Polaris\r\n end;\r\nend;\r\n\r\nprocedure TJvDBCalcEdit.Reset;\r\nbegin\r\n FDataLink.Reset;\r\n inherited Reset;\r\nend;\r\n\r\nprocedure TJvDBCalcEdit.Change;\r\nbegin\r\n if not Formatting then\r\n FDataLink.Modified;\r\n inherited Change;\r\nend;\r\n\r\nprocedure TJvDBCalcEdit.SetText(const AValue: string);\r\nbegin\r\n if not ReadOnly then\r\n inherited SetText(AValue);\r\nend;\r\n\r\n//Polaris\r\nprocedure TJvDBCalcEdit.DataChanged;\r\nbegin\r\n inherited;\r\n if Assigned(FDataLink) and Assigned(FDataLink.Field) {and DecimalPlaceRound} then\r\n begin\r\n EditText := DisplayText;\r\n try\r\n if EditText <> '' then\r\n if (StrToFloat(TextToValText(EditText)) = 0) and ZeroEmpty then\r\n EditText := '';\r\n except\r\n end;\r\n end;\r\nend;\r\n//Polaris\r\n\r\nfunction TJvDBCalcEdit.GetDataSource: TDataSource;\r\nbegin\r\n Result := FDataLink.DataSource;\r\nend;\r\n\r\nprocedure TJvDBCalcEdit.SetDataSource(Value: TDataSource);\r\nbegin\r\n if FDataLink.DataSource <> Value then\r\n begin\r\n if not (FDataLink.DataSourceFixed and (csLoading in ComponentState)) then\r\n begin\r\n if FDataLink.DataSource <> nil then\r\n FDataLink.DataSource.RemoveFreeNotification(Self);\r\n FDataLink.DataSource := Value;\r\n end;\r\n if Value <> nil then\r\n Value.FreeNotification(Self);\r\n UpdateFieldParams;\r\n end;\r\nend;\r\n\r\nfunction TJvDBCalcEdit.GetDataField: string;\r\nbegin\r\n Result := FDataLink.FieldName;\r\nend;\r\n\r\nprocedure TJvDBCalcEdit.SetDataField(const Value: string);\r\nbegin\r\n if FDataLink.FieldName <> Value then\r\n begin\r\n FDataLink.FieldName := Value;\r\n UpdateFieldParams;\r\n end;\r\nend;\r\n\r\nprocedure TJvDBCalcEdit.SetDefaultParams(Value: Boolean);\r\nbegin\r\n if DefaultParams <> Value then\r\n begin\r\n FDefaultParams := Value;\r\n if FDefaultParams then\r\n UpdateFieldParams;\r\n end;\r\nend;\r\n\r\nprocedure TJvDBCalcEdit.UpdateFieldParams;\r\nbegin\r\n if FDataLink.Field <> nil then\r\n begin\r\n if FDataLink.Field is TNumericField then\r\n begin\r\n if TNumericField(FDataLink.Field).DisplayFormat <> '' then\r\n DisplayFormat := TNumericField(FDataLink.Field).DisplayFormat;\r\n Alignment := TNumericField(FDataLink.Field).Alignment;\r\n end;\r\n if FDataLink.Field is TLargeintField then\r\n begin\r\n MaxValue := TLargeintField(FDataLink.Field).MaxValue;\r\n MinValue := TLargeintField(FDataLink.Field).MinValue;\r\n DecimalPlaces := 0;\r\n if DisplayFormat = '' then\r\n DisplayFormat := ',#';\r\n end\r\n else\r\n if FDataLink.Field is TIntegerField then\r\n begin\r\n MaxValue := TIntegerField(FDataLink.Field).MaxValue;\r\n MinValue := TIntegerField(FDataLink.Field).MinValue;\r\n DecimalPlaces := 0;\r\n if DisplayFormat = '' then\r\n DisplayFormat := ',#';\r\n end\r\n else\r\n if FDataLink.Field is TBCDField then\r\n begin\r\n MaxValue := TBCDField(FDataLink.Field).MaxValue;\r\n MinValue := TBCDField(FDataLink.Field).MinValue;\r\n end\r\n else\r\n if FDataLink.Field is TFloatField then\r\n begin\r\n MaxValue := TFloatField(FDataLink.Field).MaxValue;\r\n MinValue := TFloatField(FDataLink.Field).MinValue;\r\n //Polaris DecimalPlaces := TFloatField(FDataLink.Field).Precision;\r\n DecimalPlaces := Min(DecimalPlaces, TFloatField(FDataLink.Field).Precision);\r\n end\r\n else\r\n if FDataLink.Field is TBooleanField then\r\n begin\r\n MinValue := 0;\r\n MaxValue := 1;\r\n DecimalPlaces := 0;\r\n if DisplayFormat = '' then\r\n DisplayFormat := ',#';\r\n end;\r\n end;\r\n UpdatePopup;\r\nend;\r\n\r\nfunction TJvDBCalcEdit.GetReadOnly: Boolean;\r\nbegin\r\n Result := FDataLink.ReadOnly;\r\nend;\r\n\r\nprocedure TJvDBCalcEdit.SetReadOnly(Value: Boolean);\r\nbegin\r\n FDataLink.ReadOnly := Value;\r\nend;\r\n\r\nfunction TJvDBCalcEdit.GetField: TField;\r\nbegin\r\n Result := FDataLink.Field;\r\nend;\r\n\r\nprocedure TJvDBCalcEdit.DataChange(Sender: TObject);\r\nbegin\r\n if FDefaultParams then\r\n UpdateFieldParams;\r\n if FDataLink.Field <> nil then\r\n begin\r\n if FDataLink.Field.IsNull then\r\n begin\r\n Self.Value := 0.0;\r\n EditText := '';\r\n end\r\n else\r\n if FDataLink.Field.DataType in [ftSmallint, ftInteger, ftWord] then\r\n Self.AsInteger := FDataLink.Field.AsInteger\r\n else\r\n if FDataLink.Field.DataType = ftBoolean then\r\n Self.AsInteger := Ord(FDataLink.Field.AsBoolean)\r\n else\r\n if FDataLink.Field is TLargeintField then\r\n Self.Value := TLargeintField(FDataLink.Field).AsLargeInt\r\n else\r\n Self.Value := FDataLink.Field.AsFloat;\r\n DataChanged;\r\n end\r\n else\r\n begin\r\n if csDesigning in ComponentState then\r\n begin\r\n Self.Value := 0;\r\n EditText := Format('(%s)', [Name]);\r\n end\r\n else\r\n Self.Value := 0;\r\n end;\r\nend;\r\n\r\nprocedure TJvDBCalcEdit.EditingChange(Sender: TObject);\r\nbegin\r\n inherited ReadOnly := not FDataLink.Editing;\r\nend;\r\n\r\nprocedure TJvDBCalcEdit.UpdateFieldData(Sender: TObject);\r\nbegin\r\n inherited UpdateData;\r\n //Polaris if (Value = 0) and ZeroEmpty then FDataLink.Field.Clear\r\n if (Trim(Text) = '') and FEmptyIsNull then\r\n FDataLink.Field.Clear\r\n //if (Value = 0) and ZeroEmpty then\r\n// FDataLink.Field.Clear\r\n else\r\n\r\n case FDataLink.Field.DataType of\r\n ftSmallint,\r\n ftInteger,\r\n ftWord:\r\n begin\r\n FDataLink.Field.AsInteger := Self.AsInteger;\r\n end;\r\n ftBoolean:\r\n begin\r\n FDataLink.Field.AsBoolean := Boolean(Self.AsInteger);\r\n end;\r\n ftFMTBcd,\r\n ftBCD:\r\n begin\r\n FDataLink.Field.AsBCD := DoubleToBCD(Self.Value)\r\n end;\r\n else\r\n begin\r\n FDataLink.Field.AsFloat := Self.Value;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvDBCalcEdit.CMGetDataLink(var Msg: TMessage);\r\nbegin\r\n Msg.Result := LRESULT(FDataLink);\r\nend;\r\n\r\nprocedure TJvDBCalcEdit.AcceptValue(const Value: Variant);\r\nbegin\r\n if VarIsNullEmpty(Value) then\r\n FDataLink.Field.Clear\r\n else\r\n FDataLink.Field.Value := CheckValue(Value, False);\r\n DoChange;\r\nend;\r\n\r\nprocedure TJvDBCalcEdit.WMPaste(var Msg: TMessage);\r\nbegin\r\n FDataLink.Edit;\r\n inherited;\r\nend;\r\n\r\nprocedure TJvDBCalcEdit.WMCut(var Msg: TMessage);\r\nbegin\r\n FDataLink.Edit;\r\n inherited;\r\nend;\r\n\r\n// Polaris\r\nprocedure TJvDBCalcEdit.DoExit;\r\nbegin\r\n if Modified then\r\n try\r\n CheckRange;\r\n FDataLink.UpdateRecord;\r\n except\r\n SelectAll;\r\n if CanFocus then\r\n SetFocus;\r\n raise;\r\n end;\r\n inherited DoExit;\r\nend;\r\n\r\nfunction TJvDBCalcEdit.UseRightToLeftAlignment: Boolean;\r\nbegin\r\n Result := DBUseRightToLeftAlignment(Self, Field);\r\nend;\r\n\r\nfunction TJvDBCalcEdit.ExecuteAction(Action: TBasicAction): Boolean;\r\nbegin\r\n Result := inherited ExecuteAction(Action) or (FDataLink <> nil) and\r\n FDataLink.ExecuteAction(Action);\r\nend;\r\n\r\nfunction TJvDBCalcEdit.UpdateAction(Action: TBasicAction): Boolean;\r\nbegin\r\n Result := inherited UpdateAction(Action) or (FDataLink <> nil) and\r\n FDataLink.UpdateAction(Action);\r\nend;\r\n\r\n//=== { TJvStatusDataLink } ==================================================\r\n\r\ntype\r\n TJvStatusDataLink = class(TDataLink)\r\n private\r\n FLabel: TJvDBStatusLabel;\r\n protected\r\n procedure ActiveChanged; override;\r\n procedure EditingChanged; override;\r\n procedure DataSetChanged; override;\r\n procedure DataSetScrolled(Distance: Integer); override;\r\n procedure LayoutChanged; override;\r\n public\r\n constructor Create(ALabel: TJvDBStatusLabel);\r\n destructor Destroy; override;\r\n end;\r\n\r\nconstructor TJvStatusDataLink.Create(ALabel: TJvDBStatusLabel);\r\nbegin\r\n inherited Create;\r\n FLabel := ALabel;\r\nend;\r\n\r\ndestructor TJvStatusDataLink.Destroy;\r\nbegin\r\n FLabel := nil;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvStatusDataLink.ActiveChanged;\r\nbegin\r\n DataSetChanged;\r\nend;\r\n\r\nprocedure TJvStatusDataLink.DataSetScrolled(Distance: Integer);\r\nbegin\r\n if (FLabel <> nil) and (FLabel.Style = lsRecordNo) then\r\n FLabel.UpdateStatus;\r\nend;\r\n\r\nprocedure TJvStatusDataLink.EditingChanged;\r\nbegin\r\n if (FLabel <> nil) and (FLabel.Style <> lsRecordSize) then\r\n FLabel.UpdateStatus;\r\nend;\r\n\r\nprocedure TJvStatusDataLink.DataSetChanged;\r\nbegin\r\n if FLabel <> nil then\r\n FLabel.UpdateData;\r\nend;\r\n\r\nprocedure TJvStatusDataLink.LayoutChanged;\r\nbegin\r\n if (FLabel <> nil) and (FLabel.Style <> lsRecordSize) then\r\n DataSetChanged; { ??? }\r\nend;\r\n\r\n//=== { TJvDBStatusLabel } ===================================================\r\n\r\nconst\r\n GlyphSpacing = 2;\r\n GlyphColumns = 7;\r\n\r\nconstructor TJvDBStatusLabel.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n ShadowSize := 0;\r\n Layout := tlCenter;\r\n ControlStyle := ControlStyle - [csSetCaption , csReplicatable];\r\n FRecordCount := -1;\r\n FRecordNo := -1;\r\n ShowAccelChar := False;\r\n FDataSetName := '';\r\n FDataLink := TJvStatusDataLink.Create(Self);\r\n FStyle := lsState;\r\n GlyphAlign := glGlyphLeft;\r\n FEditColor := clRed;\r\n FCaptions := TStringList.Create;\r\n FCaptions.OnChange := CaptionsChanged;\r\n FGlyph := TBitmap.Create;\r\n FGlyph.Handle := LoadBitmap(HInstance, 'JvDBStatusLabelSTATES');\r\n Caption := '';\r\nend;\r\n\r\ndestructor TJvDBStatusLabel.Destroy;\r\nbegin\r\n FreeAndNil(FDataLink);\r\n //DisposeStr(FDataSetName);\r\n FCaptions.OnChange := nil;\r\n FreeAndNil(FCaptions);\r\n FreeAndNil(FCell);\r\n FreeAndNil(FGlyph);\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvDBStatusLabel.Loaded;\r\nbegin\r\n inherited Loaded;\r\n UpdateData;\r\nend;\r\n\r\nfunction TJvDBStatusLabel.GetDefaultFontColor: TColor;\r\nbegin\r\n if (FStyle = lsState) and (FDataLink <> nil) and\r\n (GetDatasetState in [dsEdit, dsInsert]) then\r\n Result := FEditColor\r\n else\r\n Result := inherited GetDefaultFontColor;\r\nend;\r\n\r\nfunction TJvDBStatusLabel.GetLabelCaption: string;\r\nbegin\r\n if (csDesigning in ComponentState) and ((FStyle = lsState) or\r\n (FDataLink = nil) or not FDataLink.Active) then\r\n Result := Format('(%s)', [Name])\r\n else\r\n if (FDataLink = nil) or (DataSource = nil) then\r\n Result := ''\r\n else\r\n begin\r\n case FStyle of\r\n lsState:\r\n if FShowOptions in [doCaption, doBoth] then\r\n begin\r\n if DataSetName = '' then\r\n Result := GetCaption(DataSource.State)\r\n else\r\n Result := Format('%s: %s', [DataSetName, GetCaption(DataSource.State)]);\r\n end\r\n else { doGlyph }\r\n Result := '';\r\n lsRecordNo:\r\n if FDataLink.Active then\r\n begin\r\n if FRecordNo >= 0 then\r\n begin\r\n if FRecordCount >= 0 then\r\n Result := Format('%d:%d', [FRecordNo, FRecordCount])\r\n else\r\n Result := IntToStr(FRecordNo);\r\n end\r\n else\r\n begin\r\n if FRecordCount >= 0 then\r\n Result := Format('( %d )', [FRecordCount])\r\n else\r\n Result := '';\r\n end;\r\n end\r\n else\r\n Result := '';\r\n lsRecordSize:\r\n if FDataLink.Active then\r\n Result := IntToStr(FDataLink.DataSet.RecordSize)\r\n else\r\n Result := '';\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJvDBStatusLabel.GetDatasetState: TDataSetState;\r\nbegin\r\n if DataSource <> nil then\r\n Result := DataSource.State\r\n else\r\n Result := dsInactive;\r\nend;\r\n\r\nprocedure TJvDBStatusLabel.SetName(const Value: TComponentName);\r\nbegin\r\n inherited SetName(Value);\r\n if csDesigning in ComponentState then\r\n Invalidate;\r\nend;\r\n\r\nfunction TJvDBStatusLabel.GetCaptions: TStrings;\r\nbegin\r\n Result := FCaptions;\r\nend;\r\n\r\nprocedure TJvDBStatusLabel.SetCaptions(Value: TStrings);\r\nbegin\r\n FCaptions.Assign(Value);\r\nend;\r\n\r\nfunction TJvDBStatusLabel.GetStatusKind(State: TDataSetState): TDBStatusKind;\r\nbegin\r\n if not (State in [Low(TDBStatusKind)..High(TDBStatusKind)]) then\r\n begin\r\n case State of\r\n dsFilter:\r\n Result := dsSetKey;\r\n dsNewValue, dsOldValue, dsCurValue:\r\n Result := dsEdit;\r\n else\r\n Result := TDBStatusKind(State);\r\n end;\r\n end\r\n else\r\n Result := TDBStatusKind(State);\r\nend;\r\n\r\nfunction TJvDBStatusLabel.GetCaption(State: TDataSetState): string;\r\nconst\r\n StrIds: array [TDBStatusKind] of string = (RsInactiveData, RsBrowseData,\r\n RsEditData, RsInsertData, RsSetKeyData, RsCalcFieldsData);\r\nvar\r\n Kind: TDBStatusKind;\r\nbegin\r\n Kind := GetStatusKind(State);\r\n if (Ord(Kind) < Captions.Count) and (Captions[Ord(Kind)] <> '') then\r\n Result := Captions[Ord(Kind)]\r\n else\r\n Result := StrIds[Kind];\r\nend;\r\n\r\nprocedure TJvDBStatusLabel.Paint;\r\nvar\r\n GlyphOrigin: TPoint;\r\nbegin\r\n inherited Paint;\r\n if (FStyle = lsState) and (FShowOptions in [doGlyph, doBoth]) and\r\n (FCell <> nil) then\r\n begin\r\n if GlyphAlign = glGlyphLeft then\r\n GlyphOrigin.X := GlyphSpacing\r\n else {glGlyphRight}\r\n GlyphOrigin.X := ClientWidth - MarginRight + GlyphSpacing;\r\n case Layout of\r\n tlTop:\r\n GlyphOrigin.Y := 0;\r\n tlCenter:\r\n GlyphOrigin.Y := (ClientHeight - FCell.Height) div 2;\r\n else { tlBottom }\r\n GlyphOrigin.Y := ClientHeight - FCell.Height;\r\n end;\r\n DrawBitmapTransparent(Canvas, GlyphOrigin.X, GlyphOrigin.Y,\r\n FCell, FGlyph.TransparentColor);\r\n end;\r\nend;\r\n\r\nprocedure TJvDBStatusLabel.CaptionsChanged(Sender: TObject);\r\nbegin\r\n FCaptions.OnChange := nil;\r\n try\r\n while (Pred(FCaptions.Count) > Ord(High(TDBStatusKind))) do\r\n FCaptions.Delete(FCaptions.Count - 1);\r\n finally\r\n FCaptions.OnChange := CaptionsChanged;\r\n end;\r\n if not (csDesigning in ComponentState) then\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvDBStatusLabel.UpdateData;\r\n\r\n function IsSequenced: Boolean;\r\n begin\r\n Result := FDataLink.DataSet.IsSequenced;\r\n end;\r\n\r\nbegin\r\n FRecordCount := -1;\r\n if (FStyle = lsRecordNo) and FDataLink.Active and\r\n (DataSource.State in [dsBrowse, dsEdit]) then\r\n begin\r\n if Assigned(FOnGetRecordCount) then\r\n FOnGetRecordCount(Self, FDataLink.DataSet, FRecordCount)\r\n else\r\n if FCalcCount or IsSequenced then\r\n FRecordCount := FDataLink.DataSet.RecordCount;\r\n end;\r\n UpdateStatus;\r\nend;\r\n\r\nprocedure TJvDBStatusLabel.UpdateStatus;\r\nbegin\r\n if DataSource <> nil then\r\n begin\r\n case FStyle of\r\n lsState:\r\n if FShowOptions in [doGlyph, doBoth] then\r\n begin\r\n if GlyphAlign = glGlyphLeft then\r\n begin\r\n if AutoSize then\r\n Alignment := taRightJustify;\r\n MarginRight := 0;\r\n MarginLeft := (FGlyph.Width div GlyphColumns) + GlyphSpacing * 2;\r\n end\r\n else {glGlyphRight}\r\n begin\r\n if AutoSize then\r\n Alignment := taLeftJustify;\r\n MarginLeft := 0;\r\n MarginRight := (FGlyph.Width div GlyphColumns) + GlyphSpacing * 2;\r\n end;\r\n if FCell = nil then\r\n FCell := TBitmap.Create;\r\n AssignBitmapCell(FGlyph, FCell, GlyphColumns, 1,\r\n Ord(GetStatusKind(DataSource.State)));\r\n end\r\n else { doCaption }\r\n begin\r\n FCell.Free;\r\n FCell := nil;\r\n MarginLeft := 0;\r\n MarginRight := 0;\r\n end;\r\n lsRecordNo:\r\n begin\r\n FCell.Free;\r\n FCell := nil;\r\n MarginLeft := 0;\r\n MarginRight := 0;\r\n FRecordNo := -1;\r\n if FDataLink.Active then\r\n begin\r\n if Assigned(FOnGetRecNo) then\r\n FOnGetRecNo(Self, FDataLink.DataSet, FRecordNo)\r\n else\r\n try\r\n with FDataLink.DataSet do\r\n if not IsEmpty then\r\n FRecordNo := RecNo;\r\n except\r\n end;\r\n end;\r\n end;\r\n lsRecordSize:\r\n begin\r\n FCell.Free;\r\n FCell := nil;\r\n MarginLeft := 0;\r\n MarginRight := 0;\r\n end;\r\n end;\r\n end\r\n else\r\n begin\r\n FCell.Free;\r\n FCell := nil;\r\n end;\r\n NeedsResize := True;\r\n AdjustBounds;\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvDBStatusLabel.Notification(AComponent: TComponent;\r\n Operation: TOperation);\r\nbegin\r\n inherited Notification(AComponent, Operation);\r\n if (Operation = opRemove) and (FDataLink <> nil) and\r\n (AComponent = DataSource) then\r\n DataSource := nil;\r\nend;\r\n\r\nfunction TJvDBStatusLabel.GetDataSetName: string;\r\nbegin\r\n Result := FDataSetName;\r\n if not (csDesigning in ComponentState) then\r\n begin\r\n if Assigned(FOnGetDataName) then\r\n Result := FOnGetDataName(Self)\r\n else\r\n if (Result = '') and (DataSource <> nil) and (DataSource.DataSet <> nil) then\r\n Result := DataSource.DataSet.Name;\r\n end;\r\nend;\r\n\r\nprocedure TJvDBStatusLabel.SetDataSetName(Value: string);\r\nbegin\r\n FDataSetName := Value;\r\n Invalidate;\r\nend;\r\n\r\nfunction TJvDBStatusLabel.GetDataSource: TDataSource;\r\nbegin\r\n Result := FDataLink.DataSource;\r\nend;\r\n\r\nprocedure TJvDBStatusLabel.SetDataSource(Value: TDataSource);\r\nbegin\r\n if not (FDataLink.DataSourceFixed and (csLoading in ComponentState)) then\r\n begin\r\n if FDataLink.DataSource <> nil then\r\n FDataLink.DataSource.RemoveFreeNotification(Self);\r\n FDataLink.DataSource := Value;\r\n end;\r\n if Value <> nil then\r\n Value.FreeNotification(Self);\r\n if not (csLoading in ComponentState) then\r\n UpdateData;\r\nend;\r\n\r\nprocedure TJvDBStatusLabel.SetEditColor(Value: TColor);\r\nbegin\r\n if FEditColor <> Value then\r\n begin\r\n FEditColor := Value;\r\n if Style = lsState then\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvDBStatusLabel.SetGlyphAlign(Value: TGlyphAlign);\r\nbegin\r\n if FGlyphAlign <> Value then\r\n begin\r\n FGlyphAlign := Value;\r\n UpdateStatus;\r\n end;\r\nend;\r\n\r\nprocedure TJvDBStatusLabel.SetShowOptions(Value: TDBLabelOptions);\r\nbegin\r\n if FShowOptions <> Value then\r\n begin\r\n FShowOptions := Value;\r\n UpdateStatus;\r\n end;\r\nend;\r\n\r\nprocedure TJvDBStatusLabel.SetCalcCount(Value: Boolean);\r\nbegin\r\n if FCalcCount <> Value then\r\n begin\r\n FCalcCount := Value;\r\n if not (csLoading in ComponentState) then\r\n UpdateData;\r\n end;\r\nend;\r\n\r\nprocedure TJvDBStatusLabel.SetStyle(Value: TDBLabelStyle);\r\nbegin\r\n if FStyle <> Value then\r\n begin\r\n FStyle := Value;\r\n if not (csLoading in ComponentState) then\r\n UpdateData;\r\n end;\r\nend;\r\n\r\n//=== { TJvDBNavigator } =====================================================\r\n\r\nconstructor TJvDBNavigator.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n Transparent := True;\r\nend;\r\n\r\nprocedure TJvDBNavigator.SetTransparent(Value: Boolean);\r\nvar\r\n Button: TNavigateBtn;\r\nbegin\r\n FTransparent := Value;\r\n if Value then\r\n ControlStyle := ControlStyle - [csOpaque]\r\n else\r\n ControlStyle := ControlStyle + [csOpaque];\r\n\r\n {$IFDEF COMPILER7_UP}\r\n ParentBackground := Value;\r\n {$ENDIF COMPILER7_UP}\r\n for Button := Low(Buttons) to High(Buttons) do\r\n Buttons[Button].Transparent := Value;\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvDBNavigator.Paint;\r\nbegin\r\n if Transparent then\r\n Exit;\r\nend;\r\n\r\nprocedure TJvDBNavigator.WMEraseBkgnd(var Msg: TWMEraseBkgnd);\r\nvar\r\n Pt: TPoint;\r\nbegin\r\n if Transparent then\r\n begin\r\n OffsetWindowOrgEx(Msg.DC, Left, Top, @Pt);\r\n SendMessage(Parent.Handle, WM_ERASEBKGND, Msg.DC, Msg.DC);\r\n SendMessage(Parent.Handle, WM_PRINTCLIENT, Msg.DC, Msg.DC);\r\n SetWindowOrgEx(Msg.DC, Pt.X, Pt.Y, nil);\r\n Msg.Result := 1;\r\n end\r\n else\r\n inherited;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvDBDatePickerEdit.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvDBDatePickerEdit, released on 2002-10-04.\r\n\r\nThe Initial Developer of the Original Code is Oliver Giesen [giesen att lucatec dott com]\r\nPortions created by Oliver Giesen are Copyright (C) 2002 Lucatec GmbH.\r\nAll Rights Reserved.\r\n\r\nContributor(s): ______________________________________.\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nDescription:\r\n A data-aware variation of the DatePickerEdit component.\r\n\r\n Notable features:\r\n\r\n - The inherited NoDateText mechanism is enhanced and utilized to support proper\r\n handling of NULL values.\r\n\r\n - If EnforceRequired is set to True (default) you should not have to worry\r\n about setting ShowCheckBox. If the associated field has the Required flag set\r\n ShowCheckBox will automatically be False.\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvDBDatePickerEdit.pas 13329 2012-06-12 14:28:33Z obones $\r\n\r\nunit JvDBDatePickerEdit;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, Messages, Classes, Controls, DB, DBCtrls,\r\n JvDatePickerEdit;\r\n\r\ntype\r\n TJvCustomDBDatePickerEdit = class(TJvCustomDatePickerEdit)\r\n private\r\n FDataLink: TFieldDataLink;\r\n FEnforceRequired: Boolean;\r\n FAllowPopupBrowsing: Boolean;\r\n FLockEditing: Integer;\r\n procedure ValidateShowCheckBox; overload;\r\n function ValidateShowCheckBox(const AValue: Boolean): Boolean; overload;\r\n function GetDataField: string;\r\n function GetDataSource: TDataSource;\r\n procedure SetDataField(const AValue: string);\r\n procedure SetDataSource(const AValue: TDataSource);\r\n procedure SetEnforceRequired(const AValue: Boolean);\r\n procedure CMGetDataLink(var Msg: TMessage); message CM_GETDATALINK;\r\n function GetInternalDate: TDateTime;\r\n procedure SetInternalDate(const Value: TDateTime);\r\n function GetField: TField;\r\n protected\r\n procedure WMCut(var Msg: TMessage); message WM_CUT;\r\n procedure WMPaste(var Msg: TMessage); message WM_PASTE;\r\n procedure WMUndo(var Msg: TMessage); message WM_UNDO;\r\n procedure DataChange(Sender: TObject);\r\n procedure UpdateData(Sender: TObject);\r\n function IsLinked: Boolean;\r\n procedure KeyPress(var Key: Char); override;\r\n procedure Change; override;\r\n procedure DoExit; override;\r\n procedure PopupDropDown(DisableEdit: Boolean); override;\r\n function EditCanModify: Boolean; override;\r\n procedure SetChecked(const AValue: Boolean); override;\r\n procedure SetShowCheckbox(const AValue: Boolean); override;\r\n procedure UpdateDisplay; override;\r\n function GetEnableValidation: Boolean; override;\r\n function ValidateDate(const ADate: TDateTime): Boolean; override;\r\n property DataField: string read GetDataField write SetDataField;\r\n property DataSource: TDataSource read GetDataSource write SetDataSource;\r\n property EnforceRequired: Boolean read FEnforceRequired write SetEnforceRequired default False;\r\n property AllowPopupBrowsing: Boolean read FAllowPopupBrowsing write FAllowPopupBrowsing default True;\r\n procedure Loaded; override;\r\n\r\n property InternalDate: TDateTime read GetInternalDate write SetInternalDate;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n function IsEmpty: Boolean; override;\r\n property Field: TField read GetField;\r\n end;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvDBDatePickerEdit = class(TJvCustomDBDatePickerEdit)\r\n public\r\n property Checked;\r\n property Date;\r\n property Dropped;\r\n published\r\n property Action;\r\n property Align;\r\n property AllowNoDate;\r\n property AlwaysReturnEditDate;\r\n property Anchors;\r\n property AutoSelect;\r\n property AutoSize;\r\n property BorderStyle;\r\n property ButtonFlat;\r\n property ButtonHint;\r\n property ButtonWidth;\r\n property CalendarAppearance;\r\n property Caret;\r\n property CharCase;\r\n property ClipboardCommands;\r\n property Color;\r\n property Constraints;\r\n //property Cursor; {already published}\r\n property DataField;\r\n property DataSource;\r\n property DateFormat;\r\n property DateSeparator;\r\n property DirectInput;\r\n property DisabledColor;\r\n property DisabledTextColor;\r\n property DragCursor;\r\n property DragKind;\r\n property DragMode;\r\n property Enabled;\r\n property EnableValidation;\r\n property EnforceRequired;\r\n property Font;\r\n property Glyph;\r\n property GroupIndex;\r\n property HideSelection;\r\n property HintColor;\r\n property HotTrack;\r\n // property MaxYear default 2900;\r\n // property MinYear default 1900;\r\n property AllowPopupBrowsing;\r\n property BevelEdges;\r\n property BevelInner;\r\n property BevelKind default bkNone;\r\n property BevelOuter;\r\n {property BiDiMode;}\r\n property Flat;\r\n {property ParentBiDiMode;}\r\n property ImeMode;\r\n property ImeName;\r\n property OEMConvert;\r\n property ParentCtl3D;\r\n property OnEndDock;\r\n property OnStartDock;\r\n property ImageIndex;\r\n property ImageKind;\r\n property Images;\r\n property NoDateShortcut;\r\n property NoDateText;\r\n property NoDateValue;\r\n property NumGlyphs;\r\n property ParentColor;\r\n property ParentFont;\r\n property ParentShowHint;\r\n property PopupMenu;\r\n property ReadOnly;\r\n property ShowHint;\r\n property ShowCheckBox;\r\n property StoreDateFormat;\r\n property TabOrder;\r\n {property TabStop;} {(rb) Why disabled?}\r\n property Visible;\r\n property OnButtonClick;\r\n property OnChange;\r\n property OnClick;\r\n property OnCheckClick;\r\n property OnContextPopup;\r\n property OnDblClick;\r\n property OnDragDrop;\r\n property OnDragOver;\r\n property OnEnabledChanged;\r\n property OnEndDrag;\r\n property OnEnter;\r\n property OnExit;\r\n property OnKeyDown;\r\n property OnKeyPress;\r\n property OnKeyUp;\r\n property OnKillFocus;\r\n property OnMouseDown;\r\n property OnMouseEnter;\r\n property OnMouseLeave;\r\n property OnMouseMove;\r\n property OnMouseUp;\r\n property OnParentColorChange;\r\n property OnSetFocus;\r\n property OnStartDrag;\r\n property OnPopupHidden;\r\n property OnPopupShown;\r\n\r\n property OnGetValidDateString;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvDBDatePickerEdit.pas $';\r\n Revision: '$Revision: 13329 $';\r\n Date: '$Date: 2012-06-12 16:28:33 +0200 (mar. 12 juin 2012) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n Variants, SysUtils;\r\n\r\nfunction IsNullOrEmptyStringField(Field: TField): Boolean;\r\nbegin\r\n Result := Field.IsNull or ((Field is TStringField) and (Trim(Field.AsString) = ''));\r\nend;\r\n\r\n//=== { TJvCustomDBDatePickerEdit } ==========================================\r\n\r\nprocedure TJvCustomDBDatePickerEdit.Change;\r\nbegin\r\n if IsLinked then\r\n FDataLink.Modified;\r\n inherited Change;\r\nend;\r\n\r\nprocedure TJvCustomDBDatePickerEdit.CMGetDataLink(var Msg: TMessage);\r\nbegin\r\n Msg.Result := LRESULT(FDataLink);\r\nend;\r\n\r\nconstructor TJvCustomDBDatePickerEdit.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n ControlStyle := ControlStyle + [csReplicatable];\r\n FEnforceRequired := False;\r\n FAllowPopupBrowsing := True;\r\n FDataLink := TFieldDataLink.Create;\r\n with FDataLink do\r\n begin\r\n Control := Self;\r\n OnDataChange := DataChange;\r\n OnUpdateData := UpdateData;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomDBDatePickerEdit.Loaded;\r\nbegin\r\n inherited Loaded;\r\n if AllowNoDate and not IsLinked then\r\n InternalDate := NoDateValue;\r\nend;\r\n\r\nprocedure TJvCustomDBDatePickerEdit.DataChange(Sender: TObject);\r\nbegin\r\n if IsLinked and FDataLink.Active then\r\n begin\r\n if AllowNoDate and IsNullOrEmptyStringField(FDataLink.Field) then\r\n InternalDate := NoDateValue\r\n else\r\n InternalDate := FDataLink.Field.AsDateTime;\r\n end;\r\nend;\r\n\r\ndestructor TJvCustomDBDatePickerEdit.Destroy;\r\nbegin\r\n FDataLink.OnDataChange := nil;\r\n FDataLink.OnUpdateData := nil;\r\n FreeAndNil(FDataLink);\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvCustomDBDatePickerEdit.WMCut(var Msg: TMessage);\r\nbegin\r\n if EditCanModify then\r\n inherited;\r\nend;\r\n\r\nprocedure TJvCustomDBDatePickerEdit.WMPaste(var Msg: TMessage);\r\nbegin\r\n if EditCanModify then\r\n inherited;\r\nend;\r\n\r\nprocedure TJvCustomDBDatePickerEdit.DoExit;\r\nbegin\r\n inherited DoExit;\r\n if IsLinked and FDataLink.Editing then\r\n try\r\n FDataLink.UpdateRecord;\r\n except\r\n SetFocus;\r\n raise;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomDBDatePickerEdit.WMUndo(var Msg: TMessage);\r\nbegin\r\n if EditCanModify then\r\n inherited;\r\nend;\r\n\r\nfunction TJvCustomDBDatePickerEdit.EditCanModify: Boolean;\r\nbegin\r\n Result := (FLockEditing = 0) and not ReadOnly and (not IsLinked or FDataLink.Edit);\r\nend;\r\n\r\nfunction TJvCustomDBDatePickerEdit.GetDataField: string;\r\nbegin\r\n if FDataLink <> nil then\r\n Result := FDataLink.FieldName\r\n else\r\n Result := '';\r\nend;\r\n\r\nfunction TJvCustomDBDatePickerEdit.GetDataSource: TDataSource;\r\nbegin\r\n if FDataLink <> nil then\r\n Result := FDataLink.DataSource\r\n else\r\n Result := nil;\r\nend;\r\n\r\nfunction TJvCustomDBDatePickerEdit.GetEnableValidation: Boolean;\r\nbegin\r\n Result := inherited GetEnableValidation;\r\n {if we enabled \"as-you-type\" validation for an unlinked control, we'd have\r\n validation errors pop up just from tabbing over the control, therefore we\r\n temporary disable it}\r\n if InternalChanging or Leaving then\r\n Result := Result and IsLinked and FDataLink.Editing;\r\nend;\r\n\r\nfunction TJvCustomDBDatePickerEdit.GetField: TField;\r\nbegin\r\n Result := FDataLink.Field;\r\nend;\r\n\r\nfunction TJvCustomDBDatePickerEdit.IsEmpty: Boolean;\r\nbegin\r\n if IsLinked then\r\n begin\r\n if Assigned(FDataLink.DataSet) and FDataLink.DataSet.Active then\r\n begin\r\n if FDataLink.Editing then\r\n Result := inherited IsEmpty\r\n else\r\n try\r\n Result := FDataLink.DataSet.IsEmpty or FDataLink.Field.IsNull;\r\n except\r\n Result := True;\r\n end;\r\n end\r\n else\r\n Result := True;\r\n end\r\n else\r\n Result := AllowNoDate and (Date = NoDateValue);\r\nend;\r\n\r\nfunction TJvCustomDBDatePickerEdit.IsLinked: Boolean;\r\nbegin\r\n Result := Assigned(FDataLink) and Assigned(DataSource) and (DataField <> '');\r\nend;\r\n\r\nprocedure TJvCustomDBDatePickerEdit.PopupDropDown(DisableEdit: Boolean);\r\nbegin\r\n if AllowPopupBrowsing or EditCanModify then\r\n inherited PopupDropDown(DisableEdit);\r\nend;\r\n\r\nprocedure TJvCustomDBDatePickerEdit.SetChecked(const AValue: Boolean);\r\nbegin\r\n if AValue <> Checked then\r\n begin\r\n if EditCanModify then\r\n inherited SetChecked(AValue)\r\n else\r\n UpdateDisplay;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomDBDatePickerEdit.SetDataField(const AValue: string);\r\nbegin\r\n FDataLink.FieldName := AValue;\r\n ValidateShowCheckBox;\r\nend;\r\n\r\nprocedure TJvCustomDBDatePickerEdit.SetDataSource(const AValue: TDataSource);\r\nbegin\r\n FDataLink.DataSource := AValue;\r\n ValidateShowCheckBox;\r\nend;\r\n\r\nprocedure TJvCustomDBDatePickerEdit.SetEnforceRequired(const AValue: Boolean);\r\nbegin\r\n FEnforceRequired := AValue;\r\n ValidateShowCheckBox;\r\nend;\r\n\r\nprocedure TJvCustomDBDatePickerEdit.SetShowCheckbox(const AValue: Boolean);\r\nbegin\r\n inherited SetShowCheckbox(ValidateShowCheckBox(AValue));\r\nend;\r\n\r\nprocedure TJvCustomDBDatePickerEdit.UpdateData(Sender: TObject);\r\nbegin\r\n if IsLinked and FDataLink.Editing then\r\n begin\r\n if not Checked or (AllowNoDate and ((Text = NoDateText) or IsEmptyMaskText(Text))) then\r\n FDataLink.Field.Clear\r\n else\r\n FDataLink.Field.AsDateTime := Self.Date;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomDBDatePickerEdit.UpdateDisplay;\r\nbegin\r\n if IsLinked or not (csDesigning in ComponentState) then\r\n begin\r\n inherited UpdateDisplay;\r\n end\r\n else\r\n if not InternalChanging then // Mantis 4093: Avoid stack overflow as setting Checked might call UpdateDisplay\r\n begin\r\n BeginInternalChange;\r\n try\r\n Checked := False;\r\n if not (csDesigning in ComponentState) then\r\n Text := '';\r\n finally\r\n EndInternalChange;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJvCustomDBDatePickerEdit.ValidateDate(const ADate: TDateTime): Boolean;\r\nbegin\r\n Result := (not IsLinked or FDataLink.Active) or (FDataLink.DataSet.IsEmpty) or\r\n (not FDataLink.Editing) or\r\n ((not Focused) and (FDataLink.DataSet.State = dsInsert) and FDataLink.Field.IsNull) or\r\n (inherited ValidateDate(ADate));\r\nend;\r\n\r\nfunction TJvCustomDBDatePickerEdit.ValidateShowCheckBox(const AValue: Boolean): Boolean;\r\nbegin\r\n Result := AValue;\r\n if EnforceRequired and IsLinked and FDataLink.Active then\r\n begin\r\n if AValue and FDataLink.Field.Required then\r\n Result := False;\r\n AllowNoDate := not FDataLink.Field.Required;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomDBDatePickerEdit.ValidateShowCheckBox;\r\nbegin\r\n inherited SetShowCheckbox(ValidateShowCheckBox(ShowCheckBox));\r\nend;\r\n\r\nprocedure TJvCustomDBDatePickerEdit.KeyPress(var Key: Char);\r\nbegin\r\n inherited KeyPress(Key);\r\n if (Key = #27) and not ReadOnly and Modified and IsLinked then\r\n begin\r\n FDataLink.Reset;\r\n Key := #0;\r\n end;\r\nend;\r\n\r\nfunction TJvCustomDBDatePickerEdit.GetInternalDate: TDateTime;\r\nbegin\r\n Result := Self.Date;\r\nend;\r\n\r\nprocedure TJvCustomDBDatePickerEdit.SetInternalDate(const Value: TDateTime);\r\nbegin\r\n Inc(FLockEditing);\r\n try\r\n Self.Date := Value;\r\n finally\r\n Dec(FLockEditing);\r\n end;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend." }, { "path": "External/Jedi/Jvcl/run/JvDBDateTimePicker.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvDBDateTimePicker.PAS, released May 8, 2000\r\n\r\nThe Initial Developer of the Original Code is Eko Subagio (ekosbg att bigfoot dott com)\r\nPortions created by Eko Subagio are Copyright (C) 2000 Eko Subagio.\r\nPortions created by Microsoft are Copyright (C) 1998, 1999 Microsoft Corp.\r\nAll Rights Reserved.\r\n\r\nContributor(s): ______________________________________.\r\n\r\n by Eko Subagio\r\nCurrent Version: 1.00\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n (rom) comments should be ripped by the help writer\r\n-----------------------------------------------------------------------------}\r\n/////////////////////////////////////////////////////////////////////////\r\n// TJvDBDateTimePicker\r\n// Copyright(c)2000 Eko Subagio\r\n// TJvDBDateTimePicker is derived from TDateTimePicker from Delphi 5\r\n// TDateTimePicker Copyright(c) 2000 Borland/Inprise.\r\n// Extending and add capability to integrate with database\r\n// www.geocities.com/ekosbg\r\n/////////////////////////////////////////////////////////////////////////\r\n// $Id: JvDBDateTimePicker.pas 13315 2012-06-12 11:33:51Z obones $\r\n\r\nunit JvDBDateTimePicker;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, Messages, Classes, Controls, DB, DBCtrls,\r\n JvDateTimePicker;\r\n\r\ntype\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvDBDateTimePicker = class(TJvDateTimePicker)\r\n private\r\n FDataLink: TFieldDataLink;\r\n FBeepOnError: Boolean;\r\n FTrimValue: Boolean;\r\n FIsReadOnly: Boolean;\r\n FPaintControl: TPaintControl;\r\n function GetDataField: string;\r\n function GetDataSource: TDataSource;\r\n function GetReadOnly: Boolean;\r\n procedure SetReadOnly(Value: Boolean);\r\n procedure SetDataField(const Value: string);\r\n procedure SetDataSource(Value: TDataSource);\r\n procedure EditingChange(Sender: TObject);\r\n procedure WMLButtonDown(var Msg: TWMLButtonDown); message WM_LBUTTONDOWN;\r\n procedure WMPaint(var Msg: TWMPaint); message WM_PAINT;\r\n procedure CMGetDataLink(var Msg: TMessage); message CM_GETDATALINK;\r\n procedure CNNotify(var Msg: TWMNotify); message CN_NOTIFY;\r\n function GetField: TField;\r\n protected\r\n procedure Notification(AComponent: TComponent;\r\n Operation: TOperation); override;\r\n function IsDateAndTimeField: Boolean;\r\n // Adding capability to edit\r\n procedure DoExit; override;\r\n procedure DataChange(Sender: TObject);\r\n // Adding capability to edit\r\n procedure KeyPress(var Key: Char); override;\r\n procedure KeyDown(var Key: Word; Shift: TShiftState); override;\r\n procedure Change; override;\r\n procedure UpdateData(Sender: TObject);\r\n // On Close Up & Drop Down\r\n procedure CalendarOnCloseUp(Sender: TObject);\r\n procedure CalendarOnDropDown(Sender: TObject);\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n property Field: TField read GetField;\r\n published\r\n property BeepOnError: Boolean read FBeepOnError write FBeepOnError default True;\r\n property DataField: string read GetDataField write SetDataField;\r\n property DataSource: TDataSource read GetDataSource write SetDataSource;\r\n property TrimValue: Boolean read FTrimValue write FTrimValue default True;\r\n property ReadOnly: Boolean read GetReadOnly write SetReadOnly default False;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvDBDateTimePicker.pas $';\r\n Revision: '$Revision: 13315 $';\r\n Date: '$Date: 2012-06-12 13:33:51 +0200 (mar. 12 juin 2012) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n Variants, SysUtils, ComCtrls, CommCtrl,\r\n {$IFNDEF COMPILER12_UP}\r\n JvJCLUtils,\r\n {$ENDIF ~COMPILER12_UP}\r\n JvConsts;\r\n\r\nfunction IsNullOrEmptyStringField(Field: TField): Boolean;\r\nbegin\r\n Result := Field.IsNull or ((Field is TStringField) and (Trim(Field.AsString) = ''));\r\nend;\r\n\r\n//=== { TJvDBDateTimePicker } ================================================\r\n\r\n///////////////////////////////////////////////////////////////////////////\r\n//constructor TJvDBDateTimePicker.Create\r\n//Parameter : AOwner as TComponent\r\n//Description : As Constructor the procedure had have responsibility to\r\n// handle new instance for initial new value.\r\n//Revision : August 30, 2000\r\n//Author : -ekosbg-\r\n///////////////////////////////////////////////////////////////////////////\r\n\r\nconstructor TJvDBDateTimePicker.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FIsReadOnly := True;\r\n ControlStyle := ControlStyle + [csReplicatable];\r\n FDataLink := TFieldDataLink.Create;\r\n FDataLink.Control := Self;\r\n FDataLink.OnDataChange := DataChange;\r\n FDataLink.OnUpdateData := UpdateData;\r\n FDataLink.OnEditingChange := EditingChange;\r\n OnCloseUp := CalendarOnCloseUp;\r\n OnDropDown := CalendarOnDropDown;\r\n FBeepOnError := True;\r\n FTrimValue := True;\r\n FPaintControl := TPaintControl.Create(Self, DATETIMEPICK_CLASS);\r\nend;\r\n\r\n///////////////////////////////////////////////////////////////////////////\r\n//Destructor TJvDBDateTimePicker.Destroy\r\n//Parameter : None\r\n//Description : Destructor had have responsibility to destroy all garbage\r\n// that had been used in Constructor, free anything in here\r\n// after anything is initialized in Constructor\r\n//Revision : August 30, 2000\r\n//Author : -ekosbg-\r\n///////////////////////////////////////////////////////////////////////////\r\n\r\ndestructor TJvDBDateTimePicker.Destroy;\r\nbegin\r\n OnCloseUp := nil;\r\n OnDropDown := nil;\r\n FPaintControl.Free;\r\n FDataLink.OnDataChange := nil;\r\n FDataLink.OnUpdateData := nil;\r\n FDataLink.Free;\r\n FDataLink := nil;\r\n inherited Destroy;\r\nend;\r\n\r\n///////////////////////////////////////////////////////////////////////////\r\n//procedure : TJvDBDateTimePicker.CalendarOnCloseUp\r\n//Parameter : Sender as TObject\r\n//Descriptions : To set the dataset into edit mode, when the user\r\n// closing up the Calendar.\r\n//Revision : October 18, 2000 ekosbg att bigfoot dott com\r\n///////////////////////////////////////////////////////////////////////////\r\n\r\nprocedure TJvDBDateTimePicker.CalendarOnCloseUp(Sender: TObject);\r\nbegin\r\n FDataLink.Edit;\r\nend;\r\n\r\n///////////////////////////////////////////////////////////////////////////\r\n//procedure : TJvDBDateTimePicker.CalendarOnDropDown\r\n//Parameter : Sender as TObject\r\n//Descriptions : To set the dataset into edit mode, when the user\r\n// dropping down the Calendar.\r\n//Revision : October 18, 2000 ekosbg att bigfoot dott com\r\n///////////////////////////////////////////////////////////////////////////\r\n\r\nprocedure TJvDBDateTimePicker.CalendarOnDropDown(Sender: TObject);\r\nbegin\r\n FDataLink.Edit;\r\nend;\r\n\r\n///////////////////////////////////////////////////////////////////////////\r\n//procedure TJvDBDateTimePicker.Change;\r\n//Description : We should maintain the changes in TJvDBDateTimePicker to\r\n// datalink, in order to notify datalink that it was changed.\r\n//Revision : August 30, 2000\r\n//Author : -ekosbg-\r\n///////////////////////////////////////////////////////////////////////////\r\n\r\nprocedure TJvDBDateTimePicker.Change;\r\nbegin\r\n // call method modified\r\n FDataLink.Edit;\r\n// FDataLink.Modified;\r\n // we still need base class code\r\n inherited Change;\r\n UpdateData(Self);\r\nend;\r\n\r\nprocedure TJvDBDateTimePicker.CMGetDataLink(var Msg: TMessage);\r\nbegin\r\n Msg.Result := LRESULT(FDataLink);\r\nend;\r\n\r\n///////////////////////////////////////////////////////////////////////////\r\n//procedure TJvDBDateTimePicker.DataChange\r\n//Parameter : Sender as TObject\r\n//Description : DataChange had have responsibility to make data in control\r\n// always up to date with the current value in database\r\n// This is event handler for TFieldDataLink event property\r\n// OnDataChange\r\n//Revision : August 30, 2000\r\n//Author : -ekosbg-\r\n///////////////////////////////////////////////////////////////////////////\r\n\r\nprocedure TJvDBDateTimePicker.DataChange(Sender: TObject);\r\nbegin\r\n if Field <> nil then\r\n begin\r\n if IsNullOrEmptyStringField(Field) then\r\n DateTime := NullDate\r\n else if Kind = dtkDate then\r\n begin\r\n if IsDateAndTimeField then\r\n DateTime := Field.AsDateTime\r\n else\r\n DateTime := Int(Field.AsDateTime);\r\n end\r\n else\r\n begin\r\n if IsDateAndTimeField then\r\n DateTime := Field.AsDateTime\r\n else\r\n DateTime := Frac(Field.AsDateTime);\r\n end;\r\n end\r\n else\r\n if csDesigning in ComponentState then\r\n DateTime := Now;\r\n CheckNullValue;\r\nend;\r\n\r\n///////////////////////////////////////////////////////////////////////////\r\n//procedure TJvDBDateTimePicker.DoExit\r\n//Description : User action , She/He leave the control.......\r\n// We should tell to database that is leave and database\r\n// should be updated using datalink value\r\n//Revision : August 30, 2000\r\n//Author : -ekosbg-\r\n///////////////////////////////////////////////////////////////////////////\r\n\r\nprocedure TJvDBDateTimePicker.DoExit;\r\nbegin\r\n // trapping in exception\r\n try\r\n // Changes should Reflect database\r\n FDataLink.UpdateRecord;\r\n except\r\n // Only got an error the focus will not leave the control\r\n SetFocus;\r\n end;\r\n // We needs the method behavior from parents of DoExit;\r\n inherited DoExit;\r\nend;\r\n\r\nprocedure TJvDBDateTimePicker.EditingChange(Sender: TObject);\r\nbegin\r\n FIsReadOnly := not FDataLink.Editing;\r\nend;\r\n\r\n//function TJvDBDateTimePicker.GetDataField\r\n//Return Value : String\r\n//Description : The function retrieve for fieldname from specified\r\n// datasource\r\n//Revision : August 30, 2000\r\n//Author : -ekosbg-\r\n///////////////////////////////////////////////////////////////////////////\r\n\r\nfunction TJvDBDateTimePicker.GetDataField: string;\r\nbegin\r\n Result := FDataLink.FieldName;\r\nend;\r\n\r\n///////////////////////////////////////////////////////////////////////////\r\n//function TJvDBDateTimePicker.GetDataSource\r\n//Return Value : TDataSource\r\n//Description : The function retrieve DataSource from specified Table\r\n// To make connection with database\r\n//Revision : August 30, 2000\r\n//Author : -ekosbg-\r\n///////////////////////////////////////////////////////////////////////////\r\n\r\nfunction TJvDBDateTimePicker.GetDataSource: TDataSource;\r\nbegin\r\n Result := FDataLink.DataSource;\r\nend;\r\n\r\nfunction TJvDBDateTimePicker.GetField: TField;\r\nbegin\r\n Result := FDataLink.Field;\r\nend;\r\n\r\nfunction TJvDBDateTimePicker.GetReadOnly: Boolean;\r\nbegin\r\n Result := FDataLink.ReadOnly;\r\nend;\r\n\r\nfunction TJvDBDateTimePicker.IsDateAndTimeField: Boolean;\r\nbegin\r\n with FDataLink do\r\n Result := (Field <> nil) and\r\n (Field.DataType in [ftDateTime, ftTimeStamp]) and\r\n not TrimValue;\r\nend;\r\n\r\n///////////////////////////////////////////////////////////////////////////\r\n//procedure TJvDBDateTimePicker.KeyDown\r\n//Parameter : Key as Word by references,\r\n// ShiftState as TShiftState, this is enumeration type\r\n//Description : Handling user action what should to do ? The control should\r\n// tell to datalink that they should change mode to edit doing\r\n// an action such as delete, insert or...you guess it\r\n//Revision : August 30, 2000\r\n//Author : -ekosbg-\r\n///////////////////////////////////////////////////////////////////////////\r\n\r\nprocedure TJvDBDateTimePicker.KeyDown(var Key: Word; Shift: TShiftState);\r\nconst\r\n cAllowedKeysWhenReadOnly = [VK_LEFT, VK_RIGHT];\r\nbegin\r\n { Only allow left and right arrow when read-only, don't care about Shift }\r\n if not (Key in cAllowedKeysWhenReadOnly) and FIsReadOnly and not FDataLink.CanModify then\r\n begin\r\n if BeepOnError then\r\n Beep;\r\n Key := 0;\r\n Exit;\r\n end;\r\n\r\n // we still parent code\r\n inherited KeyDown(Key, Shift);\r\n // Is it Delete key, insert key or shiftstate ...\r\n case Key of\r\n VK_DELETE:\r\n if Shift * KeyboardShiftStates = [] then\r\n begin\r\n FDataLink.Edit;\r\n if Kind = dtkDate then\r\n begin\r\n if IsDateAndTimeField then\r\n DateTime := NullDate\r\n else\r\n DateTime := Int(NullDate);\r\n end\r\n else\r\n begin\r\n if IsDateAndTimeField then\r\n DateTime := NullDate\r\n else\r\n DateTime := Frac(NullDate);\r\n end;\r\n CheckNullValue;\r\n UpdateData(Self);\r\n end;\r\n VK_INSERT:\r\n if (Shift * KeyboardShiftStates = [ssShift]) then\r\n FDataLink.Edit;\r\n else\r\n FDataLink.Edit;\r\n end;\r\nend;\r\n\r\n///////////////////////////////////////////////////////////////////////////\r\n//procedure TJvDBDateTimePicker.KeyPress\r\n//Parameter : Key as Char by references when the key changes it will\r\n// reflect to the sender parameter variable.\r\n//Description : Handling user action what should to do ?\r\n// Hmmm... ok, first of all the character that user typed\r\n// should be checked, if it is invalid ignored the character.\r\n// Otherwise, tell to datalink that the mode should change\r\n// to edit.\r\n//Revision : August 30, 2000\r\n//Author : -ekosbg-\r\n///////////////////////////////////////////////////////////////////////////\r\n\r\nprocedure TJvDBDateTimePicker.KeyPress(var Key: Char);\r\nbegin\r\n if FIsReadOnly and not FDataLink.CanModify then\r\n begin\r\n if BeepOnError then\r\n Beep;\r\n Key := #0;\r\n Exit;\r\n end;\r\n\r\n inherited KeyPress(Key);\r\n if CharInSet(Key, [#32..#255]) and ((Field <> nil) and\r\n not (Field.IsValidChar(Key))) then\r\n begin\r\n if BeepOnError then\r\n Beep;\r\n Key := #0;\r\n end;\r\n case Key of\r\n #32..#255:\r\n FDataLink.Edit;\r\n Esc:\r\n begin\r\n FDataLink.Reset;\r\n SetFocus;\r\n Key := #0;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvDBDateTimePicker.Notification(AComponent: TComponent;\r\n Operation: TOperation);\r\nbegin\r\n inherited Notification(AComponent, Operation);\r\n if (Operation = opRemove) and (FDataLink <> nil) and (AComponent = DataSource) then\r\n DataSource := nil;\r\nend;\r\n\r\n///////////////////////////////////////////////////////////////////////////\r\n//procedure TJvDBDateTimePicker.SetDataField\r\n//Parameter : Value as String\r\n//Description : The procedure is handling the capability to set the\r\n// DataField property\r\n//Revision : August 30, 2000\r\n//Author : -ekosbg-\r\n///////////////////////////////////////////////////////////////////////////\r\n\r\nprocedure TJvDBDateTimePicker.SetDataField(const Value: string);\r\nbegin\r\n FDataLink.FieldName := Value;\r\nend;\r\n\r\n///////////////////////////////////////////////////////////////////////////\r\n//procedure TJvDBDateTimePicker.SetDataSource\r\n//Parameter : Value as TDataSource\r\n//Description : The procedure is handling the capability to set the\r\n// DataSource property\r\n//Revision : August 30, 2000\r\n//Author : -ekosbg-\r\n///////////////////////////////////////////////////////////////////////////\r\n\r\nprocedure TJvDBDateTimePicker.SetDataSource(Value: TDataSource);\r\nbegin\r\n FDataLink.DataSource := Value;\r\nend;\r\n\r\nprocedure TJvDBDateTimePicker.SetReadOnly(Value: Boolean);\r\nbegin\r\n FDataLink.ReadOnly := Value;\r\nend;\r\n\r\n///////////////////////////////////////////////////////////////////////////\r\n//procedure TJvDBDateTimePicker.UpdateDate\r\n//Parameter :\r\n//Description : We should change the value in datalink, and this is the\r\n// procedure to handle that event. It will assign with\r\n// event property Datalink, that is OnUpdateData\r\n//Revision : August 30, 2000\r\n//Author : -ekosbg-\r\n///////////////////////////////////////////////////////////////////////////\r\n\r\nprocedure TJvDBDateTimePicker.UpdateData(Sender: TObject);\r\nbegin\r\n // update value in datalink with date value in control, not from system\r\n // DataLink field might be empty\r\n if (Field = nil) or not FDataLink.Editing then\r\n Exit;\r\n \r\n if Kind = dtkDate then\r\n begin\r\n if Trunc(NullDate) = Trunc(DateTime) then\r\n if TrimValue or not IsDateAndTimeField then\r\n Field.Value := Null\r\n else\r\n Field.AsDateTime := Frac(DateTime)\r\n else\r\n if TrimValue or not IsDateAndTimeField then\r\n Field.AsDateTime := Int(DateTime)\r\n else\r\n Field.AsDateTime := DateTime;\r\n end\r\n else\r\n //if IsDateAndTimeField then ahuser: Mantis #5191; with this condition the Kind = dtkTime doesn't update the field anymore\r\n begin\r\n if Frac(NullDate) = Frac(DateTime) then\r\n if TrimValue then\r\n Field.Value := Null\r\n else\r\n Field.AsDateTime := Int(DateTime)\r\n else\r\n if TrimValue then\r\n Field.AsDateTime := Frac(DateTime)\r\n else\r\n Field.AsDateTime := DateTime;\r\n end;\r\nend;\r\n\r\nprocedure TJvDBDateTimePicker.WMPaint(var Msg: TWMPaint);\r\nvar\r\n D: TDateTime;\r\n ST: TSystemTime;\r\nbegin\r\n if not (csPaintCopy in ControlState) then\r\n inherited\r\n else\r\n begin\r\n // DataLink field might be empty\r\n if Field <> nil then\r\n begin\r\n if IsNullOrEmptyStringField(Field) then\r\n D := 0\r\n else if Kind = dtkDate then\r\n begin\r\n if IsDateAndTimeField then\r\n D := Field.AsDateTime\r\n else\r\n D := Int(Field.AsDateTime);\r\n end\r\n else\r\n begin\r\n if IsDateAndTimeField then\r\n D := Field.AsDateTime\r\n else\r\n D := Frac(Field.AsDateTime);\r\n end;\r\n end\r\n else\r\n D := Now; // Default value for date time edits\r\n\r\n DateTimeToSystemTime(D, ST);\r\n DateTime_SetSystemTime(FPaintControl.Handle, GDT_VALID, ST);\r\n SendMessage(FPaintControl.Handle, WM_ERASEBKGND, Msg.DC, 0);\r\n SendMessage(FPaintControl.Handle, WM_PAINT, Msg.DC, 0);\r\n end;\r\nend;\r\n\r\nprocedure TJvDBDateTimePicker.WMLButtonDown(var Msg: TWMLButtonDown);\r\nbegin\r\n if FIsReadOnly and not FDataLink.CanModify then\r\n begin\r\n SendCancelMode(Self);\r\n SetFocus;\r\n end\r\n else\r\n inherited;\r\nend;\r\n\r\nprocedure TJvDBDateTimePicker.CNNotify(var Msg: TWMNotify);\r\nvar\r\n st: TSystemTime;\r\nbegin\r\n case Msg.NMHdr^.code of\r\n DTN_DATETIMECHANGE:\r\n begin\r\n FDataLink.Edit;\r\n if FIsReadOnly and not FDataLink.CanModify then\r\n begin\r\n DateTimeToSystemTime(DateTime, st);\r\n MsgSetDateTime(st);\r\n Exit;\r\n end\r\n else if (Kind = dtkTime) and Assigned(Field) then\r\n begin\r\n Field.Value := SystemTimeToDateTime(PNMDateTimeChange(Msg.NMHdr).st);\r\n Exit;\r\n end;\r\n end;\r\n end;\r\n inherited;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvDBDotNetControls.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvDBDotNetCtrls.PAS, released on 2004-01-01.\r\n\r\nThe Initial Developer of the Original Code is Marc Hoffman.\r\nPortions created by Marc Hoffman are Copyright (C) 2002 APRIORI business solutions AG.\r\nPortions created by APRIORI business solutions AG are Copyright (C) 2002 APRIORI business solutions AG\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvDBDotNetControls.pas 12461 2009-08-14 17:21:33Z obones $\r\n\r\nunit JvDBDotNetControls;\r\n\r\n{$I jvcl.inc}\r\n\r\n{$IFDEF DelphiPersonalEdition}\r\n\r\ninterface\r\n\r\n{$IFDEF UNITVERSIONING}\r\nuses\r\n JclUnitVersioning;\r\n\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvDBDotNetControls.pas $';\r\n Revision: '$Revision: 12461 $';\r\n Date: '$Date: 2009-08-14 19:21:33 +0200 (ven. 14 août 2009) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\n{$ELSE}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, Messages, Classes, Controls, DBCtrls,\r\n JvDBFindEdit, JVCLVer, JvDotNetUtils;\r\n\r\ntype\r\n TJvDotNetDBEdit = class(TDBEdit)\r\n private\r\n FAboutJVCL: TJVCLAboutInfo;\r\n FHighlighted: Boolean;\r\n FOldWindowProc: TWndMethod;\r\n procedure InternalWindowProc(var Msg: TMessage);\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n published\r\n property AboutJVCL: TJVCLAboutInfo read FAboutJVCL write FAboutJVCL stored False;\r\n end;\r\n\r\n TJvDotNetDBListBox = class(TDBListBox)\r\n private\r\n FAboutJVCL: TJVCLAboutInfo;\r\n FHighlighted: Boolean;\r\n FOldWindowProc: TWndMethod;\r\n procedure InternalWindowProc(var Msg: TMessage);\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n published\r\n property AboutJVCL: TJVCLAboutInfo read FAboutJVCL write FAboutJVCL stored False;\r\n end;\r\n\r\n TJvDotNetDBLookupListBox = class(TDBLookupListBox)\r\n private\r\n FAboutJVCL: TJVCLAboutInfo;\r\n FHighlighted: Boolean;\r\n FOldWindowProc: TWndMethod;\r\n procedure InternalWindowProc(var Msg: TMessage);\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n published\r\n property AboutJVCL: TJVCLAboutInfo read FAboutJVCL write FAboutJVCL stored False;\r\n end;\r\n\r\n TJvDotNetDBMemo = class(TDBMemo)\r\n private\r\n FAboutJVCL: TJVCLAboutInfo;\r\n FHighlighted: Boolean;\r\n FOldWindowProc: TWndMethod;\r\n procedure InternalWindowProc(var Msg: TMessage);\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n published\r\n property AboutJVCL: TJVCLAboutInfo read FAboutJVCL write FAboutJVCL stored False;\r\n end;\r\n\r\n TJvDotNetDBRichEdit = class(TDBRichEdit)\r\n private\r\n FAboutJVCL: TJVCLAboutInfo;\r\n FHighlighted: Boolean;\r\n FOldWindowProc: TWndMethod;\r\n procedure InternalWindowProc(var Msg: TMessage);\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n published\r\n property AboutJVCL: TJVCLAboutInfo read FAboutJVCL write FAboutJVCL stored False;\r\n end;\r\n\r\n TJvDotNetDBFindEdit = class(TJvDBFindEdit)\r\n private\r\n FHighlighted: Boolean;\r\n FOldWindowProc: TWndMethod;\r\n procedure InternalWindowProc(var Msg: TMessage);\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvDBDotNetControls.pas $';\r\n Revision: '$Revision: 12461 $';\r\n Date: '$Date: 2009-08-14 19:21:33 +0200 (ven. 14 août 2009) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\n//=== { TJvDotNetDBEdit } ====================================================\r\n\r\nconstructor TJvDotNetDBEdit.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FOldWindowProc := WindowProc;\r\n WindowProc := InternalWindowProc;\r\nend;\r\n\r\ndestructor TJvDotNetDBEdit.Destroy;\r\nbegin\r\n WindowProc := FOldWindowProc;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvDotNetDBEdit.InternalWindowProc(var Msg: TMessage);\r\nbegin\r\n FOldWindowProc(Msg);\r\n DotNetMessageHandler(Msg, Self, Color, FHighlighted);\r\nend;\r\n\r\n//=== { TJvDotNetDBListBox } =================================================\r\n\r\nconstructor TJvDotNetDBListBox.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FOldWindowProc := WindowProc;\r\n WindowProc := InternalWindowProc;\r\nend;\r\n\r\ndestructor TJvDotNetDBListBox.Destroy;\r\nbegin\r\n WindowProc := FOldWindowProc;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvDotNetDBListBox.InternalWindowProc(var Msg: TMessage);\r\nbegin\r\n FOldWindowProc(Msg);\r\n DotNetMessageHandler(Msg, Self, Color, FHighlighted);\r\nend;\r\n\r\n//=== { TJvDotNetDBLookupListBox } ===========================================\r\n\r\nconstructor TJvDotNetDBLookupListBox.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FOldWindowProc := WindowProc;\r\n WindowProc := InternalWindowProc;\r\nend;\r\n\r\ndestructor TJvDotNetDBLookupListBox.Destroy;\r\nbegin\r\n WindowProc := FOldWindowProc;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvDotNetDBLookupListBox.InternalWindowProc(var Msg: TMessage);\r\nbegin\r\n FOldWindowProc(Msg);\r\n DotNetMessageHandler(Msg, Self, Color, FHighlighted);\r\nend;\r\n\r\n//=== { TJvDotNetDBMemo } ====================================================\r\n\r\nconstructor TJvDotNetDBMemo.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FOldWindowProc := WindowProc;\r\n WindowProc := InternalWindowProc;\r\nend;\r\n\r\ndestructor TJvDotNetDBMemo.Destroy;\r\nbegin\r\n WindowProc := FOldWindowProc;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvDotNetDBMemo.InternalWindowProc(var Msg: TMessage);\r\nbegin\r\n FOldWindowProc(Msg);\r\n DotNetMessageHandler(Msg, Self, Color, FHighlighted);\r\nend;\r\n\r\n//=== { TJvDotNetDBRichEdit } ================================================\r\n\r\nconstructor TJvDotNetDBRichEdit.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FOldWindowProc := WindowProc;\r\n WindowProc := InternalWindowProc;\r\nend;\r\n\r\ndestructor TJvDotNetDBRichEdit.Destroy;\r\nbegin\r\n WindowProc := FOldWindowProc;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvDotNetDBRichEdit.InternalWindowProc(var Msg: TMessage);\r\nbegin\r\n FOldWindowProc(Msg);\r\n DotNetMessageHandler(Msg, Self, Color, FHighlighted);\r\nend;\r\n\r\n//=== { TJvDotNetDBFindEdit } ================================================\r\n\r\nconstructor TJvDotNetDBFindEdit.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FOldWindowProc := WindowProc;\r\n WindowProc := InternalWindowProc;\r\nend;\r\n\r\ndestructor TJvDotNetDBFindEdit.Destroy;\r\nbegin\r\n WindowProc := FOldWindowProc;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvDotNetDBFindEdit.InternalWindowProc(var Msg: TMessage);\r\nbegin\r\n FOldWindowProc(Msg);\r\n DotNetMessageHandler(Msg, Self, Color, FHighlighted);\r\nend;\r\n\r\n{$ENDIF DelphiPersonalEdition}\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend." }, { "path": "External/Jedi/Jvcl/run/JvDBFilterExpr.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvDBFilterExpr.pas, released on 2008-12-10.\r\n\r\nThe Initial Developers of the Original Code is: Andreas Hausladen\r\nCopyright (c) 2008 Andreas Hausladen [Andreas DOTT Hausladen ATT gmx DOTT de]\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvDBFilterExpr.pas 13003 2011-03-16 20:51:04Z jfudickar $\r\n\r\nunit JvDBFilterExpr;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n SysUtils, Classes, Variants, DB, DBCommon;\r\n\r\ntype\r\n TJvDBFilterExpression = class(TObject)\r\n private\r\n FDataSet: TDataSet;\r\n FParser: TExprParser;\r\n FRoot: PExprNode;\r\n function EvalOpNode(N: PExprNode): Boolean;\r\n function EvalFuncNode(N: PExprNode): Variant;\r\n function EvaluateNode(N: PExprNode): Variant;\r\n public\r\n constructor Create(ADataSet: TDataSet; const Filter: string; const FilterOptions: TFilterOptions);\r\n destructor Destroy; override;\r\n function Evaluate: Boolean;\r\n end;\r\n\r\nimplementation\r\n\r\nuses\r\n SqlTimSt, DateUtils, JvResources, JclSysUtils;\r\n\r\nvar\r\n FieldTypeMapInitialized: Boolean = False;\r\n FieldTypeMap: TFieldMap;\r\n\r\ntype\r\n TExprParserAccess = class\r\n protected\r\n FDecimalSeparator: {$IF CompilerVersion > 17.0}WideChar{$ELSE}Char{$IFEND}; // Delphi 2006+ use WideChar\r\n FFilter: TFilterExpr;\r\n end;\r\n\r\n TFilterExprAccess = class\r\n protected\r\n FDataSet: TDataSet;\r\n FFieldMap: TFieldMap;\r\n FOptions: TFilterOptions;\r\n FParserOptions: TParserOptions;\r\n FNodes: PExprNode;\r\n end;\r\n\r\n{------------------------------------------------------------------------------}\r\nfunction TrimLeftEx(const S, Blanks: string): string;\r\nvar\r\n I, Len: Integer;\r\nbegin\r\n Len := Length(S);\r\n I := 1;\r\n while (I <= Len) and (Pos(S[I], Blanks) > 0) do\r\n Inc(I);\r\n Result := Copy(S, I, MaxInt);\r\nend;\r\n\r\nfunction TrimRightEx(const S, Blanks: string): string;\r\nvar\r\n I: Integer;\r\nbegin\r\n I := Length(S);\r\n while (I > 0) and (Pos(S[I], Blanks) > 0) do\r\n Dec(I);\r\n Result := Copy(S, 1, I);\r\nend;\r\n\r\nfunction TrimEx(const S, Blanks: string): string;\r\nvar\r\n L, R, Len: Integer;\r\nbegin\r\n Len := Length(S);\r\n L := 1;\r\n while (L <= Len) and (Pos(S[L], Blanks) > 0) do\r\n Inc(L);\r\n R := Len;\r\n while (R >= L) and (Pos(S[R], Blanks) > 0) do\r\n Dec(R);\r\n Result := Copy(S, L, R - L + 1);\r\nend;\r\n\r\n// Derived from \"Like\" by Michael Winter\r\n\r\nfunction IsLike(const MaskStr, S: string): Boolean;\r\nvar\r\n StringPtr: PChar;\r\n PatternPtr: PChar;\r\n StringRes: PChar;\r\n PatternRes: PChar;\r\n Index: Integer;\r\nbegin\r\n if MaskStr = '' then\r\n begin\r\n Result := False;\r\n Exit;\r\n end;\r\n\r\n Result := MaskStr = '%';\r\n\r\n if Result or (S = '') then\r\n Exit;\r\n Index := 1;\r\n\r\n StringPtr := PChar(S) + Index - 1;\r\n PatternPtr := PChar(MaskStr);\r\n StringRes := nil;\r\n PatternRes := nil;\r\n\r\n repeat\r\n repeat\r\n case PatternPtr^ of\r\n #0:\r\n begin\r\n Result := StringPtr^ = #0;\r\n if Result or (StringRes = nil) or (PatternRes = nil) then\r\n Exit;\r\n\r\n StringPtr := StringRes;\r\n PatternPtr := PatternRes;\r\n Break;\r\n end;\r\n '%':\r\n begin\r\n Inc(PatternPtr);\r\n PatternRes := PatternPtr;\r\n Break;\r\n end;\r\n '_':\r\n begin\r\n if StringPtr^ = #0 then\r\n Exit;\r\n Inc(StringPtr);\r\n Inc(PatternPtr);\r\n end;\r\n else\r\n begin\r\n if StringPtr^ = #0 then\r\n Exit;\r\n if StringPtr^ <> PatternPtr^ then\r\n begin\r\n if (StringRes = nil) or (PatternRes = nil) then\r\n Exit;\r\n StringPtr := StringRes;\r\n PatternPtr := PatternRes;\r\n Break;\r\n end\r\n else\r\n begin\r\n Inc(StringPtr);\r\n Inc(PatternPtr);\r\n end;\r\n end;\r\n end;\r\n until False;\r\n\r\n repeat\r\n case PatternPtr^ of\r\n #0:\r\n begin\r\n Result := True;\r\n Exit;\r\n end;\r\n '%':\r\n begin\r\n Inc(PatternPtr);\r\n PatternRes := PatternPtr;\r\n end;\r\n '_':\r\n begin\r\n if StringPtr^ = #0 then\r\n Exit;\r\n Inc(StringPtr);\r\n Inc(PatternPtr);\r\n end;\r\n else\r\n begin\r\n repeat\r\n if StringPtr^ = #0 then\r\n Exit;\r\n if StringPtr^ = PatternPtr^ then\r\n Break;\r\n Inc(StringPtr);\r\n until False;\r\n Inc(StringPtr);\r\n StringRes := StringPtr;\r\n Inc(PatternPtr);\r\n Break;\r\n end;\r\n end;\r\n until False;\r\n until False;\r\nend;\r\n{------------------------------------------------------------------------------}\r\n\r\n{ TJvDBFilterExpression }\r\n\r\nconstructor TJvDBFilterExpression.Create(ADataSet: TDataSet; const Filter: string;\r\n const FilterOptions: TFilterOptions);\r\nvar\r\n FieldType: TFieldType;\r\n Nodes: PExprNode;\r\n\r\n function NodesContainsLeftRight(Root: PExprNode): Boolean;\r\n var\r\n Node: PExprNode;\r\n begin\r\n Result := True;\r\n Node := Nodes;\r\n while Node <> nil do\r\n begin\r\n if (Node.FLeft = Root) or (Node.FRight = Root) then\r\n Exit;\r\n Node := Node.FNext;\r\n end;\r\n Result := False;\r\n end;\r\n\r\nbegin\r\n inherited Create;\r\n FDataSet := ADataSet;\r\n\r\n if not FieldTypeMapInitialized then\r\n begin\r\n FieldTypeMapInitialized := True;\r\n for FieldType := Low(FieldType) to High(FieldType) do\r\n FieldTypeMap[FieldType] := Ord(FieldType);\r\n end;\r\n FParser := TExprParser.Create(ADataSet, Filter, [], [poExtSyntax], '', nil, FieldTypeMap);\r\n Nodes := TFilterExprAccess(TExprParserAccess(FParser).FFilter).FNodes;\r\n\r\n { Find root node because FNodes is the last added node which must not be the root node.\r\n The root node is the node which istn't referenced by any other node's Left or Right field. }\r\n if Nodes <> nil then\r\n begin\r\n FRoot := Nodes;\r\n while (FRoot.FNext <> nil) and not ((FRoot.FKind = enOperator) and not NodesContainsLeftRight(FRoot)) do\r\n FRoot := FRoot.FNext;\r\n end;\r\nend;\r\n\r\ndestructor TJvDBFilterExpression.Destroy;\r\nbegin\r\n FParser.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJvDBFilterExpression.Evaluate: Boolean;\r\nbegin\r\n Result := EvalOpNode(FRoot);\r\nend;\r\n\r\nfunction TJvDBFilterExpression.EvaluateNode(N: PExprNode): Variant;\r\nbegin\r\n if N = nil then\r\n Result := Unassigned\r\n else\r\n begin\r\n case N.FKind of\r\n enOperator:\r\n Result := EvalOpNode(N);\r\n enConst:\r\n Result := N.FData;\r\n enField:\r\n Result := FDataSet.FieldByName(N.FData).AsVariant;\r\n enFunc:\r\n Result := EvalFuncNode(N);\r\n else\r\n raise Exception.CreateRes(@RsInvalidFilterNodeKind);\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJvDBFilterExpression.EvalOpNode(N: PExprNode): Boolean;\r\nvar\r\n I: Integer;\r\n V: Variant;\r\nbegin\r\n if N = nil then\r\n Result := False\r\n else\r\n begin\r\n Assert(N.FKind = enOperator);\r\n case N.FOperator of\r\n coEQ:\r\n Result := EvaluateNode(N.FLeft) = EvaluateNode(N.FRight);\r\n coNE:\r\n Result := EvaluateNode(N.FLeft) <> EvaluateNode(N.FRight);\r\n coGT:\r\n Result := EvaluateNode(N.FLeft) > EvaluateNode(N.FRight);\r\n coLT:\r\n Result := EvaluateNode(N.FLeft) < EvaluateNode(N.FRight);\r\n coGE:\r\n Result := EvaluateNode(N.FLeft) >= EvaluateNode(N.FRight);\r\n coLE:\r\n Result := EvaluateNode(N.FLeft) <= EvaluateNode(N.FRight);\r\n coNOT:\r\n Result := not EvaluateNode(N.FLeft);\r\n coAND:\r\n Result := LongBool(EvaluateNode(N.FLeft)) and LongBool(EvaluateNode(N.FRight));\r\n coOR:\r\n Result := LongBool(EvaluateNode(N.FLeft)) or LongBool(EvaluateNode(N.FRight));\r\n coISBLANK:\r\n Result := VarIsNull(EvaluateNode(N.FLeft));\r\n coNOTBLANK:\r\n Result := not VarIsNull(EvaluateNode(N.FLeft));\r\n coLIKE:\r\n Result := IsLike(EvaluateNode(N.FLeft), EvaluateNode(N.FRight));\r\n coIN:\r\n begin\r\n Result := False;\r\n V := EvaluateNode(N.FLeft);\r\n if N.FArgs <> nil then\r\n begin\r\n for I := 0 to N.FArgs.Count - 1 do\r\n begin\r\n if V = EvaluateNode(N.FArgs[I]) then\r\n begin\r\n Result := True;\r\n Break;\r\n end;\r\n end;\r\n end;\r\n end;\r\n coMINUS:\r\n Result := -EvaluateNode(N.FLeft);\r\n coADD:\r\n Result := EvaluateNode(N.FLeft) + EvaluateNode(N.FRight);\r\n coSUB:\r\n Result := EvaluateNode(N.FLeft) - EvaluateNode(N.FRight);\r\n coMUL:\r\n Result := EvaluateNode(N.FLeft) * EvaluateNode(N.FRight);\r\n coDIV:\r\n Result := EvaluateNode(N.FLeft) / EvaluateNode(N.FRight);\r\n else\r\n raise Exception.CreateRes(@RsUnknownFilterOperation);\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJvDBFilterExpression.EvalFuncNode(N: PExprNode): Variant;\r\nvar\r\n V: Variant;\r\nbegin\r\n if N = nil then\r\n Result := Unassigned\r\n else\r\n begin\r\n if (N.FArgs <> nil) and (N.FArgs.Count > 0) then\r\n begin\r\n V := EvaluateNode(N.FArgs[0]);\r\n\r\n if CompareText(N.FData, 'UPPER') = 0 then\r\n Result := AnsiUpperCase(V)\r\n else\r\n if CompareText(N.FData, 'LOWER') = 0 then\r\n Result := AnsiLowerCase(V)\r\n else\r\n if CompareText(N.FData, 'TRIM') = 0 then\r\n begin\r\n if N.FArgs.Count = 1 then\r\n Result := Trim(V)\r\n else\r\n Result := TrimEx(V, EvaluateNode(N.FArgs[1]));\r\n end\r\n else\r\n if CompareText(N.FData, 'TRIMLEFT') = 0 then\r\n begin\r\n if N.FArgs.Count = 1 then\r\n Result := TrimLeft(V)\r\n else\r\n Result := TrimLeftEx(V, EvaluateNode(N.FArgs[1]));\r\n end\r\n else\r\n if CompareText(N.FData, 'TRIMRIGHT') = 0 then\r\n begin\r\n if N.FArgs.Count = 1 then\r\n Result := TrimRight(V)\r\n else\r\n Result := TrimRightEx(V, EvaluateNode(N.FArgs[1]));\r\n end\r\n else\r\n if CompareText(N.FData, 'SUBSTRING') = 0 then\r\n begin\r\n if N.FArgs.Count = 2 then\r\n Result := Copy(V, Integer(EvaluateNode(N.FArgs[1])), MaxInt)\r\n else\r\n Result := Copy(V, Integer(EvaluateNode(N.FArgs[1])), Integer(EvaluateNode(N.FArgs[2])));\r\n end\r\n else\r\n if CompareText(N.FData, 'YEAR') = 0 then\r\n begin\r\n if VarIsNullEmpty(V) then Result := -1 else\r\n Result := YearOf(V);\r\n end\r\n else\r\n if CompareText(N.FData, 'MONTH') = 0 then\r\n begin\r\n if VarIsNullEmpty(V) then Result := -1 else\r\n Result := MonthOf(V);\r\n end\r\n else\r\n if CompareText(N.FData, 'DAY') = 0 then\r\n begin\r\n if VarIsNullEmpty(V) then Result := -1 else\r\n Result := DayOf(V);\r\n end\r\n else\r\n if CompareText(N.FData, 'HOUR') = 0 then\r\n begin\r\n if VarIsNullEmpty(V) then Result := -1 else\r\n Result := HourOf(V);\r\n end\r\n else\r\n if CompareText(N.FData, 'MINUTE') = 0 then\r\n begin\r\n if VarIsNullEmpty(V) then Result := -1 else\r\n Result := MinuteOf(V);\r\n end\r\n else\r\n if CompareText(N.FData, 'SECOND') = 0 then\r\n begin\r\n if VarIsNullEmpty(V) then Result := -1 else\r\n Result := SecondOf(V);\r\n end\r\n else\r\n if CompareText(N.FData, 'TIME') = 0 then\r\n begin\r\n if VarIsNullEmpty(V) then Result := NULL else\r\n Result := VarSQLTimeStampCreate(TimeOf(V));\r\n end\r\n else\r\n if CompareText(N.FData, 'DATE') = 0 then\r\n begin\r\n if VarIsNullEmpty(V) then Result := NULL else\r\n Result := VarSQLTimeStampCreate(DateOf(V));\r\n end\r\n else\r\n raise Exception.CreateResFmt(@RsUnknownFilterFunction, [N.FData]);\r\n end\r\n else\r\n raise Exception.CreateResFmt(@RsMissingFilterFunctionParameters, [N.FData]);\r\n end;\r\nend;\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvDBFindEdit.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvDBFindEdit.pas, released 2004-03-23\r\n\r\nThe Initial Developer of the Original Code is yul\r\nPortions created by yul are Copyright (C) 2004 yul.\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\n\r\nCurrent Version: 0.50\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvDBFindEdit.pas 13104 2011-09-07 06:50:43Z obones $\r\n\r\nunit JvDBFindEdit;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, Classes, Controls, ExtCtrls, DB, DBCtrls,\r\n JvMaskEdit;\r\n\r\ntype\r\n TJvEditFindStyle = (fsNavigate, fsFilter);\r\n TJvEditFindMode = (fmFirstPos, fmAnyPos);\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvDBFindEdit = class(TJvMaskEdit)\r\n private\r\n FTimer: TTimer;\r\n FOldFiltered: Boolean;\r\n FOldFilterRecord: TFilterRecordEvent;\r\n FDataLink: TFieldDataLink;\r\n FIgnoreCase: Boolean;\r\n FFindMode: TJvEditFindMode;\r\n FFindStyle: TJvEditFindStyle;\r\n FSearchText: string;\r\n procedure ActiveChange(Sender: TObject);\r\n function GetDataField: string;\r\n function GetDataSource: TDataSource;\r\n procedure SetDataField(const Value: string);\r\n procedure SetDataSource(const Value: TDataSource);\r\n procedure SetFindMode(const Value: TJvEditFindMode);\r\n procedure SetFindStyle(const Value: TJvEditFindStyle);\r\n procedure SetIgnoreCase(const Value: Boolean);\r\n procedure FTimerTimer(Sender: TObject);\r\n procedure AFilterRecord(DataSet: TDataSet; var Accept: Boolean);\r\n protected\r\n procedure Change; override;\r\n procedure Notification(AComponent: TComponent; Operation: TOperation); override;\r\n function DateVal: Boolean;\r\n function IsDate(const S1: string): Boolean;\r\n function GetDateDelimiter: string;\r\n function IsNumeric(const S1: string): Boolean;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n procedure Find(const AText: string);\r\n procedure ResetFilter;\r\n published\r\n property DataField: string read GetDataField write SetDataField;\r\n property DataSource: TDataSource read GetDataSource write SetDataSource;\r\n property FindStyle: TJvEditFindStyle read FFindStyle write SetFindStyle default fsNavigate;\r\n property FindMode: TJvEditFindMode read FFindMode write SetFindMode default fmFirstPos;\r\n property IgnoreCase: Boolean read FIgnoreCase write SetIgnoreCase default True;\r\n property Anchors;\r\n property AutoSelect;\r\n property AutoSize;\r\n property BorderStyle;\r\n property CharCase;\r\n property Color;\r\n property Constraints;\r\n property DragCursor;\r\n property Enabled;\r\n property BevelEdges;\r\n property BevelInner;\r\n property BevelKind default bkNone;\r\n property BevelOuter;\r\n property Flat;\r\n property ParentFlat;\r\n property Font;\r\n property HideSelection;\r\n property MaxLength;\r\n Property EditMask;\r\n property ParentColor;\r\n property ParentFont;\r\n property ParentShowHint;\r\n property PasswordChar;\r\n property PopupMenu;\r\n property ReadOnly;\r\n property ShowHint;\r\n property TabOrder;\r\n property TabStop;\r\n property Visible;\r\n property OnChange;\r\n property OnClick;\r\n property OnDblClick;\r\n property OnDragDrop;\r\n property OnDragOver;\r\n property OnEndDock;\r\n property OnEndDrag;\r\n property OnEnter;\r\n property OnExit;\r\n property OnKeyDown;\r\n property OnKeyPress;\r\n property OnKeyUp;\r\n property OnMouseDown;\r\n property OnMouseMove;\r\n property OnMouseUp;\r\n property OnStartDock;\r\n property OnStartDrag;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvDBFindEdit.pas $';\r\n Revision: '$Revision: 13104 $';\r\n Date: '$Date: 2011-09-07 08:50:43 +0200 (mer. 07 sept. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n {$IFNDEF COMPILER12_UP}\r\n JvJCLUtils,\r\n {$ENDIF ~COMPILER12_UP}\r\n SysUtils;\r\n\r\nconstructor TJvDBFindEdit.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FFindStyle := fsNavigate;\r\n FFindMode := fmFirstPos;\r\n FIgnoreCase := True;\r\n FTimer := TTimer.Create(Self);\r\n FTimer.Enabled := False;\r\n FTimer.Interval := 400;\r\n FTimer.OnTimer := FTimerTimer;\r\n FSearchText := '';\r\n FOldFiltered := False;\r\n FOldFilterRecord := nil;\r\n FDataLink := TFieldDataLink.Create;\r\n FDataLink.Control := Self;\r\n FDataLink.OnActiveChange := ActiveChange;\r\nend;\r\n\r\ndestructor TJvDBFindEdit.Destroy;\r\nbegin\r\n if FDataLink.Active and (FFindStyle = fsFilter) then\r\n begin\r\n FDataLink.DataSet.OnFilterRecord := FOldFilterRecord;\r\n FDataLink.DataSet.Filtered := FOldFiltered;\r\n end;\r\n FDataLink.Control := nil;\r\n DataSource := nil;\r\n FDataLink.Free;\r\n FDataLink := nil;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvDBFindEdit.Change;\r\nbegin\r\n FTimer.Enabled := False;\r\n if Text = '' then\r\n FTimer.Interval := 400;\r\n FTimer.Enabled := True;\r\n FSearchText := Text;\r\n inherited Change;\r\nend;\r\n\r\n// (ahuser) Compiler gives hint for unused value. This function prevents it\r\nfunction ToDoubleVal(const S: string; var Err: Integer): Double;\r\nbegin\r\n Val(S, Result, Err);\r\nend;\r\n\r\nfunction TJvDBFindEdit.IsNumeric(const S1: string): Boolean;\r\nvar\r\n Err: Integer;\r\nbegin\r\n Result := True;\r\n ToDoubleVal(S1, Err);\r\n if Err > 0 then\r\n Result := False;\r\nend;\r\n\r\nfunction TJvDBFindEdit.GetDateDelimiter: string;\r\nvar\r\n S1: string;\r\n I: Integer;\r\nbegin\r\n S1 := DateTimeToStr(Now);\r\n for I := 1 to Length(S1) do\r\n if not CharInSet(S1[I], ['0'..'9']) then\r\n begin\r\n Result := S1[I];\r\n Break;\r\n end;\r\nend;\r\n\r\nfunction TJvDBFindEdit.IsDate(const S1: string): Boolean;\r\nvar\r\n I, k, p1, p2: Integer;\r\n sm, sd, sj, ss: string;\r\nbegin\r\n Result := False;\r\n ss := GetDateDelimiter;\r\n k := Length(S1);\r\n if k > 0 then\r\n begin\r\n p1 := 0;\r\n p2 := 0;\r\n for I := 1 to k do\r\n begin\r\n if p1 = 0 then\r\n begin\r\n if S1[I] = ss then\r\n p1 := I;\r\n end\r\n else\r\n begin\r\n if S1[I] = ss then\r\n p2 := I;\r\n end;\r\n end;\r\n if (p1 > 0) and (p2 > 0) and (p2 > p1) then\r\n begin\r\n sm := Copy(S1, 1, p1 - 1);\r\n sd := Copy(S1, p1 + 1, p2 - p1 -1);\r\n sj := Copy(S1, p2 + 1, k - p2);\r\n if IsNumeric(sm) and IsNumeric(sd) and IsNumeric(sj) then\r\n begin\r\n p1 := StrToInt(sd);\r\n if (p1 > 0) and (p1 < 32) then\r\n begin\r\n p1 := StrToInt(sm);\r\n if (p1 > 0) and (p1 < 13) then\r\n begin\r\n p1 := StrToInt(sj);\r\n if p1 > 1969 then\r\n Result := True;\r\n end;\r\n end;\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJvDBFindEdit.DateVal: Boolean;\r\nbegin\r\n Result := True;\r\n if FDataLink.Field is TDateField then\r\n if not IsDate(FSearchText) then\r\n Result := False;\r\n\r\n if IsDate(FSearchText) then\r\n //begin\r\n // DateSeparator :='/';\r\n // ShortDateFormat := 'mm/dd/yyyy';\r\n FSearchText := DateToStr(StrToDate(FSearchText));\r\n //end;\r\nend;\r\n\r\nprocedure TJvDBFindEdit.ResetFilter;\r\nbegin\r\n Text := ''; // updates FSearchText\r\n FTimerTimer(FTimer); // if the developer calls ResetFilter we have to do it now and not later (timer)\r\n FDataLink.DataSet.Filtered := False;\r\nend;\r\n\r\nprocedure TJvDBFindEdit.FTimerTimer(Sender: TObject);\r\nbegin\r\n FTimer.Enabled := False;\r\n ActiveChange(Self);\r\n if FFindStyle = fsFilter then\r\n FDataLink.DataSet.Filtered := False;\r\n if FSearchText = '' then\r\n begin\r\n if FFindStyle = fsFilter then\r\n begin\r\n FDataLink.DataSet.OnFilterRecord := FOldFilterRecord;\r\n FDataLink.DataSet.Filtered := FOldFiltered;\r\n end;\r\n end\r\n else\r\n begin\r\n if not FDataLink.Active or (FDataLink.Field = nil) then\r\n Exit;\r\n if DateVal and not (FDataLink.Field is TBlobField) then\r\n if FFindStyle = fsNavigate then\r\n begin\r\n if IgnoreCase then\r\n FDataLink.DataSet.Locate(DataField, FSearchText, [loCaseInsensitive, loPartialKey])\r\n else\r\n FDataLink.DataSet.Locate(DataField, FSearchText, [loPartialKey]);\r\n end\r\n else\r\n FDataLink.DataSet.Filtered := True;\r\n end;\r\n if FSearchText <> '' then // Do not change it if we just set it to 400 in Change()\r\n FTimer.Interval := 100;\r\nend;\r\n\r\nprocedure TJvDBFindEdit.Find(const AText: string);\r\nbegin\r\n FSearchText := AText;\r\n FTimerTimer(FTimer);\r\nend;\r\n\r\nprocedure TJvDBFindEdit.AFilterRecord(DataSet: TDataSet; var Accept: Boolean);\r\nbegin\r\n Accept := True;\r\n if FOldFiltered and Assigned(FOldFilterRecord) then\r\n FOldFilterRecord(DataSet, Accept);\r\n if not Accept then\r\n Exit;\r\n if FFindMode = fmFirstPos then\r\n begin\r\n if IgnoreCase then\r\n Accept := Pos(AnsiUpperCase(FSearchText),\r\n AnsiUpperCase(DataSet.FieldByName(DataField).AsString)) = 1\r\n else\r\n Accept := Pos(FSearchText, DataSet.FieldByName(DataField).AsString) = 1;\r\n end\r\n else\r\n begin\r\n if IgnoreCase then\r\n Accept := Pos(AnsiUpperCase(FSearchText),\r\n AnsiUpperCase(DataSet.FieldByName(DataField).AsString)) > 0\r\n else\r\n Accept := Pos(FSearchText, DataSet.FieldByName(DataField).AsString) > 0;\r\n end;\r\nend;\r\n\r\nprocedure TJvDBFindEdit.ActiveChange(Sender: TObject);\r\nvar\r\n Func1, Func2: TFilterRecordEvent;\r\nbegin\r\n if (FFindStyle = fsNavigate) or (FDataLink.DataSet = nil) then\r\n Exit;\r\n Func1 := FDataLink.DataSet.OnFilterRecord;\r\n Func2 := AFilterRecord;\r\n if FDataLink.Active and (@Func1 <> @Func2) and (FSearchText <> '') then\r\n begin\r\n FOldFilterRecord := FDataLink.DataSet.OnFilterRecord;\r\n FOldFiltered := FDataLink.DataSet.Filtered;\r\n FDataLink.DataSet.OnFilterRecord := AFilterRecord;\r\n end;\r\nend;\r\n\r\nfunction TJvDBFindEdit.GetDataSource: TDataSource;\r\nbegin\r\n Result := FDataLink.DataSource;\r\nend;\r\n\r\nprocedure TJvDBFindEdit.SetDataSource(const Value: TDataSource);\r\nbegin\r\n if not (FDataLink.DataSourceFixed and (csLoading in ComponentState)) then\r\n begin\r\n if FDataLink.DataSource <> nil then\r\n FDataLink.DataSource.RemoveFreeNotification(Self);\r\n FDataLink.DataSource := Value;\r\n end;\r\n if Value <> nil then\r\n Value.FreeNotification(Self);\r\nend;\r\n\r\nfunction TJvDBFindEdit.GetDataField: string;\r\nbegin\r\n Result := FDataLink.FieldName;\r\nend;\r\n\r\nprocedure TJvDBFindEdit.SetDataField(const Value: string);\r\nbegin\r\n if Value <> FDataLink.FieldName then\r\n FDataLink.FieldName := Value;\r\nend;\r\n\r\nprocedure TJvDBFindEdit.SetFindMode(const Value: TJvEditFindMode);\r\nbegin\r\n if FFindStyle = fsNavigate then\r\n FFindMode := fmFirstPos\r\n else\r\n FFindMode := Value;\r\nend;\r\n\r\nprocedure TJvDBFindEdit.SetFindStyle(const Value: TJvEditFindStyle);\r\nbegin\r\n FFindStyle := Value;\r\n if FFindStyle = fsNavigate then\r\n FFindMode := fmFirstPos;\r\n ActiveChange(Self);\r\nend;\r\n\r\nprocedure TJvDBFindEdit.SetIgnoreCase(const Value: Boolean);\r\nbegin\r\n FIgnoreCase := Value;\r\nend;\r\n\r\nprocedure TJvDBFindEdit.Notification(AComponent: TComponent;\r\n Operation: TOperation);\r\nbegin\r\n inherited Notification(AComponent, Operation);\r\n if Operation = opRemove then\r\n if (FDataLink <> nil) and (AComponent = DataSource) then\r\n DataSource := nil;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvDBGrid.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvDBGrid.PAS, released on 2002-07-04.\r\n\r\nThe Initial Developers of the Original Code are: Fedor Koshevnikov, Igor Pavluk and Serge Korolev\r\nCopyright (c) 1997, 1998 Fedor Koshevnikov, Igor Pavluk and Serge Korolev\r\nCopyright (c) 2001,2002 SGB Software\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\n Polaris Software\r\n Lionel Reynaud\r\n Flemming Brandt Clausen\r\n Frdric Leneuf-Magaud\r\n Andreas Hausladen\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\n-----------------------------------------------------------------------------\r\n\r\nINFO: Draw events are triggered in this order:\r\n\r\n- Title cells:\r\nOnGetBtnParams\r\nOnDrawColumnTitle\r\n\r\n- Data cells:\r\nOnGetCellParams\r\nOnDrawColumnCell\r\n\r\nOnGetCellProps and OnDrawDataCell are obsolete.\r\n\r\n-----------------------------------------------------------------------------\r\n\r\nKNOWN ISSUES:\r\n\r\n- THE ColLines OPTION DOES NOT WORK WELL WITH HIDDEN COLUMNS - BUG SOURCE: DBGRID.PAS\r\n If a column is followed by hidden columns and ColLines is set to False, the display size\r\n of the column is smaller than its width. This is easy to notice when you give the focus\r\n to the cell (the focus rect is truncated) or when you use the AutoSize feature (there's\r\n a gap after the last column). This bug comes from DBGrid.pas.\r\n\r\n-----------------------------------------------------------------------------\r\n2004/07/08 - WPostma merged changes by Frdric Leneuf-Magaud and ahuser.}\r\n\r\n// $Id: JvDBGrid.pas 13415 2012-09-10 09:51:54Z obones $\r\n\r\nunit JvDBGrid;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Types,\r\n Windows, Messages, Classes, Graphics, Controls, Grids, Menus, DBGrids, DB,\r\n StdCtrls, Forms, Contnrs,\r\n {$IFDEF HAS_UNIT_SYSTEM_UITYPES}\r\n System.UITypes,\r\n {$ENDIF HAS_UNIT_SYSTEM_UITYPES}\r\n JvTypes, {JvTypes contains Exception base class}\r\n JvAppStorage, JvFormPlacement, JvExDBGrids, JvDBUtils;\r\n\r\nconst\r\n DefJvGridOptions = [dgEditing, dgTitles, dgIndicator, dgColumnResize,\r\n dgColLines, dgRowLines, dgTabs, dgConfirmDelete, dgCancelOnExit\r\n {$IFDEF COMPILER14_UP}\r\n , dgTitleClick, dgTitleHotTrack\r\n {$ENDIF COMPILER14_UP}];\r\n {$NODEFINE DefJvGridOptions}\r\n\r\n JvDefaultAlternateRowColor = TColor($00CCCCCC); // Light gray\r\n JvDefaultAlternateRowFontColor = TColor($00000000); // Black\r\n\r\n // Consts for AutoSizeColumnIndex\r\n JvGridResizeProportionally = -1;\r\n JvGridResizeLastVisibleCol = -2;\r\n\r\ntype\r\n TJvDBGrid = class;\r\n\r\n // Mantis 3895: The only way to lift an ambiguity in an event handler is to\r\n // redefine a type. A simple rename is not enough, hence the distinction\r\n // between BCB and the others.\r\n {$IFDEF BCB}\r\n TJvDBGridBitmap = class(TBitmap)\r\n end;\r\n {$ELSE}\r\n {$IFDEF DELPHI10_UP}\r\n TJvDBGridBitmap = class(TBitmap)\r\n end;\r\n {$ELSE}\r\n TJvDBGridBitmap = TBitmap;\r\n {$ENDIF DELPHI10_UP}\r\n {$ENDIF BCB}\r\n\r\n TJvDBGridColumnResize = (gcrNone, gcrGrid, gcrDataSet);\r\n TJvDBGridCellHintPosition = (gchpDefault, gchpMouse);\r\n\r\n TSelectColumn = (scDataBase, scGrid);\r\n TTitleClickEvent = procedure(Sender: TObject; ACol: Longint;\r\n Field: TField) of object;\r\n TCheckTitleBtnEvent = procedure(Sender: TObject; ACol: Longint;\r\n Field: TField; var Enabled: Boolean) of object;\r\n TGetCellParamsEvent = procedure(Sender: TObject; Field: TField;\r\n AFont: TFont; var Background: TColor; Highlight: Boolean) of object;\r\n TSortMarker = (smNone, smDown, smUp);\r\n TGetBtnParamsEvent = procedure(Sender: TObject; Field: TField;\r\n AFont: TFont; var Background: TColor; var ASortMarker: TSortMarker;\r\n IsDown: Boolean) of object;\r\n TGetCellPropsEvent = procedure(Sender: TObject; Field: TField;\r\n AFont: TFont; var Background: TColor) of object; { obsolete }\r\n TJvDBEditShowEvent = procedure(Sender: TObject; Field: TField;\r\n var AllowEdit: Boolean) of object;\r\n TDrawColumnTitleEvent = procedure(Sender: TObject; ACanvas: TCanvas;\r\n ARect: TRect; AColumn: TColumn; var ASortMarker: TJvDBGridBitmap; IsDown: Boolean;\r\n var Offset: Integer; var DefaultDrawText,\r\n DefaultDrawSortMarker: Boolean) of object;\r\n TJvTitleHintEvent = procedure(Sender: TObject; Field: TField;\r\n var AHint: string; var ATimeOut: Integer) of object;\r\n TJvCellHintEvent = TJvTitleHintEvent;\r\n TJvDBColumnResizeEvent = procedure(Grid: TJvDBGrid; ACol: Longint; NewWidth: Integer) of object;\r\n TJvDBCheckIfBooleanFieldEvent = function(Grid: TJvDBGrid; Field: TField;\r\n var StringForTrue: string; var StringForFalse: string): Boolean of object;\r\n TJvDBCanEditCellEvent = procedure(Grid: TJvDBGrid; Field: TField; var AllowEdit: Boolean) of object;\r\n TJvDBSelectColumnsEvent = procedure(Grid: TJvDBGrid; var DefaultDialog: Boolean) of object;\r\n\r\n TJvDBGridLayoutChangeKind = (lcLayoutChanged, lcSizeChanged, lcTopLeftChanged);\r\n TJvDBGridLayoutChangeEvent = procedure(Grid: TJvDBGrid; Kind: TJvDBGridLayoutChangeKind) of object;\r\n TJvDBGridLayoutChangeLink = class\r\n private\r\n FOnChange: TJvDBGridLayoutChangeEvent;\r\n public\r\n procedure DoChange(Grid: TJvDBGrid; Kind: TJvDBGridLayoutChangeKind);\r\n property OnChange: TJvDBGridLayoutChangeEvent read FOnChange write FOnChange;\r\n end;\r\n\r\n EJVCLDbGridException = Class(EJVCLException);\r\n\r\n TJvSelectDialogColumnStrings = class(TPersistent)\r\n private\r\n FCaption: string;\r\n FRealNamesOption: string;\r\n FOK: string;\r\n FNoSelectionWarning: string;\r\n public\r\n constructor Create;\r\n published\r\n property Caption: string read FCaption write FCaption;\r\n property RealNamesOption: string read FRealNamesOption write FRealNamesOption;\r\n property OK: string read FOK write FOK;\r\n property NoSelectionWarning: string read FNoSelectionWarning write FNoSelectionWarning;\r\n end;\r\n\r\n TJvDBGridControlSize = (\r\n fcCellSize, // Fit the control into the cell\r\n fcDesignSize, // Leave the control as it was at design time\r\n fcBiggest // Take the biggest size between Cell size and Design time size\r\n );\r\n\r\n TJvDBGridControl = class(TCollectionItem)\r\n private\r\n FControlName: string;\r\n FFieldName: string;\r\n FFitCell: TJvDBGridControlSize;\r\n FLeaveOnEnterKey: Boolean;\r\n FLeaveOnUpDownKey: Boolean;\r\n FDesignWidth: Integer; // value set when needed by PlaceControl\r\n FDesignHeight: Integer; // value set when needed by PlaceControl\r\n public\r\n procedure Assign(Source: TPersistent); override;\r\n published\r\n property ControlName: string read FControlName write FControlName;\r\n property FieldName: string read FFieldName write FFieldName;\r\n property FitCell: TJvDBGridControlSize read FFitCell write FFitCell;\r\n property LeaveOnEnterKey: Boolean read FLeaveOnEnterKey write FLeaveOnEnterKey default False;\r\n property LeaveOnUpDownKey: Boolean read FLeaveOnUpDownKey write FLeaveOnUpDownKey default False;\r\n end;\r\n\r\n TJvDBGridControls = class(TCollection)\r\n private\r\n FParentDBGrid: TJvDBGrid;\r\n function GetItem(Index: Integer): TJvDBGridControl;\r\n procedure SetItem(Index: Integer; Value: TJvDBGridControl);\r\n protected\r\n function GetOwner: TPersistent; override;\r\n public\r\n constructor Create(ParentDBGrid: TJvDBGrid);\r\n function Add: TJvDBGridControl;\r\n function ControlByField(const FieldName: string): TJvDBGridControl;\r\n function ControlByName(const CtrlName: string): TJvDBGridControl;\r\n property Items[Index: Integer]: TJvDBGridControl read GetItem write SetItem; default;\r\n end;\r\n\r\n TCharList = TCharSet;\r\n\r\n TJvGridPaintInfo = record\r\n MouseInCol: Integer; // the column that the mouse is in\r\n ColPressed: Boolean; // a column has been pressed\r\n ColPressedIdx: Integer; // idx of the pressed column\r\n ColSizing: Boolean; // currently sizing a column\r\n ColMoving: Boolean; // currently moving a column\r\n end;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvDBGrid = class(TJvExDBGrid, IJvDataControl)\r\n private\r\n FAutoSort: Boolean;\r\n FBeepOnError: Boolean;\r\n FAutoAppend: Boolean;\r\n FSizingIndex: Integer;\r\n FSizingOfs: Integer;\r\n FShowGlyphs: Boolean;\r\n FDefaultDrawing: Boolean;\r\n FReduceFlicker: Boolean;\r\n FMultiSelect: Boolean;\r\n FSelecting: Boolean;\r\n FClearSelection: Boolean;\r\n FTitleButtons: Boolean;\r\n FPressedCol: TColumn;\r\n FPressed: Boolean;\r\n FTracking: Boolean;\r\n FSwapButtons: Boolean;\r\n FIniLink: TJvIniLink;\r\n FDisableCount: Integer;\r\n FFixedCols: Integer;\r\n FMsIndicators: TImageList;\r\n FOnCheckButton: TCheckTitleBtnEvent;\r\n FOnGetCellProps: TGetCellPropsEvent;\r\n FOnGetCellParams: TGetCellParamsEvent;\r\n FOnGetBtnParams: TGetBtnParamsEvent;\r\n FOnEditChange: TNotifyEvent;\r\n FOnTitleBtnClick: TTitleClickEvent;\r\n FOnTitleBtnDblClick: TTitleClickEvent;\r\n FOnTopLeftChanged: TNotifyEvent;\r\n FSelectionAnchor: {$IFDEF RTL200_UP}TBookmark{$ELSE}TBookmarkStr{$ENDIF RTL200_UP};\r\n FOnDrawColumnTitle: TDrawColumnTitleEvent;\r\n FWord: string;\r\n FShowTitleHint: Boolean;\r\n FSortedField: string;\r\n FPostOnEnterKey: Boolean;\r\n FSelectColumn: TSelectColumn;\r\n FTitleArrow: Boolean;\r\n FTitlePopup: TPopupMenu;\r\n FOnShowTitleHint: TJvTitleHintEvent;\r\n FOnTitleArrowMenuEvent: TNotifyEvent;\r\n FAlternateRowColor: TColor;\r\n FAlternateRowFontColor: TColor;\r\n FAutoSizeColumns: Boolean;\r\n FAutoSizeColumnIndex: Integer;\r\n FMinColumnWidth: Integer;\r\n FMaxColumnWidth: Integer;\r\n FInAutoSize: Boolean;\r\n FSelectColumnsDialogStrings: TJvSelectDialogColumnStrings;\r\n FTitleColumn: TColumn;\r\n FOnColumnResized: TJvDBColumnResizeEvent;\r\n FSortMarker: TSortMarker;\r\n FShowCellHint: Boolean;\r\n FOnShowCellHint: TJvCellHintEvent;\r\n FCharList: TCharList;\r\n {$IFDEF COMPILER9_UP}\r\n FScrollBars: TScrollStyle;\r\n {$ENDIF COMPILER9_UP}\r\n FWordWrap: Boolean;\r\n FWordWrapAllFields: Boolean;\r\n FChangeLinks: TObjectList;\r\n FShowMemos: Boolean;\r\n FOnShowEditor: TJvDBEditShowEvent;\r\n FAlwaysShowEditor: Boolean;\r\n\r\n FControls: TJvDBGridControls;\r\n FCurrentControl: TWinControl;\r\n FOldControlWndProc: TWndMethod;\r\n FBooleanFieldToEdit: TField;\r\n FBooleanEditor: Boolean;\r\n FOnCheckIfBooleanField: TJvDBCheckIfBooleanFieldEvent;\r\n FStringForTrue: string;\r\n FStringForFalse: string;\r\n\r\n FAutoSizeRows: Boolean;\r\n FRowResize: Boolean;\r\n FRowsHeight: Integer;\r\n FTitleRowHeight: Integer;\r\n FCellHintPosition: TJvDBGridCellHintPosition;\r\n FCanDelete: Boolean;\r\n\r\n { Cancel edited record on mouse wheel or when resize column (double-click)}\r\n FCancelOnMouse: Boolean;\r\n\r\n { Resize column using mouse double clicking }\r\n FCanResizeColumn: Boolean;\r\n FResizeColumnIndex: Longint;\r\n FColumnResize: TJvDBGridColumnResize;\r\n\r\n // XP Theming\r\n {$IFNDEF COMPILER14_UP}\r\n FUseXPThemes: Boolean;\r\n {$ENDIF ~COMPILER14_UP}\r\n FPaintInfo: TJvGridPaintInfo;\r\n FCell: TGridCoord; // currently selected cell\r\n\r\n FTitleButtonAllowMove: Boolean;\r\n FReadOnlyCellColor: TColor;\r\n FOnCanEditCell: TJvDBCanEditCellEvent;\r\n FOnSelectColumns: TJvDBSelectColumnsEvent;\r\n FOnBeforePaint: TNotifyEvent;\r\n FOnAfterPaint: TNotifyEvent;\r\n\r\n FDelphi2010OptionsMigrated: Boolean;\r\n procedure ReadDelphi2010OptionsMigrated(Reader: TReader);\r\n procedure WriteDelphi2010OptionsMigrated(Writer: TWriter);\r\n\r\n {$IFDEF COMPILER10_UP}\r\n procedure WMPaint(var Message: TWMPaint); message WM_PAINT;\r\n {$ENDIF COMPILER10_UP}\r\n procedure CMMouseEnter(var Message: TMessage); message CM_MOUSEENTER;\r\n procedure CMMouseLeave(var Message: TMessage); message CM_MOUSELEAVE;\r\n\r\n procedure SetAutoSizeRows(Value: Boolean);\r\n procedure SetRowResize(Value: Boolean);\r\n procedure SetRowsHeight(Value: Integer);\r\n procedure SetTitleRowHeight(Value: Integer);\r\n\r\n procedure WriteCellText(ARect: TRect; DX, DY: Integer; const Text: string;\r\n Alignment: TAlignment; ARightToLeft: Boolean; FixCell: Boolean; Options: Integer = 0);\r\n function GetImageIndex(Field: TField): Integer;\r\n procedure SetShowGlyphs(Value: Boolean);\r\n function GetStorage: TJvFormPlacement;\r\n procedure SetStorage(Value: TJvFormPlacement);\r\n procedure IniSave(Sender: TObject);\r\n procedure IniLoad(Sender: TObject);\r\n procedure SetMultiSelect(Value: Boolean);\r\n procedure SetTitleButtons(Value: Boolean);\r\n procedure StopTracking;\r\n procedure TrackButton(X, Y: Integer);\r\n function ActiveRowSelected: Boolean;\r\n function GetSelCount: Longint;\r\n function GetRow: Longint;\r\n procedure SetRow(Value: Longint);\r\n procedure SaveColumnsLayout(const AppStorage: TJvCustomAppStorage; const Section: string);\r\n procedure RestoreColumnsLayout(const AppStorage: TJvCustomAppStorage; const Section: string);\r\n function GetOptions: TDBGridOptions;\r\n procedure SetOptions(Value: TDBGridOptions);\r\n function GetMasterColumn(ACol, ARow: Longint): TColumn;\r\n function GetTitleOffset: Integer;\r\n procedure SetFixedCols(Value: Integer);\r\n function GetFixedCols: Integer;\r\n function CalcLeftColumn: Integer;\r\n procedure WMChar(var Msg: TWMChar); message WM_CHAR;\r\n procedure WMCancelMode(var Msg: TMessage); message WM_CANCELMODE;\r\n procedure WMRButtonUp(var Msg: TWMMouse); message WM_RBUTTONUP;\r\n procedure CMHintShow(var Msg: TCMHintShow); message CM_HINTSHOW;\r\n procedure SetTitleArrow(const Value: Boolean);\r\n procedure SetAlternateRowColor(const Value: TColor);\r\n procedure ReadAlternateRowColor(Reader: TReader);\r\n procedure SetAlternateRowFontColor(const Value: TColor);\r\n procedure ReadAlternateRowFontColor(Reader: TReader);\r\n procedure SetAutoSizeColumnIndex(const Value: Integer);\r\n procedure SetAutoSizeColumns(const Value: Boolean);\r\n procedure SetMaxColumnWidth(const Value: Integer);\r\n procedure SetMinColumnWidth(const Value: Integer);\r\n procedure SetSelectColumnsDialogStrings(const Value: TJvSelectDialogColumnStrings);\r\n procedure SetSortedField(const Value: string);\r\n procedure SetSortMarker(const Value: TSortMarker);\r\n procedure WMVScroll(var Msg: TWMVScroll); message WM_VSCROLL;\r\n procedure SetShowMemos(const Value: Boolean);\r\n procedure SetBooleanEditor(const Value: Boolean);\r\n {$IFDEF COMPILER9_UP}\r\n procedure SetScrollBars(Value: TScrollStyle);\r\n {$ENDIF COMPILER9_UP}\r\n procedure ReadPostOnEnter(Reader: TReader);\r\n\r\n procedure SetControls(Value: TJvDBGridControls);\r\n procedure HideCurrentControl;\r\n procedure ControlWndProc(var Message: TMessage);\r\n procedure ChangeBoolean(const FieldValueChange: Shortint);\r\n function EditWithBoolBox(Field: TField): Boolean; {$IFDEF DELPHI9} inline; {$ENDIF DELPHI9}\r\n function DoKeyPress(var Msg: TWMChar): Boolean;\r\n procedure SetWordWrap(Value: Boolean);\r\n procedure SetWordWrapAllFields(Value: Boolean);\r\n procedure NotifyLayoutChange(const Kind: TJvDBGridLayoutChangeKind);\r\n\r\n // XP Theming\r\n function GetUseXPThemes: Boolean;\r\n procedure SetUseXPThemes(Value: Boolean);\r\n {$IFNDEF COMPILER14_UP}\r\n {$IFDEF JVCLThemesEnabled}\r\n function ColumnOffset: Integer; // col offset used for calculations. Is 1 if indicator is being displayed\r\n function ValidCell(ACell: TGridCoord): Boolean;\r\n {$ENDIF JVCLThemesEnabled}\r\n {$ENDIF ~COMPILER14_UP}\r\n\r\n function GetMaxDisplayText: string;\r\n function GetColumnMaxWidth: Integer;\r\n\r\n protected\r\n FCurrentDrawRow: Integer;\r\n procedure MouseLeave(Control: TControl); override;\r\n function AcquireFocus: Boolean;\r\n function CanEditShow: Boolean; override;\r\n function CanEditCell(AField: TField): Boolean; virtual;\r\n function CreateEditor: TInplaceEdit; override;\r\n procedure DblClick; override;\r\n function DoTitleBtnDblClick: Boolean; dynamic;\r\n procedure ShowSelectColumnClick; dynamic;\r\n\r\n procedure DoTitleClick(ACol: Longint; AField: TField); dynamic;\r\n procedure CheckTitleButton(ACol, ARow: Longint; var Enabled: Boolean); dynamic;\r\n function SortMarkerAssigned(const AFieldName: string): Boolean; dynamic;\r\n function ChangeSortMarker(const Value: TSortMarker): Boolean;\r\n procedure CallDrawCellEvent(ACol, ARow: Longint; ARect: TRect; AState: TGridDrawState);\r\n procedure DrawTitleCaption(Canvas: TCanvas; const TextRect: TRect; DrawColumn: TColumn);\r\n procedure DoDrawCell(ACol, ARow: Longint; ARect: TRect; AState: TGridDrawState); virtual;\r\n procedure DrawCell(ACol, ARow: Longint; ARect: TRect; AState: TGridDrawState); override;\r\n procedure DrawDataCell(const Rect: TRect; Field: TField;\r\n State: TGridDrawState); override; { obsolete from Delphi 2.0 }\r\n\r\n function BeginColumnDrag(var Origin: Integer; var Destination: Integer; const MousePt: TPoint): Boolean; override;\r\n procedure ColumnMoved(FromIndex: Integer; ToIndex: Integer); override;\r\n function AllowTitleClick: Boolean; virtual;\r\n\r\n procedure EditChanged(Sender: TObject); dynamic;\r\n procedure GetCellProps(Column: TColumn; AFont: TFont; var Background: TColor;\r\n Highlight: Boolean); dynamic;\r\n function HighlightCell(DataCol, DataRow: Integer; const Value: string;\r\n AState: TGridDrawState): Boolean; override;\r\n procedure KeyDown(var Key: Word; Shift: TShiftState); override;\r\n procedure KeyPress(var Key: Char); override;\r\n procedure SetColumnAttributes; override;\r\n procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;\r\n procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;\r\n procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;\r\n function DoMouseWheelDown(Shift: TShiftState; MousePos: TPoint): Boolean; override;\r\n function DoMouseWheelUp(Shift: TShiftState; MousePos: TPoint): Boolean; override;\r\n procedure Scroll(Distance: Integer); override;\r\n procedure LinkActive(Value: Boolean); override;\r\n {$IFDEF COMPILER9_UP}\r\n procedure UpdateScrollBar; override;\r\n {$ENDIF COMPILER9_UP}\r\n procedure LayoutChanged; override;\r\n procedure TopLeftChanged; override;\r\n procedure GridInvalidateRow(Row: Longint);\r\n procedure DrawColumnCell(const Rect: TRect; DataCol: Integer;\r\n Column: TColumn; State: TGridDrawState); override;\r\n procedure ColWidthsChanged; override;\r\n function DoEraseBackground(Canvas: TCanvas; Param: LPARAM): Boolean; override;\r\n procedure Paint; override;\r\n procedure CalcSizingState(X, Y: Integer; var State: TGridState;\r\n var Index: Longint; var SizingPos, SizingOfs: Integer;\r\n var FixedInfo: TGridDrawInfo); override;\r\n procedure DoDrawColumnTitle(ACanvas: TCanvas; ARect: TRect; AColumn: TColumn;\r\n var ASortMarker: TJvDBGridBitmap; IsDown: Boolean; var Offset: Integer;\r\n var DefaultDrawText, DefaultDrawSortMarker: Boolean); virtual;\r\n procedure ColEnter; override;\r\n procedure ColExit; override;\r\n\r\n function DoMouseWheel(Shift: TShiftState; WheelDelta: Integer;\r\n MousePos: TPoint): Boolean; override;\r\n procedure EditButtonClick; override;\r\n procedure CellClick(Column: TColumn); override;\r\n procedure DefineProperties(Filer: TFiler); override;\r\n procedure DoMinColWidth; virtual;\r\n procedure DoMaxColWidth; virtual;\r\n procedure DoAutoSizeColumns; virtual;\r\n procedure Resize; override;\r\n procedure Loaded; override;\r\n function GetMinColWidth(Default: Integer): Integer;\r\n function GetMaxColWidth(Default: Integer): Integer;\r\n function LastVisibleColumn: Integer;\r\n function FirstVisibleColumn: Integer;\r\n procedure TitleClick(Column: TColumn); override;\r\n procedure DoGetBtnParams(Field: TField; AFont: TFont; var Background: TColor;\r\n var ASortMarker: TSortMarker; IsDown: Boolean); virtual;\r\n\r\n procedure PlaceControl(Control: TWinControl; ACol, ARow: Integer); virtual;\r\n procedure RowHeightsChanged; override;\r\n function GetDataLink: TDataLink; virtual;\r\n procedure Notification(AComponent: TComponent; Operation: TOperation); override;\r\n\r\n procedure CreateParams(var Params: TCreateParams); override;\r\n public\r\n {$IFDEF SUPPORTS_CLASS_CTORDTORS}\r\n class destructor Destroy;\r\n {$ENDIF SUPPORTS_CLASS_CTORDTORS}\r\n\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n\r\n procedure DefaultDrawColumnCell(const Rect: TRect; DataCol: Integer; Column: TColumn; State: TGridDrawState); virtual;\r\n procedure DefaultDataCellDraw(const Rect: TRect; Field: TField; State: TGridDrawState);\r\n procedure DisableScroll;\r\n procedure EnableScroll;\r\n function ScrollDisabled: Boolean;\r\n procedure MouseToCell(X, Y: Integer; var ACol, ARow: Longint);\r\n procedure SelectAll;\r\n procedure UnselectAll;\r\n procedure ToggleRowSelection;\r\n procedure GotoSelection(Index: Longint);\r\n procedure LoadFromAppStore(const AppStorage: TJvCustomAppStorage; const Path: string);\r\n procedure SaveToAppStore(const AppStorage: TJvCustomAppStorage; const Path: string);\r\n procedure Load;\r\n procedure Save;\r\n procedure UpdateTabStops(ALimit: Integer = -1);\r\n procedure ShowColumnsDialog;\r\n procedure CloseControl; // Hide the current edit control and give the focus to the grid\r\n procedure InitializeColumnsWidth(const MinWidth, MaxWidth: Integer;\r\n const DisplayWholeTitle: Boolean; const FixedWidths: array of Integer);\r\n procedure MouseWheelHandler(var Message: TMessage); override;\r\n\r\n procedure RegisterLayoutChangeLink(Link: TJvDBGridLayoutChangeLink);\r\n procedure UnregisterLayoutChangeLink(Link: TJvDBGridLayoutChangeLink);\r\n\r\n procedure BeginUpdate;\r\n procedure EndUpdate;\r\n function CellRect(ACol, ARow: Longint): TRect;\r\n\r\n property SelectedRows;\r\n property SelCount: Longint read GetSelCount;\r\n property Canvas;\r\n property Col;\r\n property InplaceEditor;\r\n property LeftCol;\r\n property Row: Longint read GetRow write SetRow;\r\n property CurrentDrawRow: Integer read FCurrentDrawRow;\r\n property VisibleRowCount;\r\n property VisibleColCount;\r\n property IndicatorOffset;\r\n property TitleOffset: Integer read GetTitleOffset;\r\n property CharList: TCharList read FCharList write FCharList;\r\n published\r\n property AutoAppend: Boolean read FAutoAppend write FAutoAppend default True;\r\n property SortMarker: TSortMarker read FSortMarker write SetSortMarker default smNone;\r\n property AutoSort: Boolean read FAutoSort write FAutoSort default True;\r\n property Options: TDBGridOptions read GetOptions write SetOptions default DefJvGridOptions;\r\n property FixedCols: Integer read GetFixedCols write SetFixedCols default 0;\r\n property ClearSelection: Boolean read FClearSelection write FClearSelection default True;\r\n property DefaultDrawing: Boolean read FDefaultDrawing write FDefaultDrawing default True;\r\n property IniStorage: TJvFormPlacement read GetStorage write SetStorage;\r\n property MultiSelect: Boolean read FMultiSelect write SetMultiSelect default False;\r\n property ShowGlyphs: Boolean read FShowGlyphs write SetShowGlyphs default True;\r\n property TitleButtons: Boolean read FTitleButtons write SetTitleButtons default False;\r\n property TitleButtonAllowMove: Boolean read FTitleButtonAllowMove write FTitleButtonAllowMove default False; \r\n property OnCheckButton: TCheckTitleBtnEvent read FOnCheckButton write FOnCheckButton;\r\n property OnGetCellProps: TGetCellPropsEvent read FOnGetCellProps write FOnGetCellProps; { obsolete }\r\n property OnGetCellParams: TGetCellParamsEvent read FOnGetCellParams write FOnGetCellParams;\r\n property OnGetBtnParams: TGetBtnParamsEvent read FOnGetBtnParams write FOnGetBtnParams;\r\n property OnEditChange: TNotifyEvent read FOnEditChange write FOnEditChange;\r\n property BevelEdges;\r\n property BevelInner;\r\n property BevelKind default bkNone;\r\n property BevelOuter;\r\n property OnShowEditor: TJvDBEditShowEvent read FOnShowEditor write FOnShowEditor;\r\n property OnTitleBtnClick: TTitleClickEvent read FOnTitleBtnClick write FOnTitleBtnClick;\r\n property OnTitleBtnDblClick: TTitleClickEvent read FOnTitleBtnDblClick write FOnTitleBtnDblClick;\r\n property OnTopLeftChanged: TNotifyEvent read FOnTopLeftChanged write FOnTopLeftChanged;\r\n property OnDrawColumnTitle: TDrawColumnTitleEvent read FOnDrawColumnTitle write FOnDrawColumnTitle;\r\n property OnContextPopup;\r\n property OnMouseDown;\r\n property OnMouseMove;\r\n property OnMouseUp;\r\n property OnResize;\r\n property OnMouseWheelDown;\r\n property OnMouseWheelUp;\r\n property BeepOnError: Boolean read FBeepOnError write FBeepOnError default True;\r\n property AlternateRowColor: TColor read FAlternateRowColor write SetAlternateRowColor default clNone;\r\n property AlternateRowFontColor: TColor read FAlternateRowFontColor write SetAlternateRowFontColor default clNone;\r\n property PostOnEnterKey: Boolean read FPostOnEnterKey write FPostOnEnterKey default False;\r\n {$IFDEF COMPILER9_UP}\r\n property ScrollBars: TScrollStyle read FScrollBars write SetScrollBars default ssBoth;\r\n {$ENDIF COMPILER9_UP}\r\n property SelectColumn: TSelectColumn read FSelectColumn write FSelectColumn default scDataBase;\r\n property SortedField: string read FSortedField write SetSortedField;\r\n property ShowTitleHint: Boolean read FShowTitleHint write FShowTitleHint default False;\r\n property TitleArrow: Boolean read FTitleArrow write SetTitleArrow default False;\r\n property TitlePopup: TPopupMenu read FTitlePopup write FTitlePopup;\r\n property OnShowTitleHint: TJvTitleHintEvent read FOnShowTitleHint write FOnShowTitleHint;\r\n property OnTitleArrowMenuEvent: TNotifyEvent read FOnTitleArrowMenuEvent write FOnTitleArrowMenuEvent;\r\n property ShowCellHint: Boolean read FShowCellHint write FShowCellHint default False;\r\n property OnShowCellHint: TJvCellHintEvent read FOnShowCellHint write FOnShowCellHint;\r\n property MaxColumnWidth: Integer read FMaxColumnWidth write SetMaxColumnWidth default 0;\r\n property MinColumnWidth: Integer read FMinColumnWidth write SetMinColumnWidth default 0;\r\n property AutoSizeColumns: Boolean read FAutoSizeColumns write SetAutoSizeColumns default False;\r\n property AutoSizeColumnIndex: Integer read FAutoSizeColumnIndex write SetAutoSizeColumnIndex\r\n default JvGridResizeProportionally;\r\n property SelectColumnsDialogStrings: TJvSelectDialogColumnStrings\r\n read FSelectColumnsDialogStrings write SetSelectColumnsDialogStrings;\r\n\r\n { Determines how cell hint position is calculated, check TJvDBGrid.CMHintShow (Mantis #5759) }\r\n property CellHintPosition: TJvDBGridCellHintPosition read FCellHintPosition write FCellHintPosition default gchpDefault;\r\n\r\n { Allows user to delete things using the \"del\" key }\r\n property CanDelete: Boolean read FCanDelete write FCanDelete default True;\r\n\r\n { CancelOnMouse: cancel current record when using mouse wheel or on column resizing using double-click }\r\n property CancelOnMouse: Boolean read FCancelOnMouse write FCancelOnMouse default False;\r\n { ColumnResize: columns can be resized on max Field.DisplayText using mouse double clicking }\r\n property ColumnResize: TJvDBGridColumnResize read FColumnResize write FColumnResize default gcrGrid;\r\n\r\n { EditControls: list of controls used to edit data }\r\n property EditControls: TJvDBGridControls read FControls write SetControls;\r\n { AutoSizeRows: are rows resized automatically ? }\r\n property AutoSizeRows: Boolean read FAutoSizeRows write SetAutoSizeRows default True;\r\n { ReduceFlicker: improve (but slow) the display when painting/scrolling ? }\r\n property ReduceFlicker: Boolean read FReduceFlicker write FReduceFlicker default True;\r\n { RowResize: can rows be resized with the mouse ? }\r\n property RowResize: Boolean read FRowResize write SetRowResize default False;\r\n { RowsHeight: data rows height }\r\n property RowsHeight: Integer read FRowsHeight write SetRowsHeight;\r\n { TitleRowHeight: title row height (cannot be resized with the mouse) }\r\n property TitleRowHeight: Integer read FTitleRowHeight write SetTitleRowHeight;\r\n { WordWrap: if true, titles, memo and string fields are displayed on several lines }\r\n property WordWrap: Boolean read FWordWrap write SetWordWrap default False;\r\n { WordWrapAllFields: if true and WordWrap is true, not only memo and string fields are displayed on several lines }\r\n property WordWrapAllFields: Boolean read FWordWrapAllFields write SetWordWrapAllFields default False;\r\n { ShowMemos: if true, memo fields are shown as text }\r\n property ShowMemos: Boolean read FShowMemos write SetShowMemos default True;\r\n { BooleanEditor: if true, a checkbox is used to edit boolean fields }\r\n property BooleanEditor: Boolean read FBooleanEditor write SetBooleanEditor default True;\r\n { UseXPThemes: if true, the grid is painted in the active XP theme style }\r\n property UseXPThemes: Boolean read GetUseXPThemes write SetUseXPThemes {$IFDEF COMPILER14_UP} stored False{$ENDIF} default True;\r\n { OnCheckIfBooleanField: event used to treat integer fields and string fields as boolean fields }\r\n property OnCheckIfBooleanField: TJvDBCheckIfBooleanFieldEvent read FOnCheckIfBooleanField write FOnCheckIfBooleanField;\r\n { OnColumnResized: event triggered each time a column is resized with the mouse }\r\n property OnColumnResized: TJvDBColumnResizeEvent read FOnColumnResized write FOnColumnResized;\r\n\r\n { ReadOnlyCellColor: The color of the cells that are read only => OnCanEditCell, not Field.CanModify } \r\n property ReadOnlyCellColor: TColor read FReadOnlyCellColor write FReadOnlyCellColor default clDefault;\r\n { OnCanEditCell: event used to control the appearance of editor and cell background }\r\n property OnCanEditCell: TJvDBCanEditCellEvent read FOnCanEditCell write FOnCanEditCell;\r\n { OnSelectColumns: event is triggered when the user clicks on the TitleArrow button. }\r\n property OnSelectColumns: TJvDBSelectColumnsEvent read FOnSelectColumns write FOnSelectColumns;\r\n\r\n { OnBeforePaint: event triggered before the grid is painted. }\r\n property OnBeforePaint: TNotifyEvent read FOnBeforePaint write FOnBeforePaint;\r\n { OnBeforePaint: event triggered after the grid was painted. }\r\n property OnAfterPaint: TNotifyEvent read FOnAfterPaint write FOnAfterPaint;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvDBGrid.pas $';\r\n Revision: '$Revision: 13415 $';\r\n Date: '$Date: 2012-09-10 11:51:54 +0200 (lun. 10 sept. 2012) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n Variants, SysUtils, Math, TypInfo, Dialogs, DBConsts, StrUtils,\r\n JvDBLookup,\r\n JvConsts, JvResources, JvThemes, JvJCLUtils, JvJVCLUtils,\r\n {$IFDEF COMPILER7_UP}\r\n // => TScrollDirection, DrawArray(must be after JvJVCLUtils)\r\n {$ENDIF COMPILER7_UP}\r\n JvDBGridSelectColumnForm, JclSysUtils;\r\n\r\n{$R JvDBGrid.res}\r\n\r\ntype\r\n TBookmarks = class(TBookmarkList);\r\n TGridPicture = (gpBlob, gpMemo, gpPicture, gpOle, gpObject, gpData,\r\n gpNotEmpty, gpMarkDown, gpMarkUp, gpChecked, gpUnChecked, gpPopup);\r\n {$IFNDEF COMPILER7_UP}\r\n TScrollDirection = (sdLeft, sdRight, sdUp, sdDown);\r\n {$ENDIF ~COMPILER7_UP}\r\n\r\n TCustomGridAccess = class(TCustomGrid);\r\n\r\nconst\r\n GridBmpNames: array [TGridPicture] of PChar =\r\n ('JvDBGridBLOB', 'JvDBGridMEMO', 'JvDBGridPICT', 'JvDBGridOLE', 'JvDBGridOBJECT',\r\n 'JvDBGridDATA', 'JvDBGridNOTEMPTY', 'JvDBGridSMDOWN', 'JvDBGridSMUP',\r\n 'JvDBGridCHECKED', 'JvDBGridUNCHECKED', 'JvDBGridPOPUP');\r\n\r\n bmMultiDot = 'JvDBGridMSDOT';\r\n bmMultiArrow = 'JvDBGridMSARROW';\r\n\r\n // Consts for ChangeBoolean\r\n JvGridBool_INVERT = 9;\r\n JvGridBool_CHECK = 0;\r\n JvGridBool_UNCHECK = -1;\r\n\r\nvar\r\n GridBitmaps: array [TGridPicture] of TJvDBGridBitmap =\r\n (nil, nil, nil, nil, nil, nil, nil, nil, nil, nil, nil, nil);\r\n FirstGridBitmaps: Boolean = True;\r\n\r\nprocedure FinalizeGridBitmaps;\r\nvar\r\n I: TGridPicture;\r\nbegin\r\n for I := Low(TGridPicture) to High(TGridPicture) do\r\n FreeAndNil(GridBitmaps[I]);\r\nend;\r\n\r\nfunction GetGridBitmap(BmpType: TGridPicture): TJvDBGridBitmap;\r\nbegin\r\n if GridBitmaps[BmpType] = nil then\r\n begin\r\n if FirstGridBitmaps then\r\n FirstGridBitmaps := False;\r\n GridBitmaps[BmpType] := TJvDBGridBitmap.Create;\r\n GridBitmaps[BmpType].LoadFromResourceName(HInstance, GridBmpNames[BmpType]);\r\n end;\r\n Result := GridBitmaps[BmpType];\r\nend;\r\n\r\nfunction DrawBiDiText(DC: HDC; const Text: string; var R: TRect; Flags: UINT;\r\n Alignment: TAlignment; RightToLeft: Boolean; CanvasOrientation: TCanvasOrientation): Integer;\r\nconst\r\n AlignFlags: array [TAlignment] of UINT = (DT_LEFT, DT_RIGHT, DT_CENTER);\r\n RTL: array [Boolean] of UINT = (0, DT_RTLREADING);\r\nbegin\r\n if CanvasOrientation = coRightToLeft then\r\n ChangeBiDiModeAlignment(Alignment);\r\n Result := Windows.DrawText(DC, PChar(Text), Length(Text), R,\r\n AlignFlags[Alignment] or RTL[RightToLeft] or Flags);\r\nend;\r\n\r\nfunction IsMemoField(AField: TField): Boolean; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\nbegin\r\n Result := AField.DataType in [ftMemo {$IFDEF COMPILER10_UP}, ftWideMemo {$ENDIF}];\r\nend;\r\n\r\n//=== { TInternalInplaceEdit } ===============================================\r\n\r\ntype\r\n TInternalInplaceEdit = class(TInplaceEditList)\r\n private\r\n FDataList: TJvDBLookupList; // TDBLookupListBox\r\n FUseDataList: Boolean;\r\n FLookupSource: TDataSource;\r\n protected\r\n procedure CloseUp(Accept: Boolean); override;\r\n procedure DoEditButtonClick; override;\r\n procedure DropDown; override;\r\n procedure UpdateContents; override;\r\n procedure KeyDown(var Key: Word; Shift: TShiftState); override;\r\n function DoMouseWheel(Shift: TShiftState; WheelDelta: Integer;\r\n MousePos: TPoint): Boolean; override;\r\n public\r\n constructor Create(Owner: TComponent); override;\r\n property DataList: TJvDBLookupList read FDataList; // TDBLookupListBox\r\n property OnChange;\r\n end;\r\n\r\nconstructor TInternalInplaceEdit.Create(Owner: TComponent);\r\nbegin\r\n inherited Create(Owner);\r\n FLookupSource := TDataSource.Create(Self);\r\nend;\r\n\r\nprocedure TInternalInplaceEdit.CloseUp(Accept: Boolean);\r\nvar\r\n MasterField: TField;\r\n ListValue: Variant;\r\nbegin\r\n if ListVisible then\r\n begin\r\n if GetCapture <> 0 then\r\n SendMessage(GetCapture, WM_CANCELMODE, 0, 0);\r\n if ActiveList = DataList then\r\n ListValue := DataList.KeyValue\r\n else\r\n if PickList.ItemIndex <> -1 then\r\n ListValue := PickList.Items[PickList.ItemIndex]\r\n else\r\n ListValue := Null;\r\n SetWindowPos(ActiveList.Handle, 0, 0, 0, 0, 0, SWP_NOZORDER or\r\n SWP_NOMOVE or SWP_NOSIZE or SWP_NOACTIVATE or SWP_HIDEWINDOW);\r\n ListVisible := False;\r\n if Assigned(FDataList) then\r\n FDataList.LookupSource := nil; // ListSource\r\n FLookupSource.DataSet := nil;\r\n Invalidate;\r\n if Accept then\r\n if ActiveList = DataList then\r\n with TCustomDBGrid(Grid), TDBGrid(Grid).Columns[SelectedIndex].Field do\r\n begin\r\n MasterField := DataSet.FieldByName(KeyFields);\r\n if MasterField.CanModify and (Grid as IJvDataControl).GetDataLink.Edit then\r\n MasterField.Value := ListValue;\r\n end\r\n else\r\n if (not VarIsNull(ListValue)) and EditCanModify then\r\n with TCustomDBGrid(Grid), TDBGrid(Grid).Columns[SelectedIndex].Field do\r\n Text := ListValue;\r\n end;\r\nend;\r\n\r\nprocedure TInternalInplaceEdit.DoEditButtonClick;\r\nbegin\r\n TJvDBGrid(Grid).EditButtonClick; // TCustomDBGrid\r\nend;\r\n\r\nprocedure TInternalInplaceEdit.DropDown;\r\nvar\r\n Column: TColumn;\r\nbegin\r\n if not ListVisible then\r\n begin\r\n with TDBGrid(Grid) do\r\n Column := Columns[SelectedIndex];\r\n if ActiveList = FDataList then\r\n with Column.Field do\r\n begin\r\n FDataList.Color := Color;\r\n FDataList.Font := Font;\r\n FDataList.RowCount := Column.DropDownRows;\r\n FLookupSource.DataSet := LookupDataSet;\r\n FDataList.LookupField := LookupKeyFields; // KeyField\r\n FDataList.LookupDisplay := LookupResultField; // ListField\r\n FDataList.LookupSource := FLookupSource; // ListSource\r\n FDataList.KeyValue := DataSet.FieldByName(KeyFields).Value;\r\n end\r\n else\r\n if ActiveList = PickList then\r\n begin\r\n PickList.Items.Assign(Column.PickList);\r\n DropDownRows := Column.DropDownRows;\r\n end;\r\n end;\r\n inherited DropDown;\r\nend;\r\n\r\nprocedure TInternalInplaceEdit.UpdateContents;\r\nvar\r\n Column: TColumn;\r\nbegin\r\n inherited UpdateContents;\r\n if FUseDataList then\r\n begin\r\n if FDataList = nil then\r\n begin\r\n FDataList := TJvPopupDataList.Create(Self);\r\n FDataList.Visible := False;\r\n FDataList.Parent := Self;\r\n FDataList.OnMouseUp := ListMouseUp;\r\n end;\r\n ActiveList := FDataList;\r\n end;\r\n with TDBGrid(Grid) do\r\n Column := Columns[SelectedIndex];\r\n Self.ReadOnly := Column.ReadOnly;\r\n Font.Assign(Column.Font);\r\n ImeMode := Column.ImeMode;\r\n ImeName := Column.ImeName;\r\nend;\r\n\r\ntype\r\n TSelection = record\r\n StartPos: Integer;\r\n EndPos: Integer;\r\n end;\r\n\r\nprocedure TInternalInplaceEdit.KeyDown(var Key: Word; Shift: TShiftState);\r\n\r\n procedure SendToParent;\r\n begin\r\n TJvDBGrid(Grid).KeyDown(Key, Shift);\r\n Key := 0;\r\n end;\r\n\r\n procedure ParentEvent;\r\n var\r\n GridKeyDown: TKeyEvent;\r\n begin\r\n GridKeyDown := TJvDBGrid(Grid).OnKeyDown;\r\n if Assigned(GridKeyDown) then\r\n GridKeyDown(Grid, Key, Shift);\r\n end;\r\n\r\n function ForwardMovement: Boolean;\r\n begin\r\n Result := dgAlwaysShowEditor in TJvDBGrid(Grid).Options;\r\n end;\r\n\r\n function Ctrl: Boolean;\r\n begin\r\n Result := (Shift * KeyboardShiftStates = [ssCtrl]);\r\n end;\r\n\r\n function Selection: TSelection;\r\n begin\r\n SendMessage(Handle, EM_GETSEL, WPARAM(@Result.StartPos), LPARAM(@Result.EndPos));\r\n end;\r\n\r\n function CaretPos: Integer;\r\n var\r\n P: TPoint;\r\n begin\r\n Windows.GetCaretPos(P);\r\n Result := SendMessage(Handle, EM_CHARFROMPOS, 0, MakeLong(P.X, P.Y));\r\n end;\r\n\r\n function RightSide: Boolean;\r\n begin\r\n with Selection do\r\n Result := {(CaretPos = GetTextLen) and }\r\n ((StartPos = 0) or (EndPos = StartPos)) and (EndPos = GetTextLen);\r\n end;\r\n\r\n function LeftSide: Boolean;\r\n begin\r\n with Selection do\r\n Result := (CaretPos = 0) and (StartPos = 0) and\r\n ((EndPos = 0) or (EndPos = GetTextLen));\r\n end;\r\n\r\nbegin\r\n case Key of\r\n VK_LEFT:\r\n if ForwardMovement and (Ctrl or LeftSide) then\r\n SendToParent;\r\n VK_RIGHT:\r\n if ForwardMovement and (Ctrl or RightSide) then\r\n SendToParent;\r\n end;\r\n inherited KeyDown(Key, Shift);\r\nend;\r\n\r\nfunction TInternalInplaceEdit.DoMouseWheel(Shift: TShiftState;\r\n WheelDelta: Integer; MousePos: TPoint): Boolean;\r\nvar\r\n DataLink: TDataLink;\r\nbegin\r\n // Do not validate a record by error\r\n DataLink := (Grid as IJvDataControl).GetDataLink;\r\n if DataLink.Active and (DataLink.DataSet.State <> dsBrowse) then\r\n DataLink.DataSet.Cancel;\r\n\r\n // Ideally we would transmit the action to the DataList but\r\n // DoMouseWheel is protected\r\n // Result := FDataList.DoMouseWheel(Shift, WheelDelta, MousePos);\r\n Result := inherited DoMouseWheel(Shift, WheelDelta, MousePos);\r\nend;\r\n\r\n//=== { TJvDBGridLayoutChangeLink } ==========================================\r\n\r\nprocedure TJvDBGridLayoutChangeLink.DoChange(Grid: TJvDBGrid;\r\n Kind: TJvDBGridLayoutChangeKind);\r\nbegin\r\n if Assigned(OnChange) then\r\n OnChange(Grid, Kind);\r\nend;\r\n\r\n//=== { TJvDBGridControls } ==================================================\r\n\r\nconstructor TJvDBGridControls.Create(ParentDBGrid: TJvDBGrid);\r\nbegin\r\n inherited Create(TJvDBGridControl);\r\n FParentDBGrid := ParentDBGrid;\r\nend;\r\n\r\nprocedure TJvDBGridControl.Assign(Source: TPersistent);\r\nbegin\r\n if Source is TJvDBGridControl then\r\n begin\r\n ControlName := TJvDBGridControl(Source).ControlName;\r\n FieldName := TJvDBGridControl(Source).FieldName;\r\n FitCell := TJvDBGridControl(Source).FitCell;\r\n LeaveOnEnterKey := TJvDBGridControl(Source).LeaveOnEnterKey;\r\n LeaveOnUpDownKey := TJvDBGridControl(Source).LeaveOnUpDownKey;\r\n FDesignWidth := 0;\r\n FDesignHeight := 0;\r\n end\r\n else\r\n inherited Assign(Source);\r\nend;\r\n\r\nfunction TJvDBGridControls.GetOwner: TPersistent;\r\nbegin\r\n Result := FParentDBGrid;\r\nend;\r\n\r\nfunction TJvDBGridControls.Add: TJvDBGridControl;\r\nbegin\r\n Result := TJvDBGridControl(inherited Add);\r\nend;\r\n\r\nfunction TJvDBGridControls.GetItem(Index: Integer): TJvDBGridControl;\r\nbegin\r\n Result := TJvDBGridControl(inherited GetItem(Index));\r\nend;\r\n\r\nprocedure TJvDBGridControls.SetItem(Index: Integer; Value: TJvDBGridControl);\r\nbegin\r\n inherited SetItem(Index, Value);\r\nend;\r\n\r\nfunction TJvDBGridControls.ControlByField(const FieldName: string): TJvDBGridControl;\r\nvar\r\n Ctrl_Idx: Integer;\r\nbegin\r\n Result := nil;\r\n for Ctrl_Idx := 0 to Count - 1 do\r\n if AnsiSameText(Items[Ctrl_Idx].FieldName, FieldName) then\r\n begin\r\n Result := Items[Ctrl_Idx];\r\n Break;\r\n end;\r\nend;\r\n\r\nfunction TJvDBGridControls.ControlByName(const CtrlName: string): TJvDBGridControl;\r\nvar\r\n Ctrl_Idx: Integer;\r\nbegin\r\n Result := nil;\r\n for Ctrl_Idx := 0 to Count - 1 do\r\n if AnsiSameText(Items[Ctrl_Idx].ControlName, CtrlName) then\r\n begin\r\n Result := Items[Ctrl_Idx];\r\n Break;\r\n end;\r\nend;\r\n\r\n//=== { TJvDBGrid } ==========================================================\r\n\r\n{$IFDEF SUPPORTS_CLASS_CTORDTORS}\r\nclass destructor TJvDBGrid.Destroy;\r\nbegin\r\n FinalizeGridBitmaps;\r\nend;\r\n{$ENDIF SUPPORTS_CLASS_CTORDTORS}\r\n\r\nconstructor TJvDBGrid.Create(AOwner: TComponent);\r\nvar\r\n Bmp: TBitmap;\r\nbegin\r\n inherited Create(AOwner);\r\n {$IFDEF COMPILER9_UP}\r\n FScrollBars := ssBoth;\r\n {$ENDIF COMPILER9_UP}\r\n\r\n // (obones): issue 3026: need to create FChangeLinks at the beginning\r\n // so that any change can access the object. It seems that on some\r\n // foreign systems, the assignment to the Options property triggers\r\n // NotifyLayoutChange, so it needs the FChangeLinks object\r\n FChangeLinks := TObjectList.Create(False);\r\n\r\n FAutoSort := True;\r\n FBeepOnError := True;\r\n Bmp := TBitmap.Create;\r\n try\r\n Bmp.Handle := LoadBitmap(HInstance, bmMultiDot);\r\n FMsIndicators := TImageList.CreateSize(Bmp.Width, Bmp.Height);\r\n FMsIndicators.AddMasked(Bmp, clWhite);\r\n Bmp.Handle := LoadBitmap(HInstance, bmMultiArrow);\r\n FMsIndicators.AddMasked(Bmp, clWhite);\r\n finally\r\n Bmp.Free;\r\n end;\r\n FIniLink := TJvIniLink.Create;\r\n FIniLink.OnSave := IniSave;\r\n FIniLink.OnLoad := IniLoad;\r\n FShowGlyphs := True;\r\n FDefaultDrawing := True;\r\n FReduceFlicker := True;\r\n FClearSelection := True;\r\n FAutoAppend := True;\r\n FAlternateRowColor := clNone;\r\n FAlternateRowFontColor := clNone;\r\n FSelectColumn := scDataBase;\r\n FAutoSizeColumnIndex := JvGridResizeProportionally;\r\n FSelectColumnsDialogStrings := TJvSelectDialogColumnStrings.Create;\r\n // Note to users: the second line may not compile on non western european\r\n // systems, in which case you should simply remove it and recompile.\r\n FCharList :=\r\n ['A'..'Z', 'a'..'z', ' ', '-', '+', '0'..'9', '.', ',', Backspace,\r\n '', '', '', '', '', '', '', '', '', '', '', '', '', ''];\r\n\r\n FControls := TJvDBGridControls.Create(Self);\r\n FBooleanEditor := True;\r\n FStringForTrue := '1';\r\n FStringForFalse := '0';\r\n\r\n FAutoSizeRows := True;\r\n FRowsHeight := DefaultRowHeight;\r\n FTitleRowHeight := RowHeights[0];\r\n FShowMemos := True;\r\n FCanDelete := True;\r\n\r\n FReadOnlyCellColor := clDefault;\r\n\r\n FColumnResize := gcrGrid;\r\n\r\n // XP Theming\r\n {$IFNDEF COMPILER14_UP}\r\n FUseXPThemes := True;\r\n {$ENDIF ~COMPILER14_UP}\r\n FPaintInfo.ColPressed := False;\r\n FPaintInfo.MouseInCol := -1;\r\n FPaintInfo.ColPressedIdx := -1;\r\n FPaintInfo.ColMoving := False;\r\n FPaintInfo.ColSizing := False;\r\n FCell.X := -1;\r\n FCell.Y := -1;\r\n\r\n { properties with setters }\r\n inherited DefaultDrawing := False;\r\n inherited Options := inherited Options - [dgAlwaysShowEditor];\r\n Options := DefJvGridOptions;\r\nend;\r\n\r\ndestructor TJvDBGrid.Destroy;\r\nbegin\r\n HideCurrentControl;\r\n FControls.Free;\r\n\r\n FIniLink.Free;\r\n FMsIndicators.Free;\r\n FSelectColumnsDialogStrings.Free;\r\n\r\n FChangeLinks.Free;\r\n\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvDBGrid.RegisterLayoutChangeLink(Link: TJvDBGridLayoutChangeLink);\r\nbegin\r\n if not (csDestroying in ComponentState) then\r\n FChangeLinks.Add(Link);\r\nend;\r\n\r\nprocedure TJvDBGrid.UnregisterLayoutChangeLink(Link: TJvDBGridLayoutChangeLink);\r\nbegin\r\n if not (csDestroying in ComponentState) then\r\n FChangeLinks.Remove(Link);\r\nend;\r\n\r\nfunction TJvDBGrid.EditWithBoolBox(Field: TField): Boolean;\r\nbegin\r\n if FBooleanEditor then\r\n begin\r\n Result := (Field.DataType = ftBoolean);\r\n if not Result and Assigned(FOnCheckIfBooleanField) and\r\n (Field.DataType in [ftSmallint, ftInteger, ftLargeint, ftWord, ftString, ftWideString,\r\n ftBCD, ftFMTBCD\r\n {$IFDEF COMPILER12_UP},ftLongWord, ftShortint{$ENDIF COMPILER12_UP}]) then\r\n begin\r\n FStringForTrue := '1';\r\n FStringForFalse := '0';\r\n Result := FOnCheckIfBooleanField(Self, Field, FStringForTrue, FStringForFalse);\r\n end;\r\n end\r\n else\r\n Result := False;\r\nend;\r\n\r\nfunction TJvDBGrid.GetImageIndex(Field: TField): Integer;\r\nbegin\r\n Result := -1;\r\n if FShowGlyphs and Assigned(Field) then\r\n begin\r\n case Field.DataType of\r\n ftBytes, ftVarBytes, ftBlob, ftTypedBinary:\r\n Result := Ord(gpBlob);\r\n ftGraphic:\r\n Result := Ord(gpPicture);\r\n ftParadoxOle, ftDBaseOle:\r\n Result := Ord(gpOle);\r\n ftCursor, ftReference, ftDataSet:\r\n Result := Ord(gpData);\r\n {$IFDEF COMPILER10_UP}ftWideMemo,{$ENDIF COMPILER10_UP}\r\n ftMemo, ftFmtMemo:\r\n if not ShowMemos then\r\n Result := Ord(gpMemo);\r\n ftOraBlob, ftOraClob:\r\n Result := Ord(gpBlob);\r\n ftBoolean:\r\n if BooleanEditor and not Field.IsNull then\r\n if Field.AsBoolean then\r\n Result := Ord(gpChecked)\r\n else\r\n Result := Ord(gpUnChecked);\r\n {$IFDEF COMPILER10_UP}\r\n ftFixedWideChar,\r\n {$ENDIF COMPILER10_UP}\r\n ftString, ftWideString:\r\n if EditWithBoolBox(Field) and not Field.IsNull then\r\n if AnsiSameText(Field.AsString, FStringForFalse) then\r\n Result := Ord(gpUnChecked)\r\n else\r\n Result := Ord(gpChecked);\r\n {$IFDEF COMPILER12_UP}\r\n ftLongWord, ftShortint,\r\n {$ENDIF COMPILER12_UP}\r\n ftSmallint, ftInteger, ftLargeint, ftWord, ftBCD, ftFMTBCD:\r\n if EditWithBoolBox(Field) and not Field.IsNull then\r\n if Field.AsInteger = 0 then\r\n Result := Ord(gpUnChecked)\r\n else\r\n Result := Ord(gpChecked);\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJvDBGrid.ActiveRowSelected: Boolean;\r\nvar\r\n Index: Integer;\r\nbegin\r\n if MultiSelect and DataLink.Active then\r\n Result := SelectedRows.Find(DataLink.DataSet.Bookmark, Index)\r\n else\r\n Result := False;\r\nend;\r\n\r\nfunction TJvDBGrid.HighlightCell(DataCol, DataRow: Integer;\r\n const Value: string; AState: TGridDrawState): Boolean;\r\nbegin\r\n Result := ActiveRowSelected;\r\n if not Result then\r\n Result := inherited HighlightCell(DataCol, DataRow, Value, AState);\r\nend;\r\n\r\nprocedure TJvDBGrid.ToggleRowSelection;\r\nbegin\r\n if MultiSelect and DataLink.Active then\r\n with SelectedRows do\r\n CurrentRowSelected := not CurrentRowSelected;\r\nend;\r\n\r\nfunction TJvDBGrid.GetSelCount: Longint;\r\nbegin\r\n if MultiSelect and (DataLink <> nil) and DataLink.Active then\r\n Result := SelectedRows.Count\r\n else\r\n Result := 0;\r\nend;\r\n\r\nfunction TJvDBGrid.GetRow: Longint;\r\nbegin\r\n Result := inherited Row;\r\nend;\r\n\r\nprocedure TJvDBGrid.SetRow(Value: Longint);\r\nbegin\r\n if Value <> Row then\r\n begin\r\n if DataLink.Active and (Value >= TopRow) and (Value <= VisibleRowCount) then\r\n DataLink.DataSet.MoveBy(Value - Row)\r\n else\r\n if FBeepOnError then\r\n SysUtils.Beep;\r\n end;\r\nend;\r\n\r\nprocedure TJvDBGrid.SelectAll;\r\nvar\r\n LBookmark: TBookmark;\r\nbegin\r\n if MultiSelect and DataLink.Active then\r\n begin\r\n with DataLink.DataSet do\r\n begin\r\n if Bof and Eof then\r\n Exit;\r\n DisableControls;\r\n try\r\n LBookmark := GetBookmark;\r\n try\r\n First;\r\n while not Eof do\r\n begin\r\n SelectedRows.CurrentRowSelected := True;\r\n Next;\r\n end;\r\n finally\r\n try\r\n GotoBookmark(LBookmark);\r\n except\r\n end;\r\n FreeBookmark(LBookmark);\r\n end;\r\n finally\r\n EnableControls;\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvDBGrid.UnselectAll;\r\nbegin\r\n if MultiSelect then\r\n begin\r\n SelectedRows.Clear;\r\n FSelecting := False;\r\n end;\r\nend;\r\n\r\nprocedure TJvDBGrid.GotoSelection(Index: Longint);\r\nbegin\r\n if MultiSelect and DataLink.Active and (Index < SelectedRows.Count) and\r\n (Index >= 0) then\r\n DataLink.DataSet.GotoBookmark(Pointer(SelectedRows[Index]));\r\nend;\r\n\r\nprocedure TJvDBGrid.LayoutChanged;\r\nvar\r\n ACol: Longint;\r\nbegin\r\n ACol := Col;\r\n inherited LayoutChanged;\r\n if DataLink.Active and (FixedCols > 0) then\r\n Col := Min(Max(CalcLeftColumn, ACol), ColCount - 1);\r\n DoMinColWidth;\r\n DoMaxColWidth;\r\n DoAutoSizeColumns;\r\n\r\n NotifyLayoutChange(lcLayoutChanged);\r\nend;\r\n\r\nprocedure TJvDBGrid.NotifyLayoutChange(const Kind: TJvDBGridLayoutChangeKind);\r\nvar\r\n I: Integer;\r\nbegin\r\n // We cannot trigger DataLink.LayoutChanged nor rely on it, so we notify any linked\r\n // control of the layout changes by calling DoChange on the registered\r\n // TJvDBGridLayoutChangeLink objects\r\n for I := 0 to FChangeLinks.Count-1 do\r\n TJvDBGridLayoutChangeLink(FChangeLinks[I]).DoChange(Self, Kind);\r\n\r\n if FCurrentControl <> nil then\r\n if FCurrentControl.Visible then\r\n PlaceControl(FCurrentControl, Col, Row);\r\nend;\r\n\r\nprocedure TJvDBGrid.ColWidthsChanged;\r\n\r\n { VCL BUGFIX:\r\n The TCustomDBGrid.ColWidthsChanged method invokes DataLink.LayoutChanged/DataSource.OnDataChange\r\n for every column, regardless if it was resized or not.\r\n\r\n This causes a db-aware component or an DataSource.OnDataChange event handler to\r\n be triggered very often even if there was no actual change. This becomes worse\r\n when the assigned DataSet contains many visible fields (=>columns) and the DataChange\r\n event is used to update details data. }\r\n \r\n procedure FixedInheritedColWidthsChanged;\r\n var\r\n I, ChangeCount: Integer;\r\n begin\r\n //inherited TCustomGrid.ColWidthsChanged;\r\n inherited RowHeightsChanged; // does the same that TCustomGrid.ColWidthsChanged does.\r\n\r\n if (Datalink.Active or (Columns.State = csCustomized)) and\r\n AcquireLayoutLock then\r\n try\r\n ChangeCount := 0;\r\n for I := IndicatorOffset to ColCount - 1 do\r\n if Columns[I - IndicatorOffset].Width <> ColWidths[I] then\r\n begin\r\n Inc(ChangeCount);\r\n if ChangeCount > 1 then // we have what we need\r\n Break;\r\n end;\r\n if ChangeCount > 0 then\r\n begin\r\n if ChangeCount > 1 then\r\n DataLink.DataSet.DisableControls;\r\n try\r\n for I := IndicatorOffset to ColCount - 1 do\r\n if Columns[I - IndicatorOffset].Width <> ColWidths[I] then\r\n Columns[I - IndicatorOffset].Width := ColWidths[I];\r\n finally\r\n if ChangeCount > 1 then\r\n DataLink.DataSet.EnableControls;\r\n end;\r\n end;\r\n finally\r\n EndLayout;\r\n end;\r\n end;\r\n\r\nvar\r\n ACol: Longint;\r\nbegin\r\n ACol := Col;\r\n FixedInheritedColWidthsChanged;\r\n if DataLink.Active and (FixedCols > 0) then\r\n Col := Min(Max(CalcLeftColumn, ACol), ColCount - 1);\r\n DoMinColWidth;\r\n DoMaxColWidth;\r\n DoAutoSizeColumns;\r\nend;\r\n\r\nfunction TJvDBGrid.CreateEditor: TInplaceEdit;\r\nbegin\r\n Result := TInternalInplaceEdit.Create(Self);\r\n // replace the call to default constructor :\r\n // Result := inherited CreateEditor;\r\n TInternalInplaceEdit(Result).OnChange := EditChanged;\r\nend;\r\n\r\nfunction TJvDBGrid.GetTitleOffset: Integer;\r\nvar\r\n I, J: Integer;\r\nbegin\r\n Result := 0;\r\n if dgTitles in Options then\r\n begin\r\n Result := 1;\r\n if (DataLink <> nil) and (DataLink.DataSet <> nil) and DataLink.DataSet.ObjectView then\r\n for I := 0 to Columns.Count - 1 do\r\n begin\r\n if Columns[I].Showing then\r\n begin\r\n J := Columns[I].Depth;\r\n if J >= Result then\r\n Result := J + 1;\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvDBGrid.SetColumnAttributes;\r\nbegin\r\n inherited SetColumnAttributes;\r\n SetFixedCols(FFixedCols);\r\nend;\r\n\r\nprocedure TJvDBGrid.SetFixedCols(Value: Integer);\r\nvar\r\n FixCount, I: Integer;\r\nbegin\r\n FixCount := Max(Value, 0) + IndicatorOffset;\r\n if DataLink.Active and not (csLoading in ComponentState) and\r\n (ColCount > IndicatorOffset + 1) then\r\n begin\r\n FixCount := Min(FixCount, ColCount - 1);\r\n inherited FixedCols := FixCount;\r\n for I := 1 to Min(FixedCols, ColCount - 1) do\r\n TabStops[I + IndicatorOffset - 1] := False;\r\n end;\r\n FFixedCols := FixCount - IndicatorOffset;\r\nend;\r\n\r\nfunction TJvDBGrid.GetFixedCols: Integer;\r\nbegin\r\n if DataLink.Active then\r\n Result := inherited FixedCols - IndicatorOffset\r\n else\r\n Result := FFixedCols;\r\nend;\r\n\r\nfunction TJvDBGrid.CalcLeftColumn: Integer;\r\nbegin\r\n Result := FixedCols + IndicatorOffset;\r\n while (Result < ColCount) and (ColWidths[Result] <= 0) do\r\n Inc(Result);\r\nend;\r\n\r\nprocedure TJvDBGrid.KeyDown(var Key: Word; Shift: TShiftState);\r\nvar\r\n KeyDownEvent: TKeyEvent;\r\n\r\n procedure ClearSelections;\r\n begin\r\n if FMultiSelect then\r\n begin\r\n if FClearSelection then\r\n SelectedRows.Clear;\r\n FSelecting := False;\r\n end;\r\n end;\r\n\r\n procedure DoSelection(Select: Boolean; Direction: Integer);\r\n var\r\n AddAfter: Boolean;\r\n begin\r\n AddAfter := False;\r\n if MultiSelect and DataLink.Active then\r\n if Select and (Shift * KeyboardShiftStates = [ssShift]) then\r\n begin\r\n if not FSelecting then\r\n begin\r\n FSelectionAnchor := TBookmarks(SelectedRows).CurrentRow;\r\n SelectedRows.CurrentRowSelected := True;\r\n FSelecting := True;\r\n AddAfter := True;\r\n end\r\n else\r\n begin\r\n with TBookmarks(SelectedRows) do\r\n begin\r\n AddAfter := Compare(CurrentRow, FSelectionAnchor) <> -Direction;\r\n if not AddAfter then\r\n CurrentRowSelected := False;\r\n end;\r\n end;\r\n end\r\n else\r\n ClearSelections;\r\n if Direction <> 0 then\r\n DataLink.DataSet.MoveBy(Direction);\r\n if AddAfter then\r\n SelectedRows.CurrentRowSelected := True;\r\n end;\r\n\r\n procedure NextRow(Select: Boolean);\r\n begin\r\n with DataLink.DataSet do\r\n begin\r\n DoSelection(Select, 1);\r\n if AutoAppend and Eof and CanModify and not ReadOnly and (dgEditing in Options) then\r\n Append;\r\n end;\r\n end;\r\n\r\n procedure PriorRow(Select: Boolean);\r\n begin\r\n DoSelection(Select, -1);\r\n end;\r\n\r\n procedure CheckTab(GoForward: Boolean);\r\n var\r\n ACol, Original: Integer;\r\n begin\r\n ACol := Col;\r\n Original := ACol;\r\n //BeginUpdate;\r\n inherited BeginUpdate;\r\n try\r\n while True do\r\n begin\r\n if GoForward then\r\n Inc(ACol)\r\n else\r\n Dec(ACol);\r\n if ACol >= ColCount then\r\n begin\r\n if MultiSelect then\r\n ClearSelections;\r\n NextRow(False);\r\n ACol := IndicatorOffset;\r\n end\r\n else if ACol < IndicatorOffset then\r\n begin\r\n if MultiSelect then\r\n ClearSelections;\r\n PriorRow(False);\r\n ACol := ColCount - IndicatorOffset;\r\n end;\r\n if ACol = Original then\r\n Exit;\r\n if TabStops[ACol] then\r\n begin\r\n //MoveCol(ACol, 0);\r\n SelectedIndex := ACol - IndicatorOffset;\r\n Break;\r\n end;\r\n end;\r\n finally\r\n inherited EndUpdate;\r\n //EndUpdate; // => EndLayout => ... => Initialize => Col := FixedCols + 1\r\n end;\r\n end;\r\n\r\n function DeletePrompt: Boolean;\r\n var\r\n S: string;\r\n begin\r\n if SelectedRows.Count > 1 then\r\n S := SDeleteMultipleRecordsQuestion\r\n else\r\n S := SDeleteRecordQuestion;\r\n Result := not (dgConfirmDelete in Options) or\r\n (MessageDlg(S, mtConfirmation, [mbYes, mbNo], 0) = mrYes);\r\n end;\r\n\r\nbegin\r\n KeyDownEvent := OnKeyDown;\r\n if Assigned(KeyDownEvent) then\r\n KeyDownEvent(Self, Key, Shift);\r\n if not DataLink.Active or not CanGridAcceptKey(Key, Shift) then\r\n Exit;\r\n with DataLink.DataSet do\r\n if ssCtrl in Shift then\r\n begin\r\n if Key in [VK_UP, VK_PRIOR, VK_DOWN, VK_NEXT, VK_HOME, VK_END] then\r\n ClearSelections;\r\n case Key of\r\n VK_LEFT:\r\n if FixedCols > 0 then\r\n begin\r\n SelectedIndex := CalcLeftColumn - IndicatorOffset;\r\n Exit;\r\n end;\r\n VK_DELETE:\r\n if CanDelete and not ReadOnly and CanModify and not\r\n IsDataSetEmpty(DataLink.DataSet) then\r\n begin\r\n if DeletePrompt then\r\n begin\r\n if SelectedRows.Count > 0 then\r\n SelectedRows.Delete\r\n else\r\n Delete;\r\n end;\r\n Exit;\r\n end\r\n else\r\n begin\r\n // Mantis 4231: Do not pass delete to inherited grid as it would\r\n // allow deleting the row while having CanDelete set to False. \r\n Exit;\r\n end;\r\n end;\r\n end\r\n else\r\n begin\r\n case Key of\r\n VK_LEFT:\r\n if (FixedCols > 0) and not (dgRowSelect in Options) then\r\n if SelectedIndex <= CalcLeftColumn - IndicatorOffset then\r\n Exit;\r\n VK_HOME:\r\n if (FixedCols > 0) and (ColCount <> IndicatorOffset + 1) and\r\n not (dgRowSelect in Options) then\r\n begin\r\n SelectedIndex := CalcLeftColumn - IndicatorOffset;\r\n Exit;\r\n end;\r\n end;\r\n if DataLink.DataSet.State <> dsInsert then\r\n case Key of\r\n VK_UP:\r\n begin\r\n PriorRow(True);\r\n Exit;\r\n end;\r\n VK_DOWN:\r\n begin\r\n NextRow(True);\r\n Exit;\r\n end;\r\n end;\r\n if ((Key in [VK_LEFT, VK_RIGHT]) and (dgRowSelect in Options)) or\r\n ((Key in [VK_HOME, VK_END]) and ((ColCount = IndicatorOffset + 1) or\r\n (dgRowSelect in Options))) or (Key in [VK_ESCAPE, VK_NEXT, VK_PRIOR]) or\r\n ((Key = VK_INSERT) and CanModify and (not ReadOnly) and (dgEditing in Options)) then\r\n ClearSelections\r\n else\r\n if (Key = VK_TAB) and not (ssAlt in Shift) then\r\n begin\r\n CheckTab(not (ssShift in Shift));\r\n Exit;\r\n end;\r\n end;\r\n\r\n OnKeyDown := nil;\r\n try\r\n inherited KeyDown(Key, Shift);\r\n finally\r\n OnKeyDown := KeyDownEvent;\r\n end;\r\nend;\r\n\r\nprocedure TJvDBGrid.SetShowGlyphs(Value: Boolean);\r\nbegin\r\n if FShowGlyphs <> Value then\r\n begin\r\n FShowGlyphs := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvDBGrid.SetAutoSizeRows(Value: Boolean);\r\nbegin\r\n if FAutoSizeRows <> Value then\r\n begin\r\n FAutoSizeRows := Value;\r\n if FAutoSizeRows then\r\n begin\r\n RowResize := False;\r\n LayoutChanged; // Recalculate DefaultRowHeight\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvDBGrid.SetRowsHeight(Value: Integer);\r\nbegin\r\n if (DefaultRowHeight <> Value) and not AutoSizeRows then\r\n begin\r\n FRowsHeight := Value;\r\n DefaultRowHeight := Value;\r\n if dgTitles in Options then\r\n RowHeights[0] := TitleRowHeight;\r\n if HandleAllocated then\r\n Perform(WM_SIZE, SIZE_RESTORED, MakeLong(ClientWidth, ClientHeight));\r\n end\r\n else\r\n FRowsHeight := DefaultRowHeight;\r\nend;\r\n\r\nprocedure TJvDBGrid.SetTitleRowHeight(Value: Integer);\r\nbegin\r\n if (dgTitles in Options) and (RowHeights[0] <> Value) and not AutoSizeRows then\r\n begin\r\n FTitleRowHeight := Value;\r\n RowHeights[0] := Value;\r\n if HandleAllocated then\r\n Perform(WM_SIZE, SIZE_RESTORED, MakeLong(ClientWidth, ClientHeight));\r\n end\r\n else\r\n FTitleRowHeight := RowHeights[0];\r\nend;\r\n\r\nprocedure TJvDBGrid.RowHeightsChanged;\r\nvar\r\n RowIdx,\r\n FirstRow: Integer;\r\nbegin\r\n if DefaultRowHeight <> RowsHeight then\r\n SetRowsHeight(RowsHeight);\r\n if RowHeights[0] <> TitleRowHeight then\r\n SetTitleRowHeight(TitleRowHeight);\r\n\r\n if RowResize then\r\n begin\r\n if dgTitles in Options then\r\n FirstRow := 1\r\n else\r\n FirstRow := 0;\r\n for RowIdx := FirstRow to VisibleRowCount + 1 do\r\n if RowHeights[RowIdx] <> RowsHeight then\r\n begin\r\n SetRowsHeight(RowHeights[RowIdx]);\r\n Break;\r\n end;\r\n end;\r\n\r\n inherited RowHeightsChanged;\r\nend;\r\n\r\nfunction TJvDBGrid.GetDataLink: TDataLink;\r\nbegin\r\n Result := DataLink;\r\nend;\r\n\r\nprocedure TJvDBGrid.SetRowResize(Value: Boolean);\r\nbegin\r\n if FRowResize <> Value then\r\n begin\r\n if AutoSizeRows then\r\n FRowResize := False\r\n else\r\n FRowResize := Value;\r\n SetOptions(Options);\r\n end;\r\nend;\r\n\r\nfunction TJvDBGrid.GetOptions: TDBGridOptions;\r\nbegin\r\n Result := inherited Options;\r\n if FMultiSelect then\r\n Result := Result + [dgMultiSelect]\r\n else\r\n Result := Result - [dgMultiSelect];\r\n\r\n if FAlwaysShowEditor then\r\n Result := Result + [dgAlwaysShowEditor]\r\n else\r\n Result := Result - [dgAlwaysShowEditor];\r\nend;\r\n\r\nprocedure TJvDBGrid.SetOptions(Value: TDBGridOptions);\r\nvar\r\n NewOptions: TGridOptions;\r\nbegin\r\n { The AlwaysShowEditor option is not compatible with the custom inplace edit\r\n controls. But if the EditorMode is set to True in ColEnter() it emulates the\r\n AlwaysShowEditor option. }\r\n inherited Options := Value - [dgMultiSelect, dgAlwaysShowEditor];\r\n FAlwaysShowEditor := dgAlwaysShowEditor in Value;\r\n\r\n NewOptions := TDrawGrid(Self).Options;\r\n {\r\n if FTitleButtons then\r\n begin\r\n TDrawGrid(Self).Options := NewOptions + [goFixedHorzLine, goFixedVertLine];\r\n end\r\n else\r\n }\r\n begin\r\n if RowResize then\r\n Include(NewOptions, goRowSizing)\r\n else\r\n Exclude(NewOptions, goRowSizing);\r\n if not (dgColLines in Value) then\r\n NewOptions := NewOptions - [goFixedVertLine];\r\n if not (dgRowLines in Value) then\r\n NewOptions := NewOptions - [goFixedHorzLine];\r\n TDrawGrid(Self).Options := NewOptions;\r\n end;\r\n SetMultiSelect(dgMultiSelect in Value);\r\nend;\r\n\r\nfunction TJvDBGrid.DoEraseBackground(Canvas: TCanvas; Param: LPARAM): Boolean;\r\nvar\r\n R: TRect;\r\n Size: TSize;\r\nbegin\r\n { Fill the area between the two scroll bars. }\r\n Size.cx := GetSystemMetrics(SM_CXVSCROLL);\r\n Size.cy := GetSystemMetrics(SM_CYHSCROLL);\r\n if UseRightToLeftAlignment then\r\n R := Bounds(0, Height - Size.cy, Size.cx, Size.cy)\r\n else\r\n R := Bounds(Width - Size.cx, Height - Size.cy, Size.cx, Size.cy);\r\n Canvas.Brush.Color := Color;\r\n Canvas.FillRect(R);\r\n\r\n Result := True;\r\nend;\r\n\r\nprocedure TJvDBGrid.Paint;\r\nbegin\r\n if Assigned(FOnBeforePaint) then\r\n FOnBeforePaint(Self);\r\n {$IFNDEF COMPILER14_UP}\r\n {$IFDEF JVCLThemesEnabled}\r\n if UseXPThemes and ThemeServices.ThemesEnabled then\r\n begin\r\n // reset the inherited options but remove the goFixedVertLine and goFixedHorzLine values\r\n // as that causes the titles and indicator panels to have a black border\r\n TStringGrid(Self).Options := TStringGrid(Self).Options - [goFixedVertLine, goFixedHorzLine];\r\n end;\r\n {$ENDIF JVCLThemesEnabled}\r\n {$ENDIF ~COMPILER14_UP}\r\n inherited Paint;\r\n if not (csDesigning in ComponentState) and\r\n (dgRowSelect in Options) and DefaultDrawing and Focused then\r\n begin\r\n Canvas.Font.Color := clWindowText;\r\n with Selection do\r\n DrawFocusRect(Canvas.Handle, BoxRect(Left, Top, Right, Bottom));\r\n end;\r\n if Assigned(FOnAfterPaint) then\r\n FOnAfterPaint(Self);\r\nend;\r\n\r\nprocedure TJvDBGrid.SetTitleButtons(Value: Boolean);\r\nbegin\r\n if FTitleButtons <> Value then\r\n begin\r\n FTitleButtons := Value;\r\n Invalidate;\r\n SetOptions(Options);\r\n end;\r\nend;\r\n\r\nprocedure TJvDBGrid.SetMultiSelect(Value: Boolean);\r\nbegin\r\n if FMultiSelect <> Value then\r\n begin\r\n FMultiSelect := Value;\r\n if not Value then\r\n SelectedRows.Clear;\r\n end;\r\nend;\r\n\r\nfunction TJvDBGrid.GetStorage: TJvFormPlacement;\r\nbegin\r\n Result := FIniLink.Storage;\r\nend;\r\n\r\nprocedure TJvDBGrid.SetStorage(Value: TJvFormPlacement);\r\nbegin\r\n if not (csDestroying in ComponentState) then\r\n FIniLink.Storage := Value;\r\nend;\r\n\r\nfunction TJvDBGrid.AcquireFocus: Boolean;\r\nbegin\r\n Result := True;\r\n if FAcquireFocus and CanFocus and not (csDesigning in ComponentState) then\r\n begin\r\n SetFocus;\r\n Result := Focused or ((InplaceEditor <> nil) and InplaceEditor.Focused) or\r\n ((FCurrentControl <> nil) and FCurrentControl.Focused);\r\n end;\r\nend;\r\n\r\nfunction TJvDBGrid.CanEditShow: Boolean;\r\n\r\n function UseDefaultEditor: Boolean;\r\n const\r\n ude_DEFAULT_EDITOR = 0;\r\n ude_BOOLEAN_EDITOR = 1;\r\n ude_CUSTOM_EDITOR = 2;\r\n var\r\n F: TField;\r\n Editor: Shortint;\r\n Control: TJvDBGridControl;\r\n EditControl: TWinControl;\r\n\r\n function IsReadOnlyField: Boolean;\r\n begin\r\n Result := ReadOnly or Columns[SelectedIndex].ReadOnly or F.ReadOnly or\r\n not F.DataSet.CanModify;\r\n end;\r\n\r\n begin\r\n // Is there an editor for the selected field ?\r\n F := SelectedField;\r\n Control := FControls.ControlByField(F.FieldName);\r\n if Assigned(Control) then\r\n Editor := ude_CUSTOM_EDITOR\r\n else\r\n if EditWithBoolBox(F) then\r\n Editor := ude_BOOLEAN_EDITOR\r\n else\r\n begin\r\n Editor := ude_DEFAULT_EDITOR;\r\n\r\n // The default editor cannot modify a binary or memo field\r\n if (F.DataType in [ftUnknown, ftBytes, ftVarBytes, ftAutoInc, ftBlob,\r\n ftMemo, ftFmtMemo{$IFDEF COMPILER10_UP}, ftWideMemo{$ENDIF COMPILER10_UP}, ftGraphic, ftTypedBinary, ftDBaseOle, ftParadoxOle,\r\n ftCursor, ftADT, ftReference, ftDataSet, ftOraBlob, ftOraClob]) then\r\n begin\r\n Result := False;\r\n HideCurrentControl;\r\n HideEditor;\r\n Exit;\r\n end;\r\n end;\r\n\r\n if not CanEditCell(F) then\r\n begin\r\n HideCurrentControl;\r\n HideEditor;\r\n Exit;\r\n end;\r\n\r\n // There is an editor, so we trigger the OnShowEditor event\r\n Result := True;\r\n if Assigned(OnShowEditor) and\r\n not (Assigned(InplaceEditor) and InplaceEditor.Visible) then\r\n begin\r\n // This event can be triggered twice with the default editor because of the\r\n // two successive calls to CanEditShow in the UpdateEdit function of Grids.pas\r\n OnShowEditor(Self, F, Result);\r\n if not Result then\r\n begin\r\n HideCurrentControl;\r\n HideEditor;\r\n Exit;\r\n end;\r\n end;\r\n\r\n // Is it a customized editor ?\r\n if Editor = ude_CUSTOM_EDITOR then\r\n begin\r\n Result := False;\r\n HideEditor;\r\n EditControl := TWinControl(Owner.FindComponent(Control.ControlName));\r\n if not Assigned(EditControl) then\r\n begin\r\n Control.FieldName := '';\r\n raise EJVCLDbGridException.CreateRes(@RsEJvDBGridControlPropertyNotAssigned);\r\n end;\r\n if IsPublishedProp(EditControl, 'ReadOnly') then\r\n begin\r\n SetOrdProp(EditControl, 'ReadOnly', Ord(IsReadOnlyField));\r\n PlaceControl(EditControl, Col, Row);\r\n end\r\n else\r\n if IsReadOnlyField then\r\n HideCurrentControl\r\n else\r\n PlaceControl(EditControl, Col, Row);\r\n end\r\n else\r\n if Editor = ude_BOOLEAN_EDITOR then\r\n begin\r\n // Boolean editor\r\n Result := False;\r\n HideCurrentControl;\r\n HideEditor;\r\n if not IsReadOnlyField then\r\n FBooleanFieldToEdit := F;\r\n end\r\n else\r\n // Default editor\r\n HideCurrentControl;\r\n end;\r\n\r\nbegin\r\n Result := False;\r\n if (inherited CanEditShow) and Assigned(SelectedField) and\r\n (SelectedIndex >= 0) and (SelectedIndex < Columns.Count) then\r\n begin\r\n FBooleanFieldToEdit := nil;\r\n Result := UseDefaultEditor;\r\n end\r\n else\r\n begin\r\n if not FAlwaysShowEditor or ([dgRowSelect, dgEditing] * Options <> [dgEditing]) then\r\n if HandleAllocated and not (Assigned(InplaceEditor) and InplaceEditor.Visible) then\r\n HideEditor;\r\n end;\r\nend;\r\n\r\nfunction TJvDBGrid.CanEditCell(AField: TField): Boolean;\r\nbegin\r\n Result := True;\r\n if Assigned(FOnCanEditCell) then\r\n FOnCanEditCell(Self, AField, Result);\r\nend;\r\n\r\nprocedure TJvDBGrid.GetCellProps(Column: TColumn; AFont: TFont;\r\n var Background: TColor; Highlight: Boolean);\r\n\r\n function IsAfterFixedCols: Boolean;\r\n begin\r\n Result := Column.Index >= FixedCols;\r\n end;\r\n\r\nbegin\r\n if IsAfterFixedCols and (FCurrentDrawRow >= FixedRows) then\r\n begin\r\n if Odd(FCurrentDrawRow + FixedRows) then\r\n begin\r\n if (FAlternateRowColor <> clNone) and (FAlternateRowColor <> Color) then\r\n begin\r\n // Prefer the column's color\r\n if not ((cvColor in Column.AssignedValues) and (Column.Color <> Column.DefaultColor)) then\r\n Background := AlternateRowColor;\r\n end;\r\n if FAlternateRowFontColor <> clNone then\r\n begin\r\n // Prefer the column's font.color if it has a prefered color\r\n if not ((cvColor in Column.AssignedValues) and (Column.Color <> Column.DefaultColor)) then\r\n AFont.Color := AlternateRowFontColor;\r\n end;\r\n end;\r\n end\r\n else\r\n Background := FixedColor;\r\n\r\n if Highlight then\r\n begin\r\n AFont.Color := clHighlightText;\r\n Background := clHighlight;\r\n end;\r\n if Assigned(FOnGetCellParams) then\r\n FOnGetCellParams(Self, Column.Field, AFont, Background, Highlight)\r\n else\r\n if Assigned(FOnGetCellProps) then\r\n FOnGetCellProps(Self, Column.Field, AFont, Background);\r\nend;\r\n\r\nprocedure TJvDBGrid.DoTitleClick(ACol: Longint; AField: TField);\r\n// Fred: This function has a few known bugs, so don't complain about them and use\r\n// JvDBUltimGrid instead if you're looking for an improved sorting function.\r\nconst\r\n cIndexName = 'IndexName';\r\n cIndexDefs = 'IndexDefs';\r\n cDirection: array [Boolean] of TSortMarker = (smDown, smUp);\r\nvar\r\n IndexDefs: TIndexDefs;\r\n LIndexName: string;\r\n Descending: Boolean;\r\n IndexFound: Boolean;\r\n\r\n function GetIndexOf(AFieldName: string; var AIndexName: string; var Descending: Boolean): Boolean;\r\n var\r\n I: Integer;\r\n IsDescending: Boolean;\r\n begin\r\n Result := False;\r\n for I := 0 to IndexDefs.Count - 1 do\r\n begin\r\n if Pos(AFieldName, IndexDefs[I].Fields) >= 1 then\r\n begin\r\n AIndexName := IndexDefs[I].Name; // best match so far\r\n IsDescending := (ixDescending in IndexDefs[I].Options);\r\n Result := True;\r\n if Descending <> IsDescending then\r\n // we've found an index that is the opposite direction of the previous one, so we return now\r\n begin\r\n Descending := IsDescending;\r\n Exit;\r\n end;\r\n end;\r\n // if we get here and Result is True, it means we've found a matching index but it\r\n // might be the same as the previous one...\r\n end;\r\n end;\r\n\r\nbegin\r\n IndexFound := False;\r\n\r\n if AutoSort and IsPublishedProp(DataSource.DataSet, cIndexDefs) and\r\n IsPublishedProp(DataSource.DataSet, cIndexName) then\r\n IndexDefs := TIndexDefs(GetObjectProp(DataSource.DataSet, cIndexDefs))\r\n else\r\n IndexDefs := nil;\r\n if Assigned(IndexDefs) and Assigned(AField) then\r\n begin\r\n Descending := SortMarker = smUp;\r\n if GetIndexOf(AField.FieldName, LIndexName, Descending) then\r\n begin\r\n IndexFound := True;\r\n SortedField := AField.FieldName;\r\n SortMarker := cDirection[Descending];\r\n try\r\n SetStrProp(DataSource.DataSet, cIndexName, LIndexName);\r\n except\r\n end;\r\n end;\r\n end;\r\n //--------------------------------------------------------------------------\r\n // FBC: 2004-02-18\r\n // Following code handles the sortmarker if no Index is found.\r\n // the actual data-sorting must be implemented by the user in\r\n // event OnTitleBtnClick. Of course, we need a field (Mantis 3845)\r\n //--------------------------------------------------------------------------\r\n if AutoSort and not IndexFound and Assigned(AField) then\r\n begin\r\n if SortedField = AField.FieldName then\r\n begin\r\n case Self.SortMarker of\r\n smUp:\r\n Self.SortMarker := smDown;\r\n smDown:\r\n Self.SortMarker := smUp;\r\n end;\r\n end\r\n else\r\n begin\r\n SortedField := AField.FieldName;\r\n Self.SortMarker := smUp;\r\n end;\r\n end;\r\n if Assigned(FOnTitleBtnClick) then\r\n FOnTitleBtnClick(Self, ACol, AField);\r\nend;\r\n\r\nprocedure TJvDBGrid.CheckTitleButton(ACol, ARow: Longint; var Enabled: Boolean);\r\nvar\r\n Field: TField;\r\nbegin\r\n if (ACol >= 0) and (ACol < Columns.Count) then\r\n begin\r\n if Assigned(FOnCheckButton) then\r\n begin\r\n Field := Columns[ACol].Field;\r\n if ColumnAtDepth(Columns[ACol], ARow) <> nil then\r\n Field := ColumnAtDepth(Columns[ACol], ARow).Field;\r\n FOnCheckButton(Self, ACol, Field, Enabled);\r\n end;\r\n end\r\n else\r\n Enabled := False;\r\nend;\r\n\r\nprocedure TJvDBGrid.DisableScroll;\r\nbegin\r\n Inc(FDisableCount);\r\nend;\r\n\r\ntype\r\n TGridDataLinkAccessProtected = class(TGridDataLink);\r\n\r\nprocedure TJvDBGrid.EnableScroll;\r\nbegin\r\n if FDisableCount <> 0 then\r\n begin\r\n Dec(FDisableCount);\r\n if (FDisableCount = 0) and DataLink.Active then\r\n TGridDataLinkAccessProtected(DataLink).DataSetScrolled(0);\r\n end;\r\nend;\r\n\r\nfunction TJvDBGrid.ScrollDisabled: Boolean;\r\nbegin\r\n Result := FDisableCount <> 0;\r\nend;\r\n\r\nprocedure TJvDBGrid.Scroll(Distance: Integer);\r\nbegin\r\n if FDisableCount = 0 then\r\n begin\r\n inherited Scroll(Distance);\r\n if ((AlternateRowColor <> clNone) and (AlternateRowColor <> Color)) or\r\n ((AlternateRowFontColor <> clNone) and (AlternateRowFontColor <> Font.Color)) then\r\n Invalidate;\r\n\r\n if FAlwaysShowEditor and HandleAllocated and ([dgRowSelect, dgEditing] * Options = [dgEditing]) and\r\n Focused then\r\n begin\r\n ShowEditor;\r\n InvalidateCol(Col);\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJvDBGrid.DoMouseWheelDown(Shift: TShiftState; MousePos: TPoint): Boolean;\r\nvar\r\n Distance: Integer;\r\nbegin\r\n Result := False;\r\n if Assigned(OnMouseWheelDown) then\r\n OnMouseWheelDown(Self, Shift, MousePos, Result);\r\n if not Result then\r\n begin\r\n if not AcquireFocus then\r\n Exit;\r\n if ssCtrl in Shift then\r\n Distance := VisibleRowCount - 1\r\n else\r\n if ssShift in Shift then\r\n Distance := 1\r\n else\r\n Distance := 2;\r\n if DataLink.Active then\r\n Result := DataLink.DataSet.MoveBy(Distance) <> 0;\r\n end;\r\nend;\r\n\r\nfunction TJvDBGrid.DoMouseWheelUp(Shift: TShiftState; MousePos: TPoint): Boolean;\r\nvar\r\n Distance: Integer;\r\nbegin\r\n Result := False;\r\n if Assigned(OnMouseWheelUp) then\r\n OnMouseWheelUp(Self, Shift, MousePos, Result);\r\n if not Result then\r\n begin\r\n if not AcquireFocus then\r\n Exit;\r\n if Shift * KeyboardShiftStates = [ssCtrl] then\r\n Distance := VisibleRowCount - 1\r\n else\r\n if ssShift in Shift then\r\n Distance := 1\r\n else\r\n Distance := 2;\r\n if DataLink.Active then\r\n Result := DataLink.DataSet.MoveBy(-Distance) <> 0;\r\n end;\r\nend;\r\n\r\nprocedure TJvDBGrid.EditChanged(Sender: TObject);\r\nbegin\r\n if Assigned(FOnEditChange) then\r\n FOnEditChange(Self);\r\nend;\r\n\r\nprocedure TJvDBGrid.GridInvalidateRow(Row: Longint);\r\nvar\r\n I: Longint;\r\nbegin\r\n for I := 0 to ColCount - 1 do\r\n InvalidateCell(I, Row);\r\nend;\r\n\r\nprocedure TJvDBGrid.LinkActive(Value: Boolean);\r\nbegin\r\n inherited LinkActive(Value);\r\n if Value and FAlwaysShowEditor then\r\n ShowEditor;\r\nend;\r\n\r\n{$IFDEF COMPILER9_UP}\r\nprocedure TJvDBGrid.UpdateScrollBar;\r\nbegin\r\n if HandleAllocated then\r\n begin\r\n // The grid can only handle ssNone and ssHorizontal. We have to emulate the other modes.\r\n if not (FScrollBars in [ssNone, ssHorizontal]) then\r\n inherited UpdateScrollBar;\r\n if FScrollBars = ssVertical then\r\n ShowScrollBar(Handle, SB_HORZ, False);\r\n\r\n // UpdateScrollBar is the only virtual method that is called from TDBGrid.DataChanged\r\n if FAlwaysShowEditor and ([dgRowSelect, dgEditing] * Options = [dgEditing]) and\r\n Focused then\r\n begin\r\n ShowEditor;\r\n InvalidateCol(Col);\r\n end;\r\n end;\r\nend;\r\n{$ENDIF COMPILER9_UP}\r\n\r\nprocedure TJvDBGrid.TopLeftChanged;\r\nbegin\r\n if (dgRowSelect in Options) and DefaultDrawing then\r\n GridInvalidateRow(Self.Row);\r\n inherited TopLeftChanged;\r\n if FTracking then\r\n StopTracking;\r\n if Assigned(FOnTopLeftChanged) then\r\n FOnTopLeftChanged(Self);\r\n\r\n NotifyLayoutChange(lcTopLeftChanged);\r\nend;\r\n\r\nprocedure TJvDBGrid.StopTracking;\r\nbegin\r\n if FTracking or FSwapButtons then\r\n begin\r\n TrackButton(-1, -1);\r\n FTracking := False;\r\n MouseCapture := False;\r\n end;\r\nend;\r\n\r\nprocedure TJvDBGrid.TrackButton(X, Y: Integer);\r\nvar\r\n Cell: TGridCoord;\r\n NewPressed: Boolean;\r\n I, Offset: Integer;\r\nbegin\r\n Cell := MouseCoord(X, Y);\r\n Offset := TitleOffset;\r\n NewPressed := Windows.PtInRect(Rect(0, 0, ClientWidth, ClientHeight), {Types.} Point(X, Y)) and\r\n (FPressedCol = GetMasterColumn(Cell.X, Cell.Y)) and (Cell.Y < Offset);\r\n if FPressed <> NewPressed then\r\n begin\r\n FPressed := NewPressed;\r\n for I := 0 to Offset - 1 do\r\n GridInvalidateRow(I);\r\n end;\r\nend;\r\n\r\nprocedure TJvDBGrid.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);\r\nvar\r\n Cell, LastCell: TGridCoord;\r\n MouseDownEvent: TMouseEvent;\r\n EnableClick: Boolean;\r\n CursorPos: TPoint;\r\n lLastSelected, lNewSelected: {$IFDEF RTL200_UP}TBookmark{$ELSE}TBookmarkStr{$ENDIF RTL200_UP};\r\n lCompare: Integer;\r\n WasAlwaysShowEditor: Boolean;\r\n WasRowResizing: Boolean;\r\nbegin\r\n if not AcquireFocus then\r\n Exit;\r\n if (ssDouble in Shift) and (Button = mbLeft) then\r\n begin\r\n DblClick;\r\n Exit;\r\n end;\r\n FAcquireFocus := False;\r\n try\r\n { XP Theming }\r\n {$IFNDEF COMPILER14_UP}\r\n {$IFDEF JVCLThemesEnabled}\r\n if not (csDesigning in ComponentState) and UseXPThemes and ThemeServices.ThemesEnabled then\r\n begin\r\n FPaintInfo.ColSizing := Sizing(X, Y);\r\n if not FPaintInfo.ColSizing then\r\n begin\r\n FPaintInfo.ColPressedIdx := -1;\r\n FPaintInfo.ColPressed := False;\r\n if AllowTitleClick then\r\n FPaintInfo.MouseInCol := -1;\r\n Cell := MouseCoord(X, Y);\r\n if (Button = mbLeft) and (Cell.X >= IndicatorOffset) and (Cell.Y >= 0) and AllowTitleClick then\r\n begin\r\n FPaintInfo.ColPressed := Cell.Y < TitleOffset;\r\n if FPaintInfo.ColPressed then\r\n FPaintInfo.ColPressedIdx := Columns[RawToDataColumn(Cell.X)].Index + ColumnOffset;\r\n if ValidCell(FCell) then\r\n InvalidateCell(FCell.X, FCell.Y);\r\n FCell := Cell;\r\n end;\r\n end;\r\n end;\r\n {$ENDIF JVCLThemesEnabled}\r\n {$ENDIF ~COMPILER14_UP}\r\n\r\n if Sizing(X, Y) then\r\n inherited MouseDown(Button, Shift, X, Y)\r\n else\r\n begin\r\n Cell := MouseCoord(X, Y);\r\n LastCell.X := Col;\r\n LastCell.Y := Row;\r\n\r\n if (Button = mbRight) and\r\n (dgTitles in Options) and (dgIndicator in Options) and\r\n (Cell.Y = 0) then\r\n begin\r\n if (Cell.X = 0) and FTitleArrow and Assigned(FOnTitleArrowMenuEvent) then\r\n begin\r\n FOnTitleArrowMenuEvent(Self);\r\n Exit;\r\n end;\r\n\r\n // Display TitlePopup if it exists\r\n if Assigned(FTitlePopup) then\r\n begin\r\n GetCursorPos(CursorPos);\r\n FTitlePopup.PopupComponent := Self;\r\n FTitlePopup.Popup(CursorPos.X, CursorPos.Y);\r\n Exit;\r\n end;\r\n end;\r\n\r\n if (DragKind = dkDock) and (Cell.X < IndicatorOffset) and\r\n (Cell.Y < TitleOffset) and not (csDesigning in ComponentState) then\r\n begin\r\n BeginDrag(False);\r\n Exit;\r\n end;\r\n if FTitleButtons and (DataLink <> nil) and DataLink.Active and\r\n (Cell.Y < TitleOffset) and (Cell.X >= IndicatorOffset) and\r\n not (csDesigning in ComponentState) then\r\n begin\r\n if ((dgColumnResize in Options) or (csDesigning in ComponentState)) and (Button = mbRight) then\r\n begin\r\n Button := mbLeft;\r\n FSwapButtons := True;\r\n MouseCapture := True;\r\n FPressedCol := GetMasterColumn(Cell.X, Cell.Y);\r\n TrackButton(X, Y);\r\n end\r\n else\r\n if Button = mbLeft then\r\n begin\r\n EnableClick := True;\r\n CheckTitleButton(Cell.X - IndicatorOffset, Cell.Y, EnableClick);\r\n if EnableClick then\r\n begin\r\n MouseCapture := True;\r\n FTracking := True;\r\n FPressedCol := GetMasterColumn(Cell.X, Cell.Y);\r\n TrackButton(X, Y);\r\n end\r\n else\r\n if FBeepOnError then\r\n SysUtils.Beep;\r\n if not TitleButtonAllowMove then\r\n Exit;\r\n end;\r\n end;\r\n if Cell.Y >= 0 then\r\n begin\r\n if (Cell.X < FixedCols + IndicatorOffset) and DataLink.Active then\r\n begin\r\n if dgIndicator in Options then\r\n inherited MouseDown(Button, Shift, 1, Y)\r\n else\r\n if Cell.Y >= TitleOffset then\r\n if Cell.Y - Row <> 0 then\r\n DataLink.DataSet.MoveBy(Cell.Y - Row);\r\n end\r\n else\r\n begin\r\n { Do not show the editor if the user right clicks on the cell. Otherwise\r\n the grid's popup menu will never show. }\r\n WasAlwaysShowEditor := dgAlwaysShowEditor in Options;\r\n if WasAlwaysShowEditor and (Button = mbRight) {and (PopupMenu <> nil)} then\r\n Options := Options - [dgAlwaysShowEditor];\r\n try\r\n //-------------------------------------------------------------------------------\r\n // Prevents the grid from going back to the first column when dgRowSelect is True\r\n // Does not work if there's no indicator column\r\n //-------------------------------------------------------------------------------\r\n if (dgRowSelect in Options) and (Cell.Y >= TitleOffset) then\r\n begin\r\n // Why do we always have to work around the VCL. If we use the original X the\r\n // Grid will scroll back to the first column. But if we don't use the original X\r\n // and goRowSizing is enabled, the user can start resizing rows in the wild.\r\n WasRowResizing := goRowSizing in TCustomGridAccess(Self).Options;\r\n try\r\n // Disable goRowSizing without all the code that SetOptions executes.\r\n TGridOptions(Pointer(@TCustomGridAccess(Self).Options)^) := TCustomGridAccess(Self).Options - [goRowSizing];\r\n inherited MouseDown(Button, Shift, 1, Y);\r\n finally\r\n if WasRowResizing then\r\n TGridOptions(Pointer(@TCustomGridAccess(Self).Options)^) := TCustomGridAccess(Self).Options + [goRowSizing];\r\n end;\r\n end\r\n else\r\n inherited MouseDown(Button, Shift, X, Y);\r\n if (Col = LastCell.X) and (Row <> LastCell.Y) then\r\n begin\r\n { ColEnter is not invoked when switching between rows staying in the\r\n same column. }\r\n if FAlwaysShowEditor and not EditorMode then\r\n ShowEditor;\r\n end;\r\n finally\r\n if WasAlwaysShowEditor and (Button = mbRight) {and (PopupMenu <> nil)} then\r\n Options := Options + [dgAlwaysShowEditor];\r\n end;\r\n end;\r\n end;\r\n MouseDownEvent := OnMouseDown;\r\n if Assigned(MouseDownEvent) then\r\n MouseDownEvent(Self, Button, Shift, X, Y);\r\n if not (((csDesigning in ComponentState) or (dgColumnResize in Options)) and\r\n (Cell.Y < TitleOffset)) and (Button = mbLeft) then\r\n begin\r\n if MultiSelect and DataLink.Active then\r\n with SelectedRows do\r\n begin\r\n FSelecting := False;\r\n if Shift * KeyboardShiftStates = [ssCtrl] then\r\n CurrentRowSelected := not CurrentRowSelected\r\n else\r\n begin\r\n if (Shift * KeyboardShiftStates = [ssShift]) and (Count > 0) then\r\n begin\r\n lLastSelected := Items[Count - 1];\r\n CurrentRowSelected := not CurrentRowSelected;\r\n if CurrentRowSelected then\r\n begin\r\n with DataLink.DataSet do\r\n begin\r\n DisableControls;\r\n try\r\n lNewSelected := Bookmark;\r\n lCompare := CompareBookmarks(Pointer(lNewSelected), Pointer(lLastSelected));\r\n if lCompare > 0 then\r\n begin\r\n GotoBookmark(Pointer(lLastSelected));\r\n Next;\r\n while not (CurrentRowSelected and ({$IFDEF RTL200_UP}CompareBookmarks(Bookmark, lNewSelected) = 0{$ELSE}Bookmark = lNewSelected{$ENDIF RTL200_UP})) do\r\n begin\r\n CurrentRowSelected := True;\r\n Next;\r\n end;\r\n end\r\n else\r\n if lCompare < 0 then\r\n begin\r\n GotoBookmark(Pointer(lLastSelected));\r\n Prior;\r\n while not (CurrentRowSelected and ({$IFDEF RTL200_UP}CompareBookmarks(Bookmark, lNewSelected) = 0{$ELSE}Bookmark = lNewSelected{$ENDIF RTL200_UP})) do\r\n begin\r\n CurrentRowSelected := True;\r\n Prior;\r\n end;\r\n end;\r\n finally\r\n EnableControls;\r\n end;\r\n end;\r\n end;\r\n end\r\n else\r\n begin\r\n Clear;\r\n if FClearSelection then\r\n CurrentRowSelected := True;\r\n end;\r\n end;\r\n end;\r\n end;\r\n end;\r\n finally\r\n FAcquireFocus := True;\r\n end;\r\nend;\r\n\r\nprocedure TJvDBGrid.MouseMove(Shift: TShiftState; X, Y: Integer);\r\n{$IFNDEF COMPILER14_UP}\r\n{$IFDEF JVCLThemesEnabled}\r\nvar\r\n Cell: TGridCoord;\r\n MouseInCol: Integer;\r\n{$ENDIF JVCLThemesEnabled}\r\n{$ENDIF ~COMPILER14_UP}\r\nbegin\r\n { XP Theming }\r\n {$IFNDEF COMPILER14_UP}\r\n {$IFDEF JVCLThemesEnabled}\r\n if not (csDesigning in ComponentState) and UseXPThemes and ThemeServices.ThemesEnabled then\r\n begin\r\n if not FPaintInfo.ColSizing and not FPaintInfo.ColMoving then\r\n begin\r\n FPaintInfo.MouseInCol := -1;\r\n Cell := MouseCoord(X, Y);\r\n if (Cell.X >= IndicatorOffset) and (Cell.Y >= 0) then\r\n begin\r\n if (Cell.Y < TitleOffset) then\r\n begin\r\n MouseInCol := Columns[RawToDataColumn(Cell.X)].Index + ColumnOffset;\r\n if MouseInCol <> FPaintInfo.MouseInCol then\r\n begin\r\n InvalidateCell(Cell.X, Cell.Y);\r\n FPaintInfo.MouseInCol := MouseInCol;\r\n end;\r\n end\r\n end;\r\n if ValidCell(FCell) then\r\n InvalidateCell(FCell.X, FCell.Y);\r\n FCell := Cell;\r\n end;\r\n end;\r\n {$ENDIF JVCLThemesEnabled}\r\n {$ENDIF ~COMPILER14_UP}\r\n\r\n if FTracking and not FSwapButtons then\r\n TrackButton(X, Y);\r\n inherited MouseMove(Shift, X, Y);\r\nend;\r\n\r\nprocedure TJvDBGrid.MouseUp(Button: TMouseButton; Shift: TShiftState;\r\n X, Y: Integer);\r\nvar\r\n Cell: TGridCoord;\r\n ACol: Longint;\r\n DoClick: Boolean;\r\n ALeftCol: Integer;\r\nbegin\r\n Cell := MouseCoord(X, Y);\r\n if FTracking and (FPressedCol <> nil) then\r\n begin\r\n DoClick := PtInRect(Rect(0, 0, ClientWidth, ClientHeight), {Types.} Point(X, Y)) and\r\n (Cell.Y < TitleOffset) and\r\n (FPressedCol = GetMasterColumn(Cell.X, Cell.Y));\r\n StopTracking;\r\n if DoClick then\r\n begin\r\n ACol := Cell.X;\r\n if dgIndicator in Options then\r\n Dec(ACol, IndicatorOffset);\r\n if (DataLink <> nil) and DataLink.Active and (ACol >= 0) and\r\n (ACol < Columns.Count) then\r\n DoTitleClick(FPressedCol.Index, FPressedCol.Field);\r\n end;\r\n end\r\n else\r\n if FSwapButtons then\r\n begin\r\n StopTracking;\r\n FSwapButtons := False;\r\n MouseCapture := False;\r\n if Button = mbRight then\r\n Button := mbLeft;\r\n end;\r\n if (Button = mbLeft) and (FGridState = gsColSizing) and\r\n (FSizingIndex + Byte(not (dgIndicator in Options)) <= FixedCols) then\r\n begin\r\n ColWidths[FSizingIndex] := GetMinColWidth(X - FSizingOfs - CellRect(FSizingIndex, 0).Left);\r\n FGridState := gsNormal;\r\n end;\r\n\r\n if FTitleArrow and (Button = mbLeft) and\r\n (dgTitles in Options) and (dgIndicator in Options) and\r\n (Cell.X = 0) and (Cell.Y = 0) and (Columns.Count > 0) then\r\n ShowSelectColumnClick; // Selection of columns\r\n\r\n if (Button = mbLeft) and (FGridState = gsColSizing) then\r\n begin\r\n ALeftCol := LeftCol;\r\n inherited MouseUp(Button, Shift, X, Y);\r\n if (dgRowSelect in Options) then\r\n LeftCol := ALeftCol;\r\n if Assigned(OnColumnResized) then\r\n OnColumnResized(Self, FSizingIndex + Byte(not (dgIndicator in Options)) - 1,\r\n ColWidths[FSizingIndex]);\r\n end\r\n else\r\n inherited MouseUp(Button, Shift, X, Y);\r\n DoAutoSizeColumns;\r\n\r\n { XP Theming }\r\n {$IFNDEF COMPILER14_UP}\r\n {$IFDEF JVCLThemesEnabled}\r\n if UseXPThemes and ThemeServices.ThemesEnabled then\r\n begin\r\n FPaintInfo.ColSizing := False;\r\n FPaintInfo.ColMoving := False;\r\n FPaintInfo.ColPressedIdx := -1;\r\n Invalidate;\r\n end;\r\n {$ENDIF JVCLThemesEnabled}\r\n {$ENDIF ~COMPILER14_UP}\r\nend;\r\n\r\nprocedure TJvDBGrid.WMRButtonUp(var Msg: TWMMouse);\r\nbegin\r\n if not (FGridState in [gsColMoving, gsRowMoving]) then\r\n inherited\r\n else\r\n if not (csNoStdEvents in ControlStyle) then\r\n with Msg do\r\n MouseUp(mbRight, KeysToShiftState(Keys), XPos, YPos);\r\nend;\r\n\r\nprocedure TJvDBGrid.WMCancelMode(var Msg: TMessage);\r\nbegin\r\n StopTracking;\r\n inherited;\r\nend;\r\n\r\ntype\r\n TWinControlAccessProtected = class(TWinControl);\r\n\r\nfunction TJvDBGrid.DoKeyPress(var Msg: TWMChar): Boolean;\r\nvar\r\n Form: TCustomForm;\r\n Ch: Char;\r\nbegin\r\n Result := True;\r\n Form := GetParentForm(Self);\r\n if Form <> nil then\r\n if Form.KeyPreview and TWinControlAccessProtected(Form).DoKeyPress(Msg) then\r\n Exit;\r\n\r\n with Msg do\r\n begin\r\n if Assigned(OnKeyPress) then\r\n begin\r\n Ch := Char(CharCode);\r\n OnKeyPress(Self, Ch);\r\n CharCode := Word(Ch);\r\n end;\r\n if CharCode = 0 then\r\n Exit;\r\n end;\r\n Result := False;\r\nend;\r\n\r\nprocedure TJvDBGrid.WMChar(var Msg: TWMChar);\r\nbegin\r\n if Assigned(SelectedField) and EditWithBoolBox(SelectedField) and\r\n CharInSet(Char(Msg.CharCode), [Backspace, #32..#255]) then\r\n begin\r\n if not DoKeyPress(Msg) then\r\n case Char(Msg.CharCode) of\r\n #32:\r\n begin\r\n ShowEditor;\r\n ChangeBoolean(JvGridBool_INVERT);\r\n end;\r\n Backspace, '0', '-':\r\n begin\r\n ShowEditor;\r\n ChangeBoolean(JvGridBool_UNCHECK);\r\n end;\r\n '1', '+':\r\n begin\r\n ShowEditor;\r\n ChangeBoolean(JvGridBool_CHECK);\r\n end;\r\n end;\r\n end\r\n else\r\n begin\r\n inherited;\r\n\r\n if Assigned(FCurrentControl) then\r\n begin\r\n if FCurrentControl.Visible then\r\n PostMessage(FCurrentControl.Handle, WM_CHAR, Msg.CharCode, Msg.KeyData);\r\n end\r\n else\r\n if InplaceEditor = nil then\r\n DoKeyPress(Msg); // This is needed to trigger an onKeyPressed event when the\r\n // default editor hasn't been created because the data type\r\n // of the selected field is binary or memo.\r\n end;\r\nend;\r\n\r\nprocedure TJvDBGrid.KeyPress(var Key: Char);\r\nvar\r\n lWord: string;\r\n lMasterField: TField;\r\n I, deb: Integer;\r\n Found: Boolean;\r\n\r\n procedure CharsToFind;\r\n begin\r\n if Pos(AnsiUpperCase(FWord), AnsiUpperCase(InplaceEditor.EditText)) <> 1 then\r\n FWord := '';\r\n if Key = Backspace then\r\n if (FWord = '') or (Length(FWord) = 1) then\r\n begin\r\n lWord := '';\r\n FWord := '';\r\n end\r\n else\r\n lWord := Copy(FWord, 1, Length(FWord) - 1)\r\n else\r\n lWord := FWord + Key;\r\n end;\r\n\r\nbegin\r\n if (Key = Cr) and PostOnEnterKey and not ReadOnly then\r\n DataSource.DataSet.CheckBrowseMode;\r\n\r\n if not Assigned(FCurrentControl) then\r\n inherited KeyPress(Key);\r\n\r\n if EditorMode then\r\n begin\r\n // Goal: Allow to go directly into the InplaceEditor when one types the first\r\n // characters of a word found in the list.\r\n // Remark: InplaceEditor is protected in TCustomGrid, published in TJvDBGrid.\r\n if DataSource.DataSet.CanModify and not (ReadOnly or\r\n Columns[SelectedIndex].ReadOnly or Columns[SelectedIndex].Field.ReadOnly) then\r\n with Columns[SelectedIndex].Field do\r\n if (FieldKind = fkLookup) and CharInSet(Key, CharList) then\r\n begin\r\n CharsToFind;\r\n LookupDataSet.DisableControls;\r\n try\r\n try\r\n if LookupDataSet.Locate(LookupResultField, lWord, [loCaseInsensitive, loPartialKey]) then\r\n begin\r\n DataSet.Edit;\r\n lMasterField := DataSet.FieldByName(KeyFields);\r\n if lMasterField.CanModify then\r\n begin\r\n lMasterField.Value := LookupDataSet.FieldValues[LookupKeyFields];\r\n FWord := lWord;\r\n InplaceEditor.SelStart := Length(FWord);\r\n InplaceEditor.SelLength := Length(InplaceEditor.EditText) - Length(FWord);\r\n end;\r\n end;\r\n except\r\n { If you attempt to search for a string larger than what the field\r\n can hold, and exception will be raised. Just trap it. }\r\n end;\r\n finally\r\n LookupDataSet.EnableControls;\r\n end;\r\n end\r\n else\r\n if FieldKind = fkData then\r\n begin\r\n if DataType in [DB.ftFloat{$IFDEF COMPILER12_UP},DB.ftExtended{$ENDIF COMPILER12_UP}] then\r\n if CharInSet(Key, ['.', ',']) then\r\n Key := JclFormatSettings.DecimalSeparator;\r\n\r\n if CharInSet(Key, CharList) and (Columns[SelectedIndex].PickList.Count <> 0) then\r\n begin\r\n FWord := InplaceEditor.EditText;\r\n deb := InplaceEditor.SelStart + InplaceEditor.SelLength;\r\n if Key = Backspace then\r\n begin\r\n if (InplaceEditor.SelLength = 0) then\r\n begin\r\n lWord := Copy(FWord, 1, InplaceEditor.SelStart - 1)\r\n + Copy(FWord, deb + 1, Length(FWord) - deb + 1);\r\n deb := InplaceEditor.SelStart - 1;\r\n end\r\n else\r\n begin\r\n lWord := Copy(FWord, 1, InplaceEditor.SelStart)\r\n + Copy(FWord, deb + 1, Length(FWord) - deb);\r\n deb := InplaceEditor.SelStart;\r\n end;\r\n end\r\n else\r\n begin\r\n lWord := Copy(FWord, 1, InplaceEditor.SelStart) + Key\r\n + Copy(FWord, deb + 1, Length(FWord) - deb);\r\n deb := InplaceEditor.SelStart + 1;\r\n end;\r\n\r\n Found := False;\r\n with Columns[SelectedIndex].PickList do\r\n for I := 0 to Count - 1 do\r\n begin\r\n if AnsiStartsText(lWord, Strings[I]) then\r\n begin\r\n DataSet.Edit;\r\n\r\n InplaceEditor.EditText := Strings[I];\r\n Columns[SelectedIndex].Field.Text := Strings[I];\r\n InplaceEditor.SelStart := deb;\r\n InplaceEditor.SelLength := Length(Text) - deb;\r\n Found := True;\r\n\r\n Break;\r\n end;\r\n end;\r\n\r\n if Found then\r\n Key := #0;\r\n end;\r\n end;\r\n end\r\n else\r\n // This fixes a bug coming from DBGrids.pas when a field is not editable.\r\n // This ensures that nothing else will process the keys pressed.\r\n Key := #0;\r\nend;\r\n\r\nprocedure TJvDBGrid.DefaultDrawColumnCell(const Rect: TRect;\r\n DataCol: Integer; Column: TColumn; State: TGridDrawState);\r\nvar\r\n MemoText: string;\r\nbegin\r\n if Assigned(Column.Field) and\r\n (WordWrapAllFields or (Column.Field is TStringField) or (ShowMemos and IsMemoField(Column.Field))) then\r\n begin\r\n MemoText := Column.Field.DisplayText;\r\n if FShowMemos and IsMemoField(Column.Field) then\r\n begin\r\n // The MemoField's default DisplayText is '(Memo)' but we want the content\r\n if not Assigned(Column.Field.OnGetText) then\r\n MemoText := Column.Field.AsString;\r\n end;\r\n WriteCellText(Rect, 2, 2, MemoText, Column.Alignment,\r\n UseRightToLeftAlignmentForField(Column.Field, Column.Alignment), False);\r\n end\r\n else if GetImageIndex(Column.Field) < 0 then // Mantis 5013: Must not call inherited drawer, or the text will be painted over\r\n inherited DefaultDrawColumnCell(Rect, DataCol, Column, State);\r\nend;\r\n\r\nprocedure TJvDBGrid.DefaultDataCellDraw(const Rect: TRect; Field: TField;\r\n State: TGridDrawState);\r\nbegin\r\n DefaultDrawDataCell(Rect, Field, State);\r\nend;\r\n\r\nfunction TJvDBGrid.GetMasterColumn(ACol, ARow: Longint): TColumn;\r\nbegin\r\n if dgIndicator in Options then\r\n Dec(ACol, IndicatorOffset);\r\n if (DataLink <> nil) and DataLink.Active and (ACol >= 0) and (ACol < Columns.Count) then\r\n begin\r\n Result := Columns[ACol];\r\n Result := ColumnAtDepth(Result, ARow);\r\n end\r\n else\r\n Result := nil;\r\nend;\r\n\r\nfunction TJvDBGrid.SortMarkerAssigned(const AFieldName: string): Boolean;\r\nbegin\r\n Result := AnsiSameText(AFieldName, SortedField);\r\nend;\r\n\r\nprocedure TJvDBGrid.WriteCellText(ARect: TRect; DX, DY: Integer; const Text: string;\r\n Alignment: TAlignment; ARightToLeft: Boolean; FixCell: Boolean; Options: Integer = 0);\r\nconst\r\n AlignFlags: array [TAlignment] of Integer =\r\n (DT_LEFT or DT_EXPANDTABS or DT_NOPREFIX,\r\n DT_RIGHT or DT_EXPANDTABS or DT_NOPREFIX,\r\n DT_CENTER or DT_EXPANDTABS or DT_NOPREFIX);\r\n RTL: array [Boolean] of Integer = (0, DT_RTLREADING);\r\nvar\r\n DrawBitmap: TBitmap;\r\n Hold: Integer;\r\n B, R: TRect;\r\n DrawOptions: Integer;\r\n\r\n procedure DrawAText(CellCanvas: TCanvas);\r\n begin\r\n with CellCanvas do\r\n begin\r\n DrawOptions := DT_EXPANDTABS or DT_NOPREFIX;\r\n if Options <> 0 then\r\n DrawOptions := DrawOptions or Options;\r\n if WordWrap then\r\n DrawOptions := DrawOptions or DT_WORDBREAK;\r\n {$IFDEF JVCLThemesEnabled}\r\n if not FixCell or not (UseXPThemes and ThemeServices.{$IFDEF RTL230_UP}Enabled{$ELSE}ThemesEnabled{$ENDIF RTL230_UP}) then\r\n {$ENDIF JVCLThemesEnabled}\r\n {$IFDEF COMPILER14_UP}\r\n if not FixCell or (DrawingStyle in [gdsClassic, gdsThemed]) then\r\n {$ENDIF COMPILER14_UP}\r\n begin\r\n if Brush.Style <> bsSolid then\r\n Brush.Style := bsSolid;\r\n FillRect(B);\r\n end;\r\n SetBkMode(Handle, TRANSPARENT);\r\n DrawBiDiText(Handle, Text, R, DrawOptions, Alignment, ARightToLeft, Canvas.CanvasOrientation);\r\n end;\r\n end;\r\n\r\nbegin\r\n if ReduceFlicker\r\n {$IFDEF COMPILER14_UP} and not FixCell {$ENDIF}\r\n {$IFDEF JVCLThemesEnabled} and not (UseXPThemes and ThemeServices.{$IFDEF RTL230_UP}Enabled{$ELSE}ThemesEnabled{$ENDIF RTL230_UP}) {$ENDIF} then\r\n begin\r\n // Use offscreen bitmap to eliminate flicker and\r\n // brush origin tics in painting / scrolling.\r\n DrawBitmap := TBitmap.Create;\r\n try\r\n DrawBitmap.Canvas.Lock;\r\n try\r\n DrawBitmap.Width := Max(DrawBitmap.Width, ARect.Right - ARect.Left);\r\n DrawBitmap.Height := Max(DrawBitmap.Height, ARect.Bottom - ARect.Top);\r\n R := Rect(DX, DY, ARect.Right - ARect.Left - 1, ARect.Bottom - ARect.Top - 1);\r\n B := Rect(0, 0, ARect.Right - ARect.Left, ARect.Bottom - ARect.Top);\r\n DrawBitmap.Canvas.Font := Canvas.Font;\r\n DrawBitmap.Canvas.Font.Color := Canvas.Font.Color;\r\n DrawBitmap.Canvas.Brush := Canvas.Brush;\r\n\r\n DrawAText(DrawBitmap.Canvas);\r\n if Canvas.CanvasOrientation = coRightToLeft then\r\n begin\r\n Hold := ARect.Left;\r\n ARect.Left := ARect.Right;\r\n ARect.Right := Hold;\r\n end;\r\n Canvas.CopyRect(ARect, DrawBitmap.Canvas, B);\r\n finally\r\n DrawBitmap.Canvas.Unlock;\r\n end;\r\n finally\r\n DrawBitmap.Free;\r\n end;\r\n end\r\n else\r\n begin\r\n // No offscreen bitmap - The display is faster but flickers\r\n if IsRightToLeft then\r\n R := Rect(ARect.Left, ARect.Top, ARect.Right - 1 - DX, ARect.Bottom - DY - 1)\r\n else\r\n R := Rect(ARect.Left + DX, ARect.Top + DY, ARect.Right - 1, ARect.Bottom - 1);\r\n B := ARect;\r\n DrawAText(Canvas);\r\n end;\r\nend;\r\n\r\nprocedure TJvDBGrid.CallDrawCellEvent(ACol, ARow: Longint; ARect: TRect; AState: TGridDrawState);\r\nbegin\r\n inherited DrawCell(ACol, ARow, ARect, AState);\r\nend;\r\n\r\nprocedure TJvDBGrid.DoDrawCell(ACol, ARow: Longint; ARect: TRect; AState: TGridDrawState);\r\n{$IFNDEF COMPILER14_UP}\r\n{$IFDEF JVCLThemesEnabled}\r\nvar\r\n Details: TThemedElementDetails;\r\n lCaptionRect: TRect;\r\n lCellRect: TRect;\r\n Bmp: TBitmap;\r\n DC: HDC;\r\n{$ENDIF JVCLThemesEnabled}\r\n{$ENDIF ~COMPILER14_UP}\r\nbegin\r\n {$IFNDEF COMPILER14_UP}\r\n {$IFDEF JVCLThemesEnabled}\r\n if UseXPThemes and ThemeServices.ThemesEnabled then\r\n begin\r\n lCellRect := ARect;\r\n if ThemeServices.ThemesEnabled and (ARow = 0) and (ACol - ColumnOffset >= 0) and (dgTitles in Options) then\r\n begin\r\n lCaptionRect := ARect;\r\n if not FPaintInfo.ColPressed or (FPaintInfo.ColPressedIdx <> ACol) then\r\n begin\r\n if (FPaintInfo.MouseInCol = -1) or (FPaintInfo.MouseInCol <> ACol) or (csDesigning in ComponentState) then\r\n Details := ThemeServices.GetElementDetails(thHeaderItemNormal)\r\n else\r\n Details := ThemeServices.GetElementDetails(thHeaderItemHot);\r\n lCellRect.Right := lCellRect.Right + 1;\r\n lCellRect.Bottom := lCellRect.Bottom + 2;\r\n end\r\n else if AllowTitleClick then\r\n begin\r\n Details := ThemeServices.GetElementDetails(thHeaderItemPressed);\r\n InflateRect(lCaptionRect, -1, 1);\r\n end\r\n else\r\n begin\r\n if FPaintInfo.MouseInCol = ACol then\r\n Details := ThemeServices.GetElementDetails(thHeaderItemHot)\r\n else\r\n Details := ThemeServices.GetElementDetails(thHeaderItemNormal);\r\n end;\r\n ThemeServices.DrawElement(Canvas.Handle, Details, lCellRect);\r\n { The column title isn't painted by DrawCell if the DataLink is not active. }\r\n if (DataLink = nil) or not DataLink.Active then\r\n if (ACol - ColumnOffset >= 0) and (ACol - ColumnOffset < Columns.Count) then\r\n DrawTitleCaption(Canvas, lCaptionRect, Columns[ACol - ColumnOffset]);\r\n end\r\n else if (ACol = 0) and (dgIndicator in Options) and ThemeServices.ThemesEnabled then\r\n begin\r\n // indicator column\r\n if ARow < TitleOffset then\r\n Details := ThemeServices.GetElementDetails(thHeaderItemNormal)\r\n else\r\n Details := ThemeServices.GetElementDetails(thHeaderRoot);\r\n lCellRect.Right := lCellRect.Right + 1;\r\n lCellRect.Bottom := lCellRect.Bottom + 2;\r\n ThemeServices.DrawElement(Canvas.Handle, Details, lCellRect);\r\n // draw the indicator\r\n if (Datalink.Active) and (ARow - TitleOffset = Datalink.ActiveRecord) then\r\n begin\r\n // Unfortunatelly the TDBGrid.FIndicators: TImageList is a private field so we have to\r\n // call the original painter for the indicator and draw it into a transparent bitmap\r\n // without the 3D border.\r\n Bmp := TBitmap.Create;\r\n try\r\n Bmp.Canvas.Brush.Color := FixedColor;\r\n Bmp.Width := lCellRect.Right - lCellRect.Left;\r\n Bmp.Height := lCellRect.Bottom - lCellRect.Top;\r\n DC := Canvas.Handle;\r\n try\r\n Canvas.Handle := Bmp.Canvas.Handle;\r\n IntersectClipRect(Canvas.Handle, 2, 2, Bmp.Width - 2, Bmp.Height - 2);\r\n CallDrawCellEvent(ACol, ARow, Rect(0, 0, Bmp.Width - 1, Bmp.Height - 1), [gdFixed]);\r\n finally\r\n Canvas.Handle := DC;\r\n end;\r\n Bmp.TransparentColor := FixedColor;\r\n Bmp.Transparent := True;\r\n Canvas.Draw(lCellRect.Left, lCellRect.Top, Bmp);\r\n finally\r\n Bmp.Free;\r\n end;\r\n end;\r\n end\r\n else\r\n CallDrawCellEvent(ACol, ARow, ARect, AState);\r\n end\r\n else\r\n {$ENDIF JVCLThemesEnabled}\r\n {$ENDIF ~COMPILER14_UP}\r\n CallDrawCellEvent(ACol, ARow, ARect, AState);\r\nend;\r\n\r\nprocedure TJvDBGrid.DrawTitleCaption(Canvas: TCanvas; const TextRect: TRect; DrawColumn: TColumn);\r\nconst\r\n AlignFlags: array [TAlignment] of Integer =\r\n (DT_LEFT or DT_EXPANDTABS or DT_NOPREFIX,\r\n DT_RIGHT or DT_EXPANDTABS or DT_NOPREFIX,\r\n DT_CENTER or DT_EXPANDTABS or DT_NOPREFIX);\r\n RTL: array [Boolean] of Integer = (0, DT_RTLREADING);\r\nconst\r\n MinOffs = 1;\r\nvar\r\n CalcRect: TRect;\r\n TitleSpace,\r\n TitleOptions: Integer;\r\nbegin\r\n with DrawColumn.Title do\r\n begin\r\n TitleOptions := DT_END_ELLIPSIS;\r\n if WordWrap then\r\n begin\r\n CalcRect := TextRect;\r\n Dec(CalcRect.Right, MinOffs + 1);\r\n DrawBiDiText(Canvas.Handle, Caption, CalcRect,\r\n DT_EXPANDTABS or DT_NOPREFIX or DT_CALCRECT or DT_WORDBREAK,\r\n Alignment, IsRightToLeft, Canvas.CanvasOrientation);\r\n if CalcRect.Bottom > TextRect.Bottom then\r\n begin\r\n TitleOptions := DT_END_ELLIPSIS or DT_SINGLELINE;\r\n TitleSpace := TextRect.Bottom - TextRect.Top - Canvas.TextHeight('^g');\r\n end\r\n else\r\n begin\r\n if (CalcRect.Bottom - CalcRect.Top) > Canvas.TextHeight('^g') then\r\n TitleOptions := 0;\r\n TitleSpace := TextRect.Bottom - CalcRect.Bottom;\r\n end;\r\n end\r\n else\r\n TitleSpace := TextRect.Bottom - TextRect.Top - Canvas.TextHeight('^g');\r\n WriteCellText(TextRect, MinOffs, Max(MinOffs, TitleSpace div 2), Caption, Alignment,\r\n IsRightToLeft, True, TitleOptions);\r\n end;\r\nend;\r\n\r\nprocedure TJvDBGrid.DrawCell(ACol, ARow: Longint; ARect: TRect; AState: TGridDrawState);\r\nconst\r\n EdgeFlag: array [Boolean] of UINT = (BDR_RAISEDINNER, BDR_SUNKENINNER);\r\n MinOffs = 1;\r\nvar\r\n FrameOffs: Byte;\r\n BackColor: TColor;\r\n ASortMarker: TSortMarker;\r\n Indicator, ALeft: Integer;\r\n Down: Boolean;\r\n Bmp: TJvDBGridBitmap;\r\n SavePen: TColor;\r\n OldActive: Longint;\r\n MultiSelected: Boolean;\r\n FixRect: TRect;\r\n TitleRect, TextRect: TRect;\r\n AField: TField;\r\n MasterCol: TColumn;\r\n InBiDiMode: Boolean;\r\n DrawColumn: TColumn;\r\n DefaultDrawText, DefaultDrawSortMarker: Boolean;\r\n\r\n function CalcTitleRect(Col: TColumn; ARow: Integer; var MasterCol: TColumn): TRect;\r\n { copied from CodeGear's DbGrids.pas }\r\n var\r\n I, J: Integer;\r\n InBiDiMode: Boolean;\r\n DrawInfo: TGridDrawInfo;\r\n begin\r\n MasterCol := ColumnAtDepth(Col, ARow);\r\n if MasterCol = nil then\r\n Exit;\r\n I := DataToRawColumn(MasterCol.Index);\r\n if I >= LeftCol then\r\n J := MasterCol.Depth\r\n else\r\n begin\r\n if (FixedCols > 0) and (MasterCol.Index < FixedCols) then\r\n begin\r\n J := MasterCol.Depth;\r\n end\r\n else\r\n begin\r\n I := LeftCol;\r\n if Col.Depth > ARow then\r\n J := ARow\r\n else\r\n J := Col.Depth;\r\n end;\r\n end;\r\n Result := CellRect(I, J);\r\n InBiDiMode := UseRightToLeftAlignment and (Canvas.CanvasOrientation = coLeftToRight);\r\n for I := Col.Index to Columns.Count - 1 do\r\n begin\r\n if ColumnAtDepth(Columns[I], ARow) <> MasterCol then\r\n Break;\r\n if not InBiDiMode then\r\n begin\r\n J := CellRect(DataToRawColumn(I), ARow).Right;\r\n if J = 0 then\r\n Break;\r\n Result.Right := Max(Result.Right, J);\r\n end\r\n else\r\n begin\r\n J := CellRect(DataToRawColumn(I), ARow).Left;\r\n if J >= ClientWidth then\r\n Break;\r\n Result.Left := J;\r\n end;\r\n end;\r\n J := Col.Depth;\r\n if (J <= ARow) and (J < FixedRows - 1) then\r\n begin\r\n CalcFixedInfo(DrawInfo);\r\n Result.Bottom := DrawInfo.Vert.FixedBoundary -\r\n DrawInfo.Vert.EffectiveLineWidth;\r\n end;\r\n end;\r\n\r\n procedure DrawExpandBtn(var TitleRect, TextRect: TRect; InBiDiMode: Boolean;\r\n Expanded: Boolean); { copied from CodeGear's DbGrids.pas }\r\n const\r\n ScrollArrows: array [Boolean, Boolean] of Integer =\r\n ((DFCS_SCROLLRIGHT, DFCS_SCROLLLEFT), (DFCS_SCROLLLEFT, DFCS_SCROLLRIGHT));\r\n var\r\n ButtonRect: TRect;\r\n I: Integer;\r\n begin\r\n I := GetSystemMetrics(SM_CXHSCROLL);\r\n if (TextRect.Right - TextRect.Left) > I then\r\n begin\r\n Dec(TextRect.Right, I);\r\n ButtonRect := TitleRect;\r\n ButtonRect.Left := TextRect.Right;\r\n I := SaveDC(Canvas.Handle);\r\n try\r\n Canvas.FillRect(ButtonRect);\r\n InflateRect(ButtonRect, -1, -1);\r\n IntersectClipRect(Canvas.Handle, ButtonRect.Left, ButtonRect.Top, ButtonRect.Right, ButtonRect.Bottom);\r\n InflateRect(ButtonRect, 1, 1);\r\n { DrawFrameControl doesn't draw properly when orientation has changed.\r\n It draws as ExtTextOut does. }\r\n if InBiDiMode then { stretch the arrows box }\r\n Inc(ButtonRect.Right, GetSystemMetrics(SM_CXHSCROLL) + 4);\r\n DrawFrameControl(Canvas.Handle, ButtonRect, DFC_SCROLL,\r\n ScrollArrows[InBiDiMode, Expanded] or DFCS_FLAT);\r\n finally\r\n RestoreDC(Canvas.Handle, I);\r\n end;\r\n TitleRect.Right := ButtonRect.Left;\r\n end;\r\n end;\r\n\r\nbegin\r\n FCurrentDrawRow := ARow;\r\n Canvas.Font := Self.Font;\r\n if (DataLink <> nil) and DataLink.Active and (ACol >= 0) and\r\n (ACol < Columns.Count) then\r\n begin\r\n DrawColumn := Columns[ACol];\r\n if DrawColumn <> nil then\r\n Canvas.Font := DrawColumn.Font;\r\n end;\r\n\r\n DoDrawCell(ACol, ARow, ARect, AState);\r\n if FTitleArrow and (ARow = 0) and (ACol = 0) and\r\n (dgIndicator in Options) and (dgTitles in Options) then\r\n begin\r\n Bmp := GetGridBitmap(gpPopup);\r\n DrawBitmapTransparent(Canvas, (ARect.Left + ARect.Right - Bmp.Width) div 2,\r\n (ARect.Top + ARect.Bottom - Bmp.Height) div 2, Bmp, clWhite);\r\n end;\r\n\r\n InBiDiMode := Canvas.CanvasOrientation = coRightToLeft;\r\n if (dgIndicator in Options) and (ACol = 0) and (ARow - TitleOffset >= 0) and\r\n MultiSelect and (DataLink <> nil) and DataLink.Active and\r\n (DataLink.DataSet.State = dsBrowse) then\r\n begin { draw multiselect indicators if needed }\r\n FixRect := ARect;\r\n if [dgRowLines, dgColLines] * Options = [dgRowLines, dgColLines] then\r\n begin\r\n InflateRect(FixRect, -1, -1);\r\n FrameOffs := 1;\r\n end\r\n else\r\n FrameOffs := 2;\r\n OldActive := DataLink.ActiveRecord;\r\n try\r\n DataLink.ActiveRecord := ARow - TitleOffset;\r\n MultiSelected := ActiveRowSelected;\r\n finally\r\n DataLink.ActiveRecord := OldActive;\r\n end;\r\n if MultiSelected then\r\n begin\r\n if ARow - TitleOffset <> DataLink.ActiveRecord then\r\n Indicator := 0\r\n else\r\n Indicator := 1; { multiselected and current row }\r\n FMsIndicators.BkColor := FixedColor;\r\n ALeft := FixRect.Right - FMsIndicators.Width - FrameOffs;\r\n if InBiDiMode then\r\n Inc(ALeft);\r\n FMsIndicators.Draw(Self.Canvas, ALeft, (FixRect.Top +\r\n FixRect.Bottom - FMsIndicators.Height) shr 1, Indicator);\r\n end;\r\n end\r\n else\r\n if not (csLoading in ComponentState) and\r\n (gdFixed in AState) and (dgTitles in Options) and (ARow < TitleOffset) then\r\n begin\r\n SavePen := Canvas.Pen.Color;\r\n try\r\n Canvas.Pen.Color := clWindowFrame;\r\n if dgIndicator in Options then\r\n Dec(ACol, IndicatorOffset);\r\n AField := nil;\r\n ASortMarker := smNone;\r\n if (DataLink <> nil) and DataLink.Active and (ACol >= 0) and\r\n (ACol < Columns.Count) then\r\n begin\r\n DrawColumn := Columns[ACol];\r\n AField := DrawColumn.Field;\r\n end\r\n else\r\n DrawColumn := nil;\r\n if Assigned(DrawColumn) and not DrawColumn.Showing then\r\n Exit;\r\n TitleRect := CalcTitleRect(DrawColumn, ARow, MasterCol);\r\n if TitleRect.Right < ARect.Right then\r\n TitleRect.Right := ARect.Right;\r\n if MasterCol = nil then\r\n Exit\r\n else\r\n if MasterCol <> DrawColumn then\r\n AField := MasterCol.Field;\r\n DrawColumn := MasterCol;\r\n if ((dgColLines in Options) or FTitleButtons) and (ACol = FixedCols - 1) then\r\n begin\r\n if (ACol < Columns.Count - 1) and not (Columns[ACol + 1].Showing) then\r\n begin\r\n Canvas.MoveTo(TitleRect.Right, TitleRect.Top);\r\n Canvas.LineTo(TitleRect.Right, TitleRect.Bottom);\r\n end;\r\n end;\r\n if ((dgRowLines in Options) or FTitleButtons) and not MasterCol.Showing then\r\n begin\r\n Canvas.MoveTo(TitleRect.Left, TitleRect.Bottom);\r\n Canvas.LineTo(TitleRect.Right, TitleRect.Bottom);\r\n end;\r\n Down := FPressed and FTitleButtons and (FPressedCol = DrawColumn);\r\n if FTitleButtons or ([dgRowLines, dgColLines] * Options = [dgRowLines, dgColLines]) then\r\n begin\r\n {$IFDEF JVCLThemesEnabled}\r\n if not (UseXPThemes and ThemeServices.{$IFDEF RTL230_UP}Enabled{$ELSE}ThemesEnabled{$ENDIF RTL230_UP}) then\r\n {$ENDIF JVCLThemesEnabled}\r\n begin\r\n DrawEdge(Canvas.Handle, TitleRect, EdgeFlag[Down], BF_BOTTOMRIGHT);\r\n DrawEdge(Canvas.Handle, TitleRect, EdgeFlag[Down], BF_TOPLEFT);\r\n InflateRect(TitleRect, -1, -1);\r\n end;\r\n end;\r\n Canvas.Font := TitleFont;\r\n Canvas.Brush.Color := FixedColor;\r\n if DrawColumn <> nil then\r\n begin\r\n Canvas.Font := DrawColumn.Title.Font;\r\n Canvas.Brush.Color := DrawColumn.Title.Color;\r\n end;\r\n if FTitleButtons and (AField <> nil) then\r\n begin\r\n BackColor := Canvas.Brush.Color;\r\n //-----------------------------------------\r\n // FBC -fix SortMarker\r\n // Not so elegant, but it works.\r\n //-----------------------------------------\r\n if SortMarkerAssigned(AField.FieldName) then\r\n begin\r\n ASortMarker := Self.SortMarker;\r\n DoGetBtnParams(AField, Canvas.Font, BackColor, ASortMarker, Down);\r\n Self.SortMarker := ASortMarker;\r\n end\r\n else\r\n DoGetBtnParams(AField, Canvas.Font, BackColor, ASortMarker, Down);\r\n Canvas.Brush.Color := BackColor;\r\n end;\r\n if Down then\r\n OffsetRect(TitleRect, 1, 1);\r\n ARect := TitleRect;\r\n if (DataLink = nil) or not DataLink.Active then\r\n begin\r\n {$IFDEF COMPILER14_UP}\r\n DrawCellBackground(TitleRect, FixedColor, AState, ACol, ARow - TitleOffset);\r\n {$ELSE}\r\n {$IFDEF JVCLThemesEnabled}\r\n if not (UseXPThemes and ThemeServices.ThemesEnabled) then\r\n {$ENDIF JVCLThemesEnabled}\r\n Canvas.FillRect(TitleRect);\r\n {$ENDIF COMPILER14_UP}\r\n end\r\n else\r\n if DrawColumn <> nil then\r\n begin\r\n {$IFDEF COMPILER14_UP}\r\n DrawCellBackground(TitleRect, FixedColor, AState, ACol, ARow - TitleOffset);\r\n {$ELSE}\r\n// {$IFDEF JVCLThemesEnabled}\r\n// if not (UseXPThemes and ThemeServices.ThemesEnabled) then\r\n// {$ENDIF JVCLThemesEnabled}\r\n// Canvas.FillRect(TitleRect);\r\n {$ENDIF COMPILER14_UP}\r\n case ASortMarker of\r\n smDown:\r\n Bmp := GetGridBitmap(gpMarkDown);\r\n smUp:\r\n Bmp := GetGridBitmap(gpMarkUp);\r\n else\r\n Bmp := nil;\r\n end;\r\n if Bmp <> nil then\r\n Indicator := Bmp.Width + 6\r\n else\r\n Indicator := 1;\r\n DefaultDrawText := True;\r\n DefaultDrawSortMarker := True;\r\n DoDrawColumnTitle(Canvas, TitleRect, DrawColumn, Bmp, Down, Indicator,\r\n DefaultDrawText, DefaultDrawSortMarker);\r\n TextRect := TitleRect;\r\n if ASortMarker <> smNone then\r\n Dec(TextRect.Right, Bmp.Width + 4);\r\n if DefaultDrawText then\r\n begin\r\n if DrawColumn.Expandable then\r\n DrawExpandBtn(TitleRect, TextRect, InBiDiMode, DrawColumn.Expanded);\r\n DrawTitleCaption(Canvas, TextRect, DrawColumn);\r\n end;\r\n if DefaultDrawSortMarker then\r\n begin\r\n if Bmp <> nil then\r\n begin\r\n ALeft := TitleRect.Right - Indicator + 3;\r\n if IsRightToLeft then\r\n ALeft := TitleRect.Left + 3;\r\n {$IFDEF COMPILER14_UP}\r\n DrawCellBackground(Rect(TextRect.Right, TitleRect.Top, TitleRect.Right, TitleRect.Bottom), FixedColor, AState, ACol, ARow - TitleOffset);\r\n {$ELSE}\r\n {$IFDEF JVCLThemesEnabled}\r\n if not (UseXPThemes and ThemeServices.ThemesEnabled) then\r\n {$ENDIF JVCLThemesEnabled}\r\n Canvas.FillRect(Rect(TextRect.Right, TitleRect.Top, TitleRect.Right, TitleRect.Bottom));\r\n {$ENDIF COMPILER14_UP}\r\n if (ALeft > TitleRect.Left) and (ALeft + Bmp.Width < TitleRect.Right) then\r\n DrawBitmapTransparent(Canvas, ALeft, (TitleRect.Bottom +\r\n TitleRect.Top - Bmp.Height) div 2, Bmp, clFuchsia);\r\n end;\r\n end;\r\n end\r\n else\r\n WriteCellText(ARect, MinOffs, MinOffs, '', taLeftJustify, False, IsRightToLeft);\r\n {$IFDEF COMPILER14_UP}\r\n if ([dgRowLines, dgColLines] * Options = [dgRowLines, dgColLines]) and\r\n ((DrawingStyle = gdsClassic) or ((DrawingStyle = gdsThemed) and not ThemeServices.{$IFDEF RTL230_UP}Enabled{$ELSE}ThemesEnabled{$ENDIF RTL230_UP})) and\r\n not (gdPressed in AState) then\r\n begin\r\n InflateRect(TitleRect, 1, 1);\r\n DrawEdge(Canvas.Handle, TitleRect, BDR_RAISEDINNER, BF_BOTTOMRIGHT);\r\n DrawEdge(Canvas.Handle, TitleRect, BDR_RAISEDINNER, BF_TOPLEFT);\r\n end;\r\n {$ENDIF COMPILER14_UP}\r\n finally\r\n Canvas.Pen.Color := SavePen;\r\n end;\r\n end\r\n else\r\n begin\r\n Canvas.Font := Self.Font;\r\n if (DataLink <> nil) and DataLink.Active and (ACol >= 0) and\r\n (ACol < Columns.Count) then\r\n begin\r\n DrawColumn := Columns[ACol];\r\n if DrawColumn <> nil then\r\n Canvas.Font := DrawColumn.Font;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvDBGrid.DrawColumnCell(const Rect: TRect; DataCol: Integer;\r\n Column: TColumn; State: TGridDrawState);\r\nvar\r\n I: Integer;\r\n NewBackgrnd: TColor;\r\n Highlight: Boolean;\r\n Bmp: TBitmap;\r\n Field, ReadOnlyTestField: TField;\r\nbegin\r\n Field := Column.Field;\r\n if Assigned(DataSource) and Assigned(DataSource.DataSet) and DataSource.DataSet.Active and\r\n (SelectedRows.IndexOf(DataSource.DataSet.Bookmark) > -1) then\r\n Include(State, gdSelected);\r\n NewBackgrnd := Canvas.Brush.Color;\r\n Highlight := (gdSelected in State) and ((dgAlwaysShowSelection in Options) or Focused);\r\n GetCellProps(Column, Canvas.Font, NewBackgrnd, Highlight or ActiveRowSelected);\r\n if not Highlight and (ReadOnlyCellColor <> clDefault) and\r\n (not Field.CanModify or not CanEditCell(Field)) then\r\n begin\r\n if (gdSelected in State) and (Focused xor MultiSelect) then\r\n Canvas.Brush.Color := NewBackgrnd\r\n else\r\n begin\r\n Canvas.Brush.Color := ReadOnlyCellColor;\r\n\r\n { Lookup fields do not have a FieldNo. In this case CanModify returns False } \r\n if Field.Lookup and (Field.LookupDataSet <> nil) and (Field.LookupResultField <> '')\r\n and (Field.LookupKeyFields <> '') and (Field.KeyFields <> '') then\r\n begin\r\n I := 1;\r\n ReadOnlyTestField := Field.DataSet.FieldByName(ExtractFieldName(Field.KeyFields, I));\r\n if ReadOnlyTestField.CanModify and CanEditCell(ReadOnlyTestField) then\r\n Canvas.Brush.Color := NewBackgrnd\r\n end;\r\n end;\r\n end\r\n else\r\n Canvas.Brush.Color := NewBackgrnd;\r\n if DefaultDrawing then\r\n begin\r\n I := GetImageIndex(Field);\r\n if I >= 0 then\r\n begin\r\n Bmp := GetGridBitmap(TGridPicture(I));\r\n Canvas.FillRect(Rect);\r\n DrawBitmapTransparent(Canvas, (Rect.Left + Rect.Right + 1 - Bmp.Width) div 2,\r\n (Rect.Top + Rect.Bottom + 1 - Bmp.Height) div 2, Bmp, clOlive);\r\n end\r\n else\r\n begin\r\n DefaultDrawColumnCell(Rect, DataCol, Column, State);\r\n end;\r\n end;\r\n if (Columns.State = csDefault) or not DefaultDrawing or (csDesigning in ComponentState) then\r\n inherited DrawDataCell(Rect, Field, State);\r\n inherited DrawColumnCell(Rect, DataCol, Column, State);\r\n if DefaultDrawing and (gdFocused in State) and not (csDesigning in ComponentState) and\r\n not (dgRowSelect in Options) and\r\n (ValidParentForm(Self).ActiveControl = Self) then\r\n Canvas.DrawFocusRect(Rect);\r\nend;\r\n\r\nprocedure TJvDBGrid.DrawDataCell(const Rect: TRect; Field: TField;\r\n State: TGridDrawState);\r\nbegin\r\nend;\r\n\r\nprocedure TJvDBGrid.MouseToCell(X, Y: Integer; var ACol, ARow: Longint);\r\nvar\r\n Coord: TGridCoord;\r\nbegin\r\n Coord := MouseCoord(X, Y);\r\n ACol := Coord.X;\r\n ARow := Coord.Y;\r\nend;\r\n\r\nprocedure TJvDBGrid.SaveColumnsLayout(const AppStorage: TJvCustomAppStorage;\r\n const Section: string);\r\nvar\r\n I: Integer;\r\n SectionName: string;\r\nbegin\r\n if Section <> '' then\r\n SectionName := Section\r\n else\r\n SectionName := GetDefaultSection(Self);\r\n if Assigned(AppStorage) then\r\n begin\r\n AppStorage.BeginUpdate;\r\n try\r\n AppStorage.DeleteSubTree(SectionName);\r\n for I := 0 to Columns.Count - 1 do\r\n AppStorage.WriteString(AppStorage.ConcatPaths([SectionName, Format('%s.%s', [Name, Columns.Items[I].FieldName])]),\r\n Format('%d,%d', [Columns.Items[I].Index, Columns.Items[I].Width]));\r\n finally\r\n AppStorage.EndUpdate;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvDBGrid.RestoreColumnsLayout(const AppStorage: TJvCustomAppStorage;\r\n const Section: string);\r\nconst\r\n Delims = [' ', ','];\r\ntype\r\n TColumnInfo = record\r\n Column: TColumn;\r\n EndIndex: Integer;\r\n end;\r\n TColumnArray = array of TColumnInfo;\r\nvar\r\n I, J: Integer;\r\n SectionName, S: string;\r\n ColumnArray: TColumnArray;\r\nbegin\r\n if Section <> '' then\r\n SectionName := Section\r\n else\r\n SectionName := GetDefaultSection(Self);\r\n if Assigned(AppStorage) then\r\n begin\r\n AppStorage.BeginUpdate;\r\n try\r\n SetLength(ColumnArray, Columns.Count);\r\n for I := 0 to Columns.Count - 1 do\r\n begin\r\n S := AppStorage.ReadString(AppStorage.ConcatPaths([SectionName,\r\n Format('%s.%s', [Name, Columns.Items[I].FieldName])]));\r\n ColumnArray[I].Column := Columns.Items[I];\r\n ColumnArray[I].EndIndex := Columns.Items[I].Index;\r\n if S <> '' then\r\n begin\r\n ColumnArray[I].EndIndex := StrToIntDef(ExtractWord(1, S, Delims), ColumnArray[I].EndIndex);\r\n S := ExtractWord(2, S, Delims);\r\n Columns.Items[I].Width := StrToIntDef(S, Columns.Items[I].Width);\r\n Columns.Items[I].Visible := (S <> '-1');\r\n end;\r\n end;\r\n for I := 0 to Columns.Count - 1 do\r\n for J := 0 to Columns.Count - 1 do\r\n if ColumnArray[J].EndIndex = I then\r\n begin\r\n ColumnArray[J].Column.Index := ColumnArray[J].EndIndex;\r\n Break;\r\n end;\r\n finally\r\n AppStorage.EndUpdate;\r\n end;\r\n\r\n end;\r\nend;\r\n\r\nprocedure TJvDBGrid.LoadFromAppStore(const AppStorage: TJvCustomAppStorage; const Path: string);\r\nbegin\r\n if (DataSource <> nil) and (DataSource.DataSet <> nil) then\r\n begin\r\n HandleNeeded;\r\n BeginLayout;\r\n try\r\n if StoreColumns then\r\n RestoreColumnsLayout(AppStorage, Path)\r\n else\r\n InternalRestoreFields(DataSource.DataSet, AppStorage, Path, False);\r\n finally\r\n EndLayout;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvDBGrid.SaveToAppStore(const AppStorage: TJvCustomAppStorage; const Path: string);\r\nbegin\r\n if (DataSource <> nil) and (DataSource.DataSet <> nil) then\r\n if StoreColumns then\r\n SaveColumnsLayout(AppStorage, Path)\r\n else\r\n InternalSaveFields(DataSource.DataSet, AppStorage, Path);\r\nend;\r\n\r\nprocedure TJvDBGrid.Load;\r\nbegin\r\n IniLoad(nil);\r\nend;\r\n\r\nprocedure TJvDBGrid.Save;\r\nbegin\r\n IniSave(nil);\r\nend;\r\n\r\nprocedure TJvDBGrid.IniSave(Sender: TObject);\r\nvar\r\n Section: string;\r\nbegin\r\n if (Name <> '') and Assigned(IniStorage) then\r\n begin\r\n if StoreColumns then\r\n Section := IniStorage.AppStorage.ConcatPaths([IniStorage.AppStoragePath, GetDefaultSection(Self)])\r\n else\r\n if (DataSource <> nil) and\r\n (DataSource.DataSet <> nil) then\r\n Section := IniStorage.AppStorage.ConcatPaths([IniStorage.AppStoragePath, DataSetSectionName(DataSource.DataSet)])\r\n else\r\n Section := '';\r\n SaveToAppStore(IniStorage.AppStorage, Section);\r\n end;\r\nend;\r\n\r\nprocedure TJvDBGrid.IniLoad(Sender: TObject);\r\nvar\r\n Section: string;\r\nbegin\r\n if (Name <> '') and Assigned(IniStorage) then\r\n begin\r\n if StoreColumns then\r\n Section := IniStorage.AppStorage.ConcatPaths([IniStorage.AppStoragePath, GetDefaultSection(Self)])\r\n else\r\n if (DataSource <> nil) and\r\n (DataSource.DataSet <> nil) then\r\n Section := IniStorage.AppStorage.ConcatPaths([IniStorage.AppStoragePath, DataSetSectionName(DataSource.DataSet)])\r\n else\r\n Section := '';\r\n LoadFromAppStore(IniStorage.AppStorage, Section);\r\n end;\r\nend;\r\n\r\nprocedure TJvDBGrid.CalcSizingState(X, Y: Integer; var State: TGridState;\r\n var Index: Longint; var SizingPos, SizingOfs: Integer;\r\n var FixedInfo: TGridDrawInfo);\r\nvar\r\n Coord: TGridCoord;\r\nbegin\r\n inherited CalcSizingState(X, Y, State, Index, SizingPos, SizingOfs, FixedInfo);\r\n\r\n // do nothing if not authorized to size columns\r\n if not (dgColumnResize in Options) and not (csDesigning in ComponentState) then\r\n Exit;\r\n\r\n\r\n FCanResizeColumn := State = gsColSizing; // If true, mouse double clicking can resize column.\r\n\r\n // Mantis 5818: the inherited code sometimes gives an invalid index for the column\r\n if Index > FirstVisibleColumn + VisibleColCount then\r\n Index := FirstVisibleColumn + VisibleColCount;\r\n\r\n FResizeColumnIndex := Index - 1;// Store the column index to resize.\r\n\r\n if (State = gsNormal) and (Y <= RowHeights[0]) then\r\n begin\r\n Coord := MouseCoord(X, Y);\r\n CalcDrawInfo(FixedInfo);\r\n if CellRect(Coord.X, 0).Right - 5 < X then\r\n begin\r\n State := gsColSizing;\r\n Index := Coord.X;\r\n SizingPos := X;\r\n SizingOfs := X - CellRect(Coord.X, 0).Right;\r\n end;\r\n if CellRect(Coord.X, 0).Left + 5 > X then\r\n begin\r\n State := gsColSizing;\r\n Index := Coord.X - 1;\r\n SizingPos := X;\r\n SizingOfs := X - CellRect(Coord.X, 0).Left;\r\n end;\r\n if Index <= Byte(dgIndicator in Options) - 1 then\r\n State := gsNormal;\r\n end;\r\n FSizingIndex := Index;\r\n FSizingOfs := SizingOfs;\r\nend;\r\n\r\nprocedure TJvDBGrid.DoDrawColumnTitle(ACanvas: TCanvas; ARect: TRect;\r\n AColumn: TColumn; var ASortMarker: TJvDBGridBitmap; IsDown: Boolean; var Offset: Integer;\r\n var DefaultDrawText, DefaultDrawSortMarker: Boolean);\r\nbegin\r\n if Assigned(FOnDrawColumnTitle) then\r\n begin\r\n FOnDrawColumnTitle(Self, ACanvas, ARect, AColumn, ASortMarker, IsDown, Offset,\r\n DefaultDrawText, DefaultDrawSortMarker);\r\n end;\r\nend;\r\n\r\nprocedure TJvDBGrid.ChangeBoolean(const FieldValueChange: Shortint);\r\n// FieldValueChange = 9 -> invert, 0 -> check (true), -1 -> uncheck (false)\r\nbegin\r\n if Assigned(FBooleanFieldToEdit) and BooleanEditor then\r\n begin\r\n DataLink.Edit;\r\n if DataLink.Editing then\r\n begin\r\n if FBooleanFieldToEdit.IsNull or (FieldValueChange <> JvGridBool_INVERT) then\r\n begin\r\n case FBooleanFieldToEdit.DataType of\r\n ftBoolean:\r\n FBooleanFieldToEdit.Value := (FieldValueChange = JvGridBool_CHECK);\r\n {$IFDEF COMPILER10_UP}ftFixedWideChar,{$ENDIF COMPILER10_UP}\r\n ftString, ftWideString, ftBCD, ftFMTBCD:\r\n begin\r\n if FieldValueChange = JvGridBool_CHECK then\r\n FBooleanFieldToEdit.Value := FStringForTrue\r\n else\r\n FBooleanFieldToEdit.Value := FStringForFalse;\r\n end;\r\n else\r\n //FBooleanFieldToEdit.Value := FieldValueChange + 1;\r\n if FieldValueChange <> JvGridBool_INVERT then\r\n FBooleanFieldToEdit.Value := FieldValueChange + 1\r\n else\r\n FBooleanFieldToEdit.Value := 1;\r\n end;\r\n end\r\n else\r\n case FBooleanFieldToEdit.DataType of\r\n ftBoolean:\r\n FBooleanFieldToEdit.Value := not FBooleanFieldToEdit.AsBoolean;\r\n {$IFDEF COMPILER10_UP}ftFixedWideChar,{$ENDIF COMPILER10_UP}\r\n ftString, ftWideString, ftBCD, ftFMTBCD:\r\n begin\r\n if AnsiSameText(FBooleanFieldToEdit.AsString, FStringForTrue) then\r\n FBooleanFieldToEdit.Value := FStringForFalse\r\n else\r\n FBooleanFieldToEdit.Value := FStringForTrue;\r\n end;\r\n else\r\n FBooleanFieldToEdit.Value := 1 - Abs(FBooleanFieldToEdit.AsInteger);\r\n end;\r\n InvalidateCell(Col, Row);\r\n end;\r\n end;\r\n FBooleanFieldToEdit := nil;\r\nend;\r\n\r\nprocedure TJvDBGrid.CellClick(Column: TColumn);\r\nbegin\r\n FTitleColumn := nil;\r\n inherited CellClick(Column);\r\n\r\n if Assigned(Column.Field) and (FBooleanFieldToEdit = Column.Field) then\r\n ChangeBoolean(JvGridBool_INVERT); // Invert the field value\r\nend;\r\n\r\nprocedure TJvDBGrid.EditButtonClick;\r\nbegin\r\n // Just to have it here for the call in TJvDBInplaceEdit\r\n inherited EditButtonClick;\r\nend;\r\n\r\nprocedure TJvDBGrid.MouseLeave(Control: TControl);\r\nbegin\r\n if csDesigning in ComponentState then\r\n Exit;\r\n inherited MouseLeave(Control);\r\nend;\r\n\r\nprocedure TJvDBGrid.DoGetBtnParams(Field: TField;\r\n AFont: TFont; var Background: TColor; var ASortMarker: TSortMarker;\r\n IsDown: Boolean);\r\nbegin\r\n if Assigned(FOnGetBtnParams) then\r\n FOnGetBtnParams(Self, Field, AFont, Background, ASortMarker, IsDown);\r\nend;\r\n\r\nprocedure TJvDBGrid.ColEnter;\r\nbegin\r\n FWord := '';\r\n inherited ColEnter;\r\n if FAlwaysShowEditor and not EditorMode then\r\n ShowEditor;\r\nend;\r\n\r\nfunction TJvDBGrid.DoMouseWheel(Shift: TShiftState; WheelDelta: Integer;\r\n MousePos: TPoint): Boolean;\r\nbegin\r\n if FCancelOnMouse then\r\n begin\r\n // Do not validate a record by error\r\n if DataLink.Active and (DataLink.DataSet.State <> dsBrowse) then\r\n DataLink.DataSet.Cancel;\r\n end;\r\n Result := inherited DoMouseWheel(Shift, WheelDelta, MousePos);\r\nend;\r\n\r\nprocedure TJvDBGrid.UpdateTabStops(ALimit: Integer = -1);\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := 0 to Columns.Count - 1 do\r\n with Columns[I] do\r\n if ALimit = -1 then\r\n TabStops[I + IndicatorOffset] := True\r\n else\r\n TabStops[I + IndicatorOffset] := (I < ALimit);\r\nend;\r\n\r\nprocedure TJvDBGrid.SetTitleArrow(const Value: Boolean);\r\nbegin\r\n if FTitleArrow <> Value then\r\n begin\r\n FTitleArrow := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvDBGrid.ReadDelphi2010OptionsMigrated(Reader: TReader);\r\nbegin\r\n FDelphi2010OptionsMigrated := Reader.ReadBoolean;\r\nend;\r\n\r\nprocedure TJvDBGrid.WriteDelphi2010OptionsMigrated(Writer: TWriter);\r\nbegin\r\n Writer.WriteBoolean(True);\r\nend;\r\n\r\nprocedure TJvDBGrid.DefineProperties(Filer: TFiler);\r\nbegin\r\n inherited DefineProperties(Filer);\r\n Filer.DefineProperty('AlternRowColor', ReadAlternateRowColor, nil, False);\r\n Filer.DefineProperty('AlternRowFontColor', ReadAlternateRowFontColor, nil, False);\r\n Filer.DefineProperty('PostOnEnter', ReadPostOnEnter, nil, False);\r\n\r\n // We need to migrate the Options set for Delphi 2010 due to the added flags\r\n Filer.DefineProperty('Delphi2010OptionsMigrated', ReadDelphi2010OptionsMigrated, WriteDelphi2010OptionsMigrated,\r\n {$IFDEF COMPILER14_UP}\r\n [dgTitleClick, dgTitleHotTrack] * Options = [] // if one of them is set we already know that we are migrated\r\n {$ELSE}\r\n False\r\n {$ENDIF COMPILER14_UP}\r\n );\r\nend;\r\n\r\nprocedure TJvDBGrid.ReadPostOnEnter(Reader: TReader);\r\nbegin\r\n PostOnEnterKey := Reader.ReadBoolean;\r\nend;\r\n\r\nprocedure TJvDBGrid.ReadAlternateRowColor(Reader: TReader);\r\nbegin\r\n if Reader.ReadBoolean then\r\n AlternateRowColor := JvDefaultAlternateRowColor // this was the previous default row color\r\n else\r\n AlternateRowColor := clNone;\r\nend;\r\n\r\nprocedure TJvDBGrid.SetAlternateRowColor(const Value: TColor);\r\nbegin\r\n if FAlternateRowColor <> Value then\r\n begin\r\n FAlternateRowColor := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvDBGrid.ReadAlternateRowFontColor(Reader: TReader);\r\nbegin\r\n if Reader.ReadBoolean then\r\n AlternateRowFontColor := JvDefaultAlternateRowFontColor\r\n else\r\n AlternateRowFontColor := clNone;\r\nend;\r\n\r\nprocedure TJvDBGrid.SetAlternateRowFontColor(const Value: TColor);\r\nbegin\r\n if FAlternateRowFontColor <> Value then\r\n begin\r\n FAlternateRowFontColor := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvDBGrid.DoAutoSizeColumns;\r\n// This function ignores Min and Max column widths because these values\r\n// bring about two problems:\r\n// - if (min. width * nb. of columns) > total width --> result too large\r\n// - if (max. width * nb. of columns) < total width --> result too small\r\nvar\r\n ColLineWidth, AvailableWidth, TotalColWidth, AWidth: Integer;\r\n I, ALeftCol, LastColIndex: Integer;\r\n ScaleFactor: Double;\r\nbegin\r\n if not AutoSizeColumns or FInAutoSize or (Columns.Count = 0) or (FGridState = gsColSizing) then\r\n Exit;\r\n FInAutoSize := True;\r\n ALeftCol := LeftCol;\r\n try\r\n // Get useable width\r\n ColLineWidth := Ord(dgColLines in Options) * GridLineWidth;\r\n AvailableWidth := ClientWidth;\r\n if (dgIndicator in Options) then\r\n Dec(AvailableWidth, IndicatorWidth + ColLineWidth);\r\n TotalColWidth := 0;\r\n if FixedCols = 0 then\r\n BeginLayout;\r\n try\r\n // Autosize all columns proportionally\r\n if AutoSizeColumnIndex = JvGridResizeProportionally then\r\n begin\r\n // Get width currently occupied by visible columns\r\n for I := 0 to Columns.Count - 1 do\r\n if Columns[I].Visible then\r\n begin\r\n Inc(TotalColWidth, Columns[I].Width);\r\n Dec(AvailableWidth, ColLineWidth);\r\n end;\r\n if TotalColWidth = 0 then\r\n TotalColWidth := 1;\r\n // Calculate the relationship between what's available and what's in use\r\n ScaleFactor := AvailableWidth / TotalColWidth;\r\n if ScaleFactor = 1.0 then\r\n Exit; // No need to continue - resizing won't change anything\r\n // Adjust the columns width\r\n for I := 0 to Columns.Count - 1 do\r\n if Columns[I].Visible then\r\n begin\r\n if I = LastVisibleColumn then\r\n Columns[I].Width := AvailableWidth\r\n else\r\n begin\r\n AWidth := Round(ScaleFactor * Columns[I].Width);\r\n if AWidth < 1 then\r\n AWidth := 1;\r\n Columns[I].Width := AWidth;\r\n Dec(AvailableWidth, AWidth);\r\n end;\r\n end;\r\n end\r\n else\r\n // Autosize the last visible column\r\n if AutoSizeColumnIndex = JvGridResizeLastVisibleCol then\r\n begin\r\n LastColIndex := LastVisibleColumn;\r\n if LastColIndex < 0 then\r\n Exit;\r\n for I := 0 to Columns.Count - 1 do\r\n if Columns[I].Visible and (I < LastColIndex) then\r\n Inc(TotalColWidth, Columns[I].Width + ColLineWidth);\r\n AWidth := AvailableWidth - TotalColWidth - ColLineWidth;\r\n if AWidth > 0 then\r\n Columns[LastColIndex].Width := AWidth;\r\n end\r\n else\r\n // Only autosize one column\r\n if AutoSizeColumnIndex <= LastVisibleColumn then\r\n begin\r\n for I := 0 to Columns.Count - 1 do\r\n if Columns[I].Visible and (I <> AutoSizeColumnIndex) then\r\n Inc(TotalColWidth, Columns[I].Width + ColLineWidth);\r\n AWidth := AvailableWidth - TotalColWidth - ColLineWidth;\r\n if AWidth > 0 then\r\n Columns[AutoSizeColumnIndex].Width := AWidth;\r\n end;\r\n finally\r\n if FixedCols = 0 then\r\n EndLayout;\r\n end;\r\n finally\r\n FInAutoSize := False;\r\n LeftCol := ALeftCol;\r\n end;\r\nend;\r\n\r\nprocedure TJvDBGrid.DoMaxColWidth;\r\nvar\r\n I: Integer;\r\nbegin\r\n if AutoSizeColumns or (MaxColumnWidth <= 0) then\r\n Exit;\r\n BeginLayout;\r\n try\r\n for I := 0 to Columns.Count - 1 do\r\n if Columns[I].Visible and (Columns[I].Width > MaxColumnWidth) then\r\n Columns[I].Width := MaxColumnWidth;\r\n finally\r\n EndLayout;\r\n end;\r\nend;\r\n\r\nprocedure TJvDBGrid.DoMinColWidth;\r\nvar\r\n I: Integer;\r\nbegin\r\n if AutoSizeColumns or (MinColumnWidth <= 0) then\r\n Exit;\r\n BeginLayout;\r\n try\r\n for I := 0 to Columns.Count - 1 do\r\n if Columns[I].Visible and (Columns[I].Width < MinColumnWidth) then\r\n Columns[I].Width := MinColumnWidth;\r\n finally\r\n EndLayout;\r\n end;\r\nend;\r\n\r\nprocedure TJvDBGrid.SetAutoSizeColumnIndex(const Value: Integer);\r\nbegin\r\n if FAutoSizeColumnIndex <> Value then\r\n begin\r\n FAutoSizeColumnIndex := Value;\r\n DoAutoSizeColumns;\r\n end;\r\nend;\r\n\r\nprocedure TJvDBGrid.SetAutoSizeColumns(const Value: Boolean);\r\nbegin\r\n if FAutoSizeColumns <> Value then\r\n begin\r\n FAutoSizeColumns := Value;\r\n DoAutoSizeColumns;\r\n end;\r\nend;\r\n\r\nprocedure TJvDBGrid.SetMaxColumnWidth(const Value: Integer);\r\nbegin\r\n if FMaxColumnWidth <> Value then\r\n begin\r\n FMaxColumnWidth := Value;\r\n DoMaxColWidth;\r\n end;\r\nend;\r\n\r\nprocedure TJvDBGrid.SetMinColumnWidth(const Value: Integer);\r\nbegin\r\n if FMinColumnWidth <> Value then\r\n begin\r\n FMinColumnWidth := Value;\r\n DoMinColWidth;\r\n end;\r\nend;\r\n\r\nprocedure TJvDBGrid.InitializeColumnsWidth(const MinWidth, MaxWidth: Integer;\r\n const DisplayWholeTitle: Boolean; const FixedWidths: array of Integer);\r\nvar\r\n SavedValue: Boolean;\r\n I, J,\r\n AWidth: Integer;\r\nbegin\r\n // Resize the grid columns with the given widths (0 = default width) and\r\n // ensure they are wide enough for the title caption (optional).\r\n // If there are more columns than widths in FixedWidths, the last given width\r\n // is used for the remaining columns.\r\n // If Min/MaxWidth < 0, the Min/MaxColumnWidth value is set automatically.\r\n // If Min/MaxWidth = 0, the Min/MaxColumnWidth value is not modified.\r\n // If Min/MaxWidth > 0, the Min/MaxColumnWidth value is set to the given value.\r\n SavedValue := AutoSizeColumns;\r\n FAutoSizeColumns := False;\r\n try\r\n J := Low(FixedWidths);\r\n if MinWidth > 0 then\r\n FMinColumnWidth := MinWidth\r\n else\r\n if MinWidth < 0 then\r\n FMinColumnWidth := FixedWidths[J];\r\n if MaxWidth > 0 then\r\n FMaxColumnWidth := MaxWidth\r\n else\r\n if MaxWidth < 0 then\r\n FMaxColumnWidth := FixedWidths[J];\r\n for I := 0 to Columns.Count - 1 do\r\n if Columns[I].Visible then\r\n begin\r\n if FixedWidths[J] < 1 then\r\n AWidth := Columns[I].DefaultWidth\r\n else\r\n begin\r\n AWidth := FixedWidths[J];\r\n if (dgTitles in Options) and DisplayWholeTitle then\r\n begin\r\n Canvas.Font.Assign(Columns[I].Title.Font);\r\n if Canvas.TextWidth(Columns[I].Title.Caption) + 4 > AWidth then\r\n AWidth := Canvas.TextWidth(Columns[I].Title.Caption) + 4;\r\n end;\r\n end;\r\n if AWidth < MinColumnWidth then\r\n begin\r\n if MinWidth < 0 then\r\n FMinColumnWidth := AWidth\r\n else\r\n if MinColumnWidth > 0 then\r\n AWidth := MinColumnWidth;\r\n end;\r\n if AWidth > MaxColumnWidth then\r\n begin\r\n if MaxWidth < 0 then\r\n FMaxColumnWidth := AWidth\r\n else\r\n if MaxColumnWidth > 0 then\r\n AWidth := MaxColumnWidth;\r\n end;\r\n Columns[I].Width := AWidth;\r\n if J < High(FixedWidths) then\r\n J := J + 1;\r\n end;\r\n finally\r\n AutoSizeColumns := SavedValue;\r\n end;\r\nend;\r\n\r\nprocedure TJvDBGrid.Resize;\r\nbegin\r\n inherited Resize;\r\n DoAutoSizeColumns;\r\n\r\n NotifyLayoutChange(lcSizeChanged);\r\nend;\r\n\r\nprocedure TJvDBGrid.Loaded;\r\nvar\r\n Ctrl_Idx: Integer;\r\n WinControl: TWinControl;\r\nbegin\r\n inherited Loaded;\r\n {$IFDEF COMPILER14_UP}\r\n // Fix the bug that Embarcadero has introduced when they added new flags to the Options set\r\n if not FDelphi2010OptionsMigrated and ([dgTitleClick, dgTitleHotTrack] * Options = []) then\r\n begin\r\n FDelphi2010OptionsMigrated := True;\r\n Options := Options + [dgTitleClick, dgTitleHotTrack];\r\n end;\r\n {$ENDIF COMPILER14_UP}\r\n\r\n // Edit controls are hidden\r\n for Ctrl_Idx := 0 to FControls.Count - 1 do\r\n begin\r\n WinControl := TWinControl(Owner.FindComponent(FControls.Items[Ctrl_Idx].ControlName));\r\n if WinControl <> nil then\r\n WinControl.Visible := False;\r\n end;\r\n\r\n DoAutoSizeColumns;\r\nend;\r\n\r\nfunction TJvDBGrid.GetMaxColWidth(Default: Integer): Integer;\r\nbegin\r\n if (MaxColumnWidth > 0) and (Default > MaxColumnWidth) then\r\n Result := MaxColumnWidth\r\n else\r\n Result := Default;\r\nend;\r\n\r\nfunction TJvDBGrid.GetMinColWidth(Default: Integer): Integer;\r\nbegin\r\n if (MinColumnWidth > 0) and (Default < MinColumnWidth) then\r\n Result := MinColumnWidth\r\n else\r\n Result := Default;\r\nend;\r\n\r\nfunction TJvDBGrid.FirstVisibleColumn: Integer;\r\nbegin\r\n for Result := 0 to Columns.Count - 1 do\r\n if Columns[Result].Visible then\r\n Exit;\r\n Result := -1;\r\nend;\r\n\r\nfunction TJvDBGrid.LastVisibleColumn: Integer;\r\nbegin\r\n for Result := Columns.Count - 1 downto 0 do\r\n if Columns[Result].Visible then\r\n Exit;\r\n Result := -1;\r\nend;\r\n\r\nfunction TJvDBGrid.GetMaxDisplayText: string;\r\n\r\n procedure CheckText;\r\n var\r\n S: string;\r\n begin\r\n // if IsMemoField use AsString property\r\n if FShowMemos and IsMemoField(Columns[FResizeColumnIndex].Field) then\r\n begin\r\n S := Columns[FResizeColumnIndex].Field.AsString;\r\n if Length(Result) < Length(S) then\r\n Result := S;\r\n end\r\n else\r\n begin\r\n S := Columns[FResizeColumnIndex].Field.DisplayText;\r\n if Length(Result) < Length(S) then\r\n Result := S;\r\n end;\r\n end;\r\n\r\nconst\r\n MaxRecords = 100; { value between 100 - 1000, or maybe calculated, or user input }\r\nvar\r\n DSet: TDataSet;\r\n LBookmark: TBookmark;\r\n I, ActiveRec: Integer;\r\n LastCursor: TCursor;\r\nbegin\r\n Result := '';\r\n\r\n DSet := DataSource.DataSet;\r\n\r\n if (DSet.State in dsEditModes) and not FCancelOnMouse then\r\n DSet.CheckBrowseMode;\r\n\r\n // Start location\r\n LBookmark := DSet.GetBookmark;\r\n ActiveRec := DataLink.ActiveRecord;\r\n DSet.DisableControls;\r\n LastCursor := Screen.Cursor;\r\n try\r\n Screen.Cursor := crHourGlass;\r\n\r\n // The iteration begins...\r\n if (FColumnResize = gcrDataSet) and (DSet.RecordCount <= MaxRecords) then\r\n begin\r\n { Iterate all records in dataset. *** Very slow for thousands of records. *** }\r\n DSet.First;\r\n while not DSet.Eof do\r\n begin\r\n CheckText;\r\n DSet.Next;\r\n end;\r\n end\r\n else\r\n begin\r\n { Iterate only the rows shown by the grid. *** This is the faster approach. ***}\r\n for I := 0 to DataLink.RecordCount{BufferCount} - 1 do\r\n begin\r\n DataLink.ActiveRecord := I;\r\n CheckText;\r\n end;\r\n end;\r\n finally\r\n // ActiveRecord must be set BEFORE GotoBookmark\r\n DataLink.ActiveRecord := ActiveRec;\r\n try\r\n GotoBookmarkEx(DSet, LBookmark, [rmExact], False); // Do not center current record\r\n except\r\n end;\r\n DSet.FreeBookmark(LBookmark);\r\n\r\n DSet.EnableControls;\r\n Screen.Cursor := LastCursor;\r\n end;\r\nend;\r\n\r\nfunction TJvDBGrid.GetColumnMaxWidth: Integer;\r\nconst\r\n Space = 7; // Some space needed to distinguish field data between columns.\r\nvar\r\n S: string;\r\n RestoreCanvas: Boolean;\r\n TempDC: HDC;\r\n TM: TTextMetric;\r\nbegin\r\n if Columns[FResizeColumnIndex].Field <> nil then\r\n begin\r\n { Iterate through the recordset }\r\n S := GetMaxDisplayText;\r\n if S <> '' then\r\n begin\r\n RestoreCanvas := not HandleAllocated;\r\n if RestoreCanvas then\r\n Canvas.Handle := GetDC(0);\r\n try\r\n Canvas.Font := Font;\r\n GetTextMetrics(Canvas.Handle, TM);\r\n Result := Canvas.TextWidth(S) + TM.tmOverhang + 4 + Space;\r\n if Result < DefaultColWidth then\r\n Result := DefaultColWidth;\r\n finally\r\n if RestoreCanvas then\r\n begin\r\n TempDC := Canvas.Handle;\r\n Canvas.Handle := 0;\r\n ReleaseDC(0, TempDc);\r\n end;\r\n end;\r\n end\r\n else\r\n Result := DefaultColWidth;\r\n end\r\n else { Field is not assigned }\r\n Result := DefaultColWidth;\r\nend;\r\n\r\nprocedure TJvDBGrid.DblClick;\r\nbegin\r\n { Resize column (double-click) }\r\n if FCanResizeColumn then\r\n begin\r\n if FColumnResize <> gcrNone then\r\n Columns[FResizeColumnIndex].Width := GetColumnMaxWidth;\r\n end\r\n else // When resize column (double-click) DO NOT trigger title DblClick event.\r\n if not DoTitleBtnDblClick then\r\n inherited DblClick;\r\n FTitleColumn := nil;\r\nend;\r\n\r\nfunction TJvDBGrid.DoTitleBtnDblClick: Boolean;\r\nbegin\r\n Result := Assigned(FOnTitleBtnDblClick) and Assigned(FTitleColumn);\r\n if Result then\r\n FOnTitleBtnDblClick(Self, FTitleColumn.Index, FTitleColumn.Field);\r\nend;\r\n\r\nprocedure TJvDBGrid.TitleClick(Column: TColumn);\r\nbegin\r\n { When resize DO NOT trigger title click event }\r\n if FCanResizeColumn then\r\n Exit;\r\n \r\n FTitleColumn := Column;\r\n inherited TitleClick(Column);\r\n if AllowTitleClick then\r\n begin\r\n FPaintInfo.ColPressed := False;\r\n FPaintInfo.ColPressedIdx := -1;\r\n {$IFNDEF COMPILER14_UP}\r\n {$IFDEF JVCLThemesEnabled}\r\n if UseXPThemes and ThemeServices.ThemesEnabled then\r\n if ValidCell(FCell) then\r\n InvalidateCell(FCell.X, FCell.Y);\r\n {$ENDIF JVCLThemesEnabled}\r\n {$ENDIF ~COMPILER14_UP}\r\n end;\r\nend;\r\n\r\nprocedure TJvDBGrid.SetSortedField(const Value: string);\r\nbegin\r\n if FSortedField <> Value then\r\n begin\r\n FSortedField := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nfunction TJvDBGrid.ChangeSortMarker(const Value: TSortMarker): Boolean;\r\nbegin\r\n Result := (FSortMarker <> Value);\r\n if Result then\r\n FSortMarker := Value;\r\nend;\r\n\r\nprocedure TJvDBGrid.SetSortMarker(const Value: TSortMarker);\r\nbegin\r\n if ChangeSortMarker(Value) then\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvDBGrid.CMHintShow(var Msg: TCMHintShow);\r\nconst\r\n C_TIMEOUT = 250;\r\nvar\r\n ACol, ARow, ATimeOut, SaveRow: Integer;\r\n AtCursorPosition: Boolean;\r\n CalcOptions: Integer;\r\n InitialMousePos: TPoint;\r\n HintRect: TRect;\r\nbegin\r\n AtCursorPosition := True;\r\n with Msg.HintInfo^ do\r\n begin\r\n { Save the position of mouse cursor }\r\n InitialMousePos := Mouse.CursorPos;\r\n\r\n HintStr := GetShortHint(Hint);\r\n ATimeOut := HideTimeOut;\r\n Self.MouseToCell(CursorPos.X, CursorPos.Y, ACol, ARow);\r\n\r\n //-------------------------------------------------------------------------\r\n // ARow <= -1 if 'outside' a valid cell;\r\n // Adjust CursorRect\r\n //-------------------------------------------------------------------------\r\n if FShowTitleHint or FShowCellHint then\r\n begin\r\n if (ARow <= -1) or ((ARow >= 1) and not FShowCellHint) then\r\n begin\r\n if FShowCellHint then\r\n begin\r\n CursorRect.Left := CellRect(0, Self.RowCount - 1).Left;\r\n CursorRect.Top := CellRect(0, Self.RowCount - 1).Bottom;\r\n end\r\n else\r\n begin\r\n CursorRect.Left := CellRect(0, 0).Left;\r\n CursorRect.Top := CellRect(0, 0).Bottom;\r\n end;\r\n end\r\n else\r\n CursorRect := CellRect(ACol, ARow);\r\n end;\r\n\r\n if dgIndicator in Options then\r\n Dec(ACol, IndicatorOffset);\r\n if dgTitles in Options then\r\n Dec(ARow, TitleOffset);\r\n\r\n if FShowTitleHint and (ACol >= 0) and (ARow <= -1) then\r\n begin\r\n AtCursorPosition := FCellHintPosition = gchpMouse;\r\n HintStr := Columns[ACol].FieldName;\r\n ATimeOut := Max(ATimeOut, Length(HintStr) * C_TIMEOUT);\r\n if Assigned(FOnShowTitleHint) and DataLink.Active then\r\n FOnShowTitleHint(Self, Columns[ACol].Field, HintStr, ATimeOut);\r\n HideTimeOut := ATimeOut;\r\n end;\r\n\r\n if FShowCellHint and (ACol >= 0) and DataLink.Active and\r\n ((ARow >= 0) or not FShowTitleHint) then\r\n begin\r\n AtCursorPosition := FCellHintPosition = gchpMouse;\r\n HintStr := Hint;\r\n SaveRow := DataLink.ActiveRecord;\r\n try\r\n CalcOptions := DT_CALCRECT or DT_LEFT or DT_NOPREFIX or DrawTextBiDiModeFlagsReadingOnly;\r\n if ARow <= -1 then // can be less than -1 if the column header is multiline (AdtField)\r\n begin\r\n Canvas.Font.Assign(Columns[ACol].Title.Font);\r\n HintStr := Columns[ACol].Title.Caption;\r\n if WordWrap then\r\n CalcOptions := CalcOptions or DT_WORDBREAK;\r\n end\r\n else\r\n with Columns[ACol] do\r\n begin\r\n Canvas.Font.Assign(Font);\r\n DataLink.ActiveRecord := ARow;\r\n if Field <> nil then\r\n begin\r\n if WordWrap and\r\n (WordWrapAllFields or (Field is TStringField) or (FShowMemos and IsMemoField(Field))) then\r\n CalcOptions := CalcOptions or DT_WORDBREAK;\r\n\r\n HintStr := Field.DisplayText;\r\n // MemoField's DisplayText is '(Memo)'\r\n if not Assigned(Field.OnGetText) and IsMemoField(Field) then\r\n HintStr := Field.AsString\r\n else\r\n if (Field is TBlobField) or EditWithBoolBox(Field) then\r\n HintStr := '';\r\n end;\r\n end;\r\n\r\n if HintStr <> '' then\r\n begin\r\n HintRect := Rect(0, 0, Columns[ACol].Width - 4, 0);\r\n Windows.DrawText(Canvas.Handle, PChar(HintStr), -1, HintRect, CalcOptions);\r\n if ((HintRect.Bottom - HintRect.Top + 2) < RowHeights[ARow + 1]) and\r\n ((HintRect.Right - HintRect.Left) < Columns[ACol].Width - 2) then\r\n HintStr := '';\r\n end;\r\n\r\n ATimeOut := Max(ATimeOut, Length(HintStr) * C_TIMEOUT);\r\n if Assigned(FOnShowCellHint) and DataLink.Active then\r\n FOnShowCellHint(Self, Columns[ACol].Field, HintStr, ATimeOut);\r\n HideTimeOut := ATimeOut;\r\n finally\r\n if DataLink.ActiveRecord <> SaveRow then\r\n DataLink.ActiveRecord := SaveRow;\r\n end;\r\n end;\r\n\r\n if not AtCursorPosition and HintWindowClass.ClassNameIs('THintWindow') then\r\n HintPos := ClientToScreen(CursorRect.TopLeft)\r\n else\r\n HintPos := InitialMousePos;\r\n end;\r\n inherited;\r\nend;\r\n\r\nprocedure TJvDBGrid.WMVScroll(var Msg: TWMVScroll);\r\nvar\r\n ALeftCol: Integer;\r\nbegin\r\n if dgRowSelect in Options then\r\n begin\r\n ALeftCol := LeftCol;\r\n inherited;\r\n LeftCol := ALeftCol;\r\n end\r\n else\r\n inherited;\r\nend;\r\n\r\nprocedure TJvDBGrid.SetWordWrap(Value: Boolean);\r\nbegin\r\n if Value <> FWordWrap then\r\n begin\r\n FWordWrap := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvDBGrid.SetWordWrapAllFields(Value: Boolean);\r\nbegin\r\n if Value <> FWordWrapAllFields then\r\n begin\r\n FWordWrapAllFields := Value;\r\n if WordWrap then\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvDBGrid.PlaceControl(Control: TWinControl; ACol, ARow: Integer);\r\nvar\r\n R: TRect;\r\n GridControl: TJvDBGridControl;\r\n ClientTopLeft: TPoint;\r\n ParentForm: TCustomForm;\r\nbegin\r\n // Do not test for Assigned(Control) here or you will end\r\n // up with an infinite loop of error messages. This check must\r\n // be done in UseDefaultEditor\r\n\r\n if ReadOnly or not (Control.Enabled and DataLink.DataSet.CanModify) then\r\n begin\r\n HideCurrentControl;\r\n Exit;\r\n end;\r\n\r\n if Control <> FCurrentControl then\r\n begin\r\n HideCurrentControl;\r\n FCurrentControl := Control;\r\n if FCurrentControl <> nil then\r\n FCurrentControl.FreeNotification(Self);\r\n FOldControlWndProc := FCurrentControl.WindowProc;\r\n FCurrentControl.WindowProc := ControlWndProc;\r\n end;\r\n\r\n if Control.Parent <> Self.Parent then\r\n Control.Parent := Self.Parent;\r\n\r\n R := CellRect(ACol, ARow);\r\n if ((R.Right - R.Left) < 1) or ((R.Bottom - R.Top) < 1) then\r\n // Cell too small to be drawn -> the control is not drawn\r\n Control.BoundsRect := Rect(0, 0, 0, 0)\r\n else\r\n begin\r\n R.TopLeft := ClientToScreen(R.TopLeft);\r\n R.TopLeft := TControl(Control.Parent).ScreenToClient(R.TopLeft);\r\n R.BottomRight := ClientToScreen(R.BottomRight);\r\n R.BottomRight := TControl(Control.Parent).ScreenToClient(R.BottomRight);\r\n\r\n // Fred: I removed this code because moving a control away from the topleft corner\r\n // of the cell lets appear the cell and its focus rectangle behind.\r\n\r\n //if Control is TCustomEdit then\r\n //begin\r\n // { The edit control's text is not painted at good position when the control\r\n // has no border }\r\n // if TOpenCustomEdit(Control).BorderStyle = bsNone then\r\n // begin\r\n // Inc(R.Left, 2);\r\n // Inc(R.Top, 2);\r\n // end;\r\n //end;\r\n\r\n ClientTopLeft := TControl(Control.Parent).ScreenToClient(Self.ClientOrigin);\r\n GridControl := FControls.ControlByName(Control.Name);\r\n if GridControl.FitCell in [fcDesignSize, fcBiggest] then\r\n begin\r\n if GridControl.FitCell = fcBiggest then\r\n begin\r\n // We choose the biggest size between cell size and design size\r\n if GridControl.FDesignWidth = 0 then\r\n GridControl.FDesignWidth := Control.Width;\r\n if (R.Right - R.Left) > GridControl.FDesignWidth then\r\n Control.Width := R.Right - R.Left\r\n else\r\n Control.Width := GridControl.FDesignWidth;\r\n if GridControl.FDesignHeight = 0 then\r\n GridControl.FDesignHeight := Control.Height;\r\n if (R.Bottom - R.Top) > GridControl.FDesignHeight then\r\n Control.Height := R.Bottom - R.Top\r\n else\r\n Control.Height := GridControl.FDesignHeight;\r\n end;\r\n // Horizontal alignment of the control\r\n if (R.Left + Control.Width) > (ClientTopLeft.X + Self.ClientWidth) then\r\n begin\r\n Control.Left := (R.Right - Control.Width); // Right align\r\n if Control.Left < ClientTopLeft.X then\r\n Control.Left := ClientTopLeft.X;\r\n end\r\n else\r\n Control.Left := R.Left; // Left align\r\n // Vertical alignment of the control\r\n if (R.Top + Control.Height) > (ClientTopLeft.Y + Self.ClientHeight) then\r\n begin\r\n Control.Top := (R.Bottom - Control.Height); // Bottom align\r\n if Control.Top < ClientTopLeft.Y then\r\n Control.Top := ClientTopLeft.Y;\r\n end\r\n else\r\n Control.Top := R.Top; // Top align\r\n end\r\n else\r\n // Control drawn at cell size\r\n Control.BoundsRect := R;\r\n end;\r\n Control.BringToFront;\r\n Control.Show;\r\n\r\n ParentForm := GetParentForm(Self);\r\n if Self.Visible and Control.Visible and (Self.Parent <> nil) and\r\n Self.Parent.Visible and (ParentForm <> nil) and ParentForm.Visible then\r\n begin\r\n if dgCancelOnExit in Options then\r\n begin // Don't cancel the empty record while moving focus\r\n Options := Options - [dgCancelOnExit];\r\n Control.SetFocus;\r\n Options := Options + [dgCancelOnExit];\r\n end\r\n else\r\n Control.SetFocus;\r\n end;\r\nend;\r\n\r\nprocedure TJvDBGrid.SetControls(Value: TJvDBGridControls);\r\nbegin\r\n FControls.Assign(Value);\r\nend;\r\n\r\nprocedure TJvDBGrid.HideCurrentControl;\r\nbegin\r\n if FCurrentControl <> nil then\r\n begin\r\n FCurrentControl.WindowProc := FOldControlWndProc;\r\n if FCurrentControl.HandleAllocated then\r\n begin\r\n SendMessage(FCurrentControl.Handle, WM_KILLFOCUS, 0, 0); // can free the FCurrentControl\r\n if FCurrentControl <> nil then\r\n FCurrentControl.Hide;\r\n end;\r\n if FCurrentControl <> nil then\r\n FCurrentControl.RemoveFreeNotification(Self);\r\n FCurrentControl := nil;\r\n end;\r\n FOldControlWndProc := nil;\r\nend;\r\n\r\nprocedure TJvDBGrid.CloseControl;\r\nbegin\r\n { Do not hide the control if it has the focus because then the WM_KILLFOCUS\r\n ControlWndProc hook will hide it. }\r\n if not Visible or (FCurrentControl = nil) or not FCurrentControl.HandleAllocated or\r\n not FCurrentControl.Focused then\r\n HideCurrentControl;\r\n if Visible then\r\n begin\r\n SetFocus;\r\n { If the grid does not have the focus after a SetFocus, one of the executed\r\n CM_EXIT has failed with an exception or has set the focus to another control.\r\n In that case the CurrentControl is still active. }\r\n if (FCurrentControl <> nil) and FCurrentControl.Focused then\r\n Abort;\r\n end;\r\nend;\r\n\r\nprocedure TJvDBGrid.ControlWndProc(var Message: TMessage);\r\nvar\r\n EscapeKey: Boolean;\r\n CurrentEditor: TJvDBGridControl;\r\nbegin\r\n if Message.Msg = WM_CHAR then\r\n begin\r\n if not DoKeyPress(TWMChar(Message)) then\r\n with TWMKey(Message) do\r\n begin\r\n CurrentEditor := FControls.ControlByName(FCurrentControl.Name);\r\n if (CharCode = VK_RETURN) and (PostOnEnterKey or CurrentEditor.LeaveOnEnterKey) then\r\n begin\r\n CloseControl;\r\n if PostOnEnterKey then\r\n DataSource.DataSet.CheckBrowseMode;\r\n end\r\n else\r\n if CharCode = VK_TAB then\r\n begin\r\n CloseControl;\r\n PostMessage(Handle, WM_KEYDOWN, VK_TAB, KeyData);\r\n end\r\n else\r\n begin\r\n EscapeKey := (CharCode = VK_ESCAPE);\r\n FOldControlWndProc(Message);\r\n if EscapeKey then\r\n begin\r\n CloseControl;\r\n if Assigned(SelectedField) then\r\n begin\r\n // OldValue is only available when State=dsEdit, otherwise it can throw an AV.\r\n if (SelectedField.DataSet.State = dsEdit) and (SelectedField.OldValue <> SelectedField.Value) then\r\n SelectedField.Value := SelectedField.OldValue\r\n else if (SelectedField.DataSet.State = dsInsert) and not SelectedField.IsNull then\r\n SelectedField.Clear;\r\n end;\r\n end;\r\n end;\r\n end;\r\n end\r\n else\r\n if Message.Msg = WM_KEYDOWN then\r\n begin\r\n with TWMKey(Message) do\r\n begin\r\n CurrentEditor := FControls.ControlByName(FCurrentControl.Name);\r\n if (CurrentEditor <> nil) and CurrentEditor.LeaveOnUpDownKey and\r\n ((CharCode = VK_UP) or (CharCode = VK_DOWN)) and (KeyDataToShiftState(KeyData) = []) then\r\n begin\r\n CloseControl;\r\n DataSource.DataSet.CheckBrowseMode;\r\n PostMessage(Handle, WM_KEYDOWN, CharCode, KeyData);\r\n end\r\n else\r\n FOldControlWndProc(Message);\r\n end;\r\n end\r\n else\r\n begin\r\n FOldControlWndProc(Message);\r\n case Message.Msg Of\r\n WM_GETDLGCODE:\r\n begin\r\n CurrentEditor := FControls.ControlByName(FCurrentControl.Name);\r\n if (CurrentEditor <> nil) and CurrentEditor.LeaveOnUpDownKey then\r\n Message.Result := Message.Result or DLGC_WANTTAB or DLGC_WANTARROWS;\r\n end;\r\n CM_EXIT:\r\n HideCurrentControl;\r\n end;\r\n end;\r\nend;\r\n\r\n//=== { TJvSelectDialogColumnStrings } =======================================\r\n\r\nconstructor TJvSelectDialogColumnStrings.Create;\r\nbegin\r\n inherited Create;\r\n Caption := RsJvDBGridSelectTitle;\r\n RealNamesOption := '';//RsJvDBGridSelectOption;\r\n OK := RsButtonOKCaption;\r\n NoSelectionWarning := RsJvDBGridSelectWarning;\r\nend;\r\n\r\nprocedure TJvDBGrid.ShowSelectColumnClick;\r\nbegin\r\n ShowColumnsDialog;\r\nend;\r\n\r\nprocedure TJvDBGrid.CreateParams(var Params: TCreateParams);\r\nbegin\r\n inherited CreateParams(Params);\r\n {$IFDEF COMPILER9_UP}\r\n // The grid can only handle ssNone and ssHorizontal. We have to emulate the other modes.\r\n if FScrollBars = ssVertical then\r\n Params.Style := Params.Style and not WS_HSCROLL;\r\n {$ENDIF COMPILER9_UP}\r\nend;\r\n\r\n{$IFDEF COMPILER9_UP}\r\nprocedure TJvDBGrid.SetScrollBars(Value: TScrollStyle);\r\nbegin\r\n if Value <> FScrollBars then\r\n begin\r\n FScrollBars := Value;\r\n // The grid can only handle ssNone and ssHorizontal. We have to emulate the other modes.\r\n if Value in [ssVertical, ssBoth] then\r\n Value := ssHorizontal;\r\n\r\n if Value = inherited ScrollBars then\r\n RecreateWnd\r\n else\r\n inherited ScrollBars := Value;\r\n\r\n if (FScrollBars = ssVertical) and HandleAllocated then\r\n ShowScrollBar(Handle, SB_HORZ, False);\r\n end;\r\nend;\r\n{$ENDIF COMPILER9_UP}\r\n\r\nprocedure TJvDBGrid.SetSelectColumnsDialogStrings(const Value: TJvSelectDialogColumnStrings);\r\nbegin\r\n // do nothing\r\nend;\r\n\r\nprocedure TJvDBGrid.ShowColumnsDialog;\r\nvar\r\n R, WorkArea: TRect;\r\n Frm: TfrmSelectColumn;\r\n Pt: TPoint;\r\n DefaultDialog: Boolean;\r\nbegin\r\n DefaultDialog := True;\r\n if Assigned(FOnSelectColumns) then\r\n FOnSelectColumns(Self, DefaultDialog);\r\n if DefaultDialog then\r\n begin\r\n R := CellRect(0, 0);\r\n Frm := TfrmSelectColumn.Create(Application);\r\n try\r\n if not IsRectEmpty(R) then\r\n begin\r\n Pt := ClientToScreen(Point(R.Left, R.Bottom + 1));\r\n WorkArea := Screen.MonitorFromWindow(Handle).WorkareaRect;\r\n { force the form the be in the working area }\r\n if Pt.X + Frm.Width > WorkArea.Right then\r\n Pt.X := WorkArea.Right - Frm.Width;\r\n if Pt.Y + Frm.Height > WorkArea.Bottom then\r\n Pt.Y := WorkArea.Bottom - Frm.Height;\r\n Frm.SetBounds(Pt.X, Pt.Y, Frm.Width, Frm.Height);\r\n end;\r\n Frm.Grid := Self;\r\n Frm.DataSource := DataLink.DataSource;\r\n Frm.SelectColumn := SelectColumn;\r\n Frm.Caption := SelectColumnsDialogStrings.Caption;\r\n Frm.cbWithFieldName.Caption := SelectColumnsDialogStrings.RealNamesOption;\r\n Frm.ButtonOK.Caption := SelectColumnsDialogStrings.OK;\r\n Frm.NoSelectionWarning := SelectColumnsDialogStrings.NoSelectionWarning;\r\n Frm.ShowModal;\r\n finally\r\n Frm.Free;\r\n end;\r\n end;\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvDBGrid.SetBooleanEditor(const Value: Boolean);\r\nbegin\r\n if FBooleanEditor <> Value then\r\n begin\r\n FBooleanEditor := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvDBGrid.SetShowMemos(const Value: Boolean);\r\nbegin\r\n if FShowMemos <> Value then\r\n begin\r\n FShowMemos := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nfunction TJvDBGrid.GetUseXPThemes: Boolean;\r\nbegin\r\n {$IFDEF COMPILER14_UP}\r\n Result := DrawingStyle = gdsThemed;\r\n {$ELSE}\r\n Result := FUseXPThemes;\r\n {$ENDIF COMPILER14_UP}\r\nend;\r\n\r\nprocedure TJvDBGrid.SetUseXPThemes(Value: Boolean);\r\nbegin\r\n if Value <> UseXPThemes then\r\n begin\r\n {$IFDEF COMPILER14_UP}\r\n if Value then\r\n DrawingStyle := gdsThemed\r\n else\r\n DrawingStyle := gdsClassic;\r\n {$ELSE}\r\n FUseXPThemes := Value;\r\n Invalidate;\r\n {$ENDIF COMPILER14_UP}\r\n end;\r\nend;\r\n\r\n{$IFNDEF COMPILER14_UP}\r\n{$IFDEF JVCLThemesEnabled}\r\nfunction TJvDBGrid.ColumnOffset: Integer;\r\nbegin\r\n if dgIndicator in Options then\r\n Result := IndicatorOffset\r\n else\r\n Result := 0;\r\nend;\r\n\r\nfunction TJvDBGrid.ValidCell(ACell: TGridCoord): Boolean;\r\nbegin\r\n Result := (ACell.X <> -1) and (ACell.Y <> -1);\r\nend;\r\n{$ENDIF JVCLThemesEnabled}\r\n{$ENDIF ~COMPILER14_UP}\r\n\r\nfunction TJvDBGrid.BeginColumnDrag(var Origin: Integer; var Destination: Integer; const MousePt: TPoint): Boolean;\r\nbegin\r\n Result := inherited BeginColumnDrag(Origin, Destination, MousePt);\r\n FPaintInfo.ColMoving := Result;\r\nend;\r\n\r\n{$IFDEF COMPILER10_UP}\r\nprocedure TJvDBGrid.WMPaint(var Message: TWMPaint);\r\nvar\r\n R: TRect;\r\nbegin\r\n if UseRightToLeftAlignment then\r\n begin\r\n { Workaround for a RightToLeft painting bug (QC #70075)\r\n Side effect: The grid needs more time to paint }\r\n R.TopLeft := ClientRect.TopLeft;\r\n R.BottomRight := ClientRect.BottomRight;\r\n Windows.InvalidateRect(Handle, @R, False);\r\n end;\r\n inherited;\r\nend;\r\n{$ENDIF COMPILER10_UP}\r\n\r\nprocedure TJvDBGrid.CMMouseEnter(var Message: TMessage);\r\n{$IFNDEF COMPILER14_UP}\r\n{$IFDEF JVCLThemesEnabled}\r\nvar\r\n Cell: TGridCoord;\r\n lPt: TPoint;\r\n{$ENDIF JVCLThemesEnabled}\r\n{$ENDIF ~COMPILER14_UP}\r\nbegin\r\n inherited;\r\n {$IFNDEF COMPILER14_UP}\r\n {$IFDEF JVCLThemesEnabled}\r\n lPt := Point(Mouse.CursorPos.X, Mouse.CursorPos.Y);\r\n Cell := MouseCoord(lPt.X, lPt.Y);\r\n if UseXPThemes and ThemeServices.ThemesEnabled then\r\n if (dgTitles in Options) and (Cell.Y = 0) then\r\n InvalidateCell(Cell.X, Cell.Y);\r\n {$ENDIF JVCLThemesEnabled}\r\n {$ENDIF ~COMPILER14_UP}\r\nend;\r\n\r\nprocedure TJvDBGrid.CMMouseLeave(var Message: TMessage);\r\nbegin\r\n inherited;\r\n {$IFNDEF COMPILER14_UP}\r\n {$IFDEF JVCLThemesEnabled}\r\n if UseXPThemes and ThemeServices.ThemesEnabled then\r\n if ValidCell(FCell) then\r\n InvalidateCell(FCell.X, FCell.Y);\r\n {$ENDIF JVCLThemesEnabled}\r\n {$ENDIF ~COMPILER14_UP}\r\n FCell.X := -1;\r\n FCell.Y := -1;\r\n FPaintInfo.MouseInCol := -1;\r\n FPaintInfo.ColPressedIdx := -1;\r\nend;\r\n\r\nprocedure TJvDBGrid.ColExit;\r\nbegin\r\n inherited ColExit;\r\n FPaintInfo.MouseInCol := -1;\r\n {$IFNDEF COMPILER14_UP}\r\n {$IFDEF JVCLThemesEnabled}\r\n if UseXPThemes and ThemeServices.ThemesEnabled then\r\n if ValidCell(FCell) then\r\n InvalidateCell(FCell.X, FCell.Y);\r\n {$ENDIF JVCLThemesEnabled}\r\n {$ENDIF ~COMPILER14_UP}\r\nend;\r\n\r\nfunction TJvDBGrid.AllowTitleClick: Boolean;\r\nbegin\r\n Result := Assigned(FOnTitleBtnClick) or AutoSort;\r\nend;\r\n\r\nprocedure TJvDBGrid.ColumnMoved(FromIndex, ToIndex: Integer);\r\nbegin\r\n inherited ColumnMoved(FromIndex, ToIndex);\r\n FPaintInfo.ColMoving := False;\r\n {$IFNDEF COMPILER14_UP}\r\n {$IFDEF JVCLThemesEnabled}\r\n if UseXPThemes and ThemeServices.ThemesEnabled then\r\n Invalidate;\r\n {$ENDIF JVCLThemesEnabled}\r\n {$ENDIF ~COMPILER14_UP}\r\nend;\r\n\r\nprocedure TJvDBGrid.MouseWheelHandler(var Message: TMessage);\r\nvar\r\n LastRow: Integer;\r\nbegin\r\n LastRow := Row;\r\n inherited MouseWheelHandler(Message);\r\n if (Row <> LastRow) and (DataLink <> nil) and DataLink.Active then\r\n InvalidateCell(IndicatorOffset - 1, LastRow);\r\nend;\r\n\r\nprocedure TJvDBGrid.BeginUpdate;\r\nbegin\r\n BeginLayout;\r\nend;\r\n\r\nprocedure TJvDBGrid.EndUpdate;\r\nbegin\r\n EndLayout;\r\nend;\r\n\r\nfunction TJvDBGrid.CellRect(ACol, ARow: Longint): TRect;\r\nbegin\r\n Result := inherited CellRect(ACol, ARow);\r\nend;\r\n\r\nprocedure TJvDBGrid.Notification(AComponent: TComponent; Operation: TOperation);\r\nbegin\r\n inherited Notification(AComponent, Operation);\r\n if (Operation = opRemove) and (AComponent = FCurrentControl) then\r\n begin\r\n FCurrentControl.RemoveFreeNotification(Self);\r\n FCurrentControl := nil;\r\n end;\r\nend;\r\n\r\ninitialization\r\n {$IFDEF UNITVERSIONING}\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n {$ENDIF UNITVERSIONING}\r\n\r\nfinalization\r\n {$IFNDEF SUPPORTS_CLASS_CTORDTORS}\r\n FinalizeGridBitmaps;\r\n {$ENDIF ~SUPPORTS_CLASS_CTORDTORS}\r\n\r\n {$IFDEF UNITVERSIONING}\r\n UnregisterUnitVersion(HInstance);\r\n {$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvDBGridExport.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvDBGridExport.pas, released on 2004-01-15\r\n\r\nThe Initial Developer of the Original Code is Lionel Reynaud\r\nPortions created by Lionel Reynaud are Copyright (C) 2004 Lionel Reynaud.\r\nAll Rights Reserved.\r\n\r\nContributor(s): Marc Geldon\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvDBGridExport.pas 13230 2012-02-24 16:30:12Z obones $\r\n\r\nunit JvDBGridExport;\r\n\r\n{$I jvcl.inc}\r\n{$I windowsonly.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, Classes, SysUtils, DB, DBGrids,\r\n JvComponentBase, JvSimpleXml, JvTypes;\r\n\r\ntype\r\n TExportDestination = (edFile, edClipboard);\r\n TExportSeparator = (esTab, esSemiColon, esComma, esSpace, esPipe);\r\n TWordOrientation = (woPortrait, woLandscape);\r\n\r\n EJvExportDBGridException = class(EJVCLException);\r\n TJvWordGridFormat = $10..$17;\r\n\r\n TOleServerClose = (scNever, scNewInstance, scAlways);\r\n\r\n TRecordColumn = record\r\n Visible: Boolean;\r\n Exportable: Boolean;\r\n ColumnName: string;\r\n Column: TColumn;\r\n Field: TField;\r\n end;\r\n\r\n{ avoid Office TLB imports }\r\nconst\r\n wdDoNotSaveChanges = 0;\r\n\r\n wdTableFormatGrid1 = TJvWordGridFormat($10);\r\n wdTableFormatGrid2 = TJvWordGridFormat($11);\r\n wdTableFormatGrid3 = TJvWordGridFormat($12);\r\n wdTableFormatGrid4 = TJvWordGridFormat($13);\r\n wdTableFormatGrid5 = TJvWordGridFormat($14);\r\n wdTableFormatGrid6 = TJvWordGridFormat($15);\r\n wdTableFormatGrid7 = TJvWordGridFormat($16);\r\n wdTableFormatGrid8 = TJvWordGridFormat($17);\r\n\r\n xlPortrait = $01;\r\n xlLandscape = $02;\r\n\r\ntype\r\n TJvExportProgressEvent = procedure(Sender: TObject; Min, Max, Position: Cardinal;\r\n const AText: string; var AContinue: Boolean) of object;\r\n\r\n TJvCustomDBGridExport = class(TJvComponent)\r\n private\r\n FGrid: TDBGrid;\r\n FColumnCount: Integer;\r\n FRecordColumns: array of TRecordColumn;\r\n FCaption: string;\r\n FFileName: TFileName;\r\n FOnProgress: TJvExportProgressEvent;\r\n FLastExceptionMessage: string;\r\n FSilent: Boolean;\r\n FOnException: TNotifyEvent;\r\n FUseFieldGetText: Boolean;\r\n procedure CheckVisibleColumn;\r\n protected\r\n procedure HandleException;\r\n function ExportField(AField: TField): Boolean;\r\n function DoProgress(Min, Max, Position: Cardinal; const AText: string): Boolean; virtual;\r\n function DoExport: Boolean; virtual; abstract;\r\n procedure DoSave; virtual;\r\n procedure DoClose; virtual; abstract;\r\n procedure Notification(AComponent: TComponent; Operation: TOperation); override;\r\n function GetFieldValue(const Field: TField): Variant; virtual;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n function ExportGrid: Boolean;\r\n published\r\n // (p3) these should be published: all exporters must support them\r\n property Caption: string read FCaption write FCaption;\r\n property UseFieldGetText: Boolean read FUseFieldGetText write FUseFieldGetText default False;\r\n property Grid: TDBGrid read FGrid write FGrid;\r\n property FileName: TFileName read FFileName write FFileName;\r\n property Silent: Boolean read FSilent write FSilent default True;\r\n property OnProgress: TJvExportProgressEvent read FOnProgress write FOnProgress;\r\n property OnException: TNotifyEvent read FOnException write FOnException;\r\n property LastExceptionMessage: string read FLastExceptionMessage;\r\n end;\r\n\r\n TJvCustomDBGridExportClass = class of TJvCustomDBGridExport;\r\n\r\n { TJvCustomDBGridOleExport converts any string-variant that isn't supported\r\n by OLE to an OleStr variant. }\r\n TJvCustomDBGridOleExport = class(TJvCustomDBGridExport)\r\n protected\r\n function GetFieldValue(const Field: TField): Variant; override;\r\n end;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvDBGridWordExport = class(TJvCustomDBGridOleExport)\r\n private\r\n FWord: OleVariant;\r\n FVisible: Boolean;\r\n FOrientation: TWordOrientation;\r\n FWordFormat: TJvWordGridFormat;\r\n FClose: TOleServerClose;\r\n FRunningInstance: Boolean;\r\n protected\r\n procedure DoSave; override;\r\n function DoExport: Boolean; override;\r\n procedure DoClose; override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n published\r\n property FileName;\r\n property Caption;\r\n property Grid;\r\n property OnProgress;\r\n property Close: TOleServerClose read FClose write FClose default scNewInstance;\r\n property WordFormat: TJvWordGridFormat read FWordFormat write FWordFormat default wdTableFormatGrid3;\r\n property Visible: Boolean read FVisible write FVisible default False;\r\n property Orientation: TWordOrientation read FOrientation write FOrientation default woPortrait;\r\n end;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvDBGridExcelExport = class(TJvCustomDBGridOleExport)\r\n private\r\n FExcel: OleVariant;\r\n FVisible: Boolean;\r\n FAutoFit: Boolean;\r\n FOrientation: TWordOrientation;\r\n FClose: TOleServerClose;\r\n FRunningInstance: Boolean;\r\n function IndexFieldToExcel(Index: Integer): string;\r\n protected\r\n procedure DoSave; override;\r\n function DoExport: Boolean; override;\r\n procedure DoClose; override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n published\r\n property FileName;\r\n property Caption;\r\n property Grid;\r\n property OnProgress;\r\n property Close: TOleServerClose read FClose write FClose default scNewInstance;\r\n property Visible: Boolean read FVisible write FVisible default False;\r\n property Orientation: TWordOrientation read FOrientation write FOrientation default woPortrait;\r\n property AutoFit: Boolean read FAutoFit write FAutoFit;\r\n end;\r\n\r\n TJvCustomDBGridTextExport = class(TJvCustomDBGridExport)\r\n private\r\n {$IFDEF UNICODE}\r\n FEncoding: TEncoding;\r\n {$ENDIF UNICODE}\r\n public\r\n {$IFDEF UNICODE}\r\n property Encoding: TEncoding read FEncoding write FEncoding;\r\n {$ENDIF UNICODE}\r\n end;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvDBGridHTMLExport = class(TJvCustomDBGridTextExport)\r\n private\r\n FDocument: TStrings;\r\n FDocTitle: string;\r\n FHeader: TStrings;\r\n FFooter: TStrings;\r\n FIncludeColumnHeader: Boolean;\r\n procedure SetHeader(const Value: TStrings);\r\n procedure SetFooter(const Value: TStrings);\r\n protected\r\n procedure DoSave; override;\r\n function DoExport: Boolean; override;\r\n procedure DoClose; override;\r\n procedure SetDefaultData;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n\r\n function GenerateHTMLText: string;\r\n published\r\n property FileName;\r\n property Caption;\r\n property Grid;\r\n property OnProgress;\r\n property IncludeColumnHeader: Boolean read FIncludeColumnHeader write FIncludeColumnHeader default True;\r\n property Header: TStrings read FHeader write SetHeader;\r\n property Footer: TStrings read FFooter write SetFooter;\r\n property DocTitle: string read FDocTitle write FDocTitle;\r\n end;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvDBGridCSVExport = class(TJvCustomDBGridTextExport)\r\n private\r\n FDocument: TStrings;\r\n FDestination: TExportDestination;\r\n FExportSeparator: TExportSeparator;\r\n FShowColumnName: Boolean;\r\n FQuoteEveryTime: Boolean;\r\n FSeparator: string;\r\n procedure SetExportSeparator(const Value: TExportSeparator);\r\n function SeparatorToString(ASeparator: TExportSeparator): string;\r\n procedure SetDestination(const Value: TExportDestination);\r\n protected\r\n function DoExport: Boolean; override;\r\n procedure DoSave; override;\r\n procedure DoClose; override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n\r\n property Separator: string read FSeparator write FSeparator;\r\n published\r\n property FileName;\r\n property Caption;\r\n property Grid;\r\n property OnProgress;\r\n\r\n property Destination: TExportDestination read FDestination write SetDestination default edFile;\r\n property ExportSeparator: TExportSeparator read FExportSeparator write SetExportSeparator default esTab;\r\n property ShowColumnName: Boolean read FShowColumnName write FShowColumnName default True;\r\n property QuoteEveryTime: Boolean read FQuoteEveryTime write FQuoteEveryTime default True;\r\n end;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvDBGridXMLExport = class(TJvCustomDBGridTextExport)\r\n private\r\n FXML: TJvSimpleXML;\r\n function ClassNameNoT(AField: TField): string;\r\n protected\r\n function DoExport: Boolean; override;\r\n procedure DoSave; override;\r\n procedure DoClose; override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n\r\n // accessible so that people can set options prior export (prolog in particular)\r\n property XML: TJvSimpleXML read FXML;\r\n published\r\n property FileName;\r\n property Caption;\r\n property Grid;\r\n property OnProgress;\r\n end;\r\n\r\nfunction WordGridFormatIdentToInt(const Ident: string; var Value: Longint): Boolean;\r\nfunction IntToWordGridFormatIdent(Value: Longint; var Ident: string): Boolean;\r\nprocedure GetWordGridFormatValues(Proc: TGetStrProc);\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvDBGridExport.pas $';\r\n Revision: '$Revision: 13230 $';\r\n Date: '$Date: 2012-02-24 17:30:12 +0100 (ven. 24 févr. 2012) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n Variants, ComObj, Graphics, Clipbrd,\r\n JclRegistry,\r\n JvConsts, JvResources, JclStreams;\r\n\r\n//=== { TJvCustomDBGridExport } ==============================================\r\n\r\nconstructor TJvCustomDBGridExport.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FSilent := True;\r\nend;\r\n\r\nfunction TJvCustomDBGridExport.DoProgress(Min, Max, Position: Cardinal;\r\n const AText: string): Boolean;\r\nbegin\r\n Result := True;\r\n if Assigned(FOnProgress) then\r\n FOnProgress(Self, Min, Max, Position, AText, Result);\r\nend;\r\n\r\nprocedure TJvCustomDBGridExport.DoSave;\r\nbegin\r\n if FileExists(FileName) then\r\n DeleteFile(FileName);\r\nend;\r\n\r\nfunction TJvCustomDBGridExport.ExportField(AField: TField): Boolean;\r\nbegin\r\n Result := not (AField.DataType in [ftUnknown, ftBlob, ftGraphic,\r\n ftParadoxOle, ftDBaseOle, ftTypedBinary, ftCursor, ftADT,\r\n ftArray, ftReference, ftDataSet, ftOraBlob, ftOraClob, ftVariant,\r\n ftInterface, ftIDispatch, ftGuid]);\r\nend;\r\n\r\nprocedure TJvCustomDBGridExport.CheckVisibleColumn;\r\nvar\r\n I: Integer;\r\nbegin\r\n FColumnCount := Grid.Columns.Count;\r\n SetLength(FRecordColumns, FColumnCount);\r\n for I := 0 to FColumnCount - 1 do\r\n begin\r\n FRecordColumns[I].Column := Grid.Columns[I];\r\n FRecordColumns[I].Visible := Grid.Columns[I].Visible;\r\n FRecordColumns[I].ColumnName := Grid.Columns[I].Title.Caption;\r\n FRecordColumns[I].Field := Grid.Columns[I].Field;\r\n if FRecordColumns[I].Visible and (FRecordColumns[I].Field <> nil) then\r\n FRecordColumns[I].Exportable := ExportField(FRecordColumns[I].Field)\r\n else\r\n FRecordColumns[I].Exportable := False;\r\n end;\r\nend;\r\n\r\nfunction TJvCustomDBGridExport.ExportGrid: Boolean;\r\nbegin\r\n if not Assigned(Grid) then\r\n raise EJvExportDBGridException.CreateRes(@RsEGridIsUnassigned);\r\n if not Assigned(Grid.DataSource) or not Assigned(Grid.DataSource.DataSet) then\r\n raise EJvExportDBGridException.CreateRes(@RsEDataSetDataSourceIsUnassigned);\r\n// if FileName = '' then\r\n// raise EJvExportDBGridException.Create(RsFilenameEmpty);\r\n CheckVisibleColumn;\r\n Result := DoExport;\r\n if Result then\r\n DoSave;\r\n DoClose;\r\nend;\r\n\r\nfunction TJvCustomDBGridExport.GetFieldValue(const Field: TField): Variant;\r\nvar\r\n Str: String;\r\nbegin\r\n if Assigned(Field.OnGetText) and FUseFieldGetText then\r\n begin\r\n Field.OnGetText(Field, Str, True);\r\n Result := Str;\r\n end\r\n else\r\n Result := Field.Value;\r\nend;\r\n\r\nprocedure TJvCustomDBGridExport.HandleException;\r\nbegin\r\n if ExceptObject <> nil then\r\n begin\r\n if ExceptObject is Exception then\r\n FLastExceptionMessage := Exception(ExceptObject).Message;\r\n if not Silent then\r\n raise ExceptObject at ExceptAddr\r\n else\r\n if Assigned(FOnException) then\r\n FOnException(Self);\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomDBGridExport.Notification(AComponent: TComponent;\r\n Operation: TOperation);\r\nbegin\r\n inherited Notification(AComponent, Operation);\r\n if (Operation = opRemove) and (AComponent = Grid) then\r\n Grid := nil;\r\nend;\r\n\r\n//=== { TJvCustomDBGridOleExport } ============?==============================\r\n\r\nfunction TJvCustomDBGridOleExport.GetFieldValue(const Field: TField): Variant;\r\nbegin\r\n Result := inherited GetFieldValue(Field);\r\n if VarType(Result) >= varString then // OleStr ist the only string type that is supported\r\n Result := WideString(Result);\r\nend;\r\n\r\n//=== { TJvDBGridWordExport } ================================================\r\n\r\nconstructor TJvDBGridWordExport.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n Caption := RsExportWord;\r\n FWord := Unassigned;\r\n FVisible := False;\r\n FOrientation := woPortrait;\r\n FWordFormat := wdTableFormatGrid3;\r\n FClose := scNewInstance;\r\nend;\r\n\r\ndestructor TJvDBGridWordExport.Destroy;\r\nbegin\r\n DoClose;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJvDBGridWordExport.DoExport: Boolean;\r\nconst\r\n cWordApplication = 'Word.Application';\r\nvar\r\n I, J, K: Integer;\r\n lTable: OleVariant;\r\n ARecNo, lRecCount: Integer;\r\n lColVisible: Integer;\r\n lRowCount: Integer;\r\n lBookmark: TBookmark;\r\nbegin\r\n Result := True;\r\n FRunningInstance := True;\r\n try\r\n // get running instance\r\n FWord := GetActiveOleObject(cWordApplication);\r\n except\r\n FRunningInstance := False;\r\n try\r\n // create new\r\n FWord := CreateOleObject(cWordApplication);\r\n except\r\n FWord := Unassigned;\r\n HandleException;\r\n// raise EJvExportDBGridException.Create(RsNoWordApplication);\r\n end;\r\n end;\r\n\r\n if VarIsEmpty(FWord) then\r\n begin\r\n Result := False;\r\n Exit;\r\n end;\r\n\r\n try\r\n if not FRunningInstance then\r\n FWord.Visible := FVisible;\r\n FWord.Documents.Add;\r\n\r\n lColVisible := 0;\r\n for I := 1 to FColumnCount do\r\n if Grid.Columns[I - 1].Visible then\r\n Inc(lColVisible);\r\n\r\n lRowCount := Grid.DataSource.DataSet.RecordCount;\r\n FWord.ActiveDocument.Range.Font.Name := Grid.Font.Name;\r\n FWord.ActiveDocument.Range.Font.Size := Grid.Font.Size;\r\n if Orientation = woPortrait then\r\n FWord.ActiveDocument.PageSetup.Orientation := 0\r\n else\r\n FWord.ActiveDocument.PageSetup.Orientation := 1;\r\n lTable := FWord.ActiveDocument.Tables.Add(FWord.ActiveDocument.Range, lRowCount + 1, lColVisible);\r\n FWord.ActiveDocument.Range.InsertAfter('Date ' + DateTimeToStr(Now));\r\n // (rom) This is correct Delphi. See \"positional parameters\" in the Delphi help.\r\n lTable.AutoFormat(Format := WordFormat); // FormatNum, 1, 1, 1, 1, 1, 0, 0, 0, 1\r\n\r\n K := 1;\r\n for I := 0 to FColumnCount - 1 do\r\n if FRecordColumns[I].Visible then\r\n begin\r\n lTable.Cell(1, K).Range.InsertAfter(FRecordColumns[I].ColumnName);\r\n Inc(K);\r\n end;\r\n\r\n J := 2;\r\n with Grid.DataSource.DataSet do\r\n begin\r\n lRecCount := RecordCount;\r\n ARecNo := 0;\r\n DoProgress(0, lRecCount, ARecNo, Caption);\r\n DisableControls;\r\n lBookmark := GetBookmark;\r\n First;\r\n try\r\n while not Eof do\r\n begin\r\n K := 1;\r\n for I := 0 to FColumnCount - 1 do\r\n begin\r\n if FRecordColumns[I].Exportable and not FRecordColumns[I].Field.IsNull then\r\n begin\r\n try\r\n lTable.Cell(J, K).Range.InsertAfter(GetFieldValue(FRecordColumns[I].Field));\r\n except\r\n Result := False;\r\n HandleException;\r\n // Remember problem but continue\r\n end;\r\n end;\r\n if FRecordColumns[I].Visible then\r\n Inc(K);\r\n end;\r\n Next;\r\n Inc(J);\r\n Inc(ARecNo);\r\n if not DoProgress(0, lRecCount, ARecNo, Caption) then\r\n Last;\r\n end;\r\n DoProgress(0, lRecCount, lRecCount, Caption);\r\n finally\r\n try\r\n if BookmarkValid(lBookmark) then\r\n GotoBookmark(lBookmark);\r\n except\r\n HandleException;\r\n end;\r\n if lBookmark <> nil then\r\n FreeBookmark(lBookmark);\r\n EnableControls;\r\n end;\r\n end;\r\n lTable.UpdateAutoFormat;\r\n except\r\n HandleException;\r\n Result := False;\r\n end;\r\nend;\r\n\r\nprocedure TJvDBGridWordExport.DoSave;\r\nvar\r\n lName: OleVariant;\r\nbegin\r\n inherited DoSave;\r\n if VarIsEmpty(FWord) then\r\n Exit;\r\n try\r\n lName := OleVariant(FileName);\r\n FWord.ActiveDocument.SaveAs(lName);\r\n except\r\n HandleException;\r\n end;\r\nend;\r\n\r\nprocedure TJvDBGridWordExport.DoClose;\r\nbegin\r\n if not VarIsEmpty(FWord) and (FClose <> scNever) then\r\n try\r\n if (FClose = scAlways) or not FRunningInstance then\r\n begin\r\n FWord.ActiveDocument.Close(wdDoNotSaveChanges, EmptyParam, EmptyParam);\r\n FWord.Quit;\r\n end;\r\n FWord := Unassigned;\r\n except\r\n HandleException;\r\n end;\r\nend;\r\n\r\n//=== { TJvDBGridExcelExport } ===============================================\r\n\r\nconstructor TJvDBGridExcelExport.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n Caption := RsExportExcel;\r\n FExcel := Unassigned;\r\n FVisible := False;\r\n FOrientation := woPortrait;\r\n FClose := scNewInstance;\r\nend;\r\n\r\ndestructor TJvDBGridExcelExport.Destroy;\r\nbegin\r\n DoClose;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJvDBGridExcelExport.IndexFieldToExcel(Index: Integer): string;\r\nbegin\r\n // Max column : ZZ => Index = 702\r\n if Index > 26 then\r\n Result := Chr(64 + ((Index - 1) div 26)) + Chr(65 + ((Index - 1) mod 26))\r\n else\r\n Result := Chr(64 + Index);\r\nend;\r\n\r\nfunction TJvDBGridExcelExport.DoExport: Boolean;\r\nconst\r\n cExcelApplication = 'Excel.Application';\r\nvar\r\n I, J, K: Integer;\r\n lTable: OleVariant;\r\n lCell: OleVariant;\r\n ARecNo, lRecCount: Integer;\r\n lBookmark: TBookmark;\r\nbegin\r\n Result := True;\r\n FRunningInstance := True;\r\n try\r\n // get running instance\r\n FExcel := GetActiveOleObject(cExcelApplication);\r\n except\r\n FRunningInstance := False;\r\n try\r\n // create new instance\r\n FExcel := CreateOleObject(cExcelApplication);\r\n except\r\n FExcel := Unassigned;\r\n HandleException;\r\n end;\r\n end;\r\n\r\n if VarIsEmpty(FExcel) then\r\n begin\r\n Result := False;\r\n Exit;\r\n end;\r\n try\r\n if not FRunningInstance then\r\n FExcel.Visible := Visible;\r\n FExcel.WorkBooks.Add;\r\n\r\n lTable := FExcel.ActiveWorkbook.ActiveSheet;\r\n\r\n if Orientation = woPortrait then\r\n lTable.PageSetup.Orientation := xlPortrait\r\n else\r\n lTable.PageSetup.Orientation := xlLandscape;\r\n\r\n K := 1;\r\n for I := 0 to FColumnCount - 1 do\r\n if FRecordColumns[I].Visible then\r\n begin\r\n lCell := lTable.Range[IndexFieldToExcel(K) + '1'];\r\n lCell.Value := FRecordColumns[I].ColumnName;\r\n Inc(K);\r\n end;\r\n\r\n J := 1;\r\n with Grid.DataSource.DataSet do\r\n begin\r\n ARecNo := 0;\r\n lRecCount := RecordCount;\r\n DoProgress(0, lRecCount, ARecNo, Caption);\r\n DisableControls;\r\n lBookmark := GetBookmark;\r\n First;\r\n try\r\n while not Eof do\r\n begin\r\n Inc(J);\r\n K := 1;\r\n for I := 0 to FColumnCount - 1 do\r\n begin\r\n if FRecordColumns[I].Exportable then\r\n begin\r\n lCell := lTable.Range[IndexFieldToExcel(K) + IntToStr(J)];\r\n try\r\n lCell.Value := GetFieldValue(FRecordColumns[I].Field);\r\n except\r\n Result := False;\r\n HandleException;\r\n end;\r\n end;\r\n if FRecordColumns[I].Visible then\r\n Inc(K);\r\n end;\r\n Next;\r\n Inc(ARecNo);\r\n if not DoProgress(0, lRecCount, ARecNo, Caption) then\r\n Last;\r\n end;\r\n if AutoFit then\r\n try\r\n lTable.Columns.AutoFit; // NEW! Autofit!\r\n except\r\n {$IFDEF DEBUGINFO_ON}\r\n on E: Exception do\r\n OutputDebugString(PChar('lTable.Columns.AutoFit failed. ' + E.Message));\r\n {$ENDIF DEBUGINFO_ON}\r\n end;\r\n DoProgress(0, lRecCount, lRecCount, Caption);\r\n finally\r\n try\r\n if BookmarkValid(lBookmark) then\r\n GotoBookmark(lBookmark);\r\n except\r\n HandleException;\r\n end;\r\n if lBookmark <> nil then\r\n FreeBookmark(lBookmark);\r\n EnableControls;\r\n end;\r\n end;\r\n except\r\n HandleException;\r\n Result := False;\r\n end;\r\nend;\r\n\r\nprocedure TJvDBGridExcelExport.DoSave;\r\nvar\r\n lName: OleVariant;\r\nbegin\r\n inherited DoSave;\r\n if not VarIsEmpty(FExcel) then\r\n try\r\n lName := OleVariant(FileName);\r\n FExcel.ActiveWorkbook.SaveAs(lName);\r\n except\r\n HandleException;\r\n end;\r\nend;\r\n\r\nprocedure TJvDBGridExcelExport.DoClose;\r\nbegin\r\n if not VarIsEmpty(FExcel) and (FClose = scNever) then\r\n begin\r\n FExcel.Visible := True;\r\n Exit;\r\n end;\r\n\r\n if not VarIsEmpty(FExcel) and (FClose <> scNever) then\r\n try\r\n FExcel.ActiveWorkbook.Saved := True; // Avoid Excel's save prompt\r\n if (Close = scAlways) or not FRunningInstance then\r\n begin\r\n FExcel.ActiveWorkbook.Close;\r\n FExcel.Quit;\r\n end;\r\n FExcel := Unassigned;\r\n except\r\n HandleException;\r\n end;\r\nend;\r\n\r\n//=== { TJvDBGridHTMLExport } ================================================\r\n\r\nconstructor TJvDBGridHTMLExport.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FDocument := TStringList.Create;\r\n Caption := RsExportHTML;\r\n FDocTitle := RsHTMLExportDocTitle;\r\n FHeader := TStringList.Create;\r\n FFooter := TStringList.Create;\r\n FIncludeColumnHeader := True;\r\n SetDefaultData;\r\nend;\r\n\r\ndestructor TJvDBGridHTMLExport.Destroy;\r\nbegin\r\n FFooter.Free;\r\n FHeader.Free;\r\n FDocument.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvDBGridHTMLExport.SetDefaultData;\r\nbegin\r\n Header.Add('<#TITLE>');\r\n Header.Add('');\r\n Header.Add('');\r\n\r\n Footer.Add(''); \r\nend;\r\n\r\nprocedure TJvDBGridHTMLExport.SetFooter(const Value: TStrings);\r\nbegin\r\n FFooter.Assign(Value);\r\nend;\r\n\r\nprocedure TJvDBGridHTMLExport.SetHeader(const Value: TStrings);\r\nbegin\r\n FHeader.Assign(Value);\r\nend;\r\n\r\nfunction TJvDBGridHTMLExport.GenerateHTMLText: string;\r\nbegin\r\n if not Assigned(Grid) then\r\n raise EJvExportDBGridException.CreateRes(@RsEGridIsUnassigned);\r\n if not Assigned(Grid.DataSource) or not Assigned(Grid.DataSource.DataSet) then\r\n raise EJvExportDBGridException.CreateRes(@RsEDataSetDataSourceIsUnassigned);\r\n CheckVisibleColumn;\r\n if DoExport then\r\n Result := FDocument.Text\r\n else\r\n Result := '';\r\nend;\r\n\r\nprocedure TJvDBGridHTMLExport.DoClose;\r\nbegin\r\n // do nothing\r\nend;\r\n\r\nfunction TJvDBGridHTMLExport.DoExport: Boolean;\r\nvar\r\n I: Integer;\r\n ARecNo, lRecCount: Integer;\r\n lBookmark: TBookmark;\r\n lString, lText, lHeader, lStyle: string;\r\n\r\n function AlignmentToHTML(AAlign: TAlignment): string;\r\n begin\r\n case AAlign of\r\n taLeftJustify:\r\n Result := 'left';\r\n taRightJustify:\r\n Result := 'right';\r\n taCenter:\r\n Result := 'center';\r\n end;\r\n end;\r\n\r\n function ColorToHTML(AColor: TColor): string;\r\n var\r\n r, g, b: byte;\r\n begin\r\n AColor := ColorToRGB(AColor);\r\n r := GetRValue(AColor);\r\n g := GetGValue(AColor);\r\n b := GetBValue(AColor);\r\n Result := Format('%.2x%.2x%.2x', [r, g, b]);\r\n end;\r\n\r\n function FontSubstitute(const Name: string): string;\r\n const\r\n cFontKey: array [Boolean] of PChar =\r\n ('SOFTWARE\\Microsoft\\Windows\\CurrentVersion\\FontSubstitutes',\r\n 'SOFTWARE\\Microsoft\\Windows NT\\CurrentVersion\\FontSubstitutes');\r\n begin\r\n Result := RegReadStringDef(HKLM,\r\n cFontKey[Win32Platform = VER_PLATFORM_WIN32_NT], Name, Name);\r\n end;\r\n\r\n function FontSizeToHTML(PtSize: Integer): Integer;\r\n begin\r\n case Abs(PtSize) of\r\n 0..8:\r\n Result := 1;\r\n 9..10:\r\n Result := 2;\r\n 11..12:\r\n Result := 3;\r\n 13..17:\r\n Result := 4;\r\n 18..23:\r\n Result := 5;\r\n 24..35:\r\n Result := 6;\r\n else\r\n Result := 7;\r\n end;\r\n end;\r\n\r\n function FontToHTML(AFont: TFont; EncloseText: string): string;\r\n begin\r\n if fsBold in AFont.Style then\r\n EncloseText := '' + EncloseText + '';\r\n if fsItalic in AFont.Style then\r\n EncloseText := '' + EncloseText + '';\r\n if fsUnderline in AFont.Style then\r\n EncloseText := '' + EncloseText + '';\r\n if fsStrikeout in AFont.Style then\r\n EncloseText := '' + EncloseText + '';\r\n Result := Format('%s',\r\n [FontSubstitute(AFont.Name), ColorToHTML(AFont.Color), FontSizeToHTML(AFont.Size), EncloseText]);\r\n end;\r\n\r\n function FontStyleToHTML(AFont: TFont): string;\r\n begin\r\n Result := '';\r\n if fsBold in AFont.Style then\r\n Result := 'FONT-WEIGHT: bold; ';\r\n if fsItalic in AFont.Style then\r\n Result := Result + 'FONT-STYLE: italic; ';\r\n if fsUnderline in AFont.Style then\r\n if fsStrikeout in AFont.Style then\r\n Result := Result + 'TEXT-DECORATION: underline line-through; '\r\n else\r\n Result := Result + 'TEXT-DECORATION: underline; '\r\n else\r\n if fsStrikeout in AFont.Style then\r\n Result := Result + 'TEXT-DECORATION: line-through; ';\r\n end;\r\n\r\nbegin\r\n FDocument.Clear;\r\n\r\n Result := True;\r\n try\r\n // Create Style like :\r\n //.Column0 {FONT-FAMILY: Arial; FONT-SIZE: 12px; FONT-WEIGHT: bold; FONT-STYLE: italic\r\n // TEXT-ALIGN: right; COLOR: #FFFFFF; BACKGROUND: #9924A7}\r\n\r\n lStyle := '';\r\n lString := '';\r\n for I := 0 to FColumnCount - 1 do\r\n if FRecordColumns[I].Visible then\r\n with FRecordColumns[I].Column do\r\n begin\r\n lString := lString + Format('%s',\r\n [ColorToHTML(Title.Color), AlignmentToHTML(Alignment), FontToHTML(Title.Font, Title.Caption)]);\r\n lStyle := lStyle +\r\n Format('.Column%d {FONT-FAMILY: %s; FONT-SIZE: %dpt; %s TEXT-ALIGN: %s; COLOR: #%s; BACKGROUND: #%s;}'#13#10,\r\n [I, FontSubstitute(Font.Name), Font.Size, FontStyleToHTML(Font),\r\n AlignmentToHTML(Alignment), ColorToHTML(Font.Color), ColorToHTML(Color)]);\r\n end;\r\n lString := lString + '';\r\n lHeader := StringReplace(Header.Text, '<#TITLE>', DocTitle, [rfReplaceAll, rfIgnoreCase]);\r\n lHeader := StringReplace(lHeader, '#STYLE', lStyle, [rfReplaceAll, rfIgnoreCase]);\r\n\r\n FDocument.Add(lHeader);\r\n FDocument.Add('');\r\n if IncludeColumnHeader then\r\n FDocument.Add(lString);\r\n\r\n with Grid.DataSource.DataSet do\r\n begin\r\n ARecNo := 0;\r\n lRecCount := RecordCount;\r\n DoProgress(0, lRecCount, ARecNo, Caption);\r\n DisableControls;\r\n lBookmark := GetBookmark;\r\n First;\r\n try\r\n while not Eof do\r\n begin\r\n lString := '';\r\n for I := 0 to FColumnCount - 1 do\r\n with FRecordColumns[I] do\r\n if Visible then\r\n begin\r\n if Exportable and not Field.IsNull then\r\n try\r\n lText := GetFieldValue(Field);\r\n if lText = '' then\r\n lText := ' ';\r\n except\r\n Result := False;\r\n HandleException;\r\n end\r\n else\r\n lText := ' ';\r\n\r\n lString := lString + Format('',\r\n [I, lText]);\r\n end;\r\n lString := lString + '';\r\n FDocument.Add(lString);\r\n Next;\r\n if not DoProgress(0, lRecCount, ARecNo, Caption) then\r\n Last;\r\n end;\r\n FDocument.Add('
%s
');\r\n FDocument.AddStrings(Footer);\r\n DoProgress(0, lRecCount, lRecCount, Caption);\r\n finally\r\n try\r\n if BookmarkValid(lBookmark) then\r\n GotoBookmark(lBookmark);\r\n except\r\n HandleException;\r\n end;\r\n if lBookmark <> nil then\r\n FreeBookmark(lBookmark);\r\n EnableControls;\r\n end;\r\n end;\r\n except\r\n HandleException;\r\n Result := False;\r\n end;\r\nend;\r\n\r\nprocedure TJvDBGridHTMLExport.DoSave;\r\nbegin\r\n inherited DoSave;\r\n FDocument.SaveToFile(FileName {$IFDEF UNICODE}, Encoding{$ENDIF});\r\nend;\r\n\r\n//=== { TJvDBGridCSVExport } =================================================\r\n\r\nconstructor TJvDBGridCSVExport.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FDocument := TStringList.Create;\r\n FDestination := edFile;\r\n ExportSeparator := esTab;\r\n Caption := RsExportFile;\r\n FShowColumnName := True;\r\n FQuoteEveryTime := True;\r\nend;\r\n\r\ndestructor TJvDBGridCSVExport.Destroy;\r\nbegin\r\n FDocument.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJvDBGridCSVExport.SeparatorToString(ASeparator: TExportSeparator): string;\r\nbegin\r\n case ASeparator of\r\n esTab:\r\n Result := Tab;\r\n esSemiColon:\r\n Result := ';';\r\n esComma:\r\n Result := ',';\r\n esSpace:\r\n Result := ' ';\r\n esPipe:\r\n Result := '|';\r\n end;\r\nend;\r\n\r\nprocedure TJvDBGridCSVExport.SetExportSeparator(const Value: TExportSeparator);\r\nbegin\r\n FExportSeparator := Value;\r\n Separator := SeparatorToString(FExportSeparator);\r\nend;\r\n\r\nprocedure TJvDBGridCSVExport.SetDestination(const Value: TExportDestination);\r\nbegin\r\n FDestination := Value;\r\n if FDestination = edFile then\r\n Caption := RsExportFile\r\n else\r\n Caption := RsExportClipboard;\r\nend;\r\n\r\nfunction TJvDBGridCSVExport.DoExport: Boolean;\r\nvar\r\n I: Integer;\r\n ARecNo, lRecCount: Integer;\r\n lBookmark: TBookmark;\r\n lString, lField: string;\r\nbegin\r\n FDocument.Clear;\r\n Result := True;\r\n try\r\n if ShowColumnName then\r\n begin\r\n lString := '';\r\n for I := 0 to FColumnCount - 1 do\r\n if FRecordColumns[I].Visible then\r\n if lString = '' then\r\n lString := FRecordColumns[I].ColumnName\r\n else\r\n lString := lString + Separator + FRecordColumns[I].ColumnName;\r\n FDocument.Add(lString);\r\n end;\r\n\r\n with Grid.DataSource.DataSet do\r\n begin\r\n ARecNo := 0;\r\n lRecCount := RecordCount;\r\n DoProgress(0, lRecCount, ARecNo, Caption);\r\n DisableControls;\r\n lBookmark := GetBookmark;\r\n First;\r\n try\r\n while not Eof do\r\n begin\r\n lString := '';\r\n for I := 0 to FColumnCount - 1 do\r\n begin\r\n if FRecordColumns[I].Exportable then\r\n begin\r\n try\r\n if not FRecordColumns[I].Field.IsNull then\r\n begin\r\n lField := GetFieldValue(FRecordColumns[I].Field);\r\n if (Pos(Separator, lField) <> 0) or (FQuoteEveryTime) then\r\n lString := lString + AnsiQuotedStr(lField, '\"')\r\n else\r\n lString := lString + lField;\r\n end;\r\n except\r\n Result := False;\r\n HandleException;\r\n end;\r\n end;\r\n if FRecordColumns[I].Visible then\r\n lString := lString + Separator;\r\n end;\r\n FDocument.Add(lString);\r\n Next;\r\n Inc(ARecNo);\r\n if not DoProgress(0, lRecCount, ARecNo, Caption) then\r\n Last;\r\n end;\r\n DoProgress(0, lRecCount, lRecCount, Caption);\r\n finally\r\n try\r\n if BookmarkValid(lBookmark) then\r\n GotoBookmark(lBookmark);\r\n except\r\n HandleException;\r\n end;\r\n if lBookmark <> nil then\r\n FreeBookmark(lBookmark);\r\n EnableControls;\r\n end;\r\n end;\r\n except\r\n HandleException;\r\n Result := False;\r\n end;\r\nend;\r\n\r\nprocedure TJvDBGridCSVExport.DoSave;\r\nbegin\r\n inherited DoSave;\r\n if Destination = edFile then\r\n FDocument.SaveToFile(FileName {$IFDEF UNICODE}, Encoding{$ENDIF})\r\n else\r\n Clipboard.AsText := FDocument.Text;\r\nend;\r\n\r\nprocedure TJvDBGridCSVExport.DoClose;\r\nbegin\r\n // do nothing\r\nend;\r\n\r\n//=== { TJvDBGridXMLExport } =================================================\r\n\r\nconstructor TJvDBGridXMLExport.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FXML := TJvSimpleXML.Create(nil);\r\n FXML.Options := [sxoAutoCreate, sxoAutoIndent];\r\nend;\r\n\r\ndestructor TJvDBGridXMLExport.Destroy;\r\nbegin\r\n FXML.Free;\r\n inherited Destroy;\r\nend;\r\n\r\n// From DSDEfine of Delphi designer\r\n\r\nfunction TJvDBGridXMLExport.ClassNameNoT(AField: TField): string;\r\nbegin\r\n Result := AField.ClassName;\r\n if Result[1] = 'T' then\r\n Delete(Result, 1, 1);\r\n if SameText('Field', Copy(Result, Length(Result) - 4, 5)) then { do not localize }\r\n Delete(Result, Length(Result) - 4, 5);\r\nend;\r\n\r\n// The structure of the xml file is inspired of the xml export\r\n// create by Delphi with TClientDataSet\r\n\r\nfunction TJvDBGridXMLExport.DoExport: Boolean;\r\nvar\r\n I: Integer;\r\n ARecNo, lRecCount: Integer;\r\n lBookmark: TBookmark;\r\n lRootNode: TJvSimpleXmlElemClassic;\r\n lDataNode: TJvSimpleXmlElem;\r\n lFieldsNode: TJvSimpleXmlElem;\r\n lRecordNode: TJvSimpleXmlElem;\r\nbegin\r\n Result := True;\r\n FXML.Root.Clear;\r\n\r\n // create root node\r\n FXML.Root.Name := 'DATAPACKET';\r\n lRootNode := FXML.Root;\r\n lRootNode.Properties.Add('Version', '1.0'); // This is the first implementation !\r\n\r\n // add column header and his property\r\n lDataNode := lRootNode.Items.Add('METADATA');\r\n lFieldsNode := lDataNode.Items.Add('FIELDS');\r\n for I := 0 to FColumnCount - 1 do\r\n with FRecordColumns[I] do\r\n if Visible and (Field <> nil) then\r\n begin\r\n with lFieldsNode.Items.Add('FIELD') do\r\n begin\r\n Properties.Add('ATTRNAME', ColumnName);\r\n Properties.Add('FIELDTYPE', ClassNameNoT(Field));\r\n Properties.Add('WIDTH', Column.Width);\r\n end;\r\n end;\r\n\r\n // now add all the record\r\n lRecordNode := lRootNode.Items.Add('ROWDATA');\r\n try\r\n with Grid.DataSource.DataSet do\r\n begin\r\n ARecNo := 0;\r\n lRecCount := RecordCount;\r\n DoProgress(0, lRecCount, ARecNo, Caption);\r\n DisableControls;\r\n lBookmark := GetBookmark;\r\n First;\r\n try\r\n while not Eof do\r\n begin\r\n with lRecordNode.Items.Add('ROW') do\r\n begin\r\n for I := 0 to FColumnCount - 1 do\r\n if FRecordColumns[I].Exportable then\r\n begin\r\n try\r\n Properties.Add(FRecordColumns[I].ColumnName, VarToStr(GetFieldValue(FRecordColumns[I].Field)));\r\n except\r\n Result := False;\r\n HandleException;\r\n end\r\n end;\r\n end;\r\n Next;\r\n Inc(ARecNo);\r\n if not DoProgress(0, lRecCount, ARecNo, Caption) then\r\n Last;\r\n end;\r\n DoProgress(0, lRecCount, lRecCount, Caption);\r\n finally\r\n try\r\n if BookmarkValid(lBookmark) then\r\n GotoBookmark(lBookmark);\r\n except\r\n HandleException;\r\n end;\r\n if lBookmark <> nil then\r\n FreeBookmark(lBookmark);\r\n EnableControls;\r\n end;\r\n end;\r\n except\r\n HandleException;\r\n Result := False;\r\n end;\r\nend;\r\n\r\nprocedure TJvDBGridXMLExport.DoSave;\r\nvar\r\n XmlEncoding: TJclStringEncoding;\r\nbegin\r\n inherited DoSave;\r\n XmlEncoding := seAuto;\r\n {$IFDEF UNICODE}\r\n if Encoding <> nil then\r\n begin\r\n if Encoding is TMBCSEncoding then\r\n XmlEncoding := seAnsi\r\n else\r\n if Encoding is TUTF8Encoding then\r\n XmlEncoding := seUTF8\r\n else\r\n if Encoding is TUnicodeEncoding then\r\n XmlEncoding := seUTF16;\r\n end;\r\n {$ENDIF UNICODE}\r\n FXML.SaveToFile(FileName, XmlEncoding);\r\nend;\r\n\r\nprocedure TJvDBGridXMLExport.DoClose;\r\nbegin\r\n // do nothing\r\nend;\r\n\r\n//============================================================================\r\n\r\ntype\r\n TGridValue = packed record\r\n Value: Integer;\r\n Name: PChar;\r\n end;\r\n\r\nconst\r\n GridFormats: array [$10..$17] of TGridValue =\r\n ((Value: $10; Name: 'wdTableFormatGrid1'),\r\n (Value: $11; Name: 'wdTableFormatGrid2'),\r\n (Value: $12; Name: 'wdTableFormatGrid3'),\r\n (Value: $13; Name: 'wdTableFormatGrid4'),\r\n (Value: $14; Name: 'wdTableFormatGrid5'),\r\n (Value: $15; Name: 'wdTableFormatGrid6'),\r\n (Value: $16; Name: 'wdTableFormatGrid7'),\r\n (Value: $17; Name: 'wdTableFormatGrid8'));\r\n\r\nfunction WordGridFormatIdentToInt(const Ident: string; var Value: Longint): Boolean;\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := Low(GridFormats) to High(GridFormats) do\r\n if SameText(GridFormats[I].Name, Ident) then\r\n begin\r\n Result := True;\r\n Value := GridFormats[I].Value;\r\n Exit;\r\n end;\r\n Result := False;\r\nend;\r\n\r\nfunction IntToWordGridFormatIdent(Value: Longint; var Ident: string): Boolean;\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := Low(GridFormats) to High(GridFormats) do\r\n if GridFormats[I].Value = Value then\r\n begin\r\n Result := True;\r\n Ident := GridFormats[I].Name;\r\n Exit;\r\n end;\r\n Result := False;\r\nend;\r\n\r\nprocedure GetWordGridFormatValues(Proc: TGetStrProc);\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := Low(GridFormats) to High(GridFormats) do\r\n Proc(GridFormats[I].Name);\r\nend;\r\n\r\ninitialization\r\n {$IFDEF UNITVERSIONING}\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n {$ENDIF UNITVERSIONING}\r\n RegisterIntegerConsts(TypeInfo(TJvWordGridFormat), WordGridFormatIdentToInt, IntToWordGridFormatIdent);\r\n\r\n{$IFDEF UNITVERSIONING}\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvDBGridFooter.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvDBGridFooter.PAS, released on 2004-08-13.\r\n\r\nThe Initial Developers of the Original Code are: Frdric Leneuf-Magaud\r\nCopyright (c) 2004 Frdric Leneuf-Magaud\r\nAll Rights Reserved.\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\n-----------------------------------------------------------------------------\r\nHOW TO USE THIS COMPONENT:\r\n-----------------------------------------------------------------------------\r\n\r\n- Put a JvDBGrid or JvDBUltimGrid onto your form;\r\n- Link this component to your grid with the DBGrid property (the DataSource\r\n property is automatically set);\r\n- Open the columns property editor;\r\n- Add any column you need and set the Fieldname property for every column;\r\n- Assign the OnCalculate event to your calculation function.\r\n\r\n-----------------------------------------------------------------------------\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvDBGridFooter.pas 13104 2011-09-07 06:50:43Z obones $\r\n\r\nunit JvDBGridFooter;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n {$IFDEF MSWINDOWS}\r\n Windows, // inline\r\n {$ENDIF MSWINDOWS}\r\n Variants, SysUtils, Classes, ComCtrls,\r\n DB, DBGrids, Grids, JvDBGrid;\r\n\r\ntype\r\n TJvDBGridFooter = class;\r\n\r\n TFooterDataLink = class(TDataLink)\r\n private\r\n FGridFooter: TJvDBGridFooter;\r\n protected\r\n procedure ActiveChanged; override;\r\n procedure DataSetChanged; override;\r\n procedure DataSetScrolled(Distance: Integer); override;\r\n procedure LayoutChanged; override;\r\n public\r\n constructor Create(AFooter: TJvDBGridFooter);\r\n destructor Destroy; override;\r\n end;\r\n\r\n TFooterColumn = class(TCollectionItem)\r\n private\r\n FAlignment: TAlignment;\r\n FBevel: TStatusPanelBevel;\r\n FBiDiMode: TBiDiMode;\r\n FDisplayMask: string;\r\n FFieldName: string;\r\n FParentBiDiMode: Boolean;\r\n FStyle: TStatusPanelStyle;\r\n FWidthIfIgnore: Integer;\r\n FCurrentValue: Variant;\r\n procedure SetAlignment(Value: TAlignment);\r\n procedure SetBevel(Value: TStatusPanelBevel);\r\n procedure SetBiDiMode(Value: TBiDiMode);\r\n procedure SetDisplayMask(Value: string);\r\n procedure SetFieldName(Value: string);\r\n procedure SetParentBiDiMode(Value: Boolean);\r\n procedure SetStyle(Value: TStatusPanelStyle);\r\n procedure SetWidthIfIgnore(Value: Integer);\r\n protected\r\n function GetDisplayName: string; override;\r\n public\r\n constructor Create(Collection: TCollection); override;\r\n procedure Assign(Source: TPersistent); override;\r\n published\r\n property Alignment: TAlignment read FAlignment write SetAlignment default taCenter;\r\n property Bevel: TStatusPanelBevel read FBevel write SetBevel default pbLowered;\r\n property BiDiMode: TBiDiMode read FBiDiMode write SetBiDiMode default bdLeftToRight;\r\n property DisplayMask: string read FDisplayMask write SetDisplayMask;\r\n property FieldName: string read FFieldName write SetFieldName;\r\n property ParentBiDiMode: Boolean read FParentBiDiMode write SetParentBiDiMode\r\n default True;\r\n property Style: TStatusPanelStyle read FStyle write SetStyle default psText;\r\n property WidthIfIgnore: Integer read FWidthIfIgnore write SetWidthIfIgnore default 64;\r\n end;\r\n\r\n TFooterColumns = class(TCollection)\r\n private\r\n FFooterBar: TJvDBGridFooter;\r\n function GetItem(Index: Integer): TFooterColumn;\r\n procedure SetItem(Index: Integer; Value: TFooterColumn);\r\n protected\r\n function GetOwner: TPersistent; override;\r\n procedure Update(Item: TCollectionItem); override;\r\n public\r\n constructor Create(FooterBar: TJvDBGridFooter);\r\n function Add: TFooterColumn;\r\n property Items[Index: Integer]: TFooterColumn read GetItem write SetItem;\r\n end;\r\n\r\n TCalculateEvent = procedure(Sender: TJvDBGridFooter; const FieldName: string;\r\n var CalcValue: Variant) of object;\r\n TDisplayTextEvent = procedure(Sender: TJvDBGridFooter; Column: TFooterColumn;\r\n const Value: Variant; var Text: string) of object;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvDBGridFooter = class(TStatusBar)\r\n private\r\n FColumns: TFooterColumns;\r\n FDataLink: TFooterDataLink;\r\n FDBGrid: TJvDBGrid;\r\n FIgnoreHorzScrolling: Boolean;\r\n FIgnoreResizing: Boolean;\r\n FOnCalculate: TCalculateEvent;\r\n FOnDisplayText: TDisplayTextEvent;\r\n\r\n FJvDBGridLayoutChangeLink: TJvDBGridLayoutChangeLink;\r\n\r\n procedure SetColumns(Value: TFooterColumns);\r\n function GetDataSource: TDataSource;\r\n procedure SetDataSource(Value: TDataSource);\r\n procedure SetDBGrid(Value: TJvDBGrid);\r\n procedure SetIgnoreHorzScrolling(Value: Boolean);\r\n procedure SetIgnoreResizing(Value: Boolean);\r\n protected\r\n procedure JvDBGridLayoutChanged(Grid: TJvDBGrid; Kind: TJvDBGridLayoutChangeKind); dynamic;\r\n\r\n procedure DrawPanels; dynamic;\r\n procedure Notification(AComponent: TComponent; Operation: TOperation); override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n\r\n procedure ReCalc;\r\n published\r\n property Columns: TFooterColumns read FColumns write SetColumns;\r\n property DataSource: TDataSource read GetDataSource write SetDataSource;\r\n property DBGrid: TJvDBGrid read FDBGrid write SetDBGrid;\r\n property IgnoreHorzScrolling: Boolean read FIgnoreHorzScrolling\r\n write SetIgnoreHorzScrolling default False;\r\n property IgnoreResizing: Boolean read FIgnoreResizing write SetIgnoreResizing\r\n default False;\r\n property Panels stored False; // This property of TStatusBar is hidden\r\n property SizeGrip default False;\r\n property OnCalculate: TCalculateEvent read FOnCalculate write FOnCalculate;\r\n property OnDisplayText: TDisplayTextEvent read FOnDisplayText write FOnDisplayText;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvDBGridFooter.pas $';\r\n Revision: '$Revision: 13104 $';\r\n Date: '$Date: 2011-09-07 08:50:43 +0200 (mer. 07 sept. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n JvJVCLUtils;\r\n\r\n{ TFooterColumn }\r\n\r\nconstructor TFooterColumn.Create(Collection: TCollection);\r\nbegin\r\n inherited Create(Collection);\r\n FAlignment := taCenter;\r\n FBevel := pbLowered;\r\n FBiDiMode := bdLeftToRight;\r\n FDisplayMask := '';\r\n FFieldName := '';\r\n FParentBiDiMode := True;\r\n FStyle := psText;\r\n FWidthIfIgnore := 64;\r\n FCurrentValue := Null;\r\nend;\r\n\r\nprocedure TFooterColumn.Assign(Source: TPersistent);\r\nbegin\r\n if Source is TFooterColumn then\r\n begin\r\n Alignment := TFooterColumn(Source).Alignment;\r\n Bevel := TFooterColumn(Source).Bevel;\r\n BiDiMode := TFooterColumn(Source).BiDiMode;\r\n DisplayMask := TFooterColumn(Source).DisplayMask;\r\n FieldName := TFooterColumn(Source).FieldName;\r\n ParentBiDiMode := TFooterColumn(Source).ParentBiDiMode;\r\n Style := TFooterColumn(Source).Style;\r\n WidthIfIgnore := TFooterColumn(Source).WidthIfIgnore;\r\n end\r\n else\r\n inherited Assign(Source);\r\nend;\r\n\r\nfunction TFooterColumn.GetDisplayName: string;\r\nbegin\r\n Result := FieldName;\r\n if Result = '' then\r\n Result := inherited GetDisplayName;\r\nend;\r\n\r\nprocedure TFooterColumn.SetAlignment(Value: TAlignment);\r\nbegin\r\n if FAlignment <> Value Then\r\n begin\r\n FAlignment := Value;\r\n Changed(False);\r\n end;\r\nend;\r\n\r\nprocedure TFooterColumn.SetBevel(Value: TStatusPanelBevel);\r\nbegin\r\n if FBevel <> Value Then\r\n begin\r\n FBevel := Value;\r\n Changed(False);\r\n end;\r\nend;\r\n\r\nprocedure TFooterColumn.SetBiDiMode(Value: TBiDiMode);\r\nbegin\r\n if FBiDiMode <> Value Then\r\n begin\r\n FBiDiMode := Value;\r\n Changed(False);\r\n end;\r\nend;\r\n\r\nprocedure TFooterColumn.SetDisplayMask(Value: string);\r\nbegin\r\n if FDisplayMask <> Value Then\r\n begin\r\n FDisplayMask := Value;\r\n Changed(False);\r\n end;\r\nend;\r\n\r\nprocedure TFooterColumn.SetFieldName(Value: string);\r\nbegin\r\n if FFieldName <> Value Then\r\n begin\r\n FFieldName := Value;\r\n FCurrentValue := Null;\r\n Changed(False);\r\n end;\r\nend;\r\n\r\nprocedure TFooterColumn.SetParentBiDiMode(Value: Boolean);\r\nbegin\r\n if FParentBiDiMode <> Value Then\r\n begin\r\n FParentBiDiMode := Value;\r\n Changed(False);\r\n end;\r\nend;\r\n\r\nprocedure TFooterColumn.SetStyle(Value: TStatusPanelStyle);\r\nbegin\r\n if FStyle <> Value Then\r\n begin\r\n FStyle := Value;\r\n Changed(False);\r\n end;\r\nend;\r\n\r\nprocedure TFooterColumn.SetWidthIfIgnore(Value: Integer);\r\nbegin\r\n if FWidthIfIgnore <> Value Then\r\n begin\r\n FWidthIfIgnore := Value;\r\n Changed(False);\r\n end;\r\nend;\r\n\r\n{ TFooterColumns }\r\n\r\nconstructor TFooterColumns.Create(FooterBar: TJvDBGridFooter);\r\nbegin\r\n inherited Create(TFooterColumn);\r\n FFooterBar := FooterBar;\r\nend;\r\n\r\nfunction TFooterColumns.Add: TFooterColumn;\r\nbegin\r\n Result := TFooterColumn(inherited Add);\r\nend;\r\n\r\nfunction TFooterColumns.GetOwner: TPersistent;\r\nbegin\r\n Result := FFooterBar;\r\nend;\r\n\r\nprocedure TFooterColumns.Update(Item: TCollectionItem);\r\nbegin\r\n FFooterBar.DrawPanels;\r\nend;\r\n\r\nfunction TFooterColumns.GetItem(Index: Integer): TFooterColumn;\r\nbegin\r\n Result := TFooterColumn(inherited GetItem(Index));\r\nend;\r\n\r\nprocedure TFooterColumns.SetItem(Index: Integer; Value: TFooterColumn);\r\nbegin\r\n inherited SetItem(Index, Value);\r\nend;\r\n\r\n{ TFooterDataLink }\r\n\r\nconstructor TFooterDataLink.Create(AFooter: TJvDBGridFooter);\r\nbegin\r\n inherited Create;\r\n FGridFooter := AFooter;\r\n VisualControl := True;\r\nend;\r\n\r\ndestructor TFooterDataLink.Destroy;\r\nbegin\r\n FGridFooter := nil;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TFooterDataLink.DataSetScrolled(Distance: Integer);\r\nbegin\r\n// Don't remove this empty procedure. It prevents DataSetChanged\r\n// from recalculating the footer values for every cursor move.\r\nend;\r\n\r\nprocedure TFooterDataLink.ActiveChanged;\r\nbegin\r\n DataSetChanged;\r\nend;\r\n\r\nprocedure TFooterDataLink.DataSetChanged;\r\nbegin\r\n if FGridFooter <> nil then\r\n FGridFooter.ReCalc;\r\nend;\r\n\r\nprocedure TFooterDataLink.LayoutChanged;\r\nbegin\r\n if FGridFooter <> nil then\r\n FGridFooter.DrawPanels;\r\nend;\r\n\r\n{ TJvDBGridFooter }\r\n\r\nconstructor TJvDBGridFooter.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n\r\n FJvDBGridLayoutChangeLink := TJvDBGridLayoutChangeLink.Create;\r\n FJvDBGridLayoutChangeLink.OnChange := JvDBGridLayoutChanged;\r\n\r\n FColumns := TFooterColumns.Create(Self);\r\n FDataLink := TFooterDataLink.Create(Self);\r\nend;\r\n\r\ndestructor TJvDBGridFooter.Destroy;\r\nbegin\r\n SetDBGrid(nil);\r\n FJvDBGridLayoutChangeLink.Free;\r\n\r\n FDataLink.Free;\r\n FDataLink := nil;\r\n FColumns.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvDBGridFooter.SetColumns(Value: TFooterColumns);\r\nbegin\r\n FColumns.Assign(Value);\r\nend;\r\n\r\nfunction TJvDBGridFooter.GetDataSource: TDataSource;\r\nbegin\r\n Result := FDataLink.DataSource;\r\nend;\r\n\r\nprocedure TJvDBGridFooter.SetDataSource(Value: TDataSource);\r\nbegin\r\n if Assigned(DBGrid) then\r\n if Value <> DBGrid.DataSource then\r\n Value := DBGrid.DataSource;\r\n FDataLink.DataSource := Value;\r\nend;\r\n\r\nprocedure TJvDBGridFooter.SetDBGrid(Value: TJvDBGrid);\r\nbegin\r\n if FDBGrid <> Value then\r\n begin\r\n if FDBGrid <> nil then\r\n FDBGrid.UnregisterLayoutChangeLink(FJvDBGridLayoutChangeLink);\r\n ReplaceComponentReference(Self, Value, TComponent(FDBGrid));\r\n if FDBGrid <> nil then\r\n begin\r\n DataSource := FDBGrid.DataSource;\r\n FDBGrid.RegisterLayoutChangeLink(FJvDBGridLayoutChangeLink);\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvDBGridFooter.SetIgnoreHorzScrolling(Value: Boolean);\r\nbegin\r\n if FIgnoreHorzScrolling <> Value then\r\n begin\r\n FIgnoreHorzScrolling := Value;\r\n DrawPanels;\r\n end;\r\nend;\r\n\r\nprocedure TJvDBGridFooter.SetIgnoreResizing(Value: Boolean);\r\nbegin\r\n if FIgnoreResizing <> Value then\r\n begin\r\n FIgnoreResizing := Value;\r\n DrawPanels;\r\n end;\r\nend;\r\n\r\nprocedure TJvDBGridFooter.JvDBGridLayoutChanged(Grid: TJvDBGrid; Kind: TJvDBGridLayoutChangeKind);\r\nbegin\r\n case Kind of\r\n lcLayoutChanged:\r\n DrawPanels;\r\n lcSizeChanged:\r\n DrawPanels;\r\n lcTopLeftChanged:\r\n DrawPanels;\r\n end;\r\nend;\r\n\r\nprocedure TJvDBGridFooter.Notification(AComponent: TComponent; Operation: TOperation);\r\nbegin\r\n inherited Notification(AComponent, Operation);\r\n if (Operation = opRemove) and (AComponent = FDBGrid) then\r\n SetDBGrid(nil);\r\nend;\r\n\r\nprocedure TJvDBGridFooter.ReCalc;\r\nvar\r\n C: Integer;\r\nbegin\r\n for C := 0 to Columns.Count - 1 do\r\n if FDataLink.Active and Assigned(OnCalculate) then\r\n OnCalculate(Self, Columns.Items[C].FieldName, Columns.Items[C].FCurrentValue)\r\n else\r\n Columns.Items[C].FCurrentValue := Null;\r\n DrawPanels;\r\nend;\r\n\r\nprocedure TJvDBGridFooter.DrawPanels;\r\n\r\n procedure CreatePanel(const GCol: Integer);\r\n var\r\n C: Integer;\r\n Found: Boolean;\r\n CurrentValue: Variant;\r\n NewText: string;\r\n begin\r\n if DBGrid.Columns[GCol].Visible then\r\n with Panels.Add do\r\n begin\r\n Found := False;\r\n for C := 0 to Columns.Count - 1 do\r\n if AnsiSameText(Columns.Items[C].FieldName, DBGrid.Columns[GCol].FieldName) then\r\n begin\r\n Found := True;\r\n Alignment := Columns.Items[C].Alignment;\r\n Bevel := Columns.Items[C].Bevel;\r\n BiDiMode := Columns.Items[C].BiDiMode;\r\n ParentBiDiMode := Columns.Items[C].ParentBiDiMode;\r\n Style := Columns.Items[C].Style;\r\n CurrentValue := Columns.Items[C].FCurrentValue;\r\n if (CurrentValue = Null) and Assigned(OnCalculate) then\r\n OnCalculate(Self, Columns.Items[C].FieldName, CurrentValue);\r\n if CurrentValue = Null then\r\n Text := ''\r\n else\r\n if Trim(Columns.Items[C].DisplayMask) <> '' then\r\n begin\r\n case VarType(CurrentValue) of\r\n varSmallint,\r\n varInteger:\r\n Text := Format(Columns.Items[C].DisplayMask, [Integer(CurrentValue)]);\r\n varSingle,\r\n varDouble:\r\n Text := Format(Columns.Items[C].DisplayMask, [Double(CurrentValue)]);\r\n varCurrency:\r\n Text := Format(Columns.Items[C].DisplayMask, [Currency(CurrentValue)]);\r\n varDate:\r\n Text := Format(Columns.Items[C].DisplayMask, [TDateTime(CurrentValue)]);\r\n else\r\n Text := string(CurrentValue);\r\n end;\r\n end\r\n else\r\n Text := string(CurrentValue);\r\n if IgnoreResizing then\r\n Width := Columns.Items[C].WidthIfIgnore\r\n else\r\n Width := DBGrid.Columns[GCol].Width;\r\n if Assigned(OnDisplayText) then\r\n begin\r\n NewText := Text;\r\n OnDisplayText(Self, Columns.Items[C], CurrentValue, NewText);\r\n Text := NewText;\r\n end;\r\n Break;\r\n end;\r\n if not Found then\r\n begin\r\n Bevel := pbNone;\r\n Style := psText;\r\n Text := '';\r\n if IgnoreResizing then\r\n Width := 0\r\n else\r\n Width := DBGrid.Columns[GCol].Width;\r\n end;\r\n if dgColLines in DBGrid.Options then\r\n Width := Width + TDrawGrid(DBGrid).GridLineWidth;\r\n end;\r\n end;\r\n\r\nvar\r\n I,\r\n FirstPanel,\r\n LastPanel: Integer;\r\nbegin\r\n Panels.Clear;\r\n if Assigned(DBGrid) and not SimplePanel then\r\n begin\r\n Panels.BeginUpdate;\r\n try\r\n // Datasource checking\r\n if DataSource <> DBGrid.DataSource then\r\n DataSource := DBGrid.DataSource;\r\n\r\n // Indicator panel\r\n if dgIndicator in DBGrid.Options then\r\n with Panels.Add do\r\n begin\r\n Bevel := pbNone;\r\n Style := psText;\r\n Text := '';\r\n Width := IndicatorWidth;\r\n if dgColLines in DBGrid.Options then\r\n Width := Width + TDrawGrid(DBGrid).GridLineWidth;\r\n end;\r\n\r\n // Fixed cols panels\r\n for I := 0 to DBGrid.FixedCols - 1 do\r\n CreatePanel(I);\r\n\r\n // Movable cols panels\r\n if IgnoreHorzScrolling then\r\n begin\r\n FirstPanel := DBGrid.FixedCols;\r\n LastPanel := DBGrid.Columns.Count - 1;\r\n end\r\n else\r\n begin\r\n if dgIndicator in DBGrid.Options then\r\n FirstPanel := DBGrid.LeftCol - 1\r\n else\r\n FirstPanel := DBGrid.LeftCol;\r\n LastPanel := FirstPanel + DBGrid.VisibleColCount;\r\n if LastPanel >= DBGrid.Columns.Count then\r\n LastPanel := DBGrid.Columns.Count - 1;\r\n end;\r\n for I := FirstPanel to LastPanel do\r\n CreatePanel(I);\r\n\r\n // Ending panel\r\n with Panels.Add do\r\n begin\r\n Bevel := pbNone;\r\n Style := psText;\r\n Text := '';\r\n Width := 1;\r\n end;\r\n finally\r\n Panels.EndUpdate;\r\n end;\r\n end;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvDBGridSelectColumnForm.dfm", "content": "object frmSelectColumn: TfrmSelectColumn\r\n Left = 445\r\n Top = 244\r\n ClientWidth = 189\r\n ClientHeight = 217\r\n BorderIcons = []\r\n BorderStyle = bsSizeToolWin\r\n BorderWidth = 2\r\n Caption = 'Select columns'\r\n Color = clBtnFace\r\n Constraints.MinHeight = 140\r\n Constraints.MinWidth = 100\r\n Font.Charset = DEFAULT_CHARSET\r\n Font.Color = clWindowText\r\n Font.Height = -11\r\n Font.Name = 'MS Sans Serif'\r\n Font.Style = []\r\n FormStyle = fsStayOnTop\r\n KeyPreview = True\r\n OldCreateOrder = False\r\n OnActivate = FormActivate\r\n OnClose = FormClose\r\n OnCreate = FormCreate\r\n OnDestroy = FormDestroy\r\n OnKeyPress = FormKeyPress\r\n PixelsPerInch = 96\r\n TextHeight = 13\r\n object Panel1: TPanel\r\n Left = 0\r\n Top = 163\r\n Width = 185\r\n Height = 50\r\n Align = alBottom\r\n BevelOuter = bvNone\r\n TabOrder = 0\r\n object cbWithFieldName: TCheckBox\r\n Left = 18\r\n Top = -2\r\n Width = 165\r\n Height = 25\r\n Anchors = [akLeft, akRight]\r\n TabOrder = 0\r\n Visible = False\r\n OnClick = cbClick\r\n end\r\n object ButtonOK: TButton\r\n Left = 56\r\n Top = 19\r\n Width = 75\r\n Height = 25\r\n Anchors = []\r\n Caption = '&OK'\r\n Default = True\r\n ModalResult = 1\r\n TabOrder = 1\r\n end\r\n end\r\n object clbList: TCheckListBox\r\n Left = 0\r\n Top = 0\r\n Width = 185\r\n Height = 163\r\n OnClickCheck = clbListClickCheck\r\n Align = alClient\r\n ItemHeight = 13\r\n TabOrder = 1\r\n end\r\nend\r\n" }, { "path": "External/Jedi/Jvcl/run/JvDBGridSelectColumnForm.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvDBGridSelectColumnForm.PAS, released on 2004-01-15.\r\n\r\nThe Initial Developers of the Original Code is Lionel Reynaud\r\nCopyright (c) 2004 Lionel Reynaud\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvDBGridSelectColumnForm.pas 13415 2012-09-10 09:51:54Z obones $\r\n\r\nunit JvDBGridSelectColumnForm;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, Classes, Controls, Forms, StdCtrls, Dialogs, CheckLst, ExtCtrls,\r\n DB, DBGrids, JvDBGrid, JvComponent;\r\n\r\ntype\r\n TfrmSelectColumn = class(TJvForm)\r\n Panel1: TPanel;\r\n clbList: TCheckListBox;\r\n cbWithFieldName: TCheckBox;\r\n ButtonOK: TButton;\r\n procedure FormCreate(Sender: TObject);\r\n procedure FormClose(Sender: TObject; var Action: TCloseAction);\r\n procedure FormDestroy(Sender: TObject);\r\n procedure FormActivate(Sender: TObject);\r\n procedure cbClick(Sender: TObject);\r\n procedure clbListClickCheck(Sender: TObject);\r\n procedure FormKeyPress(Sender: TObject; var Key: Char);\r\n private\r\n FDataSource: TDataSource;\r\n FJvDBGrid: TJvDBGrid;\r\n FSelectColumn: TSelectColumn;\r\n FColumnUpdate: Boolean;\r\n FCanHide: Boolean;\r\n FNoSelectionWarning: string;\r\n procedure ResizeForm;\r\n function GetColumn(AField: TField): TColumn;\r\n public\r\n property DataSource: TDataSource read FDataSource write FDataSource;\r\n property Grid: TJvDBGrid read FJvDBGrid write FJvDBGrid;\r\n property SelectColumn: TSelectColumn read FSelectColumn write FSelectColumn;\r\n published\r\n // make this published so localization tools have a chance to pick it up\r\n property NoSelectionWarning: string read FNoSelectionWarning write FNoSelectionWarning;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvDBGridSelectColumnForm.pas $';\r\n Revision: '$Revision: 13415 $';\r\n Date: '$Date: 2012-09-10 11:51:54 +0200 (lun. 10 sept. 2012) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n {$IFDEF HAS_UNIT_SYSTEM_UITYPES}\r\n System.UITypes,\r\n {$ENDIF HAS_UNIT_SYSTEM_UITYPES}\r\n SysUtils,\r\n JvJCLUtils, JvConsts;\r\n\r\n{$R *.dfm}\r\n\r\nprocedure TfrmSelectColumn.FormCreate(Sender: TObject);\r\nbegin\r\n FColumnUpdate := True;\r\n FCanHide := True;\r\n // (p3) don't use resourcestring here since this property is normally set from the JvDBGrid\r\n // and using resourcestrings might give problems with localization synchronizing\r\n NoSelectionWarning := 'At least one column must be visible!';\r\nend;\r\n\r\nprocedure TfrmSelectColumn.FormClose(Sender: TObject;\r\n var Action: TCloseAction);\r\nvar\r\n I, J: Integer;\r\nbegin\r\n if (ModalResult = mrOk) and FColumnUpdate and FCanHide and Assigned(FJvDBGrid) then\r\n begin\r\n FJvDBGrid.BeginUpdate;\r\n try\r\n for I := 0 to clbList.Items.Count - 1 do\r\n begin\r\n J := Integer(clbList.Items.Objects[I]);\r\n if (J >= 0) and (J < FJvDBGrid.Columns.Count) then\r\n FJvDBGrid.Columns[J].Visible := clbList.Checked[I];\r\n end;\r\n finally\r\n FJvDBGrid.EndUpdate;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TfrmSelectColumn.FormDestroy(Sender: TObject);\r\nbegin\r\n clbList.Items.Clear;\r\nend;\r\n\r\nprocedure TfrmSelectColumn.FormActivate(Sender: TObject);\r\nvar\r\n I, J: Integer;\r\n ColumnTitle: string;\r\n lColumn: TColumn;\r\nbegin\r\n if Assigned(FJvDBGrid) then\r\n with FJvDBGrid do\r\n begin\r\n clbList.Items.Clear;\r\n cbWithFieldName.Hide;\r\n if (FSelectColumn = scDatabase) and Assigned(DataSource) and Assigned(DataSource.Dataset) then\r\n begin\r\n with DataSource.Dataset do\r\n for I := 0 to FieldCount - 1 do\r\n begin\r\n lColumn := GetColumn(Fields[I]);\r\n if Assigned(lColumn) then\r\n begin\r\n ColumnTitle := lColumn.Title.Caption;\r\n if (not AnsiSameText(ColumnTitle, Fields[I].FieldName))\r\n and (cbWithFieldName.Caption <> '') then\r\n begin\r\n if not cbWithFieldName.Visible then\r\n cbWithFieldName.Show;\r\n if cbWithFieldName.State = cbChecked then\r\n ColumnTitle := ColumnTitle + ' [' + Fields[I].FieldName + ']';\r\n end;\r\n J := clbList.Items.AddObject(ColumnTitle, TObject(lColumn.Index));\r\n clbList.Checked[J] := lColumn.Visible and Fields[I].Visible;\r\n end;\r\n end;\r\n end\r\n else\r\n begin\r\n for I := 0 to Columns.Count - 1 do\r\n begin\r\n ColumnTitle := FJvDBGrid.Columns[I].Title.Caption;\r\n if not AnsiSameText(ColumnTitle, FJvDBGrid.Columns[I].FieldName)\r\n and (cbWithFieldName.Caption <> '') then\r\n begin\r\n if not cbWithFieldName.Visible then\r\n cbWithFieldName.Show;\r\n if cbWithFieldName.State = cbChecked then\r\n ColumnTitle := ColumnTitle + ' [' + FJvDBGrid.Columns[I].FieldName + ']';\r\n end;\r\n J := clbList.Items.AddObject(ColumnTitle, TObject(I));\r\n clbList.Checked[J] := FJvDBGrid.Columns[I].Visible;\r\n end;\r\n end;\r\n if clbList.Items.Count > 0 then\r\n clbList.ItemIndex := 0;\r\n end;\r\n ResizeForm;\r\nend;\r\n\r\nprocedure TfrmSelectColumn.cbClick(Sender: TObject);\r\nbegin\r\n FormActivate(Self);\r\nend;\r\n\r\nfunction TfrmSelectColumn.GetColumn(AField: TField): TColumn;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := nil;\r\n with FJvDBGrid.Columns do\r\n for I := 0 to Count - 1 do\r\n begin\r\n if Items[I].FieldName = AField.FieldName then\r\n begin\r\n Result := Items[I];\r\n Break;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TfrmSelectColumn.clbListClickCheck(Sender: TObject);\r\nvar\r\n I: Integer;\r\nbegin\r\n FCanHide := clbList.Items.Count = 0;\r\n if not FCanHide then\r\n for I := 0 to clbList.Items.Count - 1 do\r\n begin\r\n if clbList.Checked[I] then\r\n begin\r\n FCanHide := True;\r\n Break;\r\n end;\r\n end;\r\n if not FCanHide then\r\n begin\r\n MessageDlg(NoSelectionWarning, mtWarning, [mbOk], 0);\r\n if clbList.ItemIndex >= 0 then\r\n begin\r\n clbList.Checked[clbList.ItemIndex] := True;\r\n FCanHide := True;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TfrmSelectColumn.FormKeyPress(Sender: TObject; var Key: Char);\r\nbegin\r\n if Key = Esc then\r\n begin\r\n ModalResult := mrCancel;\r\n FColumnUpdate := False;\r\n end;\r\nend;\r\n\r\nprocedure TfrmSelectColumn.ResizeForm;\r\nvar\r\n MinHeight: Integer;\r\nbegin\r\n MinHeight := clbList.ItemHeight * clbList.Items.Count;\r\n if MinHeight >= 400 then\r\n ClientHeight := 400\r\n else\r\n while clbList.ClientHeight < MinHeight do\r\n ClientHeight := ClientHeight + clbList.ItemHeight;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvDBHTLabel.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvDBHTLabel.PAS, released on 2004-02-01.\r\n\r\nThe Initial Developers of the Original Code are: Maciej Kaczkowski\r\nCopyright (c) 2003 Maciej Kaczkowski\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's\r\nJVCL home page, located at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n- To display data from a datasource, use the tag in Mask.\r\n- You can have more than one FIELD tag in a label, i.e:\r\n Name:, Company:\r\n- The fieldname *must* be double-quoted!\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvDBHTLabel.pas 13104 2011-09-07 06:50:43Z obones $\r\n\r\nunit JvDBHTLabel;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, Messages, Classes, DB, DBCtrls, Controls,\r\n VDBConsts,\r\n JvHtControls;\r\n\r\ntype\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvDBHTLabel = class(TJvCustomHTLabel)\r\n private\r\n FDataLink: TFieldDataLink;\r\n FMask: string;\r\n function GetDataSource: TDataSource;\r\n procedure SetDataSource(const Value: TDataSource);\r\n procedure DataChange(Sender: TObject);\r\n procedure SetMask(const Value: string);\r\n procedure CMGetDataLink(var Message: TMessage); message CM_GETDATALINK;\r\n protected\r\n function GetLabelText: string; override;\r\n procedure Loaded; override;\r\n procedure Notification(AComponent: TComponent;\r\n Operation: TOperation); override;\r\n procedure SetAutoSize(Value: Boolean); override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n procedure UpdateCaption;\r\n published\r\n property DataSource: TDataSource read GetDataSource write SetDataSource;\r\n property Mask: string read FMask write SetMask;\r\n\r\n property Align;\r\n property AutoSize;\r\n property Constraints;\r\n property Color;\r\n property Layout;\r\n property DragCursor;\r\n property BiDiMode;\r\n property DragKind;\r\n property ParentBiDiMode;\r\n property OnEndDock;\r\n property OnStartDock;\r\n property DragMode;\r\n property Enabled;\r\n property FocusControl;\r\n property Font;\r\n property ParentColor;\r\n property ParentFont;\r\n property ParentShowHint;\r\n property PopupMenu;\r\n property ShowHint;\r\n property Transparent;\r\n property Visible;\r\n property OnClick;\r\n property OnDblClick;\r\n property OnDragDrop;\r\n property OnDragOver;\r\n property OnEndDrag;\r\n property OnMouseDown;\r\n property OnMouseMove;\r\n property OnMouseUp;\r\n property OnStartDrag;\r\n property OnHyperLinkClick;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvDBHTLabel.pas $';\r\n Revision: '$Revision: 13104 $';\r\n Date: '$Date: 2011-09-07 08:50:43 +0200 (mer. 07 sept. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n SysUtils;\r\n\r\nfunction ReplaceFieldNameTag(Str: string; DataSet: TDataSet): string;\r\nvar\r\n F: TField;\r\nconst\r\n FieldName = 'FIELD'; // non-standard html\r\n FieldStr = '<' + FieldName + '=';\r\n FieldLabelName = 'FIELDLABEL';\r\n FieldLabelStr = '<' + FieldLabelName + '=';\r\n\r\n function ExtractPropertyValue(Tag, PropName: string): string;\r\n begin\r\n Result := '';\r\n PropName := UpperCase(PropName);\r\n if Pos(PropName, UpperCase(Tag)) > 0 then\r\n begin\r\n Result := Copy(Tag, Pos(PropName, UpperCase(Tag))+Length(PropName), Length(Tag));\r\n Result := Copy(Result, Pos('\"', Result)+1, Length(Result));\r\n Result := Copy(Result, 1, Pos('\"', Result)-1);\r\n end;\r\n end;\r\n\r\n function ExtractProperty(AStr: string; const PropName: string): string;\r\n var\r\n J: Integer;\r\n I: Integer;\r\n A, FieldName, Text: string;\r\n PropStr: string;\r\n begin\r\n Result := '';\r\n PropStr := '<'+PropName+'=';\r\n I := Pos(PropStr, AStr);\r\n while I > 0 do\r\n begin\r\n Result := Result + Copy(AStr, 1, I - 1);\r\n A := Copy(AStr, I, Length(AStr));\r\n J := Pos('>', A);\r\n if J > 0 then\r\n Delete(AStr, 1, I + J - 1)\r\n else\r\n AStr := '';\r\n FieldName := ExtractPropertyValue(A, PropStr);\r\n if Assigned(DataSet) and DataSet.Active then\r\n begin\r\n F := DataSet.FindField(FieldName);\r\n if F <> nil then\r\n begin\r\n if PropName = FieldLabelName then\r\n Text := F.DisplayLabel\r\n else\r\n Text := F.DisplayText;\r\n end\r\n else\r\n Text := Format('(%s)', [FieldName]);\r\n end\r\n else\r\n Text := Format('(%s)', [FieldName]);\r\n Result := Result + Text;\r\n I := Pos(PropStr, AStr);\r\n end;\r\n Result := Result + AStr;\r\n end;\r\n\r\nbegin\r\n Result := ExtractProperty(Str, FieldLabelName);\r\n Result := ExtractProperty(Result, FieldName);\r\nend;\r\n\r\n//=== { TJvDBHTLabel } =======================================================\r\n\r\nprocedure TJvDBHTLabel.CMGetDataLink(var Message: TMessage);\r\nbegin\r\n Message.Result := LRESULT(FDataLink);\r\nend;\r\n\r\nconstructor TJvDBHTLabel.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FDataLink := TFieldDataLink.Create;\r\n with FDataLink do\r\n begin\r\n Control := Self;\r\n OnDataChange := DataChange;\r\n OnEditingChange := DataChange;\r\n OnUpdateData := DataChange;\r\n OnActiveChange := DataChange;\r\n end;\r\nend;\r\n\r\ndestructor TJvDBHTLabel.Destroy;\r\nbegin\r\n FreeAndNil(FDataLink);\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvDBHTLabel.UpdateCaption;\r\nbegin\r\n if Assigned(FDataLink) and Assigned(FDataLink.DataSet) then\r\n Caption := ReplaceFieldNameTag(FMask, FDataLink.DataSet)\r\n else\r\n Caption := ReplaceFieldNameTag(Mask, nil);\r\nend;\r\n\r\nfunction TJvDBHTLabel.GetDataSource: TDataSource;\r\nbegin\r\n Result := FDataLink.DataSource;\r\nend;\r\n\r\nfunction TJvDBHTLabel.GetLabelText: string;\r\nbegin\r\n if csPaintCopy in ControlState then\r\n begin\r\n if (Assigned(FDataLink) and Assigned(FDataLink.DataSet)) then\r\n Result := ReplaceFieldNameTag(FMask, FDataLink.DataSet)\r\n else\r\n Result := ReplaceFieldNameTag(Mask, nil);\r\n end\r\n else\r\n Result := Caption;\r\nend;\r\n\r\nprocedure TJvDBHTLabel.Loaded;\r\nbegin\r\n inherited;\r\n if (csDesigning in ComponentState) then DataChange(Self);\r\nend;\r\n\r\nprocedure TJvDBHTLabel.Notification(AComponent: TComponent; Operation: TOperation);\r\nbegin\r\n inherited;\r\n if (Operation = opRemove) and (FDataLink <> nil) and\r\n (AComponent = DataSource) then\r\n DataSource := nil;\r\nend;\r\n\r\nprocedure TJvDBHTLabel.SetAutoSize(Value: Boolean);\r\nbegin\r\n if AutoSize <> Value then\r\n begin\r\n if Value and FDataLink.DataSourceFixed then DatabaseError(SDataSourceFixed);\r\n inherited;\r\n end;\r\nend;\r\n\r\nprocedure TJvDBHTLabel.SetDataSource(const Value: TDataSource);\r\nbegin\r\n FDataLink.DataSource := Value;\r\n UpdateCaption;\r\nend;\r\n\r\nprocedure TJvDBHTLabel.DataChange(Sender: TObject);\r\nbegin\r\n UpdateCaption;\r\nend;\r\n\r\nprocedure TJvDBHTLabel.SetMask(const Value: string);\r\nbegin\r\n if FMask <> Value then\r\n begin\r\n FMask := Value;\r\n UpdateCaption;\r\n end;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n\r\n" }, { "path": "External/Jedi/Jvcl/run/JvDBImage.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvDBImage.PAS, released on 2004-04-09.\r\n\r\nThe Initial Developers of the Original Code is\r\nSergio Samayoa and Peter Thornqvist \r\nPortions created by Sergio Samayoa are Copyright (C) 2004 Sergio Samayoa.\r\nPortions created by Peter Thornqvist are Copyright (C) 2004 Peter Thornqvist.\r\n\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvDBImage.pas 13314 2012-06-12 10:24:34Z obones $\r\n\r\n{\r\nDocumentation:\r\n*************\r\n\r\nWHAT IT IS:\r\n This component is a TDBImage replacement that supports other image\r\n formats than bitmap, a limitation of TDBImage since D1.\r\n\r\nIMAGE FORMATS:\r\n See JvGraphics.pas for details\r\n\r\nSUPPORT FOR TDBCtrlGrid:\r\n You can safely put an TJvDBImage in TDBCtrlGrid.\r\n}\r\n\r\nunit JvDBImage;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, Messages, Classes, Graphics, Controls,\r\n Clipbrd, DB, DBCtrls, Forms,\r\n JvJVCLUtils;\r\n\r\ntype\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvDBImage = class(TDBImage)\r\n private\r\n FAutoDisplay: Boolean;\r\n FDataLink: TFieldDataLink;\r\n FOldPictureChange: TNotifyEvent;\r\n FPictureLoaded: Boolean;\r\n FProportional: Boolean;\r\n FOnGetGraphicClass: TJvGetGraphicClassEvent;\r\n FTransparent: Boolean;\r\n FShowNameIfEmpty: Boolean;\r\n procedure SetAutoDisplay(Value: Boolean);\r\n procedure SetProportional(Value: Boolean);\r\n procedure DataChange(Sender: TObject);\r\n procedure PictureChanged(Sender: TObject);\r\n procedure UpdateData(Sender: TObject);\r\n procedure SetTransparent(const Value: Boolean);\r\n procedure SetShowNameIfEmpty(const Value: Boolean);\r\n protected\r\n procedure CreateHandle; override;\r\n procedure CheckFieldType;\r\n procedure AssignGraphicTo(Picture: TPicture);\r\n function DestRect(W, H, CW, CH: Integer): TRect;\r\n procedure Paint; override;\r\n procedure WMLButtonDblClk(var Msg: TWMLButtonDblClk); message WM_LBUTTONDBLCLK;\r\n procedure WMPaste(var Msg: TWMPaste); message WM_PASTE;\r\n procedure KeyPress(var Key: Char); override;\r\n function CanAutoSize(var NewWidth, NewHeight: Integer): Boolean; override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n procedure LoadPicture;\r\n procedure PasteFromClipboard;\r\n published\r\n property AutoSize;\r\n property AutoDisplay: Boolean read FAutoDisplay write SetAutoDisplay default True;\r\n property BevelEdges;\r\n property BevelInner;\r\n property BevelKind default bkNone;\r\n property BevelOuter;\r\n property Proportional: Boolean read FProportional write SetProportional default False;\r\n property ShowNameIfEmpty: Boolean read FShowNameIfEmpty write SetShowNameIfEmpty default True;\r\n property Transparent: Boolean read FTransparent write SetTransparent default False;\r\n property OnGetGraphicClass: TJvGetGraphicClassEvent read FOnGetGraphicClass write FOnGetGraphicClass;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvDBImage.pas $';\r\n Revision: '$Revision: 13314 $';\r\n Date: '$Date: 2012-06-12 12:24:34 +0200 (mar. 12 juin 2012) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n DBConsts, SysUtils,\r\n JvConsts;\r\n\r\n//=== { TJvDBImage } =========================================================\r\n\r\nconstructor TJvDBImage.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n // we cannot use the inherited AutoDisplay - it raises an \"Invalid Bitmap\" if\r\n // the first record in a table is an image type not supported by TDBImage\r\n inherited AutoDisplay := False;\r\n FAutoDisplay := True;\r\n FOldPictureChange := Picture.OnChange;\r\n Picture.OnChange := PictureChanged;\r\n FShowNameIfEmpty := True;\r\nend;\r\n\r\nprocedure TJvDBImage.SetProportional(Value: Boolean);\r\nbegin\r\n if FProportional <> Value then\r\n begin\r\n FProportional := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvDBImage.SetShowNameIfEmpty(const Value: Boolean);\r\nbegin\r\n if FShowNameIfEmpty <> Value then\r\n begin\r\n FShowNameIfEmpty := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvDBImage.CheckFieldType;\r\nbegin\r\n if Field = nil then\r\n Exit;\r\n with Field do\r\n if not IsBlob then\r\n DatabaseErrorFmt(SFieldTypeMismatch, [DisplayName, FieldTypeNames[ftBlob], FieldTypeNames[DataType]]);\r\nend;\r\n\r\nprocedure TJvDBImage.CreateHandle;\r\nbegin\r\n inherited CreateHandle;\r\n if FDataLink = nil then\r\n begin\r\n // (p3) get a pointer to the datalink (it is private in TDBImage):\r\n FDataLink := TFieldDataLink(SendMessage(Handle, CM_GETDATALINK, 0, 0));\r\n if FDataLink <> nil then\r\n begin\r\n FDataLink.OnDataChange := DataChange;\r\n FDataLink.OnUpdateData := UpdateData;\r\n // (p3) it is now safe to call LoadPicture because we have control over the datalink:\r\n if FAutoDisplay then\r\n LoadPicture\r\n else\r\n Invalidate;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvDBImage.AssignGraphicTo(Picture: TPicture);\r\nvar\r\n Graphic: TGraphic;\r\n GraphicClass: TGraphicClass;\r\n Stream: TMemoryStream;\r\nbegin\r\n // If nil field or null field just exit\r\n if (Field = nil) or Field.IsNull then\r\n Exit;\r\n\r\n CheckFieldType;\r\n\r\n GraphicClass := nil;\r\n Stream := TMemoryStream.Create;\r\n try\r\n // Move blob data to Stream\r\n TBlobField(Field).SaveToStream(Stream);\r\n // Figure out which Graphic class is...\r\n GraphicClass := GetGraphicClass(Stream);\r\n // Call user event\r\n if Assigned(FOnGetGraphicClass) then\r\n FOnGetGraphicClass(Self, Stream, GraphicClass);\r\n // If we got one, load it..\r\n if GraphicClass <> nil then\r\n begin\r\n Graphic := GraphicClass.Create;\r\n try\r\n Stream.Position := 0;\r\n Graphic.LoadFromStream(Stream);\r\n Picture.Graphic := Graphic;\r\n finally\r\n Graphic.Free;\r\n end;\r\n end\r\n else // try the old fashioned way\r\n Picture.Assign(Field);\r\n finally\r\n Stream.Free;\r\n end;\r\nend;\r\n\r\nprocedure TJvDBImage.PictureChanged(Sender: TObject);\r\nbegin\r\n if AutoSize and (Picture.Width > 0) and (Picture.Height > 0) then\r\n SetBounds(Left, Top, Picture.Width, Picture.Height);\r\n FOldPictureChange(Sender);\r\n FPictureLoaded := Picture.Graphic <> nil;\r\nend;\r\n\r\nprocedure TJvDBImage.DataChange(Sender: TObject);\r\nbegin\r\n Picture.Graphic := nil;\r\n FPictureLoaded := False;\r\n if FAutoDisplay then\r\n LoadPicture;\r\nend;\r\n\r\nfunction TJvDBImage.DestRect(W, H, CW, CH: Integer): TRect;\r\nvar\r\n XYAspect: Double;\r\nbegin\r\n if AutoSize then\r\n begin\r\n Result := ClientRect;\r\n Exit;\r\n end;\r\n if Stretch or (Proportional and ((W > CW) or (H > CH))) then\r\n begin\r\n if Proportional and (W > 0) and (H > 0) then\r\n begin\r\n XYAspect := W / H;\r\n if W > H then\r\n begin\r\n W := CW;\r\n H := Trunc(CW / XYAspect);\r\n if H > CH then // woops, too big\r\n begin\r\n H := CH;\r\n W := Trunc(CH * XYAspect);\r\n end;\r\n end\r\n else\r\n begin\r\n H := CH;\r\n W := Trunc(CH * XYAspect);\r\n if W > CW then // woops, too big\r\n begin\r\n W := CW;\r\n H := Trunc(CW / XYAspect);\r\n end;\r\n end;\r\n end\r\n else\r\n begin\r\n W := CW;\r\n H := CH;\r\n end;\r\n end;\r\n\r\n Result := Rect(0, 0, W, H);\r\n if Center then\r\n OffsetRect(Result, (CW - W) div 2, (CH - H) div 2);\r\nend;\r\n\r\nprocedure TJvDBImage.Paint;\r\nvar\r\n Size: TSize;\r\n R: TRect;\r\n S: string;\r\n DrawPict: TPicture;\r\n Form: TCustomForm;\r\n Pal: HPalette;\r\nbegin\r\n with Canvas do\r\n begin\r\n Brush.Style := bsSolid;\r\n Brush.Color := Color;\r\n if FPictureLoaded or (csPaintCopy in ControlState) and Assigned(FDataLink) then\r\n begin\r\n DrawPict := TPicture.Create;\r\n Pal := 0;\r\n try\r\n if (csPaintCopy in ControlState) and Assigned(FDataLink.Field) and\r\n FDataLink.Field.IsBlob then\r\n begin\r\n AssignGraphicTo(DrawPict);\r\n if DrawPict.Graphic is TBitmap then\r\n DrawPict.Bitmap.IgnorePalette := QuickDraw;\r\n end\r\n else\r\n begin\r\n DrawPict.Assign(Picture);\r\n if Focused and (DrawPict.Graphic <> nil) and\r\n (DrawPict.Graphic.Palette <> 0) then\r\n begin\r\n Pal := SelectPalette(Handle, DrawPict.Graphic.Palette, False);\r\n RealizePalette(Handle);\r\n end;\r\n end;\r\n FillRect(ClientRect); // (p3) always fill or the text might be visible through the control\r\n if (DrawPict.Graphic <> nil) and not DrawPict.Graphic.Empty then\r\n begin\r\n DrawPict.Graphic.Transparent := Self.Transparent;\r\n // (p3) DestRect adjusts the rect according to the values of Stretch, Center and Proportional\r\n R := DestRect(DrawPict.Width, DrawPict.Height, Self.Width, Self.Height);\r\n StretchDraw(R, DrawPict.Graphic);\r\n ExcludeClipRect(Handle, R.Left, R.Top, R.Right, R.Bottom);\r\n FillRect(ClientRect);\r\n SelectClipRgn(Handle, 0);\r\n end;\r\n finally\r\n if Pal <> 0 then\r\n SelectPalette(Handle, Pal, True);\r\n DrawPict.Free;\r\n end;\r\n end\r\n else if ShowNameIfEmpty then\r\n begin\r\n Font := Self.Font;\r\n if (FDataLink <> nil) and (FDataLink.Field <> nil) then\r\n S := FDataLink.Field.DisplayLabel\r\n else\r\n S := Name;\r\n if S = '' then\r\n S := Self.ClassName;\r\n S := '(' + S + ')';\r\n Size := TextExtent(S);\r\n R := ClientRect;\r\n TextRect(R, (R.Right - Size.cx) div 2, (R.Bottom - Size.cy) div 2, S);\r\n end;\r\n Form := GetParentForm(Self);\r\n if (Form <> nil) and (Form.ActiveControl = Self) and not\r\n (csDesigning in ComponentState) and not (csPaintCopy in ControlState) then\r\n begin\r\n Brush.Color := clWindowFrame;\r\n FrameRect(ClientRect);\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvDBImage.LoadPicture;\r\nbegin\r\n if not FPictureLoaded then\r\n try\r\n AssignGraphicTo(Picture);\r\n except\r\n Picture.Graphic := nil;\r\n raise;\r\n end;\r\nend;\r\n\r\nprocedure TJvDBImage.UpdateData(Sender: TObject);\r\nvar\r\n Stream: TMemoryStream;\r\nbegin\r\n CheckFieldType;\r\n\r\n // If there is no graphic just clear field and exit\r\n if Picture.Graphic = nil then\r\n begin\r\n Field.Clear;\r\n Exit;\r\n end;\r\n\r\n Stream := TMemoryStream.Create;\r\n try\r\n Picture.Graphic.SaveToStream(Stream);\r\n Stream.Position := 0;\r\n TBlobField(Field).LoadFromStream(Stream);\r\n finally\r\n Stream.Free;\r\n end;\r\nend;\r\n\r\nprocedure TJvDBImage.SetAutoDisplay(Value: Boolean);\r\nbegin\r\n if FAutoDisplay <> Value then\r\n begin\r\n FAutoDisplay := Value;\r\n if Value then\r\n LoadPicture;\r\n end;\r\nend;\r\n\r\nprocedure TJvDBImage.PasteFromClipboard;\r\nbegin\r\n if FDataLink.Edit then\r\n begin\r\n if Clipboard.HasFormat(CF_BITMAP) then\r\n Picture.Bitmap.Assign(Clipboard)\r\n else\r\n if Clipboard.HasFormat(CF_METAFILEPICT) or\r\n Clipboard.HasFormat(CF_ENHMETAFILE) then\r\n Picture.Metafile.Assign(Clipboard)\r\n else\r\n if Clipboard.HasFormat(CF_PICTURE) then\r\n Picture.Assign(Clipboard);\r\n end;\r\nend;\r\n\r\nfunction ControlCursorPos(Control: TControl): TPoint;\r\nbegin\r\n GetCursorPos(Result);\r\n Result := Control.ScreenToClient(Result);\r\nend;\r\n\r\nprocedure TJvDBImage.WMLButtonDblClk(var Msg: TWMLButtonDblClk);\r\nbegin\r\n // we can't call inherited because TDBImage loads the image there as well\r\n // and will get mighty upset if it's not a BMP, so we have to redo the\r\n // code in TControl as closely as we can\r\n SendCancelMode(Self);\r\n // inherited;\r\n if csCaptureMouse in ControlStyle then\r\n MouseCapture := True;\r\n if csClickEvents in ControlStyle then\r\n DblClick;\r\n if not (csNoStdEvents in ControlStyle) then\r\n with Msg do\r\n if (Width > 32768) or (Height > 32768) then\r\n with ControlCursorPos(Self) do\r\n MouseDown(mbLeft, KeysToShiftState(Keys), X, Y)\r\n else\r\n MouseDown(mbLeft, KeysToShiftState(Keys), XPos, YPos);\r\n LoadPicture;\r\nend;\r\n\r\nprocedure TJvDBImage.KeyPress(var Key: Char);\r\nbegin\r\n case Key of\r\n CtrlC:\r\n CopyToClipboard;\r\n CtrlV:\r\n PasteFromClipboard;\r\n CtrlX:\r\n CutToClipboard;\r\n Cr:\r\n LoadPicture;\r\n Esc:\r\n if FDataLink <> nil then\r\n FDataLink.Reset;\r\n else // this should be safe, TDBImage doesn't handle any other keys\r\n inherited KeyPress(Key);\r\n end;\r\nend;\r\n\r\nprocedure TJvDBImage.WMPaste(var Msg: TWMPaste);\r\nbegin\r\n PasteFromClipboard;\r\nend;\r\n\r\nprocedure TJvDBImage.SetTransparent(const Value: Boolean);\r\nbegin\r\n if FTransparent <> Value then\r\n begin\r\n FTransparent := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nfunction TJvDBImage.CanAutoSize(var NewWidth, NewHeight: Integer): Boolean;\r\nbegin\r\n Result := True;\r\n if not (csDesigning in ComponentState) or (Picture.Width > 0) and (Picture.Height > 0) then\r\n begin\r\n if Align in [alNone, alLeft, alRight] then\r\n NewWidth := Picture.Width + Ord(BorderStyle = bsSingle) * 4;\r\n if Align in [alNone, alTop, alBottom] then\r\n NewHeight := Picture.Height + Ord(BorderStyle = bsSingle) * 4;\r\n end;\r\nend;\r\n\r\ninitialization\r\n {$IFDEF UNITVERSIONING}\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n {$ENDIF UNITVERSIONING}\r\n { registration happens in GraphicSignatures Needed() }\r\n\r\nfinalization\r\n {$IFDEF UNITVERSIONING}\r\n UnregisterUnitVersion(HInstance);\r\n {$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvDBLogonDialogBaseDevart.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvDBLogonDialogOdac.pas, released on 2006-07-21.\r\n\r\nThe Initial Developer of the Original Code is Jens Fudickar\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\nJens Fudickar\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvDBLogonDialogOdac.pas 13371 2012-06-23 15:46:57Z jfudickar $\r\n\r\nunit JvDBLogonDialogBaseDevart;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n {$IFDEF USE_3RDPARTY_DEVART_DAC}\r\n Classes, Forms, Controls, DBAccess,\r\n JvAppStorage, JvBaseDBLogonDialog,\r\n JvDynControlEngine, JvBaseDBPasswordDialog,\r\n {$ENDIF USE_3RDPARTY_DEVART_DAC}\r\n JvDynControlEngineIntf;\r\n\r\n{$IFDEF USE_3RDPARTY_DEVART_DAC}\r\ntype\r\n\r\n TJvDBBaseDevartConnectDialog = class(TCustomConnectDialog)\r\n private\r\n FLogonDialogInternal: TJvBaseDBLogonDialog;\r\n function GetAfterTransferSessionDataToConnectionInfo: TJvLogonDialogConnectionInfoEvent;\r\n function GetAppStorage: TJvCustomAppStorage;\r\n function GetAppStoragePath: string;\r\n function GetBeforeTransferConnectionInfoToSessionData: TJvLogonDialogConnectionInfoEvent;\r\n function GetCurrentConnectionInfo: TJvBaseConnectionInfo;\r\n function GetDynControlEngine: TJvDynControlEngine;\r\n function GetOnDecryptPassword: TJvLogonDialogEncryptDecryptEvent;\r\n function GetOnEncryptPassword: TJvLogonDialogEncryptDecryptEvent;\r\n function GetOnFillDatabaseList: TJvLogonDialogFillListEvent;\r\n function GetOnFillShortcutList: TJvLogonDialogFillListEvent;\r\n function GetOnSessionConnect: TJvLogonDialogBaseSessionEvent;\r\n procedure SetAfterTransferSessionDataToConnectionInfo(const Value: TJvLogonDialogConnectionInfoEvent);\r\n procedure SetBeforeTransferConnectionInfoToSessionData(const Value: TJvLogonDialogConnectionInfoEvent);\r\n procedure SetDynControlEngine(const Value: TJvDynControlEngine);\r\n procedure SetOnDecryptPassword(const Value: TJvLogonDialogEncryptDecryptEvent);\r\n procedure SetOnEncryptPassword(const Value: TJvLogonDialogEncryptDecryptEvent);\r\n procedure SetOnFillDatabaseList(const Value: TJvLogonDialogFillListEvent);\r\n procedure SetOnFillShortcutList(const Value: TJvLogonDialogFillListEvent);\r\n procedure SetOnSessionConnect(const Value: TJvLogonDialogBaseSessionEvent);\r\n protected\r\n function CreateLogonDialogInternal: TJvBaseDBLogonDialog; virtual; abstract;\r\n function GetLogonDialogInternal: TJvBaseDBLogonDialog; virtual;\r\n property LogonDialogInternal: TJvBaseDBLogonDialog read GetLogonDialogInternal;\r\n function GetOptions: TJvBaseDBLogonDialogOptions; virtual;\r\n procedure SetAppStorage(Value: TJvCustomAppStorage);\r\n procedure SetAppStoragePath(Value: string); virtual;\r\n procedure SetOptions(const Value: TJvBaseDBLogonDialogOptions); virtual;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n function Execute: Boolean; override;\r\n function ExecuteOnSession(Session: TCustomDAConnection): Boolean;\r\n property CurrentConnectionInfo: TJvBaseConnectionInfo read GetCurrentConnectionInfo;\r\n published\r\n //1 This events gives you the possibility to modify the connection data after receiving the data from the current session\r\n property AfterTransferSessionDataToConnectionInfo: TJvLogonDialogConnectionInfoEvent read\r\n GetAfterTransferSessionDataToConnectionInfo write SetAfterTransferSessionDataToConnectionInfo;\r\n property AppStorage: TJvCustomAppStorage read GetAppStorage write SetAppStorage;\r\n property AppStoragePath: string read GetAppStoragePath write SetAppStoragePath;\r\n //1 This Event gives you the possibility to modify the connection data before it is transfered to the current session\r\n property BeforeTransferConnectionInfoToSessionData: TJvLogonDialogConnectionInfoEvent read\r\n GetBeforeTransferConnectionInfoToSessionData write SetBeforeTransferConnectionInfoToSessionData;\r\n property DynControlEngine: TJvDynControlEngine read GetDynControlEngine write SetDynControlEngine;\r\n property Options: TJvBaseDBLogonDialogOptions read GetOptions write SetOptions;\r\n property OnDecryptPassword: TJvLogonDialogEncryptDecryptEvent read GetOnDecryptPassword write SetOnDecryptPassword;\r\n property OnEncryptPassword: TJvLogonDialogEncryptDecryptEvent read GetOnEncryptPassword write SetOnEncryptPassword;\r\n //1 Event for filling the database list\r\n property OnFillDatabaseList: TJvLogonDialogFillListEvent read GetOnFillDatabaseList write SetOnFillDatabaseList;\r\n //1 Event for customizing the shortcut list\r\n property OnFillShortcutList: TJvLogonDialogFillListEvent read GetOnFillShortcutList write SetOnFillShortcutList;\r\n property OnSessionConnect: TJvLogonDialogBaseSessionEvent read GetOnSessionConnect write SetOnSessionConnect;\r\n end;\r\n{$ENDIF USE_3RDPARTY_DEVART_DAC}\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/trunk/jvcl/run/JvDBLogonDialogOdac.pas $';\r\n Revision: '$Revision: 13371 $';\r\n Date: '$Date: 2012-06-23 17:46:57 +0200 (Sa, 23 Jun 2012) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\n{$IFDEF USE_3RDPARTY_DEVART_DAC}\r\nuses\r\n SysUtils, StdCtrls, Dialogs,\r\n OraClasses, OraError, OraCall, OraServices,\r\n JvDSADialogs, JvDBPasswordDialogOdac, JvResources;\r\n\r\n//=== { TJvDBBaseDevartConnectDialog } =============================================\r\n\r\nconstructor TJvDBBaseDevartConnectDialog.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FLogonDialogInternal := CreateLogonDialogInternal;\r\nend;\r\n\r\ndestructor TJvDBBaseDevartConnectDialog.Destroy;\r\nbegin\r\n FreeAndNil(FLogonDialogInternal);\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJvDBBaseDevartConnectDialog.Execute: Boolean;\r\nbegin\r\n Result := ExecuteOnSession(Connection);\r\nend;\r\n\r\nfunction TJvDBBaseDevartConnectDialog.ExecuteOnSession(Session: TCustomDAConnection):\r\n Boolean;\r\nbegin\r\n if Assigned(FLogonDialogInternal) then\r\n begin\r\n LogonDialogInternal.Session := Session;\r\n Result := LogonDialogInternal.Execute;\r\n end\r\n else\r\n Result := False;\r\nend;\r\n\r\nfunction TJvDBBaseDevartConnectDialog.GetAfterTransferSessionDataToConnectionInfo: TJvLogonDialogConnectionInfoEvent;\r\nbegin\r\n Result := LogonDialogInternal.AfterTransferSessionDataToConnectionInfo;\r\nend;\r\n\r\nfunction TJvDBBaseDevartConnectDialog.GetAppStorage: TJvCustomAppStorage;\r\nbegin\r\n Result := LogonDialogInternal.AppStorage;\r\nend;\r\n\r\nfunction TJvDBBaseDevartConnectDialog.GetAppStoragePath: string;\r\nbegin\r\n Result := LogonDialogInternal.AppStoragePath;\r\nend;\r\n\r\nfunction TJvDBBaseDevartConnectDialog.GetBeforeTransferConnectionInfoToSessionData: TJvLogonDialogConnectionInfoEvent;\r\nbegin\r\n Result := LogonDialogInternal.BeforeTransferConnectionInfoToSessionData;\r\nend;\r\n\r\nfunction TJvDBBaseDevartConnectDialog.GetCurrentConnectionInfo: TJvBaseConnectionInfo;\r\nbegin\r\n Result := LogonDialogInternal.CurrentConnectionInfo;\r\nend;\r\n\r\nfunction TJvDBBaseDevartConnectDialog.GetDynControlEngine: TJvDynControlEngine;\r\nbegin\r\n Result := LogonDialogInternal.DynControlEngine\r\nend;\r\n\r\nfunction TJvDBBaseDevartConnectDialog.GetLogonDialogInternal: TJvBaseDBLogonDialog;\r\nbegin\r\n Result := FLogonDialogInternal;\r\nend;\r\n\r\nfunction TJvDBBaseDevartConnectDialog.GetOnDecryptPassword: TJvLogonDialogEncryptDecryptEvent;\r\nbegin\r\n Result := LogonDialogInternal.OnDecryptPassword;\r\nend;\r\n\r\nfunction TJvDBBaseDevartConnectDialog.GetOnEncryptPassword: TJvLogonDialogEncryptDecryptEvent;\r\nbegin\r\n Result := LogonDialogInternal.OnEncryptPassword;\r\nend;\r\n\r\nfunction TJvDBBaseDevartConnectDialog.GetOnFillDatabaseList: TJvLogonDialogFillListEvent;\r\nbegin\r\n Result := LogonDialogInternal.OnFillDatabaseList;\r\nend;\r\n\r\nfunction TJvDBBaseDevartConnectDialog.GetOnFillShortcutList: TJvLogonDialogFillListEvent;\r\nbegin\r\n Result := LogonDialogInternal.OnFillShortcutList;\r\nend;\r\n\r\nfunction TJvDBBaseDevartConnectDialog.GetOnSessionConnect: TJvLogonDialogBaseSessionEvent;\r\nbegin\r\n Result := LogonDialogInternal.OnSessionConnect;\r\nend;\r\n\r\nfunction TJvDBBaseDevartConnectDialog.GetOptions: TJvBaseDBLogonDialogOptions;\r\nbegin\r\n Result := LogonDialogInternal.Options;\r\nend;\r\n\r\nprocedure TJvDBBaseDevartConnectDialog.SetAfterTransferSessionDataToConnectionInfo(const Value:\r\n TJvLogonDialogConnectionInfoEvent);\r\nbegin\r\n LogonDialogInternal.AfterTransferSessionDataToConnectionInfo := Value;\r\nend;\r\n\r\nprocedure TJvDBBaseDevartConnectDialog.SetAppStorage(Value: TJvCustomAppStorage);\r\nbegin\r\n LogonDialogInternal.AppStorage := Value;\r\nend;\r\n\r\nprocedure TJvDBBaseDevartConnectDialog.SetAppStoragePath(Value: string);\r\nbegin\r\n LogonDialogInternal.AppStoragePath := Value;\r\nend;\r\n\r\nprocedure TJvDBBaseDevartConnectDialog.SetBeforeTransferConnectionInfoToSessionData(const Value:\r\n TJvLogonDialogConnectionInfoEvent);\r\nbegin\r\n LogonDialogInternal.BeforeTransferConnectionInfoToSessionData := Value;\r\nend;\r\n\r\nprocedure TJvDBBaseDevartConnectDialog.SetDynControlEngine(const Value: TJvDynControlEngine);\r\nbegin\r\n LogonDialogInternal.DynControlEngine := Value;\r\nend;\r\n\r\nprocedure TJvDBBaseDevartConnectDialog.SetOnDecryptPassword(const Value: TJvLogonDialogEncryptDecryptEvent);\r\nbegin\r\n LogonDialogInternal.OnDecryptPassword := Value;\r\nend;\r\n\r\nprocedure TJvDBBaseDevartConnectDialog.SetOnEncryptPassword(const Value: TJvLogonDialogEncryptDecryptEvent);\r\nbegin\r\n LogonDialogInternal.OnEncryptPassword := Value;\r\nend;\r\n\r\nprocedure TJvDBBaseDevartConnectDialog.SetOnFillDatabaseList(const Value: TJvLogonDialogFillListEvent);\r\nbegin\r\n LogonDialogInternal.OnFillDatabaseList := Value;\r\nend;\r\n\r\nprocedure TJvDBBaseDevartConnectDialog.SetOnFillShortcutList(const Value: TJvLogonDialogFillListEvent);\r\nbegin\r\n LogonDialogInternal.OnFillShortcutList := Value;\r\nend;\r\n\r\nprocedure TJvDBBaseDevartConnectDialog.SetOnSessionConnect(const Value: TJvLogonDialogBaseSessionEvent);\r\nbegin\r\n LogonDialogInternal.OnSessionConnect:= Value;\r\nend;\r\n\r\nprocedure TJvDBBaseDevartConnectDialog.SetOptions(const Value: TJvBaseDBLogonDialogOptions);\r\nbegin\r\n LogonDialogInternal.Options.Assign(Value);\r\nend;\r\n\r\n{$ENDIF USE_3RDPARTY_DEVART_DAC}\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvDBLogonDialogDoa.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvDBLogonDialogDoa.pas, released on 2006-07-21\r\n\r\nThe Initial Developer of the Original Code is Jens Fudickar\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\nJens Fudickar\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvDBLogonDialogDoa.pas 13104 2011-09-07 06:50:43Z obones $\r\n\r\nunit JvDBLogonDialogDoa;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Classes, Forms, Controls, Oracle,\r\n JvBaseDlg, JvAppStorage, JvBaseDBLogonDialog,\r\n JvDynControlEngine, JvBaseDBPasswordDialog, JvDynControlEngineIntf;\r\n\r\ntype\r\n TJvDBDoaLogonDialogOptions = class(TJvBaseDBOracleLogonDialogOptions)\r\n public\r\n constructor Create; override;\r\n published\r\n property AllowPasswordChange default True;\r\n property PasswordDialogOptions;\r\n end;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvDBDoaLogonDialog = class(TJvBaseDBOracleLogonDialog)\r\n private\r\n function GetOptions: TJvDBDoaLogonDialogOptions;\r\n function GetSession: TOracleSession;\r\n procedure SetOptions(const Value: TJvDBDoaLogonDialogOptions);\r\n procedure SetSession(const Value: TOracleSession); reintroduce;\r\n protected\r\n procedure CreateAdditionalConnectDialogControls(AOwner: TComponent;\r\n AParentControl: TWinControl); override;\r\n procedure CreateFormControls(AForm: TForm); override;\r\n function CreatePasswordChangeDialog: TJvBaseDBPasswordDialog; override;\r\n procedure FillDatabaseComboBoxDefaultValues(Items: TStrings); override;\r\n { Retrieve the class that holds the storage options and format settings. }\r\n class function GetDBLogonDialogOptionsClass: TJvBaseDBLogonDialogOptionsClass; override;\r\n procedure HandleExpiredPassword(const ErrorMessage: string);\r\n procedure ResizeFormControls; override;\r\n procedure TransferConnectionInfoFromDialog(ConnectionInfo: TJvBaseConnectionInfo); override;\r\n procedure TransferConnectionInfoToDialog(ConnectionInfo: TJvBaseConnectionInfo); override;\r\n procedure TransferSessionDataFromConnectionInfo(ConnectionInfo: TJvBaseConnectionInfo); override;\r\n procedure TransferSessionDataToConnectionInfo(ConnectionInfo: TJvBaseConnectionInfo); override;\r\n public\r\n procedure ClearControlInterfaceObjects; override;\r\n procedure ConnectSession; override;\r\n function SessionIsConnected: Boolean; override;\r\n published\r\n property Options: TJvDBDoaLogonDialogOptions read GetOptions write SetOptions;\r\n property Session: TOracleSession read GetSession write SetSession;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvDBLogonDialogDoa.pas $';\r\n Revision: '$Revision: 13104 $';\r\n Date: '$Date: 2011-09-07 08:50:43 +0200 (mer. 07 sept. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n SysUtils, StdCtrls, Dialogs,\r\n JvDSADialogs, JvDBPasswordDialogDoa, JvResources;\r\n\r\n//=== { TJvDBDoaLogonDialogOptions } =========================================\r\n\r\nconstructor TJvDBDoaLogonDialogOptions.Create;\r\nbegin\r\n inherited Create;\r\n AllowPasswordChange := True;\r\nend;\r\n\r\n//=== { TJvDBDoaLogonDialog } ================================================\r\n\r\nprocedure TJvDBDoaLogonDialog.ClearControlInterfaceObjects;\r\nbegin\r\n inherited ClearControlInterfaceObjects;\r\nend;\r\n\r\nprocedure TJvDBDoaLogonDialog.ConnectSession;\r\nbegin\r\n if Assigned(Session) then\r\n try\r\n Session.LogOff;\r\n Session.LogOn;\r\n except\r\n on E: EOracleError do\r\n begin\r\n case E.ErrorCode of\r\n 1005, 1017:\r\n ActivatePasswordControl;\r\n 12203, 12154:\r\n ActivateDatabaseControl;\r\n end;\r\n if (E.ErrorCode = 28001) or (E.ErrorCode = 28002) or (E.ErrorCode = 28011) then\r\n HandleExpiredPassword(E.Message)\r\n else\r\n JvDSADialogs.MessageDlg(E.Message, mtError, [mbok], 0, dckScreen,\r\n 0, mbDefault, mbDefault, mbDefault, DynControlEngine);\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvDBDoaLogonDialog.CreateAdditionalConnectDialogControls(AOwner: TComponent;\r\n AParentControl: TWinControl);\r\nbegin\r\n inherited CreateAdditionalConnectDialogControls(AOwner, AParentControl);\r\nend;\r\n\r\nprocedure TJvDBDoaLogonDialog.CreateFormControls(AForm: TForm);\r\nbegin\r\n inherited CreateFormControls(AForm);\r\nend;\r\n\r\nfunction TJvDBDoaLogonDialog.CreatePasswordChangeDialog: TJvBaseDBPasswordDialog;\r\nbegin\r\n Result := TJvDBDoaPasswordDialog.Create(Self);\r\nend;\r\n\r\nprocedure TJvDBDoaLogonDialog.FillDatabaseComboBoxDefaultValues(Items: TStrings);\r\nbegin\r\n\r\nend;\r\n\r\nclass function TJvDBDoaLogonDialog.GetDBLogonDialogOptionsClass: TJvBaseDBLogonDialogOptionsClass;\r\nbegin\r\n Result := TJvDBDoaLogonDialogOptions;\r\nend;\r\n\r\nfunction TJvDBDoaLogonDialog.GetOptions: TJvDBDoaLogonDialogOptions;\r\nbegin\r\n Result := TJvDBDoaLogonDialogOptions(inherited Options);\r\nend;\r\n\r\nfunction TJvDBDoaLogonDialog.GetSession: TOracleSession;\r\nbegin\r\n Result := TOracleSession(inherited Session);\r\nend;\r\n\r\nprocedure TJvDBDoaLogonDialog.HandleExpiredPassword(const ErrorMessage:\r\n string);\r\nbegin\r\n if JvDSADialogs.MessageDlg(ErrorMessage + #13#10 + RsDoYouWantToChangePassword,\r\n mtInformation, [mbYes, mbNo], 0, dckScreen,\r\n 0, mbDefault, mbDefault, mbDefault, DynControlEngine) = mrYes then\r\n if ChangePassword then\r\n if not SessionIsConnected then\r\n Session.LogOn;\r\nend;\r\n\r\nprocedure TJvDBDoaLogonDialog.ResizeFormControls;\r\nbegin\r\n inherited ResizeFormControls;\r\nend;\r\n\r\nfunction TJvDBDoaLogonDialog.SessionIsConnected: Boolean;\r\nbegin\r\n Result := Session.Connected;\r\nend;\r\n\r\nprocedure TJvDBDoaLogonDialog.SetOptions(const Value: TJvDBDoaLogonDialogOptions);\r\nbegin\r\n (inherited Options).Assign(Value);\r\nend;\r\n\r\nprocedure TJvDBDoaLogonDialog.SetSession(const Value: TOracleSession);\r\nbegin\r\n inherited SetSession(Value);\r\nend;\r\n\r\nprocedure TJvDBDoaLogonDialog.TransferConnectionInfoFromDialog(ConnectionInfo: TJvBaseConnectionInfo);\r\nbegin\r\n inherited TransferConnectionInfoFromDialog(ConnectionInfo);\r\nend;\r\n\r\nprocedure TJvDBDoaLogonDialog.TransferConnectionInfoToDialog(ConnectionInfo: TJvBaseConnectionInfo);\r\nbegin\r\n inherited TransferConnectionInfoToDialog(ConnectionInfo);\r\nend;\r\n\r\nprocedure TJvDBDoaLogonDialog.TransferSessionDataFromConnectionInfo(ConnectionInfo: TJvBaseConnectionInfo);\r\nbegin\r\n if Assigned(Session) then\r\n begin\r\n Session.LogonDatabase := ConnectionInfo.Database;\r\n Session.LogonPassword := ConnectionInfo.Password;\r\n Session.LogonUsername := ConnectionInfo.Username;\r\n if TJvBaseOracleConnectionInfo(ConnectionInfo).ConnectAs = 'SYSDBA' then\r\n Session.ConnectAs := caSYSDBA\r\n else\r\n if TJvBaseOracleConnectionInfo(ConnectionInfo).ConnectAs = 'SYSOPER' then\r\n Session.ConnectAs := caSYSOper\r\n else\r\n Session.ConnectAs := caNormal;\r\n end;\r\nend;\r\n\r\nprocedure TJvDBDoaLogonDialog.TransferSessionDataToConnectionInfo(ConnectionInfo: TJvBaseConnectionInfo);\r\nbegin\r\n if Assigned(Session) then\r\n begin\r\n ConnectionInfo.Database := Session.LogonDatabase;\r\n ConnectionInfo.Password := Session.LogonPassword;\r\n ConnectionInfo.Username := Session.LogonUsername;\r\n case Session.Connectas of\r\n caSYSDBA:\r\n TJvBaseOracleConnectionInfo(ConnectionInfo).ConnectAs := 'SYSDBA';\r\n caSYSOPER:\r\n TJvBaseOracleConnectionInfo(ConnectionInfo).ConnectAs := 'SYSOPER';\r\n else\r\n TJvBaseOracleConnectionInfo(ConnectionInfo).ConnectAs := 'NORMAL';\r\n end;\r\n end;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvDBLogonDialogOdac.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvDBLogonDialogOdac.pas, released on 2006-07-21.\r\n\r\nThe Initial Developer of the Original Code is Jens Fudickar\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\nJens Fudickar\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvDBLogonDialogOdac.pas 13379 2012-07-08 20:33:32Z jfudickar $\r\n\r\nunit JvDBLogonDialogOdac;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n {$IFDEF USE_3RDPARTY_DEVART_ODAC}\r\n Classes, Forms, Controls, DBAccess, Ora,\r\n JvAppStorage, JvBaseDBLogonDialog,\r\n JvDynControlEngine, JvBaseDBPasswordDialog,\r\n {$ENDIF USE_3RDPARTY_DEVART_ODAC}\r\n JvDynControlEngineIntf, JvDBLogonDialogBaseDevart;\r\n\r\n{$IFDEF USE_3RDPARTY_DEVART_ODAC}\r\ntype\r\n\r\n TJvOdacOracleConnectionInfo = class(TJvBaseOracleConnectionInfo)\r\n private\r\n FNet: Boolean;\r\n FOracleHome: string;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n function ConnectString: string; override;\r\n published\r\n property Net: Boolean read FNet write FNet default false;\r\n property OracleHome: string read FOracleHome write FOracleHome;\r\n end;\r\n\r\n TJvOdacOracleConnectionList = class(TJvBaseOracleConnectionList)\r\n protected\r\n function CreateObject: TPersistent; override;\r\n function GetConnection(I: Longint): TJvOdacOracleConnectionInfo;\r\n public\r\n property Connection[I: Longint]: TJvOdacOracleConnectionInfo read GetConnection;\r\n end;\r\n\r\n TJvDBOdacLogonDialogOptions = class(TJvBaseDBOracleLogonDialogOptions)\r\n private\r\n FShowNetOption: Boolean;\r\n FShowOracleHome: Boolean;\r\n public\r\n constructor Create; override;\r\n published\r\n property AllowPasswordChange default True;\r\n property PasswordDialogOptions;\r\n property ShowNetOption: Boolean read FShowNetOption write FShowNetOption default True;\r\n property ShowOracleHome: Boolean read FShowOracleHome write FShowOracleHome default False;\r\n end;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvDBOdacLogonDialog = class(TJvBaseDBOracleLogonDialog)\r\n private\r\n FOraSession: TOraSession;\r\n INetOptionCheckBox: IJvDynControlCheckBox;\r\n IOracleHomeEditData: IJvDynControlData;\r\n NetOptionCheckBox: TWinControl;\r\n OracleHomeEdit: TWinControl;\r\n OracleHomePanel: TWinControl;\r\n function GetConnectionList: TJvOdacOracleConnectionList;\r\n function GetOptions: TJvDBOdacLogonDialogOptions;\r\n function GetOraSession: TOraSession;\r\n procedure SetOptions(const Value: TJvDBOdacLogonDialogOptions);\r\n protected\r\n procedure CreateAdditionalConnectDialogControls(AOwner: TComponent; AParentControl: TWinControl); override;\r\n procedure CreateFormControls(AForm: TForm); override;\r\n function CreatePasswordChangeDialog: TJvBaseDBPasswordDialog; override;\r\n procedure FillAllComoboBoxes; override;\r\n procedure FillDatabaseComboBoxValues(Items: TStrings); override;\r\n procedure FillOracleHomeComboBox;\r\n { Retrieve the class that holds the storage options and format settings. }\r\n class function GetDBLogonConnectionListClass: TJvBaseConnectionListClass; override;\r\n { Retrieve the class that holds the storage options and format settings. }\r\n class function GetDBLogonDialogOptionsClass: TJvBaseDBLogonDialogOptionsClass; override;\r\n procedure HandleExpiredPassword(const ErrorMessage: string);\r\n procedure SetEditPanelsVisibility; override;\r\n procedure SetSession(const Value: TComponent); override;\r\n procedure TransferConnectionInfoFromDialog(ConnectionInfo: TJvBaseConnectionInfo); override;\r\n procedure TransferConnectionInfoToDialog(ConnectionInfo: TJvBaseConnectionInfo); override;\r\n procedure TransferSessionDataFromConnectionInfo(ConnectionInfo: TJvBaseConnectionInfo); override;\r\n procedure TransferSessionDataToConnectionInfo(ConnectionInfo: TJvBaseConnectionInfo); override;\r\n property ConnectionList: TJvOdacOracleConnectionList read GetConnectionList;\r\n property OraSession: TOraSession read GetOraSession;\r\n public\r\n procedure ClearControlInterfaceObjects; override;\r\n procedure ConnectSession; override;\r\n function SessionIsConnected: Boolean; override;\r\n published\r\n property Options: TJvDBOdacLogonDialogOptions read GetOptions write SetOptions;\r\n end;\r\n\r\n TJvDBOdacConnectDialog = class(TJvDBBaseDevartConnectDialog)\r\n private\r\n FOnFillDatabaseList: TJvLogonDialogFillListEvent;\r\n function GetLogonDialogInternal: TJvDBOdacLogonDialog; reintroduce; virtual;\r\n protected\r\n function CreateLogonDialogInternal: TJvBaseDBLogonDialog; override;\r\n function GetOptions: TJvDBOdacLogonDialogOptions; reintroduce; virtual;\r\n procedure SetOptions(const Value: TJvDBOdacLogonDialogOptions); reintroduce; virtual;\r\n property LogonDialogInternal: TJvDBOdacLogonDialog read GetLogonDialogInternal;\r\n published\r\n procedure InternalFillDatabaseList(List: TStringList);\r\n property Options: TJvDBOdacLogonDialogOptions read GetOptions write SetOptions;\r\n //1 Event for filling the database list\r\n property OnFillDatabaseList: TJvLogonDialogFillListEvent read FOnFillDatabaseList write FOnFillDatabaseList;\r\n end;\r\n{$ENDIF USE_3RDPARTY_DEVART_ODAC}\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvDBLogonDialogOdac.pas $';\r\n Revision: '$Revision: 13379 $';\r\n Date: '$Date: 2012-07-08 22:33:32 +0200 (dim. 08 juil. 2012) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\n{$IFDEF USE_3RDPARTY_DEVART_ODAC}\r\nuses\r\n SysUtils, StdCtrls, Dialogs,\r\n OraClasses, OraError, OraCall, OraServices,\r\n JvDSADialogs, JvDBPasswordDialogOdac, JvResources;\r\n\r\n//=== { TJvDBOdacLogonDialogOptions } ========================================\r\n\r\nconstructor TJvDBOdacLogonDialogOptions.Create;\r\nbegin\r\n inherited Create;\r\n FShowNetOption := True;\r\n AllowPasswordChange := True;\r\n FShowOracleHome := False;\r\nend;\r\n\r\nfunction TJvDBOdacConnectDialog.CreateLogonDialogInternal: TJvBaseDBLogonDialog;\r\nbegin\r\n Result := TJvDBOdacLogonDialog.Create(Self);\r\n TJvDBOdacLogonDialog(Result).OnFillDatabaseList := InternalFillDatabaseList;\r\nend;\r\n\r\nfunction TJvDBOdacConnectDialog.GetLogonDialogInternal: TJvDBOdacLogonDialog;\r\nbegin\r\n Result := TJvDBOdacLogonDialog(inherited GetLogonDialogInternal);\r\nend;\r\n\r\nfunction TJvDBOdacConnectDialog.GetOptions: TJvDBOdacLogonDialogOptions;\r\nbegin\r\n Result := LogonDialogInternal.Options;\r\nend;\r\n\r\nprocedure TJvDBOdacConnectDialog.InternalFillDatabaseList(List: TStringList);\r\nbegin\r\n GetServerList(List);\r\n if Assigned(OnFillDatabaseList) then\r\n OnFillDatabaseList(List);\r\nend;\r\n\r\nprocedure TJvDBOdacConnectDialog.SetOptions(const Value: TJvDBOdacLogonDialogOptions);\r\nbegin\r\n LogonDialogInternal.Options.Assign(Value);\r\nend;\r\n\r\nprocedure TJvDBOdacLogonDialog.ClearControlInterfaceObjects;\r\nbegin\r\n inherited ClearControlInterfaceObjects;\r\n INetOptionCheckBox:= nil;\r\n IOracleHomeEditData:= nil;\r\nend;\r\n\r\nprocedure TJvDBOdacLogonDialog.ConnectSession;\r\nbegin\r\n if Assigned(Session) then\r\n try\r\n OraSession.DisConnect;\r\n OraSession.PerformConnect;\r\n except\r\n on E: EOraError do\r\n begin\r\n case E.ErrorCode of\r\n 1005, 1017:\r\n ActivatePasswordControl;\r\n 12203, 12154:\r\n ActivateDatabaseControl;\r\n end;\r\n if (E.ErrorCode = 28001) or (E.ErrorCode = 28002) or (E.ErrorCode = 28011) then\r\n HandleExpiredPassword(E.Message)\r\n else\r\n JvDSADialogs.MessageDlg(E.Message, mtError, [mbok], 0, dckScreen,\r\n 0, mbDefault, mbDefault, mbDefault, DynControlEngine);\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvDBOdacLogonDialog.CreateAdditionalConnectDialogControls(AOwner: TComponent; AParentControl: TWinControl);\r\nvar\r\n IDynControlComboBox: IJvDynControlComboBox;\r\nbegin\r\n inherited CreateAdditionalConnectDialogControls (AOwner, AParentControl);\r\n CreateAdditionalConnectDialogEditPanel(AOwner, AParentControl, 'OracleHome', RsOracleHome, jctComboBox, OracleHomePanel, OracleHomeEdit, IOracleHomeEditData, DefaultOnEditChange);\r\n if Supports(OracleHomeEdit, IJvDynControlComboBox, IDynControlComboBox) then\r\n IDynControlComboBox.ControlSetNewEntriesAllowed(False);\r\n\r\n NetOptionCheckBox := DynControlEngine.CreateCheckboxControl(AOwner,AParentControl, 'NetOptionCheckBox',\r\n RsUseNetOptionForDirectConnect);\r\n AlignControlTop(NetOptionCheckBox, OracleHomePanel);\r\n NetOptionCheckBox.Visible := Options.ShowNetOption;\r\n Supports(NetOptionCheckBox, IJvDynControlCheckBox, INetOptionCheckBox);\r\n NetOptionCheckBox.Hint := RsNetOptionCheckBoxHint;\r\nend;\r\n\r\nprocedure TJvDBOdacLogonDialog.CreateFormControls(AForm: TForm);\r\nbegin\r\n inherited CreateFormControls(AForm);\r\nend;\r\n\r\nfunction TJvDBOdacLogonDialog.CreatePasswordChangeDialog:\r\n TJvBaseDBPasswordDialog;\r\nbegin\r\n Result := TJvDBOdacPasswordDialog.Create(Self);\r\nend;\r\n\r\nprocedure TJvDBOdacLogonDialog.FillAllComoboBoxes;\r\nbegin\r\n inherited FillAllComoboBoxes;\r\n FillOracleHomeComboBox;\r\nend;\r\n\r\nprocedure TJvDBOdacLogonDialog.FillDatabaseComboBoxValues(Items: TStrings);\r\nvar\r\n Enum: TOraServerEnumerator;\r\n List: TStringList;\r\nbegin\r\n List := TStringList.Create;\r\n Enum := TOraServerEnumerator.Create;\r\n try\r\n Enum.GetServerList(List);\r\n Items.AddStrings(List);\r\n finally\r\n Enum.Free;\r\n List.Free;\r\n end;\r\nend;\r\n\r\nprocedure TJvDBOdacLogonDialog.FillOracleHomeComboBox;\r\nvar\r\n Items: TStringList;\r\n IDynControlItems: IJvDynControlItems;\r\n i : Integer;\r\nbegin\r\n Items := TStringList.Create;\r\n try\r\n for i := 0 to OracleHomeCount - 1 do\r\n Items.Add(OracleHomeNames[i]);\r\n if Supports(OracleHomeEdit, IJvDynControlItems, IDynControlItems) then\r\n IDynControlItems.ControlItems.Assign(Items);\r\n finally\r\n Items.Free;\r\n end;\r\nend;\r\n\r\nfunction TJvDBOdacLogonDialog.GetConnectionList: TJvOdacOracleConnectionList;\r\nbegin\r\n Result := TJvOdacOracleConnectionList(Inherited ConnectionList);\r\nend;\r\n\r\nclass function TJvDBOdacLogonDialog.GetDBLogonConnectionListClass: TJvBaseConnectionListClass;\r\nbegin\r\n Result := TJvOdacOracleConnectionList;\r\nend;\r\n\r\nclass function TJvDBOdacLogonDialog.GetDBLogonDialogOptionsClass: TJvBaseDBLogonDialogOptionsClass;\r\nbegin\r\n Result := TJvDBOdacLogonDialogOptions;\r\nend;\r\n\r\nfunction TJvDBOdacLogonDialog.GetOptions: TJvDBOdacLogonDialogOptions;\r\nbegin\r\n Result := TJvDBOdacLogonDialogOptions(inherited Options);\r\nend;\r\n\r\nfunction TJvDBOdacLogonDialog.GetOraSession: TOraSession;\r\nbegin\r\n Result := FOraSession;\r\nend;\r\n\r\nprocedure TJvDBOdacLogonDialog.HandleExpiredPassword(const ErrorMessage: string);\r\nbegin\r\n if JvDSADialogs.MessageDlg(ErrorMessage + #13#10 + RsDoYouWantToChangePassword,\r\n mtInformation, [mbYes, mbNo], 0, dckScreen, 0, mbDefault, mbDefault, mbDefault, DynControlEngine) = mrYes then\r\n if ChangePassword then\r\n if not SessionIsConnected then\r\n OraSession.PerformConnect;\r\nend;\r\n\r\nfunction TJvDBOdacLogonDialog.SessionIsConnected: Boolean;\r\nbegin\r\n Result := OraSession.Connected;\r\nend;\r\n\r\nprocedure TJvDBOdacLogonDialog.SetEditPanelsVisibility;\r\nbegin\r\n Inherited SetEditPanelsVisibility;\r\n SetPanelVisible(OracleHomePanel, Options.ShowOracleHome);\r\n NetOptionCheckBox.Visible := Options.ShowNetOption;\r\nend;\r\n\r\nprocedure TJvDBOdacLogonDialog.SetOptions(const Value: TJvDBOdacLogonDialogOptions);\r\nbegin\r\n (inherited Options).Assign(Value);\r\nend;\r\n\r\nprocedure TJvDBOdacLogonDialog.SetSession(const Value: TComponent);\r\nbegin\r\n inherited SetSession(Value);\r\n if Value is TOraSession then\r\n FOraSession := TOraSession(Value)\r\n else\r\n FOraSession := nil;\r\nend;\r\n\r\nprocedure TJvDBOdacLogonDialog.TransferConnectionInfoFromDialog(ConnectionInfo: TJvBaseConnectionInfo);\r\nbegin\r\n inherited TransferConnectionInfoFromDialog(ConnectionInfo);\r\n if (ConnectionInfo is TJvOdacOracleConnectionInfo) then\r\n begin\r\n if Assigned (INetOptionCheckBox) then\r\n TJvOdacOracleConnectionInfo(ConnectionInfo).Net := INetOptionCheckBox.ControlState = cbChecked\r\n else\r\n TJvOdacOracleConnectionInfo(ConnectionInfo).Net := False;\r\n if Assigned (IOracleHomeEditData) then\r\n TJvOdacOracleConnectionInfo(ConnectionInfo).OracleHome := IOracleHomeEditData.ControlValue\r\n else\r\n TJvOdacOracleConnectionInfo(ConnectionInfo).OracleHome := '';\r\n end;\r\nend;\r\n\r\nprocedure TJvDBOdacLogonDialog.TransferConnectionInfoToDialog(ConnectionInfo: TJvBaseConnectionInfo);\r\nbegin\r\n inherited TransferConnectionInfoToDialog(ConnectionInfo);\r\n if (ConnectionInfo is TJvOdacOracleConnectionInfo) then\r\n begin\r\n if Assigned (INetOptionCheckBox) then\r\n if TJvOdacOracleConnectionInfo(ConnectionInfo).Net then\r\n INetOptionCheckBox.ControlState := cbChecked\r\n else\r\n INetOptionCheckBox.ControlState := cbunChecked;\r\n if Assigned (IOracleHomeEditData) then\r\n IOracleHomeEditData.ControlValue := TJvOdacOracleConnectionInfo(ConnectionInfo).OracleHome;\r\n end;\r\nend;\r\n\r\nprocedure TJvDBOdacLogonDialog.TransferSessionDataFromConnectionInfo(ConnectionInfo: TJvBaseConnectionInfo);\r\nbegin\r\n if Assigned(Session) then\r\n begin\r\n OraSession.Server := ConnectionInfo.Database;\r\n OraSession.Password := ConnectionInfo.Password;\r\n OraSession.Username := ConnectionInfo.Username;\r\n if Assigned(OraSession) and (ConnectionInfo is TJvBaseOracleConnectionInfo) then\r\n begin\r\n if TJvBaseOracleConnectionInfo(ConnectionInfo).ConnectAs = 'SYSDBA' then\r\n OraSession.ConnectMode := cmSYSDBA\r\n else\r\n if TJvBaseOracleConnectionInfo(ConnectionInfo).ConnectAs = 'SYSASM' then\r\n OraSession.ConnectMode := cmSYSASM\r\n else\r\n if TJvBaseOracleConnectionInfo(ConnectionInfo).ConnectAs = 'SYSOPER' then\r\n OraSession.ConnectMode := cmSYSOper\r\n else\r\n OraSession.ConnectMode := cmNormal;\r\n if (ConnectionInfo is TJvOdacOracleConnectionInfo) then\r\n begin\r\n if Options.ShowNetOption then\r\n OraSession.Options.Net := TJvOdacOracleConnectionInfo(ConnectionInfo).Net;\r\n if Options.ShowOracleHome then\r\n OraSession.HomeName := TJvOdacOracleConnectionInfo(ConnectionInfo).OracleHome;\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvDBOdacLogonDialog.TransferSessionDataToConnectionInfo(ConnectionInfo: TJvBaseConnectionInfo);\r\nbegin\r\n if Assigned(Session) then\r\n begin\r\n ConnectionInfo.Database := OraSession.Server;\r\n ConnectionInfo.Password := OraSession.Password;\r\n ConnectionInfo.Username := OraSession.Username;\r\n if Assigned(OraSession) and (ConnectionInfo is TJvBaseOracleConnectionInfo) then\r\n begin\r\n case OraSession.ConnectMode of\r\n cmSYSDBA:\r\n TJvBaseOracleConnectionInfo(ConnectionInfo).ConnectAs := 'SYSDBA';\r\n cmSYSASM:\r\n TJvBaseOracleConnectionInfo(ConnectionInfo).ConnectAs := 'SYSASM';\r\n cmSYSOPER:\r\n TJvBaseOracleConnectionInfo(ConnectionInfo).ConnectAs := 'SYSOPER';\r\n else\r\n TJvBaseOracleConnectionInfo(ConnectionInfo).ConnectAs := 'NORMAL';\r\n end;\r\n if (ConnectionInfo is TJvOdacOracleConnectionInfo) then\r\n begin\r\n if Options.ShowNetOption then\r\n TJvOdacOracleConnectionInfo(ConnectionInfo).net := OraSession.Options.net;\r\n if Options.ShowOracleHome and Assigned (IOracleHomeEditData) then\r\n TJvOdacOracleConnectionInfo(ConnectionInfo).OracleHome := OraSession.HomeName;\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJvOdacOracleConnectionList.CreateObject: TPersistent;\r\nbegin\r\n Result := TJvOdacOracleConnectionInfo.Create(Self);\r\nend;\r\n\r\nfunction TJvOdacOracleConnectionList.GetConnection(I: Longint): TJvOdacOracleConnectionInfo;\r\nbegin\r\n Result := TJvOdacOracleConnectionInfo(inherited Connection[i])\r\nend;\r\n\r\nconstructor TJvOdacOracleConnectionInfo.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FNet := false;\r\nend;\r\n\r\nfunction TJvOdacOracleConnectionInfo.ConnectString: string;\r\nbegin\r\n Result := inherited ConnectString;\r\n if OracleHome <> '' then\r\n Result:= Result + ' - '+OracleHome;\r\n if Net then\r\n Result := Result + ' - '+RsNetOptionConnectionList;\r\nend;\r\n{$ENDIF USE_3RDPARTY_DEVART_ODAC}\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvDBLogonDialogUniDac.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvDBLogonDialogUniDac.pas, released on 2006-07-21.\r\n\r\nThe Initial Developer of the Original Code is Jens Fudickar\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\nJens Fudickar\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvDBLogonDialogUniDac.pas 13371 2012-06-23 15:46:57Z jfudickar $\r\n\r\nunit JvDBLogonDialogUniDac;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n {$IFDEF USE_3RDPARTY_DEVART_UNIDAC}\r\n Classes, Forms, Controls, DBAccess, Uni, UniProvider, UniDacVcl,\r\n JvAppStorage, JvBaseDBLogonDialog,\r\n JvDynControlEngine, JvBaseDBPasswordDialog,\r\n {$ENDIF USE_3RDPARTY_DEVART_UNIDAC}\r\n JvDynControlEngineIntf, JvDBLogonDialogBaseDevart;\r\n\r\n{$IFDEF USE_3RDPARTY_DEVART_UNIDAC}\r\ntype\r\n TJvUniDacLogonDialogFillListEvent = procedure(const Provider : string;List: TStringList) of object;\r\n\r\n TJvUniDacConnectionInfo = class(TJvBaseOracleConnectionInfo)\r\n private\r\n FDatabaseEnabled: Boolean;\r\n FUserNameEnabled: Boolean;\r\n FPasswordEnabled: Boolean;\r\n FServerEnabled: Boolean;\r\n FPortEnabled: Boolean;\r\n FDirect: Boolean;\r\n FOracleHome: string;\r\n FPort: Integer;\r\n FProvider: String;\r\n FServer: String;\r\n FUniConnection: TUniConnection;\r\n procedure RecalculateEnabledProperties;\r\n procedure SetOracleHome(const Value: string);\r\n procedure SetProvider(const Value: String);\r\n procedure SetServer(const Value: String);\r\n procedure SetUniConnection(const Value: TUniConnection);\r\n protected\r\n function GetAliasEnabled: Boolean; override;\r\n function GetConnectAsEnabled: Boolean; override;\r\n function GetDatabaseEnabled: Boolean; override;\r\n function GetServerEnabled: Boolean; virtual;\r\n function GetPortEnabled: Boolean; virtual;\r\n function GetOracleHomeEnabled: Boolean; virtual;\r\n function GetDirectEnabled: Boolean; virtual;\r\n function GetPasswordEnabled: Boolean; override;\r\n function GetUsernameEnabled: Boolean; override;\r\n procedure Notification(AComponent: TComponent; Operation: TOperation); override;\r\n //1 This function is to identify the connection info in the connection list\r\n function SearchName: String; override;\r\n property ServerEnabled: Boolean read GetServerEnabled;\r\n property PortEnabled: Boolean read GetPortEnabled;\r\n property OracleHomeEnabled: Boolean read GetOracleHomeEnabled;\r\n property DirectEnabled: Boolean read GetDirectEnabled;\r\n property UniConnection: TUniConnection read FUniConnection write SetUniConnection;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n function ConnectString: string; override;\r\n function DatabaseGroupIdentifier: string; override;\r\n function IsConnectAllowed(AllowNullPasswords: Boolean): Boolean; override;\r\n published\r\n property Direct: Boolean read FDirect write FDirect;\r\n property OracleHome: string read FOracleHome write SetOracleHome;\r\n property Port: Integer read FPort write FPort;\r\n property Provider: String read FProvider write SetProvider;\r\n property Server: String read FServer write SetServer;\r\n end;\r\n\r\n TJvUniDacConnectionList = class(TJvBaseConnectionList)\r\n private\r\n FUniConnection: TUniConnection;\r\n procedure SetUniConnection(const Value: TUniConnection);\r\n protected\r\n function CreateObject: TPersistent; override;\r\n function GetConnection(I: Longint): TJvUniDacConnectionInfo;\r\n procedure Notification(AComponent: TComponent; Operation: TOperation); override;\r\n property UniConnection: TUniConnection read FUniConnection write SetUniConnection;\r\n public\r\n property Connection[I: Longint]: TJvUniDacConnectionInfo read GetConnection;\r\n end;\r\n\r\n TJvDBUniDacLogonDialogOptions = class(TJvBaseDBOracleLogonDialogOptions)\r\n private\r\n FShowDirectConnect: Boolean;\r\n FShowOracleHome: Boolean;\r\n public\r\n constructor Create; override;\r\n published\r\n// property AllowPasswordChange default True;\r\n// property PasswordDialogOptions;\r\n property ShowDirectConnect: Boolean read FShowDirectConnect write FShowDirectConnect default True;\r\n property ShowOracleHome: Boolean read FShowOracleHome write FShowOracleHome default False;\r\n end;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvDBUniDacLogonDialog = class(TJvBaseDBOracleLogonDialog)\r\n private\r\n DirectCheckBox: TWinControl;\r\n FInternalConnectDialog: TUniConnectDialog;\r\n FInternalConnection: TUniConnection;\r\n FOnFillServerList: TJvUniDacLogonDialogFillListEvent;\r\n FUniConnection: TUniConnection;\r\n IDirectCheckBox: IJvDynControlCheckBox;\r\n IOracleHomeEditData: IJvDynControlData;\r\n IOracleHomeEditItems: IJvDynControlItems;\r\n IPortEditData: IJvDynControlData;\r\n IProviderEditData: IJvDynControlData;\r\n IProviderEditItems: IJvDynControlItems;\r\n IServerEditData: IJvDynControlData;\r\n IServerEditItems: IJvDynControlItems;\r\n OracleHomeEdit: TWinControl;\r\n OracleHomePanel: TWinControl;\r\n PortEdit: TWinControl;\r\n PortPanel: TWinControl;\r\n ProviderEdit: TWinControl;\r\n ProviderPanel: TWinControl;\r\n ServerEdit: TWinControl;\r\n ServerPanel: TWinControl;\r\n function GetConnectionList: TJvUniDacConnectionList;\r\n function GetCurrentConnectionInfo: TJvUniDacConnectionInfo;\r\n function GetOptions: TJvDBUniDacLogonDialogOptions;\r\n function GetUniConnection: TUniConnection;\r\n procedure SetOptions(const Value: TJvDBUniDacLogonDialogOptions);\r\n property InternalConnectDialog: TUniConnectDialog read FInternalConnectDialog;\r\n property InternalConnection: TUniConnection read FInternalConnection;\r\n protected\r\n procedure CreateAdditionalConnectDialogControls(AOwner: TComponent; AParentControl: TWinControl); override;\r\n procedure CreateFormControls(AForm: TForm); override;\r\n procedure FillAllComoboBoxes; override;\r\n procedure FillDatabaseComboBoxValues(Items: TStrings); override;\r\n procedure FillServerComboBox;\r\n procedure FillServerComboBoxValues(Items: TStrings); virtual;\r\n { Retrieve the class that holds the storage options and format settings. }\r\n class function GetDBLogonConnectionListClass: TJvBaseConnectionListClass; override;\r\n { Retrieve the class that holds the storage options and format settings. }\r\n class function GetDBLogonDialogOptionsClass: TJvBaseDBLogonDialogOptionsClass; override;\r\n procedure HandleExpiredPassword(const ErrorMessage: string);\r\n procedure ProviderOnEditChange(Sender: TObject);\r\n procedure SetEditPanelsTabOrder; override;\r\n procedure SetEditPanelsVisibility; override;\r\n procedure SetSession(const Value: TComponent); override;\r\n procedure TransferConnectionInfoFromDialog(ConnectionInfo: TJvBaseConnectionInfo); override;\r\n procedure TransferConnectionInfoToDialog(ConnectionInfo: TJvBaseConnectionInfo); override;\r\n procedure TransferSessionDataFromConnectionInfo(ConnectionInfo: TJvBaseConnectionInfo); override;\r\n procedure TransferSessionDataToConnectionInfo(ConnectionInfo: TJvBaseConnectionInfo); override;\r\n property ConnectionList: TJvUniDacConnectionList read GetConnectionList;\r\n property UniConnection: TUniConnection read GetUniConnection;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n procedure ClearControlInterfaceObjects; override;\r\n procedure ConnectSession; override;\r\n function SessionIsConnected: Boolean; override;\r\n property CurrentConnectionInfo: TJvUniDacConnectionInfo read GetCurrentConnectionInfo;\r\n published\r\n property Options: TJvDBUniDacLogonDialogOptions read GetOptions write SetOptions;\r\n property OnFillServerList: TJvUniDacLogonDialogFillListEvent read FOnFillServerList write FOnFillServerList;\r\n end;\r\n\r\n TJvDBUniDacConnectDialog = class(TJvDBBaseDevartConnectDialog)\r\n private\r\n FOnFillDatabaseList: TJvLogonDialogFillListEvent;\r\n FOnFillServerList: TJvLogonDialogFillListEvent;\r\n protected\r\n function CreateLogonDialogInternal: TJvBaseDBLogonDialog; override;\r\n published\r\n procedure InternalFillDatabaseList(List: TStringList);\r\n //1 Event for filling the database list\r\n property OnFillDatabaseList: TJvLogonDialogFillListEvent read FOnFillDatabaseList write FOnFillDatabaseList;\r\n //1 Event for filling the server list\r\n property OnFillServerList: TJvLogonDialogFillListEvent read FOnFillServerList write FOnFillServerList;\r\n end;\r\n{$ENDIF USE_3RDPARTY_DEVART_UNIDAC}\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/trunk/jvcl/run/JvDBLogonDialogUniDac.pas $';\r\n Revision: '$Revision: 13371 $';\r\n Date: '$Date: 2012-06-23 17:46:57 +0200 (Sa, 23 Jun 2012) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\n{$IFDEF USE_3RDPARTY_DEVART_UNIDAC}\r\nuses\r\n SysUtils, StdCtrls, Dialogs,\r\n OraClasses, OraError, OraCall, OraServices,\r\n JvDSADialogs, JvResources, JvJVCLUtils;\r\n\r\n//=== { TJvDBOdacLogonDialogOptions } ========================================\r\n\r\n\r\nconstructor TJvDBUniDacLogonDialogOptions.Create;\r\nbegin\r\n inherited Create;\r\n FShowDirectConnect := True;\r\n// AllowPasswordChange := True;\r\n FShowOracleHome := False;\r\nend;\r\n\r\nfunction TJvDBUniDacConnectDialog.CreateLogonDialogInternal: TJvBaseDBLogonDialog;\r\nbegin\r\n Result := TJvDBUniDacLogonDialog.Create(Self);\r\n TJvDBUniDacLogonDialog(Result).OnFillDatabaseList := InternalFillDatabaseList;\r\nend;\r\n\r\nprocedure TJvDBUniDacConnectDialog.InternalFillDatabaseList(List: TStringList);\r\nbegin\r\n GetServerList(List);\r\n if Assigned(OnFillDatabaseList) then\r\n OnFillDatabaseList(List);\r\nend;\r\n\r\nconstructor TJvDBUniDacLogonDialog.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FInternalConnectDialog := TUniConnectDialog.Create(Self);\r\n FInternalConnection := TUniConnection.Create(self);\r\n FInternalConnection.ConnectDialog := FInternalConnectDialog;\r\n TJvUniDacConnectionList(ConnectionList).UniConnection := InternalConnection;\r\n CurrentConnectionInfo.UniConnection := InternalConnection;\r\nend;\r\n\r\ndestructor TJvDBUniDacLogonDialog.Destroy;\r\nbegin\r\n FreeAndNil(FInternalConnection);\r\n FreeAndNil(FInternalConnectDialog);\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvDBUniDacLogonDialog.ClearControlInterfaceObjects;\r\nbegin\r\n inherited ClearControlInterfaceObjects;\r\n IDirectCheckBox := nil;\r\n IOracleHomeEditData := nil;\r\n IOracleHomeEditItems := nil;\r\n IPortEditData := nil;\r\n IProviderEditData := nil;\r\n IProviderEditItems := nil;\r\n IServerEditData := nil;\r\n IServerEditItems := nil;\r\nend;\r\n\r\nprocedure TJvDBUniDacLogonDialog.ConnectSession;\r\nbegin\r\n if Assigned(UniConnection) then\r\n try\r\n UniConnection.DisConnect;\r\n UniConnection.PerformConnect;\r\n except\r\n on E: EDAError do\r\n begin\r\n// case E.ErrorCode of\r\n// 1005, 1017:\r\n// ActivatePasswordControl;\r\n// 12203, 12154:\r\n// ActivateDatabaseControl;\r\n// end;\r\n// if (E.ErrorCode = 28001) or (E.ErrorCode = 28002) or (E.ErrorCode = 28011) then\r\n// HandleExpiredPassword(E.Message)\r\n// else\r\n JvDSADialogs.MessageDlg(E.Message, mtError, [mbok], 0, dckScreen,\r\n 0, mbDefault, mbDefault, mbDefault, DynControlEngine);\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvDBUniDacLogonDialog.CreateAdditionalConnectDialogControls(AOwner: TComponent; AParentControl: TWinControl);\r\nvar\r\n DynControlComboBox:IJvDynControlComboBox;\r\n UniProviderNames: TStringList;\r\n IDynControl: IJvDynControl;\r\nbegin\r\n inherited CreateAdditionalConnectDialogControls (AOwner, AParentControl);\r\n CreateAdditionalConnectDialogEditPanel(AOwner, AParentControl, 'Provider', RsProvider, jctComboBox, ProviderPanel, ProviderEdit, IProviderEditData, ProviderOnEditChange);\r\n if Supports(ProviderEdit, IJvDynControlComboBox, DynControlComboBox) then\r\n DynControlComboBox.ControlSetNewEntriesAllowed(False);\r\n if Supports(ProviderEdit, IJvDynControlItems, IProviderEditItems) then\r\n begin\r\n UniProviderNames := TStringList.Create;\r\n try\r\n UniProviders.GetProviderNames(UniProviderNames);\r\n IProviderEditItems.ControlItems.Assign(UniProviderNames);\r\n finally\r\n UniProviderNames.Free;\r\n end;\r\n IProviderEditItems.ControlSetSorted(True);\r\n end;\r\n\r\n CreateAdditionalConnectDialogEditPanel(AOwner, AParentControl, 'Server', RsServer, jctComboBox, ServerPanel, ServerEdit, IServerEditData, DefaultOnEditChange);\r\n Supports(ServerEdit, IJvDynControlItems, IServerEditItems);\r\n if Supports(ServerEdit, IJvDynControl, IDynControl) then\r\n begin\r\n IDynControl.ControlSetOnClick(DefaultOnEditChange);\r\n IDynControl.ControlSetOnExit(DefaultOnEditChange); // Fix for the VCL/JVCL Controls which did not react on OnChange and OnClick\r\n end;\r\n\r\n CreateAdditionalConnectDialogEditPanel(AOwner, AParentControl, 'OracleHome', RsOracleHome, jctComboBox, OracleHomePanel, OracleHomeEdit, IOracleHomeEditData, DefaultOnEditChange);\r\n Supports(OracleHomeEdit, IJvDynControlItems, IOracleHomeEditItems);\r\n if Supports(OracleHomeEdit, IJvDynControl, IDynControl) then\r\n begin\r\n IDynControl.ControlSetOnClick(DefaultOnEditChange);\r\n IDynControl.ControlSetOnExit(DefaultOnEditChange); // Fix for the VCL/JVCL Controls which did not react on OnChange and OnClick\r\n end;\r\n\r\n CreateAdditionalConnectDialogEditPanel(AOwner, AParentControl, 'Port', RsPort, jctEdit, PortPanel, PortEdit, IPortEditData, DefaultOnEditChange);\r\n\r\n DirectCheckBox := DynControlEngine.CreateCheckboxControl(AOwner, AParentControl, 'DirectCheckBox', RsDirectConnect);\r\n AlignControlTop(DirectCheckBox, PortPanel);\r\n Supports(DirectCheckBox, IJvDynControlCheckBox, IDirectCheckBox);\r\n //DirectCheckBox.Hint := RsNetOptionCheckBoxHint;\r\nend;\r\n\r\nprocedure TJvDBUniDacLogonDialog.CreateFormControls(AForm: TForm);\r\nbegin\r\n inherited CreateFormControls(AForm);\r\nend;\r\n\r\nprocedure TJvDBUniDacLogonDialog.FillAllComoboBoxes;\r\nbegin\r\n inherited FillAllComoboBoxes;\r\n FillServerComboBox;\r\nend;\r\n\r\nprocedure TJvDBUniDacLogonDialog.FillDatabaseComboBoxValues(Items: TStrings);\r\nvar i : Integer;\r\n Connection: TJvUniDacConnectionInfo;\r\nbegin\r\n if Options.AddConnectionValuesToComboBox then\r\n for i := 0 to ConnectionList.Count - 1 do\r\n begin\r\n Connection := ConnectionList.Connection[i];\r\n if Connection.Provider = CurrentConnectionInfo.Provider then\r\n if Connection.Database <> '' then\r\n if Items.IndexOf(Connection.Database) < 0 then\r\n Items.Add(Connection.Database);\r\n end;\r\nend;\r\n\r\nprocedure TJvDBUniDacLogonDialog.FillServerComboBox;\r\nvar\r\n List: TStringList;\r\n Items: TStringList;\r\nbegin\r\n Items := TStringList.Create;\r\n try\r\n Items.Sorted := True;\r\n InternalConnection.ProviderName := CurrentConnectionInfo.Provider;\r\n if TUniUtils.CanGetProvider(InternalConnection) then begin\r\n List := TStringList.Create;\r\n try\r\n InternalConnectDialog.GetServerList(List);\r\n Items.AddStrings(List);\r\n finally\r\n List.Free;\r\n end;\r\n end;\r\n FillServerComboBoxValues(Items);\r\n if Assigned(FOnFillServerList) then\r\n FOnFillServerList(CurrentConnectionInfo.Provider, Items);\r\n IServerEditItems.ControlItems.Assign(Items);\r\n finally\r\n Items.Free;\r\n end;\r\nend;\r\n\r\nprocedure TJvDBUniDacLogonDialog.FillServerComboBoxValues(Items: TStrings);\r\nvar i : Integer;\r\n Connection: TJvUniDacConnectionInfo;\r\nbegin\r\n if Options.AddConnectionValuesToComboBox then\r\n for i := 0 to ConnectionList.Count - 1 do\r\n begin\r\n Connection := ConnectionList.Connection[i];\r\n if Connection.Provider = CurrentConnectionInfo.Provider then\r\n if Connection.Server <> '' then\r\n if Items.IndexOf(Connection.Server) < 0 then\r\n Items.Add(Connection.Server);\r\n end;\r\nend;\r\n\r\nfunction TJvDBUniDacLogonDialog.GetConnectionList: TJvUniDacConnectionList;\r\nbegin\r\n Result := TJvUniDacConnectionList(Inherited ConnectionList);\r\nend;\r\n\r\nfunction TJvDBUniDacLogonDialog.GetCurrentConnectionInfo: TJvUniDacConnectionInfo;\r\nbegin\r\n Result := TJvUniDacConnectionInfo(inherited CurrentConnectionInfo);\r\nend;\r\n\r\nclass function TJvDBUniDacLogonDialog.GetDBLogonConnectionListClass: TJvBaseConnectionListClass;\r\nbegin\r\n Result := TJvUniDacConnectionList;\r\nend;\r\n\r\nclass function TJvDBUniDacLogonDialog.GetDBLogonDialogOptionsClass: TJvBaseDBLogonDialogOptionsClass;\r\nbegin\r\n Result := TJvDBUniDacLogonDialogOptions;\r\nend;\r\n\r\nfunction TJvDBUniDacLogonDialog.GetOptions: TJvDBUniDacLogonDialogOptions;\r\nbegin\r\n Result := TJvDBUniDacLogonDialogOptions(inherited Options);\r\nend;\r\n\r\nfunction TJvDBUniDacLogonDialog.GetUniConnection: TUniConnection;\r\nbegin\r\n Result := FUniConnection;\r\nend;\r\n\r\nprocedure TJvDBUniDacLogonDialog.HandleExpiredPassword(const ErrorMessage: string);\r\nbegin\r\n if JvDSADialogs.MessageDlg(ErrorMessage + #13#10 + RsDoYouWantToChangePassword, mtInformation, [mbYes, mbNo], 0, dckScreen,\r\n 0, mbDefault, mbDefault, mbDefault, DynControlEngine) = mrYes then\r\n if ChangePassword then\r\n if not SessionIsConnected then\r\n UniConnection.PerformConnect;\r\nend;\r\n\r\nprocedure TJvDBUniDacLogonDialog.ProviderOnEditChange(Sender: TObject);\r\nbegin\r\n TransferConnectionInfoFromDialog(CurrentConnectionInfo);\r\n RearrangeEditPanel;\r\n FillAllComoboBoxes;\r\n ValidateConnectBtnEnabled;\r\nend;\r\n\r\nfunction TJvDBUniDacLogonDialog.SessionIsConnected: Boolean;\r\nbegin\r\n Result := UniConnection.Connected;\r\nend;\r\n\r\nprocedure TJvDBUniDacLogonDialog.SetEditPanelsTabOrder;\r\nbegin\r\n inherited SetEditPanelsTabOrder;\r\n ProviderPanel.TabOrder := 0;\r\n ServerPanel.TabOrder := 3;\r\n PortPanel.TabOrder := 4;\r\n OracleHomePanel.TabOrder := 5;\r\nend;\r\n\r\nprocedure TJvDBUniDacLogonDialog.SetEditPanelsVisibility;\r\nbegin\r\n Inherited SetEditPanelsVisibility;\r\n SetPanelVisible(ServerPanel, CurrentConnectionInfo.ServerEnabled);\r\n SetPanelVisible(PortPanel, CurrentConnectionInfo.PortEnabled);\r\n SetPanelVisible(OracleHomePanel, CurrentConnectionInfo.OracleHomeEnabled and Options.ShowOracleHome);\r\n DirectCheckBox.Visible := CurrentConnectionInfo.DirectEnabled and Options.ShowDirectConnect ;\r\nend;\r\n\r\nprocedure TJvDBUniDacLogonDialog.SetOptions(const Value: TJvDBUniDacLogonDialogOptions);\r\nbegin\r\n (inherited Options).Assign(Value);\r\nend;\r\n\r\nprocedure TJvDBUniDacLogonDialog.SetSession(const Value: TComponent);\r\nbegin\r\n inherited SetSession(Value);\r\n if Value is TUniConnection then\r\n FUniConnection := tUniConnection(Value)\r\n else\r\n FUniConnection := nil;\r\nend;\r\n\r\nprocedure TJvDBUniDacLogonDialog.TransferConnectionInfoFromDialog(ConnectionInfo: TJvBaseConnectionInfo);\r\nvar UniConnectionInfo : TJvUniDacConnectionInfo;\r\nbegin\r\n if (ConnectionInfo is TJvUniDacConnectionInfo) then\r\n begin\r\n UniConnectionInfo := TJvUniDacConnectionInfo(ConnectionInfo);\r\n if Assigned (IProviderEditData) then\r\n UniConnectionInfo.Provider := IProviderEditData.ControlValue\r\n else\r\n UniConnectionInfo.Provider := '';\r\n end;\r\n inherited TransferConnectionInfoFromDialog(ConnectionInfo);\r\n if (ConnectionInfo is TJvUniDacConnectionInfo) then\r\n begin\r\n UniConnectionInfo := TJvUniDacConnectionInfo(ConnectionInfo);\r\n if Assigned (IOracleHomeEditData) and UniConnectionInfo.OracleHomeEnabled then\r\n UniConnectionInfo.OracleHome := IOracleHomeEditData.ControlValue\r\n else\r\n UniConnectionInfo.OracleHome := '';\r\n if Assigned (IServerEditData) and UniConnectionInfo.ServerEnabled then\r\n UniConnectionInfo.Server := IServerEditData.ControlValue\r\n else\r\n UniConnectionInfo.Server := '';\r\n if Assigned (IPortEditData) and (IPortEditData.ControlValue <> '') and UniConnectionInfo.PortEnabled then\r\n UniConnectionInfo.Port := IPortEditData.ControlValue\r\n else\r\n UniConnectionInfo.Port := 0;\r\n if Assigned (IDirectCheckBox) and UniConnectionInfo.DirectEnabled then\r\n UniConnectionInfo.Direct := IDirectCheckBox.ControlState = cbChecked\r\n else\r\n UniConnectionInfo.Direct := False;\r\n end;\r\nend;\r\n\r\nprocedure TJvDBUniDacLogonDialog.TransferConnectionInfoToDialog(ConnectionInfo: TJvBaseConnectionInfo);\r\nvar UniConnectionInfo : TJvUniDacConnectionInfo;\r\nbegin\r\n inherited TransferConnectionInfoToDialog(ConnectionInfo);\r\n if (ConnectionInfo is TJvUniDacConnectionInfo) then\r\n begin\r\n UniConnectionInfo := TJvUniDacConnectionInfo(ConnectionInfo);\r\n if Assigned (IOracleHomeEditData) then\r\n IOracleHomeEditData.ControlValue := UniConnectionInfo.OracleHome;\r\n if Assigned (IProviderEditData) then\r\n IProviderEditData.ControlValue := UniConnectionInfo.Provider;\r\n if Assigned (IServerEditData) then\r\n IServerEditData.ControlValue := UniConnectionInfo.Server;\r\n if Assigned (IPortEditData) then\r\n IPortEditData.ControlValue := UniConnectionInfo.Port;\r\n if Assigned(IDirectCheckBox) then\r\n if UniConnectionInfo.Direct then\r\n IDirectCheckBox.ControlState := cbChecked\r\n else\r\n IDirectCheckBox.ControlState := cbunChecked;\r\n ProviderOnEditChange(nil);\r\n end;\r\nend;\r\n\r\nprocedure TJvDBUniDacLogonDialog.TransferSessionDataFromConnectionInfo(ConnectionInfo: TJvBaseConnectionInfo);\r\nvar UniConnectionInfo : TJvUniDacConnectionInfo;\r\nbegin\r\n if Assigned(Session) and Assigned(UniConnection) then\r\n begin\r\n UniConnection.Password := ConnectionInfo.Password;\r\n UniConnection.Username := ConnectionInfo.Username;\r\n UniConnection.Database := ConnectionInfo.Database;\r\n if (ConnectionInfo is TJvUniDacConnectionInfo) then\r\n begin\r\n UniConnectionInfo := TJvUniDacConnectionInfo(ConnectionInfo);\r\n UniConnection.Server:= UniConnectionInfo.Server;\r\n UniConnection.ProviderName:= UniConnectionInfo.Provider;\r\n UniConnection.Port := UniConnectionInfo.Port;\r\n if Options.ShowOracleHome then\r\n if UniConnectionInfo.OracleHomeEnabled then\r\n UniConnection.SpecificOptions.Values['HomeName'] := UniConnectionInfo.OracleHome;\r\n if UniConnectionInfo.DirectEnabled then\r\n if UniConnectionInfo.Direct then\r\n UniConnection.SpecificOptions.Values['Direct'] := 'true'\r\n else\r\n UniConnection.SpecificOptions.Values['Direct'] := 'false';\r\n if Options.ShowConnectAs then\r\n if UniConnectionInfo.ConnectAsEnabled then\r\n if UniConnectionInfo.ConnectAs = 'SYSDBA' then\r\n UniConnection.SpecificOptions.Values['ConnectMode'] := 'cmSysDBA'\r\n else if UniConnectionInfo.ConnectAs = 'SYSOPER' then\r\n UniConnection.SpecificOptions.Values['ConnectMode'] := 'cmSysOPER'\r\n else if UniConnectionInfo.ConnectAs = 'SYSASM' then\r\n UniConnection.SpecificOptions.Values['ConnectMode'] := 'cmSysASM'\r\n else\r\n UniConnection.SpecificOptions.Values['ConnectMode'] := 'cmNormal';\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvDBUniDacLogonDialog.TransferSessionDataToConnectionInfo(ConnectionInfo: TJvBaseConnectionInfo);\r\nvar UniConnectionInfo : TJvUniDacConnectionInfo;\r\n ConnectAs: String;\r\nbegin\r\n if Assigned(Session) and Assigned(UniConnection) then\r\n begin\r\n ConnectionInfo.Password := UniConnection.Password;\r\n ConnectionInfo.Username := UniConnection.Username;\r\n ConnectionInfo.Database := UniConnection.Database;\r\n if (ConnectionInfo is TJvUniDacConnectionInfo) then\r\n begin\r\n UniConnectionInfo := TJvUniDacConnectionInfo(ConnectionInfo);\r\n UniConnectionInfo.Server :=UniConnection.Server;\r\n UniConnectionInfo.Provider := UniConnection.ProviderName;\r\n UniConnectionInfo.Port := UniConnection.Port;\r\n if UniConnectionInfo.OracleHomeEnabled then\r\n UniConnectionInfo.OracleHome := UniConnection.SpecificOptions.Values['HomeName'];\r\n if UniConnectionInfo.DirectEnabled then\r\n UniConnectionInfo.Direct := Uppercase(UniConnection.SpecificOptions.Values['Direct']) = 'TRUE';\r\n if UniConnectionInfo.ConnectAsEnabled then\r\n begin\r\n ConnectAs := UniConnection.SpecificOptions.Values['ConnectMode'];\r\n Delete(ConnectAs,1,2);\r\n if ConnectAs = '' then\r\n UniConnectionInfo.ConnectAs := UpperCase(ConnectAs)\r\n else\r\n UniConnectionInfo.ConnectAs := 'NORMAL';\r\n end;\r\n\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJvUniDacConnectionList.CreateObject: TPersistent;\r\nbegin\r\n Result := TJvUniDacConnectionInfo.Create(Self);\r\n TJvUniDacConnectionInfo(Result).UniConnection := UniConnection;\r\nend;\r\n\r\nfunction TJvUniDacConnectionList.GetConnection(I: Longint): TJvUniDacConnectionInfo;\r\nbegin\r\n Result := TJvUniDacConnectionInfo(inherited Connection[i])\r\nend;\r\n\r\nprocedure TJvUniDacConnectionList.Notification(AComponent: TComponent; Operation: TOperation);\r\nbegin\r\n inherited Notification(AComponent, Operation);\r\n if (Operation = opRemove) and (AComponent = FUniConnection) then\r\n UniConnection := nil;\r\nend;\r\n\r\nprocedure TJvUniDacConnectionList.SetUniConnection(const Value: TUniConnection);\r\nvar\r\n i: Integer;\r\nbegin\r\n ReplaceComponentReference(Self, Value, tComponent(FUniConnection));\r\n for i := 0 to Count-1 do\r\n TJvUniDacConnectionInfo(Connection[i]).UniConnection := Value;\r\nend;\r\n\r\nconstructor TJvUniDacConnectionInfo.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n RecalculateEnabledProperties;\r\nend;\r\n\r\nfunction TJvUniDacConnectionInfo.ConnectString: string;\r\nbegin\r\n if UsernameEnabled then\r\n Result := TranslateUserName(Username)\r\n else\r\n Result := '';\r\n if PasswordEnabled and (Password <> '') then\r\n Result := Result + '/*****';\r\n if AliasEnabled and (Alias <> '') then\r\n Result := Result + '@' + Alias\r\n else\r\n if ServerEnabled and (Server <> '') then\r\n Result := Result +'@'+TranslateDatabaseName(Server);\r\n if ConnectAsEnabled and (ConnectAs <> 'NORMAL') then\r\n Result := Result +' ['+ConnectAs+']';\r\n if not(AliasEnabled and (Alias <> '')) and\r\n DatabaseEnabled and (Database <> '') then\r\n Result := Result + ' - ' + Database;\r\n Result := Result + ' {'+Provider+'}';\r\n if ShortCutText <> '' then\r\n Result := Result + ' ('+ShortCutText+')';\r\nend;\r\n\r\nfunction TJvUniDacConnectionInfo.DatabaseGroupIdentifier: string;\r\nbegin\r\n if AliasEnabled and (Alias <> '') then\r\n Result := Alias\r\n else\r\n if ServerEnabled then\r\n Result := TranslateDatabaseName(Server)\r\n else\r\n Result := Database;\r\nend;\r\n\r\nfunction TJvUniDacConnectionInfo.GetAliasEnabled: Boolean;\r\nbegin\r\n Result := inherited GetAliasEnabled or ServerEnabled;\r\nend;\r\n\r\nfunction TJvUniDacConnectionInfo.GetConnectAsEnabled: Boolean;\r\nbegin\r\n Result := GetOracleHomeEnabled;\r\nend;\r\n\r\nfunction TJvUniDacConnectionInfo.GetDatabaseEnabled: Boolean;\r\nbegin\r\n Result := fDatabaseEnabled;\r\nend;\r\n\r\nfunction TJvUniDacConnectionInfo.GetServerEnabled: Boolean;\r\nbegin\r\n Result := FServerEnabled;\r\nend;\r\n\r\nfunction TJvUniDacConnectionInfo.GetPortEnabled: Boolean;\r\nbegin\r\n Result := FPortEnabled;\r\nend;\r\n\r\nfunction TJvUniDacConnectionInfo.GetOracleHomeEnabled: Boolean;\r\nbegin\r\n Result := Provider = 'Oracle';\r\nend;\r\n\r\nfunction TJvUniDacConnectionInfo.GetDirectEnabled: Boolean;\r\nbegin\r\n Result := Provider = 'Oracle';\r\nend;\r\n\r\nfunction TJvUniDacConnectionInfo.GetPasswordEnabled: Boolean;\r\nbegin\r\n Result := fPasswordEnabled;\r\nend;\r\n\r\nfunction TJvUniDacConnectionInfo.GetUsernameEnabled: Boolean;\r\nbegin\r\n Result := fUsernameEnabled;\r\nend;\r\n\r\nfunction TJvUniDacConnectionInfo.IsConnectAllowed(AllowNullPasswords: Boolean): Boolean;\r\nbegin\r\n Result:= inherited IsConnectAllowed(AllowNullPasswords);\r\n Result := Result and (Provider <> '');\r\n if PortEnabled then\r\n Result := Result and (Port > 0);\r\n if ServerEnabled then\r\n Result := Result and (Server <> '');\r\nend;\r\n\r\nprocedure TJvUniDacConnectionInfo.Notification(AComponent: TComponent; Operation: TOperation);\r\nbegin\r\n inherited Notification(AComponent, Operation);\r\n if (Operation = opRemove) and (AComponent = FUniConnection) then\r\n UniConnection := nil;\r\nend;\r\n\r\nprocedure TJvUniDacConnectionInfo.RecalculateEnabledProperties;\r\nvar\r\n UniProvider: TUniProvider;\r\nbegin\r\n FDatabaseEnabled := True;\r\n FUserNameEnabled := True;\r\n FPasswordEnabled := True;\r\n FServerEnabled := True;\r\n FPortEnabled := True;\r\n if Assigned(UniConnection) and Assigned(UniConnection.ConnectDialog) and(UniConnection.ConnectDialog is TUniConnectDialog) then\r\n begin\r\n UniConnection.ProviderName := Provider;\r\n if TUniUtils.CanGetProvider(UniConnection) then\r\n begin\r\n UniProvider := TUniUtils.GetProvider(UniConnection);\n FUserNameEnabled := TUniConnectDialogUtils.GetConnectDialogService(TUniConnectDialog(UniConnection.ConnectDialog)).UsernameEnabled;\n FPasswordEnabled := TUniConnectDialogUtils.GetConnectDialogService(TUniConnectDialog(UniConnection.ConnectDialog)).PasswordEnabled;\n FServerEnabled := TUniConnectDialogUtils.GetConnectDialogService(TUniConnectDialog(UniConnection.ConnectDialog)).ServerEnabled;\n FDatabaseEnabled := UniProvider.IsDatabaseSupported and\n TUniConnectDialogUtils.GetConnectDialogService(TUniConnectDialog(UniConnection.ConnectDialog)).DatabaseEnabled;\n FPortEnabled := UniProvider.IsPortSupported and\n TUniConnectDialogUtils.GetConnectDialogService(TUniConnectDialog(UniConnection.ConnectDialog)).PortEnabled;\n end;\n end;\r\nend;\r\n\r\nfunction TJvUniDacConnectionInfo.SearchName: String;\r\nbegin\r\n Result := TranslateUserName(UserName) +'@'+TranslateDatabaseName(Server);\r\n Result := Result +'['+inttostr(Port)+']';\r\n Result := Result + '-'+Database;\r\n Result := Result + '('+Provider+')';\r\nend;\r\n\r\nprocedure TJvUniDacConnectionInfo.SetOracleHome(const Value: string);\r\nbegin\r\n FOracleHome := Trim(Value);\r\nend;\r\n\r\nprocedure TJvUniDacConnectionInfo.SetProvider(const Value: String);\r\nbegin\r\n FProvider := Trim(Value);\r\n RecalculateEnabledProperties;\r\nend;\r\n\r\nprocedure TJvUniDacConnectionInfo.SetServer(const Value: String);\r\nbegin\r\n FServer := Trim(Value);\r\nend;\r\n\r\nprocedure TJvUniDacConnectionInfo.SetUniConnection(const Value: TUniConnection);\r\nbegin\r\n ReplaceComponentReference(Self, Value, tComponent(FUniConnection));\r\n RecalculateEnabledProperties;\r\nend;\r\n\r\n{$ENDIF USE_3RDPARTY_DEVART_UNIDAC}\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvDBLookup.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvLookup.PAS, released on 2002-07-04.\r\n\r\nThe Initial Developers of the Original Code are: Fedor Koshevnikov, Igor Pavluk and Serge Korolev\r\nCopyright (c) 1997, 1998 Fedor Koshevnikov, Igor Pavluk and Serge Korolev\r\nCopyright (c) 2001,2002 SGB Software\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\n Polaris Software\r\n\r\nCopyright (c) 1995,1997 Borland International\r\nPortions copyright (c) 1995, 1996 AO ROSNO\r\nPortions copyright (c) 1997, 1998 Master-Bank\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvDBLookup.pas 13415 2012-09-10 09:51:54Z obones $\r\n\r\nunit JvDBLookup;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, Messages,\r\n {$IFDEF RTL240_UP}\r\n System.Generics.Collections,\r\n {$ENDIF RTL240_UP}\r\n Types, Variants, Classes, Graphics, Controls, Forms, DB, DBCtrls,\r\n JvDBUtils, JvToolEdit, JvComponent, JvExControls;\r\n\r\nconst\r\n // (rom) renamed\r\n DefFieldsDelimiter = ',';\r\n\r\ntype\r\n TLookupListStyle = (lsFixed, lsDelimited);\r\n TJvLookupControl = class;\r\n TGetImageEvent = procedure(Sender: TObject; IsEmpty: Boolean;\r\n var Graphic: TGraphic; var TextMargin: Integer) of object;\r\n\r\n TJvDataSourceLink = class(TJvDataLink)\r\n private\r\n FDataControl: TJvLookupControl;\r\n protected\r\n procedure ActiveChanged; override;\r\n procedure LayoutChanged; override;\r\n procedure FocusControl(const Field: TField); override;\r\n procedure RecordChanged(Field: TField); override;\r\n procedure UpdateData; override;\r\n end;\r\n\r\n TJvLookupSourceLinkMethod = procedure of object;\r\n\r\n TLookupSourceLink = class(TDataLink)\r\n private\r\n FDataControl: TJvLookupControl;\r\n protected\r\n procedure ActiveChanged; override;\r\n procedure LayoutChanged; override;\r\n procedure DataSetChanged; override;\r\n procedure DataSetScrolled(Distance: Integer); override;\r\n end;\r\n\r\n TJvLookupControl = class(TJvCustomControl)\r\n private\r\n FLookupSource: TDataSource;\r\n FDataLink: TJvDataSourceLink;\r\n FLookupLink: TLookupSourceLink;\r\n FDataFieldName: string;\r\n FLookupFieldName: string;\r\n FLookupDisplay: string;\r\n FDisplayIndex: Integer;\r\n FDataField: TField;\r\n FMasterField: TField;\r\n FKeyField: TField;\r\n FDisplayField: TField;\r\n FListFields: TList{$IFDEF RTL240_UP}{$ENDIF RTL240_UP};\r\n FValue: string;\r\n FDisplayValue: string;\r\n FDisplayEmpty: string;\r\n FSearchText: string;\r\n FEmptyValue: string;\r\n FEmptyStrIsNull: Boolean;\r\n FEmptyItemColor: TColor;\r\n FListActive: Boolean;\r\n FPopup: Boolean;\r\n FFocused: Boolean;\r\n FLocate: TJvLocateObject;\r\n FIndexSwitch: Boolean;\r\n FIgnoreCase: Boolean;\r\n FItemHeight: Integer;\r\n FFieldsDelimiter: Char;\r\n FListStyle: TLookupListStyle;\r\n FLookupFormat: string;\r\n FOnChange: TNotifyEvent;\r\n FOnGetImage: TGetImageEvent;\r\n FLookupMode: Boolean;\r\n FUseRecordCount: Boolean;\r\n FRightTrimmedLookup: Boolean;\r\n procedure CheckNotFixed;\r\n procedure SetLookupMode(Value: Boolean);\r\n function GetKeyValue: Variant;\r\n procedure SetKeyValue(const Value: Variant);\r\n function CanModify: Boolean;\r\n procedure CheckNotCircular;\r\n procedure DataLinkActiveChanged;\r\n procedure CheckDataLinkActiveChanged;\r\n function GetBorderSize: Integer;\r\n function GetField: TField;\r\n function GetDataSource: TDataSource;\r\n function GetLookupField: string;\r\n function GetLookupSource: TDataSource;\r\n function GetTextHeight: Integer;\r\n function DefaultTextHeight: Integer;\r\n function GetItemHeight: Integer;\r\n function LocateKey: Boolean;\r\n function LocateDisplay: Boolean;\r\n function ValueIsEmpty(const S: string): Boolean;\r\n function StoreEmpty: Boolean;\r\n procedure ProcessSearchKey(Key: Char);\r\n procedure UpdateKeyValue;\r\n procedure SelectKeyValue(const Value: string);\r\n procedure SetDataFieldName(const Value: string);\r\n procedure SetDataSource(Value: TDataSource);\r\n procedure SetDisplayEmpty(const Value: string);\r\n procedure SetEmptyValue(const Value: string);\r\n procedure SetEmptyStrIsNull(const Value: Boolean);\r\n procedure SetEmptyItemColor(Value: TColor);\r\n procedure SetLookupField(const Value: string);\r\n procedure SetValueKey(const Value: string);\r\n procedure SetValue(const Value: string);\r\n procedure SetDisplayValue(const Value: string);\r\n procedure SetListStyle(Value: TLookupListStyle); virtual;\r\n procedure SetFieldsDelimiter(Value: Char); virtual;\r\n procedure SetLookupDisplay(const Value: string);\r\n procedure SetLookupFormat(const Value: string);\r\n procedure SetLookupSource(Value: TDataSource);\r\n procedure SetItemHeight(Value: Integer);\r\n procedure SetUseRecordCount(const Value: Boolean);\r\n function ItemHeightStored: Boolean;\r\n procedure DrawPicture(Canvas: TCanvas; Rect: TRect; Image: TGraphic);\r\n procedure UpdateDisplayValue;\r\n function EmptyRowVisible: Boolean;\r\n procedure SetDisplayIndex(const Value: Integer);\r\n protected\r\n procedure FocusKilled(NextWnd: THandle); override;\r\n procedure FocusSet(PrevWnd: THandle); override;\r\n procedure GetDlgCode(var Code: TDlgCodes); override;\r\n function GetReadOnly: Boolean; virtual;\r\n procedure SetReadOnly(Value: Boolean); virtual;\r\n procedure Change; dynamic;\r\n procedure KeyValueChanged; virtual;\r\n procedure DisplayValueChanged; virtual;\r\n function DoFormatLine: string;\r\n procedure DataLinkRecordChanged(Field: TField); virtual;\r\n procedure DataLinkUpdateData; virtual;\r\n procedure ListLinkActiveChanged; virtual;\r\n procedure ListLinkDataChanged; virtual;\r\n procedure ListLinkDataSetChanged; virtual;\r\n procedure Notification(AComponent: TComponent; Operation: TOperation); override;\r\n function GetPicture(Current, Empty: Boolean; var TextMargin: Integer): TGraphic; virtual;\r\n procedure UpdateDisplayEmpty(const Value: string); virtual;\r\n function SearchText(var AValue: string): Boolean;\r\n function GetWindowWidth: Integer;\r\n property DataField: string read FDataFieldName write SetDataFieldName;\r\n property DataSource: TDataSource read GetDataSource write SetDataSource;\r\n property DisplayEmpty: string read FDisplayEmpty write SetDisplayEmpty;\r\n property EmptyValue: string read FEmptyValue write SetEmptyValue stored StoreEmpty;\r\n property EmptyStrIsNull: Boolean read FEmptyStrIsNull write SetEmptyStrIsNull default True;\r\n property EmptyItemColor: TColor read FEmptyItemColor write SetEmptyItemColor default clWindow;\r\n property IgnoreCase: Boolean read FIgnoreCase write FIgnoreCase default True;\r\n property IndexSwitch: Boolean read FIndexSwitch write FIndexSwitch default True;\r\n property ItemHeight: Integer read GetItemHeight write SetItemHeight stored ItemHeightStored;\r\n property ListStyle: TLookupListStyle read FListStyle write SetListStyle default lsFixed;\r\n property FieldsDelimiter: Char read FFieldsDelimiter write SetFieldsDelimiter default DefFieldsDelimiter;\r\n property LookupDisplay: string read FLookupDisplay write SetLookupDisplay;\r\n property LookupDisplayIndex: Integer read FDisplayIndex write SetDisplayIndex default 0;\r\n property LookupField: string read GetLookupField write SetLookupField;\r\n property LookupFormat: string read FLookupFormat write SetLookupFormat;\r\n property LookupSource: TDataSource read GetLookupSource write SetLookupSource;\r\n property ParentColor default False;\r\n property ReadOnly: Boolean read GetReadOnly write SetReadOnly default False;\r\n property TabStop default True;\r\n property UseRecordCount: Boolean read FUseRecordCount write SetUseRecordCount default False;\r\n property Value: string read FValue write SetValue stored False;\r\n property DisplayValue: string read FDisplayValue write SetDisplayValue stored False;\r\n property KeyValue: Variant read GetKeyValue write SetKeyValue stored False;\r\n property RightTrimmedLookup: Boolean read FRightTrimmedLookup write FRightTrimmedLookup default False;\r\n procedure SetFieldValue(Field: TField; const Value: string);\r\n property OnChange: TNotifyEvent read FOnChange write FOnChange;\r\n property OnGetImage: TGetImageEvent read FOnGetImage write FOnGetImage;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n procedure ClearValue;\r\n function Locate(const SearchField: TField; const AValue: string; Exact: Boolean): Boolean;\r\n procedure ResetField; virtual;\r\n function ExecuteAction(Action: TBasicAction): Boolean; override;\r\n function UpdateAction(Action: TBasicAction): Boolean; override;\r\n function UseRightToLeftAlignment: Boolean; override;\r\n property Field: TField read GetField;\r\n end;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvDBLookupList = class(TJvLookupControl)\r\n private\r\n FRecordIndex: Integer;\r\n FRecordCount: Integer;\r\n FRowCount: Integer;\r\n FBorderStyle: TBorderStyle;\r\n FKeySelected: Boolean;\r\n FTracking: Boolean;\r\n FTimerActive: Boolean;\r\n FLockPosition: Boolean;\r\n FSelectEmpty: Boolean;\r\n FMousePos: Integer;\r\n function GetKeyIndex: Integer;\r\n procedure ListDataChanged;\r\n procedure SelectCurrent;\r\n procedure SelectItemAt(X, Y: Integer);\r\n procedure SetBorderStyle(Value: TBorderStyle);\r\n procedure SetRowCount(Value: Integer);\r\n procedure StopTimer;\r\n procedure StopTracking;\r\n procedure TimerScroll;\r\n procedure UpdateScrollBar;\r\n procedure UpdateBufferCount(Rows: Integer);\r\n procedure CMCtl3DChanged(var Msg: TMessage); message CM_CTL3DCHANGED;\r\n procedure WMCancelMode(var Msg: TMessage); message WM_CANCELMODE;\r\n procedure WMNCHitTest(var Msg: TWMNCHitTest); message WM_NCHITTEST;\r\n procedure WMTimer(var Msg: TMessage); message WM_TIMER;\r\n procedure WMVScroll(var Msg: TWMVScroll); message WM_VSCROLL;\r\n protected\r\n procedure FontChanged; override;\r\n procedure CreateParams(var Params: TCreateParams); override;\r\n procedure CreateWnd; override;\r\n procedure KeyValueChanged; override;\r\n procedure DisplayValueChanged; override;\r\n procedure ListLinkActiveChanged; override;\r\n procedure ListLinkDataChanged; override;\r\n procedure KeyDown(var Key: Word; Shift: TShiftState); override;\r\n procedure KeyPress(var Key: Char); override;\r\n procedure Loaded; override;\r\n procedure MouseDown(Button: TMouseButton; Shift: TShiftState;\r\n X, Y: Integer); override;\r\n procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;\r\n procedure MouseUp(Button: TMouseButton; Shift: TShiftState;\r\n X, Y: Integer); override;\r\n procedure Paint; override;\r\n procedure UpdateDisplayEmpty(const Value: string); override;\r\n function DoMouseWheelDown(Shift: TShiftState; MousePos: TPoint): Boolean; override;\r\n function DoMouseWheelUp(Shift: TShiftState; MousePos: TPoint): Boolean; override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n procedure SetBounds(ALeft, ATop, AWidth, AHeight: Integer); override;\r\n procedure DrawItemText(Canvas: TCanvas; Rect: TRect;\r\n Selected, IsEmpty: Boolean); virtual;\r\n property RowCount: Integer read FRowCount write SetRowCount stored False;\r\n property DisplayValue;\r\n property Value;\r\n property KeyValue;\r\n published\r\n property BorderStyle: TBorderStyle read FBorderStyle write SetBorderStyle default bsSingle;\r\n property Align;\r\n property AutoSize;\r\n property Color;\r\n property DataField;\r\n property DataSource;\r\n property DisplayEmpty;\r\n property DragCursor;\r\n property DragMode;\r\n property EmptyItemColor;\r\n property EmptyValue;\r\n property EmptyStrIsNull;\r\n property Enabled;\r\n property FieldsDelimiter;\r\n property Font;\r\n property IgnoreCase;\r\n property Anchors;\r\n property BevelEdges;\r\n property BevelInner;\r\n property BevelKind default bkNone;\r\n property BevelOuter;\r\n property BiDiMode;\r\n property Constraints;\r\n property DragKind;\r\n property ParentBiDiMode;\r\n property ImeMode;\r\n property ImeName;\r\n property IndexSwitch;\r\n property ItemHeight;\r\n property ListStyle;\r\n property LookupField;\r\n property LookupDisplay;\r\n property LookupDisplayIndex;\r\n property LookupFormat;\r\n property LookupSource;\r\n property ParentColor;\r\n property ParentFont;\r\n property ParentShowHint;\r\n property PopupMenu;\r\n property ReadOnly;\r\n property ShowHint;\r\n property TabOrder;\r\n property TabStop;\r\n property Visible;\r\n property UseRecordCount;\r\n property OnClick;\r\n property OnDblClick;\r\n property OnDragDrop;\r\n property OnDragOver;\r\n property OnEndDrag;\r\n property OnEnter;\r\n property OnExit;\r\n property OnGetImage;\r\n property OnKeyDown;\r\n property OnKeyPress;\r\n property OnKeyUp;\r\n property OnMouseDown;\r\n property OnMouseMove;\r\n property OnMouseUp;\r\n property OnStartDrag;\r\n property OnContextPopup;\r\n property OnMouseWheelDown;\r\n property OnMouseWheelUp;\r\n property OnEndDock;\r\n property OnStartDock;\r\n end;\r\n\r\n TJvPopupDataList = class(TJvDBLookupList)\r\n private\r\n FCombo: TJvLookupControl;\r\n procedure WMMouseActivate(var Msg: TMessage); message WM_MOUSEACTIVATE;\r\n procedure CMHintShow(var Msg: TMessage); message CM_HINTSHOW;\r\n protected\r\n procedure Click; override;\r\n procedure CreateParams(var Params: TCreateParams); override;\r\n procedure KeyPress(var Key: Char); override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n end;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvDBLookupCombo = class(TJvLookupControl, IJvDataControl)\r\n private\r\n FDataList: TJvPopupDataList;\r\n FButtonWidth: Integer;\r\n FDropDownCount: Integer;\r\n FDropDownWidth: Integer;\r\n FDropDownAlign: TDropDownAlign;\r\n FEscapeKeyReset: Boolean;\r\n FDeleteKeyClear: Boolean;\r\n FListVisible: Boolean;\r\n FPressed: Boolean;\r\n FTracking: Boolean;\r\n FAlignment: TAlignment;\r\n FSelImage: TPicture;\r\n FSelMargin: Integer;\r\n FDisplayValues: TStringList;\r\n FDisplayAllFields: Boolean;\r\n FTabSelects: Boolean;\r\n FOnDropDown: TNotifyEvent;\r\n FOnCloseUp: TNotifyEvent;\r\n FLastValue: Variant;\r\n FInListDataSetChanged: Boolean;\r\n procedure ListMouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);\r\n procedure StopTracking;\r\n procedure TrackButton(X, Y: Integer);\r\n function GetMinHeight: Integer;\r\n function GetText: string;\r\n procedure InvalidateText;\r\n procedure UpdateCurrentImage;\r\n procedure PaintDisplayValues(Canvas: TCanvas; R: TRect; ALeft: Integer);\r\n procedure SetFieldsDelimiter(Value: Char); override;\r\n procedure SetListStyle(Value: TLookupListStyle); override;\r\n function GetDisplayAllFields: Boolean;\r\n procedure SetDisplayAllFields(Value: Boolean);\r\n function GetDisplayValues(Index: Integer): string;\r\n procedure CMCancelMode(var Msg: TCMCancelMode); message CM_CANCELMODE;\r\n procedure CNKeyDown(var Msg: TWMKeyDown); message CN_KEYDOWN;\r\n procedure CMCtl3DChanged(var Msg: TMessage); message CM_CTL3DCHANGED;\r\n procedure CMGetDataLink(var Msg: TMessage); message CM_GETDATALINK;\r\n procedure WMCancelMode(var Msg: TMessage); message WM_CANCELMODE;\r\n procedure WMSetCursor(var Msg: TWMSetCursor); message WM_SETCURSOR;\r\n procedure CMBiDiModeChanged(var Msg: TMessage); message CM_BIDIMODECHANGED;\r\n procedure CMHintShow(var Msg: TMessage); message CM_HINTSHOW;\r\n procedure WMEraseBkgnd(var Message: TWMEraseBkgnd); message WM_ERASEBKGND;\r\n procedure ReadEscapeClear(Reader: TReader);\r\n protected\r\n function GetDataLink: TDataLink; virtual;\r\n procedure FocusKilled(NextWnd: THandle); override;\r\n procedure BoundsChanged; override;\r\n procedure GetDlgCode(var Code: TDlgCodes); override;\r\n procedure EnabledChanged; override;\r\n procedure FontChanged; override;\r\n {$IFDEF JVCLThemesEnabled}\r\n procedure MouseEnter(Control: TControl); override;\r\n procedure MouseLeave(Control: TControl); override;\r\n {$ENDIF JVCLThemesEnabled}\r\n procedure DoEnter; override;\r\n procedure Click; override;\r\n procedure CreateParams(var Params: TCreateParams); override;\r\n function DoMouseWheelDown(Shift: TShiftState; MousePos: TPoint): Boolean; override;\r\n function DoMouseWheelUp(Shift: TShiftState; MousePos: TPoint): Boolean; override;\r\n function GetPicture(Current, Empty: Boolean; var TextMargin: Integer): TGraphic; override;\r\n procedure UpdateFieldText;\r\n procedure KeyValueChanged; override;\r\n procedure DisplayValueChanged; override;\r\n procedure ListLinkActiveChanged; override;\r\n procedure ListLinkDataChanged; override;\r\n procedure ListLinkDataSetChanged; override;\r\n procedure DataLinkRecordChanged(AField: TField); override;\r\n procedure DataLinkUpdateData; override;\r\n procedure Paint; override;\r\n procedure KeyDown(var Key: Word; Shift: TShiftState); override;\r\n procedure KeyPress(var Key: Char); override;\r\n procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;\r\n procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;\r\n procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;\r\n procedure UpdateDisplayEmpty(const Value: string); override;\r\n procedure DefineProperties(Filer: TFiler); override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n procedure CloseUp(Accept: Boolean); dynamic;\r\n procedure DropDown; virtual;\r\n procedure ResetField; override;\r\n property IsDropDown: Boolean read FListVisible;\r\n property ListVisible: Boolean read FListVisible;\r\n property Text: string read GetText;\r\n property DisplayValue;\r\n property DisplayValues[Index: Integer]: string read GetDisplayValues;\r\n property Value;\r\n property KeyValue;\r\n published\r\n property Align;\r\n property DropDownAlign: TDropDownAlign read FDropDownAlign write FDropDownAlign default daLeft;\r\n property DropDownCount: Integer read FDropDownCount write FDropDownCount default 8;\r\n property DropDownWidth: Integer read FDropDownWidth write FDropDownWidth default 0;\r\n property EscapeKeyReset: Boolean read FEscapeKeyReset write FEscapeKeyReset default True;\r\n property DeleteKeyClear: Boolean read FDeleteKeyClear write FDeleteKeyClear default True;\r\n property DisplayAllFields: Boolean read GetDisplayAllFields write SetDisplayAllFields default False;\r\n property TabSelects : Boolean read FTabSelects write FTabSelects default False;\r\n property Color;\r\n property DataField;\r\n property DataSource;\r\n property DisplayEmpty;\r\n property DragCursor;\r\n property DragMode;\r\n property EmptyValue;\r\n property EmptyStrIsNull;\r\n property EmptyItemColor;\r\n property Enabled;\r\n property FieldsDelimiter;\r\n property Font;\r\n property IgnoreCase;\r\n property Anchors;\r\n property BiDiMode;\r\n property Constraints;\r\n property DragKind;\r\n property ParentBiDiMode;\r\n property ImeMode;\r\n property ImeName;\r\n property IndexSwitch;\r\n property ItemHeight;\r\n property ListStyle;\r\n property LookupField;\r\n property LookupDisplay;\r\n property LookupDisplayIndex;\r\n property LookupFormat;\r\n property LookupSource;\r\n property ParentColor;\r\n property ParentFont;\r\n property ParentShowHint;\r\n property PopupMenu;\r\n property ReadOnly;\r\n property RightTrimmedLookup;\r\n property ShowHint;\r\n property TabOrder;\r\n property TabStop;\r\n property UseRecordCount;\r\n property Visible;\r\n property OnChange;\r\n property OnClick;\r\n property OnCloseUp: TNotifyEvent read FOnCloseUp write FOnCloseUp;\r\n property OnDropDown: TNotifyEvent read FOnDropDown write FOnDropDown;\r\n property OnDragDrop;\r\n property OnDragOver;\r\n property OnEndDrag;\r\n property OnEnter;\r\n property OnExit;\r\n property OnGetImage;\r\n property OnKeyDown;\r\n property OnKeyPress;\r\n property OnKeyUp;\r\n property OnMouseDown;\r\n property OnMouseMove;\r\n property OnMouseUp;\r\n property OnMouseWheelDown;\r\n property OnMouseWheelUp;\r\n property OnStartDrag;\r\n property OnContextPopup;\r\n property OnEndDock;\r\n property OnStartDock;\r\n end;\r\n\r\n TJvPopupDataWindow = class(TJvPopupDataList)\r\n private\r\n FEditor: TWinControl;\r\n FCloseUp: TCloseUpEvent;\r\n protected\r\n procedure InvalidateEditor;\r\n procedure Click; override;\r\n procedure DisplayValueChanged; override;\r\n function GetPicture(Current, Empty: Boolean; var TextMargin: Integer): TGraphic; override;\r\n procedure KeyPress(var Key: Char); override;\r\n procedure PopupMouseUp(Sender: TObject; Button: TMouseButton;\r\n Shift: TShiftState; X, Y: Integer);\r\n procedure CloseUp(Accept: Boolean); virtual;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n procedure Hide;\r\n procedure Show(Origin: TPoint);\r\n property OnCloseUp: TCloseUpEvent read FCloseUp write FCloseUp;\r\n end;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvDBLookupEdit = class(TJvCustomComboEdit)\r\n private\r\n FChanging: Boolean;\r\n FIgnoreChange: Boolean;\r\n FDropDownCount: Integer;\r\n FDropDownWidth: Integer;\r\n FPopupOnlyLocate: Boolean;\r\n FOnCloseUp: TNotifyEvent;\r\n FOnDropDown: TNotifyEvent;\r\n FBeforePopupValue: Variant;\r\n function GetListStyle: TLookupListStyle;\r\n procedure SetListStyle(Value: TLookupListStyle);\r\n function GetFieldsDelimiter: Char;\r\n procedure SetFieldsDelimiter(Value: Char);\r\n function GetLookupDisplay: string;\r\n procedure SetLookupDisplay(const Value: string);\r\n function GetDisplayIndex: Integer;\r\n procedure SetDisplayIndex(Value: Integer);\r\n function GetLookupField: string;\r\n procedure SetLookupField(const Value: string);\r\n function GetLookupSource: TDataSource;\r\n procedure SetLookupSource(Value: TDataSource);\r\n procedure SetDropDownCount(Value: Integer);\r\n function GetLookupValue: string;\r\n procedure SetLookupValue(const Value: string);\r\n function GetOnGetImage: TGetImageEvent;\r\n procedure SetOnGetImage(Value: TGetImageEvent);\r\n function GetUseRecordCount: Boolean;\r\n procedure SetUseRecordCount(const Value: Boolean);\r\n protected\r\n procedure Change; override;\r\n procedure KeyDown(var Key: Word; Shift: TShiftState); override;\r\n procedure KeyPress(var Key: Char); override;\r\n procedure ShowPopup(Origin: TPoint); override;\r\n procedure HidePopup; override;\r\n procedure PopupChange; override;\r\n procedure PopupDropDown(DisableEdit: Boolean); override;\r\n function AcceptPopup(var Value: Variant): Boolean; override;\r\n procedure SetPopupValue(const Value: Variant); override;\r\n function GetPopupValue: Variant; override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n property LookupValue: string read GetLookupValue write SetLookupValue;\r\n published\r\n property DropDownCount: Integer read FDropDownCount write SetDropDownCount default 8;\r\n property DropDownWidth: Integer read FDropDownWidth write FDropDownWidth default 0;\r\n property ListStyle: TLookupListStyle read GetListStyle write SetListStyle default lsFixed;\r\n property FieldsDelimiter: Char read GetFieldsDelimiter write SetFieldsDelimiter default DefFieldsDelimiter;\r\n property LookupDisplay: string read GetLookupDisplay write SetLookupDisplay;\r\n property LookupDisplayIndex: Integer read GetDisplayIndex write SetDisplayIndex default 0;\r\n property LookupField: string read GetLookupField write SetLookupField;\r\n property LookupSource: TDataSource read GetLookupSource write SetLookupSource;\r\n property PopupOnlyLocate: Boolean read FPopupOnlyLocate write FPopupOnlyLocate default True;\r\n property Alignment;\r\n property AutoSelect;\r\n property AutoSize;\r\n property BorderStyle;\r\n property ButtonHint;\r\n property CharCase;\r\n property ClickKey;\r\n property Color;\r\n property DirectInput;\r\n property DragCursor;\r\n property DragMode;\r\n property EditMask;\r\n property Enabled;\r\n property Font;\r\n property BevelEdges;\r\n property BevelInner;\r\n property BevelKind default bkNone;\r\n property BevelOuter;\r\n property Flat;\r\n property ParentFlat;\r\n property HideSelection;\r\n property Anchors;\r\n property BiDiMode;\r\n property Constraints;\r\n property DragKind;\r\n property ParentBiDiMode;\r\n property ImeMode;\r\n property ImeName;\r\n property MaxLength;\r\n property OEMConvert;\r\n property ParentColor;\r\n property ParentFont;\r\n property ParentShowHint;\r\n property PopupAlign;\r\n property PopupMenu;\r\n property ReadOnly;\r\n property ShowHint;\r\n property TabOrder;\r\n property TabStop;\r\n property Text;\r\n property UseRecordCount: Boolean read GetUseRecordCount write SetUseRecordCount default False;\r\n property Visible;\r\n property OnCloseUp: TNotifyEvent read FOnCloseUp write FOnCloseUp;\r\n property OnDropDown: TNotifyEvent read FOnDropDown write FOnDropDown;\r\n property OnGetImage: TGetImageEvent read GetOnGetImage write SetOnGetImage;\r\n property OnButtonClick;\r\n property OnChange;\r\n property OnClick;\r\n property OnDblClick;\r\n property OnDragDrop;\r\n property OnDragOver;\r\n property OnEndDrag;\r\n property OnEnter;\r\n property OnExit;\r\n property OnKeyDown;\r\n property OnKeyPress;\r\n property OnKeyUp;\r\n property OnMouseDown;\r\n property OnMouseMove;\r\n property OnMouseUp;\r\n property OnStartDrag;\r\n property OnContextPopup;\r\n property OnEndDock;\r\n property OnStartDock;\r\n end;\r\n\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvDBLookup.pas $';\r\n Revision: '$Revision: 13415 $';\r\n Date: '$Date: 2012-09-10 11:51:54 +0200 (lun. 10 sept. 2012) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n VDBConsts, DBConsts, SysUtils, Math, MultiMon,\r\n JvJCLUtils, JvJVCLUtils, JvThemes, JvTypes, JvConsts, JvResources, JclSysUtils;\r\n\r\nprocedure CheckLookupFormat(const AFormat: string);\r\n { AFormat is passed to a Format function, but the only allowed\r\n format specifiers are %s, %S and %% }\r\nvar\r\n P: PChar;\r\nbegin\r\n P := StrScan(PChar(AFormat), '%');\r\n while Assigned(P) do\r\n begin\r\n Inc(P);\r\n if P^ = #0 then\r\n raise EJVCLException.CreateRes(@RsEInvalidFormatNotAllowed)\r\n else\r\n if not CharInSet(P^, ['%', 's', 'S']) then\r\n raise EJVCLException.CreateResFmt(@RsEInvalidFormatsNotAllowed,\r\n [QuotedStr('%' + P^)]);\r\n P := StrScan(P + 2, '%');\r\n end;\r\nend;\r\n\r\nfunction GetSpecifierCount(const AFormat: string): Integer;\r\n { GetSpecifierCount counts the nr of format specifiers in AFormat }\r\nvar\r\n P: PChar;\r\nbegin\r\n Result := 0;\r\n P := StrScan(PChar(AFormat), '%');\r\n while Assigned(P) do\r\n begin\r\n Inc(P);\r\n if P^ = #0 then\r\n Exit\r\n else\r\n if CharInSet(P^, ['s', 'S']) then\r\n Inc(Result);\r\n P := StrScan(P + 2, '%');\r\n end;\r\nend;\r\n\r\n//=== { TJvDataSourceLink } ==================================================\r\n\r\nprocedure TJvDataSourceLink.ActiveChanged;\r\nbegin\r\n if FDataControl <> nil then\r\n FDataControl.DataLinkActiveChanged;\r\nend;\r\n\r\nprocedure TJvDataSourceLink.LayoutChanged;\r\nbegin\r\n if FDataControl <> nil then\r\n FDataControl.CheckDataLinkActiveChanged;\r\nend;\r\n\r\nprocedure TJvDataSourceLink.RecordChanged(Field: TField);\r\nbegin\r\n if FDataControl <> nil then\r\n FDataControl.DataLinkRecordChanged(Field);\r\nend;\r\n\r\nprocedure TJvDataSourceLink.UpdateData;\r\nbegin\r\n if FDataControl <> nil then\r\n FDataControl.DataLinkUpdateData;\r\nend;\r\n\r\nprocedure TJvDataSourceLink.FocusControl(const Field: TField);\r\nbegin\r\n if (Field <> nil) and (FDataControl <> nil) and\r\n (Field = FDataControl.FDataField) and FDataControl.CanFocus then\r\n FDataControl.SetFocus;\r\nend;\r\n\r\n//=== { TLookupSourceLink } ==================================================\r\n\r\nprocedure TLookupSourceLink.ActiveChanged;\r\nbegin\r\n if FDataControl <> nil then\r\n FDataControl.ListLinkActiveChanged;\r\nend;\r\n\r\nprocedure TLookupSourceLink.LayoutChanged;\r\nbegin\r\n if FDataControl <> nil then\r\n FDataControl.ListLinkActiveChanged;\r\nend;\r\n\r\nprocedure TLookupSourceLink.DataSetChanged;\r\nbegin\r\n if FDataControl <> nil then\r\n FDataControl.ListLinkDataSetChanged;\r\nend;\r\n\r\nprocedure TLookupSourceLink.DataSetScrolled(Distance: Integer);\r\nbegin\r\n if FDataControl <> nil then\r\n FDataControl.ListLinkDataChanged;\r\nend;\r\n\r\n//=== { TJvLookupControl } ===================================================\r\n\r\nvar\r\n SearchTickCount: Longint = 0;\r\n\r\nconstructor TJvLookupControl.Create(AOwner: TComponent);\r\nconst\r\n LookupStyle = [csOpaque];\r\nbegin\r\n inherited Create(AOwner);\r\n ControlStyle := LookupStyle;\r\n IncludeThemeStyle(Self, [csNeedsBorderPaint]);\r\n\r\n ParentColor := False;\r\n TabStop := True;\r\n FFieldsDelimiter := DefFieldsDelimiter;\r\n FLookupSource := TDataSource.Create(Self);\r\n FDataLink := TJvDataSourceLink.Create;\r\n FDataLink.FDataControl := Self;\r\n FLookupLink := TLookupSourceLink.Create;\r\n FLookupLink.FDataControl := Self;\r\n FListFields := TList{$IFDEF RTL240_UP}{$ENDIF RTL240_UP}.Create;\r\n FEmptyValue := '';\r\n FEmptyStrIsNull := True;\r\n FEmptyItemColor := clWindow;\r\n FValue := FEmptyValue;\r\n FLocate := CreateLocate(nil);\r\n FIndexSwitch := True;\r\n FIgnoreCase := True;\r\n FUseRecordCount := False;\r\nend;\r\n\r\ndestructor TJvLookupControl.Destroy;\r\nbegin\r\n FListFields.Free;\r\n FListFields := nil;\r\n if FLookupLink <> nil then\r\n FLookupLink.FDataControl := nil;\r\n FLookupLink.Free;\r\n FLookupLink := nil;\r\n if FDataLink <> nil then\r\n FDataLink.FDataControl := nil;\r\n FDataLink.Free;\r\n FDataLink := nil;\r\n FLocate.Free;\r\n FLocate := nil;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJvLookupControl.CanModify: Boolean;\r\nbegin\r\n Result := FListActive and not ReadOnly and ((FDataLink.DataSource = nil) or\r\n (FMasterField <> nil) and FMasterField.CanModify);\r\nend;\r\n\r\nprocedure TJvLookupControl.Change;\r\nbegin\r\n if Assigned(FOnChange) then\r\n FOnChange(Self);\r\nend;\r\n\r\nfunction TJvLookupControl.ValueIsEmpty(const S: string): Boolean;\r\nbegin\r\n Result := (S = FEmptyValue);\r\nend;\r\n\r\nfunction TJvLookupControl.StoreEmpty: Boolean;\r\nbegin\r\n Result := (FEmptyValue <> '');\r\nend;\r\n\r\nprocedure TJvLookupControl.CheckNotFixed;\r\nbegin\r\n if FLookupMode then\r\n _DBError(SPropDefByLookup);\r\n if FDataLink.DataSourceFixed then\r\n _DBError(SDataSourceFixed);\r\nend;\r\n\r\nprocedure TJvLookupControl.SetLookupMode(Value: Boolean);\r\nbegin\r\n if FLookupMode <> Value then\r\n if Value then\r\n begin\r\n FMasterField := FDataField.DataSet.FieldByName(FDataField.KeyFields);\r\n FLookupSource.DataSet := FDataField.LookupDataSet;\r\n FLookupFieldName := FDataField.LookupKeyFields;\r\n FLookupMode := True;\r\n FLookupLink.DataSource := FLookupSource;\r\n end\r\n else\r\n begin\r\n FLookupLink.DataSource := nil;\r\n FLookupMode := False;\r\n FLookupFieldName := '';\r\n FLookupSource.DataSet := nil;\r\n FMasterField := FDataField;\r\n end;\r\nend;\r\n\r\nprocedure TJvLookupControl.SetUseRecordCount(const Value: Boolean);\r\nbegin\r\n if Value <> FUseRecordCount then\r\n begin\r\n FUseRecordCount := Value;\r\n ListLinkActiveChanged;\r\n if FListActive then\r\n DataLinkRecordChanged(nil);\r\n end;\r\nend;\r\n\r\nfunction TJvLookupControl.GetKeyValue: Variant;\r\nbegin\r\n if ValueIsEmpty(Value) then\r\n begin\r\n if (Value = '') and FEmptyStrIsNull then\r\n Result := Null\r\n else\r\n Result := FEmptyValue;\r\n end\r\n else\r\n Result := Value;\r\nend;\r\n\r\nprocedure TJvLookupControl.SetKeyValue(const Value: Variant);\r\nbegin\r\n if VarIsNullEmpty(Value) then\r\n Self.Value := FEmptyValue\r\n else\r\n Self.Value := Value;\r\nend;\r\n\r\nprocedure TJvLookupControl.CheckNotCircular;\r\nbegin\r\n {\r\n if FDataLink.Active and FDataLink.DataSet.IsLinkedTo(LookupSource) then\r\n _DBError(SCircularDataLink);\r\n }\r\n if FDataLink.Active and ((DataSource = LookupSource) or\r\n (FDataLink.DataSet = FLookupLink.DataSet)) then\r\n _DBError(SCircularDataLink);\r\nend;\r\n\r\nprocedure TJvLookupControl.CheckDataLinkActiveChanged;\r\nvar\r\n TestField: TField;\r\nbegin\r\n if FDataLink.Active and (FDataFieldName <> '') then\r\n begin\r\n TestField := FDataLink.DataSet.FieldByName(FDataFieldName);\r\n if FDataField <> TestField then\r\n begin\r\n FDataField := nil;\r\n FMasterField := nil;\r\n CheckNotCircular;\r\n FDataField := TestField;\r\n FMasterField := FDataField;\r\n end;\r\n DataLinkRecordChanged(nil);\r\n end;\r\nend;\r\n\r\nprocedure TJvLookupControl.DataLinkActiveChanged;\r\nbegin\r\n FDataField := nil;\r\n FMasterField := nil;\r\n if FDataLink.Active and (FDataFieldName <> '') then\r\n begin\r\n CheckNotCircular;\r\n FDataField := FDataLink.DataSet.FieldByName(FDataFieldName);\r\n FMasterField := FDataField;\r\n end;\r\n SetLookupMode((FDataField <> nil) and FDataField.Lookup);\r\n DataLinkRecordChanged(nil);\r\nend;\r\n\r\nprocedure TJvLookupControl.DataLinkRecordChanged(Field: TField);\r\nbegin\r\n if (Field = nil) or (Field = FMasterField) then\r\n begin\r\n if (FMasterField <> nil) and FMasterField.DataSet.Active then\r\n SetValueKey(FMasterField.AsString)\r\n else\r\n SetValueKey(FEmptyValue);\r\n end;\r\nend;\r\n\r\nprocedure TJvLookupControl.DataLinkUpdateData;\r\nbegin\r\nend;\r\n\r\nfunction TJvLookupControl.ExecuteAction(Action: TBasicAction): Boolean;\r\nbegin\r\n Result := inherited ExecuteAction(Action) or ((FDataLink <> nil) and\r\n FDataLink.ExecuteAction(Action));\r\nend;\r\n\r\nfunction TJvLookupControl.UpdateAction(Action: TBasicAction): Boolean;\r\nbegin\r\n Result := inherited UpdateAction(Action) or ((FDataLink <> nil) and\r\n FDataLink.UpdateAction(Action));\r\nend;\r\n\r\nfunction TJvLookupControl.UseRightToLeftAlignment: Boolean;\r\nbegin\r\n Result := DBUseRightToLeftAlignment(Self, Field);\r\nend;\r\n\r\nfunction TJvLookupControl.GetBorderSize: Integer;\r\nvar\r\n Params: TCreateParams;\r\n R: TRect;\r\nbegin\r\n CreateParams(Params);\r\n SetRect(R, 0, 0, 0, 0);\r\n AdjustWindowRectEx(R, Params.Style, False, Params.ExStyle);\r\n Result := R.Bottom - R.Top;\r\nend;\r\n\r\nfunction TJvLookupControl.GetDataSource: TDataSource;\r\nbegin\r\n Result := FDataLink.DataSource;\r\nend;\r\n\r\nfunction TJvLookupControl.GetLookupField: string;\r\nbegin\r\n if FLookupMode then\r\n Result := ''\r\n else\r\n Result := FLookupFieldName;\r\nend;\r\n\r\nfunction TJvLookupControl.GetLookupSource: TDataSource;\r\nbegin\r\n if FLookupMode then\r\n Result := nil\r\n else\r\n Result := FLookupLink.DataSource;\r\nend;\r\n\r\nfunction TJvLookupControl.GetReadOnly: Boolean;\r\nbegin\r\n Result := FDataLink.ReadOnly;\r\nend;\r\n\r\nfunction TJvLookupControl.GetField: TField;\r\nbegin\r\n if Assigned(FDataLink) then\r\n Result := FDataField\r\n else\r\n Result := nil;\r\nend;\r\n\r\n// (rom) is this useful for other components? It seems superior.\r\n\r\nfunction TJvLookupControl.DefaultTextHeight: Integer;\r\nvar\r\n DC: HDC;\r\n SaveFont: HFONT;\r\n Metrics: TTextMetric;\r\nbegin\r\n DC := GetDC(HWND_DESKTOP);\r\n SaveFont := SelectObject(DC, Font.Handle);\r\n GetTextMetrics(DC, Metrics);\r\n SelectObject(DC, SaveFont);\r\n ReleaseDC(HWND_DESKTOP, DC);\r\n Result := Metrics.tmHeight;\r\nend;\r\n\r\nfunction TJvLookupControl.GetTextHeight: Integer;\r\nbegin\r\n Result := Max(DefaultTextHeight, FItemHeight);\r\nend;\r\n\r\nprocedure TJvLookupControl.KeyValueChanged;\r\nbegin\r\nend;\r\n\r\nprocedure TJvLookupControl.DisplayValueChanged;\r\nbegin\r\nend;\r\n\r\nprocedure TJvLookupControl.ListLinkActiveChanged;\r\nvar\r\n DataSet: TDataSet;\r\n ResultField: TField;\r\nbegin\r\n FListActive := False;\r\n FKeyField := nil;\r\n FDisplayField := nil;\r\n FListFields.Clear;\r\n if FLookupLink.Active and (FLookupFieldName <> '') then\r\n begin\r\n CheckNotCircular;\r\n DataSet := FLookupLink.DataSet;\r\n FKeyField := DataSet.FieldByName(FLookupFieldName);\r\n DataSet.GetFieldList(FListFields, FLookupDisplay);\r\n if FLookupMode then\r\n begin\r\n ResultField := DataSet.FieldByName(FDataField.LookupResultField);\r\n if FListFields.IndexOf(ResultField) < 0 then\r\n FListFields.Insert(0, ResultField);\r\n FDisplayField := ResultField;\r\n end\r\n else\r\n begin\r\n if FListFields.Count = 0 then\r\n FListFields.Add(FKeyField);\r\n if (FDisplayIndex >= 0) and (FDisplayIndex < FListFields.Count) then\r\n FDisplayField := TField(FListFields[FDisplayIndex])\r\n else\r\n FDisplayField := TField(FListFields[0]);\r\n end;\r\n { Reset LookupFormat if the number of specifiers > fields count\r\n else function Format will raise an error }\r\n if GetSpecifierCount(FLookupFormat) > FListFields.Count then\r\n FLookupFormat := '';\r\n\r\n FListActive := True;\r\n end;\r\n FLocate.DataSet := FLookupLink.DataSet;\r\nend;\r\n\r\nprocedure TJvLookupControl.ListLinkDataChanged;\r\nbegin\r\nend;\r\n\r\nprocedure TJvLookupControl.ListLinkDataSetChanged;\r\nbegin\r\n ListLinkDataChanged;\r\nend;\r\n\r\nfunction TJvLookupControl.LocateDisplay: Boolean;\r\nbegin\r\n Result := False;\r\n try\r\n Result := Locate(FDisplayField, FDisplayValue, True);\r\n except\r\n end;\r\nend;\r\n\r\nfunction TJvLookupControl.LocateKey: Boolean;\r\nbegin\r\n Result := False;\r\n try\r\n Result := not ValueIsEmpty(FValue) and Locate(FKeyField, FValue, True);\r\n except\r\n end;\r\nend;\r\n\r\nprocedure TJvLookupControl.Notification(AComponent: TComponent;\r\n Operation: TOperation);\r\nbegin\r\n inherited Notification(AComponent, Operation);\r\n if Operation = opRemove then\r\n begin\r\n if (FDataLink <> nil) and (AComponent = DataSource) then\r\n DataSource := nil;\r\n if (FLookupLink <> nil) and (AComponent = LookupSource) then\r\n LookupSource := nil;\r\n if AComponent = FMasterField then\r\n FMasterField := nil;\r\n end;\r\nend;\r\n\r\nfunction TJvLookupControl.SearchText(var AValue: string): Boolean;\r\nbegin\r\n Result := False;\r\n if FDisplayField <> nil then\r\n if (AValue <> '') and Locate(FDisplayField, AValue, False) then\r\n begin\r\n SelectKeyValue(FKeyField.AsString);\r\n AValue := Copy(FDisplayField.AsString, 1, Length(AValue));\r\n Result := True;\r\n end\r\n else\r\n if AValue = '' then\r\n begin\r\n FLookupLink.DataSet.First;\r\n SelectKeyValue(FKeyField.AsString);\r\n AValue := '';\r\n end;\r\nend;\r\n\r\nprocedure TJvLookupControl.ProcessSearchKey(Key: Char);\r\nvar\r\n TickCount: Longint;\r\n S: string;\r\nbegin\r\n S := '';\r\n if (FDisplayField <> nil) {and (FDisplayField.DataType = ftString)} then\r\n case Key of\r\n Tab, Esc:\r\n FSearchText := '';\r\n Backspace, #32..#255:\r\n if CanModify then\r\n begin\r\n if not FPopup then\r\n begin\r\n TickCount := GetTickCount;\r\n if TickCount - SearchTickCount > 2000 then\r\n FSearchText := '';\r\n SearchTickCount := TickCount;\r\n end;\r\n if Key = Backspace then\r\n S := Copy(FSearchText, 1, Length(FSearchText) - 1)\r\n else\r\n if Length(FSearchText) < 32 then\r\n S := FSearchText + Key;\r\n if SearchText(S) or (S = '') then\r\n FSearchText := S;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvLookupControl.ResetField;\r\nbegin\r\n if (FDataLink.DataSource = nil) or (FMasterField = nil) or FDataLink.Edit then\r\n begin\r\n if FDataLink.Edit and (FMasterField <> nil) then\r\n SetFieldValue(FMasterField, FEmptyValue);\r\n FValue := FEmptyValue;\r\n FDisplayValue := '';\r\n inherited Text := DisplayEmpty;\r\n Invalidate;\r\n Click;\r\n end;\r\nend;\r\n\r\nprocedure TJvLookupControl.ClearValue;\r\nbegin\r\n SetValueKey(FEmptyValue);\r\nend;\r\n\r\nprocedure TJvLookupControl.SelectKeyValue(const Value: string);\r\nbegin\r\n if FMasterField <> nil then\r\n begin\r\n if CanModify and FDataLink.Edit then\r\n begin\r\n if FDataField = FMasterField then\r\n FDataField.DataSet.Edit;\r\n SetFieldValue(FMasterField, Value);\r\n end\r\n else\r\n Exit;\r\n end;\r\n SetValueKey(Value);\r\n UpdateDisplayValue;\r\n Repaint;\r\n Click;\r\nend;\r\n\r\nprocedure TJvLookupControl.SetDataFieldName(const Value: string);\r\nbegin\r\n if FDataFieldName <> Value then\r\n begin\r\n FDataFieldName := Value;\r\n DataLinkActiveChanged;\r\n end;\r\nend;\r\n\r\nprocedure TJvLookupControl.SetDataSource(Value: TDataSource);\r\nbegin\r\n if FDataLink.DataSource <> nil then\r\n FDataLink.DataSource.RemoveFreeNotification(Self);\r\n FDataLink.DataSource := Value;\r\n if Value <> nil then\r\n Value.FreeNotification(Self);\r\nend;\r\n\r\nprocedure TJvLookupControl.SetListStyle(Value: TLookupListStyle);\r\nbegin\r\n if FListStyle <> Value then\r\n begin\r\n FListStyle := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvLookupControl.SetFieldsDelimiter(Value: Char);\r\nbegin\r\n if FFieldsDelimiter <> Value then\r\n begin\r\n FFieldsDelimiter := Value;\r\n if ListStyle = lsDelimited then\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvLookupControl.SetLookupField(const Value: string);\r\nbegin\r\n CheckNotFixed;\r\n if FLookupFieldName <> Value then\r\n begin\r\n FLookupFieldName := Value;\r\n ListLinkActiveChanged;\r\n if FListActive then\r\n DataLinkRecordChanged(nil);\r\n end;\r\nend;\r\n\r\nprocedure TJvLookupControl.SetDisplayEmpty(const Value: string);\r\nbegin\r\n if FDisplayEmpty <> Value then\r\n begin\r\n UpdateDisplayEmpty(Value);\r\n FDisplayEmpty := Value;\r\n if not (csReading in ComponentState) then\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvLookupControl.SetDisplayIndex(const Value: Integer);\r\nbegin\r\n if Value <> FDisplayIndex then\r\n begin\r\n FDisplayIndex := Value;\r\n ListLinkActiveChanged;\r\n end;\r\nend;\r\n\r\nprocedure TJvLookupControl.SetEmptyValue(const Value: string);\r\nbegin\r\n if FEmptyValue <> Value then\r\n begin\r\n if ValueIsEmpty(FValue) then\r\n FValue := Value;\r\n FEmptyValue := Value;\r\n end;\r\nend;\r\n\r\nprocedure TJvLookupControl.SetFieldValue(Field: TField; const Value: string);\r\nbegin\r\n if Value = FEmptyValue then\r\n if (FEmptyValue = '') and FEmptyStrIsNull then\r\n Field.Clear\r\n else\r\n Field.AsString := FEmptyValue\r\n else\r\n Field.AsString := Value;\r\nend;\r\n\r\nprocedure TJvLookupControl.SetEmptyStrIsNull(const Value: Boolean);\r\nbegin\r\n if FEmptyStrIsNull <> Value then\r\n begin\r\n FEmptyStrIsNull := Value;\r\n if CanModify and (FDataLink.DataSource <> nil) and FDataLink.Edit then\r\n if FMasterField <> nil then\r\n SetFieldValue(FMasterField, FValue)\r\n else\r\n SetFieldValue(FDataField, FValue);\r\n end;\r\nend;\r\n\r\nprocedure TJvLookupControl.SetEmptyItemColor(Value: TColor);\r\nbegin\r\n if FEmptyItemColor <> Value then\r\n begin\r\n FEmptyItemColor := Value;\r\n if not (csReading in ComponentState) and EmptyRowVisible then\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvLookupControl.UpdateDisplayEmpty(const Value: string);\r\nbegin\r\nend;\r\n\r\nprocedure TJvLookupControl.SetDisplayValue(const Value: string);\r\nbegin\r\n if (FDisplayValue <> Value) and CanModify and (FDataLink.DataSource <> nil) and\r\n Locate(FDisplayField, Value, True) then\r\n begin\r\n if FDataLink.Edit then\r\n begin\r\n // if FMasterField <> nil then FMasterField.AsString := S\r\n // else FDataField.AsString := S;\r\n if FMasterField <> nil then\r\n SetFieldValue(FMasterField, FValue)\r\n else\r\n SetFieldValue(FDataField, FValue);\r\n end;\r\n end\r\n else\r\n if FDisplayValue <> Value then\r\n begin\r\n FDisplayValue := Value;\r\n DisplayValueChanged;\r\n Change;\r\n end;\r\nend;\r\n\r\nprocedure TJvLookupControl.UpdateKeyValue;\r\nbegin\r\n if FMasterField <> nil then\r\n FValue := FMasterField.AsString\r\n else\r\n FValue := FEmptyValue;\r\n KeyValueChanged;\r\nend;\r\n\r\nprocedure TJvLookupControl.SetValueKey(const Value: string);\r\nbegin\r\n if FValue <> Value then\r\n begin\r\n FValue := Value;\r\n KeyValueChanged;\r\n end;\r\nend;\r\n\r\nprocedure TJvLookupControl.SetValue(const Value: string);\r\nbegin\r\n if Value <> FValue then\r\n begin\r\n if CanModify and (FDataLink.DataSource <> nil) and FDataLink.Edit then\r\n begin\r\n // if FMasterField <> nil then FMasterField.AsString := Value\r\n // else FDataField.AsString := Value;\r\n if FMasterField <> nil then\r\n SetFieldValue(FMasterField, Value)\r\n else\r\n SetFieldValue(FDataField, Value);\r\n end\r\n else\r\n SetValueKey(Value);\r\n Change;\r\n end;\r\nend;\r\n\r\nprocedure TJvLookupControl.SetLookupDisplay(const Value: string);\r\nbegin\r\n if FLookupDisplay <> Value then\r\n begin\r\n FLookupDisplay := Value;\r\n ListLinkActiveChanged;\r\n if FListActive then\r\n DataLinkRecordChanged(nil);\r\n end;\r\nend;\r\n\r\nprocedure TJvLookupControl.SetLookupSource(Value: TDataSource);\r\nbegin\r\n CheckNotFixed;\r\n if FLookupLink.DataSource <> nil then\r\n FLookupLink.DataSource.RemoveFreeNotification(Self);\r\n FLookupLink.DataSource := Value;\r\n if Value <> nil then\r\n Value.FreeNotification(Self);\r\n if Value <> nil then\r\n FLocate.DataSet := Value.DataSet\r\n else\r\n FLocate.DataSet := nil;\r\n if FListActive then\r\n DataLinkRecordChanged(nil);\r\nend;\r\n\r\nprocedure TJvLookupControl.SetReadOnly(Value: Boolean);\r\nbegin\r\n FDataLink.ReadOnly := Value;\r\nend;\r\n\r\nfunction TJvLookupControl.GetItemHeight: Integer;\r\nbegin\r\n Result := {Max(GetTextHeight, FItemHeight);} GetTextHeight;\r\nend;\r\n\r\nprocedure TJvLookupControl.SetItemHeight(Value: Integer);\r\nbegin\r\n if not (csReading in ComponentState) then\r\n FItemHeight := Max(DefaultTextHeight, Value)\r\n else\r\n FItemHeight := Value;\r\n Perform(CM_FONTCHANGED, 0, 0);\r\nend;\r\n\r\nfunction TJvLookupControl.ItemHeightStored: Boolean;\r\nbegin\r\n Result := FItemHeight > DefaultTextHeight;\r\nend;\r\n\r\nprocedure TJvLookupControl.DrawPicture(Canvas: TCanvas; Rect: TRect;\r\n Image: TGraphic);\r\nvar\r\n X, Y, SaveIndex: Integer;\r\n Ico: HICON;\r\n W, H: Integer;\r\nbegin\r\n if Image <> nil then\r\n begin\r\n X := (Rect.Right + Rect.Left - Image.Width) div 2;\r\n Y := (Rect.Top + Rect.Bottom - Image.Height) div 2;\r\n SaveIndex := SaveDC(Canvas.Handle);\r\n try\r\n IntersectClipRect(Canvas.Handle, Rect.Left, Rect.Top, Rect.Right,\r\n Rect.Bottom);\r\n if Image is TBitmap then\r\n DrawBitmapTransparent(Canvas, X, Y, TBitmap(Image),\r\n TBitmap(Image).TransparentColor)\r\n else\r\n if Image is TIcon then\r\n begin\r\n Ico := CreateRealSizeIcon(TIcon(Image));\r\n try\r\n GetIconSize(Ico, W, H);\r\n DrawIconEx(Canvas.Handle, (Rect.Right + Rect.Left - W) div 2,\r\n (Rect.Top + Rect.Bottom - H) div 2, Ico, W, H, 0, 0, DI_NORMAL);\r\n finally\r\n DestroyIcon(Ico);\r\n end;\r\n end\r\n else\r\n Canvas.Draw(X, Y, Image);\r\n finally\r\n RestoreDC(Canvas.Handle, SaveIndex);\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJvLookupControl.GetPicture(Current, Empty: Boolean;\r\n var TextMargin: Integer): TGraphic;\r\nbegin\r\n TextMargin := 0;\r\n Result := nil;\r\n if Assigned(FOnGetImage) then\r\n FOnGetImage(Self, Empty, Result, TextMargin);\r\nend;\r\n\r\nprocedure TJvLookupControl.GetDlgCode(var Code: TDlgCodes);\r\nbegin\r\n Code := [dcWantArrows, dcWantChars];\r\nend;\r\n\r\nprocedure TJvLookupControl.FocusKilled(NextWnd: THandle);\r\nbegin\r\n FFocused := False;\r\n inherited FocusKilled(NextWnd);\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvLookupControl.FocusSet(PrevWnd: THandle);\r\nbegin\r\n FFocused := True;\r\n inherited FocusSet(PrevWnd);\r\n Invalidate;\r\nend;\r\n\r\nfunction TJvLookupControl.Locate(const SearchField: TField;\r\n const AValue: string; Exact: Boolean): Boolean;\r\nbegin\r\n FLocate.IndexSwitch := FIndexSwitch;\r\n Result := False;\r\n try\r\n if not ValueIsEmpty(AValue) and (SearchField <> nil) then\r\n begin\r\n Result := FLocate.Locate(SearchField.FieldName, AValue, Exact, not IgnoreCase, True, RightTrimmedLookup);\r\n if Result then\r\n begin\r\n if SearchField = FDisplayField then\r\n FValue := FKeyField.AsString;\r\n UpdateDisplayValue;\r\n end;\r\n end;\r\n except\r\n end;\r\nend;\r\n\r\nfunction TJvLookupControl.EmptyRowVisible: Boolean;\r\nbegin\r\n Result := DisplayEmpty <> '';\r\nend;\r\n\r\nprocedure TJvLookupControl.UpdateDisplayValue;\r\nbegin\r\n if not ValueIsEmpty(FValue) then\r\n begin\r\n if FDisplayField <> nil then\r\n FDisplayValue := FDisplayField.AsString\r\n else\r\n FDisplayValue := '';\r\n end\r\n else\r\n FDisplayValue := '';\r\nend;\r\n\r\nfunction TJvLookupControl.GetWindowWidth: Integer;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := 0;\r\n for I := 0 to FListFields.Count - 1 do\r\n Inc(Result, TField(FListFields[I]).DisplayWidth);\r\n Canvas.Font := Font;\r\n Result := Min(Result * Canvas.TextWidth('M') + FListFields.Count * 4 +\r\n GetSystemMetrics(SM_CXVSCROLL), Screen.Width);\r\nend;\r\n\r\nprocedure TJvLookupControl.SetLookupFormat(const Value: string);\r\nbegin\r\n if Value <> FLookupFormat then\r\n begin\r\n CheckLookupFormat(Value);\r\n FLookupFormat := Value;\r\n ListLinkActiveChanged;\r\n if FListActive then\r\n DataLinkRecordChanged(nil);\r\n end;\r\nend;\r\n\r\nfunction TJvLookupControl.DoFormatLine: string;\r\nvar\r\n J, LastFieldIndex: Integer;\r\n Field: TField;\r\n LStringList: array of string;\r\n LVarList: array of TVarRec;\r\nbegin\r\n Result := '';\r\n LastFieldIndex := FListFields.Count - 1;\r\n if LookupFormat > '' then\r\n begin\r\n SetLength(LStringList, LastFieldIndex + 1);\r\n SetLength(LVarList, LastFieldIndex + 1);\r\n\r\n for J := 0 to LastFieldIndex do\r\n begin\r\n LStringList[J] := TField(FListFields[J]).DisplayText;\r\n {$IFDEF SUPPORTS_UNICODE}\r\n LVarList[J].VPWideChar := PWideChar(LStringList[J]);\r\n LVarList[J].VType := vtPWideChar;\r\n {$ELSE}\r\n LVarList[J].VPChar := PAnsiChar(LStringList[J]);\r\n LVarList[J].VType := vtPChar;\r\n {$ENDIF SUPPORTS_UNICODE}\r\n end;\r\n Result := Format(LookupFormat, LVarList);\r\n end\r\n else\r\n for J := 0 to LastFieldIndex do\r\n begin\r\n Field := TField(FListFields[J]);\r\n Result := Result + Field.DisplayText;\r\n if J < LastFieldIndex then\r\n Result := Result + FFieldsDelimiter + ' ';\r\n end;\r\nend;\r\n\r\n//=== { TJvDBLookupList } ====================================================\r\n\r\nconstructor TJvDBLookupList.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n Width := 121;\r\n Ctl3D := True;\r\n FBorderStyle := bsSingle;\r\n ControlStyle := [csOpaque, csDoubleClicks];\r\n RowCount := 7;\r\nend;\r\n\r\nprocedure TJvDBLookupList.CreateParams(var Params: TCreateParams);\r\nbegin\r\n inherited CreateParams(Params);\r\n with Params do\r\n begin\r\n Style := Style or WS_VSCROLL;\r\n if FBorderStyle = bsSingle then\r\n if Ctl3D then\r\n ExStyle := ExStyle or WS_EX_CLIENTEDGE\r\n else\r\n Style := Style or WS_BORDER;\r\n end;\r\nend;\r\n\r\nprocedure TJvDBLookupList.CreateWnd;\r\nbegin\r\n inherited CreateWnd;\r\n UpdateScrollBar;\r\nend;\r\n\r\nprocedure TJvDBLookupList.Loaded;\r\nbegin\r\n inherited Loaded;\r\n Height := Height;\r\nend;\r\n\r\nfunction TJvDBLookupList.GetKeyIndex: Integer;\r\nvar\r\n FieldValue: string;\r\nbegin\r\n if not ValueIsEmpty(FValue) then\r\n for Result := 0 to FRecordCount - 1 do\r\n begin\r\n FLookupLink.ActiveRecord := Result;\r\n FieldValue := FKeyField.AsString;\r\n FLookupLink.ActiveRecord := FRecordIndex;\r\n if FieldValue = FValue then\r\n Exit;\r\n end;\r\n Result := -1;\r\nend;\r\n\r\nprocedure TJvDBLookupList.KeyDown(var Key: Word; Shift: TShiftState);\r\nvar\r\n Delta, KeyIndex, EmptyRow: Integer;\r\nbegin\r\n inherited KeyDown(Key, Shift);\r\n FSelectEmpty := False;\r\n EmptyRow := Ord(EmptyRowVisible);\r\n if CanModify then\r\n begin\r\n Delta := 0;\r\n case Key of\r\n VK_UP, VK_LEFT:\r\n Delta := -1;\r\n VK_DOWN, VK_RIGHT:\r\n Delta := 1;\r\n VK_PRIOR:\r\n Delta := 1 - (FRowCount - EmptyRow);\r\n VK_NEXT:\r\n Delta := (FRowCount - EmptyRow) - 1;\r\n VK_HOME:\r\n Delta := -MaxInt;\r\n VK_END:\r\n Delta := MaxInt;\r\n end;\r\n if Delta <> 0 then\r\n begin\r\n if ValueIsEmpty(Value) and (EmptyRow > 0) and (Delta < 0) then\r\n FSelectEmpty := True;\r\n FSearchText := '';\r\n if Delta = -MaxInt then\r\n FLookupLink.DataSet.First\r\n else\r\n if Delta = MaxInt then\r\n FLookupLink.DataSet.Last\r\n else\r\n begin\r\n KeyIndex := GetKeyIndex;\r\n if KeyIndex >= 0 then\r\n begin\r\n FLookupLink.DataSet.MoveBy(KeyIndex - FRecordIndex);\r\n end\r\n else\r\n begin\r\n KeyValueChanged;\r\n Delta := 0;\r\n end;\r\n FLookupLink.DataSet.MoveBy(Delta);\r\n if FLookupLink.DataSet.Bof and (Delta < 0) and (EmptyRow > 0) then\r\n FSelectEmpty := True;\r\n end;\r\n SelectCurrent;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvDBLookupList.KeyPress(var Key: Char);\r\nbegin\r\n inherited KeyPress(Key);\r\n ProcessSearchKey(Key);\r\nend;\r\n\r\nprocedure TJvDBLookupList.KeyValueChanged;\r\nbegin\r\n if FListActive and not FLockPosition then\r\n if not LocateKey then\r\n FLookupLink.DataSet.First;\r\nend;\r\n\r\nprocedure TJvDBLookupList.DisplayValueChanged;\r\nbegin\r\n if FListActive and not FLockPosition then\r\n if not LocateDisplay then\r\n FLookupLink.DataSet.First;\r\nend;\r\n\r\nprocedure TJvDBLookupList.ListLinkActiveChanged;\r\nbegin\r\n try\r\n inherited ListLinkActiveChanged;\r\n finally\r\n if FListActive and not FLockPosition then\r\n begin\r\n if Assigned(FMasterField) then\r\n UpdateKeyValue\r\n else\r\n KeyValueChanged;\r\n end\r\n else\r\n ListDataChanged;\r\n end;\r\nend;\r\n\r\nprocedure TJvDBLookupList.ListDataChanged;\r\nbegin\r\n if FListActive then\r\n begin\r\n FRecordIndex := FLookupLink.ActiveRecord;\r\n\r\n // Note: if we cannot access the DataSet, then the record count will be\r\n // the one from the link and can be different from the total record count.\r\n // This may result in not displaying the scrollbar.\r\n // This was changed from simply using FLookupLink.RecordCount to fix\r\n // Mantis 3825.\r\n if Assigned(FLookupLink.DataSet) and UseRecordCount then\r\n FRecordCount := FLookupLink.DataSet.RecordCount\r\n else\r\n FRecordCount := FLookupLink.RecordCount;\r\n FKeySelected := not ValueIsEmpty(FValue) or not FLookupLink.DataSet.Bof;\r\n end\r\n else\r\n begin\r\n FRecordIndex := 0;\r\n FRecordCount := 0;\r\n FKeySelected := False;\r\n end;\r\n if HandleAllocated then\r\n begin\r\n UpdateScrollBar;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvDBLookupList.ListLinkDataChanged;\r\nbegin\r\n ListDataChanged;\r\nend;\r\n\r\nprocedure TJvDBLookupList.MouseDown(Button: TMouseButton; Shift: TShiftState;\r\n X, Y: Integer);\r\nbegin\r\n if Button = mbLeft then\r\n begin\r\n FSearchText := '';\r\n if not FPopup then\r\n begin\r\n if CanFocus then\r\n SetFocus;\r\n if not FFocused then\r\n Exit;\r\n end;\r\n if CanModify then\r\n if ssDouble in Shift then\r\n begin\r\n if FRecordIndex = Y div GetTextHeight then\r\n DblClick;\r\n end\r\n else\r\n begin\r\n MouseCapture := True;\r\n FTracking := True;\r\n SelectItemAt(X, Y);\r\n end;\r\n end;\r\n inherited MouseDown(Button, Shift, X, Y);\r\nend;\r\n\r\nprocedure TJvDBLookupList.MouseMove(Shift: TShiftState; X, Y: Integer);\r\nbegin\r\n if FTracking then\r\n begin\r\n SelectItemAt(X, Y);\r\n FMousePos := Y;\r\n TimerScroll;\r\n end;\r\n inherited MouseMove(Shift, X, Y);\r\nend;\r\n\r\nprocedure TJvDBLookupList.MouseUp(Button: TMouseButton; Shift: TShiftState;\r\n X, Y: Integer);\r\nbegin\r\n if FTracking then\r\n begin\r\n StopTracking;\r\n SelectItemAt(X, Y);\r\n end;\r\n inherited MouseUp(Button, Shift, X, Y);\r\nend;\r\n\r\nprocedure TJvDBLookupList.DrawItemText(Canvas: TCanvas; Rect: TRect;\r\n Selected, IsEmpty: Boolean);\r\nvar\r\n J, W, X, ATop, TextWidth, LastFieldIndex: Integer;\r\n S: string;\r\n Field: TField;\r\n R: TRect;\r\n AAlignment: TAlignment;\r\nbegin\r\n TextWidth := Canvas.TextWidth('M');\r\n LastFieldIndex := FListFields.Count - 1;\r\n R := Rect;\r\n R.Right := R.Left;\r\n S := '';\r\n ATop := (R.Bottom + R.Top - CanvasMaxTextHeight(Canvas)) div 2;\r\n if FListStyle = lsFixed then\r\n for J := 0 to LastFieldIndex do\r\n begin\r\n Field := TField(FListFields[J]);\r\n if J < LastFieldIndex then\r\n W := Field.DisplayWidth * TextWidth + 4\r\n else\r\n W := ClientWidth - R.Right;\r\n if IsEmpty then\r\n begin\r\n if J = 0 then\r\n begin\r\n S := DisplayEmpty;\r\n end\r\n else\r\n S := '';\r\n end\r\n else\r\n S := Field.DisplayText;\r\n X := 2;\r\n AAlignment := Field.Alignment;\r\n if UseRightToLeftAlignment then\r\n ChangeBiDiModeAlignment(AAlignment);\r\n case AAlignment of\r\n taRightJustify:\r\n X := W - Canvas.TextWidth(S) - 3;\r\n taCenter:\r\n X := (W - Canvas.TextWidth(S)) div 2;\r\n end;\r\n R.Left := R.Right;\r\n R.Right := R.Right + W;\r\n if SysLocale.MiddleEast and UseRightToLeftReading then\r\n Canvas.TextFlags := Canvas.TextFlags or ETO_RTLREADING\r\n else\r\n Canvas.TextFlags := Canvas.TextFlags and not ETO_RTLREADING;\r\n Canvas.TextRect(R, R.Left + X, ATop, S);\r\n if J < LastFieldIndex then\r\n begin\r\n Canvas.MoveTo(R.Right, R.Top);\r\n Canvas.LineTo(R.Right, R.Bottom);\r\n Inc(R.Right);\r\n if R.Right >= ClientWidth then\r\n Break;\r\n end;\r\n end\r\n else\r\n if not IsEmpty then\r\n S := DoFormatLine;\r\n if FListStyle = lsDelimited then\r\n begin\r\n if IsEmpty then\r\n S := DisplayEmpty;\r\n R.Left := Rect.Left;\r\n R.Right := Rect.Right;\r\n if SysLocale.MiddleEast and UseRightToLeftReading then\r\n Canvas.TextFlags := Canvas.TextFlags or ETO_RTLREADING\r\n else\r\n Canvas.TextFlags := Canvas.TextFlags and not ETO_RTLREADING;\r\n Canvas.TextRect(R, R.Left + 2, ATop, S);\r\n end;\r\nend;\r\n\r\nprocedure TJvDBLookupList.Paint;\r\nvar\r\n I, J, TextHeight, TextMargin: Integer;\r\n Image: TGraphic;\r\n Bmp: TBitmap;\r\n R, ImageRect: TRect;\r\n Selected: Boolean;\r\nbegin\r\n Bmp := TBitmap.Create;\r\n try\r\n Canvas.Font := Font;\r\n TextHeight := GetTextHeight;\r\n if ColorToRGB(Color) <> ColorToRGB(clBtnFace) then\r\n Canvas.Pen.Color := clBtnFace\r\n else\r\n Canvas.Pen.Color := clBtnShadow;\r\n for I := 0 to FRowCount - 1 do\r\n begin\r\n J := I - Ord(EmptyRowVisible);\r\n Canvas.Font.Color := Font.Color;\r\n Canvas.Brush.Color := Color;\r\n Selected := not FKeySelected and (I = 0) and not EmptyRowVisible;\r\n R.Top := I * TextHeight;\r\n R.Bottom := R.Top + TextHeight;\r\n if I < FRecordCount + Ord(EmptyRowVisible) then\r\n begin\r\n if (I = 0) and (J = -1) then\r\n begin\r\n if ValueIsEmpty(FValue) then\r\n begin\r\n Canvas.Font.Color := clHighlightText;\r\n Canvas.Brush.Color := clHighlight;\r\n Selected := True;\r\n end\r\n else\r\n Canvas.Brush.Color := EmptyItemColor;\r\n R.Left := 0;\r\n R.Right := ClientWidth;\r\n Image := GetPicture(False, True, TextMargin);\r\n if TextMargin > 0 then\r\n begin\r\n Bmp.Canvas.Font := Canvas.Font;\r\n Bmp.Canvas.Brush := Canvas.Brush;\r\n Bmp.Canvas.Pen := Canvas.Pen;\r\n Bmp.Width := RectWidth(R);\r\n Bmp.Height := RectHeight(R);\r\n ImageRect := Bounds(0, 0, TextMargin, RectHeight(R));\r\n Bmp.Canvas.FillRect(ImageRect);\r\n if Image <> nil then\r\n DrawPicture(Bmp.Canvas, ImageRect, Image);\r\n DrawItemText(Bmp.Canvas, Bounds(TextMargin, 0, RectWidth(R) - TextMargin,\r\n RectHeight(R)), Selected, True);\r\n Canvas.Draw(R.Left, R.Top, Bmp);\r\n end\r\n else\r\n DrawItemText(Canvas, R, Selected, True);\r\n end\r\n else\r\n begin\r\n FLookupLink.ActiveRecord := J;\r\n if not ValueIsEmpty(FValue) and (FKeyField.AsString = FValue) then\r\n begin\r\n Canvas.Font.Color := clHighlightText;\r\n Canvas.Brush.Color := clHighlight;\r\n Selected := True;\r\n end;\r\n R.Left := 0;\r\n R.Right := ClientWidth;\r\n Image := GetPicture(False, False, TextMargin);\r\n if TextMargin > 0 then\r\n begin\r\n Bmp.Canvas.Font := Canvas.Font;\r\n Bmp.Canvas.Brush := Canvas.Brush;\r\n Bmp.Canvas.Pen := Canvas.Pen;\r\n Bmp.Width := RectWidth(R);\r\n Bmp.Height := RectHeight(R);\r\n ImageRect := Bounds(0, 0, TextMargin, RectHeight(R));\r\n Bmp.Canvas.FillRect(ImageRect);\r\n if Image <> nil then\r\n DrawPicture(Bmp.Canvas, ImageRect, Image);\r\n DrawItemText(Bmp.Canvas, Bounds(TextMargin, 0, RectWidth(R) - TextMargin,\r\n RectHeight(R)), Selected, False);\r\n Canvas.Draw(R.Left, R.Top, Bmp);\r\n end\r\n else\r\n DrawItemText(Canvas, R, Selected, False);\r\n end;\r\n end;\r\n R.Left := 0;\r\n R.Right := ClientWidth;\r\n if J >= FRecordCount then\r\n Canvas.FillRect(R);\r\n if Selected and (FFocused or FPopup) then\r\n Canvas.DrawFocusRect(R);\r\n end;\r\n finally\r\n Bmp.Free;\r\n end;\r\n if FRecordCount <> 0 then\r\n FLookupLink.ActiveRecord := FRecordIndex;\r\nend;\r\n\r\nprocedure TJvDBLookupList.SelectCurrent;\r\nbegin\r\n FLockPosition := True;\r\n try\r\n if FSelectEmpty then\r\n ResetField\r\n else\r\n SelectKeyValue(FKeyField.AsString);\r\n finally\r\n FSelectEmpty := False;\r\n FLockPosition := False;\r\n end;\r\nend;\r\n\r\nprocedure TJvDBLookupList.SelectItemAt(X, Y: Integer);\r\nvar\r\n Delta: Integer;\r\nbegin\r\n if Y < 0 then\r\n Y := 0;\r\n if Y >= ClientHeight then\r\n Y := ClientHeight - 1;\r\n Delta := Y div GetTextHeight;\r\n if (Delta = 0) and EmptyRowVisible then\r\n FSelectEmpty := True\r\n else\r\n begin\r\n Delta := Delta - FRecordIndex;\r\n if EmptyRowVisible then\r\n Dec(Delta);\r\n FLookupLink.DataSet.MoveBy(Delta);\r\n end;\r\n SelectCurrent;\r\nend;\r\n\r\nprocedure TJvDBLookupList.SetBorderStyle(Value: TBorderStyle);\r\nbegin\r\n if FBorderStyle <> Value then\r\n begin\r\n FBorderStyle := Value;\r\n RecreateWnd;\r\n if not (csReading in ComponentState) then\r\n begin\r\n Height := Height;\r\n RowCount := RowCount;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvDBLookupList.UpdateDisplayEmpty(const Value: string);\r\nbegin\r\n UpdateBufferCount(RowCount - Ord(Value <> ''));\r\nend;\r\n\r\nprocedure TJvDBLookupList.UpdateBufferCount(Rows: Integer);\r\nbegin\r\n if FLookupLink.BufferCount <> Rows then\r\n begin\r\n FLookupLink.BufferCount := Rows;\r\n ListLinkDataChanged;\r\n end;\r\nend;\r\n\r\nprocedure TJvDBLookupList.SetBounds(ALeft, ATop, AWidth, AHeight: Integer);\r\nvar\r\n BorderSize, TextHeight, Rows: Integer;\r\nbegin\r\n BorderSize := GetBorderSize;\r\n TextHeight := GetTextHeight;\r\n Rows := (AHeight - BorderSize) div TextHeight;\r\n if Rows < 1 then\r\n Rows := 1;\r\n FRowCount := Rows;\r\n UpdateBufferCount(Rows - Ord(EmptyRowVisible));\r\n if not (csReading in ComponentState) then\r\n AHeight := Rows * TextHeight + BorderSize;\r\n inherited SetBounds(ALeft, ATop, AWidth, AHeight);\r\nend;\r\n\r\nprocedure TJvDBLookupList.SetRowCount(Value: Integer);\r\nbegin\r\n if Value < 1 then\r\n Value := 1;\r\n if Value > 50 then\r\n Value := 50;\r\n Height := Value * GetTextHeight + GetBorderSize;\r\nend;\r\n\r\nprocedure TJvDBLookupList.StopTimer;\r\nbegin\r\n if FTimerActive then\r\n begin\r\n // (rom) why not a TTimer?\r\n KillTimer(Handle, 1);\r\n FTimerActive := False;\r\n end;\r\nend;\r\n\r\nprocedure TJvDBLookupList.StopTracking;\r\nbegin\r\n if FTracking then\r\n begin\r\n StopTimer;\r\n FTracking := False;\r\n MouseCapture := False;\r\n end;\r\nend;\r\n\r\nprocedure TJvDBLookupList.TimerScroll;\r\nvar\r\n Delta, Distance, Interval: Integer;\r\nbegin\r\n Delta := 0;\r\n Distance := 0;\r\n if FMousePos < 0 then\r\n begin\r\n Delta := -1;\r\n Distance := -FMousePos;\r\n end;\r\n if FMousePos >= ClientHeight then\r\n begin\r\n Delta := 1;\r\n Distance := FMousePos - ClientHeight + 1;\r\n end;\r\n if Delta = 0 then\r\n StopTimer\r\n else\r\n begin\r\n if FLookupLink.DataSet.MoveBy(Delta) <> 0 then\r\n SelectCurrent;\r\n Interval := 200 - Distance * 15;\r\n if Interval < 0 then\r\n Interval := 0;\r\n SetTimer(Handle, 1, Interval, nil);\r\n FTimerActive := True;\r\n end;\r\nend;\r\n\r\nprocedure TJvDBLookupList.UpdateScrollBar;\r\nvar\r\n Pos, Max: Integer;\r\n ScrollInfo: TScrollInfo;\r\n WantScrollbar: Boolean;\r\nbegin\r\n Pos := 0;\r\n Max := 0;\r\n\r\n if Assigned(FLookupLink.DataSet) and FLookupLink.Active then\r\n begin\r\n if UseRecordCount then\r\n // FRecordCount is #records in the table\r\n WantScrollbar := FRecordCount > (FRowCount - Ord(EmptyRowVisible))\r\n else\r\n // FRecordCount is #records in the link buffer; we don't know the #records\r\n // in the table, but is it equal or bigger than FRecordCount, if FRecordCount\r\n // is smaller than the # of rows in the dropdown then FRecordCount is equal\r\n // to the #records in the table and no scrollbar is shown.\r\n WantScrollbar := FRecordCount = (FRowCount - Ord(EmptyRowVisible));\r\n\r\n if WantScrollbar then\r\n begin\r\n if UseRecordCount and (FLookupLink.DataSet.RecNo <> -1) then\r\n begin\r\n // We can be accurate\r\n Max := FRecordCount - 1;\r\n Pos := FLookupLink.DataSet.RecNo - 1;\r\n end\r\n else\r\n begin\r\n // Use an approximation\r\n Max := 4;\r\n if not FLookupLink.DataSet.Bof then\r\n if not FLookupLink.DataSet.Eof then\r\n Pos := 2\r\n else\r\n Pos := 4;\r\n end;\r\n end;\r\n end;\r\n ScrollInfo.cbSize := SizeOf(TScrollInfo);\r\n ScrollInfo.fMask := SIF_POS or SIF_RANGE;\r\n if not GetScrollInfo(Handle, SB_VERT, ScrollInfo) or\r\n (ScrollInfo.nPos <> Pos) or (ScrollInfo.nMax <> Max) then\r\n begin\r\n ScrollInfo.nMin := 0;\r\n ScrollInfo.nMax := Max;\r\n ScrollInfo.nPos := Pos;\r\n SetScrollInfo(Handle, SB_VERT, ScrollInfo, True);\r\n end;\r\nend;\r\n\r\nprocedure TJvDBLookupList.CMCtl3DChanged(var Msg: TMessage);\r\nbegin\r\n if FBorderStyle = bsSingle then\r\n begin\r\n RecreateWnd;\r\n if not (csReading in ComponentState) then\r\n RowCount := RowCount;\r\n end;\r\n inherited;\r\nend;\r\n\r\nprocedure TJvDBLookupList.FontChanged;\r\nbegin\r\n inherited FontChanged;\r\n if not (csReading in ComponentState) then\r\n Height := Height;\r\nend;\r\n\r\nprocedure TJvDBLookupList.WMCancelMode(var Msg: TMessage);\r\nbegin\r\n StopTracking;\r\n inherited;\r\nend;\r\n\r\nprocedure TJvDBLookupList.WMTimer(var Msg: TMessage);\r\nbegin\r\n TimerScroll;\r\nend;\r\n\r\nprocedure TJvDBLookupList.WMNCHitTest(var Msg: TWMNCHitTest);\r\nbegin\r\n if csDesigning in ComponentState then\r\n begin\r\n if FLookupLink.Active then\r\n DefaultHandler(Msg)\r\n else\r\n inherited;\r\n end\r\n else\r\n inherited;\r\nend;\r\n\r\nfunction TJvDBLookupList.DoMouseWheelDown(Shift: TShiftState;\r\n MousePos: TPoint): Boolean;\r\nvar\r\n ScrollableRowCount: Integer;\r\nbegin\r\n Result := inherited DoMouseWheelDown(Shift, MousePos);\r\n if not Result then\r\n begin\r\n if FLookupLink.DataSet = nil then\r\n Exit;\r\n\r\n ScrollableRowCount := RowCount - Ord(EmptyRowVisible);\r\n\r\n with FLookupLink.DataSet do\r\n { ScrollableRowCount - FRecordIndex - 1 = #records till end of visible list\r\n ScrollableRowCount div 2 = half visible list.\r\n }\r\n if Shift * [ssShift, ssCtrl] <> [] then\r\n { 1 line down }\r\n Result := MoveBy(ScrollableRowCount - FRecordIndex) <> 0\r\n else\r\n { Half Page down }\r\n Result := MoveBy(ScrollableRowCount - FRecordIndex + ScrollableRowCount div 2 - 1) <> 0;\r\n end;\r\nend;\r\n\r\nfunction TJvDBLookupList.DoMouseWheelUp(Shift: TShiftState;\r\n MousePos: TPoint): Boolean;\r\nvar\r\n ScrollableRowCount: Integer;\r\nbegin\r\n Result := inherited DoMouseWheelUp(Shift, MousePos);\r\n if not Result then\r\n begin\r\n if FLookupLink.DataSet = nil then\r\n Exit;\r\n\r\n ScrollableRowCount := RowCount - Ord(EmptyRowVisible);\r\n\r\n with FLookupLink.DataSet do\r\n { -FRecordIndex = #records till begin of visible list\r\n ScrollableRowCount div 2 = half visible list.\r\n }\r\n if Shift * [ssShift, ssCtrl] <> [] then\r\n { One line up }\r\n Result := MoveBy(-FRecordIndex - 1) <> 0\r\n else\r\n { Half Page up }\r\n Result := MoveBy(-FRecordIndex - ScrollableRowCount div 2) <> 0;\r\n end;\r\nend;\r\n\r\nprocedure TJvDBLookupList.WMVScroll(var Msg: TWMVScroll);\r\nvar\r\n ScrollableRowCount: Integer;\r\nbegin\r\n FSearchText := '';\r\n if FLookupLink.DataSet = nil then\r\n Exit;\r\n\r\n ScrollableRowCount := RowCount - Ord(EmptyRowVisible);\r\n\r\n with Msg, FLookupLink.DataSet do\r\n case ScrollCode of\r\n SB_LINEUP:\r\n MoveBy(-FRecordIndex - 1);\r\n SB_LINEDOWN:\r\n MoveBy(ScrollableRowCount - FRecordIndex);\r\n SB_PAGEUP:\r\n MoveBy(-FRecordIndex - ScrollableRowCount + 1);\r\n SB_PAGEDOWN:\r\n MoveBy(ScrollableRowCount - FRecordIndex + ScrollableRowCount - 2);\r\n SB_THUMBPOSITION:\r\n begin\r\n case Pos of\r\n 0:\r\n First;\r\n 1:\r\n MoveBy(-FRecordIndex - ScrollableRowCount + 1);\r\n 2:\r\n Exit;\r\n 3:\r\n MoveBy(ScrollableRowCount - FRecordIndex + ScrollableRowCount - 2);\r\n 4:\r\n Last;\r\n end;\r\n end;\r\n SB_BOTTOM:\r\n Last;\r\n SB_TOP:\r\n First;\r\n end;\r\nend;\r\n\r\n//=== { TJvPopupDataList } ===================================================\r\n\r\nconstructor TJvPopupDataList.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n if AOwner is TJvLookupControl then\r\n FCombo := TJvLookupControl(AOwner);\r\n ControlStyle := ControlStyle + [csNoDesignVisible, csReplicatable];\r\n FPopup := True;\r\n TabStop := False;\r\n ParentCtl3D := False;\r\n Ctl3D := False;\r\nend;\r\n\r\nprocedure TJvPopupDataList.CreateParams(var Params: TCreateParams);\r\n{$IFDEF COMPILER6}\r\nconst\r\n CS_DROPSHADOW = $20000;\r\n{$ENDIF COMPILER6}\r\nbegin\r\n inherited CreateParams(Params);\r\n with Params do\r\n begin\r\n Style := WS_POPUP or WS_BORDER;\r\n ExStyle := WS_EX_TOOLWINDOW;\r\n AddBiDiModeExStyle(ExStyle);\r\n WindowClass.Style := CS_SAVEBITS;\r\n if CheckWin32Version(5, 1) then // Windows XP+\r\n WindowClass.Style := WindowClass.Style or CS_DROPSHADOW;\r\n end;\r\nend;\r\n\r\nprocedure TJvPopupDataList.CMHintShow(var Msg: TMessage);\r\nbegin\r\n // never show\r\n Msg.Result := 1;\r\nend;\r\n\r\nprocedure TJvPopupDataList.WMMouseActivate(var Msg: TMessage);\r\nbegin\r\n Msg.Result := MA_NOACTIVATE;\r\nend;\r\n\r\nprocedure TJvPopupDataList.Click;\r\nbegin\r\n inherited Click;\r\n if Assigned(FCombo) and TJvDBLookupCombo(FCombo).FListVisible then\r\n TJvDBLookupCombo(FCombo).InvalidateText;\r\nend;\r\n\r\nprocedure TJvPopupDataList.KeyPress(var Key: Char);\r\nbegin\r\n inherited KeyPress(Key);\r\n if Assigned(FCombo) and TJvDBLookupCombo(FCombo).FListVisible then\r\n TJvDBLookupCombo(FCombo).InvalidateText;\r\nend;\r\n\r\n//=== { TJvDBLookupCombo } ===================================================\r\n\r\nconstructor TJvDBLookupCombo.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n ControlStyle := ControlStyle + [csReplicatable] - [csSetCaption];\r\n Width := 145;\r\n Height := 0;\r\n FDataList := TJvPopupDataList.Create(Self);\r\n FDataList.Visible := False;\r\n FDataList.Parent := Self;\r\n FDataList.OnMouseUp := ListMouseUp;\r\n FButtonWidth := GetSystemMetrics(SM_CXVSCROLL);\r\n FDropDownCount := 8;\r\n FDisplayValues := TStringList.Create;\r\n FSelImage := TPicture.Create;\r\n Height := {GetMinHeight} 21;\r\n FEscapeKeyReset := True;\r\n FDeleteKeyClear := True;\r\n FLastValue := Unassigned;\r\nend;\r\n\r\ndestructor TJvDBLookupCombo.Destroy;\r\nbegin\r\n FSelImage.Free;\r\n FSelImage := nil;\r\n FreeAndNil(FDisplayValues);\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvDBLookupCombo.CreateParams(var Params: TCreateParams);\r\nbegin\r\n inherited CreateParams(Params);\r\n with Params do\r\n if Ctl3D then\r\n ExStyle := ExStyle or WS_EX_CLIENTEDGE\r\n else\r\n Style := Style or WS_BORDER;\r\nend;\r\n\r\nprocedure TJvDBLookupCombo.ReadEscapeClear(Reader: TReader);\r\nbegin\r\n DeleteKeyClear := Reader.ReadBoolean;\r\nend;\r\n\r\nprocedure TJvDBLookupCombo.DefineProperties(Filer: TFiler);\r\nbegin\r\n inherited DefineProperties(Filer);\r\n // backward compatiblity\r\n Filer.DefineProperty('EscapeClear', ReadEscapeClear, nil, False);\r\nend;\r\n\r\nprocedure TJvDBLookupCombo.DataLinkUpdateData;\r\nbegin\r\n inherited DataLinkUpdateData;\r\n if (Field <> nil) and FDataLink.Active then\r\n FLastValue := Field.Value;\r\nend;\r\n\r\nprocedure TJvDBLookupCombo.DataLinkRecordChanged(AField: TField);\r\nbegin\r\n if (AField = nil) and (Field <> nil) and (FDataLink.Active) then\r\n FLastValue := Field.Value;\r\n inherited DataLinkRecordChanged(AField);\r\nend;\r\n\r\nfunction ParentFormVisible(AControl: TControl): Boolean;\r\nvar\r\n Form: TCustomForm;\r\nbegin\r\n Form := GetParentForm(AControl);\r\n Result := Assigned(Form) and Form.Visible;\r\nend;\r\n\r\nprocedure TJvDBLookupCombo.CloseUp(Accept: Boolean);\r\nvar\r\n ListValue: string;\r\nbegin\r\n if FListVisible then\r\n begin\r\n if GetCapture <> 0 then\r\n SendMessage(GetCapture, WM_CANCELMODE, 0, 0);\r\n { (rb) Need to check ParentFormVisible always before SetFocus? Delphi doesn't.\r\n Not checking whether the parent form is visible typically gives errors\r\n when closing forms with non-focusable buttons (eg speed/toolbuttons) }\r\n if ParentFormVisible(Self) and CanFocus then\r\n SetFocus;\r\n ListValue := FDataList.Value;\r\n SetWindowPos(FDataList.Handle, 0, 0, 0, 0, 0, SWP_NOZORDER or\r\n SWP_NOMOVE or SWP_NOSIZE or SWP_NOACTIVATE or SWP_HIDEWINDOW);\r\n FListVisible := False;\r\n FDataList.LookupSource := nil;\r\n Invalidate;\r\n FSearchText := '';\r\n FDataList.FSearchText := '';\r\n if Accept and CanModify and (Value <> ListValue) then\r\n SelectKeyValue(ListValue);\r\n if Assigned(FOnCloseUp) then\r\n FOnCloseUp(Self);\r\n end;\r\nend;\r\n\r\nprocedure TJvDBLookupCombo.CMHintShow(var Msg: TMessage);\r\nbegin\r\n // don't show if list is visible\r\n Msg.Result := LRESULT(Ord(FListVisible));\r\nend;\r\n\r\nprocedure TJvDBLookupCombo.DoEnter;\r\nbegin\r\n if (Field <> nil) and FDataLink.Active and VarIsEmpty(FLastValue) then\r\n FLastValue := Field.Value;\r\n inherited DoEnter;\r\nend;\r\n\r\nfunction TJvDBLookupCombo.DoMouseWheelDown(Shift: TShiftState; MousePos: TPoint): Boolean;\r\nbegin\r\n Result := inherited DoMouseWheelDown(Shift, MousePos);\r\n if not Result then\r\n begin\r\n if FLookupLink.DataSet = nil then\r\n Exit;\r\n\r\n { Simulate up or down key, see code in KeyDown }\r\n if FListActive then\r\n if ssAlt in Shift then\r\n begin\r\n if FListVisible then\r\n CloseUp(True)\r\n else\r\n DropDown;\r\n Result := True;\r\n end\r\n else\r\n if not FListVisible and not ReadOnly then\r\n begin\r\n if not LocateKey then\r\n FLookupLink.DataSet.First\r\n else\r\n FLookupLink.DataSet.MoveBy(1);\r\n SelectKeyValue(FKeyField.AsString);\r\n Result := True;\r\n end;\r\n if not Result and FListVisible then\r\n Result := FDataList.DoMouseWheelDown(Shift, MousePos);\r\n end;\r\nend;\r\n\r\nfunction TJvDBLookupCombo.DoMouseWheelUp(Shift: TShiftState; MousePos: TPoint): Boolean;\r\nbegin\r\n Result := inherited DoMouseWheelDown(Shift, MousePos);\r\n if not Result then\r\n begin\r\n if FLookupLink.DataSet = nil then\r\n Exit;\r\n\r\n { Simulate up or down key, see code in KeyDown }\r\n if FListActive then\r\n if ssAlt in Shift then\r\n begin\r\n if FListVisible then\r\n CloseUp(True)\r\n else\r\n DropDown;\r\n Result := True;\r\n end\r\n else\r\n if not FListVisible and not ReadOnly then\r\n begin\r\n if not LocateKey then\r\n FLookupLink.DataSet.First\r\n else\r\n FLookupLink.DataSet.MoveBy(-1);\r\n SelectKeyValue(FKeyField.AsString);\r\n Result := True;\r\n end;\r\n if not Result and FListVisible then\r\n Result := FDataList.DoMouseWheelUp(Shift, MousePos);\r\n end;\r\nend;\r\n\r\nprocedure TJvDBLookupCombo.DropDown;\r\nvar\r\n P: TPoint;\r\n I, Y: Integer;\r\n S: string;\r\n SelValue: string;\r\n Animate: BOOL;\r\n SlideStyle: Integer;\r\n RecordCount: Integer;\r\n Monitor: TMonitor;\r\n Rect: TRect;\r\nbegin\r\n if not FListVisible and {FListActive} CanModify then\r\n begin\r\n if Assigned(FOnDropDown) then\r\n FOnDropDown(Self);\r\n SelValue := Value; // backup before anything invokes a OnDataCahange event\r\n FDataList.Color := Color;\r\n FDataList.Font := Font;\r\n FDataList.ItemHeight := ItemHeight;\r\n FDataList.ReadOnly := not CanModify;\r\n FDataList.EmptyValue := EmptyValue;\r\n FDataList.DisplayEmpty := DisplayEmpty;\r\n FDataList.EmptyItemColor := EmptyItemColor;\r\n FDataList.UseRecordCount := UseRecordCount;\r\n if Assigned(FLookupLink.DataSet) and UseRecordCount then\r\n begin\r\n RecordCount := FLookupLink.DataSet.RecordCount;\r\n if EmptyRowVisible then // Mantis 3884\r\n Inc(RecordCount);\r\n end\r\n else\r\n RecordCount := MaxInt;\r\n\r\n if (DropDownCount > RecordCount) then\r\n FDataList.RowCount := RecordCount\r\n else\r\n FDataList.RowCount := DropDownCount;\r\n\r\n FDataList.LookupField := FLookupFieldName;\r\n FDataList.LookupFormat := FLookupFormat;\r\n FDataList.ListStyle := FListStyle;\r\n FDataList.FieldsDelimiter := FFieldsDelimiter;\r\n FDataList.IgnoreCase := FIgnoreCase;\r\n FDataList.IndexSwitch := FIndexSwitch;\r\n FDataList.OnGetImage := OnGetImage;\r\n // polaris if FDisplayField <> nil then FAlignment := FDisplayField.Alignment;\r\n S := '';\r\n for I := 0 to FListFields.Count - 1 do\r\n S := S + TField(FListFields[I]).FieldName + ';';\r\n FDataList.LookupDisplay := S;\r\n FDataList.LookupDisplayIndex := FListFields.IndexOf(FDisplayField);\r\n {FDataList.FLockPosition := True;}\r\n try\r\n FDataList.LookupSource := FLookupLink.DataSource;\r\n finally\r\n {FDataList.FLockPosition := False;}\r\n end;\r\n FDataList.SetValueKey(SelValue);\r\n {FDataList.KeyValueChanged;}\r\n if FDropDownWidth > 0 then\r\n FDataList.Width := FDropDownWidth\r\n else\r\n if FDropDownWidth < 0 then\r\n FDataList.Width := Max(Width, FDataList.GetWindowWidth)\r\n else\r\n FDataList.Width := Width;\r\n\r\n // Adjust if too close to workarea borders\r\n\r\n Monitor := FindMonitor(MonitorFromWindow(Handle, MONITOR_DEFAULTTONEAREST));\r\n Rect := GetWorkAreaRect(Monitor);\r\n\r\n P := Parent.ClientToScreen(Point(Left, Top));\r\n Y := P.Y + Height;\r\n if Y + FDataList.Height > Rect.Bottom then\r\n Y := P.Y - FDataList.Height;\r\n case FDropDownAlign of\r\n daRight:\r\n Dec(P.X, FDataList.Width - Width);\r\n daCenter:\r\n Dec(P.X, (FDataList.Width - Width) div 2);\r\n end;\r\n if P.X + FDataList.Width > Rect.Right then\r\n P.X := Rect.Right - FDataList.Width;\r\n\r\n { Use slide-open effect for combo boxes if wanted.}\r\n SystemParametersInfo(SPI_GETCOMBOBOXANIMATION, 0, @Animate, 0);\r\n if Assigned(AnimateWindowProc) and Animate then\r\n begin\r\n { Can't use SWP_SHOWWINDOW here, because the window is then immediately shown }\r\n SetWindowPos(FDataList.Handle, HWND_TOP, Max(P.X, Rect.Left), Y, 0, 0,\r\n SWP_NOSIZE or SWP_NOACTIVATE {or SWP_SHOWWINDOW});\r\n if Y < P.Y then\r\n SlideStyle := AW_VER_NEGATIVE\r\n else\r\n SlideStyle := AW_VER_POSITIVE;\r\n { 150 is a bit arbitrary (<200 is recommended) }\r\n AnimateWindowProc(FDataList.Handle, 150, SlideStyle or AW_SLIDE);\r\n ShowWindow(FDataList.Handle, SW_SHOWNOACTIVATE);\r\n { Pre XP systems seem to need this }\r\n FDataList.Invalidate;\r\n end\r\n else\r\n SetWindowPos(FDataList.Handle, HWND_TOP, Max(P.X, Rect.Left), Y, 0, 0,\r\n SWP_NOSIZE or SWP_NOACTIVATE or SWP_SHOWWINDOW);\r\n\r\n FListVisible := True;\r\n InvalidateText;\r\n Repaint;\r\n end;\r\nend;\r\n\r\nfunction TJvDBLookupCombo.GetMinHeight: Integer;\r\nbegin\r\n Result := DefaultTextHeight + GetBorderSize + 3;\r\nend;\r\n\r\nprocedure TJvDBLookupCombo.UpdateFieldText;\r\nvar\r\n I: Integer;\r\n S: string;\r\nbegin\r\n if FDisplayValues <> nil then\r\n FDisplayValues.Clear;\r\n if DisplayAllFields then\r\n begin\r\n S := DoFormatLine;\r\n if (ListStyle = lsFixed) and Assigned(FDisplayValues) then\r\n for I := 0 to FListFields.Count - 1 do\r\n //begin\r\n //if S <> '' then\r\n // S := S + FFieldsDelimiter + ' ';\r\n //S := S + TField(FListFields[I]).DisplayText;\r\n // begin\r\n with TField(FListFields[I]) do\r\n FDisplayValues.AddObject(DisplayText,\r\n TObject(MakeLong(DisplayWidth, Ord(Alignment))));\r\n // end;\r\n //end;\r\n if S = '' then\r\n S := FDisplayField.DisplayText;\r\n inherited Text := S;\r\n end\r\n else\r\n inherited Text := FDisplayField.DisplayText;\r\n FAlignment := FDisplayField.Alignment;\r\nend;\r\n\r\nfunction TJvDBLookupCombo.GetDisplayValues(Index: Integer): string;\r\nbegin\r\n if Assigned(FDisplayValues) and (FDisplayValues.Count > Index) then\r\n Result := FDisplayValues[Index]\r\n else\r\n Result := FDisplayValue;\r\nend;\r\n\r\nfunction TJvDBLookupCombo.GetText: string;\r\nbegin\r\n Result := inherited Text;\r\nend;\r\n\r\nprocedure TJvDBLookupCombo.InvalidateText;\r\nvar\r\n R: TRect;\r\nbegin\r\n if BiDiMode = bdRightToLeft then\r\n SetRect(R, FButtonWidth + 1, 1, ClientWidth - 1, ClientHeight - 1)\r\n else\r\n SetRect(R, 1, 1, ClientWidth - FButtonWidth - 1, ClientHeight - 1);\r\n Windows.InvalidateRect(Self.Handle, {$IFNDEF COMPILER12_UP}@{$ENDIF ~COMPILER12_UP}R, False);\r\n UpdateWindow(Self.Handle);\r\nend;\r\n\r\nprocedure TJvDBLookupCombo.KeyDown(var Key: Word; Shift: TShiftState);\r\nvar\r\n Delta: Integer;\r\nbegin\r\n inherited KeyDown(Key, Shift); // Let the user override the behavior\r\n if FListActive and ((Key = VK_UP) or (Key = VK_DOWN)) then\r\n begin\r\n if ssAlt in Shift then\r\n begin\r\n if FListVisible then\r\n CloseUp(True)\r\n else\r\n DropDown;\r\n Key := 0;\r\n end\r\n else\r\n if not FListVisible and not ReadOnly then\r\n begin\r\n if not LocateKey then\r\n FLookupLink.DataSet.First\r\n else\r\n begin\r\n if Key = VK_UP then\r\n Delta := -1\r\n else\r\n Delta := 1;\r\n FLookupLink.DataSet.MoveBy(Delta);\r\n end;\r\n SelectKeyValue(FKeyField.AsString);\r\n Key := 0;\r\n end;\r\n end\r\n else if not FListVisible and (Key = VK_DELETE) and ([ssShift, ssAlt, ssCtrl] * Shift = []) then\r\n begin\r\n if DeleteKeyClear and not ValueIsEmpty(FValue) and CanModify then\r\n begin\r\n ResetField;\r\n if FValue = FEmptyValue then\r\n Key := 0;\r\n end;\r\n end;\r\n\r\n if (Key <> 0) and FListVisible then\r\n FDataList.KeyDown(Key, Shift);\r\nend;\r\n\r\nprocedure TJvDBLookupCombo.KeyPress(var Key: Char);\r\nbegin\r\n inherited KeyPress(Key);\r\n if FListVisible then\r\n begin\r\n if TabSelects and IsDropDown and (Key = Tab) then\r\n Key := Cr;\r\n\r\n if CharInSet(Key, [Cr, Esc]) then\r\n begin\r\n CloseUp(Key = Cr);\r\n Key := #0;\r\n end\r\n else\r\n FDataList.KeyPress(Key)\r\n end\r\n else\r\n begin\r\n if CharInSet(Key, [#32..#255]) then\r\n begin\r\n DropDown;\r\n if FListVisible then\r\n FDataList.KeyPress(Key);\r\n end\r\n else\r\n if (Key = Esc) and FEscapeKeyReset then\r\n begin\r\n if (Field <> nil) and FDataLink.Active and CanModify and\r\n not VarIsEmpty(FLastValue) and (Field.Value <> FLastValue) and FDataLink.Edit then\r\n begin\r\n Field.Value := FLastValue;\r\n Key := #0;\r\n end;\r\n end;\r\n end;\r\n if CharInSet(Key, [Cr, Esc]) then\r\n GetParentForm(Self).Perform(CM_DIALOGKEY, Byte(Key), 0);\r\nend;\r\n\r\nprocedure TJvDBLookupCombo.DisplayValueChanged;\r\nbegin\r\n if FListActive and LocateDisplay then\r\n begin\r\n FValue := FKeyField.AsString;\r\n UpdateFieldText;\r\n end\r\n else\r\n begin\r\n FValue := FEmptyValue;\r\n inherited Text := DisplayEmpty;\r\n if FDisplayValues <> nil then\r\n FDisplayValues.Clear;\r\n FAlignment := taLeftJustify;\r\n end;\r\n UpdateDisplayValue;\r\n UpdateCurrentImage;\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvDBLookupCombo.KeyValueChanged;\r\nbegin\r\n if FLookupMode then\r\n begin\r\n if FDisplayValues <> nil then\r\n FDisplayValues.Clear;\r\n if FDataLink.Active and (FDataField <> nil) then {begin\r\n inherited Text := FDataField.DisplayText;\r\n FAlignment := FDataField.Alignment;\r\n end}\r\n if ValueIsEmpty(FValue) then\r\n begin\r\n inherited Text := DisplayEmpty;\r\n FAlignment := taLeftJustify;\r\n end\r\n else\r\n begin\r\n inherited Text := FDataField.DisplayText;\r\n FAlignment := FDataField.Alignment;\r\n end\r\n else\r\n inherited Text := '';\r\n end\r\n else\r\n if FListActive and LocateKey then\r\n UpdateFieldText\r\n else\r\n if FListActive then\r\n begin\r\n FValue := FEmptyValue;\r\n inherited Text := DisplayEmpty;\r\n if FDisplayValues <> nil then\r\n FDisplayValues.Clear;\r\n FAlignment := taLeftJustify;\r\n end\r\n else\r\n begin\r\n if csDesigning in ComponentState then\r\n inherited Text := DisplayEmpty\r\n else\r\n inherited Text := '';\r\n if FDisplayValues <> nil then\r\n FDisplayValues.Clear;\r\n end;\r\n UpdateDisplayValue;\r\n UpdateCurrentImage;\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvDBLookupCombo.SetFieldsDelimiter(Value: Char);\r\nbegin\r\n if FFieldsDelimiter <> Value then\r\n begin\r\n inherited SetFieldsDelimiter(Value);\r\n if (ListStyle = lsDelimited) and DisplayAllFields and\r\n not (csReading in ComponentState) then\r\n KeyValueChanged;\r\n end;\r\nend;\r\n\r\nprocedure TJvDBLookupCombo.SetListStyle(Value: TLookupListStyle);\r\nbegin\r\n if FListStyle <> Value then\r\n begin\r\n FListStyle := Value;\r\n if DisplayAllFields and not (csReading in ComponentState) then\r\n KeyValueChanged;\r\n end;\r\nend;\r\n\r\nfunction TJvDBLookupCombo.GetDisplayAllFields: Boolean;\r\nbegin\r\n if FLookupMode then\r\n Result := False\r\n else\r\n Result := FDisplayAllFields;\r\nend;\r\n\r\nprocedure TJvDBLookupCombo.SetDisplayAllFields(Value: Boolean);\r\nbegin\r\n if FDisplayAllFields <> Value then\r\n begin\r\n if FLookupMode then\r\n FDisplayAllFields := False\r\n else\r\n FDisplayAllFields := Value;\r\n if not (csReading in ComponentState) and not FLookupMode then\r\n KeyValueChanged\r\n else\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvDBLookupCombo.ListLinkDataChanged;\r\nbegin\r\n if FDataLink.Active and FDataLink.DataSet.IsLinkedTo(LookupSource) then\r\n if FListActive then\r\n DataLinkRecordChanged(nil);\r\nend;\r\n\r\nprocedure TJvDBLookupCombo.ListLinkDataSetChanged;\r\nbegin\r\n inherited ListLinkDataSetChanged;\r\n if not FInListDataSetChanged and not FListVisible and\r\n (FLookupSource <> nil) and (FLookupSource.DataSet <> nil) and (FLookupSource.DataSet.State = dsBrowse) then\r\n begin\r\n FInListDataSetChanged := True;\r\n try\r\n if FListActive and Assigned(FMasterField) then\r\n UpdateKeyValue\r\n else\r\n KeyValueChanged;\r\n finally\r\n FInListDataSetChanged := False;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvDBLookupCombo.ListLinkActiveChanged;\r\nbegin\r\n inherited ListLinkActiveChanged;\r\n if FListActive and Assigned(FMasterField) then\r\n UpdateKeyValue\r\n else\r\n KeyValueChanged;\r\nend;\r\n\r\nprocedure TJvDBLookupCombo.ListMouseUp(Sender: TObject; Button: TMouseButton;\r\n Shift: TShiftState; X, Y: Integer);\r\nbegin\r\n if Button = mbLeft then\r\n CloseUp(PtInRect(FDataList.ClientRect, Point(X, Y)));\r\nend;\r\n\r\nprocedure TJvDBLookupCombo.MouseDown(Button: TMouseButton; Shift: TShiftState;\r\n X, Y: Integer);\r\nbegin\r\n if Button = mbLeft then\r\n begin\r\n if CanFocus then\r\n SetFocus;\r\n if not FFocused then\r\n Exit;\r\n if FListVisible then\r\n CloseUp(False)\r\n else\r\n if {FListActive} CanModify then\r\n begin\r\n MouseCapture := True;\r\n FTracking := True;\r\n TrackButton(X, Y);\r\n DropDown;\r\n end;\r\n end;\r\n inherited MouseDown(Button, Shift, X, Y);\r\nend;\r\n\r\nprocedure TJvDBLookupCombo.MouseMove(Shift: TShiftState; X, Y: Integer);\r\nvar\r\n ListPos: TPoint;\r\n MousePos: TSmallPoint;\r\nbegin\r\n if FTracking then\r\n begin\r\n TrackButton(X, Y);\r\n if FListVisible then\r\n begin\r\n ListPos := FDataList.ScreenToClient(ClientToScreen(Point(X, Y)));\r\n if PtInRect(FDataList.ClientRect, ListPos) then\r\n begin\r\n StopTracking;\r\n MousePos := PointToSmallPoint(ListPos);\r\n SendMessage(FDataList.Handle, WM_LBUTTONDOWN, 0, {$IFDEF RTL230_UP}PointToLParam{$ELSE}LPARAM{$ENDIF RTL230_UP}(MousePos));\r\n Exit;\r\n end;\r\n end;\r\n end;\r\n inherited MouseMove(Shift, X, Y);\r\nend;\r\n\r\nprocedure TJvDBLookupCombo.MouseUp(Button: TMouseButton; Shift: TShiftState;\r\n X, Y: Integer);\r\nbegin\r\n StopTracking;\r\n inherited MouseUp(Button, Shift, X, Y);\r\nend;\r\n\r\nprocedure TJvDBLookupCombo.UpdateCurrentImage;\r\nbegin\r\n FSelImage.Assign(nil);\r\n FSelMargin := 0;\r\n FSelImage.Graphic := inherited GetPicture(False, ValueIsEmpty(Value),\r\n FSelMargin);\r\nend;\r\n\r\nfunction TJvDBLookupCombo.GetPicture(Current, Empty: Boolean;\r\n var TextMargin: Integer): TGraphic;\r\nbegin\r\n if Current then\r\n begin\r\n TextMargin := 0;\r\n Result := nil;\r\n if (FSelImage <> nil) and (FSelImage.Graphic <> nil) and\r\n not FSelImage.Graphic.Empty then\r\n begin\r\n Result := FSelImage.Graphic;\r\n TextMargin := FSelMargin;\r\n end;\r\n end\r\n else\r\n Result := inherited GetPicture(Current, Empty, TextMargin);\r\nend;\r\n\r\nprocedure TJvDBLookupCombo.PaintDisplayValues(Canvas: TCanvas; R: TRect;\r\n ALeft: Integer);\r\nvar\r\n I, LastIndex, TxtWidth: Integer;\r\n X, W, ATop, ARight: Integer;\r\n S: string;\r\nbegin\r\n if ColorToRGB(Self.Color) <> ColorToRGB(clBtnFace) then\r\n Canvas.Pen.Color := clBtnFace\r\n else\r\n Canvas.Pen.Color := clBtnShadow;\r\n LastIndex := FDisplayValues.Count - 1;\r\n TxtWidth := Canvas.TextWidth('M');\r\n ATop := Max(0, (RectHeight(R) - CanvasMaxTextHeight(Canvas)) div 2);\r\n ARight := R.Right;\r\n Inc(R.Left, ALeft);\r\n for I := 0 to LastIndex do\r\n begin\r\n S := FDisplayValues[I];\r\n W := LoWord(Longint(FDisplayValues.Objects[I]));\r\n if I < LastIndex then\r\n W := W * TxtWidth + 4\r\n else\r\n W := ARight - R.Left;\r\n X := 2;\r\n R.Right := R.Left + W;\r\n case TAlignment(HiWord(Longint(FDisplayValues.Objects[I]))) of\r\n taRightJustify:\r\n X := W - Canvas.TextWidth(S) - 3;\r\n taCenter:\r\n X := (W - Canvas.TextWidth(S)) div 2;\r\n end;\r\n Canvas.TextRect(R, R.Left + Max(0, X), ATop, S);\r\n Inc(R.Left, W);\r\n if I < LastIndex then\r\n begin\r\n Canvas.MoveTo(R.Right, R.Top);\r\n Canvas.LineTo(R.Right, R.Bottom);\r\n Inc(R.Left);\r\n end;\r\n if R.Left >= ARight then\r\n Break;\r\n end;\r\nend;\r\n\r\nprocedure TJvDBLookupCombo.WMEraseBkgnd(var Message: TWMEraseBkgnd);\r\nvar\r\n IsClipped: Boolean;\r\n SaveRgn: HRGN;\r\nbegin\r\n IsClipped := False;\r\n SaveRgn := 0;\r\n if not DoubleBuffered and\r\n (TMessage(Message).WParam <> WPARAM(TMessage(Message).LParam)) and\r\n { Do not exclude parts if we are painting into a memory device context or\r\n into a child's device context through DrawParentBackground(). }\r\n (WindowFromDC(Message.DC) = Handle) then\r\n begin\r\n SaveRgn := CreateRectRgn(0, 0, 1, 1);\r\n IsClipped := GetClipRgn(Message.DC, SaveRgn) = 1;\r\n { Exclude the edit rectangle and the drop down button. }\r\n ExcludeClipRect(Message.DC, 1, 1, ClientWidth - FButtonWidth - 1, ClientHeight - 1);\r\n ExcludeClipRect(Message.DC, ClientWidth - FButtonWidth, 0, ClientWidth, ClientHeight);\r\n end;\r\n inherited;\r\n\r\n { Restore the backuped clipping region }\r\n if SaveRgn <> 0 then\r\n begin\r\n if IsClipped then\r\n SelectClipRgn(Message.DC, SaveRgn)\r\n else\r\n SelectClipRgn(Message.DC, 0);\r\n DeleteObject(SaveRgn);\r\n end;\r\nend;\r\n\r\nprocedure TJvDBLookupCombo.Paint;\r\nconst\r\n TransColor: array [Boolean] of TColor = (clBtnFace, clWhite);\r\nvar\r\n W, X, Flags, TextMargin: Integer;\r\n AText: string;\r\n Selected, DrawList, IsEmpty: Boolean;\r\n R, ImageRect: TRect;\r\n Image: TGraphic;\r\n Bmp: TBitmap;\r\n Alignment: TAlignment;\r\n {$IFDEF JVCLThemesEnabled}\r\n State: TThemedComboBox;\r\n Details: TThemedElementDetails;\r\n {$ENDIF JVCLThemesEnabled}\r\nbegin\r\n if csDestroying in ComponentState then\r\n Exit;\r\n Canvas.Font := Font;\r\n Canvas.Brush.Color := Color;\r\n Selected := FFocused and not FListVisible and not (csPaintCopy in ControlState);\r\n if Selected then\r\n begin\r\n Canvas.Font.Color := clHighlightText;\r\n Canvas.Brush.Color := clHighlight;\r\n end\r\n else\r\n if not Enabled then\r\n Canvas.Font.Color := clGrayText;\r\n AText := inherited Text;\r\n Alignment := FAlignment;\r\n Image := nil;\r\n IsEmpty := False;\r\n DrawList := DisplayAllFields;\r\n if (csPaintCopy in ControlState) and (FDataField <> nil) then\r\n begin\r\n DrawList := False;\r\n AText := FDataField.DisplayText;\r\n Alignment := FDataField.Alignment;\r\n end;\r\n TextMargin := 0;\r\n if FListVisible then\r\n begin\r\n DrawList := False;\r\n if FDataList.FSearchText <> '' then\r\n AText := FDataList.FSearchText\r\n else\r\n begin\r\n if FDataList.ValueIsEmpty(FDataList.Value) then\r\n begin\r\n AText := DisplayEmpty;\r\n IsEmpty := True;\r\n Image := GetPicture(False, True, TextMargin);\r\n end\r\n else\r\n if FDataList.FKeyField.AsString = FDataList.Value then\r\n begin\r\n AText := FDataList.FDisplayField.DisplayText;\r\n Image := FDataList.GetPicture(False, False, TextMargin);\r\n end\r\n else\r\n Image := GetPicture(True, False, TextMargin);\r\n end;\r\n end\r\n else\r\n begin\r\n if csPaintCopy in ControlState then\r\n Image := nil\r\n else\r\n begin\r\n IsEmpty := ValueIsEmpty(Value);\r\n Image := GetPicture(True, IsEmpty, TextMargin);\r\n end;\r\n end;\r\n if UseRightToLeftAlignment then\r\n ChangeBiDiModeAlignment(Alignment);\r\n W := ClientWidth - FButtonWidth;\r\n if W > 4 then\r\n begin\r\n SetRect(R, 1, 1, W - 1, ClientHeight - 1);\r\n if TextMargin > 0 then\r\n Inc(TextMargin);\r\n X := 4 + TextMargin;\r\n if not (FListVisible and (FDataList.FSearchText <> '')) and not DrawList then\r\n case Alignment of\r\n taRightJustify:\r\n X := W - Canvas.TextWidth(AText) - 6;\r\n taCenter:\r\n X := (W + TextMargin - Canvas.TextWidth(AText)) div 2;\r\n end;\r\n Bmp := TBitmap.Create;\r\n try\r\n with Bmp.Canvas do\r\n begin\r\n Font := Self.Canvas.Font;\r\n Brush := Self.Canvas.Brush;\r\n Pen := Self.Canvas.Pen;\r\n end;\r\n if BiDiMode = bdRightToLeft then\r\n begin\r\n Dec(X, TextMargin);\r\n Inc(R.Left, FButtonWidth);\r\n R.Right := ClientWidth;\r\n end;\r\n if SysLocale.MiddleEast then\r\n begin\r\n TControlCanvas(Self.Canvas).UpdateTextFlags;\r\n Bmp.Canvas.TextFlags := Self.Canvas.TextFlags;\r\n end;\r\n Bmp.Width := RectWidth(R);\r\n Bmp.Height := RectHeight(R);\r\n ImageRect := Rect(0, 0, RectWidth(R), RectHeight(R));\r\n if DrawList and (ListStyle = lsFixed) and (FDisplayValues <> nil) and\r\n (FDisplayValues.Count > 0) then\r\n begin\r\n if IsEmpty then\r\n begin\r\n AText := DisplayEmpty;\r\n Bmp.Canvas.TextRect(ImageRect, X, Max(0, (RectHeight(R) -\r\n Canvas.TextHeight(AText)) div 2), AText);\r\n end\r\n else\r\n PaintDisplayValues(Bmp.Canvas, ImageRect, TextMargin);\r\n end\r\n else\r\n begin\r\n Bmp.Canvas.TextRect(ImageRect, X, Max(0, (RectHeight(R) -\r\n Canvas.TextHeight(AText)) div 2), AText);\r\n end;\r\n if Image <> nil then\r\n begin\r\n if BidiMode = bdRightToLeft then\r\n ImageRect.Left := ImageRect.Right - (TextMargin + 2)\r\n else\r\n ImageRect.Right := ImageRect.Left + TextMargin + 2;\r\n DrawPicture(Bmp.Canvas, ImageRect, Image);\r\n end;\r\n Canvas.Draw(R.Left, R.Top, Bmp);\r\n finally\r\n Bmp.Free;\r\n end;\r\n if Selected then\r\n Canvas.DrawFocusRect(R);\r\n end;\r\n SetRect(R, W, 0, ClientWidth, ClientHeight);\r\n if BiDiMode = bdRightToLeft then\r\n begin\r\n R.Left := 0;\r\n R.Right := FButtonWidth;\r\n end;\r\n {$IFDEF JVCLThemesEnabled}\r\n if ThemeServices.{$IFDEF RTL230_UP}Enabled{$ELSE}ThemesEnabled{$ENDIF RTL230_UP} then\r\n begin\r\n if not FListActive or not Enabled or ReadOnly then\r\n State := tcDropDownButtonDisabled\r\n else\r\n if FPressed then\r\n State := tcDropDownButtonPressed\r\n else\r\n if MouseOver and not FListVisible then\r\n State := tcDropDownButtonHot\r\n else\r\n State := tcDropDownButtonNormal;\r\n Details := ThemeServices.GetElementDetails(State);\r\n ThemeServices.DrawElement(Canvas.Handle, Details, R);\r\n end\r\n else\r\n {$ENDIF JVCLThemesEnabled}\r\n begin\r\n if not FListActive or not Enabled or ReadOnly then\r\n Flags := DFCS_SCROLLCOMBOBOX or DFCS_INACTIVE\r\n else\r\n if FPressed then\r\n Flags := DFCS_SCROLLCOMBOBOX or DFCS_FLAT or DFCS_PUSHED\r\n else\r\n Flags := DFCS_SCROLLCOMBOBOX;\r\n DrawFrameControl(Canvas.Handle, R, DFC_SCROLL, Flags);\r\n end;\r\nend;\r\n\r\nprocedure TJvDBLookupCombo.ResetField;\r\nbegin\r\n if FListVisible then\r\n CloseUp(False);\r\n inherited ResetField;\r\n UpdateCurrentImage;\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvDBLookupCombo.StopTracking;\r\nbegin\r\n if FTracking then\r\n begin\r\n TrackButton(-1, -1);\r\n FTracking := False;\r\n MouseCapture := False;\r\n end;\r\nend;\r\n\r\nprocedure TJvDBLookupCombo.TrackButton(X, Y: Integer);\r\nvar\r\n NewState: Boolean;\r\nbegin\r\n NewState := PtInRect(Rect(ClientWidth - FButtonWidth, 0, ClientWidth,\r\n ClientHeight), Point(X, Y));\r\n if FPressed <> NewState then\r\n begin\r\n FPressed := NewState;\r\n Repaint;\r\n end;\r\nend;\r\n\r\nprocedure TJvDBLookupCombo.UpdateDisplayEmpty(const Value: string);\r\nbegin\r\n if Text = FDisplayEmpty then\r\n inherited Text := Value;\r\nend;\r\n\r\nprocedure TJvDBLookupCombo.Click;\r\nbegin\r\n inherited Click;\r\n Change;\r\nend;\r\n\r\nprocedure TJvDBLookupCombo.CMCancelMode(var Msg: TCMCancelMode);\r\nbegin\r\n if (Msg.Sender <> Self) and (Msg.Sender <> FDataList) then\r\n CloseUp(False);\r\nend;\r\n\r\nprocedure TJvDBLookupCombo.CMCtl3DChanged(var Msg: TMessage);\r\nbegin\r\n RecreateWnd;\r\n if not (csReading in ComponentState) and (Height < GetMinHeight) then\r\n Height := GetMinHeight;\r\n inherited;\r\nend;\r\n\r\nprocedure TJvDBLookupCombo.CNKeyDown(var Msg: TWMKeyDown);\r\nbegin\r\n if not (csDesigning in ComponentState) then\r\n begin\r\n if TabSelects and IsDropDown and (Msg.Charcode = VK_TAB) then\r\n Msg.Charcode := VK_RETURN;\r\n\r\n if (Msg.CharCode in [VK_RETURN, VK_ESCAPE]) and FListVisible and\r\n FLookupMode and FDataLink.DataSourceFixed then\r\n begin\r\n CloseUp(Msg.CharCode = VK_RETURN);\r\n Msg.Result := 1;\r\n Exit;\r\n end;\r\n end;\r\n inherited;\r\nend;\r\n\r\nprocedure TJvDBLookupCombo.FontChanged;\r\nbegin\r\n inherited FontChanged;\r\n if not (csReading in ComponentState) then\r\n Height := Max(Height, GetMinHeight);\r\nend;\r\n\r\n{$IFDEF JVCLThemesEnabled}\r\n\r\nprocedure TJvDBLookupCombo.MouseEnter(Control: TControl);\r\nbegin\r\n if csDesigning in ComponentState then\r\n Exit;\r\n {Windows XP themes use hot track states, hence we have to update the drop down button.}\r\n if ThemeServices.{$IFDEF RTL230_UP}Enabled{$ELSE}ThemesEnabled{$ENDIF RTL230_UP} and not MouseOver then\r\n begin\r\n inherited MouseEnter(Control);\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvDBLookupCombo.MouseLeave(Control: TControl);\r\nbegin\r\n if MouseOver then\r\n begin\r\n inherited MouseLeave(Control);\r\n Invalidate;\r\n end;\r\nend;\r\n\r\n{$ENDIF JVCLThemesEnabled}\r\n\r\nprocedure TJvDBLookupCombo.EnabledChanged;\r\nbegin\r\n inherited EnabledChanged;\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvDBLookupCombo.CMGetDataLink(var Msg: TMessage);\r\nbegin\r\n Msg.Result := LRESULT(FDataLink);\r\nend;\r\n\r\nfunction TJvDBLookupCombo.GetDataLink: TDataLink;\r\nbegin\r\n Result := FDataLink;\r\nend;\r\n\r\nprocedure TJvDBLookupCombo.WMCancelMode(var Msg: TMessage);\r\nbegin\r\n StopTracking;\r\n inherited;\r\nend;\r\n\r\nprocedure TJvDBLookupCombo.GetDlgCode(var Code: TDlgCodes);\r\nbegin\r\n Code := [dcButton, dcWantAllKeys, dcWantArrows, dcWantChars];\r\nend;\r\n\r\nprocedure TJvDBLookupCombo.FocusKilled(NextWnd: THandle);\r\nbegin\r\n inherited FocusKilled(NextWnd);\r\n CloseUp(False);\r\nend;\r\n\r\nprocedure TJvDBLookupCombo.WMSetCursor(var Msg: TWMSetCursor);\r\nvar\r\n Pt: TPoint;\r\n R: TRect;\r\nbegin\r\n GetCursorPos(Pt);\r\n R := ClientRect;\r\n if PtInRect(Bounds(R.Right - FButtonWidth, R.Top, FButtonWidth, R.Bottom - R.Top), ScreenToClient(Pt)) then\r\n Windows.SetCursor(LoadCursor(0, IDC_ARROW))\r\n else\r\n inherited;\r\nend;\r\n\r\nprocedure TJvDBLookupCombo.BoundsChanged;\r\nbegin\r\n inherited BoundsChanged;\r\n if not (csReading in ComponentState) and (Height < GetMinHeight) then\r\n Height := GetMinHeight\r\n else\r\n begin\r\n if csDesigning in ComponentState then\r\n FDataList.SetBounds(0, Height + 1, 10, 10);\r\n end;\r\nend;\r\n\r\nprocedure TJvDBLookupCombo.CMBiDiModeChanged(var Msg: TMessage);\r\nbegin\r\n inherited;\r\n FDataList.BiDiMode := BiDiMode;\r\nend;\r\n\r\n//=== { TJvPopupDataWindow } =================================================\r\n\r\nconstructor TJvPopupDataWindow.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FEditor := TWinControl(AOwner);\r\n Visible := False;\r\n Parent := FEditor;\r\n OnMouseUp := PopupMouseUp;\r\nend;\r\n\r\nprocedure TJvPopupDataWindow.InvalidateEditor;\r\nvar\r\n R: TRect;\r\nbegin\r\n if FEditor is TJvCustomComboEdit then\r\n with TJvComboEdit(FEditor) do\r\n SetRect(R, 0, 0, ClientWidth - Button.Width - 2, ClientHeight + 1)\r\n else\r\n R := FEditor.ClientRect;\r\n Windows.InvalidateRect(FEditor.Handle, {$IFNDEF COMPILER12_UP}@{$ENDIF ~COMPILER12_UP}R, False);\r\n UpdateWindow(FEditor.Handle);\r\nend;\r\n\r\nprocedure TJvPopupDataWindow.Click;\r\nbegin\r\n inherited Click;\r\n if Value <> '' then\r\n with TJvDBLookupEdit(FEditor) do\r\n if not (FChanging or ReadOnly) then\r\n begin\r\n FChanging := True;\r\n try\r\n Text := Self.DisplayValue;\r\n if AutoSelect then\r\n SelectAll;\r\n finally\r\n FChanging := False;\r\n end;\r\n end;\r\n InvalidateEditor;\r\nend;\r\n\r\nprocedure TJvPopupDataWindow.DisplayValueChanged;\r\nbegin\r\n if not FLockPosition then\r\n if FListActive then\r\n begin\r\n if LocateDisplay then\r\n FValue := FKeyField.AsString\r\n else\r\n begin\r\n FLookupLink.DataSet.First;\r\n FValue := EmptyValue;\r\n end;\r\n end\r\n else\r\n FValue := FEmptyValue;\r\nend;\r\n\r\nprocedure TJvPopupDataWindow.KeyPress(var Key: Char);\r\nbegin\r\n inherited KeyPress(Key);\r\n InvalidateEditor;\r\nend;\r\n\r\nprocedure TJvPopupDataWindow.PopupMouseUp(Sender: TObject; Button: TMouseButton;\r\n Shift: TShiftState; X, Y: Integer);\r\nbegin\r\n if Button = mbLeft then\r\n CloseUp(PtInRect(Self.ClientRect, Point(X, Y)));\r\nend;\r\n\r\nprocedure TJvPopupDataWindow.CloseUp(Accept: Boolean);\r\nbegin\r\n if Assigned(FCloseUp) then\r\n FCloseUp(Self, Accept);\r\nend;\r\n\r\nfunction TJvPopupDataWindow.GetPicture(Current, Empty: Boolean;\r\n var TextMargin: Integer): TGraphic;\r\nbegin\r\n TextMargin := 0;\r\n Result := nil;\r\n if Assigned(FOnGetImage) then\r\n FOnGetImage(FEditor, Empty, Result, TextMargin);\r\nend;\r\n\r\nprocedure TJvPopupDataWindow.Hide;\r\nbegin\r\n SetWindowPos(Handle, 0, 0, 0, 0, 0, SWP_NOZORDER or\r\n SWP_NOMOVE or SWP_NOSIZE or SWP_NOACTIVATE or SWP_HIDEWINDOW);\r\n Visible := False;\r\nend;\r\n\r\nprocedure TJvPopupDataWindow.Show(Origin: TPoint);\r\nbegin\r\n SetWindowPos(Handle, HWND_TOP, Origin.X, Origin.Y, 0, 0,\r\n SWP_NOACTIVATE or SWP_SHOWWINDOW or SWP_NOSIZE);\r\n Visible := True;\r\nend;\r\n\r\n//=== { TJvDBLookupEdit } ====================================================\r\n\r\nconstructor TJvDBLookupEdit.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FDropDownCount := 8;\r\n FPopupOnlyLocate := True;\r\n ControlState := ControlState + [csCreating];\r\n try\r\n FPopup := TJvPopupDataWindow.Create(Self);\r\n TJvPopupDataWindow(FPopup).OnCloseUp := PopupCloseUp;\r\n GlyphKind := gkDropDown; { force update }\r\n finally\r\n ControlState := ControlState - [csCreating];\r\n end;\r\nend;\r\n\r\ndestructor TJvDBLookupEdit.Destroy;\r\nbegin\r\n if FPopup <> nil then\r\n with TJvPopupDataWindow(FPopup) do\r\n begin\r\n OnCloseUp := nil;\r\n OnGetImage := nil;\r\n end;\r\n FPopup.Free;\r\n FPopup := nil;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvDBLookupEdit.SetDropDownCount(Value: Integer);\r\nbegin\r\n if Value < 1 then\r\n Value := 1;\r\n if Value > 50 then\r\n Value := 50;\r\n FDropDownCount := Value;\r\nend;\r\n\r\nfunction TJvDBLookupEdit.GetListStyle: TLookupListStyle;\r\nbegin\r\n Result := TJvPopupDataWindow(FPopup).ListStyle;\r\nend;\r\n\r\nprocedure TJvDBLookupEdit.SetListStyle(Value: TLookupListStyle);\r\nbegin\r\n TJvPopupDataWindow(FPopup).ListStyle := Value;\r\nend;\r\n\r\nfunction TJvDBLookupEdit.GetFieldsDelimiter: Char;\r\nbegin\r\n Result := TJvPopupDataWindow(FPopup).FieldsDelimiter;\r\nend;\r\n\r\nprocedure TJvDBLookupEdit.SetFieldsDelimiter(Value: Char);\r\nbegin\r\n TJvPopupDataWindow(FPopup).FieldsDelimiter := Value;\r\nend;\r\n\r\nfunction TJvDBLookupEdit.GetLookupDisplay: string;\r\nbegin\r\n Result := TJvPopupDataWindow(FPopup).LookupDisplay;\r\nend;\r\n\r\nprocedure TJvDBLookupEdit.SetLookupDisplay(const Value: string);\r\nbegin\r\n TJvPopupDataWindow(FPopup).LookupDisplay := Value;\r\nend;\r\n\r\nfunction TJvDBLookupEdit.GetDisplayIndex: Integer;\r\nbegin\r\n Result := TJvPopupDataWindow(FPopup).LookupDisplayIndex;\r\nend;\r\n\r\nprocedure TJvDBLookupEdit.SetDisplayIndex(Value: Integer);\r\nbegin\r\n TJvPopupDataWindow(FPopup).LookupDisplayIndex := Value;\r\nend;\r\n\r\nfunction TJvDBLookupEdit.GetLookupField: string;\r\nbegin\r\n Result := TJvPopupDataWindow(FPopup).LookupField;\r\nend;\r\n\r\nprocedure TJvDBLookupEdit.SetLookupField(const Value: string);\r\nbegin\r\n TJvPopupDataWindow(FPopup).LookupField := Value;\r\nend;\r\n\r\nfunction TJvDBLookupEdit.GetLookupSource: TDataSource;\r\nbegin\r\n Result := TJvPopupDataWindow(FPopup).LookupSource;\r\nend;\r\n\r\nprocedure TJvDBLookupEdit.SetLookupSource(Value: TDataSource);\r\nbegin\r\n TJvPopupDataWindow(FPopup).LookupSource := Value;\r\nend;\r\n\r\nfunction TJvDBLookupEdit.GetOnGetImage: TGetImageEvent;\r\nbegin\r\n Result := TJvPopupDataWindow(FPopup).OnGetImage;\r\nend;\r\n\r\nprocedure TJvDBLookupEdit.SetOnGetImage(Value: TGetImageEvent);\r\nbegin\r\n TJvPopupDataWindow(FPopup).OnGetImage := Value;\r\nend;\r\n\r\nfunction TJvDBLookupEdit.GetLookupValue: string;\r\nbegin\r\n TJvPopupDataWindow(FPopup).DisplayValue := Text;\r\n Result := TJvPopupDataWindow(FPopup).Value;\r\nend;\r\n\r\nprocedure TJvDBLookupEdit.SetLookupValue(const Value: string);\r\nbegin\r\n TJvPopupDataWindow(FPopup).Value := Value;\r\n\r\n if Value = EmptyStr then\r\n Text := EmptyStr\r\n else\r\n Text := TJvPopupDataWindow(FPopup).DisplayValue;\r\nend;\r\n\r\nprocedure TJvDBLookupEdit.ShowPopup(Origin: TPoint);\r\nbegin\r\n TJvPopupDataWindow(FPopup).Show(Origin);\r\nend;\r\n\r\nprocedure TJvDBLookupEdit.HidePopup;\r\nbegin\r\n TJvPopupDataWindow(FPopup).Hide;\r\nend;\r\n\r\nprocedure TJvDBLookupEdit.PopupDropDown(DisableEdit: Boolean);\r\nbegin\r\n if not (ReadOnly or PopupVisible) then\r\n begin\r\n if Assigned(FOnDropDown) then\r\n FOnDropDown(Self);\r\n with TJvPopupDataWindow(FPopup) do\r\n begin\r\n Color := Self.Color;\r\n Font := Self.Font;\r\n if FDropDownWidth > 0 then\r\n Width := FDropDownWidth\r\n else\r\n if FDropDownWidth < 0 then\r\n Width := Max(Self.Width, GetWindowWidth)\r\n else\r\n Width := Self.Width;\r\n ReadOnly := Self.ReadOnly;\r\n RowCount := FDropDownCount;\r\n end;\r\n end;\r\n FBeforePopupValue := GetPopupValue;\r\n inherited PopupDropDown(False);\r\nend;\r\n\r\nprocedure TJvDBLookupEdit.KeyDown(var Key: Word; Shift: TShiftState);\r\nbegin\r\n if (Key in [VK_PRIOR, VK_NEXT, VK_UP, VK_DOWN]) and PopupVisible then\r\n begin\r\n TJvPopupDataWindow(FPopup).KeyDown(Key, Shift);\r\n Key := 0;\r\n end;\r\n inherited KeyDown(Key, Shift);\r\n FIgnoreChange := (SelLength > 0) or (Key = VK_BACK);\r\n if not (PopupVisible or ReadOnly) and (Key in [VK_UP, VK_DOWN]) and\r\n (Shift = []) then\r\n begin\r\n with TJvPopupDataWindow(FPopup) do\r\n begin\r\n KeyDown(Key, Shift);\r\n if Value <> EmptyValue then\r\n Key := 0;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvDBLookupEdit.KeyPress(var Key: Char);\r\nbegin\r\n inherited KeyPress(Key);\r\n FIgnoreChange := (SelLength > 0) or (Key = Backspace);\r\nend;\r\n\r\nprocedure TJvDBLookupEdit.Change;\r\nbegin\r\n if PopupOnlyLocate or PopupVisible then\r\n inherited Change\r\n else\r\n begin\r\n PopupChange;\r\n DoChange;\r\n end;\r\nend;\r\n\r\nprocedure TJvDBLookupEdit.PopupChange;\r\nvar\r\n S: string;\r\n Len: Integer;\r\nbegin\r\n if FChanging or FIgnoreChange or ReadOnly then\r\n begin\r\n FIgnoreChange := False;\r\n Exit;\r\n end;\r\n FChanging := True;\r\n try\r\n S := Text;\r\n if TJvPopupDataWindow(FPopup).SearchText(S) then\r\n begin\r\n Len := Length(Text);\r\n Text := TJvPopupDataWindow(FPopup).DisplayValue;\r\n SelStart := Len;\r\n SelLength := Length(Text) - Len;\r\n end\r\n else\r\n with TJvPopupDataWindow(FPopup) do\r\n Value := EmptyValue;\r\n finally\r\n FChanging := False;\r\n end;\r\nend;\r\n\r\nprocedure TJvDBLookupEdit.SetPopupValue(const Value: Variant);\r\nbegin\r\n if VarIsNullEmpty(Value) then\r\n TJvPopupDataWindow(FPopup).Value := TJvPopupDataWindow(FPopup).EmptyValue\r\n else\r\n TJvPopupDataWindow(FPopup).DisplayValue := Value;\r\n FBeforePopupValue := GetPopupValue;\r\nend;\r\n\r\nfunction TJvDBLookupEdit.GetPopupValue: Variant;\r\nbegin\r\n with TJvPopupDataWindow(FPopup) do\r\n if Value <> EmptyValue then\r\n Result := DisplayValue\r\n else\r\n Result := Self.Text;\r\nend;\r\n\r\nfunction TJvDBLookupEdit.AcceptPopup(var Value: Variant): Boolean;\r\nbegin\r\n Result := Value <> FBeforePopupValue;\r\n if Assigned(FOnCloseUp) then\r\n FOnCloseUp(Self);\r\nend;\r\n\r\nfunction TJvDBLookupEdit.GetUseRecordCount: Boolean;\r\nbegin\r\n Result := TJvPopupDataWindow(FPopup).UseRecordCount;\r\nend;\r\n\r\nprocedure TJvDBLookupEdit.SetUseRecordCount(const Value: Boolean);\r\nbegin\r\n TJvPopupDataWindow(FPopup).UseRecordCount := Value;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n\r\n" }, { "path": "External/Jedi/Jvcl/run/JvDBLookupComboEdit.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvDBLookupEdit.PAS, released on 2003-09-18.\r\nThe Code was modified to: JvDBLookupComboEdit.PAS, released on 2003-10-20.\r\n\r\nThe Initial Developers of the Original Code are: Michael Habbe\r\nCopyright (c) 2003 Michael Habbe\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n=============\r\n\r\nIt must inherit from JvLookupEdit, because the new structure in JVCL3 produced\r\n(in my environment) stack-overflow-errors, which \"kicked\" Delphi out of the\r\nmemory with only the message \"Danger. Stack-Overflow. Save your work and restart\r\nDelphi.\". (The message is in German and i never saw it before!?)\r\n\r\nI find out the problem in line 286 \"or inherited ReadOnly;\", when i uncommented\r\nit, Delphi works, but i can modify the dataset, although i set ReadOnly to True.\r\n\r\nAs aforesaid, the component works in my Delphi with JVCL2, but as soon as i\r\ninherit it with JVCL3 from JvDBLookupEdit, the specified errors occur.\r\n\r\nMichael Habbe [2003-10-20]\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvDBLookupComboEdit.pas 13104 2011-09-07 06:50:43Z obones $\r\n\r\nunit JvDBLookupComboEdit;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows,\r\n Messages,\r\n Classes, Controls, Graphics, DB, DBCtrls,\r\n JvDBLookup;\r\n\r\ntype\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvDBLookupComboEdit = class(TJvDBLookupEdit)\r\n private\r\n FDataLink: TFieldDataLink;\r\n FCanvas: TControlCanvas;\r\n // FAlignment: TAlignment;\r\n FFocused: Boolean;\r\n FBeepOnError: Boolean;\r\n procedure ActiveChange(Sender: TObject);\r\n procedure DataChange(Sender: TObject);\r\n procedure EditingChange(Sender: TObject);\r\n function GetCanvas: TCanvas;\r\n function GetDataField: string;\r\n function GetDataSource: TDataSource;\r\n function GetField: TField;\r\n function GetTextMargins: TPoint;\r\n procedure ResetMaxLength;\r\n procedure SetDataField(const Value: string);\r\n procedure SetDataSource(Value: TDataSource);\r\n procedure SetFocused(Value: Boolean);\r\n procedure UpdateData(Sender: TObject);\r\n procedure WMPaint(var Msg: TWMPaint); message WM_PAINT;\r\n procedure CMGetDataLink(var Msg: TMessage); message CM_GETDATALINK;\r\n protected\r\n procedure WMCut(var Msg: TMessage); message WM_CUT;\r\n procedure WMPaste(var Msg: TMessage); message WM_PASTE;\r\n procedure WMUndo(var Msg: TMessage); message WM_UNDO;\r\n procedure DoEnter; override;\r\n procedure DoExit; override;\r\n\r\n function GetReadOnly: Boolean; override; // suppress the warning\r\n procedure SetReadOnly(Value: Boolean); override;\r\n procedure Change; override;\r\n function EditCanModify: Boolean; override;\r\n procedure KeyDown(var Key: Word; Shift: TShiftState); override;\r\n procedure KeyPress(var Key: Char); override;\r\n procedure Loaded; override;\r\n procedure Notification(AComponent: TComponent; Operation: TOperation); override;\r\n procedure Reset; override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n function ExecuteAction(Action: TBasicAction): Boolean; override;\r\n function UpdateAction(Action: TBasicAction): Boolean; override;\r\n // function UseRightToLeftAlignment: Boolean; override;\r\n property Field: TField read GetField;\r\n property Canvas: TCanvas read GetCanvas;\r\n published\r\n property Anchors;\r\n property AutoSelect;\r\n property AutoSize;\r\n property BeepOnError: Boolean read FBeepOnError write FBeepOnError default True;\r\n property BevelEdges;\r\n property BevelInner;\r\n property BevelKind default bkNone;\r\n property BevelOuter;\r\n property BiDiMode;\r\n property BorderStyle;\r\n property CharCase;\r\n property Color;\r\n property Constraints;\r\n property DataField: string read GetDataField write SetDataField;\r\n property DataSource: TDataSource read GetDataSource write SetDataSource;\r\n property DragCursor;\r\n property DragKind;\r\n property DragMode;\r\n property Enabled;\r\n property Font;\r\n property ImeMode;\r\n property ImeName;\r\n property MaxLength;\r\n property ParentBiDiMode;\r\n property ParentColor;\r\n property ParentFont;\r\n property ParentShowHint;\r\n property PasswordChar;\r\n property PopupMenu;\r\n property ReadOnly: Boolean read GetReadOnly write SetReadOnly default False;\r\n property ShowHint;\r\n property TabOrder;\r\n property TabStop;\r\n property Visible;\r\n property OnChange;\r\n property OnClick;\r\n property OnContextPopup;\r\n property OnDblClick;\r\n property OnDragDrop;\r\n property OnDragOver;\r\n property OnEndDock;\r\n property OnEndDrag;\r\n property OnEnter;\r\n property OnExit;\r\n property OnKeyDown;\r\n property OnKeyPress;\r\n property OnKeyUp;\r\n property OnMouseDown;\r\n property OnMouseMove;\r\n property OnMouseUp;\r\n property OnStartDock;\r\n property OnStartDrag;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvDBLookupComboEdit.pas $';\r\n Revision: '$Revision: 13104 $';\r\n Date: '$Date: 2011-09-07 08:50:43 +0200 (mer. 07 sept. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n SysUtils, Forms, StdCtrls,\r\n {$IFNDEF COMPILER12_UP}\r\n JvJCLUtils,\r\n {$ENDIF ~COMPILER12_UP}\r\n JvConsts;\r\n\r\nconstructor TJvDBLookupComboEdit.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n // inherited ReadOnly := True;\r\n ControlStyle := ControlStyle + [csReplicatable];\r\n FCanvas := TControlCanvas.Create;\r\n FCanvas.Control := Self;\r\n FDataLink := TFieldDataLink.Create;\r\n FDataLink.Control := Self;\r\n FDataLink.OnDataChange := DataChange;\r\n FDataLink.OnEditingChange := EditingChange;\r\n FDataLink.OnUpdateData := UpdateData;\r\n FDataLink.OnActiveChange := ActiveChange;\r\n FBeepOnError := True;\r\nend;\r\n\r\ndestructor TJvDBLookupComboEdit.Destroy;\r\nbegin\r\n FDataLink.Free;\r\n FDataLink := nil;\r\n inherited Destroy;\r\n // (rom) destroy Canvas AFTER inherited Destroy\r\n FCanvas.Free;\r\nend;\r\n\r\nprocedure TJvDBLookupComboEdit.ResetMaxLength;\r\nvar\r\n F: TField;\r\nbegin\r\n if (MaxLength > 0) and Assigned(DataSource) and Assigned(DataSource.DataSet) then\r\n begin\r\n F := DataSource.DataSet.FindField(DataField);\r\n if Assigned(F) and (F.DataType in [ftString, ftWideString]) and (F.Size = MaxLength) then\r\n MaxLength := 0;\r\n end;\r\nend;\r\n\r\nprocedure TJvDBLookupComboEdit.Loaded;\r\nbegin\r\n inherited Loaded;\r\n ResetMaxLength;\r\n if csDesigning in ComponentState then\r\n DataChange(Self);\r\nend;\r\n\r\nprocedure TJvDBLookupComboEdit.Notification(AComponent: TComponent;\r\n Operation: TOperation);\r\nbegin\r\n inherited Notification(AComponent, Operation);\r\n if (Operation = opRemove) and (FDataLink <> nil) and (AComponent = DataSource) then\r\n DataSource := nil;\r\nend;\r\n\r\n//function TJvDBLookupComboEdit.UseRightToLeftAlignment: Boolean;\r\n//begin\r\n// Result := DBUseRightToLeftAlignment(Self, Field);\r\n//end;\r\n\r\nprocedure TJvDBLookupComboEdit.KeyDown(var Key: Word; Shift: TShiftState);\r\nbegin\r\n// inherited KeyDown(Key, Shift);\r\n// if (Key = VK_DELETE) or ((Key = VK_INSERT) and (ssShift in Shift)) then\r\n// FDataLink.Edit;\r\n\r\n // new order, because result of inherited KeyDown(...) could be = 0\r\n // so, first set DataSet in Edit-Mode\r\n case Key of\r\n VK_DELETE, VK_UP, VK_DOWN:\r\n if not EditCanModify then\r\n Key := 0;\r\n end;\r\n inherited KeyDown(Key, Shift);\r\nend;\r\n\r\nprocedure TJvDBLookupComboEdit.KeyPress(var Key: Char);\r\nbegin\r\n inherited KeyPress(Key);\r\n if CharInSet(Key, [#32..#255]) and (FDataLink.Field <> nil) and\r\n not FDataLink.Field.IsValidChar(Key) then\r\n begin\r\n if BeepOnError then\r\n SysUtils.Beep;\r\n Key := #0;\r\n end;\r\n if Key = Esc then\r\n begin\r\n FDataLink.Reset;\r\n SelectAll;\r\n// Key := #0;\r\n end\r\n else\r\n if CharInSet(Key, [#8, #9, #24{Ctrl+X}, #32..#255]) then\r\n if not EditCanModify then\r\n Key := #0;\r\nend;\r\n\r\nfunction TJvDBLookupComboEdit.EditCanModify: Boolean;\r\nbegin\r\n Result := FDataLink.Edit;\r\nend;\r\n\r\nprocedure TJvDBLookupComboEdit.Reset;\r\nbegin\r\n FDataLink.Reset;\r\n SelectAll;\r\nend;\r\n\r\nprocedure TJvDBLookupComboEdit.SetFocused(Value: Boolean);\r\nbegin\r\n if FFocused <> Value then\r\n begin\r\n FFocused := Value;\r\n // if (FAlignment <> taLeftJustify) and not IsMasked then Invalidate;\r\n FDataLink.Reset;\r\n end;\r\nend;\r\n\r\nprocedure TJvDBLookupComboEdit.Change;\r\nbegin\r\n FDataLink.Modified;\r\n inherited Change;\r\nend;\r\n\r\nfunction TJvDBLookupComboEdit.GetDataSource: TDataSource;\r\nbegin\r\n Result := FDataLink.DataSource;\r\nend;\r\n\r\nprocedure TJvDBLookupComboEdit.SetDataSource(Value: TDataSource);\r\nbegin\r\n if not (FDataLink.DataSourceFixed and (csLoading in ComponentState)) then\r\n begin\r\n if FDataLink.DataSource <> nil then\r\n FDataLink.DataSource.RemoveFreeNotification(Self);\r\n FDataLink.DataSource := Value;\r\n end;\r\n if Value <> nil then\r\n Value.FreeNotification(Self);\r\nend;\r\n\r\nfunction TJvDBLookupComboEdit.GetDataField: string;\r\nbegin\r\n Result := FDataLink.FieldName;\r\nend;\r\n\r\nprocedure TJvDBLookupComboEdit.SetDataField(const Value: string);\r\nbegin\r\n if not (csDesigning in ComponentState) then\r\n ResetMaxLength;\r\n FDataLink.FieldName := Value;\r\nend;\r\n\r\nfunction TJvDBLookupComboEdit.GetReadOnly: Boolean;\r\nbegin\r\n Result := FDataLink.ReadOnly or inherited GetReadOnly;\r\nend;\r\n\r\nprocedure TJvDBLookupComboEdit.SetReadOnly(Value: Boolean);\r\nbegin\r\n inherited SetReadOnly(Value);\r\n FDataLink.ReadOnly := Value;\r\nend;\r\n\r\nfunction TJvDBLookupComboEdit.GetCanvas: TCanvas;\r\nbegin\r\n Result := FCanvas;\r\nend;\r\n\r\nfunction TJvDBLookupComboEdit.GetField: TField;\r\nbegin\r\n Result := FDataLink.Field;\r\nend;\r\n\r\nprocedure TJvDBLookupComboEdit.ActiveChange(Sender: TObject);\r\nbegin\r\n ResetMaxLength;\r\nend;\r\n\r\nprocedure TJvDBLookupComboEdit.DataChange(Sender: TObject);\r\nbegin\r\n if FDataLink.Field <> nil then\r\n begin\r\n //if FAlignment <> FDataLink.Field.Alignment then\r\n //begin\r\n // EditText := ''; {forces update}\r\n // FAlignment := FDataLink.Field.Alignment;\r\n //end;\r\n EditMask := FDataLink.Field.EditMask;\r\n if not (csDesigning in ComponentState) then\r\n if (FDataLink.Field.DataType in [ftString, ftWideString]) and (MaxLength = 0) then\r\n MaxLength := FDataLink.Field.Size;\r\n if FFocused and FDataLink.CanModify then\r\n Text := FDataLink.Field.Text\r\n else\r\n begin\r\n EditText := FDataLink.Field.DisplayText;\r\n if FDataLink.Editing then //and FDataLink.FModified || fmodified is private in parent of fdatalink\r\n Modified := True;\r\n end;\r\n end\r\n else\r\n begin\r\n //FAlignment := taLeftJustify;\r\n EditMask := '';\r\n if csDesigning in ComponentState then\r\n EditText := Name\r\n else\r\n EditText := '';\r\n end;\r\nend;\r\n\r\nprocedure TJvDBLookupComboEdit.EditingChange(Sender: TObject);\r\nbegin\r\n //ReadOnly := not FDataLink.Editing;\r\nend;\r\n\r\nprocedure TJvDBLookupComboEdit.UpdateData(Sender: TObject);\r\nbegin\r\n ValidateEdit;\r\n FDataLink.Field.Text := Text;\r\nend;\r\n\r\nprocedure TJvDBLookupComboEdit.WMUndo(var Msg: TMessage);\r\nbegin\r\n FDataLink.Edit;\r\n inherited;\r\nend;\r\n\r\nprocedure TJvDBLookupComboEdit.WMPaste(var Msg: TMessage);\r\nbegin\r\n FDataLink.Edit;\r\n inherited;\r\nend;\r\n\r\nprocedure TJvDBLookupComboEdit.WMCut(var Msg: TMessage);\r\nbegin\r\n FDataLink.Edit;\r\n inherited;\r\nend;\r\n\r\nprocedure TJvDBLookupComboEdit.DoEnter;\r\nbegin\r\n SetFocused(True);\r\n inherited DoEnter;\r\n if SysLocale.FarEast and FDataLink.CanModify then\r\n inherited ReadOnly := False;\r\nend;\r\n\r\nprocedure TJvDBLookupComboEdit.DoExit;\r\nbegin\r\n try\r\n FDataLink.UpdateRecord;\r\n except\r\n SelectAll;\r\n SetFocus;\r\n raise;\r\n end;\r\n SetFocused(False);\r\n CheckCursor;\r\n inherited DoExit;\r\nend;\r\n\r\nprocedure TJvDBLookupComboEdit.WMPaint(var Msg: TWMPaint);\r\nconst\r\n AlignStyle: array [Boolean, TAlignment] of DWORD =\r\n ((WS_EX_LEFT, WS_EX_RIGHT, WS_EX_LEFT),\r\n (WS_EX_RIGHT, WS_EX_LEFT, WS_EX_LEFT));\r\nvar\r\n Left: Integer;\r\n Margins: TPoint;\r\n R: TRect;\r\n DC: HDC;\r\n PS: TPaintStruct;\r\n S: string;\r\n AAlignment: TAlignment;\r\n ExStyle: DWORD;\r\nbegin\r\n if csDestroying in ComponentState then\r\n Exit;\r\n AAlignment := Alignment; //FAlignment;\r\n if UseRightToLeftAlignment then\r\n ChangeBiDiModeAlignment(AAlignment);\r\n if ((AAlignment = taLeftJustify) or FFocused) and\r\n not (csPaintCopy in ControlState) then\r\n begin\r\n if SysLocale.MiddleEast and HandleAllocated and (IsRightToLeft) then\r\n begin { This keeps the right aligned text, right aligned }\r\n ExStyle := DWORD(GetWindowLong(Handle, GWL_EXSTYLE)) and (not WS_EX_RIGHT) and\r\n (not WS_EX_RTLREADING) and (not WS_EX_LEFTSCROLLBAR);\r\n if UseRightToLeftReading then\r\n ExStyle := ExStyle or WS_EX_RTLREADING;\r\n if UseRightToLeftScrollbar then\r\n ExStyle := ExStyle or WS_EX_LEFTSCROLLBAR;\r\n ExStyle := ExStyle or\r\n AlignStyle[UseRightToLeftAlignment, AAlignment];\r\n if DWORD(GetWindowLong(Handle, GWL_EXSTYLE)) <> ExStyle then\r\n SetWindowLong(Handle, GWL_EXSTYLE, ExStyle);\r\n end;\r\n inherited;\r\n Exit;\r\n end;\r\n\r\n{ Since edit controls do not handle justification unless multi-line (and\r\n then only poorly) we will draw right and center justify manually unless\r\n the edit has the focus. }\r\n DC := Msg.DC;\r\n if DC = 0 then\r\n DC := BeginPaint(Handle, PS);\r\n FCanvas.Handle := DC;\r\n try\r\n FCanvas.Font := Font;\r\n with FCanvas do\r\n begin\r\n R := ClientRect;\r\n if not Ctl3D and (BorderStyle = bsSingle) then\r\n begin\r\n Brush.Color := clWindowFrame;\r\n FrameRect(R);\r\n InflateRect(R, -1, -1);\r\n end;\r\n Brush.Color := Color;\r\n if not Enabled then\r\n Font.Color := clGrayText;\r\n if (csPaintCopy in ControlState) and (FDataLink.Field <> nil) then\r\n begin\r\n S := FDataLink.Field.DisplayText;\r\n case CharCase of\r\n ecUpperCase:\r\n S := AnsiUpperCase(S);\r\n ecLowerCase:\r\n S := AnsiLowerCase(S);\r\n end;\r\n end\r\n else\r\n S := EditText;\r\n if PasswordChar <> #0 then\r\n FillChar(S[1], Length(S), PasswordChar);\r\n Margins := GetTextMargins;\r\n case AAlignment of\r\n taLeftJustify:\r\n Left := Margins.X;\r\n taRightJustify:\r\n Left := ClientWidth - TextWidth(S) - Margins.X - 1;\r\n else\r\n Left := (ClientWidth - TextWidth(S)) div 2;\r\n end;\r\n if SysLocale.MiddleEast then\r\n UpdateTextFlags;\r\n TextRect(R, Left, Margins.Y, S);\r\n end;\r\n finally\r\n FCanvas.Handle := 0;\r\n if Msg.DC = 0 then\r\n EndPaint(Handle, PS);\r\n end;\r\nend;\r\n\r\nprocedure TJvDBLookupComboEdit.CMGetDataLink(var Msg: TMessage);\r\nbegin\r\n Msg.Result := LRESULT(FDataLink);\r\nend;\r\n\r\nfunction TJvDBLookupComboEdit.GetTextMargins: TPoint;\r\nvar\r\n I: Integer;\r\nbegin\r\n if BorderStyle = bsNone then\r\n I := 0\r\n else\r\n if Ctl3D then\r\n I := 1\r\n else\r\n I := 2;\r\n Result.X := SendMessage(Handle, EM_GETMARGINS, 0, 0) and $0000FFFF + I;\r\n Result.Y := I;\r\nend;\r\n\r\nfunction TJvDBLookupComboEdit.ExecuteAction(Action: TBasicAction): Boolean;\r\nbegin\r\n Result := inherited ExecuteAction(Action) or (FDataLink <> nil) and\r\n FDataLink.ExecuteAction(Action);\r\nend;\r\n\r\nfunction TJvDBLookupComboEdit.UpdateAction(Action: TBasicAction): Boolean;\r\nbegin\r\n Result := inherited UpdateAction(Action) or (FDataLink <> nil) and\r\n FDataLink.UpdateAction(Action);\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvDBLookupTreeView.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvDBLookupTreeView.PAS, released on 2002-07-04.\r\n\r\nThe Initial Developers of the Original Code are: Andrei Prygounkov \r\nCopyright (c) 1999, 2002 Andrei Prygounkov\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nComponents:\r\n TJvDBLookupTreeView,\r\n TJvDBLookupTreeViewCombo\r\n\r\nDescription:\r\n db-aware lookup TreeView\r\n\r\nHistory:\r\n (JVCL Library versions):\r\n 1.20:\r\n - first release;\r\n 1.61:\r\n - support for non-bde components;\r\n 2.01:\r\n - support for BiDi mode\r\n (thanks to Oussama Al-Rifai);\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvDBLookupTreeView.pas 13415 2012-09-10 09:51:54Z obones $\r\n\r\nunit JvDBLookupTreeView;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, Messages,\r\n {$IFDEF RTL240_UP}\r\n System.Generics.Collections,\r\n {$ENDIF RTL240_UP}\r\n Classes, Controls, Forms, ComCtrls, DB,\r\n JvDBTreeView, JvToolEdit, JvComponent, JvExControls;\r\n\r\n{********************** Borland **********************}\r\n\r\ntype\r\n TJvDBLookupControl = class;\r\n\r\n TJvLookupDataSourceLink = class(TDataLink)\r\n private\r\n FDBLookupControl: TJvDBLookupControl;\r\n protected\r\n procedure FocusControl(Field: TFieldRef); override;\r\n procedure ActiveChanged; override;\r\n procedure RecordChanged(Field: TField); override;\r\n end;\r\n\r\n TJvLookupListSourceLink = class(TDataLink)\r\n private\r\n FDBLookupControl: TJvDBLookupControl;\r\n protected\r\n procedure ActiveChanged; override;\r\n procedure DataSetChanged; override;\r\n end;\r\n\r\n TJvDBLookupControl = class(TJvCustomControl)\r\n private\r\n FLookupSource: TDataSource;\r\n FDataLink: TJvLookupDataSourceLink;\r\n FListLink: TJvLookupListSourceLink;\r\n FDataFieldName: string;\r\n FKeyFieldName: string;\r\n FListFieldName: string;\r\n FListFieldIndex: Integer;\r\n FDataField: TField;\r\n FMasterField: TField;\r\n FKeyField: TField;\r\n FListField: TField;\r\n FListFields: TList{$IFDEF RTL240_UP}{$ENDIF RTL240_UP};\r\n FKeyValue: Variant;\r\n FUseFilter: Boolean;\r\n FSearchText: string;\r\n FLookupMode: Boolean;\r\n FListActive: Boolean;\r\n FFocused: Boolean;\r\n FSearchTickCount: Integer;\r\n function CanModify: Boolean;\r\n procedure CheckNotCircular;\r\n procedure CheckNotLookup;\r\n procedure DataLinkActiveChanged;\r\n procedure DataLinkRecordChanged(Field: TField);\r\n function GetBorderSize: Integer;\r\n function GetDataSource: TDataSource;\r\n function GetKeyFieldName: string;\r\n function GetListSource: TDataSource;\r\n function GetReadOnly: Boolean;\r\n function GetTextHeight: Integer;\r\n procedure KeyValueChanged; virtual;\r\n procedure ListLinkActiveChanged; virtual;\r\n procedure ListLinkDataChanged; virtual;\r\n function LocateKey: Boolean;\r\n procedure ProcessSearchKey(Key: Char);\r\n procedure SelectKeyValue(const Value: Variant);\r\n procedure SetDataFieldName(const Value: string);\r\n procedure SetDataSource(Value: TDataSource);\r\n procedure SetKeyFieldName(const Value: string);\r\n procedure SetKeyValue(const Value: Variant);\r\n procedure SetListFieldName(const Value: string);\r\n procedure SetListSource(Value: TDataSource);\r\n procedure SetLookupMode(Value: Boolean);\r\n procedure SetReadOnly(Value: Boolean);\r\n procedure CMGetDataLink(var Msg: TMessage); message CM_GETDATALINK;\r\n protected\r\n procedure FocusKilled(NextWnd: THandle); override;\r\n procedure FocusSet(PrevWnd: THandle); override;\r\n procedure GetDlgCode(var Code: TDlgCodes); override;\r\n procedure Notification(AComponent: TComponent;\r\n Operation: TOperation); override;\r\n property DataField: string read FDataFieldName write SetDataFieldName;\r\n property DataSource: TDataSource read GetDataSource write SetDataSource;\r\n property KeyField: string read GetKeyFieldName write SetKeyFieldName;\r\n property KeyValue: Variant read FKeyValue write SetKeyValue;\r\n property ListField: string read FListFieldName write SetListFieldName;\r\n property ListFieldIndex: Integer read FListFieldIndex write FListFieldIndex default 0;\r\n property ListSource: TDataSource read GetListSource write SetListSource;\r\n property UseFilter: Boolean read FUseFilter write FUseFilter;\r\n property ParentColor default False;\r\n property ReadOnly: Boolean read GetReadOnly write SetReadOnly default False;\r\n property TabStop default True;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n property Field: TField read FDataField;\r\n end;\r\n\r\n TJvTreePopupDataList = class;\r\n\r\n TDropDownAlign = (daLeft, daRight, daCenter);\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvDBLookupTreeViewCombo = class(TJvDBLookupControl)\r\n private\r\n FDataList: TJvTreePopupDataList;\r\n FButtonWidth: Integer;\r\n FText: string;\r\n// FDropDownRows: Integer;\r\n FTracking: Boolean;\r\n FDropDownWidth: Integer;\r\n FDropDownHeight: Integer;\r\n FDropDownAlign: TDropDownAlign;\r\n FListVisible: Boolean;\r\n FPressed: Boolean;\r\n FAlignment: TAlignment;\r\n FLookupMode: Boolean;\r\n FOnDropDown: TNotifyEvent;\r\n FOnCloseUp: TNotifyEvent;\r\n FMasterField: string; {new}\r\n FDetailField: string; {new}\r\n FIconField: string; {new}\r\n FStartMasterValue: string;\r\n FFullExpand: Boolean; {new}\r\n procedure KeyValueChanged; override;\r\n procedure ListLinkActiveChanged; override;\r\n{ procedure ListMouseUp(Sender: TObject; Button: TMouseButton;\r\n Shift: TShiftState; X, Y: Integer);}\r\n procedure StopTracking;\r\n procedure TrackButton(X, Y: Integer);\r\n procedure CMCtl3DChanged(var Msg: TMessage); message CM_CTL3DCHANGED;\r\n procedure CMGetDataLink(var Msg: TMessage); message CM_GETDATALINK;\r\n procedure WMCancelMode(var Msg: TMessage); message WM_CANCELMODE;\r\n procedure CMCancelMode(var Msg: TCMCancelMode); message CM_CANCELMODE;\r\n procedure PopupCloseUp(Sender: TObject; Accept: Boolean); virtual;\r\n private\r\n FAutoExpand: Boolean;\r\n FChangeDelay: Integer;\r\n FHotTrack: Boolean;\r\n FRowSelect: Boolean;\r\n FToolTips: Boolean;\r\n FOnCustomDraw: TTVCustomDrawEvent;\r\n FOnCustomDrawItem: TTVCustomDrawItemEvent;\r\n FOnGetImageIndex: TTVExpandedEvent;\r\n protected\r\n procedure FontChanged; override;\r\n procedure FocusKilled(NextWnd: THandle); override;\r\n procedure CreateParams(var Params: TCreateParams); override;\r\n procedure Paint; override;\r\n procedure KeyDown(var Key: Word; Shift: TShiftState); override;\r\n procedure KeyPress(var Key: Char); override;\r\n procedure MouseDown(Button: TMouseButton; Shift: TShiftState;\r\n X, Y: Integer); override;\r\n procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;\r\n procedure MouseUp(Button: TMouseButton; Shift: TShiftState;\r\n X, Y: Integer); override;\r\n {added by zelen}\r\n {$IFDEF JVCLThemesEnabled}\r\n procedure MouseEnter(Control: TControl); override;\r\n procedure MouseLeave(Control: TControl); override;\r\n {$ENDIF JVCLThemesEnabled}\r\n {/added by zelen}\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n procedure CloseUp(Accept: Boolean);\r\n procedure DropDown;\r\n procedure SetBounds(ALeft, ATop, AWidth, AHeight: Integer); override;\r\n function CanFocusEx: Boolean;\r\n property KeyValue;\r\n property ListVisible: Boolean read FListVisible;\r\n property Text: string read FText;\r\n published\r\n property AutoSize;\r\n property Color;\r\n property DataField;\r\n property DataSource;\r\n property DragCursor;\r\n property DragMode;\r\n property DropDownAlign: TDropDownAlign read FDropDownAlign write FDropDownAlign default daLeft;\r\n// property DropDownRows: Integer read FDropDownRows write FDropDownRows default 7;\r\n property DropDownWidth: Integer read FDropDownWidth write FDropDownWidth default 0;\r\n {new}\r\n property DropDownHeight: Integer read FDropDownHeight write FDropDownHeight default 100;\r\n\r\n property Enabled;\r\n property Font;\r\n property KeyField;\r\n property ListField;\r\n property UseFilter;\r\n {new}\r\n property MasterField: string read FMasterField write FMasterField;\r\n property DetailField: string read FDetailField write FDetailField;\r\n property IconField: string read FIconField write FIconField;\r\n property StartMasterValue: string read FStartMasterValue write FStartMasterValue;\r\n\r\n property ListFieldIndex;\r\n property ListSource;\r\n property ParentColor;\r\n property ParentFont;\r\n property ParentShowHint;\r\n property PopupMenu;\r\n property ReadOnly;\r\n property ShowHint;\r\n property TabOrder;\r\n property TabStop;\r\n property Visible;\r\n property OnClick;\r\n property OnCloseUp: TNotifyEvent read FOnCloseUp write FOnCloseUp;\r\n property OnDragDrop;\r\n property OnDragOver;\r\n property OnDropDown: TNotifyEvent read FOnDropDown write FOnDropDown;\r\n property OnEndDrag;\r\n property OnEnter;\r\n property OnExit;\r\n property OnKeyDown;\r\n property OnKeyPress;\r\n property OnKeyUp;\r\n property OnMouseDown;\r\n property OnMouseMove;\r\n property OnMouseUp;\r\n property OnStartDrag;\r\n property ImeMode;\r\n property ImeName;\r\n property Anchors;\r\n property BevelEdges;\r\n property BevelInner;\r\n property BevelKind default bkNone;\r\n property BevelOuter;\r\n property BiDiMode;\r\n property BorderWidth;\r\n property Constraints;\r\n property DragKind;\r\n property ParentBiDiMode;\r\n property OnEndDock;\r\n property OnStartDock;\r\n property AutoExpand: Boolean read FAutoExpand write FAutoExpand;\r\n property ChangeDelay: Integer read FChangeDelay write FChangeDelay;\r\n property HotTrack: Boolean read FHotTrack write FHotTrack;\r\n property RowSelect: Boolean read FRowSelect write FRowSelect;\r\n property ToolTips: Boolean read FToolTips write FToolTips;\r\n property OnCustomDraw: TTVCustomDrawEvent read FOnCustomDraw write FOnCustomDraw;\r\n property OnCustomDrawItem: TTVCustomDrawItemEvent read FOnCustomDrawItem write FOnCustomDrawItem;\r\n property OnGetImageIndex: TTVExpandedEvent read FOnGetImageIndex write FOnGetImageIndex;\r\n property FullExpand: Boolean read FFullExpand write FFullExpand default False;\r\n end;\r\n\r\n{###################### Borland ######################}\r\n\r\n TJvPopupTree = class(TJvDBTreeView)\r\n private\r\n procedure CNNotify(var Msg: TWMNotify); message CN_NOTIFY;\r\n protected\r\n procedure FocusSet(PrevWnd: THandle); override;\r\n procedure DblClick; override;\r\n end;\r\n\r\n TJvTreePopupDataList = class(TJvPopupWindow)\r\n private\r\n FTree: TJvPopupTree;\r\n protected\r\n function GetValue: Variant; override;\r\n procedure SetValue(const Value: Variant); override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n\r\n function GetPopupText: string; override;\r\n end;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvDBLookupTreeView = class(TJvDBLookupControl)\r\n private\r\n FTree: TJvDBTreeView;\r\n FBorderStyle: TBorderStyle;\r\n InKeyValueChanged: Boolean;\r\n procedure SetBorderStyle(Value: TBorderStyle);\r\n function GetMasterField: string;\r\n procedure SetMasterField(Value: string);\r\n function GetDetailField: string;\r\n procedure SetDetailField(Value: string);\r\n function GetStartMasterValue: string;\r\n procedure SetStartMasterValue(Value: string);\r\n function GetIconField: string;\r\n procedure SetIconField(const Value: string);\r\n procedure KeyValueChanged; override;\r\n {Tree}\r\n function GetShowButtons: Boolean;\r\n function GetShowLines: Boolean;\r\n function GetShowRoot: Boolean;\r\n function GetReadOnly: Boolean;\r\n function GetHideSelection: Boolean;\r\n function GetIndent: Integer;\r\n procedure SetShowButtons(Value: Boolean);\r\n procedure SetShowLines(Value: Boolean);\r\n procedure SetShowRoot(Value: Boolean);\r\n procedure SetReadOnly(Value: Boolean);\r\n procedure SetHideSelection(Value: Boolean);\r\n procedure SetIndent(Value: Integer);\r\n function GetRightClickSelect: Boolean;\r\n procedure SetRightClickSelect(Value: Boolean);\r\n function GetAutoExpand: Boolean;\r\n function GetChangeDelay: Integer;\r\n function GetHotTrack: Boolean;\r\n function GetOnGetImageIndex: TTVExpandedEvent;\r\n function GetRowSelect: Boolean;\r\n function GetToolTips: Boolean;\r\n procedure SetAutoExpand(const Value: Boolean);\r\n procedure SetChangeDelay(const Value: Integer);\r\n procedure SetHotTrack(const Value: Boolean);\r\n procedure SetOnGetImageIndex(const Value: TTVExpandedEvent);\r\n procedure SetRowSelect(const Value: Boolean);\r\n procedure SetToolTips(const Value: Boolean);\r\n function GetOnCustomDraw: TTVCustomDrawEvent;\r\n function GetOnCustomDrawItem: TTVCustomDrawItemEvent;\r\n procedure SetOnCustomDraw(const Value: TTVCustomDrawEvent);\r\n procedure SetOnCustomDrawItem(const Value: TTVCustomDrawItemEvent);\r\n protected\r\n procedure FocusSet(PrevWnd: THandle); override;\r\n procedure CreateParams(var Params: TCreateParams); override;\r\n procedure ListLinkActiveChanged; override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n published\r\n property Align;\r\n property BevelEdges;\r\n property BevelInner;\r\n property BevelKind default bkNone;\r\n property BevelOuter;\r\n property BorderStyle: TBorderStyle read FBorderStyle write SetBorderStyle default bsSingle;\r\n property Color;\r\n property DataField;\r\n property DataSource;\r\n property DragCursor;\r\n property DragMode;\r\n property Enabled;\r\n property Font;\r\n property KeyField;\r\n property ListField;\r\n property ListFieldIndex;\r\n property ListSource;\r\n property ParentColor;\r\n property ParentFont;\r\n property ParentShowHint;\r\n property PopupMenu;\r\n property ShowHint;\r\n property TabOrder;\r\n property TabStop;\r\n property Visible;\r\n property OnClick;\r\n property OnDblClick;\r\n property OnDragDrop;\r\n property OnDragOver;\r\n property OnEndDrag;\r\n property OnEnter;\r\n property OnExit;\r\n property OnKeyDown;\r\n property OnKeyPress;\r\n property OnKeyUp;\r\n property OnMouseDown;\r\n property OnMouseMove;\r\n property OnMouseUp;\r\n property OnStartDrag;\r\n property ImeMode;\r\n property ImeName;\r\n property Anchors;\r\n property BiDiMode;\r\n property BorderWidth;\r\n property Constraints;\r\n property DragKind;\r\n property ParentBiDiMode;\r\n property OnEndDock;\r\n property OnStartDock;\r\n\r\n property AutoExpand: Boolean read GetAutoExpand write SetAutoExpand;\r\n property ChangeDelay: Integer read GetChangeDelay write SetChangeDelay;\r\n property HotTrack: Boolean read GetHotTrack write SetHotTrack;\r\n property RowSelect: Boolean read GetRowSelect write SetRowSelect;\r\n property ToolTips: Boolean read GetToolTips write SetToolTips;\r\n property OnCustomDraw: TTVCustomDrawEvent read GetOnCustomDraw write SetOnCustomDraw;\r\n property OnCustomDrawItem: TTVCustomDrawItemEvent read GetOnCustomDrawItem write SetOnCustomDrawItem;\r\n property OnGetImageIndex: TTVExpandedEvent read GetOnGetImageIndex write SetOnGetImageIndex;\r\n {Tree}\r\n property MasterField: string read GetMasterField write SetMasterField;\r\n property DetailField: string read GetDetailField write SetDetailField;\r\n property IconField: string read GetIconField write SetIconField;\r\n property StartMasterValue: string read GetStartMasterValue write SetStartMasterValue;\r\n property ShowButtons: Boolean read GetShowButtons write SetShowButtons;\r\n property ShowLines: Boolean read GetShowLines write SetShowLines;\r\n property ShowRoot: Boolean read GetShowRoot write SetShowRoot;\r\n property ReadOnly: Boolean read GetReadOnly write SetReadOnly;\r\n property RightClickSelect: Boolean read GetRightClickSelect write SetRightClickSelect;\r\n property HideSelection: Boolean read GetHideSelection write SetHideSelection;\r\n property Indent: Integer read GetIndent write SetIndent;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvDBLookupTreeView.pas $';\r\n Revision: '$Revision: 13415 $';\r\n Date: '$Date: 2012-09-10 11:51:54 +0200 (lun. 10 sept. 2012) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n Variants, VDBConsts,\r\n {$IFDEF COMPILER10_UP}\r\n Types, // to allow inline expansion\r\n {$ENDIF COMPILER10_UP}\r\n CommCtrl, Graphics, DBConsts,\r\n JvThemes, JclSysUtils;\r\n\r\n//=== { TJvLookupDataSourceLink } ============================================\r\n\r\nprocedure TJvLookupDataSourceLink.ActiveChanged;\r\nbegin\r\n if FDBLookupControl <> nil then\r\n FDBLookupControl.DataLinkActiveChanged;\r\nend;\r\n\r\nprocedure TJvLookupDataSourceLink.RecordChanged(Field: TField);\r\nbegin\r\n if FDBLookupControl <> nil then\r\n FDBLookupControl.DataLinkRecordChanged(Field);\r\nend;\r\n\r\nprocedure TJvLookupDataSourceLink.FocusControl(Field: TFieldRef);\r\nbegin\r\n if (Field^ <> nil) and (Field^ = FDBLookupControl.Field) and\r\n (FDBLookupControl <> nil) and FDBLookupControl.CanFocus then\r\n begin\r\n Field^ := nil;\r\n FDBLookupControl.SetFocus;\r\n end;\r\nend;\r\n\r\nprocedure TJvLookupListSourceLink.ActiveChanged;\r\nbegin\r\n if FDBLookupControl <> nil then\r\n FDBLookupControl.ListLinkActiveChanged;\r\nend;\r\n\r\nprocedure TJvLookupListSourceLink.DataSetChanged;\r\nbegin\r\n if FDBLookupControl <> nil then\r\n FDBLookupControl.ListLinkDataChanged;\r\nend;\r\n\r\n//=== { TJvDBLookupControl } =================================================\r\n\r\nfunction VarEquals(const V1, V2: Variant): Boolean;\r\nbegin\r\n Result := False;\r\n try\r\n Result := V1 = V2;\r\n except\r\n end;\r\nend;\r\n\r\nconstructor TJvDBLookupControl.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n ControlStyle := [csOpaque];\r\n IncludeThemeStyle(Self, [csNeedsBorderPaint]);\r\n\r\n ParentColor := False;\r\n TabStop := True;\r\n FLookupSource := TDataSource.Create(Self);\r\n FDataLink := TJvLookupDataSourceLink.Create;\r\n FDataLink.FDBLookupControl := Self;\r\n FListLink := TJvLookupListSourceLink.Create;\r\n FListLink.FDBLookupControl := Self;\r\n FListFields := TList{$IFDEF RTL240_UP}{$ENDIF RTL240_UP}.Create;\r\n FKeyValue := Null;\r\n FSearchTickCount := 0;\r\nend;\r\n\r\ndestructor TJvDBLookupControl.Destroy;\r\nbegin\r\n // Deregister FreeNotifications\r\n DataSource := nil;\r\n ListSource := nil;\r\n\r\n FListFields.Free;\r\n FListLink.FDBLookupControl := nil;\r\n FListLink.Free;\r\n FDataLink.FDBLookupControl := nil;\r\n FDataLink.Free;\r\n FDataLink := nil;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJvDBLookupControl.CanModify: Boolean;\r\nbegin\r\n Result := FListActive and not ReadOnly and ((FDataLink.DataSource = nil) or\r\n (FMasterField <> nil) and FMasterField.CanModify);\r\nend;\r\n\r\nprocedure TJvDBLookupControl.CheckNotCircular;\r\nbegin\r\n if (FDataLink.Active and FDataLink.DataSet.IsLinkedTo(ListSource)) or\r\n (FListLink.Active and FListLink.DataSet.IsLinkedTo(DataSource)) then\r\n DatabaseError(SCircularDataLink);\r\nend;\r\n\r\nprocedure TJvDBLookupControl.CheckNotLookup;\r\nbegin\r\n if FLookupMode then\r\n DatabaseError(SPropDefByLookup);\r\n if FDataLink.DataSourceFixed then\r\n DatabaseError(SDataSourceFixed);\r\nend;\r\n\r\nprocedure TJvDBLookupControl.DataLinkActiveChanged;\r\nbegin\r\n FDataField := nil;\r\n FMasterField := nil;\r\n if FDataLink.Active and (FDataFieldName <> '') then\r\n begin\r\n CheckNotCircular;\r\n FDataField := GetFieldProperty(FDataLink.DataSet, Self, FDataFieldName);\r\n FMasterField := FDataField;\r\n end;\r\n SetLookupMode((FDataField <> nil) and (FDataField.FieldKind = fkLookup));\r\n DataLinkRecordChanged(nil);\r\nend;\r\n\r\nprocedure TJvDBLookupControl.DataLinkRecordChanged(Field: TField);\r\nbegin\r\n if (Field = nil) or (Field = FMasterField) then\r\n if FMasterField <> nil then\r\n SetKeyValue(FMasterField.Value)\r\n else\r\n SetKeyValue(Null);\r\nend;\r\n\r\nfunction TJvDBLookupControl.GetBorderSize: Integer;\r\nvar\r\n Params: TCreateParams;\r\n R: TRect;\r\nbegin\r\n CreateParams(Params);\r\n SetRect(R, 0, 0, 0, 0);\r\n AdjustWindowRectEx(R, Params.Style, False, Params.ExStyle);\r\n Result := R.Bottom - R.Top;\r\nend;\r\n\r\nfunction TJvDBLookupControl.GetDataSource: TDataSource;\r\nbegin\r\n Result := FDataLink.DataSource;\r\nend;\r\n\r\nfunction TJvDBLookupControl.GetKeyFieldName: string;\r\nbegin\r\n if FLookupMode then\r\n Result := ''\r\n else\r\n Result := FKeyFieldName;\r\nend;\r\n\r\nfunction TJvDBLookupControl.GetListSource: TDataSource;\r\nbegin\r\n if FLookupMode then\r\n Result := nil\r\n else\r\n Result := FListLink.DataSource;\r\nend;\r\n\r\nfunction TJvDBLookupControl.GetReadOnly: Boolean;\r\nbegin\r\n Result := FDataLink.ReadOnly;\r\nend;\r\n\r\nfunction TJvDBLookupControl.GetTextHeight: Integer;\r\nvar\r\n DC: HDC;\r\n SaveFont: HFont;\r\n Metrics: TTextMetric;\r\nbegin\r\n DC := GetDC(HWND_DESKTOP);\r\n SaveFont := SelectObject(DC, Font.Handle);\r\n GetTextMetrics(DC, Metrics);\r\n SelectObject(DC, SaveFont);\r\n ReleaseDC(HWND_DESKTOP, DC);\r\n Result := Metrics.tmHeight;\r\nend;\r\n\r\nprocedure TJvDBLookupControl.KeyValueChanged;\r\nbegin\r\nend;\r\n\r\nprocedure TJvDBLookupControl.ListLinkActiveChanged;\r\nvar\r\n DataSet: TDataSet;\r\n ResultField: TField;\r\nbegin\r\n FListActive := False;\r\n FKeyField := nil;\r\n FListField := nil;\r\n FListFields.Clear;\r\n if FListLink.Active and (FKeyFieldName <> '') then\r\n begin\r\n CheckNotCircular;\r\n DataSet := FListLink.DataSet;\r\n FKeyField := GetFieldProperty(DataSet, Self, FKeyFieldName);\r\n try\r\n DataSet.GetFieldList(FListFields, FListFieldName);\r\n except\r\n DatabaseErrorFmt(SFieldNotFound, [Self.Name, FListFieldName]);\r\n end;\r\n if FLookupMode then\r\n begin\r\n ResultField := GetFieldProperty(DataSet, Self, FDataField.LookupResultField);\r\n if FListFields.IndexOf(ResultField) < 0 then\r\n FListFields.Insert(0, ResultField);\r\n FListField := ResultField;\r\n end\r\n else\r\n begin\r\n if FListFields.Count = 0 then\r\n FListFields.Add(FKeyField);\r\n if (FListFieldIndex >= 0) and (FListFieldIndex < FListFields.Count) then\r\n FListField := FListFields[FListFieldIndex]\r\n else\r\n FListField := FListFields[0];\r\n end;\r\n FListActive := True;\r\n end;\r\nend;\r\n\r\nprocedure TJvDBLookupControl.ListLinkDataChanged;\r\nbegin\r\nend;\r\n\r\nfunction TJvDBLookupControl.LocateKey: Boolean;\r\nbegin\r\n Result := False;\r\n try\r\n if not VarIsNullEmpty(FKeyValue) and\r\n FListLink.DataSet.Locate(FKeyFieldName, FKeyValue, []) then\r\n Result := True;\r\n except\r\n end;\r\nend;\r\n\r\nprocedure TJvDBLookupControl.Notification(AComponent: TComponent;\r\n Operation: TOperation);\r\nbegin\r\n inherited Notification(AComponent, Operation);\r\n if (Operation = opRemove) and not (csDestroying in ComponentState) then\r\n begin\r\n if (FDataLink <> nil) and (AComponent = DataSource) then\r\n DataSource := nil;\r\n if (FListLink <> nil) and (AComponent = ListSource) then\r\n ListSource := nil;\r\n end;\r\nend;\r\n\r\nprocedure TJvDBLookupControl.ProcessSearchKey(Key: Char);\r\nvar\r\n TickCount: Integer;\r\n S: string;\r\nbegin\r\n if (FListField <> nil) and (FListField.FieldKind = fkData) and\r\n (FListField.DataType = ftString) then\r\n case Word(Key) of\r\n VK_BACK, VK_ESCAPE:\r\n FSearchText := '';\r\n VK_SPACE..255:\r\n if CanModify then\r\n begin\r\n TickCount := GetTickCount;\r\n if TickCount - FSearchTickCount > 2000 then\r\n FSearchText := '';\r\n FSearchTickCount := TickCount;\r\n if Length(FSearchText) < 32 then\r\n begin\r\n S := FSearchText + Key;\r\n if FListLink.DataSet.Locate(FListField.FieldName, S,\r\n [loCaseInsensitive, loPartialKey]) then\r\n begin\r\n SelectKeyValue(FKeyField.Value);\r\n FSearchText := S;\r\n end;\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvDBLookupControl.SelectKeyValue(const Value: Variant);\r\nbegin\r\n if FMasterField <> nil then\r\n begin\r\n if FDataLink.Edit then\r\n FMasterField.Value := Value;\r\n end\r\n else\r\n SetKeyValue(Value);\r\n Repaint;\r\n Click;\r\nend;\r\n\r\nprocedure TJvDBLookupControl.SetDataFieldName(const Value: string);\r\nbegin\r\n if FDataFieldName <> Value then\r\n begin\r\n FDataFieldName := Value;\r\n DataLinkActiveChanged;\r\n end;\r\nend;\r\n\r\nprocedure TJvDBLookupControl.SetDataSource(Value: TDataSource);\r\nbegin\r\n if FDataLink.DataSource <> nil then\r\n FDataLink.DataSource.RemoveFreeNotification(Self);\r\n FDataLink.DataSource := Value;\r\n if Value <> nil then\r\n Value.FreeNotification(Self);\r\nend;\r\n\r\nprocedure TJvDBLookupControl.SetKeyFieldName(const Value: string);\r\nbegin\r\n CheckNotLookup;\r\n if FKeyFieldName <> Value then\r\n begin\r\n FKeyFieldName := Value;\r\n ListLinkActiveChanged;\r\n end;\r\nend;\r\n\r\nprocedure TJvDBLookupControl.SetKeyValue(const Value: Variant);\r\nbegin\r\n if not VarEquals(FKeyValue, Value) then\r\n begin\r\n FKeyValue := Value;\r\n KeyValueChanged;\r\n end;\r\nend;\r\n\r\nprocedure TJvDBLookupControl.SetListFieldName(const Value: string);\r\nbegin\r\n if FListFieldName <> Value then\r\n begin\r\n FListFieldName := Value;\r\n ListLinkActiveChanged;\r\n end;\r\nend;\r\n\r\nprocedure TJvDBLookupControl.SetListSource(Value: TDataSource);\r\nbegin\r\n CheckNotLookup;\r\n if FListLink.DataSource <> nil then\r\n FListLink.DataSource.RemoveFreeNotification(Self);\r\n FListLink.DataSource := Value;\r\n if Value <> nil then\r\n Value.FreeNotification(Self);\r\nend;\r\n\r\nprocedure TJvDBLookupControl.SetLookupMode(Value: Boolean);\r\nbegin\r\n if FLookupMode <> Value then\r\n if Value then\r\n begin\r\n FMasterField := GetFieldProperty(FDataField.DataSet, Self, FDataField.KeyFields);\r\n FLookupSource.DataSet := FDataField.LookupDataSet;\r\n FKeyFieldName := FDataField.LookupKeyFields;\r\n FLookupMode := True;\r\n FListLink.DataSource := FLookupSource;\r\n end\r\n else\r\n begin\r\n FListLink.DataSource := nil;\r\n FLookupMode := False;\r\n FKeyFieldName := '';\r\n FLookupSource.DataSet := nil;\r\n FMasterField := FDataField;\r\n end;\r\nend;\r\n\r\nprocedure TJvDBLookupControl.SetReadOnly(Value: Boolean);\r\nbegin\r\n FDataLink.ReadOnly := Value;\r\nend;\r\n\r\nprocedure TJvDBLookupControl.GetDlgCode(var Code: TDlgCodes);\r\nbegin\r\n Code := [dcWantArrows, dcWantChars];\r\nend;\r\n\r\nprocedure TJvDBLookupControl.FocusKilled(NextWnd: THandle);\r\nbegin\r\n FFocused := False;\r\n inherited FocusKilled(NextWnd);\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvDBLookupControl.FocusSet(PrevWnd: THandle);\r\nbegin\r\n FFocused := True;\r\n inherited FocusSet(PrevWnd);\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvDBLookupControl.CMGetDataLink(var Msg: TMessage);\r\nbegin\r\n Msg.Result := LRESULT(FDataLink);\r\nend;\r\n\r\n//=== { TJvDBLookupTreeViewCombo } ===========================================\r\n\r\nconstructor TJvDBLookupTreeViewCombo.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n ControlStyle := ControlStyle + [csReplicatable];\r\n Width := 145;\r\n Height := 0;\r\n FDataList := TJvTreePopupDataList.Create(Self);\r\n// FDataList.Visible := False;\r\n// FDataList.Parent := Self;\r\n FButtonWidth := GetSystemMetrics(SM_CXVSCROLL);\r\n FDropDownHeight := 100;\r\n FFullExpand := False;\r\nend;\r\n\r\nprocedure TJvDBLookupTreeViewCombo.CreateParams(var Params: TCreateParams);\r\nbegin\r\n inherited CreateParams(Params);\r\n with Params do\r\n if Ctl3D then\r\n ExStyle := ExStyle or WS_EX_CLIENTEDGE\r\n else\r\n Style := Style or WS_BORDER;\r\nend;\r\n\r\nprocedure TJvDBLookupTreeViewCombo.Paint;\r\nvar\r\n W, X, Flags: Integer;\r\n Text: string;\r\n Alignment: TAlignment;\r\n Selected: Boolean;\r\n R: TRect;\r\n\r\n {added by zelen}\r\n {$IFDEF JVCLThemesEnabled}\r\n State: TThemedComboBox;\r\n Details: TThemedElementDetails;\r\n {$ENDIF JVCLThemesEnabled}\r\n {/added by zelen}\r\n\r\nbegin\r\n Canvas.Font := Font;\r\n Canvas.Brush.Color := Color;\r\n Selected := FFocused and not FListVisible and not (csPaintCopy in ControlState);\r\n\r\n if Selected then\r\n begin\r\n Canvas.Font.Color := clHighlightText;\r\n Canvas.Brush.Color := clHighlight;\r\n end\r\n {added by zelen}\r\n else\r\n if not Enabled then\r\n Canvas.Font.Color := clGrayText;\r\n {/added by zelen}\r\n if (csPaintCopy in ControlState) and (FDataField <> nil) then\r\n begin\r\n Text := FDataField.DisplayText;\r\n Alignment := FDataField.Alignment;\r\n end\r\n else\r\n begin\r\n Text := FText;\r\n Alignment := FAlignment;\r\n end;\r\n W := ClientWidth - FButtonWidth;\r\n X := 2;\r\n case Alignment of\r\n taRightJustify: X := W - Canvas.TextWidth(Text) - 3;\r\n taCenter: X := (W - Canvas.TextWidth(Text)) div 2;\r\n end;\r\n\r\n // Fill the background (Mantis 2723)\r\n SetRect(R, 0, 0, W, ClientHeight);\r\n Canvas.FillRect(R);\r\n\r\n SetRect(R, 1, 1, W - 1, ClientHeight - 1);\r\n Canvas.TextRect(R, X, 2, Text);\r\n if Selected then\r\n Canvas.DrawFocusRect(R);\r\n\r\n SetRect(R, W, 0, ClientWidth, ClientHeight);\r\n {added by zelen}\r\n {$IFDEF JVCLThemesEnabled}\r\n if ThemeServices.{$IFDEF RTL230_UP}Enabled{$ELSE}ThemesEnabled{$ENDIF RTL230_UP} then\r\n begin\r\n if (not FListActive) or (not Enabled) or ReadOnly then\r\n State := tcDropDownButtonDisabled\r\n else\r\n if FPressed then\r\n State := tcDropDownButtonPressed\r\n else\r\n if MouseOver and not FListVisible then\r\n State := tcDropDownButtonHot\r\n else\r\n State := tcDropDownButtonNormal;\r\n Details := ThemeServices.GetElementDetails(State);\r\n ThemeServices.DrawElement(Canvas.Handle, Details, R);\r\n\r\n\r\n\r\n\r\n end\r\n else\r\n {$ENDIF JVCLThemesEnabled}\r\n {/added by zelen}\r\n begin\r\n if not FListActive or not Enabled or ReadOnly then\r\n Flags := DFCS_SCROLLCOMBOBOX or DFCS_INACTIVE\r\n else\r\n if FPressed then\r\n Flags := DFCS_SCROLLCOMBOBOX or DFCS_FLAT or DFCS_PUSHED\r\n else\r\n Flags := DFCS_SCROLLCOMBOBOX;\r\n DrawFrameControl(Canvas.Handle, R, DFC_SCROLL, Flags);\r\n end;\r\nend;\r\n\r\nprocedure TJvDBLookupTreeViewCombo.SetBounds(ALeft, ATop, AWidth, AHeight: Integer);\r\nbegin\r\n inherited SetBounds(ALeft, ATop, AWidth, GetTextHeight + GetBorderSize + 4);\r\n\r\nend;\r\n\r\nprocedure TJvDBLookupTreeViewCombo.KeyValueChanged;\r\nbegin\r\n if FLookupMode then\r\n begin\r\n FText := FDataField.DisplayText;\r\n FAlignment := FDataField.Alignment;\r\n end\r\n else\r\n if FListActive and LocateKey then\r\n begin\r\n FText := FListField.DisplayText;\r\n FAlignment := FListField.Alignment;\r\n end\r\n else\r\n begin\r\n FText := '';\r\n FAlignment := taLeftJustify;\r\n end;\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvDBLookupTreeViewCombo.ListLinkActiveChanged;\r\nbegin\r\n inherited ListLinkActiveChanged;\r\n KeyValueChanged;\r\nend;\r\n\r\nfunction TJvDBLookupTreeViewCombo.CanFocusEx: Boolean;\r\nvar\r\n P: TWinControl;\r\nbegin\r\n P := Parent;\r\n Result := Visible and Enabled;\r\n while Result and (P <> nil) do\r\n begin\r\n Result := P.Visible and P.Enabled;\r\n P := P.Parent;\r\n end;\r\nend;\r\n\r\nprocedure TJvDBLookupTreeViewCombo.CloseUp(Accept: Boolean);\r\nvar\r\n ListValue: Variant;\r\nbegin\r\n if FListVisible then\r\n begin\r\n if GetCapture <> 0 then\r\n SendMessage(GetCapture, WM_CANCELMODE, 0, 0);\r\n ListValue := FDataList.GetValue;\r\n if CanFocusEx then\r\n SetFocus;\r\n FDataList.Hide;\r\n{ SetWindowPos(FDataList.Handle, 0, 0, 0, 0, 0, SWP_NOZORDER or\r\n SWP_NOMOVE or SWP_NOSIZE or SWP_NOACTIVATE or SWP_HIDEWINDOW); }\r\n FListVisible := False;\r\n // FDataList.ListSource := nil;\r\n FDataList.FTree.DataSource := nil;\r\n Invalidate;\r\n FSearchText := '';\r\n if Accept and CanModify then\r\n SelectKeyValue(ListValue);\r\n if Assigned(FOnCloseUp) then\r\n FOnCloseUp(Self);\r\n FPressed := False;\r\n Repaint;\r\n end;\r\nend;\r\n\r\nprocedure TJvDBLookupTreeViewCombo.DropDown;\r\nvar\r\n P: TPoint;\r\n {I,}Y: Integer;\r\n {S: string;}\r\n OldLong: Longword;\r\nbegin\r\n if not FListVisible and FListActive then\r\n begin\r\n if Assigned(FOnDropDown) then\r\n FOnDropDown(Self);\r\n FDataList.Color := Color;\r\n FDataList.Font := Font;\r\n if FDropDownWidth > 0 then\r\n FDataList.Width := FDropDownWidth\r\n else\r\n FDataList.Width := Width;\r\n FDataList.Height := FDropDownHeight;\r\n // FDataList.RowCount := FDropDownRows;\r\n // FDataList.KeyField := FKeyFieldName;\r\n FDataList.FTree.MasterField := FKeyFieldName;\r\n FDataList.FTree.DetailField := FDetailField;\r\n FDataList.FTree.IconField := FIconField;\r\n FDataList.FTree.MasterField := FMasterField;\r\n FDataList.FTree.StartMasterValue := FStartMasterValue;\r\n FDataList.FTree.UseFilter := FUseFilter;\r\n\r\n {Source added by Oussama Al-Rifai}\r\n OldLong := GetWindowLong(FDataList.FTree.Handle, GWL_EXSTYLE);\r\n if BiDiMode <> bdLeftToRight then\r\n begin\r\n FDataList.FTree.BiDiMode := bdLeftToRight;\r\n SetWindowLong(FDataList.FTree.Handle, GWL_EXSTYLE, OldLong or $00400000);\r\n end\r\n else\r\n SetWindowLong(FDataList.FTree.Handle, GWL_EXSTYLE, OldLong and not $00400000);\r\n {End of source added by Oussama Al-Rifai}\r\n\r\n FDataList.FTree.AutoExpand := FAutoExpand;\r\n FDataList.FTree.ChangeDelay := FChangeDelay;\r\n FDataList.FTree.HotTrack := FHotTrack;\r\n FDataList.FTree.RowSelect := FRowSelect;\r\n FDataList.FTree.ToolTips := FToolTips;\r\n FDataList.FTree.OnCustomDraw := FOnCustomDraw;\r\n FDataList.FTree.OnCustomDrawItem := FOnCustomDrawItem;\r\n FDataList.FTree.OnGetImageIndex := FOnGetImageIndex;\r\n FDataList.FTree.ReadOnly := not FDataLink.ReadOnly;\r\n\r\n { for I := 0 to FListFields.Count - 1 do\r\n S := S + TField(FListFields[I]).FieldName + ';';\r\n FDataList.ListField := S;}\r\n FDataList.FTree.ItemField := ListField;\r\n\r\n // FDataList.ListFieldIndex := FListFields.IndexOf(FListField);\r\n // FDataList.ListSource := FListLink.DataSource;\r\n FDataList.FTree.DataSource := FListLink.DataSource;\r\n { FDataList.FTree.FullExpand;\r\n FDataList.FTree.FullCollapse;\r\n FDataList.FTree.DataChanged; }\r\n FDataList.SetValue(FListLink.DataSet.Lookup(FKeyFieldName, FKeyValue, FMasterField));\r\n\r\n // FDataList.KeyValue := KeyValue;\r\n\r\n P := Parent.ClientToScreen(Point(Left, Top));\r\n Y := P.Y + Height;\r\n if Y + FDataList.Height > Screen.Height then\r\n Y := P.Y - FDataList.Height;\r\n case FDropDownAlign of\r\n daRight: Dec(P.X, FDataList.Width - Width);\r\n daCenter: Dec(P.X, (FDataList.Width - Width) div 2);\r\n end;\r\n// FDataList.Left := P.X;\r\n// FDataList.Top := P.Y;\r\n P.Y := Y;\r\n FListVisible := True;\r\n FDataList.Show(P);\r\n// FDataList.Visible := True;\r\n// SetWindowPos(FDataList.Handle, HWND_TOP, P.X, Y, 0, 0,\r\n// SWP_NOSIZE or SWP_NOACTIVATE or SWP_SHOWWINDOW);\r\n\r\n if FullExpand then\r\n FDataList.FTree.FullExpand;\r\n\r\n Repaint;\r\n end;\r\nend;\r\n\r\nprocedure TJvDBLookupTreeViewCombo.KeyDown(var Key: Word; Shift: TShiftState);\r\nvar\r\n Delta: Integer;\r\nbegin\r\n inherited KeyDown(Key, Shift);\r\n if FListActive and ((Key = VK_UP) or (Key = VK_DOWN)) then\r\n if ssAlt in Shift then\r\n begin\r\n if FListVisible then\r\n CloseUp(True)\r\n else\r\n DropDown;\r\n Key := 0;\r\n end\r\n else\r\n if not FListVisible then\r\n begin\r\n if not LocateKey then\r\n FListLink.DataSet.First\r\n else\r\n begin\r\n if Key = VK_UP then\r\n Delta := -1\r\n else\r\n Delta := 1;\r\n FListLink.DataSet.MoveBy(Delta);\r\n end;\r\n SelectKeyValue(FKeyField.Value);\r\n Key := 0;\r\n end;\r\n if (Key <> 0) and FListVisible then\r\n // FDataList.KeyDown(Key, Shift);\r\n SendMessage(FDataList.FTree.Handle, WM_KEYDOWN, Key, 0);\r\nend;\r\n\r\nprocedure TJvDBLookupTreeViewCombo.KeyPress(var Key: Char);\r\nbegin\r\n inherited KeyPress(Key);\r\n if FListVisible then\r\n if Word(Key) in [VK_RETURN, VK_ESCAPE] then\r\n CloseUp(Word(Key) = VK_RETURN)\r\n else\r\n FDataList.KeyPress(Key)\r\n else\r\n ProcessSearchKey(Key);\r\nend;\r\n\r\nprocedure TJvDBLookupTreeViewCombo.MouseDown(Button: TMouseButton; Shift: TShiftState;\r\n X, Y: Integer);\r\nbegin\r\n if Button = mbLeft then\r\n begin\r\n SetFocus;\r\n if not FFocused then\r\n Exit;\r\n if FListVisible then\r\n CloseUp(False)\r\n else\r\n if FListActive then\r\n begin\r\n MouseCapture := True;\r\n FTracking := True;\r\n TrackButton(X, Y);\r\n DropDown;\r\n end;\r\n end;\r\n inherited MouseDown(Button, Shift, X, Y);\r\nend;\r\n\r\nprocedure TJvDBLookupTreeViewCombo.MouseMove(Shift: TShiftState; X, Y: Integer);\r\nvar\r\n ListPos: TPoint;\r\n MousePos: TSmallPoint;\r\nbegin\r\n if FTracking then\r\n begin\r\n TrackButton(X, Y);\r\n if FListVisible then\r\n begin\r\n ListPos := FDataList.ScreenToClient(ClientToScreen(Point(X, Y)));\r\n if PtInRect(FDataList.ClientRect, ListPos) then\r\n begin\r\n StopTracking;\r\n MousePos := PointToSmallPoint(ListPos);\r\n SendMessage(FDataList.FTree.Handle, WM_LBUTTONDOWN, 0, {$IFDEF RTL230_UP}PointToLParam{$ELSE}LPARAM{$ENDIF RTL230_UP}(MousePos));\r\n Exit;\r\n end;\r\n end;\r\n end;\r\n inherited MouseMove(Shift, X, Y);\r\nend;\r\n\r\nprocedure TJvDBLookupTreeViewCombo.MouseUp(Button: TMouseButton; Shift: TShiftState;\r\n X, Y: Integer);\r\nbegin\r\n StopTracking;\r\n inherited MouseUp(Button, Shift, X, Y);\r\nend;\r\n\r\nprocedure TJvDBLookupTreeViewCombo.StopTracking;\r\nbegin\r\n if FTracking then\r\n begin\r\n TrackButton(-1, -1);\r\n FTracking := False;\r\n MouseCapture := False;\r\n end;\r\nend;\r\n\r\nprocedure TJvDBLookupTreeViewCombo.TrackButton(X, Y: Integer);\r\nvar\r\n NewState: Boolean;\r\nbegin\r\n Repaint;\r\n NewState := PtInRect(Rect(ClientWidth - FButtonWidth, 0, ClientWidth,\r\n ClientHeight), Point(X, Y));\r\n if FPressed <> NewState then\r\n begin\r\n FPressed := NewState;\r\n Repaint;\r\n end;\r\nend;\r\n\r\nprocedure TJvDBLookupTreeViewCombo.CMCtl3DChanged(var Msg: TMessage);\r\nbegin\r\n RecreateWnd;\r\n Height := 0;\r\n inherited;\r\nend;\r\n\r\nprocedure TJvDBLookupTreeViewCombo.FontChanged;\r\nbegin\r\n inherited FontChanged;\r\n Height := 0;\r\nend;\r\n\r\nprocedure TJvDBLookupTreeViewCombo.CMGetDataLink(var Msg: TMessage);\r\nbegin\r\n Msg.Result := LRESULT(FDataLink);\r\nend;\r\n\r\nprocedure TJvDBLookupTreeViewCombo.WMCancelMode(var Msg: TMessage);\r\nbegin\r\n StopTracking;\r\n inherited;\r\nend;\r\n\r\nprocedure TJvDBLookupTreeViewCombo.CMCancelMode(var Msg: TCMCancelMode);\r\nbegin\r\n if (Msg.Sender <> Self) and (Msg.Sender <> FDataList) and\r\n ((FDataList <> nil) and\r\n not FDataList.ContainsControl(Msg.Sender)) then\r\n PopupCloseUp(FDataList, False);\r\nend;\r\n\r\nprocedure TJvDBLookupTreeViewCombo.PopupCloseUp(Sender: TObject;\r\n Accept: Boolean);\r\nvar\r\n AValue: Variant;\r\nbegin\r\n if (FDataList <> nil) and FListVisible then\r\n begin\r\n if GetCapture <> 0 then\r\n SendMessage(GetCapture, WM_CANCELMODE, 0, 0);\r\n AValue := FDataList.GetValue;\r\n FDataList.Hide;\r\n try\r\n try\r\n if CanFocus then\r\n SetFocus;\r\n except\r\n { ignore exceptions }\r\n end;\r\n// SetDirectInput(DirectInput);\r\n Invalidate;\r\n finally\r\n FListVisible := False;\r\n end;\r\n end;\r\nend;\r\n\r\n//=== { TJvTreePopupDataList } ===============================================\r\n\r\nconstructor TJvTreePopupDataList.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n// ControlStyle := ControlStyle + [csNoDesignVisible, csReplicatable];\r\n// TabStop := False;\r\n FTree := TJvPopupTree.Create(Self);\r\n FTree.Parent := Self;\r\n FTree.Align := alClient;\r\n FTree.ReadOnly := True;\r\n FTree.BorderStyle := bsNone;\r\n FTree.HideSelection := False;\r\n FTree.TabStop := False;\r\nend;\r\n\r\ndestructor TJvTreePopupDataList.Destroy;\r\nbegin\r\n FTree.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJvTreePopupDataList.GetPopupText: string;\r\nbegin\r\n Result := GetValue;\r\nend;\r\n\r\nfunction TJvTreePopupDataList.GetValue: Variant;\r\nbegin\r\n if FTree.Selected <> nil then\r\n// Result := (FTree.Selected as TJvDBTreeNode).MasterValue\r\n Result := FTree.DataSource.DataSet.Lookup(FTree.MasterField,\r\n (FTree.Selected as TJvDBTreeNode).MasterValue, (Owner as TJvDBLookupControl).KeyField)\r\n else\r\n Result := Null;\r\nend;\r\n\r\nprocedure TJvTreePopupDataList.SetValue(const Value: Variant);\r\nbegin\r\n FTree.SelectNode(Value);\r\nend;\r\n\r\n//=== { TJvPopupTree } =======================================================\r\n\r\n // Jean-Luc Mattei\r\n // jlucm dott club-internet att fr\r\nconst\r\n NM_CUSTOMDRAW = (NM_FIRST - 12);\r\n CDDS_PREPAINT = $000000001;\r\n CDRF_NOTIFYITEMDRAW = $00000020;\r\n CDDS_ITEM = $000010000;\r\n CDDS_ITEMPREPAINT = (CDDS_ITEM or CDDS_PREPAINT);\r\n CDIS_SELECTED = $0001;\r\n\r\ntype\r\n PNMCustomDrawInfo = ^TNMCustomDrawInfo;\r\n TNMCustomDrawInfo = record\r\n hdr: TNMHdr;\r\n dwDrawStage: DWORD;\r\n hdc: HDC;\r\n rc: TRect;\r\n dwItemSpec: {$IFDEF RTL230_UP}DWORD_PTR{$ELSE}Longint{$ENDIF TRL230_UP}; // this is control specific, but it's how to specify an item. valid only with CDDS_ITEM bit set\r\n uItemState: UINT;\r\n lItemlParam: LPARAM;\r\n end;\r\n\r\nprocedure TJvPopupTree.CNNotify(var Msg: TWMNotify);\r\nbegin\r\n with Msg.NMHdr^ do\r\n case code of\r\n NM_CUSTOMDRAW:\r\n begin\r\n with PNMCustomDrawInfo(Pointer(Msg.NMHdr))^ do\r\n begin\r\n if (dwDrawStage and CDDS_PREPAINT) = CDDS_PREPAINT then\r\n Msg.Result := CDRF_NOTIFYITEMDRAW;\r\n if (dwDrawStage and CDDS_ITEMPREPAINT) = CDDS_ITEMPREPAINT then\r\n begin\r\n if (uItemState and CDIS_SELECTED) <> 0 then\r\n begin\r\n SetTextColor(hdc, ColorToRGB(clHighlightText));\r\n SetBkColor(hdc, ColorToRGB(clHighlight));\r\n end;\r\n Msg.Result := CDRF_NOTIFYITEMDRAW;\r\n end;\r\n end;\r\n end;\r\n else\r\n inherited;\r\n end;\r\nend;\r\n\r\nprocedure TJvPopupTree.FocusSet(PrevWnd: THandle);\r\nbegin\r\n inherited FocusSet(PrevWnd);\r\n (Owner.Owner as TJvDBLookupTreeViewCombo).SetFocus;\r\nend;\r\n\r\nprocedure TJvPopupTree.DblClick;\r\nbegin\r\n (Owner.Owner as TJvDBLookupTreeViewCombo).CloseUp(True);\r\nend;\r\n\r\n//=== { TJvDBLookupTreeView } ================================================\r\n\r\ntype\r\n TJvDBLookupTreeViewTree = class(TJvDBTreeView)\r\n private\r\n procedure DataScrolled; override;\r\n procedure DataChanged; override;\r\n procedure Change2(Node: TTreeNode); override;\r\n procedure DefaultHandler(var Message); override;\r\n end;\r\n\r\nconstructor TJvDBLookupTreeView.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FBorderStyle := bsSingle;\r\n FTree := TJvDBLookupTreeViewTree.Create(Self);\r\n FTree.Parent := Self;\r\n Width := FTree.Width;\r\n Height := FTree.Height;\r\n FTree.Align := alClient;\r\n FTree.ReadOnly := True;\r\n FTree.BorderStyle := bsNone;\r\n FTree.HideSelection := False;\r\n// FTree.TabStop := False;\r\nend;\r\n\r\ndestructor TJvDBLookupTreeView.Destroy;\r\nbegin\r\n FTree.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvDBLookupTreeView.CreateParams(var Params: TCreateParams);\r\nbegin\r\n inherited CreateParams(Params);\r\n with Params do\r\n if FBorderStyle = bsSingle then\r\n if Ctl3D then\r\n ExStyle := ExStyle or WS_EX_CLIENTEDGE\r\n else\r\n Style := Style or WS_BORDER;\r\nend;\r\n\r\nprocedure TJvDBLookupTreeView.SetBorderStyle(Value: TBorderStyle);\r\nbegin\r\n if FBorderStyle <> Value then\r\n begin\r\n FBorderStyle := Value;\r\n RecreateWnd;\r\n end;\r\nend;\r\n\r\nfunction TJvDBLookupTreeView.GetMasterField: string;\r\nbegin\r\n Result := FTree.MasterField;\r\nend;\r\n\r\nprocedure TJvDBLookupTreeView.SetMasterField(Value: string);\r\nbegin\r\n FTree.MasterField := Value;\r\nend;\r\n\r\nfunction TJvDBLookupTreeView.GetDetailField: string;\r\nbegin\r\n Result := FTree.DetailField;\r\nend;\r\n\r\nprocedure TJvDBLookupTreeView.SetDetailField(Value: string);\r\nbegin\r\n FTree.DetailField := Value;\r\nend;\r\n\r\nfunction TJvDBLookupTreeView.GetIconField: string;\r\nbegin\r\n Result := FTree.IconField;\r\nend;\r\n\r\nprocedure TJvDBLookupTreeView.SetIconField(const Value: string);\r\nbegin\r\n FTree.IconField := Value;\r\nend;\r\n\r\nfunction TJvDBLookupTreeView.GetStartMasterValue: string;\r\nbegin\r\n Result := FTree.StartMasterValue;\r\nend;\r\n\r\nprocedure TJvDBLookupTreeView.SetStartMasterValue(Value: string);\r\nbegin\r\n FTree.StartMasterValue := Value;\r\nend;\r\n\r\nprocedure TJvDBLookupTreeView.ListLinkActiveChanged;\r\nbegin\r\n inherited ListLinkActiveChanged;\r\n FTree.DataSource := ListSource;\r\n FTree.ItemField := ListField;\r\nend;\r\n\r\nprocedure TJvDBLookupTreeView.KeyValueChanged;\r\nbegin\r\n InKeyValueChanged := True;\r\n try\r\n TJvDBLookupTreeViewTree(FTree).SelectNode(FKeyValue);\r\n finally\r\n InKeyValueChanged := False;\r\n end;\r\nend;\r\n\r\nprocedure TJvDBLookupTreeView.FocusSet(PrevWnd: THandle);\r\nbegin\r\n FTree.SetFocus;\r\nend;\r\n\r\n{** Tree}\r\n\r\nfunction TJvDBLookupTreeView.GetShowButtons: Boolean;\r\nbegin\r\n Result := FTree.ShowButtons;\r\nend;\r\n\r\nfunction TJvDBLookupTreeView.GetShowLines: Boolean;\r\nbegin\r\n Result := FTree.ShowLines;\r\nend;\r\n\r\nfunction TJvDBLookupTreeView.GetShowRoot: Boolean;\r\nbegin\r\n Result := FTree.ShowRoot;\r\nend;\r\n\r\nfunction TJvDBLookupTreeView.GetReadOnly: Boolean;\r\nbegin\r\n Result := FTree.ReadOnly;\r\nend;\r\n\r\nfunction TJvDBLookupTreeView.GetRightClickSelect: Boolean;\r\nbegin\r\n Result := FTree.RightClickSelect;\r\nend;\r\n\r\nfunction TJvDBLookupTreeView.GetHideSelection: Boolean;\r\nbegin\r\n Result := FTree.HideSelection;\r\nend;\r\n\r\nfunction TJvDBLookupTreeView.GetIndent: Integer;\r\nbegin\r\n Result := FTree.Indent;\r\nend;\r\n\r\nprocedure TJvDBLookupTreeView.SetShowButtons(Value: Boolean);\r\nbegin\r\n FTree.ShowButtons := Value;\r\nend;\r\n\r\nprocedure TJvDBLookupTreeView.SetShowLines(Value: Boolean);\r\nbegin\r\n FTree.ShowLines := Value;\r\nend;\r\n\r\nprocedure TJvDBLookupTreeView.SetShowRoot(Value: Boolean);\r\nbegin\r\n FTree.ShowRoot := Value;\r\nend;\r\n\r\nprocedure TJvDBLookupTreeView.SetReadOnly(Value: Boolean);\r\nbegin\r\n FTree.ReadOnly := Value;\r\nend;\r\n\r\nprocedure TJvDBLookupTreeView.SetRightClickSelect(Value: Boolean);\r\nbegin\r\n FTree.RightClickSelect := Value;\r\nend;\r\n\r\nprocedure TJvDBLookupTreeView.SetHideSelection(Value: Boolean);\r\nbegin\r\n FTree.HideSelection := Value;\r\nend;\r\n\r\nprocedure TJvDBLookupTreeView.SetIndent(Value: Integer);\r\nbegin\r\n FTree.Indent := Value;\r\nend;\r\n\r\n{ Translate properties }\r\n\r\nfunction TJvDBLookupTreeView.GetAutoExpand: Boolean;\r\nbegin\r\n Result := FTree.AutoExpand;\r\nend;\r\n\r\nfunction TJvDBLookupTreeView.GetChangeDelay: Integer;\r\nbegin\r\n Result := FTree.ChangeDelay;\r\nend;\r\n\r\nfunction TJvDBLookupTreeView.GetHotTrack: Boolean;\r\nbegin\r\n Result := FTree.HotTrack;\r\nend;\r\n\r\nfunction TJvDBLookupTreeView.GetOnCustomDraw: TTVCustomDrawEvent;\r\nbegin\r\n Result := FTree.OnCustomDraw;\r\nend;\r\n\r\nfunction TJvDBLookupTreeView.GetOnCustomDrawItem: TTVCustomDrawItemEvent;\r\nbegin\r\n Result := FTree.OnCustomDrawItem;\r\nend;\r\n\r\nfunction TJvDBLookupTreeView.GetOnGetImageIndex: TTVExpandedEvent;\r\nbegin\r\n Result := FTree.OnGetImageIndex;\r\nend;\r\n\r\nfunction TJvDBLookupTreeView.GetRowSelect: Boolean;\r\nbegin\r\n Result := FTree.RowSelect;\r\nend;\r\n\r\nfunction TJvDBLookupTreeView.GetToolTips: Boolean;\r\nbegin\r\n Result := FTree.ToolTips;\r\nend;\r\n\r\nprocedure TJvDBLookupTreeView.SetAutoExpand(const Value: Boolean);\r\nbegin\r\n FTree.AutoExpand := Value;\r\nend;\r\n\r\nprocedure TJvDBLookupTreeView.SetChangeDelay(const Value: Integer);\r\nbegin\r\n FTree.ChangeDelay := Value;\r\nend;\r\n\r\nprocedure TJvDBLookupTreeView.SetHotTrack(const Value: Boolean);\r\nbegin\r\n FTree.HotTrack := Value;\r\nend;\r\n\r\nprocedure TJvDBLookupTreeView.SetOnCustomDraw(const Value: TTVCustomDrawEvent);\r\nbegin\r\n FTree.OnCustomDraw := Value;\r\nend;\r\n\r\nprocedure TJvDBLookupTreeView.SetOnCustomDrawItem(const Value: TTVCustomDrawItemEvent);\r\nbegin\r\n FTree.OnCustomDrawItem := Value;\r\nend;\r\n\r\nprocedure TJvDBLookupTreeView.SetOnGetImageIndex(const Value: TTVExpandedEvent);\r\nbegin\r\n FTree.OnGetImageIndex := Value;\r\nend;\r\n\r\nprocedure TJvDBLookupTreeView.SetRowSelect(const Value: Boolean);\r\nbegin\r\n FTree.RowSelect := Value;\r\nend;\r\n\r\nprocedure TJvDBLookupTreeView.SetToolTips(const Value: Boolean);\r\nbegin\r\n FTree.ToolTips := Value;\r\nend;\r\n\r\n{# Translate properties }\r\n\r\n//=== { TJvDBLookupTreeViewTree } ============================================\r\n\r\nprocedure TJvDBLookupTreeViewTree.DataScrolled;\r\nbegin\r\nend;\r\n\r\nprocedure TJvDBLookupTreeViewTree.DataChanged;\r\nbegin\r\n inherited DataChanged;\r\nend;\r\n\r\nprocedure TJvDBLookupTreeViewTree.Change2(Node: TTreeNode);\r\nbegin\r\n with Owner as TJvDBLookupTreeView do\r\n if not InKeyValueChanged then\r\n begin\r\n FListLink.DataSet.Locate(MasterField, (Node as TJvDBTreeNode).MasterValue, []);\r\n SelectKeyValue(FKeyField.Value);\r\n KeyValueChanged;\r\n end;\r\nend;\r\n\r\nprocedure TJvDBLookupTreeViewTree.DefaultHandler(var Message);\r\nbegin\r\n inherited DefaultHandler(Message);\r\n with TMessage(Message) do\r\n case Msg of\r\n WM_KEYDOWN, WM_KEYUP, WM_CHAR, WM_LBUTTONDOWN, WM_LBUTTONUP,\r\n WM_RBUTTONDOWN, WM_RBUTTONUP, WM_MBUTTONDOWN, WM_MBUTTONUP,\r\n WM_MOUSEMOVE:\r\n PostMessage((Owner as TWinControl).Handle, Msg, WParam, LParam);\r\n end;\r\nend;\r\n\r\nprocedure TJvDBLookupTreeViewCombo.FocusKilled(NextWnd: THandle);\r\nbegin\r\n if (Handle <> NextWnd) and (FDataList.Handle <> NextWnd) and\r\n (FDataList.FTree.Handle <> NextWnd) then\r\n CloseUp(False);\r\n\r\n inherited FocusKilled(NextWnd);\r\nend;\r\n\r\n{added by zelen}\r\n{$IFDEF JVCLThemesEnabled}\r\n\r\nprocedure TJvDBLookupTreeViewCombo.MouseEnter(Control: TControl);\r\nbegin\r\n if csDesigning in ComponentState then\r\n Exit;\r\n inherited MouseEnter(Control);\r\n {Windows XP themes use hot track states, hence we have to update the drop down button.}\r\n if ThemeServices.{$IFDEF RTL230_UP}Enabled{$ELSE}ThemesEnabled{$ENDIF RTL230_UP} and not MouseOver and not (csDesigning in ComponentState) then\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvDBLookupTreeViewCombo.MouseLeave(Control: TControl);\r\nbegin\r\n if csDesigning in ComponentState then\r\n Exit;\r\n if ThemeServices.{$IFDEF RTL230_UP}Enabled{$ELSE}ThemesEnabled{$ENDIF RTL230_UP} and MouseOver then\r\n Invalidate;\r\n inherited MouseLeave(Control);\r\nend;\r\n\r\n{$ENDIF JVCLThemesEnabled}\r\n{/added by zelen}\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvDBPasswordDialogDoa.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvDBPasswordDialogDoa.pas, released on 2006-07-21.\r\n\r\nThe Initial Developer of the Original Code is Jens Fudickar\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvDBPasswordDialogDoa.pas 13104 2011-09-07 06:50:43Z obones $\r\n\r\nunit JvDBPasswordDialogDoa;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Classes, Menus,\r\n Oracle,\r\n JvBaseDBPasswordDialog;\r\n\r\ntype\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvDBDoaPasswordDialog = class(TJvBaseDBPasswordDialog)\r\n private\r\n function GetSession: TOracleSession;\r\n procedure SetSession(const Value: TOracleSession); reintroduce;\r\n protected\r\n function ChangePasswordInSession(NewPassword: string): Boolean; override;\r\n function GetPasswordFromSession: string; override;\r\n public\r\n published\r\n property Session: TOracleSession read GetSession write SetSession;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvDBPasswordDialogDoa.pas $';\r\n Revision: '$Revision: 13104 $';\r\n Date: '$Date: 2011-09-07 08:50:43 +0200 (mer. 07 sept. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n SysUtils, ExtCtrls, ComCtrls, StdCtrls, Types;\r\n\r\nfunction TJvDBDoaPasswordDialog.ChangePasswordInSession(NewPassword: string): Boolean;\r\nbegin\r\n Result := False;\r\n if Assigned(Session) then\r\n begin\r\n TOracleSession(Session).SetPassword(NewPassword);\r\n Session.LogonPassword := NewPassword;\r\n Result := True;\r\n end;\r\nend;\r\n\r\nfunction TJvDBDoaPasswordDialog.GetPasswordFromSession: string;\r\nbegin\r\n Result := Session.LogonPassword;\r\nend;\r\n\r\nfunction TJvDBDoaPasswordDialog.GetSession: TOracleSession;\r\nbegin\r\n if (inherited Session) is TOracleSession then\r\n Result := TOracleSession(inherited Session)\r\n else\r\n Result := nil;\r\nend;\r\n\r\nprocedure TJvDBDoaPasswordDialog.SetSession(const Value: TOracleSession);\r\nbegin\r\n inherited SetSession(Value);\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend." }, { "path": "External/Jedi/Jvcl/run/JvDBPasswordDialogOdac.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvDBPasswordDialogOdac.pas, released on 2006-07-21.\r\n\r\nThe Initial Developer of the Original Code is Jens Fudickar\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvDBPasswordDialogOdac.pas 13371 2012-06-23 15:46:57Z jfudickar $\r\n\r\nunit JvDBPasswordDialogOdac;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n {$IFDEF USE_3RDPARTY_DEVART_ODAC}\r\n Classes,\r\n Ora, dbaccess,\r\n {$ENDIF USE_3RDPARTY_DEVART_ODAC}\r\n JvBaseDBPasswordDialog;\r\n\r\n{$IFDEF USE_3RDPARTY_DEVART_ODAC}\r\ntype\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvDBOdacPasswordDialog = class(TJvBaseDBPasswordDialog)\r\n private\r\n function GetSession: TCustomDAConnection;\r\n procedure SetSession(const Value: TCustomDAConnection); reintroduce;\r\n protected\r\n function ChangePasswordInSession(NewPassword: string): Boolean; override;\r\n function GetPasswordFromSession: string; override;\r\n public\r\n published\r\n property Session: TCustomDAConnection read GetSession write SetSession;\r\n end;\r\n{$ENDIF USE_3RDPARTY_DEVART_ODAC}\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvDBPasswordDialogOdac.pas $';\r\n Revision: '$Revision: 13371 $';\r\n Date: '$Date: 2012-06-23 17:46:57 +0200 (sam. 23 juin 2012) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\n{$IFDEF USE_3RDPARTY_DEVART_ODAC}\r\nuses\r\n SysUtils, Types;\r\n\r\nfunction TJvDBOdacPasswordDialog.ChangePasswordInSession(NewPassword: string): Boolean;\r\nbegin\r\n Result := False;\r\n if Assigned(Session) then\r\n begin\r\n if Session is TOraSession then\r\n TOraSession(Session).ChangePassword(NewPassword)\r\n else\r\n Session.ExecSQL('ALTER USER ' + Session.Username + ' IDENTIFIED BY ' + NewPassword, []);\r\n Session.Password := NewPassword;\r\n Result := True;\r\n end;\r\nend;\r\n\r\nfunction TJvDBOdacPasswordDialog.GetPasswordFromSession: string;\r\nbegin\r\n Result := Session.Password;\r\nend;\r\n\r\nfunction TJvDBOdacPasswordDialog.GetSession: TCustomDAConnection;\r\nbegin\r\n if (inherited Session) is TCustomDAConnection then\r\n Result := TCustomDAConnection(inherited Session)\r\n else\r\n Result := nil;\r\nend;\r\n\r\nprocedure TJvDBOdacPasswordDialog.SetSession(const Value: TCustomDAConnection);\r\nbegin\r\n inherited SetSession(Value);\r\nend;\r\n{$ENDIF USE_3RDPARTY_DEVART_ODAC}\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend." }, { "path": "External/Jedi/Jvcl/run/JvDBPasswordDialogUniDac.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvDBPasswordDialogOdac.pas, released on 2006-07-21.\r\n\r\nThe Initial Developer of the Original Code is Jens Fudickar\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvDBPasswordDialogOdac.pas 13371 2012-06-23 15:46:57Z jfudickar $\r\n\r\nunit JvDBPasswordDialogUniDac;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n {$IFDEF USE_3RDPARTY_DEVART_UNIDAC}\r\n Classes,\r\n uni, dbaccess,\r\n {$ENDIF USE_3RDPARTY_DEVART_UNIDAC}\r\n JvBaseDBPasswordDialog;\r\n\r\n{$IFDEF USE_3RDPARTY_DEVART_UNIDAC}\r\ntype\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvDBOdacPasswordDialog = class(TJvBaseDBPasswordDialog)\r\n private\r\n function GetConnection: TUniConnection;\r\n procedure SetConnection(const Value: TUniConnection); reintroduce;\r\n protected\r\n function ChangePasswordInSession(NewPassword: string): Boolean; override;\r\n function GetPasswordFromSession: string; override;\r\n public\r\n published\r\n property Connection: TUniConnection read GetConnection write SetConnection;\r\n end;\r\n{$ENDIF USE_3RDPARTY_DEVART_UNIDAC}\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/trunk/jvcl/run/JvDBPasswordDialogOdac.pas $';\r\n Revision: '$Revision: 13371 $';\r\n Date: '$Date: 2012-06-23 17:46:57 +0200 (Sa, 23 Jun 2012) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\n{$IFDEF USE_3RDPARTY_DEVART_UNIDAC}\r\nuses\r\n SysUtils, Types;\r\n\r\nfunction TJvDBOdacPasswordDialog.ChangePasswordInSession(NewPassword: string): Boolean;\r\nbegin\r\n Result := False;\r\n if Assigned(Connection) then\r\n begin\r\n if Connection is TOraSession then\r\n TOraSession(Connection).ChangePassword(NewPassword)\r\n else\r\n Connection.ExecSQL('ALTER USER ' + Connection.Username + ' IDENTIFIED BY ' + NewPassword, []);\r\n Connection.Password := NewPassword;\r\n Result := True;\r\n end;\r\nend;\r\n\r\nfunction TJvDBOdacPasswordDialog.GetPasswordFromSession: string;\r\nbegin\r\n Result := Connection.Password;\r\nend;\r\n\r\nfunction TJvDBOdacPasswordDialog.GetConnection: TUniConnection;\r\nbegin\r\n if (inherited Connection) is TCustomDAConnection then\r\n Result := TCustomDAConnection(inherited Connection)\r\n else\r\n Result := nil;\r\nend;\r\n\r\nprocedure TJvDBOdacPasswordDialog.SetConnection(const Value: TUniConnection);\r\nbegin\r\n inherited SetConnection(Value);\r\nend;\r\n{$ENDIF USE_3RDPARTY_DEVART_UNIDAC}\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend." }, { "path": "External/Jedi/Jvcl/run/JvDBProgressBar.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvDBProgressBar.PAS, released on 2001-02-28.\r\n\r\nThe Initial Developer of the Original Code is Sbastien Buysse [sbuysse att buypin dott com]\r\nPortions created by Sbastien Buysse are Copyright (C) 2001 Sbastien Buysse.\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\nMichael Beck [mbeck att bigfoot dott com].\r\nPeter Thornqvist[peter3 at sourceforge dot net]\r\n Moved here from JvProgressBar to support D& Personal\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvDBProgressBar.pas 13104 2011-09-07 06:50:43Z obones $\r\n\r\nunit JvDBProgressBar;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Classes, DB, DBCtrls,\r\n JvProgressBar;\r\n\r\ntype\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvDBProgressBar = class(TJvProgressBar)\r\n private\r\n FDataLink: TFieldDataLink;\r\n function GetDataField: string;\r\n procedure SetDataField(Value: string);\r\n function GetDataSource: TDataSource;\r\n procedure SetDataSource(Value: TDataSource);\r\n function GetField: TField;\r\n public\r\n procedure DataChange(Sender: TObject);\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n property Field: TField read GetField;\r\n published\r\n property DataField: string read GetDataField write SetDataField;\r\n property DataSource: TDataSource read GetDataSource write SetDataSource;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvDBProgressBar.pas $';\r\n Revision: '$Revision: 13104 $';\r\n Date: '$Date: 2011-09-07 08:50:43 +0200 (mer. 07 sept. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n SysUtils;\r\n\r\nconstructor TJvDBProgressBar.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FDataLink := TFieldDataLink.Create;\r\n FDataLink.Control := Self;\r\n FDataLink.OnDataChange := DataChange;\r\nend;\r\n\r\ndestructor TJvDBProgressBar.Destroy;\r\nbegin\r\n FreeAndNil(FDataLink);\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJvDBProgressBar.GetDataField: string;\r\nbegin\r\n Result := FDataLink.FieldName;\r\nend;\r\n\r\nprocedure TJvDBProgressBar.SetDataField(Value: string);\r\nbegin\r\n FDataLink.FieldName := Value;\r\nend;\r\n\r\nfunction TJvDBProgressBar.GetDataSource: TDataSource;\r\nbegin\r\n Result := FDataLink.DataSource;\r\nend;\r\n\r\nprocedure TJvDBProgressBar.SetDataSource(Value: TDataSource);\r\nbegin\r\n FDataLink.DataSource := Value;\r\nend;\r\n\r\nfunction TJvDBProgressBar.GetField: TField;\r\nbegin\r\n Result := FDataLink.Field;\r\nend;\r\n\r\nprocedure TJvDBProgressBar.DataChange(Sender: TObject);\r\nbegin\r\n if (FDataLink.Field <> nil) and (FDataLink.Field is TNumericField) then\r\n Position := FDataLink.Field.AsInteger\r\n else\r\n Position := Min;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvDBQueryParamsForm.dfm", "content": "object JvQueryParamsDialog: TJvQueryParamsDialog\r\n Left = 210\r\n Top = 119\r\n ActiveControl = ParamList\r\n BorderIcons = [biSystemMenu]\r\n Caption = 'Query parameters'\r\n ClientHeight = 179\r\n ClientWidth = 354\r\n Color = clBtnFace\r\n Font.Charset = DEFAULT_CHARSET\r\n Font.Color = clWindowText\r\n Font.Height = -11\r\n Font.Name = 'MS Sans Serif'\r\n Font.Style = []\r\n Icon.Data = {\r\n 0000010001001010100001001000280100001600000028000000100000002000\r\n 00000100040000000000C0000000000000000000000000000000000000000000\r\n 0000000080000080000000808000800000008000800080800000C0C0C0008080\r\n 80000000FF0000FF000000FFFF00FF000000FF00FF00FFFF0000FFFFFF000000\r\n 00000000000000000BBBB0000000000BB000BB000000000BB0000B000000000B\r\n BB000BB00000000BBB000BB00000000000000BB00000000000000BB000000000\r\n 00000BB00000000000000BB00000000000000BB00000000000000BB000000000\r\n 00000BB0000000000000BBBB00000000000BBBBBB0000000000000000000FFFF\r\n 0000F87F0000E73F0000E7BF0000E39F0000E39F0000FF9F0000FF9F0000FF9F\r\n 0000FF9F0000FF9F0000FF9F0000FF9F0000FF0F0000FE070000FFFF0000}\r\n OldCreateOrder = True\r\n Position = poScreenCenter\r\n DesignSize = (\r\n 354\r\n 179)\r\n PixelsPerInch = 96\r\n TextHeight = 13\r\n object GroupBox1: TGroupBox\r\n Left = 9\r\n Top = 3\r\n Width = 328\r\n Height = 109\r\n Anchors = [akLeft, akTop, akRight, akBottom]\r\n Caption = 'Define Parameters'\r\n TabOrder = 0\r\n DesignSize = (\r\n 328\r\n 109)\r\n object Label1: TLabel\r\n Left = 8\r\n Top = 20\r\n Width = 80\r\n Height = 13\r\n Caption = '&Parameter name:'\r\n FocusControl = ParamList\r\n end\r\n object Label2: TLabel\r\n Left = 135\r\n Top = 66\r\n Width = 30\r\n Height = 13\r\n Anchors = [akTop, akRight]\r\n Caption = '&Value:'\r\n FocusControl = ParamValue\r\n end\r\n object Label3: TLabel\r\n Left = 135\r\n Top = 40\r\n Width = 49\r\n Height = 13\r\n Anchors = [akTop, akRight]\r\n Caption = '&Data type:'\r\n FocusControl = TypeList\r\n end\r\n object ParamValue: TEdit\r\n Left = 200\r\n Top = 62\r\n Width = 121\r\n Height = 21\r\n Anchors = [akTop, akRight]\r\n TabOrder = 2\r\n OnExit = ParamValueExit\r\n end\r\n object NullValue: TCheckBox\r\n Left = 135\r\n Top = 112\r\n Width = 82\r\n Height = 17\r\n Anchors = [akTop, akRight]\r\n Caption = '&Null Value'\r\n TabOrder = 3\r\n OnClick = NullValueClick\r\n end\r\n object TypeList: TComboBox\r\n Left = 200\r\n Top = 36\r\n Width = 121\r\n Height = 21\r\n Style = csDropDownList\r\n Anchors = [akTop, akRight]\r\n Sorted = True\r\n TabOrder = 1\r\n OnChange = TypeListChange\r\n end\r\n object ParamList: TListBox\r\n Left = 8\r\n Top = 36\r\n Width = 113\r\n Height = 59\r\n Anchors = [akLeft, akTop, akRight, akBottom]\r\n ItemHeight = 13\r\n Sorted = True\r\n TabOrder = 0\r\n OnClick = ParamListChange\r\n end\r\n end\r\n object OkBtn: TButton\r\n Left = 46\r\n Top = 119\r\n Width = 75\r\n Height = 25\r\n Anchors = [akLeft, akBottom]\r\n Caption = 'OK'\r\n Default = True\r\n ModalResult = 1\r\n TabOrder = 1\r\n OnClick = OkBtnClick\r\n end\r\n object CancelBtn: TButton\r\n Left = 139\r\n Top = 119\r\n Width = 75\r\n Height = 25\r\n Anchors = [akLeft, akBottom]\r\n Cancel = True\r\n Caption = 'Cancel'\r\n ModalResult = 2\r\n TabOrder = 2\r\n end\r\n object HelpBtn: TButton\r\n Left = 262\r\n Top = 119\r\n Width = 75\r\n Height = 25\r\n Anchors = [akRight, akBottom]\r\n Caption = '&Help'\r\n TabOrder = 3\r\n OnClick = HelpBtnClick\r\n end\r\nend\r\n" }, { "path": "External/Jedi/Jvcl/run/JvDBQueryParamsForm.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvQBndDlg.PAS, released on 2002-07-04.\r\n\r\nThe Initial Developers of the Original Code are: Fedor Koshevnikov, Igor Pavluk and Serge Korolev\r\nCopyright (c) 1997, 1998 Fedor Koshevnikov, Igor Pavluk and Serge Korolev\r\nCopyright (c) 2001,2002 SGB Software\r\nAll Rights Reserved.\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvDBQueryParamsForm.pas 13145 2011-11-02 21:15:19Z ahuser $\r\n\r\nunit JvDBQueryParamsForm;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n SysUtils, Classes, Controls, Forms, StdCtrls, DB,\r\n JvComponent;\r\n\r\ntype\r\n TJvQueryParamsDialog = class(TJvForm)\r\n GroupBox1: TGroupBox;\r\n Label1: TLabel;\r\n ParamValue: TEdit;\r\n Label2: TLabel;\r\n NullValue: TCheckBox;\r\n OkBtn: TButton;\r\n CancelBtn: TButton;\r\n Label3: TLabel;\r\n TypeList: TComboBox;\r\n ParamList: TListBox;\r\n HelpBtn: TButton;\r\n procedure ParamListChange(Sender: TObject);\r\n procedure TypeListChange(Sender: TObject);\r\n procedure ParamValueExit(Sender: TObject);\r\n procedure NullValueClick(Sender: TObject);\r\n procedure OkBtnClick(Sender: TObject);\r\n procedure HelpBtnClick(Sender: TObject);\r\n private\r\n InitList: TParams;\r\n PressedOK: Boolean;\r\n InValueExit: Boolean;\r\n InParamChange: Boolean;\r\n procedure CheckValue;\r\n procedure Edit;\r\n procedure Unbind;\r\n end;\r\n\r\nfunction EditQueryParams(DataSet: TDataSet; List: TParams;\r\n AHelpContext: THelpContext = 0): Boolean;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvDBQueryParamsForm.pas $';\r\n Revision: '$Revision: 13145 $';\r\n Date: '$Date: 2011-11-02 22:15:19 +0100 (mer. 02 nov. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n JvDBUtils,\r\n JvTypes, JvResources;\r\n\r\n{$R *.dfm}\r\n\r\nvar\r\n FieldTypes: array [TFieldType] of string;\r\n\r\nprocedure ClearFieldTypes;\r\nvar\r\n I: TFieldType;\r\nbegin\r\n for I := Low(TFieldType) to High(TFieldType) do\r\n FieldTypes[I] := '';\r\nend;\r\n\r\nprocedure FillFieldTypes;\r\nvar\r\n ParamString: string;\r\n I: Integer;\r\n J: TFieldType;\r\nbegin\r\n ClearFieldTypes;\r\n ParamString := RsDataTypes;\r\n J := Low(TFieldType);\r\n I := 1;\r\n while I <= Length(ParamString) do\r\n begin\r\n FieldTypes[J] := ExtractFieldNameEx(ParamString, I);\r\n Inc(J);\r\n end;\r\nend;\r\n\r\nfunction GetFieldType(const Value: string): TFieldType;\r\nbegin\r\n for Result := Low(TFieldType) to High(TFieldType) do\r\n if (FieldTypes[Result] <> '') and (FieldTypes[Result] = Value) then\r\n Exit;\r\n Result := ftUnknown;\r\nend;\r\n\r\nprocedure DoneQBind;\r\nbegin\r\n ClearFieldTypes;\r\nend;\r\n\r\nfunction EditQueryParams(DataSet: TDataSet; List: TParams;\r\n AHelpContext: THelpContext): Boolean;\r\nbegin\r\n with TJvQueryParamsDialog.Create(Application) do\r\n try\r\n HelpContext := AHelpContext;\r\n if HelpContext = 0 then\r\n begin\r\n HelpBtn.Visible := False;\r\n OkBtn.Left := OkBtn.Left + HelpBtn.Width div 2;\r\n CancelBtn.Left := CancelBtn.Left + HelpBtn.Width div 2;\r\n end;\r\n if csDesigning in DataSet.ComponentState then\r\n Caption := Format(RsParamEditor,\r\n {$IFDEF BCB}\r\n [DataSet.Owner.Name, '->', DataSet.Name]);\r\n {$ELSE}\r\n [DataSet.Owner.Name, '.', DataSet.Name]);\r\n {$ENDIF BCB}\r\n InitList := List;\r\n Edit;\r\n Result := PressedOK;\r\n finally\r\n Free;\r\n end;\r\nend;\r\n\r\nprocedure TJvQueryParamsDialog.Edit;\r\nvar\r\n I: Integer;\r\n J: TFieldType;\r\nbegin\r\n for J := Low(TFieldType) to High(TFieldType) do\r\n if (FieldTypes[J] <> '') and (FieldTypes[J] <> '') then\r\n TypeList.Items.Add(FieldTypes[J]);\r\n if InitList.Count = 0 then\r\n begin\r\n ParamValue.Enabled := False;\r\n NullValue.Enabled := False;\r\n TypeList.Enabled := False;\r\n ParamList.Enabled := False;\r\n end\r\n else\r\n begin\r\n for I := 0 to InitList.Count - 1 do\r\n if ParamList.Items.IndexOf(InitList[I].Name) = -1 then\r\n ParamList.Items.Add(InitList[I].Name);\r\n ParamList.ItemIndex := 0;\r\n ParamListChange(Self);\r\n ActiveControl := OkBtn;\r\n end;\r\n PressedOK := ShowModal = mrOk;\r\nend;\r\n\r\nprocedure TJvQueryParamsDialog.ParamListChange(Sender: TObject);\r\nbegin\r\n InParamChange := True;\r\n try\r\n with InitList.ParamByName(ParamList.Items[ParamList.ItemIndex]) do\r\n begin\r\n if (FieldTypes[DataType] <> '') and (FieldTypes[DataType] <> '') then\r\n begin\r\n with TypeList do\r\n ItemIndex := Items.IndexOf(FieldTypes[DataType]);\r\n if Bound then\r\n ParamValue.Text := AsString\r\n else\r\n ParamValue.Text := '';\r\n end\r\n else\r\n begin\r\n TypeList.ItemIndex := -1;\r\n ParamValue.Text := '';\r\n end;\r\n NullValue.Checked := IsNull;\r\n end;\r\n finally\r\n InParamChange := False;\r\n end;\r\nend;\r\n\r\nprocedure TJvQueryParamsDialog.TypeListChange(Sender: TObject);\r\nbegin\r\n with InitList.ParamByName(ParamList.Items[ParamList.ItemIndex]) do\r\n begin\r\n DataType := GetFieldType(TypeList.Text);\r\n ParamValue.Text := '';\r\n NullValue.Checked := IsNull;\r\n end;\r\nend;\r\n\r\nprocedure TJvQueryParamsDialog.ParamValueExit(Sender: TObject);\r\nbegin\r\n if InValueExit or (ActiveControl = CancelBtn) then\r\n Exit;\r\n InValueExit := True;\r\n try\r\n if ParamValue.Text <> '' then\r\n NullValue.Checked := False;\r\n if (TypeList.Text = '') and TypeList.CanFocus then\r\n begin\r\n TypeList.SetFocus;\r\n raise EJVCLException.CreateRes(@RsEInvalidParamFieldType);\r\n end;\r\n if ParamValue.Text = '' then\r\n with InitList.ParamByName(ParamList.Items[ParamList.ItemIndex]) do\r\n begin\r\n if NullValue.Checked then\r\n Clear\r\n else\r\n Unbind;\r\n end\r\n else\r\n CheckValue;\r\n finally\r\n InValueExit := False;\r\n end;\r\nend;\r\n\r\nprocedure TJvQueryParamsDialog.CheckValue;\r\nbegin\r\n try\r\n with InitList.ParamByName(ParamList.Items[ParamList.ItemIndex]) do\r\n begin\r\n if (DataType in [ftDate, ftTime, ftDateTime]) and\r\n SameText(ParamValue.Text, 'Now') then\r\n begin\r\n case DataType of\r\n ftDate:\r\n Text := DateToStr(SysUtils.Date);\r\n ftTime:\r\n Text := TimeToStr(SysUtils.Time);\r\n ftDateTime:\r\n Text := DateTimeToStr(SysUtils.Now);\r\n end;\r\n end\r\n else\r\n Text := ParamValue.Text;\r\n end;\r\n except\r\n with ParamValue do\r\n begin\r\n if CanFocus then\r\n SetFocus;\r\n SelectAll;\r\n end;\r\n raise;\r\n end;\r\nend;\r\n\r\nprocedure TJvQueryParamsDialog.Unbind;\r\nbegin\r\n with InitList.ParamByName(ParamList.Items[ParamList.ItemIndex]) do\r\n begin\r\n AsInteger := 1;\r\n DataType := GetFieldType(TypeList.Text);\r\n Bound := False;\r\n end;\r\nend;\r\n\r\nprocedure TJvQueryParamsDialog.NullValueClick(Sender: TObject);\r\nbegin\r\n if InParamChange then\r\n Exit;\r\n if NullValue.Checked then\r\n with InitList.ParamByName(ParamList.Items[ParamList.ItemIndex]) do\r\n begin\r\n Clear;\r\n ParamValue.Text := '';\r\n end\r\n else\r\n Unbind;\r\nend;\r\n\r\nprocedure TJvQueryParamsDialog.OkBtnClick(Sender: TObject);\r\nbegin\r\n if not TypeList.Enabled then\r\n Exit;\r\n try\r\n ParamValueExit(Sender);\r\n except\r\n ModalResult := mrNone;\r\n raise;\r\n end;\r\nend;\r\n\r\nprocedure TJvQueryParamsDialog.HelpBtnClick(Sender: TObject);\r\nbegin\r\n Application.HelpContext(HelpContext);\r\nend;\r\n\r\ninitialization\r\n {$IFDEF UNITVERSIONING}\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n {$ENDIF UNITVERSIONING}\r\n FillFieldTypes;\r\n\r\nfinalization\r\n DoneQBind;\r\n {$IFDEF UNITVERSIONING}\r\n UnregisterUnitVersion(HInstance);\r\n {$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvDBRadioPanel.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvDBRadioPanel.pas, released .\r\n\r\nThe Initial Developer of the Original Code is Steve Paris [paris.steve att tourisme dott gouv dott qc dott ca]\r\nPortions created by Steve Paris are Copyright (C) 2003 Steve Paris.\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nDescription:\r\n Works like TDBRadioGroup except haves the look of a TPanel. Major code come\r\n from TDBRadioGroup.\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvDBRadioPanel.pas 13104 2011-09-07 06:50:43Z obones $\r\n\r\nunit JvDBRadioPanel;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows,\r\n Messages,\r\n Classes, Controls, StdCtrls, DB, DBCtrls,\r\n JvExtComponent;\r\n\r\ntype\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvDBRadioPanel = class(TJvCustomPanel)\r\n private\r\n FButtons: TList;\r\n FItems: TStringList;\r\n FItemIndex: Integer;\r\n FColumns: Integer;\r\n FReading: Boolean;\r\n FUpdating: Boolean;\r\n FDataLink: TFieldDataLink;\r\n FValue: string;\r\n FValues: TStringList;\r\n FInSetValue: Boolean;\r\n FOnChange: TNotifyEvent;\r\n procedure DataChange(Sender: TObject);\r\n procedure UpdateData(Sender: TObject);\r\n function GetDataField: string;\r\n function GetDataSource: TDataSource;\r\n function GetField: TField;\r\n function GetReadOnly: Boolean;\r\n function GetItems: TStrings;\r\n function GetValues: TStrings;\r\n function GetButtonValue(Index: Integer): string;\r\n procedure SetDataField(const Value: string);\r\n procedure SetDataSource(Value: TDataSource);\r\n procedure SetReadOnly(Value: Boolean);\r\n procedure SetValue(const Value: string);\r\n procedure SetItems(Value: TStrings);\r\n procedure SetValues(Value: TStrings);\r\n function GetButtons(Index: Integer): TRadioButton;\r\n procedure ArrangeButtons;\r\n procedure ButtonClick(Sender: TObject);\r\n procedure ItemsChange(Sender: TObject);\r\n procedure SetButtonCount(Value: Integer);\r\n procedure SetColumns(Value: Integer);\r\n procedure SetItemIndex(Value: Integer);\r\n procedure UpdateButtons;\r\n procedure CMGetDataLink(var Msg: TMessage); message CM_GETDATALINK;\r\n protected\r\n procedure BoundsChanged; override;\r\n procedure DoExit; override;\r\n procedure EnabledChanged; override;\r\n procedure FontChanged; override;\r\n procedure Change; dynamic;\r\n procedure Click; override;\r\n procedure KeyPress(var Key: Char); override;\r\n procedure Notification(AComponent: TComponent;\r\n Operation: TOperation); override;\r\n procedure Loaded; override;\r\n procedure ReadState(Reader: TReader); override;\r\n function CanModify: Boolean; virtual;\r\n property DataLink: TFieldDataLink read FDataLink;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n\r\n procedure GetChildren(Proc: TGetChildProc; Root: TComponent); override; // public in D2009\r\n\r\n procedure FlipChildren(AllLevels: Boolean); override;\r\n function ExecuteAction(Action: TBasicAction): Boolean; override;\r\n function UpdateAction(Action: TBasicAction): Boolean; override;\r\n function UseRightToLeftAlignment: Boolean; override;\r\n property Buttons[Index: Integer]: TRadioButton read GetButtons;\r\n property Field: TField read GetField;\r\n property ItemIndex: Integer read FItemIndex write SetItemIndex default -1;\r\n property Value: string read FValue write SetValue;\r\n published\r\n property Align;\r\n property Anchors;\r\n property BiDiMode;\r\n// property Caption;\r\n property BevelInner;\r\n property BevelOuter;\r\n property Color;\r\n property Columns: Integer read FColumns write SetColumns default 1;\r\n property Constraints;\r\n property DataField: string read GetDataField write SetDataField;\r\n property DataSource: TDataSource read GetDataSource write SetDataSource;\r\n property DragCursor;\r\n property DragKind;\r\n property DragMode;\r\n property Enabled;\r\n property Font;\r\n property Items: TStrings read GetItems write SetItems;\r\n property ParentBiDiMode;\r\n property ParentColor;\r\n property ParentFont;\r\n property ParentShowHint;\r\n property PopupMenu;\r\n property ReadOnly: Boolean read GetReadOnly write SetReadOnly default False;\r\n property ShowHint;\r\n property TabOrder;\r\n property TabStop;\r\n property Values: TStrings read GetValues write SetValues;\r\n property Visible;\r\n property OnChange: TNotifyEvent read FOnChange write FOnChange;\r\n property OnClick;\r\n property OnContextPopup;\r\n property OnDragDrop;\r\n property OnDragOver;\r\n property OnEndDock;\r\n property OnEndDrag;\r\n property OnEnter;\r\n property OnExit;\r\n property OnStartDock;\r\n property OnStartDrag;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvDBRadioPanel.pas $';\r\n Revision: '$Revision: 13104 $';\r\n Date: '$Date: 2011-09-07 08:50:43 +0200 (mer. 07 sept. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n Forms,\r\n SysUtils,\r\n {$IFNDEF COMPILER12_UP}\r\n JvJCLUtils,\r\n {$ENDIF ~COMPILER12_UP}\r\n JvConsts;\r\n\r\n//=== { TGroupButton } =======================================================\r\n\r\ntype\r\n TGroupButton = class(TRadioButton)\r\n private\r\n FInClick: Boolean;\r\n procedure CNCommand(var Msg: TWMCommand); message CN_COMMAND;\r\n protected\r\n procedure KeyDown(var Key: Word; Shift: TShiftState); override;\r\n procedure KeyPress(var Key: Char); override;\r\n public\r\n constructor InternalCreate(RadioGroup: TJvDBRadioPanel);\r\n destructor Destroy; override;\r\n end;\r\n\r\nconstructor TGroupButton.InternalCreate(RadioGroup: TJvDBRadioPanel);\r\nbegin\r\n inherited Create(RadioGroup);\r\n RadioGroup.FButtons.Add(Self);\r\n Visible := False;\r\n Enabled := RadioGroup.Enabled;\r\n ParentShowHint := False;\r\n OnClick := RadioGroup.ButtonClick;\r\n Parent := RadioGroup;\r\nend;\r\n\r\ndestructor TGroupButton.Destroy;\r\nbegin\r\n TJvDBRadioPanel(Owner).FButtons.Remove(Self);\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TGroupButton.CNCommand(var Msg: TWMCommand);\r\nbegin\r\n if not FInClick then\r\n begin\r\n FInClick := True;\r\n try\r\n if ((Msg.NotifyCode = BN_CLICKED) or\r\n (Msg.NotifyCode = BN_DOUBLECLICKED)) and\r\n TJvDBRadioPanel(Parent).CanModify then\r\n inherited;\r\n except\r\n Application.HandleException(Self);\r\n end;\r\n FInClick := False;\r\n end;\r\nend;\r\n\r\nprocedure TGroupButton.KeyPress(var Key: Char);\r\nbegin\r\n inherited KeyPress(Key);\r\n TJvDBRadioPanel(Parent).KeyPress(Key);\r\n if CharInSet(Key, [Backspace, ' ']) then\r\n begin\r\n if not TJvDBRadioPanel(Parent).CanModify then\r\n Key := #0;\r\n end;\r\nend;\r\n\r\nprocedure TGroupButton.KeyDown(var Key: Word; Shift: TShiftState);\r\nbegin\r\n inherited KeyDown(Key, Shift);\r\n TJvDBRadioPanel(Parent).KeyDown(Key, Shift);\r\nend;\r\n\r\n//=== { TDBRadioPanel } ======================================================\r\n\r\nconstructor TJvDBRadioPanel.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n// ControlStyle := [csSetCaption, csDoubleClicks, csParentBackground];\r\n ControlStyle := [csDoubleClicks {$IFDEF COMPILER7_UP}, csParentBackground {$ENDIF}];\r\n FButtons := TList.Create;\r\n FItems := TStringList.Create;\r\n FItems.OnChange := ItemsChange;\r\n FItemIndex := -1;\r\n FColumns := 1;\r\n\r\n FDataLink := TFieldDataLink.Create;\r\n FDataLink.Control := Self;\r\n FDataLink.OnDataChange := DataChange;\r\n FDataLink.OnUpdateData := UpdateData;\r\n FValues := TStringList.Create;\r\nend;\r\n\r\ndestructor TJvDBRadioPanel.Destroy;\r\nbegin\r\n FDataLink.Free;\r\n FDataLink := nil;\r\n FValues.Free;\r\n\r\n SetButtonCount(0);\r\n FItems.OnChange := nil;\r\n FItems.Free;\r\n FButtons.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvDBRadioPanel.ArrangeButtons;\r\nvar\r\n ButtonsPerCol, ButtonWidth, ButtonHeight, TopMargin, I: Integer;\r\n DC: HDC;\r\n SaveFont: HFont;\r\n Metrics: TTextMetric;\r\n DeferHandle: THandle;\r\n ALeft: Integer;\r\nbegin\r\n if (FButtons.Count <> 0) and not FReading then\r\n begin\r\n DC := GetDC(HWND_DESKTOP);\r\n SaveFont := SelectObject(DC, Font.Handle);\r\n GetTextMetrics(DC, Metrics);\r\n SelectObject(DC, SaveFont);\r\n ReleaseDC(HWND_DESKTOP, DC);\r\n ButtonsPerCol := (FButtons.Count + FColumns - 1) div FColumns;\r\n ButtonWidth := (Width - 10) div FColumns;\r\n ButtonHeight := Height div ButtonsPerCol;\r\n TopMargin := 0;\r\n DeferHandle := BeginDeferWindowPos(FButtons.Count);\r\n try\r\n for I := 0 to FButtons.Count - 1 do\r\n with TGroupButton(FButtons[I]) do\r\n begin\r\n BiDiMode := Self.BiDiMode;\r\n ALeft := (I div ButtonsPerCol) * ButtonWidth + 8;\r\n\r\n if UseRightToLeftAlignment then\r\n ALeft := Self.ClientWidth - ALeft - ButtonWidth;\r\n\r\n DeferHandle := DeferWindowPos(DeferHandle, Handle, 0, ALeft,\r\n (I mod ButtonsPerCol) * ButtonHeight + TopMargin,\r\n ButtonWidth, ButtonHeight,\r\n SWP_NOZORDER or SWP_NOACTIVATE);\r\n Visible := True;\r\n end;\r\n finally\r\n EndDeferWindowPos(DeferHandle);\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvDBRadioPanel.ButtonClick(Sender: TObject);\r\nbegin\r\n if not FUpdating then\r\n begin\r\n FItemIndex := FButtons.IndexOf(Sender);\r\n Changed;\r\n Click;\r\n end;\r\nend;\r\n\r\nfunction TJvDBRadioPanel.CanModify: Boolean;\r\nbegin\r\n Result := FDataLink.Edit;\r\nend;\r\n\r\nprocedure TJvDBRadioPanel.Change;\r\nbegin\r\n if Assigned(FOnChange) then\r\n FOnChange(Self);\r\nend;\r\n\r\nprocedure TJvDBRadioPanel.Click;\r\nbegin\r\n if not FInSetValue then\r\n begin\r\n inherited Click;\r\n if ItemIndex >= 0 then\r\n Value := GetButtonValue(ItemIndex);\r\n if FDataLink.Editing then\r\n FDataLink.Modified;\r\n end;\r\nend;\r\n\r\nprocedure TJvDBRadioPanel.EnabledChanged;\r\nvar\r\n I: Integer;\r\nbegin\r\n inherited EnabledChanged;\r\n for I := 0 to FButtons.Count - 1 do\r\n TGroupButton(FButtons[I]).Enabled := Enabled;\r\nend;\r\n\r\nprocedure TJvDBRadioPanel.DoExit;\r\nbegin\r\n try\r\n FDataLink.UpdateRecord;\r\n except\r\n if ItemIndex >= 0 then\r\n TRadioButton(Controls[ItemIndex]).SetFocus\r\n else\r\n TRadioButton(Controls[0]).SetFocus;\r\n raise;\r\n end;\r\n inherited DoExit;\r\nend;\r\n\r\nprocedure TJvDBRadioPanel.FontChanged;\r\nbegin\r\n inherited FontChanged;\r\n ArrangeButtons;\r\nend;\r\n\r\nprocedure TJvDBRadioPanel.CMGetDataLink(var Msg: TMessage);\r\nbegin\r\n Msg.Result := LRESULT(FDataLink);\r\nend;\r\n\r\nprocedure TJvDBRadioPanel.DataChange(Sender: TObject);\r\nbegin\r\n if FDataLink.Field <> nil then\r\n Value := FDataLink.Field.AsString\r\n else\r\n Value := '';\r\nend;\r\n\r\nfunction TJvDBRadioPanel.ExecuteAction(Action: TBasicAction): Boolean;\r\nbegin\r\n Result := inherited ExecuteAction(Action) or (DataLink <> nil) and\r\n DataLink.ExecuteAction(Action);\r\nend;\r\n\r\nprocedure TJvDBRadioPanel.FlipChildren(AllLevels: Boolean);\r\nbegin\r\n { The radio buttons are flipped using BiDiMode }\r\nend;\r\n\r\nfunction TJvDBRadioPanel.GetButtons(Index: Integer): TRadioButton;\r\nbegin\r\n Result := TRadioButton(FButtons[Index]);\r\nend;\r\n\r\nfunction TJvDBRadioPanel.GetButtonValue(Index: Integer): string;\r\nbegin\r\n if (Index < FValues.Count) and (FValues[Index] <> '') then\r\n Result := FValues[Index]\r\n else\r\n if Index < Items.Count then\r\n Result := Items[Index]\r\n else\r\n Result := '';\r\nend;\r\n\r\nprocedure TJvDBRadioPanel.GetChildren(Proc: TGetChildProc; Root: TComponent);\r\nbegin\r\nend;\r\n\r\nfunction TJvDBRadioPanel.GetDataField: string;\r\nbegin\r\n Result := FDataLink.FieldName;\r\nend;\r\n\r\nfunction TJvDBRadioPanel.GetDataSource: TDataSource;\r\nbegin\r\n Result := FDataLink.DataSource;\r\nend;\r\n\r\nfunction TJvDBRadioPanel.GetField: TField;\r\nbegin\r\n Result := FDataLink.Field;\r\nend;\r\n\r\nfunction TJvDBRadioPanel.GetReadOnly: Boolean;\r\nbegin\r\n Result := FDataLink.ReadOnly;\r\nend;\r\n\r\nprocedure TJvDBRadioPanel.ItemsChange(Sender: TObject);\r\nbegin\r\n if not FReading then\r\n begin\r\n if FItemIndex >= FItems.Count then\r\n FItemIndex := FItems.Count - 1;\r\n UpdateButtons;\r\n end;\r\nend;\r\n\r\nprocedure TJvDBRadioPanel.KeyPress(var Key: Char);\r\nbegin\r\n inherited KeyPress(Key);\r\n case Key of\r\n Backspace, ' ':\r\n FDataLink.Edit;\r\n Esc:\r\n FDataLink.Reset;\r\n end;\r\nend;\r\n\r\nprocedure TJvDBRadioPanel.Loaded;\r\nbegin\r\n inherited Loaded;\r\n ArrangeButtons;\r\nend;\r\n\r\nprocedure TJvDBRadioPanel.Notification(AComponent: TComponent;\r\n Operation: TOperation);\r\nbegin\r\n inherited Notification(AComponent, Operation);\r\n if (Operation = opRemove) and (FDataLink <> nil) and (AComponent = DataSource) then\r\n DataSource := nil;\r\nend;\r\n\r\nprocedure TJvDBRadioPanel.ReadState(Reader: TReader);\r\nbegin\r\n FReading := True;\r\n inherited ReadState(Reader);\r\n FReading := False;\r\n UpdateButtons;\r\nend;\r\n\r\nprocedure TJvDBRadioPanel.SetButtonCount(Value: Integer);\r\nbegin\r\n while FButtons.Count < Value do\r\n TGroupButton.InternalCreate(Self);\r\n while FButtons.Count > Value do\r\n TGroupButton(FButtons.Last).Free;\r\nend;\r\n\r\nprocedure TJvDBRadioPanel.SetColumns(Value: Integer);\r\nbegin\r\n if Value < 1 then\r\n Value := 1;\r\n\r\n if Value > 16 then\r\n Value := 16;\r\n\r\n if FColumns <> Value then\r\n begin\r\n FColumns := Value;\r\n ArrangeButtons;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvDBRadioPanel.SetDataField(const Value: string);\r\nbegin\r\n FDataLink.FieldName := Value;\r\nend;\r\n\r\nprocedure TJvDBRadioPanel.SetDataSource(Value: TDataSource);\r\nbegin\r\n if FDataLink.DataSource <> nil then\r\n FDataLink.DataSource.RemoveFreeNotification(Self);\r\n FDataLink.DataSource := Value;\r\n if Value <> nil then\r\n Value.FreeNotification(Self);\r\nend;\r\n\r\nprocedure TJvDBRadioPanel.SetItemIndex(Value: Integer);\r\nbegin\r\n if FReading then\r\n FItemIndex := Value\r\n else\r\n begin\r\n if Value < -1 then\r\n Value := -1;\r\n\r\n if Value >= FButtons.Count then\r\n Value := FButtons.Count - 1;\r\n\r\n if FItemIndex <> Value then\r\n begin\r\n if FItemIndex >= 0 then\r\n TGroupButton(FButtons[FItemIndex]).Checked := False;\r\n FItemIndex := Value;\r\n if FItemIndex >= 0 then\r\n TGroupButton(FButtons[FItemIndex]).Checked := True;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJvDBRadioPanel.GetItems: TStrings;\r\nbegin\r\n Result := FItems;\r\nend;\r\n\r\nprocedure TJvDBRadioPanel.SetItems(Value: TStrings);\r\nbegin\r\n FItems.Assign(Value);\r\n DataChange(Self);\r\nend;\r\n\r\nprocedure TJvDBRadioPanel.SetReadOnly(Value: Boolean);\r\nbegin\r\n FDataLink.ReadOnly := Value;\r\nend;\r\n\r\nprocedure TJvDBRadioPanel.SetValue(const Value: string);\r\nvar\r\n I, Index: Integer;\r\nbegin\r\n if FValue <> Value then\r\n begin\r\n FInSetValue := True;\r\n try\r\n Index := -1;\r\n for I := 0 to Items.Count - 1 do\r\n if Value = GetButtonValue(I) then\r\n begin\r\n Index := I;\r\n Break;\r\n end;\r\n ItemIndex := Index;\r\n finally\r\n FInSetValue := False;\r\n end;\r\n FValue := Value;\r\n Change;\r\n end;\r\nend;\r\n\r\nfunction TJvDBRadioPanel.GetValues: TStrings;\r\nbegin\r\n Result := FValues;\r\nend;\r\n\r\nprocedure TJvDBRadioPanel.SetValues(Value: TStrings);\r\nbegin\r\n FValues.Assign(Value);\r\n DataChange(Self);\r\nend;\r\n\r\nfunction TJvDBRadioPanel.UpdateAction(Action: TBasicAction): Boolean;\r\nbegin\r\n Result := inherited UpdateAction(Action) or (DataLink <> nil) and\r\n DataLink.UpdateAction(Action);\r\nend;\r\n\r\nprocedure TJvDBRadioPanel.UpdateButtons;\r\nvar\r\n I: Integer;\r\nbegin\r\n SetButtonCount(FItems.Count);\r\n for I := 0 to FButtons.Count - 1 do\r\n TGroupButton(FButtons[I]).Caption := FItems[I];\r\n\r\n if (FItemIndex >= 0) and (FItemIndex nil then\r\n FDataLink.Field.Text := Value;\r\nend;\r\n\r\nfunction TJvDBRadioPanel.UseRightToLeftAlignment: Boolean;\r\nbegin\r\n Result := inherited UseRightToLeftAlignment;\r\nend;\r\n\r\nprocedure TJvDBRadioPanel.BoundsChanged;\r\nbegin\r\n inherited BoundsChanged;\r\n ArrangeButtons;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvDBRemoteLogin.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvRemLog.PAS, released on 2002-07-04.\r\n\r\nThe Initial Developers of the Original Code are: Fedor Koshevnikov, Igor Pavluk and Serge Korolev\r\nCopyright (c) 1997, 1998 Fedor Koshevnikov, Igor Pavluk and Serge Korolev\r\nCopyright (c) 2001,2002 SGB Software\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\n Hofi\r\n\r\nLast Modified: 2004-10-07\r\n\r\nChanges:\r\n2004-10-07:\r\n * Added\r\n TJvCustomLogin\r\n property Caption to support a custom dialog Caption.\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvDBRemoteLogin.pas 13104 2011-09-07 06:50:43Z obones $\r\n\r\nunit JvDBRemoteLogin;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\n{$IFDEF JV_MIDAS}\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n SysUtils, Windows, Messages, Classes, Graphics, Controls, Forms,\r\n Dialogs, DBClient,\r\n JvLoginForm;\r\n{$ELSE}\r\n{$IFDEF UNITVERSIONING}\r\nuses\r\n JclUnitVersioning;\r\n{$ENDIF UNITVERSIONING}\r\n{$ENDIF JV_MIDAS}\r\n\r\n{$IFDEF JV_MIDAS}\r\n\r\ntype\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvDBRemoteLogin = class(TJvCustomLogin)\r\n private\r\n FRemoteServer: TCustomRemoteServer;\r\n FPrepared: Boolean;\r\n FUserName: string;\r\n FInLogin: Boolean;\r\n FOnCheckUser: TJvLoginEvent;\r\n FSaveAfterConnect: TNotifyEvent;\r\n procedure AbortConnection;\r\n procedure OkButtonClick(Sender: TObject);\r\n procedure PrepareRemoteServer;\r\n procedure UnprepareRemoteServer;\r\n procedure ServerAfterConnect(Sender: TObject);\r\n procedure SetRemoteServer(Value: TCustomRemoteServer);\r\n procedure WriteUserName(const UserName: string);\r\n function ReadUserName(const UserName: string): string;\r\n protected\r\n function DoCheckUser(const UserName, Password: string): Boolean; dynamic;\r\n function DoLogin(var UserName: string): Boolean; override;\r\n procedure Loaded; override;\r\n procedure Notification(AComponent: TComponent; Operation: TOperation); override;\r\n public\r\n destructor Destroy; override;\r\n published\r\n property RemoteServer: TCustomRemoteServer read FRemoteServer write SetRemoteServer;\r\n property Active;\r\n property AllowEmptyPassword;\r\n property AppStorage;\r\n property AppStoragePath;\r\n property AttemptNumber;\r\n property Caption;\r\n property MaxPasswordLen;\r\n property UpdateCaption;\r\n property OnCheckUser: TJvLoginEvent read FOnCheckUser write FOnCheckUser;\r\n property AfterLogin;\r\n property BeforeLogin;\r\n property OnUnlock;\r\n property OnUnlockApp;\r\n property OnIconDblClick;\r\n end;\r\n\r\n{$ENDIF JV_MIDAS}\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvDBRemoteLogin.pas $';\r\n Revision: '$Revision: 13104 $';\r\n Date: '$Date: 2011-09-07 08:50:43 +0200 (mer. 07 sept. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n IniFiles,\r\n {$IFDEF JV_MIDAS}\r\n MConnect,\r\n {$ENDIF JV_MIDAS}\r\n JvJVCLUtils, JvResources;\r\n\r\n{$IFDEF JV_MIDAS}\r\n\r\ntype\r\n TJvServer = class(TCustomRemoteServer);\r\n\r\ndestructor TJvDBRemoteLogin.Destroy;\r\nbegin\r\n UnprepareRemoteServer;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvDBRemoteLogin.Notification(AComponent: TComponent; Operation: TOperation);\r\nbegin\r\n inherited Notification(AComponent, Operation);\r\n if (Operation = opRemove) and (AComponent = RemoteServer) then\r\n RemoteServer := nil;\r\nend;\r\n\r\nprocedure TJvDBRemoteLogin.Loaded;\r\nvar\r\n Loading: Boolean;\r\nbegin\r\n Loading := csLoading in ComponentState;\r\n inherited Loaded;\r\n if not (csDesigning in ComponentState) and Loading and\r\n Assigned(FRemoteServer) then\r\n begin\r\n if not Active then\r\n PrepareRemoteServer\r\n else\r\n if not Login then\r\n TerminateApplication;\r\n end;\r\nend;\r\n\r\nprocedure TJvDBRemoteLogin.SetRemoteServer(Value: TCustomRemoteServer);\r\nbegin\r\n if FRemoteServer <> Value then\r\n begin\r\n UnprepareRemoteServer;\r\n ReplaceComponentReference(Self, Value, TComponent(FRemoteServer));\r\n if FRemoteServer <> nil then\r\n if not (csLoading in ComponentState) then\r\n PrepareRemoteServer;\r\n end;\r\nend;\r\n\r\nprocedure TJvDBRemoteLogin.PrepareRemoteServer;\r\nbegin\r\n if Assigned(FRemoteServer) and not FPrepared then\r\n with TJvServer(RemoteServer) do\r\n begin\r\n if RemoteServer is TDispatchConnection then\r\n TDispatchConnection(RemoteServer).LoginPrompt := False;\r\n FSaveAfterConnect := AfterConnect;\r\n AfterConnect := ServerAfterConnect;\r\n FPrepared := True;\r\n end;\r\nend;\r\n\r\nprocedure TJvDBRemoteLogin.UnprepareRemoteServer;\r\nbegin\r\n if Assigned(FRemoteServer) and FPrepared then\r\n with TJvServer(RemoteServer) do\r\n begin\r\n AfterConnect := FSaveAfterConnect;\r\n FPrepared := False;\r\n end;\r\nend;\r\n\r\nprocedure TJvDBRemoteLogin.OkButtonClick(Sender: TObject);\r\nvar\r\n SetCursor: Boolean;\r\nbegin\r\n with TJvLoginForm(Sender) do\r\n begin\r\n SetCursor := GetCurrentThreadID = MainThreadID;\r\n try\r\n if SetCursor then\r\n Screen.Cursor := crHourGlass;\r\n try\r\n if DoCheckUser(UserNameEdit.Text, PasswordEdit.Text) then\r\n ModalResult := mrOk\r\n else\r\n ModalResult := mrNone;\r\n finally\r\n if SetCursor then\r\n Screen.Cursor := crDefault;\r\n end;\r\n except\r\n Application.HandleException(Self);\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvDBRemoteLogin.ServerAfterConnect(Sender: TObject);\r\nvar\r\n OnGetUser: TGetUsernameEvent;\r\nbegin\r\n if Sender = FRemoteServer then\r\n begin\r\n if not FInLogin then\r\n DoBeforeLogin;\r\n with CreateLoginForm(False) do\r\n try\r\n OnOkClick := Self.OkButtonClick;\r\n FUserName := ReadUserName(FUserName);\r\n if FRemoteServer is TDispatchConnection then\r\n begin\r\n OnGetUser := TDispatchConnection(FRemoteServer).OnGetUsername;\r\n if Assigned(OnGetUser) then\r\n OnGetUser(FRemoteServer, FUserName);\r\n end;\r\n UserNameEdit.Text := FUserName;\r\n if ShowModal = mrOk then\r\n begin\r\n FUserName := UserNameEdit.Text;\r\n WriteUserName(FUserName);\r\n if not FInLogin then\r\n begin\r\n SetLoggedUser(FUserName);\r\n DoUpdateCaption;\r\n DoAfterLogin;\r\n end;\r\n end\r\n else\r\n begin\r\n AbortConnection;\r\n SysUtils.Abort;\r\n end;\r\n finally\r\n Free;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJvDBRemoteLogin.DoCheckUser(const UserName, Password: string): Boolean;\r\nbegin\r\n Result := True;\r\n if Assigned(FOnCheckUser) then\r\n FOnCheckUser(Self, UserName, Password, Result);\r\nend;\r\n\r\nprocedure TJvDBRemoteLogin.WriteUserName(const UserName: string);\r\nbegin\r\n if Assigned(AppStorage) then\r\n AppStorage.WriteString (AppStorage.ConcatPaths([AppStoragePath, RsLastLoginUserName]), UserName);\r\nend;\r\n\r\nfunction TJvDBRemoteLogin.ReadUserName(const UserName: string): string;\r\nbegin\r\n if Assigned(AppStorage) then\r\n Result := AppStorage.ReadString (AppStorage.ConcatPaths([AppStoragePath, RsLastLoginUserName]), UserName)\r\n else\r\n Result := UserName;\r\nend;\r\n\r\nprocedure TJvDBRemoteLogin.AbortConnection;\r\nvar\r\n OnAfterDisconnect, OnBeforeDisconnect: TNotifyEvent;\r\nbegin\r\n if Assigned(FRemoteServer) and TJvServer(FRemoteServer).Connected then\r\n try\r\n OnAfterDisconnect := TJvServer(FRemoteServer).AfterDisconnect;\r\n OnBeforeDisconnect := TJvServer(FRemoteServer).BeforeDisconnect;\r\n try\r\n TJvServer(FRemoteServer).AfterDisconnect := nil;\r\n TJvServer(FRemoteServer).BeforeDisconnect := nil;\r\n TJvServer(FRemoteServer).Connected := False;\r\n finally\r\n TJvServer(FRemoteServer).AfterDisconnect := OnAfterDisconnect;\r\n TJvServer(FRemoteServer).BeforeDisconnect := OnBeforeDisconnect;\r\n end;\r\n except\r\n end;\r\nend;\r\n\r\nfunction TJvDBRemoteLogin.DoLogin(var UserName: string): Boolean;\r\nbegin\r\n Result := False;\r\n if not Assigned(FRemoteServer) then\r\n Exit;\r\n PrepareRemoteServer;\r\n FUserName := UserName;\r\n try\r\n FInLogin := True;\r\n try\r\n TJvServer(FRemoteServer).Connected := True;\r\n Result := TJvServer(FRemoteServer).Connected;\r\n UserName := FUserName;\r\n FUserName := '';\r\n finally\r\n FInLogin := False;\r\n end;\r\n except\r\n Application.HandleException(Self);\r\n Result := False;\r\n FUserName := '';\r\n AbortConnection;\r\n end;\r\n if Result and Assigned(FSaveAfterConnect) then\r\n FSaveAfterConnect(FRemoteServer);\r\nend;\r\n\r\n{$ENDIF JV_MIDAS}\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvDBRichEdit.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvDBRichEd.PAS, released on 2002-07-04.\r\n\r\nThe Initial Developers of the Original Code are: Fedor Koshevnikov, Igor Pavluk and Serge Korolev\r\nCopyright (c) 1997, 1998 Fedor Koshevnikov, Igor Pavluk and Serge Korolev\r\nCopyright (c) 2001,2002 SGB Software\r\nAll Rights Reserved.\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvDBRichEdit.pas 13104 2011-09-07 06:50:43Z obones $\r\n\r\nunit JvDBRichEdit;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, Messages, RichEdit, Classes, Controls, DB, DBCtrls,\r\n JvRichEdit;\r\n\r\ntype\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvDBRichEdit = class(TJvCustomRichEdit)\r\n private\r\n FDataLink: TFieldDataLink;\r\n FUpdating: Boolean;\r\n FStateChanging: Boolean;\r\n FMemoLoaded: Boolean;\r\n FAutoDisplay: Boolean;\r\n FFocused: Boolean;\r\n FDataSave: string;\r\n FBeepOnError: Boolean;\r\n FCreatingHandle: Boolean;\r\n function GetField: TField;\r\n function GetDataField: string;\r\n function GetDataSource: TDataSource;\r\n function GetReadOnly: Boolean;\r\n procedure SetReadOnly(Value: Boolean);\r\n procedure SetDataField(const Value: string);\r\n procedure SetDataSource(Value: TDataSource);\r\n procedure SetAutoDisplay(Value: Boolean);\r\n procedure SetFocused(Value: Boolean);\r\n procedure DataChange(Sender: TObject);\r\n procedure UpdateData(Sender: TObject);\r\n procedure EditingChange(Sender: TObject);\r\n procedure CMGetDataLink(var Msg: TMessage); message CM_GETDATALINK;\r\n procedure WMLButtonDblClk(var Msg: TWMLButtonDblClk); message WM_LBUTTONDBLCLK;\r\n procedure EMSetCharFormat(var Msg: TMessage); message EM_SETCHARFORMAT;\r\n procedure EMSetParaFormat(var Msg: TMessage); message EM_SETPARAFORMAT;\r\n protected\r\n procedure WMPaste(var Msg: TMessage); message WM_PASTE;\r\n procedure WMCut(var Msg: TMessage); message WM_CUT;\r\n procedure DoEnter; override;\r\n procedure DoExit; override;\r\n procedure Change; override;\r\n function EditCanModify: Boolean; virtual;\r\n procedure Loaded; override;\r\n procedure Notification(AComponent: TComponent; Operation: TOperation); override;\r\n procedure KeyDown(var Key: Word; Shift: TShiftState); override;\r\n procedure KeyPress(var Key: Char); override;\r\n procedure SetPlainText(Value: Boolean); override;\r\n procedure CreateWnd; override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n procedure LoadMemo; virtual;\r\n procedure UpdateMemo;\r\n function ExecuteAction(Action: TBasicAction): Boolean; override;\r\n function UpdateAction(Action: TBasicAction): Boolean; override;\r\n function UseRightToLeftAlignment: Boolean; override;\r\n property Field: TField read GetField;\r\n property Lines;\r\n published\r\n property AutoDisplay: Boolean read FAutoDisplay write SetAutoDisplay default True;\r\n property BeepOnError: Boolean read FBeepOnError write FBeepOnError default True;\r\n property DataField: string read GetDataField write SetDataField;\r\n property DataSource: TDataSource read GetDataSource write SetDataSource;\r\n property AdvancedTypography;\r\n property Align;\r\n property Alignment;\r\n property AllowObjects;\r\n property AllowInPlace;\r\n property AutoAdvancedTypography;\r\n property AutoURLDetect;\r\n property AutoVerbMenu;\r\n property BevelEdges;\r\n property BevelInner;\r\n property BevelKind default bkNone;\r\n property BevelOuter;\r\n property BorderStyle;\r\n property Color;\r\n property DragCursor;\r\n property DragMode;\r\n property Enabled;\r\n property Font;\r\n property HideSelection;\r\n property HideScrollBars;\r\n property Anchors;\r\n property BiDiMode;\r\n property Constraints;\r\n property DragKind;\r\n property ParentBiDiMode;\r\n property ImeMode;\r\n property ImeName;\r\n property LangOptions;\r\n property MaxLength;\r\n property ParentColor;\r\n property ParentFont;\r\n property ParentShowHint;\r\n property PlainText;\r\n property PopupMenu;\r\n property ReadOnly: Boolean read GetReadOnly write SetReadOnly default False;\r\n property ScrollBars;\r\n property ShowHint;\r\n property SelectionBar;\r\n property StreamFormat;\r\n property StreamMode;\r\n property TabOrder;\r\n property TabStop default True;\r\n property Title;\r\n property UndoLimit;\r\n property Visible;\r\n property WantReturns;\r\n property WantTabs;\r\n property WordSelection;\r\n property WordWrap;\r\n property Zoom;\r\n property OnChange;\r\n property OnClick;\r\n property OnDblClick;\r\n property OnDragDrop;\r\n property OnDragOver;\r\n property OnEndDrag;\r\n property OnEnter;\r\n property OnExit;\r\n property OnKeyDown;\r\n property OnKeyPress;\r\n property OnKeyUp;\r\n property OnMouseDown;\r\n property OnMouseMove;\r\n property OnMouseUp;\r\n property OnResizeRequest;\r\n property OnSelectionChange;\r\n property OnProtectChange; { obsolete }\r\n property OnProtectChangeEx;\r\n property OnSaveClipboard;\r\n property OnStartDrag;\r\n property OnContextPopup;\r\n property OnMouseWheel;\r\n property OnMouseWheelDown;\r\n property OnMouseWheelUp;\r\n property OnEndDock;\r\n property OnStartDock;\r\n property OnTextNotFound;\r\n property OnCloseFindDialog;\r\n property OnURLClick;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvDBRichEdit.pas $';\r\n Revision: '$Revision: 13104 $';\r\n Date: '$Date: 2011-09-07 08:50:43 +0200 (mer. 07 sept. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n SysUtils,\r\n {$IFNDEF COMPILER12_UP}\r\n JvJCLUtils,\r\n {$ENDIF ~COMPILER12_UP}\r\n JvConsts;\r\n\r\nconstructor TJvDBRichEdit.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n inherited ReadOnly := True;\r\n FAutoDisplay := True;\r\n FBeepOnError := True;\r\n FDataLink := TFieldDataLink.Create;\r\n FDataLink.Control := Self;\r\n FDataLink.OnDataChange := DataChange;\r\n FDataLink.OnEditingChange := EditingChange;\r\n FDataLink.OnUpdateData := UpdateData;\r\nend;\r\n\r\nprocedure TJvDBRichEdit.CreateWnd;\r\nbegin\r\n FCreatingHandle := True;\r\n try\r\n inherited CreateWnd;\r\n finally\r\n FCreatingHandle := False;\r\n end;\r\nend;\r\n\r\ndestructor TJvDBRichEdit.Destroy;\r\nbegin\r\n FDataLink.Free;\r\n FDataLink := nil;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvDBRichEdit.Loaded;\r\nbegin\r\n inherited Loaded;\r\n if csDesigning in ComponentState then\r\n DataChange(Self);\r\nend;\r\n\r\nprocedure TJvDBRichEdit.Notification(AComponent: TComponent; Operation: TOperation);\r\nbegin\r\n inherited Notification(AComponent, Operation);\r\n if (Operation = opRemove) and (FDataLink <> nil) and (AComponent = DataSource) then\r\n DataSource := nil;\r\nend;\r\n\r\nfunction TJvDBRichEdit.UseRightToLeftAlignment: Boolean;\r\nbegin\r\n Result := DBUseRightToLeftAlignment(Self, Field);\r\nend;\r\n\r\nfunction TJvDBRichEdit.EditCanModify: Boolean;\r\nbegin\r\n FStateChanging := True;\r\n try\r\n Result := FDataLink.Editing;\r\n if not Result and Assigned(FDataLink.Field) then\r\n try\r\n if FDataLink.Field.IsBlob then\r\n FDataSave := FDataLink.Field.AsString;\r\n Result := FDataLink.Edit;\r\n finally\r\n FDataSave := '';\r\n end;\r\n finally\r\n FStateChanging := False;\r\n end;\r\nend;\r\n\r\nprocedure TJvDBRichEdit.KeyDown(var Key: Word; Shift: TShiftState);\r\nbegin\r\n inherited KeyDown(Key, Shift);\r\n if FMemoLoaded then\r\n begin\r\n if (Key in [VK_DELETE, VK_BACK, VK_CLEAR]) or\r\n ((Key = VK_INSERT) and (ssShift in Shift)) or\r\n (((Key = Ord('V')) or (Key = Ord('X'))) and (ssCtrl in Shift)) then\r\n EditCanModify;\r\n end\r\n else\r\n Key := 0;\r\nend;\r\n\r\nprocedure TJvDBRichEdit.KeyPress(var Key: Char);\r\nbegin\r\n inherited KeyPress(Key);\r\n if FMemoLoaded then\r\n begin\r\n if CharInSet(Key, [#32..#255]) and (FDataLink.Field <> nil) and\r\n not FDataLink.Field.IsValidChar(Key) then\r\n begin\r\n if BeepOnError then\r\n Beep;\r\n Key := #0;\r\n end;\r\n case Key of\r\n CtrlH, CtrlI, CtrlJ, CtrlM, CtrlV, CtrlX, #32..#255:\r\n EditCanModify;\r\n Esc:\r\n FDataLink.Reset;\r\n end;\r\n end\r\n else\r\n begin\r\n if Key = Chr(VK_RETURN) then\r\n LoadMemo;\r\n if FMemoLoaded then\r\n Key := #0;\r\n end;\r\nend;\r\n\r\nprocedure TJvDBRichEdit.Change;\r\nbegin\r\n if FMemoLoaded then\r\n FDataLink.Modified;\r\n FMemoLoaded := True;\r\n inherited Change;\r\nend;\r\n\r\nfunction TJvDBRichEdit.GetDataSource: TDataSource;\r\nbegin\r\n Result := FDataLink.DataSource;\r\nend;\r\n\r\nprocedure TJvDBRichEdit.SetDataSource(Value: TDataSource);\r\nbegin\r\n if FDataLink.DataSource <> nil then\r\n FDataLink.DataSource.RemoveFreeNotification(Self);\r\n FDataLink.DataSource := Value;\r\n if Value <> nil then\r\n Value.FreeNotification(Self);\r\nend;\r\n\r\nfunction TJvDBRichEdit.GetDataField: string;\r\nbegin\r\n Result := FDataLink.FieldName;\r\nend;\r\n\r\nprocedure TJvDBRichEdit.SetDataField(const Value: string);\r\nbegin\r\n FDataLink.FieldName := Value;\r\nend;\r\n\r\nfunction TJvDBRichEdit.GetReadOnly: Boolean;\r\nbegin\r\n Result := FDataLink.ReadOnly;\r\nend;\r\n\r\nprocedure TJvDBRichEdit.SetReadOnly(Value: Boolean);\r\nbegin\r\n FDataLink.ReadOnly := Value;\r\nend;\r\n\r\nfunction TJvDBRichEdit.GetField: TField;\r\nbegin\r\n Result := FDataLink.Field;\r\nend;\r\n\r\nprocedure TJvDBRichEdit.LoadMemo;\r\nbegin\r\n if FMemoLoaded or (FDataLink.Field = nil) or not FDataLink.Field.IsBlob then\r\n Exit;\r\n FUpdating := True;\r\n try\r\n try\r\n Lines.Assign(FDataLink.Field);\r\n FMemoLoaded := True;\r\n except\r\n on E: EOutOfResources do\r\n Lines.Text := Format('(%s)', [E.Message]);\r\n end;\r\n EditingChange(Self);\r\n finally\r\n FUpdating := False;\r\n end;\r\nend;\r\n\r\nprocedure TJvDBRichEdit.DataChange(Sender: TObject);\r\nbegin\r\n if FDataLink.Field = nil then\r\n begin\r\n if csDesigning in ComponentState then\r\n Text := Name\r\n else\r\n Text := '';\r\n FMemoLoaded := False;\r\n end\r\n else\r\n if FDataLink.Field.IsBlob then\r\n begin\r\n if AutoDisplay or (FDataLink.Editing and FMemoLoaded) then\r\n begin\r\n { Check if the data has changed since we read it the first time }\r\n if FStateChanging and (FDataSave <> '') and\r\n (FDataSave = FDataLink.Field.AsString) then\r\n Exit;\r\n FMemoLoaded := False;\r\n LoadMemo;\r\n end\r\n else\r\n begin\r\n Text := Format('(%s)', [FDataLink.Field.DisplayLabel]);\r\n FMemoLoaded := False;\r\n end;\r\n end\r\n else\r\n if FDataLink.CanModify then\r\n begin\r\n if not FStateChanging then\r\n begin\r\n inherited SetPlainText(True);\r\n if FFocused then\r\n Text := FDataLink.Field.Text\r\n else\r\n Text := FDataLink.Field.DisplayText;\r\n FMemoLoaded := True;\r\n end;\r\n end\r\n else\r\n begin\r\n inherited SetPlainText(True);\r\n Text := FDataLink.Field.DisplayText;\r\n FMemoLoaded := True;\r\n end;\r\n if HandleAllocated then\r\n RedrawWindow(Handle, nil, 0, RDW_INVALIDATE or RDW_ERASE or RDW_FRAME);\r\nend;\r\n\r\nprocedure TJvDBRichEdit.EditingChange(Sender: TObject);\r\nbegin\r\n inherited ReadOnly := not (FDataLink.Editing and FMemoLoaded);\r\nend;\r\n\r\nprocedure TJvDBRichEdit.UpdateData(Sender: TObject);\r\nbegin\r\n if (FDataLink.Field <> nil) and FDataLink.Field.CanModify and not ReadOnly then\r\n begin\r\n if FDataLink.Field.IsBlob then\r\n FDataLink.Field.Assign(Lines)\r\n else\r\n FDataLink.Field.AsString := Text;\r\n end;\r\nend;\r\n\r\nprocedure TJvDBRichEdit.SetFocused(Value: Boolean);\r\nbegin\r\n if FFocused <> Value then\r\n begin\r\n FFocused := Value;\r\n if not Assigned(FDataLink.Field) or not FDataLink.Field.IsBlob then\r\n FDataLink.Reset;\r\n end;\r\nend;\r\n\r\nprocedure TJvDBRichEdit.DoEnter;\r\nbegin\r\n SetFocused(True);\r\n inherited DoEnter;\r\n if SysLocale.FarEast and FDataLink.CanModify then\r\n inherited ReadOnly := False;\r\nend;\r\n\r\nprocedure TJvDBRichEdit.DoExit;\r\nbegin\r\n try\r\n if Modified then\r\n FDataLink.UpdateRecord;\r\n except\r\n if CanFocus then\r\n SetFocus;\r\n raise;\r\n end;\r\n SetFocused(False);\r\n inherited DoExit;\r\nend;\r\n\r\nprocedure TJvDBRichEdit.SetAutoDisplay(Value: Boolean);\r\nbegin\r\n if Value <> FAutoDisplay then\r\n begin\r\n FAutoDisplay := Value;\r\n if FAutoDisplay then\r\n LoadMemo;\r\n end;\r\nend;\r\n\r\nprocedure TJvDBRichEdit.SetPlainText(Value: Boolean);\r\nbegin\r\n if PlainText <> Value then\r\n begin\r\n inherited SetPlainText(Value);\r\n if FMemoLoaded then\r\n FDataLink.Reset;\r\n end;\r\nend;\r\n\r\nprocedure TJvDBRichEdit.WMLButtonDblClk(var Msg: TWMLButtonDblClk);\r\nbegin\r\n if not FMemoLoaded then\r\n LoadMemo\r\n else\r\n inherited;\r\nend;\r\n\r\nprocedure TJvDBRichEdit.WMCut(var Msg: TMessage);\r\nbegin\r\n EditCanModify;\r\n inherited;\r\nend;\r\n\r\nprocedure TJvDBRichEdit.WMPaste(var Msg: TMessage);\r\nbegin\r\n EditCanModify;\r\n inherited;\r\nend;\r\n\r\nprocedure TJvDBRichEdit.CMGetDataLink(var Msg: TMessage);\r\nbegin\r\n Msg.Result := LRESULT(FDataLink);\r\nend;\r\n\r\nprocedure TJvDBRichEdit.UpdateMemo;\r\nbegin\r\n if FDataLink.Editing and FMemoLoaded then\r\n UpdateData(Self);\r\nend;\r\n\r\nfunction TJvDBRichEdit.ExecuteAction(Action: TBasicAction): Boolean;\r\nbegin\r\n Result := inherited ExecuteAction(Action) or (FDataLink <> nil) and\r\n FDataLink.ExecuteAction(Action);\r\nend;\r\n\r\nfunction TJvDBRichEdit.UpdateAction(Action: TBasicAction): Boolean;\r\nbegin\r\n Result := inherited UpdateAction(Action) or (FDataLink <> nil) and\r\n FDataLink.UpdateAction(Action);\r\nend;\r\n\r\nprocedure TJvDBRichEdit.EMSetCharFormat(var Msg: TMessage);\r\nbegin\r\n if not FCreatingHandle and FMemoLoaded then\r\n if not FUpdating then\r\n if EditCanModify then\r\n Change;\r\n inherited;\r\nend;\r\n\r\nprocedure TJvDBRichEdit.EMSetParaFormat(var Msg: TMessage);\r\nbegin\r\n if not FCreatingHandle and FMemoLoaded then\r\n if not FUpdating then\r\n if EditCanModify then\r\n Change;\r\n inherited;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvDBSearchComboBox.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvDBSearchComboBox.pas, released on 2004-02-28.\r\n\r\nThe Initial Developer of the Original Code is Lionel Reynaud\r\nPortions created by Sbastien Buysse are Copyright (C) 2004 Lionel Reynaud.\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nDescription:\r\n DB Component to find record with ComboBox\r\n Free modified and corrected component TDBViewCombo from ???\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvDBSearchComboBox.pas 13168 2011-11-13 10:02:20Z ahuser $\r\n\r\nunit JvDBSearchComboBox;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\n{$IFDEF COMPILER12}\r\n {$DEFINE COMPILER_GENERICS_WORKAROUND}\r\n{$ENDIF COMPILER12}\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n {$IFDEF SUPPORTS_GENERICS}\r\n Generics.Collections,\r\n {$ENDIF SUPPORTS_GENERICS}\r\n Windows, Classes, Controls, DB,\r\n JvCombobox;\r\n\r\ntype\r\n TJvDBCustomSearchComboBox = class;\r\n\r\n TJvSearchComboBoxLink = class(TDataLink)\r\n private\r\n FJvDBSearchComboBox: TJvDBCustomSearchComboBox;\r\n FDataFieldName: string;\r\n FDataField: TField;\r\n FWasEdited: Boolean;\r\n FReading: Boolean;\r\n procedure SetDataFieldName(const Value: string);\r\n procedure SetDataField;\r\n protected\r\n procedure ActiveChanged; override;\r\n procedure DataSetScrolled(Distance: Integer); override;\r\n procedure DataSetChanged; override;\r\n procedure EditingChanged; override;\r\n public\r\n constructor Create(AJvDBSearchComboBox: TJvDBCustomSearchComboBox);\r\n property DataField: TField read FDataField;\r\n property DataFieldName: string read FDataFieldName write SetDataFieldName;\r\n end;\r\n\r\n {$IFDEF SUPPORTS_GENERICS}\r\n {$IFDEF COMPILER_GENERICS_WORKAROUND}\r\n // Workaround for QC 70845: Compiler crashes when generating *.lib file with generics in unit\r\n TBookmarkList = class(TList)\r\n protected\r\n function GetItem(Index: Integer): TBookmark;\r\n procedure Notify(Ptr: Pointer; Action: TListNotification); override;\r\n public\r\n property Items[Index: Integer]: TBookmark read GetItem; default;\r\n end;\r\n {$ELSE}\r\n TBookmarkList = TList;\r\n {$ENDIF COMPILER_GENERICS_WORKAROUND}\r\n {$ELSE}\r\n TBookmarkList = TList;\r\n {$ENDIF SUPPORTS_GENERICS}\r\n\r\n TJvDBCustomSearchComboBox = class(TJvCustomComboBox)\r\n private\r\n FDataLink: TJvSearchComboBoxLink;\r\n FChanging: Boolean;\r\n FDataResult: string;\r\n\r\n // Mantis 4622: TBookmark are TBytes in D12+ and if we store them inside a\r\n // simple TList, the compiler will not see the references to the array of\r\n // bytes, hence will finalize each one of them while we keep them in our\r\n // list as simple pointers.\r\n // To avoid this, we could have fiddled with the reference counting\r\n // ourselves, but we used the new more elegant way of using the generics\r\n // which makes the compiler do all the work for us.\r\n FBookmarks: TBookmarkList;\r\n\r\n function GetDataField: string;\r\n function GetDataSource: TDataSource;\r\n procedure SetDataField(const Value: string);\r\n procedure SetDataSource(Value: TDataSource);\r\n protected\r\n procedure Scroll(Distance: Integer);\r\n procedure ReadList;\r\n procedure ClearList;\r\n procedure Select; override;\r\n procedure Notification(Component: TComponent; Operation: TOperation); override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n function GetResult: Variant;\r\n procedure Refresh;\r\n property ItemIndex;\r\n published\r\n property DataField: string read GetDataField write SetDataField;\r\n property DataResult: string read FDataResult write FDataResult;\r\n property DataSource: TDataSource read GetDataSource write SetDataSource;\r\n end;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvDBSearchComboBox = class(TJvDBCustomSearchComboBox)\r\n published\r\n property Align;\r\n property Anchors;\r\n property AutoComplete default True;\r\n property AutoSize;\r\n property AutoDropDown default False;\r\n property BevelEdges;\r\n property BevelInner;\r\n property BevelKind default bkNone;\r\n property BevelOuter;\r\n property BiDiMode;\r\n property CharCase;\r\n property Constraints;\r\n property Style;\r\n property Color;\r\n property DragMode;\r\n property DragCursor;\r\n property DropDownCount;\r\n property Enabled;\r\n property Flat;\r\n property ParentFlat;\r\n property Font;\r\n property ItemHeight;\r\n property MaxLength;\r\n property ParentColor;\r\n property ParentFont;\r\n property ParentShowHint;\r\n property PopupMenu;\r\n property ShowHint;\r\n property TabOrder;\r\n property TabStop;\r\n property Text;\r\n property Visible;\r\n property OnChange;\r\n property OnClick;\r\n property OnCloseUp;\r\n property OnContextPopup;\r\n property OnDblClick;\r\n property OnDragDrop;\r\n property OnDragOver;\r\n property OnDrawItem;\r\n property OnDropDown;\r\n property OnEndDrag;\r\n property OnEnter;\r\n property OnExit;\r\n property OnKeyDown;\r\n property OnKeyPress;\r\n property OnKeyUp;\r\n property OnMeasureItem;\r\n property OnSelect;\r\n property OnMouseEnter;\r\n property OnMouseLeave;\r\n property OnParentColorChange;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvDBSearchComboBox.pas $';\r\n Revision: '$Revision: 13168 $';\r\n Date: '$Date: 2011-11-13 11:02:20 +0100 (dim. 13 nov. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n Variants, SysUtils;\r\n\r\n{$IFDEF COMPILER_GENERICS_WORKAROUND}\r\n//=== { TBookmarkList } ======================================================\r\n\r\nfunction TBookmarkList.GetItem(Index: Integer): TBookmark;\r\nbegin\r\n Result := TBookmark(inherited Items[Index]);\r\nend;\r\n\r\nprocedure TBookmarkList.Notify(Ptr: Pointer; Action: TListNotification);\r\nvar\r\n Helper: TBookmark;\r\nbegin\r\n case Action of\r\n lnAdded:\r\n begin\r\n Helper := TBookmark(Ptr); // AddRef\r\n Pointer(Helper) := nil; // do not call ReleaseRef\r\n end;\r\n lnExtracted, lnDeleted:\r\n TBookmark(Ptr) := nil; // ReleaseRef\r\n end;\r\nend;\r\n{$ENDIF COMPILER_GENERICS_WORKAROUND}\r\n\r\n//=== { TJvSearchComboBoxLink } ==============================================\r\n\r\nconstructor TJvSearchComboBoxLink.Create(AJvDBSearchComboBox: TJvDBCustomSearchComboBox);\r\nbegin\r\n inherited Create;\r\n FJvDBSearchComboBox := AJvDBSearchComboBox;\r\n FDataFieldName := '';\r\n FDataField := nil;\r\n FWasEdited := False;\r\n FReading := False;\r\nend;\r\n\r\nprocedure TJvSearchComboBoxLink.SetDataField;\r\nbegin\r\n if DataSource = nil then\r\n Exit;\r\n if DataSource.DataSet = nil then\r\n Exit;\r\n if not DataSource.DataSet.Active then\r\n Exit;\r\n if FDataFieldName = '' then\r\n Exit;\r\n FDataField := DataSource.DataSet.FieldByName(FDataFieldName);\r\n if Active then\r\n FJvDBSearchComboBox.ReadList;\r\nend;\r\n\r\nprocedure TJvSearchComboBoxLink.SetDataFieldName(const Value: string);\r\nbegin\r\n if FDataFieldName <> Value then\r\n begin\r\n FDataFieldName := Value;\r\n SetDataField;\r\n end;\r\nend;\r\n\r\nprocedure TJvSearchComboBoxLink.ActiveChanged;\r\nbegin\r\n if Active then\r\n begin\r\n if FDataField = nil then\r\n SetDataField;\r\n end\r\n else\r\n begin\r\n FDataField := nil;\r\n FJvDBSearchComboBox.ClearList;\r\n end\r\nend;\r\n\r\nprocedure TJvSearchComboBoxLink.DataSetChanged;\r\nbegin\r\n if FReading or FJvDBSearchComboBox.FChanging then\r\n Exit;\r\n FReading := True;\r\n try\r\n if not (DataSource.DataSet.State in dsEditModes) then\r\n begin\r\n FJvDBSearchComboBox.ClearList;\r\n FJvDBSearchComboBox.ReadList;\r\n end;\r\n finally\r\n FReading := False;\r\n end;\r\nend;\r\n\r\nprocedure TJvSearchComboBoxLink.DataSetScrolled(Distance: Integer);\r\nbegin\r\n if Distance <> 0 then\r\n FJvDBSearchComboBox.Scroll(Distance);\r\nend;\r\n\r\nprocedure TJvSearchComboBoxLink.EditingChanged;\r\nbegin\r\n if Editing then\r\n FWasEdited := True;\r\nend;\r\n\r\n//=== { TJvDBCustomSearchComboBox } ==========================================\r\n\r\nconstructor TJvDBCustomSearchComboBox.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FBookmarks := TBookmarkList.Create;\r\n FDataLink := TJvSearchComboBoxLink.Create(Self);\r\n FChanging := False;\r\nend;\r\n\r\ndestructor TJvDBCustomSearchComboBox.Destroy;\r\nbegin\r\n ClearList;\r\n FDataLink.Free;\r\n FDataLink := nil; // Notification() is called by inherited Destroy\r\n inherited Destroy;\r\n FBookmarks.Free;\r\nend;\r\n\r\nprocedure TJvDBCustomSearchComboBox.Notification(Component: TComponent; Operation: TOperation);\r\nbegin\r\n inherited Notification(Component, Operation);\r\n if (FDataLink <> nil) and (Component = DataSource) and (Operation = opRemove) then\r\n DataSource := nil;\r\nend;\r\n\r\nfunction TJvDBCustomSearchComboBox.GetDataField: string;\r\nbegin\r\n Result := FDataLink.DataFieldName;\r\nend;\r\n\r\nfunction TJvDBCustomSearchComboBox.GetDataSource: TDataSource;\r\nbegin\r\n Result := FDataLink.DataSource;\r\nend;\r\n\r\nprocedure TJvDBCustomSearchComboBox.SetDataField(const Value: string);\r\nbegin\r\n FDataLink.DataFieldName := Value;\r\nend;\r\n\r\nprocedure TJvDBCustomSearchComboBox.SetDataSource(Value: TDataSource);\r\nbegin\r\n FDataLink.DataSource := Value;\r\nend;\r\n\r\nprocedure TJvDBCustomSearchComboBox.Select;\r\nbegin\r\n if not FChanging and (ItemIndex <> -1) and\r\n (FDataLink.DataSet <> nil) and (FDataLink.DataField <> nil) then\r\n begin\r\n FChanging := True;\r\n try\r\n FDataLink.DataSet.GotoBookmark(Pointer(Items.Objects[ItemIndex]));\r\n finally\r\n FChanging := False;\r\n end;\r\n end;\r\n inherited Select;\r\nend;\r\n\r\nprocedure TJvDBCustomSearchComboBox.Refresh;\r\nbegin\r\n ReadList;\r\nend;\r\n\r\nprocedure TJvDBCustomSearchComboBox.Scroll(Distance: Integer);\r\nbegin\r\n if FChanging then\r\n Exit;\r\n FChanging := True;\r\n try\r\n ItemIndex := ItemIndex + Distance;\r\n finally\r\n FChanging := False;\r\n end;\r\nend;\r\n\r\nprocedure TJvDBCustomSearchComboBox.ReadList;\r\nvar\r\n Bmrk: {$IFDEF RTL200_UP}TBookmark{$ELSE}TBookmarkStr{$ENDIF RTL200_UP};\r\n N, CurIndex: Integer;\r\n DataSet: TDataSet;\r\n Field: TField;\r\nbegin\r\n if (FDataLink.DataField = nil) or (FDataLink.DataSet = nil) or not FDataLink.DataSet.Active then\r\n Exit;\r\n Items.BeginUpdate;\r\n try\r\n DataSet := FDataLink.DataSet;\r\n ClearList;\r\n CurIndex := -1;\r\n Bmrk := DataSet.Bookmark;\r\n DataSet.DisableControls;\r\n N := 0;\r\n try\r\n Field := DataSet.FieldByName(FDataLink.FDataFieldName);\r\n DataSet.First;\r\n while not DataSet.Eof do\r\n begin\r\n FBookmarks.Add(DataSet.GetBookmark);\r\n Items.AddObject(Field.DisplayText, TObject(FBookmarks[N]));\r\n if {$IFDEF RTL200_UP}DataSet.CompareBookmarks(DataSet.Bookmark, Bmrk) = 0{$ELSE}DataSet.Bookmark = Bmrk{$ENDIF RTL200} then\r\n CurIndex := N;\r\n Inc(N);\r\n DataSet.Next;\r\n end;\r\n DataSet.Bookmark := Bmrk;\r\n finally\r\n DataSet.EnableControls;\r\n end;\r\n finally\r\n Items.EndUpdate;\r\n end;\r\n ItemIndex := CurIndex;\r\nend;\r\n\r\nprocedure TJvDBCustomSearchComboBox.ClearList;\r\nvar\r\n I: Integer;\r\nbegin\r\n if Assigned(FDataLink.DataSet) then\r\n for I := 0 to FBookmarks.Count - 1 do\r\n FDataLink.DataSet.FreeBookmark(FBookmarks[I]);\r\n FBookmarks.Clear;\r\n if HandleAllocated and not (csDestroying in ComponentState) then // TCustomComboBox uses SendMessage(Handle, ...) to clear items\r\n Items.Clear;\r\nend;\r\n\r\nfunction TJvDBCustomSearchComboBox.GetResult: Variant;\r\nbegin\r\n Result := Null;\r\n if Assigned(FDataLink.DataSet) and (DataResult <> '') then\r\n Result := FDataLink.DataSet.Lookup(DataField, Text, DataResult);\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvDBSearchEdit.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvDBSearchEdit.pas, released on 2004-02-28.\r\n\r\nThe Initial Developer of the Original Code is Lionel Reynaud\r\nPortions created by Sbastien Buysse are Copyright (C) 2004 Lionel Reynaud.\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n\r\nDescription:\r\n// DB Component to find record with Edit\r\n// Free modified and corrected component TDBSearchEdit from Alexander Burlakov\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvDBSearchEdit.pas 13104 2011-09-07 06:50:43Z obones $\r\n\r\nunit JvDBSearchEdit;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows,\r\n Messages,\r\n Classes, Controls, DB, DBCtrls,\r\n JvEdit;\r\n\r\ntype\r\n TJvDBCustomSearchEdit = class(TJvCustomEdit)\r\n private\r\n FDataLink: TFieldDataLink;\r\n FSearchOptions: TLocateOptions;\r\n FClearOnEnter: Boolean;\r\n FDataResult: string;\r\n FRaiseLocateException: Boolean;\r\n procedure DataChange(Sender: TObject);\r\n function GetDataSource: TDataSource;\r\n function GetDataField: string;\r\n procedure SetDataSource(Value: TDataSource);\r\n procedure SetDataField(const Value: string);\r\n procedure SetSearchOptions(const Value: TLocateOptions);\r\n procedure CMChanged(var Msg: TMessage); message CM_CHANGED;\r\n protected\r\n procedure DoEnter; override;\r\n procedure DoExit; override;\r\n procedure KeyPress(var Key: Char); override;\r\n procedure Notification(Component: TComponent; Operation: TOperation); override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n function GetResult: Variant;\r\n property SearchOptions: TLocateOptions read FSearchOptions\r\n write SetSearchOptions default [loCaseInsensitive, loPartialKey];\r\n published\r\n property DataSource: TDataSource read GetDataSource write SetDataSource;\r\n property DataResult: string read FDataResult write FDataResult;\r\n property DataField: string read GetDataField write SetDataField;\r\n property TabStop default True;\r\n property ClearOnEnter: Boolean read FClearOnEnter write FClearOnEnter default True;\r\n //1 Property to raise/hide any exception inside the Dataset.Locate call\r\n property RaiseLocateException: Boolean read FRaiseLocateException write FRaiseLocateException default true;\r\n end;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvDBSearchEdit = class(TJvDBCustomSearchEdit)\r\n published\r\n property SearchOptions default [loCaseInsensitive, loPartialKey];\r\n property Align;\r\n property Alignment;\r\n property Anchors;\r\n property AutoSelect;\r\n property AutoSize;\r\n property BevelEdges;\r\n property BevelInner;\r\n property BevelKind default bkNone;\r\n property BevelOuter;\r\n property BorderStyle;\r\n property CharCase;\r\n property Color;\r\n property Flat;\r\n property DragCursor;\r\n property ImeMode;\r\n property ImeName;\r\n property OEMConvert;\r\n property ParentFlat;\r\n property DragMode;\r\n property Enabled;\r\n property Font;\r\n property HideSelection;\r\n property MaxLength;\r\n property ParentColor;\r\n property ParentFont;\r\n property ParentShowHint;\r\n property PopupMenu;\r\n property ReadOnly;\r\n property ShowHint;\r\n property TabOrder;\r\n property TabStop;\r\n property Text;\r\n property Visible;\r\n property OnChange;\r\n property OnClick;\r\n property OnContextPopup;\r\n property OnDblClick;\r\n property OnDragDrop;\r\n property OnDragOver;\r\n property OnEndDrag;\r\n property OnEnter;\r\n property OnExit;\r\n property OnKeyDown;\r\n property OnKeyPress;\r\n property OnKeyUp;\r\n property OnMouseDown;\r\n property OnMouseMove;\r\n property OnMouseUp;\r\n property OnStartDrag;\r\n property OnMouseEnter;\r\n property OnMouseLeave;\r\n property OnParentColorChange;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvDBSearchEdit.pas $';\r\n Revision: '$Revision: 13104 $';\r\n Date: '$Date: 2011-09-07 08:50:43 +0200 (mer. 07 sept. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n Variants, Forms,\r\n JvConsts;\r\n\r\n//=== { TJvDBCustomSearchEdit } ==============================================\r\n\r\nconstructor TJvDBCustomSearchEdit.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FDataLink := TFieldDataLink.Create;\r\n FDataLink.Control := Self;\r\n FDataLink.OnDataChange := DataChange;\r\n FSearchOptions := [loCaseInsensitive, loPartialKey];\r\n FClearOnEnter := True;\r\n Text := '';\r\n FRaiseLocateException := True;\r\nend;\r\n\r\ndestructor TJvDBCustomSearchEdit.Destroy;\r\nbegin\r\n FDataLink.Free;\r\n FDataLink := nil;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvDBCustomSearchEdit.Notification(Component: TComponent; Operation: TOperation);\r\nbegin\r\n inherited Notification(Component, Operation);\r\n if (FDataLink <> nil) and (Component = DataSource) and (Operation = opRemove) then\r\n DataSource := nil;\r\nend;\r\n\r\nprocedure TJvDBCustomSearchEdit.DataChange(Sender: TObject);\r\nbegin\r\n if FDataLink.Field <> nil then\r\n begin\r\n if Screen.ActiveControl <> Self then\r\n begin\r\n if FDataLink.CanModify then\r\n Text := FDataLink.Field.Text\r\n else\r\n Text := FDataLink.Field.DisplayText;\r\n SelectAll;\r\n end;\r\n end\r\n else\r\n begin\r\n if csDesigning in ComponentState then\r\n Text := Name\r\n else\r\n Text := '';\r\n end;\r\nend;\r\n\r\nprocedure TJvDBCustomSearchEdit.CMChanged(var Msg: TMessage);\r\nvar\r\n LText: string;\r\nbegin\r\n if (not ((csDesigning in ComponentState) and\r\n (csLoading in ComponentState))) and\r\n Assigned(FDataLink.DataSet) then\r\n if (Screen.ActiveControl = Self) and FDataLink.Active then\r\n try\r\n if FDataLink.DataSet.Locate(FDataLink.FieldName, Text, FSearchOptions) then\r\n begin\r\n LText := Text;\r\n Text := FDataLink.DataSet.FieldByName(DataField).AsString;\r\n SelStart := Length(LText);\r\n SelLength := Length(Text) - SelStart;\r\n end;\r\n except\r\n if RaiseLocateException then\r\n raise;\r\n end;\r\nend;\r\n\r\nprocedure TJvDBCustomSearchEdit.KeyPress(var Key: Char);\r\nvar\r\n LLength: Integer;\r\nbegin\r\n if Key = Backspace then\r\n begin\r\n LLength := SelLength;\r\n SelStart := SelStart - 1;\r\n SelLength := LLength + 1;\r\n end;\r\n inherited KeyPress(Key);\r\nend;\r\n\r\nfunction TJvDBCustomSearchEdit.GetDataSource: TDataSource;\r\nbegin\r\n Result := FDataLink.DataSource;\r\nend;\r\n\r\nprocedure TJvDBCustomSearchEdit.SetDataSource(Value: TDataSource);\r\nbegin\r\n FDataLink.DataSource := Value;\r\nend;\r\n\r\nfunction TJvDBCustomSearchEdit.GetDataField: string;\r\nbegin\r\n Result := FDataLink.FieldName;\r\nend;\r\n\r\nprocedure TJvDBCustomSearchEdit.SetDataField(const Value: string);\r\nbegin\r\n FDataLink.FieldName := Value;\r\nend;\r\n\r\nprocedure TJvDBCustomSearchEdit.SetSearchOptions(const Value: TLocateOptions);\r\nbegin\r\n FSearchOptions := Value;\r\nend;\r\n\r\nfunction TJvDBCustomSearchEdit.GetResult: Variant;\r\nbegin\r\n Result := Null;\r\n if Assigned(FDataLink.DataSet) and FDataLink.DataSet.Active and (DataResult <> '') then\r\n Result := FDataLink.DataSet.Lookup(DataField, Text, DataResult);\r\nend;\r\n\r\nprocedure TJvDBCustomSearchEdit.DoEnter;\r\nbegin\r\n if FClearOnEnter then\r\n Text := '';\r\n inherited DoEnter;\r\nend;\r\n\r\nprocedure TJvDBCustomSearchEdit.DoExit;\r\nbegin\r\n inherited DoExit;\r\n // On replace le texte sur l'enregistrement en cours\r\n if Assigned(FDataLink.DataSet) and FDataLink.DataSet.Active then\r\n Text := FDataLink.DataSet.FieldByName(DataField).AsString;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvDBSpinEdit.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvDBSpinEdit.PAS, released on 2002-07-26.\r\n\r\nThe Initial Developer of the Original Code is Rob den Braasem []\r\nPortions created by Rob den Braasem are Copyright (C) 2002 Rob den Braasem.\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\n EinWill\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\nKnown Issues:\r\n\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvDBSpinEdit.pas 13343 2012-06-13 12:22:56Z obones $\r\n\r\nunit JvDBSpinEdit;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, Messages, Classes, Controls, DB, DBCtrls,\r\n JvSpin, JvConsts;\r\n\r\ntype\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvDBSpinEdit = class(TJvSpinEdit)\r\n private\r\n FDataLink: TFieldDataLink;\r\n FIsNull: Boolean;\r\n FAllowNull: Boolean;\r\n FDataChanging: Boolean;\r\n\r\n procedure DataChange(Sender: TObject);\r\n procedure UpdateData(Sender: TObject);\r\n procedure EditingChange(Sender: TObject);\r\n function GetDataField: string; { Returns data field name. }\r\n function GetDataSource: TDataSource; { Returns linked data source. }\r\n procedure SetDataField(const NewFieldName: string); { Assigns new field. }\r\n procedure SetDataSource(Value: TDataSource); { Assigns new data source. }\r\n procedure CMGetDataLink(var Msg: TMessage); message CM_GETDATALINK;\r\n function GetReadOnly: Boolean; reintroduce;\r\n procedure SetReadOnly(Value: Boolean); reintroduce;\r\n protected\r\n function IsValidChar(Key: Char): Boolean; override;\r\n procedure Change; override;\r\n procedure DoExit; override; { called to update data }\r\n function GetValue: Extended; override;\r\n procedure SetValue(NewValue: Extended); override;\r\n procedure TextChanged; override;\r\n procedure UpClick(Sender: TObject); override;\r\n procedure DownClick(Sender: TObject); override;\r\n procedure KeyDown(var Key: Word; Shift: TShiftState); override;\r\n\r\n { Backwards compatibility; eventually remove }\r\n procedure DefineProperties(Filer: TFiler); override;\r\n procedure ReadReadOnlyField(Reader: TReader);\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n\r\n function ExecuteAction(Action: TBasicAction): Boolean; override;\r\n function UpdateAction(Action: TBasicAction): Boolean; override;\r\n procedure Notification(AComponent: TComponent; Operation: TOperation); override;\r\n\r\n property IsNull: Boolean read FIsNull;\r\n published\r\n property AllowNull: Boolean read FAllowNull write FAllowNull default True;\r\n property DataField: string read GetDataField write SetDataField;\r\n property DataSource: TDataSource read GetDataSource write SetDataSource;\r\n property ReadOnly: Boolean read GetReadOnly write SetReadOnly default False;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvDBSpinEdit.pas $';\r\n Revision: '$Revision: 13343 $';\r\n Date: '$Date: 2012-06-13 14:22:56 +0200 (mer. 13 juin 2012) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n Variants, SysUtils;\r\n\r\n//=== { TJvDBSpinEdit } ======================================================\r\n\r\nconstructor TJvDBSpinEdit.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n inherited ReadOnly := True;\r\n FAllowNull := True;\r\n FDataChanging := False;\r\n FDataLink := TFieldDataLink.Create;\r\n FDataLink.Control := Self;\r\n FDataLink.OnDataChange := DataChange;\r\n FDataLink.OnEditingChange := EditingChange;\r\n FDataLink.OnUpdateData := UpdateData;\r\nend;\r\n\r\ndestructor TJvDBSpinEdit.Destroy;\r\nbegin\r\n FDataLink.Free;\r\n FDataLink := nil;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvDBSpinEdit.Change;\r\nbegin\r\n if (FDataLink <> nil) and (FDataLink.Field <> nil) then\r\n FDataLink.Modified;\r\n inherited Change;\r\nend;\r\n\r\nprocedure TJvDBSpinEdit.CMGetDataLink(var Msg: TMessage);\r\nbegin\r\n Msg.Result := LRESULT(FDataLink);\r\nend;\r\n\r\nprocedure TJvDBSpinEdit.DataChange(Sender: TObject);\r\nbegin\r\n FDataChanging := True;\r\n try\r\n if FDataLink.Field <> nil then\r\n begin\r\n if Focused and FDataLink.CanModify then\r\n begin\r\n // Mantis 2131: If field is numeric and it has a DisplayFormat then\r\n // take the unformatted text (in AsString) to have a valid number in\r\n // the Value property.\r\n if (FDataLink.Field is TNumericField) and\r\n (Length((FDataLink.Field as TNumericField).DisplayFormat) <> 0) then\r\n Text := FDataLink.Field.AsString\r\n else\r\n Text := FDataLink.Field.Text;\r\n end\r\n else\r\n begin\r\n FIsNull := FDataLink.Field.DisplayText = '';\r\n // Mantis 2131, see above\r\n if (FDataLink.Field is TNumericField) and\r\n (Length((FDataLink.Field as TNumericField).DisplayFormat) <> 0) then\r\n Text := FDataLink.Field.AsString\r\n else\r\n Text := FDataLink.Field.DisplayText;\r\n\r\n if FDataLink.Editing or (FDataLink.Field.DataSet.State = dsInsert) then\r\n Modified := True;\r\n end;\r\n end\r\n else\r\n begin\r\n FIsNull := False;\r\n if csDesigning in ComponentState then\r\n Text := Name\r\n else\r\n Text := '';\r\n end;\r\n finally\r\n FDataChanging := False;\r\n end;\r\nend;\r\n\r\nprocedure TJvDBSpinEdit.DefineProperties(Filer: TFiler);\r\nbegin\r\n inherited DefineProperties(Filer);\r\n Filer.DefineProperty('ReadOnlyField', ReadReadOnlyField, nil, False);\r\nend;\r\n\r\nprocedure TJvDBSpinEdit.DoExit;\r\nbegin\r\n try\r\n if Modified then\r\n FDataLink.Modified;\r\n FDataLink.UpdateRecord; { tell data link to update database }\r\n except\r\n SetFocus; { if it failed, don't let focus leave }\r\n SelectAll;\r\n raise;\r\n end;\r\n inherited DoExit;\r\nend;\r\n\r\nprocedure TJvDBSpinEdit.DownClick(Sender: TObject);\r\nbegin\r\n FDataLink.Edit;\r\n if IsNull then\r\n begin\r\n FIsNull := False;\r\n Value := 0;\r\n FIsNull := False;\r\n Text := '0';\r\n end;\r\n inherited DownClick(Sender);\r\nend;\r\n\r\nprocedure TJvDBSpinEdit.EditingChange(Sender: TObject);\r\nbegin\r\n inherited ReadOnly := not FDataLink.Editing;\r\nend;\r\n\r\nfunction TJvDBSpinEdit.ExecuteAction(Action: TBasicAction): Boolean;\r\nbegin\r\n Result := inherited ExecuteAction(Action) or\r\n (Assigned(FDataLink) and FDataLink.ExecuteAction(Action));\r\nend;\r\n\r\nfunction TJvDBSpinEdit.GetDataField: string; { Returns data field name. }\r\nbegin\r\n { FDataLink is built in TJvDBSpinEdit.Create; there's no need to check to see if it's assigned. }\r\n Result := FDataLink.FieldName;\r\nend;\r\n\r\nfunction TJvDBSpinEdit.GetDataSource: TDataSource; { Returns linked data source. }\r\nbegin\r\n { FDataLink is built in TJvDBSpinEdit.Create; there's no need to check to see if it's assigned. }\r\n Result := FDataLink.DataSource;\r\nend;\r\n\r\nfunction TJvDBSpinEdit.GetReadOnly: Boolean;\r\nbegin\r\n Result := FDataLink.ReadOnly;\r\nend;\r\n\r\nfunction TJvDBSpinEdit.GetValue: Extended;\r\nbegin\r\n Result := inherited GetValue;\r\n FIsNull := (Text = '') and (Result = 0.0);\r\nend;\r\n\r\nfunction TJvDBSpinEdit.IsValidChar(Key: Char): Boolean;\r\nbegin\r\n Result := inherited IsValidChar(Key);\r\n if not Result and AllowNull and\r\n ((Key = BackSpace) or (Key = Del)) then\r\n Result := True;\r\nend;\r\n\r\nprocedure TJvDBSpinEdit.KeyDown(var Key: Word; Shift: TShiftState);\r\nvar\r\n KeyState: TKeyboardState;\r\n AnsiChars: AnsiString;\r\nbegin\r\n if (Key = VK_ESCAPE) and (FDataLink.Editing) then\r\n begin\r\n FDataLink.Reset;\r\n SelectAll;\r\n Key := 0;\r\n end;\r\n inherited KeyDown(Key, Shift);\r\n\r\n // Must convert from virtual key code to character\r\n GetKeyboardState(KeyState);\r\n SetLength(AnsiChars, 2);\r\n case ToAscii(Key, MapVirtualKey(Key, 0), KeyState, @AnsiChars[1], 0) of\r\n 1: SetLength(AnsiChars, 1);\r\n 2: ;\r\n else AnsiChars := '';\r\n end;\r\n\r\n if (Key = VK_DELETE) or (Key = VK_BACK) or\r\n ((Key = VK_INSERT) and (ssShift in Shift)) or ((Length(AnsiChars) > 0) and IsValidChar(Char(AnsiChars[1]))) then\r\n FDataLink.Edit;\r\nend;\r\n\r\nprocedure TJvDBSpinEdit.Notification(AComponent: TComponent;\r\n Operation: TOperation);\r\nbegin\r\n inherited Notification(AComponent, Operation);\r\n\r\n if Operation = opRemove then\r\n if Assigned(FDataLink) and (AComponent = DataSource) then\r\n DataSource := nil;\r\nend;\r\n\r\nprocedure TJvDBSpinEdit.ReadReadOnlyField(Reader: TReader);\r\nbegin\r\n ReadOnly := Reader.ReadBoolean;\r\nend;\r\n\r\nprocedure TJvDBSpinEdit.SetDataField(const NewFieldName: string); { Assigns new field. }\r\nbegin\r\n { FDataLink is built in TJvDBSpinEdit.Create; there's no need to check to see if it's assigned. }\r\n FDataLink.FieldName := NewFieldName;\r\nend;\r\n\r\nprocedure TJvDBSpinEdit.SetDataSource(Value: TDataSource); { Assigns new data source. }\r\nbegin\r\n { FDataLink is built in TJvDBSpinEdit.Create; there's no need to check to see if it's assigned. }\r\n if not (FDataLink.DataSourceFixed and (csLoading in ComponentState)) then\r\n begin\r\n if FDataLink.DataSource <> nil then\r\n FDataLink.DataSource.RemoveFreeNotification(Self);\r\n FDataLink.DataSource := Value;\r\n end;\r\n { Tell the new DataSource that our TJvDBSpinEdit component should be notified\r\n (using the Notification method) if the DataSource is ever removed from\r\n a data module or form that is different than the owner of this control. }\r\n if Value <> nil then\r\n Value.FreeNotification(Self);\r\n\r\n //FDataLink.DataSource := NewSource;\r\n //if NewSource <> nil then\r\n // NewSource.FreeNotification(Self);\r\nend;\r\n\r\nprocedure TJvDBSpinEdit.SetReadOnly(Value: Boolean);\r\nbegin\r\n FDataLink.ReadOnly := Value;\r\nend;\r\n\r\nprocedure TJvDBSpinEdit.SetValue(NewValue: Extended);\r\nbegin\r\n if FDataLink.CanModify then\r\n begin\r\n FIsNull := (Text = '') and (NewValue = 0.0);\r\n if not (FIsNull and FAllowNull) then\r\n inherited SetValue(NewValue);\r\n if not FDataChanging and (FDataLink.Field <> nil) then\r\n begin\r\n if (IsNull and not FDataLink.Field.IsNull) or\r\n (not IsNull and not VarSameValue(FDataLink.Field.Value, NewValue)) then\r\n FDataLink.Edit;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvDBSpinEdit.TextChanged;\r\nbegin\r\n if FIsNull and AllowNull then\r\n inherited Text := ''\r\n else\r\n inherited TextChanged;\r\nend;\r\n\r\nprocedure TJvDBSpinEdit.UpClick(Sender: TObject);\r\nbegin\r\n FDataLink.Edit;\r\n if IsNull then\r\n begin\r\n FIsNull := False;\r\n Value := 0;\r\n FIsNull := False;\r\n Text := '0';\r\n end\r\n else\r\n inherited UpClick(Sender);\r\nend;\r\n\r\n{ UpdateData is only called after calls to both FDataLink.Modified and\r\n FDataLink.UpdateRecord. }\r\n\r\nfunction TJvDBSpinEdit.UpdateAction(Action: TBasicAction): Boolean;\r\nbegin\r\n Result := inherited UpdateAction(Action) or\r\n (Assigned(FDataLink) and FDataLink.UpdateAction(Action));\r\nend;\r\n\r\nprocedure TJvDBSpinEdit.UpdateData(Sender: TObject);\r\nbegin\r\n { Never masked? }\r\n {ValidateEdit;}\r\n if FDataLink.Editing then\r\n FDataLink.Field.AsFloat := Value;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvDBTreeView.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvDBTreeView.PAS, released on 2002-07-04.\r\n\r\nThe Initial Developers of the Original Code are: Andrei Prygounkov \r\nCopyright (c) 1999, 2002 Andrei Prygounkov\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\nPeter Zolja\r\nMarc Geldon\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\ncomponent : JvDBTreeView\r\ndescription : db-aware TreeView\r\n\r\nHistory:\r\n (JVCL Library versions) :\r\n 1.20:\r\n - first release;\r\n 1.61:\r\n - support for non-bde components,\r\n by Yakovlev Vacheslav (jwe att belkozin dott com)\r\n 3.3: martinalex, Jan 2007\r\n - Fix: Add Node, IconField, value set, same value as parent\r\n - Fix: Add Node, MasterField, unique value ensured\r\n - Fix: Delete node, delete records for all childs\r\n - Fix: Drag&drop, move node only for node drop, not for drop of other objects\r\n\r\nKnown Issues:\r\n Some russian comments were translated to english; these comments are marked\r\n with [translated]\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvDBTreeView.pas 13415 2012-09-10 09:51:54Z obones $\r\n\r\nunit JvDBTreeView;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows,\r\n Messages, CommCtrl,\r\n Classes, Controls, ExtCtrls, ComCtrls, DB,\r\n JvExtComponent;\r\n\r\ntype\r\n TJvDBTreeNode = class;\r\n TJvDBTreeViewDataLink = class;\r\n TFieldTypes = set of TFieldType;\r\n TGetDetailValue = function(const AMasterValue: Variant; var DetailValue: Variant): Boolean;\r\n\r\n TJvCustomDBTreeView = class(TJvCustomTreeView)\r\n private\r\n FDataLink: TJvDBTreeViewDataLink;\r\n FMasterField: string;\r\n FDetailField: string;\r\n FItemField: string;\r\n FIconField: string;\r\n FStartMasterValue: Variant;\r\n FGetDetailValue: TGetDetailValue;\r\n FUseFilter: Boolean;\r\n FSelectedIndex: Integer;\r\n {Update flags}\r\n FUpdateLock: Byte;\r\n InTreeUpdate: Boolean;\r\n InDataScrolled: Boolean;\r\n InAddChild: Boolean;\r\n InDelete: Boolean;\r\n Sel: TTreeNode;\r\n OldRecCount: Integer;\r\n FPersistentNode: Boolean;\r\n FMirror: Boolean;\r\n {**** Drag'n'Drop ****}\r\n YDragPos: Integer;\r\n TimerDnD: TTimer;\r\n procedure InternalDataChanged;\r\n procedure InternalDataScrolled;\r\n procedure InternalRecordChanged(Field: TField);\r\n procedure SetMasterField(Value: string);\r\n procedure SetDetailField(Value: string);\r\n procedure SetItemField(Value: string);\r\n procedure SetIconField(Value: string);\r\n function GetStartMasterValue: string;\r\n procedure SetStartMasterValue(Value: string);\r\n function GetDataSource: TDataSource;\r\n procedure SetDataSource(Value: TDataSource);\r\n procedure CMGetDataLink(var Msg: TMessage); message CM_GETDATALINK;\r\n procedure SetMirror(Value: Boolean);\r\n {**** Drag'n'Drop ****}\r\n procedure TimerDnDTimer(Sender: TObject);\r\n protected\r\n FMastersStream: TStream;\r\n\r\n procedure DragOver(Source: TObject; X, Y: Integer; State: TDragState;\r\n var Accept: Boolean); override;\r\n\r\n procedure CreateWnd; override;\r\n procedure DestroyWnd; override;\r\n protected\r\n procedure Warning(Msg: string);\r\n procedure HideEditor;\r\n function ValidDataSet: Boolean;\r\n procedure CheckDataSet;\r\n function ValidField(FieldName: string; AllowFieldTypes: TFieldTypes): Boolean;\r\n procedure KeyDown(var Key: Word; Shift: TShiftState); override;\r\n procedure Notification(Component: TComponent; Operation: TOperation); override;\r\n procedure Change(Node: TTreeNode); override;\r\n { data }\r\n procedure DataChanged; dynamic;\r\n procedure DataScrolled; dynamic;\r\n procedure Change2(Node: TTreeNode); dynamic;\r\n procedure RecordChanged(Field: TField); dynamic;\r\n\r\n function CanExpand(Node: TTreeNode): Boolean; override;\r\n procedure Collapse(Node: TTreeNode); override;\r\n function CreateNode: TTreeNode; override;\r\n function CanEdit(Node: TTreeNode): Boolean; override;\r\n procedure Edit(const Item: TTVItem); override;\r\n procedure MoveTo(Source, Destination: TJvDBTreeNode; Mode: TNodeAttachMode);\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n procedure DragDrop(Source: TObject; X, Y: Integer); override;\r\n procedure RefreshChild(ANode: TJvDBTreeNode);\r\n procedure UpdateTree;\r\n procedure LinkActive(Value: Boolean); virtual;\r\n procedure UpdateLock;\r\n procedure UpdateUnLock(const AUpdateTree: Boolean);\r\n function UpdateLocked: Boolean;\r\n function AddChildNode(const Node: TTreeNode; const Select: Boolean): TJvDBTreeNode;\r\n procedure DeleteNode(Node: TTreeNode);\r\n function DeleteChildren(ParentNode: TTreeNode): Boolean;\r\n function FindNextNode(const Node: TTreeNode): TTreeNode;\r\n function FindNode(AMasterValue: Variant): TJvDBTreeNode;\r\n function SelectNode(AMasterValue: Variant): TTreeNode;\r\n\r\n property DataSource: TDataSource read GetDataSource write SetDataSource;\r\n property DataLink: TJvDBTreeViewDataLink read FDataLink;\r\n property MasterField: string read FMasterField write SetMasterField;\r\n // alias for MasterField\r\n property ParentField: string read FMasterField write SetMasterField;\r\n property DetailField: string read FDetailField write SetDetailField;\r\n // alias for DetailField\r\n property KeyField: string read FDetailField write SetDetailField;\r\n\r\n property ItemField: string read FItemField write SetItemField;\r\n property IconField: string read FIconField write SetIconField;\r\n property StartMasterValue: string read GetStartMasterValue write SetStartMasterValue;\r\n property GetDetailValue: TGetDetailValue read FGetDetailValue write FGetDetailValue;\r\n property PersistentNode: Boolean read FPersistentNode write FPersistentNode;\r\n property SelectedIndex: Integer read FSelectedIndex write FSelectedIndex default 1;\r\n property UseFilter: Boolean read FUseFilter write FUseFilter;\r\n property Mirror: Boolean read FMirror write SetMirror;\r\n property Items;\r\n end;\r\n\r\n TJvDBTreeViewDataLink = class(TDataLink)\r\n private\r\n FTreeView: TJvCustomDBTreeView;\r\n protected\r\n procedure ActiveChanged; override;\r\n procedure RecordChanged(Field: TField); override;\r\n procedure DataSetChanged; override;\r\n procedure DataSetScrolled(Distance: Integer); override;\r\n public\r\n constructor Create(ATreeView: TJvCustomDBTreeView);\r\n end;\r\n\r\n TJvDBTreeNode = class(TTreeNode)\r\n private\r\n FMasterValue: Variant;\r\n public\r\n procedure SetMasterValue(AValue: Variant);\r\n procedure MoveTo(Destination: TTreeNode; Mode: TNodeAttachMode); override;\r\n property MasterValue: Variant read FMasterValue;\r\n end;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvDBTreeView = class(TJvCustomDBTreeView)\r\n published\r\n property BevelEdges;\r\n property BevelInner;\r\n property BevelKind default bkNone;\r\n property BevelOuter;\r\n property DataSource;\r\n property MasterField;\r\n property DetailField;\r\n property IconField;\r\n property ItemField;\r\n property StartMasterValue;\r\n property UseFilter;\r\n property PersistentNode;\r\n property SelectedIndex;\r\n property BorderStyle;\r\n property DragCursor;\r\n property ShowButtons;\r\n property ShowLines;\r\n property ShowRoot;\r\n property ReadOnly;\r\n property RightClickSelect;\r\n property DragMode;\r\n property HideSelection;\r\n property Indent;\r\n property OnEditing;\r\n property OnEdited;\r\n property OnExpanding;\r\n property OnExpanded;\r\n property OnCollapsing;\r\n property OnCompare;\r\n property OnCollapsed;\r\n property OnChanging;\r\n property OnChange;\r\n property OnDeletion;\r\n property OnGetImageIndex;\r\n property OnGetSelectedIndex;\r\n property Align;\r\n property Enabled;\r\n property Font;\r\n property Color;\r\n property ParentColor default False;\r\n property SortType;\r\n property TabOrder;\r\n property TabStop default True;\r\n property Visible;\r\n property OnClick;\r\n property OnEnter;\r\n property OnExit;\r\n property OnDragDrop;\r\n property OnDragOver;\r\n property OnStartDrag;\r\n property OnEndDrag;\r\n property OnMouseDown;\r\n property OnMouseMove;\r\n property OnMouseUp;\r\n property OnDblClick;\r\n property OnKeyDown;\r\n property OnKeyPress;\r\n property OnKeyUp;\r\n property PopupMenu;\r\n property ParentFont;\r\n property ParentShowHint;\r\n property ShowHint;\r\n property Images;\r\n property StateImages;\r\n property Anchors;\r\n property AutoExpand;\r\n property BiDiMode;\r\n property BorderWidth;\r\n property ChangeDelay;\r\n property Constraints;\r\n property DragKind;\r\n property HotTrack;\r\n property ParentBiDiMode;\r\n property RowSelect;\r\n property ToolTips;\r\n property OnCustomDraw;\r\n property OnCustomDrawItem;\r\n property OnEndDock;\r\n property OnStartDock;\r\n property Mirror;\r\n end;\r\n\r\n EJvDBTreeViewError = class(ETreeViewError);\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvDBTreeView.pas $';\r\n Revision: '$Revision: 13415 $';\r\n Date: '$Date: 2012-09-10 11:51:54 +0200 (lun. 10 sept. 2012) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n {$IFDEF HAS_UNIT_SYSTEM_UITYPES}\r\n System.UITypes,\r\n {$ENDIF}\r\n Variants, SysUtils, Dialogs,\r\n JvResources;\r\n\r\n// (rom) moved to implementation and removed type\r\n// (rom) never rely on assignable consts\r\nconst\r\n DnDScrollArea = 15;\r\n DnDInterval = 200;\r\n DefaultValidMasterFields = [ftSmallInt, ftInteger, ftAutoInc, ftWord, ftFloat, ftString, ftWideString, ftBCD, ftFMTBCD];\r\n DefaultValidDetailFields = DefaultValidMasterFields;\r\n DefaultValidItemFields = [ftString, ftWideString, ftMemo, ftFmtMemo, ftSmallInt, ftInteger, ftAutoInc,\r\n ftWord, ftBoolean, ftFloat, ftCurrency, ftDate, ftTime, ftDateTime, ftBCD, ftFMTBCD\r\n {$IFDEF COMPILER10_UP}\r\n , ftFixedWideChar, ftWideMemo, ftOraTimeStamp\r\n {$ENDIF COMPILER10_UP}\r\n {$IFDEF COMPILER12_UP}\r\n ,ftLongWord, ftShortint, ftByte, ftExtended\r\n {$ENDIF COMPILER12_UP}];\r\n DefaultValidIconFields = [ftSmallInt, ftAutoInc, ftInteger, ftWord, ftBCD, ftFMTBCD\r\n {$IFDEF COMPILER12_UP}\r\n ,ftLongWord, ftShortint\r\n {$ENDIF COMPILER12_UP}];\r\n\r\nfunction Var2Type(V: Variant; const VarType: Integer): Variant;\r\nbegin\r\n if V = Null then\r\n begin\r\n case VarType of\r\n varString, varOleStr:\r\n Result := '';\r\n varInteger, varSmallint, varByte:\r\n Result := 0;\r\n varBoolean:\r\n Result := False;\r\n varSingle, varDouble, varCurrency, varDate:\r\n Result := 0.0;\r\n else\r\n Result := VarAsType(V, VarType);\r\n end;\r\n end\r\n else\r\n Result := VarAsType(V, VarType);\r\nend;\r\n\r\nprocedure MirrorControl(Control: TWinControl; RightToLeft: Boolean);\r\nvar\r\n OldLong: Longword;\r\nbegin\r\n OldLong := GetWindowLong(Control.Handle, GWL_EXSTYLE);\r\n if RightToLeft then\r\n begin\r\n Control.BiDiMode := bdLeftToRight;\r\n SetWindowLong(Control.Handle, GWL_EXSTYLE, OldLong or $00400000);\r\n end\r\n else\r\n SetWindowLong(Control.Handle, GWL_EXSTYLE, OldLong and not $00400000);\r\n Control.Repaint;\r\nend;\r\n\r\n//=== { TJvDBTreeViewDataLink } ==============================================\r\n\r\nconstructor TJvDBTreeViewDataLink.Create(ATreeView: TJvCustomDBTreeView);\r\nbegin\r\n inherited Create;\r\n FTreeView := ATreeView;\r\nend;\r\n\r\nprocedure TJvDBTreeViewDataLink.ActiveChanged;\r\nbegin\r\n FTreeView.LinkActive(Active);\r\nend;\r\n\r\nprocedure TJvDBTreeViewDataLink.RecordChanged(Field: TField);\r\nbegin\r\n FTreeView.InternalRecordChanged(Field);\r\nend;\r\n\r\nprocedure TJvDBTreeViewDataLink.DataSetChanged;\r\nbegin\r\n FTreeView.InternalDataChanged;\r\nend;\r\n\r\nprocedure TJvDBTreeViewDataLink.DataSetScrolled(Distance: Integer);\r\nbegin\r\n FTreeView.InternalDataScrolled;\r\nend;\r\n\r\n//=== { TJvDBTreeNode } ======================================================\r\n\r\nprocedure TJvDBTreeNode.MoveTo(Destination: TTreeNode; Mode: TNodeAttachMode);\r\nvar\r\n PersistNode: Boolean;\r\n TV: TJvCustomDBTreeView;\r\nbegin\r\n if Destination <> nil then\r\n begin\r\n // If we are trying to move ourselves in the same parent and we are\r\n // already the last child, there is no point in moving us.\r\n // It's even dangerous as it triggers Mantis 3934\r\n if not ((Parent = Destination) and (Self = Destination.GetLastChild) and (Mode = naAddChild)) then\r\n begin\r\n TV := TreeView as TJvCustomDBTreeView;\r\n PersistNode := TV.FPersistentNode;\r\n TV.MoveTo(Self as TJvDBTreeNode, Destination as TJvDBTreeNode, Mode);\r\n TV.FPersistentNode := True;\r\n if (Destination <> nil) and Destination.HasChildren and (Destination.Count = 0) then\r\n Free\r\n else\r\n inherited MoveTo(Destination, Mode);\r\n TV.FPersistentNode := PersistNode;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvDBTreeNode.SetMasterValue(AValue: Variant);\r\nbegin\r\n FMasterValue := AValue;\r\nend;\r\n\r\n//=== { TJvCustomDBTreeView } ================================================\r\n\r\nconstructor TJvCustomDBTreeView.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FDataLink := TJvDBTreeViewDataLink.Create(Self);\r\n TimerDnD := TTimer.Create(Self);\r\n TimerDnD.Enabled := False;\r\n TimerDnD.Interval := DnDInterval;\r\n TimerDnD.OnTimer := TimerDnDTimer;\r\n FStartMasterValue := Null;\r\n FSelectedIndex := 1;\r\n FMastersStream := nil;\r\nend;\r\n\r\ndestructor TJvCustomDBTreeView.Destroy;\r\nbegin\r\n FDataLink.Free;\r\n FDataLink := nil;\r\n TimerDnD.Free;\r\n FMastersStream.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvCustomDBTreeView.CheckDataSet;\r\nbegin\r\n if not ValidDataSet then\r\n raise EJvDBTreeViewError.CreateRes(@RsEDataSetNotActive);\r\nend;\r\n\r\nprocedure TJvCustomDBTreeView.Warning(Msg: string);\r\nbegin\r\n MessageDlg('TJvCustomDBTreeView.Warning()' + #13#10 + Name + ': ' + Msg, mtWarning, [mbOk], 0);\r\nend;\r\n\r\nfunction TJvCustomDBTreeView.ValidField(FieldName: string; AllowFieldTypes: TFieldTypes): Boolean;\r\nvar\r\n AField: TField;\r\nbegin\r\n Result := (csLoading in ComponentState) or (Length(FieldName) = 0) or\r\n (FDataLink.DataSet = nil) or not FDataLink.DataSet.Active;\r\n if not Result and (Length(FieldName) > 0) then\r\n begin\r\n AField := FDataLink.DataSet.FindField(FieldName); { no exceptions }\r\n Result := (AField <> nil) and (AField.DataType in AllowFieldTypes);\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomDBTreeView.SetMasterField(Value: string);\r\nbegin\r\n if ValidField(Value, DefaultValidMasterFields) then\r\n begin\r\n FMasterField := Value;\r\n RefreshChild(nil);\r\n end\r\n else\r\n Warning(RsMasterFieldError);\r\nend;\r\n\r\nprocedure TJvCustomDBTreeView.SetDetailField(Value: string);\r\nbegin\r\n if ValidField(Value, DefaultValidDetailFields) then\r\n begin\r\n FDetailField := Value;\r\n RefreshChild(nil);\r\n end\r\n else\r\n Warning(RsDetailFieldError);\r\nend;\r\n\r\nprocedure TJvCustomDBTreeView.SetItemField(Value: string);\r\nbegin\r\n if ValidField(Value, DefaultValidItemFields) then\r\n begin\r\n FItemField := Value;\r\n RefreshChild(nil);\r\n end\r\n else\r\n Warning(RsItemFieldError);\r\nend;\r\n\r\nprocedure TJvCustomDBTreeView.SetIconField(Value: string);\r\nbegin\r\n if ValidField(Value, DefaultValidIconFields) then\r\n begin\r\n FIconField := Value;\r\n RefreshChild(nil);\r\n end\r\n else\r\n Warning(RsIconFieldError);\r\nend;\r\n\r\nfunction TJvCustomDBTreeView.GetStartMasterValue: string;\r\nbegin\r\n if FStartMasterValue = Null then\r\n Result := ''\r\n else\r\n Result := FStartMasterValue;\r\nend;\r\n\r\nprocedure TJvCustomDBTreeView.SetStartMasterValue(Value: string);\r\nbegin\r\n if Length(Value) > 0 then\r\n FStartMasterValue := Value\r\n else\r\n FStartMasterValue := Null;\r\nend;\r\n\r\nfunction TJvCustomDBTreeView.GetDataSource: TDataSource;\r\nbegin\r\n Result := FDataLink.DataSource;\r\nend;\r\n\r\nprocedure TJvCustomDBTreeView.SetDataSource(Value: TDataSource);\r\nbegin\r\n if Value = FDataLink.DataSource then\r\n Exit;\r\n Items.Clear;\r\n if FDataLink.DataSource <> nil then\r\n FDataLink.DataSource.RemoveFreeNotification(Self);\r\n FDataLink.DataSource := Value;\r\n if Value <> nil then\r\n Value.FreeNotification(Self);\r\nend;\r\n\r\nprocedure TJvCustomDBTreeView.CMGetDataLink(var Msg: TMessage);\r\nbegin\r\n Msg.Result := LRESULT(FDataLink);\r\nend;\r\n\r\nprocedure TJvCustomDBTreeView.Notification(Component: TComponent; Operation: TOperation);\r\nbegin\r\n inherited Notification(Component, Operation);\r\n if (FDataLink <> nil) and (Component = DataSource) and (Operation = opRemove) then\r\n DataSource := nil;\r\nend;\r\n\r\nfunction TJvCustomDBTreeView.CreateNode: TTreeNode;\r\nbegin\r\n Result := TJvDBTreeNode.Create(Items);\r\nend;\r\n\r\nprocedure TJvCustomDBTreeView.HideEditor;\r\nbegin\r\n if Selected <> nil then\r\n Selected.EndEdit(True);\r\nend;\r\n\r\nfunction TJvCustomDBTreeView.ValidDataSet: Boolean;\r\nbegin\r\n Result := Assigned(FDataLink) and FDataLink.Active and Assigned(FDataLink.DataSet) and FDataLink.DataSet.Active;\r\nend;\r\n\r\nprocedure TJvCustomDBTreeView.LinkActive(Value: Boolean);\r\n\r\n function AllFieldsValid: Boolean;\r\n begin\r\n Result := False;\r\n if ValidDataSet then\r\n begin\r\n if (FMasterField = '') or (FDataLink.DataSet.FindField(FMasterField) = nil) then\r\n begin\r\n Warning(RsMasterFieldEmpty);\r\n Exit;\r\n end;\r\n if (FDetailField = '') or (FDataLink.DataSet.FindField(FDetailField) = nil) then\r\n begin\r\n Warning(RsDetailFieldEmpty);\r\n Exit;\r\n end;\r\n if (FItemField = '') or (FDataLink.DataSet.FindField(FItemField) = nil) then\r\n begin\r\n Warning(RsItemFieldEmpty);\r\n Exit;\r\n end;\r\n { if (FDataLink.DataSet.FindField(FMasterField).DataType <> FDataLink.DataSet.FindField(FDetailField).DataType) then\r\n begin\r\n Warning(RsMasterDetailFieldError);\r\n Exit;\r\n end; }\r\n if (FDataLink.DataSet.FindField(FItemField).DataType in\r\n [ftBytes, ftVarBytes, ftBlob, ftGraphic, ftFmtMemo, ftParadoxOle, ftDBaseOle, ftTypedBinary]) then\r\n begin\r\n Warning(RsItemFieldError);\r\n Exit;\r\n end;\r\n if (FIconField <> '') and not (FDataLink.DataSet.FindField(FIconField).DataType in\r\n [ftSmallInt, ftInteger, ftWord]) then\r\n begin\r\n Warning(RsIconFieldError);\r\n Exit;\r\n end;\r\n end;\r\n Result := True;\r\n end;\r\nbegin\r\n if not Value then\r\n HideEditor;\r\n if not AllFieldsValid then\r\n Exit;\r\n //if ( csDesigning in ComponentState ) then Exit;\r\n if ValidDataSet then\r\n begin\r\n RefreshChild(nil);\r\n OldRecCount := FDataLink.DataSet.RecordCount;\r\n end\r\n else\r\n if FUpdateLock = 0 then\r\n Items.Clear;\r\nend;\r\n\r\nprocedure TJvCustomDBTreeView.UpdateLock;\r\nbegin\r\n Inc(FUpdateLock);\r\nend;\r\n\r\nprocedure TJvCustomDBTreeView.UpdateUnLock(const AUpdateTree: Boolean);\r\nbegin\r\n if FUpdateLock > 0 then\r\n Dec(FUpdateLock);\r\n if (FUpdateLock = 0) then\r\n if AUpdateTree then\r\n UpdateTree\r\n else\r\n OldRecCount := FDataLink.DataSet.RecordCount;\r\nend;\r\n\r\nfunction TJvCustomDBTreeView.UpdateLocked: Boolean;\r\nbegin\r\n Result := FUpdateLock > 0;\r\nend;\r\n\r\nprocedure TJvCustomDBTreeView.RefreshChild(ANode: TJvDBTreeNode);\r\nvar\r\n ParentValue: Variant;\r\n BK: TBookmark;\r\n OldFilter: string;\r\n OldFiltered: Boolean;\r\n PV: string;\r\n // I: Integer;\r\n\r\n cNode: TTreeNode;\r\n fbnString: string;\r\nbegin\r\n// CheckDataSet;\r\n if not ValidDataSet or UpdateLocked then\r\n Exit;\r\n Inc(FUpdateLock);\r\n with FDataLink.DataSet do\r\n begin\r\n BK := GetBookmark;\r\n try\r\n DisableControls;\r\n if ANode <> nil then\r\n begin\r\n ANode.DeleteChildren;\r\n ParentValue := ANode.FMasterValue;\r\n end\r\n else\r\n begin\r\n Items.Clear;\r\n ParentValue := FStartMasterValue;\r\n end;\r\n OldFiltered := False;\r\n OldFilter := '';\r\n if FUseFilter then\r\n begin\r\n if ParentValue = Null then\r\n PV := 'Null'\r\n else\r\n PV := '''' + Var2Type(ParentValue, varString) + '''';\r\n OldFilter := Filter;\r\n OldFiltered := Filtered;\r\n if Filtered then\r\n Filter := '(' + OldFilter + ') and (' + FDetailField + '=' + PV + ')'\r\n else\r\n Filter := '(' + FDetailField + '=' + PV + ')';\r\n Filtered := True;\r\n end;\r\n try\r\n First;\r\n while not Eof do\r\n begin\r\n fbnString := FieldByName(FDetailField).AsString; // avoid overhead\r\n if FUseFilter or\r\n (((ParentValue = Null) and\r\n ((fbnString = '') or\r\n (Copy(Trim(fbnString), 1, 1) = '-'))) or\r\n (FieldByName(FDetailField).Value = ParentValue)) then\r\n begin\r\n with Items.AddChild(ANode, FieldByName(FItemField).Text) as TJvDBTreeNode do\r\n begin\r\n FMasterValue := FieldValues[FMasterField];\r\n if FIconField <> '' then\r\n begin\r\n ImageIndex := Var2Type(FieldValues[FIconField], varInteger);\r\n SelectedIndex := ImageIndex + FSelectedIndex;\r\n end;\r\n end;\r\n end;\r\n Next;\r\n end;\r\n finally\r\n if FUseFilter then\r\n begin\r\n Filtered := OldFiltered;\r\n Filter := OldFilter;\r\n end;\r\n end;\r\n if ANode = nil then\r\n begin\r\n cNode := Items.GetFirstNode;\r\n while Assigned(cNode) do\r\n with TJvDBTreeNode(cNode) do\r\n begin\r\n HasChildren := Lookup(FDetailField, FMasterValue, FDetailField) <> Null;\r\n cNode := cNode.GetNext;\r\n end;\r\n {\r\n // Peter Zolja - inefficient code, faster code above\r\n for I := 0 to Items.Count - 1 do\r\n with Items[I] as TJvDBTreeNode do\r\n HasChildren := Lookup(FDetailField, FMasterValue, FDetailField) <> Null\r\n }\r\n end\r\n else\r\n begin\r\n cNode := ANode.getFirstChild;\r\n while Assigned(cNode) do\r\n with TJvDBTreeNode(cNode) do\r\n begin\r\n HasChildren := Lookup(FDetailField, FMasterValue, FDetailField) <> Null;\r\n cNode := cNode.GetNext;\r\n end;\r\n {\r\n // Peter Zolja - inefficient code, faster code above\r\n for I := 0 to ANode.Count - 1 do\r\n with ANode[I] as TJvDBTreeNode do\r\n HasChildren := Lookup(FDetailField, FMasterValue, FDetailField) <> Null\r\n }\r\n end;\r\n if ANode <> nil then\r\n OldRecCount := RecordCount;\r\n finally\r\n try\r\n GotoBookmark(BK);\r\n FreeBookmark(BK);\r\n EnableControls;\r\n finally\r\n Dec(FUpdateLock);\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJvCustomDBTreeView.CanExpand(Node: TTreeNode): Boolean;\r\nbegin\r\n Result := inherited CanExpand(Node);\r\n if Result and (Node.Count = 0) then\r\n RefreshChild(Node as TJvDBTreeNode);\r\nend;\r\n\r\nprocedure TJvCustomDBTreeView.Collapse(Node: TTreeNode);\r\nvar\r\n HasChildren: Boolean;\r\nbegin\r\n inherited Collapse(Node);\r\n if not FPersistentNode then\r\n begin\r\n HasChildren := Node.HasChildren;\r\n Node.DeleteChildren;\r\n Node.HasChildren := HasChildren;\r\n end;\r\nend;\r\n\r\nfunction TJvCustomDBTreeView.FindNode(AMasterValue: Variant): TJvDBTreeNode;\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := 0 to Items.Count - 1 do\r\n begin\r\n Result := Items[I] as TJvDBTreeNode;\r\n if Result.FMasterValue = AMasterValue then\r\n Exit;\r\n end;\r\n Result := nil;\r\nend;\r\n\r\nfunction TJvCustomDBTreeView.SelectNode(AMasterValue: Variant): TTreeNode;\r\nvar\r\n V: Variant;\r\n Node: TJvDBTreeNode;\r\n Parents: Variant; {varArray}\r\n I: Integer;\r\n\r\n function GetDetailValue(const AMasterValue: Variant; var DetailValue: Variant): Boolean;\r\n var\r\n V: Variant;\r\n begin\r\n if Assigned(FGetDetailValue) then\r\n begin\r\n Result := FGetDetailValue(AMasterValue, DetailValue);\r\n if DetailValue = FStartMasterValue then\r\n raise EJvDBTreeViewError.CreateRes(@RsEErrorValueForDetailValue);\r\n end\r\n else\r\n begin\r\n V := FDataLink.DataSet.Lookup(FMasterField, AMasterValue, FMasterField + ';' + FDetailField);\r\n Result := ((VarType(V) and varArray) = varArray) and (V[1] <> Null);\r\n if Result then\r\n begin\r\n DetailValue := V[1];\r\n if DetailValue = FStartMasterValue then\r\n raise EJvDBTreeViewError.CreateRes(@RsEInternalError);\r\n end;\r\n end;\r\n end;\r\n\r\nbegin\r\n Result := FindNode(AMasterValue);\r\n if Result = nil then\r\n try\r\n // Inc(FUpdateLock);\r\n Parents := VarArrayCreate([0, 0], varVariant);\r\n V := AMasterValue;\r\n I := 0;\r\n repeat\r\n if not GetDetailValue(V, V) then\r\n Exit;\r\n Node := FindNode(V);\r\n if Node <> nil then\r\n begin\r\n { To open all branches from that found to the necessary [translated] }\r\n //..\r\n Node.Expand(False);\r\n while I > 0 do\r\n begin\r\n FindNode(Parents[I]).Expand(False);\r\n Dec(I);\r\n end;\r\n Result := FindNode(AMasterValue);\r\n end\r\n else\r\n begin\r\n { To add in the array of parents [translated] }\r\n Inc(I);\r\n VarArrayRedim(Parents, I);\r\n Parents[I] := V;\r\n end;\r\n until Node <> nil;\r\n finally\r\n // Dec(FUpdateLock);\r\n end;\r\n if Result <> nil then\r\n Result.Selected := True;\r\nend;\r\n\r\nprocedure TJvCustomDBTreeView.UpdateTree;\r\nvar\r\n I: Integer;\r\n BK: TBookmark;\r\n AllChecked: Boolean;\r\n\r\n procedure AddRecord;\r\n var\r\n Node, ParentNode: TJvDBTreeNode;\r\n begin\r\n { If the current record is absent from the tree, but it must be in it, then\r\n add [translated] }\r\n Node := FindNode(FDataLink.DataSet[FMasterField]);\r\n if Node = nil then\r\n begin\r\n ParentNode := FindNode(FDataLink.DataSet[FDetailField]);\r\n if (((ParentNode <> nil) and (not ParentNode.HasChildren or (ParentNode.Count <> 0))) or\r\n (FDataLink.DataSet[FDetailField] = FStartMasterValue)) then\r\n begin\r\n if FDataLink.DataSet[FDetailField] = FStartMasterValue then\r\n Node := nil\r\n else\r\n begin\r\n Node := FindNode(FDataLink.DataSet[FDetailField]);\r\n if (Node = nil) or (Node.HasChildren and (Node.Count = 0)) then\r\n Exit;\r\n end;\r\n with FDataLink.DataSet, Items.AddChild(Node, FDataLink.DataSet.FieldByName(FItemField).Text) as TJvDBTreeNode do\r\n begin\r\n FMasterValue := FieldValues[FMasterField];\r\n if FIconField <> '' then\r\n begin\r\n ImageIndex := Var2Type(FieldValues[FIconField], varInteger);\r\n SelectedIndex := ImageIndex + FSelectedIndex;\r\n end;\r\n HasChildren := Lookup(FDetailField, FMasterValue, FDetailField) <> Null\r\n end;\r\n end;\r\n end;\r\n end;\r\n\r\nbegin\r\n CheckDataSet;\r\n if UpdateLocked or (InTreeUpdate) then\r\n Exit;\r\n InTreeUpdate := True;\r\n Items.BeginUpdate;\r\n try\r\n with FDataLink.DataSet do\r\n begin\r\n BK := GetBookmark;\r\n DisableControls;\r\n try\r\n {*** To delete from a tree the remote/removed records [translated] }\r\n repeat\r\n AllChecked := True;\r\n for I := 0 to Items.Count - 1 do\r\n if not Locate(FMasterField, (Items[I] as TJvDBTreeNode).FMasterValue, []) then\r\n begin\r\n Items[I].Free;\r\n AllChecked := False;\r\n Break;\r\n end\r\n else\r\n Items[I].HasChildren := Lookup(FDetailField, (Items[I] as TJvDBTreeNode).FMasterValue, FDetailField) <>\r\n Null;\r\n until AllChecked;\r\n {###}\r\n {*** To add new [translated]}\r\n First;\r\n while not Eof do\r\n begin\r\n AddRecord;\r\n Next;\r\n end;\r\n {###}\r\n finally\r\n GotoBookmark(BK);\r\n FreeBookmark(BK);\r\n EnableControls;\r\n end;\r\n OldRecCount := RecordCount;\r\n end;\r\n finally\r\n Items.EndUpdate;\r\n InTreeUpdate := False;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomDBTreeView.InternalDataChanged;\r\nbegin\r\n if not HandleAllocated or UpdateLocked or InDataScrolled then\r\n Exit;\r\n// InDataScrolled := True;\r\n try\r\n DataChanged;\r\n finally\r\n// InDataScrolled := False;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomDBTreeView.DataChanged;\r\nvar\r\n RecCount: Integer;\r\nbegin\r\n case FDataLink.DataSet.State of\r\n dsBrowse:\r\n begin\r\n RecCount := FDataLink.DataSet.RecordCount;\r\n if (RecCount = -1) or (RecCount <> OldRecCount) then\r\n UpdateTree;\r\n OldRecCount := RecCount;\r\n end;\r\n dsInsert:\r\n OldRecCount := -1; { TQuery don't change RecordCount value after insert new record }\r\n end;\r\n Selected := FindNode(FDataLink.DataSet[FMasterField]);\r\nend;\r\n\r\nprocedure TJvCustomDBTreeView.InternalDataScrolled;\r\nbegin\r\n if not HandleAllocated or UpdateLocked then\r\n Exit;\r\n InDataScrolled := True;\r\n try\r\n DataScrolled;\r\n finally\r\n InDataScrolled := False;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomDBTreeView.DataScrolled;\r\nbegin\r\n Selected := FindNode(FDataLink.DataSet[FMasterField]);\r\nend;\r\n\r\nprocedure TJvCustomDBTreeView.Change(Node: TTreeNode);\r\nvar\r\n OldState: TDataSetState;\r\nbegin\r\n if ValidDataSet and Assigned(Node) and not InDataScrolled and\r\n (FUpdateLock = 0) and\r\n (FDataLink.DataSet.State in [dsBrowse, dsEdit, dsInsert]) then\r\n begin\r\n OldState := FDataLink.DataSet.State;\r\n Inc(FUpdateLock);\r\n try\r\n Change2(Node);\r\n finally\r\n Dec(FUpdateLock);\r\n end;\r\n case OldState of\r\n dsEdit:\r\n FDataLink.DataSet.Edit;\r\n dsInsert:\r\n FDataLink.DataSet.Insert;\r\n end;\r\n end;\r\n inherited Change(Node);\r\nend;\r\n\r\nprocedure TJvCustomDBTreeView.Change2(Node: TTreeNode);\r\nbegin\r\n if Node <> nil then\r\n begin\r\n if VarIsEmpty((Node as TJvDBTreeNode).FMasterValue) then\r\n Exit;\r\n FDataLink.DataSet.Locate(FMasterField, TJvDBTreeNode(Node).FMasterValue, []);\r\n if TJvDBTreeNode(Node).FMasterValue = Null then\r\n TJvDBTreeNode(Node).SetMasterValue(FDataLink.DataSet.FieldByName(MasterField).AsVariant);\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomDBTreeView.InternalRecordChanged(Field: TField);\r\nbegin\r\n if not (HandleAllocated and ValidDataSet) then\r\n Exit;\r\n if (Selected <> nil) and (FUpdateLock = 0) and\r\n (FDataLink.DataSet.State = dsEdit) then\r\n begin\r\n Inc(FUpdateLock);\r\n try\r\n RecordChanged(Field);\r\n finally\r\n Dec(FUpdateLock);\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomDBTreeView.RecordChanged(Field: TField);\r\nvar\r\n Node: TJvDBTreeNode;\r\nbegin\r\n Selected.Text := FDataLink.DataSet.FieldByName(FItemField).Text;\r\n with Selected as TJvDBTreeNode do\r\n if FIconField <> '' then\r\n begin\r\n ImageIndex := Var2Type(FDataLink.DataSet[FIconField], varInteger);\r\n SelectedIndex := ImageIndex + FSelectedIndex;\r\n end;\r\n {*** ParentNode changed ?}\r\n if ((Selected.Parent <> nil) and\r\n (FDataLink.DataSet[FDetailField] <> (Selected.Parent as TJvDBTreeNode).FMasterValue)) or\r\n ((Selected.Parent = nil) and\r\n (FDataLink.DataSet[FDetailField] <> FStartMasterValue)) then\r\n begin\r\n Node := FindNode(FDataLink.DataSet[FDetailField]);\r\n if (FDataLink.DataSet[FDetailField] = FStartMasterValue) or (Node <> nil) then\r\n (Selected as TJvDBTreeNode).MoveTo(Node, naAddChild)\r\n else\r\n Selected.Free;\r\n end;\r\n {###}\r\n {*** MasterValue changed ?}\r\n if (FDataLink.DataSet[FMasterField] <> (Selected as TJvDBTreeNode).FMasterValue) then\r\n begin\r\n with (Selected as TJvDBTreeNode) do\r\n begin\r\n FMasterValue := FDataLink.DataSet[FMasterField];\r\n if FIconField <> '' then\r\n begin\r\n ImageIndex := Var2Type(FDataLink.DataSet[FIconField], varInteger);\r\n SelectedIndex := ImageIndex + FSelectedIndex;\r\n end;\r\n end;\r\n {what have I do with Children ?}\r\n {if you know, place your code here...}\r\n end;\r\n {###}\r\nend;\r\n\r\nfunction TJvCustomDBTreeView.CanEdit(Node: TTreeNode): Boolean;\r\nbegin\r\n Result := inherited CanEdit(Node);\r\n if FDataLink.DataSet <> nil then\r\n Result := Result and not FDataLink.ReadOnly and not ReadOnly;\r\nend;\r\n\r\nprocedure TJvCustomDBTreeView.Edit(const Item: TTVItem);\r\nbegin\r\n CheckDataSet;\r\n inherited Edit(Item);\r\n if Assigned(Selected) then\r\n begin\r\n Inc(FUpdateLock);\r\n try\r\n if Item.pszText <> nil then\r\n begin\r\n if FDataLink.Edit then\r\n FDataLink.DataSet.FieldByName(FItemField).Text := Item.pszText;\r\n try\r\n FDataLink.DataSet.Post;\r\n Change2(Self.Selected); {?}\r\n except\r\n on E: Exception do\r\n begin\r\n DataLink.DataSet.Cancel;\r\n if InAddChild then\r\n begin\r\n Self.Selected.Free;\r\n if Sel <> nil then\r\n Selected := Sel;\r\n end;\r\n raise;\r\n end;\r\n end;\r\n end\r\n else\r\n begin\r\n FDataLink.DataSet.Cancel;\r\n if InAddChild then\r\n begin\r\n Self.Selected.Free;\r\n if Sel <> nil then\r\n Selected := Sel;\r\n end;\r\n end;\r\n finally\r\n InAddChild := False;\r\n Dec(FUpdateLock);\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJvCustomDBTreeView.AddChildNode(const Node: TTreeNode; const Select: Boolean): TJvDBTreeNode;\r\nvar\r\n MV, MField: Variant;\r\n M: string;\r\n iIndex: Integer;\r\nbegin\r\n iIndex := 1;\r\n CheckDataSet;\r\n if Assigned(Node) then\r\n begin\r\n MV := (Node as TJvDBTreeNode).FMasterValue;\r\n MField := FDataLink.DataSet.RecordCount + 1;\r\n repeat\r\n Inc(MField);\r\n until FDataLink.DataSet.Lookup(FMasterField, MField, FMasterField) = Null;\r\n end\r\n else\r\n begin\r\n MV := FStartMasterValue;\r\n MField := FStartMasterValue + 1;\r\n end;\r\n if Assigned(Node) and Node.HasChildren and (Node.Count = 0) then\r\n RefreshChild(Node as TJvDBTreeNode);\r\n Inc(FUpdateLock);\r\n InAddChild := True;\r\n try\r\n OldRecCount := FDataLink.DataSet.RecordCount + 1;\r\n if FIconField <> '' then\r\n begin\r\n iIndex := Var2Type(FDataLink.DataSet[FIconField], varInteger);\r\n end;\r\n\r\n FDataLink.DataSet.Append;\r\n FDataLink.DataSet[FDetailField] := MV;\r\n FDataLink.DataSet[FMasterField] := MField;\r\n if FDataLink.DataSet.FieldValues[FItemField] = Null then\r\n M := ''\r\n else\r\n M := FDataLink.DataSet.FieldByName(FItemField).Text;\r\n Result := Items.AddChild(Node, M) as TJvDBTreeNode;\r\n with Result do\r\n begin\r\n FMasterValue := FDataLink.DataSet.FieldValues[FMasterField];\r\n if FIconField <> '' then\r\n begin\r\n ImageIndex := iIndex;\r\n SelectedIndex := ImageIndex + FSelectedIndex;\r\n FDataLink.DataSet[FIconField] := ImageIndex;\r\n end;\r\n end;\r\n Result.Selected := Select;\r\n { This line is very necessary, well it(he) does not understand from the first [translated]}\r\n Result.Selected := Select;\r\n finally\r\n Dec(FUpdateLock);\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomDBTreeView.DeleteNode(Node: TTreeNode);\r\nvar\r\n NewSel: TTreeNode;\r\n NewMV: Variant;\r\n MV: Integer;\r\nbegin\r\n MV := 0;\r\n CheckDataSet;\r\n Inc(FUpdateLock);\r\n InDelete := True;\r\n try\r\n NewSel := FindNextNode(Selected);\r\n\r\n if NewSel = nil then\r\n begin\r\n NewSel := Items.GetFirstNode;\r\n if NewSel = Selected then\r\n NewSel := nil;\r\n end;\r\n\r\n if NewSel <> nil then\r\n begin\r\n NewMV := TJvDBTreeNode(NewSel).FMasterValue;\r\n MV := NewMV;\r\n end;\r\n\r\n DeleteChildren(Node);\r\n // Selected.Free; // removes selected node, why?\r\n\r\n NewSel := FindNode(MV);\r\n if NewSel <> nil then\r\n begin\r\n NewSel.Selected := True;\r\n Change2(NewSel);\r\n end;\r\n\r\n finally\r\n InDelete := False;\r\n Dec(FUpdateLock);\r\n end;\r\nend;\r\n\r\nfunction TJvCustomDBTreeView.DeleteChildren(ParentNode: TTreeNode): Boolean;\r\nvar\r\n ChildNode: TTreeNode;\r\nbegin\r\n CheckDataSet;\r\n Inc(FUpdateLock);\r\n InDelete := True;\r\n try\r\n with ParentNode as TJvDBTreeNode do\r\n begin\r\n while ParentNode.HasChildren do\r\n begin\r\n ChildNode := ParentNode.GetNext;\r\n // (rom) make it compile, but no idea if it is correct\r\n Self.DeleteChildren(ChildNode);\r\n end;\r\n\r\n if FDataLink.DataSet.Locate(FMasterField, TJvDBTreeNode(ParentNode).FMasterValue, []) then\r\n begin\r\n FDataLink.DataSet.Delete;\r\n end;\r\n ParentNode.Delete;\r\n end;\r\n\r\n finally\r\n InDelete := False;\r\n Dec(FUpdateLock);\r\n Result := true;\r\n end;\r\nend;\r\n\r\nfunction TJvCustomDBTreeView.FindNextNode(const Node: TTreeNode): TTreeNode;\r\nbegin\r\n if Node <> nil then\r\n begin\r\n if Node.Parent <> nil then\r\n if Node.Parent.Count > 1 then\r\n if Node.Index = Node.Parent.Count - 1 then\r\n Result := Node.Parent[Node.Index - 1]\r\n else\r\n Result := Node.Parent[Node.Index + 1]\r\n else\r\n Result := Node.Parent\r\n else\r\n if Items.Count > 1 then\r\n if Node.Index = Items.Count - 1 then\r\n Result := Items[Node.Index - 1]\r\n else\r\n Result := Items[Node.Index + 1]\r\n else\r\n Result := nil;\r\n end\r\n else\r\n Result := nil;\r\nend;\r\n\r\nprocedure TJvCustomDBTreeView.MoveTo(Source, Destination: TJvDBTreeNode; Mode: TNodeAttachMode);\r\nvar\r\n MV, V: Variant;\r\nbegin\r\n CheckDataSet;\r\n if FUpdateLock = 0 then\r\n begin\r\n Inc(FUpdateLock);\r\n try\r\n MV := Source.FMasterValue;\r\n if FDataLink.DataSet.Locate(FMasterField, MV, []) and FDataLink.Edit then\r\n begin\r\n case Mode of\r\n naAdd:\r\n if Destination.Parent <> nil then\r\n V := (Destination.Parent as TJvDBTreeNode).FMasterValue\r\n else\r\n V := FStartMasterValue;\r\n naAddChild:\r\n V := Destination.FMasterValue;\r\n else\r\n raise EJvDBTreeViewError.CreateRes(@RsEMoveToModeError);\r\n end;\r\n FDataLink.DataSet[FDetailField] := V;\r\n end;\r\n finally\r\n Dec(FUpdateLock);\r\n end;\r\n end;\r\nend;\r\n\r\n{******************* Drag'n'Drop ********************}\r\n\r\nprocedure TJvCustomDBTreeView.TimerDnDTimer(Sender: TObject);\r\nbegin\r\n if YDragPos < DnDScrollArea then\r\n Perform(WM_VSCROLL, SB_LINEUP, 0)\r\n else\r\n if YDragPos > ClientHeight - DnDScrollArea then\r\n Perform(WM_VSCROLL, SB_LINEDOWN, 0);\r\nend;\r\n\r\nprocedure TJvCustomDBTreeView.DragOver(Source: TObject; X, Y: Integer;\r\n State: TDragState; var Accept: Boolean);\r\nvar\r\n Node: TTreeNode;\r\n HT: THitTests;\r\nbegin\r\n inherited DragOver(Source, X, Y, State, Accept);\r\n\r\n if ValidDataSet and (DragMode = dmAutomatic) and not FDataLink.ReadOnly and\r\n not ReadOnly then\r\n begin\r\n HT := GetHitTestInfoAt(X, Y);\r\n Node := GetNodeAt(X, Y);\r\n\r\n { Mantis #4815: Do not allow drag over if the user callback said no; see TControl.DragOver impl. }\r\n if not Assigned(OnDragOver) then\r\n Accept := True;\r\n\r\n Accept := Accept and\r\n (Source = Self) and Assigned(Selected) and\r\n (Node <> Selected) and Assigned(Node) and\r\n not Node.HasAsParent(Selected) and\r\n (HT - [htOnLabel, htOnItem, htOnIcon, htNowhere, htOnIndent, htOnButton] <> HT);\r\n YDragPos := Y;\r\n TimerDnD.Enabled := ((Y < DnDScrollArea) or (Y > ClientHeight - DnDScrollArea));\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomDBTreeView.DragDrop(Source: TObject; X, Y: Integer);\r\nvar\r\n AnItem: TTreeNode;\r\n AttachMode: TNodeAttachMode;\r\n HT: THitTests;\r\nbegin\r\n TimerDnD.Enabled := False;\r\n inherited DragDrop(Source, X, Y);\r\n if Source is TJvCustomDBTreeView then\r\n begin\r\n AnItem := GetNodeAt(X, Y);\r\n if ValidDataSet and (DragMode = dmAutomatic) and Assigned(Selected) and Assigned(AnItem) then\r\n begin\r\n HT := GetHitTestInfoAt(X, Y);\r\n if (HT - [htOnItem, htOnLabel, htOnIcon, htNowhere, htOnIndent, htOnButton] <> HT) then\r\n begin\r\n if (HT - [htOnItem, htOnLabel, htOnIcon] <> HT) then\r\n AttachMode := naAddChild\r\n else\r\n AttachMode := naAdd;\r\n (Selected as TJvDBTreeNode).MoveTo(AnItem, AttachMode);\r\n end;\r\n end;\r\n end;\r\n{\r\nvar\r\n AnItem: TTreeNode;\r\n AttachMode: TNodeAttachMode;\r\n HT: THitTests;\r\nbegin\r\n if TreeView1.Selected = nil then\r\n Exit;\r\n HT := TreeView1.GetHitTestInfoAt(X, Y);\r\n AnItem := TreeView1.GetNodeAt(X, Y);\r\n if (HT - [htOnItem, htOnIcon, htNowhere, htOnIndent] <> HT) then\r\n begin\r\n if (htOnItem in HT) or (htOnIcon in HT) then\r\n AttachMode := naAddChild\r\n else\r\n if htNowhere in HT then\r\n AttachMode := naAdd\r\n else\r\n if htOnIndent in HT then\r\n AttachMode := naInsert;\r\n TreeView1.Selected.MoveTo(AnItem, AttachMode);\r\n end;\r\nend;\r\n }\r\nend;\r\n\r\n{################### Drag'n'Drop ####################}\r\n\r\nprocedure TJvCustomDBTreeView.KeyDown(var Key: Word; Shift: TShiftState);\r\n\r\n procedure DeleteSelected;\r\n var\r\n M: string;\r\n begin\r\n if Selected.HasChildren then\r\n M := RsDeleteNode2\r\n else\r\n M := RsDeleteNode;\r\n if MessageDlg(Format(M, [Selected.Text]), mtConfirmation, [mbYes, mbNo], 0) = mrYes then\r\n DeleteNode(Selected);\r\n end;\r\n\r\nbegin\r\n inherited KeyDown(Key, Shift);\r\n if not ValidDataSet or (FDataLink.ReadOnly) or ReadOnly then\r\n Exit;\r\n case Key of\r\n VK_DELETE:\r\n if ([ssCtrl] = Shift) and Assigned(Selected) then\r\n DeleteSelected;\r\n VK_INSERT:\r\n if not IsEditing then\r\n begin\r\n Sel := Selected;\r\n if not Assigned(Selected) or ([ssAlt] = Shift) then\r\n //AddChild\r\n AddChildNode(Selected, True).EditText\r\n else\r\n //Add\r\n AddChildNode(Selected.Parent, True).EditText;\r\n end;\r\n VK_F2:\r\n if Selected <> nil then\r\n Selected.EditText;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomDBTreeView.SetMirror(Value: Boolean);\r\nbegin\r\n if Value and SysLocale.MiddleEast and not (csDesigning in ComponentState) then\r\n MirrorControl(Self, Value);\r\n FMirror := Value;\r\nend;\r\n\r\n// Note about the code in CreateWnd/DestroyWnd: When docking/undocking a form\r\n// containing a DBTreeView, or even when showing/hiding such a form, the tree\r\n// is emptied then refilled. But this makes it lose all it's master values\r\n// The initial solution was to close then reopen the dataset, but this is\r\n// ungraceful and was replaced by the code below, proposed in issue 3256.\r\nprocedure TJvCustomDBTreeView.CreateWnd;\r\nvar\r\n Node: TTreeNode;\r\n temp: string;\r\n strLength: Integer;\r\n HasChildren: Byte;\r\nbegin\r\n inherited CreateWnd;\r\n // tree is restored. Now we must restore information about Master Values\r\n if Assigned(FMastersStream) and (Items.Count > 0) then\r\n begin\r\n Node := Items.GetFirstNode;\r\n FMastersStream.Position := 0;\r\n while Assigned(Node) do\r\n begin\r\n FMastersStream.Read(strLength, SizeOf(strLength));\r\n SetLength(temp, strLength);\r\n if strLength > 0 then\r\n FMastersStream.Read(temp[1], strLength * SizeOf(Char)); // internally used stream\r\n TJvDBTreeNode(Node).SetMasterValue(temp);\r\n FMastersStream.Read(HasChildren, SizeOf(HasChildren));\r\n Node.HasChildren := HasChildren <> 0;\r\n Node := Node.GetNext;\r\n end;\r\n // nil is required, for the destructor not to try to destroy an already\r\n // destroyed object;\r\n FreeAndNil(FMastersStream);\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomDBTreeView.DestroyWnd;\r\nvar\r\n Node: TTreeNode;\r\n temp: string;\r\n strLength: Integer;\r\n HasChildren: Byte;\r\nbegin\r\n if Items.Count > 0 then\r\n begin\r\n // save master values into stream\r\n FMastersStream := TMemoryStream.Create;\r\n Node := Items.GetFirstNode;\r\n while Assigned(Node) do\r\n begin\r\n // save MasterValue as string\r\n temp := VarToStr(TJvDBTreeNode(Node).MasterValue);\r\n strLength := Length(temp);\r\n FMastersStream.Write(strLength, SizeOf(strLength));\r\n if strLength > 0 then\r\n FMastersStream.Write(temp[1], strLength * SizeOf(Char)); // internally used stream\r\n HasChildren := Byte(Node.HasChildren);\r\n FMastersStream.Write(HasChildren, SizeOf(HasChildren));\r\n Node := Node.GetNext;\r\n end;\r\n end;\r\n inherited DestroyWnd;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvDBUltimGrid.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvDBUltimGrid.PAS, released on 2004-07-22.\r\n\r\nThe Initial Developers of the Original Code are: Frdric Leneuf-Magaud\r\nCopyright (c) 2004 Frdric Leneuf-Magaud\r\nAll Rights Reserved.\r\n\r\nContributors:\r\n Niels v/d Spek\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\n-----------------------------------------------------------------------------\r\nHOW TO SORT FIELDS:\r\n-----------------------------------------------------------------------------\r\n\r\n---= Delphi example =---\r\n\r\n// Don't forget to set SortWith and assign OnIndexNotFound/OnUserSort if needed\r\n\r\nvar\r\n MyFields: TSortFields;\r\n\r\nSetLength(MyFields, 2);\r\nMyFields[0].Name := 'Country';\r\nMyFields[0].Order := JvGridSort_ASC;\r\nMyFields[1].Name := 'Sales';\r\nMyFields[1].Order := JvGridSort_DESC;\r\nMyUltimGrid.Sort(MyFields);\r\n\r\nif not MyUltimGrid.SortOK then ...\r\n\r\n---= BCB example =---\r\n\r\n// Don't forget to set SortWith and assign OnIndexNotFound/OnUserSort if needed\r\n\r\nTSortFields MyFields;\r\n\r\nMyFields.set_length(2);\r\nMyFields[0].Name = \"Country\";\r\nMyFields[0].Order = JvGridSort_ASC;\r\nMyFields[1].Name = \"Sales\";\r\nMyFields[1].Order = JvGridSort_DESC;\r\nMyUltimGrid->Sort(MyFields);\r\n\r\nif (!MyUltimGrid->SortOK) ...\r\n\r\n---= MANUAL SORTING =---\r\n\r\nif TitleButtons is true then...\r\n\r\nFirst click = the selected field is sorted in ascending order\r\nSecond click = the selected field is sorted in descending order\r\nShift+Click / Ctrl+Click = multi-column sorting\r\n\r\n-----------------------------------------------------------------------------\r\nHOW TO SEARCH A VALUE:\r\n-----------------------------------------------------------------------------\r\n\r\n---= Delphi example =---\r\n\r\nvar\r\n // Declare these vars as global vars if you want to use SearchNext\r\n ResultCol: Integer;\r\n ResultField: TField;\r\n\r\nwith MyUltimGrid do\r\nbegin\r\n SearchFields.Clear;\r\n SearchFields.Add('Category');\r\n SearchFields.Add('Common_Name');\r\n SearchFields.Add('Species Name');\r\n SearchFields.Add('Notes');\r\n if not Search('fish', ResultCol, ResultField, False, False, True) then ...\r\nend;\r\n\r\n// then:\r\nif not MyUltimGrid.SearchNext(ResultCol, ResultField, False, False, True) then ...\r\n\r\n---= BCB example =---\r\n\r\n// Declare these vars as global vars if you want to use SearchNext\r\nint ResultCol;\r\nTField *ResultField;\r\n\r\nMyUltimGrid->SearchFields->Clear();\r\nMyUltimGrid->SearchFields->Add(\"Category\");\r\nMyUltimGrid->SearchFields->Add(\"Common_Name\");\r\nMyUltimGrid->SearchFields->Add(\"Species Name\");\r\nMyUltimGrid->SearchFields->Add(\"Notes\");\r\nif (!MyUltimGrid->Search(\"fish\", ResultCol, ResultField, false, false, true)) ...\r\n\r\n// then:\r\nif (!MyUltimGrid->SearchNext(ResultCol, ResultField, false, false, true)) ...\r\n\r\n-----------------------------------------------------------------------------\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvDBUltimGrid.pas 13263 2012-02-29 14:08:36Z obones $\r\n\r\nunit JvDBUltimGrid;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, Variants, Classes, SysUtils, Graphics, Controls, DB,\r\n JvDBGrid; {JvTypes contains Exception base class}\r\n\r\nconst\r\n JvGridSort_ASC = True;\r\n JvGridSort_UP = True;\r\n JvGridSort_DESC = False;\r\n JvGridSort_DOWN = False;\r\n\r\ntype\r\n TSortField = record\r\n Name: string;\r\n Order: Boolean;\r\n end;\r\n TSortFields = array of TSortField;\r\n\r\n TJvDBUltimGrid = class;\r\n TIndexNotFoundEvent = procedure(Sender: TJvDBUltimGrid; FieldsToSort: TSortFields;\r\n IndexFieldNames: string; DescFields: string; var Retry: Boolean) of object;\r\n TUserSortEvent = procedure(Sender: TJvDBUltimGrid; var FieldsToSort: TSortFields;\r\n SortString: string; var SortOK: Boolean) of object;\r\n TRestoreGridPosEvent = procedure(Sender: TJvDBUltimGrid; SavedBookmark: TBookmark;\r\n SavedRowPos: Integer) of object;\r\n TCheckIfValidSortFieldEvent = function(Sender: TJvDBUltimGrid;\r\n FieldToSort: TField): Boolean of object;\r\n TGetSortFieldNameEvent = procedure(Sender: TJvDBUltimGrid; var FieldName: string) of object;\r\n\r\n TSortWith = (swIndex, swFields, swClient, swUserFunc, swWhere);\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvDBUltimGrid = class(TJvDBGrid)\r\n private\r\n FSortedFields: TSortFields;\r\n FSortWith: TSortWith;\r\n FSortOK: Boolean;\r\n FRestoreOnSort: Boolean;\r\n FSortExcludedFields: string;\r\n FMasterFields: string;\r\n FIndexCounter: Cardinal;\r\n\r\n FMultiColSort: Boolean;\r\n FOnIndexNotFound: TIndexNotFoundEvent;\r\n FOnUserSort: TUserSortEvent;\r\n FOnCheckIfValidSortField: TCheckIfValidSortFieldEvent;\r\n FSavedBookmark: {$IFDEF RTL200_UP}TBookmark{$ELSE}TBookmarkStr{$ENDIF RTL200_UP};\r\n FSavedRowPos: Integer;\r\n FOnRestoreGridPosition: TRestoreGridPosEvent;\r\n FValueToSearch: Variant;\r\n FSearchFields: TStringList;\r\n FOnGetSortFieldName: TGetSortFieldNameEvent;\r\n FOnAfterSort: TNotifyEvent;\r\n procedure SetMultiColSort(const Value: Boolean);\r\n function PrivateSearch(var ResultCol: Integer; var ResultField: TField;\r\n const CaseSensitive, WholeFieldOnly, Next: Boolean): Boolean;\r\n procedure SetSortExcludedFields(const Value: string);\r\n procedure SetMasterFields(const Value: string);\r\n protected\r\n function SortMarkerAssigned(const AFieldName: string): Boolean; override;\r\n procedure DoTitleClick(ACol: Longint; AField: TField); override;\r\n procedure GetSortFieldName(var FieldName: string); virtual;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n procedure Sort(FieldsToSort: TSortFields);\r\n property SortedFields: TSortFields read FSortedFields;\r\n property SortOK: Boolean read FSortOK;\r\n procedure SaveGridPosition;\r\n procedure RestoreGridPosition(Mode: TResyncMode = [rmExact, rmCenter]);\r\n property SearchFields: TStringList read FSearchFields write FSearchFields;\r\n function Search(const ValueToSearch: Variant; var ResultCol: Integer;\r\n var ResultField: TField; const CaseSensitive, WholeFieldOnly, Focus: Boolean): Boolean;\r\n function SearchNext(var ResultCol: Integer; var ResultField: TField;\r\n const CaseSensitive, WholeFieldOnly, Focus: Boolean): Boolean;\r\n // Reset any sorting is done so far. Then user can sort dataset using a sorting dataset property\r\n procedure ClearSortedFields;\r\n published\r\n property SortedField stored False; // Property of JvDBGrid not used in JvDBUltimGrid\r\n property SortMarker stored False; // Property of JvDBGrid hidden in JvDBUltimGrid\r\n\r\n { SortWith:\r\n swIndex : for BDE tables (assignment of OnIndexNotFound is recommended)\r\n swFields : for ADO tables\r\n swClient : for ClientDataSets\r\n swUserFunc : for other data providers (assignment of OnUserSort is mandatory) }\r\n property SortWith: TSortWith read FSortWith write FSortWith default swIndex;\r\n\r\n { MultiColSort: is the sorting allowed on several columns or only one ? }\r\n property MultiColSort: Boolean read FMultiColSort write SetMultiColSort default True;\r\n\r\n { Current record position is restored after sorting }\r\n property RestoreOnSort: Boolean read FRestoreOnSort write FRestoreOnSort default True;\r\n { User can exclude columns from sorting. 'Fieldname1;Fieldname2;Fieldname3' }\r\n property SortExcludedFields: string read FSortExcludedFields write SetSortExcludedFields;\r\n\r\n { Fix problem on detail dataset when insert record after you have click title to sort }\r\n { Needed for detail datasets in a master/detail relationship }\r\n property MasterFields: string read FMasterFields write SetMasterFields;\r\n\r\n { OnIndexNotFound: fired when SortWith = swIndex and the sorting index is not found }\r\n property OnIndexNotFound: TIndexNotFoundEvent read FOnIndexNotFound write FOnIndexNotFound;\r\n\r\n { OnUserSort: fired when SortWith = swUserFunc }\r\n property OnUserSort: TUserSortEvent read FOnUserSort write FOnUserSort;\r\n\r\n { OnCheckIfValidSortField allows to define your own checking routine for sorting fields }\r\n property OnCheckIfValidSortField: TCheckIfValidSortFieldEvent\r\n read FOnCheckIfValidSortField write FOnCheckIfValidSortField;\r\n\r\n { OnRestoreGridPosition: fired when RestoreGridPosition is called }\r\n property OnRestoreGridPosition: TRestoreGridPosEvent\r\n read FOnRestoreGridPosition write FOnRestoreGridPosition;\r\n\r\n { OnGetSortFieldName: allows to override the sort marker field }\r\n property OnGetSortFieldName: TGetSortFieldNameEvent read FOnGetSortFieldName Write FOnGetSortFieldName;\r\n \r\n { OnAfterSort: fired after the table was sorted. }\r\n property OnAfterSort: TNotifyEvent read FOnAfterSort write FOnAfterSort;\r\n end;\r\n\r\n EJvDBUltimGrid = class(Exception);\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvDBUltimGrid.pas $';\r\n Revision: '$Revision: 13263 $';\r\n Date: '$Date: 2012-02-29 15:08:36 +0100 (mer. 29 févr. 2012) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n TypInfo, Forms, DBGrids,\r\n JclStrings, JclSysUtils,\r\n JvResources, JvJCLUtils, JvDBUtils;\r\n\r\nconstructor TJvDBUltimGrid.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FSortedFields := nil;\r\n FSortWith := swIndex;\r\n FSortOK := True;\r\n FMultiColSort := True;\r\n FOnIndexNotFound := nil;\r\n FOnUserSort := nil;\r\n FRestoreOnSort := True;\r\n FSavedBookmark := {$IFDEF RTL200_UP}nil{$ELSE}''{$ENDIF RTL200_UP};\r\n FSavedRowPos := 0;\r\n FOnRestoreGridPosition := nil;\r\n FValueToSearch := Null;\r\n FSearchFields := TStringList.Create;\r\nend;\r\n\r\ndestructor TJvDBUltimGrid.Destroy;\r\nbegin\r\n FSearchFields.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJvDBUltimGrid.SortMarkerAssigned(const AFieldName: string): Boolean;\r\nvar\r\n SF: Integer;\r\n SortFieldName: string;\r\nbegin\r\n Result := False;\r\n if Assigned(FSortedFields) then\r\n begin\r\n SortFieldName := AFieldName;\r\n { Let the user override the sort marker field }\r\n GetSortFieldName(SortFieldName);\r\n\r\n for SF := 0 to Length(FSortedFields) - 1 do\r\n if AnsiSameText(SortFieldName, FSortedFields[SF].Name) then\r\n begin\r\n if FSortedFields[SF].Order = JvGridSort_UP then\r\n inherited ChangeSortMarker(smUp)\r\n else\r\n inherited ChangeSortMarker(smDown);\r\n Result := True;\r\n Break;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvDBUltimGrid.Sort(FieldsToSort: TSortFields);\r\nconst\r\n cIndexDefs = 'IndexDefs';\r\n cIndexName = 'IndexName';\r\n cIndexFieldNames = 'IndexFieldNames';\r\nvar\r\n DSet: TDataSet;\r\n\r\n procedure UpdateProp(const PropName: string; const Value: string; SortField: TField);\r\n var\r\n Error: Boolean;\r\n begin\r\n // Workaround for ADO 10 KB key limitation\r\n Error := (SortWith = swFields) and // swFields: for ADO tables\r\n (SortField.DataType in [ftString, ftWideString]) and\r\n (SortField.DataSize > 9361);\r\n\r\n if not Error then \r\n begin\r\n SetStrProp(DSet, PropName, Value);\r\n FSortedFields := FieldsToSort;\r\n FSortOK := True;\r\n end \r\n else\r\n begin \r\n FSortOK := False;\r\n end;\r\n end;\r\n\r\nvar\r\n SortString, DescString: string;\r\n MaxFTS: Integer;\r\n\r\n procedure SearchIndex(SortField: TField);\r\n var\r\n IndexDefs: TIndexDefs;\r\n I, J: Integer;\r\n begin\r\n IndexDefs := TIndexDefs(GetOrdProp(DSet, cIndexDefs));\r\n IndexDefs.Update;\r\n for I := 0 to IndexDefs.Count - 1 do\r\n if AnsiSameText(SortString, IndexDefs.Items[I].Fields) then\r\n begin\r\n // The search succeeds if:\r\n // - no descending order is requested\r\n // and the index found has no desc fields nor the flag ixDescending set to true\r\n // - descending order is requested\r\n // and the index found has exactly the same desc fields\r\n // - descending order is requested\r\n // and the index found has no desc fields but its flag ixDescending is true\r\n if DescString = '' then\r\n begin\r\n if (IndexDefs.Items[I].DescFields = '') and\r\n not (ixDescending in IndexDefs.Items[I].Options) then\r\n begin\r\n UpdateProp(cIndexName, IndexDefs.Items[I].Name, SortField);\r\n Break;\r\n end;\r\n end\r\n else\r\n if AnsiSameText(DescString, IndexDefs.Items[I].DescFields) then\r\n begin\r\n UpdateProp(cIndexName, IndexDefs.Items[I].Name, SortField);\r\n Break;\r\n end\r\n else\r\n if (IndexDefs.Items[I].DescFields = '') and\r\n (ixDescending in IndexDefs.Items[I].Options) then\r\n begin\r\n for J := 0 to MaxFTS do\r\n FieldsToSort[J].Order := JvGridSort_DESC;\r\n UpdateProp(cIndexName, IndexDefs.Items[I].Name, SortField);\r\n Break;\r\n end;\r\n end;\r\n end;\r\n\r\n procedure SetClientIndex(SortField: TField);\r\n const\r\n cIndexPrefix = '_Idx_';\r\n var\r\n IndexDefs: TIndexDefs;\r\n I: Integer;\r\n NewIndexName: string;\r\n begin\r\n IndexDefs := TIndexDefs(GetOrdProp(DSet, cIndexDefs));\r\n IndexDefs.Update;\r\n { Search for an existing index... }\r\n for I := 0 to IndexDefs.Count - 1 do begin\r\n if (Pos(cIndexPrefix, IndexDefs.Items[I].Name) = 1) and // Search among the indexes this procedure creates by itselt.\r\n (AnsiSameText(SortString, IndexDefs.Items[I].Fields)) and\r\n (AnsiSameText(DescString, IndexDefs.Items[I].DescFields))\r\n then begin\r\n NewIndexName := IndexDefs.Items[I].Name;\r\n UpdateProp(cIndexName, NewIndexName, SortField);\r\n Break;\r\n end\r\n end;\r\n { ... or else create a new one }\r\n Inc(FIndexCounter);\r\n NewIndexName := cIndexPrefix + IntToStr(FIndexCounter{IndexDefs.Count});\r\n with IndexDefs.AddIndexDef do begin\r\n Name := NewIndexName;\r\n Fields := SortString;\r\n CaseInsFields := SortString;\r\n DescFields := DescString;\r\n end;\r\n UpdateProp(cIndexName, NewIndexName, SortField);\r\n end;\r\n\r\nvar\r\n FTS: Integer;\r\n SortField: TField;\r\n Retry: Boolean;\r\n FieldIsValid: Boolean;\r\nbegin\r\n // Test for dataset class compatibility with respect to sort method\r\n case SortWith of\r\n swIndex:\r\n if not InheritsFromByName(DataSource.DataSet.ClassType, 'TTable') then\r\n raise EJvDBUltimGrid.Create('Only TTable or derived classes or allowed for SortWith = swIndex');\r\n swFields:\r\n if not InheritsFromByName(DataSource.DataSet.ClassType, 'TCustomADODataSet') then\r\n raise EJvDBUltimGrid.Create('Only TCustomADODataSet or derived classes or allowed for SortWith = swFields');\r\n swClient:\r\n if not InheritsFromByName(DataSource.DataSet.ClassType, 'TCustomClientDataSet') then\r\n raise EJvDBUltimGrid.Create('Only TCustomClientDataSet or derived classes or allowed for SortWith = swClient');\r\n swUserFunc: ;\r\n swWhere: ;\r\n end;\r\n\r\n FSortOK := False;\r\n if Assigned(DataLink) and DataLink.Active and Assigned(FieldsToSort) then\r\n begin\r\n // Dataset must be in browse mode\r\n DSet := DataSource.DataSet;\r\n DSet.CheckBrowseMode;\r\n\r\n if FRestoreOnSort then\r\n SaveGridPosition;\r\n\r\n // Checking of OnUserSort assignment\r\n if Assigned(OnUserSort) then\r\n SortWith := swUserFunc;\r\n if (SortWith = swUserFunc) and not Assigned(OnUserSort) then\r\n raise EJVCLDbGridException.CreateRes(@RsEJvDBGridUserSortNotAssigned);\r\n\r\n // Checking of index properties\r\n if (SortWith in [swIndex, swClient]) and\r\n not (IsPublishedProp(DSet, cIndexDefs) and IsPublishedProp(DSet, cIndexName)) then\r\n raise EJVCLDbGridException.CreateRes(@RsEJvDBGridIndexPropertyMissing)\r\n else\r\n if (SortWith = swFields) and\r\n not IsPublishedProp(DSet, cIndexFieldNames) then\r\n raise EJVCLDbGridException.CreateRes(@RsEJvDBGridIndexPropertyMissing);\r\n\r\n // Sorting\r\n Screen.Cursor := crHourGlass;\r\n DSet.DisableControls;\r\n try\r\n SortString := '';\r\n\r\n {*** FMasterFields needed for:\r\n - ADO datasets in a master/detail relationship for the detail dataset.\r\n - TClientDataSets with Provider or else TClientDataSets loses recordset.\r\n ( Not tested for BDE tables )\r\n ***}\r\n if (SortWith in [swFields, swClient]) and (FMasterFields <> '') then\r\n SortString := FMasterFields;\r\n\r\n DescString := '';\r\n MaxFTS := Length(FieldsToSort) - 1;\r\n for FTS := 0 to MaxFTS do\r\n begin\r\n FieldsToSort[FTS].Name := Trim(FieldsToSort[FTS].Name);\r\n SortField := nil; // to avoid warning\r\n if SortWith <> swWhere then\r\n begin\r\n SortField := DSet.FieldByName(FieldsToSort[FTS].Name);\r\n if Assigned(OnCheckIfValidSortField) then\r\n FieldIsValid := OnCheckIfValidSortField(Self, SortField)\r\n else\r\n FieldIsValid := not (SortField is TBlobField) and not (SortField is TBytesField)\r\n and ((SortField.FieldKind = fkData) or (SortField.FieldKind = fkInternalCalc));\r\n if not FieldIsValid then\r\n begin\r\n // No sorting of binary or special fields\r\n if BeepOnError then\r\n begin\r\n SysUtils.Beep;\r\n Continue;\r\n end\r\n else\r\n raise EJVCLDbGridException.CreateRes(@RsEJvDBGridBadFieldKind);\r\n end;\r\n end;\r\n\r\n if SortWith = swIndex then\r\n begin\r\n // Sort with index\r\n if SortString <> '' then\r\n SortString := SortString + ';';\r\n SortString := SortString + FieldsToSort[FTS].Name;\r\n if FieldsToSort[FTS].Order = JvGridSort_DESC then\r\n begin\r\n if DescString <> '' then\r\n DescString := DescString + ';';\r\n DescString := DescString + FieldsToSort[FTS].Name;\r\n end;\r\n if FTS = MaxFTS then\r\n begin\r\n SearchIndex(SortField);\r\n if not SortOK then\r\n begin\r\n if Assigned(OnIndexNotFound) then\r\n begin\r\n Retry := False;\r\n OnIndexNotFound(Self, FieldsToSort, SortString, DescString, Retry);\r\n if Retry then\r\n begin\r\n SearchIndex(SortField);\r\n if not SortOK then\r\n raise EJVCLDbGridException.CreateRes(@RsEJvDBGridIndexMissing);\r\n end;\r\n end\r\n else\r\n raise EJVCLDbGridException.CreateRes(@RsEJvDBGridIndexMissing);\r\n end;\r\n end;\r\n end\r\n else\r\n\r\n if SortWith = swClient then\r\n begin\r\n // Sort with IndexName\r\n if SortString <> '' then\r\n SortString := SortString + ';';\r\n SortString := SortString + FieldsToSort[FTS].Name;\r\n if FieldsToSort[FTS].Order = JvGridSort_DESC then\r\n begin\r\n if DescString <> '' then\r\n DescString := DescString + ';';\r\n DescString := DescString + FieldsToSort[FTS].Name;\r\n end;\r\n if FTS = MaxFTS then\r\n begin\r\n SetClientIndex(SortField);\r\n if not SortOK then\r\n begin\r\n { }\r\n end;\r\n end;\r\n end\r\n\r\n else\r\n if SortWith in [swFields, swUserFunc, swWhere] then\r\n begin\r\n // Sort with fields (temporary index), user function or where clausel\r\n if SortString <> '' then\r\n SortString := SortString + ',';\r\n if SortWith = swWhere then\r\n SortString := SortString + FieldsToSort[FTS].Name\r\n else\r\n SortString := SortString + '[' + FieldsToSort[FTS].Name + ']';\r\n\r\n if FieldsToSort[FTS].Order = JvGridSort_ASC then\r\n SortString := SortString + ' ASC'\r\n else\r\n SortString := SortString + ' DESC';\r\n if FTS = MaxFTS then\r\n begin\r\n if SortWith = swUserFunc then\r\n begin\r\n OnUserSort(Self, FieldsToSort, SortString, FSortOK);\r\n if SortOK then\r\n FSortedFields := FieldsToSort;\r\n end\r\n else\r\n UpdateProp(cIndexFieldNames, SortString, SortField);\r\n end;\r\n end;\r\n end;\r\n if FSortOK and Assigned(FOnAfterSort) then\r\n FOnAfterSort(Self);\r\n finally\r\n DSet.EnableControls;\r\n Screen.Cursor := crDefault;\r\n end;\r\n\r\n if FRestoreOnSort then\r\n RestoreGridPosition([rmExact]); // Position current record on top.\r\n// RestoreGridPosition; // Center current record.\r\n end;\r\nend;\r\n\r\nprocedure TJvDBUltimGrid.SetMultiColSort(const Value: Boolean);\r\nbegin\r\n if FMultiColSort <> Value then\r\n begin\r\n FMultiColSort := Value;\r\n if Assigned(FSortedFields) and not FMultiColSort then\r\n begin\r\n SetLength(FSortedFields, 1);\r\n Sort(FSortedFields);\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvDBUltimGrid.SetSortExcludedFields(const Value: string);\r\nbegin\r\n if FSortExcludedFields <> Value then\r\n FSortExcludedFields := StringReplace(Trim(Value), ';', ',', [rfReplaceAll]);\r\nend;\r\n\r\nprocedure TJvDBUltimGrid.SetMasterFields(const Value: string);\r\nbegin\r\n if FMasterFields <> Value then\r\n FMasterFields := StringReplace(Trim(Value), ';', ',', [rfReplaceAll]);\r\nend;\r\n\r\nprocedure TJvDBUltimGrid.ClearSortedFields;\r\nvar\r\n SF: Integer;\r\nbegin\r\n if Assigned(FSortedFields) then\r\n begin\r\n for SF := 0 to Length(FSortedFields) - 1 do\r\n ChangeSortMarker(smNone);\r\n SetLength(FSortedFields, 0);\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvDBUltimGrid.DoTitleClick(ACol: Longint; AField: TField);\r\nvar\r\n Keys: TKeyboardState;\r\n Found, ShiftOrCtrlKeyPressed: Boolean;\r\n SortArraySize: Integer;\r\n FieldsToSort: TSortFields;\r\n I: Integer;\r\n SortFieldName: string;\r\n\r\n function IsExcluded(F: TField): Boolean;\r\n var\r\n I: Integer;\r\n begin\r\n Result:=False;\r\n if FSortExcludedFields <> '' then\r\n for I:=1 to WordCount(FSortExcludedFields, [',']) do\r\n if AnsiSameText(F.FieldName, Trim(ExtractWord(I, FSortExcludedFields, [',']))) then \r\n begin\r\n Result := True;\r\n Exit;\r\n end;\r\n end;\r\n\r\nbegin\r\n FSortOK := False;\r\n try\r\n if AutoSort and Assigned(AField) and not IsExcluded(AField) then\r\n begin\r\n Found := False;\r\n SortArraySize := 1;\r\n\r\n SortFieldName := AField.FieldName;\r\n { Let the user override the sort marker field }\r\n GetSortFieldName(SortFieldName);\r\n\r\n if Assigned(FSortedFields) then\r\n begin\r\n ShiftOrCtrlKeyPressed := MultiColSort and GetKeyboardState(Keys);\r\n if ShiftOrCtrlKeyPressed then\r\n ShiftOrCtrlKeyPressed :=\r\n (((Keys[VK_SHIFT] and $80) <> 0) or ((Keys[VK_CONTROL] and $80) <> 0));\r\n SetLength(FieldsToSort, Length(FSortedFields));\r\n for I := 0 to Length(FSortedFields) - 1 do\r\n begin\r\n FieldsToSort[I].Name := FSortedFields[I].Name;\r\n if AnsiSameText(SortFieldName, FSortedFields[I].Name) then\r\n begin\r\n Found := True;\r\n if not ShiftOrCtrlKeyPressed then\r\n begin\r\n SetLength(FieldsToSort, 1);\r\n FieldsToSort[0].Name := SortFieldName;\r\n FieldsToSort[0].Order := not FSortedFields[I].Order;\r\n Break;\r\n end\r\n else\r\n FieldsToSort[I].Order := not FSortedFields[I].Order;\r\n end\r\n else\r\n FieldsToSort[I].Order := FSortedFields[I].Order;\r\n end;\r\n if (not Found) and ShiftOrCtrlKeyPressed then\r\n SortArraySize := Length(FSortedFields) + 1;\r\n end;\r\n if not Found then\r\n begin\r\n SetLength(FieldsToSort, SortArraySize);\r\n FieldsToSort[SortArraySize - 1].Name := SortFieldName;\r\n FieldsToSort[SortArraySize - 1].Order := JvGridSort_ASC;\r\n end;\r\n Sort(FieldsToSort);\r\n end;\r\n finally\r\n if Assigned(OnTitleBtnClick) then\r\n OnTitleBtnClick(Self, ACol, AField);\r\n end;\r\nend;\r\n\r\nprocedure TJvDBUltimGrid.GetSortFieldName(var FieldName: string);\r\nbegin\r\n if Assigned(FOnGetSortFieldName) then\r\n FOnGetSortFieldName(Self, FieldName);\r\nend;\r\n\r\nprocedure TJvDBUltimGrid.SaveGridPosition;\r\nbegin\r\n FSavedBookmark := DataLink.DataSet.Bookmark;\r\n FSavedRowPos := DataLink.ActiveRecord;\r\nend;\r\n\r\nprocedure TJvDBUltimGrid.RestoreGridPosition(Mode: TResyncMode = [rmExact, rmCenter]);\r\nbegin\r\n if Assigned(FOnRestoreGridPosition) then\r\n begin\r\n if DataLink.DataSet.BookmarkValid(Pointer(FSavedBookmark)) then\r\n GotoBookmarkEx(DataLink.DataSet, Pointer(FSavedBookmark), [rmExact], False);\r\n\r\n DataLink.ActiveRecord := FSavedRowPos;\r\n FOnRestoreGridPosition(Self, Pointer(FSavedBookmark), FSavedRowPos);\r\n end\r\n else\r\n if DataLink.DataSet.BookmarkValid(Pointer(FSavedBookmark)) then\r\n GotoBookmarkEx(DataLink.DataSet, Pointer(FSavedBookmark), Mode, False);\r\nend;\r\n\r\nfunction TJvDBUltimGrid.PrivateSearch(var ResultCol: Integer; var ResultField: TField;\r\n const CaseSensitive, WholeFieldOnly, Next: Boolean): Boolean;\r\nvar\r\n DSet: TDataSet;\r\n Start, ColNo, I: Integer;\r\n Found: Boolean;\r\n FieldText: string;\r\n ValueToSearchStr: string;\r\nbegin\r\n Result := False;\r\n if Assigned(DataLink) and DataLink.Active then\r\n begin\r\n Screen.Cursor := crHourGlass;\r\n DSet := DataSource.DataSet;\r\n DSet.DisableControls;\r\n try\r\n // Start location\r\n SaveGridPosition;\r\n if Next then\r\n begin\r\n Start := Col;\r\n if not (dgIndicator in Options) then\r\n Inc(Start);\r\n end\r\n else\r\n begin\r\n Start := 0;\r\n DSet.First;\r\n end;\r\n\r\n ValueToSearchStr := VarToStr(FValueToSearch);\r\n // The search begins...\r\n while not DSet.Eof do\r\n begin\r\n for ColNo := Start to Columns.Count - 1 do\r\n for I := 0 to SearchFields.Count - 1 do\r\n begin\r\n if AnsiSameText(SearchFields[I], Columns[ColNo].FieldName) then\r\n with Columns[ColNo].Field do\r\n begin\r\n if Assigned(OnGetText) then\r\n FieldText := DisplayText\r\n else\r\n FieldText := AsString;\r\n if FieldText <> '' then\r\n begin\r\n // Search inside the field content\r\n if CaseSensitive then\r\n begin\r\n if WholeFieldOnly then\r\n Found := AnsiSameStr(ValueToSearchStr, FieldText)\r\n else\r\n Found := StrSearch(ValueToSearchStr, FieldText) > 0;\r\n end\r\n else\r\n begin\r\n if WholeFieldOnly then\r\n Found := AnsiSameText(ValueToSearchStr, FieldText)\r\n else\r\n Found := StrFind(ValueToSearchStr, FieldText) > 0;\r\n end;\r\n\r\n // Text found ! -> exit\r\n if Found then\r\n begin\r\n ResultCol := ColNo;\r\n if dgIndicator in Options then\r\n Inc(ResultCol);\r\n ResultField := Columns[ColNo].Field;\r\n Result := True;\r\n Exit;\r\n end;\r\n end;\r\n end;\r\n end;\r\n Start := 0;\r\n DSet.Next;\r\n end;\r\n finally\r\n DSet.EnableControls;\r\n Screen.Cursor := crDefault;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJvDBUltimGrid.Search(const ValueToSearch: Variant; var ResultCol: Integer;\r\n var ResultField: TField; const CaseSensitive, WholeFieldOnly, Focus: Boolean): Boolean;\r\nbegin\r\n Result := False;\r\n if (SearchFields.Count > 0) and (ValueToSearch <> Null) and (ValueToSearch <> '') then\r\n begin\r\n FValueToSearch := ValueToSearch;\r\n Result := PrivateSearch(ResultCol, ResultField, CaseSensitive, WholeFieldOnly, False);\r\n if Result then\r\n begin\r\n Self.Col := ResultCol;\r\n if Focus and Self.Visible and Self.CanFocus then\r\n Self.SetFocus;\r\n end\r\n else\r\n RestoreGridPosition;\r\n end;\r\nend;\r\n\r\nfunction TJvDBUltimGrid.SearchNext(var ResultCol: Integer; var ResultField: TField;\r\n const CaseSensitive, WholeFieldOnly, Focus: Boolean): Boolean;\r\nbegin\r\n Result := False;\r\n if (SearchFields.Count > 0) and (FValueToSearch <> Null) and (FValueToSearch <> '') then\r\n begin\r\n Result := PrivateSearch(ResultCol, ResultField, CaseSensitive, WholeFieldOnly, True);\r\n if Result then\r\n begin\r\n Self.Col := ResultCol;\r\n if Focus and Self.Visible and Self.CanFocus then\r\n Self.SetFocus;\r\n end\r\n else\r\n RestoreGridPosition;\r\n end;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend." }, { "path": "External/Jedi/Jvcl/run/JvDBUtils.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvDBUtils.PAS, released on 2002-07-04.\r\n\r\nThe Initial Developers of the Original Code are: Fedor Koshevnikov, Igor Pavluk and Serge Korolev\r\nCopyright (c) 1997, 1998 Fedor Koshevnikov, Igor Pavluk and Serge Korolev\r\nCopyright (c) 2001,2002 SGB Software\r\nAll Rights Reserved.\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nContributors:\r\ntia\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvDBUtils.pas 13415 2012-09-10 09:51:54Z obones $\r\n\r\nunit JvDBUtils;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n {$IFDEF MSWINDOWS}\r\n Windows,\r\n {$ENDIF MSWINDOWS}\r\n Variants, Classes, SysUtils, DB,\r\n JvAppStorage;\r\n\r\ntype\r\n IJvDataControl = interface\r\n ['{8B6910C8-D5FD-40BA-A427-FC54FE7B85E5}']\r\n function GetDataLink: TDataLink;\r\n end;\r\n\r\n TJvDataLink = class(TDataLink)\r\n protected\r\n procedure FocusControl(Field: TFieldRef); overload; override;\r\n procedure FocusControl(const Field: TField); reintroduce; overload; virtual;\r\n end;\r\n\r\n TCommit = (ctNone, ctStep, ctAll);\r\n TJvDBProgressEvent = procedure(UserData: Integer; var Cancel: Boolean; Line: Integer) of object;\r\n\r\n EJvScriptError = class(Exception)\r\n private\r\n FErrPos: Integer;\r\n public\r\n // The dummy parameter is only there for BCB compatibility so that\r\n // when the hpp file gets generated, this constructor generates\r\n // a C++ constructor that doesn't already exist\r\n constructor Create(const AMessage: string; AErrPos: Integer; DummyForBCB: Integer = 0); overload;\r\n property ErrPos: Integer read FErrPos;\r\n end;\r\n\r\n TJvLocateObject = class(TObject)\r\n private\r\n FDataSet: TDataSet;\r\n FLookupField: TField;\r\n FLookupValue: string;\r\n FLookupExact: Boolean;\r\n FCaseSensitive: Boolean;\r\n FBookmark: TBookmark;\r\n FIndexSwitch: Boolean;\r\n procedure SetDataSet(Value: TDataSet);\r\n protected\r\n function MatchesLookup(Field: TField): Boolean;\r\n procedure CheckFieldType(Field: TField); virtual;\r\n procedure ActiveChanged; virtual;\r\n function LocateFilter: Boolean; virtual;\r\n function LocateKey: Boolean; virtual;\r\n function LocateFull: Boolean; virtual;\r\n function UseKey: Boolean; virtual;\r\n function FilterApplicable: Boolean; virtual;\r\n property LookupField: TField read FLookupField;\r\n property LookupValue: string read FLookupValue;\r\n property LookupExact: Boolean read FLookupExact;\r\n property CaseSensitive: Boolean read FCaseSensitive;\r\n property Bookmark: TBookmark read FBookmark write FBookmark;\r\n public\r\n function Locate(const KeyField, KeyValue: string; Exact,\r\n CaseSensitive: Boolean; DisableControls: Boolean = True;\r\n RightTrimmedLookup: Boolean = False): Boolean;\r\n property DataSet: TDataSet read FDataSet write SetDataSet;\r\n property IndexSwitch: Boolean read FIndexSwitch write FIndexSwitch;\r\n end;\r\n\r\n TCreateLocateObject = function: TJvLocateObject;\r\n\r\nvar\r\n CreateLocateObject: TCreateLocateObject = nil;\r\n\r\nfunction CreateLocate(DataSet: TDataSet): TJvLocateObject;\r\n\r\n{ Utility routines }\r\n\r\nfunction ExtractFieldNameEx(const Fields: {$IFDEF COMPILER10_UP} WideString {$ELSE} string {$ENDIF};\r\n var Pos: Integer): string;\r\nfunction IsDataSetEmpty(DataSet: TDataSet): Boolean;\r\nprocedure RefreshQuery(Query: TDataSet);\r\nfunction DataSetSortedSearch(DataSet: TDataSet;\r\n const Value, FieldName: string; CaseInsensitive: Boolean): Boolean;\r\nfunction DataSetSectionName(DataSet: TDataSet): string;\r\nprocedure InternalSaveFields(DataSet: TDataSet; AppStorage: TJvCustomAppStorage; const Path: string);\r\nprocedure InternalRestoreFields(DataSet: TDataSet; AppStorage: TJvCustomAppStorage;\r\n const Path: string; RestoreVisible: Boolean);\r\nfunction DataSetLocateThrough(DataSet: TDataSet; const KeyFields: string;\r\n const KeyValues: Variant; Options: TLocateOptions): Boolean;\r\n(*\r\nprocedure SaveFieldsReg(DataSet: TDataSet; IniFile: TRegIniFile);\r\nprocedure RestoreFieldsReg(DataSet: TDataSet; IniFile: TRegIniFile;\r\n RestoreVisible: Boolean);\r\n*)\r\nprocedure SaveFields(DataSet: TDataSet; AppStorage: TJvCustomAppStorage; const Path: string = '');\r\nprocedure RestoreFields(DataSet: TDataSet; AppStorage: TJvCustomAppStorage; const Path: string = '';\r\n RestoreVisible: Boolean = True);\r\nprocedure AssignRecord(Source, Dest: TDataSet; ByName: Boolean);\r\nfunction ConfirmDelete: Boolean;\r\nprocedure ConfirmDataSetCancel(DataSet: TDataSet);\r\nprocedure CheckRequiredField(Field: TField);\r\nprocedure CheckRequiredFields(const Fields: array of TField);\r\nprocedure GotoBookmarkEx(DataSet: TDataSet; const Bookmark: TBookmark; Mode: TResyncMode = [rmExact, rmCenter]; ForceScrollEvents: Boolean = False);\r\n\r\n{ SQL expressions }\r\n\r\nfunction DateToSQL(Value: TDateTime): string;\r\nfunction FormatSQLDateRange(Date1, Date2: TDateTime;\r\n const FieldName: string): string;\r\nfunction FormatSQLDateRangeEx(Date1, Date2: TDateTime;\r\n const FieldName: string): string;\r\nfunction FormatSQLNumericRange(const FieldName: string;\r\n LowValue, HighValue, LowEmpty, HighEmpty: Double; Inclusive: Boolean): string;\r\nfunction StrMaskSQL(const Value: string): string;\r\nfunction FormatSQLCondition(const FieldName, Operator, Value: string;\r\n FieldType: TFieldType; Exact: Boolean): string;\r\nfunction FormatAnsiSQLCondition(const FieldName, Operator, Value: string;\r\n FieldType: TFieldType; Exact: Boolean): string;\r\n\r\nconst\r\n TrueExpr = '0=0';\r\n {$NODEFINE TrueExpr}\r\n\r\nconst\r\n { Server Date formats}\r\n sdfStandard16 = '''\"''mm''/''dd''/''yyyy''\"'''; {\"mm/dd/yyyy\"}\r\n sdfStandard32 = '''''''dd/mm/yyyy'''''''; {'dd/mm/yyyy'}\r\n sdfOracle = '\"TO_DATE(''\"dd/mm/yyyy\"'', ''DD/MM/YYYY'')\"';\r\n sdfInterbase = '\"CAST(''\"mm\"/\"dd\"/\"yyyy\"'' AS DATE)\"';\r\n sdfMSSQL = '\"CONVERT(datetime, ''\"mm\"/\"dd\"/\"yyyy\"'', 103)\"';\r\n\r\nconst\r\n ServerDateFmt: string = sdfStandard16;\r\n\r\n{.$NODEFINE ftNonTextTypes}\r\n(*$HPPEMIT 'namespace JvDBUtils'*)\r\n(*$HPPEMIT '{'*)\r\n(*$HPPEMIT '#define ftNonTextTypes (System::Set () \\'*)\r\n(*$HPPEMIT ' << ftBytes << ftVarBytes << ftBlob << ftMemo << ftGraphic \\'*)\r\n(*$HPPEMIT ' << ftFmtMemo << ftParadoxOle << ftDBaseOle << ftTypedBinary << ftCursor )'*)\r\n(*$HPPEMIT '}'*)\r\n\r\ntype\r\n Largeint = Longint;\r\n {$NODEFINE Largeint}\r\n\r\nfunction NameDelimiter(C: Char): Boolean;\r\nfunction IsLiteral(C: Char): Boolean;\r\nprocedure _DBError(const Msg: string);\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvDBUtils.pas $';\r\n Revision: '$Revision: 13415 $';\r\n Date: '$Date: 2012-09-10 11:51:54 +0200 (lun. 10 sept. 2012) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n DBConsts, Math, Controls, Forms, Dialogs,\r\n {$IFDEF HAS_UNIT_SYSTEM_UITYPES}\r\n System.UITypes,\r\n {$ENDIF}\r\n {$IFDEF RTL240_UP}\r\n System.Generics.Collections,\r\n {$ENDIF RTL240_UP}\r\n JvJVCLUtils, JvJCLUtils, JvTypes, JvConsts, JvResources;\r\n\r\n{ TJvDataLink }\r\n\r\nprocedure TJvDataLink.FocusControl(Field: TFieldRef);\r\nbegin\r\n FocusControl(Field^);\r\nend;\r\n\r\nprocedure TJvDataLink.FocusControl(const Field: TField);\r\nbegin\r\nend;\r\n\r\n{ Utility routines }\r\n\r\nfunction NameDelimiter(C: Char): Boolean;\r\nbegin\r\n Result := CharInSet(C, [' ', ',', ';', ')', '.', Cr, Lf]);\r\nend;\r\n\r\nfunction IsLiteral(C: Char): Boolean;\r\nbegin\r\n Result := CharInSet(C, ['''', '\"']);\r\nend;\r\n\r\nprocedure _DBError(const Msg: string);\r\nbegin\r\n DatabaseError(Msg);\r\nend;\r\n\r\nconstructor EJvScriptError.Create(const AMessage: string; AErrPos: Integer; DummyForBCB: Integer);\r\nbegin\r\n inherited Create(AMessage);\r\n FErrPos := AErrPos;\r\nend;\r\n\r\n// (rom) better use Windows dialogs which are localized\r\n\r\nfunction ConfirmDelete: Boolean;\r\nbegin\r\n Screen.Cursor := crDefault;\r\n Result := MessageDlg(SDeleteRecordQuestion, mtConfirmation,\r\n [mbYes, mbNo], 0) = mrYes;\r\nend;\r\n\r\nprocedure ConfirmDataSetCancel(DataSet: TDataSet);\r\nbegin\r\n if DataSet.State in [dsEdit, dsInsert] then\r\n begin\r\n DataSet.UpdateRecord;\r\n if DataSet.Modified then\r\n begin\r\n case MessageDlg(RsConfirmSave, mtConfirmation, mbYesNoCancel, 0) of\r\n mrYes:\r\n DataSet.Post;\r\n mrNo:\r\n DataSet.Cancel;\r\n else\r\n SysUtils.Abort;\r\n end;\r\n end\r\n else\r\n DataSet.Cancel;\r\n end;\r\nend;\r\n\r\nfunction SetToBookmark(ADataSet: TDataSet; ABookmark: TBookmark): Boolean;\r\nbegin\r\n Result := False;\r\n if ADataSet.Active and (ABookmark <> nil) and not (ADataSet.Bof and ADataSet.Eof) and\r\n ADataSet.BookmarkValid(ABookmark) then\r\n try\r\n ADataSet.GotoBookmark(ABookmark);\r\n Result := True;\r\n except\r\n end;\r\nend;\r\n\r\n{ Refresh Query procedure }\r\n\r\nprocedure RefreshQuery(Query: TDataSet);\r\nvar\r\n BookMk: TBookmark;\r\nbegin\r\n Query.DisableControls;\r\n try\r\n if Query.Active then\r\n BookMk := Query.GetBookmark\r\n else\r\n BookMk := nil;\r\n try\r\n Query.Close;\r\n Query.Open;\r\n SetToBookmark(Query, BookMk);\r\n finally\r\n if BookMk <> nil then\r\n Query.FreeBookmark(BookMk);\r\n end;\r\n finally\r\n Query.EnableControls;\r\n end;\r\nend;\r\n\r\nprocedure TJvLocateObject.SetDataSet(Value: TDataSet);\r\nbegin\r\n ActiveChanged;\r\n FDataSet := Value;\r\nend;\r\n\r\nfunction TJvLocateObject.LocateFull: Boolean;\r\nbegin\r\n Result := False;\r\n DataSet.First;\r\n while not DataSet.Eof do\r\n begin\r\n if MatchesLookup(FLookupField) then\r\n begin\r\n Result := True;\r\n Break;\r\n end;\r\n DataSet.Next;\r\n end;\r\nend;\r\n\r\nfunction TJvLocateObject.LocateKey: Boolean;\r\nbegin\r\n Result := False;\r\nend;\r\n\r\nfunction TJvLocateObject.FilterApplicable: Boolean;\r\nbegin\r\n Result := FLookupField.FieldKind in [fkData, fkInternalCalc];\r\nend;\r\n\r\nfunction TJvLocateObject.LocateFilter: Boolean;\r\nvar\r\n SaveCursor: TCursor;\r\n Options: TLocateOptions;\r\n Value: Variant;\r\nbegin\r\n SaveCursor := Screen.Cursor;\r\n Screen.Cursor := crHourGlass;\r\n try\r\n Options := [];\r\n if not FCaseSensitive then\r\n Include(Options, loCaseInsensitive);\r\n if not FLookupExact then\r\n Include(Options, loPartialKey);\r\n if FLookupValue = '' then\r\n VarClear(Value)\r\n else\r\n Value := FLookupValue;\r\n Result := DataSet.Locate(FLookupField.FieldName, Value, Options);\r\n finally\r\n Screen.Cursor := SaveCursor;\r\n end;\r\nend;\r\n\r\nprocedure TJvLocateObject.CheckFieldType(Field: TField);\r\nbegin\r\nend;\r\n\r\nfunction TJvLocateObject.Locate(const KeyField, KeyValue: string;\r\n Exact, CaseSensitive: Boolean; DisableControls: Boolean; RightTrimmedLookup: Boolean): Boolean;\r\nvar\r\n LookupKey: TField;\r\n\r\n function IsStringType(FieldType: TFieldType): Boolean;\r\n const\r\n cStringTypes = [ftString, ftWideString];\r\n begin\r\n Result := FieldType in cStringTypes;\r\n end;\r\n\r\nbegin\r\n if DataSet = nil then\r\n begin\r\n Result := False;\r\n Exit;\r\n end;\r\n DataSet.CheckBrowseMode;\r\n LookupKey := DataSet.FieldByName(KeyField);\r\n DataSet.CursorPosChanged;\r\n FLookupField := LookupKey;\r\n if RightTrimmedLookup then\r\n FLookupValue := TrimRight(KeyValue)\r\n else\r\n FLookupValue := KeyValue;\r\n FLookupExact := Exact;\r\n FCaseSensitive := CaseSensitive;\r\n if not IsStringType(FLookupField.DataType) then\r\n begin\r\n FCaseSensitive := True;\r\n try\r\n CheckFieldType(FLookupField);\r\n except\r\n Result := False;\r\n Exit;\r\n end;\r\n end\r\n else\r\n FCaseSensitive := CaseSensitive;\r\n if DisableControls then\r\n DataSet.DisableControls;\r\n try\r\n FBookmark := DataSet.GetBookmark;\r\n try\r\n Result := MatchesLookup(FLookupField);\r\n if not Result then\r\n begin\r\n if UseKey then\r\n Result := LocateKey\r\n else\r\n begin\r\n if FilterApplicable then\r\n Result := LocateFilter\r\n else\r\n Result := LocateFull;\r\n end;\r\n if not Result then\r\n SetToBookmark(DataSet, FBookmark);\r\n end;\r\n finally\r\n FLookupValue := '';\r\n FLookupField := nil;\r\n DataSet.FreeBookmark(FBookmark);\r\n FBookmark := nil;\r\n end;\r\n finally\r\n if DisableControls then\r\n DataSet.EnableControls;\r\n end;\r\nend;\r\n\r\nfunction TJvLocateObject.UseKey: Boolean;\r\nbegin\r\n Result := False;\r\nend;\r\n\r\nprocedure TJvLocateObject.ActiveChanged;\r\nbegin\r\nend;\r\n\r\nfunction TJvLocateObject.MatchesLookup(Field: TField): Boolean;\r\nvar\r\n Temp: string;\r\nbegin\r\n Temp := Field.AsString;\r\n if not LookupExact then\r\n SetLength(Temp, Min(Length(FLookupValue), Length(Temp)));\r\n if CaseSensitive then\r\n Result := AnsiSameStr(Temp, LookupValue)\r\n else\r\n Result := AnsiSameText(Temp, LookupValue);\r\nend;\r\n\r\nfunction CreateLocate(DataSet: TDataSet): TJvLocateObject;\r\nbegin\r\n if Assigned(CreateLocateObject) then\r\n Result := CreateLocateObject\r\n else\r\n Result := TJvLocateObject.Create;\r\n if (Result <> nil) and (DataSet <> nil) then\r\n Result.DataSet := DataSet;\r\nend;\r\n\r\n{ DataSet locate routines }\r\n\r\nfunction DataSetLocateThrough(DataSet: TDataSet; const KeyFields: string;\r\n const KeyValues: Variant; Options: TLocateOptions): Boolean;\r\nvar\r\n FieldCount: Integer;\r\n Fields: TList{$IFDEF RTL240_UP}{$ENDIF RTL240_UP};\r\n Bookmark: {$IFDEF RTL200_UP}TBookmark{$ELSE}TBookmarkStr{$ENDIF RTL200_UP};\r\n\r\n function CompareField(Field: TField; const Value: Variant): Boolean;\r\n var\r\n S: string;\r\n begin\r\n if Field.DataType in [ftString{$IFDEF UNICODE}, ftWideString{$ENDIF UNICODE}] then\r\n begin\r\n if Value = Null then\r\n Result := Field.IsNull\r\n else\r\n begin\r\n S := Field.AsString;\r\n if loPartialKey in Options then\r\n Delete(S, Length(Value) + 1, MaxInt);\r\n if loCaseInsensitive in Options then\r\n Result := AnsiSameText(S, Value)\r\n else\r\n Result := AnsiSameStr(S, Value);\r\n end;\r\n end\r\n else\r\n Result := (Field.Value = Value);\r\n end;\r\n\r\n function CompareRecord: Boolean;\r\n var\r\n I: Integer;\r\n begin\r\n // Works with the KeyValues variant like TCustomClientDataSet.LocateRecord\r\n if (FieldCount = 1) and not VarIsArray(KeyValues) then\r\n Result := CompareField(TField(Fields[0]), KeyValues)\r\n else\r\n begin\r\n Result := True;\r\n for I := 0 to FieldCount - 1 do\r\n Result := Result and CompareField(TField(Fields[I]), KeyValues[I]);\r\n end;\r\n end;\r\n\r\nbegin\r\n Result := False;\r\n DataSet.CheckBrowseMode;\r\n if DataSet.IsEmpty then\r\n Exit;\r\n Fields := TList{$IFDEF RTL240_UP}{$ENDIF RTL240_UP}.Create;\r\n try\r\n DataSet.GetFieldList(Fields, KeyFields);\r\n FieldCount := Fields.Count;\r\n Result := CompareRecord;\r\n if Result then\r\n Exit;\r\n DataSet.DisableControls;\r\n try\r\n Bookmark := DataSet.Bookmark;\r\n try\r\n DataSet.First;\r\n while not DataSet.Eof do\r\n begin\r\n Result := CompareRecord;\r\n if Result then\r\n Break;\r\n DataSet.Next;\r\n end;\r\n finally\r\n if not Result and DataSet.BookmarkValid(TBookmark(Bookmark)) then\r\n DataSet.Bookmark := Bookmark;\r\n end;\r\n finally\r\n DataSet.EnableControls;\r\n end;\r\n finally\r\n Fields.Free;\r\n end;\r\nend;\r\n\r\n{ DataSetSortedSearch. Navigate on sorted DataSet routine. }\r\n\r\nfunction DataSetSortedSearch(DataSet: TDataSet; const Value,\r\n FieldName: string; CaseInsensitive: Boolean): Boolean;\r\nvar\r\n L, H, I: Longint;\r\n CurrentPos: Longint;\r\n CurrentValue: string;\r\n BookMk: TBookmark;\r\n Field: TField;\r\n\r\n function UpStr(const Value: string): string;\r\n begin\r\n if CaseInsensitive then\r\n Result := AnsiUpperCase(Value)\r\n else\r\n Result := Value;\r\n end;\r\n\r\n function GetCurrentStr: string;\r\n begin\r\n Result := Field.AsString;\r\n if Length(Result) > Length(Value) then\r\n SetLength(Result, Length(Value));\r\n Result := UpStr(Result);\r\n end;\r\n\r\nbegin\r\n Result := False;\r\n if DataSet = nil then\r\n Exit;\r\n Field := DataSet.FindField(FieldName);\r\n if Field = nil then\r\n Exit;\r\n if Field.DataType in [ftString{$IFDEF UNICODE}, ftWideString{$ENDIF UNICODE}] then\r\n begin\r\n DataSet.DisableControls;\r\n BookMk := DataSet.GetBookmark;\r\n try\r\n L := 0;\r\n DataSet.First;\r\n CurrentPos := 0;\r\n H := DataSet.RecordCount - 1;\r\n if Value <> '' then\r\n begin\r\n while L <= H do\r\n begin\r\n I := (L + H) shr 1;\r\n if I <> CurrentPos then\r\n DataSet.MoveBy(I - CurrentPos);\r\n CurrentPos := I;\r\n CurrentValue := GetCurrentStr;\r\n if UpStr(Value) > CurrentValue then\r\n L := I + 1\r\n else\r\n begin\r\n H := I - 1;\r\n if UpStr(Value) = CurrentValue then\r\n Result := True;\r\n end;\r\n end;\r\n if Result then\r\n begin\r\n if L <> CurrentPos then\r\n DataSet.MoveBy(L - CurrentPos);\r\n while (L < DataSet.RecordCount) and\r\n (UpStr(Value) <> GetCurrentStr) do\r\n begin\r\n Inc(L);\r\n DataSet.MoveBy(1);\r\n end;\r\n end;\r\n end\r\n else\r\n Result := True;\r\n if not Result then\r\n SetToBookmark(DataSet, BookMk);\r\n finally\r\n DataSet.FreeBookmark(BookMk);\r\n DataSet.EnableControls;\r\n end;\r\n end\r\n else\r\n DatabaseErrorFmt(SFieldTypeMismatch, [Field.DisplayName]);\r\nend;\r\n\r\n{ Save and restore DataSet Fields layout }\r\n\r\nfunction DataSetSectionName(DataSet: TDataSet): string;\r\nbegin\r\n if (DataSet.Owner <> nil) and (DataSet.Owner is TCustomForm) then\r\n Result := GetDefaultSection(DataSet.Owner as TCustomForm)\r\n else\r\n Result := DataSet.Name;\r\nend;\r\n\r\nfunction CheckSection(DataSet: TDataSet; const Section: string): string;\r\nbegin\r\n Result := Section;\r\n if Result = '' then\r\n Result := DataSetSectionName(DataSet);\r\nend;\r\n\r\nprocedure InternalSaveFields(DataSet: TDataSet; AppStorage: TJvCustomAppStorage; const Path: string);\r\nvar\r\n I: Integer;\r\n Field: TField;\r\nbegin\r\n AppStorage.BeginUpdate;\r\n try\r\n for I := 0 to DataSet.FieldCount - 1 do\r\n begin\r\n Field := DataSet.Fields[i];\r\n AppStorage.WriteString(AppStorage.ConcatPaths([CheckSection(DataSet, Path),\r\n DataSet.Name + Field.FieldName]),\r\n Format('%d,%d,%d', [Field.Index, Field.DisplayWidth, Integer(Field.Visible)]));\r\n end;\r\n finally\r\n AppStorage.EndUpdate;\r\n end;\r\nend;\r\n\r\nprocedure InternalRestoreFields(DataSet: TDataSet; AppStorage: TJvCustomAppStorage;\r\n const Path: string; RestoreVisible: Boolean);\r\ntype\r\n TFieldInfo = record\r\n Field: TField;\r\n EndIndex: Integer;\r\n end;\r\n TFieldArray = array of TFieldInfo;\r\nconst\r\n Delims = [' ', ','];\r\nvar\r\n I, J: Integer;\r\n S: string;\r\n FieldArray: TFieldArray;\r\nbegin\r\n SetLength(FieldArray, DataSet.FieldCount);\r\n AppStorage.BeginUpdate;\r\n try\r\n for I := 0 to DataSet.FieldCount - 1 do\r\n begin\r\n S := AppStorage.ReadString(AppStorage.ConcatPaths([CheckSection(DataSet, Path),\r\n DataSet.Name + DataSet.Fields[I].FieldName]), '');\r\n FieldArray[I].Field := DataSet.Fields[I];\r\n FieldArray[I].EndIndex := DataSet.Fields[I].Index;\r\n if S <> '' then\r\n begin\r\n FieldArray[I].EndIndex := StrToIntDef(ExtractWord(1, S, Delims),\r\n FieldArray[I].EndIndex);\r\n DataSet.Fields[I].DisplayWidth := StrToIntDef(ExtractWord(2, S, Delims),\r\n DataSet.Fields[I].DisplayWidth);\r\n if RestoreVisible then\r\n DataSet.Fields[I].Visible := Boolean(StrToIntDef(ExtractWord(3, S, Delims),\r\n Integer(DataSet.Fields[I].Visible)));\r\n end;\r\n end;\r\n for I := 0 to DataSet.FieldCount - 1 do\r\n begin\r\n for J := 0 to DataSet.FieldCount - 1 do\r\n begin\r\n if FieldArray[J].EndIndex = I then\r\n begin\r\n FieldArray[J].Field.Index := FieldArray[J].EndIndex;\r\n Break;\r\n end;\r\n end;\r\n end;\r\n finally\r\n AppStorage.EndUpdate;\r\n FieldArray := nil;\r\n end;\r\nend;\r\n\r\nprocedure SaveFields(DataSet: TDataSet; AppStorage: TJvCustomAppStorage; const Path: string);\r\nbegin\r\n InternalSaveFields(DataSet, AppStorage, AppStorage.ConcatPaths([Path, DataSetSectionName(DataSet)]));\r\nend;\r\n\r\nprocedure RestoreFields(DataSet: TDataSet; AppStorage: TJvCustomAppStorage; const Path: string;\r\n RestoreVisible: Boolean);\r\nbegin\r\n InternalRestoreFields(DataSet, AppStorage, AppStorage.ConcatPaths([DataSetSectionName(DataSet)]),\r\n RestoreVisible);\r\nend;\r\n\r\nfunction ExtractFieldNameEx(const Fields: {$IFDEF COMPILER10_UP} WideString {$ELSE} string {$ENDIF};\r\n var Pos: Integer): string;\r\nbegin\r\n Result := ExtractFieldName(Fields, Pos);\r\nend;\r\n\r\nfunction IsDataSetEmpty(DataSet: TDataSet): Boolean;\r\nbegin\r\n Result := (not DataSet.Active) or (DataSet.Eof and DataSet.Bof);\r\nend;\r\n\r\n{ SQL expressions }\r\n\r\nfunction DateToSQL(Value: TDateTime): string;\r\nbegin\r\n Result := IntToStr(Trunc(Value));\r\nend;\r\n\r\nfunction FormatSQLDateRange(Date1, Date2: TDateTime;\r\n const FieldName: string): string;\r\nbegin\r\n Result := TrueExpr;\r\n if (Date1 = Date2) and (Date1 <> NullDate) then\r\n begin\r\n Result := Format('%s = %s', [FieldName, FormatDateTime(ServerDateFmt,\r\n Date1)]);\r\n end\r\n else\r\n if (Date1 <> NullDate) or (Date2 <> NullDate) then\r\n begin\r\n if Date1 = NullDate then\r\n Result := Format('%s < %s', [FieldName,\r\n FormatDateTime(ServerDateFmt, IncDay(Date2, 1))])\r\n else\r\n if Date2 = NullDate then\r\n Result := Format('%s > %s', [FieldName,\r\n FormatDateTime(ServerDateFmt, IncDay(Date1, -1))])\r\n else\r\n Result := Format('(%s < %s) AND (%s > %s)',\r\n [FieldName, FormatDateTime(ServerDateFmt, IncDay(Date2, 1)),\r\n FieldName, FormatDateTime(ServerDateFmt, IncDay(Date1, -1))]);\r\n end;\r\nend;\r\n\r\nfunction FormatSQLDateRangeEx(Date1, Date2: TDateTime;\r\n const FieldName: string): string;\r\nbegin\r\n Result := TrueExpr;\r\n if (Date1 <> NullDate) or (Date2 <> NullDate) then\r\n begin\r\n if Date1 = NullDate then\r\n Result := Format('%s < %s', [FieldName,\r\n FormatDateTime(ServerDateFmt, IncDay(Date2, 1))])\r\n else\r\n if Date2 = NullDate then\r\n Result := Format('%s >= %s', [FieldName,\r\n FormatDateTime(ServerDateFmt, Date1)])\r\n else\r\n Result := Format('(%s < %s) AND (%s >= %s)',\r\n [FieldName, FormatDateTime(ServerDateFmt, IncDay(Date2, 1)),\r\n FieldName, FormatDateTime(ServerDateFmt, Date1)]);\r\n end;\r\nend;\r\n\r\nfunction FormatSQLNumericRange(const FieldName: string;\r\n LowValue, HighValue, LowEmpty, HighEmpty: Double; Inclusive: Boolean): string;\r\nconst\r\n Operators: array[Boolean, 1..2] of string[2] = (('>', '<'), ('>=', '<='));\r\nbegin\r\n Result := TrueExpr;\r\n if (LowValue = HighValue) and (LowValue <> LowEmpty) then\r\n Result := Format('%s = %g', [FieldName, LowValue])\r\n else\r\n if (LowValue <> LowEmpty) or (HighValue <> HighEmpty) then\r\n begin\r\n if LowValue = LowEmpty then\r\n Result := Format('%s %s %g', [FieldName, Operators[Inclusive, 2], HighValue])\r\n else\r\n if HighValue = HighEmpty then\r\n Result := Format('%s %s %g', [FieldName, Operators[Inclusive, 1], LowValue])\r\n else\r\n Result := Format('(%s %s %g) AND (%s %s %g)',\r\n [FieldName, Operators[Inclusive, 2], HighValue,\r\n FieldName, Operators[Inclusive, 1], LowValue]);\r\n end;\r\nend;\r\n\r\nfunction StrMaskSQL(const Value: string): string;\r\nbegin\r\n if (Pos('*', Value) = 0) and (Pos('?', Value) = 0) and (Value <> '') then\r\n Result := '*' + Value + '*'\r\n else\r\n Result := Value;\r\nend;\r\n\r\nfunction FormatSQLCondition(const FieldName, Operator, Value: string;\r\n FieldType: TFieldType; Exact: Boolean): string;\r\nvar\r\n EmptyValue: Boolean;\r\n FieldValue: string;\r\n DateValue: TDateTime;\r\n LogicOperator: string;\r\nbegin\r\n FieldValue := '';\r\n DateValue := NullDate;\r\n Exact := Exact or not (FieldType in\r\n [ftString{$IFDEF UNICODE}, ftWideString{$ENDIF UNICODE}, ftDate, ftTime, ftDateTime]);\r\n if FieldType in [ftDate, ftTime, ftDateTime] then\r\n begin\r\n DateValue := StrToDateDef(Value, NullDate);\r\n EmptyValue := (DateValue = NullDate);\r\n FieldValue := FormatDateTime(ServerDateFmt, DateValue);\r\n end\r\n else\r\n begin\r\n FieldValue := Value;\r\n EmptyValue := FieldValue = '';\r\n if not (Exact or EmptyValue) then\r\n FieldValue := ReplaceStr(ReplaceStr(StrMaskSQL(FieldValue),\r\n '*', '%'), '?', '_');\r\n if FieldType in [ftString{$IFDEF UNICODE}, ftWideString{$ENDIF UNICODE}] then\r\n FieldValue := '''' + FieldValue + '''';\r\n end;\r\n LogicOperator := Operator;\r\n if LogicOperator = '' then\r\n begin\r\n if Exact then\r\n LogicOperator := '='\r\n else\r\n begin\r\n if FieldType in [ftString{$IFDEF UNICODE}, ftWideString{$ENDIF UNICODE}] then\r\n LogicOperator := 'LIKE'\r\n else\r\n LogicOperator := '>=';\r\n end;\r\n end;\r\n if EmptyValue then\r\n Result := TrueExpr\r\n else\r\n if (FieldType = ftDateTime) and Exact then\r\n begin\r\n DateValue := IncDay(DateValue, 1);\r\n Result := Format('(%s >= %s) and (%s < %s)', [FieldName, FieldValue,\r\n FieldName, FormatDateTime(ServerDateFmt, DateValue)]);\r\n end\r\n else\r\n Result := Format('%s %s %s', [FieldName, LogicOperator, FieldValue]);\r\nend;\r\n\r\nfunction FormatAnsiSQLCondition(const FieldName, Operator, Value: string;\r\n FieldType: TFieldType; Exact: Boolean): string;\r\nvar\r\n S, Esc: string;\r\nbegin\r\n Esc := '';\r\n if not Exact and (FieldType in [ftString{$IFDEF UNICODE}, ftWideString{$ENDIF UNICODE}]) then\r\n begin\r\n S := ReplaceStr(ReplaceStr(ReplaceStr(Value, '/', '//'),\r\n '_', '/_'), '%', '/%');\r\n if S <> Value then\r\n Esc := ' ESCAPE''/''';\r\n end\r\n else\r\n S := Value;\r\n Result := FormatSQLCondition(FieldName, Operator, S, FieldType, Exact) + Esc;\r\nend;\r\n\r\nprocedure CheckRequiredField(Field: TField);\r\nbegin\r\n if not Field.ReadOnly and not Field.Calculated and Field.IsNull then\r\n begin\r\n Field.FocusControl;\r\n DatabaseErrorFmt(SFieldRequired, [Field.DisplayName]);\r\n end;\r\nend;\r\n\r\nprocedure CheckRequiredFields(const Fields: array of TField);\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := Low(Fields) to High(Fields) do\r\n CheckRequiredField(Fields[I]);\r\nend;\r\n\r\ntype\r\n TDataSetAccess = class(TDataSet);\r\n\r\nprocedure GotoBookmarkEx(DataSet: TDataSet; const Bookmark: TBookmark; Mode: TResyncMode; ForceScrollEvents: Boolean);\r\nvar\r\n DS: TDataSetAccess;\r\nbegin\r\n\tif (DataSet <> nil) and (Bookmark <> nil) then\r\n\tbegin\r\n DS := TDataSetAccess(DataSet);\r\n\t\tDS.CheckBrowseMode;\r\n\t\tif ForceScrollEvents or (rmCenter in Mode) then DS.DoBeforeScroll;\r\n\t\tDS.InternalGotoBookmark((Bookmark));\r\n\t\tDS.Resync(Mode);\r\n\t\tif ForceScrollEvents or (rmCenter in Mode) then DS.DoAfterScroll;\r\n\tend;\r\nend;\r\n\r\nprocedure AssignRecord(Source, Dest: TDataSet; ByName: Boolean);\r\nvar\r\n I: Integer;\r\n F, FSrc: TField;\r\nbegin\r\n if not (Dest.State in dsEditModes) then\r\n _DBError(SNotEditing);\r\n if ByName then\r\n begin\r\n for I := 0 to Source.FieldCount - 1 do\r\n begin\r\n F := Dest.FindField(Source.Fields[I].FieldName);\r\n FSrc := Source.Fields[i];\r\n if (F <> nil) and (F.DataType <> ftAutoInc) then\r\n begin\r\n if FSrc.IsNull then\r\n F.Value := FSrc.Value\r\n else\r\n case F.DataType of\r\n ftString: F.AsString := FSrc.AsString;\r\n ftInteger: F.AsInteger := FSrc.AsInteger;\r\n ftBoolean: F.AsBoolean := FSrc.AsBoolean;\r\n ftFloat: F.AsFloat := FSrc.AsFloat;\r\n ftCurrency: F.AsCurrency := FSrc.AsCurrency;\r\n ftDate: F.AsDateTime := FSrc.AsDateTime;\r\n ftDateTime: F.AsDateTime := FSrc.AsDateTime;\r\n else\r\n F.Value := FSrc.Value;\r\n end;\r\n end;\r\n end;\r\n end\r\n else\r\n begin\r\n for I := 0 to Min(Source.FieldDefs.Count - 1, Dest.FieldDefs.Count - 1) do\r\n begin\r\n F := Dest.FindField(Dest.FieldDefs[I].Name);\r\n FSrc := Source.FindField(Source.FieldDefs[I].Name);\r\n if (F <> nil) and (FSrc <> nil) and (F.DataType <> ftAutoInc) then\r\n begin\r\n if FSrc.IsNull then\r\n F.Value := FSrc.Value\r\n else\r\n case F.DataType of\r\n ftString: F.AsString := FSrc.AsString;\r\n ftInteger: F.AsInteger := FSrc.AsInteger;\r\n ftBoolean: F.AsBoolean := FSrc.AsBoolean;\r\n ftFloat: F.AsFloat := FSrc.AsFloat;\r\n ftCurrency: F.AsCurrency := FSrc.AsCurrency;\r\n ftDate: F.AsDateTime := FSrc.AsDateTime;\r\n ftDateTime: F.AsDateTime := FSrc.AsDateTime;\r\n else\r\n F.Value := FSrc.Value;\r\n end;\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n\r\n" }, { "path": "External/Jedi/Jvcl/run/JvDSADialogs.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvDSADialogs.PAS, released on 2002-08-23.\r\n\r\nThe Initial Developer of the Original Code is Marcel Bestebroer [marcelb att zeelandnet dott nl]\r\nPortions created by Marcel Bestebroer are Copyright (C) 2002 Marcel Bestebroer.\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\n Steve Magruder\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvDSADialogs.pas 13415 2012-09-10 09:51:54Z obones $\r\n\r\nunit JvDSADialogs;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n {$IFDEF MSWINDOWS}\r\n Windows,\r\n {$ENDIF MSWINDOWS}\r\n SysUtils, Classes, Contnrs, Graphics, Controls, Forms, StdCtrls, Dialogs,\r\n ExtCtrls, JvComponent,\r\n JvComponentBase, JvDynControlEngine, JvTypes, JvAppStorage,\r\n JvDynControlEngineIntf;\r\n\r\ntype\r\n TDlgCenterKind = (dckScreen, dckMainForm, dckActiveForm);\r\n\r\n TDSAMessageForm = class(TJvForm)\r\n private\r\n FTimeout: Integer;\r\n FTimer: TTimer;\r\n FCountdown: IJvDynControlCaption;\r\n FMsg: string;\r\n FDefaultButton: {$IFDEF RTL200_UP}TCustomButton{$ELSE}TButton{$ENDIF};\r\n protected\r\n property DefaultButton: {$IFDEF RTL200_UP}TCustomButton{$ELSE}TButton{$ENDIF} read FDefaultButton write FDefaultButton ;\r\n procedure CustomKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);\r\n procedure CustomMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);\r\n procedure CustomShow(Sender: TObject);\r\n procedure HelpButtonClick(Sender: TObject);\r\n procedure TimerEvent(Sender: TObject);\r\n procedure WriteToClipboard(const Text: string);\r\n function GetFormText: string;\r\n class function TimeoutUnit(Count: Integer; Seconds: Boolean = True): string;\r\n procedure CancelAutoClose;\r\n public\r\n constructor CreateNew(AOwner: TComponent; Dummy: Integer = 0); override;\r\n function IsDSAChecked: Boolean;\r\n property Msg: string read FMsg write FMsg;\r\n property Timeout: Integer read FTimeout write FTimeout;\r\n end;\r\n\r\n//----------------------------------------------------------------------------\r\n// DSA storage and registration classes, types, constants and exceptions\r\n//----------------------------------------------------------------------------\r\n\r\ntype\r\n TDSACheckTextKind = type Integer;\r\n\r\nconst\r\n ctkShow = 0;\r\n ctkAsk = 1;\r\n ctkWarn = 2;\r\n\r\ntype\r\n TDSAStorage = class;\r\n\r\n TDSARegItem = record\r\n ID: Integer;\r\n Name: string;\r\n Description: string;\r\n Storage: TDSAStorage;\r\n ChkTextKind: TDSACheckTextKind;\r\n end;\r\n\r\n TDSACustomData = procedure(const Storage: TDSAStorage; const DSAInfo: TDSARegItem) of object;\r\n\r\n TDSAStorage = class(TObject)\r\n private\r\n FStates: TStack;\r\n protected\r\n procedure BeginCustomRead(const DSAInfo: TDSARegItem); virtual;\r\n procedure BeginCustomWrite(const DSAInfo: TDSARegItem); virtual;\r\n procedure BeginRead(const DSAInfo: TDSARegItem); virtual;\r\n procedure BeginWrite(const DSAInfo: TDSARegItem); virtual;\r\n procedure EndCustomRead(const DSAInfo: TDSARegItem); virtual;\r\n procedure EndCustomWrite(const DSAInfo: TDSARegItem); virtual;\r\n procedure EndRead(const DSAInfo: TDSARegItem); virtual;\r\n procedure EndWrite(const DSAInfo: TDSARegItem); virtual;\r\n function IsKeyNameAllowed(const Key: string): Boolean;\r\n function GetCheckMarkTextSuffix: string; virtual; abstract;\r\n procedure SetCheckMarkTextSuffix(const Value: string); virtual; abstract;\r\n public\r\n constructor Create;\r\n destructor Destroy; override;\r\n function GetState(const DSAInfo: TDSARegItem; out LastResult: Integer;\r\n const OnCustomData: TDSACustomData = nil): Boolean; virtual;\r\n function ReadBool(const DSAInfo: TDSARegItem; const Key: string): Boolean; virtual; abstract;\r\n function ReadBoolDef(const DSAInfo: TDSARegItem; const Key: string;\r\n const Default: Boolean): Boolean; virtual; abstract;\r\n function ReadFloat(const DSAInfo: TDSARegItem; const Key: string): Extended; virtual; abstract;\r\n function ReadFloatDef(const DSAInfo: TDSARegItem; const Key: string;\r\n const Default: Extended): Extended; virtual; abstract;\r\n function ReadInt64(const DSAInfo: TDSARegItem; const Key: string): Int64; virtual; abstract;\r\n function ReadInt64Def(const DSAInfo: TDSARegItem; const Key: string;\r\n const Default: Int64): Int64; virtual; abstract;\r\n function ReadInteger(const DSAInfo: TDSARegItem; const Key: string): Integer; virtual; abstract;\r\n function ReadIntegerDef(const DSAInfo: TDSARegItem; const Key: string;\r\n const Default: Integer): Integer; virtual; abstract;\r\n function ReadString(const DSAInfo: TDSARegItem; const Key: string): string; virtual; abstract;\r\n function ReadStringDef(const DSAInfo: TDSARegItem; const Key: string;\r\n const Default: string): string; virtual; abstract;\r\n procedure SetState(const DSAInfo: TDSARegItem; const DontShowAgain: Boolean;\r\n const LastResult: Integer; const OnCustomData: TDSACustomData = nil); virtual;\r\n procedure WriteBool(const DSAInfo: TDSARegItem; const Key: string; const Value: Boolean); virtual; abstract;\r\n procedure WriteFloat(const DSAInfo: TDSARegItem; const Key: string; const Value: Extended); virtual; abstract;\r\n procedure WriteInt64(const DSAInfo: TDSARegItem; const Key: string; const Value: Int64); virtual; abstract;\r\n procedure WriteInteger(const DSAInfo: TDSARegItem; const Key: string; const Value: Integer); virtual; abstract;\r\n procedure WriteString(const DSAInfo: TDSARegItem; const Key: string; const Value: string); virtual; abstract;\r\n property CheckMarkTextSuffix: string read GetCheckMarkTextSuffix;\r\n end;\r\n\r\n {$IFDEF MSWINDOWS}\r\n TDSARegStorage = class(TDSAStorage)\r\n private\r\n FRootKey: HKEY;\r\n FKey: string;\r\n protected\r\n procedure CreateKey(const DSAInfo: TDSARegItem); virtual;\r\n function GetCheckMarkTextSuffix: string; override;\r\n procedure SetCheckMarkTextSuffix(const Value: string); override;\r\n public\r\n constructor Create(const ARootKey: HKEY; const AKey: string);\r\n function ReadBool(const DSAInfo: TDSARegItem; const Key: string): Boolean; override;\r\n function ReadBoolDef(const DSAInfo: TDSARegItem; const Key: string; const Default: Boolean): Boolean; override;\r\n function ReadFloat(const DSAInfo: TDSARegItem; const Key: string): Extended; override;\r\n function ReadFloatDef(const DSAInfo: TDSARegItem; const Key: string; const Default: Extended): Extended; override;\r\n function ReadInt64(const DSAInfo: TDSARegItem; const Key: string): Int64; override;\r\n function ReadInt64Def(const DSAInfo: TDSARegItem; const Key: string; const Default: Int64): Int64; override;\r\n function ReadInteger(const DSAInfo: TDSARegItem; const Key: string): Integer; override;\r\n function ReadIntegerDef(const DSAInfo: TDSARegItem; const Key: string; const Default: Integer): Integer; override;\r\n function ReadString(const DSAInfo: TDSARegItem; const Key: string): string; override;\r\n function ReadStringDef(const DSAInfo: TDSARegItem; const Key: string; const Default: string): string; override;\r\n procedure WriteBool(const DSAInfo: TDSARegItem; const Key: string; const Value: Boolean); override;\r\n procedure WriteFloat(const DSAInfo: TDSARegItem; const Key: string; const Value: Extended); override;\r\n procedure WriteInt64(const DSAInfo: TDSARegItem; const Key: string; const Value: Int64); override;\r\n procedure WriteInteger(const DSAInfo: TDSARegItem; const Key: string; const Value: Integer); override;\r\n procedure WriteString(const DSAInfo: TDSARegItem; const Key: string; const Value: string); override;\r\n property RootKey: HKEY read FRootKey write FRootKey;\r\n property Key: string read FKey write FKey;\r\n end;\r\n {$ENDIF MSWINDOWS}\r\n\r\n TDSAQueueStorage = class(TDSAStorage)\r\n private\r\n FList: TStringList;\r\n FCheckMarkSuffix: string;\r\n protected\r\n procedure AddDSA(const DSAInfo: TDSARegItem);\r\n procedure DeleteDSA(const Index: Integer);\r\n function FindDSA(const DSAInfo: TDSARegItem): Integer;\r\n function GetCheckMarkTextSuffix: string; override;\r\n function GetDSAValue(const DSAInfo: TDSARegItem; const Key: string; const Kind: Integer): string;\r\n function HasDSAKey(const DSAInfo: TDSARegItem; const Key: string): Boolean;\r\n procedure SetCheckMarkTextSuffix(const Value: string); override;\r\n procedure SetDSAValue(const DSAInfo: TDSARegItem; const Key: string; const Kind: Integer; const Value: string);\r\n public\r\n constructor Create;\r\n destructor Destroy; override;\r\n procedure Clear;\r\n function ReadBool(const DSAInfo: TDSARegItem; const Key: string): Boolean; override;\r\n function ReadBoolDef(const DSAInfo: TDSARegItem; const Key: string; const Default: Boolean): Boolean; override;\r\n function ReadFloat(const DSAInfo: TDSARegItem; const Key: string): Extended; override;\r\n function ReadFloatDef(const DSAInfo: TDSARegItem; const Key: string; const Default: Extended): Extended; override;\r\n function ReadInt64(const DSAInfo: TDSARegItem; const Key: string): Int64; override;\r\n function ReadInt64Def(const DSAInfo: TDSARegItem; const Key: string; const Default: Int64): Int64; override;\r\n function ReadInteger(const DSAInfo: TDSARegItem; const Key: string): Integer; override;\r\n function ReadIntegerDef(const DSAInfo: TDSARegItem; const Key: string; const Default: Integer): Integer; override;\r\n function ReadString(const DSAInfo: TDSARegItem; const Key: string): string; override;\r\n function ReadStringDef(const DSAInfo: TDSARegItem; const Key: string; const Default: string): string; override;\r\n procedure WriteBool(const DSAInfo: TDSARegItem; const Key: string; const Value: Boolean); override;\r\n procedure WriteFloat(const DSAInfo: TDSARegItem; const Key: string; const Value: Extended); override;\r\n procedure WriteInt64(const DSAInfo: TDSARegItem; const Key: string; const Value: Int64); override;\r\n procedure WriteInteger(const DSAInfo: TDSARegItem; const Key: string; const Value: Integer); override;\r\n procedure WriteString(const DSAInfo: TDSARegItem; const Key: string; const Value: string); override;\r\n property CheckMarkTextSuffix: string read GetCheckMarkTextSuffix write SetCheckMarkTextSuffix;\r\n end;\r\n\r\nconst\r\n ssCustomRead: Pointer = @TDSAStorage.BeginCustomRead;\r\n ssCustomWrite: Pointer = @TDSAStorage.BeginCustomWrite;\r\n ssRead: Pointer = @TDSAStorage.BeginRead;\r\n ssWrite: Pointer = @TDSAStorage.BeginWrite;\r\n\r\n//--------------------------------------------------------------------------------------------------\r\n// MessageDlg replacements and extensions\r\n//--------------------------------------------------------------------------------------------------\r\n\r\n// Additional values for DefaultButton, CancelButton and HelpButton parameters\r\n\r\nconst\r\n mbNone = TMsgDlgBtn(-1);\r\n mbDefault = TMsgDlgBtn(-2);\r\n\r\nprocedure ShowMessage(const Msg: string; const Center: TDlgCenterKind = dckScreen; const Timeout: Integer = 0;\r\n const ADynControlEngine: TJvDynControlEngine = nil);\r\nprocedure ShowMessageFmt(const Msg: string; const Params: array of const; const Center: TDlgCenterKind = dckScreen;\r\n const Timeout: Integer = 0; const ADynControlEngine: TJvDynControlEngine = nil);\r\n\r\nfunction MessageDlg(const Msg: string; const DlgType: TMsgDlgType; const Buttons: TMsgDlgButtons;\r\n const HelpCtx: Longint; const Center: TDlgCenterKind = dckScreen; const Timeout: Integer = 0;\r\n const DefaultButton: TMsgDlgBtn = mbDefault; const CancelButton: TMsgDlgBtn = mbDefault;\r\n const HelpButton: TMsgDlgBtn = mbHelp;\r\n const ADynControlEngine: TJvDynControlEngine = nil): TModalResult; overload;\r\nfunction MessageDlg(const Caption, Msg: string; const DlgType: TMsgDlgType; const Buttons: TMsgDlgButtons;\r\n const HelpCtx: Longint; const Center: TDlgCenterKind = dckScreen; const Timeout: Integer = 0;\r\n const DefaultButton: TMsgDlgBtn = mbDefault; const CancelButton: TMsgDlgBtn = mbDefault;\r\n const HelpButton: TMsgDlgBtn = mbHelp;\r\n const ADynControlEngine: TJvDynControlEngine = nil): TModalResult; overload;\r\nfunction MessageDlg(const Caption, Msg: string; const Picture: TGraphic; const Buttons: TMsgDlgButtons;\r\n const HelpCtx: Longint; const Center: TDlgCenterKind = dckScreen; const Timeout: Integer = 0;\r\n const DefaultButton: TMsgDlgBtn = mbDefault; const CancelButton: TMsgDlgBtn = mbDefault;\r\n const HelpButton: TMsgDlgBtn = mbHelp;\r\n const ADynControlEngine: TJvDynControlEngine = nil): TModalResult; overload;\r\n\r\nfunction MessageDlgEx(const Msg: string; const DlgType: TMsgDlgType; const Buttons: array of string;\r\n const Results: array of Integer; const HelpCtx: Longint; const Center: TDlgCenterKind = dckScreen;\r\n const Timeout: Integer = 0; const DefaultButton: Integer = 0; const CancelButton: Integer = 1;\r\n const HelpButton: Integer = -1;\r\n const ADynControlEngine: TJvDynControlEngine = nil): TModalResult; overload;\r\nfunction MessageDlgEx(const Caption, Msg: string; const DlgType: TMsgDlgType; const Buttons: array of string;\r\n const Results: array of Integer; const HelpCtx: Longint; const Center: TDlgCenterKind = dckScreen;\r\n const Timeout: Integer = 0; const DefaultButton: Integer = 0; const CancelButton: Integer = 1;\r\n const HelpButton: Integer = -1;\r\n const ADynControlEngine: TJvDynControlEngine = nil): TModalResult; overload;\r\nfunction MessageDlgEx(const Caption, Msg: string; const Picture: TGraphic; const Buttons: array of string;\r\n const Results: array of Integer; const HelpCtx: Longint; const Center: TDlgCenterKind = dckScreen;\r\n const Timeout: Integer = 0; const DefaultButton: Integer = 0; const CancelButton: Integer = 1;\r\n const HelpButton: Integer = -1;\r\n const ADynControlEngine: TJvDynControlEngine = nil): TModalResult; overload;\r\n\r\n//--------------------------------------------------------------------------------------------------\r\n// \"Don't Show Again\" (DSA) dialogs\r\n//--------------------------------------------------------------------------------------------------\r\n\r\nprocedure DSAShowMessage(const DlgID: Integer; const Msg: string; const Center: TDlgCenterKind = dckScreen;\r\n const Timeout: Integer = 0; const ADynControlEngine: TJvDynControlEngine = nil);\r\nprocedure DSAShowMessageFmt(const DlgID: Integer; const Msg: string; const Params: array of const;\r\n const Center: TDlgCenterKind = dckScreen; const Timeout: Integer = 0;\r\n const ADynControlEngine: TJvDynControlEngine = nil);\r\nfunction DSAMessageDlg(const DlgID: Integer; const Msg: string; const DlgType: TMsgDlgType;\r\n const Buttons: TMsgDlgButtons; const HelpCtx: Longint; const Center: TDlgCenterKind = dckScreen;\r\n const Timeout: Integer = 0; const DefaultButton: TMsgDlgBtn = mbDefault;\r\n const CancelButton: TMsgDlgBtn = mbDefault; const HelpButton: TMsgDlgBtn = mbHelp;\r\n const ADynControlEngine: TJvDynControlEngine = nil): TModalResult; overload;\r\nfunction DSAMessageDlg(const DlgID: Integer; const Caption, Msg: string; const DlgType: TMsgDlgType;\r\n const Buttons: TMsgDlgButtons; const HelpCtx: Longint; const Center: TDlgCenterKind = dckScreen;\r\n const Timeout: Integer = 0; const DefaultButton: TMsgDlgBtn = mbDefault;\r\n const CancelButton: TMsgDlgBtn = mbDefault; const HelpButton: TMsgDlgBtn = mbHelp;\r\n const ADynControlEngine: TJvDynControlEngine = nil): TModalResult; overload;\r\nfunction DSAMessageDlg(const DlgID: Integer; const Caption, Msg: string; const Picture: TGraphic;\r\n const Buttons: TMsgDlgButtons; const HelpCtx: Longint; const Center: TDlgCenterKind = dckScreen;\r\n const Timeout: Integer = 0; const DefaultButton: TMsgDlgBtn = mbDefault;\r\n const CancelButton: TMsgDlgBtn = mbDefault; const HelpButton: TMsgDlgBtn = mbHelp;\r\n const ADynControlEngine: TJvDynControlEngine = nil): TModalResult; overload;\r\nfunction DSAMessageDlgEx(const DlgID: Integer; const Msg: string; const DlgType: TMsgDlgType;\r\n const Buttons: array of string; const Results: array of Integer; const HelpCtx: Longint;\r\n const Center: TDlgCenterKind = dckScreen; const Timeout: Integer = 0;\r\n const DefaultButton: Integer = 0; const CancelButton: Integer = 1; const HelpButton: Integer = -1;\r\n const ADynControlEngine: TJvDynControlEngine = nil): Integer; overload;\r\nfunction DSAMessageDlgEx(const DlgID: Integer; const Caption, Msg: string; const DlgType: TMsgDlgType;\r\n const Buttons: array of string; const Results: array of Integer; const HelpCtx: Longint;\r\n const Center: TDlgCenterKind = dckScreen; const Timeout: Integer = 0; const DefaultButton: Integer = 0;\r\n const CancelButton: Integer = 1; const HelpButton: Integer = -1;\r\n const ADynControlEngine: TJvDynControlEngine = nil): TModalResult; overload;\r\nfunction DSAMessageDlgEx(const DlgID: Integer; const Caption, Msg: string; const Picture: TGraphic;\r\n const Buttons: array of string; const Results: array of Integer; const HelpCtx: Longint;\r\n const Center: TDlgCenterKind = dckScreen; const Timeout: Integer = 0; const DefaultButton: Integer = 0;\r\n const CancelButton: Integer = 1; const HelpButton: Integer = -1;\r\n const ADynControlEngine: TJvDynControlEngine = nil): Integer; overload;\r\n\r\n//----------------------------------------------------------------------------\r\n// Generic DSA dialog\r\n//----------------------------------------------------------------------------\r\n\r\nfunction CreateDSAMessageForm(const ACaption, Msg: string; const APicture: TGraphic;\r\n const Buttons: array of string; const Results: array of Integer; const HelpCtx: Integer;\r\n const CheckCaption: string; const Center: TDlgCenterKind = dckScreen;\r\n const ATimeout: Integer = 0; const DefaultButton: Integer = 0; const CancelButton: Integer = 1;\r\n HelpButton: Integer = -1; const ADynControlEngine: TJvDynControlEngine = nil): TDSAMessageForm;\r\n\r\n//----------------------------------------------------------------------------\r\n// DSA registration\r\n//----------------------------------------------------------------------------\r\n\r\nprocedure RegisterDSA(const DlgID: Integer; const Name, Description: string;\r\n const Storage: TDSAStorage; const CheckTextKind: TDSACheckTextKind = ctkShow);\r\nprocedure UnregisterDSA(const DlgID: Integer);\r\nfunction LocateDSAReg(const DlgID: Integer): TDSARegItem;\r\n\r\n//----------------------------------------------------------------------------\r\n// DSA state setting/retrieving\r\n//----------------------------------------------------------------------------\r\n\r\nfunction GetDSAState(const DlgID: Integer): Boolean; overload;\r\nfunction GetDSAState(const DlgID: Integer; out ResCode: Integer;\r\n const OnCustomData: TDSACustomData = nil): Boolean; overload;\r\nprocedure SetDSAState(const DlgID: Integer; const DontShowAgain: Boolean;\r\n const LastResult: Integer = mrNone; const OnCustomData: TDSACustomData = nil);\r\n\r\n//----------------------------------------------------------------------------\r\n// Iterating the DSA registration\r\n//----------------------------------------------------------------------------\r\n\r\nfunction DSACount: Integer;\r\nfunction DSAItem(const Index: Integer): TDSARegItem;\r\n\r\n//----------------------------------------------------------------------------\r\n// DSA check box text registration\r\n//----------------------------------------------------------------------------\r\n\r\nprocedure RegisterDSACheckMarkText(const ID: TDSACheckTextKind; const Text: string);\r\nprocedure UnregisterDSACheckMarkText(const ID: TDSACheckTextKind);\r\nfunction GetDSACheckMarkText(const ID: TDSACheckTextKind): string;\r\n\r\n//----------------------------------------------------------------------------\r\n// Standard DSA storage devices\r\n//----------------------------------------------------------------------------\r\n{$IFDEF MSWINDOWS}\r\nfunction DSARegStore: TDSARegStorage;\r\n{$ENDIF MSWINDOWS}\r\nfunction DSAQueueStore: TDSAQueueStorage;\r\n\r\n//----------------------------------------------------------------------------\r\n// DSA time formatting function.\r\n// Returns a string representing the number of seconds.\r\n// Standard function returns this:\r\n// \"(Secs) sec\" if Secs is lower than 60\r\n// \"(Secs div 60) min (Secs mod 60) sec\" if Secs is greater or equal to 60\r\n// The min and sec constants are taken from resource strings in JvResources.\r\n//----------------------------------------------------------------------------\r\ntype\r\n TJvDSATimeFormatter = function(Secs: Integer) : string;\r\n\r\nprocedure SetDSATimeFormatter(const ATimeFormatter: TJvDSATimeFormatter);\r\nfunction StandardDSATimeFormatter(Secs: Integer) : string;\r\n\r\n//----------------------------------------------------------------------------\r\n// VCL component\r\n//----------------------------------------------------------------------------\r\n\r\ntype\r\n EJvDSADialog = class(EJVCLException);\r\n\r\n TJvDSADataEvent = procedure(Sender: TObject; const DSAInfo: TDSARegItem; const Storage: TDSAStorage) of object;\r\n TJvDSAAutoCloseEvent = procedure(Sender: TObject; var Handled: Boolean) of object;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvDSADialog = class(TJvComponent)\r\n private\r\n FCheckControl: TWinControl;\r\n FDialogID: Integer;\r\n FIgnoreDSAChkMrkTxt: Boolean;\r\n FOnUpdateKeys: TJvDSADataEvent;\r\n FOnApplyKeys: TJvDSADataEvent;\r\n FOrgOwner: TComponent;\r\n FOrgShowModalPtr: Pointer;\r\n FTimeout: Integer;\r\n FTimer: TTimer;\r\n FTimerCount: Integer;\r\n FOnCountdown: TNotifyEvent;\r\n FOnAutoClose: TJvDSAAutoCloseEvent;\r\n protected\r\n procedure AutoClose;\r\n procedure AfterShow; virtual;\r\n procedure ApplySavedState; virtual;\r\n procedure BeforeShow; virtual;\r\n procedure DoApplyKeys(const Storage: TDSAStorage; const DSAInfo: TDSARegItem); virtual;\r\n function DoAutoClose: Boolean;\r\n procedure DoCountDown;\r\n procedure DoUpdateKeys(const Storage: TDSAStorage; const DSAInfo: TDSARegItem); virtual;\r\n function GetDSAStateInternal(out ModalResult: Integer): Boolean;\r\n function GetOrgOwner: TComponent;\r\n function GetOrgShowModalPtr: Pointer;\r\n function GetStorage: TDSAStorage;\r\n procedure FormPatch;\r\n procedure FormUnPatch;\r\n procedure Notification(AComponent: TComponent; Operation: TOperation); override;\r\n procedure SetCheckControl(Value: TWinControl); virtual;\r\n procedure SetDialogID(Value: Integer); virtual;\r\n procedure SetOrgOwner(Value: TComponent);\r\n procedure SetOrgShowModalPtr(Value: Pointer);\r\n procedure TimerEvent(Sender: TObject);\r\n procedure UpdateDSAState; virtual;\r\n property OrgOwner: TComponent read GetOrgOwner write SetOrgOwner;\r\n property OrgShowModalPtr: Pointer read GetOrgShowModalPtr write SetOrgShowModalPtr;\r\n property Storage: TDSAStorage read GetStorage;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n function GetModalResult: Integer; virtual;\r\n function IsDSAChecked: Boolean; virtual;\r\n procedure Loaded; override;\r\n procedure CancelCountdown; virtual;\r\n function SecondsLeft: Integer;\r\n published\r\n property Timeout: Integer read FTimeout write FTimeout;\r\n property CheckControl: TWinControl read FCheckControl write SetCheckControl;\r\n property DialogID: Integer read FDialogID write SetDialogID;\r\n property IgnoreDSAChkMrkTxt: Boolean read FIgnoreDSAChkMrkTxt write FIgnoreDSAChkMrkTxt;\r\n property OnApplyKeys: TJvDSADataEvent read FOnApplyKeys write FOnApplyKeys;\r\n property OnUpdateKeys: TJvDSADataEvent read FOnUpdateKeys write FOnUpdateKeys;\r\n property OnCountdown: TNotifyEvent read FOnCountdown write FOnCountdown;\r\n property OnAutoClose: TJvDSAAutoCloseEvent read FOnAutoClose write FOnAutoClose;\r\n end;\r\n\r\ntype\r\n TDSAAppStorage = class(TDSAStorage)\r\n private\r\n FAppStorage : TJvCustomAppStorage;\r\n FAppStoragePath: string;\r\n protected\r\n function GetCheckMarkTextSuffix: string; override;\r\n procedure SetCheckMarkTextSuffix(const Value: string); override;\r\n public\r\n constructor Create(AAppStorage : TJvCustomAppStorage; const APath : string);\r\n function ReadBool(const DSAInfo: TDSARegItem; const Key: string): Boolean; override;\r\n function ReadBoolDef(const DSAInfo: TDSARegItem; const Key: string; const Default: Boolean): Boolean; override;\r\n function ReadFloat(const DSAInfo: TDSARegItem; const Key: string): Extended; override;\r\n function ReadFloatDef(const DSAInfo: TDSARegItem; const Key: string; const Default: Extended): Extended; override;\r\n function ReadInt64(const DSAInfo: TDSARegItem; const Key: string): Int64; override;\r\n function ReadInt64Def(const DSAInfo: TDSARegItem; const Key: string; const Default: Int64): Int64; override;\r\n function ReadInteger(const DSAInfo: TDSARegItem; const Key: string): Integer; override;\r\n function ReadIntegerDef(const DSAInfo: TDSARegItem; const Key: string; const Default: Integer): Integer; override;\r\n function ReadString(const DSAInfo: TDSARegItem; const Key: string): string; override;\r\n function ReadStringDef(const DSAInfo: TDSARegItem; const Key: string; const Default: string): string; override;\r\n procedure WriteBool(const DSAInfo: TDSARegItem; const Key: string; const Value: Boolean); override;\r\n procedure WriteFloat(const DSAInfo: TDSARegItem; const Key: string; const Value: Extended); override;\r\n procedure WriteInt64(const DSAInfo: TDSARegItem; const Key: string; const Value: Int64); override;\r\n procedure WriteInteger(const DSAInfo: TDSARegItem; const Key: string; const Value: Integer); override;\r\n procedure WriteString(const DSAInfo: TDSARegItem; const Key: string; const Value: string); override;\r\n property AppStorage: TJvCustomAppStorage read FAppStorage write FAppStorage;\r\n property AppStoragePath: string read FAppStoragePath write FAppStoragePath;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvDSADialogs.pas $';\r\n Revision: '$Revision: 13415 $';\r\n Date: '$Date: 2012-09-10 11:51:54 +0200 (lun. 10 sept. 2012) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n Types, Consts, Math, TypInfo,\r\n {$IFDEF MSWINDOWS}\r\n JclRegistry,\r\n {$ENDIF MSWINDOWS}\r\n JclBase, JclSysUtils,\r\n JvConsts, JvResources, JvJVCLUtils;\r\n\r\nconst\r\n cDSAStateValueName = 'DSA_State'; // do not localize\r\n cDSAStateLastResultName = 'LastResult'; // do not localize\r\n\r\n sPathStr = '%s\\%s\\%s';\r\n\r\n\r\ntype\r\n PBoolean = ^Boolean;\r\n\r\nvar\r\n TimeFormatter: TJvDSATimeFormatter = StandardDSATimeFormatter;\r\n\r\nprocedure SetDSATimeFormatter(const ATimeFormatter: TJvDSATimeFormatter);\r\nbegin\r\n TimeFormatter := ATimeFormatter\r\nend;\r\n\r\nfunction StandardDSATimeFormatter(Secs: Integer) : string;\r\nvar\r\n Mins: Integer;\r\n TimeStr: string;\r\nbegin\r\n Mins := Secs div 60;\r\n Secs := Secs mod 60;\r\n if Mins <> 0 then\r\n TimeStr := Format('%d %s %d %s', [Mins, TDSAMessageForm.TimeoutUnit(Mins, False),\r\n Secs, TDSAMessageForm.TimeoutUnit(Secs)])\r\n else\r\n TimeStr := Format('%d %s', [Secs, TDSAMessageForm.TimeoutUnit(Secs)]);\r\n\r\n Result := Format(RsCntdownText, [TimeStr]);\r\nend;\r\n\r\n//=== CheckMarkTexts =========================================================\r\n\r\nvar\r\n GlobalCheckMarkTexts: TStringList = nil;\r\n\r\nfunction CheckMarkTexts: TStrings;\r\nbegin\r\n if GlobalCheckMarkTexts = nil then\r\n GlobalCheckMarkTexts := TStringList.Create;\r\n Result := GlobalCheckMarkTexts;\r\nend;\r\n\r\nfunction GetCheckMarkText(const ID: TDSACheckTextKind): string;\r\nvar\r\n Idx: Integer;\r\nbegin\r\n Idx := CheckMarkTexts.IndexOfObject(TObject(ID));\r\n if Idx > -1 then\r\n Result := CheckMarkTexts[Idx]\r\n else\r\n Result := '';\r\nend;\r\n\r\n//=== { TDSAMessageForm } ====================================================\r\n\r\nconstructor TDSAMessageForm.CreateNew(AOwner: TComponent; Dummy: Integer);\r\nvar\r\n NonClientMetrics: TNonClientMetrics;\r\nbegin\r\n inherited CreateNew(AOwner, Dummy);\r\n {$IFDEF RTL210_UP}\r\n NonClientMetrics.cbSize := TNonClientMetrics.SizeOf;\r\n {$ELSE}\r\n NonClientMetrics.cbSize := SizeOf(NonClientMetrics);\r\n {$ENDIF RTL210_UP}\r\n if SystemParametersInfo(SPI_GETNONCLIENTMETRICS, NonClientMetrics.cbSize, @NonClientMetrics, 0) then\r\n Font.Handle := CreateFontIndirect(NonClientMetrics.lfMessageFont);\r\n FTimer := TTimer.Create(Self);\r\n FTimer.Enabled := False;\r\n FTimer.Interval := 1000;\r\n FTimer.OnTimer := TimerEvent;\r\nend;\r\n\r\nprocedure TDSAMessageForm.CustomKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);\r\nbegin\r\n CancelAutoClose;\r\n if (Shift = [ssCtrl]) and (Key = Word('C')) then\r\n begin\r\n WriteToClipboard(GetFormText);\r\n end;\r\n if Key = VK_RETURN then\r\n if ActiveControl is {$IFDEF RTL200_UP}TCustomButton{$ELSE}TButton{$ENDIF} then\r\n {$IFDEF RTL200_UP}TCustomButton{$ELSE}TButton{$ENDIF}(ActiveControl).Click\r\n else if Assigned(DefaultButton) then\r\n DefaultButton.Click;\r\nend;\r\n\r\nprocedure TDSAMessageForm.CustomMouseDown(Sender: TObject; Button: TMouseButton;\r\n Shift: TShiftState; X, Y: Integer);\r\nbegin\r\n CancelAutoClose;\r\nend;\r\n\r\nprocedure TDSAMessageForm.CustomShow(Sender: TObject);\r\nvar\r\n I: Integer;\r\n First : Boolean;\r\n Btn : {$IFDEF RTL200_UP}TCustomButton{$ELSE}TButton{$ENDIF};\r\nbegin\r\n if Timeout <> 0 then\r\n FTimer.Enabled := True;\r\n First := True;\r\n for I := 0 to ComponentCount - 1 do\r\n begin\r\n if (Components[i] is {$IFDEF RTL200_UP}TCustomButton{$ELSE}TButton{$ENDIF}) then\r\n begin\r\n Btn := (Components[i] as {$IFDEF RTL200_UP}TCustomButton{$ELSE}TButton{$ENDIF});\r\n if First then\r\n begin\r\n First := False;\r\n Btn.SetFocus;\r\n end\r\n else if Btn.Default then\r\n begin\r\n Btn.SetFocus;\r\n Break;\r\n end;\r\n end;\r\n end;\r\n Supports(FindComponent('CountDown'),IJvDynControlCaption, FCountDown);\r\nend;\r\n\r\nprocedure TDSAMessageForm.HelpButtonClick(Sender: TObject);\r\nbegin\r\n CancelAutoClose;\r\n Application.HelpContext(HelpContext);\r\nend;\r\n\r\nprocedure TDSAMessageForm.TimerEvent(Sender: TObject);\r\nvar\r\n I: Integer;\r\nbegin\r\n if FTimer.Enabled then\r\n begin\r\n Dec(FTimeout);\r\n if FTimeout = 0 then\r\n begin\r\n FTimer.Enabled := False;\r\n for I := 0 to ComponentCount - 1 do\r\n begin\r\n if (Components[i] is {$IFDEF RTL200_UP}TCustomButton{$ELSE}TButton{$ENDIF}) and (Components[i] as {$IFDEF RTL200_UP}TCustomButton{$ELSE}TButton{$ENDIF}).Default then\r\n begin\r\n (Components[i] as {$IFDEF RTL200_UP}TCustomButton{$ELSE}TButton{$ENDIF}).Click;\r\n Exit;\r\n end;\r\n end;\r\n // No default button found; just close the form\r\n Close;\r\n end\r\n else\r\n if Assigned(FCountdown) then\r\n FCountdown.ControlCaption := TimeFormatter(Timeout);\r\n end;\r\nend;\r\n\r\n\r\nprocedure TDSAMessageForm.WriteToClipboard(const Text: string);\r\nvar\r\n Data: THandle;\r\n DataPtr: Pointer;\r\nbegin\r\n if OpenClipboard(0) then\r\n begin\r\n try\r\n Data := GlobalAlloc(GMEM_MOVEABLE + GMEM_DDESHARE, (Length(Text) + 1) * SizeOf(Char));\r\n try\r\n DataPtr := GlobalLock(Data);\r\n try\r\n Move(PChar(Text)^, DataPtr^, (Length(Text) + 1) * SizeOf(Char));\r\n EmptyClipboard;\r\n SetClipboardData({$IFDEF UNICODE}CF_UNICODETEXT{$ELSE}CF_TEXT{$ENDIF UNICODE}, Data);\r\n finally\r\n GlobalUnlock(Data);\r\n end;\r\n except\r\n GlobalFree(Data);\r\n raise;\r\n end;\r\n finally\r\n CloseClipboard;\r\n end;\r\n end\r\n else\r\n raise EJVCLException.CreateRes(@SCannotOpenClipboard);\r\nend;\r\n\r\n\r\n\r\n\r\nfunction TDSAMessageForm.GetFormText: string;\r\nvar\r\n DividerLine, ButtonCaptions: string;\r\n I: Integer;\r\nbegin\r\n DividerLine := StringOfChar('-', 27) + CrLf;\r\n for I := 0 to ComponentCount - 1 do\r\n if Components[i] is {$IFDEF RTL200_UP}TCustomButton{$ELSE}TButton{$ENDIF} then\r\n ButtonCaptions := ButtonCaptions + TButton(Components[i]).Caption + StringOfChar(' ', 3);\r\n ButtonCaptions := StringReplace(ButtonCaptions, '&', '', [rfReplaceAll]);\r\n Result := Format('%s%s%s%s%s%s%s%s%s%s', [DividerLine, Caption, CrLf, DividerLine,\r\n Msg, CrLf, DividerLine, ButtonCaptions, CrLf, DividerLine]);\r\nend;\r\n\r\nclass function TDSAMessageForm.TimeoutUnit(Count: Integer; Seconds: Boolean): string;\r\nbegin\r\n if Seconds then\r\n if Count <> 1 then\r\n Result := RsCntdownSecsText\r\n else\r\n Result := RsCntdownSecText\r\n else\r\n if Count <> 1 then\r\n Result := RsCntdownMinsText\r\n else\r\n Result := RsCntdownMinText;\r\nend;\r\n\r\nprocedure TDSAMessageForm.CancelAutoClose;\r\nbegin\r\n FTimer.Enabled := False;\r\nend;\r\n\r\nfunction TDSAMessageForm.IsDSAChecked: Boolean;\r\nvar\r\n I: Integer;\r\nbegin\r\n I := ComponentCount - 1;\r\n while (I > -1) and not (Components[i] is TCustomCheckBox) do\r\n Dec(I);\r\n if (I > -1) then\r\n Result := TCheckBox(Components[i]).Checked\r\n else\r\n Result := False;\r\nend;\r\n\r\nfunction GetAveCharSize(Canvas: TCanvas): TPoint;\r\nvar\r\n I: Integer;\r\n Buffer: array [0..51] of Char;\r\nbegin\r\n for I := 0 to 25 do\r\n Buffer[I] := Chr(I + Ord('A'));\r\n for I := 0 to 25 do\r\n Buffer[I + 26] := Chr(I + Ord('a'));\r\n GetTextExtentPoint32(Canvas.Handle, Buffer, 52, TSize(Result));\r\n Result.X := Result.X div 52;\r\nend;\r\n\r\nfunction CreateDSAMessageForm(const ACaption, Msg: string; const APicture: TGraphic;\r\n const Buttons: array of string; const Results: array of Integer; const HelpCtx: Integer;\r\n const CheckCaption: string; const Center: TDlgCenterKind = dckScreen;\r\n const ATimeout: Integer = 0; const DefaultButton: Integer = 0;\r\n const CancelButton: Integer = 1; HelpButton: Integer = -1;\r\n const ADynControlEngine: TJvDynControlEngine = nil): TDSAMessageForm;\r\nconst\r\n mcHorzMargin = 8;\r\n mcVertMargin = 8;\r\n mcHorzSpacing = 10;\r\n mcVertSpacing = 4;\r\n mcButtonWidth = 50;\r\n mcButtonHeight = 14;\r\n mcButtonSpacing = 4;\r\nvar\r\n DialogUnits: TPoint;\r\n HorzMargin, VertMargin, HorzSpacing, VertSpacing, ButtonWidth: Integer;\r\n ButtonHeight, ButtonSpacing, ButtonCount, ButtonGroupWidth: Integer;\r\n IconWidth, IconHeight,\r\n TextWidth, TextHeight,\r\n X: Integer;\r\n ChkTextWidth: Integer;\r\n TimeoutTextWidth: Integer;\r\n TempRect, TextRect: TRect;\r\n I: Integer;\r\n CenterParent: TComponent;\r\n CenterParLeft, CenterParTop, CenterParWidth, CenterParHeight: Integer;\r\n DynControlEngine: TJvDynControlEngine;\r\n CountDownlabel, MessageLabel: TControl;\r\n Image: TWinControl;\r\n DynControlImage: IJvDynControlImage;\r\n DynControlLabel: IJvDynControlLabel;\r\n MessagePanel: TWinControl;\r\n BottomPanel: TWinControl;\r\n ResultForm : TDSAMessageForm;\r\n Button : TButton;\r\n CheckBox : TWinControl;\r\n ImagePanel: TWinControl;\r\n CheckPanel : TWinControl;\r\n MainPanel : TWinControl;\r\n DynControlAutoSize: IJvDynControlAutoSize;\r\n\r\n procedure CalcTextRect(iSingle: Boolean; lpString: PChar; nCount: Integer; var lpRect: TRect);\r\n begin\r\n if iSingle then\r\n DrawText(ResultForm.Canvas.Handle, lpString, nCount, lpRect,\r\n DT_CALCRECT or DT_LEFT or DT_SINGLELINE or ResultForm.DrawTextBiDiModeFlagsReadingOnly)\r\n else\r\n DrawText(ResultForm.Canvas.Handle, lpString, nCount, lpRect,\r\n DT_EXPANDTABS or DT_CALCRECT or DT_WORDBREAK or ResultForm.DrawTextBiDiModeFlagsReadingOnly);\r\n end;\r\n\r\n procedure ResizeResultForm;\r\n begin\r\n ResultForm.ClientWidth := Max(TimeoutTextWidth,\r\n Max(17 + ChkTextWidth,\r\n Max(IconWidth+TextWidth, ButtonGroupWidth)))\r\n + HorzMargin * 2;\r\n ResultForm.ClientHeight := Max(IconHeight, TextHeight) + ButtonHeight + VertSpacing * 2 + VertMargin * 2;\r\n\r\n if CheckCaption <> '' then\r\n ResultForm.ClientHeight := ResultForm.ClientHeight + VertSpacing + 17;\r\n if ATimeout > 0 then\r\n ResultForm.ClientHeight := ResultForm.ClientHeight + VertSpacing + 13;\r\n\r\n if ResultForm.ClientWidth > Screen.Width-100 then\r\n ResultForm.ClientWidth := Screen.Width-100;\r\n if ResultForm.ClientHeight > Screen.Height-100 then\r\n ResultForm.ClientHeight := Screen.Height-100;\r\n\r\n ResultForm.Left := (CenterParWidth div 2) - (ResultForm.Width div 2) + CenterParLeft;\r\n ResultForm.Top := (CenterParHeight div 2) - (ResultForm.Height div 2) + CenterParTop;\r\n end;\r\n\r\nbegin\r\n ResultForm := nil;\r\n if Assigned(ADynControlEngine) then\r\n DynControlEngine := ADynControlEngine\r\n else\r\n DynControlEngine := DefaultDynControlEngine;\r\n case Center of\r\n dckScreen:\r\n CenterParent := Screen;\r\n dckMainForm:\r\n CenterParent := Application.MainForm;\r\n dckActiveForm:\r\n CenterParent := Screen.ActiveCustomForm;\r\n else\r\n CenterParent := nil;\r\n end;\r\n if CenterParent = nil then\r\n CenterParent := Screen;\r\n if CenterParent is TScreen then\r\n begin\r\n CenterParLeft := 0;\r\n CenterParTop := 0;\r\n CenterParWidth := TScreen(CenterParent).Width;\r\n CenterParHeight := TScreen(CenterParent).Height;\r\n end\r\n else\r\n begin\r\n CenterParLeft := TWinControl(CenterParent).Left;\r\n CenterParTop := TWinControl(CenterParent).Top;\r\n CenterParWidth := TWinControl(CenterParent).Width;\r\n CenterParHeight := TWinControl(CenterParent).Height;\r\n end;\r\n if HelpButton = High(Integer) then\r\n HelpButton := High(Buttons);\r\n ResultForm := TDSAMessageForm.CreateNew(Screen.ActiveCustomForm);\r\n try\r\n ResultForm.Msg := Msg;\r\n ResultForm.Position := poDesigned; // Delphi 2005 has a new default\r\n ResultForm.BiDiMode := Application.BiDiMode;\r\n ResultForm.BorderStyle := bsDialog;\r\n ResultForm.Canvas.Font := ResultForm.Font;\r\n ResultForm.KeyPreview := True;\r\n ResultForm.HelpContext := HelpCtx;\r\n ResultForm.OnKeyDown := ResultForm.CustomKeyDown;\r\n ResultForm.OnShow := ResultForm.CustomShow;\r\n ResultForm.OnMouseDown := ResultForm.CustomMouseDown;\r\n DialogUnits := GetAveCharSize(ResultForm.Canvas);\r\n HorzMargin := MulDiv(mcHorzMargin, DialogUnits.X, 4);\r\n VertMargin := MulDiv(mcVertMargin, DialogUnits.Y, 8);\r\n HorzSpacing := MulDiv(mcHorzSpacing, DialogUnits.X, 4);\r\n VertSpacing := MulDiv(mcVertSpacing, DialogUnits.Y, 8);\r\n ButtonWidth := MulDiv(mcButtonWidth, DialogUnits.X, 4);\r\n ResultForm.Timeout := Abs(ATimeout);\r\n for I := Low(Buttons) to High(Buttons) do\r\n begin\r\n TextRect := Rect(0, 0, 0, 0);\r\n CalcTextRect (true, PChar(Buttons[I]), -1, TextRect);\r\n if (TextRect.Right - TextRect.Left + 8) > ButtonWidth then\r\n ButtonWidth := (TextRect.Right - TextRect.Left + 8);\r\n end;\r\n ButtonHeight := MulDiv(mcButtonHeight, DialogUnits.Y, 8);\r\n ButtonSpacing := MulDiv(mcButtonSpacing, DialogUnits.X, 4);\r\n\r\n if (Screen.Width div 2) > (CenterParWidth + (2 * (CenterParLeft - Screen.DesktopLeft))) then\r\n SetRect(TextRect, 0, 0, CenterParWidth + (2 * (CenterParLeft - Screen.DesktopLeft)), 0)\r\n else\r\n SetRect(TextRect, 0, 0, Screen.Width div 2, 0);\r\n\r\n\r\n CalcTextRect (False, PChar(Msg), Length(Msg) + 1, TextRect);\r\n TextWidth := TextRect.Right;\r\n TextHeight := TextRect.Bottom;\r\n if CheckCaption <> '' then\r\n begin\r\n SetRect(TempRect, 0, 0, Screen.Width div 2, 0);\r\n CalcTextRect (False, PChar(CheckCaption), Length(CheckCaption) + 1, TempRect);\r\n ChkTextWidth := TempRect.Right;\r\n end\r\n else\r\n ChkTextWidth := 0;\r\n if ATimeout > 0 then\r\n begin\r\n SetRect(TempRect, 0, 0, Screen.Width div 2, 0);\r\n CalcTextRect (False, PChar(TimeFormatter(ResultForm.Timeout)),\r\n Length(TimeFormatter(ResultForm.Timeout)) + 1, TempRect);\r\n TimeoutTextWidth := TempRect.Right;\r\n end\r\n else\r\n TimeoutTextWidth := 0;\r\n if APicture <> nil then\r\n begin\r\n IconWidth := APicture.Width + HorzSpacing;\r\n IconHeight := APicture.Height;\r\n end\r\n else\r\n begin\r\n IconWidth := 0;\r\n IconHeight := 0;\r\n end;\r\n\r\n ButtonCount := Length(Buttons);\r\n ButtonGroupWidth := 0;\r\n if ButtonCount <> 0 then\r\n ButtonGroupWidth := ButtonWidth * ButtonCount + ButtonSpacing * (ButtonCount - 1);\r\n\r\n ResizeResultForm;\r\n\r\n if ACaption <> '' then\r\n ResultForm.Caption := ACaption\r\n else\r\n ResultForm.Caption := Application.Title;\r\n\r\n BottomPanel := DynControlEngine.CreatePanelControl(ResultForm, ResultForm, 'BottomPanel', '', alBottom);\r\n BottomPanel.Height := VertSpacing+VertMargin+ButtonHeight;\r\n\r\n MainPanel := DynControlEngine.CreatePanelControl(ResultForm, ResultForm, 'MainPanel', '', alClient);\r\n\r\n CheckPanel := DynControlEngine.CreatePanelControl(ResultForm, MainPanel, 'CheckPanel', '', alBottom);\r\n CheckPanel.Visible := (CheckCaption <> '') or (ATimeout > 0);\r\n\r\n ImagePanel := DynControlEngine.CreatePanelControl(ResultForm, MainPanel, 'ImagePanel', '', alLeft);\r\n ImagePanel.Visible := Assigned(APicture);\r\n if Assigned(APicture) then\r\n begin\r\n ImagePanel.Width := APicture.Width + 4 + HorzMargin - 2;\r\n Image := DynControlEngine.CreateImageControl(ResultForm, ImagePanel, 'Image');\r\n if Supports(Image, IJvDynControlImage, DynControlImage) then\r\n begin\r\n DynControlImage.ControlSetGraphic(APicture);\r\n DynControlImage.ControlSetCenter(True);\r\n end;\r\n Image.SetBounds(HorzMargin - 2, VertMargin - 2, APicture.Width + 2, APicture.Height + 2);\r\n Image.Enabled := False;\r\n end;\r\n\r\n MessagePanel := DynControlEngine.CreatePanelControl(ResultForm, MainPanel, 'Panel', '', alClient);\r\n if ImagePanel.Visible then\r\n MessagePanel.Width := MainPanel.Width-ImagePanel.Width\r\n else\r\n MessagePanel.Width := MainPanel.Width;\r\n MessageLabel := DynControlEngine.CreateLabelControl(ResultForm, MessagePanel, 'Message', Msg, nil);\r\n\r\n if Assigned(APicture) then\r\n MessageLabel.Left := HorzSpacing\r\n else\r\n MessageLabel.Left := HorzMargin;\r\n MessageLabel.Top := VertMargin;\r\n MessageLabel.Width := MessagePanel.Width-MessageLabel.Left;\r\n MessageLabel.Height := MessagePanel.Height - MessageLabel.Top;\r\n\r\n if Supports(MessageLabel, IJvDynControlLabel, DynControlLabel) then\r\n DynControlLabel.ControlSetWordWrap(True);\r\n if Supports(MessageLabel, IJvDynControlAutoSize, DynControlAutoSize) then\r\n begin\r\n DynControlAutoSize.ControlSetAutoSize(True);\r\n TextWidth := MessageLabel.Width;\r\n TextHeight := MessageLabel.Height;\r\n end;\r\n\r\n MessageLabel.BiDiMode := ResultForm.BiDiMode;\r\n\r\n ResultForm.DefaultButton := nil;\r\n X := (ResultForm.ClientWidth - ButtonGroupWidth) div 2;\r\n for I := Low(Buttons) to High(Buttons) do\r\n begin\r\n Button := DynControlEngine.CreateButton(ResultForm, BottomPanel, 'Button' + IntToStr(I), Buttons[I], '', nil, False, False);\r\n Button.ModalResult := Results[I];\r\n if I = DefaultButton then\r\n begin\r\n ResultForm.DefaultButton := Button;\r\n Button.Default := True;\r\n end;\r\n if I = CancelButton then\r\n Button.Cancel := True;\r\n Button.TabStop := True;\r\n Button.SetBounds(X, VertSpacing, ButtonWidth, ButtonHeight);\r\n Inc(X, ButtonWidth + ButtonSpacing);\r\n if I = HelpButton then\r\n Button.OnClick := ResultForm.HelpButtonClick;\r\n end;\r\n CheckBox := nil; // to avoid warnings\r\n if CheckCaption <> '' then\r\n begin\r\n CheckBox := DynControlEngine.CreateCheckboxControl(ResultForm, CheckPanel, 'DontShowAgain', CheckCaption);\r\n CheckBox.BiDiMode := ResultForm.BiDiMode;\r\n CheckBox.SetBounds(HorzMargin, 0,\r\n ResultForm.ClientWidth - 2 * HorzMargin, CheckBox.Height);\r\n CheckPanel.Height := CheckBox.Height;\r\n end;\r\n if ATimeout > 0 then\r\n begin\r\n CountDownlabel := DynControlEngine.CreateLabelControl(ResultForm, CheckPanel, 'Countdown',\r\n TimeFormatter(ResultForm.Timeout), nil);\r\n\r\n CountDownlabel.BiDiMode := ResultForm.BiDiMode;\r\n if CheckCaption <> '' then\r\n begin\r\n CheckPanel.Height := CheckBox.Height+CountDownlabel.Height+VertSpacing;;\r\n CountDownlabel.SetBounds (HorzMargin, CheckBox.Height+VertSpacing,\r\n ResultForm.ClientWidth - 2 * HorzMargin, CountDownlabel.Height)\r\n end\r\n else\r\n begin\r\n CheckPanel.Height := CountDownlabel.Height;;\r\n CountDownlabel.SetBounds(HorzMargin, 0,\r\n ResultForm.ClientWidth - 2 * HorzMargin, CountDownlabel.Height);\r\n end;\r\n end;\r\n\r\n ResizeResultForm;\r\n\r\n except\r\n FreeAndNil(ResultForm);\r\n raise;\r\n end;\r\n Result := ResultForm;\r\nend;\r\n\r\n//=== { TDSARegister } =======================================================\r\n\r\ntype\r\n TAddResult = (arAdded, arExists, arDuplicateID, arDuplicateName);\r\n\r\n TDSARegister = class\r\n private\r\n FList: array of TDSARegItem;\r\n protected\r\n function AddNew: Integer;\r\n procedure Remove(const Index: Integer);\r\n function IndexOf(const ID: Integer): Integer; overload;\r\n function IndexOf(const Name: string): Integer; overload;\r\n function IndexOf(const Item: TDSARegItem): Integer; overload;\r\n public\r\n destructor Destroy; override;\r\n function Add(const Item: TDSARegItem): TAddResult; overload;\r\n function Add(const ID: Integer; const Name, Description: string;\r\n const Storage: TDSAStorage; const CheckTextKind:\r\n TDSACheckTextKind = ctkShow): TAddResult; overload;\r\n procedure Clear;\r\n// procedure Delete(const Item: TDSARegItem); overload;\r\n procedure Delete(const ID: Integer); overload;\r\n// procedure Delete(const Name: string); overload;\r\n function Locate(const ID: Integer): TDSARegItem; overload;\r\n// function Locate(const Name: string): TDSARegItem; overload;\r\n end;\r\n\r\nconst\r\n EmptyItem: TDSARegItem = (ID: High(Integer); Name: ''; Storage: nil);\r\n\r\nvar\r\n GlobalDSARegister: TDSARegister = nil;\r\n\r\nfunction DSARegister: TDSARegister;\r\nbegin\r\n if not Assigned(GlobalDSARegister) then\r\n begin\r\n GlobalDSARegister := TDSARegister.Create;\r\n // register\r\n RegisterDSACheckMarkText(ctkShow, RsDSActkShowText);\r\n RegisterDSACheckMarkText(ctkAsk, RsDSActkAskText);\r\n RegisterDSACheckMarkText(ctkWarn, RsDSActkWarnText);\r\n end;\r\n Result := GlobalDSARegister;\r\nend;\r\n\r\ndestructor TDSARegister.Destroy;\r\nbegin\r\n inherited Destroy;\r\n Clear;\r\nend;\r\n\r\nfunction TDSARegister.AddNew: Integer;\r\nbegin\r\n Result := Length(FList);\r\n SetLength(FList, Result + 1);\r\nend;\r\n\r\nprocedure TDSARegister.Remove(const Index: Integer);\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := Index + 1 to High(FList) do\r\n begin\r\n FList[I-1].ID := FList[I].ID;\r\n FList[I-1].Name := FList[I].Name;\r\n FList[I-1].Description := FList[I].Description;\r\n FList[I-1].ChkTextKind := FList[I].ChkTextKind;\r\n FList[I-1].Storage := FList[I].Storage;\r\n end;\r\n SetLength(FList, High(FList));\r\nend;\r\n\r\nfunction TDSARegister.IndexOf(const ID: Integer): Integer;\r\nbegin\r\n Result := High(FList);\r\n while (Result > -1) and (FList[Result].ID <> ID) do\r\n Dec(Result);\r\nend;\r\n\r\nfunction TDSARegister.IndexOf(const Name: string): Integer;\r\nbegin\r\n Result := High(FList);\r\n while (Result > -1) and not AnsiSameText(FList[Result].Name, Name) do\r\n Dec(Result);\r\nend;\r\n\r\nfunction TDSARegister.IndexOf(const Item: TDSARegItem): Integer;\r\nbegin\r\n Result := IndexOf(Item.ID);\r\n if (Result > -1) and not AnsiSameText(FList[Result].Name, Item.Name) then\r\n Result := -1;\r\nend;\r\n\r\nfunction TDSARegister.Add(const Item: TDSARegItem): TAddResult;\r\nvar\r\n Idx: Integer;\r\nbegin\r\n if IndexOf(Item) > -1 then\r\n Result := arExists\r\n else\r\n if IndexOf(Item.ID) > -1 then\r\n begin\r\n Idx := IndexOf(Item.ID);\r\n if AnsiSameText(FList[Idx].Name, Item.Name) then\r\n Result := arExists\r\n else\r\n Result := arDuplicateID;\r\n end\r\n else\r\n if IndexOf(Item.Name) > -1 then\r\n Result := arDuplicateName\r\n else\r\n begin\r\n Idx := AddNew;\r\n FList[Idx].ID := Item.ID;\r\n FList[Idx].Name := Item.Name;\r\n FList[Idx].Description := Item.Description;\r\n FList[Idx].Storage := Item.Storage;\r\n FList[Idx].ChkTextKind := Item.ChkTextKind;\r\n Result := arAdded;\r\n end;\r\nend;\r\n\r\nfunction TDSARegister.Add(const ID: Integer; const Name, Description: string;\r\n const Storage: TDSAStorage; const CheckTextKind: TDSACheckTextKind = ctkShow): TAddResult;\r\nvar\r\n TmpItem: TDSARegItem;\r\nbegin\r\n TmpItem.ID := ID;\r\n TmpItem.Name := Name;\r\n TmpItem.Description := Description;\r\n TmpItem.Storage := Storage;\r\n TmpItem.ChkTextKind := CheckTextKind;\r\n Result := Add(TmpItem);\r\nend;\r\n\r\nprocedure TDSARegister.Clear;\r\nbegin\r\n SetLength(FList, 0);\r\nend;\r\n\r\n(* make Delphi 5 compiler happy // andreas\r\nprocedure TDSARegister.Delete(const Item: TDSARegItem);\r\nvar\r\n Idx: Integer;\r\nbegin\r\n Idx := IndexOf(Item.ID);\r\n if (Idx > -1) and AnsiSameText(FList[Idx].Name, Item.Name) then\r\n Remove(Idx);\r\nend;\r\n*)\r\n\r\nprocedure TDSARegister.Delete(const ID: Integer);\r\nvar\r\n Idx: Integer;\r\nbegin\r\n Idx := IndexOf(ID);\r\n if Idx > -1 then\r\n Remove(Idx);\r\nend;\r\n\r\n(* make Delphi 5 compiler happy // andreas\r\nprocedure TDSARegister.Delete(const Name: string);\r\nvar\r\n Idx: Integer;\r\nbegin\r\n Idx := IndexOf(Name);\r\n if Idx > -1 then\r\n Remove(Idx);\r\nend;\r\n*)\r\n\r\nfunction TDSARegister.Locate(const ID: Integer): TDSARegItem;\r\nvar\r\n Idx: Integer;\r\nbegin\r\n Idx := IndexOf(ID);\r\n if Idx > -1 then\r\n Result := FList[Idx]\r\n else\r\n Result := EmptyItem;\r\nend;\r\n\r\n(* make Delphi 5 compiler happy // andreas\r\nfunction TDSARegister.Locate(const Name: string): TDSARegItem;\r\nvar\r\n Idx: Integer;\r\nbegin\r\n Idx := IndexOf(Name);\r\n if Idx > -1 then\r\n Result := FList[Idx]\r\n else\r\n Result := EmptyItem;\r\nend;\r\n*)\r\n\r\n//=== { TDSAStorage } ========================================================\r\n\r\nconstructor TDSAStorage.Create;\r\nbegin\r\n inherited Create;\r\n FStates := TStack.Create;\r\nend;\r\n\r\ndestructor TDSAStorage.Destroy;\r\nbegin\r\n FStates.Free;\r\n inherited Create;\r\nend;\r\n\r\nprocedure TDSAStorage.BeginCustomRead(const DSAInfo: TDSARegItem);\r\nbegin\r\n FStates.Push(ssCustomRead);\r\nend;\r\n\r\nprocedure TDSAStorage.BeginCustomWrite(const DSAInfo: TDSARegItem);\r\nbegin\r\n FStates.Push(ssCustomWrite);\r\nend;\r\n\r\nprocedure TDSAStorage.BeginRead(const DSAInfo: TDSARegItem);\r\nbegin\r\n FStates.Push(ssRead);\r\nend;\r\n\r\nprocedure TDSAStorage.BeginWrite(const DSAInfo: TDSARegItem);\r\nbegin\r\n FStates.Push(ssWrite);\r\nend;\r\n\r\nprocedure TDSAStorage.EndCustomRead(const DSAInfo: TDSARegItem);\r\nbegin\r\n if FStates.Peek <> ssCustomRead then\r\n raise EJvDSADialog.CreateRes(@RsECannotEndCustomReadIfNotInCustomRea);\r\n FStates.Pop;\r\nend;\r\n\r\nprocedure TDSAStorage.EndCustomWrite(const DSAInfo: TDSARegItem);\r\nbegin\r\n if FStates.Peek <> ssCustomWrite then\r\n raise EJvDSADialog.CreateRes(@RsECannotEndCustomWriteIfNotInCustomWr);\r\n FStates.Pop;\r\nend;\r\n\r\nprocedure TDSAStorage.EndRead(const DSAInfo: TDSARegItem);\r\nbegin\r\n if FStates.Peek <> ssRead then\r\n raise EJvDSADialog.CreateRes(@RsECannotEndReadIfNotInReadMode);\r\n FStates.Pop;\r\nend;\r\n\r\nprocedure TDSAStorage.EndWrite(const DSAInfo: TDSARegItem);\r\nbegin\r\n if FStates.Peek <> ssWrite then\r\n raise EJvDSADialog.CreateRes(@RsECannotEndWriteIfNotInWriteMode);\r\n FStates.Pop;\r\nend;\r\n\r\nfunction TDSAStorage.IsKeyNameAllowed(const Key: string): Boolean;\r\nbegin\r\n if AnsiSameText(Key, cDSAStateValueName) or AnsiSameText(Key, cDSAStateLastResultName) then\r\n Result := Integer(FStates.Peek) in [Integer(ssRead), Integer(ssWrite)]\r\n else\r\n Result := Integer(FStates.Peek) in [Integer(ssCustomRead), Integer(ssCustomWrite)];\r\nend;\r\n\r\nfunction TDSAStorage.GetState(const DSAInfo: TDSARegItem; out LastResult: Integer;\r\n const OnCustomData: TDSACustomData = nil): Boolean;\r\nbegin\r\n BeginRead(DSAInfo);\r\n try\r\n LastResult := 0;\r\n Result := ReadBoolDef(DSAInfo, cDSAStateValueName, False);\r\n if Result then\r\n begin\r\n LastResult := ReadIntegerDef(DSAInfo, cDSAStateLastResultName, 0);\r\n if Assigned(OnCustomData) then\r\n begin\r\n BeginCustomRead(DSAInfo);\r\n try\r\n OnCustomData(Self, DSAInfo);\r\n finally\r\n EndCustomRead(DSAInfo);\r\n end;\r\n end;\r\n end;\r\n finally\r\n EndRead(DSAInfo);\r\n end;\r\nend;\r\n\r\nprocedure TDSAStorage.SetState(const DSAInfo: TDSARegItem; const DontShowAgain: Boolean;\r\n const LastResult: Integer; const OnCustomData: TDSACustomData = nil);\r\nbegin\r\n BeginWrite(DSAInfo);\r\n try\r\n WriteBool(DSAInfo, cDSAStateValueName, DontShowAgain);\r\n if DontShowAgain then\r\n begin\r\n WriteInteger(DSAInfo, cDSAStateLastResultName, LastResult);\r\n if Assigned(OnCustomData) then\r\n begin\r\n BeginCustomWrite(DSAInfo);\r\n try\r\n OnCustomData(Self, DSAInfo);\r\n finally\r\n EndCustomWrite(DSAInfo);\r\n end;\r\n end;\r\n end;\r\n finally\r\n EndWrite(DSAInfo);\r\n end;\r\nend;\r\n\r\n//=== { TDSARegStorage } =====================================================\r\n\r\n{$IFDEF MSWINDOWS}\r\n\r\nconstructor TDSARegStorage.Create(const ARootKey: HKEY; const AKey: string);\r\nbegin\r\n inherited Create;\r\n FRootKey := ARootKey;\r\n FKey := AKey;\r\nend;\r\n\r\nprocedure TDSARegStorage.CreateKey(const DSAInfo: TDSARegItem);\r\nbegin\r\n if not (RegKeyExists(RootKey, Key + '\\' + DSAInfo.Name) or\r\n (RegCreateKey(RootKey, Key + '\\' + DSAInfo.Name, '') = ERROR_SUCCESS)) then\r\n raise EJvDSADialog.CreateResFmt(@RsEDSARegKeyCreateError, [Key + '\\' + DSAInfo.Name]);\r\nend;\r\n\r\nfunction TDSARegStorage.GetCheckMarkTextSuffix: string;\r\nbegin\r\n Result := '';\r\nend;\r\n\r\nprocedure TDSARegStorage.SetCheckMarkTextSuffix(const Value: string);\r\nbegin\r\nend;\r\n\r\nfunction TDSARegStorage.ReadBool(const DSAInfo: TDSARegItem; const Key: string): Boolean;\r\nbegin\r\n Result := RegReadBool(RootKey, Self.Key + '\\' + DSAInfo.Name, Key);\r\nend;\r\n\r\nfunction TDSARegStorage.ReadBoolDef(const DSAInfo: TDSARegItem; const Key: string;\r\n const Default: Boolean): Boolean;\r\nbegin\r\n Result := RegReadBoolDef(RootKey, Self.Key + '\\' + DSAInfo.Name, Key, Default);\r\nend;\r\n\r\nfunction TDSARegStorage.ReadFloat(const DSAInfo: TDSARegItem; const Key: string): Extended;\r\nbegin\r\n RegReadBinary(RootKey, Self.Key + '\\' + DSAInfo.Name, Key, Result, SizeOf(Extended));\r\nend;\r\n\r\nfunction TDSARegStorage.ReadFloatDef(const DSAInfo: TDSARegItem; const Key: string;\r\n const Default: Extended): Extended;\r\nbegin\r\n if RegReadBinaryDef(RootKey, Self.Key + '\\' + DSAInfo.Name, Key, Result, SizeOf(Extended), 0) = 0 then\r\n Result := Default;\r\nend;\r\n\r\nfunction TDSARegStorage.ReadInt64(const DSAInfo: TDSARegItem; const Key: string): Int64;\r\nbegin\r\n Result := RegReadInt64(RootKey, Self.Key + '\\' + DSAInfo.Name, Key);\r\nend;\r\n\r\nfunction TDSARegStorage.ReadInt64Def(const DSAInfo: TDSARegItem; const Key: string; const Default: Int64): Int64;\r\nbegin\r\n Result := RegReadInt64Def(RootKey, Self.Key + '\\' + DSAInfo.Name, Key, Default);\r\nend;\r\n\r\nfunction TDSARegStorage.ReadInteger(const DSAInfo: TDSARegItem; const Key: string): Integer;\r\nbegin\r\n Result := RegReadInteger(RootKey, Self.Key + '\\' + DSAInfo.Name, Key);\r\nend;\r\n\r\nfunction TDSARegStorage.ReadIntegerDef(const DSAInfo: TDSARegItem; const Key: string;\r\n const Default: Integer): Integer;\r\nbegin\r\n Result := RegReadIntegerDef(RootKey, Self.Key + '\\' + DSAInfo.Name, Key, Default);\r\nend;\r\n\r\nfunction TDSARegStorage.ReadString(const DSAInfo: TDSARegItem; const Key: string): string;\r\nbegin\r\n Result := RegReadString(RootKey, Self.Key + '\\' + DSAInfo.Name, Key);\r\nend;\r\n\r\nfunction TDSARegStorage.ReadStringDef(const DSAInfo: TDSARegItem; const Key: string;\r\n const Default: string): string;\r\nbegin\r\n Result := RegReadStringDef(RootKey, Self.Key + '\\' + DSAInfo.Name, Key, Default);\r\nend;\r\n\r\nprocedure TDSARegStorage.WriteBool(const DSAInfo: TDSARegItem; const Key: string;\r\n const Value: Boolean);\r\nbegin\r\n CreateKey(DSAInfo);\r\n RegWriteBool(RootKey, Self.Key + '\\' + DSAInfo.Name, Key, Value);\r\nend;\r\n\r\nprocedure TDSARegStorage.WriteFloat(const DSAInfo: TDSARegItem; const Key: string;\r\n const Value: Extended);\r\nvar\r\n Temp: Extended;\r\nbegin\r\n CreateKey(DSAInfo);\r\n Temp := Value;\r\n RegWriteBinary(RootKey, Self.Key + '\\' + DSAInfo.Name, Key, Temp, SizeOf(Extended));\r\nend;\r\n\r\nprocedure TDSARegStorage.WriteInt64(const DSAInfo: TDSARegItem; const Key: string;\r\n const Value: Int64);\r\nbegin\r\n CreateKey(DSAInfo);\r\n RegWriteInt64(RootKey, Self.Key + '\\' + DSAInfo.Name, Key, Value);\r\nend;\r\n\r\nprocedure TDSARegStorage.WriteInteger(const DSAInfo: TDSARegItem; const Key: string;\r\n const Value: Integer);\r\nbegin\r\n CreateKey(DSAInfo);\r\n RegWriteInteger(RootKey, Self.Key + '\\' + DSAInfo.Name, Key, Value);\r\nend;\r\n\r\nprocedure TDSARegStorage.WriteString(const DSAInfo: TDSARegItem; const Key: string;\r\n const Value: string);\r\nbegin\r\n CreateKey(DSAInfo);\r\n RegWriteString(RootKey, Self.Key + '\\' + DSAInfo.Name, Key, Value);\r\nend;\r\n\r\n{$ENDIF MSWINDOWS}\r\n\r\n//=== { TDSAValues } =========================================================\r\n\r\nconst\r\n DSABool = 1;\r\n DSAFloat = 2;\r\n DSAInt64 = 3;\r\n DSAInt = 4;\r\n DSAString = 5;\r\n\r\n DSAKindTexts: array [DSABool..DSAString] of string =\r\n (RsEDSAAccessBool, RsEDSAAccessFloat, RsEDSAAccessInt64, RsEDSAAccessInt, RsEDSAAccessString);\r\n\r\ntype\r\n TDSAValues = class(TStringList)\r\n public\r\n constructor Create;\r\n end;\r\n\r\nconstructor TDSAValues.Create;\r\nbegin\r\n inherited Create;\r\n Sorted := True;\r\nend;\r\n\r\n//=== { TDSAQueueStorage } ===================================================\r\n\r\nconstructor TDSAQueueStorage.Create;\r\nbegin\r\n inherited Create;\r\n FList := TStringList.Create;\r\n FList.Sorted := True;\r\n FCheckMarkSuffix := RsInTheCurrentQueue;\r\nend;\r\n\r\ndestructor TDSAQueueStorage.Destroy;\r\nbegin\r\n Clear;\r\n FList.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TDSAQueueStorage.AddDSA(const DSAInfo: TDSARegItem);\r\nbegin\r\n if FindDSA(DSAInfo) < 0 then\r\n FList.AddObject(DSAInfo.Name, TDSAValues.Create);\r\nend;\r\n\r\nprocedure TDSAQueueStorage.DeleteDSA(const Index: Integer);\r\nbegin\r\n FList.Objects[Index].Free;\r\n FList.Delete(Index);\r\nend;\r\n\r\nfunction TDSAQueueStorage.FindDSA(const DSAInfo: TDSARegItem): Integer;\r\nbegin\r\n Result := FList.IndexOf(DSAInfo.Name);\r\nend;\r\n\r\nfunction TDSAQueueStorage.GetCheckMarkTextSuffix: string;\r\nbegin\r\n Result := FCheckMarkSuffix;\r\nend;\r\n\r\nfunction TDSAQueueStorage.GetDSAValue(const DSAInfo: TDSARegItem; const Key: string;\r\n const Kind: Integer): string;\r\nvar\r\n I: Integer;\r\n DSAKeys: TStrings;\r\nbegin\r\n I := FindDSA(DSAInfo);\r\n if I < 0 then\r\n raise EJvDSADialog.CreateResFmt(@RsEDSADialogIDNotStored, [DSAInfo.ID]);\r\n DSAKeys := TStrings(FList.Objects[I]);\r\n I := DSAKeys.IndexOfName(Key);\r\n if I < 0 then\r\n raise EJvDSADialog.CreateResFmt(@RsEDSAKeyNotFound, [Key]);\r\n if Integer(DSAKeys.Objects[I]) <> Kind then\r\n raise EJvDSADialog.CreateResFmt(@RsEDSAKeyNoAccessAs, [Key, DSAKindTexts[Kind]]);\r\n Result := DSAKeys.Values[Key];\r\nend;\r\n\r\nfunction TDSAQueueStorage.HasDSAKey(const DSAInfo: TDSARegItem; const Key: string): Boolean;\r\nvar\r\n I: Integer;\r\n DSAKeys: TStrings;\r\nbegin\r\n I := FindDSA(DSAInfo);\r\n Result := I > -1;\r\n if Result then\r\n begin\r\n DSAKeys := TStrings(FList.Objects[I]);\r\n Result := DSAKeys.IndexOfName(Key) > -1;\r\n end;\r\nend;\r\n\r\nprocedure TDSAQueueStorage.SetCheckMarkTextSuffix(const Value: string);\r\nbegin\r\n if Value <> CheckMarkTextSuffix then\r\n FCheckMarkSuffix := Value;\r\nend;\r\n\r\nprocedure TDSAQueueStorage.SetDSAValue(const DSAInfo: TDSARegItem; const Key: string;\r\n const Kind: Integer; const Value: string);\r\nvar\r\n I: Integer;\r\n DSAKeys: TStrings;\r\nbegin\r\n AddDSA(DSAInfo);\r\n I := FindDSA(DSAInfo);\r\n if I < 0 then\r\n raise EJvDSADialog.CreateResFmt(@RsEDSADialogIDNotStored, [DSAInfo.ID]);\r\n DSAKeys := TStrings(FList.Objects[I]);\r\n I := DSAKeys.IndexOfName(Key);\r\n if I < 0 then\r\n DSAKeys.AddObject(Key + '=' + Value, TObject(Kind))\r\n else\r\n begin\r\n if Integer(DSAKeys.Objects[I]) <> Kind then\r\n raise EJvDSADialog.CreateResFmt(@RsEDSAKeyNoAccessAs, [Key, DSAKindTexts[Kind]]);\r\n DSAKeys.Values[Key] := Value;\r\n end;\r\nend;\r\n\r\nprocedure TDSAQueueStorage.Clear;\r\nbegin\r\n while FList.Count > 0 do\r\n DeleteDSA(FList.Count - 1);\r\nend;\r\n\r\nfunction TDSAQueueStorage.ReadBool(const DSAInfo: TDSARegItem; const Key: string): Boolean;\r\nvar\r\n S: string;\r\nbegin\r\n S := GetDSAValue(DSAInfo, Key, DSABool);\r\n Result := AnsiSameText(S, 'True') or AnsiSameText(S, '1');\r\nend;\r\n\r\nfunction TDSAQueueStorage.ReadBoolDef(const DSAInfo: TDSARegItem; const Key: string;\r\n const Default: Boolean): Boolean;\r\nbegin\r\n if HasDSAKey(DSAInfo, Key) then\r\n Result := ReadBool(DSAInfo, Key)\r\n else\r\n Result := Default;\r\nend;\r\n\r\nfunction TDSAQueueStorage.ReadFloat(const DSAInfo: TDSARegItem; const Key: string): Extended;\r\nbegin\r\n Result := StrToFloat(StringReplace(GetDSAValue(DSAInfo, Key, DSAFloat),\r\n JclFormatSettings.ThousandSeparator, JclFormatSettings.DecimalSeparator, [rfReplaceAll, rfIgnoreCase]));\r\nend;\r\n\r\nfunction TDSAQueueStorage.ReadFloatDef(const DSAInfo: TDSARegItem; const Key: string;\r\n const Default: Extended): Extended;\r\nbegin\r\n if HasDSAKey(DSAInfo, Key) then\r\n Result := ReadFloat(DSAInfo, Key)\r\n else\r\n Result := Default;\r\nend;\r\n\r\nfunction TDSAQueueStorage.ReadInt64(const DSAInfo: TDSARegItem; const Key: string): Int64;\r\nbegin\r\n Result := StrToInt64(GetDSAValue(DSAInfo, Key, DSAInt64));\r\nend;\r\n\r\nfunction TDSAQueueStorage.ReadInt64Def(const DSAInfo: TDSARegItem; const Key: string;\r\n const Default: Int64): Int64;\r\nbegin\r\n if HasDSAKey(DSAInfo, Key) then\r\n Result := ReadInt64(DSAInfo, Key)\r\n else\r\n Result := Default;\r\nend;\r\n\r\nfunction TDSAQueueStorage.ReadInteger(const DSAInfo: TDSARegItem; const Key: string): Integer;\r\nbegin\r\n Result := StrToInt(GetDSAValue(DSAInfo, Key, DSAInt));\r\nend;\r\n\r\nfunction TDSAQueueStorage.ReadIntegerDef(const DSAInfo: TDSARegItem; const Key: string;\r\n const Default: Integer): Integer;\r\nbegin\r\n if HasDSAKey(DSAInfo, Key) then\r\n Result := ReadInteger(DSAInfo, Key)\r\n else\r\n Result := Default;\r\nend;\r\n\r\nfunction TDSAQueueStorage.ReadString(const DSAInfo: TDSARegItem; const Key: string): string;\r\nbegin\r\n Result := GetDSAValue(DSAInfo, Key, DSAString);\r\nend;\r\n\r\nfunction TDSAQueueStorage.ReadStringDef(const DSAInfo: TDSARegItem; const Key: string;\r\n const Default: string): string;\r\nbegin\r\n if HasDSAKey(DSAInfo, Key) then\r\n Result := ReadString(DSAInfo, Key)\r\n else\r\n Result := Default;\r\nend;\r\n\r\nprocedure TDSAQueueStorage.WriteBool(const DSAInfo: TDSARegItem; const Key: string;\r\n const Value: Boolean);\r\nbegin\r\n if Value then\r\n SetDSAValue(DSAInfo, Key, DSABool, '1')\r\n else\r\n SetDSAValue(DSAInfo, Key, DSABool, '0');\r\nend;\r\n\r\nprocedure TDSAQueueStorage.WriteFloat(const DSAInfo: TDSARegItem; const Key: string;\r\n const Value: Extended);\r\nbegin\r\n SetDSAValue(DSAInfo, Key, DSAFloat, FloatToStr(Value));\r\nend;\r\n\r\nprocedure TDSAQueueStorage.WriteInt64(const DSAInfo: TDSARegItem; const Key: string;\r\n const Value: Int64);\r\nbegin\r\n SetDSAValue(DSAInfo, Key, DSAInt64, IntToStr(Value));\r\nend;\r\n\r\nprocedure TDSAQueueStorage.WriteInteger(const DSAInfo: TDSARegItem; const Key: string;\r\n const Value: Integer);\r\nbegin\r\n SetDSAValue(DSAInfo, Key, DSAInt, IntToStr(Value));\r\nend;\r\n\r\nprocedure TDSAQueueStorage.WriteString(const DSAInfo: TDSARegItem; const Key: string;\r\n const Value: string);\r\nbegin\r\n SetDSAValue(DSAInfo, Key, DSAString, Value);\r\nend;\r\n\r\n//--------------------------------------------------------------------------------------------------\r\n// Helpers\r\n//--------------------------------------------------------------------------------------------------\r\n\r\nconst\r\n Captions: array [TMsgDlgType] of string =\r\n (SMsgDlgWarning, SMsgDlgError, SMsgDlgInformation, SMsgDlgConfirm, '');\r\n IconIDs: array [TMsgDlgType] of PChar =\r\n (IDI_EXCLAMATION, IDI_HAND, IDI_ASTERISK, IDI_QUESTION, nil);\r\n\r\n ButtonCaptions: array [TMsgDlgBtn] of string =\r\n (SMsgDlgYes, SMsgDlgNo, SMsgDlgOK, SMsgDlgCancel, SMsgDlgAbort,\r\n SMsgDlgRetry, SMsgDlgIgnore, SMsgDlgAll, SMsgDlgNoToAll, SMsgDlgYesToAll,\r\n SMsgDlgHelp{$IFDEF COMPILER12_UP}, SMsgDlgClose{$ENDIF COMPILER12_UP});\r\n ModalResults: array [TMsgDlgBtn] of Integer =\r\n (mrYes, mrNo, mrOk, mrCancel, mrAbort, mrRetry, mrIgnore, mrAll, mrNoToAll,\r\n mrYesToAll, 0{$IFDEF COMPILER12_UP}, mrClose{$ENDIF COMPILER12_UP});\r\n\r\nfunction DlgCaption(const DlgType: TMsgDlgType): string;\r\nbegin\r\n Result := Captions[DlgType];\r\nend;\r\n\r\nfunction DlgPic(const DlgType: TMsgDlgType): TGraphic;\r\nbegin\r\n if IconIDs[DlgType] <> nil then\r\n begin\r\n Result := TIcon.Create;\r\n try\r\n TIcon(Result).Handle := LoadIcon(0, IconIDs[DlgType]);\r\n except\r\n Result.Free;\r\n raise;\r\n end;\r\n end\r\n else\r\n Result := nil;\r\nend;\r\n\r\nfunction DlgButtonCaptions(const Buttons: TMsgDlgButtons): TDynStringArray;\r\nvar\r\n I: Integer;\r\n B: TMsgDlgBtn;\r\nbegin\r\n SetLength(Result, Ord(High(TMsgDlgBtn)) + 1);\r\n I := 0;\r\n for B := Low(TMsgDlgBtn) to High(TMsgDlgBtn) do\r\n if B in Buttons then\r\n begin\r\n Result[I] := ButtonCaptions[B];\r\n Inc(I);\r\n end;\r\n SetLength(Result, I);\r\nend;\r\n\r\nfunction DlgButtonResults(const Buttons: TMsgDlgButtons): TDynIntegerArray;\r\nvar\r\n I: Integer;\r\n B: TMsgDlgBtn;\r\nbegin\r\n SetLength(Result, Ord(High(TMsgDlgBtn)) + 1);\r\n I := 0;\r\n for B := Low(TMsgDlgBtn) to High(TMsgDlgBtn) do\r\n if B in Buttons then\r\n begin\r\n Result[I] := ModalResults[B];\r\n Inc(I);\r\n end;\r\n SetLength(Result, I);\r\nend;\r\n\r\nfunction ButtonIndex(const Results: array of Integer; const ResCode: Integer): Integer; overload;\r\nbegin\r\n Result := High(Results);\r\n while (Result > -1) and (Results[Result] <> ResCode) do\r\n Dec(Result);\r\nend;\r\n\r\nfunction ButtonIndex(const Results: array of Integer; const Button: TMsgDlgBtn): Integer; overload;\r\nbegin\r\n Result := ButtonIndex(Results, ModalResults[Button]);\r\nend;\r\n\r\n//----------------------------------------------------------------------------\r\n// MessageDlg replacements and extensions\r\n//----------------------------------------------------------------------------\r\n\r\nprocedure ShowMessage(const Msg: string; const Center: TDlgCenterKind; const Timeout: Integer;\r\n const ADynControlEngine: TJvDynControlEngine);\r\nbegin\r\n MessageDlg(Msg, mtCustom, [mbOK], 0, Center, Timeout);\r\nend;\r\n\r\nprocedure ShowMessageFmt(const Msg: string; const Params: array of const; const Center: TDlgCenterKind;\r\n const Timeout: Integer; const ADynControlEngine: TJvDynControlEngine);\r\nbegin\r\n MessageDlg(Format(Msg, Params), mtCustom, [mbOK], 0, Center, Timeout);\r\nend;\r\n\r\nfunction MessageDlg(const Msg: string; const DlgType: TMsgDlgType; const Buttons: TMsgDlgButtons;\r\n const HelpCtx: Longint; const Center: TDlgCenterKind; const Timeout: Integer;\r\n const DefaultButton: TMsgDlgBtn; const CancelButton: TMsgDlgBtn; const HelpButton: TMsgDlgBtn;\r\n const ADynControlEngine: TJvDynControlEngine): TModalResult;\r\nvar\r\n TmpPic: TGraphic;\r\nbegin\r\n TmpPic := DlgPic(DlgType);\r\n try\r\n Result := MessageDlg(DlgCaption(DlgType), Msg, TmpPic, Buttons, HelpCtx, Center, Timeout, DefaultButton,\r\n CancelButton, HelpButton, ADynControlEngine);\r\n finally\r\n TmpPic.Free;\r\n end;\r\nend;\r\n\r\nfunction MessageDlg(const Caption, Msg: string; const DlgType: TMsgDlgType; const Buttons: TMsgDlgButtons;\r\n const HelpCtx: Longint; const Center: TDlgCenterKind; const Timeout: Integer;\r\n const DefaultButton: TMsgDlgBtn; const CancelButton: TMsgDlgBtn; const HelpButton: TMsgDlgBtn;\r\n const ADynControlEngine: TJvDynControlEngine): TModalResult;\r\nvar\r\n TmpPic: TGraphic;\r\nbegin\r\n TmpPic := DlgPic(DlgType);\r\n try\r\n Result := MessageDlg(Caption, Msg, TmpPic, Buttons, HelpCtx, Center,\r\n Timeout, DefaultButton, CancelButton, HelpButton, ADynControlEngine);\r\n finally\r\n TmpPic.Free;\r\n end;\r\nend;\r\n\r\nfunction MessageDlg(const Caption, Msg: string; const Picture: TGraphic; const Buttons: TMsgDlgButtons;\r\n const HelpCtx: Longint; const Center: TDlgCenterKind; const Timeout: Integer;\r\n const DefaultButton: TMsgDlgBtn; const CancelButton: TMsgDlgBtn; const HelpButton: TMsgDlgBtn;\r\n const ADynControlEngine: TJvDynControlEngine): TModalResult;\r\nvar\r\n DefBtn: TMsgDlgBtn;\r\n CanBtn: TMsgDlgBtn;\r\n BtnResults: TDynIntegerArray;\r\nbegin\r\n if DefaultButton = mbDefault then\r\n begin\r\n if mbOK in Buttons then\r\n DefBtn := mbOK\r\n else\r\n if mbYes in Buttons then\r\n DefBtn := mbYes\r\n else\r\n DefBtn := mbRetry;\r\n end\r\n else\r\n DefBtn := DefaultButton;\r\n if CancelButton = mbDefault then\r\n begin\r\n if mbCancel in Buttons then\r\n CanBtn := mbCancel\r\n else\r\n if mbNo in Buttons then\r\n CanBtn := mbNo\r\n else\r\n CanBtn := mbOK;\r\n end\r\n else\r\n CanBtn := CancelButton;\r\n BtnResults := DlgButtonResults(Buttons);\r\n Result := MessageDlgEx(Caption, Msg, Picture, DlgButtonCaptions(Buttons),\r\n BtnResults, HelpCtx, Center, Timeout, ButtonIndex(BtnResults, DefBtn),\r\n ButtonIndex(BtnResults, CanBtn), ButtonIndex(BtnResults, HelpButton),\r\n ADynControlEngine);\r\nend;\r\n\r\nfunction MessageDlgEx(const Msg: string; const DlgType: TMsgDlgType; const Buttons: array of string;\r\n const Results: array of Integer; const HelpCtx: Longint; const Center: TDlgCenterKind;\r\n const Timeout: Integer; const DefaultButton: Integer; const CancelButton: Integer;\r\n const HelpButton: Integer; const ADynControlEngine: TJvDynControlEngine): TModalResult;\r\nvar\r\n TmpPic: TGraphic;\r\nbegin\r\n TmpPic := DlgPic(DlgType);\r\n try\r\n Result := MessageDlgEx(DlgCaption(DlgType), Msg, TmpPic, Buttons, Results, HelpCtx, Center, Timeout, DefaultButton,\r\n CancelButton, HelpButton, ADynControlEngine);\r\n finally\r\n TmpPic.Free;\r\n end;\r\nend;\r\n\r\nfunction MessageDlgEx(const Caption, Msg: string; const DlgType: TMsgDlgType;\r\n const Buttons: array of string; const Results: array of Integer; const HelpCtx: Longint;\r\n const Center: TDlgCenterKind; const Timeout: Integer; const DefaultButton: Integer;\r\n const CancelButton: Integer; const HelpButton: Integer;\r\n const ADynControlEngine: TJvDynControlEngine): TModalResult;\r\nvar\r\n TmpPic: TGraphic;\r\nbegin\r\n TmpPic := DlgPic(DlgType);\r\n try\r\n Result := MessageDlgEx(Caption, Msg, TmpPic, Buttons, Results, HelpCtx,\r\n Center, Timeout, DefaultButton, CancelButton, HelpButton, ADynControlEngine);\r\n finally\r\n TmpPic.Free;\r\n end;\r\nend;\r\n\r\nfunction MessageDlgEx(const Caption, Msg: string; const Picture: TGraphic;\r\n const Buttons: array of string; const Results: array of Integer; const HelpCtx: Longint;\r\n const Center: TDlgCenterKind; const Timeout: Integer; const DefaultButton: Integer;\r\n const CancelButton: Integer; const HelpButton: Integer;\r\n const ADynControlEngine: TJvDynControlEngine): TModalResult;\r\nbegin\r\n with CreateDSAMessageForm(Caption, Msg, Picture, Buttons, Results, HelpCtx, '',\r\n Center, Timeout, DefaultButton, CancelButton, HelpButton, ADynControlEngine) do\r\n try\r\n Result := ShowModal;\r\n finally\r\n Free;\r\n end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------\r\n// \"Don't Show Again\" (DSA) dialogs\r\n//----------------------------------------------------------------------------\r\n\r\nprocedure DSAShowMessage(const DlgID: Integer; const Msg: string;\r\n const Center: TDlgCenterKind; const Timeout: Integer;\r\n const ADynControlEngine: TJvDynControlEngine);\r\nbegin\r\n DSAMessageDlg(DlgID, Msg, mtCustom, [mbOK], 0, Center, Timeout, mbDefault,\r\n mbDefault, mbHelp, ADynControlEngine);\r\nend;\r\n\r\nprocedure DSAShowMessageFmt(const DlgID: Integer; const Msg: string;\r\n const Params: array of const; const Center: TDlgCenterKind;\r\n const Timeout: Integer; const ADynControlEngine: TJvDynControlEngine);\r\nbegin\r\n DSAMessageDlg(DlgID, Format(Msg, Params), mtCustom, [mbOK], 0, Center, Timeout,\r\n mbDefault, mbDefault, mbHelp, ADynControlEngine);\r\nend;\r\n\r\nfunction DSAMessageDlg(const DlgID: Integer; const Msg: string; const DlgType: TMsgDlgType;\r\n const Buttons: TMsgDlgButtons; const HelpCtx: Longint; const Center: TDlgCenterKind;\r\n const Timeout: Integer; const DefaultButton: TMsgDlgBtn; const CancelButton: TMsgDlgBtn;\r\n const HelpButton: TMsgDlgBtn; const ADynControlEngine: TJvDynControlEngine): TModalResult;\r\nvar\r\n TmpPic: TGraphic;\r\nbegin\r\n TmpPic := DlgPic(DlgType);\r\n try\r\n Result := DSAMessageDlg(DlgID, DlgCaption(DlgType), Msg, TmpPic, Buttons, HelpCtx,\r\n Center, Timeout, DefaultButton, CancelButton, HelpButton, ADynControlEngine);\r\n finally\r\n TmpPic.Free;\r\n end;\r\nend;\r\n\r\nfunction DSAMessageDlg(const DlgID: Integer; const Caption, Msg: string;\r\n const DlgType: TMsgDlgType; const Buttons: TMsgDlgButtons; const HelpCtx: Longint;\r\n const Center: TDlgCenterKind; const Timeout: Integer; const DefaultButton: TMsgDlgBtn;\r\n const CancelButton: TMsgDlgBtn; const HelpButton: TMsgDlgBtn;\r\n const ADynControlEngine: TJvDynControlEngine): TModalResult;\r\nvar\r\n TmpPic: TGraphic;\r\nbegin\r\n TmpPic := DlgPic(DlgType);\r\n try\r\n Result := DSAMessageDlg(DlgID, Caption, Msg, TmpPic, Buttons, HelpCtx, Center,\r\n Timeout, DefaultButton, CancelButton, HelpButton, ADynControlEngine);\r\n finally\r\n TmpPic.Free;\r\n end;\r\nend;\r\n\r\nfunction DSAMessageDlg(const DlgID: Integer; const Caption, Msg: string;\r\n const Picture: TGraphic; const Buttons: TMsgDlgButtons; const HelpCtx: Longint;\r\n const Center: TDlgCenterKind; const Timeout: Integer; const DefaultButton: TMsgDlgBtn;\r\n const CancelButton: TMsgDlgBtn; const HelpButton: TMsgDlgBtn;\r\n const ADynControlEngine: TJvDynControlEngine): TModalResult;\r\nvar\r\n DefBtn: TMsgDlgBtn;\r\n CanBtn: TMsgDlgBtn;\r\n BtnResults: TDynIntegerArray;\r\nbegin\r\n if DefaultButton = mbDefault then\r\n begin\r\n if mbOK in Buttons then\r\n DefBtn := mbOK\r\n else\r\n if mbYes in Buttons then\r\n DefBtn := mbYes\r\n else\r\n DefBtn := mbRetry;\r\n end\r\n else\r\n DefBtn := DefaultButton;\r\n if CancelButton = mbDefault then\r\n begin\r\n if mbCancel in Buttons then\r\n CanBtn := mbCancel\r\n else\r\n if mbNo in Buttons then\r\n CanBtn := mbNo\r\n else\r\n CanBtn := mbOK;\r\n end\r\n else\r\n CanBtn := CancelButton;\r\n BtnResults := DlgButtonResults(Buttons);\r\n Result := DSAMessageDlgEx(DlgID, Caption, Msg, Picture, DlgButtonCaptions(Buttons),\r\n BtnResults, HelpCtx, Center, Timeout, ButtonIndex(BtnResults, DefBtn),\r\n ButtonIndex(BtnResults, CanBtn), ButtonIndex(BtnResults, HelpButton), ADynControlEngine);\r\nend;\r\n\r\nfunction DSAMessageDlgEx(const DlgID: Integer; const Msg: string; const DlgType: TMsgDlgType;\r\n const Buttons: array of string; const Results: array of Integer; const HelpCtx: Longint;\r\n const Center: TDlgCenterKind; const Timeout: Integer; const DefaultButton: Integer;\r\n const CancelButton: Integer; const HelpButton: Integer;\r\n const ADynControlEngine: TJvDynControlEngine): Integer;\r\nvar\r\n TmpPic: TGraphic;\r\nbegin\r\n TmpPic := DlgPic(DlgType);\r\n try\r\n Result := DSAMessageDlgEx(DlgID, DlgCaption(DlgType), Msg, TmpPic, Buttons,\r\n Results, HelpCtx, Center, Timeout, DefaultButton, CancelButton,\r\n HelpButton, ADynControlEngine);\r\n finally\r\n TmpPic.Free;\r\n end;\r\nend;\r\n\r\nfunction DSAMessageDlgEx(const DlgID: Integer; const Caption, Msg: string; const DlgType: TMsgDlgType;\r\n const Buttons: array of string; const Results: array of Integer; const HelpCtx: Longint;\r\n const Center: TDlgCenterKind; const Timeout, DefaultButton, CancelButton, HelpButton: Integer;\r\n const ADynControlEngine: TJvDynControlEngine): TModalResult;\r\nvar\r\n TmpPic: TGraphic;\r\nbegin\r\n TmpPic := DlgPic(DlgType);\r\n try\r\n Result := DSAMessageDlgEx(DlgID, Caption, Msg, TmpPic, Buttons, Results, HelpCtx,\r\n Center, Timeout, DefaultButton, CancelButton, HelpButton, ADynControlEngine);\r\n finally\r\n TmpPic.Free;\r\n end;\r\nend;\r\n\r\nfunction DSAMessageDlgEx(const DlgID: Integer; const Caption, Msg: string; const Picture: TGraphic;\r\n const Buttons: array of string; const Results: array of Integer; const HelpCtx: Longint;\r\n const Center: TDlgCenterKind; const Timeout, DefaultButton, CancelButton, HelpButton: Integer;\r\n const ADynControlEngine: TJvDynControlEngine): Integer;\r\nvar\r\n DSAItem: TDSARegItem;\r\n CheckCaption: string;\r\n Temp: string;\r\nbegin\r\n if not GetDSAState(DlgID, Result) then\r\n begin\r\n Result := High(Integer);\r\n DSAItem := LocateDSAReg(DlgID);\r\n CheckCaption := GetCheckMarkText(DSAItem.ChkTextKind);\r\n if CheckCaption = '' then\r\n CheckCaption := GetCheckMarkText(ctkShow);\r\n Temp := DSAItem.Storage.CheckMarkTextSuffix;\r\n if Temp <> '' then\r\n CheckCaption := CheckCaption + ' ' + Temp + '.'\r\n else\r\n CheckCaption := CheckCaption + '.';\r\n // Create and show dialog\r\n with CreateDSAMessageForm(Caption, Msg, Picture, Buttons, Results, HelpCtx, CheckCaption,\r\n Center, Timeout, DefaultButton, CancelButton, HelpButton, ADynControlEngine) do\r\n try\r\n Result := ShowModal;\r\n if IsDSAChecked then\r\n SetDSAState(DlgID, True, Result);\r\n finally\r\n Free;\r\n end;\r\n end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------\r\n// DSA registration\r\n//----------------------------------------------------------------------------\r\n\r\nprocedure RegisterDSA(const DlgID: Integer; const Name, Description: string;\r\n const Storage: TDSAStorage; const CheckTextKind: TDSACheckTextKind = ctkShow);\r\nbegin\r\n case DSARegister.Add(DlgID, Name, Description, Storage, CheckTextKind) of\r\n arDuplicateID:\r\n raise EJvDSADialog.CreateResFmt(@RsEDSADuplicateID, [DlgID]);\r\n arDuplicateName:\r\n raise EJvDSADialog.CreateResFmt(@RsEDSADuplicateName, [Name]);\r\n end;\r\nend;\r\n\r\nprocedure UnregisterDSA(const DlgID: Integer);\r\nbegin\r\n DSARegister.Delete(DlgID);\r\nend;\r\n\r\nfunction LocateDSAReg(const DlgID: Integer): TDSARegItem;\r\nbegin\r\n Result := DSARegister.Locate(DlgID);\r\nend;\r\n\r\n//----------------------------------------------------------------------------\r\n// DSA state setting/retrieving\r\n//----------------------------------------------------------------------------\r\n\r\nfunction GetDSAState(const DlgID: Integer): Boolean;\r\nvar\r\n Dummy: Integer;\r\nbegin\r\n Result := GetDSAState(DlgID, Dummy);\r\nend;\r\n\r\nfunction GetDSAState(const DlgID: Integer; out ResCode: Integer;\r\n const OnCustomData: TDSACustomData = nil): Boolean;\r\nvar\r\n RegItem: TDSARegItem;\r\nbegin\r\n RegItem := DSARegister.Locate(DlgID);\r\n if RegItem.ID <> EmptyItem.ID then\r\n Result := RegItem.Storage.GetState(RegItem, ResCode, OnCustomData)\r\n else\r\n raise EJvDSADialog.CreateResFmt(@RsEDSADialogIDNotFound, [DlgID]);\r\nend;\r\n\r\nprocedure SetDSAState(const DlgID: Integer; const DontShowAgain: Boolean;\r\n const LastResult: Integer = mrNone; const OnCustomData: TDSACustomData = nil);\r\nvar\r\n RegItem: TDSARegItem;\r\nbegin\r\n RegItem := DSARegister.Locate(DlgID);\r\n if RegItem.ID <> EmptyItem.ID then\r\n RegItem.Storage.SetState(RegItem, DontShowAgain, LastResult, OnCustomData)\r\n else\r\n raise EJvDSADialog.CreateResFmt(@RsEDSADialogIDNotFound, [DlgID]);\r\nend;\r\n\r\n//----------------------------------------------------------------------------\r\n// Iterating the DSA registration\r\n//----------------------------------------------------------------------------\r\n\r\nfunction DSACount: Integer;\r\nbegin\r\n Result := Length(DSARegister.FList);\r\nend;\r\n\r\nfunction DSAItem(const Index: Integer): TDSARegItem;\r\nbegin\r\n Result := DSARegister.FList[Index];\r\nend;\r\n\r\n//----------------------------------------------------------------------------\r\n// DSA check box text registration\r\n//----------------------------------------------------------------------------\r\n\r\nprocedure RegisterDSACheckMarkText(const ID: TDSACheckTextKind; const Text: string);\r\nbegin\r\n if CheckMarkTexts.IndexOfObject(TObject(ID)) < 0 then\r\n CheckMarkTexts.AddObject(Text, TObject(ID))\r\n else\r\n raise EJvDSADialog.CreateResFmt(@RsEDSADuplicateCTK_ID, [ID]);\r\nend;\r\n\r\nprocedure UnregisterDSACheckMarkText(const ID: TDSACheckTextKind);\r\nvar\r\n Idx: Integer;\r\nbegin\r\n Idx := CheckMarkTexts.IndexOfObject(TObject(ID));\r\n if Idx > -1 then\r\n CheckMarkTexts.Delete(Idx);\r\nend;\r\n\r\nfunction GetDSACheckMarkText(const ID: TDSACheckTextKind): string;\r\nbegin\r\n Result := GetCheckMarkText(ID);\r\nend;\r\n\r\n//----------------------------------------------------------------------------\r\n// Standard DSA storage devices\r\n//----------------------------------------------------------------------------\r\n\r\n{$IFDEF MSWINDOWS}\r\n\r\nvar\r\n GlobalRegStore: TDSAStorage = nil;\r\n\r\nfunction DSARegStore: TDSARegStorage;\r\nbegin\r\n if GlobalRegStore = nil then\r\n begin\r\n GlobalRegStore :=\r\n TDSARegStorage.Create(HKEY_CURRENT_USER, 'Software\\' + Application.Title + '\\DSA');\r\n end;\r\n Result := TDSARegStorage(GlobalRegStore);\r\nend;\r\n\r\n{$ENDIF MSWINDOWS}\r\n\r\nvar\r\n GlobalQueueStore: TDSAStorage = nil;\r\n\r\nfunction DSAQueueStore: TDSAQueueStorage;\r\nbegin\r\n if GlobalQueueStore = nil then\r\n GlobalQueueStore := TDSAQueueStorage.Create;\r\n Result := TDSAQueueStorage(GlobalQueueStore);\r\nend;\r\n\r\n{ ShowModal patch }\r\n\r\nfunction GetShowModalVMTOffset: Integer;\r\nasm\r\n MOV EAX, VMTOFFSET TCustomForm.ShowModal\r\nend;\r\n\r\nfunction GetShowModalVMTIndex: Integer; // Locate the VMT index of ShowModal\r\nbegin\r\n Result := GetShowModalVMTOffset div SizeOf(Pointer);\r\nend;\r\n\r\n//=== { TPatchedForm } =======================================================\r\n\r\ntype\r\n TShowModalMethod = function: Integer of object; // So we can call the original ShowModal method.\r\n\r\n TPatchedForm = class(TCustomForm) // To replace the orignal ShowModal method.\r\n public\r\n function ShowModal: Integer; override;\r\n end;\r\n\r\nfunction TPatchedForm.ShowModal: Integer;\r\nvar\r\n I: Integer;\r\n JvDSADialog: TJvDSADialog;\r\n DSAItem: TDSARegItem;\r\n CheckCaption: string;\r\n Temp: string;\r\n ShowModalMethod: TShowModalMethod;\r\nbegin\r\n // retrieve the TJvDSADialog instance.\r\n I := ComponentCount - 1;\r\n while (I > -1) and not (Components[I] is TJvDSADialog) do\r\n Dec(I);\r\n if I = -1 then\r\n raise EJvDSADialog.CreateRes(@RsEJvDSADialogPatchErrorJvDSADialogCom);\r\n JvDSADialog := Components[I] as TJvDSADialog;\r\n\r\n // Check the DSA state\r\n if not JvDSADialog.GetDSAStateInternal(Result) then\r\n begin\r\n if (JvDSADialog.CheckControl <> nil) and not JvDSADialog.IgnoreDSAChkMrkTxt then\r\n begin\r\n // Get DSA checkmark caption\r\n DSAItem := LocateDSAReg(JvDSADialog.DialogID);\r\n CheckCaption := GetDSACheckMarkText(DSAItem.ChkTextKind);\r\n if CheckCaption = '' then\r\n CheckCaption := GetDSACheckMarkText(ctkShow);\r\n Temp := DSAItem.Storage.CheckMarkTextSuffix;\r\n if Temp <> '' then\r\n CheckCaption := CheckCaption + ' ' + Temp + '.'\r\n else\r\n CheckCaption := CheckCaption + '.';\r\n SetStrProp(JvDSADialog.CheckControl, 'Caption', CheckCaption);\r\n end;\r\n\r\n { Notify the JvDSADialog component that we are about to show the form (may initialize the\r\n auto-close timer) }\r\n JvDSADialog.BeforeShow;\r\n // Show the dialog by calling the original ShowModal method: setting up the method pointers.\r\n TMethod(ShowModalMethod).Data := Self;\r\n TMethod(ShowModalMethod).Code := JvDSADialog.GetOrgShowModalPtr;\r\n // Show the dialog by calling the original ShowModal method: make the actual call.\r\n Result := ShowModalMethod;\r\n { Notify the JvDSADialog component that we the form has closed (may clean up the\r\n auto-close timer) }\r\n JvDSADialog.AfterShow;\r\n // Update the DSA state in storage.\r\n JvDSADialog.UpdateDSAState;\r\n end\r\n else\r\n // The dialog is suppressed. Apply the saved state.\r\n JvDSADialog.ApplySavedState;\r\nend;\r\n\r\n//=== { TJvDSADialog } =======================================================\r\n\r\nconstructor TJvDSADialog.Create(AOwner: TComponent);\r\nvar\r\n I: Integer;\r\nbegin\r\n if AOwner is TCustomForm then\r\n begin\r\n I := AOwner.ComponentCount - 1;\r\n while (I > -1) and not (AOwner.Components[I] is TJvDSADialog) do\r\n Dec(I);\r\n if I > -1 then\r\n raise EJvDSADialog.CreateRes(@RsEAlreadyDSADialog);\r\n inherited Create(AOwner);\r\n end\r\n else\r\n raise EJvDSADialog.CreateRes(@RsEOnlyAllowedOnForms);\r\nend;\r\n\r\ndestructor TJvDSADialog.Destroy;\r\nbegin\r\n FormUnPatch;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvDSADialog.AutoClose;\r\nbegin\r\n CancelCountdown;\r\n if not DoAutoClose then\r\n (Owner as TCustomForm).Close;\r\nend;\r\n\r\nprocedure TJvDSADialog.AfterShow;\r\nbegin\r\n if FTimer <> nil then\r\n FreeAndNil(FTimer);\r\nend;\r\n\r\nprocedure TJvDSADialog.ApplySavedState;\r\nvar\r\n ResCode: Integer;\r\nbegin\r\n GetDSAState(DialogID, ResCode, DoApplyKeys);\r\n TCustomForm(Owner).ModalResult := ResCode;\r\nend;\r\n\r\nprocedure TJvDSADialog.BeforeShow;\r\nbegin\r\n if FTimeout > 0 then\r\n begin\r\n FTimer := TTimer.Create(Self);\r\n FTimer.Enabled := False;\r\n FTimer.Interval := 1000;\r\n FTimer.OnTimer := TimerEvent;\r\n FTimerCount := FTimeout;\r\n end;\r\nend;\r\n\r\nprocedure TJvDSADialog.DoApplyKeys(const Storage: TDSAStorage; const DSAInfo: TDSARegItem);\r\nbegin\r\n if Assigned(FOnApplyKeys) then\r\n OnApplyKeys(Self, DSAInfo, Storage);\r\nend;\r\n\r\nfunction TJvDSADialog.DoAutoClose: Boolean;\r\nbegin\r\n Result := False;\r\n if Assigned(FOnAutoClose) then\r\n FOnAutoClose(Self, Result);\r\nend;\r\n\r\nprocedure TJvDSADialog.DoCountDown;\r\nbegin\r\n if Assigned(FOnCountdown) then\r\n OnCountdown(Self);\r\nend;\r\n\r\nprocedure TJvDSADialog.DoUpdateKeys;\r\nbegin\r\n if Assigned(FOnUpdateKeys) then\r\n OnUpdateKeys(Self, DSAInfo, Storage);\r\nend;\r\n\r\nfunction TJvDSADialog.GetDSAStateInternal(out ModalResult: Integer): Boolean;\r\nbegin\r\n Result := GetDSAState(DialogID, ModalResult);\r\nend;\r\n\r\nfunction TJvDSADialog.GetOrgOwner: TComponent;\r\nbegin\r\n Result := FOrgOwner;\r\nend;\r\n\r\nfunction TJvDSADialog.GetOrgShowModalPtr: Pointer;\r\nbegin\r\n Result := FOrgShowModalPtr;\r\nend;\r\n\r\nfunction TJvDSADialog.GetStorage: TDSAStorage;\r\nbegin\r\n Result := LocateDSAReg(DialogID).Storage;\r\nend;\r\n\r\nprocedure TJvDSADialog.FormPatch;\r\nvar\r\n VMTIdx: Integer;\r\nbegin\r\n VMTIdx := GetShowModalVMTIndex;\r\n SetOrgShowModalPtr(GetVirtualMethod(Owner.ClassType, VMTIdx));\r\n SetOrgOwner(Owner);\r\n SetVirtualMethod(Owner.ClassType, VMTIdx, @TPatchedForm.ShowModal);\r\nend;\r\n\r\nprocedure TJvDSADialog.FormUnPatch;\r\nvar\r\n VMTIdx: Integer;\r\nbegin\r\n if GetOrgShowModalPtr <> nil then\r\n begin\r\n VMTIdx := GetShowModalVMTIndex;\r\n SetVirtualMethod(GetOrgOwner.ClassType, VMTIdx, GetOrgShowModalPtr);\r\n SetOrgShowModalPtr(nil);\r\n end;\r\nend;\r\n\r\nprocedure TJvDSADialog.Notification(AComponent: TComponent; Operation: TOperation);\r\nbegin\r\n inherited Notification(AComponent, Operation);\r\n if (Operation = opRemove) and (AComponent = CheckControl) then\r\n CheckControl := nil;\r\nend;\r\n\r\nprocedure TJvDSADialog.SetCheckControl(Value: TWinControl);\r\nbegin\r\n if ReplaceComponentReference(Self, Value, TComponent(FCheckControl)) then\r\n if Value <> nil then\r\n begin\r\n if GetPropInfo(Value, 'Checked') = nil then\r\n raise EJvDSADialog.CreateRes(@RsECtrlHasNoCheckedProp);\r\n if GetPropInfo(Value, 'Caption') = nil then\r\n raise EJvDSADialog.CreateRes(@RsECtrlHasNoCaptionProp);\r\n end;\r\nend;\r\n\r\nprocedure TJvDSADialog.SetDialogID(Value: Integer);\r\nbegin\r\n if Value <> DialogID then\r\n begin\r\n if not (csDesigning in ComponentState) and not (csLoading in Owner.ComponentState) then\r\n raise EJvDSADialog.CreateRes(@RsEDialogIDChangeOnlyInDesign);\r\n FDialogID := Value;\r\n end;\r\nend;\r\n\r\nprocedure TJvDSADialog.SetOrgOwner(Value: TComponent);\r\nbegin\r\n FOrgOwner := Value;\r\nend;\r\n\r\nprocedure TJvDSADialog.SetOrgShowModalPtr(Value: Pointer);\r\nbegin\r\n FOrgShowModalPtr := Value;\r\nend;\r\n\r\nprocedure TJvDSADialog.TimerEvent(Sender: TObject);\r\nbegin\r\n Dec(FTimerCount);\r\n if FTimerCount = 0 then\r\n AutoClose\r\n else\r\n DoCountDown;\r\nend;\r\n\r\nprocedure TJvDSADialog.UpdateDSAState;\r\nbegin\r\n SetDSAState(DialogID, IsDSAChecked, TCustomForm(Owner).ModalResult, DoUpdateKeys);\r\nend;\r\n\r\nfunction TJvDSADialog.GetModalResult: Integer;\r\nbegin\r\n Result := TCustomForm(Owner).ModalResult;\r\nend;\r\n\r\nfunction TJvDSADialog.IsDSAChecked: Boolean;\r\nbegin\r\n if CheckControl <> nil then\r\n Result := GetOrdProp(CheckControl, 'Checked') <> 0\r\n else\r\n Result := False;\r\nend;\r\n\r\nprocedure TJvDSADialog.Loaded;\r\nbegin\r\n inherited Loaded;\r\n if not (csDesigning in ComponentState) then\r\n FormPatch;\r\nend;\r\n\r\nprocedure TJvDSADialog.CancelCountdown;\r\nbegin\r\n if FTimer <> nil then\r\n begin\r\n FTimer.Enabled := False;\r\n FreeAndNil(FTimer);\r\n end;\r\nend;\r\n\r\nfunction TJvDSADialog.SecondsLeft: Integer;\r\nbegin\r\n if Timeout <> 0 then\r\n Result := FTimerCount\r\n else\r\n Result := 0;\r\nend;\r\n\r\nconstructor TDSAAppStorage.Create(AAppStorage : TJvCustomAppStorage; const APath : string);\r\nbegin\r\n inherited Create;\r\n FAppStorage := AAppStorage;\r\n FAppStoragePath := APath;\r\nend;\r\n\r\nfunction TDSAAppStorage.GetCheckMarkTextSuffix: string;\r\nbegin\r\n Result := '';\r\nend;\r\n\r\nprocedure TDSAAppStorage.SetCheckMarkTextSuffix(const Value: string);\r\nbegin\r\nend;\r\n\r\nfunction TDSAAppStorage.ReadBool(const DSAInfo: TDSARegItem; const Key: string): Boolean;\r\nbegin\r\n Result := FAppStorage.ReadBoolean(Format(sPathStr, [FAppStoragePath, DSAInfo.Name, Key]));\r\nend;\r\n\r\nfunction TDSAAppStorage.ReadBoolDef(const DSAInfo: TDSARegItem; const Key: string;\r\n const Default: Boolean): Boolean;\r\nbegin\r\n Result := FAppStorage.ReadBoolean(Format(sPathStr, [FAppStoragePath, DSAInfo.Name, Key]), Default);\r\nend;\r\n\r\nfunction TDSAAppStorage.ReadFloat(const DSAInfo: TDSARegItem; const Key: string): Extended;\r\nbegin\r\n Result := FAppStorage.ReadFloat(Format(sPathStr, [FAppStoragePath, DSAInfo.Name, Key]));\r\nend;\r\n\r\nfunction TDSAAppStorage.ReadFloatDef(const DSAInfo: TDSARegItem; const Key: string;\r\n const Default: Extended): Extended;\r\nbegin\r\n Result := FAppStorage.ReadFloat(Format(sPathStr, [FAppStoragePath, DSAInfo.Name, Key]), Default);\r\nend;\r\n\r\nfunction TDSAAppStorage.ReadInt64(const DSAInfo: TDSARegItem; const Key: string): Int64;\r\nbegin\r\n Result := FAppStorage.ReadInteger(Format(sPathStr, [FAppStoragePath, DSAInfo.Name, Key]));\r\nend;\r\n\r\nfunction TDSAAppStorage.ReadInt64Def(const DSAInfo: TDSARegItem; const Key: string; const Default: Int64): Int64;\r\nbegin\r\n Result := FAppStorage.ReadInteger(Format(sPathStr, [FAppStoragePath, DSAInfo.Name, Key]), Default);\r\nend;\r\n\r\nfunction TDSAAppStorage.ReadInteger(const DSAInfo: TDSARegItem; const Key: string): Integer;\r\nbegin\r\n Result := FAppStorage.ReadInteger(Format(sPathStr, [FAppStoragePath, DSAInfo.Name, Key]));\r\nend;\r\n\r\nfunction TDSAAppStorage.ReadIntegerDef(const DSAInfo: TDSARegItem; const Key: string;\r\n const Default: Integer): Integer;\r\nbegin\r\n Result := FAppStorage.ReadInteger(Format(sPathStr, [FAppStoragePath, DSAInfo.Name, Key]), Default);\r\nend;\r\n\r\nfunction TDSAAppStorage.ReadString(const DSAInfo: TDSARegItem; const Key: string): string;\r\nbegin\r\n Result := FAppStorage.ReadString(Format(sPathStr, [FAppStoragePath, DSAInfo.Name, Key]));\r\nend;\r\n\r\nfunction TDSAAppStorage.ReadStringDef(const DSAInfo: TDSARegItem; const Key: string;\r\n const Default: string): string;\r\nbegin\r\n Result := FAppStorage.ReadString(Format(sPathStr, [FAppStoragePath, DSAInfo.Name, Key]), Default);\r\nend;\r\n\r\nprocedure TDSAAppStorage.WriteBool(const DSAInfo: TDSARegItem; const Key: string;\r\n const Value: Boolean);\r\nbegin\r\n FAppStorage.WriteBoolean(Format(sPathStr, [FAppStoragePath, DSAInfo.Name, Key]), Value);\r\nend;\r\n\r\nprocedure TDSAAppStorage.WriteFloat(const DSAInfo: TDSARegItem; const Key: string;\r\n const Value: Extended);\r\nbegin\r\n FAppStorage.WriteFloat(Format(sPathStr, [FAppStoragePath, DSAInfo.Name, Key]), Value);\r\nend;\r\n\r\nprocedure TDSAAppStorage.WriteInt64(const DSAInfo: TDSARegItem; const Key: string;\r\n const Value: Int64);\r\nbegin\r\n FAppStorage.WriteInteger(Format(sPathStr, [FAppStoragePath, DSAInfo.Name, Key]), Value);\r\nend;\r\n\r\nprocedure TDSAAppStorage.WriteInteger(const DSAInfo: TDSARegItem; const Key: string;\r\n const Value: Integer);\r\nbegin\r\n FAppStorage.WriteInteger(Format(sPathStr, [FAppStoragePath, DSAInfo.Name, Key]), Value);\r\nend;\r\n\r\nprocedure TDSAAppStorage.WriteString(const DSAInfo: TDSARegItem; const Key: string;\r\n const Value: string);\r\nbegin\r\n FAppStorage.WriteString(Format(sPathStr, [FAppStoragePath, DSAInfo.Name, Key]), Value);\r\nend;\r\n\r\ninitialization\r\n {$IFDEF UNITVERSIONING}\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n {$ENDIF UNITVERSIONING}\r\n\r\nfinalization\r\n FreeAndNil(GlobalCheckMarkTexts);\r\n FreeAndNil(GlobalDSARegister);\r\n FreeAndNil(GlobalQueueStore);\r\n {$IFDEF MSWINDOWS}\r\n FreeAndNil(GlobalRegStore);\r\n {$ENDIF MSWINDOWS}\r\n {$IFDEF UNITVERSIONING}\r\n UnregisterUnitVersion(HInstance);\r\n {$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvDataEmbedded.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvDataEmbedded.PAS, released on 2001-02-28.\r\n\r\nThe Initial Developer of the Original Code is Sbastien Buysse [sbuysse att buypin dott com]\r\nPortions created by Sbastien Buysse are Copyright (C) 2001 Sbastien Buysse ,dejoy.\r\nAll Rights Reserved.\r\n\r\nContributor(s): Michael Beck [mbeck att bigfoot dott com].\r\n\r\n Added TJvComponentEmbedded and TJvPersistentEmbedded from dejoy 2004-07-30:\r\n Override DefineUnpublishedProperties to define property in DefineUnpublishedProperties,\r\n\r\n If you want to define a general property, use DoDefineProperty,\r\n If you want to define a binary property, use DoDefineBinaryProperty.\r\n Override ReadUnpublished and WriteUnpublished to read or write non-published properties.\r\n You can use DefinePropertyIs in ReadUnpublished or WriteUnpublished to detect which\r\n property is being processed.\r\n\r\n If you have many unpublished properties to process, you don't need to write a lot of\r\n WriteXXX or ReadXXX procedures to process them. Instead, just override\r\n DefineUnpublishedProperties, ReadUnpublished and WriteUnpublished\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvDataEmbedded.pas 13104 2011-09-07 06:50:43Z obones $\r\n\r\nunit JvDataEmbedded;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF MSWINDOWS}\r\n Windows, // inline\r\n {$ENDIF MSWINDOWS}\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n SysUtils, Classes,\r\n JVCLVer, JvTypes;\r\n\r\ntype\r\n TJvPersistentEmbedded = class(TInterfacedPersistent)\r\n private\r\n FFiler: TFiler;\r\n FFilerTag: string;\r\n protected\r\n procedure DefineProperties(Filer: TFiler); override;\r\n procedure DefineUnpublishedProperties(Filer: TFiler); virtual;\r\n function DefinePropertyIs(const Name: string): Boolean; dynamic;\r\n procedure DoDefineProperty(const Name: string; HasData: Boolean); dynamic;\r\n procedure DoDefineBinaryProperty(const Name: string; HasData: Boolean); dynamic;\r\n procedure ReadUnpublished(Reader: TReader); overload; dynamic;\r\n procedure WriteUnpublished(Writer: TWriter); overload; dynamic;\r\n procedure ReadUnpublishedStream(Stream: TStream); overload; dynamic;\r\n procedure WriteUnpublishedStream(Stream: TStream); overload; dynamic;\r\n public\r\n procedure SaveToStream(Stream: TStream); virtual;\r\n procedure LoadFromStream(Stream: TStream); virtual;\r\n end;\r\n\r\n TJvComponentEmbedded = class(TComponent)\r\n private\r\n FFiler: TFiler;\r\n FFilerTag: string;\r\n protected\r\n procedure DefineProperties(Filer: TFiler); override;\r\n procedure DefineUnpublishedProperties(Filer: TFiler); virtual;\r\n function DefinePropertyIs(const Name: string): Boolean; dynamic;\r\n procedure DoDefineProperty(const Name: string; HasData: Boolean); dynamic;\r\n procedure DoDefineBinaryProperty(const Name: string; HasData: Boolean); dynamic;\r\n procedure ReadUnpublished(Reader: TReader); overload; dynamic;\r\n procedure WriteUnpublished(Writer: TWriter); overload; dynamic;\r\n procedure ReadUnpublishedStream(Stream: TStream); overload; dynamic;\r\n procedure WriteUnpublishedStream(Stream: TStream); overload; dynamic;\r\n public\r\n procedure SaveToStream(Stream: TStream); virtual;\r\n procedure LoadFromStream(Stream: TStream); virtual;\r\n end;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64 or pidOSX32)]\r\n {$ENDIF RTL230_UP}\r\n TJvDataEmbedded = class(TJvComponentEmbedded)\r\n private\r\n FAboutJVCL: TJVCLAboutInfo; // (ahuser) removed JvComponent dependency for easy CLX usage\r\n FStream: TMemoryStream;\r\n FOnLoading: TNotifyEvent;\r\n FOnSaved: TNotifyEvent;\r\n FOnLoaded: TNotifyEvent;\r\n FOnSaving: TNotifyEvent;\r\n FOnChange: TNotifyEvent;\r\n function GetSize: Integer;\r\n function GetStream: TStream;\r\n procedure SetStream(const Value: TStream);\r\n procedure SetSize(const Value: Integer);\r\n protected\r\n procedure DefineUnpublishedProperties(Filer: TFiler); override;\r\n procedure ReadUnpublishedStream(Stream: TStream); override;\r\n procedure WriteUnpublishedStream(Stream: TStream); override;\r\n procedure DoLoading; virtual;\r\n procedure DoLoaded; virtual;\r\n procedure DoSaving; virtual;\r\n procedure DoSaved; virtual;\r\n procedure Change; virtual;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n procedure DataLoadFromFile(const FileName: TFileName);\r\n procedure DataLoadFromStream(Stream: TStream);\r\n procedure DataSaveToFile(const FileName: TFileName);\r\n procedure DataSaveToStream(Stream: TStream);\r\n property Size: Integer read GetSize write SetSize;\r\n property Data: TStream read GetStream write SetStream;\r\n published\r\n property AboutJVCL: TJVCLAboutInfo read FAboutJVCL write FAboutJVCL stored False;\r\n property OnLoading: TNotifyEvent read FOnLoading write FOnLoading;\r\n property OnLoaded: TNotifyEvent read FOnLoaded write FOnLoaded;\r\n property OnSaving: TNotifyEvent read FOnSaving write FOnSaving;\r\n property OnSaved: TNotifyEvent read FOnSaved write FOnSaved;\r\n property OnChange: TNotifyEvent read FOnChange write FOnChange;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvDataEmbedded.pas $';\r\n Revision: '$Revision: 13104 $';\r\n Date: '$Date: 2011-09-07 08:50:43 +0200 (mer. 07 sept. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\n\r\nconst\r\n cEmbeddedData = 'EmbeddedData';\r\n\r\n//=== { TJvDataEmbedded } ====================================================\r\n\r\nconstructor TJvDataEmbedded.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FStream := TMemoryStream.Create;\r\nend;\r\n\r\ndestructor TJvDataEmbedded.Destroy;\r\nbegin\r\n FStream.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJvDataEmbedded.GetSize: Integer;\r\nbegin\r\n Result := FStream.Size;\r\nend;\r\n\r\nfunction TJvDataEmbedded.GetStream: TStream;\r\nbegin\r\n Result := FStream;\r\n Result.Position := 0;\r\nend;\r\n\r\nprocedure TJvDataEmbedded.SetStream(const Value: TStream);\r\nbegin\r\n FStream.Clear;\r\n if Value <> nil then\r\n FStream.CopyFrom(Value, Value.Size - Value.Position);\r\n Change;\r\nend;\r\n\r\nprocedure TJvDataEmbedded.DataSaveToFile(const FileName: TFileName);\r\nbegin\r\n DoSaving;\r\n FStream.SaveToFile(FileName);\r\n DoSaved;\r\nend;\r\n\r\nprocedure TJvDataEmbedded.DataSaveToStream(Stream: TStream);\r\nbegin\r\n DoSaving;\r\n Stream.CopyFrom(FStream, 0);\r\n DoSaved;\r\nend;\r\n\r\nprocedure TJvDataEmbedded.SetSize(const Value: Integer);\r\nbegin\r\n FStream.SetSize(Value);\r\n Change;\r\nend;\r\n\r\nprocedure TJvDataEmbedded.DefineUnpublishedProperties(Filer: TFiler);\r\nbegin\r\n inherited DefineUnpublishedProperties(Filer);\r\n DoDefineBinaryProperty(cEmbeddedData, FStream.Size > 0);\r\nend;\r\n\r\nprocedure TJvDataEmbedded.ReadUnpublishedStream(Stream: TStream);\r\nvar\r\n I: Integer;\r\nbegin\r\n if DefinePropertyIs(cEmbeddedData) then\r\n begin\r\n Stream.Read(I, SizeOf(I));\r\n FStream.Clear;\r\n FStream.Size := I;\r\n Stream.Read(FStream.Memory^, I);\r\n end;\r\nend;\r\n\r\nprocedure TJvDataEmbedded.WriteUnpublishedStream(Stream: TStream);\r\nvar\r\n I: Integer;\r\nbegin\r\n if DefinePropertyIs(cEmbeddedData) then\r\n begin\r\n I := FStream.Size;\r\n Stream.Write(I, SizeOf(I));\r\n Stream.Write(FStream.Memory^, I);\r\n end;\r\nend;\r\n\r\nprocedure TJvDataEmbedded.DataLoadFromFile(const FileName: TFileName);\r\nbegin\r\n DoLoading;\r\n FStream.LoadFromFile(FileName);\r\n DoLoaded;\r\nend;\r\n\r\nprocedure TJvDataEmbedded.DataLoadFromStream(Stream: TStream);\r\nbegin\r\n DoLoading;\r\n FStream.CopyFrom(Stream, 0);\r\n DoLoaded;\r\nend;\r\n\r\nprocedure TJvDataEmbedded.DoLoaded;\r\nbegin\r\n if Assigned(FOnLoaded) then\r\n FOnLoaded(Self);\r\n Change;\r\nend;\r\n\r\nprocedure TJvDataEmbedded.DoLoading;\r\nbegin\r\n if Assigned(FOnLoading) then\r\n FOnLoading(Self);\r\nend;\r\n\r\nprocedure TJvDataEmbedded.DoSaved;\r\nbegin\r\n if Assigned(FOnSaved) then\r\n FOnSaved(Self);\r\nend;\r\n\r\nprocedure TJvDataEmbedded.DoSaving;\r\nbegin\r\n if Assigned(FOnSaving) then\r\n FOnSaving(Self);\r\nend;\r\n\r\nprocedure TJvDataEmbedded.Change;\r\nbegin\r\n if Assigned(FOnChange) then\r\n FOnChange(Self);\r\nend;\r\n\r\n//=== { TJvComponentEmbedded } ===============================================\r\n\r\nprocedure TJvComponentEmbedded.DefineProperties(Filer: TFiler);\r\nbegin\r\n FFiler := Filer;\r\n inherited DefineProperties(Filer);\r\n DefineUnpublishedProperties(Filer);\r\nend;\r\n\r\nfunction TJvComponentEmbedded.DefinePropertyIs(const Name: string): Boolean;\r\nbegin\r\n Result := AnsiSameText(FFilerTag, Name);\r\nend;\r\n\r\nprocedure TJvComponentEmbedded.DefineUnpublishedProperties(Filer: TFiler);\r\nbegin\r\nend;\r\n\r\nprocedure TJvComponentEmbedded.DoDefineBinaryProperty(const Name: string; HasData: Boolean);\r\nbegin\r\n FFilerTag := Name;\r\n if Assigned(FFiler) and (Name <> '') then\r\n FFiler.DefineBinaryProperty(Name, ReadUnpublishedStream, WriteUnpublishedStream, HasData);\r\nend;\r\n\r\nprocedure TJvComponentEmbedded.DoDefineProperty(const Name: string; HasData: Boolean);\r\nbegin\r\n FFilerTag := Name;\r\n if Assigned(FFiler) and (Name <> '') then\r\n FFiler.DefineProperty(Name, ReadUnpublished, WriteUnpublished, HasData);\r\nend;\r\n\r\nprocedure TJvComponentEmbedded.ReadUnpublished(Reader: TReader);\r\nbegin\r\nend;\r\n\r\nprocedure TJvComponentEmbedded.LoadFromStream(Stream: TStream);\r\nbegin\r\n if (Stream <> nil) and (Stream.Size > 0) then\r\n Stream.ReadComponent(Self);\r\nend;\r\n\r\nprocedure TJvComponentEmbedded.ReadUnpublishedStream(Stream: TStream);\r\nbegin\r\nend;\r\n\r\nprocedure TJvComponentEmbedded.WriteUnpublished(Writer: TWriter);\r\nbegin\r\nend;\r\n\r\nprocedure TJvComponentEmbedded.SaveToStream(Stream: TStream);\r\nbegin\r\n Stream.WriteComponent(Self);\r\nend;\r\n\r\nprocedure TJvComponentEmbedded.WriteUnpublishedStream(Stream: TStream);\r\nbegin\r\nend;\r\n\r\n//=== { TJvPersistentEmbedded } ==============================================\r\n\r\ntype\r\n TPersistentWrapper = class(TComponent)\r\n private\r\n FPersistent: TPersistent;\r\n published\r\n property Persistent: TPersistent read FPersistent write FPersistent;\r\n end;\r\n\r\nprocedure TJvPersistentEmbedded.DefineProperties(Filer: TFiler);\r\nbegin\r\n FFiler := Filer;\r\n inherited DefineProperties(Filer);\r\n DefineUnpublishedProperties(Filer);\r\nend;\r\n\r\nfunction TJvPersistentEmbedded.DefinePropertyIs(const Name: string): Boolean;\r\nbegin\r\n Result := AnsiSameText(FFilerTag, Name);\r\nend;\r\n\r\nprocedure TJvPersistentEmbedded.DefineUnpublishedProperties(Filer: TFiler);\r\nbegin\r\nend;\r\n\r\nprocedure TJvPersistentEmbedded.DoDefineBinaryProperty(const Name: string; HasData: Boolean);\r\nbegin\r\n FFilerTag := Name;\r\n if Assigned(FFiler) and (Name <> '') then\r\n FFiler.DefineBinaryProperty(Name, ReadUnpublishedStream, WriteUnpublishedStream, HasData);\r\nend;\r\n\r\nprocedure TJvPersistentEmbedded.DoDefineProperty(const Name: string; HasData: Boolean);\r\nbegin\r\n FFilerTag := Name;\r\n if Assigned(FFiler) and (Name <> '') then\r\n FFiler.DefineProperty(Name, ReadUnpublished, WriteUnpublished, HasData);\r\nend;\r\n\r\nprocedure TJvPersistentEmbedded.LoadFromStream(Stream: TStream);\r\nvar\r\n M: TPersistentWrapper;\r\nbegin\r\n if (Stream <> nil) and (Stream.Size > 0) then\r\n begin\r\n M := TPersistentWrapper.Create(nil);\r\n try\r\n M.Persistent := Self;\r\n Stream.ReadComponent(M);\r\n M.Persistent := nil;\r\n finally\r\n M.Free;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvPersistentEmbedded.ReadUnpublishedStream(Stream: TStream);\r\nbegin\r\nend;\r\n\r\nprocedure TJvPersistentEmbedded.ReadUnpublished(Reader: TReader);\r\nbegin\r\nend;\r\n\r\nprocedure TJvPersistentEmbedded.SaveToStream(Stream: TStream);\r\nvar\r\n M: TPersistentWrapper;\r\nbegin\r\n M := TPersistentWrapper.Create(nil);\r\n try\r\n M.Persistent := Self;\r\n Stream.WriteComponent(M);\r\n finally\r\n M.Free;\r\n end;\r\nend;\r\n\r\nprocedure TJvPersistentEmbedded.WriteUnpublished(Writer: TWriter);\r\nbegin\r\nend;\r\n\r\nprocedure TJvPersistentEmbedded.WriteUnpublishedStream(Stream: TStream);\r\nbegin\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n\r\n\r\n" }, { "path": "External/Jedi/Jvcl/run/JvDataProvider.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvDataProviderImpl.pas, released on --.\r\n\r\nThe Initial Developer of the Original Code is Marcel Bestebroer\r\nPortions created by Marcel Bestebroer are Copyright (C) 2002 - 2003 Marcel Bestebroer\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\n Remko Bonte\r\n Peter Thrnqvist\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvDataProvider.pas 13415 2012-09-10 09:51:54Z obones $\r\n\r\nunit JvDataProvider;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows,\r\n {$IFDEF HAS_UNIT_LIBC}\r\n Libc,\r\n {$ENDIF HAS_UNIT_LIBC}\r\n Classes, Contnrs, Graphics, Controls, ImgList,\r\n JclBase,\r\n JvComponentBase, JvDataProviderIntf;\r\n\r\n{$IFDEF COMPILER15_UP}\r\n // C++Builder XE now overloads GetInterface() with a generic version. But the Delphi compiler\r\n // only emits the old version if you use \"const GUID: TGUID\" as a parameter. This causes the\r\n // GetInterface() reintroduction, that this unit makes in TExtensibleInterfacedPersistent, to\r\n // generate compile errors in the C++ code.\r\n // With the new \"HPPEMIT END\" we can work around this by disabling the new\r\n // MANAGED_INTERFACE_OPERATORS define for this HPP file.\r\n\r\n {$HPPEMIT '#ifdef MANAGED_INTERFACE_OPERATORS'}\r\n {$HPPEMIT ' #undef MANAGED_INTERFACE_OPERATORS'}\r\n {$HPPEMIT ' #define JvDataProviderHpp_MANAGED_INTERFACE_OPERATORS'}\r\n {$HPPEMIT '#endif'}\r\n\r\n {$HPPEMIT END '#ifdef JvDataProvider_MANAGED_INTERFACE_OPERATORS'}\r\n {$HPPEMIT END ' #define MANAGED_INTERFACE_OPERATORS'}\r\n {$HPPEMIT END ' #undef JvDataProviderHpp_MANAGED_INTERFACE_OPERATORS'}\r\n {$HPPEMIT END '#endif'}\r\n{$ENDIF COMPILER15_UP}\r\n\r\ntype\r\n // Forwards\r\n TExtensibleInterfacedPersistent = class;\r\n TAggregatedPersistentEx = class;\r\n TJvBaseDataItem = class;\r\n TJvBaseDataItems = class;\r\n TJvBaseDataContexts = class;\r\n TJvBaseDataContextsManager = class;\r\n TJvBaseDataContext = class;\r\n TJvDataConsumer = class;\r\n TJvDataConsumerAggregatedObject = class;\r\n TJvDataConsumerServerNotify = class;\r\n TJvDataConsumerClientNotifyList = class;\r\n TJvDataConsumerClientNotifyItem = class;\r\n\r\n // Class references\r\n TAggregatedPersistentExClass = class of TAggregatedPersistentEx;\r\n TJvDataItemTextImplClass = class of TJvBaseDataItemTextImpl;\r\n TJvBaseDataItemClass = class of TJvBaseDataItem;\r\n TJvDataItemsClass = class of TJvBaseDataItems;\r\n TJvDataContextsClass = class of TJvBaseDataContexts;\r\n TJvDataContextsManagerClass = class of TJvBaseDataContextsManager;\r\n TJvDataContextClass = class of TJvBaseDataContext;\r\n TJvDataConsumerAggregatedObjectClass = class of TJvDataConsumerAggregatedObject;\r\n\r\n // Various types\r\n TProviderNotifyEvent = procedure(ADataProvider: IJvDataProvider;\r\n AReason: TDataProviderChangeReason; Source: IUnknown) of object;\r\n TJvDataProviderTree = type Integer;\r\n TJvDataProviderItemID = type string;\r\n TJvDataProviderContexts = type Integer;\r\n TBeforeCreateSubSvcEvent = procedure(Sender: TJvDataConsumer;\r\n var SubSvcClass: TJvDataConsumerAggregatedObjectClass) of object;\r\n TAfterCreateSubSvcEvent = procedure(Sender: TJvDataConsumer;\r\n SubSvc: TJvDataConsumerAggregatedObject) of object;\r\n TJvDataConsumerChangeReason = (ccrProviderSelect, ccrProviderChange, ccrViewChange,\r\n ccrContextChange, ccrOther);\r\n TJvDataConsumerChangeEvent = procedure(Sender: TJvDataConsumer;\r\n Reason: TJvDataConsumerChangeReason) of object;\r\n\r\n // Generic classes (move to some other unit?)\r\n TExtensibleInterfacedPersistent = class(TPersistent, IUnknown)\r\n private\r\n FAdditionalIntfImpl: TList;\r\n protected\r\n FRefCount: Integer;\r\n { IUnknown }\r\n function _AddRef: Integer; virtual; stdcall;\r\n function _Release: Integer; virtual; stdcall;\r\n function QueryInterface(const IID: TGUID; out Obj): HRESULT; virtual; stdcall;\r\n // implementer list\r\n procedure AddIntfImpl(const Obj: TAggregatedPersistentEx);\r\n procedure RemoveIntfImpl(const Obj: TAggregatedPersistentEx);\r\n function IndexOfImplClass(const AClass: TAggregatedPersistentExClass): Integer;\r\n function GetImplOfClass(AClass: TAggregatedPersistentExClass): TAggregatedPersistentEx;\r\n procedure ClearIntfImpl;\r\n procedure InitImplementers; virtual;\r\n function ImplCount: Integer;\r\n function GetImplementer(Index: Integer): TAggregatedPersistentEx;\r\n // refercence counting\r\n procedure SuspendRefCount;\r\n procedure ResumeRefCount;\r\n // streaming\r\n function IsStreamableExtension(AnExtension: TAggregatedPersistentEx): Boolean; virtual;\r\n procedure DefineProperties(Filer: TFiler); override;\r\n procedure ReadImplementers(Reader: TReader);\r\n procedure WriteImplementers(Writer: TWriter);\r\n procedure ReadImplementer(Reader: TReader);\r\n procedure WriteImplementer(Writer: TWriter; Instance: TAggregatedPersistentEx);\r\n public\r\n constructor Create;\r\n destructor Destroy; override;\r\n procedure AfterConstruction; override;\r\n procedure BeforeDestruction; override;\r\n function GetInterface(const IID: TGUID; out Obj): Boolean; virtual;\r\n class function NewInstance: TObject; override;\r\n property RefCount: Integer read FRefCount;\r\n end;\r\n\r\n TAggregatedPersistent = class(TPersistent)\r\n private\r\n FController: Pointer;\r\n function GetController: IUnknown;\r\n protected\r\n { IUnknown }\r\n function QueryInterface(const IID: TGUID; out Obj): HRESULT; virtual; stdcall;\r\n function _AddRef: Integer; virtual; stdcall;\r\n function _Release: Integer; virtual; stdcall;\r\n public\r\n constructor Create(Controller: IUnknown);\r\n function GetInterface(const IID: TGUID; out Obj): Boolean; virtual;\r\n property Controller: IUnknown read GetController;\r\n end;\r\n\r\n TAggregatedPersistentEx = class(TAggregatedPersistent)\r\n private\r\n FOwner: TExtensibleInterfacedPersistent;\r\n protected\r\n property Owner: TExtensibleInterfacedPersistent read FOwner;\r\n function IsHidden: Boolean; virtual;\r\n public\r\n constructor Create(AOwner: TExtensibleInterfacedPersistent); virtual;\r\n procedure AfterConstruction; override;\r\n procedure BeforeDestruction; override;\r\n end;\r\n\r\n // Generic event based provider notification\r\n TJvProviderNotification = class(TObject, IUnknown, IJvDataProviderNotify)\r\n private\r\n FProvider: IJvDataProvider;\r\n FOnChanging: TProviderNotifyEvent;\r\n FOnChanged: TProviderNotifyEvent;\r\n protected\r\n procedure SetProvider(Value: IJvDataProvider);\r\n { IUnknown }\r\n function _AddRef: Integer; virtual; stdcall;\r\n function _Release: Integer; virtual; stdcall;\r\n function QueryInterface(const IID: TGUID; out Obj): HRESULT; virtual; stdcall;\r\n { IJvDataProviderNotify }\r\n procedure DataProviderChanging(const ADataProvider: IJvDataProvider;\r\n AReason: TDataProviderChangeReason; Source: IUnknown);\r\n procedure DataProviderChanged(const ADataProvider: IJvDataProvider;\r\n AReason: TDataProviderChangeReason; Source: IUnknown);\r\n function Consumer: IJvDataConsumer;\r\n public\r\n destructor Destroy; override;\r\n property OnChanging: TProviderNotifyEvent read FOnChanging write FOnChanging;\r\n property OnChanged: TProviderNotifyEvent read FOnChanged write FOnChanged;\r\n property Provider: IJvDataProvider read FProvider write SetProvider;\r\n end;\r\n\r\n // Item implementation classes\r\n TJvDataItemAggregatedObject = class(TAggregatedPersistentEx)\r\n protected\r\n function QueryInterface(const IID: TGUID; out Obj): HRESULT; override; stdcall;\r\n procedure ContextDestroying(Context: IJvDataContext); dynamic;\r\n function Item: IJvDataItem;\r\n function ItemImpl: TJvBaseDataItem;\r\n end;\r\n\r\n TJvBaseDataItem = class(TExtensibleInterfacedPersistent, IJvDataItem)\r\n private\r\n FItems: Pointer;\r\n FItemsIntf: IJvDataItems;\r\n FID: string;\r\n protected\r\n { Initialize ID. Each item must have an unique identification. Implementers may choose how this\r\n ID is generated. No checks are made when items are added to a provider to ensure it's\r\n unique. If multiple items with the same ID are added only the first item in the tree will be\r\n selectable at design time. }\r\n procedure InitID; virtual;\r\n { Set the ID string. Used by InitID to set the actual ID string. }\r\n procedure SetID(Value: string);\r\n { Reference counting: add 1 if this item is part of a dynamic list (Items.IsDynamic returns\r\n True). Otherwise reference counting is not used. }\r\n function _AddRef: Integer; override; stdcall;\r\n { Reference counting: substract 1 if this item is part of a dynamic list (Items.IsDynamic returns\r\n True). Otherwise reference counting is not used. }\r\n function _Release: Integer; override; stdcall;\r\n // design support\r\n function GetOwner: TPersistent; override;\r\n { Streaming of an item. }\r\n procedure DefineProperties(Filer: TFiler); override;\r\n procedure ReadSubItems(Reader: TReader);\r\n procedure WriteSubItems(Writer: TWriter);\r\n { IJvDataItem methods and properties. }\r\n function GetItems: IJvDataItems;\r\n function GetIndex: Integer;\r\n function GetImplementer: TObject;\r\n function GetID: string;\r\n procedure ContextDestroying(Context: IJvDataContext); dynamic;\r\n function IsParentOf(AnItem: IJvDataItem; DirectParent: Boolean = False): Boolean; virtual;\r\n function IsDeletable: Boolean; dynamic;\r\n property Items: IJvDataItems read GetItems;\r\n property Implementer: TObject read GetImplementer;\r\n { Optional IJvDataContextSensitive interface implementation }\r\n procedure RevertToAncestor; dynamic;\r\n function IsEqualToAncestor: Boolean; dynamic;\r\n public\r\n constructor Create(AOwner: IJvDataItems);\r\n procedure AfterConstruction; override;\r\n function GetNamePath: string; override;\r\n published\r\n property ID: string read GetID write SetID;\r\n end;\r\n\r\n TJvBaseDataItemTextImpl = class(TJvDataItemAggregatedObject, IJvDataItemText)\r\n protected\r\n function GetText: string; virtual; abstract;\r\n procedure SetText(const Value: string); virtual; abstract;\r\n function Editable: Boolean; virtual; abstract;\r\n public\r\n property Text: string read GetText write SetText;\r\n end;\r\n\r\n TJvBaseDataItemImageImpl = class(TJvDataItemAggregatedObject, IJvDataItemImage)\r\n protected\r\n function GetAlignment: TAlignment; virtual; abstract;\r\n procedure SetAlignment(Value: TAlignment); virtual; abstract;\r\n function GetImageIndex: Integer; virtual; abstract;\r\n procedure SetImageIndex(Index: Integer); virtual; abstract;\r\n function GetSelectedIndex: Integer; virtual; abstract;\r\n procedure SetSelectedIndex(Value: Integer); virtual; abstract;\r\n end;\r\n\r\n TJvBaseDataItemRenderer = class(TJvDataItemAggregatedObject, IJvDataItemRenderer)\r\n protected\r\n procedure Draw(ACanvas: TCanvas; var ARect: TRect; State: TProviderDrawStates); virtual; abstract;\r\n function Measure(ACanvas: TCanvas): TSize; virtual; abstract;\r\n end;\r\n\r\n TJvBaseDataItemStates = class(TJvDataItemAggregatedObject, IJvDataItemStates)\r\n protected\r\n function Get_Enabled: TDataItemState; virtual; abstract;\r\n procedure Set_Enabled(Value: TDataItemState); virtual; abstract;\r\n function Get_Checked: TDataItemState; virtual; abstract;\r\n procedure Set_Checked(Value: TDataItemState); virtual; abstract;\r\n function Get_Visible: TDataItemState; virtual; abstract;\r\n procedure Set_Visible(Value: TDataItemState); virtual; abstract;\r\n end;\r\n\r\n // Items implementation classes\r\n TJvDataItemsAggregatedObject = class(TAggregatedPersistentEx)\r\n protected\r\n procedure ContextDestroying(Context: IJvDataContext); dynamic;\r\n function Items: IJvDataItems;\r\n function ItemsImpl: TJvBaseDataItems;\r\n end;\r\n\r\n TJvBaseDataItems = class(TExtensibleInterfacedPersistent, IJvDataItems, IJvDataIDSearch)\r\n function IJvDataIDSearch.Find = FindByID;\r\n private\r\n FParent: Pointer;\r\n FParentIntf: IJvDataItem;\r\n FProvider: IJvDataProvider;\r\n FSubAggregate: TAggregatedPersistentEx;\r\n protected\r\n { Adds an item to the list. }\r\n procedure InternalAdd(Item: IJvDataItem); virtual; abstract;\r\n { Removes an item from the list. }\r\n procedure InternalDelete(Index: Integer); virtual; abstract;\r\n { Moves an item in the list to a new index. }\r\n procedure InternalMove(OldIndex, NewIndex: Integer); virtual; abstract;\r\n { Called by the IJvDataItemsManagement and IJvDataItemsDesigner implementations to add a new\r\n item. It will redirect it to InternalAdd. InternalAdd will perform the add, but may also\r\n perform addition steps if needed (in case of context specific list it might need to copy the\r\n list first). }\r\n procedure ItemAdd(Item: IJvDataItem);\r\n { Called by the IJvDataItemsManagement implementation to remove an item. It will redirect it to\r\n InternalDelete. InternalDelete will perform the removal, but may also perform addition steps\r\n if needed (i.e. notify the other contexts if the delete is performed on the context-less list\r\n or copy the list for a context specific list that inherits from an ancestor). }\r\n procedure ItemDelete(Index: Integer);\r\n { Called by the IJvDataItem implementation to move an item. It will redirect it to\r\n InternalMove. InternalMove will perform the moving if it's called from within a context.\r\n The context-less list does not allow moving of items. }\r\n procedure ItemMove(OldIndex, NewIndex: Integer);\r\n { Determines if the item is streamable. }\r\n function IsStreamableItem(Item: IJvDataItem): Boolean; virtual;\r\n function ScanForID(Items: IJvDataItems; ID: string; Recursive: Boolean): IJvDataItem;\r\n { Streaming methods }\r\n procedure DefineProperties(Filer: TFiler); override;\r\n procedure ReadItems(Reader: TReader);\r\n procedure WriteItems(Writer: TWriter);\r\n procedure ReadItem(Reader: TReader);\r\n procedure WriteItem(Writer: TWriter; Item: IJvDataItem);\r\n { IJvDataItems methods }\r\n function GetCount: Integer; virtual; abstract;\r\n function GetItem(I: Integer): IJvDataItem; virtual; abstract;\r\n function GetItemByID(ID: string): IJvDataItem;\r\n function GetItemByIndexPath(IndexPath: array of Integer): IJvDataItem;\r\n function GetParent: IJvDataItem; virtual;\r\n function GetProvider: IJvDataProvider;\r\n function GetImplementer: TObject;\r\n function IsDynamic: Boolean; virtual;\r\n procedure ContextDestroying(Context: IJvDataContext); dynamic;\r\n { IJvDataIDSearch methods }\r\n function FindByID(ID: string; const Recursive: Boolean = False): IJvDataItem;\r\n public\r\n constructor Create; overload; virtual;\r\n constructor Create(const Provider: IJvDataProvider); overload; virtual;\r\n constructor Create(const Parent: IJvDataItem); overload; virtual;\r\n procedure BeforeDestruction; override;\r\n end;\r\n\r\n TJvBaseDataItemsRenderer = class(TJvDataItemsAggregatedObject, IJvDataItemsRenderer)\r\n protected\r\n procedure DoDrawItem(ACanvas: TCanvas; var ARect: TRect; Item: IJvDataItem; State: TProviderDrawStates); virtual; abstract;\r\n function DoMeasureItem(ACanvas: TCanvas; Item: IJvDataItem): TSize; virtual; abstract;\r\n { IJvDataItemsRenderer methods }\r\n procedure DrawItemByIndex(ACanvas: TCanvas; var ARect: TRect; Index: Integer;\r\n State: TProviderDrawStates); virtual;\r\n function MeasureItemByIndex(ACanvas: TCanvas; Index: Integer): TSize; virtual;\r\n procedure DrawItem(ACanvas: TCanvas; var ARect: TRect; Item: IJvDataItem;\r\n State: TProviderDrawStates); virtual;\r\n function MeasureItem(ACanvas: TCanvas; Item: IJvDataItem): TSize; virtual;\r\n function AvgItemSize(ACanvas: TCanvas): TSize; virtual; abstract;\r\n end;\r\n\r\n TJvBaseDataItemsManagement = class(TJvDataItemsAggregatedObject, IJvDataItemsManagement)\r\n protected\r\n { IJvDataItemManagement methods }\r\n function Add(Item: IJvDataItem): IJvDataItem; virtual; abstract;\r\n function New: IJvDataItem; virtual; abstract;\r\n procedure Clear; virtual; abstract;\r\n procedure Delete(Index: Integer); virtual; abstract;\r\n procedure Remove(var Item: IJvDataItem); virtual; abstract;\r\n end;\r\n\r\n TJvBaseDataItemsImagesImpl = class(TJvDataItemsAggregatedObject, IJvDataItemsImages)\r\n protected\r\n { IJvDataItemImages methods }\r\n function GetDisabledImages: TCustomImageList; virtual; abstract;\r\n procedure SetDisabledImages(const Value: TCustomImageList); virtual; abstract;\r\n function GetHotImages: TCustomImageList; virtual; abstract;\r\n procedure SetHotImages(const Value: TCustomImageList); virtual; abstract;\r\n function GetImages: TCustomImageList; virtual; abstract;\r\n procedure SetImages(const Value: TCustomImageList); virtual; abstract;\r\n end;\r\n\r\n // Standard item implementers\r\n TJvDataItemTextImpl = class(TJvBaseDataItemTextImpl)\r\n private\r\n FText: string;\r\n protected\r\n function GetText: string; override;\r\n procedure SetText(const Value: string); override;\r\n function Editable: Boolean; override;\r\n published\r\n property Text: string read GetText write SetText;\r\n end;\r\n\r\n { Context sensitive text implementation: Retrieves/Sets the captiontext linked to the currently\r\n selected context. The implementation provides in a default text that is not linked to any\r\n context. If there's no active context set at the provider; this text will be retrieved/set.\r\n If the active context set at the provider has no text linked to it, the standard text\r\n is retrieved, but a new link is added when the text is changed. }\r\n TJvDataItemContextTextImpl = class(TJvDataItemTextImpl, IJvDataContextSensitive)\r\n private\r\n FContextStrings: TStringList;\r\n protected\r\n function GetText: string; override;\r\n procedure SetText(const Value: string); override;\r\n function Editable: Boolean; override;\r\n public\r\n constructor Create(AOwner: TExtensibleInterfacedPersistent); override;\r\n destructor Destroy; override;\r\n procedure RevertToAncestor; dynamic;\r\n function IsEqualToAncestor: Boolean; dynamic;\r\n end;\r\n\r\n { Blockable text implementation: allows to set the text portion to read-only, blocking any\r\n consumer-side editing (assuming the consumer respects the value returned by the\r\n IJvDataItemText.Editable function) }\r\n TJvDataItemBlockableTextImpl = class (TJvDataItemTextImpl)\r\n private\r\n FReadOnly: Boolean;\r\n protected\r\n procedure SetReadOnly(Value: Boolean);\r\n function Editable: Boolean; override;\r\n published\r\n property ReadOnly: Boolean read FReadOnly write SetReadOnly;\r\n end;\r\n\r\n TJvDataItemImageImpl = class(TJvBaseDataItemImageImpl)\r\n private\r\n FAlignment: TAlignment;\r\n FImageIndex: Integer;\r\n FSelectedIndex: Integer;\r\n protected\r\n function GetAlignment: TAlignment; override;\r\n procedure SetAlignment(Value: TAlignment); override;\r\n function GetImageIndex: Integer; override;\r\n procedure SetImageIndex(Index: Integer); override;\r\n function GetSelectedIndex: Integer; override;\r\n procedure SetSelectedIndex(Value: Integer); override;\r\n published\r\n property Alignment: TAlignment read GetAlignment write SetAlignment default taLeftJustify;\r\n property ImageIndex: Integer read GetImageIndex write SetImageIndex default 0;\r\n property SelectedIndex: Integer read GetSelectedIndex write SetSelectedIndex default 0;\r\n end;\r\n\r\n TJvBaseDataItemSubItems = class(TJvDataItemAggregatedObject, IJvDataItems)\r\n private\r\n FItems: IJvDataItems;\r\n protected\r\n property Items: IJvDataItems read FItems implements IJvDataItems;\r\n public\r\n constructor Create(AOwner: TExtensibleInterfacedPersistent; AItems: TJvBaseDataItems); reintroduce; virtual;\r\n procedure BeforeDestruction; override;\r\n function GetInterface(const IID: TGUID; out Obj): Boolean; override;\r\n end;\r\n\r\n TJvCustomDataItemTextRenderer = class(TJvBaseDataItemRenderer)\r\n protected\r\n procedure Draw(ACanvas: TCanvas; var ARect: TRect; State: TProviderDrawStates); override;\r\n function Measure(ACanvas: TCanvas): TSize; override;\r\n end;\r\n\r\n TJvCustomDataItemRenderer = class(TJvBaseDataItemRenderer)\r\n protected\r\n procedure Draw(ACanvas: TCanvas; var ARect: TRect; State: TProviderDrawStates); override;\r\n function Measure(ACanvas: TCanvas): TSize; override;\r\n end;\r\n\r\n TJvCustomDataItemStates = class(TJvBaseDataItemStates)\r\n private\r\n FEnabled: TDataItemState;\r\n FChecked: TDataItemState;\r\n FVisible: TDataItemState;\r\n protected\r\n procedure InitStatesUsage(UseEnabled, UseChecked, UseVisible: Boolean);\r\n function Get_Enabled: TDataItemState; override;\r\n procedure Set_Enabled(Value: TDataItemState); override;\r\n function Get_Checked: TDataItemState; override;\r\n procedure Set_Checked(Value: TDataItemState); override;\r\n function Get_Visible: TDataItemState; override;\r\n procedure Set_Visible(Value: TDataItemState); override;\r\n published\r\n property Enabled: TDataItemState read Get_Enabled write Set_Enabled;\r\n property Checked: TDataItemState read Get_Checked write Set_Checked;\r\n property Visible: TDataItemState read Get_Visible write Set_Visible;\r\n end;\r\n\r\n // Standard items implementers\r\n TJvCustomDataItemsTextRenderer = class(TJvBaseDataItemsRenderer)\r\n protected\r\n procedure DoDrawItem(ACanvas: TCanvas; var ARect: TRect; Item: IJvDataItem;\r\n State: TProviderDrawStates); override;\r\n function DoMeasureItem(ACanvas: TCanvas; Item: IJvDataItem): TSize; override;\r\n function AvgItemSize(ACanvas: TCanvas): TSize; override;\r\n end;\r\n\r\n TJvCustomDataItemsRenderer = class(TJvBaseDataItemsRenderer)\r\n protected\r\n procedure DoDrawItem(ACanvas: TCanvas; var ARect: TRect; Item: IJvDataItem;\r\n State: TProviderDrawStates); override;\r\n function DoMeasureItem(ACanvas: TCanvas; Item: IJvDataItem): TSize; override;\r\n function AvgItemSize(ACanvas: TCanvas): TSize; override;\r\n end;\r\n\r\n TJvDataItemsList = class(TJvBaseDataItems)\r\n private\r\n FList: TObjectList;\r\n protected\r\n procedure InternalAdd(Item: IJvDataItem); override;\r\n procedure InternalDelete(Index: Integer); override;\r\n procedure InternalMove(OldIndex, NewIndex: Integer); override;\r\n function IsDynamic: Boolean; override;\r\n function GetCount: Integer; override;\r\n function GetItem(I: Integer): IJvDataItem; override;\r\n public\r\n constructor Create; override;\r\n destructor Destroy; override;\r\n\r\n property List: TObjectList read FList;\r\n end;\r\n\r\n TJvBaseDataItemsListManagement = class(TJvBaseDataItemsManagement)\r\n protected\r\n function Add(Item: IJvDataItem): IJvDataItem; override;\r\n procedure Clear; override;\r\n procedure Delete(Index: Integer); override;\r\n procedure Remove(var Item: IJvDataItem); override;\r\n end;\r\n\r\n TJvCustomDataItemsImages = class(TJvBaseDataItemsImagesImpl)\r\n private\r\n FDisabledImages: TCustomImageList;\r\n FHotImages: TCustomImageList;\r\n FImages: TCustomImageList;\r\n protected\r\n function GetDisabledImages: TCustomImageList; override;\r\n procedure SetDisabledImages(const Value: TCustomImageList); override;\r\n function GetHotImages: TCustomImageList; override;\r\n procedure SetHotImages(const Value: TCustomImageList); override;\r\n function GetImages: TCustomImageList; override;\r\n procedure SetImages(const Value: TCustomImageList); override;\r\n published\r\n property DisabledImages: TCustomImageList read GetDisabledImages write SetDisabledImages;\r\n property HotImages: TCustomImageList read GetHotImages write SetHotImages;\r\n property Images: TCustomImageList read GetImages write SetImages;\r\n end;\r\n\r\n // Generic data provider implementation\r\n TJvCustomDataProvider = class(TJvComponent, IUnknown, IJvDataProvider)\r\n private\r\n FDataItems: IJvDataItems;\r\n FDataContextsImpl: TJvBaseDataContexts;\r\n FDataContextsIntf: IJvDataContexts;\r\n FNotifiers: TInterfaceList;\r\n FTreeItems: TJvDataProviderTree;\r\n FConsumerStack: TInterfaceList;\r\n FContextStack: TInterfaceList;\r\n FContexts: TJvDataProviderContexts;\r\n protected\r\n function QueryInterface(const IID: TGUID; out Obj): HRESULT; override;\r\n procedure Changing(ChangeReason: TDataProviderChangeReason; Source: IUnknown = nil);\r\n procedure Changed(ChangeReason: TDataProviderChangeReason; Source: IUnknown = nil);\r\n class function PersistentDataItems: Boolean; virtual;\r\n class function ItemsClass: TJvDataItemsClass; virtual;\r\n class function ContextsClass: TJvDataContextsClass; virtual;\r\n class function ContextsManagerClass: TJvDataContextsManagerClass; virtual;\r\n procedure DefineProperties(Filer: TFiler); override;\r\n procedure ReadRoot(Reader: TReader);\r\n procedure WriteRoot(Writer: TWriter);\r\n procedure ReadContexts(Reader: TReader);\r\n procedure WriteContexts(Writer: TWriter);\r\n procedure ReadContext(Reader: TReader; Index: Integer);\r\n procedure WriteContext(Writer: TWriter; AContext: IJvDataContext);\r\n procedure AddToArray(var ClassArray: TClassArray; AClass: TClass);\r\n procedure DeleteFromArray(var ClassArray: TClassArray; Index: Integer);\r\n function IndexOfClass(AClassArray: TClassArray; AClass: TClass): Integer;\r\n procedure RemoveFromArray(var ClassArray: TClassArray; AClass: TClass);\r\n function IsTreeProvider: Boolean; dynamic;\r\n function GetDataItemsImpl: TJvBaseDataItems;\r\n { IDataProvider }\r\n function GetItems: IJvDataItems; virtual;\r\n procedure RegisterChangeNotify(ANotify: IJvDataProviderNotify); dynamic;\r\n procedure UnregisterChangeNotify(ANotify: IJvDataProviderNotify); dynamic;\r\n function ConsumerClasses: TClassArray; dynamic;\r\n procedure SelectConsumer(Consumer: IJvDataConsumer);\r\n function SelectedConsumer: IJvDataConsumer;\r\n procedure ReleaseConsumer;\r\n procedure SelectContext(Context: IJvDataContext);\r\n function SelectedContext: IJvDataContext;\r\n procedure ReleaseContext;\r\n procedure ContextAdded(Context: IJvDataContext); dynamic;\r\n procedure ContextDestroying(Context: IJvDataContext); dynamic;\r\n procedure ConsumerDestroying(Consumer: IJvDataConsumer); dynamic;\r\n function AllowProviderDesigner: Boolean; dynamic;\r\n function AllowContextManager: Boolean; dynamic;\r\n function GetNotifierCount: Integer;\r\n function GetNotifier(Index: Integer): IJvDataProviderNotify;\r\n function GetImplementer: TObject;\r\n\r\n property DataItemsImpl: TJvBaseDataItems read GetDataItemsImpl;\r\n property DataContextsImpl: TJvBaseDataContexts read FDataContextsImpl;\r\n property Items: TJvDataProviderTree read FTreeItems write FTreeItems stored False;\r\n property Contexts: TJvDataProviderContexts read FContexts write FContexts stored False;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n procedure BeforeDestruction; override;\r\n function GetInterface(const IID: TGUID; out Obj): Boolean; virtual;\r\n end;\r\n\r\n // Basic context list\r\n TJvBaseDataContexts = class(TExtensibleInterfacedPersistent, IJvDataContexts)\r\n private\r\n FProvider: IJvDataProvider;\r\n FDsgnContext: IJvDataContext;\r\n FAncestor: IJvDataContext;\r\n protected\r\n procedure DoAddContext(Context: IJvDataContext); virtual; abstract;\r\n procedure DoDeleteContext(Index: Integer); virtual; abstract;\r\n procedure DoRemoveContext(Context: IJvDataContext); virtual; abstract;\r\n procedure DoClearContexts; virtual; abstract;\r\n function Provider: IJvDataProvider;\r\n function Ancestor: IJvDataContext;\r\n function GetCount: Integer; virtual; abstract;\r\n function GetContext(Index: Integer): IJvDataContext; virtual; abstract;\r\n function GetContextByName(Name: string): IJvDataContext; virtual;\r\n function IndexOf(Ctx: IJvDataContext): Integer; virtual;\r\n property DsgnContext: IJvDataContext read FDsgnContext write FDsgnContext;\r\n public\r\n constructor Create(AProvider: IJvDataProvider; AAncestor: IJvDataContext;\r\n ManagerClass: TJvDataContextsManagerClass = nil); virtual;\r\n end;\r\n\r\n // Basic context list manager\r\n TJvBaseDataContextsManager = class(TAggregatedPersistentEx, IJvDataContextsManager)\r\n protected\r\n function Contexts: IJvDataContexts;\r\n function ContextsImpl: TJvBaseDataContexts;\r\n function Add(Context: IJvDataContext): IJvDataContext;\r\n function New: IJvDataContext; virtual; abstract;\r\n procedure Delete(Context: IJvDataContext);\r\n procedure Clear;\r\n end;\r\n\r\n // Basic context\r\n TJvBaseDataContext = class(TExtensibleInterfacedPersistent, IJvDataContext)\r\n private\r\n FContexts: TJvBaseDataContexts;\r\n protected\r\n { Will actually set the name without any checks or notification. You should use SetName to\r\n change the context's name which in turn will call this method after it has checked the\r\n name is unique. }\r\n procedure DoSetName(Value: string); virtual; abstract;\r\n { Changes this context's name to the given name. It will first check if the new name is\r\n unique and then calls DoSetName to change it. }\r\n procedure SetName(Value: string); virtual;\r\n function GetImplementer: TObject;\r\n function ContextsImpl: TJvBaseDataContexts;\r\n function Contexts: IJvDataContexts;\r\n function Name: string; virtual; abstract;\r\n function IsDeletable: Boolean; dynamic;\r\n function IsStreamable: Boolean; dynamic;\r\n public\r\n constructor Create(AContexts: TJvBaseDataContexts; AName: string); virtual;\r\n end;\r\n\r\n // Basic managed context\r\n TJvBaseManagedDataContext = class(TJvBaseDataContext, IJvDataContextManager);\r\n\r\n // Basic fixed context\r\n TJvBaseFixedDataContext = class(TJvBaseDataContext)\r\n protected\r\n function IsDeletable: Boolean; override;\r\n end;\r\n\r\n // Standard context list\r\n TJvDataContexts = class(TJvBaseDataContexts)\r\n private\r\n FContexts: TInterfaceList;\r\n protected\r\n procedure DoAddContext(Context: IJvDataContext); override;\r\n procedure DoDeleteContext(Index: Integer); override;\r\n procedure DoRemoveContext(Context: IJvDataContext); override;\r\n procedure DoClearContexts; override;\r\n function GetCount: Integer; override;\r\n function GetContext(Index: Integer): IJvDataContext; override;\r\n public\r\n constructor Create(AProvider: IJvDataProvider; AAncestor: IJvDataContext;\r\n ManagerClass: TJvDataContextsManagerClass = nil); override;\r\n destructor Destroy; override;\r\n end;\r\n\r\n // Standard context\r\n TJvDataContext = class(TJvBaseDataContext)\r\n private\r\n FName: string;\r\n protected\r\n procedure DoSetName(Value: string); override;\r\n function Name: string; override;\r\n end;\r\n\r\n // Standard managed context\r\n TJvManagedDataContext = class(TJvDataContext, IJvDataContextManager);\r\n\r\n // Standard fixed context\r\n TJvFixedDataContext = class(TJvDataContext)\r\n protected\r\n function IsDeletable: Boolean; override;\r\n end;\r\n\r\n// Helper classes: rendering helpers\r\n { Render class to be used by both the IJvDataItemsRenderer as well as IJvDataItemRenderer\r\n implementers. Reduces code duplication if both type of implementers can use the same rendering\r\n mechanism. }\r\n TJvDP_ProviderBaseRender = class(TObject)\r\n private\r\n FItem: IJvDataItem;\r\n FCanvas: TCanvas;\r\n FState: TProviderDrawStates;\r\n protected\r\n Rect: TRect;\r\n procedure Prepare(ForMeasure: Boolean); virtual; abstract;\r\n procedure DoDraw; virtual; abstract;\r\n function DoMeasure: TSize; virtual; abstract;\r\n\r\n property Item: IJvDataItem read FItem;\r\n property Canvas: TCanvas read FCanvas;\r\n property State: TProviderDrawStates read FState;\r\n public\r\n constructor Create(AItem: IJvDataItem; ACanvas: TCanvas; AState: TProviderDrawStates);\r\n class procedure Draw(AItem: IJvDataItem; ACanvas: TCanvas; var ARect: TRect; AState: TProviderDrawStates);\r\n class function Measure(AItem: IJvDataItem; ACanvas: TCanvas; AState: TProviderDrawStates): TSize;\r\n end;\r\n\r\n TJvDP_ProviderTextOnlyRender = class(TJvDP_ProviderBaseRender)\r\n private\r\n FHasNoText: Boolean;\r\n FText: string;\r\n FTextRect: TRect;\r\n protected\r\n procedure Prepare(ForMeasure: Boolean); override;\r\n procedure DoDraw; override;\r\n function DoMeasure: TSize; override;\r\n\r\n property HasNoText: Boolean read FHasNoText write FHasNoText;\r\n property Text: string read FText write FText;\r\n property TextRect: TRect read FTextRect write FTextRect;\r\n end;\r\n\r\n TJvDP_ProviderImgAndTextRender = class(TJvDP_ProviderTextOnlyRender)\r\n private\r\n FHasImage: Boolean;\r\n FHasDisabledImage: Boolean;\r\n FImages: TCustomImageList;\r\n FImageIndex: Integer;\r\n FAlignment: TAlignment;\r\n protected\r\n procedure Prepare(ForMeasure: Boolean); override;\r\n procedure DoDraw; override;\r\n function DoMeasure: TSize; override;\r\n\r\n property HasImage: Boolean read FHasImage write FHasImage;\r\n property HasDisabledImage: Boolean read FHasDisabledImage write FHasDisabledImage;\r\n property Images: TCustomImageList read FImages write FImages;\r\n property ImageIndex: Integer read FImageIndex write FImageIndex;\r\n property Alignment: TAlignment read FAlignment write FAlignment;\r\n end;\r\n\r\n TJvDataConsumer = class(TExtensibleInterfacedPersistent, IJvDataConsumer, IJvDataProviderNotify,\r\n IJvDataConsumerProvider, IJvDataConsumerClientNotify)\r\n private\r\n FOwner: TComponent;\r\n FAttrList: array of Integer;\r\n FProvider: IJvDataProvider;\r\n FContext: IJvDataContext;\r\n FAfterCreateSubSvc: TAfterCreateSubSvcEvent;\r\n FBeforeCreateSubSvc: TBeforeCreateSubSvcEvent;\r\n FOnChanging: TJvDataConsumerChangeEvent;\r\n FOnChanged: TJvDataConsumerChangeEvent;\r\n FNeedFixups: Boolean;\r\n FFixupContext: TJvDataContextID;\r\n FOnProviderChanging: TProviderNotifyEvent;\r\n FOnProviderChanged: TProviderNotifyEvent;\r\n FServerList: TInterfaceList;\r\n procedure SetProvider(Value: IJvDataProvider);\r\n protected\r\n function _AddRef: Integer; override; stdcall;\r\n function _Release: Integer; override; stdcall;\r\n { Event triggering }\r\n procedure DoProviderChanging(ADataProvider: IJvDataProvider; AReason: TDataProviderChangeReason; Source: IUnknown);\r\n procedure DoProviderChanged(ADataProvider: IJvDataProvider; AReason: TDataProviderChangeReason; Source: IUnknown);\r\n procedure DoAfterCreateSubSvc(ASvc: TJvDataConsumerAggregatedObject);\r\n procedure DoBeforeCreateSubSvc(var AClass: TJvDataConsumerAggregatedObjectClass);\r\n procedure DoChanging(Reason: TJvDataConsumerChangeReason);\r\n procedure DoChanged(Reason: TJvDataConsumerChangeReason);\r\n { Misc. }\r\n procedure DoAddAttribute(Attr: Integer);\r\n procedure Changing(Reason: TJvDataConsumerChangeReason); virtual;\r\n procedure Changed(Reason: TJvDataConsumerChangeReason); virtual;\r\n procedure ProviderChanging;\r\n procedure ProviderChanged;\r\n procedure ContextChanging;\r\n procedure ContextChanged;\r\n procedure AfterSubSvcAdded(ASvc: TJvDataConsumerAggregatedObject); virtual;\r\n procedure UpdateExtensions; virtual;\r\n procedure FixupExtensions;\r\n procedure FixupContext;\r\n procedure ViewChanged(AExtension: TJvDataConsumerAggregatedObject);\r\n procedure NotifyItemSelected(Value: IJvDataItem);\r\n procedure NotifyServerItemChanged(Server: IJvDataConsumerServerNotify; Value: IJvDataItem);\r\n procedure NotifyServerProviderChanged;\r\n function ExtensionCount: Integer;\r\n function Extension(Index: Integer): TJvDataConsumerAggregatedObject;\r\n function IsContextStored: Boolean;\r\n function GetNeedExtensionFixups: Boolean;\r\n function GetNeedContextFixup: Boolean;\r\n { Property access }\r\n function GetContext: TJvDataContextID;\r\n procedure SetContext(Value: TJvDataContextID);\r\n function GetServerCount: Integer;\r\n function GetServers(I: Integer): IJvDataConsumerServerNotify;\r\n { IJvDataProviderNotify methods }\r\n procedure DataProviderChanging(const ADataProvider: IJvDataProvider; AReason: TDataProviderChangeReason; Source: IUnknown);\r\n procedure DataProviderChanged(const ADataProvider: IJvDataProvider; AReason: TDataProviderChangeReason; Source: IUnknown);\r\n function Consumer: IJvDataConsumer;\r\n { IJvDataConsumer methods }\r\n function VCLComponent: TComponent;\r\n function AttributeApplies(Attr: Integer): Boolean;\r\n { IJvDataConsumerProvider methods }\r\n function IJvDataConsumerProvider.GetProvider = ProviderIntf;\r\n { IJvDataConsumerClientNotify methods }\r\n procedure IJvDataConsumerClientNotify.ItemSelected = ServerItemChanged;\r\n procedure ServerItemChanged(Server: IJvDataConsumerServerNotify; Value: IJvDataItem); virtual;\r\n procedure LinkAdded(Server: IJvDataConsumerServerNotify);\r\n procedure LinkRemoved(Server: IJvDataConsumerServerNotify);\r\n { States }\r\n property NeedExtensionFixups: Boolean read GetNeedExtensionFixups;\r\n property NeedContextFixup: Boolean read GetNeedContextFixup;\r\n { Other }\r\n property ServerCount: Integer read GetServerCount;\r\n property Servers[I: Integer]: IJvDataConsumerServerNotify read GetServers;\r\n public\r\n constructor Create(AOwner: TComponent; Attributes: array of Integer);\r\n destructor Destroy; override;\r\n { Direct link to actual provider interface. This is done to aid in the implementation (less\r\n IFDEF's in the code; always refer to ProviderIntf and it's working in all Delphi versions). }\r\n function ProviderIntf: IJvDataProvider; virtual;\r\n procedure SetProviderIntf(Value: IJvDataProvider); virtual;\r\n function ContextIntf: IJvDataContext; virtual;\r\n procedure SetContextIntf(Value: IJvDataContext); virtual;\r\n procedure Loaded; virtual;\r\n procedure Enter;\r\n procedure Leave;\r\n { Notifies the consumer the specified item is selected in the control. Will execute the item's\r\n IJvDataItemExecute interface if one is assigned to the item and notifies all service\r\n extensions of the selection change. }\r\n procedure ItemSelected(Value: IJvDataItem);\r\n function IsLoading: Boolean;\r\n\r\n property OnChanging: TJvDataConsumerChangeEvent read FOnChanging write FOnChanging;\r\n property OnChanged: TJvDataConsumerChangeEvent read FOnChanged write FOnChanged;\r\n property OnProviderChanging: TProviderNotifyEvent read FOnProviderChanging\r\n write FOnProviderChanging;\r\n property OnProviderChanged: TProviderNotifyEvent read FOnProviderChanged\r\n write FOnProviderChanged;\r\n property AfterCreateSubSvc: TAfterCreateSubSvcEvent read FAfterCreateSubSvc\r\n write FAfterCreateSubSvc;\r\n property BeforeCreateSubSvc: TBeforeCreateSubSvcEvent read FBeforeCreateSubSvc\r\n write FBeforeCreateSubSvc;\r\n published\r\n property Provider: IJvDataProvider read ProviderIntf write SetProvider;\r\n property Context: TJvDataContextID read GetContext write SetContext stored IsContextStored;\r\n end;\r\n\r\n TJvDataConsumerAggregatedObject = class(TAggregatedPersistentEx)\r\n protected\r\n StreamedInWithoutProvider: Boolean;\r\n procedure DataProviderChanging(ADataProvider: IJvDataProvider;\r\n AReason: TDataProviderChangeReason; Source: IUnknown); virtual;\r\n procedure DataProviderChanged(ADataProvider: IJvDataProvider;\r\n AReason: TDataProviderChangeReason; Source: IUnknown); virtual;\r\n { Called when the Provider/Context are set and NotifyFixups has been called earlier. It doesn't\r\n matter which sub service called NotifyFixups, all services are notified if the\r\n provider/context are set. }\r\n procedure Fixup; virtual;\r\n { Called after a new provider is selected to determine if the sub service can stay around.\r\n Return False to have the sub service removed (the default implementation) or set to True to\r\n keep it around. Note that on entry to this method the new provider is already selected. }\r\n function KeepOnProviderChange: Boolean; virtual;\r\n { Called after a new context is selected to determine if the sub service can stay around.\r\n Return False to have the sub service removed or set to True to keep it around (default\r\n implementation). Note that on entry to this method the new context is already selected. }\r\n function KeepOnContextChange: Boolean; virtual;\r\n { Notifies the consumer service a change is about to take place. Sub services should call this\r\n method when something is changing. }\r\n procedure Changing(Reason: TJvDataConsumerChangeReason);\r\n { Notifies the consumer service a change has taken place. Sub services should call this method\r\n when something has changed. }\r\n procedure Changed(Reason: TJvDataConsumerChangeReason);\r\n { Notifies the consumer service (and other extensions) a change has taken place that might have\r\n influenced the view list. }\r\n procedure NotifyViewChanged;\r\n { Called after the view has changed by another extension. }\r\n procedure ViewChanged(AExtension: TJvDataConsumerAggregatedObject); virtual;\r\n { Called when an item has been selected by the consumer. }\r\n procedure ItemSelected(Value: IJvDataItem); virtual;\r\n { Called when a linked server consumer has selected a new item. }\r\n procedure ServerItemChanged(Server: IJvDataConsumerServerNotify; Value: IJvDataItem); virtual;\r\n { Signal to the consumer service that settings need to be applies but the provider/context was\r\n not yet available. This may occur during streaming in from the DFM. As soon as the provider is\r\n known, the context is also set and Fixup is called for all sub services. }\r\n procedure NotifyFixups;\r\n { Called when the provider is about to be changed. }\r\n procedure ProviderChanging; virtual;\r\n { Called when the provider has changed but only after KeepOnProviderChange returned True. }\r\n procedure ProviderChanged; virtual;\r\n { Called when the context is about to be changed. }\r\n procedure ContextChanging; virtual;\r\n { Called when the context has changed but only after KeepOnContextChange returned True. }\r\n procedure ContextChanged; virtual;\r\n { Reference to the consumer service interface. }\r\n function Consumer: IJvDataConsumer;\r\n { Reference to the consumer service implementation. }\r\n function ConsumerImpl: TJvDataConsumer;\r\n { Retrieve the root IJvDataItems reference. }\r\n function RootItems: IJvDataItems;\r\n end;\r\n\r\n { Consumer sub service to select the context to use for the consumer. Only needed for design time\r\n purposes; use TJvDataConsumer.Context to change it directly. }\r\n TJvDataConsumerContext = class(TJvDataConsumerAggregatedObject, IJvDataConsumerContext)\r\n protected\r\n function GetContextID: TJvDataContextID;\r\n procedure SetContextID(Value: TJvDataContextID);\r\n function GetContext: IJvDataContext;\r\n procedure SetContext(Value: IJvDataContext);\r\n public\r\n property ContextIntf: IJvDataContext read GetContext write SetContext;\r\n published\r\n property Context: TJvDataContextID read GetContextID write SetContextID;\r\n end;\r\n\r\n { Consumer sub service to select the item to display or item that serves as the root. }\r\n TJvDataConsumerItemSelect = class(TJvDataConsumerAggregatedObject, IJvDataConsumerItemSelect)\r\n { Method resolutions }\r\n function IJvDataConsumerItemSelect.GetItem = GetItemIntf;\r\n procedure IJvDataConsumerItemSelect.SetItem = SetItemIntf;\r\n private\r\n FItemID: TJvDataItemID;\r\n FItem: IJvDataItem;\r\n protected\r\n procedure Fixup; override;\r\n function GetItem: TJvDataItemID;\r\n procedure SetItem(Value: TJvDataItemID);\r\n procedure DataProviderChanging(ADataProvider: IJvDataProvider;\r\n AReason: TDataProviderChangeReason; Source: IUnknown); override;\r\n procedure DataProviderChanged(ADataProvider: IJvDataProvider;\r\n AReason: TDataProviderChangeReason; Source: IUnknown); override;\r\n public\r\n function GetItemIntf: IJvDataItem;\r\n procedure SetItemIntf(Value: IJvDataItem);\r\n published\r\n property Item: TJvDataItemID read GetItem write SetItem;\r\n end;\r\n\r\n { Consumer sub service to maintain a flat list of the data tree. }\r\n TJvCustomDataConsumerViewList = class(TJvDataConsumerAggregatedObject, IJvDataConsumerViewList)\r\n private\r\n FAutoExpandLevel: Integer;\r\n FExpandOnNewItem: Boolean;\r\n FLevelIndent: Integer;\r\n protected\r\n function KeepOnProviderChange: Boolean; override;\r\n procedure ProviderChanging; override;\r\n procedure ProviderChanged; override;\r\n procedure ContextChanged; override;\r\n procedure ViewChanged(AExtension: TJvDataConsumerAggregatedObject); override;\r\n procedure DataProviderChanging(ADataProvider: IJvDataProvider;\r\n AReason: TDataProviderChangeReason; Source: IUnknown); override;\r\n procedure DataProviderChanged(ADataProvider: IJvDataProvider;\r\n AReason: TDataProviderChangeReason; Source: IUnknown); override;\r\n function InternalItemSibling(ParentIndex: Integer; var ScanIndex: Integer): Integer;\r\n function Get_AutoExpandLevel: Integer;\r\n procedure Set_AutoExpandLevel(Value: Integer);\r\n function Get_ExpandOnNewItem: Boolean;\r\n procedure Set_ExpandOnNewItem(Value: Boolean);\r\n function Get_LevelIndent: Integer;\r\n procedure Set_LevelIndent(Value: Integer);\r\n { Add an item as the sub item of the item specified. The parent item will be marked as being\r\n expanded. }\r\n procedure AddItem(Index: Integer; Item: IJvDataItem; ExpandToLevel: Integer = 0); virtual; abstract;\r\n { Add a list of items at the specified Index. The item preceding that index will be handled as\r\n if it was the parent of all items to be inserted. This will also mark that item as being\r\n expanded. }\r\n procedure AddItems(var Index: Integer; Items: IJvDataItems; ExpandToLevel: Integer = 0); virtual; abstract;\r\n procedure AddChildItem(ParentIndex: Integer; Item: IJvDataItem); virtual; abstract;\r\n procedure InsertItem(InsertIndex, ParentIndex: Integer; Item: IJvDataItem); virtual; abstract;\r\n { Delete the specified item and the items sub tree. }\r\n procedure DeleteItem(Index: Integer); virtual; abstract;\r\n { Deletes the specified items sub tree and mark the item as not-expanded }\r\n procedure DeleteItems(Index: Integer); virtual; abstract;\r\n procedure UpdateItemFlags(Index: Integer; Value, Mask: Integer); virtual; abstract;\r\n procedure ClearView; virtual;\r\n procedure RebuildView; virtual;\r\n public\r\n constructor Create(AOwner: TExtensibleInterfacedPersistent); override;\r\n procedure ExpandTreeTo(Item: IJvDataItem); virtual;\r\n { Toggles an item's expanded state. If an item becomes expanded, the item's sub item as present\r\n in the IJvDataItems instance will be added; if an item becomes collapsed the sub items are\r\n removed from the view. }\r\n procedure ToggleItem(Index: Integer); virtual; abstract;\r\n { Locate an item in the view list, returning it's absolute index. }\r\n function IndexOfItem(Item: IJvDataItem): Integer; virtual; abstract;\r\n { Locate an item ID in the view list, returning it's absolute index. }\r\n function IndexOfID(ID: TJvDataItemID): Integer; virtual; abstract;\r\n { Locate an item in the view list, returning it's index in the parent item. }\r\n function ChildIndexOfItem(Item: IJvDataItem): Integer; virtual; abstract;\r\n { Locate an item ID in the view list, returning it's index in the parent item. }\r\n function ChildIndexOfID(ID: TJvDataItemID): Integer; virtual; abstract;\r\n { Retrieve the IJvDataItem reference given the absolute index into the view list. }\r\n function Item(Index: Integer): IJvDataItem; virtual; abstract;\r\n { Retrieve an items level given the absolute index into the view list. }\r\n function ItemLevel(Index: Integer): Integer; virtual; abstract;\r\n { Retrieve an items expanded state given the absolute index into the view list. }\r\n function ItemIsExpanded(Index: Integer): Boolean; virtual; abstract;\r\n { Determine if an item has children given the absolute index into the view list. }\r\n function ItemHasChildren(Index: Integer): Boolean; virtual; abstract;\r\n { Retrieve an items parent given the absolute index into the view list. }\r\n function ItemParent(Index: Integer): IJvDataItem; virtual; abstract;\r\n { Retrieve an items parent absolute index given the absolute index into the view list. }\r\n function ItemParentIndex(Index: Integer): Integer; virtual; abstract;\r\n { Retrieve an items sibling given an absolute index. }\r\n function ItemSibling(Index: Integer): IJvDataItem; virtual; abstract;\r\n { Retrieve the index of an items sibling given an absolute index. }\r\n function ItemSiblingIndex(Index: Integer): Integer; virtual; abstract;\r\n { Retrieve the IJvDataItem reference given the child index and a parent item. }\r\n function SubItem(Parent: IJvDataItem; Index: Integer): IJvDataItem; overload; virtual; abstract;\r\n { Retrieve the IJvDataItem reference given the child index and a parent absolute index. }\r\n function SubItem(Parent, Index: Integer): IJvDataItem; overload; virtual; abstract;\r\n { Retrieve the absolute index given a child index and a parent item. }\r\n function SubItemIndex(Parent: IJvDataItem; Index: Integer): Integer; overload; virtual; abstract;\r\n { Retrieve the absolute index given a child index and a parent absolute index. }\r\n function SubItemIndex(Parent, Index: Integer): Integer; overload; virtual; abstract;\r\n { Retrieve info on grouping; each bit represents a level, if the bit is set the item at that\r\n level has another sibling. Can be used to render tree lines. Note that this is very generic\r\n implementation that is not the fastest. To make this info readily available will require\r\n a descendant that stores and updates this info on a per item basis. This method can then be\r\n adpated to use that info directly. }\r\n function ItemGroupInfo(Index: Integer): TDynIntegerArray; virtual;\r\n { Retrieve the number of viewable items. }\r\n function Count: Integer; virtual; abstract;\r\n\r\n property AutoExpandLevel: Integer read FAutoExpandLevel write FAutoExpandLevel;\r\n property ExpandOnNewItem: Boolean read FExpandOnNewItem write FExpandOnNewItem;\r\n property LevelIndent: Integer read Get_LevelIndent write Set_LevelIndent default 16;\r\n end;\r\n\r\n { View list; uses the least possible amount of memory but may be slow to find sibling/child\r\n items. }\r\n TViewListItem = record\r\n ItemID: string;\r\n Flags: Integer; // lower 24 bits contain item level\r\n end;\r\n TViewListItems = array of TViewListItem;\r\n\r\n TJvDataConsumerViewList = class(TJvCustomDataConsumerViewList)\r\n private\r\n FViewItems: TViewListItems;\r\n protected\r\n procedure AddItem(Index: Integer; Item: IJvDataItem; ExpandToLevel: Integer = 0); override;\r\n procedure AddChildItem(ParentIndex: Integer; Item: IJvDataItem); override;\r\n procedure AddItems(var Index: Integer; Items: IJvDataItems; ExpandToLevel: Integer = 0); override;\r\n procedure InsertItem(InsertIndex, ParentIndex: Integer; Item: IJvDataItem); override;\r\n procedure DeleteItem(Index: Integer); override;\r\n procedure DeleteItems(Index: Integer); override;\r\n procedure UpdateItemFlags(Index: Integer; Value, Mask: Integer); override;\r\n public\r\n procedure ToggleItem(Index: Integer); override;\r\n function IndexOfItem(Item: IJvDataItem): Integer; override;\r\n function IndexOfID(ID: TJvDataItemID): Integer; override;\r\n function ChildIndexOfItem(Item: IJvDataItem): Integer; override;\r\n function ChildIndexOfID(ID: TJvDataItemID): Integer; override;\r\n function Item(Index: Integer): IJvDataItem; override;\r\n function ItemLevel(Index: Integer): Integer; override;\r\n function ItemIsExpanded(Index: Integer): Boolean; override;\r\n function ItemHasChildren(Index: Integer): Boolean; override;\r\n function ItemParent(Index: Integer): IJvDataItem; override;\r\n function ItemParentIndex(Index: Integer): Integer; override;\r\n function ItemSibling(Index: Integer): IJvDataItem; override;\r\n function ItemSiblingIndex(Index: Integer): Integer; override;\r\n function SubItem(Parent: IJvDataItem; Index: Integer): IJvDataItem; override;\r\n function SubItem(Parent, Index: Integer): IJvDataItem; override;\r\n function SubItemIndex(Parent: IJvDataItem; Index: Integer): Integer; override;\r\n function SubItemIndex(Parent, Index: Integer): Integer; override;\r\n function Count: Integer; override;\r\n published\r\n property LevelIndent;\r\n end;\r\n\r\n TJvDataConsumerServerNotify = class(TJvDataConsumerAggregatedObject, IJvDataConsumerServerNotify)\r\n private\r\n FClients: TJvDataConsumerClientNotifyList;\r\n protected\r\n procedure SetClients(Value: TJvDataConsumerClientNotifyList);\r\n procedure ItemSelected(Value: IJvDataItem); override;\r\n function GetOwner: TPersistent; override;\r\n procedure NotifyItemSelected(Value: IJvDataItem);\r\n { IJvDataConsumerServerNotify }\r\n procedure AddClient(Client: IJvDataConsumerClientNotify);\r\n procedure RemoveClient(Client: IJvDataConsumerClientNotify);\r\n procedure NotifyProviderChanged(Client: IJvDataConsumerClientNotify); virtual;\r\n function IsValidClient(Client: IJvDataConsumerClientNotify): Boolean; virtual;\r\n public\r\n constructor Create(AOwner: TExtensibleInterfacedPersistent); override;\r\n destructor Destroy; override;\r\n published\r\n property Clients: TJvDataConsumerClientNotifyList read FClients write SetClients;\r\n end;\r\n\r\n TJvDataConsumerClientNotifyList = class(TOwnedCollection)\r\n private\r\n FServer: TJvDataConsumerServerNotify;\r\n protected\r\n function GetServer: TJvDataConsumerServerNotify;\r\n function GetNotifyItems(I: Integer): TJvDataConsumerClientNotifyItem;\r\n function GetConsumer(I: Integer): IJvDataConsumer;\r\n procedure SetItemName(Item: TCollectionItem); override;\r\n public\r\n constructor Create(AServer: TJvDataConsumerServerNotify);\r\n\r\n procedure Add(AComponent: TComponent); overload;\r\n procedure Add(AConsumer: IJvDataConsumer); overload;\r\n procedure Delete(Index: Integer); overload;\r\n procedure Delete(AComponent: TComponent); overload;\r\n procedure Delete(AConsumer: IJvDataConsumer); overload;\r\n function IndexOf(AComponent: TComponent): Integer; overload;\r\n function IndexOf(AConsumer: IJvDataConsumer): Integer; overload;\r\n\r\n property Server: TJvDataConsumerServerNotify read GetServer;\r\n property NotifyItems[I: Integer]: TJvDataConsumerClientNotifyItem read GetNotifyItems;\r\n property Clients[I: Integer]: IJvDataConsumer read GetConsumer; default;\r\n end;\r\n\r\n TJvDataConsumerClientNotifyItem = class(TCollectionItem)\r\n private\r\n FNotifier: IJvDataConsumerClientNotify;\r\n protected\r\n function GetList: TJvDataConsumerClientNotifyList;\r\n function GetConsumer: IJvDataConsumer;\r\n function GetComponent: TComponent;\r\n procedure SetComponent(Value: TComponent);\r\n procedure SetNotifier(Value: IJvDataConsumerClientNotify);\r\n function GetDisplayName: string; override;\r\n public\r\n destructor Destroy; override;\r\n\r\n property List: TJvDataConsumerClientNotifyList read GetList;\r\n property Notifier: IJvDataConsumerClientNotify read FNotifier write SetNotifier;\r\n published\r\n property Component: TComponent read GetComponent write SetComponent;\r\n end;\r\n\r\n { TStrings descendant that will use the specified consumer's view list to retrieve the individual\r\n items. }\r\n TJvConsumerStrings = class(TStrings)\r\n private\r\n FConsumer: TJvDataConsumer;\r\n protected\r\n function Get(Index: Integer): string; override;\r\n function GetCount: Integer; override;\r\n property Consumer: TJvDataConsumer read FConsumer;\r\n public\r\n constructor Create(AConsumer: TJvDataConsumer);\r\n procedure Clear; override;\r\n procedure Delete(Index: Integer); override;\r\n procedure Insert(Index: Integer; const S: string); override;\r\n end;\r\n\r\n// Helper routines\r\n{ Locate nearest IJvDataItems* implementation for a specific item. }\r\nfunction DP_FindItemsIntf(AItem: IJvDataItem; IID: TGUID; out Obj): Boolean;\r\n{ Locate nearest IJvDataItemsRenderer implementation for a specific item. }\r\nfunction DP_FindItemsRenderer(AItem: IJvDataItem; out Renderer: IJvDataItemsRenderer): Boolean;\r\n{ Locate nearest IJvDataItemsImages implementation for a specific item. }\r\nfunction DP_FindItemsImages(AItem: IJvDataItem; out Images: IJvDataItemsImages): Boolean;\r\n{ Generate items list to emulate trees in a flat list control }\r\nprocedure DP_GenItemsList(RootList: IJvDataItems; ItemList: TStrings);\r\n{ Convert TOwnerDrawState to TProviderDrawStates }\r\nfunction DP_OwnerDrawStateToProviderDrawState(State: TOwnerDrawState): TProviderDrawStates;\r\n{ Atomically select a consumer/context pair, pushing the current consumer/context onto their\r\n internal stacks. }\r\nprocedure DP_SelectConsumerContext(Provider: IJvDataProvider; Consumer: IJvDataConsumer; Context: IJvDataContext);\r\n{ Atomically release a consumer/context pair, reinstating the prior pair on the respective stacks. }\r\nprocedure DP_ReleaseConsumerContext(Provider: IJvDataProvider);\r\n{ Retrieve the specified context's name path. }\r\nfunction GetContextPath(Context: IJvDataContext): string;\r\n{ Retrieve the specified item's ID path. The path is based on the currently active context. }\r\nfunction GetItemIDPath(Item: IJvDataItem): string;\r\n{ Retrieve the specified item's index path. The path is based on the currently active context. }\r\nfunction GetItemIndexPath(Item: IJvDataItem): TDynIntegerArray;\r\n{ Determine a unique context name for the given prefix in the given context list. }\r\nfunction GetUniqueCtxName(Contexts: IJvDataContexts; Prefix: string): string;\r\n{ Determine checked state for an item, combining both consumer and provider info. }\r\nfunction GetItemCheckedState(Item: IJvDataItem): TDataItemState;\r\n{ Determine enabled state for an item, combining both consumer and provider info. }\r\nfunction GetItemEnabledState(Item: IJvDataItem): TDataItemState;\r\n{ Determine visible state for an item, combining both consumer and provider info. }\r\nfunction GetItemVisibleState(Item: IJvDataItem): TDataItemState;\r\n\r\n// Rename and move to JvFunctions? Converts a buffer into a string of hex digits.\r\nfunction HexBytes(const Buf; Length: Integer): string;\r\n// Move to other unit? Render text in a disabled way (much like TLabel does)\r\nprocedure DisabledTextRect(ACanvas: TCanvas; var ARect: TRect; Left, Top: Integer; Text: string);\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvDataProvider.pas $';\r\n Revision: '$Revision: 13415 $';\r\n Date: '$Date: 2012-09-10 11:51:54 +0200 (lun. 10 sept. 2012) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n {$IFDEF MSWINDOWS}\r\n ActiveX,\r\n {$ENDIF MSWINDOWS}\r\n Types, SysUtils, TypInfo, RTLConsts,\r\n JclStrings,\r\n JvTypes, JvConsts, JvResources, JvJCLUtils;\r\n\r\nconst\r\n vifHasChildren = Integer($80000000);\r\n vifCanHaveChildren = Integer($40000000);\r\n vifExpanded = Integer($20000000);\r\n\r\n cClassName = 'ClassName';\r\n cName = 'Name';\r\n cProvider = 'Provider';\r\n\r\nfunction HexBytes(const Buf; Length: Integer): string;\r\nvar\r\n P: PChar;\r\nbegin\r\n Result := '';\r\n P := @Buf;\r\n while Length > 1 do\r\n begin\r\n Result := Result + IntToHex(Ord(P^), 2);\r\n Inc(P);\r\n Dec(Length);\r\n end;\r\nend;\r\n\r\n//TODO: Copied from JvLabel.pas to avoid dependency. Must move to another unit.\r\n\r\ntype\r\n TShadowPosition = (spLeftTop, spLeftBottom, spRightBottom, spRightTop);\r\n\r\nfunction DrawShadowText(DC: HDC; Str: PChar; Count: Integer; var Rect: TRect;\r\n Format: Word; ShadowSize: Byte; ShadowColor: TColorRef;\r\n ShadowPos: TShadowPosition): Integer;\r\nvar\r\n RText, RShadow: TRect;\r\n Color: TColorRef;\r\n OldBkMode: Integer;\r\nbegin\r\n RText := Rect;\r\n RShadow := Rect;\r\n Color := SetTextColor(DC, ShadowColor);\r\n case ShadowPos of\r\n spLeftTop:\r\n OffsetRect(RShadow, -ShadowSize, -ShadowSize);\r\n spRightBottom:\r\n OffsetRect(RShadow, ShadowSize, ShadowSize);\r\n spLeftBottom:\r\n begin\r\n {OffsetRect(RText, ShadowSize, 0);}\r\n OffsetRect(RShadow, -ShadowSize, ShadowSize);\r\n end;\r\n spRightTop:\r\n begin\r\n {OffsetRect(RText, 0, ShadowSize);}\r\n OffsetRect(RShadow, ShadowSize, -ShadowSize);\r\n end;\r\n end;\r\n Result := DrawText(DC, Str, Count, RShadow, Format);\r\n if Result > 0 then\r\n Inc(Result, ShadowSize);\r\n SetTextColor(DC, Color);\r\n OldBkMode := SetBkMode(DC, TRANSPARENT);\r\n try\r\n DrawText(DC, Str, Count, RText, Format);\r\n finally\r\n SetBkMode(DC, OldBkMode);\r\n end;\r\n UnionRect(Rect, RText, RShadow);\r\nend;\r\n\r\nprocedure DisabledTextRect(ACanvas: TCanvas; var ARect: TRect; Left, Top: Integer; Text: string);\r\nbegin\r\n ACanvas.Font.Color := clGrayText;\r\n DrawShadowText(ACanvas.Handle, PChar(Text), Length(Text), ARect, 0, 1, ColorToRGB(clBtnHighlight),\r\n spRightBottom);\r\nend;\r\n\r\nprocedure AddItemsToList(AItems: IJvDataItems; ItemList: TStrings; Level: Integer);\r\nvar\r\n I: Integer;\r\n ThisItem: IJvDataItem;\r\n SubItems: IJvDataItems;\r\nbegin\r\n for I := 0 to AItems.Count - 1 do\r\n begin\r\n ThisItem := AItems.Items[I];\r\n ItemList.AddObject(ThisItem.GetID, TObject(Level));\r\n if Supports(ThisItem, IJvDataItems, SubItems) then\r\n AddItemsToList(SubItems, ItemList, Level + 1);\r\n end;\r\nend;\r\n\r\nfunction DP_FindItemsIntf(AItem: IJvDataItem; IID: TGUID; out Obj): Boolean;\r\nbegin\r\n while (AItem <> nil) and not Supports(AItem.GetItems, IID, Obj) do\r\n AItem := AItem.GetItems.Parent;\r\n Result := AItem <> nil;\r\nend;\r\n\r\nfunction DP_FindItemsRenderer(AItem: IJvDataItem; out Renderer: IJvDataItemsRenderer): Boolean;\r\nbegin\r\n Result := DP_FindItemsIntf(AItem, IJvDataItemsRenderer, Renderer);\r\nend;\r\n\r\nfunction DP_FindItemsImages(AItem: IJvDataItem; out Images: IJvDataItemsImages): Boolean;\r\nbegin\r\n Result := DP_FindItemsIntf(AItem, IJvDataItemsImages, Images);\r\nend;\r\n\r\nprocedure DP_GenItemsList(RootList: IJvDataItems; ItemList: TStrings);\r\nbegin\r\n ItemList.Clear;\r\n AddItemsToList(RootList, ItemList, 0);\r\nend;\r\n\r\nfunction DP_OwnerDrawStateToProviderDrawState(State: TOwnerDrawState): TProviderDrawStates;\r\nbegin\r\n Move(State, Result, SizeOf(State));\r\nend;\r\n\r\nprocedure DP_SelectConsumerContext(Provider: IJvDataProvider; Consumer: IJvDataConsumer; Context: IJvDataContext);\r\nbegin\r\n Provider.SelectConsumer(Consumer);\r\n try\r\n Provider.SelectContext(Context);\r\n except\r\n Provider.ReleaseConsumer;\r\n raise;\r\n end;\r\nend;\r\n\r\nprocedure DP_ReleaseConsumerContext(Provider: IJvDataProvider);\r\nvar\r\n CurConsumer: IJvDataConsumer;\r\nbegin\r\n CurConsumer := Provider.SelectedConsumer;\r\n Provider.ReleaseConsumer;\r\n try\r\n Provider.ReleaseContext;\r\n except\r\n Provider.SelectConsumer(CurConsumer);\r\n raise;\r\n end;\r\nend;\r\n\r\nfunction IsExtensionSpecificIntf(IID: TGUID): Boolean;\r\nbegin\r\n Result := IsEqualGuid(IID, IJvDataContextSensitive);\r\nend;\r\n\r\nfunction GetContextPath(Context: IJvDataContext): string;\r\nbegin\r\n if Context <> nil then\r\n begin\r\n Result := Context.Name;\r\n while Context <> nil do\r\n begin\r\n Context := Context.Contexts.Ancestor;\r\n if Context <> nil then\r\n Result := Context.Name + '\\' + Result;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction GetItemIDPath(Item: IJvDataItem): string;\r\nbegin\r\n if Item <> nil then\r\n begin\r\n Result := Item.GetID;\r\n while Item <> nil do\r\n begin\r\n Item := Item.Items.Parent;\r\n if Item <> nil then\r\n Result := Item.GetID + '\\' + Result;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure InsertIntArray(var Arr: TDynIntegerArray; Index: Integer; Item: Integer);\r\nbegin\r\n SetLength(Arr, Length(Arr) + 1);\r\n if Index < High(Arr) then\r\n Move(Arr[Index], Arr[Index + 1], (High(Arr) - Index) * SizeOf(Integer));\r\n Arr[Index] := Item;\r\nend;\r\n\r\nfunction GetItemIndexPath(Item: IJvDataItem): TDynIntegerArray;\r\nbegin\r\n if Item <> nil then\r\n begin\r\n SetLength(Result, 1);\r\n Result[0] := Item.GetIndex;\r\n while Item <> nil do\r\n begin\r\n Item := Item.Items.Parent;\r\n if Item <> nil then\r\n InsertIntArray(Result, 0, Item.GetIndex);\r\n end;\r\n end\r\n else\r\n SetLength(Result, 0);\r\nend;\r\n\r\nfunction GetUniqueCtxName(Contexts: IJvDataContexts; Prefix: string): string;\r\nvar\r\n PrefixLen: Integer;\r\n SuffixNum: Int64;\r\n CtxIdx: Integer;\r\n TmpNum: Int64;\r\nbegin\r\n PrefixLen := Length(Prefix);\r\n SuffixNum := 1;\r\n for CtxIdx := 0 to Contexts.GetCount - 1 do\r\n if AnsiSameStr(Prefix, Copy(Contexts.GetContext(CtxIdx).Name, 1, PrefixLen)) then\r\n with Contexts.GetContext(CtxIdx) do\r\n begin\r\n if StrIsSubset(Copy(Name, PrefixLen + 1, Length(Name) - PrefixLen), CharIsDigit) then\r\n begin\r\n TmpNum := StrToInt64(Copy(Name, PrefixLen + 1, Length(Name) - PrefixLen));\r\n if TmpNum >= SuffixNum then\r\n SuffixNum := TmpNum + 1;\r\n end;\r\n end;\r\n Result := Prefix + IntToStr(SuffixNum);\r\nend;\r\n\r\nfunction GetItemCheckedState(Item: IJvDataItem): TDataItemState;\r\nvar\r\n Provider: IJvDataProvider;\r\n ConsState: IJvDataConsumerItemState;\r\n ItemState: IJvDataItemStates;\r\nbegin\r\n Result := disNotUsed;\r\n if Item <> nil then\r\n begin\r\n Provider := Item.Items.Provider;\r\n if Supports(Provider.SelectedConsumer, IJvDataConsumerItemState, ConsState) then\r\n Result := ConsState.Checked(Item);\r\n if (Result = disNotUsed) and Supports(Item, IJvDataItemStates, ItemState) then\r\n Result := ItemState.Checked;\r\n end;\r\nend;\r\n\r\nfunction GetItemEnabledState(Item: IJvDataItem): TDataItemState;\r\nvar\r\n Provider: IJvDataProvider;\r\n ConsState: IJvDataConsumerItemState;\r\n ItemState: IJvDataItemStates;\r\nbegin\r\n Result := disNotUsed;\r\n if Item <> nil then\r\n begin\r\n Provider := Item.Items.Provider;\r\n if Supports(Provider.SelectedConsumer, IJvDataConsumerItemState, ConsState) then\r\n Result := ConsState.Enabled(Item);\r\n if (Result <> disFalse) and Supports(Item, IJvDataItemStates, ItemState) then\r\n Result := ItemState.Enabled;\r\n end;\r\nend;\r\n\r\nfunction GetItemVisibleState(Item: IJvDataItem): TDataItemState;\r\nvar\r\n Provider: IJvDataProvider;\r\n ConsState: IJvDataConsumerItemState;\r\n ItemState: IJvDataItemStates;\r\nbegin\r\n Result := disNotUsed;\r\n if Item <> nil then\r\n begin\r\n Provider := Item.Items.Provider;\r\n if Supports(Provider.SelectedConsumer, IJvDataConsumerItemState, ConsState) then\r\n Result := ConsState.Visible(Item);\r\n if (Result in [disIndetermined, disNotUsed]) and Supports(Item, IJvDataItemStates,\r\n ItemState) then\r\n Result := ItemState.Visible;\r\n end;\r\nend;\r\n\r\n//=== { TJvDP_ProviderBaseRender } ===========================================\r\n\r\nconstructor TJvDP_ProviderBaseRender.Create(AItem: IJvDataItem; ACanvas: TCanvas; AState: TProviderDrawStates);\r\nbegin\r\n inherited Create;\r\n FItem := AItem;\r\n FCanvas := ACanvas;\r\n FState := AState;\r\nend;\r\n\r\nclass procedure TJvDP_ProviderBaseRender.Draw(AItem: IJvDataItem; ACanvas: TCanvas; var ARect: TRect; AState: TProviderDrawStates);\r\nbegin\r\n with Self.Create(AItem, ACanvas, AState) do\r\n try\r\n Rect := ARect;\r\n Prepare(False);\r\n DoDraw;\r\n finally\r\n Free;\r\n end;\r\nend;\r\n\r\nclass function TJvDP_ProviderBaseRender.Measure(AItem: IJvDataItem; ACanvas: TCanvas; AState: TProviderDrawStates): TSize;\r\nbegin\r\n with Self.Create(AItem, ACanvas, AState) do\r\n try\r\n Prepare(True);\r\n Result := DoMeasure;\r\n finally\r\n Free;\r\n end;\r\nend;\r\n\r\n//=== { TJvDP_ProviderTextOnlyRender } =======================================\r\n\r\nprocedure TJvDP_ProviderTextOnlyRender.Prepare(ForMeasure: Boolean);\r\nvar\r\n TextIntf: IJvDataItemText;\r\nbegin\r\n HasNoText := not Supports(Item, IJvDataItemText, TextIntf);\r\n if HasNoText then\r\n FText := RsDataItemRenderHasNoText\r\n else\r\n FText := TextIntf.Text;\r\nend;\r\n\r\nprocedure TJvDP_ProviderTextOnlyRender.DoDraw;\r\nbegin\r\n Canvas.TextRect(Rect, Rect.Left, Rect.Top, FText);\r\nend;\r\n\r\nfunction TJvDP_ProviderTextOnlyRender.DoMeasure: TSize;\r\nbegin\r\n Result := Canvas.TextExtent(FText);\r\nend;\r\n\r\n//=== { TJvDP_ProviderImgAndTextRender } =====================================\r\n\r\nprocedure TJvDP_ProviderImgAndTextRender.Prepare(ForMeasure: Boolean);\r\nvar\r\n ImgIntf: IJvDataItemImage;\r\n ImgsIntf: IJvDataItemsImages;\r\nbegin\r\n inherited Prepare(ForMeasure);\r\n FImageIndex := -1;\r\n FImages := nil;\r\n if Supports(Item, IJvDataItemImage, ImgIntf) then\r\n begin\r\n FAlignment := ImgIntf.Alignment;\r\n if DP_FindItemsImages(Item, ImgsIntf) then\r\n begin\r\n { We have an item that supports an image and one of it's parents has an imagelist assigned. }\r\n if (pdsDisabled in State) and (ImgsIntf.DisabledImages <> nil) then\r\n begin\r\n FImages := ImgsIntf.DisabledImages;\r\n FHasDisabledImage := True;\r\n end\r\n else\r\n begin\r\n FHasDisabledImage := False;\r\n if (pdsHot in State) and (ImgsIntf.HotImages <> nil) then\r\n FImages := ImgsIntf.HotImages\r\n else\r\n FImages := ImgsIntf.Images;\r\n end;\r\n if (pdsSelected in State) and (ImgIntf.SelectedIndex <> -1) then\r\n FImageIndex := ImgIntf.SelectedIndex\r\n else\r\n begin\r\n FImageIndex := ImgIntf.ImageIndex;\r\n if FImageIndex < 0 then\r\n FImageIndex := ImgIntf.SelectedIndex;\r\n end;\r\n end;\r\n end;\r\n FHasImage := (FImages <> nil) and (FImageIndex > -1);\r\n if HasImage and HasNoText then\r\n Text := '';\r\nend;\r\n\r\nprocedure TJvDP_ProviderImgAndTextRender.DoDraw;\r\nvar\r\n rgn: HRGN;\r\n iSaveDC: Integer;\r\n TxtW: Integer;\r\nbegin\r\n rgn := CreateRectRgn(0,0,0,0);\r\n GetClipRgn(Canvas.Handle, rgn);\r\n try\r\n IntersectClipRect(Canvas.Handle, Rect.Left, Rect.Top, Rect.Right, Rect.Bottom);\r\n if HasImage then\r\n begin\r\n iSaveDC := SaveDC(Canvas.Handle);\r\n try\r\n // Apply alignment rules and render the image\r\n case Alignment of\r\n taLeftJustify:\r\n begin\r\n Images.Draw(Canvas, Rect.Left, Rect.Top, ImageIndex,\r\n HasDisabledImage or not (pdsDisabled in State));\r\n Rect.Left := Rect.Left + Images.Width + 2;\r\n end;\r\n taRightJustify:\r\n begin\r\n Images.Draw(Canvas, Rect.Right - Images.Width, Rect.Top, ImageIndex,\r\n HasDisabledImage or not (pdsDisabled in State));\r\n Rect.Right := Rect.Right - Images.Width - 2;\r\n end;\r\n taCenter:\r\n begin\r\n Images.Draw(Canvas, Rect.Left + ((Rect.Right - Rect.Left - Images.Width) div 2),\r\n Rect.Top, ImageIndex, HasDisabledImage or not (pdsDisabled in State));\r\n Rect.Top := Rect.Top + Images.Height + 2;\r\n TxtW := Canvas.TextWidth(Text);\r\n Rect.Left := Rect.Left + ((Rect.Right - Rect.Left - TxtW) div 2);\r\n end;\r\n end;\r\n finally\r\n if iSaveDC <> 0 then\r\n RestoreDC(Canvas.Handle, iSaveDC);\r\n end;\r\n end;\r\n if pdsGrayed in State then\r\n Canvas.Font.Color := clGrayText;\r\n if (pdsDisabled in State) and not (pdsGrayed in State) then\r\n DisabledTextRect(Canvas, Rect, Rect.Left, Rect.Top, Text)\r\n else\r\n Canvas.TextRect(Rect, Rect.Left, Rect.Top, Text);\r\n finally\r\n SelectClipRgn(Canvas.Handle, rgn);\r\n DeleteObject(rgn);\r\n end;\r\nend;\r\n\r\nfunction TJvDP_ProviderImgAndTextRender.DoMeasure: TSize;\r\nbegin\r\n if HasImage then\r\n begin\r\n // Apply alignment rules and render the image\r\n case Alignment of\r\n taLeftJustify,\r\n taRightJustify:\r\n begin\r\n Result := Canvas.TextExtent(Text);\r\n Inc(Result.cx, Images.Width + 2);\r\n if Images.Height > Result.cy then\r\n Result.cy := Images.Height;\r\n end;\r\n taCenter:\r\n begin\r\n Result := Canvas.TextExtent(Text);\r\n Inc(Result.cy, Images.Height + 2);\r\n if Images.Width > Result.cx then\r\n Result.cx := Images.Width;\r\n end;\r\n end;\r\n end\r\n else\r\n Result := inherited DoMeasure;\r\nend;\r\n\r\ntype\r\n TReaderAccessProtected = class(TReader);\r\n\r\n {$TYPEINFO ON}\r\n THackWriter = class(TWriter)\r\n // (rom) public or protected missing\r\n function GetPropPath: string;\r\n function PropPathField: PString;\r\n procedure SetPropPath(const NewPath: string);\r\n property PropPath: string read GetPropPath write SetPropPath;\r\n published\r\n property RootAncestor;\r\n end;\r\n {$IFNDEF TYPEINFO_ON}\r\n {$TYPEINFO OFF}\r\n {$ENDIF !TYPEINFO_ON}\r\n\r\nfunction THackWriter.GetPropPath: string;\r\nbegin\r\n Result := PropPathField^;\r\nend;\r\n\r\nfunction THackWriter.PropPathField: PString;\r\nvar\r\n RAPI: PPropInfo;\r\nbegin\r\n RAPI := GetPropInfo(THackWriter, 'RootAncestor');\r\n if RAPI = nil then // Should never happen\r\n raise EJVCLException.CreateRes(@RsEInternalError);\r\n Result := Pointer(Cardinal(RAPI.GetProc) and $00FFFFFF + Cardinal(Self) + 4);\r\nend;\r\n\r\nprocedure THackWriter.SetPropPath(const NewPath: string);\r\nbegin\r\n if NewPath <> PropPath then\r\n PropPathField^ := NewPath;\r\nend;\r\n\r\n//=== { TJvDataItemAggregatedObject } ========================================\r\n\r\nfunction TJvDataItemAggregatedObject.QueryInterface(const IID: TGUID; out Obj): HRESULT;\r\nconst\r\n E_NOINTERFACE = HRESULT($80004002);\r\nbegin\r\n if not GetInterface(IID, Obj) then\r\n begin\r\n if IsExtensionSpecificIntf(IID) then\r\n Result := E_NOINTERFACE\r\n else\r\n Result := inherited QueryInterface(IID, Obj);\r\n end\r\n else\r\n Result := S_OK;\r\nend;\r\n\r\nprocedure TJvDataItemAggregatedObject.ContextDestroying(Context: IJvDataContext);\r\nbegin\r\nend;\r\n\r\nfunction TJvDataItemAggregatedObject.Item: IJvDataItem;\r\nbegin\r\n Result := Owner as IJvDataItem;\r\nend;\r\n\r\nfunction TJvDataItemAggregatedObject.ItemImpl: TJvBaseDataItem;\r\nbegin\r\n Result := Owner as TJvBaseDataItem;\r\nend;\r\n\r\n//=== { TJvCustomDataItemsTextRenderer } =====================================\r\n\r\nprocedure TJvCustomDataItemsTextRenderer.DoDrawItem(ACanvas: TCanvas; var ARect: TRect;\r\n Item: IJvDataItem; State: TProviderDrawStates);\r\nbegin\r\n TJvDP_ProviderTextOnlyRender.Draw(Item, ACanvas, ARect, State);\r\nend;\r\n\r\nfunction TJvCustomDataItemsTextRenderer.DoMeasureItem(ACanvas: TCanvas; Item: IJvDataItem): TSize;\r\nbegin\r\n Result := TJvDP_ProviderTextOnlyRender.Measure(Item, ACanvas, []);\r\nend;\r\n\r\nfunction TJvCustomDataItemsTextRenderer.AvgItemSize(ACanvas: TCanvas): TSize;\r\nbegin\r\n Result := ACanvas.TextExtent('WyWyWyWyWyWyWyWyWyWy');\r\nend;\r\n\r\n//=== { TJvCustomDataItemsRenderer } =========================================\r\n\r\nprocedure TJvCustomDataItemsRenderer.DoDrawItem(ACanvas: TCanvas; var ARect: TRect;\r\n Item: IJvDataItem; State: TProviderDrawStates);\r\nbegin\r\n TJvDP_ProviderImgAndTextRender.Draw(Item, ACanvas, ARect, State);\r\nend;\r\n\r\nfunction TJvCustomDataItemsRenderer.DoMeasureItem(ACanvas: TCanvas; Item: IJvDataItem): TSize;\r\nbegin\r\n Result := TJvDP_ProviderImgAndTextRender.Measure(Item, ACanvas, []);\r\nend;\r\n\r\nfunction TJvCustomDataItemsRenderer.AvgItemSize(ACanvas: TCanvas): TSize;\r\nbegin\r\n Result := ACanvas.TextExtent('WyWyWyWyWyWyWyWyWyWy');\r\nend;\r\n\r\n//=== { TJvDataItemTextImpl } ================================================\r\n\r\nfunction TJvDataItemTextImpl.GetText: string;\r\nbegin\r\n Result := FText;\r\nend;\r\n\r\nfunction TJvDataItemTextImpl.Editable: Boolean;\r\nbegin\r\n Result := True;\r\nend;\r\n\r\nprocedure TJvDataItemTextImpl.SetText(const Value: string);\r\nbegin\r\n if Text <> Value then\r\n begin\r\n Item.GetItems.Provider.Changing(pcrUpdateItem, Item);\r\n FText := Value;\r\n Item.GetItems.Provider.Changed(pcrUpdateItem, Item);\r\n end;\r\nend;\r\n\r\n//=== { TJvDataItemContextTextImpl } =========================================\r\n\r\nconstructor TJvDataItemContextTextImpl.Create(AOwner: TExtensibleInterfacedPersistent);\r\nbegin\r\n inherited Create(AOwner);\r\n FContextStrings := TStringList.Create;\r\nend;\r\n\r\ndestructor TJvDataItemContextTextImpl.Destroy;\r\nbegin\r\n FreeAndNil(FContextStrings);\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJvDataItemContextTextImpl.GetText: string;\r\nvar\r\n CurCtx: IJvDataContext;\r\nbegin\r\n CurCtx := Item.GetItems.Provider.SelectedContext;\r\n while (CurCtx <> nil) and (FContextStrings.IndexOfObject(TObject(CurCtx)) = -1) do\r\n CurCtx := CurCtx.Contexts.Ancestor;\r\n if (CurCtx <> nil) and (FContextStrings.IndexOfObject(TObject(CurCtx)) > -1) then\r\n Result := FContextStrings[FContextStrings.IndexOfObject(TObject(CurCtx))]\r\n else\r\n Result := inherited GetText;\r\nend;\r\n\r\nfunction TJvDataItemContextTextImpl.Editable: Boolean;\r\nbegin\r\n Result := True;\r\nend;\r\n\r\nprocedure TJvDataItemContextTextImpl.SetText(const Value: string);\r\nvar\r\n CurCtx: IJvDataContext;\r\n I: Integer;\r\nbegin\r\n CurCtx := Item.GetItems.Provider.SelectedContext;\r\n if CurCtx <> nil then\r\n begin\r\n if Text <> Value then\r\n begin\r\n Item.GetItems.Provider.Changing(pcrUpdateItem, Item);\r\n I := FContextStrings.IndexOfObject(TObject(CurCtx));\r\n if I > -1 then\r\n FContextStrings[I] := Value\r\n else\r\n FContextStrings.AddObject(Value, TObject(CurCtx));\r\n Item.GetItems.Provider.Changed(pcrUpdateItem, Item);\r\n end;\r\n end\r\n else\r\n inherited SetText(Value);\r\nend;\r\n\r\nprocedure TJvDataItemContextTextImpl.RevertToAncestor;\r\nvar\r\n CurCtx: IJvDataContext;\r\n I: Integer;\r\nbegin\r\n CurCtx := Item.GetItems.Provider.SelectedContext;\r\n if CurCtx <> nil then\r\n begin\r\n I := FContextStrings.IndexOfObject(TObject(CurCtx));\r\n if I > -1 then\r\n begin\r\n Item.GetItems.Provider.Changing(pcrUpdateItem, Item);\r\n FContextStrings.Delete(I);\r\n Item.GetItems.Provider.Changed(pcrUpdateItem, Item);\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJvDataItemContextTextImpl.IsEqualToAncestor: Boolean;\r\nvar\r\n CurCtx: IJvDataContext;\r\nbegin\r\n CurCtx := Item.GetItems.Provider.SelectedContext;\r\n Result := FContextStrings.IndexOfObject(TObject(CurCtx)) = -1;\r\nend;\r\n\r\n//=== { TJvDataItemBlockableTextImpl } ========================================\r\n\r\nfunction TJvDataItemBlockableTextImpl.Editable: Boolean;\r\nbegin\r\n Result := not FReadOnly;\r\nend;\r\n\r\nprocedure TJvDataItemBlockableTextImpl.SetReadOnly(Value: Boolean);\r\nbegin\r\n if ReadOnly <> Value then\r\n begin\r\n Item.Items.Provider.Changing(pcrUpdateItem, Item);\r\n FReadOnly := Value;\r\n Item.Items.Provider.Changed(pcrUpdateItem, Item);\r\n end;\r\nend;\r\n\r\n//=== { TJvDataItemImageImpl } ===============================================\r\n\r\nfunction TJvDataItemImageImpl.GetAlignment: TAlignment;\r\nbegin\r\n Result := FAlignment;\r\nend;\r\n\r\nprocedure TJvDataItemImageImpl.SetAlignment(Value: TAlignment);\r\nbegin\r\n if GetAlignment <> Value then\r\n begin\r\n Item.GetItems.Provider.Changing(pcrUpdateItem, Item);\r\n FAlignment := Value;\r\n Item.GetItems.Provider.Changed(pcrUpdateItem, Item);\r\n end;\r\nend;\r\n\r\nfunction TJvDataItemImageImpl.GetImageIndex: Integer;\r\nbegin\r\n Result := FImageIndex;\r\nend;\r\n\r\nprocedure TJvDataItemImageImpl.SetImageIndex(Index: Integer);\r\nbegin\r\n if GetImageIndex <> Index then\r\n begin\r\n Item.GetItems.Provider.Changing(pcrUpdateItem, Item);\r\n FImageIndex := Index;\r\n Item.GetItems.Provider.Changed(pcrUpdateItem, Item);\r\n end;\r\nend;\r\n\r\nfunction TJvDataItemImageImpl.GetSelectedIndex: Integer;\r\nbegin\r\n Result := FSelectedIndex;\r\nend;\r\n\r\nprocedure TJvDataItemImageImpl.SetSelectedIndex(Value: Integer);\r\nbegin\r\n if GetSelectedIndex <> Value then\r\n begin\r\n Item.GetItems.Provider.Changing(pcrUpdateItem, Item);\r\n FSelectedIndex := Value;\r\n Item.GetItems.Provider.Changed(pcrUpdateItem, Item);\r\n end;\r\nend;\r\n\r\n//=== { TExtensibleInterfacedPersistent } ====================================\r\n\r\nconstructor TExtensibleInterfacedPersistent.Create;\r\nbegin\r\n inherited Create;\r\n FAdditionalIntfImpl := TList.Create;\r\nend;\r\n\r\ndestructor TExtensibleInterfacedPersistent.Destroy;\r\nbegin\r\n ClearIntfImpl;\r\n FreeAndNil(FAdditionalIntfImpl);\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TExtensibleInterfacedPersistent.AfterConstruction;\r\nbegin\r\n inherited AfterConstruction;\r\n InitImplementers;\r\n // Release the constructor's implicit refcount\r\n InterlockedDecrement(FRefCount);\r\nend;\r\n\r\nprocedure TExtensibleInterfacedPersistent.BeforeDestruction;\r\nbegin\r\n if RefCount <> 0 then\r\n RunError(2);\r\n inherited BeforeDestruction;\r\nend;\r\n\r\nfunction TExtensibleInterfacedPersistent._AddRef: Integer;\r\nbegin\r\n Result := InterlockedIncrement(FRefCount);\r\nend;\r\n\r\nfunction TExtensibleInterfacedPersistent._Release: Integer;\r\nbegin\r\n Result := InterlockedDecrement(FRefCount);\r\n if Result = 0 then\r\n Destroy;\r\nend;\r\n\r\nfunction TExtensibleInterfacedPersistent.QueryInterface(const IID: TGUID; out Obj): HRESULT;\r\nconst\r\n E_NOINTERFACE = HRESULT($80004002);\r\nbegin\r\n if GetInterface(IID, Obj) then\r\n Result := S_OK\r\n else\r\n Result := E_NOINTERFACE;\r\nend;\r\n\r\nprocedure TExtensibleInterfacedPersistent.AddIntfImpl(const Obj: TAggregatedPersistentEx);\r\nbegin\r\n if IndexOfImplClass(TAggregatedPersistentExClass(Obj.ClassType)) >= 0 then\r\n raise EJVCLException.CreateRes(@RsEExtensibleIntObjDuplicateClass);\r\n FAdditionalIntfImpl.Add(Obj);\r\nend;\r\n\r\nprocedure TExtensibleInterfacedPersistent.RemoveIntfImpl(const Obj: TAggregatedPersistentEx);\r\nvar\r\n I: Integer;\r\nbegin\r\n I := FAdditionalIntfImpl.IndexOf(Obj);\r\n if I > -1 then\r\n begin\r\n FAdditionalIntfImpl[I] := nil;\r\n Obj.Free;\r\n FAdditionalIntfImpl.Delete(I);\r\n end;\r\nend;\r\n\r\nfunction TExtensibleInterfacedPersistent.ImplCount: Integer;\r\nbegin\r\n Result := FAdditionalIntfImpl.Count;\r\nend;\r\n\r\nfunction TExtensibleInterfacedPersistent.IndexOfImplClass(const AClass: TAggregatedPersistentExClass): Integer;\r\nbegin\r\n Result := FAdditionalIntfImpl.Count - 1;\r\n while (Result >= 0) and not (TObject(FAdditionalIntfImpl[Result]) is AClass) do\r\n Dec(Result);\r\nend;\r\n\r\nprocedure TExtensibleInterfacedPersistent.ClearIntfImpl;\r\nvar\r\n I: Integer;\r\n Obj: TObject;\r\nbegin\r\n for I := FAdditionalIntfImpl.Count - 1 downto 0 do\r\n begin\r\n Obj := TObject(FAdditionalIntfImpl[I]);\r\n FAdditionalIntfImpl[I] := nil;\r\n Obj.Free;\r\n FAdditionalIntfImpl.Delete(I);\r\n end;\r\n FAdditionalIntfImpl.Clear;\r\nend;\r\n\r\nprocedure TExtensibleInterfacedPersistent.InitImplementers;\r\nbegin\r\nend;\r\n\r\nprocedure TExtensibleInterfacedPersistent.SuspendRefCount;\r\nbegin\r\n InterlockedIncrement(FRefCount);\r\nend;\r\n\r\nprocedure TExtensibleInterfacedPersistent.ResumeRefCount;\r\nbegin\r\n InterlockedDecrement(FRefCount);\r\nend;\r\n\r\nfunction TExtensibleInterfacedPersistent.IsStreamableExtension(AnExtension: TAggregatedPersistentEx): Boolean;\r\nbegin\r\n Result := GetClass(AnExtension.ClassName) <> nil;\r\nend;\r\n\r\nprocedure TExtensibleInterfacedPersistent.DefineProperties(Filer: TFiler);\r\nvar\r\n I: Integer;\r\nbegin\r\n inherited DefineProperties(Filer);\r\n I := FAdditionalIntfImpl.Count - 1;\r\n while (I >= 0) and not IsStreamableExtension(TAggregatedPersistentEx(FAdditionalIntfImpl[I])) do\r\n Dec(I);\r\n Filer.DefineProperty('Extensions', ReadImplementers, WriteImplementers, I >= 0);\r\nend;\r\n\r\nprocedure TExtensibleInterfacedPersistent.ReadImplementers(Reader: TReader);\r\nbegin\r\n { When loading implementers the interface of this object may be referenced. We don't want the\r\n instance destroyed yet, so reference counting will be suspended (by incrementing it) and resumed\r\n when we're done (by decrementing it without checking if it became zero) }\r\n SuspendRefCount;\r\n try\r\n if Reader.ReadValue <> vaCollection then\r\n raise EReadError.CreateRes(@RsEExtensibleIntObjCollectionExpected);\r\n while not Reader.EndOfList do\r\n ReadImplementer(Reader);\r\n Reader.ReadListEnd;\r\n finally\r\n ResumeRefCount;\r\n end;\r\nend;\r\n\r\nprocedure TExtensibleInterfacedPersistent.WriteImplementers(Writer: TWriter);\r\nvar\r\n I: Integer;\r\n SavePropPath: string;\r\nbegin\r\n THackWriter(Writer).WriteValue(vaCollection);\r\n SavePropPath := THackWriter(Writer).PropPath;\r\n THackWriter(Writer).PropPath := '';\r\n try\r\n for I := 0 to FAdditionalIntfImpl.Count - 1 do\r\n if IsStreamableExtension(TAggregatedPersistentEx(FAdditionalIntfImpl[I])) then\r\n WriteImplementer(Writer, TAggregatedPersistentEx(FAdditionalIntfImpl[I]));\r\n Writer.WriteListEnd;\r\n finally\r\n THackWriter(Writer).PropPath := SavePropPath;\r\n end;\r\nend;\r\n\r\nprocedure TExtensibleInterfacedPersistent.ReadImplementer(Reader: TReader);\r\nvar\r\n ClassName: string;\r\n ClassType: TPersistentClass;\r\n I: Integer;\r\n Impl: TAggregatedPersistentEx;\r\nbegin\r\n Reader.ReadListBegin;\r\n ClassName := Reader.ReadStr;\r\n if not AnsiSameText(ClassName, cClassName) then\r\n raise EReadError.CreateRes(@RsEExtensibleIntObjClassNameExpected);\r\n ClassName := Reader.ReadString;\r\n ClassType := FindClass(ClassName);\r\n if not ClassType.InheritsFrom(TAggregatedPersistentEx) then\r\n raise EReadError.CreateRes(@RsEExtensibleIntObjInvalidClass);\r\n I := IndexOfImplClass(TAggregatedPersistentExClass(ClassType));\r\n if I >= 0 then\r\n Impl := TAggregatedPersistentEx(FAdditionalIntfImpl[I])\r\n else\r\n Impl := TAggregatedPersistentExClass(ClassType).Create(Self);\r\n while not Reader.EndOfList do\r\n TReaderAccessProtected(Reader).ReadProperty(Impl);\r\n Reader.ReadListEnd;\r\nend;\r\n\r\nprocedure TExtensibleInterfacedPersistent.WriteImplementer(Writer: TWriter;\r\n Instance: TAggregatedPersistentEx);\r\nbegin\r\n Writer.WriteListBegin;\r\n THackWriter(Writer).WritePropName(cClassName);\r\n Writer.WriteString(Instance.ClassName);\r\n THackWriter(Writer).WriteProperties(Instance);\r\n Writer.WriteListEnd;\r\nend;\r\n\r\nfunction TExtensibleInterfacedPersistent.GetImplementer(Index: Integer): TAggregatedPersistentEx;\r\nbegin\r\n Result := TAggregatedPersistentEx(FAdditionalIntfImpl[Index]);\r\nend;\r\n\r\nfunction TExtensibleInterfacedPersistent.GetImplOfClass(AClass: TAggregatedPersistentExClass): TAggregatedPersistentEx;\r\nvar\r\n idx: Integer;\r\nbegin\r\n idx := IndexOfImplClass(AClass);\r\n if idx >= 0 then\r\n Result := TAggregatedPersistentEx(FAdditionalIntfImpl[idx])\r\n else\r\n Result := nil;\r\nend;\r\n\r\nfunction TExtensibleInterfacedPersistent.GetInterface(const IID: TGUID; out Obj): Boolean;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := inherited GetInterface(IID, Obj);\r\n if not Result then\r\n begin\r\n I := FAdditionalIntfImpl.Count - 1;\r\n while (I >= 0) and ((FAdditionalIntfImpl[I] = nil) or TAggregatedPersistentEx(FAdditionalIntfImpl[I]).IsHidden or\r\n not TAggregatedPersistentEx(FAdditionalIntfImpl[I]).GetInterface(IID, Obj)) do\r\n Dec(I);\r\n Result := I >= 0;\r\n end;\r\nend;\r\n\r\nclass function TExtensibleInterfacedPersistent.NewInstance: TObject;\r\nbegin\r\n Result := inherited NewInstance;\r\n // set a refcount to avoid destruction due to refcounting during construction\r\n TExtensibleInterfacedPersistent(Result).FRefCount := 1;\r\nend;\r\n\r\n//=== { TAggregatedPersistent } ==============================================\r\n\r\nconstructor TAggregatedPersistent.Create(Controller: IUnknown);\r\nbegin\r\n inherited Create;\r\n FController := Pointer(Controller);\r\nend;\r\n\r\nfunction TAggregatedPersistent.GetController: IUnknown;\r\nbegin\r\n Result := IUnknown(FController);\r\nend;\r\n\r\nfunction TAggregatedPersistent.QueryInterface(const IID: TGUID; out Obj): HRESULT;\r\nbegin\r\n Result := Controller.QueryInterface(IID, Obj);\r\nend;\r\n\r\nfunction TAggregatedPersistent._AddRef: Integer;\r\nbegin\r\n Result := Controller._AddRef;\r\nend;\r\n\r\nfunction TAggregatedPersistent._Release: Integer;\r\nbegin\r\n Result := Controller._Release;\r\nend;\r\n\r\nfunction TAggregatedPersistent.GetInterface(const IID: TGUID; out Obj): Boolean;\r\nbegin\r\n Result := inherited GetInterface(IID, Obj);\r\nend;\r\n\r\n//=== { TAggregatedPersistentEx } ============================================\r\n\r\nconstructor TAggregatedPersistentEx.Create(AOwner: TExtensibleInterfacedPersistent);\r\nbegin\r\n inherited Create(AOwner);\r\n FOwner := AOwner;\r\nend;\r\n\r\nfunction TAggregatedPersistentEx.IsHidden: Boolean;\r\nbegin\r\n Result := False;\r\nend;\r\n\r\nprocedure TAggregatedPersistentEx.AfterConstruction;\r\nbegin\r\n inherited AfterConstruction;\r\n FOwner.AddIntfImpl(Self);\r\nend;\r\n\r\nprocedure TAggregatedPersistentEx.BeforeDestruction;\r\nvar\r\n I: Integer;\r\nbegin\r\n inherited BeforeDestruction;\r\n I := FOwner.FAdditionalIntfImpl.IndexOf(Self);\r\n if I >= 0 then\r\n FOwner.FAdditionalIntfImpl.Delete(I);\r\nend;\r\n\r\n//=== { TJvProviderNotification } ============================================\r\n\r\ndestructor TJvProviderNotification.Destroy;\r\nbegin\r\n Provider := nil;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvProviderNotification.SetProvider(Value: IJvDataProvider);\r\nbegin\r\n if Value <> Provider then\r\n begin\r\n if Provider <> nil then\r\n Provider.UnregisterChangeNotify(Self);\r\n FProvider := Value;\r\n if Provider <> nil then\r\n Provider.RegisterChangeNotify(Self);\r\n end;\r\nend;\r\n\r\nfunction TJvProviderNotification._AddRef: Integer;\r\nbegin\r\n Result := -1;\r\nend;\r\n\r\nfunction TJvProviderNotification._Release: Integer;\r\nbegin\r\n Result := -1;\r\nend;\r\n\r\nfunction TJvProviderNotification.QueryInterface(const IID: TGUID; out Obj): HRESULT;\r\nconst\r\n E_NOINTERFACE = HRESULT($80004002);\r\nbegin\r\n if GetInterface(IID, Obj) then\r\n Result := S_OK\r\n else\r\n Result := E_NOINTERFACE;\r\nend;\r\n\r\nprocedure TJvProviderNotification.DataProviderChanging(const ADataProvider: IJvDataProvider;\r\n AReason: TDataProviderChangeReason; Source: IUnknown);\r\nbegin\r\n if (AReason = pcrDestroy) and (Provider <> nil) then\r\n begin\r\n Provider.UnregisterChangeNotify(Self);\r\n FProvider := nil;\r\n end;\r\n if Assigned(FOnChanging) then\r\n FOnChanging(ADataProvider, AReason, Source);\r\nend;\r\n\r\nprocedure TJvProviderNotification.DataProviderChanged(const ADataProvider: IJvDataProvider;\r\n AReason: TDataProviderChangeReason; Source: IUnknown);\r\nbegin\r\n if Assigned(FOnChanged) then\r\n FOnChanged(ADataProvider, AReason, Source);\r\nend;\r\n\r\nfunction TJvProviderNotification.Consumer: IJvDataConsumer;\r\nbegin\r\n Result := nil;\r\nend;\r\n\r\n//=== { TJvBaseDataItems } ===================================================\r\n\r\nconstructor TJvBaseDataItems.Create;\r\nbegin\r\n inherited Create;\r\nend;\r\n\r\nconstructor TJvBaseDataItems.Create(const Provider: IJvDataProvider);\r\nbegin\r\n Create;\r\n FProvider := Provider;\r\nend;\r\n\r\nconstructor TJvBaseDataItems.Create(const Parent: IJvDataItem);\r\nbegin\r\n Create(Parent.GetItems.Provider);\r\n FParent := Pointer(Parent);\r\n if (Parent <> nil) and Parent.GetItems.IsDynamic then\r\n FParentIntf := Parent;\r\n if (Parent <> nil) and (Parent.GetImplementer is TExtensibleInterfacedPersistent) then\r\n FSubAggregate := TJvBaseDataItemSubItems.Create(\r\n TExtensibleInterfacedPersistent(Parent.GetImplementer), Self);\r\nend;\r\n\r\nprocedure TJvBaseDataItems.ItemAdd(Item: IJvDataItem);\r\nbegin\r\n GetProvider.Changing(pcrAdd, Self);\r\n InternalAdd(Item);\r\n GetProvider.Changed(pcrAdd, Item);\r\nend;\r\n\r\nprocedure TJvBaseDataItems.ItemDelete(Index: Integer);\r\nvar\r\n Item: IJvDataItem;\r\nbegin\r\n Item := GetItem(Index);\r\n if (Item <> nil) and (Item.IsDeletable) then\r\n begin\r\n GetProvider.Changing(pcrDelete, Item);\r\n Item := nil;\r\n InternalDelete(Index);\r\n GetProvider.Changed(pcrDelete, Self);\r\n end;\r\nend;\r\n\r\nprocedure TJvBaseDataItems.ItemMove(OldIndex, NewIndex: Integer);\r\nbegin\r\n if OldIndex <> NewIndex then\r\n begin\r\n if (NewIndex <= GetCount) and (NewIndex >= 0) then\r\n begin\r\n if GetProvider.SelectedContext <> nil then\r\n begin\r\n GetProvider.Changing(pcrUpdateItems, Self);\r\n InternalMove(OldIndex, NewIndex);\r\n GetProvider.Changed(pcrUpdateItems, Self);\r\n end\r\n else\r\n raise EJVCLDataItems.CreateRes(@RsEItemsMayNotBeMovedInTheMainTree);\r\n end\r\n else\r\n raise EJVCLDataItems.CreateRes(@RsEInvalidIndex);\r\n end;\r\nend;\r\n\r\nfunction TJvBaseDataItems.IsStreamableItem(Item: IJvDataItem): Boolean;\r\nvar\r\n AClass: TPersistentClass;\r\nbegin\r\n AClass := GetClass(Item.GetImplementer.ClassName);\r\n Result := (AClass <> nil) and AClass.InheritsFrom(TJvBaseDataItem);\r\nend;\r\n\r\nfunction TJvBaseDataItems.ScanForID(Items: IJvDataItems; ID: string; Recursive: Boolean): IJvDataItem;\r\nvar\r\n I: Integer;\r\n SubItems: IJvDataItems;\r\nbegin\r\n if (Items <> nil) then\r\n begin\r\n Result := Items.GetItemByID(ID);\r\n if (Result = nil) and Recursive then\r\n begin\r\n I := Items.GetCount - 1;\r\n while (I >= 0) and (Result = nil) do\r\n begin\r\n if Supports(Items.GetItem(I), IJvDataItems, SubItems) then\r\n Result := ScanForID(SubItems, ID, True);\r\n Dec(I);\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvBaseDataItems.DefineProperties(Filer: TFiler);\r\nbegin\r\n inherited DefineProperties(Filer);\r\n Filer.DefineProperty('Items', ReadItems, WriteItems, True);\r\nend;\r\n\r\nprocedure TJvBaseDataItems.ReadItems(Reader: TReader);\r\nbegin\r\n if Reader.ReadValue <> vaCollection then\r\n raise EReadError.CreateRes(@RsEExtensibleIntObjCollectionExpected);\r\n while not Reader.EndOfList do\r\n ReadItem(Reader);\r\n Reader.ReadListEnd;\r\nend;\r\n\r\nprocedure TJvBaseDataItems.WriteItems(Writer: TWriter);\r\nvar\r\n I: Integer;\r\n SavePropPath: string;\r\nbegin\r\n THackWriter(Writer).WriteValue(vaCollection);\r\n SavePropPath := THackWriter(Writer).PropPath;\r\n THackWriter(Writer).PropPath := '';\r\n try\r\n for I := 0 to GetCount - 1 do\r\n begin\r\n if IsStreamableItem(GetItem(I)) then\r\n WriteItem(Writer, GetItem(I));\r\n end;\r\n Writer.WriteListEnd;\r\n finally\r\n THackWriter(Writer).PropPath := SavePropPath;\r\n end;\r\nend;\r\n\r\nprocedure TJvBaseDataItems.ReadItem(Reader: TReader);\r\nvar\r\n PropName: string;\r\n ClassName: string;\r\n PerstClass: TPersistentClass;\r\n ItemClass: TJvBaseDataItemClass;\r\n ItemInstance: TJvBaseDataItem;\r\nbegin\r\n Reader.ReadListBegin;\r\n PropName := Reader.ReadStr;\r\n if not AnsiSameText(PropName, cClassName) then\r\n raise EReadError.CreateRes(@RsEExtensibleIntObjClassNameExpected);\r\n ClassName := Reader.ReadString;\r\n PerstClass := FindClass(ClassName);\r\n if not PerstClass.InheritsFrom(TJvBaseDataItem) then\r\n raise EReadError.CreateRes(@RsEExtensibleIntObjInvalidClass);\r\n ItemClass := TJvBaseDataItemClass(PerstClass);\r\n ItemInstance := ItemClass.Create(Self);\r\n try\r\n InternalAdd(ItemInstance);\r\n except\r\n ItemInstance.Free;\r\n raise;\r\n end;\r\n while not Reader.EndOfList do\r\n TReaderAccessProtected(Reader).ReadProperty(ItemInstance);\r\n Reader.ReadListEnd;\r\nend;\r\n\r\nprocedure TJvBaseDataItems.WriteItem(Writer: TWriter; Item: IJvDataItem);\r\nvar\r\n Inst: TPersistent;\r\nbegin\r\n Writer.WriteListBegin;\r\n Inst := TPersistent(Item.GetImplementer);\r\n Writer.WriteStr(cClassName);\r\n Writer.WriteString(Inst.ClassName);\r\n THackWriter(Writer).WriteProperties(Inst);\r\n Writer.WriteListEnd;\r\nend;\r\n\r\nfunction TJvBaseDataItems.GetItemByID(ID: string): IJvDataItem;\r\nvar\r\n CurItems: IJvDataItems;\r\n PathSep: Integer;\r\n PathSep2: Integer;\r\n ThisPath: string;\r\n Idx: Integer;\r\nbegin\r\n CurItems := Self;\r\n while (CurItems <> nil) and (Result = nil) and (ID <> '') do\r\n begin\r\n PathSep := Pos('\\', ID);\r\n PathSep2 := Pos('/', ID);\r\n if (PathSep > PathSep2) or (PathSep = 0) then\r\n PathSep := PathSep2;\r\n if PathSep = 0 then\r\n PathSep := Length(ID) + 1;\r\n ThisPath := Copy(ID, 1, PathSep - 1);\r\n if ThisPath = '..' then\r\n begin\r\n if GetParent <> nil then\r\n CurItems := GetParent.GetItems\r\n else\r\n CurItems := nil;\r\n end\r\n else\r\n if (ThisPath = '') and (GetParent <> nil) and (PathSep <> 0) then\r\n CurItems := GetProvider.GetItems\r\n else\r\n begin\r\n Idx := CurItems.GetCount - 1;\r\n while (Idx >= 0) and not AnsiSameText(CurItems.GetItem(Idx).GetID, ThisPath) do\r\n Dec(Idx);\r\n Delete(ID, 1, PathSep);\r\n if Idx >= 0 then\r\n begin\r\n if ID = '' then\r\n Result := CurItems.GetItem(Idx)\r\n else\r\n Supports(CurItems.GetItem(Idx), IJvDataItems, CurItems);\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJvBaseDataItems.GetItemByIndexPath(IndexPath: array of Integer): IJvDataItem;\r\nvar\r\n Idx: Integer;\r\n ItemList: IJvDataItems;\r\nbegin\r\n if Length(IndexPath) > 0 then\r\n begin\r\n ItemList := Self;\r\n Idx := 0;\r\n while (Idx < Length(IndexPath)) do\r\n begin\r\n Supports(ItemList.GetItem(IndexPath[Idx]), IJvDataItems, ItemList);\r\n Inc(Idx);\r\n end;\r\n Result := ItemList.GetParent;\r\n end;\r\nend;\r\n\r\nfunction TJvBaseDataItems.GetParent: IJvDataItem;\r\nbegin\r\n Result := IJvDataItem(FParent);\r\nend;\r\n\r\nfunction TJvBaseDataItems.GetProvider: IJvDataProvider;\r\nbegin\r\n Result := FProvider;\r\nend;\r\n\r\nfunction TJvBaseDataItems.GetImplementer: TObject;\r\nbegin\r\n Result := Self;\r\nend;\r\n\r\nfunction TJvBaseDataItems.IsDynamic: Boolean;\r\nbegin\r\n Result := True;\r\nend;\r\n\r\nprocedure TJvBaseDataItems.ContextDestroying(Context: IJvDataContext);\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := 0 to FAdditionalIntfImpl.Count - 1 do\r\n TJvDataItemsAggregatedObject(FAdditionalIntfImpl[I]).ContextDestroying(Context);\r\n for I := 0 to GetCount - 1 do\r\n GetItem(I).ContextDestroying(Context);\r\nend;\r\n\r\nfunction TJvBaseDataItems.FindByID(ID: string; const Recursive: Boolean): IJvDataItem;\r\nbegin\r\n Result := ScanForID(Self, ID, Recursive);\r\nend;\r\n\r\nprocedure TJvBaseDataItems.BeforeDestruction;\r\nbegin\r\n inherited BeforeDestruction;\r\n if FSubAggregate <> nil then\r\n FreeAndNil(FSubAggregate);\r\nend;\r\n\r\n//=== { TJvBaseDataItemSubItems } ============================================\r\n\r\nconstructor TJvBaseDataItemSubItems.Create(AOwner: TExtensibleInterfacedPersistent;\r\n AItems: TJvBaseDataItems);\r\nbegin\r\n inherited Create(AOwner);\r\n FItems := AItems;\r\nend;\r\n\r\nprocedure TJvBaseDataItemSubItems.BeforeDestruction;\r\nbegin\r\n inherited BeforeDestruction;\r\n if FItems.GetImplementer is TJvBaseDataItems then\r\n TJvBaseDataItems(FItems.GetImplementer).FSubAggregate := nil;\r\nend;\r\n\r\nfunction TJvBaseDataItemSubItems.GetInterface(const IID: TGUID; out Obj): Boolean;\r\nbegin\r\n Result := inherited GetInterface(IID, Obj) or Succeeded(FItems.QueryInterface(IID, Obj));\r\nend;\r\n\r\n//=== { TJvCustomDataItemTextRenderer } ======================================\r\n\r\nprocedure TJvCustomDataItemTextRenderer.Draw(ACanvas: TCanvas; var ARect: TRect; State: TProviderDrawStates);\r\nbegin\r\n TJvDP_ProviderTextOnlyRender.Draw(Item, ACanvas, ARect, State);\r\nend;\r\n\r\nfunction TJvCustomDataItemTextRenderer.Measure(ACanvas: TCanvas): TSize;\r\nbegin\r\n Result := TJvDP_ProviderTextOnlyRender.Measure(Item, ACanvas, []);\r\nend;\r\n\r\n//=== { TJvCustomDataItemRenderer } ==========================================\r\n\r\nprocedure TJvCustomDataItemRenderer.Draw(ACanvas: TCanvas; var ARect: TRect; State: TProviderDrawStates);\r\nbegin\r\n TJvDP_ProviderImgAndTextRender.Draw(Item, ACanvas, ARect, State);\r\nend;\r\n\r\nfunction TJvCustomDataItemRenderer.Measure(ACanvas: TCanvas): TSize;\r\nbegin\r\n Result := TJvDP_ProviderImgAndTextRender.Measure(Item, ACanvas, []);\r\nend;\r\n\r\n//=== { TJvCustomDataItemStates } ============================================\r\n\r\nprocedure TJvCustomDataItemStates.InitStatesUsage(UseEnabled, UseChecked, UseVisible: Boolean);\r\nbegin\r\n if UseEnabled then\r\n FEnabled := disTrue\r\n else\r\n FEnabled := disNotUsed;\r\n if UseChecked then\r\n FChecked := disFalse\r\n else\r\n FChecked := disNotUsed;\r\n if UseVisible then\r\n FVisible := disTrue\r\n else\r\n FVisible := disNotUsed;\r\nend;\r\n\r\nfunction TJvCustomDataItemStates.Get_Enabled: TDataItemState;\r\nbegin\r\n Result := FEnabled;\r\nend;\r\n\r\nprocedure TJvCustomDataItemStates.Set_Enabled(Value: TDataItemState);\r\nbegin\r\n if Value = disNotUsed then\r\n Exit;\r\n if Value <> Get_Enabled then\r\n begin\r\n Item.GetItems.Provider.Changing(pcrUpdateItem, Item);\r\n FEnabled := Value;\r\n Item.GetItems.Provider.Changed(pcrUpdateItem, Item);\r\n end;\r\nend;\r\n\r\nfunction TJvCustomDataItemStates.Get_Checked: TDataItemState;\r\nbegin\r\n Result := FChecked;\r\nend;\r\n\r\nprocedure TJvCustomDataItemStates.Set_Checked(Value: TDataItemState);\r\nbegin\r\n if Value = disNotUsed then\r\n Exit;\r\n if Value <> Get_Checked then\r\n begin\r\n Item.GetItems.Provider.Changing(pcrUpdateItem, Item);\r\n FChecked := Value;\r\n Item.GetItems.Provider.Changed(pcrUpdateItem, Item);\r\n end;\r\nend;\r\n\r\nfunction TJvCustomDataItemStates.Get_Visible: TDataItemState;\r\nbegin\r\n Result := FVisible;\r\nend;\r\n\r\nprocedure TJvCustomDataItemStates.Set_Visible(Value: TDataItemState);\r\nbegin\r\n if Value = disNotUsed then\r\n Exit;\r\n if Value <> Get_Visible then\r\n begin\r\n Item.GetItems.Provider.Changing(pcrUpdateItem, Item);\r\n FVisible := Value;\r\n Item.GetItems.Provider.Changed(pcrUpdateItem, Item);\r\n end;\r\nend;\r\n\r\n//=== { TJvDataItemsAggregatedObject } =======================================\r\n\r\nprocedure TJvDataItemsAggregatedObject.ContextDestroying(Context: IJvDataContext);\r\nbegin\r\nend;\r\n\r\nfunction TJvDataItemsAggregatedObject.Items: IJvDataItems;\r\nbegin\r\n Result := Owner as IJvDataItems;\r\nend;\r\n\r\nfunction TJvDataItemsAggregatedObject.ItemsImpl: TJvBaseDataItems;\r\nbegin\r\n Result := Owner as TJvBaseDataItems;\r\nend;\r\n\r\n//=== { TJvBaseDataItemsRenderer } ===========================================\r\n\r\nprocedure TJvBaseDataItemsRenderer.DrawItemByIndex(ACanvas: TCanvas; var ARect: TRect;\r\n Index: Integer; State: TProviderDrawStates);\r\nbegin\r\n if (Index < 0) or (Index >= Items.Count) then\r\n raise EJVCLDataItems.CreateResFmt(@SListIndexError, [Index]);\r\n DrawItem(ACanvas, ARect, Items.Items[Index], State);\r\nend;\r\n\r\nfunction TJvBaseDataItemsRenderer.MeasureItemByIndex(ACanvas: TCanvas; Index: Integer): TSize;\r\nbegin\r\n if Index = -1 then\r\n Result := AvgItemSize(ACanvas)\r\n else\r\n begin\r\n if (Index < 0) or (Index >= Items.Count) then\r\n raise EJVCLDataItems.CreateResFmt(@SListIndexError, [Index]);\r\n Result := MeasureItem(ACanvas, Items.Items[Index]);\r\n end;\r\nend;\r\n\r\nprocedure TJvBaseDataItemsRenderer.DrawItem(ACanvas: TCanvas; var ARect: TRect; Item: IJvDataItem;\r\n State: TProviderDrawStates);\r\nvar\r\n ImgRender: IJvDataItemRenderer;\r\nbegin\r\n if Supports(Item, IJvDataItemRenderer, ImgRender) then\r\n ImgRender.Draw(ACanvas, ARect, State)\r\n else\r\n DoDrawItem(ACanvas, ARect, Item, State);\r\nend;\r\n\r\nfunction TJvBaseDataItemsRenderer.MeasureItem(ACanvas: TCanvas; Item: IJvDataItem): TSize;\r\nvar\r\n ImgRender: IJvDataItemRenderer;\r\nbegin\r\n if Supports(Item, IJvDataItemRenderer, ImgRender) then\r\n Result := ImgRender.Measure(ACanvas)\r\n else\r\n Result := DoMeasureItem(ACanvas, Item);\r\nend;\r\n\r\n//=== { TJvDataItemsList } ===================================================\r\n\r\nconstructor TJvDataItemsList.Create;\r\nbegin\r\n inherited Create;\r\n FList := TObjectList.Create;\r\nend;\r\n\r\ndestructor TJvDataItemsList.Destroy;\r\nbegin\r\n FreeAndNil(FList);\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvDataItemsList.InternalAdd(Item: IJvDataItem);\r\nbegin\r\n List.Add(Item.GetImplementer);\r\nend;\r\n\r\nprocedure TJvDataItemsList.InternalDelete(Index: Integer);\r\nbegin\r\n List.Delete(Index);\r\nend;\r\n\r\nprocedure TJvDataItemsList.InternalMove(OldIndex, NewIndex: Integer);\r\nbegin\r\n List.Move(OldIndex, NewIndex);\r\nend;\r\n\r\nfunction TJvDataItemsList.IsDynamic: Boolean;\r\nbegin\r\n Result := False;\r\nend;\r\n\r\nfunction TJvDataItemsList.GetCount: Integer;\r\nbegin\r\n Result := List.Count;\r\nend;\r\n\r\nfunction TJvDataItemsList.GetItem(I: Integer): IJvDataItem;\r\nbegin\r\n Result := (List[I] as TJvBaseDataItem) as IJvDataItem;\r\nend;\r\n\r\n//=== { TJvBaseDataItemsListManagement } =====================================\r\n\r\nfunction TJvBaseDataItemsListManagement.Add(Item: IJvDataItem): IJvDataItem;\r\nbegin\r\n Items.Provider.Changing(pcrAdd, Items);\r\n TJvDataItemsList(ItemsImpl).List.Add(Item.GetImplementer);\r\n Result := Item;\r\n Items.Provider.Changed(pcrAdd, Result);\r\nend;\r\n\r\nprocedure TJvBaseDataItemsListManagement.Clear;\r\nbegin\r\n Items.Provider.Changing(pcrUpdateItems, Items);\r\n TJvDataItemsList(ItemsImpl).List.Clear;\r\n Items.Provider.Changed(pcrUpdateItems, Items);\r\nend;\r\n\r\nprocedure TJvBaseDataItemsListManagement.Delete(Index: Integer);\r\nbegin\r\n if (Items.GetItem(Index) <> nil) and Items.GetItem(Index).IsDeletable then\r\n begin\r\n Items.Provider.Changing(pcrDelete, Items.GetItem(Index));\r\n TJvDataItemsList(ItemsImpl).List.Delete(Index);\r\n Items.Provider.Changed(pcrDelete, nil);\r\n end\r\n else\r\n if Items.GetItem(Index) <> nil then\r\n raise EJVCLDataItems.CreateRes(@RsEItemCanNotBeDeleted);\r\nend;\r\n\r\nprocedure TJvBaseDataItemsListManagement.Remove(var Item: IJvDataItem);\r\nvar\r\n Impl: TObject;\r\nbegin\r\n if (Item <> nil) and Item.IsDeletable then\r\n begin\r\n Impl := Item.GetImplementer;\r\n Pointer(Item) := nil;\r\n if (Impl is TExtensibleInterfacedPersistent) and\r\n (TExtensibleInterfacedPersistent(Impl).RefCount = 0) then\r\n begin\r\n TExtensibleInterfacedPersistent(Impl).SuspendRefCount;\r\n try\r\n Item := TExtensibleInterfacedPersistent(Impl) as IJvDataItem;\r\n try\r\n Items.Provider.Changing(pcrDelete, Item);\r\n finally\r\n Pointer(Item) := nil;\r\n end;\r\n finally\r\n TExtensibleInterfacedPersistent(Impl).ResumeRefCount;\r\n end;\r\n TJvDataItemsList(ItemsImpl).List.Remove(Impl);\r\n Items.Provider.Changed(pcrDelete, nil);\r\n end;\r\n end\r\n else\r\n if Item <> nil then\r\n raise EJVCLDataItems.CreateRes(@RsEItemCanNotBeDeleted);\r\nend;\r\n\r\n//=== { TJvCustomDataItemsImages } ===========================================\r\n\r\nfunction TJvCustomDataItemsImages.GetDisabledImages: TCustomImageList;\r\nbegin\r\n Result := FDisabledImages;\r\nend;\r\n\r\nprocedure TJvCustomDataItemsImages.SetDisabledImages(const Value: TCustomImageList);\r\nbegin\r\n if Value <> GetDisabledImages then\r\n begin\r\n (Owner as IJvDataItems).Provider.Changing(pcrUpdateItems, Items);\r\n FDisabledImages := Value;\r\n (Owner as IJvDataItems).Provider.Changed(pcrUpdateItems, Items);\r\n end;\r\nend;\r\n\r\nfunction TJvCustomDataItemsImages.GetHotImages: TCustomImageList;\r\nbegin\r\n Result := FHotImages;\r\nend;\r\n\r\nprocedure TJvCustomDataItemsImages.SetHotImages(const Value: TCustomImageList);\r\nbegin\r\n if Value <> GetHotImages then\r\n begin\r\n (Owner as IJvDataItems).Provider.Changing(pcrUpdateItems, Items);\r\n FHotImages := Value;\r\n (Owner as IJvDataItems).Provider.Changed(pcrUpdateItems, Items);\r\n end;\r\nend;\r\n\r\nfunction TJvCustomDataItemsImages.GetImages: TCustomImageList;\r\nbegin\r\n Result := FImages;\r\nend;\r\n\r\nprocedure TJvCustomDataItemsImages.SetImages(const Value: TCustomImageList);\r\nbegin\r\n if Value <> GetImages then\r\n begin\r\n (Owner as IJvDataItems).Provider.Changing(pcrUpdateItems, Items);\r\n FImages := Value;\r\n (Owner as IJvDataItems).Provider.Changed(pcrUpdateItems, Items);\r\n end;\r\nend;\r\n\r\n//=== { TJvBaseDataItem } ====================================================\r\n\r\nconstructor TJvBaseDataItem.Create(AOwner: IJvDataItems);\r\nbegin\r\n inherited Create;\r\n FItems := Pointer(AOwner);\r\n // Dynamically generated items will need a hard reference to the IJvDataItems owner.\r\n if AOwner.IsDynamic then\r\n FItemsIntf := AOwner;\r\nend;\r\n\r\nprocedure TJvBaseDataItem.AfterConstruction;\r\nbegin\r\n InitID;\r\n inherited AfterConstruction;\r\nend;\r\n\r\nprocedure TJvBaseDataItem.InitID;\r\nvar\r\n G: TGUID;\r\nbegin\r\n CoCreateGuid(G);\r\n FID := HexBytes(G, SizeOf(G));\r\nend;\r\n\r\nprocedure TJvBaseDataItem.SetID(Value: string);\r\nbegin\r\n FID := Value;\r\nend;\r\n\r\nfunction TJvBaseDataItem._AddRef: Integer;\r\nbegin\r\n GetItems.GetProvider.SelectContext(nil);\r\n try\r\n if GetItems.IsDynamic then\r\n Result := inherited _AddRef\r\n else\r\n Result := -1;\r\n finally\r\n GetItems.GetProvider.ReleaseContext;\r\n end;\r\nend;\r\n\r\nfunction TJvBaseDataItem._Release: Integer;\r\nvar\r\n NeedsRelease: Boolean;\r\nbegin\r\n GetItems.GetProvider.SelectContext(nil);\r\n try\r\n NeedsRelease := GetItems.IsDynamic;\r\n finally\r\n GetItems.GetProvider.ReleaseContext;\r\n end;\r\n if NeedsRelease then\r\n Result := inherited _Release\r\n else\r\n Result := -1;\r\nend;\r\n\r\nprocedure TJvBaseDataItem.DefineProperties(Filer: TFiler);\r\nvar\r\n Tmp: IJvDataItems;\r\nbegin\r\n inherited DefineProperties(Filer);\r\n Filer.DefineProperty('SubItems', ReadSubItems, WriteSubItems,\r\n Supports(Self as IJvDataItem, IJvDataItems, Tmp));\r\nend;\r\n\r\nprocedure TJvBaseDataItem.ReadSubItems(Reader: TReader);\r\nvar\r\n PropName: string;\r\n ClassName: string;\r\n AClass: TPersistentClass;\r\n I: Integer;\r\nbegin\r\n { When loading sub items the interface of this object may be referenced. We don't want the\r\n instance destroyed yet, so reference counting will be suspended (by incrementing it) and resumed\r\n when we're done (by decrementing it without checking if it became zero) }\r\n SuspendRefCount;\r\n try\r\n if Reader.ReadValue <> vaCollection then\r\n raise EReadError.CreateRes(@RsEExtensibleIntObjCollectionExpected);\r\n Reader.ReadListBegin;\r\n PropName := Reader.ReadStr;\r\n if not AnsiSameText(PropName, cClassName) then\r\n raise EReadError.CreateRes(@RsEExtensibleIntObjClassNameExpected);\r\n ClassName := Reader.ReadString;\r\n AClass := FindClass(ClassName);\r\n if not AClass.InheritsFrom(TJvBaseDataItems) then\r\n raise EReadError.CreateRes(@RsEExtensibleIntObjInvalidClass);\r\n I := IndexOfImplClass(TJvBaseDataItemSubItems);\r\n if I > -1 then\r\n begin\r\n if TJvBaseDataItemSubItems(FAdditionalIntfImpl[I]).Items.GetImplementer.ClassType <> AClass then\r\n begin\r\n FAdditionalIntfImpl.Delete(I);\r\n I := -1;\r\n end;\r\n end;\r\n if I = -1 then\r\n begin\r\n TJvDataItemsClass(AClass).Create(Self);\r\n I := IndexOfImplClass(TJvBaseDataItemSubItems);\r\n end;\r\n while not Reader.EndOfList do\r\n TReaderAccessProtected(Reader).ReadProperty(\r\n TJvBaseDataItems(TJvBaseDataItemSubItems(FAdditionalIntfImpl[I]).Items.GetImplementer));\r\n Reader.ReadListEnd;\r\n Reader.ReadListEnd;\r\n finally\r\n ResumeRefCount;\r\n end;\r\nend;\r\n\r\nprocedure TJvBaseDataItem.WriteSubItems(Writer: TWriter);\r\nvar\r\n Items: IJvDataItems;\r\n SavePropPath: string;\r\nbegin\r\n QueryInterface(IJvDataItems, Items);\r\n THackWriter(Writer).WriteValue(vaCollection);\r\n SavePropPath := THackWriter(Writer).PropPath;\r\n THackWriter(Writer).PropPath := '';\r\n try\r\n Writer.WriteListBegin;\r\n Writer.WriteStr(cClassName);\r\n Writer.WriteString(Items.GetImplementer.ClassName);\r\n THackWriter(Writer).WriteProperties(Items.GetImplementer as TPersistent);\r\n Writer.WriteListEnd;\r\n Writer.WriteListEnd;\r\n finally\r\n THackWriter(Writer).PropPath := SavePropPath;\r\n end;\r\nend;\r\n\r\nfunction TJvBaseDataItem.GetItems: IJvDataItems;\r\nbegin\r\n Result := IJvDataItems(FItems);\r\nend;\r\n\r\nfunction TJvBaseDataItem.GetNamePath: string;\r\nvar\r\n Comp: TPersistent;\r\nbegin\r\n Comp := GetOwner;\r\n if (Comp <> nil) and (Comp is TComponent) then\r\n Result := (Comp as TComponent).Name\r\n else\r\n Result := RsUnknown;\r\n Result := Result + ': Item[' + GetID + ']';\r\nend;\r\n\r\nfunction TJvBaseDataItem.GetOwner: TPersistent;\r\nbegin\r\n if Items <> nil then\r\n Result := (Items.Provider as IInterfaceComponentReference).GetComponent\r\n else\r\n Result := inherited GetOwner;\r\nend;\r\n\r\nfunction TJvBaseDataItem.GetIndex: Integer;\r\nvar\r\n Owner: IJvDataItems;\r\nbegin\r\n Owner := GetItems;\r\n Result := Owner.GetCount - 1;\r\n while (Result >= 0) and (Owner.GetItem(Result) <> Self as IJvDataItem) do\r\n Dec(Result);\r\nend;\r\n\r\nfunction TJvBaseDataItem.GetImplementer: TObject;\r\nbegin\r\n Result := Self;\r\nend;\r\n\r\nfunction TJvBaseDataItem.GetID: string;\r\nbegin\r\n Result := FID;\r\nend;\r\n\r\nprocedure TJvBaseDataItem.ContextDestroying(Context: IJvDataContext);\r\nvar\r\n I: Integer;\r\n SubItems: IJvDataItems;\r\nbegin\r\n for I := 0 to FAdditionalIntfImpl.Count - 1 do\r\n TJvDataItemAggregatedObject(FAdditionalIntfImpl[I]).ContextDestroying(Context);\r\n if Supports(Self as IJvDataItem, IJvDataItems, SubItems) then\r\n SubItems.ContextDestroying(Context);\r\nend;\r\n\r\nfunction TJvBaseDataItem.IsParentOf(AnItem: IJvDataItem; DirectParent: Boolean): Boolean;\r\nbegin\r\n Result := AnItem.GetItems.Parent = (Self as IJvDataItem);\r\n if not Result and not DirectParent then\r\n begin\r\n AnItem := AnItem.GetItems.Parent;\r\n while (AnItem <> nil) and (AnItem <> (Self as IJvDataItem)) do\r\n AnItem := AnItem.GetItems.Parent;\r\n Result := AnItem = (Self as IJvDataItem);\r\n end;\r\nend;\r\n\r\nfunction TJvBaseDataItem.IsDeletable: Boolean;\r\nbegin\r\n Result := True;\r\nend;\r\n\r\nprocedure TJvBaseDataItem.RevertToAncestor;\r\nvar\r\n I: Integer;\r\n Inst: TJvDataItemAggregatedObject;\r\n CtxSens: IJvDataContextSensitive;\r\nbegin\r\n for I := 0 to FAdditionalIntfImpl.Count - 1 do\r\n begin\r\n Inst := TJvDataItemAggregatedObject(FAdditionalIntfImpl[I]);\r\n if Inst.GetInterface(IJvDataContextSensitive, CtxSens) then\r\n CtxSens.RevertToAncestor;\r\n end;\r\nend;\r\n\r\nfunction TJvBaseDataItem.IsEqualToAncestor: Boolean;\r\nvar\r\n I: Integer;\r\n Inst: TJvDataItemAggregatedObject;\r\n CtxSens: IJvDataContextSensitive;\r\nbegin\r\n Result := True;\r\n I := 0;\r\n while Result and (I < FAdditionalIntfImpl.Count) do\r\n begin\r\n Inst := TJvDataItemAggregatedObject(FAdditionalIntfImpl[I]);\r\n if Inst.GetInterface(IJvDataContextSensitive, CtxSens) then\r\n Result := CtxSens.IsEqualToAncestor;\r\n Inc(I);\r\n end;\r\nend;\r\n\r\n//=== { TJvCustomDataProvider } ==============================================\r\n\r\nconstructor TJvCustomDataProvider.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FNotifiers := TInterfaceList.Create;\r\n FConsumerStack := TInterfaceList.Create;\r\n FContextStack := TInterfaceList.Create;\r\n if ContextsClass <> nil then\r\n begin\r\n FDataContextsImpl := ContextsClass.Create(Self, nil, ContextsManagerClass);\r\n FDataContextsIntf := FDataContextsImpl;\r\n end;\r\n if ItemsClass <> nil then\r\n FDataItems := ItemsClass.Create(Self)\r\n else\r\n raise EJVCLDataProvider.CreateRes(@RsEDataProviderNeedsItemsImpl);\r\nend;\r\n\r\ndestructor TJvCustomDataProvider.Destroy;\r\nbegin\r\n FreeAndNil(FNotifiers);\r\n FreeAndNil(FConsumerStack);\r\n FreeAndNil(FContextStack);\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvCustomDataProvider.BeforeDestruction;\r\nbegin\r\n inherited BeforeDestruction;\r\n Changing(pcrDestroy);\r\nend;\r\n\r\nfunction TJvCustomDataProvider.QueryInterface(const IID: TGUID; out Obj): HRESULT;\r\nconst\r\n E_NOINTERFACE = HRESULT($80004002);\r\nbegin\r\n if GetInterface(IID, Obj) then\r\n Result := S_OK\r\n else\r\n Result := E_NOINTERFACE;\r\nend;\r\n\r\nprocedure TJvCustomDataProvider.Changing(ChangeReason: TDataProviderChangeReason; Source: IUnknown);\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := FNotifiers.Count - 1 downto 0 do\r\n (FNotifiers[I] as IJvDataProviderNotify).DataProviderChanging(Self, ChangeReason, Source);\r\n if ChangeReason = pcrContextDelete then\r\n ContextDestroying(IJvDataContext(Source));\r\nend;\r\n\r\nprocedure TJvCustomDataProvider.Changed(ChangeReason: TDataProviderChangeReason; Source: IUnknown);\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := FNotifiers.Count - 1 downto 0 do\r\n (FNotifiers[I] as IJvDataProviderNotify).DataProviderChanged(Self, ChangeReason, Source);\r\n if ChangeReason = pcrContextAdd then\r\n ContextAdded(IJvDataContext(Source));\r\nend;\r\n\r\nclass function TJvCustomDataProvider.PersistentDataItems: Boolean;\r\nbegin\r\n Result := False;\r\nend;\r\n\r\nclass function TJvCustomDataProvider.ItemsClass: TJvDataItemsClass;\r\nbegin\r\n Result := TJvDataItemsList;\r\nend;\r\n\r\nclass function TJvCustomDataProvider.ContextsClass: TJvDataContextsClass;\r\nbegin\r\n Result := nil;\r\nend;\r\n\r\nclass function TJvCustomDataProvider.ContextsManagerClass: TJvDataContextsManagerClass;\r\nbegin\r\n Result := nil;\r\nend;\r\n\r\nprocedure TJvCustomDataProvider.DefineProperties(Filer: TFiler);\r\nbegin\r\n inherited DefineProperties(Filer);\r\n if (ContextsClass <> nil) and (ContextsManagerClass <> nil) then\r\n Filer.DefineProperty('ContextList', ReadContexts, WriteContexts, True);\r\n if PersistentDataItems then\r\n Filer.DefineProperty('Root', ReadRoot, WriteRoot, True);\r\nend;\r\n\r\nprocedure TJvCustomDataProvider.ReadRoot(Reader: TReader);\r\nbegin\r\n if Reader.ReadValue <> vaCollection then\r\n raise EReadError.CreateRes(@RsEExtensibleIntObjCollectionExpected);\r\n Reader.ReadListBegin;\r\n // We don't really have a root item; just stream in the DataItemsImpl instance.\r\n while not Reader.EndOfList do\r\n TReaderAccessProtected(Reader).ReadProperty(DataItemsImpl);\r\n // (rom) why twice? Please comment.\r\n Reader.ReadListEnd;\r\n Reader.ReadListEnd;\r\nend;\r\n\r\nprocedure TJvCustomDataProvider.WriteRoot(Writer: TWriter);\r\nbegin\r\n THackWriter(Writer).WriteValue(vaCollection);\r\n Writer.WriteListBegin;\r\n // We don't really have a root item; just stream out the DataItemsImpl instance.\r\n THackWriter(Writer).WriteProperties(DataItemsImpl);\r\n // (rom) why twice? Please comment.\r\n Writer.WriteListEnd;\r\n Writer.WriteListEnd;\r\nend;\r\n\r\nprocedure TJvCustomDataProvider.ReadContexts(Reader: TReader);\r\nvar\r\n I: Integer;\r\nbegin\r\n if Reader.ReadValue <> vaCollection then\r\n raise EReadError.CreateRes(@RsEExtensibleIntObjCollectionExpected);\r\n for I := DataContextsImpl.GetCount - 1 downto 0 do\r\n if DataContextsImpl.GetContext(I).IsDeletable then\r\n DataContextsImpl.DoDeleteContext(I);\r\n I := 0;\r\n while not Reader.EndOfList do\r\n begin\r\n ReadContext(Reader, I);\r\n Inc(I);\r\n end;\r\n Reader.ReadListEnd;\r\nend;\r\n\r\nprocedure TJvCustomDataProvider.WriteContexts(Writer: TWriter);\r\nvar\r\n I: Integer;\r\nbegin\r\n THackWriter(Writer).WriteValue(vaCollection);\r\n for I := 0 to FDataContextsImpl.GetCount - 1 do\r\n if not FDataContextsImpl.GetContext(I).IsDeletable and\r\n TJvBaseDataContext(FDataContextsImpl.GetContext(I).GetImplementer).IsStreamable then\r\n WriteContext(Writer, FDataContextsImpl.GetContext(I));\r\n for I := 0 to FDataContextsImpl.GetCount - 1 do\r\n if FDataContextsImpl.GetContext(I).IsDeletable then\r\n WriteContext(Writer, FDataContextsImpl.GetContext(I));\r\n Writer.WriteListEnd;\r\nend;\r\n\r\nprocedure TJvCustomDataProvider.ReadContext(Reader: TReader; Index: Integer);\r\nvar\r\n ClassName: string;\r\n ClassType: TClass;\r\n CtxName: string;\r\n CtxInst: TJvBaseDataContext;\r\nbegin\r\n Reader.ReadListBegin;\r\n ClassType := nil;\r\n if Index >= DataContextsImpl.GetCount then\r\n begin\r\n ClassName := Reader.ReadStr;\r\n if not AnsiSameText(ClassName, cClassName) then\r\n raise EReadError.CreateRes(@RsEExtensibleIntObjClassNameExpected);\r\n ClassName := Reader.ReadString;\r\n ClassType := FindClass(ClassName);\r\n if not ClassType.InheritsFrom(TJvBaseDataContext) then\r\n raise EReadError.CreateRes(@RsEExtensibleIntObjInvalidClass);\r\n end;\r\n CtxName := Reader.ReadStr;\r\n if not AnsiSameText(CtxName, cName) then\r\n raise EReadError.CreateRes(@RsEContextNameExpected);\r\n CtxName := Reader.ReadString;\r\n if Index >= DataContextsImpl.GetCount then\r\n begin\r\n CtxInst := TJvDataContextClass(ClassType).Create(FDataContextsImpl, CtxName);\r\n try\r\n FDataContextsImpl.DoAddContext(CtxInst);\r\n except\r\n CtxInst.Free;\r\n raise;\r\n end;\r\n end\r\n else\r\n CtxInst := TJvBaseDataContext(DataContextsImpl.GetContextByName(CtxName).GetImplementer);\r\n while not Reader.EndOfList do\r\n TReaderAccessProtected(Reader).ReadProperty(CtxInst);\r\n Reader.ReadListEnd;\r\nend;\r\n\r\nprocedure TJvCustomDataProvider.WriteContext(Writer: TWriter; AContext: IJvDataContext);\r\nbegin\r\n Writer.WriteListBegin;\r\n if AContext.IsDeletable then\r\n begin\r\n Writer.WriteStr(cClassName);\r\n Writer.WriteString(AContext.GetImplementer.ClassName);\r\n end;\r\n Writer.WriteStr(cName);\r\n Writer.WriteString(AContext.Name);\r\n THackWriter(Writer).WriteProperties(TPersistent(AContext.GetImplementer));\r\n Writer.WriteListEnd;\r\nend;\r\n\r\nprocedure TJvCustomDataProvider.AddToArray(var ClassArray: TClassArray; AClass: TClass);\r\nbegin\r\n SetLength(ClassArray, Length(ClassArray) + 1);\r\n ClassArray[High(ClassArray)] := AClass;\r\nend;\r\n\r\nprocedure TJvCustomDataProvider.DeleteFromArray(var ClassArray: TClassArray; Index: Integer);\r\nbegin\r\n if (Index >= 0) and (Index <= High(ClassArray)) then\r\n begin\r\n if Index < High(ClassArray) then\r\n Move(ClassArray[Index + 1], ClassArray[Index], SizeOf(TClass) * (High(ClassArray) - Index));\r\n SetLength(ClassArray, High(ClassArray));\r\n end;\r\nend;\r\n\r\nfunction TJvCustomDataProvider.IndexOfClass(AClassArray: TClassArray; AClass: TClass): Integer;\r\nbegin\r\n Result := High(AClassArray);\r\n while (Result >= 0) and (AClassArray[Result] <> AClass) do\r\n Dec(Result);\r\nend;\r\n\r\nprocedure TJvCustomDataProvider.RemoveFromArray(var ClassArray: TClassArray; AClass: TClass);\r\nvar\r\n I: Integer;\r\nbegin\r\n I := IndexOfClass(ClassArray, AClass);\r\n if I > -1 then\r\n DeleteFromArray(ClassArray, I);\r\nend;\r\n\r\nfunction TJvCustomDataProvider.IsTreeProvider: Boolean;\r\nvar\r\n I: Integer;\r\n Obj: IJvDataItems;\r\nbegin\r\n I := GetItems.Count - 1;\r\n while (I >= 0) and not Supports(GetItems.GetItem(I), IJvDataItems, Obj) do\r\n Dec(I);\r\n Result := I >= 0;\r\nend;\r\n\r\nfunction TJvCustomDataProvider.GetDataItemsImpl: TJvBaseDataItems;\r\nbegin\r\n if FDataItems <> nil then\r\n Result := TJvBaseDataItems(FDataItems.GetImplementer)\r\n else\r\n Result := nil;\r\nend;\r\n\r\nfunction TJvCustomDataProvider.GetItems: IJvDataItems;\r\nbegin\r\n Result := FDataItems;\r\nend;\r\n\r\nprocedure TJvCustomDataProvider.RegisterChangeNotify(ANotify: IJvDataProviderNotify);\r\nbegin\r\n if FNotifiers.IndexOf(ANotify) < 0 then\r\n FNotifiers.Add(ANotify);\r\nend;\r\n\r\nprocedure TJvCustomDataProvider.UnregisterChangeNotify(ANotify: IJvDataProviderNotify);\r\nbegin\r\n FNotifiers.Remove(ANotify);\r\nend;\r\n\r\nfunction TJvCustomDataProvider.ConsumerClasses: TClassArray;\r\nvar\r\n Obj: IUnknown;\r\nbegin\r\n SetLength(Result, 0);\r\n\r\n // Generic provider based extensions\r\n if Supports(Self as IJvDataProvider, IJvDataContexts, Obj) then\r\n AddToArray(Result, TJvDataConsumerContext);\r\n\r\n // Consumer based extensions\r\n if SelectedConsumer <> nil then\r\n begin\r\n // Generic consumer based extensions\r\n if SelectedConsumer.AttributeApplies(DPA_RendersSingleItem) or IsTreeProvider then\r\n AddToArray(Result, TJvDataConsumerItemSelect);\r\n if SelectedConsumer.AttributeApplies(DPA_ConsumerDisplaysList) then\r\n AddToArray(Result, TJvDataConsumerViewList);\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomDataProvider.SelectConsumer(Consumer: IJvDataConsumer);\r\nbegin\r\n if FConsumerStack <> nil then\r\n FConsumerStack.Insert(0, Consumer);\r\nend;\r\n\r\nfunction TJvCustomDataProvider.SelectedConsumer: IJvDataConsumer;\r\nbegin\r\n if (FConsumerStack <> nil) and (FConsumerStack.Count > 0) then\r\n Result := IJvDataConsumer(FConsumerStack[0])\r\n else\r\n Result := nil;\r\nend;\r\n\r\nprocedure TJvCustomDataProvider.ReleaseConsumer;\r\nbegin\r\n if (FConsumerStack <> nil) and (FConsumerStack.Count > 0) then\r\n FConsumerStack.Delete(0)\r\n else\r\n if FConsumerStack <> nil then\r\n raise EJVCLDataProvider.CreateRes(@RsEConsumerStackIsEmpty);\r\nend;\r\n\r\nprocedure TJvCustomDataProvider.SelectContext(Context: IJvDataContext);\r\nbegin\r\n if FContextStack <> nil then\r\n FContextStack.Insert(0, Context);\r\nend;\r\n\r\nfunction TJvCustomDataProvider.SelectedContext: IJvDataContext;\r\nbegin\r\n if (FContextStack <> nil) and (FContextStack.Count > 0) then\r\n Result := IJvDataContext(FContextStack[0])\r\n else\r\n Result := nil;\r\nend;\r\n\r\nprocedure TJvCustomDataProvider.ReleaseContext;\r\nbegin\r\n if (FContextStack <> nil) and (FContextStack.Count > 0) then\r\n FContextStack.Delete(0)\r\n else\r\n if FContextStack <> nil then\r\n raise EJVCLDataProvider.CreateRes(@RsEContextStackIsEmpty);\r\nend;\r\n\r\nprocedure TJvCustomDataProvider.ContextAdded(Context: IJvDataContext);\r\nbegin\r\nend;\r\n\r\nprocedure TJvCustomDataProvider.ContextDestroying(Context: IJvDataContext);\r\nbegin\r\n DataItemsImpl.ContextDestroying(Context);\r\nend;\r\n\r\nprocedure TJvCustomDataProvider.ConsumerDestroying(Consumer: IJvDataConsumer);\r\nbegin\r\nend;\r\n\r\nfunction TJvCustomDataProvider.AllowProviderDesigner: Boolean;\r\nbegin\r\n Result := PersistentDataItems;\r\nend;\r\n\r\nfunction TJvCustomDataProvider.AllowContextManager: Boolean;\r\nvar\r\n CtxMan: IJvDataContextsManager;\r\nbegin\r\n Result := (FDataContextsImpl <> nil) and\r\n Supports(FDataContextsImpl as IJvDataContexts, IJvDataContextsManager, CtxMan);\r\nend;\r\n\r\nfunction TJvCustomDataProvider.GetNotifierCount: Integer;\r\nbegin\r\n Result := FNotifiers.Count;\r\nend;\r\n\r\nfunction TJvCustomDataProvider.GetNotifier(Index: Integer): IJvDataProviderNotify;\r\nbegin\r\n Result := IJvDataProviderNotify(FNotifiers[Index]);\r\nend;\r\n\r\nfunction TJvCustomDataProvider.GetImplementer: TObject;\r\nbegin\r\n Result := Self;\r\nend;\r\n\r\nfunction TJvCustomDataProvider.GetInterface(const IID: TGUID; out Obj): Boolean;\r\nbegin\r\n Result := inherited GetInterface(IID, Obj) or Supports(GetItems, IID, Obj) or (\r\n // If we have contexts, check the interface table of that implementation as well.\r\n (FDataContextsImpl <> nil) and Supports(TObject(FDataContextsImpl), IID, Obj)\r\n );\r\nend;\r\n\r\n//=== { TJvBaseDataContexts } ================================================\r\n\r\nconstructor TJvBaseDataContexts.Create(AProvider: IJvDataProvider; AAncestor: IJvDataContext;\r\n ManagerClass: TJvDataContextsManagerClass);\r\nbegin\r\n inherited Create;\r\n FProvider := AProvider;\r\n FAncestor := AAncestor;\r\n if ManagerClass <> nil then\r\n ManagerClass.Create(Self);\r\nend;\r\n\r\nfunction TJvBaseDataContexts.Provider: IJvDataProvider;\r\nbegin\r\n Result := FProvider;\r\nend;\r\n\r\nfunction TJvBaseDataContexts.Ancestor: IJvDataContext;\r\nbegin\r\n Result := FAncestor;\r\nend;\r\n\r\nfunction TJvBaseDataContexts.GetContextByName(Name: string): IJvDataContext;\r\nvar\r\n PathSep: Integer;\r\n PathSep2: Integer;\r\n ThisPath: string;\r\n Idx: Integer;\r\nbegin\r\n PathSep := Pos('\\', Name);\r\n PathSep2 := Pos('/', Name);\r\n if (PathSep > PathSep2) or (PathSep = 0) then\r\n PathSep := PathSep2;\r\n if PathSep = 0 then\r\n PathSep := Length(Name) + 1;\r\n ThisPath := Copy(Name, 1, PathSep - 1);\r\n if ThisPath = '..' then\r\n begin\r\n if Ancestor <> nil then\r\n Result := Ancestor.Contexts.GetContextByName(Copy(Name, PathSep + 1, Length(Name) - PathSep));\r\n end\r\n else\r\n if (ThisPath = '') and (Ancestor <> nil) and (PathSep <> 0) then\r\n Result := (Provider as IJvDataContexts).GetContextByName(Copy(Name, PathSep + 1, Length(Name) - PathSep))\r\n else\r\n begin\r\n Idx := GetCount - 1;\r\n while (Idx >= 0) and not AnsiSameText(GetContext(Idx).Name, ThisPath) do\r\n Dec(Idx);\r\n if Idx >= 0 then\r\n begin\r\n Result := GetContext(Idx);\r\n if PathSep < Length(Name) then\r\n Result := Result.Contexts.GetContextByName(Copy(Name, PathSep + 1, Length(Name) - PathSep));\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJvBaseDataContexts.IndexOf(Ctx: IJvDataContext): Integer;\r\nbegin\r\n Result := GetCount - 1;\r\n while (Result >= 0) and (Ctx <> GetContext(Result)) do\r\n Dec(Result);\r\nend;\r\n\r\n//=== { TJvBaseDataContextsManager } =========================================\r\n\r\nfunction TJvBaseDataContextsManager.Contexts: IJvDataContexts;\r\nbegin\r\n Result := Owner as IJvDataContexts;\r\nend;\r\n\r\nfunction TJvBaseDataContextsManager.ContextsImpl: TJvBaseDataContexts;\r\nbegin\r\n Result := Owner as TJvBaseDataContexts;\r\nend;\r\n\r\nfunction TJvBaseDataContextsManager.Add(Context: IJvDataContext): IJvDataContext;\r\nbegin\r\n Result := Context;\r\n ContextsImpl.DoAddContext(Result);\r\nend;\r\n\r\nprocedure TJvBaseDataContextsManager.Delete(Context: IJvDataContext);\r\nbegin\r\n ContextsImpl.DoRemoveContext(Context);\r\nend;\r\n\r\nprocedure TJvBaseDataContextsManager.Clear;\r\nbegin\r\n ContextsImpl.DoClearContexts;\r\nend;\r\n\r\n//=== { TJvBaseDataContext } =================================================\r\n\r\nconstructor TJvBaseDataContext.Create(AContexts: TJvBaseDataContexts; AName: string);\r\nbegin\r\n if AContexts <> nil then\r\n begin\r\n inherited Create;\r\n FContexts := AContexts;\r\n SetName(AName);\r\n end\r\n else\r\n raise EJVCLDataContexts.CreateRes(@RsECannotCreateAContextWithoutAContext);\r\nend;\r\n\r\nprocedure TJvBaseDataContext.SetName(Value: string);\r\nvar\r\n ExistingContext: IJvDataContext;\r\nbegin\r\n if Value <> Name then\r\n begin\r\n ExistingContext := Contexts.GetContextByName(Value);\r\n if (ExistingContext = nil) or (ExistingContext = (Self as IJvDataContext)) then\r\n DoSetName(Value)\r\n else\r\n raise EJVCLDataContexts.CreateRes(@RsEAContextWithThatNameAlreadyExists);\r\n end;\r\nend;\r\n\r\nfunction TJvBaseDataContext.GetImplementer: TObject;\r\nbegin\r\n Result := Self;\r\nend;\r\n\r\nfunction TJvBaseDataContext.ContextsImpl: TJvBaseDataContexts;\r\nbegin\r\n Result := FContexts;\r\nend;\r\n\r\nfunction TJvBaseDataContext.Contexts: IJvDataContexts;\r\nbegin\r\n Result := FContexts;\r\nend;\r\n\r\nfunction TJvBaseDataContext.IsDeletable: Boolean;\r\nbegin\r\n Result := True;\r\nend;\r\n\r\nfunction TJvBaseDataContext.IsStreamable: Boolean;\r\nbegin\r\n Result := not IsDeletable;\r\nend;\r\n\r\n//=== { TJvBaseFixedDataContext } ============================================\r\n\r\nfunction TJvBaseFixedDataContext.IsDeletable: Boolean;\r\nbegin\r\n Result := False;\r\nend;\r\n\r\n//=== { TJvDataContexts } ====================================================\r\n\r\nconstructor TJvDataContexts.Create(AProvider: IJvDataProvider; AAncestor: IJvDataContext;\r\n ManagerClass: TJvDataContextsManagerClass);\r\nbegin\r\n inherited Create(AProvider, AAncestor, ManagerClass);\r\n FContexts := TInterfaceList.Create;\r\nend;\r\n\r\ndestructor TJvDataContexts.Destroy;\r\nbegin\r\n FreeAndNil(FContexts);\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvDataContexts.DoAddContext(Context: IJvDataContext);\r\nvar\r\n Tmp: IJvDataContext;\r\nbegin\r\n Tmp := GetContextByName(Context.Name);\r\n if Tmp = nil then\r\n begin\r\n Provider.Changing(pcrContextAdd, Ancestor);\r\n FContexts.Add(Context);\r\n Provider.Changed(pcrContextAdd, Context);\r\n end\r\n else\r\n begin\r\n if Tmp <> Context then\r\n raise EJVCLDataContexts.CreateRes(@RsEAContextWithThatNameAlreadyExists);\r\n end;\r\nend;\r\n\r\nprocedure TJvDataContexts.DoDeleteContext(Index: Integer);\r\nvar\r\n Ctx: IJvDataContext;\r\n Anc: IJvDataContext;\r\nbegin\r\n Ctx := GetContext(Index);\r\n if (Ctx <> nil) and Ctx.IsDeletable then\r\n begin\r\n Anc := Ctx.Contexts.Ancestor;\r\n Provider.Changing(pcrContextDelete, Ctx);\r\n Ctx := nil;\r\n FContexts.Delete(Index);\r\n Provider.Changed(pcrContextDelete, Anc);\r\n end;\r\nend;\r\n\r\nprocedure TJvDataContexts.DoRemoveContext(Context: IJvDataContext);\r\nvar\r\n Idx: Integer;\r\nbegin\r\n Idx := GetCount - 1;\r\n while (Idx >= 0) and (GetContext(Idx) <> Context) do\r\n Dec(Idx);\r\n if Idx >= 0 then\r\n DoDeleteContext(Idx);\r\nend;\r\n\r\nprocedure TJvDataContexts.DoClearContexts;\r\nbegin\r\n FContexts.Clear;\r\nend;\r\n\r\nfunction TJvDataContexts.GetCount: Integer;\r\nbegin\r\n Result := FContexts.Count;\r\nend;\r\n\r\nfunction TJvDataContexts.GetContext(Index: Integer): IJvDataContext;\r\nbegin\r\n Result := IJvDataContext(FContexts[Index]);\r\nend;\r\n\r\n//=== { TJvDataContext } =====================================================\r\n\r\nprocedure TJvDataContext.DoSetName(Value: string);\r\nbegin\r\n FName := Value;\r\nend;\r\n\r\nfunction TJvDataContext.Name: string;\r\nbegin\r\n Result := FName;\r\nend;\r\n\r\n//=== { TJvFixedDataContext } ================================================\r\n\r\nfunction TJvFixedDataContext.IsDeletable: Boolean;\r\nbegin\r\n Result := False;\r\nend;\r\n\r\n//=== { TJvDataConsumer } ====================================================\r\n\r\nconstructor TJvDataConsumer.Create(AOwner: TComponent; Attributes: array of Integer);\r\nvar\r\n I: Integer;\r\nbegin\r\n inherited Create;\r\n FOwner := AOwner;\r\n FServerList := TInterfaceList.Create;\r\n for I := Low(Attributes) to High(Attributes) do\r\n DoAddAttribute(Attributes[I]);\r\nend;\r\n\r\ndestructor TJvDataConsumer.Destroy;\r\nbegin\r\n // detach event handlers to avoid AVs when destroying\r\n FOnChanged := nil;\r\n FOnProviderChanging := nil;\r\n FOnProviderChanged := nil;\r\n FAfterCreateSubSvc := nil;\r\n FBeforeCreateSubSvc := nil;\r\n Provider := nil;\r\n FreeAndNil(FServerList);\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvDataConsumer.SetProvider(Value: IJvDataProvider);\r\nvar\r\n CtxList: IJvDataContexts;\r\nbegin\r\n if FProvider <> Value then\r\n begin\r\n Changing(ccrProviderSelect);\r\n if FProvider <> nil then\r\n FProvider.UnregisterChangeNotify(Self);\r\n ProviderChanging;\r\n FProvider := Value;\r\n if FProvider <> nil then\r\n FProvider.RegisterChangeNotify(Self);\r\n if NeedContextFixup then\r\n FixupContext\r\n else\r\n begin\r\n if Supports(ProviderIntf, IJvDataContexts, CtxList) and (CtxList.GetCount >0 ) then\r\n SetContextIntf(CtxList.GetContext(0))\r\n else\r\n SetContextIntf(nil);\r\n end;\r\n ProviderChanged;\r\n NotifyServerProviderChanged;\r\n if NeedExtensionFixups then\r\n FixupExtensions;\r\n ViewChanged(nil);\r\n Changed(ccrProviderSelect);\r\n end;\r\nend;\r\n\r\nfunction TJvDataConsumer._AddRef: Integer;\r\nbegin\r\n Result := -1;\r\nend;\r\n\r\nfunction TJvDataConsumer._Release: Integer;\r\nbegin\r\n Result := -1;\r\nend;\r\n\r\nprocedure TJvDataConsumer.DoProviderChanging(ADataProvider: IJvDataProvider;\r\n AReason: TDataProviderChangeReason; Source: IUnknown);\r\nbegin\r\n if Assigned(FOnProviderChanging) then\r\n OnProviderChanging(ADataProvider, AReason, Source);\r\nend;\r\n\r\nprocedure TJvDataConsumer.DoProviderChanged(ADataProvider: IJvDataProvider;\r\n AReason: TDataProviderChangeReason; Source: IUnknown);\r\nbegin\r\n if Assigned(FOnProviderChanged) then\r\n OnProviderChanged(ADataProvider, AReason, Source);\r\nend;\r\n\r\nprocedure TJvDataConsumer.DoAfterCreateSubSvc(ASvc: TJvDataConsumerAggregatedObject);\r\nbegin\r\n if Assigned(FAfterCreateSubSvc) then\r\n AfterCreateSubSvc(Self, ASvc);\r\nend;\r\n\r\nprocedure TJvDataConsumer.DoBeforeCreateSubSvc(var AClass: TJvDataConsumerAggregatedObjectClass);\r\nbegin\r\n if Assigned(FBeforeCreateSubSvc) then\r\n BeforeCreateSubSvc(Self, AClass);\r\nend;\r\n\r\nprocedure TJvDataConsumer.DoChanging(Reason: TJvDataConsumerChangeReason);\r\nbegin\r\n if Assigned(FOnChanging) then\r\n OnChanging(Self, Reason);\r\nend;\r\n\r\nprocedure TJvDataConsumer.DoChanged(Reason: TJvDataConsumerChangeReason);\r\nbegin\r\n if Assigned(FOnChanged) then\r\n OnChanged(Self, Reason);\r\nend;\r\n\r\nprocedure TJvDataConsumer.DoAddAttribute(Attr: Integer);\r\nbegin\r\n if not AttributeApplies(Attr) then\r\n begin\r\n SetLength(FAttrList, Length(FAttrList) + 1);\r\n FAttrList[High(FAttrList)] := Attr;\r\n end;\r\nend;\r\n\r\nprocedure TJvDataConsumer.Changing(Reason: TJvDataConsumerChangeReason);\r\nbegin\r\n DoChanging(Reason);\r\nend;\r\n\r\nprocedure TJvDataConsumer.Changed(Reason: TJvDataConsumerChangeReason);\r\nbegin\r\n if VCLComponent is TControl then\r\n TControl(VCLComponent).Invalidate;\r\n DoChanged(Reason);\r\nend;\r\n\r\nprocedure TJvDataConsumer.ProviderChanging;\r\nvar\r\n I: Integer;\r\nbegin\r\n if FAdditionalIntfImpl <> nil then\r\n begin\r\n if not FNeedFixups and (FFixupContext = '') then\r\n begin\r\n I := 0;\r\n while I < ExtensionCount do\r\n begin\r\n Extension(I).ProviderChanging;\r\n Inc(I);\r\n end\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvDataConsumer.ProviderChanged;\r\nvar\r\n I: Integer;\r\nbegin\r\n if FAdditionalIntfImpl <> nil then\r\n begin\r\n if not FNeedFixups and (FFixupContext = '') then\r\n begin\r\n I := 0;\r\n while I < ExtensionCount do\r\n begin\r\n if Extension(I).StreamedInWithoutProvider or Extension(I).KeepOnProviderChange then\r\n begin\r\n Extension(I).ProviderChanged;\r\n Inc(I);\r\n end\r\n else\r\n RemoveIntfImpl(Extension(I));\r\n end;\r\n end;\r\n UpdateExtensions;\r\n end;\r\nend;\r\n\r\nprocedure TJvDataConsumer.ContextChanging;\r\nvar\r\n I: Integer;\r\nbegin\r\n if FAdditionalIntfImpl <> nil then\r\n begin\r\n if not FNeedFixups and (FFixupContext = '') then\r\n begin\r\n I := 0;\r\n while I < ExtensionCount do\r\n begin\r\n Extension(I).ContextChanging;\r\n Inc(I);\r\n end\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvDataConsumer.ContextChanged;\r\nvar\r\n I: Integer;\r\nbegin\r\n if FAdditionalIntfImpl <> nil then\r\n begin\r\n if not FNeedFixups and (FFixupContext = '') then\r\n begin\r\n I := 0;\r\n while I < ExtensionCount do\r\n begin\r\n if Extension(I).StreamedInWithoutProvider or Extension(I).KeepOnContextChange then\r\n begin\r\n Extension(I).ContextChanged;\r\n Inc(I);\r\n end\r\n else\r\n RemoveIntfImpl(Extension(I));\r\n end;\r\n end;\r\n UpdateExtensions;\r\n end;\r\nend;\r\n\r\nprocedure TJvDataConsumer.AfterSubSvcAdded(ASvc: TJvDataConsumerAggregatedObject);\r\nbegin\r\n DoAfterCreateSubSvc(ASvc);\r\n if ASvc is TJvCustomDataConsumerViewList then\r\n TJvCustomDataConsumerViewList(ASvc).RebuildView\r\nend;\r\n\r\nprocedure TJvDataConsumer.UpdateExtensions;\r\nvar\r\n ImplArray: TClassArray;\r\n I: Integer;\r\n TmpClass: TJvDataConsumerAggregatedObjectClass;\r\nbegin\r\n SetLength(ImplArray, 0);\r\n if ProviderIntf <> nil then\r\n begin\r\n DP_SelectConsumerContext(ProviderIntf, Self, ContextIntf);\r\n try\r\n ImplArray := ProviderIntf.ConsumerClasses;\r\n finally\r\n DP_ReleaseConsumerContext(ProviderIntf);\r\n end;\r\n for I := Low(ImplArray) to High(ImplArray) do\r\n begin\r\n TmpClass := TJvDataConsumerAggregatedObjectClass(ImplArray[I]);\r\n if IndexOfImplClass(TmpClass) < 0 then\r\n begin\r\n DoBeforeCreateSubSvc(TmpClass);\r\n if TmpClass <> nil then\r\n DoAfterCreateSubSvc(TmpClass.Create(Self));\r\n end;\r\n end;\r\n if AttributeApplies(DPA_ConsumerDisplaysList) then\r\n begin\r\n TmpClass := TJvDataConsumerViewList;\r\n if IndexOfImplClass(TJvDataConsumerViewList) < 0 then\r\n begin\r\n DoBeforeCreateSubSvc(TmpClass);\r\n if TmpClass <> nil then\r\n AfterSubSvcAdded(TmpClass.Create(Self));\r\n end;\r\n end;\r\n end\r\n else\r\n ClearIntfImpl;\r\nend;\r\n\r\nprocedure TJvDataConsumer.FixupExtensions;\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := 0 to ExtensionCount - 1 do\r\n Extension(I).Fixup;\r\n FNeedFixups := False;\r\nend;\r\n\r\nprocedure TJvDataConsumer.FixupContext;\r\nbegin\r\n Context := FFixupContext;\r\n FFixupContext := '';\r\nend;\r\n\r\nprocedure TJvDataConsumer.ViewChanged(AExtension: TJvDataConsumerAggregatedObject);\r\nvar\r\n I: Integer;\r\nbegin\r\n try\r\n for I := 0 to ExtensionCount - 1 do\r\n if Extension(I) <> AExtension then\r\n Extension(I).ViewChanged(AExtension);\r\n finally\r\n Changed(ccrViewChange);\r\n end;\r\nend;\r\n\r\nprocedure TJvDataConsumer.NotifyItemSelected(Value: IJvDataItem);\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := 0 to ExtensionCount - 1 do\r\n Extension(I).ItemSelected(Value);\r\nend;\r\n\r\nprocedure TJvDataConsumer.NotifyServerItemChanged(Server: IJvDataConsumerServerNotify;\r\n Value: IJvDataItem);\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := 0 to ExtensionCount - 1 do\r\n Extension(I).ServerItemChanged(Server, Value);\r\nend;\r\n\r\nprocedure TJvDataConsumer.NotifyServerProviderChanged;\r\nvar\r\n I: Integer;\r\nbegin\r\n if not IsLoading then\r\n for I := 0 to ServerCount - 1 do\r\n Servers[I].NotifyProviderChanged(Self);\r\nend;\r\n\r\nfunction TJvDataConsumer.ExtensionCount: Integer;\r\nbegin\r\n Result := FAdditionalIntfImpl.Count;\r\nend;\r\n\r\nfunction TJvDataConsumer.Extension(Index: Integer): TJvDataConsumerAggregatedObject;\r\nbegin\r\n Result := TJvDataConsumerAggregatedObject(FAdditionalIntfImpl[Index]);\r\nend;\r\n\r\nfunction TJvDataConsumer.IsContextStored: Boolean;\r\nvar\r\n CtxList: IJvDataContexts;\r\nbegin\r\n Result := (ProviderIntf <> nil) and Supports(ProviderIntf, IJvDataContexts, CtxList) and\r\n (CtxList.GetCount > 0) and (ContextIntf <> CtxList.GetContext(0));\r\nend;\r\n\r\nfunction TJvDataConsumer.GetNeedExtensionFixups: Boolean;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := FNeedFixups and ((VCLComponent = nil) or\r\n not (csLoading in VCLComponent.ComponentState));\r\n if not Result then\r\n begin\r\n I := ExtensionCount - 1;\r\n while not Result and (I >= 0) do\r\n begin\r\n Result := Extension(I).StreamedInWithoutProvider;\r\n Dec(I);\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJvDataConsumer.GetNeedContextFixup: Boolean;\r\nbegin\r\n Result := (FFixupContext <> '') and ((VCLComponent = nil) or\r\n not (csLoading in VCLComponent.ComponentState));\r\nend;\r\n\r\nfunction TJvDataConsumer.GetContext: TJvDataContextID;\r\nbegin\r\n if FContext = nil then\r\n Result := ''\r\n else\r\n Result := FContext.Name;\r\nend;\r\n\r\nprocedure TJvDataConsumer.SetContext(Value: TJvDataContextID);\r\nvar\r\n ContextsIntf: IJvDataContexts;\r\n ContextIntf: IJvDataContext;\r\nbegin\r\n if not AnsiSameStr(Value, GetContext) then\r\n begin\r\n if ProviderIntf = nil then\r\n begin\r\n if (VCLComponent <> nil) and (csLoading in VCLComponent.ComponentState) then\r\n FFixupContext := Value\r\n else\r\n raise EJVCLDataConsumer.CreateRes(@RsEYouMustSpecifyAProviderBeforeSettin);\r\n end\r\n else\r\n begin\r\n if Value <> '' then\r\n begin\r\n if Supports(ProviderIntf, IJvDataContexts, ContextsIntf) then\r\n begin\r\n ContextIntf := ContextsIntf.GetContextByName(Value);\r\n if ContextIntf <> nil then\r\n SetContextIntf(ContextIntf)\r\n else\r\n raise EJVCLDataConsumer.CreateResFmt(@RsEProviderHasNoContextNameds, [Value]);\r\n end\r\n else\r\n raise EJVCLDataConsumer.CreateRes(@RsEProviderDoesNotSupportContexts);\r\n end\r\n else\r\n SetContextIntf(nil);\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJvDataConsumer.GetServerCount: Integer;\r\nbegin\r\n Result := FServerList.Count;\r\nend;\r\n\r\nfunction TJvDataConsumer.GetServers(I: Integer): IJvDataConsumerServerNotify;\r\nbegin\r\n Result := IJvDataConsumerServerNotify(FServerList[I]);\r\nend;\r\n\r\nprocedure TJvDataConsumer.DataProviderChanging(const ADataProvider: IJvDataProvider;\r\n AReason: TDataProviderChangeReason; Source: IUnknown);\r\nvar\r\n I: Integer;\r\nbegin\r\n DoProviderChanging(ADataProvider, AReason, Source);\r\n for I := 0 to ExtensionCount - 1 do\r\n Extension(I).DataProviderChanging(ADataProvider, AReason, Source);\r\n if AReason = pcrDestroy then\r\n Provider := nil;\r\nend;\r\n\r\nprocedure TJvDataConsumer.DataProviderChanged(const ADataProvider: IJvDataProvider;\r\n AReason: TDataProviderChangeReason; Source: IUnknown);\r\nvar\r\n I: Integer;\r\nbegin\r\n DoProviderChanged(ADataProvider, AReason, Source);\r\n for I := 0 to ExtensionCount - 1 do\r\n Extension(I).DataProviderChanged(ADataProvider, AReason, Source);\r\n if AReason = pcrFullRefresh then\r\n ViewChanged(nil)\r\n else\r\n Changed(ccrProviderChange);\r\nend;\r\n\r\nfunction TJvDataConsumer.Consumer: IJvDataConsumer;\r\nbegin\r\n Result := Self;\r\nend;\r\n\r\nfunction TJvDataConsumer.VCLComponent: TComponent;\r\nbegin\r\n Result := FOwner;\r\nend;\r\n\r\nfunction TJvDataConsumer.AttributeApplies(Attr: Integer): Boolean;\r\nvar\r\n I: Integer;\r\nbegin\r\n I := High(FAttrList);\r\n while (I >= 0) and (FAttrList[I] <> Attr) do\r\n Dec(I);\r\n Result := I >= 0;\r\nend;\r\n\r\nprocedure TJvDataConsumer.ServerItemChanged(Server: IJvDataConsumerServerNotify; Value: IJvDataItem);\r\nbegin\r\n NotifyServerItemChanged(Server, Value);\r\nend;\r\n\r\nprocedure TJvDataConsumer.LinkAdded(Server: IJvDataConsumerServerNotify);\r\nbegin\r\n FServerList.Add(Server);\r\nend;\r\n\r\nprocedure TJvDataConsumer.LinkRemoved(Server: IJvDataConsumerServerNotify);\r\nbegin\r\n FServerList.Remove(Server);\r\nend;\r\n\r\nfunction TJvDataConsumer.ProviderIntf: IJvDataProvider;\r\nbegin\r\n Result := FProvider;\r\nend;\r\n\r\nprocedure TJvDataConsumer.SetProviderIntf(Value: IJvDataProvider);\r\nbegin\r\n SetProvider(Value);\r\nend;\r\n\r\nfunction TJvDataConsumer.ContextIntf: IJvDataContext;\r\nbegin\r\n Result := FContext;\r\nend;\r\n\r\nprocedure TJvDataConsumer.SetContextIntf(Value: IJvDataContext);\r\nbegin\r\n if Value <> ContextIntf then\r\n begin\r\n if (Value <> nil) and (Value.Contexts.Provider <> ProviderIntf) then\r\n raise EJVCLDataConsumer.CreateRes(@RsETheSpecifiedContextIsNotPartOfTheSa);\r\n Changing(ccrContextChange);\r\n ContextChanging;\r\n FContext := Value;\r\n ContextChanged;\r\n Changed(ccrContextChange);\r\n end;\r\nend;\r\n\r\nprocedure TJvDataConsumer.Loaded;\r\nbegin\r\n if FFixupContext <> '' then\r\n begin\r\n Context := FFixupContext;\r\n FFixupContext := '';\r\n end;\r\n if FNeedFixups then\r\n begin\r\n FixupExtensions;\r\n FNeedFixups := False;\r\n end;\r\nend;\r\n\r\nprocedure TJvDataConsumer.Enter;\r\nbegin\r\n DP_SelectConsumerContext(ProviderIntf, Self, ContextIntf);\r\nend;\r\n\r\nprocedure TJvDataConsumer.Leave;\r\nbegin\r\n DP_ReleaseConsumerContext(ProviderIntf);\r\nend;\r\n\r\nprocedure TJvDataConsumer.ItemSelected(Value: IJvDataItem);\r\nvar\r\n ItemAct: IJvDataItemBasicAction;\r\nbegin\r\n NotifyItemSelected(Value);\r\n if Supports(Value, IJvDataItemBasicAction, ItemAct) then\r\n ItemAct.Execute(VCLComponent);\r\nend;\r\n\r\nfunction TJvDataConsumer.IsLoading: Boolean;\r\nbegin\r\n Result := NeedExtensionFixups or NeedContextFixup;\r\nend;\r\n\r\n//=== { TJvDataConsumerAggregatedObject } ====================================\r\n\r\nprocedure TJvDataConsumerAggregatedObject.DataProviderChanging(ADataProvider: IJvDataProvider;\r\n AReason: TDataProviderChangeReason; Source: IUnknown);\r\nbegin\r\nend;\r\n\r\nprocedure TJvDataConsumerAggregatedObject.DataProviderChanged(ADataProvider: IJvDataProvider;\r\n AReason: TDataProviderChangeReason; Source: IUnknown);\r\nbegin\r\nend;\r\n\r\nprocedure TJvDataConsumerAggregatedObject.Fixup;\r\nbegin\r\nend;\r\n\r\nfunction TJvDataConsumerAggregatedObject.KeepOnProviderChange: Boolean;\r\nbegin\r\n Result := False;\r\nend;\r\n\r\nfunction TJvDataConsumerAggregatedObject.KeepOnContextChange: Boolean;\r\nbegin\r\n Result := True;\r\nend;\r\n\r\nprocedure TJvDataConsumerAggregatedObject.Changing(Reason: TJvDataConsumerChangeReason);\r\nbegin\r\n ConsumerImpl.Changing(Reason);\r\nend;\r\n\r\nprocedure TJvDataConsumerAggregatedObject.Changed(Reason: TJvDataConsumerChangeReason);\r\nbegin\r\n StreamedInWithoutProvider := ConsumerImpl.ProviderIntf = nil;\r\n ConsumerImpl.Changed(Reason);\r\nend;\r\n\r\nprocedure TJvDataConsumerAggregatedObject.NotifyViewChanged;\r\nbegin\r\n ConsumerImpl.ViewChanged(Self);\r\nend;\r\n\r\nprocedure TJvDataConsumerAggregatedObject.ViewChanged(AExtension: TJvDataConsumerAggregatedObject);\r\nbegin\r\nend;\r\n\r\nprocedure TJvDataConsumerAggregatedObject.ItemSelected(Value: IJvDataItem);\r\nbegin\r\nend;\r\n\r\nprocedure TJvDataConsumerAggregatedObject.ServerItemChanged(Server: IJvDataConsumerServerNotify;\r\n Value: IJvDataItem);\r\nbegin\r\nend;\r\n\r\nprocedure TJvDataConsumerAggregatedObject.NotifyFixups;\r\nbegin\r\n ConsumerImpl.FNeedFixups := True;\r\n StreamedInWithoutProvider := True;\r\nend;\r\n\r\nprocedure TJvDataConsumerAggregatedObject.ProviderChanging;\r\nbegin\r\nend;\r\n\r\nprocedure TJvDataConsumerAggregatedObject.ProviderChanged;\r\nbegin\r\nend;\r\n\r\nprocedure TJvDataConsumerAggregatedObject.ContextChanging;\r\nbegin\r\nend;\r\n\r\nprocedure TJvDataConsumerAggregatedObject.ContextChanged;\r\nbegin\r\nend;\r\n\r\nfunction TJvDataConsumerAggregatedObject.Consumer: IJvDataConsumer;\r\nbegin\r\n Result := Owner as IJvDataConsumer;\r\nend;\r\n\r\nfunction TJvDataConsumerAggregatedObject.ConsumerImpl: TJvDataConsumer;\r\nbegin\r\n Result := Owner as TJvDataConsumer;\r\nend;\r\n\r\nfunction TJvDataConsumerAggregatedObject.RootItems: IJvDataItems;\r\nvar\r\n RootSelect: IJvDataConsumerItemSelect;\r\nbegin\r\n if Supports(Consumer, IJvDataConsumerItemSelect, RootSelect) and (RootSelect.GetItem <> nil) then\r\n RootSelect.GetItem.QueryInterface(IJvDataItems, Result)\r\n else\r\n ConsumerImpl.ProviderIntf.QueryInterface(IJvDataItems, Result);\r\nend;\r\n\r\n//=== { TJvDataConsumerContext } =============================================\r\n\r\nfunction TJvDataConsumerContext.GetContextID: TJvDataContextID;\r\nbegin\r\n Result := ConsumerImpl.Context;\r\nend;\r\n\r\nprocedure TJvDataConsumerContext.SetContextID(Value: TJvDataContextID);\r\nbegin\r\n ConsumerImpl.Context := Value;\r\nend;\r\n\r\nfunction TJvDataConsumerContext.GetContext: IJvDataContext;\r\nbegin\r\n Result := ConsumerImpl.ContextIntf;\r\nend;\r\n\r\nprocedure TJvDataConsumerContext.SetContext(Value: IJvDataContext);\r\nbegin\r\n ConsumerImpl.SetContextIntf(Value);\r\nend;\r\n\r\n//=== { TJvDataConsumerItemSelect } ==========================================\r\n\r\nprocedure TJvDataConsumerItemSelect.Fixup;\r\nbegin\r\n SetItem(FItemID);\r\n FItemID := '';\r\nend;\r\n\r\nfunction TJvDataConsumerItemSelect.GetItem: TJvDataItemID;\r\nbegin\r\n if GetItemIntf = nil then\r\n Result := ''\r\n else\r\n Result := GetItemIntf.GetID;\r\nend;\r\n\r\nprocedure TJvDataConsumerItemSelect.SetItem(Value: TJvDataItemID);\r\nvar\r\n TmpItem: IJvDataItem;\r\nbegin\r\n if not AnsiSameStr(Value, GetItem) then\r\n begin\r\n if Value = '' then\r\n SetItemIntf(nil)\r\n else\r\n begin\r\n if ConsumerImpl.ProviderIntf = nil then\r\n begin\r\n if (Consumer.VCLComponent <> nil) and (csLoading in Consumer.VCLComponent.ComponentState) then\r\n begin\r\n FItemID := Value;\r\n NotifyFixups;\r\n Exit;\r\n end\r\n else\r\n raise EJVCLDataConsumer.CreateRes(@RsEYouMustSpecifyAProviderBeforeSettin_);\r\n end\r\n else\r\n begin\r\n ConsumerImpl.Enter;\r\n try\r\n TmpItem := (ConsumerImpl.ProviderIntf as IJvDataIDSearch).Find(Value, True);\r\n if TmpItem <> nil then\r\n SetItemIntf(TmpItem)\r\n else\r\n raise EJVCLDataConsumer.CreateRes(@RsEItemNotFoundInTheSelectedContext);\r\n finally\r\n ConsumerImpl.Leave;\r\n end;\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvDataConsumerItemSelect.DataProviderChanging(ADataProvider: IJvDataProvider;\r\n AReason: TDataProviderChangeReason; Source: IUnknown);\r\nvar\r\n SourceItem: IJvDataItem;\r\nbegin\r\n if AReason = pcrDelete then\r\n begin\r\n SourceItem := IJvDataItem(Source);\r\n if (SourceItem <> nil) and (GetItemIntf <> nil) then\r\n begin\r\n ConsumerImpl.Enter;\r\n try\r\n if (SourceItem = GetItemIntf) or (SourceItem.IsParentOf(GetItemIntf)) then\r\n FItem := nil;\r\n finally\r\n ConsumerImpl.Leave;\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvDataConsumerItemSelect.DataProviderChanged(ADataProvider: IJvDataProvider;\r\n AReason: TDataProviderChangeReason; Source: IUnknown);\r\nbegin\r\nend;\r\n\r\nfunction TJvDataConsumerItemSelect.GetItemIntf: IJvDataItem;\r\nbegin\r\n Result := FItem;\r\nend;\r\n\r\nprocedure TJvDataConsumerItemSelect.SetItemIntf(Value: IJvDataItem);\r\nbegin\r\n if Value <> GetItemIntf then\r\n begin\r\n FItem := Value;\r\n NotifyViewChanged;\r\n end;\r\nend;\r\n\r\n//=== { TJvCustomDataConsumerViewList } ======================================\r\n\r\nconstructor TJvCustomDataConsumerViewList.Create(AOwner: TExtensibleInterfacedPersistent);\r\nbegin\r\n inherited Create(AOwner);\r\n FLevelIndent := 16;\r\n if ConsumerImpl.ProviderIntf <> nil then\r\n RebuildView;\r\nend;\r\n\r\nfunction TJvCustomDataConsumerViewList.KeepOnProviderChange: Boolean;\r\nbegin\r\n Result := True;\r\nend;\r\n\r\nprocedure TJvCustomDataConsumerViewList.ProviderChanging;\r\nbegin\r\n ClearView;\r\nend;\r\n\r\nprocedure TJvCustomDataConsumerViewList.ProviderChanged;\r\nbegin\r\n RebuildView;\r\nend;\r\n\r\nprocedure TJvCustomDataConsumerViewList.ContextChanged;\r\nbegin\r\n RebuildView;\r\nend;\r\n\r\nprocedure TJvCustomDataConsumerViewList.ViewChanged(AExtension: TJvDataConsumerAggregatedObject);\r\nbegin\r\n RebuildView;\r\nend;\r\n\r\nprocedure TJvCustomDataConsumerViewList.DataProviderChanging(ADataProvider: IJvDataProvider;\r\n AReason: TDataProviderChangeReason; Source: IUnknown);\r\nvar\r\n ItemIdx: Integer;\r\nbegin\r\n case AReason of\r\n pcrDelete:\r\n begin\r\n // Source is a reference to the item being deleted\r\n if Source <> nil then\r\n begin\r\n ConsumerImpl.Enter;\r\n try\r\n if IJvDataItem(Source) <> nil then\r\n begin\r\n ItemIdx := IndexOfItem(IJvDataItem(Source));\r\n if ItemIdx >= 0 then\r\n begin\r\n DeleteItem(ItemIdx);\r\n NotifyViewChanged;\r\n end;\r\n end;\r\n finally\r\n ConsumerImpl.Leave;\r\n end;\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomDataConsumerViewList.DataProviderChanged(ADataProvider: IJvDataProvider;\r\n AReason: TDataProviderChangeReason; Source: IUnknown);\r\nvar\r\n ParItem: IJvDataItem;\r\n ParIdx: Integer;\r\nbegin\r\n case AReason of\r\n pcrAdd:\r\n begin\r\n // Source is a reference to the new item\r\n if Source <> nil then\r\n begin\r\n ConsumerImpl.Enter;\r\n try\r\n if IJvDataItem(Source) <> nil then\r\n begin\r\n ParItem := IJvDataItem(Source).GetItems.GetParent;\r\n if ParItem <> nil then\r\n begin\r\n ParIdx := IndexOfItem(ParItem);\r\n if (ParIdx < 0) and ExpandOnNewItem then\r\n begin\r\n // Make sure the tree is expanded up to the parent item\r\n ExpandTreeTo(ParItem);\r\n ParIdx := IndexOfItem(ParItem);\r\n end;\r\n if ParIdx >= 0 then\r\n begin\r\n if not ItemIsExpanded(ParIdx) and ExpandOnNewItem then\r\n begin\r\n // Expand parent item; will retrieve all sub items, including the newly added item\r\n if not ItemHasChildren(ParIdx) then\r\n UpdateItemFlags(ParIdx, vifHasChildren + vifCanHaveChildren,\r\n vifHasChildren + vifCanHaveChildren);\r\n ToggleItem(ParIdx);\r\n end\r\n else\r\n if ItemIsExpanded(ParIdx) then\r\n begin\r\n // parent is expanded, add the new item to the view.\r\n AddChildItem(ParIdx, IJvDataItem(Source));\r\n NotifyViewChanged;\r\n end;\r\n end;\r\n end\r\n else\r\n begin\r\n // Item at the root; always add it\r\n AddChildItem(-1, IJvDataItem(Source));\r\n NotifyViewChanged;\r\n end;\r\n end;\r\n finally\r\n ConsumerImpl.Leave;\r\n end;\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJvCustomDataConsumerViewList.InternalItemSibling(ParentIndex: Integer;\r\n var ScanIndex: Integer): Integer;\r\nvar\r\n Lvl: Integer;\r\nbegin\r\n Lvl := ItemLevel(ParentIndex);\r\n if ScanIndex <= ParentIndex then\r\n ScanIndex := ParentIndex + 1;\r\n while (ScanIndex < Count) and (ItemLevel(ScanIndex) > Lvl) do\r\n Inc(ScanIndex);\r\n if (ScanIndex >= Count) or (ItemLevel(ScanIndex) < Lvl) then\r\n Result := -1\r\n else\r\n Result := ScanIndex;\r\n if ScanIndex > Count then\r\n ScanIndex := Count;\r\nend;\r\n\r\nfunction TJvCustomDataConsumerViewList.Get_AutoExpandLevel: Integer;\r\nbegin\r\n Result := FAutoExpandLevel;\r\nend;\r\n\r\nprocedure TJvCustomDataConsumerViewList.Set_AutoExpandLevel(Value: Integer);\r\nbegin\r\n FAutoExpandLevel := Value;\r\nend;\r\n\r\nfunction TJvCustomDataConsumerViewList.Get_ExpandOnNewItem: Boolean;\r\nbegin\r\n Result := FExpandOnNewItem;\r\nend;\r\n\r\nprocedure TJvCustomDataConsumerViewList.Set_ExpandOnNewItem(Value: Boolean);\r\nbegin\r\n FExpandOnNewItem := Value;\r\nend;\r\n\r\nfunction TJvCustomDataConsumerViewList.Get_LevelIndent: Integer;\r\nbegin\r\n Result := FLevelIndent;\r\nend;\r\n\r\nprocedure TJvCustomDataConsumerViewList.Set_LevelIndent(Value: Integer);\r\nbegin\r\n if Value <> LevelIndent then\r\n begin\r\n FLevelIndent := Value;\r\n Changed(ccrOther);\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomDataConsumerViewList.ClearView;\r\nbegin\r\n // override if the implementation can be optimized\r\n while Count > 0 do\r\n DeleteItem(0);\r\nend;\r\n\r\nprocedure TJvCustomDataConsumerViewList.RebuildView;\r\nvar\r\n Idx: Integer;\r\nbegin\r\n ClearView;\r\n if (ConsumerImpl <> nil) and (ConsumerImpl.ProviderIntf <> nil) then\r\n begin\r\n ConsumerImpl.Enter;\r\n try\r\n Idx := 0;\r\n AddItems(Idx, RootItems, AutoExpandLevel);\r\n finally\r\n ConsumerImpl.Leave;\r\n end;\r\n end;\r\n NotifyViewChanged;\r\nend;\r\n\r\nprocedure TJvCustomDataConsumerViewList.ExpandTreeTo(Item: IJvDataItem);\r\nvar\r\n ParIdx: Integer;\r\nbegin\r\n if (Item <> nil) and (GetItemVisibleState(Item) <> disFalse) then\r\n begin\r\n if (IndexOfID(Item.GetID) >= 0) and (Item.Items.GetParent <> nil) then\r\n begin\r\n ExpandTreeTo(Item.GetItems.GetParent);\r\n ParIdx := IndexOfID(Item.GetItems.GetParent.GetID);\r\n if ParIdx >= 0 then\r\n begin\r\n if ItemIsExpanded(ParIdx) then // we have a big problem \r\n raise EJVCLDataConsumer.CreateRes(@RsEViewListOutOfSync);\r\n ToggleItem(ParIdx);\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure SetBit(var IntArray: array of Integer; BitNo: Integer);\r\nvar\r\n ArrayOffset: Integer;\r\n BitOffset: Integer;\r\nbegin\r\n ArrayOffset := BitNo div 32;\r\n BitOffset := BitNo mod 32;\r\n IntArray[ArrayOffset] := IntArray[ArrayOffset] or (1 shl BitOffset);\r\nend;\r\n\r\nfunction TJvCustomDataConsumerViewList.ItemGroupInfo(Index: Integer): TDynIntegerArray;\r\nvar\r\n LvlIdx: Integer;\r\n LastScanIndex: Integer;\r\nbegin\r\n LvlIdx := ItemLevel(Index) - 1;\r\n SetLength(Result, LvlIdx div 32 + Ord((LvlIdx mod 32) > 0));\r\n LastScanIndex := Index;\r\n { Keep using the last scanned item as a start point to find a sibling for the next parent. Reduces\r\n the number of compares to make. }\r\n while LvlIdx >= 0 do\r\n begin\r\n Index := ItemParentIndex(Index);\r\n if InternalItemSibling(Index, LastScanIndex) <> -1 then\r\n SetBit(Result, LvlIdx); // There's another sibling at this level; set the corresponding bit\r\n Dec(LvlIdx);\r\n end;\r\nend;\r\n\r\n//=== { TJvDataConsumerViewList } ============================================\r\n\r\nprocedure TJvDataConsumerViewList.AddItem(Index: Integer; Item: IJvDataItem; ExpandToLevel: Integer);\r\nvar\r\n Lvl: Integer;\r\n Idx: Integer;\r\n SubItems: IJvDataItems;\r\nbegin\r\n if GetItemVisibleState(Item) <> disFalse then\r\n begin\r\n if Index < 0 then\r\n begin\r\n Lvl := 0;\r\n Idx := Count;\r\n end\r\n else\r\n begin\r\n Lvl := Succ(ItemLevel(Index));\r\n Idx := Index + 1;\r\n if FViewItems[Index].Flags and (vifHasChildren + vifExpanded) = vifHasChildren then\r\n begin\r\n ToggleItem(Index);\r\n Exit;\r\n end;\r\n end;\r\n while (Idx < Count) and (ItemLevel(Idx) >= Lvl) do\r\n Inc(Idx);\r\n SetLength(FViewItems, Length(FViewItems) + 1);\r\n if Idx < High(FViewItems) then\r\n begin\r\n Move(FViewItems[Idx], FViewItems[Idx + 1], (High(FViewItems) - Idx) * SizeOf(FViewItems[0]));\r\n FillChar(FViewItems[Idx], SizeOf(FViewItems[0]), 0);\r\n end;\r\n with FViewItems[Idx] do\r\n begin\r\n ItemID := Item.GetID;\r\n if Supports(Item, IJvDataItems, SubItems) then\r\n begin\r\n if SubItems.Count > 0 then\r\n Flags := Lvl + vifHasChildren + vifCanHaveChildren\r\n else\r\n Flags := Lvl + vifCanHaveChildren\r\n end\r\n else\r\n Flags := Lvl;\r\n end;\r\n if Index > -1 then\r\n with FViewItems[Index] do\r\n Flags := Flags or vifHasChildren or vifCanHaveChildren or vifExpanded;\r\n if (ExpandToLevel <> 0) and (SubItems <> nil) and (SubItems.Count > 0) then\r\n begin\r\n Inc(Index);\r\n AddItems(Index, SubItems, ExpandToLevel - 1);\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvDataConsumerViewList.AddChildItem(ParentIndex: Integer; Item: IJvDataItem);\r\nvar\r\n InsertIndex: Integer;\r\nbegin\r\n if GetItemVisibleState(Item) <> disFalse then\r\n begin\r\n InsertIndex := -1;\r\n if ParentIndex > -1 then\r\n begin\r\n if not ItemIsExpanded(ParentIndex) then\r\n begin\r\n if not ItemHasChildren(ParentIndex) then\r\n UpdateItemFlags(ParentIndex, vifHasChildren + vifCanHaveChildren, vifHasChildren +\r\n vifCanHaveChildren);\r\n ToggleItem(ParentIndex);\r\n end;\r\n if IndexOfItem(Item) < 0 then\r\n InternalItemSibling(ParentIndex, InsertIndex);\r\n end\r\n else\r\n InsertIndex := Count;\r\n if InsertIndex > -1 then\r\n InsertItem(InsertIndex, ParentIndex, Item);\r\n end;\r\nend;\r\n\r\nprocedure TJvDataConsumerViewList.AddItems(var Index: Integer; Items: IJvDataItems; ExpandToLevel: Integer);\r\nvar\r\n SkipCount: Integer;\r\n I: Integer;\r\n J: Integer;\r\n SubItems: IJvDataItems;\r\nbegin\r\n J := Count;\r\n SetLength(FViewItems, Count + Items.Count);\r\n if Index < J then\r\n begin\r\n Move(FViewItems[Index], FViewItems[Index + Items.Count], (J - Index) * SizeOf(FViewItems[0]));\r\n FillChar(FViewItems[Index], Items.Count * SizeOf(FViewItems[0]), 0);\r\n end;\r\n J := 0;\r\n if Index > 0 then\r\n begin\r\n J := 1 + FViewItems[Index - 1].Flags and $00FFFFFF;\r\n FViewItems[Index - 1].Flags := FViewItems[Index - 1].Flags or vifExpanded;\r\n end;\r\n SkipCount := 0;\r\n for I := 0 to Items.Count - 1 do\r\n begin\r\n if GetItemVisibleState(Items.Items[I]) <> disFalse then\r\n begin\r\n with FViewItems[Index] do\r\n begin\r\n ItemID := Items.Items[I].GetID;\r\n Flags := J;\r\n if Supports(Items.Items[I], IJvDataItems, SubItems) then\r\n begin\r\n Flags := Flags + vifCanHaveChildren;\r\n if SubItems.Count > 0 then\r\n begin\r\n Flags := Flags + vifHasChildren;\r\n if ExpandToLevel <> 0 then\r\n begin\r\n Inc(Index);\r\n AddItems(Index, SubItems, ExpandToLevel - 1);\r\n Dec(Index);\r\n end;\r\n end;\r\n end;\r\n end;\r\n Inc(Index);\r\n end\r\n else\r\n Inc(SkipCount);\r\n end;\r\n if SkipCount > 0 then\r\n begin\r\n if Index < High(FViewItems) then\r\n Move(FViewItems[Index + 1], FViewItems[Index], SkipCount * SizeOf(FViewItems[0]));\r\n FillChar(FViewItems[Length(FViewItems) - SkipCount], SkipCount * SizeOf(FViewItems[0]), 0);\r\n SetLength(FViewItems, Length(FViewItems) - SkipCount);\r\n end;\r\nend;\r\n\r\nprocedure TJvDataConsumerViewList.InsertItem(InsertIndex, ParentIndex: Integer; Item: IJvDataItem);\r\nvar\r\n Level: Integer;\r\n SubItems: IJvDataItems;\r\nbegin\r\n if GetItemVisibleState(Item) <> disFalse then\r\n begin\r\n if ParentIndex < 0 then\r\n Level := 0\r\n else\r\n Level := Succ(ItemLevel(ParentIndex));\r\n SetLength(FViewItems, Count + 1);\r\n if InsertIndex < High(FViewItems) then\r\n begin\r\n Move(FViewItems[InsertIndex], FViewItems[InsertIndex + 1], (High(FViewItems) - InsertIndex) * SizeOf(FViewItems[0]));\r\n FillChar(FViewItems[InsertIndex], SizeOf(FViewItems[0]), 0);\r\n end;\r\n with FViewItems[InsertIndex] do\r\n begin\r\n ItemID := Item.GetID;\r\n if Supports(Item, IJvDataItems, SubItems) then\r\n begin\r\n Level := Level + vifCanHaveChildren;\r\n if SubItems.Count > 0 then\r\n Level := Level + vifHasChildren;\r\n end;\r\n Flags := Level;\r\n end;\r\n if ParentIndex >= 0 then\r\n FViewItems[ParentIndex].Flags := FViewItems[ParentIndex].Flags or (vifCanHaveChildren +\r\n vifHasChildren + vifExpanded);\r\n end;\r\nend;\r\n\r\nprocedure TJvDataConsumerViewList.DeleteItem(Index: Integer);\r\nvar\r\n PrevIsParent: Boolean;\r\nbegin\r\n DeleteItems(Index);\r\n PrevIsParent := (Index > 0) and (ItemLevel(Index - 1) = (ItemLevel(Index) - 1));\r\n FViewItems[Index].ItemID := '';\r\n if Index < High(FViewItems) then\r\n Move(FViewItems[Index + 1], FViewItems[Index], (Length(FViewItems) - Index) * SizeOf(FViewItems[0]));\r\n FillChar(FViewItems[High(FViewItems)], SizeOf(FViewItems[0]), 0);\r\n SetLength(FViewItems, High(FViewItems));\r\n if PrevIsParent and ((Index = Length(FViewItems)) or (ItemLevel(Index - 1) <> (ItemLevel(Index) - 1))) then\r\n FViewItems[Index - 1].Flags := FViewItems[Index - 1].Flags and not (vifHasChildren or vifExpanded);\r\nend;\r\n\r\nprocedure TJvDataConsumerViewList.DeleteItems(Index: Integer);\r\nvar\r\n Idx: Integer;\r\n Lvl: Integer;\r\nbegin\r\n if FViewItems[Index].Flags and (vifExpanded + vifHasChildren) = (vifExpanded + vifHasChildren) then\r\n begin\r\n Lvl := ItemLevel(Index) + 1;\r\n Idx := Index + 1;\r\n while (Idx < Length(FViewItems)) and (ItemLevel(Idx) >= Lvl) do\r\n begin\r\n FViewItems[Idx].ItemID := '';\r\n Inc(Idx);\r\n end;\r\n // Idx points to next item that is not a child\r\n if Idx < Count then\r\n Move(FViewItems[Idx], FViewItems[Index + 1], (Length(FViewItems) - Idx) * SizeOf(FViewItems[0]));\r\n FillChar(FViewItems[Length(FViewItems) - Pred(Idx - Index)], Pred(Idx - Index) * SizeOf(FViewItems[0]), 0);\r\n SetLength(FViewItems, Length(FViewItems) - (Idx - Index - 1));\r\n FViewItems[Index].Flags := FViewItems[Index].Flags and not vifExpanded;\r\n end;\r\nend;\r\n\r\nprocedure TJvDataConsumerViewList.UpdateItemFlags(Index: Integer; Value, Mask: Integer);\r\nbegin\r\n FViewItems[Index].Flags := FViewItems[Index].Flags and not Mask or (Value and Mask);\r\nend;\r\n\r\nprocedure TJvDataConsumerViewList.ToggleItem(Index: Integer);\r\nvar\r\n TmpItem: IJvDataItem;\r\n Items: IJvDataItems;\r\nbegin\r\n if ItemHasChildren(Index) then\r\n begin\r\n if ItemIsExpanded(Index) then\r\n DeleteItems(Index)\r\n else\r\n begin\r\n TmpItem := Item(Index);\r\n if (TmpItem <> nil) and Supports(TmpItem, IJvDataItems, Items) then\r\n begin\r\n Inc(Index);\r\n AddItems(Index, Items);\r\n end;\r\n end;\r\n NotifyViewChanged;\r\n end;\r\nend;\r\n\r\nfunction TJvDataConsumerViewList.IndexOfItem(Item: IJvDataItem): Integer;\r\nbegin\r\n Result := IndexOfID(Item.GetID);\r\nend;\r\n\r\nfunction TJvDataConsumerViewList.IndexOfID(ID: TJvDataItemID): Integer;\r\nbegin\r\n Result := Count - 1;\r\n while (Result >= 0) and not AnsiSameText(FViewItems[Result].ItemID, ID) do\r\n Dec(Result);\r\nend;\r\n\r\nfunction TJvDataConsumerViewList.ChildIndexOfItem(Item: IJvDataItem): Integer;\r\nbegin\r\n Result := ChildIndexOfID(Item.GetID);\r\nend;\r\n\r\nfunction TJvDataConsumerViewList.ChildIndexOfID(ID: TJvDataItemID): Integer;\r\nvar\r\n Index: Integer;\r\n ChildLevel: Integer;\r\nbegin\r\n Result := -1;\r\n Index := IndexOfID(ID);\r\n if Index >= 0 then\r\n begin\r\n Inc(Result);\r\n if Index > 0 then\r\n begin\r\n ChildLevel := ItemLevel(Index);\r\n Dec(Index);\r\n while (Index >= 0) and (ItemLevel(Index) >= ChildLevel) do\r\n begin\r\n if ItemLevel(Index) = ChildLevel then\r\n Inc(Result);\r\n Dec(Index);\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJvDataConsumerViewList.Item(Index: Integer): IJvDataItem;\r\nvar\r\n Items: IJvDataItems;\r\n Finder: IJvDataIDSearch;\r\n {$IFNDEF ViewList_UseFinder}\r\n ParIdx: Integer;\r\n {$ENDIF !ViewList_UseFinder}\r\nbegin\r\n {$IFDEF ViewList_UseFinder}\r\n { The easiest way: use IJvDataIDSearch to locate the item given it's ID value. Scans all items\r\n recursively until it finds a match or nothing at all. Could be rather slow on larger trees. }\r\n Items := RootItems;\r\n if Supports(RootItems, IJvDataIDSearch, Finder) then\r\n Result := Finder.Find(FViewItems[Index].ItemID, True);\r\n {$ELSE}\r\n { This should be faster, especially with larger trees. This will only scan the parent item's\r\n IJvDataItems list (the parent item is retrieved using this same method). This still saves a lot\r\n of ID comparisons in large trees and for dynamic items also an enormous amount of\r\n creation/destruction of items. The entire implementation of this class should be adapted to not\r\n store the ID but the item's index in the provider list, so we can streamline this method to use\r\n and index path only. }\r\n ParIdx := ItemParentIndex(Index);\r\n if ParIdx >= 0 then\r\n // Parent found, retrieve the IJVDataItems reference\r\n Item(ParIdx).QueryInterface(IJvDataItems, Items)\r\n else\r\n // Apparantly this item is at the root of the view; retrieve the proper IJvDataItems reference\r\n Items := RootItems;\r\n if Supports(Items, IJvDataIDSearch, Finder) then\r\n Result := Finder.Find(FViewItems[Index].ItemID, False);\r\n {$ENDIF ViewList_UseFinder}\r\nend;\r\n\r\nfunction TJvDataConsumerViewList.ItemLevel(Index: Integer): Integer;\r\nbegin\r\n Result := FViewItems[Index].Flags and $00FFFFFF;\r\nend;\r\n\r\nfunction TJvDataConsumerViewList.ItemIsExpanded(Index: Integer): Boolean;\r\nbegin\r\n Result := FViewItems[Index].Flags and vifExpanded <> 0;\r\nend;\r\n\r\nfunction TJvDataConsumerViewList.ItemHasChildren(Index: Integer): Boolean;\r\nbegin\r\n Result := FViewItems[Index].Flags and vifHasChildren <> 0;\r\nend;\r\n\r\nfunction TJvDataConsumerViewList.ItemParent(Index: Integer): IJvDataItem;\r\nvar\r\n ParIdx: Integer;\r\nbegin\r\n ParIdx := ItemParentIndex(Index);\r\n if ParIdx >= 0 then\r\n Result := Item(ParIdx);\r\nend;\r\n\r\nfunction TJvDataConsumerViewList.ItemParentIndex(Index: Integer): Integer;\r\nvar\r\n ParLevel: Integer;\r\nbegin\r\n ParLevel := ItemLevel(Index) - 1;\r\n Result := Index - 1;\r\n while (Result >= 0) and (ItemLevel(Result) > ParLevel) do\r\n Dec(Result);\r\nend;\r\n\r\nfunction TJvDataConsumerViewList.ItemSibling(Index: Integer): IJvDataItem;\r\nvar\r\n Idx: Integer;\r\nbegin\r\n Idx := ItemSiblingIndex(Index);\r\n if Idx > -1 then\r\n Result := Item(Idx)\r\n else\r\n Result := nil;\r\nend;\r\n\r\nfunction TJvDataConsumerViewList.ItemSiblingIndex(Index: Integer): Integer;\r\nbegin\r\n Result := InternalItemSibling(Index, Index);\r\nend;\r\n\r\nfunction TJvDataConsumerViewList.SubItem(Parent: IJvDataItem; Index: Integer): IJvDataItem;\r\nbegin\r\n Result := SubItem(IndexOfItem(Parent), Index);\r\nend;\r\n\r\nfunction TJvDataConsumerViewList.SubItem(Parent, Index: Integer): IJvDataItem;\r\nvar\r\n Idx: Integer;\r\nbegin\r\n Idx := SubItemIndex(Parent, Index);\r\n if Idx > -1 then\r\n Result := Item(Idx)\r\n else\r\n Result := nil;\r\nend;\r\n\r\nfunction TJvDataConsumerViewList.SubItemIndex(Parent: IJvDataItem; Index: Integer): Integer;\r\nbegin\r\n Result := SubItemIndex(IndexOfItem(Parent), Index);\r\nend;\r\n\r\nfunction TJvDataConsumerViewList.SubItemIndex(Parent, Index: Integer): Integer;\r\nbegin\r\n Result := Parent + 1;\r\n while (Result >= 0) and (Index >= 0) do\r\n begin\r\n Dec(Index);\r\n if Index >= 0 then\r\n Result := ItemSiblingIndex(Result);\r\n end;\r\nend;\r\n\r\nfunction TJvDataConsumerViewList.Count: Integer;\r\nbegin\r\n Result := Length(FViewItems);\r\nend;\r\n\r\n//=== { TJvDataConsumerServerNotify } ========================================\r\n\r\nconstructor TJvDataConsumerServerNotify.Create(AOwner: TExtensibleInterfacedPersistent);\r\nbegin\r\n inherited Create(AOwner);\r\n FClients := TJvDataConsumerClientNotifyList.Create(Self);\r\nend;\r\n\r\ndestructor TJvDataConsumerServerNotify.Destroy;\r\nbegin\r\n FreeAndNil(FClients);\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvDataConsumerServerNotify.SetClients(Value: TJvDataConsumerClientNotifyList);\r\nbegin\r\n if Value <> nil then\r\n FClients.Assign(Value)\r\n else\r\n FClients.Clear;\r\nend;\r\n\r\nprocedure TJvDataConsumerServerNotify.ItemSelected(Value: IJvDataItem);\r\nbegin\r\n { Default behavior: notify clients about the newly selected item. Override the method to take\r\n other action (either in addition to or instead of the default behavior). }\r\n NotifyItemSelected(Value);\r\nend;\r\n\r\nfunction TJvDataConsumerServerNotify.GetOwner: TPersistent;\r\nbegin\r\n // To make the collection editor actually show up.\r\n Result := ConsumerImpl.VCLComponent;\r\nend;\r\n\r\nprocedure TJvDataConsumerServerNotify.NotifyItemSelected(Value: IJvDataItem);\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := 0 to Clients.Count - 1 do\r\n if Clients.NotifyItems[I].Notifier <> nil then\r\n Clients.NotifyItems[I].Notifier.ItemSelected(Self, Value);\r\nend;\r\n\r\nfunction TJvDataConsumerServerNotify.IsValidClient(Client: IJvDataConsumerClientNotify): Boolean;\r\nbegin\r\n // Override this method to determine if the specified client can be linked to this server.\r\n Result := False;\r\nend;\r\n\r\nprocedure TJvDataConsumerServerNotify.AddClient(Client: IJvDataConsumerClientNotify);\r\nbegin\r\n if IsValidClient(Client) then\r\n FClients.Add(Client as IJvDataConsumer);\r\nend;\r\n\r\nprocedure TJvDataConsumerServerNotify.RemoveClient(Client: IJvDataConsumerClientNotify);\r\nbegin\r\n FClients.Delete(Client as IJvDataConsumer);\r\nend;\r\n\r\nprocedure TJvDataConsumerServerNotify.NotifyProviderChanged(Client: IJvDataConsumerClientNotify);\r\nbegin\r\n if not IsValidClient(Client) then\r\n RemoveClient(Client);\r\nend;\r\n\r\n//=== { TJvDataConsumerClientNotifyList } ====================================\r\n\r\nconstructor TJvDataConsumerClientNotifyList.Create(AServer: TJvDataConsumerServerNotify);\r\nbegin\r\n inherited Create(AServer.ConsumerImpl.VCLComponent, TJvDataConsumerClientNotifyItem);\r\n FServer := AServer;\r\nend;\r\n\r\nfunction TJvDataConsumerClientNotifyList.GetServer: TJvDataConsumerServerNotify;\r\nbegin\r\n Result := FServer;\r\nend;\r\n\r\nfunction TJvDataConsumerClientNotifyList.GetNotifyItems(\r\n I: Integer): TJvDataConsumerClientNotifyItem;\r\nbegin\r\n Result := TJvDataConsumerClientNotifyItem(Items[I]);\r\nend;\r\n\r\nfunction TJvDataConsumerClientNotifyList.GetConsumer(I: Integer): IJvDataConsumer;\r\nvar\r\n Item: TJvDataConsumerClientNotifyItem;\r\nbegin\r\n Item := GetNotifyItems(I);\r\n Supports(Item.Notifier, IJvDataConsumer, Result);\r\nend;\r\n\r\nprocedure TJvDataConsumerClientNotifyList.SetItemName(Item: TCollectionItem);\r\nbegin\r\n Server.StreamedInWithoutProvider := Server.ConsumerImpl.ProviderIntf = nil;\r\nend;\r\n\r\nprocedure TJvDataConsumerClientNotifyList.Add(AComponent: TComponent);\r\nvar\r\n PI: PPropInfo;\r\n Obj: TObject;\r\n Consumer: IJvDataConsumer;\r\nbegin\r\n if AComponent <> nil then\r\n begin\r\n PI := GetPropInfo(AComponent, cProvider);\r\n if PI <> nil then\r\n begin\r\n Obj := GetObjectProp(AComponent, cProvider);\r\n if (Obj <> nil) and Supports(Obj, IJvDataConsumer, Consumer) then\r\n Add(Consumer)\r\n else\r\n raise EJVCLDataConsumer.CreateResFmt(@RsEProviderIsNoIJvDataConsumer, [AComponent.Name]);\r\n end\r\n else\r\n raise EJVCLDataConsumer.CreateResFmt(@RsEComponentIsNotDataConsumer, [AComponent.Name]);\r\n end\r\n else\r\n raise EJVCLDataConsumer.CreateRes(@RsECannotAddNil);\r\nend;\r\n\r\nprocedure TJvDataConsumerClientNotifyList.Add(AConsumer: IJvDataConsumer);\r\nvar\r\n Notifier: IJvDataConsumerClientNotify;\r\nbegin\r\n if AConsumer <> nil then\r\n begin\r\n if IndexOf(AConsumer) = -1 then\r\n begin\r\n if Supports(AConsumer, IJvDataConsumerClientNotify, Notifier) then\r\n TJvDataConsumerClientNotifyItem.Create(Self).Notifier := Notifier\r\n else\r\n raise EJVCLDataConsumer.CreateRes(@RsEConsumerNoSupportIJvDataConsumerClientNotify);\r\n end;\r\n end\r\n else\r\n raise EJVCLDataConsumer.CreateRes(@RsECannotAddNil);\r\nend;\r\n\r\nprocedure TJvDataConsumerClientNotifyList.Delete(Index: Integer);\r\nbegin\r\n inherited Delete(Index);\r\nend;\r\n\r\nprocedure TJvDataConsumerClientNotifyList.Delete(AComponent: TComponent);\r\nvar\r\n Idx: Integer;\r\nbegin\r\n Idx := IndexOf(AComponent);\r\n if Idx > -1 then\r\n Delete(Idx);\r\nend;\r\n\r\nprocedure TJvDataConsumerClientNotifyList.Delete(AConsumer: IJvDataConsumer);\r\nvar\r\n Idx: Integer;\r\nbegin\r\n Idx := IndexOf(AConsumer);\r\n if Idx > -1 then\r\n Delete(Idx);\r\nend;\r\n\r\nfunction TJvDataConsumerClientNotifyList.IndexOf(AComponent: TComponent): Integer;\r\nbegin\r\n Result := Count - 1;\r\n while (Result >= 0) and (NotifyItems[Result].Component <> AComponent) do\r\n Dec(Result);\r\nend;\r\n\r\nfunction TJvDataConsumerClientNotifyList.IndexOf(AConsumer: IJvDataConsumer): Integer;\r\nbegin\r\n Result := Count - 1;\r\n while (Result >= 0) and (Clients[Result] <> AConsumer) do\r\n Dec(Result);\r\nend;\r\n\r\n//=== { TJvDataConsumerClientNotifyItem } ====================================\r\n\r\nfunction TJvDataConsumerClientNotifyItem.GetList: TJvDataConsumerClientNotifyList;\r\nbegin\r\n Result := TJvDataConsumerClientNotifyList(Collection);\r\nend;\r\n\r\nfunction TJvDataConsumerClientNotifyItem.GetConsumer: IJvDataConsumer;\r\nbegin\r\n Supports(FNotifier, IJvDataConsumer, Result);\r\nend;\r\n\r\nfunction TJvDataConsumerClientNotifyItem.GetComponent: TComponent;\r\nvar\r\n Con: IJvDataConsumer;\r\nbegin\r\n Con := GetConsumer;\r\n if Con <> nil then\r\n Result := Con.VCLComponent\r\n else\r\n Result := nil;\r\nend;\r\n\r\nprocedure TJvDataConsumerClientNotifyItem.SetComponent(Value: TComponent);\r\nvar\r\n PI: PPropInfo;\r\n Obj: TObject;\r\n Consumer: IJvDataConsumer;\r\n TmpNotifier: IJvDataConsumerClientNotify;\r\nbegin\r\n if Value <> Component then\r\n begin\r\n if Value <> nil then\r\n begin\r\n PI := GetPropInfo(Value, cProvider);\r\n if PI <> nil then\r\n begin\r\n Obj := GetObjectProp(Value, cProvider);\r\n if (Obj <> nil) and Supports(Obj, IJvDataConsumer, Consumer) then\r\n begin\r\n if Supports(Consumer, IJvDataConsumerClientNotify, TmpNotifier) then\r\n begin\r\n if Notifier <> nil then\r\n Notifier.LinkRemoved(List.Server);\r\n FNotifier := TmpNotifier;\r\n Notifier.LinkAdded(List.Server);\r\n end\r\n else\r\n raise EJVCLDataConsumer.CreateRes(@RsEConsumerNoSupportIJvDataConsumerClientNotify);\r\n end\r\n else\r\n raise EJVCLDataConsumer.CreateResFmt(@RsEProviderIsNoIJvDataConsumer, [Value.Name]);\r\n end\r\n else\r\n raise EJVCLDataConsumer.CreateResFmt(@RsEComponentIsNotDataConsumer, [Value.Name]);\r\n end\r\n else\r\n raise EJVCLDataConsumer.CreateRes(@RsECannotAddNil);\r\n end;\r\nend;\r\n\r\nprocedure TJvDataConsumerClientNotifyItem.SetNotifier(Value: IJvDataConsumerClientNotify);\r\nvar\r\n Consumer: IJvDataConsumer;\r\nbegin\r\n if Value <> Notifier then\r\n begin\r\n if Value <> nil then\r\n begin\r\n if Supports(Value, IJvDataConsumer, Consumer) then\r\n begin\r\n if Notifier <> nil then\r\n Notifier.LinkRemoved(List.Server);\r\n FNotifier := Value;\r\n Notifier.LinkAdded(List.Server);\r\n end\r\n else\r\n raise EJVCLDataConsumer.CreateRes(@RsENotifierNoSupprtIJvDataConsumer);\r\n end\r\n else\r\n raise EJVCLDataConsumer.CreateRes(@RsECannotAddNil);\r\n end;\r\nend;\r\n\r\nfunction TJvDataConsumerClientNotifyItem.GetDisplayName: string;\r\nbegin\r\n if (Component = nil) or (Component.Name = '') then\r\n Result := inherited GetDisplayName\r\n else\r\n Result := Component.Name;\r\nend;\r\n\r\ndestructor TJvDataConsumerClientNotifyItem.Destroy;\r\nbegin\r\n if Notifier <> nil then\r\n Notifier.LinkRemoved(List.Server);\r\n inherited Destroy;\r\nend;\r\n\r\n//=== { TJvConsumerStrings } =================================================\r\n\r\nconstructor TJvConsumerStrings.Create(AConsumer: TJvDataConsumer);\r\nbegin\r\n inherited Create;\r\n FConsumer := AConsumer;\r\nend;\r\n\r\nfunction TJvConsumerStrings.Get(Index: Integer): string;\r\nvar\r\n VL: IJvDataConsumerViewList;\r\n ItemText: IJvDataItemText;\r\nbegin\r\n if Index < 0 then\r\n Error(SListIndexError, Index);\r\n Result := '';\r\n Consumer.Enter;\r\n try\r\n if Supports(Consumer as IJvDataConsumer, IJvDataConsumerViewList, VL) then\r\n begin\r\n if Index >= VL.Count then\r\n Error(SListIndexError, Index);\r\n if Supports(VL.Item(Index), IJvDataItemText, ItemText) then\r\n Result := ItemText.Text;\r\n end;\r\n finally\r\n Consumer.Leave;\r\n end;\r\nend;\r\n\r\nfunction TJvConsumerStrings.GetCount: Integer;\r\nvar\r\n VL: IJvDataConsumerViewList;\r\nbegin\r\n Result := 0;\r\n Consumer.Enter;\r\n try\r\n if Supports(Consumer as IJvDataConsumer, IJvDataConsumerViewList, VL) then\r\n Result := VL.Count;\r\n finally\r\n Consumer.Leave;\r\n end;\r\nend;\r\n\r\nprocedure TJvConsumerStrings.Clear;\r\nbegin\r\n // Do not allow the consumer view list to be modified this way.\r\nend;\r\n\r\nprocedure TJvConsumerStrings.Delete(Index: Integer);\r\nbegin\r\n // Do not allow the consumer view list to be modified this way.\r\nend;\r\n\r\nprocedure TJvConsumerStrings.Insert(Index: Integer; const S: string);\r\nbegin\r\n // Do not allow the consumer view list to be modified this way.\r\nend;\r\n\r\n//============================================================================\r\n\r\nprocedure Init;\r\nbegin\r\n {$IFDEF COMPILER7_UP}\r\n GroupDescendentsWith(TExtensibleInterfacedPersistent, TControl);\r\n GroupDescendentsWith(TAggregatedPersistent, TControl);\r\n {$ENDIF COMPILER7_UP}\r\n RegisterClasses([\r\n // Items related\r\n TJvDataItemsList, TJvCustomDataItemsImages, TJvCustomDataItemsTextRenderer,\r\n TJvBaseDataItemsListManagement,\r\n // Item related\r\n TJvBaseDataItem, TJvDataItemTextImpl, TJvDataItemImageImpl,\r\n TJvDataItemContextTextImpl, TJvDataItemBlockableTextImpl,\r\n // Consumer related\r\n TJvDataConsumer, TJvDataConsumerItemSelect,\r\n // Context list related\r\n TJvDataContexts,\r\n // Context related\r\n TJvDataContext, TJvManagedDataContext, TJvFixedDataContext]);\r\nend;\r\n\r\ninitialization\r\n {$IFDEF UNITVERSIONING}\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n {$ENDIF UNITVERSIONING}\r\n Init;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvDataProviderIntf.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvDataProvider.pas, released on 2003-12-24.\r\n\r\nThe Initial Developers of the Original Code are Marcel Bestebroer, Peter\r\nThrnqvist and Remko Bonte\r\nPortions created by these individuals are Copyright (C) 2002 - 2003 Project JEDI\r\nAll Rights Reserved.\r\n\r\nContributor(s): -\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvDataProviderIntf.pas 12461 2009-08-14 17:21:33Z obones $\r\n\r\nunit JvDataProviderIntf;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, Classes, Graphics, ImgList,\r\n JclBase,\r\n JvTypes;\r\n\r\ntype\r\n TDataProviderChangeReason =\r\n (pcrAdd, pcrDelete, pcrUpdateItem, pcrUpdateItems, pcrDestroy,\r\n pcrContextAdd, pcrContextDelete, pcrContextUpdate, pcrFullRefresh);\r\n TDataItemState = (disFalse, disTrue, disIndetermined, disNotUsed);\r\n TProviderDrawState =\r\n (pdsSelected, pdsGrayed, pdsDisabled, pdsChecked,\r\n pdsFocused, pdsDefault, pdsHot);\r\n TProviderDrawStates = set of TProviderDrawState;\r\n TClassArray = array of TClass;\r\n TJvDataContextID = type string;\r\n TJvDataItemID = type string;\r\n\r\n // forwards\r\n IJvDataProvider = interface;\r\n IJvDataProviderColumn = interface;\r\n IJvDataItems = interface;\r\n IJvDataItem = interface;\r\n IJvDataItemColumn = interface;\r\n IJvDataConsumer = interface;\r\n IJvDataProviderNotify = interface;\r\n IJvDataContexts = interface;\r\n IJvDataContext = interface;\r\n IJvDataConsumerServerNotify = interface;\r\n IJvDataConsumerClientNotify = interface;\r\n\r\n IJvDataProvider = interface\r\n ['{62A7A17D-1E21-427E-861D-C92FBB9B09A6}']\r\n procedure RegisterChangeNotify(ANotify: IJvDataProviderNotify);\r\n procedure UnregisterChangeNotify(ANotify: IJvDataProviderNotify);\r\n function GetItems: IJvDataItems;\r\n procedure Changing(ChangeReason: TDataProviderChangeReason; Source: IUnknown = nil);\r\n procedure Changed(ChangeReason: TDataProviderChangeReason; Source: IUnknown = nil);\r\n function ConsumerClasses: TClassArray;\r\n procedure SelectConsumer(Consumer: IJvDataConsumer);\r\n function SelectedConsumer: IJvDataConsumer;\r\n procedure ReleaseConsumer;\r\n procedure SelectContext(Context: IJvDataContext);\r\n function SelectedContext: IJvDataContext;\r\n procedure ReleaseContext;\r\n procedure ContextDestroying(Context: IJvDataContext);\r\n procedure ConsumerDestroying(Consumer: IJvDataConsumer);\r\n function AllowProviderDesigner: Boolean;\r\n function AllowContextManager: Boolean;\r\n function GetNotifierCount: Integer;\r\n function GetNotifier(Index: Integer): IJvDataProviderNotify;\r\n function GetImplementer: TObject;\r\n end;\r\n\r\n IJvDataProviderColumns = interface\r\n ['{ABB37FDF-F4D2-464F-BFE9-8A1D299AD0D5}']\r\n function GetCount: Integer;\r\n function GetColumn(Index: Integer): IJvDataProviderColumn;\r\n function GetColumnByID(ID: string): IJvDataProviderColumn;\r\n property Count: Integer read GetCount;\r\n property Columns[Index: Integer]: IJvDataProviderColumn read GetColumn;\r\n end;\r\n\r\n IJvDataProviderColumnsManager = interface\r\n ['{CCEA2462-EA95-43DB-AE29-4E7839CDAB71}']\r\n function Add: IJvDataProviderColumn;\r\n function AddID(ID: string): IJvDataProviderColumn;\r\n procedure Clear;\r\n procedure Remove(Column: IJvDataProviderColumn);\r\n procedure RemoveAt(Index: Integer);\r\n end;\r\n\r\n IJvDataProviderColumn = interface\r\n ['{4AD52B08-B1D1-43BA-8B84-171980DECD92}']\r\n function GetCaption: string;\r\n function GetID: string;\r\n procedure SetCaption(Value: string);\r\n\r\n property Caption: string read GetCaption write SetCaption;\r\n end;\r\n\r\n IJvDataProviderNotify = interface\r\n ['{5B9D1847-6D35-4D9C-8BC2-2054997AB120}']\r\n procedure DataProviderChanging(const ADataProvider: IJvDataProvider; AReason: TDataProviderChangeReason; Source: IUnknown);\r\n procedure DataProviderChanged(const ADataProvider: IJvDataProvider; AReason: TDataProviderChangeReason; Source: IUnknown);\r\n function Consumer: IJvDataConsumer;\r\n end;\r\n\r\n IJvDataItems = interface\r\n ['{93747660-24FB-4294-BF4E-C7F88EA23983}']\r\n function GetCount: Integer;\r\n function GetItem(Index: Integer): IJvDataItem;\r\n function GetItemByID(ID: string): IJvDataItem;\r\n function GetItemByIndexPath(IndexPath: array of Integer): IJvDataItem;\r\n function GetParent: IJvDataItem;\r\n function GetProvider: IJvDataProvider;\r\n function GetImplementer: TObject;\r\n function IsDynamic: Boolean;\r\n procedure ContextDestroying(Context: IJvDataContext);\r\n property Count: Integer read GetCount;\r\n property Items[Index: Integer]: IJvDataItem read GetItem;\r\n property Parent: IJvDataItem read GetParent;\r\n property Provider: IJvDataProvider read GetProvider;\r\n end;\r\n\r\n IJvDataItemsImages = interface\r\n ['{735755A6-AD11-460C-B985-46464D73EDBC}']\r\n function GetDisabledImages: TCustomImageList;\r\n procedure SetDisabledImages(const Value: TCustomImageList);\r\n function GetHotImages: TCustomImageList;\r\n procedure SetHotImages(const Value: TCustomImageList);\r\n function GetImages: TCustomImageList;\r\n procedure SetImages(const Value: TCustomImageList);\r\n property DisabledImages: TCustomImageList read GetDisabledImages write SetDisabledImages;\r\n property HotImages: TCustomImageList read GetHotImages write SetHotImages;\r\n property Images: TCustomImageList read GetImages write SetImages;\r\n end;\r\n\r\n IJvDataItemsRenderer = interface\r\n ['{4EA490F4-7CCF-44A1-AA26-5320CDE9FAFC}']\r\n procedure DrawItemByIndex(ACanvas: TCanvas; var ARect: TRect; Index: Integer; State: TProviderDrawStates);\r\n function MeasureItemByIndex(ACanvas: TCanvas; Index: Integer): TSize;\r\n procedure DrawItem(ACanvas: TCanvas; var ARect: TRect; Item: IJvDataItem; State: TProviderDrawStates);\r\n function MeasureItem(ACanvas: TCanvas; Item: IJvDataItem): TSize;\r\n function AvgItemSize(ACanvas: TCanvas): TSize;\r\n end;\r\n\r\n IJvDataItemsManagement = interface\r\n ['{76611CC0-9DCD-4394-8B6E-1ADEF1942BC3}']\r\n function Add(Item: IJvDataItem): IJvDataItem;\r\n function New: IJvDataItem;\r\n procedure Clear;\r\n procedure Delete(Index: Integer);\r\n procedure Remove(var Item: IJvDataItem);\r\n end;\r\n\r\n IJvDataItemsDesigner = interface\r\n ['{31B2544C-8E4F-40FE-94B8-04243EF40821}']\r\n function GetCount: Integer;\r\n function GetKind(Index: Integer; out Caption: string): Boolean;\r\n function NewByKind(Kind: Integer): IJvDataItem;\r\n end;\r\n\r\n IJvDataIDSearch = interface\r\n ['{0F5BDC79-893B-45C9-94E9-C2B2FD4ABFE7}']\r\n function Find(ID: string; const Recursive: Boolean = False): IJvDataItem;\r\n end;\r\n\r\n IJvDataTextSearch = interface\r\n ['{E3BC388D-50F6-402D-9E30-36D5F7F40616}']\r\n function Find(Text: string; const Recursive: Boolean = False): IJvDataItem;\r\n end;\r\n\r\n IJvDataItem = interface\r\n ['{C965CF64-A1F2-44A4-B856-3A4EC6B693E1}']\r\n function GetItems: IJvDataItems;\r\n function GetIndex: Integer;\r\n function GetImplementer: TObject;\r\n function GetID: string;\r\n procedure ContextDestroying(Context: IJvDataContext);\r\n function IsParentOf(AnItem: IJvDataItem; DirectParent: Boolean = False): Boolean;\r\n function IsDeletable: Boolean;\r\n property Items: IJvDataItems read GetItems;\r\n property Implementer: TObject read GetImplementer;\r\n end;\r\n\r\n IJvDataItemColumns = interface\r\n ['{4DAC0051-E132-4701-9B9B-B3F1BC295D30}']\r\n function GetColumnByID(ID: string; CreateIfNotExists: Boolean = False): IJvDataItemColumn;\r\n function GetColumnFor(Header: IJvDataProviderColumn; CreateIfNotExists: Boolean = False): IJvDataItemColumn;\r\n end;\r\n\r\n IJvDataItemColumn = interface\r\n ['{33B508B9-AD9B-4B24-A19C-1A97714A754A}']\r\n function Header: IJvDataProviderColumn;\r\n end;\r\n\r\n IJvDataItemRenderer = interface\r\n ['{9E877A0D-01C2-4204-AA74-84D6516BBEB9}']\r\n procedure Draw(ACanvas: TCanvas; var ARect: TRect; State: TProviderDrawStates);\r\n function Measure(ACanvas: TCanvas): TSize;\r\n end;\r\n\r\n IJvDataItemText = interface\r\n ['{94FA56D9-281B-4252-B46D-15E7BADA70DA}']\r\n function GetText: string;\r\n procedure SetText(const Value: string);\r\n function Editable: Boolean;\r\n property Text: string read GetText write SetText;\r\n end;\r\n\r\n IJvDataItemImage = interface\r\n ['{6425D73A-90CF-42ED-9AB2-63125A4C0774}']\r\n function GetAlignment: TAlignment;\r\n procedure SetAlignment(Value: TAlignment);\r\n function GetImageIndex: Integer;\r\n procedure SetImageIndex(Index: Integer);\r\n function GetSelectedIndex: Integer;\r\n procedure SetSelectedIndex(Value: Integer);\r\n property Alignment: TAlignment read GetAlignment write SetAlignment;\r\n property ImageIndex: Integer read GetImageIndex write SetImageIndex;\r\n property SelectedIndex: Integer read GetSelectedIndex write SetSelectedIndex;\r\n end;\r\n\r\n IJvDataItemBasicAction = interface\r\n ['{86859A20-560D-4E9A-AC8B-2457789451B0}']\r\n function Execute(Sender: TObject): Boolean;\r\n end;\r\n\r\n IJvDataItemStates = interface\r\n ['{5BD81E0B-DAD2-4560-943A-205E0FF2A97F}']\r\n function get_Enabled: TDataItemState;\r\n procedure set_Enabled(Value: TDataItemState);\r\n function get_Checked: TDataItemState;\r\n procedure set_Checked(Value: TDataItemState);\r\n function get_Visible: TDataItemState;\r\n procedure set_Visible(Value: TDataItemState);\r\n property Enabled: TDataItemState read get_Enabled write set_Enabled;\r\n property Checked: TDataItemState read get_Checked write set_Checked;\r\n property Visible: TDataItemState read get_Visible write set_Visible;\r\n end;\r\n\r\n IJvDataItemDesigner = interface\r\n ['{8F1A1283-2D13-4A28-9616-08B3EF73F29A}']\r\n function GetVerbCount: Integer;\r\n function GetVerb(Index: Integer; out Caption: string; out Enabled, Checked, Visible,\r\n RadioItem: Boolean): Boolean;\r\n function ExecVerb(Index: Integer): Boolean;\r\n end;\r\n\r\n IJvDataContextSensitive = interface\r\n ['{7067F5C1-05DC-4DAC-A595-AF9151695FBB}']\r\n procedure RevertToAncestor;\r\n function IsEqualToAncestor: Boolean;\r\n end;\r\n\r\n IJvDataConsumer = interface\r\n ['{B2F18D03-F615-4AA2-A51A-74D330C05C0E}']\r\n function VCLComponent: TComponent;\r\n function AttributeApplies(Attr: Integer): Boolean;\r\n end;\r\n\r\n IJvDataConsumerProvider = interface\r\n ['{1F01D2E5-2ACB-4B84-AFE6-67E563FB470B}']\r\n function GetProvider: IJvDataProvider;\r\n end;\r\n\r\n IJvDataConsumerContext = interface\r\n ['{7AA9F53D-BBD4-4B64-916A-AAF4AB25A496}']\r\n function GetContext: IJvDataContext;\r\n procedure SetContext(Value: IJvDataContext);\r\n end;\r\n\r\n IJvDataConsumerItemState = interface\r\n ['{09EBDED8-502E-4C2E-9842-312850FF3358}']\r\n function Enabled(Item: IJvDataItem): TDataItemState;\r\n function Checked(Item: IJvDataItem): TDataItemState;\r\n function Visible(Item: IJvDataItem): TDataItemState;\r\n end;\r\n\r\n IJvDataConsumerItemSelect = interface\r\n ['{F11554AE-263D-4C04-BCDB-79F04DE89609}']\r\n function GetItem: IJvDataItem;\r\n procedure SetItem(Value: IJvDataItem);\r\n end;\r\n\r\n IJvDataConsumerViewList = interface\r\n ['{F3A78F68-D998-4877-8C73-1E0D2987808D}']\r\n function get_AutoExpandLevel: Integer;\r\n procedure set_AutoExpandLevel(Value: Integer);\r\n function get_ExpandOnNewItem: Boolean;\r\n procedure set_ExpandOnNewItem(Value: Boolean);\r\n function get_LevelIndent: Integer;\r\n procedure set_LevelIndent(Value: Integer);\r\n procedure RebuildView;\r\n procedure ExpandTreeTo(Item: IJvDataItem);\r\n procedure ToggleItem(Index: Integer);\r\n function IndexOfItem(Item: IJvDataItem): Integer;\r\n function IndexOfID(ID: TJvDataItemID): Integer;\r\n function ChildIndexOfItem(Item: IJvDataItem): Integer;\r\n function ChildIndexOfID(ID: TJvDataItemID): Integer;\r\n function Item(Index: Integer): IJvDataItem;\r\n function ItemLevel(Index: Integer): Integer;\r\n function ItemIsExpanded(Index: Integer): Boolean;\r\n function ItemHasChildren(Index: Integer): Boolean;\r\n function ItemParent(Index: Integer): IJvDataItem;\r\n function ItemParentIndex(Index: Integer): Integer;\r\n function ItemSibling(Index: Integer): IJvDataItem;\r\n function ItemSiblingIndex(Index: Integer): Integer;\r\n function SubItem(Parent: IJvDataItem; Index: Integer): IJvDataItem; overload;\r\n function SubItem(Parent, Index: Integer): IJvDataItem; overload;\r\n function SubItemIndex(Parent: IJvDataItem; Index: Integer): Integer; overload;\r\n function SubItemIndex(Parent, Index: Integer): Integer; overload;\r\n function ItemGroupInfo(Index: Integer): TDynIntegerArray;\r\n function Count: Integer;\r\n property AutoExpandLevel: Integer read get_AutoExpandLevel write set_AutoExpandLevel;\r\n property ExpandOnNewItem: Boolean read get_ExpandOnNewItem write set_ExpandOnNewItem;\r\n property LevelIndent: Integer read get_LevelIndent write set_LevelIndent;\r\n end;\r\n\r\n IJvDataConsumerServerNotify = interface\r\n ['{636CF1CD-6A5A-414F-9506-EAC461202119}']\r\n procedure AddClient(Client: IJvDataConsumerClientNotify);\r\n procedure RemoveClient(Client: IJvDataConsumerClientNotify);\r\n procedure NotifyProviderChanged(Client: IJvDataConsumerClientNotify);\r\n function IsValidClient(Client: IJvDataConsumerClientNotify): Boolean;\r\n end;\r\n\r\n IJvDataConsumerClientNotify = interface\r\n ['{D1AAAFDF-BEB1-44DB-B8D8-A60080CEF3C7}']\r\n procedure ItemSelected(Server: IJvDataConsumerServerNotify; Value: IJvDataItem);\r\n procedure LinkAdded(Server: IJvDataConsumerServerNotify);\r\n procedure LinkRemoved(Server: IJvDataConsumerServerNotify);\r\n end;\r\n\r\n IJvDataContexts = interface\r\n ['{BA5DC787-29C6-40FA-9542-F0A1E92A2B30}']\r\n function Provider: IJvDataProvider;\r\n function Ancestor: IJvDataContext;\r\n function GetCount: Integer;\r\n function GetContext(Index: Integer): IJvDataContext;\r\n function GetContextByName(Name: string): IJvDataContext;\r\n function IndexOf(Ctx: IJvDataContext): Integer;\r\n end;\r\n\r\n IJvDataContextsManager = interface\r\n ['{A94D62CA-F9B4-4DAA-9091-86D01A962BB1}']\r\n function Add(Context: IJvDataContext): IJvDataContext;\r\n function New: IJvDataContext;\r\n procedure Delete(Context: IJvDataContext);\r\n procedure Clear;\r\n end;\r\n\r\n IJvDataContext = interface\r\n ['{F226D92A-3493-4EF8-9CE6-037357EB0CEA}']\r\n function GetImplementer: TObject;\r\n function Contexts: IJvDataContexts;\r\n function Name: string;\r\n function IsDeletable: Boolean;\r\n end;\r\n\r\n IJvDataContextManager = interface\r\n ['{530367D8-601C-4E36-B5F0-357160497C50}']\r\n procedure SetName(Value: string);\r\n end;\r\n\r\n EJVCLDataProvider = class(EJVCLException);\r\n EJVCLDataConsumer = class(EJVCLDataProvider);\r\n EJVCLDataItems = class(EJVCLDataProvider);\r\n EJVCLDataContexts = class(EJVCLDataProvider);\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvDataProviderIntf.pas $';\r\n Revision: '$Revision: 12461 $';\r\n Date: '$Date: 2009-08-14 19:21:33 +0200 (ven. 14 août 2009) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvDataSource.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvDataSource.PAS, released on 08-07-2006.\r\n\r\nThe Initial Developer of the Original Code is Andreas Hausladen\r\n[Andreas dott Hausladen att gmx dott com]\r\nPortions created by Andreas Hausladen are Copyright (C) 2006 Andreas Hausladen.\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvDataSource.pas 13104 2011-09-07 06:50:43Z obones $\r\n\r\nunit JvDataSource;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n SysUtils, Classes, JvDataSourceIntf, DB, DBConsts;\r\n\r\ntype\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvDataSource = class(TDataSource, IJvDataSource, IJvDataSourceConnectorHandler)\r\n private\r\n FDataLink: TDataLink;\r\n FDataConnectors: TList;\r\n FUpdateLock: Integer;\r\n FUpdateLookBookmark: TBookmark;\r\n FOnFieldChanged: TDataChangeEvent;\r\n FOnEditingChanged: TNotifyEvent;\r\n FOnActiveChanged: TNotifyEvent;\r\n FOnCheckBrowseMode: TNotifyEvent;\r\n FOnLayoutChanged: TNotifyEvent;\r\n FOnDataSetChanged: TNotifyEvent;\r\n FOnDataSetScrolled: TNotifyEvent;\r\n FOnRecordChanged: TNotifyEvent;\r\n FEventsEnabled: Boolean;\r\n FNeedScroll: Boolean;\r\n FDataUpdated: Boolean;\r\n FDisableEventsOnLoading: Boolean;\r\n function GetDataConnector(Index: Integer): TJvDataConnector;\r\n function GetDataConnectorCount: Integer;\r\n protected\r\n procedure DataConnectorsFreeNotification;\r\n procedure AddDataConnector(DataConnector: TJvDataConnector);\r\n procedure RemoveDataConnector(DataConnector: TJvDataConnector);\r\n\r\n function DataSet: TDataSet;\r\n procedure Notify(Msg: Integer);\r\n\r\n procedure ActiveChanged; virtual;\r\n procedure FieldChanged(Field: TField); virtual;\r\n procedure RecordChanged; virtual;\r\n procedure LayoutChanged; virtual;\r\n procedure DataSetChanged; virtual;\r\n procedure DataSetScrolled; virtual;\r\n procedure EditingChanged; virtual;\r\n procedure CheckBrowseMode; virtual;\r\n procedure UpdateData; virtual;\r\n\r\n function AreEventsEnabled: Boolean;\r\n\r\n property DataConnectorCount: Integer read GetDataConnectorCount;\r\n property DataConnectors[Index: Integer]: TJvDataConnector read GetDataConnector; default;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n\r\n { IJvDataSource implementation }\r\n protected\r\n { DataSource }\r\n procedure Edit; // DataSource.Edit\r\n function GetState: TJvDataSetState;\r\n function GetAutoEdit: Boolean;\r\n function GetEnabled: Boolean;\r\n\r\n { DataSet }\r\n public\r\n function GetDataLink: TObject;\r\n function GetDataSet: TObject;\r\n procedure DataSetEdit; // DataSet.Edit\r\n function CanModify: Boolean;\r\n procedure First;\r\n procedure Last;\r\n procedure Next;\r\n procedure Prior;\r\n function Eof: Boolean;\r\n function Bof: Boolean;\r\n function RecordCount: Integer;\r\n function FieldByName(const FieldName: TDataFieldString): TObject;\r\n function FindField(const FieldName: TDataFieldString): TObject;\r\n procedure GetFieldNames(List: TStrings);\r\n function GetRecNo: Integer;\r\n procedure SetRecNo(Value: Integer);\r\n procedure Append;\r\n procedure Insert;\r\n procedure Post;\r\n procedure Cancel;\r\n procedure Delete;\r\n procedure Open;\r\n procedure Close;\r\n procedure MoveBy(Distance: Integer);\r\n function Locate(const KeyFields: string; const KeyValues: Variant;\r\n Options: TJvDBLocateOptions): Boolean;\r\n\r\n procedure BeginUpdate;\r\n procedure EndUpdate;\r\n\r\n property RecNo: Integer read GetRecNo write SetRecNo;\r\n\r\n { Fields }\r\n function GetFieldCount: Integer;\r\n function GetField(Index: Integer): TObject;\r\n function GetFieldName(Field: TObject): TDataFieldString;\r\n function GetFieldType(Field: TObject): TJvDBFieldType;\r\n function GetFieldSize(Field: TObject): Integer;\r\n function GetFieldDisplayLabel(Field: TObject): TDataFieldString;\r\n function GetFieldDisplayWidth(Field: TObject): Integer;\r\n procedure SetFieldDisplayWidth(Field: TObject; Value: Integer);\r\n function GetFieldEditMask(Field: TObject): TJvEditMask;\r\n function GetFieldReadOnly(Field: TObject): Boolean;\r\n function GetFieldVisible(Field: TObject): Boolean;\r\n function GetFieldRequired(Field: TObject): Boolean;\r\n procedure FieldClear(Field: TObject);\r\n function GetFieldIsNull(Field: TObject): Boolean;\r\n function GetFieldIsBlob(Field: TObject): Boolean;\r\n function GetFieldCanModify(Field: TObject): Boolean;\r\n\r\n function GetFieldOldValue(Field: TObject): Variant;\r\n function GetFieldValue(Field: TObject): Variant;\r\n procedure SetFieldValue(Field: TObject; const Value: Variant);\r\n function GetFieldString(Field: TObject): string;\r\n procedure SetFieldString(Field: TObject; const Value: string);\r\n function GetFieldWideString(Field: TObject): WideString;\r\n procedure SetFieldWideString(Field: TObject; const Value: WideString);\r\n function GetFieldInteger(Field: TObject): Integer;\r\n procedure SetFieldInteger(Field: TObject; const Value: Integer);\r\n function GetFieldFloat(Field: TObject): Double;\r\n procedure SetFieldFloat(Field: TObject; const Value: Double);\r\n function GetFieldDateTime(Field: TObject): TDateTime;\r\n procedure SetFieldDateTime(Field: TObject; const Value: TDateTime);\r\n function GetFieldBoolean(Field: TObject): Boolean;\r\n procedure SetFieldBoolean(Field: TObject; const Value: Boolean);\r\n\r\n property FieldCount: Integer read GetFieldCount;\r\n property Fields[Index: Integer]: TObject read GetField;\r\n property FieldName[Field: TObject]: TDataFieldString read GetFieldName;\r\n property FieldType[Field: TObject]: TJvDBFieldType read GetFieldType;\r\n property FieldSize[Field: TObject]: Integer read GetFieldSize;\r\n property FieldDisplayLabel[Field: TObject]: TDataFieldString read GetFieldDisplayLabel;\r\n property FieldDisplayWidth[Field: TObject]: Integer read GetFieldDisplayWidth write SetFieldDisplayWidth;\r\n property FieldEditMask[Field: TObject]: TJvEditMask read GetFieldEditMask;\r\n property FieldReadOnly[Field: TObject]: Boolean read GetFieldReadOnly;\r\n property FieldVisible[Field: TObject]: Boolean read GetFieldVisible;\r\n property FieldRequired[Field: TObject]: Boolean read GetFieldRequired;\r\n property FieldIsNull[Field: TObject]: Boolean read GetFieldIsNull;\r\n property FieldIsBlob[Field: TObject]: Boolean read GetFieldIsBlob;\r\n property FieldCanModify[Field: TObject]: Boolean read GetFieldCanModify;\r\n\r\n property FieldOldValue[Field: TObject]: Variant read GetFieldOldValue;\r\n property FieldValue[Field: TObject]: Variant read GetFieldValue write SetFieldValue;\r\n property FieldString[Field: TObject]: string read GetFieldString write SetFieldString;\r\n property FieldWideString[Field: TObject]: WideString read GetFieldWideString write SetFieldWideString;\r\n property FieldInteger[Field: TObject]: Integer read GetFieldInteger write SetFieldInteger;\r\n property FieldFloat[Field: TObject]: Double read GetFieldFloat write SetFieldFloat;\r\n property FieldDataTime[Field: TObject]: TDateTime read GetFieldDateTime write SetFieldDateTime;\r\n property FieldBoolean[Field: TObject]: Boolean read GetFieldBoolean write SetFieldBoolean;\r\n published\r\n property EventsEnabled: Boolean read FEventsEnabled write FEventsEnabled default True;\r\n property DisableEventsOnLoading: Boolean read FDisableEventsOnLoading write FDisableEventsOnLoading default True;\r\n property OnActiveChanged: TNotifyEvent read FOnActiveChanged write FOnActiveChanged;\r\n property OnFieldChanged: TDataChangeEvent read FOnFieldChanged write FOnFieldChanged;\r\n property OnRecordChanged: TNotifyEvent read FOnRecordChanged write FOnRecordChanged;\r\n property OnLayoutChanged: TNotifyEvent read FOnLayoutChanged write FOnLayoutChanged;\r\n property OnDataSetChanged: TNotifyEvent read FOnDataSetChanged write FOnDataSetChanged;\r\n property OnDataSetScrolled: TNotifyEvent read FOnDataSetScrolled write FOnDataSetScrolled;\r\n property OnEditingChanged: TNotifyEvent read FOnEditingChanged write FOnEditingChanged;\r\n property OnCheckBrowseMode: TNotifyEvent read FOnCheckBrowseMode write FOnCheckBrowseMode;\r\n end;\r\n\r\n TJvDataSourceDataLink = class(TDataLink)\r\n private\r\n FDataSource: TJvDataSource;\r\n protected\r\n procedure ActiveChanged; override;\r\n procedure RecordChanged(Field: TField); override;\r\n procedure UpdateData; override;\r\n procedure LayoutChanged; override;\r\n procedure DataSetChanged; override;\r\n procedure DataSetScrolled(Distance: Integer); override;\r\n procedure EditingChanged; override;\r\n procedure CheckBrowseMode; override;\r\n public\r\n constructor Create(ADataSource: TJvDataSource);\r\n end;\r\n\r\nimplementation\r\n\r\nuses\r\n System.Types;\r\n\r\n{ TJvDataSourceDataLink }\r\n\r\nconstructor TJvDataSourceDataLink.Create(ADataSource: TJvDataSource);\r\nbegin\r\n inherited Create;\r\n FDataSource := ADataSource\r\nend;\r\n\r\nprocedure TJvDataSourceDataLink.LayoutChanged;\r\nbegin\r\n FDataSource.Notify(DC_LAYOUTCHANGED);\r\n FDataSource.LayoutChanged;\r\nend;\r\n\r\nprocedure TJvDataSourceDataLink.ActiveChanged;\r\nbegin\r\n FDataSource.Notify(DC_ACTIVECHANGED);\r\n FDataSource.ActiveChanged;\r\nend;\r\n\r\nprocedure TJvDataSourceDataLink.RecordChanged(Field: TField);\r\nbegin\r\n FDataSource.Notify(DC_RECORDCHANGED);\r\n if Field <> nil then\r\n FDataSource.FieldChanged(Field);\r\n FDataSource.RecordChanged;\r\nend;\r\n\r\nprocedure TJvDataSourceDataLink.UpdateData;\r\nbegin\r\n FDataSource.Notify(DC_UPDATEDATA);\r\n FDataSource.UpdateData;\r\nend;\r\n\r\nprocedure TJvDataSourceDataLink.DataSetChanged;\r\nbegin\r\n FDataSource.Notify(DC_RECORDCHANGED);\r\n FDataSource.DataSetChanged;\r\nend;\r\n\r\nprocedure TJvDataSourceDataLink.DataSetScrolled(Distance: Integer);\r\nbegin\r\n FDataSource.Notify(DC_RECORDCHANGED); // that is what the inherited method would do\r\n FDataSource.Notify(DC_DATASETSCROLLED);\r\n FDataSource.DataSetScrolled;\r\nend;\r\n\r\nprocedure TJvDataSourceDataLink.EditingChanged;\r\nbegin\r\n FDataSource.Notify(DC_EDITINGCHANGED);\r\n FDataSource.EditingChanged;\r\nend;\r\n\r\nprocedure TJvDataSourceDataLink.CheckBrowseMode;\r\nbegin\r\n FDataSource.Notify(DC_CHECKBROWSEMODE);\r\n FDataSource.CheckBrowseMode;\r\nend;\r\n\r\n{ TJvDataSource }\r\n\r\nconstructor TJvDataSource.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FDataLink := TJvDataSourceDataLink.Create(Self);\r\n FDataConnectors := TList.Create;\r\n FDataLink.DataSource := Self;\r\n FEventsEnabled := True;\r\n FDisableEventsOnLoading := True;\r\nend;\r\n\r\nprocedure TJvDataSource.DataConnectorsFreeNotification;\r\nvar\r\n I: Integer;\r\nbegin\r\n { Notify all DataConnectors by setting their DataSource property to NIL }\r\n I := FDataConnectors.Count - 1;\r\n while i >= 0 do\r\n begin\r\n DataConnectors[I].DataSource := nil;\r\n if I >= DataConnectorCount then\r\n I := DataConnectorCount - 1\r\n else\r\n Dec(I);\r\n end;\r\nend;\r\n\r\ndestructor TJvDataSource.Destroy;\r\nbegin\r\n DataConnectorsFreeNotification;\r\n FDataLink.Free;\r\n FDataConnectors.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJvDataSource.GetDataConnector(Index: Integer): TJvDataConnector;\r\nbegin\r\n Result := TJvDataConnector(FDataConnectors[Index]);\r\nend;\r\n\r\nfunction TJvDataSource.GetDataConnectorCount: Integer;\r\nbegin\r\n Result := FDataConnectors.Count;\r\nend;\r\n\r\nfunction TJvDataSource.GetDataLink: TObject;\r\nbegin\r\n Result := FDataLink;\r\nend;\r\n\r\nprocedure TJvDataSource.Notify(Msg: Integer);\r\nvar\r\n M: TJvDataConnectorMsg;\r\n I: Integer;\r\nbegin\r\n M.Msg := Msg;\r\n for I := 0 to DataConnectorCount - 1 do\r\n DataConnectors[I].Dispatch(M);\r\nend;\r\n\r\nprocedure TJvDataSource.AddDataConnector(DataConnector: TJvDataConnector);\r\nbegin\r\n FDataConnectors.Add(DataConnector);\r\nend;\r\n\r\nprocedure TJvDataSource.RemoveDataConnector(DataConnector: TJvDataConnector);\r\nbegin\r\n FDataConnectors.Remove(DataConnector);\r\nend;\r\n\r\nprocedure TJvDataSource.Edit;\r\nbegin\r\n inherited Edit;\r\nend;\r\n\r\nfunction TJvDataSource.GetState: TJvDataSetState;\r\nbegin\r\n Result := TJvDataSetState(State);\r\nend;\r\n\r\nfunction TJvDataSource.GetAutoEdit: Boolean;\r\nbegin\r\n Result := AutoEdit;\r\nend;\r\n\r\nfunction TJvDataSource.GetEnabled: Boolean;\r\nbegin\r\n Result := Enabled;\r\nend;\r\n\r\nfunction TJvDataSource.DataSet: TDataSet;\r\nbegin\r\n Result := inherited DataSet;\r\n if not Assigned(Result) then\r\n raise EDatabaseError.CreateRes(@SDataSetClosed);\r\nend;\r\n\r\nfunction TJvDataSource.GetDataSet: TObject;\r\nbegin\r\n Result := inherited DataSet;\r\nend;\r\n\r\nprocedure TJvDataSource.DataSetEdit;\r\nbegin\r\n DataSet.Edit;\r\nend;\r\n\r\nfunction TJvDataSource.CanModify: Boolean;\r\nbegin\r\n Result := Assigned(inherited DataSet) and DataSet.CanModify;\r\nend;\r\n\r\nprocedure TJvDataSource.First;\r\nbegin\r\n DataSet.First;\r\nend;\r\n\r\nprocedure TJvDataSource.Last;\r\nbegin\r\n DataSet.Last;\r\nend;\r\n\r\nprocedure TJvDataSource.Next;\r\nbegin\r\n DataSet.Next;\r\nend;\r\n\r\nprocedure TJvDataSource.Prior;\r\nbegin\r\n DataSet.Prior;\r\nend;\r\n\r\nfunction TJvDataSource.Eof: Boolean;\r\nbegin\r\n Result := DataSet.Eof;\r\nend;\r\n\r\nfunction TJvDataSource.Bof: Boolean;\r\nbegin\r\n Result := DataSet.Bof;\r\nend;\r\n\r\nfunction TJvDataSource.RecordCount: Integer;\r\nbegin\r\n Result := DataSet.RecordCount;\r\nend;\r\n\r\nfunction TJvDataSource.FieldByName(const FieldName: TDataFieldString): TObject;\r\nbegin\r\n Result := DataSet.FieldByName(FieldName);\r\nend;\r\n\r\nfunction TJvDataSource.FindField(const FieldName: TDataFieldString): TObject;\r\nbegin\r\n Result := DataSet.FindField(FieldName);\r\nend;\r\n\r\nprocedure TJvDataSource.GetFieldNames(List: TStrings);\r\nbegin\r\n {$IFDEF COMPILER10_UP}\r\n {$WARN SYMBOL_DEPRECATED OFF}\r\n DataSet.GetFieldNames(List);\r\n {$WARN SYMBOL_DEPRECATED ON}\r\n {$ELSE}\r\n DataSet.GetFieldNames(List);\r\n {$ENDIF COMPILER10_UP}\r\nend;\r\n\r\nfunction TJvDataSource.GetRecNo: Integer;\r\nbegin\r\n Result := DataSet.RecNo;\r\nend;\r\n\r\nprocedure TJvDataSource.SetRecNo(Value: Integer);\r\nbegin\r\n DataSet.RecNo := Value;\r\nend;\r\n\r\nprocedure TJvDataSource.Append;\r\nbegin\r\n DataSet.Append;\r\nend;\r\n\r\nprocedure TJvDataSource.Insert;\r\nbegin\r\n DataSet.Insert;\r\nend;\r\n\r\nprocedure TJvDataSource.Post;\r\nbegin\r\n DataSet.Post;\r\nend;\r\n\r\nprocedure TJvDataSource.Cancel;\r\nbegin\r\n DataSet.Cancel;\r\nend;\r\n\r\nprocedure TJvDataSource.Delete;\r\nbegin\r\n DataSet.Delete;\r\nend;\r\n\r\nprocedure TJvDataSource.Open;\r\nbegin\r\n DataSet.Open;\r\nend;\r\n\r\nprocedure TJvDataSource.Close;\r\nbegin\r\n DataSet.Close;\r\nend;\r\n\r\nprocedure TJvDataSource.MoveBy(Distance: Integer);\r\nbegin\r\n DataSet.MoveBy(Distance)\r\nend;\r\n\r\nfunction TJvDataSource.Locate(const KeyFields: string; const KeyValues: Variant;\r\n Options: TJvDBLocateOptions): Boolean;\r\nbegin\r\n Result := DataSet.Locate(KeyFields, KeyValues, TLocateOptions(Options));\r\nend;\r\n\r\nprocedure TJvDataSource.BeginUpdate;\r\nbegin\r\n if FUpdateLock = 0 then\r\n begin\r\n DataSet.DisableControls;\r\n FUpdateLookBookmark := DataSet.GetBookmark;\r\n end;\r\n Inc(FUpdateLock);\r\nend;\r\n\r\nprocedure TJvDataSource.EndUpdate;\r\nbegin\r\n Dec(FUpdateLock);\r\n if FUpdateLock = 0 then\r\n begin\r\n try\r\n try\r\n DataSet.GotoBookmark(FUpdateLookBookmark);\r\n except\r\n end;\r\n DataSet.FreeBookmark(FUpdateLookBookmark);\r\n finally\r\n DataSet.EnableControls;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJvDataSource.GetFieldCount: Integer;\r\nbegin\r\n Result := DataSet.FieldCount;\r\nend;\r\n\r\nfunction TJvDataSource.GetField(Index: Integer): TObject;\r\nbegin\r\n Result := DataSet.Fields[Index];\r\nend;\r\n\r\nfunction TJvDataSource.GetFieldName(Field: TObject): TDataFieldString;\r\nbegin\r\n Result := TField(Field).FieldName;\r\nend;\r\n\r\nfunction TJvDataSource.GetFieldType(Field: TObject): TJvDBFieldType;\r\nbegin\r\n Result := TJvDBFieldType(TField(Field).DataType);\r\nend;\r\n\r\nfunction TJvDataSource.GetFieldSize(Field: TObject): Integer;\r\nbegin\r\n Result := TField(Field).Size;\r\nend;\r\n\r\nfunction TJvDataSource.GetFieldDisplayLabel(Field: TObject): TDataFieldString;\r\nbegin\r\n Result := TField(Field).DisplayLabel;\r\nend;\r\n\r\nfunction TJvDataSource.GetFieldDisplayWidth(Field: TObject): Integer;\r\nbegin\r\n Result := TField(Field).DisplayWidth;\r\nend;\r\n\r\nprocedure TJvDataSource.SetFieldDisplayWidth(Field: TObject; Value: Integer);\r\nbegin\r\n TField(Field).DisplayWidth := Value;\r\nend;\r\n\r\nfunction TJvDataSource.GetFieldEditMask(Field: TObject): TJvEditMask;\r\nbegin\r\n Result := TField(Field).EditMask;\r\nend;\r\n\r\nfunction TJvDataSource.GetFieldReadOnly(Field: TObject): Boolean;\r\nbegin\r\n Result := TField(Field).ReadOnly;\r\nend;\r\n\r\nfunction TJvDataSource.GetFieldVisible(Field: TObject): Boolean;\r\nbegin\r\n Result := TField(Field).Visible;\r\nend;\r\n\r\nfunction TJvDataSource.GetFieldRequired(Field: TObject): Boolean;\r\nbegin\r\n Result := TField(Field).Required;\r\nend;\r\n\r\nprocedure TJvDataSource.FieldClear(Field: TObject);\r\nbegin\r\n TField(Field).Clear;\r\nend;\r\n\r\nfunction TJvDataSource.GetFieldIsNull(Field: TObject): Boolean;\r\nbegin\r\n Result := TField(Field).IsNull\r\nend;\r\n\r\nfunction TJvDataSource.GetFieldIsBlob(Field: TObject): Boolean;\r\nbegin\r\n Result := TField(Field).IsBlob;\r\nend;\r\n\r\nfunction TJvDataSource.GetFieldCanModify(Field: TObject): Boolean;\r\nbegin\r\n Result := TField(Field).CanModify;\r\nend;\r\n\r\nfunction TJvDataSource.GetFieldOldValue(Field: TObject): Variant;\r\nbegin\r\n Result := TField(Field).OldValue;\r\nend;\r\n\r\nfunction TJvDataSource.GetFieldValue(Field: TObject): Variant;\r\nbegin\r\n Result := TField(Field).AsVariant;\r\nend;\r\n\r\nprocedure TJvDataSource.SetFieldValue(Field: TObject; const Value: Variant);\r\nbegin\r\n TField(Field).AsVariant := Value;\r\nend;\r\n\r\nfunction TJvDataSource.GetFieldString(Field: TObject): string;\r\nbegin\r\n Result := TField(Field).AsString;\r\nend;\r\n\r\nprocedure TJvDataSource.SetFieldString(Field: TObject; const Value: string);\r\nbegin\r\n TField(Field).AsString := Value;\r\nend;\r\n\r\nfunction TJvDataSource.GetFieldWideString(Field: TObject): WideString;\r\nbegin\r\n {$IFDEF COMPILER10_UP}\r\n Result := TField(Field).AsWideString;\r\n {$ELSE}\r\n Result := TField(Field).AsString;\r\n {$ENDIF COMPILER10_UP}\r\nend;\r\n\r\nprocedure TJvDataSource.SetFieldWideString(Field: TObject; const Value: WideString);\r\nbegin\r\n {$IFDEF COMPILER10_UP}\r\n TField(Field).AsWideString := Value;\r\n {$ELSE}\r\n TField(Field).AsString := Value;\r\n {$ENDIF COMPILER10_UP}\r\nend;\r\n\r\nfunction TJvDataSource.GetFieldInteger(Field: TObject): Integer;\r\nbegin\r\n Result := TField(Field).AsInteger;\r\nend;\r\n\r\nprocedure TJvDataSource.SetFieldInteger(Field: TObject; const Value: Integer);\r\nbegin\r\n TField(Field).AsInteger := Value;\r\nend;\r\n\r\nfunction TJvDataSource.GetFieldFloat(Field: TObject): Double;\r\nbegin\r\n Result := TField(Field).AsFloat;\r\nend;\r\n\r\nprocedure TJvDataSource.SetFieldFloat(Field: TObject; const Value: Double);\r\nbegin\r\n TField(Field).AsFloat := Value;\r\nend;\r\n\r\nfunction TJvDataSource.GetFieldDateTime(Field: TObject): TDateTime;\r\nbegin\r\n Result := TField(Field).AsDateTime;\r\nend;\r\n\r\nprocedure TJvDataSource.SetFieldDateTime(Field: TObject; const Value: TDateTime);\r\nbegin\r\n TField(Field).AsDateTime := Value;\r\nend;\r\n\r\nfunction TJvDataSource.GetFieldBoolean(Field: TObject): Boolean;\r\nbegin\r\n Result := TField(Field).AsBoolean;\r\nend;\r\n\r\nprocedure TJvDataSource.SetFieldBoolean(Field: TObject; const Value: Boolean);\r\nbegin\r\n TField(Field).AsBoolean := Value;\r\nend;\r\n\r\nprocedure TJvDataSource.ActiveChanged;\r\nbegin\r\n try\r\n if AreEventsEnabled and Assigned(FOnActiveChanged) then\r\n FOnActiveChanged(Self);\r\n finally\r\n DataSetScrolled;\r\n end;\r\nend;\r\n\r\nprocedure TJvDataSource.CheckBrowseMode;\r\nbegin\r\n if FDataLink.DataSet <> nil then\r\n begin\r\n if not (FDataLink.DataSet.State in [dsEdit, dsInsert]) then\r\n FDataUpdated := False;\r\n FNeedScroll := True;\r\n if (FDataLink.DataSet.State = dsInsert) and FDataUpdated then\r\n FNeedScroll := False;\r\n if AreEventsEnabled and Assigned(FOnCheckBrowseMode) then\r\n FOnCheckBrowseMode(Self);\r\n end;\r\nend;\r\n\r\nprocedure TJvDataSource.DataSetChanged;\r\nvar\r\n ScrollEventEnabled: Boolean;\r\nbegin\r\n ScrollEventEnabled := FNeedScroll;\r\n FNeedScroll := False;\r\n try\r\n if AreEventsEnabled and Assigned(FOnDataSetChanged) then\r\n FOnDataSetChanged(Self);\r\n finally\r\n if ScrollEventEnabled or \r\n ((FDataLink.DataSet <> nil) and (FDataLink.DataSet.State = dsInsert)) then\r\n DataSetScrolled;\r\n end;\r\nend;\r\n\r\nprocedure TJvDataSource.DataSetScrolled;\r\nbegin\r\n FNeedScroll := False;\r\n if AreEventsEnabled and Assigned(FOnDataSetScrolled) then\r\n FOnDataSetScrolled(Self);\r\nend;\r\n\r\nprocedure TJvDataSource.EditingChanged;\r\nbegin\r\n if FDataLink.DataSet <> nil then\r\n begin\r\n if FDataUpdated or (FDataLink.DataSet.Active and (FDataLink.DataSet.RecNo <> -1)) then // DataSet.State is already updated\r\n FNeedScroll := False;\r\n if AreEventsEnabled and Assigned(FOnEditingChanged) then\r\n FOnEditingChanged(Self);\r\n end;\r\nend;\r\n\r\nprocedure TJvDataSource.LayoutChanged;\r\nbegin\r\n if AreEventsEnabled and Assigned(FOnLayoutChanged) then\r\n FOnLayoutChanged(Self);\r\nend;\r\n\r\nprocedure TJvDataSource.RecordChanged;\r\nbegin\r\n if AreEventsEnabled and Assigned(FOnRecordChanged) then\r\n FOnRecordChanged(Self);\r\nend;\r\n\r\nprocedure TJvDataSource.FieldChanged(Field: TField);\r\nbegin\r\n if AreEventsEnabled and Assigned(FOnFieldChanged) then\r\n FOnFieldChanged(Self, Field);\r\nend;\r\n\r\nprocedure TJvDataSource.UpdateData;\r\nbegin // event is handled by TDataSource\r\n FDataUpdated := True;\r\nend;\r\n\r\nfunction TJvDataSource.AreEventsEnabled: Boolean;\r\nbegin\r\n Result := EventsEnabled;\r\n if Result and DisableEventsOnLoading then\r\n Result := not (csLoading in ComponentState);\r\nend;\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvDataSourceIntf.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvDataSourceIntf.PAS, released on 08-07-2006.\r\n\r\nThe Initial Developer of the Original Code is Andreas Hausladen\r\n[Andreas dott Hausladen att gmx dott com]\r\nPortions created by Andreas Hausladen are Copyright (C) 2006 Andreas Hausladen.\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvDataSourceIntf.pas 12461 2009-08-14 17:21:33Z obones $\r\n\r\nunit JvDataSourceIntf;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFNDEF DelphiPersonalEdition}\r\n DB,\r\n {$ENDIF !DelphiPersonalEdition}\r\n SysUtils, Classes, Contnrs;\r\n\r\nconst\r\n DC_ACTIVECHANGED = 100;\r\n DC_RECORDCHANGED = 101;\r\n DC_UPDATEDATA = 102;\r\n DC_LAYOUTCHANGED = 103;\r\n DC_DATASETCHANGED = 104;\r\n DC_DATASETSCROLLED = 105;\r\n DC_EDITINGCHANGED = 106;\r\n DC_CHECKBROWSEMODE = 107;\r\n\r\ntype\r\n // To avoid ambiguities in BCB when used with the Pro and above SKUs, the\r\n // DB related types are simply mapped to those from the DB unit.\r\n // Of course, in the case of a Personal edition, they have to be fully\r\n // declared.\r\n {$IFDEF DelphiPersonalEdition}\r\n TJvDataSetState = (dsInactive, dsBrowse, dsEdit, dsInsert, dsSetKey,\r\n dsCalcFields, dsFilter, dsNewValue, dsOldValue, dsCurValue, dsBlockRead,\r\n dsInternalCalc, dsOpening);\r\n {$ELSE}\r\n TJvDataSetState = TDataSetState;\r\n {$ENDIF DelphiPersonalEdition}\r\n\r\n {$IFDEF DelphiPersonalEdition}\r\n TJvDBFieldType = (ftUnknown, ftString, ftSmallint, ftInteger, ftWord, // 0..4\r\n ftBoolean, ftFloat, ftCurrency, ftBCD, ftDate, ftTime, ftDateTime, // 5..11\r\n ftBytes, ftVarBytes, ftAutoInc, ftBlob, ftMemo, ftGraphic, ftFmtMemo, // 12..18\r\n ftParadoxOle, ftDBaseOle, ftTypedBinary, ftCursor, ftFixedChar, ftWideString, // 19..24\r\n ftLargeint, ftADT, ftArray, ftReference, ftDataSet, ftOraBlob, ftOraClob, // 25..31\r\n ftVariant, ftInterface, ftIDispatch, ftGuid, ftTimeStamp, ftFMTBcd, // 32..37\r\n ftFixedWideChar, ftWideMemo, ftOraTimeStamp, ftOraInterval); // 38..41\r\n {$ELSE}\r\n TJvDBFieldType = TFieldType;\r\n {$ENDIF DelphiPersonalEdition}\r\n\r\n {$IFDEF DelphiPersonalEdition}\r\n TJvDBLocateOption = (loCaseInsensitive, loPartialKey);\r\n {$ELSE}\r\n TJvDBLocateOption = TLocateOption;\r\n {$ENDIF DelphiPersonalEdition}\r\n TJvDBLocateOptions = set of TJvDBLocateOption;\r\n\r\n {$IFDEF COMPILER10_UP}\r\n TDataFieldString = WideString;\r\n {$ELSE}\r\n TDataFieldString = string;\r\n {$ENDIF COMPILER10_UP}\r\n TJvEditMask = string;\r\n\r\n TJvDataConnectorMsg = record\r\n Msg: Integer;\r\n end;\r\n\r\n TJvDataConnector = class;\r\n\r\n IJvDataSourceConnectorHandler = interface\r\n ['{CCAB936A-6CB4-4047-95C8-7EBFC5DC4B9F}']\r\n procedure AddDataConnector(DataConnector: TJvDataConnector);\r\n procedure RemoveDataConnector(DataConnector: TJvDataConnector);\r\n end;\r\n\r\n IJvDataSource = interface\r\n ['{6F0ECE0E-0B77-4EC1-8E62-1C5ADE76D6B9}']\r\n\r\n { DataSource }\r\n procedure Edit; // DataSource.Edit\r\n function GetState: TJvDataSetState;\r\n function GetAutoEdit: Boolean;\r\n function GetEnabled: Boolean;\r\n\r\n property State: TJvDataSetState read GetState;\r\n property AutoEdit: Boolean read GetAutoEdit;\r\n property Enabled: Boolean read GetEnabled;\r\n\r\n { DataSet }\r\n function GetDataLink: TObject;\r\n function GetDataSet: TObject;\r\n procedure DataSetEdit; // DataSet.Edit\r\n function CanModify: Boolean;\r\n procedure First;\r\n procedure Last;\r\n procedure Next;\r\n procedure Prior;\r\n function Eof: Boolean;\r\n function Bof: Boolean;\r\n function RecordCount: Integer;\r\n function FieldByName(const FieldName: TDataFieldString): TObject;\r\n function FindField(const FieldName: TDataFieldString): TObject;\r\n procedure GetFieldNames(List: TStrings);\r\n function GetRecNo: Integer;\r\n procedure SetRecNo(Value: Integer);\r\n procedure Append;\r\n procedure Insert;\r\n procedure Post;\r\n procedure Cancel;\r\n procedure Delete;\r\n procedure Open;\r\n procedure Close;\r\n procedure MoveBy(Distance: Integer);\r\n function Locate(const KeyFields: string; const KeyValues: Variant;\r\n Options: TJvDBLocateOptions): Boolean;\r\n\r\n procedure BeginUpdate;\r\n procedure EndUpdate;\r\n\r\n property RecNo: Integer read GetRecNo write SetRecNo;\r\n property DataSet: TObject read GetDataSet;\r\n\r\n { Fields }\r\n function GetFieldCount: Integer;\r\n function GetField(Index: Integer): TObject;\r\n function GetFieldName(Field: TObject): TDataFieldString;\r\n function GetFieldType(Field: TObject): TJvDBFieldType;\r\n function GetFieldSize(Field: TObject): Integer;\r\n function GetFieldDisplayLabel(Field: TObject): TDataFieldString;\r\n function GetFieldDisplayWidth(Field: TObject): Integer;\r\n procedure SetFieldDisplayWidth(Field: TObject; Value: Integer);\r\n function GetFieldEditMask(Field: TObject): TJvEditMask;\r\n function GetFieldReadOnly(Field: TObject): Boolean;\r\n function GetFieldVisible(Field: TObject): Boolean;\r\n function GetFieldRequired(Field: TObject): Boolean;\r\n procedure FieldClear(Field: TObject);\r\n function GetFieldIsNull(Field: TObject): Boolean;\r\n function GetFieldIsBlob(Field: TObject): Boolean;\r\n function GetFieldCanModify(Field: TObject): Boolean;\r\n\r\n function GetFieldOldValue(Field: TObject): Variant;\r\n function GetFieldValue(Field: TObject): Variant;\r\n procedure SetFieldValue(Field: TObject; const Value: Variant);\r\n function GetFieldString(Field: TObject): string;\r\n procedure SetFieldString(Field: TObject; const Value: string);\r\n function GetFieldWideString(Field: TObject): WideString;\r\n procedure SetFieldWideString(Field: TObject; const Value: WideString);\r\n function GetFieldInteger(Field: TObject): Integer;\r\n procedure SetFieldInteger(Field: TObject; const Value: Integer);\r\n function GetFieldFloat(Field: TObject): Double;\r\n procedure SetFieldFloat(Field: TObject; const Value: Double);\r\n function GetFieldDateTime(Field: TObject): TDateTime;\r\n procedure SetFieldDateTime(Field: TObject; const Value: TDateTime);\r\n function GetFieldBoolean(Field: TObject): Boolean;\r\n procedure SetFieldBoolean(Field: TObject; const Value: Boolean);\r\n\r\n property FieldCount: Integer read GetFieldCount;\r\n property Fields[Index: Integer]: TObject read GetField;\r\n property FieldName[Field: TObject]: TDataFieldString read GetFieldName;\r\n property FieldType[Field: TObject]: TJvDBFieldType read GetFieldType;\r\n property FieldSize[Field: TObject]: Integer read GetFieldSize;\r\n property FieldDisplayLabel[Field: TObject]: TDataFieldString read GetFieldDisplayLabel;\r\n property FieldDisplayWidth[Field: TObject]: Integer read GetFieldDisplayWidth write SetFieldDisplayWidth;\r\n property FieldEditMask[Field: TObject]: TJvEditMask read GetFieldEditMask;\r\n property FieldReadOnly[Field: TObject]: Boolean read GetFieldReadOnly;\r\n property FieldVisible[Field: TObject]: Boolean read GetFieldVisible;\r\n property FieldRequired[Field: TObject]: Boolean read GetFieldRequired;\r\n property FieldIsNull[Field: TObject]: Boolean read GetFieldIsNull;\r\n property FieldIsBlob[Field: TObject]: Boolean read GetFieldIsBlob;\r\n property FieldCanModify[Field: TObject]: Boolean read GetFieldCanModify;\r\n\r\n property FieldOldValue[Field: TObject]: Variant read GetFieldOldValue;\r\n property FieldValue[Field: TObject]: Variant read GetFieldValue write SetFieldValue;\r\n property FieldString[Field: TObject]: string read GetFieldString write SetFieldString;\r\n property FieldWideString[Field: TObject]: WideString read GetFieldWideString write SetFieldWideString;\r\n property FieldInteger[Field: TObject]: Integer read GetFieldInteger write SetFieldInteger;\r\n property FieldFloat[Field: TObject]: Double read GetFieldFloat write SetFieldFloat;\r\n property FieldDataTime[Field: TObject]: TDateTime read GetFieldDateTime write SetFieldDateTime;\r\n property FieldBoolean[Field: TObject]: Boolean read GetFieldBoolean write SetFieldBoolean;\r\n end;\r\n\r\n TJvDataConnectorField = class(TObject)\r\n private\r\n FDataSource: IJvDataSource;\r\n FField: TObject;\r\n FFieldName: TDataFieldString;\r\n function GetAsBoolean: Boolean;\r\n function GetAsDateTime: TDateTime;\r\n function GetAsFloat: Double;\r\n function GetAsInt64: Int64;\r\n function GetAsInteger: Integer;\r\n function GetDataType: TJvDBFieldType;\r\n function GetDisplayLabel: TDataFieldString;\r\n function GetDisplayWidth: Integer;\r\n function GetEditMask: TJvEditMask;\r\n function GetIsBlob: Boolean;\r\n function GetIsNull: Boolean;\r\n function GetOldValue: Variant;\r\n function GetReadOnly: Boolean;\r\n function GetRequired: Boolean;\r\n function GetSize: Integer;\r\n function GetValue: Variant;\r\n function GetVisible: Boolean;\r\n procedure SetAsBoolean(const Value: Boolean);\r\n procedure SetAsDateTime(const Value: TDateTime);\r\n procedure SetAsFloat(const Value: Double);\r\n procedure SetAsInt64(const Value: Int64);\r\n procedure SetAsInteger(const Value: Integer);\r\n procedure SetDisplayWidth(const Value: Integer);\r\n procedure SetValue(const Value: Variant);\r\n procedure SetDataSource(const Value: IJvDataSource);\r\n procedure SetFieldName(const Value: TDataFieldString);\r\n function GetAsString: string;\r\n procedure SetAsString(const Value: string);\r\n function GetAsWideString: WideString;\r\n procedure SetAsWideString(const Value: WideString);\r\n function GetIsValid: Boolean;\r\n function GetCanModify: Boolean;\r\n protected\r\n procedure UpdateField(const ADataSource: IJvDataSource);\r\n property DataSource: IJvDataSource read FDataSource write SetDataSource;\r\n public\r\n procedure Clear;\r\n property IsValid: Boolean read GetIsValid; // False if Field = nil\r\n\r\n property Field: TObject read FField;\r\n property FieldName: TDataFieldString read FFieldName write SetFieldName;\r\n property DataType: TJvDBFieldType read GetDataType;\r\n property Size: Integer read GetSize;\r\n property DisplayLabel: TDataFieldString read GetDisplayLabel;\r\n property DisplayWidth: Integer read GetDisplayWidth write SetDisplayWidth;\r\n property EditMask: TJvEditMask read GetEditMask;\r\n property ReadOnly: Boolean read GetReadOnly;\r\n property Visible: Boolean read GetVisible;\r\n property Required: Boolean read GetRequired;\r\n property IsNull: Boolean read GetIsNull;\r\n property IsBlob: Boolean read GetIsBlob;\r\n property CanModify: Boolean read GetCanModify;\r\n\r\n property OldValue: Variant read GetOldValue;\r\n property Value: Variant read GetValue write SetValue;\r\n property AsString: string read GetAsString write SetAsString;\r\n property AsWideString: WideString read GetAsWideString write SetAsWideString;\r\n property AsInteger: Integer read GetAsInteger write SetAsInteger;\r\n property AsFloat: Double read GetAsFloat write SetAsFloat;\r\n property AsDateTime: TDateTime read GetAsDateTime write SetAsDateTime;\r\n property AsBoolean: Boolean read GetAsBoolean write SetAsBoolean;\r\n property AsInt64: Int64 read GetAsInt64 write SetAsInt64;\r\n end;\r\n\r\n TJvDataConnector = class(TPersistent)\r\n private\r\n FDataSource: IJvDataSource;\r\n FLockRecordChange: Integer;\r\n FModified: Boolean;\r\n FActive: Boolean;\r\n FMaster: TJvDataConnector;\r\n FFields: TObjectList;\r\n\r\n procedure DcRecordChanged(var Msg: TJvDataConnectorMsg); message DC_RECORDCHANGED;\r\n procedure DcActiveChanged(var Msg: TJvDataConnectorMsg); message DC_ACTIVECHANGED;\r\n procedure DcUpdateData(var Msg: TJvDataConnectorMsg); message DC_UPDATEDATA;\r\n procedure DcLayoutChanged(var Msg: TJvDataConnectorMsg); message DC_LAYOUTCHANGED;\r\n\r\n procedure SetDataSource(const Value: IJvDataSource);\r\n function GetDataSetConnected: Boolean;\r\n function GetField(Index: Integer): TJvDataConnectorField;\r\n function GetFieldCount: Integer;\r\n function GetFieldField(Field: TObject): TJvDataConnectorField;\r\n protected\r\n property Master: TJvDataConnector read FMaster write FMaster;\r\n\r\n { DataSourceConnected is invoked when a new DataSource is assigned. }\r\n procedure DataSourceConnected; virtual;\r\n { DataSourceDisconnected is invoked when the DataSource is destroyed or\r\n the DataSource is set to a new DataSource or NIL. }\r\n procedure DataSourceDisconnected; virtual;\r\n\r\n procedure ActiveChanged; virtual;\r\n procedure RecordChanged; virtual;\r\n procedure UpdateData; virtual;\r\n procedure LayoutChanged; virtual;\r\n\r\n procedure Notify(Msg: Integer); virtual;\r\n\r\n function CanEdit: Boolean; virtual;\r\n public\r\n constructor Create;\r\n destructor Destroy; override;\r\n procedure Assign(Source: TPersistent); override;\r\n function GetDataLink: TObject;\r\n\r\n function FieldByName(const FieldName: TDataFieldString): TJvDataConnectorField;\r\n function FindField(const FieldName: TDataFieldString): TJvDataConnectorField;\r\n\r\n property FieldCount: Integer read GetFieldCount;\r\n property Fields[Index: Integer]: TJvDataConnectorField read GetField;\r\n\r\n procedure Edit;\r\n procedure Reset;\r\n procedure UpdateRecord;\r\n procedure Modify;\r\n property DataSetConnected: Boolean read GetDataSetConnected;\r\n property Modified: Boolean read FModified;\r\n property Active: Boolean read FActive write FActive;\r\n published\r\n property DataSource: IJvDataSource read FDataSource write SetDataSource;\r\n end;\r\n\r\n TJvFieldDataConnector = class(TJvDataConnector)\r\n private\r\n FField: TJvDataConnectorField;\r\n procedure SetDataField(const Value: TDataFieldString);\r\n function GetDataField: TDataFieldString;\r\n protected\r\n procedure UpdateFields; virtual;\r\n procedure ActiveChanged; override;\r\n procedure LayoutChanged; override;\r\n procedure DataSourceConnected; override;\r\n procedure DataSourceDisconnected; override;\r\n function CanEdit: Boolean; override;\r\n public\r\n constructor Create;\r\n destructor Destroy; override;\r\n procedure Assign(Source: TPersistent); override;\r\n property Field: TJvDataConnectorField read FField;\r\n published\r\n property DataField: TDataFieldString read GetDataField write SetDataField;\r\n end;\r\n\r\n TJvKeyFieldDataConnector = class(TJvFieldDataConnector)\r\n private\r\n FKey: TJvDataConnectorField;\r\n function GetKeyField: TDataFieldString;\r\n procedure SetKeyField(const Value: TDataFieldString);\r\n protected\r\n procedure UpdateFields; override;\r\n public\r\n constructor Create;\r\n destructor Destroy; override;\r\n procedure Assign(Source: TPersistent); override;\r\n\r\n property Key: TJvDataConnectorField read FKey;\r\n published\r\n property KeyField: TDataFieldString read GetKeyField write SetKeyField;\r\n end;\r\n\r\n TJvLookupDataConnector = class(TJvKeyFieldDataConnector)\r\n private\r\n FList: TJvKeyFieldDataConnector;\r\n function GetListField: TDataFieldString;\r\n function GetListSource: IJvDataSource;\r\n procedure SetListField(const Value: TDataFieldString);\r\n procedure SetListSource(const Value: IJvDataSource);\r\n function GetListKeyField: TDataFieldString;\r\n procedure SetListKeyField(const Value: TDataFieldString);\r\n public\r\n constructor Create;\r\n destructor Destroy; override;\r\n procedure Assign(Source: TPersistent); override;\r\n\r\n property List: TJvKeyFieldDataConnector read FList;\r\n published\r\n property ListField: TDataFieldString read GetListField write SetListField;\r\n property ListSource: IJvDataSource read GetListSource write SetListSource;\r\n property ListKeyField: TDataFieldString read GetListKeyField write SetListKeyField;\r\n end;\r\n\r\nimplementation\r\n\r\n//=== { TJvDataConnector } ===================================================\r\n\r\nconstructor TJvDataConnector.Create;\r\nbegin\r\n inherited Create;\r\n FFields := TObjectList.Create;\r\nend;\r\n\r\ndestructor TJvDataConnector.Destroy;\r\nvar\r\n Handler: IJvDataSourceConnectorHandler;\r\nbegin\r\n if Assigned(FDataSource) and Supports(FDataSource, IJvDataSourceConnectorHandler, Handler) then\r\n Handler.RemoveDataConnector(Self);\r\n FDataSource := nil;\r\n FFields.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJvDataConnector.GetDataLink: TObject;\r\nbegin\r\n if DataSource <> nil then\r\n Result := DataSource.GetDataLink\r\n else\r\n Result := nil;\r\nend;\r\n\r\nprocedure TJvDataConnector.ActiveChanged;\r\nbegin\r\n Notify(DC_RECORDCHANGED);\r\nend;\r\n\r\nprocedure TJvDataConnector.RecordChanged;\r\nbegin\r\nend;\r\n\r\nprocedure TJvDataConnector.Reset;\r\nbegin\r\n if DataSetConnected and Active then\r\n begin\r\n Active := False;\r\n try\r\n Notify(DC_RECORDCHANGED);\r\n finally\r\n Active := True;\r\n end;\r\n FModified := False;\r\n end;\r\nend;\r\n\r\nprocedure TJvDataConnector.UpdateData;\r\nbegin\r\nend;\r\n\r\nprocedure TJvDataConnector.LayoutChanged;\r\nbegin\r\n Notify(DC_RECORDCHANGED);\r\nend;\r\n\r\nprocedure TJvDataConnector.Modify;\r\nbegin\r\n if Active and (FLockRecordChange = 0) then\r\n begin\r\n Edit;\r\n FModified := True;\r\n end;\r\nend;\r\n\r\nprocedure TJvDataConnector.Notify(Msg: Integer);\r\nvar\r\n M: TJvDataConnectorMsg;\r\nbegin\r\n M.Msg := Msg;\r\n Dispatch(M);\r\nend;\r\n\r\nprocedure TJvDataConnector.Assign(Source: TPersistent);\r\nbegin\r\n if Source is TJvDataConnector then\r\n DataSource := TJvDataConnector(Source).DataSource\r\n else\r\n inherited Assign(Source);\r\nend;\r\n\r\nfunction TJvDataConnector.CanEdit: Boolean;\r\nbegin\r\n Result := Active and Assigned(DataSource);\r\nend;\r\n\r\nprocedure TJvDataConnector.DataSourceConnected;\r\nbegin\r\n FModified := False;\r\n FActive := True;\r\n Notify(DC_ACTIVECHANGED);\r\nend;\r\n\r\nprocedure TJvDataConnector.DataSourceDisconnected;\r\nbegin\r\n Notify(DC_ACTIVECHANGED);\r\n FActive := False;\r\n FModified := False;\r\n FFields.Clear;\r\nend;\r\n\r\nprocedure TJvDataConnector.DcActiveChanged(var Msg: TJvDataConnectorMsg);\r\nbegin\r\n if FLockRecordChange = 0 then\r\n begin\r\n ActiveChanged;\r\n FModified := False;\r\n end;\r\n if Assigned(FMaster) then\r\n FMaster.Dispatch(Msg);\r\nend;\r\n\r\nprocedure TJvDataConnector.DcLayoutChanged(var Msg: TJvDataConnectorMsg);\r\nbegin\r\n FFields.Clear;\r\n if FLockRecordChange = 0 then\r\n begin\r\n LayoutChanged;\r\n FModified := False;\r\n end;\r\n if Assigned(FMaster) then\r\n FMaster.Dispatch(Msg);\r\nend;\r\n\r\nprocedure TJvDataConnector.DcRecordChanged(var Msg: TJvDataConnectorMsg);\r\nbegin\r\n if FLockRecordChange = 0 then\r\n begin\r\n Inc(FLockRecordChange);\r\n try\r\n RecordChanged;\r\n finally\r\n Dec(FLockRecordChange);\r\n end;\r\n FModified := False;\r\n end;\r\n\r\n if Assigned(FMaster) then\r\n FMaster.Dispatch(Msg);\r\nend;\r\n\r\nprocedure TJvDataConnector.DcUpdateData(var Msg: TJvDataConnectorMsg);\r\nbegin\r\n if Active then\r\n begin\r\n Inc(FLockRecordChange);\r\n try\r\n UpdateData;\r\n finally\r\n Dec(FLockRecordChange);\r\n end;\r\n FModified := False;\r\n end;\r\n\r\n if Assigned(FMaster) then\r\n FMaster.Dispatch(Msg);\r\nend;\r\n\r\nprocedure TJvDataConnector.Edit;\r\nbegin\r\n if CanEdit and (FLockRecordChange = 0) then\r\n begin\r\n Inc(FLockRecordChange);\r\n try\r\n DataSource.Edit;\r\n finally\r\n Dec(FLockRecordChange);\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJvDataConnector.FieldByName(const FieldName: TDataFieldString): TJvDataConnectorField;\r\nbegin\r\n Result := GetFieldField(DataSource.FieldByName(FieldName)); // raises exception if not found\r\nend;\r\n\r\nfunction TJvDataConnector.FindField(const FieldName: TDataFieldString): TJvDataConnectorField;\r\nbegin\r\n Result := nil;\r\n if DataSource <> nil then\r\n Result := GetFieldField(DataSource.FindField(FieldName));\r\nend;\r\n\r\nfunction TJvDataConnector.GetDataSetConnected: Boolean;\r\nbegin\r\n Result := Assigned(DataSource) and (DataSource.DataSet <> nil);\r\nend;\r\n\r\nfunction TJvDataConnector.GetField(Index: Integer): TJvDataConnectorField;\r\nbegin\r\n Result := GetFieldField(DataSource.Fields[Index]);\r\nend;\r\n\r\nfunction TJvDataConnector.GetFieldCount: Integer;\r\nbegin\r\n if DataSource <> nil then\r\n Result := DataSource.FieldCount\r\n else\r\n Result := 0;\r\nend;\r\n\r\nfunction TJvDataConnector.GetFieldField(Field: TObject): TJvDataConnectorField;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := nil;\r\n if Field <> nil then\r\n begin\r\n for I := 0 to FFields.Count - 1 do\r\n begin\r\n Result := TJvDataConnectorField(FFields[I]);\r\n if Result.Field = Field then\r\n Exit;\r\n end;\r\n Result := TJvDataConnectorField.Create;\r\n FFields.Add(Result);\r\n Result.DataSource := DataSource;\r\n Result.FieldName := DataSource.FieldName[Field];\r\n end;\r\nend;\r\n\r\nprocedure TJvDataConnector.SetDataSource(const Value: IJvDataSource);\r\nvar\r\n Handler: IJvDataSourceConnectorHandler;\r\nbegin\r\n if Value <> FDataSource then\r\n begin\r\n if Assigned(FDataSource) then\r\n begin\r\n if Supports(FDataSource, IJvDataSourceConnectorHandler, Handler) then\r\n Handler.RemoveDataConnector(Self);\r\n end;\r\n try\r\n FDataSource := nil;\r\n DataSourceDisconnected;\r\n finally\r\n FDataSource := Value;\r\n if Assigned(FDataSource) then\r\n begin\r\n if Supports(FDataSource, IJvDataSourceConnectorHandler, Handler) then\r\n begin\r\n Handler.AddDataConnector(Self);\r\n DataSourceConnected;\r\n end\r\n else\r\n FDataSource := nil;\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvDataConnector.UpdateRecord;\r\nbegin\r\n if DataSetConnected and Modified and Active then\r\n begin\r\n Inc(FLockRecordChange);\r\n try\r\n UpdateData;\r\n finally\r\n Dec(FLockRecordChange);\r\n end;\r\n FModified := False;\r\n end;\r\nend;\r\n\r\n//=== { TJvFieldDataConnector } ==============================================\r\n\r\nconstructor TJvFieldDataConnector.Create;\r\nbegin\r\n inherited Create;\r\n FField := TJvDataConnectorField.Create;\r\nend;\r\n\r\nprocedure TJvFieldDataConnector.ActiveChanged;\r\nbegin\r\n UpdateFields;\r\n inherited ActiveChanged;\r\nend;\r\n\r\nprocedure TJvFieldDataConnector.Assign(Source: TPersistent);\r\nbegin\r\n inherited Assign(Source);\r\n if Source is TJvFieldDataConnector then\r\n DataField := TJvFieldDataConnector(Source).DataField;\r\nend;\r\n\r\nfunction TJvFieldDataConnector.CanEdit: Boolean;\r\nbegin\r\n Result := inherited CanEdit and Field.CanModify;\r\nend;\r\n\r\nprocedure TJvFieldDataConnector.DataSourceConnected;\r\nbegin\r\n UpdateFields;\r\n inherited DataSourceConnected;\r\nend;\r\n\r\nprocedure TJvFieldDataConnector.DataSourceDisconnected;\r\nbegin\r\n UpdateFields;\r\n inherited DataSourceDisconnected;\r\nend;\r\n\r\ndestructor TJvFieldDataConnector.Destroy;\r\nbegin\r\n FField.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJvFieldDataConnector.GetDataField: TDataFieldString;\r\nbegin\r\n Result := FField.FieldName;\r\nend;\r\n\r\nprocedure TJvFieldDataConnector.LayoutChanged;\r\nbegin\r\n UpdateFields;\r\n inherited LayoutChanged;\r\nend;\r\n\r\nprocedure TJvFieldDataConnector.SetDataField(const Value: TDataFieldString);\r\nbegin\r\n FField.FieldName := Value;\r\n Notify(DC_RECORDCHANGED);\r\nend;\r\n\r\nprocedure TJvFieldDataConnector.UpdateFields;\r\nbegin\r\n FField.UpdateField(DataSource);\r\nend;\r\n\r\n//=== { TJvDataConnectorField } ==============================================\r\n\r\nprocedure TJvDataConnectorField.SetDataSource(const Value: IJvDataSource);\r\nbegin\r\n if Value <> FDataSource then\r\n UpdateField(Value);\r\nend;\r\n\r\nprocedure TJvDataConnectorField.SetFieldName(const Value: TDataFieldString);\r\nbegin\r\n if Value <> FFieldName then\r\n begin\r\n FFieldName := Value;\r\n UpdateField(FDataSource);\r\n end;\r\nend;\r\n\r\nprocedure TJvDataConnectorField.UpdateField(const ADataSource: IJvDataSource);\r\nbegin\r\n FDataSource := ADataSource;\r\n if Assigned(DataSource) and (DataSource.DataSet <> nil) then\r\n FField := DataSource.FindField(FFieldName)\r\n else\r\n FField := nil;\r\nend;\r\n\r\nprocedure TJvDataConnectorField.Clear;\r\nbegin\r\n DataSource.FieldClear(Field);\r\nend;\r\n\r\nfunction TJvDataConnectorField.GetAsBoolean: Boolean;\r\nbegin\r\n Result := DataSource.FieldBoolean[Field];\r\nend;\r\n\r\nfunction TJvDataConnectorField.GetAsDateTime: TDateTime;\r\nbegin\r\n Result := DataSource.FieldDataTime[Field];\r\nend;\r\n\r\nfunction TJvDataConnectorField.GetAsFloat: Double;\r\nbegin\r\n Result := DataSource.FieldFloat[Field];\r\nend;\r\n\r\nfunction TJvDataConnectorField.GetAsInt64: Int64;\r\nbegin\r\n Result := StrToInt64Def(DataSource.FieldString[Field], 0);\r\nend;\r\n\r\nfunction TJvDataConnectorField.GetAsInteger: Integer;\r\nbegin\r\n Result := DataSource.FieldInteger[Field];\r\nend;\r\n\r\nfunction TJvDataConnectorField.GetAsString: string;\r\nbegin\r\n Result := DataSource.FieldString[Field];\r\nend;\r\n\r\nfunction TJvDataConnectorField.GetAsWideString: WideString;\r\nbegin\r\n Result := DataSource.FieldWideString[Field];\r\nend;\r\n\r\nfunction TJvDataConnectorField.GetCanModify: Boolean;\r\nbegin\r\n Result := IsValid and DataSource.FieldCanModify[Field];\r\nend;\r\n\r\nfunction TJvDataConnectorField.GetDataType: TJvDBFieldType;\r\nbegin\r\n Result := DataSource.FieldType[Field];\r\nend;\r\n\r\nfunction TJvDataConnectorField.GetDisplayLabel: TDataFieldString;\r\nbegin\r\n Result := DataSource.FieldDisplayLabel[Field];\r\nend;\r\n\r\nfunction TJvDataConnectorField.GetDisplayWidth: Integer;\r\nbegin\r\n Result := DataSource.FieldDisplayWidth[Field];\r\nend;\r\n\r\nfunction TJvDataConnectorField.GetEditMask: TJvEditMask;\r\nbegin\r\n Result := DataSource.FieldEditMask[Field];\r\nend;\r\n\r\nfunction TJvDataConnectorField.GetIsBlob: Boolean;\r\nbegin\r\n Result := DataSource.FieldIsBlob[Field];\r\nend;\r\n\r\nfunction TJvDataConnectorField.GetIsNull: Boolean;\r\nbegin\r\n Result := DataSource.FieldIsNull[Field];\r\nend;\r\n\r\nfunction TJvDataConnectorField.GetIsValid: Boolean;\r\nbegin\r\n if (DataSource <> nil) and (Field = nil) then\r\n UpdateField(DataSource);\r\n Result := (DataSource <> nil) and (Field <> nil);\r\nend;\r\n\r\nfunction TJvDataConnectorField.GetOldValue: Variant;\r\nbegin\r\n Result := DataSource.FieldOldValue[Field];\r\nend;\r\n\r\nfunction TJvDataConnectorField.GetReadOnly: Boolean;\r\nbegin\r\n Result := DataSource.FieldReadOnly[Field];\r\nend;\r\n\r\nfunction TJvDataConnectorField.GetRequired: Boolean;\r\nbegin\r\n Result := DataSource.FieldRequired[Field];\r\nend;\r\n\r\nfunction TJvDataConnectorField.GetSize: Integer;\r\nbegin\r\n Result := DataSource.FieldSize[Field];\r\nend;\r\n\r\nfunction TJvDataConnectorField.GetValue: Variant;\r\nbegin\r\n Result := DataSource.FieldValue[Field];\r\nend;\r\n\r\nfunction TJvDataConnectorField.GetVisible: Boolean;\r\nbegin\r\n Result := DataSource.FieldVisible[Field];\r\nend;\r\n\r\nprocedure TJvDataConnectorField.SetAsBoolean(const Value: Boolean);\r\nbegin\r\n DataSource.FieldBoolean[Field] := Value;\r\nend;\r\n\r\nprocedure TJvDataConnectorField.SetAsDateTime(const Value: TDateTime);\r\nbegin\r\n DataSource.FieldDataTime[Field] := Value;\r\nend;\r\n\r\nprocedure TJvDataConnectorField.SetAsFloat(const Value: Double);\r\nbegin\r\n DataSource.FieldFloat[Field] := Value;\r\nend;\r\n\r\nprocedure TJvDataConnectorField.SetAsInt64(const Value: Int64);\r\nbegin\r\n DataSource.FieldString[Field] := IntToStr(Value);\r\nend;\r\n\r\nprocedure TJvDataConnectorField.SetAsInteger(const Value: Integer);\r\nbegin\r\n DataSource.FieldInteger[Field] := Value;\r\nend;\r\n\r\nprocedure TJvDataConnectorField.SetAsString(const Value: string);\r\nbegin\r\n DataSource.FieldString[Field] := Value;\r\nend;\r\n\r\nprocedure TJvDataConnectorField.SetAsWideString(const Value: WideString);\r\nbegin\r\n DataSource.FieldWideString[Field] := Value;\r\nend;\r\n\r\nprocedure TJvDataConnectorField.SetDisplayWidth(const Value: Integer);\r\nbegin\r\n DataSource.FieldDisplayWidth[Field] := Value;\r\nend;\r\n\r\nprocedure TJvDataConnectorField.SetValue(const Value: Variant);\r\nbegin\r\n DataSource.FieldValue[Field] := Value;\r\nend;\r\n\r\n//=== { TJvKeyFieldDataConnector } ===========================================\r\n\r\nconstructor TJvKeyFieldDataConnector.Create;\r\nbegin\r\n inherited Create;\r\n FKey := TJvDataConnectorField.Create;\r\nend;\r\n\r\ndestructor TJvKeyFieldDataConnector.Destroy;\r\nbegin\r\n FKey.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvKeyFieldDataConnector.Assign(Source: TPersistent);\r\nbegin\r\n inherited Assign(Source);\r\n if Source is TJvKeyFieldDataConnector then\r\n KeyField := TJvKeyFieldDataConnector(Source).KeyField;\r\nend;\r\n\r\nfunction TJvKeyFieldDataConnector.GetKeyField: TDataFieldString;\r\nbegin\r\n Result := FKey.FieldName;\r\nend;\r\n\r\nprocedure TJvKeyFieldDataConnector.SetKeyField(const Value: TDataFieldString);\r\nbegin\r\n FKey.FieldName := Value;\r\nend;\r\n\r\n\r\nprocedure TJvKeyFieldDataConnector.UpdateFields;\r\nbegin\r\n inherited UpdateFields;\r\n FKey.UpdateField(DataSource);\r\nend;\r\n\r\n//=== { TJvLookupDataConnector } =============================================\r\n\r\nconstructor TJvLookupDataConnector.Create;\r\nbegin\r\n inherited Create;\r\n FList := TJvKeyFieldDataConnector.Create;\r\n FList.Master := Self;\r\nend;\r\n\r\ndestructor TJvLookupDataConnector.Destroy;\r\nbegin\r\n FList.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvLookupDataConnector.Assign(Source: TPersistent);\r\nbegin\r\n inherited Assign(Source);\r\n if Source is TJvLookupDataConnector then\r\n FList.Assign(Source);\r\nend;\r\n\r\nfunction TJvLookupDataConnector.GetListField: TDataFieldString;\r\nbegin\r\n Result := FList.DataField;\r\nend;\r\n\r\nfunction TJvLookupDataConnector.GetListKeyField: TDataFieldString;\r\nbegin\r\n Result := FList.KeyField;\r\nend;\r\n\r\nfunction TJvLookupDataConnector.GetListSource: IJvDataSource;\r\nbegin\r\n Result := FList.DataSource;\r\nend;\r\n\r\nprocedure TJvLookupDataConnector.SetListField(const Value: TDataFieldString);\r\nbegin\r\n FList.DataField := Value;\r\nend;\r\n\r\nprocedure TJvLookupDataConnector.SetListKeyField(const Value: TDataFieldString);\r\nbegin\r\n FList.KeyField := Value;\r\nend;\r\n\r\nprocedure TJvLookupDataConnector.SetListSource(const Value: IJvDataSource);\r\nbegin\r\n FList.DataSource := Value;\r\nend;\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvDatePickerEdit.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvDatePickerEdit, released on 2002-10-04.\r\n\r\nThe Initial Developer of the Original Code is Oliver Giesen [giesen att lucatec dott de]\r\nPortions created by Oliver Giesen are Copyright (C) 2002 Lucatec GmbH.\r\nAll Rights Reserved.\r\n\r\nContributor(s): Peter Thrnqvist.\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nDescription:\r\n A replacement for TDateTimePicker which is better suited for keyboard-input by\r\n ultimately descending from TCustomMaskEdit.\r\n\r\n Other notable features (especially in comparison to the native DATETIMEPICKER):\r\n\r\n - The control is able to construct a suitable EditMask from a valid date format\r\n string such as the global ShortDateFormat (the default) which should make it\r\n adapt well to regional settings / individual requirements.\r\n\r\n - It is possible to specify a NoDateText which will be displayed when no date\r\n is selected. The original datetimepicker would display 1899-12-31 in such\r\n cases. This feature could be further controlled by the AllowNoDate and\r\n NoDateShortcut properties. With the NoDateValue you can control what TDateTime\r\n value should be used. It defaults to 0, what means 1899-12-31.\r\n\r\nKnown issues / not (yet) implemented features:\r\n\r\n - there is no real support for DateFormats containing any literal characters\r\n other than the defined DateSeparator, especially spaces. it /might/ work in\r\n some cases but in the majority of cases it will not.\r\n TODO: simply disallow such characters or implement proper handling?\r\n\r\n - as the embedded MS-calendar does not support dates prior to 1752-09-14,\r\n neither does this control. this is not yet handled gracefully in absolutely\r\n all situations though.\r\n\r\n - the Min/MaxYear contstraints are currently commented out as they are not\r\n functional in the current state. They would still require some work to make\r\n up for two-digit year entries.\r\n\r\n - the control does (currently) not allow for time entry\r\n - it really is a control for date entry only.\r\n\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvDatePickerEdit.pas 13415 2012-09-10 09:51:54Z obones $\r\n\r\nunit JvDatePickerEdit;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, Messages, Classes, Controls, ImgList,\r\n {$IFDEF HAS_UNIT_SYSTEM_UITYPES}\r\n System.UITypes,\r\n {$ENDIF HAS_UNIT_SYSTEM_UITYPES}\r\n JvCalendar, JvDropDownForm, JvCheckedMaskEdit, JvToolEdit;\r\n\r\ntype\r\n {Types used to handle and convert between date format strings and EditMasks:}\r\n TJvDateFigure = (dfNone, dfYear, dfMonth, dfDay);\r\n TJvDateFigureInfo = record\r\n Figure: TJvDateFigure;\r\n Start: Byte;\r\n Length: Byte;\r\n Index: Byte;\r\n end;\r\n TJvDateFigures = array[0..2] of TJvDateFigureInfo;\r\n\r\n {A dropdown form with an embedded calendar control.}\r\n TJvDropCalendar = class(TJvCustomDropDownForm)\r\n private\r\n FCal: TJvCustomMonthCalendar;\r\n FWithBeep: Boolean;\r\n FOnChange: TNotifyEvent;\r\n FOnSelect: TNotifyEvent;\r\n FOnCancel: TNotifyEvent;\r\n procedure CalSelChange(Sender: TObject; StartDate, EndDate: TDateTime);\r\n procedure CalSelect(Sender: TObject; StartDate, EndDate: TDateTime);\r\n procedure CalKeyPress(Sender: TObject; var Key: Char);\r\n procedure CalKillFocus(const ASender: TObject; const ANextControl: TWinControl);\r\n protected\r\n procedure DoCancel;\r\n procedure DoChange;\r\n procedure DoSelect;\r\n procedure DoShow; override;\r\n function GetSelDate: TDateTime;\r\n procedure SetSelDate(const AValue: TDateTime);\r\n public\r\n constructor CreateWithAppearance(AOwner: TComponent;\r\n const AAppearance: TJvMonthCalAppearance);\r\n destructor Destroy; override;\r\n procedure SetFocus; override;\r\n property SelDate: TDateTime read GetSelDate write SetSelDate;\r\n property WithBeep: Boolean read FWithBeep write FWithBeep;\r\n property OnCancel: TNotifyEvent read FOnCancel write FOnCancel;\r\n property OnChange: TNotifyEvent read FOnChange write FOnChange;\r\n property OnSelect: TNotifyEvent read FOnSelect write FOnSelect;\r\n end;\r\n\r\n TJvGetValidDateStringEvent = procedure(Sender: TObject; var DateText: string) of object;\r\n\r\n TJvCustomDatePickerEdit = class(TJvCustomCheckedMaskEdit)\r\n private\r\n FAllowNoDate: Boolean;\r\n FCalAppearance: TJvMonthCalAppearance;\r\n FDate: TDateTime;\r\n FDateError: Boolean;\r\n FDeleting: Boolean;\r\n FDateFigures: TJvDateFigures;\r\n FInternalDateFormat,\r\n FDateFormat: string;\r\n FEnableValidation: Boolean;\r\n FMask: string;\r\n FNoDateShortcut: TShortcut;\r\n FNoDateText: string;\r\n FStoreDate: Boolean;\r\n FAlwaysReturnEditDate: Boolean;\r\n FEmptyMaskText: string;\r\n FStoreDateFormat: Boolean;\r\n FDateSeparator: Char;\r\n FPopupDate: TDateTime;\r\n FNoDateValue: TDateTime;\r\n FOnGetValidDateString: TJvGetValidDateStringEvent;\r\n // FMinYear: Word;\r\n // FMaxYear: Word;\r\n procedure CalDestroy(Sender: TObject);\r\n procedure CalSelect(Sender: TObject);\r\n procedure CalCloseQuery(Sender: TObject; var CanClose: Boolean);\r\n function AttemptTextToDate(const AText: string; var ADate: TDateTime;\r\n const AForce: Boolean = False; const ARaise: Boolean = False): Boolean;\r\n function DateFormatToEditMask(var ADateFormat: string): string;\r\n function DateToText(const ADate: TDateTime): string;\r\n function DetermineDateSeparator(AFormat: string): Char;\r\n procedure ResetDateFormat;\r\n procedure FindSeparators(var AFigures: TJvDateFigures; const AText: string; const AGetLengths: Boolean = True);\r\n procedure ParseFigures(var AFigures: TJvDateFigures; AFormat: string; const AMask: string);\r\n procedure RaiseNoDate;\r\n procedure SetAllowNoDate(const AValue: Boolean);\r\n procedure SetCalAppearance(const AValue: TJvMonthCalAppearance);\r\n function GetDate: TDateTime;\r\n procedure SetDate(const AValue: TDateTime);\r\n procedure SetDateFormat(AValue: string);\r\n function GetDropped: Boolean;\r\n procedure SetNoDateText(const AValue: string);\r\n procedure SetNoDateValue(const AValue: TDateTime);\r\n procedure SetDateSeparator(const AValue: Char);\r\n function GetEditMask: string;\r\n procedure SetEditMask(const AValue: string);\r\n function GetText: TCaption;\r\n procedure SetText(const AValue: TCaption);\r\n procedure WMPaste(var Msg: TMessage); message WM_PASTE;\r\n procedure CMExit(var Msg: TMessage); message CM_EXIT;\r\n protected\r\n function ValidateEditText: string;\r\n procedure CalChanged; virtual;\r\n procedure RestoreMaskForKeyPress;\r\n function GetValidDateString(const Text: string): string; virtual;\r\n procedure AcceptValue(const Value: Variant); override;\r\n function AcceptPopup(var Value: Variant): Boolean; override;\r\n function IsNoDateShortcutStored: Boolean;\r\n function IsNoDateTextStored: Boolean;\r\n function IsNoDateValueStored: Boolean;\r\n procedure PopupChange; override;\r\n procedure Change; override;\r\n procedure Loaded; override;\r\n procedure CreateWnd; override;\r\n procedure DoKillFocus(const ANextControl: TWinControl); override;\r\n procedure KeyDown(var Key: Word; Shift: TShiftState); override;\r\n procedure KeyPress(var Key: Char); override;\r\n procedure CreatePopup; override;\r\n procedure HidePopup; override;\r\n procedure ShowPopup(Origin: TPoint); override;\r\n procedure DoCtl3DChanged; override;\r\n procedure EnabledChanged; override;\r\n function GetChecked: Boolean; override;\r\n function GetPopupValue: Variant; override;\r\n procedure SetChecked(const AValue: Boolean); override;\r\n procedure SetPopupValue(const Value: Variant); override;\r\n procedure SetShowCheckbox(const AValue: Boolean); override;\r\n function GetEnableValidation: Boolean; virtual;\r\n procedure UpdateDisplay; virtual;\r\n function ValidateDate(const ADate: TDateTime): Boolean; virtual;\r\n function ActiveFigure: TJvDateFigureInfo;\r\n procedure ClearMask;\r\n procedure RestoreMask;\r\n function IsEmptyMaskText(const AText: string): Boolean;\r\n property AllowNoDate: Boolean read FAllowNoDate write SetAllowNoDate;\r\n property AlwaysReturnEditDate: Boolean read FAlwaysReturnEditDate write FAlwaysReturnEditDate default True;\r\n property CalendarAppearance: TJvMonthCalAppearance read FCalAppearance write SetCalAppearance;\r\n property Date: TDateTime read GetDate write SetDate stored FStoreDate;\r\n property DateFormat: string read FDateFormat write SetDateFormat stored FStoreDateFormat;\r\n property DateSeparator: Char read FDateSeparator write SetDateSeparator stored FStoreDateFormat;\r\n property Dropped: Boolean read GetDropped;\r\n property EnableValidation: Boolean read GetEnableValidation write FEnableValidation default True;\r\n property ImageKind default ikDropDown;\r\n // property MaxYear: Word read FMaxYear write FMaxYear;\r\n // property MinYear: Word read FMinYear write FMinYear;\r\n property NoDateShortcut: TShortcut read FNoDateShortcut write FNoDateShortcut stored IsNoDateShortcutStored;\r\n property NoDateText: string read FNoDateText write SetNoDateText stored IsNoDateTextStored;\r\n property NoDateValue: TDateTime read FNoDateValue write SetNoDateValue stored IsNoDateValueStored; \r\n property ShowButton default True;\r\n property StoreDate: Boolean read FStoreDate write FStoreDate default False;\r\n property StoreDateFormat: Boolean read FStoreDateFormat write FStoreDateFormat default False;\r\n\r\n property OnGetValidDateString: TJvGetValidDateStringEvent read FOnGetValidDateString write FOnGetValidDateString;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n class function DefaultImageIndex: TImageIndex; override;\r\n procedure Clear; override;\r\n function IsEmpty: Boolean; virtual;\r\n\r\n function HasValidDate: Boolean;\r\n\r\n property EditMask: string read GetEditMask write SetEditMask;\r\n property Text: TCaption read GetText write SetText;\r\n end;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvDatePickerEdit = class(TJvCustomDatePickerEdit)\r\n public\r\n property Dropped;\r\n published\r\n property Action;\r\n property Align;\r\n property AllowNoDate;\r\n property AlwaysReturnEditDate;\r\n property Anchors;\r\n property AutoSelect;\r\n property AutoSize;\r\n property BorderStyle;\r\n property ButtonFlat;\r\n property ButtonHint;\r\n property ButtonWidth;\r\n property CalendarAppearance;\r\n property Caret;\r\n property CharCase;\r\n property Checked;\r\n property ClickKey;\r\n property ClipboardCommands;\r\n property Color;\r\n property Constraints;\r\n property Date;\r\n property DateFormat;\r\n property DateSeparator;\r\n {property BiDiMode;}\r\n {property ParentBiDiMode;}\r\n property BevelEdges;\r\n property BevelInner;\r\n property BevelKind default bkNone;\r\n property BevelOuter;\r\n property Flat;\r\n property ImeMode;\r\n property ImeName;\r\n property OEMConvert;\r\n property ParentFlat;\r\n property OnEndDock;\r\n property OnStartDock;\r\n property DirectInput;\r\n property DisabledColor;\r\n property DisabledTextColor;\r\n property DragCursor;\r\n property DragKind;\r\n property DragMode;\r\n property Enabled;\r\n property EnableValidation;\r\n property Font;\r\n property Glyph;\r\n property GroupIndex;\r\n property HideSelection;\r\n property HintColor;\r\n property HotTrack;\r\n // property MaxYear default 2900;\r\n // property MinYear default 1900;\r\n property ImageIndex;\r\n property ImageKind;\r\n property Images;\r\n property NoDateShortcut;\r\n property NoDateText;\r\n property NoDateValue;\r\n property NumGlyphs;\r\n property ParentColor;\r\n property ParentFont;\r\n property ParentShowHint;\r\n property PopupMenu;\r\n property ReadOnly;\r\n property ShowCheckBox;\r\n property ShowHint;\r\n property ShowButton;\r\n property StoreDate;\r\n property StoreDateFormat;\r\n property TabOrder;\r\n property TabStop;\r\n property Visible;\r\n property OnButtonClick;\r\n property OnChange;\r\n property OnClick;\r\n property OnCheckClick;\r\n property OnContextPopup;\r\n property OnDblClick;\r\n property OnDragDrop;\r\n property OnDragOver;\r\n property OnEnabledChanged;\r\n property OnEndDrag;\r\n property OnEnter;\r\n property OnExit;\r\n property OnKeyDown;\r\n property OnKeyPress;\r\n property OnKeyUp;\r\n property OnKillFocus;\r\n property OnMouseDown;\r\n property OnMouseEnter;\r\n property OnMouseLeave;\r\n property OnMouseMove;\r\n property OnMouseUp;\r\n property OnParentColorChange;\r\n property OnSetFocus;\r\n property OnStartDrag;\r\n\r\n property OnGetValidDateString;\r\n property OnPopupShown;\r\n property OnPopupHidden;\r\n property OnPopupChange;\r\n property OnPopupValueAccepted;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvDatePickerEdit.pas $';\r\n Revision: '$Revision: 13415 $';\r\n Date: '$Date: 2012-09-10 11:51:54 +0200 (lun. 10 sept. 2012) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n Variants, SysUtils, Menus,\r\n {$IFDEF HAS_UNIT_CHARACTER}\r\n Character, // for inline\r\n {$ENDIF HAS_UNIT_CHARACTER}\r\n JclStrings,\r\n JvConsts, JvTypes, JvResources, JclSysUtils;\r\n\r\nconst\r\n DateMaskSuffix = '!;1;_';\r\n\r\n//=== { TJvCustomDatePickerEdit } ============================================\r\n\r\nprocedure TJvCustomDatePickerEdit.AcceptValue(const Value: Variant);\r\nvar\r\n TextBefore: string;\r\n TmpDate: TDateTime;\r\n TmpValue: Variant;\r\n OldFormat: string;\r\n OldSeparator: Char;\r\nbegin\r\n TextBefore := Text;\r\n\r\n // Mantis 3056: If the date format is not the system's default, the value\r\n // displayed in the text box after having selected a date in the popup\r\n // will be 30.12.1899. This is because the variant will be converted to a\r\n // string using ShortDateFormat. So we change it here, to ensure it is\r\n // the one for the control. We also have to do the cast to a string\r\n // ourselves because VarToStr (called in TJvCustomComboEdit) ignores the\r\n // ShortDateFormat variable.\r\n // And we only call the inherited method this way if the variant is a\r\n // date, or we would risk an exception trying to convert something to a\r\n // date when it is not.\r\n if VarIsType(Value, varDate) then\r\n begin\r\n OldFormat := JclFormatSettings.ShortDateFormat;\r\n OldSeparator := JclFormatSettings.DateSeparator;\r\n try\r\n JclFormatSettings.ShortDateFormat := FInternalDateFormat;\r\n JclFormatSettings.DateSeparator := FDateSeparator;\r\n TmpDate := Value;\r\n TmpValue := DateToStr(TmpDate);\r\n inherited AcceptValue(TmpValue);\r\n finally\r\n JclFormatSettings.ShortDateFormat := OldFormat;\r\n JclFormatSettings.DateSeparator := OldSeparator;\r\n end;\r\n end\r\n else\r\n inherited AcceptValue(TmpValue);\r\n\r\n // Inherited AcceptValue will change the base class Text property, thus not\r\n // calling our SetText method. As a result, we must set the date in this case\r\n if Text <> TextBefore then\r\n begin\r\n AttemptTextToDate(Text, TmpDate, False);\r\n Self.Date := TmpDate;\r\n end;\r\nend;\r\n\r\nfunction TJvCustomDatePickerEdit.ActiveFigure: TJvDateFigureInfo;\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := 2 downto 0 do\r\n { SelStart is 0-based, FDateFigures[I].Start is 1-based }\r\n if SelStart + 1 >= FDateFigures[I].Start then\r\n begin\r\n Result := FDateFigures[I];\r\n Exit;\r\n end;\r\n Result.Figure := dfNone;\r\nend;\r\n\r\nfunction TJvCustomDatePickerEdit.GetValidDateString(const Text: string): string;\r\nbegin\r\n Result := Text;\r\n if Assigned(FOnGetValidDateString) then\r\n FOnGetValidDateString(Self, Result);\r\nend;\r\n\r\nfunction TJvCustomDatePickerEdit.AttemptTextToDate(const AText: string;\r\n var ADate: TDateTime; const AForce: Boolean; const ARaise: Boolean): Boolean;\r\nvar\r\n OldFormat: string;\r\n OldSeparator: Char;\r\n OldDate: TDateTime;\r\n Dummy: Integer;\r\nbegin\r\n {only attempt to convert, if at least the Mask is matched\r\n - otherwise we'd be swamped by exceptions during input}\r\n if AForce or Validate(AText, Dummy) then\r\n begin\r\n Result := True;\r\n OldDate := ADate;\r\n OldFormat := JclFormatSettings.ShortDateFormat;\r\n OldSeparator := JclFormatSettings.DateSeparator;\r\n try\r\n JclFormatSettings.DateSeparator := FDateSeparator;\r\n JclFormatSettings.ShortDateFormat := FInternalDateFormat;\r\n if AllowNoDate and ((Text = NoDateText) or IsEmptyMaskText(AText)) then\r\n ADate := NoDateValue\r\n else\r\n begin\r\n if ARaise then\r\n ADate := StrToDate(StrRemoveChars(GetValidDateString(AText), [' ']))\r\n else\r\n begin\r\n if not TryStrToDate(StrRemoveChars(GetValidDateString(AText), [' ']), ADate) then\r\n begin\r\n if AText = '' then\r\n ADate := Now\r\n else\r\n ADate := OldDate;\r\n Result := False;\r\n end;\r\n end;\r\n end;\r\n finally\r\n JclFormatSettings.DateSeparator := OldSeparator;\r\n JclFormatSettings.ShortDateFormat := OldFormat;\r\n end;\r\n end\r\n else\r\n Result := False;\r\nend;\r\n\r\nprocedure TJvCustomDatePickerEdit.CalChanged;\r\nvar\r\n NewDate: TDateTime;\r\nbegin\r\n if (FPopup is TJvDropCalendar) then\r\n begin\r\n NewDate := TJvDropCalendar(FPopup).SelDate;\r\n try\r\n if (NewDate <> Date) and EditCanModify then\r\n Date := NewDate;\r\n except\r\n on E: Exception do\r\n begin\r\n { If the EditCanModify method raises an exception the popup calendar is\r\n destroyed in the modal message loop of the exception dialog and when\r\n it returns we are still in the WM_LBUTTONUP handler of the now destroyed\r\n calendar. To prevent this the following code gracefully closes the popup\r\n calendar. }\r\n PopupCloseUp(Self, False);\r\n raise;\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomDatePickerEdit.CalCloseQuery(Sender: TObject; var CanClose: Boolean);\r\nvar\r\n P: TPoint;\r\nbegin\r\n {If we would let the calendar close itself while clicking the button, the\r\n DropButtonClick method would simply reopen it again as it would find the\r\n calendar closed.}\r\n GetCursorPos(P);\r\n CanClose := not PtInRect(Button.BoundsRect, Button.ScreenToClient(P));\r\nend;\r\n\r\nprocedure TJvCustomDatePickerEdit.CalDestroy(Sender: TObject);\r\nbegin\r\n PopupCloseUp(Self, False);\r\nend;\r\n\r\nprocedure TJvCustomDatePickerEdit.CalSelect(Sender: TObject);\r\nbegin\r\n CalChanged;\r\n PopupCloseUp(Self, True);\r\nend;\r\n\r\nprocedure TJvCustomDatePickerEdit.Change;\r\nvar\r\n lDate: TDateTime;\r\n lFigVal: Word;\r\n lActFig: TJvDateFigureInfo;\r\n\r\n procedure SetActiveFigVal(const AValue: Word);\r\n begin\r\n BeginInternalChange;\r\n try\r\n SelStart := lActFig.Start - 1;\r\n SelLength := lActFig.Length;\r\n SelText := Format('%.*d', [lActFig.Length, AValue]);\r\n finally\r\n EndInternalChange;\r\n end;\r\n end;\r\n\r\n procedure EnforceRange(const AMin, AMax: Word);\r\n begin\r\n if lFigVal > AMax then\r\n SetActiveFigVal(AMax)\r\n else\r\n if lFigVal < AMin then\r\n SetActiveFigVal(AMin);\r\n end;\r\n\r\nbegin\r\n if InternalChanging then\r\n Exit;\r\n\r\n FDateError := False;\r\n\r\n if [csDesigning, csDestroying] * ComponentState <> [] then\r\n Exit;\r\n\r\n if (Text <> NoDateText) and (Text <> '') then\r\n begin\r\n lDate := Self.Date;\r\n if AttemptTextToDate(Text, lDate) then\r\n begin\r\n BeginInternalChange;\r\n try\r\n Self.Date := lDate;\r\n finally\r\n EndInternalChange;\r\n end;\r\n end\r\n else\r\n if (not FDeleting) and EnableValidation then\r\n begin\r\n lActFig := ActiveFigure;\r\n\r\n if lActFig.Figure <> dfNone then\r\n begin\r\n lFigVal := StrToIntDef(Trim(Copy(Text, lActFig.Start, lActFig.Length)), 0);\r\n //only enforce range if the cursor is at the end of the current figure:\r\n if SelStart = lActFig.Start + lActFig.Length - 1 then\r\n case lActFig.Figure of\r\n dfDay:\r\n EnforceRange(1, 31);\r\n dfMonth:\r\n EnforceRange(1, 12);\r\n dfYear:\r\n {EnforceRange( MinYear, MaxYear)}; //year-validation still under development\r\n end;\r\n end;\r\n {make sure querying the date in an OnChange event handler always reflects\r\n the current contents of the control and not just the last valid value.}\r\n lDate := NoDateValue;\r\n AttemptTextToDate(Text, lDate, lActFig.Index = High(TJvDateFigures));\r\n if AlwaysReturnEditDate then\r\n FDate := lDate;\r\n end;\r\n end;\r\n inherited Change;\r\nend;\r\n\r\nprocedure TJvCustomDatePickerEdit.Clear;\r\nbegin\r\n Checked := False;\r\nend;\r\n\r\nprocedure TJvCustomDatePickerEdit.ClearMask;\r\nbegin\r\n if EditMask <> '' then\r\n begin\r\n FMask := EditMask;\r\n if not (csDesigning in ComponentState) then\r\n EditMask := '';\r\n end;\r\nend;\r\n\r\nconstructor TJvCustomDatePickerEdit.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n\r\n FAllowNoDate := True;\r\n FAlwaysReturnEditDate := True;\r\n FDate := SysUtils.Date;\r\n FDateError := False;\r\n FDeleting := False;\r\n FEnableValidation := True;\r\n // FMaxYear := 2900;\r\n // FMinYear := 1800;\r\n FNoDateShortcut := TextToShortCut(RsDefaultNoDateShortcut);\r\n FNoDateText := '';\r\n FStoreDate := False;\r\n FStoreDateFormat := False;\r\n\r\n FCalAppearance := TJvMonthCalAppearance.Create;\r\n\r\n ControlState := ControlState + [csCreating];\r\n try\r\n ImageKind := ikDropDown; { force update }\r\n ShowButton := True;\r\n finally\r\n ControlState := ControlState - [csCreating];\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomDatePickerEdit.CreatePopup;\r\nbegin\r\n if not Assigned(FPopup) then\r\n begin\r\n FPopup := TJvDropCalendar.CreateWithAppearance(Self, FCalAppearance);\r\n with TJvDropCalendar(FPopup) do\r\n begin\r\n// SelDate := Self.Date;\r\n //OnChange := Self.CalChange;\r\n OnSelect := Self.CalSelect;\r\n OnDestroy := Self.CalDestroy;\r\n OnCloseQuery := Self.CalCloseQuery;\r\n// OnKillFocus := Self.CalKillFocus;\r\n// Show;\r\n// SetFocus;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomDatePickerEdit.CreateWnd;\r\nbegin\r\n inherited CreateWnd;\r\n\r\n // obones: changed to DateFormat instead of ShortDateFormat, it was\r\n // preventing any date format different from the system's value to be\r\n // set at design time\r\n SetDateFormat(DateFormat);\r\nend;\r\n\r\nfunction TJvCustomDatePickerEdit.DateFormatToEditMask(\r\n var ADateFormat: string): string;\r\nbegin\r\n StrReplace(ADateFormat, 'dddddd', JclFormatSettings.LongDateFormat, []);\r\n StrReplace(ADateFormat, 'ddddd', JclFormatSettings.ShortDateFormat, []);\r\n StrReplace(ADateFormat, 'dddd', '', []); // unsupported: DoW as full name\r\n StrReplace(ADateFormat, 'ddd', '', []); // unsupported: DoW as abbrev\r\n StrReplace(ADateFormat, 'MMMM', 'MM', []);\r\n StrReplace(ADateFormat, 'MMM', 'M', []);\r\n Result := ADateFormat;\r\n StrReplace(Result, 'dd', '00', []);\r\n StrReplace(Result, 'd', '99', []);\r\n StrReplace(Result, 'MM', '00', []);\r\n StrReplace(Result, 'M', '99', []);\r\n StrReplace(Result, 'yyyy', '0099', []);\r\n StrReplace(Result, 'yy', '00', []);\r\n StrReplace(Result, ' ', '_', []);\r\n Result := Trim(Result) + DateMaskSuffix;\r\nend;\r\n\r\nfunction TJvCustomDatePickerEdit.DateToText(const ADate: TDateTime): string;\r\nvar\r\n OldSep: Char;\r\nbegin\r\n OldSep := JclFormatSettings.DateSeparator;\r\n // without this a slash would always be converted to SysUtils.DateSeparator\r\n JclFormatSettings.DateSeparator := Self.DateSeparator;\r\n try\r\n Result := FormatDateTime(FInternalDateFormat, ADate);\r\n finally\r\n JclFormatSettings.DateSeparator := OldSep;\r\n end;\r\nend;\r\n\r\nclass function TJvCustomDatePickerEdit.DefaultImageIndex: TImageIndex;\r\nbegin\r\n Result := TJvDateEdit.DefaultImageIndex;\r\nend;\r\n\r\ndestructor TJvCustomDatePickerEdit.Destroy;\r\nbegin\r\n FreeAndNil(FCalAppearance);\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJvCustomDatePickerEdit.DetermineDateSeparator(AFormat: string): Char;\r\nbegin\r\n AFormat := StrRemoveChars(Trim(AFormat), ['d', 'M', 'y']);\r\n if AFormat <> '' then\r\n Result := AFormat[1]\r\n else\r\n Result := JclFormatSettings.DateSeparator;\r\nend;\r\n\r\nprocedure TJvCustomDatePickerEdit.DoCtl3DChanged;\r\nbegin\r\n inherited DoCtl3DChanged;\r\n { (rb) Conflicts with ButtonFlat property }\r\n Button.Flat := not Self.Ctl3D;\r\nend;\r\n\r\nfunction TJvCustomDatePickerEdit.ValidateEditText: string;\r\nvar\r\n lDate: TDateTime;\r\nbegin\r\n Result := '';\r\n if EnableValidation then\r\n try\r\n lDate := Self.Date;\r\n if (Text <> NoDateText) and AttemptTextToDate(Text, lDate, True, True) then\r\n Self.Date := lDate;\r\n except\r\n on EConvertError do\r\n if not (csDestroying in ComponentState) then\r\n begin\r\n FDateError := True;\r\n SetFocus;\r\n raise;\r\n end\r\n else\r\n Self.Date := NoDateValue;\r\n end;\r\n if AllowNoDate and (lDate = NoDateValue) then\r\n begin\r\n Result := EditText;\r\n EditText := '';\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomDatePickerEdit.CMExit(var Msg: TMessage);\r\nvar\r\n OrgEditText: string;\r\nbegin\r\n OrgEditText := ValidateEditText;\r\n inherited;\r\n if OrgEditText <> '' then\r\n EditText := OrgEditText;\r\nend;\r\n\r\nprocedure TJvCustomDatePickerEdit.DoKillFocus(const ANextControl: TWinControl);\r\nbegin\r\n if ((ANextControl = nil) or ((ANextControl <> FPopup) and\r\n (ANextControl.Owner <> FPopup))) and not FDateError then\r\n PopupCloseUp(Self, False);\r\n inherited DoKillFocus(ANextControl);\r\nend;\r\n\r\n//procedure TJvCustomDatePickerEdit.DropButtonClick(Sender: TObject);\r\n//begin\r\n// if Dropped then\r\n// CloseUp\r\n// else\r\n// DropDown;\r\n//end;\r\n\r\n//procedure TJvCustomDatePickerEdit.DropDown;\r\n//begin\r\n// if not Dropped then\r\n// begin\r\n// if IsEmpty then\r\n// Self.Date := SysUtils.Date;\r\n//\r\n// FDropFo := TJvDropCalendar.CreateWithAppearance(Self, FCalAppearance);\r\n// with FDropFo do\r\n// begin\r\n// SelDate := Self.Date;\r\n// OnChange := Self.CalChange;\r\n// OnSelect := Self.CalSelect;\r\n// OnDestroy := Self.CalDestroy;\r\n// OnCloseQuery := Self.CalCloseQuery;\r\n// OnKillFocus := Self.CalKillFocus;\r\n// Show;\r\n// SetFocus;\r\n// end;\r\n// end;\r\n//end;\r\n\r\nprocedure TJvCustomDatePickerEdit.EnabledChanged;\r\nbegin\r\n inherited EnabledChanged;\r\n if not Enabled and Dropped then\r\n PopupCloseUp(Self, False);\r\nend;\r\n\r\nprocedure TJvCustomDatePickerEdit.FindSeparators(var AFigures: TJvDateFigures;\r\n const AText: string; const AGetLengths: Boolean);\r\nbegin\r\n //TODO 3 : make up for escaped characters in EditMask\r\n AFigures[0].Start := 1;\r\n AFigures[1].Start := Pos(DateSeparator, AText) + 1;\r\n AFigures[2].Start := StrLastPos(DateSeparator, AText) + 1;\r\n\r\n if AGetLengths then\r\n begin\r\n AFigures[0].Length := AFigures[1].Start - 2;\r\n AFigures[1].Length := AFigures[2].Start - AFigures[1].Start - 1;\r\n AFigures[2].Length := Length(AText) - AFigures[2].Start + 1;\r\n end;\r\nend;\r\n\r\nfunction TJvCustomDatePickerEdit.GetChecked: Boolean;\r\nbegin\r\n Result := not IsEmpty;\r\nend;\r\n\r\nfunction TJvCustomDatePickerEdit.GetDate: TDateTime;\r\nbegin\r\n Result := FDate;\r\nend;\r\n\r\nfunction TJvCustomDatePickerEdit.GetDropped: Boolean;\r\nbegin\r\n //Result := Assigned(FDropFo) and not (csDestroying in FDropFo.ComponentState);\r\n Result := PopupVisible;\r\nend;\r\n\r\nfunction TJvCustomDatePickerEdit.GetEditMask: string;\r\nbegin\r\n Result := inherited EditMask;\r\nend;\r\n\r\nfunction TJvCustomDatePickerEdit.GetEnableValidation: Boolean;\r\nbegin\r\n Result := FEnableValidation;\r\nend;\r\n\r\nfunction TJvCustomDatePickerEdit.GetPopupValue: Variant;\r\nbegin\r\n if FPopup is TJvDropCalendar then\r\n Result := TJvDropCalendar(FPopup).SelDate;\r\nend;\r\n\r\nfunction TJvCustomDatePickerEdit.GetText: TCaption;\r\nvar\r\n OldSep: Char;\r\nbegin\r\n OldSep := JclFormatSettings.DateSeparator;\r\n JclFormatSettings.DateSeparator := Self.DateSeparator;\r\n try\r\n Result := inherited Text;\r\n finally\r\n JclFormatSettings.DateSeparator := OldSep;\r\n end;\r\nend;\r\n\r\nfunction TJvCustomDatePickerEdit.HasValidDate: Boolean;\r\nvar\r\n TmpDate: TDateTime;\r\nbegin\r\n Result := AttemptTextToDate(Text, TmpDate, False, False);\r\nend;\r\n\r\nprocedure TJvCustomDatePickerEdit.HidePopup;\r\nbegin\r\n// inherited;\r\n if FPopup is TJvDropCalendar then\r\n begin\r\n TJvDropCalendar(FPopup).Hide;\r\n if Assigned(OnPopupHidden) then\r\n OnPopupHidden(Self);\r\n end;\r\nend;\r\n\r\nfunction TJvCustomDatePickerEdit.IsEmpty: Boolean;\r\nbegin\r\n Result := FDate = NoDateValue;\r\nend;\r\n\r\nfunction TJvCustomDatePickerEdit.IsEmptyMaskText(const AText: string): Boolean;\r\nbegin\r\n Result := AnsiSameStr(AText, FEmptyMaskText);\r\nend;\r\n\r\nfunction TJvCustomDatePickerEdit.IsNoDateShortcutStored: Boolean;\r\nbegin\r\n Result := (NoDateShortcut <> TextToShortCut(RsDefaultNoDateShortcut));\r\nend;\r\n\r\nfunction TJvCustomDatePickerEdit.IsNoDateTextStored: Boolean;\r\nbegin\r\n Result := NoDateText <> '';\r\nend;\r\n\r\nfunction TJvCustomDatePickerEdit.IsNoDateValueStored: Boolean;\r\nbegin\r\n Result := NoDateValue <> 0;\r\nend;\r\n\r\nprocedure TJvCustomDatePickerEdit.RestoreMaskForKeyPress;\r\nbegin\r\n try\r\n if ((EditMask = '') or (EditMask <> FMask)) and (Text = NoDateText) {and EditCanModify} then\r\n begin\r\n Text := '';\r\n RestoreMask;\r\n end;\r\n except\r\n Text := '';\r\n RestoreMask;\r\n raise;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomDatePickerEdit.KeyDown(var Key: Word; Shift: TShiftState);\r\nvar\r\n // Indicates whether FDeleting is set here from False to True.\r\n DeleteSetHere: Boolean;\r\n OrgEditText: string;\r\n WasUnmasked: Boolean;\r\nbegin\r\n DeleteSetHere := False;\r\n WasUnmasked := not IsMasked;\r\n RestoreMaskForKeyPress;\r\n\r\n if AllowNoDate and (ShortCut(Key, Shift) = NoDateShortcut) and EditCanModify then\r\n Date := NoDateValue\r\n else\r\n if Shift * KeyboardShiftStates = [] then\r\n case Key of\r\n VK_BACK, VK_CLEAR, VK_DELETE, VK_EREOF, VK_OEM_CLEAR:\r\n begin\r\n DeleteSetHere := not FDeleting;\r\n FDeleting := True;\r\n\r\n { Workaround for an TMaskEdit bug: If the NoDateText is visible and the\r\n user presses VK_BACK the TCustomMaskEdit.DeleteKeys will raise an\r\n access violation.\r\n Fortunately we have already cleared the edit in RestoreMaskForKeyPress(). }\r\n if (Key = VK_BACK) and (SelStart = 0) and (SelLength = 1) and WasUnmasked then\r\n Key := 0;\r\n end;\r\n VK_RETURN:\r\n begin\r\n OrgEditText := ValidateEditText;\r\n if OrgEditText <> '' then\r\n EditText := OrgEditText;\r\n end;\r\n end;\r\n inherited KeyDown(Key, Shift);\r\n FDeleting := FDeleting and not DeleteSetHere;\r\nend;\r\n\r\nprocedure TJvCustomDatePickerEdit.KeyPress(var Key: Char);\r\nvar\r\n OldSep: Char;\r\nbegin\r\n { If used in JvDBGrid the KeyDown event isn't invoked, so the EditMask isn't set\r\n when the KeyPress event triggers. }\r\n RestoreMaskForKeyPress;\r\n\r\n { this makes the transition easier for users used to non-mask-aware edit controls\r\n as they could continue typing the separator character without the cursor\r\n auto-advancing to the next figure when they don't expect it : }\r\n if ((Key = Self.DateSeparator) and (Text[SelStart] = Self.DateSeparator)) or\r\n ((CharIsPrintable(Key) or (Key = #8)) and not EditCanModify) then\r\n begin\r\n Key := #0;\r\n Exit;\r\n end;\r\n { EditCanModify could have triggered a ClearMask. }\r\n RestoreMaskForKeyPress;\r\n\r\n OldSep := JclFormatSettings.DateSeparator;\r\n JclFormatSettings.DateSeparator := Self.DateSeparator;\r\n try\r\n inherited KeyPress(Key);\r\n finally\r\n JclFormatSettings.DateSeparator := OldSep;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomDatePickerEdit.Loaded;\r\nvar\r\n SavedWidth : Integer;\r\nbegin\r\n // (obones) Mantis 2491: After a copy and paste operation in the IDE, the new\r\n // control would be one pixel less in width. This is caused by a call to\r\n // SetText that triggers a call to TCustomMaskEdit.CheckCursor that sends\r\n // WM_LEFT to the control. Somehow, this ends up being eaten by the designer\r\n // and reduces the width. Add a call to CheckCursor just before UpdateDisplay\r\n // below, you'll see it's reduced by two. What's weird is that if you do the\r\n // exact same thing in Loaded in TJvCustomCheckedMaskedEdit, the width does\r\n // not get reduced. So it must be something in this class, but I cannot\r\n // figure out exactly what is done here to trigger this. For now, Let's just\r\n // save and restore the width.\r\n SavedWidth := Width;\r\n try\r\n inherited Loaded;\r\n UpdateDisplay;\r\n finally\r\n Width := SavedWidth;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomDatePickerEdit.ParseFigures(var AFigures: TJvDateFigures;\r\n AFormat: string; const AMask: string);\r\nvar\r\n I: Integer;\r\n DummyFigures: TJvDateFigures;\r\nbegin\r\n {Determine the position of the individual figures in the mask string.}\r\n FindSeparators(AFigures, AMask);\r\n AFigures[2].Length := AFigures[2].Length - Length(DateMaskSuffix);\r\n\r\n AFormat := UpperCase(AFormat);\r\n\r\n {Determine the order of the individual figures in the format string.}\r\n FindSeparators(DummyFigures, AFormat, False);\r\n\r\n for I := 0 to 2 do\r\n begin\r\n case AFormat[DummyFigures[I].Start] of\r\n 'D':\r\n AFigures[I].Figure := dfDay;\r\n 'M':\r\n AFigures[I].Figure := dfMonth;\r\n 'Y':\r\n AFigures[I].Figure := dfYear;\r\n end;\r\n AFigures[I].Index := I;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomDatePickerEdit.PopupChange;\r\nbegin\r\n inherited PopupChange;\r\n DoChange;\r\nend;\r\n\r\nprocedure TJvCustomDatePickerEdit.RaiseNoDate;\r\nbegin\r\n raise EJVCLException.CreateResFmt(@RsEMustHaveADate, [Name]);\r\nend;\r\n\r\nprocedure TJvCustomDatePickerEdit.ResetDateFormat;\r\nbegin\r\n FInternalDateFormat := FDateFormat;\r\n FMask := DateFormatToEditMask(FInternalDateFormat);\r\n ParseFigures(FDateFigures, FInternalDateFormat, FMask);\r\n BeginInternalChange;\r\n try\r\n EditMask := '';\r\n Text := '';\r\n EditMask := FMask;\r\n FEmptyMaskText := Text;\r\n finally\r\n EndInternalChange;\r\n end;\r\n UpdateDisplay;\r\nend;\r\n\r\nprocedure TJvCustomDatePickerEdit.RestoreMask;\r\nbegin\r\n if EditMask = '' then\r\n EditMask := FMask;\r\nend;\r\n\r\nprocedure TJvCustomDatePickerEdit.SetAllowNoDate(const AValue: Boolean);\r\nbegin\r\n if AllowNoDate <> AValue then\r\n begin\r\n FAllowNoDate := AValue;\r\n\r\n if AValue and IsEmpty then\r\n if csDesigning in ComponentState then\r\n Self.Date := SysUtils.Date\r\n else\r\n RaiseNoDate;\r\n\r\n if not AValue then\r\n ShowCheckBox := False;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomDatePickerEdit.SetCalAppearance(const AValue: TJvMonthCalAppearance);\r\nbegin\r\n FCalAppearance.Assign(AValue);\r\nend;\r\n\r\nprocedure TJvCustomDatePickerEdit.SetChecked(const AValue: Boolean);\r\nbegin\r\n inherited SetChecked(AValue);\r\n if Checked <> AValue then\r\n begin\r\n if AValue then\r\n begin\r\n if Self.Date = NoDateValue then\r\n Self.Date := SysUtils.Date;\r\n end\r\n else\r\n Self.Date := NoDateValue;\r\n Change;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomDatePickerEdit.SetDate(const AValue: TDateTime);\r\nbegin\r\n if (FDate <> AValue) and ValidateDate(AValue) then\r\n begin\r\n StoreDate := Trunc(AValue) = Trunc(FDate);\r\n FDate := AValue;\r\n if AValue <> NoDateValue then\r\n Checked := True;\r\n DoChange;\r\n end;\r\n UpdateDisplay;\r\nend;\r\n\r\nprocedure TJvCustomDatePickerEdit.SetDateFormat(AValue: string);\r\nbegin\r\n if AValue = '' then\r\n AValue := JclFormatSettings.ShortDateFormat;\r\n if AValue <> FDateFormat then\r\n begin\r\n FDateFormat := AValue;\r\n FDateSeparator := DetermineDateSeparator(FDateFormat);\r\n StoreDateFormat := FDateFormat <> JclFormatSettings.ShortDateFormat;\r\n ResetDateFormat;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomDatePickerEdit.SetDateSeparator(const AValue: Char);\r\nbegin\r\n if AValue <> FDateSeparator then\r\n begin\r\n FDateSeparator := AValue;\r\n ResetDateFormat;\r\n end;\r\nend;\r\n\r\n{ The only purpose of the following overrides is to overcome a known issue in\r\n Mask.pas where it is impossible to use the slash character in an EditMask if\r\n SysUtils.DateSeparator is set to something else even if the slash was escaped\r\n as a literal. By inheritance the following methods all end up eventually in\r\n Mask.MaskIntlLiteralToChar which performs the unwanted conversion. By\r\n temporarily setting SysUtils.DateSeparator we could circumvent this. }\r\n\r\nprocedure TJvCustomDatePickerEdit.SetEditMask(const AValue: string);\r\nvar\r\n OldSep: Char;\r\n Designing: Boolean;\r\nbegin\r\n{ if csDesigning in ComponentState then\r\n Exit;}\r\n\r\n OldSep := JclFormatSettings.DateSeparator;\r\n JclFormatSettings.DateSeparator := Self.DateSeparator;\r\n try\r\n Designing := False;\r\n if csDesigning in ComponentState then\r\n begin\r\n // If SetEditMask is called from CreateWnd via SetDateFormat, the TMaskEdit.SetCursor emulates\r\n // a Shift+Left/Right key press. The form designer catches the key press and the\r\n // IDE's Designer Guidelines code throws an access violation.\r\n // With this we disable the form designer until \"inherted EditMask\" was executed.\r\n Designing := True;\r\n SetDesigning(False, False);\r\n end;\r\n try\r\n inherited EditMask := AValue;\r\n finally\r\n if Designing then\r\n SetDesigning(True, False);\r\n end;\r\n finally\r\n JclFormatSettings.DateSeparator := OldSep;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomDatePickerEdit.SetNoDateText(const AValue: string);\r\nbegin\r\n FNoDateText := AValue;\r\n UpdateDisplay;\r\nend;\r\n\r\nprocedure TJvCustomDatePickerEdit.SetNoDateValue(const AValue: TDateTime);\r\nbegin\r\n if AValue <> FNoDateValue then\r\n begin\r\n FNoDateValue := AValue;\r\n UpdateDisplay;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomDatePickerEdit.SetPopupValue(const Value: Variant);\r\nvar\r\n NewDate: TDateTime;\r\nbegin\r\n if FPopup is TJvDropCalendar then\r\n begin\r\n // We must do the conversion ourselves as the date format might\r\n // have been personalized. (Mantis 3628)\r\n // Default to Now if the Value is not valid. (Mantis 3733)\r\n if (Value = Null) or (Value = NoDateText) or not AttemptTextToDate(VarToStr(Value), NewDate) then\r\n NewDate := Now;\r\n FPopupDate := NewDate;\r\n TJvDropCalendar(FPopup).SelDate := NewDate;\r\n end;\r\nend;\r\n\r\nfunction TJvCustomDatePickerEdit.AcceptPopup(var Value: Variant): Boolean;\r\nbegin\r\n Result := inherited AcceptPopup(Value);\r\n if Result then\r\n Result := Value <> FPopupDate;\r\nend;\r\n\r\nprocedure TJvCustomDatePickerEdit.SetShowCheckbox(const AValue: Boolean);\r\nbegin\r\n inherited SetShowCheckbox(AValue);\r\n if AValue then\r\n AllowNoDate := True;\r\n UpdateDisplay;\r\nend;\r\n\r\nprocedure TJvCustomDatePickerEdit.SetText(const AValue: TCaption);\r\nvar\r\n OldSep: Char;\r\nbegin\r\n OldSep := JclFormatSettings.DateSeparator;\r\n JclFormatSettings.DateSeparator := Self.DateSeparator;\r\n try\r\n inherited Text := AValue;\r\n finally\r\n JclFormatSettings.DateSeparator := OldSep;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomDatePickerEdit.ShowPopup(Origin: TPoint);\r\nbegin\r\n if FPopup is TJvDropCalendar then\r\n begin\r\n TJvDropCalendar(FPopup).Show;\r\n if Assigned(OnPopupShown) then\r\n OnPopupShown(Self);\r\n end\r\n else\r\n begin\r\n inherited ShowPopup(Origin);\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomDatePickerEdit.UpdateDisplay;\r\nbegin\r\n if InternalChanging or (csLoading in ComponentState) then\r\n Exit;\r\n\r\n // (obones): We need a valid handle here, because setting the text\r\n // will read the value of DateSeparator. This value is #0 until the\r\n // CreateWnd method is called.\r\n // If we don't do that, setting any property that changes the display\r\n // (like checked) just after having created the control at runtime\r\n // would trigger an \"Invalid date\" exception because the date, month\r\n // and day would not be separated at all.\r\n // Doing this means that a parent is required for the change to work.\r\n HandleNeeded;\r\n\r\n BeginInternalChange;\r\n try\r\n inherited SetChecked(not IsEmpty);\r\n if IsEmpty then\r\n begin\r\n if not (csDesigning in ComponentState) then\r\n begin\r\n ClearMask;\r\n Text := NoDateText;\r\n end;\r\n end\r\n else\r\n begin\r\n RestoreMask;\r\n Text := DateToText(Self.Date)\r\n end;\r\n finally\r\n EndInternalChange;\r\n end;\r\nend;\r\n\r\nfunction TJvCustomDatePickerEdit.ValidateDate(const ADate: TDateTime): Boolean;\r\nbegin\r\n if not AllowNoDate and (ADate = NoDateValue) then\r\n RaiseNoDate;\r\n if (ADate < EncodeDate(1752, 09, 14)) or ((ADate > EncodeDate(1752, 09, 19)) and (ADate < EncodeDate(1752, 10, 1))) then\r\n { For historical/political reasons the days 1752-09-03 - 1752-09-13 do not\r\n exist in the Gregorian calendar - for some unknown reason the Microsoft\r\n calendar treats the period between 1752-09-20 and 1752-09-30 as missing\r\n instead, even though dates before 1752-09-14 are considered invalid as\r\n well (MS' offical explanation saying they only support the Gregorian\r\n calendar as of British adoption of it is not accurate: Britain adopted the\r\n Gregorian calendar starting 1752-01-01).}\r\n Result := False\r\n else\r\n Result := True;\r\nend;\r\n\r\nprocedure TJvCustomDatePickerEdit.WMPaste(var Msg: TMessage);\r\nvar\r\n OldSep: Char;\r\nbegin\r\n if csDesigning in ComponentState then\r\n Exit;\r\n\r\n OldSep := JclFormatSettings.DateSeparator;\r\n JclFormatSettings.DateSeparator := Self.DateSeparator;\r\n try\r\n inherited;\r\n finally\r\n JclFormatSettings.DateSeparator := OldSep;\r\n end;\r\nend;\r\n\r\n//=== { TJvDropCalendar } ====================================================\r\n\r\nprocedure TJvDropCalendar.CalKeyPress(Sender: TObject; var Key: Char);\r\nbegin\r\n if WithBeep then\r\n SysUtils.Beep;\r\n case Word(Key) of\r\n VK_RETURN:\r\n DoSelect;\r\n VK_ESCAPE:\r\n DoCancel;\r\n else\r\n DoChange;\r\n end;\r\nend;\r\n\r\nprocedure TJvDropCalendar.CalKillFocus(const ASender: TObject;\r\n const ANextControl: TWinControl);\r\nvar\r\n P: TPoint;\r\nbegin\r\n GetCursorPos(P);\r\n if PtInRect(BoundsRect, P) then\r\n Exit;\r\n if Assigned(ANextControl) then\r\n FocusKilled(ANextControl.Handle)\r\n else\r\n FocusKilled(0);\r\nend;\r\n\r\nprocedure TJvDropCalendar.CalSelChange(Sender: TObject;\r\n StartDate, EndDate: TDateTime);\r\nbegin\r\n DoChange;\r\nend;\r\n\r\nprocedure TJvDropCalendar.CalSelect(Sender: TObject; StartDate, EndDate: TDateTime);\r\nbegin\r\n DoSelect;\r\nend;\r\n\r\nconstructor TJvDropCalendar.CreateWithAppearance(AOwner: TComponent;\r\n const AAppearance: TJvMonthCalAppearance);\r\nbegin\r\n inherited Create(AOwner);\r\n FWithBeep := False;\r\n FCal := TJvMonthCalendar2.CreateWithAppearance(Self, AAppearance);\r\n with TJvMonthCalendar2(FCal) do\r\n begin\r\n Parent := Self;\r\n ParentFont := True;\r\n OnSelChange := CalSelChange;\r\n OnSelect := CalSelect;\r\n OnKillFocus := CalKillFocus;\r\n OnKeyPress := CalKeyPress;\r\n Visible := True;\r\n AutoSize := True;\r\n end;\r\nend;\r\n\r\ndestructor TJvDropCalendar.Destroy;\r\nbegin\r\n if Assigned(FCal) then\r\n with TJvMonthCalendar2(FCal) do\r\n begin\r\n OnSelChange := nil;\r\n OnSelect := nil;\r\n OnKeyPress := nil;\r\n end;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvDropCalendar.DoCancel;\r\nbegin\r\n if Assigned(OnCancel) then\r\n OnCancel(Self)\r\n else\r\n Release;\r\nend;\r\n\r\nprocedure TJvDropCalendar.DoChange;\r\nbegin\r\n if Assigned(OnChange) then\r\n OnChange(Self);\r\nend;\r\n\r\nprocedure TJvDropCalendar.DoSelect;\r\nvar\r\n LastCloseOnLeave: Boolean;\r\nbegin\r\n { Protect against releasing the calendar in the message loop of the\r\n Application.HandleException dialog. }\r\n LastCloseOnLeave := CloseOnLeave;\r\n try\r\n CloseOnLeave := False;\r\n if Assigned(OnSelect) then\r\n OnSelect(Self);\r\n finally\r\n CloseOnLeave := LastCloseOnLeave;\r\n end;\r\nend;\r\n\r\nprocedure TJvDropCalendar.DoShow;\r\nbegin\r\n {\r\n In the constructor the calendar will sometimes report\r\n the wrong size, so we do this here.\r\n }\r\n AutoSize := True;\r\n TJvMonthCalendar2(FCal).Today := Date; { update the current day }\r\n inherited DoShow;\r\nend;\r\n\r\nfunction TJvDropCalendar.GetSelDate: TDateTime;\r\nbegin\r\n Result := TJvMonthCalendar2(FCal).DateFirst;\r\nend;\r\n\r\nprocedure TJvDropCalendar.SetFocus;\r\nbegin\r\n if FCal.CanFocus then\r\n FCal.SetFocus\r\n else\r\n inherited SetFocus;\r\nend;\r\n\r\nprocedure TJvDropCalendar.SetSelDate(const AValue: TDateTime);\r\nbegin\r\n TJvMonthCalendar2(FCal).DateFirst := AValue;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvDateTimePicker.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvDateTimePicker.PAS, released on 2001-02-28.\r\n\r\nThe Initial Developer of the Original Code is S?stien Buysse [sbuysse att buypin dott com]\r\nPortions created by Sbastien Buysse are Copyright (C) 2001 Sbastien Buysse.\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\nMichael Beck [mbeck att bigfoot dott com]\r\n\r\nPeter Thrnqvist [peter3 att peter3 dott com]:\r\n* Added NullDate, NullText and DropDownDate properties\r\n * Bug: When TDateTImePicker is used for TIMES, it is impossible to turn\r\n off the NullDate feature. It should be optional! -W.Postma.\r\n\r\nMarc Geldon [marcgeldon att web dott de]\r\n* Fixed CheckNullValue (any nonformat characters must be enclosed within single quotes!)\r\n\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n* (p3) To make NullDate and NullText maximally useful, set ParseInput to True and handle the\r\n OnUserInput something like this:\r\n if UserString = '' then\r\n DateAndTime := JvDateTimePicker1.NullDate;\r\n\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvDateTimePicker.pas 13415 2012-09-10 09:51:54Z obones $\r\n\r\nunit JvDateTimePicker;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, Messages, SysUtils, Classes, Controls, ComCtrls,\r\n JvExComCtrls;\r\n\r\ntype\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvDateTimePicker = class(TJvExDateTimePicker)\r\n private\r\n FNullText: string;\r\n FNullDate: TDateTime;\r\n FDropDownDate: TDate;\r\n FWeekNumbers: Boolean;\r\n FMsgSetDateTimeEmptyNullText: Boolean;\r\n FShowTodayCircle: Boolean;\r\n FShowToday: Boolean;\r\n procedure CNNotify(var Msg: TWMNotify); message CN_NOTIFY;\r\n procedure SetNullDate(const Value: TDateTime);\r\n procedure SetNullText(const Value: string);\r\n procedure UpdateCalendar(CalHandle: THandle);\r\n protected\r\n function WithinDelta(Val1, Val2: TDateTime): Boolean; virtual;\r\n // returns True if NullDate matches Date or frac(NullDate) matches frac(Time) depending on Kind\r\n function CheckNullValue: Boolean; overload;\r\n function CheckNullValue(const ANullText, AFormat: string; AKind: TDateTimeKind; ADateTime, ANullDate: TDateTime): Boolean; overload; virtual;\r\n procedure Change; override;\r\n function MsgSetDateTime(Value: TSystemTime): Boolean; override;\r\n procedure CheckValidDate(Value: TDate); override;\r\n procedure CheckEmptyDate; override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n procedure Clear;\r\n function IsNull: Boolean;\r\n published\r\n property AutoSize;\r\n // The initial date to display when the drop-down calendar is shown and NullDate = Date/Time\r\n property DropDownDate: TDate read FDropDownDate write FDropDownDate;\r\n // The Date/Time (depending on the Kind property) that represents an empty \"null\" value, default is 1899-12-31\r\n property NullDate: TDateTime read FNullDate write SetNullDate;\r\n // The text to display when NullDate = Date/Time\r\n property NullText: string read FNullText write SetNullText;\r\n property WeekNumbers: Boolean read FWeekNumbers write FWeekNumbers default False;\r\n property ShowToday: Boolean read FShowToday write FShowToday default True;\r\n property ShowTodayCircle: Boolean read FShowTodayCircle write FShowTodayCircle default True;\r\n property HintColor;\r\n property OnMouseEnter;\r\n property OnMouseLeave;\r\n property OnParentColorChange;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvDateTimePicker.pas $';\r\n Revision: '$Revision: 13415 $';\r\n Date: '$Date: 2012-09-10 11:51:54 +0200 (lun. 10 sept. 2012) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n CommCtrl,\r\n Types,\r\n JvThemes;\r\n\r\n{$IFNDEF COMPILER7_UP}\r\nconst\r\n ComCtlVersionIE6 = $00060000;\r\n{$ENDIF !COMPILER7_UP}\r\n\r\nprocedure SetCalendarStyle(AHandle: THandle; Value: Integer; UseStyle: Boolean);\r\nvar\r\n Style: Integer;\r\nbegin\r\n if AHandle <> 0 then\r\n begin\r\n Style := GetWindowLong(AHandle, GWL_STYLE);\r\n if UseStyle then\r\n Style := Style or Value\r\n else\r\n Style := Style and not Value;\r\n SetWindowLong(AHandle, GWL_STYLE, Style);\r\n end;\r\nend;\r\n\r\nconstructor TJvDateTimePicker.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n// FNullText := RsNoneCaption; XXX Don't do this unless you also set the 'default' specifier in the property declaration above! Causes problems. -WP\r\n FDropDownDate := SysUtils.Date;\r\n FShowToday := True;\r\n FShowTodayCircle := True;\r\nend;\r\n\r\nfunction TJvDateTimePicker.IsNull: Boolean;\r\nbegin\r\n Result := (DateTime = NullDate) and (FNullText <> '');\r\nend;\r\n\r\nfunction TJvDateTimePicker.WithinDelta(Val1, Val2: TDateTime): Boolean;\r\nbegin\r\n Result := Abs(Frac(Val1) - Frac(Val2)) < EncodeTime(0, 0, 1, 0);\r\nend;\r\n\r\nfunction TJvDateTimePicker.CheckNullValue: Boolean;\r\nbegin\r\n Result := CheckNullValue(FNullText, Format, Kind, DateTime, NullDate);\r\nend;\r\n\r\nprocedure TJvDateTimePicker.CheckEmptyDate;\r\nbegin\r\n // Don't throw the EDateTimeError if Date=0.0 and ShowCheckBox=False (Mantis #4651).\r\n // The VCL has some strange behavior here. Why is 1899-12-30 not allowed. The Windows\r\n // Control supports it, but TDateTimePicker doesn't.\r\n // TDateTimePicker.SetTime() can't be \"fixed\" because it doesn't call CheckEmptyDate() but\r\n // has the exact same code inline.\r\n if not ShowCheckbox then\r\n begin\r\n Checked := False;\r\n Invalidate;\r\n end\r\n else\r\n inherited CheckEmptyDate;\r\nend;\r\n\r\nfunction TJvDateTimePicker.CheckNullValue(const ANullText, AFormat: string;\r\n AKind: TDateTimeKind; ADateTime, ANullDate: TDateTime): Boolean;\r\nbegin\r\n // Warren added NullText length check so that this feature can be disabled if not used!\r\n if ANullText = '' then\r\n Result := False\r\n else\r\n Result := ((AKind = dtkDate) and (Trunc(ADateTime) = Trunc(ANullDate)) or\r\n ((AKind = dtkTime) and WithinDelta(ADateTime, ANullDate)));\r\n\r\n if Result then\r\n SendMessage(Handle, DTM_SETFORMAT, 0, LPARAM(PChar('''' + ANullText + '''')))\r\n else\r\n SendMessage(Handle, DTM_SETFORMAT, 0, LPARAM(PChar(AFormat)));\r\nend;\r\n\r\nprocedure TJvDateTimePicker.CheckValidDate(Value: TDate);\r\nbegin\r\n if Value <> NullDate then\r\n inherited CheckValidDate(Value);\r\nend;\r\n\r\nprocedure TJvDateTimePicker.Clear;\r\nbegin\r\n DateTime := NullDate;\r\n Checked := False;\r\nend;\r\n\r\nprocedure TJvDateTimePicker.SetNullDate(const Value: TDateTime);\r\nbegin\r\n FNullDate := Trunc(Value);\r\n CheckNullValue;\r\nend;\r\n\r\nprocedure TJvDateTimePicker.SetNullText(const Value: string);\r\nbegin\r\n if FNullText <> Value then\r\n begin\r\n FNullText := Value;\r\n CheckNullValue;\r\n end;\r\nend;\r\n\r\nfunction TJvDateTimePicker.MsgSetDateTime(Value: TSystemTime): Boolean;\r\nvar\r\n LNullText: string;\r\nbegin\r\n Result := inherited MsgSetDateTime(Value);\r\n if FMsgSetDateTimeEmptyNullText then\r\n LNullText := ''\r\n else\r\n LNullText := FNullText;\r\n CheckNullValue(LNullText, Format, Kind, SystemTimeToDateTime(Value), NullDate);\r\nend;\r\n\r\nprocedure TJvDateTimePicker.Change;\r\nbegin\r\n inherited Change;\r\n CheckNullValue;\r\nend;\r\n\r\nfunction IsBlankSysTime(const St: TSystemTime): Boolean;\r\nbegin\r\n with St do\r\n Result := (wYear = 0) and (wMonth = 0) and\r\n (wDayOfWeek = 0) and (wDay = 0) and\r\n (wHour = 0) and (wMinute = 0) and\r\n (wSecond = 0) and (wMilliseconds = 0);\r\nend;\r\n\r\nfunction IsWinVista_UP: Boolean;\r\nbegin\r\n Result := (Win32Platform = VER_PLATFORM_WIN32_NT) and CheckWin32Version(6, 0);\r\nend;\r\n\r\nprocedure TJvDateTimePicker.UpdateCalendar(CalHandle: THandle);\r\nvar\r\n R, WindowRect: TRect;\r\n MinWidth, MinHeight, MaxTodayWidth: Integer;\r\n SizeHandle: THandle;\r\nbegin\r\n if CalHandle <> 0 then\r\n begin\r\n SetCalendarStyle(CalHandle,MCS_WEEKNUMBERS, WeekNumbers);\r\n SetCalendarStyle(CalHandle,MCS_NOTODAY, not ShowToday);\r\n SetCalendarStyle(CalHandle,MCS_NOTODAYCIRCLE, not ShowTodayCircle);\r\n\r\n MonthCal_GetMinReqRect(CalHandle, R);\r\n with R do\r\n begin\r\n MinHeight := Bottom - Top;\r\n MinWidth := Right - Left;\r\n end;\r\n MaxTodayWidth := MonthCal_GetMaxTodayWidth(CalHandle);\r\n if MinWidth < MaxTodayWidth then MinWidth := MaxTodayWidth;\r\n if IsWinVista_UP and (GetComCtlVersion >= ComCtlVersionIE6) then\r\n begin\r\n // On Vista the popup month calendar has a parent window that we must resize\r\n SizeHandle := GetParent(CalHandle);\r\n // The dropdown window uses a 'border' of..\r\n {$IFDEF JVCLThemesEnabled}\r\n if ThemeServices.{$IFDEF RTL230_UP}Enabled{$ELSE}ThemesEnabled{$ENDIF RTL230_UP} then\r\n begin\r\n // .. 3 pixels when themed\r\n Inc(MinWidth, 3*2);\r\n Inc(MinHeight, 3*2);\r\n end\r\n else\r\n {$ENDIF JVCLThemesEnabled}\r\n begin\r\n // .. otherwise 5 pixels\r\n Inc(MinWidth, 5*2);\r\n Inc(MinHeight, 5*2);\r\n end;\r\n end\r\n else\r\n SizeHandle := CalHandle;\r\n GetWindowRect(SizeHandle, WindowRect);\r\n MoveWindow(SizeHandle, WindowRect.Left, WindowRect.Top, MinWidth, MinHeight, False);\r\n end;\r\nend;\r\n\r\nprocedure TJvDateTimePicker.CNNotify(var Msg: TWMNotify);\r\nvar\r\n ACal: THandle;\r\n St: TSystemTime;\r\n Dt: TDateTime;\r\n AllowChange: Boolean;\r\n WasMsgEmptyNullText: Boolean;\r\nbegin\r\n with Msg, NMHdr^ do\r\n case code of\r\n DTN_DROPDOWN:\r\n begin\r\n inherited;\r\n ACal := DateTime_GetMonthCal(Handle);\r\n UpdateCalendar(ACal);\r\n if CheckNullValue and (ACal <> 0) then\r\n begin\r\n DateTimeToSystemTime(FDropDownDate, St);\r\n if not IsBlankSysTime(St) then\r\n MonthCal_SetCurSel(ACal, St);\r\n end;\r\n end;\r\n DTN_USERSTRING:\r\n begin\r\n with PNMDateTimeString(NMHdr)^ do\r\n begin\r\n if not TryStrToDateTime(pszUserString, Dt) then\r\n Dt := NullDate;\r\n if Assigned(OnUserInput) then\r\n begin\r\n AllowChange := True;\r\n OnUserInput(Self, pszUserString, Dt, AllowChange);\r\n dwFlags := Ord(not AllowChange);\r\n end\r\n else\r\n dwFlags := Ord(False);\r\n DateTimeToSystemTime(Dt, St);\r\n end;\r\n end;\r\n DTN_CLOSEUP:\r\n begin\r\n // We need to use the NullText in MsgSetDateTime() because if the user clicked outside\r\n // the popup calendar and the old value was NullValue, the NullValue date would be\r\n // displayed instead of the NullText. And we don't want that to happen.\r\n // Alternatively we could call CheckNullValue() after \"inherited\". But why do the check\r\n // twice with the possibility of a short time span where the NullDate is visible.\r\n WasMsgEmptyNullText := FMsgSetDateTimeEmptyNullText;\r\n FMsgSetDateTimeEmptyNullText := False;\r\n try\r\n inherited;\r\n finally\r\n FMsgSetDateTimeEmptyNullText := WasMsgEmptyNullText;\r\n end;\r\n end;\r\n NM_SETFOCUS:\r\n begin\r\n FMsgSetDateTimeEmptyNullText := True;\r\n inherited;\r\n end;\r\n NM_KILLFOCUS:\r\n begin\r\n FMsgSetDateTimeEmptyNullText := False;\r\n inherited;\r\n end;\r\n else\r\n inherited;\r\n end;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvDdeCmd.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvAppDdeCmd.PAS, released Jan 2, 1998.\r\n\r\nThe Initial Developer of the Original Code is Petr Vones (petr dott v att mujmail dott cz)\r\nPortions created by Petr Vones are Copyright (C) 1999 Petr Vones.\r\nPortions created by Microsoft are Copyright (C) 1998, 1999 Microsoft Corp.\r\nAll Rights Reserved.\r\n\r\nContributor(s): ______________________________________.\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvDdeCmd.pas 13104 2011-09-07 06:50:43Z obones $\r\n\r\nunit JvDdeCmd;\r\n\r\n{$I jvcl.inc}\r\n{$I windowsonly.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Messages, DdeMan, Classes,\r\n JvComponentBase, JvTypes;\r\n\r\ntype\r\n EJvADCParserError = class(EJVCLException);\r\n\r\n TJvADCBusyEvent = procedure(Sender: TObject; IsBusy: Boolean) of object;\r\n\r\n TJvADCParsedEvent = procedure(Sender: TObject; const Command: string;\r\n Parameters: TStrings) of object;\r\n\r\n TJvADCMacroEvent = procedure(Sender: TObject; const CommandStr: string) of object;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvAppDdeCmd = class(TJvComponent)\r\n private\r\n FCorrectParams: Boolean;\r\n FEnabled: Boolean;\r\n FCommands: TStringList;\r\n FIgnoreAppBusy: Boolean;\r\n FModalState: Boolean;\r\n FOnBusyChanged: TJvADCBusyEvent;\r\n FOnExecCommand: TJvADCMacroEvent;\r\n FOnExecParsedCmd: TJvADCParsedEvent;\r\n function GetCommands: TStrings;\r\n procedure SetEnabled(Value: Boolean);\r\n procedure SetIgnoreAppBusy(Value: Boolean);\r\n procedure SetModalState(Value: Boolean);\r\n function AppBusy: Boolean;\r\n procedure ExecuteCommands;\r\n procedure ExecuteParsedCommands(const CmdStr: string);\r\n function HookWndProc(var AMsg: TMessage): Boolean;\r\n procedure Notify(ACommands: TStrings);\r\n protected\r\n procedure BusyStateChanged; dynamic;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n property Commands: TStrings read GetCommands;\r\n published\r\n property CorrectParams: Boolean read FCorrectParams write FCorrectParams default True;\r\n property Enabled: Boolean read FEnabled write SetEnabled default True;\r\n property IgnoreAppBusy: Boolean read FIgnoreAppBusy write SetIgnoreAppBusy default False;\r\n property OnBusyChanged: TJvADCBusyEvent read FOnBusyChanged write FOnBusyChanged;\r\n property OnExecCommand: TJvADCMacroEvent read FOnExecCommand write FOnExecCommand;\r\n property OnExecParsedCmd: TJvADCParsedEvent read FOnExecParsedCmd write FOnExecParsedCmd;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvDdeCmd.pas $';\r\n Revision: '$Revision: 13104 $';\r\n Date: '$Date: 2011-09-07 08:50:43 +0200 (mer. 07 sept. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n SysUtils, Forms,\r\n JvResources;\r\n\r\nconst\r\n DdeTopicStr = 'System';\r\n\r\n//=== { TAppDdeMgr } =========================================================\r\n\r\ntype\r\n TAppDdeMgr = class(TObject)\r\n private\r\n DdeServ: TDdeServerConv;\r\n Commands: TStringList;\r\n Components: TList;\r\n procedure DdeServerConvExecuteMacro(Sender: TObject; Msg: TStrings);\r\n procedure NotifyComponents;\r\n public\r\n constructor Create;\r\n destructor Destroy; override;\r\n procedure AddComponent(AComponent: TComponent);\r\n procedure DeleteComponent(AComponent: TComponent);\r\n end;\r\n\r\nvar\r\n AppDdeMgr: TAppDdeMgr = nil;\r\n\r\nconstructor TAppDdeMgr.Create;\r\nbegin\r\n inherited Create;\r\n if Application.FindComponent(DdeTopicStr) = nil then\r\n begin\r\n DdeServ := TDdeServerConv.Create(Application);\r\n with DdeServ do\r\n begin\r\n Name := DdeTopicStr;\r\n OnExecuteMacro := DdeServerConvExecuteMacro;\r\n end;\r\n Commands := TStringList.Create;\r\n Components := TList.Create;\r\n end;\r\nend;\r\n\r\ndestructor TAppDdeMgr.Destroy;\r\nbegin\r\n FreeAndNil(Components);\r\n FreeAndNil(Commands);\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TAppDdeMgr.AddComponent(AComponent: TComponent);\r\nbegin\r\n Components.Add(AComponent);\r\nend;\r\n\r\nprocedure TAppDdeMgr.DeleteComponent(AComponent: TComponent);\r\nbegin\r\n Components.Remove(AComponent);\r\nend;\r\n\r\nprocedure TAppDdeMgr.DdeServerConvExecuteMacro(Sender: TObject; Msg: TStrings);\r\nbegin\r\n if Components <> nil then\r\n begin\r\n Commands.Add(Msg[0]);\r\n NotifyComponents;\r\n end;\r\nend;\r\n\r\nprocedure TAppDdeMgr.NotifyComponents;\r\nvar\r\n I: Integer;\r\nbegin\r\n with Components do\r\n for I := 0 to Count - 1 do\r\n TJvAppDdeCmd(Items[I]).Notify(Commands);\r\n Commands.Clear;\r\nend;\r\n\r\n//=== { TJvAppDdeCmd } =======================================================\r\n\r\nconstructor TJvAppDdeCmd.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FCorrectParams := True;\r\n FEnabled := True;\r\n FIgnoreAppBusy := False;\r\n FModalState := False;\r\n FCommands := TStringList.Create;\r\n if not (csDesigning in ComponentState) then\r\n begin\r\n if not Assigned(AppDdeMgr) then\r\n AppDdeMgr := TAppDdeMgr.Create;\r\n AppDdeMgr.AddComponent(Self);\r\n Application.HookMainWindow(HookWndProc);\r\n end;\r\nend;\r\n\r\ndestructor TJvAppDdeCmd.Destroy;\r\nbegin\r\n if not (csDesigning in ComponentState) then\r\n begin\r\n Application.UnhookMainWindow(HookWndProc);\r\n AppDdeMgr.DeleteComponent(Self);\r\n end;\r\n FreeAndNil(FCommands);\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJvAppDdeCmd.GetCommands: TStrings;\r\nbegin\r\n Result := FCommands;\r\nend;\r\n\r\nprocedure TJvAppDdeCmd.SetEnabled(Value: Boolean);\r\nbegin\r\n if FEnabled <> Value then\r\n begin\r\n FEnabled := Value;\r\n BusyStateChanged;\r\n end;\r\nend;\r\n\r\nprocedure TJvAppDdeCmd.SetIgnoreAppBusy(Value: Boolean);\r\nbegin\r\n if FIgnoreAppBusy <> Value then\r\n begin\r\n FIgnoreAppBusy := Value;\r\n BusyStateChanged;\r\n end;\r\nend;\r\n\r\nprocedure TJvAppDdeCmd.SetModalState(Value: Boolean);\r\nbegin\r\n if FModalState <> Value then\r\n begin\r\n FModalState := Value;\r\n BusyStateChanged;\r\n end;\r\nend;\r\n\r\nfunction TJvAppDdeCmd.AppBusy: Boolean;\r\nbegin\r\n Result := (not FEnabled) or (FModalState and (not FIgnoreAppBusy));\r\nend;\r\n\r\nprocedure TJvAppDdeCmd.BusyStateChanged;\r\nbegin\r\n if Assigned(FOnBusyChanged) then\r\n FOnBusyChanged(Self, AppBusy);\r\n ExecuteCommands;\r\nend;\r\n\r\nprocedure TJvAppDdeCmd.ExecuteCommands;\r\nbegin\r\n with FCommands do\r\n while (not AppBusy) and (Count > 0) do\r\n begin\r\n try\r\n if Assigned(FOnExecCommand) then\r\n FOnExecCommand(Self, Strings[0]);\r\n if Assigned(FOnExecParsedCmd) then\r\n ExecuteParsedCommands(Strings[0]);\r\n Delete(0);\r\n except\r\n Delete(0);\r\n Application.HandleException(Self);\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvAppDdeCmd.ExecuteParsedCommands(const CmdStr: string);\r\nvar\r\n I: Integer;\r\n CmdSPos, CmdEPos, ParamsSPos, ParamsEPos: Integer;\r\n StartCmd, StartParams, StartString: Boolean;\r\n S, Cmd: string;\r\n Params: TStringList;\r\n\r\n procedure CorrParams;\r\n var\r\n I, ErrCode, Value: Integer;\r\n C: string;\r\n begin\r\n with Params do\r\n for I := 0 to Count - 1 do\r\n begin\r\n C := Strings[I];\r\n if Length(C) >= 2 then\r\n begin\r\n if C[1] = '\"' then\r\n System.Delete(C, 1, 1);\r\n if C[Length(C)] = '\"' then\r\n System.Delete(C, Length(C), 1);\r\n Strings[I] := C;\r\n end;\r\n Val(C, Value, ErrCode);\r\n if ErrCode = 0 then\r\n Objects[I] := Pointer(Value);\r\n end;\r\n end;\r\n\r\nbegin\r\n I := 1;\r\n StartCmd := False;\r\n StartParams := False;\r\n StartString := False;\r\n CmdSPos := 0;\r\n CmdEPos := 0;\r\n ParamsSPos := 0;\r\n // ParamsEPos := 0;\r\n Params := TStringList.Create;\r\n try\r\n S := Trim(CmdStr);\r\n while I <= Length(S) do\r\n begin\r\n if not StartCmd then\r\n begin\r\n if S[I] <> '[' then\r\n raise EJvADCParserError.CreateRes(@RsEErrorCommandStart);\r\n StartCmd := True;\r\n StartParams := False;\r\n StartString := False;\r\n CmdSPos := I + 1;\r\n CmdEPos := 0;\r\n ParamsSPos := 0;\r\n // ParamsEPos := 0;\r\n Params.Clear;\r\n end\r\n else\r\n begin\r\n if S[I] = '\"' then\r\n StartString := not StartString\r\n else\r\n if not StartString then\r\n begin\r\n if (S[I] = ',') and StartParams then\r\n begin\r\n Params.Add(Copy(S, ParamsSPos, I - ParamsSPos));\r\n ParamsSPos := I + 1;\r\n end\r\n else\r\n if S[I] = '(' then\r\n begin\r\n CmdEPos := I - 1;\r\n StartParams := True;\r\n ParamsSPos := I + 1;\r\n end\r\n else\r\n if (S[I] = ')') and StartParams then\r\n begin\r\n ParamsEPos := I - 1;\r\n StartParams := False;\r\n Params.Add(Copy(S, ParamsSPos, ParamsEPos - ParamsSPos + 1));\r\n end\r\n else\r\n if (S[I] = ']') and (not StartParams) then\r\n begin\r\n if CmdEPos = 0 then\r\n CmdEPos := I - 1;\r\n Cmd := AnsiUpperCase(Copy(S, CmdSPos, CmdEPos - CmdSPos + 1));\r\n if FCorrectParams then\r\n CorrParams;\r\n FOnExecParsedCmd(Self, Cmd, Params);\r\n StartCmd := False;\r\n end;\r\n end;\r\n end;\r\n Inc(I);\r\n end;\r\n if StartCmd or StartParams or StartString then\r\n raise EJvADCParserError.CreateResFmt(@RsEErrorCommandFormat, [S]);\r\n finally\r\n Params.Free;\r\n end;\r\nend;\r\n\r\nfunction TJvAppDdeCmd.HookWndProc(var AMsg: TMessage): Boolean;\r\nbegin\r\n Result := False;\r\n if AMsg.Msg = WM_ENABLE then\r\n SetModalState(not TWMEnable(AMsg).Enabled);\r\nend;\r\n\r\nprocedure TJvAppDdeCmd.Notify(ACommands: TStrings);\r\nbegin\r\n FCommands.AddStrings(ACommands);\r\n ExecuteCommands;\r\nend;\r\n\r\ninitialization\r\n {$IFDEF UNITVERSIONING}\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n {$ENDIF UNITVERSIONING}\r\n\r\nfinalization\r\n FreeAndNil(AppDdeMgr);\r\n {$IFDEF UNITVERSIONING}\r\n UnregisterUnitVersion(HInstance);\r\n {$ENDIF UNITVERSIONING}\r\n\r\nend." }, { "path": "External/Jedi/Jvcl/run/JvDebugHandler.pas", "content": "{-----------------------------------------------------------------------------\r\n JvDebugHandler.pas version 2.0.0.0 for use with Delphi versions 7 and 9(2005}\r\n\r\n{ The contents of this file are subject to the Mozilla Public License\r\n Version 1.1 (the \"License\"); you may not use this file except in compliance\r\n with the License. You may obtain a copy of the License at\r\n http://www.mozilla.org/NPL/NPL-1_1Final.html\r\n\r\n Software distributed under the License is distributed on an \"AS IS\" basis,\r\n WITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\n the specific language governing rights and limitations under the License.\r\n\r\n { Many thanks to David Rose, who turned my original template code into the first\r\n version of a component to serve this purpose, and from which this component\r\n has evolved, and to Brian Weith who solved a problem neither of us really\r\n understands , as well as Brad White who was of invaluable help to me! And\r\n finally to the members of the JEDI group who wrote the wonderful underlying code\r\n which this component depends upon.}\r\n\r\n { Copyright 2004 Robert Meek dba Tangentals Design [All Rights Reserved]\r\n\r\n 707 Rear Maple St.\r\n Minersville, Pa. U.S.A. 17954\r\n\r\n Phone: (570) 544-2631\r\n FAX: (570) 544-6547\r\n Cell: (570) 590-3879\r\n E-mail: rmeek att ptd dott net\r\n WWW: www.TangentalsDesign.com\r\n\r\n All code, files, and/or data pertaining to and referenced by the above named\r\n program or unit, as well as any ancillary files or information packaged with them\r\n are soley owned by Robert Meek dba Tangentals Design, and provided for educational\r\n and non-profit use only unless specifically stated to the contrary above. Any\r\n other use, and/or distribution is strictly prohibited unless signed permission is\r\n first provided by me.\r\n\r\n Use this program, code, and/or information at your own Risk!}\r\n\r\n { INSTRUCTIONS:\r\n\r\n This non-visual component has been tested under Delphi 7 and 9 and can be used\r\n ONLY in conjuction with the JEDI Library and it's included Debug handling routines.\r\n All laws, rules, and provisions provided for under the Mozilla public license\r\n apply, and though this component may be freely used in both freeware/shareware,\r\n opensource and commercial projects, some restrictions DO apply, and so you are\r\n urged to read the MPL (license.txt) and MPL FAQ documents available in the\r\n JCL-Help.chm file that comes included with the JEDI Code Library. The latest\r\n version of the JEDI Code Library can be found and downloaded from:\r\n http://www.delphi-jedi.org/Jedi:CODELIBJCL\r\n\r\n To use this component: Install as a \"new component\" into an old or new package.\r\n Please note: The above is true ONLY if you wish to make use of this pas file as\r\n is and NOT if it is but one component contained in a Delphi Package! Provided you\r\n have correctly installed the JEDI Library, drop the component onto the MainForm\r\n of a project and set the following properties in the object inspector or in your\r\n mainform's OnCreate method as code.\r\n\r\n ExceptionLogging = True will send exception info to logfile and/or any other viewer\r\n as set in the \"OnOtherDestination\" event. In other words, this\r\n turns the component on and off. Note: This is NOT the same as\r\n loading/unloading the component! It provides a means by which an\r\n option could be set at runtime that will activate it. A good example\r\n would be in the case of an unexplained error on a users machine,\r\n The user could be instructed to turn this on via a menu item, then\r\n send the resulting log file back to you for analysis.\r\n StackTrackingEnabled = True does just what it says, providing a full stack trace of\r\n any exceptions including line numbers.\r\n UnHandledExceptions = True if you only want those exceptions NOT handled by the\r\n application to be logged.\r\n LogToFile = True allows for a text-based log file to be created.\r\n LogFileName = '' can be set here or in the mainform's OnCreate with or without path.\r\n If no name or path is given, any logfiles created will be provided\r\n the name: Application.Title + 'ERRORLOG.txt' and will be placed in\r\n the application's directory.\r\n AppendLogFile = True will append the exception information generated to the beginning\r\n of any logfile for this project already in existance. If one doesn't\r\n yet exist, it will be created. Each new exception logged will appear\r\n above the last and seperated by two blank lines.\r\n OnOtherDestination event: is the only event provided. When assigned, by double-\r\n clicking it in the object inspector, a procedure of this name will\r\n be created for you in your mainform's unit. Any code you write here\r\n will be run immeadiatly upon any exception information being generated,\r\n before and completely independant of the component's own logfile and\r\n whether or not \"CreateLogFile\" is set to True or False.\r\n From here you may access the \"ExceptionSgtringList\" which holds this\r\n information and do with it as wanted. You may for example, have the\r\n \"ExceptionStringList\" saved to another logfile, or to another utility\r\n application such as CodeSite.\r\n Please note that thwe \"ExceptionStringList\" is created and freed\r\n properly by the component itself...you need only access it if wanted.\r\n Also note that even though \"AppendLogFile\" may be set to True, this\r\n property ONLY applies to the component's own logfile. When the\r\n \"ExceptionStringList\" is accessed from within the \"OnOtherDestination\"\r\n method, it is holding ONLY the current exception's information. To\r\n use this information in an appended form, it will be necessary to write\r\n such code as necessary. As an example: You could, within this method,\r\n create a second stringList of your own and assign the \"ExceptionStringList's\"\r\n lines to it each time the event fires. Finally, as an example of how\r\n CodeSite users can easily make use of the exception information, the code\r\n as written below and added to \"OnOtherDestination\" method is all that\r\n is needed:\r\n For CodeSite 2:\r\n If CodeSite.Enabled = True Then\r\n CodeSite.SendStringList('ERROR INFO', JclDebugHandler1.ExceptionStringList);\r\n\r\n For CodeSite 3:\r\n If CodeSite.Enabled = True Then\r\n CodeSite.Send('ERROR INFO: ', JclDebugHandler1.ExceptionStringList);\r\n\r\n Although it is NOT necessary to check if CodeSite is enabled or not here, I\r\n choose do do so because if I disable it and still leave this code in place,\r\n an exception will not occur.\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvDebugHandler.pas 13264 2012-02-29 15:47:52Z obones $\r\n\r\nunit JvDebugHandler;\r\n\r\n{$I jvcl.inc}\r\n{$I windowsonly.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n SysUtils, Classes, Forms,\r\n JclDebug, JclHookExcept,\r\n JvComponentBase,\r\n AppEvnts;\r\n\r\ntype\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64 or pidOSX32)]\r\n {$ENDIF RTL230_UP}\r\n TJvDebugHandler = class(TJvComponent)\r\n private\r\n FExceptionLogging: Boolean;\r\n FAppEvents: TApplicationEvents;\r\n FStackTrackingEnable: Boolean;\r\n FUnhandledExceptionsOnly: Boolean;\r\n FLogToFile: Boolean;\r\n FName: string;\r\n FAppendLogFile: Boolean;\r\n FIsLoaded: Boolean;\r\n\r\n FOnOtherDestination: TNotifyEvent;\r\n procedure SetUnhandled(Value: Boolean);\r\n procedure HandleUnKnownException(Sender: TObject; E: Exception);\r\n procedure SetStackTracking(Value: Boolean);\r\n procedure ExceptionNotifier(ExceptObj: TObject; ExceptAddr: Pointer; OSException: Boolean);\r\n protected\r\n procedure Loaded; override;\r\n public\r\n ExceptionStringList: TStringList;\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n published\r\n property ExceptionLogging: Boolean read FExceptionLogging write FExceptionLogging default True;\r\n property StackTrackingEnable: Boolean read FStackTrackingEnable write SetStackTracking default True;\r\n property UnhandledExceptionsOnly: Boolean read FUnhandledExceptionsOnly write SetUnhandled default False;\r\n property LogToFile: Boolean read FLogToFile write FLogToFile default True;\r\n property LogFileName: string read FName write FName;\r\n property AppendLogFile: Boolean read FAppendLogFile write FAppendLogFile default True;\r\n property OnOtherDestination: TNotifyEvent read FOnOtherDestination write FOnOtherDestination;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvDebugHandler.pas $';\r\n Revision: '$Revision: 13264 $';\r\n Date: '$Date: 2012-02-29 16:47:52 +0100 (mer. 29 févr. 2012) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\n\r\nconstructor TJvDebugHandler.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FExceptionLogging := True;\r\n FStackTrackingEnable := True;\r\n FLogToFile := True;\r\n FAppendLogFile := True;\r\n Loaded;\r\nend;\r\n\r\ndestructor TJvDebugHandler.Destroy;\r\nbegin\r\n JclStopExceptionTracking;\r\n JclRemoveExceptNotifier(ExceptionNotifier);\r\n JclUnhookExceptions;\r\n FreeAndNil(FAppEvents);\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvDebugHandler.HandleUnKnownException(Sender: TObject; E: Exception);\r\nbegin\r\n ExceptionNotifier(E, ExceptAddr, False);\r\nend;\r\n\r\nprocedure TJvDebugHandler.SetUnhandled(Value: Boolean);\r\nbegin\r\n if FUnhandledExceptionsOnly <> Value then\r\n begin\r\n FUnhandledExceptionsOnly := Value;\r\n if FUnhandledExceptionsOnly then\r\n begin\r\n JclRemoveExceptNotifier(ExceptionNotifier);\r\n if FAppEvents = nil then\r\n FAppEvents := TApplicationEvents.Create(nil);\r\n FAppEvents.OnException := HandleUnknownException;\r\n end\r\n else\r\n begin\r\n if FAppEvents <> nil then\r\n begin\r\n FreeAndNil(FAppEvents);\r\n JclAddExceptNotifier(ExceptionNotifier);\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvDebugHandler.SetStackTracking(Value: Boolean);\r\nbegin\r\n if Value <> FStackTrackingEnable Then\r\n begin\r\n FStackTrackingEnable := Value;\r\n if FStackTrackingEnable then\r\n JclStartExceptionTracking\r\n else\r\n JclStopExceptionTracking;\r\n end;\r\nend;\r\n\r\nprocedure TJvDebugHandler.ExceptionNotifier(ExceptObj: TObject; ExceptAddr: Pointer;\r\n OSException: Boolean);\r\nvar\r\n I: Integer;\r\n PreviousExceptionStringList: TStringList;\r\n FileName: string;\r\n UnitName: string;\r\n ProcedureName: string;\r\n Line: Integer;\r\n Loc: string;\r\nbegin\r\n FileName := '';\r\n UnitName := '';\r\n ProcedureName := '';\r\n Loc := '';\r\n if FExceptionLogging and not (csDesigning in ComponentState) then\r\n begin\r\n ExceptionStringList := TStringList.Create;\r\n try\r\n // (rom) literals instead of resourcestrings are acceptable here\r\n if MapOfAddr(ExceptAddr, FileName, UnitName, ProcedureName, Line) then\r\n Loc := Format('in %s at %d in file %s', [ProcedureName, Line, FileName])\r\n else\r\n Loc := Format('at address %p', [ExceptAddr]);\r\n\r\n ExceptionStringList.Add(DateTimeToStr(now) + ' Exception ' +\r\n ExceptObj.ClassName + ' occured ' + Loc);\r\n if ExceptObj is Exception then\r\n ExceptionStringList.Add('Message: ' + Exception(ExceptObj).Message);\r\n\r\n if FStackTrackingEnable then\r\n begin\r\n ExceptionStringList.Add('Call stack: ');\r\n if JclLastExceptStackList <> nil Then\r\n JclLastExceptStackList.AddToStrings(ExceptionStringList);\r\n end;\r\n\r\n if FLogToFile Then\r\n begin\r\n if FName = '' then\r\n FName := ExtractFilePath(Application.ExeName) + Application.Title + 'ERRORLOG.txt';\r\n if not FAppendLogFile Then\r\n ExceptionStringList.SaveToFile(FName)\r\n else\r\n begin\r\n if not FileExists(FName) then\r\n ExceptionStringList.SaveToFile(FName)\r\n else\r\n begin\r\n PreviousExceptionStringList := TStringList.Create;\r\n try\r\n PreviousExceptionStringList.LoadFromFile(FName);\r\n ExceptionStringList.Add('');\r\n ExceptionStringList.Add('');\r\n for I := 0 to PreviousExceptionStringList.Count - 1 do\r\n ExceptionStringList.Add(PreviousExceptionStringList[I]);\r\n ExceptionStringList.SaveToFile(FName);\r\n finally\r\n PreviousExceptionStringList.Free;\r\n end;\r\n end;\r\n end;\r\n end;\r\n\r\n if Assigned(FOnOtherDestination) Then\r\n FOnOtherDestination(Self)\r\n else\r\n Application.ShowException(Exception(ExceptObj));\r\n finally\r\n ExceptionStringList.Free;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvDebugHandler.Loaded;\r\nbegin\r\n if not FIsLoaded Then\r\n begin\r\n FIsLoaded := True;\r\n inherited Loaded;\r\n if csDesigning in ComponentState then\r\n Exit;\r\n if JclHookExceptions then\r\n begin\r\n if not FUnhandledExceptionsOnly then\r\n JclAddExceptNotifier(ExceptionNotifier);\r\n if FStackTrackingEnable Then\r\n JclStartExceptionTracking\r\n else\r\n JclStopExceptionTracking;\r\n end;\r\n end;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n\r\n" }, { "path": "External/Jedi/Jvcl/run/JvDeleteError.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvDeleteError.PAS, released on 2001-02-28.\r\n\r\nThe Initial Developer of the Original Code is Sbastien Buysse [sbuysse att buypin dott com]\r\nPortions created by Sbastien Buysse are Copyright (C) 2001 Sbastien Buysse.\r\nAll Rights Reserved.\r\n\r\nContributor(s): Michael Beck [mbeck att bigfoot dott com].\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvDeleteError.pas 13351 2012-06-13 15:16:00Z obones $\r\n\r\nunit JvDeleteError;\r\n\r\n{$I jvcl.inc}\r\n{$I windowsonly.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, SysUtils, Classes,\r\n JvCustomFileMessageDialog, JvTypes;\r\n\r\ntype\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvDeleteError = class(TJvCustomFileMessageDialog)\r\n private\r\n FWin32ErrorCode: Integer;\r\n FFileName: TFileName;\r\n FStyle: TJvDeleteStyles;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n published\r\n property FileName: TFileName read FFileName write FFileName;\r\n property Win32ErrorCode: Integer read FWin32ErrorCode write FWin32ErrorCode default 0;\r\n property Style: TJvDeleteStyles read FStyle write FStyle;\r\n function Execute: TJvDiskRes; override;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvDeleteError.pas $';\r\n Revision: '$Revision: 13351 $';\r\n Date: '$Date: 2012-06-13 17:16:00 +0200 (mer. 13 juin 2012) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n JvSetupApi;\r\n\r\nconstructor TJvDeleteError.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FStyle := [];\r\n FFileName := '';\r\n FWin32ErrorCode := 0;\r\nend;\r\n\r\nfunction TJvDeleteError.Execute: TJvDiskRes;\r\nvar\r\n Sty: DWORD;\r\nbegin\r\n Sty := 0;\r\n if idNoBeep in Style then\r\n Sty := Sty or IDF_NOBEEP;\r\n if idNoForeground in Style then\r\n Sty := Sty or IDF_NOFOREGROUND;\r\n\r\n case SetupDeleteError(OwnerWindow, Pointer(Title), PChar(FileName), FWin32ErrorCode, Sty) of\r\n DPROMPT_SUCCESS:\r\n Result := dsSuccess;\r\n DPROMPT_CANCEL:\r\n Result := dsCancel;\r\n DPROMPT_SKIPFILE:\r\n Result := dsSkipfile;\r\n else\r\n Result := dsError;\r\n end;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvDesignClip.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvDesingClip.pas, released on 2005-08-21.\r\n\r\nThe Initial Developer of the Original Code is Scott J Miles\r\nPortions created by Scott J Miles are Copyright (C) 2005 Scott J Miles.\r\nAll Rights Reserved.\r\n\r\nContributor(s): Olivier Sannier (JVCL Integration)\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL\r\nhome page, located at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvDesignClip.pas 13138 2011-10-26 23:17:50Z jfudickar $\r\nunit JvDesignClip;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, Classes;\r\n\r\ntype\r\n TJvDesignComponentClipboard = class(TObject)\r\n protected\r\n Stream: TMemoryStream;\r\n FParentComponent: TComponent;\r\n procedure Close;\r\n procedure Open;\r\n procedure ReadError(Reader: TReader; const Msg: string; var Handled: Boolean);\r\n public\r\n constructor Create(ParentComponent: TComponent);\r\n\r\n function GetComponent: TComponent;\r\n procedure CloseRead;\r\n procedure CloseWrite;\r\n procedure OpenRead;\r\n procedure OpenWrite;\r\n procedure SetComponent(InComponent: TComponent);\r\n end;\r\n\r\nfunction DesignLoadComponentFromBinaryStream(InStream: TStream;\r\n InComponent: TComponent; InOnError: TReaderError): TComponent;\r\nprocedure DesignSaveComponentToBinaryStream(InStream: TStream; InComponent: TComponent);\r\nprocedure DesignCopyStreamFromClipboard(InFmt: Cardinal; InS: TStream);\r\nprocedure DesignCopyStreamToClipboard(InFmt: Cardinal; InS: TStream);\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvDesignClip.pas $';\r\n Revision: '$Revision: 13138 $';\r\n Date: '$Date: 2011-10-27 01:17:50 +0200 (jeu. 27 oct. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n SysUtils, Clipbrd;\r\n\r\nvar\r\n CF_COMPONENTSTREAM: UINT;\r\n\r\nprocedure DesignSaveComponentToBinaryStream(InStream: TStream; InComponent: TComponent);\r\nvar\r\n MS: TMemoryStream;\r\n SZ: Int64;\r\nbegin\r\n MS := TMemoryStream.Create;\r\n try\r\n MS.WriteComponent(InComponent);\r\n MS.Position := 0;\r\n SZ := MS.Size;\r\n InStream.Write(SZ, SizeOf(SZ));\r\n InStream.CopyFrom(MS, SZ);\r\n finally\r\n MS.Free;\r\n end;\r\nend;\r\n\r\nfunction DesignLoadComponentFromBinaryStream(InStream: TStream;\r\n InComponent: TComponent; InOnError: TReaderError): TComponent;\r\nvar\r\n MS: TMemoryStream;\r\n SZ: Int64;\r\nbegin\r\n InStream.Read(SZ, SizeOf(SZ));\r\n MS := TMemoryStream.Create;\r\n try\r\n MS.CopyFrom(InStream, SZ);\r\n MS.Position := 0;\r\n with TReader.Create(MS, 4096) do\r\n try\r\n Parent := InComponent;\r\n OnError := InOnError;\r\n Result := ReadRootComponent(nil);\r\n finally\r\n Free;\r\n end;\r\n finally\r\n MS.Free;\r\n end;\r\nend;\r\n\r\nprocedure DesignCopyStreamToClipboard(InFmt: Cardinal; InS: TStream);\r\nvar\r\n HMem: THandle;\r\n PMem: Pointer;\r\nbegin\r\n InS.Position := 0;\r\n HMem := GlobalAlloc(GHND or GMEM_DDESHARE, InS.Size);\r\n if HMem <> 0 then\r\n begin\r\n PMem := GlobalLock(HMem);\r\n if PMem <> nil then\r\n begin\r\n InS.Read(PMem^, InS.Size);\r\n InS.Position := 0;\r\n GlobalUnlock(HMem);\r\n Clipboard.Open;\r\n try\r\n Clipboard.SetAsHandle(InFmt, HMem);\r\n finally\r\n Clipboard.Close;\r\n end;\r\n end\r\n else\r\n begin\r\n GlobalFree(HMem);\r\n OutOfMemoryError;\r\n end;\r\n end else\r\n OutOfMemoryError;\r\nend;\r\n\r\nprocedure DesignCopyStreamFromClipboard(InFmt: Cardinal; InS: TStream);\r\nvar\r\n HMem: THandle;\r\n PMem: Pointer;\r\nbegin\r\n HMem := Clipboard.GetAsHandle(InFmt);\r\n if HMem <> 0 then\r\n begin\r\n PMem := GlobalLock(HMem);\r\n if PMem <> nil then\r\n begin\r\n InS.Write(PMem^, GlobalSize(HMem));\r\n InS.Position := 0;\r\n GlobalUnlock(HMem);\r\n end;\r\n end;\r\nend;\r\n\r\n//=== { TJvDesignComponentClipboard } ========================================\r\n\r\nprocedure TJvDesignComponentClipboard.Close;\r\nbegin\r\n Stream.Free;\r\n Clipboard.Close;\r\nend;\r\n\r\nprocedure TJvDesignComponentClipboard.CloseRead;\r\nbegin\r\n Close;\r\nend;\r\n\r\nprocedure TJvDesignComponentClipboard.CloseWrite;\r\nbegin\r\n DesignCopyStreamToClipboard(CF_COMPONENTSTREAM, Stream);\r\n Close;\r\nend;\r\n\r\nconstructor TJvDesignComponentClipboard.Create(ParentComponent: TComponent);\r\nbegin\r\n inherited Create;\r\n\r\n FParentComponent := ParentComponent;\r\nend;\r\n\r\nfunction TJvDesignComponentClipboard.GetComponent: TComponent;\r\nbegin\r\n if Stream.Position < Stream.Size then\r\n Result := DesignLoadComponentFromBinaryStream(Stream, FParentComponent, ReadError)\r\n else\r\n Result := nil;\r\nend;\r\n\r\nprocedure TJvDesignComponentClipboard.Open;\r\nbegin\r\n Clipboard.Open;\r\n Stream := TMemoryStream.Create;\r\nend;\r\n\r\nprocedure TJvDesignComponentClipboard.OpenRead;\r\nbegin\r\n Open;\r\n DesignCopyStreamFromClipboard(CF_COMPONENTSTREAM, Stream);\r\nend;\r\n\r\nprocedure TJvDesignComponentClipboard.OpenWrite;\r\nbegin\r\n Open;\r\nend;\r\n\r\nprocedure TJvDesignComponentClipboard.ReadError(Reader: TReader;\r\n const Msg: string; var Handled: Boolean);\r\nbegin\r\n Handled := True;\r\nend;\r\n\r\nprocedure TJvDesignComponentClipboard.SetComponent(InComponent: TComponent);\r\nbegin\r\n DesignSaveComponentToBinaryStream(Stream, InComponent);\r\nend;\r\n\r\ninitialization\r\n { The following string should not be localized }\r\n CF_COMPONENTSTREAM := RegisterClipboardFormat('Delphi Components');\r\n {$IFDEF UNITVERSIONING}\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n {$ENDIF UNITVERSIONING}\r\n\r\nfinalization\r\n {$IFDEF UNITVERSIONING}\r\n UnregisterUnitVersion(HInstance);\r\n {$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvDesignImp.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvDesingImp.pas, released on 2005-08-21.\r\n\r\nThe Initial Developer of the Original Code is Scott J Miles\r\nPortions created by Scott J Miles are Copyright (C) 2005 Scott J Miles.\r\nAll Rights Reserved.\r\n\r\nContributor(s): Olivier Sannier (JVCL Integration)\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL\r\nhome page, located at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvDesignImp.pas 13415 2012-09-10 09:51:54Z obones $\r\n\r\nunit JvDesignImp;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, Messages, SysUtils, Classes, Controls, Graphics,\r\n Forms, Contnrs,\r\n JvDesignSurface;\r\n\r\nconst\r\n cJvDesignDefaultHandleWidth = 8;\r\n\r\ntype\r\n TJvDesignHandle = class(TCustomControl)\r\n private\r\n FResizeable: Boolean;\r\n protected\r\n function HandleRect(AIndex: Integer): TRect;\r\n function HitRect(APoint: TPoint): Integer;\r\n procedure Paint; override;\r\n procedure PaintEdge(const ARect: TRect);\r\n procedure PaintHandle(const ARect: TRect);\r\n procedure WMEraseBkgnd(var Msg: TWmEraseBkgnd); message WM_ERASEBKGND;\r\n property Resizeable: Boolean read FResizeable write FResizeable;\r\n end;\r\n\r\n TJvDesignHandles = class(TComponent)\r\n private\r\n FContainer: TWinControl;\r\n FSelected: TControl;\r\n FResizeable: Boolean;\r\n protected\r\n function GetHandleWidth: Integer;\r\n function GetSelectionRect: TRect;\r\n function SelectedToScreenRect(const ARect: TRect): TRect;\r\n procedure CreateHandles;\r\n procedure SetContainer(const Value: TWinControl);\r\n procedure SetHandleRects(const ARect: TRect);\r\n procedure SetResizeable(const Value: Boolean);\r\n procedure SetSelected(const Value: TControl);\r\n procedure ShowHideHandles(AShow: Boolean);\r\n public\r\n Handles: array [0..3] of TJvDesignHandle;\r\n constructor Create(AOwner: TComponent); override;\r\n function HitRect(X, Y: Integer): TJvDesignHandleId;\r\n function SelectedToContainer(const APt: TPoint): TPoint;\r\n procedure RepaintHandles;\r\n procedure UpdateHandles;\r\n property Container: TWinControl read FContainer write SetContainer;\r\n property HandleWidth: Integer read GetHandleWidth;\r\n property Resizeable: Boolean read FResizeable write SetResizeable;\r\n property Selected: TControl read FSelected write SetSelected;\r\n end;\r\n\r\n TJvDesignSelector = class(TJvDesignCustomSelector)\r\n private\r\n FHandles: TObjectList;\r\n FHandleWidth: Integer;\r\n protected\r\n function FindHandles(AValue: TControl): TJvDesignHandles;\r\n function GetCount: Integer; override;\r\n function GetHandles(AIndex: Integer): TJvDesignHandles;\r\n function GetSelection(AIndex: Integer): TControl; override;\r\n procedure SetHandles(AIndex: Integer; AValue: TJvDesignHandles);\r\n procedure SetHandleWidth(AValue: Integer);\r\n procedure SetSelection(AIndex: Integer; AValue: TControl); override;\r\n procedure ShowHideResizeHandles;\r\n property Handles[AIndex: Integer]: TJvDesignHandles read GetHandles write SetHandles;\r\n public\r\n constructor Create(ASurface: TJvDesignSurface); override;\r\n destructor Destroy; override;\r\n function GetClientControl(AControl: TControl): TControl; override;\r\n function GetCursor(AX, AY: Integer): TCursor; override;\r\n function GetHitHandle(AX, AY: Integer): TJvDesignHandleId; override;\r\n function IsSelected(AValue: TControl): Boolean; override;\r\n procedure AddToSelection(AValue: TControl); override;\r\n procedure ClearSelection; override;\r\n procedure RemoveFromSelection(AValue: TControl); override;\r\n procedure Update; override;\r\n published\r\n property HandleWidth: Integer read FHandleWidth write SetHandleWidth default cJvDesignDefaultHandleWidth;\r\n end;\r\n\r\n TJvDesignCustomMouseTool = class(TObject)\r\n protected\r\n FDragRect: TRect;\r\n public\r\n procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); virtual; abstract;\r\n procedure MouseMove(Shift: TShiftState; X, Y: Integer); virtual; abstract;\r\n procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); virtual; abstract;\r\n property DragRect: TRect read FDragRect write FDragRect;\r\n end;\r\n\r\n TJvDesignDragMode = (dmNone, dmMove, dmResize, dmSelect, dmCreate);\r\n\r\n TJvDesignAction = (daSelectParent, daDelete, daCopy, daCut, daPaste,\r\n daNudgeLeft, daNudgeRight, daNudgeUp, daNudgeDown, daGrowWidth,\r\n daShrinkWidth, daGrowHeight, daShrinkHeight, daLastAction = MaxInt);\r\n\r\n TJvDesignController = class(TJvDesignCustomController)\r\n private\r\n FClicked: TControl;\r\n FDragMode: TJvDesignDragMode;\r\n FDragRect: TRect;\r\n FKeyDownShift: TShiftState;\r\n FMouseIsDown: Boolean;\r\n FMouseTool: TJvDesignCustomMouseTool;\r\n protected\r\n function GetDragRect: TRect; override;\r\n function KeyDown(AKeyCode: Cardinal): Boolean; override;\r\n function KeyUp(AKeyCode: Cardinal): Boolean; override;\r\n function MouseDown(Button: TMouseButton; X, Y: Integer): Boolean; override;\r\n function MouseMove(X, Y: Integer): Boolean; override;\r\n function MouseUp(Button: TMouseButton; X, Y: Integer): Boolean; override;\r\n procedure Action(AAction: TJvDesignAction);\r\n end;\r\n\r\n TJvDesignMouseTool = class(TJvDesignCustomMouseTool)\r\n private\r\n FSurface: TJvDesignSurface;\r\n FMouseLast: TPoint;\r\n FMouseStart: TPoint;\r\n protected\r\n function GetMouseDelta: TPoint; virtual;\r\n public\r\n constructor Create(AOwner: TJvDesignSurface); virtual;\r\n property Surface: TJvDesignSurface read FSurface write FSurface;\r\n end;\r\n\r\n TJvDesignMover = class(TJvDesignMouseTool)\r\n private\r\n FDragRects: array of TRect;\r\n protected\r\n procedure ApplyDragRects;\r\n procedure CalcDragRects;\r\n procedure CalcPaintRects;\r\n procedure PaintDragRects;\r\n public\r\n constructor Create(AOwner: TJvDesignSurface); override;\r\n procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;\r\n procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;\r\n procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;\r\n end;\r\n\r\n TJvDesignBander = class(TJvDesignMouseTool)\r\n protected\r\n function GetClient: TControl; virtual;\r\n function GetPaintRect: TRect;\r\n procedure CalcDragRect; virtual;\r\n procedure PaintDragRect; virtual;\r\n public\r\n procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;\r\n procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;\r\n procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;\r\n end;\r\n\r\n TJvDesignSizer = class(TJvDesignBander)\r\n private\r\n FHandleId: TJvDesignHandleId;\r\n protected\r\n function GetClient: TControl; override;\r\n procedure ApplyDragRect;\r\n procedure ApplyMouseDelta(X, Y: Integer);\r\n procedure CalcDragRect; override;\r\n public\r\n constructor CreateSizer(AOwner: TJvDesignSurface; AHandle: TJvDesignHandleId);\r\n procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;\r\n end;\r\n\r\n TJvDesignDesigner = class(TComponent, IDesignerHook)\r\n private\r\n FMessenger: TJvDesignCustomMessenger;\r\n public\r\n constructor Create(AMessenger: TJvDesignCustomMessenger); reintroduce;\r\n // IDesignerNotify interface\r\n procedure Modified;\r\n procedure Notification(AnObject: TPersistent; Operation: TOperation); reintroduce;\r\n\r\n // IDesigner, IDesignerHook interface\r\n function GetCustomForm: TCustomForm;\r\n procedure SetCustomForm(Value: TCustomForm);\r\n function GetIsControl: Boolean;\r\n procedure SetIsControl(Value: Boolean);\r\n function IsDesignMsg(Sender: TControl; var Msg: TMessage): Boolean;\r\n {$IFDEF RTL240_UP}\r\n procedure DrawSelectionMarks(AControl: TControl);\r\n function IsSelected(AControl: TControl): Boolean;\r\n {$ENDIF RTL240_UP}\r\n procedure PaintGrid;\r\n procedure ValidateRename(AComponent: TComponent; const CurName, NewName: string); reintroduce;\r\n function UniqueName(const BaseName: string): string;\r\n function GetRoot: TComponent;\r\n {$IFDEF COMPILER9_UP}\r\n procedure PaintMenu;\r\n {$ENDIF COMPILER9_UP}\r\n property Messenger: TJvDesignCustomMessenger read FMessenger write FMessenger;\r\n property IsControl: Boolean read GetIsControl write SetIsControl;\r\n property Form: TCustomForm read GetCustomForm write SetCustomForm;\r\n end;\r\n\r\n TJvDesignDesignerMessenger = class(TJvDesignCustomMessenger)\r\n private\r\n FDesignedForm: TCustomForm;\r\n FDesigner: TJvDesignDesigner;\r\n protected\r\n procedure SetComponentDesigning(AComponent: TComponent; ADesigning: Boolean);\r\n procedure SetContainer(AValue: TWinControl); override;\r\n procedure UndesignComponent(AComponent: TComponent);\r\n public\r\n constructor Create; override;\r\n destructor Destroy; override;\r\n procedure DesignComponent(AComponent: TComponent; ADesigning: Boolean); override;\r\n end;\r\n\r\n TJvDesignMessageHookList = class(TComponent)\r\n private\r\n FHooks: TObjectList;\r\n FUser: TJvDesignCustomMessenger;\r\n protected\r\n procedure Notification(AComponent: TComponent; Operation: TOperation); override;\r\n public\r\n constructor Create(AUser: TJvDesignCustomMessenger); reintroduce;\r\n destructor Destroy; override;\r\n procedure Clear;\r\n procedure Hook(AClient: TWinControl);\r\n procedure Unhook(AComponent: TComponent);\r\n end;\r\n\r\n TJvDesignWinControlHookMessenger = class(TJvDesignCustomMessenger)\r\n private\r\n FHooks: TJvDesignMessageHookList;\r\n protected\r\n procedure HookWinControl(AWinControl: TWinControl);\r\n procedure UnhookWinControl(AWinControl: TWinControl);\r\n procedure SetContainer(AValue: TWinControl); override;\r\n public\r\n constructor Create; override;\r\n destructor Destroy; override;\r\n procedure Clear; override;\r\n procedure DesignComponent(AComponent: TComponent; ADesigning: Boolean); override;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvDesignImp.pas $';\r\n Revision: '$Revision: 13415 $';\r\n Date: '$Date: 2012-09-10 11:51:54 +0200 (lun. 10 sept. 2012) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n Types,\r\n JvDesignUtils, JvResources, JvTypes;\r\n\r\nvar\r\n ShadedBits: TBitmap;\r\n\r\nfunction NeedShadedBits: TBitmap;\r\nbegin\r\n if ShadedBits = nil then\r\n begin\r\n ShadedBits := TBitmap.Create;\r\n with ShadedBits do\r\n begin\r\n Width := 4;\r\n Height := 2;\r\n Canvas.Pixels[0, 0] := clGray;\r\n Canvas.Pixels[1, 0] := clBtnFace;\r\n Canvas.Pixels[2, 0] := clBtnFace;\r\n Canvas.Pixels[3, 0] := clBtnFace;\r\n Canvas.Pixels[0, 1] := clBtnFace;\r\n Canvas.Pixels[1, 1] := clBtnFace;\r\n Canvas.Pixels[2, 1] := clGray;\r\n Canvas.Pixels[3, 1] := clBtnFace;\r\n end;\r\n end;\r\n Result := ShadedBits;\r\nend;\r\n\r\nprocedure FreeShadedBits;\r\nbegin\r\n FreeAndNil(ShadedBits);\r\nend;\r\n\r\n//=== { TJvDesignHandle } ====================================================\r\n\r\nfunction TJvDesignHandle.HandleRect(AIndex: Integer): TRect;\r\nvar\r\n W: Integer;\r\nbegin\r\n W := TJvDesignHandles(Owner).HandleWidth;\r\n case AIndex of\r\n 0:\r\n Result := Rect(0, 0, W, W); // left-top\r\n 1:\r\n Result := Rect((Width - W) div 2, 0, (Width + W) div 2, W); // middle-top\r\n 2:\r\n Result := Rect(Width - W, 0, Width, W); // right-top\r\n 3:\r\n Result := Rect(0, (Height - W) div 2, W, (Height + W) div 2); // left-center\r\n end;\r\nend;\r\n\r\nprocedure TJvDesignHandle.WMEraseBkgnd(var Msg: TWmEraseBkgnd);\r\nbegin\r\n Msg.Result := 1;\r\nend;\r\n\r\nprocedure TJvDesignHandle.PaintHandle(const ARect: TRect);\r\nbegin\r\n Canvas.Rectangle(ARect);\r\nend;\r\n\r\nprocedure TJvDesignHandle.PaintEdge(const ARect: TRect);\r\nbegin\r\n Canvas.FillRect(ClientRect);\r\nend;\r\n\r\nprocedure TJvDesignHandle.Paint;\r\nbegin\r\n with Canvas do\r\n begin\r\n Brush.Bitmap := NeedShadedBits;\r\n PaintEdge(ClientRect);\r\n Brush.Bitmap := nil;\r\n Brush.Color := clWhite;\r\n Pen.Color := clBlack;\r\n if Resizeable then\r\n if Width > Height then\r\n begin\r\n PaintHandle(HandleRect(0));\r\n PaintHandle(HandleRect(1));\r\n PaintHandle(HandleRect(2));\r\n end\r\n else\r\n PaintHandle(HandleRect(3));\r\n end;\r\nend;\r\n\r\nfunction TJvDesignHandle.HitRect(APoint: TPoint): Integer;\r\nbegin\r\n Result := -1;\r\n if Width > Height then\r\n if PtInRect(HandleRect(0), APoint) then\r\n Result := 0\r\n else\r\n if PtInRect(HandleRect(1), APoint) then\r\n Result := 1\r\n else\r\n if PtInRect(HandleRect(2), APoint) then\r\n Result := 2;\r\n if Result < 0 then\r\n if PtInRect(HandleRect(3), APoint) then\r\n Result := 3;\r\nend;\r\n\r\n//=== { TJvDesignHandles } ===================================================\r\n\r\nconstructor TJvDesignHandles.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n CreateHandles;\r\n Resizeable := True;\r\nend;\r\n\r\nprocedure TJvDesignHandles.CreateHandles;\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := Low(Handles) to High(Handles) do\r\n Handles[I] := TJvDesignHandle.Create(Self);\r\nend;\r\n\r\nfunction TJvDesignHandles.GetHandleWidth: Integer;\r\nbegin\r\n Result := TJvDesignSelector(Owner).HandleWidth;\r\nend;\r\n\r\nprocedure TJvDesignHandles.SetContainer(const Value: TWinControl);\r\nvar\r\n I: Integer;\r\nbegin\r\n FContainer := Value;\r\n for I := Low(Handles) to High(Handles) do\r\n with Handles[I] do\r\n begin\r\n Visible := False;\r\n Parent := Container;\r\n end;\r\nend;\r\n\r\nprocedure TJvDesignHandles.SetSelected(const Value: TControl);\r\nbegin\r\n if Selected <> Value then\r\n begin\r\n if Value is TJvDesignHandle then\r\n FSelected := nil\r\n else\r\n FSelected := Value;\r\n UpdateHandles;\r\n end;\r\nend;\r\n\r\nprocedure TJvDesignHandles.SetResizeable(const Value: Boolean);\r\nvar\r\n I: Integer;\r\nbegin\r\n FResizeable := Value;\r\n for I := Low(Handles) to High(Handles) do\r\n Handles[I].Resizeable := Value;\r\nend;\r\n\r\nprocedure TJvDesignHandles.ShowHideHandles(AShow: Boolean);\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := Low(Handles) to High(Handles) do\r\n with Handles[I] do\r\n begin\r\n Visible := AShow;\r\n if AShow then\r\n BringToFront;\r\n Update;\r\n end;\r\nend;\r\n\r\nprocedure TJvDesignHandles.UpdateHandles;\r\nbegin\r\n if (Selected <> nil) and (Container <> nil) and (Selected <> Container) then\r\n begin\r\n SetHandleRects(GetSelectionRect);\r\n ShowHideHandles(True);\r\n end\r\n else\r\n ShowHideHandles(False)\r\nend;\r\n\r\nprocedure TJvDesignHandles.RepaintHandles;\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := Low(Handles) to High(Handles) do\r\n Handles[I].Repaint;\r\nend;\r\n\r\nfunction TJvDesignHandles.HitRect(X, Y: Integer): TJvDesignHandleId;\r\nconst\r\n cRectIds: array [0..3, 0..3] of TJvDesignHandleId =\r\n (\r\n (dhLeftTop, dhMiddleTop, dhRightTop, dhNone),\r\n (dhNone, dhNone, dhNone, dhLeftMiddle),\r\n (dhNone, dhNone, dhNone, dhRightMiddle),\r\n (dhLeftBottom, dhMiddleBottom, dhRightBottom, dhNone)\r\n );\r\nvar\r\n I, R: Integer;\r\nbegin\r\n for I := 0 to 3 do\r\n begin\r\n with Handles[I] do\r\n R := HitRect(Point(X - Left, Y - Top));\r\n if R >= 0 then\r\n begin\r\n Result := cRectIds[I][R];\r\n Exit;\r\n end;\r\n end;\r\n Result := dhNone;\r\nend;\r\n\r\nfunction TJvDesignHandles.SelectedToContainer(const APt: TPoint): TPoint;\r\nvar\r\n C: TControl;\r\nbegin\r\n Result := APt;\r\n C := Selected.Parent;\r\n while (C <> Container) and (C <> nil) do\r\n begin\r\n Inc(Result.X, C.Left);\r\n Inc(Result.Y, C.Top);\r\n C := C.Parent;\r\n end;\r\nend;\r\n\r\nfunction TJvDesignHandles.SelectedToScreenRect(const ARect: TRect): TRect;\r\nvar\r\n P: TWinControl;\r\nbegin\r\n if Selected = Container then\r\n P := Container\r\n else\r\n P := Selected.Parent;\r\n Result.TopLeft := P.ClientToScreen(ARect.TopLeft);\r\n Result.BottomRight := P.ClientToScreen(ARect.BottomRight);\r\nend;\r\n\r\nfunction TJvDesignHandles.GetSelectionRect: TRect;\r\nvar\r\n P: TPoint;\r\nbegin\r\n if Selected = Container then\r\n P := Point(0, 0)\r\n else\r\n P := SelectedToContainer(Selected.BoundsRect.TopLeft);\r\n Result := Rect(P.X, P.Y, P.X + Selected.Width, P.Y + Selected.Height);\r\n InflateRect(Result, -HandleWidth div 2, -HandleWidth div 2);\r\nend;\r\n\r\nprocedure TJvDesignHandles.SetHandleRects(const ARect: TRect);\r\nvar\r\n W: Integer;\r\nbegin\r\n W := HandleWidth;\r\n Handles[0].BoundsRect := Rect(ARect.Left - W, ARect.Top - W, ARect.Right + W, ARect.Top);\r\n Handles[1].BoundsRect := Rect(ARect.Left - W, ARect.Top, ARect.Left, ARect.Bottom);\r\n Handles[2].BoundsRect := Rect(ARect.Right, ARect.Top, ARect.Right + W, ARect.Bottom);\r\n Handles[3].BoundsRect := Rect(ARect.Left - W, ARect.Bottom, ARect.Right + W, ARect.Bottom + W);\r\nend;\r\n\r\n//=== { TJvDesignSelector } ==================================================\r\n\r\nconstructor TJvDesignSelector.Create(ASurface: TJvDesignSurface);\r\nbegin\r\n inherited Create(ASurface);\r\n //ControllerClass := TJvDesignController;\r\n FHandleWidth := cJvDesignDefaultHandleWidth;\r\n FHandles := TObjectList.Create;\r\nend;\r\n\r\ndestructor TJvDesignSelector.Destroy;\r\nbegin\r\n FHandles.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvDesignSelector.SetHandleWidth(AValue: Integer);\r\nbegin\r\n FHandleWidth := AValue;\r\n Update;\r\nend;\r\n\r\nfunction TJvDesignSelector.GetCount: Integer;\r\nbegin\r\n Result := FHandles.Count;\r\nend;\r\n\r\nfunction TJvDesignSelector.GetHandles(AIndex: Integer): TJvDesignHandles;\r\nbegin\r\n Result := TJvDesignHandles(FHandles[AIndex]);\r\nend;\r\n\r\nprocedure TJvDesignSelector.SetHandles(AIndex: Integer; AValue: TJvDesignHandles);\r\nbegin\r\n FHandles[AIndex] := AValue;\r\nend;\r\n\r\nfunction TJvDesignSelector.GetSelection(AIndex: Integer): TControl;\r\nbegin\r\n Result := Handles[AIndex].Selected;\r\nend;\r\n\r\nprocedure TJvDesignSelector.SetSelection(AIndex: Integer; AValue: TControl);\r\nbegin\r\n Handles[AIndex].Selected := AValue;\r\nend;\r\n\r\nfunction TJvDesignSelector.FindHandles(AValue: TControl): TJvDesignHandles;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := nil;\r\n for I := 0 to Count - 1 do\r\n begin\r\n Result := Handles[I];\r\n if Result.Selected = AValue then\r\n Break\r\n else\r\n Result := nil;\r\n end;\r\nend;\r\n\r\nfunction TJvDesignSelector.IsSelected(AValue: TControl): Boolean;\r\nbegin\r\n Result := FindHandles(AValue) <> nil;\r\nend;\r\n\r\nprocedure TJvDesignSelector.ClearSelection;\r\nbegin\r\n //if not (csDestroying in ComponentState) then\r\n FHandles.Clear;\r\nend;\r\n\r\nprocedure TJvDesignSelector.ShowHideResizeHandles;\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := 0 to Count - 1 do\r\n with Handles[I] do\r\n begin\r\n Resizeable := (Count = 1);\r\n RepaintHandles;\r\n end;\r\nend;\r\n\r\nprocedure TJvDesignSelector.AddToSelection(AValue: TControl);\r\nvar\r\n H: TJvDesignHandles;\r\nbegin\r\n if AValue = nil then\r\n raise EJVCLException.CreateRes(@RsEDesignCannotSelect);\r\n if not IsSelected(AValue) then\r\n begin\r\n H := TJvDesignHandles.Create(Self);\r\n H.Container := Surface.Container;\r\n H.Resizeable := Count = 0;\r\n FHandles.Add(H);\r\n H.Selected := AValue;\r\n if Count = 2 then\r\n ShowHideResizeHandles\r\n else\r\n H.UpdateHandles;\r\n Surface.Messenger.DesignComponent(H.Handles[0], True);\r\n Surface.Messenger.DesignComponent(H.Handles[1], True);\r\n Surface.Messenger.DesignComponent(H.Handles[2], True);\r\n Surface.Messenger.DesignComponent(H.Handles[3], True);\r\n end;\r\nend;\r\n\r\nprocedure TJvDesignSelector.RemoveFromSelection(AValue: TControl);\r\nbegin\r\n if IsSelected(AValue) then\r\n begin\r\n FHandles.Remove(FindHandles(AValue));\r\n Surface.SelectionChange;\r\n end;\r\nend;\r\n\r\nfunction TJvDesignSelector.GetClientControl(AControl: TControl): TControl;\r\nbegin\r\n if AControl is TJvDesignHandle then\r\n Result := TJvDesignHandles(AControl.Owner).Selected\r\n else\r\n Result := AControl;\r\nend;\r\n\r\nprocedure TJvDesignSelector.Update;\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := 0 to Count - 1 do\r\n Handles[I].UpdateHandles;\r\nend;\r\n\r\nfunction TJvDesignSelector.GetHitHandle(AX, AY: Integer): TJvDesignHandleId;\r\nbegin\r\n if Count > 0 then\r\n Result := Handles[0].HitRect(AX, AY)\r\n else\r\n Result := dhNone;\r\nend;\r\n\r\nfunction TJvDesignSelector.GetCursor(AX, AY: Integer): TCursor;\r\nconst\r\n cCurs: array[TJvDesignHandleId] of TCursor =\r\n (crHandPoint, crSizeNWSE, crSizeNS, crSizeNESW, crSizeWE, crSizeWE,\r\n crSizeNESW, crSizeNS, crSizeNWSE);\r\nbegin\r\n Result := cCurs[GetHitHandle(AX, AY)];\r\nend;\r\n\r\n//=== { TJvDesignController } ================================================\r\n\r\nprocedure TJvDesignController.Action(AAction: TJvDesignAction);\r\nbegin\r\n with Surface do\r\n case AAction of\r\n daSelectParent:\r\n SelectParent;\r\n daDelete:\r\n DeleteComponents;\r\n daCopy:\r\n CopyComponents;\r\n daCut:\r\n CutComponents;\r\n daPaste:\r\n PasteComponents;\r\n daNudgeLeft:\r\n NudgeComponents(-1, 0);\r\n daNudgeRight:\r\n NudgeComponents(1, 0);\r\n daNudgeUp:\r\n NudgeComponents(0, -1);\r\n daNudgeDown:\r\n NudgeComponents(0, 1);\r\n daGrowWidth:\r\n GrowComponents(1, 0);\r\n daShrinkWidth:\r\n GrowComponents(-1, 0);\r\n daGrowHeight:\r\n GrowComponents(0, 1);\r\n daShrinkHeight:\r\n GrowComponents(0, -1);\r\n end;\r\n Surface.UpdateDesigner;\r\nend;\r\n\r\nfunction TJvDesignController.GetDragRect: TRect;\r\nbegin\r\n Result := FDragRect;\r\nend;\r\n\r\nfunction TJvDesignController.KeyDown(AKeyCode: Cardinal): Boolean;\r\n\r\n function CtrlKeys: Boolean;\r\n begin\r\n Result := True;\r\n case AKeyCode of\r\n VK_LEFT:\r\n Action(daNudgeLeft);\r\n VK_RIGHT:\r\n Action(daNudgeRight);\r\n VK_UP:\r\n Action(daNudgeUp);\r\n VK_DOWN:\r\n Action(daNudgeDown);\r\n else\r\n Result := False;\r\n end;\r\n end;\r\n\r\n function ShiftKeys: Boolean;\r\n begin\r\n Result := True;\r\n case AKeyCode of\r\n VK_LEFT:\r\n Action(daShrinkWidth);\r\n VK_RIGHT:\r\n Action(daGrowWidth);\r\n VK_UP:\r\n Action(daShrinkHeight);\r\n VK_DOWN:\r\n Action(daGrowHeight);\r\n else\r\n Result := False;\r\n end;\r\n end;\r\n\r\nbegin\r\n FKeyDownShift := Shift;\r\n if ssCtrl in FKeyDownShift then\r\n Result := CtrlKeys\r\n else\r\n if ssShift in FKeyDownShift then\r\n Result := ShiftKeys\r\n else\r\n Result := False;\r\nend;\r\n\r\nfunction TJvDesignController.KeyUp(AKeyCode: Cardinal): Boolean;\r\n\r\n function Keys: Boolean;\r\n begin\r\n Result := True;\r\n case AKeyCode of\r\n VK_ESCAPE:\r\n Action(daSelectParent);\r\n VK_DELETE:\r\n Action(daDelete);\r\n else\r\n Result := False;\r\n end;\r\n end;\r\n\r\n function CtrlKeys: Boolean;\r\n begin\r\n Result := True;\r\n case AKeyCode of\r\n Ord('C'):\r\n Action(daCopy);\r\n Ord('X'):\r\n Action(daCut);\r\n Ord('V'):\r\n Action(daPaste);\r\n else\r\n Result := False;\r\n end;\r\n end;\r\n\r\n function ShiftKeys: Boolean;\r\n begin\r\n Result := False;\r\n end;\r\n\r\nbegin\r\n FKeyDownShift := FKeyDownShift + Shift;\r\n if ssCtrl in FKeyDownShift then\r\n Result := CtrlKeys\r\n else\r\n if ssShift in FKeyDownShift then\r\n Result := ShiftKeys\r\n else\r\n Result := Keys;\r\n FKeyDownShift := [];\r\nend;\r\n\r\nfunction TJvDesignController.MouseDown(Button: TMouseButton; X, Y: Integer): Boolean;\r\nvar\r\n HandleId: TJvDesignHandleId;\r\n\r\n procedure CaptureMouse;\r\n begin\r\n FMouseIsDown := True;\r\n Mouse.Capture := Surface.Container.Handle;\r\n end;\r\n\r\n procedure FocusSurface;\r\n var\r\n WasActive: Boolean;\r\n begin\r\n if not Surface.Container.Focused and Surface.Container.CanFocus then\r\n begin\r\n // Mantis 4732: deactivate the container otherwise SetFocus does not work\r\n // This bug apparently only happens under certain rare conditions\r\n // under windows but its fix does not seem to have any negative impact\r\n // on systems where it does not happen.\r\n WasActive := TJvDesignPanel(Surface.Container).Active;\r\n if WasActive then\r\n TJvDesignPanel(Surface.Container).Active := False;\r\n\r\n Surface.Container.SetFocus;\r\n\r\n if WasActive then\r\n TJvDesignPanel(Surface.Container).Active := True;\r\n end;\r\n end;\r\n\r\n procedure SelectDragMode;\r\n begin\r\n HandleId := dhNone;\r\n if ssCtrl in Shift then\r\n // Ctrl-drag selection has highest priority\r\n FDragMode := dmSelect\r\n else\r\n begin\r\n HandleId := Surface.GetHitHandle(X, Y);\r\n if HandleId <> dhNone then\r\n begin\r\n FClicked := Surface.Selection[0];\r\n FDragMode := dmResize;\r\n end\r\n else\r\n begin\r\n FClicked := Surface.FindControl(X, Y);\r\n if (FClicked = Surface.Container) or (FClicked is TJvDesignHandle) then\r\n FClicked := nil;\r\n Surface.GetAddClass;\r\n if Surface.AddClass <> '' then\r\n // then object creation\r\n FDragMode := dmCreate\r\n else\r\n if FClicked <> nil then\r\n // moving is last\r\n FDragMode := dmMove\r\n else\r\n // select by default\r\n FDragMode := dmSelect;\r\n end;\r\n end;\r\n if FClicked = nil then\r\n FClicked := Surface.Container;\r\n FClicked.Parent.DisableAlign;\r\n end;\r\n\r\n procedure CreateMouseTool;\r\n begin\r\n case FDragMode of\r\n dmSelect, dmCreate:\r\n begin\r\n Surface.ClearSelection;\r\n FMouseTool := TJvDesignBander.Create(Surface);\r\n end;\r\n dmMove:\r\n begin\r\n if ssShift in Shift then\r\n Surface.Selector.AddToSelection(FClicked)\r\n else\r\n if not Surface.Selector.IsSelected(FClicked) then\r\n Surface.Select(FClicked);\r\n FMouseTool := TJvDesignMover.Create(Surface);\r\n end;\r\n dmResize:\r\n begin\r\n if not Surface.Selector.IsSelected(FClicked) then\r\n Surface.Select(FClicked);\r\n FMouseTool := TJvDesignSizer.CreateSizer(Surface, HandleId);\r\n end;\r\n end;\r\n if FMouseTool <> nil then\r\n FMouseTool.MouseDown(Button, Shift, X, Y);\r\n end;\r\n\r\nbegin\r\n FocusSurface;\r\n CaptureMouse;\r\n SelectDragMode;\r\n CreateMouseTool;\r\n Result := True;\r\nend;\r\n\r\nfunction TJvDesignController.MouseMove(X, Y: Integer): Boolean;\r\nbegin\r\n if not FMouseIsDown then\r\n Windows.SetCursor(Screen.Cursors[Surface.GetCursor(X, Y)])\r\n else\r\n if FMouseTool <> nil then\r\n FMouseTool.MouseMove(Shift, X, Y);\r\n Result := True;\r\nend;\r\n\r\nfunction TJvDesignController.MouseUp(Button: TMouseButton; X, Y: Integer): Boolean;\r\n\r\n procedure ReleaseMouse;\r\n begin\r\n FMouseIsDown := False;\r\n Mouse.Capture := 0;\r\n end;\r\n\r\n procedure EnableAlign;\r\n begin\r\n // If the debugger breaks in during a mouse operation,\r\n // AlignDisabled can become stuck.\r\n // This routine is to aid debugging only.\r\n if FClicked <> nil then\r\n while FClicked.Parent.AlignDisabled do\r\n FClicked.Parent.EnableAlign;\r\n end;\r\n\r\n procedure FinishMouseTool;\r\n begin\r\n if FMouseTool <> nil then\r\n try\r\n FMouseTool.MouseUp(Button, Shift, X, Y);\r\n FDragRect := DesignValidateRect(FMouseTool.DragRect);\r\n case FDragMode of\r\n dmCreate:\r\n begin\r\n if FClicked <> nil then\r\n Surface.Select(FClicked);\r\n Surface.AddComponent;\r\n end;\r\n else\r\n Surface.SelectionChange;\r\n end;\r\n finally\r\n FreeAndNil(FMouseTool);\r\n end;\r\n end;\r\n\r\nbegin\r\n if FMouseIsDown then\r\n begin\r\n ReleaseMouse;\r\n EnableAlign;\r\n FinishMouseTool;\r\n // We have to call UpdateDesigner for GraphicControls because they don't get\r\n // WM_WINDOWPOSCHANGED messages that update the designer handles.\r\n if FClicked is TGraphicControl then\r\n Surface.UpdateDesigner;\r\n FClicked := nil;\r\n end;\r\n Result := True;\r\nend;\r\n\r\n//=== { TJvDesignMouseTool } =================================================\r\n\r\nconstructor TJvDesignMouseTool.Create(AOwner: TJvDesignSurface);\r\nbegin\r\n Surface := AOwner;\r\nend;\r\n\r\nfunction TJvDesignMouseTool.GetMouseDelta: TPoint;\r\nconst\r\n GridX = 4;\r\n GridY = 4;\r\nbegin\r\n Result.X := FMouseLast.X - FMouseStart.X;\r\n Dec(Result.X, Result.X mod GridX);\r\n Result.Y := FMouseLast.Y - FMouseStart.Y;\r\n Dec(Result.Y, Result.Y mod GridY);\r\nend;\r\n\r\n//=== { TJvDesignMover } =====================================================\r\n\r\nconstructor TJvDesignMover.Create(AOwner: TJvDesignSurface);\r\nbegin\r\n inherited Create(AOwner);\r\n SetLength(FDragRects, Surface.Count);\r\nend;\r\n\r\nprocedure TJvDesignMover.CalcDragRects;\r\nvar\r\n Delta: TPoint;\r\n I: Integer;\r\nbegin\r\n Delta := GetMouseDelta;\r\n for I := 0 to Surface.Count - 1 do\r\n with Surface.Selection[I] do\r\n begin\r\n FDragRects[I] := BoundsRect;\r\n OffsetRect(FDragRects[I], Delta.X, Delta.Y);\r\n end;\r\nend;\r\n\r\nprocedure TJvDesignMover.CalcPaintRects;\r\nvar\r\n I: Integer;\r\n Pt: TPoint;\r\nbegin\r\n CalcDragRects;\r\n for I := 0 to Surface.Count - 1 do\r\n with Surface.Selection[I] do\r\n begin\r\n Pt := Parent.ClientToScreen(Point(0, 0));\r\n OffsetRect(FDragRects[I], Pt.X, Pt.Y);\r\n end;\r\nend;\r\n\r\nprocedure TJvDesignMover.PaintDragRects;\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := 0 to Surface.Count - 1 do\r\n DesignPaintRubberbandRect(Surface.Container, FDragRects[I], psDot);\r\nend;\r\n\r\nprocedure TJvDesignMover.ApplyDragRects;\r\nvar\r\n I: Integer;\r\nbegin\r\n if (GetMouseDelta.X <> 0) or (GetMouseDelta.Y <> 0) then\r\n begin\r\n CalcDragRects;\r\n for I := 0 to Surface.Count - 1 do\r\n Surface.Selection[I].BoundsRect := FDragRects[I];\r\n Surface.Change;\r\n end;\r\nend;\r\n\r\nprocedure TJvDesignMover.MouseDown(Button: TMouseButton; Shift: TShiftState;\r\n X, Y: Integer);\r\nbegin\r\n FMouseStart := Point(X, Y);\r\n FMouseLast := FMouseStart;\r\n CalcPaintRects;\r\n PaintDragRects;\r\nend;\r\n\r\nprocedure TJvDesignMover.MouseMove(Shift: TShiftState; X, Y: Integer);\r\nbegin\r\n PaintDragRects;\r\n FMouseLast := Point(X, Y);\r\n CalcPaintRects;\r\n PaintDragRects;\r\nend;\r\n\r\nprocedure TJvDesignMover.MouseUp(Button: TMouseButton; Shift: TShiftState;\r\n X, Y: Integer);\r\nbegin\r\n PaintDragRects;\r\n FMouseLast := Point(X, Y);\r\n ApplyDragRects;\r\nend;\r\n\r\n//=== { TJvDesignBander } ====================================================\r\n\r\nprocedure TJvDesignBander.CalcDragRect;\r\nvar\r\n Pt: TPoint;\r\nbegin\r\n Pt := GetMouseDelta;\r\n FDragRect := Rect(0, 0, Pt.X, Pt.Y);\r\n OffsetRect(FDragRect, FMouseStart.X, FMouseStart.Y);\r\nend;\r\n\r\nfunction TJvDesignBander.GetClient: TControl;\r\nbegin\r\n Result := Surface.Container;\r\nend;\r\n\r\nfunction TJvDesignBander.GetPaintRect: TRect;\r\nvar\r\n Pt: TPoint;\r\nbegin\r\n Result := FDragRect;\r\n Pt := GetClient.ClientToScreen(Point(0, 0));\r\n OffsetRect(Result, Pt.X, Pt.Y);\r\nend;\r\n\r\nprocedure TJvDesignBander.PaintDragRect;\r\nbegin\r\n DesignPaintRubberbandRect(Surface.Container, GetPaintRect, psDot);\r\nend;\r\n\r\nprocedure TJvDesignBander.MouseDown(Button: TMouseButton; Shift: TShiftState;\r\n X, Y: Integer);\r\nbegin\r\n FMouseStart := Point(X, Y);\r\n FMouseLast := FMouseStart;\r\n CalcDragRect;\r\n PaintDragRect;\r\nend;\r\n\r\nprocedure TJvDesignBander.MouseMove(Shift: TShiftState; X, Y: Integer);\r\nbegin\r\n PaintDragRect;\r\n FMouseLast := Point(X, Y);\r\n CalcDragRect;\r\n PaintDragRect;\r\nend;\r\n\r\nprocedure TJvDesignBander.MouseUp(Button: TMouseButton; Shift: TShiftState;\r\n X, Y: Integer);\r\nbegin\r\n PaintDragRect;\r\n CalcDragRect;\r\nend;\r\n\r\n//=== { TJvDesignSizer } =====================================================\r\n\r\nconstructor TJvDesignSizer.CreateSizer(AOwner: TJvDesignSurface; AHandle: TJvDesignHandleId);\r\nbegin\r\n inherited Create(AOwner);\r\n FHandleId := AHandle;\r\nend;\r\n\r\nprocedure TJvDesignSizer.ApplyMouseDelta(X, Y: Integer);\r\nbegin\r\n case FHandleId of\r\n dhLeftTop, dhMiddleTop, dhRightTop:\r\n Inc(FDragRect.Top, Y);\r\n dhLeftBottom, dhMiddleBottom, dhRightBottom:\r\n Inc(FDragRect.Bottom, Y);\r\n end;\r\n case FHandleId of\r\n dhLeftTop, dhLeftMiddle, dhLeftBottom:\r\n Inc(FDragRect.Left, X);\r\n dhRightTop, dhRightMiddle, dhRightBottom:\r\n Inc(FDragRect.Right, X);\r\n end;\r\nend;\r\n\r\nprocedure TJvDesignSizer.CalcDragRect;\r\nvar\r\n Pt: TPoint;\r\nbegin\r\n FDragRect := Surface.Selection[0].BoundsRect;\r\n Pt := GetMouseDelta;\r\n ApplyMouseDelta(Pt.X, Pt.Y);\r\n FDragRect := DesignValidateRect(FDragRect);\r\nend;\r\n\r\nfunction TJvDesignSizer.GetClient: TControl;\r\nbegin\r\n Result := Surface.Selection[0].Parent;\r\nend;\r\n\r\nprocedure TJvDesignSizer.ApplyDragRect;\r\nbegin\r\n Surface.Selection[0].BoundsRect := FDragRect;\r\n Surface.Change;\r\nend;\r\n\r\nprocedure TJvDesignSizer.MouseUp(Button: TMouseButton; Shift: TShiftState;\r\n X, Y: Integer);\r\nbegin\r\n inherited MouseUp(Button, Shift, X, Y);\r\n ApplyDragRect;\r\nend;\r\n\r\n//=== { TJvDesignDesigner } ==================================================\r\n\r\nconstructor TJvDesignDesigner.Create(AMessenger: TJvDesignCustomMessenger);\r\nbegin\r\n inherited Create(nil);\r\n FMessenger := AMessenger;\r\nend;\r\n\r\nfunction TJvDesignDesigner.GetCustomForm: TCustomForm;\r\nbegin\r\n Result := nil;\r\nend;\r\n\r\nfunction TJvDesignDesigner.GetIsControl: Boolean;\r\nbegin\r\n Result := False;\r\nend;\r\n\r\nfunction TJvDesignDesigner.GetRoot: TComponent;\r\nbegin\r\n Result := nil;\r\nend;\r\n\r\nfunction TJvDesignDesigner.IsDesignMsg(Sender: TControl; var Msg: TMessage): Boolean;\r\nbegin\r\n Result := Messenger.IsDesignMessage(Sender, Msg);\r\nend;\r\n\r\n{$IFDEF RTL240_UP}\r\nprocedure TJvDesignDesigner.DrawSelectionMarks(AControl: TControl);\r\nbegin\r\n {$MESSAGE WARN 'Check and implement TJvDesignDesigner.DrawSelectionMarks if necessary'}\r\nend;\r\n\r\nfunction TJvDesignDesigner.IsSelected(AControl: TControl): Boolean;\r\nbegin\r\n {$MESSAGE WARN 'Check and implement TJvDesignDesigner.IsSelected if necessary'}\r\n Result := False;\r\nend;\r\n{$ENDIF RTL240_UP}\r\n\r\nprocedure TJvDesignDesigner.Modified;\r\nbegin\r\n //\r\nend;\r\n\r\nprocedure TJvDesignDesigner.Notification(AnObject: TPersistent;\r\n Operation: TOperation);\r\nbegin\r\n //\r\nend;\r\n\r\nprocedure TJvDesignDesigner.PaintGrid;\r\nbegin\r\n //\r\nend;\r\n\r\nprocedure TJvDesignDesigner.SetCustomForm(Value: TCustomForm);\r\nbegin\r\n //\r\nend;\r\n\r\nprocedure TJvDesignDesigner.SetIsControl(Value: Boolean);\r\nbegin\r\n //\r\nend;\r\n\r\nfunction TJvDesignDesigner.UniqueName(const BaseName: string): string;\r\nbegin\r\n //\r\nend;\r\n\r\nprocedure TJvDesignDesigner.ValidateRename(AComponent: TComponent;\r\n const CurName, NewName: string);\r\nbegin\r\n //\r\nend;\r\n\r\n{$IFDEF COMPILER9_UP}\r\nprocedure TJvDesignDesigner.PaintMenu;\r\nbegin\r\n //\r\nend;\r\n{$ENDIF COMPILER9_UP}\r\n\r\n//=== { TJvDesignDesignerMessenger } =========================================\r\n\r\nconstructor TJvDesignDesignerMessenger.Create;\r\nbegin\r\n FDesigner := TJvDesignDesigner.Create(Self);\r\nend;\r\n\r\ndestructor TJvDesignDesignerMessenger.Destroy;\r\nbegin\r\n if Container <> nil then\r\n DesignChildren(Container, False);\r\n if FDesignedForm <> nil then\r\n FDesignedForm.Designer := nil;\r\n FDesigner.Free;\r\n inherited Destroy;\r\nend;\r\n\r\ntype\r\n TAccessComponent = class(TComponent);\r\n\r\nprocedure TJvDesignDesignerMessenger.SetComponentDesigning(AComponent: TComponent; ADesigning: Boolean);\r\nbegin\r\n TAccessComponent(AComponent).SetDesigning(ADesigning);\r\nend;\r\n\r\nprocedure TJvDesignDesignerMessenger.UndesignComponent(AComponent: TComponent);\r\nbegin\r\n SetComponentDesigning(AComponent, False);\r\nend;\r\n\r\nprocedure TJvDesignDesignerMessenger.DesignComponent(AComponent: TComponent; ADesigning: Boolean);\r\nbegin\r\n SetComponentDesigning(AComponent, ADesigning);\r\nend;\r\n\r\nprocedure TJvDesignDesignerMessenger.SetContainer(AValue: TWinControl);\r\n\r\n function FindParentForm: TCustomForm;\r\n var\r\n P: TWinControl;\r\n begin\r\n P := Container;\r\n while P.Parent <> nil do\r\n P := P.Parent;\r\n if not (P is TCustomForm) then\r\n raise EJVCLException.CreateResFmt(@RsEOldestFmt , [ClassName]);\r\n Result := TCustomForm(P);\r\n end;\r\n\r\nbegin\r\n inherited SetContainer(AValue);\r\n if Container <> nil then\r\n begin\r\n FDesignedForm := FindParentForm;\r\n FDesignedForm.Designer := FDesigner;\r\n DesignChildren(Container, True);\r\n end;\r\nend;\r\n\r\n//=== { TJvDesignMessageHookList } ===========================================\r\n\r\nconstructor TJvDesignMessageHookList.Create(AUser: TJvDesignCustomMessenger);\r\nbegin\r\n inherited Create(nil);\r\n FUser := AUser;\r\n FHooks := TObjectList.Create;\r\n FHooks.OwnsObjects := True;\r\nend;\r\n\r\ndestructor TJvDesignMessageHookList.Destroy;\r\nbegin\r\n FHooks.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvDesignMessageHookList.Clear;\r\nbegin\r\n FHooks.Clear;\r\nend;\r\n\r\nprocedure TJvDesignMessageHookList.Hook(AClient: TWinControl);\r\nbegin\r\n AClient.FreeNotification(Self);\r\n FHooks.Add(TJvDesignMessageHook.Create(FUser, AClient));\r\nend;\r\n\r\nprocedure TJvDesignMessageHookList.Unhook(AComponent: TComponent);\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := 0 to FHooks.Count - 1 do\r\n if TJvDesignMessageHook(FHooks[I]).Client = AComponent then\r\n begin\r\n FHooks.Delete(I);\r\n Break;\r\n end;\r\nend;\r\n\r\nprocedure TJvDesignMessageHookList.Notification(AComponent: TComponent;\r\n Operation: TOperation);\r\nbegin\r\n inherited Notification(AComponent, Operation);\r\n if Operation = opRemove then\r\n Unhook(AComponent);\r\nend;\r\n\r\n//=== { TJvDesignWinControlHookMessenger } ===================================\r\n\r\nconstructor TJvDesignWinControlHookMessenger.Create;\r\nbegin\r\n inherited Create;\r\n FHooks := TJvDesignMessageHookList.Create(Self);\r\nend;\r\n\r\ndestructor TJvDesignWinControlHookMessenger.Destroy;\r\nbegin\r\n FHooks.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvDesignWinControlHookMessenger.Clear;\r\nbegin\r\n FHooks.Clear;\r\nend;\r\n\r\nprocedure TJvDesignWinControlHookMessenger.DesignComponent(AComponent: TComponent; ADesigning: Boolean);\r\nbegin\r\n if (AComponent is TWinControl) then\r\n if ADesigning then\r\n HookWinControl(TWinControl(AComponent))\r\n else\r\n UnhookWinControl(TWinControl(AComponent))\r\nend;\r\n\r\nprocedure TJvDesignWinControlHookMessenger.HookWinControl(AWinControl: TWinControl);\r\nbegin\r\n FHooks.Hook(AWinControl);\r\n DesignChildren(AWinControl, True);\r\nend;\r\n\r\nprocedure TJvDesignWinControlHookMessenger.UnhookWinControl(AWinControl: TWinControl);\r\nbegin\r\n FHooks.Unhook(AWinControl);\r\n DesignChildren(AWinControl, False);\r\nend;\r\n\r\nprocedure TJvDesignWinControlHookMessenger.SetContainer(AValue: TWinControl);\r\nbegin\r\n inherited SetContainer(AValue);\r\n if Container <> nil then\r\n DesignChildren(Container, True);\r\nend;\r\n\r\ninitialization\r\n {$IFDEF UNITVERSIONING}\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n {$ENDIF UNITVERSIONING}\r\n\r\nfinalization\r\n FreeShadedBits;\r\n {$IFDEF UNITVERSIONING}\r\n UnregisterUnitVersion(HInstance);\r\n {$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvDesignSurface.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvDesingSurface.pas, released on 2005-08-21.\r\n\r\nThe Initial Developer of the Original Code is Scott J Miles\r\nPortions created by Scott J Miles are Copyright (C) 2005 Scott J Miles.\r\nAll Rights Reserved.\r\n\r\nContributor(s): Olivier Sannier (JVCL Integration)\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL\r\nhome page, located at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n Mantis 3963: When a design surface is active, the ENTIRE form where it is\r\n located suffers impacts from being in design mode. This can not\r\n be circumvented because the Designer property is to be set on\r\n the parent form and it MUST be set for the design mode to be\r\n effective. The only workaround is to not have anything else\r\n on the form being designed.\r\n\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvDesignSurface.pas 13415 2012-09-10 09:51:54Z obones $\r\n\r\nunit JvDesignSurface;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, Messages, SysUtils, Classes, Controls, Graphics,\r\n Forms, ExtCtrls;\r\n\r\ntype\r\n TJvDesignSurface = class;\r\n\r\n TJvDesignMessage = function(ASender: TControl; var AMsg: TMessage;\r\n const APt: TPoint): Boolean of object;\r\n\r\n TJvDesignCustomMessenger = class(TObject)\r\n private\r\n FContainer: TWinControl;\r\n FOnDesignMessage: TJvDesignMessage;\r\n protected\r\n procedure SetContainer(AValue: TWinControl); virtual;\r\n public\r\n constructor Create; virtual;\r\n destructor Destroy; override;\r\n function IsDesignMessage(ASender: TControl; var AMessage: TMessage): Boolean; virtual;\r\n procedure Clear; virtual;\r\n procedure DesignChildren(AContainer: TWinControl; ADesigning: Boolean);\r\n procedure DesignComponent(AComponent: TComponent; ADesigning: Boolean); virtual;\r\n property Container: TWinControl read FContainer write SetContainer;\r\n property OnDesignMessage: TJvDesignMessage read FOnDesignMessage write FOnDesignMessage;\r\n end;\r\n\r\n TJvDesignCustomMessengerClass = class of TJvDesignCustomMessenger;\r\n\r\n TJvDesignMessageHook = class(TObject)\r\n private\r\n FClient: TWinControl;\r\n FOldProc: TWndMethod;\r\n FUser: TJvDesignCustomMessenger;\r\n protected\r\n procedure HookProc(var AMessage: TMessage);\r\n procedure Unhook;\r\n public\r\n constructor Create(AUser: TJvDesignCustomMessenger; AClient: TWinControl);\r\n destructor Destroy; override;\r\n property Client: TWinControl read FClient;\r\n end;\r\n\r\n TJvDesignCustomController = class(TObject)\r\n private\r\n FSurface: TJvDesignSurface;\r\n protected\r\n function GetDragRect: TRect; virtual; abstract;\r\n function GetShift: TShiftState;\r\n function KeyDown(AKeyCode: Cardinal): Boolean; virtual; abstract;\r\n function KeyUp(AKeyCode: Cardinal): Boolean; virtual; abstract;\r\n function MouseDown(Button: TMouseButton; X, Y: Integer): Boolean; virtual; abstract;\r\n function MouseMove(X, Y: Integer): Boolean; virtual; abstract;\r\n function MouseUp(Button: TMouseButton; X, Y: Integer): Boolean; virtual; abstract;\r\n public\r\n constructor Create(ASurface: TJvDesignSurface); virtual;\r\n property DragRect: TRect read GetDragRect;\r\n property Shift: TShiftState read GetShift;\r\n property Surface: TJvDesignSurface read FSurface;\r\n end;\r\n\r\n TJvDesignCustomControllerClass = class of TJvDesignCustomController;\r\n\r\n TJvDesignHandleId = (dhNone, dhLeftTop, dhMiddleTop, dhRightTop, dhLeftMiddle,\r\n dhRightMiddle, dhLeftBottom, dhMiddleBottom, dhRightBottom);\r\n\r\n TJvDesignCustomSelector = class(TComponent)\r\n private\r\n FSurface: TJvDesignSurface;\r\n protected\r\n function GetCount: Integer; virtual; abstract;\r\n function GetSelection(AIndex: Integer): TControl; virtual; abstract;\r\n procedure SetSelection(AIndex: Integer; AValue: TControl); virtual; abstract;\r\n public\r\n constructor Create(ASurface: TJvDesignSurface); reintroduce; virtual;\r\n destructor Destroy; override;\r\n function IsSelected(AValue: TControl): Boolean; virtual; abstract;\r\n function GetClientControl(AControl: TControl): TControl; virtual; abstract;\r\n function GetCursor(AX, AY: Integer): TCursor; virtual; abstract;\r\n function GetHitHandle(AX, AY: Integer): TJvDesignHandleId; virtual; abstract;\r\n procedure AddToSelection(AValue: TControl); virtual; abstract;\r\n procedure ClearSelection; virtual; abstract;\r\n procedure RemoveFromSelection(AValue: TControl); virtual; abstract;\r\n procedure ToggleSelection(AValue: TControl);\r\n procedure Update; virtual; abstract;\r\n property Count: Integer read GetCount;\r\n property Selection[AIndex: Integer]: TControl read GetSelection write SetSelection;\r\n property Surface: TJvDesignSurface read FSurface;\r\n end;\r\n\r\n TJvDesignCustomSelectorClass = class of TJvDesignCustomSelector;\r\n\r\n TJvDesignObjectArray = array of TObject;\r\n TJvDesignGetAddClassEvent = procedure(Sender: TObject; var ioClass: string) of object;\r\n{\r\n TJvDesignOwnerDrawGridEvent = procedure(ASender: TObject; ACanvas: TCanvas;\r\n ARect: TRect) of object;\r\n}\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvDesignSurface = class(TComponent)\r\n private\r\n FActive: Boolean;\r\n FAddClass: string;\r\n FContainer: TWinControl;\r\n FContainerHook: TJvDesignMessageHook;\r\n FController: TJvDesignCustomController;\r\n FControllerClass: TJvDesignCustomControllerClass;\r\n// FDrawGrid: Boolean;\r\n FMessenger: TJvDesignCustomMessenger;\r\n FMessengerClass: TJvDesignCustomMessengerClass;\r\n FSelector: TJvDesignCustomSelector;\r\n FSelectorClass: TJvDesignCustomSelectorClass;\r\n FUpdateOwner: TComponent;\r\n protected\r\n FOnChange: TNotifyEvent;\r\n FOnGetAddClass: TJvDesignGetAddClassEvent;\r\n// FOnOwnerDrawGrid: TJvDesignOwnerDrawGridEvent;\r\n FOnSelectionChange: TNotifyEvent;\r\n function GetAddBounds: TRect;\r\n function GetCount: Integer;\r\n function GetSelected: TJvDesignObjectArray;\r\n function GetSelectedContainer: TWinControl;\r\n function GetSelection(AIndex: Integer): TControl;\r\n procedure BeginUpdate;\r\n procedure EndUpdate;\r\n procedure NeedContainer;\r\n procedure NeedController;\r\n procedure NeedMessenger;\r\n procedure NeedSelector;\r\n //procedure PaintContainerBkgnd(ADC: HDC);\r\n procedure ReaderError(Reader: TReader; const Msg: string; var Handled: Boolean);\r\n procedure SetActive(AValue: Boolean);\r\n procedure SetContainer(AValue: TWinControl);\r\n //procedure SetDrawGrid(const Value: Boolean);\r\n procedure SetSelection(AIndex: Integer; AValue: TControl);\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n function Clear: TJvDesignSurface;\r\n function ContainerToSelectedContainer(const APt: TPoint): TPoint;\r\n function FindControl(AX, AY: Integer): TControl; virtual;\r\n function GetCursor(AX, AY: Integer): TCursor; virtual;\r\n function GetHitHandle(AX, AY: Integer): TJvDesignHandleId; virtual;\r\n function IsDesignMessage(ASender: TControl; var AMsg: TMessage; const APt: TPoint): Boolean;\r\n function LoadFromFile(const AFileName: string): TJvDesignSurface;\r\n function LoadFromStream(AStream: TStream): TJvDesignSurface;\r\n procedure AddComponent;\r\n procedure Change;\r\n procedure ClearSelection;\r\n procedure CopyComponents;\r\n procedure CutComponents;\r\n procedure DeleteComponents;\r\n procedure GetAddClass;\r\n procedure GrowComponents(AGrowWidth, AGrowHeight: Integer);\r\n procedure NudgeComponents(ANudgeLeft, ANudgeTop: Integer);\r\n procedure PasteComponents;\r\n procedure SaveToFile(const AFileName: string);\r\n procedure SaveToStream(AStream: TStream);\r\n procedure Select(AControl: TControl);\r\n procedure SelectionChange;\r\n procedure SelectParent;\r\n procedure SetSelected(const AValue: array of TObject);\r\n procedure UpdateDesigner; virtual;\r\n property Active: Boolean read FActive write SetActive;\r\n property AddClass: string read FAddClass write FAddClass;\r\n property Controller: TJvDesignCustomController read FController;\r\n property ControllerClass: TJvDesignCustomControllerClass read FControllerClass write FControllerClass;\r\n property Count: Integer read GetCount;\r\n property Messenger: TJvDesignCustomMessenger read FMessenger;\r\n property MessengerClass: TJvDesignCustomMessengerClass read FMessengerClass write FMessengerClass;\r\n property Selected: TJvDesignObjectArray read GetSelected;\r\n property SelectedContainer: TWinControl read GetSelectedContainer;\r\n property Selection[AIndex: Integer]: TControl read GetSelection write SetSelection;\r\n property Selector: TJvDesignCustomSelector read FSelector;\r\n property SelectorClass: TJvDesignCustomSelectorClass read FSelectorClass write FSelectorClass;\r\n published\r\n property Container: TWinControl read FContainer write SetContainer;\r\n// property DrawGrid: Boolean read FDrawGrid write SetDrawGrid default True;\r\n property OnChange: TNotifyEvent read FOnChange write FOnChange;\r\n property OnGetAddClass: TJvDesignGetAddClassEvent read FOnGetAddClass write FOnGetAddClass;\r\n// property OnOwnerDrawGrid: TJvDesignOwnerDrawGridEvent read FOnOwnerDrawGrid write FOnOwnerDrawGrid;\r\n property OnSelectionChange: TNotifyEvent read FOnSelectionChange write FOnSelectionChange;\r\n end;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvDesignScrollBox = class(TScrollBox)\r\n protected\r\n procedure AutoScrollInView(AControl: TControl); override;\r\n end;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvDesignPanel = class(TPanel)\r\n private\r\n FSurface: TJvDesignSurface;\r\n FOnPaint: TNotifyEvent;\r\n FDrawRules: Boolean;\r\n function GetActive: Boolean;\r\n function GetOnChange: TNotifyEvent;\r\n function GetOnGetAddClass: TJvDesignGetAddClassEvent;\r\n function GetOnSelectionChange: TNotifyEvent;\r\n procedure SetActive(const Value: Boolean);\r\n procedure SetOnChange(const Value: TNotifyEvent);\r\n procedure SetOnGetAddClass(const Value: TJvDesignGetAddClassEvent);\r\n procedure SetOnSelectionChange(const Value: TNotifyEvent);\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n procedure Clear;\r\n procedure LoadFromFile(const AFileName: string);\r\n procedure LoadFromStream(AStream: TStream);\r\n procedure Paint; override;\r\n procedure SaveToFile(const AFileName: string);\r\n procedure SaveToStream(AStream: TStream);\r\n procedure SetDrawRules(const Value: Boolean);\r\n property Active: Boolean read GetActive write SetActive;\r\n property Canvas;\r\n property Surface: TJvDesignSurface read FSurface;\r\n published\r\n property DrawRules: Boolean read FDrawRules write SetDrawRules default True;\r\n property OnPaint: TNotifyEvent read FOnPaint write FOnPaint;\r\n property OnChange: TNotifyEvent read GetOnChange write SetOnChange;\r\n property OnGetAddClass: TJvDesignGetAddClassEvent read GetOnGetAddClass write SetOnGetAddClass;\r\n property OnSelectionChange: TNotifyEvent read GetOnSelectionChange write SetOnSelectionChange;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvDesignSurface.pas $';\r\n Revision: '$Revision: 13415 $';\r\n Date: '$Date: 2012-09-10 11:51:54 +0200 (lun. 10 sept. 2012) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n Types,\r\n JvDesignUtils, JvDesignClip, JvDesignImp, JvResources, JvTypes;\r\n\r\n//=== { TJvDesignCustomMessenger } ===========================================\r\n\r\nconstructor TJvDesignCustomMessenger.Create;\r\nbegin\r\n //\r\nend;\r\n\r\ndestructor TJvDesignCustomMessenger.Destroy;\r\nbegin\r\n //\r\nend;\r\n\r\nprocedure TJvDesignCustomMessenger.Clear;\r\nbegin\r\n //\r\nend;\r\n\r\nprocedure TJvDesignCustomMessenger.DesignComponent(AComponent: TComponent; ADesigning: Boolean);\r\nbegin\r\n //\r\nend;\r\n\r\nprocedure TJvDesignCustomMessenger.DesignChildren(AContainer: TWinControl; ADesigning: Boolean);\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := 0 to AContainer.ControlCount - 1 do\r\n DesignComponent(AContainer.Controls[I], ADesigning);\r\nend;\r\n\r\nprocedure TJvDesignCustomMessenger.SetContainer(AValue: TWinControl);\r\nbegin\r\n FContainer := AValue;\r\nend;\r\n\r\nfunction TJvDesignCustomMessenger.IsDesignMessage(ASender: TControl;\r\n var AMessage: TMessage): Boolean;\r\n\r\n function MousePoint: TPoint;\r\n begin\r\n with TWMMouse(AMessage) do\r\n MousePoint := Point(XPos, YPos);\r\n Result := DesignClientToParent(Result, ASender, Container);\r\n end;\r\n\r\nbegin\r\n if not Assigned(FOnDesignMessage) then\r\n Result := False\r\n else\r\n case AMessage.Msg of\r\n WM_MOUSEFIRST..WM_MOUSELAST:\r\n Result := FOnDesignMessage(ASender, AMessage, MousePoint);\r\n WM_KEYDOWN..WM_KEYUP, WM_PAINT, WM_ERASEBKGND, WM_WINDOWPOSCHANGED, CN_KEYDOWN..CN_KEYUP:\r\n Result := FOnDesignMessage(ASender, AMessage, Point(0, 0));\r\n else\r\n Result := False;\r\n end;\r\nend;\r\n\r\n//=== { TJvDesignMessageHook } ===============================================\r\n\r\nconstructor TJvDesignMessageHook.Create(AUser: TJvDesignCustomMessenger;\r\n AClient: TWinControl);\r\nbegin\r\n FUser := AUser;\r\n FClient := AClient;\r\n FOldProc := FClient.WindowProc;\r\n FClient.WindowProc := HookProc;\r\nend;\r\n\r\ndestructor TJvDesignMessageHook.Destroy;\r\nbegin\r\n Unhook;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvDesignMessageHook.Unhook;\r\nbegin\r\n FClient.WindowProc := FOldProc;\r\nend;\r\n\r\nprocedure TJvDesignMessageHook.HookProc(var AMessage: TMessage);\r\nbegin\r\n if not FUser.IsDesignMessage(FClient, AMessage) then\r\n FOldProc(AMessage);\r\nend;\r\n\r\n//=== { TJvDesignCustomController } ==========================================\r\n\r\nconstructor TJvDesignCustomController.Create(ASurface: TJvDesignSurface);\r\nbegin\r\n FSurface := ASurface;\r\nend;\r\n\r\nfunction TJvDesignCustomController.GetShift: TShiftState;\r\nbegin\r\n Result := KeyboardStateToShiftState;\r\nend;\r\n\r\n//=== { TJvDesignCustomSelector } ============================================\r\n\r\nconstructor TJvDesignCustomSelector.Create(ASurface: TJvDesignSurface);\r\nbegin\r\n inherited Create(nil);\r\n FSurface := ASurface;\r\nend;\r\n\r\ndestructor TJvDesignCustomSelector.Destroy;\r\nbegin\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvDesignCustomSelector.ToggleSelection(AValue: TControl);\r\nbegin\r\n if IsSelected(AValue) then\r\n RemoveFromSelection(AValue)\r\n else\r\n AddToSelection(AValue);\r\nend;\r\n\r\n//=== { TJvDesignSurface } ===================================================\r\n\r\nconstructor TJvDesignSurface.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FMessengerClass := TJvDesignDesignerMessenger;\r\n FControllerClass := TJvDesignController;\r\n FSelectorClass := TJvDesignSelector;\r\n //FDrawGrid := True;\r\nend;\r\n\r\ndestructor TJvDesignSurface.Destroy;\r\nbegin\r\n FContainerHook.Free;\r\n Messenger.Free;\r\n Controller.Free;\r\n Selector.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvDesignSurface.Change;\r\nbegin\r\n if Assigned(FOnChange) then\r\n FOnChange(Self);\r\nend;\r\n\r\nprocedure TJvDesignSurface.SetContainer(AValue: TWinControl);\r\nbegin\r\n FContainer := AValue;\r\nend;\r\n\r\nprocedure TJvDesignSurface.NeedContainer;\r\nbegin\r\n if (Container = nil) and (Owner is TWinControl) then\r\n Container := TWinControl(Owner);\r\n if Container = nil then\r\n raise EJVCLException.CreateResFmt(@RsEDesignNilFmt, [ClassName, 'Container']);\r\nend;\r\n\r\nprocedure TJvDesignSurface.NeedController;\r\nbegin\r\n if (Controller = nil) and (ControllerClass <> nil) then\r\n FController := ControllerClass.Create(Self);\r\n if Controller = nil then\r\n raise EJVCLException.CreateResFmt(@RsEDesignNilFmt, [ClassName, 'Controller']);\r\nend;\r\n\r\nprocedure TJvDesignSurface.NeedMessenger;\r\nbegin\r\n if (Messenger = nil) and (MessengerClass <> nil) then\r\n begin\r\n FMessenger := MessengerClass.Create;\r\n Messenger.OnDesignMessage := IsDesignMessage;\r\n end;\r\n if Messenger = nil then\r\n raise EJVCLException.CreateResFmt(@RsEDesignNilFmt, [ClassName, 'Messenger']);\r\nend;\r\n\r\nprocedure TJvDesignSurface.NeedSelector;\r\nbegin\r\n if (Selector = nil) and (SelectorClass <> nil) then\r\n FSelector := SelectorClass.Create(Self);\r\n if Selector = nil then\r\n raise EJVCLException.CreateResFmt(@RsEDesignNilFmt, [ClassName, 'Selector']);\r\nend;\r\n\r\nprocedure TJvDesignSurface.SetActive(AValue: Boolean);\r\n\r\n procedure Activate;\r\n begin\r\n NeedContainer;\r\n NeedController;\r\n NeedSelector;\r\n NeedMessenger;\r\n Messenger.Container := Container;\r\n FContainerHook := TJvDesignMessageHook.Create(Messenger, Container);\r\n end;\r\n\r\n procedure Deactivate;\r\n begin\r\n FreeAndNil(FContainerHook);\r\n Selector.ClearSelection;\r\n FreeAndNil(FMessenger);\r\n end;\r\n\r\nbegin\r\n if FActive <> AValue then\r\n begin\r\n if AValue then\r\n Activate\r\n else\r\n Deactivate;\r\n FActive := AValue;\r\n SelectionChange;\r\n if Assigned(Container) then\r\n Container.Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvDesignSurface.UpdateDesigner;\r\nbegin\r\n Selector.Update;\r\nend;\r\n\r\nfunction TJvDesignSurface.GetCount: Integer;\r\nbegin\r\n Result := Selector.Count;\r\nend;\r\n\r\nfunction TJvDesignSurface.GetSelection(AIndex: Integer): TControl;\r\nbegin\r\n Result := Selector.Selection[AIndex];\r\nend;\r\n\r\nprocedure TJvDesignSurface.SetSelection(AIndex: Integer; AValue: TControl);\r\nbegin\r\n Selector.Selection[AIndex] := AValue;\r\nend;\r\n\r\nprocedure TJvDesignSurface.ClearSelection;\r\nbegin\r\n Selector.ClearSelection;\r\nend;\r\n\r\nprocedure TJvDesignSurface.SelectionChange;\r\nbegin\r\n if not (csDestroying in ComponentState) and Assigned(FOnSelectionChange) then\r\n FOnSelectionChange(Self);\r\nend;\r\n\r\nfunction TJvDesignSurface.GetSelected: TJvDesignObjectArray;\r\nvar\r\n I: Integer;\r\nbegin\r\n SetLength(Result, Count);\r\n for I := 0 to Count - 1 do\r\n Result[I] := Selector.Selection[I];\r\nend;\r\n\r\nprocedure TJvDesignSurface.SetSelected(const AValue: array of TObject);\r\nvar\r\n I: Integer;\r\nbegin\r\n ClearSelection;\r\n for I := 0 to Length(AValue) - 1 do\r\n if AValue[I] is TControl then\r\n Selector.AddToSelection(TControl(AValue[I]));\r\nend;\r\n\r\nprocedure TJvDesignSurface.Select(AControl: TControl);\r\nbegin\r\n ClearSelection;\r\n if AControl <> nil then\r\n Selector.AddToSelection(AControl);\r\nend;\r\n\r\nfunction TJvDesignSurface.FindControl(AX, AY: Integer): TControl;\r\nvar\r\n C, C0: TControl;\r\n P: TPoint;\r\nbegin\r\n P := Point(AX, AY);\r\n C := Container.ControlAtPos(P, True, True);\r\n while (C <> nil) and (C is TWinControl) do\r\n begin\r\n Dec(P.X, C.Left);\r\n Dec(P.Y, C.Top);\r\n C0 := TWinControl(C).ControlAtPos(P, True, True);\r\n if (C0 = nil) or (C0.Owner <> C.Owner) then\r\n Break;\r\n C := C0;\r\n end;\r\n if C = nil then\r\n C := Container;\r\n Result := Selector.GetClientControl(C);\r\nend;\r\n\r\nfunction TJvDesignSurface.GetSelectedContainer: TWinControl;\r\nbegin\r\n if Count <> 1 then\r\n Result := Container\r\n else\r\n if (Selection[0] is TWinControl) and\r\n (csAcceptsControls in Selection[0].ControlStyle) then\r\n Result := TWinControl(Selection[0])\r\n else\r\n Result := Selection[0].Parent;\r\nend;\r\n\r\nfunction TJvDesignSurface.ContainerToSelectedContainer(const APt: TPoint): TPoint;\r\nvar\r\n C: TControl;\r\nbegin\r\n Result := APt;\r\n C := SelectedContainer;\r\n while (C <> Container) and (C <> nil) do\r\n begin\r\n Dec(Result.X, C.Left);\r\n Dec(Result.Y, C.Top);\r\n C := C.Parent;\r\n end;\r\nend;\r\n\r\nfunction TJvDesignSurface.GetAddBounds: TRect;\r\nbegin\r\n with Controller do\r\n begin\r\n Result.TopLeft := ContainerToSelectedContainer(DragRect.TopLeft);\r\n Result.BottomRight := ContainerToSelectedContainer(DragRect.BottomRight);\r\n end;\r\nend;\r\n\r\nprocedure TJvDesignSurface.GetAddClass;\r\nbegin\r\n if Assigned(FOnGetAddClass) then\r\n FOnGetAddClass(Self, FAddClass);\r\nend;\r\n\r\nprocedure TJvDesignSurface.AddComponent;\r\nvar\r\n CC: TComponentClass;\r\n C: TComponent;\r\n CO: TControl;\r\n\r\n function GetBounds: TRect;\r\n begin\r\n Result := GetAddBounds;\r\n if DesignRectWidth(Result) = 0 then\r\n Result.Right := Result.Left + CO.Width;\r\n if DesignRectHeight(Result) = 0 then\r\n Result.Bottom := Result.Top + CO.Height;\r\n end;\r\n\r\nbegin\r\n CC := TComponentClass(GetClass(AddClass));\r\n if (CC <> nil) and (SelectedContainer <> nil) then\r\n begin\r\n //C := CC.Create(Owner);\r\n //C.Name := DesignUniqueName(Owner, AddClass);\r\n C := CC.Create(Container);\r\n C.Name := DesignUniqueName(Container, AddClass);\r\n if C is TControl then\r\n begin\r\n CO := TControl(C);\r\n CO.Parent := SelectedContainer;\r\n CO.BoundsRect := GetBounds;\r\n Select(CO);\r\n end;\r\n Messenger.DesignComponent(C, Active);\r\n SelectionChange;\r\n Change;\r\n AddClass := '';\r\n end;\r\nend;\r\n\r\nprocedure TJvDesignSurface.NudgeComponents(ANudgeLeft, ANudgeTop: Integer);\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := 0 to Count - 1 do\r\n with Selection[I] do\r\n begin\r\n Left := Left + ANudgeLeft;\r\n Top := Top + ANudgeTop;\r\n end;\r\n Change;\r\nend;\r\n\r\nprocedure TJvDesignSurface.GrowComponents(AGrowWidth, AGrowHeight: Integer);\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := 0 to Count - 1 do\r\n with Selection[I] do\r\n begin\r\n Width := DesignMax(1, Width + AGrowWidth);\r\n Height := DesignMax(1, Height + AGrowHeight);\r\n end;\r\n Change;\r\nend;\r\n\r\nprocedure TJvDesignSurface.DeleteComponents;\r\nvar\r\n I: Integer;\r\nbegin\r\n if Count > 0 then\r\n begin\r\n for I := 0 to Count - 1 do\r\n Selection[I].Free;\r\n ClearSelection;\r\n SelectionChange;\r\n Change;\r\n end;\r\nend;\r\n\r\nprocedure TJvDesignSurface.CopyComponents;\r\nvar\r\n I: Integer;\r\nbegin\r\n with TJvDesignComponentClipboard.Create(Container) do\r\n try\r\n OpenWrite;\r\n try\r\n for I := 0 to Count - 1 do\r\n SetComponent(Selection[I]);\r\n finally\r\n CloseWrite;\r\n end;\r\n finally\r\n Free;\r\n end;\r\nend;\r\n\r\nprocedure TJvDesignSurface.CutComponents;\r\nbegin\r\n CopyComponents;\r\n DeleteComponents;\r\nend;\r\n\r\nprocedure TJvDesignSurface.PasteComponents;\r\nvar\r\n CO: TControl;\r\n C: TComponent;\r\n P: TWinControl;\r\n\r\n procedure KeepInParent;\r\n begin\r\n if CO.Left > P.ClientWidth then\r\n CO.Left := P.ClientWidth - CO.Width;\r\n if CO.Top > P.ClientHeight then\r\n CO.Top := P.ClientHeight - CO.Height;\r\n end;\r\n\r\n procedure PasteComponent;\r\n begin\r\n C.Name := DesignUniqueName(Owner, C.ClassName);\r\n Owner.InsertComponent(C);\r\n if C is TControl then\r\n begin\r\n CO := TControl(C);\r\n KeepInParent;\r\n CO.Parent := P;\r\n Selector.AddToSelection(CO);\r\n end;\r\n end;\r\n\r\nbegin\r\n with TJvDesignComponentClipboard.Create(Container) do\r\n try\r\n OpenRead;\r\n try\r\n C := GetComponent;\r\n if (C <> nil) then\r\n begin\r\n P := SelectedContainer;\r\n ClearSelection;\r\n repeat\r\n PasteComponent;\r\n C := GetComponent;\r\n until C = nil;\r\n SelectionChange;\r\n Change;\r\n end;\r\n finally\r\n CloseRead;\r\n end;\r\n finally\r\n Free;\r\n end;\r\nend;\r\n\r\nprocedure TJvDesignSurface.SelectParent;\r\nbegin\r\n if Count > 0 then\r\n Select(Selection[0].Parent);\r\nend;\r\n\r\n{\r\nprocedure TJvDesignSurface.PaintContainerBkgnd(ADC: HDC);\r\nvar\r\n r: TRect;\r\n canvas: TCanvas;\r\nbegin\r\n if DrawGrid then\r\n begin\r\n canvas := TCanvas.Create;\r\n try\r\n SelectClipRgn(ADC, 0);\r\n canvas.Handle := ADC;\r\n canvas.Brush.Color := Container.Brush.Color;\r\n r := canvas.ClipRect;\r\n if Assigned(FOnOwnerDrawGrid) then\r\n FOnOwnerDrawGrid(Self, canvas, Container.ClientRect)\r\n else begin\r\n canvas.FillRect(Container.ClientRect);\r\n DesignPaintRules(canvas, Container.ClientRect);\r\n end;\r\n finally\r\n canvas.Free;\r\n end;\r\n end;\r\nend;\r\n}\r\n\r\ntype\r\n TAccessWinControl = class(TWinControl);\r\n\r\nfunction TJvDesignSurface.IsDesignMessage(ASender: TControl;\r\n var AMsg: TMessage; const APt: TPoint): Boolean;\r\n\r\n function VirtKey: Cardinal;\r\n begin\r\n Result := AMsg.WParam;\r\n end;\r\n\r\n{\r\n function HandlePaint: Boolean;\r\n begin\r\n Result := False;\r\n end;\r\n\r\n function HandleEraseBkgnd: Boolean;\r\n begin\r\n if (ASender <> Container) then\r\n Result := False\r\n else begin\r\n PaintContainerBkgnd(TWMPaint(AMsg).DC);\r\n AMsg.Result := 1;\r\n Result := True;\r\n end;\r\n end;\r\n}\r\nvar\r\n PosChangedHandle: HWND;\r\n I: Integer;\r\n Control: TAccessWinControl;\r\nbegin\r\n if not Active then\r\n Result := False\r\n else\r\n case AMsg.Msg of\r\n{\r\n WM_ERASEBKGND:\r\n Result := HandleEraseBkgnd;\r\n WM_PAINT:\r\n Result := HandlePaint;\r\n}\r\n WM_LBUTTONDOWN:\r\n Result := Controller.MouseDown(mbLeft, APt.X, APt.Y);\r\n WM_LBUTTONUP:\r\n Result := Controller.MouseUp(mbLeft, APt.X, APt.Y);\r\n WM_MOUSEMOVE:\r\n Result := Controller.MouseMove(APt.X, APt.Y);\r\n WM_KEYDOWN, CN_KEYDOWN:\r\n Result := Controller.KeyDown(VirtKey);\r\n WM_KEYUP, CN_KEYUP:\r\n Result := Controller.KeyUp(VirtKey);\r\n WM_WINDOWPOSCHANGED:\r\n begin\r\n if AMsg.lParam <> 0 then\r\n begin\r\n PosChangedHandle := PWindowPos(AMsg.lParam).hwnd;\r\n\r\n // If the window that has changed is a control owned by our container\r\n // then we must update the designer. This allows to programatically\r\n // change the location of a control while making the designer handles\r\n // follow it around (Mantis 4693).\r\n // For this to work properly, we MUST update the bounds of the\r\n // control before calling UpdateDesigner because the VCL has not yet\r\n // processed the WM_WINDOWPOSCHANGED message when this code executes.\r\n // If we did not, the designer would use the previous position of the\r\n // control to display the handles.\r\n // Additionnaly, we must not work with controls that don't have their\r\n // handle allocated. In some instances, creating the handle may trigger\r\n // a second WM_WINDOWPOSCHANGED message, thus leading to an infinite\r\n // loop and a crash (Mantis 5225)\r\n for I := 0 to Container.ComponentCount - 1 do\r\n begin\r\n if Container.Components[I] is TWinControl then\r\n begin\r\n Control := TAccessWinControl(Container.Components[I]);\r\n if Control.HandleAllocated and (PosChangedHandle = Control.Handle) then\r\n begin\r\n if not (csDestroyingHandle in Control.ControlState) then\r\n {$IFDEF DELPHI10_UP}\r\n Control.UpdateBounds;\r\n {$ELSE}\r\n Control.Dispatch(AMsg);\r\n {$ENDIF DELPHI10_UP}\r\n\r\n UpdateDesigner;\r\n end;\r\n end;\r\n end;\r\n end;\r\n\r\n // Must return False to let the VCL do its own work of placing the window\r\n Result := False;\r\n end;\r\n else\r\n Result := False;\r\n end;\r\nend;\r\n\r\nfunction TJvDesignSurface.GetCursor(AX, AY: Integer): TCursor;\r\nbegin\r\n // Using FindControl is inefficient.\r\n // All we really want to know is if Selected[0] contains (AX, AY)\r\n if (Count > 0) and (FindControl(AX, AY) = Selected[0]) then\r\n Result := Selector.GetCursor(AX, AY)\r\n else\r\n Result := crDefault;\r\nend;\r\n\r\nfunction TJvDesignSurface.GetHitHandle(AX, AY: Integer): TJvDesignHandleId;\r\nbegin\r\n Result := Selector.GetHitHandle(AX, AY);\r\nend;\r\n\r\nprocedure TJvDesignSurface.BeginUpdate;\r\nbegin\r\n Active := False;\r\n FUpdateOwner := Owner;\r\n Owner.RemoveComponent(Self);\r\nend;\r\n\r\nprocedure TJvDesignSurface.EndUpdate;\r\nbegin\r\n FUpdateOwner.InsertComponent(Self);\r\n Active := True;\r\nend;\r\n\r\nprocedure TJvDesignSurface.ReaderError(Reader: TReader; const Msg: string;\r\n var Handled: Boolean);\r\nbegin\r\n Handled := True;\r\nend;\r\n\r\nfunction TJvDesignSurface.Clear: TJvDesignSurface;\r\nbegin\r\n BeginUpdate;\r\n try\r\n Container.DestroyComponents;\r\n finally\r\n EndUpdate;\r\n end;\r\n Result := Self;\r\nend;\r\n\r\nprocedure TJvDesignSurface.SaveToStream(AStream: TStream);\r\nbegin\r\n BeginUpdate;\r\n try\r\n DesignSaveComponentToStream(Container, AStream);\r\n finally\r\n EndUpdate;\r\n end;\r\nend;\r\n\r\nfunction TJvDesignSurface.LoadFromStream(AStream: TStream): TJvDesignSurface;\r\nvar\r\n SavedName: string;\r\nbegin\r\n BeginUpdate;\r\n SavedName := Container.Name;\r\n try\r\n Container.DestroyComponents;\r\n DesignLoadComponentFromStream(Container, AStream, ReaderError);\r\n Container.Name := SavedName;\r\n finally\r\n Container.Name := SavedName;\r\n EndUpdate;\r\n end;\r\n Result := Self;\r\nend;\r\n\r\nprocedure TJvDesignSurface.SaveToFile(const AFileName: string);\r\nbegin\r\n BeginUpdate;\r\n try\r\n DesignSaveComponentToFile(Container, AFileName);\r\n finally\r\n EndUpdate;\r\n end;\r\nend;\r\n\r\nfunction TJvDesignSurface.LoadFromFile(const AFileName: string): TJvDesignSurface;\r\nvar\r\n SavedName: string;\r\nbegin\r\n BeginUpdate;\r\n SavedName := Container.Name;\r\n try\r\n Container.DestroyComponents;\r\n DesignLoadComponentFromFile(Container, AFileName, ReaderError);\r\n finally\r\n Container.Name := SavedName;\r\n EndUpdate;\r\n end;\r\n Result := Self;\r\nend;\r\n\r\n{\r\nprocedure TJvDesignSurface.SetDrawGrid(const Value: Boolean);\r\nbegin\r\n FDrawGrid := Value;\r\n if Active then\r\n Container.Invalidate;\r\nend;\r\n}\r\n\r\n//=== { TJvDesignScrollBox } =================================================\r\n\r\nprocedure TJvDesignScrollBox.AutoScrollInView(AControl: TControl);\r\nbegin\r\n //\r\nend;\r\n\r\n//=== { TJvDesignPanel } =====================================================\r\n\r\nconstructor TJvDesignPanel.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FDrawRules := True;\r\n FSurface := TJvDesignSurface.Create(Self);\r\n Surface.Name := 'Surface';\r\n Surface.Container := Self;\r\nend;\r\n\r\nprocedure TJvDesignPanel.SetDrawRules(const Value: Boolean);\r\nbegin\r\n FDrawRules := Value;\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvDesignPanel.Paint;\r\nbegin\r\n inherited Paint;\r\n if Surface.Active or (csDesigning in ComponentState) then\r\n begin\r\n if DrawRules then\r\n DesignPaintRules(Canvas, ClientRect);\r\n if Assigned(FOnPaint) then\r\n FOnPaint(Self);\r\n end;\r\nend;\r\n\r\nprocedure TJvDesignPanel.Clear;\r\nbegin\r\n // DesignSurface property value is lost on clear.\r\n // Restore it with the value returned from Clear.\r\n FSurface := Surface.Clear;\r\nend;\r\n\r\nprocedure TJvDesignPanel.SaveToStream(AStream: TStream);\r\nbegin\r\n Surface.SaveToStream(AStream);\r\nend;\r\n\r\nprocedure TJvDesignPanel.LoadFromStream(AStream: TStream);\r\nbegin\r\n // DesignSurface property value is lost on load.\r\n // Restore it with the value returned from LoadFromStream.\r\n FSurface := Surface.LoadFromStream(AStream);\r\nend;\r\n\r\nprocedure TJvDesignPanel.SaveToFile(const AFileName: string);\r\nbegin\r\n Surface.SaveToFile(AFileName);\r\nend;\r\n\r\nprocedure TJvDesignPanel.LoadFromFile(const AFileName: string);\r\nbegin\r\n // DesignSurface property value is lost on load.\r\n // Restore it with the value returned from LoadFromFile.\r\n FSurface := Surface.LoadFromFile(AFileName);\r\nend;\r\n\r\nfunction TJvDesignPanel.GetActive: Boolean;\r\nbegin\r\n Result := Surface.Active;\r\nend;\r\n\r\nfunction TJvDesignPanel.GetOnChange: TNotifyEvent;\r\nbegin\r\n Result := Surface.OnChange;\r\nend;\r\n\r\nfunction TJvDesignPanel.GetOnGetAddClass: TJvDesignGetAddClassEvent;\r\nbegin\r\n Result := Surface.OnGetAddClass;\r\nend;\r\n\r\nfunction TJvDesignPanel.GetOnSelectionChange: TNotifyEvent;\r\nbegin\r\n Result := Surface.OnSelectionChange;\r\nend;\r\n\r\nprocedure TJvDesignPanel.SetActive(const Value: Boolean);\r\nbegin\r\n Surface.Active := Value;\r\nend;\r\n\r\nprocedure TJvDesignPanel.SetOnChange(const Value: TNotifyEvent);\r\nbegin\r\n Surface.OnChange := Value;\r\nend;\r\n\r\nprocedure TJvDesignPanel.SetOnGetAddClass(const Value: TJvDesignGetAddClassEvent);\r\nbegin\r\n Surface.OnGetAddClass := Value;\r\nend;\r\n\r\nprocedure TJvDesignPanel.SetOnSelectionChange(const Value: TNotifyEvent);\r\nbegin\r\n Surface.OnSelectionChange := Value;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvDesignUtils.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvDesingUtils.pas, released on 2005-08-21.\r\n\r\nThe Initial Developer of the Original Code is Scott J Miles\r\nPortions created by Scott J Miles are Copyright (C) 2005 Scott J Miles.\r\nAll Rights Reserved.\r\n\r\nContributor(s): Olivier Sannier (JVCL Integration)\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL\r\nhome page, located at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvDesignUtils.pas 13104 2011-09-07 06:50:43Z obones $\r\n\r\nunit JvDesignUtils;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n SysUtils, Windows, Classes, Controls, Graphics, Forms;\r\n\r\nfunction DesignClientToParent(const APt: TPoint; AControl, AParent: TControl): TPoint;\r\n\r\nfunction DesignMin(AA, AB: Integer): Integer;\r\nfunction DesignMax(AA, AB: Integer): Integer;\r\n\r\nfunction DesignRectWidth(const ARect: TRect): Integer;\r\nfunction DesignRectHeight(const ARect: TRect): Integer;\r\nfunction DesignValidateRect(const ARect: TRect): TRect;\r\n\r\nfunction DesignNameIsUnique(AOwner: TComponent; const AName: string): Boolean;\r\nfunction DesignUniqueName(AOwner: TComponent; const AClassName: string): string;\r\n\r\nprocedure DesignPaintRubberbandRect(AContainer: TWinControl; ARect: TRect; APenStyle: TPenStyle);\r\nprocedure DesignPaintGrid(ACanvas: TCanvas; const ARect: TRect;\r\n ABackColor: TColor = clBtnFace; AGridColor: TColor = clBlack;\r\n ADivPixels: Integer = 8);\r\nprocedure DesignPaintRules(ACanvas: TCanvas; const ARect: TRect;\r\n ADivPixels: Integer = 32; ASubDivs: Boolean = True);\r\n\r\nprocedure DesignSaveComponentToStream(AComp: TComponent; AStream: TStream);\r\nfunction DesignLoadComponentFromStream(AComp: TComponent; AStream: TStream;\r\n AOnError: TReaderError): TComponent;\r\n\r\nprocedure DesignSaveComponentToFile(AComp: TComponent; const AFileName: string);\r\nprocedure DesignLoadComponentFromFile(AComp: TComponent;\r\n const AFileName: string; AOnError: TReaderError);\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvDesignUtils.pas $';\r\n Revision: '$Revision: 13104 $';\r\n Date: '$Date: 2011-09-07 08:50:43 +0200 (mer. 07 sept. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nfunction DesignClientToParent(const APt: TPoint; AControl, AParent: TControl): TPoint;\r\nbegin\r\n Result := APt;\r\n while (AControl <> AParent) and (AControl <> nil) do\r\n begin\r\n Inc(Result.X, AControl.Left);\r\n Inc(Result.Y, AControl.Top);\r\n AControl := AControl.Parent;\r\n end;\r\nend;\r\n\r\nfunction DesignMin(AA, AB: Integer): Integer;\r\nbegin\r\n if AB < AA then\r\n Result := AB\r\n else\r\n Result := AA;\r\nend;\r\n\r\nfunction DesignMax(AA, AB: Integer): Integer;\r\nbegin\r\n if AB > AA then\r\n Result := AB\r\n else\r\n Result := AA;\r\nend;\r\n\r\nfunction DesignRectWidth(const ARect: TRect): Integer;\r\nbegin\r\n Result := ARect.Right - ARect.Left;\r\nend;\r\n\r\nfunction DesignRectHeight(const ARect: TRect): Integer;\r\nbegin\r\n Result := ARect.Bottom - ARect.Top;\r\nend;\r\n\r\nfunction DesignValidateRect(const ARect: TRect): TRect;\r\nbegin\r\n if ARect.Right < ARect.Left then\r\n begin\r\n Result.Left := ARect.Right;\r\n Result.Right := ARect.Left;\r\n end\r\n else\r\n begin\r\n Result.Left := ARect.Left;\r\n Result.Right := ARect.Right;\r\n end;\r\n if ARect.Bottom < ARect.Top then\r\n begin\r\n Result.Top := ARect.Bottom;\r\n Result.Bottom := ARect.Top;\r\n end\r\n else\r\n begin\r\n Result.Top := ARect.Top;\r\n Result.Bottom := ARect.Bottom;\r\n end;\r\nend;\r\n\r\nfunction DesignNameIsUnique(AOwner: TComponent; const AName: string): Boolean;\r\nbegin\r\n Result := True;\r\n while Result and (AOwner <> nil) do\r\n begin\r\n Result := AOwner.FindComponent(AName) = nil;\r\n AOwner := AOwner.Owner;\r\n end;\r\nend;\r\n\r\nfunction DesignUniqueName(AOwner: TComponent; const AClassName: string): string;\r\nvar\r\n Base: string;\r\n I: Integer;\r\nbegin\r\n Base := Copy(AClassName, 2, MAXINT);\r\n I := 0;\r\n repeat\r\n Inc(I);\r\n Result := Base + IntToStr(I);\r\n until DesignNameIsUnique(AOwner, Result);\r\nend;\r\n\r\nprocedure DesignPaintRubberbandRect(AContainer: TWinControl; ARect: TRect; APenStyle: TPenStyle);\r\nvar\r\n DesktopWindow: HWND;\r\n DC: HDC;\r\n C: TCanvas;\r\nbegin\r\n if AContainer = nil then\r\n DesktopWindow := GetDesktopWindow\r\n else\r\n begin\r\n DesktopWindow := AContainer.Handle;\r\n ARect.TopLeft := AContainer.ScreenToClient(ARect.TopLeft);\r\n ARect.BottomRight := AContainer.ScreenToClient(ARect.BottomRight);\r\n end;\r\n DC := GetDCEx(DesktopWindow, 0, DCX_CACHE or DCX_LOCKWINDOWUPDATE);\r\n try\r\n C := TCanvas.Create;\r\n try\r\n C.Handle := DC;\r\n C.Pen.Style := APenStyle;\r\n C.Pen.Color := clWhite;\r\n C.Pen.Mode := pmXor;\r\n C.Brush.Style := bsClear;\r\n C.Rectangle(ARect);\r\n finally\r\n C.Free;\r\n end;\r\n finally\r\n ReleaseDC(DesktopWindow, DC);\r\n end;\r\nend;\r\n\r\nprocedure DesignPaintRules(ACanvas: TCanvas; const ARect: TRect;\r\n ADivPixels: Integer; ASubDivs: Boolean);\r\nvar\r\n d, d2, w, h, I: Integer;\r\nbegin\r\n d := ADivPixels;\r\n d2 := d div 2;\r\n w := (ARect.Right - ARect.Left + d - 1) div d;\r\n h := (ARect.Bottom - ARect.Top + d - 1) div d;\r\n with ACanvas do\r\n begin\r\n Pen.Style := psDot;\r\n for I := 0 to w do\r\n begin\r\n Pen.Color := $DDDDDD;\r\n MoveTo(I * d, ARect.Top);\r\n LineTo(I * d, ARect.Bottom);\r\n if ASubDivs then\r\n begin\r\n Pen.Color := $F0F0F0;\r\n MoveTo(I * d + d2, ARect.Top);\r\n LineTo(I * d + d2, ARect.Bottom);\r\n end;\r\n end;\r\n for I := 0 to h do\r\n begin\r\n Pen.Color := $DDDDDD;\r\n MoveTo(ARect.Left, I * d);\r\n LineTo(ARect.Right, I * d);\r\n if ASubDivs then\r\n begin\r\n Pen.Color := $F0F0F0;\r\n MoveTo(ARect.Left, I * d + d2);\r\n LineTo(ARect.Right, I * d + d2);\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure DesignPaintGrid(ACanvas: TCanvas; const ARect: TRect;\r\n ABackColor, AGridColor: TColor; ADivPixels: Integer);\r\nvar\r\n b: TBitmap;\r\n I: Integer;\r\nbegin\r\n b := TBitmap.Create;\r\n try\r\n b.Height := DesignRectHeight(ARect);\r\n b.Width := ADivPixels;\r\n b.Canvas.Brush.Color := ABackColor;\r\n b.Canvas.FillRect(Rect(0, 0, b.Width, b.Height));\r\n\r\n I := 0;\r\n repeat\r\n b.Canvas.Pixels[0, I] := AGridColor;\r\n Inc(I, ADivPixels);\r\n until (I >= b.Height);\r\n\r\n I := ARect.Left;\r\n repeat\r\n ACanvas.Draw(I, ARect.Top, b);\r\n Inc(I, ADivPixels);\r\n until I >= ARect.Right;\r\n finally\r\n b.Free;\r\n end;\r\nend;\r\n\r\nprocedure DesignSaveComponentToStream(AComp: TComponent; AStream: TStream);\r\nvar\r\n MS: TMemoryStream;\r\nbegin\r\n MS := TMemoryStream.Create;\r\n try\r\n MS.WriteComponent(AComp);\r\n MS.Position := 0;\r\n ObjectBinaryToText(MS, AStream);\r\n finally\r\n MS.Free;\r\n end;\r\nend;\r\n\r\ntype\r\n TAccessComponent = class(TComponent);\r\n\r\nfunction DesignLoadComponentFromStream(AComp: TComponent; AStream: TStream;\r\n AOnError: TReaderError): TComponent;\r\nvar\r\n MemStream: TMemoryStream;\r\n CompDesigning: Boolean;\r\nbegin\r\n MemStream := TMemoryStream.Create;\r\n try\r\n ObjectTextToBinary(AStream, MemStream);\r\n MemStream.Position := 0;\r\n with TReader.Create(MemStream, 4096) do\r\n try\r\n OnError := AOnError;\r\n { We have to set the container into design mode so all loaded components\r\n are in design mode. }\r\n CompDesigning := csDesigning in AComp.ComponentState;\r\n TAccessComponent(AComp).SetDesigning(True, False);\r\n try\r\n Result := ReadRootComponent(AComp);\r\n finally\r\n if not CompDesigning then\r\n TAccessComponent(AComp).SetDesigning(CompDesigning, False);\r\n end;\r\n finally\r\n Free;\r\n end;\r\n finally\r\n MemStream.Free;\r\n end;\r\nend;\r\n\r\nprocedure DesignSaveComponentToFile(AComp: TComponent; const AFileName: string);\r\nvar\r\n FS: TFileStream;\r\nbegin\r\n FS := TFileStream.Create(AFileName, fmCreate);\r\n try\r\n DesignSaveComponentToStream(AComp, FS);\r\n finally\r\n FS.Free;\r\n end;\r\nend;\r\n\r\nprocedure DesignLoadComponentFromFile(AComp: TComponent;\r\n const AFileName: string; AOnError: TReaderError);\r\nvar\r\n FS: TFileStream;\r\nbegin\r\n FS := TFileStream.Create(AFileName, fmOpenRead);\r\n try\r\n DesignLoadComponentFromStream(AComp, FS, AOnError);\r\n finally\r\n FS.Free;\r\n end;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvDesktopAlert.pas", "content": " {-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvDesktopAlert.PAS, released on 2004-03-23.\r\n\r\nThe Initial Developer of the Original Code is Peter Thornqvist \r\nPortions created by Peter Thornqvist are Copyright (C) 2004 Peter Thornqvist.\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\nHans-Eric Grnlund (stack logic)\r\nOlivier Sannier (animation styles logic)\r\nMiha Vrhovnik (custom form display logic)\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvDesktopAlert.pas 13352 2012-06-14 09:21:26Z obones $\r\n\r\nunit JvDesktopAlert;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, Classes, Controls, Graphics, Forms, ExtCtrls, Menus, ImgList,\r\n JvComponentBase, JvBaseDlg, JvDesktopAlertForm;\r\n\r\nconst\r\n JvDefaultFrameColor = TColor($00943000);\r\n JvDefaultWindowFromColor = TColor($00FFE7CE);\r\n JvDefaultWindowToColor = TColor($00E7A67B);\r\n JvDefaultCaptionFromColor = TColor($00D68652);\r\n JvDefaultCaptionToColor = TColor($00944110);\r\n\r\ntype\r\n // The possible animation styles as an enumeration\r\n TJvAlertStyle = (asFade, asCenterGrow);\r\n\r\n // The different status a style handler can have\r\n TJvStyleHandlerStatus = (hsIdle, hsStartAnim, hsEndAnim, hsDisplay);\r\n\r\n TJvCustomDesktopAlertStyleHandler = class;\r\n\r\n TJvDesktopAlertStack = class;\r\n TJvDesktopAlert = class;\r\n TJvDesktopAlertChangePersistent = class(TPersistent)\r\n private\r\n FOnChange: TNotifyEvent;\r\n protected\r\n procedure Change;\r\n public\r\n property OnChange: TNotifyEvent read FOnChange write FOnChange;\r\n end;\r\n\r\n TJvDesktopAlertColors = class(TJvDesktopAlertChangePersistent)\r\n private\r\n FWindowFrom: TColor;\r\n FCaptionTo: TColor;\r\n FWindowTo: TColor;\r\n FFrame: TColor;\r\n FCaptionFrom: TColor;\r\n procedure SetCaptionFrom(const Value: TColor);\r\n procedure SetCaptionTo(const Value: TColor);\r\n procedure SetFrame(const Value: TColor);\r\n procedure SetWindowFrom(const Value: TColor);\r\n procedure SetWindowTo(const Value: TColor);\r\n public\r\n constructor Create;\r\n procedure Assign(Source: TPersistent); override;\r\n published\r\n property Frame: TColor read FFrame write SetFrame default JvDefaultFrameColor;\r\n property WindowFrom: TColor read FWindowFrom write SetWindowFrom default JvDefaultWindowFromColor;\r\n property WindowTo: TColor read FWindowTo write SetWindowTo default JvDefaultWindowToColor;\r\n property CaptionFrom: TColor read FCaptionFrom write SetCaptionFrom default JvDefaultCaptionFromColor;\r\n property CaptionTo: TColor read FCaptionTo write SetCaptionTo default JvDefaultCaptionToColor;\r\n end;\r\n\r\n TJvDesktopAlertPosition =\r\n (dapTopLeft, dapTopRight, dapBottomLeft, dapBottomRight, dapCustom,\r\n dapDesktopCenter, dapMainFormCenter, dapOwnerFormCenter, dapActiveFormCenter,\r\n dapMainFormTopLeft, dapMainFormTopRight, dapMainFormBottomLeft, dapMainFormBottomRight,\r\n dapOwnerFormTopLeft, dapOwnerFormTopRight, dapOwnerFormBottomLeft, dapOwnerFormBottomRight,\r\n dapActiveFormTopLeft, dapActiveFormTopRight, dapActiveFormBottomLeft, dapActiveFormBottomRight);\r\n\r\n TJvDesktopAlertLocation = class(TJvDesktopAlertChangePersistent)\r\n private\r\n FTop: Integer;\r\n FLeft: Integer;\r\n FPosition: TJvDesktopAlertPosition;\r\n FAlwaysResetPosition: Boolean;\r\n FHeight: Integer;\r\n FWidth: Integer;\r\n procedure SetTop(const Value: Integer);\r\n procedure SetLeft(const Value: Integer);\r\n procedure SetPosition(const Value: TJvDesktopAlertPosition);\r\n procedure SetHeight(const Value: Integer);\r\n procedure SetWidth(const Value: Integer);\r\n public\r\n constructor Create;\r\n published\r\n property Position: TJvDesktopAlertPosition read FPosition write SetPosition default dapBottomRight;\r\n property Top: Integer read FTop write SetTop;\r\n property Left: Integer read FLeft write SetLeft;\r\n property Width: Integer read FWidth write SetWidth;\r\n property Height: Integer read FHeight write SetHeight;\r\n property AlwaysResetPosition: Boolean read FAlwaysResetPosition write FAlwaysResetPosition default True;\r\n end;\r\n\r\n TJvDesktopAlertButtonItem = class(TCollectionItem)\r\n private\r\n FImageIndex: Integer;\r\n FOnClick: TNotifyEvent;\r\n FTag: Integer;\r\n public\r\n procedure Assign(Source: TPersistent); override;\r\n published\r\n property ImageIndex: Integer read FImageIndex write FImageIndex;\r\n property Tag: Integer read FTag write FTag;\r\n property OnClick: TNotifyEvent read FOnClick write FOnClick;\r\n end;\r\n\r\n TJvDesktopAlertButtons = class(TOwnedCollection)\r\n private\r\n function GetItem(Index: Integer): TJvDesktopAlertButtonItem;\r\n procedure SetItem(Index: Integer; const Value: TJvDesktopAlertButtonItem);\r\n public\r\n constructor Create(AOwner: TPersistent);\r\n function Add: TJvDesktopAlertButtonItem;\r\n property Items[Index: Integer]: TJvDesktopAlertButtonItem read GetItem write SetItem; default;\r\n procedure Assign(Source: TPersistent); override;\r\n end;\r\n\r\n TJvDesktopAlertOption = (daoCanClick, daoCanMove, daoCanMoveAnywhere, daoCanClose);\r\n TJvDesktopAlertOptions = set of TJvDesktopAlertOption;\r\n\r\n TJvCustomDesktopAlert = class(TJvCommonDialog)\r\n private\r\n FStacker: TJvDesktopAlertStack;\r\n FColors: TJvDesktopAlertColors;\r\n FLocation: TJvDesktopAlertLocation;\r\n FOptions: TJvDesktopAlertOptions;\r\n FAutoFocus: Boolean;\r\n FAutoFree: Boolean;\r\n FAlertStyle: TJvAlertStyle;\r\n FStyleHandler: TJvCustomDesktopAlertStyleHandler;\r\n\r\n function GetStacker: TJvDesktopAlertStack;\r\n procedure SetColors(const Value: TJvDesktopAlertColors);\r\n function GetAlertStack: TJvDesktopAlertStack;\r\n procedure SetAlertStack(const Value: TJvDesktopAlertStack);\r\n procedure SetLocation(const Value: TJvDesktopAlertLocation);\r\n procedure DoLocationChange(Sender: TObject);\r\n procedure SetOptions(const Value: TJvDesktopAlertOptions);\r\n procedure SetStyleHandler(const Value: TJvCustomDesktopAlertStyleHandler);\r\n procedure SetAlertStyle(const Value: TJvAlertStyle);\r\n protected\r\n FDesktopForm: TJvCustomFormDesktopAlert;\r\n procedure Notification(AComponent: TComponent; Operation: TOperation); override;\r\n procedure InternalOnMove(Sender: TObject);\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n function Showing: Boolean;\r\n procedure Close(Immediate: Boolean);\r\n function Execute(ParentWnd: HWND): Boolean; overload; override;\r\n property StyleHandler: TJvCustomDesktopAlertStyleHandler read FStyleHandler write SetStyleHandler;\r\n published\r\n property AlertStack: TJvDesktopAlertStack read GetAlertStack write SetAlertStack;\r\n property AlertStyle: TJvAlertStyle read FAlertStyle write SetAlertStyle default asFade;\r\n property AutoFocus: Boolean read FAutoFocus write FAutoFocus default False;\r\n property AutoFree: Boolean read FAutoFree write FAutoFree default False;\r\n\r\n property Options: TJvDesktopAlertOptions read FOptions write SetOptions default [daoCanClick..daoCanClose];\r\n property Colors: TJvDesktopAlertColors read FColors write SetColors;\r\n property Location: TJvDesktopAlertLocation read FLocation write SetLocation;\r\n\r\n // This property is equivalent to StyleHandler, it is just renamed to look better in the inspector\r\n property StyleOptions: TJvCustomDesktopAlertStyleHandler read FStyleHandler write SetStyleHandler;\r\n end;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvDesktopAlert = class(TJvCustomDesktopAlert)\r\n private\r\n FImages: TCustomImageList;\r\n FButtons: TJvDesktopAlertButtons;\r\n FOnClose: TNotifyEvent;\r\n FOnMouseEnter: TNotifyEvent;\r\n FOnMessageClick: TNotifyEvent;\r\n FOnShow: TNotifyEvent;\r\n FOnMouseLeave: TNotifyEvent;\r\n FData: TObject;\r\n FOnShown: TNotifyEvent;\r\n FOnShowing: TNotifyEvent;\r\n procedure SetButtons(const Value: TJvDesktopAlertButtons);\r\n procedure SetDropDownMenu(const Value: TPopupMenu);\r\n procedure SetFont(const Value: TFont);\r\n procedure SetHeaderFont(const Value: TFont);\r\n procedure SetImage(const Value: TPicture);\r\n procedure SetImages(const Value: TCustomImageList);\r\n procedure SetPopupMenu(const Value: TPopupMenu);\r\n procedure InternalOnShowing(Sender: TObject);\r\n procedure InternalOnShow(Sender: TObject);\r\n procedure InternalOnShown(Sender: TObject);\r\n procedure InternalOnClose(Sender: TObject; var Action: TCloseAction);\r\n procedure InternalMouseEnter(Sender: TObject);\r\n procedure InternalMouseLeave(Sender: TObject);\r\n procedure InternalMessageClick(Sender: TObject);\r\n function GetFont: TFont;\r\n function GetHeaderFont: TFont;\r\n function GetImage: TPicture;\r\n function GetDropDownMenu: TPopupMenu;\r\n function GetHeaderText: string;\r\n function GetMessageText: string;\r\n function GetPopupMenu: TPopupMenu;\r\n procedure SetHeaderText(const Value: string);\r\n procedure SetMessageText(const Value: string);\r\n function GetParentFont: Boolean;\r\n function GetShowHint: Boolean;\r\n function GetHint: string;\r\n procedure SetHint(const Value: string);\r\n procedure SetParentFont(const Value: Boolean);\r\n procedure SetShowHint(const Value: Boolean);\r\n function GetCloseButtonClick: TNotifyEvent;\r\n procedure SetCloseButtonClick(const Value: TNotifyEvent);\r\n function GetBiDiMode: TBidiMode;\r\n procedure SetBiDiMode(const Value: TBidiMode);\r\n function GetDesktopForm: TJvFormDesktopAlert;\r\n property DesktopForm: TJvFormDesktopAlert read GetDesktopForm;\r\n protected\r\n FFormButtons: array of TControl;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n function Execute(ParentWnd: HWND): Boolean; overload; override;\r\n property Form: TJvCustomFormDesktopAlert read FDesktopForm;\r\n property Data: TObject read FData write FData;\r\n published\r\n property AlertStack;\r\n property AlertStyle;\r\n property AutoFocus;\r\n property AutoFree;\r\n\r\n property Options;\r\n property Colors;\r\n property Location;\r\n\r\n property StyleOptions;\r\n\r\n property BiDiMode: TBidiMode read GetBiDiMode write SetBiDiMode default bdLeftToRight;\r\n property HeaderText: string read GetHeaderText write SetHeaderText;\r\n property MessageText: string read GetMessageText write SetMessageText;\r\n\r\n property HeaderFont: TFont read GetHeaderFont write SetHeaderFont;\r\n property Hint: string read GetHint write SetHint;\r\n property ShowHint: Boolean read GetShowHint write SetShowHint;\r\n property Font: TFont read GetFont write SetFont;\r\n property ParentFont: Boolean read GetParentFont write SetParentFont;\r\n property Buttons: TJvDesktopAlertButtons read FButtons write SetButtons;\r\n property Image: TPicture read GetImage write SetImage;\r\n property Images: TCustomImageList read FImages write SetImages;\r\n property DropDownMenu: TPopupMenu read GetDropDownMenu write SetDropDownMenu;\r\n property PopupMenu: TPopupMenu read GetPopupMenu write SetPopupMenu;\r\n\r\n property OnShowing: TNotifyEvent read FOnShowing write FOnShowing;\r\n property OnShow: TNotifyEvent read FOnShow write FOnShow;\r\n property OnShown: TNotifyEvent read FOnShown write FOnShown;\r\n property OnCloseButtonClick: TNotifyEvent read GetCloseButtonClick write SetCloseButtonClick;\r\n property OnClose: TNotifyEvent read FOnClose write FOnClose;\r\n property OnMouseEnter: TNotifyEvent read FOnMouseEnter write FOnMouseEnter;\r\n property OnMouseLeave: TNotifyEvent read FOnMouseLeave write FOnMouseLeave;\r\n property OnMessageClick: TNotifyEvent read FOnMessageClick write FOnMessageClick;\r\n end;\r\n\r\n TJvDesktopAlertForm = class(TJvCustomDesktopAlert)\r\n private\r\n procedure SetForm(const Value: TJvCustomFormDesktopAlert);\r\n protected\r\n public\r\n property Form: TJvCustomFormDesktopAlert read FDesktopForm write SetForm;\r\n function Execute(ParentWnd: HWND): Boolean; overload; override;\r\n published\r\n property AlertStack;\r\n property AlertStyle;\r\n property AutoFocus;\r\n property AutoFree;\r\n\r\n property Options;\r\n property Colors;\r\n property Location;\r\n\r\n property StyleOptions;\r\n end;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvDesktopAlertStack = class(TJvComponent)\r\n private\r\n FItems: TList;\r\n FPosition: TJvDesktopAlertPosition;\r\n function GetCount: Integer;\r\n function GetItems(Index: Integer): TJvCustomFormDesktopAlert;\r\n procedure SetPosition(const Value: TJvDesktopAlertPosition);\r\n protected\r\n procedure UpdatePositions; virtual;\r\n public\r\n procedure Add(AForm: TCustomForm); virtual;\r\n procedure Remove(AForm: TCustomForm); virtual;\r\n\r\n property Items[Index: Integer]: TJvCustomFormDesktopAlert read GetItems;\r\n property Count: Integer read GetCount;\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n published\r\n // all forms must have the same position property\r\n property Position: TJvDesktopAlertPosition read FPosition write SetPosition default dapBottomRight;\r\n end;\r\n\r\n // Common ancestor of all the alert styles for a TJvCustomFormDesktopAlert\r\n TJvCustomDesktopAlertStyleHandler = class(TPersistent)\r\n private\r\n FAnimTimer: TTimer;\r\n FOwnerForm: TJvCustomFormDesktopAlert;\r\n FStartSteps: Cardinal;\r\n FEndSteps: Cardinal;\r\n FEndInterval: Cardinal;\r\n FStartInterval: Cardinal;\r\n FDisplayDuration: Cardinal;\r\n FCurrentStep: Cardinal;\r\n FStatus: TJvStyleHandlerStatus;\r\n function GetActive: Boolean;\r\n protected\r\n procedure SetEndInterval(const Value: Cardinal); virtual;\r\n procedure SetEndSteps(const Value: Cardinal); virtual;\r\n procedure SetStartInterval(const Value: Cardinal); virtual;\r\n procedure SetStartSteps(const Value: Cardinal); virtual;\r\n // This procedure will be called for each step of the starting animation\r\n // It will be called StartSteps time, every StartInterval milliseconds\r\n // The implementation here only ensures that once the number of steps\r\n // is reached, the timer is stopped\r\n procedure StartAnimTimer(Sender: TObject); virtual;\r\n // This procedure will be called for each step of the ending animation\r\n // It will be called EndSteps time, every EndInterval milliseconds\r\n // The implementation here only ensures that once the number of steps\r\n // is reached, the timer is stopped and then calls DoDisplay\r\n procedure EndAnimTimer(Sender: TObject); virtual;\r\n // This procedure will be called once after DisplayDuration\r\n // (if it is > 0) when the start animation is finished.\r\n procedure DisplayTimer(Sender: TObject); virtual;\r\n // This procedure is called just before the start animation timer\r\n // is enabled. Use it to setup initial values required for the\r\n // animation\r\n // As implemented in this base class, the owner form is shown\r\n procedure PrepareStartAnimation; virtual;\r\n // This procedure is called just after the start animation has finished\r\n // Use it to set the final values of the animation\r\n procedure FinalizeStartAnimation; virtual; abstract;\r\n // This procedure is called just before the end animation timer\r\n // is enabled. Use it to setup initial values required for the\r\n // animation\r\n procedure PrepareEndAnimation; virtual; abstract;\r\n // This procedure is called just after the end animation has finished\r\n // Use it to set the final values of the animation\r\n // As implemented in this base class, this closes the owner form.\r\n // Note: It is required to close the form or the end animation\r\n // will keep being repeated\r\n procedure FinalizeEndAnimation; virtual;\r\n // The timer used for all animations and waits\r\n property AnimTimer: TTimer read FAnimTimer;\r\n public\r\n constructor Create(OwnerForm: TJvCustomFormDesktopAlert); virtual;\r\n destructor Destroy; override;\r\n // Sets up the timer to call StartAnimTimer on the correct interval\r\n // then show the owner form.\r\n // If StartSteps is not greater than 0, the animation will not start\r\n // and the form will not be shown.\r\n procedure DoStartAnimation; virtual;\r\n // Sets up the timer to call EndAnimTimer on the correct interval\r\n // If EndSteps is not greater than 0, the animation will not start\r\n procedure DoEndAnimation; virtual;\r\n // Sets up the timer to call DisplayTimer after the correct delay\r\n // If DisplayDuration is equal to 0, the timer is not enabled and\r\n // DisplayTimer will never be called\r\n procedure DoDisplay; virtual;\r\n // Aborts the current animation, if any. Will call the proper Finalize\r\n // function as applicable. The middle wait is NOT aborted by a call\r\n // to this function\r\n procedure AbortAnimation; virtual;\r\n // The owner form, the form to which the style is associated.\r\n // This value MUST NOT be nil when any of the DoXXXX function is called\r\n property OwnerForm: TJvCustomFormDesktopAlert read FOwnerForm write FOwnerForm;\r\n // The current step in the animation (starts at 0, use Active to know\r\n // if an animation or wait is in progress).\r\n property CurrentStep: Cardinal read FCurrentStep;\r\n // Returns AnimTimer.Enabled\r\n property Active: Boolean read GetActive;\r\n // Returns the status of the handler\r\n property Status: TJvStyleHandlerStatus read FStatus;\r\n published\r\n // The duration between each step of the start animation\r\n property StartInterval: Cardinal read FStartInterval write SetStartInterval;\r\n // The number of steps in the start animation\r\n property StartSteps: Cardinal read FStartSteps write SetStartSteps;\r\n // The duration between each step of the end animation\r\n property EndInterval: Cardinal read FEndInterval write SetEndInterval;\r\n // The number of steps in the end animation\r\n property EndSteps: Cardinal read FEndSteps write SetEndSteps;\r\n // The duration of the middle wait (between the end of the start\r\n // animation and the beginning of the end animation)\r\n property DisplayDuration: Cardinal read FDisplayDuration write FDisplayDuration;\r\n end;\r\n\r\n // This style will make the form fade in and fade out.\r\n // NOTE: This is only supported by Delphi or C++ Builder 6 and above\r\n // NOTE: Even if the compiler supports it, this only works if the\r\n // operating system is Windows 2000 or Windows XP\r\n TJvFadeAlertStyleHandler = class (TJvCustomDesktopAlertStyleHandler)\r\n private\r\n FMinAlphaBlendValue: Byte;\r\n FCurrentAlphaBlendValue: Byte;\r\n FMaxAlphaBlendValue: Byte;\r\n procedure SetMinAlphaBlendValue(const Value: Byte);\r\n procedure SetMaxAlphaBlendValue(const Value: Byte);\r\n protected\r\n procedure StartAnimTimer(Sender: TObject); override;\r\n procedure EndAnimTimer(Sender: TObject); override;\r\n // Applies the current alpha blend value to the owner form\r\n procedure DoAlphaBlend(Value: Byte);\r\n procedure PrepareStartAnimation; override;\r\n procedure FinalizeStartAnimation; override;\r\n procedure PrepareEndAnimation; override;\r\n procedure FinalizeEndAnimation; override;\r\n public\r\n constructor Create(OwnerForm: TJvCustomFormDesktopAlert); override;\r\n procedure AbortAnimation; override;\r\n published\r\n property MinAlphaBlendValue: Byte read FMinAlphaBlendValue write SetMinAlphaBlendValue default 0;\r\n property MaxAlphaBlendValue: Byte read FMaxAlphaBlendValue write SetMaxAlphaBlendValue default 255;\r\n property CurrentAlphaBlendValue: Byte read FCurrentAlphaBlendValue;\r\n property StartInterval default 25;\r\n property StartSteps default 10;\r\n property EndInterval default 50;\r\n property EndSteps default 10;\r\n property DisplayDuration default 1400;\r\n end;\r\n\r\n TJvCenterGrowAlertStyleHandler = class(TJvCustomDesktopAlertStyleHandler)\r\n private\r\n FMaxGrowthPercentage: Double;\r\n FMinGrowthPercentage: Double;\r\n procedure SetMaxGrowthPercentage(const Value: Double);\r\n procedure SetMinGrowthPercentage(const Value: Double);\r\n protected\r\n procedure StartAnimTimer(Sender: TObject); override;\r\n procedure EndAnimTimer(Sender: TObject); override;\r\n // Applies the current region growth percentage value to the owner form\r\n procedure DoGrowRegion(Percentage: Double);\r\n procedure PrepareStartAnimation; override;\r\n procedure FinalizeStartAnimation; override;\r\n procedure PrepareEndAnimation; override;\r\n procedure FinalizeEndAnimation; override;\r\n public\r\n constructor Create(OwnerForm: TJvCustomFormDesktopAlert); override;\r\n procedure AbortAnimation; override;\r\n published\r\n property StartInterval default 25;\r\n property StartSteps default 10;\r\n property EndInterval default 50;\r\n property EndSteps default 10;\r\n property DisplayDuration default 1400;\r\n property MinGrowthPercentage: Double read FMinGrowthPercentage write SetMinGrowthPercentage;\r\n property MaxGrowthPercentage: Double read FMaxGrowthPercentage write SetMaxGrowthPercentage;\r\n end;\r\n\r\nfunction CreateHandlerForStyle(Style: TJvAlertStyle; OwnerForm: TJvCustomFormDesktopAlert): TJvCustomDesktopAlertStyleHandler;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvDesktopAlert.pas $';\r\n Revision: '$Revision: 13352 $';\r\n Date: '$Date: 2012-06-14 11:21:26 +0200 (jeu. 14 juin 2012) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n SysUtils, Messages,\r\n JvJVCLUtils, JvTypes;\r\n\r\nvar\r\n GStacker: TJvDesktopAlertStack = nil;\r\n\r\nfunction CreateHandlerForStyle(Style: TJvAlertStyle; OwnerForm: TJvCustomFormDesktopAlert): TJvCustomDesktopAlertStyleHandler;\r\nbegin\r\n case Style of\r\n asFade:\r\n Result := TJvFadeAlertStyleHandler.Create(OwnerForm);\r\n asCenterGrow:\r\n Result := TJvCenterGrowAlertStyleHandler.Create(OwnerForm);\r\n else\r\n raise Exception.Create('');\r\n end;\r\nend;\r\n\r\nfunction GlobalStacker: TJvDesktopAlertStack;\r\nbegin\r\n if GStacker = nil then\r\n GStacker := TJvDesktopAlertStack.Create(nil);\r\n Result := GStacker;\r\nend;\r\n\r\n//=== { TJvDesktopAlertChangePersistent } ====================================\r\n\r\nprocedure TJvDesktopAlertChangePersistent.Change;\r\nbegin\r\n if Assigned(FOnChange) then\r\n FOnChange(Self);\r\nend;\r\n\r\n//=== { TJvDesktopAlertColors } ==============================================\r\n\r\nconstructor TJvDesktopAlertColors.Create;\r\nbegin\r\n inherited Create;\r\n FFrame := JvDefaultFrameColor;\r\n FWindowFrom := JvDefaultWindowFromColor;\r\n FWindowTo := JvDefaultWindowToColor;\r\n FCaptionFrom := JvDefaultCaptionFromColor;\r\n FCaptionTo := JvDefaultCaptionToColor;\r\nend;\r\n\r\nprocedure TJvDesktopAlertColors.Assign(Source: TPersistent);\r\nbegin\r\n if Source is TJvDesktopAlertColors then\r\n begin\r\n if Source <> Self then\r\n begin\r\n FFrame := TJvDesktopAlertColors(Source).Frame;\r\n FWindowFrom := TJvDesktopAlertColors(Source).WindowFrom;\r\n FWindowTo := TJvDesktopAlertColors(Source).WindowTo;\r\n FCaptionFrom := TJvDesktopAlertColors(Source).CaptionFrom;\r\n FCaptionTo := TJvDesktopAlertColors(Source).CaptionTo;\r\n Change;\r\n end;\r\n end\r\n else\r\n inherited Assign(Source);\r\nend;\r\n\r\nprocedure TJvDesktopAlertColors.SetCaptionFrom(const Value: TColor);\r\nbegin\r\n if FCaptionFrom <> Value then\r\n begin\r\n FCaptionFrom := Value;\r\n Change;\r\n end;\r\nend;\r\n\r\nprocedure TJvDesktopAlertColors.SetCaptionTo(const Value: TColor);\r\nbegin\r\n if FCaptionTo <> Value then\r\n begin\r\n FCaptionTo := Value;\r\n Change;\r\n end;\r\nend;\r\n\r\nprocedure TJvDesktopAlertColors.SetFrame(const Value: TColor);\r\nbegin\r\n if FFrame <> Value then\r\n begin\r\n FFrame := Value;\r\n Change;\r\n end;\r\nend;\r\n\r\nprocedure TJvDesktopAlertColors.SetWindowFrom(const Value: TColor);\r\nbegin\r\n if FWindowFrom <> Value then\r\n begin\r\n FWindowFrom := Value;\r\n Change;\r\n end;\r\nend;\r\n\r\nprocedure TJvDesktopAlertColors.SetWindowTo(const Value: TColor);\r\nbegin\r\n if FWindowTo <> Value then\r\n begin\r\n FWindowTo := Value;\r\n Change;\r\n end;\r\nend;\r\n\r\n//=== { TJvDesktopAlertLocation } ============================================\r\n\r\nconstructor TJvDesktopAlertLocation.Create;\r\nbegin\r\n inherited Create;\r\n FPosition := dapBottomRight;\r\n FAlwaysResetPosition := True;\r\nend;\r\n\r\nprocedure TJvDesktopAlertLocation.SetHeight(const Value: Integer);\r\nbegin\r\n if FHeight <> Value then\r\n begin\r\n FHeight := Value;\r\n Change;\r\n end;\r\nend;\r\n\r\nprocedure TJvDesktopAlertLocation.SetLeft(const Value: Integer);\r\nbegin\r\n if FLeft <> Value then\r\n begin\r\n FLeft := Value;\r\n Change;\r\n end;\r\nend;\r\n\r\nprocedure TJvDesktopAlertLocation.SetPosition(const Value: TJvDesktopAlertPosition);\r\nbegin\r\n// if FPosition <> Value then\r\n begin\r\n FPosition := Value;\r\n Change;\r\n end;\r\nend;\r\n\r\nprocedure TJvDesktopAlertLocation.SetTop(const Value: Integer);\r\nbegin\r\n if FTop <> Value then\r\n begin\r\n FTop := Value;\r\n Change;\r\n end;\r\nend;\r\n\r\nprocedure TJvDesktopAlertLocation.SetWidth(const Value: Integer);\r\nbegin\r\n if FWidth <> Value then\r\n begin\r\n FWidth := Value;\r\n Change;\r\n end;\r\nend;\r\n\r\n//=== { TJvDesktopAlertButtonItem } ==========================================\r\n\r\nprocedure TJvDesktopAlertButtonItem.Assign(Source: TPersistent);\r\nbegin\r\n if Source is TJvDesktopAlertButtonItem then\r\n begin\r\n if Source <> Self then\r\n begin\r\n ImageIndex := TJvDesktopAlertButtonItem(Source).ImageIndex;\r\n OnClick := TJvDesktopAlertButtonItem(Source).OnClick;\r\n Tag := TJvDesktopAlertButtonItem(Source).Tag;\r\n end;\r\n end\r\n else\r\n inherited Assign(Source);\r\nend;\r\n\r\n//=== { TJvDesktopAlertButtons } =============================================\r\n\r\nconstructor TJvDesktopAlertButtons.Create(AOwner: TPersistent);\r\nbegin\r\n inherited Create(AOwner, TJvDesktopAlertButtonItem);\r\nend;\r\n\r\nfunction TJvDesktopAlertButtons.Add: TJvDesktopAlertButtonItem;\r\nbegin\r\n Result := TJvDesktopAlertButtonItem(inherited Add);\r\nend;\r\n\r\nprocedure TJvDesktopAlertButtons.Assign(Source: TPersistent);\r\nvar\r\n I: Integer;\r\nbegin\r\n if Source is TJvDesktopAlertButtons then\r\n begin\r\n if Source <> Self then\r\n begin\r\n Clear;\r\n for I := 0 to TJvDesktopAlertButtons(Source).Count - 1 do\r\n Add.Assign(TJvDesktopAlertButtons(Source)[I]);\r\n end;\r\n end\r\n else\r\n inherited Assign(Source);\r\nend;\r\n\r\nfunction TJvDesktopAlertButtons.GetItem(Index: Integer): TJvDesktopAlertButtonItem;\r\nbegin\r\n Result := TJvDesktopAlertButtonItem(inherited Items[Index]);\r\nend;\r\n\r\nprocedure TJvDesktopAlertButtons.SetItem(Index: Integer; const Value: TJvDesktopAlertButtonItem);\r\nbegin\r\n inherited Items[Index] := Value;\r\nend;\r\n\r\n\r\n//=== { TJvDesktopAlert } ====================================================\r\n\r\nconstructor TJvDesktopAlert.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FButtons := TJvDesktopAlertButtons.Create(Self);\r\n FDesktopForm := TJvFormDesktopAlert.Create(Self);\r\n AlertStyle := asFade;\r\n FOptions := [daoCanClick..daoCanClose];\r\nend;\r\n\r\ndestructor TJvDesktopAlert.Destroy;\r\nbegin\r\n FreeAndNil(FButtons);\r\n\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJvDesktopAlert.Execute(ParentWnd: HWND): Boolean;\r\nvar\r\n I, X, Y: Integer;\r\n FActiveWindow, FActiveFocus: HWND;\r\nbegin\r\n inherited Execute(ParentWnd);\r\n\r\n DesktopForm.OnShowing := InternalOnShowing;\r\n DesktopForm.OnShow := InternalOnShow;\r\n DesktopForm.OnShown := InternalOnShown;\r\n DesktopForm.OnClose := InternalOnClose;\r\n DesktopForm.OnMouseEnter := InternalMouseEnter;\r\n DesktopForm.OnMouseLeave := InternalMouseLeave;\r\n DesktopForm.OnUserMove := InternalOnMove;\r\n DesktopForm.lblText.OnClick := InternalMessageClick;\r\n DesktopForm.Moveable := (daoCanMove in Options);\r\n DesktopForm.MoveAnywhere := (daoCanMoveAnywhere in Options);\r\n DesktopForm.Closeable := (daoCanClose in Options);\r\n DesktopForm.ClickableMessage := daoCanClick in Options;\r\n if not Assigned(DesktopForm.tbClose.OnClick) then\r\n DesktopForm.tbClose.OnClick := DesktopForm.acCloseExecute;\r\n\r\n DesktopForm.tbDropDown.DropDownMenu := DropDownMenu;\r\n DesktopForm.imIcon.Picture := Image;\r\n\r\n DesktopForm.Font := Font;\r\n DesktopForm.lblHeader.Caption := HeaderText;\r\n DesktopForm.lblHeader.Font := HeaderFont;\r\n DesktopForm.lblText.Caption := MessageText;\r\n\r\n for I := 0 to Length(FFormButtons) - 1 do\r\n FFormButtons[I].Free;\r\n SetLength(FFormButtons, Buttons.Count);\r\n X := 2;\r\n Y := DesktopForm.Height - 23;\r\n for I := 0 to Length(FFormButtons) - 1 do\r\n begin\r\n FFormButtons[I] := TJvDesktopAlertButton.Create(DesktopForm);\r\n with TJvDesktopAlertButton(FFormButtons[I]) do\r\n begin\r\n SetBounds(X, Y, 21, 21);\r\n ToolType := abtImage;\r\n Images := Self.Images;\r\n ImageIndex := Buttons[I].ImageIndex;\r\n Tag := Buttons[I].Tag;\r\n InternalClick := Buttons[I].OnClick;\r\n OnClick := DesktopForm.DoButtonClick;\r\n Parent := DesktopForm;\r\n Inc(X, 22);\r\n end;\r\n end;\r\n Location.Position := GetStacker.Position;\r\n if not AutoFocus then\r\n begin\r\n FActiveFocus := GetFocus;\r\n FActiveWindow := ParentWnd;\r\n end\r\n else\r\n begin\r\n FActiveWindow := NullHandle;\r\n FActiveFocus := NullHandle;\r\n end;\r\n DesktopForm.AllowFocus := AutoFocus;\r\n DesktopForm.ShowNoActivate;\r\n Result := True;\r\n if not AutoFocus and (FActiveFocus <> GetFocus) then\r\n begin\r\n if (FActiveFocus <> NullHandle) then\r\n SetFocus(FActiveFocus)\r\n else\r\n if (FActiveWindow <> NullHandle) then\r\n SetActiveWindow(FActiveWindow);\r\n end;\r\n GetStacker.Add(DesktopForm);\r\nend;\r\n\r\nfunction TJvDesktopAlert.GetDesktopForm: TJvFormDesktopAlert;\r\nbegin\r\n Result := TJvFormDesktopAlert(FDesktopForm);\r\nend;\r\n\r\nfunction TJvDesktopAlert.GetDropDownMenu: TPopupMenu;\r\nbegin\r\n Result := DesktopForm.tbDropDown.DropDownMenu;\r\nend;\r\n\r\nfunction TJvDesktopAlert.GetFont: TFont;\r\nbegin\r\n Result := DesktopForm.lblText.Font;\r\nend;\r\n\r\nfunction TJvDesktopAlert.GetHeaderFont: TFont;\r\nbegin\r\n Result := DesktopForm.lblHeader.Font;\r\nend;\r\n\r\nfunction TJvDesktopAlert.GetHeaderText: string;\r\nbegin\r\n Result := DesktopForm.lblHeader.Caption;\r\nend;\r\n\r\nfunction TJvDesktopAlert.GetImage: TPicture;\r\nbegin\r\n Result := DesktopForm.imIcon.Picture;\r\nend;\r\n\r\nfunction TJvDesktopAlert.GetMessageText: string;\r\nbegin\r\n Result := DesktopForm.lblText.Caption;\r\nend;\r\n\r\nfunction TJvDesktopAlert.GetParentFont: Boolean;\r\nbegin\r\n Result := DesktopForm.ParentFont;\r\nend;\r\n\r\nfunction TJvDesktopAlert.GetPopupMenu: TPopupMenu;\r\nbegin\r\n Result := DesktopForm.PopupMenu;\r\nend;\r\n\r\nfunction TJvDesktopAlert.GetShowHint: Boolean;\r\nbegin\r\n Result := DesktopForm.ShowHint;\r\nend;\r\n\r\nfunction TJvDesktopAlert.GetHint: string;\r\nbegin\r\n Result := DesktopForm.Hint;\r\nend;\r\n\r\nprocedure TJvDesktopAlert.InternalMessageClick(Sender: TObject);\r\nvar\r\n FEndInterval:Cardinal;\r\nbegin\r\n if Assigned(FOnMessageClick) and (daoCanClick in Options) then\r\n begin\r\n FEndInterval := StyleHandler.EndInterval;\r\n try\r\n StyleHandler.EndInterval := 0;\r\n FOnMessageClick(Self); // (p3) should this be Sender instead?\r\n finally\r\n StyleHandler.EndInterval := FEndInterval;\r\n end;\r\n if not DesktopForm.MouseInControl then\r\n StyleHandler.DoEndAnimation;\r\n end;\r\nend;\r\n\r\nprocedure TJvDesktopAlert.InternalMouseEnter(Sender: TObject);\r\nbegin\r\n if Assigned(FOnMouseEnter) then\r\n FOnMouseEnter(Self);\r\nend;\r\n\r\nprocedure TJvDesktopAlert.InternalMouseLeave(Sender: TObject);\r\nbegin\r\n if Assigned(FOnMouseLeave) then\r\n FOnMouseLeave(Self);\r\nend;\r\n\r\nprocedure TJvDesktopAlert.InternalOnClose(Sender: TObject;\r\n var Action: TCloseAction);\r\nbegin\r\n if (csDestroying in ComponentState) then\r\n Exit;\r\n if Location.Position = dapCustom then\r\n begin\r\n Location.Top := DesktopForm.Top;\r\n Location.Left := DesktopForm.Left;\r\n end;\r\n if Assigned(FOnClose) then\r\n FOnClose(Self);\r\n GetStacker.Remove(DesktopForm);\r\n if AutoFree and (DesktopForm <> nil) and not (csDesigning in ComponentState) then\r\n begin\r\n DesktopForm.OnClose := nil;\r\n // post a message to the form so we have time to finish off all event handlers and\r\n // timers before the form and component are freed\r\n PostMessage(DesktopForm.Handle, JVDESKTOPALERT_AUTOFREE, WPARAM(DesktopForm), LPARAM(Self));\r\n FDesktopForm := nil;\r\n end;\r\nend;\r\n\r\nprocedure TJvDesktopAlert.InternalOnShow(Sender: TObject);\r\nbegin\r\n if Assigned(FOnShow) then\r\n FOnShow(Self);\r\nend;\r\n\r\nprocedure TJvDesktopAlert.InternalOnShowing(Sender: TObject);\r\nbegin\r\n if Assigned(FOnShowing) then\r\n FOnShowing(Self);\r\nend;\r\n\r\nprocedure TJvDesktopAlert.InternalOnShown(Sender: TObject);\r\nbegin\r\n if Assigned(FOnShown) then\r\n FOnShown(Self);\r\nend;\r\n\r\nprocedure TJvDesktopAlert.SetButtons(const Value: TJvDesktopAlertButtons);\r\nbegin\r\n FButtons.Assign(Value);\r\nend;\r\n\r\nprocedure TJvDesktopAlert.SetDropDownMenu(const Value: TPopupMenu);\r\nbegin\r\n DesktopForm.tbDropDown.DropDownMenu := Value;\r\nend;\r\n\r\nprocedure TJvDesktopAlert.SetFont(const Value: TFont);\r\nbegin\r\n DesktopForm.lblText.Font := Value;\r\nend;\r\n\r\nprocedure TJvDesktopAlert.SetHeaderFont(const Value: TFont);\r\nbegin\r\n DesktopForm.lblHeader.Font := Value;\r\nend;\r\n\r\nprocedure TJvDesktopAlert.SetHeaderText(const Value: string);\r\nbegin\r\n DesktopForm.lblHeader.Caption := Value;\r\nend;\r\n\r\nprocedure TJvDesktopAlert.SetHint(const Value: string);\r\nbegin\r\n DesktopForm.Hint := Value;\r\nend;\r\n\r\nprocedure TJvDesktopAlert.SetImage(const Value: TPicture);\r\nbegin\r\n DesktopForm.imIcon.Picture := Value;\r\nend;\r\n\r\nprocedure TJvDesktopAlert.SetImages(const Value: TCustomImageList);\r\nbegin\r\n ReplaceComponentReference(Self, Value, TComponent(FImages));\r\nend;\r\n\r\nprocedure TJvDesktopAlert.SetMessageText(const Value: string);\r\nbegin\r\n DesktopForm.lblText.Caption := Value;\r\n DesktopForm.lblText.Update;\r\nend;\r\n\r\nprocedure TJvDesktopAlert.SetParentFont(const Value: Boolean);\r\nbegin\r\n DesktopForm.ParentFont := Value;\r\nend;\r\n\r\nprocedure TJvDesktopAlert.SetPopupMenu(const Value: TPopupMenu);\r\nbegin\r\n DesktopForm.PopupMenu := Value;\r\nend;\r\n\r\nprocedure TJvDesktopAlert.SetShowHint(const Value: Boolean);\r\nbegin\r\n DesktopForm.ShowHint := Value;\r\nend;\r\n\r\nfunction TJvDesktopAlert.GetCloseButtonClick: TNotifyEvent;\r\nbegin\r\n Result := DesktopForm.tbClose.OnClick;\r\nend;\r\n\r\nprocedure TJvDesktopAlert.SetCloseButtonClick(const Value: TNotifyEvent);\r\nbegin\r\n DesktopForm.tbClose.OnClick := Value;\r\nend;\r\n\r\n//=== { TJvDesktopAlertStack } ===============================================\r\n\r\nconstructor TJvDesktopAlertStack.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FItems := TList.Create;\r\n FPosition := dapBottomRight;\r\nend;\r\n\r\ndestructor TJvDesktopAlertStack.Destroy;\r\nbegin\r\n FItems.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvDesktopAlertStack.Add(AForm: TCustomForm);\r\nbegin\r\n FItems.Add(AForm);\r\n UpdatePositions;\r\nend;\r\n\r\nfunction TJvDesktopAlertStack.GetCount: Integer;\r\nbegin\r\n Result := FItems.Count;\r\nend;\r\n\r\nfunction TJvDesktopAlertStack.GetItems(Index: Integer): TJvCustomFormDesktopAlert;\r\nbegin\r\n Result := TJvCustomFormDesktopAlert(FItems[Index]);\r\n Assert((Result = nil) or (Result is TJvCustomFormDesktopAlert));\r\nend;\r\n\r\nprocedure TJvDesktopAlertStack.Remove(AForm: TCustomForm);\r\nvar\r\n Index, PrevNilSlot: Integer;\r\n Form: TJvCustomFormDesktopAlert;\r\nbegin\r\n if (AForm <> nil) and (AForm is TJvCustomFormDesktopAlert) then\r\n begin\r\n // The basic trick here is to push piling forms down in the list, while keeping the\r\n // static ones (i.e. a form that has the mouse pointer over it) in place.\r\n Index := FItems.IndexOf(AForm);\r\n if Index >= 0 then\r\n begin\r\n FItems[Index] := nil;\r\n\r\n Inc(Index);\r\n while Index < FItems.Count do\r\n begin\r\n Form := Items[Index];\r\n if Assigned(Form) and (not Form.MouseInControl) then\r\n begin\r\n PrevNilSlot := Pred(Index);\r\n while FItems[PrevNilSlot] <> nil do\r\n Dec(PrevNilSlot);\r\n FItems[PrevNilSlot] := FItems[Index];\r\n FItems[Index] := nil;\r\n end;\r\n\r\n Inc(Index);\r\n end;\r\n\r\n while (Pred(FItems.Count) >= 0) and (FItems[Pred(FItems.Count)] = nil) do\r\n FItems.Delete(Pred(FItems.Count));\r\n\r\n UpdatePositions;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvDesktopAlertStack.SetPosition(const Value: TJvDesktopAlertPosition);\r\nbegin\r\n if FPosition <> Value then\r\n begin\r\n// if Value = dapCustom then raise\r\n// Exception.Create('TJvDesktopAlertStack does not handle dapCustom alerts!');\r\n// FItems.Clear;\r\n FPosition := Value;\r\n end;\r\nend;\r\n\r\nprocedure TJvDesktopAlertStack.UpdatePositions;\r\nvar\r\n C, I: Integer;\r\n Form: TJvCustomFormDesktopAlert;\r\n X, Y: Integer;\r\n R: TRect;\r\nbegin\r\n C := Count;\r\n if C > 0 then\r\n begin\r\n R := ScreenWorkArea;\r\n case Position of\r\n dapBottomRight:\r\n begin\r\n Y := R.Bottom;\r\n for I := 0 to Pred(C) do\r\n begin\r\n Form := Items[I];\r\n if Assigned(Form) and Form.Visible then\r\n begin\r\n X := R.Right - Form.Width;\r\n Dec(Y, Form.Height);\r\n Form.SetNewOrigin(X, Y);\r\n end;\r\n end;\r\n end;\r\n dapBottomLeft:\r\n begin\r\n X := R.Left;\r\n Y := R.Bottom;\r\n for I := 0 to Pred(C) do\r\n begin\r\n Form := Items[I];\r\n if Assigned(Form) and Form.Visible then\r\n begin\r\n Dec(Y, Form.Height);\r\n Form.SetNewOrigin(X, Y);\r\n end;\r\n end;\r\n end;\r\n dapTopRight:\r\n begin\r\n Y := R.Top;\r\n for I := 0 to Pred(C) do\r\n begin\r\n Form := Items[I];\r\n if Assigned(Form) and Form.Visible then\r\n begin\r\n X := R.Right - Form.Width;\r\n Form.SetNewOrigin(X, Y);\r\n Inc(Y, Form.Height);\r\n end;\r\n end;\r\n end;\r\n dapTopLeft:\r\n begin\r\n Y := R.Top;\r\n X := R.Left;\r\n for I := 0 to Pred(C) do\r\n begin\r\n Form := Items[I];\r\n if Assigned(Form) and Form.Visible then\r\n begin\r\n Form.SetNewOrigin(X, Y);\r\n Inc(Y, Form.Height);\r\n end;\r\n end;\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\n//=== { TJvCustomDesktopAlertStyle } =========================================\r\n\r\nconstructor TJvCustomDesktopAlertStyleHandler.Create(OwnerForm: TJvCustomFormDesktopAlert);\r\nbegin\r\n inherited Create;\r\n FAnimTimer := TTimer.Create(nil);\r\n FAnimTimer.Enabled := False;\r\n FOwnerForm := OwnerForm;\r\nend;\r\n\r\ndestructor TJvCustomDesktopAlertStyleHandler.Destroy;\r\nbegin\r\n FAnimTimer.OnTimer := nil;\r\n FreeAndNil(FAnimTimer);\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvCustomDesktopAlertStyleHandler.AbortAnimation;\r\nbegin\r\n AnimTimer.Enabled := False;\r\n if Status = hsStartAnim then\r\n FinalizeStartAnimation\r\n else\r\n if Status = hsEndAnim then\r\n FinalizeEndAnimation;\r\nend;\r\n\r\nprocedure TJvCustomDesktopAlertStyleHandler.DoEndAnimation;\r\nbegin\r\n if EndSteps > 0 then\r\n begin\r\n AnimTimer.Enabled := False;\r\n AnimTimer.OnTimer := EndAnimTimer;\r\n AnimTimer.Interval := EndInterval;\r\n FCurrentStep := 0;\r\n PrepareEndAnimation;\r\n FStatus := hsEndAnim;\r\n AnimTimer.Enabled := True;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomDesktopAlertStyleHandler.DoDisplay;\r\nbegin\r\n if DisplayDuration > 0 then\r\n begin\r\n AnimTimer.Enabled := False;\r\n AnimTimer.OnTimer := DisplayTimer;\r\n AnimTimer.Interval := DisplayDuration;\r\n FCurrentStep := 0;\r\n FStatus := hsDisplay;\r\n AnimTimer.Enabled := True;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomDesktopAlertStyleHandler.DoStartAnimation;\r\nbegin\r\n if StartSteps > 0 then\r\n begin\r\n AnimTimer.Enabled := False;\r\n AnimTimer.OnTimer := StartAnimTimer;\r\n AnimTimer.Interval := StartInterval;\r\n FCurrentStep := 0;\r\n PrepareStartAnimation;\r\n FStatus := hsStartAnim;\r\n AnimTimer.Enabled := True;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomDesktopAlertStyleHandler.EndAnimTimer(Sender: TObject);\r\nbegin\r\n Inc(FCurrentStep);\r\n if CurrentStep >= EndSteps then\r\n begin\r\n AnimTimer.Enabled := False;\r\n FinalizeEndAnimation;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomDesktopAlertStyleHandler.DisplayTimer(Sender: TObject);\r\nbegin\r\n AnimTimer.Enabled := False;\r\n FStatus := hsIdle;\r\nend;\r\n\r\nfunction TJvCustomDesktopAlertStyleHandler.GetActive: Boolean;\r\nbegin\r\n Result := AnimTimer.Enabled;\r\nend;\r\n\r\nprocedure TJvCustomDesktopAlertStyleHandler.SetEndInterval(const Value: Cardinal);\r\nbegin\r\n FEndInterval := Value;\r\nend;\r\n\r\nprocedure TJvCustomDesktopAlertStyleHandler.SetEndSteps(const Value: Cardinal);\r\nbegin\r\n FEndSteps := Value;\r\n if FEndSteps < 1 then\r\n FEndSteps := 1;\r\nend;\r\n\r\nprocedure TJvCustomDesktopAlertStyleHandler.SetStartInterval(const Value: Cardinal);\r\nbegin\r\n FStartInterval := Value;\r\nend;\r\n\r\nprocedure TJvCustomDesktopAlertStyleHandler.SetStartSteps(const Value: Cardinal);\r\nbegin\r\n FStartSteps := Value;\r\n if FStartSteps < 1 then\r\n FStartSteps := 1;\r\nend;\r\n\r\nprocedure TJvCustomDesktopAlertStyleHandler.StartAnimTimer(Sender: TObject);\r\nbegin\r\n Inc(FCurrentStep);\r\n if CurrentStep >= StartSteps then\r\n begin\r\n AnimTimer.Enabled := False;\r\n FinalizeStartAnimation;\r\n DoDisplay;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomDesktopAlertStyleHandler.FinalizeEndAnimation;\r\nbegin\r\n if OwnerForm <> nil then\r\n OwnerForm.Close;\r\nend;\r\n\r\nprocedure TJvCustomDesktopAlertStyleHandler.PrepareStartAnimation;\r\nbegin\r\n if OwnerForm <> nil then\r\n ShowWindow(OwnerForm.Handle, SW_SHOWNA);\r\nend;\r\n\r\n//=== { TJvFadeAlertStyleHandler } ===========================================\r\n\r\nconst\r\n WS_EX_LAYERED = $00080000;\r\n LWA_ALPHA = $00000002;\r\n\r\ntype\r\n TDynamicSetLayeredWindowAttributes =\r\n function(HWnd: THandle; crKey: COLORREF; bAlpha: Byte; dwFlags: DWORD): Boolean; stdcall;\r\n\r\nconstructor TJvFadeAlertStyleHandler.Create(OwnerForm: TJvCustomFormDesktopAlert);\r\nbegin\r\n inherited Create(OwnerForm);\r\n\r\n // Set default values\r\n StartInterval := 25;\r\n StartSteps := 10;\r\n EndInterval := 50;\r\n EndSteps := 10;\r\n DisplayDuration := 1400;\r\n MinAlphaBlendValue := 0;\r\n MaxAlphaBlendValue := 255;\r\nend;\r\n\r\nprocedure TJvFadeAlertStyleHandler.AbortAnimation;\r\nbegin\r\n if not (Status in [hsDisplay, hsStartAnim]) then\r\n begin\r\n AnimTimer.Enabled := False;\r\n DoAlphaBlend(MaxAlphaBlendValue);\r\n end;\r\nend;\r\n\r\nprocedure TJvFadeAlertStyleHandler.DoAlphaBlend(Value: Byte);\r\nvar\r\n DynamicSetLayeredWindowAttributes: TDynamicSetLayeredWindowAttributes;\r\n CurrentStyle: Cardinal;\r\n\r\n procedure InitProcs;\r\n const\r\n sUser32 = 'User32.dll';\r\n var\r\n ModH: HMODULE;\r\n begin\r\n ModH := GetModuleHandle(sUser32);\r\n if ModH <> 0 then\r\n @DynamicSetLayeredWindowAttributes := GetProcAddress(ModH, 'SetLayeredWindowAttributes')\r\n else\r\n @DynamicSetLayeredWindowAttributes := nil;\r\n end;\r\n\r\nbegin\r\n if OwnerForm <> nil then\r\n begin\r\n InitProcs;\r\n if OwnerForm.HandleAllocated and Assigned(DynamicSetLayeredWindowAttributes) then\r\n begin\r\n CurrentStyle := GetWindowLong(OwnerForm.Handle, GWL_EXSTYLE);\r\n if (CurrentStyle and WS_EX_LAYERED) = 0 then\r\n SetWindowLong(OwnerForm.Handle, GWL_EXSTYLE,\r\n GetWindowLong(OwnerForm.Handle, GWL_EXSTYLE) or WS_EX_LAYERED);\r\n DynamicSetLayeredWindowAttributes(OwnerForm.Handle, 0, Value, LWA_ALPHA);\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvFadeAlertStyleHandler.EndAnimTimer(Sender: TObject);\r\nbegin\r\n inherited EndAnimTimer(Sender);\r\n DoAlphaBlend(MaxAlphaBlendValue -\r\n ((Cardinal(MaxAlphaBlendValue) - MinAlphaBlendValue) * CurrentStep) div EndSteps);\r\nend;\r\n\r\nprocedure TJvFadeAlertStyleHandler.FinalizeEndAnimation;\r\nbegin\r\n DoAlphaBlend(MinAlphaBlendValue);\r\n inherited FinalizeEndAnimation; // Do not forget to call inherited, to hide the form\r\nend;\r\n\r\nprocedure TJvFadeAlertStyleHandler.FinalizeStartAnimation;\r\nbegin\r\n DoAlphaBlend(MaxAlphaBlendValue);\r\nend;\r\n\r\nprocedure TJvFadeAlertStyleHandler.PrepareEndAnimation;\r\nbegin\r\n DoAlphaBlend(MaxAlphaBlendValue);\r\nend;\r\n\r\nprocedure TJvFadeAlertStyleHandler.PrepareStartAnimation;\r\nbegin\r\n DoAlphaBlend(MinAlphaBlendValue);\r\n inherited PrepareStartAnimation;\r\nend;\r\n\r\nprocedure TJvFadeAlertStyleHandler.SetMaxAlphaBlendValue(const Value: Byte);\r\nbegin\r\n FMaxAlphaBlendValue := Value;\r\nend;\r\n\r\nprocedure TJvFadeAlertStyleHandler.SetMinAlphaBlendValue(const Value: Byte);\r\nbegin\r\n FMinAlphaBlendValue := Value;\r\nend;\r\n\r\nprocedure TJvFadeAlertStyleHandler.StartAnimTimer(Sender: TObject);\r\nbegin\r\n DoAlphaBlend(MinAlphaBlendValue +\r\n ((Cardinal(MaxAlphaBlendValue) - MinAlphaBlendValue) * CurrentStep) div StartSteps);\r\n inherited StartAnimTimer(Sender);\r\nend;\r\n\r\n//=== { TJvCenterGrowAlertStyleHandler } =====================================\r\n\r\nconstructor TJvCenterGrowAlertStyleHandler.Create(OwnerForm: TJvCustomFormDesktopAlert);\r\nbegin\r\n inherited Create(OwnerForm);\r\n\r\n // Set default values\r\n StartInterval := 25;\r\n StartSteps := 10;\r\n EndInterval := 50;\r\n EndSteps := 10;\r\n DisplayDuration := 1400;\r\n\r\n MinGrowthPercentage := 0;\r\n MaxGrowthPercentage := 100;\r\nend;\r\n\r\nprocedure TJvCenterGrowAlertStyleHandler.AbortAnimation;\r\nbegin\r\n if not (Status in [hsDisplay, hsStartAnim]) then\r\n begin\r\n AnimTimer.Enabled := False;\r\n DoGrowRegion(MaxGrowthPercentage);\r\n end;\r\nend;\r\n\r\nprocedure TJvCenterGrowAlertStyleHandler.DoGrowRegion(Percentage: Double);\r\nvar\r\n RegionRect: TRect;\r\n Region: HRGN;\r\n RegionHeight: Integer;\r\n RegionWidth: Integer;\r\nbegin\r\n if OwnerForm <> nil then\r\n begin\r\n RegionHeight := Round(Percentage * OwnerForm.Height / 100.0);\r\n RegionWidth := Round(Percentage * OwnerForm.Width / 100.0);\r\n\r\n RegionRect.Left := (OwnerForm.Width - RegionWidth) div 2;\r\n RegionRect.Right := RegionRect.Left + RegionWidth;\r\n RegionRect.Top := (OwnerForm.Height - RegionHeight) div 2;\r\n RegionRect.Bottom := RegionRect.Top + RegionHeight;\r\n\r\n Region := CreateRectRgnIndirect(RegionRect);\r\n SetWindowRgn(OwnerForm.Handle, Region, True);\r\n end;\r\nend;\r\n\r\nprocedure TJvCenterGrowAlertStyleHandler.StartAnimTimer(Sender: TObject);\r\nbegin\r\n DoGrowRegion(MinGrowthPercentage +\r\n ((MaxGrowthPercentage - MinGrowthPercentage) * CurrentStep) / StartSteps);\r\n inherited StartAnimTimer(Sender);\r\nend;\r\n\r\nprocedure TJvCenterGrowAlertStyleHandler.EndAnimTimer(Sender: TObject);\r\nbegin\r\n inherited EndAnimTimer(Sender);\r\n DoGrowRegion(MaxGrowthPercentage -\r\n ((MaxGrowthPercentage - MinGrowthPercentage) * CurrentStep) / EndSteps);\r\nend;\r\n\r\nprocedure TJvCenterGrowAlertStyleHandler.FinalizeEndAnimation;\r\nbegin\r\n DoGrowRegion(MinGrowthPercentage);\r\n inherited FinalizeEndAnimation;\r\nend;\r\n\r\nprocedure TJvCenterGrowAlertStyleHandler.FinalizeStartAnimation;\r\nbegin\r\n DoGrowRegion(MaxGrowthPercentage);\r\nend;\r\n\r\nprocedure TJvCenterGrowAlertStyleHandler.PrepareEndAnimation;\r\nbegin\r\n DoGrowRegion(MaxGrowthPercentage);\r\nend;\r\n\r\nprocedure TJvCenterGrowAlertStyleHandler.PrepareStartAnimation;\r\nbegin\r\n DoGrowRegion(MinGrowthPercentage);\r\n inherited PrepareStartAnimation;\r\nend;\r\n\r\nprocedure TJvCenterGrowAlertStyleHandler.SetMaxGrowthPercentage(const Value: Double);\r\nbegin\r\n FMaxGrowthPercentage := Value;\r\n if FMaxGrowthPercentage < 0.0 then\r\n FMaxGrowthPercentage := 0.0;\r\n if FMaxGrowthPercentage > 100.0 then\r\n FMaxGrowthPercentage := 100.0;\r\nend;\r\n\r\nprocedure TJvCenterGrowAlertStyleHandler.SetMinGrowthPercentage(const Value: Double);\r\nbegin\r\n FMinGrowthPercentage := Value;\r\n if FMinGrowthPercentage < 0.0 then\r\n FMinGrowthPercentage := 0.0;\r\n if FMinGrowthPercentage > 100.0 then\r\n FMinGrowthPercentage := 100.0;\r\nend;\r\n\r\nfunction TJvDesktopAlert.GetBiDiMode: TBidiMode;\r\nbegin\r\n Result := FDesktopForm.BiDiMode;\r\nend;\r\n\r\nprocedure TJvDesktopAlert.SetBiDiMode(const Value: TBidiMode);\r\nbegin\r\n FDesktopForm.BiDiMode := Value;\r\nend;\r\n\r\n{ TJvCustomDesktopAlert }\r\n\r\nprocedure TJvCustomDesktopAlert.Close(Immediate: Boolean);\r\nbegin\r\n if Showing then\r\n begin\r\n if Immediate then\r\n FDesktopForm.Close\r\n else\r\n FStyleHandler.DoEndAnimation;\r\n end;\r\nend;\r\n\r\nconstructor TJvCustomDesktopAlert.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FColors := TJvDesktopAlertColors.Create;\r\n FLocation := TJvDesktopAlertLocation.Create;\r\n FLocation.OnChange := DoLocationChange;\r\n AlertStyle := asFade;\r\n FOptions := [daoCanClick..daoCanClose];\r\nend;\r\n\r\ndestructor TJvCustomDesktopAlert.Destroy;\r\nbegin\r\n // when AutoFreeing, Delphi doesn't like the component having an owner, so remove the Owner here\r\n if FAutoFree and (Owner <> nil) and not (csDesigning in ComponentState) then\r\n Owner.RemoveComponent(Self);\r\n if (FDesktopForm <> nil) then\r\n begin\r\n if FDesktopForm.Showing then\r\n FDesktopForm.Close;\r\n FDesktopForm.OnClose := nil;\r\n GetStacker.Remove(FDesktopForm);\r\n FDesktopForm.Release;\r\n FDesktopForm := nil;\r\n end;\r\n FreeAndNil(FColors);\r\n FreeAndNil(FLocation);\r\n FreeAndNil(FStyleHandler);\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvCustomDesktopAlert.DoLocationChange(Sender: TObject);\r\nbegin\r\n if GetStacker.Position <> Location.Position then\r\n begin\r\n if GetStacker = GlobalStacker then\r\n GetStacker.Position := Location.Position\r\n else\r\n Location.Position := GetStacker.Position;\r\n end;\r\nend;\r\n\r\nfunction TJvCustomDesktopAlert.Execute(ParentWnd: HWND): Boolean;\r\nvar\r\n ARect: TRect;\r\n Position: TJvDesktopAlertPosition;\r\n\r\n procedure CenterForm(AForm: TCustomForm; ARect: TRect);\r\n begin\r\n AForm.Top := ARect.Top + ((ARect.Bottom - ARect.Top) - AForm.Height) div 2;\r\n AForm.Left := ARect.Left + ((ARect.Right - ARect.Left) - AForm.Width) div 2;\r\n end;\r\nbegin\r\n Assert(FDesktopForm <> nil);\r\n if FDesktopForm.Visible then\r\n FDesktopForm.Close;\r\n\r\n ARect := ScreenWorkArea;\r\n if (Application <> nil) and (Application.MainForm <> nil) and\r\n (Location.Position in [dapMainFormTopLeft, dapMainFormTopRight, dapMainFormBottomLeft, dapMainFormBottomRight]) then\r\n ARect := Application.MainForm.BoundsRect\r\n else\r\n if (Screen.ActiveForm <> nil) and\r\n (Location.Position in [dapActiveFormTopLeft, dapActiveFormTopRight, dapActiveFormBottomLeft, dapActiveFormBottomRight]) then\r\n ARect := Screen.ActiveForm.BoundsRect\r\n else\r\n if (Owner is TCustomForm) and\r\n (Location.Position in [dapOwnerFormTopLeft, dapOwnerFormTopRight, dapOwnerFormBottomLeft, dapOwnerFormBottomRight]) then\r\n ARect := TCustomForm(Owner).BoundsRect;\r\n\r\n Position := Location.Position;\r\n case Position of\r\n dapMainFormTopLeft, dapActiveFormTopLeft, dapOwnerFormTopLeft:\r\n Position := dapTopLeft;\r\n dapMainFormTopRight, dapActiveFormTopRight, dapOwnerFormTopRight:\r\n Position := dapTopRight;\r\n dapMainFormBottomLeft, dapActiveFormBottomLeft, dapOwnerFormBottomLeft:\r\n Position := dapBottomLeft;\r\n dapMainFormBottomRight, dapActiveFormBottomRight, dapOwnerFormBottomRight:\r\n Position := dapBottomRight;\r\n end;\r\n\r\n if Location.Width <> 0 then\r\n FDesktopForm.Width := Location.Width\r\n else\r\n FDesktopForm.Width := cDefaultAlertFormWidth;\r\n if Location.Height <> 0 then\r\n FDesktopForm.Height := Location.Height\r\n else\r\n FDesktopForm.Height := cDefaultAlertFormHeight;\r\n case Position of\r\n dapTopLeft:\r\n begin\r\n FDesktopForm.Top := ARect.Top;\r\n FDesktopForm.Left := ARect.Left;\r\n end;\r\n dapTopRight:\r\n begin\r\n FDesktopForm.Top := ARect.Top;\r\n FDesktopForm.Left := ARect.Right - FDesktopForm.Width;\r\n end;\r\n dapBottomLeft:\r\n begin\r\n FDesktopForm.Top := ARect.Bottom - FDesktopForm.Height;\r\n FDesktopForm.Left := ARect.Left;\r\n end;\r\n dapBottomRight:\r\n begin\r\n FDesktopForm.Top := ARect.Bottom - FDesktopForm.Height;\r\n FDesktopForm.Left := ARect.Right - FDesktopForm.Width;\r\n end;\r\n dapCustom:\r\n begin\r\n FDesktopForm.Top := Location.Top;\r\n FDesktopForm.Left := Location.Left;\r\n end;\r\n dapDesktopCenter, dapMainFormCenter, dapOwnerFormCenter, dapActiveFormCenter:\r\n begin\r\n CenterForm(FDesktopForm, ARect);\r\n if (Location.Position = dapActiveFormCenter) and (Screen.ActiveForm <> nil) then\r\n CenterForm(FDesktopForm, Screen.ActiveForm.BoundsRect)\r\n else\r\n if (Location.Position = dapMainFormCenter) and (Application <> nil) and (Application.MainForm <> nil) then\r\n CenterForm(FDesktopForm, Application.MainForm.BoundsRect)\r\n else\r\n if (Location.Position = dapOwnerFormCenter) then\r\n if (Owner is TCustomForm) then\r\n CenterForm(FDesktopForm, TCustomForm(Owner).BoundsRect)\r\n else\r\n begin\r\n GetWindowRect(ParentWnd, ARect);\r\n CenterForm(FDesktopForm, ARect);\r\n end;\r\n end;\r\n end;\r\n\r\n FDesktopForm.Moveable := (daoCanMove in Options);\r\n FDesktopForm.MoveAnywhere := (daoCanMoveAnywhere in Options);\r\n FDesktopForm.WindowColorFrom := Colors.WindowFrom;\r\n FDesktopForm.WindowColorTo := Colors.WindowTo;\r\n FDesktopForm.CaptionColorFrom := Colors.CaptionFrom;\r\n FDesktopForm.CaptionColorTo := Colors.CaptionTo;\r\n FDesktopForm.FrameColor := Colors.Frame;\r\n\r\n Result := True;\r\nend;\r\n\r\nfunction TJvCustomDesktopAlert.GetAlertStack: TJvDesktopAlertStack;\r\nbegin\r\n if FStacker = GlobalStacker then\r\n Result := nil\r\n else\r\n Result := FStacker;\r\nend;\r\n\r\nfunction TJvCustomDesktopAlert.GetStacker: TJvDesktopAlertStack;\r\nbegin\r\n if FStacker = nil then\r\n Result := GlobalStacker\r\n else\r\n Result := FStacker;\r\nend;\r\n\r\nprocedure TJvCustomDesktopAlert.InternalOnMove(Sender: TObject);\r\nbegin\r\n if not (csDesigning in ComponentState) and not Location.AlwaysResetPosition and\r\n (Location.Position <> dapCustom) then\r\n begin\r\n GetStacker.Remove(FDesktopForm);\r\n Location.Position := dapCustom;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomDesktopAlert.Notification(AComponent: TComponent;\r\n Operation: TOperation);\r\nbegin\r\n inherited Notification(AComponent, Operation);\r\n if Operation = opRemove then\r\n begin\r\n if AComponent = FStacker then\r\n AlertStack := nil;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomDesktopAlert.SetAlertStack(const Value: TJvDesktopAlertStack);\r\nbegin\r\n if ReplaceComponentReference(Self, Value, TComponent(FStacker)) then\r\n if FStacker <> nil then\r\n Location.Position := FStacker.Position;\r\nend;\r\n\r\nprocedure TJvCustomDesktopAlert.SetAlertStyle(const Value: TJvAlertStyle);\r\nbegin\r\n FAlertStyle := Value;\r\n FStyleHandler.Free;\r\n FStyleHandler := CreateHandlerForStyle(AlertStyle, TJvCustomFormDesktopAlert(FDesktopForm));\r\nend;\r\n\r\nprocedure TJvCustomDesktopAlert.SetColors(const Value: TJvDesktopAlertColors);\r\nbegin\r\n FColors.Assign(Value);\r\nend;\r\n\r\nprocedure TJvCustomDesktopAlert.SetLocation(const Value: TJvDesktopAlertLocation);\r\nbegin\r\n //\r\nend;\r\n\r\nprocedure TJvCustomDesktopAlert.SetOptions(const Value: TJvDesktopAlertOptions);\r\nbegin\r\n if FOptions <> Value then\r\n begin\r\n FOptions := Value;\r\n if not (daoCanMove in FOptions) then\r\n Exclude(FOptions, daoCanMoveAnywhere);\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomDesktopAlert.SetStyleHandler(const Value: TJvCustomDesktopAlertStyleHandler);\r\nbegin\r\n FStyleHandler.Assign(Value);\r\nend;\r\n\r\nfunction TJvCustomDesktopAlert.Showing: Boolean;\r\nbegin\r\n Result := (FDesktopForm <> nil) and FDesktopForm.Showing;\r\nend;\r\n\r\n{ TJvDesktopAlertForm }\r\n\r\nfunction TJvDesktopAlertForm.Execute(ParentWnd: HWND): Boolean;\r\nvar\r\n FActiveWindow, FActiveFocus: HWND;\r\nbegin\r\n inherited Execute(ParentWnd);\r\n\r\n FDesktopForm.Closeable := (daoCanClose in Options);\r\n FDesktopForm.OnUserMove := InternalOnMove;\r\n\r\n Location.Position := GetStacker.Position;\r\n if not AutoFocus then\r\n begin\r\n FActiveFocus := GetFocus;\r\n FActiveWindow := ParentWnd;\r\n end\r\n else\r\n begin\r\n FActiveWindow := NullHandle;\r\n FActiveFocus := NullHandle;\r\n end;\r\n FDesktopForm.AllowFocus := AutoFocus;\r\n FDesktopForm.ShowNoActivate;\r\n Result := True;\r\n if not AutoFocus and (FActiveFocus <> GetFocus) then\r\n begin\r\n if (FActiveFocus <> NullHandle) then\r\n SetFocus(FActiveFocus)\r\n else\r\n if (FActiveWindow <> NullHandle) then\r\n SetActiveWindow(FActiveWindow);\r\n end;\r\n GetStacker.Add(FDesktopForm);\r\nend;\r\n\r\nprocedure TJvDesktopAlertForm.SetForm(const Value: TJvCustomFormDesktopAlert);\r\nbegin\r\n FDesktopForm := Value;\r\n if Value <> nil then begin\r\n Location.Width := FDesktopForm.Width;\r\n Location.Height := FDesktopForm.Height;\r\n end;\r\n //reforce alert style so proper form will be assigned to alert displayer\r\n AlertStyle := AlertStyle;\r\nend;\r\n\r\ninitialization\r\n {$IFDEF UNITVERSIONING}\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n {$ENDIF UNITVERSIONING}\r\n\r\nfinalization\r\n FreeAndNil(GStacker);\r\n {$IFDEF UNITVERSIONING}\r\n UnregisterUnitVersion(HInstance);\r\n {$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvDesktopAlertForm.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvDesktopAlertForm.PAS, released on 2004-03-24.\r\n\r\nThe Initial Developer of the Original Code is Peter Thornqvist \r\nPortions created by Peter Thornqvist are Copyright (C) 2004 Peter Thornqvist.\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\nHans-Eric Grnlund (stack logic)\r\nOlivier Sannier (animation styles logic)\r\nMiha Vrhovnik (custom form display logic)\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n* This form is used by the TJvDesktopAlert component\r\n\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvDesktopAlertForm.pas 13415 2012-09-10 09:51:54Z obones $\r\n\r\nunit JvDesktopAlertForm;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, Messages, Classes, Graphics, Controls, Forms, StdCtrls, ExtCtrls,\r\n ImgList, ActnList,\r\n {$IFDEF HAS_UNIT_SYSTEM_UITYPES}\r\n System.UITypes,\r\n {$ENDIF HAS_UNIT_SYSTEM_UITYPES}\r\n JvButton, JvLabel, JvExForms;\r\n\r\nconst\r\n cDefaultAlertFormWidth = 329;\r\n cDefaultAlertFormHeight = 76;\r\n JVDESKTOPALERT_AUTOFREE = WM_USER + 1001;\r\n\r\ntype\r\n TJvDesktopAlertButtonType = (abtArrowLeft, abtArrowRight, abtClose, abtMaximize,\r\n abtMinimize, abtDropDown, abtDropDownChevron, abtRestore, abtImage);\r\n\r\n TJvDesktopAlertButton = class(TJvCustomGraphicButton)\r\n private\r\n FChangeLink: TChangeLink;\r\n FImages: TCustomImageList;\r\n FImageIndex: TImageIndex;\r\n FToolType: TJvDesktopAlertButtonType;\r\n FInternalClick: TNotifyEvent;\r\n procedure SetImages(const Value: TCustomImageList);\r\n procedure SetImageIndex(const Value: TImageIndex);\r\n procedure DoImagesChange(Sender: TObject);\r\n procedure SetToolType(const Value: TJvDesktopAlertButtonType);\r\n protected\r\n procedure Notification(AComponent: TComponent; Operation: TOperation); override;\r\n procedure Paint; override;\r\n procedure MouseEnter(Control: TControl); override;\r\n procedure MouseLeave(Control: TControl); override;\r\n public\r\n property InternalClick: TNotifyEvent read FInternalClick write FInternalClick;\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n published\r\n property ToolType: TJvDesktopAlertButtonType read FToolType write SetToolType;\r\n property DropDownMenu;\r\n property Images: TCustomImageList read FImages write SetImages;\r\n property ImageIndex: TImageIndex read FImageIndex write SetImageIndex;\r\n property Width default 21;\r\n property Height default 21;\r\n property OnClick;\r\n end;\r\n\r\n // We have to inherit from TJvExForm instead of TJvExCustmForm\r\n // because otherwise our custom forms might not load correctly\r\n // ('Property does not exist' exceptions are raised)\r\n TJvCustomFormDesktopAlert = class(TJvExForm)\r\n private\r\n FOnMouseLeave: TNotifyEvent;\r\n FOnMouseEnter: TNotifyEvent;\r\n FOnUserMove: TNotifyEvent;\r\n MouseTimer: TTimer;\r\n FCloseable: Boolean;\r\n FMoveable: Boolean;\r\n FMoveAnywhere: Boolean;\r\n FAllowFocus: Boolean;\r\n FCaptionColorTo: TColor;\r\n FWindowColorTo: TColor;\r\n FWindowColorFrom: TColor;\r\n FCaptionColorFrom: TColor;\r\n FFrameColor: TColor;\r\n FOnShown: TNotifyEvent;\r\n FOnShowing: TNotifyEvent;\r\n FEndInterval:Cardinal;\r\n FMouseInControl: Boolean;\r\n procedure WMNCHitTest(var Msg: TWMNCHitTest); message WM_NCHITTEST;\r\n procedure WMActivate(var Message: TWMActivate); message WM_ACTIVATE;\r\n procedure WMMouseActivate(var Message: TWMMouseActivate); message WM_MOUSEACTIVATE;\r\n procedure WMMove(var Msg: TWMMove); message WM_MOVE;\r\n procedure JvDeskTopAlertAutoFree(var Msg: TMessage); message JVDESKTOPALERT_AUTOFREE;\r\n procedure DoMouseTimer(Sender: TObject);\r\n procedure FormPaint(Sender: TObject);\r\n function GetVisible: Boolean;\r\n protected\r\n acClose: TAction;\r\n procedure DoShow; override;\r\n procedure DoClose(var Action: TCloseAction); override;\r\n procedure MouseEnter(AControl: TControl); override;\r\n procedure MouseLeave(AControl: TControl); override;\r\n //override this one if you'd like to exes sth before form is shown\r\n procedure InternalDoShow; virtual;\r\n procedure CreateParams(var Params: TCreateParams); override;\r\n\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n procedure acCloseExecute(Sender: TObject);\r\n procedure SetNewTop(const Value: Integer);\r\n procedure SetNewLeft(const Value: Integer);\r\n procedure SetNewOrigin(ALeft, ATop: Integer);\r\n procedure ShowNoActivate;\r\n\r\n property Moveable: Boolean read FMoveable write FMoveable;\r\n property MoveAnywhere: Boolean read FMoveAnywhere write FMoveAnywhere;\r\n property Closeable: Boolean read FCloseable write FCloseable;\r\n property MouseInControl: Boolean read FMouseInControl;\r\n property WindowColorFrom: TColor read FWindowColorFrom write FWindowColorFrom;\r\n property WindowColorTo: TColor read FWindowColorTo write FWindowColorTo;\r\n property CaptionColorFrom: TColor read FCaptionColorFrom write FCaptionColorFrom;\r\n property CaptionColorTo: TColor read FCaptionColorTo write FCaptionColorTo;\r\n property FrameColor: TColor read FFrameColor write FFrameColor;\r\n property AllowFocus: Boolean read FAllowFocus write FAllowFocus;\r\n\r\n property Showing read GetVisible;\r\n property Visible read GetVisible;\r\n property OnMouseEnter: TNotifyEvent read FOnMouseEnter write FOnMouseEnter;\r\n property OnMouseLeave: TNotifyEvent read FOnMouseLeave write FOnMouseLeave;\r\n property OnUserMove: TNotifyEvent read FOnUserMove write FOnUserMove;\r\n property OnClose;\r\n property OnShowing: TNotifyEvent read FOnShowing write FOnShowing;\r\n property OnShow;\r\n property OnShown: TNotifyEvent read FOnShown write FOnShown;\r\n end;\r\n\r\n TJvFormDesktopAlert = class(TJvCustomFormDesktopAlert)\r\n private\r\n FClickableMessage: Boolean;\r\n protected\r\n procedure InternalDoShow; override;\r\n procedure DoDropDownClose(Sender: TObject);\r\n procedure DoDropDownMenu(Sender: TObject; MousePos: TPoint; var Handled: Boolean);\r\n public\r\n imIcon: TImage;\r\n lblText: TJvLabel;\r\n lblHeader: TLabel;\r\n tbDropDown: TJvDesktopAlertButton;\r\n tbClose: TJvDesktopAlertButton;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n procedure DoButtonClick(Sender: TObject);\r\n\r\n property ClickableMessage: Boolean read FClickableMessage write FClickableMessage;\r\n property ParentFont;\r\n property PopupMenu;\r\n property OnClose;\r\n property OnShowing;\r\n property OnShow;\r\n property OnShown;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvDesktopAlertForm.pas $';\r\n Revision: '$Revision: 13415 $';\r\n Date: '$Date: 2012-09-10 11:51:54 +0200 (lun. 10 sept. 2012) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n Types, Menus, SysUtils,\r\n JvJVCLUtils, JvDesktopAlert, JvResources;\r\n\r\n{.$R *.dfm} // not needed\r\n\r\nconst\r\n cAlphaIncrement = 5;\r\n cCaptionHeight = 8;\r\n\r\n JvDefaultCaptionDotColor = TColor($00F8FCF8);\r\n JvDefaultCaptionDotShadowColor = TColor($00B8BCB8);\r\n JvDefaultTrackBorderColor = TColor($00663300);\r\n JvDefaultHotTrackColor = TColor($00CC9999);\r\n JvDefaultTrackColor = TColor($00D6BEB5);\r\n\r\nprocedure DrawDesktopAlertCaption(Canvas: TCanvas; ARect: TRect; ColorFrom, ColorTo: TColor; DrawDots: Boolean);\r\nvar\r\n I: Integer;\r\n R: TRect;\r\nbegin\r\n GradientFillRect(Canvas, ARect, ColorFrom, ColorTo, fdTopToBottom, cCaptionHeight);\r\n R := ARect;\r\n Inc(R.Left, (R.Right - R.Left) div 2 - 20);\r\n Inc(R.Top, 3);\r\n R.Right := R.Left + 2;\r\n R.Bottom := R.Top + 2;\r\n if DrawDots then\r\n for I := 0 to 9 do // draw the dots\r\n begin\r\n Canvas.Brush.Color := clGray;\r\n Canvas.FillRect(R);\r\n OffsetRect(R, 1, 1);\r\n Canvas.Brush.Color := JvDefaultCaptionDotColor;\r\n Canvas.FillRect(R);\r\n Canvas.Brush.Color := JvDefaultCaptionDotShadowColor;\r\n Canvas.FillRect(Rect(R.Left, R.Top, R.Left + 1, R.Top + 1));\r\n OffsetRect(R, 3, -1);\r\n end;\r\nend;\r\n\r\nprocedure DrawDesktopAlertWindow(Canvas: TCanvas; WindowRect: TRect;\r\n FrameColor: TColor; WindowColorFrom, WindowColorTo, CaptionColorFrom, CaptionColorTo: TColor; DrawDots: Boolean);\r\nvar\r\n CaptionRect: TRect;\r\n ATop: Integer;\r\n AColors: Byte;\r\nbegin\r\n CaptionRect := WindowRect;\r\n CaptionRect.Bottom := CaptionRect.Top + cCaptionHeight;\r\n DrawDesktopAlertCaption(Canvas, CaptionRect, CaptionColorFrom, CaptionColorTo, DrawDots);\r\n ATop := WindowRect.Top;\r\n WindowRect.Top := CaptionRect.Bottom + 1;\r\n Dec(WindowRect.Bottom);\r\n if WindowRect.Bottom - WindowRect.Top < 255 then\r\n AColors := WindowRect.Bottom - WindowRect.Top\r\n else\r\n AColors := 32;\r\n GradientFillRect(Canvas, WindowRect, WindowColorFrom, WindowColorTo, fdTopToBottom, AColors);\r\n WindowRect.Top := ATop;\r\n Inc(WindowRect.Bottom);\r\n Canvas.Brush.Color := clGray;\r\n Canvas.FrameRect(WindowRect);\r\nend;\r\n\r\n//=== { TJvFormDesktopAlert } ================================================\r\n\r\nconstructor TJvFormDesktopAlert.Create(AOwner: TComponent);\r\nbegin\r\n inherited CreateNew(AOwner, 1);\r\n\r\n Font.Assign(Screen.IconFont);\r\n MouseTimer := TTimer.Create(Self);\r\n MouseTimer.Enabled := False;\r\n MouseTimer.Interval := 200;\r\n MouseTimer.OnTimer := DoMouseTimer;\r\n MouseTimer.Enabled := True;\r\n\r\n BorderStyle := bsNone;\r\n BorderIcons := [];\r\n Scaled := False;\r\n Height := cDefaultAlertFormHeight;\r\n Width := cDefaultAlertFormWidth;\r\n OnPaint := FormPaint;\r\n\r\n imIcon := TImage.Create(Self);\r\n imIcon.Parent := Self;\r\n imIcon.SetBounds(8, 11, 32, 32);\r\n imIcon.AutoSize := True;\r\n imIcon.Transparent := True;\r\n\r\n lblHeader := TLabel.Create(Self);\r\n lblHeader.Parent := Self;\r\n lblHeader.SetBounds(48, 11, 71, 13);\r\n lblHeader.Font.Style := [fsBold];\r\n lblHeader.Transparent := True;\r\n\r\n lblText := TJvLabel.Create(Self);\r\n lblText.Parent := Self;\r\n lblText.SetBounds(56, 24, 67, 13);\r\n lblText.Transparent := True;\r\n lblText.WordWrap := True;\r\n lblText.Anchors := [akLeft..akBottom];\r\n\r\n acClose := TAction.Create(Self);\r\n acClose.Caption := RsClose;\r\n\r\n acClose.ShortCut := ShortCut(VK_F4, [ssAlt]); // 32883\r\n acClose.OnExecute := acCloseExecute;\r\n\r\n tbClose := TJvDesktopAlertButton.Create(Self);\r\n tbClose.ToolType := abtClose;\r\n tbClose.Parent := Self;\r\n tbClose.SetBounds(Width - 17, cCaptionHeight + 2, 15, 15);\r\n tbClose.Anchors := [akRight, akTop];\r\n\r\n tbDropDown := TJvDesktopAlertButton.Create(Self);\r\n tbDropDown.ToolType := abtDropDown;\r\n tbDropDown.Parent := Self;\r\n tbDropDown.BoundsRect := tbClose.BoundsRect;\r\n tbDropDown.Left := tbDropDown.Left - 16;\r\n tbDropDown.Anchors := [akRight, akTop];\r\n tbDropDown.OnDropDownMenu := DoDropDownMenu;\r\n tbDropDown.OnDropDownClose := DoDropDownClose;\r\nend;\r\n\r\nprocedure TJvFormDesktopAlert.InternalDoShow;\r\nbegin\r\n lblText.HotTrackFont.Style := [fsUnderLine];\r\n lblText.HotTrackFont.Color := clNavy;\r\n if ClickableMessage then\r\n begin\r\n lblText.HotTrack := True;\r\n lblText.Cursor := crHandPoint;\r\n end\r\n else\r\n begin\r\n lblText.HotTrack := False;\r\n lblText.Cursor := crDefault;\r\n end;\r\n\r\n if tbDropDown.DropDownMenu = nil then\r\n tbDropDown.Visible := False;\r\n\r\n // if the form is not closeable, then do not show the button\r\n if not Closeable then\r\n begin\r\n tbClose.Visible := False;\r\n tbDropDown.Left := tbClose.Left;\r\n end;\r\n\r\n imIcon.Top := 13;\r\n lblHeader.Top := imIcon.Top;\r\n lblHeader.Left := imIcon.Left + imIcon.Width + 5;\r\n lblText.Left := lblHeader.Left + 8;\r\n lblText.Width := tbDropDown.Left - lblText.Left;\r\n lblText.Top := lblHeader.Top + lblHeader.Height;\r\nend;\r\n\r\n//=== { TJvDesktopAlertButton } ==============================================\r\n\r\nconstructor TJvDesktopAlertButton.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FChangeLink := TChangeLink.Create;\r\n FChangeLink.OnChange := DoImagesChange;\r\n Width := 21;\r\n Height := 21;\r\nend;\r\n\r\ndestructor TJvDesktopAlertButton.Destroy;\r\nbegin\r\n FChangeLink.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvDesktopAlertButton.DoImagesChange(Sender: TObject);\r\nbegin\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvDesktopAlertButton.MouseEnter(Control: TControl);\r\nbegin\r\n inherited;\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvDesktopAlertButton.MouseLeave(Control: TControl);\r\nbegin\r\n inherited;\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvDesktopAlertButton.Notification(AComponent: TComponent; Operation: TOperation);\r\nbegin\r\n inherited Notification(AComponent, Operation);\r\n if Operation = opRemove then\r\n if AComponent = Images then\r\n Images := nil;\r\nend;\r\n\r\nprocedure TJvDesktopAlertButton.Paint;\r\nconst\r\n cMarlett = 'Marlett';\r\nvar\r\n Rect: TRect;\r\nbegin\r\n with Canvas do\r\n begin\r\n Rect := ClientRect;\r\n Brush.Style := bsClear;\r\n if bsMouseInside in MouseStates then\r\n begin\r\n Pen.Color := JvDefaultTrackBorderColor;\r\n Rectangle(Rect);\r\n InflateRect(Rect, -1, -1);\r\n if bsMouseDown in MouseStates then\r\n Brush.Color := JvDefaultHotTrackColor\r\n else\r\n Brush.Color := JvDefaultTrackColor;\r\n FillRect(Rect);\r\n end;\r\n case ToolType of\r\n abtArrowLeft:\r\n begin\r\n Canvas.Font.Name := cMarlett;\r\n Canvas.Font.Style := [];\r\n Canvas.Font.Size := 10;\r\n DrawText(Canvas.Handle, '3', 1, Rect, DT_SINGLELINE or DT_CENTER or DT_VCENTER);\r\n end;\r\n abtArrowRight:\r\n begin\r\n Canvas.Font.Name := cMarlett;\r\n Canvas.Font.Style := [];\r\n Canvas.Font.Size := 10;\r\n DrawText(Canvas.Handle, '4', 1, Rect, DT_SINGLELINE or DT_CENTER or DT_VCENTER);\r\n end;\r\n abtClose:\r\n begin\r\n Canvas.Font.Name := cMarlett;\r\n Canvas.Font.Size := 7;\r\n Canvas.Font.Style := [];\r\n DrawText(Canvas.Handle, 'r', 1, Rect, DT_SINGLELINE or DT_CENTER or DT_VCENTER);\r\n end;\r\n abtMaximize:\r\n begin\r\n Canvas.Font.Name := cMarlett;\r\n Canvas.Font.Style := [];\r\n DrawText(Canvas.Handle, '2', 1, Rect, DT_SINGLELINE or DT_CENTER or DT_VCENTER);\r\n end;\r\n abtMinimize:\r\n begin\r\n Canvas.Font.Name := cMarlett;\r\n Canvas.Font.Style := [];\r\n DrawText(Canvas.Handle, '1', 1, Rect, DT_SINGLELINE or DT_CENTER or DT_VCENTER);\r\n end;\r\n abtDropDown:\r\n begin\r\n Canvas.Font.Name := cMarlett;\r\n Canvas.Font.Size := 10;\r\n Canvas.Font.Style := [];\r\n DrawText(Canvas.Handle, 'u', 1, Rect, DT_SINGLELINE or DT_CENTER or DT_VCENTER);\r\n end;\r\n abtDropDownChevron:\r\n begin // area should be 7x12\r\n InflateRect(Rect, -((Rect.Right - Rect.Left) - 7) div 2, -((Rect.Bottom - Rect.Top) - 12) div 2);\r\n Canvas.Pen.Color := clWindowText;\r\n\r\n Canvas.MoveTo(Rect.Left, Rect.Top);\r\n Canvas.LineTo(Rect.Left + 2, Rect.Top);\r\n\r\n Canvas.MoveTo(Rect.Left + 3, Rect.Top);\r\n Canvas.LineTo(Rect.Left + 5, Rect.Top);\r\n OffsetRect(Rect, 1, 1);\r\n\r\n Canvas.MoveTo(Rect.Left, Rect.Top);\r\n Canvas.LineTo(Rect.Left + 2, Rect.Top);\r\n\r\n Canvas.MoveTo(Rect.Left + 3, Rect.Top);\r\n Canvas.LineTo(Rect.Left + 5, Rect.Top);\r\n OffsetRect(Rect, 1, 1);\r\n\r\n Canvas.MoveTo(Rect.Left, Rect.Top);\r\n Canvas.LineTo(Rect.Left + 2, Rect.Top);\r\n\r\n Canvas.MoveTo(Rect.Left + 3, Rect.Top);\r\n Canvas.LineTo(Rect.Left + 5, Rect.Top);\r\n OffsetRect(Rect, -1, 1);\r\n\r\n Canvas.MoveTo(Rect.Left, Rect.Top);\r\n Canvas.LineTo(Rect.Left + 2, Rect.Top);\r\n\r\n Canvas.MoveTo(Rect.Left + 3, Rect.Top);\r\n Canvas.LineTo(Rect.Left + 5, Rect.Top);\r\n OffsetRect(Rect, -1, 1);\r\n\r\n Canvas.MoveTo(Rect.Left, Rect.Top);\r\n Canvas.LineTo(Rect.Left + 2, Rect.Top);\r\n\r\n Canvas.MoveTo(Rect.Left + 3, Rect.Top);\r\n Canvas.LineTo(Rect.Left + 5, Rect.Top);\r\n\r\n OffsetRect(Rect, 1, 4);\r\n Canvas.MoveTo(Rect.Left, Rect.Top);\r\n Canvas.LineTo(Rect.Left + 5, Rect.Top);\r\n OffsetRect(Rect, 1, 1);\r\n Canvas.MoveTo(Rect.Left, Rect.Top);\r\n Canvas.LineTo(Rect.Left + 3, Rect.Top);\r\n OffsetRect(Rect, 1, 1);\r\n Canvas.MoveTo(Rect.Left, Rect.Top);\r\n Canvas.LineTo(Rect.Left + 1, Rect.Top);\r\n end;\r\n abtRestore:\r\n begin\r\n Canvas.Font.Name := cMarlett;\r\n Canvas.Font.Style := [];\r\n DrawText(Canvas.Handle, '3', 1, Rect, DT_SINGLELINE or DT_CENTER or DT_VCENTER);\r\n end;\r\n abtImage:\r\n begin\r\n if (Images = nil) or (ImageIndex < 0) or (ImageIndex >= Images.Count) then\r\n Exit;\r\n Images.Draw(Canvas,\r\n (Width - Images.Width) div 2 + Ord(bsMouseDown in MouseStates),\r\n (Height - Images.Height) div 2 + Ord(bsMouseDown in MouseStates),\r\n ImageIndex,\r\n dsTransparent,\r\n itImage,\r\n Enabled);\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvDesktopAlertButton.SetImageIndex(const Value: TImageIndex);\r\nbegin\r\n if FImageIndex <> Value then\r\n begin\r\n FImageIndex := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvDesktopAlertButton.SetImages(const Value: TCustomImageList);\r\nbegin\r\n if ReplaceImageListReference(Self, Value, FImages, FChangeLink) then\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvDesktopAlertButton.SetToolType(const Value: TJvDesktopAlertButtonType);\r\nbegin\r\n if FToolType <> Value then\r\n begin\r\n FToolType := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvFormDesktopAlert.DoButtonClick(Sender: TObject);\r\nvar\r\n FEndInterval: Cardinal;\r\nbegin\r\n if Sender is TJvDesktopAlertButton then\r\n begin\r\n FEndInterval := TJvDesktopAlert(Owner).StyleHandler.EndInterval;\r\n try\r\n // stop the animation while the OnClick handler executes:\r\n // we don't want the form to disappear before we return\r\n TJvDesktopAlert(Owner).StyleHandler.EndInterval := 0;\r\n if Assigned(TJvDesktopAlertButton(Sender).InternalClick) then\r\n TJvDesktopAlertButton(Sender).InternalClick(Sender);\r\n finally\r\n TJvDesktopAlert(Owner).StyleHandler.EndInterval := FEndInterval;\r\n if not MouseInControl then\r\n TJvDesktopAlert(Owner).StyleHandler.DoEndAnimation;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvFormDesktopAlert.DoDropDownClose(Sender: TObject);\r\nbegin\r\n // restore previous EndInterval value\r\n if FEndInterval <> 0 then\r\n TJvDesktopAlert(Owner).StyleHandler.EndInterval := FEndInterval;\r\n FEndInterval := 0;\r\n if not MouseInControl then\r\n TJvDesktopAlert(Owner).StyleHandler.DoEndAnimation;\r\nend;\r\n\r\nprocedure TJvFormDesktopAlert.DoDropDownMenu(Sender: TObject;\r\n MousePos: TPoint; var Handled: Boolean);\r\nbegin\r\n // suspend the form while the menu is visible\r\n FEndInterval := TJvDesktopAlert(Owner).StyleHandler.EndInterval;\r\n TJvDesktopAlert(Owner).StyleHandler.EndInterval := 0;\r\nend;\r\n\r\n{ TJvCustomFormDesktopAlert }\r\n\r\nprocedure TJvCustomFormDesktopAlert.acCloseExecute(Sender: TObject);\r\nbegin\r\n if Closeable then\r\n Close;\r\nend;\r\n\r\nconstructor TJvCustomFormDesktopAlert.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n\r\n MouseTimer := TTimer.Create(Self);\r\n MouseTimer.Enabled := False;\r\n MouseTimer.Interval := 200;\r\n MouseTimer.OnTimer := DoMouseTimer;\r\n MouseTimer.Enabled := True;\r\n\r\n BorderStyle := bsNone;\r\n BorderIcons := [];\r\n Scaled := False;\r\n OnPaint := FormPaint;\r\n\r\n acClose := TAction.Create(Self);\r\n acClose.Caption := RsClose;\r\n\r\n acClose.ShortCut := ShortCut(VK_F4, [ssAlt]); // 32883\r\n acClose.OnExecute := acCloseExecute;\r\nend;\r\n\r\nprocedure TJvCustomFormDesktopAlert.CreateParams(var Params: TCreateParams);\r\nbegin\r\n inherited CreateParams(Params);\r\n Params.ExStyle := Params.ExStyle or WS_EX_TOOLWINDOW;\r\n Params.WndParent := HWND_DESKTOP;\r\nend;\r\n\r\nprocedure TJvCustomFormDesktopAlert.DoClose(var Action: TCloseAction);\r\nbegin\r\n MouseTimer.Enabled := False;\r\n inherited DoClose(Action);\r\n if Action = caHide then\r\n ShowWindow(Handle, SW_HIDE);\r\nend;\r\n\r\nprocedure TJvCustomFormDesktopAlert.DoMouseTimer(Sender: TObject);\r\nvar\r\n P: TPoint;\r\n\r\n function IsInForm(P: TPoint): Boolean;\r\n var\r\n W: TControl;\r\n begin\r\n W := ControlAtPos(P, True, True);\r\n Result := (W = Self) or (FindVCLWindow(P) = Self) or ((W <> nil) and (GetParentForm(W) = Self));\r\n end;\r\n\r\nbegin\r\n // this is here to ensure that MouseInControl is correctly set even\r\n // if we never got a CM_MouseLeave (that happens a lot)\r\n MouseTimer.Enabled := False;\r\n GetCursorPos(P);\r\n FMouseInControl := PtInRect(BoundsRect, P); // and IsInForm(P);\r\n MouseTimer.Enabled := True;\r\n if not TJvCustomDesktopAlert(Owner).StyleHandler.Active and not MouseInControl and\r\n (TJvCustomDesktopAlert(Owner).StyleHandler.DisplayDuration > 0) then\r\n TJvCustomDesktopAlert(Owner).StyleHandler.DoEndAnimation;\r\nend;\r\n\r\nprocedure TJvCustomFormDesktopAlert.DoShow;\r\nbegin\r\n if Assigned(OnShowing) then\r\n OnShowing(Self);\r\n\r\n inherited DoShow;\r\n TJvCustomDesktopAlert(Owner).StyleHandler.AbortAnimation;\r\n InternalDoShow;\r\n TJvCustomDesktopAlert(Owner).StyleHandler.DoStartAnimation;\r\n MouseTimer.Enabled := True;\r\n\r\n if Assigned(OnShown) then\r\n OnShown(Self);\r\nend;\r\n\r\nprocedure TJvCustomFormDesktopAlert.FormPaint(Sender: TObject);\r\nbegin\r\n DrawDesktopAlertWindow(Canvas, ClientRect, FrameColor, WindowColorFrom, WindowColorTo, CaptionColorFrom, CaptionColorTo, Moveable or MoveAnywhere);\r\nend;\r\n\r\nfunction TJvCustomFormDesktopAlert.GetVisible: Boolean;\r\nbegin\r\n Result := IsWindowVisible(Handle);\r\nend;\r\n\r\nprocedure TJvCustomFormDesktopAlert.InternalDoShow;\r\nbegin\r\n//\r\nend;\r\n\r\nprocedure TJvCustomFormDesktopAlert.JvDeskTopAlertAutoFree(var Msg: TMessage);\r\nbegin\r\n // WParam is us, LParam is the TJvDesktopAlert\r\n if Msg.WParam = WPARAM(Self) then\r\n begin\r\n Release;\r\n TObject(Msg.LParam).Free;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomFormDesktopAlert.MouseEnter(AControl: TControl);\r\nbegin\r\n inherited MouseEnter(AControl);\r\n FMouseInControl := True;\r\n // SetFocus;\r\n TJvCustomDesktopAlert(Owner).StyleHandler.AbortAnimation;\r\n if Assigned(FOnMouseEnter) then\r\n FOnMouseEnter(Self);\r\nend;\r\n\r\nprocedure TJvCustomFormDesktopAlert.MouseLeave(AControl: TControl);\r\nvar\r\n P: TPoint;\r\nbegin\r\n inherited MouseLeave(AControl);\r\n // make sure the mouse actually left the outer boundaries\r\n GetCursorPos(P);\r\n if MouseInControl and not PtInRect(BoundsRect, P) then\r\n begin\r\n if Assigned(FOnMouseLeave) then\r\n FOnMouseLeave(Self);\r\n if not TJvCustomDesktopAlert(Owner).StyleHandler.Active and\r\n (TJvCustomDesktopAlert(Owner).StyleHandler.DisplayDuration > 0) then\r\n TJvCustomDesktopAlert(Owner).StyleHandler.DoEndAnimation;\r\n FMouseInControl := False;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomFormDesktopAlert.SetNewLeft(const Value: Integer);\r\nbegin\r\n SetNewOrigin(Value, Top);\r\nend;\r\n\r\nprocedure TJvCustomFormDesktopAlert.SetNewOrigin(ALeft, ATop: Integer);\r\nvar\r\n MoveEvent: TNotifyEvent;\r\nbegin\r\n if ((Top <> ATop) or (Left <> ALeft)) and not MouseInControl then\r\n begin\r\n MoveEvent := FOnUserMove;\r\n FOnUserMove := nil;\r\n Left := ALeft;\r\n Top := ATop;\r\n FOnUserMove := MoveEvent;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomFormDesktopAlert.SetNewTop(const Value: Integer);\r\nbegin\r\n SetNewOrigin(Left, Value);\r\nend;\r\n\r\nprocedure TJvCustomFormDesktopAlert.ShowNoActivate;\r\nbegin\r\n Visible := True;\r\n Include(FFormState, fsShowing);\r\n// Windows.SetParent(Handle, 0);\r\n//-- The above was introduced to partially solve the issue of the visible\r\n//-- TJvFormDesktopAlert(s) dropping behind another App when this App is\r\n//-- defocused.\r\n//-- Unfortunately, this re-introduces the bug of momentarily taking the focus\r\n//-- away from the active form within this App, when it has the focus.\r\n//-- A further side-effect is to set Application.Active := True\r\n SetWindowPos(Handle, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOMOVE or SWP_NOSIZE or\r\n SWP_NOACTIVATE or SWP_NOOWNERZORDER or SWP_NOREDRAW or SWP_NOSENDCHANGING);\r\n DoShow;\r\n Exclude(FFormState, fsShowing);\r\n Include(FFormState, fsVisible);\r\nend;\r\n\r\n\r\nprocedure TJvCustomFormDesktopAlert.WMActivate(var Message: TWMActivate);\r\nbegin\r\n if (Message.Active = WA_INACTIVE) or AllowFocus then\r\n inherited\r\n else\r\n Message.Result := 1;\r\nend;\r\n\r\nprocedure TJvCustomFormDesktopAlert.WMMouseActivate(var Message: TWMMouseActivate);\r\nbegin\r\n if AllowFocus then\r\n inherited\r\n else\r\n Message.Result := MA_NOACTIVATE;\r\nend;\r\n\r\nprocedure TJvCustomFormDesktopAlert.WMMove(var Msg: TWMMove);\r\nbegin\r\n inherited;\r\n if Showing and Assigned(FOnUserMove) then\r\n FOnUserMove(Self);\r\nend;\r\n\r\nprocedure TJvCustomFormDesktopAlert.WMNCHitTest(var Msg: TWMNCHitTest);\r\nvar\r\n P: TPoint;\r\nbegin\r\n P := ScreenToClient(Point(Msg.XPos, Msg.YPos));\r\n if ((P.Y <= cCaptionHeight) and Moveable) or (MoveAnywhere and (ControlAtPos(P, False) = nil)) then\r\n begin\r\n TJvCustomDesktopAlert(Owner).StyleHandler.AbortAnimation;\r\n Msg.Result := HTCAPTION;\r\n end\r\n else\r\n inherited;\r\nend;\r\n\r\n\r\ninitialization\r\n {$IFDEF UNITVERSIONING}\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n {$ENDIF UNITVERSIONING}\r\n RegisterClasses([TLabel, TImage, TAction, TJvDesktopAlertButton, TJvLabel]);\r\n\r\n{$IFDEF UNITVERSIONING}\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvDiagramShape.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvDiagramShape.PAS, released on 2002-03-22.\r\n\r\nOriginal Developer: Jim Cooper \r\nContributor(s): Michael Beck \r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvDiagramShape.pas 13104 2011-09-07 06:50:43Z obones $\r\n\r\nunit JvDiagramShape;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows,\r\n Classes, Graphics, Controls, ExtCtrls, ImgList,\r\n JvComponent;\r\n\r\ntype\r\n TJvTextShape = class;\r\n\r\n // All controls descend from this, to help with streaming and unique naming\r\n TJvCustomDiagramShape = class(TJvGraphicControl)\r\n private\r\n FCanProcessMouseMsg: Boolean;\r\n FCaption: TJvTextShape;\r\n FSelected: Boolean;\r\n FWasCovered: Boolean;\r\n FMultiSelect: Boolean;\r\n FRightClickSelect: Boolean;\r\n FAlignment: TAlignment;\r\n protected\r\n procedure SetCaption(Value: TJvTextShape); virtual;\r\n procedure MouseDown(Button: TMouseButton; Shift: TShiftState;\r\n X, Y: Integer); override;\r\n procedure MouseUp(Button: TMouseButton; Shift: TShiftState;\r\n X, Y: Integer); override;\r\n function GetCustomShapeAtPos(X, Y: Integer): TJvCustomDiagramShape;\r\n property CanProcessMouseMsg: Boolean read FCanProcessMouseMsg\r\n write FCanProcessMouseMsg;\r\n procedure SetParent(AParent: TWinControl); override;\r\n procedure SetSelected(Value: Boolean); virtual;\r\n procedure Notification(AComponent: TComponent; Operation: TOperation); override;\r\n property MultiSelect: Boolean read FMultiSelect write FMultiSelect;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n procedure SetBounds(ALeft, ATop, AWidth, AHeight: Integer); override;\r\n procedure AlignCaption(Alignment: TAlignment);\r\n // Class methods to save and load all TJvCustomDiagramShape components\r\n // that are children of a given control. They are class methods so that an\r\n // instance of TJvCustomDiagramShape is not required\r\n class procedure SaveToFile(const FileName: string; ParentControl: TWinControl);\r\n class procedure LoadFromFile(const FileName: string; ParentControl: TWinControl);\r\n class procedure DeleteAllShapes(ParentControl: TWinControl);\r\n class procedure DeleteSelectedShapes(ParentControl: TWinControl);\r\n class procedure UnselectAllShapes(ParentControl: TWinControl);\r\n class procedure SetMultiSelected(ParentControl: TWinControl; Value: Boolean);\r\n property Selected: Boolean read FSelected write SetSelected;\r\n property Caption: TJvTextShape read FCaption write SetCaption;\r\n property RightClickSelect: Boolean read FRightClickSelect write FRightClickSelect default True;\r\n property OnDblClick;\r\n end;\r\n\r\n TJvMoveableShape = class(TJvCustomDiagramShape)\r\n private\r\n FOrigin: TPoint;\r\n FMoving: Boolean;\r\n protected\r\n procedure StartMove(X, Y: Integer);\r\n procedure Move(DeltaX, DeltaY: Integer);\r\n procedure EndMove;\r\n function ValidMove(DeltaX, DeltaY: Integer): Boolean;\r\n procedure MoveShapes(DeltaX, DeltaY: Integer);\r\n procedure MouseDown(Button: TMouseButton; Shift: TShiftState;\r\n X, Y: Integer); override;\r\n procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;\r\n procedure MouseUp(Button: TMouseButton; Shift: TShiftState;\r\n X, Y: Integer); override;\r\n property Moving: Boolean read FMoving write FMoving;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n published\r\n property Caption;\r\n property RightClickSelect;\r\n // Make these properties available\r\n property OnClick;\r\n property OnDblClick;\r\n end;\r\n\r\n TJvSizingMode = (smTopLeft, smTop, smTopRight, smLeft, smRight,\r\n smBottomLeft, smBottom, smBottomRight, smNone);\r\n\r\n TJvSizeableShape = class(TJvMoveableShape)\r\n private\r\n FSizingMode: TJvSizingMode;\r\n FSizeOrigin: TPoint;\r\n FSizeRectHeight: Integer;\r\n FSizeRectWidth: Integer;\r\n FMinHeight: Integer;\r\n FMinWidth: Integer;\r\n protected\r\n procedure SetSelected(Value: Boolean); override;\r\n procedure Paint; override;\r\n procedure DrawSizingRects;\r\n function GetSizeRect(SizeRectType: TJvSizingMode): TRect;\r\n procedure CheckForSizeRects(X, Y: Integer);\r\n procedure ResizeControl(X, Y: Integer);\r\n procedure MouseDown(Button: TMouseButton; Shift: TShiftState;\r\n X, Y: Integer); override;\r\n procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;\r\n procedure MouseUp(Button: TMouseButton; Shift: TShiftState;\r\n X, Y: Integer); override;\r\n property SizingMode: TJvSizingMode read FSizingMode write FSizingMode;\r\n property SizeRectHeight: Integer read FSizeRectHeight write FSizeRectHeight;\r\n property SizeRectWidth: Integer read FSizeRectWidth write FSizeRectWidth;\r\n property MinHeight: Integer read FMinHeight write FMinHeight;\r\n property MinWidth: Integer read FMinWidth write FMinWidth;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n procedure SetBounds(ALeft, ATop, AWidth, AHeight: Integer); override;\r\n end;\r\n\r\n TJvTextShape = class(TJvSizeableShape)\r\n private\r\n FText: TCaption;\r\n FAutoSize: Boolean;\r\n FFont: TFont;\r\n procedure SetText(const Value: TCaption);\r\n procedure SetFont(Value: TFont);\r\n procedure FontChange(Sender: TObject);\r\n protected\r\n procedure SetAutoSize(Value: Boolean); override;\r\n procedure RefreshText;\r\n procedure SetParent(AParent: TWinControl); override;\r\n procedure Paint; override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n procedure SetBounds(ALeft, ATop, AWidth, AHeight: Integer); override;\r\n published\r\n property Text: TCaption read FText write SetText;\r\n property AutoSize: Boolean read FAutoSize write SetAutoSize default True;\r\n property Font: TFont read FFont write SetFont;\r\n end;\r\n\r\n TJvBitmapShape = class(TJvMoveableShape)\r\n private\r\n FImages: TImageList;\r\n FImageIndex: Integer;\r\n procedure SetImages(Value: TImageList);\r\n procedure SetImageIndex(Value: Integer);\r\n protected\r\n procedure SetSelected(Value: Boolean); override;\r\n procedure Paint; override;\r\n procedure Notification(AComponent: TComponent; Operation: TOperation); override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n published\r\n property Images: TImageList read FImages write SetImages;\r\n property ImageIndex: Integer read FImageIndex write SetImageIndex;\r\n // Make these properties available\r\n property PopupMenu;\r\n property OnMouseDown;\r\n property OnMouseUp;\r\n property OnMouseMove;\r\n property OnClick;\r\n property OnDblClick;\r\n end;\r\n\r\n TJvStandardShape = class(TJvSizeableShape)\r\n private\r\n FShapeType: TShapeType;\r\n FLineColor: TColor;\r\n procedure SetShapeType(Value: TShapeType);\r\n protected\r\n procedure Paint; override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n published\r\n property ShapeType: TShapeType read FShapeType write SetShapeType;\r\n // (rom) renamed from LineColour\r\n property LineColor: TColor read FLineColor write FLineColor default clBlack;\r\n end;\r\n\r\n TJvConnectionSide = (csLeft, csRight, csTop, csBottom);\r\n\r\n TJvConnection = class(TPersistent)\r\n private\r\n FShape: TJvCustomDiagramShape;\r\n FSide: TJvConnectionSide; // Side to connect to\r\n FOffset: Integer; // Distance from top or left of side\r\n public\r\n constructor Create;\r\n procedure Assign(Source: TPersistent); override;\r\n // Gets connection point in parent's coordinates\r\n function ConnPoint(TerminatorRect: TRect): TPoint;\r\n // Gets terminator connection point in parent's coordinates\r\n function TermPoint(TerminatorRect: TRect): TPoint;\r\n // Functions to get boundaries of the terminators\r\n function LeftMost(TerminatorRect: TRect): TPoint;\r\n function RightMost(TerminatorRect: TRect): TPoint;\r\n function TopMost(TerminatorRect: TRect): TPoint;\r\n function BottomMost(TerminatorRect: TRect): TPoint;\r\n published\r\n property Shape: TJvCustomDiagramShape read FShape write FShape;\r\n property Side: TJvConnectionSide read FSide write FSide;\r\n property Offset: Integer read FOffset write FOffset;\r\n end;\r\n\r\n TJvConnector = class(TJvCustomDiagramShape)\r\n private\r\n FLineWidth: Integer;\r\n FLineColor: TColor;\r\n // The shapes connected by this control\r\n FStartConn: TJvConnection;\r\n FEndConn: TJvConnection;\r\n // Area of the terminator symbol to be drawn (in horizontal position)\r\n FStartTermRect: TRect;\r\n FEndTermRect: TRect;\r\n // Used to track required movement of the caption\r\n FMidPoint: TPoint;\r\n procedure SetLineWidth(Value: Integer);\r\n function GetConn(Index: Integer): TJvConnection;\r\n procedure SetConn(Index: Integer; Value: TJvConnection);\r\n function GetTermRect(Index: Integer): TRect;\r\n procedure SetTermRect(Index: Integer; Value: TRect);\r\n procedure CheckSize(var AWidth, AHeight: Integer);\r\n function GetMidPoint: TPoint;\r\n protected\r\n procedure SetCaption(Value: TJvTextShape); override;\r\n procedure Paint; override;\r\n procedure Notification(AComponent: TComponent; Operation: TOperation); override;\r\n // For drawing arrows etc. Called from Paint.\r\n procedure DrawStartTerminator; virtual;\r\n procedure DrawEndTerminator; virtual;\r\n procedure MoveCaption;\r\n // Converts point from parent's coordinates to own coordinates\r\n function Convert(APoint: TPoint): TPoint;\r\n function IsConnected(ConnectedShape: TJvCustomDiagramShape): Boolean;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n // Restrict the minimum size\r\n procedure SetBounds(ALeft, ATop, AWidth, AHeight: Integer); override;\r\n // Called when moving one of the connected shapes\r\n procedure SetBoundingRect;\r\n procedure SetConnections(TheStartConn, TheEndConn: TJvConnection);\r\n property StartTermRect: TRect index 1 read GetTermRect write SetTermRect;\r\n property EndTermRect: TRect index 2 read GetTermRect write SetTermRect;\r\n published\r\n // Publish these properties so that component streaming can be used to\r\n // store them in a file\r\n property LineWidth: Integer read FLineWidth write SetLineWidth default 1;\r\n property LineColor: TColor read FLineColor write FLineColor default clBlack;\r\n property StartConn: TJvConnection index 1 read GetConn write SetConn;\r\n property EndConn: TJvConnection index 2 read GetConn write SetConn;\r\n property MidPoint: TPoint read GetMidPoint;\r\n property Caption;\r\n property RightClickSelect;\r\n // Make these properties available\r\n property OnClick;\r\n property OnDblClick;\r\n end;\r\n\r\n TJvSingleHeadArrow = class(TJvConnector)\r\n protected\r\n procedure DrawArrowHead(ConnPt, TermPt: TPoint);\r\n procedure DrawEndTerminator; override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n end;\r\n\r\n TJvSingleHeadOpenDashArrow = class(TJvConnector)\r\n protected\r\n procedure Paint; override;\r\n procedure DrawArrowHead(ConnPt, TermPt: TPoint);\r\n procedure DrawEndTerminator; override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n end;\r\n\r\n TJvBluntSingleHeadOpenDashArrow = class(TJvSingleHeadOpenDashArrow)\r\n protected\r\n procedure DrawStartTerminator; override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n end;\r\n\r\n TJvBluntSingleHeadArrow = class(TJvSingleHeadArrow)\r\n protected\r\n procedure DrawStartTerminator; override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n end;\r\n\r\n TJvSubCaseArrow = class(TJvConnector)\r\n protected\r\n procedure DrawArrowHead(ConnPt, TermPt: TPoint);\r\n procedure DrawEndTerminator; override;\r\n procedure DrawStartTerminator; override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n end;\r\n\r\n TJvDoubleHeadArrow = class(TJvSingleHeadArrow)\r\n protected\r\n procedure DrawStartTerminator; override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvDiagramShape.pas $';\r\n Revision: '$Revision: 13104 $';\r\n Date: '$Date: 2011-09-07 08:50:43 +0200 (mer. 07 sept. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n SysUtils,\r\n JvTypes, JvConsts;\r\n\r\ntype\r\n // This type is solely for the acccess to the protected MouseDown method\r\n TCrackTControl = class(TControl);\r\n\r\nvar\r\n // Used in unique naming scheme. It is global in this unit to enable a\r\n // 'memory' of the component names used during the lifetime of this unit.\r\n GlobalShapeCount: Integer = 1;\r\n\r\nprocedure NoLessThan(var Value: Integer; Limit: Integer);\r\nbegin\r\n if Value < Limit then\r\n Value := Limit;\r\nend;\r\n\r\nfunction RectHeight(ARect: TRect): Integer;\r\nbegin\r\n Result := ARect.Bottom - ARect.Top;\r\nend;\r\n\r\nfunction RectWidth(ARect: TRect): Integer;\r\nbegin\r\n Result := ARect.Right - ARect.Left;\r\nend;\r\n\r\nfunction InRect(X, Y: Integer; ARect: TRect): Boolean;\r\nbegin\r\n Result := (X >= ARect.Left) and (X <= ARect.Right) and\r\n (Y >= ARect.Top) and (Y <= ARect.Bottom);\r\nend;\r\n\r\nfunction Min(A: array of Integer): Integer;\r\nvar\r\n I: Integer;\r\nbegin\r\n // (rom) the \"Purely\" comment is wrong\r\n // (rom) the function explicitly handles empty arrays\r\n Result := 0; // Purely to stop compiler warnings\r\n for I := Low(A) to High(A) do\r\n if I = Low(A) then\r\n Result := A[I]\r\n else\r\n if A[I] < Result then\r\n Result := A[I];\r\nend;\r\n\r\nfunction Max(A: array of Integer): Integer;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := 0; // Purely to stop compiler warnings\r\n for I := Low(A) to High(A) do\r\n if I = Low(A) then\r\n Result := A[I]\r\n else\r\n if A[I] > Result then\r\n Result := A[I];\r\nend;\r\n\r\n//=== { TJvCustomDiagramShape } ==============================================\r\n\r\nconstructor TJvCustomDiagramShape.Create(AOwner: TComponent);\r\nvar\r\n AlreadyUsed: Boolean;\r\n I: Integer;\r\n TempName: string;\r\nbegin\r\n inherited Create(AOwner);\r\n FCanProcessMouseMsg := True;\r\n FCaption := nil;\r\n FSelected := False;\r\n FWasCovered := False;\r\n\r\n // (rom) this was removed, but should be handled\r\n //if AOwner = nil then\r\n //Exit;\r\n // Give the component a name and ensure that it is unique\r\n repeat\r\n // Use a local variable to hold the name, so that don't get exceptions\r\n // raised on duplicate names\r\n TempName := 'Shape' + IntToStr(GlobalShapeCount);\r\n Inc(GlobalShapeCount);\r\n AlreadyUsed := False;\r\n\r\n // Loop through all the components on the form to ensure that this name\r\n // is not already in use\r\n for I := 0 to Owner.ComponentCount - 1 do\r\n if Owner.Components[I].Name = TempName then\r\n begin\r\n // Try the next component name as this one is used already\r\n AlreadyUsed := True;\r\n Break;\r\n end;\r\n until not AlreadyUsed;\r\n Name := TempName;\r\nend;\r\n\r\ndestructor TJvCustomDiagramShape.Destroy;\r\nvar\r\n I: Integer;\r\nbegin\r\n FreeAndNil(FCaption);\r\n // First check that this control has been placed on a form\r\n if Assigned(Parent) then\r\n begin\r\n // Search parent control for TJvConnector components that connect\r\n // to this component\r\n I := 0;\r\n while I < Parent.ControlCount do\r\n if (Parent.Controls[I] is TJvConnector) and\r\n (TJvConnector(Parent.Controls[I]).IsConnected(Self)) then\r\n Parent.Controls[I].Free\r\n else\r\n Inc(I);\r\n end;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvCustomDiagramShape.SetCaption(Value: TJvTextShape);\r\nbegin\r\n if (Value = nil) and Assigned(FCaption) then\r\n begin\r\n FCaption.Free;\r\n FCaption := nil;\r\n end\r\n else\r\n if Value <> FCaption then\r\n begin\r\n FCaption := Value;\r\n FCaption.Parent := Self.Parent;\r\n // Ensure the caption gets aligned correctly. Ths only needs to happen if\r\n // the caption has not already been set in place (it will already be in the\r\n // right place if we are loading this from a file).\r\n if (FCaption.Left = 0) and (FCaption.Top = 0) then\r\n AlignCaption(taCenter);\r\n end;\r\nend;\r\n\r\n\r\n\r\nprocedure TJvCustomDiagramShape.SetParent(AParent: TWinControl);\r\n\r\nbegin\r\n inherited SetParent(AParent);\r\n if Assigned(FCaption) then\r\n FCaption.Parent := AParent;\r\nend;\r\n\r\nprocedure TJvCustomDiagramShape.SetSelected(Value: Boolean);\r\nbegin\r\n FSelected := Value;\r\n if Assigned(FCaption) then\r\n FCaption.SetSelected(Value);\r\nend;\r\n\r\nprocedure TJvCustomDiagramShape.SetBounds(ALeft, ATop, AWidth, AHeight: Integer);\r\nvar\r\n I: Integer;\r\nbegin\r\n inherited SetBounds(ALeft, ATop, AWidth, AHeight);\r\n if not Assigned(Parent) then\r\n Exit;\r\n // Search parent control for TJvConnector components\r\n for I := 0 to Parent.ControlCount - 1 do\r\n if Parent.Controls[I] is TJvConnector then\r\n if TJvConnector(Parent.Controls[I]).IsConnected(Self) then\r\n // Resize the connector, but don't draw it yet\r\n TJvConnector(Parent.Controls[I]).SetBoundingRect;\r\n AlignCaption(FAlignment);\r\nend;\r\n\r\nprocedure TJvCustomDiagramShape.Notification(AComponent: TComponent; Operation: TOperation);\r\nbegin\r\n inherited Notification(AComponent, Operation);\r\n if Operation = opRemove then\r\n if AComponent = FCaption then\r\n FCaption := nil;\r\nend;\r\n\r\nprocedure TJvCustomDiagramShape.MouseDown(Button: TMouseButton; Shift: TShiftState;\r\n X, Y: Integer);\r\nvar\r\n TempPt: TPoint;\r\n CoveredShape: TJvCustomDiagramShape;\r\nbegin\r\n if CanProcessMouseMsg then\r\n begin\r\n BringToFront;\r\n MouseCapture := True;\r\n inherited MouseDown(Button, Shift, X, Y);\r\n Exit;\r\n end;\r\n\r\n // Pass message on to any covered control capable of handling it\r\n CoveredShape := GetCustomShapeAtPos(X, Y);\r\n TempPt := Point(X, Y);\r\n MouseCapture := False;\r\n\r\n if CoveredShape <> nil then\r\n begin\r\n SendToBack;\r\n // Convert coordinates to covered shape's coordinates\r\n TempPt := CoveredShape.ScreenToClient(ClientToScreen(TempPt));\r\n // Send the mouse down message to the covered shape\r\n CoveredShape.MouseDown(Button, Shift, TempPt.X, TempPt.Y);\r\n // Flag the control as having been covered because we lose a mouse click\r\n CoveredShape.FWasCovered := True;\r\n end\r\n else\r\n if Assigned(Parent) then\r\n begin\r\n // Send mouse down message to Parent. The typecast is purely to gain access\r\n // to the Parent.MouseDown method. Need to convert coordinates to parent's\r\n // coordinates\r\n TempPt := Parent.ScreenToClient(ClientToScreen(TempPt));\r\n TCrackTControl(Parent).MouseDown(Button, Shift, TempPt.X, TempPt.Y);\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomDiagramShape.MouseUp(Button: TMouseButton; Shift: TShiftState;\r\n X, Y: Integer);\r\nbegin\r\n inherited MouseUp(Button, Shift, X, Y);\r\n if FWasCovered then\r\n begin\r\n // We will lose a mouse click, so replace it\r\n Click;\r\n FWasCovered := False;\r\n end;\r\nend;\r\n\r\nfunction TJvCustomDiagramShape.GetCustomShapeAtPos(X, Y: Integer): TJvCustomDiagramShape;\r\nvar\r\n I: Integer;\r\n Pt: TPoint;\r\nbegin\r\n Result := nil;\r\n if not Assigned(Parent) then\r\n Exit;\r\n\r\n Pt := Parent.ScreenToClient(ClientToScreen(Point(X, Y)));\r\n\r\n for I := 0 to Parent.ControlCount - 1 do\r\n if (Parent.Controls[I] <> Self) and\r\n (Parent.Controls[I] is TJvCustomDiagramShape) and\r\n TJvCustomDiagramShape(Parent.Controls[I]).CanProcessMouseMsg and\r\n InRect(Pt.X, Pt.Y, Parent.Controls[I].BoundsRect) then\r\n begin\r\n Result := TJvCustomDiagramShape(Parent.Controls[I]);\r\n Exit;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomDiagramShape.AlignCaption(Alignment: TAlignment);\r\nvar\r\n ALeft, ATop, AWidth, AHeight: Integer;\r\nbegin\r\n FAlignment := Alignment;\r\n if not Assigned(FCaption) then\r\n Exit;\r\n\r\n ALeft := Left;\r\n ATop := Top + Height + 5;\r\n AWidth := FCaption.Width;\r\n AHeight := FCaption.Height;\r\n\r\n case Alignment of\r\n taLeftJustify:\r\n ALeft := Left;\r\n taRightJustify:\r\n ALeft := Left + Width - 1;\r\n taCenter:\r\n ALeft := Left + ((Width - FCaption.Width) div 2);\r\n end;\r\n FCaption.SetBounds(ALeft, ATop, AWidth, AHeight);\r\nend;\r\n\r\nclass procedure TJvCustomDiagramShape.SaveToFile(const FileName: string;\r\n ParentControl: TWinControl);\r\nvar\r\n FS: TFileStream;\r\n Writer: TWriter;\r\n RealName: string;\r\nbegin\r\n FS := TFileStream.Create(FileName, fmCreate or fmShareDenyWrite);\r\n Writer := TWriter.Create(FS, 1024);\r\n try\r\n Writer.Root := ParentControl.Owner;\r\n RealName := ParentControl.Name;\r\n ParentControl.Name := '';\r\n Writer.WriteComponent(ParentControl);\r\n ParentControl.Name := RealName;\r\n finally\r\n Writer.Free;\r\n FS.Free;\r\n end;\r\nend;\r\n\r\nclass procedure TJvCustomDiagramShape.LoadFromFile(const FileName: string;\r\n ParentControl: TWinControl);\r\nvar\r\n FS: TFileStream;\r\n Reader: TReader;\r\n RealName: string;\r\nbegin\r\n DeleteAllShapes(ParentControl);\r\n FS := TFileStream.Create(FileName, fmOpenRead or fmShareDenyWrite);\r\n Reader := TReader.Create(FS, 1024);\r\n try\r\n // Save the parent's name, in case we are reading into a different\r\n // control than we saved the diagram from\r\n RealName := ParentControl.Name;\r\n Reader.Root := ParentControl.Owner;\r\n Reader.BeginReferences;\r\n Reader.ReadComponent(ParentControl);\r\n Reader.FixupReferences;\r\n // Restore the parent's name\r\n ParentControl.Name := RealName;\r\n finally\r\n Reader.EndReferences;\r\n Reader.Free;\r\n FS.Free;\r\n end;\r\nend;\r\n\r\nclass procedure TJvCustomDiagramShape.DeleteAllShapes(ParentControl: TWinControl);\r\nvar\r\n I: Integer;\r\nbegin\r\n // Delete controls from ParentControl\r\n I := 0;\r\n // (rom) added Assigned for security\r\n if Assigned(ParentControl) then\r\n while I < ParentControl.ControlCount do\r\n if ParentControl.Controls[I] is TJvCustomDiagramShape then\r\n ParentControl.Controls[I].Free\r\n // Note that there is no need to increment the counter, because the\r\n // next component (if any) will now be at the same position in Controls[]\r\n else\r\n Inc(I);\r\nend;\r\n\r\nclass procedure TJvCustomDiagramShape.DeleteSelectedShapes(ParentControl: TWinControl);\r\nvar\r\n I: Integer;\r\nbegin\r\n // Delete controls from ParentControl if they are flagged as selected\r\n I := 0;\r\n // (rom) added Assigned for security\r\n if Assigned(ParentControl) then\r\n while I < ParentControl.ControlCount do\r\n if (ParentControl.Controls[I] is TJvCustomDiagramShape) and\r\n (TJvCustomDiagramShape(ParentControl.Controls[I]).Selected) then\r\n ParentControl.Controls[I].Free\r\n // Note that there is no need to increment the counter, because the\r\n // next component (if any) will now be at the same position in Controls[]\r\n else\r\n Inc(I);\r\nend;\r\n\r\nclass procedure TJvCustomDiagramShape.UnselectAllShapes(ParentControl: TWinControl);\r\nvar\r\n I: Integer;\r\nbegin\r\n // (rom) added Assigned for security\r\n if Assigned(ParentControl) then\r\n for I := 0 to ParentControl.ControlCount - 1 do\r\n if ParentControl.Controls[I] is TJvCustomDiagramShape then\r\n TJvCustomDiagramShape(ParentControl.Controls[I]).Selected := False;\r\nend;\r\n\r\nclass procedure TJvCustomDiagramShape.SetMultiSelected(ParentControl: TWinControl;\r\n Value: Boolean);\r\nvar\r\n I: Integer;\r\nbegin\r\n if Assigned(ParentControl) then\r\n for I := 0 to ParentControl.ControlCount - 1 do\r\n if ParentControl.Controls[I] is TJvCustomDiagramShape then\r\n TJvCustomDiagramShape(ParentControl.Controls[I]).MultiSelect := Value;\r\nend;\r\n\r\n//=== { TJvMoveableShape } ===================================================\r\n\r\nconstructor TJvMoveableShape.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n Selected := False;\r\n Moving := False;\r\n FOrigin := Point(0, 0);\r\nend;\r\n\r\nprocedure TJvMoveableShape.StartMove(X, Y: Integer);\r\nbegin\r\n Selected := True;\r\n Moving := True;\r\n FOrigin := Point(X, Y);\r\nend;\r\n\r\nprocedure TJvMoveableShape.Move(DeltaX, DeltaY: Integer);\r\nbegin\r\n SetBounds(Left + DeltaX, Top + DeltaY, Width, Height);\r\nend;\r\n\r\nprocedure TJvMoveableShape.EndMove;\r\nbegin\r\n Moving := False;\r\n FOrigin := Point(0, 0);\r\nend;\r\n\r\nfunction TJvMoveableShape.ValidMove(DeltaX, DeltaY: Integer): Boolean;\r\nbegin\r\n Result := True;\r\n if not Assigned(Parent) then\r\n Exit;\r\n\r\n if Selected then\r\n Result := (Left + DeltaX >= 0) and (Top + DeltaY >= 0) and\r\n (Left + DeltaX + Width - 1 < Parent.ClientRect.Right - Parent.ClientRect.Left) and\r\n (Top + DeltaY + Height - 1 < Parent.ClientRect.Bottom - Parent.ClientRect.Top);\r\nend;\r\n\r\nprocedure TJvMoveableShape.MoveShapes(DeltaX, DeltaY: Integer);\r\nvar\r\n I, Pass: Integer;\r\n TempControl: TControl;\r\nbegin\r\n if not Assigned(Parent) then\r\n Exit;\r\n\r\n // Do 2 passes through controls. The first one is to check that all\r\n // movements are valid\r\n for Pass := 1 to 2 do\r\n begin\r\n for I := 0 to Parent.ControlCount - 1 do\r\n begin\r\n TempControl := Parent.Controls[I];\r\n if TempControl is TJvMoveableShape then\r\n begin\r\n if (Pass = 1) and\r\n (not TJvMoveableShape(TempControl).ValidMove(DeltaX, DeltaY)) then\r\n Exit\r\n else\r\n if (Pass = 2) and TJvMoveableShape(TempControl).Selected then\r\n TJvMoveableShape(TempControl).Move(DeltaX, DeltaY);\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvMoveableShape.MouseDown(Button: TMouseButton; Shift: TShiftState;\r\n X, Y: Integer);\r\nbegin\r\n inherited MouseDown(Button, Shift, X, Y);\r\n // Only respond to left mouse button events\r\n if Button <> mbLeft then\r\n Exit;\r\n // If not holding down the shift key then not doing multiple selection\r\n if not (ssShift in Shift) then\r\n UnselectAllShapes(Parent);\r\n // Start moving the component\r\n StartMove(X, Y);\r\nend;\r\n\r\nprocedure TJvMoveableShape.MouseMove(Shift: TShiftState; X, Y: Integer);\r\nbegin\r\n inherited MouseMove(Shift, X, Y);\r\n // Only need to move the component if the left mouse button is being held down\r\n if not (ssLeft in Shift) then\r\n begin\r\n Moving := False;\r\n Exit;\r\n end;\r\n\r\n if Moving then\r\n // Move all the selected shapes\r\n MoveShapes(X - FOrigin.X, Y - FOrigin.Y);\r\nend;\r\n\r\nprocedure TJvMoveableShape.MouseUp(Button: TMouseButton; Shift: TShiftState;\r\n X, Y: Integer);\r\nvar\r\n I: Integer;\r\n TempControl: TControl;\r\nbegin\r\n inherited MouseUp(Button, Shift, X, Y);\r\n // Only interested in left mouse button events\r\n if Button <> mbLeft then\r\n Exit;\r\n\r\n EndMove;\r\n\r\n // If this shape is covering any smaller shapes then send it to the back,\r\n // so that we can get at the smaller ones\r\n if not Assigned(Parent) then\r\n Exit;\r\n for I := 0 to Parent.ControlCount - 1 do\r\n begin\r\n TempControl := Parent.Controls[I];\r\n if (TempControl <> Self) and\r\n (TempControl is TJvCustomDiagramShape) and\r\n TJvCustomDiagramShape(TempControl).CanProcessMouseMsg and\r\n InRect(TempControl.Left, TempControl.Top, BoundsRect) and\r\n InRect(TempControl.Left + TempControl.Width,\r\n TempControl.Top + TempControl.Height, BoundsRect) then\r\n begin\r\n // TempControl is not this one, it is a custom shape, that can process\r\n // mouse messages (eg not a connector), and is completely covered by\r\n // this control. So bring the convered control to the top of the z-order\r\n // so that we can access it.\r\n TempControl.BringToFront;\r\n Exit;\r\n end;\r\n end;\r\nend;\r\n\r\n//=== { TJvSizeableShape } ===================================================\r\n\r\nconstructor TJvSizeableShape.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FSizingMode := smNone;\r\n FSizeOrigin := Point(0, 0);\r\n FSizeRectHeight := 5;\r\n FSizeRectWidth := 5;\r\n FMinHeight := FSizeRectHeight;\r\n FMinWidth := FSizeRectWidth;\r\nend;\r\n\r\nprocedure TJvSizeableShape.SetSelected(Value: Boolean);\r\nbegin\r\n if Value <> FSelected then\r\n begin\r\n inherited SetSelected(Value);\r\n // Force redraw to show sizing rectangles\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvSizeableShape.Paint;\r\nbegin\r\n inherited Paint;\r\n if not Assigned(Parent) then\r\n Exit;\r\n DrawSizingRects;\r\nend;\r\n\r\nfunction TJvSizeableShape.GetSizeRect(SizeRectType: TJvSizingMode): TRect;\r\nbegin\r\n case SizeRectType of\r\n smTopLeft:\r\n Result := Bounds(0, 0, SizeRectWidth, SizeRectHeight);\r\n smTop:\r\n Result := Bounds(((ClientRect.Right - ClientRect.Left) div 2) -\r\n (SizeRectWidth div 2), 0, SizeRectWidth, SizeRectHeight);\r\n smTopRight:\r\n Result := Bounds(ClientRect.Right - SizeRectWidth, 0,\r\n SizeRectWidth, SizeRectHeight);\r\n smLeft:\r\n Result := Bounds(0, ((ClientRect.Bottom - ClientRect.Top) div 2) -\r\n (SizeRectHeight div 2), SizeRectWidth, SizeRectHeight);\r\n smRight:\r\n Result := Bounds(ClientRect.Right - SizeRectWidth,\r\n ((ClientRect.Bottom - ClientRect.Top) div 2) -\r\n (SizeRectHeight div 2), SizeRectWidth, SizeRectHeight);\r\n smBottomLeft:\r\n Result := Bounds(0, ClientRect.Bottom - SizeRectHeight,\r\n SizeRectWidth, SizeRectHeight);\r\n smBottom:\r\n Result := Bounds(((ClientRect.Right - ClientRect.Left) div 2) -\r\n (SizeRectWidth div 2), ClientRect.Bottom - SizeRectHeight,\r\n SizeRectWidth, SizeRectHeight);\r\n smBottomRight:\r\n Result := Bounds(ClientRect.Right - SizeRectWidth,\r\n ClientRect.Bottom - SizeRectHeight, SizeRectWidth, SizeRectHeight);\r\n smNone:\r\n Result := Bounds(0, 0, 0, 0);\r\n end;\r\nend;\r\n\r\nprocedure TJvSizeableShape.DrawSizingRects;\r\nvar\r\n OldBrush: TBrush;\r\n SMode: TJvSizingMode;\r\nbegin\r\n if not FSelected or not CanProcessMouseMsg then\r\n Exit;\r\n with Canvas do\r\n begin\r\n // Draw the sizing rectangles\r\n OldBrush := TBrush.Create;\r\n try\r\n OldBrush.Assign(Brush);\r\n Brush.Style := bsSolid;\r\n Brush.Color := clBlack;\r\n Pen.Color := clBlack;\r\n for SMode := smTopLeft to smBottomRight do\r\n FillRect(GetSizeRect(SMode));\r\n finally\r\n Brush.Assign(OldBrush);\r\n OldBrush.Free;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvSizeableShape.CheckForSizeRects(X, Y: Integer);\r\nconst\r\n cCursors: array [TJvSizingMode] of TCursor =\r\n (crSizeNWSE, crSizeNS, crSizeNESW, crSizeWE, crSizeWE,\r\n crSizeNESW, crSizeNS, crSizeNWSE, crDefault);\r\nvar\r\n SMode: TJvSizingMode;\r\nbegin\r\n FSizingMode := smNone;\r\n if not Selected then\r\n Exit;\r\n\r\n for SMode := smTopLeft to smBottomRight do\r\n if InRect(X, Y, GetSizeRect(SMode)) then\r\n begin\r\n SizingMode := SMode;\r\n Break;\r\n end;\r\n Cursor := cCursors[SizingMode];\r\nend;\r\n\r\nprocedure TJvSizeableShape.ResizeControl(X, Y: Integer);\r\nvar\r\n L, T, W, H, DeltaX, DeltaY: Integer;\r\nbegin\r\n L := Left;\r\n T := Top;\r\n W := Width;\r\n H := Height;\r\n DeltaX := X - FSizeOrigin.X;\r\n DeltaY := Y - FSizeOrigin.Y;\r\n // Calculate the new boundaries on the control. Also change FSizeOrigin to\r\n // reflect change in boundaries if necessary.\r\n case FSizingMode of\r\n smTopLeft:\r\n begin\r\n // Ensure that don't move the left edge if this would make the\r\n // control too narrow\r\n if (L + DeltaX >= 0) and (W - DeltaX > MinWidth) then\r\n begin\r\n L := L + DeltaX;\r\n W := W - DeltaX;\r\n end;\r\n // Ensure that don't move the top edge if this would make the\r\n // control too short\r\n if (T + DeltaY >= 0) and (H - DeltaY > MinHeight) then\r\n begin\r\n T := T + DeltaY;\r\n H := H - DeltaY;\r\n end;\r\n end;\r\n smTop:\r\n begin\r\n if (T + DeltaY >= 0) and (H - DeltaY > MinHeight) then\r\n begin\r\n T := T + DeltaY;\r\n H := H - DeltaY;\r\n end;\r\n end;\r\n smTopRight:\r\n begin\r\n W := W + DeltaX;\r\n if (T + DeltaY >= 0) and (H - DeltaY > MinHeight) then\r\n begin\r\n T := T + DeltaY;\r\n H := H - DeltaY;\r\n end;\r\n FSizeOrigin.X := X;\r\n end;\r\n smLeft:\r\n begin\r\n if (L + DeltaX >= 0) and (W - DeltaX > MinWidth) then\r\n begin\r\n L := L + DeltaX;\r\n W := W - DeltaX;\r\n end;\r\n end;\r\n smRight:\r\n begin\r\n W := W + DeltaX;\r\n FSizeOrigin.X := X;\r\n end;\r\n smBottomLeft:\r\n begin\r\n if (L + DeltaX >= 0) and (W - DeltaX > MinWidth) then\r\n begin\r\n L := L + DeltaX;\r\n W := W - DeltaX;\r\n end;\r\n H := H + DeltaY;\r\n FSizeOrigin.Y := Y;\r\n end;\r\n smBottom:\r\n begin\r\n H := H + DeltaY;\r\n FSizeOrigin.X := X;\r\n FSizeOrigin.Y := Y;\r\n end;\r\n smBottomRight:\r\n begin\r\n W := W + DeltaX;\r\n H := H + DeltaY;\r\n FSizeOrigin.X := X;\r\n FSizeOrigin.Y := Y;\r\n end;\r\n smNone: ;\r\n end;\r\n SetBounds(L, T, W, H);\r\nend;\r\n\r\nprocedure TJvSizeableShape.MouseDown(Button: TMouseButton; Shift: TShiftState;\r\n X, Y: Integer);\r\nbegin\r\n if (FSizingMode = smNone) or (Button <> mbLeft) or (ssShift in Shift) then\r\n begin\r\n // Do moving instead of sizing\r\n FSizingMode := smNone;\r\n inherited MouseDown(Button, Shift, X, Y);\r\n Exit;\r\n end;\r\n\r\n // If sizing then make this the only selected control\r\n UnselectAllShapes(Parent);\r\n BringToFront;\r\n { TODO : check on all Shapes selected }\r\n // FSelected := True;\r\n FSizeOrigin := Point(X, Y);\r\nend;\r\n\r\nprocedure TJvSizeableShape.MouseMove(Shift: TShiftState; X, Y: Integer);\r\nbegin\r\n if Moving then\r\n inherited MouseMove(Shift, X, Y)\r\n else\r\n if (FSizingMode <> smNone) and (ssLeft in Shift) then\r\n ResizeControl(X, Y)\r\n else\r\n // Check if over a sizing rectangle\r\n CheckForSizeRects(X, Y);\r\nend;\r\n\r\nprocedure TJvSizeableShape.MouseUp(Button: TMouseButton; Shift: TShiftState;\r\n X, Y: Integer);\r\nbegin\r\n if Button = mbLeft then\r\n FSizingMode := smNone;\r\n inherited MouseUp(Button, Shift, X, Y);\r\nend;\r\n\r\nprocedure TJvSizeableShape.SetBounds(ALeft, ATop, AWidth, AHeight: Integer);\r\nbegin\r\n // Check that the control bounds are sensible. The control must be at least\r\n // as large as a sizing rectangle\r\n NoLessThan(ALeft, 0);\r\n NoLessThan(ATop, 0);\r\n NoLessThan(AWidth, FMinWidth);\r\n NoLessThan(AHeight, FMinHeight);\r\n inherited SetBounds(ALeft, ATop, AWidth, AHeight);\r\nend;\r\n\r\n//=== { TJvTextShape } =======================================================\r\n\r\nconstructor TJvTextShape.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FAutoSize := True;\r\n FText := '';\r\n FFont := TFont.Create;\r\n FFont.OnChange := FontChange;\r\nend;\r\n\r\ndestructor TJvTextShape.Destroy;\r\nbegin\r\n FreeAndNil(FFont);\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvTextShape.RefreshText;\r\nvar\r\n I, Count: Integer;\r\n TempStr: string;\r\nbegin\r\n FMinHeight := FSizeRectHeight;\r\n FMinWidth := FSizeRectWidth;\r\n TempStr := '';\r\n Count := 1;\r\n if AutoSize and Assigned(Parent) then\r\n begin\r\n Canvas.Font := Font;\r\n for I := 1 to Length(FText) do\r\n begin\r\n if FText[I] = Lf then\r\n begin\r\n // Check the width of this line\r\n FMinWidth := Max([FMinWidth, Canvas.TextWidth(TempStr)]);\r\n TempStr := '';\r\n // Count the line feeds\r\n Inc(Count);\r\n end\r\n else\r\n TempStr := TempStr + FText[I];\r\n end;\r\n if Count = 1 then\r\n // In case there is only one line\r\n FMinWidth := Max([FMinWidth, Canvas.TextWidth(FText)]);\r\n // Calculate the height of the text rectangle\r\n FMinHeight := Max([FMinHeight, Canvas.TextHeight(FText) * Count]);\r\n end;\r\n SetBounds(Left, Top, FMinWidth, FMinHeight);\r\nend;\r\n\r\n\r\n\r\nprocedure TJvTextShape.SetText(const Value: TCaption);\r\nbegin\r\n if FText <> Value then\r\n begin\r\n FText := Value;\r\n RefreshText;\r\n end;\r\nend;\r\n\r\nprocedure TJvTextShape.SetAutoSize(Value: Boolean);\r\nbegin\r\n if FAutoSize <> Value then\r\n begin\r\n FAutoSize := Value;\r\n RefreshText;\r\n end;\r\nend;\r\n\r\nprocedure TJvTextShape.SetFont(Value: TFont);\r\nbegin\r\n FFont.Assign(Value);\r\nend;\r\n\r\nprocedure TJvTextShape.FontChange(Sender: TObject);\r\nbegin\r\n RefreshText;\r\nend;\r\n\r\n\r\n\r\nprocedure TJvTextShape.SetParent(AParent: TWinControl);\r\n\r\nbegin\r\n inherited SetParent(AParent);\r\n RefreshText;\r\nend;\r\n\r\nprocedure TJvTextShape.Paint;\r\nvar\r\n TempRect: TRect;\r\nbegin\r\n if not Assigned(Parent) then\r\n Exit;\r\n Canvas.Font := Font;\r\n TempRect := ClientRect; // So can pass as a var parameter\r\n DrawText(Canvas.Handle, PCaptionChar(FText), Length(FText), TempRect,\r\n DT_CENTER or DT_NOPREFIX or DT_WORDBREAK);\r\n inherited Paint;\r\nend;\r\n\r\nprocedure TJvTextShape.SetBounds(ALeft, ATop, AWidth, AHeight: Integer);\r\nbegin\r\n // Check that the control bounds are sensible. Note that this also works\r\n // if try to set Left, Top etc properties, as their access methods call\r\n // SetBounds().\r\n NoLessThan(AWidth, FMinWidth);\r\n NoLessThan(AHeight, FMinHeight);\r\n inherited SetBounds(ALeft, ATop, AWidth, AHeight);\r\nend;\r\n\r\n//=== { TJvBitmapShape } =====================================================\r\n\r\nconstructor TJvBitmapShape.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FImages := nil;\r\n FImageIndex := 0;\r\nend;\r\n\r\nprocedure TJvBitmapShape.SetSelected(Value: Boolean);\r\nbegin\r\n if Value <> FSelected then\r\n begin\r\n inherited SetSelected(Value);\r\n // Force redraw to show focus rectangle\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvBitmapShape.SetImages(Value: TImageList);\r\nbegin\r\n if Value <> FImages then\r\n begin\r\n FImages := Value;\r\n if FImages <> nil then\r\n // Set the size of the component to the image size\r\n SetBounds(Left, Top, FImages.Width, FImages.Height);\r\n end;\r\nend;\r\n\r\nprocedure TJvBitmapShape.SetImageIndex(Value: Integer);\r\nbegin\r\n if Value <> FImageIndex then\r\n begin\r\n FImageIndex := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvBitmapShape.Paint;\r\nvar\r\n OldPen: TPen;\r\nbegin\r\n inherited Paint;\r\n if (not Assigned(Parent)) or (not Assigned(FImages)) or\r\n (FImageIndex < 0) or (FImageIndex >= FImages.Count) then\r\n // The component has not been placed on a form yet, or does not have an\r\n // associated image\r\n Exit;\r\n\r\n // Draw a focus rectangle\r\n OldPen := Canvas.Pen;\r\n Canvas.Pen.Style := psDot;\r\n Canvas.Brush.Style := bsClear;\r\n\r\n if Selected then\r\n Canvas.Pen.Mode := pmNot\r\n else\r\n Canvas.Pen.Mode := pmNop;\r\n\r\n // (rom) draws a rectangle\r\n Canvas.Polyline([Point(0, 0), Point(Width - 1, 0),\r\n Point(Width - 1, Height - 1), Point(0, Height - 1), Point(0, 0)]);\r\n Canvas.Pen := OldPen;\r\n\r\n // Draw the bitmap\r\n FImages.DrawingStyle := dsTransparent;\r\n FImages.Draw(Canvas, 0, 0, FImageIndex);\r\nend;\r\n\r\nprocedure TJvBitmapShape.Notification(AComponent: TComponent; Operation: TOperation);\r\nbegin\r\n inherited Notification(AComponent, Operation);\r\n if Operation = opRemove then\r\n if AComponent = FImages then\r\n FImages := nil;\r\nend;\r\n\r\n//=== { TJvStandardShape } ===================================================\r\n\r\nconstructor TJvStandardShape.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n // Set a default shape and size and colors\r\n FShapeType := stRectangle;\r\n Width := 100;\r\n Height := 60;\r\n FLineColor := clBlack;\r\nend;\r\n\r\nprocedure TJvStandardShape.SetShapeType(Value: TShapeType);\r\nbegin\r\n if FShapeType <> Value then\r\n begin\r\n FShapeType := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvStandardShape.Paint;\r\nvar\r\n TempRect: TRect;\r\n S: Integer;\r\nbegin\r\n inherited Paint;\r\n if not Assigned(Parent) then\r\n Exit;\r\n\r\n TempRect := ClientRect; // So can pass as a var parameter\r\n InflateRect(TempRect, -SizeRectWidth, -SizeRectHeight);\r\n\r\n // Draw shape outline\r\n Canvas.Brush.Style := bsClear;\r\n Canvas.Pen.Color := FLineColor;\r\n S := Min([TempRect.Right - TempRect.Left + 1, TempRect.Bottom - TempRect.Top + 1]);\r\n\r\n if FShapeType in [stSquare, stRoundSquare, stCircle] then\r\n begin\r\n TempRect.Right := TempRect.Left + S;\r\n TempRect.Bottom := TempRect.Top + S;\r\n end;\r\n\r\n case FShapeType of\r\n stRectangle, stSquare:\r\n Canvas.Rectangle(TempRect.Left, TempRect.Top, TempRect.Right, TempRect.Bottom);\r\n stRoundRect, stRoundSquare:\r\n Canvas.RoundRect(TempRect.Left, TempRect.Top, TempRect.Right, TempRect.Bottom,\r\n S div 4, S div 4);\r\n stCircle, stEllipse:\r\n Canvas.Ellipse(TempRect.Left, TempRect.Top, TempRect.Right, TempRect.Bottom);\r\n end;\r\nend;\r\n\r\n//=== { TJvConnection } ======================================================\r\n\r\nconstructor TJvConnection.Create;\r\nbegin\r\n inherited Create;\r\n FShape := nil;\r\n FSide := csRight;\r\n FOffset := 0;\r\nend;\r\n\r\nprocedure TJvConnection.Assign(Source: TPersistent);\r\nbegin\r\n if Source is TJvConnection then\r\n begin\r\n FShape := TJvConnection(Source).FShape;\r\n FSide := TJvConnection(Source).FSide;\r\n FOffset := TJvConnection(Source).FOffset;\r\n end\r\n else\r\n inherited Assign(Source);\r\nend;\r\n\r\nfunction TJvConnection.ConnPoint(TerminatorRect: TRect): TPoint;\r\nvar\r\n X, Y, W: Integer;\r\nbegin\r\n Result := Point(0, 0);\r\n X := 0;\r\n Y := 0;\r\n W := TerminatorRect.Right - TerminatorRect.Left;\r\n\r\n if FShape = nil then\r\n Exit;\r\n\r\n case FSide of\r\n csLeft:\r\n begin\r\n X := FShape.Left - W;\r\n Y := FShape.Top + FOffset;\r\n end;\r\n csRight:\r\n begin\r\n X := FShape.Left + FShape.Width - 1 + W;\r\n Y := FShape.Top + FOffset;\r\n end;\r\n csTop:\r\n begin\r\n X := FShape.Left + FOffset;\r\n Y := FShape.Top - W;\r\n end;\r\n csBottom:\r\n begin\r\n X := FShape.Left + FOffset;\r\n Y := FShape.Top + FShape.Height - 1 + W;\r\n end;\r\n end;\r\n Result := Point(X, Y);\r\nend;\r\n\r\nfunction TJvConnection.TermPoint(TerminatorRect: TRect): TPoint;\r\nbegin\r\n Result.X := 0;\r\n Result.Y := 0;\r\n if Shape = nil then\r\n Exit;\r\n case Side of\r\n csLeft:\r\n begin\r\n Result.X := Shape.Left;\r\n Result.Y := Shape.Top + Self.Offset;\r\n end;\r\n csRight:\r\n begin\r\n Result.X := Shape.Left + Shape.Width - 1;\r\n Result.Y := Shape.Top + Self.Offset;\r\n end;\r\n csTop:\r\n begin\r\n Result.X := Shape.Left + Self.Offset;\r\n Result.Y := Shape.Top;\r\n end;\r\n csBottom:\r\n begin\r\n Result.X := Shape.Left + Self.Offset;\r\n Result.Y := Shape.Top + Shape.Height - 1;\r\n end;\r\n else\r\n Result.X := 0;\r\n Result.Y := 0;\r\n end;\r\nend;\r\n\r\nfunction TJvConnection.LeftMost(TerminatorRect: TRect): TPoint;\r\nbegin\r\n Result := TermPoint(TerminatorRect);\r\n if Shape = nil then\r\n Exit;\r\n case Side of\r\n csLeft:\r\n Result.X := Shape.Left - RectWidth(TerminatorRect);\r\n csRight:\r\n Result.X := Shape.Left + Shape.Width;\r\n csTop, csBottom:\r\n Result.X := Shape.Left + Offset - (RectHeight(TerminatorRect) div 2);\r\n end;\r\nend;\r\n\r\nfunction TJvConnection.RightMost(TerminatorRect: TRect): TPoint;\r\nbegin\r\n Result := TermPoint(TerminatorRect);\r\n if Shape = nil then\r\n Exit;\r\n case Side of\r\n csLeft:\r\n Result.X := Shape.Left - 1;\r\n csRight:\r\n Result.X := Shape.Left + Shape.Width - 1 + RectWidth(TerminatorRect);\r\n csTop, csBottom:\r\n Result.X := Shape.Left + Offset + (RectHeight(TerminatorRect) div 2);\r\n end;\r\nend;\r\n\r\nfunction TJvConnection.TopMost(TerminatorRect: TRect): TPoint;\r\nbegin\r\n Result := TermPoint(TerminatorRect);\r\n if Shape = nil then\r\n Exit;\r\n case Side of\r\n csLeft, csRight:\r\n Result.Y := Shape.Top + Offset - (RectHeight(TerminatorRect) div 2);\r\n csTop:\r\n Result.Y := Shape.Top - RectWidth(TerminatorRect) - 1;\r\n csBottom:\r\n Result.Y := Shape.Top + Shape.Height;\r\n end;\r\nend;\r\n\r\nfunction TJvConnection.BottomMost(TerminatorRect: TRect): TPoint;\r\nbegin\r\n Result := TermPoint(TerminatorRect);\r\n if Shape = nil then\r\n Exit;\r\n case Side of\r\n csLeft, csRight:\r\n Result.Y := Shape.Top + Offset + (RectHeight(TerminatorRect) div 2);\r\n csTop:\r\n Result.Y := Shape.Top - 1;\r\n csBottom:\r\n Result.Y := Shape.Top + Shape.Height + RectWidth(TerminatorRect);\r\n end;\r\nend;\r\n\r\n//=== { TJvConnector } =======================================================\r\n\r\nconstructor TJvConnector.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FCanProcessMouseMsg := False;\r\n FLineWidth := 1;\r\n FLineColor := clBlack;\r\n FStartTermRect := Rect(0, 0, 0, 0);\r\n FEndTermRect := Rect(0, 0, 0, 0);\r\n FStartConn := TJvConnection.Create;\r\n FEndConn := TJvConnection.Create;\r\n FMidPoint := Point(0, 0);\r\nend;\r\n\r\ndestructor TJvConnector.Destroy;\r\nbegin\r\n FreeAndNil(FStartConn);\r\n FreeAndNil(FEndConn);\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvConnector.Paint;\r\nvar\r\n EndPt: TPoint;\r\nbegin\r\n inherited Paint;\r\n if not Assigned(Parent) then\r\n Exit;\r\n if Assigned(FStartConn.Shape) and Assigned(FEndConn.Shape) then\r\n begin\r\n // Draw the terminators (arrows etc)\r\n DrawStartTerminator;\r\n DrawEndTerminator;\r\n with Canvas do\r\n begin\r\n // Draw the connecting line\r\n Brush.Style := bsClear;\r\n Pen.Width := FLineWidth;\r\n Pen.Color := FLineColor;\r\n // Convert from Parent coordinates to control coordinates\r\n PenPos := Convert(FStartConn.ConnPoint(FStartTermRect));\r\n EndPt := Convert(FEndConn.ConnPoint(FEndTermRect));\r\n LineTo(EndPt.X, EndPt.Y);\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvConnector.Notification(AComponent: TComponent; Operation: TOperation);\r\nbegin\r\n inherited Notification(AComponent, Operation);\r\n if Operation = opRemove then\r\n begin\r\n // (rom) added Assigned to fix a crash\r\n if Assigned(FStartConn) and (AComponent = FStartConn.FShape) then\r\n FStartConn.FShape := nil;\r\n if Assigned(FEndConn) and (AComponent = FEndConn.FShape) then\r\n FEndConn.FShape := nil;\r\n end;\r\nend;\r\n\r\nprocedure TJvConnector.DrawStartTerminator;\r\nbegin\r\nend;\r\n\r\nprocedure TJvConnector.DrawEndTerminator;\r\nbegin\r\nend;\r\n\r\nprocedure TJvConnector.MoveCaption;\r\nvar\r\n NewMidPoint: TPoint;\r\n ALeft, ATop, ARight, ABottom: Integer;\r\nbegin\r\n if Assigned(FCaption) then\r\n begin\r\n if (FMidPoint.X = 0) and (FMidPoint.Y = 0) then\r\n FMidPoint := GetMidPoint;\r\n NewMidPoint := GetMidPoint;\r\n // Move the caption relative to the mid point of the connector\r\n // Not resizing anything, just moving an unconnected shape, so can use\r\n // faster update method than SetBounds\r\n FCaption.Invalidate;\r\n ALeft := FCaption.Left + NewMidPoint.X - FMidPoint.X;\r\n ATop := FCaption.Top + NewMidPoint.Y - FMidPoint.Y;\r\n ARight := ALeft + FCaption.Width;\r\n ABottom := ATop + FCaption.Height;\r\n FCaption.UpdateBoundsRect(Rect(ALeft, ATop, ARight, ABottom));\r\n // Save the new mid point\r\n FMidPoint := NewMidPoint;\r\n end;\r\nend;\r\n\r\nprocedure TJvConnector.CheckSize(var AWidth, AHeight: Integer);\r\nbegin\r\n // Ensure the control is at least as big as the line width\r\n NoLessThan(AHeight, FLineWidth);\r\n NoLessThan(AWidth, FLineWidth);\r\n // Ensure the control is at least as big as the start terminator rectangle\r\n NoLessThan(AHeight, RectHeight(FStartTermRect));\r\n NoLessThan(AWidth, RectWidth(FStartTermRect));\r\n // Ensure the control is at least as big as the end terminator rectangle\r\n NoLessThan(AHeight, RectHeight(FEndTermRect));\r\n NoLessThan(AWidth, RectWidth(FEndTermRect));\r\nend;\r\n\r\nprocedure TJvConnector.SetBounds(ALeft, ATop, AWidth, AHeight: Integer);\r\nbegin\r\n CheckSize(AWidth, AHeight);\r\n // Resize the connector\r\n inherited SetBounds(ALeft, ATop, AWidth, AHeight);\r\n // Move the caption\r\n MoveCaption;\r\nend;\r\n\r\nprocedure TJvConnector.SetBoundingRect;\r\nvar\r\n ALeft, ATop, AWidth, AHeight: Integer;\r\nbegin\r\n if (FStartConn.Shape = nil) or (FEndConn.Shape = nil) then\r\n Exit;\r\n ALeft := Min([FStartConn.LeftMost(FStartTermRect).X,\r\n FEndConn.LeftMost(FEndTermRect).X]);\r\n ATop := Min([FStartConn.TopMost(FStartTermRect).Y,\r\n FEndConn.TopMost(FEndTermRect).Y]);\r\n AWidth := Max([FStartConn.RightMost(FStartTermRect).X,\r\n FEndConn.RightMost(FEndTermRect).X]) - ALeft + 2;\r\n AHeight := Max([FStartConn.BottomMost(FStartTermRect).Y,\r\n FEndConn.BottomMost(FEndTermRect).Y]) - ATop + 2;\r\n CheckSize(AWidth, AHeight);\r\n Invalidate;\r\n UpdateBoundsRect(Rect(ALeft, ATop, ALeft + AWidth - 1, ATop + AHeight - 1));\r\n MoveCaption;\r\nend;\r\n\r\nprocedure TJvConnector.SetLineWidth(Value: Integer);\r\nbegin\r\n // Ensure that can always see the line!\r\n if Value >= 1 then\r\n FLineWidth := Value;\r\nend;\r\n\r\nfunction TJvConnector.GetConn(Index: Integer): TJvConnection;\r\nbegin\r\n case Index of\r\n 1:\r\n Result := FStartConn;\r\n 2:\r\n Result := FEndConn;\r\n else\r\n Result := nil;\r\n end;\r\nend;\r\n\r\nprocedure TJvConnector.SetConn(Index: Integer; Value: TJvConnection);\r\nbegin\r\n case Index of\r\n 1:\r\n FStartConn.Assign(Value);\r\n 2:\r\n FEndConn.Assign(Value);\r\n end;\r\n SetBoundingRect;\r\nend;\r\n\r\nprocedure TJvConnector.SetConnections(TheStartConn, TheEndConn: TJvConnection);\r\nbegin\r\n StartConn := TheStartConn;\r\n EndConn := TheEndConn;\r\nend;\r\n\r\nfunction TJvConnector.GetTermRect(Index: Integer): TRect;\r\nbegin\r\n case Index of\r\n 1:\r\n Result := FStartTermRect;\r\n 2:\r\n Result := FEndTermRect;\r\n end;\r\nend;\r\n\r\nprocedure TJvConnector.SetTermRect(Index: Integer; Value: TRect);\r\nbegin\r\n if (Value.Right - Value.Left >= 0) and (Value.Bottom - Value.Top >= 0) then\r\n begin\r\n case Index of\r\n 1:\r\n FStartTermRect := Value;\r\n 2:\r\n FEndTermRect := Value;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvConnector.SetCaption(Value: TJvTextShape);\r\nbegin\r\n inherited SetCaption(Value);\r\n MoveCaption;\r\nend;\r\n\r\nfunction TJvConnector.Convert(APoint: TPoint): TPoint;\r\nbegin\r\n Result := ScreenToClient(Parent.ClientToScreen(APoint));\r\nend;\r\n\r\nfunction TJvConnector.IsConnected(ConnectedShape: TJvCustomDiagramShape): Boolean;\r\nbegin\r\n Result := (FStartConn <> nil) and (FEndConn <> nil) and (ConnectedShape <> nil) and\r\n ((FStartConn.Shape = ConnectedShape) or (FEndConn.Shape = ConnectedShape));\r\nend;\r\n\r\nfunction TJvConnector.GetMidPoint: TPoint;\r\nvar\r\n A, B: TPoint;\r\nbegin\r\n Result := Point(0, 0);\r\n if (not Assigned(FStartConn)) or (not Assigned(FEndConn)) then\r\n Exit;\r\n A := FStartConn.ConnPoint(FStartTermRect);\r\n B := FEndConn.ConnPoint(FEndTermRect);\r\n Result := Point(Min([A.X, B.X]) + Abs(A.X - B.X) div 2,\r\n Min([A.Y, B.Y]) + Abs(A.Y - B.Y) div 2);\r\nend;\r\n\r\n//=== { TJvSingleHeadArrow } =================================================\r\n\r\nconstructor TJvSingleHeadArrow.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n EndTermRect := Rect(0, 0, 25, 10);\r\nend;\r\n\r\nprocedure TJvSingleHeadArrow.DrawArrowHead(ConnPt, TermPt: TPoint);\r\nvar\r\n PointPt, Corner1Pt, Corner2Pt: TPoint;\r\nbegin\r\n with Canvas do\r\n begin\r\n Brush.Style := bsSolid;\r\n Brush.Color := FLineColor;\r\n Pen.Color := FLineColor;\r\n\r\n // Draw a line connecting the Conn and Term points\r\n PenPos := ConnPt;\r\n LineTo(TermPt.X, TermPt.Y);\r\n // Set the basic points (to be modified depending on arrow head direction\r\n PointPt := TermPt;\r\n Corner1Pt := ConnPt;\r\n Corner2Pt := ConnPt;\r\n\r\n if ConnPt.X < TermPt.X then\r\n begin\r\n // Draw a right pointing arrow head\r\n Inc(Corner1Pt.X, 10);\r\n Inc(Corner2Pt.X, 10);\r\n Dec(Corner1Pt.Y, RectHeight(EndTermRect) div 2);\r\n Inc(Corner2Pt.Y, RectHeight(EndTermRect) div 2);\r\n end\r\n else\r\n if ConnPt.X > TermPt.X then\r\n begin\r\n // Draw a left pointing arrow head\r\n Dec(Corner1Pt.X, 10);\r\n Dec(Corner2Pt.X, 10);\r\n Dec(Corner1Pt.Y, RectHeight(EndTermRect) div 2);\r\n Inc(Corner2Pt.Y, RectHeight(EndTermRect) div 2);\r\n end\r\n else\r\n if ConnPt.Y < TermPt.Y then\r\n begin\r\n // Draw a down pointing arrow head\r\n Inc(Corner1Pt.Y, 10);\r\n Inc(Corner2Pt.Y, 10);\r\n Dec(Corner1Pt.X, RectHeight(EndTermRect) div 2);\r\n Inc(Corner2Pt.X, RectHeight(EndTermRect) div 2);\r\n end\r\n else\r\n begin\r\n // Draw a up pointing arrow head\r\n Dec(Corner1Pt.Y, 10);\r\n Dec(Corner2Pt.Y, 10);\r\n Dec(Corner1Pt.X, RectHeight(EndTermRect) div 2);\r\n Inc(Corner2Pt.X, RectHeight(EndTermRect) div 2);\r\n end;\r\n Polygon([PointPt, Corner1Pt, Corner2Pt]);\r\n end;\r\nend;\r\n\r\nprocedure TJvSingleHeadArrow.DrawEndTerminator;\r\nvar\r\n ConnPt, TermPt: TPoint;\r\nbegin\r\n inherited DrawEndTerminator;\r\n if Assigned(FEndConn.Shape) then\r\n begin\r\n ConnPt := Convert(FEndConn.ConnPoint(EndTermRect));\r\n TermPt := Convert(FEndConn.TermPoint(EndTermRect));\r\n DrawArrowHead(ConnPt, TermPt);\r\n end;\r\nend;\r\n\r\n//=== { TJvSingleHeadOpenDashArrow } =========================================\r\n\r\nconstructor TJvSingleHeadOpenDashArrow.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n EndTermRect := Rect(0, 0, 25, 10);\r\nend;\r\n\r\nprocedure TJvSingleHeadOpenDashArrow.Paint;\r\nbegin\r\n Canvas.Pen.Style := psDash;\r\n inherited Paint;\r\n Canvas.Pen.Style := psSolid;\r\nend;\r\n\r\nprocedure TJvSingleHeadOpenDashArrow.DrawArrowHead(ConnPt, TermPt: TPoint);\r\nvar\r\n PointPt, Corner1Pt, Corner2Pt: TPoint;\r\nbegin\r\n with Canvas do\r\n begin\r\n Brush.Style := bsClear;\r\n Brush.Color := clWindow;\r\n Pen.Color := FLineColor;\r\n\r\n // Draw a line connecting the Conn and Term points\r\n PenPos := ConnPt;\r\n LineTo(TermPt.X, TermPt.Y);\r\n // Set the basic points (to be modified depending on arrow head direction\r\n PointPt := TermPt;\r\n Corner1Pt := ConnPt;\r\n Corner2Pt := ConnPt;\r\n\r\n if ConnPt.X < TermPt.X then\r\n begin\r\n // Draw a right pointing arrow head\r\n Inc(Corner1Pt.X, 10);\r\n Inc(Corner2Pt.X, 10);\r\n Dec(Corner1Pt.Y, RectHeight(EndTermRect) div 2);\r\n Inc(Corner2Pt.Y, RectHeight(EndTermRect) div 2);\r\n end\r\n else\r\n if ConnPt.X > TermPt.X then\r\n begin\r\n // Draw a left pointing arrow head\r\n Dec(Corner1Pt.X, 10);\r\n Dec(Corner2Pt.X, 10);\r\n Dec(Corner1Pt.Y, RectHeight(EndTermRect) div 2);\r\n Inc(Corner2Pt.Y, RectHeight(EndTermRect) div 2);\r\n end\r\n else\r\n if ConnPt.Y < TermPt.Y then\r\n begin\r\n // Draw a down pointing arrow head\r\n Inc(Corner1Pt.Y, 10);\r\n Inc(Corner2Pt.Y, 10);\r\n Dec(Corner1Pt.X, RectHeight(EndTermRect) div 2);\r\n Inc(Corner2Pt.X, RectHeight(EndTermRect) div 2);\r\n end\r\n else\r\n begin\r\n // Draw a up pointing arrow head\r\n Dec(Corner1Pt.Y, 10);\r\n Dec(Corner2Pt.Y, 10);\r\n Dec(Corner1Pt.X, RectHeight(EndTermRect) div 2);\r\n Inc(Corner2Pt.X, RectHeight(EndTermRect) div 2);\r\n end;\r\n // Polyline([Corner1Pt,PointPt,Corner2Pt]);\r\n MoveTo(PointPt.X, PointPt.Y);\r\n LineTo(Corner1Pt.X, Corner1Pt.Y);\r\n MoveTo(PointPt.X, PointPt.Y);\r\n LineTo(Corner2Pt.X, Corner2Pt.Y);\r\n end;\r\nend;\r\n\r\nprocedure TJvSingleHeadOpenDashArrow.DrawEndTerminator;\r\nvar\r\n ConnPt, TermPt: TPoint;\r\nbegin\r\n inherited DrawEndTerminator;\r\n if Assigned(FEndConn.Shape) then\r\n begin\r\n ConnPt := Convert(FEndConn.ConnPoint(EndTermRect));\r\n TermPt := Convert(FEndConn.TermPoint(EndTermRect));\r\n DrawArrowHead(ConnPt, TermPt);\r\n end;\r\nend;\r\n\r\n//=== { TJvBluntSingleHeadOpenDashArrow } ====================================\r\n\r\nconstructor TJvBluntSingleHeadOpenDashArrow.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n StartTermRect := Rect(0, 0, 10, 10);\r\nend;\r\n\r\nprocedure TJvBluntSingleHeadOpenDashArrow.DrawStartTerminator;\r\nvar\r\n ConnPt, TermPt: TPoint;\r\nbegin\r\n inherited DrawStartTerminator;\r\n if not Assigned(FStartConn.Shape) then\r\n Exit;\r\n ConnPt := Convert(FStartConn.ConnPoint(StartTermRect));\r\n TermPt := Convert(FStartConn.TermPoint(StartTermRect));\r\n // Draw a line connecting the Conn and Term points\r\n Canvas.Pen.Color := FLineColor;\r\n Canvas.PenPos := ConnPt;\r\n Canvas.LineTo(TermPt.X, TermPt.Y);\r\nend;\r\n\r\n//=== { TJvBluntSingleHeadArrow } ============================================\r\n\r\nconstructor TJvBluntSingleHeadArrow.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n StartTermRect := Rect(0, 0, 10, 10);\r\nend;\r\n\r\nprocedure TJvBluntSingleHeadArrow.DrawStartTerminator;\r\nvar\r\n ConnPt, TermPt: TPoint;\r\nbegin\r\n inherited DrawStartTerminator;\r\n if not Assigned(FStartConn.Shape) then\r\n Exit;\r\n ConnPt := Convert(FStartConn.ConnPoint(StartTermRect));\r\n TermPt := Convert(FStartConn.TermPoint(StartTermRect));\r\n // Draw a line connecting the Conn and Term points\r\n Canvas.Pen.Color := FLineColor;\r\n Canvas.PenPos := ConnPt;\r\n Canvas.LineTo(TermPt.X, TermPt.Y);\r\nend;\r\n\r\n//=== { TJvSubCaseArrow } ====================================================\r\n\r\nconstructor TJvSubCaseArrow.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n EndTermRect := Rect(0, 0, 25, 10);\r\n StartTermRect := Rect(0, 0, 10, 10);\r\nend;\r\n\r\nprocedure TJvSubCaseArrow.DrawArrowHead(ConnPt, TermPt: TPoint);\r\nvar\r\n PointPt, Corner1Pt, Corner2Pt: TPoint;\r\nbegin\r\n with Canvas do\r\n begin\r\n Brush.Style := bsSolid;\r\n Brush.Color := FLineColor;\r\n Pen.Color := FLineColor;\r\n\r\n // Draw a line connecting the Conn and Term points\r\n PenPos := ConnPt;\r\n LineTo(TermPt.X, TermPt.Y);\r\n // Set the basic points (to be modified depending on arrow head direction\r\n PointPt := TermPt;\r\n Corner1Pt := ConnPt;\r\n Corner2Pt := ConnPt;\r\n\r\n if ConnPt.X < TermPt.X then\r\n begin\r\n // Draw a right pointing arrow head\r\n Inc(Corner1Pt.X, 10);\r\n Inc(Corner2Pt.X, 10);\r\n Dec(Corner1Pt.Y, RectHeight(EndTermRect) div 2);\r\n Inc(Corner2Pt.Y, RectHeight(EndTermRect) div 2);\r\n end\r\n else\r\n if ConnPt.X > TermPt.X then\r\n begin\r\n // Draw a left pointing arrow head\r\n Dec(Corner1Pt.X, 10);\r\n Dec(Corner2Pt.X, 10);\r\n Dec(Corner1Pt.Y, RectHeight(EndTermRect) div 2);\r\n Inc(Corner2Pt.Y, RectHeight(EndTermRect) div 2);\r\n end\r\n else\r\n if ConnPt.Y < TermPt.Y then\r\n begin\r\n // Draw a down pointing arrow head\r\n Inc(Corner1Pt.Y, 10);\r\n Inc(Corner2Pt.Y, 10);\r\n Dec(Corner1Pt.X, RectHeight(EndTermRect) div 2);\r\n Inc(Corner2Pt.X, RectHeight(EndTermRect) div 2);\r\n end\r\n else\r\n begin\r\n // Draw a up pointing arrow head\r\n Dec(Corner1Pt.Y, 10);\r\n Dec(Corner2Pt.Y, 10);\r\n Dec(Corner1Pt.X, RectHeight(EndTermRect) div 2);\r\n Inc(Corner2Pt.X, RectHeight(EndTermRect) div 2);\r\n end;\r\n Brush.Color := clWindow;\r\n Polygon([PointPt, Corner1Pt, Corner2Pt]);\r\n end;\r\nend;\r\n\r\nprocedure TJvSubCaseArrow.DrawEndTerminator;\r\nvar\r\n ConnPt, TermPt: TPoint;\r\nbegin\r\n inherited DrawEndTerminator;\r\n if Assigned(FEndConn.Shape) then\r\n begin\r\n ConnPt := Convert(FEndConn.ConnPoint(EndTermRect));\r\n TermPt := Convert(FEndConn.TermPoint(EndTermRect));\r\n DrawArrowHead(ConnPt, TermPt);\r\n end;\r\nend;\r\n\r\nprocedure TJvSubCaseArrow.DrawStartTerminator;\r\nvar\r\n ConnPt, TermPt: TPoint;\r\nbegin\r\n inherited DrawStartTerminator;\r\n if not Assigned(FStartConn.Shape) then\r\n Exit;\r\n ConnPt := Convert(FStartConn.ConnPoint(StartTermRect));\r\n TermPt := Convert(FStartConn.TermPoint(StartTermRect));\r\n // Draw a line connecting the Conn and Term points\r\n Canvas.Pen.Color := FLineColor;\r\n Canvas.PenPos := ConnPt;\r\n Canvas.LineTo(TermPt.X, TermPt.Y);\r\nend;\r\n\r\n//=== { TJvDoubleHeadArrow } =================================================\r\n\r\nconstructor TJvDoubleHeadArrow.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n StartTermRect := EndTermRect;\r\nend;\r\n\r\nprocedure TJvDoubleHeadArrow.DrawStartTerminator;\r\nvar\r\n ConnPt, TermPt: TPoint;\r\nbegin\r\n inherited DrawStartTerminator;\r\n if Assigned(FStartConn.Shape) then\r\n begin\r\n ConnPt := Convert(FStartConn.ConnPoint(StartTermRect));\r\n TermPt := Convert(FStartConn.TermPoint(StartTermRect));\r\n DrawArrowHead(ConnPt, TermPt);\r\n end;\r\nend;\r\n\r\n//=== Initialisation and cleanup routines ====================================\r\n\r\nprocedure RegisterStorageClasses;\r\nbegin\r\n {$IFDEF COMPILER7_UP}\r\n GroupDescendentsWith(TJvConnection, TControl);\r\n {$ENDIF COMPILER7_UP}\r\n RegisterClasses([TJvCustomDiagramShape, TJvMoveableShape,\r\n TJvSizeableShape, TJvConnection, TJvConnector, TJvSingleHeadArrow,\r\n TJvBluntSingleHeadArrow, TJvDoubleHeadArrow, TJvBitmapShape,\r\n TJvTextShape, TJvStandardShape, TJvSingleHeadOpenDashArrow,\r\n TJvBluntSingleHeadOpenDashArrow, TJvSubCaseArrow]);\r\nend;\r\n\r\ninitialization\r\n {$IFDEF UNITVERSIONING}\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n {$ENDIF UNITVERSIONING}\r\n RegisterStorageClasses;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvDialButton.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvRadioGroup.PAS, released on 2002-07-16.\r\n\r\nThe Initial Developer of the Original Code is Rudolph Velthuis\r\nPortions created by Rudolph Velthuis are Copyright (C) 1997 drs. Rudolph Velthuis.\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\n marcelb - renaming TJvDialButton, adding on/off state and on/off color for pointer.\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nDescription:\r\n TJvDialButton component, a button like the dial on a radio.\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvDialButton.pas 13212 2012-02-23 12:47:24Z obones $\r\n\r\nunit JvDialButton;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, Messages, Classes, Graphics, Controls, Forms, ExtCtrls, ComCtrls,\r\n JvComponent;\r\n\r\ntype\r\n TJvDialPointerShape = (psLine, psTriangle, psDot, psOwnerDraw);\r\n TJvTickLength = (tlShort, tlMiddle, tlLong);\r\n TJvDialAngle = 0..3600; // 0.0 - 360.0 deg // in decidegrees (use 100 for 10 degrees)\r\n TJvRepeatValue = 10..1000; // mouse repeat values\r\n TJvCustomDialButton = class;\r\n TJvDialDrawEvent = procedure(Sender: TJvCustomDialButton; ARect: TRect) of object;\r\n TJvDialComputeTicks = procedure(Sender: TJvCustomDialButton) of object;\r\n\r\n PTick = ^TTick;\r\n TTick = record\r\n Value: Integer;\r\n Length: Integer;\r\n Color: TColor;\r\n Changed: Boolean;\r\n end;\r\n\r\n TJvCustomDialButton = class(TJvCustomControl)\r\n private\r\n FBitmap: TBitmap;\r\n FBitmapRect: TRect;\r\n FBitmapInvalid: Boolean;\r\n FBorderStyle: TBorderStyle;\r\n FButtonEdge: Integer;\r\n FDefaultPos: Integer;\r\n FFrequency: Integer;\r\n FLargeChange: Integer;\r\n FMax: Integer;\r\n FMaxAngle: TJvDialAngle;\r\n FMin: Integer;\r\n FMinAngle: TJvDialAngle;\r\n FPointerRect: TRect;\r\n FPointerColor: TColor;\r\n FPointerColorOff: TColor;\r\n FPointerSize: Integer;\r\n FPointerShape: TJvDialPointerShape;\r\n FPosition: Integer;\r\n FRadius: Integer;\r\n FSize: Integer;\r\n FState: Boolean;\r\n FSmallChange: Integer;\r\n FTicks: TList;\r\n FTickStyle: TTickStyle;\r\n FIncrementing: Boolean;\r\n FRepeatTimer: TTimer;\r\n FRepeatRate: TJvRepeatValue;\r\n FRepeatDelay: TJvRepeatValue;\r\n FOnChange: TNotifyEvent;\r\n FOnDrawPointer: TJvDialDrawEvent;\r\n FOnComputeTicks: TJvDialComputeTicks;\r\n function CalcBounds(var AWidth, AHeight: Integer): Boolean;\r\n function GetAngle: TJvDialAngle;\r\n function GetCenter: TPoint;\r\n procedure SetAngle(Value: TJvDialAngle);\r\n procedure SetBorderStyle(Value: TBorderStyle);\r\n procedure SetButtonEdge(Value: Integer);\r\n procedure SetDefaultPos(Value: Integer);\r\n procedure SetFrequency(Value: Integer);\r\n procedure SetLargeChange(Value: Integer);\r\n procedure SetMin(Value: Integer);\r\n procedure SetMinAngle(Value: TJvDialAngle);\r\n procedure SetMax(Value: Integer);\r\n procedure SetMaxAngle(Value: TJvDialAngle);\r\n procedure SetPointerColor(Value: TColor);\r\n procedure SetPointerColorOff(Value: TColor);\r\n procedure SetPointerSize(Value: Integer);\r\n procedure SetPointerShape(Value: TJvDialPointerShape);\r\n procedure SetPosition(Value: Integer);\r\n procedure SetRadius(Value: Integer);\r\n procedure SetSmallChange(Value: Integer);\r\n procedure SetState(Value: Boolean);\r\n procedure SetTickStyle(Value: TTickStyle);\r\n procedure UpdateSize;\r\n procedure TimerExpired(Sender: TObject);\r\n procedure ComputeTicks;\r\n protected\r\n function AngleToPos(AnAngle: TJvDialAngle): Integer;\r\n procedure BitmapNeeded; dynamic;\r\n procedure Change; dynamic;\r\n procedure ClearTicks;\r\n procedure Click; override;\r\n procedure CreateParams(var Params: TCreateParams); override;\r\n procedure CMCtl3DChanged(var Msg: TMessage); message CM_CTL3DCHANGED;\r\n procedure WMSysColorChange(var Msg: TMessage); message WM_SYSCOLORCHANGE;\r\n procedure WndProc(var Msg: TMessage); override;\r\n procedure FocusSet(PrevWnd: THandle); override;\r\n procedure FocusKilled(NextWnd: THandle); override;\r\n procedure ColorChanged; override;\r\n procedure ParentColorChanged; override;\r\n procedure DrawBorder; dynamic;\r\n procedure DrawButton; dynamic;\r\n procedure DrawPointer; dynamic;\r\n procedure DrawTick(ACanvas: TCanvas; var Tick: TTick); dynamic;\r\n procedure DrawTicks; dynamic;\r\n procedure KeyDown(var Key: Word; Shift: TShiftState); override;\r\n procedure Loaded; override;\r\n procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;\r\n procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;\r\n procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;\r\n procedure Paint; override;\r\n function PosToAngle(Pos: Integer): TJvDialAngle;\r\n procedure SetTicks(Value: TTickStyle); virtual;\r\n\r\n procedure IncPos(Shift: TShiftState); dynamic;\r\n procedure DecPos(Shift: TShiftState); dynamic;\r\n property Ticks: TList read FTicks write FTicks stored True;\r\n // to be published later:\r\n property Angle: TJvDialAngle read GetAngle write SetAngle stored False; // in decidegrees (use 100 for 10 degrees)\r\n property BorderStyle: TBorderStyle read FBorderStyle write SetBorderStyle default bsNone;\r\n property ButtonEdge: Integer read FButtonEdge write SetButtonEdge default 2;\r\n property DefaultPos: Integer read FDefaultPos write SetDefaultPos;\r\n property Frequency: Integer read FFrequency write SetFrequency default 10;\r\n property LargeChange: Integer read FLargeChange write SetLargeChange default 2;\r\n property Max: Integer read FMax write SetMax default 100;\r\n property MaxAngle: TJvDialAngle read FMaxAngle write SetMaxAngle default 3300; // in decidegrees (use 100 for 10 degrees)\r\n property Min: Integer read FMin write SetMin default 0;\r\n property MinAngle: TJvDialAngle read FMinAngle write SetMinAngle default 300; // in decidegrees (use 100 for 10 degrees)\r\n property PointerColorOn: TColor read FPointerColor write SetPointerColor default clBtnText;\r\n property PointerColorOff: TColor read FPointerColorOff write SetPointerColorOff default clGrayText;\r\n property PointerSize: Integer read FPointerSize write SetPointerSize default 33;\r\n property PointerShape: TJvDialPointerShape read FPointerShape write SetPointerShape default psLine;\r\n property Position: Integer read FPosition write SetPosition default 0;\r\n property Radius: Integer read FRadius write SetRadius;\r\n property RepeatDelay: TJvRepeatValue read FRepeatDelay write FRepeatDelay default 400;\r\n property RepeatRate: TJvRepeatValue read FRepeatRate write FRepeatRate default 100;\r\n property SmallChange: Integer read FSmallChange write SetSmallChange default 1;\r\n property State: Boolean read FState write SetState default True;\r\n property TickStyle: TTickStyle read FTickStyle write SetTickStyle stored True;\r\n property TabStop default True;\r\n property OnChange: TNotifyEvent read FOnChange write FOnChange;\r\n property OnDrawPointer: TJvDialDrawEvent read FOnDrawPointer write FOnDrawPointer;\r\n property OnComputeTicks: TJvDialComputeTicks read FOnComputeTicks write FOnComputeTicks;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n function AngleToPoint(AnAngle: TJvDialAngle; ACenter: TPoint; ARadius: Integer): TPoint;\r\n procedure SetAngleParams(AnAngle, AMin, AMax: TJvDialAngle); virtual;\r\n procedure SetBounds(ALeft, ATop, AWidth, AHeight: Integer); override;\r\n procedure SetParams(APosition, AMin, AMax: Integer); virtual;\r\n procedure SetTick(Value: Integer; Length: TJvTickLength); virtual;\r\n function RadToAngle(const Radian: Double): TJvDialAngle;\r\n function AngleToRad(AnAngle: TJvDialAngle): Double;\r\n property Bitmap: TBitmap read FBitmap;\r\n property Center: TPoint read GetCenter;\r\n end;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvDialButton = class(TJvCustomDialButton)\r\n published\r\n // properties\r\n property Align;\r\n property Angle;\r\n property BorderStyle;\r\n property ButtonEdge;\r\n property Color;\r\n property Cursor;\r\n property DefaultPos;\r\n property DragCursor;\r\n property DragMode;\r\n property Enabled;\r\n property Frequency;\r\n property LargeChange;\r\n property Max;\r\n property MaxAngle;\r\n property Min;\r\n property MinAngle;\r\n property ParentColor;\r\n property ParentShowHint;\r\n property PointerColorOn;\r\n property PointerColorOff;\r\n property PointerSize;\r\n property PointerShape;\r\n property PopupMenu;\r\n property Position;\r\n property Radius;\r\n property RepeatDelay;\r\n property RepeatRate;\r\n property ShowHint;\r\n property SmallChange;\r\n property State;\r\n property TickStyle;\r\n property TabOrder;\r\n property TabStop;\r\n property Visible;\r\n // events\r\n property OnChange;\r\n property OnClick;\r\n property OnComputeTicks;\r\n property OnDblClick;\r\n property OnDragDrop;\r\n property OnDragOver;\r\n property OnDrawPointer;\r\n property OnEndDrag;\r\n property OnEnter;\r\n property OnExit;\r\n property OnKeyDown;\r\n property OnKeyPress;\r\n property OnKeyUp;\r\n property OnMouseDown;\r\n property OnMouseMove;\r\n property OnMouseUp;\r\n property OnStartDrag;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvDialButton.pas $';\r\n Revision: '$Revision: 13212 $';\r\n Date: '$Date: 2012-02-23 13:47:24 +0100 (jeu. 23 févr. 2012) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n Consts, Math,\r\n JvThemes;\r\n\r\nconst\r\n dAngleToRadian = Pi / 1800;\r\n dRadianToAngle = 1800 / Pi;\r\n rcMaxEdge = 100;\r\n rcMinEdge = 0;\r\n rcMinRadius = 15;\r\n tlLongLen = 10;\r\n tlMiddleLen = 6;\r\n tlShortLen = 4;\r\n\r\n MinBorder = 1;\r\n TickBorder = tlLongLen;\r\n\r\nfunction GetShiftState: TShiftState;\r\nbegin\r\n Result := [];\r\n if GetKeyState(VK_SHIFT) < 0 then\r\n Include(Result, ssShift);\r\n if GetKeyState(VK_CONTROL) < 0 then\r\n Include(Result, ssCtrl);\r\n if GetKeyState(VK_MENU) < 0 then\r\n Include(Result, ssAlt);\r\nend;\r\n\r\nconstructor TJvCustomDialButton.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n ControlStyle := ControlStyle + [csClickEvents, csCaptureMouse];\r\n IncludeThemeStyle(Self, [csParentBackground]);\r\n FTicks := TList.Create;\r\n FBorderStyle := bsNone;\r\n FButtonEdge := 5;\r\n FDefaultPos := 0;\r\n FFrequency := 10;\r\n FLargeChange := 2;\r\n FMax := 100;\r\n FMaxAngle := 3300;\r\n FMin := 0;\r\n FMinAngle := 300;\r\n FPointerColor := clBtnText;\r\n FPointerColorOff := clGrayText;\r\n FPointerSize := 33;\r\n FRadius := rcMinRadius;\r\n FSmallChange := 1;\r\n FState := True;\r\n TabStop := True;\r\n FTickStyle := tsAuto;\r\n FBitmapInvalid := True;\r\n FPointerRect.Left := -1; // Only on start up\r\n Width := 51;\r\n Height := 51;\r\n FRepeatDelay := 400;\r\n FRepeatRate := 100;\r\n SetTicks(FTickStyle);\r\n Position := 0;\r\nend;\r\n\r\ndestructor TJvCustomDialButton.Destroy;\r\nbegin\r\n FBitmap.Free;\r\n ClearTicks;\r\n FTicks.Free;\r\n FRepeatTimer.Free;\r\n inherited Destroy;\r\nend;\r\n\r\n// Convert position Pos to an angle.\r\n\r\nfunction TJvCustomDialButton.PosToAngle(Pos: Integer): TJvDialAngle;\r\nbegin\r\n Result := FMinAngle + ((FMaxAngle - FMinAngle) * (Pos - FMin) div (FMax - FMin));\r\nend;\r\n\r\n// Convert angle AnAngle to a position.\r\n\r\nfunction TJvCustomDialButton.AngleToPos(AnAngle: TJvDialAngle): Integer;\r\nbegin\r\n Result := FMin + ((FMax - FMin) * (AnAngle - FMinAngle) div (FMaxAngle - FMinAngle));\r\nend;\r\n\r\n// Convert polar coordinates defined by AnAngle, ACenter and ARadius to a TPoint.\r\n\r\nfunction TJvCustomDialButton.AngleToPoint(AnAngle: TJvDialAngle; ACenter: TPoint;\r\n ARadius: Integer): TPoint;\r\nvar\r\n RadAngle: Double;\r\nbegin\r\n RadAngle := AngleToRad(AnAngle);\r\n Result.X := ACenter.X - Round(ARadius * Sin(RadAngle));\r\n Result.Y := ACenter.Y + Round(ARadius * Cos(RadAngle));\r\nend;\r\n\r\n// Convert a APoint to an angle (relative to ACenter) in radians, where\r\n// bottom is 0, left is Pi/2, top is Pi and so on.\r\n\r\nfunction PointToRad(const APoint, ACenter: TPoint): Double;\r\nvar\r\n N: Integer;\r\nbegin\r\n N := APoint.X - ACenter.X;\r\n if N = 0 then\r\n Result := 0.5 * Pi\r\n else\r\n Result := ArcTan((ACenter.Y - APoint.Y) / N);\r\n if N < 0 then\r\n Result := Result + Pi;\r\n Result := 1.5 * Pi - Result;\r\nend;\r\n\r\n// Get current angle (from position).\r\n\r\nfunction TJvCustomDialButton.GetAngle: TJvDialAngle;\r\nbegin\r\n Result := PosToAngle(FPosition);\r\nend;\r\n\r\n// Set current angle. Sets Position.\r\n\r\nprocedure TJvCustomDialButton.SetAngle(Value: TJvDialAngle);\r\nbegin\r\n SetAngleParams(Value, FMinAngle, FMaxAngle);\r\nend;\r\n\r\n// Set border style. Redraw if necessary.\r\n\r\nprocedure TJvCustomDialButton.SetBorderStyle(Value: TBorderStyle);\r\nbegin\r\n if Value <> FBorderStyle then\r\n begin\r\n FBorderStyle := Value;\r\n if HandleAllocated then\r\n begin\r\n RecreateWnd;\r\n DrawBorder;\r\n end;\r\n end;\r\nend;\r\n\r\n// Set positional (Cartesian) parameters, value checked and invalidate if\r\n// necessary.\r\n\r\nprocedure TJvCustomDialButton.SetParams(APosition, AMin, AMax: Integer);\r\nvar\r\n Invalid: Boolean;\r\n InvalidTicks: Boolean;\r\n Changed: Boolean;\r\nbegin\r\n Changed := False;\r\n\r\n // Ensure minimum and maximum in right order.\r\n if AMax < AMin then\r\n raise EInvalidOperation.CreateResFmt(@SPropertyOutOfRange, [ClassName]);\r\n\r\n // Limit Position to Min and Max.\r\n if APosition < AMin then\r\n APosition := AMin;\r\n if APosition > AMax then\r\n APosition := AMax;\r\n\r\n Invalid := False;\r\n InvalidTicks := False;\r\n\r\n // Change Min if necessary and flag redrawing if so.\r\n if FMin <> AMin then\r\n begin\r\n FMin := AMin;\r\n InvalidTicks := True;\r\n end;\r\n\r\n // Change Max if necessary and flag redrawing if so.\r\n if FMax <> AMax then\r\n begin\r\n FMax := AMax;\r\n InvalidTicks := True;\r\n end;\r\n\r\n if InvalidTicks then\r\n begin\r\n ComputeTicks;\r\n Invalid := True;\r\n end;\r\n\r\n // Change Position if necessary and draw pointer accordingly.\r\n if APosition <> FPosition then\r\n begin\r\n FPosition := APosition;\r\n DrawPointer;\r\n Changed := True;\r\n end;\r\n\r\n // If redrawing flagged, cause a redraw, redoing the bitmap too.\r\n if Invalid then\r\n begin\r\n FBitmapInvalid := True;\r\n Changed := True;\r\n Invalidate;\r\n end;\r\n\r\n if Changed then\r\n // Notify the user of changes.\r\n Change;\r\nend;\r\n\r\n// Set all angle parameters at once.\r\n\r\nprocedure TJvCustomDialButton.SetAngleParams(AnAngle, AMin, AMax: TJvDialAngle);\r\nvar\r\n Invalid: Boolean;\r\n InvalidTicks: Boolean;\r\n Pos: Integer;\r\nbegin\r\n // Error if AMax < AMin\r\n if AMax < AMin then\r\n raise EInvalidOperation.CreateResFmt(@SPropertyOutOfRange, [ClassName]);\r\n\r\n // Confine AnAngle to limits.\r\n if AnAngle < AMin then\r\n AnAngle := AMin;\r\n if AnAngle > AMax then\r\n AnAngle := AMax;\r\n Invalid := False;\r\n InvalidTicks := False;\r\n\r\n // Set MinAngle.\r\n if FMinAngle <> AMin then\r\n begin\r\n FMinAngle := AMin;\r\n InvalidTicks := True;\r\n end;\r\n\r\n // Set MaxAngle.\r\n if FMaxAngle <> AMax then\r\n begin\r\n FMaxAngle := AMax;\r\n InvalidTicks := True;\r\n end;\r\n\r\n if InvalidTicks then\r\n begin\r\n ComputeTicks;\r\n Invalid := True;\r\n end;\r\n\r\n // Redraw if necessary\r\n if Invalid then\r\n begin\r\n FBitmapInvalid := True;\r\n Invalidate;\r\n end;\r\n\r\n // Set Position.\r\n Pos := AngleToPos(AnAngle);\r\n if Pos <> FPosition then\r\n SetParams(Pos, FMin, FMax);\r\nend;\r\n\r\nprocedure TJvCustomDialButton.SetDefaultPos(Value: Integer);\r\nbegin\r\n // Change this if side effects are needed, e.g. to show a default pos marker.\r\n if Value <> FDefaultPos then\r\n FDefaultPos := Value;\r\nend;\r\n\r\nprocedure TJvCustomDialButton.SetFrequency(Value: Integer);\r\nbegin\r\n if Value <> FFrequency then\r\n begin\r\n FFrequency := Value;\r\n if FFrequency < 1 then\r\n FFrequency := 1;\r\n if FTickStyle = tsAuto then\r\n begin\r\n ClearTicks;\r\n SetTicks(FTickStyle);\r\n end;\r\n FBitmapInvalid := True;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomDialButton.SetMin(Value: Integer);\r\nbegin\r\n SetParams(FPosition, Value, FMax);\r\nend;\r\n\r\nprocedure TJvCustomDialButton.SetMinAngle(Value: TJvDialAngle);\r\nbegin\r\n SetAngleParams(PosToAngle(FPosition), Value, FMaxAngle);\r\nend;\r\n\r\nprocedure TJvCustomDialButton.SetMax(Value: Integer);\r\nbegin\r\n SetParams(FPosition, FMin, Value);\r\nend;\r\n\r\nprocedure TJvCustomDialButton.SetMaxAngle(Value: TJvDialAngle);\r\nbegin\r\n SetAngleParams(PosToAngle(FPosition), FMinAngle, Value);\r\nend;\r\n\r\nprocedure TJvCustomDialButton.SetPosition(Value: Integer);\r\nbegin\r\n SetParams(Value, FMin, FMax);\r\nend;\r\n\r\nfunction TJvCustomDialButton.CalcBounds(var AWidth, AHeight: Integer): Boolean;\r\nvar\r\n ASize: Integer;\r\nbegin\r\n Result := False;\r\n ASize := rcMinRadius + MinBorder + TickBorder;\r\n if FBorderStyle = bsSingle then\r\n Inc(ASize, GetSystemMetrics(SM_CXBORDER));\r\n ASize := 2 * ASize + 1;\r\n if AWidth < ASize then\r\n begin\r\n AWidth := ASize;\r\n Result := True;\r\n end;\r\n if AHeight < ASize then\r\n begin\r\n AHeight := ASize;\r\n Result := True;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomDialButton.SetRadius(Value: Integer);\r\nvar\r\n MaxRadius: Integer;\r\nbegin\r\n if Width <= Height then\r\n MaxRadius := (Width - 1) div 2 - MinBorder - TickBorder\r\n else\r\n MaxRadius := (Height - 1) div 2 - MinBorder - TickBorder;\r\n if FBorderStyle = bsSingle then\r\n Dec(MaxRadius, GetSystemMetrics(SM_CXBORDER));\r\n if Value > MaxRadius then\r\n Value := MaxRadius;\r\n if Value < rcMinRadius then\r\n Value := rcMinRadius;\r\n if Value <> FRadius then\r\n begin\r\n FRadius := Value;\r\n FBitmapInvalid := True;\r\n Invalidate;\r\n end;\r\n UpdateSize;\r\nend;\r\n\r\nprocedure TJvCustomDialButton.SetTicks(Value: TTickStyle);\r\nvar\r\n L: TJvTickLength;\r\n I: Integer;\r\nbegin\r\n if Value <> tsNone then\r\n begin\r\n SetTick(FMin, tlLong);\r\n SetTick(FMax, tlLong);\r\n end;\r\n if Value = tsAuto then\r\n begin\r\n I := FMin + FFrequency;\r\n L := tlMiddle;\r\n while I < FMax do\r\n begin\r\n SetTick(I, L);\r\n if L = tlMiddle then\r\n L := tlLong\r\n else\r\n L := tlMiddle;\r\n Inc(I, FFrequency);\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomDialButton.SetState(Value: Boolean);\r\nbegin\r\n if Value <> FState then\r\n begin\r\n FState := Value;\r\n DrawPointer;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomDialButton.SetTickStyle(Value: TTickStyle);\r\nbegin\r\n if FTickStyle <> Value then\r\n begin\r\n FTickStyle := Value;\r\n ComputeTicks;\r\n FBitmapInvalid := True;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomDialButton.Change;\r\nbegin\r\n if Assigned(FOnChange) then\r\n FOnChange(Self);\r\nend;\r\n\r\nprocedure TJvCustomDialButton.SetSmallChange(Value: Integer);\r\nbegin\r\n if Value > FLargeChange then\r\n Value := FLargeChange div 2;\r\n if Value < 1 then\r\n Value := 1;\r\n FSmallChange := Value;\r\nend;\r\n\r\nprocedure TJvCustomDialButton.SetLargeChange(Value: Integer);\r\nbegin\r\n if Value <= FSmallChange + 1 then\r\n Value := FSmallChange + 1;\r\n FLargeChange := Value;\r\nend;\r\n\r\nprocedure TJvCustomDialButton.SetTick(Value: Integer; Length: TJvTickLength);\r\nconst\r\n Lengths: array [TJvTickLength] of Byte =\r\n (tlShortLen, tlMiddleLen, tlLongLen);\r\nvar\r\n P: PTick;\r\n I: Integer;\r\nbegin\r\n if (Value < FMin) or (Value > FMax) then\r\n raise EInvalidOperation.CreateResFmt(@SOutOfRange, [FMin, FMax]);\r\n for I := 0 to FTicks.Count - 1 do\r\n begin\r\n P := FTicks.Items[I];\r\n if P^.Value = Value then\r\n begin\r\n if P^.Length <> Lengths[Length] then\r\n begin\r\n P^.Length := Lengths[Length];\r\n P^.Changed := True;\r\n Invalidate;\r\n end;\r\n Exit;\r\n end;\r\n end;\r\n New(P);\r\n P^.Value := Value;\r\n P^.Length := Lengths[Length];\r\n P^.Changed := True;\r\n P^.Color := clBtnText;\r\n FTicks.Add(P);\r\n if HandleAllocated then\r\n begin\r\n DrawTick(FBitmap.Canvas, P^);\r\n DrawTick(Canvas, P^);\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomDialButton.DrawTick(ACanvas: TCanvas; var Tick: TTick);\r\nvar\r\n Pt: TPoint;\r\n ValueAngle: Integer;\r\nbegin\r\n ValueAngle := PosToAngle(Tick.Value);\r\n ACanvas.Pen.Color := Tick.Color;\r\n Pt := AngleToPoint(ValueAngle, Center, FRadius);\r\n ACanvas.MoveTo(Pt.X, Pt.Y);\r\n Pt := AngleToPoint(ValueAngle, GetCenter, FRadius + Tick.Length);\r\n ACanvas.LineTo(Pt.X, Pt.Y);\r\n Tick.Changed := False;\r\nend;\r\n\r\nprocedure TJvCustomDialButton.Paint;\r\nbegin\r\n if csCreating in ControlState then\r\n Exit;\r\n Canvas.Brush.Color := Parent.Brush.Color;\r\n DrawThemedBackground(Self, Canvas, ClientRect);\r\n BitmapNeeded;\r\n Canvas.Draw(0, 0, FBitmap);\r\n DrawBorder;\r\n DrawPointer;\r\nend;\r\n\r\nprocedure TJvCustomDialButton.DrawPointer;\r\nvar\r\n Outer, Inner, Extra: TPoint;\r\n InnerRadius, DotRadius: Integer;\r\n Region: HRgn;\r\n SmallRadius: Integer;\r\n\r\n function Lowest(A, B, C: Integer): Integer;\r\n begin\r\n if A < B then\r\n if A < C then\r\n Result := A\r\n else\r\n Result := C\r\n else\r\n if B < C then\r\n Result := B\r\n else\r\n Result := C\r\n end;\r\n\r\n function Highest(A, B, C: Integer): Integer;\r\n begin\r\n if A > B then\r\n if A > C then\r\n Result := A\r\n else\r\n Result := C\r\n else\r\n if B > C then\r\n Result := B\r\n else\r\n Result := C;\r\n end;\r\n\r\nbegin\r\n if not HandleAllocated then\r\n Exit;\r\n InnerRadius := (100 - FButtonEdge) * FRadius div 100 - 1;\r\n if FPointerRect.Left < 0 then\r\n FPointerRect := Rect(Center.X - InnerRadius,\r\n Center.Y - InnerRadius,\r\n Center.X + InnerRadius + 1,\r\n Center.Y + InnerRadius + 1);\r\n Canvas.CopyRect(FPointerRect, FBitmap.Canvas, FPointerRect);\r\n // This is for a solid dot. I'd also like to make a Ctl3D type of dot or\r\n // an open type of dot. We'd also have to make a disabled type of dot.\r\n if State then\r\n begin\r\n Canvas.Pen.Color := FPointerColor;\r\n Canvas.Brush.Color := FPointerColor;\r\n end\r\n else\r\n begin\r\n Canvas.Pen.Color := FPointerColorOff;\r\n Canvas.Brush.Color := FPointerColorOff;\r\n end;\r\n case FPointerShape of\r\n psLine:\r\n begin\r\n Outer := AngleToPoint(Angle, Center, InnerRadius);\r\n Canvas.MoveTo(Outer.X, Outer.Y);\r\n Inner := AngleToPoint(Angle, Center, (101 - FPointerSize) * InnerRadius div 100);\r\n Canvas.LineTo(Inner.X, Inner.Y);\r\n FPointerRect := Rect(Math.Min(Inner.X, Outer.X),\r\n Math.Min(Inner.Y, Outer.Y),\r\n Math.Max(Inner.X, Outer.X),\r\n Math.Max(Inner.Y, Outer.Y));\r\n end;\r\n psTriangle:\r\n begin\r\n SmallRadius := FPointerSize * InnerRadius div 100;\r\n Outer := AngleToPoint(Angle, Center, InnerRadius);\r\n Inner := AngleToPoint(Angle - 1500, Outer, SmallRadius);\r\n Extra := AngleToPoint(Angle + 1500, Outer, SmallRadius);\r\n Canvas.Polygon([Outer, Inner, Extra]);\r\n FPointerRect := Rect(Lowest(Outer.X, Inner.X, Extra.X),\r\n Lowest(Outer.Y, Inner.Y, Extra.Y),\r\n Highest(Outer.X, Inner.X, Extra.X),\r\n Highest(Outer.Y, Inner.Y, Extra.Y));\r\n end;\r\n psDot:\r\n begin\r\n DotRadius := FPointerSize * InnerRadius div 200;\r\n Inner := AngleToPoint(Angle, Center, InnerRadius - DotRadius);\r\n if Inner.X > Center.X then\r\n Inc(Inner.X);\r\n if Inner.Y > Center.Y then\r\n Inc(Inner.Y);\r\n FPointerRect := Rect(Inner.X - DotRadius,\r\n Inner.Y - DotRadius,\r\n Inner.X + DotRadius,\r\n Inner.Y + DotRadius);\r\n Canvas.Ellipse(FPointerRect.Left, FPointerRect.Top, FPointerRect.Right, FPointerRect.Bottom);\r\n end;\r\n psOwnerDraw:\r\n if Assigned(FOnDrawPointer) then\r\n begin\r\n DotRadius := FPointerSize * InnerRadius div 200;\r\n Outer := AngleToPoint(Angle, Center, InnerRadius - DotRadius);\r\n if Outer.X > Center.X then\r\n Inc(Outer.X);\r\n if Outer.Y > Center.Y then\r\n Inc(Outer.Y);\r\n FPointerRect := Rect(Outer.X - DotRadius,\r\n Outer.Y - DotRadius,\r\n Outer.X + DotRadius,\r\n Outer.Y + DotRadius);\r\n\r\n // Create a clipping region to protect the area outside the button\r\n // face.\r\n Region := CreateEllipticRgn(FPointerRect.Left - 1, FPointerRect.Top - 1,\r\n FPointerRect.Right + 1, FPointerRect.Bottom + 1);\r\n SelectClipRgn(Canvas.Handle, Region);\r\n try\r\n FOnDrawPointer(Self, FPointerRect);\r\n except\r\n DeleteObject(Region);\r\n SelectClipRgn(Canvas.Handle, 0);\r\n raise;\r\n end;\r\n end;\r\n end;\r\n InflateRect(FPointerRect, 1, 1);\r\nend;\r\n\r\nprocedure TJvCustomDialButton.BitmapNeeded;\r\nbegin\r\n if FBitmap = nil then\r\n begin\r\n FBitmap := TBitmap.Create;\r\n FBitmapInvalid := True;\r\n end;\r\n {$IFDEF JVCLThemesEnabled}\r\n if FBitmapInvalid or ThemeServices.{$IFDEF RTL230_UP}Enabled{$ELSE}ThemesEnabled{$ENDIF RTL230_UP} then\r\n {$ELSE}\r\n if FBitmapInvalid then\r\n {$ENDIF JVCLThemesEnabled}\r\n begin\r\n if FBitmap.Width <> FSize + 1 then\r\n begin\r\n FBitmap.Width := FSize + 1;\r\n FBitmap.Height := FSize + 1;\r\n FBitmapRect := Bounds(0, 0, FSize + 1, FSize + 1);\r\n end;\r\n\r\n {$IFDEF JVCLThemesEnabled}\r\n if ThemeServices.{$IFDEF RTL230_UP}Enabled{$ELSE}ThemesEnabled{$ENDIF RTL230_UP} then\r\n FBitmap.Canvas.CopyRect(FBitmapRect, Canvas, FBitmapRect);\r\n {$ENDIF JVCLThemesEnabled}\r\n\r\n // Draw on bitmap.\r\n DrawButton;\r\n DrawTicks;\r\n end;\r\nend;\r\n\r\nfunction Blend(const Factor: Double; const Color1, Color2: TColor): TColor;\r\nvar\r\n Factor2: Double;\r\nbegin\r\n Factor2 := 1.0 - Factor;\r\n with TRGBQuad(Result) do\r\n begin\r\n rgbBlue := Trunc(Factor * TRGBQuad(Color1).rgbBlue + Factor2 * TRGBQuad(Color2).rgbBlue);\r\n rgbGreen := Trunc(Factor * TRGBQuad(Color1).rgbGreen + Factor2 * TRGBQuad(Color2).rgbGreen);\r\n rgbRed := Trunc(Factor * TRGBQuad(Color1).rgbRed + Factor2 * TRGBQuad(Color2).rgbRed);\r\n rgbReserved := 0;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomDialButton.DrawButton;\r\nconst\r\n HalfPi = 1.57079632679489661923;\r\nvar\r\n Edge: Integer;\r\n ButtonRect: TRect;\r\n Face, Highlight, Shadow: TColor;\r\n Size: Integer;\r\n OldOrg: TPoint;\r\n Canvas: TCanvas;\r\n I: Integer;\r\nbegin\r\n Size := 2 * FRadius + 1;\r\n ButtonRect := Bounds(0, 0, Size, Size);\r\n Canvas := FBitmap.Canvas;\r\n Canvas.Brush.Color := Parent.Brush.Color;\r\n Canvas.Brush.Style := bsSolid;\r\n {$IFDEF JVCLThemesEnabled}\r\n if not ThemeServices.{$IFDEF RTL230_UP}Enabled{$ELSE}ThemesEnabled{$ENDIF RTL230_UP} then\r\n {$ENDIF JVCLThemesEnabled}\r\n Canvas.FillRect(FBitmapRect);\r\n SetViewportOrgEx(Canvas.Handle, FSize div 2 - FRadius, FSize div 2 - FRadius,\r\n @OldOrg);\r\n try\r\n // Draw edge.\r\n Canvas.Pen.Style := psClear;\r\n\r\n Highlight := ColorToRGB(clBtnHighlight);\r\n Face := ColorToRGB(Color);\r\n // darking the color by halving each color part value\r\n Shadow := (ColorToRGB(Color) and $00FEFEFE) shr 1;\r\n\r\n for I := 0 to Size do\r\n begin\r\n Canvas.Brush.Color := Blend(Cos(I * HalfPi / Size), Highlight, Face);\r\n Canvas.Pie(0, 0, Size, Size, I + 1, 0, I - 1, 0);\r\n Canvas.Pie(0, 0, Size, Size, 0, I - 1, 0, I + 1);\r\n end;\r\n\r\n for I := 0 to Size do\r\n begin\r\n Canvas.Brush.Color := Blend(1.0 - Sin(I * HalfPi / Size), Face, Shadow);\r\n Canvas.Pie(0, 0, Size, Size, Size, I + 1, Size, I - 1);\r\n Canvas.Pie(0, 0, Size, Size, I - 1, Size, I + 1, Size);\r\n end;\r\n\r\n // Draw top of disk.\r\n Canvas.Pen.Style := psSolid;\r\n Canvas.Pen.Color := Color;\r\n Canvas.Brush.Color := Color;\r\n Edge := FButtonEdge * FRadius div 100 + 1;\r\n Canvas.Ellipse(0 + Edge, 0 + Edge, 0 + Size - Edge, 0 + Size - Edge);\r\n\r\n // Draw bounding circle.\r\n Canvas.Pen.Color := clBtnText;\r\n Canvas.Brush.Style := bsClear;\r\n Canvas.Ellipse(0, 0, Size, Size);\r\n finally\r\n // Reset viewport origin.\r\n SetViewportOrgEx(Canvas.Handle, OldOrg.X, OldOrg.Y, nil);\r\n end;\r\n FBitmapInvalid := False;\r\nend;\r\n\r\nprocedure TJvCustomDialButton.SetPointerShape(Value: TJvDialPointerShape);\r\nbegin\r\n if Value <> FPointerShape then\r\n begin\r\n FPointerShape := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomDialButton.DrawBorder;\r\nvar\r\n ARect: TRect;\r\nbegin\r\n ARect := ClientRect;\r\n InflateRect(ARect, -1, -1);\r\n Canvas.Brush.Style := bsClear;\r\n {$IFDEF JVCLThemesEnabled}\r\n if ThemeServices.{$IFDEF RTL230_UP}Enabled{$ELSE}ThemesEnabled{$ENDIF RTL230_UP} then\r\n begin\r\n BitmapNeeded;\r\n Canvas.Pen.Color := FBitmap.Canvas.Pixels[0, 0]\r\n end\r\n else\r\n {$ENDIF JVCLThemesEnabled}\r\n Canvas.Pen.Color := Parent.Brush.Color;\r\n Canvas.Rectangle(ARect.Left, ARect.Top, ARect.Right, ARect.Bottom);\r\n Canvas.Brush.Style := bsSolid;\r\n if Focused then\r\n Canvas.DrawFocusRect(ARect);\r\nend;\r\n\r\nprocedure TJvCustomDialButton.DrawTicks;\r\nvar\r\n I: Integer;\r\nbegin\r\n if (FTickStyle = tsNone) or (FTicks = nil) or (FTicks.Count = 0) then\r\n Exit;\r\n for I := 0 to FTicks.Count - 1 do\r\n DrawTick(FBitmap.Canvas, PTick(FTicks.List[I])^);\r\nend;\r\n\r\nprocedure TJvCustomDialButton.UpdateSize;\r\nbegin\r\n FSize := 2 * (MinBorder + FRadius + TickBorder) + 1;\r\nend;\r\n\r\nprocedure TJvCustomDialButton.SetBounds(ALeft, ATop, AWidth, AHeight: Integer);\r\nbegin\r\n if CalcBounds(AWidth, AHeight) then\r\n FBitmapInvalid := True;\r\n inherited SetBounds(ALeft, ATop, AWidth, AHeight);\r\n SetRadius(AWidth + AHeight);\r\nend;\r\n\r\nprocedure TJvCustomDialButton.ParentColorChanged;\r\nbegin\r\n FBitmapInvalid := True;\r\n inherited ParentColorChanged;\r\nend;\r\n\r\n// Set button edge in percent (0 - 100).\r\n\r\nprocedure TJvCustomDialButton.SetButtonEdge(Value: Integer);\r\nbegin\r\n if Value < rcMinEdge then\r\n Value := rcMinEdge;\r\n if Value > rcMaxEdge then\r\n Value := rcMaxEdge;\r\n if Value <> FButtonEdge then\r\n begin\r\n FButtonEdge := Value;\r\n if not FBitmapInvalid then\r\n begin\r\n FBitmapInvalid := True;\r\n Invalidate;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomDialButton.FocusKilled(NextWnd: THandle);\r\nbegin\r\n inherited FocusKilled(NextWnd);\r\n if HandleAllocated then\r\n DrawBorder;\r\nend;\r\n\r\nprocedure TJvCustomDialButton.FocusSet(PrevWnd: THandle);\r\nbegin\r\n inherited FocusSet(PrevWnd);\r\n if HandleAllocated then\r\n DrawBorder;\r\nend;\r\n\r\nprocedure TJvCustomDialButton.MouseDown(Button: TMouseButton;\r\n Shift: TShiftState; X, Y: Integer);\r\nvar\r\n A: TJvDialAngle;\r\nbegin\r\n inherited MouseDown(Button, Shift, X, Y);\r\n if not Focused then\r\n begin\r\n SetFocus;\r\n Invalidate;\r\n end;\r\n if PtInRect(FPointerRect, Point(X, Y)) then\r\n MouseCapture := True\r\n else\r\n begin\r\n A := RadToAngle(PointToRad(Point(X, Y), GetCenter));\r\n if A < Angle then\r\n begin\r\n DecPos(Shift);\r\n FIncrementing := False;\r\n end\r\n else\r\n begin\r\n IncPos(Shift);\r\n FIncrementing := True;\r\n end;\r\n if FRepeatTimer = nil then\r\n FRepeatTimer := TTimer.Create(Self);\r\n FRepeatTimer.OnTimer := TimerExpired;\r\n FRepeatTimer.Interval := FRepeatDelay;\r\n FRepeatTimer.Enabled := True;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomDialButton.TimerExpired(Sender: TObject);\r\nbegin\r\n FRepeatTimer.Enabled := False;\r\n FRepeatTimer.Interval := FRepeatRate;\r\n if FIncrementing then\r\n IncPos(GetShiftState)\r\n else\r\n DecPos(GetShiftState);\r\n FRepeatTimer.Enabled := True;\r\nend;\r\n\r\nprocedure TJvCustomDialButton.MouseMove(Shift: TShiftState; X, Y: Integer);\r\nbegin\r\n inherited MouseMove(Shift, X, Y);\r\n if MouseCapture then\r\n SetAngle(RadToAngle(PointToRad(Point(X, Y), GetCenter)));\r\nend;\r\n\r\nprocedure TJvCustomDialButton.MouseUp(Button: TMouseButton;\r\n Shift: TShiftState; X, Y: Integer);\r\nbegin\r\n inherited MouseUp(Button, Shift, X, Y);\r\n if FRepeatTimer <> nil then\r\n FRepeatTimer.Enabled := False;\r\n MouseCapture := False;\r\nend;\r\n\r\nfunction TJvCustomDialButton.GetCenter: TPoint;\r\nbegin\r\n Result.X := FSize div 2;\r\n Result.Y := Result.X;\r\nend;\r\n\r\nprocedure TJvCustomDialButton.ClearTicks;\r\nvar\r\n I: Integer;\r\nbegin\r\n if FTicks <> nil then\r\n with FTicks do\r\n begin\r\n for I := 0 to Count - 1 do\r\n if List[I] <> nil then\r\n Dispose(PTick(List[I]));\r\n Clear;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomDialButton.Click;\r\nbegin\r\n inherited Click;\r\n FState := not FState;\r\n Invalidate;\r\nend;\r\n\r\n\r\nprocedure TJvCustomDialButton.CreateParams(var Params: TCreateParams);\r\nconst\r\n BorderStyles: array [TBorderStyle] of Cardinal = (0, WS_BORDER);\r\nbegin\r\n inherited CreateParams(Params);\r\n Params.Style := Params.Style or BorderStyles[FBorderStyle];\r\n if Ctl3D and (FBorderStyle = bsSingle) then\r\n begin\r\n Params.Style := Params.Style and not WS_BORDER;\r\n Params.ExStyle := Params.ExStyle or WS_EX_STATICEDGE;\r\n end;\r\nend;\r\n\r\n\r\nprocedure TJvCustomDialButton.SetPointerColor(Value: TColor);\r\nbegin\r\n if Value <> FPointerColor then\r\n begin\r\n FPointerColor := Value;\r\n if State then\r\n DrawPointer;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomDialButton.SetPointerColorOff(Value: TColor);\r\nbegin\r\n if Value <> FPointerColorOff then\r\n begin\r\n FPointerColorOff := Value;\r\n if not State then\r\n DrawPointer;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomDialButton.IncPos(Shift: TShiftState);\r\nbegin\r\n if ssShift in Shift then\r\n Position := Position + FLargeChange\r\n else\r\n if ssCtrl in Shift then\r\n Position := FMax\r\n else\r\n Position := Position + FSmallChange;\r\nend;\r\n\r\nprocedure TJvCustomDialButton.DecPos(Shift: TShiftState);\r\nbegin\r\n if ssShift in Shift then\r\n Position := Position - FLargeChange\r\n else\r\n if ssCtrl in Shift then\r\n Position := FMin\r\n else\r\n Position := Position - FSmallChange;\r\nend;\r\n\r\nprocedure TJvCustomDialButton.KeyDown(var Key: Word; Shift: TShiftState);\r\nbegin\r\n case Key of\r\n VK_UP, VK_RIGHT:\r\n IncPos(Shift);\r\n VK_DOWN, VK_LEFT:\r\n DecPos(Shift);\r\n VK_PRIOR:\r\n IncPos(Shift + [ssShift]);\r\n VK_NEXT:\r\n DecPos(Shift + [ssShift]);\r\n VK_HOME:\r\n Position := FMin;\r\n VK_END:\r\n Position := FMax;\r\n else\r\n inherited KeyDown(Key, Shift);\r\n Exit;\r\n end;\r\n Key := 0;\r\n inherited KeyDown(Key, Shift);\r\nend;\r\n\r\n\r\n\r\nprocedure TJvCustomDialButton.CMCtl3DChanged(var Msg: TMessage);\r\nbegin\r\n inherited;\r\n FBitmapInvalid := True;\r\n RecreateWnd;\r\nend;\r\n\r\nprocedure TJvCustomDialButton.WndProc(var Msg: TMessage);\r\nbegin\r\n if Msg.Msg = CN_KEYDOWN then\r\n DoKeyDown(TWMKey(Msg));\r\n inherited WndProc(Msg);\r\nend;\r\n\r\nprocedure TJvCustomDialButton.WMSysColorChange(var Msg: TMessage);\r\nbegin\r\n FBitmapInvalid := True;\r\n Invalidate;\r\nend;\r\n\r\n\r\n\r\nprocedure TJvCustomDialButton.SetPointerSize(Value: Integer);\r\nbegin\r\n if Value > 100 then\r\n Value := 100\r\n else\r\n if Value < 1 then\r\n Value := 1;\r\n if Value <> FPointerSize then\r\n begin\r\n FPointerSize := Value;\r\n DrawPointer;\r\n end;\r\nend;\r\n\r\nfunction TJvCustomDialButton.AngleToRad(AnAngle: TJvDialAngle): Double;\r\nbegin\r\n Result := dAngleToRadian * AnAngle;\r\nend;\r\n\r\nprocedure TJvCustomDialButton.ColorChanged;\r\nbegin\r\n FBitmapInvalid := True;\r\n inherited ColorChanged;\r\nend;\r\n\r\nprocedure TJvCustomDialButton.ComputeTicks;\r\nbegin\r\n if csLoading in ComponentState then\r\n Exit;\r\n\r\n ClearTicks;\r\n case FTickStyle of\r\n tsNone:\r\n ;\r\n tsAuto:\r\n SetTicks(FTickStyle);\r\n tsManual:\r\n if Assigned(FOnComputeTicks) then\r\n FOnComputeTicks(Self);\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomDialButton.Loaded;\r\nbegin\r\n inherited Loaded;\r\n ComputeTicks;\r\n Change;\r\nend;\r\n\r\nfunction TJvCustomDialButton.RadToAngle(const Radian: Double): TJvDialAngle;\r\nbegin\r\n Result := Round(dRadianToAngle * Radian);\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvDialogActns.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvStdActions.PAS, released on 2002-10-06.\r\n\r\nThe Initial Developer of the Original Code is Peter Thrnqvist.\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvDialogActns.pas 13351 2012-06-13 15:16:00Z obones $\r\n\r\nunit JvDialogActns;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n SysUtils, Classes, ActnList, StdActns,\r\n JvBaseDlg, JvBrowseFolder, JvSelectDirectory, JvConnectNetwork,\r\n JvWinDialogs, JvDialogs, JvPageSetupTitled, JvPageSetup;\r\n\r\ntype\r\n TJvCommonDialogClass = class of TJvCommonDialog;\r\n\r\n TJvCommonDialogAction = class(TCustomAction)\r\n private\r\n FExecuteResult: Boolean;\r\n FOnAccept: TNotifyEvent;\r\n FOnCancel: TNotifyEvent;\r\n FBeforeExecute: TNotifyEvent;\r\n FAfterExecute: TNotifyEvent;\r\n protected\r\n FDialog: TJvCommonDialog;\r\n function GetDialogClass: TJvCommonDialogClass; virtual;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n function HandlesTarget(Target: TObject): Boolean; override;\r\n procedure ExecuteTarget(Target: TObject); override;\r\n property ExecuteResult: Boolean read FExecuteResult;\r\n published\r\n property Caption;\r\n property Enabled;\r\n property HelpContext;\r\n property Hint;\r\n property ImageIndex;\r\n property ShortCut;\r\n property SecondaryShortCuts;\r\n property Visible;\r\n property OnAccept: TNotifyEvent read FOnAccept write FOnAccept;\r\n property OnCancel: TNotifyEvent read FOnCancel write FOnCancel;\r\n property BeforeExecute: TNotifyEvent read FBeforeExecute write FBeforeExecute;\r\n property AfterExecute: TNotifyEvent read FAfterExecute write FAfterExecute;\r\n end;\r\n\r\n // (rom) renamed to match renamed TJvBrowseForFolder\r\n TJvBrowseForFolderAction = class(TJvCommonDialogAction)\r\n private\r\n function GetDialog: TJvBrowseForFolderDialog;\r\n protected\r\n function GetDialogClass: TJvCommonDialogClass; override;\r\n published\r\n property Dialog: TJvBrowseForFolderDialog read GetDialog;\r\n end;\r\n\r\n TJvSelectDirectoryAction = class(TJvCommonDialogAction)\r\n private\r\n function GetDialog: TJvSelectDirectory;\r\n protected\r\n function GetDialogClass: TJvCommonDialogClass; override;\r\n published\r\n property Dialog: TJvSelectDirectory read GetDialog;\r\n end;\r\n\r\n TJvConnectNetworkAction = class(TJvCommonDialogAction)\r\n private\r\n function GetDialog: TJvNetworkConnect;\r\n protected\r\n function GetDialogClass: TJvCommonDialogClass; override;\r\n published\r\n property Dialog: TJvNetworkConnect read GetDialog;\r\n end;\r\n\r\n TJvFloppyFormatAction = class(TJvCommonDialogAction)\r\n private\r\n function GetDialog: TJvFormatDriveDialog;\r\n protected\r\n function GetDialogClass: TJvCommonDialogClass; override;\r\n published\r\n property Dialog: TJvFormatDriveDialog read GetDialog;\r\n end;\r\n\r\n TJvOrganizeFavoritesAction = class(TJvCommonDialogAction)\r\n private\r\n function GetDialog: TJvOrganizeFavoritesDialog;\r\n protected\r\n function GetDialogClass: TJvCommonDialogClass; override;\r\n published\r\n property Dialog: TJvOrganizeFavoritesDialog read GetDialog;\r\n end;\r\n\r\n TJvControlPanelAction = class(TJvCommonDialogAction)\r\n private\r\n function GetDialog: TJvAppletDialog;\r\n protected\r\n function GetDialogClass: TJvCommonDialogClass; override;\r\n published\r\n property Dialog: TJvAppletDialog read GetDialog;\r\n end;\r\n\r\n TJvOpenFileAction = class(TCommonDialogAction)\r\n private\r\n function GetDialog: TJvOpenDialog;\r\n protected\r\n function GetDialogClass: TCommonDialogClass; override;\r\n published\r\n property Caption;\r\n property Enabled;\r\n property HelpContext;\r\n property Hint;\r\n property ImageIndex;\r\n property ShortCut;\r\n property Visible;\r\n property SecondaryShortCuts;\r\n property OnAccept;\r\n property OnCancel;\r\n published\r\n property Dialog: TJvOpenDialog read GetDialog;\r\n end;\r\n\r\n TJvSaveFileAction = class(TJvOpenFileAction)\r\n private\r\n function GetDialog: TJvSaveDialog;\r\n protected\r\n function GetDialogClass: TCommonDialogClass; override;\r\n published\r\n property Dialog: TJvSaveDialog read GetDialog;\r\n end;\r\n\r\n TJvPageSetupAction = class(TJvCommonDialogAction)\r\n private\r\n function GetDialog: TJvPageSetupDialog;\r\n protected\r\n function GetDialogClass: TJvCommonDialogClass; override;\r\n published\r\n property Dialog: TJvPageSetupDialog read GetDialog;\r\n end;\r\n\r\n TJvPageSetupTitledAction = class(TJvCommonDialogAction)\r\n private\r\n function GetDialog: TJvPageSetupTitledDialog;\r\n protected\r\n function GetDialogClass: TJvCommonDialogClass; override;\r\n published\r\n property Dialog: TJvPageSetupTitledDialog read GetDialog;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvDialogActns.pas $';\r\n Revision: '$Revision: 13351 $';\r\n Date: '$Date: 2012-06-13 17:16:00 +0200 (mer. 13 juin 2012) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\n\r\n//=== { TJvCommonDialogAction } ==============================================\r\n\r\nconstructor TJvCommonDialogAction.Create(AOwner: TComponent);\r\nvar\r\n DialogClass: TJvCommonDialogClass;\r\nbegin\r\n inherited Create(AOwner);\r\n DialogClass := GetDialogClass;\r\n if Assigned(DialogClass) then\r\n begin\r\n FDialog := DialogClass.Create(Self);\r\n FDialog.Name := Copy(DialogClass.ClassName, 2, Length(DialogClass.ClassName));\r\n FDialog.SetSubComponent(True);\r\n end;\r\n DisableIfNoHandler := False;\r\n Enabled := True;\r\nend;\r\n\r\nprocedure TJvCommonDialogAction.ExecuteTarget(Target: TObject);\r\nbegin\r\n FExecuteResult := False;\r\n if Assigned(FDialog) then\r\n begin\r\n if Assigned(FBeforeExecute) then\r\n FBeforeExecute(Self);\r\n FExecuteResult := FDialog.Execute;\r\n if Assigned(FAfterExecute) then\r\n FAfterExecute(Self);\r\n if FExecuteResult then\r\n begin\r\n if Assigned(FOnAccept) then\r\n FOnAccept(Self)\r\n end\r\n else\r\n if Assigned(FOnCancel) then\r\n FOnCancel(Self);\r\n end;\r\nend;\r\n\r\nfunction TJvCommonDialogAction.GetDialogClass: TJvCommonDialogClass;\r\nbegin\r\n Result := nil;\r\nend;\r\n\r\nfunction TJvCommonDialogAction.HandlesTarget(Target: TObject): Boolean;\r\nbegin\r\n Result := True;\r\nend;\r\n\r\n//=== { TJvBrowseForFolderAction } ===========================================\r\n\r\nfunction TJvBrowseForFolderAction.GetDialog: TJvBrowseForFolderDialog;\r\nbegin\r\n Result := TJvBrowseForFolderDialog(FDialog);\r\nend;\r\n\r\nfunction TJvBrowseForFolderAction.GetDialogClass: TJvCommonDialogClass;\r\nbegin\r\n Result := TJvBrowseForFolderDialog;\r\nend;\r\n\r\n//=== { TJvSelectDirectoryAction } ===========================================\r\n\r\nfunction TJvSelectDirectoryAction.GetDialog: TJvSelectDirectory;\r\nbegin\r\n Result := TJvSelectDirectory(FDialog);\r\nend;\r\n\r\nfunction TJvSelectDirectoryAction.GetDialogClass: TJvCommonDialogClass;\r\nbegin\r\n Result := TJvSelectDirectory;\r\nend;\r\n\r\n//=== { TJvConnectNetworkAction } ============================================\r\n\r\nfunction TJvConnectNetworkAction.GetDialog: TJvNetworkConnect;\r\nbegin\r\n Result := TJvNetworkConnect(FDialog);\r\nend;\r\n\r\nfunction TJvConnectNetworkAction.GetDialogClass: TJvCommonDialogClass;\r\nbegin\r\n Result := TJvNetworkConnect;\r\nend;\r\n\r\n//=== { TJvFloppyFormatAction } ==============================================\r\n\r\nfunction TJvFloppyFormatAction.GetDialog: TJvFormatDriveDialog;\r\nbegin\r\n Result := TJvFormatDriveDialog(FDialog);\r\nend;\r\n\r\nfunction TJvFloppyFormatAction.GetDialogClass: TJvCommonDialogClass;\r\nbegin\r\n Result := TJvFormatDriveDialog;\r\nend;\r\n\r\n//=== { TJvOrganizeFavoritesAction } =========================================\r\n\r\nfunction TJvOrganizeFavoritesAction.GetDialog: TJvOrganizeFavoritesDialog;\r\nbegin\r\n Result := TJvOrganizeFavoritesDialog(FDialog);\r\nend;\r\n\r\nfunction TJvOrganizeFavoritesAction.GetDialogClass: TJvCommonDialogClass;\r\nbegin\r\n Result := TJvOrganizeFavoritesDialog;\r\nend;\r\n\r\n//=== { TJvControlPanelAction } ==============================================\r\n\r\nfunction TJvControlPanelAction.GetDialog: TJvAppletDialog;\r\nbegin\r\n Result := TJvAppletDialog(FDialog);\r\nend;\r\n\r\nfunction TJvControlPanelAction.GetDialogClass: TJvCommonDialogClass;\r\nbegin\r\n Result := TJvAppletDialog;\r\nend;\r\n\r\n//=== { TJvOpenFileAction } ==================================================\r\n\r\nfunction TJvOpenFileAction.GetDialog: TJvOpenDialog;\r\nbegin\r\n Result := TJvOpenDialog(FDialog);\r\nend;\r\n\r\nfunction TJvOpenFileAction.GetDialogClass: TCommonDialogClass;\r\nbegin\r\n Result := TJvOpenDialog;\r\nend;\r\n\r\n//=== { TJvSaveFileAction } ==================================================\r\n\r\nfunction TJvSaveFileAction.GetDialog: TJvSaveDialog;\r\nbegin\r\n Result := TJvSaveDialog(FDialog);\r\nend;\r\n\r\nfunction TJvSaveFileAction.GetDialogClass: TCommonDialogClass;\r\nbegin\r\n Result := TJvSaveDialog;\r\nend;\r\n\r\n//=== { TJvPageSetupAction } =================================================\r\n\r\nfunction TJvPageSetupAction.GetDialog: TJvPageSetupDialog;\r\nbegin\r\n Result := TJvPageSetupDialog(FDialog);\r\nend;\r\n\r\nfunction TJvPageSetupAction.GetDialogClass: TJvCommonDialogClass;\r\nbegin\r\n Result := TJvPageSetupDialog;\r\nend;\r\n\r\n//=== { TJvPageSetupTitledAction } ===========================================\r\n\r\nfunction TJvPageSetupTitledAction.GetDialog: TJvPageSetupTitledDialog;\r\nbegin\r\n Result := TJvPageSetupTitledDialog(FDialog);\r\nend;\r\n\r\nfunction TJvPageSetupTitledAction.GetDialogClass: TJvCommonDialogClass;\r\nbegin\r\n Result := TJvPageSetupTitledDialog;\r\nend;\r\n\r\n//=== { TCommonDialogAction } ================================================\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvDialogs.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvDialogs.PAS, released Oct 10, 1999.\r\n\r\nThe Initial Developer of the Original Code is Petr Vones (petr dott v att mujmail dott cz)\r\nPortions created by Petr Vones are Copyright (C) 1999 Petr Vones.\r\nPortions created by Microsoft are Copyright (C) 1998, 1999 Microsoft Corp.\r\nAll Rights Reserved.\r\n\r\nContributor(s): Debbie Gregory \r\n Marcel van Brakel .\r\n\r\nCurrent Version: 0.50\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvDialogs.pas 13180 2011-11-22 12:45:23Z obones $\r\n\r\nunit JvDialogs;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, Messages, Classes, Graphics, Controls, Forms, Dialogs,\r\n JVCLVer;\r\n\r\ntype\r\n TJvOpenDialogAC = (acEdit, acListView);\r\n TJvOpenDialogAS = (asSmallIcon, asReport);\r\n TDialogErrorEvent = procedure(Sender: TObject; ErrorCode:Cardinal) of object;\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvOpenDialog = class(TOpenDialog)\r\n private\r\n FAboutJVCL: TJVCLAboutInfo;\r\n FActiveControl: TJvOpenDialogAC;\r\n FActiveStyle: TJvOpenDialogAS;\r\n FActiveSettingDone: Boolean;\r\n FAutoSize: Boolean;\r\n FDefBtnCaption: string;\r\n FFilterLabelCaption: string;\r\n FInitialSize: TSize;\r\n FMakeResizeable: Boolean;\r\n FOriginalRect: TRect;\r\n FParentWndInstance, FOldParentWndInstance: Pointer;\r\n FParentWnd: THandle;\r\n FOnShareViolation: TCloseQueryEvent;\r\n FHeight: Integer;\r\n FWidth: Integer;\r\n FUseUserSize: Boolean;\r\n FOnError: TDialogErrorEvent;\r\n procedure CenterAndSize;\r\n function DoActiveSetting: Boolean;\r\n procedure WMNCDestroy(var Msg: TWMNCDestroy); message WM_NCDESTROY;\r\n procedure SetDefBtnCaption(const Value: string);\r\n procedure SetFilterLabelCaption(const Value: string);\r\n protected\r\n procedure DoFolderChange; override;\r\n function DoShareViolation: Boolean; dynamic;\r\n procedure DoShow; override;\r\n function GetLocalizedSizeCommand: string;\r\n procedure ParentResize; dynamic;\r\n procedure ParentWndProc(var Msg: TMessage); virtual;\r\n function TaskModalDialog(DialogFunc: Pointer; var DialogData): Bool; override;\r\n procedure UpdateCaptions;\r\n procedure UpdateControlPos; dynamic;\r\n procedure WndProc(var Msg: TMessage); override;\r\n protected\r\n procedure DoError(ErrorCode:Cardinal);virtual;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n property ParentWnd: THandle read FParentWnd;\r\n procedure SelectFolder(const FolderName: string);\r\n property Template;\r\n published\r\n property AboutJVCL: TJVCLAboutInfo read FAboutJVCL write FAboutJVCL stored False;\r\n property ActiveControl: TJvOpenDialogAC read FActiveControl write FActiveControl default acEdit;\r\n property ActiveStyle: TJvOpenDialogAS read FActiveStyle write FActiveStyle default asSmallIcon;\r\n property AutoSize: Boolean read FAutoSize write FAutoSize default False;\r\n property DefBtnCaption: string read FDefBtnCaption write SetDefBtnCaption;\r\n property FilterLabelCaption: string read FFilterLabelCaption write SetFilterLabelCaption;\r\n property Height: Integer read FHeight write FHeight;\r\n property UseUserSize: Boolean read FUseUserSize write FUseUserSize default False;\r\n property Width: Integer read FWidth write FWidth;\r\n property OnError: TDialogErrorEvent read FOnError write FOnError;\r\n property OnShareViolation: TCloseQueryEvent read FOnShareViolation write FOnShareViolation;\r\n end;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvSaveDialog = class(TJvOpenDialog)\r\n function TaskModalDialog(DialogFunc: Pointer; var DialogData): Bool; override;\r\n end;\r\n\r\n TJvCDQueryEvent = procedure(Sender: TObject; SelectedColor: TColor; var Accept: Boolean) of object;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvColorDialog = class(TColorDialog)\r\n private\r\n FAboutJVCL: TJVCLAboutInfo;\r\n FColorOkMessage: DWORD;\r\n FSetRBGMessage: DWORD;\r\n FOnQueryColor: TJvCDQueryEvent;\r\n procedure WMNCDestroy(var Msg: TWMNCDestroy); message WM_NCDESTROY;\r\n protected\r\n procedure DoClose; override;\r\n procedure DoShow; override;\r\n function DoQueryColor(Color: TColor): Boolean; dynamic;\r\n function TaskModalDialog(DialogFunc: Pointer; var DialogData): Bool; override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n procedure SelectColor(Color: TColor);\r\n published\r\n property AboutJVCL: TJVCLAboutInfo read FAboutJVCL write FAboutJVCL stored False;\r\n property OnQueryColor: TJvCDQueryEvent read FOnQueryColor write FOnQueryColor;\r\n end;\r\n\r\nvar\r\n JvDialogsUseFixW2k: Boolean = True;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvDialogs.pas $';\r\n Revision: '$Revision: 13180 $';\r\n Date: '$Date: 2011-11-22 13:45:23 +0100 (mar. 22 nov. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n CommDlg, CommCtrl, Dlgs,\r\n Types, SysUtils, Math,\r\n JclSysInfo,\r\n {$IFNDEF COMPILER12_UP}\r\n JvJCLUtils, // SetWindowLongPtr\r\n {$ENDIF ~COMPILER12_UP}\r\n JvJVCLUtils;\r\n\r\nconst\r\n btnOk = 1;\r\n btnCancel = 2;\r\n\r\nvar\r\n W2kFixMsAcmLibrary: THandle = 0;\r\n\r\nfunction IsWin2kOrAbove: Boolean;\r\nbegin\r\n Result := (Win32Platform = VER_PLATFORM_WIN32_NT) and CheckWin32Version(5, 0);\r\nend;\r\n\r\nprocedure UninstallW2kFix;\r\nbegin\r\n if W2kFixMsAcmLibrary > 0 then\r\n begin\r\n FreeLibrary(W2kFixMsAcmLibrary);\r\n W2kFixMsAcmLibrary := 0;\r\n end;\r\nend;\r\n\r\nprocedure InstallW2kFix;\r\nbegin\r\n if JvDialogsUseFixW2k and IsWin2K and (W2kFixMsAcmLibrary = 0) then\r\n W2kFixMsAcmLibrary := SafeLoadLibrary('msacm32.dll');\r\nend;\r\n\r\n//=== { TJvOpenDialog } ======================================================\r\n\r\nconstructor TJvOpenDialog.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FActiveControl := acEdit;\r\n FActiveStyle := asSmallIcon;\r\n FMakeResizeable := GetWindowsVersion in [wvWin95, wvWin95OSR2, wvWinNT4];\r\n FParentWndInstance := JvMakeObjectInstance(ParentWndProc);\r\n FParentWndInstance := JvMakeObjectInstance(ParentWndProc);\r\nend;\r\n\r\ndestructor TJvOpenDialog.Destroy;\r\nbegin\r\n JvFreeObjectInstance(FParentWndInstance);\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvOpenDialog.CenterAndSize;\r\nvar\r\n Monitor: TMonitor;\r\nbegin\r\n if UseUserSize then\r\n begin\r\n if Application.MainForm <> nil then\r\n Monitor := Application.MainForm.Monitor\r\n else\r\n Monitor := Screen.Monitors[0];\r\n SetWindowPos(FParentWnd, 0,\r\n Monitor.Left + ((Monitor.Width - Width) div 2),\r\n Monitor.Top + ((Monitor.Height - Height) div 3),\r\n Width, Height,\r\n SWP_NOACTIVATE or SWP_NOZORDER);\r\n end;\r\nend;\r\n\r\nfunction TJvOpenDialog.DoActiveSetting: Boolean;\r\nvar\r\n DefViewWnd, ListViewWnd: HWND;\r\nbegin\r\n Result := False;\r\n if not FActiveSettingDone then\r\n begin\r\n DefViewWnd := FindWindowEx(FParentWnd, 0, PChar('SHELLDLL_DefView'), nil);\r\n ListViewWnd := FindWindowEx(DefViewWnd, 0, PChar('SysListView32'), nil);\r\n if (DefViewWnd <> 0) and (ListViewWnd <> 0) then\r\n begin\r\n if FActiveStyle = asReport then\r\n SendMessage(DefViewWnd, WM_COMMAND, $702C, 0);\r\n if FActiveControl = acListView then\r\n begin\r\n SetFocus(ListViewWnd);\r\n PostMessage(ListViewWnd, WM_KEYDOWN, VK_SPACE, 0);\r\n end;\r\n FActiveSettingDone := True;\r\n CenterAndSize;\r\n Result := True;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvOpenDialog.DoFolderChange;\r\nbegin\r\n DoActiveSetting;\r\n inherited DoFolderChange;\r\nend;\r\n\r\nfunction TJvOpenDialog.DoShareViolation: Boolean;\r\nbegin\r\n Result := True;\r\n if Assigned(FOnShareViolation) then\r\n FOnShareViolation(Self, Result);\r\nend;\r\n\r\nprocedure TJvOpenDialog.DoShow;\r\nvar\r\n SysMenu: HMENU;\r\n R: TRect;\r\nbegin\r\n FParentWnd := GetParent(Handle);\r\n GetClientRect(FParentWnd, FOriginalRect);\r\n GetWindowRect(FParentWnd, R);\r\n FInitialSize.cx := R.Right - R.Left;\r\n FInitialSize.cy := R.Bottom - R.Top;\r\n Width := Max(Width, FInitialSize.cx);\r\n Height := Max(Height, FInitialSize.cy);\r\n if FMakeResizeable and (ofEnableSizing in Options) then\r\n begin\r\n SetWindowLong(ParentWnd, GWL_STYLE, GetWindowLong(ParentWnd, GWL_STYLE) or WS_THICKFRAME);\r\n SetWindowPos(ParentWnd, 0, 0, 0, 0, 0, SWP_NOSIZE or SWP_NOMOVE or SWP_NOZORDER or\r\n SWP_FRAMECHANGED or SWP_DRAWFRAME or SWP_NOCOPYBITS);\r\n SysMenu := GetSystemMenu(ParentWnd, False);\r\n InsertMenu(SysMenu, SC_CLOSE, MF_BYCOMMAND, SC_SIZE, PChar(GetLocalizedSizeCommand));\r\n FOldParentWndInstance := Pointer(SetWindowLongPtr(FParentWnd, GWL_WNDPROC, LONG_PTR(FParentWndInstance)));\r\n UpdateControlPos;\r\n end;\r\n UpdateCaptions;\r\n inherited DoShow;\r\nend;\r\n\r\nfunction TJvOpenDialog.GetLocalizedSizeCommand: string;\r\nvar\r\n SysMenu: HMENU;\r\nbegin\r\n if not (csDesigning in ComponentState) and Assigned(Application.MainForm) then\r\n begin\r\n SysMenu := GetSystemMenu(Application.MainForm.Handle, False);\r\n SetString(Result, nil, 50);\r\n GetMenuString(SysMenu, SC_SIZE, PChar(Result), 50, MF_BYCOMMAND);\r\n Result := PChar(Result);\r\n end\r\n else\r\n Result := '';\r\n if Result = '' then\r\n Result := 'Size'; // do not localize\r\nend;\r\n\r\nprocedure TJvOpenDialog.ParentResize;\r\nbegin\r\n InvalidateRect(ParentWnd, nil, False);\r\n UpdateControlPos;\r\nend;\r\n\r\nprocedure TJvOpenDialog.ParentWndProc(var Msg: TMessage);\r\nconst\r\n SizeGripRectSize = 15;\r\n\r\n function SizeGripRect: TRect;\r\n begin\r\n GetClientRect(ParentWnd, Result);\r\n SetRect(Result, Result.Right - SizeGripRectSize, Result.Bottom - SizeGripRectSize,\r\n Result.Right, Result.Bottom);\r\n end;\r\n\r\n procedure PaintSizeGrip;\r\n var\r\n PS: TPaintStruct;\r\n DC: HDC;\r\n R: TRect;\r\n Pen, SavePen: HPen;\r\n I: Integer;\r\n begin\r\n DC := BeginPaint(ParentWnd, PS);\r\n R := SizeGripRect;\r\n Pen := CreatePen(PS_SOLID, 1, ColorToRGB(clBtnShadow));\r\n SavePen := SelectObject(DC, Pen);\r\n for I := 0 to (SizeGripRectSize - 2) div 4 do\r\n begin\r\n MoveToEx(DC, R.Right, R.Bottom - (I * 4), nil);\r\n LineTo(DC, R.Right - (I * 4), R.Bottom);\r\n MoveToEx(DC, R.Right, R.Bottom - (I * 4) - 1, nil);\r\n LineTo(DC, R.Right - (I * 4) - 1, R.Bottom);\r\n end;\r\n SelectObject(DC, SavePen);\r\n DeleteObject(Pen);\r\n Pen := CreatePen(PS_SOLID, 1, ColorToRGB(clWindow));\r\n SavePen := SelectObject(DC, Pen);\r\n for I := 0 to (SizeGripRectSize - 2) div 4 do\r\n begin\r\n MoveToEx(DC, R.Right, R.Bottom - (I * 4) - 2, nil);\r\n LineTo(DC, R.Right - (I * 4) - 2, R.Bottom);\r\n end;\r\n SelectObject(DC, SavePen);\r\n DeleteObject(Pen);\r\n EndPaint(ParentWnd, PS);\r\n end;\r\n\r\nbegin\r\n with Msg do\r\n begin\r\n case Msg of\r\n { WM_SIZE:\r\n ParentResize;}\r\n WM_GETMINMAXINFO:\r\n with PMinMaxInfo(LParam)^ do\r\n begin\r\n ptMinTrackSize.X := FInitialSize.cx;\r\n ptMinTrackSize.Y := FInitialSize.cy;\r\n end;\r\n WM_PAINT:\r\n PaintSizeGrip;\r\n end;\r\n Result := CallWindowProc(FOldParentWndInstance, FParentWnd, Msg, WParam, LParam);\r\n if Msg = WM_SIZE then\r\n ParentResize;\r\n end;\r\nend;\r\n\r\nprocedure TJvOpenDialog.SetDefBtnCaption(const Value: string);\r\nbegin\r\n if FDefBtnCaption <> Value then\r\n begin\r\n FDefBtnCaption := Value;\r\n if FParentWnd <> 0 then\r\n UpdateCaptions;\r\n end;\r\nend;\r\n\r\nprocedure TJvOpenDialog.SetFilterLabelCaption(const Value: string);\r\nbegin\r\n if FFilterLabelCaption <> Value then\r\n begin\r\n FFilterLabelCaption := Value;\r\n if FParentWnd <> 0 then\r\n UpdateCaptions;\r\n end;\r\nend;\r\n\r\nprocedure TJvOpenDialog.SelectFolder(const FolderName: string);\r\nvar\r\n LastFocus: HWND;\r\nbegin\r\n if ParentWnd = 0 then\r\n Exit;\r\n LastFocus := GetFocus;\r\n SendMessage(ParentWnd, CDM_SETCONTROLTEXT, edt1, LPARAM(PChar(FolderName)));\r\n SendMessage(GetDlgItem(ParentWnd, btnOk), BM_CLICK, 0, 0);\r\n SendMessage(ParentWnd, CDM_SETCONTROLTEXT, edt1, 0);\r\n SetFocus(LastFocus);\r\nend;\r\n\r\nfunction TJvOpenDialog.TaskModalDialog(DialogFunc: Pointer; var DialogData): Bool;\r\nbegin\r\n TOpenFileName(DialogData).hInstance := FindClassHInstance(Self.ClassType);\r\n FActiveSettingDone := False;\r\n if IsWin2kOrAbove then\r\n begin\r\n if ActiveStyle = asReport then\r\n InstallW2kFix;\r\n Result := inherited TaskModalDialog(DialogFunc, DialogData);\r\n end\r\n else\r\n Result := inherited TaskModalDialog(DialogFunc, DialogData);\r\n if not Result then\r\n DoError(CommDlgExtendedError);\r\nend;\r\n\r\nprocedure TJvOpenDialog.UpdateCaptions;\r\nbegin\r\n if Length(FDefBtnCaption) > 0 then\r\n SendMessage(ParentWnd, CDM_SETCONTROLTEXT, btnOk, LPARAM(PChar(DefBtnCaption)));\r\n if Length(FFilterLabelCaption) > 0 then\r\n SendMessage(ParentWnd, CDM_SETCONTROLTEXT, stc2, LPARAM(PChar(FilterLabelCaption)));\r\nend;\r\n\r\nprocedure TJvOpenDialog.UpdateControlPos;\r\nvar\r\n WRect: TRect;\r\n CtrlWnd: HWND;\r\n OfsSize: TPoint;\r\n CLeft, CTop, CWidth, CHeight: Integer;\r\n DeferHandle: HDWP;\r\n\r\n function GetDlgWndInfo(Wnd: HWND): Boolean;\r\n var\r\n Rect: TRect;\r\n begin\r\n Result := Wnd <> 0;\r\n if not Result then\r\n Exit;\r\n CtrlWnd := Wnd;\r\n GetWindowRect(CtrlWnd, Rect);\r\n MapWindowPoints(0, ParentWnd, Rect, 2);\r\n CLeft := Rect.Left;\r\n CTop := Rect.Top;\r\n CWidth := Rect.Right - Rect.Left;\r\n CHeight := Rect.Bottom - Rect.Top;\r\n end;\r\n\r\n function GetDlgItemInfo(ItemNum: Integer): Boolean;\r\n begin\r\n Result := GetDlgWndInfo(GetDlgItem(ParentWnd, ItemNum));\r\n end;\r\n\r\nbegin\r\n GetClientRect(ParentWnd, WRect);\r\n OfsSize.X := (WRect.Right - WRect.Left) - (FOriginalRect.Right - FOriginalRect.Left);\r\n OfsSize.Y := (WRect.Bottom - WRect.Top) - (FOriginalRect.Bottom - FOriginalRect.Top);\r\n FOriginalRect := WRect;\r\n\r\n DeferHandle := BeginDeferWindowPos(12);\r\n\r\n GetDlgItemInfo(btnOk); // Default Button\r\n Inc(CLeft, OfsSize.X);\r\n Inc(CTop, OfsSize.Y);\r\n DeferHandle := DeferWindowPos(DeferHandle, CtrlWnd, 0, CLeft, CTop, 0, 0,\r\n SWP_NOACTIVATE or SWP_NOZORDER or SWP_NOSIZE);\r\n\r\n GetDlgItemInfo(btnCancel); // Cancel Button\r\n Inc(CLeft, OfsSize.X);\r\n Inc(CTop, OfsSize.Y);\r\n DeferHandle := DeferWindowPos(DeferHandle, CtrlWnd, 0, CLeft, CTop, 0, 0,\r\n SWP_NOACTIVATE or SWP_NOZORDER or SWP_NOSIZE);\r\n\r\n GetDlgItemInfo(pshHelp); // Help Button\r\n Inc(CLeft, OfsSize.X);\r\n Inc(CTop, OfsSize.Y);\r\n DeferHandle := DeferWindowPos(DeferHandle, CtrlWnd, 0, CLeft, CTop, 0, 0,\r\n SWP_NOACTIVATE or SWP_NOZORDER or SWP_NOSIZE);\r\n\r\n GetDlgItemInfo(edt1); // Filename\r\n Inc(CTop, OfsSize.Y);\r\n Inc(CWidth, OfsSize.X);\r\n DeferHandle := DeferWindowPos(DeferHandle, CtrlWnd, 0, CLeft, CTop, CWidth, CHeight,\r\n SWP_NOACTIVATE or SWP_NOZORDER);\r\n\r\n GetDlgItemInfo(cmb1); // File Type\r\n Inc(CTop, OfsSize.Y);\r\n Inc(CWidth, OfsSize.X);\r\n DeferHandle := DeferWindowPos(DeferHandle, CtrlWnd, 0, CLeft, CTop, CWidth, CHeight,\r\n SWP_NOACTIVATE or SWP_NOZORDER);\r\n\r\n GetDlgItemInfo(chx1); // Read-only Checkbox\r\n Inc(CTop, OfsSize.Y);\r\n Inc(CWidth, OfsSize.X);\r\n DeferHandle := DeferWindowPos(DeferHandle, CtrlWnd, 0, CLeft, CTop, CWidth, CHeight,\r\n SWP_NOACTIVATE or SWP_NOZORDER or SWP_NOSIZE);\r\n\r\n GetDlgItemInfo(stc2); // File Type Label\r\n Inc(CTop, OfsSize.Y);\r\n DeferHandle := DeferWindowPos(DeferHandle, CtrlWnd, 0, CLeft, CTop, 0, 0,\r\n SWP_NOACTIVATE or SWP_NOZORDER or SWP_NOSIZE);\r\n\r\n GetDlgItemInfo(stc3); // Filename Label\r\n Inc(CTop, OfsSize.Y);\r\n DeferHandle := DeferWindowPos(DeferHandle, CtrlWnd, 0, CLeft, CTop, 0, 0,\r\n SWP_NOACTIVATE or SWP_NOZORDER or SWP_NOSIZE);\r\n\r\n GetDlgItemInfo(cmb2); // Folder combobox\r\n Inc(CWidth, OfsSize.X);\r\n DeferHandle := DeferWindowPos(DeferHandle, CtrlWnd, 0, 0, 0, CWidth, CHeight,\r\n SWP_NOACTIVATE or SWP_NOZORDER or SWP_NOMOVE);\r\n\r\n if GetDlgItemInfo(lst2) then // ListView run\r\n begin\r\n Inc(CHeight, OfsSize.Y);\r\n Inc(CWidth, OfsSize.X);\r\n DeferHandle := DeferWindowPos(DeferHandle, CtrlWnd, 0, 0, 0, CWidth, CHeight,\r\n SWP_NOACTIVATE or SWP_NOZORDER or SWP_NOMOVE);\r\n end;\r\n if GetDlgItemInfo(lst1) then // ListView init\r\n begin\r\n Inc(CHeight, OfsSize.Y);\r\n Inc(CWidth, OfsSize.X);\r\n DeferHandle := DeferWindowPos(DeferHandle, CtrlWnd, 0, 0, 0, CWidth, CHeight,\r\n SWP_NOACTIVATE or SWP_NOZORDER or SWP_NOMOVE);\r\n end;\r\n\r\n if GetDlgWndInfo(FindWindowEx(FParentWnd, 0, TOOLBARCLASSNAME, nil)) then\r\n begin\r\n Inc(CLeft, OfsSize.X);\r\n DeferHandle := DeferWindowPos(DeferHandle, CtrlWnd, 0, CLeft, CTop, 0, 0,\r\n SWP_NOACTIVATE or SWP_NOZORDER or SWP_NOSIZE);\r\n end;\r\n\r\n EndDeferWindowPos(DeferHandle);\r\nend;\r\n\r\nprocedure TJvOpenDialog.WMNCDestroy(var Msg: TWMNCDestroy);\r\nbegin\r\n FParentWnd := 0;\r\n inherited;\r\nend;\r\n\r\nprocedure TJvOpenDialog.WndProc(var Msg: TMessage);\r\nconst\r\n ShareViolResult: array [Boolean] of DWORD = (OFN_SHARENOWARN, OFN_SHAREFALLTHROUGH);\r\nbegin\r\n with Msg do\r\n case Msg of\r\n WM_ENTERIDLE:\r\n DoActiveSetting;\r\n WM_NOTIFY:\r\n case POFNotify(LParam)^.hdr.code of\r\n CDN_SHAREVIOLATION:\r\n if Assigned(FOnShareViolation) then\r\n begin\r\n Result := ShareViolResult[DoShareViolation];\r\n SetWindowLong(Handle, DWL_MSGRESULT, Result);\r\n Exit;\r\n end;\r\n end;\r\n end;\r\n inherited;\r\nend;\r\n\r\nprocedure TJvOpenDialog.DoError(ErrorCode: Cardinal);\r\nbegin\r\n if Assigned(FOnError) then\r\n FOnError(Self, ErrorCode);\r\nend;\r\n\r\n//=== { TJvSaveDialog } ======================================================\r\n\r\nfunction TJvSaveDialog.TaskModalDialog(DialogFunc: Pointer; var DialogData): Bool;\r\nbegin\r\n DialogFunc := @GetSaveFileName;\r\n Result := inherited TaskModalDialog(DialogFunc, DialogData);\r\nend;\r\n\r\n//=== { TJvColorDialog } =====================================================\r\n\r\nvar\r\n GlobalColorDialog: TJvColorDialog = nil;\r\n OldColorDialogHookProc: Pointer = nil;\r\n\r\nfunction ColorDialogHook(Wnd: HWND; Msg: UINT; WParam: WPARAM; LParam: LPARAM): {$IFDEF RTL230_UP}UINT_PTR{$ELSE}UINT{$ENDIF RTL230_UP}; stdcall;\r\nbegin\r\n if Assigned(GlobalColorDialog) and (Msg = GlobalColorDialog.FColorOkMessage) then\r\n Result := Integer(not GlobalColorDialog.DoQueryColor(TColor(PChooseColor(LParam)^.rgbResult)))\r\n else\r\n Result := CallWindowProc(OldColorDialogHookProc, Wnd, Msg, WParam, LParam);\r\nend;\r\n\r\nconstructor TJvColorDialog.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FColorOkMessage := RegisterWindowMessage(COLOROKSTRING);\r\n FSetRBGMessage := RegisterWindowMessage(SETRGBSTRING);\r\nend;\r\n\r\nprocedure TJvColorDialog.DoClose;\r\nbegin\r\n GlobalColorDialog := nil;\r\n inherited DoClose;\r\nend;\r\n\r\nfunction TJvColorDialog.DoQueryColor(Color: TColor): Boolean;\r\nbegin\r\n Result := True;\r\n if Assigned(FOnQueryColor) then\r\n FOnQueryColor(Self, Color, Result);\r\nend;\r\n\r\nprocedure TJvColorDialog.DoShow;\r\nbegin\r\n GlobalColorDialog := Self;\r\n inherited DoShow;\r\nend;\r\n\r\nprocedure TJvColorDialog.SelectColor(Color: TColor);\r\nbegin\r\n if Handle <> 0 then\r\n SendMessage(Handle, FSetRBGMessage, 0, ColorToRGB(Color));\r\nend;\r\n\r\nfunction TJvColorDialog.TaskModalDialog(DialogFunc: Pointer; var DialogData): Bool;\r\nbegin\r\n with TChooseColor(DialogData) do\r\n begin\r\n OldColorDialogHookProc := @lpfnHook;\r\n lpfnHook := ColorDialogHook;\r\n end;\r\n Result := inherited TaskModalDialog(DialogFunc, DialogData);\r\nend;\r\n\r\nprocedure TJvColorDialog.WMNCDestroy(var Msg: TWMNCDestroy);\r\nbegin\r\n inherited;\r\n OldColorDialogHookProc := nil;\r\nend;\r\n\r\ninitialization\r\n {$IFDEF UNITVERSIONING}\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n {$ENDIF UNITVERSIONING}\r\n\r\nfinalization\r\n UninstallW2kFix;\r\n {$IFDEF UNITVERSIONING}\r\n UnregisterUnitVersion(HInstance);\r\n {$ENDIF UNITVERSIONING}\r\n\r\nend." }, { "path": "External/Jedi/Jvcl/run/JvDice.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvDice.PAS, released on 2002-07-04.\r\n\r\nThe Initial Developers of the Original Code are: Fedor Koshevnikov, Igor Pavluk and Serge Korolev\r\nCopyright (c) 1997, 1998 Fedor Koshevnikov, Igor Pavluk and Serge Korolev\r\nCopyright (c) 2001,2002 SGB Software\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\n Polaris Software\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvDice.pas 13104 2011-09-07 06:50:43Z obones $\r\n\r\nunit JvDice;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, Messages, Classes, Graphics, Controls,\r\n JvTimer, JvComponent, JvExControls;\r\n\r\nconst\r\n WM_JVDICE_STOP_ROTATE = WM_APP + 1;\r\n\r\ntype\r\n TJvDiceValue = 1..6;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvDice = class(TJvCustomControl) // , IJvDenySubClassing\r\n private\r\n FActive: Boolean;\r\n FBitmap: array [TJvDiceValue] of TBitmap;\r\n FInterval: Cardinal;\r\n FAutoStopInterval: Cardinal;\r\n FOnChange: TNotifyEvent;\r\n FRotate: Boolean;\r\n FShowFocus: Boolean;\r\n FTimer: TJvTimer;\r\n FTickCount: Longint;\r\n FValue: TJvDiceValue;\r\n FOnStart: TNotifyEvent;\r\n FOnStop: TNotifyEvent;\r\n procedure SetInterval(Value: Cardinal);\r\n procedure SetRotate(Value: Boolean);\r\n procedure SetShowFocus(Value: Boolean);\r\n procedure SetValue(Value: TJvDiceValue);\r\n procedure TimerFires(Sender: TObject);\r\n procedure NewRandomValue;\r\n protected\r\n procedure FocusChanged(AControl: TWinControl); override;\r\n function DoEraseBackground(Canvas: TCanvas; Param: LPARAM): Boolean; override;\r\n procedure SetAutoSize(Value: Boolean); override;\r\n function GetPalette: HPALETTE; override;\r\n procedure AdjustSize; override;\r\n procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;\r\n procedure Paint; override;\r\n procedure Change; dynamic;\r\n procedure DoStart; dynamic;\r\n procedure DoStop; dynamic;\r\n procedure WmJvDidecStopRotate(var Msg: TMessage); message WM_JVDICE_STOP_ROTATE;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n procedure Throw;\r\n published\r\n {$IFDEF JVCLThemesEnabled}\r\n property ParentBackground default True;\r\n {$ENDIF JVCLThemesEnabled}\r\n property Align;\r\n property AutoSize default True;\r\n property DragCursor;\r\n property DragKind;\r\n property OnEndDock;\r\n property OnStartDock;\r\n property AutoStopInterval: Cardinal read FAutoStopInterval write FAutoStopInterval default 0;\r\n property Color;\r\n property Cursor;\r\n property DragMode;\r\n property Enabled;\r\n property Interval: Cardinal read FInterval write SetInterval default 60;\r\n property ParentColor;\r\n property ParentShowHint;\r\n property PopupMenu;\r\n property Rotate: Boolean read FRotate write SetRotate default False;\r\n property ShowFocus: Boolean read FShowFocus write SetShowFocus default False;\r\n property ShowHint;\r\n property Anchors;\r\n property Constraints;\r\n property TabOrder;\r\n property TabStop;\r\n property Value: TJvDiceValue read FValue write SetValue default Low(TJvDiceValue);\r\n property Visible;\r\n property OnClick;\r\n property OnDblClick;\r\n property OnEnter;\r\n property OnExit;\r\n property OnMouseMove;\r\n property OnMouseDown;\r\n property OnMouseUp;\r\n property OnKeyDown;\r\n property OnKeyUp;\r\n property OnKeyPress;\r\n property OnDragOver;\r\n property OnDragDrop;\r\n property OnEndDrag;\r\n property OnStartDrag;\r\n property OnContextPopup;\r\n property OnChange: TNotifyEvent read FOnChange write FOnChange;\r\n property OnStart: TNotifyEvent read FOnStart write FOnStart;\r\n property OnStop: TNotifyEvent read FOnStop write FOnStop;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvDice.pas $';\r\n Revision: '$Revision: 13104 $';\r\n Date: '$Date: 2011-09-07 08:50:43 +0200 (mer. 07 sept. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n SysUtils, ImgList,\r\n JvThemes;\r\n\r\n{$R JvDice.Res}\r\n\r\nconstructor TJvDice.Create(AOwner: TComponent);\r\nvar\r\n I: TJvDiceValue;\r\nbegin\r\n inherited Create(AOwner);\r\n Randomize;\r\n ControlStyle := [csClickEvents, csSetCaption, csCaptureMouse,\r\n csOpaque, csDoubleClicks];\r\n IncludeThemeStyle(Self, [csParentBackground]);\r\n FInterval := 60;\r\n FValue := Low(TJvDiceValue);\r\n for I := Low(TJvDiceValue) to High(TJvDiceValue) do\r\n begin\r\n FBitmap[I] := TBitmap.Create;\r\n FBitmap[I].LoadFromResourceName(HInstance, Format('JvDice%d', [Ord(I)]));\r\n end;\r\n AutoSize := True;\r\n Width := FBitmap[Value].Width + 2;\r\n Height := FBitmap[Value].Height + 2;\r\nend;\r\n\r\ndestructor TJvDice.Destroy;\r\nvar\r\n I: TJvDiceValue;\r\nbegin\r\n FOnChange := nil;\r\n for I := Low(TJvDiceValue) to High(TJvDiceValue) do\r\n FBitmap[I].Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvDice.Throw;\r\nbegin\r\n Value := TJvDiceValue(Random(6) + 1);\r\nend;\r\n\r\nprocedure TJvDice.NewRandomValue;\r\nvar\r\n Val: Byte;\r\nbegin\r\n repeat\r\n Val := Random(6) + 1;\r\n until Val <> Byte(Value);\r\n Value := TJvDiceValue(Val);\r\nend;\r\n\r\n\r\nfunction TJvDice.GetPalette: HPALETTE;\r\nbegin\r\n Result := FBitmap[Value].Palette;\r\nend;\r\n\r\n\r\nprocedure TJvDice.DoStart;\r\nbegin\r\n if Assigned(FOnStart) then\r\n FOnStart(Self);\r\nend;\r\n\r\nprocedure TJvDice.DoStop;\r\nbegin\r\n if Assigned(FOnStop) then\r\n FOnStop(Self);\r\nend;\r\n\r\nprocedure TJvDice.FocusChanged(AControl: TWinControl);\r\nvar\r\n Active: Boolean;\r\nbegin\r\n Active := AControl = Self;\r\n if Active <> FActive then\r\n begin\r\n FActive := Active;\r\n if FShowFocus then\r\n Invalidate;\r\n end;\r\n inherited FocusChanged(AControl);\r\nend;\r\n\r\nfunction TJvDice.DoEraseBackground(Canvas: TCanvas; Param: LPARAM): Boolean;\r\nbegin\r\n Result := True; // Paint clears the background\r\nend;\r\n\r\nprocedure TJvDice.AdjustSize;\r\nvar\r\n MinSide: Integer;\r\nbegin\r\n if not (csReading in ComponentState) then\r\n begin\r\n if AutoSize and (FBitmap[Value].Width > 0) and\r\n (FBitmap[Value].Height > 0) then\r\n SetBounds(Left, Top, FBitmap[Value].Width + 2, FBitmap[Value].Height + 2)\r\n else\r\n begin\r\n { Adjust aspect ratio if control size changed }\r\n MinSide := Width;\r\n if Height < Width then\r\n MinSide := Height;\r\n SetBounds(Left, Top, MinSide, MinSide);\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvDice.MouseDown(Button: TMouseButton;\r\n Shift: TShiftState; X, Y: Integer);\r\nbegin\r\n if (Button = mbLeft) and TabStop and CanFocus then\r\n SetFocus;\r\n inherited MouseDown(Button, Shift, X, Y);\r\nend;\r\n\r\nprocedure TJvDice.Paint;\r\nvar\r\n ARect: TRect;\r\n\r\n procedure DrawBitmap;\r\n var\r\n TmpImage: TBitmap;\r\n IWidth, IHeight: Integer;\r\n IRect: TRect;\r\n ImgList: TImageList;\r\n begin\r\n IWidth := FBitmap[Value].Width;\r\n IHeight := FBitmap[Value].Height;\r\n if (IWidth = 0) and (IHeight = 0) then\r\n Exit;\r\n\r\n IRect := Rect(0, 0, IWidth, IHeight);\r\n TmpImage := TBitmap.Create;\r\n ImgList := TImageList.CreateSize(IWidth, IHeight);\r\n try\r\n ImgList.AddMasked(FBitmap[Value], FBitmap[Value].TransparentColor);\r\n TmpImage.Width := IWidth;\r\n TmpImage.Height := IHeight;\r\n TmpImage.Canvas.CopyRect(ClientRect, Canvas, ClientRect);\r\n ImgList.Draw(TmpImage.Canvas, 0, 0, 0);\r\n InflateRect(ARect, -1, -1);\r\n Canvas.StretchDraw(ARect, TmpImage);\r\n finally\r\n TmpImage.Free;\r\n ImgList.Free;\r\n end;\r\n end;\r\n\r\nbegin\r\n Canvas.Brush.Color := Parent.Brush.Color;\r\n DrawThemedBackground(Self, Canvas, ClientRect);\r\n ARect := ClientRect;\r\n DrawBitmap;\r\n if Focused and FShowFocus and TabStop and not (csDesigning in ComponentState) then\r\n Canvas.DrawFocusRect(ARect);\r\nend;\r\n\r\nprocedure TJvDice.TimerFires(Sender: TObject);\r\nvar\r\n Now: Longint;\r\nbegin\r\n // Note: This method here is done in the context of the main thread of the\r\n // application. However, the timer thread is waiting for this event\r\n // handler to finish. So if call any method that in turn waits for the\r\n // timer thread, we are bound to get into a deadlock. This is the\r\n // reason why we post a message to the component telling it to stop\r\n // rotating at the first available moment after we have returned.\r\n NewRandomValue;\r\n\r\n if FRotate and (AutoStopInterval > 0) then\r\n begin\r\n Now := GetTickCount;\r\n if (Now - FTickCount >= Integer(AutoStopInterval)) or (Now < FTickCount) then\r\n PostMessage(Handle, WM_JVDICE_STOP_ROTATE, 0, 0);\r\n end;\r\nend;\r\n\r\nprocedure TJvDice.WmJvDidecStopRotate(var Msg: TMessage);\r\nbegin\r\n Rotate := False;\r\nend;\r\n\r\nprocedure TJvDice.Change;\r\nbegin\r\n if Assigned(FOnChange) then\r\n FOnChange(Self);\r\nend;\r\n\r\nprocedure TJvDice.SetValue(Value: TJvDiceValue);\r\nbegin\r\n if FValue <> Value then\r\n begin\r\n FValue := Value;\r\n Invalidate;\r\n Change;\r\n end;\r\nend;\r\n\r\nprocedure TJvDice.SetAutoSize(Value: Boolean);\r\nbegin\r\n inherited SetAutoSize(Value);\r\n AdjustSize;\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvDice.SetInterval(Value: Cardinal);\r\nbegin\r\n if FInterval <> Value then\r\n begin\r\n FInterval := Value;\r\n if FTimer <> nil then\r\n FTimer.Interval := FInterval;\r\n end;\r\nend;\r\n\r\nprocedure TJvDice.SetRotate(Value: Boolean);\r\nbegin\r\n if FRotate <> Value then\r\n begin\r\n if Value then\r\n begin\r\n if FTimer = nil then\r\n FTimer := TJvTimer.Create(Self);\r\n try\r\n with FTimer do\r\n begin\r\n OnTimer := TimerFires;\r\n Interval := FInterval;\r\n Enabled := True;\r\n end;\r\n FRotate := Value;\r\n FTickCount := GetTickCount;\r\n DoStart;\r\n except\r\n FTimer.Free;\r\n FTimer := nil;\r\n raise;\r\n end;\r\n end\r\n else\r\n begin\r\n FRotate := Value;\r\n FTimer.Free;\r\n FTimer := nil;\r\n DoStop;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvDice.SetShowFocus(Value: Boolean);\r\nbegin\r\n if FShowFocus <> Value then\r\n begin\r\n FShowFocus := Value;\r\n if not (csDesigning in ComponentState) then\r\n Invalidate;\r\n end;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvDiskPrompt.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvDiskPrompt.PAS, released on 2001-02-28.\r\n\r\nThe Initial Developer of the Original Code is Sbastien Buysse [sbuysse att buypin dott com]\r\nPortions created by Sbastien Buysse are Copyright (C) 2001 Sbastien Buysse.\r\nAll Rights Reserved.\r\n\r\nContributor(s): Michael Beck [mbeck att bigfoot dott com].\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvDiskPrompt.pas 13351 2012-06-13 15:16:00Z obones $\r\n\r\nunit JvDiskPrompt;\r\n\r\n{$I jvcl.inc}\r\n{$I windowsonly.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, Classes,\r\n JvCustomFileMessageDialog, JvTypes;\r\n\r\ntype\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvDiskPrompt = class(TJvCustomFileMessageDialog)\r\n private\r\n FPathToSource: string;\r\n FTagFile: string;\r\n FNewPath: string;\r\n FFileSought: string;\r\n FDiskName: string;\r\n FStyle: TJvDiskStyles;\r\n protected\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n function Execute: TJvDiskRes; override;\r\n published\r\n property DiskName: string read FDiskName write FDiskName;\r\n property PathToSource: string read FPathToSource write FPathToSource;\r\n property FileSought: string read FFileSought write FFileSought;\r\n property TagFile: string read FTagFile write FTagFile;\r\n property NewPath: string read FNewPath write FNewPath;\r\n property Style: TJvDiskStyles read FStyle write FStyle default [];\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvDiskPrompt.pas $';\r\n Revision: '$Revision: 13351 $';\r\n Date: '$Date: 2012-06-13 17:16:00 +0200 (mer. 13 juin 2012) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n JvSetupApi;\r\n\r\nconstructor TJvDiskPrompt.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FDiskName := '';\r\n FPathToSource := '';\r\n FFileSought := '';\r\n FTagFile := '';\r\n FNewPath := '';\r\n FStyle := [];\r\nend;\r\n\r\nfunction TJvDiskPrompt.Execute: TJvDiskRes;\r\nvar\r\n Required: DWORD;\r\n Res: array [0..255] of Char;\r\nbegin\r\n case SetupPromptForDisk(OwnerWindow, Pointer(Title), Pointer(DiskName),\r\n Pointer(PathToSource), PChar(FileSought), Pointer(TagFile),\r\n JvDiskStylesToDWORD(Style), Res, SizeOf(Res), Required) of\r\n DPROMPT_SUCCESS:\r\n begin\r\n FNewPath := Res;\r\n Result := dsSuccess;\r\n end;\r\n DPROMPT_CANCEL:\r\n Result := dsCancel;\r\n DPROMPT_SKIPFILE:\r\n Result := dsSkipfile;\r\n else\r\n Result := dsError;\r\n end;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend." }, { "path": "External/Jedi/Jvcl/run/JvDockAdvTree.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvDockAdvTree.pas, released on 2005-02-14.\r\n\r\nThe Initial Developer of the Original Code is luxiaoban.\r\nPortions created by luxiaoban are Copyright (C) 2002,2003 luxiaoban.\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\n\r\nLast Modified: 2005-02-08\r\n\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\n\r\nDescription:\r\n Code split out from JvDockTree.pas because of compiler issues - WPostma.\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvDockAdvTree.pas 13145 2011-11-02 21:15:19Z ahuser $\r\n\r\nunit JvDockAdvTree;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, Messages, Classes, Graphics, Controls, Forms,\r\n JvDockTree;\r\n\r\ntype\r\n TJvDockAdvTree = class(TJvDockTree)\r\n private\r\n FButtonHeight: Integer;\r\n FButtonWidth: Integer;\r\n FLeftOffset: Integer;\r\n FRightOffset: Integer;\r\n FTopOffset: Integer;\r\n FBottomOffset: Integer;\r\n FButtonSplitter: Integer;\r\n FCloseButtonZone: TJvDockAdvZone;\r\n FDropDockSize: Integer;\r\n FDockHeightWidth: array [TDockOrientation] of Integer;\r\n FDockRectangles: array [TDockOrientation, Boolean] of Integer;\r\n procedure SetBottomOffset(const Value: Integer);\r\n procedure SetButtonHeight(const Value: Integer);\r\n procedure SetButtonSplitter(const Value: Integer);\r\n procedure SetButtonWidth(const Value: Integer);\r\n procedure SetLeftOffset(const Value: Integer);\r\n procedure SetRightOffset(const Value: Integer);\r\n procedure SetTopOffset(const Value: Integer);\r\n function GetDockHeightWidth(Orient: TDockOrientation): Integer;\r\n procedure SetDockHeightWidth(Orient: TDockOrientation; const Value: Integer);\r\n function GetDockRectangles(Orient: TDockOrientation; AtLast: Boolean): Integer;\r\n procedure SetDockRectangles(Orient: TDockOrientation; AtLast: Boolean; const Value: Integer);\r\n procedure SetDropDockSize(const Value: Integer);\r\n protected\r\n function DoLButtonDown(var Msg: TWMMouse;\r\n var Zone: TJvDockZone; out HTFlag: Integer): Boolean; override;\r\n procedure DoLButtonUp(var Msg: TWMMouse;\r\n var Zone: TJvDockZone; out HTFlag: Integer); override;\r\n procedure DoMouseMove(var Msg: TWMMouse;\r\n var Zone: TJvDockZone; out HTFlag: Integer); override;\r\n procedure InsertSibling(NewZone, SiblingZone: TJvDockZone;\r\n InsertLast, Update: Boolean); override;\r\n procedure InsertNewParent(NewZone, SiblingZone: TJvDockZone;\r\n ParentOrientation: TDockOrientation; InsertLast, Update: Boolean); override;\r\n procedure InitDockHeightWidth(NoOrValue, HorValue, VerValue: Integer);\r\n procedure InitDockRectangles(ARect: TRect);\r\n procedure ScaleZone(Zone: TJvDockZone); override;\r\n procedure ScaleChildZone(Zone: TJvDockZone); override;\r\n procedure ScaleSiblingZone(Zone: TJvDockZone); override;\r\n procedure ShiftZone(Zone: TJvDockZone); override;\r\n procedure RemoveZone(Zone: TJvDockZone; Hide: Boolean); override;\r\n public\r\n constructor Create(DockSite: TWinControl; ADockZoneClass: TJvDockZoneClass;\r\n ADockStyle: TJvDockObservableStyle); override;\r\n property BottomOffset: Integer read FBottomOffset write SetBottomOffset;\r\n property ButtonHeight: Integer read FButtonHeight write SetButtonHeight;\r\n property ButtonSplitter: Integer read FButtonSplitter write SetButtonSplitter;\r\n property ButtonWidth: Integer read FButtonWidth write SetButtonWidth;\r\n property LeftOffset: Integer read FLeftOffset write SetLeftOffset;\r\n property RightOffset: Integer read FRightOffset write SetRightOffset;\r\n property TopOffset: Integer read FTopOffset write SetTopOffset;\r\n property CloseButtonZone: TJvDockAdvZone read FCloseButtonZone write FCloseButtonZone;\r\n property DockHeightWidth[Orient: TDockOrientation]: Integer read GetDockHeightWidth write SetDockHeightWidth;\r\n property DockRectangles[Orient: TDockOrientation; AtLast: Boolean]: Integer read GetDockRectangles write\r\n SetDockRectangles;\r\n property DropDockSize: Integer read FDropDockSize write SetDropDockSize;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvDockAdvTree.pas $';\r\n Revision: '$Revision: 13145 $';\r\n Date: '$Date: 2011-11-02 22:15:19 +0100 (mer. 02 nov. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\n//=== { TJvDockAdvTree } =====================================================\r\n\r\nconstructor TJvDockAdvTree.Create(DockSite: TWinControl;\r\n ADockZoneClass: TJvDockZoneClass; ADockStyle: TJvDockObservableStyle);\r\nbegin\r\n inherited Create(DockSite, ADockZoneClass, ADockStyle);\r\n FButtonHeight := 12;\r\n FButtonWidth := 12;\r\n FLeftOffset := 0;\r\n FRightOffset := 0;\r\n FTopOffset := 0;\r\n FBottomOffset := 0;\r\n FButtonSplitter := 2;\r\nend;\r\n\r\nfunction TJvDockAdvTree.DoLButtonDown(var Msg: TWMMouse;\r\n var Zone: TJvDockZone; out HTFlag: Integer): Boolean;\r\nvar\r\n TempZone: TJvDockAdvZone;\r\nbegin\r\n Result := inherited DoLButtonDown(Msg, Zone, HTFlag);\r\n if (Zone <> nil) and (HTFlag = HTCLOSE) then\r\n begin\r\n TempZone := TJvDockAdvZone(Zone);\r\n TempZone.CloseBtnDown := True;\r\n TempZone.MouseDown := True;\r\n FCloseButtonZone := TempZone;\r\n DockSite.Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockAdvTree.DoLButtonUp(var Msg: TWMMouse;\r\n var Zone: TJvDockZone; out HTFlag: Integer);\r\nbegin\r\n inherited DoLButtonUp(Msg, Zone, HTFlag);\r\n if SizingZone = nil then\r\n begin\r\n FCloseButtonZone := nil;\r\n if (Zone <> nil) and (HTFlag = HTCLOSE) then\r\n TJvDockAdvZone(Zone).CloseBtnDown := False;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockAdvTree.DoMouseMove(var Msg: TWMMouse;\r\n var Zone: TJvDockZone; out HTFlag: Integer);\r\nvar\r\n TempZone: TJvDockAdvZone;\r\nbegin\r\n inherited DoMouseMove(Msg, Zone, HTFlag);\r\n if SizingZone = nil then\r\n begin\r\n TempZone := TJvDockAdvZone(Zone);\r\n if ((TempZone <> nil) and (TempZone.CloseBtnDown <> (HTFlag = HTCLOSE)) and\r\n ((FCloseButtonZone = TempZone) and FCloseButtonZone.MouseDown)) then\r\n begin\r\n TempZone.CloseBtnDown := (HTFlag = HTCLOSE) and FCloseButtonZone.MouseDown;\r\n DockSite.Invalidate;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockAdvTree.InsertSibling(NewZone, SiblingZone: TJvDockZone;\r\n InsertLast, Update: Boolean);\r\nvar\r\n TempUpdate: Boolean;\r\nbegin\r\n TempUpdate := Update;\r\n Update := False;\r\n try\r\n inherited InsertSibling(NewZone, SiblingZone, InsertLast, Update);\r\n if NewZone.ChildControl <> nil then\r\n InitDockHeightWidth(0, NewZone.ChildControl.TBDockHeight + BorderWidth,\r\n NewZone.ChildControl.LRDockWidth + BorderWidth)\r\n else\r\n InitDockHeightWidth(0, 0, 0);\r\n finally\r\n Update := TempUpdate;\r\n end;\r\n\r\n if Update then\r\n begin\r\n NewZone.Insert(FDropDockSize, False);\r\n SetNewBounds(NewZone.ParentZone);\r\n ForEachAt(NewZone.ParentZone, UpdateZone, tskForward);\r\n end;\r\nend;\r\n\r\nprocedure TJvDockAdvTree.SetBottomOffset(const Value: Integer);\r\nbegin\r\n FBottomOffset := Value;\r\nend;\r\n\r\nprocedure TJvDockAdvTree.SetButtonHeight(const Value: Integer);\r\nbegin\r\n FButtonHeight := Value;\r\nend;\r\n\r\nprocedure TJvDockAdvTree.SetButtonSplitter(const Value: Integer);\r\nbegin\r\n FButtonSplitter := Value;\r\nend;\r\n\r\nprocedure TJvDockAdvTree.SetButtonWidth(const Value: Integer);\r\nbegin\r\n FButtonWidth := Value;\r\nend;\r\n\r\nprocedure TJvDockAdvTree.SetLeftOffset(const Value: Integer);\r\nbegin\r\n FLeftOffset := Value;\r\nend;\r\n\r\nprocedure TJvDockAdvTree.SetRightOffset(const Value: Integer);\r\nbegin\r\n FRightOffset := Value;\r\nend;\r\n\r\nprocedure TJvDockAdvTree.SetTopOffset(const Value: Integer);\r\nbegin\r\n FTopOffset := Value;\r\nend;\r\n\r\nfunction TJvDockAdvTree.GetDockHeightWidth(Orient: TDockOrientation): Integer;\r\nbegin\r\n Result := FDockHeightWidth[Orient];\r\nend;\r\n\r\nprocedure TJvDockAdvTree.SetDockHeightWidth(Orient: TDockOrientation;\r\n const Value: Integer);\r\nbegin\r\n FDockHeightWidth[Orient] := Value;\r\nend;\r\n\r\nfunction TJvDockAdvTree.GetDockRectangles(Orient: TDockOrientation;\r\n AtLast: Boolean): Integer;\r\nbegin\r\n Result := FDockRectangles[Orient, AtLast];\r\nend;\r\n\r\nprocedure TJvDockAdvTree.SetDockRectangles(Orient: TDockOrientation;\r\n AtLast: Boolean; const Value: Integer);\r\nbegin\r\n FDockRectangles[Orient, AtLast] := Value;\r\nend;\r\n\r\nprocedure TJvDockAdvTree.InitDockRectangles(ARect: TRect);\r\nbegin\r\n FDockRectangles[doNoOrient, False] := 0;\r\n FDockRectangles[doNoOrient, True] := 0;\r\n FDockRectangles[doHorizontal, False] := ARect.Top;\r\n FDockRectangles[doHorizontal, True] := ARect.Bottom;\r\n FDockRectangles[doVertical, False] := ARect.Left;\r\n FDockRectangles[doVertical, True] := ARect.Right;\r\nend;\r\n\r\nprocedure TJvDockAdvTree.InitDockHeightWidth(NoOrValue, HorValue,\r\n VerValue: Integer);\r\nbegin\r\n FDockHeightWidth[doNoOrient] := NoOrValue;\r\n FDockHeightWidth[doHorizontal] := HorValue;\r\n FDockHeightWidth[doVertical] := VerValue;\r\nend;\r\n\r\nprocedure TJvDockAdvTree.ScaleChildZone(Zone: TJvDockZone);\r\nbegin\r\n if Zone = ReplacementZone then\r\n ShiftScaleOrientation := doNoOrient;\r\n inherited ScaleChildZone(Zone);\r\nend;\r\n\r\nprocedure TJvDockAdvTree.ScaleSiblingZone(Zone: TJvDockZone);\r\nbegin\r\n if Zone = ReplacementZone then\r\n ShiftScaleOrientation := doNoOrient;\r\n inherited ScaleSiblingZone(Zone);\r\nend;\r\n\r\nprocedure TJvDockAdvTree.ScaleZone(Zone: TJvDockZone);\r\nbegin\r\n if Zone = ReplacementZone then\r\n ShiftScaleOrientation := doNoOrient;\r\n inherited ScaleZone(Zone);\r\nend;\r\n\r\nprocedure TJvDockAdvTree.ShiftZone(Zone: TJvDockZone);\r\nbegin\r\n if Zone = ReplacementZone then\r\n ShiftScaleOrientation := doNoOrient;\r\n inherited ShiftZone(Zone);\r\nend;\r\n\r\nprocedure TJvDockAdvTree.InsertNewParent(NewZone, SiblingZone: TJvDockZone;\r\n ParentOrientation: TDockOrientation; InsertLast, Update: Boolean);\r\nvar\r\n TempUpdate: Boolean;\r\nbegin\r\n TempUpdate := Update;\r\n Update := False;\r\n if NewZone.ChildControl <> nil then\r\n InitDockHeightWidth(0, NewZone.ChildControl.TBDockHeight + BorderWidth,\r\n NewZone.ChildControl.LRDockWidth + BorderWidth)\r\n else\r\n InitDockHeightWidth(0, 0, 0);\r\n\r\n if SiblingZone = nil then\r\n if InsertLast then\r\n ReplacementZone := TopZone\r\n else\r\n ReplacementZone := NewZone;\r\n\r\n try\r\n inherited InsertNewParent(NewZone, SiblingZone, ParentOrientation, InsertLast, Update);\r\n finally\r\n Update := TempUpdate;\r\n ReplacementZone := nil;\r\n end;\r\n\r\n if Update then\r\n begin\r\n NewZone.Insert(DropDockSize, False);\r\n ForEachAt(NewZone.ParentZone, UpdateZone, tskForward);\r\n SetNewBounds(NewZone.ParentZone);\r\n end;\r\nend;\r\n\r\nprocedure TJvDockAdvTree.RemoveZone(Zone: TJvDockZone; Hide: Boolean);\r\nbegin\r\n inherited RemoveZone(Zone, Hide);\r\nend;\r\n\r\nprocedure TJvDockAdvTree.SetDropDockSize(const Value: Integer);\r\nbegin\r\n FDropDockSize := Value;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend." }, { "path": "External/Jedi/Jvcl/run/JvDockConjoinHost.dfm", "content": "object JvDockConjoinHost: TJvDockConjoinHost\r\n Left = 300\r\n Top = 200\r\n Width = 0\r\n Height = 0\r\n Caption = ''\r\n Color = clBtnFace\r\n Font.Charset = DEFAULT_CHARSET\r\n Font.Color = clWindowText\r\n Font.Height = -12\r\n Font.Name = 'Arial'\r\n Font.Style = []\r\n OldCreateOrder = False\r\n Visible = False\r\n PixelsPerInch = 96\r\n TextHeight = 13\r\nend\r\n" }, { "path": "External/Jedi/Jvcl/run/JvDockControlForm.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvDockControlForm.pas, released on 2003-12-31.\r\n\r\nThe Initial Developer of the Original Code is luxiaoban.\r\nPortions created by luxiaoban are Copyright (C) 2002,2003 luxiaoban.\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\n 2005-02-08 - Warren Postma - TJvDockServer.CustomPanel.\r\n\r\nLast Modified: 2005-02-08\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvDockControlForm.pas 13415 2012-09-10 09:51:54Z obones $\r\n\r\n{ Changes:\r\n\r\n 2005-02-08 WP: Added TJvDockServer.CustomDock panel (new property),\r\n and new event TJvDockServer.OnCustomPanel to get\r\n a custom parent control (such as the form's center area) for the\r\n CustomPanel. Previously you could only dock at the edges. Created a\r\n splitter object (to avoid possible access violations) but the splitter\r\n control is hidden and never used for this custom panel. Several\r\n changes were made to the VID dock style also to make this custom\r\n panel more useful,allowing an \"tabbed MDI\" style application.\r\n}\r\n\r\nunit JvDockControlForm;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, Messages, Classes, Graphics, Controls, Forms, Menus,\r\n ExtCtrls, ComCtrls,\r\n JvComponentBase, JvComponent, JvAppStorage, JvConsts,\r\n JvDockTree, JvDockSupportClass, JvDockSupportControl, JvDockAdvTree;\r\n\r\nconst\r\n JvDockPositionCount = 5;\r\n\r\n JvDockState_Unknown = 0;\r\n JvDockState_Docking = 1;\r\n JvDockState_Floating = 2;\r\n\r\ntype\r\n TJvDockSplitterSize = 0..32767;\r\n\r\n TJvDockBaseControl = class;\r\n TJvDockServer = class;\r\n TJvDockClient = class;\r\n TJvDockConjoinPanel = class;\r\n TJvDockTabPageControl = class;\r\n TJvDockConjoinHostForm = class;\r\n TJvDockTabHostForm = class;\r\n\r\n TJvDockSplitter = class(TJvDockCustomPanelSplitter)\r\n private\r\n FDockServer: TJvDockServer;\r\n function GetSplitterIndex: Integer;\r\n protected\r\n function FindControl: TControl; override;\r\n property DockServer: TJvDockServer read FDockServer write FDockServer;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n property SplitterIndex: Integer read GetSplitterIndex;\r\n end;\r\n\r\n TJvDockSetDockPanelSizeFrom = (sdfDockPanel, sdfClient);\r\n\r\n TJvDockPanel = class(TJvDockCustomPanel)\r\n private\r\n FDockServer: TJvDockServer;\r\n FCustomFlag: Boolean; // Set only if custom area! {NEW}\r\n function GetPanelIndex: Integer;\r\n\tprocedure SetDockServer(ADockServer: TJvDockServer);\r\n protected\r\n function CreateDockManager: IDockManager; override;\r\n procedure AddDockServer(ADockServer: TJvDockServer); virtual;\r\n procedure RemoveDockServer(ADockServer: TJvDockServer); virtual;\r\n procedure ReloadDockedControl(const AControlName: string;\r\n var AControl: TControl); override;\r\n procedure CustomStartDock(var Source: TJvDockDragDockObject); override;\r\n procedure CustomGetSiteInfo(Source: TJvDockDragDockObject; Client: TControl; var InfluenceRect: TRect;\r\n MousePos: TPoint; var CanDock: Boolean); override;\r\n procedure CustomDockOver(Source: TJvDockDragDockObject; X, Y: Integer;\r\n State: TDragState; var Accept: Boolean); override;\r\n procedure CustomPositionDockRect(Source: TJvDockDragDockObject; X, Y: Integer); override;\r\n procedure CustomDockDrop(Source: TJvDockDragDockObject; X, Y: Integer); override;\r\n procedure CustomEndDock(Target: TObject; X, Y: Integer); override;\r\n function CustomUnDock(Source: TJvDockDragDockObject; NewTarget: TWinControl; Client: TControl): Boolean; override;\r\n function DoUnDock(NewTarget: TWinControl; Client: TControl): Boolean; override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n procedure DockDrop(Source: TDragDockObject; X, Y: Integer); override;\r\n\r\n procedure ShowDockPanel(MakeVisible: Boolean; Client: TControl;\r\n PanelSizeFrom: TJvDockSetDockPanelSizeFrom = sdfClient); virtual;\r\n procedure ResetPosition;\r\n\t// GetDockedControls: NEW! -WPostma.\r\n\t// base class doesn't have this capability.\r\n\t// see TJvDockAdvPanel for override that implements this!\r\n\tprocedure GetDockedControls(WinControls: TList); virtual; { not supported in base! }\r\n\tfunction FindTabHostForm:TWinControl; virtual;\r\n\r\n property PanelIndex: Integer read GetPanelIndex;\r\n property DockServer: TJvDockServer read FDockServer write SetDockServer;\r\n property CustomFlag: Boolean read FCustomFlag write FCustomFlag; // Set only if custom area! {NEW}\r\n end;\r\n\r\n TJvDockAdvPanel = class(TJvDockPanel)\r\n private\r\n procedure CMUnDockClient(var Msg: TCMUnDockClient); message CM_UNDOCKCLIENT;\r\n protected\r\n procedure CustomDockDrop(Source: TJvDockDragDockObject; X, Y: Integer); override;\r\n function CustomUnDock(Source: TJvDockDragDockObject; NewTarget: TWinControl; Client: TControl): Boolean; override;\r\n function DoUnDock(NewTarget: TWinControl; Client: TControl): Boolean; override;\r\n public\r\n\tprocedure GetDockedControls(WinControls: TList); override;\r\n\tfunction FindTabHostForm:TWinControl; override;\r\n\tprocedure DockDrop(Source: TDragDockObject; X, Y: Integer); override;\r\n end;\r\n\r\n TJvDockPanelClass = class of TJvDockPanel;\r\n TJvDockSplitterClass = class of TJvDockSplitter;\r\n TJvDockConjoinPanelClass = class of TJvDockConjoinPanel;\r\n TJvDockTabClass = class of TJvDockTabPageControl;\r\n\r\n { Maintained by a TJvDockServer; TJvDockServer ensures that FDockServer is\r\n assigned. FSplitter may be nil }\r\n TJvDockSplitterStyle = class(TPersistent)\r\n private\r\n FSplitter: TJvDockSplitter;\r\n FDockServer: TJvDockServer;\r\n FColor: TColor;\r\n FCursor: TCursor;\r\n FParentColor: Boolean;\r\n FResizeStyle: TResizeStyle;\r\n FSize: TJvDockSplitterSize;\r\n FMinSize: TJvDockSplitterSize;\r\n procedure SetColor(const Value: TColor);\r\n procedure SetCursor(const Value: TCursor);\r\n procedure SetParentColor(const Value: Boolean);\r\n procedure SetResizeStyle(const Value: TResizeStyle);\r\n procedure SetSize(const Value: TJvDockSplitterSize);\r\n procedure SetMinSize(const Value: TJvDockSplitterSize);\r\n protected\r\n procedure AssignTo(Dest: TPersistent); override;\r\n procedure AssignToSplitter(Dest: TJvDockSplitter);\r\n procedure SetSplitterStyle;\r\n property Splitter: TJvDockSplitter read FSplitter write FSplitter;\r\n public\r\n constructor Create(ASplitter: TJvDockSplitter; ACursor: TCursor); virtual;\r\n procedure Assign(Source: TPersistent); override;\r\n published\r\n property Color: TColor read FColor write SetColor default clBtnFace;\r\n property Cursor: TCursor read FCursor write SetCursor;\r\n property ParentColor: Boolean read FParentColor write SetParentColor default True;\r\n property ResizeStyle: TResizeStyle read FResizeStyle write SetResizeStyle default rsPattern;\r\n property Size: TJvDockSplitterSize read FSize write SetSize default 3;\r\n property MinSize: TJvDockSplitterSize read FMinSize write SetMinSize default 30;\r\n end;\r\n\r\n TJvDockBasicStyle = class;\r\n\r\n TJvDockBasicStyle = class(TJvDockObservableStyle)\r\n private\r\n FDockPanelClass: TJvDockPanelClass;\r\n FDockSplitterClass: TJvDockSplitterClass;\r\n FConjoinPanelClass: TJvDockConjoinPanelClass;\r\n FTabDockClass: TJvDockTabClass;\r\n FDockPanelTreeClass: TJvDockTreeClass;\r\n FDockPanelZoneClass: TJvDockZoneClass;\r\n FConjoinPanelTreeClass: TJvDockTreeClass;\r\n FConjoinPanelZoneClass: TJvDockZoneClass;\r\n FDockBaseControls: TList;\r\n function GetDockBaseControlCount: Integer;\r\n function GetDockBaseControl(Index: Integer): TJvDockBaseControl;\r\n protected\r\n procedure FormStartDock(DockClient: TJvDockClient; var Source: TJvDockDragDockObject); virtual;\r\n procedure FormGetSiteInfo(Source: TJvDockDragDockObject; DockClient: TJvDockClient; Client: TControl;\r\n var InfluenceRect: TRect; MousePos: TPoint; var CanDock: Boolean); virtual;\r\n procedure FormDockOver(DockClient: TJvDockClient; Source: TJvDockDragDockObject; X, Y: Integer;\r\n State: TDragState; var Accept: Boolean); virtual;\r\n procedure FormPositionDockRect(DockClient: TJvDockClient; Source: TJvDockDragDockObject); virtual;\r\n procedure FormDockDrop(DockClient: TJvDockClient; Source: TJvDockDragDockObject; X, Y: Integer); virtual;\r\n procedure FormEndDock(DockClient: TJvDockClient; Target: TObject; X, Y: Integer); virtual;\r\n function FormUnDock(DockClient: TJvDockClient; NewTarget: TWinControl; Client: TControl): Boolean; virtual;\r\n procedure FormGetDockEdge(DockClient: TJvDockClient; Source: TJvDockDragDockObject;\r\n MousePos: TPoint; var DropAlign: TAlign); virtual;\r\n\r\n procedure SetDockBaseControl(IsCreate: Boolean; DockBaseControl: TJvDockBaseControl); virtual;\r\n function DockServerWindowProc(DockServer: TJvDockServer; var Msg: TMessage): Boolean; virtual;\r\n function DockClientWindowProc(DockClient: TJvDockClient; var Msg: TMessage): Boolean; virtual;\r\n procedure AddDockBaseControl(ADockBaseControl: TJvDockBaseControl); virtual;\r\n procedure RemoveDockBaseControl(ADockBaseControl: TJvDockBaseControl); virtual;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n\r\n function CanSetEnableDocked(ADockBaseControl: TJvDockBaseControl): Boolean; virtual;\r\n function CanSetLeftDocked(ADockBaseControl: TJvDockBaseControl): Boolean; virtual;\r\n function CanSetRightDocked(ADockBaseControl: TJvDockBaseControl): Boolean; virtual;\r\n function CanSetTopDocked(ADockBaseControl: TJvDockBaseControl): Boolean; virtual;\r\n function CanSetBottomDocked(ADockBaseControl: TJvDockBaseControl): Boolean; virtual;\r\n function CanSetEachOtherDocked(ADockBaseControl: TJvDockBaseControl): Boolean; virtual;\r\n\r\n procedure ResetCursor(Source: TJvDockDragDockObject); virtual;\r\n\r\n function GetDockState(DockClient: TJvDockClient): Integer; virtual;\r\n\r\n procedure DoShowDockForm(DockWindow: TWinControl); virtual;\r\n procedure DoHideDockForm(DockWindow: TWinControl); virtual;\r\n\r\n procedure ShowDockForm(ADockClient: TJvDockClient); virtual;\r\n procedure HideDockForm(ADockClient: TJvDockClient); virtual;\r\n function GetDockFormVisible(ADockClient: TJvDockClient): Boolean; virtual;\r\n\r\n property DockBaseControlCount: Integer read GetDockBaseControlCount;\r\n property DockBaseControl[Index: Integer]: TJvDockBaseControl read GetDockBaseControl;\r\n\r\n procedure RestoreClient(DockClient: TJvDockClient); virtual;\r\n property DockPanelClass: TJvDockPanelClass read FDockPanelClass write FDockPanelClass;\r\n property DockSplitterClass: TJvDockSplitterClass read FDockSplitterClass write FDockSplitterClass;\r\n property ConjoinPanelClass: TJvDockConjoinPanelClass read FConjoinPanelClass write FConjoinPanelClass;\r\n property TabDockClass: TJvDockTabClass read FTabDockClass write FTabDockClass;\r\n property DockPanelTreeClass: TJvDockTreeClass read FDockPanelTreeClass write FDockPanelTreeClass;\r\n property DockPanelZoneClass: TJvDockZoneClass read FDockPanelZoneClass write FDockPanelZoneClass;\r\n property ConjoinPanelTreeClass: TJvDockTreeClass read FConjoinPanelTreeClass write FConjoinPanelTreeClass;\r\n property ConjoinPanelZoneClass: TJvDockZoneClass read FConjoinPanelZoneClass write FConjoinPanelZoneClass;\r\n end;\r\n\r\n TJvDockAdvStyle = class(TJvDockBasicStyle)\r\n protected\r\n function DockClientWindowProc(DockClient: TJvDockClient; var Msg: TMessage): Boolean; override;\r\n end;\r\n\r\n TJvDockBaseControl = class(TJvComponent)\r\n private\r\n FEnableDock: Boolean;\r\n FLeftDock: Boolean; { Can the parent form be docked into the Left dock? }\r\n FTopDock: Boolean; { Can the parent form be docked into the Top dock? }\r\n FRightDock: Boolean; { Can the parent form be docked into the Right dock? }\r\n FBottomDock: Boolean; { Can the parent form be docked into the Bottom dock? }\r\n FCustomDock: Boolean; {NEW! Can the parent form be docked into the Custom (center window) dock area? }\r\n FEachOtherDock: Boolean;\r\n FDockStyle: TJvDockBasicStyle;\r\n FOldOnClose: TCloseEvent;\r\n FOldOnCreate: TNotifyEvent;\r\n FParentForm: TForm;\r\n FOldWindowProc: TWndMethod;\r\n procedure SetDockStyle(ADockStyle: TJvDockBasicStyle);\r\n protected\r\n procedure SetParentComponent(Value: TComponent); override;\r\n\r\n function CanSetEnableDocked: Boolean; virtual;\r\n function CanSetLeftDocked: Boolean; virtual;\r\n function CanSetRightDocked: Boolean; virtual;\r\n function CanSetTopDocked: Boolean; virtual;\r\n function CanSetBottomDocked: Boolean; virtual;\r\n function CanSetEachOtherDocked: Boolean; virtual;\r\n\r\n procedure DoFormOnClose(Sender: TObject; var Action: TCloseAction); virtual;\r\n procedure DoFormOnCreate(Sender: TObject); virtual;\r\n\r\n procedure SetBottomDock(const Value: Boolean); virtual;\r\n procedure SetEachOtherDock(const Value: Boolean); virtual;\r\n procedure SetEnableDock(const Value: Boolean); virtual;\r\n procedure SetLeftDock(const Value: Boolean); virtual;\r\n procedure SetRightDock(const Value: Boolean); virtual;\r\n procedure SetTopDock(const Value: Boolean); virtual;\r\n\r\n procedure AddDockStyle(ADockStyle: TJvDockBasicStyle); virtual;\r\n procedure RemoveDockStyle(ADockStyle: TJvDockBasicStyle); virtual;\r\n\r\n procedure Notification(AComponent: TComponent; Operation: TOperation); override;\r\n procedure WindowProc(var Msg: TMessage); virtual;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n procedure Assign(Source: TPersistent); override;\r\n { Owner of this component }\r\n property ParentForm: TForm read FParentForm;\r\n property EnableDock: Boolean read FEnableDock write SetEnableDock default True;\r\n property LeftDock: Boolean read FLeftDock write SetLeftDock default True;\r\n property TopDock: Boolean read FTopDock write SetTopDock default True;\r\n property RightDock: Boolean read FRightDock write SetRightDock default True;\r\n property BottomDock: Boolean read FBottomDock write SetBottomDock default True;\r\n property EachOtherDock: Boolean read FEachOtherDock write SetEachOtherDock default True;\r\n property CustomDock: Boolean read FCustomDock write FCustomDock default True; {NEW!}\r\n property DockStyle: TJvDockBasicStyle read FDockStyle write SetDockStyle;\r\n end;\r\n\r\n TJvDockCustomPanelEvent = procedure(Sender: TJvDockServer;\r\n var AParent: TWinControl; var Align: TAlign) of object; {NEW!}\r\n TJvDockCheckDockableEvent = procedure(DockClient: TJvDockClient; DockForm: TForm;\r\n DockServer: TJvDockServer; DockPanel: TJvDockPanel; var CanDock: Boolean) of object; {NEW!}\r\n TJvDockTabHostFormCreatedEvent = procedure(DockClient: TJvDockClient;\r\n TabHost: TJvDockTabHostForm) of object;\r\n\r\n TJvDockGetClientAlignSizeEvent = procedure(Align: TAlign; var Value: Integer) of object;\r\n TJvDockFinishSetDockPanelSizeEvent = procedure(DockPanel: TJvDockPanel) of object;\r\n\r\n {\r\n\r\n TJvDockServer is the Creator of 4 panels and 4 splitters that are placed on\r\n the form that contains the TJvDockServer. The type of the panels and splitters\r\n is determined by the DockStyle.\r\n\r\n o TJvDockServer maintains the panels and splitters. If the dock server is\r\n destroyed then the panels and splitters are destroyed.\r\n o If the DockStyle is changed then the panels+splitters are destroyed and\r\n recreated.\r\n o If DockStyle is set to nil then the panels+splitters are nil.\r\n }\r\n\r\n TJvDockPosition = (dpLeft, dpRight, dpTop, dpBottom, dpCustom); {dpCustom NEW!}\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvDockServer = class(TJvDockBaseControl)\r\n private\r\n FDockPanelClass: TJvDockPanelClass;\r\n FDockPanels: array [TJvDockPosition] of TJvDockPanel;\r\n FDockSplitterClass: TJvDockSplitterClass;\r\n FSplitters: array [TJvDockPosition] of TJvDockSplitter;\r\n FSplitterStyles: array [TJvDockPosition] of TJvDockSplitterStyle;\r\n FOnCustomPanel: TJvDockCustomPanelEvent; // Self, AParent, Align\r\n FOnGetClientAlignSize: TJvDockGetClientAlignSizeEvent;\r\n FOnFinishSetDockPanelSize: TJvDockFinishSetDockPanelSizeEvent;\r\n FAutoFocusDockedForm: Boolean;\r\n procedure CreateDockPanelAndSplitter;\r\n procedure DestroyDockPanelAndSplitter;\r\n procedure CreateSplitterStyle;\r\n procedure DestroySplitterStyle;\r\n procedure SetSplitterStyles;\r\n procedure DoGetClientAlignControl(Align: TAlign; var Value: Integer);\r\n function GetDockPanel(DockPosition: TJvDockPosition): TJvDockPanel;\r\n function GetDockPanelIndex(const Index: Integer): TJvDockPanel;\r\n function GetDockPanelWithAlign(Index: TAlign): TJvDockPanel;\r\n function GetDockSplitterWithAlign(Index: TAlign): TJvDockSplitter;\r\n function GetSplitter(DockPosition: TJvDockPosition): TJvDockSplitter;\r\n function GetSplitterIndex(const Index: Integer): TJvDockSplitter;\r\n function GetSplitterStyle(DockPosition: TJvDockPosition): TJvDockSplitterStyle;\r\n function GetSplitterStyleIndex(const Index: Integer): TJvDockSplitterStyle;\r\n procedure SetSplitterStyle(DockPosition: TJvDockPosition; ASplitterStyle: TJvDockSplitterStyle);\r\n procedure SetSplitterStyleIndex(const Index: Integer; ASplitterStyle: TJvDockSplitterStyle);\r\n protected\r\n procedure Notification(AComponent: TComponent; Operation: TOperation); override;\r\n procedure DoFinishSetDockPanelSize(DockPanel: TJvDockPanel);\r\n procedure DoFloatDockClients(DockPanel: TJvDockPanel);\r\n procedure SetBottomDock(const Value: Boolean); override;\r\n procedure SetEnableDock(const Value: Boolean); override;\r\n procedure SetLeftDock(const Value: Boolean); override;\r\n procedure SetRightDock(const Value: Boolean); override;\r\n procedure SetTopDock(const Value: Boolean); override;\r\n\r\n procedure AddDockStyle(ADockStyle: TJvDockBasicStyle); override;\r\n procedure RemoveDockStyle(ADockStyle: TJvDockBasicStyle); override;\r\n\r\n procedure WMActivate(var Msg: TWMActivate);\r\n procedure WindowProc(var Msg: TMessage); override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n function GetClientAlignControl(Align: TAlign): Integer;\r\n\r\n\tproperty DockPanel[DockPosition: TJvDockPosition]: TJvDockPanel read GetDockPanel;\r\n property Splitter[DockPosition: TJvDockPosition]: TJvDockSplitter read GetSplitter;\r\n property SplitterStyle[DockPosition: TJvDockPosition]: TJvDockSplitterStyle read GetSplitterStyle write\r\n SetSplitterStyle;\r\n\r\n property LeftDockPanel: TJvDockPanel index 0 read GetDockPanelIndex;\r\n property RightDockPanel: TJvDockPanel index 1 read GetDockPanelIndex;\r\n property TopDockPanel: TJvDockPanel index 2 read GetDockPanelIndex;\r\n property BottomDockPanel: TJvDockPanel index 3 read GetDockPanelIndex;\r\n property CustomDockPanel: TJvDockPanel index 4 read GetDockPanelIndex;\r\n\r\n property LeftSplitter: TJvDockSplitter index 0 read GetSplitterIndex;\r\n property RightSplitter: TJvDockSplitter index 1 read GetSplitterIndex;\r\n property TopSplitter: TJvDockSplitter index 2 read GetSplitterIndex;\r\n property BottomSplitter: TJvDockSplitter index 3 read GetSplitterIndex;\r\n\r\n property DockPanelWithAlign[Index: TAlign]: TJvDockPanel read GetDockPanelWithAlign;\r\n property DockSplitterWithAlign[Index: TAlign]: TJvDockSplitter read GetDockSplitterWithAlign;\r\n published\r\n property LeftSplitterStyle: TJvDockSplitterStyle index 0 read GetSplitterStyleIndex write SetSplitterStyleIndex;\r\n property RightSplitterStyle: TJvDockSplitterStyle index 1 read GetSplitterStyleIndex write SetSplitterStyleIndex;\r\n property TopSplitterStyle: TJvDockSplitterStyle index 2 read GetSplitterStyleIndex write SetSplitterStyleIndex;\r\n property BottomSplitterStyle: TJvDockSplitterStyle index 3 read GetSplitterStyleIndex write SetSplitterStyleIndex;\r\n property AutoFocusDockedForm: Boolean read FAutoFocusDockedForm write FAutoFocusDockedForm default True;\r\n property EnableDock;\r\n property LeftDock;\r\n property TopDock;\r\n property RightDock;\r\n property BottomDock;\r\n property DockStyle;\r\n property CustomDock;\r\n property OnGetClientAlignSize: TJvDockGetClientAlignSizeEvent read FOnGetClientAlignSize\r\n write FOnGetClientAlignSize;\r\n property OnFinishSetDockPanelSize: TJvDockFinishSetDockPanelSizeEvent read FOnFinishSetDockPanelSize\r\n write FOnFinishSetDockPanelSize;\r\n property OnCustomPanel: TJvDockCustomPanelEvent read FOnCustomPanel write FOnCustomPanel; {NEW!}\r\n end;\r\n\r\n TJvDockMouseStation = (msFloat, msConjoin, msTabPage);\r\n\r\n TJvDockNCButtonEvent = procedure(DockClient: TJvDockClient; Button: TMouseButton;\r\n X, Y: Smallint; HitTest: Longint; MouseStation: TJvDockMouseStation) of object;\r\n TJvDockNCButtonDownEvent = TJvDockNCButtonEvent;\r\n TJvDockNCButtonUpEvent = TJvDockNCButtonEvent;\r\n TJvDockNCButtonDblClkEvent = TJvDockNCButtonEvent;\r\n TJvDockNCMouseMoveEvent = procedure(DockClient: TJvDockClient;\r\n\tX, Y: Smallint; HitTest: Longint; MouseStation: TJvDockMouseStation) of object;\r\n TJvDockPaintDockEvent = procedure(Canvas: TCanvas;\r\n Control: TControl; const ARect: TRect) of object;\r\n TJvDockPaintDockGrabberEvent = TJvDockPaintDockEvent;\r\n TJvDockPaintDockSplitterEvent = TJvDockPaintDockEvent;\r\n TJvDockFormHintEvent = procedure(HTFlag: Integer; var HintStr: string; var CanShow: Boolean) of object;\r\n\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvDockClient = class(TJvDockBaseControl)\r\n private\r\n FConjoinPanelClass: TJvDockConjoinPanelClass;\r\n FTabDockClass: TJvDockTabClass;\r\n FParentVisible: Boolean;\r\n FNCPopupMenu: TPopupMenu;\r\n FDirectDrag: Boolean;\r\n FShowHint: Boolean;\r\n FCanFloat: Boolean;\r\n FDockLevel: Integer;\r\n FEnableCloseButton: Boolean;\r\n FOnNCButtonDown: TJvDockNCButtonDownEvent;\r\n FOnNCButtonUp: TJvDockNCButtonUpEvent;\r\n FOnNCMouseMove: TJvDockNCMouseMoveEvent;\r\n\tFOnNCButtonDblClk: TJvDockNCButtonDblClkEvent;\r\n FOnPaintDockGrabber: TJvDockPaintDockGrabberEvent;\r\n FOnPaintDockSplitter: TJvDockPaintDockSplitterEvent;\r\n FOnFormShowHint: TJvDockFormHintEvent;\r\n FOnFormShow: TNotifyEvent;\r\n FOnFormHide: TNotifyEvent;\r\n FOnCheckIsDockable: TJvDockCheckDockableEvent; {NEW!}\r\n FOnTabHostFormCreated: TJvDockTabHostFormCreatedEvent; {NEW!}\r\n FCurrentDockSite: TWinControl;\r\n FLastDockSite: TWinControl;\r\n FUnDockLeft: Integer;\r\n FUnDockTop: Integer;\r\n FVSPaneWidth: Integer;\r\n procedure SetParentVisible(const Value: Boolean);\r\n function GetLRDockWidth: Integer;\r\n function GetTBDockHeight: Integer;\r\n procedure SetLRDockWidth(const Value: Integer);\r\n procedure SetTBDockHeight(const Value: Integer);\r\n procedure SetNCPopupMenu(Value: TPopupMenu);\r\n procedure WMNCLButtonDown(var Msg: TWMNCHitMessage);\r\n procedure WMNCLButtonUp(var Msg: TWMNCHitMessage);\r\n procedure WMNCLButtonDblClk(var Msg: TWMNCHitMessage);\r\n procedure WMNCMButtonDown(var Msg: TWMNCHitMessage);\r\n procedure WMNCMButtonUp(var Msg: TWMNCHitMessage);\r\n procedure WMNCMButtonDblClk(var Msg: TWMNCHitMessage);\r\n procedure WMNCRButtonDown(var Msg: TWMNCHitMessage);\r\n procedure WMNCRButtonUp(var Msg: TWMNCHitMessage);\r\n\tprocedure WMNCRButtonDblClk(var Msg: TWMNCHitMessage);\r\n procedure WMNCMouseMove(var Msg: TWMNCHitMessage);\r\n procedure CMVisibleChanged(var Msg: TMessage);\r\n procedure SetCurrentDockSite(const Value: TWinControl);\r\n procedure SetLastDockSite(ALastDockSite: TWinControl);\r\n procedure SetVSPaneWidth(const Value: Integer);\r\n procedure SetUnDockLeft(const Value: Integer);\r\n procedure SetUnDockTop(const Value: Integer);\r\n function GetDockState: Integer;\r\n procedure SetCanFloat(const Value: Boolean);\r\n procedure SetDockLevel(const Value: Integer);\r\n procedure SetEnableCloseButton(const Value: Boolean);\r\n protected\r\n procedure DoMenuPopup(X, Y: Integer); virtual;\r\n procedure Deactivate; virtual;\r\n procedure Activate; virtual;\r\n procedure Notification(AComponent: TComponent; Operation: TOperation); override;\r\n procedure DoFloatDockClients(PanelAlign: TAlign);\r\n procedure DoFloatDockEachOther;\r\n procedure SetBottomDock(const Value: Boolean); override;\r\n procedure SetEachOtherDock(const Value: Boolean); override;\r\n procedure SetEnableDock(const Value: Boolean); override;\r\n procedure SetLeftDock(const Value: Boolean); override;\r\n procedure SetRightDock(const Value: Boolean); override;\r\n procedure SetTopDock(const Value: Boolean); override;\r\n procedure DoFormOnClose(Sender: TObject; var Action: TCloseAction); override;\r\n procedure AddDockStyle(ADockStyle: TJvDockBasicStyle); override;\r\n\tprocedure RemoveDockStyle(ADockStyle: TJvDockBasicStyle); override;\r\n procedure WMSize(var Msg: TWMSize);\r\n procedure WMActivate(var Msg: TWMActivate);\r\n procedure WindowProc(var Msg: TMessage); override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n procedure FormStartDock(var Source: TJvDockDragDockObject); virtual;\r\n procedure FormPositionDockRect(Source: TJvDockDragDockObject); virtual;\r\n procedure FormDockOver(Source: TJvDockDragDockObject; X, Y: Integer;\r\n State: TDragState; var Accept: Boolean); virtual;\r\n procedure FormDockDrop(Source: TJvDockDragDockObject; X, Y: Integer); virtual;\r\n procedure FormEndDock(Target: TObject; X, Y: Integer); virtual;\r\n function FormUnDock(NewTarget: TWinControl; Client: TControl): Boolean; virtual;\r\n procedure FormGetSiteInfo(Source: TJvDockDragDockObject;\r\n Client: TControl; var InfluenceRect: TRect; MousePos: TPoint;\r\n var CanDock: Boolean); virtual;\r\n procedure FormGetDockEdge(Source: TJvDockDragDockObject; MousePos: TPoint; var DropAlign: TAlign); virtual;\r\n procedure Assign(Source: TPersistent); override;\r\n procedure MakeShowEvent;\r\n procedure MakeHideEvent;\r\n function CreateConjoinPanelClass(ConjoinHost: TForm): TJvDockConjoinPanel;\r\n function CreateTabDockClass(TabHost: TForm): TJvDockTabPageControl;\r\n function CreateConjoinHostAndDockControl(Control1, Control2: TControl;\r\n DockType: TAlign): TJvDockConjoinHostForm; virtual;\r\n function CreateTabHostAndDockControl(Control1, Control2: TControl): TJvDockTabHostForm; virtual;\r\n\r\n\tfunction FindTabHostForm: TForm;\r\n\t// return nil if not found, otherwise, get currently docked parent tabhost form if there is one.\r\n\r\n procedure DoNCButtonDown(Msg: TWMNCHitMessage; Button: TMouseButton;\r\n MouseStation: TJvDockMouseStation); virtual;\r\n procedure DoNCButtonUp(Msg: TWMNCHitMessage; Button: TMouseButton;\r\n MouseStation: TJvDockMouseStation); virtual;\r\n procedure DoNCMouseMove(Msg: TWMNCHitMessage;\r\n MouseStation: TJvDockMouseStation); virtual;\r\n procedure DoNCButtonDblClk(Msg: TWMNCHitMessage; Button: TMouseButton;\r\n MouseStation: TJvDockMouseStation); virtual;\r\n\r\n procedure DoPaintDockGrabber(Canvas: TCanvas;\r\n Control: TControl; const ARect: TRect);\r\n procedure DoPaintDockSplitter(Canvas: TCanvas;\r\n Control: TControl; const ARect: TRect);\r\n procedure DoFormShowHint(HTFlag: Integer; var HintStr: string; var CanShow: Boolean);\r\n procedure ShowParentForm;\r\n procedure HideParentForm;\r\n procedure RestoreChild;\r\n property VSPaneWidth: Integer read FVSPaneWidth write SetVSPaneWidth;\r\n property ParentVisible: Boolean read FParentVisible write SetParentVisible;\r\n { (rb) not used? }\r\n property CurrentDockSite: TWinControl read FCurrentDockSite write SetCurrentDockSite;\r\n property LastDockSite: TWinControl read FLastDockSite write SetLastDockSite;\r\n property UnDockLeft: Integer read FUnDockLeft write SetUnDockLeft;\r\n property UnDockTop: Integer read FUnDockTop write SetUnDockTop;\r\n property DockState: Integer read GetDockState;\r\n published\r\n property LRDockWidth: Integer read GetLRDockWidth write SetLRDockWidth default 100;\r\n property TBDockHeight: Integer read GetTBDockHeight write SetTBDockHeight default 100;\r\n property NCPopupMenu: TPopupMenu read FNCPopupMenu write SetNCPopupMenu;\r\n property DirectDrag: Boolean read FDirectDrag write FDirectDrag;\r\n property ShowHint: Boolean read FShowHint write FShowHint default True;\r\n property CanFloat: Boolean read FCanFloat write SetCanFloat default True;\r\n { Not implemented; intention: only forms with the same DockLevel could be docked together }\r\n property DockLevel: Integer read FDockLevel write SetDockLevel default 0;\r\n property EnableCloseButton: Boolean read FEnableCloseButton write SetEnableCloseButton default True;\r\n property EnableDock;\r\n property LeftDock;\r\n property TopDock;\r\n property RightDock;\r\n property BottomDock;\r\n property EachOtherDock;\r\n property DockStyle;\r\n property CustomDock;\r\n property OnFormShow: TNotifyEvent read FOnFormShow write FOnFormShow;\r\n property OnFormHide: TNotifyEvent read FOnFormHide write FOnFormHide;\r\n property OnCheckIsDockable: TJvDockCheckDockableEvent read FOnCheckIsDockable write FOnCheckIsDockable; {NEW!}\r\n property OnTabHostFormCreated: TJvDockTabHostFormCreatedEvent read FOnTabHostFormCreated\r\n write FOnTabHostFormCreated; {NEW!}\r\n property OnNCButtonDown: TJvDockNCButtonDownEvent read FOnNCButtonDown write FOnNCButtonDown;\r\n property OnNCButtonUp: TJvDockNCButtonUpEvent read FOnNCButtonUp write FOnNCButtonUp;\r\n property OnNCMouseMove: TJvDockNCMouseMoveEvent read FOnNCMouseMove write FOnNCMouseMove;\r\n property OnNCButtonDblClk: TJvDockNCButtonDblClkEvent read FOnNCButtonDblClk write FOnNCButtonDblClk;\r\n property OnPaintDockGrabber: TJvDockPaintDockGrabberEvent read FOnPaintDockGrabber write FOnPaintDockGrabber;\r\n property OnPaintDockSplitter: TJvDockPaintDockSplitterEvent read FOnPaintDockSplitter write FOnPaintDockSplitter;\r\n property OnFormShowHint: TJvDockFormHintEvent read FOnFormShowHint write FOnFormShowHint;\r\n end;\r\n\r\n { Maintained by a TJvDockConjoinHostForm; That is (always) the owner, ie.\r\n that is assumed on multiple places in the code) }\r\n TJvDockConjoinPanel = class(TJvDockCustomPanel)\r\n private\r\n function GetDockClient: TJvDockClient;\r\n function GetParentForm: TJvDockConjoinHostForm;\r\n procedure CMUnDockClient(var Msg: TCMUnDockClient); message CM_UNDOCKCLIENT;\r\n protected\r\n function CreateDockManager: IDockManager; override;\r\n procedure ReloadDockedControl(const AControlName: string; var AControl: TControl); override;\r\n procedure CustomStartDock(var Source: TJvDockDragDockObject); override;\r\n procedure CustomGetSiteInfo(Source: TJvDockDragDockObject;\r\n Client: TControl; var InfluenceRect: TRect; MousePos: TPoint;\r\n var CanDock: Boolean); override;\r\n procedure CustomDockOver(Source: TJvDockDragDockObject; X, Y: Integer;\r\n State: TDragState; var Accept: Boolean); override;\r\n procedure CustomPositionDockRect(Source: TJvDockDragDockObject; X, Y: Integer); override;\r\n procedure CustomDockDrop(Source: TJvDockDragDockObject; X, Y: Integer); override;\r\n procedure CustomEndDock(Target: TObject; X, Y: Integer); override;\r\n function CustomUnDock(Source: TJvDockDragDockObject; NewTarget: TWinControl;\r\n Client: TControl): Boolean; override;\r\n procedure DoDockOver(Source: TDragDockObject; X, Y: Integer; State: TDragState;\r\n var Accept: Boolean); override;\r\n procedure GetSiteInfo(Client: TControl; var InfluenceRect: TRect;\r\n MousePos: TPoint; var CanDock: Boolean); override;\r\n function DoUnDock(NewTarget: TWinControl; Client: TControl): Boolean; override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n procedure DockDrop(Source: TDragDockObject; X, Y: Integer); override;\r\n { DockClient of the Owner }\r\n property DockClient: TJvDockClient read GetDockClient;\r\n { ParentForm is the Owner }\r\n property ParentForm: TJvDockConjoinHostForm read GetParentForm;\r\n end;\r\n\r\n TJvDockAdvConjoinPanel = class(TJvDockConjoinPanel)\r\n private\r\n procedure CMUnDockClient(var Msg: TCMUnDockClient); message CM_UNDOCKCLIENT;\r\n protected\r\n procedure CustomDockDrop(Source: TJvDockDragDockObject; X, Y: Integer); override;\r\n function CustomUnDock(Source: TJvDockDragDockObject; NewTarget: TWinControl;\r\n Client: TControl): Boolean; override;\r\n function DoUnDock(NewTarget: TWinControl; Client: TControl): Boolean; override;\r\n public\r\n procedure DockDrop(Source: TDragDockObject; X, Y: Integer); override;\r\n end;\r\n\r\n { Maintained by a TJvDockTabHostForm; That is (always) the owner, ie.\r\n that is assumed on multiple places in the code) }\r\n TJvDockTabPageControl = class(TJvDockPageControl)\r\n private\r\n FVersion: Integer;\r\n FStyleLink: TJvDockStyleLink;\r\n function GetParentForm: TJvDockTabHostForm;\r\n procedure DockStyleChanged(Sender: TObject);\r\n function GetDockStyle: TJvDockObservableStyle;\r\n function GetActiveDockForm: TCustomForm;\r\n function GetDockForm(Index: Integer): TCustomForm;\r\n protected\r\n procedure AdjustClientRect(var Rect: TRect); override;\r\n procedure ReloadDockedControl(const AControlName: string;\r\n var AControl: TControl); override;\r\n procedure CustomStartDock(var Source: TJvDockDragDockObject); override;\r\n procedure CustomGetSiteInfo(Source: TJvDockDragDockObject; Client: TControl;\r\n var InfluenceRect: TRect; MousePos: TPoint; var CanDock: Boolean); override;\r\n procedure CustomDockOver(Source: TJvDockDragDockObject; X, Y: Integer;\r\n State: TDragState; var Accept: Boolean); override;\r\n procedure CustomPositionDockRect(Source: TJvDockDragDockObject; X, Y: Integer); override;\r\n procedure CustomDockDrop(Source: TJvDockDragDockObject; X, Y: Integer); override;\r\n procedure CustomEndDock(Target: TObject; X, Y: Integer); override;\r\n function CustomUnDock(Source: TJvDockDragDockObject; NewTarget: TWinControl;\r\n Client: TControl): Boolean; override;\r\n procedure CustomGetDockEdge(Source: TJvDockDragDockObject; MousePos: TPoint;\r\n var DropAlign: TAlign); override;\r\n function DoUnDock(NewTarget: TWinControl; Client: TControl): Boolean; override;\r\n\r\n procedure SyncWithStyle; virtual;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n procedure AfterConstruction; override;\r\n procedure DockDrop(Source: TDragDockObject; X, Y: Integer); override;\r\n procedure LoadFromStream(Stream: TStream); virtual;\r\n procedure SaveToStream(Stream: TStream); virtual;\r\n\r\n property ActiveDockForm: TCustomForm read GetActiveDockForm;\r\n property DockForm[Index: Integer]: TCustomForm read GetDockForm;\r\n { ParentForm is the Owner }\r\n property ParentForm: TJvDockTabHostForm read GetParentForm;\r\n property TabPosition;\r\n property DockStyle: TJvDockObservableStyle read GetDockStyle;\r\n end;\r\n\r\n TJvDockAdvTabPageControl = class(TJvDockTabPageControl)\r\n private\r\n procedure CMUnDockClient(var Msg: TCMUnDockClient); message CM_UNDOCKCLIENT;\r\n protected\r\n procedure CustomDockDrop(Source: TJvDockDragDockObject; X, Y: Integer); override;\r\n function CustomUnDock(Source: TJvDockDragDockObject; NewTarget: TWinControl;\r\n Client: TControl): Boolean; override;\r\n function DoUnDock(NewTarget: TWinControl; Client: TControl): Boolean; override;\r\n public\r\n destructor Destroy; override;\r\n procedure DockDrop(Source: TDragDockObject; X, Y: Integer); override;\r\n end;\r\n\r\n { A TJvDockableForm is a base class for TJvDockConjoinHostForm\r\n and TJvDockTabHostForm which are the base classes for the two kinds of\r\n docked-views possible for handling multiple controls docked to the same\r\n dock site.\r\n This form is not meant to be visible to the user nor to contain any\r\n visible components, it is just part of the docking framework.\r\n This is the reason why it does not inherit from TJvForm, and it were\r\n inheriting from it, all sorts of weird bugs would show up (Mantis 5023)\r\n }\r\n TJvDockableForm = class(TForm) { DO NOT MAKE THIS TJvForm! }\r\n private\r\n FDockClient: TJvDockClient;\r\n FDockableControl: TWinControl;\r\n FUnDockControl: TControl;\r\n FFloatingChild: TControl;\r\n function GetDockableControl: TWinControl;\r\n procedure SetDockableControl(const Value: TWinControl);\r\n procedure SetUnDockControl(const Value: TControl);\r\n protected\r\n procedure DoClose(var Action: TCloseAction); override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n { Fixed DockClient owned by the component }\r\n property DockClient: TJvDockClient read FDockClient;\r\n { Either a TJvDockTabPageControl or a TJvDockConjoinPanel, assigned on\r\n construction of the dockable form }\r\n property DockableControl: TWinControl read GetDockableControl write SetDockableControl;\r\n { ?? Probably needs notification }\r\n property UnDockControl: TControl read FUnDockControl write SetUnDockControl;\r\n { ?? Probably needs notification }\r\n property FloatingChild: TControl read FFloatingChild;\r\n end;\r\n\r\n TJvDockConjoinHostForm = class(TJvDockableForm)\r\n private\r\n FPanel: TJvDockConjoinPanel;\r\n protected\r\n procedure DoClose(var Action: TCloseAction); override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n property DockClient;\r\n { Constructed in TJvDockClient.CreateConjoinPanelClass }\r\n property Panel: TJvDockConjoinPanel read FPanel write FPanel;\r\n end;\r\n\r\n TJvDockTabHostForm = class(TJvDockableForm)\r\n private\r\n FPageControl: TJvDockTabPageControl;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n procedure ShowDockedControl(AControl:TWinControl); virtual; // If aControl is docked in PageControl, change PageControl to that page. NEW! WPostma.\r\n procedure UpdateCaption(AControl:TWinControl); virtual; // update tab host's tabs and title bar when page caption changes.\r\n\r\n // backwards compatibility: Mantis 4100\r\n function GetActiveDockForm: TForm;\r\n property DockClient;\r\n { Constructed in TJvDockClient.CreateTabDockClass }\r\n property PageControl: TJvDockTabPageControl read FPageControl write FPageControl;\r\n end;\r\n\r\n TJvGlobalDockManager = class(TJvDockManager)\r\n private\r\n FDockServers: TList;\r\n FDockClients: TList;\r\n FDockableForms: TList;\r\n function GetDockClient(const Index: Integer): TJvDockClient;\r\n function GetDockClientCount: Integer;\r\n function GetDockServer(const Index: Integer): TJvDockServer;\r\n function GetDockServerCount: Integer;\r\n function GetDockableForm(const Index: Integer): TJvDockableForm;\r\n function GetDockableFormCount: Integer;\r\n public\r\n constructor Create; override;\r\n destructor Destroy; override;\r\n procedure RegisterDockServer(ADockServer: TJvDockServer);\r\n procedure RegisterDockClient(ADockClient: TJvDockClient);\r\n procedure RegisterDockableForm(ADockableForm: TJvDockableForm);\r\n procedure UnRegisterDockServer(ADockServer: TJvDockServer);\r\n procedure UnRegisterDockClient(ADockClient: TJvDockClient);\r\n procedure UnRegisterDockableForm(ADockableForm: TJvDockableForm);\r\n function FindDockServerForm(const AName: string): TControl;\r\n function FindDockClientForm(const AName: string): TControl;\r\n function FindDockControlForm(const AName: string): TControl;\r\n\r\n property DockServer[const Index: Integer]: TJvDockServer read GetDockServer;\r\n property DockClient[const Index: Integer]: TJvDockClient read GetDockClient;\r\n property DockableForm[const Index: Integer]: TJvDockableForm read GetDockableForm;\r\n property DockServerCount: Integer read GetDockServerCount;\r\n property DockClientCount: Integer read GetDockClientCount;\r\n property DockableFormCount: Integer read GetDockableFormCount;\r\n end;\r\n\r\nvar\r\n DefaultDockPanelClass: TJvDockPanelClass = TJvDockPanel;\r\n DefaultDockSplitterClass: TJvDockSplitterClass = TJvDockSplitter;\r\n DefaultConjoinPanelClass: TJvDockConjoinPanelClass = TJvDockConjoinPanel;\r\n DefaultTabDockClass: TJvDockTabClass = TJvDockTabPageControl;\r\n DefaultDockZoneClass: TJvDockZoneClass = TJvDockZone;\r\n DefaultDockTreeClass: TJvDockTreeClass = TJvDockTree;\r\n\r\nprocedure ShowDockForm(DockWindow: TWinControl);\r\nprocedure HideDockForm(DockWindow: TWinControl);\r\nprocedure MakeDockClientEvent(Host: TControl; Visible: Boolean);\r\nfunction GetFormVisible(DockWindow: TWinControl): Boolean;\r\nprocedure SetDockPageControlPopupMenu(Value: TPopupMenu);\r\nprocedure SetDockPageControlHotTrack(Value: Boolean);\r\nprocedure SetTabDockHostBorderStyle(Value: TFormBorderStyle);\r\nprocedure SetConjoinDockHostBorderStyle(Value: TFormBorderStyle);\r\n\r\n// Save Layout to JvAppStorage:\r\nprocedure SaveDockTreeToAppStorage(AppStorage: TJvCustomAppStorage; AppStoragePath: string = '');\r\n// Load Layout from JvAppStorage:\r\nprocedure LoadDockTreeFromAppStorage(AppStorage: TJvCustomAppStorage; AppStoragePath: string = '');\r\n\r\nprocedure SaveDockTreeToFile(FileName: string);\r\nprocedure LoadDockTreeFromFile(FileName: string);\r\nprocedure SaveDockTreeToReg(ARootKey: DWORD; RegPatch: string);\r\nprocedure LoadDockTreeFromReg(ARootKey: DWORD; RegPatch: string);\r\n\r\nfunction FindDockBaseControl(Client: TControl): TJvDockBaseControl;\r\nfunction FindDockClient(Client: TControl): TJvDockClient;\r\nfunction FindDockServer(Client: TControl): TJvDockServer;\r\n\r\nfunction IsDockable(Sender: TWinControl; Client: TControl;\r\n DropCtl: TControl = nil; DockAlign: TAlign = alNone): Boolean;\r\nfunction ComputeDockingRect(AControl: TControl;\r\n var DockRect: TRect; MousePos: TPoint): TAlign;\r\n\r\n{ Undocks AControl from Sender; Sender is used to calculate the rectangle in\r\n which AControl is displayed when it starts floating. }\r\nprocedure DoFloat(Sender, AControl: TControl);\r\nprocedure SetDockSite(Control: TWinControl; SiteValue: Boolean);\r\nprocedure DoFloatForm(DockForm: TControl);\r\nprocedure FreeAllDockableForm;\r\nprocedure DoFloatAllForm;\r\n\r\nfunction GetClientAlignControlArea(AControl: TWinControl; Align: TAlign; Exclude: TControl = nil): Integer;\r\nprocedure ResetDockClient(Control: TControl; NewTarget: TControl); overload;\r\nprocedure ResetDockClient(DockClient: TJvDockClient; NewTarget: TControl); overload;\r\n\r\n\r\nfunction ManualTabDock(DockSite: TWinControl; Form1, Form2: TForm): TJvDockTabHostForm;\r\n\r\nfunction _ManualTabDock(DockSite: TWinControl; Form1, Form2: TForm;oldTechnique:Boolean=false): TJvDockTabHostForm; {experimental}\r\n\r\n\r\n{ Must create the initial tab dock with two pages, using ManualTabDock,\r\n then you can add more pages with this:}\r\nprocedure ManualTabDockAddPage(TabHost: TJvDockTabHostForm; AForm: TForm);\r\nfunction ManualConjoinDock(DockSite: TWinControl; Form1, Form2: TForm): TJvDockConjoinHostForm;\r\n\r\nfunction DockStateStr(DockState: Integer): string; {return string for a dock state}\r\n\r\nprocedure BeginDockLoading;\r\nprocedure EndDockLoading;\r\nfunction JvGlobalDockIsLoading: Boolean;\r\n\r\n{$IFNDEF COMPILER9_UP}\r\nprocedure InvalidateDockHostSiteOfControl(Control: TControl; FocusLost: Boolean);\r\n{$ENDIF !COMPILER9_UP}\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvDockControlForm.pas $';\r\n Revision: '$Revision: 13415 $';\r\n Date: '$Date: 2012-09-10 11:51:54 +0200 (lun. 10 sept. 2012) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n Types, SysUtils,\r\n JvAppRegistryStorage, JvAppIniStorage, JvTypes,\r\n JvDockSupportProc, JvDockGlobals, JvDockInfo, JvDockVSNetStyle, JvJVCLUtils;\r\n\r\n{$R JvDockableForm.dfm}\r\n{$R JvDockConjoinHost.dfm}\r\n{$R JvDockTabHost.dfm}\r\n\r\ntype\r\n TControlAccessProtected = class(TControl);\r\n TWinControlAccessProtected = class(TWinControl);\r\n\r\nvar\r\n DockPageControlPopupMenu: TPopupMenu = nil;\r\n DockPageControlHotTrack: Boolean = False;\r\n TabDockHostBorderStyle: TFormBorderStyle = bsSizeToolWin;\r\n ConjoinDockHostBorderStyle: TFormBorderStyle = bsSizeToolWin;\r\n\r\n GDockLoadCount: Integer = 0;\r\n GShowingChanged: TList;\r\n\r\n//=== Local procedures =======================================================\r\n\r\nfunction IsWinXP_UP: Boolean;\r\nbegin\r\n Result := (Win32Platform = VER_PLATFORM_WIN32_NT) and CheckWin32Version(5, 1);\r\nend;\r\n\r\nprocedure ApplyShowingChanged;\r\nvar\r\n I: Integer;\r\nbegin\r\n if IsWinXP_UP and (GShowingChanged <> nil) then\r\n for I := 0 to Screen.FormCount - 1 do\r\n if GShowingChanged.IndexOf(Screen.Forms[I]) >= 0 then\r\n Screen.Forms[i].Perform(CM_SHOWINGCHANGED, 0, 0);\r\n FreeAndNil(GShowingChanged);\r\nend;\r\n\r\nprocedure UpdateCaption(Source: TWinControl; Exclude: TControl);\r\nvar\r\n I: Integer;\r\n Host: TJvDockableForm;\r\nbegin\r\n if (Source <> nil) and (Source.Parent is TJvDockableForm) then\r\n begin\r\n Host := TJvDockableForm(Source.Parent);\r\n Host.Caption := '';\r\n\r\n for I := 0 to Source.DockClientCount - 1 do\r\n if Source.DockClients[I].Visible and (Source.DockClients[I] <> Exclude) then\r\n Host.Caption := Host.Caption + TCustomForm(Source.DockClients[I]).Caption + RsDockStringSplitter;\r\n\r\n if Host.HostDockSite is TJvDockTabPageControl then\r\n with TJvDockTabPageControl(Host.HostDockSite) do\r\n if (ActivePage <> nil) and (ActivePage.Controls[0] = Source) then\r\n ActivePage.Caption := Host.Caption;\r\n UpdateCaption(Host.HostDockSite, nil);\r\n end;\r\nend;\r\n\r\n//=== Global procedures ======================================================\r\n\r\nprocedure BeginDockLoading;\r\nbegin\r\n if GDockLoadCount = 0 then\r\n begin\r\n JvDockLockWindow(nil);\r\n end;\r\n Inc(GDockLoadCount);\r\nend;\r\n\r\nprocedure EndDockLoading;\r\nbegin\r\n Dec(GDockLoadCount);\r\n if GDockLoadCount = 0 then\r\n begin\r\n ApplyShowingChanged;\r\n JvDockUnLockWindow;\r\n end;\r\nend;\r\n\r\nfunction JvGlobalDockIsLoading: Boolean;\r\nbegin\r\n Result := GDockLoadCount > 0;\r\nend;\r\n\r\nfunction ComputeDockingRect(AControl: TControl; var DockRect: TRect; MousePos: TPoint): TAlign;\r\nvar\r\n DockTopRect, DockLeftRect, DockBottomRect, DockRightRect, DockCenterRect: TRect;\r\nbegin\r\n Result := alNone;\r\n\r\n if AControl = nil then\r\n Exit;\r\n with AControl do\r\n begin\r\n DockLeftRect.TopLeft := Point(0, 0);\r\n DockLeftRect.BottomRight := Point(ClientWidth div 5, ClientHeight);\r\n\r\n DockTopRect.TopLeft := Point(ClientWidth div 5, 0);\r\n DockTopRect.BottomRight := Point(ClientWidth div 5 * 4, ClientHeight div 5);\r\n\r\n DockRightRect.TopLeft := Point(ClientWidth div 5 * 4, 0);\r\n DockRightRect.BottomRight := Point(ClientWidth, ClientHeight);\r\n\r\n DockBottomRect.TopLeft := Point(ClientWidth div 5, ClientHeight div 5 * 4);\r\n DockBottomRect.BottomRight := Point(ClientWidth div 5 * 4, ClientHeight);\r\n\r\n DockCenterRect.TopLeft := Point(ClientWidth div 5, ClientHeight div 5);\r\n DockCenterRect.BottomRight := Point(ClientWidth div 5 * 4, ClientHeight div 5 * 4);\r\n\r\n if PtInRect(DockLeftRect, MousePos) then\r\n begin\r\n Result := alLeft;\r\n DockRect := DockLeftRect;\r\n DockRect.Right := ClientWidth div 2;\r\n end\r\n else\r\n if PtInRect(DockTopRect, MousePos) then\r\n begin\r\n Result := alTop;\r\n DockRect := DockTopRect;\r\n DockRect.Left := 0;\r\n DockRect.Right := ClientWidth;\r\n DockRect.Bottom := ClientHeight div 2;\r\n end\r\n else\r\n if PtInRect(DockRightRect, MousePos) then\r\n begin\r\n Result := alRight;\r\n DockRect := DockRightRect;\r\n DockRect.Left := ClientWidth div 2;\r\n end\r\n else\r\n if PtInRect(DockBottomRect, MousePos) then\r\n begin\r\n Result := alBottom;\r\n DockRect := DockBottomRect;\r\n DockRect.Left := 0;\r\n DockRect.Right := ClientWidth;\r\n DockRect.Top := ClientHeight div 2;\r\n end\r\n else\r\n if PtInRect(DockCenterRect, MousePos) then\r\n begin\r\n Result := alClient;\r\n DockRect := DockCenterRect;\r\n end;\r\n if Result = alNone then\r\n Exit;\r\n\r\n DockRect.TopLeft := ClientToScreen(DockRect.TopLeft);\r\n DockRect.BottomRight := ClientToScreen(DockRect.BottomRight);\r\n end;\r\nend;\r\n\r\nfunction DockStateStr(DockState: Integer): string;\r\nbegin\r\n // (rom) XML strings do not localize\r\n case DockState of\r\n JvDockState_Unknown:\r\n Result := 'Unknown';\r\n JvDockState_Docking:\r\n Result := 'Docking';\r\n JvDockState_Floating:\r\n Result := 'Floating';\r\n else\r\n Result := IntToStr(DockState);\r\n end;\r\nend;\r\n\r\nprocedure DoFloat(Sender, AControl: TControl);\r\nvar\r\n ARect: TRect;\r\n CH, BW: Integer;\r\nbegin\r\n BW := JvDockGetSysBorderWidth;\r\n CH := JvDockGetSysCaptionHeight;\r\n\r\n ARect.TopLeft := Sender.ClientToScreen(Point(-(BW + 3), -(CH + BW + 1)));\r\n ARect.BottomRight := Sender.ClientToScreen(\r\n Point(Sender.UndockWidth - (BW + 3), Sender.UndockHeight - (BW + CH + 1)));\r\n AControl.ManualFloat(ARect);\r\n if (AControl.Left <> ARect.Left) or (AControl.Top <> ARect.Top) then\r\n begin\r\n AControl.Left := ARect.Left;\r\n AControl.Top := ARect.Top;\r\n end;\r\nend;\r\n\r\nprocedure DoFloatAllForm;\r\nvar\r\n I: Integer;\r\n TempList: TList;\r\nbegin\r\n TempList := TList.Create;\r\n try\r\n for I := 0 to Screen.CustomFormCount - 1 do\r\n if not (Screen.CustomForms[I] is TJvDockableForm) and\r\n (Assigned(FinddockClient(Screen.CustomForms[I])) or\r\n Assigned(FinddockServer(Screen.CustomForms[I]))) then\r\n TempList.Add(Screen.CustomForms[I]);\r\n\r\n for I := 0 to TempList.Count - 1 do\r\n DoFloatForm(TempList[I]);\r\n finally\r\n TempList.Free;\r\n end;\r\n FreeAllDockableForm;\r\nend;\r\n\r\nprocedure DoFloatForm(DockForm: TControl);\r\nvar\r\n I: TAlign;\r\n J: Integer;\r\n ADockServer: TJvDockServer;\r\n // ARect: TRect;\r\n Channel: TJvDockVSChannel;\r\n allow:Boolean;\r\n dockClient:TJvDockClient;\r\nbegin\r\n if not (csDestroying in DockForm.ComponentState) then\r\n if DockForm is TForm then begin\r\n\tallow := true;\r\n\tif Assigned(TForm(DockForm).OnUnDock) then\r\n\t TForm(DockForm).OnUnDock(DockForm,DockForm,\r\n\t\tTWinControl(nil),allow);\r\n\tif allow then begin\r\n\t dockClient := FindDockClient(DockForm);\r\n\t if Assigned(dockclient) and (not dockClient.CanFloat) then begin\r\n\t\texit;\r\n\t end;\r\n\tend;\r\n\tif not allow then begin\r\n\t exit;\r\n\tend;\r\n end;\r\n\r\n\r\n\r\n if DockForm is TJvDockableForm then\r\n begin\r\n with TJvDockableForm(DockForm).DockableControl do\r\n begin\r\n for J := DockClientCount - 1 downto 0 do\r\n DoFloatForm(DockClients[J]);\r\n\r\n DockForm.ManualDock(nil);\r\n end;\r\n end\r\n else\r\n begin\r\n ADockServer := FindDockServer(DockForm);\r\n if ADockServer <> nil then\r\n begin\r\n // (rom) better use a Count or introduce one\r\n // (p3) this is due to the fact that DockPanel returns a dockpanel based on the indices 0 to 3\r\n // DockPanelWithAlign uses the TAlign enumeration, however\r\n for I := alTop to alRight do\r\n if Assigned(ADockServer.DockPanelWithAlign[I]) then\r\n begin\r\n for J := ADockServer.DockPanelWithAlign[I].DockClientCount - 1 downto 0 do\r\n DoFloatForm(ADockServer.DockPanelWithAlign[I].DockClients[J]);\r\n if ADockServer.DockPanelWithAlign[I] is TJvDockVSNETPanel then\r\n with TJvDockVSNETPanel(ADockServer.DockPanelWithAlign[I]).VSChannel do\r\n begin\r\n RemoveAllBlock;\r\n HidePopupPanel(ActiveDockForm);\r\n end;\r\n end;\r\n end\r\n else\r\n begin\r\n if DockForm.HostDockSite <> nil then\r\n begin\r\n if (DockForm.HostDockSite.Parent is TJvDockableForm) and\r\n (DockForm.HostDockSite.DockClientCount <= 2) then\r\n PostMessage(DockForm.HostDockSite.Parent.Handle, WM_CLOSE, 0, 0);\r\n end;\r\n // else\r\n // ARect := DockForm.BoundsRect;\r\n\r\n Channel := RetrieveChannel(DockForm.HostDockSite);\r\n if Assigned(Channel) then\r\n begin\r\n Channel.RemoveDockControl(TWinControl(DockForm));\r\n DockForm.Dock(nil, Bounds(DockForm.Left, DockForm.Top, DockForm.UndockWidth, DockForm.UndockHeight));\r\n end\r\n else\r\n DockForm.ManualDock(nil);\r\n end;\r\n end;\r\nend;\r\n\r\nfunction FindDockBaseControl(Client: TControl): TJvDockBaseControl;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := nil;\r\n if Client <> nil then\r\n for I := 0 to Client.ComponentCount - 1 do\r\n if Client.Components[I] is TJvDockBaseControl then\r\n begin\r\n Result := TJvDockBaseControl(Client.Components[I]);\r\n Break;\r\n end;\r\nend;\r\n\r\nfunction FindDockClient(Client: TControl): TJvDockClient;\r\nvar\r\n ADockControl: TJvDockBaseControl;\r\nbegin\r\n ADockControl := FindDockBaseControl(Client);\r\n if ADockControl is TJvDockClient then\r\n Result := TJvDockClient(ADockControl)\r\n else\r\n Result := nil;\r\nend;\r\n\r\nfunction FindDockServer(Client: TControl): TJvDockServer;\r\nvar\r\n ADockControl: TJvDockBaseControl;\r\nbegin\r\n ADockControl := FindDockBaseControl(Client);\r\n if ADockControl is TJvDockServer then\r\n Result := TJvDockServer(ADockControl)\r\n else\r\n Result := nil;\r\nend;\r\n\r\nprocedure FreeAllDockableForm;\r\nvar\r\n I: Integer;\r\nbegin\r\n Assert(JvGlobalDockManager <> nil);\r\n for I := JvGlobalDockManager.DockableFormCount - 1 downto 0 do\r\n if JvGlobalDockManager.DockableForm[I].DockableControl.DockClientCount = 0 then\r\n JvGlobalDockManager.DockableForm[I].Free;\r\nend;\r\n\r\nfunction GetClientAlignControlArea(AControl: TWinControl; Align: TAlign; Exclude: TControl): Integer;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := 0;\r\n for I := 0 to AControl.ControlCount - 1 do\r\n if (AControl.Controls[I].Align = Align) and AControl.Controls[I].Visible and\r\n (AControl.Controls[I] <> Exclude) and\r\n not ((AControl.Controls[I] is TJvDockSplitter) or (AControl.Controls[I] is TJvDockPanel)) then\r\n if Align in [alLeft, alRight] then\r\n Inc(Result, AControl.Controls[I].Width)\r\n else\r\n Inc(Result, AControl.Controls[I].Height);\r\nend;\r\n\r\nfunction GetFormVisible(DockWindow: TWinControl): Boolean;\r\nvar\r\n ADockClient: TJvDockClient;\r\nbegin\r\n Result := True;\r\n ADockClient := FindDockClient(DockWindow);\r\n if ADockClient <> nil then\r\n Result := ADockClient.DockStyle.GetDockFormVisible(ADockClient);\r\nend;\r\n\r\nprocedure HideDockForm(DockWindow: TWinControl);\r\nvar\r\n ADockClient: TJvDockClient;\r\nbegin\r\n // delegate to style\r\n ADockClient := FindDockClient(DockWindow);\r\n if Assigned(ADockClient) and Assigned(ADockClient.DockStyle) then\r\n ADockClient.DockStyle.DoHideDockForm(DockWindow);\r\nend;\r\n\r\nprocedure TJvDockBasicStyle.DoHideDockForm(DockWindow: TWinControl);\r\n\r\n procedure HideDockChild(DockWindow: TWinControl);\r\n var\r\n I: Integer;\r\n DockClient: TJvDockClient;\r\n begin\r\n if DockWindow = nil then\r\n Exit;\r\n if (DockWindow is TJvDockableForm) and (DockWindow.Visible) then\r\n with TJvDockableForm(DockWindow).DockableControl do\r\n for I := 0 to DockClientCount - 1 do\r\n HideDockChild(TWinControl(DockClients[I]));\r\n DockClient := FindDockClient(DockWindow);\r\n if (DockWindow is TForm) and (TForm(DockWindow).FormStyle <> fsMDIChild) and\r\n (DockClient.DockStyle <> nil) then\r\n DockClient.DockStyle.HideDockForm(DockClient);\r\n end;\r\n\r\n procedure HideDockParent(DockWindow: TWinControl);\r\n var\r\n Host: TWinControl;\r\n DockClient: TJvDockClient;\r\n begin\r\n if (DockWindow <> nil) and (DockWindow.HostDockSite <> nil) then\r\n begin\r\n Host := DockWindow.HostDockSite;\r\n if Host.VisibleDockClientCount = 0 then\r\n if Host is TJvDockPanel then\r\n TJvDockPanel(Host).ShowDockPanel(False, nil)\r\n else\r\n begin\r\n if Host.Parent <> nil then\r\n begin\r\n DockClient := FindDockClient(Host.Parent);\r\n if (DockClient <> nil) and (DockClient.DockStyle <> nil) then\r\n DockClient.DockStyle.HideDockForm(DockClient);\r\n HideDockParent(Host.Parent);\r\n end;\r\n end;\r\n end;\r\n end;\r\n\r\nbegin\r\n HideDockChild(DockWindow);\r\n HideDockParent(DockWindow);\r\n if (DockWindow.HostDockSite is TJvDockCustomControl) then\r\n TJvDockCustomControl(DockWindow.HostDockSite).UpdateCaption(DockWindow);\r\nend;\r\n\r\n{$IFNDEF COMPILER9_UP}\r\nprocedure InvalidateDockHostSiteOfControl(Control: TControl; FocusLost: Boolean);\r\nvar\r\n ChildDockSite: TControl;\r\n ParentWalk: TWinControl;\r\nbegin\r\n { Invalidate the first dock site we come across; its ui may\r\n need updating to reflect which control has focus. }\r\n if Control = nil then\r\n Exit;\r\n ChildDockSite := Control;\r\n ParentWalk := Control.Parent;\r\n while (ChildDockSite.HostDockSite = nil) and (ParentWalk <> nil) do\r\n begin\r\n ChildDockSite := ParentWalk;\r\n ParentWalk := ParentWalk.Parent;\r\n end;\r\n if ChildDockSite <> nil then\r\n TWinControlAccessProtected(ChildDockSite).SendDockNotification(CM_INVALIDATEDOCKHOST,\r\n WPARAM(Control), LPARAM(FocusLost));\r\nend;\r\n{$ENDIF !COMPILER9_UP}\r\n\r\nfunction IsDockable(Sender: TWinControl; Client: TControl; DropCtl: TControl = nil;\r\n DockAlign: TAlign = alNone): Boolean;\r\nvar\r\n I: Integer;\r\n ADockClient: TJvDockClient;\r\n SenderDockStyle, ClientDockStyle: TJvDockBasicStyle;\r\n SenderStyleName, ClientStyleName: string;\r\n SenderDocPanel: TJvDockPanel;\r\n //s:String;\r\n // (rom) disabled unused\r\n //label\r\n // JudgeRelation;\r\nbegin\r\n ADockClient := FindDockClient(Client);\r\n Result := False;\r\n if (ADockClient <> nil) and (ADockClient.EnableDock) then\r\n begin\r\n if Sender is TJvDockPanel then\r\n begin\r\n SenderDocPanel := TJvDockPanel(Sender);\r\n with SenderDocPanel do\r\n begin\r\n {$IFDEF JVDOCK_DEBUG}\r\n if CustomFlag and (not ADockClient.CustomDock) then\r\n begin\r\n OutputDebugString('IsDockable() - Debugging Dock-to-custom-panel problem.');\r\n ADockClient.CustomDock := True; // BUG WORKAROUND. WPostma.\r\n end;\r\n {$ENDIF JVDOCK_DEBUG}\r\n Result := DockServer.EnableDock and\r\n (((Align = alLeft) and DockServer.LeftDock and (ADockClient.LeftDock)) or\r\n ((Align = alTop) and DockServer.TopDock and (ADockClient.TopDock)) or\r\n ((Align = alRight) and DockServer.RightDock and (ADockClient.RightDock)) or\r\n ((Align = alBottom) and DockServer.BottomDock and (ADockClient.BottomDock)) or\r\n ((CustomFlag) and Assigned(DockServer.CustomDockPanel) and (ADockClient.CustomDock))\r\n );\r\n\r\n //{$IFDEF JVDOCK_DEBUG}\r\n // XXXXXX very noisy during drag operations:\r\n //if Result then begin\r\n // if Assigned(DropCtl) then\r\n // s := DropCtl.Name\r\n // else\r\n // s := 'nil';\r\n // OutputDebugString(PChar( 'JvDockControlForm.pas IsDockable: '+Sender.Name+ ': Dockable. DropCtl='+s ));\r\n //end;\r\n //{$ENDIF JVDOCK_DEBUG}\r\n SenderDockStyle := DockServer.DockStyle;\r\n end;\r\n end\r\n else\r\n begin\r\n if (Sender <> nil) and (Sender.Parent is TJvDockableForm) then\r\n with TJvDockableForm(Sender.Parent).DockableControl do\r\n for I := 0 to DockClientCount - 1 do\r\n if DockClients[I] = Client then\r\n Exit;\r\n Result := ADockClient.EachOtherDock;\r\n if Sender <> nil then\r\n ADockClient := FindDockClient(Sender.Parent);\r\n if ADockClient <> nil then\r\n Result := Result and ADockClient.EachOtherDock;\r\n\r\n if ADockClient <> nil then\r\n SenderDockStyle := ADockClient.DockStyle\r\n else\r\n Exit;\r\n end;\r\n\r\n ADockClient := FindDockClient(Client);\r\n if ADockClient <> nil then\r\n ClientDockStyle := ADockClient.DockStyle\r\n else\r\n Exit;\r\n\r\n if SenderDockStyle = nil then\r\n SenderStyleName := ''\r\n else\r\n SenderStyleName := SenderDockStyle.ClassName;\r\n\r\n if ClientDockStyle = nil then\r\n ClientStyleName := ''\r\n else\r\n ClientStyleName := ClientDockStyle.ClassName;\r\n\r\n Result := Result and (SenderStyleName = ClientStyleName);\r\n\r\n //JudgeRelation:\r\n end;\r\nend;\r\n\r\nprocedure LoadDockTreeFromAppStorage(AppStorage: TJvCustomAppStorage; AppStoragePath: string = '');\r\nvar\r\n JvDockInfoTree: TJvDockInfoTree;\r\nbegin\r\n AppStorage.BeginUpdate;\r\n try\r\n HideAllPopupPanel(nil); {This is in JvDockVSNetStyle.pas }\r\n\r\n JvDockInfoTree := TJvDockInfoTree.Create(TJvDockInfoZone);\r\n try\r\n BeginDockLoading;\r\n try\r\n JvDockInfoTree.AppStorage := AppStorage;\r\n JvDockInfoTree.AppStoragePath := AppStoragePath;\r\n JvDockInfoTree.ReadInfoFromAppStorage;\r\n finally\r\n EndDockLoading;\r\n end;\r\n finally\r\n JvDockInfoTree.Free;\r\n end;\r\n finally\r\n AppStorage.EndUpdate;\r\n end;\r\nend;\r\n\r\nprocedure LoadDockTreeFromFile(FileName: string);\r\nvar\r\n JvAppStorage: TJvAppIniFileStorage;\r\nbegin\r\n JvAppStorage := TJvAppIniFileStorage.Create(nil);\r\n try\r\n JvAppStorage.Location := flCustom;\r\n JvAppStorage.FileName := FileName;\r\n JvAppStorage.Reload;\r\n LoadDockTreeFromAppStorage(JvAppStorage);\r\n finally\r\n JvAppStorage.Free;\r\n end;\r\nend;\r\n\r\nprocedure LoadDockTreeFromReg(ARootKey: DWORD; RegPatch: string);\r\nvar\r\n JvAppStorage: TJvAppRegistryStorage;\r\nbegin\r\n JvAppStorage := TJvAppRegistryStorage.Create(nil);\r\n try\r\n // (p3) this seems dangerous but it's the same method as used by TJvAppRegistryStorage\r\n JvAppStorage.RegRoot := TJvRegKey(HKEY_CLASSES_ROOT + ARootKey);\r\n JvAppStorage.Path := RegPatch;\r\n LoadDockTreeFromAppStorage(JvAppStorage);\r\n finally\r\n JvAppStorage.Free;\r\n end;\r\nend;\r\n\r\nprocedure MakeDockClientEvent(Host: TControl; Visible: Boolean);\r\nvar\r\n I: Integer;\r\n DC: TJvDockClient;\r\nbegin\r\n DC := FindDockClient(Host);\r\n if DC <> nil then\r\n begin\r\n if Visible then\r\n DC.MakeShowEvent\r\n else\r\n DC.MakeHideEvent;\r\n if (Host is TJvDockableForm) and Host.Visible then\r\n with TJvDockableForm(Host).DockableControl do\r\n for I := 0 to DockClientCount - 1 do\r\n MakeDockClientEvent(DockClients[I], Visible);\r\n end;\r\nend;\r\n\r\n{ Quick way to do conjoined docking programmatically - Added by Warren }\r\n\r\nfunction ManualConjoinDock(DockSite: TWinControl; Form1, Form2: TForm): TJvDockConjoinHostForm;\r\nvar\r\n ConjoinHost: TJvDockConjoinHostForm;\r\n DockClient1, DockCLient2: TJvDockClient;\r\nbegin\r\n Form1.Show;\r\n Form2.Show;\r\n DockClient1 := FindDockClient(Form1);\r\n Assert(Assigned(DockClient1));\r\n DockClient2 := FindDockClient(Form2);\r\n Assert(Assigned(DockClient2));\r\n ConjoinHost := DockClient1.CreateConjoinHostAndDockControl(DockClient1.ParentForm, Form2, alTop);\r\n ShowDockForm(Form2);\r\n ConjoinHost.ManualDock(DockSite);\r\n Result := ConjoinHost;\r\nend;\r\n\r\ntype\r\n TWinControlAccess = class(TWinControl);\r\n\r\n\r\n\r\n{ Contributed by Kiriakos. Improved version 2011-12-27 }\r\nfunction ManualTabDock(DockSite: TWinControl; Form1, Form2: TForm): TJvDockTabHostForm;\r\nvar\r\n TabHost: TJvDockTabHostForm;\r\n DockClient1, DockCLient2: TJvDockClient;\r\n ScreenPos: TRect;\r\nbegin\r\n DockClient1 := FindDockClient(Form1);\r\n Form1.Hide;\r\n\r\n Assert(Assigned(DockClient1));\r\n\r\n if DockClient1.DockState = JvDockState_Docking then\r\n begin\r\n ScreenPos := Application.MainForm.ClientRect; // Just making it float temporarily.\r\n Form1.ManualFloat(ScreenPos);\r\n end;\r\n\r\n DockClient2 := FindDockClient(Form2);\r\n Assert(Assigned(DockClient2));\r\n Form2.Hide;\r\n\r\n if DockClient2.DockState = JvDockState_Docking then\r\n begin\r\n ScreenPos := Application.MainForm.ClientRect; // Just making it float temporarily.\r\n Form2.ManualFloat(ScreenPos);\r\n end;\r\n\r\n TabHost := DockClient1.CreateTabHostAndDockControl(Form1, Form2);\r\n\r\n TabHost.ManualDock(DockSite,nil,alClient);\r\n\r\n ShowDockForm(Form1);\r\n ShowDockForm(Form2);\r\n Result := TabHost;\r\nend;\r\n\r\n\r\n{_ManualTabDock:experimental}\r\nfunction _ManualTabDock(DockSite: TWinControl; Form1, Form2: TForm;oldTechnique:Boolean): TJvDockTabHostForm;\r\nvar\r\n DockClient: TJvDockClient;\r\n HostForm: TForm;\r\n dockPanel:TJvDockPanel;\r\nbegin\r\n Assert(DockSite <> nil);\r\n\r\n if not (DockSite is TJvDockPanel) then begin\r\n raise EInvalidOperation.Create('ManualTabDock:DockSite must be TJvDockPanel');\r\n end;\r\n dockPanel := TJvDockPanel(DockSite);\r\n\r\n\r\n { This is an initial sanity check, but the actual DockClient is required later,\r\n so we can find the tab host form that contains it. }\r\n DockClient := FindDockClient(Form1);\r\n if DockClient = nil then\r\n raise EInvalidOperation.Create('ManualTabDock:DockClient not found. Form you are trying to dock must have a dock style');\r\n\r\n { This should create the tab host form, if the docking style supports tabbed docking,\r\n as all 'advanced' docking styles provided in the JVCL do provide.\r\n\r\n This is the same call used when you drag something with your mouse, so it\r\n is much more reliable, and consistent, and updates the DOckManager state\r\n\twhich prevents all manner of weird problems. }\r\n\r\n\tif oldTechnique then begin\r\n\t HostForm := dockPanel.FindTabHostForm as TForm;\r\n\t if Assigned(HostForm) then begin\r\n\t\tManualTabDockAddPage( TJvDockTabHostForm(HostForm), Form1 );\r\n\t\tManualTabDockAddPage( TJvDockTabHostForm(HostForm), Form2 );\r\n\t\tresult := TJvDockTabHostForm(HostForm);\r\n\t\texit;\r\n\t end;\r\n\t // This is the original way I had it in 2006: It had bugs.\r\n\t HostForm := DockClient.CreateTabHostAndDockControl(FOrm1,Form2);\r\n\t FOrm1.Show;\r\n\t FOrm2.Show;\r\n\r\n\t HostForm.ManualDock(DockSite,nil,alClient);\r\n\t HostForm.Show;\r\n\r\n end else begin\r\n\t // This was the fix in 2008, which broke somehow, later:\r\n\t TWinControlAccess(DockSite).DockManager.InsertControl(Form2, alClient, Form1);\r\n end;\r\n\r\n\r\n\r\n\r\n if not Assigned(Form1.Parent) then begin\r\n\t OutputDebugString('no parent on form 1');\r\n end;\r\n if not Assigned(Form2.Parent) then begin\r\n OutputDebugString('no parent on form 2');\r\n end;\r\n\r\n\r\n { Now find and return the the new tab host object created depp within the bowels\r\n of the Docking Style code. If anything fails, return EInvalidOperation because its\r\n likely that whoever called ManualTabDock sent us objects that can not be properly\r\n docked, or is using a docking style that does not support tab docking. }\r\n\r\n HostForm := DockClient.FindTabHostForm;\r\n if HostForm = nil then\r\n raise EInvalidOperation.Create('ManualTabDock:TabHost not created. Your Docking Style may not support tabbed docking.');\r\n\r\n\tResult := HostForm as TJvDockTabHostForm; {not nil, we checked, so this won't fail.}\r\nend;\r\n\r\n\r\n(*\r\n This old way was a kludge written by Warren that never properly worked anyways.\r\n It had the odd habit of rearranging controls, making previous docked forms (controls)\r\n disappear when docking a new one, and all manner of bad stuff like that.\r\n\r\nfunction Old_ManualTabDock(DockSite: TWinControl; Form1, Form2: TForm): TJvDockTabHostForm;\r\nvar\r\n TabHost: TJvDockTabHostForm;\r\n DockClient1, DockCLient2: TJvDockClient;\r\n ScreenPos: TRect;\r\n// otherForm:TForm;\r\n// n:Integer;\r\nbegin\r\n DockClient1 := FindDockClient(Form1);\r\n Form1.Hide;\r\n\r\n\r\n Assert(Assigned(DockClient1));\r\n\r\n if DockClient1.DockState = JvDockState_Docking then\r\n begin\r\n ScreenPos := Application.MainForm.ClientRect; // Just making it float temporarily.\r\n Form1.ManualFloat(ScreenPos); // This screws up on Delphi 2010.\r\n end;\r\n DockClient2 := FindDockClient(Form2);\r\n\r\n Form2.Hide;\r\n\r\n Assert(Assigned(DockClient2));\r\n if DockClient2.DockState = JvDockState_Docking then\r\n begin\r\n ScreenPos := Application.MainForm.ClientRect; // Just making it float temporarily.\r\n Form2.ManualFloat(ScreenPos);\r\n end;\r\n\r\n TabHost := DockClient1.CreateTabHostAndDockControl(Form1, Form2);\r\n\r\n\r\n\r\n {Mantis # 5023 workaround}\r\n TabHost.Show; { I have NO Idea why we need to call show here sometimes, and hide works here other times.}\r\n\r\n\r\n\r\n TabHost.ManualDock(DockSite,nil,alClient);\r\n if not Form1.Visible then\r\n Form1.Show;\r\n if not Form2.Visible then\r\n Form2.Show;\r\n\r\n// TabHost.Show; { problems if done here!}\r\n\r\n ShowDockForm(Form2);\r\n Result := TabHost;\r\nend;\r\n\r\n*)\r\n\r\n{ Must create the initial tab dock with two pages, using ManualTabDock,\r\n then you can add more pages with this:}\r\n\r\nprocedure ManualTabDockAddPage(TabHost: TJvDockTabHostForm; AForm: TForm);\r\nbegin\r\n Assert(Assigned(TabHost));\r\n Assert(Assigned(TabHost.PageControl));\r\n //AForm.Show;\r\n AForm.ManualDock(TabHost.PageControl);\r\n AForm.Show;\r\nend;\r\n\r\nprocedure ResetDockClient(DockClient: TJvDockClient; NewTarget: TControl);\r\nvar\r\n Pt: TPoint;\r\nbegin\r\n if (DockClient <> nil) and not (csDestroying in DockClient.ParentForm.ComponentState) then\r\n begin\r\n if not ((DockClient.ParentForm.HostDockSite is TJvDockPanel) and (NewTarget is TJvDockPanel)) then\r\n begin\r\n if (DockClient.LastDockSite is TJvDockPanel) and (NewTarget is TJvDockPanel) and\r\n (DockClient.LastDockSite <> NewTarget) then\r\n with TJvDockPanel(DockClient.LastDockSite) do\r\n if UseDockManager and (JvDockManager <> nil) then\r\n JvDockManager.RemoveControl(DockClient.ParentForm);\r\n\r\n if DockClient.ParentForm.HostDockSite is TJvDockPanel then\r\n DockClient.LastDockSite := DockClient.ParentForm.HostDockSite\r\n else\r\n DockClient.LastDockSite := nil;\r\n\r\n if DockClient.ParentForm.HostDockSite = nil then\r\n begin\r\n DockClient.UnDockLeft := DockClient.ParentForm.BoundsRect.TopLeft.X;\r\n DockClient.UnDockTop := DockClient.ParentForm.BoundsRect.TopLeft.Y;\r\n end\r\n else\r\n begin\r\n Pt := DockClient.ParentForm.BoundsRect.TopLeft;\r\n Pt := DockClient.ParentForm.HostDockSite.ClientToScreen(Pt);\r\n DockClient.UnDockLeft := Pt.X;\r\n DockClient.UnDockTop := Pt.Y;\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure ResetDockClient(Control: TControl; NewTarget: TControl);\r\nbegin\r\n ResetDockClient(FindDockClient(Control), NewTarget);\r\nend;\r\n\r\n // Save Layout to JvAppStorage:\r\n //\r\n // Uses Global VCL object Screens to go through all forms, and save layout for\r\n // all the forms. Use any JvCustomAppStorage descendant to store to, such\r\n // as registry, ini files, etc.\r\n\r\nprocedure SaveDockTreeToAppStorage(AppStorage: TJvCustomAppStorage; AppStoragePath: string = '');\r\nvar\r\n JvDockInfoTree: TJvDockInfoTree;\r\n I: Integer;\r\nbegin\r\n AppStorage.BeginUpdate;\r\n try\r\n HideAllPopupPanel(nil); {This is in JvDockVSNetStyle.pas }\r\n JvDockInfoTree := TJvDockInfoTree.Create(TJvDockInfoZone);\r\n try\r\n for I := 0 to Screen.CustomFormCount - 1 do\r\n if (Screen.CustomForms[I].Parent = nil) and\r\n ((FindDockClient(Screen.CustomForms[I]) <> nil) or\r\n (FindDockServer(Screen.CustomForms[I]) <> nil)) then\r\n begin\r\n {$IFDEF JVDOCK_DEBUG}\r\n OutputDebugString(PChar('SaveDockTreeToAppStorage : Form ' + Screen.CustomForms[I].Name));\r\n {$ENDIF JVDOCK_DEBUG}\r\n JvDockInfoTree.CreateZoneAndAddInfoFromApp(Screen.CustomForms[I]);\r\n end;\r\n\r\n JvDockInfoTree.AppStorage := AppStorage;\r\n JvDockInfoTree.AppStoragePath := AppStoragePath;\r\n JvDockInfoTree.WriteInfoToAppStorage;\r\n finally\r\n JvDockInfoTree.Free;\r\n end;\r\n finally\r\n AppStorage.EndUpdate;\r\n end;\r\nend;\r\n\r\nprocedure SaveDockTreeToFile(FileName: string);\r\nvar\r\n JvAppStorage: TJvAppIniFileStorage;\r\nbegin\r\n JvAppStorage := TJvAppIniFileStorage.Create(nil);\r\n try\r\n JvAppStorage.Location := flCustom;\r\n JvAppStorage.FileName := FileName;\r\n JvAppStorage.Reload;\r\n SaveDockTreeToAppStorage(JvAppStorage);\r\n finally\r\n JvAppStorage.Flush;\r\n JvAppStorage.Free;\r\n end;\r\nend;\r\n\r\nprocedure SaveDockTreeToReg(ARootKey: DWORD; RegPatch: string);\r\nvar\r\n JvAppStorage: TJvAppRegistryStorage;\r\nbegin\r\n JvAppStorage := TJvAppRegistryStorage.Create(nil);\r\n try\r\n // (p3) this seems dangerous but it's the same method as used by TJvAppRegistryStorage\r\n JvAppStorage.RegRoot := TJvRegKey(HKEY_CLASSES_ROOT + ARootKey);\r\n JvAppStorage.Path := RegPatch;\r\n SaveDockTreeToAppStorage(JvAppStorage);\r\n finally\r\n JvAppStorage.Free;\r\n end;\r\nend;\r\n\r\nprocedure SetConjoinDockHostBorderStyle(Value: TFormBorderStyle);\r\nvar\r\n I: Integer;\r\nbegin\r\n ConjoinDockHostBorderStyle := Value;\r\n for I := 0 to Screen.FormCount - 1 do\r\n if (Screen.CustomForms[I] is TJvDockConjoinHostForm) and (Screen.CustomForms[I].HostDockSite = nil) then\r\n TJvDockConjoinHostForm(Screen.CustomForms[I]).BorderStyle := Value;\r\nend;\r\n\r\nprocedure SetDockPageControlHotTrack(Value: Boolean);\r\nvar\r\n I: Integer;\r\nbegin\r\n DockPageControlHotTrack := Value;\r\n for I := 0 to Screen.FormCount - 1 do\r\n if Screen.CustomForms[I] is TJvDockTabHostForm then\r\n TJvDockTabHostForm(Screen.CustomForms[I]).PageControl.HotTrack := Value;\r\nend;\r\n\r\nprocedure SetDockPageControlPopupMenu(Value: TPopupMenu);\r\nvar\r\n I: Integer;\r\nbegin\r\n DockPageControlPopupMenu := Value;\r\n for I := 0 to Screen.FormCount - 1 do\r\n if Screen.CustomForms[I] is TJvDockTabHostForm then\r\n TJvDockTabHostForm(Screen.CustomForms[I]).PageControl.PopupMenu := Value;\r\nend;\r\n\r\nprocedure SetDockSite(Control: TWinControl; SiteValue: Boolean);\r\nbegin\r\n TWinControlAccessProtected(Control).DockSite := SiteValue;\r\n if (not (csDesigning in Control.ComponentState)) and (JvGlobalDockManager <> nil) then\r\n JvGlobalDockManager.RegisterDockSite(Control, SiteValue);\r\nend;\r\n\r\nprocedure SetTabDockHostBorderStyle(Value: TFormBorderStyle);\r\nvar\r\n I: Integer;\r\nbegin\r\n TabDockHostBorderStyle := Value;\r\n for I := 0 to Screen.FormCount - 1 do\r\n if (Screen.CustomForms[I] is TJvDockTabHostForm) and (Screen.CustomForms[I].HostDockSite = nil) then\r\n TJvDockTabHostForm(Screen.CustomForms[I]).BorderStyle := Value;\r\nend;\r\n\r\nprocedure ShowDockForm(DockWindow: TWinControl);\r\nvar\r\n ADockClient: TJvDockClient;\r\nbegin\r\n // delegate to style\r\n ADockClient := FindDockClient(DockWindow);\r\n if Assigned(ADockClient) and Assigned(ADockClient.DockStyle) then\r\n ADockClient.DockStyle.DoShowDockForm(DockWindow);\r\nend;\r\n\r\nprocedure TJvDockBasicStyle.DoShowDockForm(DockWindow: TWinControl);\r\n\r\n procedure ShowClient(Client, DockParent: TWinControl);\r\n var\r\n ADockClient: TJvDockClient;\r\n ADockServer: TJvDockServer;\r\n I: Integer;\r\n begin\r\n if (DockParent is TJvDockableForm) and (Client <> nil) then\r\n begin\r\n with TJvDockableForm(DockParent).DockableControl do\r\n for I := 0 to DockClientCount - 1 do\r\n if DockClients[I] <> Client then\r\n MakeDockClientEvent(DockClients[I], True);\r\n if Client.HostDockSite is TJvDockCustomControl then\r\n TJvDockCustomControl(Client.HostDockSite).UpdateCaption(nil);\r\n end\r\n else\r\n begin\r\n ADockClient := FindDockClient(DockParent);\r\n if (ADockClient <> nil) and (ADockClient.DockStyle <> nil) then\r\n begin\r\n ADockClient.DockStyle.ShowDockForm(ADockClient);\r\n ADockServer := FindDockServer(GetParentForm(DockParent));\r\n if (not Assigned(ADockServer) or ADockServer.AutoFocusDockedForm) and\r\n DockParent.CanFocus then\r\n DockParent.SetFocus;\r\n end;\r\n end;\r\n if DockParent.Parent = nil then\r\n SetForegroundWindow(DockParent.Handle);\r\n end;\r\n\r\n function ShowDockPanel(Client: TWinControl): TWinControl;\r\n begin\r\n Result := Client;\r\n if Assigned(Client) and (Client.HostDockSite is TJvDockPanel) then\r\n begin\r\n ShowClient(nil, Client);\r\n TJvDockPanel(Client.HostDockSite).ShowDockPanel(True, Client, sdfDockPanel);\r\n Result := nil;\r\n end;\r\n end;\r\n\r\n function ShowTabDockHost(Client: TWinControl): TWinControl;\r\n var\r\n I: Integer;\r\n begin\r\n Result := Client;\r\n if Assigned(Client) and (Client.HostDockSite is TJvDockTabPageControl) then\r\n begin\r\n ShowClient(nil, Client);\r\n\r\n with TJvDockTabPageControl(Client.HostDockSite) do\r\n for I := 0 to Count - 1 do\r\n if Pages[I].Controls[0] = Client then\r\n begin\r\n Pages[I].Show;\r\n Break;\r\n end;\r\n if (Client.HostDockSite <> nil) and not (Client.HostDockSite is TJvDockPanel) then\r\n begin\r\n Result := Client.HostDockSite.Parent;\r\n ShowClient(Client, Result);\r\n if (Result <> nil) and (Result.HostDockSite is TJvDockTabPageControl) then\r\n { (rb) never called AFAICS }\r\n Result := ShowTabDockHost(Result)\r\n else\r\n ShowClient(nil, Result);\r\n end;\r\n end;\r\n end;\r\n\r\n function ShowConjoinDockHost(Client: TWinControl): TWinControl;\r\n begin\r\n Result := Client;\r\n if Assigned(Client) and Assigned(Client.HostDockSite) and not (Client.HostDockSite is TJvDockPanel) then\r\n begin\r\n ShowClient(nil, Client);\r\n if Client.HostDockSite.Parent <> nil then\r\n begin\r\n Result := Client.HostDockSite.Parent;\r\n ShowClient(Client, Result);\r\n if (Result <> nil) and (Result.HostDockSite is TJvDockConjoinPanel) then\r\n { (rb) never called AFAICS }\r\n Result := ShowConjoinDockHost(Result)\r\n else\r\n ShowClient(nil, Result);\r\n end;\r\n end;\r\n end;\r\n\r\nbegin\r\n repeat\r\n { Show single floating window }\r\n if Assigned(DockWindow) and (DockWindow.HostDockSite = nil) then\r\n ShowClient(nil, DockWindow);\r\n DockWindow := ShowTabDockHost(DockWindow);\r\n DockWindow := ShowConjoinDockHost(DockWindow);\r\n { Show docked window }\r\n DockWindow := ShowDockPanel(DockWindow);\r\n until (DockWindow = nil) or (DockWindow.Parent = nil);\r\nend;\r\n\r\n//=== { TJvDockableForm } ====================================================\r\n\r\nconstructor TJvDockableForm.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n DragKind := dkDock;\r\n FDockClient := TJvDockClient.Create(Self);\r\n JvGlobalDockManager.RegisterDockableForm(Self);\r\n FFloatingChild := nil;\r\n TBDockHeight := FDockClient.TBDockHeight;\r\n LRDockWidth := FDockClient.LRDockWidth;\r\nend;\r\n\r\ndestructor TJvDockableForm.Destroy;\r\nbegin\r\n if JvGlobalDockManager <> nil then\r\n JvGlobalDockManager.UnRegisterDockableForm(Self);\r\n { Now handled in destroy of DockClient via TJvDockClient.SetLastDockSite }\r\n //if DockClient.LastDockSite is TJvDockPanel then\r\n // if Assigned(TJvDockPanel(DockClient.LastDockSite).JvDockManager) then\r\n // TJvDockPanel(DockClient.LastDockSite).JvDockManager.RemoveControl(Self);\r\n inherited Destroy;\r\n // (rom) better comment this\r\n FFloatingChild := nil;\r\nend;\r\n\r\nprocedure TJvDockableForm.DoClose(var Action: TCloseAction);\r\nvar\r\n I: Integer;\r\nbegin\r\n if not Assigned(DockableControl) then\r\n exit;\r\n\r\n if DockableControl.DockClientCount = 1 then\r\n begin\r\n FFloatingChild := DockableControl.DockClients[0];\r\n\r\n if HostDockSite <> nil then\r\n FFloatingChild.Visible := False;\r\n\r\n DoFloat(Self, DockableControl.DockClients[0]);\r\n Action := caFree;\r\n end\r\n else\r\n if DockableControl.DockClientCount = 0 then\r\n Action := caFree\r\n else\r\n begin\r\n Action := caHide;\r\n if (FUnDockControl <> nil) and (DockableControl.DockClientCount = 2) then\r\n for I := 0 to DockableControl.DockClientCount - 1 do\r\n if FUnDockControl = DockableControl.DockClients[I] then\r\n begin\r\n Action := caNone;\r\n Break;\r\n end;\r\n end;\r\n if (HostDockSite is TJvDockPanel) and (HostDockSite.VisibleDockClientCount = 1) and\r\n (FFloatingChild = nil) then\r\n TJvDockPanel(HostDockSite).ShowDockPanel(False, Self);\r\n\r\n inherited DoClose(Action);\r\n FUnDockControl := nil;\r\nend;\r\n\r\nfunction TJvDockableForm.GetDockableControl: TWinControl;\r\nbegin\r\n Result := FDockableControl;\r\nend;\r\n\r\nprocedure TJvDockableForm.SetDockableControl(const Value: TWinControl);\r\nbegin\r\n FDockableControl := Value;\r\nend;\r\n\r\nprocedure TJvDockableForm.SetUnDockControl(const Value: TControl);\r\nbegin\r\n FUnDockControl := Value;\r\nend;\r\n\r\n//=== { TJvDockAdvConjoinPanel } =============================================\r\n\r\nprocedure TJvDockAdvConjoinPanel.CMUnDockClient(var Msg: TCMUnDockClient);\r\nbegin\r\n inherited;\r\nend;\r\n\r\nprocedure TJvDockAdvConjoinPanel.CustomDockDrop(Source: TJvDockDragDockObject;\r\n X, Y: Integer);\r\nbegin\r\n if not JvGlobalDockIsLoading then\r\n ResetDockClient(Source.Control, Source.TargetControl);\r\n inherited CustomDockDrop(Source, X, Y);\r\nend;\r\n\r\nfunction TJvDockAdvConjoinPanel.CustomUnDock(Source: TJvDockDragDockObject;\r\n NewTarget: TWinControl; Client: TControl): Boolean;\r\nbegin\r\n if not JvGlobalDockIsLoading then\r\n ResetDockClient(Source.Control, NewTarget);\r\n Result := inherited CustomUnDock(Source, NewTarget, Client);\r\nend;\r\n\r\nprocedure TJvDockAdvConjoinPanel.DockDrop(Source: TDragDockObject;\r\n X, Y: Integer);\r\nbegin\r\n if not JvGlobalDockIsLoading then\r\n ResetDockClient(Source.Control, TControl(Source.DragTarget));\r\n inherited DockDrop(Source, X, Y);\r\nend;\r\n\r\nfunction TJvDockAdvConjoinPanel.DoUnDock(NewTarget: TWinControl;\r\n Client: TControl): Boolean;\r\nbegin\r\n if not JvGlobalDockIsLoading then\r\n ResetDockClient(Client, NewTarget);\r\n Result := inherited DoUnDock(NewTarget, Client);\r\nend;\r\n\r\n//=== { TJvDockAdvPanel } ====================================================\r\n\r\nprocedure TJvDockAdvPanel.CMUnDockClient(var Msg: TCMUnDockClient);\r\nvar\r\n DockClient: TJvDockClient;\r\nbegin\r\n if JvGlobalDockIsLoading then\r\n Exit;\r\n with Msg do\r\n begin\r\n Result := 0;\r\n if UseDockManager and (JvDockManager <> nil) then\r\n begin\r\n DockClient := FindDockClient(Client);\r\n if (NewTarget <> nil) or\r\n ((Client <> nil) and (csDestroying in Client.ComponentState)) then\r\n begin\r\n if DockClient <> nil then\r\n DockClient.LastDockSite := nil;\r\n JvDockManager.RemoveControl(Client);\r\n end\r\n else\r\n begin\r\n if DockClient <> nil then\r\n DockClient.LastDockSite := Self;\r\n JvDockManager.HideControl(Client);\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockAdvPanel.CustomDockDrop(Source: TJvDockDragDockObject;\r\n X, Y: Integer);\r\nbegin\r\n if not JvGlobalDockIsLoading then\r\n ResetDockClient(Source.Control, Source.TargetControl);\r\n inherited CustomDockDrop(Source, X, Y);\r\nend;\r\n\r\nfunction TJvDockAdvPanel.CustomUnDock(Source: TJvDockDragDockObject;\r\n NewTarget: TWinControl; Client: TControl): Boolean;\r\nbegin\r\n if not JvGlobalDockIsLoading then\r\n ResetDockClient(Source.Control, NewTarget);\r\n Result := inherited CustomUnDock(Source, NewTarget, Client)\r\nend;\r\n\r\nprocedure TJvDockAdvPanel.DockDrop(Source: TDragDockObject; X, Y: Integer);\r\nbegin\r\n if not JvGlobalDockIsLoading then\r\n ResetDockClient(Source.Control, TControl(Source.DragTarget));\r\n inherited DockDrop(Source, X, Y);\r\nend;\r\n\r\nfunction TJvDockAdvPanel.DoUnDock(NewTarget: TWinControl;\r\n Client: TControl): Boolean;\r\nbegin\r\n if not JvGlobalDockIsLoading then\r\n ResetDockClient(Client, NewTarget);\r\n Result := inherited DoUnDock(NewTarget, Client);\r\nend;\r\n\r\n// NEW! -WPostma.\r\n// Calls FADVTree.QueryControls which finds forms containing JvDockClient\r\n// objects that are directly or indirectly docked to this panel.\r\n\r\nprocedure TJvDockAdvPanel.GetDockedControls(WinControls: TList); //override;\r\nbegin\r\n { (rb) Same result could be get via iterating property TWinControl.DockClients }\r\n Assert(Assigned(WinControls));\r\n if Assigned(JvDockManager) then\r\n begin\r\n\tWinControls.Clear;\r\n\t{$IFDEF JVDOCK_QUERY}\r\n\tJvDockManager.ControlQuery({Docked to self}Self, WinControls);\r\n\t{$ENDIF JVDOCK_QUERY}\r\n end;\r\nend;\r\n\r\nfunction TJvDockAdvPanel.FindTabHostForm:TWinControl;\r\nvar\r\n n:Integer;\r\n wc:TControl;\r\nbegin\r\n\tfor n := 0 to Self.DockClientCount-1 do begin\r\n\t\twc := Self.DockClients[n];\r\n\t\tif wc is TJvDockTabHostForm then begin\r\n\t\t result := wc as TWinControl;\r\n\t\t exit;\r\n\t\tend;\r\n\tend;\r\n\tresult := nil;\r\n\r\nend;\r\n\r\n\r\n//=== { TJvDockAdvStyle } ====================================================\r\n\r\nfunction TJvDockAdvStyle.DockClientWindowProc(DockClient: TJvDockClient;\r\n var Msg: TMessage): Boolean;\r\nbegin\r\n if (DockClient <> nil) and (Msg.Msg = WM_NCLBUTTONDBLCLK) then\r\n if DockClient.CanFloat then\r\n DockClient.RestoreChild;\r\n Result := inherited DockClientWindowProc(DockClient, Msg);\r\nend;\r\n\r\n//=== { TJvDockAdvTabPageControl } ===========================================\r\n\r\ndestructor TJvDockAdvTabPageControl.Destroy;\r\n//var\r\n// DockClient: TJvDockClient;\r\nbegin\r\n { Now handled in TJvDockClient.SetLastDockSite }\r\n // { Parent is always nil? Self is maintained by TJvDockTabHostForm (=Parent),\r\n // Self is destroyed only if TJvDockTabHostForm is destroyed (thus is nil at\r\n // this point }\r\n // DockClient := FindDockClient(Parent);\r\n // if (DockClient <> nil) and (DockClient.LastDockSite is TJvDockPanel) then\r\n // with TJvDockPanel(DockClient.LastDockSite) do\r\n // if UseDockManager and (JvDockManager <> nil) then\r\n // JvDockManager.RemoveControl(Self.Parent);\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvDockAdvTabPageControl.CMUnDockClient(var Msg: TCMUnDockClient);\r\nbegin\r\n inherited;\r\nend;\r\n\r\nprocedure TJvDockAdvTabPageControl.CustomDockDrop(Source: TJvDockDragDockObject;\r\n X, Y: Integer);\r\nbegin\r\n if not JvGlobalDockIsLoading then\r\n ResetDockClient(Source.Control, Source.TargetControl);\r\n inherited CustomDockDrop(Source, X, Y);\r\nend;\r\n\r\nfunction TJvDockAdvTabPageControl.CustomUnDock(Source: TJvDockDragDockObject;\r\n NewTarget: TWinControl; Client: TControl): Boolean;\r\nbegin\r\n if not JvGlobalDockIsLoading then\r\n ResetDockClient(Source.Control, NewTarget);\r\n Result := inherited CustomUnDock(Source, NewTarget, Client)\r\nend;\r\n\r\nprocedure TJvDockAdvTabPageControl.DockDrop(Source: TDragDockObject;\r\n X, Y: Integer);\r\nbegin\r\n if not JvGlobalDockIsLoading then\r\n ResetDockClient(Source.Control, TControl(Source.DragTarget));\r\n inherited DockDrop(Source, X, Y);\r\nend;\r\n\r\nfunction TJvDockAdvTabPageControl.DoUnDock(NewTarget: TWinControl;\r\n Client: TControl): Boolean;\r\nbegin\r\n if not JvGlobalDockIsLoading then\r\n ResetDockClient(Client, NewTarget);\r\n Result := inherited DoUnDock(NewTarget, Client);\r\nend;\r\n\r\n//=== { TJvDockBaseControl } =================================================\r\n\r\nconstructor TJvDockBaseControl.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n { Dangerous/Dirty }\r\n FParentForm := TForm(AOwner);\r\n FEnableDock := True;\r\n FLeftDock := True;\r\n FTopDock := True;\r\n FCustomDock := True; {Allowed to dock in custom area!}\r\n FRightDock := True;\r\n FBottomDock := True;\r\n FEachOtherDock := True;\r\n FDockStyle := nil;\r\n if not (csDesigning in ComponentState) then\r\n begin\r\n FOldOnClose := FParentForm.OnClose;\r\n ParentForm.OnClose := DoFormOnClose;\r\n FOldOnCreate := FParentForm.OnCreate;\r\n ParentForm.OnCreate := DoFormOnCreate;\r\n FOldWindowProc := FParentForm.WindowProc;\r\n FParentForm.WindowProc := WindowProc;\r\n end;\r\nend;\r\n\r\ndestructor TJvDockBaseControl.Destroy;\r\nbegin\r\n if not (csDesigning in ComponentState) then\r\n begin\r\n if Assigned(FOldWindowProc) then\r\n FParentForm.WindowProc := FOldWindowProc;\r\n FOldWindowProc := nil;\r\n { ?? FDockStyle is always a TJvDockBasicStyle }\r\n if Assigned(FDockStyle) {and not (FDockStyle is TJvDockBasicStyle)} then\r\n FDockStyle.SetDockBaseControl(False, Self);\r\n end;\r\n DockStyle := nil;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvDockBaseControl.AddDockStyle(ADockStyle: TJvDockBasicStyle);\r\nbegin\r\n { Notification }\r\nend;\r\n\r\nprocedure TJvDockBaseControl.Assign(Source: TPersistent);\r\nbegin\r\n if Source is TJvDockBaseControl then\r\n begin\r\n EnableDock := TJvDockBaseControl(Source).EnableDock;\r\n LeftDock := TJvDockBaseControl(Source).LeftDock;\r\n TopDock := TJvDockBaseControl(Source).TopDock;\r\n RightDock := TJvDockBaseControl(Source).RightDock;\r\n BottomDock := TJvDockBaseControl(Source).BottomDock;\r\n CustomDock := TJvDockBaseControl(Source).CustomDock; {NEW!}\r\n EachOtherDock := TJvDockBaseControl(Source).EachOtherDock;\r\n DockStyle := TJvDockBaseControl(Source).DockStyle;\r\n end\r\n else\r\n inherited Assign(Source);\r\nend;\r\n\r\nfunction TJvDockBaseControl.CanSetBottomDocked: Boolean;\r\nbegin\r\n if DockStyle <> nil then\r\n Result := DockStyle.CanSetBottomDocked(Self)\r\n else\r\n Result := True;\r\nend;\r\n\r\nfunction TJvDockBaseControl.CanSetEachOtherDocked: Boolean;\r\nbegin\r\n if DockStyle <> nil then\r\n Result := DockStyle.CanSetEachOtherDocked(Self)\r\n else\r\n Result := True;\r\nend;\r\n\r\nfunction TJvDockBaseControl.CanSetEnableDocked: Boolean;\r\nbegin\r\n if DockStyle <> nil then\r\n Result := DockStyle.CanSetEnableDocked(Self)\r\n else\r\n Result := True;\r\nend;\r\n\r\nfunction TJvDockBaseControl.CanSetLeftDocked: Boolean;\r\nbegin\r\n if DockStyle <> nil then\r\n Result := DockStyle.CanSetLeftDocked(Self)\r\n else\r\n Result := True;\r\nend;\r\n\r\nfunction TJvDockBaseControl.CanSetRightDocked: Boolean;\r\nbegin\r\n if DockStyle <> nil then\r\n Result := DockStyle.CanSetRightDocked(Self)\r\n else\r\n Result := True;\r\nend;\r\n\r\nfunction TJvDockBaseControl.CanSetTopDocked: Boolean;\r\nbegin\r\n if DockStyle <> nil then\r\n Result := DockStyle.CanSetTopDocked(Self)\r\n else\r\n Result := True;\r\nend;\r\n\r\nprocedure TJvDockBaseControl.DoFormOnClose(Sender: TObject;\r\n var Action: TCloseAction);\r\nbegin\r\n { Code is moved to AddDockStyle, RemoveDockStyle; if a user assigns OnClose,\r\n OnCreate handlers things would go wrong.\r\n }\r\n if Assigned(FOldOnClose) then\r\n FOldOnClose(Sender, Action);\r\nend;\r\n\r\nprocedure TJvDockBaseControl.DoFormOnCreate(Sender: TObject);\r\nbegin\r\n { Code is moved to AddDockStyle, RemoveDockStyle; if a user assigns OnClose,\r\n OnCreate handlers things would go wrong.\r\n }\r\n if Assigned(FOldOnCreate) then\r\n FOldOnCreate(Sender);\r\nend;\r\n\r\nprocedure TJvDockBaseControl.Notification(AComponent: TComponent;\r\n Operation: TOperation);\r\nbegin\r\n inherited Notification(AComponent, Operation);\r\n if Operation = opRemove then\r\n if AComponent = FDockStyle then\r\n DockStyle := nil;\r\nend;\r\n\r\nprocedure TJvDockBaseControl.RemoveDockStyle(ADockStyle: TJvDockBasicStyle);\r\nbegin\r\n { Notification }\r\nend;\r\n\r\nprocedure TJvDockBaseControl.SetBottomDock(const Value: Boolean);\r\nbegin\r\n if CanSetBottomDocked then\r\n FBottomDock := Value;\r\nend;\r\n\r\nprocedure TJvDockBaseControl.SetDockStyle(ADockStyle: TJvDockBasicStyle);\r\nbegin\r\n {$IFDEF JVDOCK_DEBUG}\r\n OutputDebugString('TJvDockBaseControl.SetDockStyle');\r\n {$ENDIF JVDOCK_DEBUG}\r\n if ADockStyle <> FDockStyle then\r\n begin\r\n ParentForm.DisableAlign;\r\n try\r\n if FDockStyle <> nil then\r\n begin\r\n { Remove Self from the internal list of the dock style component }\r\n FDockStyle.RemoveDockBaseControl(Self);\r\n\r\n { Give the ancestors a change to respond }\r\n RemoveDockStyle(FDockStyle);\r\n end;\r\n\r\n ReplaceComponentReference(Self, ADockStyle, TComponent(FDockStyle));\r\n\r\n if FDockStyle <> nil then\r\n begin\r\n { Let the style initialize the TJvDockClient/TJvDockServer }\r\n FDockStyle.SetDockBaseControl([csLoading, csDesigning] * ComponentState <> [], Self);\r\n\r\n { Add Self to the internal list of the dock style component }\r\n FDockStyle.AddDockBaseControl(Self);\r\n\r\n { Give the ancestors a change to respond }\r\n AddDockStyle(FDockStyle);\r\n\r\n end;\r\n finally\r\n ParentForm.EnableAlign;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockBaseControl.SetEachOtherDock(const Value: Boolean);\r\nbegin\r\n if CanSetEachOtherDocked then\r\n FEachOtherDock := Value;\r\nend;\r\n\r\nprocedure TJvDockBaseControl.SetEnableDock(const Value: Boolean);\r\nbegin\r\n if CanSetEnableDocked then\r\n FEnableDock := Value;\r\nend;\r\n\r\nprocedure TJvDockBaseControl.SetLeftDock(const Value: Boolean);\r\nbegin\r\n if CanSetLeftDocked then\r\n FLeftDock := Value;\r\nend;\r\n\r\nprocedure TJvDockBaseControl.SetParentComponent(Value: TComponent);\r\nvar\r\n DockBaseControl: TJvDockBaseControl;\r\nbegin\r\n DockBaseControl := FindDockBaseControl(ParentForm);\r\n if Assigned(DockBaseControl) and (DockBaseControl <> Self) then\r\n raise EInvalidOperation.CreateResFmt(@RsEDockCannotLayAnother, [DockBaseControl.ClassName, ClassName]);\r\n inherited SetParentComponent(Value);\r\nend;\r\n\r\nprocedure TJvDockBaseControl.SetRightDock(const Value: Boolean);\r\nbegin\r\n if CanSetRightDocked then\r\n FRightDock := Value;\r\nend;\r\n\r\nprocedure TJvDockBaseControl.SetTopDock(const Value: Boolean);\r\nbegin\r\n if CanSetTopDocked then\r\n FTopDock := Value;\r\nend;\r\n\r\nprocedure TJvDockBaseControl.WindowProc(var Msg: TMessage);\r\nbegin\r\n if not (csDesigning in ComponentState) then\r\n if Assigned(FOldWindowProc) then\r\n FOldWindowProc(Msg);\r\nend;\r\n\r\n//=== { TJvDockBasicStyle } ==================================================\r\n\r\nconstructor TJvDockBasicStyle.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n\r\n DockPanelClass := DefaultDockPanelClass;\r\n DockSplitterClass := DefaultDockSplitterClass;\r\n ConjoinPanelClass := DefaultConjoinPanelClass;\r\n TabDockClass := DefaultTabDockClass;\r\n DockPanelTreeClass := DefaultDockTreeClass;\r\n DockPanelZoneClass := DefaultDockZoneClass;\r\n ConjoinPanelTreeClass := DefaultDockTreeClass;\r\n ConjoinPanelZoneClass := DefaultDockZoneClass;\r\n FDockBaseControls := TList.Create;\r\nend;\r\n\r\ndestructor TJvDockBasicStyle.Destroy;\r\nbegin\r\n FDockBaseControls.Free;\r\n FreeServerOption;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvDockBasicStyle.AddDockBaseControl(ADockBaseControl: TJvDockBaseControl);\r\nbegin\r\n {$IFDEF JVDOCK_DEBUG}\r\n OutputDebugString('TJvDockBasicStyle.AddDockBaseControl');\r\n {$ENDIF JVDOCK_DEBUG}\r\n if ADockBaseControl = nil then\r\n Exit;\r\n FDockBaseControls.Add(ADockBaseControl);\r\nend;\r\n\r\nfunction TJvDockBasicStyle.CanSetBottomDocked(ADockBaseControl: TJvDockBaseControl): Boolean;\r\nbegin\r\n Result := True;\r\nend;\r\n\r\nfunction TJvDockBasicStyle.CanSetEachOtherDocked(ADockBaseControl: TJvDockBaseControl): Boolean;\r\nbegin\r\n Result := True;\r\nend;\r\n\r\nfunction TJvDockBasicStyle.CanSetEnableDocked(ADockBaseControl: TJvDockBaseControl): Boolean;\r\nbegin\r\n Result := True;\r\nend;\r\n\r\nfunction TJvDockBasicStyle.CanSetLeftDocked(ADockBaseControl: TJvDockBaseControl): Boolean;\r\nbegin\r\n Result := True;\r\nend;\r\n\r\nfunction TJvDockBasicStyle.CanSetRightDocked(ADockBaseControl: TJvDockBaseControl): Boolean;\r\nbegin\r\n Result := True;\r\nend;\r\n\r\nfunction TJvDockBasicStyle.CanSetTopDocked(ADockBaseControl: TJvDockBaseControl): Boolean;\r\nbegin\r\n Result := True;\r\nend;\r\n\r\nfunction TJvDockBasicStyle.DockClientWindowProc(DockClient: TJvDockClient; var Msg: TMessage): Boolean;\r\nbegin\r\n Result := False;\r\nend;\r\n\r\nfunction TJvDockBasicStyle.DockServerWindowProc(DockServer: TJvDockServer;\r\n var Msg: TMessage): Boolean;\r\nbegin\r\n Result := False;\r\nend;\r\n\r\nprocedure TJvDockBasicStyle.FormDockDrop(DockClient: TJvDockClient;\r\n Source: TJvDockDragDockObject; X, Y: Integer);\r\nvar\r\n ARect, DRect: TRect;\r\n DockType: TAlign;\r\n Host: TCustomForm;\r\n APanelDock: TWinControl;\r\nbegin\r\n if IsDockable(DockClient.ParentForm, Source.Control, Source.DropOnControl, Source.DropAlign) then\r\n begin\r\n Host := nil;\r\n\r\n if not JvGlobalDockIsLoading then\r\n JvDockLockWindow(nil);\r\n try\r\n with DockClient do\r\n begin\r\n DockType := ComputeDockingRect(DockClient.ParentForm, ARect, Point(X, Y));\r\n\r\n if ParentForm.HostDockSite is TJvDockPanel then\r\n begin\r\n if DockType = alClient then\r\n begin\r\n if Source.Control is TJvDockTabHostForm then\r\n begin\r\n APanelDock := ParentForm.HostDockSite;\r\n ARect := ParentForm.BoundsRect;\r\n ParentForm.ManualDock(TJvDockTabHostForm(Source.Control).PageControl, nil, alClient);\r\n TJvDockTabHostForm(Source.Control).PageControl.ActivePage.PageIndex := 0;\r\n Source.Control.BoundsRect := ARect;\r\n Source.Control.ManualDock(APanelDock, nil, alClient);\r\n if ParentForm.FormStyle = fsStayOnTop then\r\n TForm(Source.Control).FormStyle := fsStayOnTop;\r\n end\r\n else\r\n begin\r\n APanelDock := ParentForm.HostDockSite;\r\n DRect.TopLeft := ParentForm.HostDockSite.ClientToScreen(Point(0, 0));\r\n Host := CreateTabHostAndDockControl(ParentForm, Source.Control);\r\n SetDockSite(ParentForm, False);\r\n SetDockSite(TWinControl(Source.Control), False);\r\n Host.Top := DRect.Top;\r\n Host.Left := DRect.Left;\r\n Host.ManualDock(APanelDock, nil, alClient);\r\n Host.Visible := True;\r\n end;\r\n end\r\n else\r\n begin\r\n DRect := ParentForm.HostDockSite.BoundsRect;\r\n Source.Control.ManualDock(ParentForm.HostDockSite, nil, DockType);\r\n ParentForm.HostDockSite.BoundsRect := DRect;\r\n end;\r\n Exit;\r\n end;\r\n\r\n if DockType = alClient then\r\n begin\r\n Host := CreateTabHostAndDockControl(ParentForm, Source.Control);\r\n SetDockSite(ParentForm, False);\r\n SetDockSite(TWinControl(Source.Control), False);\r\n Host.Visible := True;\r\n end\r\n else\r\n if DockType <> alNone then\r\n begin\r\n Host := CreateConjoinHostAndDockControl(ParentForm, Source.Control, DockType);\r\n SetDockSite(ParentForm, False);\r\n SetDockSite(TWinControl(Source.Control), False);\r\n Host.Visible := True;\r\n end;\r\n\r\n if Host <> nil then\r\n begin\r\n Host.LRDockWidth := Source.Control.LRDockWidth;\r\n Host.TBDockHeight := Source.Control.TBDockHeight;\r\n end;\r\n end;\r\n finally\r\n if not JvGlobalDockIsLoading then\r\n JvDockUnLockWindow;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockBasicStyle.FormDockOver(DockClient: TJvDockClient;\r\n Source: TJvDockDragDockObject; X, Y: Integer; State: TDragState; var Accept: Boolean);\r\nvar\r\n ARect: TRect;\r\nbegin\r\n with DockClient do\r\n begin\r\n Accept := EnableDock and EachOtherDock and\r\n IsDockable(ParentForm.HostDockSite, Source.Control, Source.DropOnControl, Source.DropAlign);\r\n if Accept and (State = dsDragMove) and\r\n (ComputeDockingRect(ParentForm, ARect, Point(X, Y)) <> alNone) then\r\n Source.DockRect := ARect;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockBasicStyle.FormEndDock(DockClient: TJvDockClient;\r\n Target: TObject; X, Y: Integer);\r\nbegin\r\nend;\r\n\r\nprocedure TJvDockBasicStyle.FormGetDockEdge(DockClient: TJvDockClient;\r\n Source: TJvDockDragDockObject; MousePos: TPoint; var DropAlign: TAlign);\r\nbegin\r\n DropAlign := TControlAccessProtected(DockClient.ParentForm).GetDockEdge(MousePos);\r\nend;\r\n\r\nprocedure TJvDockBasicStyle.FormGetSiteInfo(Source: TJvDockDragDockObject;\r\n DockClient: TJvDockClient; Client: TControl; var InfluenceRect: TRect;\r\n MousePos: TPoint; var CanDock: Boolean);\r\nbegin\r\n with DockClient do\r\n CanDock := EnableDock and EachOtherDock and\r\n IsDockable(ParentForm, Client, Source.DropOnControl, Source.DropAlign);\r\nend;\r\n\r\nprocedure TJvDockBasicStyle.FormPositionDockRect(DockClient: TJvDockClient;\r\n Source: TJvDockDragDockObject);\r\nvar\r\n NewWidth, NewHeight: Integer;\r\n TempX, TempY: Double;\r\n R: TRect;\r\nbegin\r\n with Source do\r\n begin\r\n if (DragTarget = nil) or (not TWinControlAccessProtected(DragTarget).UseDockManager) then\r\n begin\r\n NewWidth := Control.UndockWidth;\r\n NewHeight := Control.UndockHeight;\r\n TempX := DragPos.X - ((NewWidth) * MouseDeltaX);\r\n TempY := DragPos.Y - ((NewHeight) * MouseDeltaY);\r\n R := DockRect;\r\n R.Left := Round(TempX);\r\n R.Top := Round(TempY);\r\n R.Right := R.Left + NewWidth;\r\n R.Bottom := R.Top + NewHeight;\r\n DockRect := R;\r\n AdjustDockRect(DockRect);\r\n end\r\n else\r\n begin\r\n GetWindowRect(TargetControl.Handle, R);\r\n DockRect := R;\r\n if TWinControlAccessProtected(DragTarget).UseDockManager then\r\n if TargetControl is TJvDockCustomPanel then\r\n if (TJvDockCustomPanel(DragTarget).JvDockManager <> nil) then\r\n begin\r\n R := DockRect;\r\n TJvDockCustomPanel(DragTarget).JvDockManager.PositionDockRect(Control,\r\n DropOnControl, DropAlign, R);\r\n DockRect := R;\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockBasicStyle.FormStartDock(DockClient: TJvDockClient;\r\n var Source: TJvDockDragDockObject);\r\nbegin\r\nend;\r\n\r\nfunction TJvDockBasicStyle.FormUnDock(DockClient: TJvDockClient; NewTarget: TWinControl;\r\n Client: TControl): Boolean;\r\nbegin\r\n Result := True;\r\nend;\r\n\r\nfunction TJvDockBasicStyle.GetDockBaseControlCount: Integer;\r\nbegin\r\n Result := FDockBaseControls.Count;\r\nend;\r\n\r\nfunction TJvDockBasicStyle.GetDockBaseControl(Index: Integer): TJvDockBaseControl;\r\nbegin\r\n Result := TJvDockBaseControl(FDockBaseControls[Index]);\r\nend;\r\n\r\nfunction TJvDockBasicStyle.GetDockFormVisible(ADockClient: TJvDockClient): Boolean;\r\nbegin\r\n Result := True;\r\n if ADockClient <> nil then\r\n begin\r\n if ADockClient.ParentForm.Visible then\r\n begin\r\n if ADockClient.ParentForm.HostDockSite <> nil then\r\n begin\r\n if ADockClient.ParentForm.HostDockSite is TJvDockPanel then\r\n Result := ADockClient.ParentForm.HostDockSite.Width * ADockClient.ParentForm.HostDockSite.Height > 0\r\n else\r\n Result := GetFormVisible(ADockClient.ParentForm.HostDockSite.Parent);\r\n end;\r\n end\r\n else\r\n Result := False;\r\n end;\r\nend;\r\n\r\nfunction TJvDockBasicStyle.GetDockState(DockClient: TJvDockClient): Integer;\r\nbegin\r\n Result := JvDockState_Unknown;\r\n if (DockClient <> nil) and (DockClient.ParentForm <> nil) then\r\n if DockClient.ParentForm.Floating then\r\n Result := JvDockState_Floating\r\n else\r\n Result := JvDockState_Docking;\r\nend;\r\n\r\nprocedure TJvDockBasicStyle.HideDockForm(ADockClient: TJvDockClient);\r\nbegin\r\n if ADockClient <> nil then\r\n begin\r\n ADockClient.ParentForm.Visible := False;\r\n ADockClient.MakeHideEvent;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockBasicStyle.RemoveDockBaseControl(ADockBaseControl: TJvDockBaseControl);\r\nbegin\r\n FDockBaseControls.Remove(ADockBaseControl);\r\nend;\r\n\r\nprocedure TJvDockBasicStyle.ResetCursor(Source: TJvDockDragDockObject);\r\nbegin\r\n if (Source.TargetControl = nil) and (Source.Control <> nil) and (Source.Control.Floating) then\r\n Windows.SetCursor(Screen.Cursors[crDefault])\r\n else\r\n if (Source.TargetControl = nil) and (not JvGlobalDockClient.CanFloat) then\r\n Windows.SetCursor(Screen.Cursors[crNo])\r\n else\r\n Windows.SetCursor(Screen.Cursors[crDefault]);\r\nend;\r\n\r\nprocedure TJvDockBasicStyle.RestoreClient(DockClient: TJvDockClient);\r\nvar\r\n TmpLastDockSite: TWinControl;\r\n TmpUnDockLeft, TmpUnDockTop: Integer;\r\n I: Integer;\r\n ADockClient: TJvDockClient;\r\n ADockServer: TJvDockServer;\r\n ARect: TRect;\r\n\r\n procedure DoFloatParentForm;\r\n begin\r\n with DockClient do\r\n if (ParentForm.HostDockSite <> nil) then\r\n begin\r\n ARect := Bounds(TmpUnDockLeft, TmpUnDockTop, ParentForm.UndockWidth, ParentForm.UndockHeight);\r\n ParentForm.ManualFloat(ARect);\r\n if (ParentForm.Left <> ARect.Left) or (ParentForm.Top <> ARect.Top) then\r\n begin\r\n ParentForm.Left := ARect.Left;\r\n ParentForm.Top := ARect.Top;\r\n end;\r\n end;\r\n end;\r\n\r\nbegin\r\n if DockClient = nil then\r\n Exit;\r\n if not DockClient.CanFloat then\r\n Exit;\r\n with DockClient do\r\n begin\r\n if not EnableDock then\r\n Exit;\r\n if LastDockSite is TJvDockPanel then\r\n begin\r\n with TJvDockPanel(LastDockSite) do\r\n begin\r\n if ((not LeftDock) and (Align = alLeft)) or\r\n ((not RightDock) and (Align = alRight)) or\r\n ((not TopDock) and (Align = alTop)) or\r\n ((not BottomDock) and (Align = alBottom)) then\r\n begin\r\n DoFloatParentForm;\r\n Exit;\r\n end;\r\n\r\n ADockServer := DockServer;\r\n if ADockServer <> nil then\r\n if (not ADockServer.EnableDock) or\r\n ((not ADockServer.LeftDock) and (Align = alLeft)) or\r\n ((not ADockServer.RightDock) and (Align = alRight)) or\r\n ((not ADockServer.TopDock) and (Align = alTop)) or\r\n ((not ADockServer.BottomDock) and (Align = alBottom)) then\r\n begin\r\n DoFloatParentForm;\r\n Exit;\r\n end;\r\n end;\r\n end;\r\n\r\n if ParentForm is TJvDockConjoinHostForm then\r\n begin\r\n with TJvDockConjoinHostForm(ParentForm).Panel do\r\n for I := DockClientCount - 1 downto 0 do\r\n begin\r\n ADockClient := FindDockClient(DockClients[I]);\r\n if (ADockClient <> nil) and (ADockClient.LastDockSite is TJvDockPanel) then\r\n ADockClient.RestoreChild;\r\n end;\r\n Exit;\r\n end;\r\n\r\n TmpLastDockSite := LastDockSite;\r\n TmpUnDockLeft := UnDockLeft;\r\n TmpUnDockTop := UnDockTop;\r\n\r\n ResetDockClient(DockClient, nil);\r\n\r\n DoFloatParentForm;\r\n\r\n if TmpLastDockSite is TJvDockPanel then\r\n begin\r\n with TJvDockPanel(TmpLastDockSite) do\r\n begin\r\n if UseDockManager and (JvDockManager <> nil) then\r\n begin\r\n if not JvDockManager.HasZoneWithControl(ParentForm) then\r\n Exit;\r\n DisableAlign;\r\n try\r\n ParentForm.Dock(TmpLastDockSite, Rect(0, 0, 0, 0));\r\n\r\n JvDockManager.ShowControl(ParentForm);\r\n\r\n ParentForm.ActiveControl := nil;\r\n SetDockSite(ParentForm, False);\r\n\r\n if ParentForm.Visible and ParentForm.CanFocus then\r\n ParentForm.SetFocus;\r\n ShowDockPanel(True, ParentForm, sdfDockPanel);\r\n finally\r\n EnableAlign;\r\n end;\r\n end;\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockBasicStyle.SetDockBaseControl(IsCreate: Boolean;\r\n DockBaseControl: TJvDockBaseControl);\r\nbegin\r\nend;\r\n\r\nprocedure TJvDockBasicStyle.ShowDockForm(ADockClient: TJvDockClient);\r\nbegin\r\n if ADockClient <> nil then\r\n begin\r\n ADockClient.ParentForm.Visible := True;\r\n ADockClient.MakeShowEvent;\r\n end;\r\nend;\r\n\r\n//=== { TJvDockClient } ======================================================\r\n\r\nconstructor TJvDockClient.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FParentVisible := ParentForm.Visible;\r\n ParentForm.DragKind := dkDock;\r\n ParentForm.DragMode := dmAutomatic;\r\n ParentForm.UseDockManager := False;\r\n if not (ParentForm is TJvDockableForm) then\r\n SetDockSite(ParentForm, True);\r\n LRDockWidth := 100;\r\n TBDockHeight := 100;\r\n if JvGlobalDockClient = nil then\r\n JvGlobalDockClient := Self;\r\n FDirectDrag := False;\r\n FShowHint := True;\r\n FCanFloat := True;\r\n FDockLevel := 0;\r\n EnableCloseButton := True;\r\nend;\r\n\r\ndestructor TJvDockClient.Destroy;\r\nbegin\r\n if not (ParentForm is TJvDockableForm) then\r\n SetDockSite(ParentForm, False);\r\n ParentForm.DragKind := dkDrag;\r\n ParentForm.DragMode := dmManual;\r\n LastDockSite := nil;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvDockClient.Activate;\r\nbegin\r\n {$IFNDEF COMPILER9_UP}\r\n if ParentForm.HostDockSite is TJvDockCustomPanel then\r\n InvalidateDockHostSiteOfControl(ParentForm, False);\r\n {$ENDIF !COMPILER9_UP}\r\nend;\r\n\r\nprocedure TJvDockClient.AddDockStyle(ADockStyle: TJvDockBasicStyle);\r\nbegin\r\n JvGlobalDockManager.RegisterDockClient(Self);\r\n\r\n if Assigned(ADockStyle) and Assigned(ADockStyle.ConjoinPanelClass) then\r\n FConjoinPanelClass := ADockStyle.ConjoinPanelClass\r\n else\r\n FConjoinPanelClass := DefaultConjoinPanelClass;\r\n\r\n if Assigned(ADockStyle) and Assigned(ADockStyle.TabDockClass) then\r\n FTabDockClass := ADockStyle.TabDockClass\r\n else\r\n FTabDockClass := DefaultTabDockClass;\r\nend;\r\n\r\nprocedure TJvDockClient.Assign(Source: TPersistent);\r\nbegin\r\n if Source is TJvDockClient then\r\n begin\r\n FConjoinPanelClass := TJvDockClient(Source).FConjoinPanelClass;\r\n FTabDockClass := TJvDockClient(Source).FTabDockClass;\r\n ParentVisible := TJvDockClient(Source).ParentVisible;\r\n NCPopupMenu := TJvDockClient(Source).NCPopupMenu;\r\n DirectDrag := TJvDockClient(Source).DirectDrag;\r\n ShowHint := TJvDockClient(Source).ShowHint;\r\n CanFloat := TJvDockClient(Source).CanFloat;\r\n // (rom) either bug or needs comment\r\n FDockLevel := TJvDockClient(Source).DockLevel;\r\n CustomDock := TJvDockClient(Source).CustomDock; {NEW!}\r\n DockStyle := TJvDockClient(Source).DockStyle;\r\n end;\r\n inherited Assign(Source); // Also copy base class properties!\r\nend;\r\n\r\nprocedure TJvDockClient.CMVisibleChanged(var Msg: TMessage);\r\nbegin\r\nend;\r\n\r\nfunction TJvDockClient.CreateConjoinHostAndDockControl(Control1, Control2: TControl;\r\n DockType: TAlign): TJvDockConjoinHostForm;\r\nvar\r\n APanel: TJvDockConjoinPanel;\r\n OldDockWidth, OldDockHeight: Integer;\r\nbegin\r\n Result := TJvDockConjoinHostForm.Create(Application);\r\n\r\n { CreateConjoinPanelClass implicitly sets Result.DockClient.DockStyle via the\r\n assign in that function }\r\n APanel := CreateConjoinPanelClass(Result);\r\n\r\n Result.BoundsRect := Control1.BoundsRect;\r\n\r\n Result.Width := Control1.UndockWidth;\r\n Result.Height := Control1.UndockHeight;\r\n\r\n OldDockWidth := Control1.LRDockWidth;\r\n OldDockHeight := Control1.TBDockHeight;\r\n Control1.ManualDock(APanel, nil, alNone);\r\n Control1.LRDockWidth := OldDockWidth;\r\n Control1.TBDockHeight := OldDockHeight;\r\n\r\n OldDockWidth := Control2.LRDockWidth;\r\n OldDockHeight := Control2.TBDockHeight;\r\n Control2.ManualDock(APanel, nil, DockType);\r\n Control2.LRDockWidth := OldDockWidth;\r\n Control2.TBDockHeight := OldDockHeight;\r\n\r\n SetDockSite(Result, False);\r\nend;\r\n\r\nfunction TJvDockClient.CreateConjoinPanelClass(ConjoinHost: TForm): TJvDockConjoinPanel;\r\nbegin\r\n Result := nil;\r\n TJvDockConjoinHostForm(ConjoinHost).DockClient.Assign(Self);\r\n if (FConjoinPanelClass <> nil) and\r\n (FConjoinPanelClass <> TJvDockConjoinPanelClass(ClassType)) then\r\n begin\r\n Result := FConjoinPanelClass.Create(ConjoinHost);\r\n Result.Align := alClient;\r\n TJvDockConjoinHostForm(ConjoinHost).DockableControl := Result;\r\n TJvDockConjoinHostForm(ConjoinHost).Panel := Result;\r\n SetDockSite(Result, True);\r\n end;\r\nend;\r\n\r\n{ CreateTabDockClass creates a TJvDockTabPageControl subclass. The actual subclass\r\n used is stored in FTabDockClass which is assigned by the Docking Style object,\r\n so this is truly polymorphic.\r\n\r\n We need a TJvDockTabPageControl to do tabbed-docking inside a container form.\r\n The typical container this is placed inside of is either a\r\n TJvDockConjoinHostForm or TJvDockTabHostForm.\r\n}\r\n\r\nfunction TJvDockClient.CreateTabDockClass(TabHost: TForm): TJvDockTabPageControl;\r\nbegin\r\n Result := nil;\r\n { copy properties of the JvTabDockPageControl's DockClient\r\n from the form it contains. }\r\n TJvDockTabHostForm(TabHost).DockClient.Assign(Self);\r\n\r\n// Next line commented out, it seems it is useless. See Mantis 3900.\r\n// Assert(TJvDockTabHostForm(TabHost).DockClient.CustomDock, 'DEBUG HELPER: Not working!');\r\n\r\n if (FTabDockClass <> nil) and (FTabDockClass <> TJvDockTabClass(ClassType)) then\r\n begin\r\n Result := FTabDockClass.Create(TabHost);\r\n Result.Align := alClient;\r\n TJvDockTabHostForm(TabHost).DockableControl := Result;\r\n TJvDockTabHostForm(TabHost).PageControl := Result;\r\n SetDockSite(Result, True);\r\n end;\r\nend;\r\n\r\n{ This is the main function for creating a tabbed dock, given two non-tab-docked\r\n controls (usually these are actually Forms), we create a TJvDockTabHostForm,\r\n and then inside it we create a TabDock container. A TJvDockTabHostForm is\r\n an empty TForm containing a DockClient object, and then it contains a set of\r\n tabbed pages inside the TJvDockTabPageControl object (Page). }\r\n\r\nfunction TJvDockClient.CreateTabHostAndDockControl(Control1, Control2: TControl): TJvDockTabHostForm;\r\nvar\r\n Page: TJvDockTabPageControl;\r\n OldDockWidth, OldDockHeight: Integer;\r\nbegin\r\n Result := TJvDockTabHostForm.Create(Application);\r\n Result.Name := 'TJvDockTabHostForm_' + Control1.Name + '_' + Control2.Name + '_' +\r\n IntToHex(LPARAM(Result), 2 * SizeOf(LPARAM));\r\n\r\n { CreateTabDockClass implicitly sets Result.DockClient.DockStyle via the\r\n assign in that function }\r\n Page := CreateTabDockClass(Result);\r\n Page.Name := Page.ClassName + '_' + Control1.Name + '_' + Control2.Name; // debug!\r\n\r\n Result.BoundsRect := Control1.BoundsRect;\r\n\r\n Result.Width := Control1.UndockWidth;\r\n Result.Height := Control1.UndockHeight;\r\n\r\n OldDockWidth := Control1.LRDockWidth;\r\n OldDockHeight := Control1.TBDockHeight;\r\n Control1.ManualDock(Page, nil, alClient);\r\n Control1.LRDockWidth := OldDockWidth;\r\n Control1.TBDockHeight := OldDockHeight;\r\n\r\n OldDockWidth := Control2.LRDockWidth;\r\n OldDockHeight := Control2.TBDockHeight;\r\n Control2.ManualDock(Page, nil, alClient);\r\n Control2.LRDockWidth := OldDockWidth;\r\n Control2.TBDockHeight := OldDockHeight;\r\n\r\n SetDockSite(Result, False);\r\n //TJvDockTabHostFormCreatedEvent:\r\n if Assigned(FOnTabHostFormCreated) then\r\n FOnTabHostFormCreated(Self, {TabHost:TJvDockTabHostForm} Result);\r\nend;\r\n\r\nprocedure TJvDockClient.Deactivate;\r\nbegin\r\n {$IFNDEF COMPILER9_UP}\r\n if ParentForm.HostDockSite is TJvDockCustomPanel then\r\n InvalidateDockHostSiteOfControl(ParentForm, True);\r\n {$ENDIF !COMPILER9_UP}\r\nend;\r\n\r\nprocedure TJvDockClient.DoFloatDockClients(PanelAlign: TAlign);\r\nbegin\r\n if not (csDestroying in ParentForm.ComponentState) and\r\n (ParentForm.HostDockSite is TJvDockPanel) and\r\n (PanelAlign = ParentForm.HostDockSite.Align) then\r\n RestoreChild;\r\nend;\r\n\r\nprocedure TJvDockClient.DoFloatDockEachOther;\r\nbegin\r\n if not (csDestroying in ParentForm.ComponentState) and\r\n (ParentForm.HostDockSite <> nil) and\r\n (ParentForm.HostDockSite.Parent is TJvDockableForm) then\r\n RestoreChild;\r\nend;\r\n\r\nprocedure TJvDockClient.DoFormOnClose(Sender: TObject; var Action: TCloseAction);\r\nbegin\r\n if Action = caHide then\r\n begin\r\n HideDockForm(ParentForm);\r\n FParentVisible := True;\r\n end;\r\n inherited DoFormOnClose(Sender, Action);\r\nend;\r\n\r\nprocedure TJvDockClient.DoFormShowHint(HTFlag: Integer; var HintStr: string;\r\n var CanShow: Boolean);\r\nbegin\r\n if Assigned(FOnFormShowHint) then\r\n FOnFormShowHint(HTFlag, HintStr, CanShow);\r\nend;\r\n\r\nprocedure TJvDockClient.DoMenuPopup(X, Y: Integer);\r\nbegin\r\n if FNCPopupMenu <> nil then\r\n begin\r\n FNCPopupMenu.PopupComponent := ParentForm;\r\n FNCPopupMenu.Popup(X, Y);\r\n end;\r\nend;\r\n\r\nprocedure TJvDockClient.DoNCButtonDblClk(Msg: TWMNCHitMessage; Button: TMouseButton;\r\n MouseStation: TJvDockMouseStation);\r\nbegin\r\n if Assigned(FOnNCButtonDblClk) then\r\n FOnNCButtonDblClk(Self, Button, Msg.XCursor, Msg.YCursor,\r\n Msg.HitTest, MouseStation);\r\nend;\r\n\r\nprocedure TJvDockClient.DoNCButtonDown(Msg: TWMNCHitMessage;\r\n Button: TMouseButton; MouseStation: TJvDockMouseStation);\r\nbegin\r\n if Assigned(FOnNCButtonDown) then\r\n FOnNCButtonDown(Self, Button, Msg.XCursor, Msg.YCursor,\r\n Msg.HitTest, MouseStation);\r\nend;\r\n\r\nprocedure TJvDockClient.DoNCButtonUp(Msg: TWMNCHitMessage;\r\n Button: TMouseButton; MouseStation: TJvDockMouseStation);\r\nbegin\r\n if Assigned(FOnNCButtonUp) then\r\n FOnNCButtonUp(Self, Button, Msg.XCursor, Msg.YCursor,\r\n Msg.HitTest, MouseStation);\r\n if Button = mbRight then\r\n DoMenuPopup(Msg.XCursor, Msg.YCursor);\r\nend;\r\n\r\nprocedure TJvDockClient.DoNCMouseMove(Msg: TWMNCHitMessage;\r\n MouseStation: TJvDockMouseStation);\r\nbegin\r\n if Assigned(FOnNCMouseMove) then\r\n FOnNCMouseMove(Self, Msg.XCursor, Msg.YCursor,\r\n Msg.HitTest, MouseStation);\r\nend;\r\n\r\nprocedure TJvDockClient.DoPaintDockGrabber(Canvas: TCanvas;\r\n Control: TControl; const ARect: TRect);\r\nbegin\r\n if Assigned(FOnPaintDockGrabber) then\r\n FOnPaintDockGrabber(Canvas, Control, ARect);\r\nend;\r\n\r\nprocedure TJvDockClient.DoPaintDockSplitter(Canvas: TCanvas;\r\n Control: TControl; const ARect: TRect);\r\nbegin\r\n if Assigned(FOnPaintDockSplitter) then\r\n FOnPaintDockSplitter(Canvas, Control, ARect);\r\nend;\r\n\r\n// return nil if not found, otherwise, get currently docked parent tabhost form if there is one.\r\n\r\nfunction TJvDockClient.FindTabHostForm: TForm;\r\nvar\r\n OwnerWin: TWinControl;\r\n TabSheet: TJvDockTabSheet;\r\n CheckForm: TComponent;\r\nbegin\r\n Result := nil;\r\n if not Assigned(Owner) or not (Owner is TWinControl) then\r\n Exit;\r\n OwnerWin := TWinControl(Owner);\r\n if Self.DockState <> JvDockState_Docking then\r\n Exit;\r\n if not Assigned(OwnerWin.Parent) then\r\n Exit;\r\n if OwnerWin.Parent is TJvDockTabSheet then\r\n begin\r\n TabSheet := TJvDockTabSheet(OwnerWin.Parent);\r\n if TabSheet.Owner is TJvDockPageControl then\r\n begin\r\n CheckForm := TJvDockPageControl(TabSheet.Owner).Owner;\r\n if CheckForm is TJvDockTabHostForm then\r\n Result := TForm(CheckForm);\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockClient.FormDockDrop(Source: TJvDockDragDockObject;\r\n X, Y: Integer);\r\nbegin\r\n if Assigned(DockStyle) then\r\n DockStyle.FormDockDrop(Self, Source, X, Y);\r\nend;\r\n\r\nprocedure TJvDockClient.FormDockOver(Source: TJvDockDragDockObject;\r\n X, Y: Integer; State: TDragState; var Accept: Boolean);\r\nbegin\r\n FormPositionDockRect(Source);\r\n if Assigned(DockStyle) then\r\n DockStyle.FormDockOver(Self, Source, X, Y, State, Accept);\r\nend;\r\n\r\nprocedure TJvDockClient.FormEndDock(Target: TObject; X, Y: Integer);\r\nbegin\r\n if Assigned(DockStyle) then\r\n DockStyle.FormEndDock(Self, Target, X, Y);\r\nend;\r\n\r\nprocedure TJvDockClient.FormGetDockEdge(Source: TJvDockDragDockObject;\r\n MousePos: TPoint; var DropAlign: TAlign);\r\nbegin\r\n if Assigned(DockStyle) then\r\n DockStyle.FormGetDockEdge(Self, Source, MousePos, DropAlign)\r\n else\r\n DropAlign := alNone;\r\nend;\r\n\r\nprocedure TJvDockClient.FormGetSiteInfo(Source: TJvDockDragDockObject; Client: TControl;\r\n var InfluenceRect: TRect; MousePos: TPoint; var CanDock: Boolean);\r\nbegin\r\n GetWindowRect(ParentForm.Handle, InfluenceRect);\r\n InflateRect(InfluenceRect, -4, -4);\r\n if Assigned(DockStyle) then\r\n DockStyle.FormGetSiteInfo(Source, Self, Client, InfluenceRect, MousePos, CanDock);\r\nend;\r\n\r\nprocedure TJvDockClient.FormPositionDockRect(Source: TJvDockDragDockObject);\r\nbegin\r\n if Assigned(DockStyle) then\r\n DockStyle.FormPositionDockRect(Self, Source);\r\nend;\r\n\r\nprocedure TJvDockClient.FormStartDock(var Source: TJvDockDragDockObject);\r\nbegin\r\n if Assigned(DockStyle) then\r\n DockStyle.FormStartDock(Self, Source);\r\nend;\r\n\r\nfunction TJvDockClient.FormUnDock(NewTarget: TWinControl;\r\n Client: TControl): Boolean;\r\nbegin\r\n if Assigned(DockStyle) then\r\n Result := DockStyle.FormUnDock(Self, NewTarget, Client)\r\n else\r\n Result := False;\r\nend;\r\n\r\nfunction TJvDockClient.GetDockState: Integer;\r\nbegin\r\n Result := JvDockState_Unknown;\r\n if DockStyle <> nil then\r\n Result := DockStyle.GetDockState(Self);\r\nend;\r\n\r\nfunction TJvDockClient.GetLRDockWidth: Integer;\r\nbegin\r\n Result := ParentForm.LRDockWidth;\r\nend;\r\n\r\nfunction TJvDockClient.GetTBDockHeight: Integer;\r\nbegin\r\n Result := ParentForm.TBDockHeight;\r\nend;\r\n\r\nprocedure TJvDockClient.HideParentForm;\r\nbegin\r\n HideDockForm(ParentForm);\r\nend;\r\n\r\nprocedure TJvDockClient.MakeHideEvent;\r\nbegin\r\n ParentVisible := False;\r\n if Assigned(FOnFormHide) then\r\n FOnFormHide(Self);\r\nend;\r\n\r\nprocedure TJvDockClient.MakeShowEvent;\r\nbegin\r\n if ParentForm.Visible then\r\n begin\r\n if Assigned(FOnFormShow) then\r\n FOnFormShow(Self);\r\n ParentVisible := True;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockClient.Notification(AComponent: TComponent;\r\n Operation: TOperation);\r\nbegin\r\n inherited Notification(AComponent, Operation);\r\n if Operation = opRemove then\r\n begin\r\n if AComponent = FLastDockSite then\r\n LastDockSite := nil\r\n else\r\n if AComponent = NCPopupMenu then\r\n NCPopupMenu := nil;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockClient.RemoveDockStyle(ADockStyle: TJvDockBasicStyle);\r\nbegin\r\n DoFloatDockClients(alTop);\r\n DoFloatDockClients(alBottom);\r\n DoFloatDockClients(alLeft);\r\n DoFloatDockClients(alRight);\r\n DoFloatDockEachOther;\r\n\r\n FConjoinPanelClass := nil;\r\n FTabDockClass := nil;\r\n\r\n if JvGlobalDockManager <> nil then\r\n JvGlobalDockManager.UnRegisterDockClient(Self);\r\nend;\r\n\r\nprocedure TJvDockClient.RestoreChild;\r\nbegin\r\n DockStyle.RestoreClient(Self);\r\nend;\r\n\r\nprocedure TJvDockClient.SetBottomDock(const Value: Boolean);\r\nbegin\r\n if not Value then\r\n DoFloatDockClients(alBottom);\r\n inherited SetBottomDock(Value);\r\nend;\r\n\r\nprocedure TJvDockClient.SetCanFloat(const Value: Boolean);\r\nbegin\r\n FCanFloat := Value;\r\nend;\r\n\r\nprocedure TJvDockClient.SetCurrentDockSite(const Value: TWinControl);\r\nbegin\r\n FCurrentDockSite := Value;\r\nend;\r\n\r\nprocedure TJvDockClient.SetDockLevel(const Value: Integer);\r\nbegin\r\n if not ParentForm.Floating then\r\n if FDockLevel <> Value then\r\n DoFloatForm(ParentForm);\r\n FDockLevel := Value;\r\nend;\r\n\r\nprocedure TJvDockClient.SetEachOtherDock(const Value: Boolean);\r\nbegin\r\n if not Value then\r\n DoFloatDockEachOther;\r\n inherited SetEachOtherDock(Value);\r\nend;\r\n\r\nprocedure TJvDockClient.SetEnableCloseButton(const Value: Boolean);\r\nbegin\r\n FEnableCloseButton := Value;\r\nend;\r\n\r\nprocedure TJvDockClient.SetEnableDock(const Value: Boolean);\r\nbegin\r\n if not Value then\r\n begin\r\n DoFloatDockClients(alTop);\r\n DoFloatDockClients(alBottom);\r\n DoFloatDockClients(alLeft);\r\n DoFloatDockClients(alRight);\r\n DoFloatDockEachOther;\r\n end;\r\n if ParentForm <> nil then\r\n if Value then\r\n ParentForm.DragKind := dkDock\r\n else\r\n ParentForm.DragKind := dkDrag;\r\n inherited SetEnableDock(Value);\r\nend;\r\n\r\nprocedure TJvDockClient.SetLastDockSite(ALastDockSite: TWinControl);\r\nvar\r\n JvDockManager: IJvDockManager;\r\nbegin\r\n if ALastDockSite <> FLastDockSite then\r\n begin\r\n if FLastDockSite <> nil then\r\n begin\r\n if TWinControlAccessProtected(FLastDockSite).UseDockManager and\r\n Supports(TWinControlAccessProtected(FLastDockSite).DockManager, IJvDockManager, JvDockManager) then\r\n JvDockManager.RemoveControl(Self.ParentForm);\r\n end;\r\n ReplaceComponentReference(Self, ALastDockSite, TComponent(FLastDockSite));\r\n end;\r\nend;\r\n\r\nprocedure TJvDockClient.SetLeftDock(const Value: Boolean);\r\nbegin\r\n if not Value then\r\n DoFloatDockClients(alLeft);\r\n inherited SetLeftDock(Value);\r\nend;\r\n\r\nprocedure TJvDockClient.SetLRDockWidth(const Value: Integer);\r\nbegin\r\n if ParentForm.LRDockWidth <> Value then\r\n ParentForm.LRDockWidth := Value;\r\nend;\r\n\r\nprocedure TJvDockClient.SetNCPopupMenu(Value: TPopupMenu);\r\nbegin\r\n ReplaceComponentReference(Self, Value, TComponent(FNCPopupMenu));\r\nend;\r\n\r\nprocedure TJvDockClient.SetParentVisible(const Value: Boolean);\r\nbegin\r\n FParentVisible := Value;\r\nend;\r\n\r\nprocedure TJvDockClient.SetRightDock(const Value: Boolean);\r\nbegin\r\n if not Value then\r\n DoFloatDockClients(alRight);\r\n inherited SetRightDock(Value);\r\nend;\r\n\r\nprocedure TJvDockClient.SetTBDockHeight(const Value: Integer);\r\nbegin\r\n if ParentForm.TBDockHeight <> Value then\r\n ParentForm.TBDockHeight := Value;\r\nend;\r\n\r\nprocedure TJvDockClient.SetTopDock(const Value: Boolean);\r\nbegin\r\n if not Value then\r\n DoFloatDockClients(alTop);\r\n inherited SetTopDock(Value);\r\nend;\r\n\r\nprocedure TJvDockClient.SetUnDockLeft(const Value: Integer);\r\nbegin\r\n FUnDockLeft := Value;\r\nend;\r\n\r\nprocedure TJvDockClient.SetUnDockTop(const Value: Integer);\r\nbegin\r\n FUnDockTop := Value;\r\nend;\r\n\r\nprocedure TJvDockClient.SetVSPaneWidth(const Value: Integer);\r\nbegin\r\n FVSPaneWidth := Value;\r\nend;\r\n\r\nprocedure TJvDockClient.ShowParentForm;\r\nbegin\r\n ShowDockForm(ParentForm);\r\nend;\r\n\r\nprocedure TJvDockClient.WindowProc(var Msg: TMessage);\r\nvar\r\n OldOrient: TDockOrientation;\r\nbegin\r\n if Assigned(FDockStyle) then\r\n if FDockStyle.DockClientWindowProc(Self, Msg) then\r\n Exit;\r\n if not (csDesigning in ComponentState) then\r\n begin\r\n case Msg.Msg of\r\n CM_SHOWINGCHANGED:\r\n if IsWinXP_UP and JvGlobalDockIsLoading then\r\n begin\r\n if GShowingChanged = nil then\r\n GShowingChanged := TList.Create;\r\n GShowingChanged.Add(ParentForm);\r\n Exit;\r\n end;\r\n WM_NCLBUTTONDOWN:\r\n begin\r\n WMNCLButtonDown(TWMNCHitMessage(Msg));\r\n if Msg.Result = 1 then\r\n Exit;\r\n end;\r\n WM_NCLBUTTONUP:\r\n WMNCLButtonUp(TWMNCHitMessage(Msg));\r\n WM_NCLBUTTONDBLCLK:\r\n WMNCLButtonDblClk(TWMNCHitMessage(Msg));\r\n WM_NCMBUTTONDOWN:\r\n WMNCMButtonDown(TWMNCHitMessage(Msg));\r\n WM_NCMBUTTONUP:\r\n WMNCMButtonUp(TWMNCHitMessage(Msg));\r\n WM_NCMBUTTONDBLCLK:\r\n WMNCMButtonDblClk(TWMNCHitMessage(Msg));\r\n WM_NCRBUTTONDOWN:\r\n begin\r\n WMNCRButtonDown(TWMNCHitMessage(Msg));\r\n if FNCPopupMenu <> nil then\r\n Exit;\r\n end;\r\n WM_NCRBUTTONUP:\r\n WMNCRButtonUp(TWMNCHitMessage(Msg));\r\n WM_NCRBUTTONDBLCLK:\r\n WMNCRButtonDblClk(TWMNCHitMessage(Msg));\r\n WM_NCMOUSEMOVE:\r\n WMNCMouseMove(TWMNCHitMessage(Msg));\r\n WM_SIZE:\r\n WMSize(TWMSize(Msg));\r\n WM_ACTIVATE:\r\n WMActivate(TWMActivate(Msg));\r\n WM_WINDOWPOSCHANGED:\r\n begin\r\n ParentForm.ControlState := ParentForm.ControlState + [csDocking];\r\n OldOrient := ParentForm.DockOrientation;\r\n ParentForm.DockOrientation := doNoOrient;\r\n try\r\n inherited WindowProc(Msg);\r\n finally\r\n ParentForm.ControlState := ParentForm.ControlState - [csDocking];\r\n ParentForm.DockOrientation := OldOrient;\r\n end;\r\n Exit;\r\n end;\r\n CM_ENTER:\r\n Activate;\r\n CM_EXIT:\r\n Deactivate;\r\n CM_VISIBLECHANGED:\r\n CMVisibleChanged(Msg);\r\n end;\r\n end;\r\n\r\n inherited WindowProc(Msg);\r\n\r\n if Msg.Msg = WM_SETTEXT then\r\n if ParentForm.HostDockSite is TJvDockCustomControl then\r\n TJvDockCustomControl(ParentForm.HostDockSite).UpdateCaption(ParentForm);\r\nend;\r\n\r\nprocedure TJvDockClient.WMActivate(var Msg: TWMActivate);\r\nbegin\r\n {$IFNDEF COMPILER9_UP}\r\n InvalidateDockHostSiteOfControl(ParentForm.ActiveControl, Msg.Active = WA_INACTIVE);\r\n {$ENDIF !COMPILER9_UP}\r\nend;\r\n\r\nprocedure TJvDockClient.WMNCLButtonDblClk(var Msg: TWMNCHitMessage);\r\nbegin\r\n DoNCButtonDblClk(Msg, mbLeft, msFloat);\r\nend;\r\n\r\nprocedure TJvDockClient.WMNCLButtonDown(var Msg: TWMNCHitMessage);\r\nbegin\r\n DoNCButtonDown(Msg, mbLeft, msFloat);\r\n\r\n JvGlobalDockClient := Self;\r\n\r\n if (Msg.HitTest = HTCAPTION) and (ParentForm.DragKind = dkDock) and not\r\n (csDesigning in ComponentState) and not IsIconic(ParentForm.Handle) then\r\n begin\r\n SetWindowPos(ParentForm.Handle, 0, 0, 0, 0, 0, SWP_NOZORDER or SWP_NOMOVE or SWP_NOSIZE);\r\n PostMessage(ParentForm.Handle, WM_NCLBUTTONUP, TMessage(Msg).WParam, TMessage(Msg).LParam);\r\n if ParentForm.Active then\r\n JvGlobalDockManager.BeginDrag(ParentForm, DirectDrag, Integer(DirectDrag) * 2 - 1);\r\n Msg.Result := 1;\r\n end\r\n else\r\n Msg.Result := 0;\r\nend;\r\n\r\nprocedure TJvDockClient.WMNCLButtonUp(var Msg: TWMNCHitMessage);\r\nbegin\r\n DoNCButtonUp(Msg, mbLeft, msFloat);\r\nend;\r\n\r\nprocedure TJvDockClient.WMNCMButtonDblClk(var Msg: TWMNCHitMessage);\r\nbegin\r\n DoNCButtonDblClk(Msg, mbMiddle, msFloat);\r\nend;\r\n\r\nprocedure TJvDockClient.WMNCMButtonDown(var Msg: TWMNCHitMessage);\r\nbegin\r\n DoNCButtonDown(Msg, mbMiddle, msFloat);\r\nend;\r\n\r\nprocedure TJvDockClient.WMNCMButtonUp(var Msg: TWMNCHitMessage);\r\nbegin\r\n DoNCButtonUp(Msg, mbMiddle, msFloat);\r\nend;\r\n\r\nprocedure TJvDockClient.WMNCMouseMove(var Msg: TWMNCHitMessage);\r\nbegin\r\n DoNCMouseMove(Msg, msFloat);\r\nend;\r\n\r\nprocedure TJvDockClient.WMNCRButtonDblClk(var Msg: TWMNCHitMessage);\r\nbegin\r\n DoNCButtonDblClk(Msg, mbRight, msFloat);\r\nend;\r\n\r\nprocedure TJvDockClient.WMNCRButtonDown(var Msg: TWMNCHitMessage);\r\nbegin\r\n DoNCButtonDown(Msg, mbRight, msFloat);\r\nend;\r\n\r\nprocedure TJvDockClient.WMNCRButtonUp(var Msg: TWMNCHitMessage);\r\nbegin\r\n DoNCButtonUp(Msg, mbRight, msFloat);\r\nend;\r\n\r\nprocedure TJvDockClient.WMSize(var Msg: TWMSize);\r\nbegin\r\n inherited;\r\nend;\r\n\r\n//=== { TJvDockConjoinHostForm } =============================================\r\n\r\nconstructor TJvDockConjoinHostForm.Create(AOwner: TComponent);\r\nbegin\r\n {$IFDEF JVDOCK_DEBUG}\r\n OutputDebugString('TJvDockConjoinHostForm.Create');\r\n {$ENDIF JVDOCK_DEBUG}\r\n inherited Create(AOwner);\r\n BorderStyle := ConjoinDockHostBorderStyle;\r\nend;\r\n\r\nprocedure TJvDockConjoinHostForm.DoClose(var Action: TCloseAction);\r\nbegin\r\n inherited DoClose(Action);\r\nend;\r\n\r\n//=== { TJvDockConjoinPanel } ================================================\r\n\r\nconstructor TJvDockConjoinPanel.Create(AOwner: TComponent);\r\nbegin\r\n {$IFDEF JVDOCK_DEBUG}\r\n OutputDebugString('TJvDockConjoinPanel.Create');\r\n {$ENDIF JVDOCK_DEBUG}\r\n inherited Create(AOwner);\r\n Parent := TWinControl(AOwner);\r\n Align := alClient;\r\n BevelOuter := bvNone;\r\n DoubleBuffered := True;\r\n ParentFont := False;\r\n Caption := '';\r\nend;\r\n\r\nprocedure TJvDockConjoinPanel.CMUnDockClient(var Msg: TCMUnDockClient);\r\nbegin\r\n inherited;\r\n { Panel can be closed when\r\n * DockClientCount <= 1:\r\n One hidden form left that is freed. Call originates from TControl.Destroy\r\n * DockClientCount=2 and VisibleDockClientCount=1\r\n Two forms left, one is freed. Call originates from TControl.Destroy or\r\n TJvDockManager.DoUnDock etc.\r\n }\r\n if (DockClientCount <= 1) or ((DockClientCount = 2) and (VisibleDockClientCount = 1)) then\r\n PostMessage(ParentForm.Handle, WM_CLOSE, 0, 0);\r\n if VisibleDockClientCount <= 2 then\r\n JvDockControlForm.UpdateCaption(Self, Msg.Client);\r\n if UseDockManager and (JvDockManager <> nil) then\r\n JvDockManager.ResetBounds(True);\r\nend;\r\n\r\nprocedure TJvDockConjoinPanel.CustomDockDrop(Source: TJvDockDragDockObject;\r\n X, Y: Integer);\r\nbegin\r\n inherited CustomDockDrop(Source, X, Y);\r\n if Source.Control is TForm then\r\n begin\r\n ParentForm.ActiveControl := nil;\r\n if TForm(Source.Control).FormStyle = fsStayOnTop then\r\n TForm(Parent).FormStyle := fsStayOnTop;\r\n end;\r\n UpdateCaption(nil);\r\nend;\r\n\r\nprocedure TJvDockConjoinPanel.CustomDockOver(Source: TJvDockDragDockObject;\r\n X, Y: Integer; State: TDragState; var Accept: Boolean);\r\nbegin\r\n inherited CustomDockOver(Source, X, Y, State, Accept);\r\n Accept := IsDockable(Self, Source.Control, Source.DropOnControl, Source.DropAlign);\r\nend;\r\n\r\nprocedure TJvDockConjoinPanel.CustomEndDock(Target: TObject; X, Y: Integer);\r\nbegin\r\n inherited CustomEndDock(Target, X, Y);\r\nend;\r\n\r\nprocedure TJvDockConjoinPanel.CustomGetSiteInfo(Source: TJvDockDragDockObject;\r\n Client: TControl; var InfluenceRect: TRect; MousePos: TPoint; var CanDock: Boolean);\r\nbegin\r\n CanDock := IsDockable(Self, Client, Source.DropOnControl, Source.DropAlign);\r\n inherited CustomGetSiteInfo(Source, Client, InfluenceRect, MousePos, CanDock);\r\nend;\r\n\r\nprocedure TJvDockConjoinPanel.CustomPositionDockRect(Source: TJvDockDragDockObject;\r\n X, Y: Integer);\r\nbegin\r\n inherited CustomPositionDockRect(Source, X, Y);\r\nend;\r\n\r\nprocedure TJvDockConjoinPanel.CustomStartDock(var Source: TJvDockDragDockObject);\r\nbegin\r\n ParentForm.FUnDockControl := nil;\r\n inherited CustomStartDock(Source);\r\nend;\r\n\r\nfunction TJvDockConjoinPanel.CustomUnDock(Source: TJvDockDragDockObject;\r\n NewTarget: TWinControl; Client: TControl): Boolean;\r\nbegin\r\n ParentForm.FUnDockControl := Client;\r\n\r\n if not (Client is TJvDockableForm) then\r\n SetDockSite(TForm(Client), True);\r\n if ((VisibleDockClientCount = 1) or\r\n (DockClientCount <= 2)) and (NewTarget <> ParentForm.DockableControl) then\r\n PostMessage(Parent.Handle, WM_CLOSE, 0, 0);\r\n UpdateCaption(Client);\r\n Result := inherited CustomUnDock(Source, NewTarget, Client);\r\nend;\r\n\r\nprocedure TJvDockConjoinPanel.DockDrop(Source: TDragDockObject; X, Y: Integer);\r\nbegin\r\n if Perform(CM_DOCKCLIENT, WPARAM(Source), {$IFDEF RTL230_UP}PointToLParam{$ELSE}LPARAM{$ENDIF RTL230_UP}(SmallPoint(X, Y))) >= 0 then\r\n begin\r\n if Source.Control is TForm then\r\n begin\r\n ParentForm.ActiveControl := nil;\r\n TForm(Source.Control).ActiveControl := nil;\r\n\r\n SetDockSite(TForm(Source.Control), False);\r\n if TForm(Source.Control).FormStyle = fsStayOnTop then\r\n TForm(Parent).FormStyle := fsStayOnTop;\r\n end;\r\n UpdateCaption(nil);\r\n end;\r\nend;\r\n\r\nprocedure TJvDockConjoinPanel.DoDockOver(Source: TDragDockObject;\r\n X, Y: Integer; State: TDragState; var Accept: Boolean);\r\nbegin\r\n Accept := IsDockable(Self, Source.Control, Source.DropOnControl, Source.DropAlign);\r\nend;\r\n\r\nfunction TJvDockConjoinPanel.DoUnDock(NewTarget: TWinControl;\r\n Client: TControl): Boolean;\r\nbegin\r\n ParentForm.FUnDockControl := Client;\r\n\r\n if not (Client is TJvDockableForm) then\r\n SetDockSite(TForm(Client), True);\r\n if (VisibleDockClientCount = 1) or\r\n (DockClientCount <= 2) then\r\n { It's possible that 2 WM_CLOSE are send to the parent form }\r\n PostMessage(Parent.Handle, WM_CLOSE, 0, 0);\r\n UpdateCaption(Client);\r\n Result := Perform(CM_UNDOCKCLIENT, WPARAM(NewTarget), LPARAM(Client)) = 0;\r\nend;\r\n\r\nfunction TJvDockConjoinPanel.GetDockClient: TJvDockClient;\r\nbegin\r\n if Assigned(ParentForm) then\r\n Result := ParentForm.FDockClient\r\n else\r\n Result := nil;\r\nend;\r\n\r\nfunction TJvDockConjoinPanel.GetParentForm: TJvDockConjoinHostForm;\r\nbegin\r\n { Dirty }\r\n Result := TJvDockConjoinHostForm(Parent);\r\nend;\r\n\r\nprocedure TJvDockConjoinPanel.GetSiteInfo(Client: TControl;\r\n var InfluenceRect: TRect; MousePos: TPoint; var CanDock: Boolean);\r\nbegin\r\n CanDock := IsDockable(Self, Client);\r\n if CanDock then\r\n GetWindowRect(Handle, InfluenceRect);\r\nend;\r\n\r\nprocedure TJvDockConjoinPanel.ReloadDockedControl(const AControlName: string;\r\n var AControl: TControl);\r\nbegin\r\n AControl := JvDockFindDockFormWithName(AControlName);\r\nend;\r\n\r\nfunction TJvDockConjoinPanel.CreateDockManager: IDockManager;\r\nvar\r\n TreeClass: TJvDockTreeClass;\r\n ADockStyle: TJvDockBasicStyle;\r\nbegin\r\n Result := nil;\r\n\r\n if (DockManager = nil) and DockSite and UseDockManager then\r\n begin\r\n if Assigned(DockClient) then\r\n begin\r\n ADockStyle := DockClient.DockStyle;\r\n if Assigned(ADockStyle) then\r\n begin\r\n TreeClass := ADockStyle.ConjoinPanelTreeClass;\r\n if Assigned(TreeClass) and (TreeClass <> TJvDockTree) then\r\n Result := TreeClass.Create(Self, ADockStyle.ConjoinPanelZoneClass, ADockStyle) as IJvDockManager;\r\n end;\r\n end;\r\n end;\r\n if Result = nil then\r\n Result := DockManager;\r\n DoubleBuffered := DoubleBuffered or (Result <> nil);\r\nend;\r\n\r\n//=== { TJvDockPanel } =======================================================\r\n\r\nconstructor TJvDockPanel.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n DoubleBuffered := True;\r\n BevelOuter := bvNone;\r\n Width := 10;\r\n Height := 10;\r\nend;\r\n\r\nprocedure TJvDockPanel.AddDockServer(ADockServer: TJvDockServer);\r\nbegin\r\n { Notification }\r\nend;\r\n\r\nprocedure TJvDockPanel.CustomDockDrop(Source: TJvDockDragDockObject;\r\n X, Y: Integer);\r\nbegin\r\n inherited CustomDockDrop(Source, X, Y);\r\n\r\n if Source.Control <> nil then\r\n ShowDockPanel(True, Source.Control);\r\n\r\n if Source.Control is TForm then begin\r\n if Assigned(TForm(Source.Control).OnEndDock) then\r\n TForm(Source.Control).OnEndDock( Self, Source.TargetControl, X,Y);\r\n\r\n end;\r\n\r\nend;\r\n\r\nprocedure TJvDockPanel.CustomDockOver(Source: TJvDockDragDockObject;\r\n X, Y: Integer; State: TDragState; var Accept: Boolean);\r\nbegin\r\n Accept := IsDockable(Self, Source.Control, Source.DropOnControl, Source.DropAlign);\r\n if Accept then\r\n inherited CustomDockOver(Source, X, Y, State, Accept);\r\nend;\r\n\r\nprocedure TJvDockPanel.CustomEndDock(Target: TObject; X, Y: Integer);\r\nbegin\r\n inherited CustomEndDock(Target, X, Y);\r\nend;\r\n\r\nprocedure TJvDockPanel.CustomGetSiteInfo(Source: TJvDockDragDockObject; Client: TControl;\r\n var InfluenceRect: TRect; MousePos: TPoint; var CanDock: Boolean);\r\nbegin\r\n inherited CustomGetSiteInfo(Source, Client, InfluenceRect, MousePos, CanDock);\r\n CanDock := IsDockable(Self, Client, Source.DropOnControl, Source.DropAlign);\r\nend;\r\n\r\nprocedure TJvDockPanel.CustomPositionDockRect(Source: TJvDockDragDockObject; X, Y: Integer);\r\nvar\r\n ARect: TRect;\r\nbegin\r\n inherited CustomPositionDockRect(Source, X, Y);\r\n if (VisibleDockClientCount = 0) and (JvGlobalDockClient <> nil) then\r\n begin\r\n case Align of\r\n alTop:\r\n begin\r\n ARect.TopLeft := ClientToScreen(Point(0, 0));\r\n ARect.BottomRight := ClientToScreen(Point(Width, Source.Control.TBDockHeight));\r\n end;\r\n alBottom:\r\n begin\r\n ARect.TopLeft := ClientToScreen(Point(0, -Source.Control.TBDockHeight));\r\n ARect.BottomRight := ClientToScreen(Point(Width, 0));\r\n end;\r\n alLeft:\r\n begin\r\n ARect.TopLeft := ClientToScreen(Point(0, 0));\r\n ARect.BottomRight := ClientToScreen(Point(Source.Control.LRDockWidth, Height));\r\n end;\r\n alRight:\r\n begin\r\n ARect.TopLeft := ClientToScreen(Point(-Source.Control.LRDockWidth, 0));\r\n ARect.BottomRight := ClientToScreen(Point(Width, Height));\r\n end;\r\n alClient:\r\n begin\r\n ARect.TopLeft := ClientToScreen(Point(0, 0));\r\n ARect.BottomRight := ClientToScreen(Point(Width, Height));\r\n end;\r\n end;\r\n Source.DockRect := ARect;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockPanel.CustomStartDock(var Source: TJvDockDragDockObject);\r\nbegin\r\n inherited CustomStartDock(Source);\r\nend;\r\n\r\nfunction TJvDockPanel.CustomUnDock(Source: TJvDockDragDockObject; NewTarget: TWinControl;\r\n Client: TControl): Boolean;\r\nbegin\r\n ShowDockPanel(False, nil);\r\n Result := inherited CustomUnDock(Source, NewTarget, Client);\r\n if not (Client is TJvDockableForm) and (Client is TWinControl) then\r\n SetDockSite(TWinControl(Client), True);\r\nend;\r\n\r\nprocedure TJvDockPanel.DockDrop(Source: TDragDockObject; X, Y: Integer);\r\nbegin\r\n if Perform(CM_DOCKCLIENT, WPARAM(Source), {$IFDEF RTL230_UP}PointToLParam{$ELSE}LPARAM{$ENDIF RTL230_UP}(SmallPoint(X, Y))) >= 0 then\r\n begin\r\n if Source.Control is TForm then\r\n begin\r\n TForm(Source.Control).ActiveControl := nil;\r\n SetDockSite(TForm(Source.Control), False);\r\n end;\r\n UpdateCaption(nil);\r\n end;\r\n ShowDockPanel(TWinControl(Source.DragTarget).VisibleDockClientCount > 0, Source.Control);\r\nend;\r\n\r\nfunction TJvDockPanel.DoUnDock(NewTarget: TWinControl; Client: TControl): Boolean;\r\nbegin\r\n Result := IsDockable(Self, Client);\r\n ShowDockPanel(False, nil);\r\n Result := Result and (Perform(CM_UNDOCKCLIENT, WPARAM(NewTarget), LPARAM(Client)) = 0);\r\n if Result then\r\n if not (Client is TJvDockableForm) then\r\n SetDockSite(TForm(Client), True);\r\nend;\r\n\r\nprocedure TJvDockPanel.GetDockedControls(WinControls: TList);\r\nbegin\r\n // THE BASE CLASS DOESN'T SUPPORT THIS. JUST RETURN QUIETLY.\r\n // See TJvDockAdvPanel.GetDockedControls for the actual implementation.\r\nend;\r\n\r\nfunction TJvDockPanel.FindTabHostForm:TWinControl;\r\nbegin\r\n\t// base class does not support this. This version just returns nil.\r\n\tresult := nil;\r\nend;\r\n\r\n\r\nfunction TJvDockPanel.GetPanelIndex: Integer;\r\nbegin\r\n case Align of\r\n alTop:\r\n Result := 0;\r\n alBottom:\r\n Result := 1;\r\n alLeft:\r\n Result := 2;\r\n alRight:\r\n Result := 3;\r\n else\r\n if FCustomFlag then\r\n Result := 4 {NEW!}\r\n else\r\n Result := -1; {unknown.}\r\n end;\r\nend;\r\n\r\nprocedure TJvDockPanel.ReloadDockedControl(const AControlName: string;\r\n var AControl: TControl);\r\nbegin\r\n AControl := JvDockFindDockFormWithName(AControlName);\r\nend;\r\n\r\nprocedure TJvDockPanel.RemoveDockServer(ADockServer: TJvDockServer);\r\nbegin\r\n { Notification }\r\nend;\r\n\r\nprocedure TJvDockPanel.ResetPosition;\r\nbegin\r\n case Align of\r\n alLeft:\r\n Left := GetClientAlignControlArea(Parent, Align) + 1;\r\n alRight:\r\n Left := Parent.ClientWidth - GetClientAlignControlArea(Parent, Align) - Width - 1;\r\n alTop:\r\n Top := GetClientAlignControlArea(Parent, Align) + 1;\r\n alBottom:\r\n Top := Parent.ClientHeight - GetClientAlignControlArea(Parent, Align) - Height - 1;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockPanel.SetDockServer(ADockServer: TJvDockServer);\r\nbegin\r\n if ADockServer <> FDockServer then\r\n begin\r\n if FDockServer <> nil then\r\n RemoveDockServer(FDockServer);\r\n\r\n FDockServer := ADockServer;\r\n\r\n if FDockServer <> nil then\r\n AddDockServer(FDockServer);\r\n end;\r\nend;\r\n\r\nprocedure TJvDockPanel.ShowDockPanel(MakeVisible: Boolean;\r\n Client: TControl; PanelSizeFrom: TJvDockSetDockPanelSizeFrom);\r\nconst\r\n DefaultDockSize = 100;\r\nvar\r\n DockHeight, DockWidth: Integer;\r\nbegin\r\n if (not MakeVisible and (VisibleDockClientCount > 1)) or\r\n (JvGlobalDockClient = nil) then\r\n Exit;\r\n\r\n if Assigned(DockServer.DockSplitterWithAlign[Align]) then\r\n DockServer.DockSplitterWithAlign[Align].Visible := MakeVisible;\r\n\r\n if MakeVisible and (Client <> nil) then\r\n begin\r\n if Width * Height = 0 then\r\n begin\r\n if (PanelSizeFrom = sdfDockPanel) or (Client = nil) then\r\n begin\r\n DockHeight := TBDockHeight;\r\n DockWidth := LRDockWidth;\r\n end\r\n else\r\n begin\r\n DockHeight := Client.TBDockHeight;\r\n DockWidth := Client.LRDockWidth;\r\n end;\r\n\r\n if DockHeight = 0 then\r\n DockHeight := DefaultDockSize;\r\n if DockWidth = 0 then\r\n DockWidth := DefaultDockSize;\r\n\r\n Parent.DisableAlign;\r\n try\r\n case Align of\r\n alTop:\r\n begin\r\n Top := DockServer.GetClientAlignControl(alTop);\r\n Height := DockHeight;\r\n DockServer.TopSplitter.Top := Top + Height;\r\n end;\r\n alBottom:\r\n begin\r\n Top := Parent.ClientHeight - DockServer.GetClientAlignControl(alBottom) - DockHeight + 1;\r\n Height := DockHeight;\r\n DockServer.BottomSplitter.Top := Top + DockServer.BottomSplitter.Height;\r\n end;\r\n alLeft:\r\n begin\r\n Left := DockServer.GetClientAlignControl(alLeft);\r\n Width := DockWidth;\r\n DockServer.LeftSplitter.Left := Left + Width;\r\n end;\r\n alRight:\r\n begin\r\n Width := DockWidth;\r\n Left := Parent.ClientWidth - DockServer.GetClientAlignControl(alRight) - DockWidth + 1;\r\n DockServer.RightSplitter.Left := Left - DockServer.RightSplitter.Width;\r\n end;\r\n end;\r\n finally\r\n Parent.EnableAlign;\r\n if UseDockManager and (JvDockManager <> nil) then\r\n JvDockManager.ResetBounds(True);\r\n end;\r\n DockServer.DoFinishSetDockPanelSize(Self);\r\n end;\r\n end\r\n else\r\n begin\r\n if (PanelSizeFrom = sdfDockPanel) or (Client = nil) then\r\n begin\r\n if Height > 0 then\r\n TBDockHeight := Height;\r\n if Width > 0 then\r\n LRDockWidth := Width;\r\n end\r\n else\r\n begin\r\n if Height > 0 then\r\n Client.TBDockHeight := Height;\r\n if Width > 0 then\r\n Client.LRDockWidth := Width;\r\n end;\r\n if Align in [alLeft, alRight] then\r\n Width := 0\r\n else\r\n Height := 0;\r\n\r\n ResetPosition;\r\n end;\r\n\r\n if MakeVisible and (Client <> nil) then\r\n begin\r\n if not Client.Visible then\r\n Client.Show;\r\n\r\n if DockServer.AutoFocusDockedForm and (Client is TWinControl) and\r\n not TWinControl(Client).Focused and TWinControl(Client).CanFocus then\r\n TWinControl(Client).SetFocus;\r\n end;\r\nend;\r\n\r\nfunction TJvDockPanel.CreateDockManager: IDockManager;\r\nvar\r\n ADockStyle: TJvDockBasicStyle;\r\n TreeClass: TJvDockTreeClass;\r\nbegin\r\n Result := nil;\r\n if (DockManager = nil) and DockSite and UseDockManager then\r\n begin\r\n if Assigned(DockServer) then\r\n begin\r\n ADockStyle := DockServer.DockStyle;\r\n if Assigned(ADockStyle) then\r\n begin\r\n TreeClass := ADockStyle.DockPanelTreeClass;\r\n if Assigned(TreeClass) and (TreeClass <> TJvDockTree) then\r\n Result := TreeClass.Create(Self, ADockStyle.DockPanelZoneClass, ADockStyle) as IJvDockManager;\r\n end;\r\n end;\r\n end;\r\n\r\n if Result = nil then\r\n Result := DockManager;\r\n DoubleBuffered := DoubleBuffered or (Result <> nil);\r\nend;\r\n\r\n//=== { TJvDockServer } ======================================================\r\n\r\nconstructor TJvDockServer.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FAutoFocusDockedForm := True;\r\n CreateSplitterStyle;\r\nend;\r\n\r\ndestructor TJvDockServer.Destroy;\r\nbegin\r\n DestroySplitterStyle;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvDockServer.AddDockStyle(ADockStyle: TJvDockBasicStyle);\r\nbegin\r\n JvGlobalDockManager.RegisterDockServer(Self);\r\n\r\n if Assigned(ADockStyle) and Assigned(ADockStyle.DockPanelClass) then\r\n FDockPanelClass := ADockStyle.DockPanelClass\r\n else\r\n FDockPanelClass := DefaultDockPanelClass;\r\n\r\n if Assigned(ADockStyle) and Assigned(ADockStyle.DockSplitterClass) then\r\n FDockSplitterClass := ADockStyle.DockSplitterClass\r\n else\r\n FDockSplitterClass := DefaultDockSplitterClass;\r\n\r\n if not (csDesigning in ComponentState) then\r\n begin\r\n CreateDockPanelAndSplitter;\r\n SetSplitterStyles;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockServer.CreateDockPanelAndSplitter;\r\n//var\r\n// ControlList: TList;\r\n\r\n function CreatePanel(AParent: TWinControl; Align: TAlign; Name: string): TJvDockPanel;\r\n begin\r\n if (FDockPanelClass <> nil) and\r\n (FDockPanelClass <> TJvDockPanelClass(ClassType)) then\r\n begin\r\n Result := FDockPanelClass.Create({Owner} Self);\r\n // (ahuser) Delphi 5's TComponent.Notification() will fail if Owner=Self.Owner\r\n Result.Parent := AParent; {ParentForm;}\r\n Result.Name := Name;\r\n Result.Caption := '';\r\n Result.Align := Align;\r\n Result.DockServer := Self;\r\n Result.ResetPosition;\r\n if Align in [alTop, alBottom] then\r\n Result.Height := 0\r\n else\r\n if Align in [alLeft, alRight] then\r\n Result.Width := 0;\r\n SetDockSite(Result, True);\r\n\r\n Result.FreeNotification(Self);\r\n end\r\n else\r\n Result := nil;\r\n end;\r\n\r\n function CreateSplitter(AParent: TWinControl; Align: TAlign; Name: string): TJvDockSplitter;\r\n begin\r\n if (FDockSplitterClass <> nil) and\r\n (FDockSplitterClass <> TJvDockSplitterClass(ClassType)) then\r\n begin\r\n Result := FDockSplitterClass.Create({Owner}Self);\r\n // (ahuser) Delphi 5's TComponent.Notification() will fail if Owner=Self.Owner\r\n Result.Parent := AParent; {ParentForm;}\r\n Result.Name := Name;\r\n Result.Visible := False;\r\n Result.Align := Align;\r\n Result.DockServer := Self;\r\n Result.FreeNotification(Self);\r\n end\r\n else\r\n Result := nil;\r\n end;\r\n\r\n {NEW! Docking panel in center area, or other part of form than the built in left/top/right/bottom panels! }\r\n\r\n procedure CustomDockPanel;\r\n var\r\n AParent: TWinControl;\r\n LAlign: TAlign;\r\n begin\r\n AParent := PArentForm;\r\n LAlign := alClient;\r\n if Assigned(FOnCustomPanel) then\r\n //TJvDockCustomPanelEvent:\r\n FOnCustomPanel(Self, AParent, LAlign)\r\n else\r\n begin\r\n FDockPanels[dpCustom] := nil;\r\n FSplitters[dpCustom] := nil;\r\n Exit;\r\n end;\r\n if (LAlign <> alNone) and Assigned(AParent) then\r\n begin // Don't create if align is alNone or parent is NIL.\r\n FDockPanels[dpCustom] := CreatePanel(AParent, LAlign, {NOTRANSLATE} 'CustomDockPanel');\r\n FDockPanels[dpCustom].CustomFlag := True;\r\n if AParent is TPanel then\r\n FDockPanels[dpCustom].Color := TPanel(AParent).Color;\r\n FSplitters[dpCustom] := nil; //CreateSplitter(ParentForm, alTop, 'CustomSplitter' + cDefaultNameSuffix);\r\n //FSplitters[dpCustom].Visible := False;\r\n end\r\n else\r\n FDockPanels[dpCustom] := nil;\r\n FSplitters[dpCustom] := nil;\r\n end;\r\n\r\nbegin\r\n // ControlList := TList.Create;\r\n // try\r\n FDockPanels[dpLeft] := CreatePanel(ParentForm, alLeft, {NOTRANSLATE} 'LeftDockPanel');\r\n FSplitters[dpLeft] := CreateSplitter(ParentForm, alLeft, {NOTRANSLATE} 'LeftSplitter');\r\n FDockPanels[dpRight] := CreatePanel(ParentForm, alRight, {NOTRANSLATE} 'RightDockPanel');\r\n FSplitters[dpRight] := CreateSplitter(ParentForm, alRight, {NOTRANSLATE} 'RightSplitter');\r\n FDockPanels[dpTop] := CreatePanel(ParentForm, alTop, {NOTRANSLATE} 'TopDockPanel');\r\n FSplitters[dpTop] := CreateSplitter(ParentForm, alTop, {NOTRANSLATE} 'TopSplitter');\r\n FDockPanels[dpBottom] := CreatePanel(ParentForm, alBottom, {NOTRANSLATE} 'BottomDockPanel');\r\n FSplitters[dpBottom] := CreateSplitter(ParentForm, alBottom, {NOTRANSLATE} 'BottomSplitter');\r\n\r\n CustomDockPanel;\r\n\r\n// FSplitters[dpCustom] := nil; // NOT USED!\r\n // finally\r\n // ControlList.Free;\r\n // end;\r\nend;\r\n\r\nprocedure TJvDockServer.CreateSplitterStyle;\r\nconst\r\n cCursor: array [TJvDockPosition] of TCursor =\r\n (crHSplit, crHSplit, crVSplit, crVSplit, crNone);\r\nvar\r\n Position: TJvDockPosition;\r\nbegin\r\n for Position := Low(TJvDockPosition) to High(TJvDockPosition) do\r\n begin\r\n FSplitterStyles[Position] := TJvDockSplitterStyle.Create(Splitter[Position], cCursor[Position]);\r\n FSplitterStyles[Position].FDockServer := Self;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockServer.DestroyDockPanelAndSplitter;\r\nvar\r\n Position: TJvDockPosition;\r\nbegin\r\n for Position := Low(TJvDockPosition) to High(TJvDockPosition) do\r\n begin\r\n { SplitterStyles may already be destroyed }\r\n if Assigned(SplitterStyle[Position]) then\r\n SplitterStyle[Position].Splitter := nil;\r\n FreeAndNil(FDockPanels[Position]);\r\n FreeAndNil(FSplitters[Position]);\r\n end;\r\nend;\r\n\r\nprocedure TJvDockServer.DestroySplitterStyle;\r\nvar\r\n Position: TJvDockPosition;\r\nbegin\r\n for Position := Low(TJvDockPosition) to High(TJvDockPosition) do\r\n FreeAndNil(FSplitterStyles[Position]);\r\nend;\r\n\r\nprocedure TJvDockServer.DoFinishSetDockPanelSize(DockPanel: TJvDockPanel);\r\nbegin\r\n if Assigned(FOnFinishSetDockPanelSize) then\r\n FOnFinishSetDockPanelSize(DockPanel);\r\nend;\r\n\r\nprocedure TJvDockServer.DoFloatDockClients(DockPanel: TJvDockPanel);\r\nvar\r\n I: Integer;\r\n DC: TJvDockClient;\r\nbegin\r\n if not (csDesigning in ComponentState) and (DockPanel <> nil) then\r\n for I := DockPanel.DockClientCount - 1 downto 0 do\r\n begin\r\n DC := FindDockClient(DockPanel.DockClients[I]);\r\n if DC <> nil then\r\n DC.RestoreChild;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockServer.DoGetClientAlignControl(Align: TAlign; var Value: Integer);\r\nbegin\r\n if Assigned(FOnGetClientAlignSize) then\r\n\tFOnGetClientAlignSize(Align, Value);\r\nend;\r\n\r\nfunction TJvDockServer.GetClientAlignControl(Align: TAlign): Integer;\r\nbegin\r\n Result := GetClientAlignControlArea(ParentForm, Align);\r\n DoGetClientAlignControl(Align, Result);\r\nend;\r\n\r\nfunction TJvDockServer.GetDockPanel(DockPosition: TJvDockPosition): TJvDockPanel;\r\nbegin\r\n Result := FDockPanels[DockPosition];\r\nend;\r\n\r\nfunction TJvDockServer.GetDockPanelIndex(const Index: Integer): TJvDockPanel;\r\nbegin\r\n Result := FDockPanels[TJvDockPosition(Index)];\r\nend;\r\n\r\nfunction TJvDockServer.GetDockPanelWithAlign(Index: TAlign): TJvDockPanel;\r\nbegin\r\n Result := nil;\r\n case Index of\r\n alLeft:\r\n Result := LeftDockPanel;\r\n alRight:\r\n Result := RightDockPanel;\r\n alTop:\r\n Result := TopDockPanel;\r\n alBottom:\r\n Result := BottomDockPanel;\r\n end;\r\nend;\r\n\r\nfunction TJvDockServer.GetDockSplitterWithAlign(Index: TAlign): TJvDockSplitter;\r\nbegin\r\n Result := nil;\r\n case Index of\r\n alLeft:\r\n Result := LeftSplitter;\r\n alRight:\r\n Result := RightSplitter;\r\n alTop:\r\n Result := TopSplitter;\r\n alBottom:\r\n Result := BottomSplitter;\r\n end;\r\nend;\r\n\r\nfunction TJvDockServer.GetSplitter(DockPosition: TJvDockPosition): TJvDockSplitter;\r\nbegin\r\n Result := FSplitters[DockPosition];\r\nend;\r\n\r\nfunction TJvDockServer.GetSplitterIndex(const Index: Integer): TJvDockSplitter;\r\nbegin\r\n Result := FSplitters[TJvDockPosition(Index)];\r\nend;\r\n\r\nfunction TJvDockServer.GetSplitterStyle(DockPosition: TJvDockPosition): TJvDockSplitterStyle;\r\nbegin\r\n Result := FSplitterStyles[DockPosition];\r\nend;\r\n\r\nfunction TJvDockServer.GetSplitterStyleIndex(const Index: Integer): TJvDockSplitterStyle;\r\nbegin\r\n Result := FSplitterStyles[TJvDockPosition(Index)];\r\nend;\r\n\r\nprocedure TJvDockServer.Notification(AComponent: TComponent;\r\n Operation: TOperation);\r\nvar\r\n Position: TJvDockPosition;\r\nbegin\r\n inherited Notification(AComponent, Operation);\r\n\r\n if Operation = opRemove then\r\n begin\r\n for Position := Low(TJvDockPosition) to High(TJvDockPosition) do\r\n if AComponent = DockPanel[Position] then\r\n begin\r\n FDockPanels[Position] := nil;\r\n DestroyDockPanelAndSplitter;\r\n end\r\n else\r\n if AComponent = Splitter[Position] then\r\n begin\r\n FSplitters[Position] := nil;\r\n if Assigned(SplitterStyle[Position]) then\r\n SplitterStyle[Position].Splitter := nil;\r\n DestroyDockPanelAndSplitter;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockServer.RemoveDockStyle(ADockStyle: TJvDockBasicStyle);\r\nbegin\r\n DoFloatDockClients(TopDockPanel);\r\n DoFloatDockClients(BottomDockPanel);\r\n DoFloatDockClients(LeftDockPanel);\r\n DoFloatDockClients(RightDockPanel);\r\n\r\n DestroyDockPanelAndSplitter;\r\n\r\n FDockPanelClass := nil;\r\n FDockSplitterClass := nil;\r\n\r\n { !! can be nil }\r\n if JvGlobalDockManager <> nil then\r\n JvGlobalDockManager.UnRegisterDockServer(Self);\r\nend;\r\n\r\nprocedure TJvDockServer.SetBottomDock(const Value: Boolean);\r\nbegin\r\n if not Value then\r\n DoFloatDockClients(BottomDockPanel);\r\n inherited SetBottomDock(Value);\r\nend;\r\n\r\nprocedure TJvDockServer.SetEnableDock(const Value: Boolean);\r\nbegin\r\n if not Value then\r\n begin\r\n DoFloatDockClients(TopDockPanel);\r\n DoFloatDockClients(BottomDockPanel);\r\n DoFloatDockClients(LeftDockPanel);\r\n DoFloatDockClients(RightDockPanel);\r\n end;\r\n inherited SetEnableDock(Value);\r\nend;\r\n\r\nprocedure TJvDockServer.SetLeftDock(const Value: Boolean);\r\nbegin\r\n if not Value then\r\n DoFloatDockClients(LeftDockPanel);\r\n inherited SetLeftDock(Value);\r\nend;\r\n\r\nprocedure TJvDockServer.SetRightDock(const Value: Boolean);\r\nbegin\r\n if not Value then\r\n DoFloatDockClients(RightDockPanel);\r\n inherited SetRightDock(Value);\r\nend;\r\n\r\nprocedure TJvDockServer.SetSplitterStyle(DockPosition: TJvDockPosition;\r\n ASplitterStyle: TJvDockSplitterStyle);\r\nbegin\r\n FSplitterStyles[DockPosition].Assign(ASplitterStyle);\r\nend;\r\n\r\nprocedure TJvDockServer.SetSplitterStyleIndex(const Index: Integer;\r\n ASplitterStyle: TJvDockSplitterStyle);\r\nbegin\r\n FSplitterStyles[TJvDockPosition(Index)].Assign(ASplitterStyle);\r\nend;\r\n\r\nprocedure TJvDockServer.SetSplitterStyles;\r\nvar\r\n Position: TJvDockPosition;\r\nbegin\r\n for Position := Low(TJvDockPosition) to High(TJvDockPosition) do\r\n begin\r\n SplitterStyle[Position].Splitter := Splitter[Position];\r\n SplitterStyle[Position].SetSplitterStyle;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockServer.SetTopDock(const Value: Boolean);\r\nbegin\r\n if not Value then\r\n DoFloatDockClients(TopDockPanel);\r\n inherited SetTopDock(Value);\r\nend;\r\n\r\nprocedure TJvDockServer.WindowProc(var Msg: TMessage);\r\nbegin\r\n if Assigned(FDockStyle) then\r\n if FDockStyle.DockServerWindowProc(Self, Msg) then\r\n Exit;\r\n if not (csDesigning in ComponentState) then\r\n if Msg.Msg = WM_ACTIVATE then\r\n WMActivate(TWMActivate(Msg));\r\n inherited WindowProc(Msg);\r\nend;\r\n\r\nprocedure TJvDockServer.WMActivate(var Msg: TWMActivate);\r\n{$IFNDEF COMPILER9_UP}\r\nvar\r\n Control: TWinControl;\r\n{$ENDIF !COMPILER9_UP}\r\nbegin\r\n {$IFNDEF COMPILER9_UP}\r\n if Msg.Active = WA_INACTIVE then\r\n begin\r\n Control := ParentForm.ActiveControl;\r\n if Assigned(Control) then\r\n InvalidateDockHostSiteOfControl(Control, True);\r\n end\r\n else\r\n begin\r\n Control := ParentForm.ActiveControl;\r\n if Assigned(Control) then\r\n begin\r\n // { ?? }\r\n // if AutoFocusDockedForm and Control.CanFocus then\r\n // Control.SetFocus;\r\n InvalidateDockHostSiteOfControl(Control, False);\r\n end;\r\n end;\r\n {$ENDIF !COMPILER9_UP}\r\nend;\r\n\r\n//=== { TJvDockSplitter } ====================================================\r\n\r\nconstructor TJvDockSplitter.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n AutoSnap := False;\r\nend;\r\n\r\nfunction TJvDockSplitter.FindControl: TControl;\r\nbegin\r\n if DockServer <> nil then\r\n Result := DockServer.GetDockPanelWithAlign(Align)\r\n else\r\n Result := inherited FindControl;\r\nend;\r\n\r\nfunction TJvDockSplitter.GetSplitterIndex: Integer;\r\nbegin\r\n case Align of\r\n alTop:\r\n Result := 0;\r\n alBottom:\r\n Result := 1;\r\n alLeft:\r\n Result := 2;\r\n alRight:\r\n Result := 3;\r\n else\r\n Result := -1;\r\n end;\r\nend;\r\n\r\n//=== { TJvDockSplitterStyle } ===============================================\r\n\r\nconstructor TJvDockSplitterStyle.Create(ASplitter: TJvDockSplitter; ACursor: TCursor);\r\nbegin\r\n inherited Create;\r\n FSplitter := ASplitter;\r\n Color := clBtnFace;\r\n Cursor := ACursor;\r\n ParentColor := False;\r\n ResizeStyle := rsPattern;\r\n FSize := 3;\r\n FMinSize := 30;\r\nend;\r\n\r\nprocedure TJvDockSplitterStyle.Assign(Source: TPersistent);\r\nbegin\r\n if Source is TJvDockSplitterStyle then\r\n begin\r\n Color := TJvDockSplitterStyle(Source).Color;\r\n Cursor := TJvDockSplitterStyle(Source).Cursor;\r\n ParentColor := TJvDockSplitterStyle(Source).ParentColor;\r\n ResizeStyle := TJvDockSplitterStyle(Source).ResizeStyle;\r\n Size := TJvDockSplitterStyle(Source).Size;\r\n end\r\n else\r\n inherited Assign(Source);\r\nend;\r\n\r\nprocedure TJvDockSplitterStyle.AssignTo(Dest: TPersistent);\r\nbegin\r\n if Dest is TJvDockSplitterStyle then\r\n with TJvDockSplitterStyle(Dest) do\r\n begin\r\n Color := Self.Color;\r\n Cursor := Self.Cursor;\r\n ParentColor := Self.ParentColor;\r\n ResizeStyle := Self.ResizeStyle;\r\n Size := Self.Size;\r\n end\r\n else\r\n inherited AssignTo(Dest);\r\nend;\r\n\r\nprocedure TJvDockSplitterStyle.AssignToSplitter(Dest: TJvDockSplitter);\r\nbegin\r\n Dest.Color := Color;\r\n Dest.Cursor := Cursor;\r\n Dest.ParentColor := ParentColor;\r\n Dest.ResizeStyle := ResizeStyle;\r\n if Dest.Align in [alTop, alBottom] then\r\n Dest.Height := Size\r\n else\r\n Dest.Width := Size;\r\nend;\r\n\r\nprocedure TJvDockSplitterStyle.SetColor(const Value: TColor);\r\nbegin\r\n if FColor <> Value then\r\n begin\r\n FColor := Value;\r\n ParentColor := False;\r\n if Assigned(FSplitter) then\r\n FSplitter.Color := Value;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockSplitterStyle.SetCursor(const Value: TCursor);\r\nbegin\r\n FCursor := Value;\r\n if Assigned(FSplitter) then\r\n FSplitter.Cursor := Value;\r\nend;\r\n\r\nprocedure TJvDockSplitterStyle.SetMinSize(const Value: TJvDockSplitterSize);\r\nbegin\r\n FMinSize := Value;\r\n if Assigned(FSplitter) then\r\n FSplitter.MinSize := Value;\r\nend;\r\n\r\nprocedure TJvDockSplitterStyle.SetParentColor(const Value: Boolean);\r\nbegin\r\n if FParentColor <> Value then\r\n begin\r\n FParentColor := Value;\r\n if Value then\r\n FColor := FDockServer.ParentForm.Color;\r\n if Assigned(FSplitter) then\r\n FSplitter.ParentColor := Value;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockSplitterStyle.SetResizeStyle(const Value: TResizeStyle);\r\nbegin\r\n FResizeStyle := Value;\r\n if Assigned(FSplitter) then\r\n FSplitter.ResizeStyle := Value;\r\nend;\r\n\r\nprocedure TJvDockSplitterStyle.SetSize(const Value: TJvDockSplitterSize);\r\nbegin\r\n FSize := Value;\r\n if Assigned(FSplitter) then\r\n begin\r\n if FSplitter.Align in [alTop, alBottom] then\r\n FSplitter.Height := Value\r\n else\r\n FSplitter.Width := Value;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockSplitterStyle.SetSplitterStyle;\r\nbegin\r\n if Assigned(FSplitter) then\r\n AssignToSplitter(FSplitter);\r\nend;\r\n\r\n//=== { TJvDockTabHostForm } =================================================\r\n\r\nconstructor TJvDockTabHostForm.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n BorderStyle := TabDockHostBorderStyle;\r\nend;\r\n\r\nfunction TJvDockTabHostForm.GetActiveDockForm: TForm;\r\nbegin\r\n if PageControl.ActiveDockForm is TForm then\r\n Result := TForm(PageControl.ActiveDockForm)\r\n else\r\n Result := nil;\r\nend;\r\n\r\n//------------------------------------------------------------------------\r\n// ShowDockedControl:\r\n//\r\n// If under program control you need a tabdock to switch pages to show\r\n// a particular docked form, you call DockTabHostForm.ShowControl(aForm):\r\n//\r\n// If aControl is docked in DockTabhostForm.PageControl, this will\r\n// change the PageControl.ActivePage to that page.\r\n//------------------------------------------------------------------------\r\n\r\nprocedure TJvDockTabHostForm.ShowDockedControl(AControl: TWinControl); // NEW! WPostma.\r\nvar\r\n t: Integer;\r\n TabSheet: TJvDockTabSheet;\r\nbegin\r\n Assert(Assigned(AControl));\r\n if not Assigned(AControl.Parent) then\r\n exit;\r\n if not (AControl.Parent is TJvDockTabSheet) then\r\n exit;\r\n TabSheet := TJvDockTabSheet(AControl.Parent);\r\n // Now go through the pages and find it!\r\n for t := 0 to FPageControl.Count - 1 do\r\n begin\r\n if FPageControl.Pages[t] = TabSheet then\r\n begin\r\n FPageControl.ActivePage := TabSheet; { set page!}\r\n if AControl is TForm then\r\n TabSheet.Caption := TForm(AControl).Caption;\r\n Self.Caption := TabSheet.Caption;\r\n exit;\r\n end;\r\n end;\r\nend;\r\n\r\n// If while docked, you need a docked form's caption to update,\r\n// and this update needs to be shown on the tabs on the screen,\r\n// and possibly also the title bar of the docktabhost form needs\r\n// updating also, then you need to call this function, like this:\r\n// DockTabHostForm.UpdateCaption(MyForm)\r\n\r\nprocedure TJvDockTabHostForm.UpdateCaption(AControl: TWinControl); //virtual;\r\nvar\r\n t: Integer;\r\n TabSheet: TJvDockTabSheet;\r\nbegin\r\n Assert(Assigned(AControl));\r\n if not Assigned(AControl.Parent) then\r\n exit;\r\n if not (AControl.Parent is TJvDockTabSheet) then\r\n exit;\r\n TabSheet := TJvDockTabSheet(AControl.Parent);\r\n // Now go through the pages and find the one page that needs\r\n // its caption updated.\r\n for t := 0 to FPageControl.Count - 1 do\r\n begin\r\n if FPageControl.Pages[t] = TabSheet then\r\n begin\r\n if AControl is TForm then\r\n TabSheet.Caption := TForm(AControl).Caption;\r\n if FPageControl.ActivePage = TabSheet then\r\n Self.Caption := TabSheet.Caption; // tabhost's form caption needs updating.\r\n exit;\r\n end;\r\n end;\r\nend;\r\n\r\n//=== { TJvDockTabPageControl } ==============================================\r\n\r\nconstructor TJvDockTabPageControl.Create(AOwner: TComponent);\r\nvar\r\n ADockClient: TJvDockClient;\r\nbegin\r\n inherited Create(AOwner);\r\n if AOwner is TWinControl then\r\n Parent := TWinControl(AOwner);\r\n FStyleLink := TJvDockStyleLink.Create;\r\n { First set DockStyle then OnStyleChanged so no OnStyleChanged is fired;\r\n we do it ourself in AfterContruction }\r\n ADockClient := FindDockClient(Parent);\r\n if Assigned(ADockClient) then\r\n FStyleLink.DockStyle := ADockClient.DockStyle;\r\n FStyleLink.OnStyleChanged := DockStyleChanged;\r\n SetDockSite(Self, True);\r\n PopupMenu := DockPageControlPopupMenu;\r\n HotTrack := DockPageControlHotTrack;\r\n DoubleBuffered := True;\r\n Caption := '';\r\n FVersion := $00040000;\r\nend;\r\n\r\ndestructor TJvDockTabPageControl.Destroy;\r\nbegin\r\n FStyleLink.Free;\r\n SetDockSite(Self, False);\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvDockTabPageControl.AdjustClientRect(var Rect: TRect);\r\nbegin\r\n inherited AdjustClientRect(Rect);\r\n case TabPosition of\r\n tpLeft:\r\n Inc(Rect.Left, 2);\r\n tpRight:\r\n Dec(Rect.Right, 2);\r\n tpBottom:\r\n begin\r\n Dec(Rect.Top, 1);\r\n Dec(Rect.Bottom, 2);\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockTabPageControl.AfterConstruction;\r\nbegin\r\n inherited AfterConstruction;\r\n FStyleLink.StyleChanged;\r\nend;\r\n\r\nprocedure TJvDockTabPageControl.CustomDockDrop(Source: TJvDockDragDockObject;\r\n X, Y: Integer);\r\nvar\r\n DragDockObject: TDragDockObject;\r\nbegin\r\n if Source.DropAlign in [alClient, alNone] then\r\n begin\r\n DragDockObject := TDragDockObject.Create(Source.Control);\r\n try\r\n DragDockObject.DockRect := Source.DockRect;\r\n DragDockObject.Control := Source.Control;\r\n Perform(CM_DOCKCLIENT, WPARAM(DragDockObject), {$IFDEF RTL230_UP}PointToLParam{$ELSE}LPARAM{$ENDIF RTL230_UP}(SmallPoint(X, Y)));\r\n UpdateCaption(nil);\r\n finally\r\n DragDockObject.Free;\r\n end;\r\n end\r\n else\r\n inherited CustomDockDrop(Source, X, Y);\r\n if Source.Control is TForm then\r\n begin\r\n TForm(Source.Control).ActiveControl := nil;\r\n SetDockSite(TForm(Source.Control), False);\r\n end;\r\nend;\r\n\r\nprocedure TJvDockTabPageControl.CustomDockOver(Source: TJvDockDragDockObject;\r\n X, Y: Integer; State: TDragState; var Accept: Boolean);\r\nvar\r\n Rect: TRect;\r\nbegin\r\n inherited CustomDockOver(Source, X, Y, State, Accept);\r\n\r\n Accept := IsDockable(Self, Source.Control, Source.DropOnControl, Source.DropAlign);\r\n\r\n if Accept then\r\n begin\r\n ComputeDockingRect(Self, Rect, Point(ClientWidth div 2, ClientHeight div 2));\r\n Source.DockRect := Rect;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockTabPageControl.CustomEndDock(Target: TObject; X, Y: Integer);\r\nbegin\r\n inherited CustomEndDock(Target, X, Y);\r\nend;\r\n\r\nprocedure TJvDockTabPageControl.CustomGetDockEdge(Source: TJvDockDragDockObject;\r\n MousePos: TPoint; var DropAlign: TAlign);\r\nvar\r\n ARect: TRect;\r\nbegin\r\n ARect := Source.DockRect;\r\n DropAlign := ComputeDockingRect(Source.Control, ARect, MousePos);\r\nend;\r\n\r\nprocedure TJvDockTabPageControl.CustomGetSiteInfo(Source: TJvDockDragDockObject;\r\n Client: TControl; var InfluenceRect: TRect; MousePos: TPoint; var CanDock: Boolean);\r\nbegin\r\n inherited CustomGetSiteInfo(Source, Client, InfluenceRect, MousePos, CanDock);\r\n CanDock := IsDockable(Self, Client, Source.DropOnControl, Source.DropAlign);\r\nend;\r\n\r\nprocedure TJvDockTabPageControl.CustomPositionDockRect(Source: TJvDockDragDockObject;\r\n X, Y: Integer);\r\nbegin\r\n inherited CustomPositionDockRect(Source, X, Y);\r\nend;\r\n\r\nprocedure TJvDockTabPageControl.CustomStartDock(var Source: TJvDockDragDockObject);\r\nbegin\r\n inherited CustomStartDock(Source);\r\nend;\r\n\r\nfunction TJvDockTabPageControl.CustomUnDock(Source: TJvDockDragDockObject;\r\n NewTarget: TWinControl; Client: TControl): Boolean;\r\nbegin\r\n if not (Client is TJvDockableForm) then\r\n SetDockSite(TForm(Client), True);\r\n if (VisibleDockClientCount = 1) or (DockClientCount <= 2) then\r\n PostMessage(Parent.Handle, WM_CLOSE, 0, 0);\r\n UpdateCaption(Client);\r\n Result := Perform(CM_UNDOCKCLIENT, WPARAM(NewTarget), LPARAM(Client)) = 0;\r\nend;\r\n\r\nprocedure TJvDockTabPageControl.DockDrop(Source: TDragDockObject; X,\r\n Y: Integer);\r\nbegin\r\n if Perform(CM_DOCKCLIENT, WPARAM(Source), {$IFDEF RTL230_UP}PointToLParam{$ELSE}LPARAM{$ENDIF RTL230_UP}(SmallPoint(X, Y))) >= 0 then\r\n begin\r\n if Source.Control is TForm then\r\n begin\r\n TForm(Source.Control).ActiveControl := nil;\r\n SetDockSite(TWinControl(Source.Control), False);\r\n if TForm(Source.Control).FormStyle = fsStayOnTop then\r\n TForm(Parent).FormStyle := fsStayOnTop;\r\n end;\r\n UpdateCaption(nil);\r\n end;\r\nend;\r\n\r\nprocedure TJvDockTabPageControl.DockStyleChanged(Sender: TObject);\r\nbegin\r\n SyncWithStyle;\r\nend;\r\n\r\nfunction TJvDockTabPageControl.DoUnDock(NewTarget: TWinControl;\r\n Client: TControl): Boolean;\r\nbegin\r\n if not (Client is TJvDockableForm) then\r\n SetDockSite(TForm(Client), True);\r\n if (VisibleDockClientCount = 1) or\r\n (DockClientCount <= 2) then\r\n PostMessage(Parent.Handle, WM_CLOSE, 0, 0);\r\n UpdateCaption(Client);\r\n Result := Perform(CM_UNDOCKCLIENT, WPARAM(NewTarget), LPARAM(Client)) = 0;\r\nend;\r\n\r\nfunction TJvDockTabPageControl.GetActiveDockForm: TCustomForm;\r\nbegin\r\n Result := DockForm[ActivePageIndex];\r\nend;\r\n\r\nfunction TJvDockTabPageControl.GetDockForm(Index: Integer): TCustomForm;\r\nvar\r\n Page: TJvDockTabSheet;\r\nbegin\r\n Result := nil;\r\n\r\n if (Index > -1) and (Index < Count) then\r\n begin\r\n Page := Pages[Index];\r\n if Assigned(Page) and (Page.ControlCount = 1) and (Page.Controls[0] is TCustomForm) then\r\n begin\r\n Result := TCustomForm(Page.Controls[0]);\r\n end\r\n end;\r\nend;\r\n\r\nfunction TJvDockTabPageControl.GetDockStyle: TJvDockObservableStyle;\r\nbegin\r\n Result := FStyleLink.DockStyle;\r\nend;\r\n\r\nfunction TJvDockTabPageControl.GetParentForm: TJvDockTabHostForm;\r\nbegin\r\n if Parent is TJvDockTabHostForm then\r\n Result := TJvDockTabHostForm(Parent)\r\n else\r\n Result := nil;\r\nend;\r\n\r\nprocedure TJvDockTabPageControl.LoadFromStream(Stream: TStream);\r\nvar\r\n I, ACount, NameLen, SheetVisible, ActiveSheetIndex: Integer;\r\n ControlName: UTF8String;\r\n AControl: TControl;\r\n Index: Integer;\r\nbegin\r\n Stream.Read(I, SizeOf(I));\r\n\r\n Stream.Read(ACount, SizeOf(ACount));\r\n Index := 0;\r\n for I := 0 to ACount - 1 do\r\n begin\r\n ControlName := '';\r\n\r\n Stream.Read(NameLen, SizeOf(NameLen));\r\n if NameLen > 0 then\r\n begin\r\n SetLength(ControlName, NameLen);\r\n Stream.Read(ControlName[1], NameLen);\r\n end;\r\n\r\n Stream.Read(SheetVisible, SizeOf(SheetVisible));\r\n\r\n if ControlName <> '' then\r\n begin\r\n ReloadDockedControl({$IFDEF UNICODE}UTF8ToString{$ELSE}UTF8Decode{$ENDIF}(ControlName), AControl);\r\n if AControl <> nil then\r\n begin\r\n AControl.ManualDock(Self, nil, alClient);\r\n { DockClients[Index] is always AControl? }\r\n DockClients[Index].Visible := Boolean(SheetVisible);\r\n if (Self is TJvDockVSNETTabPageControl) and (Index = Count - 1) then\r\n TJvDockVSNETTabSheet(Pages[Index]).OldVisible := Boolean(SheetVisible);\r\n Inc(Index);\r\n end;\r\n end;\r\n end;\r\n\r\n Stream.Read(ActiveSheetIndex, SizeOf(ActiveSheetIndex));\r\n ActivePageIndex := ActiveSheetIndex;\r\n Change;\r\nend;\r\n\r\nprocedure TJvDockTabPageControl.ReloadDockedControl(const AControlName: string;\r\n var AControl: TControl);\r\nbegin\r\n AControl := JvDockFindDockFormWithName(AControlName);\r\nend;\r\n\r\nprocedure TJvDockTabPageControl.SaveToStream(Stream: TStream);\r\nvar\r\n I, ACount, NameLen, SheetVisible, ActiveSheetIndex: Integer;\r\n ControlName: UTF8String;\r\n CurrentControl: TControl;\r\n TabPageStreamEndFlag: Integer;\r\nbegin\r\n Stream.Write(FVersion, SizeOf(FVersion));\r\n ACount := Count;\r\n\r\n Stream.Write(ACount, SizeOf(ACount));\r\n for I := 0 to ACount - 1 do\r\n begin\r\n if Pages[I].ControlCount > 0 then\r\n begin\r\n CurrentControl := Pages[I].Controls[0];\r\n\r\n ControlName := UTF8Encode(CurrentControl.Name);\r\n NameLen := Length(ControlName);\r\n Stream.Write(NameLen, SizeOf(NameLen));\r\n if NameLen > 0 then\r\n Stream.Write(ControlName[1], NameLen);\r\n\r\n SheetVisible := 0;\r\n if (Self is TJvDockVSNETTabPageControl) and (ParentForm.HostDockSite is TJvDockPanel) then\r\n SheetVisible := Integer(TJvDockVSNETTabSheet(Pages[I]).OldVisible)\r\n else\r\n SheetVisible := SheetVisible + Integer(CurrentControl.Visible);\r\n\r\n Stream.Write(SheetVisible, SizeOf(SheetVisible));\r\n end;\r\n end;\r\n ActiveSheetIndex := ActivePageIndex;\r\n\r\n Stream.Write(ActiveSheetIndex, SizeOf(ActiveSheetIndex));\r\n\r\n TabPageStreamEndFlag := -10;\r\n Stream.Write(TabPageStreamEndFlag, SizeOf(TabPageStreamEndFlag));\r\nend;\r\n\r\nprocedure TJvDockTabPageControl.SyncWithStyle;\r\nbegin\r\n HotTrack := DockStyle.TabServerOption.HotTrack;\r\n TabPosition := DockStyle.TabServerOption.TabPosition;\r\nend;\r\n\r\n//=== { TJvGlobalDockManager } ===============================================\r\n\r\nconstructor TJvGlobalDockManager.Create;\r\nbegin\r\n inherited Create;\r\n FDockServers := TList.Create;\r\n FDockClients := TList.Create;\r\n FDockableForms := TList.Create;\r\nend;\r\n\r\ndestructor TJvGlobalDockManager.Destroy;\r\nbegin\r\n FDockableForms.Free;\r\n FDockServers.Free;\r\n FDockClients.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJvGlobalDockManager.FindDockClientForm(\r\n const AName: string): TControl;\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := 0 to DockClientCount - 1 do\r\n begin\r\n Result := DockClient[I].ParentForm;\r\n if Result.Name = AName then\r\n Exit;\r\n end;\r\n Result := nil;\r\nend;\r\n\r\nfunction TJvGlobalDockManager.FindDockControlForm(\r\n const AName: string): TControl;\r\nbegin\r\n Result := FindDockServerForm(AName);\r\n if Result = nil then\r\n FindDockClientForm(AName);\r\nend;\r\n\r\nfunction TJvGlobalDockManager.FindDockServerForm(\r\n const AName: string): TControl;\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := 0 to DockServerCount - 1 do\r\n begin\r\n Result := DockServer[I].ParentForm;\r\n if Result.Name = AName then\r\n Exit;\r\n end;\r\n Result := nil;\r\nend;\r\n\r\nfunction TJvGlobalDockManager.GetDockableForm(\r\n const Index: Integer): TJvDockableForm;\r\nbegin\r\n Result := TJvDockableForm(FDockableForms[Index]);\r\nend;\r\n\r\nfunction TJvGlobalDockManager.GetDockableFormCount: Integer;\r\nbegin\r\n Result := FDockableForms.Count;\r\nend;\r\n\r\nfunction TJvGlobalDockManager.GetDockClient(\r\n const Index: Integer): TJvDockClient;\r\nbegin\r\n Result := TJvDockClient(FDockClients[Index]);\r\nend;\r\n\r\nfunction TJvGlobalDockManager.GetDockClientCount: Integer;\r\nbegin\r\n Result := FDockClients.Count;\r\nend;\r\n\r\nfunction TJvGlobalDockManager.GetDockServer(\r\n const Index: Integer): TJvDockServer;\r\nbegin\r\n Result := TJvDockServer(FDockServers[Index]);\r\nend;\r\n\r\nfunction TJvGlobalDockManager.GetDockServerCount: Integer;\r\nbegin\r\n Result := FDockServers.Count;\r\nend;\r\n\r\nprocedure TJvGlobalDockManager.RegisterDockableForm(\r\n ADockableForm: TJvDockableForm);\r\nvar\r\n Index: Integer;\r\nbegin\r\n Index := FDockableForms.IndexOf(ADockableForm);\r\n if Index < 0 then\r\n FDockableForms.Add(ADockableForm);\r\nend;\r\n\r\nprocedure TJvGlobalDockManager.RegisterDockClient(\r\n ADockClient: TJvDockClient);\r\nvar\r\n Index: Integer;\r\nbegin\r\n Index := FDockClients.IndexOf(ADockClient);\r\n if Index < 0 then\r\n FDockClients.Add(ADockClient);\r\nend;\r\n\r\nprocedure TJvGlobalDockManager.RegisterDockServer(\r\n ADockServer: TJvDockServer);\r\nvar\r\n Index: Integer;\r\nbegin\r\n Index := FDockServers.IndexOf(ADockServer);\r\n if Index < 0 then\r\n FDockServers.Add(ADockServer);\r\nend;\r\n\r\nprocedure TJvGlobalDockManager.UnRegisterDockableForm(\r\n ADockableForm: TJvDockableForm);\r\nbegin\r\n FDockableForms.Remove(ADockableForm);\r\nend;\r\n\r\nprocedure TJvGlobalDockManager.UnRegisterDockClient(\r\n ADockClient: TJvDockClient);\r\nbegin\r\n FDockClients.Remove(ADockClient);\r\nend;\r\n\r\nprocedure TJvGlobalDockManager.UnRegisterDockServer(\r\n ADockServer: TJvDockServer);\r\nbegin\r\n FDockServers.Remove(ADockServer);\r\nend;\r\n\r\nprocedure InitDockManager;\r\nbegin\r\n try\r\n JvGlobalDockManager.Free;\r\n JvGlobalDockManager := nil;\r\n JvGlobalDockManager := TJvGlobalDockManager.Create;\r\n except\r\n end;\r\nend;\r\n\r\nprocedure DoneDockManager;\r\nbegin\r\n JvGlobalDockManager.Free;\r\n JvGlobalDockManager := nil;\r\nend;\r\n\r\ninitialization\r\n {$IFDEF UNITVERSIONING}\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n {$ENDIF UNITVERSIONING}\r\n InitDockManager;\r\n\r\nfinalization\r\n DoneDockManager;\r\n {$IFDEF UNITVERSIONING}\r\n UnregisterUnitVersion(HInstance);\r\n {$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvDockDelphiStyle.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvDockDelphiStyle.pas, released on 2003-12-31.\r\n\r\nThe Initial Developer of the Original Code is luxiaoban.\r\nPortions created by luxiaoban are Copyright (C) 2002,2003 luxiaoban.\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvDockDelphiStyle.pas 13138 2011-10-26 23:17:50Z jfudickar $\r\n\r\nunit JvDockDelphiStyle;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, Messages, Classes, Controls, Graphics,\r\n JvDockControlForm, JvDockSupportControl, JvDockTree;\r\n\r\ntype\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvDockDelphiStyle = class(TJvDockBasicStyle)\r\n protected\r\n procedure FormDockDrop(DockClient: TJvDockClient;\r\n Source: TJvDockDragDockObject; X, Y: Integer); override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n published\r\n property ConjoinServerOption;\r\n property TabServerOption;\r\n end;\r\n\r\n TJvDockDelphiSplitter = class(TJvDockSplitter);\r\n\r\n TJvDockDelphiPanel = class(TJvDockPanel);\r\n\r\n TJvDockDelphiConjoinPanel = class(TJvDockConjoinPanel);\r\n\r\n TJvDockDelphiTabPageControl = class(TJvDockTabPageControl)\r\n protected\r\n procedure CMDockClient(var Msg: TCMDockClient); message CM_DOCKCLIENT;\r\n end;\r\n\r\n TJvDockDelphiZone = class(TJvDockZone);\r\n\r\n TJvDockDelphiTree = class(TJvDockTree);\r\n\r\n TJvDockDelphiDragDockObject = class(TJvDockDragDockObject);\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvDockDelphiStyle.pas $';\r\n Revision: '$Revision: 13138 $';\r\n Date: '$Date: 2011-10-27 01:17:50 +0200 (jeu. 27 oct. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n SysUtils, Forms,\r\n JvDockSupportProc;\r\n\r\nconstructor TJvDockDelphiStyle.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n DockPanelClass := TJvDockDelphiPanel;\r\n DockSplitterClass := TJvDockDelphiSplitter;\r\n ConjoinPanelClass := TJvDockDelphiConjoinPanel;\r\n TabDockClass := TJvDockDelphiTabPageControl;\r\n DockPanelZoneClass := TJvDockDelphiZone;\r\n DockPanelTreeClass := TJvDockDelphiTree;\r\n ConjoinPanelZoneClass := TJvDockDelphiZone;\r\n ConjoinPanelTreeClass := TJvDockDelphiTree;\r\nend;\r\n\r\nprocedure TJvDockDelphiStyle.FormDockDrop(DockClient: TJvDockClient;\r\n Source: TJvDockDragDockObject; X, Y: Integer);\r\nvar\r\n ARect, DRect: TRect;\r\n DockType: TAlign;\r\n Host: TForm;\r\n APanelDock: TWinControl;\r\n ADockClient: TJvDockClient;\r\nbegin\r\n if IsDockable(DockClient.ParentForm, Source.Control, Source.DropOnControl, Source.DropAlign) then\r\n begin\r\n Host := nil;\r\n\r\n JvDockLockWindow(nil);\r\n try\r\n with DockClient do\r\n begin\r\n DockType := ComputeDockingRect(DockClient.ParentForm, ARect, Point(X, Y));\r\n if ParentForm.HostDockSite is TJvDockPanel then\r\n begin\r\n if DockType = alClient then\r\n begin\r\n if Source.Control is TJvDockTabHostForm then\r\n begin\r\n APanelDock := ParentForm.HostDockSite;\r\n ARect := ParentForm.BoundsRect;\r\n ParentForm.ManualDock(TJvDockTabHostForm(Source.Control).PageControl, nil, alClient);\r\n TJvDockTabHostForm(Source.Control).PageControl.ActivePage.PageIndex := 0;\r\n Source.Control.BoundsRect := ARect;\r\n Source.Control.ManualDock(APanelDock, nil, alClient);\r\n if ParentForm.FormStyle = fsStayOnTop then\r\n TForm(Source.Control).FormStyle := fsStayOnTop;\r\n end\r\n else\r\n begin\r\n APanelDock := ParentForm.HostDockSite;\r\n DRect.TopLeft := ParentForm.HostDockSite.ClientToScreen(Point(0, 0));\r\n Host := CreateTabHostAndDockControl(ParentForm, Source.Control);\r\n SetDockSite(ParentForm, False);\r\n SetDockSite(TWinControl(Source.Control), False);\r\n Host.Top := DRect.Top;\r\n Host.Left := DRect.Left;\r\n Host.ManualDock(APanelDock, nil, alClient);\r\n Host.Visible := True;\r\n end;\r\n end\r\n else\r\n begin\r\n DRect := ParentForm.HostDockSite.BoundsRect;\r\n Source.Control.ManualDock(ParentForm.HostDockSite, nil, DockType);\r\n ParentForm.HostDockSite.BoundsRect := DRect;\r\n end;\r\n Exit;\r\n end;\r\n\r\n if DockType = alClient then\r\n begin\r\n if Source.Control is TJvDockTabHostForm then\r\n begin\r\n ARect := DockClient.ParentForm.BoundsRect;\r\n DockClient.ParentForm.ManualDock(TJvDockTabHostForm(Source.Control).PageControl, nil, alClient);\r\n TJvDockTabHostForm(Source.Control).PageControl.ActivePage.PageIndex := 0;\r\n Source.Control.BoundsRect := ARect;\r\n if DockClient.ParentForm.FormStyle = fsStayOnTop then\r\n TJvDockTabHostForm(Source.Control).FormStyle := fsStayOnTop;\r\n Exit;\r\n end\r\n else\r\n begin\r\n Host := DockClient.CreateTabHostAndDockControl(DockClient.ParentForm, Source.Control);\r\n Host.Visible := True;\r\n end;\r\n end\r\n else\r\n if DockType <> alNone then\r\n begin\r\n Host := CreateConjoinHostAndDockControl(ParentForm, Source.Control, DockType);\r\n ADockClient := FindDockClient(Host);\r\n if ADockClient <> nil then\r\n ADockClient.EnableDock := False;\r\n SetDockSite(ParentForm, False);\r\n SetDockSite(TWinControl(Source.Control), False);\r\n Host.Visible := True;\r\n end;\r\n\r\n if Host <> nil then\r\n begin\r\n Host.LRDockWidth := Source.Control.LRDockWidth;\r\n Host.TBDockHeight := Source.Control.TBDockHeight;\r\n end;\r\n end;\r\n finally\r\n JvDockUnLockWindow;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockDelphiTabPageControl.CMDockClient(var Msg: TCMDockClient);\r\nvar\r\n I: Integer;\r\n Control: TControl;\r\n Count: Integer;\r\nbegin\r\n if Msg.DockSource.Control is TJvDockTabHostForm then\r\n with TJvDockTabHostForm(Msg.DockSource.Control) do\r\n begin\r\n Count := Self.Count;\r\n for I := PageControl.DockClientCount - 1 downto 0 do\r\n begin\r\n Control := PageControl.DockClients[I];\r\n DoFloat(PageControl, Control);\r\n Control.ManualDock(Self, nil, alClient);\r\n Self.ActivePage.PageIndex := Count;\r\n end;\r\n end\r\n else\r\n inherited;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvDockGlobals.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvDockGlobals.pas, released on 2003-12-31.\r\n\r\nThe Initial Developer of the Original Code is luxiaoban.\r\nPortions created by luxiaoban are Copyright (C) 2002,2003 luxiaoban.\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvDockGlobals.pas 12461 2009-08-14 17:21:33Z obones $\r\n\r\nunit JvDockGlobals;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Messages, Graphics,\r\n JvDockControlForm;\r\n\r\nconst\r\n RsDockBaseDockTreeVersion = $00040000;\r\n RsDockVCDockTreeVersion = $00040010;\r\n\r\n DefExpandoRect = 10;\r\n\r\n WM_NCMOUSEFIRST = WM_NCMOUSEMOVE;\r\n WM_NCMOUSELAST = WM_NCMBUTTONDBLCLK;\r\n\r\n HTSPLITTER = 30;\r\n HTEXPAND = 31;\r\n HTNONE = 31;\r\n HTAUTOHIDE = 40;\r\n\r\n VCDefaultGrabberSize = 15;\r\n VCDefaultDockSplitterWidth = 4;\r\n VCDefaultBorderWidth = 4;\r\n\r\n VIDDefaultDockGrabbersSize = 18;\r\n VIDDefaultDockSplitterWidth = 4;\r\n\r\n DefaultVSNETGrabberSize = 19;\r\n MaxActivePaneWidth = 100;\r\n VSNETPageInactiveFontColor = TColor($00525552);\r\n VSNETPageInactiveSheetColor = TColor($00EFF3F7);\r\n JvDockXorColor = TColor($00FFD8CE);\r\n\r\nresourcestring\r\n RsDockServerName = 'JVCL Dock Server Component';\r\n RsDockClientName = 'JVCL Dock Client Component';\r\n RsDockStyleName = 'JVCL Dock Style Component';\r\n\r\n RsDockManagerVersion = '1.0.0.0';\r\n RsDockStyleVersion = '1.0.0.0';\r\n\r\n RsDockManagerCopyrightBegin = '2002';\r\n RsDockManagerCopyrightEnd = '2003';\r\n RsDockStyleCopyRightBegin = '2002';\r\n RsDockStyleCopyRightEnd = '2003';\r\n\r\n RsDockAuthorName = 'zhouyibo';\r\n RsDockCompanyName = '';\r\n RsDockHomePage = 'http://jvcl.sourceforge.net';\r\n // (rom) split against harvesters\r\n RsDockEmail = 'jvcl' + '@' + 'jvcl' + '.' + 'sf' + '.' + 'net';\r\n\r\n RsDockAbout = 'About';\r\n RsDockManagerAbout = 'This is a %s, Version is %s,' + #13#10 +\r\n 'Copyright: %s-%s, Author: %s %s,' + #13#10 +\r\n 'Home Page: %s,' + #13#10 +\r\n 'Email: %s';\r\n RsDockStyleAbout = 'This is a %s, Version is %s,' + #13#10 +\r\n 'Copyright: %s-%s, Author: %s %s,' + #13#10 +\r\n 'Home Page: %s,' + #13#10 +\r\n 'Email: %s';\r\n\r\n RsDockStringSplitter = ' ';\r\n RsDockJvDockInfoSplitter = '@';\r\n\r\n RsDockJvDockTreeCloseBtnHint = 'Close';\r\n RsDockVCDockTreeExpandBtnHint = 'Expand';\r\n RsDockVSNETDockTreeAutoHideBtnHint = 'Auto Hide';\r\n RsDockJvDockTreeVSplitterHint = 'Vertical Splitter';\r\n RsDockJvDockTreeHSplitterHint = 'Horizontal Splitter';\r\n\r\n RsDockTableIndexError = 'Table''s index out of range';\r\n RsDockNodeExistedError = 'Node already exist';\r\n RsDockComProcError = 'The function address is nil';\r\n\r\n RsEDockControlCannotIsNil = 'Control can not be nil';\r\n RsEDockCannotGetValueWithNoOrient = 'Cannot get data of control that has no dock orientation';\r\n RsEDockCannotSetValueWithNoOrient = 'Cannot set data of control that has no dock orientation';\r\n\r\n RsEDockCannotChangeDockStyleProperty = 'Changing DockStyle at runtime is not supported';\r\n RsEDockCannotLayAnother = 'Only one %s allowed on each form. Cannot add another %s';\r\n\r\n RsEDockCannotSetTabPosition = 'Cannot set TabPosition property to tpLeft or tpRight';\r\n RsEDockTabPositionMustBetpBottom = 'TabPosition property must be tpBottom';\r\n\r\n RsDockCannotFindWindow = 'Cannot find window';\r\n\r\n RsEInvalidDockSiteOrientationValue = 'Invalid DockSiteOrientation value doNoOrient';\r\n\r\n { GLOBALS NOTE:\r\n\r\n JvGlobalDockManager:\r\n\r\n JvDocking's TForm Drag-and-Drop functionality requires the use of these globals.\r\n During a drag-drop operation (see JvDockSupportControl.pas, particularly\r\n the class TJvDockDragDockObject, it is assumed that JvGlobalDockManager\r\n will always be assigned to a valid dock manager. If it is not assigned,\r\n access violations would occur.\r\n }\r\n\r\nvar\r\n JvGlobalDockManager: TJvGlobalDockManager = nil;\r\n JvGlobalDockClient: TJvDockClient = nil;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvDockGlobals.pas $';\r\n Revision: '$Revision: 12461 $';\r\n Date: '$Date: 2009-08-14 19:21:33 +0200 (ven. 14 août 2009) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvDockHashTable.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvDockHashTable.pas, released on 2003-12-31.\r\n\r\nThe Initial Developer of the Original Code is luxiaoban.\r\nPortions created by luxiaoban are Copyright (C) 2002, 2003 luxiaoban.\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvDockHashTable.pas 12461 2009-08-14 17:21:33Z obones $\r\n\r\nunit JvDockHashTable;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF COMPILER9_UP}\r\n Windows, // inline\r\n {$ENDIF COMPILER9_UP}\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Classes;\r\n\r\nconst\r\n DefaultHashSize = 20;\r\n\r\ntype\r\n TJvDockClientHashNode = class(TObject)\r\n private\r\n FKeyName: string;\r\n FKeyData: Pointer;\r\n FPrevNode: TJvDockClientHashNode;\r\n FNextNode: TJvDockClientHashNode;\r\n FListIndex: Integer;\r\n public\r\n property KeyName: string read FKeyName write FKeyName;\r\n property KeyData: Pointer read FKeyData write FKeyData;\r\n property PrevNode: TJvDockClientHashNode read FPrevNode write FPrevNode;\r\n property NextNode: TJvDockClientHashNode read FNextNode write FNextNode;\r\n property ListIndex: Integer read FListIndex write FListIndex;\r\n end;\r\n\r\n TJvDockControlHashTable = class(TObject)\r\n private\r\n FCurrentSize: Integer;\r\n FTableSize: Integer;\r\n FEntryList: TList;\r\n FRaiseException: Boolean;\r\n procedure SetTableSize(const Value: Integer);\r\n protected\r\n function HashProc(const Name: string): Integer; virtual;\r\n procedure DeleteListIndex(Index: Integer);\r\n function CreateKeyNode(const KeyName: string; KeyData: Pointer;\r\n ListIndex: Integer): TJvDockClientHashNode;\r\n function CompareKey(const Key1, Key2: string): Integer;\r\n public\r\n constructor Create(Size: Integer = DefaultHashSize; RiseExcept: Boolean = True); virtual;\r\n destructor Destroy; override;\r\n procedure CreateDictionary(Size: Integer); virtual;\r\n function IsIn(const Name: string): Boolean; virtual;\r\n function FindNode(const Name: string): TJvDockClientHashNode; virtual;\r\n function Find(const Name: string): Pointer; virtual;\r\n function Insert(const Name: string; Data: Pointer): Integer; virtual;\r\n procedure Remove(const Name: string); virtual;\r\n procedure MakeEmpty;\r\n property CurrentSize: Integer read FCurrentSize;\r\n property TableSize: Integer read FTableSize write SetTableSize;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvDockHashTable.pas $';\r\n Revision: '$Revision: 12461 $';\r\n Date: '$Date: 2009-08-14 19:21:33 +0200 (ven. 14 août 2009) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n SysUtils,\r\n JvDockGlobals;\r\n\r\n//=== { TJvDockControlHashTable } ============================================\r\n\r\nconstructor TJvDockControlHashTable.Create(Size: Integer; RiseExcept: Boolean);\r\nbegin\r\n // (rom) added inherited Create\r\n inherited Create;\r\n CreateDictionary(Size);\r\n FRaiseException := RiseExcept;\r\nend;\r\n\r\ndestructor TJvDockControlHashTable.Destroy;\r\nbegin\r\n MakeEmpty;\r\n FEntryList.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJvDockControlHashTable.CompareKey(const Key1, Key2: string): Integer;\r\nbegin\r\n Result := AnsiStrComp(PChar(Key1), PChar(Key2));\r\nend;\r\n\r\nprocedure TJvDockControlHashTable.CreateDictionary(Size: Integer);\r\nbegin\r\n // (rom) secured against calling it several times\r\n if not Assigned(FEntryList) then\r\n begin\r\n FEntryList := TList.Create;\r\n FEntryList.Count := Size;\r\n FTableSize := Size;\r\n end;\r\nend;\r\n\r\nfunction TJvDockControlHashTable.CreateKeyNode(const KeyName: string;\r\n KeyData: Pointer; ListIndex: Integer): TJvDockClientHashNode;\r\nbegin\r\n Result := TJvDockClientHashNode.Create;\r\n Result.KeyName := KeyName;\r\n Result.KeyData := KeyData;\r\n Result.ListIndex := ListIndex;\r\nend;\r\n\r\nprocedure TJvDockControlHashTable.DeleteListIndex(Index: Integer);\r\nvar\r\n Node, NextNode: TJvDockClientHashNode;\r\nbegin\r\n Node := FEntryList[Index];\r\n while Node <> nil do\r\n begin\r\n NextNode := Node.NextNode;\r\n Node.Free;\r\n Node := NextNode;\r\n end;\r\n FEntryList.Delete(Index);\r\nend;\r\n\r\nfunction TJvDockControlHashTable.Find(const Name: string): Pointer;\r\nvar\r\n Node: TJvDockClientHashNode;\r\nbegin\r\n Node := FindNode(Name);\r\n if Node <> nil then\r\n Result := Node.KeyData\r\n else\r\n Result := nil;\r\nend;\r\n\r\nfunction TJvDockControlHashTable.FindNode(const Name: string): TJvDockClientHashNode;\r\nvar\r\n Value: Integer;\r\n ListIndex: Integer;\r\nbegin\r\n ListIndex := HashProc(Name);\r\n Assert((ListIndex >= 0) and (ListIndex < FTableSize), RsDockTableIndexError);\r\n Result := FEntryList[ListIndex];\r\n if Result <> nil then\r\n repeat\r\n Value := CompareKey(Name, Result.FKeyName);\r\n if Value = 0 then\r\n Break;\r\n Result := Result.FNextNode;\r\n until Result = nil;\r\nend;\r\n\r\nfunction TJvDockControlHashTable.HashProc(const Name: string): Integer;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := 0;\r\n for I := 1 to Length(Name) do\r\n Inc(Result, Ord(Name[I]));\r\n Result := Result mod FTableSize;\r\nend;\r\n\r\nfunction TJvDockControlHashTable.Insert(const Name: string; Data: Pointer): Integer;\r\nvar\r\n Index: Integer;\r\n Value: Integer;\r\n Node, ParentNode: TJvDockClientHashNode;\r\nbegin\r\n Result := -1;\r\n Index := HashProc(Name);\r\n Assert((Index >= 0) and (Index < FTableSize), RsDockTableIndexError);\r\n if FEntryList[Index] = nil then\r\n FEntryList[Index] := CreateKeyNode(Name, Data, Index)\r\n else\r\n begin\r\n Node := FEntryList[Index];\r\n ParentNode := nil;\r\n while Node <> nil do\r\n begin\r\n Value := CompareKey(Name, Node.FKeyName);\r\n\r\n if FRaiseException then\r\n Assert(Value <> 0, RsDockNodeExistedError)\r\n else\r\n if Value = 0 then\r\n Exit;\r\n ParentNode := Node;\r\n Node := Node.FNextNode;\r\n end;\r\n\r\n Node := CreateKeyNode(Name, Data, Index);\r\n Node.FPrevNode := ParentNode;\r\n ParentNode.NextNode := Node;\r\n end;\r\n Result := Index;\r\nend;\r\n\r\nfunction TJvDockControlHashTable.IsIn(const Name: string): Boolean;\r\nbegin\r\n Result := FindNode(Name) <> nil;\r\nend;\r\n\r\nprocedure TJvDockControlHashTable.MakeEmpty;\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := FEntryList.Count - 1 downto 0 do\r\n DeleteListIndex(I);\r\nend;\r\n\r\nprocedure TJvDockControlHashTable.Remove(const Name: string);\r\nvar\r\n Node: TJvDockClientHashNode;\r\nbegin\r\n Node := FindNode(Name);\r\n if Node <> nil then\r\n begin\r\n if Node.FPrevNode <> nil then\r\n Node.FPrevNode.FNextNode := Node.FNextNode\r\n else\r\n FEntryList[Node.ListIndex] := Node.FNextNode;\r\n if Node.FNextNode <> nil then\r\n Node.FNextNode.FPrevNode := Node.FPrevNode;\r\n Node.Free;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockControlHashTable.SetTableSize(const Value: Integer);\r\nbegin\r\n FEntryList.Count := Value;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvDockInfo.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvDockInfo.pas, released on 2003-12-31.\r\n\r\nThe Initial Developer of the Original Code is luxiaoban.\r\nPortions created by luxiaoban are Copyright (C) 2002,2003 luxiaoban.\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvDockInfo.pas 12461 2009-08-14 17:21:33Z obones $\r\n\r\nunit JvDockInfo;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, IniFiles, Registry, Classes, Controls, Forms,\r\n JvAppStorage, JvDockControlForm, JvDockSupportClass, JvDockSupportProc;\r\n\r\ntype\r\n TJvDockInfoTree = class;\r\n\r\n TJvDockFormStyle = (dsNormal, dsConjoin, dsTab, dsDockPanel);\r\n\r\n TJvDockInfoZone = class(TJvDockBaseZone)\r\n private\r\n FDockFormName: string;\r\n FParentName: string;\r\n FDockRect: TRect;\r\n FLastDockSiteName: string;\r\n FUnDockLeft: Integer;\r\n FUnDockTop: Integer;\r\n FLRDockWidth: Integer;\r\n FTBDockHeight: Integer;\r\n FUnDockWidth: Integer;\r\n FUnDockHeight: Integer;\r\n FVSPaneWidth: Integer;\r\n FVisible: Boolean;\r\n FBorderStyle: TBorderStyle;\r\n FFormStyle: TFormStyle;\r\n FWindowState: TWindowState;\r\n FCanDocked: Boolean;\r\n FEachOtherDocked: Boolean;\r\n FLeftDocked: Boolean;\r\n FTopDocked: Boolean;\r\n FRightDocked: Boolean;\r\n FBottomDocked: Boolean;\r\n FCustomDocked: Boolean; {NEW! Contains custom dock panel! }\r\n FDockFormStyle: TJvDockFormStyle;\r\n FDockClientData: string;\r\n FDockControl: TWinControl;\r\n function GetChildControlCount: Integer;\r\n public\r\n procedure SetDockInfoFromControlToNode(Control: TControl); virtual;\r\n procedure SetDockInfoFromNodeToControl(Control: TControl); virtual;\r\n procedure SetDockInfoFromDockControlToNode(DockControl: TJvDockBaseControl); virtual;\r\n procedure SetDockInfoFromNodeToDockControl(DockControl: TJvDockBaseControl); virtual;\r\n property DockFormName: string read FDockFormName write FDockFormName;\r\n property ParentName: string read FParentName write FParentName;\r\n property DockRect: TRect read FDockRect write FDockRect;\r\n property LastDockSiteName: string read FLastDockSiteName write FLastDockSiteName;\r\n property UnDockLeft: Integer read FUnDockLeft write FUnDockLeft;\r\n property UnDockTop: Integer read FUnDockTop write FUnDockTop;\r\n property LRDockWidth: Integer read FLRDockWidth write FLRDockWidth;\r\n property TBDockHeight: Integer read FTBDockHeight write FTBDockHeight;\r\n property UnDockWidth: Integer read FUnDockWidth write FUnDockWidth;\r\n property UnDockHeight: Integer read FUnDockHeight write FUnDockHeight;\r\n property VSPaneWidth: Integer read FVSPaneWidth write FVSPaneWidth;\r\n property BorderStyle: TBorderStyle read FBorderStyle write FBorderStyle;\r\n property FormStyle: TFormStyle read FFormStyle write FFormStyle;\r\n property WindowState: TWindowState read FWindowState write FWindowState;\r\n property Visible: Boolean read FVisible write FVisible;\r\n property CanDocked: Boolean read FCanDocked write FCanDocked;\r\n property EachOtherDocked: Boolean read FEachOtherDocked write FEachOtherDocked;\r\n property LeftDocked: Boolean read FLeftDocked write FLeftDocked;\r\n property TopDocked: Boolean read FTopDocked write FTopDocked;\r\n property RightDocked: Boolean read FRightDocked write FRightDocked;\r\n property BottomDocked: Boolean read FBottomDocked write FBottomDocked;\r\n property CustomDocked: Boolean read FCustomDocked write FCustomDocked; {NEW! Contains custom dock panel! }\r\n property DockFormStyle: TJvDockFormStyle read FDockFormStyle write FDockFormStyle;\r\n property DockClientData: string read FDockClientData write FDockClientData;\r\n property DockControl: TWinControl read FDockControl write FDockControl;\r\n end;\r\n\r\n // TJvDockInfoStyle enumerates the mode that is used when you call\r\n // TJvDockInfoTree.ScanTreeZone. This is a part of the code used to\r\n // implement persistence (loading and saving of docking layouts).\r\n //\r\n TJvDockInfoStyle =\r\n (isNone, { No mode set }\r\n isJVCLReadInfo, { Mode for this scan is JVCL App Storage Load }\r\n isJVCLWriteInfo, { Mode for this scan is JVCL App Storage Save }\r\n\r\n isReadFileInfo, { Mode for this scan is Text File Read. Backwards compatible. }\r\n isWriteFileInfo, { Mode for this scan is Text File Write. Backwards compatible. }\r\n\r\n isReadRegInfo, { Mode for this scan is registry Read }\r\n isWriteRegInfo); { Mode for this scan is registry Write }\r\n\r\n { JvDockInfoTree contains information about the docking tree. It is created\r\n as part of the persistence framework for the JvDocking components. In order\r\n to save or load docking layout you must create one of these objects and use\r\n it to store the information about the set of docked forms being managed by\r\n JvDocking. }\r\n TJvDockInfoTree = class(TJvDockBaseTree)\r\n private\r\n FAppStorage: TJvCustomAppStorage;\r\n FAppStoragePath: string;\r\n FDockInfoIni: TCustomIniFile;\r\n FDockInfoReg: TRegistry;\r\n FRegName: string;\r\n FJvDockInfoStyle: TJvDockInfoStyle; { Which action to do when doing a ScanTreeZone() recursive operation over the document tree. }\r\n FDataStream: TMemoryStream;\r\n function FindDockForm(const FormName: string): TCustomForm;\r\n function CreateHostControl(ATreeZone: TJvDockInfoZone): TWinControl;\r\n protected\r\n procedure ScanTreeZone(TreeZone: TJvDockBaseZone); override;\r\n procedure CreateZoneAndAddInfoFromAppStorage; virtual;\r\n procedure CreateZoneAndAddInfoFromIni; virtual;\r\n procedure CreateZoneAndAddInfoFromReg; virtual;\r\n procedure SetDockControlInfo(ATreeZone: TJvDockInfoZone); virtual;\r\n public\r\n constructor Create(TreeZone: TJvDockTreeZoneClass); override;\r\n destructor Destroy; override;\r\n\r\n // This is the most important function in this class, it basically\r\n // puts the important information from the application form into this\r\n // object.\r\n procedure CreateZoneAndAddInfoFromApp(Control: TControl); virtual;\r\n\r\n procedure ReadInfoFromAppStorage;\r\n procedure WriteInfoToAppStorage;\r\n property AppStorage: TJvCustomAppStorage read FAppStorage write FAppStorage;\r\n property AppStoragePath: string read FAppStoragePath write FAppStoragePath;\r\n procedure ReadInfoFromIni;\r\n procedure ReadInfoFromReg(const RegName: string);\r\n procedure WriteInfoToIni;\r\n procedure WriteInfoToReg(const RegName: string);\r\n property DockInfoIni: TCustomIniFile read FDockInfoIni write FDockInfoIni;\r\n property DockInfoReg: TRegistry read FDockInfoReg write FDockInfoReg;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvDockInfo.pas $';\r\n Revision: '$Revision: 12461 $';\r\n Date: '$Date: 2009-08-14 19:21:33 +0200 (ven. 14 août 2009) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n SysUtils,\r\n JvDockGlobals, JvDockVSNetStyle;\r\n\r\n//=== Local procedures =======================================================\r\n\r\nfunction FindDockForm(const FormName: string): TCustomForm;\r\nbegin\r\n if Pos(RsDockJvDockInfoSplitter, FormName) > 0 then\r\n Result := nil\r\n else\r\n Result := JvDockFindDockFormWithName(FormName);\r\nend;\r\n\r\nfunction FindDockPanel(const ControlName: string): TWinControl;\r\nvar\r\n Index: Word;\r\n DockServer: TJvDockServer;\r\nbegin\r\n Result := nil;\r\n Index := Pos(RsDockJvDockInfoSplitter, ControlName);\r\n if Index = 0 then\r\n Exit;\r\n Result := FindDockForm(Copy(ControlName, 1, Index - 1));\r\n if Result <> nil then\r\n begin\r\n DockServer := FindDockServer(Result);\r\n if DockServer <> nil then\r\n with DockServer do\r\n begin\r\n if Pos('TopDockPanel', ControlName) > Index then\r\n Result := TopDockPanel\r\n else\r\n if Pos('LeftDockPanel', ControlName) > Index then\r\n Result := LeftDockPanel\r\n else\r\n if Pos('BottomDockPanel', ControlName) > Index then\r\n Result := BottomDockPanel\r\n else\r\n if Pos('RightDockPanel', ControlName) > Index then\r\n Result := RightDockPanel\r\n else\r\n if Pos('CustomDockPanel', ControlName) > Index then\r\n Result := CustomDockPanel;\r\n\r\n // Mantis 3603: No more AV, Result may not always be a TJvDockVSNETPanel\r\n if (Result is TJvDockVSNETPanel) and (Pos('PopupPanel', ControlName) > 20) then\r\n Result := (Result as TJvDockVSNETPanel).VSChannel.VSPopupPanel;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction FindDockHost(const ControlName: string): TWinControl;\r\nbegin\r\n Result := FindDockForm(ControlName);\r\n if Result = nil then\r\n Result := FindDockPanel(ControlName);\r\nend;\r\n\r\n//=== { TJvDockInfoTree } ====================================================\r\n\r\nconstructor TJvDockInfoTree.Create(TreeZone: TJvDockTreeZoneClass);\r\nbegin\r\n inherited Create(TreeZone);\r\n FJvDockInfoStyle := isNone;\r\n FDataStream := TMemoryStream.Create;\r\nend;\r\n\r\ndestructor TJvDockInfoTree.Destroy;\r\nbegin\r\n inherited Destroy;\r\n FreeAndNil(FDataStream);\r\nend;\r\n\r\n{ Create an TJvDockConjoinHostForm or TJvDockTabHostForm when restoring a docking layout }\r\nfunction TJvDockInfoTree.CreateHostControl(ATreeZone: TJvDockInfoZone): TWinControl;\r\nvar\r\n Form: TForm;\r\n ADockClient: TJvDockClient;\r\nbegin\r\n { The dockinfo data that is saved, contains names of the values of ChildZone.DockControl\r\n Thus on loading it can be that no form with that DockControl name can be found;\r\n then DockControl will be nil\r\n }\r\n Result := nil;\r\n case ATreeZone.DockFormStyle of\r\n dsConjoin:\r\n if Assigned(TJvDockInfoZone(ATreeZone.ChildZone).DockControl) then\r\n begin\r\n Form := TJvDockConjoinHostForm.Create(Application);\r\n ADockClient := FindDockClient(TJvDockInfoZone(ATreeZone.ChildZone).DockControl);\r\n Result := ADockClient.CreateConjoinPanelClass(Form).Parent;\r\n end;\r\n dsTab:\r\n if Assigned(TJvDockInfoZone(ATreeZone.ChildZone).DockControl) then\r\n begin\r\n Form := TJvDockTabHostForm.Create(Application);\r\n ADockClient := FindDockClient(TJvDockInfoZone(ATreeZone.ChildZone).DockControl);\r\n Result := ADockClient.CreateTabDockClass(Form).Parent;\r\n end;\r\n end;\r\n if Result <> nil then\r\n Result.Name := ATreeZone.DockFormName;\r\nend;\r\n\r\n// CreateZoneAndAddInfoFromApp\r\n//\r\n// Control: TControl - note this is probably actually a TForm\r\n// descendant, since this library only supports form docking.\r\n//\r\n// This is the most important function in this class, it basically\r\n// puts the important information from the application form into this\r\n// object.\r\n//\r\n// This is used to take a form that is docked somewhere and extract all the\r\n// docking layout information contained inside it, and add it to this JvDockInfoTree\r\n// object, which can then be iterated through, stored to disk, etc. }\r\n\r\nprocedure TJvDockInfoTree.CreateZoneAndAddInfoFromApp(Control: TControl);\r\nvar\r\n I: TJvDockPosition; {was TAlign}\r\n J: Integer;\r\n TreeZone: TJvDockInfoZone;\r\n DockBaseControl: TJvDockBaseControl;\r\n TmpDockPanel: TJvDockPanel;\r\nbegin\r\n TreeZone := TJvDockInfoZone(AddChildZone(CurrTreeZone, nil));\r\n with TreeZone do\r\n begin\r\n ParentName := TJvDockInfoZone(CurrTreeZone).DockFormName;\r\n SetDockInfoFromControlToNode(Control);\r\n if Control is TJvDockPanel then\r\n DockFormName := TJvDockInfoZone(CurrTreeZone).DockFormName +\r\n RsDockJvDockInfoSplitter + Control.Name\r\n else\r\n DockFormName := Control.Name;\r\n FDataStream.Clear;\r\n if Control is TJvDockTabHostForm then\r\n TJvDockTabHostForm(Control).PageControl.SaveToStream(FDataStream)\r\n else\r\n if Control is TJvDockConjoinHostForm then\r\n TJvDockConjoinHostForm(Control).Panel.DockManager.SaveToStream(FDataStream)\r\n else\r\n if Control is TJvDockPanel then\r\n TJvDockPanel(Control).DockManager.SaveToStream(FDataStream);\r\n DockClientData := JvDockStreamDataToString(FDataStream);\r\n DockBaseControl := FindDockBaseControl(Control);\r\n if DockBaseControl <> nil then\r\n begin\r\n SetDockInfoFromDockControlToNode(DockBaseControl);\r\n if Control is TJvDockTabHostForm then\r\n DockFormStyle := dsTab\r\n else\r\n if Control is TJvDockConjoinHostForm then\r\n DockFormStyle := dsConjoin\r\n else\r\n DockFormStyle := dsNormal;\r\n if DockBaseControl is TJvDockClient then\r\n begin\r\n if Control is TJvDockableForm then\r\n with TJvDockableForm(Control).DockableControl do\r\n for J := 0 to DockClientCount - 1 do\r\n begin\r\n CurrTreeZone := TreeZone;\r\n CreateZoneAndAddInfoFromApp(DockClients[J]);\r\n CurrTreeZone := TreeZone.GetParentZone;\r\n end;\r\n end\r\n else\r\n begin\r\n // Changed to persist ALL DockPanels, not just Top,Left,Right,Bottom.\r\n // This is a hardcoded assumption throughout the component that is\r\n // proving hard to overcome.\r\n for I := Low(TJvDockPosition) to High(TJvDockPosition) do // There are 5 TJvDockPositions now ! {NEW!}\r\n begin\r\n CurrTreeZone := TreeZone;\r\n TmpDockPanel := TJvDockServer(DockBaseControl).DockPanel[I];\r\n if Assigned(TmpDockPanel) then\r\n begin\r\n CreateZoneAndAddInfoFromApp(TmpDockPanel);\r\n if TmpDockPanel is TJvDockVSNETPanel then // JvDockVSNetStyle specific:\r\n CreateZoneAndAddInfoFromApp(TJvDockVSNETPanel(TmpDockPanel).VSChannel.VSPopupPanel);\r\n end;\r\n CurrTreeZone := TreeZone.GetParentZone;\r\n end;\r\n end;\r\n end;\r\n\r\n if Control is TJvDockPanel then\r\n begin\r\n DockFormStyle := dsDockPanel;\r\n if Control is TJvDockVSPopupPanel then\r\n with TJvDockVSPopupPanel(Control) do\r\n for J := 0 to DockClientCount - 1 do\r\n begin\r\n CurrTreeZone := TreeZone;\r\n CreateZoneAndAddInfoFromApp(TWinControl(DockClients[J]));\r\n CurrTreeZone := TreeZone.GetParentZone;\r\n end\r\n else\r\n with TJvDockPanel(Control) do\r\n for J := 0 to DockClientCount - 1 do\r\n begin\r\n CurrTreeZone := TreeZone;\r\n CreateZoneAndAddInfoFromApp(TWinControl(DockClients[J]));\r\n CurrTreeZone := TreeZone.GetParentZone;\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockInfoTree.CreateZoneAndAddInfoFromAppStorage;\r\nvar\r\n FormList: TStringList;\r\n CP, CP1: PChar;\r\n S: string;\r\n I: Integer;\r\n OldPath: string;\r\n OldDefaultIfValueNotExists : Boolean;\r\n\r\n procedure CreateZoneAndAddInfo(Index: Integer);\r\n var\r\n I: Integer;\r\n TreeZone: TJvDockInfoZone;\r\n begin\r\n if FAppStorage.PathExists(FormList[Index]) then\r\n begin\r\n TreeZone := TJvDockInfoZone(AddChildZone(CurrTreeZone, nil));\r\n with TreeZone, FAppStorage do\r\n begin\r\n { Move down into the folder of the form.. }\r\n Path := ConcatPaths([Path, FormList[Index]]);\r\n\r\n DockFormName := FormList[Index];\r\n ParentName := ReadString('ParentName');\r\n DockRect := Rect(ReadInteger('DockLeft'), ReadInteger('DockTop'),\r\n ReadInteger('DockRight'), ReadInteger('DockBottom'));\r\n LRDockWidth := ReadInteger('LRDockWidth');\r\n LastDockSiteName := ReadString('LastDockSiteName');\r\n UnDockLeft := ReadInteger('UnDockLeft');\r\n UnDockTop := ReadInteger('UnDockTop');\r\n TBDockHeight := ReadInteger('TBDockHeight');\r\n UnDockWidth := ReadInteger('UnDockWidth');\r\n UnDockHeight := ReadInteger('UnDockHeight');\r\n VSPaneWidth := ReadInteger('VSPaneWidth');\r\n Visible := ReadBoolean('Visible');\r\n BorderStyle := TBorderStyle(ReadInteger('BorderStyle'));\r\n FormStyle := TFormStyle(ReadInteger('FormStyle'));\r\n WindowState := TWindowState(ReadInteger('WindowState'));\r\n DockFormStyle := TJvDockFormStyle(ReadInteger('DockFormStyle'));\r\n CanDocked := ReadBoolean('CanDocked');\r\n EachOtherDocked := ReadBoolean('EachOtherDocked');\r\n LeftDocked := ReadBoolean('LeftDocked');\r\n TopDocked := ReadBoolean('TopDocked');\r\n RightDocked := ReadBoolean('RightDocked');\r\n BottomDocked := ReadBoolean('BottomDocked');\r\n CustomDocked := ReadBoolean('CustomDocked'); {NEW}\r\n DockClientData := ReadString('DockClientData');\r\n\r\n { ..and move up a level }\r\n Path := ConcatPaths([Path, '..']);\r\n end;\r\n for I := Index - 1 downto 0 do\r\n begin\r\n { Search for forms that have this form (FormList[I]) as parent }\r\n if FAppStorage.ReadString(FAppStorage.ConcatPaths([FormList[I], 'ParentName'])) = FormList[Index] then\r\n begin\r\n CurrTreeZone := TreeZone;\r\n CreateZoneAndAddInfo(I);\r\n CurrTreeZone := TreeZone.GetParentZone;\r\n end;\r\n end;\r\n end;\r\n end;\r\n\r\nvar\r\n FormName: string;\r\nbegin\r\n FormList := TStringList.Create;\r\n FJvDockInfoStyle := isJVCLReadInfo; // set mode for Scan.\r\n try\r\n { Normally, we wouldn't find duplicate names, but if so ignore them otherwise havoc }\r\n FormList.Duplicates := dupIgnore;\r\n OldPath := FAppStorage.Path;\r\n OldDefaultIfValueNotExists := FAppStorage.StorageOptions.DefaultIfValueNotExists;\r\n FAppStorage.StorageOptions.DefaultIfValueNotExists := True;\r\n try\r\n FAppStorage.Path := FAppStorage.ConcatPaths([FAppStorage.Path, AppStoragePath, 'Forms']);\r\n if FAppStorage.ValueStored('FormNames') then\r\n begin\r\n S := FAppStorage.ReadString('FormNames');\r\n CP := PChar(S);\r\n CP1 := StrPos(CP, ';');\r\n while CP1 <> nil do\r\n begin\r\n SetString(FormName, CP, CP1 - CP);\r\n // (Mantis #4293) Avoid restoration of not instantiated forms => DockFormStyle == dsNormal\r\n if TJvDockFormStyle(FAppStorage.ReadInteger(\r\n FAppStorage.ConcatPaths([FormName, 'DockFormStyle']))) = dsNormal then\r\n begin\r\n for I := 0 to Screen.FormCount - 1 do\r\n begin\r\n if Screen.Forms[I].Name = FormName then\r\n begin\r\n FormList.Add(FormName);\r\n Break;\r\n end;\r\n end;\r\n end\r\n else\r\n FormList.Add(FormName);\r\n CP := CP1 + 1;\r\n CP1 := StrPos(CP, ';');\r\n end;\r\n for I := FormList.Count - 1 downto 0 do\r\n if FAppStorage.ReadString(FAppStorage.ConcatPaths([FormList[I], 'ParentName'])) = '' then\r\n CreateZoneAndAddInfo(I);\r\n end;\r\n finally\r\n FAppStorage.Path := OldPath;\r\n FAppStorage.StorageOptions.DefaultIfValueNotExists := OldDefaultIfValueNotExists;\r\n end;\r\n finally\r\n FormList.Free;\r\n FJvDockInfoStyle := isNone;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockInfoTree.CreateZoneAndAddInfoFromIni;\r\nvar\r\n I: Integer;\r\n Sections: TStringList;\r\n TempDockInfoZoneArray: array of TJvDockInfoZone;\r\n\r\n procedure CreateTempDockInfoZoneArray;\r\n var\r\n I: Integer;\r\n begin\r\n SetLength(TempDockInfoZoneArray, SizeOf(TJvDockInfoZone) * Sections.Count);\r\n for I := 0 to Sections.Count - 1 do\r\n begin\r\n TempDockInfoZoneArray[I] := TJvDockInfoZone.Create(nil);\r\n with TempDockInfoZoneArray[I], DockInfoIni do\r\n begin\r\n DockFormName := Sections[I];\r\n ParentName := ReadString(DockFormName, 'ParentName', 'ERROR');\r\n DockRect := Rect(ReadInteger(DockFormName, 'DockLeft', 0),\r\n ReadInteger(DockFormName, 'DockTop', 0),\r\n ReadInteger(DockFormName, 'DockRight', 100),\r\n ReadInteger(DockFormName, 'DockBottom', 100));\r\n LastDockSiteName := ReadString(DockFormName, 'LastDockSiteName', 'ERROR');\r\n UnDockLeft := ReadInteger(DockFormName, 'UnDockLeft', 100);\r\n UnDockTop := ReadInteger(DockFormName, 'UnDockTop', 100);\r\n LRDockWidth := ReadInteger(DockFormName, 'LRDockWidth', 100);\r\n TBDockHeight := ReadInteger(DockFormName, 'TBDockHeight', 100);\r\n UnDockWidth := ReadInteger(DockFormName, 'UnDockWidth', 100);\r\n UnDockHeight := ReadInteger(DockFormName, 'UnDockHeight', 100);\r\n VSPaneWidth := ReadInteger(DockFormName, 'VSPaneWidth', 100);\r\n Visible := ReadBool(DockFormName, 'Visible', True);\r\n BorderStyle := TBorderStyle(ReadInteger(DockFormName, 'BorderStyle', 0));\r\n FormStyle := TFormStyle(ReadInteger(DockFormName, 'FormStyle', 0));\r\n WindowState := TWindowState(ReadInteger(DockFormName, 'WindowState', 0));\r\n DockFormStyle := TJvDockFormStyle(ReadInteger(DockFormName, 'DockFormStyle', 0));\r\n CanDocked := ReadBool(DockFormName, 'CanDocked', True);\r\n EachOtherDocked := ReadBool(DockFormName, 'EachOtherDocked', True);\r\n LeftDocked := ReadBool(DockFormName, 'LeftDocked', LeftDocked);\r\n TopDocked := ReadBool(DockFormName, 'TopDocked', True);\r\n RightDocked := ReadBool(DockFormName, 'RightDocked', True);\r\n BottomDocked := ReadBool(DockFormName, 'BottomDocked', True);\r\n CustomDocked := ReadBool(DockFormName, 'CustomDocked', True);\r\n DockClientData := ReadString(DockFormName, 'DockClientData', '');\r\n end;\r\n end;\r\n end;\r\n\r\n procedure DestroyTempDockInfoZoneArray;\r\n var\r\n I: Integer;\r\n begin\r\n for I := Sections.Count - 1 downto 0 do\r\n TempDockInfoZoneArray[I].Free;\r\n end;\r\n\r\n procedure CreateZoneAndAddInfo(Index: Integer);\r\n var\r\n I: Integer;\r\n TreeZone: TJvDockInfoZone;\r\n begin\r\n TreeZone := TJvDockInfoZone(AddChildZone(CurrTreeZone, nil));\r\n\r\n with TempDockInfoZoneArray[Index] do\r\n begin\r\n TreeZone.DockFormName := DockFormName;\r\n TreeZone.ParentName := ParentName;\r\n TreeZone.DockRect := DockRect;\r\n TreeZone.LastDockSiteName := LastDockSiteName;\r\n TreeZone.UnDockLeft := UnDockLeft;\r\n TreeZone.UnDockTop := UnDockTop;\r\n TreeZone.LRDockWidth := LRDockWidth;\r\n TreeZone.TBDockHeight := TBDockHeight;\r\n TreeZone.UnDockWidth := UnDockWidth;\r\n TreeZone.UnDockHeight := UnDockHeight;\r\n TreeZone.VSPaneWidth := VSPaneWidth;\r\n TreeZone.Visible := Visible;\r\n TreeZone.BorderStyle := BorderStyle;\r\n TreeZone.FormStyle := FormStyle;\r\n TreeZone.WindowState := WindowState;\r\n TreeZone.DockFormStyle := DockFormStyle;\r\n TreeZone.CanDocked := CanDocked;\r\n TreeZone.EachOtherDocked := EachOtherDocked;\r\n TreeZone.LeftDocked := LeftDocked;\r\n TreeZone.TopDocked := TopDocked;\r\n TreeZone.RightDocked := RightDocked;\r\n TreeZone.BottomDocked := BottomDocked;\r\n TreeZone.CustomDocked := CustomDocked; {NEW!}\r\n TreeZone.DockClientData := DockClientData;\r\n end;\r\n\r\n for I := Index - 1 downto 0 do\r\n if TempDockInfoZoneArray[I].ParentName = Sections[Index] then\r\n begin\r\n CurrTreeZone := TreeZone;\r\n CreateZoneAndAddInfo(I);\r\n CurrTreeZone := TreeZone.GetParentZone;\r\n end;\r\n end;\r\n\r\nbegin\r\n Sections := TStringList.Create;\r\n try\r\n DockInfoIni.ReadSections(Sections);\r\n CreateTempDockInfoZoneArray;\r\n for I := Sections.Count - 1 downto 0 do\r\n if TempDockInfoZoneArray[I].ParentName = '' then\r\n CreateZoneAndAddInfo(I);\r\n FJvDockInfoStyle := isNone;\r\n finally\r\n DestroyTempDockInfoZoneArray;\r\n Sections.Free;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockInfoTree.CreateZoneAndAddInfoFromReg;\r\nvar\r\n FormList: TStringList;\r\n CP, CP1: PChar;\r\n I: Integer;\r\n S: string;\r\n\r\n procedure CreateZoneAndAddInfo(Index: Integer);\r\n var\r\n I: Integer;\r\n TreeZone: TJvDockInfoZone;\r\n begin\r\n DockInfoReg.OpenKey(FRegName, False);\r\n if DockInfoReg.KeyExists(FormList[Index]) then\r\n begin\r\n DockInfoReg.OpenKey(FRegName + '\\' + FormList[Index], False);\r\n TreeZone := TJvDockInfoZone(AddChildZone(CurrTreeZone, nil));\r\n with TreeZone, DockInfoReg do\r\n begin\r\n DockFormName := FormList[Index];\r\n ParentName := ReadString('ParentName');\r\n DockRect := Rect(ReadInteger('DockLeft'), ReadInteger('DockTop'),\r\n ReadInteger('DockRight'), ReadInteger('DockBottom'));\r\n LRDockWidth := ReadInteger('LRDockWidth');\r\n LastDockSiteName := ReadString('LastDockSiteName');\r\n UnDockLeft := ReadInteger('UnDockLeft');\r\n UnDockTop := ReadInteger('UnDockTop');\r\n TBDockHeight := ReadInteger('TBDockHeight');\r\n UnDockWidth := ReadInteger('UnDockWidth');\r\n UnDockHeight := ReadInteger('UnDockHeight');\r\n VSPaneWidth := ReadInteger('VSPaneWidth');\r\n Visible := ReadBool('Visible');\r\n BorderStyle := TBorderStyle(ReadInteger('BorderStyle'));\r\n FormStyle := TFormStyle(ReadInteger('FormStyle'));\r\n WindowState := TWindowState(ReadInteger('WindowState'));\r\n DockFormStyle := TJvDockFormStyle(ReadInteger('DockFormStyle'));\r\n CanDocked := ReadBool('CanDocked');\r\n EachOtherDocked := ReadBool('EachOtherDocked');\r\n LeftDocked := ReadBool('LeftDocked');\r\n TopDocked := ReadBool('TopDocked');\r\n RightDocked := ReadBool('RightDocked');\r\n BottomDocked := ReadBool('BottomDocked');\r\n CustomDocked := ReadBool('CustomDocked'); {NEW!}\r\n DockClientData := ReadString('DockClientData');\r\n end;\r\n for I := Index - 1 downto 0 do\r\n begin\r\n DockInfoReg.OpenKey(FRegName + '\\' + FormList[I], False);\r\n if DockInfoReg.ReadString('ParentName') = FormList[Index] then\r\n begin\r\n CurrTreeZone := TreeZone;\r\n CreateZoneAndAddInfo(I);\r\n CurrTreeZone := TreeZone.GetParentZone;\r\n end;\r\n end;\r\n end;\r\n end;\r\n\r\nbegin\r\n FormList := TStringList.Create;\r\n try\r\n if DockInfoReg.OpenKey(FRegName, False) then\r\n begin\r\n S := DockInfoReg.ReadString('FormNames');\r\n CP := PChar(S);\r\n CP1 := StrPos(CP, '\\');\r\n while CP1 <> nil do\r\n begin\r\n CP1^ := #0;\r\n FormList.Add(CP);\r\n CP := CP1 + 1;\r\n CP1 := StrPos(CP, '\\');\r\n end;\r\n FJvDockInfoStyle := isReadFileInfo;\r\n for I := FormList.Count - 1 downto 0 do\r\n begin\r\n DockInfoReg.OpenKey(FRegName + '\\' + FormList[I], False);\r\n if DockInfoReg.ReadString('ParentName') = '' then\r\n CreateZoneAndAddInfo(I);\r\n end;\r\n FJvDockInfoStyle := isNone;\r\n end;\r\n finally\r\n DockInfoReg.CloseKey;\r\n FormList.Free;\r\n end;\r\nend;\r\n\r\nfunction TJvDockInfoTree.FindDockForm(const FormName: string): TCustomForm;\r\nbegin\r\n if Pos(RsDockJvDockInfoSplitter, FormName) > 0 then\r\n Result := nil\r\n else\r\n Result := JvDockFindDockFormWithName(FormName);\r\nend;\r\n\r\nprocedure TJvDockInfoTree.ReadInfoFromAppStorage;\r\nbegin\r\n AppStorage.BeginUpdate;\r\n try\r\n CreateZoneAndAddInfoFromAppStorage;\r\n DoFloatAllForm;\r\n // (rom) this is disputable\r\n Application.ProcessMessages;\r\n try\r\n FJvDockInfoStyle := isJVCLReadInfo;\r\n MiddleScanTree(TopTreeZone);\r\n finally\r\n FJvDockInfoStyle := isNone;\r\n end;\r\n finally\r\n AppStorage.EndUpdate;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockInfoTree.ReadInfoFromIni;\r\nbegin\r\n CreateZoneAndAddInfoFromIni;\r\n\r\n DoFloatAllForm;\r\n\r\n // (rom) this is disputable\r\n Application.ProcessMessages;\r\n\r\n FJvDockInfoStyle := isJVCLReadInfo;\r\n MiddleScanTree(TopTreeZone);\r\n FJvDockInfoStyle := isNone;\r\nend;\r\n\r\nprocedure TJvDockInfoTree.ReadInfoFromReg(const RegName: string);\r\nbegin\r\n FRegName := RegName;\r\n CreateZoneAndAddInfoFromReg;\r\n\r\n DoFloatAllForm;\r\n\r\n // (rom) this is disputable\r\n Application.ProcessMessages;\r\n\r\n FJvDockInfoStyle := isReadRegInfo;\r\n MiddleScanTree(TopTreeZone);\r\n FJvDockInfoStyle := isNone;\r\nend;\r\n\r\nprocedure TJvDockInfoTree.ScanTreeZone(TreeZone: TJvDockBaseZone);\r\nvar\r\n I: Integer;\r\n OldPath: string;\r\n\r\n procedure WriteIntegerIfNonZero(const Path: string; Value: Integer);\r\n begin\r\n if Value <> 0 then\r\n fAppStorage.WriteInteger(Path, Value);\r\n end;\r\n\r\n procedure WriteBooleanIfFalse(const Path: string; Value: Boolean);\r\n begin\r\n if not Value then\r\n fAppStorage.WriteBoolean(Path, Value);\r\n end;\r\n\r\n\r\nbegin\r\n if FJvDockInfoStyle = isJVCLReadInfo then { JVCL Mode persistance : READ }\r\n begin\r\n for I := 0 to TreeZone.GetChildCount - 1 do\r\n with TJvDockInfoZone(TreeZone.GetChildZone(I)) do\r\n DockControl := FindDockForm(DockFormName);\r\n SetDockControlInfo(TJvDockInfoZone(TreeZone));\r\n end\r\n else\r\n if FJvDockInfoStyle = isJVCLWriteInfo then { JVCL Mode persistance : WRITE }\r\n begin\r\n if TreeZone <> TopTreeZone then\r\n with TJvDockInfoZone(TreeZone), FAppStorage do\r\n begin\r\n OldPath := Path;\r\n try\r\n Path := ConcatPaths([Path, AppStoragePath, 'Forms']);\r\n WriteString('FormNames', ReadString('FormNames') + DockFormName + ';');\r\n Path := ConcatPaths([Path, DockFormName]);\r\n WriteString('ParentName', ParentName);\r\n WriteIntegerIfNonZero('DockLeft', DockRect.Left);\r\n WriteIntegerIfNonZero('DockTop', DockRect.Top);\r\n WriteIntegerIfNonZero('DockRight', DockRect.Right);\r\n WriteIntegerIfNonZero('DockBottom', DockRect.Bottom);\r\n WriteString('LastDockSiteName', LastDockSiteName);\r\n WriteIntegerIfNonZero('UnDockLeft', UnDockLeft);\r\n WriteIntegerIfNonZero('UnDockTop', UnDockTop);\r\n WriteIntegerIfNonZero('LRDockWidth', LRDockWidth);\r\n WriteIntegerIfNonZero('TBDockHeight', TBDockHeight);\r\n WriteIntegerIfNonZero('UnDockWidth', UnDockWidth);\r\n WriteIntegerIfNonZero('UnDockHeight', UnDockHeight);\r\n WriteIntegerIfNonZero('VSPaneWidth', VSPaneWidth);\r\n WriteBooleanIfFalse('Visible', Visible);\r\n WriteIntegerIfNonZero('BorderStyle', Integer(BorderStyle));\r\n WriteIntegerIfNonZero('FormStyle', Integer(FormStyle));\r\n WriteIntegerIfNonZero('WindowState', Integer(WindowState));\r\n WriteIntegerIfNonZero('DockFormStyle', Integer(DockFormStyle));\r\n WriteBooleanIfFalse('CanDocked', CanDocked);\r\n WriteBooleanIfFalse('EachOtherDocked', EachOtherDocked);\r\n WriteBooleanIfFalse('LeftDocked', LeftDocked);\r\n WriteBooleanIfFalse('TopDocked', TopDocked);\r\n WriteBooleanIfFalse('RightDocked', RightDocked);\r\n WriteBooleanIfFalse('BottomDocked', BottomDocked);\r\n WriteBooleanIfFalse('CustomDocked', CustomDocked); {NEW!}\r\n WriteString('DockClientData', DockClientData);\r\n finally\r\n FAppStorage.Path := OldPath;\r\n end;\r\n end;\r\n end;\r\n inherited ScanTreeZone(TreeZone);\r\nend;\r\n\r\nprocedure TJvDockInfoTree.SetDockControlInfo(ATreeZone: TJvDockInfoZone);\r\nvar\r\n DockBaseControl: TJvDockBaseControl;\r\n Host: TWinControl;\r\nbegin\r\n with ATreeZone do\r\n begin\r\n if DockFormName = '' then\r\n Exit;\r\n Host := FindDockHost(DockFormName);\r\n if (Host = nil) and (ATreeZone.GetChildControlCount > 1) then\r\n Host := CreateHostControl(ATreeZone);\r\n if (Host <> nil) and (DockClientData <> '') and (FDataStream <> nil) then\r\n begin\r\n FDataStream.Clear;\r\n\r\n JvDockStringToStreamData(FDataStream, DockClientData);\r\n\r\n FDataStream.Position := 0;\r\n if Host is TJvDockTabHostForm then\r\n begin\r\n with TJvDockTabHostForm(Host).PageControl do\r\n begin\r\n DisableAlign;\r\n try\r\n LoadFromStream(FDataStream);\r\n finally\r\n EnableAlign;\r\n end;\r\n end;\r\n end\r\n else\r\n if Host is TJvDockConjoinHostForm then\r\n begin\r\n with TJvDockConjoinHostForm(Host).Panel do\r\n begin\r\n DisableAlign;\r\n try\r\n DockManager.LoadFromStream(FDataStream);\r\n finally\r\n EnableAlign;\r\n end;\r\n end;\r\n end\r\n else\r\n if Host is TJvDockPanel then\r\n begin\r\n with TJvDockPanel(Host) do\r\n begin\r\n DisableAlign;\r\n try\r\n DockManager.LoadFromStream(FDataStream);\r\n finally\r\n EnableAlign;\r\n end;\r\n end;\r\n end;\r\n end;\r\n if Host <> nil then\r\n begin\r\n SetDockInfoFromNodeToControl(Host);\r\n DockBaseControl := FindDockBaseControl(Host);\r\n if DockBaseControl <> nil then\r\n SetDockInfoFromNodeToDockControl(DockBaseControl);\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockInfoTree.WriteInfoToAppStorage;\r\nbegin\r\n AppStorage.BeginUpdate;\r\n try\r\n AppStorage.DeleteSubTree(AppStoragePath);\r\n try\r\n FJvDockInfoStyle := isJVCLWriteInfo;\r\n MiddleScanTree(TopTreeZone);\r\n finally\r\n FJvDockInfoStyle := isNone;\r\n end;\r\n finally\r\n AppStorage.EndUpdate;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockInfoTree.WriteInfoToIni;\r\nvar\r\n Sections: TStringList;\r\n I: Integer;\r\nbegin\r\n Sections := TStringList.Create;\r\n try\r\n DockInfoIni.ReadSections(Sections);\r\n\r\n for I := 0 to Sections.Count - 1 do\r\n DockInfoIni.EraseSection(Sections[I]);\r\n finally\r\n Sections.Free;\r\n end;\r\n FJvDockInfoStyle := isJVCLWriteInfo;\r\n MiddleScanTree(TopTreeZone);\r\n FJvDockInfoStyle := isNone;\r\nend;\r\n\r\nprocedure TJvDockInfoTree.WriteInfoToReg(const RegName: string);\r\nbegin\r\n try\r\n if DockInfoReg.OpenKey(RegName, False) then\r\n DockInfoReg.DeleteKey(RegName);\r\n\r\n DockInfoReg.CreateKey(RegName);\r\n DockInfoReg.CloseKey;\r\n FRegName := RegName;\r\n\r\n FJvDockInfoStyle := isWriteRegInfo;\r\n MiddleScanTree(TopTreeZone);\r\n FJvDockInfoStyle := isNone;\r\n finally\r\n DockInfoReg.CloseKey;\r\n end;\r\nend;\r\n\r\n//=== { TJvDockInfoZone } ====================================================\r\n\r\nfunction TJvDockInfoZone.GetChildControlCount: Integer;\r\nvar\r\n Zone: TJvDockBaseZone;\r\nbegin\r\n Result := 0;\r\n if ChildZone <> nil then\r\n begin\r\n Inc(Result);\r\n Zone := ChildZone;\r\n while Zone.NextSibling <> nil do\r\n begin\r\n Zone := Zone.NextSibling;\r\n if TJvDockInfoZone(Zone).DockControl <> nil then\r\n Inc(Result);\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockInfoZone.SetDockInfoFromControlToNode(Control: TControl);\r\nbegin\r\n DockRect := Control.BoundsRect;\r\n UnDockWidth := Control.UnDockWidth;\r\n UnDockHeight := Control.UnDockHeight;\r\n if Control is TJvDockVSPopupPanel then\r\n Control.Visible := False\r\n else\r\n Visible := Control.Visible;\r\n\r\n if Control is TForm then\r\n begin\r\n BorderStyle := TForm(Control).BorderStyle;\r\n FormStyle := TForm(Control).FormStyle;\r\n WindowState := TForm(Control).WindowState;\r\n LRDockWidth := Control.LRDockWidth;\r\n TBDockHeight := Control.TBDockHeight;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockInfoZone.SetDockInfoFromDockControlToNode(DockControl: TJvDockBaseControl);\r\n\r\n function GetLastDockSiteName(AControl: TControl): string;\r\n begin\r\n Result := RsDockCannotFindWindow;\r\n if AControl <> nil then\r\n begin\r\n if AControl.Parent is TJvDockableForm then\r\n Result := AControl.Parent.Name\r\n else\r\n if AControl is TJvDockPanel then\r\n Result := AControl.Parent.Name + RsDockJvDockInfoSplitter + AControl.Name;\r\n end;\r\n end;\r\n\r\nbegin\r\n CanDocked := DockControl.EnableDock;\r\n EachOtherDocked := DockControl.EachOtherDock;\r\n LeftDocked := DockControl.LeftDock;\r\n TopDocked := DockControl.TopDock;\r\n RightDocked := DockControl.RightDock;\r\n BottomDocked := DockControl.BottomDock;\r\n CustomDocked := DockControl.CustomDock; {NEW!}\r\n\r\n if DockControl is TJvDockClient then\r\n begin\r\n VSPaneWidth := TJvDockClient(DockControl).VSPaneWidth;\r\n UnDockLeft := TJvDockClient(DockControl).UnDockLeft;\r\n UnDockTop := TJvDockClient(DockControl).UnDockTop;\r\n LastDockSiteName := GetLastDockSiteName(TJvDockClient(DockControl).LastDockSite);\r\n end\r\n else\r\n VSPaneWidth := 0;\r\nend;\r\n\r\n{ When restoring a Control (form) properties when loading layout, this sets one form's properties.}\r\n\r\nprocedure TJvDockInfoZone.SetDockInfoFromNodeToControl(Control: TControl);\r\nvar\r\n DS: TJvDockServer;\r\n\r\n procedure SetPopupPanelSize(PopupPanel: TJvDockVSPopupPanel);\r\n begin\r\n end;\r\n\r\n procedure SetDockSiteSize(DockSite: TJvDockPanel);\r\n begin\r\n if DockSite.Align in [alTop, alBottom] then\r\n DockSite.JvDockManager.DockSiteSize := DockRect.Bottom - DockRect.Top\r\n else\r\n DockSite.JvDockManager.DockSiteSize := DockRect.Right - DockRect.Left;\r\n end;\r\n\r\nbegin\r\n if (ParentName = '') or ((Control is TJvDockPanel) and\r\n (TJvDockPanel(Control).VisibleDockClientCount > 0)) then\r\n begin\r\n TWinControl(Control).DisableAlign;\r\n try\r\n if Control is TForm then\r\n begin\r\n TForm(Control).BorderStyle := BorderStyle;\r\n TForm(Control).FormStyle := FormStyle;\r\n if WindowState = wsNormal then\r\n Control.BoundsRect := DockRect;\r\n TForm(Control).WindowState := WindowState;\r\n end\r\n else\r\n begin\r\n if Control is TJvDockVSPopupPanel then\r\n SetPopupPanelSize(Control as TJvDockVSPopupPanel)\r\n else\r\n SetDockSiteSize(Control as TJvDockPanel);\r\n end;\r\n DS := FindDockServer(Control);\r\n if DS <> nil then\r\n begin\r\n DS.GetClientAlignControl(alTop);\r\n DS.GetClientAlignControl(alBottom);\r\n DS.GetClientAlignControl(alLeft);\r\n DS.GetClientAlignControl(alRight);\r\n end;\r\n finally\r\n TWinControl(Control).EnableAlign;\r\n end;\r\n end;\r\n// // KV to avoid flickering in Vista\r\n// if not ((Control is TForm) and (ParentName <> '')) then\r\n Control.Visible := Visible;\r\n Control.LRDockWidth := LRDockWidth;\r\n Control.TBDockHeight := TBDockHeight;\r\n Control.UnDockHeight := UnDockHeight;\r\n Control.UnDockWidth := UnDockWidth;\r\nend;\r\n\r\n{ Restores settings in the TjvDockClient inside the form, when loading docking layout. }\r\n\r\nprocedure TJvDockInfoZone.SetDockInfoFromNodeToDockControl(DockControl: TJvDockBaseControl);\r\n\r\n function GetLastDockSite(const AName: string): TWinControl;\r\n begin\r\n Result := FindDockPanel(AName);\r\n if Result = nil then\r\n begin\r\n Result := FindDockForm(AName);\r\n if Result is TJvDockableForm then\r\n Result := TJvDockableForm(Result).DockableControl;\r\n end;\r\n end;\r\n\r\nbegin\r\n if DockControl is TJvDockClient then\r\n begin\r\n TJvDockClient(DockControl).UnDockLeft := UnDockLeft;\r\n TJvDockClient(DockControl).UnDockTop := UnDockTop;\r\n TJvDockClient(DockControl).LastDockSite := GetLastDockSite(LastDockSiteName);\r\n if Visible then\r\n begin\r\n TJvDockClient(DockControl).ParentVisible := False;\r\n TJvDockClient(DockControl).MakeShowEvent;\r\n end\r\n else\r\n TJvDockClient(DockControl).MakeHideEvent;\r\n TJvDockClient(DockControl).VSPaneWidth := VSPaneWidth;\r\n end;\r\n DockControl.EnableDock := CanDocked;\r\n DockControl.LeftDock := LeftDocked;\r\n DockControl.TopDock := TopDocked;\r\n DockControl.BottomDock := BottomDocked;\r\n DockControl.CustomDock := CustomDocked; {NEW!}\r\n DockControl.RightDock := RightDocked;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvDockSupportClass.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvDockSupportClass.pas, released on 2003-12-31.\r\n\r\nThe Initial Developer of the Original Code is luxiaoban.\r\nPortions created by luxiaoban are Copyright (C) 2002,2003 luxiaoban.\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvDockSupportClass.pas 13104 2011-09-07 06:50:43Z obones $\r\n\r\nunit JvDockSupportClass;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, SysUtils, Messages, Classes, Controls, Forms;\r\n\r\ntype\r\n TJvDockBaseTree = class;\r\n\r\n { TJvDockBaseZone: A node in a tree.\r\n\r\n This should probably be called TJvDockTreeItem since this is\r\n the base Item type for items managed by the tree\r\n TJvDockBaseTree.\r\n }\r\n\r\n TJvDockBaseZone = class(TObject)\r\n private\r\n FBaseTree: TJvDockBaseTree;\r\n FChildZone: TJvDockBaseZone;\r\n FNextSibling: TJvDockBaseZone;\r\n FPrevSibling: TJvDockBaseZone;\r\n FParentZone: TJvDockBaseZone;\r\n protected\r\n function GetNextSibingCount: Integer;\r\n function GetPrevSibingCount: Integer;\r\n public\r\n constructor Create(BaseTree: TJvDockBaseTree); virtual;\r\n destructor Destroy; override;\r\n\r\n function CreateChildZone: TJvDockBaseZone;\r\n function GetParentZone: TJvDockBaseZone; virtual;\r\n function GetChildCount: Integer;\r\n function GetChildZone(Index: Word): TJvDockBaseZone;\r\n property BaseTree: TJvDockBaseTree read FBaseTree write FBaseTree;\r\n property ChildZone: TJvDockBaseZone read FChildZone write FChildZone;\r\n property NextSibling: TJvDockBaseZone read FNextSibling write FNextSibling;\r\n property PrevSibling: TJvDockBaseZone read FPrevSibling write FPrevSibling;\r\n property ParentZone: TJvDockBaseZone read FParentZone write FParentZone;\r\n end;\r\n\r\n TJvDockScanZoneNotification = (snNone, snAdded, snExtracted, snDeleted);\r\n\r\n TJvDockTreeZoneClass = class of TJvDockBaseZone;\r\n\r\n TJvDockScanTreeZoneProc = procedure(TreeZone: TJvDockBaseZone);\r\n\r\n TJvDockBaseTree = class(TObject)\r\n private\r\n FScanAction: TJvDockScanZoneNotification;\r\n FTreeZoneClass: TJvDockTreeZoneClass;\r\n FTopTreeZone: TJvDockBaseZone;\r\n FCurrTreeZone: TJvDockBaseZone;\r\n FScanZoneProc: TJvDockScanTreeZoneProc;\r\n protected\r\n procedure ForwardScanTree(TreeZone: TJvDockBaseZone); virtual;\r\n procedure BackwardScanTree(TreeZone: TJvDockBaseZone); virtual;\r\n procedure MiddleScanTree(TreeZone: TJvDockBaseZone); virtual;\r\n procedure ScanTreeZone(TreeZone: TJvDockBaseZone); virtual;\r\n public\r\n constructor Create(TreeZone: TJvDockTreeZoneClass); virtual;\r\n destructor Destroy; override;\r\n {$IFDEF JVDOCK_DEBUG}\r\n // This helps us to understand the content of the tree by allowing\r\n // us to build a dump:\r\n procedure DebugDump(var Index: Integer; Indent, Entity: string; TreeZone: TJvDockBaseZone; Strs: TStrings); //virtual;\r\n {$ENDIF JVDOCK_DEBUG}\r\n function AddChildZone(TreeZone, NewZone: TJvDockBaseZone): TJvDockBaseZone; virtual;\r\n function AddNextSibling(TreeZone, NewZone: TJvDockBaseZone): TJvDockBaseZone; virtual;\r\n function AddPrevSibling(TreeZone, NewZone: TJvDockBaseZone): TJvDockBaseZone; virtual;\r\n function AddParentZone(TreeZone, NewZone: TJvDockBaseZone): TJvDockBaseZone; virtual;\r\n procedure RemoveChildZone(TreeZone: TJvDockBaseZone); virtual;\r\n procedure RemoveNextSibling(TreeZone: TJvDockBaseZone); virtual;\r\n procedure RemovePrevSibling(TreeZone: TJvDockBaseZone); virtual;\r\n procedure RemoveParentZone(TreeZone: TJvDockBaseZone); virtual;\r\n property TreeZoneClass: TJvDockTreeZoneClass read FTreeZoneClass write FTreeZoneClass;\r\n property TopTreeZone: TJvDockBaseZone read FTopTreeZone write FTopTreeZone;\r\n property CurrTreeZone: TJvDockBaseZone read FCurrTreeZone write FCurrTreeZone;\r\n property ScanZoneProc: TJvDockScanTreeZoneProc read FScanZoneProc write FScanZoneProc;\r\n end;\r\n\r\n TJvDockBaseGetFormEventComponent = class(TComponent)\r\n private\r\n FOldOnActivate: TNotifyEvent;\r\n FOldOnClose: TCloseEvent;\r\n FOldOnCloseQuery: TCloseQueryEvent;\r\n FOldOnCreate: TNotifyEvent;\r\n FOldOnDeactivate: TNotifyEvent;\r\n FOldOnDestroy: TNotifyEvent;\r\n FOldOnHelp: THelpEvent;\r\n FOldOnHide: TNotifyEvent;\r\n FOldOnPaint: TNotifyEvent;\r\n FOldOnShortCut: TShortCutEvent;\r\n FOldOnShow: TNotifyEvent;\r\n FOldOnDockDrop: TDockDropEvent;\r\n FOldOnDockOver: TDockOverEvent;\r\n FOldOnExit: TNotifyEvent;\r\n FOldOnGetSiteInfo: TGetSiteInfoEvent;\r\n FOldOnKeyDown: TKeyEvent;\r\n FOldOnKeyPress: TKeyPressEvent;\r\n FOldOnKeyUp: TKeyEvent;\r\n FOldOnMouseWheel: TMouseWheelEvent;\r\n FOldOnMouseWheelDown: TMouseWheelUpDownEvent;\r\n FOldOnMouseWheelUp: TMouseWheelUpDownEvent;\r\n FOldOnUndock: TUnDockEvent;\r\n FOldOnCanResize: TCanResizeEvent;\r\n FOldOnClick: TNotifyEvent;\r\n FOldOnConstrainedResize: TConstrainedResizeEvent;\r\n FOldOnContextPopup: TContextPopupEvent;\r\n FOldOnDblClick: TNotifyEvent;\r\n FOldOnDragDrop: TDragDropEvent;\r\n FOldOnDragOver: TDragOverEvent;\r\n FOldOnEndDock: TEndDragEvent;\r\n FOldOnEndDrag: TEndDragEvent;\r\n FOldOnMouseDown: TMouseEvent;\r\n FOldOnMouseMove: TMouseMoveEvent;\r\n FOldOnMouseUp: TMouseEvent;\r\n FOldOnResize: TNotifyEvent;\r\n FOldOnStartDock: TStartDockEvent;\r\n FParentForm: TForm;\r\n FOldWindowProc: TWndMethod;\r\n protected\r\n procedure DoFormOnActivate(Sender: TObject); virtual;\r\n procedure DoFormOnClose(Sender: TObject; var Action: TCloseAction); virtual;\r\n procedure DoFormOnCloseQuery(Sender: TObject; var CanClose: Boolean); virtual;\r\n procedure DoFormOnCreate(Sender: TObject); virtual;\r\n procedure DoFormOnDeactivate(Sender: TObject); virtual;\r\n procedure DoFormOnDestroy(Sender: TObject); virtual;\r\n function DoFormOnHelp(Command: Word; Data: {$IFDEF RTL230_UP}THelpEventData{$ELSE}Longint{$ENDIF}; var CallHelp: Boolean): Boolean;\r\n procedure DoFormOnHide(Sender: TObject); virtual;\r\n procedure DoFormOnPaint(Sender: TObject); virtual;\r\n procedure DoFormOnShortCut(var Msg: TWMKey; var Handled: Boolean); virtual;\r\n procedure DoFormOnShow(Sender: TObject); virtual;\r\n procedure DoFormOnDockDrop(Sender: TObject; Source: TDragDockObject;\r\n X, Y: Integer); virtual;\r\n procedure DoFormOnDockOver(Sender: TObject; Source: TDragDockObject;\r\n X, Y: Integer; State: TDragState; var Accept: Boolean); virtual;\r\n procedure DoFormOnExit(Sender: TObject); virtual;\r\n procedure DoFormOnGetSiteInfo(Sender: TObject; DockClient: TControl;\r\n var InfluenceRect: TRect; MousePos: TPoint; var CanDock: Boolean); virtual;\r\n procedure DoFormOnKeyDown(Sender: TObject; var Key: Word;\r\n Shift: TShiftState); virtual;\r\n procedure DoFormOnKeyPress(Sender: TObject; var Key: Char); virtual;\r\n procedure DoFormOnKeyUp(Sender: TObject; var Key: Word;\r\n Shift: TShiftState); virtual;\r\n procedure DoFormOnMouseWheel(Sender: TObject; Shift: TShiftState;\r\n WheelDelta: Integer; MousePos: TPoint; var Handled: Boolean); virtual;\r\n procedure DoFormOnMouseWheelDown(Sender: TObject; Shift: TShiftState;\r\n MousePos: TPoint; var Handled: Boolean); virtual;\r\n procedure DoFormOnMouseWheelUp(Sender: TObject; Shift: TShiftState;\r\n MousePos: TPoint; var Handled: Boolean); virtual;\r\n procedure DoFormOnUndock(Sender: TObject; Client: TControl;\r\n NewTarget: TWinControl; var Allow: Boolean); virtual;\r\n procedure DoFormOnCanResize(Sender: TObject; var NewWidth, NewHeight: Integer;\r\n var Resize: Boolean); virtual;\r\n procedure DoFormOnClick(Sender: TObject); virtual;\r\n procedure DoFormOnConstrainedResize(Sender: TObject; var MinWidth, MinHeight,\r\n MaxWidth, MaxHeight: Integer); virtual;\r\n procedure DoFormOnContextPopup(Sender: TObject; MousePos: TPoint;\r\n var Handled: Boolean); virtual;\r\n procedure DoFormOnDblClick(Sender: TObject); virtual;\r\n procedure DoFormOnDragDrop(Sender, Source: TObject; X, Y: Integer); virtual;\r\n procedure DoFormOnDragOver(Sender, Source: TObject; X, Y: Integer;\r\n State: TDragState; var Accept: Boolean); virtual;\r\n procedure DoFormOnEndDock(Sender, Target: TObject; X, Y: Integer); virtual;\r\n procedure DoFormOnEndDrag(Sender, Target: TObject; X, Y: Integer); virtual;\r\n procedure DoFormOnMouseDown(Sender: TObject; Button: TMouseButton;\r\n Shift: TShiftState; X, Y: Integer); virtual;\r\n procedure DoFormOnMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer); virtual;\r\n procedure DoFormOnMouseUp(Sender: TObject; Button: TMouseButton;\r\n Shift: TShiftState; X, Y: Integer); virtual;\r\n procedure DoFormOnResize(Sender: TObject); virtual;\r\n procedure DoFormOnStartDock(Sender: TObject; var DragObject: TDragDockObject); virtual;\r\n procedure WindowProc(var Msg: TMessage); virtual;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n property ParentForm: TForm read FParentForm;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvDockSupportClass.pas $';\r\n Revision: '$Revision: 13104 $';\r\n Date: '$Date: 2011-09-07 08:50:43 +0200 (mer. 07 sept. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\n//=== { TJvDockBaseZone } ====================================================\r\n\r\nconstructor TJvDockBaseZone.Create(BaseTree: TJvDockBaseTree);\r\nbegin\r\n inherited Create;\r\n FBaseTree := BaseTree;\r\n FChildZone := nil;\r\n FNextSibling := nil;\r\n FPrevSibling := nil;\r\n FParentZone := nil;\r\nend;\r\n\r\ndestructor TJvDockBaseZone.Destroy;\r\nbegin\r\n FBaseTree := nil;\r\n FChildZone := nil;\r\n FNextSibling := nil;\r\n FPrevSibling := nil;\r\n FParentZone := nil;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJvDockBaseZone.CreateChildZone: TJvDockBaseZone;\r\nbegin\r\n Result := nil;\r\nend;\r\n\r\nfunction TJvDockBaseZone.GetChildCount: Integer;\r\nvar\r\n Zone: TJvDockBaseZone;\r\nbegin\r\n Result := 0;\r\n if FChildZone <> nil then\r\n begin\r\n Inc(Result);\r\n Zone := FChildZone;\r\n while Zone.NextSibling <> nil do\r\n begin\r\n Zone := Zone.NextSibling;\r\n Inc(Result);\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJvDockBaseZone.GetChildZone(Index: Word): TJvDockBaseZone;\r\nbegin\r\n Result := FChildZone;\r\n while (Index > 0) and (Result <> nil) do\r\n begin\r\n Result := Result.NextSibling;\r\n Dec(Index);\r\n end;\r\nend;\r\n\r\nfunction TJvDockBaseZone.GetNextSibingCount: Integer;\r\nvar\r\n Zone: TJvDockBaseZone;\r\nbegin\r\n Result := 0;\r\n Zone := Self;\r\n while Zone.NextSibling <> nil do\r\n begin\r\n Zone := Zone.NextSibling;\r\n Inc(Result);\r\n end;\r\nend;\r\n\r\nfunction TJvDockBaseZone.GetParentZone: TJvDockBaseZone;\r\nvar\r\n TreeZone: TJvDockBaseZone;\r\nbegin\r\n TreeZone := Self;\r\n while (TreeZone <> nil) and (TreeZone.ParentZone = nil) and\r\n (TreeZone.PrevSibling <> nil) do\r\n TreeZone := TreeZone.PrevSibling;\r\n if TreeZone <> nil then\r\n Result := TreeZone.ParentZone\r\n else\r\n Result := nil;\r\nend;\r\n\r\nfunction TJvDockBaseZone.GetPrevSibingCount: Integer;\r\nvar\r\n Zone: TJvDockBaseZone;\r\nbegin\r\n Result := 0;\r\n Zone := Self;\r\n while Zone.PrevSibling <> nil do\r\n begin\r\n Zone := Zone.PrevSibling;\r\n Inc(Result);\r\n end;\r\nend;\r\n\r\n//=== { TJvDockBaseTree } ====================================================\r\n\r\nconstructor TJvDockBaseTree.Create(TreeZone: TJvDockTreeZoneClass);\r\nbegin\r\n inherited Create;\r\n FTreeZoneClass := TreeZone;\r\n FTopTreeZone := FTreeZoneClass.Create(Self);\r\n FCurrTreeZone := FTopTreeZone;\r\n FScanZoneProc := nil;\r\n FScanAction := snNone;\r\nend;\r\n\r\ndestructor TJvDockBaseTree.Destroy;\r\nbegin\r\n FScanAction := snDeleted;\r\n BackwardScanTree(TopTreeZone);\r\n FScanAction := snNone;\r\n inherited Destroy;\r\nend;\r\n\r\n{$IFDEF JVDOCK_DEBUG}\r\n// This helps us to understand the content of the tree by allowing\r\n// us to build an XML dump of the tree.\r\nprocedure TJvDockBaseTree.DebugDump(var Index: Integer; Indent, Entity: string; TreeZone: TJvDockBaseZone; Strs: TStrings);\r\nvar\r\n Zone: TJvDockBaseZone;\r\n WasIndex: Integer;\r\n\r\n procedure Write(S: string);\r\n begin\r\n Strs.Add(S);\r\n end;\r\n\r\nbegin\r\n Zone := TreeZone;\r\n while Assigned(Zone) do\r\n begin\r\n WasIndex := Index;\r\n Inc(Index);\r\n Write(Indent + '<' + Entity + IntToStr(WasIndex) + '>');\r\n Write(Indent + ' ' + Zone.ClassName + '');\r\n DebugDump(Index, Indent + ' ', 'child.' + entity, Zone.ChildZone, Strs);\r\n Write(Indent + '');\r\n Write('');\r\n Zone := Zone.NextSibling;\r\n end;\r\nend;\r\n{$ENDIF JVDOCK_DEBUG}\r\n\r\nfunction TJvDockBaseTree.AddChildZone(TreeZone, NewZone: TJvDockBaseZone): TJvDockBaseZone;\r\nbegin\r\n if TreeZone.ChildZone <> nil then\r\n Result := AddNextSibling(TreeZone.ChildZone, NewZone)\r\n else\r\n begin\r\n if NewZone = nil then\r\n Result := FTreeZoneClass.Create(Self)\r\n else\r\n Result := NewZone;\r\n TreeZone.ChildZone := Result;\r\n Result.ParentZone := TreeZone;\r\n end;\r\nend;\r\n\r\nfunction TJvDockBaseTree.AddNextSibling(TreeZone, NewZone: TJvDockBaseZone): TJvDockBaseZone;\r\nbegin\r\n while TreeZone.NextSibling <> nil do\r\n TreeZone := TreeZone.NextSibling;\r\n if NewZone = nil then\r\n Result := FTreeZoneClass.Create(Self)\r\n else\r\n Result := NewZone;\r\n TreeZone.NextSibling := Result;\r\n Result.PrevSibling := TreeZone;\r\n Result.ParentZone := TreeZone.ParentZone;\r\nend;\r\n\r\nfunction TJvDockBaseTree.AddParentZone(TreeZone, NewZone: TJvDockBaseZone): TJvDockBaseZone;\r\nbegin\r\n if NewZone = nil then\r\n Result := FTreeZoneClass.Create(Self)\r\n else\r\n Result := NewZone;\r\n while TreeZone.PrevSibling <> nil do\r\n TreeZone := TreeZone.PrevSibling;\r\n if TreeZone.ParentZone <> nil then\r\n TreeZone.ParentZone.ChildZone := Result\r\n else\r\n TopTreeZone := Result;\r\n Result.ParentZone := TreeZone.ParentZone;\r\n TreeZone.ParentZone := Result;\r\nend;\r\n\r\nfunction TJvDockBaseTree.AddPrevSibling(TreeZone, NewZone: TJvDockBaseZone): TJvDockBaseZone;\r\nbegin\r\n if NewZone = nil then\r\n Result := FTreeZoneClass.Create(Self)\r\n else\r\n Result := NewZone;\r\n if TreeZone.PrevSibling <> nil then\r\n begin\r\n TreeZone.PrevSibling.NextSibling := Result;\r\n Result.PrevSibling := TreeZone.PrevSibling;\r\n TreeZone.PrevSibling := Result;\r\n Result.NextSibling := TreeZone;\r\n Result.ParentZone := TreeZone.ParentZone;\r\n end\r\n else\r\n begin\r\n if TreeZone.ParentZone <> nil then\r\n TreeZone.ParentZone.ChildZone := Result\r\n else\r\n TopTreeZone := Result;\r\n Result.ParentZone := TreeZone.ParentZone;\r\n Result.NextSibling := TreeZone;\r\n TreeZone.PrevSibling := Result;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockBaseTree.ForwardScanTree(TreeZone: TJvDockBaseZone);\r\nbegin\r\n if TreeZone <> nil then\r\n begin\r\n ScanTreeZone(TreeZone);\r\n ForwardScanTree(TreeZone.ChildZone);\r\n ForwardScanTree(TreeZone.NextSibling);\r\n end;\r\nend;\r\n\r\nprocedure TJvDockBaseTree.MiddleScanTree(TreeZone: TJvDockBaseZone);\r\nbegin\r\n if TreeZone <> nil then\r\n begin\r\n MiddleScanTree(TreeZone.ChildZone);\r\n ScanTreeZone(TreeZone);\r\n MiddleScanTree(TreeZone.NextSibling);\r\n end;\r\nend;\r\n\r\nprocedure TJvDockBaseTree.BackwardScanTree(TreeZone: TJvDockBaseZone);\r\nbegin\r\n if TreeZone <> nil then\r\n begin\r\n BackwardScanTree(TreeZone.ChildZone);\r\n BackwardScanTree(TreeZone.NextSibling);\r\n ScanTreeZone(TreeZone);\r\n end;\r\nend;\r\n\r\nprocedure TJvDockBaseTree.ScanTreeZone(TreeZone: TJvDockBaseZone);\r\nbegin\r\n if Assigned(FScanZoneProc) then\r\n FScanZoneProc(TreeZone);\r\n if FScanAction = snDeleted then\r\n TreeZone.Free;\r\nend;\r\n\r\nprocedure TJvDockBaseTree.RemoveChildZone(TreeZone: TJvDockBaseZone);\r\nbegin\r\n if TreeZone.ChildZone <> nil then\r\n begin\r\n FScanAction := snDeleted;\r\n BackwardScanTree(TreeZone.ChildZone);\r\n FScanAction := snNone;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockBaseTree.RemoveNextSibling(TreeZone: TJvDockBaseZone);\r\nbegin\r\n if TreeZone.NextSibling <> nil then\r\n begin\r\n FScanAction := snDeleted;\r\n BackwardScanTree(TreeZone.NextSibling);\r\n FScanAction := snNone;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockBaseTree.RemoveParentZone(TreeZone: TJvDockBaseZone);\r\nbegin\r\nend;\r\n\r\nprocedure TJvDockBaseTree.RemovePrevSibling(TreeZone: TJvDockBaseZone);\r\nbegin\r\n if TreeZone.PrevSibling <> nil then\r\n begin\r\n FScanAction := snDeleted;\r\n BackwardScanTree(TreeZone.PrevSibling);\r\n FScanAction := snNone;\r\n end;\r\nend;\r\n\r\n//=== { TJvDockBaseGetFormEventComponent } ===================================\r\n\r\nconstructor TJvDockBaseGetFormEventComponent.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FParentForm := TForm(AOwner);\r\n if not (csDesigning in ComponentState) then\r\n begin\r\n FOldOnActivate := FParentForm.OnActivate;\r\n FParentForm.OnActivate := DoFormOnActivate;\r\n FOldOnClose := FParentForm.OnClose;\r\n FParentForm.OnClose := DoFormOnClose;\r\n FOldOnCloseQuery := FParentForm.OnCloseQuery;\r\n FParentForm.OnCloseQuery := DoFormOnCloseQuery;\r\n FOldOnCreate := FParentForm.OnCreate;\r\n FParentForm.OnCreate := DoFormOnCreate;\r\n FOldOnDeactivate := FParentForm.OnDeactivate;\r\n FParentForm.OnDeactivate := DoFormOnDeactivate;\r\n FOldOnDestroy := FParentForm.OnDestroy;\r\n FParentForm.OnDestroy := DoFormOnDestroy;\r\n FOldOnHelp := FParentForm.OnHelp;\r\n FParentForm.OnHelp := DoFormOnHelp;\r\n FOldOnHide := FParentForm.OnHide;\r\n FParentForm.OnHide := DoFormOnHide;\r\n FOldOnPaint := FParentForm.OnPaint;\r\n FParentForm.OnPaint := DoFormOnPaint;\r\n FOldOnShortCut := FParentForm.OnShortCut;\r\n FParentForm.OnShortCut := DoFormOnShortCut;\r\n FOldOnShow := FParentForm.OnShow;\r\n FParentForm.OnShow := DoFormOnShow;\r\n FOldOnDockDrop := FParentForm.OnDockDrop;\r\n FParentForm.OnDockDrop := DoFormOnDockDrop;\r\n FOldOnDockOver := FParentForm.OnDockOver;\r\n FParentForm.OnDockOver := DoFormOnDockOver;\r\n FOldOnGetSiteInfo := FParentForm.OnGetSiteInfo;\r\n FParentForm.OnGetSiteInfo := DoFormOnGetSiteInfo;\r\n FOldOnKeyDown := FParentForm.OnKeyDown;\r\n FParentForm.OnKeyDown := DoFormOnKeyDown;\r\n FOldOnKeyPress := FParentForm.OnKeyPress;\r\n FParentForm.OnKeyPress := DoFormOnKeyPress;\r\n FOldOnKeyUp := FParentForm.OnKeyUp;\r\n FParentForm.OnKeyUp := DoFormOnKeyUp;\r\n FOldOnMouseWheel := FParentForm.OnMouseWheel;\r\n FParentForm.OnMouseWheel := DoFormOnMouseWheel;\r\n FOldOnMouseWheelDown := FParentForm.OnMouseWheelDown;\r\n FParentForm.OnMouseWheelDown := DoFormOnMouseWheelDown;\r\n FOldOnMouseWheelUp := FParentForm.OnMouseWheelUp;\r\n FParentForm.OnMouseWheelUp := DoFormOnMouseWheelUp;\r\n FOldOnUndock := FParentForm.OnUnDock;\r\n FParentForm.OnUnDock := DoFormOnUndock;\r\n FOldOnCanResize := FParentForm.OnCanResize;\r\n FParentForm.OnCanResize := DoFormOnCanResize;\r\n FOldOnClick := FParentForm.OnClick;\r\n FParentForm.OnClick := DoFormOnClick;\r\n FOldOnConstrainedResize := FParentForm.OnConstrainedResize;\r\n FParentForm.OnConstrainedResize := DoFormOnConstrainedResize;\r\n FOldOnContextPopup := FParentForm.OnContextPopup;\r\n FParentForm.OnContextPopup := DoFormOnContextPopup;\r\n FOldOnDblClick := FParentForm.OnDblClick;\r\n FParentForm.OnDblClick := DoFormOnDblClick;\r\n FOldOnDragDrop := FParentForm.OnDragDrop;\r\n FParentForm.OnDragDrop := DoFormOnDragDrop;\r\n FOldOnDragOver := FParentForm.OnDragOver;\r\n FParentForm.OnDragOver := DoFormOnDragOver;\r\n FOldOnEndDock := FParentForm.OnEndDock;\r\n FParentForm.OnEndDock := DoFormOnEndDock;\r\n FOldOnMouseDown := FParentForm.OnMouseDown;\r\n FParentForm.OnMouseDown := DoFormOnMouseDown;\r\n FOldOnMouseMove := FParentForm.OnMouseMove;\r\n FParentForm.OnMouseMove := DoFormOnMouseMove;\r\n FOldOnMouseUp := FParentForm.OnMouseUp;\r\n FParentForm.OnMouseUp := DoFormOnMouseUp;\r\n FOldOnResize := FParentForm.OnResize;\r\n FParentForm.OnResize := DoFormOnResize;\r\n FOldOnStartDock := FParentForm.OnStartDock;\r\n FParentForm.OnStartDock := DoFormOnStartDock;\r\n FOldWindowProc := FParentForm.WindowProc;\r\n FParentForm.WindowProc := WindowProc;\r\n end;\r\nend;\r\n\r\ndestructor TJvDockBaseGetFormEventComponent.Destroy;\r\nbegin\r\n if not (csDesigning in ComponentState) then\r\n begin\r\n if Assigned(FOldWindowProc) then\r\n FParentForm.WindowProc := FOldWindowProc;\r\n FOldWindowProc := nil;\r\n\r\n FParentForm.OnActivate := FOldOnActivate;\r\n FOldOnActivate := nil;\r\n FParentForm.OnClose := FOldOnClose;\r\n FOldOnClose := nil;\r\n FParentForm.OnCloseQuery := FOldOnCloseQuery;\r\n FOldOnCloseQuery := nil;\r\n FParentForm.OnCreate := FOldOnCreate;\r\n FOldOnCreate := nil;\r\n FParentForm.OnDeactivate := FOldOnDeactivate;\r\n FOldOnDeactivate := nil;\r\n FParentForm.OnDestroy := FOldOnDestroy;\r\n FOldOnDestroy := nil;\r\n FParentForm.OnHelp := FOldOnHelp;\r\n FOldOnHelp := nil;\r\n FParentForm.OnHide := FOldOnHide;\r\n FOldOnHide := nil;\r\n FParentForm.OnPaint := FOldOnPaint;\r\n FOldOnPaint := nil;\r\n FParentForm.OnShortCut := FOldOnShortCut;\r\n FOldOnShortCut := nil;\r\n FParentForm.OnShow := FOldOnShow;\r\n FOldOnShow := nil;\r\n FParentForm.OnDockDrop := FOldOnDockDrop;\r\n FOldOnDockDrop := nil;\r\n FParentForm.OnDockOver := FOldOnDockOver;\r\n FOldOnDockOver := nil;\r\n FParentForm.OnGetSiteInfo := FOldOnGetSiteInfo;\r\n FOldOnGetSiteInfo := nil;\r\n FParentForm.OnKeyDown := FOldOnKeyDown;\r\n FOldOnKeyDown := nil;\r\n FParentForm.OnKeyPress := FOldOnKeyPress;\r\n FOldOnKeyPress := nil;\r\n FParentForm.OnKeyUp := FOldOnKeyUp;\r\n FOldOnKeyUp := nil;\r\n FParentForm.OnMouseWheel := FOldOnMouseWheel;\r\n FOldOnMouseWheel := nil;\r\n FParentForm.OnMouseWheelDown := FOldOnMouseWheelDown;\r\n FOldOnMouseWheelDown := nil;\r\n FParentForm.OnMouseWheelUp := FOldOnMouseWheelUp;\r\n FOldOnMouseWheelUp := nil;\r\n FParentForm.OnUnDock := FOldOnUndock;\r\n FOldOnUndock := nil;\r\n FParentForm.OnCanResize := FOldOnCanResize;\r\n FOldOnCanResize := nil;\r\n FParentForm.OnClick := FOldOnClick;\r\n FOldOnClick := nil;\r\n FParentForm.OnConstrainedResize := FOldOnConstrainedResize;\r\n FOldOnConstrainedResize := nil;\r\n FParentForm.OnContextPopup := FOldOnContextPopup;\r\n FOldOnContextPopup := nil;\r\n FParentForm.OnDblClick := FOldOnDblClick;\r\n FOldOnDblClick := nil;\r\n FParentForm.OnDragDrop := FOldOnDragDrop;\r\n FOldOnDragDrop := nil;\r\n FParentForm.OnDragOver := FOldOnDragOver;\r\n FOldOnDragOver := nil;\r\n FParentForm.OnEndDock := FOldOnEndDock;\r\n FOldOnEndDock := nil;\r\n FParentForm.OnMouseDown := FOldOnMouseDown;\r\n FOldOnMouseDown := nil;\r\n FParentForm.OnMouseMove := FOldOnMouseMove;\r\n FOldOnMouseMove := nil;\r\n FParentForm.OnMouseUp := FOldOnMouseUp;\r\n FOldOnMouseUp := nil;\r\n FParentForm.OnResize := FOldOnResize;\r\n FOldOnResize := nil;\r\n FParentForm.OnStartDock := FOldOnStartDock;\r\n FOldOnStartDock := nil;\r\n FParentForm := nil;\r\n end;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvDockBaseGetFormEventComponent.DoFormOnActivate(Sender: TObject);\r\nbegin\r\n if Assigned(FOldOnActivate) then\r\n FOldOnActivate(Sender);\r\nend;\r\n\r\nprocedure TJvDockBaseGetFormEventComponent.DoFormOnCanResize(Sender: TObject;\r\n var NewWidth, NewHeight: Integer; var Resize: Boolean);\r\nbegin\r\n if Assigned(FOldOnCanResize) then\r\n FOldOnCanResize(Sender, NewWidth, NewHeight, Resize);\r\nend;\r\n\r\nprocedure TJvDockBaseGetFormEventComponent.DoFormOnClick(Sender: TObject);\r\nbegin\r\n if Assigned(FOldOnClick) then\r\n FOldOnClick(Sender);\r\nend;\r\n\r\nprocedure TJvDockBaseGetFormEventComponent.DoFormOnClose(Sender: TObject;\r\n var Action: TCloseAction);\r\nbegin\r\n if Assigned(FOldOnClose) then\r\n FOldOnClose(Sender, Action);\r\nend;\r\n\r\nprocedure TJvDockBaseGetFormEventComponent.DoFormOnCloseQuery(Sender: TObject;\r\n var CanClose: Boolean);\r\nbegin\r\n if Assigned(FOldOnCloseQuery) then\r\n FOldOnCloseQuery(Sender, CanClose);\r\nend;\r\n\r\nprocedure TJvDockBaseGetFormEventComponent.DoFormOnConstrainedResize(Sender: TObject;\r\n var MinWidth, MinHeight, MaxWidth, MaxHeight: Integer);\r\nbegin\r\n if Assigned(FOldOnConstrainedResize) then\r\n FOldOnConstrainedResize(Sender, MinWidth, MinHeight, MaxWidth, MaxHeight);\r\nend;\r\n\r\nprocedure TJvDockBaseGetFormEventComponent.DoFormOnContextPopup(\r\n Sender: TObject; MousePos: TPoint; var Handled: Boolean);\r\nbegin\r\n if Assigned(FOldOnContextPopup) then\r\n FOldOnContextPopup(Sender, MousePos, Handled);\r\nend;\r\n\r\nprocedure TJvDockBaseGetFormEventComponent.DoFormOnCreate(Sender: TObject);\r\nbegin\r\n if Assigned(FOldOnCreate) then\r\n FOldOnCreate(Sender);\r\nend;\r\n\r\nprocedure TJvDockBaseGetFormEventComponent.DoFormOnDblClick(Sender: TObject);\r\nbegin\r\n if Assigned(FOldOnDblClick) then\r\n FOldOnDblClick(Sender);\r\nend;\r\n\r\nprocedure TJvDockBaseGetFormEventComponent.DoFormOnDeactivate(Sender: TObject);\r\nbegin\r\n if Assigned(FOldOnDeactivate) then\r\n FOldOnDeactivate(Sender);\r\nend;\r\n\r\nprocedure TJvDockBaseGetFormEventComponent.DoFormOnDestroy(Sender: TObject);\r\nbegin\r\n if Assigned(FOldOnDestroy) then\r\n FOldOnDestroy(Sender);\r\nend;\r\n\r\nprocedure TJvDockBaseGetFormEventComponent.DoFormOnDockDrop(Sender: TObject;\r\n Source: TDragDockObject; X, Y: Integer);\r\nbegin\r\n if Assigned(FOldOnDockDrop) then\r\n FOldOnDockDrop(Sender, Source, X, Y);\r\nend;\r\n\r\nprocedure TJvDockBaseGetFormEventComponent.DoFormOnDockOver(Sender: TObject;\r\n Source: TDragDockObject; X, Y: Integer; State: TDragState; var Accept: Boolean);\r\nbegin\r\n if Assigned(FOldOnDockOver) then\r\n FOldOnDockOver(Sender, Source, X, Y, State, Accept);\r\nend;\r\n\r\nprocedure TJvDockBaseGetFormEventComponent.DoFormOnDragDrop(Sender, Source: TObject; X, Y: Integer);\r\nbegin\r\n if Assigned(FOldOnDragDrop) then\r\n FOldOnDragDrop(Sender, Source, X, Y);\r\nend;\r\n\r\nprocedure TJvDockBaseGetFormEventComponent.DoFormOnDragOver(Sender, Source: TObject;\r\n X, Y: Integer; State: TDragState; var Accept: Boolean);\r\nbegin\r\n if Assigned(FOldOnDragOver) then\r\n FOldOnDragOver(Sender, Source, X, Y, State, Accept);\r\nend;\r\n\r\nprocedure TJvDockBaseGetFormEventComponent.DoFormOnEndDock(Sender, Target: TObject;\r\n X, Y: Integer);\r\nbegin\r\n if Assigned(FOldOnEndDock) then\r\n FOldOnEndDock(Sender, Target, X, Y);\r\nend;\r\n\r\nprocedure TJvDockBaseGetFormEventComponent.DoFormOnEndDrag(Sender, Target: TObject;\r\n X, Y: Integer);\r\nbegin\r\n if Assigned(FOldOnEndDrag) then\r\n FOldOnEndDrag(Sender, Target, X, Y);\r\nend;\r\n\r\nprocedure TJvDockBaseGetFormEventComponent.DoFormOnExit(Sender: TObject);\r\nbegin\r\n if Assigned(FOldOnExit) then\r\n FOldOnExit(Sender);\r\nend;\r\n\r\nprocedure TJvDockBaseGetFormEventComponent.DoFormOnGetSiteInfo(Sender: TObject;\r\n DockClient: TControl; var InfluenceRect: TRect; MousePos: TPoint; var CanDock: Boolean);\r\nbegin\r\n if Assigned(FOldOnGetSiteInfo) then\r\n FOldOnGetSiteInfo(Sender, DockClient, InfluenceRect, MousePos, CanDock);\r\nend;\r\n\r\nfunction TJvDockBaseGetFormEventComponent.DoFormOnHelp(Command: Word;\r\n Data: {$IFDEF RTL230_UP}THelpEventData{$ELSE}Longint{$ENDIF}; var CallHelp: Boolean): Boolean;\r\nbegin\r\n Result := False;\r\n if Assigned(FOldOnHelp) then\r\n Result := FOldOnHelp(Command, Data, CallHelp);\r\nend;\r\n\r\nprocedure TJvDockBaseGetFormEventComponent.DoFormOnHide(Sender: TObject);\r\nbegin\r\n if Assigned(FOldOnHide) then\r\n FOldOnHide(Sender);\r\nend;\r\n\r\nprocedure TJvDockBaseGetFormEventComponent.DoFormOnKeyDown(Sender: TObject;\r\n var Key: Word; Shift: TShiftState);\r\nbegin\r\n if Assigned(FOldOnKeyDown) then\r\n FOldOnKeyDown(Sender, Key, Shift);\r\nend;\r\n\r\nprocedure TJvDockBaseGetFormEventComponent.DoFormOnKeyPress(Sender: TObject;\r\n var Key: Char);\r\nbegin\r\n if Assigned(FOldOnKeyPress) then\r\n FOldOnKeyPress(Sender, Key);\r\nend;\r\n\r\nprocedure TJvDockBaseGetFormEventComponent.DoFormOnKeyUp(Sender: TObject;\r\n var Key: Word; Shift: TShiftState);\r\nbegin\r\n if Assigned(FOldOnKeyUp) then\r\n FOldOnKeyUp(Sender, Key, Shift);\r\nend;\r\n\r\nprocedure TJvDockBaseGetFormEventComponent.DoFormOnMouseDown(Sender: TObject;\r\n Button: TMouseButton; Shift: TShiftState; X, Y: Integer);\r\nbegin\r\n if Assigned(FOldOnMouseDown) then\r\n FOldOnMouseDown(Sender, Button, Shift, X, Y);\r\nend;\r\n\r\nprocedure TJvDockBaseGetFormEventComponent.DoFormOnMouseMove(Sender: TObject;\r\n Shift: TShiftState; X, Y: Integer);\r\nbegin\r\n if Assigned(FOldOnMouseMove) then\r\n FOldOnMouseMove(Sender, Shift, X, Y);\r\nend;\r\n\r\nprocedure TJvDockBaseGetFormEventComponent.DoFormOnMouseUp(Sender: TObject;\r\n Button: TMouseButton; Shift: TShiftState; X, Y: Integer);\r\nbegin\r\n if Assigned(FOldOnMouseUp) then\r\n FOldOnMouseUp(Sender, Button, Shift, X, Y);\r\nend;\r\n\r\nprocedure TJvDockBaseGetFormEventComponent.DoFormOnMouseWheel(Sender: TObject;\r\n Shift: TShiftState; WheelDelta: Integer; MousePos: TPoint;\r\n var Handled: Boolean);\r\nbegin\r\n if Assigned(FOldOnMouseWheel) then\r\n FOldOnMouseWheel(Sender, Shift, WheelDelta, MousePos, Handled);\r\nend;\r\n\r\nprocedure TJvDockBaseGetFormEventComponent.DoFormOnMouseWheelDown(Sender: TObject;\r\n Shift: TShiftState; MousePos: TPoint; var Handled: Boolean);\r\nbegin\r\n if Assigned(FOldOnMouseWheelDown) then\r\n FOldOnMouseWheelDown(Sender, Shift, MousePos, Handled);\r\nend;\r\n\r\nprocedure TJvDockBaseGetFormEventComponent.DoFormOnMouseWheelUp(Sender: TObject;\r\n Shift: TShiftState; MousePos: TPoint; var Handled: Boolean);\r\nbegin\r\n if Assigned(FOldOnMouseWheelUp) then\r\n FOldOnMouseWheelUp(Sender, Shift, MousePos, Handled);\r\nend;\r\n\r\nprocedure TJvDockBaseGetFormEventComponent.DoFormOnPaint(Sender: TObject);\r\nbegin\r\n if Assigned(FOldOnPaint) then\r\n FOldOnPaint(Sender);\r\nend;\r\n\r\nprocedure TJvDockBaseGetFormEventComponent.DoFormOnResize(Sender: TObject);\r\nbegin\r\n if Assigned(FOldOnResize) then\r\n FOldOnResize(Sender);\r\nend;\r\n\r\nprocedure TJvDockBaseGetFormEventComponent.DoFormOnShortCut(var Msg: TWMKey;\r\n var Handled: Boolean);\r\nbegin\r\n if Assigned(FOldOnShortCut) then\r\n FOldOnShortCut(Msg, Handled);\r\nend;\r\n\r\nprocedure TJvDockBaseGetFormEventComponent.DoFormOnShow(Sender: TObject);\r\nbegin\r\n if Assigned(FOldOnShow) then\r\n FOldOnShow(Sender);\r\nend;\r\n\r\nprocedure TJvDockBaseGetFormEventComponent.DoFormOnStartDock(Sender: TObject;\r\n var DragObject: TDragDockObject);\r\nbegin\r\n if Assigned(FOldOnStartDock) then\r\n FOldOnStartDock(Sender, DragObject);\r\nend;\r\n\r\nprocedure TJvDockBaseGetFormEventComponent.DoFormOnUndock(Sender: TObject;\r\n Client: TControl; NewTarget: TWinControl; var Allow: Boolean);\r\nbegin\r\n if Assigned(FOldOnUndock) then\r\n FOldOnUndock(Sender, Client, NewTarget, Allow);\r\nend;\r\n\r\nprocedure TJvDockBaseGetFormEventComponent.WindowProc(var Msg: TMessage);\r\nbegin\r\n if Assigned(FOldWindowProc) then\r\n FOldWindowProc(Msg);\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n\r\n\r\n" }, { "path": "External/Jedi/Jvcl/run/JvDockSupportControl.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvDockSupportControl.pas, released on 2003-12-31.\r\n\r\nThe Initial Developer of the Original Code is luxiaoban.\r\nPortions created by luxiaoban are Copyright (C) 2002, 2003 luxiaoban.\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvDockSupportControl.pas 13415 2012-09-10 09:51:54Z obones $\r\n\r\nunit JvDockSupportControl;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Messages, Windows, CommCtrl, Graphics, Controls, Forms, ImgList, Classes, ExtCtrls,\r\n ComCtrls,\r\n {$IFDEF HAS_UNIT_SYSTEM_UITYPES}\r\n System.UITypes,\r\n {$ENDIF HAS_UNIT_SYSTEM_UITYPES}\r\n JvComponent, JvAppStorage,\r\n JvDockTree;\r\n\r\ntype\r\n TJvAlphaBlendedForm = class(TForm)\r\n protected\r\n procedure CreateParams(var Params: TCreateParams); override;\r\n end;\r\n\r\n TJvDockDragDockObject = class(TObject)\r\n private\r\n // FDockClient:TObject;{NEW: Opaque reference to TJvDockClient}\r\n FMouseDeltaX: Double;\r\n FMouseDeltaY: Double;\r\n FControl: TControl;\r\n FDragTarget: Pointer;\r\n FDragPos: TPoint;\r\n FDropOnControl: TControl;\r\n FDropAlign: TAlign;\r\n FDragHandle: THandle;\r\n FDragTargetPos: TPoint;\r\n FCancelling: Boolean;\r\n FFloating: Boolean;\r\n FFrameWidth: Integer;\r\n FBrush: TBrush;\r\n FCtrlDown: Boolean;\r\n FDockRect: TRect;\r\n FEraseDockRect: TRect;\r\n FAlphaBlendedForm: TJvAlphaBlendedForm;\r\n FAlphaBlendedTab: TJvAlphaBlendedForm;\r\n procedure SetBrush(const Value: TBrush);\r\n procedure SetDropAlign(const Value: TAlign);\r\n procedure SetDropOnControl(const Value: TControl);\r\n function GetTargetControl: TWinControl;\r\n procedure SetTargetControl(const Value: TWinControl);\r\n function GetAlphaBlendedTab: TJvAlphaBlendedForm;\r\n protected\r\n property AlphaBlendedForm: TJvAlphaBlendedForm read FAlphaBlendedForm;\r\n property AlphaBlendedTab: TJvAlphaBlendedForm read GetAlphaBlendedTab;\r\n procedure DefaultDockImage(Erase: Boolean); virtual;\r\n procedure DrawDragRect(DoErase: Boolean); virtual;\r\n procedure GetBrush_PenSize_DrawRect(var ABrush: TBrush; var PenSize: Integer;\r\n var DrawRect: TRect; Erase: Boolean); virtual;\r\n function GetFrameWidth: Integer; virtual;\r\n procedure SetFrameWidth(const Value: Integer); virtual;\r\n procedure MouseMsg(var Msg: TMessage); virtual;\r\n function CanLeave(NewTarget: TWinControl): Boolean; virtual;\r\n public\r\n constructor Create(AControl: TControl); virtual;\r\n destructor Destroy; override;\r\n\r\n procedure AdjustDockRect(const ARect: TRect); virtual;\r\n function Capture: THandle;\r\n function DragFindWindow(const Pos: TPoint): THandle; virtual;\r\n procedure ReleaseCapture(Handle: THandle);\r\n procedure EndDrag(Target: TObject; X, Y: Integer); virtual;\r\n procedure Finished(Target: TObject; X, Y: Integer; Accepted: Boolean); virtual;\r\n function GetDragCursor(Accepted: Boolean; X, Y: Integer): TCursor; virtual;\r\n function GetDragImages: TDragImageList; virtual;\r\n procedure DrawDragDockImage; virtual;\r\n procedure EraseDragDockImage; virtual;\r\n function GetDropCtl: TControl; virtual;\r\n\r\n property MouseDeltaX: Double read FMouseDeltaX write FMouseDeltaX;\r\n property MouseDeltaY: Double read FMouseDeltaY write FMouseDeltaY;\r\n property Control: TControl read FControl write FControl;\r\n property DockRect: TRect read FDockRect write FDockRect;\r\n property DragTarget: Pointer read FDragTarget write FDragTarget;\r\n property DragPos: TPoint read FDragPos write FDragPos;\r\n property DropOnControl: TControl read FDropOnControl write SetDropOnControl;\r\n property DropAlign: TAlign read FDropAlign write SetDropAlign;\r\n property DragHandle: THandle read FDragHandle write FDragHandle;\r\n property DragTargetPos: TPoint read FDragTargetPos write FDragTargetPos;\r\n property EraseDockRect: TRect read FEraseDockRect;\r\n property Cancelling: Boolean read FCancelling write FCancelling;\r\n property Floating: Boolean read FFloating write FFloating;\r\n property FrameWidth: Integer read GetFrameWidth write SetFrameWidth;\r\n property Brush: TBrush read FBrush write SetBrush;\r\n property CtrlDown: Boolean read FCtrlDown write FCtrlDown;\r\n property TargetControl: TWinControl read GetTargetControl write SetTargetControl;\r\n\r\n {DockClient: Opaque reference to TJvDockClient. Nil if none.}\r\n // property DockClient:TObject read FDockClient write FDockClient;\r\n end;\r\n\r\n TJvDockCustomControl = class(TJvCustomControl)\r\n private\r\n function GetJvDockManager: IJvDockManager;\r\n protected\r\n procedure WndProc(var Msg: TMessage); override;\r\n procedure CustomStartDock(var Source: TJvDockDragDockObject); virtual;\r\n procedure CustomGetSiteInfo(Source: TJvDockDragDockObject;\r\n Client: TControl; var InfluenceRect: TRect; MousePos: TPoint;\r\n var CanDock: Boolean); virtual;\r\n procedure CustomDockOver(Source: TJvDockDragDockObject; X, Y: Integer;\r\n State: TDragState; var Accept: Boolean); virtual;\r\n procedure CustomPositionDockRect(Source: TJvDockDragDockObject; X, Y: Integer); virtual;\r\n procedure CustomDockDrop(Source: TJvDockDragDockObject; X, Y: Integer); virtual;\r\n procedure CustomEndDock(Target: TObject; X, Y: Integer); virtual;\r\n function CustomUnDock(Source: TJvDockDragDockObject; NewTarget: TWinControl; Client: TControl): Boolean; virtual;\r\n procedure CustomGetDockEdge(Source: TJvDockDragDockObject; MousePos: TPoint; var DropAlign: TAlign); virtual;\r\n public\r\n procedure UpdateCaption(Exclude: TControl); virtual;\r\n property DockManager;\r\n property JvDockManager: IJvDockManager read GetJvDockManager{ write SetJvDockManager};\r\n end;\r\n\r\n TJvDockCustomPanel = class(TJvDockCustomControl)\r\n protected\r\n function CreateDockManager: IDockManager; override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n property DockSite;\r\n end;\r\n\r\n TJvDockCustomTabControl = class;\r\n\r\n TJvDockTabStrings = class(TStrings)\r\n private\r\n FTabControl: TJvDockCustomTabControl;\r\n protected\r\n function Get(Index: Integer): string; override;\r\n function GetCount: Integer; override;\r\n function GetObject(Index: Integer): TObject; override;\r\n procedure Put(Index: Integer; const S: string); override;\r\n procedure PutObject(Index: Integer; AObject: TObject); override;\r\n procedure SetUpdateState(Updating: Boolean); override;\r\n public\r\n procedure Clear; override;\r\n procedure Delete(Index: Integer); override;\r\n procedure Insert(Index: Integer; const S: string); override;\r\n end;\r\n\r\n TJvDockDrawTabEvent = procedure(Control: TJvDockCustomTabControl; TabIndex: Integer;\r\n const Rect: TRect; Active: Boolean) of object;\r\n\r\n TJvDockPageControl = class;\r\n\r\n TJvDockCustomTabControl = class(TJvDockCustomControl)\r\n private\r\n FHotTrack: Boolean;\r\n FImageChangeLink: TChangeLink;\r\n FImages: TCustomImageList;\r\n FMultiLine: Boolean;\r\n FMultiSelect: Boolean;\r\n FOwnerDraw: Boolean;\r\n FRaggedRight: Boolean;\r\n FSaveTabIndex: Integer;\r\n FSaveTabs: TStringList;\r\n FScrollOpposite: Boolean;\r\n FStyle: TTabStyle;\r\n FTabPosition: TTabPosition;\r\n FTabs: TJvDockTabStrings;\r\n FTabSize: TSmallPoint;\r\n FUpdating: Boolean;\r\n FSavedAdjustRect: TRect;\r\n FOnChange: TNotifyEvent;\r\n FOnChanging: TTabChangingEvent;\r\n FOnDrawTab: TJvDockDrawTabEvent;\r\n FOnGetImageIndex: TTabGetImageEvent;\r\n function GetDisplayRect: TRect;\r\n function GetTabIndex: Integer;\r\n function GetTabs: TStrings;\r\n procedure ImageListChange(Sender: TObject);\r\n function InternalSetMultiLine(Value: Boolean): Boolean;\r\n procedure SetMultiLine(Value: Boolean);\r\n procedure SetMultiSelect(Value: Boolean);\r\n procedure SetOwnerDraw(Value: Boolean);\r\n procedure SetRaggedRight(Value: Boolean);\r\n procedure SetScrollOpposite(Value: Boolean);\r\n procedure SetStyle(Value: TTabStyle);\r\n procedure SetTabIndex(Value: Integer);\r\n procedure SetTabs(Value: TStrings);\r\n procedure SetTabWidth(Value: Smallint);\r\n procedure TabsChanged;\r\n procedure UpdateTabSize;\r\n procedure CMFontChanged(var Msg); message CM_FONTCHANGED;\r\n procedure CMSysColorChange(var Msg: TMessage); message CM_SYSCOLORCHANGE;\r\n procedure CMTabStopChanged(var Msg: TMessage); message CM_TABSTOPCHANGED;\r\n procedure CNNotify(var Msg: TWMNotify); message CN_NOTIFY;\r\n procedure CMDialogChar(var Msg: TCMDialogChar); message CM_DIALOGCHAR;\r\n procedure CNDrawItem(var Msg: TWMDrawItem); message CN_DRAWITEM;\r\n procedure TCMAdjustRect(var Msg: TMessage); message TCM_ADJUSTRECT;\r\n procedure WMDestroy(var Msg: TWMDestroy); message WM_DESTROY;\r\n procedure WMNotifyFormat(var Msg: TMessage); message WM_NOTIFYFORMAT;\r\n procedure WMSize(var Msg: TMessage); message WM_SIZE;\r\n protected\r\n procedure AdjustClientRect(var Rect: TRect); override;\r\n function CanChange: Boolean; dynamic;\r\n function CanShowTab(TabIndex: Integer): Boolean; virtual;\r\n procedure Change; dynamic;\r\n procedure CreateParams(var Params: TCreateParams); override;\r\n procedure CreateWnd; override;\r\n procedure DrawTab(TabIndex: Integer; const Rect: TRect; Active: Boolean); virtual;\r\n function GetImageIndex(TabIndex: Integer): Integer; virtual;\r\n procedure Loaded; override;\r\n procedure Notification(AComponent: TComponent; Operation: TOperation); override;\r\n procedure PaintWindow(DC: HDC); override;\r\n procedure SetHotTrack(Value: Boolean); virtual;\r\n procedure SetImages(Value: TCustomImageList); virtual;\r\n procedure SetTabHeight(Value: Smallint); virtual;\r\n procedure SetTabPosition(Value: TTabPosition); virtual;\r\n procedure UpdateTabImages;\r\n property DisplayRect: TRect read GetDisplayRect;\r\n property HotTrack: Boolean read FHotTrack write SetHotTrack default False;\r\n property Images: TCustomImageList read FImages write SetImages;\r\n property MultiLine: Boolean read FMultiLine write SetMultiLine default False;\r\n property MultiSelect: Boolean read FMultiSelect write SetMultiSelect default False;\r\n property OwnerDraw: Boolean read FOwnerDraw write SetOwnerDraw default False;\r\n property RaggedRight: Boolean read FRaggedRight write SetRaggedRight default False;\r\n property ScrollOpposite: Boolean read FScrollOpposite\r\n write SetScrollOpposite default False;\r\n property Style: TTabStyle read FStyle write SetStyle default tsTabs;\r\n property TabHeight: Smallint read FTabSize.Y write SetTabHeight default 0;\r\n property TabIndex: Integer read GetTabIndex write SetTabIndex default -1;\r\n property TabPosition: TTabPosition read FTabPosition write SetTabPosition default tpTop;\r\n property Tabs: TStrings read GetTabs write SetTabs;\r\n property TabWidth: Smallint read FTabSize.X write SetTabWidth default 0;\r\n property OnChange: TNotifyEvent read FOnChange write FOnChange;\r\n property OnChanging: TTabChangingEvent read FOnChanging write FOnChanging;\r\n property OnDrawTab: TJvDockDrawTabEvent read FOnDrawTab write FOnDrawTab;\r\n property OnGetImageIndex: TTabGetImageEvent read FOnGetImageIndex write FOnGetImageIndex;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n function IndexOfTabAt(X, Y: Integer): Integer;\r\n function GetHitTestInfoAt(X, Y: Integer): THitTests;\r\n function TabRect(Index: Integer): TRect;\r\n function RowCount: Integer;\r\n procedure ScrollTabs(Delta: Integer);\r\n property TabStop default True;\r\n end;\r\n\r\n TJvDockTabSheet = class(TJvWinControl)\r\n private\r\n FImageIndex: TImageIndex;\r\n FPageControl: TJvDockPageControl;\r\n FTabVisible: Boolean;\r\n FTabShowing: Boolean;\r\n FHighlighted: Boolean;\r\n FOnHide: TNotifyEvent;\r\n FOnShow: TNotifyEvent;\r\n function GetPageIndex: Integer;\r\n function GetTabIndex: Integer;\r\n procedure SetHighlighted(Value: Boolean);\r\n procedure SetImageIndex(Value: TImageIndex);\r\n procedure SetPageIndex(Value: Integer);\r\n procedure SetTabShowing(Value: Boolean);\r\n procedure SetTabVisible(Value: Boolean);\r\n procedure CMTextChanged(var Msg: TMessage); message CM_TEXTCHANGED;\r\n procedure CMShowingChanged(var Msg: TMessage); message CM_SHOWINGCHANGED;\r\n protected\r\n procedure CreateParams(var Params: TCreateParams); override;\r\n procedure SetPageControl(APageControl: TJvDockPageControl); virtual;\r\n procedure ReadState(Reader: TReader); override;\r\n procedure DoHide; dynamic;\r\n procedure DoShow; dynamic;\r\n procedure UpdateTabShowing; dynamic;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n property PageControl: TJvDockPageControl read FPageControl write SetPageControl;\r\n property TabIndex: Integer read GetTabIndex;\r\n published\r\n property Caption;\r\n property Height stored False;\r\n property Highlighted: Boolean read FHighlighted write SetHighlighted default False;\r\n property ImageIndex: TImageIndex read FImageIndex write SetImageIndex default -1;\r\n property Left stored False;\r\n property PageIndex: Integer read GetPageIndex write SetPageIndex stored False;\r\n property TabVisible: Boolean read FTabVisible write SetTabVisible default True;\r\n property Top stored False;\r\n property Visible stored False;\r\n property Width stored False;\r\n property OnHide: TNotifyEvent read FOnHide write FOnHide;\r\n property OnShow: TNotifyEvent read FOnShow write FOnShow;\r\n end;\r\n\r\n TJvDockTabSheetClass = class of TJvDockTabSheet;\r\n\r\n TJvDockPageControl = class(TJvDockCustomTabControl)\r\n private\r\n FPages: TList;\r\n FActivePage: TJvDockTabSheet;\r\n FNewDockSheet: TJvDockTabSheet;\r\n FUndockingPage: TJvDockTabSheet;\r\n FTabSheetClass: TJvDockTabSheetClass;\r\n procedure ChangeActivePage(Page: TJvDockTabSheet);\r\n procedure DeleteTab(Page: TJvDockTabSheet; Index: Integer);\r\n function GetActivePageIndex: Integer;\r\n function GetPage(Index: Integer): TJvDockTabSheet;\r\n function GetCount: Integer;\r\n procedure InsertPage(Page: TJvDockTabSheet);\r\n procedure InsertTab(Page: TJvDockTabSheet);\r\n procedure MoveTab(CurIndex, NewIndex: Integer);\r\n procedure RemovePage(Page: TJvDockTabSheet);\r\n procedure SetActivePageIndex(const Value: Integer);\r\n procedure UpdateTab(Page: TJvDockTabSheet);\r\n procedure UpdateTabHighlights;\r\n procedure CMDesignHitTest(var Msg: TCMDesignHitTest); message CM_DESIGNHITTEST;\r\n procedure CMDialogKey(var Msg: TCMDialogKey); message CM_DIALOGKEY;\r\n procedure CMDockClient(var Msg: TCMDockClient); message CM_DOCKCLIENT;\r\n procedure CMDockNotification(var Msg: TCMDockNotification); message CM_DOCKNOTIFICATION;\r\n procedure CMUnDockClient(var Msg: TCMUnDockClient); message CM_UNDOCKCLIENT;\r\n procedure WMLButtonDown(var Msg: TWMLButtonDown); message WM_LBUTTONDOWN;\r\n procedure WMLButtonDblClk(var Msg: TWMLButtonDblClk); message WM_LBUTTONDBLCLK;\r\n procedure WMLButtonUp(var Msg: TWMLButtonUp); message WM_LBUTTONUP;\r\n procedure WMRButtonDown(var Msg: TWMRButtonDown); message WM_RBUTTONDOWN;\r\n procedure WMRButtonDblClk(var Msg: TWMRButtonDblClk); message WM_RBUTTONDBLCLK;\r\n procedure WMRButtonUp(var Msg: TWMRButtonUp); message WM_RBUTTONUP;\r\n procedure WMMButtonDown(var Msg: TWMMButtonDown); message WM_MBUTTONDOWN;\r\n procedure WMMButtonDblClk(var Msg: TWMMButtonDblClk); message WM_MBUTTONDBLCLK;\r\n procedure WMMButtonUp(var Msg: TWMMButtonUp); message WM_MBUTTONUP;\r\n protected\r\n function CanShowTab(TabIndex: Integer): Boolean; override;\r\n procedure Change; override;\r\n procedure DoAddDockClient(Client: TControl; const ARect: TRect); override;\r\n procedure DockOver(Source: TDragDockObject; X, Y: Integer;\r\n State: TDragState; var Accept: Boolean); override;\r\n function DoMouseEvent(var Msg: TWMMouse; Control: TControl): TWMNCHitMessage; virtual;\r\n procedure DoRemoveDockClient(Client: TControl); override;\r\n function GetDockClientFromMousePos(MousePos: TPoint): TControl; virtual;\r\n function GetImageIndex(TabIndex: Integer): Integer; override;\r\n function GetPageFromDockClient(Client: TControl): TJvDockTabSheet;\r\n procedure GetSiteInfo(Client: TControl; var InfluenceRect: TRect;\r\n MousePos: TPoint; var CanDock: Boolean); override;\r\n procedure Loaded; override;\r\n procedure SetActivePage(Page: TJvDockTabSheet); virtual;\r\n procedure ShowControl(AControl: TControl); override;\r\n procedure UpdateActivePage; virtual;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n\r\n procedure GetChildren(Proc: TGetChildProc; Root: TComponent); override; // public in D2009\r\n function FindNextPage(CurPage: TJvDockTabSheet;\r\n GoForward, CheckTabVisible: Boolean): TJvDockTabSheet;\r\n procedure SelectNextPage(GoForward: Boolean; CheckTabVisible: Boolean = True);\r\n procedure SetChildOrder(Child: TComponent; Order: Integer); override;\r\n property ActivePage: TJvDockTabSheet read FActivePage write SetActivePage;\r\n property ActivePageIndex: Integer read GetActivePageIndex\r\n write SetActivePageIndex;\r\n property Count: Integer read GetCount;\r\n property Pages[Index: Integer]: TJvDockTabSheet read GetPage;\r\n property PageSheets: TList read FPages;\r\n property TabSheetClass: TJvDockTabSheetClass read FTabSheetClass write FTabSheetClass;\r\n end;\r\n\r\n TJvDockDragOperation = (dopNone, dopDrag, dopDock);\r\n\r\n PSiteInfoRec = ^TSiteInfoRec;\r\n TSiteInfoRec = record\r\n Site: TWinControl;\r\n TopParent: THandle;\r\n end;\r\n\r\n TSiteList = class(TList)\r\n public\r\n procedure AddSite(ASite: TWinControl);\r\n procedure Clear; override;\r\n function Find(ParentWnd: THandle; var Index: Integer): Boolean;\r\n function GetTopSite: TWinControl;\r\n end;\r\n\r\n TJvDockManager = class(TObject)\r\n private\r\n FLoadCount: Integer;\r\n FSaveCount: Integer;\r\n FDragObject: TJvDockDragDockObject;\r\n FDragControl: TControl;\r\n FDragFreeObject: Boolean;\r\n FDragCapture: THandle;\r\n FDragStartPos: TPoint;\r\n FDragSaveCursor: HCURSOR;\r\n FDragThreshold: Integer;\r\n FActiveDrag: TJvDockDragOperation;\r\n FDragImageList: TDragImageList;\r\n FDockSiteList: TList;\r\n FQualifyingSites: TSiteList;\r\n procedure BeginLoad;\r\n procedure EndLoad;\r\n procedure BeginSave;\r\n procedure EndSave;\r\n public\r\n procedure CalcDockSizes(Control: TControl);\r\n constructor Create; virtual;\r\n destructor Destroy; override;\r\n function IsDockLoading: Boolean;\r\n function IsSaving: Boolean;\r\n procedure ShowDockForm(DockWindow: TWinControl);\r\n procedure HideDockForm(DockWindow: TWinControl);\r\n function GetFormVisible(DockWindow: TWinControl): Boolean;\r\n procedure SetTabDockHostBorderStyle(Value: TFormBorderStyle);\r\n procedure SetConjoinDockHostBorderStyle(Value: TFormBorderStyle);\r\n procedure SaveDockTreeToAppStorage(AppStorage: TJvCustomAppStorage; const AppStoragePath: string = '');\r\n procedure LoadDockTreeFromAppStorage(AppStorage: TJvCustomAppStorage; const AppStoragePath: string = '');\r\n procedure BeginDrag(Control: TControl; Immediate: Boolean; Threshold: Integer = -1); virtual;\r\n procedure DragInitControl(Control: TControl; Immediate: Boolean; Threshold: Integer); virtual;\r\n procedure DragInit(ADragObject: TJvDockDragDockObject; Immediate: Boolean; Threshold: Integer); virtual;\r\n procedure DragTo(const Pos: TPoint); virtual;\r\n procedure DragDone(Drop: Boolean); virtual;\r\n procedure CancelDrag; virtual;\r\n procedure ResetCursor; virtual;\r\n function DragFindTarget(const Pos: TPoint; var Handle: THandle;\r\n DragKind: TDragKind; Client: TControl): Pointer; virtual;\r\n procedure DoGetSiteInfo(Target, Client: TControl; var InfluenceRect: TRect;\r\n MousePos: TPoint; var CanDock: Boolean); virtual;\r\n function DoDockOver(DragState: TDragState): Boolean; virtual;\r\n procedure DoDockDrop(Source: TJvDockDragDockObject; Pos: TPoint); virtual;\r\n function DoUnDock(Source: TJvDockDragDockObject; Target: TWinControl; Client: TControl): Boolean; virtual;\r\n procedure DoEndDrag(Target: TObject; X, Y: Integer); virtual;\r\n function DragFindWindow(const Pos: TPoint): THandle; virtual;\r\n function GetDockSiteAtPos(MousePos: TPoint; Client: TControl): TWinControl; virtual;\r\n procedure DoGetDockEdge(Target: TControl; MousePos: TPoint; var DropAlign: TAlign); virtual;\r\n procedure RegisterDockSite(Site: TWinControl; DoRegister: Boolean); virtual;\r\n property DragObject: TJvDockDragDockObject read FDragObject write FDragObject;\r\n end;\r\n\r\n TJvDockCustomPanelSplitter = class(TJvCustomControl)\r\n private\r\n FActiveControl: TWinControl;\r\n FAutoSnap: Boolean;\r\n FBeveled: Boolean;\r\n FBrush: TBrush;\r\n FControl: TControl;\r\n FDownPos: TPoint;\r\n FLineDC: HDC;\r\n FLineVisible: Boolean;\r\n FMinSize: NaturalNumber;\r\n FMaxSize: Integer;\r\n FNewSize: Integer;\r\n FOldKeyDown: TKeyEvent;\r\n FOldSize: Integer;\r\n FPrevBrush: HBRUSH;\r\n FResizeStyle: TResizeStyle;\r\n FSplit: Integer;\r\n FOnCanResize: TCanResizeEvent;\r\n FOnMoved: TNotifyEvent;\r\n FOnPaint: TNotifyEvent;\r\n procedure AllocateLineDC;\r\n procedure CalcSplitSize(X, Y: Integer; var NewSize, Split: Integer);\r\n procedure DrawLine;\r\n procedure FocusKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);\r\n procedure ReleaseLineDC;\r\n procedure SetBeveled(Value: Boolean);\r\n procedure UpdateControlSize;\r\n procedure UpdateSize(X, Y: Integer);\r\n protected\r\n function CanResize(var NewSize: Integer): Boolean; reintroduce; virtual;\r\n function DoCanResize(var NewSize: Integer): Boolean; virtual;\r\n function FindControl: TControl; virtual;\r\n procedure MouseDown(Button: TMouseButton; Shift: TShiftState;\r\n X, Y: Integer); override;\r\n procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;\r\n procedure MouseUp(Button: TMouseButton; Shift: TShiftState;\r\n X, Y: Integer); override;\r\n procedure Paint; override;\r\n procedure RequestAlign; override;\r\n procedure StopSizing; dynamic;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n property Canvas;\r\n published\r\n property Align default alLeft;\r\n property AutoSnap: Boolean read FAutoSnap write FAutoSnap default True;\r\n property Beveled: Boolean read FBeveled write SetBeveled default False;\r\n property Color;\r\n property Constraints;\r\n property MinSize: NaturalNumber read FMinSize write FMinSize default 30;\r\n property ParentColor;\r\n property ResizeStyle: TResizeStyle read FResizeStyle write FResizeStyle\r\n default rsPattern;\r\n property Visible;\r\n property OnCanResize: TCanResizeEvent read FOnCanResize write FOnCanResize;\r\n property OnMoved: TNotifyEvent read FOnMoved write FOnMoved;\r\n property OnPaint: TNotifyEvent read FOnPaint write FOnPaint;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvDockSupportControl.pas $';\r\n Revision: '$Revision: 13415 $';\r\n Date: '$Date: 2012-09-10 11:51:54 +0200 (lun. 10 sept. 2012) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n Types, ComStrs, Consts, SysUtils,\r\n {$IFNDEF COMPILER12_UP}\r\n JvJCLUtils,\r\n {$ENDIF ~COMPILER12_UP}\r\n JvDockGlobals, JvDockControlForm, JvDockSupportProc, JvJVCLUtils;\r\n\r\ntype\r\n TlbNCButtonProc = procedure(Msg: TWMNCHitMessage; Button: TMouseButton;\r\n MouseStation: TJvDockMouseStation) of object;\r\n\r\n PCheckTargetInfo = ^TCheckTargetInfo;\r\n TCheckTargetInfo = record\r\n ClientWnd: THandle;\r\n TargetWnd: THandle;\r\n CurrentWnd: THandle;\r\n MousePos: TPoint;\r\n Found: Boolean;\r\n end;\r\n\r\n TControlAccessProtected = class(TControl);\r\n TWinControlAccessProtected = class(TWinControl);\r\n\r\n//=== Local procedures =======================================================\r\n\r\nfunction ButtonEvent(Page: TJvDockPageControl; Msg: TWMMouse;\r\n Button: TMouseButton; MouseStation: TJvDockMouseStation; Proc: TlbNCButtonProc): TControl;\r\nbegin\r\n Result := Page.GetDockClientFromMousePos(SmallPointToPoint(Msg.Pos));\r\n if (Result <> nil) and Assigned(Proc) then\r\n begin\r\n JvGlobalDockClient := FindDockClient(Result);\r\n Proc(Page.DoMouseEvent(Msg, Page), Button, MouseStation);\r\n end;\r\nend;\r\n\r\nprocedure TabControlError(const S: string);\r\nbegin\r\n raise EListError.Create(S);\r\nend;\r\n\r\nprocedure SetComCtlStyle(Ctl: TWinControl; Value: Integer; UseStyle: Boolean);\r\nvar\r\n Style: Integer;\r\nbegin\r\n if Ctl.HandleAllocated then\r\n begin\r\n Style := GetWindowLong(Ctl.Handle, GWL_STYLE);\r\n if not UseStyle then\r\n Style := Style and not Value\r\n else\r\n Style := Style or Value;\r\n SetWindowLong(Ctl.Handle, GWL_STYLE, Style);\r\n end;\r\nend;\r\n\r\nfunction IsBeforeTargetWindow(Window: HWND; Data: Longint): Bool; stdcall;\r\nvar\r\n R: TRect;\r\nbegin\r\n if Window = PCheckTargetInfo(Data)^.TargetWnd then\r\n Result := False\r\n else\r\n begin\r\n if PCheckTargetInfo(Data)^.CurrentWnd = 0 then\r\n begin\r\n GetWindowRect(Window, R);\r\n if PtInRect(R, PCheckTargetInfo(Data)^.MousePos) then\r\n PCheckTargetInfo(Data)^.CurrentWnd := Window;\r\n end;\r\n if Window = PCheckTargetInfo(Data)^.CurrentWnd then\r\n begin\r\n Result := False;\r\n PCheckTargetInfo(Data)^.Found := True;\r\n end\r\n else\r\n if Window = PCheckTargetInfo(Data)^.ClientWnd then\r\n begin\r\n Result := True;\r\n PCheckTargetInfo(Data)^.CurrentWnd := 0;\r\n end\r\n else\r\n Result := True;\r\n end;\r\nend;\r\n\r\n//=== { TJvDockCustomControl } ===============================================\r\n\r\nprocedure TJvDockCustomControl.CustomDockDrop(Source: TJvDockDragDockObject;\r\n X, Y: Integer);\r\nvar\r\n DestRect: TRect;\r\n Form: TCustomForm;\r\nbegin\r\n DestRect := Source.DockRect;\r\n MapWindowPoints(0, Handle, DestRect, 2);\r\n DisableAlign;\r\n try\r\n Source.Control.Dock(Self, DestRect);\r\n if UseDockManager and (DockManager <> nil) then\r\n DockManager.InsertControl(Source.Control,\r\n Source.DropAlign, Source.DropOnControl);\r\n finally\r\n EnableAlign;\r\n end;\r\n Form := GetParentForm(Self);\r\n if Form <> nil then\r\n Form.BringToFront;\r\n\r\n if Source.Control is TForm then\r\n begin\r\n TForm(Source.Control).ActiveControl := nil;\r\n SetDockSite(TForm(Source.Control), False);\r\n end;\r\nend;\r\n\r\nprocedure TJvDockCustomControl.CustomDockOver(Source: TJvDockDragDockObject;\r\n X, Y: Integer; State: TDragState; var Accept: Boolean);\r\nbegin\r\n CustomPositionDockRect(Source, X, Y);\r\nend;\r\n\r\nprocedure TJvDockCustomControl.CustomEndDock(Target: TObject; X, Y: Integer);\r\nbegin\r\nend;\r\n\r\nprocedure TJvDockCustomControl.CustomGetDockEdge(Source: TJvDockDragDockObject;\r\n MousePos: TPoint; var DropAlign: TAlign);\r\nbegin\r\n DropAlign := GetDockEdge(MousePos);\r\nend;\r\n\r\nprocedure TJvDockCustomControl.CustomGetSiteInfo(Source: TJvDockDragDockObject;\r\n Client: TControl; var InfluenceRect: TRect; MousePos: TPoint; var CanDock: Boolean);\r\nbegin\r\n GetWindowRect(Handle, InfluenceRect);\r\n InflateRect(InfluenceRect, DefExpandoRect, DefExpandoRect);\r\nend;\r\n\r\nprocedure TJvDockCustomControl.CustomPositionDockRect(Source: TJvDockDragDockObject;\r\n X, Y: Integer);\r\nvar\r\n NewWidth, NewHeight: Integer;\r\n TempX, TempY: Double;\r\n R: TRect;\r\nbegin\r\n with Source do\r\n begin\r\n if (DragTarget = nil) or (not TWinControlAccessProtected(DragTarget).UseDockManager) then\r\n begin\r\n NewWidth := Control.UndockWidth;\r\n NewHeight := Control.UndockHeight;\r\n TempX := DragPos.X - ((NewWidth) * MouseDeltaX);\r\n TempY := DragPos.Y - ((NewHeight) * MouseDeltaY);\r\n R := DockRect;\r\n R.Left := Round(TempX);\r\n R.Top := Round(TempY);\r\n R.Right := R.Left + NewWidth;\r\n R.Bottom := R.Top + NewHeight;\r\n DockRect := R;\r\n AdjustDockRect(DockRect);\r\n end\r\n else\r\n begin\r\n GetWindowRect(TargetControl.Handle, R);\r\n DockRect := R;\r\n if TWinControlAccessProtected(DragTarget).UseDockManager then\r\n if TargetControl is TJvDockCustomPanel then\r\n if TJvDockCustomPanel(DragTarget).JvDockManager <> nil then\r\n begin\r\n R := DockRect;\r\n TJvDockCustomPanel(DragTarget).JvDockManager.PositionDockRect(Control,\r\n DropOnControl, DropAlign, R);\r\n DockRect := R;\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockCustomControl.CustomStartDock(var Source: TJvDockDragDockObject);\r\nbegin\r\nend;\r\n\r\nfunction TJvDockCustomControl.CustomUnDock(Source: TJvDockDragDockObject;\r\n NewTarget: TWinControl; Client: TControl): Boolean;\r\nbegin\r\n Result := (Perform(CM_UNDOCKCLIENT, WPARAM(NewTarget), LPARAM(Client)) = 0);\r\nend;\r\n\r\nfunction TJvDockCustomControl.GetJvDockManager: IJvDockManager;\r\nbegin\r\n Result := IJvDockManager(DockManager);\r\nend;\r\n\r\nprocedure TJvDockCustomControl.UpdateCaption(Exclude: TControl);\r\nvar\r\n I: Integer;\r\n Host: TJvDockableForm;\r\nbegin\r\n if Parent is TJvDockableForm then\r\n begin\r\n Host := TJvDockableForm(Parent);\r\n Host.Caption := '';\r\n\r\n for I := 0 to Host.DockableControl.DockClientCount - 1 do\r\n if Host.DockableControl.DockClients[I].Visible and (Host.DockableControl.DockClients[I] <> Exclude) then\r\n Host.Caption := Host.Caption + TCustomForm(Host.DockableControl.DockClients[I]).Caption + RsDockStringSplitter;\r\n\r\n if Host.HostDockSite is TJvDockTabPageControl then\r\n with TJvDockTabPageControl(Host.HostDockSite) do\r\n if (ActivePage <> nil) and (ActivePage.Controls[0] = Self) then\r\n ActivePage.Caption := Host.Caption;\r\n if Host.HostDockSite is TJvDockCustomControl then\r\n TJvDockCustomControl(Host.HostDockSite).UpdateCaption(nil);\r\n end;\r\nend;\r\n\r\nprocedure TJvDockCustomControl.WndProc(var Msg: TMessage);\r\nvar\r\n CMUnDockClient: TCMUnDockClient;\r\n DockableForm: TJvDockableForm;\r\nbegin\r\n if Msg.Msg = CM_UNDOCKCLIENT then\r\n begin\r\n CMUnDockClient := TCMUnDockClient(Msg);\r\n if CMUnDockClient.Client is TJvDockableForm then\r\n begin\r\n DockableForm := TJvDockableForm(CMUnDockClient.Client);\r\n if DockableForm.FloatingChild <> nil then\r\n begin\r\n if Self is TJvDockTabPageControl then\r\n DockableForm.FloatingChild.ManualDock(Self)\r\n else\r\n begin\r\n DisableAlign;\r\n try\r\n { using a null-rect as parameter for Dock causes align problems }\r\n// DockableForm.FloatingChild.Dock(Self, Rect(0, 0, 0, 0));\r\n DockableForm.FloatingChild.Dock(Self, Self.BoundsRect);\r\n finally\r\n EnableAlign;\r\n end;\r\n end;\r\n DockableForm.FloatingChild.Visible := True;\r\n if Self is TJvDockCustomPanel then\r\n JvDockManager.ReplaceZoneChild(DockableForm, DockableForm.FloatingChild);\r\n end;\r\n end;\r\n end;\r\n inherited WndProc(Msg);\r\nend;\r\n\r\n//=== { TJvDockCustomPanel } =================================================\r\n\r\nconstructor TJvDockCustomPanel.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n ControlStyle := [csAcceptsControls, csCaptureMouse, csClickEvents,\r\n csSetCaption, csOpaque, csDoubleClicks, csReplicatable];\r\n Color := clBtnFace;\r\n UseDockManager := True;\r\nend;\r\n\r\ndestructor TJvDockCustomPanel.Destroy;\r\nbegin\r\n SetDockSite(Self, False);\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJvDockCustomPanel.CreateDockManager: IDockManager;\r\nbegin\r\n if (DockManager = nil) and DockSite and UseDockManager then\r\n Result := DefaultDockTreeClass.Create(Self, DefaultDockZoneClass, nil) as IJvDockManager\r\n else\r\n Result := DockManager;\r\n DoubleBuffered := DoubleBuffered or (Result <> nil);\r\nend;\r\n\r\n//=== { TJvDockCustomPanelSplitter } =========================================\r\n\r\nconstructor TJvDockCustomPanelSplitter.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FAutoSnap := True;\r\n Align := alLeft;\r\n Width := 3;\r\n Cursor := crHSplit;\r\n FMinSize := 30;\r\n FResizeStyle := rsPattern;\r\n FOldSize := -1;\r\nend;\r\n\r\ndestructor TJvDockCustomPanelSplitter.Destroy;\r\nbegin\r\n FBrush.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvDockCustomPanelSplitter.AllocateLineDC;\r\nbegin\r\n FLineDC := GetDCEx(Parent.Handle, 0,\r\n DCX_CACHE or DCX_CLIPSIBLINGS or DCX_LOCKWINDOWUPDATE);\r\n if ResizeStyle = rsPattern then\r\n begin\r\n if FBrush = nil then\r\n begin\r\n FBrush := TBrush.Create;\r\n FBrush.Bitmap := AllocPatternBitmap(clBlack, clWhite);\r\n end;\r\n FPrevBrush := SelectObject(FLineDC, FBrush.Handle);\r\n end;\r\nend;\r\n\r\nprocedure TJvDockCustomPanelSplitter.CalcSplitSize(X, Y: Integer; var NewSize, Split: Integer);\r\nvar\r\n S: Integer;\r\nbegin\r\n if Align in [alLeft, alRight] then\r\n Split := X - FDownPos.X\r\n else\r\n Split := Y - FDownPos.Y;\r\n S := 0;\r\n case Align of\r\n alLeft:\r\n S := FControl.Width + Split;\r\n alRight:\r\n S := FControl.Width - Split;\r\n alTop:\r\n S := FControl.Height + Split;\r\n alBottom:\r\n S := FControl.Height - Split;\r\n end;\r\n NewSize := S;\r\n if S < FMinSize then\r\n NewSize := FMinSize\r\n else\r\n if S > FMaxSize then\r\n NewSize := FMaxSize;\r\n if S <> NewSize then\r\n begin\r\n if Align in [alRight, alBottom] then\r\n S := S - NewSize\r\n else\r\n S := NewSize - S;\r\n Inc(Split, S);\r\n end;\r\nend;\r\n\r\nfunction TJvDockCustomPanelSplitter.CanResize(var NewSize: Integer): Boolean;\r\nbegin\r\n Result := True;\r\n if Assigned(FOnCanResize) then\r\n FOnCanResize(Self, NewSize, Result);\r\nend;\r\n\r\nfunction TJvDockCustomPanelSplitter.DoCanResize(var NewSize: Integer): Boolean;\r\nbegin\r\n Result := CanResize(NewSize);\r\n if Result and (NewSize <= MinSize) and FAutoSnap then\r\n NewSize := 0;\r\nend;\r\n\r\nprocedure TJvDockCustomPanelSplitter.DrawLine;\r\nvar\r\n X, Y: Integer;\r\nbegin\r\n FLineVisible := not FLineVisible;\r\n X := Left;\r\n Y := Top;\r\n if Align in [alLeft, alRight] then\r\n X := Left + FSplit\r\n else\r\n Y := Top + FSplit;\r\n PatBlt(FLineDC, X, Y, Width, Height, PATINVERT);\r\nend;\r\n\r\nfunction TJvDockCustomPanelSplitter.FindControl: TControl;\r\nvar\r\n P: TPoint;\r\n I: Integer;\r\n R: TRect;\r\nbegin\r\n Result := nil;\r\n P := Point(Left, Top);\r\n case Align of\r\n alLeft:\r\n Dec(P.X);\r\n alRight:\r\n Inc(P.X, Width);\r\n alTop:\r\n Dec(P.Y);\r\n alBottom:\r\n Inc(P.Y, Height);\r\n else\r\n Exit;\r\n end;\r\n for I := 0 to Parent.ControlCount - 1 do\r\n begin\r\n Result := Parent.Controls[I];\r\n if Result.Visible and Result.Enabled then\r\n begin\r\n R := Result.BoundsRect;\r\n if (R.Right - R.Left) = 0 then\r\n if Align in [alTop, alLeft] then\r\n Dec(R.Left)\r\n else\r\n Inc(R.Right);\r\n if (R.Bottom - R.Top) = 0 then\r\n if Align in [alTop, alLeft] then\r\n Dec(R.Top)\r\n else\r\n Inc(R.Bottom);\r\n if PtInRect(R, P) then\r\n Exit;\r\n end;\r\n end;\r\n Result := nil;\r\nend;\r\n\r\nprocedure TJvDockCustomPanelSplitter.FocusKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);\r\nbegin\r\n if Key = VK_ESCAPE then\r\n StopSizing\r\n else\r\n if Assigned(FOldKeyDown) then\r\n FOldKeyDown(Sender, Key, Shift);\r\nend;\r\n\r\nprocedure TJvDockCustomPanelSplitter.MouseDown(Button: TMouseButton; Shift: TShiftState;\r\n X, Y: Integer);\r\nvar\r\n I: Integer;\r\nbegin\r\n inherited MouseDown(Button, Shift, X, Y);\r\n if Button = mbLeft then\r\n begin\r\n FControl := FindControl;\r\n FDownPos := Point(X, Y);\r\n if Assigned(FControl) then\r\n begin\r\n if Align in [alLeft, alRight] then\r\n begin\r\n FMaxSize := Parent.ClientWidth - FMinSize;\r\n for I := 0 to Parent.ControlCount - 1 do\r\n with Parent.Controls[I] do\r\n if Visible and (Align in [alLeft, alRight]) then\r\n Dec(FMaxSize, Width);\r\n Inc(FMaxSize, FControl.Width);\r\n end\r\n else\r\n begin\r\n FMaxSize := Parent.ClientHeight - FMinSize;\r\n for I := 0 to Parent.ControlCount - 1 do\r\n with Parent.Controls[I] do\r\n if Align in [alTop, alBottom] then\r\n Dec(FMaxSize, Height);\r\n Inc(FMaxSize, FControl.Height);\r\n end;\r\n UpdateSize(X, Y);\r\n AllocateLineDC;\r\n with ValidParentForm(Self) do\r\n if ActiveControl <> nil then\r\n begin\r\n FActiveControl := ActiveControl;\r\n FOldKeyDown := TWinControlAccessProtected(FActiveControl).OnKeyDown;\r\n TWinControlAccessProtected(FActiveControl).OnKeyDown := FocusKeyDown;\r\n end;\r\n if ResizeStyle in [rsLine, rsPattern] then\r\n DrawLine;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockCustomPanelSplitter.MouseMove(Shift: TShiftState; X, Y: Integer);\r\nvar\r\n NewSize, Split: Integer;\r\nbegin\r\n inherited MouseMove(Shift, X, Y);\r\n if (ssLeft in Shift) and Assigned(FControl) then\r\n begin\r\n CalcSplitSize(X, Y, NewSize, Split);\r\n if DoCanResize(NewSize) and (FNewSize <> NewSize) then\r\n begin\r\n if ResizeStyle in [rsLine, rsPattern] then\r\n DrawLine;\r\n FNewSize := NewSize;\r\n FSplit := Split;\r\n if ResizeStyle = rsUpdate then\r\n UpdateControlSize;\r\n if ResizeStyle in [rsLine, rsPattern] then\r\n DrawLine;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockCustomPanelSplitter.MouseUp(Button: TMouseButton; Shift: TShiftState;\r\n X, Y: Integer);\r\nbegin\r\n inherited MouseUp(Button, Shift, X, Y);\r\n if Assigned(FControl) then\r\n begin\r\n if ResizeStyle in [rsLine, rsPattern] then\r\n DrawLine;\r\n UpdateControlSize;\r\n StopSizing;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockCustomPanelSplitter.Paint;\r\nvar\r\n FrameBrush: HBRUSH;\r\n R: TRect;\r\nbegin\r\n R := ClientRect;\r\n Canvas.Brush.Color := Color;\r\n Canvas.FillRect(ClientRect);\r\n if Beveled then\r\n begin\r\n if Align in [alLeft, alRight] then\r\n InflateRect(R, -1, 2)\r\n else\r\n InflateRect(R, 2, -1);\r\n OffsetRect(R, 1, 1);\r\n FrameBrush := CreateSolidBrush(ColorToRGB(clBtnHighlight));\r\n FrameRect(Canvas.Handle, R, FrameBrush);\r\n DeleteObject(FrameBrush);\r\n OffsetRect(R, -2, -2);\r\n FrameBrush := CreateSolidBrush(ColorToRGB(clBtnShadow));\r\n FrameRect(Canvas.Handle, R, FrameBrush);\r\n DeleteObject(FrameBrush);\r\n end;\r\n\r\n if csDesigning in ComponentState then\r\n with Canvas do\r\n begin\r\n Pen.Style := psDot;\r\n Pen.Mode := pmXor;\r\n Pen.Color := JvDockXorColor;\r\n Brush.Style := bsClear;\r\n Rectangle(0, 0, ClientWidth, ClientHeight);\r\n end;\r\n\r\n if Assigned(FOnPaint) then\r\n FOnPaint(Self);\r\nend;\r\n\r\nprocedure TJvDockCustomPanelSplitter.ReleaseLineDC;\r\nbegin\r\n if FPrevBrush <> 0 then\r\n SelectObject(FLineDC, FPrevBrush);\r\n ReleaseDC(Parent.Handle, FLineDC);\r\n if FBrush <> nil then\r\n begin\r\n FBrush.Free;\r\n FBrush := nil;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockCustomPanelSplitter.RequestAlign;\r\nbegin\r\n inherited RequestAlign;\r\n if (Cursor <> crVSplit) and (Cursor <> crHSplit) then\r\n Exit;\r\n if Align in [alBottom, alTop] then\r\n Cursor := crVSplit\r\n else\r\n Cursor := crHSplit;\r\nend;\r\n\r\nprocedure TJvDockCustomPanelSplitter.SetBeveled(Value: Boolean);\r\nbegin\r\n FBeveled := Value;\r\n Repaint;\r\nend;\r\n\r\nprocedure TJvDockCustomPanelSplitter.StopSizing;\r\nbegin\r\n if Assigned(FControl) then\r\n begin\r\n if FLineVisible then\r\n DrawLine;\r\n FControl := nil;\r\n ReleaseLineDC;\r\n if Assigned(FActiveControl) then\r\n begin\r\n TWinControlAccessProtected(FActiveControl).OnKeyDown := FOldKeyDown;\r\n FActiveControl := nil;\r\n end;\r\n end;\r\n if Assigned(FOnMoved) then\r\n FOnMoved(Self);\r\nend;\r\n\r\nprocedure TJvDockCustomPanelSplitter.UpdateControlSize;\r\nbegin\r\n if FNewSize <> FOldSize then\r\n begin\r\n case Align of\r\n alLeft:\r\n FControl.Width := FNewSize;\r\n alTop:\r\n FControl.Height := FNewSize;\r\n alRight:\r\n begin\r\n Parent.DisableAlign;\r\n try\r\n FControl.Left := FControl.Left + (FControl.Width - FNewSize);\r\n FControl.Width := FNewSize;\r\n finally\r\n Parent.EnableAlign;\r\n end;\r\n end;\r\n alBottom:\r\n begin\r\n Parent.DisableAlign;\r\n try\r\n FControl.Top := FControl.Top + (FControl.Height - FNewSize);\r\n FControl.Height := FNewSize;\r\n finally\r\n Parent.EnableAlign;\r\n end;\r\n end;\r\n end;\r\n TControlAccessProtected(FControl).Resize;\r\n Update;\r\n if Assigned(FOnMoved) then\r\n FOnMoved(Self);\r\n FOldSize := FNewSize;\r\n\r\n end;\r\nend;\r\n\r\nprocedure TJvDockCustomPanelSplitter.UpdateSize(X, Y: Integer);\r\nbegin\r\n CalcSplitSize(X, Y, FNewSize, FSplit);\r\nend;\r\n\r\n//=== { TJvDockCustomTabControl } ============================================\r\n\r\nconstructor TJvDockCustomTabControl.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n Width := 289;\r\n Height := 193;\r\n TabStop := True;\r\n ControlStyle := [csAcceptsControls, csDoubleClicks];\r\n FTabs := TJvDockTabStrings.Create;\r\n FTabs.FTabControl := Self;\r\n FImageChangeLink := TChangeLink.Create;\r\n FImageChangeLink.OnChange := ImageListChange;\r\nend;\r\n\r\ndestructor TJvDockCustomTabControl.Destroy;\r\nbegin\r\n FreeAndNil(FTabs);\r\n FreeAndNil(FSaveTabs);\r\n FreeAndNil(FImageChangeLink);\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvDockCustomTabControl.AdjustClientRect(var Rect: TRect);\r\nbegin\r\n Rect := DisplayRect;\r\n inherited AdjustClientRect(Rect);\r\nend;\r\n\r\nfunction TJvDockCustomTabControl.CanChange: Boolean;\r\nbegin\r\n Result := True;\r\n if Assigned(FOnChanging) then\r\n FOnChanging(Self, Result);\r\nend;\r\n\r\nfunction TJvDockCustomTabControl.CanShowTab(TabIndex: Integer): Boolean;\r\nbegin\r\n Result := True;\r\nend;\r\n\r\nprocedure TJvDockCustomTabControl.Change;\r\nbegin\r\n if Assigned(FOnChange) then\r\n FOnChange(Self);\r\nend;\r\n\r\nprocedure TJvDockCustomTabControl.CMDialogChar(var Msg: TCMDialogChar);\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := 0 to FTabs.Count - 1 do\r\n if IsAccel(Msg.CharCode, FTabs[I]) and CanShowTab(I) and CanFocus then\r\n begin\r\n Msg.Result := 1;\r\n if CanChange then\r\n begin\r\n TabIndex := I;\r\n Change;\r\n end;\r\n Exit;\r\n end;\r\n inherited;\r\nend;\r\n\r\nprocedure TJvDockCustomTabControl.CMFontChanged(var Msg);\r\nbegin\r\n inherited;\r\n if HandleAllocated then\r\n Perform(WM_SIZE, 0, 0);\r\nend;\r\n\r\nprocedure TJvDockCustomTabControl.CMSysColorChange(var Msg: TMessage);\r\nbegin\r\n inherited;\r\n if not (csLoading in ComponentState) then\r\n begin\r\n Msg.Msg := WM_SYSCOLORCHANGE;\r\n DefaultHandler(Msg);\r\n end;\r\nend;\r\n\r\nprocedure TJvDockCustomTabControl.CMTabStopChanged(var Msg: TMessage);\r\nbegin\r\n if not (csDesigning in ComponentState) then\r\n RecreateWnd;\r\nend;\r\n\r\nprocedure TJvDockCustomTabControl.CNDrawItem(var Msg: TWMDrawItem);\r\nvar\r\n SaveIndex: Integer;\r\nbegin\r\n with Msg.DrawItemStruct^ do\r\n begin\r\n SaveIndex := SaveDC(hDC);\r\n Canvas.Lock;\r\n try\r\n Canvas.Handle := hDC;\r\n Canvas.Font := Font;\r\n Canvas.Brush := Brush;\r\n DrawTab(itemID, rcItem, itemState and ODS_SELECTED <> 0);\r\n finally\r\n Canvas.Handle := 0;\r\n Canvas.Unlock;\r\n RestoreDC(hDC, SaveIndex);\r\n end;\r\n end;\r\n Msg.Result := 1;\r\nend;\r\n\r\nprocedure TJvDockCustomTabControl.CNNotify(var Msg: TWMNotify);\r\nbegin\r\n with Msg do\r\n case NMHdr^.code of\r\n TCN_SELCHANGE:\r\n Change;\r\n TCN_SELCHANGING:\r\n Result := Ord(not CanChange);\r\n end;\r\nend;\r\n\r\nprocedure TJvDockCustomTabControl.CreateParams(var Params: TCreateParams);\r\nconst\r\n AlignStyles: array [Boolean, TTabPosition] of DWORD =\r\n ((0, TCS_BOTTOM, TCS_VERTICAL, TCS_VERTICAL or TCS_RIGHT),\r\n (0, TCS_BOTTOM, TCS_VERTICAL or TCS_RIGHT, TCS_VERTICAL));\r\n TabStyles: array [TTabStyle] of DWORD =\r\n (TCS_TABS, TCS_BUTTONS, TCS_BUTTONS or TCS_FLATBUTTONS);\r\n RRStyles: array [Boolean] of DWORD =\r\n (0, TCS_RAGGEDRIGHT);\r\nbegin\r\n InitCommonControl(ICC_TAB_CLASSES);\r\n inherited CreateParams(Params);\r\n CreateSubClass(Params, WC_TABCONTROL);\r\n with Params do\r\n begin\r\n Style := Style or WS_CLIPCHILDREN or\r\n AlignStyles[UseRightToLeftAlignment, FTabPosition] or\r\n TabStyles[FStyle] or RRStyles[FRaggedRight];\r\n if not TabStop then\r\n Style := Style or TCS_FOCUSNEVER;\r\n if FMultiLine then\r\n Style := Style or TCS_MULTILINE;\r\n if FMultiSelect then\r\n Style := Style or TCS_MULTISELECT;\r\n if FOwnerDraw then\r\n Style := Style or TCS_OWNERDRAWFIXED;\r\n if FTabSize.X <> 0 then\r\n Style := Style or TCS_FIXEDWIDTH;\r\n if FHotTrack and (not (csDesigning in ComponentState)) then\r\n Style := Style or TCS_HOTTRACK;\r\n if FScrollOpposite then\r\n Style := Style or TCS_SCROLLOPPOSITE;\r\n WindowClass.style := WindowClass.style and\r\n not (CS_HREDRAW or CS_VREDRAW) or CS_DBLCLKS;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockCustomTabControl.CreateWnd;\r\nbegin\r\n inherited CreateWnd;\r\n if (Images <> nil) and Images.HandleAllocated then\r\n Perform(TCM_SETIMAGELIST, 0, LPARAM(Images.Handle));\r\n if Integer(FTabSize) <> 0 then\r\n UpdateTabSize;\r\n if FSaveTabs <> nil then\r\n begin\r\n FTabs.Assign(FSaveTabs);\r\n SetTabIndex(FSaveTabIndex);\r\n FSaveTabs.Free;\r\n FSaveTabs := nil;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockCustomTabControl.DrawTab(TabIndex: Integer; const Rect: TRect;\r\n Active: Boolean);\r\nbegin\r\n if Assigned(FOnDrawTab) then\r\n FOnDrawTab(Self, TabIndex, Rect, Active)\r\n else\r\n Canvas.FillRect(Rect);\r\nend;\r\n\r\nfunction TJvDockCustomTabControl.GetDisplayRect: TRect;\r\nbegin\r\n Result := ClientRect;\r\n SendMessage(Handle, TCM_ADJUSTRECT, 0, LPARAM(@Result));\r\n if TabPosition = tpTop then\r\n Inc(Result.Top, 2);\r\nend;\r\n\r\nfunction TJvDockCustomTabControl.GetHitTestInfoAt(X, Y: Integer): THitTests;\r\nvar\r\n HitTest: TTCHitTestInfo;\r\nbegin\r\n Result := [];\r\n if PtInRect(ClientRect, Point(X, Y)) then\r\n begin\r\n HitTest.pt.X := X;\r\n HitTest.pt.Y := Y;\r\n if TabCtrl_HitTest(Handle, @HitTest) <> -1 then\r\n begin\r\n if (HitTest.flags and TCHT_NOWHERE) <> 0 then\r\n Include(Result, htNowhere);\r\n if (HitTest.flags and TCHT_ONITEM) = TCHT_ONITEM then\r\n Include(Result, htOnItem)\r\n else\r\n begin\r\n if (HitTest.flags and TCHT_ONITEM) <> 0 then\r\n Include(Result, htOnItem);\r\n if (HitTest.flags and TCHT_ONITEMICON) <> 0 then\r\n Include(Result, htOnIcon);\r\n if (HitTest.flags and TCHT_ONITEMLABEL) <> 0 then\r\n Include(Result, htOnLabel);\r\n end;\r\n end\r\n else\r\n Result := [htNowhere];\r\n end;\r\nend;\r\n\r\nfunction TJvDockCustomTabControl.GetImageIndex(TabIndex: Integer): Integer;\r\nbegin\r\n Result := TabIndex;\r\n if Assigned(FOnGetImageIndex) then\r\n FOnGetImageIndex(Self, TabIndex, Result);\r\nend;\r\n\r\nfunction TJvDockCustomTabControl.GetTabIndex: Integer;\r\nbegin\r\n Result := SendMessage(Handle, TCM_GETCURSEL, 0, 0);\r\nend;\r\n\r\nfunction TJvDockCustomTabControl.GetTabs: TStrings;\r\nbegin\r\n Result := FTabs;\r\nend;\r\n\r\nprocedure TJvDockCustomTabControl.ImageListChange(Sender: TObject);\r\nbegin\r\n Perform(TCM_SETIMAGELIST, 0, LPARAM(TCustomImageList(Sender).Handle));\r\nend;\r\n\r\nfunction TJvDockCustomTabControl.IndexOfTabAt(X, Y: Integer): Integer;\r\nvar\r\n HitTest: TTCHitTestInfo;\r\nbegin\r\n Result := -1;\r\n if PtInRect(ClientRect, Point(X, Y)) then\r\n begin\r\n HitTest.pt.X := X;\r\n HitTest.pt.Y := Y;\r\n Result := TabCtrl_HitTest(Handle, @HitTest);\r\n end;\r\nend;\r\n\r\nfunction TJvDockCustomTabControl.InternalSetMultiLine(Value: Boolean): Boolean;\r\nbegin\r\n Result := FMultiLine <> Value;\r\n if Result then\r\n begin\r\n if not Value and ((TabPosition = tpLeft) or (TabPosition = tpRight)) then\r\n TabControlError(sTabMustBeMultiLine);\r\n FMultiLine := Value;\r\n if not Value then\r\n FScrollOpposite := False;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockCustomTabControl.Loaded;\r\nbegin\r\n inherited Loaded;\r\n if Images <> nil then\r\n UpdateTabImages;\r\nend;\r\n\r\nprocedure TJvDockCustomTabControl.Notification(AComponent: TComponent;\r\n Operation: TOperation);\r\nbegin\r\n inherited Notification(AComponent, Operation);\r\n if (Operation = opRemove) and (AComponent = Images) then\r\n Images := nil;\r\nend;\r\n\r\nprocedure TJvDockCustomTabControl.PaintWindow(DC: HDC);\r\nvar\r\n Msg: TMessage;\r\nbegin\r\n if not OwnerDraw then\r\n begin\r\n Msg.Msg := WM_PAINT;\r\n Msg.WParam := DC;\r\n Msg.LParam := 0;\r\n Msg.Result := 0;\r\n DefaultHandler(Msg);\r\n end;\r\n inherited PaintWindow(DC);\r\nend;\r\n\r\nfunction TJvDockCustomTabControl.RowCount: Integer;\r\nbegin\r\n Result := TabCtrl_GetRowCount(Handle);\r\nend;\r\n\r\nprocedure TJvDockCustomTabControl.ScrollTabs(Delta: Integer);\r\nvar\r\n Wnd: HWND;\r\n P: TPoint;\r\n Rect: TRect;\r\n I: Integer;\r\nbegin\r\n Wnd := FindWindowEx(Handle, 0, 'msctls_updown32', nil);\r\n if Wnd <> 0 then\r\n begin\r\n Windows.GetClientRect(Wnd, Rect);\r\n if Delta < 0 then\r\n P.X := Rect.Left + 2\r\n else\r\n P.X := Rect.Right - 2;\r\n P.Y := Rect.Top + 2;\r\n for I := 0 to Abs(Delta) - 1 do\r\n begin\r\n SendMessage(Wnd, WM_LBUTTONDOWN, 0, MakeLParam(P.X, P.Y));\r\n SendMessage(Wnd, WM_LBUTTONUP, 0, MakeLParam(P.X, P.Y));\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockCustomTabControl.SetHotTrack(Value: Boolean);\r\nbegin\r\n if FHotTrack <> Value then\r\n begin\r\n FHotTrack := Value;\r\n RecreateWnd;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockCustomTabControl.SetImages(Value: TCustomImageList);\r\nbegin\r\n ReplaceImageListReference(Self, Value, FImages, FImageChangeLink);\r\n if Images <> nil then\r\n Perform(TCM_SETIMAGELIST, 0, LPARAM(Images.Handle))\r\n else\r\n Perform(TCM_SETIMAGELIST, 0, 0);\r\nend;\r\n\r\nprocedure TJvDockCustomTabControl.SetMultiLine(Value: Boolean);\r\nbegin\r\n if InternalSetMultiLine(Value) then\r\n RecreateWnd;\r\nend;\r\n\r\nprocedure TJvDockCustomTabControl.SetMultiSelect(Value: Boolean);\r\nbegin\r\n if FMultiSelect <> Value then\r\n begin\r\n FMultiSelect := Value;\r\n RecreateWnd;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockCustomTabControl.SetOwnerDraw(Value: Boolean);\r\nbegin\r\n if FOwnerDraw <> Value then\r\n begin\r\n FOwnerDraw := Value;\r\n RecreateWnd;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockCustomTabControl.SetRaggedRight(Value: Boolean);\r\nbegin\r\n if FRaggedRight <> Value then\r\n begin\r\n FRaggedRight := Value;\r\n SetComCtlStyle(Self, TCS_RAGGEDRIGHT, Value);\r\n end;\r\nend;\r\n\r\nprocedure TJvDockCustomTabControl.SetScrollOpposite(Value: Boolean);\r\nbegin\r\n if FScrollOpposite <> Value then\r\n begin\r\n FScrollOpposite := Value;\r\n if Value then\r\n FMultiLine := Value;\r\n RecreateWnd;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockCustomTabControl.SetStyle(Value: TTabStyle);\r\nbegin\r\n if FStyle <> Value then\r\n begin\r\n if (Value <> tsTabs) and (TabPosition <> tpTop) then\r\n raise EInvalidOperation.CreateRes(@SInvalidTabStyle);\r\n FStyle := Value;\r\n RecreateWnd;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockCustomTabControl.SetTabHeight(Value: Smallint);\r\nbegin\r\n if FTabSize.Y <> Value then\r\n begin\r\n if Value < 0 then\r\n raise EInvalidOperation.CreateResFmt(@SPropertyOutOfRange, [Self.Classname]);\r\n FTabSize.Y := Value;\r\n UpdateTabSize;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockCustomTabControl.SetTabIndex(Value: Integer);\r\nbegin\r\n SendMessage(Handle, TCM_SETCURSEL, Value, 0);\r\nend;\r\n\r\nprocedure TJvDockCustomTabControl.SetTabPosition(Value: TTabPosition);\r\nbegin\r\n if FTabPosition <> Value then\r\n begin\r\n if (Value <> tpTop) and (Style <> tsTabs) then\r\n raise EInvalidOperation.CreateRes(@SInvalidTabPosition);\r\n FTabPosition := Value;\r\n if not MultiLine and ((Value = tpLeft) or (Value = tpRight)) then\r\n InternalSetMultiLine(True);\r\n RecreateWnd;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockCustomTabControl.SetTabs(Value: TStrings);\r\nbegin\r\n FTabs.Assign(Value);\r\nend;\r\n\r\nprocedure TJvDockCustomTabControl.SetTabWidth(Value: Smallint);\r\nvar\r\n OldValue: Smallint;\r\nbegin\r\n if FTabSize.X <> Value then\r\n begin\r\n if Value < 0 then\r\n raise EInvalidOperation.CreateResFmt(@SPropertyOutOfRange, [Self.ClassName]);\r\n OldValue := FTabSize.X;\r\n FTabSize.X := Value;\r\n if (OldValue = 0) or (Value = 0) then\r\n RecreateWnd\r\n else\r\n UpdateTabSize;\r\n end;\r\nend;\r\n\r\nfunction TJvDockCustomTabControl.TabRect(Index: Integer): TRect;\r\nbegin\r\n TabCtrl_GetItemRect(Handle, Index, Result);\r\nend;\r\n\r\nprocedure TJvDockCustomTabControl.TabsChanged;\r\nbegin\r\n if not FUpdating then\r\n begin\r\n if HandleAllocated then\r\n SendMessage(Handle, WM_SIZE, SIZE_RESTORED, MakeLong(Word(Width), Word(Height)));\r\n Realign;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockCustomTabControl.TCMAdjustRect(var Msg: TMessage);\r\nbegin\r\n try\r\n inherited;\r\n if (TabPosition <> tpTop) and (Msg.WParam = 0) then\r\n FSavedAdjustRect := PRect(Msg.LParam)^;\r\n except\r\n PRect(Msg.LParam)^ := FSavedAdjustRect;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockCustomTabControl.UpdateTabImages;\r\nvar\r\n I: Integer;\r\n TCItem: TTCItem;\r\nbegin\r\n TCItem.mask := TCIF_IMAGE;\r\n for I := 0 to FTabs.Count - 1 do\r\n begin\r\n TCItem.iImage := GetImageIndex(I);\r\n if SendMessage(Handle, TCM_SETITEM, I, LPARAM(@TCItem)) = 0 then\r\n TabControlError(Format(sTabFailSet, [FTabs[I], I]));\r\n end;\r\n TabsChanged;\r\nend;\r\n\r\nprocedure TJvDockCustomTabControl.UpdateTabSize;\r\nbegin\r\n SendMessage(Handle, TCM_SETITEMSIZE, 0, {$IFDEF RTL230_UP}PointToLParam{$ELSE}LPARAM{$ENDIF RTL230_UP}(FTabSize));\r\n TabsChanged;\r\nend;\r\n\r\nprocedure TJvDockCustomTabControl.WMDestroy(var Msg: TWMDestroy);\r\nvar\r\n FocusHandle: HWND;\r\nbegin\r\n if (FTabs <> nil) and (FTabs.Count > 0) then\r\n begin\r\n FSaveTabs := TStringList.Create;\r\n FSaveTabs.Assign(FTabs);\r\n FSaveTabIndex := GetTabIndex;\r\n end;\r\n FocusHandle := GetFocus;\r\n if (FocusHandle <> 0) and ((FocusHandle = Handle) or\r\n IsChild(Handle, FocusHandle)) then\r\n Windows.SetFocus(0);\r\n inherited;\r\n WindowHandle := 0;\r\nend;\r\n\r\nprocedure TJvDockCustomTabControl.WMNotifyFormat(var Msg: TMessage);\r\nbegin\r\n with Msg do\r\n Result := DefWindowProc(Handle, Msg, WParam, LParam);\r\nend;\r\n\r\nprocedure TJvDockCustomTabControl.WMSize(var Msg: TMessage);\r\nbegin\r\n inherited;\r\n RedrawWindow(Handle, nil, 0, RDW_INVALIDATE or RDW_ERASE);\r\nend;\r\n\r\n//=== { TJvAlphaBlendedForm } ==============================================\r\n\r\nprocedure TJvAlphaBlendedForm.CreateParams(var Params: TCreateParams);\r\nbegin\r\n inherited CreateParams(Params);\r\n Params.ExStyle := Params.ExStyle or WS_EX_TRANSPARENT;\r\nend;\r\n\r\n//=== { TJvDockDragDockObject } ==============================================\r\n\r\nconstructor TJvDockDragDockObject.Create(AControl: TControl);\r\nbegin\r\n inherited Create;\r\n FControl := AControl;\r\n FBrush := TBrush.Create;\r\n FBrush.Bitmap := AllocPatternBitmap(clBlack, clWhite);\r\n FFrameWidth := 4;\r\n FCtrlDown := False;\r\n\r\n FAlphaBlendedForm := GetAlphaBlendedTab; { create the form ... }\r\n FAlphaBlendedTab := nil; { ... but use it for the form and not for the tab }\r\nend;\r\n\r\ndestructor TJvDockDragDockObject.Destroy;\r\nbegin\r\n if FBrush <> nil then\r\n begin\r\n FBrush.Free;\r\n FBrush := nil;\r\n end;\r\n FAlphaBlendedForm.Free;\r\n FAlphaBlendedTab.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJvDockDragDockObject.GetAlphaBlendedTab: TJvAlphaBlendedForm;\r\nbegin\r\n if FAlphaBlendedTab = nil then\r\n begin\r\n FAlphaBlendedTab := TJvAlphaBlendedForm.CreateNew(nil);\r\n FAlphaBlendedTab.Visible := False;\r\n FAlphaBlendedTab.Color := clHighlight;\r\n FAlphaBlendedTab.AlphaBlend := True;\r\n FAlphaBlendedTab.AlphaBlendValue := 140;\r\n FAlphaBlendedTab.BorderIcons := [];\r\n FAlphaBlendedTab.BorderStyle := bsNone;\r\n FAlphaBlendedTab.FormStyle := fsStayOnTop;\r\n FAlphaBlendedTab.BoundsRect := Rect(0, 0, 0, 0);\r\n end;\r\n Result := FAlphaBlendedTab;\r\nend;\r\n\r\nprocedure TJvDockDragDockObject.AdjustDockRect(const ARect: TRect);\r\nvar\r\n DeltaX, DeltaY: Integer;\r\n R: TRect;\r\n\r\n function AbsMin(Value1, Value2: Integer): Integer;\r\n begin\r\n if Abs(Value1) < Abs(Value2) then\r\n Result := Value1\r\n else\r\n Result := Value2;\r\n end;\r\n\r\nbegin\r\n if (ARect.Left > FDragPos.X) or (ARect.Right < FDragPos.X) then\r\n DeltaX := AbsMin(ARect.Left - FDragPos.X, ARect.Right - FDragPos.X)\r\n else\r\n DeltaX := 0;\r\n if (ARect.Top > FDragPos.Y) or (ARect.Bottom < FDragPos.Y) then\r\n DeltaY := AbsMin(ARect.Top - FDragPos.Y, ARect.Bottom - FDragPos.Y)\r\n else\r\n DeltaY := 0;\r\n if (DeltaX <> 0) or (DeltaY <> 0) then\r\n begin\r\n R := DockRect;\r\n OffsetRect(R, -DeltaX, -DeltaY);\r\n DockRect := R;\r\n end;\r\nend;\r\n\r\nfunction TJvDockDragDockObject.CanLeave(NewTarget: TWinControl): Boolean;\r\nbegin\r\n Result := (NewTarget <> TWinControl(FDragTarget));\r\nend;\r\n\r\nfunction TJvDockDragDockObject.Capture: THandle;\r\nbegin\r\n Result := AllocateHWnd(MouseMsg);\r\n SetCapture(Result);\r\nend;\r\n\r\nprocedure TJvDockDragDockObject.DefaultDockImage(Erase: Boolean);\r\nVar\r\n DrawRect: TRect;\r\n PenSize: Integer;\r\n ABrush: TBrush;\r\nbegin\r\n GetBrush_PenSize_DrawRect(ABrush, PenSize, DrawRect, Erase);\r\n AlphaBlendedForm.Visible := True;\r\n AlphaBlendedForm.BoundsRect := DrawRect;\r\nend;\r\n\r\nfunction TJvDockDragDockObject.DragFindWindow(const Pos: TPoint): THandle;\r\nvar\r\n WinControl: TWinControl;\r\nbegin\r\n WinControl := FindVCLWindow(Pos);\r\n if WinControl <> nil then\r\n Result := WinControl.Handle\r\n else\r\n Result := 0;\r\nend;\r\n\r\nprocedure TJvDockDragDockObject.DrawDragDockImage;\r\nbegin\r\n DefaultDockImage(False);\r\nend;\r\n\r\nprocedure TJvDockDragDockObject.DrawDragRect(DoErase: Boolean);\r\nbegin\r\n if not CompareMem(@DockRect, @EraseDockRect, SizeOf(TRect)) then\r\n begin\r\n if DoErase then\r\n EraseDragDockImage;\r\n DrawDragDockImage;\r\n FEraseDockRect := DockRect;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockDragDockObject.EndDrag(Target: TObject; X, Y: Integer);\r\nbegin\r\n JvGlobalDockManager.DoEndDrag(Target, X, Y);\r\nend;\r\n\r\nprocedure TJvDockDragDockObject.EraseDragDockImage;\r\nbegin\r\n DefaultDockImage(True);\r\nend;\r\n\r\nprocedure TJvDockDragDockObject.Finished(Target: TObject; X, Y: Integer;\r\n Accepted: Boolean);\r\nbegin\r\n if not Accepted then\r\n Target := nil;\r\n EndDrag(Target, X, Y);\r\nend;\r\n\r\nprocedure TJvDockDragDockObject.GetBrush_PenSize_DrawRect(var ABrush: TBrush;\r\n var PenSize: Integer; var DrawRect: TRect; Erase: Boolean);\r\nbegin\r\n ABrush := Brush;\r\n PenSize := FrameWidth;\r\n if Erase then\r\n DrawRect := EraseDockRect\r\n else\r\n DrawRect := DockRect;\r\nend;\r\n\r\nfunction TJvDockDragDockObject.GetDragCursor(Accepted: Boolean;\r\n X, Y: Integer): TCursor;\r\nbegin\r\n Result := crDefault;\r\nend;\r\n\r\nfunction TJvDockDragDockObject.GetDragImages: TDragImageList;\r\nbegin\r\n Result := nil;\r\nend;\r\n\r\nfunction TJvDockDragDockObject.GetDropCtl: TControl;\r\nvar\r\n NextCtl: TControl;\r\n TargetCtl: TWinControl;\r\n CtlIdx: Integer;\r\n\r\n function GetDockClientsIndex: Integer;\r\n begin\r\n for Result := 0 to TWinControlAccessProtected(TargetCtl).DockClientCount - 1 do\r\n if TWinControlAccessProtected(TargetCtl).DockClients[Result] = NextCtl then\r\n Exit;\r\n Result := -1;\r\n end;\r\n\r\nbegin\r\n Result := nil;\r\n TargetCtl := DragTarget;\r\n if (TargetCtl = nil) or not TWinControlAccessProtected(TargetCtl).UseDockManager or\r\n (TargetCtl.DockClientCount = 0) or\r\n ((TargetCtl.DockClientCount = 1) and\r\n (TWinControlAccessProtected(TargetCtl).DockClients[0] = Control)) then\r\n Exit;\r\n NextCtl := FindDragTarget(DragPos, False);\r\n while (NextCtl <> nil) and (NextCtl <> TargetCtl) do\r\n begin\r\n CtlIdx := GetDockClientsIndex;\r\n if CtlIdx <> -1 then\r\n begin\r\n Result := TargetCtl.DockClients[CtlIdx];\r\n Exit;\r\n end\r\n else\r\n NextCtl := NextCtl.Parent;\r\n end;\r\nend;\r\n\r\nfunction TJvDockDragDockObject.GetFrameWidth: Integer;\r\nbegin\r\n Result := FFrameWidth;\r\nend;\r\n\r\nfunction TJvDockDragDockObject.GetTargetControl: TWinControl;\r\nbegin\r\n if FDragTarget <> nil then\r\n Result := TWinControl(FDragTarget)\r\n else\r\n Result := nil;\r\nend;\r\n\r\nprocedure TJvDockDragDockObject.MouseMsg(var Msg: TMessage);\r\nvar\r\n P: TPoint;\r\n\r\n procedure DoDragDone(DropFlag: Boolean); {NEW! Warren added.}\r\n var\r\n DS: TJvDockServer;\r\n DC: TJvDockClient;\r\n DP: TJvDockPanel;\r\n DF: TForm;\r\n begin\r\n if not Assigned(JvGlobalDockManager) then\r\n Exit;\r\n\r\n if DropFlag and Assigned(FControl) then\r\n begin\r\n // only do this if DropFlag is true and there is a control (usually a form) we are dragging\r\n if not Assigned(TargetControl) then\r\n begin\r\n {$IFDEF JVDOCK_DEBUG}\r\n OutputDebugString('TJvDockDragDockObject.MouseMsg.DoDragDone: User drag finished, TargetControl=nil, user made form floating.');\r\n {$ENDIF JVDOCK_DEBUG}\r\n\r\n {In this case, we're dragging something off and making it floating. }\r\n {if Assigned(FControl) then\r\n DC := FindDockClient(FControl)\r\n else\r\n DC := nil;\r\n\r\n DP := nil;\r\n DS := nil;\r\n DF := nil;\r\n if Assigned(DC) then begin\r\n if Assigned(DC.OnCheckIsDockable) then begin\r\n DC.OnCheckIsDockable( DC, DF, DS, DP, DropFlag );\r\n end;\r\n end;}\r\n end\r\n else\r\n if TargetControl is TJvDockPanel then\r\n begin\r\n { In this case, we're about to dock to a TJvDockPanel }\r\n {DP := TargetControl as TJvDockPanel;\r\n DS := DP.DockServer;\r\n DC := FindDockClient(FControl);\r\n if FControl is TForm then\r\n DF := FControl as TForm\r\n else\r\n DF := nil;\r\n if Assigned(DC.OnCheckIsDockable) then begin\r\n DC.OnCheckIsDockable( DC, DF, DS, DP, DropFlag );\r\n end;}\r\n end\r\n else\r\n if TargetControl is TForm then\r\n begin\r\n { This appears to have something to do with conjoined and tabbed host forms }\r\n DC := FindDockClient(TargetControl);\r\n DP := nil;\r\n DS := nil;\r\n if FControl is TForm then\r\n DF := FControl as TForm\r\n else\r\n DF := nil;\r\n if Assigned(DC.OnCheckIsDockable) then\r\n DC.OnCheckIsDockable(DC, DF, DS, DP, DropFlag);\r\n end\r\n else\r\n begin\r\n {$IFDEF JVDOCK_DEBUG}\r\n // Debug message!\r\n OutputDebugString('TJvDockDragDockObject.MouseMsg.DoDragDone: TargetControl is not an expected type!');\r\n {$ENDIF JVDOCK_DEBUG}\r\n end;\r\n end;\r\n Assert(Assigned(JvGlobalDockManager));\r\n Assert(Assigned(JvGlobalDockClient));\r\n JvGlobalDockManager.DragDone(DropFlag);\r\n {$IFDEF JVDOCK_DEBUG}\r\n OutputDebugString('DoDragDone completed.');\r\n {$ENDIF JVDOCK_DEBUG}\r\n end;\r\n\r\nbegin\r\n try\r\n case Msg.Msg of\r\n WM_MOUSEMOVE:\r\n begin\r\n P := SmallPointToPoint(TWMMouse(Msg).Pos);\r\n ClientToScreen(JvGlobalDockManager.FDragCapture, P);\r\n JvGlobalDockManager.DragTo(P);\r\n end;\r\n WM_CAPTURECHANGED:\r\n DoDragDone(False); //JvGlobalDockManager.DragDone(False);\r\n WM_LBUTTONUP, WM_RBUTTONUP:\r\n if not JvGlobalDockClient.CanFloat then\r\n begin\r\n if (TargetControl = nil) and (JvGlobalDockClient.ParentForm.HostDockSite = nil) then\r\n DoDragDone(True) //JvGlobalDockManager.DragDone(True)\r\n else\r\n DoDragDone(TargetControl <> nil); //JvGlobalDockManager.DragDone(TargetControl <> nil);\r\n end\r\n else\r\n DoDragDone(True); //JvGlobalDockManager.DragDone(True);\r\n CN_KEYUP:\r\n if Msg.WParam = VK_CONTROL then\r\n begin\r\n FCtrlDown := False;\r\n JvGlobalDockManager.DragTo(JvGlobalDockManager.DragObject.DragPos);\r\n end;\r\n CN_KEYDOWN:\r\n case Msg.WParam of\r\n VK_CONTROL:\r\n begin\r\n FCtrlDown := True;\r\n JvGlobalDockManager.DragTo(JvGlobalDockManager.DragObject.DragPos);\r\n end;\r\n VK_ESCAPE:\r\n begin\r\n Msg.Result := 1;\r\n DoDragDone(False); //JvGlobalDockManager.DragDone(False);\r\n end;\r\n end;\r\n end;\r\n except\r\n if JvGlobalDockManager.FDragControl <> nil then\r\n DoDragDone(False); //JvGlobalDockManager.DragDone(False);\r\n raise;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockDragDockObject.ReleaseCapture(Handle: THandle);\r\nbegin\r\n Windows.ReleaseCapture;\r\n DeallocateHWnd(Handle);\r\nend;\r\n\r\nprocedure TJvDockDragDockObject.SetBrush(const Value: TBrush);\r\nbegin\r\n FBrush.Assign(Value);\r\nend;\r\n\r\nprocedure TJvDockDragDockObject.SetDropAlign(const Value: TAlign);\r\nbegin\r\n if FDropAlign <> Value then\r\n FDropAlign := Value;\r\nend;\r\n\r\nprocedure TJvDockDragDockObject.SetDropOnControl(const Value: TControl);\r\nbegin\r\n FDropOnControl := Value;\r\nend;\r\n\r\nprocedure TJvDockDragDockObject.SetFrameWidth(const Value: Integer);\r\nbegin\r\n FFrameWidth := Value;\r\nend;\r\n\r\nprocedure TJvDockDragDockObject.SetTargetControl(const Value: TWinControl);\r\nbegin\r\n FDragTarget := Value;\r\nend;\r\n\r\n//=== { TJvDockManager } =====================================================\r\n\r\nconstructor TJvDockManager.Create;\r\nbegin\r\n inherited Create;\r\n FDockSiteList := TList.Create;\r\nend;\r\n\r\ndestructor TJvDockManager.Destroy;\r\nbegin\r\n FDockSiteList.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvDockManager.BeginDrag(Control: TControl; Immediate: Boolean; Threshold: Integer);\r\nvar\r\n P: TPoint;\r\nbegin\r\n if TControlAccessProtected(Control).DragKind <> dkDock then\r\n Exit;\r\n\r\n CalcDockSizes(Control);\r\n if (FDragControl = nil) or (FDragControl = Pointer($FFFFFFFF)) then\r\n begin\r\n FDragControl := nil;\r\n if csLButtonDown in Control.ControlState then\r\n begin\r\n GetCursorPos(P);\r\n P := Control.ScreenToClient(P);\r\n Control.Perform(WM_LBUTTONUP, 0, {$IFDEF RTL230_UP}PointToLParam{$ELSE}LPARAM{$ENDIF RTL230_UP}(PointToSmallPoint(P)));\r\n end;\r\n\r\n if Threshold < 0 then\r\n Threshold := Mouse.DragThreshold;\r\n\r\n if FDragControl <> Pointer($FFFFFFFF) then\r\n DragInitControl(Control, Immediate, Threshold);\r\n end;\r\nend;\r\n\r\nprocedure TJvDockManager.BeginLoad;\r\nbegin\r\n Inc(FLoadCount);\r\n if FLoadCount = 1 then\r\n begin\r\n end;\r\nend;\r\n\r\nprocedure TJvDockManager.BeginSave;\r\nbegin\r\n Inc(FSaveCount);\r\nend;\r\n\r\nprocedure TJvDockManager.CalcDockSizes(Control: TControl);\r\nvar\r\n Rect: TRect;\r\nbegin\r\n with Control do\r\n if Floating then\r\n begin\r\n UndockHeight := Height;\r\n UndockWidth := Width;\r\n end\r\n else\r\n if HostDockSite is TJvDockCustomPanel then\r\n begin\r\n Rect := TJvDockCustomPanel(HostDockSite).JvDockManager.GetFrameRect(Control);\r\n if HostDockSite.Align in [alTop, alBottom] then\r\n TBDockHeight := Rect.Bottom - Rect.Top\r\n else\r\n if HostDockSite.Align in [alLeft, alRight] then\r\n LRDockWidth := Rect.Right - Rect.Left;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockManager.CancelDrag;\r\nbegin\r\n if DragObject <> nil then\r\n DragDone(False);\r\n FDragControl := nil;\r\nend;\r\n\r\nprocedure TJvDockManager.DoDockDrop(Source: TJvDockDragDockObject; Pos: TPoint);\r\nvar\r\n Target: TWinControl;\r\n ADockClient: TJvDockClient;\r\n Pt: TPoint;\r\nbegin\r\n if Source.DragTarget <> nil then\r\n begin\r\n Target := Source.TargetControl;\r\n Pt := Target.ScreenToClient(Pos);\r\n if Target is TJvDockCustomControl then\r\n TJvDockCustomControl(Target).CustomDockDrop(Source, Pt.X, Pt.Y)\r\n else\r\n if Target is TForm then\r\n begin\r\n ADockClient := FindDockClient(Target);\r\n if ADockClient <> nil then\r\n ADockClient.FormDockDrop(Source, Pt.X, Pt.Y);\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJvDockManager.DoDockOver(DragState: TDragState): Boolean;\r\nvar\r\n Target: TControl;\r\n ADockClient: TJvDockClient;\r\n Pt: TPoint;\r\nbegin\r\n Result := True;\r\n if DragObject.DragTarget <> nil then\r\n begin\r\n Target := TControl(DragObject.DragTarget);\r\n Pt := Target.ScreenToClient(DragObject.DragPos);\r\n if Target is TJvDockCustomControl then\r\n TJvDockCustomControl(Target).CustomDockOver(DragObject, Pt.X, Pt.Y, DragState, Result)\r\n else\r\n if Target is TForm then\r\n begin\r\n ADockClient := FindDockClient(Target);\r\n if ADockClient <> nil then\r\n ADockClient.FormDockOver(DragObject, Pt.X, Pt.Y, DragState, Result);\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockManager.DoEndDrag(Target: TObject; X, Y: Integer);\r\nvar\r\n ADockClient: TJvDockClient;\r\nbegin\r\n if Target is TJvDockCustomControl then\r\n TJvDockCustomControl(Target).CustomEndDock(Target, X, Y)\r\n else\r\n if Target is TForm then\r\n begin\r\n ADockClient := FindDockClient(TControl(Target));\r\n if ADockClient <> nil then\r\n ADockClient.FormEndDock(Target, X, Y);\r\n end;\r\nend;\r\n\r\nprocedure TJvDockManager.DoGetDockEdge(Target: TControl; MousePos: TPoint; var DropAlign: TAlign);\r\nvar\r\n ADockClient: TJvDockClient;\r\nbegin\r\n if Target is TJvDockCustomControl then\r\n TJvDockCustomControl(Target).CustomGetDockEdge(DragObject, MousePos, DropAlign)\r\n else\r\n if Target is TForm then\r\n begin\r\n ADockClient := FindDockClient(Target);\r\n if ADockClient <> nil then\r\n ADockClient.FormGetDockEdge(DragObject, MousePos, DropAlign);\r\n end;\r\nend;\r\n\r\nprocedure TJvDockManager.DoGetSiteInfo(Target, Client: TControl;\r\n var InfluenceRect: TRect; MousePos: TPoint; var CanDock: Boolean);\r\nvar\r\n ADockClient: TJvDockClient;\r\nbegin\r\n if Target is TJvDockCustomControl then\r\n TJvDockCustomControl(Target).CustomGetSiteInfo(DragObject, Client, InfluenceRect, MousePos, CanDock)\r\n else\r\n if Target is TForm then\r\n begin\r\n ADockClient := FindDockClient(Target);\r\n if ADockClient <> nil then\r\n ADockClient.FormGetSiteInfo(DragObject, Client, InfluenceRect, MousePos, CanDock);\r\n end\r\n else\r\n CanDock := False;\r\nend;\r\n\r\nfunction TJvDockManager.DoUnDock(Source: TJvDockDragDockObject; Target: TWinControl; Client: TControl): Boolean;\r\nvar\r\n allow:Boolean;\r\nbegin\r\n if not (csDestroying in Client.ComponentState) then\r\n if Client is TForm then begin\r\n if Client is TForm then begin\r\n allow := true;\r\n if Assigned(TForm(Client).OnUnDock) then\r\n TForm(Client).OnUnDock(Self,Client,TWinControl(nil),allow);\r\n if not allow then begin\r\n result := false;\r\n exit;\r\n end;\r\n\r\n end;\r\n\r\n end;\r\n\r\n\r\n\r\n if Client.HostDockSite is TJvDockCustomControl then\r\n Result := TJvDockCustomControl(Client.HostDockSite).CustomUnDock(Source, Target, Client)\r\n else\r\n Result := False;\r\nend;\r\n\r\nprocedure TJvDockManager.DragDone(Drop: Boolean);\r\nvar\r\n DragSave: TJvDockDragDockObject;\r\n DockObject: TJvDockDragDockObject;\r\n Accepted: Boolean;\r\n TargetPos: TPoint;\r\n ParentForm: TCustomForm;\r\n\r\n function CheckUndock: Boolean;\r\n begin\r\n Result := DragObject.DragTarget <> nil;\r\n with FDragControl do\r\n if Drop and (FActiveDrag = dopDock) then\r\n if Floating or (HostDockSite = nil) then\r\n Result := True\r\n else\r\n Result := DoUnDock(DragObject, DragObject.DragTarget, FDragControl);\r\n end;\r\n\r\n procedure DoFloatForm(Control: TControl);\r\n var\r\n WasVisible: Boolean;\r\n begin\r\n if Control.FloatingDockSiteClass = Control.ClassType then\r\n begin\r\n WasVisible := Control.Visible;\r\n try\r\n if Assigned(DragObject.AlphaBlendedForm) then\r\n DragObject.AlphaBlendedForm.Hide;\r\n Control.Dock(nil, DragObject.DockRect);\r\n if (Control.Left <> DragObject.DockRect.Left) or (Control.Top <> DragObject.DockRect.Top) then\r\n begin\r\n Control.Left := DragObject.DockRect.Left;\r\n Control.Top := DragObject.DockRect.Top;\r\n end;\r\n finally\r\n if WasVisible then\r\n Control.BringToFront;\r\n end;\r\n end;\r\n end;\r\n\r\nbegin\r\n DockObject := nil;\r\n DragSave := nil;\r\n Accepted := False;\r\n if (DragObject = nil) or DragObject.Cancelling then\r\n Exit;\r\n try\r\n DragSave := DragObject;\r\n try\r\n DragObject.Cancelling := True;\r\n DragObject.ReleaseCapture(FDragCapture);\r\n if FActiveDrag = dopDock then\r\n begin\r\n DockObject := DragObject;\r\n DockObject.EraseDragDockImage;\r\n DockObject.Floating := DockObject.DragTarget = nil;\r\n end;\r\n if (DragObject.DragTarget <> nil) and\r\n (TObject(DragObject.DragTarget) is TControl) then\r\n TargetPos := DragObject.DragTargetPos\r\n else\r\n TargetPos := DragObject.DragPos;\r\n\r\n {Check before we undock, then check if the drop is going to be accepted }\r\n\r\n Accepted := {local function:} CheckUndock and {DragDone parameter:} Drop;\r\n\r\n if FActiveDrag = dopDock then\r\n begin\r\n if Accepted and DockObject.Floating then\r\n begin\r\n ParentForm := GetParentForm(DockObject.Control);\r\n if (ParentForm <> nil) and\r\n (ParentForm.ActiveControl = DockObject.Control) then\r\n ParentForm.ActiveControl := nil;\r\n DoFloatForm(FDragControl);\r\n end;\r\n end\r\n else\r\n begin\r\n if FDragImageList <> nil then\r\n FDragImageList.EndDrag\r\n else\r\n Windows.SetCursor(FDragSaveCursor);\r\n end;\r\n FDragControl := nil;\r\n if DragSave.DragTarget <> nil then\r\n begin\r\n if not Accepted then\r\n begin\r\n DragSave.DragPos := Point(0, 0);\r\n TargetPos.X := 0;\r\n TargetPos.Y := 0;\r\n end\r\n else\r\n DoDockDrop(DragSave, DragSave.DragPos);\r\n end;\r\n DragObject := nil;\r\n finally\r\n FQualifyingSites.Free;\r\n FQualifyingSites := nil;\r\n DragSave.Cancelling := False;\r\n DragSave.Finished(DragSave.DragTarget, TargetPos.X, TargetPos.Y, Accepted);\r\n DragObject := nil;\r\n end;\r\n finally\r\n FDragControl := nil;\r\n DragSave.Free;\r\n end;\r\nend;\r\n\r\nfunction TJvDockManager.DragFindTarget(const Pos: TPoint; var Handle: THandle;\r\n DragKind: TDragKind; Client: TControl): Pointer;\r\nbegin\r\n Result := GetDockSiteAtPos(Pos, Client);\r\n if Result <> nil then\r\n Handle := TWinControl(Result).Handle;\r\nend;\r\n\r\nfunction TJvDockManager.DragFindWindow(const Pos: TPoint): THandle;\r\nbegin\r\n Result := DragObject.DragFindWindow(Pos);\r\nend;\r\n\r\nprocedure TJvDockManager.DragInit(ADragObject: TJvDockDragDockObject;\r\n Immediate: Boolean; Threshold: Integer);\r\nvar\r\n R: TRect;\r\nbegin\r\n DragObject := ADragObject;\r\n DragObject.DragTarget := nil;\r\n GetCursorPos(FDragStartPos);\r\n DragObject.DragPos := FDragStartPos;\r\n FDragSaveCursor := Windows.GetCursor;\r\n FDragCapture := DragObject.Capture;\r\n FDragThreshold := Threshold;\r\n with ADragObject do\r\n begin\r\n R := DockRect;\r\n if R.Right - R.Left > 0 then\r\n MouseDeltaX := (DragPos.X - R.Left) / (R.Right - R.Left)\r\n else\r\n MouseDeltaX := 0;\r\n if R.Bottom - R.Top > 0 then\r\n MouseDeltaY := (DragPos.Y - R.Top) / (R.Bottom - R.Top)\r\n else\r\n MouseDeltaY := 0;\r\n if Immediate then\r\n begin\r\n FActiveDrag := dopDock;\r\n DrawDragDockImage;\r\n end\r\n else\r\n FActiveDrag := dopNone;\r\n end;\r\n FDragImageList := DragObject.GetDragImages;\r\n if FDragImageList <> nil then\r\n FDragImageList.BeginDrag(GetDesktopWindow, FDragStartPos.X, FDragStartPos.Y);\r\n FQualifyingSites := TSiteList.Create;\r\n if FActiveDrag <> dopNone then\r\n DragTo(FDragStartPos);\r\nend;\r\n\r\nprocedure TJvDockManager.DragInitControl(Control: TControl;\r\n Immediate: Boolean; Threshold: Integer);\r\nvar\r\n ARect: TRect;\r\n DragObj: TJvDockDragDockObject;\r\n\r\n procedure DoStartDock;\r\n begin\r\n if Assigned(JvGlobalDockClient) then\r\n begin\r\n DragObj := DragObject;\r\n JvGlobalDockClient.FormStartDock(DragObj);\r\n DragObject := DragObj;\r\n end;\r\n if DragObject = nil then\r\n begin\r\n DragObject := TJvDockDragDockObject.Create(Control);\r\n FDragFreeObject := True;\r\n end;\r\n end;\r\n\r\nbegin\r\n FDragControl := Control;\r\n try\r\n DragObject := nil;\r\n FDragFreeObject := False;\r\n\r\n DoStartDock;\r\n if FDragControl = nil then\r\n Exit;\r\n with DragObject do\r\n begin\r\n if Control.HostDockSite is TJvDockCustomPanel then\r\n ARect := TJvDockCustomPanel(Control.HostDockSite).JvDockManager.GetFrameRectEx(Control)\r\n else\r\n GetWindowRect(TWinControl(Control).Handle, ARect);\r\n DockRect := ARect;\r\n FEraseDockRect := DockRect;\r\n end;\r\n DragInit(DragObject, Immediate, Threshold);\r\n except\r\n FDragControl := nil;\r\n raise;\r\n end;\r\nend;\r\n\r\n{ TJvDockManager.DragTo: WM_MOUSEMOVE Mouse Drag handler.\r\n\r\n The global Dock manager which is of this type, TJvDockManager, handles\r\n the WM_MOUSEMOVE messages sent to TJvDockDragDockObject.MouseMsg.\r\n\r\n In this function we decide what destination (drop object)\r\n we are in by calling DragFindTarget.\r\n\r\n There is a lot of boilerplate code here that isn't used, such\r\n as the ability to draw a drag image (not useful when dragging forms).\r\n\r\n}\r\nprocedure TJvDockManager.DragTo(const Pos: TPoint);\r\nvar\r\n DragCursor: TCursor;\r\n Target: TControl;\r\n TargetHandle: THandle;\r\n DoErase: Boolean;\r\n TempAlign: TAlign;\r\nbegin\r\n if (Abs(FDragStartPos.X - Pos.X) >= FDragThreshold) or\r\n (Abs(FDragStartPos.Y - Pos.Y) >= FDragThreshold) then\r\n begin\r\n Target := DragFindTarget(Pos, TargetHandle, TControlAccessProtected(FDragControl).DragKind, FDragControl);\r\n if (FActiveDrag = dopNone) and (FDragImageList <> nil) then\r\n FDragImageList.BeginDrag(GetDesktopWindow, FDragStartPos.X, FDragStartPos.Y);\r\n DoErase := FActiveDrag <> dopNone;\r\n FActiveDrag := dopDock;\r\n\r\n if DragObject.CanLeave(TWinControl(Target)) then\r\n begin\r\n DoDockOver(dsDragLeave);\r\n if DragObject = nil then\r\n Exit;\r\n DragObject.DragTarget := Target;\r\n DragObject.DragHandle := TargetHandle;\r\n DragObject.DragPos := Pos;\r\n DoDockOver(dsDragEnter);\r\n if DragObject = nil then\r\n Exit;\r\n end;\r\n DragObject.DragPos := Pos;\r\n if DragObject.DragTarget <> nil then\r\n DragObject.DragTargetPos := TControl(DragObject.DragTarget).ScreenToClient(Pos);\r\n DragCursor := DragObject.GetDragCursor(DoDockOver(dsDragMove), Pos.X, Pos.Y);\r\n if FDragImageList <> nil then\r\n begin\r\n if (Target = nil) or (csDisplayDragImage in Target.ControlStyle) then\r\n begin\r\n FDragImageList.DragCursor := DragCursor;\r\n if not FDragImageList.Dragging then\r\n FDragImageList.BeginDrag(GetDesktopWindow, Pos.X, Pos.Y)\r\n else\r\n FDragImageList.DragMove(Pos.X, Pos.Y);\r\n end\r\n else\r\n begin\r\n FDragImageList.EndDrag;\r\n Windows.SetCursor(Screen.Cursors[DragCursor]);\r\n end;\r\n end;\r\n\r\n ResetCursor;\r\n if FActiveDrag = dopDock then\r\n begin\r\n with DragObject do\r\n begin\r\n if Target = nil then\r\n begin\r\n if Assigned(JvGlobalDockClient) then\r\n JvGlobalDockClient.FormPositionDockRect(DragObject);\r\n end\r\n else\r\n begin\r\n DropOnControl := GetDropCtl;\r\n TempAlign := DropAlign;\r\n if DropOnControl = nil then\r\n DoGetDockEdge(TargetControl, DragTargetPos, TempAlign)\r\n else\r\n DoGetDockEdge(DropOnControl, DropOnControl.ScreenToClient(Pos), TempAlign);\r\n DropAlign := TempAlign;\r\n end;\r\n end;\r\n if DragObject <> nil then\r\n DragObject.DrawDragRect(DoErase);\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockManager.EndLoad;\r\nbegin\r\n Dec(FLoadCount);\r\n if FLoadCount <= 0 then\r\n begin\r\n FLoadCount := 0;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockManager.EndSave;\r\nbegin\r\n Dec(FSaveCount);\r\n if FSaveCount <= 0 then\r\n FSaveCount := 0;\r\nend;\r\n\r\nfunction TJvDockManager.GetDockSiteAtPos(MousePos: TPoint;\r\n Client: TControl): TWinControl;\r\nvar\r\n I: Integer;\r\n R: TRect;\r\n Site: TWinControl;\r\n CanDock, ControlKeyDown: Boolean;\r\n\r\n function ValidDockTarget(Target: TWinControl): Boolean;\r\n var\r\n Info: TCheckTargetInfo;\r\n Control: TWinControl;\r\n R1, R2: TRect;\r\n begin\r\n Result := True;\r\n\r\n Info.CurrentWnd := DragFindWindow(MousePos);\r\n if Info.CurrentWnd = 0 then\r\n Exit;\r\n if GetWindow(Info.CurrentWnd, GW_OWNER) <> Application.Handle then\r\n begin\r\n Control := FindControl(Info.CurrentWnd);\r\n if Control = nil then\r\n Exit;\r\n while Control.Parent <> nil do\r\n Control := Control.Parent;\r\n Info.CurrentWnd := Control.Handle;\r\n end;\r\n\r\n Control := Target;\r\n while Control.Parent <> nil do\r\n Control := Control.Parent;\r\n Info.TargetWnd := Control.Handle;\r\n if Info.CurrentWnd = Info.TargetWnd then\r\n Exit;\r\n\r\n if Client.Parent <> nil then\r\n begin\r\n Control := Client.Parent;\r\n while Control.Parent <> nil do\r\n Control := Control.Parent;\r\n Info.ClientWnd := Control.Handle;\r\n end\r\n else\r\n if Client is TWinControl then\r\n Info.ClientWnd := TWinControl(Client).Handle\r\n else\r\n Info.ClientWnd := 0;\r\n\r\n Info.Found := False;\r\n Info.MousePos := MousePos;\r\n EnumThreadWindows(GetCurrentThreadID, @IsBeforeTargetWindow, LPARAM(@Info));\r\n\r\n if Info.Found then\r\n begin\r\n GetWindowRect(Info.CurrentWnd, R1);\r\n DoGetSiteInfo(Target, Client, R2, MousePos, CanDock);\r\n\r\n if (DragObject.Control.HostDockSite <> nil) and\r\n (DragObject.Control.HostDockSite.Handle = Info.CurrentWnd) then\r\n Exit;\r\n if IntersectRect(R1, R1, R2) then\r\n Result := False;\r\n end;\r\n end;\r\n\r\n function IsSiteChildOfClient: Boolean;\r\n begin\r\n if Client is TWinControl then\r\n Result := IsChild(TWinControl(Client).Handle, Site.Handle)\r\n else\r\n Result := False;\r\n end;\r\n\r\nbegin\r\n Result := nil;\r\n ControlKeyDown := (GetKeyState(VK_CONTROL) and not $7FFF) <> 0;\r\n if (FDockSiteList = nil) or ControlKeyDown then\r\n Exit;\r\n FQualifyingSites.Clear;\r\n for I := 0 to FDockSiteList.Count - 1 do\r\n begin\r\n Site := TWinControl(FDockSiteList[I]);\r\n if (Site <> Client) and Site.Showing and Site.Enabled and\r\n IsWindowVisible(Site.Handle) and (not IsSiteChildOfClient) then\r\n begin\r\n CanDock := True;\r\n DoGetSiteInfo(Site, Client, R, MousePos, CanDock);\r\n if CanDock and PtInRect(R, MousePos) then\r\n FQualifyingSites.AddSite(Site);\r\n end;\r\n end;\r\n if FQualifyingSites.Count > 0 then\r\n Result := FQualifyingSites.GetTopSite;\r\n if (Result <> nil) and not ValidDockTarget(Result) then\r\n Result := nil;\r\nend;\r\n\r\nfunction TJvDockManager.GetFormVisible(DockWindow: TWinControl): Boolean;\r\nbegin\r\n Result := JvDockControlForm.GetFormVisible(DockWindow);\r\nend;\r\n\r\nprocedure TJvDockManager.HideDockForm(DockWindow: TWinControl);\r\nbegin\r\n JvDockControlForm.HideDockForm(DockWindow);\r\nend;\r\n\r\nfunction TJvDockManager.IsDockLoading: Boolean;\r\nbegin\r\n Result := FLoadCount > 0;\r\nend;\r\n\r\nfunction TJvDockManager.IsSaving: Boolean;\r\nbegin\r\n Result := FSaveCount > 0;\r\nend;\r\n\r\nprocedure TJvDockManager.LoadDockTreeFromAppStorage(AppStorage: TJvCustomAppStorage;\r\n const AppStoragePath: string = '');\r\nbegin\r\n BeginLoad;\r\n try\r\n JvDockControlForm.LoadDockTreeFromAppStorage(AppStorage, AppStoragePath);\r\n finally\r\n EndLoad;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockManager.RegisterDockSite(Site: TWinControl; DoRegister: Boolean);\r\nvar\r\n Index: Integer;\r\nbegin\r\n if Site <> nil then\r\n begin\r\n if FDockSiteList = nil then\r\n FDockSiteList := TList.Create;\r\n Index := FDockSiteList.IndexOf(Pointer(Site));\r\n if DoRegister then\r\n begin\r\n if Index = -1 then\r\n FDockSiteList.Add(Pointer(Site));\r\n end\r\n else\r\n begin\r\n if Index <> -1 then\r\n FDockSiteList.Delete(Index);\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockManager.ResetCursor;\r\nbegin\r\n if (JvGlobalDockClient <> nil) and (JvGlobalDockClient.DockStyle <> nil) then\r\n JvGlobalDockClient.DockStyle.ResetCursor(DragObject);\r\nend;\r\n\r\nprocedure TJvDockManager.SaveDockTreeToAppStorage(AppStorage: TJvCustomAppStorage;\r\n const AppStoragePath: string = '');\r\nbegin\r\n BeginSave;\r\n try\r\n JvDockControlForm.SaveDockTreeToAppStorage(AppStorage, AppStoragePath);\r\n finally\r\n EndSave;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockManager.SetConjoinDockHostBorderStyle(Value: TFormBorderStyle);\r\nbegin\r\n JvDockControlForm.SetConjoinDockHostBorderStyle(Value);\r\nend;\r\n\r\nprocedure TJvDockManager.SetTabDockHostBorderStyle(Value: TFormBorderStyle);\r\nbegin\r\n JvDockControlForm.SetTabDockHostBorderStyle(Value);\r\nend;\r\n\r\nprocedure TJvDockManager.ShowDockForm(DockWindow: TWinControl);\r\nbegin\r\n JvDockControlForm.ShowDockForm(DockWindow);\r\nend;\r\n\r\n//=== { TJvDockPageControl } =================================================\r\n\r\nconstructor TJvDockPageControl.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n ControlStyle := [csDoubleClicks, csOpaque];\r\n FPages := TList.Create;\r\n FTabSheetClass := TJvDockTabSheet;\r\nend;\r\n\r\ndestructor TJvDockPageControl.Destroy;\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := 0 to FPages.Count - 1 do\r\n TJvDockTabSheet(FPages[I]).FPageControl := nil;\r\n FPages.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJvDockPageControl.CanShowTab(TabIndex: Integer): Boolean;\r\nbegin\r\n Result := TJvDockTabSheet(FPages[TabIndex]).Enabled;\r\nend;\r\n\r\nprocedure TJvDockPageControl.Change;\r\nvar\r\n Form: TCustomForm;\r\nbegin\r\n if TabIndex >= 0 then\r\n UpdateActivePage;\r\n if csDesigning in ComponentState then\r\n begin\r\n Form := GetParentForm(Self);\r\n if (Form <> nil) and (Form.Designer <> nil) then\r\n Form.Designer.Modified;\r\n end;\r\n inherited Change;\r\nend;\r\n\r\nprocedure TJvDockPageControl.ChangeActivePage(Page: TJvDockTabSheet);\r\nvar\r\n ParentForm: TCustomForm;\r\nbegin\r\n if FActivePage <> Page then\r\n begin\r\n ParentForm := GetParentForm(Self);\r\n if (ParentForm <> nil) and (FActivePage <> nil) and\r\n FActivePage.ContainsControl(ParentForm.ActiveControl) then\r\n begin\r\n ParentForm.ActiveControl := FActivePage;\r\n if ParentForm.ActiveControl <> FActivePage then\r\n begin\r\n TabIndex := FActivePage.TabIndex;\r\n Exit;\r\n end;\r\n end;\r\n if Page <> nil then\r\n begin\r\n Page.BringToFront;\r\n Page.Visible := True;\r\n if (ParentForm <> nil) and (FActivePage <> nil) and\r\n (ParentForm.ActiveControl = FActivePage) then\r\n if Page.CanFocus then\r\n ParentForm.ActiveControl := Page\r\n else\r\n ParentForm.ActiveControl := Self;\r\n end;\r\n if FActivePage <> nil then\r\n FActivePage.Visible := False;\r\n FActivePage := Page;\r\n if (ParentForm <> nil) and (FActivePage <> nil) and\r\n (ParentForm.ActiveControl = FActivePage) then\r\n FActivePage.SelectFirst;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockPageControl.CMDesignHitTest(var Msg: TCMDesignHitTest);\r\nvar\r\n HitIndex: Integer;\r\n HitTestInfo: TTCHitTestInfo;\r\nbegin\r\n HitTestInfo.pt := SmallPointToPoint(Msg.Pos);\r\n HitIndex := SendMessage(Handle, TCM_HITTEST, 0, LPARAM(@HitTestInfo));\r\n if (HitIndex >= 0) and (HitIndex <> TabIndex) then\r\n Msg.Result := 1;\r\nend;\r\n\r\nprocedure TJvDockPageControl.CMDialogKey(var Msg: TCMDialogKey);\r\nbegin\r\n if (Focused or Windows.IsChild(Handle, Windows.GetFocus)) and\r\n (Msg.CharCode = VK_TAB) and (GetKeyState(VK_CONTROL) < 0) then\r\n begin\r\n SelectNextPage(GetKeyState(VK_SHIFT) >= 0);\r\n Msg.Result := 1;\r\n end\r\n else\r\n inherited;\r\nend;\r\n\r\nprocedure TJvDockPageControl.CMDockClient(var Msg: TCMDockClient);\r\nvar\r\n IsVisible: Boolean;\r\n DockCtl: TControl;\r\nbegin\r\n Msg.Result := 0;\r\n if FTabSheetClass <> nil then\r\n FNewDockSheet := FTabSheetClass.Create(Self)\r\n else\r\n FNewDockSheet := TJvDockTabSheet.Create(Self);\r\n try\r\n try\r\n DockCtl := Msg.DockSource.Control;\r\n FNewDockSheet.PageControl := Self;\r\n if DockCtl is TCustomForm then\r\n FNewDockSheet.Caption := TCustomForm(DockCtl).Caption;\r\n DockCtl.Dock(Self, Msg.DockSource.DockRect);\r\n except\r\n FNewDockSheet.Free;\r\n raise;\r\n end;\r\n IsVisible := DockCtl.Visible;\r\n FNewDockSheet.TabVisible := IsVisible;\r\n if IsVisible then\r\n ActivePage := FNewDockSheet;\r\n DockCtl.Align := alClient;\r\n finally\r\n FNewDockSheet := nil;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockPageControl.CMDockNotification(var Msg: TCMDockNotification);\r\nvar\r\n I: Integer;\r\n S: string;\r\n Page: TJvDockTabSheet;\r\nbegin\r\n Page := GetPageFromDockClient(Msg.Client);\r\n if Page <> nil then\r\n case Msg.NotifyRec.ClientMsg of\r\n WM_SETTEXT:\r\n begin\r\n S := PChar(Msg.NotifyRec.MsgLParam);\r\n for I := 1 to Length(S) do\r\n if CharInSet(S[I], [#13, #10]) then\r\n begin\r\n SetLength(S, I - 1);\r\n Break;\r\n end;\r\n Page.Caption := S;\r\n end;\r\n CM_VISIBLECHANGED:\r\n Page.TabVisible := Boolean(Msg.NotifyRec.MsgWParam);\r\n end;\r\n inherited;\r\nend;\r\n\r\nprocedure TJvDockPageControl.CMUnDockClient(var Msg: TCMUnDockClient);\r\nvar\r\n Page: TJvDockTabSheet;\r\nbegin\r\n{$ifdef RTL210_UP}\r\n if (csDestroying in Self.ComponentState) then exit; // rather ugly workaround for Delphi 2010+ crash at shutdown.\r\n{$endif}\r\n\r\n Msg.Result := 0;\r\n Page := GetPageFromDockClient(Msg.Client);\r\n if Page <> nil then\r\n begin\r\n FUndockingPage := Page;\r\n Msg.Client.Align := alNone;\r\n end;\r\n if (VisibleDockClientCount = 1) or (DockClientCount <= 2) then\r\n PostMessage(Parent.Handle, WM_CLOSE, 0, 0);\r\nend;\r\n\r\nprocedure TJvDockPageControl.DeleteTab(Page: TJvDockTabSheet; Index: Integer);\r\nvar\r\n UpdateIndex: Boolean;\r\nbegin\r\n UpdateIndex := Page = ActivePage;\r\n Tabs.Delete(Index);\r\n if UpdateIndex then\r\n begin\r\n if Index >= Tabs.Count then\r\n Index := Tabs.Count - 1;\r\n TabIndex := Index;\r\n end;\r\n UpdateActivePage;\r\nend;\r\n\r\nprocedure TJvDockPageControl.DoAddDockClient(Client: TControl; const ARect: TRect);\r\nbegin\r\n if FNewDockSheet <> nil then\r\n Client.Parent := FNewDockSheet;\r\nend;\r\n\r\nprocedure TJvDockPageControl.DockOver(Source: TDragDockObject; X, Y: Integer;\r\n State: TDragState; var Accept: Boolean);\r\nvar\r\n R: TRect;\r\nbegin\r\n GetWindowRect(Handle, R);\r\n Source.DockRect := R;\r\n DoDockOver(Source, X, Y, State, Accept);\r\nend;\r\n\r\nfunction TJvDockPageControl.DoMouseEvent(var Msg: TWMMouse;\r\n Control: TControl): TWMNCHitMessage;\r\nbegin\r\n Result := JvDockCreateNCMessage(Control, Msg.Msg + WM_NCMOUSEFIRST - WM_MOUSEFIRST,\r\n HTCAPTION, SmallPointToPoint(Msg.Pos));\r\nend;\r\n\r\nprocedure TJvDockPageControl.DoRemoveDockClient(Client: TControl);\r\nbegin\r\n if (FUndockingPage <> nil) and not (csDestroying in ComponentState) then\r\n begin\r\n SelectNextPage(True);\r\n FUndockingPage.Free;\r\n FUndockingPage := nil;\r\n end;\r\nend;\r\n\r\nfunction TJvDockPageControl.FindNextPage(CurPage: TJvDockTabSheet;\r\n GoForward, CheckTabVisible: Boolean): TJvDockTabSheet;\r\nvar\r\n I, StartIndex: Integer;\r\nbegin\r\n if FPages.Count <> 0 then\r\n begin\r\n StartIndex := FPages.IndexOf(CurPage);\r\n if StartIndex = -1 then\r\n if GoForward then\r\n StartIndex := FPages.Count - 1\r\n else\r\n StartIndex := 0;\r\n I := StartIndex;\r\n repeat\r\n if GoForward then\r\n begin\r\n Inc(I);\r\n if I = FPages.Count then\r\n I := 0;\r\n end\r\n else\r\n begin\r\n if I = 0 then\r\n I := FPages.Count;\r\n Dec(I);\r\n end;\r\n Result := FPages[I];\r\n if not CheckTabVisible or Result.TabVisible then\r\n Exit;\r\n until I = StartIndex;\r\n end;\r\n Result := nil;\r\nend;\r\n\r\nfunction TJvDockPageControl.GetActivePageIndex: Integer;\r\nbegin\r\n if ActivePage <> nil then\r\n Result := ActivePage.GetPageIndex\r\n else\r\n Result := -1;\r\nend;\r\n\r\nprocedure TJvDockPageControl.GetChildren(Proc: TGetChildProc; Root: TComponent);\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := 0 to FPages.Count - 1 do\r\n Proc(TComponent(FPages[I]));\r\nend;\r\n\r\nfunction TJvDockPageControl.GetCount: Integer;\r\nbegin\r\n Result := FPages.Count;\r\nend;\r\n\r\nfunction TJvDockPageControl.GetDockClientFromMousePos(MousePos: TPoint): TControl;\r\nvar\r\n I, HitIndex: Integer;\r\n HitTestInfo: TTCHitTestInfo;\r\n Page: TJvDockTabSheet;\r\nbegin\r\n Result := nil;\r\n if DockSite then\r\n begin\r\n HitTestInfo.pt := MousePos;\r\n HitIndex := SendMessage(Handle, TCM_HITTEST, 0, LPARAM(@HitTestInfo));\r\n if HitIndex >= 0 then\r\n begin\r\n Page := nil;\r\n for I := 0 to HitIndex do\r\n Page := FindNextPage(Page, True, True);\r\n if (Page <> nil) and (Page.ControlCount > 0) then\r\n begin\r\n Result := Page.Controls[0];\r\n if Result.HostDockSite <> Self then\r\n Result := nil;\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJvDockPageControl.GetImageIndex(TabIndex: Integer): Integer;\r\nvar\r\n I, Visible, NotVisible: Integer;\r\nbegin\r\n if Assigned(FOnGetImageIndex) then\r\n Result := inherited GetImageIndex(TabIndex)\r\n else\r\n begin\r\n Visible := 0;\r\n NotVisible := 0;\r\n for I := 0 to FPages.Count - 1 do\r\n begin\r\n if not GetPage(I).TabVisible then\r\n Inc(NotVisible)\r\n else\r\n Inc(Visible);\r\n if Visible = TabIndex + 1 then\r\n Break;\r\n end;\r\n Result := GetPage(TabIndex + NotVisible).ImageIndex;\r\n end;\r\nend;\r\n\r\nfunction TJvDockPageControl.GetPage(Index: Integer): TJvDockTabSheet;\r\nbegin\r\n Result := FPages[Index];\r\nend;\r\n\r\nfunction TJvDockPageControl.GetPageFromDockClient(Client: TControl): TJvDockTabSheet;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := nil;\r\n for I := 0 to Count - 1 do\r\n if (Client.Parent = Pages[I]) and (Client.HostDockSite = Self) then\r\n begin\r\n Result := Pages[I];\r\n Break;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockPageControl.GetSiteInfo(Client: TControl; var InfluenceRect: TRect;\r\n MousePos: TPoint; var CanDock: Boolean);\r\nbegin\r\n CanDock := GetPageFromDockClient(Client) = nil;\r\n inherited GetSiteInfo(Client, InfluenceRect, MousePos, CanDock);\r\nend;\r\n\r\nprocedure TJvDockPageControl.InsertPage(Page: TJvDockTabSheet);\r\nbegin\r\n FPages.Add(Page);\r\n Page.FPageControl := Self;\r\n Page.UpdateTabShowing;\r\nend;\r\n\r\nprocedure TJvDockPageControl.InsertTab(Page: TJvDockTabSheet);\r\nbegin\r\n Tabs.InsertObject(Page.TabIndex, Page.Caption, Page);\r\n UpdateActivePage;\r\nend;\r\n\r\nprocedure TJvDockPageControl.Loaded;\r\nbegin\r\n inherited Loaded;\r\n UpdateTabHighlights;\r\nend;\r\n\r\nprocedure TJvDockPageControl.MoveTab(CurIndex, NewIndex: Integer);\r\nbegin\r\n Tabs.Move(CurIndex, NewIndex);\r\nend;\r\n\r\nprocedure TJvDockPageControl.RemovePage(Page: TJvDockTabSheet);\r\nvar\r\n NextSheet: TJvDockTabSheet;\r\nbegin\r\n NextSheet := FindNextPage(Page, True, not (csDesigning in ComponentState));\r\n if NextSheet = Page then\r\n NextSheet := nil;\r\n Page.SetTabShowing(False);\r\n Page.FPageControl := nil;\r\n FPages.Remove(Page);\r\n SetActivePage(NextSheet);\r\nend;\r\n\r\nprocedure TJvDockPageControl.SelectNextPage(GoForward: Boolean; CheckTabVisible: Boolean = True);\r\nvar\r\n Page: TJvDockTabSheet;\r\nbegin\r\n Page := FindNextPage(ActivePage, GoForward, CheckTabVisible);\r\n if (Page <> nil) and (Page <> ActivePage) and CanChange then\r\n begin\r\n SetActivePage(Page);\r\n Change;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockPageControl.SetActivePage(Page: TJvDockTabSheet);\r\nbegin\r\n if (Page <> nil) and (Page.PageControl <> Self) then\r\n Exit;\r\n ChangeActivePage(Page);\r\n if Page = nil then\r\n TabIndex := -1\r\n else\r\n if Page = FActivePage then\r\n TabIndex := Page.TabIndex;\r\nend;\r\n\r\nprocedure TJvDockPageControl.SetActivePageIndex(const Value: Integer);\r\nbegin\r\n if (Value > -1) and (Value < Count) then\r\n ActivePage := Pages[Value]\r\n else\r\n ActivePage := nil;\r\nend;\r\n\r\nprocedure TJvDockPageControl.SetChildOrder(Child: TComponent; Order: Integer);\r\nbegin\r\n TJvDockTabSheet(Child).PageIndex := Order;\r\nend;\r\n\r\nprocedure TJvDockPageControl.ShowControl(AControl: TControl);\r\nbegin\r\n if (AControl is TJvDockTabSheet) and (TJvDockTabSheet(AControl).PageControl = Self) then\r\n SetActivePage(TJvDockTabSheet(AControl));\r\n inherited ShowControl(AControl);\r\nend;\r\n\r\nprocedure TJvDockPageControl.UpdateActivePage;\r\nbegin\r\n if TabIndex >= 0 then\r\n SetActivePage(TJvDockTabSheet(Tabs.Objects[TabIndex]))\r\n else\r\n SetActivePage(nil);\r\nend;\r\n\r\nprocedure TJvDockPageControl.UpdateTab(Page: TJvDockTabSheet);\r\nbegin\r\n Tabs[Page.TabIndex] := Page.Caption;\r\nend;\r\n\r\nprocedure TJvDockPageControl.UpdateTabHighlights;\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := 0 to Count - 1 do\r\n Pages[I].SetHighlighted(Pages[I].FHighlighted);\r\nend;\r\n\r\nprocedure TJvDockPageControl.WMLButtonDblClk(var Msg: TWMLButtonDblClk);\r\nvar\r\n DockCtl: TControl;\r\nbegin\r\n inherited;\r\n if JvGlobalDockClient <> nil then\r\n DockCtl := ButtonEvent(Self, Msg, mbLeft, msTabPage, JvGlobalDockClient.DoNCButtonDblClk)\r\n else\r\n DockCtl := nil;\r\n if (DockCtl <> nil) and JvGlobalDockClient.CanFloat then\r\n DockCtl.ManualDock(nil, nil, alNone);\r\nend;\r\n\r\nprocedure TJvDockPageControl.WMLButtonDown(var Msg: TWMLButtonDown);\r\nvar\r\n DockCtl: TControl;\r\nbegin\r\n inherited;\r\n if JvGlobalDockClient <> nil then\r\n DockCtl := ButtonEvent(Self, Msg, mbLeft, msTabPage, JvGlobalDockClient.DoNCButtonDown)\r\n else\r\n DockCtl := nil;\r\n if (DockCtl <> nil) and (Style = tsTabs) then\r\n JvGlobalDockManager.BeginDrag(DockCtl, False);\r\nend;\r\n\r\nprocedure TJvDockPageControl.WMLButtonUp(var Msg: TWMLButtonUp);\r\nbegin\r\n inherited;\r\n if JvGlobalDockClient <> nil then\r\n ButtonEvent(Self, Msg, mbLeft, msTabPage, JvGlobalDockClient.DoNCButtonUp);\r\nend;\r\n\r\nprocedure TJvDockPageControl.WMMButtonDblClk(var Msg: TWMMButtonDblClk);\r\nbegin\r\n inherited;\r\n if JvGlobalDockClient <> nil then\r\n ButtonEvent(Self, Msg, mbMiddle, msTabPage, JvGlobalDockClient.DoNCButtonDblClk);\r\nend;\r\n\r\nprocedure TJvDockPageControl.WMMButtonDown(var Msg: TWMMButtonDown);\r\nbegin\r\n inherited;\r\n if JvGlobalDockClient <> nil then\r\n ButtonEvent(Self, Msg, mbMiddle, msTabPage, JvGlobalDockClient.DoNCButtonDown);\r\nend;\r\n\r\nprocedure TJvDockPageControl.WMMButtonUp(var Msg: TWMMButtonUp);\r\nbegin\r\n inherited;\r\n if JvGlobalDockClient <> nil then\r\n ButtonEvent(Self, Msg, mbMiddle, msTabPage, JvGlobalDockClient.DoNCButtonUp);\r\nend;\r\n\r\nprocedure TJvDockPageControl.WMRButtonDblClk(var Msg: TWMRButtonDblClk);\r\nbegin\r\n inherited;\r\n if JvGlobalDockClient <> nil then\r\n ButtonEvent(Self, Msg, mbRight, msTabPage, JvGlobalDockClient.DoNCButtonDblClk);\r\nend;\r\n\r\nprocedure TJvDockPageControl.WMRButtonDown(var Msg: TWMRButtonDown);\r\nbegin\r\n Msg.Msg := WM_LBUTTONDOWN;\r\n inherited;\r\n if JvGlobalDockClient <> nil then\r\n ButtonEvent(Self, Msg, mbRight, msTabPage, JvGlobalDockClient.DoNCButtonDown);\r\nend;\r\n\r\nprocedure TJvDockPageControl.WMRButtonUp(var Msg: TWMRButtonUp);\r\nbegin\r\n inherited;\r\n if JvGlobalDockClient <> nil then\r\n ButtonEvent(Self, Msg, mbRight, msTabPage, JvGlobalDockClient.DoNCButtonUp);\r\nend;\r\n\r\n//=== { TJvDockTabSheet } ====================================================\r\n\r\nconstructor TJvDockTabSheet.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n Align := alClient;\r\n ControlStyle := ControlStyle + [csAcceptsControls, csNoDesignVisible];\r\n Visible := False;\r\n FTabVisible := True;\r\n FHighlighted := False;\r\n FImageIndex := -1;\r\nend;\r\n\r\ndestructor TJvDockTabSheet.Destroy;\r\nbegin\r\n if FPageControl <> nil then\r\n begin\r\n if FPageControl.FUndockingPage = Self then\r\n FPageControl.FUndockingPage := nil;\r\n FPageControl.RemovePage(Self);\r\n end;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvDockTabSheet.CMShowingChanged(var Msg: TMessage);\r\nbegin\r\n inherited;\r\n if Showing then\r\n try\r\n DoShow\r\n except\r\n Application.HandleException(Self);\r\n end\r\n else\r\n if not Showing then\r\n try\r\n DoHide;\r\n except\r\n Application.HandleException(Self);\r\n end;\r\nend;\r\n\r\nprocedure TJvDockTabSheet.CMTextChanged(var Msg: TMessage);\r\nbegin\r\n if FTabShowing then\r\n FPageControl.UpdateTab(Self);\r\nend;\r\n\r\nprocedure TJvDockTabSheet.CreateParams(var Params: TCreateParams);\r\nbegin\r\n inherited CreateParams(Params);\r\n with Params.WindowClass do\r\n style := style and not (CS_HREDRAW or CS_VREDRAW);\r\nend;\r\n\r\nprocedure TJvDockTabSheet.DoHide;\r\nbegin\r\n if Assigned(FOnHide) then\r\n FOnHide(Self);\r\nend;\r\n\r\nprocedure TJvDockTabSheet.DoShow;\r\nbegin\r\n if Assigned(FOnShow) then\r\n FOnShow(Self);\r\nend;\r\n\r\nfunction TJvDockTabSheet.GetPageIndex: Integer;\r\nbegin\r\n if (FPageControl <> nil) and (FPageControl.FPages <> nil) then\r\n Result := FPageControl.FPages.IndexOf(Self)\r\n else\r\n Result := -1;\r\nend;\r\n\r\nfunction TJvDockTabSheet.GetTabIndex: Integer;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := 0;\r\n if not FTabShowing then\r\n Dec(Result)\r\n else\r\n for I := 0 to PageIndex - 1 do\r\n if TJvDockTabSheet(FPageControl.FPages[I]).FTabShowing then\r\n Inc(Result);\r\nend;\r\n\r\nprocedure TJvDockTabSheet.ReadState(Reader: TReader);\r\nbegin\r\n inherited ReadState(Reader);\r\n if Reader.Parent is TJvDockPageControl then\r\n PageControl := TJvDockPageControl(Reader.Parent);\r\nend;\r\n\r\nprocedure TJvDockTabSheet.SetHighlighted(Value: Boolean);\r\nbegin\r\n if not (csReading in ComponentState) then\r\n SendMessage(PageControl.Handle, TCM_HIGHLIGHTITEM, TabIndex, MakeLong(Word(Value), 0));\r\n FHighlighted := Value;\r\nend;\r\n\r\nprocedure TJvDockTabSheet.SetImageIndex(Value: TImageIndex);\r\nbegin\r\n if FImageIndex <> Value then\r\n begin\r\n FImageIndex := Value;\r\n if FTabShowing then\r\n FPageControl.UpdateTab(Self);\r\n end;\r\nend;\r\n\r\nprocedure TJvDockTabSheet.SetPageControl(APageControl: TJvDockPageControl);\r\nbegin\r\n if FPageControl <> APageControl then\r\n begin\r\n if FPageControl <> nil then\r\n FPageControl.RemovePage(Self);\r\n Parent := APageControl;\r\n if APageControl <> nil then\r\n APageControl.InsertPage(Self);\r\n end;\r\nend;\r\n\r\nprocedure TJvDockTabSheet.SetPageIndex(Value: Integer);\r\nvar\r\n I, MaxPageIndex: Integer;\r\nbegin\r\n if (FPageControl <> nil) and (FPageControl.FPages <> nil) then\r\n begin\r\n MaxPageIndex := FPageControl.FPages.Count - 1;\r\n if Value > MaxPageIndex then\r\n raise EListError.CreateResFmt(@SPageIndexError, [Value, MaxPageIndex]);\r\n I := TabIndex;\r\n FPageControl.FPages.Move(PageIndex, Value);\r\n if I >= 0 then\r\n FPageControl.MoveTab(I, TabIndex);\r\n end;\r\nend;\r\n\r\nprocedure TJvDockTabSheet.SetTabShowing(Value: Boolean);\r\nvar\r\n Index: Integer;\r\nbegin\r\n if FTabShowing <> Value then\r\n if Value then\r\n begin\r\n FTabShowing := True;\r\n FPageControl.InsertTab(Self);\r\n end\r\n else\r\n begin\r\n Index := TabIndex;\r\n FTabShowing := False;\r\n FPageControl.DeleteTab(Self, Index);\r\n end;\r\nend;\r\n\r\nprocedure TJvDockTabSheet.SetTabVisible(Value: Boolean);\r\nbegin\r\n if FTabVisible <> Value then\r\n begin\r\n FTabVisible := Value;\r\n UpdateTabShowing;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockTabSheet.UpdateTabShowing;\r\nbegin\r\n SetTabShowing((FPageControl <> nil) and FTabVisible);\r\nend;\r\n\r\n//=== { TJvDockTabStrings } ==================================================\r\n\r\nprocedure TJvDockTabStrings.Clear;\r\nbegin\r\n if SendMessage(FTabControl.Handle, TCM_DELETEALLITEMS, 0, 0) = 0 then\r\n TabControlError(sTabFailClear);\r\n FTabControl.TabsChanged;\r\nend;\r\n\r\nprocedure TJvDockTabStrings.Delete(Index: Integer);\r\nbegin\r\n if SendMessage(FTabControl.Handle, TCM_DELETEITEM, Index, 0) = 0 then\r\n TabControlError(Format(sTabFailDelete, [Index]));\r\n FTabControl.TabsChanged;\r\nend;\r\n\r\nfunction TJvDockTabStrings.Get(Index: Integer): string;\r\nconst\r\n RTL: array [Boolean] of Longint = (0, TCIF_RTLREADING);\r\nvar\r\n TCItem: TTCItem;\r\n Buffer: array [0..4095] of Char;\r\nbegin\r\n TCItem.mask := TCIF_TEXT or RTL[FTabControl.UseRightToLeftReading];\r\n TCItem.pszText := Buffer;\r\n TCItem.cchTextMax := SizeOf(Buffer);\r\n if SendMessage(FTabControl.Handle, TCM_GETITEM, Index, LPARAM(@TCItem)) = 0 then\r\n TabControlError(Format(sTabFailRetrieve, [Index]));\r\n Result := Buffer;\r\nend;\r\n\r\nfunction TJvDockTabStrings.GetCount: Integer;\r\nbegin\r\n Result := SendMessage(FTabControl.Handle, TCM_GETITEMCOUNT, 0, 0);\r\nend;\r\n\r\nfunction TJvDockTabStrings.GetObject(Index: Integer): TObject;\r\nvar\r\n TCItem: TTCItem;\r\nbegin\r\n TCItem.mask := TCIF_PARAM;\r\n if SendMessage(FTabControl.Handle, TCM_GETITEM, Index, LPARAM(@TCItem)) = 0 then\r\n TabControlError(Format(sTabFailGetObject, [Index]));\r\n Result := TObject(TCItem.lParam);\r\nend;\r\n\r\nprocedure TJvDockTabStrings.Insert(Index: Integer; const S: string);\r\nconst\r\n RTL: array [Boolean] of Longint = (0, TCIF_RTLREADING);\r\nvar\r\n TCItem: TTCItem;\r\nbegin\r\n TCItem.mask := TCIF_TEXT or RTL[FTabControl.UseRightToLeftReading] or\r\n TCIF_IMAGE;\r\n TCItem.pszText := PChar(S);\r\n TCItem.iImage := FTabControl.GetImageIndex(Index);\r\n if SendMessage(FTabControl.Handle, TCM_INSERTITEM, Index, LPARAM(@TCItem)) < 0 then\r\n TabControlError(Format(sTabFailSet, [S, Index]));\r\n FTabControl.TabsChanged;\r\nend;\r\n\r\nprocedure TJvDockTabStrings.Put(Index: Integer; const S: string);\r\nconst\r\n RTL: array [Boolean] of Longint = (0, TCIF_RTLREADING);\r\nvar\r\n TCItem: TTCItem;\r\nbegin\r\n TCItem.mask := TCIF_TEXT or RTL[FTabControl.UseRightToLeftReading] or\r\n TCIF_IMAGE;\r\n TCItem.pszText := PChar(S);\r\n TCItem.iImage := FTabControl.GetImageIndex(Index);\r\n if SendMessage(FTabControl.Handle, TCM_SETITEM, Index, LPARAM(@TCItem)) = 0 then\r\n TabControlError(Format(sTabFailSet, [S, Index]));\r\n FTabControl.TabsChanged;\r\nend;\r\n\r\nprocedure TJvDockTabStrings.PutObject(Index: Integer; AObject: TObject);\r\nvar\r\n TCItem: TTCItem;\r\nbegin\r\n TCItem.mask := TCIF_PARAM;\r\n TCItem.lParam := LPARAM(AObject);\r\n if SendMessage(FTabControl.Handle, TCM_SETITEM, WPARAM(Index), LPARAM(@TCItem)) = 0 then\r\n TabControlError(Format(sTabFailSetObject, [Index]));\r\nend;\r\n\r\nprocedure TJvDockTabStrings.SetUpdateState(Updating: Boolean);\r\nbegin\r\n FTabControl.FUpdating := Updating;\r\n SendMessage(FTabControl.Handle, WM_SETREDRAW, Ord(not Updating), 0);\r\n if not Updating then\r\n begin\r\n FTabControl.Invalidate;\r\n FTabControl.TabsChanged;\r\n end;\r\nend;\r\n\r\n//=== { TSiteList } ==========================================================\r\n\r\nprocedure TSiteList.AddSite(ASite: TWinControl);\r\nvar\r\n SI: PSiteInfoRec;\r\n Index: Integer;\r\n\r\n function GetTopParent: HWND;\r\n var\r\n NextParent: HWND;\r\n begin\r\n NextParent := ASite.Handle;\r\n Result := NextParent;\r\n while NextParent <> 0 do\r\n begin\r\n Result := NextParent;\r\n NextParent := GetParent(NextParent);\r\n end;\r\n end;\r\n\r\nbegin\r\n New(SI);\r\n SI.Site := ASite;\r\n SI.TopParent := GetTopParent;\r\n if Find(SI.TopParent, Index) then\r\n Insert(Index, SI)\r\n else\r\n Add(SI);\r\nend;\r\n\r\nprocedure TSiteList.Clear;\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := 0 to Count - 1 do\r\n Dispose(PSiteInfoRec(Items[I]));\r\n inherited Clear;\r\nend;\r\n\r\nfunction TSiteList.Find(ParentWnd: THandle; var Index: Integer): Boolean;\r\nbegin\r\n Index := 0;\r\n Result := False;\r\n while Index < Count do\r\n begin\r\n Result := (PSiteInfoRec(Items[Index]).TopParent = ParentWnd);\r\n if Result then\r\n Exit;\r\n Inc(Index);\r\n end;\r\nend;\r\n\r\nfunction TSiteList.GetTopSite: TWinControl;\r\nvar\r\n Index: Integer;\r\n DesktopWnd, CurrentWnd: HWND;\r\nbegin\r\n Result := nil;\r\n if Count = 0 then\r\n Exit\r\n else\r\n if Count = 1 then\r\n Result := PSiteInfoRec(Items[0]).Site\r\n else\r\n begin\r\n DesktopWnd := GetDesktopWindow;\r\n CurrentWnd := GetTopWindow(DesktopWnd);\r\n while (Result = nil) and (CurrentWnd <> 0) do\r\n if Find(CurrentWnd, Index) then\r\n Result := PSiteInfoRec(List[Index])^.Site\r\n else\r\n CurrentWnd := GetNextWindow(CurrentWnd, GW_HWNDNEXT);\r\n end;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvDockSupportProc.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvDockSupportProc.pas, released on 2003-12-31.\r\n\r\nThe Initial Developer of the Original Code is luxiaoban.\r\nPortions created by luxiaoban are Copyright (C) 2002,2003 luxiaoban.\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvDockSupportProc.pas 12805 2010-06-10 14:11:07Z obones $\r\n\r\nunit JvDockSupportProc;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, Messages, Classes, Graphics, Controls, Forms;\r\n\r\ntype\r\n TJvDockListScanKind = (lskForward, lskBackward);\r\n\r\nfunction JvDockStreamDataToString(Stream: TStream): string;\r\nprocedure JvDockStringToStreamData(Stream: TStream; const Data: string);\r\n\r\nfunction JvDockFindDockFormWithName(const FormName: string;\r\n FromDockManager: Boolean = False;\r\n FromList: Boolean = True;\r\n ScanKind: TJvDockListScanKind = lskForward): TCustomForm;\r\nfunction JvDockFindDockServerFormWithName(const FormName: string;\r\n FromDockManager: Boolean = False;\r\n FromList: Boolean = True;\r\n ScanKind: TJvDockListScanKind = lskForward): TCustomForm;\r\nfunction JvDockFindDockClientFormWithName(const FormName: string;\r\n FromDockManager: Boolean = False;\r\n FromList: Boolean = True;\r\n ScanKind: TJvDockListScanKind = lskForward): TCustomForm;\r\nfunction JvDockFindDockServerFromDockManager(const FormName: string;\r\n FromList: Boolean = True;\r\n ScanKind: TJvDockListScanKind = lskForward): TCustomForm;\r\nfunction JvDockFindDockClientFromDockManager(const FormName: string;\r\n FromList: Boolean = True;\r\n ScanKind: TJvDockListScanKind = lskForward): TCustomForm;\r\nfunction JvDockFindDockFormFromScreen(const FormName: string;\r\n ScanKind: TJvDockListScanKind = lskForward): TCustomForm;\r\n\r\nfunction JvDockGetMinOffset(TBDockSize, ControlSize: Integer; Scale: Real): Integer;\r\n\r\nfunction JvDockGetNoNClientMetrics: TNONCLIENTMETRICS;\r\n\r\nfunction JvDockGetSysCaptionHeight: Integer;\r\n\r\nfunction JvDockGetSysBorderWidth: Integer;\r\nfunction JvDockGetSysCaptionHeightAndBorderWidth: Integer;\r\nfunction JvDockGetActiveTitleBeginColor: TColor;\r\nfunction JvDockGetActiveTitleEndColor: TColor;\r\nfunction JvDockGetInactiveTitleBeginColor: TColor;\r\nfunction JvDockGetInactiveTitleEndColor: TColor;\r\nfunction JvDockGetTitleFontColor(Active: Boolean): TColor;\r\nfunction JvDockGetActiveTitleFontColor: TColor;\r\nfunction JvDockGetInactiveTitleFontColor: TColor;\r\nfunction JvDockGetTitleFont: TFont;\r\n\r\nprocedure JvDockLockWindow(Control: TWinControl);\r\nprocedure JvDockUnLockWindow;\r\n\r\nfunction JvDockCreateNCMessage(Control: TControl; Msg: Cardinal; HTFlag: Integer; Pos: TPoint): TWMNCHitMessage;\r\nfunction JvDockExchangeOrient(Orient: TDockOrientation): TDockOrientation;\r\nfunction JvDockGetControlOrient(AControl: TControl): TDockOrientation;\r\nfunction JvDockGetControlSize(AControl: TControl): Integer;\r\n\r\nprocedure RegisterSettingChangeClient(Client: TObject; Event: TNotifyEvent);\r\nprocedure UnRegisterSettingChangeClient(Client: TObject);\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvDockSupportProc.pas $';\r\n Revision: '$Revision: 12805 $';\r\n Date: '$Date: 2010-06-10 16:11:07 +0200 (jeu. 10 juin 2010) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n SysUtils, Math,\r\n JvJVCLUtils, JvDockControlForm, JvDockGlobals;\r\n\r\ntype\r\n { The dock style components used to hook the form they were dropped on, so\r\n they could respond to Windows setting changes. The components can now use\r\n the TJvMsgWindow -via the RegisterSettingChangeClient procedure- that creates\r\n a window so it is able to receive WM_SETTINGCHANGE messages. Notification is\r\n done via the Observer pattern\r\n }\r\n TJvMsgWindow = class(TObject)\r\n private\r\n FHandle: HWND;\r\n FClients: TList;\r\n FNotifyEvents: TList;\r\n procedure WndProc(var Msg: TMessage);\r\n procedure NotifyClients;\r\n public\r\n constructor Create; virtual;\r\n destructor Destroy; override;\r\n procedure RegisterClient(Client: TObject; Event: TNotifyEvent); virtual;\r\n procedure UnRegisterClient(Client: TObject); virtual;\r\n end;\r\n\r\nvar\r\n GMsgHook: TJvMsgWindow;\r\n JvDockTitleFont: TFont = nil;\r\n\r\nfunction JvDockStreamDataToString(Stream: TStream): string;\r\nvar\r\n Ch: AnsiChar;\r\nbegin\r\n Result := '';\r\n Stream.Position := 0;\r\n while Stream.Position < Stream.Size do\r\n begin\r\n Stream.Read(Ch, SizeOf(Ch));\r\n Result := Result + IntToHex(Ord(Ch), 2);\r\n end;\r\nend;\r\n\r\nprocedure JvDockStringToStreamData(Stream: TStream; const Data: string);\r\nvar\r\n I: Integer;\r\n Ch: AnsiChar;\r\nbegin\r\n I := 1;\r\n while I < Length(Data) do\r\n begin\r\n Ch := AnsiChar(StrToInt('$' + Copy(Data, I, 2)));\r\n Stream.Write(Ch, SizeOf(Ch));\r\n Inc(I, 2);\r\n end;\r\nend;\r\n\r\nfunction JvDockFindDockFormWithName(const FormName: string; FromDockManager: Boolean;\r\n FromList: Boolean; ScanKind: TJvDockListScanKind): TCustomForm;\r\nbegin\r\n Result := JvDockFindDockClientFormWithName(FormName, FromDockManager, FromList, ScanKind);\r\n if Result = nil then\r\n Result := JvDockFindDockServerFormWithName(FormName, FromDockManager, FromList, ScanKind);\r\nend;\r\n\r\nfunction JvDockFindDockServerFormWithName(const FormName: string; FromDockManager: Boolean;\r\n FromList: Boolean; ScanKind: TJvDockListScanKind): TCustomForm;\r\nbegin\r\n if FromDockManager then\r\n Result := JvDockFindDockServerFromDockManager(FormName, FromList, ScanKind)\r\n else\r\n Result := JvDockFindDockFormFromScreen(FormName, ScanKind);\r\nend;\r\n\r\nfunction JvDockFindDockClientFormWithName(const FormName: string; FromDockManager: Boolean;\r\n FromList: Boolean; ScanKind: TJvDockListScanKind): TCustomForm;\r\nbegin\r\n if FromDockManager then\r\n Result := JvDockFindDockClientFromDockManager(FormName, FromList, ScanKind)\r\n else\r\n Result := JvDockFindDockFormFromScreen(FormName, ScanKind);\r\nend;\r\n\r\nfunction JvDockFindDockServerFromDockManager(const FormName: string; FromList: Boolean;\r\n ScanKind: TJvDockListScanKind): TCustomForm;\r\nvar\r\n I: Integer;\r\nbegin\r\n case ScanKind of\r\n lskForward:\r\n for I := 0 to JvGlobalDockManager.DockServerCount - 1 do\r\n begin\r\n Result := JvGlobalDockManager.DockServer[I].ParentForm;\r\n if Assigned(Result) and (FormName = Result.Name) then\r\n Exit;\r\n end;\r\n lskBackward:\r\n for I := JvGlobalDockManager.DockServerCount - 1 downto 0 do\r\n begin\r\n Result := JvGlobalDockManager.DockServer[I].ParentForm;\r\n if Assigned(Result) and (FormName = Result.Name) then\r\n Exit;\r\n end;\r\n end;\r\n Result := nil;\r\nend;\r\nfunction JvDockFindDockClientFromDockManager(const FormName: string; FromList: Boolean;\r\n ScanKind: TJvDockListScanKind): TCustomForm;\r\nvar\r\n I: Integer;\r\nbegin\r\n case ScanKind of\r\n lskForward:\r\n for I := 0 to JvGlobalDockManager.DockClientCount - 1 do\r\n begin\r\n Result := JvGlobalDockManager.DockClient[I].ParentForm;\r\n if Assigned(Result) and (FormName = Result.Name) then\r\n Exit;\r\n end;\r\n lskBackward:\r\n for I := JvGlobalDockManager.DockClientCount - 1 downto 0 do\r\n begin\r\n Result := JvGlobalDockManager.DockClient[I].ParentForm;\r\n if Assigned(Result) and (FormName = Result.Name) then\r\n Exit;\r\n end;\r\n end;\r\n Result := nil;\r\nend;\r\n\r\nfunction JvDockFindDockFormFromScreen(const FormName: string;\r\n ScanKind: TJvDockListScanKind): TCustomForm;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := nil;\r\n case ScanKind of\r\n lskForward:\r\n for I := 0 to Screen.CustomFormCount - 1 do\r\n if FormName = Screen.CustomForms[I].Name then\r\n begin\r\n Result := Screen.CustomForms[I];\r\n Break;\r\n end;\r\n lskBackward:\r\n for I := Screen.CustomFormCount - 1 downto 0 do\r\n if FormName = Screen.CustomForms[I].Name then\r\n begin\r\n Result := Screen.CustomForms[I];\r\n Break;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction JvDockGetMinOffset(TBDockSize, ControlSize: Integer; Scale: Real): Integer;\r\nbegin\r\n if (Scale < 0) or (Scale > 1) then\r\n Scale := 1;\r\n Result := Min(TBDockSize, Round(ControlSize * Scale));\r\nend;\r\n\r\nfunction JvDockGetNoNClientMetrics: TNONCLIENTMETRICS;\r\nbegin\r\n {$IFDEF RTL210_UP}\r\n Result.cbSize := TNonClientMetrics.SizeOf;\r\n {$ELSE}\r\n Result.cbSize := SizeOf(Result);\r\n {$ENDIF RTL210_UP}\r\n SystemParametersInfo(SPI_GETNONCLIENTMETRICS, Result.cbSize, @Result, 0);\r\nend;\r\n\r\nfunction JvDockGetSysCaptionHeight: Integer;\r\nbegin\r\n Result := JvDockGetNoNClientMetrics.iCaptionHeight\r\nend;\r\n\r\nfunction JvDockGetSysBorderWidth: Integer;\r\nbegin\r\n Result := JvDockGetNoNClientMetrics.iBorderWidth;\r\nend;\r\n\r\nfunction JvDockGetSysCaptionHeightAndBorderWidth: Integer;\r\nvar\r\n NoNCM: TNONCLIENTMETRICS;\r\nbegin\r\n NoNCM := JvDockGetNoNClientMetrics;\r\n Result := NoNCM.iBorderWidth + NoNCM.iCaptionHeight;\r\nend;\r\n\r\nfunction JvDockGetActiveTitleBeginColor: TColor;\r\nbegin\r\n Result := GetSysColor(COLOR_ACTIVECAPTION);\r\nend;\r\n\r\nfunction JvDockGetActiveTitleEndColor: TColor;\r\nbegin\r\n Result := GetSysColor(COLOR_GRADIENTACTIVECAPTION);\r\nend;\r\n\r\nfunction JvDockGetInactiveTitleBeginColor: TColor;\r\nbegin\r\n Result := GetSysColor(COLOR_INACTIVECAPTION);\r\nend;\r\n\r\nfunction JvDockGetInactiveTitleEndColor: TColor;\r\nbegin\r\n Result := GetSysColor(COLOR_GRADIENTINACTIVECAPTION);\r\nend;\r\n\r\nfunction JvDockGetTitleFontColor(Active: Boolean): TColor;\r\nbegin\r\n if Active then\r\n Result := JvDockGetActiveTitleFontColor\r\n else\r\n Result := JvDockGetInactiveTitleFontColor;\r\nend;\r\n\r\nfunction JvDockGetActiveTitleFontColor: TColor;\r\nbegin\r\n Result := GetSysColor(COLOR_CAPTIONTEXT);\r\nend;\r\n\r\nfunction JvDockGetInactiveTitleFontColor: TColor;\r\nbegin\r\n Result := GetSysColor(COLOR_INACTIVECAPTIONTEXT);\r\nend;\r\n\r\nfunction JvDockGetTitleFont: TFont;\r\nvar\r\n NoNCM: TNONCLIENTMETRICS;\r\nbegin\r\n if JvDockTitleFont = nil then\r\n JvDockTitleFont := TFont.Create;\r\n Result := JvDockTitleFont;\r\n NoNCM := JvDockGetNoNClientMetrics;\r\n Result.Handle := CreateFontIndirect(NoNCM.lfCaptionFont);\r\nend;\r\n\r\nvar\r\n GLockCount: Integer;\r\n GWindowLocked: Boolean;\r\n\r\nprocedure JvDockLockWindow(Control: TWinControl);\r\nbegin\r\n { Ignore Control parameter; otherwise nested JvDockLockWindow calls are not possible }\r\n if GLockCount = 0 then\r\n GWindowLocked := LockWindowUpdate(GetDesktopWindow);\r\n Inc(GLockCount);\r\nend;\r\n\r\nprocedure JvDockUnLockWindow;\r\nbegin\r\n Dec(GLockCount);\r\n if GLockCount = 0 then\r\n begin\r\n if GWindowLocked then\r\n LockWindowUpdate(0);\r\n GWindowLocked := False;\r\n end;\r\nend;\r\n\r\nfunction JvDockCreateNCMessage(Control: TControl; Msg: Cardinal; HTFlag: Integer;\r\n Pos: TPoint): TWMNCHitMessage;\r\nbegin\r\n Result.Msg := Msg;\r\n Result.HitTest := HTFlag;\r\n Pos := Control.ClientToScreen(Pos);\r\n Result.XCursor := Pos.X;\r\n Result.YCursor := Pos.Y;\r\nend;\r\n\r\nfunction JvDockExchangeOrient(Orient: TDockOrientation): TDockOrientation;\r\nbegin\r\n case Orient of\r\n doHorizontal:\r\n Result := doVertical;\r\n doVertical:\r\n Result := doHorizontal;\r\n else\r\n Result := doNoOrient;\r\n end;\r\nend;\r\n\r\nfunction JvDockGetControlOrient(AControl: TControl): TDockOrientation;\r\nbegin\r\n Assert(AControl <> nil);\r\n Result := doNoOrient;\r\n case AControl.Align of\r\n alClient, alNone:\r\n Result := doNoOrient;\r\n alLeft, alRight:\r\n Result := doVertical;\r\n alTop, alBottom:\r\n Result := doHorizontal;\r\n end;\r\nend;\r\n\r\nfunction JvDockGetControlSize(AControl: TControl): Integer;\r\nbegin\r\n case JvDockGetControlOrient(AControl) of\r\n doVertical:\r\n Result := AControl.Width;\r\n doHorizontal:\r\n Result := AControl.Height;\r\n else\r\n raise Exception.CreateRes(@RsEDockCannotGetValueWithNoOrient);\r\n end;\r\nend;\r\n\r\nprocedure RegisterSettingChangeClient(Client: TObject; Event: TNotifyEvent);\r\nbegin\r\n if GMsgHook = nil then\r\n GMsgHook := TJvMsgWindow.Create;\r\n GMsgHook.RegisterClient(Client, Event);\r\nend;\r\n\r\nprocedure UnRegisterSettingChangeClient(Client: TObject);\r\nbegin\r\n if Assigned(GMsgHook) then\r\n begin\r\n GMsgHook.UnRegisterClient(Client);\r\n if GMsgHook.FClients.Count = 0 then\r\n FreeAndNil(GMsgHook);\r\n end;\r\nend;\r\n\r\n//=== { TJvMsgWindow } =======================================================\r\n\r\nconstructor TJvMsgWindow.Create;\r\nbegin\r\n inherited Create;\r\n FClients := TList.Create;\r\n FNotifyEvents := TList.Create;\r\n FHandle := AllocateHWndEx(WndProc);\r\nend;\r\n\r\ndestructor TJvMsgWindow.Destroy;\r\nbegin\r\n if FHandle <> 0 then\r\n DeallocateHWndEx(FHandle);\r\n FClients.Free;\r\n FNotifyEvents.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvMsgWindow.NotifyClients;\r\nvar\r\n I: Integer;\r\n NotifyEvent: TNotifyEvent;\r\nbegin\r\n for I := 0 to FClients.Count - 1 do\r\n begin\r\n TMethod(NotifyEvent).Code := FNotifyEvents[I];\r\n TMethod(NotifyEvent).Data := FClients[I];\r\n NotifyEvent(Self);\r\n end;\r\nend;\r\n\r\nprocedure TJvMsgWindow.RegisterClient(Client: TObject; Event: TNotifyEvent);\r\nbegin\r\n FClients.Add(Client);\r\n FNotifyEvents.Add(TMethod(Event).Code);\r\nend;\r\n\r\nprocedure TJvMsgWindow.UnRegisterClient(Client: TObject);\r\nvar\r\n Index: Integer;\r\nbegin\r\n Index := FClients.IndexOf(Client);\r\n if Index <> -1 then\r\n begin\r\n FClients.Delete(Index);\r\n FNotifyEvents.Delete(Index);\r\n end;\r\nend;\r\n\r\nprocedure TJvMsgWindow.WndProc(var Msg: TMessage);\r\nbegin\r\n with Msg do\r\n if (Msg = WM_SETTINGCHANGE) or (Msg = WM_SYSCOLORCHANGE) then\r\n try\r\n NotifyClients;\r\n except\r\n if Assigned(ApplicationHandleException) then\r\n ApplicationHandleException(Self);\r\n end\r\n else\r\n { !! Call DefWindowProc, so messages like WM_QUERYENDSESSION are\r\n processed correctly, see Mantis #3527 }\r\n Result := DefWindowProc(FHandle, Msg, wParam, lParam);\r\nend;\r\n\r\ninitialization\r\n {$IFDEF UNITVERSIONING}\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n {$ENDIF UNITVERSIONING}\r\n\r\nfinalization\r\n FreeAndNil(JvDockTitleFont);\r\n FreeAndNil(GMsgHook);\r\n {$IFDEF UNITVERSIONING}\r\n UnregisterUnitVersion(HInstance);\r\n {$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvDockTabHost.dfm", "content": "object JvDockTabHost: TJvDockTabHost\r\n Left = 300\r\n Top = 200\r\n Width = 0\r\n Height = 0\r\n Caption = ''\r\n Color = clBtnFace\r\n Font.Charset = DEFAULT_CHARSET\r\n Font.Color = clWindowText\r\n Font.Height = -12\r\n Font.Name = 'MS Sans Serif'\r\n Font.Style = []\r\n OldCreateOrder = False\r\n Visible = False\r\n PixelsPerInch = 96\r\n TextHeight = 13\r\nend\r\n" }, { "path": "External/Jedi/Jvcl/run/JvDockTree.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvDockTree.pas, released on 2003-12-31.\r\n\r\nThe Initial Developer of the Original Code is luxiaoban.\r\nPortions created by luxiaoban are Copyright (C) 2002,2003 luxiaoban.\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvDockTree.pas 13180 2011-11-22 12:45:23Z obones $\r\n\r\nunit JvDockTree;\r\n\r\n{$I jvcl.inc}\r\n\r\n{$DEFINE JVDOCK_QUERY} // experimental!\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n ComCtrls,\r\n Windows, Messages, Classes, Graphics, Controls, Forms,\r\n JvComponentBase;\r\n\r\ntype\r\n TJvDockTree = class;\r\n\r\n IJvDockManager = interface(IDockManager)\r\n ['{7B0AACBC-E9BF-42F8-9629-E551067090B2}']\r\n function GetActiveControl: TControl;\r\n procedure SetActiveControl(const Value: TControl);\r\n function GetGrabberSize: Integer;\r\n procedure SetGrabberSize(const Value: Integer);\r\n function GetDockSplitterWidth: Integer;\r\n procedure SetDockSplitterWidth(const Value: Integer);\r\n function GetBorderWidth: Integer;\r\n procedure SetBorderWidth(const Value: Integer);\r\n function GetDockRect: TRect;\r\n procedure SetDockRect(const Value: TRect);\r\n function GetDockSiteSize: Integer;\r\n procedure SetDockSiteSize(const Value: Integer);\r\n function GetMinSize: Integer;\r\n procedure BeginResizeDockSite;\r\n procedure EndResizeDockSite;\r\n function GetDockEdge(DockRect: TRect; MousePos: TPoint;\r\n var DropAlign: TAlign; Control: TControl): TControl;\r\n function GetHTFlag(MousePos: TPoint): Integer;\r\n procedure GetSiteInfo(Client: TControl;\r\n var InfluenceRect: TRect; MousePos: TPoint; var CanDock: Boolean);\r\n procedure ShowControl(Control: TControl);\r\n procedure HideControl(Control: TControl);\r\n procedure ShowAllControl;\r\n procedure HideAllControl;\r\n procedure ShowSingleControl(Control: TControl);\r\n procedure HideSingleControl(Control: TControl);\r\n procedure ReplaceZoneChild(OldControl, NewControl: TControl);\r\n function HasZoneWithControl(Control: TControl): Boolean;\r\n function GetDockClientLimit(Orient: TDockOrientation; IsMin: Boolean): Integer;\r\n function GetFrameRect(Control: TControl): TRect;\r\n function GetFrameRectEx(Control: TControl): TRect;\r\n {$IFDEF JVDOCK_QUERY}\r\n // Descends the Tree and Finds and return TWinControls docked to a particular parent.\r\n procedure ControlQuery(DockedTo: TWinControl; FoundItems: TList);\r\n {$ENDIF JVDOCK_QUERY}\r\n // backwards compatibility: Mantis 4100\r\n property ActiveControl: TControl read GetActiveControl write SetActiveControl;\r\n property GrabberSize: Integer read GetGrabberSize write SetGrabberSize;\r\n property SplitterWidth: Integer read GetDockSplitterWidth write SetDockSplitterWidth;\r\n property BorderWidth: Integer read GetBorderWidth write SetBorderWidth;\r\n property DockSiteSize: Integer read GetDockSiteSize write SetDockSiteSize;\r\n property DockRect: TRect read GetDockRect write SetDockRect;\r\n property MinSize: Integer read GetMinSize;\r\n //property AlwaysAdjust: Boolean read GetAlwaysAdjust write SetAlwaysAdjust;\r\n end;\r\n\r\n { Left dock panel with 3 zones; zone 1 contains zone 2 & 3; zone 2 contains\r\n control A; zone 3 contains control B.\r\n Right dock panel with 3 zones; zone 4 contains zone 5 & 6; zone 5 contains\r\n control C; zone 6 contains control D.\r\n\r\n Zone 1 Zone 2 Zone 3 Zone 4 Zone 5 Zone 6\r\n -----------------------------------------------------------------------------\r\n Contains Zone 2+3 Control A Control B Zone 5+6 Control C Control D\r\n Orientation Vertical No No Horiz. No No\r\n ZoneLimit x2-x0 x1 x2 x4-x3 y1 y2\r\n LimitBegin x0 x0 x1 y0 y0 y1\r\n LimitSize x2-x0 x1-x0 x2-x0 y2-y0 y1-y0 y2-y1\r\n\r\n y0\r\n --------------------------/\r\n | | | | |\r\n | | | | C |\r\n | | | | | y1\r\n | A | B | |-----|-/\r\n | | | | |\r\n | | | | D |\r\n | | | | | y2\r\n |---|---|---------|-----|-/\r\n \\ \\ \\ \\ \\\r\n x0 x1 x2 x3 x4\r\n }\r\n\r\n TJvDockZone = class(TObject)\r\n private\r\n FChildControl: TWinControl;\r\n FChildZones: TJvDockZone;\r\n FNextSibling: TJvDockZone;\r\n FOrientation: TDockOrientation;\r\n FParentZone: TJvDockZone;\r\n FPrevSibling: TJvDockZone;\r\n FTree: TJvDockTree; { Owner }\r\n FZoneLimit: Integer;\r\n FVisibleSize: Integer;\r\n FVisibled: Boolean;\r\n FControlVisibled: Boolean;\r\n FIsInside: Boolean;\r\n function GetFirstSibling: TJvDockZone;\r\n function GetLastSibling: TJvDockZone;\r\n function GetFirstChild: TJvDockZone;\r\n function GetLastChild: TJvDockZone;\r\n function GetTopLeftArr(Orient: TDockOrientation): Integer;\r\n function GetHeightWidthArr(Orient: TDockOrientation): Integer;\r\n function GetAfterClosestVisibleZone: TJvDockZone;\r\n function GetBeforeClosestVisibleZone: TJvDockZone;\r\n function GetAfterApoapsisVisibleZone: TJvDockZone;\r\n function GetBeforeApoapsisVisibleZone: TJvDockZone;\r\n function GetNextSiblingCount: Integer;\r\n function GetPrevSiblingCount: Integer;\r\n procedure SetVisibled(const Value: Boolean);\r\n procedure SetZoneLimit(const Value: Integer);\r\n function GetVisibleNextSiblingCount: Integer;\r\n function GetVisibleNextSiblingTotal: Integer;\r\n function GetVisiblePrevSiblingCount: Integer;\r\n function GetVisiblePrevSiblingTotal: Integer;\r\n function GetFirstVisibleChildZone: TJvDockZone;\r\n function GetLastVisibleChildZone: TJvDockZone;\r\n procedure SetIsInside(const Value: Boolean);\r\n protected\r\n procedure AdjustZoneLimit(Value: Integer); virtual;\r\n procedure LButtonDblClkMethod; virtual;\r\n function GetChildCount: Integer;\r\n function GetVisibleChildCount: Integer;\r\n function GetChildTotal: Integer;\r\n function GetVisibleChildTotal: Integer;\r\n function GetLimitBegin: Integer;\r\n function GetLimitSize: Integer;\r\n function GetTopLeft(Orient: Integer): Integer;\r\n function GetHeightWidth(Orient: Integer): Integer;\r\n function GetControlName: string;\r\n function GetSplitterLimit(IsMin: Boolean): Integer; virtual;\r\n function DoGetSplitterLimit(Orientation: TDockOrientation;\r\n IsMin: Boolean; var LimitResult: Integer): Integer; virtual;\r\n function SetControlName(const Value: string): Boolean;\r\n procedure DoCustomSetControlName; virtual;\r\n procedure SetChildControlVisible(Client: TControl; AVisible: Boolean); virtual;\r\n public\r\n constructor Create(ATree: TJvDockTree); virtual;\r\n procedure Insert(DockSize: Integer; Hide: Boolean); virtual;\r\n procedure Remove(DockSize: Integer; Hide: Boolean); virtual;\r\n procedure InsertOrRemove(DockSize: Integer; Insert: Boolean; Hide: Boolean); virtual;\r\n procedure ResetChildren(Exclude: TJvDockZone); virtual;\r\n procedure Update; virtual;\r\n function GetFrameRect: TRect; virtual;\r\n procedure SetZoneSize(Size: Integer; Show: Boolean); virtual;\r\n property BeforeClosestVisibleZone: TJvDockZone read GetBeforeClosestVisibleZone;\r\n property AfterClosestVisibleZone: TJvDockZone read GetAfterClosestVisibleZone;\r\n property BeforeApoapsisVisibleZone: TJvDockZone read GetBeforeApoapsisVisibleZone;\r\n property AfterApoapsisVisibleZone: TJvDockZone read GetAfterApoapsisVisibleZone;\r\n property FirstVisibleChildZone: TJvDockZone read GetFirstVisibleChildZone;\r\n property LastVisibleChildZone: TJvDockZone read GetLastVisibleChildZone;\r\n property ChildCount: Integer read GetChildCount;\r\n property ChildTotal: Integer read GetChildTotal;\r\n property ChildZones: TJvDockZone read FChildZones write FChildZones;\r\n property ChildControl: TWinControl read FChildControl write FChildControl;\r\n property FirstChild: TJvDockZone read GetFirstChild;\r\n property FirstSibling: TJvDockZone read GetFirstSibling;\r\n property Height: Integer index Ord(doHorizontal) read GetHeightWidth;\r\n property HeightWidth[Orient: TDockOrientation]: Integer read GetHeightWidthArr;\r\n property LastChild: TJvDockZone read GetLastChild;\r\n property LastSibling: TJvDockZone read GetLastSibling;\r\n property Left: Integer index Ord(doVertical) read GetTopLeft;\r\n property LimitBegin: Integer read GetLimitBegin;\r\n property LimitSize: Integer read GetLimitSize;\r\n property NextSibling: TJvDockZone read FNextSibling write FNextSibling;\r\n property NextSiblingCount: Integer read GetNextSiblingCount;\r\n property Orientation: TDockOrientation read FOrientation write FOrientation;\r\n property ParentZone: TJvDockZone read FParentZone write FParentZone;\r\n property PrevSibling: TJvDockZone read FPrevSibling write FPrevSibling;\r\n property PrevSiblingCount: Integer read GetPrevSiblingCount;\r\n property Top: Integer index Ord(doHorizontal) read GetTopLeft;\r\n property TopLeft[Orient: TDockOrientation]: Integer read GetTopLeftArr;\r\n property Tree: TJvDockTree read FTree;\r\n property VisibleChildCount: Integer read GetVisibleChildCount;\r\n property VisibleChildTotal: Integer read GetVisibleChildTotal;\r\n property VisiblePrevSiblingCount: Integer read GetVisiblePrevSiblingCount;\r\n property VisiblePrevSiblingTotal: Integer read GetVisiblePrevSiblingTotal;\r\n property VisibleNextSiblingCount: Integer read GetVisibleNextSiblingCount;\r\n property VisibleNextSiblingTotal: Integer read GetVisibleNextSiblingTotal;\r\n property VisibleSize: Integer read FVisibleSize write FVisibleSize;\r\n property Width: Integer index Ord(doVertical) read GetHeightWidth;\r\n property ZoneLimit: Integer read FZoneLimit write SetZoneLimit;\r\n property Visibled: Boolean read FVisibled write SetVisibled;\r\n property IsInside: Boolean read FIsInside write SetIsInside;\r\n end;\r\n\r\n TJvDockAdvZone = class(TJvDockZone)\r\n private\r\n FCloseBtnDown: Boolean;\r\n FMouseDown: Boolean;\r\n protected\r\n procedure LButtonDblClkMethod; override;\r\n public\r\n constructor Create(ATree: TJvDockTree); override;\r\n destructor Destroy; override;\r\n procedure Insert(DockSize: Integer; Hide: Boolean); override;\r\n procedure Remove(DockSize: Integer; Hide: Boolean); override;\r\n property CloseBtnDown: Boolean read FCloseBtnDown write FCloseBtnDown;\r\n property MouseDown: Boolean read FMouseDown write FMouseDown;\r\n end;\r\n\r\n TJvDockTreeScanKind = (tskForward, tskMiddle, tskBackward);\r\n TJvDockTreeScanPriority = (tspSibling, tspChild);\r\n TJvDockGrabbersPosition = (gpTop, gpBottom, gpLeft, gpRight);\r\n TJvDockForEachZoneProc = procedure(Zone: TJvDockZone) of object;\r\n TJvDockZoneClass = class of TJvDockZone;\r\n\r\n TJvDockObservableStyle = class;\r\n TJvDockStyleLink = class;\r\n\r\n TJvDockTree = class(TInterfacedObject, IJvDockManager)\r\n private\r\n FDockZoneClass: TJvDockZoneClass;\r\n FBorderWidth: Integer;\r\n FSplitterWidth: Integer;\r\n FBrush: TBrush;\r\n FDockSite: TWinControl;\r\n FPreviousRect: TRect;\r\n FDockRect: TRect;\r\n FOldWndProc: TWndMethod;\r\n FReplacementZone: TJvDockZone;\r\n FResizeCount: Integer;\r\n FScaleBy: Double;\r\n FShiftScaleOrientation: TDockOrientation;\r\n FShiftBy: Integer;\r\n FSizePos: TPoint;\r\n FSizingDC: HDC;\r\n FSizingWnd: THandle;\r\n FSizingZone: TJvDockZone;\r\n FTopZone: TJvDockZone; // <-- Root Node of the tree. What is called Zone in here should really be called TreeNode.\r\n FTopXYLimit: Integer;\r\n FUpdateCount: Integer;\r\n FVersion: Integer;\r\n FOldHTFlag: Integer;\r\n FParentLimit: Integer;\r\n FMinSize: Integer;\r\n FCanvas: TControlCanvas;\r\n FStyleLink: TJvDockStyleLink;\r\n FGrabberSize: Integer; { size of grabber }\r\n FGrabberShowLines: Boolean; {should there be bump-lines to make the grabber look 'grabby'? }\r\n FGrabberBgColor: TColor; // if FGrabberStandardDraw is False, this indicates background color of Grabber.\r\n FGrabberBottomEdgeColor: TColor; // if anything other than clNone, draw a line at bottom edge.\r\n procedure SetTopZone(const Value: TJvDockZone);\r\n procedure SetTopXYLimit(const Value: Integer);\r\n procedure SetDockZoneClass(const Value: TJvDockZoneClass);\r\n function GetDockSplitterWidth: Integer;\r\n function GetBorderWidth: Integer;\r\n procedure SetDockSplitterWidth(const Value: Integer);\r\n procedure SetBorderWidth(const Value: Integer);\r\n function GetDockSiteOrientation: TDockOrientation;\r\n function GetDockSiteSize: Integer;\r\n procedure SetDockSiteSize(const Value: Integer);\r\n procedure SetMinSize(const Value: Integer);\r\n function GetDockSiteBegin: Integer;\r\n procedure SetDockSiteBegin(const Value: Integer);\r\n function GetDockSiteSizeAlternate: Integer;\r\n procedure SetDockSiteSizeAlternate(const Value: Integer);\r\n function GetDockSiteSizeWithOrientation(Orient: TDockOrientation): Integer;\r\n procedure SetDockSiteSizeWithOrientation(Orient: TDockOrientation; const Value: Integer);\r\n function GetDockRect: TRect;\r\n procedure SetDockRect(const Value: TRect);\r\n function GetMinSize: Integer;\r\n function HasZoneWithControl(Control: TControl): Boolean;\r\n procedure DockStyleChanged(Sender: TObject);\r\n function GetDockStyle: TJvDockObservableStyle;\r\n protected\r\n procedure WindowProc(var Msg: TMessage); virtual;\r\n procedure BeginDrag(Control: TControl; Immediate: Boolean; Threshold: Integer = -1); virtual;\r\n function DoMouseEvent(var Msg: TWMMouse; var Zone: TJvDockZone;\r\n out HTFlag: Integer): TWMNCHitMessage; virtual;\r\n procedure DoMouseMove(var Msg: TWMMouse; var Zone: TJvDockZone; out HTFlag: Integer); virtual;\r\n function DoLButtonDown(var Msg: TWMMouse; var Zone: TJvDockZone; out HTFlag: Integer): Boolean; virtual;\r\n procedure DoLButtonUp(var Msg: TWMMouse; var Zone: TJvDockZone; out HTFlag: Integer); virtual;\r\n procedure DoLButtonDbClk(var Msg: TWMMouse; var Zone: TJvDockZone; out HTFlag: Integer); virtual;\r\n procedure DoMButtonDown(var Msg: TWMMouse; var Zone: TJvDockZone; out HTFlag: Integer); virtual;\r\n procedure DoMButtonUp(var Msg: TWMMouse; var Zone: TJvDockZone; out HTFlag: Integer); virtual;\r\n procedure DoMButtonDbClk(var Msg: TWMMouse; var Zone: TJvDockZone; out HTFlag: Integer); virtual;\r\n procedure DoRButtonDown(var Msg: TWMMouse; var Zone: TJvDockZone; out HTFlag: Integer); virtual;\r\n procedure DoRButtonUp(var Msg: TWMMouse; var Zone: TJvDockZone; out HTFlag: Integer); virtual;\r\n procedure DoRButtonDbClk(var Msg: TWMMouse; var Zone: TJvDockZone; out HTFlag: Integer); virtual;\r\n procedure DoHideZoneChild(AZone: TJvDockZone); virtual;\r\n procedure DoSetCursor(var Msg: TWMSetCursor; var Zone: TJvDockZone; out HTFlag: Integer); virtual;\r\n procedure DoHintShow(var Msg: TCMHintShow; var Zone: TJvDockZone; out HTFlag: Integer); virtual;\r\n procedure DoOtherHint(Zone: TJvDockZone; HTFlag: Integer; var HintStr: string); virtual;\r\n procedure CustomSaveZone(Stream: TStream; Zone: TJvDockZone); virtual;\r\n procedure CustomLoadZone(Stream: TStream; var Zone: TJvDockZone); virtual;\r\n procedure DoSaveZone(Stream: TStream; Zone: TJvDockZone; Level: Integer); virtual;\r\n procedure DoLoadZone(Stream: TStream); virtual;\r\n procedure AdjustDockRect(Control: TControl; var ARect: TRect); virtual;\r\n procedure BeginResizeDockSite;\r\n procedure BeginUpdate;\r\n procedure CalcSplitterPos; virtual;\r\n procedure ControlVisibilityChanged(Control: TControl; Visible: Boolean); virtual;\r\n function GetDockAlign(Client: TControl; var DropCtl: TControl): TAlign; virtual;\r\n function DoFindZone(const MousePos: TPoint; out HTFlag: Integer;\r\n Zone: TJvDockZone): TJvDockZone; virtual;\r\n procedure DrawSizeSplitter; virtual;\r\n procedure EndResizeDockSite;\r\n procedure EndUpdate;\r\n function FindControlZone(Control: TControl; IncludeHide: Boolean = False): TJvDockZone; virtual;\r\n function FindControlZoneAndLevel(Control: TControl;\r\n var CtlLevel: Integer; IncludeHide: Boolean = False): TJvDockZone; virtual;\r\n procedure ForEachAt(Zone: TJvDockZone; Proc: TJvDockForEachZoneProc;\r\n ScanKind: TJvDockTreeScanKind = tskForward; ScanPriority: TJvDockTreeScanPriority = tspSibling); virtual;\r\n function GetActiveControl: TControl; virtual;\r\n function GetGrabberSize: Integer; virtual;\r\n function GetBorderHTFlag(const MousePos: TPoint; out HTFlag: Integer;\r\n Zone: TJvDockZone): TJvDockZone; virtual;\r\n function GetLeftGrabbersHTFlag(const MousePos: TPoint; out HTFlag: Integer;\r\n Zone: TJvDockZone): TJvDockZone; virtual;\r\n function GetRightGrabbersHTFlag(const MousePos: TPoint; out HTFlag: Integer;\r\n Zone: TJvDockZone): TJvDockZone; virtual;\r\n function GetTopGrabbersHTFlag(const MousePos: TPoint; out HTFlag: Integer;\r\n Zone: TJvDockZone): TJvDockZone; virtual;\r\n function GetBottomGrabbersHTFlag(const MousePos: TPoint; out HTFlag: Integer;\r\n Zone: TJvDockZone): TJvDockZone; virtual;\r\n function GetDockEdge(DockRect: TRect; MousePos: TPoint; var DropAlign: TAlign;\r\n Control: TControl): TControl; virtual;\r\n function GetDockClientLimit(Orient: TDockOrientation; IsMin: Boolean): Integer; virtual;\r\n function GetFrameRect(Control: TControl): TRect; virtual;\r\n function GetFrameRectEx(Control: TControl): TRect; virtual;\r\n function GetSplitterRect(Zone: TJvDockZone): TRect; virtual;\r\n function GetDockGrabbersPosition: TJvDockGrabbersPosition; virtual;\r\n procedure GetControlBounds(Control: TControl; out CtlBounds: TRect); virtual;\r\n function GetSplitterLimit(AZone: TJvDockZone; IsCurrent, IsMin: Boolean): Integer; virtual;\r\n procedure DoGetNextLimit(Zone, AZone: TJvDockZone; var LimitResult: Integer); virtual;\r\n function GetHTFlag(MousePos: TPoint): Integer; virtual;\r\n procedure GetSiteInfo(Client: TControl;\r\n var InfluenceRect: TRect; MousePos: TPoint; var CanDock: Boolean); virtual;\r\n function HitTest(const MousePos: TPoint; out HTFlag: Integer): TControl; virtual;\r\n function InternalHitTest(const MousePos: TPoint;\r\n out HTFlag: Integer): TJvDockZone; virtual;\r\n procedure InsertControl(Control: TControl; InsertAt: TAlign;\r\n DropCtl: TControl); virtual;\r\n procedure InsertNewParent(NewZone, SiblingZone: TJvDockZone;\r\n ParentOrientation: TDockOrientation; InsertLast, Update: Boolean); virtual;\r\n procedure InsertSibling(NewZone, SiblingZone: TJvDockZone;\r\n InsertLast, Update: Boolean); virtual;\r\n procedure LoadFromStream(Stream: TStream); virtual;\r\n procedure SaveToStream(Stream: TStream); virtual;\r\n procedure PaintDockSite; virtual;\r\n procedure DrawDockSiteRect; virtual;\r\n procedure DrawZone(Zone: TJvDockZone); virtual;\r\n procedure DrawZoneGrabber(Zone: TJvDockZone); virtual;\r\n procedure DrawDockGrabber(Control: TWinControl; const ARect: TRect); virtual;\r\n procedure DrawZoneSplitter(Zone: TJvDockZone); virtual;\r\n procedure DrawSplitterRect(const ARect: TRect); virtual;\r\n procedure DrawZoneBorder(Zone: TJvDockZone); virtual;\r\n procedure DrawDockBorder(DockControl: TControl; R1, R2: TRect); virtual;\r\n procedure GetCaptionRect(var Rect: TRect); virtual;\r\n procedure PositionDockRect(Client, DropCtl: TControl; DropAlign: TAlign; var DockRect: TRect); virtual;\r\n procedure PruneZone(Zone: TJvDockZone); virtual;\r\n procedure RemoveZone(Zone: TJvDockZone; Hide: Boolean = True); virtual;\r\n procedure ScaleZone(Zone: TJvDockZone); virtual;\r\n procedure ScaleChildZone(Zone: TJvDockZone); virtual;\r\n procedure ScaleSiblingZone(Zone: TJvDockZone); virtual;\r\n procedure ShiftZone(Zone: TJvDockZone); virtual;\r\n procedure UpdateZone(Zone: TJvDockZone); virtual;\r\n procedure DrawSplitter(Zone: TJvDockZone); virtual;\r\n procedure RemoveControl(Control: TControl); virtual;\r\n procedure SetActiveControl(const Value: TControl); virtual;\r\n procedure SetGrabberSize(const Value: Integer); virtual;\r\n procedure SetNewBounds(Zone: TJvDockZone); virtual;\r\n procedure SetReplacingControl(Control: TControl);\r\n procedure SplitterMouseDown(OnZone: TJvDockZone; MousePos: TPoint); virtual;\r\n procedure SplitterMouseUp; virtual;\r\n procedure ResetBounds(Force: Boolean); virtual;\r\n procedure WriteControlName(Stream: TStream; const ControlName: string);\r\n procedure ReadControlName(Stream: TStream; var ControlName: string);\r\n procedure ShowControl(Control: TControl);\r\n procedure HideControl(Control: TControl);\r\n procedure ShowAllControl;\r\n procedure HideAllControl;\r\n procedure ShowSingleControl(Control: TControl);\r\n procedure HideSingleControl(Control: TControl);\r\n procedure ReplaceZoneChild(OldControl, NewControl: TControl);\r\n procedure SyncWithStyle; virtual;\r\n property BorderWidth: Integer read GetBorderWidth write SetBorderWidth;\r\n property Canvas: TControlCanvas read FCanvas;\r\n property DockSiteSize: Integer read GetDockSiteSize write SetDockSiteSize;\r\n property DockSiteSizeAlternate: Integer read GetDockSiteSizeAlternate write SetDockSiteSizeAlternate;\r\n property DockSiteBegin: Integer read GetDockSiteBegin write SetDockSiteBegin;\r\n property DockSiteSizeWithOrientation[Orient: TDockOrientation]: Integer\r\n read GetDockSiteSizeWithOrientation write SetDockSiteSizeWithOrientation;\r\n\r\n property GrabberSize: Integer read GetGrabberSize write SetGrabberSize;\r\n property GrabberShowLines: Boolean read FGrabberShowLines write FGrabberShowLines; {should there be bump-lines to make the grabber look 'grabby'? }\r\n property GrabberBgColor: TColor read FGrabberBgColor write FGrabberBgColor; // if FGrabberStandardDraw is False, this indicates background color of Grabber. Set to clNone to skip painting the background.\r\n property GrabberBottomEdgeColor: TColor read FGrabberBottomEdgeColor write FGrabberBottomEdgeColor; // if anything other than clNone, draw a line at bottom edge.\r\n\r\n property GrabbersPosition: TJvDockGrabbersPosition read GetDockGrabbersPosition;\r\n property MinSize: Integer read GetMinSize write SetMinSize;\r\n property DockRect: TRect read GetDockRect write SetDockRect;\r\n property PreviousRect: TRect read FPreviousRect write FPreviousRect;\r\n property ParentLimit: Integer read FParentLimit write FParentLimit;\r\n property ReplacementZone: TJvDockZone read FReplacementZone write FReplacementZone;\r\n property ResizeCount: Integer read FResizeCount write FResizeCount;\r\n property ScaleBy: Double read FScaleBy write FScaleBy;\r\n property ShiftBy: Integer read FShiftBy write FShiftBy;\r\n property ShiftScaleOrientation: TDockOrientation read FShiftScaleOrientation write FShiftScaleOrientation;\r\n property SizePos: TPoint read FSizePos write FSizePos;\r\n property SizingDC: HDC read FSizingDC;\r\n property SizingWnd: THandle read FSizingWnd;\r\n property SizingZone: TJvDockZone read FSizingZone write FSizingZone;\r\n property SplitterWidth: Integer read GetDockSplitterWidth write SetDockSplitterWidth;\r\n property UpdateCount: Integer read FUpdateCount write FUpdateCount;\r\n property Version: Integer read FVersion write FVersion;\r\n\r\n {$IFDEF JVDOCK_DEBUG}\r\n // internal helper functions used recursively from DebugDump:\r\n procedure _ParentDump(LevelsLeft: Integer; AParent: TWinControl; Indent: string; Strs: TStrings);\r\n procedure _PageControlDump(PageControl: TWinControl; Indent: string; Strs: TStrings); {actually TJvDockTabPageControl}\r\n procedure _ControlDump(AControl: TWinControl; Indent: string; Strs: TStrings);\r\n // This helps us to understand the content of the tree by allowing\r\n // us to build a dump:\r\n procedure DebugDump(var Index: Integer; Indent, Entity: string; TreeZone: TJvDockZone; Strs: TStrings); //virtual;\r\n {$ENDIF JVDOCK_DEBUG}\r\n\r\n {$IFDEF JVDOCK_QUERY}\r\n procedure _ParentQuery( LevelsLeft:Integer; AParent:TWinControl; FoundItems:TList );\r\n procedure _PageControlQuery(PageControl: TWinControl; FoundItems:TList); {actually TJvDockTabPageControl}\r\n procedure _ControlQuery( AControl:TWinControl; FoundItems:TList);\r\n procedure DoControlQuery(TreeZone: TJvDockZone; FoundItems:TList); //virtual;\r\n {$ENDIF JVDOCK_QUERY}\r\n public\r\n {$IFDEF JVDOCK_DEBUG}\r\n // A top level call for end user to call, which calls\r\n // DebugDump in turn:\r\n procedure Debug(BasePropertyName: string; Strs: TStrings);\r\n {$ENDIF JVDOCK_DEBUG}\r\n {$IFDEF JVDOCK_QUERY}\r\n // Descends the Tree and Finds and return TWinControls docked to a particular parent.\r\n procedure ControlQuery(DockedTo: TWinControl; FoundItems: TList);\r\n {$ENDIF JVDOCK_QUERY}\r\n constructor Create(ADockSite: TWinControl; ADockZoneClass: TJvDockZoneClass; ADockStyle: TJvDockObservableStyle); virtual;\r\n destructor Destroy; override;\r\n procedure AfterConstruction; override;\r\n procedure SetSplitterCursor(CursorIndex: TDockOrientation); virtual;\r\n procedure PaintSite(DC: HDC); virtual;\r\n procedure UpdateAll;\r\n procedure UpdateChild(Zone: TJvDockZone);\r\n\r\n property DockSite: TWinControl read FDockSite write FDockSite;\r\n property DockSiteOrientation: TDockOrientation read GetDockSiteOrientation;\r\n property TopXYLimit: Integer read FTopXYLimit write SetTopXYLimit;\r\n property TopZone: TJvDockZone read FTopZone write SetTopZone; // ROOT NODE!\r\n property DockZoneClass: TJvDockZoneClass read FDockZoneClass write SetDockZoneClass;\r\n property DockStyle: TJvDockObservableStyle read GetDockStyle;\r\n end;\r\n\r\n TJvDockTreeClass = class of TJvDockTree;\r\n TJvDockBasicConjoinServerOptionClass = class of TJvDockBasicConjoinServerOption;\r\n TJvDockBasicTabServerOptionClass = class of TJvDockBasicTabServerOption;\r\n\r\n { Maintained by a TJvDockBasicStyle ancestor. That ancestor ensures that\r\n FDockStyle is set (to itself) }\r\n TJvDockBasicServerOption = class(TPersistent)\r\n private\r\n FDockStyle: TJvDockObservableStyle;\r\n FUpdateCount: Integer;\r\n FIsChanged: Boolean;\r\n protected\r\n procedure Changed; virtual;\r\n property DockStyle: TJvDockObservableStyle read FDockStyle;\r\n public\r\n constructor Create(ADockStyle: TJvDockObservableStyle); virtual;\r\n procedure Assign(Source: TPersistent); override;\r\n procedure BeginUpdate;\r\n procedure EndUpdate;\r\n end;\r\n\r\n TJvDockGrabbersSize = 1..MaxInt;\r\n TJvDockSplitterWidth = 1..MaxInt;\r\n\r\n TJvDockBasicConjoinServerOption = class(TJvDockBasicServerOption)\r\n private\r\n FGrabbersSize: TJvDockGrabbersSize;\r\n FSplitterWidth: TJvDockSplitterWidth;\r\n protected\r\n procedure SetGrabbersSize(const Value: TJvDockGrabbersSize);\r\n procedure SetDockSplitterWidth(const Value: TJvDockSplitterWidth);\r\n public\r\n constructor Create(ADockStyle: TJvDockObservableStyle); override;\r\n procedure Assign(Source: TPersistent); override;\r\n published\r\n property GrabbersSize: TJvDockGrabbersSize read FGrabbersSize write SetGrabbersSize default 12;\r\n property SplitterWidth: TJvDockSplitterWidth read FSplitterWidth write SetDockSplitterWidth default 4;\r\n end;\r\n\r\n TJvDockBasicTabServerOption = class(TJvDockBasicServerOption)\r\n private\r\n FTabPosition: TTabPosition;\r\n FHotTrack: Boolean;\r\n protected\r\n procedure SetTabPosition(const Value: TTabPosition); virtual;\r\n procedure SetHotTrack(const Value: Boolean); virtual;\r\n public\r\n constructor Create(ADockStyle: TJvDockObservableStyle); override;\r\n procedure Assign(Source: TPersistent); override;\r\n published\r\n property HotTrack: Boolean read FHotTrack write SetHotTrack default False;\r\n property TabPosition: TTabPosition read FTabPosition write SetTabPosition default tpTop;\r\n end;\r\n\r\n TJvDockStyleLink = class\r\n private\r\n FDockStyle: TJvDockObservableStyle;\r\n FOnStyleChanged: TNotifyEvent;\r\n procedure SetDockStyle(ADockStyle: TJvDockObservableStyle);\r\n public\r\n destructor Destroy; override;\r\n procedure StyleChanged;\r\n property DockStyle: TJvDockObservableStyle read FDockStyle write SetDockStyle;\r\n property OnStyleChanged: TNotifyEvent read FOnStyleChanged write FOnStyleChanged;\r\n end;\r\n\r\n TJvDockObservableStyle = class(TJvComponent)\r\n private\r\n FConjoinServerOptionClass: TJvDockBasicConjoinServerOptionClass;\r\n FTabServerOptionClass: TJvDockBasicTabServerOptionClass;\r\n FConjoinServerOption: TJvDockBasicConjoinServerOption;\r\n FTabServerOption: TJvDockBasicTabServerOption;\r\n FLinks: TList;\r\n procedure SetConjoinServerOption(Value: TJvDockBasicConjoinServerOption); //virtual;\r\n procedure SetTabServerOption(Value: TJvDockBasicTabServerOption);\r\n protected\r\n procedure CreateServerOption; virtual;\r\n procedure FreeServerOption; virtual;\r\n\r\n procedure AddLink(ALink: TJvDockStyleLink);\r\n procedure RemoveLink(ALink: TJvDockStyleLink);\r\n\r\n procedure Changed;\r\n procedure SendStyleEvent;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n\r\n procedure AfterConstruction; override;\r\n\r\n property ConjoinServerOptionClass: TJvDockBasicConjoinServerOptionClass read FConjoinServerOptionClass\r\n write FConjoinServerOptionClass;\r\n property TabServerOptionClass: TJvDockBasicTabServerOptionClass read FTabServerOptionClass\r\n write FTabServerOptionClass;\r\n property ConjoinServerOption: TJvDockBasicConjoinServerOption read FConjoinServerOption\r\n write SetConjoinServerOption;\r\n property TabServerOption: TJvDockBasicTabServerOption read FTabServerOption write SetTabServerOption;\r\n end;\r\n\r\n// (rom) made typed const to allow SizeOf\r\nconst\r\n TreeStreamEndFlag: Integer = -1;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvDockTree.pas $';\r\n Revision: '$Revision: 13180 $';\r\n Date: '$Date: 2011-11-22 13:45:23 +0100 (mar. 22 nov. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n Types,\r\n {$IFDEF JVCLThemesEnabled}\r\n JvThemes,\r\n {$ENDIF JVCLThemesEnabled}\r\n Consts, SysUtils, Math,\r\n JvDockControlForm, JvDockSupportProc, JvDockGlobals, JvDockVSNetStyle,\r\n JvDockAdvTree;\r\n\r\ntype\r\n TWinControlAccessProtected = class(TWinControl);\r\n\r\n{$IFNDEF UNICODE}\r\nfunction UTF8ToString(const S: UTF8String): string; // also declared in JvJCLUtils\r\nbegin\r\n Result := UTF8Decode(S);\r\nend;\r\n{$ENDIF ~UNICODE}\r\n\r\n//=== { TJvDockZone } ========================================================\r\n\r\nconstructor TJvDockZone.Create(ATree: TJvDockTree);\r\nbegin\r\n ParentZone := nil;\r\n PrevSibling := nil;\r\n NextSibling := nil;\r\n ChildZones := nil;\r\n ChildControl := nil;\r\n FTree := ATree;\r\n FVisibled := True;\r\nend;\r\n\r\nfunction TJvDockZone.GetChildCount: Integer;\r\nvar\r\n Zone: TJvDockZone;\r\nbegin\r\n Result := 0;\r\n Zone := ChildZones;\r\n while Zone <> nil do\r\n begin\r\n Zone := Zone.NextSibling;\r\n Inc(Result);\r\n end;\r\nend;\r\n\r\nfunction TJvDockZone.GetLimitBegin: Integer;\r\nvar\r\n CheckZone: TJvDockZone;\r\nbegin\r\n if FTree.FTopZone = Self then\r\n CheckZone := Self\r\n else\r\n CheckZone := FParentZone;\r\n if CheckZone.Orientation = doHorizontal then\r\n Result := Top\r\n else\r\n if CheckZone.Orientation = doVertical then\r\n Result := Left\r\n else\r\n Result := 0;\r\nend;\r\n\r\nfunction TJvDockZone.GetLimitSize: Integer;\r\nvar\r\n CheckZone: TJvDockZone;\r\nbegin\r\n if FTree.FTopZone = Self then\r\n CheckZone := Self\r\n else\r\n CheckZone := FParentZone;\r\n if CheckZone.Orientation = doHorizontal then\r\n Result := Height\r\n else\r\n if CheckZone.Orientation = doVertical then\r\n Result := Width\r\n else\r\n Result := Tree.TopXYLimit;\r\nend;\r\n\r\nfunction TJvDockZone.GetTopLeft(Orient: Integer): Integer;\r\nvar\r\n Zone: TJvDockZone;\r\n R: TRect;\r\nbegin\r\n Zone := Self;\r\n while Zone <> FTree.FTopZone do\r\n begin\r\n if (Zone.VisiblePrevSiblingCount > 0) and (Zone.ParentZone.Orientation = TDockOrientation(Orient)) then\r\n begin\r\n Result := Zone.BeforeClosestVisibleZone.ZoneLimit;\r\n Exit;\r\n end\r\n else\r\n Zone := Zone.ParentZone;\r\n end;\r\n R := FTree.FDockSite.ClientRect;\r\n TWinControlAccessProtected(FTree.FDockSite).AdjustClientRect(R);\r\n case TDockOrientation(Orient) of\r\n doVertical:\r\n Result := R.Left;\r\n doHorizontal:\r\n Result := R.Top;\r\n else\r\n Result := 0;\r\n end;\r\nend;\r\n\r\nfunction TJvDockZone.GetHeightWidth(Orient: Integer): Integer;\r\nvar\r\n Zone: TJvDockZone;\r\n R: TRect;\r\nbegin\r\n if (Self = FTree.FTopZone) or ((FParentZone = FTree.FTopZone) and\r\n (ChildControl <> nil) and (FTree.FTopZone.ChildCount = 1)) then\r\n begin\r\n R := FTree.FDockSite.ClientRect;\r\n TWinControlAccessProtected(FTree.FDockSite).AdjustClientRect(R);\r\n if TDockOrientation(Orient) = doHorizontal then\r\n Result := R.Bottom - R.Top\r\n else\r\n Result := R.Right - R.Left;\r\n end\r\n else\r\n begin\r\n Zone := Self;\r\n while (Zone <> FTree.FTopZone) and (Zone.ParentZone <> nil) do\r\n begin\r\n if Zone.ParentZone.Orientation = TDockOrientation(Orient) then\r\n begin\r\n Result := Zone.ZoneLimit - Zone.LimitBegin;\r\n Exit;\r\n end\r\n else\r\n Zone := Zone.ParentZone;\r\n end;\r\n if FTree.FTopZone.Orientation = TDockOrientation(Orient) then\r\n Result := FTree.TopXYLimit\r\n else\r\n Result := FTree.FTopZone.ZoneLimit;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockZone.ResetChildren(Exclude: TJvDockZone);\r\nvar\r\n SumLimit: Integer;\r\n NewLimit: Integer;\r\n FirstChildBegin: Integer;\r\n OldPrevLimit: Integer;\r\n ChildNode: TJvDockZone;\r\n PrevNode: TJvDockZone;\r\nbegin\r\n case Orientation of\r\n doHorizontal:\r\n NewLimit := Height;\r\n doVertical:\r\n NewLimit := Width;\r\n else\r\n Exit;\r\n end;\r\n\r\n ChildNode := FirstVisibleChildZone;\r\n if ChildNode = nil then\r\n Exit;\r\n\r\n SumLimit := NewLimit;\r\n NewLimit := NewLimit div VisibleChildCount;\r\n\r\n FirstChildBegin := ChildNode.LimitBegin;\r\n\r\n Tree.ShiftScaleOrientation := Orientation;\r\n Tree.ParentLimit := 0;\r\n if ChildNode.ZoneLimit - FirstChildBegin > 0 then\r\n Tree.ScaleBy := NewLimit / (ChildNode.ZoneLimit - FirstChildBegin)\r\n else\r\n Tree.ScaleBy := 1;\r\n if (Tree.ScaleBy <> 1) and (ChildNode.VisibleChildCount > 0) then\r\n Tree.ForEachAt(ChildNode.ChildZones, Tree.ScaleChildZone, tskMiddle, tspChild);\r\n\r\n if ChildNode <> Exclude then\r\n OldPrevLimit := ChildNode.ZoneLimit\r\n else\r\n OldPrevLimit := FirstChildBegin;\r\n\r\n ChildNode.ZoneLimit := FirstChildBegin + NewLimit;\r\n ChildNode.Update;\r\n\r\n PrevNode := ChildNode;\r\n ChildNode := ChildNode.AfterClosestVisibleZone;\r\n\r\n while ChildNode <> nil do\r\n begin\r\n if ChildNode.ZoneLimit - OldPrevLimit > 0 then\r\n Tree.ScaleBy := NewLimit / (ChildNode.ZoneLimit - OldPrevLimit)\r\n else\r\n Tree.ScaleBy := 1;\r\n\r\n Tree.ShiftBy := PrevNode.ZoneLimit - OldPrevLimit;\r\n if (Tree.ShiftBy <> 0) and (ChildNode.VisibleChildCount > 0) then\r\n Tree.ForEachAt(ChildNode.ChildZones, Tree.ShiftZone, tskForward);\r\n\r\n Tree.ParentLimit := PrevNode.ZoneLimit;\r\n\r\n if (Tree.ScaleBy <> 1) and (ChildNode.VisibleChildCount > 0) then\r\n Tree.ForEachAt(ChildNode.ChildZones, Tree.ScaleChildZone, tskForward);\r\n\r\n if ChildNode <> Exclude then\r\n OldPrevLimit := ChildNode.ZoneLimit;\r\n\r\n ChildNode.ZoneLimit := PrevNode.ZoneLimit + NewLimit;\r\n\r\n if ChildNode.AfterClosestVisibleZone = nil then\r\n begin\r\n if NewLimit = 0 then\r\n NewLimit := 1;\r\n ChildNode.ZoneLimit := ChildNode.ZoneLimit + (SumLimit mod NewLimit);\r\n end;\r\n ChildNode.Update;\r\n PrevNode := ChildNode;\r\n ChildNode := ChildNode.AfterClosestVisibleZone;\r\n end;\r\nend;\r\n\r\nfunction TJvDockZone.GetControlName: string;\r\nbegin\r\n Result := '';\r\n if ChildControl <> nil then\r\n begin\r\n if ChildControl.Name = '' then\r\n raise Exception.CreateRes(@SDockedCtlNeedsName);\r\n Result := ChildControl.Name;\r\n end;\r\nend;\r\n\r\nfunction TJvDockZone.SetControlName(const Value: string): Boolean;\r\nvar\r\n Client: TControl;\r\nbegin\r\n Client := nil;\r\n with FTree do\r\n begin\r\n TWinControlAccessProtected(FDockSite).ReloadDockedControl(Value, Client);\r\n Result := Client <> nil;\r\n if Result then\r\n begin\r\n FReplacementZone := Self;\r\n ChildControl := TWinControl(Client);\r\n DoCustomSetControlName;\r\n try\r\n if IsInside then\r\n Client.ManualDock(FDockSite, nil, alNone);\r\n finally\r\n SetChildControlVisible(Client, FControlVisibled);\r\n FReplacementZone := nil;\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockZone.Update;\r\nvar\r\n NewWidth, NewHeight: Integer;\r\n R: TRect;\r\n\r\n function ParentNotLast: Boolean;\r\n var\r\n Parent: TJvDockZone;\r\n begin\r\n Result := False;\r\n Parent := FParentZone;\r\n while Parent <> nil do\r\n begin\r\n if (Parent.VisibleNextSiblingCount > 0) and (Parent.Orientation = ParentZone.Orientation) then\r\n begin\r\n Result := True;\r\n Exit;\r\n end;\r\n Parent := Parent.FParentZone;\r\n end;\r\n end;\r\n\r\nbegin\r\n if Visibled and (ChildControl <> nil) and (FTree.FUpdateCount = 0) then\r\n begin\r\n { (rb) It is possible that ChildControl points to a control that is\r\n already destroyed. This can happen when Tree.RemoveControl is not\r\n called for this control.\r\n\r\n This is possible when the host docksite is marked as destroying when\r\n the ChildControl is destroyed (See TControl.Destroy) thus no\r\n CM_UNDOCKCLIENT message is processed. Normally the tree&zones are\r\n destroyed as soon as the host docksite is beginning to destroy; but\r\n a host docksite can be marked earlier as destroying when its parent\r\n is destroying. (This looks like a VCL bug)\r\n\r\n Don't know a good way to catch this but checking whether the host\r\n docksite is destroying before accessing ChildControl is a work-around.\r\n }\r\n if csDestroying in FTree.FDockSite.ComponentState then\r\n Exit;\r\n ChildControl.DockOrientation := FParentZone.Orientation;\r\n NewWidth := Width;\r\n NewHeight := Height;\r\n if ParentNotLast then\r\n if FParentZone.Orientation = doHorizontal then\r\n Dec(NewWidth, FTree.SplitterWidth)\r\n else\r\n Dec(NewHeight, FTree.SplitterWidth);\r\n\r\n if ((NextSibling <> nil) and (VisibleNextSiblingTotal > 0)) or ((FParentZone <> FTree.FTopZone) and\r\n ((FParentZone.Orientation = FTree.FTopZone.Orientation) and\r\n (FZoneLimit < FTree.TopXYLimit)) or\r\n ((FParentZone.Orientation <> FTree.FTopZone.Orientation) and\r\n (FZoneLimit < FTree.FTopZone.ZoneLimit))) then\r\n if FParentZone.Orientation = doHorizontal then\r\n Dec(NewHeight, FTree.SplitterWidth)\r\n else\r\n Dec(NewWidth, FTree.SplitterWidth);\r\n R := Bounds(Left, Top, NewWidth, NewHeight);\r\n FTree.AdjustDockRect(ChildControl, R);\r\n ChildControl.BoundsRect := R;\r\n end;\r\nend;\r\n\r\nfunction TJvDockZone.GetFrameRect: TRect;\r\nvar\r\n ALeft, ATop, ARight, ABottom, BorderWidth: Integer;\r\nbegin\r\n ALeft := Left;\r\n ATop := Top;\r\n if NextSibling <> nil then\r\n BorderWidth := Tree.BorderWidth\r\n else\r\n BorderWidth := 0;\r\n ARight := ALeft + Width - BorderWidth;\r\n ABottom := ATop + Height - BorderWidth;\r\n Result := Rect(ALeft, ATop, ARight, ABottom);\r\nend;\r\n\r\nfunction TJvDockZone.GetFirstSibling: TJvDockZone;\r\nbegin\r\n Result := Self;\r\n while Result.PrevSibling <> nil do\r\n Result := Result.PrevSibling;\r\nend;\r\n\r\nfunction TJvDockZone.GetLastSibling: TJvDockZone;\r\nbegin\r\n Result := Self;\r\n while (Result <> nil) and (Result.NextSibling <> nil) do\r\n Result := Result.NextSibling;\r\nend;\r\n\r\nfunction TJvDockZone.GetFirstChild: TJvDockZone;\r\nbegin\r\n Result := ChildZones;\r\nend;\r\n\r\nfunction TJvDockZone.GetLastChild: TJvDockZone;\r\nbegin\r\n Result := ChildZones;\r\n if Result <> nil then\r\n Result := Result.LastSibling;\r\nend;\r\n\r\nfunction TJvDockZone.GetTopLeftArr(Orient: TDockOrientation): Integer;\r\nbegin\r\n case Orient of\r\n doHorizontal:\r\n Result := Top;\r\n doVertical:\r\n Result := Left;\r\n else\r\n Result := 0;\r\n end;\r\nend;\r\n\r\nfunction TJvDockZone.GetHeightWidthArr(Orient: TDockOrientation): Integer;\r\nbegin\r\n case Orient of\r\n doHorizontal:\r\n Result := Height;\r\n doVertical:\r\n Result := Width;\r\n else\r\n Result := 0;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockZone.AdjustZoneLimit(Value: Integer);\r\nbegin\r\n FZoneLimit := Value;\r\n if PrevSibling <> nil then\r\n PrevSibling.ZoneLimit := PrevSibling.ZoneLimit + Value;\r\nend;\r\n\r\nprocedure TJvDockZone.SetZoneSize(Size: Integer; Show: Boolean);\r\nbegin\r\n InsertOrRemove(Size, Show, False);\r\nend;\r\n\r\nprocedure TJvDockZone.InsertOrRemove(DockSize: Integer; Insert: Boolean; Hide: Boolean);\r\nbegin\r\nend;\r\n\r\nprocedure TJvDockZone.Insert(DockSize: Integer; Hide: Boolean);\r\nbegin\r\n InsertOrRemove(DockSize, True, Hide);\r\n\r\n if (ParentZone <> nil) and (ParentZone.VisibleChildCount = 0) then\r\n ParentZone.Insert(ParentZone.VisibleSize, Hide);\r\n\r\n Visibled := True;\r\n if ParentZone <> nil then\r\n ParentZone.ResetChildren(Self);\r\n\r\n Tree.SetNewBounds(ParentZone);\r\n Tree.UpdateChild(ParentZone);\r\nend;\r\n\r\nprocedure TJvDockZone.Remove(DockSize: Integer; Hide: Boolean);\r\nvar\r\n Zone: TJvDockZone;\r\nbegin\r\n InsertOrRemove(DockSize, False, Hide);\r\n\r\n Visibled := not Hide;\r\n\r\n if (ParentZone <> Tree.TopZone) and (ParentZone.VisibleChildCount = 0) then\r\n ParentZone.Remove(ParentZone.LimitSize, Hide);\r\n\r\n if AfterClosestVisibleZone = nil then\r\n begin\r\n Zone := BeforeClosestVisibleZone;\r\n if Zone <> nil then\r\n begin\r\n Zone.ZoneLimit := ZoneLimit;\r\n Tree.SetNewBounds(Zone);\r\n end;\r\n end;\r\n\r\n ZoneLimit := LimitBegin;\r\nend;\r\n\r\nfunction TJvDockZone.GetVisibleChildCount: Integer;\r\nvar\r\n Zone: TJvDockZone;\r\nbegin\r\n Result := 0;\r\n Zone := ChildZones;\r\n while Zone <> nil do\r\n begin\r\n if Zone.Visibled then\r\n Inc(Result);\r\n Zone := Zone.NextSibling;\r\n end;\r\nend;\r\n\r\nfunction TJvDockZone.GetChildTotal: Integer;\r\n\r\n procedure DoFindChildCount(Zone: TJvDockZone);\r\n begin\r\n if Zone <> nil then\r\n begin\r\n DoFindChildCount(Zone.NextSibling);\r\n DoFindChildCount(Zone.ChildZones);\r\n Inc(Result);\r\n end;\r\n end;\r\n\r\nbegin\r\n Result := 0;\r\n DoFindChildCount(ChildZones);\r\nend;\r\n\r\nfunction TJvDockZone.GetVisibleChildTotal: Integer;\r\n\r\n procedure DoFindVisibleChildCount(Zone: TJvDockZone);\r\n begin\r\n if Zone <> nil then\r\n begin\r\n DoFindVisibleChildCount(Zone.NextSibling);\r\n DoFindVisibleChildCount(Zone.ChildZones);\r\n if Zone.Visibled then\r\n Inc(Result);\r\n end;\r\n end;\r\n\r\nbegin\r\n Result := 0;\r\n DoFindVisibleChildCount(ChildZones);\r\nend;\r\n\r\nfunction TJvDockZone.GetAfterClosestVisibleZone: TJvDockZone;\r\nbegin\r\n Result := NextSibling;\r\n while Result <> nil do\r\n begin\r\n if Result.Visibled then\r\n Break;\r\n Result := Result.NextSibling;\r\n end;\r\nend;\r\n\r\nfunction TJvDockZone.GetBeforeClosestVisibleZone: TJvDockZone;\r\nbegin\r\n Result := PrevSibling;\r\n while Result <> nil do\r\n begin\r\n if Result.Visibled then\r\n Break;\r\n Result := Result.PrevSibling;\r\n end;\r\nend;\r\n\r\nfunction TJvDockZone.GetAfterApoapsisVisibleZone: TJvDockZone;\r\nbegin\r\n Result := LastSibling;\r\n if Result <> nil then\r\n Result := Result.BeforeClosestVisibleZone;\r\n if Self = Result then\r\n Result := nil;\r\nend;\r\n\r\nfunction TJvDockZone.GetBeforeApoapsisVisibleZone: TJvDockZone;\r\nbegin\r\n Result := ParentZone.ChildZones;\r\n if Result <> Self then\r\n Result := Result.AfterClosestVisibleZone;\r\n if Self = Result then\r\n Result := nil;\r\nend;\r\n\r\nfunction TJvDockZone.GetNextSiblingCount: Integer;\r\nvar\r\n AZone: TJvDockZone;\r\nbegin\r\n Result := 0;\r\n AZone := NextSibling;\r\n while AZone <> nil do\r\n begin\r\n Inc(Result);\r\n AZone := AZone.NextSibling;\r\n end;\r\nend;\r\n\r\nfunction TJvDockZone.GetPrevSiblingCount: Integer;\r\nvar\r\n AZone: TJvDockZone;\r\nbegin\r\n Result := 0;\r\n AZone := PrevSibling;\r\n while AZone <> nil do\r\n begin\r\n Inc(Result);\r\n AZone := AZone.PrevSibling;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockZone.SetVisibled(const Value: Boolean);\r\nbegin\r\n FVisibled := Value;\r\n if (not FVisibled) and (Self <> Tree.TopZone) then\r\n if ParentZone.Orientation = doNoOrient then\r\n VisibleSize := Tree.TopXYLimit\r\n else\r\n VisibleSize := LimitSize;\r\nend;\r\n\r\nfunction TJvDockZone.GetVisibleNextSiblingCount: Integer;\r\nvar\r\n Zone: TJvDockZone;\r\nbegin\r\n Result := 0;\r\n Zone := NextSibling;\r\n while Zone <> nil do\r\n begin\r\n if Zone.Visibled then\r\n Inc(Result);\r\n Zone := Zone.NextSibling;\r\n end;\r\nend;\r\n\r\nfunction TJvDockZone.GetVisibleNextSiblingTotal: Integer;\r\n\r\n procedure DoFindVisibleNextSiblingCount(Zone: TJvDockZone);\r\n begin\r\n if Zone <> nil then\r\n begin\r\n DoFindVisibleNextSiblingCount(Zone.NextSibling);\r\n DoFindVisibleNextSiblingCount(Zone.ChildZones);\r\n if Zone.Visibled then\r\n Inc(Result);\r\n end;\r\n end;\r\n\r\nbegin\r\n Result := 0;\r\n DoFindVisibleNextSiblingCount(NextSibling);\r\nend;\r\n\r\nfunction TJvDockZone.GetVisiblePrevSiblingCount: Integer;\r\nvar\r\n Zone: TJvDockZone;\r\nbegin\r\n Result := 0;\r\n Zone := PrevSibling;\r\n while Zone <> nil do\r\n begin\r\n if Zone.Visibled then\r\n Inc(Result);\r\n Zone := Zone.PrevSibling;\r\n end;\r\nend;\r\n\r\nfunction TJvDockZone.GetVisiblePrevSiblingTotal: Integer;\r\n\r\n procedure DoFindVisibleNextSiblingCount(Zone: TJvDockZone);\r\n begin\r\n if (Zone <> nil) and (Zone <> Self) then\r\n begin\r\n DoFindVisibleNextSiblingCount(Zone.NextSibling);\r\n DoFindVisibleNextSiblingCount(Zone.ChildZones);\r\n if Zone.Visibled then\r\n Inc(Result);\r\n end;\r\n end;\r\n\r\nbegin\r\n Result := 0;\r\n DoFindVisibleNextSiblingCount(ParentZone);\r\nend;\r\n\r\nprocedure TJvDockZone.SetZoneLimit(const Value: Integer);\r\nbegin\r\n FZoneLimit := Value;\r\nend;\r\n\r\nfunction TJvDockZone.GetFirstVisibleChildZone: TJvDockZone;\r\nbegin\r\n Result := ChildZones;\r\n while (Result <> nil) and (not Result.Visibled) do\r\n Result := Result.NextSibling;\r\nend;\r\n\r\nfunction TJvDockZone.GetSplitterLimit(IsMin: Boolean): Integer;\r\nbegin\r\n if IsMin then\r\n Result := ZoneLimit\r\n else\r\n Result := LimitBegin;\r\n\r\n if ChildZones <> nil then\r\n ChildZones.DoGetSplitterLimit(ParentZone.Orientation, IsMin, Result);\r\nend;\r\n\r\nfunction TJvDockZone.DoGetSplitterLimit(Orientation: TDockOrientation;\r\n IsMin: Boolean; var LimitResult: Integer): Integer;\r\nbegin\r\n Result := 0;\r\n if (ParentZone <> nil) and (ParentZone.Orientation = Orientation) and Visibled then\r\n if IsMin then\r\n LimitResult := Min(LimitResult, ZoneLimit)\r\n else\r\n if AfterClosestVisibleZone <> nil then\r\n LimitResult := Max(LimitResult, ZoneLimit);\r\n\r\n if NextSibling <> nil then\r\n NextSibling.DoGetSplitterLimit(Orientation, IsMin, LimitResult);\r\n\r\n if ChildZones <> nil then\r\n ChildZones.DoGetSplitterLimit(Orientation, IsMin, LimitResult);\r\nend;\r\n\r\nfunction TJvDockZone.GetLastVisibleChildZone: TJvDockZone;\r\nvar\r\n Zone: TJvDockZone;\r\nbegin\r\n Result := nil;\r\n Zone := ChildZones;\r\n while (Zone <> nil) and Zone.Visibled do\r\n begin\r\n Result := Zone;\r\n Zone := Zone.NextSibling;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockZone.DoCustomSetControlName;\r\nbegin\r\nend;\r\n\r\nprocedure TJvDockZone.LButtonDblClkMethod;\r\nbegin\r\n if ChildControl <> nil then\r\n ChildControl.ManualDock(nil, nil, alTop);\r\nend;\r\n\r\nprocedure TJvDockZone.SetIsInside(const Value: Boolean);\r\nbegin\r\n FIsInside := Value;\r\nend;\r\n\r\nprocedure TJvDockZone.SetChildControlVisible(Client: TControl; AVisible: Boolean);\r\nbegin\r\n if Client <> nil then\r\n Client.Visible := FControlVisibled;\r\nend;\r\n\r\n//=== { TJvDockTree } ========================================================\r\n\r\nconstructor TJvDockTree.Create(ADockSite: TWinControl;\r\n ADockZoneClass: TJvDockZoneClass; ADockStyle: TJvDockObservableStyle);\r\nvar\r\n I: Integer;\r\nbegin\r\n // (rom) added inherited Create\r\n inherited Create;\r\n // (rom) Canvas now always existent\r\n FCanvas := TControlCanvas.Create;\r\n FStyleLink := TJvDockStyleLink.Create;\r\n { First set DockStyle then OnStyleChanged so no OnStyleChanged is fired;\r\n we do it ourself in AfterContruction }\r\n FStyleLink.DockStyle := ADockStyle;\r\n FStyleLink.OnStyleChanged := DockStyleChanged;\r\n FDockZoneClass := ADockZoneClass;\r\n FBorderWidth := 0;\r\n FSplitterWidth := 4;\r\n FDockSite := ADockSite;\r\n FGrabberSize := 18; {Default Grabber Height}\r\n\r\n FDockSite.ShowHint := True;\r\n FVersion := RsDockBaseDockTreeVersion;\r\n\r\n FMinSize := 12;\r\n FTopZone := FDockZoneClass.Create(Self);\r\n FBrush := TBrush.Create;\r\n FBrush.Bitmap := AllocPatternBitmap(clBlack, clWhite);\r\n\r\n FGrabberBgColor := clBtnFace; // default grabber color.\r\n FGrabberShowLines := True;\r\n FGrabberBottomEdgeColor := clBtnShadow; // Dark gray, usually.\r\n\r\n BeginUpdate;\r\n try\r\n for I := 0 to DockSite.ControlCount - 1 do\r\n InsertControl(DockSite.Controls[I], alLeft, nil);\r\n FTopZone.ResetChildren(nil);\r\n finally\r\n EndUpdate;\r\n end;\r\n if not (csDesigning in DockSite.ComponentState) then\r\n begin\r\n FOldWndProc := FDockSite.WindowProc;\r\n FDockSite.WindowProc := WindowProc;\r\n end;\r\nend;\r\n\r\ndestructor TJvDockTree.Destroy;\r\nbegin\r\n FStyleLink.Free;\r\n\r\n if Assigned(FOldWndProc) then\r\n FDockSite.WindowProc := FOldWndProc;\r\n PruneZone(FTopZone);\r\n FBrush.Free;\r\n inherited Destroy;\r\n // (rom) free a Canvas always AFTER inherited Destroy\r\n FCanvas.Free;\r\nend;\r\n\r\n{$IFDEF JVDOCK_DEBUG}\r\n\r\nprocedure TJvDockTree.Debug(BasePropertyName: string; Strs: TStrings);\r\nvar\r\n N: Integer;\r\nbegin\r\n Assert(Assigned(Strs));\r\n Strs.Clear;\r\n N := 0;\r\n DebugDump(N, '', BasePropertyName, TopZone, Strs);\r\n if (Strs.Count = 0) or (N = 0) then\r\n Strs.Add('This tree is empty');\r\nend;\r\n\r\n//XXX Helper routines for DebugDump: XXX\r\n\r\nprocedure TJvDockTree._ParentDump(LevelsLeft: Integer; AParent: TWinControl; Indent: string; Strs: TStrings);\r\nvar\r\n DockServer: TJvDockServer;\r\n LClassName, LName: string;\r\n\r\n procedure Write(S: string);\r\n begin\r\n Strs.Add(S);\r\n end;\r\n\r\nbegin\r\n if Assigned(AParent) then\r\n begin\r\n LClassName := AParent.ClassName;\r\n LName := AParent.Name;\r\n Write(Indent + ' ');\r\n Write(Indent + ' ' + LClassName + '');\r\n Write(Indent + ' ' + LName + '@' + IntToHex(LPARAM(AParent), 2 * SizeOf(LPARAM)) + '');\r\n if AParent is TJvDockPanel then\r\n begin\r\n DockServer := TJvDockPanel(AParent).DockServer;\r\n if Assigned(DockServer) then\r\n Write(Indent + ' ' + DockServer.Name + '')\r\n else\r\n Write(Indent + ' TJvDockPanel has no DockServer');\r\n end;\r\n // recurse down:\r\n if (LevelsLeft > 0) then\r\n if AParent.Parent <> AParent then // don't show controls where they are their own parent!\r\n _ParentDump(LevelsLeft - 1, AParent.Parent, Indent + ' ', Strs);\r\n Write(Indent + ' ');\r\n end;\r\nend;\r\n\r\nprocedure TJvDockTree._PageControlDump(PageControl: TWinControl; Indent: string; Strs: TStrings); {actually TJvDockTabPageControl}\r\nvar\r\n I, J, Count: Integer;\r\n PageID: string;\r\n LPageControl: TJvDockTabPageControl;\r\n LClassName, LName: string;\r\n\r\n procedure Write(S: string);\r\n begin\r\n Strs.Add(S);\r\n end;\r\n\r\nbegin\r\n if Assigned(PageControl) then\r\n begin\r\n LPageControl := PageControl as TJvDockTabPageControl;\r\n LClassName := LPageControl.ClassName;\r\n LName := LPageControl.Name;\r\n Count := LPageControl.Count;\r\n Write(Indent + ' ');\r\n Write(Indent + ' ' + LClassName + '');\r\n Write(Indent + ' ' + LName + '');\r\n for I := 0 to Count-1 do\r\n begin\r\n PageID := 'Page' + IntToStr(I + 1);\r\n Write(Indent + ' <' + PageID + '>');\r\n Write(Indent + ' ' + LPageControl.Pages[I].ClassName + '');\r\n Write(Indent + ' ' + LPageControl.Pages[I].Name + '');\r\n Write(Indent + ' ' + LPageControl.Pages[I].Caption + '');\r\n Write('');\r\n for J := 0 to LPageControl.Pages[I].ControlCount - 1 do\r\n begin\r\n _ControlDump(LPageControl.Pages[I].Controls[J] as TWinControl, Indent + ' ', Strs);\r\n Write('');\r\n end;\r\n Write(Indent + ' ');\r\n Write('');\r\n end;\r\n\r\n Write(Indent + ' ');\r\n Write('');\r\n end\r\n else\r\n Write(Indent + ' No pagecontrol in the TJvDockTabHostForm.');\r\nend;\r\n\r\nprocedure TJvDockTree._ControlDump(AControl: TWinControl; Indent: string; Strs: TStrings);\r\nvar\r\n LClassName, LName: string;\r\n LForm: TForm;\r\n DockClient: TJvDockClient;\r\n\r\n procedure Write(S: string);\r\n begin\r\n Strs.Add(S);\r\n end;\r\n\r\nbegin\r\n Write(Indent + ' ');\r\n LClassName := AControl.ClassName;\r\n LName := AControl.Name;\r\n Write(Indent + ' ' + LClassName + '');\r\n Write(Indent + ' ' + LName + '');\r\n Write(Indent + ' ' + BoolToStr(AControl.Visible, True) + '');\r\n Write(Indent + ' ' + BoolToStr(AControl.Enabled, True) + '');\r\n\r\n if AControl is TForm then\r\n begin\r\n LForm := TForm(AControl);\r\n Write(Indent + ' ' + LForm.Caption + '');\r\n DockClient := FindDockClient(AControl);\r\n if Assigned(DockClient) then\r\n begin\r\n LClassName := DockClient.ClassName;\r\n LName := DockClient.Name;\r\n Write(Indent + ' ');\r\n Write(Indent + ' ' + LClassName + '');\r\n Write(Indent + ' ' + LName + '');\r\n Write(Indent + ' ' + BoolToStr(DockClient.CustomDock, True) + '');\r\n\r\n // uses DockStateStr - utility function in JvDockControlForm.pas:\r\n Write(Indent + ' ' + DockStateStr(DockClient.DockState) + '');\r\n\r\n Write(Indent + ' ');\r\n end\r\n else\r\n Write(Indent + ' No dockclient found in this form.');\r\n if LForm is TJvDockTabHostForm then\r\n _PageControlDump(TJvDockTabHostForm(LForm).PageControl, Indent, Strs);\r\n end;\r\n\r\n { LAST for each control, recursively dump the TWinControl.Parent\r\n tree, but limit to only a few levels\r\n so we can avoid information overload. Oops. Too late. :-) }\r\n _ParentDump(3, AControl.Parent, Indent, Strs);\r\n\r\n Write(Indent + ' ');\r\nend;\r\n\r\n// This helps us to understand the current contents of the tree at runtime,\r\n// by allowing us to build an XML dump of the TJvDockTree.\r\nprocedure TJvDockTree.DebugDump(var Index: Integer; Indent, Entity: string; TreeZone: TJvDockZone; Strs: TStrings); //virtual;\r\nvar\r\n Zone: TJvDockZone;\r\n WasIndex: Integer;\r\n\r\n procedure Write(S: string);\r\n begin\r\n Strs.Add(S);\r\n end;\r\n\r\nbegin\r\n Zone := TreeZone;\r\n\r\n { while loop over siblings at this level...}\r\n while Assigned(Zone) do\r\n begin\r\n WasIndex := Index;\r\n Inc(Index);\r\n\r\n {xml Entity begins }\r\n Write(Indent + '<' + Entity + IntToStr(WasIndex) + '>');\r\n\r\n {for every tree and tree item inside it that we dump, report actual class name }\r\n Write(Indent + ' ' + Zone.ClassName + '');\r\n\r\n { Dump controls recursively }\r\n if Assigned(Zone.ChildControl) then\r\n _ControlDump(Zone.ChildControl, Indent, Strs);\r\n\r\n { Dump children recursively }\r\n DebugDump(Index, Indent + ' ', Entity + '.ChildZone', Zone.ChildZones, Strs);\r\n\r\n {xml Entity ends }\r\n Write(Indent + '');\r\n\r\n {blank line after each Entity ends}\r\n Write('');\r\n\r\n {dump all siblings at this level immediately after current item }\r\n Zone := Zone.NextSibling;\r\n end;\r\nend;\r\n\r\n{$ENDIF JVDOCK_DEBUG}\r\n\r\n{$IFDEF JVDOCK_QUERY}\r\n\r\n// This helps us to find particular Controls (ie Forms) that are\r\n// docked to a particular dock panel, or are floating, etc.\r\n//\r\n// DockedTo - return only items docked to this parent control,\r\n// or if the parameter DockedTo is NIL, then query for\r\n// floating Forms. These forms must contain a\r\n// JvDockClient that says it is currently in a Floating state.\r\n//\r\n// FoundItems - OUT: TList of results (pointers to TWinControl objects).\r\n//\r\n//\r\nprocedure TJvDockTree.ControlQuery(DockedTo: TWinControl; FoundItems: TList);\r\nbegin\r\n Assert(Assigned(FoundItems));\r\n FoundItems.Clear;\r\n // Root tree node is TopZone. The tree is made of nodes called\r\n // Zones and Zones may have Controls. Some of those Controls are Forms\r\n // we might be querying for, and some are parent container forms containing\r\n // a tabbed set of other forms, so we have to check for that and\r\n // go down into those container forms. DoQuery calls itself and other\r\n // helper routines, recursively, and together this set of routines\r\n // descends through the Zones, Controls (Forms), etc, finding all\r\n // the Controls inside those zones.\r\n DoControlQuery(TopZone, FoundItems);\r\nend;\r\n\r\n//XXX Helper routines for DoQuery: XXX\r\n\r\nprocedure TJvDockTree._ParentQuery(LevelsLeft: Integer; AParent: TWinControl; FoundItems: TList );\r\nvar\r\n// DockServer: TJvDockServer;\r\n LClassName, LName: string;\r\nbegin\r\n if Assigned(AParent) then\r\n begin\r\n LClassName := AParent.ClassName;\r\n LName := AParent.Name;\r\n //Write(Indent + ' ');\r\n //Write(Indent + ' ' + LClassName + '');\r\n //Write(Indent + ' ' + LName + '@' + IntToHex(LPARAM(AParent), 2 * SizeOf(LPARAM)) + '');\r\n if AParent is TJvDockPanel then\r\n begin\r\n (*DockServer := TJvDockPanel(AParent).DockServer;\r\n if Assigned(DockServer) then\r\n begin\r\n //Write(Indent + ' ' + DockServer.Name + '');\r\n end\r\n else\r\n begin\r\n //Write(Indent + ' TJvDockPanel has no DockServer');\r\n end;*)\r\n end;\r\n // recurse down:\r\n if LevelsLeft > 0 then\r\n if AParent.Parent <> AParent then // don't show controls where they are their own parent!\r\n _ParentQuery(LevelsLeft - 1, AParent.Parent, FoundItems);\r\n //Write(Indent + ' ');\r\n end;\r\nend;\r\n\r\nprocedure TJvDockTree._PageControlQuery(PageControl: TWinControl; FoundItems: TList); {actually TJvDockTabPageControl}\r\nvar\r\n I, J, Count: Integer;\r\n PageID: string;\r\n LPageControl: TJvDockTabPageControl;\r\n LClassName, LName: string;\r\nbegin\r\n if Assigned(PageControl) then\r\n begin\r\n LPageControl := PageControl as TJvDockTabPageControl;\r\n LClassName := LPageControl.ClassName;\r\n LName := LPageControl.Name;\r\n Count := LPageControl.Count;\r\n //Write(Indent + ' ');\r\n //Write(Indent + ' ' + LClassName + '');\r\n //Write(Indent + ' ' + LName + '');\r\n for I := 0 to Count - 1 do\r\n begin\r\n PageID := 'Page' + IntToStr(I + 1);\r\n //Write(Indent + ' <' + PageID + '>');\r\n //Write(Indent + ' ' + LPageControl.Pages[I].ClassName + '');\r\n //Write(Indent + ' ' + LPageControl.Pages[I].Name + '');\r\n //Write(Indent + ' ' + LPageControl.Pages[I].Caption + '');\r\n //Write('');\r\n for J := 0 to LPageControl.Pages[I].ControlCount - 1 do\r\n _ControlQuery(LPageControl.Pages[I].Controls[J] as TWinControl, FoundItems);\r\n //Write(Indent + ' ');\r\n end;\r\n //Write(Indent + ' ');\r\n //Write('');\r\n end;\r\nend;\r\n\r\nprocedure TJvDockTree._ControlQuery(AControl: TWinControl; FoundItems: TList);\r\nvar\r\n LClassName, LName: string;\r\n LForm: TForm;\r\n DockClient: TJvDockClient;\r\nbegin\r\n //Write(Indent + ' ');\r\n LClassName := AControl.ClassName;\r\n LName := AControl.Name;\r\n //Write(Indent + ' ' + LClassName + '');\r\n //Write(Indent + ' ' + LName + '');\r\n //Write(Indent + ' ' + BoolToStr(AControl.Visible, True) + '');\r\n //Write(Indent + ' ' + BoolToStr(AControl.Enabled, True) + '');\r\n\r\n if AControl is TForm then\r\n begin\r\n LForm := TForm(AControl);\r\n //Write(Indent + ' ' + LForm.Caption + '');\r\n DockClient := FindDockClient(AControl);\r\n if Assigned(DockClient) then\r\n begin\r\n LClassName := DockClient.ClassName;\r\n LName := DockClient.Name;\r\n\r\n // FOUND A CONTROL WHICH IS A FORM AND HAS A JVDOCK CLIENT.\r\n // Add it to FoundItems:\r\n if DockClient.DockState = JvDockState_Docking then\r\n begin\r\n Assert(Assigned(FoundItems));\r\n FoundItems.Add(AControl);\r\n end;\r\n //Write(Indent + ' ');\r\n //Write(Indent + ' ' + LClassName + '');\r\n //Write(Indent + ' ' + LName + '');\r\n //Write(Indent + ' ' + BoolToStr(DockClient.CustomDock, True) + '');\r\n\r\n // uses DockStateStr - utility function in JvDockControlForm.pas:\r\n //Write(Indent + ' ' + DockStateStr(DockClient.DockState) + '');\r\n\r\n //Write(Indent + ' ');\r\n end\r\n else\r\n begin\r\n //Write(Indent + ' No dockclient found in this form.');\r\n end;\r\n if LForm is TJvDockTabHostForm then\r\n _PageControlQuery(TJvDockTabHostForm(LForm).PageControl, FoundItems);\r\n end;\r\n\r\n { LAST for each control, recursively query the TWinControl.Parent\r\n tree, but limit to only a few levels\r\n so we can avoid information overload. Oops. Too late. :-) }\r\n _ParentQuery(3, AControl.Parent, FoundItems);\r\n //Write(Indent + ' ');\r\nend;\r\n\r\n// DoQuery:\r\n// This is a recursive function called from top level function Query().\r\n// This helps us to find particular Controls, that are docked to a particular\r\n// dock panel, or are floating, etc.\r\nprocedure TJvDockTree.DoControlQuery(TreeZone: TJvDockZone; FoundItems: TList);\r\nvar\r\n Zone: TJvDockZone;\r\nbegin\r\n Zone := TreeZone;\r\n\r\n { while loop over siblings at this level...}\r\n while Assigned(Zone) do\r\n begin\r\n { Dump controls recursively }\r\n if Assigned( Zone.ChildControl) then\r\n _ControlQuery(Zone.ChildControl, FoundItems);\r\n { query children, descends recursively }\r\n DoControlQuery(Zone.ChildZones, FoundItems);\r\n\r\n {query all siblings at this level immediately after current item }\r\n Zone := Zone.NextSibling;\r\n end;\r\nend;\r\n\r\n{$ENDIF JVDOCK_QUERY}\r\n\r\nprocedure TJvDockTree.AdjustDockRect(Control: TControl; var ARect: TRect);\r\nbegin\r\n InflateRect(ARect, -BorderWidth, -BorderWidth);\r\n case GrabbersPosition of\r\n gpTop:\r\n Inc(ARect.Top, GrabberSize);\r\n gpBottom:\r\n Dec(ARect.Bottom, GrabberSize);\r\n gpLeft:\r\n Inc(ARect.Left, GrabberSize);\r\n gpRight:\r\n Dec(ARect.Right, GrabberSize);\r\n end;\r\nend;\r\n\r\nprocedure TJvDockTree.BeginUpdate;\r\nbegin\r\n Inc(FUpdateCount);\r\nend;\r\n\r\nprocedure TJvDockTree.EndUpdate;\r\nbegin\r\n Dec(FUpdateCount);\r\n if FUpdateCount <= 0 then\r\n begin\r\n FUpdateCount := 0;\r\n UpdateAll;\r\n end;\r\nend;\r\n\r\nfunction TJvDockTree.FindControlZone(Control: TControl; IncludeHide: Boolean): TJvDockZone;\r\nvar\r\n CtlZone: TJvDockZone;\r\n\r\n procedure DoFindControlZone(StartZone: TJvDockZone);\r\n begin\r\n if (StartZone.ChildControl = Control) and (StartZone.Visibled or IncludeHide) then\r\n CtlZone := StartZone\r\n else\r\n begin\r\n if (CtlZone = nil) and (StartZone.NextSibling <> nil) then\r\n DoFindControlZone(StartZone.NextSibling);\r\n\r\n if (CtlZone = nil) and (StartZone.ChildZones <> nil) then\r\n DoFindControlZone(StartZone.ChildZones);\r\n end;\r\n end;\r\n\r\nbegin\r\n CtlZone := nil;\r\n if (Control <> nil) and (FTopZone <> nil) then\r\n DoFindControlZone(FTopZone);\r\n Result := CtlZone;\r\nend;\r\n\r\nprocedure TJvDockTree.ForEachAt(Zone: TJvDockZone; Proc: TJvDockForEachZoneProc;\r\n ScanKind: TJvDockTreeScanKind; ScanPriority: TJvDockTreeScanPriority);\r\n\r\n procedure DoForwardForEach(Zone: TJvDockZone);\r\n begin\r\n Proc(Zone);\r\n if ScanPriority = tspSibling then\r\n begin\r\n if Zone.NextSibling <> nil then\r\n DoForwardForEach(Zone.NextSibling);\r\n\r\n if Zone.ChildZones <> nil then\r\n DoForwardForEach(Zone.ChildZones);\r\n end\r\n else\r\n begin\r\n if Zone.ChildZones <> nil then\r\n DoForwardForEach(Zone.ChildZones);\r\n\r\n if Zone.NextSibling <> nil then\r\n DoForwardForEach(Zone.NextSibling);\r\n end;\r\n end;\r\n\r\n procedure DoMiddleForEach(Zone: TJvDockZone);\r\n begin\r\n if ScanPriority = tspSibling then\r\n begin\r\n if Zone.NextSibling <> nil then\r\n DoMiddleForEach(Zone.NextSibling);\r\n end\r\n else\r\n begin\r\n if Zone.ChildZones <> nil then\r\n DoMiddleForEach(Zone.ChildZones);\r\n end;\r\n\r\n Proc(Zone);\r\n\r\n if ScanPriority = tspSibling then\r\n begin\r\n if Zone.ChildZones <> nil then\r\n DoMiddleForEach(Zone.ChildZones);\r\n end\r\n else\r\n if Zone.NextSibling <> nil then\r\n DoMiddleForEach(Zone.NextSibling);\r\n end;\r\n\r\n procedure DoBackwardForEach(Zone: TJvDockZone);\r\n begin\r\n if ScanPriority = tspSibling then\r\n begin\r\n if Zone.NextSibling <> nil then\r\n DoBackwardForEach(Zone.NextSibling);\r\n\r\n if Zone.ChildZones <> nil then\r\n DoBackwardForEach(Zone.ChildZones);\r\n end\r\n else\r\n begin\r\n if Zone.ChildZones <> nil then\r\n DoForwardForEach(Zone.ChildZones);\r\n\r\n if Zone.NextSibling <> nil then\r\n DoForwardForEach(Zone.NextSibling);\r\n end;\r\n Proc(Zone);\r\n end;\r\n\r\nbegin\r\n if Zone = nil then\r\n begin\r\n if FTopZone = nil then\r\n FTopZone := FDockZoneClass.Create(Self);\r\n Zone := FTopZone;\r\n end;\r\n\r\n case ScanKind of\r\n tskForward:\r\n DoForwardForEach(Zone);\r\n tskMiddle:\r\n DoMiddleForEach(Zone);\r\n tskBackward:\r\n DoBackwardForEach(Zone);\r\n end;\r\nend;\r\n\r\nprocedure TJvDockTree.GetControlBounds(Control: TControl; out CtlBounds: TRect);\r\nvar\r\n Z: TJvDockZone;\r\nbegin\r\n Z := FindControlZone(Control);\r\n if Z = nil then\r\n FillChar(CtlBounds, SizeOf(CtlBounds), 0)\r\n else\r\n with Z do\r\n CtlBounds := Bounds(Left, Top, Width, Height);\r\nend;\r\n\r\nfunction TJvDockTree.HitTest(const MousePos: TPoint; out HTFlag: Integer): TControl;\r\nvar\r\n Zone: TJvDockZone;\r\nbegin\r\n Zone := InternalHitTest(MousePos, HTFlag);\r\n if Zone <> nil then\r\n Result := Zone.ChildControl\r\n else\r\n Result := nil;\r\nend;\r\n\r\nprocedure TJvDockTree.InsertControl(Control: TControl; InsertAt: TAlign;\r\n DropCtl: TControl);\r\nconst\r\n Orients: array [TAlign] of TDockOrientation =\r\n (doNoOrient, doHorizontal, doHorizontal, doVertical, doVertical, doNoOrient, doNoOrient);\r\n MakeLast: array [TAlign] of Boolean =\r\n (False, False, True, False, True, False, False);\r\nvar\r\n Sibling: TJvDockZone;\r\n Me: TJvDockZone;\r\n InsertOrientation: TDockOrientation;\r\n CurrentOrientation: TDockOrientation;\r\n NewWidth, NewHeight: Integer;\r\n R: TRect;\r\nbegin\r\n if FReplacementZone <> nil then\r\n begin\r\n FReplacementZone.ChildControl := TWinControl(Control);\r\n FReplacementZone.Update;\r\n Exit;\r\n end\r\n else\r\n if FTopZone <> nil then\r\n begin\r\n if FTopZone.ChildZones = nil then\r\n begin\r\n R := FDockSite.ClientRect;\r\n TWinControlAccessProtected(FDockSite).AdjustClientRect(R);\r\n NewWidth := R.Right - R.Left;\r\n NewHeight := R.Bottom - R.Top;\r\n if TWinControlAccessProtected(FDockSite).AutoSize then\r\n begin\r\n if NewWidth = 0 then\r\n NewWidth := Control.UndockWidth;\r\n if NewHeight = 0 then\r\n NewHeight := Control.UndockHeight;\r\n end;\r\n R := Bounds(R.Left, R.Top, NewWidth, NewHeight);\r\n AdjustDockRect(Control, R);\r\n Control.BoundsRect := R;\r\n Me := FDockZoneClass.Create(Self);\r\n FTopZone.ChildZones := Me;\r\n Me.FParentZone := FTopZone;\r\n Me.ChildControl := TWinControl(Control);\r\n end\r\n else\r\n begin\r\n if InsertAt in [alClient, alNone] then\r\n InsertAt := alRight;\r\n\r\n Me := FindControlZone(Control, True);\r\n if Me <> nil then\r\n RemoveZone(Me, False);\r\n\r\n Sibling := FindControlZone(DropCtl);\r\n\r\n InsertOrientation := Orients[InsertAt];\r\n if FTopZone.ChildCount = 1 then\r\n begin\r\n FTopZone.Orientation := InsertOrientation;\r\n case InsertOrientation of\r\n doHorizontal:\r\n begin\r\n FTopZone.ZoneLimit := FTopZone.ChildZones.Width;\r\n TopXYLimit := FTopZone.ChildZones.Height;\r\n end;\r\n doVertical:\r\n begin\r\n FTopZone.ZoneLimit := FTopZone.ChildZones.Height;\r\n TopXYLimit := FTopZone.ChildZones.Width;\r\n end;\r\n end;\r\n end;\r\n\r\n Me := FDockZoneClass.Create(Self);\r\n Me.ChildControl := TWinControl(Control);\r\n\r\n if Sibling <> nil then\r\n CurrentOrientation := Sibling.FParentZone.Orientation\r\n else\r\n CurrentOrientation := FTopZone.Orientation;\r\n if InsertOrientation = doNoOrient then\r\n InsertOrientation := CurrentOrientation;\r\n\r\n if InsertOrientation = CurrentOrientation then\r\n InsertSibling(Me, Sibling, MakeLast[InsertAt], True)\r\n else\r\n InsertNewParent(Me, Sibling, InsertOrientation, MakeLast[InsertAt], True);\r\n end;\r\n\r\n FDockSite.Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockTree.InsertNewParent(NewZone, SiblingZone: TJvDockZone;\r\n ParentOrientation: TDockOrientation; InsertLast, Update: Boolean);\r\nvar\r\n NewParent: TJvDockZone;\r\nbegin\r\n NewParent := FDockZoneClass.Create(Self);\r\n\r\n NewParent.Orientation := ParentOrientation;\r\n if SiblingZone = nil then\r\n begin\r\n NewParent.ZoneLimit := TopXYLimit;\r\n TopXYLimit := FTopZone.ZoneLimit;\r\n ShiftScaleOrientation := ParentOrientation;\r\n ScaleBy := 0.5;\r\n if InsertLast then\r\n begin\r\n FTopZone.Visibled := FTopZone.VisibleChildCount > 0;\r\n NewParent.ChildZones := FTopZone;\r\n FTopZone.ParentZone := NewParent;\r\n FTopZone.NextSibling := NewZone;\r\n NewZone.PrevSibling := FTopZone;\r\n NewZone.ParentZone := NewParent;\r\n FTopZone := NewParent;\r\n ForEachAt(NewParent.ChildZones, ScaleZone, tskForward);\r\n end\r\n else\r\n begin\r\n NewParent.ChildZones := NewZone;\r\n FTopZone.ParentZone := NewParent;\r\n FTopZone.PrevSibling := NewZone;\r\n NewZone.NextSibling := FTopZone;\r\n NewZone.ParentZone := NewParent;\r\n FTopZone := NewParent;\r\n\r\n if ParentOrientation <> FTopZone.Orientation then\r\n NewZone.ZoneLimit := FTopZone.ZoneLimit div 2\r\n else\r\n NewZone.ZoneLimit := TopXYLimit div 2;\r\n\r\n ForEachAt(NewZone.NextSibling, ScaleZone, tskForward);\r\n if ParentOrientation <> FTopZone.Orientation then\r\n ShiftBy := FTopZone.ZoneLimit div 2\r\n else\r\n ShiftBy := TopXYLimit div 2;\r\n ForEachAt(NewZone.NextSibling, ShiftZone, tskForward);\r\n end;\r\n ForEachAt(nil, UpdateZone, tskForward);\r\n end\r\n else\r\n begin\r\n NewParent.ZoneLimit := SiblingZone.ZoneLimit;\r\n NewParent.ParentZone := SiblingZone.ParentZone;\r\n NewParent.PrevSibling := SiblingZone.PrevSibling;\r\n if NewParent.PrevSibling <> nil then\r\n NewParent.PrevSibling.NextSibling := NewParent;\r\n NewParent.NextSibling := SiblingZone.NextSibling;\r\n if NewParent.NextSibling <> nil then\r\n NewParent.NextSibling.PrevSibling := NewParent;\r\n if NewParent.ParentZone.ChildZones = SiblingZone then\r\n NewParent.ParentZone.ChildZones := NewParent;\r\n NewZone.ParentZone := NewParent;\r\n SiblingZone.ParentZone := NewParent;\r\n if InsertLast then\r\n begin\r\n NewParent.ChildZones := SiblingZone;\r\n SiblingZone.ZoneLimit := NewParent.ParentZone.ZoneLimit;\r\n SiblingZone.PrevSibling := nil;\r\n SiblingZone.NextSibling := NewZone;\r\n NewZone.PrevSibling := SiblingZone;\r\n end\r\n else\r\n begin\r\n NewParent.ChildZones := NewZone;\r\n SiblingZone.PrevSibling := NewZone;\r\n SiblingZone.NextSibling := nil;\r\n NewZone.NextSibling := SiblingZone;\r\n end;\r\n end;\r\n if Update then\r\n begin\r\n NewParent.ResetChildren(nil);\r\n ForEachAt(nil, UpdateZone, tskForward);\r\n end;\r\nend;\r\n\r\nprocedure TJvDockTree.InsertSibling(NewZone, SiblingZone: TJvDockZone;\r\n InsertLast, Update: Boolean);\r\nbegin\r\n if (NewZone <> nil) and (SiblingZone <> nil) and\r\n (NewZone.ChildControl = SiblingZone.ChildControl) then\r\n SiblingZone := nil;\r\n if SiblingZone = nil then\r\n begin\r\n SiblingZone := FTopZone.ChildZones;\r\n if InsertLast then\r\n SiblingZone := SiblingZone.LastSibling;\r\n end;\r\n if InsertLast then\r\n begin\r\n NewZone.ParentZone := SiblingZone.ParentZone;\r\n NewZone.PrevSibling := SiblingZone;\r\n NewZone.NextSibling := SiblingZone.NextSibling;\r\n if NewZone.NextSibling <> nil then\r\n NewZone.NextSibling.PrevSibling := NewZone;\r\n SiblingZone.NextSibling := NewZone;\r\n end\r\n else\r\n begin\r\n NewZone.NextSibling := SiblingZone;\r\n NewZone.PrevSibling := SiblingZone.PrevSibling;\r\n if NewZone.PrevSibling <> nil then\r\n NewZone.PrevSibling.NextSibling := NewZone;\r\n SiblingZone.PrevSibling := NewZone;\r\n NewZone.ParentZone := SiblingZone.ParentZone;\r\n if NewZone.ParentZone.ChildZones = SiblingZone then\r\n NewZone.ParentZone.ChildZones := NewZone;\r\n end;\r\n if Update then\r\n begin\r\n SiblingZone.ParentZone.ResetChildren(nil);\r\n UpdateChild(SiblingZone.ParentZone);\r\n end;\r\nend;\r\n\r\nfunction TJvDockTree.DoFindZone(const MousePos: TPoint;\r\n out HTFlag: Integer; Zone: TJvDockZone): TJvDockZone;\r\nconst\r\n HTFlagArr: array [Boolean] of Integer = (HTCLIENT, HTSPLITTER);\r\nbegin\r\n Result := nil;\r\n\r\n if (Zone.ParentZone.Orientation = doHorizontal) and\r\n (Zone.NextSibling <> nil) and\r\n ((MousePos.Y <= Zone.FZoneLimit) and\r\n (MousePos.Y >= Zone.FZoneLimit - SplitterWidth)) and\r\n ((MousePos.X <= Zone.ParentZone.FZoneLimit) and\r\n (MousePos.X >= Zone.ParentZone.LimitBegin)) then\r\n begin\r\n HTFlag := HTFlagArr[Zone.VisibleNextSiblingTotal > 0];\r\n Result := Zone;\r\n end\r\n else\r\n if (Zone.FParentZone.Orientation = doVertical) and\r\n (Zone.NextSibling <> nil) and\r\n ((MousePos.X <= Zone.FZoneLimit) and\r\n (MousePos.X >= Zone.FZoneLimit - SplitterWidth)) and\r\n ((MousePos.Y <= Zone.ParentZone.FZoneLimit) and\r\n (MousePos.Y >= Zone.ParentZone.LimitBegin)) then\r\n begin\r\n HTFlag := HTFlagArr[Zone.VisibleNextSiblingTotal > 0];\r\n Result := Zone;\r\n end\r\n else\r\n if Zone.ChildControl <> nil then\r\n begin\r\n case GrabbersPosition of\r\n gpTop:\r\n Result := GetTopGrabbersHTFlag(MousePos, HTFlag, Zone);\r\n gpLeft:\r\n Result := GetLeftGrabbersHTFlag(MousePos, HTFlag, Zone);\r\n gpBottom:\r\n Result := GetBottomGrabbersHTFlag(MousePos, HTFlag, Zone);\r\n gpRight:\r\n Result := GetRightGrabbersHTFlag(MousePos, HTFlag, Zone);\r\n end;\r\n\r\n if Result = nil then\r\n Result := GetBorderHTFlag(MousePos, HTFlag, Zone);\r\n end\r\n else\r\n Result := nil;\r\n\r\n if (Result <> nil) and (not Result.Visibled) then\r\n Result := nil;\r\n\r\n if (Result = nil) and (Zone.NextSibling <> nil) then\r\n Result := DoFindZone(MousePos, HTFlag, Zone.NextSibling);\r\n if (Result = nil) and (Zone.ChildZones <> nil) then\r\n Result := DoFindZone(MousePos, HTFlag, Zone.ChildZones);\r\nend;\r\n\r\nfunction TJvDockTree.InternalHitTest(const MousePos: TPoint; out HTFlag: Integer): TJvDockZone;\r\nvar\r\n ResultZone: TJvDockZone;\r\n CtlAtPos: TControl;\r\n\r\n function FindControlAtPos(const Pos: TPoint): TControl;\r\n var\r\n I: Integer;\r\n P: TPoint;\r\n begin\r\n for I := FDockSite.ControlCount - 1 downto 0 do\r\n begin\r\n Result := FDockSite.Controls[I];\r\n if not Result.Visible or\r\n ((Result is TWinControl) and not TWinControl(Result).Showing) then\r\n Continue;\r\n P := Point(Pos.X - Result.Left, Pos.Y - Result.Top);\r\n if PtInRect(Result.ClientRect, P) then\r\n Exit;\r\n end;\r\n Result := nil;\r\n end;\r\n\r\nbegin\r\n ResultZone := nil;\r\n HTFlag := HTNOWHERE;\r\n CtlAtPos := FindControlAtPos(MousePos);\r\n if (CtlAtPos <> nil) and (CtlAtPos.HostDockSite = FDockSite) then\r\n begin\r\n ResultZone := FindControlZone(CtlAtPos);\r\n if ResultZone <> nil then\r\n HTFlag := HTCLIENT;\r\n end\r\n else\r\n if (FTopZone <> nil) and (FTopZone.ChildZones <> nil) and\r\n (FTopZone.ChildCount >= 1) and (CtlAtPos = nil) then\r\n ResultZone := DoFindZone(MousePos, HTFlag, FTopZone.ChildZones);\r\n Result := ResultZone;\r\nend;\r\n\r\nprocedure TJvDockTree.LoadFromStream(Stream: TStream);\r\nvar\r\n I: Integer;\r\nbegin\r\n PruneZone(FTopZone);\r\n\r\n Stream.Read(I, SizeOf(I));\r\n if I <> Version then\r\n Exit;\r\n\r\n BeginUpdate;\r\n try\r\n Stream.Read(FTopXYLimit, SizeOf(FTopXYLimit));\r\n DoLoadZone(Stream);\r\n finally\r\n EndUpdate;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockTree.PaintSite(DC: HDC);\r\nbegin\r\n FCanvas.Control := FDockSite;\r\n FCanvas.Lock;\r\n try\r\n FCanvas.Handle := DC;\r\n try\r\n PaintDockSite;\r\n finally\r\n FCanvas.Handle := 0;\r\n end;\r\n finally\r\n FCanvas.Unlock;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockTree.PositionDockRect(Client, DropCtl: TControl;\r\n DropAlign: TAlign; var DockRect: TRect);\r\nvar\r\n VisibleClients, NewX, NewY, NewWidth, NewHeight: Integer;\r\nbegin\r\n VisibleClients := FDockSite.VisibleDockClientCount;\r\n\r\n if (DropCtl = nil) or (DropCtl.DockOrientation = doNoOrient) or\r\n (VisibleClients < 2) then\r\n begin\r\n DockRect := Rect(0, 0, FDockSite.ClientWidth, FDockSite.ClientHeight);\r\n\r\n if VisibleClients > 0 then\r\n case DropAlign of\r\n alLeft:\r\n DockRect.Right := DockRect.Right div 2;\r\n alRight:\r\n DockRect.Left := DockRect.Right div 2;\r\n alTop:\r\n DockRect.Bottom := DockRect.Bottom div 2;\r\n alBottom:\r\n DockRect.Top := DockRect.Bottom div 2;\r\n end;\r\n end\r\n else\r\n begin\r\n NewX := DropCtl.Left;\r\n NewY := DropCtl.Top;\r\n NewWidth := DropCtl.Width;\r\n NewHeight := DropCtl.Height;\r\n if DropAlign in [alLeft, alRight] then\r\n NewWidth := DropCtl.Width div 2\r\n else\r\n if DropAlign in [alTop, alBottom] then\r\n NewHeight := DropCtl.Height div 2;\r\n case DropAlign of\r\n alRight:\r\n Inc(NewX, NewWidth);\r\n alBottom:\r\n Inc(NewY, NewHeight);\r\n end;\r\n DockRect := Bounds(NewX, NewY, NewWidth, NewHeight);\r\n if DropAlign = alClient then\r\n DockRect := Bounds(NewX, NewY, NewWidth, NewHeight);\r\n end;\r\n MapWindowPoints(FDockSite.Handle, 0, DockRect, 2);\r\nend;\r\n\r\nprocedure TJvDockTree.PruneZone(Zone: TJvDockZone);\r\n\r\n procedure DoPrune(Zone: TJvDockZone);\r\n begin\r\n if Zone.NextSibling <> nil then\r\n DoPrune(Zone.NextSibling);\r\n if Zone.ChildZones <> nil then\r\n DoPrune(Zone.ChildZones);\r\n Zone.Free;\r\n end;\r\n\r\nbegin\r\n if Zone = nil then\r\n Exit;\r\n\r\n if Zone.ChildZones <> nil then\r\n DoPrune(Zone.ChildZones);\r\n\r\n if Zone.FPrevSibling <> nil then\r\n Zone.FPrevSibling.NextSibling := Zone.NextSibling\r\n else\r\n if Zone.FParentZone <> nil then\r\n Zone.FParentZone.ChildZones := Zone.NextSibling;\r\n if Zone.NextSibling <> nil then\r\n Zone.NextSibling.FPrevSibling := Zone.FPrevSibling;\r\n\r\n if Zone = FTopZone then\r\n FTopZone := nil;\r\n Zone.Free;\r\nend;\r\n\r\nprocedure TJvDockTree.RemoveControl(Control: TControl);\r\nvar\r\n Z: TJvDockZone;\r\nbegin\r\n Z := FindControlZone(Control, True);\r\n if Z <> nil then\r\n begin\r\n if Z = FReplacementZone then\r\n Z.ChildControl := nil\r\n else\r\n begin\r\n if (Z.ParentZone.Orientation <> doNoOrient) and Z.Visibled then\r\n Z.Remove(Z.LimitSize, False);\r\n RemoveZone(Z, False);\r\n SetNewBounds(nil);\r\n UpdateAll;\r\n end;\r\n Control.DockOrientation := doNoOrient;\r\n\r\n FDockSite.Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockTree.RemoveZone(Zone: TJvDockZone; Hide: Boolean);\r\nvar\r\n Sibling, LastChild: TJvDockZone;\r\n VisibleZoneChildCount, ZoneChildCount: Integer;\r\n// (rom) disabled unused\r\n//label\r\n// LOOP;\r\nbegin\r\n if not Hide then\r\n begin\r\n if Zone = nil then\r\n raise Exception.Create(SDockTreeRemoveError + SDockZoneNotFound);\r\n if Zone.ChildControl = nil then\r\n raise Exception.Create(SDockTreeRemoveError + SDockZoneHasNoCtl);\r\n VisibleZoneChildCount := Zone.ParentZone.VisibleChildCount;\r\n ZoneChildCount := Zone.ParentZone.ChildCount;\r\n if VisibleZoneChildCount <= 1 then\r\n begin\r\n if Zone.PrevSibling = nil then\r\n begin\r\n Zone.ParentZone.ChildZones := Zone.NextSibling;\r\n if Zone.NextSibling <> nil then\r\n Zone.NextSibling.PrevSibling := nil;\r\n end\r\n else\r\n if Zone.NextSibling = nil then\r\n Zone.PrevSibling.NextSibling := nil\r\n else\r\n begin\r\n Zone.PrevSibling.NextSibling := Zone.NextSibling;\r\n Zone.NextSibling.PrevSibling := Zone.PrevSibling;\r\n end;\r\n end;\r\n if ZoneChildCount = 2 then\r\n begin\r\n if Zone.PrevSibling = nil then\r\n Sibling := Zone.NextSibling\r\n else\r\n Sibling := Zone.PrevSibling;\r\n if Sibling.ChildControl <> nil then\r\n begin\r\n if Zone.ParentZone = FTopZone then\r\n begin\r\n FTopZone.ChildZones := Sibling;\r\n Sibling.PrevSibling := nil;\r\n Sibling.NextSibling := nil;\r\n Sibling.ZoneLimit := FTopZone.LimitSize;\r\n Sibling.Update;\r\n end\r\n else\r\n begin\r\n Zone.ParentZone.Orientation := doNoOrient;\r\n Zone.ParentZone.ChildControl := Sibling.ChildControl;\r\n Zone.ParentZone.ChildZones := nil;\r\n Sibling.Free;\r\n end;\r\n\r\n ForEachAt(Zone.ParentZone, UpdateZone, tskForward);\r\n end\r\n else\r\n begin\r\n if Zone.ParentZone = FTopZone then\r\n begin\r\n Sibling.ZoneLimit := TopXYLimit;\r\n TopXYLimit := FTopZone.ZoneLimit;\r\n FTopZone.Free;\r\n FTopZone := Sibling;\r\n Sibling.NextSibling := nil;\r\n Sibling.PrevSibling := nil;\r\n Sibling.ParentZone := nil;\r\n end\r\n else\r\n begin\r\n Sibling.ChildZones.PrevSibling := Zone.ParentZone.PrevSibling;\r\n if Sibling.ChildZones.PrevSibling = nil then\r\n Zone.ParentZone.ParentZone.ChildZones := Sibling.ChildZones\r\n else\r\n Sibling.ChildZones.PrevSibling.NextSibling := Sibling.ChildZones;\r\n LastChild := Sibling.ChildZones;\r\n LastChild.ParentZone := Zone.ParentZone.ParentZone;\r\n repeat\r\n LastChild := LastChild.NextSibling;\r\n if LastChild <> nil then\r\n LastChild.ParentZone := Zone.ParentZone.ParentZone\r\n else\r\n Break;\r\n until LastChild.NextSibling = nil;\r\n if LastChild <> nil then\r\n begin\r\n LastChild.NextSibling := Zone.ParentZone.NextSibling;\r\n if LastChild.NextSibling <> nil then\r\n LastChild.NextSibling.PrevSibling := LastChild;\r\n ForEachAt(LastChild.ParentZone, UpdateZone, tskForward);\r\n end;\r\n Zone.ParentZone.Free;\r\n Sibling.Free;\r\n end;\r\n end;\r\n end\r\n else\r\n begin\r\n if Zone.PrevSibling = nil then\r\n begin\r\n Zone.ParentZone.ChildZones := Zone.NextSibling;\r\n if Zone.NextSibling <> nil then\r\n begin\r\n Zone.NextSibling.PrevSibling := nil;\r\n Zone.NextSibling.Update;\r\n end;\r\n end\r\n else\r\n begin\r\n Zone.PrevSibling.NextSibling := Zone.NextSibling;\r\n if Zone.NextSibling <> nil then\r\n Zone.NextSibling.PrevSibling := Zone.PrevSibling;\r\n Zone.PrevSibling.ZoneLimit := Zone.ZoneLimit;\r\n Zone.PrevSibling.Update;\r\n end;\r\n ForEachAt(Zone.ParentZone, UpdateZone, tskForward);\r\n end;\r\n //LOOP:\r\n Zone.Free;\r\n end;\r\n SetNewBounds(nil);\r\n UpdateAll;\r\nend;\r\n\r\nprocedure TJvDockTree.ResetBounds(Force: Boolean);\r\nvar\r\n R: TRect;\r\nbegin\r\n if not (csLoading in FDockSite.ComponentState) and\r\n (FTopZone <> nil) and (FDockSite.DockClientCount > 0) then\r\n begin\r\n R := FDockSite.ClientRect;\r\n TWinControlAccessProtected(FDockSite).AdjustClientRect(R);\r\n if Force or (not CompareMem(@R, @FPreviousRect, SizeOf(TRect))) then\r\n begin\r\n FPreviousRect := R;\r\n case FTopZone.Orientation of\r\n doHorizontal:\r\n begin\r\n FTopZone.ZoneLimit := R.Right - R.Left;\r\n if R.Bottom - R.Top > 0 then\r\n TopXYLimit := R.Bottom - R.Top;\r\n end;\r\n doVertical:\r\n begin\r\n FTopZone.ZoneLimit := R.Bottom - R.Top;\r\n if R.Right - R.Left > 0 then\r\n TopXYLimit := R.Right - R.Left;\r\n end;\r\n end;\r\n SetNewBounds(nil);\r\n if FUpdateCount = 0 then\r\n ForEachAt(nil, UpdateZone, tskForward);\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockTree.ScaleZone(Zone: TJvDockZone);\r\nbegin\r\n FParentLimit := 0;\r\n ScaleChildZone(Zone);\r\nend;\r\n\r\nprocedure TJvDockTree.SaveToStream(Stream: TStream);\r\nbegin\r\n Stream.Write(FVersion, SizeOf(FVersion));\r\n Stream.Write(FTopXYLimit, SizeOf(FTopXYLimit));\r\n DoSaveZone(Stream, FTopZone, 0);\r\n Stream.Write(TreeStreamEndFlag, SizeOf(TreeStreamEndFlag));\r\nend;\r\n\r\nprocedure TJvDockTree.SetNewBounds(Zone: TJvDockZone);\r\n\r\n procedure DoSetNewBounds(Zone: TJvDockZone);\r\n begin\r\n if Zone <> nil then\r\n begin\r\n if (Zone.VisibleNextSiblingCount = 0) and (Zone <> FTopZone) then\r\n begin\r\n if Zone.ParentZone = FTopZone then\r\n Zone.ZoneLimit := FTopXYLimit\r\n else\r\n Zone.ZoneLimit := Zone.ParentZone.ParentZone.FZoneLimit;\r\n end;\r\n if Zone.ChildZones <> nil then\r\n DoSetNewBounds(Zone.ChildZones);\r\n if Zone.NextSibling <> nil then\r\n DoSetNewBounds(Zone.NextSibling);\r\n end;\r\n end;\r\n\r\nbegin\r\n if JvGlobalDockIsLoading then\r\n Exit;\r\n if Zone = nil then\r\n Zone := FTopZone.ChildZones;\r\n DoSetNewBounds(Zone);\r\n\r\n FDockSite.Invalidate;\r\nend;\r\n\r\nprocedure TJvDockTree.SetReplacingControl(Control: TControl);\r\nbegin\r\n FReplacementZone := FindControlZone(Control);\r\nend;\r\n\r\nprocedure TJvDockTree.ShiftZone(Zone: TJvDockZone);\r\nbegin\r\n if (Zone <> nil) and (Zone <> FTopZone) and\r\n (Zone.ParentZone.Orientation = FShiftScaleOrientation) then\r\n begin\r\n Inc(Zone.FZoneLimit, FShiftBy);\r\n if Zone.LimitSize < FMinSize then\r\n Zone.FZoneLimit := Zone.LimitBegin + FMinSize;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockTree.SplitterMouseDown(OnZone: TJvDockZone; MousePos: TPoint);\r\nbegin\r\n FSizingZone := OnZone;\r\n Mouse.Capture := FDockSite.Handle;\r\n FSizingWnd := FDockSite.Handle;\r\n FSizingDC := GetDCEx(FSizingWnd, 0, DCX_CACHE or DCX_CLIPSIBLINGS or DCX_LOCKWINDOWUPDATE);\r\n FSizePos := MousePos;\r\n DrawSizeSplitter;\r\nend;\r\n\r\nprocedure TJvDockTree.SplitterMouseUp;\r\n\r\n procedure SetSiblingZoneSize(PosXY: Integer);\r\n var\r\n AZone: TJvDockZone;\r\n PrevCount, NextCount: Integer;\r\n begin\r\n PrevCount := FSizingZone.PrevSiblingCount;\r\n AZone := FSizingZone.ParentZone.ChildZones;\r\n while (AZone <> nil) and (AZone <> FSizingZone) do\r\n begin\r\n if AZone.ZoneLimit >= PosXY - PrevCount * MinSize +\r\n Integer(AZone.PrevSibling = nil) * (SplitterWidth div 2) then\r\n begin\r\n AZone.ZoneLimit := PosXY - PrevCount * MinSize +\r\n Integer(AZone.PrevSibling = nil) * (SplitterWidth div 2);\r\n Break;\r\n end;\r\n Dec(PrevCount);\r\n AZone := AZone.NextSibling;\r\n end;\r\n\r\n AZone := AZone.NextSibling;\r\n while PrevCount > 0 do\r\n begin\r\n Dec(PrevCount);\r\n AZone.ZoneLimit := AZone.LimitBegin + MinSize;\r\n AZone := AZone.NextSibling;\r\n end;\r\n\r\n NextCount := 1;\r\n AZone := FSizingZone.NextSibling;\r\n while AZone <> nil do\r\n begin\r\n if AZone.ZoneLimit <= PosXY + NextCount * MinSize +\r\n Integer(AZone.NextSibling <> nil) * (SplitterWidth div 2) then\r\n AZone.ZoneLimit := PosXY + NextCount * MinSize +\r\n Integer(AZone.NextSibling <> nil) * (SplitterWidth div 2);\r\n Inc(NextCount);\r\n AZone := AZone.NextSibling;\r\n end;\r\n end;\r\n\r\nbegin\r\n Mouse.Capture := 0;\r\n DrawSizeSplitter;\r\n ReleaseDC(FSizingWnd, FSizingDC);\r\n if FSizingZone.ParentZone.Orientation = doHorizontal then\r\n begin\r\n FSizingZone.ZoneLimit := FSizePos.Y + (SplitterWidth div 2);\r\n SetSiblingZoneSize(FSizePos.Y);\r\n end\r\n else\r\n begin\r\n FSizingZone.ZoneLimit := FSizePos.X + (SplitterWidth div 2);\r\n SetSiblingZoneSize(FSizePos.X);\r\n end;\r\n SetNewBounds(FSizingZone.ParentZone);\r\n ForEachAt(FSizingZone.ParentZone, UpdateZone, tskForward);\r\n FSizingZone := nil;\r\nend;\r\n\r\nprocedure TJvDockTree.UpdateAll;\r\nbegin\r\n if (FUpdateCount = 0) and (FDockSite.DockClientCount > 0) then\r\n ForEachAt(nil, UpdateZone, tskForward);\r\nend;\r\n\r\nprocedure TJvDockTree.UpdateZone(Zone: TJvDockZone);\r\nbegin\r\n if FUpdateCount = 0 then\r\n Zone.Update;\r\nend;\r\n\r\nprocedure TJvDockTree.DrawSizeSplitter;\r\nvar\r\n R: TRect;\r\n PrevBrush: HBrush;\r\nbegin\r\n if FSizingZone <> nil then\r\n begin\r\n if FSizingZone.ParentZone.Orientation = doHorizontal then\r\n begin\r\n R.Left := FSizingZone.Left;\r\n R.Top := FSizePos.Y - (SplitterWidth div 2);\r\n R.Right := R.Left + FSizingZone.Width;\r\n R.Bottom := R.Top + SplitterWidth;\r\n end\r\n else\r\n begin\r\n R.Left := FSizePos.X - (SplitterWidth div 2);\r\n R.Top := FSizingZone.Top;\r\n R.Right := R.Left + SplitterWidth;\r\n R.Bottom := R.Top + FSizingZone.Height;\r\n end;\r\n PrevBrush := SelectObject(FSizingDC, FBrush.Handle);\r\n PatBlt(FSizingDC, R.Left, R.Top, R.Right - R.Left, R.Bottom - R.Top, PATINVERT);\r\n SelectObject(FSizingDC, PrevBrush);\r\n end;\r\nend;\r\n\r\nfunction TJvDockTree.GetSplitterLimit(AZone: TJvDockZone; IsCurrent, IsMin: Boolean): Integer;\r\nbegin\r\n if IsCurrent then\r\n Result := AZone.GetSplitterLimit(False)\r\n else\r\n if AZone.AfterClosestVisibleZone <> nil then\r\n Result := AZone.AfterClosestVisibleZone.GetSplitterLimit(True)\r\n else\r\n Result := AZone.ZoneLimit + AZone.LimitSize;\r\nend;\r\n\r\nprocedure TJvDockTree.ControlVisibilityChanged(Control: TControl;\r\n Visible: Boolean);\r\nbegin\r\n if Visible then\r\n ShowControl(Control)\r\n else\r\n HideControl(Control);\r\nend;\r\n\r\nprocedure TJvDockTree.WindowProc(var Msg: TMessage);\r\nvar\r\n TempZone: TJvDockZone;\r\n HitTestValue: Integer;\r\nbegin\r\n case Msg.Msg of\r\n CM_DOCKNOTIFICATION:\r\n with TCMDockNotification(Msg) do\r\n if NotifyRec.ClientMsg = CM_VISIBLECHANGED then\r\n ControlVisibilityChanged(Client, Boolean(NotifyRec.MsgWParam));\r\n WM_MOUSEMOVE:\r\n DoMouseMove(TWMMouse(Msg), TempZone, HitTestValue);\r\n WM_LBUTTONDBLCLK:\r\n DoLButtonDbClk(TWMMouse(Msg), TempZone, HitTestValue);\r\n WM_LBUTTONDOWN:\r\n if DoLButtonDown(TWMMouse(Msg), TempZone, HitTestValue) then\r\n Exit;\r\n WM_LBUTTONUP:\r\n DoLButtonUp(TWMMouse(Msg), TempZone, HitTestValue);\r\n WM_MBUTTONDOWN:\r\n DoMButtonDown(TWMMouse(Msg), TempZone, HitTestValue);\r\n WM_MBUTTONUP:\r\n DoMButtonUp(TWMMouse(Msg), TempZone, HitTestValue);\r\n WM_RBUTTONDOWN:\r\n DoRButtonDown(TWMMouse(Msg), TempZone, HitTestValue);\r\n WM_RBUTTONUP:\r\n DoRButtonUp(TWMMouse(Msg), TempZone, HitTestValue);\r\n WM_SETCURSOR:\r\n begin\r\n DoSetCursor(TWMSetCursor(Msg), TempZone, HitTestValue);\r\n if Msg.Result = 1 then\r\n Exit;\r\n end;\r\n end;\r\n\r\n FOldWndProc(Msg);\r\n if Msg.Msg = CM_HINTSHOW then\r\n DoHintShow(TCMHintShow(Msg), TempZone, HitTestValue);\r\nend;\r\n\r\nprocedure TJvDockTree.SetGrabberSize(const Value: Integer);\r\nbegin\r\n if FGrabberSize <> Value then\r\n begin\r\n FGrabberSize := Value;\r\n UpdateAll;\r\n DockSite.Invalidate;\r\n end;\r\nend;\r\n\r\nfunction TJvDockTree.GetDockGrabbersPosition: TJvDockGrabbersPosition;\r\nbegin\r\n if DockSite.Align in [alTop, alBottom] then\r\n Result := gpLeft\r\n else\r\n Result := gpTop;\r\nend;\r\n\r\nfunction TJvDockTree.GetBottomGrabbersHTFlag(const MousePos: TPoint;\r\n out HTFlag: Integer; Zone: TJvDockZone): TJvDockZone;\r\nbegin\r\n Result := nil;\r\nend;\r\n\r\nfunction TJvDockTree.GetBorderHTFlag(const MousePos: TPoint;\r\n out HTFlag: Integer; Zone: TJvDockZone): TJvDockZone;\r\nvar\r\n ARect: TRect;\r\nbegin\r\n Result := nil;\r\n\r\n ARect := Zone.GetFrameRect;\r\n\r\n if PtInRect(ARect, MousePos) then\r\n begin\r\n InflateRect(ARect, -BorderWidth, -BorderWidth);\r\n if not PtInRect(ARect, MousePos) then\r\n begin\r\n Result := Zone;\r\n HTFlag := HTBORDER;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJvDockTree.GetLeftGrabbersHTFlag(const MousePos: TPoint;\r\n out HTFlag: Integer; Zone: TJvDockZone): TJvDockZone;\r\nbegin\r\n if (MousePos.X >= Zone.Left + BorderWidth) and (MousePos.X <= Zone.Left + BorderWidth + GrabberSize) and\r\n (MousePos.Y >= Zone.Top) and (MousePos.Y <= Zone.Top + Zone.Height) then\r\n begin\r\n Result := Zone;\r\n if MousePos.Y < Zone.ChildControl.Top + GrabberSize + 3 then\r\n HTFlag := HTCLOSE\r\n else\r\n HTFlag := HTCAPTION;\r\n end\r\n else\r\n Result := nil;\r\nend;\r\n\r\nfunction TJvDockTree.GetRightGrabbersHTFlag(const MousePos: TPoint;\r\n out HTFlag: Integer; Zone: TJvDockZone): TJvDockZone;\r\nbegin\r\n Result := nil;\r\nend;\r\n\r\nfunction TJvDockTree.GetTopGrabbersHTFlag(const MousePos: TPoint;\r\n out HTFlag: Integer; Zone: TJvDockZone): TJvDockZone;\r\nbegin\r\n if (MousePos.Y >= Zone.Top + BorderWidth) and (MousePos.Y <= Zone.Top + BorderWidth + GrabberSize) and\r\n (MousePos.X >= Zone.Left) and (MousePos.X <= Zone.Left + Zone.Width) then\r\n begin\r\n Result := Zone;\r\n with Zone.ChildControl do\r\n if MousePos.X > Left + Width - GrabberSize - 3 then\r\n HTFlag := HTCLOSE\r\n else\r\n HTFlag := HTCAPTION;\r\n end\r\n else\r\n Result := nil;\r\nend;\r\n\r\nfunction TJvDockTree.GetActiveControl: TControl;\r\nbegin\r\n Result := Screen.ActiveControl;\r\n if not DockSite.ContainsControl(Result) then\r\n Result := nil;\r\nend;\r\n\r\nprocedure TJvDockTree.SetActiveControl(const Value: TControl);\r\nbegin\r\n {ignore}\r\nend;\r\n\r\nfunction TJvDockTree.GetGrabberSize: Integer;\r\nbegin\r\n Result := FGrabberSize;\r\nend;\r\n\r\nfunction TJvDockTree.FindControlZoneAndLevel(Control: TControl;\r\n var CtlLevel: Integer; IncludeHide: Boolean): TJvDockZone;\r\nvar\r\n CtlZone: TJvDockZone;\r\n\r\n procedure DoFindControlZone(StartZone: TJvDockZone; Level: Integer);\r\n begin\r\n if (StartZone.ChildControl = Control) and (StartZone.Visibled or IncludeHide) then\r\n begin\r\n CtlZone := StartZone;\r\n CtlLevel := Level;\r\n end\r\n else\r\n begin\r\n if (CtlZone = nil) and (StartZone.NextSibling <> nil) then\r\n DoFindControlZone(StartZone.NextSibling, Level);\r\n\r\n if (CtlZone = nil) and (StartZone.ChildZones <> nil) then\r\n DoFindControlZone(StartZone.ChildZones, Level + 1);\r\n if (CtlZone <> nil) and (not CtlZone.Visibled) then\r\n CtlZone := nil;\r\n end;\r\n end;\r\n\r\nbegin\r\n CtlZone := nil;\r\n CtlLevel := 0;\r\n if (Control <> nil) and (FTopZone <> nil) then\r\n DoFindControlZone(FTopZone, 0);\r\n Result := CtlZone;\r\nend;\r\n\r\nprocedure TJvDockTree.SetDockSplitterWidth(const Value: Integer);\r\nbegin\r\n if FSplitterWidth <> Value then\r\n begin\r\n FSplitterWidth := Value;\r\n UpdateAll;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockTree.SetTopZone(const Value: TJvDockZone);\r\nbegin\r\n FTopZone := Value;\r\nend;\r\n\r\nprocedure TJvDockTree.SetTopXYLimit(const Value: Integer);\r\nbegin\r\n FTopXYLimit := Value;\r\nend;\r\n\r\nprocedure TJvDockTree.DoMouseMove(var Msg: TWMMouse;\r\n var Zone: TJvDockZone; out HTFlag: Integer);\r\nvar\r\n Control: TControl;\r\n DockClient: TJvDockClient;\r\nbegin\r\n if FSizingZone <> nil then\r\n begin\r\n DrawSizeSplitter;\r\n FSizePos := SmallPointToPoint(Msg.Pos);\r\n CalcSplitterPos;\r\n DrawSizeSplitter;\r\n end;\r\n\r\n Zone := InternalHitTest(SmallPointToPoint(Msg.Pos), HTFlag);\r\n if Zone <> nil then\r\n begin\r\n DockClient := FindDockClient(Zone.ChildControl);\r\n if DockClient <> nil then\r\n DockClient.DoNCMouseMove(JvDockCreateNCMessage(DockSite,\r\n WM_NCMOUSEMOVE, HTFlag, FSizePos), msConjoin);\r\n Control := Zone.ChildControl;\r\n end\r\n else\r\n Control := nil;\r\n if (Control <> nil) and (HTFlag <> FOldHTFlag) then\r\n begin\r\n Application.HideHint;\r\n Application.HintMouseMessage(Control, TMessage(Msg));\r\n Application.ActivateHint(SmallPointToPoint(Msg.Pos));\r\n FOldHTFlag := HTFlag;\r\n end;\r\nend;\r\n\r\nfunction TJvDockTree.DoLButtonDown(var Msg: TWMMouse;\r\n var Zone: TJvDockZone; out HTFlag: Integer): Boolean;\r\nvar\r\n P: TPoint;\r\n Mesg: TMsg;\r\nbegin\r\n Result := False;\r\n P := SmallPointToPoint(Msg.Pos);\r\n\r\n Zone := InternalHitTest(P, HTFlag);\r\n if Zone <> nil then\r\n begin\r\n if HTFlag = HTSPLITTER then\r\n SplitterMouseDown(Zone, P)\r\n else\r\n if (HTFlag = HTCAPTION) or (HTFlag = HTBORDER) then\r\n begin\r\n JvGlobalDockClient := FindDockClient(Zone.ChildControl);\r\n if JvGlobalDockClient <> nil then\r\n JvGlobalDockClient.DoNCButtonDown(JvDockCreateNCMessage(DockSite,\r\n WM_NCLBUTTONDOWN, HTFlag, P), mbLeft, msConjoin);\r\n\r\n if (not PeekMessage(Mesg, FDockSite.Handle, WM_LBUTTONDBLCLK,\r\n WM_LBUTTONDBLCLK, PM_NOREMOVE)) and\r\n Assigned(Zone.ChildControl) then\r\n if not Zone.ChildControl.ContainsControl(Screen.ActiveControl) and Zone.ChildControl.CanFocus then\r\n Zone.ChildControl.SetFocus;\r\n if (TWinControlAccessProtected(Zone.ChildControl).DragKind = dkDock) and\r\n (TWinControlAccessProtected(Zone.ChildControl).DragMode = dmAutomatic) then\r\n BeginDrag(Zone.ChildControl, True);\r\n Result := True;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockTree.DoLButtonUp(var Msg: TWMMouse;\r\n var Zone: TJvDockZone; out HTFlag: Integer);\r\nvar\r\n P: TPoint;\r\n DockClient: TJvDockClient;\r\nbegin\r\n if FSizingZone = nil then\r\n begin\r\n P := SmallPointToPoint(Msg.Pos);\r\n Zone := InternalHitTest(P, HTFlag);\r\n if Zone <> nil then\r\n if (HTFlag <> HTSPLITTER) and (Zone.ChildControl <> nil) then\r\n begin\r\n DockClient := FindDockClient(Zone.ChildControl);\r\n if DockClient <> nil then\r\n DockClient.DoNCButtonUp(JvDockCreateNCMessage(DockSite,\r\n WM_NCLBUTTONUP, HTFlag, P), mbLeft, msConjoin);\r\n if HTFlag = HTCLOSE then\r\n begin\r\n if (DockClient <> nil) and not DockClient.EnableCloseButton then\r\n Exit;\r\n DoHideZoneChild(Zone);\r\n end;\r\n end;\r\n end\r\n else\r\n SplitterMouseUp;\r\nend;\r\n\r\nprocedure TJvDockTree.DoLButtonDbClk(var Msg: TWMMouse;\r\n var Zone: TJvDockZone; out HTFlag: Integer);\r\nvar\r\n P: TPoint;\r\nbegin\r\n P := SmallPointToPoint(Msg.Pos);\r\n Zone := InternalHitTest(P, HTFlag);\r\n if (Zone <> nil) and (Zone.ChildControl <> nil) and\r\n (HTFlag = HTCAPTION) or (HTFlag = HTBORDER) then\r\n begin\r\n if HTFlag <> HTSPLITTER then\r\n JvGlobalDockClient.DoNCButtonDblClk(JvDockCreateNCMessage(DockSite,\r\n WM_NCLBUTTONUP, HTFlag, P), mbLeft, msConjoin);\r\n if JvGlobalDockClient.CanFloat then\r\n begin\r\n JvGlobalDockManager.CancelDrag;\r\n Zone.LButtonDblClkMethod;\r\n end;\r\n Zone := nil;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockTree.DoSetCursor(var Msg: TWMSetCursor;\r\n var Zone: TJvDockZone; out HTFlag: Integer);\r\nvar\r\n P: TPoint;\r\nbegin\r\n GetCursorPos(P);\r\n P := FDockSite.ScreenToClient(P);\r\n with Msg do\r\n if (Smallint(HitTest) = HTCLIENT) and (CursorWnd = FDockSite.Handle) and\r\n (FDockSite.VisibleDockClientCount > 0) then\r\n begin\r\n Zone := InternalHitTest(P, HTFlag);\r\n if (Zone <> nil) and (HTFlag = HTSPLITTER) then\r\n begin\r\n SetSplitterCursor(Zone.ParentZone.Orientation);\r\n Result := 1;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockTree.DoHintShow(var Msg: TCMHintShow;\r\n var Zone: TJvDockZone; out HTFlag: Integer);\r\nvar\r\n Control: TWinControl;\r\n R: TRect;\r\n ADockClient: TJvDockClient;\r\n CanShow: Boolean;\r\nbegin\r\n with Msg do\r\n begin\r\n if Result = 0 then\r\n begin\r\n Zone := InternalHitTest(HintInfo^.CursorPos, HTFlag);\r\n if Zone <> nil then\r\n Control := Zone.ChildControl\r\n else\r\n Control := nil;\r\n\r\n ADockClient := FindDockClient(Control);\r\n if (ADockClient <> nil) and (not ADockClient.ShowHint) then\r\n Exit;\r\n\r\n if HTFlag = HTSPLITTER then\r\n HintInfo^.HintStr := ''\r\n else\r\n if Control <> nil then\r\n begin\r\n R := GetFrameRect(Control);\r\n if HTFlag = HTCAPTION then\r\n HintInfo^.HintStr := TWinControlAccessProtected(Control).Caption\r\n else\r\n if HTFlag = HTCLOSE then\r\n HintInfo^.HintStr := RsDockJvDockTreeCloseBtnHint\r\n else\r\n DoOtherHint(Zone, HTFlag, HintInfo^.HintStr);\r\n\r\n HintInfo^.CursorRect := R;\r\n\r\n CanShow := True;\r\n if ADockClient <> nil then\r\n ADockClient.DoFormShowHint(HTFlag, HintInfo^.HintStr, CanShow);\r\n if not CanShow then\r\n HintInfo^.HintStr := '';\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockTree.SetSplitterCursor(CursorIndex: TDockOrientation);\r\nconst\r\n SizeCursors: array [TDockOrientation] of TCursor =\r\n (crDefault, crVSplit, crHSplit);\r\nbegin\r\n Windows.SetCursor(Screen.Cursors[SizeCursors[CursorIndex]]);\r\nend;\r\n\r\nprocedure TJvDockTree.SetDockZoneClass(const Value: TJvDockZoneClass);\r\nbegin\r\n FDockZoneClass := Value;\r\nend;\r\n\r\nprocedure TJvDockTree.DoMButtonDown(var Msg: TWMMouse;\r\n var Zone: TJvDockZone; out HTFlag: Integer);\r\nvar\r\n Mesg: TWMNCHitMessage;\r\n DockClient: TJvDockClient;\r\nbegin\r\n Mesg := DoMouseEvent(Msg, Zone, HTFlag);\r\n if Mesg.Result > 0 then\r\n begin\r\n DockClient := FindDockClient(Zone.ChildControl);\r\n if DockClient <> nil then\r\n DockClient.DoNCButtonDown(Mesg, mbMiddle, msConjoin);\r\n end;\r\nend;\r\n\r\nprocedure TJvDockTree.DoMButtonUp(var Msg: TWMMouse;\r\n var Zone: TJvDockZone; out HTFlag: Integer);\r\nvar\r\n Mesg: TWMNCHitMessage;\r\n DockClient: TJvDockClient;\r\nbegin\r\n Mesg := DoMouseEvent(Msg, Zone, HTFlag);\r\n if Mesg.Result > 0 then\r\n begin\r\n DockClient := FindDockClient(Zone.ChildControl);\r\n if DockClient <> nil then\r\n DockClient.DoNCButtonUp(Mesg, mbMiddle, msConjoin);\r\n end;\r\nend;\r\n\r\nprocedure TJvDockTree.DoRButtonDown(var Msg: TWMMouse;\r\n var Zone: TJvDockZone; out HTFlag: Integer);\r\nvar\r\n Mesg: TWMNCHitMessage;\r\n DockClient: TJvDockClient;\r\nbegin\r\n Mesg := DoMouseEvent(Msg, Zone, HTFlag);\r\n if Mesg.Result > 0 then\r\n begin\r\n DockClient := FindDockClient(Zone.ChildControl);\r\n if DockClient <> nil then\r\n DockClient.DoNCButtonDown(Mesg, mbRight, msConjoin);\r\n end;\r\nend;\r\n\r\nprocedure TJvDockTree.DoRButtonUp(var Msg: TWMMouse;\r\n var Zone: TJvDockZone; out HTFlag: Integer);\r\nvar\r\n Mesg: TWMNCHitMessage;\r\n DockClient: TJvDockClient;\r\nbegin\r\n Mesg := DoMouseEvent(Msg, Zone, HTFlag);\r\n if Mesg.Result > 0 then\r\n begin\r\n DockClient := FindDockClient(Zone.ChildControl);\r\n if DockClient <> nil then\r\n DockClient.DoNCButtonUp(Mesg, mbRight, msConjoin);\r\n end;\r\nend;\r\n\r\nfunction TJvDockTree.DoMouseEvent(var Msg: TWMMouse;\r\n var Zone: TJvDockZone; out HTFlag: Integer): TWMNCHitMessage;\r\nvar\r\n Pt: TPoint;\r\nbegin\r\n Result.Result := 0;\r\n Pt := SmallPointToPoint(Msg.Pos);\r\n Zone := InternalHitTest(Pt, HTFlag);\r\n if (Zone <> nil) and (Zone.ChildControl <> nil) and (HTFlag <> HTSPLITTER) then\r\n begin\r\n Result := JvDockCreateNCMessage(DockSite, Msg.Msg + WM_NCMOUSEFIRST - WM_MOUSEFIRST, HTFlag, Pt);\r\n Result.Result := 1;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockTree.DoMButtonDbClk(var Msg: TWMMouse;\r\n var Zone: TJvDockZone; out HTFlag: Integer);\r\nvar\r\n Pt: TPoint;\r\n DockClient: TJvDockClient;\r\nbegin\r\n Pt := SmallPointToPoint(Msg.Pos);\r\n Zone := InternalHitTest(Pt, HTFlag);\r\n if (Zone <> nil) and (Zone.ChildControl <> nil) and (HTFlag = HTCAPTION) then\r\n if HTFlag <> HTSPLITTER then\r\n begin\r\n DockClient := FindDockClient(Zone.ChildControl);\r\n if DockClient <> nil then\r\n DockClient.DoNCButtonDblClk(JvDockCreateNCMessage(\r\n DockSite, WM_NCLBUTTONUP, HTFlag, Pt), mbMiddle, msConjoin);\r\n end;\r\nend;\r\n\r\nprocedure TJvDockTree.DoRButtonDbClk(var Msg: TWMMouse;\r\n var Zone: TJvDockZone; out HTFlag: Integer);\r\nvar\r\n Pt: TPoint;\r\n DockClient: TJvDockClient;\r\nbegin\r\n Pt := SmallPointToPoint(Msg.Pos);\r\n Zone := InternalHitTest(Pt, HTFlag);\r\n if (Zone <> nil) and (Zone.ChildControl <> nil) and (HTFlag = HTCAPTION) then\r\n if HTFlag <> HTSPLITTER then\r\n begin\r\n DockClient := FindDockClient(Zone.ChildControl);\r\n if DockClient <> nil then\r\n DockClient.DoNCButtonDblClk(JvDockCreateNCMessage(\r\n DockSite, WM_NCLBUTTONUP, HTFlag, Pt), mbRight, msConjoin);\r\n end;\r\nend;\r\n\r\nfunction TJvDockTree.GetFrameRect(Control: TControl): TRect;\r\nvar\r\n NLeft, NTop: Integer;\r\nbegin\r\n if Control <> nil then\r\n begin\r\n Result := Control.BoundsRect;\r\n NLeft := Result.Left;\r\n NTop := Result.Top;\r\n AdjustDockRect(Control, Result);\r\n Dec(Result.Left, 2 * (Result.Left - Control.Left) + 1);\r\n if Result.Left < 0 then\r\n Result.Left := 0;\r\n Dec(Result.Top, 2 * (Result.Top - Control.Top));\r\n Dec(Result.Right, 2 * (Result.Right - NLeft - Control.Width));\r\n Dec(Result.Bottom, 2 * (Result.Bottom - NTop - Control.Height));\r\n end\r\n else\r\n raise Exception.CreateRes(@RsEDockControlCannotIsNil);\r\nend;\r\n\r\nfunction TJvDockTree.GetSplitterRect(Zone: TJvDockZone): TRect;\r\nvar\r\n A, B, C, D: Integer;\r\nbegin\r\n if (Zone <> nil) and Zone.Visibled and (Zone.ParentZone <> nil) and\r\n (Zone.VisibleNextSiblingCount >= 1) and\r\n (Zone.ParentZone.Orientation <> doNoOrient) then\r\n begin\r\n A := Zone.ParentZone.LimitBegin;\r\n B := Zone.ParentZone.ZoneLimit;\r\n C := Zone.ZoneLimit - SplitterWidth;\r\n D := C + 1 * SplitterWidth;\r\n if Zone.ParentZone.Orientation = doHorizontal then\r\n Result := Rect(A, C, B, D)\r\n else\r\n if Zone.ParentZone.Orientation = doVertical then\r\n Result := Rect(C, A, D, B);\r\n end\r\n else\r\n Result := Rect(0, 0, 0, 0);\r\nend;\r\n\r\nprocedure TJvDockTree.BeginDrag(Control: TControl;\r\n Immediate: Boolean; Threshold: Integer);\r\nvar\r\n DockClient: TJvDockClient;\r\nbegin\r\n DockClient := FindDockClient(Control);\r\n if DockClient <> nil then\r\n JvGlobalDockManager.BeginDrag(Control, DockClient.DirectDrag, Threshold);\r\nend;\r\n\r\nfunction TJvDockTree.GetFrameRectEx(Control: TControl): TRect;\r\nbegin\r\n if Control <> nil then\r\n begin\r\n Result := GetFrameRect(Control);\r\n MapWindowPoints(DockSite.Handle, 0, Result, 2);\r\n end;\r\nend;\r\n\r\nprocedure TJvDockTree.DrawDockSiteRect;\r\nbegin\r\nend;\r\n\r\nprocedure TJvDockTree.SetBorderWidth(const Value: Integer);\r\nbegin\r\n if FBorderWidth <> Value then\r\n begin\r\n FBorderWidth := Value;\r\n UpdateAll;\r\n DockSite.Invalidate;\r\n end;\r\nend;\r\n\r\nfunction TJvDockTree.GetBorderWidth: Integer;\r\nbegin\r\n Result := FBorderWidth;\r\nend;\r\n\r\nfunction TJvDockTree.GetDockSplitterWidth: Integer;\r\nbegin\r\n Result := FSplitterWidth;\r\nend;\r\n\r\nprocedure TJvDockTree.DrawSplitter(Zone: TJvDockZone);\r\nvar\r\n R: TRect;\r\nbegin\r\n R := GetSplitterRect(Zone);\r\n DrawSplitterRect(R);\r\nend;\r\n\r\nfunction TJvDockTree.GetDockEdge(DockRect: TRect; MousePos: TPoint;\r\n var DropAlign: TAlign; Control: TControl): TControl;\r\nbegin\r\n Result := nil;\r\nend;\r\n\r\nfunction TJvDockTree.GetDockSiteOrientation: TDockOrientation;\r\nbegin\r\n Result := JvDockGetControlOrient(DockSite);\r\nend;\r\n\r\nprocedure TJvDockTree.BeginResizeDockSite;\r\nbegin\r\n Inc(FResizeCount);\r\nend;\r\n\r\nprocedure TJvDockTree.EndResizeDockSite;\r\nbegin\r\n Dec(FResizeCount);\r\n if FResizeCount < 0 then\r\n FResizeCount := 0;\r\nend;\r\n\r\nprocedure TJvDockTree.ScaleChildZone(Zone: TJvDockZone);\r\nbegin\r\n if (Zone <> nil) and (Zone.ParentZone <> nil) and Zone.Visibled and\r\n (Zone.ParentZone.Orientation = ShiftScaleOrientation) then\r\n Zone.ZoneLimit := Integer(Round(Zone.ZoneLimit * ScaleBy + FParentLimit * (1 - ScaleBy)));\r\nend;\r\n\r\nprocedure TJvDockTree.ScaleSiblingZone(Zone: TJvDockZone);\r\nbegin\r\n ScaleChildZone(Zone);\r\nend;\r\n\r\nfunction TJvDockTree.GetDockSiteSize: Integer;\r\nbegin\r\n case DockSiteOrientation of\r\n doVertical:\r\n Result := DockSite.Width;\r\n doHorizontal:\r\n Result := DockSite.Height;\r\n else\r\n raise Exception.CreateRes(@RsEDockCannotGetValueWithNoOrient);\r\n end;\r\nend;\r\n\r\nprocedure TJvDockTree.SetDockSiteSize(const Value: Integer);\r\nbegin\r\n DockSite.Parent.DisableAlign;\r\n try\r\n // if we have a docksite aligned to alClient it's unnecessary\r\n // to set the DockSite Size\r\n if DockSite.Align = alClient then\r\n Exit;\r\n\r\n if DockSite.Align in [alRight, alBottom] then\r\n DockSiteBegin := DockSiteBegin - (Value - DockSiteSize);\r\n case DockSiteOrientation of\r\n doVertical:\r\n DockSite.Width := Value;\r\n doHorizontal:\r\n DockSite.Height := Value;\r\n else\r\n raise Exception.CreateRes(@RsEDockCannotSetValueWithNoOrient);\r\n end;\r\n finally\r\n DockSite.Parent.EnableAlign;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockTree.SetMinSize(const Value: Integer);\r\nbegin\r\n FMinSize := Value;\r\nend;\r\n\r\nfunction TJvDockTree.GetDockSiteBegin: Integer;\r\nbegin\r\n case DockSiteOrientation of\r\n doVertical:\r\n Result := DockSite.Left;\r\n doHorizontal:\r\n Result := DockSite.Top;\r\n else\r\n raise Exception.CreateRes(@RsEDockCannotGetValueWithNoOrient);\r\n end;\r\nend;\r\n\r\nprocedure TJvDockTree.SetDockSiteBegin(const Value: Integer);\r\nbegin\r\n case DockSiteOrientation of\r\n doVertical:\r\n DockSite.Left := Value;\r\n doHorizontal:\r\n DockSite.Top := Value;\r\n else\r\n raise Exception.CreateRes(@RsEDockCannotSetValueWithNoOrient);\r\n end;\r\nend;\r\n\r\nfunction TJvDockTree.GetDockSiteSizeAlternate: Integer;\r\nbegin\r\n case DockSiteOrientation of\r\n doVertical:\r\n Result := DockSite.Height;\r\n doHorizontal:\r\n Result := DockSite.Width;\r\n else\r\n raise Exception.CreateRes(@RsEDockCannotGetValueWithNoOrient);\r\n end;\r\nend;\r\n\r\nprocedure TJvDockTree.SetDockSiteSizeAlternate(const Value: Integer);\r\nbegin\r\n case DockSiteOrientation of\r\n doVertical:\r\n DockSite.Height := Value;\r\n doHorizontal:\r\n DockSite.Width := Value;\r\n else\r\n raise Exception.CreateRes(@RsEDockCannotSetValueWithNoOrient);\r\n end;\r\nend;\r\n\r\nprocedure TJvDockTree.CalcSplitterPos;\r\nvar\r\n MinWidth: Integer;\r\n TestLimit: Integer;\r\nbegin\r\n MinWidth := MinSize;\r\n if FSizingZone.ParentZone.Orientation = doHorizontal then\r\n begin\r\n TestLimit := GetSplitterLimit(FSizingZone, True, False) + MinWidth;\r\n if FSizePos.Y <= TestLimit then\r\n FSizePos.Y := TestLimit;\r\n TestLimit := GetSplitterLimit(FSizingZone, False, True) - MinWidth - SplitterWidth;\r\n if FSizePos.Y >= TestLimit then\r\n FSizePos.Y := TestLimit;\r\n end\r\n else\r\n begin\r\n TestLimit := GetSplitterLimit(FSizingZone, True, False) + MinWidth;\r\n if FSizePos.X <= TestLimit then\r\n FSizePos.X := TestLimit;\r\n TestLimit := GetSplitterLimit(FSizingZone, False, True) - MinWidth - SplitterWidth;\r\n if FSizePos.X >= TestLimit then\r\n FSizePos.X := TestLimit;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockTree.DoSaveZone(Stream: TStream; Zone: TJvDockZone; Level: Integer);\r\nbegin\r\n Stream.Write(Level, SizeOf(Level));\r\n CustomSaveZone(Stream, Zone);\r\n\r\n if Zone.ChildZones <> nil then\r\n DoSaveZone(Stream, Zone.ChildZones, Level + 1);\r\n if Zone.NextSibling <> nil then\r\n DoSaveZone(Stream, Zone.NextSibling, Level);\r\nend;\r\n\r\nprocedure TJvDockTree.WriteControlName(Stream: TStream; const ControlName: string);\r\nvar\r\n NameLen: Longint;\r\n UTF8ControlName: UTF8String;\r\nbegin\r\n UTF8ControlName := UTF8Encode(ControlName);\r\n\r\n NameLen := Length(UTF8ControlName);\r\n Stream.Write(NameLen, SizeOf(NameLen));\r\n if NameLen > 0 then\r\n Stream.Write(UTF8ControlName[1], NameLen);\r\nend;\r\n\r\nprocedure TJvDockTree.DoLoadZone(Stream: TStream);\r\nvar\r\n Level, LastLevel, I: Integer;\r\n Zone, LastZone, NextZone: TJvDockZone;\r\nbegin\r\n LastLevel := 0;\r\n LastZone := nil;\r\n while True do\r\n begin\r\n if Stream.Read(Level, SizeOf(Level)) <> SizeOf(Level) then\r\n Break;\r\n if Level <= TreeStreamEndFlag then // stream end and invalid data\r\n Break;\r\n Zone := FDockZoneClass.Create(Self);\r\n CustomLoadZone(Stream, Zone);\r\n if Zone = nil then\r\n Continue;\r\n\r\n if (Level = 0) or (LastZone = nil) then\r\n FTopZone := Zone\r\n else\r\n if Level = LastLevel then\r\n begin\r\n LastZone.NextSibling := Zone;\r\n Zone.FPrevSibling := LastZone;\r\n Zone.FParentZone := LastZone.FParentZone;\r\n end\r\n else\r\n if Level > LastLevel then\r\n begin\r\n LastZone.ChildZones := Zone;\r\n Zone.FParentZone := LastZone;\r\n end\r\n else\r\n if Level < LastLevel then\r\n begin\r\n NextZone := LastZone;\r\n for I := 1 to LastLevel - Level do\r\n if NextZone <> nil then\r\n NextZone := NextZone.FParentZone;\r\n if NextZone <> nil then\r\n NextZone.NextSibling := Zone;\r\n if (Zone <> nil) and (NextZone <> nil) then\r\n begin\r\n Zone.FPrevSibling := NextZone;\r\n Zone.FParentZone := NextZone.FParentZone;\r\n end;\r\n end;\r\n LastLevel := Level;\r\n LastZone := Zone;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockTree.ReadControlName(Stream: TStream; var ControlName: string);\r\nvar\r\n Size: Longint;\r\n UTF8ControlName: UTF8String;\r\nbegin\r\n ControlName := '';\r\n Size := 0;\r\n Stream.Read(Size, SizeOf(Size));\r\n if Size > 0 then\r\n begin\r\n SetLength(UTF8ControlName, Size);\r\n Stream.Read(UTF8ControlName[1], Size);\r\n ControlName := UTF8ToString(UTF8ControlName);\r\n end;\r\nend;\r\n\r\nprocedure TJvDockTree.CustomLoadZone(Stream: TStream; var Zone: TJvDockZone);\r\nvar\r\n CompName: string;\r\nbegin\r\n with Stream do\r\n begin\r\n Read(Zone.FOrientation, SizeOf(Zone.Orientation));\r\n Read(Zone.FZoneLimit, SizeOf(Zone.FZoneLimit));\r\n Read(Zone.FVisibled, SizeOf(Zone.Visibled));\r\n Read(Zone.FControlVisibled, SizeOf(Zone.FControlVisibled));\r\n Read(Zone.FVisibleSize, SizeOf(Zone.VisibleSize));\r\n Read(Zone.FIsInside, SizeOf(Zone.FIsInside));\r\n ReadControlName(Stream, CompName);\r\n if CompName <> '' then\r\n if not Zone.SetControlName(CompName) then\r\n begin\r\n Zone.Free;\r\n Zone := nil;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockTree.CustomSaveZone(Stream: TStream; Zone: TJvDockZone);\r\nvar\r\n AVisible: Boolean;\r\nbegin\r\n Stream.Write(Zone.Orientation, SizeOf(Zone.Orientation));\r\n Stream.Write(Zone.ZoneLimit, SizeOf(Zone.ZoneLimit));\r\n\r\n if Zone.ChildControl <> nil then\r\n AVisible := Zone.ChildControl.Visible;\r\n Stream.Write(Zone.Visibled, SizeOf(Zone.Visibled));\r\n\r\n AVisible := False;\r\n if Zone.ChildControl <> nil then\r\n AVisible := Zone.ChildControl.Visible;\r\n Stream.Write(AVisible, SizeOf(AVisible));\r\n\r\n Stream.Write(Zone.VisibleSize, SizeOf(Zone.VisibleSize));\r\n\r\n Zone.IsInside := True;\r\n if (Zone.ChildControl <> nil) and (Zone.ChildControl.HostDockSite <> DockSite) and\r\n not (DockSite is TJvDockVSPopupPanel) then\r\n Zone.IsInside := False;\r\n Stream.Write(Zone.IsInside, SizeOf(Zone.IsInside));\r\n\r\n WriteControlName(Stream, Zone.GetControlName);\r\nend;\r\n\r\nprocedure TJvDockTree.SetDockSiteSizeWithOrientation(Orient: TDockOrientation;\r\n const Value: Integer);\r\nbegin\r\n case Orient of\r\n doVertical:\r\n DockSite.Width := Value;\r\n doHorizontal:\r\n DockSite.Height := Value;\r\n else\r\n raise Exception.CreateRes(@RsEDockCannotSetValueWithNoOrient);\r\n end;\r\nend;\r\n\r\nprocedure TJvDockTree.DoOtherHint(Zone: TJvDockZone;\r\n HTFlag: Integer; var HintStr: string);\r\nbegin\r\nend;\r\n\r\nfunction TJvDockTree.GetHTFlag(MousePos: TPoint): Integer;\r\nvar\r\n Zone: TJvDockZone;\r\nbegin\r\n Zone := InternalHitTest(MousePos, Result);\r\n if Zone = nil then\r\n Result := HTNONE;\r\nend;\r\n\r\nprocedure TJvDockTree.GetSiteInfo(Client: TControl;\r\n var InfluenceRect: TRect; MousePos: TPoint; var CanDock: Boolean);\r\nbegin\r\n GetWindowRect(DockSite.Handle, InfluenceRect);\r\n InflateRect(InfluenceRect, DefExpandoRect, DefExpandoRect);\r\nend;\r\n\r\nfunction TJvDockTree.GetDockRect: TRect;\r\nbegin\r\n Result := FDockRect;\r\nend;\r\n\r\nprocedure TJvDockTree.SetDockRect(const Value: TRect);\r\nbegin\r\n FDockRect := Value;\r\nend;\r\n\r\nfunction TJvDockTree.GetDockAlign(Client: TControl; var DropCtl: TControl): TAlign;\r\nvar\r\n CRect, DRect: TRect;\r\nbegin\r\n Result := alRight;\r\n if DropCtl <> nil then\r\n begin\r\n CRect := Client.BoundsRect;\r\n DRect := DropCtl.BoundsRect;\r\n if (CRect.Top <= DRect.Top) and (CRect.Bottom < DRect.Bottom) and\r\n (CRect.Right >= DRect.Right) then\r\n Result := alTop\r\n else\r\n if (CRect.Left <= DRect.Left) and (CRect.Right < DRect.Right) and\r\n (CRect.Bottom >= DRect.Bottom) then\r\n Result := alLeft\r\n else\r\n if CRect.Top >= ((DRect.Top + DRect.Bottom) div 2) then\r\n Result := alBottom;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockTree.HideControl(Control: TControl);\r\nvar\r\n Z: TJvDockZone;\r\nbegin\r\n if ReplacementZone <> nil then\r\n Exit;\r\n Z := FindControlZone(Control);\r\n if Z <> nil then\r\n begin\r\n if Z = FReplacementZone then\r\n Z.ChildControl := nil\r\n else\r\n begin\r\n if TopZone.VisibleChildTotal = 1 then\r\n Z.Remove(TopXYLimit, True)\r\n else\r\n Z.Remove(Z.LimitSize, True);\r\n end;\r\n Control.DockOrientation := doNoOrient;\r\n SetNewBounds(nil);\r\n UpdateAll;\r\n\r\n FDockSite.Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockTree.ShowControl(Control: TControl);\r\nvar\r\n Z: TJvDockZone;\r\nbegin\r\n if ReplacementZone <> nil then\r\n Exit;\r\n Z := FindControlZone(Control, True);\r\n if Z <> nil then\r\n Z.Insert(Z.VisibleSize, False);\r\n\r\n SetNewBounds(nil);\r\n UpdateAll;\r\n DockSite.Invalidate;\r\nend;\r\n\r\nprocedure TJvDockTree.DoGetNextLimit(Zone, AZone: TJvDockZone; var LimitResult: Integer);\r\nbegin\r\n if (Zone <> AZone) and\r\n (Zone.ParentZone.Orientation = AZone.ParentZone.Orientation) and\r\n (Zone.ZoneLimit > AZone.FZoneLimit) and ((Zone.ChildControl = nil) or\r\n ((Zone.ChildControl <> nil) and (Zone.ChildControl.Visible))) then\r\n LimitResult := Min(LimitResult, Zone.ZoneLimit);\r\n if Zone.NextSibling <> nil then\r\n DoGetNextLimit(Zone.NextSibling, AZone, LimitResult);\r\n\r\n if Zone.ChildZones <> nil then\r\n DoGetNextLimit(Zone.ChildZones, AZone, LimitResult);\r\nend;\r\n\r\nprocedure TJvDockTree.UpdateChild(Zone: TJvDockZone);\r\nbegin\r\n if (FUpdateCount = 0) and (FDockSite.DockClientCount > 0) then\r\n ForEachAt(Zone, UpdateZone, tskForward);\r\nend;\r\n\r\nfunction TJvDockTree.GetDockClientLimit(Orient: TDockOrientation; IsMin: Boolean): Integer;\r\nvar\r\n Zone: TJvDockZone;\r\nbegin\r\n Result := 0;\r\n if TopZone.ChildCount = 1 then\r\n Result := Integer(not IsMin) * DockSiteSizeWithOrientation[Orient]\r\n else\r\n begin\r\n if IsMin then\r\n begin\r\n if TopZone.Orientation = Orient then\r\n Zone := TopZone.LastVisibleChildZone\r\n else\r\n Zone := TopZone;\r\n if Zone <> nil then\r\n Result := Zone.LimitBegin;\r\n end\r\n else\r\n begin\r\n if TopZone.Orientation = Orient then\r\n Zone := TopZone.FirstVisibleChildZone\r\n else\r\n Zone := TopZone;\r\n if Zone <> nil then\r\n Result := Zone.ZoneLimit;\r\n end;\r\n\r\n TopZone.DoGetSplitterLimit(Orient, IsMin, Result);\r\n end;\r\nend;\r\n\r\nfunction TJvDockTree.GetDockSiteSizeWithOrientation(Orient: TDockOrientation): Integer;\r\nbegin\r\n case Orient of\r\n doVertical:\r\n Result := DockSite.Width;\r\n doHorizontal:\r\n Result := DockSite.Height;\r\n else\r\n raise Exception.CreateRes(@RsEDockCannotGetValueWithNoOrient);\r\n end;\r\nend;\r\n\r\nfunction TJvDockTree.GetMinSize: Integer;\r\nbegin\r\n Result := FMinSize;\r\nend;\r\n\r\nprocedure TJvDockTree.GetCaptionRect(var Rect: TRect);\r\nbegin\r\n Rect.Left := 0;\r\n Rect.Top := 0;\r\n Rect.Right := 0;\r\n Rect.Bottom := 0;\r\nend;\r\n\r\nprocedure TJvDockTree.HideAllControl;\r\n\r\n procedure DoHideAllControl(AZone: TJvDockZone);\r\n begin\r\n if AZone <> nil then\r\n begin\r\n DoHideAllControl(AZone.NextSibling);\r\n DoHideAllControl(AZone.ChildZones);\r\n if (AZone.ChildControl <> nil) and (AZone.Visibled) then\r\n AZone.Remove(AZone.LimitSize, True);\r\n end;\r\n end;\r\n\r\nbegin\r\n if ReplacementZone <> nil then\r\n Exit;\r\n DoHideAllControl(TopZone.ChildZones);\r\n SetNewBounds(nil);\r\n UpdateAll;\r\n DockSite.Invalidate;\r\nend;\r\n\r\nprocedure TJvDockTree.HideSingleControl(Control: TControl);\r\n\r\n procedure DoHideSingleControl(AZone: TJvDockZone);\r\n begin\r\n if AZone <> nil then\r\n begin\r\n DoHideSingleControl(AZone.NextSibling);\r\n DoHideSingleControl(AZone.ChildZones);\r\n if AZone.ChildControl <> nil then\r\n if AZone.ChildControl = Control then\r\n begin\r\n if AZone.ChildControl.Visible then\r\n begin\r\n AZone.Remove(AZone.LimitSize, True);\r\n AZone.ChildControl.Visible := False;\r\n end;\r\n end\r\n else\r\n begin\r\n AZone.Insert(AZone.VisibleSize, False);\r\n AZone.ChildControl.Visible := True;\r\n end;\r\n end;\r\n end;\r\n\r\nbegin\r\n if ReplacementZone <> nil then\r\n Exit;\r\n if Control <> nil then\r\n begin\r\n DoHideSingleControl(TopZone.ChildZones);\r\n SetNewBounds(nil);\r\n UpdateAll;\r\n DockSite.Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockTree.ShowAllControl;\r\n\r\n procedure DoShowAllControl(AZone: TJvDockZone);\r\n begin\r\n if AZone <> nil then\r\n begin\r\n DoShowAllControl(AZone.NextSibling);\r\n DoShowAllControl(AZone.ChildZones);\r\n if (AZone.ChildControl <> nil) and not AZone.Visibled then\r\n AZone.Insert(AZone.VisibleSize, True);\r\n end;\r\n end;\r\n\r\nbegin\r\n if ReplacementZone <> nil then\r\n Exit;\r\n DoShowAllControl(TopZone.ChildZones);\r\n SetNewBounds(nil);\r\n UpdateAll;\r\n DockSite.Invalidate;\r\nend;\r\n\r\nprocedure TJvDockTree.ShowSingleControl(Control: TControl);\r\n\r\n procedure DoShowSingleControl(AZone: TJvDockZone);\r\n begin\r\n if AZone <> nil then\r\n begin\r\n DoShowSingleControl(AZone.NextSibling);\r\n DoShowSingleControl(AZone.ChildZones);\r\n if AZone.ChildControl <> nil then\r\n if AZone.ChildControl = Control then\r\n begin\r\n if not AZone.ChildControl.Visible then\r\n begin\r\n AZone.Insert(AZone.VisibleSize, False);\r\n AZone.ChildControl.Visible := True;\r\n end;\r\n end\r\n else\r\n begin\r\n AZone.Remove(AZone.LimitSize, True);\r\n AZone.ChildControl.Visible := False;\r\n end;\r\n end;\r\n end;\r\n\r\nbegin\r\n if ReplacementZone <> nil then\r\n Exit;\r\n if Control <> nil then\r\n begin\r\n DoShowSingleControl(TopZone.ChildZones);\r\n SetNewBounds(nil);\r\n UpdateAll;\r\n DockSite.Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockTree.DrawDockBorder(DockControl: TControl; R1, R2: TRect);\r\nbegin\r\nend;\r\n\r\nprocedure TJvDockTree.DrawDockGrabber(Control: TWinControl;\r\n const ARect: TRect);\r\n\r\n procedure DrawCloseButton(Left, Top: Integer);\r\n var\r\n ADockClient: TJvDockClient;\r\n {$IFDEF JVCLThemesEnabled}\r\n Details: TThemedElementDetails;\r\n CurrentThemeType: TThemedWindow;\r\n {$ENDIF JVCLThemesEnabled}\r\n begin\r\n ADockClient := FindDockClient(Control);\r\n if (ADockClient <> nil) and not ADockClient.EnableCloseButton then\r\n Exit;\r\n // MF\r\n {$IFDEF JVCLThemesEnabled}\r\n if ThemeServices.{$IFDEF RTL230_UP}Available{$ELSE}ThemesAvailable{$ENDIF RTL230_UP} and ThemeServices.{$IFDEF RTL230_UP}Enabled{$ELSE}ThemesEnabled{$ENDIF RTL230_UP} then\r\n begin\r\n if GrabberSize < 14 then\r\n CurrentThemeType := twSmallCloseButtonNormal\r\n else\r\n CurrentThemeType := twCloseButtonNormal;\r\n Details := ThemeServices.GetElementDetails(CurrentThemeType);\r\n ThemeServices.DrawElement(Canvas.Handle, Details, Rect(Left, Top,\r\n Left + GrabberSize - 2, Top + GrabberSize - 2));\r\n end\r\n else\r\n {$ENDIF JVCLThemesEnabled}\r\n {This is the grabber's Close button if one should be drawn. }\r\n DrawFrameControl(Canvas.Handle, Rect(Left, Top, Left + GrabberSize - 2,\r\n Top + GrabberSize - 2), DFC_CAPTION, DFCS_CAPTIONCLOSE);\r\n end;\r\n\r\n procedure DrawGrabberLine(Left, Top, Right, Bottom: Integer);\r\n begin\r\n Canvas.Pen.Color := clBtnHighlight;\r\n Canvas.MoveTo(Right, Top);\r\n Canvas.LineTo(Left, Top);\r\n Canvas.LineTo(Left, Bottom);\r\n Canvas.Pen.Color := clBtnShadow;\r\n Canvas.LineTo(Right, Bottom);\r\n Canvas.LineTo(Right, Top - 1);\r\n end;\r\n\r\nbegin\r\n case GrabbersPosition of\r\n gpLeft:\r\n begin\r\n if FGrabberBgColor <> clNone then\r\n begin { draw only if color is given }\r\n Canvas.Brush.Color := FGrabberBgColor;\r\n Canvas.Brush.Style := bsSolid;\r\n if FGrabberBottomEdgeColor <> clNone then\r\n begin\r\n Canvas.Pen.Color := FGrabberBottomEdgeColor;\r\n Canvas.Pen.Style := psSolid;\r\n end\r\n else\r\n Canvas.Pen.Style := psClear;\r\n\r\n Canvas.Rectangle(ARect.Left, ARect.Top, ARect.Left + GrabberSize, ARect.Bottom);\r\n end;\r\n\r\n DrawCloseButton(ARect.Left + BorderWidth + BorderWidth + 1, ARect.Top + BorderWidth + BorderWidth + 1);\r\n if FGrabberShowLines then\r\n begin\r\n DrawGrabberLine(ARect.Left + BorderWidth + 3, ARect.Top + GrabberSize + BorderWidth + 1,\r\n ARect.Left + BorderWidth + 5, ARect.Bottom + BorderWidth - 2);\r\n DrawGrabberLine(ARect.Left + BorderWidth + 6, ARect.Top + GrabberSize + BorderWidth + 1,\r\n ARect.Left + BorderWidth + 8, ARect.Bottom + BorderWidth - 2);\r\n end;\r\n\r\n if FGrabberBottomEdgeColor<>clNone then\r\n begin\r\n Canvas.Pen.Color := FGrabberBottomEdgeColor;\r\n Canvas.Pen.Style := psSolid;\r\n Canvas.MoveTo(ARect.Left + GrabberSize, ARect.Top);\r\n Canvas.LineTo(ARect.Left + GrabberSize, ARect.Bottom);\r\n end;\r\n end;\r\n gpTop:\r\n begin\r\n if FGrabberBgColor <> clNone then\r\n begin { draw only if color is given }\r\n Canvas.Brush.Color := FGrabberBgColor;\r\n Canvas.Brush.Style := bsSolid;\r\n if FGrabberBottomEdgeColor <> clNone then\r\n begin\r\n Canvas.Pen.Color := FGrabberBottomEdgeColor;\r\n Canvas.Pen.Style := psSolid;\r\n end\r\n else\r\n Canvas.Pen.Style := psClear;\r\n Canvas.Rectangle(ARect.Left, ARect.Top, ARect.Right, ARect.Top + GrabberSize + 2);\r\n end;\r\n\r\n DrawCloseButton(ARect.Right - GrabberSize + BorderWidth + 1, ARect.Top + BorderWidth + 1);\r\n if FGrabberShowLines then\r\n begin\r\n DrawGrabberLine(ARect.Left + BorderWidth + 4, ARect.Top + BorderWidth + BorderWidth + 3,\r\n ARect.Right - GrabberSize + BorderWidth - 4, ARect.Top + BorderWidth + 5);\r\n DrawGrabberLine(ARect.Left + BorderWidth + 4, ARect.Top + BorderWidth + BorderWidth + 6,\r\n ARect.Right - GrabberSize + BorderWidth - 4, ARect.Top + BorderWidth + 8);\r\n end;\r\n\r\n if FGrabberBottomEdgeColor <> clNone then\r\n begin\r\n Canvas.Pen.Color := FGrabberBottomEdgeColor;\r\n Canvas.Pen.Style := psSolid;\r\n Canvas.MoveTo(ARect.Left, ARect.Top + GrabberSize - 1);\r\n Canvas.LineTo(ARect.Right, ARect.Top + GrabberSize - 1);\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockTree.DrawSplitterRect(const ARect: TRect);\r\nbegin\r\n Canvas.Brush.Color := TWinControlAccessProtected(DockSite).Color;\r\n Canvas.FillRect(ARect);\r\nend;\r\n\r\nprocedure TJvDockTree.DrawZone(Zone: TJvDockZone);\r\nbegin\r\n DrawZoneBorder(Zone);\r\n DrawZoneGrabber(Zone);\r\n DrawZoneSplitter(Zone);\r\n DrawDockSiteRect;\r\nend;\r\n\r\nprocedure TJvDockTree.DrawZoneBorder(Zone: TJvDockZone);\r\nbegin\r\nend;\r\n\r\nprocedure TJvDockTree.DrawZoneGrabber(Zone: TJvDockZone);\r\nvar\r\n ChildControl: TWinControl;\r\n R: TRect;\r\nbegin\r\n if Zone = nil then\r\n Exit;\r\n ChildControl := Zone.ChildControl;\r\n if (ChildControl <> nil) and ChildControl.Visible and\r\n (ChildControl.HostDockSite = DockSite) then\r\n begin\r\n R := GetFrameRect(ChildControl);\r\n DrawDockGrabber(ChildControl, R);\r\n end;\r\nend;\r\n\r\nprocedure TJvDockTree.DrawZoneSplitter(Zone: TJvDockZone);\r\nvar\r\n R: TRect;\r\nbegin\r\n R := GetSplitterRect(Zone);\r\n if (R.Left <> 0) or (R.Right <> 0) then\r\n DrawSplitterRect(R);\r\nend;\r\n\r\nprocedure TJvDockTree.PaintDockSite;\r\nbegin\r\n ForEachAt(nil, DrawZone, tskBackward);\r\nend;\r\n\r\nfunction TJvDockTree.HasZoneWithControl(Control: TControl): Boolean;\r\nbegin\r\n Result := FindControlZone(Control, True) <> nil;\r\nend;\r\n\r\nprocedure TJvDockTree.ReplaceZoneChild(OldControl, NewControl: TControl);\r\nvar\r\n Zone: TJvDockZone;\r\nbegin\r\n Zone := FindControlZone(OldControl, True);\r\n if Zone <> nil then\r\n begin\r\n Zone.ChildControl := TWinControl(NewControl);\r\n UpdateAll;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockTree.DoHideZoneChild(AZone: TJvDockZone);\r\nvar\r\n AForm: TCustomForm;\r\nbegin\r\n if (AZone <> nil) and (AZone.ChildControl <> nil) then\r\n if AZone.ChildControl.InheritsFrom(TCustomForm) then\r\n begin\r\n AForm := TCustomForm(AZone.ChildControl);\r\n AForm.Close;\r\n end\r\n else\r\n AZone.ChildControl.Visible := False;\r\nend;\r\n\r\nprocedure TJvDockTree.DockStyleChanged(Sender: TObject);\r\nbegin\r\n BeginUpdate;\r\n try\r\n SyncWithStyle;\r\n finally\r\n EndUpdate;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockTree.SyncWithStyle;\r\nbegin\r\n GrabberSize := DockStyle.ConjoinServerOption.GrabbersSize;\r\n SplitterWidth := DockStyle.ConjoinServerOption.SplitterWidth;\r\nend;\r\n\r\nfunction TJvDockTree.GetDockStyle: TJvDockObservableStyle;\r\nbegin\r\n Result := FStyleLink.DockStyle;\r\nend;\r\n\r\nprocedure TJvDockTree.AfterConstruction;\r\nbegin\r\n inherited AfterConstruction;\r\n FStyleLink.StyleChanged;\r\nend;\r\n\r\n//=== { TJvDockAdvZone } =====================================================\r\n\r\nconstructor TJvDockAdvZone.Create(ATree: TJvDockTree);\r\nbegin\r\n inherited Create(ATree);\r\n FCloseBtnDown := False;\r\n FMouseDown := False;\r\nend;\r\n\r\ndestructor TJvDockAdvZone.Destroy;\r\nbegin\r\n if Self = TJvDockAdvTree(Tree).CloseButtonZone then\r\n TJvDockAdvTree(Tree).CloseButtonZone := nil;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvDockAdvZone.Insert(DockSize: Integer; Hide: Boolean);\r\nbegin\r\n InsertOrRemove(DockSize, True, Hide);\r\nend;\r\n\r\nprocedure TJvDockAdvZone.LButtonDblClkMethod;\r\nbegin\r\n if JvGlobalDockClient <> nil then\r\n JvGlobalDockClient.RestoreChild;\r\nend;\r\n\r\nprocedure TJvDockAdvZone.Remove(DockSize: Integer; Hide: Boolean);\r\nbegin\r\n InsertOrRemove(DockSize, False, Hide);\r\nend;\r\n\r\n// TJvDockAdvTree has been moved into its own unit because of compiler issues.\r\n// -Wpostma.\r\n\r\n//=== { TJvDockObservableStyle } =============================================\r\n\r\nprocedure TJvDockObservableStyle.AddLink(ALink: TJvDockStyleLink);\r\nbegin\r\n FLinks.Add(ALink);\r\nend;\r\n\r\nprocedure TJvDockObservableStyle.AfterConstruction;\r\nbegin\r\n inherited AfterConstruction;\r\n CreateServerOption;\r\nend;\r\n\r\nprocedure TJvDockObservableStyle.Changed;\r\nbegin\r\n SendStyleEvent;\r\nend;\r\n\r\nconstructor TJvDockObservableStyle.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n\r\n FConjoinServerOptionClass := TJvDockBasicConjoinServerOption;\r\n FTabServerOptionClass := TJvDockBasicTabServerOption;\r\n FLinks := TList.Create;\r\nend;\r\n\r\nprocedure TJvDockObservableStyle.CreateServerOption;\r\nbegin\r\n if FConjoinServerOption = nil then\r\n FConjoinServerOption := ConjoinServerOptionClass.Create(Self);\r\n if FTabServerOption = nil then\r\n FTabServerOption := TabServerOptionClass.Create(Self);\r\nend;\r\n\r\ndestructor TJvDockObservableStyle.Destroy;\r\nbegin\r\n FreeServerOption;\r\n while FLinks.Count > 0 do\r\n TJvDockStyleLink(FLinks[0]).DockStyle := nil;\r\n FreeAndNil(FLinks);\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvDockObservableStyle.FreeServerOption;\r\nbegin\r\n FConjoinServerOption.Free;\r\n FConjoinServerOption := nil;\r\n FTabServerOption.Free;\r\n FTabServerOption := nil;\r\nend;\r\n\r\nprocedure TJvDockObservableStyle.RemoveLink(ALink: TJvDockStyleLink);\r\nbegin\r\n FLinks.Remove(ALink);\r\nend;\r\n\r\nprocedure TJvDockObservableStyle.SendStyleEvent;\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := 0 to FLinks.Count - 1 do\r\n TJvDockStyleLink(FLinks[I]).StyleChanged;\r\nend;\r\n\r\nprocedure TJvDockObservableStyle.SetConjoinServerOption(\r\n Value: TJvDockBasicConjoinServerOption);\r\nbegin\r\n FConjoinServerOption.Assign(Value);\r\nend;\r\n\r\nprocedure TJvDockObservableStyle.SetTabServerOption(\r\n Value: TJvDockBasicTabServerOption);\r\nbegin\r\n FTabServerOption.Assign(Value);\r\nend;\r\n\r\n//=== { TJvDockBasicConjoinServerOption } ====================================\r\n\r\nconstructor TJvDockBasicConjoinServerOption.Create(ADockStyle: TJvDockObservableStyle);\r\nbegin\r\n inherited Create(ADockStyle);\r\n FGrabbersSize := 12;\r\n FSplitterWidth := 4;\r\nend;\r\n\r\nprocedure TJvDockBasicConjoinServerOption.Assign(Source: TPersistent);\r\nbegin\r\n if Source is TJvDockBasicConjoinServerOption then\r\n begin\r\n BeginUpdate;\r\n try\r\n GrabbersSize := TJvDockBasicConjoinServerOption(Source).FGrabbersSize;\r\n SplitterWidth := TJvDockBasicConjoinServerOption(Source).FSplitterWidth;\r\n finally\r\n EndUpdate;\r\n end;\r\n end\r\n else\r\n inherited Assign(Source);\r\nend;\r\n\r\nprocedure TJvDockBasicConjoinServerOption.SetDockSplitterWidth(const Value: TJvDockSplitterWidth);\r\nbegin\r\n if FSplitterWidth <> Value then\r\n begin\r\n FSplitterWidth := Value;\r\n Changed;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockBasicConjoinServerOption.SetGrabbersSize(const Value: TJvDockGrabbersSize);\r\nbegin\r\n if FGrabbersSize <> Value then\r\n begin\r\n FGrabbersSize := Value;\r\n Changed;\r\n end;\r\nend;\r\n\r\n//=== { TJvDockBasicServerOption } ===========================================\r\n\r\nconstructor TJvDockBasicServerOption.Create(ADockStyle: TJvDockObservableStyle);\r\nbegin\r\n // (rom) added inherited Create\r\n inherited Create;\r\n FDockStyle := ADockStyle;\r\nend;\r\n\r\nprocedure TJvDockBasicServerOption.Assign(Source: TPersistent);\r\nbegin\r\n if Source is TJvDockBasicServerOption then\r\n begin\r\n // TODO\r\n end\r\n else\r\n inherited Assign(Source);\r\nend;\r\n\r\nprocedure TJvDockBasicServerOption.BeginUpdate;\r\nbegin\r\n Inc(FUpdateCount);\r\nend;\r\n\r\nprocedure TJvDockBasicServerOption.Changed;\r\nbegin\r\n if FUpdateCount = 0 then\r\n begin\r\n FIsChanged := False;\r\n DockStyle.Changed;\r\n end\r\n else\r\n FIsChanged := True;\r\nend;\r\n\r\nprocedure TJvDockBasicServerOption.EndUpdate;\r\nbegin\r\n Dec(FUpdateCount);\r\n if (FUpdateCount = 0) and FIsChanged then\r\n Changed;\r\nend;\r\n\r\n//=== { TJvDockBasicTabServerOption } ========================================\r\n\r\nconstructor TJvDockBasicTabServerOption.Create(ADockStyle: TJvDockObservableStyle);\r\nbegin\r\n inherited Create(ADockStyle);\r\n FHotTrack := False;\r\n FTabPosition := tpTop;\r\nend;\r\n\r\nprocedure TJvDockBasicTabServerOption.Assign(Source: TPersistent);\r\nbegin\r\n if Source is TJvDockBasicTabServerOption then\r\n begin\r\n BeginUpdate;\r\n try\r\n TabPosition := TJvDockBasicTabServerOption(Source).TabPosition;\r\n HotTrack := TJvDockBasicTabServerOption(Source).HotTrack;\r\n finally\r\n EndUpdate;\r\n end;\r\n end\r\n else\r\n inherited Assign(Source);\r\nend;\r\n\r\nprocedure TJvDockBasicTabServerOption.SetHotTrack(const Value: Boolean);\r\nbegin\r\n if FHotTrack <> Value then\r\n begin\r\n FHotTrack := Value;\r\n Changed;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockBasicTabServerOption.SetTabPosition(const Value: TTabPosition);\r\nbegin\r\n if FTabPosition <> Value then\r\n begin\r\n FTabPosition := Value;\r\n Changed;\r\n end;\r\nend;\r\n\r\n//=== { TJvDockStyleLink } ===================================================\r\n\r\ndestructor TJvDockStyleLink.Destroy;\r\nbegin\r\n DockStyle := nil;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvDockStyleLink.SetDockStyle(ADockStyle: TJvDockObservableStyle);\r\nbegin\r\n if ADockStyle <> FDockStyle then\r\n begin\r\n if FDockStyle <> nil then\r\n FDockStyle.RemoveLink(Self);\r\n FDockStyle := ADockStyle;\r\n if FDockStyle <> nil then\r\n begin\r\n FDockStyle.AddLink(Self);\r\n StyleChanged;\r\n\r\n { Note: Most controls that use the style link, set the DockStyle property\r\n in the contructor. This will trigger an OnStyleChanged event, upon which\r\n the control will sync with the DockStyle. This may be a problem if the\r\n control is overriden:\r\n\r\n for example in the TJvDockTree case:\r\n\r\n (1) TJvDockVSNETTree.Create, inherited Create is called, thus:\r\n TJvDockVIDTree.Create, inherited Create is called, thus:\r\n TJvDockAdvTree.Create, inherited Create is called, thus:\r\n TJvDockTree.Create, properties are set to default\r\n (2) TJvDockTree.FStyleLink.DockStyle is set thus\r\n TJvDockVIDTree.SyncWithStyle is called; properties are set\r\n TJvDockTree.SyncStyle is called; properties are set\r\n (3) TJvDockAdvTree.Create continues, properties are set to default\r\n TJvDockVIDTree.Create continues, properties are set to default\r\n TJvDockVSNETTree.Create continues, properties are set to default\r\n\r\n Thus /after/ the SyncWithStyle call the values that are set to the\r\n TJvDock**ConjoinServerOption values are overwritten with the values in\r\n the ancestor Tree constructors.\r\n\r\n In most cases this is solved by using AfterConstruction, thus\r\n\r\n (1) TJvDockVSNETTree.Create, inherited Create is called, thus:\r\n TJvDockVIDTree.Create, inherited Create is called, thus:\r\n TJvDockAdvTree.Create, inherited Create is called, thus:\r\n TJvDockTree.Create, properties are set to default\r\n (3) TJvDockAdvTree.Create continues, properties are set to default\r\n TJvDockVIDTree.Create continues, properties are set to default\r\n TJvDockVSNETTree.Create continues, properties are set to default\r\n TJvDockTree.AfterConstruction is called thus:\r\n (2) TJvDockTree.FStyleLink.StyleChanged is called thus:\r\n TJvDockVIDTree.SyncWithStyle is called; properties are set\r\n TJvDockTree.SyncStyle is called; properties are set\r\n }\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockStyleLink.StyleChanged;\r\nbegin\r\n if Assigned(FDockStyle) and Assigned(FOnStyleChanged) then\r\n FOnStyleChanged(Self);\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvDockVCStyle.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvDockVCStyle.pas, released on 2003-12-31.\r\n\r\nThe Initial Developer of the Original Code is luxiaoban.\r\nPortions created by luxiaoban are Copyright (C) 2002,2003 luxiaoban.\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvDockVCStyle.pas 13180 2011-11-22 12:45:23Z obones $\r\n\r\nunit JvDockVCStyle;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, Messages, Classes, Graphics, Controls,\r\n JvDockControlForm, JvDockSupportControl, JvDockTree, JvDockAdvTree;\r\n\r\ntype\r\n TJvDockVCConjoinServerOption = class(TJvDockBasicConjoinServerOption)\r\n private\r\n FBorderWidth: Integer;\r\n procedure SetBorderWidth(const Value: Integer);\r\n public\r\n constructor Create(ADockStyle: TJvDockObservableStyle); override;\r\n procedure Assign(Source: TPersistent); override;\r\n published\r\n property BorderWidth: Integer read FBorderWidth write SetBorderWidth default 4;\r\n end;\r\n\r\n TJvDockVCTabServerOption = class(TJvDockBasicTabServerOption);\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvDockVCStyle = class(TJvDockAdvStyle)\r\n private\r\n FOldEachOtherDock: Boolean;\r\n protected\r\n procedure FormGetDockEdge(DockClient: TJvDockClient; Source: TJvDockDragDockObject;\r\n MousePos: TPoint; var DropAlign: TAlign); override;\r\n procedure FormStartDock(DockClient: TJvDockClient;\r\n var Source: TJvDockDragDockObject); override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n function CanSetEachOtherDocked(ADockBaseControl: TJvDockBaseControl): Boolean; override;\r\n procedure SetDockBaseControl(IsCreate: Boolean;\r\n DockBaseControl: TJvDockBaseControl); override;\r\n published\r\n property ConjoinServerOption;\r\n property TabServerOption;\r\n end;\r\n\r\n TJvDockVCSplitter = class(TJvDockSplitter)\r\n private\r\n FOldSize: Integer;\r\n protected\r\n function DoCanResize(var NewSize: Integer): Boolean; override;\r\n procedure Paint; override;\r\n procedure MouseUp(Button: TMouseButton; Shift: TShiftState;\r\n X, Y: Integer); override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n end;\r\n\r\n TJvDockVCPanel = class(TJvDockAdvPanel)\r\n protected\r\n procedure CustomGetSiteInfo(Source: TJvDockDragDockObject; Client: TControl;\r\n var InfluenceRect: TRect; MousePos: TPoint; var CanDock: Boolean); override;\r\n procedure CustomPositionDockRect(Source: TJvDockDragDockObject; X, Y: Integer); override;\r\n procedure CustomDockOver(Source: TJvDockDragDockObject; X, Y: Integer;\r\n State: TDragState; var Accept: Boolean); override;\r\n function CustomUnDock(Source: TJvDockDragDockObject; NewTarget: TWinControl; Client: TControl): Boolean; override;\r\n function GetDockEdge(MousePos: TPoint): TAlign; override;\r\n procedure CustomDockDrop(Source: TJvDockDragDockObject; X, Y: Integer); override;\r\n procedure CustomGetDockEdge(Source: TJvDockDragDockObject; MousePos: TPoint; var DropAlign: TAlign); override;\r\n end;\r\n\r\n TJvDockVCConjoinPanel = class(TJvDockConjoinPanel);\r\n TJvDockVCTabPageControl = class(TJvDockAdvTabPageControl);\r\n\r\n TJvDockZoneSizeStyle = (zssMinimum, zssNormal, zssMaximum);\r\n\r\n TJvDockVCZone = class(TJvDockAdvZone)\r\n private\r\n FZoneSizeStyle: TJvDockZoneSizeStyle;\r\n FExpandButtonDown: Boolean;\r\n procedure DoSetChildSizeStyle(ZoneSizeStyle: TJvDockZoneSizeStyle);\r\n public\r\n constructor Create(Tree: TJvDockTree); override;\r\n procedure Insert(DockSize: Integer; Hide: Boolean); override;\r\n procedure Remove(DockSize: Integer; Hide: Boolean); override;\r\n procedure InsertOrRemove(DockSize: Integer; Insert: Boolean; Hide: Boolean); override;\r\n procedure SetZoneSize(Size: Integer; Show: Boolean); override;\r\n property ZoneSizeStyle: TJvDockZoneSizeStyle read FZoneSizeStyle write FZoneSizeStyle;\r\n property ExpandButtonDown: Boolean read FExpandButtonDown write FExpandButtonDown;\r\n end;\r\n\r\n TJvDockVCTree = class(TJvDockAdvTree)\r\n private\r\n FExpandBtnZone: TJvDockVCZone;\r\n protected\r\n procedure WindowProc(var Msg: TMessage); override;\r\n procedure BeginDrag(Control: TControl;\r\n Immediate: Boolean; Threshold: Integer = -1); override;\r\n procedure ControlVisibilityChanged(Control: TControl; Visible: Boolean); override;\r\n function GetDockAlign(Client: TControl; var DropCtl: TControl): TAlign; override;\r\n function DoLButtonDown(var Msg: TWMMouse;\r\n var Zone: TJvDockZone; out HTFlag: Integer): Boolean; override;\r\n procedure DoLButtonUp(var Msg: TWMMouse;\r\n var Zone: TJvDockZone; out HTFlag: Integer); override;\r\n procedure DoMouseMove(var Msg: TWMMouse;\r\n var Zone: TJvDockZone; out HTFlag: Integer); override;\r\n procedure DoOtherHint(Zone: TJvDockZone;\r\n HTFlag: Integer; var HintStr: string); override;\r\n procedure CustomSaveZone(Stream: TStream; Zone: TJvDockZone); override;\r\n procedure CustomLoadZone(Stream: TStream; var Zone: TJvDockZone); override;\r\n procedure CalcSplitterPos; override;\r\n function GetDropOnZone(Orient: TDockOrientation; DockRect: TRect; var DropAlign: TAlign): TJvDockZone; virtual;\r\n function GetDropOnControl(Orient: TDockOrientation; Zone: TJvDockZone; DockRect: TRect;\r\n var DropAlign: TAlign; Control: TControl): TControl; virtual;\r\n function GetDockEdge(DockRect: TRect; MousePos: TPoint;\r\n var DropAlign: TAlign; Control: TControl): TControl; override;\r\n function GetLeftGrabbersHTFlag(const MousePos: TPoint;\r\n out HTFlag: Integer; Zone: TJvDockZone): TJvDockZone; override;\r\n function GetTopGrabbersHTFlag(const MousePos: TPoint;\r\n out HTFlag: Integer; Zone: TJvDockZone): TJvDockZone; override;\r\n procedure InsertControl(Control: TControl; InsertAt: TAlign; DropCtl: TControl); override;\r\n procedure InsertNewParent(NewZone, SiblingZone: TJvDockZone;\r\n ParentOrientation: TDockOrientation; InsertLast, Update: Boolean); override;\r\n procedure InsertSibling(NewZone, SiblingZone: TJvDockZone;\r\n InsertLast, Update: Boolean); override;\r\n procedure DrawDockGrabber(Control: TWinControl; const ARect: TRect); override;\r\n procedure DrawDockSiteRect; override;\r\n procedure DrawSplitterRect(const ARect: TRect); override;\r\n procedure GetCaptionRect(var Rect: TRect); override;\r\n procedure RemoveControl(Control: TControl); override;\r\n procedure RemoveZone(Zone: TJvDockZone; Hide: Boolean = True); override;\r\n procedure ResetBounds(Force: Boolean); override;\r\n procedure ResetDockZoneSizeStyle(Parent: TJvDockZone;\r\n ZoneSizeStyle: TJvDockZoneSizeStyle; Exclude: TJvDockZone);\r\n procedure ScaleZone(Zone: TJvDockZone); override;\r\n procedure ScaleChildZone(Zone: TJvDockZone); override;\r\n procedure ScaleSiblingZone(Zone: TJvDockZone); override;\r\n procedure ShiftZone(Zone: TJvDockZone); override;\r\n procedure SplitterMouseUp; override;\r\n procedure SyncWithStyle; override;\r\n public\r\n constructor Create(DockSite: TWinControl; DockZoneClass: TJvDockZoneClass; ADockStyle: TJvDockObservableStyle); override;\r\n end;\r\n\r\n TJvDockVCDragDockObject = class(TJvDockDragDockObject)\r\n private\r\n FDockOverBrush: TBrush;\r\n FDockOverFrameWidth: Integer;\r\n FCurrentState: TDragState;\r\n FPreviousState: TDragState;\r\n FPreviousTarget: Pointer;\r\n procedure SetPreviousState(const Value: TDragState);\r\n procedure SetCurrentState(const Value: TDragState);\r\n protected\r\n procedure GetBrush_PenSize_DrawRect(\r\n var ABrush: TBrush; var PenSize: Integer; var DrawRect: TRect; Erase: Boolean); override;\r\n procedure SetDefaultBrushStyle; virtual;\r\n public\r\n constructor Create(AControl: TControl); override;\r\n destructor Destroy; override;\r\n function DragFindWindow(const Pos: TPoint): THandle; override;\r\n function GetDropCtl: TControl; override;\r\n property CurrentState: TDragState read FCurrentState write SetCurrentState;\r\n property PreviousState: TDragState read FPreviousState write SetPreviousState;\r\n property PreviousTarget: Pointer read FPreviousTarget write FPreviousTarget;\r\n property DockOverFrameWidth: Integer read FDockOverFrameWidth write FDockOverFrameWidth;\r\n property DockOverBrush: TBrush read FDockOverBrush;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvDockVCStyle.pas $';\r\n Revision: '$Revision: 13180 $';\r\n Date: '$Date: 2011-11-22 13:45:23 +0100 (mar. 22 nov. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n Types,\r\n {$IFDEF JVCLThemesEnabled}\r\n JvThemes,\r\n {$ENDIF JVCLThemesEnabled}\r\n SysUtils, ExtCtrls,\r\n JvDockSupportProc, JvDockGlobals;\r\n\r\ntype\r\n TWinControlAccessProtected = class(TWinControl);\r\n\r\nconst\r\n DefaultFrameWidth = 3;\r\n DefaultDockOverFrameWidth = 1;\r\n DefaultDockOverBrushStyle = bsSolid;\r\n\r\n ScaleMaximum = 9999;\r\n\r\n DropAlignArray: array [TDockOrientation, Boolean] of TAlign =\r\n ((alNone, alNone), (alTop, alBottom), (alLeft, alRight));\r\n\r\n//=== { TJvDockVCConjoinServerOption } =======================================\r\n\r\nconstructor TJvDockVCConjoinServerOption.Create(ADockStyle: TJvDockObservableStyle);\r\nbegin\r\n inherited Create(ADockStyle);\r\n FBorderWidth := 4;\r\nend;\r\n\r\nprocedure TJvDockVCConjoinServerOption.Assign(Source: TPersistent);\r\nbegin\r\n if Source is TJvDockVCConjoinServerOption then\r\n begin\r\n BeginUpdate;\r\n try\r\n BorderWidth := TJvDockVCConjoinServerOption(Source).FBorderWidth;\r\n inherited Assign(Source);\r\n finally\r\n EndUpdate;\r\n end;\r\n end\r\n else\r\n inherited Assign(Source);\r\nend;\r\n\r\nprocedure TJvDockVCConjoinServerOption.SetBorderWidth(const Value: Integer);\r\nbegin\r\n if Value <> FBorderWidth then\r\n begin\r\n FBorderWidth := Value;\r\n Changed;\r\n end;\r\nend;\r\n\r\n//=== { TJvDockVCDragDockObject } ============================================\r\n\r\nconstructor TJvDockVCDragDockObject.Create(AControl: TControl);\r\nbegin\r\n inherited Create(AControl);\r\n FrameWidth := DefaultFrameWidth;\r\n\r\n FDockOverFrameWidth := DefaultDockOverFrameWidth;\r\n\r\n FDockOverBrush := TBrush.Create;\r\n SetDefaultBrushStyle;\r\n\r\n CurrentState := dsDragEnter;\r\n PreviousState := CurrentState;\r\nend;\r\n\r\ndestructor TJvDockVCDragDockObject.Destroy;\r\nbegin\r\n FDockOverBrush.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJvDockVCDragDockObject.DragFindWindow(const Pos: TPoint): THandle;\r\nbegin\r\n Result := 0;\r\nend;\r\n\r\nprocedure TJvDockVCDragDockObject.GetBrush_PenSize_DrawRect(var ABrush: TBrush;\r\n var PenSize: Integer; var DrawRect: TRect; Erase: Boolean);\r\nvar\r\n DockOver: Boolean;\r\n\r\n procedure GetBrushAndFrameWidth;\r\n begin\r\n if DockOver then\r\n begin\r\n PenSize := FDockOverFrameWidth;\r\n ABrush := FDockOverBrush;\r\n end\r\n else\r\n begin\r\n PenSize := FrameWidth;\r\n ABrush := Brush;\r\n end;\r\n end;\r\n\r\nbegin\r\n DockOver :=\r\n ((PreviousState = dsDragEnter) and (CurrentState = dsDragMove) and (not Erase or (PreviousTarget <> nil))) or\r\n ((PreviousState = dsDragMove) and (CurrentState = dsDragMove)) or\r\n ((PreviousState = dsDragMove) and (CurrentState = dsDragLeave) and Erase);\r\n\r\n GetBrushAndFrameWidth;\r\n\r\n if (PreviousState = dsDragMove) and (CurrentState = dsDragLeave) then\r\n begin\r\n PreviousState := dsDragEnter;\r\n PreviousTarget := nil;\r\n end\r\n else\r\n PreviousTarget := DragTarget;\r\n\r\n if Erase then\r\n DrawRect := EraseDockRect\r\n else\r\n DrawRect := DockRect;\r\nend;\r\n\r\nfunction TJvDockVCDragDockObject.GetDropCtl: TControl;\r\nbegin\r\n Result := DropOnControl;\r\nend;\r\n\r\nprocedure TJvDockVCDragDockObject.SetCurrentState(const Value: TDragState);\r\nbegin\r\n FCurrentState := Value;\r\nend;\r\n\r\nprocedure TJvDockVCDragDockObject.SetDefaultBrushStyle;\r\nbegin\r\n FDockOverBrush.Bitmap := AllocPatternBitmap(clBlack, clWhite);\r\n FDockOverBrush.Style := bsSolid;\r\nend;\r\n\r\nprocedure TJvDockVCDragDockObject.SetPreviousState(const Value: TDragState);\r\nbegin\r\n FPreviousState := Value;\r\nend;\r\n\r\n//=== { TJvDockVCPanel } =====================================================\r\n\r\nprocedure TJvDockVCPanel.CustomDockDrop(Source: TJvDockDragDockObject; X, Y: Integer);\r\nbegin\r\n if Source is TJvDockVCDragDockObject then\r\n begin\r\n TJvDockVCDragDockObject(Source).CurrentState := dsDragEnter;\r\n TJvDockVCDragDockObject(Source).PreviousState := dsDragEnter;\r\n end;\r\n\r\n if Source.DropOnControl <> Source.Control then\r\n inherited CustomDockDrop(Source, X, Y);\r\nend;\r\n\r\nprocedure TJvDockVCPanel.CustomDockOver(Source: TJvDockDragDockObject; X, Y: Integer;\r\n State: TDragState; var Accept: Boolean);\r\nvar\r\n DropAlign: TAlign;\r\n VCSource: TJvDockVCDragDockObject;\r\n SysCaptionHeight: Integer;\r\n PanelScreenRect: TRect;\r\n R: TRect;\r\nbegin\r\n inherited CustomDockOver(Source, X, Y, State, Accept);\r\n\r\n if Source is TJvDockVCDragDockObject then\r\n begin\r\n VCSource := TJvDockVCDragDockObject(Source);\r\n VCSource.PreviousState := VCSource.CurrentState;\r\n VCSource.CurrentState := State;\r\n end;\r\n\r\n if State = dsDragMove then\r\n begin\r\n DropAlign := Source.DropAlign;\r\n Source.DropOnControl := JvDockManager.GetDockEdge(Source.EraseDockRect,\r\n Source.DragPos, DropAlign, Source.Control);\r\n Source.DropAlign := DropAlign;\r\n\r\n SysCaptionHeight := Ord(Source.Control.Floating) * JvDockGetSysCaptionHeight;\r\n\r\n PanelScreenRect := BoundsRect;\r\n MapWindowPoints(Parent.Handle, 0, PanelScreenRect, 2);\r\n\r\n if ((Align in [alTop, alBottom]) and\r\n (Source.DockRect.Right = PanelScreenRect.Right) and\r\n (Source.DockRect.Left = PanelScreenRect.Left)) or\r\n ((Align in [alLeft, alRight]) and\r\n (Source.DockRect.Top = PanelScreenRect.Top) and\r\n (Source.DockRect.Bottom = PanelScreenRect.Bottom)) then\r\n Exit;\r\n\r\n if ((Source.DropOnControl <> nil) and (Source.DropOnControl <> Source.Control)) and\r\n (Source.DropOnControl.HostDockSite <> Source.Control.HostDockSite) then\r\n begin\r\n if DropAlign in [alTop, alBottom] then\r\n begin\r\n if ((Source.Control.DockOrientation = doVertical) or (Source.Control.HostDockSite = nil)) then\r\n begin\r\n R := Source.DockRect;\r\n R.Bottom := Source.DockRect.Top + Source.Control.UndockHeight - SysCaptionHeight;\r\n Source.DockRect := R;\r\n end;\r\n end\r\n else\r\n if DropAlign in [alLeft, alRight] then\r\n if (Source.Control.DockOrientation = doHorizontal) or (Source.Control.HostDockSite = nil) then\r\n begin\r\n R := Source.DockRect;\r\n R.Right := Source.DockRect.Left + Source.Control.UndockWidth - SysCaptionHeight;\r\n Source.DockRect := R;\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockVCPanel.CustomGetDockEdge(Source: TJvDockDragDockObject;\r\n MousePos: TPoint; var DropAlign: TAlign);\r\nbegin\r\nend;\r\n\r\nprocedure TJvDockVCPanel.CustomGetSiteInfo(Source: TJvDockDragDockObject; Client: TControl;\r\n var InfluenceRect: TRect; MousePos: TPoint; var CanDock: Boolean);\r\nbegin\r\n GetWindowRect(Handle, InfluenceRect);\r\n with Client, JvGlobalDockManager.DragObject do\r\n case Self.Align of\r\n alTop:\r\n if MousePos.Y >= InfluenceRect.Top then\r\n InflateRect(InfluenceRect, 0,\r\n JvDockGetMinOffset(TBDockHeight, Height, MouseDeltaY));\r\n alBottom:\r\n if MousePos.Y <= InfluenceRect.Top then\r\n InflateRect(InfluenceRect, 0,\r\n JvDockGetMinOffset(TBDockHeight, Height, 1 - MouseDeltaY));\r\n alLeft:\r\n if MousePos.X >= InfluenceRect.Left then\r\n InflateRect(InfluenceRect,\r\n JvDockGetMinOffset(LRDockWidth, Width, MouseDeltaX), 0);\r\n alRight:\r\n if MousePos.X <= InfluenceRect.Left then\r\n InflateRect(InfluenceRect,\r\n JvDockGetMinOffset(LRDockWidth, Width, 1 - MouseDeltaX), 0);\r\n end;\r\n CanDock := IsDockable(Self, Client, Source.DropOnControl, Source.DropAlign);\r\nend;\r\n\r\nprocedure TJvDockVCPanel.CustomPositionDockRect(Source: TJvDockDragDockObject; X, Y: Integer);\r\nvar\r\n R: TRect;\r\n BorderWidth: Integer;\r\n GrabberSize: Integer;\r\n PanelScreenRect: TRect;\r\n SysCaptionHeight: Integer;\r\n DockSize: Integer;\r\n\r\n procedure GetDockSize;\r\n begin\r\n if Align in [alLeft, alRight] then\r\n begin\r\n if (Source.Control.HostDockSite <> nil) and\r\n (Source.Control.HostDockSite <> Source.TargetControl) then\r\n DockSize := Source.Control.UndockHeight\r\n else\r\n DockSize := Source.Control.Height;\r\n end\r\n else\r\n begin\r\n if (Source.Control.HostDockSite <> nil) and\r\n (Source.Control.HostDockSite <> Source.TargetControl) then\r\n DockSize := Source.Control.UndockWidth\r\n else\r\n DockSize := Source.Control.Width;\r\n end;\r\n end;\r\n\r\n procedure SetMaxDockSize(Align: TAlign);\r\n begin\r\n if Align in [alLeft, alRight] then\r\n begin\r\n if R.Bottom - R.Top >= PanelScreenRect.Bottom - PanelScreenRect.Top then\r\n begin\r\n R.Top := PanelScreenRect.Top;\r\n R.Bottom := PanelScreenRect.Bottom;\r\n end;\r\n end\r\n else\r\n begin\r\n if R.Right - R.Left >= PanelScreenRect.Right - PanelScreenRect.Left then\r\n begin\r\n R.Left := PanelScreenRect.Left;\r\n R.Right := PanelScreenRect.Right;\r\n end;\r\n end;\r\n end;\r\n\r\nbegin\r\n if Source.Control.HostDockSite is TJvDockCustomPanel then\r\n begin\r\n BorderWidth := TJvDockCustomPanel(Source.Control.HostDockSite).JvDockManager.BorderWidth;\r\n GrabberSize := TJvDockCustomPanel(Source.Control.HostDockSite).JvDockManager.GrabberSize;\r\n end\r\n else\r\n begin\r\n BorderWidth := 0;\r\n GrabberSize := 0;\r\n end;\r\n\r\n PanelScreenRect := BoundsRect;\r\n MapWindowPoints(Parent.Handle, 0, PanelScreenRect, 2);\r\n\r\n SysCaptionHeight := Ord(Source.Control.Floating) * JvDockGetSysCaptionHeight;\r\n\r\n GetDockSize;\r\n\r\n with Source.Control do\r\n begin\r\n case Self.Align of\r\n alTop:\r\n begin\r\n R.TopLeft := Self.ClientToScreen(Point(0, 0));\r\n R.BottomRight := Self.ClientToScreen(Point(Self.Width, TBDockHeight));\r\n R.Top := R.Top + Y -\r\n JvDockGetMinOffset(TBDockHeight, Height + 2 * BorderWidth, Source.MouseDeltaY);\r\n R.Bottom := R.Top + TBDockHeight;\r\n if (Self.Height > 0) and (R.Top + TBDockHeight div 2 < PanelScreenRect.Bottom) and\r\n (R.Bottom - TBDockHeight div 2 > PanelScreenRect.Top) then\r\n begin\r\n R.Left := R.Left + X - Round((Width + 2 * BorderWidth + GrabberSize) * Source.MouseDeltaX);\r\n R.Right := R.Left + DockSize + 2 * BorderWidth + GrabberSize - SysCaptionHeight;\r\n end;\r\n end;\r\n alBottom:\r\n begin\r\n R.TopLeft := Self.ClientToScreen(Point(0, -TBDockHeight));\r\n R.BottomRight := Self.ClientToScreen(Point(Self.Width, 0));\r\n R.Top := R.Top + Y +\r\n JvDockGetMinOffset(TBDockHeight, Height + 2 * BorderWidth, 1 - Source.MouseDeltaY);\r\n R.Bottom := R.Top + TBDockHeight;\r\n if (Self.Height > 0) and (R.Top + TBDockHeight div 2 < PanelScreenRect.Bottom) and\r\n (R.Bottom - TBDockHeight div 2 > PanelScreenRect.Top) then\r\n begin\r\n R.Left := R.Left + X - Round((Width + 2 * BorderWidth + GrabberSize) * Source.MouseDeltaX);\r\n R.Right := R.Left + DockSize + 2 * BorderWidth + GrabberSize - SysCaptionHeight;\r\n end;\r\n end;\r\n alLeft:\r\n begin\r\n R.TopLeft := Self.ClientToScreen(Point(0, 0));\r\n R.BottomRight := Self.ClientToScreen(Point(LRDockWidth, Self.Height));\r\n R.Left := R.Left + X -\r\n JvDockGetMinOffset(LRDockWidth, Width + 2 * BorderWidth, Source.MouseDeltaX);\r\n R.Right := R.Left + LRDockWidth;\r\n if (Self.Width > 0) and ((R.Left + LRDockWidth div 2 < PanelScreenRect.Right) and\r\n (R.Right - LRDockWidth div 2 > PanelScreenRect.Left)) then\r\n begin\r\n R.Top := R.Top + Y - Round((Height + 2 * BorderWidth + GrabberSize) * Source.MouseDeltaY);\r\n R.Bottom := R.Top + DockSize + 2 * BorderWidth + GrabberSize - SysCaptionHeight;\r\n end;\r\n end;\r\n alRight:\r\n begin\r\n R.TopLeft := Self.ClientToScreen(Point(-LRDockWidth, 0));\r\n R.BottomRight := Self.ClientToScreen(Point(Self.Width, Self.Height));\r\n R.Left := R.Left + X +\r\n JvDockGetMinOffset(LRDockWidth, Width + 2 * BorderWidth, 1 - Source.MouseDeltaX);\r\n R.Right := R.Left + LRDockWidth;\r\n if (Self.Width > 0) and (R.Left + LRDockWidth div 2 > PanelScreenRect.Left) and\r\n (R.Right - LRDockWidth div 2 < PanelScreenRect.Right) then\r\n begin\r\n R.Top := R.Top + Y - Round((Height + 2 * BorderWidth + GrabberSize) * Source.MouseDeltaY);\r\n R.Bottom := R.Top + DockSize + 2 * BorderWidth + GrabberSize - SysCaptionHeight;\r\n end;\r\n end;\r\n end;\r\n end;\r\n SetMaxDockSize(Align);\r\n Inc(R.Left);\r\n Source.DockRect := R;\r\nend;\r\n\r\nfunction TJvDockVCPanel.CustomUnDock(Source: TJvDockDragDockObject; NewTarget: TWinControl;\r\n Client: TControl): Boolean;\r\nvar\r\n DropAlign: TAlign;\r\n MousePos: TPoint;\r\nbegin\r\n if (NewTarget = nil) or (NewTarget = Client.HostDockSite) then\r\n begin\r\n DropAlign := Source.DropAlign;\r\n Source.DropOnControl := JvDockManager.GetDockEdge(\r\n Source.DockRect, Source.DragPos, DropAlign, Source.Control);\r\n Source.DropAlign := DropAlign;\r\n end;\r\n MousePos := ScreenToClient(Source.DragPos);\r\n if ((Align in [alTop, alBottom]) and ((0 > MousePos.X) or (Width < MousePos.X))) or\r\n ((Align in [alLeft, alRight]) and ((0 > MousePos.Y) or (Height < MousePos.Y))) or\r\n (Source.CtrlDown) or Source.Floating then\r\n Result := inherited CustomUnDock(Source, NewTarget, Client)\r\n else\r\n if Source.DropOnControl <> Source.Control then\r\n Result := inherited CustomUnDock(Source, NewTarget, Client)\r\n else\r\n Result := True;\r\nend;\r\n\r\nfunction TJvDockVCPanel.GetDockEdge(MousePos: TPoint): TAlign;\r\nbegin\r\n Result := inherited GetDockEdge(MousePos);\r\nend;\r\n\r\n//=== { TJvDockVCSplitter } ==================================================\r\n\r\nconstructor TJvDockVCSplitter.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FOldSize := MinSize;\r\nend;\r\n\r\nfunction TJvDockVCSplitter.DoCanResize(var NewSize: Integer): Boolean;\r\nvar\r\n DockPanel: TJvDockPanel;\r\n Limit, MinSize: Integer;\r\nbegin\r\n Result := inherited DoCanResize(NewSize);\r\n if Result and (FOldSize > NewSize) then\r\n begin\r\n DockPanel := DockServer.DockPanelWithAlign[Align];\r\n if DockPanel = nil then\r\n begin\r\n Result := False;\r\n Exit;\r\n end;\r\n Limit := DockPanel.JvDockManager.GetDockClientLimit(JvDockGetControlOrient(DockPanel),\r\n Align in [alLeft, alTop]);\r\n MinSize := DockPanel.JvDockManager.MinSize;\r\n\r\n if DockPanel.Align in [alLeft, alTop] then\r\n begin\r\n if NewSize < Limit + MinSize then\r\n Result := False;\r\n end\r\n else\r\n begin\r\n if NewSize < JvDockGetControlSize(DockPanel) - Limit + MinSize then\r\n Result := False;\r\n end;\r\n end;\r\n if Result then\r\n FOldSize := NewSize;\r\nend;\r\n\r\nprocedure TJvDockVCSplitter.MouseUp(Button: TMouseButton;\r\n Shift: TShiftState; X, Y: Integer);\r\nvar\r\n DockPanel: TJvDockPanel;\r\nbegin\r\n DockPanel := DockServer.DockPanelWithAlign[Align];\r\n if Assigned(DockPanel) then\r\n begin\r\n DockPanel.JvDockManager.BeginResizeDockSite;\r\n try\r\n inherited MouseUp(Button, Shift, X, Y);\r\n finally\r\n DockPanel.JvDockManager.EndResizeDockSite;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockVCSplitter.Paint;\r\nvar\r\n Rect: TRect;\r\nbegin\r\n Rect := ClientRect;\r\n Inc(Rect.Right, 2);\r\n case Align of\r\n alLeft:\r\n InflateRect(Rect, 0, 2);\r\n alRight:\r\n begin\r\n OffsetRect(Rect, -1, 0);\r\n InflateRect(Rect, 0, 2);\r\n end;\r\n alTop:\r\n begin\r\n Inc(Rect.Bottom, 2);\r\n InflateRect(Rect, 2, 0);\r\n end;\r\n alBottom:\r\n begin\r\n Dec(Rect.Top, 2);\r\n InflateRect(Rect, 2, 1);\r\n end;\r\n end;\r\n Canvas.Brush.Color := Color;\r\n DrawFrameControl(Canvas.Handle, Rect, DFC_BUTTON, DFCS_BUTTONPUSH or DFCS_ADJUSTRECT);\r\nend;\r\n\r\n//=== { TJvDockVCStyle } =====================================================\r\n\r\nconstructor TJvDockVCStyle.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n DockPanelClass := TJvDockVCPanel;\r\n DockSplitterClass := TJvDockVCSplitter;\r\n ConjoinPanelClass := TJvDockVCConjoinPanel;\r\n TabDockClass := TJvDockVCTabPageControl;\r\n DockPanelTreeClass := TJvDockVCTree;\r\n DockPanelZoneClass := TJvDockVCZone;\r\n ConjoinPanelTreeClass := TJvDockVCTree;\r\n ConjoinPanelZoneClass := TJvDockVCZone;\r\n ConjoinServerOptionClass := TJvDockVCConjoinServerOption;\r\n TabServerOptionClass := TJvDockVCTabServerOption;\r\nend;\r\n\r\nfunction TJvDockVCStyle.CanSetEachOtherDocked(ADockBaseControl: TJvDockBaseControl): Boolean;\r\nbegin\r\n Result := False;\r\nend;\r\n\r\nprocedure TJvDockVCStyle.FormGetDockEdge(DockClient: TJvDockClient;\r\n Source: TJvDockDragDockObject; MousePos: TPoint; var DropAlign: TAlign);\r\nbegin\r\nend;\r\n\r\nprocedure TJvDockVCStyle.FormStartDock(DockClient: TJvDockClient;\r\n var Source: TJvDockDragDockObject);\r\nbegin\r\n inherited FormStartDock(DockClient, Source);\r\n Source := TJvDockVCDragDockObject.Create(DockClient.ParentForm);\r\nend;\r\n\r\nprocedure TJvDockVCStyle.SetDockBaseControl(IsCreate: Boolean;\r\n DockBaseControl: TJvDockBaseControl);\r\nvar\r\n ADockClient: TJvDockClient;\r\nbegin\r\n if DockBaseControl is TJvDockClient then\r\n begin\r\n ADockClient := TJvDockClient(DockBaseControl);\r\n if IsCreate then\r\n begin\r\n FOldEachOtherDock := ADockClient.EachOtherDock;\r\n ADockClient.EachOtherDock := False;\r\n ADockClient.DirectDrag := True;\r\n end\r\n else\r\n ADockClient.EachOtherDock := FOldEachOtherDock;\r\n end;\r\nend;\r\n\r\n//=== { TJvDockVCTree } ======================================================\r\n\r\nconstructor TJvDockVCTree.Create(DockSite: TWinControl; DockZoneClass: TJvDockZoneClass;\r\n ADockStyle: TJvDockObservableStyle);\r\nbegin\r\n inherited Create(DockSite, DockZoneClass, ADockStyle);\r\n Version := RsDockVCDockTreeVersion;\r\n BorderWidth := 4;\r\n MinSize := 20;\r\nend;\r\n\r\nprocedure TJvDockVCTree.BeginDrag(Control: TControl; Immediate: Boolean; Threshold: Integer);\r\nbegin\r\n JvGlobalDockManager.BeginDrag(Control, True, 0);\r\nend;\r\n\r\nprocedure TJvDockVCTree.CalcSplitterPos;\r\nvar\r\n TestLimit: Integer;\r\n TempPos: TPoint;\r\nbegin\r\n TempPos := SizePos;\r\n if SizingZone.ParentZone.Orientation = doHorizontal then\r\n begin\r\n TestLimit := SizingZone.Top + MinSize;\r\n if TempPos.Y <= TestLimit then\r\n begin\r\n if DockSiteOrientation = doVertical then\r\n begin\r\n if TempPos.Y <= (SizingZone.VisiblePrevSiblingCount + 1) * MinSize - SplitterWidth div 2 then\r\n TempPos.Y := (SizingZone.VisiblePrevSiblingCount + 1) * MinSize - SplitterWidth div 2;\r\n end\r\n else\r\n TempPos.Y := TestLimit;\r\n end;\r\n\r\n TestLimit := GetSplitterLimit(SizingZone, False, True) - MinSize;\r\n if TempPos.Y >= TestLimit then\r\n begin\r\n if DockSiteOrientation = doVertical then\r\n begin\r\n if TempPos.Y >= DockSiteSizeAlternate - SizingZone.VisibleNextSiblingCount * MinSize then\r\n TempPos.Y := DockSiteSizeAlternate - SizingZone.VisibleNextSiblingCount * MinSize;\r\n end\r\n else\r\n TempPos.Y := TestLimit;\r\n end;\r\n end\r\n else\r\n begin\r\n TestLimit := SizingZone.Left + MinSize;\r\n if TempPos.X <= TestLimit then\r\n begin\r\n if DockSiteOrientation = doHorizontal then\r\n begin\r\n if TempPos.X <= (SizingZone.VisiblePrevSiblingCount + 1) * MinSize - SplitterWidth div 2 then\r\n TempPos.X := (SizingZone.VisiblePrevSiblingCount + 1) * MinSize - SplitterWidth div 2;\r\n end\r\n else\r\n TempPos.X := TestLimit;\r\n end;\r\n\r\n TestLimit := GetSplitterLimit(SizingZone, False, True) - MinSize;\r\n if TempPos.X >= TestLimit then\r\n begin\r\n if DockSiteOrientation = doHorizontal then\r\n begin\r\n if TempPos.X >= DockSiteSizeAlternate - SizingZone.VisibleNextSiblingCount * MinSize then\r\n TempPos.X := DockSiteSizeAlternate - SizingZone.VisibleNextSiblingCount * MinSize;\r\n end\r\n else\r\n TempPos.X := TestLimit;\r\n end;\r\n end;\r\n SizePos := TempPos;\r\nend;\r\n\r\nprocedure TJvDockVCTree.ControlVisibilityChanged(Control: TControl; Visible: Boolean);\r\nbegin\r\n inherited ControlVisibilityChanged(Control, Visible);\r\nend;\r\n\r\nprocedure TJvDockVCTree.CustomLoadZone(Stream: TStream; var Zone: TJvDockZone);\r\nbegin\r\n Stream.Read(TJvDockVCZone(Zone).FZoneSizeStyle, SizeOf(TJvDockZoneSizeStyle));\r\n inherited CustomLoadZone(Stream, Zone);\r\nend;\r\n\r\nprocedure TJvDockVCTree.CustomSaveZone(Stream: TStream; Zone: TJvDockZone);\r\nbegin\r\n Stream.Write(TJvDockVCZone(Zone).FZoneSizeStyle, SizeOf(TJvDockZoneSizeStyle));\r\n inherited CustomSaveZone(Stream, Zone);\r\nend;\r\n\r\nfunction TJvDockVCTree.DoLButtonDown(var Msg: TWMMouse;\r\n var Zone: TJvDockZone; out HTFlag: Integer): Boolean;\r\nvar\r\n TempZone: TJvDockVCZone;\r\n Active: Boolean;\r\nbegin\r\n Result := inherited DoLButtonDown(Msg, Zone, HTFlag);\r\n if (Zone <> nil) and (HTFlag = HTEXPAND) then\r\n begin\r\n TempZone := TJvDockVCZone(Zone);\r\n Active := ((TempZone.ParentZone.Orientation <> DockSiteOrientation) and\r\n (TempZone.ParentZone.VisibleChildCount >= 2));\r\n if Active then\r\n begin\r\n TempZone.ExpandButtonDown := True;\r\n TempZone.MouseDown := True;\r\n FExpandBtnZone := TempZone;\r\n DockSite.Invalidate;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockVCTree.DoLButtonUp(var Msg: TWMMouse;\r\n var Zone: TJvDockZone; out HTFlag: Integer);\r\nvar\r\n TempZone: TJvDockVCZone;\r\nbegin\r\n inherited DoLButtonUp(Msg, Zone, HTFlag);\r\n if (SizingZone = nil) and (FExpandBtnZone <> nil) then\r\n begin\r\n FExpandBtnZone := nil;\r\n if (Zone <> nil) and (HTFlag = HTEXPAND) then\r\n begin\r\n TempZone := TJvDockVCZone(Zone);\r\n TempZone.ExpandButtonDown := False;\r\n if TempZone.ZoneSizeStyle in [zssMaximum] then\r\n TJvDockVCZone(TempZone.ParentZone).DoSetChildSizeStyle(zssNormal)\r\n else\r\n begin\r\n TJvDockVCZone(TempZone.ParentZone).DoSetChildSizeStyle(zssMinimum);\r\n TempZone.ZoneSizeStyle := zssMaximum;\r\n end;\r\n ResetDockZoneSizeStyle(TempZone.ParentZone, TempZone.ZoneSizeStyle, nil);\r\n DockSite.Invalidate;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockVCTree.DoMouseMove(var Msg: TWMMouse;\r\n var Zone: TJvDockZone; out HTFlag: Integer);\r\nvar\r\n TempZone: TJvDockVCZone;\r\nbegin\r\n inherited DoMouseMove(Msg, Zone, HTFlag);\r\n if SizingZone = nil then\r\n begin\r\n TempZone := TJvDockVCZone(Zone);\r\n if ((TempZone <> nil) and (TempZone.ExpandButtonDown <> (HTFlag = HTEXPAND)) and\r\n ((FExpandBtnZone = TempZone) and FExpandBtnZone.MouseDown)) then\r\n begin\r\n TempZone.ExpandButtonDown := (HTFlag = HTEXPAND) and FExpandBtnZone.MouseDown;\r\n DockSite.Invalidate;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockVCTree.DoOtherHint(Zone: TJvDockZone;\r\n HTFlag: Integer; var HintStr: string);\r\nbegin\r\n inherited DoOtherHint(Zone, HTFlag, HintStr);\r\n if HTFlag = HTEXPAND then\r\n HintStr := RsDockVCDockTreeExpandBtnHint;\r\nend;\r\n\r\nprocedure TJvDockVCTree.DrawDockGrabber(Control: TWinControl; const ARect: TRect);\r\nvar\r\n VCDockZone: TJvDockVCZone;\r\n DrawRect: TRect;\r\n {$IFDEF JVCLThemesEnabled}\r\n Details: TThemedElementDetails;\r\n CurrentThemeTypeBtn: TThemedWindow;\r\n CurrentThemeTypeSB: TThemedScrollBar;\r\n {$ENDIF JVCLThemesEnabled}\r\n\r\n procedure DrawCloseButton(Left, Top: Integer);\r\n var\r\n ADockClient: TJvDockClient;\r\n begin\r\n if VCDockZone <> nil then\r\n begin\r\n ADockClient := FindDockClient(Control);\r\n if (ADockClient <> nil) and not ADockClient.EnableCloseButton then\r\n Exit;\r\n {$IFDEF JVCLThemesEnabled}\r\n if ThemeServices.{$IFDEF RTL230_UP}Available{$ELSE}ThemesAvailable{$ENDIF RTL230_UP} and ThemeServices.{$IFDEF RTL230_UP}Enabled{$ELSE}ThemesEnabled{$ENDIF RTL230_UP} then\r\n begin\r\n CurrentThemeTypeBtn := twSmallCloseButtonNormal;\r\n if VCDockZone.CloseBtnDown then\r\n CurrentThemeTypeBtn := twSmallCloseButtonPushed;\r\n Details := ThemeServices.GetElementDetails(CurrentThemeTypeBtn);\r\n ThemeServices.DrawElement(Canvas.Handle, Details, Classes.Rect(Left, Top,\r\n Left + ButtonWidth, Top + ButtonHeight));\r\n end\r\n else\r\n {$ENDIF JVCLThemesEnabled}\r\n DrawFrameControl(Canvas.Handle, Classes.Rect(Left, Top, Left + ButtonWidth,\r\n Top + ButtonHeight), DFC_CAPTION, DFCS_CAPTIONCLOSE or Ord(VCDockZone.CloseBtnDown) * DFCS_PUSHED);\r\n end;\r\n end;\r\n\r\n procedure DrawExpendBotton(Left, Top: Integer);\r\n const\r\n ArrowOrient: array [TAlign] of DWORD =\r\n (0, DFCS_SCROLLUP, DFCS_SCROLLDOWN, DFCS_SCROLLLEFT, DFCS_SCROLLRIGHT, 0, 0);\r\n {$IFDEF JVCLThemesEnabled}\r\n ArrowOrientTheme: array [TAlign] of TThemedScrollBar =\r\n (tsScrollBarDontCare, tsArrowBtnUpNormal, tsArrowBtnDownNormal, tsArrowBtnLeftNormal,\r\n tsArrowBtnRightNormal, tsScrollBarDontCare, tsScrollBarDontCare);\r\n {$ENDIF JVCLThemesEnabled}\r\n CurrArrow: array [Boolean, TDockOrientation] of TAlign =\r\n ((alNone, alLeft, alTop), (alNone, alRight, alBottom));\r\n var\r\n InActive: Boolean;\r\n IsMaximum: Boolean;\r\n begin\r\n if VCDockZone <> nil then\r\n begin\r\n InActive := not ((VCDockZone.ParentZone.Orientation <> DockSiteOrientation) and\r\n (VCDockZone.ParentZone.VisibleChildCount >= 2));\r\n IsMaximum := VCDockZone.ZoneSizeStyle in [zssMaximum];\r\n {$IFDEF JVCLThemesEnabled}\r\n if ThemeServices.{$IFDEF RTL230_UP}Available{$ELSE}ThemesAvailable{$ENDIF RTL230_UP} and ThemeServices.{$IFDEF RTL230_UP}Enabled{$ELSE}ThemesEnabled{$ENDIF RTL230_UP} then\r\n begin\r\n CurrentThemeTypeSB := ArrowOrientTheme[CurrArrow[IsMaximum, DockSiteOrientation]];\r\n if VCDockZone.ExpandButtonDown then\r\n CurrentThemeTypeSB := TThemedScrollBar(Ord(CurrentThemeTypeSB) + 2);\r\n if InActive then\r\n CurrentThemeTypeSB := TThemedScrollBar(Ord(CurrentThemeTypeSB) + 3);\r\n Details := ThemeServices.GetElementDetails(CurrentThemeTypeSB);\r\n ThemeServices.DrawElement(Canvas.Handle, Details, Classes.Rect(Left, Top, Left + ButtonWidth, Top + ButtonHeight));\r\n end\r\n else\r\n {$ENDIF JVCLThemesEnabled}\r\n DrawFrameControl(Canvas.Handle, Classes.Rect(Left, Top, Left + ButtonWidth,\r\n Top + ButtonHeight), DFC_SCROLL,\r\n ArrowOrient[CurrArrow[IsMaximum, DockSiteOrientation]] +\r\n Cardinal(Ord(InActive)) * DFCS_INACTIVE +\r\n Cardinal(Ord(VCDockZone.ExpandButtonDown)) * DFCS_PUSHED);\r\n end;\r\n end;\r\n\r\n procedure DrawGrabberLine(Left, Top, Right, Bottom: Integer);\r\n begin\r\n if (Left >= Right) or (Top >= Bottom) then\r\n Exit;\r\n Canvas.Pen.Color := clBtnHighlight;\r\n Canvas.MoveTo(Right, Top);\r\n Canvas.LineTo(Left, Top);\r\n Canvas.LineTo(Left, Bottom);\r\n Canvas.Pen.Color := clBtnShadow;\r\n Canvas.LineTo(Right, Bottom);\r\n Canvas.LineTo(Right, Top - 1);\r\n end;\r\n\r\nbegin\r\n VCDockZone := TJvDockVCZone(FindControlZone(Control));\r\n DrawRect := ARect;\r\n Canvas.Brush.Color := TWinControlAccessProtected(DockSite).Color;\r\n Canvas.FillRect(DrawRect);\r\n case GrabbersPosition of\r\n gpLeft:\r\n begin\r\n DrawExpendBotton(ARect.Left + BorderWidth + LeftOffset,\r\n ARect.Top + TopOffset + ButtonHeight + ButtonSplitter + BorderWidth);\r\n DrawCloseButton(ARect.Left + BorderWidth + LeftOffset, ARect.Top + TopOffset + BorderWidth);\r\n DrawGrabberLine(ARect.Left + BorderWidth + LeftOffset + 3,\r\n ARect.Top + 2 * ButtonHeight + TopOffset + ButtonSplitter + BottomOffset + BorderWidth + 3,\r\n ARect.Left + BorderWidth + LeftOffset + 5, ARect.Bottom - BorderWidth - 2);\r\n DrawGrabberLine(ARect.Left + BorderWidth + LeftOffset + 7,\r\n ARect.Top + 2 * ButtonHeight + TopOffset + ButtonSplitter + BottomOffset + BorderWidth + 3,\r\n ARect.Left + BorderWidth + LeftOffset + 9, ARect.Bottom - BorderWidth - 2);\r\n end;\r\n gpTop:\r\n begin\r\n DrawExpendBotton(ARect.Right - LeftOffset - 2 * ButtonWidth - ButtonSplitter - BorderWidth,\r\n ARect.Top + TopOffset + BorderWidth);\r\n DrawCloseButton(ARect.Right - LeftOffset - ButtonWidth - BorderWidth, ARect.Top + TopOffset + BorderWidth);\r\n DrawGrabberLine(ARect.Left + BorderWidth, ARect.Top + BorderWidth + TopOffset + 3,\r\n ARect.Right - 2 * ButtonWidth - RightOffset - ButtonSplitter - LeftOffset - BorderWidth - 3,\r\n ARect.Top + BorderWidth + TopOffset + 5);\r\n DrawGrabberLine(ARect.Left + BorderWidth, ARect.Top + BorderWidth + TopOffset + 7,\r\n ARect.Right - 2 * ButtonWidth - RightOffset - ButtonSplitter - LeftOffset - BorderWidth - 3,\r\n ARect.Top + BorderWidth + TopOffset + 9);\r\n end;\r\n gpBottom:\r\n begin\r\n end;\r\n gpRight:\r\n begin\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockVCTree.DrawDockSiteRect;\r\nvar\r\n Rect: TRect;\r\nbegin\r\n inherited DrawDockSiteRect;\r\n Rect := DockSite.ClientRect;\r\n InflateRect(Rect, BorderWidth, 0);\r\n if DockSite.Align = alTop then\r\n Inc(Rect.Bottom, BorderWidth)\r\n else\r\n if DockSite.Align = alBottom then\r\n Dec(Rect.Top, BorderWidth);\r\n Frame3D(Canvas, Rect, clBtnShadow, clBtnHighlight, 1);\r\n Frame3D(Canvas, Rect, clBtnHighlight, clBtnShadow, 1);\r\n\r\n Canvas.Pen.Color := clBlack;\r\n if DockSite.Align = alRight then\r\n begin\r\n Canvas.MoveTo(0, 0);\r\n Canvas.LineTo(0, DockSite.Height);\r\n end\r\n else\r\n if DockSite.Align = alBottom then\r\n begin\r\n Canvas.MoveTo(0, 0);\r\n Canvas.LineTo(DockSite.Width, 0);\r\n end;\r\nend;\r\n\r\nprocedure TJvDockVCTree.DrawSplitterRect(const ARect: TRect);\r\nvar\r\n Rect: TRect;\r\nbegin\r\n inherited DrawSplitterRect(ARect);\r\n Rect := ARect;\r\n InflateRect(Rect, 1, 1);\r\n DrawFrameControl(Canvas.Handle, Rect, DFC_BUTTON, DFCS_BUTTONPUSH or DFCS_ADJUSTRECT);\r\nend;\r\n\r\nprocedure TJvDockVCTree.GetCaptionRect(var Rect: TRect);\r\nbegin\r\n case GrabbersPosition of\r\n gpTop:\r\n Rect.Bottom := Rect.Top + GrabberSize + 2;\r\n gpLeft:\r\n Rect.Right := Rect.Left + GrabberSize + 2;\r\n end;\r\nend;\r\n\r\nfunction TJvDockVCTree.GetDockAlign(Client: TControl; var DropCtl: TControl): TAlign;\r\nbegin\r\n Result := inherited GetDockAlign(Client, DropCtl);\r\n case DockSite.Align of\r\n alLeft, alRight:\r\n if (Result in [alLeft, alRight]) and (DropCtl <> nil) then\r\n DropCtl := nil;\r\n alTop, alBottom:\r\n if (Result in [alTop, alBottom]) and (DropCtl <> nil) then\r\n DropCtl := nil;\r\n end;\r\nend;\r\n\r\nfunction TJvDockVCTree.GetDockEdge(DockRect: TRect;\r\n MousePos: TPoint; var DropAlign: TAlign; Control: TControl): TControl;\r\nvar\r\n Zone: TJvDockZone;\r\n TempOrient: TDockOrientation;\r\nbegin\r\n inherited GetDockEdge(DockRect, MousePos, DropAlign, Control);\r\n\r\n MapWindowPoints(0, DockSite.Handle, DockRect, 2);\r\n InitDockHeightWidth(0, DockSite.Height, DockSite.Width);\r\n InitDockRectangles(DockRect);\r\n\r\n TempOrient := DockSiteOrientation;\r\n Zone := GetDropOnZone(TempOrient, DockRect, DropAlign);\r\n TempOrient := JvDockExchangeOrient(TempOrient);\r\n Result := GetDropOnControl(TempOrient, Zone, DockRect, DropAlign, Control);\r\n DropDockSize := DockRectangles[TempOrient, True] - DockRectangles[TempOrient, False];\r\nend;\r\n\r\nfunction TJvDockVCTree.GetDropOnControl(Orient: TDockOrientation; Zone: TJvDockZone;\r\n DockRect: TRect; var DropAlign: TAlign; Control: TControl): TControl;\r\nvar\r\n TempZone: TJvDockZone;\r\n Scale: Double;\r\n BeginBorderLimit: Integer;\r\n EndBorderLimit: Integer;\r\n\r\n procedure GetBeginBorderControl(Zone: TJvDockZone);\r\n begin\r\n BeginBorderLimit := Zone.TopLeft[Orient];\r\n\r\n if DockRectangles[Orient, False] < BeginBorderLimit then\r\n begin\r\n Result := Zone.ChildControl;\r\n DropAlign := DropAlignArray[Orient, False];\r\n end;\r\n end;\r\n\r\n procedure GetEndBorderControl(Zone: TJvDockZone);\r\n begin\r\n BeginBorderLimit := Zone.TopLeft[Orient];\r\n EndBorderLimit := BeginBorderLimit + Zone.HeightWidth[Orient];\r\n\r\n if DockRectangles[Orient, False] < EndBorderLimit then\r\n begin\r\n Result := Zone.ChildControl;\r\n if DockRectangles[Orient, False] = BeginBorderLimit then\r\n Scale := ScaleMaximum\r\n else\r\n Scale := (EndBorderLimit - DockRectangles[Orient, True]) / (DockRectangles[Orient, False] - BeginBorderLimit);\r\n if Scale >= 1 then\r\n DropAlign := DropAlignArray[Orient, False]\r\n else\r\n begin\r\n if (Zone.AfterClosestVisibleZone <> nil) and (Zone.AfterClosestVisibleZone.ChildControl = Control) then\r\n begin\r\n Result := Zone.AfterClosestVisibleZone.ChildControl;\r\n DropAlign := DropAlignArray[Orient, False];\r\n end\r\n else\r\n DropAlign := DropAlignArray[Orient, True];\r\n end;\r\n end;\r\n end;\r\n\r\nbegin\r\n Result := nil;\r\n Scale := 0;\r\n if Zone <> nil then\r\n begin\r\n if Zone.ChildCount = 0 then\r\n begin\r\n GetBeginBorderControl(Zone);\r\n if Result = nil then\r\n GetEndBorderControl(Zone);\r\n end\r\n else\r\n begin\r\n TempZone := Zone.ChildZones;\r\n if TempZone <> nil then\r\n GetBeginBorderControl(TempZone);\r\n while (TempZone <> nil) and (Result = nil) do\r\n begin\r\n GetEndBorderControl(TempZone);\r\n TempZone := TempZone.AfterClosestVisibleZone;\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJvDockVCTree.GetDropOnZone(Orient: TDockOrientation; DockRect: TRect;\r\n var DropAlign: TAlign): TJvDockZone;\r\nvar\r\n TempZone: TJvDockZone;\r\n Scale: Double;\r\n TempOrient: TDockOrientation;\r\n\r\n procedure GetBeginBorderZone(BorderLimit: Integer);\r\n begin\r\n if DockRectangles[Orient, True] = BorderLimit then\r\n Scale := ScaleMaximum\r\n else\r\n Scale := (BorderLimit - DockRectangles[Orient, False]) / (DockRectangles[Orient, True] - BorderLimit);\r\n if Scale >= 0 then\r\n begin\r\n if Scale >= 1 then\r\n Result := TempZone.BeforeClosestVisibleZone\r\n else\r\n Result := TempZone;\r\n end;\r\n end;\r\n\r\n procedure GetEndBorderZone(BorderLimit: Integer);\r\n begin\r\n if (DockRectangles[Orient, True] <= BorderLimit) then\r\n Scale := ScaleMaximum\r\n else\r\n Scale := (BorderLimit - DockRectangles[Orient, False]) / (DockRectangles[Orient, True] - BorderLimit);\r\n if Scale >= 0 then\r\n begin\r\n if Scale < 1 then\r\n Result := TempZone.AfterClosestVisibleZone\r\n else\r\n Result := TempZone;\r\n end;\r\n end;\r\n\r\nbegin\r\n Result := nil;\r\n TempOrient := JvDockExchangeOrient(Orient);\r\n if (DockRectangles[TempOrient, False] > DockHeightWidth[TempOrient]) or\r\n (DockRectangles[TempOrient, True] < 0) then\r\n Exit;\r\n\r\n if (DockRectangles[Orient, False] + DockRectangles[Orient, True]) div 2 <= 0 then\r\n DropAlign := DropAlignArray[Orient, False]\r\n else\r\n if (DockRectangles[Orient, False] + DockRectangles[Orient, True]) div 2 >= DockHeightWidth[Orient] then\r\n DropAlign := DropAlignArray[Orient, True]\r\n else\r\n begin\r\n if (TopZone.ChildCount <= 1) or (TopZone.Orientation <> Orient) then\r\n Result := TopZone\r\n else\r\n begin\r\n Scale := 0;\r\n TempZone := TopZone.ChildZones;\r\n GetBeginBorderZone(0);\r\n while (TempZone <> nil) and (Scale <= 0) do\r\n begin\r\n GetEndBorderZone(TempZone.ZoneLimit);\r\n TempZone := TempZone.AfterClosestVisibleZone;\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJvDockVCTree.GetLeftGrabbersHTFlag(const MousePos: TPoint;\r\n out HTFlag: Integer; Zone: TJvDockZone): TJvDockZone;\r\nbegin\r\n if (MousePos.X >= Zone.Left + BorderWidth) and (MousePos.X <= Zone.Left + BorderWidth + GrabberSize) and\r\n (MousePos.Y >= Zone.Top) and (MousePos.Y <= Zone.Top + Zone.Height) then\r\n begin\r\n Result := Zone;\r\n with Zone.ChildControl do\r\n begin\r\n if PtInRect(Classes.Rect(\r\n Left - GrabberSize + LeftOffset,\r\n Top + TopOffset,\r\n Left - GrabberSize + LeftOffset + ButtonWidth,\r\n Top + TopOffset + ButtonHeight), MousePos) then\r\n HTFlag := HTCLOSE\r\n else\r\n if PtInRect(Classes.Rect(\r\n Left - GrabberSize + LeftOffset,\r\n Top + ButtonHeight + TopOffset + ButtonSplitter,\r\n Left - GrabberSize + LeftOffset + ButtonWidth,\r\n Top + 2 * ButtonHeight + TopOffset + ButtonSplitter), MousePos) then\r\n HTFlag := HTEXPAND\r\n else\r\n HTFlag := HTCAPTION;\r\n end;\r\n end\r\n else\r\n Result := nil;\r\nend;\r\n\r\nfunction TJvDockVCTree.GetTopGrabbersHTFlag(const MousePos: TPoint;\r\n out HTFlag: Integer; Zone: TJvDockZone): TJvDockZone;\r\nbegin\r\n if (MousePos.Y >= Zone.Top + BorderWidth) and (MousePos.Y <= Zone.Top + BorderWidth + GrabberSize) and\r\n (MousePos.X >= Zone.Left) and (MousePos.X <= Zone.Left + Zone.Width) then\r\n begin\r\n Result := Zone;\r\n with Zone.ChildControl do\r\n begin\r\n if PtInRect(Classes.Rect(\r\n Left + Width - ButtonWidth - RightOffset,\r\n Top - GrabberSize + TopOffset,\r\n Left + Width - RightOffset,\r\n Top - GrabberSize + TopOffset + ButtonHeight), MousePos) then\r\n HTFlag := HTCLOSE\r\n else\r\n if PtInRect(Classes.Rect(\r\n Left + Width - 2 * ButtonWidth - RightOffset - ButtonSplitter,\r\n Top - GrabberSize + TopOffset,\r\n Left + Width - ButtonWidth - RightOffset - ButtonSplitter,\r\n Top - GrabberSize + TopOffset + ButtonHeight), MousePos) then\r\n HTFlag := HTEXPAND\r\n else\r\n HTFlag := HTCAPTION;\r\n end;\r\n end\r\n else\r\n Result := nil;\r\nend;\r\n\r\nprocedure TJvDockVCTree.InsertControl(Control: TControl;\r\n InsertAt: TAlign; DropCtl: TControl);\r\nbegin\r\n inherited InsertControl(Control, InsertAt, DropCtl);\r\nend;\r\n\r\nprocedure TJvDockVCTree.InsertNewParent(NewZone, SiblingZone: TJvDockZone;\r\n ParentOrientation: TDockOrientation; InsertLast, Update: Boolean);\r\nbegin\r\n inherited InsertNewParent(NewZone, SiblingZone,\r\n ParentOrientation, InsertLast, Update);\r\nend;\r\n\r\nprocedure TJvDockVCTree.InsertSibling(NewZone, SiblingZone: TJvDockZone;\r\n InsertLast, Update: Boolean);\r\nbegin\r\n inherited InsertSibling(NewZone, SiblingZone, InsertLast, Update);\r\nend;\r\n\r\nprocedure TJvDockVCTree.RemoveControl(Control: TControl);\r\nvar\r\n DockRect: TRect;\r\n OldDockSize: Integer;\r\nbegin\r\n OldDockSize := DropDockSize;\r\n\r\n DockRect := GetFrameRect(Control);\r\n if DockSiteOrientation = doHorizontal then\r\n DropDockSize := DockRect.Right - DockRect.Left\r\n else\r\n if DockSiteOrientation = doVertical then\r\n DropDockSize := DockRect.Bottom - DockRect.Top;\r\n\r\n inherited RemoveControl(Control);\r\n\r\n DropDockSize := OldDockSize;\r\nend;\r\n\r\nprocedure TJvDockVCTree.RemoveZone(Zone: TJvDockZone; Hide: Boolean);\r\nbegin\r\n inherited RemoveZone(Zone, Hide);\r\nend;\r\n\r\nprocedure TJvDockVCTree.ResetBounds(Force: Boolean);\r\nvar\r\n R: TRect;\r\nbegin\r\n BeginUpdate;\r\n try\r\n if not JvGlobalDockIsLoading then\r\n begin\r\n R := DockSite.ClientRect;\r\n\r\n if ResizeCount > 0 then\r\n begin\r\n if TopZone.ChildZones <> nil then\r\n begin\r\n if (DockSite.Align = alRight) and (R.Right <> PreviousRect.Right) then\r\n begin\r\n ShiftBy := -PreviousRect.Right + R.Right;\r\n ShiftScaleOrientation := doVertical;\r\n ForEachAt(TopZone.ChildZones, ShiftZone, tskForward);\r\n SetNewBounds(nil);\r\n end;\r\n if (DockSite.Align = alBottom) and (R.Bottom <> PreviousRect.Bottom) then\r\n begin\r\n ShiftBy := -PreviousRect.Bottom + R.Bottom;\r\n ShiftScaleOrientation := doHorizontal;\r\n ForEachAt(TopZone.ChildZones, ShiftZone, tskForward);\r\n SetNewBounds(nil);\r\n end;\r\n end;\r\n end;\r\n\r\n if (DockSiteOrientation = doVertical) and (R.Bottom <> PreviousRect.Bottom) then\r\n begin\r\n if PreviousRect.Bottom - PreviousRect.Top = 0 then\r\n ScaleBy := R.Bottom - R.Top\r\n else\r\n if PreviousRect.Bottom - PreviousRect.Top > 0 then\r\n ScaleBy := (R.Bottom - R.Top) / (PreviousRect.Bottom - PreviousRect.Top)\r\n else\r\n ScaleBy := 1;\r\n ShiftScaleOrientation := doHorizontal;\r\n if ScaleBy <> 1 then\r\n ForEachAt(nil, ScaleZone, tskForward);\r\n end;\r\n if (DockSiteOrientation = doHorizontal) and (R.Right <> PreviousRect.Right) then\r\n begin\r\n if PreviousRect.Right - PreviousRect.Left = 0 then\r\n ScaleBy := R.Right - R.Left\r\n else\r\n if PreviousRect.Right - PreviousRect.Left > 0 then\r\n ScaleBy := (R.Right - R.Left) / (PreviousRect.Right - PreviousRect.Left)\r\n else\r\n ScaleBy := 1;\r\n ShiftScaleOrientation := doVertical;\r\n if ScaleBy <> 1 then\r\n ForEachAt(nil, ScaleZone, tskForward);\r\n end;\r\n end;\r\n inherited ResetBounds(Force);\r\n finally\r\n EndUpdate;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockVCTree.ResetDockZoneSizeStyle(Parent: TJvDockZone;\r\n ZoneSizeStyle: TJvDockZoneSizeStyle; Exclude: TJvDockZone);\r\nvar\r\n Zone: TJvDockVCZone;\r\n ChildCount: Integer;\r\n AverageSize: Integer;\r\nbegin\r\n ChildCount := Parent.VisibleChildCount - Ord((Exclude <> nil) and (Exclude.ParentZone = Parent));\r\n if ChildCount = 0 then\r\n Exit;\r\n AverageSize := DockSiteSizeAlternate div ChildCount;\r\n Assert(AverageSize > 0);\r\n Zone := TJvDockVCZone(Parent.FirstVisibleChildZone);\r\n while Zone <> nil do\r\n begin\r\n if Exclude <> Zone then\r\n begin\r\n Dec(ChildCount);\r\n if ZoneSizeStyle in [zssMaximum] then\r\n begin\r\n if Zone.ZoneSizeStyle = zssMinimum then\r\n Zone.ZoneLimit := Zone.LimitBegin + MinSize\r\n else\r\n if Zone.ZoneSizeStyle = zssMaximum then\r\n Zone.ZoneLimit := DockSiteSizeAlternate - ChildCount * MinSize;\r\n end\r\n else\r\n if ZoneSizeStyle in [zssNormal] then\r\n Zone.ZoneLimit := Zone.LimitBegin + AverageSize;\r\n end\r\n else\r\n if Exclude <> nil then\r\n Exclude.ZoneLimit := Exclude.LimitBegin;\r\n\r\n Zone := TJvDockVCZone(Zone.AfterClosestVisibleZone);\r\n end;\r\n SetNewBounds(Parent);\r\n ForEachAt(Parent, UpdateZone, tskForward);\r\nend;\r\n\r\nprocedure TJvDockVCTree.ScaleChildZone(Zone: TJvDockZone);\r\nbegin\r\n if Zone <> nil then\r\n case TJvDockVCZone(Zone).ZoneSizeStyle of\r\n zssMinimum:\r\n begin\r\n Zone.ZoneLimit := Zone.LimitBegin + MinSize;\r\n Exit;\r\n end;\r\n zssMaximum:\r\n begin\r\n Zone.ZoneLimit := DockSiteSizeAlternate - Zone.VisibleNextSiblingCount * MinSize;\r\n Exit;\r\n end;\r\n end;\r\n inherited ScaleChildZone(Zone);\r\n\r\n if (Zone <> nil) and (Zone.ParentZone <> nil) and Zone.Visibled and\r\n (Zone.ParentZone.Orientation = ShiftScaleOrientation) then\r\n begin\r\n if Zone.LimitSize < MinSize then\r\n Zone.ZoneLimit := Zone.LimitBegin + MinSize;\r\n\r\n if (Zone.BeforeClosestVisibleZone <> nil) and\r\n (Zone.LimitBegin > DockSiteSizeWithOrientation[Zone.ParentZone.Orientation] -\r\n (Zone.VisibleNextSiblingCount + 1) * MinSize + SplitterWidth div 2) then\r\n Zone.BeforeClosestVisibleZone.ZoneLimit := DockSiteSizeWithOrientation[Zone.ParentZone.Orientation] -\r\n (Zone.VisibleNextSiblingCount + 1) * MinSize + SplitterWidth div 2;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockVCTree.ScaleSiblingZone(Zone: TJvDockZone);\r\nbegin\r\n inherited ScaleSiblingZone(Zone);\r\nend;\r\n\r\nprocedure TJvDockVCTree.ScaleZone(Zone: TJvDockZone);\r\nbegin\r\n if Zone <> nil then\r\n case TJvDockVCZone(Zone).ZoneSizeStyle of\r\n zssMinimum:\r\n Zone.ZoneLimit := Zone.LimitBegin + MinSize;\r\n zssMaximum:\r\n Zone.ZoneLimit := DockSiteSizeAlternate - Zone.VisibleNextSiblingCount * MinSize;\r\n else\r\n inherited ScaleZone(Zone);\r\n end\r\n else\r\n inherited ScaleZone(Zone);\r\nend;\r\n\r\nprocedure TJvDockVCTree.ShiftZone(Zone: TJvDockZone);\r\nbegin\r\n inherited ShiftZone(Zone);\r\n if (Zone <> nil) and (Zone <> TopZone) and\r\n (Zone.ParentZone.Orientation = ShiftScaleOrientation) then\r\n begin\r\n if Zone.LimitSize < MinSize then\r\n Zone.ZoneLimit := Zone.LimitBegin + MinSize;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockVCTree.SplitterMouseUp;\r\nbegin\r\n BeginUpdate;\r\n try\r\n ShiftBy := 0;\r\n\r\n if (DockSiteOrientation = doVertical) and\r\n (SizingZone.ParentZone.Orientation = doVertical) then\r\n ShiftBy := SizePos.X + (SplitterWidth div 2) - SizingZone.ZoneLimit\r\n else\r\n if (DockSiteOrientation = doHorizontal) and\r\n (SizingZone.ParentZone.Orientation = doHorizontal) then\r\n ShiftBy := SizePos.Y + (SplitterWidth div 2) - SizingZone.ZoneLimit;\r\n\r\n if (ShiftBy <> 0) and (SizingZone.AfterClosestVisibleZone <> nil) then\r\n begin\r\n if (DockSite.Align in [alLeft, alTop]) then\r\n begin\r\n ShiftScaleOrientation := DockSiteOrientation;\r\n ForEachAt(SizingZone.AfterClosestVisibleZone, ShiftZone, tskForward);\r\n inherited SplitterMouseUp;\r\n end\r\n else\r\n begin\r\n ShiftBy := -ShiftBy;\r\n ShiftScaleOrientation := DockSiteOrientation;\r\n ForEachAt(SizingZone.AfterClosestVisibleZone, ShiftZone, tskForward);\r\n SizePos := Point(SizePos.X + ShiftBy, SizePos.Y + ShiftBy);\r\n inherited SplitterMouseUp;\r\n end;\r\n\r\n DockSiteSize := DockSiteSize + ShiftBy;\r\n end\r\n else\r\n begin\r\n TJvDockVCZone(SizingZone.ParentZone).DoSetChildSizeStyle(zssNormal);\r\n inherited SplitterMouseUp;\r\n end;\r\n finally\r\n EndUpdate;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockVCTree.WindowProc(var Msg: TMessage);\r\nbegin\r\n inherited WindowProc(Msg);\r\nend;\r\n\r\n//=== { TJvDockVCZone } ======================================================\r\n\r\nconstructor TJvDockVCZone.Create(Tree: TJvDockTree);\r\nbegin\r\n inherited Create(Tree);\r\n FZoneSizeStyle := zssNormal;\r\n FExpandButtonDown := False;\r\nend;\r\n\r\nprocedure TJvDockVCZone.DoSetChildSizeStyle(ZoneSizeStyle: TJvDockZoneSizeStyle);\r\nvar\r\n Zone: TJvDockVCZone;\r\nbegin\r\n Zone := TJvDockVCZone(ChildZones);\r\n while Zone <> nil do\r\n begin\r\n Zone.ZoneSizeStyle := ZoneSizeStyle;\r\n Zone := TJvDockVCZone(Zone.AfterClosestVisibleZone);\r\n end;\r\nend;\r\n\r\nprocedure TJvDockVCZone.Insert(DockSize: Integer; Hide: Boolean);\r\nvar\r\n PrevShift, NextShift: Integer;\r\n TempSize: Integer;\r\n BorderSize: Integer;\r\n BeforeVisibleZone, AfterVisibleZone: TJvDockZone;\r\nbegin\r\n if (ParentZone <> nil) and (ParentZone.VisibleChildCount = 0) then\r\n ParentZone.Insert(ParentZone.VisibleSize, Hide);\r\n\r\n if (ParentZone = nil) or ((ParentZone = Tree.TopZone) and (ParentZone.ChildCount <= 1)) then\r\n begin\r\n Visibled := True;\r\n Exit;\r\n end;\r\n\r\n BeforeVisibleZone := BeforeClosestVisibleZone;\r\n AfterVisibleZone := AfterClosestVisibleZone;\r\n\r\n BorderSize := TJvDockVCTree(Tree).BorderWidth * Ord(AfterClosestVisibleZone = nil);\r\n\r\n if ParentZone.Orientation <> TJvDockVCTree(Tree).DockSiteOrientation then\r\n begin\r\n if ((BeforeVisibleZone <> nil) and (TJvDockVCZone(BeforeVisibleZone).ZoneSizeStyle in [zssMaximum, zssMinimum])) or\r\n ((AfterVisibleZone <> nil) and (TJvDockVCZone(AfterVisibleZone).ZoneSizeStyle in [zssMaximum, zssMinimum])) then\r\n begin\r\n ZoneSizeStyle := zssMinimum;\r\n TJvDockVCTree(Tree).ResetDockZoneSizeStyle(ParentZone, zssMaximum, nil);\r\n Visibled := True;\r\n Exit;\r\n end;\r\n case TJvDockVCTree(Tree).DockSiteOrientation of\r\n doVertical:\r\n TempSize := Tree.DockSite.Height;\r\n doHorizontal:\r\n TempSize := Tree.DockSite.Width;\r\n else\r\n raise Exception.CreateRes(@RsEInvalidDockSiteOrientationValue);\r\n end;\r\n\r\n if DockSize >= TempSize - (ParentZone.VisibleChildCount) * TJvDockVCTree(Tree).MinSize then\r\n DockSize := (TempSize - (ParentZone.VisibleChildCount) * TJvDockVCTree(Tree).MinSize) div 2;\r\n\r\n TempSize := ParentZone.HeightWidth[ParentZone.Orientation] + BorderSize;\r\n\r\n if DockSize = 0 then\r\n DockSize := TempSize div 2;\r\n\r\n Visibled := False;\r\n\r\n if (BeforeVisibleZone = nil) and (AfterVisibleZone = nil) then\r\n begin\r\n PrevShift := 0;\r\n NextShift := 0;\r\n end\r\n else\r\n if BeforeVisibleZone = nil then\r\n begin\r\n PrevShift := 0;\r\n NextShift := DockSize + BorderSize;\r\n ZoneLimit := DockSize + BorderSize;\r\n if ParentZone.VisibleChildCount = 1 then\r\n AfterVisibleZone.ZoneLimit := TempSize;\r\n end\r\n else\r\n if AfterVisibleZone = nil then\r\n begin\r\n PrevShift := DockSize + BorderSize;\r\n NextShift := 0;\r\n if (ParentZone.VisibleChildCount = 1) and (ParentZone = Tree.TopZone) then\r\n BeforeVisibleZone.ZoneLimit := Tree.TopXYLimit - PrevShift\r\n else\r\n BeforeVisibleZone.ZoneLimit := BeforeVisibleZone.ZoneLimit - PrevShift;\r\n ZoneLimit := TempSize;\r\n end\r\n else\r\n begin\r\n PrevShift := Round((BeforeVisibleZone.ZoneLimit) * (DockSize + BorderSize) / TempSize);\r\n NextShift := DockSize - PrevShift;\r\n if (ParentZone.VisibleChildCount = 1) and (ParentZone = Tree.TopZone) then\r\n BeforeVisibleZone.ZoneLimit := Tree.TopXYLimit - PrevShift\r\n else\r\n BeforeVisibleZone.ZoneLimit := BeforeVisibleZone.ZoneLimit - PrevShift;\r\n ZoneLimit := BeforeVisibleZone.ZoneLimit + DockSize;\r\n end;\r\n\r\n Visibled := True;\r\n\r\n if PrevShift <> 0 then\r\n begin\r\n with TJvDockVCTree(Tree) do\r\n begin\r\n ReplacementZone := BeforeVisibleZone;\r\n try\r\n if BeforeVisibleZone.ZoneLimit + PrevShift <> 0 then\r\n ScaleBy := PrevSibling.ZoneLimit / (BeforeVisibleZone.ZoneLimit + PrevShift)\r\n else\r\n ScaleBy := 1;\r\n ShiftScaleOrientation := ParentZone.Orientation;\r\n if ScaleBy <> 1 then\r\n ForEachAt(ParentZone.ChildZones, ScaleZone, tskForward);\r\n finally\r\n ReplacementZone := nil;\r\n end;\r\n end;\r\n\r\n if BeforeVisibleZone.LimitSize < TJvDockVCTree(Tree).MinSize then\r\n BeforeVisibleZone.ZoneLimit := BeforeVisibleZone.LimitBegin + TJvDockVCTree(Tree).MinSize;\r\n end;\r\n\r\n if NextShift <> 0 then\r\n begin\r\n with TJvDockVCTree(Tree) do\r\n begin\r\n if TempSize - ZoneLimit + NextShift <> 0 then\r\n ScaleBy := (TempSize - ZoneLimit) / (TempSize - ZoneLimit + NextShift)\r\n else\r\n ScaleBy := 1;\r\n ParentLimit := TempSize;\r\n ShiftScaleOrientation := ParentZone.Orientation;\r\n if ScaleBy <> 1 then\r\n ForEachAt(AfterVisibleZone, ScaleSiblingZone, tskForward);\r\n end;\r\n if AfterVisibleZone.LimitSize < TJvDockVCTree(Tree).MinSize then\r\n AfterVisibleZone.ZoneLimit := AfterVisibleZone.LimitBegin + TJvDockVCTree(Tree).MinSize;\r\n end;\r\n end\r\n else\r\n begin\r\n with TJvDockVCTree(Tree) do\r\n begin\r\n TempSize := DockHeightWidth[DockSiteOrientation] - BorderSize;\r\n\r\n if BeforeVisibleZone <> nil then\r\n begin\r\n if (Tree.TopZone.VisibleChildCount = 2) and Visibled then\r\n BeforeVisibleZone.ZoneLimit := Tree.TopXYLimit + BorderSize;\r\n if Visibled then\r\n ZoneLimit := BeforeVisibleZone.ZoneLimit + TempSize\r\n else\r\n ZoneLimit := BeforeVisibleZone.ZoneLimit + DockSize + BorderSize;\r\n\r\n TempSize := ZoneLimit;\r\n end;\r\n\r\n if AfterVisibleZone <> nil then\r\n begin\r\n if Visibled then\r\n ZoneLimit := LimitBegin + TempSize\r\n else\r\n ZoneLimit := LimitBegin + DockSize - BorderSize;\r\n\r\n ShiftBy := ZoneLimit;\r\n ShiftScaleOrientation := DockSiteOrientation;\r\n ForEachAt(AfterVisibleZone, ShiftZone, tskForward);\r\n TempSize := DockSiteSize + ZoneLimit - LimitBegin;\r\n end;\r\n Visibled := True;\r\n DockSiteSize := TempSize;\r\n TJvDockPanel(DockSite).DockServer.GetClientAlignControl(DockSite.Align);\r\n end;\r\n end;\r\n Visibled := True;\r\nend;\r\n\r\nprocedure TJvDockVCZone.InsertOrRemove(DockSize: Integer; Insert: Boolean; Hide: Boolean);\r\nvar\r\n PrevShift, NextShift: Integer;\r\n TempSize: Integer;\r\n BorderWidth: Integer;\r\nbegin\r\n if not Insert then\r\n Visibled := False;\r\n\r\n if (ParentZone <> nil) and (ParentZone.VisibleChildCount = 0) and (ParentZone <> Tree.TopZone) then\r\n begin\r\n if Insert then\r\n TempSize := ParentZone.VisibleSize\r\n else\r\n TempSize := ParentZone.LimitSize;\r\n\r\n ParentZone.InsertOrRemove(TempSize, Insert, Hide);\r\n end;\r\n if ParentZone = nil then\r\n Exit;\r\n\r\n if ParentZone.Orientation <> TJvDockVCTree(Tree).DockSiteOrientation then\r\n begin\r\n if TJvDockVCZone(ParentZone.ChildZones).ZoneSizeStyle in [zssMaximum, zssMinimum] then\r\n begin\r\n if Insert then\r\n begin\r\n ZoneSizeStyle := zssMinimum;\r\n TJvDockVCTree(Tree).ResetDockZoneSizeStyle(ParentZone, zssMaximum, nil);\r\n end\r\n else\r\n begin\r\n if ZoneSizeStyle = zssMinimum then\r\n TJvDockVCTree(Tree).ResetDockZoneSizeStyle(ParentZone, zssMaximum, Self)\r\n else\r\n if ZoneSizeStyle = zssMaximum then\r\n begin\r\n TJvDockVCTree(Tree).ResetDockZoneSizeStyle(ParentZone, zssNormal, Self);\r\n TJvDockVCZone(ParentZone).DoSetChildSizeStyle(zssNormal);\r\n end;\r\n end;\r\n Exit;\r\n end;\r\n\r\n case TJvDockVCTree(Tree).DockSiteOrientation of\r\n doVertical:\r\n TempSize := Tree.DockSite.Height;\r\n doHorizontal:\r\n TempSize := Tree.DockSite.Width;\r\n else\r\n raise Exception.CreateRes(@RsEInvalidDockSiteOrientationValue);\r\n end;\r\n\r\n if DockSize > TempSize - (ParentZone.VisibleChildCount - 1) * TJvDockVCTree(Tree).MinSize then\r\n DockSize := TempSize - (ParentZone.VisibleChildCount - 1) * TJvDockVCTree(Tree).MinSize;\r\n\r\n BorderWidth := TJvDockVCTree(Tree).BorderWidth;\r\n\r\n TempSize := ParentZone.HeightWidth[ParentZone.Orientation] + BorderWidth;\r\n\r\n if DockSize = 0 then\r\n DockSize := TempSize div 2;\r\n\r\n if BeforeClosestVisibleZone = nil then\r\n begin\r\n PrevShift := 0;\r\n NextShift := (2 * Ord(Insert) - 1) * (DockSize + BorderWidth);\r\n\r\n ZoneLimit := Ord(Insert) * (DockSize + BorderWidth);\r\n if ParentZone.VisibleChildCount = 2 then\r\n NextSibling.ZoneLimit := TempSize;\r\n end\r\n else\r\n if AfterClosestVisibleZone = nil then\r\n begin\r\n PrevShift := (2 * Ord(Insert) - 1) * (DockSize + BorderWidth);\r\n NextShift := 0;\r\n begin\r\n if ParentZone.ChildCount = 2 then\r\n PrevSibling.ZoneLimit := TempSize - Ord(Insert) * PrevShift\r\n else\r\n PrevSibling.ZoneLimit := PrevSibling.ZoneLimit - PrevShift;\r\n end;\r\n ZoneLimit := TempSize;\r\n end\r\n else\r\n begin\r\n PrevShift := (2 * Ord(Insert) - 1) * Round((PrevSibling.ZoneLimit) *\r\n (DockSize + BorderWidth) / (TempSize - Ord(not Insert) * (DockSize + BorderWidth)));\r\n NextShift := (2 * Ord(Insert) - 1) * DockSize - PrevShift;\r\n PrevSibling.ZoneLimit := PrevSibling.ZoneLimit - PrevShift;\r\n ZoneLimit := Ord(Insert) * (DockSize + BorderWidth) + PrevSibling.ZoneLimit;\r\n end;\r\n\r\n if PrevShift <> 0 then\r\n begin\r\n with TJvDockVCTree(Tree) do\r\n begin\r\n ReplacementZone := PrevSibling;\r\n try\r\n if PrevSibling.ZoneLimit + PrevShift <> 0 then\r\n ScaleBy := PrevSibling.ZoneLimit / (PrevSibling.ZoneLimit + PrevShift)\r\n else\r\n ScaleBy := 1;\r\n ShiftScaleOrientation := ParentZone.Orientation;\r\n if ScaleBy <> 1 then\r\n ForEachAt(ParentZone.ChildZones, ScaleZone, tskForward);\r\n finally\r\n ReplacementZone := nil;\r\n end;\r\n end;\r\n\r\n if PrevSibling.LimitSize < TJvDockVCTree(Tree).MinSize then\r\n PrevSibling.ZoneLimit := PrevSibling.LimitBegin + TJvDockVCTree(Tree).MinSize;\r\n end;\r\n\r\n if NextShift <> 0 then\r\n begin\r\n with TJvDockVCTree(Tree) do\r\n begin\r\n if TempSize - ZoneLimit + NextShift <> 0 then\r\n ScaleBy := (TempSize - ZoneLimit) / (TempSize - ZoneLimit + NextShift)\r\n else\r\n ScaleBy := 1;\r\n ParentLimit := TempSize;\r\n ShiftScaleOrientation := ParentZone.Orientation;\r\n if ScaleBy <> 1 then\r\n ForEachAt(NextSibling, ScaleSiblingZone, tskForward);\r\n end;\r\n end;\r\n\r\n ParentZone.Update;\r\n end\r\n else\r\n begin\r\n with TJvDockVCTree(Tree) do\r\n begin\r\n if Insert then\r\n begin\r\n if AfterClosestVisibleZone = nil then\r\n begin\r\n ZoneLimit := LimitBegin + DockHeightWidth[DockSiteOrientation];\r\n DockSiteSize := ZoneLimit;\r\n end\r\n else\r\n if BeforeClosestVisibleZone = nil then\r\n begin\r\n ZoneLimit := DockHeightWidth[DockSiteOrientation] + BorderWidth;\r\n ShiftBy := ZoneLimit;\r\n ShiftScaleOrientation := DockSiteOrientation;\r\n ForEachAt(AfterClosestVisibleZone, ShiftZone, tskForward);\r\n DockSiteSize := DockSiteSize + ZoneLimit;\r\n end;\r\n\r\n TJvDockPanel(DockSite).DockServer.GetClientAlignControl(DockSite.Align);\r\n end\r\n else\r\n begin\r\n ZoneLimit := LimitBegin;\r\n ShiftBy := -DockSize;\r\n ShiftScaleOrientation := DockSiteOrientation;\r\n\r\n if PrevSibling <> nil then\r\n DockSiteSize := DockSiteSize - DockSize - 5\r\n else\r\n if NextSibling <> nil then\r\n begin\r\n ForEachAt(NextSibling, ShiftZone, tskForward);\r\n DockSiteSize := DockSiteSize - DockSize;\r\n end;\r\n end;\r\n end;\r\n end;\r\n if Insert then\r\n Visibled := True;\r\nend;\r\n\r\nprocedure TJvDockVCZone.Remove(DockSize: Integer; Hide: Boolean);\r\nvar\r\n PrevShift, NextShift: Integer;\r\n TempSize: Integer;\r\n BorderSize: Integer;\r\n BeforeVisibleZone, AfterVisibleZone: TJvDockZone;\r\nbegin\r\n if (ParentZone <> nil) and (ParentZone.VisibleChildCount = 1) and (ParentZone <> Tree.TopZone) then\r\n ParentZone.Remove(ParentZone.LimitSize, Hide);\r\n\r\n if (ParentZone = nil) or ((ParentZone = Tree.TopZone) and (ParentZone.ChildCount <= 1)) then\r\n begin\r\n Visibled := False;\r\n Exit;\r\n end;\r\n\r\n BeforeVisibleZone := BeforeClosestVisibleZone;\r\n AfterVisibleZone := AfterClosestVisibleZone;\r\n\r\n BorderSize := TJvDockVCTree(Tree).BorderWidth * Ord(AfterClosestVisibleZone = nil);\r\n\r\n if ParentZone.Orientation <> TJvDockVCTree(Tree).DockSiteOrientation then\r\n begin\r\n if ZoneSizeStyle in [zssMaximum, zssMinimum] then\r\n begin\r\n if ZoneSizeStyle = zssMinimum then\r\n TJvDockVCTree(Tree).ResetDockZoneSizeStyle(ParentZone, zssMaximum, Self)\r\n else\r\n if ZoneSizeStyle = zssMaximum then\r\n begin\r\n TJvDockVCTree(Tree).ResetDockZoneSizeStyle(ParentZone, zssNormal, Self);\r\n TJvDockVCZone(ParentZone).DoSetChildSizeStyle(zssNormal);\r\n end;\r\n Visibled := False;\r\n Exit;\r\n end;\r\n\r\n case TJvDockVCTree(Tree).DockSiteOrientation of\r\n doVertical:\r\n TempSize := Tree.DockSite.Height;\r\n doHorizontal:\r\n TempSize := Tree.DockSite.Width;\r\n else\r\n raise Exception.CreateRes(@RsEInvalidDockSiteOrientationValue);\r\n end;\r\n\r\n if DockSize > TempSize - (ParentZone.VisibleChildCount - 1) * TJvDockVCTree(Tree).MinSize then\r\n DockSize := TempSize - (ParentZone.VisibleChildCount - 1) * TJvDockVCTree(Tree).MinSize;\r\n\r\n TempSize := ParentZone.HeightWidth[ParentZone.Orientation] + BorderSize;\r\n\r\n if DockSize = 0 then\r\n DockSize := TempSize div 2;\r\n\r\n Visibled := False;\r\n\r\n if (BeforeVisibleZone = nil) and (AfterVisibleZone = nil) then\r\n Exit;\r\n\r\n if BeforeVisibleZone = nil then\r\n begin\r\n PrevShift := 0;\r\n NextShift := -DockSize + BorderSize;\r\n ZoneLimit := -DockSize + BorderSize;\r\n end\r\n else\r\n if AfterVisibleZone = nil then\r\n begin\r\n PrevShift := -DockSize + BorderSize;\r\n NextShift := 0;\r\n BeforeVisibleZone.ZoneLimit := BeforeVisibleZone.ZoneLimit - PrevShift;\r\n ZoneLimit := TempSize;\r\n end\r\n else\r\n begin\r\n PrevShift := -Round((BeforeVisibleZone.ZoneLimit) *\r\n (DockSize + BorderSize) / (TempSize - (DockSize + BorderSize)));\r\n NextShift := -DockSize - PrevShift;\r\n BeforeVisibleZone.ZoneLimit := BeforeVisibleZone.ZoneLimit - PrevShift;\r\n ZoneLimit := BeforeVisibleZone.ZoneLimit;\r\n end;\r\n\r\n if PrevShift <> 0 then\r\n begin\r\n with TJvDockVCTree(Tree) do\r\n begin\r\n ReplacementZone := BeforeVisibleZone;\r\n try\r\n if BeforeVisibleZone.ZoneLimit + PrevShift <> 0 then\r\n ScaleBy := PrevSibling.ZoneLimit / (BeforeVisibleZone.ZoneLimit + PrevShift)\r\n else\r\n ScaleBy := 1;\r\n ShiftScaleOrientation := ParentZone.Orientation;\r\n if ScaleBy <> 1 then\r\n ForEachAt(ParentZone.ChildZones, ScaleZone, tskForward);\r\n finally\r\n ReplacementZone := nil;\r\n end;\r\n end;\r\n\r\n if BeforeVisibleZone.LimitSize < TJvDockVCTree(Tree).MinSize then\r\n BeforeVisibleZone.ZoneLimit := BeforeVisibleZone.LimitBegin + TJvDockVCTree(Tree).MinSize;\r\n end;\r\n\r\n if NextShift <> 0 then\r\n begin\r\n with TJvDockVCTree(Tree) do\r\n begin\r\n if TempSize - ZoneLimit + NextShift <> 0 then\r\n ScaleBy := (TempSize - ZoneLimit) / (TempSize - ZoneLimit + NextShift)\r\n else\r\n ScaleBy := 1;\r\n ParentLimit := TempSize;\r\n ShiftScaleOrientation := ParentZone.Orientation;\r\n if ScaleBy <> 1 then\r\n ForEachAt(AfterVisibleZone, ScaleSiblingZone, tskForward);\r\n end;\r\n if AfterVisibleZone.LimitSize < TJvDockVCTree(Tree).MinSize then\r\n AfterVisibleZone.ZoneLimit := AfterVisibleZone.LimitBegin + TJvDockVCTree(Tree).MinSize;\r\n end;\r\n end\r\n else\r\n begin\r\n Visibled := False;\r\n with TJvDockVCTree(Tree) do\r\n begin\r\n ZoneLimit := LimitBegin - BorderSize;\r\n ShiftBy := -DockSize - BorderSize;\r\n ShiftScaleOrientation := DockSiteOrientation;\r\n\r\n if BeforeClosestVisibleZone <> nil then\r\n DockSiteSize := DockSiteSize - DockSize - BorderSize\r\n else\r\n if AfterClosestVisibleZone <> nil then\r\n begin\r\n ForEachAt(AfterClosestVisibleZone, ShiftZone, tskForward);\r\n DockSiteSize := DockSiteSize - DockSize - BorderSize;\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockVCZone.SetZoneSize(Size: Integer; Show: Boolean);\r\nbegin\r\n inherited SetZoneSize(Size, Show);\r\nend;\r\n\r\nprocedure TJvDockVCTree.SyncWithStyle;\r\nbegin\r\n inherited SyncWithStyle;\r\n if DockStyle.ConjoinServerOption is TJvDockVCConjoinServerOption then\r\n BorderWidth := TJvDockVCConjoinServerOption(DockStyle.ConjoinServerOption).BorderWidth;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvDockVIDStyle.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvDockVIDStyle.pas, released on 2003-12-31.\r\n\r\nThe Initial Developer of the Original Code is luxiaoban.\r\nPortions created by luxiaoban are Copyright (C) 2002,2003 luxiaoban.\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvDockVIDStyle.pas 13415 2012-09-10 09:51:54Z obones $\r\n\r\nunit JvDockVIDStyle;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, Messages, Classes, Graphics, Controls, ComCtrls, ImgList,\r\n JvConsts, JvDockControlForm, JvDockSupportControl, JvDockTree,\r\n JvDockAdvTree, JvDockGlobals;\r\n\r\ntype\r\n TJvDockVIDConjoinServerOption = class(TJvDockBasicConjoinServerOption)\r\n private\r\n FTextEllipsis: Boolean;\r\n FTextAlignment: TAlignment;\r\n FInactiveTitleEndColor: TColor;\r\n FInactiveTitleStartColor: TColor;\r\n FInactiveTitleVerticalGradient: Boolean;\r\n FActiveTitleEndColor: TColor;\r\n FActiveTitleStartColor: TColor;\r\n FActiveTitleVerticalGradient: Boolean;\r\n FActiveDockGrabber: Boolean;\r\n FSystemInfo: Boolean;\r\n FActiveFont: TFont;\r\n FInactiveFont: TFont;\r\n procedure SetActiveTitleEndColor(const Value: TColor);\r\n procedure SetActiveTitleStartColor(const Value: TColor);\r\n procedure SetInactiveTitleEndColor(const Value: TColor);\r\n procedure SetInactiveTitleStartColor(const Value: TColor);\r\n procedure SetTextAlignment(const Value: TAlignment);\r\n procedure SetTextEllipsis(const Value: Boolean);\r\n procedure SetSystemInfo(const Value: Boolean);\r\n procedure SetActiveFont(Value: TFont);\r\n procedure SetInactiveFont(Value: TFont);\r\n procedure SetActiveTitleVerticalGradient(const Value: Boolean);\r\n procedure SetInactiveTitleVerticalGradient(const Value: Boolean);\r\n procedure SetActiveDockGrabber(const Value: Boolean);\r\n protected\r\n procedure FontChanged(Sender: TObject);\r\n function IsNotSystemInfo: Boolean;\r\n procedure SettingChange(Sender: TObject);\r\n procedure Changed; override;\r\n procedure UpdateDefaultSystemCaptionInfo; virtual;\r\n procedure SetDefaultSystemCaptionInfo;\r\n public\r\n constructor Create(ADockStyle: TJvDockObservableStyle); override;\r\n destructor Destroy; override;\r\n procedure Assign(Source: TPersistent); override;\r\n published\r\n property ActiveFont: TFont read FActiveFont write SetActiveFont stored IsNotSystemInfo;\r\n property InactiveFont: TFont read FInactiveFont write SetInactiveFont stored IsNotSystemInfo;\r\n property TextAlignment: TAlignment read FTextAlignment write SetTextAlignment default taLeftJustify;\r\n property ActiveTitleStartColor: TColor read FActiveTitleStartColor write SetActiveTitleStartColor stored\r\n IsNotSystemInfo;\r\n property ActiveTitleEndColor: TColor read FActiveTitleEndColor write SetActiveTitleEndColor stored\r\n IsNotSystemInfo;\r\n property ActiveTitleVerticalGradient: Boolean read FActiveTitleVerticalGradient write\r\n SetActiveTitleVerticalGradient default False;\r\n property ActiveDockGrabber: Boolean read FActiveDockGrabber write SetActiveDockGrabber default False;\r\n property InactiveTitleStartColor: TColor read FInactiveTitleStartColor write SetInactiveTitleStartColor stored\r\n IsNotSystemInfo;\r\n property InactiveTitleEndColor: TColor read FInactiveTitleEndColor write SetInactiveTitleEndColor stored\r\n IsNotSystemInfo;\r\n property InactiveTitleVerticalGradient: Boolean read FInactiveTitleVerticalGradient write\r\n SetInactiveTitleVerticalGradient default False;\r\n property TextEllipsis: Boolean read FTextEllipsis write SetTextEllipsis default True;\r\n property SystemInfo: Boolean read FSystemInfo write SetSystemInfo default True;\r\n property GrabbersSize default VIDDefaultDockGrabbersSize;\r\n property SplitterWidth default VIDDefaultDockSplitterWidth;\r\n end;\r\n\r\n TJvDockVIDTabServerOption = class(TJvDockBasicTabServerOption)\r\n private\r\n FActiveFont: TFont;\r\n FActiveSheetColor: TColor;\r\n FHotTrackColor: TColor;\r\n FInactiveFont: TFont;\r\n FInactiveSheetColor: TColor;\r\n FShowTabImages: Boolean;\r\n { NEW! if true, shows invididual close buttons on tabs. If false, you get the old VID behaviour. }\r\n FShowCloseButtonOnTabs: Boolean;\r\n {NEW! default is true, which is the old VID Style behaviour. False is a new behaviour added by Warren. }\r\n FShowCloseButtonOnGrabber: Boolean;\r\n procedure SetActiveFont(Value: TFont);\r\n procedure SetActiveSheetColor(const Value: TColor);\r\n procedure SetHotTrackColor(const Value: TColor);\r\n procedure SetInactiveFont(Value: TFont);\r\n procedure SetInactiveSheetColor(const Value: TColor);\r\n procedure SetShowTabImages(const Value: Boolean);\r\n procedure SetShowCloseButtonOnGrabber(const Value: Boolean);\r\n procedure SetShowCloseButtonOnTabs(const Value: Boolean);\r\n protected\r\n procedure FontChanged(Sender: TObject);\r\n public\r\n constructor Create(ADockStyle: TJvDockObservableStyle); override;\r\n destructor Destroy; override;\r\n procedure Assign(Source: TPersistent); override;\r\n procedure SetTabPosition(const Value: TTabPosition); override;\r\n published\r\n property ActiveSheetColor: TColor read FActiveSheetColor write SetActiveSheetColor default clBtnFace;\r\n property InactiveSheetColor: TColor read FInactiveSheetColor write SetInactiveSheetColor default clBtnShadow;\r\n property ActiveFont: TFont read FActiveFont write SetActiveFont;\r\n property InactiveFont: TFont read FInactiveFont write SetInactiveFont;\r\n property HotTrackColor: TColor read FHotTrackColor write SetHotTrackColor default clBlue;\r\n property ShowTabImages: Boolean read FShowTabImages write SetShowTabImages default False;\r\n property TabPosition default tpBottom;\r\n { NEW! If true, shows invididual close buttons on tabs.\r\n If false, you get the old VID behaviour. }\r\n property ShowCloseButtonOnTabs: Boolean read FShowCloseButtonOnTabs write SetShowCloseButtonOnTabs;\r\n {NEW! Default is true, which is the old VID Style behaviour.\r\n False is a new behaviour added by Warren. }\r\n property ShowCloseButtonOnGrabber: Boolean read FShowCloseButtonOnGrabber write\r\n SetShowCloseButtonOnGrabber default True;\r\n end;\r\n\r\n TJvDockSystemInfoChange = procedure(Value: Boolean) of object;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvDockVIDStyle = class(TJvDockAdvStyle)\r\n private\r\n FAlwaysShowGrabber: Boolean;\r\n FSystemInfoChange: TJvDockSystemInfoChange;\r\n procedure SetAlwaysShowGrabber(const Value: Boolean);\r\n protected\r\n function DockClientWindowProc(DockClient: TJvDockClient; var Msg: TMessage): Boolean; override;\r\n procedure FormDockDrop(DockClient: TJvDockClient;\r\n Source: TJvDockDragDockObject; X, Y: Integer); override;\r\n procedure FormGetSiteInfo(Source: TJvDockDragDockObject; DockClient: TJvDockClient;\r\n Client: TControl; var InfluenceRect: TRect; MousePos: TPoint;\r\n var CanDock: Boolean); override;\r\n procedure FormDockOver(DockClient: TJvDockClient; Source: TJvDockDragDockObject; X, Y: Integer;\r\n State: TDragState; var Accept: Boolean); override;\r\n procedure FormStartDock(DockClient: TJvDockClient;\r\n var Source: TJvDockDragDockObject); override;\r\n procedure FormGetDockEdge(DockClient: TJvDockClient; Source: TJvDockDragDockObject;\r\n MousePos: TPoint; var DropAlign: TAlign); override;\r\n\r\n procedure DoSystemInfoChange(Value: Boolean);\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n procedure SetDockBaseControl(IsCreate: Boolean; DockBaseControl: TJvDockBaseControl); override;\r\n published\r\n property AlwaysShowGrabber: Boolean read FAlwaysShowGrabber write SetAlwaysShowGrabber; {NEW}\r\n property SystemInfoChange: TJvDockSystemInfoChange read FSystemInfoChange write FSystemInfoChange;\r\n property ConjoinServerOption;\r\n property TabServerOption;\r\n end;\r\n\r\n TJvDockVIDSplitter = class(TJvDockSplitter);\r\n\r\n TJvDockVIDPanel = class(TJvDockAdvPanel)\r\n protected\r\n procedure CustomGetSiteInfo(Source: TJvDockDragDockObject;\r\n Client: TControl; var InfluenceRect: TRect; MousePos: TPoint;\r\n var CanDock: Boolean); override;\r\n procedure CustomStartDock(var Source: TJvDockDragDockObject); override;\r\n procedure CustomDockDrop(Source: TJvDockDragDockObject; X, Y: Integer); override;\r\n procedure CustomDockOver(Source: TJvDockDragDockObject; X, Y: Integer;\r\n State: TDragState; var Accept: Boolean); override;\r\n procedure CustomGetDockEdge(Source: TJvDockDragDockObject; MousePos: TPoint;\r\n var DropAlign: TAlign); override;\r\n public\r\n procedure DockDrop(Source: TDragDockObject; X, Y: Integer); override;\r\n procedure UpdateCaption(Exclude: TControl); override;\r\n end;\r\n\r\n TJvDockVIDConjoinPanel = class(TJvDockAdvConjoinPanel)\r\n protected\r\n procedure CustomGetSiteInfo(Source: TJvDockDragDockObject;\r\n Client: TControl; var InfluenceRect: TRect; MousePos: TPoint;\r\n var CanDock: Boolean); override;\r\n procedure CustomDockOver(Source: TJvDockDragDockObject; X, Y: Integer;\r\n State: TDragState; var Accept: Boolean); override;\r\n procedure CustomGetDockEdge(Source: TJvDockDragDockObject; MousePos: TPoint; var DropAlign: TAlign); override;\r\n function CustomUnDock(Source: TJvDockDragDockObject; NewTarget: TWinControl; Client: TControl): Boolean; override;\r\n procedure CustomDockDrop(Source: TJvDockDragDockObject; X, Y: Integer); override;\r\n public\r\n procedure UpdateCaption(Exclude: TControl); override;\r\n procedure DockDrop(Source: TDragDockObject; X, Y: Integer); override;\r\n end;\r\n\r\n TJvDockVIDZone = class(TJvDockAdvZone)\r\n protected\r\n function GetSplitterLimit(IsMin: Boolean): Integer; override;\r\n public\r\n destructor Destroy; override;\r\n procedure Insert(DockSize: Integer; Hide: Boolean); override;\r\n procedure Remove(DockSize: Integer; Hide: Boolean); override;\r\n end;\r\n\r\n TJvDockVIDTree = class(TJvDockAdvTree)\r\n private\r\n FDropOnZone: TJvDockZone;\r\n FLockDropDockSizeCount: Integer;\r\n FCaptionLeftOffset: Integer;\r\n FCaptionRightOffset: Integer;\r\n FShowCloseButtonOnGrabber: Boolean;\r\n FAlwaysShowGrabber: Boolean;\r\n procedure LockDropDockSize;\r\n procedure UnlockDropDockSize;\r\n procedure SetCaptionLeftOffset(const Value: Integer);\r\n procedure SetCaptionRightOffset(const Value: Integer);\r\n procedure SetShowCloseButtonOnGrabber(const Value: Boolean);\r\n procedure SetAlwaysShowGrabber(const Value: Boolean);\r\n procedure InvalidateDockSite(const Client: TControl);\r\n protected\r\n procedure InsertControlFromConjoinHost(Control: TControl;\r\n InsertAt: TAlign; DropCtl: TControl); virtual;\r\n procedure IgnoreZoneInfor(Stream: TMemoryStream); virtual;\r\n\r\n { [ERROR] Method 'AdjustDockRect' not found in base class.\r\n if you get this error here, it is a Delphi compiler issue. }\r\n\r\n procedure AdjustDockRect(Control: TControl; var ARect: TRect); override;\r\n procedure WindowProc(var Msg: TMessage); override;\r\n procedure SplitterMouseUp; override;\r\n function GetTopGrabbersHTFlag(const MousePos: TPoint;\r\n out HTFlag: Integer; Zone: TJvDockZone): TJvDockZone; override;\r\n function GetDockGrabbersPosition: TJvDockGrabbersPosition; override;\r\n procedure GetSiteInfo(Client: TControl;\r\n var InfluenceRect: TRect; MousePos: TPoint; var CanDock: Boolean); override;\r\n procedure InsertControl(Control: TControl; InsertAt: TAlign;\r\n DropCtl: TControl); override;\r\n procedure InsertSibling(NewZone, SiblingZone: TJvDockZone;\r\n InsertLast, Update: Boolean); override;\r\n procedure InsertNewParent(NewZone, SiblingZone: TJvDockZone;\r\n ParentOrientation: TDockOrientation; InsertLast, Update: Boolean); override;\r\n procedure DrawDockGrabber(Control: TWinControl; const ARect: TRect); override;\r\n procedure DrawSplitterRect(const ARect: TRect); override;\r\n procedure PaintDockGrabberRect(Canvas: TCanvas; Control: TWinControl;\r\n const ARect: TRect; PaintAlways: Boolean = False); virtual;\r\n procedure DrawCloseButton(Canvas: TCanvas; Zone: TJvDockZone;\r\n Left, Top: Integer); virtual;\r\n procedure ResetBounds(Force: Boolean); override;\r\n procedure DrawDockSiteRect; override;\r\n procedure PositionDockRect(Client, DropCtl: TControl; DropAlign: TAlign;\r\n var DockRect: TRect); override;\r\n function GetDockEdge(DockRect: TRect; MousePos: TPoint;\r\n var DropAlign: TAlign; Control: TControl): TControl; override;\r\n procedure RemoveZone(Zone: TJvDockZone; Hide: Boolean = True); override;\r\n procedure GetCaptionRect(var Rect: TRect); override;\r\n procedure SyncWithStyle; override;\r\n property CaptionLeftOffset: Integer read FCaptionLeftOffset write SetCaptionLeftOffset;\r\n property CaptionRightOffset: Integer read FCaptionRightOffset write SetCaptionRightOffset;\r\n public\r\n constructor Create(DockSite: TWinControl; DockZoneClass: TJvDockZoneClass;\r\n ADockStyle: TJvDockObservableStyle); override;\r\n property ShowCloseButtonOnGrabber: Boolean read FShowCloseButtonOnGrabber write SetShowCloseButtonOnGrabber;\r\n property AlwaysShowGrabber: Boolean read FAlwaysShowGrabber write SetAlwaysShowGrabber;\r\n end;\r\n\r\n TJvDockVIDTabPageControl = class;\r\n\r\n TJvDockVIDTabSheet = class(TJvDockTabSheet)\r\n private\r\n FTabWidth: Integer;\r\n FShowTabWidth: Integer;\r\n FIsSourceDockClient: Boolean;\r\n procedure SetTabWidth(const Value: Integer);\r\n procedure WMSetText(var Msg: TMessage); message WM_SETTEXT;\r\n procedure SetSheetSort(const CaptionStr: string);\r\n protected\r\n procedure SetPageControl(APageControl: TJvDockPageControl); override;\r\n property TabWidth: Integer read FTabWidth write SetTabWidth;\r\n property ShowTabWidth: Integer read FShowTabWidth;\r\n procedure Loaded; override;\r\n procedure UpdateTabShowing; override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n published\r\n property BorderWidth;\r\n property Caption;\r\n property DragMode;\r\n property Enabled;\r\n property Font;\r\n property Height stored False;\r\n property Highlighted;\r\n property ImageIndex;\r\n property Left stored False;\r\n property Constraints;\r\n property PageIndex;\r\n property ParentFont;\r\n property ParentShowHint;\r\n property PopupMenu;\r\n property ShowHint;\r\n property TabVisible;\r\n property Top stored False;\r\n property Visible stored False;\r\n property Width stored False;\r\n property OnContextPopup;\r\n property OnDragDrop;\r\n property OnDragOver;\r\n property OnEndDrag;\r\n property OnEnter;\r\n property OnExit;\r\n property OnHide;\r\n property OnMouseDown;\r\n property OnMouseMove;\r\n property OnMouseUp;\r\n property OnResize;\r\n property OnShow;\r\n property OnStartDrag;\r\n end;\r\n\r\n TJvDockTabPanel = class(TCustomControl)\r\n private\r\n FDockPanel: TJvDockPanel; // If docked to a dock panel, this is it. nil is floating.\r\n FPage: TJvDockVIDTabPageControl;\r\n FActiveSheetColor: TColor;\r\n FHotTrackColor: TColor;\r\n FActiveFont: TFont;\r\n FInactiveFont: TFont;\r\n FTabLeftOffset: Integer;\r\n FTabRightOffset: Integer;\r\n FTabTopOffset: Integer;\r\n FTabBottomOffset: Integer;\r\n FCaptionLeftOffset: Integer;\r\n FCaptionRightOffset: Integer;\r\n FCaptionTopOffset: Integer;\r\n FTabSplitterWidth: Integer;\r\n FTabHeight: Integer;\r\n FSortList: TList;\r\n FSelectSheet: TJvDockVIDTabSheet;\r\n FTempPages: TList;\r\n FSelectHotIndex: Integer;\r\n FShowTabImages: Boolean;\r\n procedure SetPage(const Value: TJvDockVIDTabPageControl);\r\n function GetTotalTabWidth: Integer;\r\n procedure SetTotalTabWidth(const Value: Integer);\r\n function GetMinTabWidth: TJvDockTabSheet;\r\n function GetMaxTabWidth: TJvDockTabSheet;\r\n procedure SetTabBottomOffset(const Value: Integer);\r\n procedure SetTabLeftOffset(const Value: Integer);\r\n procedure SetTabRightOffset(const Value: Integer);\r\n procedure SetTabTopOffset(const Value: Integer);\r\n procedure SetCaptionLeftOffset(const Value: Integer);\r\n procedure SetCaptionRightOffset(const Value: Integer);\r\n procedure SetCaptionTopOffset(const Value: Integer);\r\n procedure SetTabSplitterWidth(const Value: Integer);\r\n function GetSorts(Index: Integer): TJvDockVIDTabSheet;\r\n function GetPanelHeight: Integer;\r\n function GetPanelWidth: Integer;\r\n procedure SetPanelHeight(const Value: Integer);\r\n function FindSheetWithPos(cX, cY, cTopOffset, cBottomOffset: Integer): Integer;\r\n function GetDockClientFromPageIndex(Index: Integer): TControl;\r\n procedure CMMouseLeave(var Msg: TMessage); message CM_MOUSELEAVE;\r\n procedure SetShowTabImages(const Value: Boolean);\r\n procedure SetTabHeight(const Value: Integer);\r\n protected\r\n procedure Paint; override;\r\n procedure MouseDown(Button: TMouseButton; Shift: TShiftState;\r\n X, Y: Integer); override;\r\n procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;\r\n procedure MouseUp(Button: TMouseButton; Shift: TShiftState;\r\n X, Y: Integer); override;\r\n function GetPageIndexFromMousePos(X, Y: Integer): Integer; virtual;\r\n procedure SetShowTabWidth;\r\n property TotalTabWidth: Integer read GetTotalTabWidth write SetTotalTabWidth;\r\n property MinTabWidth: TJvDockTabSheet read GetMinTabWidth;\r\n property MaxTabWidth: TJvDockTabSheet read GetMaxTabWidth;\r\n property TabLeftOffset: Integer read FTabLeftOffset write SetTabLeftOffset default 5;\r\n property TabRightOffset: Integer read FTabRightOffset write SetTabRightOffset default 5;\r\n property TabTopOffset: Integer read FTabTopOffset write SetTabTopOffset default 2;\r\n property TabBottomOffset: Integer read FTabBottomOffset write SetTabBottomOffset default 3;\r\n property TabSplitterWidth: Integer read FTabSplitterWidth write SetTabSplitterWidth default 2;\r\n property CaptionTopOffset: Integer read FCaptionTopOffset write SetCaptionTopOffset default 0;\r\n property CaptionLeftOffset: Integer read FCaptionLeftOffset write SetCaptionLeftOffset default 5;\r\n property CaptionRightOffset: Integer read FCaptionRightOffset write SetCaptionRightOffset default 5;\r\n property Sorts[Index: Integer]: TJvDockVIDTabSheet read GetSorts;\r\n property PanelHeight: Integer read GetPanelHeight write SetPanelHeight;\r\n property PanelWidth: Integer read GetPanelWidth;\r\n property TabHeight: Integer read FTabHeight write SetTabHeight;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n procedure Resize; override;\r\n procedure DeleteSorts(Sheet: TJvDockVIDTabSheet);\r\n property Page: TJvDockVIDTabPageControl read FPage write SetPage;\r\n property SelectSheet: TJvDockVIDTabSheet read FSelectSheet write FSelectSheet;\r\n property ShowTabImages: Boolean read FShowTabImages write SetShowTabImages;\r\n {NEW! If docked to a TJvDockPanel, this is it. if not (nil) then it is floating.}\r\n property DockPanel: TJvDockPanel read FDockPanel write FDockPanel;\r\n end;\r\n\r\n TJvDockTabPanelClass = class of TJvDockTabPanel;\r\n\r\n TJvDockVIDTabPageControl = class(TJvDockAdvTabPageControl)\r\n private\r\n FTabPanelClass: TJvDockTabPanelClass;\r\n FPanel: TJvDockTabPanel;\r\n FTempSheet: TJvDockVIDTabSheet;\r\n FTabImageList: TCustomImageList;\r\n procedure SetActiveSheetColor(const Value: TColor);\r\n procedure SetInactiveSheetColor(const Value: TColor);\r\n procedure SetTabBottomOffset(const Value: Integer);\r\n procedure SetTabLeftOffset(const Value: Integer);\r\n procedure SetTabRightOffset(const Value: Integer);\r\n procedure SetTabTopOffset(const Value: Integer);\r\n procedure SetActiveFont(Value: TFont);\r\n procedure SetInactiveFont(Value: TFont);\r\n procedure SetHotTrackColor(const Value: TColor);\r\n function GetTabBottomOffset: Integer;\r\n function GetTabLeftOffset: Integer;\r\n function GetTabRightOffset: Integer;\r\n function GetTabTopOffset: Integer;\r\n function GetInactiveSheetColor: TColor;\r\n function GetActiveSheetColor: TColor;\r\n function GetActiveFont: TFont;\r\n function GetInactiveFont: TFont;\r\n function GetVisibleSheetCount: Integer;\r\n function GetHotTrackColor: TColor;\r\n function GetShowTabImages: Boolean;\r\n procedure SetShowTabImages(const Value: Boolean);\r\n function GetPage(Index: Integer): TJvDockVIDTabSheet;\r\n function GetActiveVIDPage: TJvDockVIDTabSheet;\r\n procedure SetActiveVIDPage(const Value: TJvDockVIDTabSheet);\r\n procedure CMDockNotification(var Msg: TCMDockNotification); message CM_DOCKNOTIFICATION;\r\n protected\r\n procedure AdjustClientRect(var Rect: TRect); override;\r\n procedure CreatePanel; virtual;\r\n procedure Change; override;\r\n procedure DoRemoveDockClient(Client: TControl); override;\r\n\r\n procedure CustomDockOver(Source: TJvDockDragDockObject; X, Y: Integer; State: TDragState;\r\n var Accept: Boolean); override;\r\n procedure CustomGetSiteInfo(Source: TJvDockDragDockObject; Client: TControl; var InfluenceRect: TRect;\r\n MousePos: TPoint; var CanDock: Boolean); override;\r\n procedure CustomDockDrop(Source: TJvDockDragDockObject; X, Y: Integer); override;\r\n procedure CustomGetDockEdge(Source: TJvDockDragDockObject; MousePos: TPoint; var DropAlign: TAlign); override;\r\n function CustomUnDock(Source: TJvDockDragDockObject; NewTarget: TWinControl; Client: TControl): Boolean; override;\r\n procedure DrawTab(TabIndex: Integer; const Rect: TRect; Active: Boolean); override;\r\n procedure CreateParams(var Params: TCreateParams); override;\r\n function GetDockClientFromMousePos(MousePos: TPoint): TControl; override;\r\n procedure Paint; override;\r\n procedure SetActivePage(Page: TJvDockTabSheet); override;\r\n procedure SetTabHeight(Value: Smallint); override;\r\n procedure SetTabPosition(Value: TTabPosition); override;\r\n procedure CreateWnd; override;\r\n procedure Loaded; override;\r\n procedure SetHotTrack(Value: Boolean); override;\r\n procedure SetImages(Value: TCustomImageList); override;\r\n procedure SyncWithStyle; override;\r\n property TabPanelClass: TJvDockTabPanelClass read FTabPanelClass write FTabPanelClass;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n procedure AfterConstruction; override;\r\n property ActiveVIDPage: TJvDockVIDTabSheet read GetActiveVIDPage write SetActiveVIDPage;\r\n destructor Destroy; override;\r\n procedure DockDrop(Source: TDragDockObject; X, Y: Integer); override;\r\n function DoUnDock(NewTarget: TWinControl; Client: TControl): Boolean; override;\r\n\r\n procedure UpdateCaption(Exclude: TControl); override;\r\n procedure Resize; override;\r\n property Pages[Index: Integer]: TJvDockVIDTabSheet read GetPage;\r\n property Panel: TJvDockTabPanel read FPanel;\r\n property TempSheet: TJvDockVIDTabSheet read FTempSheet write FTempSheet;\r\n property VisibleSheetCount: Integer read GetVisibleSheetCount;\r\n published\r\n property ActiveSheetColor: TColor read GetActiveSheetColor write SetActiveSheetColor;\r\n property InactiveSheetColor: TColor read GetInactiveSheetColor write SetInactiveSheetColor;\r\n property TabLeftOffset: Integer read GetTabLeftOffset write SetTabLeftOffset default 5;\r\n property TabRightOffset: Integer read GetTabRightOffset write SetTabRightOffset default 5;\r\n property TabTopOffset: Integer read GetTabTopOffset write SetTabTopOffset default 2;\r\n property TabBottomOffset: Integer read GetTabBottomOffset write SetTabBottomOffset default 3;\r\n property ActiveFont: TFont read GetActiveFont write SetActiveFont;\r\n property InactiveFont: TFont read GetInactiveFont write SetInactiveFont;\r\n property HotTrackColor: TColor read GetHotTrackColor write SetHotTrackColor;\r\n property ShowTabImages: Boolean read GetShowTabImages write SetShowTabImages;\r\n property ActivePage;\r\n property Align;\r\n property Anchors;\r\n property BiDiMode;\r\n property Constraints;\r\n property DockSite;\r\n property DragCursor;\r\n property DragKind;\r\n property DragMode;\r\n property Enabled;\r\n property Font;\r\n property HotTrack;\r\n property Images;\r\n property MultiLine;\r\n property OwnerDraw;\r\n property ParentBiDiMode;\r\n property ParentFont;\r\n property ParentShowHint;\r\n property PopupMenu;\r\n property RaggedRight;\r\n property ScrollOpposite;\r\n property ShowHint;\r\n property Style;\r\n property TabHeight;\r\n property TabIndex;\r\n property TabOrder;\r\n property TabPosition;\r\n property TabStop;\r\n property TabWidth;\r\n property Visible;\r\n property OnChange;\r\n property OnChanging;\r\n property OnContextPopup;\r\n property OnDockDrop;\r\n property OnDockOver;\r\n property OnDragDrop;\r\n property OnDragOver;\r\n property OnDrawTab;\r\n property OnEndDock;\r\n property OnEndDrag;\r\n property OnEnter;\r\n property OnExit;\r\n property OnGetImageIndex;\r\n property OnGetSiteInfo;\r\n property OnMouseDown;\r\n property OnMouseMove;\r\n property OnMouseUp;\r\n property OnResize;\r\n property OnStartDock;\r\n property OnStartDrag;\r\n property OnUnDock;\r\n end;\r\n\r\n TJvDockVIDDragDockObject = class(TJvDockDragDockObject)\r\n private\r\n FOldDropAlign: TAlign;\r\n FCurrState: TDragState;\r\n FOldState: TDragState;\r\n FOldTarget: Pointer;\r\n FSourceDockClientList: TList;\r\n FDropTabControl: TJvDockVIDTabPageControl;\r\n FIsTabDockOver: Boolean;\r\n FErase: Boolean;\r\n function GetSourceDockClient(Index: Integer): TControl;\r\n function GetSourceDockClientCount: Integer;\r\n procedure SetOldState(const Value: TDragState);\r\n procedure SetCurrState(const Value: TDragState);\r\n protected\r\n procedure GetBrush_PenSize_DrawRect(var ABrush: TBrush; var PenSize: Integer;\r\n var DrawRect: TRect; Erase: Boolean); override;\r\n procedure MouseMsg(var Msg: TMessage); override;\r\n procedure DefaultDockImage(Erase: Boolean); override;\r\n function CanLeave(NewTarget: TWinControl): Boolean; override;\r\n public\r\n constructor Create(AControl: TControl); override;\r\n destructor Destroy; override;\r\n function DragFindWindow(const Pos: TPoint): THandle; override;\r\n function GetDropCtl: TControl; override;\r\n property SourceDockClients[Index: Integer]: TControl read GetSourceDockClient;\r\n property SourceDockClientCount: Integer read GetSourceDockClientCount;\r\n property CurrState: TDragState read FCurrState write SetCurrState;\r\n property OldState: TDragState read FOldState write SetOldState;\r\n end;\r\n\r\nprocedure PaintGradientBackground(Canvas: TCanvas; ARect: TRect; StartColor, EndColor: TColor;\r\n Vertical: Boolean = False);\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvDockVIDStyle.pas $';\r\n Revision: '$Revision: 13415 $';\r\n Date: '$Date: 2012-09-10 11:51:54 +0200 (lun. 10 sept. 2012) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n {$IFDEF HAS_UNIT_SYSTEM_UITYPES}\r\n System.UITypes,\r\n {$ENDIF HAS_UNIT_SYSTEM_UITYPES}\r\n Types,\r\n {$IFDEF JVCLThemesEnabled}\r\n JvThemes,\r\n {$ENDIF JVCLThemesEnabled}\r\n SysUtils, Math, Forms,\r\n JvDockSupportProc;\r\n\r\ntype\r\n TJvTempWinControl = class(TWinControl);\r\n\r\nvar\r\n gi_DockRect: TRect;\r\n\r\n{ (rb) Compare to PaintGradientBackground in JvDockVIDVCStyle.pas }\r\nprocedure PaintGradientBackground(Canvas: TCanvas; ARect: TRect;\r\n StartColor, EndColor: TColor; Vertical: Boolean = False);\r\nconst\r\n D = 256;\r\nvar\r\n X, Y, C1, C2, R1, G1, B1, W, H: Integer;\r\n DR, DG, DB, DH, DW: Real;\r\n\r\n procedure InitRGBValues(C1, C2: Integer);\r\n begin\r\n R1 := GetRValue(C1);\r\n G1 := GetGValue(C1);\r\n B1 := GetBValue(C1);\r\n DR := (GetRValue(C2) - R1) / D;\r\n DG := (GetGValue(C2) - G1) / D;\r\n DB := (GetBValue(C2) - B1) / D;\r\n end;\r\n\r\nbegin\r\n with Canvas do\r\n begin\r\n Lock;\r\n try\r\n Brush.Style := bsSolid;\r\n\r\n { !! GetRValue etc. assume that the input param is a RGB value thus\r\n NO system color, such as clWindowText etc. }\r\n C1 := ColorToRGB(StartColor);\r\n C2 := ColorToRGB(EndColor);\r\n\r\n if C1 <> C2 then\r\n begin\r\n InitRGBValues(C1, C2);\r\n\r\n if not Vertical then\r\n begin\r\n DH := (ARect.Right - ARect.Left) / D;\r\n for X := 0 to 255 do\r\n begin\r\n Brush.Color := RGB(R1 + Round(DR * X), G1 + Round(DG * X),\r\n B1 + Round(DB * X));\r\n if ARect.Right <= ARect.Left + Round((X + 1) * DH) then\r\n W := ARect.Right\r\n else\r\n W := ARect.Left + Round((X + 1) * DH);\r\n FillRect(Rect(ARect.Left + Round(X * DH), ARect.Top, W, ARect.Bottom));\r\n end;\r\n end\r\n else\r\n begin\r\n DW := (ARect.Bottom - ARect.Top) / D;\r\n for Y := 0 to 255 do\r\n begin\r\n Brush.Color := RGB(R1 + Round(DR * Y), G1 + Round(DG * Y),\r\n B1 + Round(DB * Y));\r\n if ARect.Bottom <= ARect.Top + Round((Y + 1) * DW) then\r\n H := ARect.Bottom\r\n else\r\n H := ARect.Top + Round((Y + 1) * DW);\r\n FillRect(Rect(ARect.Left, ARect.Top + Round(Y * DW), ARect.Right, H));\r\n end;\r\n end;\r\n end\r\n else\r\n begin\r\n Brush.Color := StartColor;\r\n FillRect(ARect);\r\n end;\r\n finally\r\n Unlock;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure AssignList(FromList, ToList: TList);\r\nvar\r\n I: Integer;\r\nbegin\r\n ToList.Clear;\r\n for I := 0 to FromList.Count - 1 do\r\n ToList.Add(FromList[I]);\r\nend;\r\n\r\nfunction ComputeVIDDockingRect(Target, Control: TControl; var DockRect: TRect; MousePos: TPoint): TAlign;\r\nvar\r\n DockTopRect: TRect;\r\n DockLeftRect: TRect;\r\n DockBottomRect: TRect;\r\n DockRightRect: TRect;\r\n DockCenterRect: TRect;\r\n DockTabRect: TRect;\r\nbegin\r\n Result := alNone;\r\n if Target = nil then\r\n Exit;\r\n\r\n with Target do\r\n begin\r\n DockLeftRect.TopLeft := Point(0, 0);\r\n DockLeftRect.BottomRight := Point(ClientWidth div 5, ClientHeight);\r\n\r\n DockTopRect.TopLeft := Point(ClientWidth div 5, 0);\r\n DockTopRect.BottomRight := Point(ClientWidth div 5 * 4, ClientHeight div 5);\r\n\r\n DockRightRect.TopLeft := Point(ClientWidth div 5 * 4, 0);\r\n DockRightRect.BottomRight := Point(ClientWidth, ClientHeight);\r\n\r\n if Target is TJvDockCustomTabControl then\r\n begin\r\n DockBottomRect.TopLeft := Point(ClientWidth div 5, ClientWidth div 5 * 4);\r\n DockBottomRect.BottomRight := Point(ClientWidth div 5 * 4, ClientHeight - JvDockGetSysCaptionHeight);\r\n end\r\n else\r\n begin\r\n DockBottomRect.TopLeft := Point(0, ClientHeight div 5 * 4);\r\n DockBottomRect.BottomRight := Point(ClientWidth, ClientHeight);\r\n end;\r\n\r\n DockCenterRect.TopLeft := Point(0, -JvDockGetSysCaptionHeight);\r\n DockCenterRect.BottomRight := Point(ClientWidth, 0);\r\n\r\n if Target is TJvDockCustomTabControl then\r\n begin\r\n DockTabRect.TopLeft := Point(0, ClientHeight - JvDockGetSysCaptionHeight);\r\n DockTabRect.BottomRight := Point(ClientWidth, ClientHeight);\r\n end\r\n else\r\n DockTabRect := Rect(0, 0, 0, 0);\r\n\r\n if PtInRect(DockCenterRect, MousePos) or\r\n PtInRect(DockTabRect, MousePos) then\r\n begin\r\n Result := alClient;\r\n DockRect := DockCenterRect;\r\n DockRect.BottomRight := Point(ClientWidth, ClientHeight);\r\n end\r\n else\r\n if PtInRect(DockLeftRect, MousePos) then\r\n begin\r\n Result := alLeft;\r\n DockRect := DockLeftRect;\r\n DockRect.Right := Min(ClientWidth div 2, Control.ClientWidth);\r\n end\r\n else\r\n if PtInRect(DockTopRect, MousePos) then\r\n begin\r\n Result := alTop;\r\n DockRect := DockTopRect;\r\n DockRect.Left := 0;\r\n DockRect.Right := ClientWidth;\r\n DockRect.Bottom := Min(ClientHeight div 2, Control.ClientHeight);\r\n end\r\n else\r\n if PtInRect(DockRightRect, MousePos) then\r\n begin\r\n Result := alRight;\r\n DockRect := DockRightRect;\r\n DockRect.Left := Max(ClientWidth div 2, ClientWidth - Control.ClientWidth);\r\n end\r\n else\r\n if PtInRect(DockBottomRect, MousePos) then\r\n begin\r\n Result := alBottom;\r\n DockRect := DockBottomRect;\r\n DockRect.Top := Max(ClientHeight div 2, ClientHeight - Control.ClientHeight);\r\n end;\r\n if Result = alNone then\r\n Exit;\r\n\r\n DockRect.TopLeft := ClientToScreen(DockRect.TopLeft);\r\n DockRect.BottomRight := ClientToScreen(DockRect.BottomRight);\r\n end;\r\nend;\r\n\r\n(* (ahuser) not used - make Delphi 5 happy\r\nprocedure SetTabControlPreview(VIDSource: TJvDockVIDDragDockObject;\r\n TabControl: TJvDockVIDTabPageControl;\r\n State: TDragState; DropAlign: TAlign);\r\n\r\nvar\r\n I: Integer;\r\n Index: Integer;\r\nbegin\r\n if TabControl <> nil then\r\n begin\r\n if DropAlign = alClient then\r\n begin\r\n\r\n if TabControl.FTempSheet = nil then\r\n begin\r\n\r\n for I := VIDSource.SourceDockClientCount - 1 downto 0 do\r\n begin\r\n\r\n TabControl.FTempSheet := TJvDockVIDTabSheet.Create(TabControl);\r\n TabControl.FTempSheet.PageControl := TabControl;\r\n\r\n TabControl.FTempSheet.Caption := TJvTempWinControl(VIDSource.SourceDockClients[I]).Caption;\r\n Index := TabControl.FTabImageList.AddIcon(TForm(VIDSource.SourceDockClients[I]).Icon);\r\n if Index <> -1 then\r\n TabControl.FTempSheet.ImageIndex := Index;\r\n\r\n TabControl.FTempSheet.FIsSourceDockClient := True;\r\n end;\r\n\r\n TabControl.ActivePage := TabControl.FTempSheet;\r\n TabControl.Panel.SelectSheet := TabControl.FTempSheet;\r\n\r\n TabControl.Panel.FTempPages.Assign(TabControl.PageSheets);\r\n\r\n TabControl.ActivePage.Invalidate;\r\n\r\n end;\r\n end;\r\n\r\n if ((State = dsDragLeave) or (VIDSource.DropAlign <> alClient)) and (TabControl.FTempSheet <> nil) then\r\n begin\r\n\r\n for I := TabControl.PageCount - 1 downto 0 do\r\n begin\r\n if TJvDockVIDTabSheet(TabControl.Pages[I]).FIsSourceDockClient then\r\n begin\r\n\r\n Index := TabControl.Panel.FTempPages.IndexOf(TabControl.Pages[I]);\r\n\r\n if Index >= 0 then\r\n begin\r\n TabControl.Panel.FTempPages.Delete(Index);\r\n if TabControl.FTabImageList.Count > Index then\r\n TabControl.FTabImageList.Delete(Index);\r\n end;\r\n\r\n TabControl.Pages[I].Free;\r\n end;\r\n end;\r\n\r\n TabControl.FTempSheet := nil;\r\n\r\n end;\r\n\r\n TabControl.ParentForm.Caption := TabControl.ActivePage.Caption;\r\n\r\n if TabControl.ParentForm.HostDockSite is TJvDockCustomPanel then\r\n TabControl.ParentForm.HostDockSite.Invalidate;\r\n end;\r\nend;\r\n*)\r\n\r\n//=== { TJvDockVIDStyle } ====================================================\r\n\r\nconstructor TJvDockVIDStyle.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n DockPanelClass := TJvDockVIDPanel;\r\n DockSplitterClass := TJvDockVIDSplitter;\r\n ConjoinPanelClass := TJvDockVIDConjoinPanel;\r\n TabDockClass := TJvDockVIDTabPageControl;\r\n DockPanelTreeClass := TJvDockVIDTree;\r\n DockPanelZoneClass := TJvDockVIDZone;\r\n ConjoinPanelTreeClass := TJvDockVIDTree;\r\n ConjoinPanelZoneClass := TJvDockVIDZone;\r\n ConjoinServerOptionClass := TJvDockVIDConjoinServerOption;\r\n TabServerOptionClass := TJvDockVIDTabServerOption;\r\nend;\r\n\r\nprocedure TJvDockVIDStyle.FormDockOver(DockClient: TJvDockClient; Source: TJvDockDragDockObject; X, Y: Integer;\r\n State: TDragState; var Accept: Boolean);\r\nvar\r\n ARect: TRect;\r\nbegin\r\n with DockClient do\r\n begin\r\n Accept := EnableDock and EachOtherDock and\r\n IsDockable(ParentForm, Source.Control, Source.DropOnControl, Source.DropAlign);\r\n if State = dsDragMove then\r\n begin\r\n Source.DropAlign := ComputeVIDDockingRect(ParentForm, Source.Control, ARect, Point(X, Y));\r\n if Accept and (Source.DropAlign <> alNone) then\r\n begin\r\n if Source.DropAlign = alClient then\r\n Inc(ARect.Top, JvDockGetSysCaptionHeightAndBorderWidth + 1);\r\n Source.DockRect := ARect;\r\n end;\r\n gi_DockRect := ARect;\r\n end\r\n else\r\n if State = dsDragLeave then\r\n Source.DropAlign := alNone;\r\n if Source is TJvDockVIDDragDockObject then\r\n begin\r\n TJvDockVIDDragDockObject(Source).OldState := TJvDockVIDDragDockObject(Source).CurrState;\r\n TJvDockVIDDragDockObject(Source).CurrState := State;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockVIDStyle.FormGetSiteInfo(Source: TJvDockDragDockObject; DockClient: TJvDockClient;\r\n Client: TControl; var InfluenceRect: TRect; MousePos: TPoint;\r\n var CanDock: Boolean);\r\nconst\r\n DefExpandoRect = 20;\r\nvar\r\n CH_BW: Integer;\r\n ARect: TRect;\r\nbegin\r\n with DockClient do\r\n begin\r\n CanDock := IsDockable(ParentForm, Client, Source.DropOnControl, Source.DropAlign);\r\n if CanDock then\r\n begin\r\n GetWindowRect(ParentForm.Handle, InfluenceRect);\r\n if ParentForm.HostDockSite is TJvDockCustomPanel then\r\n Dec(InfluenceRect.Top, TJvDockCustomPanel(ParentForm.HostDockSite).JvDockManager.GrabberSize);\r\n if PtInRect(InfluenceRect, MousePos) then\r\n begin\r\n ARect := InfluenceRect;\r\n InflateRect(ARect, -DefExpandoRect, -DefExpandoRect);\r\n CH_BW := JvDockGetSysCaptionHeightAndBorderWidth;\r\n Inc(ARect.Top, CH_BW + 1);\r\n if PtInRect(ARect, MousePos) then\r\n begin\r\n InfluenceRect := Rect(0, 0, 0, 0);\r\n CanDock := False;\r\n end;\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockVIDStyle.FormDockDrop(DockClient: TJvDockClient;\r\n Source: TJvDockDragDockObject; X, Y: Integer);\r\nvar\r\n ARect, DRect: TRect;\r\n DockType: TAlign;\r\n Host: TJvDockableForm;\r\n APanelDock: TWinControl;\r\n VIDSource: TJvDockVIDDragDockObject;\r\n I: Integer;\r\nbegin\r\n if Source is TJvDockVIDDragDockObject then\r\n begin\r\n TJvDockVIDDragDockObject(Source).CurrState := dsDragEnter;\r\n TJvDockVIDDragDockObject(Source).OldState := dsDragEnter;\r\n end;\r\n\r\n if IsDockable(DockClient.ParentForm, Source.Control, Source.DropOnControl, Source.DropAlign) then\r\n begin\r\n Host := nil;\r\n JvDockLockWindow(nil);\r\n try\r\n with DockClient do\r\n begin\r\n DockType := ComputeVIDDockingRect(DockClient.ParentForm, Source.Control, ARect, Point(X, Y));\r\n if ParentForm.HostDockSite is TJvDockPanel then\r\n begin\r\n if DockType = alClient then\r\n begin\r\n if Source.Control is TJvDockTabHostForm then\r\n begin\r\n APanelDock := ParentForm.HostDockSite;\r\n ARect := ParentForm.BoundsRect;\r\n ParentForm.ManualDock(TJvDockTabHostForm(Source.Control).PageControl, nil, alClient);\r\n TJvDockTabHostForm(Source.Control).PageControl.ActivePage.PageIndex := 0;\r\n Source.Control.BoundsRect := ARect;\r\n Source.Control.ManualDock(APanelDock, nil, alClient);\r\n if ParentForm.FormStyle = fsStayOnTop then\r\n TForm(Source.Control).FormStyle := fsStayOnTop;\r\n end\r\n else\r\n begin\r\n APanelDock := ParentForm.HostDockSite;\r\n DRect.TopLeft := ParentForm.HostDockSite.ClientToScreen(Point(0, 0));\r\n Host := CreateTabHostAndDockControl(ParentForm, Source.Control);\r\n SetDockSite(ParentForm, False);\r\n SetDockSite(TWinControl(Source.Control), False);\r\n Host.Top := DRect.Top;\r\n Host.Left := DRect.Left;\r\n Host.Visible := True;\r\n Host.ManualDock(APanelDock, nil, alClient);\r\n end;\r\n end\r\n else\r\n begin\r\n DRect := ParentForm.HostDockSite.BoundsRect;\r\n Source.Control.ManualDock(ParentForm.HostDockSite, nil, DockType);\r\n ParentForm.HostDockSite.BoundsRect := DRect;\r\n SetDockSite(TWinControl(Source.Control), False);\r\n end;\r\n Exit;\r\n end;\r\n\r\n if DockType = alClient then\r\n begin\r\n if Source.Control is TJvDockTabHostForm then\r\n begin\r\n APanelDock := ParentForm.HostDockSite;\r\n ARect := ParentForm.BoundsRect;\r\n ParentForm.ManualDock(TJvDockTabHostForm(Source.Control).PageControl, nil, alClient);\r\n TJvDockTabHostForm(Source.Control).PageControl.ActivePage.PageIndex := 0;\r\n Source.Control.BoundsRect := ARect;\r\n Source.Control.ManualDock(APanelDock, nil, alClient);\r\n if ParentForm.FormStyle = fsStayOnTop then\r\n TForm(Source.Control).FormStyle := fsStayOnTop;\r\n Exit;\r\n end\r\n else\r\n begin\r\n if Source is TJvDockVIDDragDockObject then\r\n begin\r\n VIDSource := TJvDockVIDDragDockObject(Source);\r\n DoFloatForm(Source.Control);\r\n FreeAllDockableForm;\r\n for I := 0 to VIDSource.SourceDockClientCount - 1 do\r\n begin\r\n VIDSource.Control := VIDSource.SourceDockClients[I];\r\n if Host = nil then\r\n Host := DockClient.CreateTabHostAndDockControl(DockClient.ParentForm, Source.Control)\r\n else\r\n Source.Control.ManualDock(TJvDockTabHostForm(Host).PageControl, nil, alClient);\r\n end;\r\n if not JvGlobalDockIsLoading and\r\n (TJvDockTabHostForm(Host).GetActiveDockForm <> nil) and\r\n GetParentForm(Host).Visible and\r\n TJvDockTabHostForm(Host).GetActiveDockForm.CanFocus then\r\n TJvDockTabHostForm(Host).GetActiveDockForm.SetFocus;\r\n Host.Visible := True;\r\n end;\r\n end;\r\n end\r\n else\r\n if DockType <> alNone then\r\n begin\r\n Host := CreateConjoinHostAndDockControl(ParentForm, Source.Control, DockType);\r\n SetDockSite(ParentForm, False);\r\n SetDockSite(TWinControl(Source.Control), False);\r\n Host.Visible := True;\r\n end;\r\n\r\n if Host <> nil then\r\n begin\r\n Host.LRDockWidth := Source.Control.LRDockWidth;\r\n Host.TBDockHeight := Source.Control.TBDockHeight;\r\n end;\r\n end;\r\n finally\r\n JvDockUnLockWindow;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockVIDStyle.SetDockBaseControl(IsCreate: Boolean;\r\n DockBaseControl: TJvDockBaseControl);\r\nvar\r\n ADockClient: TJvDockClient;\r\nbegin\r\n if DockBaseControl is TJvDockClient then\r\n begin\r\n ADockClient := TJvDockClient(DockBaseControl);\r\n if IsCreate then\r\n ADockClient.DirectDrag := False;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockVIDStyle.FormStartDock(DockClient: TJvDockClient;\r\n var Source: TJvDockDragDockObject);\r\nbegin\r\n inherited FormStartDock(DockClient, Source);\r\n Source := TJvDockVIDDragDockObject.Create(DockClient.ParentForm);\r\n{allows DockClient.OnCheckIsDockable event to fire once before docking, to block or allow drag/drop to this site. }\r\n// Source.DockClient := DockClient;\r\nend;\r\n\r\nprocedure TJvDockVIDStyle.FormGetDockEdge(DockClient: TJvDockClient;\r\n Source: TJvDockDragDockObject; MousePos: TPoint; var DropAlign: TAlign);\r\nvar\r\n ARect: TRect;\r\nbegin\r\n DropAlign := ComputeVIDDockingRect(DockClient.ParentForm, Source.Control, ARect, MousePos);\r\nend;\r\n\r\nfunction TJvDockVIDStyle.DockClientWindowProc(DockClient: TJvDockClient;\r\n var Msg: TMessage): Boolean;\r\nbegin\r\n Result := inherited DockClientWindowProc(DockClient, Msg);\r\nend;\r\n\r\nprocedure TJvDockVIDStyle.DoSystemInfoChange(Value: Boolean);\r\nbegin\r\n if Assigned(FSystemInfoChange) then\r\n FSystemInfoChange(Value);\r\nend;\r\n\r\nprocedure TJvDockVIDStyle.SetAlwaysShowGrabber(const Value: Boolean);\r\nbegin\r\n if Value <> FAlwaysShowGrabber then\r\n begin\r\n FAlwaysShowGrabber := Value;\r\n Changed;\r\n end;\r\nend;\r\n\r\n//=== { TJvDockVIDPanel } ====================================================\r\n\r\nprocedure TJvDockVIDPanel.CustomDockDrop(Source: TJvDockDragDockObject; X, Y: Integer);\r\nbegin\r\n if Source.Control is TJvDockableForm then\r\n ShowDockPanel(True, Source.Control);\r\n if not ((Source.Control.HostDockSite <> nil) and\r\n (Source.DropOnControl = Source.Control.HostDockSite.Parent) and\r\n (Source.DropAlign = alClient)) then\r\n begin\r\n inherited CustomDockDrop(Source, X, Y);\r\n {$IFNDEF COMPILER9_UP}\r\n InvalidateDockHostSiteOfControl(Source.Control, False);\r\n {$ENDIF !COMPILER9_UP}\r\n if (Source.Control is TWinControl) and TWinControl(Source.Control).CanFocus then\r\n TWinControl(Source.Control).SetFocus;\r\n if (ControlCount > 0) and Assigned(Controls[0]) and (Controls[0] is TJvDockTabHostForm) then \r\n begin\r\n with TJvDockTabHostForm(Controls[0]) do\r\n if (GetActiveDockForm <> nil) and GetActiveDockForm.CanFocus then\r\n GetActiveDockForm.SetFocus;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockVIDPanel.CustomDockOver(Source: TJvDockDragDockObject;\r\n X, Y: Integer; State: TDragState; var Accept: Boolean);\r\nvar\r\n DropAlign: TAlign;\r\nbegin\r\n inherited CustomDockOver(Source, X, Y, State, Accept);\r\n if Accept and (Source is TJvDockVIDDragDockObject) then\r\n if State = dsDragMove then\r\n begin\r\n DropAlign := Source.DropAlign;\r\n JvDockManager.GetDockEdge(Source.DockRect, Source.DragPos, DropAlign, Source.Control);\r\n end;\r\nend;\r\n\r\nprocedure TJvDockVIDPanel.CustomGetDockEdge(Source: TJvDockDragDockObject;\r\n MousePos: TPoint; var DropAlign: TAlign);\r\nbegin\r\nend;\r\n\r\nprocedure TJvDockVIDPanel.CustomGetSiteInfo(Source: TJvDockDragDockObject;\r\n Client: TControl; var InfluenceRect: TRect; MousePos: TPoint;\r\n var CanDock: Boolean);\r\nbegin\r\n if VisibleDockClientCount = 0 then\r\n inherited CustomGetSiteInfo(Source, Client, InfluenceRect, MousePos, CanDock)\r\n else\r\n begin\r\n CanDock := IsDockable(Self, Client, Source.DropOnControl, Source.DropAlign);\r\n if CanDock then\r\n JvDockManager.GetSiteInfo(Client, InfluenceRect, MousePos, CanDock);\r\n end;\r\nend;\r\n\r\nprocedure TJvDockVIDPanel.CustomStartDock(var Source: TJvDockDragDockObject);\r\nbegin\r\n Source := TJvDockVIDDragDockObject.Create(Self);\r\nend;\r\n\r\nprocedure TJvDockVIDPanel.DockDrop(Source: TDragDockObject; X, Y: Integer);\r\nbegin\r\n inherited DockDrop(Source, X, Y);\r\nend;\r\n\r\nprocedure TJvDockVIDPanel.UpdateCaption(Exclude: TControl);\r\nbegin\r\n inherited UpdateCaption(Exclude);\r\n Invalidate;\r\nend;\r\n\r\n//=== { TJvDockVIDTree } =====================================================\r\n\r\nconstructor TJvDockVIDTree.Create(DockSite: TWinControl;\r\n DockZoneClass: TJvDockZoneClass; ADockStyle: TJvDockObservableStyle);\r\nbegin\r\n inherited Create(DockSite, DockZoneClass, ADockStyle);\r\n FDropOnZone := nil;\r\n\r\n ButtonHeight := 11;\r\n ButtonWidth := 13;\r\n LeftOffset := 4;\r\n RightOffset := 4;\r\n TopOffset := 4;\r\n BottomOffset := 3;\r\n ButtonSplitter := 2;\r\n BorderWidth := 0;\r\n MinSize := 20;\r\n CaptionLeftOffset := 0;\r\n CaptionRightOffset := 0;\r\nend;\r\n\r\nfunction TJvDockVIDTree.GetDockGrabbersPosition: TJvDockGrabbersPosition;\r\nbegin\r\n Result := gpTop;\r\nend;\r\n\r\nfunction TJvDockVIDTree.GetTopGrabbersHTFlag(const MousePos: TPoint;\r\n out HTFlag: Integer; Zone: TJvDockZone): TJvDockZone;\r\nbegin\r\n if (MousePos.Y >= Zone.Top) and (MousePos.Y <= Zone.Top + GrabberSize) and\r\n (MousePos.X >= Zone.Left) and (MousePos.X <= Zone.Left + Zone.Width) then\r\n begin\r\n Result := Zone;\r\n with Zone.ChildControl do\r\n begin\r\n if PtInRect(Rect(\r\n Left + Width - ButtonWidth - RightOffset,\r\n Top - GrabberSize + TopOffset,\r\n Left + Width - RightOffset,\r\n Top - GrabberSize + TopOffset + ButtonHeight), MousePos) then\r\n HTFlag := HTCLOSE\r\n else\r\n HTFlag := HTCAPTION;\r\n end;\r\n end\r\n else\r\n Result := nil;\r\nend;\r\n\r\nprocedure TJvDockVIDTree.InsertControl(Control: TControl; InsertAt: TAlign;\r\n DropCtl: TControl);\r\nvar\r\n I: Integer;\r\n Host: TJvDockTabHostForm;\r\n ChildCount: Integer;\r\n VIDSource: TJvDockVIDDragDockObject;\r\n TempControl: TControl;\r\n ARect: TRect;\r\n AZone: TJvDockZone;\r\n\r\n function CreateDockPageControl(Client: TControl): TJvDockTabHostForm;\r\n var\r\n Zone: TJvDockZone;\r\n TempCtl: TControl;\r\n TempPanel: TJvDockConjoinPanel;\r\n DockClient: TJvDockClient;\r\n APoint: TPoint;\r\n begin\r\n {$IFDEF JVDOCK_DEBUG}\r\n OutputDebugString('TJvDockVIDTree.InsertControl.CreateDockPageControl');\r\n {$ENDIF JVDOCK_DEBUG}\r\n Result := nil;\r\n Zone := FindControlZone(DropCtl);\r\n DockClient := FindDockClient(DropCtl);\r\n if (DockClient <> nil) and (Zone <> nil) then\r\n begin\r\n TempCtl := DropCtl;\r\n\r\n if Zone.ParentZone.Orientation = doHorizontal then\r\n begin\r\n if Zone.PrevSibling = nil then\r\n begin\r\n if Zone.NextSibling <> nil then\r\n DropCtl := Zone.NextSibling.ChildControl;\r\n InsertAt := alTop;\r\n end\r\n else\r\n begin\r\n DropCtl := Zone.PrevSibling.ChildControl;\r\n InsertAt := alBottom;\r\n end;\r\n end\r\n else\r\n if Zone.ParentZone.Orientation = doVertical then\r\n begin\r\n if Zone.PrevSibling = nil then\r\n begin\r\n if Zone.NextSibling <> nil then\r\n DropCtl := Zone.NextSibling.ChildControl;\r\n InsertAt := alLeft;\r\n end\r\n else\r\n begin\r\n DropCtl := Zone.PrevSibling.ChildControl;\r\n InsertAt := alRight;\r\n end;\r\n end;\r\n\r\n if TempCtl.HostDockSite is TJvDockConjoinPanel then\r\n TempPanel := TJvDockConjoinPanel(TempCtl.HostDockSite)\r\n else\r\n TempPanel := nil;\r\n\r\n Result := DockClient.CreateTabHostAndDockControl(TempCtl, Client);\r\n if TempPanel <> nil then\r\n\r\n TempPanel.ParentForm.UnDockControl := Result;\r\n\r\n SetDockSite(TWinControl(TempCtl), False);\r\n SetDockSite(TWinControl(Client), False);\r\n\r\n if DockSite.Align = alBottom then\r\n APoint := Point(0, -TempCtl.TBDockHeight)\r\n else\r\n if DockSite.Align = alRight then\r\n APoint := Point(-TempCtl.LRDockWidth, 0)\r\n else\r\n APoint := Point(0, 0);\r\n APoint := DockSite.ClientToScreen(APoint);\r\n Result.Left := APoint.X;\r\n Result.Top := APoint.Y;\r\n Result.UndockWidth := TempCtl.UndockWidth;\r\n Result.UndockHeight := TempCtl.UndockHeight;\r\n Result.LRDockWidth := TempCtl.LRDockWidth;\r\n Result.TBDockHeight := TempCtl.TBDockHeight + GrabberSize;\r\n\r\n Result.Visible := True;\r\n end;\r\n end;\r\n\r\nbegin\r\n {$IFDEF JVDOCK_DEBUG}\r\n OutputDebugString('TJvDockVIDTree.InsertControl');\r\n {$ENDIF JVDOCK_DEBUG}\r\n if not JvGlobalDockIsLoading then\r\n JvDockLockWindow(nil);\r\n try\r\n VIDSource := nil;\r\n if Control is TJvDockableForm then\r\n begin\r\n if InsertAt in [alClient] then\r\n begin\r\n if DropCtl is TJvDockTabHostForm then\r\n begin\r\n try\r\n VIDSource := TJvDockVIDDragDockObject.Create(Control);\r\n DoFloatForm(Control);\r\n FreeAllDockableForm;\r\n for I := VIDSource.SourceDockClientCount - 1 downto 0 do\r\n begin\r\n TempControl := VIDSource.SourceDockClients[I];\r\n TempControl.ManualDock(TJvDockTabHostForm(DropCtl).PageControl);\r\n if TempControl is TForm then\r\n begin\r\n TForm(TempControl).ActiveControl := nil;\r\n SetDockSite(TForm(TempControl), False);\r\n end;\r\n end;\r\n finally\r\n VIDSource.Free;\r\n JvGlobalDockManager.DragObject.Control := nil;\r\n end;\r\n end\r\n else\r\n begin\r\n if (DockSite is TJvDockCustomPanel) and (DockSite.VisibleDockClientCount > 1) and (DropCtl <> nil) then\r\n begin\r\n try\r\n VIDSource := TJvDockVIDDragDockObject.Create(Control);\r\n DoFloatForm(Control);\r\n FreeAllDockableForm;\r\n\r\n Host := CreateDockPageControl(VIDSource.SourceDockClients[0]);\r\n if Host <> nil then\r\n begin\r\n for I := VIDSource.SourceDockClientCount - 1 downto 1 do\r\n begin\r\n TempControl := VIDSource.SourceDockClients[I];\r\n TempControl.ManualDock(Host.PageControl);\r\n if TempControl is TForm then\r\n begin\r\n TForm(TempControl).ActiveControl := nil;\r\n SetDockSite(TForm(TempControl), False);\r\n end;\r\n end;\r\n\r\n Host.ManualDock(DockSite, nil, InsertAt);\r\n end;\r\n finally\r\n VIDSource.Free;\r\n JvGlobalDockManager.DragObject.Control := nil;\r\n end;\r\n end\r\n else\r\n inherited InsertControl(Control, InsertAt, DropCtl);\r\n end;\r\n end\r\n else\r\n if Control is TJvDockConjoinHostForm then\r\n begin\r\n TJvTempWinControl(TJvDockableForm(Control).DockableControl).DockManager.ResetBounds(True);\r\n InsertControlFromConjoinHost(Control, InsertAt, DropCtl);\r\n end\r\n else\r\n inherited InsertControl(Control, InsertAt, DropCtl);\r\n end\r\n else\r\n begin\r\n if InsertAt in [alLeft, alTop] then\r\n DropDockSize := DropDockSize + SplitterWidth div 2;\r\n if InsertAt in [alClient] then\r\n begin\r\n if DropCtl is TJvDockTabHostForm then\r\n Control.ManualDock(TJvDockTabHostForm(DropCtl).PageControl, nil, alClient)\r\n else\r\n if TopZone.ChildZones <> nil then\r\n begin\r\n ChildCount := TopZone.ChildCount;\r\n if DropCtl <> nil then\r\n begin\r\n ARect := DropCtl.BoundsRect;\r\n AZone := FindControlZone(DropCtl);\r\n\r\n if DropCtl.DockOrientation = doHorizontal then\r\n begin\r\n if ((AZone <> nil) and (AZone.ZoneLimit <> DockSite.Height)) then\r\n ARect.Bottom := ARect.Bottom + SplitterWidth;\r\n end\r\n else\r\n begin\r\n if ((AZone <> nil) and (AZone.ZoneLimit <> DockSite.Width)) then\r\n ARect.Right := ARect.Right + SplitterWidth;\r\n end;\r\n DockRect := ARect;\r\n end\r\n else\r\n DockRect := Rect(0, 0, TopZone.Width, TopZone.Height);\r\n\r\n Host := CreateDockPageControl(Control);\r\n if Host <> nil then\r\n if (ChildCount >= 2) or (DockSite is TJvDockPanel) then\r\n begin\r\n if InsertAt in [alLeft, alRight] then\r\n DropDockSize := DockRect.Right - DockRect.Left\r\n else\r\n DropDockSize := DockRect.Bottom - DockRect.Top + GrabberSize;\r\n\r\n LockDropDockSize;\r\n Host.ManualDock(DockSite, DropCtl, InsertAt);\r\n\r\n UnlockDropDockSize;\r\n end\r\n else\r\n Host.BoundsRect := DockSite.Parent.BoundsRect;\r\n end\r\n else\r\n inherited InsertControl(Control, InsertAt, DropCtl);\r\n end\r\n else\r\n inherited InsertControl(Control, InsertAt, DropCtl);\r\n\r\n { (rb) no idea what gi_DockRect should be doing, but prevent it is used\r\n before it is set (by checking whether it is empty). Using it when the rect\r\n is empty causes align problems }\r\n if not IsRectEmpty(gi_DockRect) then\r\n DockRect := gi_DockRect;\r\n end;\r\n ForEachAt(nil, UpdateZone);\r\n finally\r\n if not JvGlobalDockIsLoading then\r\n JvDockUnLockWindow;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockVIDTree.InsertControlFromConjoinHost(Control: TControl;\r\n InsertAt: TAlign; DropCtl: TControl);\r\nconst\r\n OrientArray: array [TAlign] of TDockOrientation =\r\n (doNoOrient, doHorizontal, doHorizontal, doVertical, doVertical, doNoOrient, doNoOrient);\r\n MakeLast: array [TAlign] of Boolean =\r\n (False, False, True, False, True, False, False);\r\n ReverseAt: array [TAlign] of TAlign =\r\n (alClient, alBottom, alTop, alRight, alLeft, alNone, alCustom);\r\nvar\r\n Stream: TMemoryStream;\r\n TopOrientation: TDockOrientation;\r\n InsertOrientation: TDockOrientation;\r\n CurrentOrientation: TDockOrientation;\r\n ZoneLimit: Integer;\r\n Level, LastLevel, I: Integer;\r\n Zone, NextZone: TJvDockZone;\r\n DropCtlZone, LastZone: TJvDockZone;\r\n OffsetXYLimitArr: array [TDockOrientation] of Integer;\r\n ControlXYLimitArr: array [TDockOrientation] of Integer;\r\n\r\n procedure ReadZone(SetZone: Boolean);\r\n var\r\n I: Integer;\r\n begin\r\n with Stream do\r\n begin\r\n Read(Level, SizeOf(Level));\r\n if Level = TreeStreamEndFlag then\r\n Exit;\r\n Zone := DockZoneClass.Create(Self);\r\n CustomLoadZone(Stream, Zone);\r\n ZoneLimit := Zone.ZoneLimit;\r\n end;\r\n if SetZone then\r\n begin\r\n if Level = LastLevel then\r\n begin\r\n Zone.NextSibling := LastZone.NextSibling;\r\n if LastZone.NextSibling <> nil then\r\n LastZone.NextSibling.PrevSibling := Zone;\r\n LastZone.NextSibling := Zone;\r\n Zone.PrevSibling := LastZone;\r\n Zone.ParentZone := LastZone.ParentZone;\r\n end\r\n else\r\n if Level > LastLevel then\r\n begin\r\n LastZone.ChildZones := Zone;\r\n Zone.ParentZone := LastZone;\r\n InsertOrientation := LastZone.Orientation;\r\n end\r\n else\r\n if Level < LastLevel then\r\n begin\r\n NextZone := LastZone;\r\n for I := 1 to LastLevel - Level do\r\n NextZone := NextZone.ParentZone;\r\n Zone.NextSibling := NextZone.NextSibling;\r\n if NextZone.NextSibling <> nil then\r\n NextZone.NextSibling.PrevSibling := Zone;\r\n NextZone.NextSibling := Zone;\r\n Zone.PrevSibling := NextZone;\r\n Zone.ParentZone := NextZone.ParentZone;\r\n InsertOrientation := Zone.ParentZone.Orientation;\r\n end;\r\n Zone.ZoneLimit := OffsetXYLimitArr[InsertOrientation] + ZoneLimit;\r\n end;\r\n LastLevel := Level;\r\n LastZone := Zone;\r\n end;\r\n\r\nbegin\r\n ControlXYLimitArr[doNoOrient] := 0;\r\n ControlXYLimitArr[doHorizontal] := DockRect.Bottom - DockRect.Top;\r\n ControlXYLimitArr[doVertical] := DockRect.Right - DockRect.Left;\r\n\r\n Stream := TMemoryStream.Create;\r\n if Control is TJvDockConjoinHostForm then\r\n TJvDockConjoinHostForm(Control).Panel.JvDockManager.SaveToStream(Stream);\r\n Stream.Position := 0;\r\n\r\n BeginUpdate;\r\n try\r\n Stream.Read(I, SizeOf(I));\r\n Stream.Position := Stream.Position + 8;\r\n Stream.Read(TopOrientation, SizeOf(TopOrientation));\r\n Stream.Read(ZoneLimit, SizeOf(ZoneLimit));\r\n IgnoreZoneInfor(Stream);\r\n if (DropCtl = nil) and (TopZone.ChildCount = 1) then\r\n DropCtl := TopZone.ChildZones.ChildControl;\r\n DropCtlZone := FindControlZone(DropCtl);\r\n if InsertAt in [alClient, alNone] then\r\n InsertAt := alRight;\r\n InsertOrientation := OrientArray[InsertAt];\r\n if TopZone.ChildCount = 0 then\r\n begin\r\n TopZone.Orientation := TopOrientation;\r\n InsertOrientation := TopOrientation;\r\n end\r\n else\r\n if TopZone.ChildCount = 1 then\r\n begin\r\n TopZone.Orientation := InsertOrientation;\r\n case InsertOrientation of\r\n doHorizontal:\r\n begin\r\n TopZone.ZoneLimit := TopZone.ChildZones.Width;\r\n TopXYLimit := TopZone.ChildZones.Height;\r\n end;\r\n doVertical:\r\n begin\r\n TopZone.ZoneLimit := TopZone.ChildZones.Height;\r\n TopXYLimit := TopZone.ChildZones.Width;\r\n end;\r\n end;\r\n end;\r\n\r\n if DropCtlZone <> nil then\r\n CurrentOrientation := DropCtlZone.ParentZone.Orientation\r\n else\r\n CurrentOrientation := TopZone.Orientation;\r\n\r\n if InsertOrientation = doHorizontal then\r\n DropDockSize := DockRect.Bottom - DockRect.Top\r\n else\r\n if InsertOrientation = doVertical then\r\n DropDockSize := DockRect.Right - DockRect.Left\r\n else\r\n DropDockSize := 0;\r\n\r\n OffsetXYLimitArr[doNoOrient] := 0;\r\n if DropCtlZone <> nil then\r\n begin\r\n OffsetXYLimitArr[doHorizontal] := DropCtlZone.TopLeft[doHorizontal] +\r\n Integer(MakeLast[InsertAt]) * (DropCtlZone.HeightWidth[doHorizontal] - ControlXYLimitArr[doHorizontal]);\r\n if (FDropOnZone <> nil) and (InsertOrientation = doHorizontal) then\r\n OffsetXYLimitArr[doHorizontal] := FDropOnZone.ZoneLimit - Round((FDropOnZone.ZoneLimit -\r\n FDropOnZone.ParentZone.ChildZones.LimitBegin) * (DropDockSize + BorderWidth) /\r\n (FDropOnZone.ParentZone.Height));\r\n OffsetXYLimitArr[doVertical] := DropCtlZone.TopLeft[doVertical] +\r\n Integer(MakeLast[InsertAt]) * (DropCtlZone.HeightWidth[doVertical] - ControlXYLimitArr[doVertical]);\r\n if (FDropOnZone <> nil) and (InsertOrientation = doVertical) then\r\n OffsetXYLimitArr[doVertical] := FDropOnZone.ZoneLimit - Round((FDropOnZone.ZoneLimit -\r\n FDropOnZone.ParentZone.ChildZones.LimitBegin) * (DropDockSize + BorderWidth) /\r\n (FDropOnZone.ParentZone.Width));\r\n end\r\n else\r\n begin\r\n if TopZone.VisibleChildCount = 0 then\r\n begin\r\n OffsetXYLimitArr[doHorizontal] := 0;\r\n OffsetXYLimitArr[doVertical] := 0;\r\n end\r\n else\r\n begin\r\n OffsetXYLimitArr[doHorizontal] := Integer(MakeLast[InsertAt]) * ControlXYLimitArr[doHorizontal];\r\n OffsetXYLimitArr[doVertical] := Integer(MakeLast[InsertAt]) * ControlXYLimitArr[doVertical];\r\n end;\r\n end;\r\n\r\n if TopOrientation <> InsertOrientation then\r\n begin\r\n LastZone := DockZoneClass.Create(Self);\r\n if InsertOrientation <> CurrentOrientation then\r\n InsertNewParent(LastZone, DropCtlZone, InsertOrientation, MakeLast[InsertAt], True)\r\n else\r\n InsertSibling(LastZone, DropCtlZone, MakeLast[InsertAt], True);\r\n LastZone.Orientation := TopOrientation;\r\n LastLevel := 0;\r\n end\r\n else\r\n begin\r\n LastLevel := 1;\r\n if TopZone.ChildCount > 0 then\r\n begin\r\n ReadZone(False);\r\n if InsertOrientation <> CurrentOrientation then\r\n InsertNewParent(LastZone, DropCtlZone, InsertOrientation, MakeLast[InsertAt], True)\r\n else\r\n InsertSibling(LastZone, DropCtlZone, MakeLast[InsertAt], True);\r\n LastZone.ZoneLimit := ZoneLimit + OffsetXYLimitArr[InsertOrientation];\r\n end\r\n else\r\n begin\r\n LastLevel := 0;\r\n LastZone := TopZone;\r\n end;\r\n end;\r\n\r\n OffsetXYLimitArr[doHorizontal] := LastZone.TopLeft[doHorizontal];\r\n OffsetXYLimitArr[doVertical] := LastZone.TopLeft[doVertical];\r\n\r\n while True do\r\n begin\r\n ReadZone(True);\r\n if Level = TreeStreamEndFlag then\r\n Break;\r\n end;\r\n finally\r\n Stream.Free;\r\n EndUpdate;\r\n end;\r\n SetNewBounds(nil);\r\nend;\r\n\r\nprocedure TJvDockVIDTree.DrawDockGrabber(Control: TWinControl; const ARect: TRect);\r\nconst\r\n TextAlignment: array [TAlignment] of UINT =\r\n (DT_LEFT, DT_RIGHT, DT_CENTER);\r\nvar\r\n Option: TJvDockVIDConjoinServerOption;\r\n DrawRect: TRect;\r\n uFormat: UINT;\r\n IsActive: Boolean;\r\nbegin\r\n Assert(Assigned(Control));\r\n\r\n case GrabbersPosition of\r\n gpTop:\r\n if Assigned(DockStyle) and (DockStyle.ConjoinServerOption is TJvDockVIDConjoinServerOption) then\r\n begin\r\n Option := TJvDockVIDConjoinServerOption(DockStyle.ConjoinServerOption);\r\n\r\n IsActive := Assigned(Screen.ActiveControl) and Screen.ActiveControl.Focused and\r\n Control.ContainsControl(Screen.ActiveControl);\r\n DrawRect := ARect;\r\n\r\n Inc(DrawRect.Top, 2);\r\n DrawRect.Bottom := DrawRect.Top + GrabberSize - 3;\r\n if IsActive then\r\n PaintGradientBackground(Canvas, DrawRect, Option.ActiveTitleStartColor,\r\n Option.ActiveTitleEndColor, Option.ActiveTitleVerticalGradient)\r\n else\r\n PaintGradientBackground(Canvas, DrawRect, Option.InactiveTitleStartColor,\r\n Option.InactiveTitleEndColor, Option.InactiveTitleVerticalGradient);\r\n Canvas.Brush.Style := bsClear; // body already painted\r\n PaintDockGrabberRect(Canvas, Control, DrawRect, Option.ActiveDockGrabber);\r\n\r\n if IsActive then\r\n Canvas.Font.Assign(Option.ActiveFont)\r\n else\r\n Canvas.Font.Assign(Option.InactiveFont);\r\n Canvas.Brush.Style := bsClear;\r\n GetCaptionRect(DrawRect);\r\n uFormat := DT_VCENTER or DT_SINGLELINE or\r\n (Cardinal(Ord(Option.TextEllipsis)) * DT_END_ELLIPSIS) or TextAlignment[Option.TextAlignment];\r\n { DIRTY cast }\r\n DrawText(Canvas.Handle, PChar(TForm(Control).Caption), -1, DrawRect, uFormat);\r\n if ShowCloseButtonOnGrabber or not (Control is TJvDockTabHostForm) then\r\n DrawCloseButton(Canvas, FindControlZone(Control), ARect.Right - RightOffset - ButtonWidth, ARect.Top + TopOffset);\r\n end;\r\n {$IFDEF JVDOCK_DEBUG}\r\n gpBottom:\r\n OutputDebugString('GrabbersPosition = gpBottom - Not supported');\r\n gpRight:\r\n OutputDebugString('GrabbersPosition = gpRight - Not supported');\r\n gpLeft:\r\n OutputDebugString('GrabbersPosition=gpLeft - Not supported');\r\n {$ENDIF JVDOCK_DEBUG}\r\n end;\r\nend;\r\n\r\nprocedure TJvDockVIDTree.ResetBounds(Force: Boolean);\r\nvar\r\n R: TRect;\r\nbegin\r\n if not (csLoading in DockSite.ComponentState) and\r\n (TopZone <> nil) and (DockSite.DockClientCount > 0) then\r\n begin\r\n R := DockSite.ClientRect;\r\n if DockSite is TJvDockConjoinPanel then\r\n begin\r\n if R.Right = R.Left then\r\n Inc(R.Right, DockSite.Parent.UndockWidth);\r\n if R.Bottom = R.Top then\r\n Inc(R.Bottom, DockSite.Parent.UndockHeight);\r\n end;\r\n if Force or (not CompareMem(@R, @PreviousRect, SizeOf(TRect))) then\r\n begin\r\n case TopZone.Orientation of\r\n doHorizontal:\r\n begin\r\n if R.Right - R.Left > 0 then\r\n TopZone.ZoneLimit := R.Right - R.Left;\r\n if R.Bottom - R.Top > 0 then\r\n TopXYLimit := R.Bottom - R.Top;\r\n end;\r\n doVertical:\r\n begin\r\n if R.Bottom - R.Top > 0 then\r\n TopZone.ZoneLimit := R.Bottom - R.Top;\r\n if R.Right - R.Left > 0 then\r\n TopXYLimit := R.Right - R.Left;\r\n end;\r\n end;\r\n if DockSite.DockClientCount > 0 then\r\n begin\r\n if not JvGlobalDockIsLoading then\r\n begin\r\n if (R.Bottom - R.Top > 0) and (PreviousRect.Bottom - PreviousRect.Top > 0) then\r\n ScaleBy := (R.Bottom - R.Top) / (PreviousRect.Bottom - PreviousRect.Top)\r\n else\r\n ScaleBy := 1;\r\n\r\n ShiftScaleOrientation := doHorizontal;\r\n\r\n if (UpdateCount = 0) and (ScaleBy <> 1) then\r\n ForEachAt(nil, ScaleZone, tskForward);\r\n\r\n if (R.Right - R.Left > 0) and (PreviousRect.Right - PreviousRect.Left > 0) then\r\n ScaleBy := (R.Right - R.Left) / (PreviousRect.Right - PreviousRect.Left)\r\n else\r\n ScaleBy := 1;\r\n\r\n ShiftScaleOrientation := doVertical;\r\n\r\n if (UpdateCount = 0) and (ScaleBy <> 1) then\r\n ForEachAt(nil, ScaleZone, tskForward);\r\n end;\r\n\r\n SetNewBounds(nil);\r\n if UpdateCount = 0 then\r\n ForEachAt(nil, UpdateZone, tskForward);\r\n\r\n PreviousRect := R;\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockVIDTree.DrawSplitterRect(const ARect: TRect);\r\nbegin\r\n inherited DrawSplitterRect(ARect);\r\nend;\r\n\r\nprocedure TJvDockVIDTree.WindowProc(var Msg: TMessage);\r\nvar\r\n Align: TAlign;\r\nbegin\r\n if Msg.Msg = CM_DOCKNOTIFICATION then\r\n begin\r\n with TCMDockNotification(Msg) do\r\n begin\r\n if NotifyRec.ClientMsg = CM_INVALIDATEDOCKHOST then\r\n InvalidateDockSite(TControl(NotifyRec.MsgWParam))\r\n else\r\n inherited;\r\n end;\r\n end\r\n else\r\n if Msg.Msg = CM_DOCKCLIENT then\r\n begin\r\n { (rb) no idea what gi_DockRect should be doing, but prevent it is used\r\n before it is set (by checking whether it is empty). Using it when the rect\r\n is empty causes align problems }\r\n if not IsRectEmpty(gi_DockRect) then\r\n begin\r\n Align := TCMDockClient(Msg).DockSource.DropAlign;\r\n TCMDockClient(Msg).DockSource.DockRect := gi_DockRect;\r\n GetDockEdge(gi_DockRect, TCMDockClient(Msg).DockSource.DragPos, Align, TCMDockClient(Msg).DockSource.Control);\r\n end;\r\n end;\r\n inherited WindowProc(Msg);\r\nend;\r\n\r\nprocedure TJvDockVIDTree.SplitterMouseUp;\r\nvar\r\n OldLimit: Integer;\r\n Zone: TJvDockZone;\r\nbegin\r\n Mouse.Capture := 0;\r\n DrawSizeSplitter;\r\n ReleaseDC(SizingWnd, SizingDC);\r\n\r\n OldLimit := SizingZone.ZoneLimit;\r\n\r\n ShiftScaleOrientation := SizingZone.ParentZone.Orientation;\r\n if SizingZone.ParentZone.Orientation = doHorizontal then\r\n SizingZone.ZoneLimit := SizePos.Y + (SplitterWidth div 2)\r\n else\r\n SizingZone.ZoneLimit := SizePos.X + (SplitterWidth div 2);\r\n\r\n ParentLimit := SizingZone.LimitBegin;\r\n if OldLimit - ParentLimit > 0 then\r\n ScaleBy := (SizingZone.ZoneLimit - ParentLimit) / (OldLimit - ParentLimit)\r\n else\r\n ScaleBy := 1;\r\n\r\n if SizingZone.ChildZones <> nil then\r\n ForEachAt(SizingZone.ChildZones, ScaleChildZone, tskForward);\r\n\r\n Zone := SizingZone;\r\n while (Zone.NextSibling <> nil) and (not Zone.NextSibling.Visibled) do\r\n begin\r\n Zone.NextSibling.ZoneLimit := SizingZone.ZoneLimit;\r\n Zone := Zone.NextSibling;\r\n end;\r\n\r\n if SizingZone.NextSibling <> nil then\r\n begin\r\n if SizingZone.NextSibling.ZoneLimit - OldLimit > 0 then\r\n ScaleBy := (SizingZone.NextSibling.ZoneLimit - SizingZone.ZoneLimit) / (SizingZone.NextSibling.ZoneLimit -\r\n OldLimit)\r\n else\r\n ScaleBy := 1;\r\n ParentLimit := SizingZone.NextSibling.ZoneLimit;\r\n\r\n if SizingZone.NextSibling.ChildZones <> nil then\r\n ForEachAt(SizingZone.NextSibling.ChildZones, ScaleSiblingZone, tskForward);\r\n end;\r\n\r\n SetNewBounds(SizingZone.ParentZone);\r\n ForEachAt(SizingZone.ParentZone, UpdateZone, tskForward);\r\n SizingZone := nil;\r\nend;\r\n\r\nprocedure TJvDockVIDTree.DrawDockSiteRect;\r\nbegin\r\nend;\r\n\r\nprocedure TJvDockVIDTree.InsertSibling(NewZone, SiblingZone: TJvDockZone;\r\n InsertLast, Update: Boolean);\r\nbegin\r\n if FDropOnZone <> nil then\r\n SiblingZone := FDropOnZone;\r\n inherited InsertSibling(NewZone, SiblingZone, InsertLast, Update);\r\nend;\r\n\r\nprocedure TJvDockVIDTree.PositionDockRect(Client, DropCtl: TControl;\r\n DropAlign: TAlign; var DockRect: TRect);\r\nlabel\r\n LBDropCtlExist;\r\nvar\r\n VisibleClients, NewX, NewY, NewWidth, NewHeight: Integer;\r\n Zone: TJvDockZone;\r\n HTFlag: Integer;\r\n MousePos: TPoint;\r\n Scale: Double;\r\n CtrlRect: TRect;\r\n\r\n procedure DockOverSplitter;\r\n begin\r\n NewX := Zone.ParentZone.Left;\r\n NewY := Zone.ParentZone.Top;\r\n NewWidth := Zone.ParentZone.Width;\r\n NewHeight := Zone.ParentZone.Height;\r\n case Zone.ParentZone.Orientation of\r\n doHorizontal:\r\n begin\r\n Scale := (Zone.ZoneLimit - Zone.ParentZone.ChildZones.LimitBegin) / NewHeight;\r\n NewHeight := Min(NewHeight div 2, Client.ClientHeight);\r\n NewY := Zone.ZoneLimit - Round(NewHeight * Scale);\r\n end;\r\n doVertical:\r\n begin\r\n Scale := (Zone.ZoneLimit - Zone.ParentZone.ChildZones.LimitBegin) / NewWidth;\r\n NewWidth := Min(NewWidth div 2, Client.ClientWidth);\r\n NewX := Zone.ZoneLimit - Round(NewWidth * Scale);\r\n end;\r\n end;\r\n DockRect := Bounds(NewX, NewY, NewWidth, NewHeight);\r\n if Zone.Visibled then\r\n begin\r\n if Zone.ParentZone.Orientation = doHorizontal then\r\n JvGlobalDockManager.DragObject.DropAlign := alBottom\r\n else\r\n if Zone.ParentZone.Orientation = doVertical then\r\n JvGlobalDockManager.DragObject.DropAlign := alRight;\r\n JvGlobalDockManager.DragObject.DropOnControl := Zone.ChildControl;\r\n FDropOnZone := Zone;\r\n end;\r\n end;\r\n\r\nbegin\r\n if DropAlign = alNone then\r\n DropAlign := alClient;\r\n VisibleClients := DockSite.VisibleDockClientCount;\r\n FDropOnZone := nil;\r\n\r\n if JvGlobalDockManager.DragObject <> nil then\r\n MousePos := JvGlobalDockManager.DragObject.DragPos\r\n else\r\n MousePos := Client.ScreenToClient(Mouse.CursorPos);\r\n\r\n MapWindowPoints(0, DockSite.Handle, MousePos, 2);\r\n Zone := InternalHitTest(MousePos, HTFlag);\r\n if Zone <> nil then\r\n if Zone.ChildControl <> nil then\r\n if (HTFlag = HTCAPTION) or (HTFlag = HTCLOSE) then\r\n begin\r\n DockRect := Zone.ChildControl.BoundsRect;\r\n JvGlobalDockManager.DragObject.DropAlign := alClient;\r\n if Zone.ChildControl is TJvDockTabHostForm then\r\n begin\r\n if JvGlobalDockManager.DragObject is TJvDockVIDDragDockObject then\r\n TJvDockVIDDragDockObject(JvGlobalDockManager.DragObject).FDropTabControl :=\r\n TJvDockVIDTabPageControl(TJvDockTabHostForm(Zone.ChildControl).PageControl);\r\n end\r\n else\r\n begin\r\n if JvGlobalDockManager.DragObject is TJvDockVIDDragDockObject then\r\n TJvDockVIDDragDockObject(JvGlobalDockManager.DragObject).FDropTabControl := nil;\r\n end;\r\n end;\r\n\r\n if DropCtl = nil then\r\n begin\r\n if Zone <> nil then\r\n begin\r\n if Zone.ChildControl <> nil then\r\n begin\r\n if (HTFlag = HTCAPTION) or (HTFlag = HTCLOSE) then\r\n JvGlobalDockManager.DragObject.DropOnControl := Zone.ChildControl\r\n else\r\n if HTFlag = HTCLIENT then\r\n begin\r\n DropCtl := Zone.ChildControl;\r\n goto LBDropCtlExist;\r\n end\r\n else\r\n if HTFlag = HTSPLITTER then\r\n DockOverSplitter;\r\n end\r\n else\r\n if HTFlag = HTSPLITTER then\r\n begin\r\n DockOverSplitter;\r\n end\r\n else\r\n Exit;\r\n end\r\n else\r\n begin\r\n DockRect := Rect(0, 0, DockSite.ClientWidth, DockSite.ClientHeight);\r\n\r\n if VisibleClients > 0 then\r\n case DropAlign of\r\n alLeft:\r\n DockRect.Right := DockRect.Right div 2;\r\n alRight:\r\n DockRect.Left := DockRect.Right div 2;\r\n alTop:\r\n DockRect.Bottom := DockRect.Bottom div 2;\r\n alBottom:\r\n DockRect.Top := DockRect.Bottom div 2;\r\n end;\r\n end;\r\n end\r\n else\r\n begin\r\n\r\n LBDropCtlExist:\r\n Zone := FindControlZone(DropCtl);\r\n CtrlRect := DockRect;\r\n MapWindowPoints(0, DockSite.Handle, CtrlRect, 2);\r\n if Zone <> nil then\r\n begin\r\n if Zone.ParentZone.Orientation = doVertical then\r\n begin\r\n if (DropAlign = alRight) and (Zone.NextSibling <> nil) then\r\n begin\r\n DockOverSplitter;\r\n MapWindowPoints(DockSite.Handle, 0, DockRect, 2);\r\n Exit;\r\n end\r\n else\r\n if (DropAlign = alLeft) and (Zone.PrevSibling <> nil) then\r\n begin\r\n Zone := Zone.PrevSibling;\r\n DockOverSplitter;\r\n MapWindowPoints(DockSite.Handle, 0, DockRect, 2);\r\n Exit;\r\n end\r\n else\r\n begin\r\n if DropAlign in [alLeft, alRight] then\r\n CtrlRect := Bounds(Zone.ParentZone.Left, Zone.ParentZone.Top, Zone.ParentZone.Width, Zone.ParentZone.Height)\r\n else\r\n if DropAlign in [alTop, alBottom, alClient] then\r\n begin\r\n CtrlRect := DropCtl.BoundsRect;\r\n Dec(CtrlRect.Top, GrabberSize);\r\n end;\r\n OffsetRect(CtrlRect, 0, GrabberSize);\r\n end;\r\n end\r\n else\r\n if Zone.ParentZone.Orientation = doHorizontal then\r\n begin\r\n if (DropAlign = alBottom) and (Zone.NextSibling <> nil) then\r\n begin\r\n DockOverSplitter;\r\n MapWindowPoints(DockSite.Handle, 0, DockRect, 2);\r\n Exit;\r\n end\r\n else\r\n if (DropAlign = alTop) and (Zone.PrevSibling <> nil) then\r\n begin\r\n Zone := Zone.PrevSibling;\r\n DockOverSplitter;\r\n MapWindowPoints(DockSite.Handle, 0, DockRect, 2);\r\n Exit;\r\n end\r\n else\r\n begin\r\n if DropAlign in [alTop, alBottom] then\r\n CtrlRect := Bounds(Zone.ParentZone.Left, Zone.ParentZone.Top, Zone.ParentZone.Width, Zone.ParentZone.Height)\r\n else\r\n if DropAlign in [alLeft, alRight, alClient] then\r\n begin\r\n CtrlRect := DropCtl.BoundsRect;\r\n Dec(CtrlRect.Top, GrabberSize);\r\n end;\r\n OffsetRect(CtrlRect, 0, GrabberSize);\r\n end;\r\n end\r\n else\r\n begin\r\n CtrlRect := DropCtl.BoundsRect;\r\n Dec(CtrlRect.Top, GrabberSize);\r\n OffsetRect(CtrlRect, 0, GrabberSize);\r\n end;\r\n\r\n NewX := CtrlRect.Left;\r\n NewY := CtrlRect.Top - GrabberSize;\r\n NewWidth := CtrlRect.Right - CtrlRect.Left;\r\n NewHeight := CtrlRect.Bottom - CtrlRect.Top;\r\n if DropAlign in [alLeft, alRight] then\r\n NewWidth := Min(Client.UndockWidth, NewWidth div 2)\r\n else\r\n if DropAlign in [alTop, alBottom] then\r\n NewHeight := Min(Client.UndockHeight, NewHeight div 2);\r\n case DropAlign of\r\n alRight:\r\n Inc(NewX, CtrlRect.Right - CtrlRect.Left - NewWidth);\r\n alBottom:\r\n Inc(NewY, CtrlRect.Bottom - CtrlRect.Top - NewHeight);\r\n end;\r\n DockRect := Bounds(NewX, NewY, NewWidth, NewHeight);\r\n if DropAlign = alClient then\r\n DockRect := Bounds(NewX, NewY, NewWidth, NewHeight);\r\n if DropAlign = alNone then\r\n begin\r\n end;\r\n end;\r\n end;\r\n MapWindowPoints(DockSite.Handle, 0, DockRect, 2);\r\nend;\r\n\r\nfunction TJvDockVIDTree.GetDockEdge(DockRect: TRect; MousePos: TPoint;\r\n var DropAlign: TAlign; Control: TControl): TControl;\r\nbegin\r\n Result := inherited GetDockEdge(DockRect, MousePos, DropAlign, Control);\r\n if FLockDropDockSizeCount = 0 then\r\n begin\r\n if DropAlign in [alLeft, alRight] then\r\n DropDockSize := DockRect.Right - DockRect.Left\r\n else\r\n if DropAlign in [alTop, alBottom] then\r\n DropDockSize := DockRect.Bottom - DockRect.Top\r\n else\r\n DropDockSize := 0;\r\n Self.DockRect := DockRect;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockVIDTree.InsertNewParent(NewZone, SiblingZone: TJvDockZone;\r\n ParentOrientation: TDockOrientation; InsertLast, Update: Boolean);\r\nbegin\r\n if FDropOnZone <> nil then\r\n begin\r\n SiblingZone := FDropOnZone;\r\n InsertSibling(NewZone, SiblingZone, InsertLast, Update);\r\n end\r\n else\r\n inherited InsertNewParent(NewZone, SiblingZone, ParentOrientation,\r\n InsertLast, Update);\r\nend;\r\n\r\nprocedure TJvDockVIDTree.RemoveZone(Zone: TJvDockZone; Hide: Boolean);\r\nbegin\r\n if (FDropOnZone <> nil) and\r\n ((FDropOnZone.NextSibling = Zone) or (FDropOnZone = Zone)) then\r\n FDropOnZone := nil;\r\n inherited RemoveZone(Zone, Hide);\r\nend;\r\n\r\nprocedure TJvDockVIDTree.GetSiteInfo(Client: TControl;\r\n var InfluenceRect: TRect; MousePos: TPoint; var CanDock: Boolean);\r\nvar\r\n Zone: TJvDockZone;\r\n HTFlag: Integer;\r\n Pos: TPoint;\r\n Align: TAlign;\r\nbegin\r\n Pos := DockSite.ScreenToClient(MousePos);\r\n Zone := InternalHitTest(Pos, HTFlag);\r\n if Zone <> nil then\r\n begin\r\n if HTFlag = HTSPLITTER then\r\n begin\r\n InfluenceRect := GetSplitterRect(Zone);\r\n MapWindowPoints(DockSite.Handle, 0, InfluenceRect, 2);\r\n end\r\n else\r\n begin\r\n Pos := MousePos;\r\n if Zone.ChildControl <> nil then\r\n Pos := Zone.ChildControl.ScreenToClient(MousePos);\r\n Align := ComputeVIDDockingRect(Zone.ChildControl, Client, InfluenceRect, Pos);\r\n if (Align = alNone) or (Client = Zone.ChildControl) then\r\n begin\r\n InfluenceRect := Rect(0, 0, 0, 0);\r\n CanDock := False;\r\n end\r\n else\r\n begin\r\n if Zone.ParentZone.Orientation = doVertical then\r\n begin\r\n if (Align = alRight) and (Zone.NextSibling <> nil) and (Zone.NextSibling.Visibled) then\r\n begin\r\n InfluenceRect := GetSplitterRect(Zone);\r\n InflateRect(InfluenceRect, DefExpandoRect, 0);\r\n end\r\n else\r\n if (Align = alLeft) and (Zone.PrevSibling <> nil) and (Zone.PrevSibling.Visibled) then\r\n begin\r\n InfluenceRect := GetSplitterRect(Zone.PrevSibling);\r\n InflateRect(InfluenceRect, DefExpandoRect, 0);\r\n end\r\n else\r\n Exit;\r\n end\r\n else\r\n if Zone.ParentZone.Orientation = doHorizontal then\r\n begin\r\n if (Align = alBottom) and (Zone.NextSibling <> nil) and (Zone.NextSibling.Visibled) then\r\n begin\r\n InfluenceRect := GetSplitterRect(Zone);\r\n InflateRect(InfluenceRect, 0, DefExpandoRect);\r\n end\r\n else\r\n if (Align = alTop) and (Zone.PrevSibling <> nil) and (Zone.PrevSibling.Visibled) then\r\n begin\r\n InfluenceRect := GetSplitterRect(Zone.PrevSibling);\r\n InflateRect(InfluenceRect, 0, DefExpandoRect);\r\n end\r\n else\r\n Exit;\r\n end\r\n else\r\n Exit;\r\n end;\r\n MapWindowPoints(DockSite.Handle, 0, InfluenceRect, 2);\r\n end;\r\n end\r\n else\r\n begin\r\n InfluenceRect := Rect(0, 0, 0, 0);\r\n CanDock := False;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockVIDTree.LockDropDockSize;\r\nbegin\r\n Inc(FLockDropDockSizeCount);\r\nend;\r\n\r\nprocedure TJvDockVIDTree.UnlockDropDockSize;\r\nbegin\r\n Dec(FLockDropDockSizeCount);\r\n if FLockDropDockSizeCount < 0 then\r\n FLockDropDockSizeCount := 0;\r\nend;\r\n\r\nprocedure TJvDockVIDTree.PaintDockGrabberRect(Canvas: TCanvas;\r\n Control: TWinControl; const ARect: TRect; PaintAlways: Boolean = False);\r\nbegin\r\nend;\r\n\r\nprocedure TJvDockVIDTree.SetCaptionLeftOffset(const Value: Integer);\r\nbegin\r\n FCaptionLeftOffset := Value;\r\nend;\r\n\r\nprocedure TJvDockVIDTree.SetCaptionRightOffset(const Value: Integer);\r\nbegin\r\n FCaptionRightOffset := Value;\r\nend;\r\n\r\nprocedure TJvDockVIDTree.DrawCloseButton(Canvas: TCanvas; Zone: TJvDockZone; Left, Top: Integer);\r\nvar\r\n AZone: TJvDockAdvZone;\r\n ADockClient: TJvDockClient;\r\n {$IFDEF JVCLThemesEnabled}\r\n Details: TThemedElementDetails;\r\n CurrentThemeType: TThemedWindow;\r\n {$ENDIF JVCLThemesEnabled}\r\nbegin\r\n AZone := TJvDockAdvZone(Zone);\r\n if AZone <> nil then\r\n begin\r\n ADockClient := FindDockClient(Zone.ChildControl);\r\n if (ADockClient <> nil) and not ADockClient.EnableCloseButton then\r\n Exit;\r\n {$IFDEF JVCLThemesEnabled}\r\n if ThemeServices.{$IFDEF RTL230_UP}Available{$ELSE}ThemesAvailable{$ENDIF RTL230_UP} and ThemeServices.{$IFDEF RTL230_UP}Enabled{$ELSE}ThemesEnabled{$ENDIF RTL230_UP} then\r\n begin\r\n if GrabberSize <= 18 then\r\n begin\r\n CurrentThemeType := twSmallCloseButtonNormal;\r\n if AZone.CloseBtnDown then\r\n CurrentThemeType := twSmallCloseButtonPushed;\r\n end\r\n else\r\n begin\r\n CurrentThemeType := twCloseButtonNormal;\r\n if AZone.CloseBtnDown then\r\n CurrentThemeType := twCloseButtonPushed;\r\n end;\r\n Details := ThemeServices.GetElementDetails(CurrentThemeType);\r\n ThemeServices.DrawElement(Canvas.Handle, Details, Rect(Left, Top, Left + ButtonWidth, Top + ButtonHeight));\r\n end\r\n else\r\n {$ENDIF JVCLThemesEnabled}\r\n DrawFrameControl(Canvas.Handle, Rect(Left, Top, Left + ButtonWidth,\r\n Top + ButtonHeight), DFC_CAPTION, DFCS_CAPTIONCLOSE or Integer(AZone.CloseBtnDown) * DFCS_PUSHED)\r\n end;\r\nend;\r\n\r\nprocedure TJvDockVIDTree.GetCaptionRect(var Rect: TRect);\r\nbegin\r\n Inc(Rect.Left, 2 + CaptionLeftOffset);\r\n Inc(Rect.Top, 1);\r\n Dec(Rect.Right, ButtonWidth + CaptionRightOffset - 1);\r\n Dec(Rect.Bottom, 2);\r\nend;\r\n\r\n{ Adjust docking area rectangle to compensante for Grabber control }\r\nprocedure TJvDockVIDTree.AdjustDockRect(Control: TControl; var ARect: TRect);\r\nbegin\r\n if AlwaysShowGrabber or (DockSite.Align <> alClient) or (TopZone.VisibleChildTotal > 1) then\r\n inherited AdjustDockRect(Control, ARect);\r\nend;\r\n\r\nprocedure TJvDockVIDTree.IgnoreZoneInfor(Stream: TMemoryStream);\r\nvar\r\n CompName: string;\r\nbegin\r\n Stream.Position := Stream.Position + 6;\r\n ReadControlName(Stream, CompName);\r\nend;\r\n\r\nprocedure TJvDockVIDTree.SyncWithStyle;\r\nbegin\r\n inherited SyncWithStyle;\r\n\r\n if DockStyle is TJvDockVIDStyle then\r\n AlwaysShowGrabber := TJvDockVIDStyle(DockStyle).AlwaysShowGrabber;\r\n\r\n if DockStyle.TabServerOption is TJvDockVIDTabServerOption then\r\n begin\r\n ShowCloseButtonOnGrabber := TJvDockVIDTabServerOption(DockStyle.TabServerOption).ShowCloseButtonOnGrabber;\r\n end;\r\n\r\n { Not all properties are copied (See TJvDockVIDTree.DrawDockGrabber) so we\r\n must invalidate the DockSite so it gets repainted. }\r\n DockSite.Invalidate;\r\nend;\r\n\r\nprocedure TJvDockVIDTree.SetShowCloseButtonOnGrabber(const Value: Boolean);\r\nbegin\r\n if Value <> FShowCloseButtonOnGrabber then\r\n begin\r\n FShowCloseButtonOnGrabber := Value;\r\n UpdateAll;\r\n DockSite.Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockVIDTree.SetAlwaysShowGrabber(const Value: Boolean);\r\nbegin\r\n if Value <> FAlwaysShowGrabber then\r\n begin\r\n FAlwaysShowGrabber := Value;\r\n UpdateAll;\r\n DockSite.Invalidate;\r\n end;\r\nend;\r\n\r\n//=== { TJvDockVIDConjoinPanel } =============================================\r\n\r\nprocedure TJvDockVIDConjoinPanel.CustomDockDrop(Source: TJvDockDragDockObject;\r\n X, Y: Integer);\r\nbegin\r\n if not ((Source.Control.HostDockSite <> nil) and\r\n (Source.DropOnControl = Source.Control.HostDockSite.Parent) and\r\n (Source.DropAlign = alClient)) then\r\n begin\r\n inherited CustomDockDrop(Source, X, Y);\r\n ParentForm.Caption := '';\r\n {$IFNDEF COMPILER9_UP}\r\n InvalidateDockHostSiteOfControl(Source.Control, False);\r\n {$ENDIF !COMPILER9_UP}\r\n if (Source.Control is TWinControl) and Source.Control.Visible and\r\n TWinControl(Source.Control).CanFocus then\r\n TWinControl(Source.Control).SetFocus;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockVIDConjoinPanel.CustomDockOver(Source: TJvDockDragDockObject; X,\r\n Y: Integer; State: TDragState; var Accept: Boolean);\r\nvar\r\n DropAlign: TAlign;\r\nbegin\r\n inherited CustomDockOver(Source, X, Y, State, Accept);\r\n if Accept and (Source is TJvDockVIDDragDockObject) then\r\n if State = dsDragMove then\r\n begin\r\n DropAlign := Source.DropAlign;\r\n JvDockManager.GetDockEdge(Source.EraseDockRect, Source.DragPos, DropAlign, Source.Control);\r\n end;\r\nend;\r\n\r\nprocedure TJvDockVIDConjoinPanel.CustomGetDockEdge(Source: TJvDockDragDockObject;\r\n MousePos: TPoint; var DropAlign: TAlign);\r\nbegin\r\nend;\r\n\r\nprocedure TJvDockVIDConjoinPanel.CustomGetSiteInfo(Source: TJvDockDragDockObject; Client: TControl;\r\n var InfluenceRect: TRect; MousePos: TPoint; var CanDock: Boolean);\r\nbegin\r\n JvDockManager.GetSiteInfo(Client, InfluenceRect, MousePos, CanDock);\r\n CanDock := IsDockable(Self, Client, Source.DropOnControl, Source.DropAlign);\r\nend;\r\n\r\nfunction TJvDockVIDConjoinPanel.CustomUnDock(Source: TJvDockDragDockObject; NewTarget: TWinControl;\r\n Client: TControl): Boolean;\r\nbegin\r\n Result := inherited CustomUnDock(Source, NewTarget, Client);\r\nend;\r\n\r\nprocedure TJvDockVIDConjoinPanel.DockDrop(Source: TDragDockObject;\r\n X, Y: Integer);\r\nbegin\r\n inherited DockDrop(Source, X, Y);\r\nend;\r\n\r\nprocedure TJvDockVIDConjoinPanel.UpdateCaption(Exclude: TControl);\r\nbegin\r\n if VisibleDockClientCount > 1 then\r\n ParentForm.Caption := ''\r\n else\r\n inherited UpdateCaption(Exclude);\r\n Invalidate;\r\nend;\r\n\r\n// TJvDockVIDTabPageControl ==================================================\r\nfunction TJvDockVIDTabPageControl.DoUnDock(NewTarget: TWinControl; Client: TControl): Boolean;\r\nbegin\r\n Result := inherited DoUnDock(NewTarget, Client);\r\n if Assigned(ParentForm) then\r\n ParentForm.Caption := ActivePage.Caption;\r\nend;\r\n\r\nconstructor TJvDockVIDTabPageControl.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FPanel := nil;\r\n TabWidth := 1;\r\n MultiLine := True;\r\n TabSheetClass := TJvDockVIDTabSheet;\r\n TabPanelClass := TJvDockTabPanel;\r\n FTempSheet := nil;\r\n TabPosition := tpTop; // Warren changed! was tpBottom;\r\n FTabImageList := nil;\r\n Images := nil;\r\n\r\n if AOwner is TJvDockTabHostForm then\r\n begin\r\n FTabImageList := TCustomImageList.Create(AOwner);\r\n {$IFDEF RTL200_UP}\r\n FTabImageList.ColorDepth := cd32Bit;\r\n {$ENDIF RTL200_UP}\r\n Images := FTabImageList;\r\n end;\r\nend;\r\n\r\ndestructor TJvDockVIDTabPageControl.Destroy;\r\nbegin\r\n if FTabImageList <> nil then\r\n begin\r\n FTabImageList.Free;\r\n FTabImageList := nil;\r\n end;\r\n if FPanel <> nil then\r\n begin\r\n FPanel.Free;\r\n FPanel := nil;\r\n end;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvDockVIDTabPageControl.AfterConstruction;\r\nbegin\r\n // we must create the panel before the inherited call, because\r\n // TJvDockTabPageControl.AfterConstruction calls SyncWithStyle which needs\r\n // a panel.\r\n CreatePanel;\r\n inherited AfterConstruction;\r\nend;\r\n\r\nprocedure TJvDockVIDTabPageControl.Loaded;\r\nbegin\r\n inherited Loaded;\r\n CreatePanel;\r\nend;\r\n\r\nprocedure TJvDockVIDTabPageControl.CreatePanel;\r\nbegin\r\n if FPanel = nil then\r\n begin\r\n FPanel := TabPanelClass.Create(Self);\r\n FPanel.Page := Self;\r\n FPanel.Parent := Self;\r\n FPanel.TabLeftOffset := 5;\r\n FPanel.TabRightOffset := 5;\r\n FPanel.TabTopOffset := 3;\r\n FPanel.TabBottomOffset := 3;\r\n ActiveSheetColor := clBtnFace;\r\n InactiveSheetColor := clBtnShadow;\r\n end;\r\n Resize;\r\nend;\r\n\r\nprocedure TJvDockVIDTabPageControl.CreateWnd;\r\nbegin\r\n inherited CreateWnd;\r\nend;\r\n\r\nprocedure TJvDockVIDTabPageControl.CMDockNotification(\r\n var Msg: TCMDockNotification);\r\nbegin\r\n if Msg.Msg = CM_DOCKNOTIFICATION then\r\n begin\r\n with TCMDockNotification(Msg) do\r\n begin\r\n if NotifyRec.ClientMsg = CM_INVALIDATEDOCKHOST then\r\n {$IFDEF COMPILER9_UP}\r\n Self.InvalidateDockHostSite(Boolean(NotifyRec.MsgLParam))\r\n {$ELSE}\r\n InvalidateDockHostSiteOfControl(Self, Boolean(NotifyRec.MsgLParam))\r\n {$ENDIF COMPILER9_UP}\r\n else\r\n inherited;\r\n end;\r\n end\r\n else\r\n inherited;\r\nend;\r\n\r\nprocedure TJvDockVIDTabPageControl.CustomDockDrop(Source: TJvDockDragDockObject;\r\n X, Y: Integer);\r\nvar\r\n ARect: TRect;\r\n I: Integer;\r\n VIDSource: TJvDockVIDDragDockObject;\r\n DockClient: TJvDockClient;\r\n Host: TJvDockConjoinHostForm;\r\n Index: Integer;\r\nbegin\r\n if Source.DropAlign in [alClient, alNone] then\r\n begin\r\n if Source is TJvDockVIDDragDockObject then\r\n begin\r\n BeginDockLoading;\r\n try\r\n DoFloatForm(Source.Control);\r\n FreeAllDockableForm;\r\n VIDSource := TJvDockVIDDragDockObject(Source);\r\n\r\n for I := 0 to VIDSource.SourceDockClientCount - 1 do\r\n begin\r\n Source.Control := VIDSource.SourceDockClients[I];\r\n inherited CustomDockDrop(Source, X, Y);\r\n if Source.Control is TCustomForm then\r\n if FTabImageList <> nil then\r\n begin\r\n Index := FTabImageList.AddIcon(TForm(Source.Control).Icon);\r\n if Index <> -1 then\r\n ActivePage.ImageIndex := Index;\r\n end;\r\n end;\r\n finally\r\n EndDockLoading;\r\n JvGlobalDockManager.DragObject.Control := nil;\r\n end;\r\n end;\r\n end\r\n else\r\n begin\r\n DockClient := FindDockClient(ParentForm);\r\n if DockClient <> nil then\r\n begin\r\n ARect := ParentForm.BoundsRect;\r\n Host := DockClient.CreateConjoinHostAndDockControl(ParentForm, Source.Control, Source.DropAlign);\r\n Host.BoundsRect := ARect;\r\n SetDockSite(ParentForm, False);\r\n SetDockSite(TWinControl(Source.Control), False);\r\n Host.Visible := True;\r\n end;\r\n end;\r\n FPanel.SelectSheet := nil;\r\n with ActivePage do\r\n if not JvGlobalDockIsLoading and (ControlCount > 0) and Assigned(Controls[0]) then \r\n begin\r\n if Visible and (Controls[0] <> nil) and (Controls[0] as TWinControl).CanFocus then\r\n (Controls[0] as TWinControl).SetFocus;\r\n end;\r\n ParentForm.Caption := ActivePage.Caption;\r\nend;\r\n\r\nprocedure TJvDockVIDTabPageControl.CustomDockOver(Source: TJvDockDragDockObject;\r\n X, Y: Integer; State: TDragState; var Accept: Boolean);\r\nvar\r\n ARect: TRect;\r\nbegin\r\n Accept := IsDockable(Self, Source.Control, Source.DropOnControl, Source.DropAlign);\r\n if Accept then\r\n begin\r\n if ParentForm.HostDockSite = nil then\r\n begin\r\n Source.DropAlign := ComputeVIDDockingRect(Self, Source.Control, ARect, Point(X, Y));\r\n if Source.DropAlign = alClient then\r\n ARect.Top := ARect.Top + JvDockGetSysCaptionHeight;\r\n\r\n if Accept and (Source.DropAlign <> alNone) then\r\n begin\r\n Source.DockRect := ARect;\r\n gi_DockRect := ARect;\r\n end;\r\n end\r\n else\r\n begin\r\n if ParentForm.HostDockSite is TJvDockCustomPanel then\r\n begin\r\n ARect := Source.DockRect;\r\n TJvDockCustomPanel(ParentForm.HostDockSite).JvDockManager.PositionDockRect(Source.Control, Source.DropOnControl,\r\n Source.DropAlign, ARect);\r\n Source.DockRect := ARect;\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockVIDTabPageControl.CustomGetSiteInfo(Source: TJvDockDragDockObject; Client: TControl;\r\n var InfluenceRect: TRect; MousePos: TPoint; var CanDock: Boolean);\r\nconst\r\n DefExpandoRect = 20;\r\nvar\r\n CH_BW: Integer;\r\n ARect: TRect;\r\nbegin\r\n CanDock := IsDockable(Self, Client, Source.DropOnControl, Source.DropAlign);\r\n if ParentForm.HostDockSite <> nil then\r\n CanDock := False;\r\n if CanDock then\r\n begin\r\n GetWindowRect(Parent.Handle, InfluenceRect);\r\n if PtInRect(InfluenceRect, MousePos) then\r\n begin\r\n ARect := InfluenceRect;\r\n InflateRect(ARect, -DefExpandoRect, -DefExpandoRect);\r\n\r\n CH_BW := JvDockGetSysCaptionHeightAndBorderWidth;\r\n Inc(ARect.Top, CH_BW + 1);\r\n Dec(ARect.Bottom, TabHeight);\r\n if PtInRect(ARect, MousePos) then\r\n InfluenceRect := Rect(0, 0, 0, 0);\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockVIDTabPageControl.DoRemoveDockClient(Client: TControl);\r\nbegin\r\n inherited DoRemoveDockClient(Client);\r\n if Assigned(ParentForm) then\r\n ParentForm.Caption := ActivePage.Caption; {bugfix FEB 14, 2005 - WPostma.}\r\nend;\r\n\r\nprocedure TJvDockVIDTabPageControl.Change;\r\nbegin\r\n Assert(Assigned(ParentForm));\r\n inherited Change;\r\n\r\n { During closing/undocking of a form,\r\n ActivePage is actually going to be wrong.\r\n See above in DoRemoveDockClient for where we fix\r\n this problem. }\r\n ParentForm.Caption := ActivePage.Caption;\r\n\r\n if ParentForm.HostDockSite is TJvDockCustomPanel then\r\n begin\r\n // if ParentForm.Visible and ParentForm.CanFocus then\r\n // ParentForm.SetFocus;\r\n ParentForm.HostDockSite.Invalidate;\r\n end;\r\n // if (ActivePage <> nil) and (ActivePage.Visible) and (ActivePage.CanFocus) then\r\n // if ParentForm.Visible and ParentForm.CanFocus then\r\n // ActivePage.SetFocus;\r\nend;\r\n\r\nprocedure TJvDockVIDTabPageControl.AdjustClientRect(var Rect: TRect);\r\nbegin\r\n Rect := ClientRect;\r\n if (Parent is TJvDockTabHostForm) and (VisibleDockClientCount = 1) then\r\n Exit;\r\n case TabPosition of\r\n tpTop:\r\n Inc(Rect.Top, Panel.FTabHeight - 1);\r\n tpBottom:\r\n Dec(Rect.Bottom, Panel.FTabHeight - 1);\r\n tpLeft:\r\n Inc(Rect.Left, Panel.FTabHeight - 1);\r\n tpRight:\r\n Dec(Rect.Right, Panel.FTabHeight - 1);\r\n end;\r\nend;\r\n\r\nprocedure TJvDockVIDTabPageControl.CreateParams(var Params: TCreateParams);\r\nbegin\r\n inherited CreateParams(Params);\r\nend;\r\n\r\nprocedure TJvDockVIDTabPageControl.DrawTab(TabIndex: Integer;\r\n const Rect: TRect; Active: Boolean);\r\nbegin\r\n inherited DrawTab(TabIndex, Rect, Active);\r\nend;\r\n\r\nfunction TJvDockVIDTabPageControl.GetActiveFont: TFont;\r\nbegin\r\n Result := FPanel.FActiveFont;\r\nend;\r\n\r\nfunction TJvDockVIDTabPageControl.GetActiveSheetColor: TColor;\r\nbegin\r\n Result := FPanel.FActiveSheetColor;\r\nend;\r\n\r\nfunction TJvDockVIDTabPageControl.GetInactiveFont: TFont;\r\nbegin\r\n Result := FPanel.FInactiveFont;\r\nend;\r\n\r\nfunction TJvDockVIDTabPageControl.GetInactiveSheetColor: TColor;\r\nbegin\r\n Result := FPanel.Color;\r\nend;\r\n\r\nfunction TJvDockVIDTabPageControl.GetTabBottomOffset: Integer;\r\nbegin\r\n Result := FPanel.TabBottomOffset;\r\nend;\r\n\r\nfunction TJvDockVIDTabPageControl.GetTabLeftOffset: Integer;\r\nbegin\r\n Result := FPanel.TabLeftOffset;\r\nend;\r\n\r\nfunction TJvDockVIDTabPageControl.GetTabRightOffset: Integer;\r\nbegin\r\n Result := FPanel.TabRightOffset;\r\nend;\r\n\r\nfunction TJvDockVIDTabPageControl.GetTabTopOffset: Integer;\r\nbegin\r\n Result := FPanel.TabTopOffset;\r\nend;\r\n\r\nprocedure TJvDockVIDTabPageControl.Paint;\r\nbegin\r\n inherited Paint;\r\nend;\r\n\r\nprocedure TJvDockVIDTabPageControl.Resize;\r\nbegin\r\n inherited Resize;\r\n if FPanel = nil then\r\n Exit;\r\n case TabPosition of\r\n tpLeft:\r\n begin\r\n FPanel.Left := 0;\r\n FPanel.Width := Panel.FTabHeight;\r\n FPanel.Top := 0;\r\n FPanel.Height := Height;\r\n end;\r\n tpRight:\r\n begin\r\n FPanel.Left := Width - Panel.FTabHeight;\r\n FPanel.Top := 0;\r\n FPanel.Width := Panel.FTabHeight;\r\n FPanel.Height := Height;\r\n end;\r\n tpTop:\r\n begin\r\n FPanel.Left := 0;\r\n FPanel.Top := 0;\r\n FPanel.Width := Width;\r\n FPanel.Height := Panel.FTabHeight;\r\n end;\r\n tpBottom:\r\n begin\r\n FPanel.Left := 0;\r\n FPanel.Top := Height - Panel.FTabHeight;\r\n FPanel.Width := Width;\r\n FPanel.Height := Panel.FTabHeight;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockVIDTabPageControl.SetActiveFont(Value: TFont);\r\nbegin\r\n FPanel.FActiveFont.Assign(Value);\r\n if ActivePage <> nil then\r\n TJvDockVIDTabSheet(ActivePage).SetSheetSort(ActivePage.Caption);\r\n FPanel.Invalidate;\r\nend;\r\n\r\nprocedure TJvDockVIDTabPageControl.SetActiveSheetColor(const Value: TColor);\r\nbegin\r\n FPanel.FActiveSheetColor := Value;\r\n FPanel.Invalidate;\r\nend;\r\n\r\nprocedure TJvDockVIDTabPageControl.SetInactiveFont(Value: TFont);\r\nvar\r\n I: Integer;\r\nbegin\r\n FPanel.FInactiveFont.Assign(Value);\r\n for I := 0 to Count - 1 do\r\n if Pages[I] <> ActivePage then\r\n TJvDockVIDTabSheet(Pages[I]).SetSheetSort(Pages[I].Caption);\r\n FPanel.Invalidate;\r\nend;\r\n\r\nprocedure TJvDockVIDTabPageControl.SetInactiveSheetColor(const Value: TColor);\r\nbegin\r\n if FPanel.Color <> Value then\r\n begin\r\n FPanel.Color := Value;\r\n FPanel.Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockVIDTabPageControl.SetTabBottomOffset(const Value: Integer);\r\nbegin\r\n if FPanel.TabBottomOffset <> Value then\r\n begin\r\n FPanel.TabBottomOffset := Value;\r\n FPanel.Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockVIDTabPageControl.SetTabHeight(Value: Smallint);\r\nbegin\r\n inherited SetTabHeight(Value);\r\n if Panel.FTabHeight <> Value then\r\n begin\r\n Panel.FTabHeight := Value;\r\n FPanel.Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockVIDTabPageControl.SetTabLeftOffset(const Value: Integer);\r\nbegin\r\n if FPanel.TabLeftOffset <> Value then\r\n begin\r\n FPanel.TabLeftOffset := Value;\r\n FPanel.Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockVIDTabPageControl.SetTabPosition(Value: TTabPosition);\r\nbegin\r\n Assert(Value in [tpTop, tpBottom], RsEDockCannotSetTabPosition);\r\n inherited SetTabPosition(Value);\r\n Resize;\r\nend;\r\n\r\nprocedure TJvDockVIDTabPageControl.SetTabRightOffset(const Value: Integer);\r\nbegin\r\n if FPanel.TabRightOffset <> Value then\r\n begin\r\n FPanel.TabRightOffset := Value;\r\n FPanel.Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockVIDTabPageControl.SetTabTopOffset(const Value: Integer);\r\nbegin\r\n if FPanel.TabTopOffset <> Value then\r\n begin\r\n FPanel.TabTopOffset := Value;\r\n FPanel.Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockVIDTabPageControl.SetActivePage(Page: TJvDockTabSheet);\r\nbegin\r\n inherited SetActivePage(Page);\r\n FPanel.Invalidate;\r\nend;\r\n\r\nprocedure TJvDockVIDTabPageControl.DockDrop(Source: TDragDockObject;\r\n X, Y: Integer);\r\nvar\r\n Index: Integer;\r\n NewPage: TJvDockTabSheet;\r\nbegin\r\n inherited DockDrop(Source, X, Y);\r\n FPanel.SelectSheet := nil;\r\n if ActivePage <> nil then\r\n ParentForm.Caption := ActivePage.Caption;\r\n if Source.Control is TCustomForm then\r\n begin\r\n if Source.Control.Parent is TJvDockTabSheet then\r\n NewPage := TJvDockTabSheet(Source.Control.Parent)\r\n else\r\n NewPage := nil;\r\n if Source.Control.Visible and Assigned(NewPage) then\r\n ActivePage := NewPage;\r\n if FTabImageList <> nil then\r\n begin\r\n Index := FTabImageList.AddIcon(TForm(Source.Control).Icon);\r\n if (Index <> -1) and Assigned(NewPage) then\r\n NewPage.ImageIndex := Index;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJvDockVIDTabPageControl.GetDockClientFromMousePos(MousePos: TPoint): TControl;\r\nvar\r\n PageIndex: Integer;\r\nbegin\r\n Result := nil;\r\n case TabPosition of\r\n tpTop:\r\n PageIndex := Panel.FindSheetWithPos(MousePos.X, MousePos.Y, 0, Panel.Height - TabBottomOffset);\r\n tpBottom:\r\n PageIndex := Panel.FindSheetWithPos(MousePos.X, MousePos.Y, TabBottomOffset, Panel.Height);\r\n tpLeft:\r\n PageIndex := Panel.FindSheetWithPos(MousePos.Y, MousePos.X, 0, Panel.Height - TabBottomOffset);\r\n tpRight:\r\n PageIndex := Panel.FindSheetWithPos(MousePos.Y, MousePos.X, TabBottomOffset, Panel.Height);\r\n else\r\n PageIndex := -1;\r\n end;\r\n if PageIndex >= 0 then\r\n begin\r\n Result := Pages[PageIndex].Controls[0];\r\n if Result.HostDockSite <> Self then\r\n Result := nil;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockVIDTabPageControl.CustomGetDockEdge(Source: TJvDockDragDockObject;\r\n MousePos: TPoint; var DropAlign: TAlign);\r\nvar\r\n ARect: TRect;\r\nbegin\r\n DropAlign := ComputeVIDDockingRect(Self, Source.Control, ARect, MousePos);\r\nend;\r\n\r\nfunction TJvDockVIDTabPageControl.GetVisibleSheetCount: Integer;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := 0;\r\n for I := 0 to Count - 1 do\r\n if Pages[I].TabVisible then\r\n Inc(Result);\r\nend;\r\n\r\nprocedure TJvDockVIDTabPageControl.UpdateCaption(Exclude: TControl);\r\nbegin\r\n ParentForm.Caption := ActivePage.Caption;\r\n if Parent <> nil then\r\n begin\r\n Parent.Invalidate;\r\n if Parent.HostDockSite <> nil then\r\n Parent.HostDockSite.Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockVIDTabPageControl.SetHotTrack(Value: Boolean);\r\nbegin\r\n inherited SetHotTrack(Value);\r\nend;\r\n\r\nprocedure TJvDockVIDTabPageControl.SetImages(Value: TCustomImageList);\r\nbegin\r\n inherited SetImages(Value);\r\n if Panel <> nil then\r\n begin\r\n Panel.ShowTabImages := Value <> nil;\r\n Panel.Invalidate;\r\n end;\r\nend;\r\n\r\nfunction TJvDockVIDTabPageControl.GetHotTrackColor: TColor;\r\nbegin\r\n Result := Panel.FHotTrackColor;\r\nend;\r\n\r\nprocedure TJvDockVIDTabPageControl.SetHotTrackColor(const Value: TColor);\r\nbegin\r\n if Panel.FHotTrackColor <> Value then\r\n begin\r\n Panel.FHotTrackColor := Value;\r\n Panel.Invalidate;\r\n end;\r\nend;\r\n\r\nfunction TJvDockVIDTabPageControl.GetShowTabImages: Boolean;\r\nbegin\r\n Result := FPanel.FShowTabImages;\r\nend;\r\n\r\nprocedure TJvDockVIDTabPageControl.SetShowTabImages(const Value: Boolean);\r\nbegin\r\n FPanel.ShowTabImages := Value;\r\nend;\r\n\r\nfunction TJvDockVIDTabPageControl.CustomUnDock(Source: TJvDockDragDockObject;\r\n NewTarget: TWinControl; Client: TControl): Boolean;\r\nvar\r\n CurrPage: TJvDockTabSheet;\r\n I: Integer;\r\nbegin\r\n if not ((Source.Control.HostDockSite <> nil) and\r\n (Source.DropOnControl = Source.Control.HostDockSite.Parent) and\r\n (Source.DropAlign = alClient)) then\r\n begin\r\n CurrPage := GetPageFromDockClient(Client);\r\n if CurrPage <> nil then\r\n begin\r\n //if (FTabImageList <> nil) and ShowTabImages and\r\n // (FTabImageList.Count > CurrPage.ImageIndex) then\r\n //prevent AV\r\n if Assigned(FTabImageList) then\r\n if ShowTabImages and\r\n (FTabImageList.Count > CurrPage.ImageIndex) and\r\n (CurrPage.ImageIndex >= 0) then\r\n begin\r\n FTabImageList.Delete(CurrPage.ImageIndex);\r\n for I := 0 to Count - 1 do\r\n if Pages[I].ImageIndex > CurrPage.ImageIndex then\r\n Pages[I].ImageIndex := Pages[I].ImageIndex - 1;\r\n end;\r\n end;\r\n Result := inherited CustomUnDock(Source, NewTarget, Client);\r\n end\r\n else\r\n Result := True;\r\nend;\r\n\r\nfunction TJvDockVIDTabPageControl.GetPage(Index: Integer): TJvDockVIDTabSheet;\r\nbegin\r\n Result := TJvDockVIDTabSheet(inherited Pages[Index]);\r\nend;\r\n\r\nfunction TJvDockVIDTabPageControl.GetActiveVIDPage: TJvDockVIDTabSheet;\r\nbegin\r\n Result := TJvDockVIDTabSheet(inherited ActivePage);\r\nend;\r\n\r\nprocedure TJvDockVIDTabPageControl.SetActiveVIDPage(const Value: TJvDockVIDTabSheet);\r\nbegin\r\n ActivePage := Value;\r\nend;\r\n\r\nprocedure TJvDockVIDTabPageControl.SyncWithStyle;\r\nvar\r\n VIDTabServerOption: TJvDockVIDTabServerOption;\r\nbegin\r\n inherited SyncWithStyle;\r\n // panel must be created\r\n if FPanel = nil then\r\n Exit;\r\n if DockStyle.TabServerOption is TJvDockVIDTabServerOption then\r\n begin\r\n VIDTabServerOption := TJvDockVIDTabServerOption(DockStyle.TabServerOption);\r\n\r\n ActiveFont := VIDTabServerOption.ActiveFont;\r\n ActiveSheetColor := VIDTabServerOption.ActiveSheetColor;\r\n HotTrackColor := VIDTabServerOption.HotTrackColor;\r\n InactiveFont := VIDTabServerOption.InactiveFont;\r\n InactiveSheetColor := VIDTabServerOption.InactiveSheetColor;\r\n ShowTabImages := VIDTabServerOption.ShowTabImages;\r\n TabPosition := VIDTabServerOption.TabPosition;\r\n end;\r\nend;\r\n\r\n//=== { TJvDockTabPanel } ====================================================\r\n\r\nconstructor TJvDockTabPanel.Create(AOwner: TComponent);\r\nbegin\r\n {$IFDEF JVDOCK_DEBUG}\r\n OutputDebugString('JvDockVIDStyle.pas: TJvDockTabPanel.Create');\r\n {$ENDIF JVDOCK_DEBUG}\r\n inherited Create(AOwner);\r\n Page := nil;\r\n FCaptionTopOffset := 0;\r\n FCaptionLeftOffset := 5;\r\n FCaptionRightOffset := 5;\r\n FTabBottomOffset := 3;\r\n FTabSplitterWidth := 3;\r\n FTabHeight := 22;\r\n FSortList := TList.Create;\r\n FActiveFont := TFont.Create;\r\n FActiveFont.Color := clBlack;\r\n FInactiveFont := TFont.Create;\r\n FInactiveFont.Color := clWhite;\r\n FHotTrackColor := clBlue;\r\n FTempPages := TList.Create;\r\n FSelectHotIndex := -1;\r\n FShowTabImages := False;\r\n FSelectSheet := nil;\r\nend;\r\n\r\ndestructor TJvDockTabPanel.Destroy;\r\nbegin\r\n FActiveFont.Free;\r\n FInactiveFont.Free;\r\n FSortList.Free;\r\n FTempPages.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvDockTabPanel.DeleteSorts(Sheet: TJvDockVIDTabSheet);\r\nvar\r\n SheetIndex: Integer;\r\nbegin\r\n SheetIndex := FSortList.IndexOf(Sheet);\r\n if SheetIndex >= 0 then\r\n FSortList.Delete(SheetIndex);\r\n if Sheet <> nil then\r\n Sheet.TabVisible := False;\r\n SetShowTabWidth;\r\n Page.Invalidate;\r\nend;\r\n\r\nfunction TJvDockTabPanel.FindSheetWithPos(cX, cY, cTopOffset, cBottomOffset: Integer): Integer;\r\nvar\r\n I: Integer;\r\n CompleteWidth, CurrTabWidth: Integer;\r\n Pages: TList;\r\nbegin\r\n Result := -1;\r\n if (cY > cBottomOffset) or (cY < cTopOffset) then\r\n Exit;\r\n CompleteWidth := 0;\r\n if FSelectSheet = nil then\r\n Pages := Page.PageSheets\r\n else\r\n Pages := FTempPages;\r\n for I := 0 to Pages.Count - 1 do\r\n begin\r\n if not TJvDockVIDTabSheet(Pages[I]).TabVisible then\r\n Continue;\r\n CurrTabWidth := TJvDockVIDTabSheet(Pages[I]).ShowTabWidth;\r\n if (cX >= FTabLeftOffset + CompleteWidth) and (cX <= FTabLeftOffset + CurrTabWidth + CompleteWidth +\r\n FTabSplitterWidth) then\r\n begin\r\n Result := I;\r\n Exit;\r\n end;\r\n Inc(CompleteWidth, CurrTabWidth + FTabSplitterWidth);\r\n end;\r\nend;\r\n\r\nfunction TJvDockTabPanel.GetPageIndexFromMousePos(X, Y: Integer): Integer;\r\nbegin\r\n Result := -1;\r\n case Page.TabPosition of\r\n tpTop:\r\n Result := FindSheetWithPos(X, Y, 0, Height - TabBottomOffset);\r\n tpBottom:\r\n Result := FindSheetWithPos(X, Y, TabBottomOffset, Height);\r\n tpLeft:\r\n Result := FindSheetWithPos(Y, X, 0, Height - TabBottomOffset);\r\n tpRight:\r\n Result := FindSheetWithPos(Y, X, TabBottomOffset, Height);\r\n end;\r\nend;\r\n\r\nfunction TJvDockTabPanel.GetMaxTabWidth: TJvDockTabSheet;\r\nvar\r\n I: Integer;\r\n MaxWidth, CurrWidth: Integer;\r\nbegin\r\n Result := nil;\r\n MaxWidth := 0;\r\n if Page = nil then\r\n Exit;\r\n for I := 0 to Page.Count - 1 do\r\n begin\r\n CurrWidth := Canvas.TextWidth(Page.Tabs[I]);\r\n if MaxWidth < CurrWidth then\r\n begin\r\n Result := Page.Pages[I];\r\n MaxWidth := CurrWidth;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJvDockTabPanel.GetMinTabWidth: TJvDockTabSheet;\r\nvar\r\n I: Integer;\r\n MinWidth, CurrWidth: Integer;\r\nbegin\r\n Result := nil;\r\n MinWidth := 0;\r\n for I := 0 to Page.Count - 1 do\r\n begin\r\n CurrWidth := Canvas.TextWidth(Page.Tabs[I]);\r\n if MinWidth > CurrWidth then\r\n begin\r\n Result := Page.Pages[I];\r\n MinWidth := CurrWidth;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJvDockTabPanel.GetPanelHeight: Integer;\r\nbegin\r\n case Page.TabPosition of\r\n tpLeft, tpRight:\r\n Result := Width;\r\n tpTop, tpBottom:\r\n Result := Height;\r\n else\r\n Result := 0;\r\n end;\r\nend;\r\n\r\nfunction TJvDockTabPanel.GetPanelWidth: Integer;\r\nbegin\r\n case Page.TabPosition of\r\n tpLeft, tpRight:\r\n Result := Height;\r\n tpTop, tpBottom:\r\n Result := Width;\r\n else\r\n Result := 0;\r\n end;\r\nend;\r\n\r\nfunction TJvDockTabPanel.GetSorts(Index: Integer): TJvDockVIDTabSheet;\r\nbegin\r\n Result := FSortList[Index];\r\nend;\r\n\r\nfunction TJvDockTabPanel.GetTotalTabWidth: Integer;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := 0;\r\n if FSortList = nil then\r\n Exit;\r\n for I := 0 to FSortList.Count - 1 do\r\n Inc(Result, Sorts[I].TabWidth + Integer(I <> FSortList.Count - 1) * FTabSplitterWidth);\r\nend;\r\n\r\nprocedure TJvDockTabPanel.MouseDown(Button: TMouseButton; Shift: TShiftState;\r\n X, Y: Integer);\r\nvar\r\n Ctrl: TControl;\r\n Index: Integer;\r\n Msg: TWMMouse;\r\n Sheet: TJvDockVIDTabSheet;\r\n AParentForm: TCustomForm;\r\nbegin\r\n inherited MouseDown(Button, Shift, X, Y);\r\n if Page = nil then\r\n Exit;\r\n\r\n Index := GetPageIndexFromMousePos(X, Y);\r\n if Index >= 0 then\r\n begin\r\n if Index <> Page.ActivePageIndex then\r\n begin\r\n Sheet := Page.ActiveVIDPage;\r\n Page.ActivePageIndex := Index;\r\n Sheet.SetSheetSort(Sheet.Caption);\r\n Page.ActiveVIDPage.SetSheetSort(Page.ActiveVIDPage.Caption);\r\n Page.Change;\r\n Invalidate;\r\n end;\r\n if Assigned(Page.ActivePage) and Page.ActivePage.CanFocus then\r\n begin\r\n AParentForm := GetParentForm(Page);\r\n if Assigned(AParentForm) then \r\n begin\r\n Page.SelectFirst;\r\n AParentForm.SetFocus;\r\n end;\r\n end;\r\n\r\n if Button = mbLeft then\r\n begin\r\n FSelectSheet := TJvDockVIDTabSheet(Page.ActivePage);\r\n FTempPages.Assign(Page.PageSheets);\r\n end;\r\n\r\n Ctrl := GetDockClientFromPageIndex(Index);\r\n if Ctrl <> nil then\r\n begin\r\n JvGlobalDockClient := FindDockClient(Ctrl);\r\n if JvGlobalDockClient <> nil then\r\n begin\r\n Msg.Msg := WM_NCLBUTTONDOWN + Integer(Button) * 3 + Integer(ssDouble in Shift) * 2;\r\n Msg.Pos.x := X;\r\n Msg.Pos.y := Y;\r\n if not (ssDouble in Shift) then\r\n JvGlobalDockClient.DoNCButtonDown(Page.DoMouseEvent(Msg, Page), Button, msTabPage)\r\n else\r\n begin\r\n JvGlobalDockClient.DoNCButtonDblClk(Page.DoMouseEvent(Msg, Page), Button, msTabPage);\r\n if (Button = mbLeft) and JvGlobalDockClient.CanFloat then\r\n Ctrl.ManualDock(nil, nil, alNone);\r\n end;\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockTabPanel.MouseMove(Shift: TShiftState; X, Y: Integer);\r\nvar\r\n Index: Integer;\r\n Ctrl: TControl;\r\n ARect: TRect;\r\nbegin\r\n inherited MouseMove(Shift, X, Y);\r\n Index := GetPageIndexFromMousePos(X, Y);\r\n if Page.HotTrack and (Index <> FSelectHotIndex) then\r\n begin\r\n FSelectHotIndex := Index;\r\n Invalidate;\r\n end;\r\n\r\n if Assigned(FSelectSheet) then\r\n begin\r\n Index := GetPageIndexFromMousePos(X, Y);\r\n if Index >= 0 then\r\n begin\r\n if (Index <> Page.ActivePageIndex) and (Page.Count > Index) then\r\n begin\r\n FSelectSheet.PageIndex := Index;\r\n Invalidate;\r\n end;\r\n end\r\n else\r\n begin\r\n case Page.TabPosition of\r\n tpTop:\r\n ARect := Rect(0, 0, Width, Height - FTabBottomOffset);\r\n tpBottom:\r\n ARect := Rect(0, FTabBottomOffset, Width, Height);\r\n tpLeft:\r\n ARect := Rect(0, 0, Width - FTabBottomOffset, Height);\r\n tpRight:\r\n ARect := Rect(FTabBottomOffset, 0, Width, Height);\r\n else\r\n ARect := Rect(0, 0, 0, 0);\r\n end;\r\n if PtInRect(ARect, Point(X, Y)) then\r\n Exit;\r\n if Page.FTempSheet = nil then\r\n begin\r\n Ctrl := GetDockClientFromPageIndex(FSelectSheet.PageIndex);\r\n if Ctrl <> nil then\r\n JvGlobalDockManager.BeginDrag(Ctrl, False, 1);\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockTabPanel.MouseUp(Button: TMouseButton; Shift: TShiftState;\r\n X, Y: Integer);\r\nvar\r\n Ctrl: TControl;\r\n Index: Integer;\r\n Msg: TWMMouse;\r\nbegin\r\n {$IFDEF JVDOCK_DEBUG}\r\n OutputDebugString('JvDockVIDStyle.pas: TJvDockTabPanel.MouseUp');\r\n {$ENDIF JVDOCK_DEBUG}\r\n\r\n inherited MouseUp(Button, Shift, X, Y);\r\n FSelectSheet := nil;\r\n if Page = nil then\r\n Exit;\r\n\r\n Index := GetPageIndexFromMousePos(X, Y);\r\n Ctrl := GetDockClientFromPageIndex(Index);\r\n if Ctrl <> nil then\r\n begin\r\n JvGlobalDockClient := FindDockClient(Ctrl);\r\n if JvGlobalDockClient <> nil then\r\n begin\r\n Msg.Msg := WM_NCLBUTTONUP + Integer(Button) * 3 + Integer(ssDouble in Shift) * 2;\r\n Msg.Pos := PointToSmallPoint(Page.ScreenToClient(ClientToScreen(Point(X, Y))));\r\n if not (ssDouble in Shift) then\r\n JvGlobalDockClient.DoNCButtonUp(Page.DoMouseEvent(Msg, Page), Button, msTabPage);\r\n end;\r\n end;\r\nend;\r\n\r\n{ TJvDockTabPanel.Paint,etc.\r\n TODO-LIST-ITEM:\r\n ---------------\r\n VID style has a bit of a problem with what to do in\r\n case of a lot of tabs. It keeps making the text shorter via\r\n text drawn with ellipsis but doesn't EVER display the left/right\r\n buttons that allow you to scroll through a long list of tabs.\r\n To fix this is non-trivial. -WPostma.\r\n }\r\nprocedure TJvDockTabPanel.Paint;\r\nvar\r\n ARect: TRect;\r\n CurrTabWidth: Integer;\r\n I, CompleteWidth: Integer;\r\n ImageWidth: Integer;\r\n CaptionString: string;\r\nbegin\r\n inherited Paint;\r\n if Page = nil then\r\n Exit;\r\n\r\n if (Page.Images <> nil) and (Page.ShowTabImages) then\r\n ImageWidth := Page.Images.Width\r\n else\r\n ImageWidth := 0;\r\n\r\n Canvas.Brush.Color := Page.ActiveSheetColor;\r\n case Page.TabPosition of\r\n tpLeft:\r\n Canvas.FillRect(Rect(PanelHeight - FTabBottomOffset, 0, PanelHeight, PanelWidth));\r\n tpRight:\r\n Canvas.FillRect(Rect(0, 0, FTabBottomOffset, PanelWidth));\r\n tpTop:\r\n Canvas.FillRect(Rect(0, PanelHeight - FTabBottomOffset, PanelWidth, PanelHeight));\r\n tpBottom:\r\n Canvas.FillRect(Rect(0, 0, PanelWidth, FTabBottomOffset));\r\n end;\r\n\r\n case Page.TabPosition of\r\n tpTop, tpLeft:\r\n Canvas.Pen.Color := clWhite;\r\n tpBottom, tpRight:\r\n Canvas.Pen.Color := clBlack;\r\n end;\r\n\r\n case Page.TabPosition of\r\n tpLeft:\r\n begin\r\n Canvas.MoveTo(PanelHeight - FTabBottomOffset, 0);\r\n Canvas.LineTo(PanelHeight - FTabBottomOffset, PanelWidth);\r\n end;\r\n tpRight:\r\n begin\r\n Canvas.MoveTo(FTabBottomOffset, 0);\r\n Canvas.LineTo(FTabBottomOffset, PanelWidth);\r\n end;\r\n tpTop:\r\n begin\r\n Canvas.MoveTo(0, PanelHeight - FTabBottomOffset);\r\n Canvas.LineTo(PanelWidth, PanelHeight - FTabBottomOffset);\r\n end;\r\n tpBottom:\r\n begin\r\n Canvas.MoveTo(0, FTabBottomOffset);\r\n Canvas.LineTo(PanelWidth, FTabBottomOffset);\r\n end;\r\n end;\r\n\r\n CompleteWidth := 0;\r\n\r\n Canvas.Brush.Style := bsClear;\r\n\r\n for I := 0 to Page.Count - 1 do\r\n begin\r\n if not Page.Pages[I].TabVisible then\r\n Continue;\r\n\r\n CurrTabWidth := TJvDockVIDTabSheet(Page.Pages[I]).ShowTabWidth;\r\n\r\n if Page.ActivePageIndex = I then\r\n begin\r\n Canvas.Brush.Color := Page.ActiveSheetColor;\r\n case Page.TabPosition of\r\n tpLeft:\r\n Canvas.FillRect(Rect(FTabTopOffset, CompleteWidth + FTabLeftOffset,\r\n PanelHeight, CompleteWidth + FTabLeftOffset + CurrTabWidth));\r\n tpRight:\r\n Canvas.FillRect(Rect(FTabBottomOffset, CompleteWidth + FTabLeftOffset,\r\n PanelHeight - FTabTopOffset, CompleteWidth + FTabLeftOffset + CurrTabWidth));\r\n tpTop:\r\n Canvas.FillRect(Rect(CompleteWidth + FTabLeftOffset, FTabTopOffset,\r\n CompleteWidth + FTabLeftOffset + CurrTabWidth, PanelHeight));\r\n tpBottom:\r\n Canvas.FillRect(Rect(CompleteWidth + FTabLeftOffset, FTabBottomOffset,\r\n CompleteWidth + FTabLeftOffset + CurrTabWidth, PanelHeight - FTabTopOffset));\r\n end;\r\n\r\n Canvas.Pen.Color := clWhite;\r\n case Page.TabPosition of\r\n tpLeft:\r\n begin\r\n Canvas.MoveTo(PanelHeight - FTabBottomOffset, CompleteWidth + FTabLeftOffset);\r\n Canvas.LineTo(FTabTopOffset, CompleteWidth + FTabLeftOffset);\r\n Canvas.LineTo(FTabTopOffset, CompleteWidth + FTabLeftOffset + CurrTabWidth);\r\n Canvas.Pen.Color := clBlack;\r\n Canvas.LineTo(PanelHeight - FTabBottomOffset, CompleteWidth + FTabLeftOffset + CurrTabWidth);\r\n end;\r\n tpRight:\r\n begin\r\n Canvas.MoveTo(FTabTopOffset, CompleteWidth + FTabLeftOffset);\r\n Canvas.LineTo(PanelHeight - FTabBottomOffset, CompleteWidth + FTabLeftOffset);\r\n Canvas.Pen.Color := clBlack;\r\n Canvas.LineTo(PanelHeight - FTabBottomOffset, CompleteWidth + FTabLeftOffset + CurrTabWidth);\r\n Canvas.LineTo(FTabTopOffset, CompleteWidth + FTabLeftOffset + CurrTabWidth);\r\n end;\r\n tpTop:\r\n begin\r\n Canvas.MoveTo(CompleteWidth + FTabLeftOffset, PanelHeight - FTabBottomOffset);\r\n Canvas.LineTo(CompleteWidth + FTabLeftOffset, FTabTopOffset);\r\n Canvas.LineTo(CompleteWidth + FTabLeftOffset + CurrTabWidth, FTabTopOffset);\r\n Canvas.Pen.Color := clBlack;\r\n Canvas.LineTo(CompleteWidth + FTabLeftOffset + CurrTabWidth, PanelHeight - FTabTopOffset);\r\n end;\r\n tpBottom:\r\n begin\r\n Canvas.MoveTo(CompleteWidth + FTabLeftOffset, FTabBottomOffset);\r\n Canvas.LineTo(CompleteWidth + FTabLeftOffset, PanelHeight - FTabTopOffset);\r\n Canvas.Pen.Color := clBlack;\r\n Canvas.LineTo(CompleteWidth + FTabLeftOffset + CurrTabWidth, PanelHeight - FTabTopOffset);\r\n Canvas.LineTo(CompleteWidth + FTabLeftOffset + CurrTabWidth, FTabBottomOffset);\r\n end;\r\n end;\r\n\r\n Canvas.Font.Assign(FActiveFont);\r\n end\r\n else\r\n begin\r\n if (I < Page.ActivePageIndex - 1) or (I > Page.ActivePageIndex) then\r\n begin\r\n Canvas.Pen.Color := Page.InactiveFont.Color;\r\n case Page.TabPosition of\r\n tpLeft, tpRight:\r\n begin\r\n Canvas.MoveTo(PanelHeight - FTabBottomOffset - 3, CompleteWidth + FTabLeftOffset + CurrTabWidth);\r\n Canvas.LineTo(FTabTopOffset + 2, CompleteWidth + FTabLeftOffset + CurrTabWidth);\r\n end;\r\n tpTop, tpBottom:\r\n begin\r\n Canvas.MoveTo(CompleteWidth + FTabLeftOffset + CurrTabWidth, PanelHeight - FTabBottomOffset - 3);\r\n Canvas.LineTo(CompleteWidth + FTabLeftOffset + CurrTabWidth, FTabTopOffset + 2);\r\n end;\r\n end;\r\n end;\r\n Canvas.Brush.Color := Page.InactiveSheetColor;\r\n Canvas.Font.Assign(FInactiveFont);\r\n end;\r\n\r\n if FSelectHotIndex = I then\r\n Canvas.Font.Color := FHotTrackColor;\r\n\r\n case Page.TabPosition of\r\n tpLeft:\r\n ARect := Rect(FTabTopOffset + FCaptionTopOffset + 1,\r\n CompleteWidth + FTabLeftOffset + FCaptionLeftOffset,\r\n PanelHeight,\r\n CompleteWidth + FTabLeftOffset + CurrTabWidth - FCaptionRightOffset);\r\n\r\n tpRight:\r\n ARect := Rect(FTabBottomOffset + FCaptionTopOffset + 1,\r\n CompleteWidth + FTabLeftOffset + FCaptionLeftOffset,\r\n PanelHeight,\r\n CompleteWidth + FTabLeftOffset + CurrTabWidth - FCaptionRightOffset);\r\n\r\n tpTop:\r\n ARect := Rect(CompleteWidth + FTabLeftOffset + FCaptionLeftOffset +\r\n Integer(FShowTabImages) * (ImageWidth + FCaptionLeftOffset),\r\n FTabTopOffset + FCaptionTopOffset + 1,\r\n CompleteWidth + FTabLeftOffset + CurrTabWidth - FCaptionRightOffset,\r\n PanelHeight);\r\n\r\n tpBottom:\r\n ARect := Rect(CompleteWidth + FTabLeftOffset + FCaptionLeftOffset +\r\n Integer(FShowTabImages) * (ImageWidth + FCaptionLeftOffset),\r\n FTabBottomOffset + FCaptionTopOffset + 1,\r\n CompleteWidth + FTabLeftOffset + CurrTabWidth - FCaptionRightOffset,\r\n PanelHeight);\r\n end;\r\n\r\n CaptionString := Page.Pages[I].Caption;\r\n DrawText(Canvas.Handle, PChar(CaptionString), Length(CaptionString),\r\n ARect, DT_LEFT or DT_SINGLELINE or DT_END_ELLIPSIS);\r\n\r\n if FShowTabImages and (Page.Images <> nil) and (CurrTabWidth > ImageWidth + 2 * FCaptionLeftOffset) then\r\n Page.Images.Draw(Canvas, CompleteWidth + FTabLeftOffset + FCaptionLeftOffset,\r\n FTabBottomOffset + FCaptionTopOffset + 1, Page.Pages[I].ImageIndex, True);\r\n\r\n Inc(CompleteWidth, CurrTabWidth + FTabSplitterWidth);\r\n end;\r\n\r\n Canvas.Brush.Color := Page.ActiveSheetColor;\r\n ARect := ClientRect;\r\n Canvas.FrameRect(ARect);\r\nend;\r\n\r\nprocedure TJvDockTabPanel.Resize;\r\nbegin\r\n inherited Resize;\r\n SetShowTabWidth;\r\nend;\r\n\r\nprocedure TJvDockTabPanel.SetCaptionLeftOffset(const Value: Integer);\r\nbegin\r\n if FCaptionLeftOffset <> Value then\r\n begin\r\n FCaptionLeftOffset := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockTabPanel.SetCaptionRightOffset(const Value: Integer);\r\nbegin\r\n if FCaptionRightOffset <> Value then\r\n begin\r\n FCaptionRightOffset := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockTabPanel.SetCaptionTopOffset(const Value: Integer);\r\nbegin\r\n if FCaptionTopOffset <> Value then\r\n begin\r\n FCaptionTopOffset := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockTabPanel.SetPage(const Value: TJvDockVIDTabPageControl);\r\nbegin\r\n FPage := Value;\r\nend;\r\n\r\nprocedure TJvDockTabPanel.SetPanelHeight(const Value: Integer);\r\nbegin\r\n if PanelHeight <> Value then\r\n begin\r\n case Page.TabPosition of\r\n tpLeft, tpRight:\r\n Width := Value;\r\n tpTop, tpBottom:\r\n Height := Value;\r\n end;\r\n SetShowTabWidth;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockTabPanel.SetTabBottomOffset(const Value: Integer);\r\nbegin\r\n if FTabBottomOffset <> Value then\r\n begin\r\n FTabBottomOffset := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockTabPanel.SetTabLeftOffset(const Value: Integer);\r\nbegin\r\n if FTabLeftOffset <> Value then\r\n begin\r\n FTabLeftOffset := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockTabPanel.SetTabRightOffset(const Value: Integer);\r\nbegin\r\n if FTabRightOffset <> Value then\r\n begin\r\n FTabRightOffset := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockTabPanel.SetTabSplitterWidth(const Value: Integer);\r\nbegin\r\n if FTabSplitterWidth <> Value then\r\n begin\r\n FTabSplitterWidth := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockTabPanel.SetTabTopOffset(const Value: Integer);\r\nbegin\r\n if FTabTopOffset <> Value then\r\n begin\r\n FTabTopOffset := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockTabPanel.SetTotalTabWidth(const Value: Integer);\r\nbegin\r\nend;\r\n\r\nfunction TJvDockTabPanel.GetDockClientFromPageIndex(Index: Integer): TControl;\r\nbegin\r\n Result := nil;\r\n if Index >= 0 then\r\n if Page.Pages[Index].ControlCount = 1 then\r\n begin\r\n Result := Page.Pages[Index].Controls[0];\r\n if Result.HostDockSite <> Page then\r\n Result := nil;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockTabPanel.SetShowTabWidth;\r\nvar\r\n I, J, TempWidth: Integer;\r\n PanelWidth, VisibleCount: Integer;\r\n ImageWidth: Integer;\r\nbegin\r\n if Page = nil then\r\n Exit;\r\n if FSortList = nil then\r\n Exit;\r\n PanelWidth := 0;\r\n case Page.TabPosition of\r\n tpTop, tpBottom:\r\n PanelWidth := Width;\r\n tpLeft, tpRight:\r\n PanelWidth := Height;\r\n end;\r\n\r\n TempWidth := PanelWidth - FCaptionLeftOffset - FCaptionRightOffset;\r\n if Page.ShowTabImages then\r\n ImageWidth := Page.Images.Width + FCaptionLeftOffset\r\n else\r\n ImageWidth := 0;\r\n VisibleCount := Page.VisibleSheetCount;\r\n J := 0;\r\n for I := 0 to FSortList.Count - 1 do\r\n begin\r\n if not Sorts[I].TabVisible then\r\n Continue;\r\n if (VisibleCount - J) * (Sorts[I].TabWidth + FTabSplitterWidth + ImageWidth) > TempWidth then\r\n Sorts[I].FShowTabWidth := TempWidth div (VisibleCount - J) - FTabSplitterWidth\r\n else\r\n Sorts[I].FShowTabWidth := Sorts[I].TabWidth + ImageWidth;\r\n Dec(TempWidth, Sorts[I].FShowTabWidth + FTabSplitterWidth);\r\n Inc(J);\r\n end;\r\nend;\r\n\r\nprocedure TJvDockTabPanel.CMMouseLeave(var Msg: TMessage);\r\nbegin\r\n inherited;\r\n if FSelectHotIndex <> -1 then\r\n begin\r\n FSelectHotIndex := -1;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockTabPanel.SetShowTabImages(const Value: Boolean);\r\nbegin\r\n if FShowTabImages <> Value then\r\n begin\r\n FShowTabImages := Value;\r\n SetShowTabWidth;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockTabPanel.SetTabHeight(const Value: Integer);\r\nbegin\r\n FTabHeight := Value;\r\n Height := FTabHeight + FTabTopOffset + FTabBottomOffset;\r\nend;\r\n\r\n//=== { TJvDockVIDTabSheet } =================================================\r\n\r\nconstructor TJvDockVIDTabSheet.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FIsSourceDockClient := False;\r\nend;\r\n\r\ndestructor TJvDockVIDTabSheet.Destroy;\r\nbegin\r\n if (PageControl is TJvDockVIDTabPageControl) and (PageControl <> nil) then\r\n TJvDockVIDTabPageControl(PageControl).Panel.DeleteSorts(Self);\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvDockVIDTabSheet.Loaded;\r\nbegin\r\n inherited Loaded;\r\n SetSheetSort(Caption);\r\nend;\r\n\r\nprocedure TJvDockVIDTabSheet.SetPageControl(APageControl: TJvDockPageControl);\r\nbegin\r\n inherited SetPageControl(APageControl);\r\nend;\r\n\r\nprocedure TJvDockVIDTabSheet.SetSheetSort(const CaptionStr: string);\r\nvar\r\n TabPanel: TJvDockTabPanel;\r\n TempWidth: Integer;\r\n\r\n procedure DoSetSheetSort;\r\n var\r\n I: Integer;\r\n begin\r\n TJvDockVIDTabPageControl(PageControl).Panel.FSortList.Remove(Self);\r\n for I := 0 to TJvDockVIDTabPageControl(PageControl).Panel.FSortList.Count - 1 do\r\n if TJvDockVIDTabPageControl(PageControl).Panel.Sorts[I].TabWidth > TempWidth then\r\n begin\r\n TJvDockVIDTabPageControl(PageControl).Panel.FSortList.Insert(I, Self);\r\n Exit;\r\n end;\r\n TJvDockVIDTabPageControl(PageControl).Panel.FSortList.Add(Self);\r\n end;\r\n\r\nbegin\r\n if (PageControl is TJvDockVIDTabPageControl) and (PageControl <> nil) then\r\n begin\r\n TabPanel := TJvDockVIDTabPageControl(PageControl).Panel;\r\n if PageControl.ActivePage = Self then\r\n TabPanel.Canvas.Font.Assign(TabPanel.Page.ActiveFont)\r\n else\r\n TabPanel.Canvas.Font.Assign(TabPanel.Page.InactiveFont);\r\n TempWidth := TabPanel.Canvas.TextWidth(\r\n CaptionStr) + TabPanel.CaptionLeftOffset + TabPanel.CaptionRightOffset;\r\n if TempWidth <> FTabWidth then\r\n begin\r\n DoSetSheetSort;\r\n FTabWidth := TempWidth;\r\n TabPanel.SetShowTabWidth;\r\n TabPanel.Invalidate;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockVIDTabSheet.SetTabWidth(const Value: Integer);\r\nbegin\r\n FTabWidth := Value;\r\nend;\r\n\r\nprocedure TJvDockVIDTabSheet.UpdateTabShowing;\r\nbegin\r\n inherited UpdateTabShowing;\r\n TJvDockVIDTabPageControl(PageControl).Panel.SetShowTabWidth;\r\nend;\r\n\r\nprocedure TJvDockVIDTabSheet.WMSetText(var Msg: TMessage);\r\nbegin\r\n inherited;\r\n SetSheetSort(PChar(Msg.LParam));\r\nend;\r\n\r\n//=== { TJvDockVIDDragDockObject } ===========================================\r\n\r\nconstructor TJvDockVIDDragDockObject.Create(AControl: TControl);\r\n\r\n procedure DoGetSourceDockClients(Control: TControl);\r\n var\r\n I: Integer;\r\n DockableControl: TWinControl;\r\n begin\r\n if Control is TJvDockableForm then\r\n begin\r\n DockableControl := TJvDockableForm(Control).DockableControl;\r\n for I := 0 to DockableControl.DockClientCount - 1 do\r\n DoGetSourceDockClients(DockableControl.DockClients[I]);\r\n end\r\n else\r\n FSourceDockClientList.Add(Control);\r\n end;\r\n\r\nbegin\r\n inherited Create(AControl);\r\n FSourceDockClientList := TList.Create;\r\n DoGetSourceDockClients(AControl);\r\n FDropTabControl := nil;\r\n FIsTabDockOver := False;\r\n CurrState := dsDragEnter;\r\n OldState := CurrState;\r\nend;\r\n\r\ndestructor TJvDockVIDDragDockObject.Destroy;\r\nbegin\r\n FDropTabControl := nil;\r\n FSourceDockClientList.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvDockVIDDragDockObject.GetBrush_PenSize_DrawRect(var ABrush: TBrush;\r\n var PenSize: Integer; var DrawRect: TRect; Erase: Boolean);\r\nbegin\r\n if DragTarget = nil then\r\n DropAlign := alNone;\r\n inherited GetBrush_PenSize_DrawRect(ABrush, PenSize, DrawRect, Erase);\r\n FIsTabDockOver := ((FOldDropAlign = alClient) and FErase) or\r\n ((DropAlign = alClient) and not FErase);\r\n FOldDropAlign := DropAlign;\r\n FOldTarget := DragTarget;\r\nend;\r\n\r\n// (rom) unused writeable const option removed\r\n\r\nprocedure TJvDockVIDDragDockObject.DefaultDockImage(Erase: Boolean);\r\nvar\r\n DrawRect: TRect;\r\n TabControlRect: TRect;\r\n TabRect: TRect;\r\n PenSize: Integer;\r\n ABrush: TBrush;\r\n ShowTab: Boolean;\r\n LeftOffset: Integer;\r\n BottomOffset: Integer;\r\n MaxTabWidth: Integer;\r\nbegin\r\n FErase := Erase;\r\n GetBrush_PenSize_DrawRect(ABrush, PenSize, DrawRect, Erase);\r\n if Erase then\r\n Exit; // No need to erase\r\n\r\n ShowTab := False;\r\n if FIsTabDockOver and Assigned(FDropTabControl) then\r\n begin\r\n TabControlRect := FDropTabControl.BoundsRect;\r\n TabControlRect := Classes.Rect(FDropTabControl.ClientToScreen(TabControlRect.TopLeft),\r\n FDropTabControl.ClientToScreen(TabControlRect.BottomRight));\r\n // This is to make sure the TabControlRect is included in the DrawRect\r\n if PtInRect(DrawRect, TabControlRect.TopLeft) and\r\n PtInRect(DrawRect, Point(TabControlRect.BottomRight.X -1,\r\n TabControlRect.BottomRight.Y -1))\r\n then\r\n ShowTab := True;\r\n end;\r\n\r\n if not ShowTab then\r\n begin\r\n AlphaBlendedForm.Visible := True;\r\n AlphaBlendedForm.BoundsRect := DrawRect;\r\n AlphaBlendedTab.Visible := False;\r\n AlphaBlendedTab.BoundsRect := Rect(0, 0, 0, 0);\r\n end\r\n else\r\n begin\r\n LeftOffset := FDropTabControl.TabLeftOffset;\r\n BottomOffset := FDropTabControl.Panel.TabHeight;\r\n if FDropTabControl.Panel.Page.Count > 0 then\r\n MaxTabWidth := FDropTabControl.Panel.Sorts[0].TabWidth\r\n else\r\n MaxTabWidth := 30;\r\n\r\n if TabControlRect.Right - TabControlRect.Left < LeftOffset + 2 * MaxTabWidth then\r\n MaxTabWidth := (TabControlRect.Right - TabControlRect.Left - LeftOffset) div 2;\r\n\r\n if TabControlRect.Bottom - TabControlRect.Top < 2 * BottomOffset then\r\n BottomOffset := Max((TabControlRect.Bottom - TabControlRect.Top) div 2, 0);\r\n\r\n Assert(FDropTabControl.TabPosition in [tpBottom, tpTop],\r\n RsEDockCannotSetTabPosition);\r\n\r\n TabRect := TabControlRect;\r\n if FDropTabControl.TabPosition = tpBottom then\r\n begin\r\n Dec(TabControlRect.Bottom, BottomOffset);\r\n AlphaBlendedForm.Visible := True;\r\n AlphaBlendedForm.BoundsRect := TabControlRect;\r\n TabRect := Bounds(TabRect.Left + LeftOffset, TabRect.Bottom - BottomOffset,\r\n MaxTabWidth, BottomOffset);\r\n AlphaBlendedTab.Visible := True;\r\n AlphaBlendedTab.BoundsRect := TabRect;\r\n end\r\n else\r\n begin\r\n Inc(TabControlRect.Top, BottomOffset);\r\n AlphaBlendedForm.Visible := True;\r\n AlphaBlendedForm.BoundsRect := TabControlRect;\r\n TabRect := Bounds(TabRect.Left + LeftOffset, TabRect.Top,\r\n MaxTabWidth, BottomOffset);\r\n AlphaBlendedTab.Visible := True;\r\n AlphaBlendedTab.BoundsRect := TabRect;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJvDockVIDDragDockObject.DragFindWindow(const Pos: TPoint): THandle;\r\nbegin\r\n Result := 0;\r\nend;\r\n\r\nfunction TJvDockVIDDragDockObject.GetDropCtl: TControl;\r\nvar\r\n ARect: TRect;\r\n I: Integer;\r\nbegin\r\n Result := inherited GetDropCtl;\r\n if (Result = nil) and (TargetControl is TJvDockCustomPanel) then\r\n for I := 0 to TargetControl.DockClientCount - 1 do\r\n if TargetControl.DockClients[I].Visible then\r\n begin\r\n ARect := TJvDockCustomPanel(DragTarget).JvDockManager.GetFrameRectEx(TargetControl.DockClients[I]);\r\n if PtInRect(ARect, DragPos) then\r\n begin\r\n Result := TargetControl.DockClients[I];\r\n Exit;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJvDockVIDDragDockObject.GetSourceDockClient(Index: Integer): TControl;\r\nbegin\r\n Result := TControl(FSourceDockClientList[Index]);\r\nend;\r\n\r\nfunction TJvDockVIDDragDockObject.GetSourceDockClientCount: Integer;\r\nbegin\r\n Result := FSourceDockClientList.Count;\r\nend;\r\n\r\nprocedure TJvDockVIDDragDockObject.MouseMsg(var Msg: TMessage);\r\nvar\r\n APos: TPoint;\r\n Page: TJvDockVIDTabPageControl;\r\nbegin\r\n inherited MouseMsg(Msg);\r\n\r\n // Warren added assertions:\r\n Assert(Assigned(JvGlobalDockClient));\r\n Assert(Assigned(JvGlobalDockManager));\r\n\r\n case Msg.Msg of\r\n WM_CAPTURECHANGED:\r\n begin\r\n // Warren added Assertions:\r\n Assert(Assigned(JvGlobalDockClient.ParentForm));\r\n // Assert(Assigned(JvGlobalDockClient.ParentForm.HostDockSite));\r\n\r\n if Assigned( JvGlobalDockClient.ParentForm.HostDockSite) and\r\n (JvGlobalDockClient.ParentForm.HostDockSite is TJvDockVIDTabPageControl) then\r\n TJvDockVIDTabPageControl(JvGlobalDockClient.ParentForm.HostDockSite).Panel.MouseUp(mbLeft, [], 0, 0)\r\n else\r\n if TWinControl(JvGlobalDockManager.DragObject.DragTarget) is TJvDockVIDTabPageControl then\r\n TJvDockVIDTabPageControl(JvGlobalDockManager.DragObject.TargetControl).Panel.MouseUp(mbLeft, [], 0, 0);\r\n\r\n end;\r\n WM_MOUSEMOVE:\r\n if JvGlobalDockManager.DragObject.TargetControl is TJvDockVIDTabPageControl then\r\n begin\r\n Page := TJvDockVIDTabPageControl(JvGlobalDockManager.DragObject.TargetControl);\r\n if Page.FTempSheet <> nil then\r\n begin\r\n APos := Point(TWMMouse(Msg).XPos, TWMMouse(Msg).YPos);\r\n APos := Page.Panel.ScreenToClient(APos);\r\n Page.Panel.MouseMove([], APos.X, APos.Y);\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockVIDDragDockObject.SetOldState(const Value: TDragState);\r\nbegin\r\n FOldState := Value;\r\nend;\r\n\r\nprocedure TJvDockVIDDragDockObject.SetCurrState(const Value: TDragState);\r\nbegin\r\n FCurrState := Value;\r\nend;\r\n\r\nfunction TJvDockVIDDragDockObject.CanLeave(NewTarget: TWinControl): Boolean;\r\nbegin\r\n Result := inherited CanLeave(NewTarget);\r\nend;\r\n\r\n//=== { TJvDockVIDZone } =====================================================\r\n\r\ndestructor TJvDockVIDZone.Destroy;\r\nbegin\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJvDockVIDZone.GetSplitterLimit(IsMin: Boolean): Integer;\r\nbegin\r\n if IsMin then\r\n Result := ZoneLimit\r\n else\r\n Result := LimitBegin;\r\nend;\r\n\r\nprocedure TJvDockVIDZone.Insert(DockSize: Integer; Hide: Boolean);\r\nvar\r\n PrevShift: Integer;\r\n NextShift: Integer;\r\n TempSize: Integer;\r\n BorderSize: Integer;\r\n BeforeVisibleZone: TJvDockZone;\r\n AfterVisibleZone: TJvDockZone;\r\n BeginSize: Integer;\r\nbegin\r\n if (ParentZone <> nil) and (ParentZone.VisibleChildCount = 0) then\r\n ParentZone.Insert(ParentZone.VisibleSize, Hide);\r\n\r\n if (ParentZone = nil) or ((ParentZone = Tree.TopZone) and (ParentZone.ChildCount <= 1)) then\r\n begin\r\n Visibled := True;\r\n Exit;\r\n end;\r\n\r\n if (ParentZone <> nil) and (ParentZone.ChildZones <> nil) then\r\n BeginSize := ParentZone.ChildZones.LimitBegin\r\n else\r\n BeginSize := 0;\r\n\r\n BeforeVisibleZone := BeforeClosestVisibleZone;\r\n AfterVisibleZone := AfterClosestVisibleZone;\r\n\r\n BorderSize := TJvDockVIDTree(Tree).BorderWidth * Integer(AfterClosestVisibleZone <> nil) div 2;\r\n TempSize := ParentZone.HeightWidth[ParentZone.Orientation] + BorderSize;\r\n Visibled := False;\r\n\r\n if DockSize >= TempSize - (ParentZone.VisibleChildCount) * TJvDockVIDTree(Tree).MinSize then\r\n DockSize := (TempSize - (ParentZone.VisibleChildCount) * TJvDockVIDTree(Tree).MinSize) div 2;\r\n\r\n if DockSize < TJvDockVIDTree(Tree).MinSize then\r\n DockSize := TempSize div 2;\r\n\r\n if (BeforeVisibleZone = nil) and (AfterVisibleZone = nil) then\r\n begin\r\n PrevShift := 0;\r\n NextShift := 0;\r\n ZoneLimit := TempSize + BeginSize;\r\n end\r\n else\r\n if BeforeVisibleZone = nil then\r\n begin\r\n PrevShift := 0;\r\n NextShift := DockSize + BorderSize;\r\n ZoneLimit := DockSize + LimitBegin + BorderSize;\r\n if ParentZone.VisibleChildCount = 1 then\r\n AfterVisibleZone.ZoneLimit := TempSize + BeginSize;\r\n end\r\n else\r\n if AfterVisibleZone = nil then\r\n begin\r\n PrevShift := DockSize + BorderSize;\r\n NextShift := 0;\r\n if (ParentZone.VisibleChildCount = 1) and (ParentZone = Tree.TopZone) then\r\n BeforeVisibleZone.ZoneLimit := Tree.TopXYLimit - PrevShift\r\n else\r\n BeforeVisibleZone.ZoneLimit := BeforeVisibleZone.ZoneLimit - PrevShift;\r\n ZoneLimit := TempSize + BeginSize;\r\n end\r\n else\r\n begin\r\n PrevShift := Round((BeforeVisibleZone.ZoneLimit - BeginSize) * (DockSize + BorderSize) / TempSize);\r\n NextShift := DockSize - PrevShift;\r\n if (ParentZone.VisibleChildCount = 1) and (ParentZone = Tree.TopZone) then\r\n BeforeVisibleZone.ZoneLimit := Tree.TopXYLimit - PrevShift\r\n else\r\n BeforeVisibleZone.ZoneLimit := BeforeVisibleZone.ZoneLimit - PrevShift;\r\n ZoneLimit := BeforeVisibleZone.ZoneLimit + DockSize;\r\n end;\r\n\r\n if PrevShift <> 0 then\r\n begin\r\n with TJvDockVIDTree(Tree) do\r\n begin\r\n ReplacementZone := BeforeVisibleZone;\r\n try\r\n if (BeforeVisibleZone.ZoneLimit - BeginSize) * (BeforeVisibleZone.ZoneLimit - BeginSize + PrevShift) <> 0 then\r\n ScaleBy := (BeforeVisibleZone.ZoneLimit - BeginSize) / (BeforeVisibleZone.ZoneLimit - BeginSize + PrevShift)\r\n else\r\n ScaleBy := 1;\r\n ParentLimit := BeginSize;\r\n ShiftScaleOrientation := ParentZone.Orientation;\r\n if ScaleBy <> 1 then\r\n ForEachAt(ParentZone.ChildZones, ScaleChildZone, tskMiddle, tspChild);\r\n finally\r\n ReplacementZone := nil;\r\n end;\r\n end;\r\n\r\n if BeforeVisibleZone.LimitSize < TJvDockVIDTree(Tree).MinSize then\r\n BeforeVisibleZone.ZoneLimit := BeforeVisibleZone.LimitBegin + TJvDockVIDTree(Tree).MinSize;\r\n end;\r\n\r\n if NextShift <> 0 then\r\n with TJvDockVIDTree(Tree) do\r\n begin\r\n if (TempSize + BeginSize - LimitBegin - NextShift) * (TempSize + BeginSize - LimitBegin) <> 0 then\r\n ScaleBy := (TempSize + BeginSize - LimitBegin - NextShift) / (TempSize + BeginSize - LimitBegin)\r\n else\r\n ScaleBy := 1;\r\n ParentLimit := TempSize + BeginSize;\r\n ShiftScaleOrientation := ParentZone.Orientation;\r\n if ScaleBy <> 1 then\r\n ForEachAt(AfterVisibleZone, ScaleSiblingZone, tskForward);\r\n end;\r\n Visibled := True;\r\nend;\r\n\r\nprocedure TJvDockVIDZone.Remove(DockSize: Integer; Hide: Boolean);\r\nvar\r\n PrevShift: Integer;\r\n NextShift: Integer;\r\n TempSize: Integer;\r\n BorderSize: Integer;\r\n BeforeVisibleZone: TJvDockZone;\r\n AfterVisibleZone: TJvDockZone;\r\n BeginSize: Integer;\r\nbegin\r\n if (ParentZone <> nil) and (ParentZone.VisibleChildCount = 1) and (ParentZone <> Tree.TopZone) then\r\n ParentZone.Remove(ParentZone.LimitSize, Hide);\r\n\r\n if (ParentZone = nil) or ((ParentZone = Tree.TopZone) and (ParentZone.ChildCount <= 1)) then\r\n begin\r\n Visibled := False;\r\n Exit;\r\n end;\r\n\r\n if (ParentZone <> nil) and (ParentZone.ChildZones <> nil) then\r\n BeginSize := ParentZone.ChildZones.LimitBegin\r\n else\r\n BeginSize := 0;\r\n\r\n BeforeVisibleZone := BeforeClosestVisibleZone;\r\n AfterVisibleZone := AfterClosestVisibleZone;\r\n\r\n BorderSize := TJvDockVIDTree(Tree).BorderWidth * Integer(AfterClosestVisibleZone <> nil) div 2;\r\n TempSize := ParentZone.HeightWidth[ParentZone.Orientation] + BorderSize;\r\n\r\n if DockSize > TempSize - (ParentZone.VisibleChildCount - 1) * TJvDockVIDTree(Tree).MinSize then\r\n DockSize := TempSize - (ParentZone.VisibleChildCount - 1) * TJvDockVIDTree(Tree).MinSize;\r\n if DockSize = 0 then\r\n DockSize := TempSize div 2;\r\n\r\n Visibled := False;\r\n if (BeforeVisibleZone = nil) and (AfterVisibleZone = nil) then\r\n Exit;\r\n\r\n if BeforeVisibleZone = nil then\r\n begin\r\n PrevShift := 0;\r\n NextShift := -DockSize + BorderSize;\r\n ZoneLimit := -DockSize + BorderSize + BeginSize;\r\n end\r\n else\r\n if AfterVisibleZone = nil then\r\n begin\r\n PrevShift := -DockSize + BorderSize;\r\n NextShift := 0;\r\n BeforeVisibleZone.ZoneLimit := BeforeVisibleZone.ZoneLimit - PrevShift;\r\n ZoneLimit := TempSize + BeginSize;\r\n end\r\n else\r\n begin\r\n PrevShift := -Round((BeforeVisibleZone.ZoneLimit - BeginSize) * (DockSize + BorderSize) / (TempSize - (DockSize +\r\n BorderSize)));\r\n NextShift := -DockSize - PrevShift;\r\n BeforeVisibleZone.ZoneLimit := BeforeVisibleZone.ZoneLimit - PrevShift;\r\n ZoneLimit := BeforeVisibleZone.ZoneLimit;\r\n end;\r\n\r\n if PrevShift <> 0 then\r\n begin\r\n with TJvDockVIDTree(Tree) do\r\n begin\r\n ReplacementZone := BeforeVisibleZone;\r\n try\r\n if (BeforeVisibleZone.ZoneLimit - BeginSize) * (BeforeVisibleZone.ZoneLimit - BeginSize + PrevShift) <> 0 then\r\n ScaleBy := (BeforeVisibleZone.ZoneLimit - BeginSize) / (BeforeVisibleZone.ZoneLimit - BeginSize + PrevShift)\r\n else\r\n ScaleBy := 1;\r\n ParentLimit := BeginSize;\r\n ShiftScaleOrientation := ParentZone.Orientation;\r\n if ScaleBy <> 1 then\r\n ForEachAt(ParentZone.ChildZones, ScaleChildZone, tskMiddle, tspChild);\r\n finally\r\n ReplacementZone := nil;\r\n end;\r\n end;\r\n\r\n if BeforeVisibleZone.LimitSize < TJvDockVIDTree(Tree).MinSize then\r\n BeforeVisibleZone.ZoneLimit := BeforeVisibleZone.LimitBegin + TJvDockVIDTree(Tree).MinSize;\r\n end;\r\n\r\n if NextShift <> 0 then\r\n with TJvDockVIDTree(Tree) do\r\n begin\r\n if (TempSize + BeginSize - LimitBegin) * (TempSize + BeginSize - LimitBegin + NextShift) <> 0 then\r\n ScaleBy := (TempSize + BeginSize - LimitBegin) / (TempSize + BeginSize - LimitBegin + NextShift)\r\n else\r\n ScaleBy := 1;\r\n ParentLimit := TempSize + BeginSize;\r\n ShiftScaleOrientation := ParentZone.Orientation;\r\n if ScaleBy <> 1 then\r\n ForEachAt(AfterVisibleZone, ScaleSiblingZone, tskForward);\r\n end;\r\nend;\r\n\r\n//=== { TJvDockVIDTabServerOption } ==========================================\r\n\r\nconstructor TJvDockVIDTabServerOption.Create(ADockStyle: TJvDockObservableStyle);\r\nbegin\r\n inherited Create(ADockStyle);\r\n TabPosition := tpBottom;\r\n FActiveFont := TFont.Create;\r\n FActiveFont.OnChange := FontChanged;\r\n FActiveSheetColor := clBtnFace;\r\n FHotTrackColor := clBlue;\r\n FInactiveFont := TFont.Create;\r\n FInactiveFont.Color := clWhite;\r\n FInactiveFont.OnChange := FontChanged;\r\n FInactiveSheetColor := clBtnShadow;\r\n FShowTabImages := False;\r\n FShowCloseButtonOnGrabber := True;\r\n FShowCloseButtonOnTabs := False;\r\nend;\r\n\r\ndestructor TJvDockVIDTabServerOption.Destroy;\r\nbegin\r\n FActiveFont.Free;\r\n FInactiveFont.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvDockVIDTabServerOption.Assign(Source: TPersistent);\r\nvar\r\n Src: TJvDockVIDTabServerOption;\r\nbegin\r\n if Source is TJvDockVIDTabServerOption then\r\n begin\r\n BeginUpdate;\r\n try\r\n Src := TJvDockVIDTabServerOption(Source);\r\n\r\n ActiveFont := Src.ActiveFont;\r\n ActiveSheetColor := Src.ActiveSheetColor;\r\n HotTrackColor := Src.HotTrackColor;\r\n InactiveFont := Src.InactiveFont;\r\n InactiveSheetColor := Src.InactiveSheetColor;\r\n ShowTabImages := Src.ShowTabImages;\r\n\r\n inherited Assign(Source);\r\n finally\r\n EndUpdate;\r\n end;\r\n end\r\n else\r\n inherited Assign(Source);\r\nend;\r\n\r\nprocedure TJvDockVIDTabServerOption.FontChanged(Sender: TObject);\r\nbegin\r\n Changed;\r\nend;\r\n\r\nprocedure TJvDockVIDTabServerOption.SetActiveFont(Value: TFont);\r\nbegin\r\n FActiveFont.Assign(Value);\r\nend;\r\n\r\nprocedure TJvDockVIDTabServerOption.SetActiveSheetColor(const Value: TColor);\r\nbegin\r\n if FActiveSheetColor <> Value then\r\n begin\r\n FActiveSheetColor := Value;\r\n Changed;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockVIDTabServerOption.SetHotTrackColor(const Value: TColor);\r\nbegin\r\n if FHotTrackColor <> Value then\r\n begin\r\n FHotTrackColor := Value;\r\n Changed;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockVIDTabServerOption.SetInactiveFont(Value: TFont);\r\nbegin\r\n FInactiveFont.Assign(Value);\r\nend;\r\n\r\nprocedure TJvDockVIDTabServerOption.SetInactiveSheetColor(const Value: TColor);\r\nbegin\r\n if FInactiveSheetColor <> Value then\r\n begin\r\n FInactiveSheetColor := Value;\r\n Changed;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockVIDTabServerOption.SetShowTabImages(const Value: Boolean);\r\nbegin\r\n if FShowTabImages <> Value then\r\n begin\r\n FShowTabImages := Value;\r\n Changed;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockVIDTabServerOption.SetTabPosition(const Value: TTabPosition);\r\nbegin\r\n// if Value = tpBottom then\r\n inherited SetTabPosition(Value)\r\n// else // TabPosition property must be tpBottom.\r\n// raise Exception.CreateRes(@RsEDockTabPositionMustBetpBottom);\r\nend;\r\n\r\nprocedure TJvDockVIDTabServerOption.SetShowCloseButtonOnGrabber(\r\n const Value: Boolean);\r\nbegin\r\n if FShowCloseButtonOnGrabber <> Value then\r\n begin\r\n FShowCloseButtonOnGrabber := Value;\r\n Changed;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockVIDTabServerOption.SetShowCloseButtonOnTabs(\r\n const Value: Boolean);\r\nbegin\r\n if FShowCloseButtonOnTabs <> Value then\r\n begin\r\n FShowCloseButtonOnTabs := Value;\r\n Changed;\r\n end;\r\nend;\r\n\r\n//=== { TJvDockVIDConjoinServerOption } ======================================\r\n\r\nconstructor TJvDockVIDConjoinServerOption.Create(ADockStyle: TJvDockObservableStyle);\r\nbegin\r\n inherited Create(ADockStyle);\r\n GrabbersSize := VIDDefaultDockGrabbersSize;\r\n SplitterWidth := VIDDefaultDockSplitterWidth;\r\n FActiveFont := TFont.Create;\r\n FActiveFont.OnChange := FontChanged;\r\n FInactiveFont := TFont.Create;\r\n FInactiveFont.OnChange := FontChanged;\r\n SystemInfo := True;\r\nend;\r\n\r\ndestructor TJvDockVIDConjoinServerOption.Destroy;\r\nbegin\r\n { Make sure we unregister, can be called more than once }\r\n UnRegisterSettingChangeClient(Self);\r\n FActiveFont.Free;\r\n FInactiveFont.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvDockVIDConjoinServerOption.Assign(Source: TPersistent);\r\nvar\r\n Src: TJvDockVIDConjoinServerOption;\r\nbegin\r\n if Source is TJvDockVIDConjoinServerOption then\r\n begin\r\n BeginUpdate;\r\n try\r\n Src := TJvDockVIDConjoinServerOption(Source);\r\n\r\n TextEllipsis := Src.TextEllipsis;\r\n TextAlignment := Src.TextAlignment;\r\n InactiveTitleEndColor := Src.InactiveTitleEndColor;\r\n InactiveTitleStartColor := Src.InactiveTitleStartColor;\r\n InactiveTitleVerticalGradient := Src.InactiveTitleVerticalGradient;\r\n ActiveTitleEndColor := Src.ActiveTitleEndColor;\r\n ActiveTitleStartColor := Src.ActiveTitleStartColor;\r\n ActiveTitleVerticalGradient := Src.ActiveTitleVerticalGradient;\r\n ActiveDockGrabber := Src.ActiveDockGrabber;\r\n ActiveFont := Src.ActiveFont;\r\n InactiveFont := Src.InactiveFont;\r\n SystemInfo := Src.SystemInfo;\r\n\r\n inherited Assign(Source);\r\n finally\r\n EndUpdate;\r\n end;\r\n end\r\n else\r\n inherited Assign(Source);\r\nend;\r\n\r\nprocedure TJvDockVIDConjoinServerOption.SetActiveTitleEndColor(const Value: TColor);\r\nbegin\r\n if Value <> FActiveTitleEndColor then\r\n begin\r\n FActiveTitleEndColor := Value;\r\n // setting SystemInfo to False does not trigger a Changed call\r\n SystemInfo := False;\r\n Changed;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockVIDConjoinServerOption.SetActiveTitleStartColor(const Value: TColor);\r\nbegin\r\n if Value <> FActiveTitleStartColor then\r\n begin\r\n FActiveTitleStartColor := Value;\r\n SystemInfo := False;\r\n Changed;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockVIDConjoinServerOption.SetActiveTitleVerticalGradient(const Value: Boolean);\r\nbegin\r\n if Value <> FActiveTitleVerticalGradient then\r\n begin\r\n FActiveTitleVerticalGradient := Value;\r\n SystemInfo := False;\r\n Changed;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockVIDConjoinServerOption.SetActiveDockGrabber(\r\n const Value: Boolean);\r\nbegin\r\n if Value <> FActiveDockGrabber then\r\n begin\r\n FActiveDockGrabber := Value;\r\n SystemInfo := False;\r\n Changed;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockVIDConjoinServerOption.SetInactiveTitleEndColor(const Value: TColor);\r\nbegin\r\n if Value <> FInactiveTitleEndColor then\r\n begin\r\n FInactiveTitleEndColor := Value;\r\n SystemInfo := False;\r\n Changed;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockVIDConjoinServerOption.SetInactiveTitleStartColor(const Value: TColor);\r\nbegin\r\n if Value <> FInactiveTitleStartColor then\r\n begin\r\n FInactiveTitleStartColor := Value;\r\n SystemInfo := False;\r\n Changed;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockVIDConjoinServerOption.SetInactiveTitleVerticalGradient(const Value: Boolean);\r\nbegin\r\n if Value <> FInactiveTitleVerticalGradient then\r\n begin\r\n FInactiveTitleVerticalGradient := Value;\r\n SystemInfo := False;\r\n Changed;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockVIDConjoinServerOption.SetSystemInfo(const Value: Boolean);\r\nbegin\r\n if Value <> FSystemInfo then\r\n begin\r\n if FSystemInfo then\r\n UnRegisterSettingChangeClient(Self);\r\n FSystemInfo := Value;\r\n if FSystemInfo then\r\n begin\r\n RegisterSettingChangeClient(Self, SettingChange);\r\n SetDefaultSystemCaptionInfo;\r\n // If necessary Changed is called via SetDefaultSystemCaptionInfo\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockVIDConjoinServerOption.SetTextAlignment(\r\n const Value: TAlignment);\r\nbegin\r\n if Value <> FTextAlignment then\r\n begin\r\n FTextAlignment := Value;\r\n SystemInfo := False;\r\n Changed;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockVIDConjoinServerOption.SetTextEllipsis(const Value: Boolean);\r\nbegin\r\n if Value <> FTextEllipsis then\r\n begin\r\n FTextEllipsis := Value;\r\n SystemInfo := False;\r\n Changed;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockVIDConjoinServerOption.SetDefaultSystemCaptionInfo;\r\nvar\r\n Saved: Boolean;\r\nbegin\r\n Saved := SystemInfo;\r\n BeginUpdate;\r\n FSystemInfo := False;\r\n try\r\n UpdateDefaultSystemCaptionInfo;\r\n finally\r\n FSystemInfo := Saved;\r\n EndUpdate;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockVIDConjoinServerOption.UpdateDefaultSystemCaptionInfo;\r\nbegin\r\n ActiveTitleStartColor := JvDockGetActiveTitleBeginColor;\r\n ActiveTitleEndColor := JvDockGetActiveTitleEndColor;\r\n ActiveTitleVerticalGradient := False;\r\n InactiveTitleStartColor := JvDockGetInactiveTitleBeginColor;\r\n InactiveTitleEndColor := JvDockGetInactiveTitleEndColor;\r\n InactiveTitleVerticalGradient := False;\r\n ActiveDockGrabber := False;\r\n TextAlignment := taLeftJustify;\r\n TextEllipsis := True;\r\n ActiveFont := JvDockGetTitleFont;\r\n ActiveFont.Style := FActiveFont.Style + [fsBold];\r\n InactiveFont := FActiveFont;\r\n ActiveFont.Color := JvDockGetActiveTitleFontColor;\r\n InactiveFont.Color := JvDockGetInactiveTitleFontColor;\r\n GrabbersSize := VIDDefaultDockGrabbersSize;\r\n SplitterWidth := VIDDefaultDockSplitterWidth;\r\nend;\r\n\r\nprocedure TJvDockVIDConjoinServerOption.SetActiveFont(Value: TFont);\r\nbegin\r\n FActiveFont.Assign(Value);\r\nend;\r\n\r\nprocedure TJvDockVIDConjoinServerOption.SetInactiveFont(Value: TFont);\r\nbegin\r\n FInactiveFont.Assign(Value);\r\nend;\r\n\r\nprocedure TJvDockVIDConjoinServerOption.Changed;\r\nbegin\r\n inherited Changed;\r\n SystemInfo := SystemInfo and (GrabbersSize = VIDDefaultDockGrabbersSize) and\r\n (SplitterWidth = VIDDefaultDockSplitterWidth);\r\n TJvDockVIDStyle(DockStyle).DoSystemInfoChange(SystemInfo);\r\nend;\r\n\r\nfunction TJvDockVIDConjoinServerOption.IsNotSystemInfo: Boolean;\r\nbegin\r\n Result := not SystemInfo;\r\nend;\r\n\r\nprocedure TJvDockVIDConjoinServerOption.FontChanged(Sender: TObject);\r\nbegin\r\n // setting SystemInfo to False does not trigger a Changed call\r\n SystemInfo := False;\r\n Changed;\r\nend;\r\n\r\nprocedure TJvDockVIDConjoinServerOption.SettingChange(Sender: TObject);\r\nbegin\r\n { ?? }\r\n {DockStyle.ParentForm.Caption := '';}\r\n if SystemInfo then\r\n SetDefaultSystemCaptionInfo;\r\nend;\r\n\r\n{$IFNDEF COMPILER9_UP}\r\nfunction GetRealParentForm(Control: TControl): TCustomForm;\r\nbegin\r\n while not (Control is TCustomForm) and (Control.Parent <> nil) do\r\n Control := Control.Parent;\r\n if Control is TCustomForm then\r\n Result := TCustomForm(Control)\r\n else\r\n Result := nil;\r\nend;\r\n{$ENDIF !COMPILER9_UP}\r\n\r\n{$IFNDEF COMPILER9_UP}\r\ntype\r\n TWinControlAccessProtected = class(TWinControl);\r\n{$ENDIF !COMPILER9_UP}\r\n\r\nfunction GetDockManager(Control: TWinControl; out ADockManager: IDockManager): Boolean;\r\nbegin\r\n ADockManager := nil;\r\n {$IFDEF COMPILER9_UP}\r\n with Control do\r\n if UseDockManager then\r\n ADockManager := DockManager;\r\n {$ELSE}\r\n with TWinControlAccessProtected(Control) do\r\n if UseDockManager then\r\n ADockManager := DockManager;\r\n {$ENDIF COMPILER9_UP}\r\n Result := Assigned(ADockManager);\r\nend;\r\n\r\nprocedure TJvDockVIDTree.InvalidateDockSite(const Client: TControl);\r\nvar\r\n ParentForm: TCustomForm;\r\n Rect: TRect;\r\n ADockManager: IDockManager;\r\nbegin\r\n {$IFDEF COMPILER9_UP}\r\n ParentForm := GetParentForm(Client, False);\r\n {$ELSE}\r\n ParentForm := GetRealParentForm(Client);\r\n {$ENDIF COMPILER9_UP}\r\n { Just invalidate the parent form's rect in the HostDockSite\r\n so that we can \"follow focus\" on docked items. }\r\n if (ParentForm <> nil) and (ParentForm.HostDockSite <> nil) then\r\n begin\r\n if GetDockManager(ParentForm.HostDockSite, ADockManager) then\r\n begin\r\n ADockManager.GetControlBounds(ParentForm, Rect);\r\n InvalidateRect(ParentForm.HostDockSite.Handle, @Rect, False);\r\n end;\r\n end;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvDockVIDVCStyle.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvDockVIDVCStyle.pas, released on 2003-12-31.\r\n\r\nThe Initial Developer of the Original Code is luxiaoban.\r\nPortions created by luxiaoban are Copyright (C) 2002,2003 luxiaoban.\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\ndevedit\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvDockVIDVCStyle.pas 13278 2012-03-21 08:51:44Z obones $\r\n\r\nunit JvDockVIDVCStyle;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, Messages, Classes, Controls, Graphics, ComCtrls, ImgList,\r\n JvDockControlForm, JvDockSupportControl, JvDockTree, JvDockAdvTree;\r\n\r\nconst\r\n VIDDefaultDockGrabbersSize = 18;\r\n VIDDefaultDockSplitterWidth = 4;\r\n HTEXPAND = 31;\r\n\r\ntype\r\n TJvDockVIDVCConjoinServerOption = class(TJvDockBasicConjoinServerOption)\r\n private\r\n FTextEllipsis: Boolean;\r\n FTextAlignment: TAlignment;\r\n FInactiveTitleEndColor: TColor;\r\n FInactiveTitleStartColor: TColor;\r\n FActiveTitleEndColor: TColor;\r\n FActiveTitleStartColor: TColor;\r\n FSystemInfo: Boolean;\r\n FActiveFont: TFont;\r\n FInactiveFont: TFont;\r\n procedure SetActiveTitleEndColor(const Value: TColor);\r\n procedure SetActiveTitleStartColor(const Value: TColor);\r\n procedure SetInactiveTitleEndColor(const Value: TColor);\r\n procedure SetInactiveTitleStartColor(const Value: TColor);\r\n procedure SetTextAlignment(const Value: TAlignment);\r\n procedure SetTextEllipsis(const Value: Boolean);\r\n procedure SetSystemInfo(const Value: Boolean);\r\n procedure SetActiveFont(Value: TFont);\r\n procedure SetInactiveFont(Value: TFont);\r\n protected\r\n procedure FontChanged(Sender: TObject);\r\n function IsNotSystemInfo: Boolean;\r\n procedure SettingChange(Sender: TObject);\r\n procedure Changed; override;\r\n procedure UpdateDefaultSystemCaptionInfo; virtual;\r\n procedure SetDefaultSystemCaptionInfo;\r\n public\r\n constructor Create(ADockStyle: TJvDockObservableStyle); override;\r\n destructor Destroy; override;\r\n procedure Assign(Source: TPersistent); override;\r\n published\r\n { (rb) these properties are all *not* used. }\r\n property ActiveFont: TFont read FActiveFont write SetActiveFont stored IsNotSystemInfo;\r\n property InactiveFont: TFont read FInactiveFont write SetInactiveFont stored IsNotSystemInfo;\r\n property TextAlignment: TAlignment read FTextAlignment write SetTextAlignment default taLeftJustify;\r\n property ActiveTitleStartColor: TColor read FActiveTitleStartColor write SetActiveTitleStartColor stored IsNotSystemInfo;\r\n property ActiveTitleEndColor: TColor read FActiveTitleEndColor write SetActiveTitleEndColor stored IsNotSystemInfo;\r\n property InactiveTitleStartColor: TColor read FInactiveTitleStartColor write SetInactiveTitleStartColor stored IsNotSystemInfo;\r\n property InactiveTitleEndColor: TColor read FInactiveTitleEndColor write SetInactiveTitleEndColor stored IsNotSystemInfo;\r\n property TextEllipsis: Boolean read FTextEllipsis write SetTextEllipsis default True;\r\n property SystemInfo: Boolean read FSystemInfo write SetSystemInfo default True;\r\n property GrabbersSize default VIDDefaultDockGrabbersSize;\r\n property SplitterWidth default VIDDefaultDockSplitterWidth;\r\n end;\r\n\r\n TJvDockZoneSizeStyle = (zssMinimum, zssNormal, zssMaximum);\r\n\r\n TJvDockVIDVCTabServerOption = class(TJvDockBasicTabServerOption)\r\n private\r\n FActiveFont: TFont;\r\n FActiveSheetColor: TColor;\r\n FHotTrackColor: TColor;\r\n FInactiveFont: TFont;\r\n FInactiveSheetColor: TColor;\r\n FShowTabImages: Boolean;\r\n procedure SetActiveFont(Value: TFont);\r\n procedure SetActiveSheetColor(const Value: TColor);\r\n procedure SetHotTrackColor(const Value: TColor);\r\n procedure SetInactiveFont(Value: TFont);\r\n procedure SetInactiveSheetColor(const Value: TColor);\r\n procedure SetShowTabImages(const Value: Boolean);\r\n protected\r\n procedure FontChanged(Sender: TObject);\r\n public\r\n constructor Create(ADockStyle: TJvDockObservableStyle); override;\r\n destructor Destroy; override;\r\n procedure Assign(Source: TPersistent); override;\r\n procedure SetTabPosition(const Value: TTabPosition); override;\r\n published\r\n property ActiveSheetColor: TColor read FActiveSheetColor write SetActiveSheetColor;\r\n property InactiveSheetColor: TColor read FInactiveSheetColor write SetInactiveSheetColor default clBtnShadow;\r\n property ActiveFont: TFont read FActiveFont write SetActiveFont;\r\n property InactiveFont: TFont read FInactiveFont write SetInactiveFont;\r\n property HotTrackColor: TColor read FHotTrackColor write SetHotTrackColor default clBlue;\r\n property ShowTabImages: Boolean read FShowTabImages write SetShowTabImages default False;\r\n property TabPosition default tpBottom;\r\n end;\r\n\r\n TJvDockSystemInfoChange = procedure(Value: Boolean) of object;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvDockVIDVCStyle = class(TJvDockAdvStyle)\r\n private\r\n FSystemInfoChange: TJvDockSystemInfoChange;\r\n protected\r\n function DockClientWindowProc(DockClient: TJvDockClient; var Msg: TMessage): Boolean; override;\r\n procedure FormDockDrop(DockClient: TJvDockClient;\r\n Source: TJvDockDragDockObject; X, Y: Integer); override;\r\n procedure FormGetSiteInfo(Source: TJvDockDragDockObject; DockClient: TJvDockClient;\r\n Client: TControl; var InfluenceRect: TRect; MousePos: TPoint;\r\n var CanDock: Boolean); override;\r\n procedure FormDockOver(DockClient: TJvDockClient; Source: TJvDockDragDockObject; X, Y: Integer;\r\n State: TDragState; var Accept: Boolean); override;\r\n procedure FormStartDock(DockClient: TJvDockClient;\r\n var Source: TJvDockDragDockObject); override;\r\n procedure FormGetDockEdge(DockClient: TJvDockClient; Source: TJvDockDragDockObject;\r\n MousePos: TPoint; var DropAlign: TAlign); override;\r\n procedure DoSystemInfoChange(Value: Boolean);\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n procedure SetDockBaseControl(IsCreate: Boolean; DockBaseControl: TJvDockBaseControl); override;\r\n published\r\n property SystemInfoChange: TJvDockSystemInfoChange read FSystemInfoChange\r\n write FSystemInfoChange;\r\n property ConjoinServerOption;\r\n property TabServerOption;\r\n end;\r\n\r\n TJvDockVIDVCSplitter = class(TJvDockSplitter)\r\n protected\r\n procedure Paint; override;\r\n end;\r\n\r\n TJvDockVIDVCPanel = class(TJvDockAdvPanel)\r\n protected\r\n procedure CustomGetSiteInfo(Source: TJvDockDragDockObject;\r\n Client: TControl; var InfluenceRect: TRect; MousePos: TPoint;\r\n var CanDock: Boolean); override;\r\n procedure CustomStartDock(var Source: TJvDockDragDockObject); override;\r\n procedure CustomDockDrop(Source: TJvDockDragDockObject; X, Y: Integer); override;\r\n procedure CustomDockOver(Source: TJvDockDragDockObject; X, Y: Integer;\r\n State: TDragState; var Accept: Boolean); override;\r\n procedure CustomGetDockEdge(Source: TJvDockDragDockObject; MousePos: TPoint;\r\n var DropAlign: TAlign); override;\r\n public\r\n procedure DockDrop(Source: TDragDockObject; X, Y: Integer); override;\r\n procedure UpdateCaption(Exclude: TControl); override;\r\n end;\r\n\r\n TJvDockVIDVCConjoinPanel = class(TJvDockAdvConjoinPanel)\r\n protected\r\n procedure CustomGetSiteInfo(Source: TJvDockDragDockObject;\r\n Client: TControl; var InfluenceRect: TRect; MousePos: TPoint;\r\n var CanDock: Boolean); override;\r\n procedure CustomDockOver(Source: TJvDockDragDockObject; X, Y: Integer;\r\n State: TDragState; var Accept: Boolean); override;\r\n procedure CustomGetDockEdge(Source: TJvDockDragDockObject; MousePos: TPoint; var DropAlign: TAlign); override;\r\n function CustomUnDock(Source: TJvDockDragDockObject; NewTarget: TWinControl; Client: TControl): Boolean; override;\r\n procedure CustomDockDrop(Source: TJvDockDragDockObject; X, Y: Integer); override;\r\n public\r\n procedure UpdateCaption(Exclude: TControl); override;\r\n procedure DockDrop(Source: TDragDockObject; X, Y: Integer); override;\r\n end;\r\n\r\n TJvDockVIDVCZone = class(TJvDockAdvZone)\r\n private\r\n FExpandButtonDown: Boolean;\r\n FZoneSizeStyle: TJvDockZoneSizeStyle;\r\n procedure DoSetChildSizeStyle(ZoneSizeStyle: TJvDockZoneSizeStyle);\r\n protected\r\n function GetSplitterLimit(IsMin: Boolean): Integer; override;\r\n public\r\n property ExpandButtonDown: Boolean read FExpandButtonDown write FExpandButtonDown;\r\n property ZoneSizeStyle: TJvDockZoneSizeStyle read FZoneSizeStyle write FZoneSizeStyle;\r\n procedure Insert(DockSize: Integer; Hide: Boolean); override;\r\n procedure Remove(DockSize: Integer; Hide: Boolean); override;\r\n end;\r\n\r\n TJvDockVIDVCTree = class(TJvDockAdvTree)\r\n private\r\n FDropOnZone: TJvDockZone;\r\n FExpandBtnZone: TJvDockVIDVCZone;\r\n FLockDropDockSizeCount: Integer;\r\n FCaptionLeftOffset: Integer;\r\n FCaptionRightOffset: Integer;\r\n procedure LockDropDockSize;\r\n procedure UnlockDropDockSize;\r\n procedure SetCaptionLeftOffset(const Value: Integer);\r\n procedure SetCaptionRightOffset(const Value: Integer);\r\n protected\r\n procedure DoLButtonUp(var Msg: TWMMouse;\r\n var Zone: TJvDockZone; out HTFlag: Integer); override;\r\n procedure ResetDockZoneSizeStyle(Parent: TJvDockZone;\r\n ZoneSizeStyle: TJvDockZoneSizeStyle; Exclude: TJvDockZone);\r\n function GetLeftGrabbersHTFlag(const MousePos: TPoint;\r\n out HTFlag: Integer; Zone: TJvDockZone): TJvDockZone; override;\r\n function GetTopGrabbersHTFlag(const MousePos: TPoint;\r\n out HTFlag: Integer; Zone: TJvDockZone): TJvDockZone; override;\r\n\r\n procedure DoMouseMove(var Msg: TWMMouse;\r\n var Zone: TJvDockZone; out HTFlag: Integer); override;\r\n function DoLButtonDown(var Msg: TWMMouse;\r\n var Zone: TJvDockZone; out HTFlag: Integer): Boolean; override;\r\n\r\n procedure InsertControlFromConjoinHost(Control: TControl;\r\n InsertAt: TAlign; DropCtl: TControl); virtual;\r\n procedure IgnoreZoneInfor(Stream: TMemoryStream); virtual;\r\n// procedure AdjustDockRect(Control: TControl; var ARect: TRect); override;\r\n procedure WindowProc(var Msg: TMessage); override;\r\n procedure SplitterMouseUp; override;\r\n procedure GetSiteInfo(Client: TControl;\r\n var InfluenceRect: TRect; MousePos: TPoint; var CanDock: Boolean); override;\r\n procedure InsertControl(Control: TControl; InsertAt: TAlign;\r\n DropCtl: TControl); override;\r\n procedure InsertSibling(NewZone, SiblingZone: TJvDockZone;\r\n InsertLast, Update: Boolean); override;\r\n procedure InsertNewParent(NewZone, SiblingZone: TJvDockZone;\r\n ParentOrientation: TDockOrientation; InsertLast, Update: Boolean); override;\r\n procedure DrawDockGrabber(Control: TWinControl; const ARect: TRect); override;\r\n procedure DrawSplitterRect(const ARect: TRect); override;\r\n procedure PaintDockGrabberRect(Canvas: TCanvas; Control: TControl;\r\n const ARect: TRect); virtual;\r\n procedure DrawCloseButton(Canvas: TCanvas; Zone: TJvDockZone;\r\n Left, Top: Integer); virtual;\r\n procedure ResetBounds(Force: Boolean); override;\r\n procedure DrawDockSiteRect; override;\r\n{ procedure PositionDockRect(Client, DropCtl: TControl; DropAlign: TAlign;\r\n var DockRect: TRect); override;}\r\n function GetDockEdge(DockRect: TRect; MousePos: TPoint;\r\n var DropAlign: TAlign; Control: TControl): TControl; override;\r\n procedure RemoveZone(Zone: TJvDockZone; Hide: Boolean = True); override;\r\n procedure GetCaptionRect(var Rect: TRect); override;\r\n property CaptionLeftOffset: Integer read FCaptionLeftOffset write SetCaptionLeftOffset;\r\n property CaptionRightOffset: Integer read FCaptionRightOffset write SetCaptionRightOffset;\r\n public\r\n constructor Create(DockSite: TWinControl; DockZoneClass: TJvDockZoneClass; ADockStyle: TJvDockObservableStyle); override;\r\n end;\r\n\r\n TJvDockVIDVCTabPageControl = class;\r\n\r\n TJvDockVIDVCTabSheet = class(TJvDockTabSheet)\r\n private\r\n FTabWidth: Integer;\r\n FShowTabWidth: Integer;\r\n FIsSourceDockClient: Boolean;\r\n // FZoneSizeStyle: TJvDockZoneSizeStyle;\r\n procedure SetTabWidth(const Value: Integer);\r\n procedure WMSetText(var Msg: TMessage); message WM_SETTEXT;\r\n procedure SetSheetSort(const CaptionStr: string);\r\n protected\r\n procedure SetPageControl(APageControl: TJvDockPageControl); override;\r\n property TabWidth: Integer read FTabWidth write SetTabWidth;\r\n property ShowTabWidth: Integer read FShowTabWidth;\r\n procedure Loaded; override;\r\n procedure UpdateTabShowing; override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n published\r\n property BorderWidth;\r\n property Caption;\r\n property DragMode;\r\n property Enabled;\r\n property Font;\r\n property Height stored False;\r\n property Highlighted;\r\n property ImageIndex;\r\n property Left stored False;\r\n property Constraints;\r\n property PageIndex;\r\n property ParentFont;\r\n property ParentShowHint;\r\n property PopupMenu;\r\n property ShowHint;\r\n property TabVisible;\r\n property Top stored False;\r\n property Visible stored False;\r\n property Width stored False;\r\n property OnContextPopup;\r\n property OnDragDrop;\r\n property OnDragOver;\r\n property OnEndDrag;\r\n property OnEnter;\r\n property OnExit;\r\n property OnHide;\r\n property OnMouseDown;\r\n property OnMouseMove;\r\n property OnMouseUp;\r\n property OnResize;\r\n property OnShow;\r\n property OnStartDrag;\r\n end;\r\n\r\n TJvDockTabPanel = class(TCustomControl)\r\n private\r\n FPage: TJvDockVIDVCTabPageControl;\r\n FActiveSheetColor: TColor;\r\n FHotTrackColor: TColor;\r\n FActiveFont: TFont;\r\n FInactiveFont: TFont;\r\n FTabLeftOffset: Integer;\r\n FTabRightOffset: Integer;\r\n FTabTopOffset: Integer;\r\n FTabBottomOffset: Integer;\r\n FCaptionLeftOffset: Integer;\r\n FCaptionRightOffset: Integer;\r\n FCaptionTopOffset: Integer;\r\n FTabSplitterWidth: Integer;\r\n FTabHeight: Integer;\r\n FSortList: TList;\r\n FSelectSheet: TJvDockVIDVCTabSheet;\r\n FTempPages: TList;\r\n FSelectHotIndex: Integer;\r\n FShowTabImages: Boolean;\r\n procedure SetPage(const Value: TJvDockVIDVCTabPageControl);\r\n function GetTotalTabWidth: Integer;\r\n procedure SetTotalTabWidth(const Value: Integer);\r\n function GetMinTabWidth: TJvDockTabSheet;\r\n function GetMaxTabWidth: TJvDockTabSheet;\r\n procedure SetTabBottomOffset(const Value: Integer);\r\n procedure SetTabLeftOffset(const Value: Integer);\r\n procedure SetTabRightOffset(const Value: Integer);\r\n procedure SetTabTopOffset(const Value: Integer);\r\n procedure SetCaptionLeftOffset(const Value: Integer);\r\n procedure SetCaptionRightOffset(const Value: Integer);\r\n procedure SetCaptionTopOffset(const Value: Integer);\r\n procedure SetTabSplitterWidth(const Value: Integer);\r\n function GetSorts(Index: Integer): TJvDockVIDVCTabSheet;\r\n function GetPanelHeight: Integer;\r\n function GetPanelWidth: Integer;\r\n procedure SetPanelHeight(const Value: Integer);\r\n function FindSheetWithPos(cX, cY, cTopOffset, cBottomOffset: Integer): Integer;\r\n function GetDockClientFromPageIndex(Index: Integer): TControl;\r\n procedure CMMouseLeave(var Msg: TMessage); message CM_MOUSELEAVE;\r\n procedure SetShowTabImages(const Value: Boolean);\r\n procedure SetTabHeight(const Value: Integer);\r\n protected\r\n procedure Paint; override;\r\n procedure MouseDown(Button: TMouseButton; Shift: TShiftState;\r\n X, Y: Integer); override;\r\n procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;\r\n procedure MouseUp(Button: TMouseButton; Shift: TShiftState;\r\n X, Y: Integer); override;\r\n function GetPageIndexFromMousePos(X, Y: Integer): Integer; virtual;\r\n procedure SetShowTabWidth;\r\n property TotalTabWidth: Integer read GetTotalTabWidth write SetTotalTabWidth;\r\n property MinTabWidth: TJvDockTabSheet read GetMinTabWidth;\r\n property MaxTabWidth: TJvDockTabSheet read GetMaxTabWidth;\r\n property TabLeftOffset: Integer read FTabLeftOffset write SetTabLeftOffset default 5;\r\n property TabRightOffset: Integer read FTabRightOffset write SetTabRightOffset default 5;\r\n property TabTopOffset: Integer read FTabTopOffset write SetTabTopOffset default 2;\r\n property TabBottomOffset: Integer read FTabBottomOffset write SetTabBottomOffset default 3;\r\n property TabSplitterWidth: Integer read FTabSplitterWidth write SetTabSplitterWidth default 2;\r\n property CaptionTopOffset: Integer read FCaptionTopOffset write SetCaptionTopOffset default 0;\r\n property CaptionLeftOffset: Integer read FCaptionLeftOffset write SetCaptionLeftOffset default 5;\r\n property CaptionRightOffset: Integer read FCaptionRightOffset write SetCaptionRightOffset default 5;\r\n property Sorts[Index: Integer]: TJvDockVIDVCTabSheet read GetSorts;\r\n property PanelHeight: Integer read GetPanelHeight write SetPanelHeight;\r\n property PanelWidth: Integer read GetPanelWidth;\r\n property TabHeight: Integer read FTabHeight write SetTabHeight;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n procedure Resize; override;\r\n procedure DeleteSorts(Sheet: TJvDockVIDVCTabSheet);\r\n property Page: TJvDockVIDVCTabPageControl read FPage write SetPage;\r\n property SelectSheet: TJvDockVIDVCTabSheet read FSelectSheet write FSelectSheet;\r\n property ShowTabImages: Boolean read FShowTabImages write SetShowTabImages;\r\n end;\r\n\r\n TJvDockTabPanelClass = class of TJvDockTabPanel;\r\n\r\n TJvDockVIDVCTabPageControl = class(TJvDockAdvTabPageControl)\r\n private\r\n FTabPanelClass: TJvDockTabPanelClass;\r\n FPanel: TJvDockTabPanel;\r\n FTempSheet: TJvDockVIDVCTabSheet;\r\n FTabImageList: TCustomImageList;\r\n procedure SetActiveSheetColor(const Value: TColor);\r\n procedure SetInactiveSheetColor(const Value: TColor);\r\n procedure SetTabBottomOffset(const Value: Integer);\r\n procedure SetTabLeftOffset(const Value: Integer);\r\n procedure SetTabRightOffset(const Value: Integer);\r\n procedure SetTabTopOffset(const Value: Integer);\r\n procedure SetActiveFont(Value: TFont);\r\n procedure SetInactiveFont(Value: TFont);\r\n procedure SetHotTrackColor(const Value: TColor);\r\n function GetTabBottomOffset: Integer;\r\n function GetTabLeftOffset: Integer;\r\n function GetTabRightOffset: Integer;\r\n function GetTabTopOffset: Integer;\r\n function GetInactiveSheetColor: TColor;\r\n function GetActiveSheetColor: TColor;\r\n function GetActiveFont: TFont;\r\n function GetInactiveFont: TFont;\r\n function GetVisibleSheetCount: Integer;\r\n function GetHotTrackColor: TColor;\r\n function GetShowTabImages: Boolean;\r\n procedure SetShowTabImages(const Value: Boolean);\r\n function GetPage(Index: Integer): TJvDockVIDVCTabSheet;\r\n function GetActiveVIDPage: TJvDockVIDVCTabSheet;\r\n procedure SetActiveVIDPage(const Value: TJvDockVIDVCTabSheet);\r\n protected\r\n procedure AdjustClientRect(var Rect: TRect); override;\r\n procedure CreatePanel; virtual;\r\n procedure Change; override;\r\n procedure CustomDockOver(Source: TJvDockDragDockObject; X, Y: Integer; State: TDragState;\r\n var Accept: Boolean); override;\r\n procedure CustomGetSiteInfo(Source: TJvDockDragDockObject; Client: TControl; var InfluenceRect: TRect;\r\n MousePos: TPoint; var CanDock: Boolean); override;\r\n procedure CustomDockDrop(Source: TJvDockDragDockObject; X, Y: Integer); override;\r\n procedure CustomGetDockEdge(Source: TJvDockDragDockObject; MousePos: TPoint; var DropAlign: TAlign); override;\r\n function CustomUnDock(Source: TJvDockDragDockObject; NewTarget: TWinControl; Client: TControl): Boolean; override;\r\n procedure DrawTab(TabIndex: Integer; const Rect: TRect; Active: Boolean); override;\r\n procedure CreateParams(var Params: TCreateParams); override;\r\n function GetDockClientFromMousePos(MousePos: TPoint): TControl; override;\r\n procedure Paint; override;\r\n procedure SetActivePage(Page: TJvDockTabSheet); override;\r\n procedure SetTabHeight(Value: Smallint); override;\r\n procedure SetTabPosition(Value: TTabPosition); override;\r\n procedure CreateWnd; override;\r\n procedure Loaded; override;\r\n procedure SetHotTrack(Value: Boolean); override;\r\n procedure SetImages(Value: TCustomImageList); override;\r\n property TabPanelClass: TJvDockTabPanelClass read FTabPanelClass write FTabPanelClass;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n procedure AfterConstruction; override;\r\n property ActiveVIDPage: TJvDockVIDVCTabSheet read GetActiveVIDPage write SetActiveVIDPage;\r\n destructor Destroy; override;\r\n procedure DockDrop(Source: TDragDockObject; X, Y: Integer); override;\r\n procedure UpdateCaption(Exclude: TControl); override;\r\n procedure Resize; override;\r\n property Pages[Index: Integer]: TJvDockVIDVCTabSheet read GetPage;\r\n property Panel: TJvDockTabPanel read FPanel;\r\n property TempSheet: TJvDockVIDVCTabSheet read FTempSheet write FTempSheet;\r\n property VisibleSheetCount: Integer read GetVisibleSheetCount;\r\n published\r\n property ActiveSheetColor: TColor read GetActiveSheetColor write SetActiveSheetColor;\r\n property InactiveSheetColor: TColor read GetInactiveSheetColor write SetInactiveSheetColor;\r\n property TabLeftOffset: Integer read GetTabLeftOffset write SetTabLeftOffset default 5;\r\n property TabRightOffset: Integer read GetTabRightOffset write SetTabRightOffset default 5;\r\n property TabTopOffset: Integer read GetTabTopOffset write SetTabTopOffset default 2;\r\n property TabBottomOffset: Integer read GetTabBottomOffset write SetTabBottomOffset default 3;\r\n property ActiveFont: TFont read GetActiveFont write SetActiveFont;\r\n property InactiveFont: TFont read GetInactiveFont write SetInactiveFont;\r\n property HotTrackColor: TColor read GetHotTrackColor write SetHotTrackColor;\r\n property ShowTabImages: Boolean read GetShowTabImages write SetShowTabImages;\r\n property ActivePage;\r\n property Align;\r\n property Anchors;\r\n property BiDiMode;\r\n property Constraints;\r\n property DockSite;\r\n property DragCursor;\r\n property DragKind;\r\n property DragMode;\r\n property Enabled;\r\n property Font;\r\n property HotTrack;\r\n property Images;\r\n property MultiLine;\r\n property OwnerDraw;\r\n property ParentBiDiMode;\r\n property ParentFont;\r\n property ParentShowHint;\r\n property PopupMenu;\r\n property RaggedRight;\r\n property ScrollOpposite;\r\n property ShowHint;\r\n property Style;\r\n property TabHeight;\r\n property TabIndex;\r\n property TabOrder;\r\n property TabPosition;\r\n property TabStop;\r\n property TabWidth;\r\n property Visible;\r\n property OnChange;\r\n property OnChanging;\r\n property OnContextPopup;\r\n property OnDockDrop;\r\n property OnDockOver;\r\n property OnDragDrop;\r\n property OnDragOver;\r\n property OnDrawTab;\r\n property OnEndDock;\r\n property OnEndDrag;\r\n property OnEnter;\r\n property OnExit;\r\n property OnGetImageIndex;\r\n property OnGetSiteInfo;\r\n property OnMouseDown;\r\n property OnMouseMove;\r\n property OnMouseUp;\r\n property OnResize;\r\n property OnStartDock;\r\n property OnStartDrag;\r\n property OnUnDock;\r\n end;\r\n\r\n TJvDockVIDVCDragDockObject = class(TJvDockDragDockObject)\r\n private\r\n FOldDropAlign: TAlign;\r\n FCurrState: TDragState;\r\n FOldState: TDragState;\r\n FOldTarget: Pointer;\r\n FSourceDockClientList: TList;\r\n FDropTabControl: TJvDockVIDVCTabPageControl;\r\n FIsTabDockOver: Boolean;\r\n FErase: Boolean;\r\n function GetSourceDockClient(Index: Integer): TControl;\r\n function GetSourceDockClientCount: Integer;\r\n procedure SetOldState(const Value: TDragState);\r\n procedure SetCurrState(const Value: TDragState);\r\n protected\r\n procedure GetBrush_PenSize_DrawRect(var ABrush: TBrush;\r\n var PenSize: Integer; var DrawRect: TRect; Erase: Boolean); override;\r\n procedure MouseMsg(var Msg: TMessage); override;\r\n procedure DefaultDockImage(Erase: Boolean); override;\r\n function CanLeave(NewTarget: TWinControl): Boolean; override;\r\n public\r\n constructor Create(AControl: TControl); override;\r\n destructor Destroy; override;\r\n function DragFindWindow(const Pos: TPoint): THandle; override;\r\n function GetDropCtl: TControl; override;\r\n property SourceDockClients[Index: Integer]: TControl read GetSourceDockClient;\r\n property SourceDockClientCount: Integer read GetSourceDockClientCount;\r\n property CurrState: TDragState read FCurrState write SetCurrState;\r\n property OldState: TDragState read FOldState write SetOldState;\r\n end;\r\n\r\nprocedure PaintGradientBackground(Canvas: TCanvas; ARect: TRect; StartColor, EndColor: TColor);\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvDockVIDVCStyle.pas $';\r\n Revision: '$Revision: 13278 $';\r\n Date: '$Date: 2012-03-21 09:51:44 +0100 (mer. 21 mars 2012) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n Types,\r\n {$IFDEF JVCLThemesEnabled}\r\n JvThemes,\r\n {$ENDIF JVCLThemesEnabled}\r\n SysUtils, Math, Forms, ExtCtrls,\r\n JvDockSupportProc, JvDockGlobals;\r\n\r\ntype\r\n TWinControlAccessProtected = class(TWinControl);\r\n\r\n// (rom) such global variables are problematic\r\nvar\r\n gi_DockRect: TRect;\r\n\r\n{ (rb) Compare to PaintGradientBackground in JvDockVIDStyle.pas }\r\nprocedure PaintGradientBackground(Canvas: TCanvas; ARect: TRect;\r\n StartColor, EndColor: TColor);\r\nconst\r\n D = 256;\r\nvar\r\n X, C1, C2, R1, G1, B1, W: Integer;\r\n DR, DG, DB, DH: Real;\r\n\r\n procedure InitRGBValues(C1, C2: Integer);\r\n begin\r\n R1 := GetRValue(C1);\r\n G1 := GetGValue(C1);\r\n B1 := GetBValue(C1);\r\n DR := (GetRValue(C2) - R1) / D;\r\n DG := (GetGValue(C2) - G1) / D;\r\n DB := (GetBValue(C2) - B1) / D;\r\n end;\r\n\r\nbegin\r\n with Canvas do\r\n begin\r\n Lock;\r\n try\r\n Brush.Style := bsSolid;\r\n\r\n { !! GetRValue etc. assume that the input param is a RGB value thus\r\n NO system color, such as clWindowText etc. }\r\n C1 := ColorToRGB(StartColor);\r\n C2 := ColorToRGB(EndColor);\r\n\r\n if C1 <> C2 then\r\n begin\r\n InitRGBValues(C1, C2);\r\n\r\n DH := (ARect.Right - ARect.Left) / D;\r\n for X := 0 to 255 do\r\n begin\r\n Brush.Color := RGB(R1 + Round(DR * X), G1 + Round(DG * X),\r\n B1 + Round(DB * X));\r\n if ARect.Right <= ARect.Left + Round((X + 1) * DH) then\r\n W := ARect.Right\r\n else\r\n W := ARect.Left + Round((X + 1) * DH);\r\n FillRect(Classes.Rect(ARect.Left + Round(X * DH), ARect.Top, W, ARect.Bottom))\r\n end;\r\n end\r\n else\r\n begin\r\n Brush.Color := StartColor;\r\n FillRect(ARect);\r\n end;\r\n finally\r\n Unlock;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure AssignList(FromList, ToList: TList);\r\nvar\r\n I: Integer;\r\nbegin\r\n ToList.Clear;\r\n for I := 0 to FromList.Count - 1 do\r\n ToList.Add(FromList[I]);\r\nend;\r\n\r\nfunction ComputeVIDDockingRect(Target, Control: TControl; var DockRect: TRect; MousePos: TPoint): TAlign;\r\nvar\r\n DockTopRect: TRect;\r\n DockLeftRect: TRect;\r\n DockBottomRect: TRect;\r\n DockRightRect: TRect;\r\n DockCenterRect: TRect;\r\n DockTabRect: TRect;\r\nbegin\r\n Result := alNone;\r\n if Target = nil then\r\n Exit;\r\n\r\n with Target do\r\n begin\r\n DockLeftRect.TopLeft := Point(0, 0);\r\n DockLeftRect.BottomRight := Point(ClientWidth div 5, ClientHeight);\r\n\r\n DockTopRect.TopLeft := Point(ClientWidth div 5, 0);\r\n DockTopRect.BottomRight := Point(ClientWidth div 5 * 4, ClientHeight div 5);\r\n\r\n DockRightRect.TopLeft := Point(ClientWidth div 5 * 4, 0);\r\n DockRightRect.BottomRight := Point(ClientWidth, ClientHeight);\r\n\r\n if Target is TJvDockCustomTabControl then\r\n begin\r\n DockBottomRect.TopLeft := Point(ClientWidth div 5, ClientWidth div 5 * 4);\r\n DockBottomRect.BottomRight := Point(ClientWidth div 5 * 4, ClientHeight - JvDockGetSysCaptionHeight);\r\n end\r\n else\r\n begin\r\n DockBottomRect.TopLeft := Point(0, ClientHeight div 5 * 4);\r\n DockBottomRect.BottomRight := Point(ClientWidth, ClientHeight);\r\n end;\r\n\r\n DockCenterRect.TopLeft := Point(0, -JvDockGetSysCaptionHeight);\r\n DockCenterRect.BottomRight := Point(ClientWidth, 0);\r\n\r\n if Target is TJvDockCustomTabControl then\r\n begin\r\n DockTabRect.TopLeft := Point(0, ClientHeight - JvDockGetSysCaptionHeight);\r\n DockTabRect.BottomRight := Point(ClientWidth, ClientHeight);\r\n end\r\n else\r\n DockTabRect := Classes.Rect(0, 0, 0, 0);\r\n\r\n if PtInRect(DockCenterRect, MousePos) or\r\n PtInRect(DockTabRect, MousePos) then\r\n begin\r\n Result := alClient;\r\n DockRect := DockCenterRect;\r\n DockRect.BottomRight := Point(ClientWidth, ClientHeight);\r\n end\r\n else\r\n if PtInRect(DockLeftRect, MousePos) then\r\n begin\r\n Result := alLeft;\r\n DockRect := DockLeftRect;\r\n DockRect.Right := Min(ClientWidth div 2, Control.ClientWidth);\r\n end\r\n else\r\n if PtInRect(DockTopRect, MousePos) then\r\n begin\r\n Result := alTop;\r\n DockRect := DockTopRect;\r\n DockRect.Left := 0;\r\n DockRect.Right := ClientWidth;\r\n DockRect.Bottom := Min(ClientHeight div 2, Control.ClientHeight);\r\n end\r\n else\r\n if PtInRect(DockRightRect, MousePos) then\r\n begin\r\n Result := alRight;\r\n DockRect := DockRightRect;\r\n DockRect.Left := Max(ClientWidth div 2, ClientWidth - Control.ClientWidth);\r\n end\r\n else\r\n if PtInRect(DockBottomRect, MousePos) then\r\n begin\r\n Result := alBottom;\r\n DockRect := DockBottomRect;\r\n DockRect.Top := Max(ClientHeight div 2, ClientHeight - Control.ClientHeight);\r\n end;\r\n if Result = alNone then\r\n Exit;\r\n\r\n DockRect.TopLeft := ClientToScreen(DockRect.TopLeft);\r\n DockRect.BottomRight := ClientToScreen(DockRect.BottomRight);\r\n end;\r\nend;\r\n\r\n(* (ahuser) not used - make Delphi 5 happy\r\nprocedure SetTabControlPreview(VIDSource: TJvDockVIDVCDragDockObject;\r\n TabControl: TJvDockVIDVCTabPageControl;\r\n State: TDragState; DropAlign: TAlign);\r\n\r\nvar\r\n I: Integer;\r\n Index: Integer;\r\nbegin\r\n if TabControl <> nil then\r\n begin\r\n if DropAlign = alClient then\r\n begin\r\n\r\n if TabControl.FTempSheet = nil then\r\n begin\r\n\r\n for I := VIDSource.SourceDockClientCount - 1 downto 0 do\r\n begin\r\n\r\n TabControl.FTempSheet := TJvDockVIDVCTabSheet.Create(TabControl);\r\n TabControl.FTempSheet.PageControl := TabControl;\r\n\r\n TabControl.FTempSheet.Caption := TWinControlAccessProtected(VIDSource.SourceDockClients[I]).Caption;\r\n Index := TabControl.FTabImageList.AddIcon(TForm(VIDSource.SourceDockClients[I]).Icon);\r\n if Index <> -1 then\r\n TabControl.FTempSheet.ImageIndex := Index;\r\n\r\n TabControl.FTempSheet.FIsSourceDockClient := True;\r\n end;\r\n\r\n TabControl.ActivePage := TabControl.FTempSheet;\r\n TabControl.Panel.SelectSheet := TabControl.FTempSheet;\r\n\r\n TabControl.Panel.FTempPages.Assign(TabControl.PageSheets);\r\n\r\n TabControl.ActivePage.Invalidate;\r\n\r\n end;\r\n end;\r\n\r\n if ((State = dsDragLeave) or (VIDSource.DropAlign <> alClient)) and (TabControl.FTempSheet <> nil) then\r\n begin\r\n\r\n for I := TabControl.PageCount - 1 downto 0 do\r\n begin\r\n if TJvDockVIDVCTabSheet(TabControl.Pages[I]).FIsSourceDockClient then\r\n begin\r\n\r\n Index := TabControl.Panel.FTempPages.IndexOf(TabControl.Pages[I]);\r\n\r\n if Index >= 0 then\r\n begin\r\n TabControl.Panel.FTempPages.Delete(Index);\r\n if TabControl.FTabImageList.Count > Index then\r\n TabControl.FTabImageList.Delete(Index);\r\n end;\r\n\r\n TabControl.Pages[I].Free;\r\n end;\r\n end;\r\n\r\n TabControl.FTempSheet := nil;\r\n\r\n end;\r\n\r\n TabControl.ParentForm.Caption := TabControl.ActivePage.Caption;\r\n\r\n if TabControl.ParentForm.HostDockSite is TJvDockCustomPanel then\r\n TabControl.ParentForm.HostDockSite.Invalidate;\r\n end;\r\nend;\r\n*)\r\n\r\n//=== { TJvDockVIDVCStyle } ==================================================\r\n\r\nconstructor TJvDockVIDVCStyle.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n DockPanelClass := TJvDockVIDVCPanel;\r\n DockSplitterClass := TJvDockVIDVCSplitter;\r\n ConjoinPanelClass := TJvDockVIDVCConjoinPanel;\r\n TabDockClass := TJvDockVIDVCTabPageControl;\r\n DockPanelTreeClass := TJvDockVIDVCTree;\r\n DockPanelZoneClass := TJvDockVIDVCZone;\r\n ConjoinPanelTreeClass := TJvDockVIDVCTree;\r\n ConjoinPanelZoneClass := TJvDockVIDVCZone;\r\n ConjoinServerOptionClass := TJvDockVIDVCConjoinServerOption;\r\n TabServerOptionClass := TJvDockVIDVCTabServerOption;\r\nend;\r\n\r\nprocedure TJvDockVIDVCStyle.FormDockOver(DockClient: TJvDockClient;\r\n Source: TJvDockDragDockObject; X, Y: Integer; State: TDragState;\r\n var Accept: Boolean);\r\nvar\r\n ARect: TRect;\r\nbegin\r\n with DockClient do\r\n begin\r\n Accept := EnableDock and EachOtherDock and\r\n IsDockable(ParentForm, Source.Control, Source.DropOnControl, Source.DropAlign);\r\n if State = dsDragMove then\r\n begin\r\n Source.DropAlign := ComputeVIDDockingRect(ParentForm, Source.Control, ARect, Point(X, Y));\r\n if Accept and (Source.DropAlign <> alNone) then\r\n begin\r\n if Source.DropAlign = alClient then\r\n Inc(ARect.Top, JvDockGetSysCaptionHeightAndBorderWidth + 1);\r\n Source.DockRect := ARect;\r\n end;\r\n gi_DockRect := ARect;\r\n end\r\n else\r\n if State = dsDragLeave then\r\n Source.DropAlign := alNone;\r\n if Source is TJvDockVIDVCDragDockObject then\r\n begin\r\n TJvDockVIDVCDragDockObject(Source).OldState := TJvDockVIDVCDragDockObject(Source).CurrState;\r\n TJvDockVIDVCDragDockObject(Source).CurrState := State;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockVIDVCStyle.FormGetSiteInfo(Source: TJvDockDragDockObject;\r\n DockClient: TJvDockClient; Client: TControl; var InfluenceRect: TRect;\r\n MousePos: TPoint; var CanDock: Boolean);\r\nconst\r\n DefExpandoRect = 20;\r\nvar\r\n CH_BW: Integer;\r\n ARect: TRect;\r\nbegin\r\n with DockClient do\r\n begin\r\n CanDock := IsDockable(ParentForm, Client, Source.DropOnControl, Source.DropAlign);\r\n if CanDock then\r\n begin\r\n GetWindowRect(ParentForm.Handle, InfluenceRect);\r\n if ParentForm.HostDockSite is TJvDockCustomPanel then\r\n begin\r\n Dec(InfluenceRect.Top, TJvDockCustomPanel(ParentForm.HostDockSite).JvDockManager.GrabberSize);\r\n end;\r\n if PtInRect(InfluenceRect, MousePos) then\r\n begin\r\n ARect := InfluenceRect;\r\n InflateRect(ARect, -DefExpandoRect, -DefExpandoRect);\r\n CH_BW := JvDockGetSysCaptionHeightAndBorderWidth;\r\n Inc(ARect.Top, CH_BW + 1);\r\n if PtInRect(ARect, MousePos) then\r\n begin\r\n InfluenceRect := Classes.Rect(0, 0, 0, 0);\r\n CanDock := False;\r\n end;\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockVIDVCStyle.FormDockDrop(DockClient: TJvDockClient;\r\n Source: TJvDockDragDockObject; X, Y: Integer);\r\nvar\r\n ARect, DRect: TRect;\r\n DockType: TAlign;\r\n Host: TJvDockableForm;\r\n APanelDock: TWinControl;\r\n VIDSource: TJvDockVIDVCDragDockObject;\r\n I: Integer;\r\nbegin\r\n if Source is TJvDockVIDVCDragDockObject then\r\n begin\r\n TJvDockVIDVCDragDockObject(Source).CurrState := dsDragEnter;\r\n TJvDockVIDVCDragDockObject(Source).OldState := dsDragEnter;\r\n end;\r\n\r\n if IsDockable(DockClient.ParentForm, Source.Control, Source.DropOnControl, Source.DropAlign) then\r\n begin\r\n Host := nil;\r\n JvDockLockWindow(nil);\r\n try\r\n with DockClient do\r\n begin\r\n DockType := ComputeVIDDockingRect(DockClient.ParentForm, Source.Control, ARect, Point(X, Y));\r\n if ParentForm.HostDockSite is TJvDockPanel then\r\n begin\r\n if DockType = alClient then\r\n begin\r\n if Source.Control is TJvDockTabHostForm then\r\n begin\r\n APanelDock := ParentForm.HostDockSite;\r\n ARect := ParentForm.BoundsRect;\r\n ParentForm.ManualDock(TJvDockTabHostForm(Source.Control).PageControl, nil, alClient);\r\n TJvDockTabHostForm(Source.Control).PageControl.ActivePage.PageIndex := 0;\r\n Source.Control.BoundsRect := ARect;\r\n Source.Control.ManualDock(APanelDock, nil, alClient);\r\n if ParentForm.FormStyle = fsStayOnTop then\r\n TForm(Source.Control).FormStyle := fsStayOnTop;\r\n end\r\n else\r\n begin\r\n APanelDock := ParentForm.HostDockSite;\r\n DRect.TopLeft := ParentForm.HostDockSite.ClientToScreen(Point(0, 0));\r\n Host := CreateTabHostAndDockControl(ParentForm, Source.Control);\r\n SetDockSite(ParentForm, False);\r\n SetDockSite(TWinControl(Source.Control), False);\r\n Host.Top := DRect.Top;\r\n Host.Left := DRect.Left;\r\n Host.Visible := True;\r\n Host.ManualDock(APanelDock, nil, alClient);\r\n end;\r\n end\r\n else\r\n begin\r\n DRect := ParentForm.HostDockSite.BoundsRect;\r\n Source.Control.ManualDock(ParentForm.HostDockSite, nil, DockType);\r\n ParentForm.HostDockSite.BoundsRect := DRect;\r\n SetDockSite(TWinControl(Source.Control), False);\r\n end;\r\n Exit;\r\n end;\r\n\r\n if DockType = alClient then\r\n begin\r\n if Source.Control is TJvDockTabHostForm then\r\n begin\r\n APanelDock := ParentForm.HostDockSite;\r\n ARect := ParentForm.BoundsRect;\r\n ParentForm.ManualDock(TJvDockTabHostForm(Source.Control).PageControl, nil, alClient);\r\n TJvDockTabHostForm(Source.Control).PageControl.ActivePage.PageIndex := 0;\r\n Source.Control.BoundsRect := ARect;\r\n Source.Control.ManualDock(APanelDock, nil, alClient);\r\n if ParentForm.FormStyle = fsStayOnTop then\r\n TForm(Source.Control).FormStyle := fsStayOnTop;\r\n Exit;\r\n end\r\n else\r\n begin\r\n if Source is TJvDockVIDVCDragDockObject then\r\n begin\r\n VIDSource := TJvDockVIDVCDragDockObject(Source);\r\n DoFloatForm(Source.Control);\r\n FreeAllDockableForm;\r\n for I := 0 to VIDSource.SourceDockClientCount - 1 do\r\n begin\r\n VIDSource.Control := VIDSource.SourceDockClients[I];\r\n if Host = nil then\r\n Host := DockClient.CreateTabHostAndDockControl(DockClient.ParentForm, Source.Control)\r\n else\r\n Source.Control.ManualDock(TJvDockTabHostForm(Host).PageControl, nil, alClient);\r\n end;\r\n Host.Visible := True;\r\n end;\r\n end;\r\n end\r\n else\r\n if DockType <> alNone then\r\n begin\r\n Host := CreateConjoinHostAndDockControl(ParentForm, Source.Control, DockType);\r\n SetDockSite(ParentForm, False);\r\n SetDockSite(TWinControl(Source.Control), False);\r\n Host.Visible := True;\r\n end;\r\n\r\n if Host <> nil then\r\n begin\r\n Host.LRDockWidth := Source.Control.LRDockWidth;\r\n Host.TBDockHeight := Source.Control.TBDockHeight;\r\n end;\r\n end;\r\n finally\r\n JvDockUnLockWindow;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockVIDVCStyle.SetDockBaseControl(IsCreate: Boolean;\r\n DockBaseControl: TJvDockBaseControl);\r\nvar\r\n ADockClient: TJvDockClient;\r\nbegin\r\n if DockBaseControl is TJvDockClient then\r\n begin\r\n ADockClient := TJvDockClient(DockBaseControl);\r\n if IsCreate then\r\n ADockClient.DirectDrag := False;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockVIDVCStyle.FormStartDock(DockClient: TJvDockClient;\r\n var Source: TJvDockDragDockObject);\r\nbegin\r\n inherited FormStartDock(DockClient, Source);\r\n Source := TJvDockVIDVCDragDockObject.Create(DockClient.ParentForm);\r\nend;\r\n\r\nprocedure TJvDockVIDVCStyle.FormGetDockEdge(DockClient: TJvDockClient;\r\n Source: TJvDockDragDockObject; MousePos: TPoint; var DropAlign: TAlign);\r\nvar\r\n ARect: TRect;\r\nbegin\r\n DropAlign := ComputeVIDDockingRect(DockClient.ParentForm, Source.Control, ARect, MousePos);\r\nend;\r\n\r\nfunction TJvDockVIDVCStyle.DockClientWindowProc(DockClient: TJvDockClient;\r\n var Msg: TMessage): Boolean;\r\nbegin\r\n Result := inherited DockClientWindowProc(DockClient, Msg);\r\nend;\r\n\r\nprocedure TJvDockVIDVCStyle.DoSystemInfoChange(Value: Boolean);\r\nbegin\r\n if Assigned(FSystemInfoChange) then\r\n FSystemInfoChange(Value);\r\nend;\r\n\r\n//=== { TJvDockVIDVCPanel } ==================================================\r\n\r\nprocedure TJvDockVIDVCPanel.CustomDockDrop(Source: TJvDockDragDockObject; X, Y: Integer);\r\nbegin\r\n if Source.Control is TJvDockableForm then\r\n ShowDockPanel(True, Source.Control);\r\n if not ((Source.Control.HostDockSite <> nil) and\r\n (Source.DropOnControl = Source.Control.HostDockSite.Parent) and\r\n (Source.DropAlign = alClient)) then\r\n begin\r\n inherited CustomDockDrop(Source, X, Y);\r\n {$IFNDEF COMPILER9_UP}\r\n InvalidateDockHostSiteOfControl(Source.Control, False);\r\n {$ENDIF !COMPILER9_UP}\r\n if (Source.Control is TWinControl) and TWinControl(Source.Control).CanFocus then\r\n TWinControl(Source.Control).SetFocus;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockVIDVCPanel.CustomDockOver(Source: TJvDockDragDockObject;\r\n X, Y: Integer; State: TDragState; var Accept: Boolean);\r\nvar\r\n DropAlign: TAlign;\r\nbegin\r\n inherited CustomDockOver(Source, X, Y, State, Accept);\r\n if Accept and (Source is TJvDockVIDVCDragDockObject) then\r\n if State = dsDragMove then\r\n begin\r\n DropAlign := Source.DropAlign;\r\n JvDockManager.GetDockEdge(Source.DockRect, Source.DragPos, DropAlign, Source.Control);\r\n end;\r\nend;\r\n\r\nprocedure TJvDockVIDVCPanel.CustomGetDockEdge(Source: TJvDockDragDockObject;\r\n MousePos: TPoint; var DropAlign: TAlign);\r\nbegin\r\nend;\r\n\r\nprocedure TJvDockVIDVCPanel.CustomGetSiteInfo(Source: TJvDockDragDockObject;\r\n Client: TControl; var InfluenceRect: TRect; MousePos: TPoint;\r\n var CanDock: Boolean);\r\nbegin\r\n if VisibleDockClientCount = 0 then\r\n inherited CustomGetSiteInfo(Source, Client, InfluenceRect, MousePos, CanDock)\r\n else\r\n begin\r\n CanDock := IsDockable(Self, Client, Source.DropOnControl, Source.DropAlign);\r\n if CanDock then\r\n JvDockManager.GetSiteInfo(Client, InfluenceRect, MousePos, CanDock);\r\n end;\r\nend;\r\n\r\nprocedure TJvDockVIDVCPanel.CustomStartDock(var Source: TJvDockDragDockObject);\r\nbegin\r\n Source := TJvDockVIDVCDragDockObject.Create(Self);\r\nend;\r\n\r\nprocedure TJvDockVIDVCPanel.DockDrop(Source: TDragDockObject; X, Y: Integer);\r\nbegin\r\n inherited DockDrop(Source, X, Y);\r\nend;\r\n\r\nprocedure TJvDockVIDVCPanel.UpdateCaption(Exclude: TControl);\r\nbegin\r\n inherited UpdateCaption(Exclude);\r\n Invalidate;\r\nend;\r\n\r\n//=== { TJvDockVIDVCTree } ===================================================\r\n\r\nconstructor TJvDockVIDVCTree.Create(DockSite: TWinControl;\r\n DockZoneClass: TJvDockZoneClass; ADockStyle: TJvDockObservableStyle);\r\nbegin\r\n inherited Create(DockSite, DockZoneClass, ADockStyle);\r\n FDropOnZone := nil;\r\n ButtonHeight := 11;\r\n ButtonWidth := 13;\r\n LeftOffset := 2;\r\n RightOffset := 2;\r\n TopOffset := 4;\r\n BottomOffset := 3;\r\n ButtonSplitter := 2;\r\n BorderWidth := 4;\r\n MinSize := 20;\r\n CaptionLeftOffset := 0;\r\n CaptionRightOffset := 0;\r\nend;\r\n\r\nprocedure TJvDockVIDVCTree.InsertControl(Control: TControl; InsertAt: TAlign;\r\n DropCtl: TControl);\r\nvar\r\n I: Integer;\r\n Host: TJvDockTabHostForm;\r\n ChildCount: Integer;\r\n VIDSource: TJvDockVIDVCDragDockObject;\r\n TempControl: TControl;\r\n ARect: TRect;\r\n AZone: TJvDockZone;\r\n\r\n function CreateDockPageControl(Client: TControl): TJvDockTabHostForm;\r\n var\r\n Zone: TJvDockZone;\r\n TempCtl: TControl;\r\n TempPanel: TJvDockConjoinPanel;\r\n DockClient: TJvDockClient;\r\n APoint: TPoint;\r\n begin\r\n Result := nil;\r\n Zone := FindControlZone(DropCtl);\r\n DockClient := FindDockClient(DropCtl);\r\n if (DockClient <> nil) and (Zone <> nil) then\r\n begin\r\n TempCtl := DropCtl;\r\n\r\n if Zone.ParentZone.Orientation = doHorizontal then\r\n begin\r\n if Zone.PrevSibling = nil then\r\n begin\r\n if Zone.NextSibling <> nil then\r\n DropCtl := Zone.NextSibling.ChildControl;\r\n InsertAt := alTop;\r\n end\r\n else\r\n begin\r\n DropCtl := Zone.PrevSibling.ChildControl;\r\n InsertAt := alBottom;\r\n end;\r\n end\r\n else\r\n if Zone.ParentZone.Orientation = doVertical then\r\n begin\r\n if Zone.PrevSibling = nil then\r\n begin\r\n if Zone.NextSibling <> nil then\r\n DropCtl := Zone.NextSibling.ChildControl;\r\n InsertAt := alLeft;\r\n end\r\n else\r\n begin\r\n DropCtl := Zone.PrevSibling.ChildControl;\r\n InsertAt := alRight;\r\n end;\r\n end;\r\n\r\n if TempCtl.HostDockSite is TJvDockConjoinPanel then\r\n TempPanel := TJvDockConjoinPanel(TempCtl.HostDockSite)\r\n else\r\n TempPanel := nil;\r\n\r\n Result := DockClient.CreateTabHostAndDockControl(TempCtl, Client);\r\n if TempPanel <> nil then\r\n\r\n TempPanel.ParentForm.UnDockControl := Result;\r\n\r\n SetDockSite(TWinControl(TempCtl), False);\r\n SetDockSite(TWinControl(Client), False);\r\n\r\n if DockSite.Align = alBottom then\r\n APoint := Point(0, -TempCtl.TBDockHeight)\r\n else\r\n if DockSite.Align = alRight then\r\n APoint := Point(-TempCtl.LRDockWidth, 0)\r\n else\r\n APoint := Point(0, 0);\r\n APoint := DockSite.ClientToScreen(APoint);\r\n Result.Left := APoint.X;\r\n Result.Top := APoint.Y;\r\n Result.UndockWidth := TempCtl.UndockWidth;\r\n Result.UndockHeight := TempCtl.UndockHeight;\r\n Result.LRDockWidth := TempCtl.LRDockWidth;\r\n Result.TBDockHeight := TempCtl.TBDockHeight + GrabberSize;\r\n\r\n Result.Visible := True;\r\n end;\r\n end;\r\n\r\nbegin\r\n if not JvGlobalDockIsLoading then\r\n JvDockLockWindow(nil);\r\n try\r\n VIDSource := nil;\r\n if Control is TJvDockableForm then\r\n begin\r\n if InsertAt in [alClient] then\r\n begin\r\n if DropCtl is TJvDockTabHostForm then\r\n begin\r\n try\r\n VIDSource := TJvDockVIDVCDragDockObject.Create(Control);\r\n DoFloatForm(Control);\r\n FreeAllDockableForm;\r\n for I := VIDSource.SourceDockClientCount - 1 downto 0 do\r\n begin\r\n TempControl := VIDSource.SourceDockClients[I];\r\n TempControl.ManualDock(TJvDockTabHostForm(DropCtl).PageControl);\r\n if TempControl is TForm then\r\n begin\r\n TForm(TempControl).ActiveControl := nil;\r\n SetDockSite(TForm(TempControl), False);\r\n end;\r\n end;\r\n finally\r\n VIDSource.Free;\r\n JvGlobalDockManager.DragObject.Control := nil;\r\n end;\r\n end\r\n else\r\n begin\r\n if (DockSite is TJvDockCustomPanel) and (DockSite.VisibleDockClientCount > 1) and (DropCtl <> nil) then\r\n begin\r\n try\r\n VIDSource := TJvDockVIDVCDragDockObject.Create(Control);\r\n DoFloatForm(Control);\r\n FreeAllDockableForm;\r\n\r\n Host := CreateDockPageControl(VIDSource.SourceDockClients[0]);\r\n if Host <> nil then\r\n begin\r\n for I := VIDSource.SourceDockClientCount - 1 downto 1 do\r\n begin\r\n TempControl := VIDSource.SourceDockClients[I];\r\n TempControl.ManualDock(Host.PageControl);\r\n if TempControl is TForm then\r\n begin\r\n TForm(TempControl).ActiveControl := nil;\r\n SetDockSite(TForm(TempControl), False);\r\n end;\r\n end;\r\n\r\n Host.ManualDock(DockSite, nil, InsertAt);\r\n end;\r\n finally\r\n VIDSource.Free;\r\n JvGlobalDockManager.DragObject.Control := nil;\r\n end;\r\n end\r\n else\r\n inherited InsertControl(Control, InsertAt, DropCtl);\r\n end;\r\n end\r\n else\r\n if Control is TJvDockConjoinHostForm then\r\n begin\r\n TWinControlAccessProtected(TJvDockableForm(Control).DockableControl).DockManager.ResetBounds(True);\r\n InsertControlFromConjoinHost(Control, InsertAt, DropCtl);\r\n end\r\n else\r\n inherited InsertControl(Control, InsertAt, DropCtl);\r\n end\r\n else\r\n begin\r\n if InsertAt in [alLeft, alTop] then\r\n DropDockSize := DropDockSize + SplitterWidth div 2;\r\n if InsertAt in [alClient] then\r\n begin\r\n if DropCtl is TJvDockTabHostForm then\r\n Control.ManualDock(TJvDockTabHostForm(DropCtl).PageControl, nil, alClient)\r\n else\r\n if TopZone.ChildZones <> nil then\r\n begin\r\n ChildCount := TopZone.ChildCount;\r\n if DropCtl <> nil then\r\n begin\r\n ARect := DropCtl.BoundsRect;\r\n AZone := FindControlZone(DropCtl);\r\n\r\n if DropCtl.DockOrientation = doHorizontal then\r\n begin\r\n if ((AZone <> nil) and (AZone.ZoneLimit <> DockSite.Height)) then\r\n ARect.Bottom := ARect.Bottom + SplitterWidth;\r\n end\r\n else\r\n begin\r\n if ((AZone <> nil) and (AZone.ZoneLimit <> DockSite.Width)) then\r\n ARect.Right := ARect.Right + SplitterWidth;\r\n end;\r\n DockRect := ARect;\r\n end\r\n else\r\n DockRect := Classes.Rect(0, 0, TopZone.Width, TopZone.Height);\r\n\r\n Host := CreateDockPageControl(Control);\r\n if Host <> nil then\r\n if (ChildCount >= 2) or (DockSite is TJvDockPanel) then\r\n begin\r\n if InsertAt in [alLeft, alRight] then\r\n DropDockSize := DockRect.Right - DockRect.Left\r\n else\r\n DropDockSize := DockRect.Bottom - DockRect.Top + GrabberSize;\r\n\r\n LockDropDockSize;\r\n Host.ManualDock(DockSite, DropCtl, InsertAt);\r\n\r\n UnlockDropDockSize;\r\n end\r\n else\r\n Host.BoundsRect := DockSite.Parent.BoundsRect;\r\n end\r\n else\r\n inherited InsertControl(Control, InsertAt, DropCtl);\r\n end\r\n else\r\n inherited InsertControl(Control, InsertAt, DropCtl);\r\n\r\n { (rb) no idea what gi_DockRect should be doing, but prevent it is used\r\n before it is set (by checking whether it is empty). Using it when the rect\r\n is empty causes align problems }\r\n if not IsRectEmpty(gi_DockRect) then\r\n DockRect := gi_DockRect;\r\n end;\r\n ForEachAt(nil, UpdateZone);\r\n finally\r\n if not JvGlobalDockIsLoading then\r\n JvDockUnLockWindow;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockVIDVCTree.InsertControlFromConjoinHost(Control: TControl;\r\n InsertAt: TAlign; DropCtl: TControl);\r\nconst\r\n OrientArray: array [TAlign] of TDockOrientation =\r\n (doNoOrient, doHorizontal, doHorizontal, doVertical, doVertical, doNoOrient, doNoOrient);\r\n MakeLast: array [TAlign] of Boolean =\r\n (False, False, True, False, True, False, False);\r\n ReverseAt: array [TAlign] of TAlign =\r\n (alClient, alBottom, alTop, alRight, alLeft, alNone, alCustom);\r\nvar\r\n Stream: TMemoryStream;\r\n TopOrientation: TDockOrientation;\r\n InsertOrientation: TDockOrientation;\r\n CurrentOrientation: TDockOrientation;\r\n ZoneLimit: Integer;\r\n Level, LastLevel, I: Integer;\r\n Zone, NextZone: TJvDockZone;\r\n DropCtlZone, LastZone: TJvDockZone;\r\n OffsetXYLimitArr: array [TDockOrientation] of Integer;\r\n ControlXYLimitArr: array [TDockOrientation] of Integer;\r\n\r\n procedure ReadZone(SetZone: Boolean);\r\n var\r\n I: Integer;\r\n begin\r\n with Stream do\r\n begin\r\n Read(Level, SizeOf(Level));\r\n if Level = TreeStreamEndFlag then\r\n Exit;\r\n Zone := DockZoneClass.Create(Self);\r\n CustomLoadZone(Stream, Zone);\r\n ZoneLimit := Zone.ZoneLimit;\r\n end;\r\n if SetZone then\r\n begin\r\n if Level = LastLevel then\r\n begin\r\n Zone.NextSibling := LastZone.NextSibling;\r\n if LastZone.NextSibling <> nil then\r\n LastZone.NextSibling.PrevSibling := Zone;\r\n LastZone.NextSibling := Zone;\r\n Zone.PrevSibling := LastZone;\r\n Zone.ParentZone := LastZone.ParentZone;\r\n end\r\n else\r\n if Level > LastLevel then\r\n begin\r\n LastZone.ChildZones := Zone;\r\n Zone.ParentZone := LastZone;\r\n InsertOrientation := LastZone.Orientation;\r\n end\r\n else\r\n if Level < LastLevel then\r\n begin\r\n NextZone := LastZone;\r\n for I := 1 to LastLevel - Level do\r\n NextZone := NextZone.ParentZone;\r\n Zone.NextSibling := NextZone.NextSibling;\r\n if NextZone.NextSibling <> nil then\r\n NextZone.NextSibling.PrevSibling := Zone;\r\n NextZone.NextSibling := Zone;\r\n Zone.PrevSibling := NextZone;\r\n Zone.ParentZone := NextZone.ParentZone;\r\n InsertOrientation := Zone.ParentZone.Orientation;\r\n end;\r\n Zone.ZoneLimit := OffsetXYLimitArr[InsertOrientation] + ZoneLimit;\r\n end;\r\n LastLevel := Level;\r\n LastZone := Zone;\r\n end;\r\n\r\nbegin\r\n ControlXYLimitArr[doNoOrient] := 0;\r\n ControlXYLimitArr[doHorizontal] := DockRect.Bottom - DockRect.Top;\r\n ControlXYLimitArr[doVertical] := DockRect.Right - DockRect.Left;\r\n\r\n Stream := TMemoryStream.Create;\r\n if Control is TJvDockConjoinHostForm then\r\n TJvDockConjoinHostForm(Control).Panel.JvDockManager.SaveToStream(Stream);\r\n Stream.Position := 0;\r\n\r\n BeginUpdate;\r\n try\r\n Stream.Read(I, SizeOf(I));\r\n Stream.Position := Stream.Position + 8;\r\n Stream.Read(TopOrientation, SizeOf(TopOrientation));\r\n Stream.Read(ZoneLimit, SizeOf(ZoneLimit));\r\n IgnoreZoneInfor(Stream);\r\n if (DropCtl = nil) and (TopZone.ChildCount = 1) then\r\n DropCtl := TopZone.ChildZones.ChildControl;\r\n DropCtlZone := FindControlZone(DropCtl);\r\n if InsertAt in [alClient, alNone] then\r\n InsertAt := alRight;\r\n InsertOrientation := OrientArray[InsertAt];\r\n if TopZone.ChildCount = 0 then\r\n begin\r\n TopZone.Orientation := TopOrientation;\r\n InsertOrientation := TopOrientation;\r\n end\r\n else\r\n if TopZone.ChildCount = 1 then\r\n begin\r\n TopZone.Orientation := InsertOrientation;\r\n case InsertOrientation of\r\n doHorizontal:\r\n begin\r\n TopZone.ZoneLimit := TopZone.ChildZones.Width;\r\n TopXYLimit := TopZone.ChildZones.Height;\r\n end;\r\n doVertical:\r\n begin\r\n TopZone.ZoneLimit := TopZone.ChildZones.Height;\r\n TopXYLimit := TopZone.ChildZones.Width;\r\n end;\r\n end;\r\n end;\r\n\r\n if DropCtlZone <> nil then\r\n CurrentOrientation := DropCtlZone.ParentZone.Orientation\r\n else\r\n CurrentOrientation := TopZone.Orientation;\r\n\r\n if InsertOrientation = doHorizontal then\r\n DropDockSize := DockRect.Bottom - DockRect.Top\r\n else\r\n if InsertOrientation = doVertical then\r\n DropDockSize := DockRect.Right - DockRect.Left\r\n else\r\n DropDockSize := 0;\r\n\r\n OffsetXYLimitArr[doNoOrient] := 0;\r\n if DropCtlZone <> nil then\r\n begin\r\n OffsetXYLimitArr[doHorizontal] := DropCtlZone.TopLeft[doHorizontal] +\r\n Integer(MakeLast[InsertAt]) * (DropCtlZone.HeightWidth[doHorizontal] - ControlXYLimitArr[doHorizontal]);\r\n if (FDropOnZone <> nil) and (InsertOrientation = doHorizontal) then\r\n OffsetXYLimitArr[doHorizontal] := FDropOnZone.ZoneLimit - Round((FDropOnZone.ZoneLimit -\r\n FDropOnZone.ParentZone.ChildZones.LimitBegin) * (DropDockSize + BorderWidth) /\r\n (FDropOnZone.ParentZone.Height));\r\n OffsetXYLimitArr[doVertical] := DropCtlZone.TopLeft[doVertical] +\r\n Integer(MakeLast[InsertAt]) * (DropCtlZone.HeightWidth[doVertical] - ControlXYLimitArr[doVertical]);\r\n if (FDropOnZone <> nil) and (InsertOrientation = doVertical) then\r\n OffsetXYLimitArr[doVertical] := FDropOnZone.ZoneLimit - Round((FDropOnZone.ZoneLimit -\r\n FDropOnZone.ParentZone.ChildZones.LimitBegin) * (DropDockSize + BorderWidth) /\r\n (FDropOnZone.ParentZone.Width));\r\n end\r\n else\r\n begin\r\n if TopZone.VisibleChildCount = 0 then\r\n begin\r\n OffsetXYLimitArr[doHorizontal] := 0;\r\n OffsetXYLimitArr[doVertical] := 0;\r\n end\r\n else\r\n begin\r\n OffsetXYLimitArr[doHorizontal] := Integer(MakeLast[InsertAt]) * ControlXYLimitArr[doHorizontal];\r\n OffsetXYLimitArr[doVertical] := Integer(MakeLast[InsertAt]) * ControlXYLimitArr[doVertical];\r\n end;\r\n end;\r\n\r\n if TopOrientation <> InsertOrientation then\r\n begin\r\n LastZone := DockZoneClass.Create(Self);\r\n if InsertOrientation <> CurrentOrientation then\r\n InsertNewParent(LastZone, DropCtlZone, InsertOrientation, MakeLast[InsertAt], True)\r\n else\r\n InsertSibling(LastZone, DropCtlZone, MakeLast[InsertAt], True);\r\n LastZone.Orientation := TopOrientation;\r\n LastLevel := 0;\r\n end\r\n else\r\n begin\r\n LastLevel := 1;\r\n if TopZone.ChildCount > 0 then\r\n begin\r\n ReadZone(False);\r\n if InsertOrientation <> CurrentOrientation then\r\n InsertNewParent(LastZone, DropCtlZone, InsertOrientation, MakeLast[InsertAt], True)\r\n else\r\n InsertSibling(LastZone, DropCtlZone, MakeLast[InsertAt], True);\r\n LastZone.ZoneLimit := ZoneLimit + OffsetXYLimitArr[InsertOrientation];\r\n end\r\n else\r\n begin\r\n LastLevel := 0;\r\n LastZone := TopZone;\r\n end;\r\n end;\r\n\r\n OffsetXYLimitArr[doHorizontal] := LastZone.TopLeft[doHorizontal];\r\n OffsetXYLimitArr[doVertical] := LastZone.TopLeft[doVertical];\r\n\r\n // (rom) is this rock solid?\r\n while True do\r\n begin\r\n ReadZone(True);\r\n if Level = TreeStreamEndFlag then\r\n Break;\r\n end;\r\n finally\r\n Stream.Free;\r\n EndUpdate;\r\n end;\r\n SetNewBounds(nil);\r\nend;\r\n\r\nprocedure TJvDockVIDVCTree.DrawDockGrabber(Control: TWinControl; const ARect: TRect);\r\nvar\r\n lbVCDockZone: TJvDockVIDVCZone;\r\n DrawRect: TRect;\r\n\r\n procedure DrawCloseButton(Left, Top: Integer);\r\n var\r\n ADockClient: TJvDockClient;\r\n begin\r\n if lbVCDockZone <> nil then\r\n begin\r\n ADockClient := FindDockClient(Control);\r\n if (ADockClient <> nil) and (not ADockClient.EnableCloseButton) then\r\n Exit;\r\n DrawFrameControl(Canvas.Handle, Classes.Rect(Left, Top, Left + ButtonWidth,\r\n Top + ButtonHeight), DFC_CAPTION, DFCS_CAPTIONCLOSE or Integer(lbVCDockZone.CloseBtnDown) * DFCS_PUSHED)\r\n end;\r\n end;\r\n\r\n procedure DrawExpendBotton(Left, Top: Integer);\r\n const\r\n ArrowOrient: array [TAlign] of DWORD =\r\n (0, DFCS_SCROLLUP, DFCS_SCROLLDOWN, DFCS_SCROLLLEFT, DFCS_SCROLLRIGHT, 0, 0);\r\n CurrArrow: array [Boolean, TDockOrientation] of TAlign =\r\n ((alNone, alLeft, alTop), (alNone, alRight, alBottom));\r\n var\r\n InActive: Boolean;\r\n IsMaximum: Boolean;\r\n begin\r\n if lbVCDockZone <> nil then\r\n begin\r\n InActive := not ((lbVCDockZone.ParentZone.Orientation <> DockSiteOrientation) and\r\n (lbVCDockZone.ParentZone.VisibleChildCount >= 2));\r\n IsMaximum := lbVCDockZone.ZoneSizeStyle in [zssMaximum];\r\n DrawFrameControl(Canvas.Handle, Classes.Rect(Left, Top, Left + ButtonWidth,\r\n Top + ButtonHeight), DFC_SCROLL,\r\n ArrowOrient[CurrArrow[IsMaximum, DockSiteOrientation]] +\r\n Cardinal(InActive) * (DFCS_INACTIVE) + Cardinal(lbVCDockZone.ExpandButtonDown) * DFCS_PUSHED);\r\n end;\r\n end;\r\n\r\n procedure DrawGrabberLine(Left, Top, Right, Bottom: Integer);\r\n begin\r\n if (Left >= Right) or (Top >= Bottom) then\r\n Exit;\r\n with Canvas do\r\n begin\r\n Pen.Color := clBtnHighlight;\r\n MoveTo(Right, Top);\r\n LineTo(Left, Top);\r\n LineTo(Left, Bottom);\r\n Pen.Color := clBtnShadow;\r\n LineTo(Right, Bottom);\r\n LineTo(Right, Top - 1);\r\n end;\r\n end;\r\n\r\nbegin\r\n lbVCDockZone := TJvDockVIDVCZone(FindControlZone(Control));\r\n DrawRect := ARect;\r\n Canvas.Brush.Color := TWinControlAccessProtected(DockSite).Color;\r\n Canvas.FillRect(DrawRect);\r\n case GrabbersPosition of\r\n gpLeft:\r\n begin\r\n DrawExpendBotton(ARect.Left + BorderWidth + LeftOffset, ARect.Top + TopOffset + ButtonHeight + ButtonSplitter +\r\n BorderWidth);\r\n DrawCloseButton(ARect.Left + BorderWidth + LeftOffset, ARect.Top + TopOffset + BorderWidth);\r\n DrawGrabberLine(ARect.Left + BorderWidth + LeftOffset + 3, ARect.Top + 2 * ButtonHeight + TopOffset + ButtonSplitter +\r\n BottomOffset + BorderWidth + 3, ARect.Left + BorderWidth + LeftOffset + 5, ARect.Bottom - BorderWidth - 2);\r\n DrawGrabberLine(ARect.Left + BorderWidth + LeftOffset + 7, ARect.Top + 2 * ButtonHeight + TopOffset + ButtonSplitter +\r\n BottomOffset + BorderWidth + 3, ARect.Left + BorderWidth + LeftOffset + 9, ARect.Bottom - BorderWidth - 2);\r\n end;\r\n gpTop:\r\n begin\r\n DrawExpendBotton(ARect.Right - LeftOffset - 2 * ButtonWidth - ButtonSplitter - BorderWidth, ARect.Top + TopOffset +\r\n BorderWidth);\r\n DrawCloseButton(ARect.Right - LeftOffset - ButtonWidth - BorderWidth, ARect.Top + TopOffset + BorderWidth);\r\n DrawGrabberLine(ARect.Left + BorderWidth, ARect.Top + BorderWidth + TopOffset + 3, ARect.Right - 2 * ButtonWidth - RightOffset -\r\n ButtonSplitter - LeftOffset - BorderWidth - 3, ARect.Top + BorderWidth + TopOffset + 5);\r\n DrawGrabberLine(ARect.Left + BorderWidth, ARect.Top + BorderWidth + TopOffset + 7, ARect.Right - 2 * ButtonWidth - RightOffset -\r\n ButtonSplitter - LeftOffset - BorderWidth - 3, ARect.Top + BorderWidth + TopOffset + 9);\r\n end;\r\n gpBottom:\r\n begin\r\n end;\r\n gpRight:\r\n begin\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockVIDVCTree.ResetBounds(Force: Boolean);\r\nvar\r\n R: TRect;\r\nbegin\r\n if not (csLoading in DockSite.ComponentState) and\r\n (TopZone <> nil) and (DockSite.DockClientCount > 0) then\r\n begin\r\n R := DockSite.ClientRect;\r\n if DockSite is TJvDockConjoinPanel then\r\n begin\r\n if R.Right = R.Left then\r\n Inc(R.Right, DockSite.Parent.UndockWidth);\r\n if R.Bottom = R.Top then\r\n Inc(R.Bottom, DockSite.Parent.UndockHeight);\r\n end;\r\n if Force or (not CompareMem(@R, @PreviousRect, SizeOf(TRect))) then\r\n begin\r\n case TopZone.Orientation of\r\n doHorizontal:\r\n begin\r\n if R.Right - R.Left > 0 then\r\n TopZone.ZoneLimit := R.Right - R.Left;\r\n if R.Bottom - R.Top > 0 then\r\n TopXYLimit := R.Bottom - R.Top;\r\n end;\r\n doVertical:\r\n begin\r\n if R.Bottom - R.Top > 0 then\r\n TopZone.ZoneLimit := R.Bottom - R.Top;\r\n if R.Right - R.Left > 0 then\r\n TopXYLimit := R.Right - R.Left;\r\n end;\r\n end;\r\n if DockSite.DockClientCount > 0 then\r\n begin\r\n if not JvGlobalDockIsLoading then\r\n begin\r\n if (R.Bottom - R.Top > 0) and (PreviousRect.Bottom - PreviousRect.Top > 0) then\r\n ScaleBy := (R.Bottom - R.Top) / (PreviousRect.Bottom - PreviousRect.Top)\r\n else\r\n ScaleBy := 1;\r\n\r\n ShiftScaleOrientation := doHorizontal;\r\n\r\n if (UpdateCount = 0) and (ScaleBy <> 1) then\r\n ForEachAt(nil, ScaleZone, tskForward);\r\n\r\n if (R.Right - R.Left > 0) and (PreviousRect.Right - PreviousRect.Left > 0) then\r\n ScaleBy := (R.Right - R.Left) / (PreviousRect.Right - PreviousRect.Left)\r\n else\r\n ScaleBy := 1;\r\n\r\n ShiftScaleOrientation := doVertical;\r\n\r\n if (UpdateCount = 0) and (ScaleBy <> 1) then\r\n ForEachAt(nil, ScaleZone, tskForward);\r\n end;\r\n\r\n SetNewBounds(nil);\r\n if UpdateCount = 0 then\r\n ForEachAt(nil, UpdateZone, tskForward);\r\n\r\n PreviousRect := R;\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockVIDVCTree.DrawSplitterRect(const ARect: TRect);\r\nvar\r\n Rect: TRect;\r\nbegin\r\n inherited DrawSplitterRect(ARect);\r\n Rect := ARect;\r\n InflateRect(Rect, 1, 1);\r\n DrawFrameControl(Canvas.Handle, Rect, DFC_BUTTON, DFCS_BUTTONPUSH or DFCS_ADJUSTRECT);\r\nend;\r\n\r\nprocedure TJvDockVIDVCTree.WindowProc(var Msg: TMessage);\r\nvar\r\n Align: TAlign;\r\nbegin\r\n if Msg.Msg = CM_DOCKCLIENT then\r\n begin\r\n { (rb) no idea what gi_DockRect should be doing, but prevent it is used\r\n before it is set (by checking whether it is empty). Using it when the rect\r\n is empty causes align problems }\r\n if not IsRectEmpty(gi_DockRect) then\r\n begin\r\n Align := TCMDockClient(Msg).DockSource.DropAlign;\r\n TCMDockClient(Msg).DockSource.DockRect := gi_DockRect;\r\n GetDockEdge(gi_DockRect, TCMDockClient(Msg).DockSource.DragPos, Align, TCMDockClient(Msg).DockSource.Control);\r\n end;\r\n end;\r\n inherited WindowProc(Msg);\r\nend;\r\n\r\nprocedure TJvDockVIDVCTree.SplitterMouseUp;\r\nvar\r\n OldLimit: Integer;\r\n Zone: TJvDockZone;\r\nbegin\r\n Mouse.Capture := 0;\r\n DrawSizeSplitter;\r\n ReleaseDC(SizingWnd, SizingDC);\r\n\r\n OldLimit := SizingZone.ZoneLimit;\r\n\r\n ShiftScaleOrientation := SizingZone.ParentZone.Orientation;\r\n if SizingZone.ParentZone.Orientation = doHorizontal then\r\n SizingZone.ZoneLimit := SizePos.Y + (SplitterWidth div 2)\r\n else\r\n SizingZone.ZoneLimit := SizePos.X + (SplitterWidth div 2);\r\n\r\n ParentLimit := SizingZone.LimitBegin;\r\n if OldLimit - ParentLimit > 0 then\r\n ScaleBy := (SizingZone.ZoneLimit - ParentLimit) / (OldLimit - ParentLimit)\r\n else\r\n ScaleBy := 1;\r\n\r\n if SizingZone.ChildZones <> nil then\r\n ForEachAt(SizingZone.ChildZones, ScaleChildZone, tskForward);\r\n\r\n Zone := SizingZone;\r\n while (Zone.NextSibling <> nil) and (not Zone.NextSibling.Visibled) do\r\n begin\r\n Zone.NextSibling.ZoneLimit := SizingZone.ZoneLimit;\r\n Zone := Zone.NextSibling;\r\n end;\r\n\r\n if SizingZone.NextSibling <> nil then\r\n begin\r\n if SizingZone.NextSibling.ZoneLimit - OldLimit > 0 then\r\n ScaleBy := (SizingZone.NextSibling.ZoneLimit - SizingZone.ZoneLimit) / (SizingZone.NextSibling.ZoneLimit -\r\n OldLimit)\r\n else\r\n ScaleBy := 1;\r\n ParentLimit := SizingZone.NextSibling.ZoneLimit;\r\n\r\n if SizingZone.NextSibling.ChildZones <> nil then\r\n ForEachAt(SizingZone.NextSibling.ChildZones, ScaleSiblingZone, tskForward);\r\n end;\r\n\r\n SetNewBounds(SizingZone.ParentZone);\r\n ForEachAt(SizingZone.ParentZone, UpdateZone, tskForward);\r\n SizingZone := nil;\r\nend;\r\n\r\nprocedure TJvDockVIDVCTree.InsertSibling(NewZone, SiblingZone: TJvDockZone;\r\n InsertLast, Update: Boolean);\r\nbegin\r\n if FDropOnZone <> nil then\r\n SiblingZone := FDropOnZone;\r\n inherited InsertSibling(NewZone, SiblingZone, InsertLast, Update);\r\nend;\r\n\r\n{procedure TJvDockVIDVCTree.PositionDockRect(Client, DropCtl: TControl;\r\n DropAlign: TAlign; var DockRect: TRect);\r\nlabel\r\n LBDropCtlExist;\r\nvar\r\n VisibleClients, NewX, NewY, NewWidth, NewHeight: Integer;\r\n Zone: TJvDockZone;\r\n HTFlag: Integer;\r\n MousePos: TPoint;\r\n Scale: Double;\r\n CtrlRect: TRect;\r\n\r\n procedure DockOverSplitter;\r\n begin\r\n NewX := Zone.ParentZone.Left;\r\n NewY := Zone.ParentZone.Top;\r\n NewWidth := Zone.ParentZone.Width;\r\n NewHeight := Zone.ParentZone.Height;\r\n case Zone.ParentZone.Orientation of\r\n doHorizontal:\r\n begin\r\n Scale := (Zone.ZoneLimit - Zone.ParentZone.ChildZones.LimitBegin) / NewHeight;\r\n NewHeight := Min(NewHeight div 2, Client.ClientHeight);\r\n //NewY := Zone.ZoneLimit - Round(NewHeight * Scale);\r\n end;\r\n doVertical:\r\n begin\r\n Scale := (Zone.ZoneLimit - Zone.ParentZone.ChildZones.LimitBegin) / NewWidth;\r\n NewWidth := Min(NewWidth div 2, Client.ClientWidth);\r\n NewX := Zone.ZoneLimit - Round(NewWidth * Scale);\r\n end;\r\n end;\r\n DockRect := Bounds(NewX, NewY, NewWidth, NewHeight);\r\n if Zone.Visibled then\r\n begin\r\n if Zone.ParentZone.Orientation = doHorizontal then\r\n JvGlobalDockManager.DragObject.DropAlign := alBottom\r\n else\r\n if Zone.ParentZone.Orientation = doVertical then\r\n JvGlobalDockManager.DragObject.DropAlign := alRight;\r\n JvGlobalDockManager.DragObject.DropOnControl := Zone.ChildControl;\r\n FDropOnZone := Zone;\r\n end;\r\n end;\r\n\r\nbegin\r\n if DropAlign = alNone then\r\n DropAlign := alClient;\r\n VisibleClients := DockSite.VisibleDockClientCount;\r\n FDropOnZone := nil;\r\n\r\n MousePos := JvGlobalDockManager.DragObject.DragPos;\r\n MapWindowPoints(0, DockSite.Handle, MousePos, 2);\r\n Zone := InternalHitTest(MousePos, HTFlag);\r\n if Zone <> nil then\r\n if Zone.ChildControl <> nil then\r\n if (HTFlag = HTCaption) or (HTFlag = HTClose) then\r\n begin\r\n DockRect := Zone.ChildControl.BoundsRect;\r\n JvGlobalDockManager.DragObject.DropAlign := alClient;\r\n if Zone.ChildControl is TJvDockTabHostForm then\r\n begin\r\n if JvGlobalDockManager.DragObject is TJvDockVIDVCDragDockObject then\r\n TJvDockVIDVCDragDockObject(JvGlobalDockManager.DragObject).FDropTabControl :=\r\n TJvDockVIDVCTabPageControl(TJvDockTabHostForm(Zone.ChildControl).PageControl);\r\n end\r\n else\r\n begin\r\n if JvGlobalDockManager.DragObject is TJvDockVIDVCDragDockObject then\r\n TJvDockVIDVCDragDockObject(JvGlobalDockManager.DragObject).FDropTabControl := nil;\r\n end;\r\n end;\r\n\r\n if DropCtl = nil then\r\n begin\r\n if Zone <> nil then\r\n begin\r\n if Zone.ChildControl <> nil then\r\n begin\r\n if (HTFlag = HTCaption) or (HTFlag = HTClose) then\r\n JvGlobalDockManager.DragObject.DropOnControl := Zone.ChildControl\r\n else\r\n if HTFlag = HTClient then\r\n begin\r\n DropCtl := Zone.ChildControl;\r\n goto LBDropCtlExist;\r\n end\r\n else\r\n if HTFlag = HTSplitter then\r\n DockOverSplitter;\r\n end\r\n else\r\n if HTFlag = HTSplitter then\r\n begin\r\n DockOverSplitter;\r\n end\r\n else\r\n Exit;\r\n end\r\n else\r\n begin\r\n DockRect := Rect(0, 0, DockSite.ClientWidth, DockSite.ClientHeight);\r\n\r\n if VisibleClients > 0 then\r\n case DropAlign of\r\n alLeft:\r\n DockRect.Right := DockRect.Right div 2;\r\n alRight:\r\n DockRect.Left := DockRect.Right div 2;\r\n alTop:\r\n DockRect.Bottom := DockRect.Bottom div 2;\r\n alBottom:\r\n DockRect.Top := DockRect.Bottom div 2;\r\n end;\r\n end;\r\n end\r\n else\r\n begin\r\n\r\n LBDropCtlExist:\r\n Zone := FindControlZone(DropCtl);\r\n CtrlRect := DockRect;\r\n MapWindowPoints(0, DockSite.Handle, CtrlRect, 2);\r\n if Zone <> nil then\r\n begin\r\n if Zone.ParentZone.Orientation = doVertical then\r\n begin\r\n if (DropAlign = alRight) and (Zone.NextSibling <> nil) then\r\n begin\r\n DockOverSplitter;\r\n MapWindowPoints(DockSite.Handle, 0, DockRect, 2);\r\n Exit;\r\n end\r\n else\r\n if (DropAlign = alLeft) and (Zone.PrevSibling <> nil) then\r\n begin\r\n Zone := Zone.PrevSibling;\r\n DockOverSplitter;\r\n MapWindowPoints(DockSite.Handle, 0, DockRect, 2);\r\n Exit;\r\n end\r\n else\r\n{ begin\r\n if DropAlign in [alLeft, alRight] then\r\n CtrlRect := Bounds(Zone.ParentZone.Left, Zone.ParentZone.Top, Zone.ParentZone.Width, Zone.ParentZone.Height)\r\n else\r\n if DropAlign in [alTop, alBottom, alClient] then\r\n begin\r\n CtrlRect := DropCtl.BoundsRect;\r\n if DropAlign in [alLeft, alRight] then\r\n Dec(CtrlRect.Top, GrabberSize);\r\n end;\r\n OffsetRect(CtrlRect, 0, GrabberSize);\r\n end;\r\n end\r\n else\r\n if Zone.ParentZone.Orientation = doHorizontal then\r\n begin\r\n if (DropAlign = alBottom) and (Zone.NextSibling <> nil) then\r\n begin\r\n DockOverSplitter;\r\n MapWindowPoints(DockSite.Handle, 0, DockRect, 2);\r\n Exit;\r\n end\r\n else\r\n if (DropAlign = alTop) and (Zone.PrevSibling <> nil) then\r\n begin\r\n Zone := Zone.PrevSibling;\r\n DockOverSplitter;\r\n MapWindowPoints(DockSite.Handle, 0, DockRect, 2);\r\n Exit;\r\n end\r\n else\r\n begin\r\n{ if DropAlign in [alTop, alBottom] then\r\n CtrlRect := Bounds(Zone.ParentZone.Left, Zone.ParentZone.Top, Zone.ParentZone.Width, Zone.ParentZone.Height)\r\n else\r\n if DropAlign in [alLeft, alRight, alClient] then\r\n begin\r\n CtrlRect := DropCtl.BoundsRect;\r\n if DropAlign in [alLeft, alRight] then\r\n Dec(CtrlRect.Top, GrabberSize);\r\n end;\r\n //if DropAlign in [alLeft, alRight] then\r\n OffsetRect(CtrlRect, 0, GrabberSize);\r\n end;\r\n end\r\n else\r\n begin\r\n CtrlRect := DropCtl.BoundsRect;\r\n\r\n //Dec(CtrlRect.Top, GrabberSize);\r\n //OffsetRect(CtrlRect, 0, GrabberSize);\r\n end;\r\n\r\n NewX := CtrlRect.Left;\r\n if DropAlign in [alTop, alBottom] then\r\n NewY := CtrlRect.Top\r\n else\r\n NewY := CtrlRect.Top - GrabberSize;\r\n NewWidth := CtrlRect.Right - CtrlRect.Left;\r\n NewHeight := CtrlRect.Bottom - CtrlRect.Top;\r\n if DropAlign in [alLeft, alRight] then\r\n NewWidth := Min(Client.UndockWidth, NewWidth div 2)\r\n else\r\n if DropAlign in [alTop, alBottom] then\r\n NewHeight := Min(Client.UndockHeight, NewHeight div 2);\r\n case DropAlign of\r\n alRight:\r\n Inc(NewX, CtrlRect.Right - CtrlRect.Left - NewWidth);\r\n alBottom:\r\n Inc(NewY, CtrlRect.Bottom - CtrlRect.Top - NewHeight);\r\n end;\r\n DockRect := Bounds(NewX, NewY, NewWidth, NewHeight);\r\n if DropAlign = alClient then\r\n DockRect := Bounds(NewX, NewY, NewWidth, NewHeight);\r\n if DropAlign = alNone then\r\n begin\r\n end;\r\n end;\r\n end;\r\n MapWindowPoints(DockSite.Handle, 0, DockRect, 2);\r\nend; }\r\n\r\nfunction TJvDockVIDVCTree.GetDockEdge(DockRect: TRect; MousePos: TPoint;\r\n var DropAlign: TAlign; Control: TControl): TControl;\r\nbegin\r\n Result := inherited GetDockEdge(DockRect, MousePos, DropAlign, Control);\r\n if FLockDropDockSizeCount = 0 then\r\n begin\r\n if DropAlign in [alLeft, alRight] then\r\n DropDockSize := DockRect.Right - DockRect.Left\r\n else\r\n if DropAlign in [alTop, alBottom] then\r\n DropDockSize := DockRect.Bottom - DockRect.Top\r\n else\r\n DropDockSize := 0;\r\n Self.DockRect := DockRect;\r\n end;\r\nend;\r\n\r\nfunction TJvDockVIDVCTree.GetLeftGrabbersHTFlag(const MousePos: TPoint;\r\n out HTFlag: Integer; Zone: TJvDockZone): TJvDockZone;\r\nbegin\r\n if (MousePos.X >= Zone.Left + BorderWidth) and (MousePos.X <= Zone.Left + BorderWidth + GrabberSize) and\r\n (MousePos.Y >= Zone.Top) and (MousePos.Y <= Zone.Top + Zone.Height) then\r\n begin\r\n Result := Zone;\r\n with Zone.ChildControl do\r\n begin\r\n if PtInRect(Classes.Rect(\r\n Left - GrabberSize + LeftOffset,\r\n Top + TopOffset,\r\n Left - GrabberSize + LeftOffset + ButtonWidth,\r\n Top + TopOffset + ButtonHeight), MousePos) then\r\n HTFlag := HTCLOSE\r\n else\r\n if PtInRect(Classes.Rect(\r\n Left - GrabberSize + LeftOffset,\r\n Top + ButtonHeight + TopOffset + ButtonSplitter,\r\n Left - GrabberSize + LeftOffset + ButtonWidth,\r\n Top + 2 * ButtonHeight + TopOffset + ButtonSplitter), MousePos) then\r\n HTFlag := HTEXPAND\r\n else\r\n HTFlag := HTCAPTION;\r\n end;\r\n end\r\n else\r\n Result := nil;\r\nend;\r\n\r\nfunction TJvDockVIDVCTree.GetTopGrabbersHTFlag(const MousePos: TPoint;\r\n out HTFlag: Integer; Zone: TJvDockZone): TJvDockZone;\r\nbegin\r\n if (MousePos.Y >= Zone.Top + BorderWidth) and (MousePos.Y <= Zone.Top + BorderWidth + GrabberSize) and\r\n (MousePos.X >= Zone.Left) and (MousePos.X <= Zone.Left + Zone.Width) then\r\n begin\r\n Result := Zone;\r\n with Zone.ChildControl do\r\n begin\r\n if PtInRect(Classes.Rect(\r\n Left + Width - ButtonWidth - RightOffset,\r\n Top - GrabberSize + TopOffset,\r\n Left + Width - RightOffset,\r\n Top - GrabberSize + TopOffset + ButtonHeight), MousePos) then\r\n HTFlag := HTCLOSE\r\n else\r\n if PtInRect(Classes.Rect(\r\n Left + Width - 2 * ButtonWidth - RightOffset - ButtonSplitter,\r\n Top - GrabberSize + TopOffset,\r\n Left + Width - ButtonWidth - RightOffset - ButtonSplitter,\r\n Top - GrabberSize + TopOffset + ButtonHeight), MousePos) then\r\n HTFlag := HTEXPAND\r\n else\r\n HTFlag := HTCAPTION;\r\n end;\r\n end\r\n else\r\n Result := nil;\r\nend;\r\n\r\nprocedure TJvDockVIDVCTree.InsertNewParent(NewZone, SiblingZone: TJvDockZone;\r\n ParentOrientation: TDockOrientation; InsertLast, Update: Boolean);\r\nbegin\r\n if FDropOnZone <> nil then\r\n begin\r\n SiblingZone := FDropOnZone;\r\n InsertSibling(NewZone, SiblingZone, InsertLast, Update);\r\n end\r\n else\r\n inherited InsertNewParent(NewZone, SiblingZone, ParentOrientation,\r\n InsertLast, Update);\r\nend;\r\n\r\nprocedure TJvDockVIDVCTree.RemoveZone(Zone: TJvDockZone; Hide: Boolean);\r\nbegin\r\n if (FDropOnZone <> nil) and\r\n ((FDropOnZone.NextSibling = Zone) or (FDropOnZone = Zone)) then\r\n FDropOnZone := nil;\r\n inherited RemoveZone(Zone, Hide);\r\nend;\r\n\r\nprocedure TJvDockVIDVCSplitter.Paint;\r\nvar\r\n Rect: TRect;\r\nbegin\r\n Rect := ClientRect;\r\n Inc(Rect.Right, 2);\r\n case Align of\r\n alLeft:\r\n InflateRect(Rect, 0, 2);\r\n alRight:\r\n begin\r\n OffsetRect(Rect, -1, 0);\r\n InflateRect(Rect, 0, 2);\r\n end;\r\n alTop:\r\n begin\r\n Inc(Rect.Bottom, 2);\r\n InflateRect(Rect, 2, 0);\r\n end;\r\n alBottom:\r\n begin\r\n Dec(Rect.Top, 2);\r\n InflateRect(Rect, 2, 1);\r\n end;\r\n end;\r\n Canvas.Brush.Color := Color;\r\n DrawFrameControl(Canvas.Handle, Rect, DFC_BUTTON, DFCS_BUTTONPUSH or DFCS_ADJUSTRECT);\r\nend;\r\n\r\nprocedure TJvDockVIDVCTree.GetSiteInfo(Client: TControl;\r\n var InfluenceRect: TRect; MousePos: TPoint; var CanDock: Boolean);\r\nvar\r\n Zone: TJvDockZone;\r\n HTFlag: Integer;\r\n Pos: TPoint;\r\n Align: TAlign;\r\nbegin\r\n Pos := DockSite.ScreenToClient(MousePos);\r\n Zone := InternalHitTest(Pos, HTFlag);\r\n if Zone <> nil then\r\n begin\r\n if HTFlag = HTSPLITTER then\r\n begin\r\n InfluenceRect := GetSplitterRect(Zone);\r\n MapWindowPoints(DockSite.Handle, 0, InfluenceRect, 2);\r\n end\r\n else\r\n begin\r\n Pos := MousePos;\r\n if Zone.ChildControl <> nil then\r\n Pos := Zone.ChildControl.ScreenToClient(MousePos);\r\n Align := ComputeVIDDockingRect(Zone.ChildControl, Client, InfluenceRect, Pos);\r\n if (Align = alNone) or (Client = Zone.ChildControl) then\r\n begin\r\n InfluenceRect := Classes.Rect(0, 0, 0, 0);\r\n CanDock := False;\r\n end\r\n else\r\n begin\r\n if Zone.ParentZone.Orientation = doVertical then\r\n begin\r\n if (Align = alRight) and (Zone.NextSibling <> nil) and (Zone.NextSibling.Visibled) then\r\n begin\r\n InfluenceRect := GetSplitterRect(Zone);\r\n InflateRect(InfluenceRect, DefExpandoRect, 0);\r\n end\r\n else\r\n if (Align = alLeft) and (Zone.PrevSibling <> nil) and (Zone.PrevSibling.Visibled) then\r\n begin\r\n InfluenceRect := GetSplitterRect(Zone.PrevSibling);\r\n InflateRect(InfluenceRect, DefExpandoRect, 0);\r\n end\r\n else\r\n Exit;\r\n end\r\n else\r\n if Zone.ParentZone.Orientation = doHorizontal then\r\n begin\r\n if (Align = alBottom) and (Zone.NextSibling <> nil) and (Zone.NextSibling.Visibled) then\r\n begin\r\n InfluenceRect := GetSplitterRect(Zone);\r\n InflateRect(InfluenceRect, 0, DefExpandoRect);\r\n end\r\n else\r\n if (Align = alTop) and (Zone.PrevSibling <> nil) and (Zone.PrevSibling.Visibled) then\r\n begin\r\n InfluenceRect := GetSplitterRect(Zone.PrevSibling);\r\n InflateRect(InfluenceRect, 0, DefExpandoRect);\r\n end\r\n else\r\n Exit;\r\n end\r\n else\r\n Exit;\r\n end;\r\n MapWindowPoints(DockSite.Handle, 0, InfluenceRect, 2);\r\n end;\r\n end\r\n else\r\n begin\r\n InfluenceRect := Classes.Rect(0, 0, 0, 0);\r\n CanDock := False;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockVIDVCTree.LockDropDockSize;\r\nbegin\r\n Inc(FLockDropDockSizeCount);\r\nend;\r\n\r\nprocedure TJvDockVIDVCTree.UnlockDropDockSize;\r\nbegin\r\n Dec(FLockDropDockSizeCount);\r\n if FLockDropDockSizeCount < 0 then\r\n FLockDropDockSizeCount := 0;\r\nend;\r\n\r\nprocedure TJvDockVIDVCTree.PaintDockGrabberRect(Canvas: TCanvas;\r\n Control: TControl; const ARect: TRect);\r\nbegin\r\nend;\r\n\r\nprocedure TJvDockVIDVCTree.SetCaptionLeftOffset(const Value: Integer);\r\nbegin\r\n FCaptionLeftOffset := Value;\r\nend;\r\n\r\nprocedure TJvDockVIDVCTree.SetCaptionRightOffset(const Value: Integer);\r\nbegin\r\n FCaptionRightOffset := Value;\r\nend;\r\n\r\nprocedure TJvDockVIDVCTree.DrawCloseButton(Canvas: TCanvas; Zone: TJvDockZone; Left, Top: Integer);\r\nvar\r\n AZone: TJvDockAdvZone;\r\n ADockClient: TJvDockClient;\r\n {$IFDEF JVCLThemesEnabled}\r\n Details: TThemedElementDetails;\r\n CurrentThemeType: TThemedWindow;\r\n {$ENDIF JVCLThemesEnabled}\r\nbegin\r\n AZone := TJvDockAdvZone(Zone);\r\n if AZone <> nil then\r\n begin\r\n ADockClient := FindDockClient(Zone.ChildControl);\r\n if (ADockClient <> nil) and not ADockClient.EnableCloseButton then\r\n Exit;\r\n {$IFDEF JVCLThemesEnabled}\r\n if ThemeServices.{$IFDEF RTL230_UP}Available{$ELSE}ThemesAvailable{$ENDIF RTL230_UP} and ThemeServices.{$IFDEF RTL230_UP}Enabled{$ELSE}ThemesEnabled{$ENDIF RTL230_UP} then\r\n begin\r\n if GrabberSize < 14 then\r\n begin\r\n CurrentThemeType := twSmallCloseButtonNormal;\r\n if AZone.CloseBtnDown then\r\n CurrentThemeType := twSmallCloseButtonPushed;\r\n end\r\n else\r\n begin\r\n CurrentThemeType := twCloseButtonNormal;\r\n if AZone.CloseBtnDown then\r\n CurrentThemeType := twCloseButtonPushed;\r\n end;\r\n Details := ThemeServices.GetElementDetails(CurrentThemeType);\r\n ThemeServices.DrawElement(Canvas.Handle, Details, Classes.Rect(Left, Top, Left + ButtonWidth, Top + ButtonHeight));\r\n end\r\n else\r\n {$ENDIF JVCLThemesEnabled}\r\n DrawFrameControl(Canvas.Handle, Classes.Rect(Left, Top, Left + ButtonWidth,\r\n Top + ButtonHeight), DFC_CAPTION, DFCS_CAPTIONCLOSE or Integer(AZone.CloseBtnDown) * DFCS_PUSHED)\r\n end;\r\nend;\r\n\r\nprocedure TJvDockVIDVCTree.GetCaptionRect(var Rect: TRect);\r\nbegin\r\n case GrabbersPosition of\r\n gpTop:\r\n Rect.Bottom := Rect.Top + GrabberSize + 2;\r\n gpLeft:\r\n Rect.Right := Rect.Left + GrabberSize + 2;\r\n end;\r\n\r\nend;\r\n\r\n{procedure TJvDockVIDVCTree.AdjustDockRect(Control: TControl;\r\n var ARect: TRect);\r\nbegin\r\n if (DockSite.Align <> alClient) or (TopZone.VisibleChildTotal > 1) then\r\n inherited AdjustDockRect(Control, ARect);\r\nend; }\r\n\r\nprocedure TJvDockVIDVCTree.IgnoreZoneInfor(Stream: TMemoryStream);\r\nvar\r\n CompName: string;\r\nbegin\r\n Stream.Position := Stream.Position + 6;\r\n ReadControlName(Stream, CompName);\r\nend;\r\n\r\n//=== { TJvDockVIDVCConjoinPanel } ===========================================\r\n\r\nprocedure TJvDockVIDVCConjoinPanel.CustomDockDrop(Source: TJvDockDragDockObject;\r\n X, Y: Integer);\r\nbegin\r\n if not ((Source.Control.HostDockSite <> nil) and\r\n (Source.DropOnControl = Source.Control.HostDockSite.Parent) and\r\n (Source.DropAlign = alClient)) then\r\n begin\r\n inherited CustomDockDrop(Source, X, Y);\r\n ParentForm.Caption := '';\r\n {$IFNDEF COMPILER9_UP}\r\n InvalidateDockHostSiteOfControl(Source.Control, False);\r\n {$ENDIF !COMPILER9_UP}\r\n if (Source.Control is TWinControl) and Source.Control.Visible and\r\n TWinControl(Source.Control).CanFocus then\r\n TWinControl(Source.Control).SetFocus;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockVIDVCConjoinPanel.CustomDockOver(Source: TJvDockDragDockObject; X,\r\n Y: Integer; State: TDragState; var Accept: Boolean);\r\nvar\r\n DropAlign: TAlign;\r\nbegin\r\n inherited CustomDockOver(Source, X, Y, State, Accept);\r\n if Accept and (Source is TJvDockVIDVCDragDockObject) then\r\n if State = dsDragMove then\r\n begin\r\n DropAlign := Source.DropAlign;\r\n JvDockManager.GetDockEdge(Source.EraseDockRect, Source.DragPos, DropAlign, Source.Control);\r\n end;\r\nend;\r\n\r\nprocedure TJvDockVIDVCConjoinPanel.CustomGetDockEdge(Source: TJvDockDragDockObject;\r\n MousePos: TPoint; var DropAlign: TAlign);\r\nbegin\r\nend;\r\n\r\nprocedure TJvDockVIDVCConjoinPanel.CustomGetSiteInfo(Source: TJvDockDragDockObject; Client: TControl;\r\n var InfluenceRect: TRect; MousePos: TPoint; var CanDock: Boolean);\r\nbegin\r\n JvDockManager.GetSiteInfo(Client, InfluenceRect, MousePos, CanDock);\r\n CanDock := IsDockable(Self, Client, Source.DropOnControl, Source.DropAlign);\r\nend;\r\n\r\nfunction TJvDockVIDVCConjoinPanel.CustomUnDock(Source: TJvDockDragDockObject; NewTarget: TWinControl;\r\n Client: TControl): Boolean;\r\nbegin\r\n Result := inherited CustomUnDock(Source, NewTarget, Client);\r\nend;\r\n\r\nprocedure TJvDockVIDVCConjoinPanel.DockDrop(Source: TDragDockObject;\r\n X, Y: Integer);\r\nbegin\r\n inherited DockDrop(Source, X, Y);\r\nend;\r\n\r\nprocedure TJvDockVIDVCConjoinPanel.UpdateCaption(Exclude: TControl);\r\nbegin\r\n if VisibleDockClientCount > 1 then\r\n ParentForm.Caption := ''\r\n else\r\n inherited UpdateCaption(Exclude);\r\n Invalidate;\r\nend;\r\n\r\n//=== { TJvDockNewTabPageControl } ===========================================\r\n\r\nconstructor TJvDockVIDVCTabPageControl.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FPanel := nil;\r\n TabWidth := 1;\r\n MultiLine := True;\r\n TabSheetClass := TJvDockVIDVCTabSheet;\r\n TabPanelClass := TJvDockTabPanel;\r\n FTempSheet := nil;\r\n TabPosition := tpBottom;\r\n FTabImageList := nil;\r\n Images := nil;\r\n if AOwner is TJvDockTabHostForm then\r\n begin\r\n FTabImageList := TCustomImageList.Create(AOwner);\r\n {$IFDEF RTL200_UP}\r\n FTabImageList.ColorDepth := cd32Bit;\r\n {$ENDIF RTL200_UP}\r\n Images := FTabImageList;\r\n end;\r\nend;\r\n\r\ndestructor TJvDockVIDVCTabPageControl.Destroy;\r\nbegin\r\n if FTabImageList <> nil then\r\n begin\r\n FTabImageList.Free;\r\n FTabImageList := nil;\r\n end;\r\n if FPanel <> nil then\r\n begin\r\n FPanel.Free;\r\n FPanel := nil;\r\n end;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvDockVIDVCTabPageControl.AfterConstruction;\r\nbegin\r\n inherited AfterConstruction;\r\n CreatePanel;\r\nend;\r\n\r\nprocedure TJvDockVIDVCTabPageControl.Loaded;\r\nbegin\r\n inherited Loaded;\r\n CreatePanel;\r\nend;\r\n\r\nprocedure TJvDockVIDVCTabPageControl.CreatePanel;\r\nbegin\r\n if FPanel = nil then\r\n begin\r\n FPanel := TabPanelClass.Create(Self);\r\n FPanel.Page := Self;\r\n FPanel.Parent := Self;\r\n FPanel.TabLeftOffset := 5;\r\n FPanel.TabRightOffset := 5;\r\n FPanel.TabTopOffset := 3;\r\n FPanel.TabBottomOffset := 3;\r\n ActiveSheetColor := clBtnFace;\r\n InactiveSheetColor := clBtnShadow;\r\n end;\r\n Resize;\r\nend;\r\n\r\nprocedure TJvDockVIDVCTabPageControl.CreateWnd;\r\nbegin\r\n inherited CreateWnd;\r\nend;\r\n\r\nprocedure TJvDockVIDVCTabPageControl.CustomDockDrop(Source: TJvDockDragDockObject;\r\n X, Y: Integer);\r\nvar\r\n ARect: TRect;\r\n I: Integer;\r\n VIDSource: TJvDockVIDVCDragDockObject;\r\n DockClient: TJvDockClient;\r\n Host: TJvDockConjoinHostForm;\r\n Index: Integer;\r\nbegin\r\n if Source.DropAlign in [alClient, alNone] then\r\n begin\r\n if Source is TJvDockVIDVCDragDockObject then\r\n begin\r\n BeginDockLoading;\r\n try\r\n DoFloatForm(Source.Control);\r\n FreeAllDockableForm;\r\n VIDSource := TJvDockVIDVCDragDockObject(Source);\r\n\r\n for I := 0 to VIDSource.SourceDockClientCount - 1 do\r\n begin\r\n Source.Control := VIDSource.SourceDockClients[I];\r\n inherited CustomDockDrop(Source, X, Y);\r\n if Source.Control is TCustomForm then\r\n if FTabImageList <> nil then\r\n begin\r\n Index := FTabImageList.AddIcon(TForm(Source.Control).Icon);\r\n if Index <> -1 then\r\n ActivePage.ImageIndex := Index;\r\n end;\r\n end;\r\n finally\r\n EndDockLoading;\r\n JvGlobalDockManager.DragObject.Control := nil;\r\n end;\r\n end;\r\n end\r\n else\r\n begin\r\n DockClient := FindDockClient(ParentForm);\r\n if DockClient <> nil then\r\n begin\r\n ARect := ParentForm.BoundsRect;\r\n Host := DockClient.CreateConjoinHostAndDockControl(ParentForm, Source.Control, Source.DropAlign);\r\n Host.BoundsRect := ARect;\r\n SetDockSite(ParentForm, False);\r\n SetDockSite(TWinControl(Source.Control), False);\r\n Host.Visible := True;\r\n end;\r\n end;\r\n FPanel.SelectSheet := nil;\r\n ParentForm.Caption := ActivePage.Caption;\r\nend;\r\n\r\nprocedure TJvDockVIDVCTabPageControl.CustomDockOver(Source: TJvDockDragDockObject;\r\n X, Y: Integer; State: TDragState; var Accept: Boolean);\r\nvar\r\n ARect: TRect;\r\nbegin\r\n { This procedure is called when a dockable form is dragged over a\r\n undocked (stand-alone) tab page controls }\r\n Accept := IsDockable(Self, Source.Control, Source.DropOnControl, Source.DropAlign);\r\n if Accept then\r\n begin\r\n if ParentForm.HostDockSite = nil then\r\n begin\r\n Source.DropAlign := ComputeVIDDockingRect(Self, Source.Control, ARect, Point(X, Y));\r\n if Source.DropAlign = alClient then\r\n ARect.Top := ARect.Top + JvDockGetSysCaptionHeight;\r\n\r\n if Accept and (Source.DropAlign <> alNone) then\r\n begin\r\n Source.DockRect := ARect;\r\n gi_DockRect := ARect;\r\n end;\r\n end\r\n else\r\n begin\r\n if ParentForm.HostDockSite is TJvDockCustomPanel then\r\n begin\r\n ARect := Source.DockRect;\r\n TJvDockCustomPanel(ParentForm.HostDockSite).JvDockManager.PositionDockRect(Source.Control, Source.DropOnControl,\r\n Source.DropAlign, ARect);\r\n Source.DockRect := ARect;\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockVIDVCTabPageControl.CustomGetSiteInfo(Source: TJvDockDragDockObject; Client: TControl;\r\n var InfluenceRect: TRect; MousePos: TPoint; var CanDock: Boolean);\r\nconst\r\n DefExpandoRect = 20;\r\nvar\r\n CH_BW: Integer;\r\n ARect: TRect;\r\nbegin\r\n CanDock := IsDockable(Self, Client, Source.DropOnControl, Source.DropAlign);\r\n if ParentForm.HostDockSite <> nil then\r\n CanDock := False;\r\n if CanDock then\r\n begin\r\n GetWindowRect(Parent.Handle, InfluenceRect);\r\n if PtInRect(InfluenceRect, MousePos) then\r\n begin\r\n ARect := InfluenceRect;\r\n InflateRect(ARect, -DefExpandoRect, -DefExpandoRect);\r\n\r\n CH_BW := JvDockGetSysCaptionHeightAndBorderWidth;\r\n Inc(ARect.Top, CH_BW + 1);\r\n Dec(ARect.Bottom, TabHeight);\r\n if PtInRect(ARect, MousePos) then\r\n InfluenceRect := Classes.Rect(0, 0, 0, 0);\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockVIDVCTabPageControl.Change;\r\nbegin\r\n inherited Change;\r\n ParentForm.Caption := ActivePage.Caption;\r\n\r\n if ParentForm.HostDockSite is TJvDockCustomPanel then\r\n begin\r\n // if ParentForm.Visible and ParentForm.CanFocus then\r\n // ParentForm.SetFocus;\r\n ParentForm.HostDockSite.Invalidate;\r\n end;\r\n // if (ActivePage <> nil) and (ActivePage.Visible) and (ActivePage.CanFocus) then\r\n // if ParentForm.Visible and ParentForm.CanFocus then\r\n // ActivePage.SetFocus;\r\nend;\r\n\r\nprocedure TJvDockVIDVCTabPageControl.AdjustClientRect(var Rect: TRect);\r\nbegin\r\n Rect := ClientRect;\r\n if (Parent is TJvDockTabHostForm) and (VisibleDockClientCount = 1) then\r\n Exit;\r\n case TabPosition of\r\n tpTop:\r\n Inc(Rect.Top, Panel.FTabHeight - 1);\r\n tpBottom:\r\n Dec(Rect.Bottom, Panel.FTabHeight - 1);\r\n tpLeft:\r\n Inc(Rect.Left, Panel.FTabHeight - 1);\r\n tpRight:\r\n Dec(Rect.Right, Panel.FTabHeight - 1);\r\n end;\r\nend;\r\n\r\nprocedure TJvDockVIDVCTabPageControl.CreateParams(var Params: TCreateParams);\r\nbegin\r\n inherited CreateParams(Params);\r\nend;\r\n\r\nprocedure TJvDockVIDVCTabPageControl.DrawTab(TabIndex: Integer;\r\n const Rect: TRect; Active: Boolean);\r\nbegin\r\n inherited DrawTab(TabIndex, Rect, Active);\r\nend;\r\n\r\nfunction TJvDockVIDVCTabPageControl.GetActiveFont: TFont;\r\nbegin\r\n Result := FPanel.FActiveFont;\r\nend;\r\n\r\nfunction TJvDockVIDVCTabPageControl.GetActiveSheetColor: TColor;\r\nbegin\r\n Result := FPanel.FActiveSheetColor;\r\nend;\r\n\r\nfunction TJvDockVIDVCTabPageControl.GetInactiveFont: TFont;\r\nbegin\r\n Result := FPanel.FInactiveFont;\r\nend;\r\n\r\nfunction TJvDockVIDVCTabPageControl.GetInactiveSheetColor: TColor;\r\nbegin\r\n Result := FPanel.Color;\r\nend;\r\n\r\nfunction TJvDockVIDVCTabPageControl.GetTabBottomOffset: Integer;\r\nbegin\r\n Result := FPanel.TabBottomOffset;\r\nend;\r\n\r\nfunction TJvDockVIDVCTabPageControl.GetTabLeftOffset: Integer;\r\nbegin\r\n Result := FPanel.TabLeftOffset;\r\nend;\r\n\r\nfunction TJvDockVIDVCTabPageControl.GetTabRightOffset: Integer;\r\nbegin\r\n Result := FPanel.TabRightOffset;\r\nend;\r\n\r\nfunction TJvDockVIDVCTabPageControl.GetTabTopOffset: Integer;\r\nbegin\r\n Result := FPanel.TabTopOffset;\r\nend;\r\n\r\nprocedure TJvDockVIDVCTabPageControl.Paint;\r\nbegin\r\n inherited Paint;\r\nend;\r\n\r\nprocedure TJvDockVIDVCTabPageControl.Resize;\r\nbegin\r\n inherited Resize;\r\n if FPanel = nil then\r\n Exit;\r\n case TabPosition of\r\n tpLeft:\r\n begin\r\n FPanel.Left := 0;\r\n FPanel.Width := Panel.FTabHeight;\r\n FPanel.Top := 0;\r\n FPanel.Height := Height;\r\n end;\r\n tpRight:\r\n begin\r\n FPanel.Left := Width - Panel.FTabHeight;\r\n FPanel.Top := 0;\r\n FPanel.Width := Panel.FTabHeight;\r\n FPanel.Height := Height;\r\n end;\r\n tpTop:\r\n begin\r\n FPanel.Left := 0;\r\n FPanel.Top := 0;\r\n FPanel.Width := Width;\r\n FPanel.Height := Panel.FTabHeight;\r\n end;\r\n tpBottom:\r\n begin\r\n FPanel.Left := 0;\r\n FPanel.Top := Height - Panel.FTabHeight;\r\n FPanel.Width := Width;\r\n FPanel.Height := Panel.FTabHeight;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockVIDVCTabPageControl.SetActiveFont(Value: TFont);\r\nbegin\r\n FPanel.FActiveFont.Assign(Value);\r\n if ActivePage <> nil then\r\n TJvDockVIDVCTabSheet(ActivePage).SetSheetSort(ActivePage.Caption);\r\n FPanel.Invalidate;\r\nend;\r\n\r\nprocedure TJvDockVIDVCTabPageControl.SetActiveSheetColor(const Value: TColor);\r\nbegin\r\n FPanel.FActiveSheetColor := Value;\r\n FPanel.Invalidate;\r\nend;\r\n\r\nprocedure TJvDockVIDVCTabPageControl.SetInactiveFont(Value: TFont);\r\nvar\r\n I: Integer;\r\nbegin\r\n FPanel.FInactiveFont.Assign(Value);\r\n for I := 0 to Count - 1 do\r\n if Pages[I] <> ActivePage then\r\n TJvDockVIDVCTabSheet(Pages[I]).SetSheetSort(Pages[I].Caption);\r\n FPanel.Invalidate;\r\nend;\r\n\r\nprocedure TJvDockVIDVCTabPageControl.SetInactiveSheetColor(const Value: TColor);\r\nbegin\r\n if FPanel.Color <> Value then\r\n begin\r\n FPanel.Color := Value;\r\n FPanel.Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockVIDVCTabPageControl.SetTabBottomOffset(const Value: Integer);\r\nbegin\r\n if FPanel.TabBottomOffset <> Value then\r\n begin\r\n FPanel.TabBottomOffset := Value;\r\n FPanel.Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockVIDVCTabPageControl.SetTabHeight(Value: Smallint);\r\nbegin\r\n inherited SetTabHeight(Value);\r\n if Panel.FTabHeight <> Value then\r\n begin\r\n Panel.FTabHeight := Value;\r\n FPanel.Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockVIDVCTabPageControl.SetTabLeftOffset(const Value: Integer);\r\nbegin\r\n if FPanel.TabLeftOffset <> Value then\r\n begin\r\n FPanel.TabLeftOffset := Value;\r\n FPanel.Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockVIDVCTabPageControl.SetTabPosition(Value: TTabPosition);\r\nbegin\r\n Assert(Value in [tpTop, tpBottom], RsEDockCannotSetTabPosition);\r\n inherited SetTabPosition(Value);\r\n Resize;\r\nend;\r\n\r\nprocedure TJvDockVIDVCTabPageControl.SetTabRightOffset(const Value: Integer);\r\nbegin\r\n if FPanel.TabRightOffset <> Value then\r\n begin\r\n FPanel.TabRightOffset := Value;\r\n FPanel.Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockVIDVCTabPageControl.SetTabTopOffset(const Value: Integer);\r\nbegin\r\n if FPanel.TabTopOffset <> Value then\r\n begin\r\n FPanel.TabTopOffset := Value;\r\n FPanel.Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockVIDVCTabPageControl.SetActivePage(Page: TJvDockTabSheet);\r\nbegin\r\n inherited SetActivePage(Page);\r\n FPanel.Invalidate;\r\nend;\r\n\r\nprocedure TJvDockVIDVCTabPageControl.DockDrop(Source: TDragDockObject;\r\n X, Y: Integer);\r\nvar\r\n Index: Integer;\r\n NewPage: TJvDockTabSheet;\r\nbegin\r\n inherited DockDrop(Source, X, Y);\r\n FPanel.SelectSheet := nil;\r\n if ActivePage <> nil then\r\n ParentForm.Caption := ActivePage.Caption;\r\n if Source.Control is TCustomForm then\r\n begin\r\n if Source.Control.Parent is TJvDockTabSheet then\r\n NewPage := TJvDockTabSheet(Source.Control.Parent)\r\n else\r\n NewPage := nil;\r\n if Source.Control.Visible and Assigned(NewPage) then\r\n ActivePage := NewPage;\r\n if FTabImageList <> nil then\r\n begin\r\n Index := FTabImageList.AddIcon(TForm(Source.Control).Icon);\r\n if (Index <> -1) and Assigned(NewPage) then\r\n NewPage.ImageIndex := Index;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJvDockVIDVCTabPageControl.GetDockClientFromMousePos(MousePos: TPoint): TControl;\r\nvar\r\n PageIndex: Integer;\r\nbegin\r\n Result := nil;\r\n case TabPosition of\r\n tpTop:\r\n PageIndex := Panel.FindSheetWithPos(MousePos.X, MousePos.Y, 0, Panel.Height - TabBottomOffset);\r\n tpBottom:\r\n PageIndex := Panel.FindSheetWithPos(MousePos.X, MousePos.Y, TabBottomOffset, Panel.Height);\r\n tpLeft:\r\n PageIndex := Panel.FindSheetWithPos(MousePos.Y, MousePos.X, 0, Panel.Height - TabBottomOffset);\r\n tpRight:\r\n PageIndex := Panel.FindSheetWithPos(MousePos.Y, MousePos.X, TabBottomOffset, Panel.Height);\r\n else\r\n PageIndex := -1;\r\n end;\r\n if PageIndex >= 0 then\r\n begin\r\n Result := Pages[PageIndex].Controls[0];\r\n if Result.HostDockSite <> Self then\r\n Result := nil;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockVIDVCTabPageControl.CustomGetDockEdge(Source: TJvDockDragDockObject;\r\n MousePos: TPoint; var DropAlign: TAlign);\r\nvar\r\n ARect: TRect;\r\nbegin\r\n DropAlign := ComputeVIDDockingRect(Self, Source.Control, ARect, MousePos);\r\nend;\r\n\r\nfunction TJvDockVIDVCTabPageControl.GetVisibleSheetCount: Integer;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := 0;\r\n for I := 0 to Count - 1 do\r\n if Pages[I].TabVisible then\r\n Inc(Result);\r\nend;\r\n\r\nprocedure TJvDockVIDVCTabPageControl.UpdateCaption(Exclude: TControl);\r\nbegin\r\n ParentForm.Caption := ActivePage.Caption;\r\n if Parent <> nil then\r\n begin\r\n Parent.Invalidate;\r\n if Parent.HostDockSite <> nil then\r\n Parent.HostDockSite.Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockVIDVCTabPageControl.SetHotTrack(Value: Boolean);\r\nbegin\r\n inherited SetHotTrack(Value);\r\nend;\r\n\r\nprocedure TJvDockVIDVCTabPageControl.SetImages(Value: TCustomImageList);\r\nbegin\r\n inherited SetImages(Value);\r\n if Panel <> nil then\r\n begin\r\n Panel.ShowTabImages := Value <> nil;\r\n Panel.Invalidate;\r\n end;\r\nend;\r\n\r\nfunction TJvDockVIDVCTabPageControl.GetHotTrackColor: TColor;\r\nbegin\r\n Result := Panel.FHotTrackColor;\r\nend;\r\n\r\nprocedure TJvDockVIDVCTabPageControl.SetHotTrackColor(const Value: TColor);\r\nbegin\r\n if Panel.FHotTrackColor <> Value then\r\n begin\r\n Panel.FHotTrackColor := Value;\r\n Panel.Invalidate;\r\n end;\r\nend;\r\n\r\nfunction TJvDockVIDVCTabPageControl.GetShowTabImages: Boolean;\r\nbegin\r\n Result := FPanel.FShowTabImages;\r\nend;\r\n\r\nprocedure TJvDockVIDVCTabPageControl.SetShowTabImages(const Value: Boolean);\r\nbegin\r\n FPanel.ShowTabImages := Value;\r\nend;\r\n\r\nfunction TJvDockVIDVCTabPageControl.CustomUnDock(Source: TJvDockDragDockObject;\r\n NewTarget: TWinControl; Client: TControl): Boolean;\r\nvar\r\n CurrPage: TJvDockTabSheet;\r\n I: Integer;\r\nbegin\r\n if not ((Source.Control.HostDockSite <> nil) and\r\n (Source.DropOnControl = Source.Control.HostDockSite.Parent) and\r\n (Source.DropAlign = alClient)) then\r\n begin\r\n CurrPage := GetPageFromDockClient(Client);\r\n if CurrPage <> nil then\r\n begin\r\n if (FTabImageList <> nil) and ShowTabImages and\r\n (FTabImageList.Count > CurrPage.ImageIndex) then\r\n begin\r\n FTabImageList.Delete(CurrPage.ImageIndex);\r\n for I := 0 to Count - 1 do\r\n if Pages[I].ImageIndex > CurrPage.ImageIndex then\r\n Pages[I].ImageIndex := Pages[I].ImageIndex - 1;\r\n end;\r\n end;\r\n Result := inherited CustomUnDock(Source, NewTarget, Client);\r\n end\r\n else\r\n Result := True;\r\nend;\r\n\r\nfunction TJvDockVIDVCTabPageControl.GetPage(Index: Integer): TJvDockVIDVCTabSheet;\r\nbegin\r\n Result := TJvDockVIDVCTabSheet(inherited Pages[Index]);\r\nend;\r\n\r\nfunction TJvDockVIDVCTabPageControl.GetActiveVIDPage: TJvDockVIDVCTabSheet;\r\nbegin\r\n Result := TJvDockVIDVCTabSheet(inherited ActivePage);\r\nend;\r\n\r\nprocedure TJvDockVIDVCTabPageControl.SetActiveVIDPage(const Value: TJvDockVIDVCTabSheet);\r\nbegin\r\n ActivePage := Value;\r\nend;\r\n\r\n//=== { TJvDockTabPanel } ====================================================\r\n\r\nconstructor TJvDockTabPanel.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n Page := nil;\r\n FCaptionTopOffset := 0;\r\n FCaptionLeftOffset := 5;\r\n FCaptionRightOffset := 5;\r\n FTabBottomOffset := 3;\r\n FTabSplitterWidth := 3;\r\n FTabHeight := 22;\r\n FSortList := TList.Create;\r\n FActiveFont := TFont.Create;\r\n FActiveFont.Color := clBlack;\r\n FInactiveFont := TFont.Create;\r\n FInactiveFont.Color := clWhite;\r\n FHotTrackColor := clBlue;\r\n FTempPages := TList.Create;\r\n FSelectHotIndex := -1;\r\n FShowTabImages := False;\r\n FSelectSheet := nil;\r\nend;\r\n\r\ndestructor TJvDockTabPanel.Destroy;\r\nbegin\r\n FActiveFont.Free;\r\n FInactiveFont.Free;\r\n FSortList.Free;\r\n FTempPages.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvDockTabPanel.DeleteSorts(Sheet: TJvDockVIDVCTabSheet);\r\nvar\r\n SheetIndex: Integer;\r\nbegin\r\n SheetIndex := FSortList.IndexOf(Sheet);\r\n if SheetIndex >= 0 then\r\n FSortList.Delete(SheetIndex);\r\n if Sheet <> nil then\r\n Sheet.TabVisible := False;\r\n SetShowTabWidth;\r\n Page.Invalidate;\r\nend;\r\n\r\nfunction TJvDockTabPanel.FindSheetWithPos(cX, cY, cTopOffset, cBottomOffset: Integer): Integer;\r\nvar\r\n I: Integer;\r\n CompleteWidth, CurrTabWidth: Integer;\r\n Pages: TList;\r\nbegin\r\n Result := -1;\r\n if (cY > cBottomOffset) or (cY < cTopOffset) then\r\n Exit;\r\n CompleteWidth := 0;\r\n if FSelectSheet = nil then\r\n Pages := Page.PageSheets\r\n else\r\n Pages := FTempPages;\r\n for I := 0 to Pages.Count - 1 do\r\n begin\r\n if not TJvDockVIDVCTabSheet(Pages[I]).TabVisible then\r\n Continue;\r\n CurrTabWidth := TJvDockVIDVCTabSheet(Pages[I]).ShowTabWidth;\r\n if (cX >= FTabLeftOffset + CompleteWidth) and (cX <= FTabLeftOffset + CurrTabWidth + CompleteWidth +\r\n FTabSplitterWidth) then\r\n begin\r\n Result := I;\r\n Exit;\r\n end;\r\n Inc(CompleteWidth, CurrTabWidth + FTabSplitterWidth);\r\n end;\r\nend;\r\n\r\nfunction TJvDockTabPanel.GetPageIndexFromMousePos(X, Y: Integer): Integer;\r\nbegin\r\n Result := -1;\r\n case Page.TabPosition of\r\n tpTop:\r\n Result := FindSheetWithPos(X, Y, 0, Height - TabBottomOffset);\r\n tpBottom:\r\n Result := FindSheetWithPos(X, Y, TabBottomOffset, Height);\r\n tpLeft:\r\n Result := FindSheetWithPos(Y, X, 0, Height - TabBottomOffset);\r\n tpRight:\r\n Result := FindSheetWithPos(Y, X, TabBottomOffset, Height);\r\n end;\r\nend;\r\n\r\nfunction TJvDockTabPanel.GetMaxTabWidth: TJvDockTabSheet;\r\nvar\r\n I: Integer;\r\n MaxWidth, CurrWidth: Integer;\r\nbegin\r\n Result := nil;\r\n MaxWidth := 0;\r\n if Page = nil then\r\n Exit;\r\n for I := 0 to Page.Count - 1 do\r\n begin\r\n CurrWidth := Canvas.TextWidth(Page.Tabs[I]);\r\n if MaxWidth < CurrWidth then\r\n begin\r\n Result := Page.Pages[I];\r\n MaxWidth := CurrWidth;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJvDockTabPanel.GetMinTabWidth: TJvDockTabSheet;\r\nvar\r\n I: Integer;\r\n MinWidth, CurrWidth: Integer;\r\nbegin\r\n Result := nil;\r\n MinWidth := 0;\r\n for I := 0 to Page.Count - 1 do\r\n begin\r\n CurrWidth := Canvas.TextWidth(Page.Tabs[I]);\r\n if MinWidth > CurrWidth then\r\n begin\r\n Result := Page.Pages[I];\r\n MinWidth := CurrWidth;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJvDockTabPanel.GetPanelHeight: Integer;\r\nbegin\r\n case Page.TabPosition of\r\n tpLeft, tpRight:\r\n Result := Width;\r\n tpTop, tpBottom:\r\n Result := Height;\r\n else\r\n Result := 0;\r\n end;\r\nend;\r\n\r\nfunction TJvDockTabPanel.GetPanelWidth: Integer;\r\nbegin\r\n case Page.TabPosition of\r\n tpLeft, tpRight:\r\n Result := Height;\r\n tpTop, tpBottom:\r\n Result := Width;\r\n else\r\n Result := 0;\r\n end;\r\nend;\r\n\r\nfunction TJvDockTabPanel.GetSorts(Index: Integer): TJvDockVIDVCTabSheet;\r\nbegin\r\n Result := FSortList[Index];\r\nend;\r\n\r\nfunction TJvDockTabPanel.GetTotalTabWidth: Integer;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := 0;\r\n if FSortList = nil then\r\n Exit;\r\n for I := 0 to FSortList.Count - 1 do\r\n Inc(Result, Sorts[I].TabWidth + Integer(I <> FSortList.Count - 1) * FTabSplitterWidth);\r\nend;\r\n\r\nprocedure TJvDockTabPanel.MouseDown(Button: TMouseButton; Shift: TShiftState;\r\n X, Y: Integer);\r\nvar\r\n Ctrl: TControl;\r\n Index: Integer;\r\n Msg: TWMMouse;\r\n Sheet: TJvDockVIDVCTabSheet;\r\n AParentForm: TCustomForm;\r\nbegin\r\n inherited MouseDown(Button, Shift, X, Y);\r\n if Page = nil then\r\n Exit;\r\n\r\n Index := GetPageIndexFromMousePos(X, Y);\r\n if Index >= 0 then\r\n begin\r\n if Index <> Page.ActivePageIndex then\r\n begin\r\n if Assigned(Page.ActivePage) and Page.ActivePage.CanFocus then\r\n begin\r\n AParentForm := GetParentForm(Page);\r\n if Assigned(AParentForm) then\r\n AParentForm.ActiveControl := Page.ActivePage;\r\n end;\r\n Sheet := Page.ActiveVIDPage;\r\n Page.ActivePageIndex := Index;\r\n Sheet.SetSheetSort(Sheet.Caption);\r\n Page.ActiveVIDPage.SetSheetSort(Page.ActiveVIDPage.Caption);\r\n Page.Change;\r\n Invalidate;\r\n end;\r\n\r\n if Button = mbLeft then\r\n begin\r\n FSelectSheet := TJvDockVIDVCTabSheet(Page.ActivePage);\r\n FTempPages.Assign(Page.PageSheets);\r\n end;\r\n\r\n Ctrl := GetDockClientFromPageIndex(Index);\r\n if Ctrl <> nil then\r\n begin\r\n JvGlobalDockClient := FindDockClient(Ctrl);\r\n if JvGlobalDockClient <> nil then\r\n begin\r\n Msg.Msg := WM_NCLBUTTONDOWN + Integer(Button) * 3 + Integer(ssDouble in Shift) * 2;\r\n Msg.Pos.x := X;\r\n Msg.Pos.y := Y;\r\n if not (ssDouble in Shift) then\r\n JvGlobalDockClient.DoNCButtonDown(Page.DoMouseEvent(Msg, Page), Button, msTabPage)\r\n else\r\n begin\r\n JvGlobalDockClient.DoNCButtonDblClk(Page.DoMouseEvent(Msg, Page), Button, msTabPage);\r\n if (Button = mbLeft) and JvGlobalDockClient.CanFloat then\r\n Ctrl.ManualDock(nil, nil, alNone);\r\n end;\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockTabPanel.MouseMove(Shift: TShiftState; X, Y: Integer);\r\nvar\r\n Index: Integer;\r\n Ctrl: TControl;\r\n ARect: TRect;\r\nbegin\r\n inherited MouseMove(Shift, X, Y);\r\n Index := GetPageIndexFromMousePos(X, Y);\r\n if Page.HotTrack and (Index <> FSelectHotIndex) then\r\n begin\r\n FSelectHotIndex := Index;\r\n Invalidate;\r\n end;\r\n\r\n if Assigned(FSelectSheet) then\r\n begin\r\n Index := GetPageIndexFromMousePos(X, Y);\r\n if Index >= 0 then\r\n begin\r\n if (Index <> Page.ActivePageIndex) and (Page.Count > Index) then\r\n begin\r\n FSelectSheet.PageIndex := Index;\r\n Invalidate;\r\n end;\r\n end\r\n else\r\n begin\r\n case Page.TabPosition of\r\n tpTop:\r\n ARect := Classes.Rect(0, 0, Width, Height - FTabBottomOffset);\r\n tpBottom:\r\n ARect := Classes.Rect(0, FTabBottomOffset, Width, Height);\r\n tpLeft:\r\n ARect := Classes.Rect(0, 0, Width - FTabBottomOffset, Height);\r\n tpRight:\r\n ARect := Classes.Rect(FTabBottomOffset, 0, Width, Height);\r\n else\r\n ARect := Classes.Rect(0, 0, 0, 0);\r\n end;\r\n if PtInRect(ARect, Point(X, Y)) then\r\n Exit;\r\n if Page.FTempSheet = nil then\r\n begin\r\n Ctrl := GetDockClientFromPageIndex(FSelectSheet.PageIndex);\r\n if Ctrl <> nil then\r\n JvGlobalDockManager.BeginDrag(Ctrl, False, 1);\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockTabPanel.MouseUp(Button: TMouseButton; Shift: TShiftState;\r\n X, Y: Integer);\r\nvar\r\n Ctrl: TControl;\r\n Index: Integer;\r\n Msg: TWMMouse;\r\nbegin\r\n inherited MouseUp(Button, Shift, X, Y);\r\n FSelectSheet := nil;\r\n if Page = nil then\r\n Exit;\r\n\r\n Index := GetPageIndexFromMousePos(X, Y);\r\n Ctrl := GetDockClientFromPageIndex(Index);\r\n if Ctrl <> nil then\r\n begin\r\n JvGlobalDockClient := FindDockClient(Ctrl);\r\n if JvGlobalDockClient <> nil then\r\n begin\r\n Msg.Msg := WM_NCLBUTTONUP + Integer(Button) * 3 + Integer(ssDouble in Shift) * 2;\r\n Msg.Pos := PointToSmallPoint(Page.ScreenToClient(ClientToScreen(Point(X, Y))));\r\n if not (ssDouble in Shift) then\r\n JvGlobalDockClient.DoNCButtonUp(Page.DoMouseEvent(Msg, Page), Button, msTabPage);\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockTabPanel.Paint;\r\nvar\r\n ARect: TRect;\r\n CurrTabWidth: Integer;\r\n I, CompleteWidth: Integer;\r\n ImageWidth: Integer;\r\n CaptionString: string;\r\nbegin\r\n inherited Paint;\r\n if Page = nil then\r\n Exit;\r\n\r\n if (Page.Images <> nil) and (Page.ShowTabImages) then\r\n ImageWidth := Page.Images.Width\r\n else\r\n ImageWidth := 0;\r\n\r\n Canvas.Brush.Color := Page.ActiveSheetColor;\r\n case Page.TabPosition of\r\n tpLeft:\r\n Canvas.FillRect(Classes.Rect(PanelHeight - FTabBottomOffset, 0, PanelHeight, PanelWidth));\r\n tpRight:\r\n Canvas.FillRect(Classes.Rect(0, 0, FTabBottomOffset, PanelWidth));\r\n tpTop:\r\n Canvas.FillRect(Classes.Rect(0, PanelHeight - FTabBottomOffset, PanelWidth, PanelHeight));\r\n tpBottom:\r\n Canvas.FillRect(Classes.Rect(0, 0, PanelWidth, FTabBottomOffset));\r\n end;\r\n\r\n case Page.TabPosition of\r\n tpTop, tpLeft:\r\n Canvas.Pen.Color := clWhite;\r\n tpBottom, tpRight:\r\n Canvas.Pen.Color := clBlack;\r\n end;\r\n\r\n case Page.TabPosition of\r\n tpLeft:\r\n begin\r\n Canvas.MoveTo(PanelHeight - FTabBottomOffset, 0);\r\n Canvas.LineTo(PanelHeight - FTabBottomOffset, PanelWidth);\r\n end;\r\n tpRight:\r\n begin\r\n Canvas.MoveTo(FTabBottomOffset, 0);\r\n Canvas.LineTo(FTabBottomOffset, PanelWidth);\r\n end;\r\n tpTop:\r\n begin\r\n Canvas.MoveTo(0, PanelHeight - FTabBottomOffset);\r\n Canvas.LineTo(PanelWidth, PanelHeight - FTabBottomOffset);\r\n end;\r\n tpBottom:\r\n begin\r\n Canvas.MoveTo(0, FTabBottomOffset);\r\n Canvas.LineTo(PanelWidth, FTabBottomOffset);\r\n end;\r\n end;\r\n\r\n CompleteWidth := 0;\r\n\r\n Canvas.Brush.Style := bsClear;\r\n\r\n for I := 0 to Page.Count - 1 do\r\n begin\r\n if not Page.Pages[I].TabVisible then\r\n Continue;\r\n\r\n CurrTabWidth := TJvDockVIDVCTabSheet(Page.Pages[I]).ShowTabWidth;\r\n\r\n if Page.ActivePageIndex = I then\r\n begin\r\n Canvas.Brush.Color := Page.ActiveSheetColor;\r\n case Page.TabPosition of\r\n tpLeft:\r\n Canvas.FillRect(Classes.Rect(FTabTopOffset, CompleteWidth + FTabLeftOffset,\r\n PanelHeight, CompleteWidth + FTabLeftOffset + CurrTabWidth));\r\n tpRight:\r\n Canvas.FillRect(Classes.Rect(FTabBottomOffset, CompleteWidth + FTabLeftOffset,\r\n PanelHeight - FTabTopOffset, CompleteWidth + FTabLeftOffset + CurrTabWidth));\r\n tpTop:\r\n Canvas.FillRect(Classes.Rect(CompleteWidth + FTabLeftOffset, FTabTopOffset,\r\n CompleteWidth + FTabLeftOffset + CurrTabWidth, PanelHeight));\r\n tpBottom:\r\n Canvas.FillRect(Classes.Rect(CompleteWidth + FTabLeftOffset, FTabBottomOffset,\r\n CompleteWidth + FTabLeftOffset + CurrTabWidth, PanelHeight - FTabTopOffset));\r\n end;\r\n\r\n Canvas.Pen.Color := clWhite;\r\n case Page.TabPosition of\r\n tpLeft:\r\n begin\r\n Canvas.MoveTo(PanelHeight - FTabBottomOffset, CompleteWidth + FTabLeftOffset);\r\n Canvas.LineTo(FTabTopOffset, CompleteWidth + FTabLeftOffset);\r\n Canvas.LineTo(FTabTopOffset, CompleteWidth + FTabLeftOffset + CurrTabWidth);\r\n Canvas.Pen.Color := clBlack;\r\n Canvas.LineTo(PanelHeight - FTabBottomOffset, CompleteWidth + FTabLeftOffset + CurrTabWidth);\r\n end;\r\n tpRight:\r\n begin\r\n Canvas.MoveTo(FTabTopOffset, CompleteWidth + FTabLeftOffset);\r\n Canvas.LineTo(PanelHeight - FTabBottomOffset, CompleteWidth + FTabLeftOffset);\r\n Canvas.Pen.Color := clBlack;\r\n Canvas.LineTo(PanelHeight - FTabBottomOffset, CompleteWidth + FTabLeftOffset + CurrTabWidth);\r\n Canvas.LineTo(FTabTopOffset, CompleteWidth + FTabLeftOffset + CurrTabWidth);\r\n end;\r\n tpTop:\r\n begin\r\n Canvas.MoveTo(CompleteWidth + FTabLeftOffset, PanelHeight - FTabBottomOffset);\r\n Canvas.LineTo(CompleteWidth + FTabLeftOffset, FTabTopOffset);\r\n Canvas.LineTo(CompleteWidth + FTabLeftOffset + CurrTabWidth, FTabTopOffset);\r\n Canvas.Pen.Color := clBlack;\r\n Canvas.LineTo(CompleteWidth + FTabLeftOffset + CurrTabWidth, PanelHeight - FTabTopOffset);\r\n end;\r\n tpBottom:\r\n begin\r\n Canvas.MoveTo(CompleteWidth + FTabLeftOffset, FTabBottomOffset);\r\n Canvas.LineTo(CompleteWidth + FTabLeftOffset, PanelHeight - FTabTopOffset);\r\n Canvas.Pen.Color := clBlack;\r\n Canvas.LineTo(CompleteWidth + FTabLeftOffset + CurrTabWidth, PanelHeight - FTabTopOffset);\r\n Canvas.LineTo(CompleteWidth + FTabLeftOffset + CurrTabWidth, FTabBottomOffset);\r\n end;\r\n end;\r\n\r\n Canvas.Font.Assign(FActiveFont);\r\n end\r\n else\r\n begin\r\n if (I < Page.ActivePageIndex - 1) or (I > Page.ActivePageIndex) then\r\n begin\r\n Canvas.Pen.Color := Page.InactiveFont.Color;\r\n case Page.TabPosition of\r\n tpLeft, tpRight:\r\n begin\r\n Canvas.MoveTo(PanelHeight - FTabBottomOffset - 3, CompleteWidth + FTabLeftOffset + CurrTabWidth);\r\n Canvas.LineTo(FTabTopOffset + 2, CompleteWidth + FTabLeftOffset + CurrTabWidth);\r\n end;\r\n tpTop, tpBottom:\r\n begin\r\n Canvas.MoveTo(CompleteWidth + FTabLeftOffset + CurrTabWidth, PanelHeight - FTabBottomOffset - 3);\r\n Canvas.LineTo(CompleteWidth + FTabLeftOffset + CurrTabWidth, FTabTopOffset + 2);\r\n end;\r\n end;\r\n end;\r\n Canvas.Brush.Color := Page.InactiveSheetColor;\r\n Canvas.Font.Assign(FInactiveFont);\r\n end;\r\n\r\n if FSelectHotIndex = I then\r\n Canvas.Font.Color := FHotTrackColor;\r\n\r\n case Page.TabPosition of\r\n tpLeft:\r\n ARect := Classes.Rect(FTabTopOffset + FCaptionTopOffset + 1,\r\n CompleteWidth + FTabLeftOffset + FCaptionLeftOffset,\r\n PanelHeight,\r\n CompleteWidth + FTabLeftOffset + CurrTabWidth - FCaptionRightOffset);\r\n\r\n tpRight:\r\n ARect := Classes.Rect(FTabBottomOffset + FCaptionTopOffset + 1,\r\n CompleteWidth + FTabLeftOffset + FCaptionLeftOffset,\r\n PanelHeight,\r\n CompleteWidth + FTabLeftOffset + CurrTabWidth - FCaptionRightOffset);\r\n\r\n tpTop:\r\n ARect := Classes.Rect(CompleteWidth + FTabLeftOffset + FCaptionLeftOffset +\r\n Integer(FShowTabImages) * (ImageWidth + FCaptionLeftOffset),\r\n FTabTopOffset + FCaptionTopOffset + 1,\r\n CompleteWidth + FTabLeftOffset + CurrTabWidth - FCaptionRightOffset,\r\n PanelHeight);\r\n\r\n tpBottom:\r\n ARect := Classes.Rect(CompleteWidth + FTabLeftOffset + FCaptionLeftOffset +\r\n Integer(FShowTabImages) * (ImageWidth + FCaptionLeftOffset),\r\n FTabBottomOffset + FCaptionTopOffset + 1,\r\n CompleteWidth + FTabLeftOffset + CurrTabWidth - FCaptionRightOffset,\r\n PanelHeight);\r\n end;\r\n\r\n CaptionString := Page.Pages[I].Caption;\r\n DrawText(Canvas.Handle, PChar(CaptionString), Length(CaptionString),\r\n ARect, DT_LEFT or DT_SINGLELINE or DT_END_ELLIPSIS);\r\n\r\n if FShowTabImages and (Page.Images <> nil) and (CurrTabWidth > ImageWidth + 2 * FCaptionLeftOffset) then\r\n Page.Images.Draw(Canvas, CompleteWidth + FTabLeftOffset + FCaptionLeftOffset,\r\n FTabBottomOffset + FCaptionTopOffset + 1, Page.Pages[I].ImageIndex, True);\r\n\r\n Inc(CompleteWidth, CurrTabWidth + FTabSplitterWidth);\r\n end;\r\n\r\n Canvas.Brush.Color := Page.ActiveSheetColor;\r\n ARect := ClientRect;\r\n Canvas.FrameRect(ARect);\r\nend;\r\n\r\nprocedure TJvDockTabPanel.Resize;\r\nbegin\r\n inherited Resize;\r\n SetShowTabWidth;\r\nend;\r\n\r\nprocedure TJvDockTabPanel.SetCaptionLeftOffset(const Value: Integer);\r\nbegin\r\n if FCaptionLeftOffset <> Value then\r\n begin\r\n FCaptionLeftOffset := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockTabPanel.SetCaptionRightOffset(const Value: Integer);\r\nbegin\r\n if FCaptionRightOffset <> Value then\r\n begin\r\n FCaptionRightOffset := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockTabPanel.SetCaptionTopOffset(const Value: Integer);\r\nbegin\r\n if FCaptionTopOffset <> Value then\r\n begin\r\n FCaptionTopOffset := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockTabPanel.SetPage(const Value: TJvDockVIDVCTabPageControl);\r\nbegin\r\n FPage := Value;\r\nend;\r\n\r\nprocedure TJvDockTabPanel.SetPanelHeight(const Value: Integer);\r\nbegin\r\n if PanelHeight <> Value then\r\n begin\r\n case Page.TabPosition of\r\n tpLeft, tpRight:\r\n Width := Value;\r\n tpTop, tpBottom:\r\n Height := Value;\r\n end;\r\n SetShowTabWidth;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockTabPanel.SetTabBottomOffset(const Value: Integer);\r\nbegin\r\n if FTabBottomOffset <> Value then\r\n begin\r\n FTabBottomOffset := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockTabPanel.SetTabLeftOffset(const Value: Integer);\r\nbegin\r\n if FTabLeftOffset <> Value then\r\n begin\r\n FTabLeftOffset := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockTabPanel.SetTabRightOffset(const Value: Integer);\r\nbegin\r\n if FTabRightOffset <> Value then\r\n begin\r\n FTabRightOffset := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockTabPanel.SetTabSplitterWidth(const Value: Integer);\r\nbegin\r\n if FTabSplitterWidth <> Value then\r\n begin\r\n FTabSplitterWidth := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockTabPanel.SetTabTopOffset(const Value: Integer);\r\nbegin\r\n if FTabTopOffset <> Value then\r\n begin\r\n FTabTopOffset := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockTabPanel.SetTotalTabWidth(const Value: Integer);\r\nbegin\r\nend;\r\n\r\nfunction TJvDockTabPanel.GetDockClientFromPageIndex(Index: Integer): TControl;\r\nbegin\r\n Result := nil;\r\n if Index >= 0 then\r\n if Page.Pages[Index].ControlCount = 1 then\r\n begin\r\n Result := Page.Pages[Index].Controls[0];\r\n if Result.HostDockSite <> Page then\r\n Result := nil;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockTabPanel.SetShowTabWidth;\r\nvar\r\n I, J, TempWidth: Integer;\r\n PanelWidth, VisibleCount: Integer;\r\n ImageWidth: Integer;\r\nbegin\r\n if Page = nil then\r\n Exit;\r\n if FSortList = nil then\r\n Exit;\r\n PanelWidth := 0;\r\n case Page.TabPosition of\r\n tpTop, tpBottom:\r\n PanelWidth := Width;\r\n tpLeft, tpRight:\r\n PanelWidth := Height;\r\n end;\r\n\r\n TempWidth := PanelWidth - FCaptionLeftOffset - FCaptionRightOffset;\r\n if Page.ShowTabImages then\r\n ImageWidth := Page.Images.Width + FCaptionLeftOffset\r\n else\r\n ImageWidth := 0;\r\n VisibleCount := Page.VisibleSheetCount;\r\n J := 0;\r\n for I := 0 to FSortList.Count - 1 do\r\n begin\r\n if not Sorts[I].TabVisible then\r\n Continue;\r\n if (VisibleCount - J) * (Sorts[I].TabWidth + FTabSplitterWidth + ImageWidth) > TempWidth then\r\n Sorts[I].FShowTabWidth := TempWidth div (VisibleCount - J) - FTabSplitterWidth\r\n else\r\n Sorts[I].FShowTabWidth := Sorts[I].TabWidth + ImageWidth;\r\n Dec(TempWidth, Sorts[I].FShowTabWidth + FTabSplitterWidth);\r\n Inc(J);\r\n end;\r\nend;\r\n\r\nprocedure TJvDockTabPanel.CMMouseLeave(var Msg: TMessage);\r\nbegin\r\n inherited;\r\n if FSelectHotIndex <> -1 then\r\n begin\r\n FSelectHotIndex := -1;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockTabPanel.SetShowTabImages(const Value: Boolean);\r\nbegin\r\n if FShowTabImages <> Value then\r\n begin\r\n FShowTabImages := Value;\r\n SetShowTabWidth;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockTabPanel.SetTabHeight(const Value: Integer);\r\nbegin\r\n FTabHeight := Value;\r\n Height := FTabHeight + FTabTopOffset + FTabBottomOffset;\r\nend;\r\n\r\n//=== { TJvDockVIDVCTabSheet } ===============================================\r\n\r\nconstructor TJvDockVIDVCTabSheet.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FIsSourceDockClient := False;\r\nend;\r\n\r\ndestructor TJvDockVIDVCTabSheet.Destroy;\r\nbegin\r\n if (PageControl is TJvDockVIDVCTabPageControl) and (PageControl <> nil) then\r\n TJvDockVIDVCTabPageControl(PageControl).Panel.DeleteSorts(Self);\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvDockVIDVCTabSheet.Loaded;\r\nbegin\r\n inherited Loaded;\r\n SetSheetSort(Caption);\r\nend;\r\n\r\nprocedure TJvDockVIDVCTabSheet.SetPageControl(APageControl: TJvDockPageControl);\r\nbegin\r\n inherited SetPageControl(APageControl);\r\nend;\r\n\r\nprocedure TJvDockVIDVCTabSheet.SetSheetSort(const CaptionStr: string);\r\nvar\r\n TabPanel: TJvDockTabPanel;\r\n TempWidth: Integer;\r\n\r\n procedure DoSetSheetSort;\r\n var\r\n I: Integer;\r\n begin\r\n TJvDockVIDVCTabPageControl(PageControl).Panel.FSortList.Remove(Self);\r\n for I := 0 to TJvDockVIDVCTabPageControl(PageControl).Panel.FSortList.Count - 1 do\r\n if TJvDockVIDVCTabPageControl(PageControl).Panel.Sorts[I].TabWidth > TempWidth then\r\n begin\r\n TJvDockVIDVCTabPageControl(PageControl).Panel.FSortList.Insert(I, Self);\r\n Exit;\r\n end;\r\n TJvDockVIDVCTabPageControl(PageControl).Panel.FSortList.Add(Self);\r\n end;\r\n\r\nbegin\r\n if (PageControl is TJvDockVIDVCTabPageControl) and (PageControl <> nil) then\r\n begin\r\n TabPanel := TJvDockVIDVCTabPageControl(PageControl).Panel;\r\n if PageControl.ActivePage = Self then\r\n TabPanel.Canvas.Font.Assign(TabPanel.Page.ActiveFont)\r\n else\r\n TabPanel.Canvas.Font.Assign(TabPanel.Page.InactiveFont);\r\n TempWidth := TabPanel.Canvas.TextWidth(\r\n CaptionStr) + TabPanel.CaptionLeftOffset + TabPanel.CaptionRightOffset;\r\n if TempWidth <> FTabWidth then\r\n begin\r\n DoSetSheetSort;\r\n FTabWidth := TempWidth;\r\n TabPanel.SetShowTabWidth;\r\n TabPanel.Invalidate;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockVIDVCTabSheet.SetTabWidth(const Value: Integer);\r\nbegin\r\n FTabWidth := Value;\r\nend;\r\n\r\nprocedure TJvDockVIDVCTabSheet.UpdateTabShowing;\r\nbegin\r\n inherited UpdateTabShowing;\r\n TJvDockVIDVCTabPageControl(PageControl).Panel.SetShowTabWidth;\r\nend;\r\n\r\nprocedure TJvDockVIDVCTabSheet.WMSetText(var Msg: TMessage);\r\nbegin\r\n inherited;\r\n SetSheetSort(PChar(Msg.LParam));\r\nend;\r\n\r\n//=== { TJvDockVIDVCDragDockObject } =========================================\r\n\r\nconstructor TJvDockVIDVCDragDockObject.Create(AControl: TControl);\r\n\r\n procedure DoGetSourceDockClients(Control: TControl);\r\n var\r\n I: Integer;\r\n DockableControl: TWinControl;\r\n begin\r\n if Control is TJvDockableForm then\r\n begin\r\n DockableControl := TJvDockableForm(Control).DockableControl;\r\n for I := 0 to DockableControl.DockClientCount - 1 do\r\n DoGetSourceDockClients(DockableControl.DockClients[I]);\r\n end\r\n else\r\n FSourceDockClientList.Add(Control);\r\n end;\r\n\r\nbegin\r\n inherited Create(AControl);\r\n FSourceDockClientList := TList.Create;\r\n DoGetSourceDockClients(AControl);\r\n FDropTabControl := nil;\r\n FIsTabDockOver := False;\r\n CurrState := dsDragEnter;\r\n OldState := CurrState;\r\nend;\r\n\r\ndestructor TJvDockVIDVCDragDockObject.Destroy;\r\nbegin\r\n FDropTabControl := nil;\r\n FSourceDockClientList.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvDockVIDVCDragDockObject.GetBrush_PenSize_DrawRect(var ABrush: TBrush;\r\n var PenSize: Integer; var DrawRect: TRect; Erase: Boolean);\r\nbegin\r\n if DragTarget = nil then\r\n DropAlign := alNone;\r\n inherited GetBrush_PenSize_DrawRect(ABrush, PenSize, DrawRect, Erase);\r\n FIsTabDockOver := ((FOldDropAlign = alClient) and FErase) or\r\n ((DropAlign = alClient) and not FErase);\r\n FOldDropAlign := DropAlign;\r\n FOldTarget := DragTarget;\r\nend;\r\n\r\n// (rom) unused writeable const option removed\r\n\r\nprocedure TJvDockVIDVCDragDockObject.DefaultDockImage(Erase: Boolean);\r\nvar\r\n DrawRect: TRect;\r\n TabControlRect: TRect;\r\n TabRect: TRect;\r\n PenSize: Integer;\r\n ABrush: TBrush;\r\n ShowTab: Boolean;\r\n LeftOffset: Integer;\r\n BottomOffset: Integer;\r\n MaxTabWidth: Integer;\r\nbegin\r\n FErase := Erase;\r\n GetBrush_PenSize_DrawRect(ABrush, PenSize, DrawRect, Erase);\r\n if Erase then\r\n Exit; // No need to erase\r\n\r\n ShowTab := False;\r\n if FIsTabDockOver and Assigned(FDropTabControl) then\r\n begin\r\n TabControlRect := FDropTabControl.BoundsRect;\r\n TabControlRect := Classes.Rect(FDropTabControl.ClientToScreen(TabControlRect.TopLeft),\r\n FDropTabControl.ClientToScreen(TabControlRect.BottomRight));\r\n // This is to make sure the TabControlRect is included in the DrawRect\r\n if PtInRect(DrawRect, TabControlRect.TopLeft) and\r\n PtInRect(DrawRect, Point(TabControlRect.BottomRight.X -1,\r\n TabControlRect.BottomRight.Y -1))\r\n then\r\n ShowTab := True;\r\n end;\r\n\r\n if not ShowTab then\r\n begin\r\n AlphaBlendedForm.Visible := True;\r\n AlphaBlendedForm.BoundsRect := DrawRect;\r\n AlphaBlendedTab.Visible := False;\r\n AlphaBlendedTab.BoundsRect := Classes.Rect(0, 0, 0, 0);\r\n end\r\n else\r\n begin\r\n LeftOffset := FDropTabControl.TabLeftOffset;\r\n BottomOffset := FDropTabControl.Panel.TabHeight;\r\n if FDropTabControl.Panel.Page.Count > 0 then\r\n MaxTabWidth := FDropTabControl.Panel.Sorts[0].TabWidth\r\n else\r\n MaxTabWidth := 30;\r\n\r\n if TabControlRect.Right - TabControlRect.Left < LeftOffset + 2 * MaxTabWidth then\r\n MaxTabWidth := (TabControlRect.Right - TabControlRect.Left - LeftOffset) div 2;\r\n\r\n if TabControlRect.Bottom - TabControlRect.Top < 2 * BottomOffset then\r\n BottomOffset := Max((TabControlRect.Bottom - TabControlRect.Top) div 2, 0);\r\n\r\n Assert(FDropTabControl.TabPosition in [tpBottom, tpTop],\r\n RsEDockCannotSetTabPosition);\r\n\r\n TabRect := TabControlRect;\r\n if FDropTabControl.TabPosition = tpBottom then\r\n begin\r\n Dec(TabControlRect.Bottom, BottomOffset);\r\n AlphaBlendedForm.Visible := True;\r\n AlphaBlendedForm.BoundsRect := TabControlRect;\r\n TabRect := Bounds(TabRect.Left + LeftOffset, TabRect.Bottom - BottomOffset,\r\n MaxTabWidth, BottomOffset);\r\n AlphaBlendedTab.Visible := True;\r\n AlphaBlendedTab.BoundsRect := TabRect;\r\n end\r\n else\r\n begin\r\n Inc(TabControlRect.Top, BottomOffset);\r\n AlphaBlendedForm.Visible := True;\r\n AlphaBlendedForm.BoundsRect := TabControlRect;\r\n TabRect := Bounds(TabRect.Left + LeftOffset, TabRect.Top,\r\n MaxTabWidth, BottomOffset);\r\n AlphaBlendedTab.Visible := True;\r\n AlphaBlendedTab.BoundsRect := TabRect;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJvDockVIDVCDragDockObject.DragFindWindow(const Pos: TPoint): THandle;\r\nbegin\r\n Result := 0;\r\nend;\r\n\r\nfunction TJvDockVIDVCDragDockObject.GetDropCtl: TControl;\r\nvar\r\n ARect: TRect;\r\n I: Integer;\r\nbegin\r\n Result := inherited GetDropCtl;\r\n if (Result = nil) and (TargetControl is TJvDockCustomPanel) then\r\n for I := 0 to TargetControl.DockClientCount - 1 do\r\n if TargetControl.DockClients[I].Visible then\r\n begin\r\n ARect := TJvDockCustomPanel(DragTarget).JvDockManager.GetFrameRectEx(TargetControl.DockClients[I]);\r\n if PtInRect(ARect, DragPos) then\r\n begin\r\n Result := TargetControl.DockClients[I];\r\n Exit;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJvDockVIDVCDragDockObject.GetSourceDockClient(Index: Integer): TControl;\r\nbegin\r\n Result := TControl(FSourceDockClientList[Index]);\r\nend;\r\n\r\nfunction TJvDockVIDVCDragDockObject.GetSourceDockClientCount: Integer;\r\nbegin\r\n Result := FSourceDockClientList.Count;\r\nend;\r\n\r\nprocedure TJvDockVIDVCDragDockObject.MouseMsg(var Msg: TMessage);\r\nvar\r\n APos: TPoint;\r\n Page: TJvDockVIDVCTabPageControl;\r\nbegin\r\n inherited MouseMsg(Msg);\r\n case Msg.Msg of\r\n WM_CAPTURECHANGED:\r\n if JvGlobalDockClient.ParentForm.HostDockSite is TJvDockVIDVCTabPageControl then\r\n TJvDockVIDVCTabPageControl(JvGlobalDockClient.ParentForm.HostDockSite).Panel.MouseUp(mbLeft, [], 0, 0)\r\n else\r\n if TWinControl(JvGlobalDockManager.DragObject.DragTarget) is TJvDockVIDVCTabPageControl then\r\n TJvDockVIDVCTabPageControl(JvGlobalDockManager.DragObject.TargetControl).Panel.MouseUp(mbLeft, [], 0, 0);\r\n WM_MOUSEMOVE:\r\n if JvGlobalDockManager.DragObject.TargetControl is TJvDockVIDVCTabPageControl then\r\n begin\r\n Page := TJvDockVIDVCTabPageControl(JvGlobalDockManager.DragObject.TargetControl);\r\n if Page.FTempSheet <> nil then\r\n begin\r\n APos := Point(TWMMouse(Msg).XPos, TWMMouse(Msg).YPos);\r\n APos := Page.Panel.ScreenToClient(APos);\r\n Page.Panel.MouseMove([], APos.X, APos.Y);\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockVIDVCDragDockObject.SetOldState(const Value: TDragState);\r\nbegin\r\n FOldState := Value;\r\nend;\r\n\r\nprocedure TJvDockVIDVCDragDockObject.SetCurrState(const Value: TDragState);\r\nbegin\r\n FCurrState := Value;\r\nend;\r\n\r\nfunction TJvDockVIDVCDragDockObject.CanLeave(NewTarget: TWinControl): Boolean;\r\nbegin\r\n Result := inherited CanLeave(NewTarget);\r\nend;\r\n\r\n//=== { TJvDockVIDVCZone } ===================================================\r\n\r\nfunction TJvDockVIDVCZone.GetSplitterLimit(IsMin: Boolean): Integer;\r\nbegin\r\n if IsMin then\r\n Result := ZoneLimit\r\n else\r\n Result := LimitBegin;\r\nend;\r\n\r\nprocedure TJvDockVIDVCZone.Insert(DockSize: Integer; Hide: Boolean);\r\nvar\r\n PrevShift: Integer;\r\n NextShift: Integer;\r\n TempSize: Integer;\r\n BorderSize: Integer;\r\n BeforeVisibleZone: TJvDockZone;\r\n AfterVisibleZone: TJvDockZone;\r\n BeginSize: Integer;\r\nbegin\r\n if (ParentZone <> nil) and (ParentZone.VisibleChildCount = 0) then\r\n ParentZone.Insert(ParentZone.VisibleSize, Hide);\r\n\r\n if (ParentZone = nil) or ((ParentZone = Tree.TopZone) and (ParentZone.ChildCount <= 1)) then\r\n begin\r\n Visibled := True;\r\n Exit;\r\n end;\r\n\r\n if (ParentZone <> nil) and (ParentZone.ChildZones <> nil) then\r\n BeginSize := ParentZone.ChildZones.LimitBegin\r\n else\r\n BeginSize := 0;\r\n\r\n BeforeVisibleZone := BeforeClosestVisibleZone;\r\n AfterVisibleZone := AfterClosestVisibleZone;\r\n\r\n BorderSize := TJvDockVIDVCTree(Tree).BorderWidth * Integer(AfterClosestVisibleZone <> nil) div 2;\r\n TempSize := ParentZone.HeightWidth[ParentZone.Orientation] + BorderSize;\r\n Visibled := False;\r\n\r\n if DockSize >= TempSize - (ParentZone.VisibleChildCount) * TJvDockVIDVCTree(Tree).MinSize then\r\n DockSize := (TempSize - (ParentZone.VisibleChildCount) * TJvDockVIDVCTree(Tree).MinSize) div 2;\r\n\r\n if DockSize < TJvDockVIDVCTree(Tree).MinSize then\r\n DockSize := TempSize div 2;\r\n\r\n if (BeforeVisibleZone = nil) and (AfterVisibleZone = nil) then\r\n begin\r\n PrevShift := 0;\r\n NextShift := 0;\r\n ZoneLimit := TempSize + BeginSize;\r\n end\r\n else\r\n if BeforeVisibleZone = nil then\r\n begin\r\n PrevShift := 0;\r\n NextShift := DockSize + BorderSize;\r\n ZoneLimit := DockSize + LimitBegin + BorderSize;\r\n if ParentZone.VisibleChildCount = 1 then\r\n AfterVisibleZone.ZoneLimit := TempSize + BeginSize;\r\n end\r\n else\r\n if AfterVisibleZone = nil then\r\n begin\r\n PrevShift := DockSize + BorderSize;\r\n NextShift := 0;\r\n if (ParentZone.VisibleChildCount = 1) and (ParentZone = Tree.TopZone) then\r\n BeforeVisibleZone.ZoneLimit := Tree.TopXYLimit - PrevShift\r\n else\r\n BeforeVisibleZone.ZoneLimit := BeforeVisibleZone.ZoneLimit - PrevShift;\r\n ZoneLimit := TempSize + BeginSize;\r\n end\r\n else\r\n begin\r\n PrevShift := Round((BeforeVisibleZone.ZoneLimit - BeginSize) * (DockSize + BorderSize) / TempSize);\r\n NextShift := DockSize - PrevShift;\r\n if (ParentZone.VisibleChildCount = 1) and (ParentZone = Tree.TopZone) then\r\n BeforeVisibleZone.ZoneLimit := Tree.TopXYLimit - PrevShift\r\n else\r\n BeforeVisibleZone.ZoneLimit := BeforeVisibleZone.ZoneLimit - PrevShift;\r\n ZoneLimit := BeforeVisibleZone.ZoneLimit + DockSize;\r\n end;\r\n\r\n if PrevShift <> 0 then\r\n begin\r\n with TJvDockVIDVCTree(Tree) do\r\n begin\r\n ReplacementZone := BeforeVisibleZone;\r\n try\r\n if (BeforeVisibleZone.ZoneLimit - BeginSize) * (BeforeVisibleZone.ZoneLimit - BeginSize + PrevShift) <> 0 then\r\n ScaleBy := (BeforeVisibleZone.ZoneLimit - BeginSize) / (BeforeVisibleZone.ZoneLimit - BeginSize + PrevShift)\r\n else\r\n ScaleBy := 1;\r\n ParentLimit := BeginSize;\r\n ShiftScaleOrientation := ParentZone.Orientation;\r\n if ScaleBy <> 1 then\r\n ForEachAt(ParentZone.ChildZones, ScaleChildZone, tskMiddle, tspChild);\r\n finally\r\n ReplacementZone := nil;\r\n end;\r\n end;\r\n\r\n if BeforeVisibleZone.LimitSize < TJvDockVIDVCTree(Tree).MinSize then\r\n BeforeVisibleZone.ZoneLimit := BeforeVisibleZone.LimitBegin + TJvDockVIDVCTree(Tree).MinSize;\r\n end;\r\n\r\n if NextShift <> 0 then\r\n with TJvDockVIDVCTree(Tree) do\r\n begin\r\n if (TempSize + BeginSize - LimitBegin - NextShift) * (TempSize + BeginSize - LimitBegin) <> 0 then\r\n ScaleBy := (TempSize + BeginSize - LimitBegin - NextShift) / (TempSize + BeginSize - LimitBegin)\r\n else\r\n ScaleBy := 1;\r\n ParentLimit := TempSize + BeginSize;\r\n ShiftScaleOrientation := ParentZone.Orientation;\r\n if ScaleBy <> 1 then\r\n ForEachAt(AfterVisibleZone, ScaleSiblingZone, tskForward);\r\n end;\r\n Visibled := True;\r\nend;\r\n\r\nprocedure TJvDockVIDVCZone.Remove(DockSize: Integer; Hide: Boolean);\r\nvar\r\n PrevShift: Integer;\r\n NextShift: Integer;\r\n TempSize: Integer;\r\n BorderSize: Integer;\r\n BeforeVisibleZone: TJvDockZone;\r\n AfterVisibleZone: TJvDockZone;\r\n BeginSize: Integer;\r\nbegin\r\n if (ParentZone <> nil) and (ParentZone.VisibleChildCount = 1) and (ParentZone <> Tree.TopZone) then\r\n ParentZone.Remove(ParentZone.LimitSize, Hide);\r\n\r\n if (ParentZone = nil) or ((ParentZone = Tree.TopZone) and (ParentZone.ChildCount <= 1)) then\r\n begin\r\n Visibled := False;\r\n Exit;\r\n end;\r\n\r\n if (ParentZone <> nil) and (ParentZone.ChildZones <> nil) then\r\n BeginSize := ParentZone.ChildZones.LimitBegin\r\n else\r\n BeginSize := 0;\r\n\r\n BeforeVisibleZone := BeforeClosestVisibleZone;\r\n AfterVisibleZone := AfterClosestVisibleZone;\r\n\r\n BorderSize := TJvDockVIDVCTree(Tree).BorderWidth * Integer(AfterClosestVisibleZone <> nil) div 2;\r\n TempSize := ParentZone.HeightWidth[ParentZone.Orientation] + BorderSize;\r\n\r\n if DockSize > TempSize - (ParentZone.VisibleChildCount - 1) * TJvDockVIDVCTree(Tree).MinSize then\r\n DockSize := TempSize - (ParentZone.VisibleChildCount - 1) * TJvDockVIDVCTree(Tree).MinSize;\r\n if DockSize = 0 then\r\n DockSize := TempSize div 2;\r\n\r\n Visibled := False;\r\n if (BeforeVisibleZone = nil) and (AfterVisibleZone = nil) then\r\n Exit;\r\n\r\n if BeforeVisibleZone = nil then\r\n begin\r\n PrevShift := 0;\r\n NextShift := -DockSize + BorderSize;\r\n ZoneLimit := -DockSize + BorderSize + BeginSize;\r\n end\r\n else\r\n if AfterVisibleZone = nil then\r\n begin\r\n PrevShift := -DockSize + BorderSize;\r\n NextShift := 0;\r\n BeforeVisibleZone.ZoneLimit := BeforeVisibleZone.ZoneLimit - PrevShift;\r\n ZoneLimit := TempSize + BeginSize;\r\n end\r\n else\r\n begin\r\n PrevShift := -Round((BeforeVisibleZone.ZoneLimit - BeginSize) * (DockSize + BorderSize) / (TempSize - (DockSize +\r\n BorderSize)));\r\n NextShift := -DockSize - PrevShift;\r\n BeforeVisibleZone.ZoneLimit := BeforeVisibleZone.ZoneLimit - PrevShift;\r\n ZoneLimit := BeforeVisibleZone.ZoneLimit;\r\n end;\r\n\r\n if PrevShift <> 0 then\r\n begin\r\n with TJvDockVIDVCTree(Tree) do\r\n begin\r\n ReplacementZone := BeforeVisibleZone;\r\n try\r\n if (BeforeVisibleZone.ZoneLimit - BeginSize) * (BeforeVisibleZone.ZoneLimit - BeginSize + PrevShift) <> 0 then\r\n ScaleBy := (BeforeVisibleZone.ZoneLimit - BeginSize) / (BeforeVisibleZone.ZoneLimit - BeginSize + PrevShift)\r\n else\r\n ScaleBy := 1;\r\n ParentLimit := BeginSize;\r\n ShiftScaleOrientation := ParentZone.Orientation;\r\n if ScaleBy <> 1 then\r\n ForEachAt(ParentZone.ChildZones, ScaleChildZone, tskMiddle, tspChild);\r\n finally\r\n ReplacementZone := nil;\r\n end;\r\n end;\r\n\r\n if BeforeVisibleZone.LimitSize < TJvDockVIDVCTree(Tree).MinSize then\r\n BeforeVisibleZone.ZoneLimit := BeforeVisibleZone.LimitBegin + TJvDockVIDVCTree(Tree).MinSize;\r\n end;\r\n\r\n if NextShift <> 0 then\r\n with TJvDockVIDVCTree(Tree) do\r\n begin\r\n if (TempSize + BeginSize - LimitBegin) * (TempSize + BeginSize - LimitBegin + NextShift) <> 0 then\r\n ScaleBy := (TempSize + BeginSize - LimitBegin) / (TempSize + BeginSize - LimitBegin + NextShift)\r\n else\r\n ScaleBy := 1;\r\n ParentLimit := TempSize + BeginSize;\r\n ShiftScaleOrientation := ParentZone.Orientation;\r\n if ScaleBy <> 1 then\r\n ForEachAt(AfterVisibleZone, ScaleSiblingZone, tskForward);\r\n end;\r\nend;\r\n\r\n//=== { TJvDockVIDVCTabServerOption } ========================================\r\n\r\nconstructor TJvDockVIDVCTabServerOption.Create(ADockStyle: TJvDockObservableStyle);\r\nbegin\r\n inherited Create(ADockStyle);\r\n TabPosition := tpBottom;\r\n FActiveFont := TFont.Create;\r\n FActiveFont.OnChange := FontChanged;\r\n FActiveSheetColor := clBtnFace;\r\n FHotTrackColor := clBlue;\r\n FInactiveFont := TFont.Create;\r\n FInactiveFont.Color := clWhite;\r\n FInactiveFont.OnChange := FontChanged;\r\n FInactiveSheetColor := clBtnShadow;\r\n FShowTabImages := False;\r\nend;\r\n\r\ndestructor TJvDockVIDVCTabServerOption.Destroy;\r\nbegin\r\n FActiveFont.Free;\r\n FInactiveFont.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvDockVIDVCTabServerOption.Assign(Source: TPersistent);\r\nvar\r\n Src: TJvDockVIDVCTabServerOption;\r\nbegin\r\n if Source is TJvDockVIDVCTabServerOption then\r\n begin\r\n BeginUpdate;\r\n try\r\n Src := TJvDockVIDVCTabServerOption(Source);\r\n\r\n ActiveFont := Src.ActiveFont;\r\n ActiveSheetColor := Src.ActiveSheetColor;\r\n HotTrackColor := Src.HotTrackColor;\r\n InactiveFont := Src.InactiveFont;\r\n InactiveSheetColor := Src.InactiveSheetColor;\r\n ShowTabImages := Src.ShowTabImages;\r\n\r\n inherited Assign(Source);\r\n finally\r\n EndUpdate;\r\n end;\r\n end\r\n else\r\n inherited Assign(Source);\r\nend;\r\n\r\nprocedure TJvDockVIDVCTabServerOption.FontChanged(Sender: TObject);\r\nbegin\r\n Changed;\r\nend;\r\n\r\nprocedure TJvDockVIDVCTabServerOption.SetActiveFont(Value: TFont);\r\nbegin\r\n FActiveFont.Assign(Value);\r\nend;\r\n\r\nprocedure TJvDockVIDVCTabServerOption.SetActiveSheetColor(const Value: TColor);\r\nbegin\r\n if FActiveSheetColor <> Value then\r\n begin\r\n FActiveSheetColor := Value;\r\n Changed;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockVIDVCTabServerOption.SetHotTrackColor(const Value: TColor);\r\nbegin\r\n if FHotTrackColor <> Value then\r\n begin\r\n FHotTrackColor := Value;\r\n Changed;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockVIDVCTabServerOption.SetInactiveFont(Value: TFont);\r\nbegin\r\n FInactiveFont.Assign(Value);\r\nend;\r\n\r\nprocedure TJvDockVIDVCTabServerOption.SetInactiveSheetColor(const Value: TColor);\r\nbegin\r\n if FInactiveSheetColor <> Value then\r\n begin\r\n FInactiveSheetColor := Value;\r\n Changed;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockVIDVCTabServerOption.SetShowTabImages(const Value: Boolean);\r\nbegin\r\n if FShowTabImages <> Value then\r\n begin\r\n FShowTabImages := Value;\r\n Changed;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockVIDVCTabServerOption.SetTabPosition(const Value: TTabPosition);\r\nbegin\r\n if Value = tpBottom then\r\n inherited SetTabPosition(Value)\r\n else\r\n raise Exception.CreateRes(@RsEDockTabPositionMustBetpBottom);\r\nend;\r\n\r\n///=== { TJvDockVIDVCConjoinServerOption } ===================================\r\n\r\nconstructor TJvDockVIDVCConjoinServerOption.Create(ADockStyle: TJvDockObservableStyle);\r\nbegin\r\n inherited Create(ADockStyle);\r\n GrabbersSize := VIDDefaultDockGrabbersSize;\r\n SplitterWidth := VIDDefaultDockSplitterWidth;\r\n FActiveFont := TFont.Create;\r\n FActiveFont.OnChange := FontChanged;\r\n FInactiveFont := TFont.Create;\r\n FInactiveFont.OnChange := FontChanged;\r\n SystemInfo := True;\r\nend;\r\n\r\ndestructor TJvDockVIDVCConjoinServerOption.Destroy;\r\nbegin\r\n { Make sure we unregister, can be called more than once }\r\n UnRegisterSettingChangeClient(Self);\r\n FActiveFont.Free;\r\n FInactiveFont.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvDockVIDVCConjoinServerOption.Assign(Source: TPersistent);\r\nvar\r\n Src: TJvDockVIDVCConjoinServerOption;\r\nbegin\r\n if Source is TJvDockVIDVCConjoinServerOption then\r\n begin\r\n BeginUpdate;\r\n try\r\n Src := TJvDockVIDVCConjoinServerOption(Source);\r\n\r\n TextEllipsis := Src.TextEllipsis;\r\n TextAlignment := Src.TextAlignment;\r\n InactiveTitleEndColor := Src.InactiveTitleEndColor;\r\n InactiveTitleStartColor := Src.InactiveTitleStartColor;\r\n ActiveTitleEndColor := Src.ActiveTitleEndColor;\r\n ActiveTitleStartColor := Src.ActiveTitleStartColor;\r\n ActiveFont := Src.ActiveFont;\r\n InactiveFont := Src.InactiveFont;\r\n SystemInfo := Src.SystemInfo;\r\n\r\n inherited Assign(Source);\r\n finally\r\n EndUpdate;\r\n end;\r\n end\r\n else\r\n inherited Assign(Source);\r\nend;\r\n\r\nprocedure TJvDockVIDVCConjoinServerOption.SetActiveTitleEndColor(const Value: TColor);\r\nbegin\r\n if FActiveTitleEndColor <> Value then\r\n begin\r\n FActiveTitleEndColor := Value;\r\n SystemInfo := False;\r\n Changed;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockVIDVCConjoinServerOption.SetActiveTitleStartColor(const Value: TColor);\r\nbegin\r\n if FActiveTitleStartColor <> Value then\r\n begin\r\n FActiveTitleStartColor := Value;\r\n SystemInfo := False;\r\n Changed;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockVIDVCConjoinServerOption.SetInactiveTitleEndColor(const Value: TColor);\r\nbegin\r\n if FInactiveTitleEndColor <> Value then\r\n begin\r\n FInactiveTitleEndColor := Value;\r\n SystemInfo := False;\r\n Changed;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockVIDVCConjoinServerOption.SetInactiveTitleStartColor(const Value: TColor);\r\nbegin\r\n if FInactiveTitleStartColor <> Value then\r\n begin\r\n FInactiveTitleStartColor := Value;\r\n SystemInfo := False;\r\n Changed;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockVIDVCConjoinServerOption.SetSystemInfo(const Value: Boolean);\r\nbegin\r\n if FSystemInfo <> Value then\r\n begin\r\n if FSystemInfo then\r\n UnRegisterSettingChangeClient(Self);\r\n FSystemInfo := Value;\r\n if FSystemInfo then\r\n begin\r\n RegisterSettingChangeClient(Self, SettingChange);\r\n SetDefaultSystemCaptionInfo;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockVIDVCConjoinServerOption.SetTextAlignment(\r\n const Value: TAlignment);\r\nbegin\r\n if FTextAlignment <> Value then\r\n begin\r\n FTextAlignment := Value;\r\n SystemInfo := False;\r\n Changed;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockVIDVCConjoinServerOption.SetTextEllipsis(const Value: Boolean);\r\nbegin\r\n if FTextEllipsis <> Value then\r\n begin\r\n FTextEllipsis := Value;\r\n SystemInfo := False;\r\n Changed;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockVIDVCConjoinServerOption.SetDefaultSystemCaptionInfo;\r\nvar\r\n Saved: Boolean;\r\nbegin\r\n { We use a trick to temporarily disable changing of SystemInfo; by\r\n setting FSystemInfo to false.\r\n }\r\n Saved := SystemInfo;\r\n BeginUpdate;\r\n FSystemInfo := False;\r\n try\r\n UpdateDefaultSystemCaptionInfo;\r\n finally\r\n FSystemInfo := Saved;\r\n EndUpdate;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockVIDVCConjoinServerOption.SetActiveFont(Value: TFont);\r\nbegin\r\n FActiveFont.Assign(Value);\r\nend;\r\n\r\nprocedure TJvDockVIDVCConjoinServerOption.SetInactiveFont(Value: TFont);\r\nbegin\r\n FInactiveFont.Assign(Value);\r\nend;\r\n\r\nprocedure TJvDockVIDVCConjoinServerOption.FontChanged(Sender: TObject);\r\nbegin\r\n SystemInfo := False;\r\n Changed;\r\nend;\r\n\r\nprocedure TJvDockVIDVCConjoinServerOption.UpdateDefaultSystemCaptionInfo;\r\nbegin\r\n ActiveTitleStartColor := JvDockGetActiveTitleBeginColor;\r\n ActiveTitleEndColor := JvDockGetActiveTitleEndColor;\r\n InactiveTitleStartColor := JvDockGetInactiveTitleBeginColor;\r\n InactiveTitleEndColor := JvDockGetInactiveTitleEndColor;\r\n TextAlignment := taLeftJustify;\r\n TextEllipsis := True;\r\n ActiveFont := JvDockGetTitleFont;\r\n ActiveFont.Style := ActiveFont.Style + [fsBold];\r\n InactiveFont := ActiveFont;\r\n ActiveFont.Color := JvDockGetActiveTitleFontColor;\r\n InactiveFont.Color := JvDockGetInactiveTitleFontColor;\r\n GrabbersSize := VIDDefaultDockGrabbersSize;\r\n SplitterWidth := VIDDefaultDockSplitterWidth;\r\nend;\r\n\r\nfunction TJvDockVIDVCConjoinServerOption.IsNotSystemInfo: Boolean;\r\nbegin\r\n Result := not SystemInfo;\r\nend;\r\n\r\nprocedure TJvDockVIDVCConjoinServerOption.SettingChange(Sender: TObject);\r\nbegin\r\n { ?? }\r\n //DockStyle.ParentForm.Caption := '';\r\n if SystemInfo then\r\n SetDefaultSystemCaptionInfo;\r\nend;\r\n\r\nprocedure TJvDockVIDVCConjoinServerOption.Changed;\r\nbegin\r\n inherited Changed;\r\n SystemInfo := SystemInfo and (GrabbersSize = VIDDefaultDockGrabbersSize) and\r\n (SplitterWidth = VIDDefaultDockSplitterWidth);\r\n TJvDockVIDVCStyle(DockStyle).DoSystemInfoChange(SystemInfo);\r\nend;\r\n\r\nprocedure TJvDockVIDVCTree.DrawDockSiteRect;\r\nvar\r\n Rect: TRect;\r\nbegin\r\n inherited DrawDockSiteRect;\r\n Rect := DockSite.ClientRect;\r\n InflateRect(Rect, BorderWidth, 0);\r\n if DockSite.Align = alTop then\r\n Inc(Rect.Bottom, BorderWidth)\r\n else\r\n if DockSite.Align = alBottom then\r\n Dec(Rect.Top, BorderWidth);\r\n Frame3D(Canvas, Rect, clBtnShadow, clBtnHighlight, 1);\r\n Frame3D(Canvas, Rect, clBtnHighlight, clBtnShadow, 1);\r\n\r\n Canvas.Pen.Color := clBlack;\r\n if DockSite.Align = alRight then\r\n begin\r\n Canvas.MoveTo(0, 0);\r\n Canvas.LineTo(0, DockSite.Height);\r\n end\r\n else\r\n if DockSite.Align = alBottom then\r\n begin\r\n Canvas.MoveTo(0, 0);\r\n Canvas.LineTo(DockSite.Width, 0);\r\n end;\r\nend;\r\n\r\nfunction TJvDockVIDVCTree.DoLButtonDown(var Msg: TWMMouse;\r\n var Zone: TJvDockZone; out HTFlag: Integer): Boolean;\r\nvar\r\n TempZone: TJvDockVIDVCZone;\r\n Active: Boolean;\r\nbegin\r\n Result := inherited DoLButtonDown(Msg, Zone, HTFlag);\r\n if (Zone <> nil) and (HTFlag = HTEXPAND) then\r\n begin\r\n TempZone := TJvDockVIDVCZone(Zone);\r\n Active := ((TempZone.ParentZone.Orientation <> DockSiteOrientation) and\r\n (TempZone.ParentZone.VisibleChildCount >= 2));\r\n if Active then\r\n begin\r\n TempZone.ExpandButtonDown := True;\r\n TempZone.MouseDown := True;\r\n FExpandBtnZone := TempZone;\r\n DockSite.Invalidate;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockVIDVCTree.DoMouseMove(var Msg: TWMMouse;\r\n var Zone: TJvDockZone; out HTFlag: Integer);\r\nvar\r\n TempZone: TJvDockVIDVCZone;\r\nbegin\r\n inherited DoMouseMove(Msg, Zone, HTFlag);\r\n if SizingZone = nil then\r\n begin\r\n TempZone := TJvDockVIDVCZone(Zone);\r\n if ((TempZone <> nil) and (TempZone.ExpandButtonDown <> (HTFlag = HTEXPAND)) and\r\n ((FExpandBtnZone = TempZone) and FExpandBtnZone.MouseDown)) then\r\n begin\r\n TempZone.ExpandButtonDown := (HTFlag = HTEXPAND) and FExpandBtnZone.MouseDown;\r\n DockSite.Invalidate;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockVIDVCTree.DoLButtonUp(var Msg: TWMMouse;\r\n var Zone: TJvDockZone; out HTFlag: Integer);\r\nvar\r\n TempZone: TJvDockVIDVCZone;\r\nbegin\r\n inherited DoLButtonUp(Msg, Zone, HTFlag);\r\n if (SizingZone = nil) and (FExpandBtnZone <> nil) then\r\n begin\r\n FExpandBtnZone := nil;\r\n if (Zone <> nil) and (HTFlag = HTEXPAND) then\r\n begin\r\n TempZone := TJvDockVIDVCZone(Zone);\r\n TempZone.ExpandButtonDown := False;\r\n if TempZone.ZoneSizeStyle in [zssMaximum] then\r\n TJvDockVIDVCZone(TempZone.ParentZone).DoSetChildSizeStyle(zssNormal)\r\n else\r\n begin\r\n TJvDockVIDVCZone(TempZone.ParentZone).DoSetChildSizeStyle(zssMinimum);\r\n TempZone.ZoneSizeStyle := zssMaximum;\r\n end;\r\n ResetDockZoneSizeStyle(TempZone.ParentZone, TempZone.ZoneSizeStyle, nil);\r\n DockSite.Invalidate;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockVIDVCZone.DoSetChildSizeStyle(ZoneSizeStyle: TJvDockZoneSizeStyle);\r\nvar\r\n Zone: TJvDockVIDVCZone;\r\nbegin\r\n Zone := TJvDockVIDVCZone(ChildZones);\r\n while Zone <> nil do\r\n begin\r\n Zone.ZoneSizeStyle := ZoneSizeStyle;\r\n Zone := TJvDockVIDVCZone(Zone.AfterClosestVisibleZone);\r\n end;\r\nend;\r\n\r\nprocedure TJvDockVIDVCTree.ResetDockZoneSizeStyle(Parent: TJvDockZone;\r\n ZoneSizeStyle: TJvDockZoneSizeStyle; Exclude: TJvDockZone);\r\nvar\r\n Zone: TJvDockVIDVCZone;\r\n ChildCount: Integer;\r\n AverageSize: Integer;\r\nbegin\r\n ChildCount := Parent.VisibleChildCount - Integer((Exclude <> nil) and (Exclude.ParentZone = Parent));\r\n AverageSize := DockSiteSizeAlternate div ChildCount;\r\n Assert(AverageSize > 0);\r\n Zone := TJvDockVIDVCZone(Parent.FirstVisibleChildZone);\r\n while Zone <> nil do\r\n begin\r\n if Exclude <> Zone then\r\n begin\r\n Dec(ChildCount);\r\n if ZoneSizeStyle in [zssMaximum] then\r\n begin\r\n if Zone.ZoneSizeStyle = zssMinimum then\r\n Zone.ZoneLimit := Zone.LimitBegin + MinSize\r\n else\r\n if Zone.ZoneSizeStyle = zssMaximum then\r\n Zone.ZoneLimit := DockSiteSizeAlternate - ChildCount * MinSize;\r\n end\r\n else\r\n if ZoneSizeStyle in [zssNormal] then\r\n Zone.ZoneLimit := Zone.LimitBegin + AverageSize;\r\n end\r\n else\r\n if Exclude <> nil then\r\n Exclude.ZoneLimit := Exclude.LimitBegin;\r\n\r\n Zone := TJvDockVIDVCZone(Zone.AfterClosestVisibleZone);\r\n end;\r\n SetNewBounds(Parent);\r\n ForEachAt(Parent, UpdateZone, tskForward);\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvDockVSNetStyle.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvDockVSNetStyle.pas, released on 2003-12-31.\r\n\r\nThe Initial Developer of the Original Code is luxiaoban.\r\nPortions created by luxiaoban are Copyright (C) 2002,2003 luxiaoban.\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvDockVSNetStyle.pas 13415 2012-09-10 09:51:54Z obones $\r\n\r\nunit JvDockVSNetStyle;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, Messages, Classes, Graphics, Controls, Forms, ExtCtrls,\r\n JvDockControlForm, JvDockSupportControl, JvDockTree, JvDockVIDStyle,\r\n JvDockGlobals, Contnrs;\r\n\r\ntype\r\n TJvDockVSNETConjoinServerOption = class(TJvDockVIDConjoinServerOption)\r\n protected\r\n procedure UpdateDefaultSystemCaptionInfo; override;\r\n public\r\n constructor Create(ADockStyle: TJvDockObservableStyle); override;\r\n end;\r\n\r\n TJvDockVSNETTabServerOption = class(TJvDockVIDTabServerOption)\r\n public\r\n constructor Create(ADockStyle: TJvDockObservableStyle); override;\r\n published\r\n property InactiveSheetColor default VSNETPageInactiveSheetColor;\r\n property ShowTabImages default True;\r\n end;\r\n\r\n TJvDockVSNETChannelOption = class(TJvDockBasicServerOption)\r\n private\r\n FActivePaneSize: Integer;\r\n FShowImage: Boolean;\r\n FMouseleaveHide: Boolean;\r\n FHideHoldTime: Integer;\r\n FTabColor: TColor;\r\n procedure SetActivePaneSize(Value: Integer);\r\n procedure SetShowImage(const Value: Boolean);\r\n procedure SetHideHoldTime(const Value: Integer);\r\n procedure SetMouseleaveHide(const Value: Boolean);\r\n procedure SetTabColor(const Value: TColor);\r\n public\r\n constructor Create(ADockStyle: TJvDockObservableStyle); override;\r\n procedure Assign(Source: TPersistent); override;\r\n published\r\n property ActivePaneSize: Integer read FActivePaneSize write SetActivePaneSize default 100;\r\n { ShowImage is not used }\r\n property ShowImage: Boolean read FShowImage write SetShowImage default True;\r\n property MouseleaveHide: Boolean read FMouseleaveHide write SetMouseleaveHide default True;\r\n property HideHoldTime: Integer read FHideHoldTime write SetHideHoldTime default 1000;\r\n property TabColor: TColor read FTabColor write SetTabColor default clBtnFace;\r\n end;\r\n\r\n TJvDockVSNETChannelOptionClass = class of TJvDockVSNETChannelOption;\r\n\r\n TJvDockVSBlock = class;\r\n TJvDockVSChannel = class;\r\n TJvDockVSNETPanel = class;\r\n TJvDockVSPopupPanel = class;\r\n TJvDockVSPopupPanelSplitter = class;\r\n\r\n TJvDockVSPane = class(TObject)\r\n private\r\n FBlock: TJvDockVSBlock;\r\n FDockForm: TCustomForm;\r\n FIndex: Integer;\r\n FWidth: Integer;\r\n FVisible: Boolean;\r\n function GetActive: Boolean;\r\n public\r\n constructor Create(ABlock: TJvDockVSBlock; AForm: TCustomForm; AWidth: Integer; AIndex: Integer); virtual;\r\n destructor Destroy; override;\r\n // KV added\r\n property Active: Boolean read GetActive;\r\n property Visible: Boolean read FVisible;\r\n property DockForm: TCustomForm read FDockForm;\r\n end;\r\n\r\n TJvDockBlockType = (btConjoinBlock, btTabBlock);\r\n\r\n TJvDockVSBlock = class(TObject)\r\n private\r\n FVSChannel: TJvDockVSChannel;\r\n FVSPanes: TObjectList;\r\n FActiveBlockWidth: Integer;\r\n FInactiveBlockWidth: Integer;\r\n FBlockType: TJvDockBlockType;\r\n FImageList: TImageList;\r\n FBlockStartPos: Integer;\r\n FActivePane: TJvDockVSPane;\r\n function GetVSPane(Index: Integer): TJvDockVSPane;\r\n function GetVSPaneCount: Integer;\r\n function GetActiveDockControl: TWinControl;\r\n procedure SetActivePane(APane: TJvDockVSPane);\r\n protected\r\n procedure ResetActiveBlockWidth;\r\n function AddPane(AControl: TControl; const AWidth: Integer): TJvDockVSPane;\r\n procedure DeletePane(Index: Integer);\r\n procedure UpdateActivePane(StartIndex: Integer);\r\n { Following names should be ActivePaneWidth, InactivePaneWidth }\r\n { ActivePane has size ActiveBlockWidth.. }\r\n property ActiveBlockWidth: Integer read FActiveBlockWidth write FActiveBlockWidth;\r\n { ..other panes have size InactiveBlockWidth }\r\n property InactiveBlockWidth: Integer read FInactiveBlockWidth write FInactiveBlockWidth;\r\n { The popup dock form of ActivePane }\r\n property ActiveDockControl: TWinControl read GetActiveDockControl;\r\n { Pane that last displayed its popup dock form. A block always has an\r\n ActivePane. If no Pane has shown its popup dock form, then the last\r\n added pane is the ActivePane }\r\n property ActivePane: TJvDockVSPane read FActivePane write SetActivePane;\r\n property BlockType: TJvDockBlockType read FBlockType;\r\n { Owner }\r\n property VSChannel: TJvDockVSChannel read FVSChannel;\r\n public\r\n constructor Create(AOwner: TJvDockVSChannel); virtual;\r\n destructor Destroy; override;\r\n procedure AddDockControl(Control: TWinControl);\r\n procedure RemoveDockControl(Control: TWinControl);\r\n function FindDockControl(Control: TWinControl; var PaneIndex: Integer): Boolean;\r\n function GetTotalWidth: Integer;\r\n property VSPaneCount: Integer read GetVSPaneCount;\r\n property VSPane[Index: Integer]: TJvDockVSPane read GetVSPane;\r\n // KV properties added\r\n property ImageList: TImageList read FImageList;\r\n end;\r\n\r\n TJvDockChannelState = (csShow, csHide);\r\n\r\n {\r\n TJvDockServer\r\n |\r\n |----- TJvDockVSNETPanel (4x per server)\r\n |\r\n |----- TJvDockVSChannel\r\n |\r\n |---- TJvDockVSPopupPanel\r\n |\r\n |---- TJvDockVSPopupPanelSplitter\r\n\r\n -------- = maintains/creates\r\n\r\n }\r\n\r\n TJvDockVSChannel = class(TCustomControl)\r\n private\r\n FAnimationDelayTimer: TTimer;\r\n FPopupPane: TJvDockVSPane;\r\n FVSNETDockPanel: TJvDockVSNETPanel; { Owner }\r\n FCurrentPos: Integer;\r\n FBlocks: TObjectList;\r\n FChannelWidth: Integer;\r\n FBlockStartOffset: Integer;\r\n FBlockUpOffset: Integer;\r\n FBlockInterval: Integer;\r\n FVSPopupPanel: TJvDockVSPopupPanel;\r\n FVSPopupPanelSplitter: TJvDockVSPopupPanelSplitter;\r\n FActivePaneSize: Integer;\r\n FDelayPane: TJvDockVSPane;\r\n FStyleLink: TJvDockStyleLink;\r\n FTabColor: TColor;\r\n function GetBlockCount: Integer;\r\n function GetBlock(Index: Integer): TJvDockVSBlock;\r\n function PaneAtPos(MousePos: TPoint): TJvDockVSPane;\r\n procedure SetBlockStartOffset(const Value: Integer);\r\n procedure CMMouseLeave(var Msg: TMessage); message CM_MOUSELEAVE;\r\n procedure FreeBlockList;\r\n procedure SetActivePaneSize(const Value: Integer);\r\n procedure DoAnimationDelay(Sender: TObject);\r\n procedure DockStyleChanged(Sender: TObject);\r\n procedure SetTabColor(const Value: TColor);\r\n function GetDockServer: TJvDockServer;\r\n function GetDockStyle: TJvDockObservableStyle;\r\n function GetActiveDockForm: TCustomForm;\r\n protected\r\n // KV move GetBlockRect to protected\r\n procedure GetBlockRect(Block: TJvDockVSBlock; Index: Integer; var ARect: TRect);\r\n procedure Notification(AComponent: TComponent;\r\n Operation: TOperation); override;\r\n procedure InternalInsertControl(AWinControl: TWinControl);\r\n procedure InternalRemoveControl(AWinControl: TWinControl);\r\n procedure SetPopupPane(APane: TJvDockVSPane);\r\n procedure PopupPaneChanged; virtual;\r\n\r\n procedure ResetFontAngle; virtual;\r\n procedure ResetBlock; virtual;\r\n procedure Paint; override;\r\n procedure MouseDown(Button: TMouseButton; Shift: TShiftState;\r\n X, Y: Integer); override;\r\n procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;\r\n procedure MouseUp(Button: TMouseButton; Shift: TShiftState;\r\n X, Y: Integer); override;\r\n procedure SetVSPopupPanelSplitterPosition;\r\n procedure SyncWithStyle; virtual;\r\n property ChannelWidth: Integer read FChannelWidth;\r\n property BlockStartOffset: Integer read FBlockStartOffset write SetBlockStartOffset;\r\n property BlockUpOffset: Integer read FBlockUpOffset;\r\n property BlockInterval: Integer read FBlockInterval;\r\n property DockServer: TJvDockServer read GetDockServer;\r\n // KV property added\r\n property CurrentPos: Integer read FCurrentPos write FCurrentPos;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n procedure AfterConstruction; override;\r\n { Same as FindPane? }\r\n function GetPaneWithControl(AControl: TControl): TJvDockVSPane;\r\n procedure CreateVSPopupPanel;\r\n procedure DestroyVSPopupPanel;\r\n procedure ResetPosition;\r\n procedure AddDockControl(Control: TWinControl);\r\n procedure RemoveDockControl(Control: TWinControl);\r\n function FindDockControl(Control: TWinControl; var BlockIndex: Integer;\r\n var PaneIndex: Integer): Boolean;\r\n function FindPane(Control: TWinControl): TJvDockVSPane;\r\n procedure AutoFocusActiveDockForm;\r\n { Slides the window into view }\r\n procedure PopupDockForm(Pane: TJvDockVSPane); overload;\r\n procedure PopupDockForm(Control: TWinControl); overload;\r\n { Disables auto-hide }\r\n procedure ShowPopupPanel(Pane: TJvDockVSPane); overload;\r\n procedure ShowPopupPanel(Control: TWinControl); overload;\r\n { Hides the window by sliding it to the edge of the form }\r\n procedure HidePopupPanel(Pane: TJvDockVSPane); overload;\r\n procedure HidePopupPanel(Control: TWinControl); overload;\r\n procedure HidePopupPanelWithAnimate;\r\n procedure ResetActivePaneWidth;\r\n procedure ResetPopupPanelHeight;\r\n procedure RemoveAllBlock;\r\n procedure DeleteBlock(Index: Integer);\r\n property BlockCount: Integer read GetBlockCount;\r\n property Block[Index: Integer]: TJvDockVSBlock read GetBlock;\r\n property VSPopupPanel: TJvDockVSPopupPanel read FVSPopupPanel;\r\n property VSPopupPanelSplitter: TJvDockVSPopupPanelSplitter read FVSPopupPanelSplitter;\r\n { Popup dock form that is visible; nil if no popup form is visible }\r\n property ActiveDockForm: TCustomForm read GetActiveDockForm;\r\n { Maximum size of a block's active pane }\r\n property ActivePaneSize: Integer read FActivePaneSize write SetActivePaneSize;\r\n { Pane that has a visible popup dock form; nil if no popup dock form is visible }\r\n property PopupPane: TJvDockVSPane read FPopupPane;\r\n property TabColor: TColor read FTabColor write SetTabColor;\r\n property DockStyle: TJvDockObservableStyle read GetDockStyle;\r\n end;\r\n\r\n TJvDockVSChannelClass = class of TJvDockVSChannel;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvDockVSNetStyle = class(TJvDockVIDStyle)\r\n private\r\n FTimer: TTimer;\r\n FDockServers: TList;\r\n FCurrentTimer: Integer;\r\n FChannelOption: TJvDockVSNETChannelOption;\r\n FChannelOptionClass: TJvDockVSNETChannelOptionClass;\r\n procedure Timer(Sender: TObject);\r\n function GetChannelOption: TJvDockVSNETChannelOption;\r\n procedure SetChannelOption(const Value: TJvDockVSNETChannelOption);\r\n protected\r\n function DockServerWindowProc(DockServer: TJvDockServer; var Msg: TMessage): Boolean; override;\r\n function DockClientWindowProc(DockClient: TJvDockClient; var Msg: TMessage): Boolean; override;\r\n procedure AddDockBaseControl(ADockBaseControl: TJvDockBaseControl); override;\r\n procedure RemoveDockBaseControl(ADockBaseControl: TJvDockBaseControl); override;\r\n procedure CreateServerOption; override; { AfterConstruction }\r\n procedure FreeServerOption; override; { Destroy }\r\n\r\n procedure BeginPopup(AChannel: TJvDockVSChannel);\r\n procedure EndPopup(AChannel: TJvDockVSChannel);\r\n\r\n { construction/destruction of timer is a bit rigid }\r\n procedure CreateTimer;\r\n procedure DestroyTimer;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n procedure DoUnAutoHideDockForm(DockWindow: TWinControl); virtual;\r\n procedure DoShowDockForm(DockWindow: TWinControl); override;\r\n procedure DoHideDockForm(DockWindow: TWinControl); override;\r\n procedure SetDockFormVisible(ADockClient: TJvDockClient; AVisible: Boolean);\r\n procedure ShowDockForm(ADockClient: TJvDockClient); override;\r\n procedure HideDockForm(ADockClient: TJvDockClient); override;\r\n function GetDockFormVisible(ADockClient: TJvDockClient): Boolean; override;\r\n procedure RestoreClient(DockClient: TJvDockClient); override;\r\n class procedure SetAnimationInterval(const Value: Integer);\r\n class function GetAnimationInterval: Integer;\r\n class function GetAnimationStartInterval: Integer;\r\n class procedure SetAnimationMoveWidth(const Value: Integer);\r\n class function GetAnimationMoveWidth: Integer;\r\n published\r\n property ChannelOption: TJvDockVSNETChannelOption read GetChannelOption write SetChannelOption;\r\n end;\r\n\r\n TJvDockVSNETSplitter = class(TJvDockVIDSplitter);\r\n\r\n { A 'pure' TJvDockVSNETPanel maintains a TJvDockVSChannel (A TJvDockVSPopupPanel\r\n component that is a TJvDockVSNETPanel descendant does NOT, see\r\n TJvDockVSNETPanel.AddDockServer)\r\n }\r\n TJvDockVSNETPanel = class(TJvDockVIDPanel)\r\n private\r\n FVSChannelClass: TJvDockVSChannelClass;\r\n FVSChannel: TJvDockVSChannel;\r\n protected\r\n procedure Notification(AComponent: TComponent;\r\n Operation: TOperation); override;\r\n procedure AddDockServer(ADockServer: TJvDockServer); override;\r\n procedure RemoveDockServer(ADockServer: TJvDockServer); override;\r\n procedure CustomDockDrop(Source: TJvDockDragDockObject; X, Y: Integer); override;\r\n procedure Resize; override;\r\n //KV\r\n property VSChannelClass: TJvDockVSChannelClass\r\n read FVSChannelClass write FVSChannelClass;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n procedure CreateVSChannel;\r\n procedure DestroyVSChannel;\r\n procedure DoAutoHideControl(Control: TWinControl);\r\n procedure DoHideControl(Control: TWinControl);\r\n procedure DoShowControl(Control: TWinControl);\r\n property VSChannel: TJvDockVSChannel read FVSChannel;\r\n end;\r\n\r\n TJvDockVSPopupPanel = class(TJvDockVSNETPanel)\r\n private\r\n FVSNETDockPanel: TJvDockVSNETPanel;\r\n {procedure SetVSNETDockPanel(const Value: TJvDockVSNETPanel);}\r\n function GetVSChannel: TJvDockVSChannel;\r\n protected\r\n function CreateDockManager: IDockManager; override;\r\n procedure SetParent(AParent: TWinControl); override;\r\n public\r\n // Can't put 'override' this one because signature is different!\r\n // But it MUST have DockStyle in the constructor now! -Wpostma!\r\n constructor Create(AOwner: TComponent; APanel: TJvDockVSNETPanel); reintroduce; virtual;\r\n\r\n procedure ShowDockPanel(MakeVisible: Boolean; Client: TControl;\r\n PanelSizeFrom: TJvDockSetDockPanelSizeFrom); override;\r\n { Dirty override; solve with virtual method? }\r\n property VSChannel: TJvDockVSChannel read GetVSChannel;\r\n { Owner }\r\n property VSNETDockPanel: TJvDockVSNETPanel read FVSNETDockPanel {write SetVSNETDockPanel};\r\n end;\r\n\r\n TJvDockVSNETConjoinPanel = class(TJvDockVIDConjoinPanel);\r\n\r\n TJvDockBtnState = (bsUp, bsNormal, bsDown);\r\n\r\n TJvDockVSNETZone = class(TJvDockVIDZone)\r\n private\r\n FAutoHideBtnDown: Boolean;\r\n FAutoHideBtnState: TJvDockBtnState;\r\n FCloseBtnState: TJvDockBtnState;\r\n FVSPaneVisible: Boolean;\r\n procedure SetAutoHideBtnState(const Value: TJvDockBtnState);\r\n procedure SetCloseBtnState(const Value: TJvDockBtnState);\r\n procedure SetAutoHideBtnDown(const Value: Boolean);\r\n procedure SetVSPaneVisible(const Value: Boolean);\r\n protected\r\n procedure DoCustomSetControlName; override;\r\n procedure SetChildControlVisible(Client: TControl; AVisible: Boolean); override;\r\n property AutoHideBtnDown: Boolean read FAutoHideBtnDown write SetAutoHideBtnDown;\r\n property AutoHideBtnState: TJvDockBtnState read FAutoHideBtnState write SetAutoHideBtnState;\r\n property CloseBtnState: TJvDockBtnState read FCloseBtnState write SetCloseBtnState;\r\n property VSPaneVisible: Boolean read FVSPaneVisible write SetVSPaneVisible;\r\n public\r\n constructor Create(Tree: TJvDockTree); override;\r\n\r\n end;\r\n\r\n TJvDockVSNETTree = class(TJvDockVIDTree)\r\n private\r\n FAutoHideZone: TJvDockVSNETZone;\r\n protected\r\n procedure IgnoreZoneInfor(Stream: TMemoryStream); override;\r\n procedure BeginDrag(Control: TControl;\r\n Immediate: Boolean; Threshold: Integer = -1); override;\r\n function DoLButtonDown(var Msg: TWMMouse;\r\n var Zone: TJvDockZone; out HTFlag: Integer): Boolean; override;\r\n procedure DoLButtonUp(var Msg: TWMMouse;\r\n var Zone: TJvDockZone; out HTFlag: Integer); override;\r\n procedure DoLButtonDbClk(var Msg: TWMMouse;\r\n var Zone: TJvDockZone; out HTFlag: Integer); override;\r\n procedure DoMouseMove(var Msg: TWMMouse;\r\n var AZone: TJvDockZone; out HTFlag: Integer); override;\r\n procedure DoHideZoneChild(AZone: TJvDockZone); override;\r\n function GetTopGrabbersHTFlag(const MousePos: TPoint;\r\n out HTFlag: Integer; Zone: TJvDockZone): TJvDockZone; override;\r\n procedure DrawDockGrabber(Control: TWinControl; const ARect: TRect); override;\r\n procedure PaintDockGrabberRect(Canvas: TCanvas; Control: TWinControl;\r\n const ARect: TRect; PaintAlways: Boolean = False); override;\r\n procedure DrawCloseButton(Canvas: TCanvas; Zone: TJvDockZone;\r\n Left, Top: Integer); override;\r\n procedure DrawAutoHideButton(Zone: TJvDockZone;\r\n Left, Top: Integer); virtual;\r\n procedure GetCaptionRect(var Rect: TRect); override;\r\n procedure DoOtherHint(Zone: TJvDockZone;\r\n HTFlag: Integer; var HintStr: string); override;\r\n procedure CustomSaveZone(Stream: TStream;\r\n Zone: TJvDockZone); override;\r\n procedure CustomLoadZone(Stream: TStream;\r\n var Zone: TJvDockZone); override;\r\n property AutoHideZone: TJvDockVSNETZone read FAutoHideZone\r\n write FAutoHideZone;\r\n public\r\n constructor Create(DockSite: TWinControl; DockZoneClass: TJvDockZoneClass;\r\n ADockStyle: TJvDockObservableStyle); override;\r\n end;\r\n\r\n TJvDockVSNETTabSheet = class(TJvDockVIDTabSheet)\r\n private\r\n FOldVisible: Boolean;\r\n procedure SetOldVisible(const Value: Boolean);\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n property OldVisible: Boolean read FOldVisible write SetOldVisible;\r\n end;\r\n\r\n TJvDockVSNETTabPanel = class(TJvDockTabPanel)\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n end;\r\n\r\n TJvDockVSNETTabPageControl = class(TJvDockVIDTabPageControl)\r\n protected\r\n procedure ShowControl(AControl: TControl); override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n end;\r\n\r\n TJvDockVSNETDragDockObject = class(TJvDockVIDDragDockObject);\r\n\r\n TJvDockVSPopupPanelSplitter = class(TCustomControl)\r\n private\r\n FVSPopupPanel: TJvDockVSPopupPanel;\r\n FSplitWidth: Integer;\r\n FActiveControl: TWinControl;\r\n FAutoSnap: Boolean;\r\n FBeveled: Boolean;\r\n FBrush: TBrush;\r\n FControl: TControl;\r\n FDownPos: TPoint;\r\n FLineDC: HDC;\r\n FLineVisible: Boolean;\r\n FMinSize: NaturalNumber;\r\n FMaxSize: Integer;\r\n FNewSize: Integer;\r\n FOldKeyDown: TKeyEvent;\r\n FOldSize: Integer;\r\n FPrevBrush: HBRUSH;\r\n FResizeStyle: TResizeStyle;\r\n FSplit: Integer;\r\n FOnCanResize: TCanResizeEvent;\r\n FOnMoved: TNotifyEvent;\r\n FOnPaint: TNotifyEvent;\r\n procedure AllocateLineDC;\r\n procedure CalcSplitSize(X, Y: Integer; var NewSize, Split: Integer);\r\n procedure DrawLine;\r\n function FindControl: TControl;\r\n procedure FocusKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);\r\n procedure ReleaseLineDC;\r\n procedure SetBeveled(Value: Boolean);\r\n procedure UpdateControlSize;\r\n procedure UpdateSize(X, Y: Integer);\r\n procedure SetVSPopupPanel(Value: TJvDockVSPopupPanel);\r\n function GetVSChannelAlign: TAlign;\r\n procedure SetSplitWidth(const Value: Integer);\r\n protected\r\n procedure Notification(AComponent: TComponent;\r\n Operation: TOperation); override;\r\n function CanResize(var NewSize: Integer): Boolean; reintroduce; virtual;\r\n function DoCanResize(var NewSize: Integer): Boolean; virtual;\r\n procedure MouseDown(Button: TMouseButton; Shift: TShiftState;\r\n X, Y: Integer); override;\r\n procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;\r\n procedure MouseUp(Button: TMouseButton; Shift: TShiftState;\r\n X, Y: Integer); override;\r\n procedure Paint; override;\r\n procedure RequestAlign; override;\r\n procedure StopSizing; dynamic;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n property Canvas;\r\n { Owner of the Owner }\r\n property VSPopupPanel: TJvDockVSPopupPanel read FVSPopupPanel write SetVSPopupPanel;\r\n property SplitWidth: Integer read FSplitWidth write SetSplitWidth;\r\n published\r\n property Align default alLeft;\r\n property VSChannelAlign: TAlign read GetVSChannelAlign;\r\n property AutoSnap: Boolean read FAutoSnap write FAutoSnap default True;\r\n property Beveled: Boolean read FBeveled write SetBeveled default False;\r\n property Color;\r\n property Constraints;\r\n property MinSize: NaturalNumber read FMinSize write FMinSize default 30;\r\n property ParentColor;\r\n property ResizeStyle: TResizeStyle read FResizeStyle write FResizeStyle default rsPattern;\r\n property Visible;\r\n property OnCanResize: TCanResizeEvent read FOnCanResize write FOnCanResize;\r\n property OnMoved: TNotifyEvent read FOnMoved write FOnMoved;\r\n property OnPaint: TNotifyEvent read FOnPaint write FOnPaint;\r\n end;\r\n\r\nprocedure HideAllPopupPanel(ExcludeChannel: TJvDockVSChannel);\r\n{ Disables auto-hide for ADockWindow. If ADockWindow is not auto-hidden then\r\n the procedures works the same as JvDockControlForm.ShowDockForm }\r\nprocedure UnAutoHideDockForm(ADockWindow: TWinControl);\r\nfunction RetrieveChannel(HostDockSite: TWinControl): TJvDockVSChannel;\r\n\r\nvar\r\n DefaultVSChannelClass: TJvDockVSChannelClass = nil;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvDockVSNetStyle.pas $';\r\n Revision: '$Revision: 13415 $';\r\n Date: '$Date: 2012-09-10 11:51:54 +0200 (lun. 10 sept. 2012) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n Types, SysUtils, Math, ImgList, {AppEvnts,} JvJVCLUtils,\r\n JvDockSupportProc;\r\n\r\ntype\r\n TAnimateState = (asPopup, asHide);\r\n\r\n TCustomFormAccess = class(TCustomForm);\r\n TWinControlAccessProtected = class(TWinControl);\r\n TCustomControlAccessProtected = class(TCustomControl);\r\n\r\n { Enumerates the channels of a dock server; Ensure MoveNext returns true\r\n before reading Current }\r\n TChannelEnumerator = class\r\n private\r\n FIndex: Integer;\r\n FDockServer: TJvDockServer;\r\n function GetCurrent: TJvDockVSChannel;\r\n public\r\n constructor Create(ADockServer: TJvDockServer);\r\n function MoveNext: Boolean;\r\n property Current: TJvDockVSChannel read GetCurrent;\r\n end;\r\n\r\n TPopupPanelAnimate = class(TTimer)\r\n private\r\n FMaxWidth: Integer;\r\n FCurrentWidth: Integer;\r\n FActiveChannel: TJvDockVSChannel;\r\n FState: TAnimateState;\r\n protected\r\n procedure Timer; override;\r\n procedure OnCustomTimer(Sender: TObject);\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n { Animates the popup of the form }\r\n procedure PopupForm(AChannel: TJvDockVSChannel; MaxWidth: Integer); virtual;\r\n { Animates the hiding of the form }\r\n procedure HideForm(AChannel: TJvDockVSChannel; MaxWidth: Integer); virtual;\r\n end;\r\n\r\nvar\r\n GlobalPopupPanelAnimate: TPopupPanelAnimate = nil;\r\n GlobalPopupPanelAnimateInterval: Integer = 20;\r\n GlobalPopupPanelAnimateMoveWidth: Integer = 20;\r\n GlobalPopupPanelStartAnimateInterval: Integer = 400;\r\n\r\n//=== Local procedures =======================================================\r\n\r\nfunction PopupPanelAnimate: TPopupPanelAnimate;\r\nbegin\r\n if GlobalPopupPanelAnimate = nil then\r\n GlobalPopupPanelAnimate := TPopupPanelAnimate.Create(nil);\r\n Result := GlobalPopupPanelAnimate;\r\nend;\r\n\r\nprocedure ResetChannelBlockStartOffset(Channel: TJvDockVSChannel);\r\nvar\r\n LeftChannel: TJvDockVSChannel;\r\n OldOffset: Integer;\r\n LeftAlignArea: Integer;\r\nbegin\r\n LeftChannel := TJvDockVSNETPanel(Channel.DockServer.LeftDockPanel).VSChannel;\r\n if LeftChannel <> nil then\r\n begin\r\n LeftAlignArea := GetClientAlignControlArea(LeftChannel.Parent, alLeft);\r\n with TChannelEnumerator.Create(Channel.DockServer) do\r\n try\r\n while MoveNext do\r\n if Current.Align in [alTop, alBottom] then\r\n begin\r\n OldOffset := Current.BlockStartOffset;\r\n Current.BlockStartOffset := 2 + LeftAlignArea;\r\n if OldOffset <> Current.BlockStartOffset then\r\n Current.Invalidate;\r\n end;\r\n finally\r\n Free;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure SetControlBringToFront(Control: TWinControl; Align: TAlign);\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := Control.ControlCount - 1 downto 0 do\r\n if Control.Controls[I].Visible and (Control.Controls[I].Align = Align) and\r\n not (Control.Controls[I] is TJvDockVSChannel) and\r\n not (Control.Controls[I] is TJvDockPanel) and\r\n not (Control.Controls[I] is TJvDockSplitter) then\r\n Control.Controls[I].BringToFront;\r\nend;\r\n\r\nfunction ControlIsOnPopup(AControl: TControl): Boolean;\r\nbegin\r\n Result := False;\r\n\r\n while Assigned(AControl) do\r\n begin\r\n if (AControl is TJvDockVSPopupPanel) or\r\n (AControl is TJvDockVSPopupPanelSplitter) or\r\n (AControl is TJvDockVSChannel) then\r\n begin\r\n Result := True;\r\n Exit;\r\n end;\r\n AControl := AControl.Parent;\r\n end;\r\nend;\r\n\r\n//=== Global procedures ======================================================\r\n\r\nprocedure HideAllPopupPanel(ExcludeChannel: TJvDockVSChannel);\r\nvar\r\n I: Integer;\r\n DockServer: TJvDockServer;\r\nbegin\r\n for I := 0 to JvGlobalDockManager.DockServerCount - 1 do\r\n begin\r\n DockServer := JvGlobalDockManager.DockServer[I];\r\n if Assigned(DockServer) then\r\n with TChannelEnumerator.Create(DockServer) do\r\n try\r\n while MoveNext do\r\n if Current <> ExcludeChannel then\r\n Current.HidePopupPanel(Current.PopupPane);\r\n finally\r\n Free;\r\n end;\r\n end;\r\nend;\r\n\r\n{ Returns the channel of a form that is docked onto a popup panel }\r\n\r\nfunction RetrieveChannel(HostDockSite: TWinControl): TJvDockVSChannel;\r\nbegin\r\n Result := nil;\r\n if HostDockSite is TJvDockVSPopupPanel then\r\n // normal docked forms\r\n Result := TJvDockVSPopupPanel(HostDockSite).VSChannel\r\n else\r\n if Assigned(HostDockSite) and Assigned(HostDockSite.Parent) then\r\n begin\r\n HostDockSite := HostDockSite.Parent.HostDockSite;\r\n if HostDockSite is TJvDockVSPopupPanel then\r\n // tab docked forms\r\n Result := TJvDockVSPopupPanel(HostDockSite).VSChannel\r\n end;\r\nend;\r\n\r\nprocedure UnAutoHideDockForm(ADockWindow: TWinControl);\r\nvar\r\n ADockClient: TJvDockClient;\r\nbegin\r\n // delegate to style\r\n ADockClient := FindDockClient(ADockWindow);\r\n if Assigned(ADockClient) and (ADockClient.DockStyle is TJvDockVSNetStyle) then\r\n TJvDockVSNetStyle(ADockClient.DockStyle).DoUnAutoHideDockForm(ADockWindow);\r\nend;\r\n\r\n//=== { TChannelEnumerator } =================================================\r\n\r\nconstructor TChannelEnumerator.Create(ADockServer: TJvDockServer);\r\nbegin\r\n inherited Create;\r\n FIndex := -1;\r\n FDockServer := ADockServer;\r\nend;\r\n\r\nfunction TChannelEnumerator.GetCurrent: TJvDockVSChannel;\r\nbegin\r\n Result := TJvDockVSNETPanel(FDockServer.DockPanelWithAlign[TAlign(FIndex)]).VSChannel;\r\nend;\r\n\r\nfunction TChannelEnumerator.MoveNext: Boolean;\r\nvar\r\n I: Integer;\r\n Panel: TJvDockPanel;\r\nbegin\r\n I := FIndex + 1;\r\n while I <= Ord(High(TAlign)) do\r\n begin\r\n Panel := FDockServer.DockPanelWithAlign[TAlign(I)];\r\n if (Panel is TJvDockVSNETPanel) and Assigned(TJvDockVSNETPanel(Panel).VSChannel) then\r\n Break;\r\n Inc(I);\r\n end;\r\n Result := I <= Ord(High(TAlign));\r\n if Result then\r\n FIndex := I;\r\nend;\r\n\r\n//=== { TJvDockVSBlock } =====================================================\r\n\r\nconstructor TJvDockVSBlock.Create(AOwner: TJvDockVSChannel);\r\nbegin\r\n inherited Create;\r\n FVSChannel := AOwner;\r\n FVSPanes := TObjectList.Create;\r\n FImageList := TImageList.CreateSize(16, 16);\r\n {$IFDEF RTL200_UP}\r\n FImageList.ColorDepth := cd32Bit;\r\n {$ENDIF RTL200_UP}\r\n FInactiveBlockWidth := 24;\r\n FActiveBlockWidth := 24;\r\nend;\r\n\r\ndestructor TJvDockVSBlock.Destroy;\r\nbegin\r\n FImageList.Free;\r\n FVSPanes.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvDockVSBlock.AddDockControl(Control: TWinControl);\r\nvar\r\n I, PaneWidth, FirstIndex: Integer;\r\n\r\n function GetPaneWidth: Integer;\r\n begin\r\n Result := 100;\r\n if Control = nil then\r\n Exit;\r\n case VSChannel.Align of\r\n alLeft, alRight:\r\n Result := Control.Width;\r\n alTop, alBottom:\r\n Result := Control.Height;\r\n end;\r\n end;\r\n\r\nvar\r\n NewPane: TJvDockVSPane;\r\n Form: TCustomForm;\r\n APageControl: TJvDockTabPageControl;\r\nbegin\r\n PaneWidth := GetPaneWidth;\r\n if Control is TJvDockTabHostForm then\r\n begin\r\n FBlockType := btTabBlock;\r\n APageControl := TJvDockTabHostForm(Control).PageControl;\r\n FirstIndex := VSPaneCount;\r\n { Mantis 3989: (Kiriakos) PageControl.DockClients does NOT have to be in the\r\n same order as PageControl.Pages; for example, if we reorder the pages. }\r\n for I := 0 to APageControl.Count - 1 do\r\n begin\r\n Form := APageControl.DockForm[I];\r\n if Assigned(Form) then\r\n begin\r\n AddPane(Form, PaneWidth);\r\n TJvDockVSNETTabSheet(APageControl.Pages[I]).OldVisible := Form.Visible;\r\n if APageControl.Pages[I] <> APageControl.ActivePage then\r\n Form.Visible := False;\r\n end;\r\n end;\r\n UpdateActivePane(FirstIndex);\r\n end\r\n else\r\n begin\r\n FBlockType := btConjoinBlock;\r\n NewPane := AddPane(Control, PaneWidth);\r\n if Assigned(NewPane) then\r\n ActivePane := NewPane;\r\n end;\r\n ResetActiveBlockWidth;\r\nend;\r\n\r\nfunction TJvDockVSBlock.AddPane(AControl: TControl; const AWidth: Integer): TJvDockVSPane;\r\nconst\r\n ANDbits: array[0..2*16-1] of Byte = ($FF,$FF,\r\n $FF,$FF,\r\n $FF,$FF,\r\n $FF,$FF,\r\n $FF,$FF,\r\n $FF,$FF,\r\n $FF,$FF,\r\n $FF,$FF,\r\n $FF,$FF,\r\n $FF,$FF,\r\n $FF,$FF,\r\n $FF,$FF,\r\n $FF,$FF,\r\n $FF,$FF,\r\n $FF,$FF,\r\n $FF,$FF);\r\n XORbits: array[0..2*16-1] of Byte = ($00,$00,\r\n $00,$00,\r\n $00,$00,\r\n $00,$00,\r\n $00,$00,\r\n $00,$00,\r\n $00,$00,\r\n $00,$00,\r\n $00,$00,\r\n $00,$00,\r\n $00,$00,\r\n $00,$00,\r\n $00,$00,\r\n $00,$00,\r\n $00,$00,\r\n $00,$00);\r\nvar\r\n Icon: TIcon;\r\n ADockClient: TJvDockClient;\r\nbegin\r\n if not (AControl is TCustomForm) then\r\n begin\r\n Result := nil;\r\n Exit;\r\n end;\r\n\r\n Result := TJvDockVSPane.Create(Self, TCustomForm(AControl), AWidth, VSPaneCount);\r\n FVSPanes.Add(Result);\r\n if not JvGlobalDockIsLoading then\r\n begin\r\n ADockClient := FindDockClient(AControl);\r\n if ADockClient <> nil then\r\n ADockClient.VSPaneWidth := AWidth;\r\n end;\r\n { Add the form icon }\r\n\r\n if not Assigned(TCustomFormAccess(AControl).Icon) or not TCustomFormAccess(AControl).Icon.HandleAllocated then\r\n begin\r\n Icon := TIcon.Create;\r\n try\r\n Icon.Width := 16;\r\n Icon.Height := 16;\r\n //2. Adding an Icon without real bitmap does nothing,\r\n //so transparent icon needed\r\n Icon.Handle := CreateIcon(hInstance,16,16,1,1,@ANDbits,@XORbits);\r\n FImageList.AddIcon(Icon);\r\n finally\r\n Icon.Free;\r\n end;\r\n end\r\n else\r\n FImageList.AddIcon(TCustomFormAccess(AControl).Icon);\r\nend;\r\n\r\nprocedure TJvDockVSBlock.DeletePane(Index: Integer);\r\nvar\r\n I: Integer;\r\n ActivePaneRemoved: Boolean;\r\nbegin\r\n for I := Index to VSPaneCount - 2 do\r\n VSPane[I + 1].FIndex := VSPane[I].FIndex;\r\n ActivePaneRemoved := VSPane[Index] = Self.ActivePane;\r\n FVSPanes.Delete(Index);\r\n { Remove the form icon }\r\n if Index < FImageList.Count then\r\n FImageList.Delete(Index);\r\n if ActivePaneRemoved then\r\n UpdateActivePane(Index);\r\nend;\r\n\r\nfunction TJvDockVSBlock.FindDockControl(Control: TWinControl;\r\n var PaneIndex: Integer): Boolean;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := False;\r\n PaneIndex := -1;\r\n if Control = nil then\r\n Exit;\r\n for I := 0 to VSPaneCount - 1 do\r\n if VSPane[I].FDockForm = Control then\r\n begin\r\n PaneIndex := I;\r\n Result := True;\r\n Exit;\r\n end;\r\n if FBlockType = btTabBlock then\r\n begin\r\n if (VSPaneCount > 0) and (VSPane[0].FDockForm.HostDockSite.Parent = Control) then\r\n begin\r\n PaneIndex := 0;\r\n Result := True;\r\n Exit;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJvDockVSBlock.GetActiveDockControl: TWinControl;\r\nbegin\r\n if Assigned(ActivePane) then\r\n Result := ActivePane.DockForm\r\n else\r\n Result := nil;\r\nend;\r\n\r\nfunction TJvDockVSBlock.GetTotalWidth: Integer;\r\nbegin\r\n // 1 pane is active, the rest is inactive\r\n Result := (VSPaneCount - 1) * FInactiveBlockWidth + FActiveBlockWidth;\r\nend;\r\n\r\nfunction TJvDockVSBlock.GetVSPane(Index: Integer): TJvDockVSPane;\r\nbegin\r\n Result := TJvDockVSPane(FVSPanes[Index]);\r\nend;\r\n\r\nfunction TJvDockVSBlock.GetVSPaneCount: Integer;\r\nbegin\r\n Result := FVSPanes.Count;\r\nend;\r\n\r\nprocedure TJvDockVSBlock.RemoveDockControl(Control: TWinControl);\r\nbegin\r\n ResetActiveBlockWidth;\r\nend;\r\n\r\nprocedure TJvDockVSBlock.ResetActiveBlockWidth;\r\nvar\r\n I: Integer;\r\n TextWidth: Integer;\r\n Canvas: TCanvas;\r\nbegin\r\n FActiveBlockWidth := 0;\r\n\r\n if VSPaneCount > 0 then\r\n begin\r\n if VSChannel.Parent is TCustomControl then\r\n Canvas := TCustomControlAccessProtected(VSChannel.Parent).Canvas\r\n else if VSChannel.Parent is TCustomForm then\r\n Canvas := TForm(VSChannel.Parent).Canvas\r\n else\r\n Canvas := nil;\r\n\r\n if Canvas <> nil then\r\n begin\r\n for I := 0 to VSPaneCount - 1 do\r\n begin\r\n TextWidth := Canvas.TextWidth(VSPane[I].FDockForm.Caption) + InactiveBlockWidth + 10;\r\n if TextWidth >= VSChannel.ActivePaneSize then\r\n begin\r\n FActiveBlockWidth := VSChannel.ActivePaneSize;\r\n Exit;\r\n end;\r\n\r\n FActiveBlockWidth := Max(FActiveBlockWidth, TextWidth);\r\n end;\r\n end;\r\n end;\r\n\r\n if FActiveBlockWidth = 0 then\r\n FActiveBlockWidth := VSChannel.ActivePaneSize;\r\nend;\r\n\r\nprocedure TJvDockVSBlock.SetActivePane(APane: TJvDockVSPane);\r\nbegin\r\n if FActivePane <> APane then\r\n begin\r\n FActivePane := APane;\r\n VSChannel.Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockVSBlock.UpdateActivePane(StartIndex: Integer);\r\nvar\r\n I: Integer;\r\nbegin\r\n { Start looking at position StartIndex for a visible pane }\r\n for I := 0 to VSPaneCount - 1 do\r\n if VSPane[(I + StartIndex) mod VSPaneCount].FVisible then\r\n begin\r\n ActivePane := VSPane[(I + StartIndex) mod VSPaneCount];\r\n Break;\r\n end;\r\nend;\r\n\r\n//=== { TJvDockVSChannel } ===================================================\r\n\r\nconstructor TJvDockVSChannel.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FStyleLink := TJvDockStyleLink.Create;\r\n FBlocks := TObjectList.Create;\r\n FActivePaneSize := MaxActivePaneWidth;\r\n FTabColor := clBtnFace;\r\n FChannelWidth := 22;\r\n FBlockStartOffset := 2;\r\n FBlockUpOffset := 2;\r\n FBlockInterval := 13;\r\n if AOwner is TJvDockVSNETPanel then\r\n begin\r\n FVSNETDockPanel := TJvDockVSNETPanel(AOwner);\r\n { First set DockStyle then OnStyleChanged so no OnStyleChanged is fired;\r\n we do it ourself in AfterContruction }\r\n FStyleLink.DockStyle := DockServer.DockStyle;\r\n end;\r\n FStyleLink.OnStyleChanged := DockStyleChanged;\r\n Color := VSNETPageInactiveSheetColor;\r\n ParentFont := True;\r\nend;\r\n\r\ndestructor TJvDockVSChannel.Destroy;\r\nbegin\r\n if Assigned(GlobalPopupPanelAnimate) and (GlobalPopupPanelAnimate.FActiveChannel = Self) then\r\n begin\r\n GlobalPopupPanelAnimate.Free;\r\n GlobalPopupPanelAnimate := nil;\r\n end;\r\n FreeBlockList;\r\n FAnimationDelayTimer.Free;\r\n FStyleLink.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvDockVSChannel.AddDockControl(Control: TWinControl);\r\nvar\r\n ABlock: TJvDockVSBlock;\r\nbegin\r\n if Control is TJvDockTabHostForm then\r\n begin\r\n ABlock := TJvDockVSBlock.Create(Self);\r\n ABlock.AddDockControl(Control);\r\n FBlocks.Add(ABlock);\r\n end\r\n else\r\n begin\r\n if (BlockCount >= 1) and (Block[0].BlockType = btConjoinBlock) then\r\n Block[0].AddDockControl(Control)\r\n else\r\n begin\r\n ABlock := TJvDockVSBlock.Create(Self);\r\n ABlock.AddDockControl(Control);\r\n FBlocks.Insert(0, ABlock);\r\n end;\r\n end;\r\n HideAllPopupPanel(Self);\r\n ResetPosition;\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvDockVSChannel.AfterConstruction;\r\nbegin\r\n inherited AfterConstruction;\r\n FStyleLink.StyleChanged;\r\nend;\r\n\r\nprocedure TJvDockVSChannel.AutoFocusActiveDockForm;\r\nbegin\r\n if DockServer.AutoFocusDockedForm and Assigned(ActiveDockForm) and ActiveDockForm.CanFocus then\r\n begin\r\n ActiveDockForm.SetFocus;\r\n {$IFNDEF COMPILER9_UP}\r\n InvalidateDockHostSiteOfControl(ActiveDockForm, False);\r\n {$ENDIF !COMPILER9_UP}\r\n end;\r\nend;\r\n\r\nprocedure TJvDockVSChannel.CMMouseLeave(var Msg: TMessage);\r\nbegin\r\n inherited;\r\nend;\r\n\r\nprocedure TJvDockVSChannel.CreateVSPopupPanel;\r\nbegin\r\n FVSPopupPanel := TJvDockVSPopupPanel.Create(Parent, FVSNETDockPanel);\r\n\r\n { Channel is maintainer/Creator }\r\n FVSPopupPanel.FreeNotification(Self);\r\n FVSPopupPanel.Name := FVSNETDockPanel.Name + '_PopupPanel';\r\n FVSPopupPanel.Visible := False;\r\n if Parent is TCustomForm then\r\n begin\r\n FVSPopupPanel.Parent := Parent;\r\n FVSPopupPanel.Align := alNone;\r\n FVSPopupPanel.BringToFront;\r\n end;\r\n FVSPopupPanelSplitter := TJvDockVSPopupPanelSplitter.Create(Parent);\r\n { Channel is maintainer/Creator }\r\n FVSPopupPanelSplitter.FreeNotification(Self);\r\n if Parent is TCustomForm then\r\n begin\r\n FVSPopupPanelSplitter.Parent := Parent;\r\n FVSPopupPanelSplitter.Align := alNone;\r\n FVSPopupPanelSplitter.VSPopupPanel := VSPopupPanel;\r\n FVSPopupPanelSplitter.Color := clBtnFace;\r\n FVSPopupPanelSplitter.Visible := False;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockVSChannel.DeleteBlock(Index: Integer);\r\nbegin\r\n FBlocks.Delete(Index);\r\nend;\r\n\r\nprocedure TJvDockVSChannel.DestroyVSPopupPanel;\r\nbegin\r\n FreeAndNil(FVSPopupPanel);\r\n FreeAndNil(FVSPopupPanelSplitter);\r\nend;\r\n\r\nprocedure TJvDockVSChannel.DoAnimationDelay(Sender: TObject);\r\nvar\r\n P: TPoint;\r\nbegin\r\n try\r\n // Show the form only if the cursor is still above the same pane\r\n GetCursorPos(P);\r\n if PaneAtPos(ScreenToClient(P)) = FDelayPane then\r\n PopupDockForm(FDelayPane);\r\n finally\r\n // dangerous to free in handler?\r\n FAnimationDelayTimer.Free;\r\n FAnimationDelayTimer := nil;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockVSChannel.DockStyleChanged(Sender: TObject);\r\nbegin\r\n SyncWithStyle;\r\nend;\r\n\r\nfunction TJvDockVSChannel.FindDockControl(Control: TWinControl;\r\n var BlockIndex: Integer; var PaneIndex: Integer): Boolean;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := False;\r\n BlockIndex := -1;\r\n PaneIndex := -1;\r\n if Control = nil then\r\n Exit;\r\n\r\n for I := 0 to BlockCount - 1 do\r\n if Block[I].FindDockControl(Control, PaneIndex) then\r\n begin\r\n BlockIndex := I;\r\n Result := True;\r\n Exit;\r\n end;\r\nend;\r\n\r\nfunction TJvDockVSChannel.FindPane(Control: TWinControl): TJvDockVSPane;\r\nvar\r\n I, J: Integer;\r\nbegin\r\n Result := nil;\r\n if FindDockControl(Control, I, J) then\r\n Result := Block[I].VSPane[J];\r\nend;\r\n\r\nprocedure TJvDockVSChannel.FreeBlockList;\r\nbegin\r\n FreeAndNil(FBlocks);\r\nend;\r\n\r\nfunction TJvDockVSChannel.GetActiveDockForm: TCustomForm;\r\nbegin\r\n if PopupPane <> nil then\r\n Result := PopupPane.DockForm\r\n else\r\n Result := nil;\r\nend;\r\n\r\nfunction TJvDockVSChannel.GetBlock(Index: Integer): TJvDockVSBlock;\r\nbegin\r\n Result := TJvDockVSBlock(FBlocks[Index]);\r\nend;\r\n\r\nfunction TJvDockVSChannel.GetBlockCount: Integer;\r\nbegin\r\n Result := FBlocks.Count;\r\nend;\r\n\r\nprocedure TJvDockVSChannel.GetBlockRect(Block: TJvDockVSBlock; Index: Integer;\r\n var ARect: TRect);\r\nvar\r\n BlockWidth: Integer;\r\nbegin\r\n if Block.VSPane[Index] <> Block.ActivePane then\r\n BlockWidth := Block.InactiveBlockWidth\r\n else\r\n BlockWidth := Block.ActiveBlockWidth;\r\n\r\n case Align of\r\n alLeft:\r\n begin\r\n ARect.Left := -1;\r\n ARect.Top := FCurrentPos;\r\n ARect.Right := Width - FBlockUpOffset;\r\n ARect.Bottom := ARect.Top + BlockWidth;\r\n end;\r\n alRight:\r\n begin\r\n ARect.Left := FBlockUpOffset;\r\n ARect.Top := FCurrentPos;\r\n ARect.Right := Width + 1;\r\n ARect.Bottom := ARect.Top + BlockWidth;\r\n end;\r\n alTop:\r\n begin\r\n ARect.Left := FCurrentPos;\r\n ARect.Top := -1;\r\n ARect.Right := ARect.Left + BlockWidth;\r\n ARect.Bottom := Height - FBlockUpOffset;\r\n end;\r\n alBottom:\r\n begin\r\n ARect.Left := FCurrentPos;\r\n ARect.Top := FBlockUpOffset;\r\n ARect.Right := ARect.Left + BlockWidth;\r\n ARect.Bottom := Height + 1;\r\n end;\r\n end;\r\n\r\n Inc(FCurrentPos, BlockWidth - 1);\r\nend;\r\n\r\nfunction TJvDockVSChannel.GetDockServer: TJvDockServer;\r\nbegin\r\n if Assigned(FVSNETDockPanel) then\r\n Result := FVSNETDockPanel.DockServer\r\n else\r\n Result := nil;\r\nend;\r\n\r\nfunction TJvDockVSChannel.GetDockStyle: TJvDockObservableStyle;\r\nbegin\r\n Result := FStyleLink.DockStyle;\r\nend;\r\n\r\nfunction TJvDockVSChannel.GetPaneWithControl(AControl: TControl): TJvDockVSPane;\r\nvar\r\n I, J: Integer;\r\nbegin\r\n Result := nil;\r\n for I := 0 to BlockCount - 1 do\r\n for J := 0 to Block[I].VSPaneCount - 1 do\r\n if AControl = Block[I].VSPane[J].FDockForm then\r\n begin\r\n Result := Block[I].VSPane[J];\r\n Exit;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockVSChannel.HidePopupPanel(Pane: TJvDockVSPane);\r\nbegin\r\n if Pane <> nil then\r\n begin\r\n if Align in [alLeft, alRight] then\r\n begin\r\n VSPopupPanel.Width := 0;\r\n VSPopupPanelSplitter.Width := 0;\r\n end\r\n else\r\n if Align in [alTop, alBottom] then\r\n begin\r\n VSPopupPanel.Height := 0;\r\n VSPopupPanelSplitter.Height := 0;\r\n end;\r\n SetPopupPane(nil);\r\n end;\r\n VSPopupPanel.Visible := False;\r\n VSPopupPanelSplitter.Visible := False;\r\n SetPopupPane(nil);\r\nend;\r\n\r\nprocedure TJvDockVSChannel.HidePopupPanel(Control: TWinControl);\r\nvar\r\n Pane: TJvDockVSPane;\r\nbegin\r\n Pane := FindPane(Control);\r\n if Assigned(Pane) then\r\n HidePopupPanel(Pane);\r\nend;\r\n\r\nprocedure TJvDockVSChannel.HidePopupPanelWithAnimate;\r\nbegin\r\n if PopupPane <> nil then\r\n PopupPanelAnimate.HideForm(Self, PopupPane.FWidth);\r\nend;\r\n\r\nprocedure TJvDockVSChannel.InternalInsertControl(AWinControl: TWinControl);\r\nbegin\r\n if Assigned(AWinControl) then\r\n begin\r\n if Assigned(VSPopupPanel) and VSPopupPanel.UseDockManager and (VSPopupPanel.JvDockManager <> nil) then\r\n VSPopupPanel.JvDockManager.InsertControl(AWinControl, alNone, nil);\r\n AWinControl.FreeNotification(Self);\r\n end;\r\nend;\r\n\r\nprocedure TJvDockVSChannel.InternalRemoveControl(AWinControl: TWinControl);\r\nbegin\r\n if Assigned(AWinControl) then\r\n begin\r\n AWinControl.RemoveFreeNotification(Self);\r\n if Assigned(VSPopupPanel) and VSPopupPanel.UseDockManager and (VSPopupPanel.JvDockManager <> nil) then\r\n VSPopupPanel.JvDockManager.RemoveControl(AWinControl);\r\n end;\r\nend;\r\n\r\nprocedure TJvDockVSChannel.MouseDown(Button: TMouseButton; Shift: TShiftState;\r\n X, Y: Integer);\r\nvar\r\n Pane: TJvDockVSPane;\r\nbegin\r\n inherited MouseDown(Button, Shift, X, Y);\r\n Pane := PaneAtPos(Point(X, Y));\r\n if Assigned(Pane) then\r\n begin\r\n if PopupPane = Pane then\r\n begin\r\n if Pane.DockForm.CanFocus then\r\n Pane.DockForm.SetFocus;\r\n end\r\n else\r\n PopupDockForm(Pane);\r\n end;\r\nend;\r\n\r\nprocedure TJvDockVSChannel.MouseMove(Shift: TShiftState; X, Y: Integer);\r\nvar\r\n NewDelayPane: TJvDockVSPane;\r\nbegin\r\n inherited MouseMove(Shift, X, Y);\r\n\r\n NewDelayPane := PaneAtPos(Point(X, Y));\r\n if Assigned(NewDelayPane) and (NewDelayPane <> PopupPane) and IsForegroundTask then\r\n begin\r\n // Create the timer object if not existing\r\n if FAnimationDelayTimer = nil then\r\n begin\r\n FAnimationDelayTimer := TTimer.Create(nil);\r\n FAnimationDelayTimer.OnTimer := DoAnimationDelay;\r\n FAnimationDelayTimer.Interval := TJvDockVSNetStyle.GetAnimationStartInterval;\r\n FAnimationDelayTimer.Enabled := True;\r\n end\r\n // Restart the timer only, if mouse is above another pane now\r\n else\r\n if NewDelayPane <> FDelayPane then\r\n begin\r\n FAnimationDelayTimer.Enabled := False;\r\n FAnimationDelayTimer.Enabled := True;\r\n end;\r\n end\r\n else\r\n FreeAndNil(FAnimationDelayTimer);\r\n\r\n FDelayPane := NewDelayPane;\r\nend;\r\n\r\nprocedure TJvDockVSChannel.MouseUp(Button: TMouseButton; Shift: TShiftState;\r\n X, Y: Integer);\r\nbegin\r\n inherited MouseUp(Button, Shift, X, Y);\r\nend;\r\n\r\nprocedure TJvDockVSChannel.Notification(AComponent: TComponent;\r\n Operation: TOperation);\r\nbegin\r\n inherited Notification(AComponent, Operation);\r\n if Operation = opRemove then\r\n begin\r\n if AComponent = FVSPopupPanel then\r\n begin\r\n FVSPopupPanel := nil;\r\n DestroyVSPopupPanel;\r\n end\r\n else\r\n if AComponent = FVSPopupPanelSplitter then\r\n begin\r\n FVSPopupPanelSplitter := nil;\r\n DestroyVSPopupPanel;\r\n end\r\n else\r\n if AComponent is TWinControl then\r\n InternalRemoveControl(TWinControl(AComponent));\r\n end;\r\nend;\r\n\r\nprocedure TJvDockVSChannel.Paint;\r\nvar\r\n I: Integer;\r\n\r\n procedure DrawSingleBlock(Block: TJvDockVSBlock);\r\n var\r\n DrawRect: TRect;\r\n I: Integer;\r\n OldGraphicsMode: Integer;\r\n VisiblePaneCount: Integer;\r\n\r\n procedure AdjustImagePos;\r\n begin\r\n if Align = alLeft then\r\n begin\r\n Inc(DrawRect.Left, 3);\r\n Inc(DrawRect.Top, 4);\r\n end\r\n else\r\n if Align = alTop then\r\n begin\r\n Inc(DrawRect.Left, 4);\r\n Inc(DrawRect.Top, 2);\r\n end\r\n else\r\n if Align = alRight then\r\n begin\r\n Inc(DrawRect.Left, 4);\r\n Inc(DrawRect.Top, 4);\r\n end\r\n else\r\n if Align = alBottom then\r\n begin\r\n Inc(DrawRect.Left, 4);\r\n Inc(DrawRect.Top, 3);\r\n end;\r\n end;\r\n\r\n begin\r\n VisiblePaneCount := 0;\r\n for I := 0 to Block.VSPaneCount - 1 do\r\n begin\r\n if not Block.VSPane[I].FVisible then\r\n Continue;\r\n\r\n GetBlockRect(Block, I, DrawRect);\r\n Canvas.Brush.Color := TabColor;\r\n Canvas.FillRect(DrawRect);\r\n Canvas.Brush.Color := clGray;\r\n Canvas.FrameRect(DrawRect);\r\n\r\n AdjustImagePos;\r\n Block.FImageList.Draw(Canvas, DrawRect.Left, DrawRect.Top, I, dsTransparent, itImage);\r\n\r\n if Block.ActivePane = Block.VSPane[I] then\r\n begin\r\n if Align in [alTop, alBottom] then\r\n Inc(DrawRect.Left, Block.InactiveBlockWidth)\r\n else\r\n if Align in [alLeft, alRight] then\r\n begin\r\n Inc(DrawRect.Top, Block.InactiveBlockWidth);\r\n if Align = alLeft then\r\n DrawRect.Left := 15\r\n else\r\n DrawRect.Left := 20;\r\n DrawRect.Right := DrawRect.Left + (DrawRect.Bottom - DrawRect.Top);\r\n end;\r\n Canvas.Brush.Color := TabColor;\r\n Canvas.Pen.Color := clBlack;\r\n\r\n Dec(DrawRect.Right, 3);\r\n\r\n OldGraphicsMode := SetGraphicsMode(Canvas.Handle, GM_ADVANCED);\r\n Canvas.Brush.Style := bsClear;\r\n DrawText(Canvas.Handle, PChar(Block.VSPane[I].FDockForm.Caption), -1, DrawRect, DT_END_ELLIPSIS or DT_NOCLIP);\r\n SetGraphicsMode(Canvas.Handle, OldGraphicsMode);\r\n end;\r\n Inc(VisiblePaneCount);\r\n end;\r\n if VisiblePaneCount > 0 then\r\n Inc(FCurrentPos, FBlockInterval);\r\n end;\r\n\r\nbegin\r\n inherited Paint;\r\n\r\n FCurrentPos := FBlockStartOffset;\r\n for I := 0 to BlockCount - 1 do\r\n DrawSingleBlock(Block[I]);\r\nend;\r\n\r\nfunction TJvDockVSChannel.PaneAtPos(MousePos: TPoint): TJvDockVSPane;\r\nvar\r\n I, J: Integer;\r\n ARect: TRect;\r\nbegin\r\n Result := nil;\r\n FCurrentPos := FBlockStartOffset;\r\n for I := 0 to BlockCount - 1 do\r\n begin\r\n for J := 0 to Block[I].VSPaneCount - 1 do\r\n begin\r\n if not Block[I].VSPane[J].FVisible then\r\n Continue;\r\n GetBlockRect(Block[I], J, ARect);\r\n if PtInRect(ARect, MousePos) then\r\n begin\r\n Result := Block[I].VSPane[J];\r\n Exit;\r\n end;\r\n end;\r\n Inc(FCurrentPos, FBlockInterval);\r\n end;\r\nend;\r\n\r\nprocedure TJvDockVSChannel.PopupDockForm(Pane: TJvDockVSPane);\r\n\r\n procedure SetSingleDockFormVisible(HostDockSite: TWinControl; AForm: TCustomForm);\r\n var\r\n I: Integer;\r\n begin\r\n AForm.Visible := True;\r\n for I := 0 to HostDockSite.DockClientCount - 1 do\r\n if AForm <> HostDockSite.DockClients[I] then\r\n HostDockSite.DockClients[I].Visible := False;\r\n end;\r\n\r\nbegin\r\n if (Pane = nil) or (PopupPane = Pane) then\r\n Exit;\r\n\r\n HidePopupPanel(PopupPane);\r\n { !! Setting visible to true here is too early and causes Align problems.\r\n Visibility is anyway set by FVSPopupPanel.JvDockManager.ShowSingleControl\r\n call.\r\n }\r\n // Pane.FDockForm.Visible := True;\r\n PopupPanelAnimate.PopupForm(Self, Pane.FWidth);\r\n if (Pane.FDockForm <> nil) and (Pane.FDockForm.HostDockSite.Parent is TJvDockTabHostForm) then\r\n begin\r\n // Popup is shown, but the dockform is on a pagecontrol with multiple\r\n // tabs. We hide the other tabs.\r\n SetSingleDockFormVisible(Pane.FDockForm.HostDockSite, Pane.FDockForm);\r\n TJvDockTabHostForm(Pane.FDockForm.HostDockSite.Parent).Caption := Pane.FDockForm.Caption;\r\n // Make the pagecontrol the only visible control.\r\n FVSPopupPanel.JvDockManager.ShowSingleControl(Pane.FDockForm.HostDockSite.Parent);\r\n end\r\n else\r\n FVSPopupPanel.JvDockManager.ShowSingleControl(Pane.FDockForm);\r\n SetPopupPane(Pane);\r\n FVSPopupPanel.JvDockManager.ResetBounds(True);\r\nend;\r\n\r\nprocedure TJvDockVSChannel.PopupDockForm(Control: TWinControl);\r\nvar\r\n Pane: TJvDockVSPane;\r\nbegin\r\n Pane := FindPane(Control);\r\n if Assigned(Pane) then\r\n PopupDockForm(Pane);\r\nend;\r\n\r\nprocedure TJvDockVSChannel.PopupPaneChanged;\r\nbegin\r\n { Notification }\r\nend;\r\n\r\nprocedure TJvDockVSChannel.RemoveAllBlock;\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := BlockCount - 1 downto 0 do\r\n DeleteBlock(I);\r\nend;\r\n\r\nprocedure TJvDockVSChannel.RemoveDockControl(Control: TWinControl);\r\nvar\r\n BlockIndex, PaneIndex: Integer;\r\nbegin\r\n VSPopupPanel.Visible := False;\r\n if FindDockControl(Control, BlockIndex, PaneIndex) then\r\n begin\r\n Block[BlockIndex].DeletePane(PaneIndex);\r\n if (Block[BlockIndex].VSPaneCount <= 0) or (Block[BlockIndex].FBlockType = btTabBlock) then\r\n DeleteBlock(BlockIndex);\r\n end;\r\n ResetPosition;\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvDockVSChannel.ResetActivePaneWidth;\r\nvar\r\n DockClient: TJvDockClient;\r\nbegin\r\n if PopupPane = nil then\r\n Exit;\r\n\r\n DockClient := FindDockClient(PopupPane.DockForm);\r\n if Align in [alLeft, alRight] then\r\n PopupPane.FWidth := VSPopupPanel.Width\r\n else\r\n if Align in [alTop, alBottom] then\r\n PopupPane.FWidth := VSPopupPanel.Height + VSPopupPanel.JvDockManager.GrabberSize;\r\n if DockClient <> nil then\r\n DockClient.VSPaneWidth := PopupPane.FWidth;\r\nend;\r\n\r\nprocedure TJvDockVSChannel.ResetBlock;\r\nvar\r\n I: Integer;\r\nbegin\r\n if BlockCount > 0 then\r\n begin\r\n Block[0].FBlockStartPos := FBlockStartOffset;\r\n for I := 1 to BlockCount - 1 do\r\n Block[I].FBlockStartPos := Block[I - 1].FBlockStartPos + Block[I - 1].GetTotalWidth + FBlockInterval;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockVSChannel.ResetFontAngle;\r\nvar\r\n LogFont: TLogFont;\r\nbegin\r\n if Align in [alLeft, alRight] then\r\n if GetObject(Canvas.Font.Handle, SizeOf(LogFont), @LogFont) <> 0 then\r\n begin\r\n LogFont.lfEscapement := 2700;\r\n LogFont.lfOrientation := 2700;\r\n Canvas.Font.Handle := CreateFontIndirect(LogFont);\r\n end;\r\nend;\r\n\r\nprocedure TJvDockVSChannel.ResetPopupPanelHeight;\r\nbegin\r\n if Align in [alLeft, alRight] then\r\n begin\r\n VSPopupPanel.Top := Top;\r\n VSPopupPanel.Height := Height;\r\n VSPopupPanelSplitter.Top := Top;\r\n VSPopupPanelSplitter.Height := Height;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockVSChannel.ResetPosition;\r\nvar\r\n I, J: Integer;\r\n PaneCount: Integer;\r\nbegin\r\n PaneCount := 0;\r\n for I := 0 to BlockCount - 1 do\r\n for J := 0 to Block[I].VSPaneCount - 1 do\r\n if Block[I].VSPane[J].FVisible then\r\n Inc(PaneCount);\r\n\r\n Visible := PaneCount > 0;\r\n case Align of\r\n alLeft:\r\n begin\r\n Width := FChannelWidth;\r\n Left := GetClientAlignControlArea(Parent, Align, Self);\r\n end;\r\n alRight:\r\n begin\r\n Width := FChannelWidth;\r\n Left := Parent.ClientWidth - GetClientAlignControlArea(Parent, Align, Self) - FChannelWidth + 1;\r\n end;\r\n alTop:\r\n begin\r\n Height := FChannelWidth;\r\n Top := GetClientAlignControlArea(Parent, Align, Self);\r\n end;\r\n alBottom:\r\n begin\r\n Height := FChannelWidth;\r\n Top := Parent.ClientHeight - GetClientAlignControlArea(Parent, Align, Self) - FChannelWidth + 1;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockVSChannel.SetActivePaneSize(const Value: Integer);\r\nbegin\r\n if FActivePaneSize <> Value then\r\n begin\r\n FActivePaneSize := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockVSChannel.SetBlockStartOffset(const Value: Integer);\r\nbegin\r\n FBlockStartOffset := Value;\r\nend;\r\n\r\nprocedure TJvDockVSChannel.SetPopupPane(APane: TJvDockVSPane);\r\nbegin\r\n if APane <> FPopupPane then\r\n begin\r\n FPopupPane := APane;\r\n { If a pane has a visible popup dock form, then it becomes the active pane of\r\n the block }\r\n if Assigned(FPopupPane) then\r\n FPopupPane.FBlock.ActivePane := FPopupPane;\r\n PopupPaneChanged;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockVSChannel.SetTabColor(const Value: TColor);\r\nbegin\r\n if FTabColor <> Value then\r\n begin\r\n FTabColor := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockVSChannel.SetVSPopupPanelSplitterPosition;\r\nbegin\r\n case Align of\r\n alLeft:\r\n VSPopupPanelSplitter.SetBounds(VSPopupPanel.Left + VSPopupPanel.Width,\r\n VSPopupPanel.Top,\r\n VSPopupPanelSplitter.SplitWidth,\r\n VSPopupPanel.Height);\r\n alRight:\r\n VSPopupPanelSplitter.SetBounds(VSPopupPanel.Left - VSPopupPanelSplitter.SplitWidth,\r\n VSPopupPanel.Top,\r\n VSPopupPanelSplitter.SplitWidth,\r\n VSPopupPanel.Height);\r\n alTop:\r\n VSPopupPanelSplitter.SetBounds(VSPopupPanel.Left,\r\n VSPopupPanel.Top + VSPopupPanel.Height,\r\n VSPopupPanel.Width,\r\n VSPopupPanelSplitter.SplitWidth);\r\n alBottom:\r\n VSPopupPanelSplitter.SetBounds(VSPopupPanel.Left,\r\n VSPopupPanel.Top - VSPopupPanelSplitter.SplitWidth,\r\n VSPopupPanel.Width,\r\n VSPopupPanelSplitter.SplitWidth);\r\n end;\r\n VSPopupPanelSplitter.Visible := True;\r\n VSPopupPanelSplitter.BringToFront;\r\nend;\r\n\r\nprocedure TJvDockVSChannel.ShowPopupPanel(Pane: TJvDockVSPane);\r\n\r\n procedure SetSingleDockFormVisible(HostDockSite: TWinControl; AForm: TCustomForm);\r\n var\r\n I: Integer;\r\n begin\r\n for I := 0 to HostDockSite.DockClientCount - 1 do\r\n HostDockSite.DockClients[I].Visible := AForm = HostDockSite.DockClients[I];\r\n end;\r\nvar\r\n LShowControl: TWinControl;\r\nbegin\r\n if Pane = nil then\r\n Exit;\r\n\r\n JvDockLockWindow(nil);\r\n Parent.DisableAlign;\r\n try\r\n { Auto-hide all popups of this pane }\r\n HidePopupPanel(PopupPane);\r\n Pane.FDockForm.Visible := True;\r\n if (Pane.FDockForm <> nil) and (Pane.FDockForm.HostDockSite.Parent is TJvDockTabHostForm) then\r\n begin\r\n FVSPopupPanel.JvDockManager.ShowSingleControl(Pane.FDockForm.HostDockSite.Parent);\r\n SetSingleDockFormVisible(Pane.FDockForm.HostDockSite, Pane.FDockForm);\r\n TJvDockTabHostForm(Pane.FDockForm.HostDockSite.Parent).Caption := Pane.FDockForm.Caption;\r\n end\r\n else\r\n FVSPopupPanel.JvDockManager.ShowSingleControl(Pane.FDockForm);\r\n\r\n SetPopupPane(Pane);\r\n FVSPopupPanel.JvDockManager.ResetBounds(True);\r\n\r\n VSPopupPanel.BringToFront;\r\n VSPopupPanelSplitter.BringToFront;\r\n SetControlBringToFront(Parent, Align);\r\n BringToFront;\r\n case Align of\r\n alLeft:\r\n begin\r\n VSPopupPanel.SetBounds(Left + Width,\r\n Top,\r\n Pane.FWidth,\r\n Height);\r\n VSPopupPanelSplitter.SetBounds(VSPopupPanel.Left + VSPopupPanel.Width,\r\n Top,\r\n VSPopupPanelSplitter.SplitWidth,\r\n Height);\r\n end;\r\n alRight:\r\n begin\r\n VSPopupPanel.SetBounds(Left - Pane.FWidth,\r\n Top,\r\n Pane.FWidth,\r\n Height);\r\n VSPopupPanelSplitter.SetBounds(VSPopupPanel.Left - VSPopupPanelSplitter.SplitWidth,\r\n Top,\r\n VSPopupPanelSplitter.SplitWidth,\r\n Height);\r\n end;\r\n alTop:\r\n begin\r\n VSPopupPanel.SetBounds(Left,\r\n Top + Height,\r\n Width,\r\n Pane.FWidth);\r\n VSPopupPanelSplitter.SetBounds(Left,\r\n VSPopupPanel.Top + VSPopupPanel.Height,\r\n Width,\r\n VSPopupPanelSplitter.SplitWidth);\r\n end;\r\n alBottom:\r\n begin\r\n VSPopupPanel.SetBounds(Left,\r\n Top - Pane.FWidth,\r\n Width,\r\n Pane.FWidth);\r\n VSPopupPanelSplitter.SetBounds(Left,\r\n VSPopupPanel.Top - VSPopupPanelSplitter.SplitWidth,\r\n Width,\r\n VSPopupPanelSplitter.SplitWidth);\r\n end;\r\n end;\r\n VSPopupPanel.Visible := True;\r\n VSPopupPanelSplitter.Visible := True;\r\n\r\n { If the form is on a tab, then show the parent of the pagecontrol\r\n (a TJvDockTabHostForm), otherwise show the form.\r\n }\r\n LShowControl := nil;\r\n case Pane.FBlock.BlockType of\r\n btTabBlock:\r\n if Pane.FDockForm.Parent is TJvDockTabSheet then\r\n begin\r\n LShowControl := TJvDockTabSheet(Pane.FDockForm.Parent).PageControl;\r\n if Assigned(LShowControl) then\r\n LShowControl := LShowControl.Parent;\r\n end;\r\n btConjoinBlock: LShowControl := Pane.FDockForm;\r\n end;\r\n if Assigned(LShowControl) then\r\n FVSPopupPanel.DoShowControl(LShowControl);\r\n\r\n AutoFocusActiveDockForm;\r\n finally\r\n Parent.EnableAlign;\r\n JvDockUnLockWindow;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockVSChannel.ShowPopupPanel(Control: TWinControl);\r\nvar\r\n Pane: TJvDockVSPane;\r\nbegin\r\n Pane := FindPane(Control);\r\n if Assigned(Pane) then\r\n ShowPopupPanel(Pane);\r\nend;\r\n\r\nprocedure TJvDockVSChannel.SyncWithStyle;\r\nbegin\r\n if DockStyle is TJvDockVSNetStyle then\r\n begin\r\n ActivePaneSize := TJvDockVSNetStyle(DockStyle).ChannelOption.ActivePaneSize;\r\n TabColor := TJvDockVSNetStyle(DockStyle).ChannelOption.TabColor;\r\n end;\r\nend;\r\n\r\n//=== { TJvDockVSNETChannelOption } ==========================================\r\n\r\nconstructor TJvDockVSNETChannelOption.Create(ADockStyle: TJvDockObservableStyle);\r\nbegin\r\n inherited Create(ADockStyle);\r\n FActivePaneSize := 100;\r\n FShowImage := True;\r\n FMouseleaveHide := True;\r\n FHideHoldTime := 1000;\r\n FTabColor := clBtnFace;\r\nend;\r\n\r\nprocedure TJvDockVSNETChannelOption.Assign(Source: TPersistent);\r\nvar\r\n Src: TJvDockVSNETChannelOption;\r\nbegin\r\n if Source is TJvDockVSNETChannelOption then\r\n begin\r\n BeginUpdate;\r\n try\r\n Src := TJvDockVSNETChannelOption(Source);\r\n\r\n ActivePaneSize := Src.ActivePaneSize;\r\n ShowImage := Src.ShowImage;\r\n MouseleaveHide := Src.MouseleaveHide;\r\n HideHoldTime := Src.HideHoldTime;\r\n TabColor := Src.TabColor;\r\n\r\n inherited Assign(Source);\r\n finally\r\n EndUpdate;\r\n end;\r\n end\r\n else\r\n inherited Assign(Source);\r\nend;\r\n\r\nprocedure TJvDockVSNETChannelOption.SetActivePaneSize(Value: Integer);\r\nbegin\r\n Value := Max(24, Value);\r\n if FActivePaneSize <> Value then\r\n begin\r\n FActivePaneSize := Value;\r\n Changed;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockVSNETChannelOption.SetHideHoldTime(const Value: Integer);\r\nbegin\r\n if FHideHoldTime <> Value then\r\n if Value < 100 then\r\n begin\r\n { (rom) disabled\r\n if csDesigning in DockStyle.ComponentState then\r\n ShowMessage('HideHoldTime cannot be less than 100');\r\n }\r\n FHideHoldTime := 100;\r\n end\r\n else\r\n FHideHoldTime := Value;\r\nend;\r\n\r\nprocedure TJvDockVSNETChannelOption.SetMouseleaveHide(const Value: Boolean);\r\nbegin\r\n if FMouseleaveHide <> Value then\r\n begin\r\n FMouseleaveHide := Value;\r\n { Notify TJvDockVSNetStyle for enabling/disabling timer? }\r\n end;\r\nend;\r\n\r\nprocedure TJvDockVSNETChannelOption.SetShowImage(const Value: Boolean);\r\nbegin\r\n FShowImage := Value;\r\nend;\r\n\r\nprocedure TJvDockVSNETChannelOption.SetTabColor(const Value: TColor);\r\nbegin\r\n if FTabColor <> Value then\r\n begin\r\n FTabColor := Value;\r\n Changed;\r\n end;\r\nend;\r\n\r\n//=== { TJvDockVSNETConjoinServerOption } ====================================\r\n\r\nconstructor TJvDockVSNETConjoinServerOption.Create(ADockStyle: TJvDockObservableStyle);\r\nbegin\r\n inherited Create(ADockStyle);\r\n SystemInfo := True;\r\nend;\r\n\r\nprocedure TJvDockVSNETConjoinServerOption.UpdateDefaultSystemCaptionInfo;\r\nbegin\r\n inherited UpdateDefaultSystemCaptionInfo;\r\n\r\n ActiveFont.Color := clWhite;\r\n ActiveFont.Style := [];\r\n\r\n InactiveFont.Color := clBlack;\r\n InactiveFont.Style := [];\r\n\r\n ActiveTitleEndColor := ActiveTitleStartColor;\r\n InactiveTitleStartColor := clBtnFace;\r\n InactiveTitleEndColor := clBtnFace;\r\nend;\r\n\r\n//=== { TJvDockVSNETPanel } ==================================================\r\n\r\nconstructor TJvDockVSNETPanel.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FVSChannelClass := TJvDockVSChannel;\r\nend;\r\n\r\nprocedure TJvDockVSNETPanel.AddDockServer(ADockServer: TJvDockServer);\r\nbegin\r\n { Dirty; resolve with new class? }\r\n if not (Self is TJvDockVSPopupPanel) and Assigned(ADockServer) then\r\n begin\r\n CreateVSChannel;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockVSNETPanel.CreateVSChannel;\r\nbegin\r\n if (FVSChannelClass <> nil) and\r\n { (rb) ??? }\r\n (FVSChannelClass <> TJvDockVSChannelClass(ClassType)) then\r\n begin\r\n FVSChannel := FVSChannelClass.Create(Self);\r\n FVSChannel.Parent := Parent;\r\n FVSChannel.Align := Align;\r\n FVSChannel.ResetFontAngle;\r\n FVSChannel.ResetPosition;\r\n FVSChannel.Visible := False;\r\n FVSChannel.Name := Name + '_VSChannel';\r\n FVSChannel.CreateVSPopupPanel;\r\n FVSChannel.FreeNotification(Self);\r\n end;\r\nend;\r\n\r\nprocedure TJvDockVSNETPanel.CustomDockDrop(Source: TJvDockDragDockObject;\r\n X, Y: Integer);\r\nbegin\r\n inherited CustomDockDrop(Source, X, Y);\r\n VSChannel.ActiveDockForm.Perform(CM_EXIT, 0, 0);\r\nend;\r\n\r\nprocedure TJvDockVSNETPanel.DestroyVSChannel;\r\nbegin\r\n FVSChannel.Free;\r\n FVSChannel := nil;\r\nend;\r\n\r\nprocedure TJvDockVSNETPanel.DoAutoHideControl(Control: TWinControl);\r\nbegin\r\n if Align = alNone then\r\n DoShowControl(Control)\r\n else\r\n DoHideControl(Control);\r\nend;\r\n\r\nprocedure TJvDockVSNETPanel.DoHideControl(Control: TWinControl);\r\nbegin\r\n JvDockLockWindow(nil);\r\n DisableAlign;\r\n try\r\n VSChannel.AddDockControl(Control);\r\n ShowDockPanel(VisibleDockClientCount > 1, Control, sdfDockPanel);\r\n { using a null-rect as parameter for Dock causes align problems }\r\n Control.Dock(VSChannel.VSPopupPanel, Control.BoundsRect);\r\n// Control.Dock(VSChannel.VSPopupPanel, Rect(0, 0, 0, 0));\r\n { (rb) For every call to InsertControl there must be a call to RemoveControl.\r\n That is not guaranteed now, so JvDockManager may be filled with dangling\r\n references }\r\n// VSChannel.VSPopupPanel.JvDockManager.InsertControl(Control, alNone, nil);\r\n VSChannel.InternalInsertControl(Control);\r\n VSChannel.VSPopupPanel.JvDockManager.ShowSingleControl(Control);\r\n JvDockManager.HideControl(Control);\r\n ResetChannelBlockStartOffset(VSChannel);\r\n finally\r\n EnableAlign;\r\n JvDockUnLockWindow;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockVSNETPanel.DoShowControl(Control: TWinControl);\r\nvar\r\n Panel: TJvDockVSNETPanel;\r\n\r\n procedure ResetDockFormVisible;\r\n var\r\n I: Integer;\r\n begin\r\n if Control is TJvDockTabHostForm then\r\n with TJvDockTabHostForm(Control) do\r\n for I := 0 to PageControl.Count - 1 do\r\n begin\r\n PageControl.Pages[I].Visible := TJvDockVSNETTabSheet(PageControl.Pages[I]).OldVisible;\r\n PageControl.Pages[I].Controls[0].Visible := PageControl.Pages[I].Visible;\r\n end;\r\n end;\r\n\r\nbegin\r\n { Dirty; solve with virtual method? }\r\n if Self is TJvDockVSPopupPanel then\r\n begin\r\n Panel := TJvDockVSPopupPanel(Self).FVSNETDockPanel;\r\n\r\n JvDockLockWindow(nil);\r\n Panel.DisableAlign;\r\n try\r\n { using a null-rect as parameter for Dock causes align problems }\r\n Control.Dock(Panel, Control.BoundsRect);\r\n// Control.Dock(Panel, Rect(0, 0, 0, 0));\r\n Panel.JvDockManager.ShowControl(Control);\r\n// JvDockManager.RemoveControl(Control);\r\n Panel.VSChannel.InternalRemoveControl(Control);\r\n Panel.VSChannel.RemoveDockControl(Control);\r\n Panel.ShowDockPanel(Panel.VisibleDockClientCount > 0, Control, sdfDockPanel);\r\n Panel.VSChannel.AutoFocusActiveDockForm;\r\n Panel.VSChannel.HidePopupPanel(Panel.VSChannel.PopupPane);\r\n ResetDockFormVisible;\r\n ResetChannelBlockStartOffset(Panel.VSChannel);\r\n finally\r\n Panel.EnableAlign;\r\n JvDockUnLockWindow;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockVSNETPanel.Notification(AComponent: TComponent;\r\n Operation: TOperation);\r\nbegin\r\n inherited Notification(AComponent, Operation);\r\n if (AComponent = VSChannel) and (Operation = opRemove) then\r\n FVSChannel := nil;\r\nend;\r\n\r\nprocedure TJvDockVSNETPanel.RemoveDockServer(ADockServer: TJvDockServer);\r\nbegin\r\n DestroyVSChannel;\r\nend;\r\n\r\nprocedure TJvDockVSNETPanel.Resize;\r\nbegin\r\n inherited Resize;\r\n if (Align in [alTop, alBottom]) and Assigned(DockServer) then\r\n begin\r\n if Assigned(DockServer.DockPanelWithAlign[alLeft]) then\r\n TJvDockVSNETPanel(DockServer.DockPanelWithAlign[alLeft]).VSChannel.ResetPopupPanelHeight;\r\n if Assigned(DockServer.DockPanelWithAlign[alRight]) then\r\n TJvDockVSNETPanel(DockServer.DockPanelWithAlign[alRight]).VSChannel.ResetPopupPanelHeight;\r\n end;\r\nend;\r\n\r\n//=== { TJvDockVSNetStyle } ==================================================\r\n\r\nconstructor TJvDockVSNetStyle.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n DockPanelClass := TJvDockVSNETPanel;\r\n DockSplitterClass := TJvDockVSNETSplitter;\r\n ConjoinPanelClass := TJvDockVSNETConjoinPanel;\r\n TabDockClass := TJvDockVSNETTabPageControl;\r\n DockPanelTreeClass := TJvDockVSNETTree;\r\n DockPanelZoneClass := TJvDockVSNETZone;\r\n ConjoinPanelTreeClass := TJvDockVSNETTree;\r\n ConjoinPanelZoneClass := TJvDockVSNETZone;\r\n ConjoinServerOptionClass := TJvDockVSNETConjoinServerOption;\r\n TabServerOptionClass := TJvDockVSNETTabServerOption;\r\n FChannelOptionClass := TJvDockVSNETChannelOption;\r\n\r\n FDockServers := TList.Create;\r\nend;\r\n\r\ndestructor TJvDockVSNetStyle.Destroy;\r\nbegin\r\n { Note that RemoveDockBaseControl can be called in the inherited Destroy call.\r\n So we set FTimer to nil, and destroy FDockServers after the inherited call.\r\n }\r\n DestroyTimer;\r\n inherited Destroy;\r\n FDockServers.Free;\r\nend;\r\n\r\nprocedure TJvDockVSNetStyle.AddDockBaseControl(ADockBaseControl: TJvDockBaseControl);\r\nbegin\r\n inherited AddDockBaseControl(ADockBaseControl);\r\n\r\n if ADockBaseControl is TJvDockServer then\r\n FDockServers.Add(ADockBaseControl);\r\nend;\r\n\r\nprocedure TJvDockVSNetStyle.BeginPopup(AChannel: TJvDockVSChannel);\r\nbegin\r\n CreateTimer;\r\nend;\r\n\r\nprocedure TJvDockVSNetStyle.CreateServerOption;\r\nbegin\r\n inherited CreateServerOption;\r\n if (FChannelOption = nil) and (FChannelOptionClass <> nil) then\r\n FChannelOption := FChannelOptionClass.Create(Self);\r\nend;\r\n\r\nprocedure TJvDockVSNetStyle.CreateTimer;\r\nbegin\r\n if not ChannelOption.MouseleaveHide then\r\n Exit;\r\n if csDesigning in ComponentState then\r\n Exit;\r\n\r\n if not Assigned(FTimer) then\r\n begin\r\n FTimer := TTimer.Create(Self);\r\n FTimer.Interval := 100; // !! high interval\r\n FTimer.OnTimer := Self.Timer;\r\n FTimer.Enabled := True;\r\n\r\n FCurrentTimer := ChannelOption.HideHoldTime;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockVSNetStyle.DestroyTimer;\r\nbegin\r\n FTimer.Free;\r\n FTimer := nil;\r\nend;\r\n\r\nfunction TJvDockVSNetStyle.DockClientWindowProc(DockClient: TJvDockClient;\r\n var Msg: TMessage): Boolean;\r\nvar\r\n Channel: TJvDockVSChannel;\r\nbegin\r\n Result := inherited DockClientWindowProc(DockClient, Msg);\r\n case Msg.Msg of\r\n CM_ENTER, CM_EXIT:\r\n begin\r\n Channel := RetrieveChannel(DockClient.ParentForm.HostDockSite);\r\n if Msg.Msg = CM_EXIT then\r\n begin\r\n if Assigned(Channel) and (Channel.ActiveDockForm = DockClient.ParentForm) then\r\n Channel.HidePopupPanelWithAnimate;\r\n end\r\n else\r\n if Msg.Msg = CM_ENTER then\r\n HideAllPopupPanel(Channel);\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJvDockVSNetStyle.DockServerWindowProc(DockServer: TJvDockServer;\r\n var Msg: TMessage): Boolean;\r\nbegin\r\n Result := inherited DockServerWindowProc(DockServer, Msg);\r\n if Msg.Msg = WM_SIZE then\r\n with TChannelEnumerator.Create(DockServer) do\r\n try\r\n while MoveNext do\r\n Current.HidePopupPanel(Current.PopupPane);\r\n finally\r\n Free;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockVSNetStyle.DoHideDockForm(DockWindow: TWinControl);\r\nvar\r\n TmpDockWindow: TWinControl;\r\n\r\n procedure HideDockChild(DockWindow: TWinControl);\r\n var\r\n I: Integer;\r\n DockClient: TJvDockClient;\r\n begin\r\n if DockWindow = nil then\r\n Exit;\r\n if (DockWindow is TJvDockableForm) and (DockWindow.Visible) then\r\n with TJvDockableForm(DockWindow).DockableControl do\r\n for I := 0 to DockClientCount - 1 do\r\n HideDockChild(TWinControl(DockClients[I]));\r\n DockClient := FindDockClient(DockWindow);\r\n if (DockWindow is TForm) and (TForm(DockWindow).FormStyle <> fsMDIChild) and\r\n (DockClient.DockStyle <> nil) then\r\n DockClient.DockStyle.HideDockForm(DockClient);\r\n end;\r\n\r\n procedure HideDockParent(DockWindow: TWinControl);\r\n var\r\n Host: TWinControl;\r\n DockClient: TJvDockClient;\r\n begin\r\n if (DockWindow <> nil) and (DockWindow.HostDockSite <> nil) then\r\n begin\r\n // work-around\r\n if Assigned(RetrieveChannel(DockWindow.HostDockSite)) then\r\n Exit;\r\n\r\n Host := DockWindow.HostDockSite;\r\n if Host.VisibleDockClientCount = 0 then\r\n if Host is TJvDockPanel then\r\n TJvDockPanel(Host).ShowDockPanel(False, nil)\r\n else\r\n begin\r\n if Host.Parent <> nil then\r\n begin\r\n DockClient := FindDockClient(Host.Parent);\r\n if (DockClient <> nil) and (DockClient.DockStyle <> nil) then\r\n DockClient.DockStyle.HideDockForm(DockClient);\r\n HideDockParent(Host.Parent);\r\n end;\r\n end;\r\n end;\r\n end;\r\n\r\n procedure HidePopupPanel(Client: TWinControl);\r\n var\r\n Channel: TJvDockVSChannel;\r\n begin\r\n Channel := RetrieveChannel(Client.HostDockSite);\r\n if Assigned(Channel) then\r\n Channel.HidePopupPanel(Client);\r\n end;\r\n\r\nbegin\r\n TmpDockWindow := DockWindow;\r\n HideDockChild(DockWindow);\r\n HideDockParent(DockWindow);\r\n if (DockWindow.HostDockSite is TJvDockCustomControl) then\r\n TJvDockCustomControl(DockWindow.HostDockSite).UpdateCaption(DockWindow);\r\n HidePopupPanel(TmpDockWindow);\r\nend;\r\n\r\nprocedure TJvDockVSNetStyle.DoShowDockForm(DockWindow: TWinControl);\r\n\r\n procedure PopupAutoHiddenForm(Client: TWinControl);\r\n var\r\n Channel: TJvDockVSChannel;\r\n begin\r\n Channel := RetrieveChannel(Client.HostDockSite);\r\n if Assigned(Channel) then\r\n Channel.PopupDockForm(Client);\r\n end;\r\n\r\nbegin\r\n inherited DoShowDockForm(DockWindow);\r\n PopupAutoHiddenForm(DockWindow);\r\nend;\r\n\r\nprocedure TJvDockVSNetStyle.DoUnAutoHideDockForm(DockWindow: TWinControl);\r\n\r\n procedure ShowAutoHiddenForm(Client: TWinControl);\r\n var\r\n Channel: TJvDockVSChannel;\r\n begin\r\n Channel := RetrieveChannel(Client.HostDockSite);\r\n if Assigned(Channel) then\r\n Channel.ShowPopupPanel(Client);\r\n end;\r\n\r\nbegin\r\n inherited DoShowDockForm(DockWindow);\r\n ShowAutoHiddenForm(DockWindow);\r\nend;\r\n\r\nprocedure TJvDockVSNetStyle.EndPopup(AChannel: TJvDockVSChannel);\r\nbegin\r\n DestroyTimer;\r\nend;\r\n\r\nprocedure TJvDockVSNetStyle.FreeServerOption;\r\nbegin\r\n inherited FreeServerOption;\r\n FChannelOption.Free;\r\n FChannelOption := nil;\r\nend;\r\n\r\nclass function TJvDockVSNetStyle.GetAnimationInterval: Integer;\r\nbegin\r\n Result := GlobalPopupPanelAnimateInterval;\r\nend;\r\n\r\nclass function TJvDockVSNetStyle.GetAnimationMoveWidth: Integer;\r\nbegin\r\n Result := GlobalPopupPanelAnimateMoveWidth;\r\nend;\r\n\r\nclass function TJvDockVSNetStyle.GetAnimationStartInterval: Integer;\r\nbegin\r\n Result := GlobalPopupPanelStartAnimateInterval;\r\nend;\r\n\r\nfunction TJvDockVSNetStyle.GetChannelOption: TJvDockVSNETChannelOption;\r\nbegin\r\n Result := FChannelOption;\r\nend;\r\n\r\nfunction TJvDockVSNetStyle.GetDockFormVisible(ADockClient: TJvDockClient): Boolean;\r\nvar\r\n Channel: TJvDockVSChannel;\r\n Pane: TJvDockVSPane;\r\nbegin\r\n Result := True;\r\n if Assigned(ADockClient) then\r\n begin\r\n Channel := RetrieveChannel(ADockClient.ParentForm.HostDockSite);\r\n if Assigned(Channel) then\r\n begin\r\n Pane := Channel.FindPane(ADockClient.ParentForm);\r\n if Assigned(Pane) then\r\n Result := Pane.FVisible;\r\n end\r\n else\r\n Result := inherited GetDockFormVisible(ADockClient);\r\n end;\r\nend;\r\n\r\nprocedure TJvDockVSNetStyle.HideDockForm(ADockClient: TJvDockClient);\r\nbegin\r\n inherited HideDockForm(ADockClient);\r\n SetDockFormVisible(ADockClient, False);\r\nend;\r\n\r\nprocedure TJvDockVSNetStyle.RemoveDockBaseControl(\r\n ADockBaseControl: TJvDockBaseControl);\r\nbegin\r\n inherited RemoveDockBaseControl(ADockBaseControl);\r\n\r\n if ADockBaseControl is TJvDockServer then\r\n begin\r\n FDockServers.Remove(ADockBaseControl);\r\n if FDockServers.Count = 0 then\r\n DestroyTimer;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockVSNetStyle.RestoreClient(DockClient: TJvDockClient);\r\nbegin\r\n { Skip if the form is autohidden on a channel }\r\n if Assigned(RetrieveChannel(DockClient.ParentForm.HostDockSite)) then\r\n Exit;\r\n inherited RestoreClient(DockClient);\r\nend;\r\n\r\nclass procedure TJvDockVSNetStyle.SetAnimationInterval(const Value: Integer);\r\nbegin\r\n if GlobalPopupPanelAnimateInterval <> Value then\r\n begin\r\n GlobalPopupPanelAnimateInterval := Value;\r\n FreeAndNil(GlobalPopupPanelAnimate);\r\n end;\r\nend;\r\n\r\nclass procedure TJvDockVSNetStyle.SetAnimationMoveWidth(const Value: Integer);\r\nbegin\r\n if GlobalPopupPanelAnimateMoveWidth <> Value then\r\n begin\r\n GlobalPopupPanelAnimateMoveWidth := Value;\r\n FreeAndNil(GlobalPopupPanelAnimate);\r\n end;\r\nend;\r\n\r\nprocedure TJvDockVSNetStyle.SetChannelOption(const Value: TJvDockVSNETChannelOption);\r\nbegin\r\n { !! May be nil }\r\n FChannelOption.Assign(Value);\r\nend;\r\n\r\nprocedure TJvDockVSNetStyle.SetDockFormVisible(ADockClient: TJvDockClient;\r\n AVisible: Boolean);\r\nvar\r\n Channel: TJvDockVSChannel;\r\n Pane: TJvDockVSPane;\r\n\r\n procedure ResetActivePane;\r\n var\r\n I: Integer;\r\n begin\r\n if AVisible then\r\n Pane.FBlock.ActivePane := Pane\r\n else\r\n begin\r\n for I := Pane.FIndex downto 0 do\r\n if Pane.FBlock.VSPane[I].FVisible then\r\n begin\r\n Pane.FBlock.ActivePane := Pane.FBlock.VSPane[I];\r\n Exit;\r\n end;\r\n for I := Pane.FIndex + 1 to Pane.FBlock.VSPaneCount - 1 do\r\n if Pane.FBlock.VSPane[I].FVisible then\r\n begin\r\n Pane.FBlock.ActivePane := Pane.FBlock.VSPane[I];\r\n Exit;\r\n end;\r\n end;\r\n end;\r\nbegin\r\n if not Assigned(ADockClient) then\r\n Exit;\r\n\r\n Channel := RetrieveChannel(ADockClient.ParentForm.HostDockSite);\r\n if not Assigned(Channel) then\r\n begin\r\n // Mantis 3752\r\n if ADockClient.ParentForm.Parent is TJvDockVSNETTabSheet then\r\n (ADockClient.ParentForm.Parent as TJvDockVSNETTabSheet).OldVisible := AVisible;\r\n Exit;\r\n end;\r\n\r\n Pane := Channel.FindPane(ADockClient.ParentForm);\r\n if Assigned(Pane) and (Pane.FDockForm = ADockClient.ParentForm) then\r\n begin\r\n Pane.FVisible := AVisible;\r\n ResetActivePane;\r\n if ADockClient.ParentForm.Parent is TJvDockVSNETTabSheet then\r\n TJvDockVSNETTabSheet(ADockClient.ParentForm.Parent).OldVisible := AVisible;\r\n\r\n Channel.ResetPosition;\r\n Channel.Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockVSNetStyle.ShowDockForm(ADockClient: TJvDockClient);\r\nbegin\r\n inherited ShowDockForm(ADockClient);\r\n SetDockFormVisible(ADockClient, True);\r\nend;\r\n\r\nprocedure TJvDockVSNetStyle.Timer(Sender: TObject);\r\n\r\n function IsPopupWindow(Handle: HWND): Boolean;\r\n var\r\n OwningProcess: DWORD;\r\n LStyle: Cardinal;\r\n begin\r\n Result := False;\r\n if (Handle <> 0) and (GetWindowThreadProcessID(Handle, @OwningProcess) <> 0) and\r\n (OwningProcess = GetCurrentProcessId) then\r\n begin\r\n LStyle := GetWindowLong(Handle, GWL_STYLE);\r\n Result := WS_POPUP and LSTYLE <> 0;\r\n end;\r\n end;\r\n\r\n function PointIsOnPopup(P: TPoint; GlobalCheck: Boolean; Recurse: Boolean): Boolean;\r\n const\r\n GW_ENABLEDPOPUP = 6;\r\n var\r\n Control: TWinControl;\r\n Handle: HWND;\r\n Rect: TRect;\r\n ActivePopupWindow: Boolean;\r\n begin\r\n Control := FindVCLWindow(P);\r\n Result := ControlIsOnPopup(Control);\r\n if not Result then\r\n begin\r\n // Check whether a popup window is currently displayed (hint, popup menu)\r\n Handle := WindowFromPoint(P);\r\n ActivePopupWindow := IsPopupWindow(Handle);\r\n if not ActivePopupWindow and GlobalCheck then\r\n begin\r\n Handle := GetWindow(Application.Handle, GW_ENABLEDPOPUP);\r\n ActivePopupWindow := IsPopupWindow(Handle);\r\n if not ActivePopupWindow then\r\n begin\r\n Handle := GetTopWindow(GetDesktopWindow);\r\n ActivePopupWindow := IsPopupWindow(Handle);\r\n end;\r\n end;\r\n\r\n if Recurse and ActivePopupWindow then\r\n begin\r\n GetWindowRect(Handle, Rect);\r\n // Search for a control one pixel to the left;\r\n Dec(Rect.Left);\r\n Result := PointIsOnPopup(Rect.TopLeft, False, False);\r\n if not Result then\r\n begin\r\n // Search for a control one pixel to the Right;\r\n Inc(Rect.Right);\r\n Result := PointIsOnPopup(Point(Rect.Right, Rect.Top), False, False);\r\n end;\r\n end;\r\n end;\r\n end;\r\n\r\nvar\r\n P: TPoint;\r\n I: Integer;\r\n ADockServer: TJvDockServer;\r\nbegin\r\n if (csDesigning in ComponentState) or not ChannelOption.MouseleaveHide or\r\n ((GetAsyncKeyState(VK_LBUTTON) and $8000) <> 0) then\r\n Exit;\r\n\r\n GetCursorPos(P);\r\n if PointIsOnPopup(P, True, True) then\r\n begin\r\n { Reset timer }\r\n FCurrentTimer := ChannelOption.HideHoldTime;\r\n Exit;\r\n end;\r\n\r\n Dec(FCurrentTimer, 100);\r\n if FCurrentTimer > 0 then\r\n Exit;\r\n DestroyTimer;\r\n\r\n for I := 0 to FDockServers.Count - 1 do\r\n begin\r\n ADockServer := TJvDockServer(FDockServers[I]);\r\n with TChannelEnumerator.Create(ADockServer) do\r\n try\r\n while MoveNext do\r\n Current.HidePopupPanelWithAnimate;\r\n finally\r\n Free;\r\n end;\r\n end;\r\nend;\r\n\r\n//=== { TJvDockVSNETTabPageControl } =========================================\r\n\r\nconstructor TJvDockVSNETTabPageControl.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n TabSheetClass := TJvDockVSNETTabSheet;\r\n TabPanelClass := TJvDockVSNETTabPanel;\r\nend;\r\n\r\nprocedure TJvDockVSNETTabPageControl.ShowControl(AControl: TControl);\r\nbegin\r\n inherited ShowControl(AControl);\r\nend;\r\n\r\n//=== { TJvDockVSNETTabPanel } ===============================================\r\n\r\nconstructor TJvDockVSNETTabPanel.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n TabHeight := 25;\r\n CaptionTopOffset := 1;\r\nend;\r\n\r\n//=== { TJvDockVSNETTabServerOption } ========================================\r\n\r\nconstructor TJvDockVSNETTabServerOption.Create(ADockStyle: TJvDockObservableStyle);\r\nbegin\r\n inherited Create(ADockStyle);\r\n InactiveFont.Color := VSNETPageInactiveFontColor;\r\n InactiveSheetColor := VSNETPageInactiveSheetColor;\r\n ShowTabImages := True;\r\nend;\r\n\r\n//=== { TJvDockVSNETTabSheet } ===============================================\r\n\r\nconstructor TJvDockVSNETTabSheet.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FOldVisible := True;\r\nend;\r\n\r\nprocedure TJvDockVSNETTabSheet.SetOldVisible(const Value: Boolean);\r\nbegin\r\n FOldVisible := Value;\r\nend;\r\n\r\n//=== { TJvDockVSNETTree } ===================================================\r\n\r\nconstructor TJvDockVSNETTree.Create(DockSite: TWinControl;\r\n DockZoneClass: TJvDockZoneClass; ADockStyle: TJvDockObservableStyle);\r\nbegin\r\n inherited Create(DockSite, DockZoneClass, ADockStyle);\r\n\r\n ButtonHeight := 12;\r\n ButtonWidth := 16;\r\n LeftOffset := 2;\r\n RightOffset := 3;\r\n TopOffset := 4;\r\n BottomOffset := 3;\r\n ButtonSplitter := 2;\r\n CaptionLeftOffset := 5;\r\n CaptionRightOffset := 5;\r\nend;\r\n\r\nprocedure TJvDockVSNETTree.BeginDrag(Control: TControl; Immediate: Boolean;\r\n Threshold: Integer);\r\nbegin\r\n if not (DockSite is TJvDockVSPopupPanel) then\r\n inherited BeginDrag(Control, Immediate, Threshold);\r\nend;\r\n\r\nprocedure TJvDockVSNETTree.CustomLoadZone(Stream: TStream;\r\n var Zone: TJvDockZone);\r\nvar\r\n Pane: TJvDockVSPane;\r\n I: Integer;\r\n Sheet: TJvDockVSNETTabSheet;\r\n\r\n procedure SetPaneVisible(ChildControl: TControl; VSPaneVisible: Boolean);\r\n var\r\n ADockClient: TJvDockClient;\r\n begin\r\n if Pane <> nil then\r\n begin\r\n Pane.FVisible := VSPaneVisible;\r\n ADockClient := FindDockClient(Pane.FDockForm);\r\n if ADockClient <> nil then\r\n if Pane.FVisible then\r\n begin\r\n ADockClient.ParentVisible := False;\r\n ADockClient.ParentForm.Visible := True;\r\n ADockClient.MakeShowEvent;\r\n end\r\n else\r\n ADockClient.MakeHideEvent;\r\n end;\r\n end;\r\n\r\nbegin\r\n inherited CustomLoadZone(Stream, Zone);\r\n if Zone = nil then\r\n Exit;\r\n Stream.Read(TJvDockVSNETZone(Zone).FVSPaneVisible, SizeOf(TJvDockVSNETZone(Zone).VSPaneVisible));\r\n if DockSite is TJvDockVSPopupPanel then\r\n begin\r\n with TJvDockVSPopupPanel(DockSite).VSChannel, TJvDockVSNETZone(Zone) do\r\n begin\r\n if ChildControl is TJvDockTabHostForm then\r\n begin\r\n for I := 0 to TJvDockTabHostForm(ChildControl).PageControl.Count - 1 do\r\n begin\r\n Sheet := TJvDockVSNETTabSheet(TJvDockTabHostForm(ChildControl).PageControl.Pages[I]);\r\n Pane := FindPane(TWinControl(Sheet.Controls[0]));\r\n SetPaneVisible(ChildControl, Sheet.OldVisible);\r\n end;\r\n end\r\n else\r\n begin\r\n Pane := FindPane(ChildControl);\r\n SetPaneVisible(ChildControl, VSPaneVisible);\r\n end;\r\n ResetPosition;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockVSNETTree.CustomSaveZone(Stream: TStream;\r\n Zone: TJvDockZone);\r\nvar\r\n Pane: TJvDockVSPane;\r\nbegin\r\n inherited CustomSaveZone(Stream, Zone);\r\n if DockSite is TJvDockVSPopupPanel then\r\n with TJvDockVSPopupPanel(DockSite).VSChannel, TJvDockVSNETZone(Zone) do\r\n begin\r\n Pane := FindPane(ChildControl);\r\n if Pane <> nil then\r\n VSPaneVisible := Pane.FVisible;\r\n end;\r\n Stream.Write(TJvDockVSNETZone(Zone).VSPaneVisible, SizeOf(TJvDockVSNETZone(Zone).VSPaneVisible));\r\nend;\r\n\r\nprocedure TJvDockVSNETTree.DoHideZoneChild(AZone: TJvDockZone);\r\nvar\r\n Form: TCustomForm;\r\n ADockClient: TJvDockClient;\r\nbegin\r\n if (AZone <> nil) and (AZone.ChildControl <> nil) then\r\n begin\r\n if AZone.ChildControl is TJvDockTabHostForm then\r\n begin\r\n Form := TJvDockTabHostForm(AZone.ChildControl).PageControl.ActiveDockForm;\r\n if Form <> nil then\r\n begin\r\n ADockClient := FindDockClient(Form);\r\n if (ADockClient <> nil) and not ADockClient.EnableCloseButton then\r\n Exit\r\n else\r\n Form.Close;\r\n end;\r\n end\r\n else\r\n inherited DoHideZoneChild(AZone);\r\n end;\r\nend;\r\n\r\nprocedure TJvDockVSNETTree.DoLButtonDbClk(var Msg: TWMMouse;\r\n var Zone: TJvDockZone; out HTFlag: Integer);\r\nbegin\r\n if not (DockSite is TJvDockVSPopupPanel) then\r\n inherited DoLButtonDbClk(Msg, Zone, HTFlag);\r\nend;\r\n\r\nfunction TJvDockVSNETTree.DoLButtonDown(var Msg: TWMMouse;\r\n var Zone: TJvDockZone; out HTFlag: Integer): Boolean;\r\nbegin\r\n Result := inherited DoLButtonDown(Msg, Zone, HTFlag);\r\n if Zone <> nil then\r\n begin\r\n if HTFlag = HTCLOSE then\r\n TJvDockVSNETZone(Zone).CloseBtnState := bsDown\r\n else\r\n if HTFlag = HTAUTOHIDE then\r\n begin\r\n AutoHideZone := TJvDockVSNETZone(Zone);\r\n AutoHideZone.AutoHideBtnDown := True;\r\n AutoHideZone.AutoHideBtnState := bsDown;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockVSNETTree.DoLButtonUp(var Msg: TWMMouse;\r\n var Zone: TJvDockZone; out HTFlag: Integer);\r\nbegin\r\n if CloseButtonZone <> nil then\r\n TJvDockVSNETZone(CloseButtonZone).CloseBtnState := bsNormal;\r\n inherited DoLButtonUp(Msg, Zone, HTFlag);\r\n if AutoHideZone <> nil then\r\n begin\r\n AutoHideZone.AutoHideBtnDown := False;\r\n AutoHideZone.AutoHideBtnState := bsNormal;\r\n if HTFlag = HTAUTOHIDE then\r\n if DockSite is TJvDockVSNETPanel then\r\n TJvDockVSNETPanel(DockSite).DoAutoHideControl(AutoHideZone.ChildControl);\r\n AutoHideZone := nil;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockVSNETTree.DoMouseMove(var Msg: TWMMouse;\r\n var AZone: TJvDockZone; out HTFlag: Integer);\r\nvar\r\n Zone: TJvDockVSNETZone;\r\nbegin\r\n inherited DoMouseMove(Msg, AZone, HTFlag);\r\n if AZone <> nil then\r\n begin\r\n Zone := TJvDockVSNETZone(AZone);\r\n if Zone.AutoHideBtnDown then\r\n begin\r\n if HTFlag = HTAUTOHIDE then\r\n Zone.AutoHideBtnState := bsDown\r\n else\r\n Zone.AutoHideBtnState := bsUp;\r\n end\r\n else\r\n if (HTFlag = HTAUTOHIDE) and not Zone.CloseBtnDown then\r\n Zone.AutoHideBtnState := bsUp\r\n else\r\n Zone.AutoHideBtnState := bsNormal;\r\n\r\n if Zone.CloseBtnDown then\r\n begin\r\n if HTFlag = HTCLOSE then\r\n Zone.CloseBtnState := bsDown\r\n else\r\n Zone.CloseBtnState := bsUp;\r\n end\r\n else\r\n if (HTFlag = HTCLOSE) and not Zone.AutoHideBtnDown then\r\n Zone.CloseBtnState := bsUp\r\n else\r\n Zone.CloseBtnState := bsNormal;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockVSNETTree.DoOtherHint(Zone: TJvDockZone; HTFlag: Integer;\r\n var HintStr: string);\r\nbegin\r\n inherited DoOtherHint(Zone, HTFlag, HintStr);\r\n if HTFlag = HTAUTOHIDE then\r\n HintStr := RsDockVSNETDockTreeAutoHideBtnHint;\r\nend;\r\n\r\nprocedure TJvDockVSNETTree.DrawAutoHideButton(Zone: TJvDockZone; Left, Top: Integer);\r\nvar\r\n AZone: TJvDockVSNETZone;\r\n ColorArr: array [1..2] of TColor;\r\n ADockClient: TJvDockClient;\r\n IsActive: Boolean;\r\nbegin\r\n if Zone <> nil then\r\n begin\r\n ADockClient := FindDockClient(Zone.ChildControl);\r\n if (ADockClient <> nil) and not ADockClient.EnableCloseButton then\r\n Left := Left + ButtonWidth; // move the auto hide button to the Close Button's location\r\n\r\n AZone := TJvDockVSNETZone(Zone);\r\n IsActive := Assigned(Screen.ActiveControl) and Screen.ActiveControl.Focused and\r\n AZone.ChildControl.ContainsControl(Screen.ActiveControl);\r\n if AZone.AutoHideBtnState <> bsNormal then\r\n begin\r\n if AZone.AutoHideBtnState = bsUp then\r\n begin\r\n ColorArr[1] := clBlack;\r\n if IsActive then\r\n ColorArr[2] := clBtnFace\r\n else\r\n ColorArr[2] := clWhite;\r\n end\r\n else\r\n if AZone.AutoHideBtnState = bsDown then\r\n begin\r\n ColorArr[1] := clBtnFace;\r\n ColorArr[2] := clBlack;\r\n end;\r\n Canvas.Pen.Color := ColorArr[1];\r\n Canvas.MoveTo(Left, Top + ButtonHeight);\r\n Canvas.LineTo(Left + ButtonWidth, Top + ButtonHeight);\r\n Canvas.LineTo(Left + ButtonWidth, Top);\r\n Canvas.Pen.Color := ColorArr[2];\r\n Canvas.LineTo(Left, Top);\r\n Canvas.LineTo(Left, Top + ButtonHeight);\r\n end;\r\n\r\n if AZone.AutoHideBtnState = bsDown then\r\n begin\r\n Inc(Left);\r\n Inc(Top);\r\n end;\r\n\r\n if IsActive then\r\n Canvas.Pen.Color := clWhite\r\n else\r\n Canvas.Pen.Color := clBlack;\r\n if DockSite.Align in [alLeft, alRight, alTop, alBottom] then\r\n begin\r\n Canvas.MoveTo(Left + 9, Top + 10);\r\n Canvas.LineTo(Left + 9, Top + 7);\r\n Canvas.MoveTo(Left + 6, Top + 7);\r\n Canvas.LineTo(Left + 13, Top + 7);\r\n Canvas.MoveTo(Left + 7, Top + 6);\r\n Canvas.LineTo(Left + 7, Top + 2);\r\n Canvas.LineTo(Left + 10, Top + 2);\r\n Canvas.LineTo(Left + 10, Top + 6);\r\n Canvas.LineTo(Left + 11, Top + 6);\r\n Canvas.LineTo(Left + 11, Top + 1);\r\n end\r\n else\r\n if DockSite.Align in [alNone] then\r\n begin\r\n Canvas.MoveTo(Left + 5, Top + 6);\r\n Canvas.LineTo(Left + 8, Top + 6);\r\n Canvas.MoveTo(Left + 8, Top + 3);\r\n Canvas.LineTo(Left + 8, Top + 10);\r\n Canvas.MoveTo(Left + 9, Top + 4);\r\n Canvas.LineTo(Left + 12, Top + 4);\r\n Canvas.LineTo(Left + 12, Top + 7);\r\n Canvas.LineTo(Left + 9, Top + 7);\r\n Canvas.LineTo(Left + 9, Top + 8);\r\n Canvas.LineTo(Left + 13, Top + 8);\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockVSNETTree.DrawCloseButton(Canvas: TCanvas;\r\n Zone: TJvDockZone; Left, Top: Integer);\r\nvar\r\n DrawRect: TRect;\r\n AZone: TJvDockVSNETZone;\r\n ColorArr: array [1..2] of TColor;\r\n ADockClient: TJvDockClient;\r\n AForm: TCustomForm;\r\n IsActive: Boolean;\r\n OrgPenWidth: Integer;\r\nbegin\r\n if Zone <> nil then\r\n begin\r\n ADockClient := FindDockClient(Zone.ChildControl);\r\n if (ADockClient <> nil) and not ADockClient.EnableCloseButton then\r\n Exit;\r\n if Zone.ChildControl is TJvDockTabHostForm then\r\n begin\r\n AForm := TJvDockTabHostForm(Zone.ChildControl).PageControl.ActiveDockForm;\r\n if AForm <> nil then\r\n begin\r\n ADockClient := FindDockClient(AForm);\r\n if (ADockClient <> nil) and not ADockClient.EnableCloseButton then\r\n Exit;\r\n end;\r\n end;\r\n AZone := TJvDockVSNETZone(Zone);\r\n IsActive := Assigned(Screen.ActiveControl) and Screen.ActiveControl.Focused and\r\n AZone.ChildControl.ContainsControl(Screen.ActiveControl);\r\n\r\n DrawRect.Left := Left + 6;\r\n DrawRect.Right := DrawRect.Left + 7;\r\n DrawRect.Top := Top + 3;\r\n DrawRect.Bottom := DrawRect.Top + 7;\r\n\r\n if AZone.CloseBtnState <> bsNormal then\r\n begin\r\n if AZone.CloseBtnState = bsUp then\r\n begin\r\n ColorArr[1] := clBlack;\r\n if IsActive then\r\n ColorArr[2] := clBtnFace\r\n else\r\n ColorArr[2] := clWhite;\r\n end\r\n else\r\n if AZone.CloseBtnState = bsDown then\r\n begin\r\n ColorArr[1] := clBtnFace;\r\n ColorArr[2] := clBlack;\r\n end;\r\n Canvas.Pen.Color := ColorArr[1];\r\n Canvas.MoveTo(Left, Top + ButtonHeight);\r\n Canvas.LineTo(Left + ButtonWidth, Top + ButtonHeight);\r\n Canvas.LineTo(Left + ButtonWidth, Top);\r\n Canvas.Pen.Color := ColorArr[2];\r\n Canvas.LineTo(Left, Top);\r\n Canvas.LineTo(Left, Top + ButtonHeight);\r\n end;\r\n\r\n if AZone.CloseBtnState = bsDown then\r\n OffsetRect(DrawRect, 1, 1);\r\n\r\n if IsActive then\r\n Canvas.Pen.Color := clWhite\r\n else\r\n Canvas.Pen.Color := clBlack;\r\n OrgPenWidth := Canvas.Pen.Width;\r\n try\r\n Canvas.Pen.Width := 2;\r\n Dec(DrawRect.Left);\r\n Dec(DrawRect.Right);\r\n Canvas.MoveTo(DrawRect.Left, DrawRect.Top);\r\n Canvas.LineTo(DrawRect.Right, DrawRect.Bottom);\r\n Canvas.MoveTo(DrawRect.Right, DrawRect.Top);\r\n Canvas.LineTo(DrawRect.Left, DrawRect.Bottom);\r\n finally\r\n Canvas.Pen.Width := OrgPenWidth;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockVSNETTree.DrawDockGrabber(Control: TWinControl; const ARect: TRect);\r\nbegin\r\n inherited DrawDockGrabber(Control, ARect);\r\n if DockSite.Align <> alClient then\r\n begin\r\n DrawAutoHideButton(FindControlZone(Control),\r\n ARect.Right - RightOffset - 2 * ButtonWidth - ButtonSplitter,\r\n ARect.Top + TopOffset)\r\n end;\r\nend;\r\n\r\nprocedure TJvDockVSNETTree.GetCaptionRect(var Rect: TRect);\r\nvar\r\n ADockClient: TJvDockClient;\r\nbegin\r\n if DockSite.Align = alClient then\r\n inherited GetCaptionRect(Rect)\r\n else\r\n begin\r\n Inc(Rect.Left, 2 + CaptionLeftOffset);\r\n ADockClient := FindDockClient(DockSite);\r\n Inc(Rect.Top, 1);\r\n if (ADockClient = nil) or ADockClient.EnableCloseButton then\r\n Dec(Rect.Right, 2 * ButtonWidth + ButtonSplitter + CaptionRightOffset - 1)\r\n else\r\n Dec(Rect.Right, 1 * ButtonWidth + ButtonSplitter + CaptionRightOffset - 1);\r\n Dec(Rect.Bottom, 2);\r\n end;\r\nend;\r\n\r\nfunction TJvDockVSNETTree.GetTopGrabbersHTFlag(const MousePos: TPoint;\r\n out HTFlag: Integer; Zone: TJvDockZone): TJvDockZone;\r\nvar\r\n ADockClient: TJvDockClient;\r\nbegin\r\n Result := inherited GetTopGrabbersHTFlag(MousePos, HTFlag, Zone);\r\n if Zone <> nil then\r\n begin\r\n ADockClient := FindDockClient(Zone.ChildControl);\r\n if (ADockClient <> nil) and not ADockClient.EnableCloseButton then\r\n begin\r\n if HTFlag = HTCLOSE then\r\n HTFLAG := HTAUTOHIDE;\r\n Exit;\r\n end;\r\n end;\r\n\r\n if (Zone <> nil) and (DockSite.Align <> alClient) and (HTFlag <> HTCLOSE) then\r\n begin\r\n with Zone.ChildControl do\r\n if PtInRect(Rect(\r\n Left + Width - 2 * ButtonWidth - RightOffset - ButtonSplitter,\r\n Top - GrabberSize + TopOffset,\r\n Left + Width - 1 * ButtonWidth - RightOffset - ButtonSplitter,\r\n Top - GrabberSize + TopOffset + ButtonHeight), MousePos) then\r\n HTFlag := HTAUTOHIDE;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockVSNETTree.IgnoreZoneInfor(Stream: TMemoryStream);\r\nbegin\r\n inherited IgnoreZoneInfor(Stream);\r\n Stream.Position := Stream.Position + 1;\r\nend;\r\n\r\nprocedure TJvDockVSNETTree.PaintDockGrabberRect(Canvas: TCanvas;\r\n Control: TWinControl; const ARect: TRect; PaintAlways: Boolean = False);\r\nvar\r\n DrawRect: TRect;\r\n IsActive: Boolean;\r\nbegin\r\n inherited PaintDockGrabberRect(Canvas, Control, ARect);\r\n IsActive := Assigned(Screen.ActiveControl) and Screen.ActiveControl.Focused and\r\n Control.ContainsControl(Screen.ActiveControl);\r\n if not IsActive or PaintAlways then\r\n begin\r\n Canvas.Pen.Color := clGray;\r\n DrawRect := ARect;\r\n Inc(DrawRect.Left);\r\n Canvas.RoundRect(DrawRect.Left, DrawRect.Top, DrawRect.Right, DrawRect.Bottom, 2, 2);\r\n end;\r\nend;\r\n\r\n//=== { TJvDockVSNETZone } ===================================================\r\n\r\nconstructor TJvDockVSNETZone.Create(Tree: TJvDockTree);\r\nbegin\r\n inherited Create(Tree);\r\n FAutoHideBtnState := bsNormal;\r\n FCloseBtnState := bsNormal;\r\n FVSPaneVisible := True;\r\nend;\r\n\r\nprocedure TJvDockVSNETZone.DoCustomSetControlName;\r\nvar\r\n I: Integer;\r\n Pane: TJvDockVSPane;\r\n ADockClient: TJvDockClient;\r\nbegin\r\n inherited DoCustomSetControlName;\r\n if Tree.DockSite is TJvDockVSPopupPanel then\r\n begin\r\n with TJvDockVSPopupPanel(Tree.DockSite).VSChannel do\r\n begin\r\n AddDockControl(ChildControl);\r\n if ChildControl is TJvDockTabHostForm then\r\n begin\r\n with TJvDockTabHostForm(ChildControl).PageControl do\r\n for I := 0 to DockClientCount - 1 do\r\n begin\r\n Pane := FindPane(TWinControl(DockClients[I]));\r\n ADockClient := FindDockClient(DockClients[I]);\r\n if (Pane <> nil) and (ADockClient <> nil) then\r\n Pane.FWidth := ADockClient.VSPaneWidth;\r\n end;\r\n end\r\n else\r\n begin\r\n Pane := FindPane(ChildControl);\r\n ADockClient := FindDockClient(ChildControl);\r\n if (Pane <> nil) and (ADockClient <> nil) then\r\n Pane.FWidth := ADockClient.VSPaneWidth;\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockVSNETZone.SetAutoHideBtnDown(const Value: Boolean);\r\nbegin\r\n FAutoHideBtnDown := Value;\r\nend;\r\n\r\nprocedure TJvDockVSNETZone.SetAutoHideBtnState(const Value: TJvDockBtnState);\r\nbegin\r\n if FAutoHideBtnState <> Value then\r\n begin\r\n FAutoHideBtnState := Value;\r\n Tree.DockSite.Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockVSNETZone.SetChildControlVisible(Client: TControl;\r\n AVisible: Boolean);\r\nbegin\r\n inherited SetChildControlVisible(Client, AVisible);\r\nend;\r\n\r\nprocedure TJvDockVSNETZone.SetCloseBtnState(const Value: TJvDockBtnState);\r\nbegin\r\n if FCloseBtnState <> Value then\r\n begin\r\n FCloseBtnState := Value;\r\n Tree.DockSite.Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockVSNETZone.SetVSPaneVisible(const Value: Boolean);\r\nbegin\r\n FVSPaneVisible := Value;\r\nend;\r\n\r\n//=== { TJvDockVSPane } ======================================================\r\n\r\nconstructor TJvDockVSPane.Create(ABlock: TJvDockVSBlock; AForm: TCustomForm;\r\n AWidth: Integer; AIndex: Integer);\r\nbegin\r\n inherited Create;\r\n FBlock := ABlock;\r\n FDockForm := AForm;\r\n FWidth := AWidth;\r\n FIndex := AIndex;\r\n FVisible := AForm.Visible;\r\nend;\r\n\r\ndestructor TJvDockVSPane.Destroy;\r\nbegin\r\n if FBlock.ActivePane = Self then\r\n FBlock.FActivePane := nil;\r\n if FBlock.VSChannel.PopupPane = Self then\r\n FBlock.VSChannel.SetPopupPane(nil);\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJvDockVSPane.GetActive: Boolean;\r\nbegin\r\n Result := FBlock.VSChannel.PopupPane = Self;\r\nend;\r\n\r\n//=== { TJvDockVSPopupPanel } ================================================\r\n\r\nconstructor TJvDockVSPopupPanel.Create(AOwner: TComponent; APanel: TJvDockVSNETPanel);\r\nbegin\r\n inherited Create(AOwner);\r\n\r\n FVSNETDockPanel := APanel;\r\n FVSChannel := APanel.VSChannel;\r\n DockServer := APanel.DockServer;\r\n\r\n DockSite := True; {calls CreateDockManager when you do this!}\r\n Anchors := [akLeft, akRight, akTop, akBottom];\r\n BoundsRect := Rect(0, 0, 0, 0);\r\nend;\r\n\r\nfunction TJvDockVSPopupPanel.CreateDockManager: IDockManager;\r\nvar\r\n ADockStyle: TJvDockBasicStyle;\r\n TreeClass: TJvDockTreeClass;\r\nbegin\r\n Result := nil;\r\n if (DockManager = nil) and DockSite and UseDockManager then\r\n begin\r\n if Assigned(DockServer) then\r\n begin\r\n ADockStyle := DockServer.DockStyle;\r\n if Assigned(ADockStyle) then\r\n begin\r\n TreeClass := ADockStyle.DockPanelTreeClass;\r\n if Assigned(TreeClass) and (TreeClass <> TJvDockTree) then\r\n Result := TreeClass.Create(Self, ADockStyle.DockPanelZoneClass, ADockStyle) as IJvDockManager;\r\n end;\r\n end;\r\n end;\r\n\r\n if Result = nil then\r\n Result := DockManager;\r\n { (rb) Why not? }\r\n // DoubleBuffered := DoubleBuffered or (Result <> nil);\r\nend;\r\n\r\nfunction TJvDockVSPopupPanel.GetVSChannel: TJvDockVSChannel;\r\nbegin\r\n if FVSNETDockPanel <> nil then\r\n Result := FVSNETDockPanel.VSChannel\r\n else\r\n Result := nil;\r\nend;\r\n\r\nprocedure TJvDockVSPopupPanel.SetParent(AParent: TWinControl);\r\nbegin\r\n // (rom) this is suspicious\r\n inherited SetParent(AParent);\r\n if AParent = nil then\r\n Exit;\r\nend;\r\n\r\nprocedure TJvDockVSPopupPanel.ShowDockPanel(MakeVisible: Boolean;\r\n Client: TControl; PanelSizeFrom: TJvDockSetDockPanelSizeFrom);\r\nbegin\r\n { (rb) Meaning? }\r\n if Align <> alNone then\r\n inherited ShowDockPanel(MakeVisible, Client, PanelSizeFrom);\r\nend;\r\n\r\n//=== { TJvDockVSPopupPanelSplitter } ========================================\r\n\r\nconstructor TJvDockVSPopupPanelSplitter.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FAutoSnap := False;\r\n Align := alNone;\r\n Height := 0;\r\n Width := 0;\r\n FMinSize := 30;\r\n FResizeStyle := rsPattern;\r\n FOldSize := -1;\r\n FSplitWidth := 4;\r\n Anchors := [akLeft, akRight, akTop, akBottom];\r\nend;\r\n\r\ndestructor TJvDockVSPopupPanelSplitter.Destroy;\r\nbegin\r\n FBrush.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvDockVSPopupPanelSplitter.AllocateLineDC;\r\nbegin\r\n FLineDC := GetDCEx(Parent.Handle, 0,\r\n DCX_CACHE or DCX_CLIPSIBLINGS or DCX_LOCKWINDOWUPDATE);\r\n if ResizeStyle = rsPattern then\r\n begin\r\n if FBrush = nil then\r\n begin\r\n FBrush := TBrush.Create;\r\n FBrush.Bitmap := AllocPatternBitmap(clBlack, clWhite);\r\n end;\r\n FPrevBrush := SelectObject(FLineDC, FBrush.Handle);\r\n end;\r\nend;\r\n\r\nprocedure TJvDockVSPopupPanelSplitter.CalcSplitSize(X, Y: Integer; var NewSize, Split: Integer);\r\nvar\r\n S: Integer;\r\nbegin\r\n if VSChannelAlign in [alLeft, alRight] then\r\n Split := X - FDownPos.X\r\n else\r\n Split := Y - FDownPos.Y;\r\n S := 0;\r\n case VSChannelAlign of\r\n alLeft:\r\n S := FControl.Width + Split;\r\n alRight:\r\n S := FControl.Width - Split;\r\n alTop:\r\n S := FControl.Height + Split;\r\n alBottom:\r\n S := FControl.Height - Split;\r\n end;\r\n NewSize := S;\r\n if S < FMinSize then\r\n NewSize := FMinSize\r\n else\r\n if S > FMaxSize then\r\n NewSize := FMaxSize;\r\n if S <> NewSize then\r\n begin\r\n if VSChannelAlign in [alRight, alBottom] then\r\n S := S - NewSize\r\n else\r\n S := NewSize - S;\r\n Inc(Split, S);\r\n end;\r\nend;\r\n\r\nfunction TJvDockVSPopupPanelSplitter.CanResize(var NewSize: Integer): Boolean;\r\nbegin\r\n Result := True;\r\n if Assigned(FOnCanResize) then\r\n FOnCanResize(Self, NewSize, Result);\r\nend;\r\n\r\nfunction TJvDockVSPopupPanelSplitter.DoCanResize(var NewSize: Integer): Boolean;\r\nbegin\r\n Result := CanResize(NewSize);\r\n if Result and (NewSize <= MinSize) and FAutoSnap then\r\n NewSize := 0;\r\nend;\r\n\r\nprocedure TJvDockVSPopupPanelSplitter.DrawLine;\r\nvar\r\n X, Y: Integer;\r\nbegin\r\n FLineVisible := not FLineVisible;\r\n X := Left;\r\n Y := Top;\r\n if VSChannelAlign in [alLeft, alRight] then\r\n X := Left + FSplit\r\n else\r\n Y := Top + FSplit;\r\n PatBlt(FLineDC, X, Y, Width, Height, PATINVERT);\r\nend;\r\n\r\nfunction TJvDockVSPopupPanelSplitter.FindControl: TControl;\r\nbegin\r\n Result := FVSPopupPanel;\r\nend;\r\n\r\nprocedure TJvDockVSPopupPanelSplitter.FocusKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);\r\nbegin\r\n if Key = VK_ESCAPE then\r\n StopSizing\r\n else\r\n if Assigned(FOldKeyDown) then\r\n FOldKeyDown(Sender, Key, Shift);\r\nend;\r\n\r\nfunction TJvDockVSPopupPanelSplitter.GetVSChannelAlign: TAlign;\r\nbegin\r\n Result := alNone;\r\n if (VSPopupPanel <> nil) and (VSPopupPanel.FVSNETDockPanel <> nil) then\r\n Result := VSPopupPanel.FVSNETDockPanel.Align;\r\nend;\r\n\r\nprocedure TJvDockVSPopupPanelSplitter.MouseDown(Button: TMouseButton; Shift: TShiftState;\r\n X, Y: Integer);\r\nvar\r\n I: Integer;\r\nbegin\r\n inherited MouseDown(Button, Shift, X, Y);\r\n if Button = mbLeft then\r\n begin\r\n FControl := FindControl;\r\n FDownPos := Point(X, Y);\r\n if Assigned(FControl) then\r\n begin\r\n if VSChannelAlign in [alLeft, alRight] then\r\n begin\r\n FMaxSize := Parent.ClientWidth - FMinSize;\r\n for I := 0 to Parent.ControlCount - 1 do\r\n with Parent.Controls[I] do\r\n if Align in [alLeft, alRight] then\r\n Dec(FMaxSize, Width);\r\n Inc(FMaxSize, FControl.Width);\r\n end\r\n else\r\n begin\r\n FMaxSize := Parent.ClientHeight - FMinSize;\r\n for I := 0 to Parent.ControlCount - 1 do\r\n with Parent.Controls[I] do\r\n if Align in [alTop, alBottom] then\r\n Dec(FMaxSize, Height);\r\n Inc(FMaxSize, FControl.Height);\r\n end;\r\n UpdateSize(X, Y);\r\n AllocateLineDC;\r\n with ValidParentForm(Self) do\r\n if ActiveControl <> nil then\r\n begin\r\n FActiveControl := ActiveControl;\r\n { !! Dirty }\r\n FOldKeyDown := TWinControlAccessProtected(FActiveControl).OnKeyDown;\r\n TWinControlAccessProtected(FActiveControl).OnKeyDown := FocusKeyDown;\r\n end;\r\n if ResizeStyle in [rsLine, rsPattern] then\r\n DrawLine;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockVSPopupPanelSplitter.MouseMove(Shift: TShiftState; X, Y: Integer);\r\nvar\r\n NewSize, Split: Integer;\r\nbegin\r\n inherited MouseMove(Shift, X, Y);\r\n if (ssLeft in Shift) and Assigned(FControl) then\r\n begin\r\n CalcSplitSize(X, Y, NewSize, Split);\r\n if DoCanResize(NewSize) then\r\n begin\r\n if ResizeStyle in [rsLine, rsPattern] then\r\n DrawLine;\r\n FNewSize := NewSize;\r\n FSplit := Split;\r\n if ResizeStyle = rsUpdate then\r\n UpdateControlSize;\r\n if ResizeStyle in [rsLine, rsPattern] then\r\n DrawLine;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockVSPopupPanelSplitter.MouseUp(Button: TMouseButton; Shift: TShiftState;\r\n X, Y: Integer);\r\nbegin\r\n inherited MouseUp(Button, Shift, X, Y);\r\n if Assigned(FControl) then\r\n begin\r\n if ResizeStyle in [rsLine, rsPattern] then\r\n DrawLine;\r\n UpdateControlSize;\r\n StopSizing;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockVSPopupPanelSplitter.Notification(AComponent: TComponent;\r\n Operation: TOperation);\r\nbegin\r\n inherited Notification(AComponent, Operation);\r\n if (Operation = opRemove) and (AComponent = VSPopupPanel) then\r\n FVSPopupPanel := nil;\r\nend;\r\n\r\nprocedure TJvDockVSPopupPanelSplitter.Paint;\r\nvar\r\n FrameBrush: HBRUSH;\r\n R: TRect;\r\nbegin\r\n R := ClientRect;\r\n Canvas.Brush.Color := Color;\r\n InflateRect(R, 2, 2);\r\n case VSChannelAlign of\r\n alLeft:\r\n Dec(R.Right, 2);\r\n alRight:\r\n Inc(R.Left, 3);\r\n alTop:\r\n Dec(R.Bottom, 2);\r\n alBottom:\r\n Inc(R.Top, 3);\r\n end;\r\n DrawFrameControl(Canvas.Handle, R, DFC_BUTTON, DFCS_BUTTONPUSH or DFCS_ADJUSTRECT);\r\n R := ClientRect;\r\n if Beveled then\r\n begin\r\n if VSChannelAlign in [alLeft, alRight] then\r\n InflateRect(R, -1, 2)\r\n else\r\n InflateRect(R, 2, -1);\r\n OffsetRect(R, 1, 1);\r\n FrameBrush := CreateSolidBrush(ColorToRGB(clBtnHighlight));\r\n FrameRect(Canvas.Handle, R, FrameBrush);\r\n DeleteObject(FrameBrush);\r\n OffsetRect(R, -2, -2);\r\n FrameBrush := CreateSolidBrush(ColorToRGB(clBtnShadow));\r\n FrameRect(Canvas.Handle, R, FrameBrush);\r\n DeleteObject(FrameBrush);\r\n end;\r\n\r\n if csDesigning in ComponentState then\r\n with Canvas do\r\n begin\r\n Pen.Style := psDot;\r\n Pen.Mode := pmXor;\r\n Pen.Color := JvDockXorColor;\r\n Brush.Style := bsClear;\r\n Rectangle(0, 0, ClientWidth, ClientHeight);\r\n end;\r\n\r\n if Assigned(FOnPaint) then\r\n FOnPaint(Self);\r\nend;\r\n\r\nprocedure TJvDockVSPopupPanelSplitter.ReleaseLineDC;\r\nbegin\r\n if FPrevBrush <> 0 then\r\n SelectObject(FLineDC, FPrevBrush);\r\n ReleaseDC(Parent.Handle, FLineDC);\r\n if FBrush <> nil then\r\n begin\r\n FBrush.Free;\r\n FBrush := nil;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockVSPopupPanelSplitter.RequestAlign;\r\nbegin\r\n inherited RequestAlign;\r\n if VSChannelAlign in [alBottom, alTop] then\r\n Cursor := crVSplit\r\n else\r\n Cursor := crHSplit;\r\nend;\r\n\r\nprocedure TJvDockVSPopupPanelSplitter.SetBeveled(Value: Boolean);\r\nbegin\r\n FBeveled := Value;\r\n Repaint;\r\nend;\r\n\r\nprocedure TJvDockVSPopupPanelSplitter.SetSplitWidth(const Value: Integer);\r\nbegin\r\n FSplitWidth := Value;\r\nend;\r\n\r\nprocedure TJvDockVSPopupPanelSplitter.SetVSPopupPanel(Value: TJvDockVSPopupPanel);\r\nbegin\r\n { Dirty }\r\n Assert((Value <> nil) and (Value is TJvDockVSPopupPanel));\r\n FVSPopupPanel := Value;\r\nend;\r\n\r\nprocedure TJvDockVSPopupPanelSplitter.StopSizing;\r\nbegin\r\n if Assigned(FControl) then\r\n begin\r\n if FLineVisible then\r\n DrawLine;\r\n FControl := nil;\r\n ReleaseLineDC;\r\n if Assigned(FActiveControl) then\r\n begin\r\n { !! Dirty }\r\n TWinControlAccessProtected(FActiveControl).OnKeyDown := FOldKeyDown;\r\n FActiveControl := nil;\r\n end;\r\n end;\r\n if Assigned(FOnMoved) then\r\n FOnMoved(Self);\r\nend;\r\n\r\nprocedure TJvDockVSPopupPanelSplitter.UpdateControlSize;\r\nbegin\r\n if FNewSize <> FOldSize then\r\n begin\r\n case VSChannelAlign of\r\n alLeft:\r\n begin\r\n FControl.Width := FNewSize;\r\n Left := FControl.Left + FNewSize;\r\n end;\r\n alTop:\r\n begin\r\n FControl.Height := FNewSize;\r\n Top := FControl.Top + FNewSize;\r\n end;\r\n alRight:\r\n begin\r\n Parent.DisableAlign;\r\n try\r\n FControl.Left := FControl.Left + (FControl.Width - FNewSize);\r\n FControl.Width := FNewSize;\r\n Left := FControl.Left - Width;\r\n finally\r\n Parent.EnableAlign;\r\n end;\r\n end;\r\n alBottom:\r\n begin\r\n Parent.DisableAlign;\r\n try\r\n FControl.Top := FControl.Top + (FControl.Height - FNewSize);\r\n FControl.Height := FNewSize;\r\n Top := FControl.Top - Height;\r\n finally\r\n Parent.EnableAlign;\r\n end;\r\n end;\r\n end;\r\n FVSPopupPanel.VSChannel.ResetActivePaneWidth;\r\n Update;\r\n if Assigned(FOnMoved) then\r\n FOnMoved(Self);\r\n FOldSize := FNewSize;\r\n end;\r\nend;\r\n\r\nprocedure TJvDockVSPopupPanelSplitter.UpdateSize(X, Y: Integer);\r\nbegin\r\n CalcSplitSize(X, Y, FNewSize, FSplit);\r\nend;\r\n\r\n//=== { TPopupPanelAnimate } =================================================\r\n\r\nconstructor TPopupPanelAnimate.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n Interval := TJvDockVSNetStyle.GetAnimationInterval;\r\n Enabled := False;\r\n FMaxWidth := 0;\r\n FCurrentWidth := 0;\r\n OnTimer := OnCustomTimer;\r\n FState := asPopup;\r\nend;\r\n\r\nprocedure TPopupPanelAnimate.HideForm(AChannel: TJvDockVSChannel; MaxWidth: Integer);\r\nbegin\r\n if FActiveChannel <> nil then\r\n Exit;\r\n FActiveChannel := AChannel;\r\n Enabled := (FActiveChannel <> nil) and (FActiveChannel.ActiveDockForm <> nil);\r\n if FActiveChannel <> nil then\r\n begin\r\n FMaxWidth := MaxWidth;\r\n FCurrentWidth := 0;\r\n FState := asHide;\r\n end;\r\nend;\r\n\r\nprocedure TPopupPanelAnimate.OnCustomTimer(Sender: TObject);\r\nbegin\r\n // ??? no handler?\r\nend;\r\n\r\nprocedure TPopupPanelAnimate.PopupForm(AChannel: TJvDockVSChannel; MaxWidth: Integer);\r\nbegin\r\n { Currently busy with animating? }\r\n if (FCurrentWidth > 0) and (FActiveChannel <> nil) then\r\n { Dangerous, not in try..finally }\r\n FActiveChannel.Parent.EnableAlign;\r\n FActiveChannel := AChannel;\r\n Enabled := FActiveChannel <> nil;\r\n if FActiveChannel <> nil then\r\n begin\r\n FMaxWidth := MaxWidth;\r\n FCurrentWidth := 0;\r\n FState := asPopup;\r\n end;\r\nend;\r\n\r\nprocedure TPopupPanelAnimate.Timer;\r\nvar\r\n SuitableWidth: Integer;\r\n\r\n procedure SetControlBringToFront(Control: TWinControl; Align: TAlign);\r\n var\r\n I: Integer;\r\n begin\r\n for I := Control.ControlCount - 1 downto 0 do\r\n if Control.Controls[I].Visible and (Control.Controls[I].Align = Align) and\r\n not (Control.Controls[I] is TJvDockVSChannel) and\r\n not (Control.Controls[I] is TJvDockPanel) and\r\n not (Control.Controls[I] is TJvDockSplitter) then\r\n Control.Controls[I].BringToFront;\r\n end;\r\n\r\nbegin\r\n inherited Timer;\r\n if FActiveChannel = nil then\r\n Exit;\r\n\r\n SuitableWidth := Min(FCurrentWidth, FMaxWidth);\r\n with FActiveChannel do\r\n begin\r\n if FCurrentWidth = 0 then\r\n begin\r\n { Dangerous, not in try..finally }\r\n Parent.DisableAlign;\r\n VSPopupPanel.BringToFront;\r\n VSPopupPanelSplitter.BringToFront;\r\n SetControlBringToFront(Parent, Align);\r\n BringToFront;\r\n end;\r\n case Align of\r\n alLeft:\r\n begin\r\n if FState = asPopup then\r\n begin\r\n if FCurrentWidth = 0 then\r\n begin\r\n VSPopupPanel.Width := FMaxWidth;\r\n VSPopupPanel.Top := Top;\r\n VSPopupPanel.Height := Height;\r\n VSPopupPanelSplitter.Top := Top;\r\n VSPopupPanelSplitter.Height := Height;\r\n VSPopupPanelSplitter.Width := VSPopupPanelSplitter.SplitWidth;\r\n end;\r\n VSPopupPanel.Left := Left + Width + SuitableWidth - VSPopupPanel.Width;\r\n end\r\n else\r\n if FState = asHide then\r\n VSPopupPanel.Left := Left - FCurrentWidth;\r\n\r\n VSPopupPanelSplitter.Left := VSPopupPanel.Left + VSPopupPanel.Width;\r\n end;\r\n alRight:\r\n begin\r\n if FState = asPopup then\r\n begin\r\n if FCurrentWidth = 0 then\r\n begin\r\n VSPopupPanel.Width := FMaxWidth;\r\n VSPopupPanel.Top := Top;\r\n VSPopupPanel.Height := Height;\r\n VSPopupPanelSplitter.Top := Top;\r\n VSPopupPanelSplitter.Height := Height;\r\n VSPopupPanelSplitter.Width := VSPopupPanelSplitter.SplitWidth;\r\n end;\r\n VSPopupPanel.Left := Left - SuitableWidth;\r\n end\r\n else\r\n if FState = asHide then\r\n VSPopupPanel.Left := Left - VSPopupPanel.Width + FCurrentWidth;\r\n\r\n VSPopupPanelSplitter.Left := VSPopupPanel.Left - VSPopupPanelSplitter.SplitWidth;\r\n end;\r\n alTop:\r\n begin\r\n if FState = asPopup then\r\n begin\r\n if FCurrentWidth = 0 then\r\n begin\r\n VSPopupPanel.Left := Left;\r\n VSPopupPanel.Height := FMaxWidth;\r\n VSPopupPanel.Width := Width;\r\n VSPopupPanelSplitter.Left := Left;\r\n VSPopupPanelSplitter.Width := Width;\r\n VSPopupPanelSplitter.Height := VSPopupPanelSplitter.SplitWidth;\r\n end;\r\n VSPopupPanel.Top := Top + Height + SuitableWidth - VSPopupPanel.Height;\r\n end\r\n else\r\n if FState = asHide then\r\n VSPopupPanel.Top := Top - FCurrentWidth;\r\n\r\n VSPopupPanelSplitter.Top := VSPopupPanel.Top + VSPopupPanel.Height;\r\n end;\r\n alBottom:\r\n begin\r\n if FState = asPopup then\r\n begin\r\n if FCurrentWidth = 0 then\r\n begin\r\n VSPopupPanel.Left := Left;\r\n VSPopupPanel.Width := Width;\r\n VSPopupPanel.Height := FMaxWidth;\r\n VSPopupPanelSplitter.Left := Left;\r\n VSPopupPanelSplitter.Width := Width;\r\n VSPopupPanelSplitter.Height := VSPopupPanelSplitter.SplitWidth;\r\n end;\r\n VSPopupPanel.Top := Top - SuitableWidth;\r\n end\r\n else\r\n if FState = asHide then\r\n VSPopupPanel.Top := Top - VSPopupPanel.Height + FCurrentWidth;\r\n VSPopupPanelSplitter.Top := VSPopupPanel.Top - VSPopupPanelSplitter.SplitWidth;\r\n end;\r\n end;\r\n VSPopupPanel.Visible := True;\r\n VSPopupPanelSplitter.Visible := True;\r\n end;\r\n if FCurrentWidth >= FMaxWidth then\r\n begin\r\n { Dangerous, not in try..finally }\r\n FActiveChannel.Parent.EnableAlign;\r\n Self.Enabled := False;\r\n if FState = asHide then\r\n begin\r\n if FActiveChannel.DockServer.DockStyle is TJvDockVSNetStyle then\r\n TJvDockVSNetStyle(FActiveChannel.DockServer.DockStyle).EndPopup(FActiveChannel);\r\n FActiveChannel.HidePopupPanel(FActiveChannel.PopupPane);\r\n end\r\n else\r\n begin\r\n if FActiveChannel.DockServer.DockStyle is TJvDockVSNetStyle then\r\n TJvDockVSNetStyle(FActiveChannel.DockServer.DockStyle).BeginPopup(FActiveChannel);\r\n\r\n FActiveChannel.AutoFocusActiveDockForm;\r\n HideAllPopupPanel(FActiveChannel);\r\n end;\r\n FActiveChannel := nil;\r\n FCurrentWidth := 0;\r\n FMaxWidth := 0;\r\n end\r\n else\r\n Inc(FCurrentWidth, TJvDockVSNetStyle.GetAnimationMoveWidth);\r\nend;\r\n\r\ninitialization\r\n {$IFDEF UNITVERSIONING}\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n {$ENDIF UNITVERSIONING}\r\n\r\nfinalization\r\n GlobalPopupPanelAnimate.Free;\r\n GlobalPopupPanelAnimate := nil;\r\n {$IFDEF UNITVERSIONING}\r\n UnregisterUnitVersion(HInstance);\r\n {$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvDockableForm.dfm", "content": "object JvDockableForm: TJvDockableForm\r\n Left = 168\r\n Top = 133\r\n Width = 272\r\n Height = 241\r\n Caption = ''\r\n Color = clBtnFace\r\n Font.Charset = DEFAULT_CHARSET\r\n Font.Color = clWindowText\r\n Font.Height = -12\r\n Font.Name = 'Arial'\r\n Font.Style = []\r\n OldCreateOrder = False\r\n Visible = False\r\n PixelsPerInch = 96\r\n TextHeight = 13\r\nend\r\n" }, { "path": "External/Jedi/Jvcl/run/JvDotNetControls.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvDotNetCtrls.PAS, released on 2004-01-01.\r\n\r\nThe Initial Developer of the Original Code is Marc Hoffman.\r\nPortions created by Marc Hoffman are Copyright (C) 2002 APRIORI business solutions AG.\r\nPortions created by APRIORI business solutions AG are\r\nCopyright (C) 2002 APRIORI business solutions AG\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvDotNetControls.pas 13138 2011-10-26 23:17:50Z jfudickar $\r\n\r\nunit JvDotNetControls;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, Messages, Classes, Controls,\r\n JvRichEdit, JvListView, JvCheckListBox, JvEdit, JvHotKey, JvListBox,\r\n JvMaskEdit, JvMemo, JvComCtrls, JvScrollBox, JvToolEdit,\r\n StdCtrls;\r\n\r\ntype\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvDotNetCheckListBox = class(TJvCheckListBox)\r\n private\r\n FHighlighted: Boolean;\r\n FOldWindowProc: TWndMethod;\r\n procedure InternalWindowProc(var Msg: TMessage);\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n end;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvDotNetEdit = class(TJvEdit)\r\n private\r\n FHighlighted: Boolean;\r\n FOldWindowProc: TWndMethod;\r\n procedure InternalWindowProc(var Msg: TMessage);\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n end;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvDotNetHotKey = class(TJvHotKey)\r\n private\r\n FHighlighted: Boolean;\r\n FOldWindowProc: TWndMethod;\r\n procedure InternalWindowProc(var Msg: TMessage);\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n end;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvDotNetListBox = class(TJvListBox)\r\n private\r\n FHighlighted: Boolean;\r\n FOldWindowProc: TWndMethod;\r\n procedure InternalWindowProc(var Msg: TMessage);\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n end;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvDotNetListView = class(TJvListView)\r\n private\r\n FHighlighted: Boolean;\r\n FOldWindowProc: TWndMethod;\r\n procedure InternalWindowProc(var Msg: TMessage);\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n end;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvDotNetMaskEdit = class(TJvMaskEdit)\r\n private\r\n FHighlighted: Boolean;\r\n FOldWindowProc: TWndMethod;\r\n procedure InternalWindowProc(var Msg: TMessage);\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n end;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvDotNetMemo = class(TJvMemo)\r\n private\r\n FHighlighted: Boolean;\r\n FOldWindowProc: TWndMethod;\r\n procedure InternalWindowProc(var Msg: TMessage);\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n end;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvDotNetRichEdit = class(TJvRichEdit)\r\n private\r\n FHighlighted: Boolean;\r\n FOldWindowProc: TWndMethod;\r\n procedure InternalWindowProc(var Msg: TMessage);\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n end;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvDotNetScrollBox = class(TJvScrollBox)\r\n private\r\n FHighlighted: Boolean;\r\n FOldWindowProc: TWndMethod;\r\n procedure InternalWindowProc(var Msg: TMessage);\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n end;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvDotNetTreeView = class(TJvTreeView)\r\n private\r\n FHighlighted: Boolean;\r\n FOldWindowProc: TWndMethod;\r\n procedure InternalWindowProc(var Msg: TMessage);\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n end;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvDotNetFilenameEdit = class(TJvFilenameEdit)\r\n private\r\n FHighlighted: Boolean;\r\n FOldWindowProc: TWndMethod;\r\n procedure InternalWindowProc(var Msg: TMessage);\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n end;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvDotNetDirectoryEdit = class(TJvDirectoryEdit)\r\n private\r\n FHighlighted: Boolean;\r\n FOldWindowProc: TWndMethod;\r\n procedure InternalWindowProc(var Msg: TMessage);\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n end;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvDotNetButton = class(TButton)\r\n private\r\n FHighlighted: Boolean;\r\n FOldWindowProc: TWndMethod;\r\n procedure InternalWindowProc(var Msg: TMessage);\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n published\r\n property Color;\r\n end;\r\n\r\n(* TJvDotNetCustomControl = class(TWinControl)\r\n published\r\n { Published declarations }\r\n property Color;\r\n end;\r\n*)\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvDotNetControls.pas $';\r\n Revision: '$Revision: 13138 $';\r\n Date: '$Date: 2011-10-27 01:17:50 +0200 (jeu. 27 oct. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n JvDotNetUtils;\r\n\r\n//=== { TJvDotNetCheckListBox } ==============================================\r\n\r\nconstructor TJvDotNetCheckListBox.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FOldWindowProc := WindowProc;\r\n WindowProc := InternalWindowProc;\r\nend;\r\n\r\ndestructor TJvDotNetCheckListBox.Destroy;\r\nbegin\r\n WindowProc := FOldWindowProc;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvDotNetCheckListBox.InternalWindowProc(var Msg: TMessage);\r\nbegin\r\n FOldWindowProc(Msg);\r\n DotNetMessageHandler(Msg, Self, Color, FHighlighted);\r\nend;\r\n\r\n//=== { TJvDotNetEdit } ======================================================\r\n\r\nconstructor TJvDotNetEdit.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FOldWindowProc := WindowProc;\r\n WindowProc := InternalWindowProc;\r\nend;\r\n\r\ndestructor TJvDotNetEdit.Destroy;\r\nbegin\r\n WindowProc := FOldWindowProc;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvDotNetEdit.InternalWindowProc(var Msg: TMessage);\r\nbegin\r\n FOldWindowProc(Msg);\r\n DotNetMessageHandler(Msg, Self, Color, FHighlighted);\r\nend;\r\n\r\n//=== { TJvDotNetHotKey } ====================================================\r\n\r\nconstructor TJvDotNetHotKey.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FOldWindowProc := WindowProc;\r\n WindowProc := InternalWindowProc;\r\nend;\r\n\r\ndestructor TJvDotNetHotKey.Destroy;\r\nbegin\r\n WindowProc := FOldWindowProc;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvDotNetHotKey.InternalWindowProc(var Msg: TMessage);\r\nbegin\r\n FOldWindowProc(Msg);\r\n DotNetMessageHandler(Msg, Self, Color, FHighlighted);\r\nend;\r\n\r\n//=== { TJvDotNetListBox } ===================================================\r\n\r\nconstructor TJvDotNetListBox.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FOldWindowProc := WindowProc;\r\n WindowProc := InternalWindowProc;\r\nend;\r\n\r\ndestructor TJvDotNetListBox.Destroy;\r\nbegin\r\n WindowProc := FOldWindowProc;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvDotNetListBox.InternalWindowProc(var Msg: TMessage);\r\nbegin\r\n FOldWindowProc(Msg);\r\n DotNetMessageHandler(Msg, Self, Color, FHighlighted);\r\nend;\r\n\r\n//=== { TJvDotNetListView } ==================================================\r\n\r\nconstructor TJvDotNetListView.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FOldWindowProc := WindowProc;\r\n WindowProc := InternalWindowProc;\r\nend;\r\n\r\ndestructor TJvDotNetListView.Destroy;\r\nbegin\r\n WindowProc := FOldWindowProc;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvDotNetListView.InternalWindowProc(var Msg: TMessage);\r\nbegin\r\n FOldWindowProc(Msg);\r\n DotNetMessageHandler(Msg, Self, Color, FHighlighted);\r\nend;\r\n\r\n//=== { TJvDotNetMaskEdit } ==================================================\r\n\r\nconstructor TJvDotNetMaskEdit.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FOldWindowProc := WindowProc;\r\n WindowProc := InternalWindowProc;\r\nend;\r\n\r\ndestructor TJvDotNetMaskEdit.Destroy;\r\nbegin\r\n WindowProc := FOldWindowProc;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvDotNetMaskEdit.InternalWindowProc(var Msg: TMessage);\r\nbegin\r\n FOldWindowProc(Msg);\r\n DotNetMessageHandler(Msg, Self, Color, FHighlighted);\r\nend;\r\n\r\n//=== { TJvDotNetMemo } ======================================================\r\n\r\nconstructor TJvDotNetMemo.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FOldWindowProc := WindowProc;\r\n WindowProc := InternalWindowProc;\r\nend;\r\n\r\ndestructor TJvDotNetMemo.Destroy;\r\nbegin\r\n WindowProc := FOldWindowProc;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvDotNetMemo.InternalWindowProc(var Msg: TMessage);\r\nbegin\r\n FOldWindowProc(Msg);\r\n DotNetMessageHandler(Msg, Self, Color, FHighlighted);\r\nend;\r\n\r\n//=== { TJvDotNetRichEdit } ==================================================\r\n\r\nconstructor TJvDotNetRichEdit.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FOldWindowProc := WindowProc;\r\n WindowProc := InternalWindowProc;\r\nend;\r\n\r\ndestructor TJvDotNetRichEdit.Destroy;\r\nbegin\r\n WindowProc := FOldWindowProc;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvDotNetRichEdit.InternalWindowProc(var Msg: TMessage);\r\nbegin\r\n FOldWindowProc(Msg);\r\n DotNetMessageHandler(Msg, Self, Color, FHighlighted);\r\nend;\r\n\r\n//=== { TJvDotNetScrollBox } =================================================\r\n\r\nconstructor TJvDotNetScrollBox.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FOldWindowProc := WindowProc;\r\n WindowProc := InternalWindowProc;\r\nend;\r\n\r\ndestructor TJvDotNetScrollBox.Destroy;\r\nbegin\r\n WindowProc := FOldWindowProc;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvDotNetScrollBox.InternalWindowProc(var Msg: TMessage);\r\nbegin\r\n FOldWindowProc(Msg);\r\n DotNetMessageHandler(Msg, Self, Color, FHighlighted);\r\nend;\r\n\r\n//=== { TJvDotNetTreeView } ==================================================\r\n\r\nconstructor TJvDotNetTreeView.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FOldWindowProc := WindowProc;\r\n WindowProc := InternalWindowProc;\r\nend;\r\n\r\ndestructor TJvDotNetTreeView.Destroy;\r\nbegin\r\n WindowProc := FOldWindowProc;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvDotNetTreeView.InternalWindowProc(var Msg: TMessage);\r\nbegin\r\n FOldWindowProc(Msg);\r\n DotNetMessageHandler(Msg, Self, Color, FHighlighted);\r\nend;\r\n\r\n//=== { TJvDotNetFilenameEdit } ==============================================\r\n\r\nconstructor TJvDotNetFilenameEdit.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FOldWindowProc := WindowProc;\r\n WindowProc := InternalWindowProc;\r\nend;\r\n\r\ndestructor TJvDotNetFilenameEdit.Destroy;\r\nbegin\r\n WindowProc := FOldWindowProc;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvDotNetFilenameEdit.InternalWindowProc(var Msg: TMessage);\r\nbegin\r\n FOldWindowProc(Msg);\r\n DotNetMessageHandler(Msg, Self, Color, FHighlighted);\r\nend;\r\n\r\n//=== { TJvDotNetDirectoryEdit } =============================================\r\n\r\nconstructor TJvDotNetDirectoryEdit.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FOldWindowProc := WindowProc;\r\n WindowProc := InternalWindowProc;\r\nend;\r\n\r\ndestructor TJvDotNetDirectoryEdit.Destroy;\r\nbegin\r\n WindowProc := FOldWindowProc;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvDotNetDirectoryEdit.InternalWindowProc(var Msg: TMessage);\r\nbegin\r\n FOldWindowProc(Msg);\r\n DotNetMessageHandler(Msg, Self, Color, FHighlighted);\r\nend;\r\n\r\n//=== { TJvDotNetButton } ====================================================\r\n\r\nconstructor TJvDotNetButton.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FOldWindowProc := WindowProc;\r\n WindowProc := InternalWindowProc;\r\nend;\r\n\r\ndestructor TJvDotNetButton.Destroy;\r\nbegin\r\n WindowProc := FOldWindowProc;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvDotNetButton.InternalWindowProc(var Msg: TMessage);\r\nbegin\r\n // (p3) this doesn't work 100% when tabbing into the button\r\n FOldWindowProc(Msg);\r\n DotNetMessageHandler(Msg, Self, Color, FHighlighted);\r\n if Msg.Msg = CM_MOUSELEAVE then\r\n Invalidate; // redraw 3D border\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend." }, { "path": "External/Jedi/Jvcl/run/JvDotNetUtils.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvDotNetUtils.PAS, released on 2004-01-01.\r\n\r\nThe Initial Developer of the Original Code is Marc Hoffman.\r\nPortions created by Marc Hoffman are Copyright (C) 2002 APRIORI business solutions AG.\r\nPortions created by APRIORI business solutions AG are Copyright (C) 2002 APRIORI business solutions AG\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvDotNetUtils.pas 12461 2009-08-14 17:21:33Z obones $\r\n\r\nunit JvDotNetUtils;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, Messages, Classes, Graphics, Controls;\r\n\r\nprocedure DotNetMessageHandler(var Msg: TMessage; AControl: TWinControl;\r\n AColor: TColor; var InControl: Boolean);\r\nprocedure DrawDotNetControl(Control: TWinControl; AColor: TColor; InControl: Boolean);\r\nprocedure SetDotNetFrameColors(FocusedColor, UnfocusedColor: TColor);\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvDotNetUtils.pas $';\r\n Revision: '$Revision: 12461 $';\r\n Date: '$Date: 2009-08-14 19:21:33 +0200 (ven. 14 août 2009) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nvar\r\n InternalFocusedColor: TColor = TColor($00733800);\r\n InternalUnfocusedColor: TColor = clGray;\r\n\r\nprocedure SetDotNetFrameColors(FocusedColor, UnfocusedColor: TColor);\r\nbegin\r\n InternalFocusedColor := FocusedColor;\r\n InternalUnfocusedColor := UnfocusedColor;\r\nend;\r\n\r\nprocedure DotNetMessageHandler(var Msg: TMessage; AControl: TWinControl; AColor: TColor;\r\n var InControl: Boolean);\r\nbegin\r\n case Msg.Msg of\r\n CM_MOUSEENTER, CM_MOUSELEAVE, WM_SETFOCUS, WM_KILLFOCUS, WM_NCPAINT:\r\n begin\r\n // (rom) moved the if statements here for improved efficiency\r\n if Msg.Msg = CM_MOUSEENTER then\r\n InControl := True\r\n else\r\n if Msg.Msg = CM_MOUSELEAVE then\r\n InControl := False;\r\n DrawDotNetControl(AControl, AColor, InControl);\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure DrawDotNetControl(Control: TWinControl; AColor: TColor; InControl: Boolean);\r\nvar\r\n DC: HDC;\r\n R: TRect;\r\n Canvas: TCanvas;\r\nbegin\r\n DC := GetWindowDC(Control.Handle);\r\n try\r\n GetWindowRect(Control.Handle, R);\r\n OffsetRect(R, -R.Left, -R.Top);\r\n Canvas := TCanvas.Create;\r\n with Canvas do\r\n try\r\n Handle := DC;\r\n Brush.Color := InternalUnfocusedColor;\r\n if Control.Focused or InControl then\r\n Brush.Color := InternalFocusedColor;\r\n FrameRect(R);\r\n InflateRect(R, -1, -1);\r\n if not (Control.Focused or InControl) then\r\n Brush.Color := AColor;\r\n FrameRect(R);\r\n finally\r\n Free;\r\n end;\r\n finally\r\n ReleaseDC(Control.Handle, DC);\r\n end;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvDragDrop.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvDragDrop.PAS, released on 2001-02-28.\r\n\r\nThe Initial Developer of the Original Code is S?stien Buysse [sbuysse att buypin dott com]\r\nPortions created by S?stien Buysse are Copyright (C) 2001 S?stien Buysse.\r\nAll Rights Reserved.\r\n\r\nContributor(s): Michael Beck [mbeck att bigfoot dott com],\r\n Andreas Hausladen [Andreas dott Hausladen att gmx dott de].\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvDragDrop.pas 13173 2011-11-19 12:43:58Z ahuser $\r\n\r\nunit JvDragDrop;\r\n\r\n{$I jvcl.inc}\r\n{$I windowsonly.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, Messages, ShellAPI, ActiveX, Classes, Controls,\r\n JvComponentBase, JclWideStrings;\r\n\r\ntype\r\n TJvDropTarget = class;\r\n TJvDragDrop = class;\r\n\r\n TJvDropEvent = procedure(Sender: TObject; Pos: TPoint; Value: TStrings) of object;\r\n TJvDropEffect = (deNone, deCopy, deMove, deLink, deScroll);\r\n\r\n TJvDragEvent = procedure(Sender: TJvDropTarget; var Effect: TJvDropEffect) of object;\r\n TJvDragDropEvent = procedure(Sender: TJvDropTarget; var Effect: TJvDropEffect;\r\n Shift: TShiftState; X, Y: Integer) of object;\r\n TJvDragLeaveEvent = procedure(Sender: TJvDropTarget) of object;\r\n TJvDragAcceptEvent = procedure(Sender: TJvDropTarget; var Accept: Boolean) of object;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvDropTarget = class(TJvComponent, IDropTarget)\r\n private\r\n FDataObject: IDataObject;\r\n FStreamedAcceptDrag: Boolean;\r\n FControl: TWinControl;\r\n FOnDragDrop: TJvDragDropEvent;\r\n FOnDragAccept: TJvDragAcceptEvent;\r\n FOnDragEnter: TJvDragEvent;\r\n FOnDragOver: TJvDragEvent;\r\n FOnDragLeave: TJvDragLeaveEvent;\r\n FAcceptDrag: Boolean;\r\n procedure SetControl(Value: TWinControl);\r\n procedure SetAcceptDrag(Value: Boolean);\r\n procedure RegisterControl;\r\n procedure UnregisterControl;\r\n protected\r\n function DragEnter(const dataObj: IDataObject; grfKeyState: Longint;\r\n pt: TPoint; var dwEffect: Longint): HRESULT; stdcall;\r\n function DragOver(grfKeyState: Longint; pt: TPoint;\r\n var dwEffect: Longint): HRESULT; stdcall;\r\n function DragLeave: HRESULT; stdcall;\r\n function Drop(const dataObj: IDataObject; grfKeyState: Longint; pt: TPoint;\r\n var dwEffect: Longint): HRESULT; stdcall;\r\n function DoDragAccept: Boolean; dynamic;\r\n procedure DoDragEnter(var Effect: Longint); dynamic;\r\n procedure DoDragOver(var Effect: Longint); dynamic;\r\n procedure DoDragLeave; dynamic;\r\n procedure DoDragDrop(var Effect: Longint; Shift: TShiftState; X, Y: Integer); dynamic;\r\n procedure Loaded; override;\r\n procedure Notification(AComponent: TComponent; Operation: TOperation); override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n // GetFilenames returns the HDROP Filenames. (same as TJvDragDrop).\r\n // Return value: number of filenames\r\n function GetFilenames(List: TStrings): Integer;\r\n // GetFilenamesW returns the HDROP Filenames, in unicode.\r\n // Return value: number of filenames\r\n function GetFilenamesW(List: TWideStrings): Integer;\r\n // GetFileDescrNames returns the File Descriptor file names (not available for Explorer drag/drop)\r\n function GetFileDescrNames(List: TStrings): Integer;\r\n // GetFileDescrCount returns the number of File Descroptor file names.\r\n function GetFileDescrCount: Integer;\r\n // GetFileContent returns the file content of the File Descriptor\r\n function GetFileContent(Index: Integer; Stream: TStream): Boolean;\r\n property DataObject: IDataObject read FDataObject;\r\n published\r\n property AcceptDrag: Boolean read FAcceptDrag write SetAcceptDrag default True;\r\n property Control: TWinControl read FControl write SetControl;\r\n property OnDragDrop: TJvDragDropEvent read FOnDragDrop write FOnDragDrop;\r\n property OnDragAccept: TJvDragAcceptEvent read FOnDragAccept write FOnDragAccept;\r\n property OnDragEnter: TJvDragEvent read FOnDragEnter write FOnDragEnter;\r\n property OnDragOver: TJvDragEvent read FOnDragOver write FOnDragOver;\r\n property OnDragLeave: TJvDragLeaveEvent read FOnDragLeave write FOnDragLeave;\r\n end;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvDragDrop = class(TJvComponent)\r\n private\r\n FAcceptDrag: Boolean;\r\n FStreamedAcceptDrag: Boolean;\r\n FFiles: TStringList;\r\n FOnDrop: TJvDropEvent;\r\n FIsHooked: Boolean;\r\n FTargetStrings: TStrings;\r\n FDropTarget: TWinControl;\r\n procedure DropFiles(Handle: HDROP);\r\n function GetFiles: TStrings;\r\n procedure SetAcceptDrag(Value: Boolean);\r\n procedure SetDropTarget(const Value: TWinControl);\r\n function WndProc(var Msg: TMessage): Boolean;\r\n protected\r\n procedure HookControl;\r\n procedure UnHookControl;\r\n procedure Loaded; override;\r\n procedure Notification(AComponent: TComponent; Operation: TOperation); override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n property Files: TStrings read GetFiles;\r\n property TargetStrings: TStrings read FTargetStrings write FTargetStrings;\r\n published\r\n property AcceptDrag: Boolean read FAcceptDrag write SetAcceptDrag default True;\r\n property DropTarget: TWinControl read FDropTarget write SetDropTarget;\r\n property OnDrop: TJvDropEvent read FOnDrop write FOnDrop;\r\n end;\r\n\r\nfunction CF_FILEDESCRIPTOR: UINT;\r\nfunction CF_FILECONTENTS: UINT;\r\nfunction Malloc: IMalloc;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvDragDrop.pas $';\r\n Revision: '$Revision: 13173 $';\r\n Date: '$Date: 2011-11-19 13:43:58 +0100 (sam. 19 nov. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n ShlObj, SysUtils, Forms,\r\n JvJCLUtils,\r\n JvWndProcHook, JvJVCLUtils;\r\n\r\nvar\r\n GlobalCF_FILEDESCRIPTOR: UINT = $FFFFFFF;\r\n GlobalCF_FILECONTENTS: UINT = $FFFFFFF;\r\n GlobalMalloc: IMalloc = nil;\r\n\r\n FileDropFormatEtc: FORMATETC;\r\n FileContentFormatEtc: FORMATETC;\r\n FileDescriptorFormatEtc: FORMATETC;\r\n\r\nfunction CF_FILEDESCRIPTOR: UINT;\r\nbegin\r\n if GlobalCF_FILEDESCRIPTOR = $FFFFFFF then\r\n GlobalCF_FILEDESCRIPTOR := RegisterClipboardFormat(CFSTR_FILEDESCRIPTOR);\r\n Result := GlobalCF_FILEDESCRIPTOR;\r\nend;\r\n\r\nfunction CF_FILECONTENTS: UINT;\r\nbegin\r\n if GlobalCF_FILECONTENTS = $FFFFFFF then\r\n GlobalCF_FILECONTENTS := RegisterClipboardFormat(CFSTR_FILECONTENTS);\r\n Result := GlobalCF_FILECONTENTS;\r\nend;\r\n\r\nfunction Malloc: IMalloc;\r\nbegin\r\n if not Assigned(GlobalMalloc) then\r\n ShGetMalloc(GlobalMalloc);\r\n Result := GlobalMalloc;\r\nend;\r\n\r\n//=== { TJvDragDrop } ========================================================\r\n\r\nconstructor TJvDragDrop.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FAcceptDrag := False;\r\n FStreamedAcceptDrag := True;\r\n FFiles := TStringList.Create;\r\n FIsHooked := False;\r\n if (Owner is TWinControl) and (csDesigning in ComponentState) then\r\n FDropTarget := TWinControl(Owner);\r\nend;\r\n\r\ndestructor TJvDragDrop.Destroy;\r\nbegin\r\n UnHookControl;\r\n FFiles.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvDragDrop.Loaded;\r\nbegin\r\n inherited Loaded;\r\n FAcceptDrag := False;\r\n SetAcceptDrag(FStreamedAcceptDrag);\r\nend;\r\n\r\nprocedure TJvDragDrop.DropFiles(Handle: HDROP);\r\nvar\r\n Buffer: PChar;\r\n I, BufferLength, NeededLength: Integer;\r\n MousePt: TPoint;\r\n Count: Integer;\r\nbegin\r\n FFiles.Clear;\r\n\r\n BufferLength := MAX_PATH;\r\n\r\n { Note: Do not use fixed stack buffers of size MAX_PATH,\r\n to prevent buffer overrun attacks, be paranoid }\r\n GetMem(Buffer, BufferLength * SizeOf(Char));\r\n try\r\n { Return value is a count of the dropped files }\r\n Count := DragQueryFile(Handle, $FFFFFFFF, nil, 0);\r\n\r\n for I := 0 to Count-1 do\r\n begin\r\n { Return value is the required size, in characters, of the buffer,\r\n *not* including the terminating null character (hence the + 1) }\r\n NeededLength := DragQueryFile(Handle, I, nil, 0) + 1;\r\n if NeededLength > BufferLength then\r\n begin\r\n BufferLength := NeededLength;\r\n ReallocMem(Buffer, BufferLength * SizeOf(Char));\r\n end;\r\n DragQueryFile(Handle, I, Buffer, BufferLength);\r\n FFiles.Add(Buffer);\r\n end;\r\n finally\r\n FreeMem(Buffer);\r\n end;\r\n\r\n if Assigned(FTargetStrings) then\r\n FTargetStrings.Assign(FFiles);\r\n\r\n if Assigned(FOnDrop) then\r\n begin\r\n DragQueryPoint(Handle, MousePt);\r\n FOnDrop(Self, MousePt, FFiles);\r\n end;\r\n\r\n DragFinish(Handle);\r\nend;\r\n\r\nprocedure TJvDragDrop.HookControl;\r\nbegin\r\n if not FIsHooked then\r\n { Paranoia checks }\r\n if Assigned(FDropTarget) and not (csDesigning in ComponentState) then\r\n FIsHooked := RegisterWndProcHook(FDropTarget, WndProc, hoBeforeMsg);\r\nend;\r\n\r\nprocedure TJvDragDrop.UnHookControl;\r\nbegin\r\n if FIsHooked then\r\n begin\r\n FIsHooked := False;\r\n { Paranoia checks }\r\n if Assigned(FDropTarget) and not (csDesigning in ComponentState) then\r\n UnRegisterWndProcHook(FDropTarget, WndProc, hoBeforeMsg);\r\n end;\r\nend;\r\n\r\nprocedure TJvDragDrop.Notification(AComponent: TComponent; Operation: TOperation);\r\nbegin\r\n inherited Notification(AComponent, Operation);\r\n\r\n if (AComponent = FDropTarget) and (Operation = opRemove) then\r\n DropTarget := nil;\r\nend;\r\n\r\nprocedure TJvDragDrop.SetAcceptDrag(Value: Boolean);\r\nbegin\r\n if csLoading in ComponentState then\r\n { When loading, delay changing to active until all properties are loaded }\r\n FStreamedAcceptDrag := Value\r\n else\r\n if Value <> FAcceptDrag then\r\n begin\r\n FAcceptDrag := Value;\r\n\r\n if Assigned(FDropTarget) and not (csDesigning in ComponentState) then\r\n begin\r\n { If the component is being destroyed, we don't want to call its Handle\r\n property, which will implicitly re-create its already destroyed handle }\r\n if not (csDestroying in FDropTarget.ComponentState) then\r\n DragAcceptFiles(FDropTarget.Handle, FAcceptDrag);\r\n\r\n if FAcceptDrag then\r\n HookControl\r\n else\r\n UnHookControl;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJvDragDrop.GetFiles: TStrings;\r\nbegin\r\n Result := FFiles;\r\nend;\r\n\r\nprocedure TJvDragDrop.SetDropTarget(const Value: TWinControl);\r\nvar\r\n WasActive: Boolean;\r\nbegin\r\n if csLoading in ComponentState then\r\n FDropTarget := Value\r\n else\r\n if Value <> FDropTarget then\r\n begin\r\n WasActive := AcceptDrag;\r\n\r\n { This will implicitly unhook the current DropTarget }\r\n AcceptDrag := False;\r\n\r\n ReplaceComponentReference(Self, Value, TComponent(FDropTarget));\r\n\r\n if WasActive then\r\n { And hook again.. }\r\n AcceptDrag := True;\r\n end;\r\nend;\r\n\r\nfunction TJvDragDrop.WndProc(var Msg: TMessage): Boolean;\r\nbegin\r\n Result := Msg.Msg = WM_DROPFILES;\r\n if Result then\r\n DropFiles(HDROP(Msg.WParam));\r\nend;\r\n\r\n\r\n//=== { TJvDropTarget } ======================================================\r\n\r\nprocedure InitFormatEtc;\r\nbegin\r\n if FileDescriptorFormatEtc.cfFormat <> 0 then\r\n Exit;\r\n\r\n with FileDropFormatEtc do\r\n begin\r\n cfFormat := CF_HDROP;\r\n ptd := nil;\r\n dwAspect := DVASPECT_CONTENT;\r\n lindex := 0;\r\n tymed := TYMED_HGLOBAL;\r\n end;\r\n\r\n with FileDescriptorFormatEtc do\r\n begin\r\n cfFormat := CF_FILEDESCRIPTOR;\r\n ptd := nil;\r\n dwAspect := DVASPECT_CONTENT;\r\n lindex := -1;\r\n tymed := TYMED_HGLOBAL;\r\n end;\r\n\r\n with FileContentFormatEtc do\r\n begin\r\n cfFormat := CF_FILECONTENTS;\r\n ptd := nil;\r\n dwAspect := DVASPECT_CONTENT;\r\n lindex := 0;\r\n tymed := TYMED_ISTREAM;\r\n end;\r\nend;\r\n\r\nprocedure GetDropEffect(Effect: Longint; var Eff: TJvDropEffect);\r\nbegin\r\n Eff := deNone;\r\n if (Effect and DROPEFFECT_NONE) <> 0 then\r\n Eff := deNone\r\n else\r\n if (Effect and DROPEFFECT_COPY) <> 0 then\r\n Eff := deCopy\r\n else\r\n if (Effect and DROPEFFECT_MOVE) <> 0 then\r\n Eff := deMove\r\n else\r\n if (Effect and DROPEFFECT_LINK) <> 0 then\r\n Eff := deLink\r\n else\r\n if (Effect and DROPEFFECT_SCROLL) <> 0 then\r\n Eff := deScroll;\r\nend;\r\n\r\nprocedure SetDropEffect(var Effect: Longint; Eff: TJvDropEffect);\r\nbegin\r\n case Eff of\r\n deNone:\r\n Effect := DROPEFFECT_NONE;\r\n deCopy:\r\n Effect := DROPEFFECT_COPY;\r\n deMove:\r\n Effect := DROPEFFECT_MOVE;\r\n deLink:\r\n Effect := DROPEFFECT_LINK;\r\n deScroll:\r\n Effect := Longint(DROPEFFECT_SCROLL);\r\n end;\r\nend;\r\n\r\nconstructor TJvDropTarget.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n Malloc; // a simple call prevents Delphi from crashing\r\n\r\n FAcceptDrag := True;\r\n FStreamedAcceptDrag := True;\r\n\r\n InitFormatEtc;\r\nend;\r\n\r\ndestructor TJvDropTarget.Destroy;\r\nbegin\r\n UnregisterControl;\r\n FDataObject := nil;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJvDropTarget.DragEnter(const dataObj: IDataObject; grfKeyState: Longint;\r\n pt: TPoint; var dwEffect: Longint): HRESULT;\r\nbegin\r\n FDataObject := dataObj;\r\n Result := S_OK;\r\n\r\n if not DoDragAccept then\r\n begin\r\n FDataObject := nil;\r\n dwEffect := DROPEFFECT_NONE;\r\n end\r\n else\r\n begin\r\n dwEffect := DROPEFFECT_COPY;\r\n try\r\n DoDragEnter(dwEffect);\r\n except\r\n Result := E_UNEXPECTED;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJvDropTarget.DragOver(grfKeyState: Longint; pt: TPoint;\r\n var dwEffect: Longint): HRESULT;\r\nbegin\r\n Result := S_OK;\r\n if FDataObject = nil then\r\n begin\r\n FDataObject := nil;\r\n dwEffect := DROPEFFECT_NONE;\r\n end\r\n else\r\n begin\r\n dwEffect := DROPEFFECT_COPY;\r\n try\r\n DoDragOver(dwEffect);\r\n except\r\n Result := E_UNEXPECTED;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJvDropTarget.DragLeave: HRESULT;\r\nbegin\r\n try\r\n DoDragLeave;\r\n Result := S_OK;\r\n except\r\n Result := E_UNEXPECTED;\r\n end;\r\n FDataObject := nil;\r\nend;\r\n\r\nfunction TJvDropTarget.Drop(const dataObj: IDataObject; grfKeyState: Longint;\r\n pt: TPoint; var dwEffect: Longint): HRESULT;\r\nbegin\r\n Result := S_OK;\r\n if FDataObject = nil then\r\n begin\r\n FDataObject := nil;\r\n dwEffect := DROPEFFECT_NONE;\r\n end\r\n else\r\n begin\r\n dwEffect := DROPEFFECT_COPY;\r\n try\r\n DoDragDrop(dwEffect, KeyDataToShiftState(grfKeyState), pt.X, pt.Y);\r\n except\r\n Result := E_UNEXPECTED;\r\n end;\r\n FDataObject := nil;\r\n end;\r\nend;\r\n\r\nfunction TJvDropTarget.DoDragAccept: Boolean;\r\nbegin\r\n Result := True;\r\n if Assigned(FOnDragAccept) then\r\n FOnDragAccept(Self, Result);\r\nend;\r\n\r\nprocedure TJvDropTarget.DoDragEnter(var Effect: Longint);\r\nvar\r\n Eff: TJvDropEffect;\r\nbegin\r\n GetDropEffect(Effect, Eff);\r\n if Assigned(FOnDragEnter) then\r\n FOnDragEnter(Self, Eff);\r\n SetDropEffect(Effect, Eff);\r\nend;\r\n\r\nprocedure TJvDropTarget.DoDragOver(var Effect: Longint);\r\nvar\r\n Eff: TJvDropEffect;\r\nbegin\r\n GetDropEffect(Effect, Eff);\r\n if Assigned(FOnDragOver) then\r\n FOnDragOver(Self, Eff);\r\n SetDropEffect(Effect, Eff);\r\nend;\r\n\r\nprocedure TJvDropTarget.DoDragLeave;\r\nbegin\r\n if Assigned(FOnDragLeave) then\r\n FOnDragLeave(Self);\r\nend;\r\n\r\nprocedure TJvDropTarget.DoDragDrop(var Effect: Longint; Shift: TShiftState;\r\n X, Y: Integer);\r\nvar\r\n Eff: TJvDropEffect;\r\nbegin\r\n GetDropEffect(Effect, Eff);\r\n if Assigned(FOnDragDrop) then\r\n FOnDragDrop(Self, Eff, Shift, X, Y);\r\n SetDropEffect(Effect, Eff);\r\nend;\r\n\r\nprocedure TJvDropTarget.SetControl(Value: TWinControl);\r\nbegin\r\n if Value <> FControl then\r\n begin\r\n UnregisterControl;\r\n ReplaceComponentReference(Self, Value, TComponent(FControl));\r\n RegisterControl;\r\n end;\r\nend;\r\n\r\nprocedure TJvDropTarget.RegisterControl;\r\nbegin\r\n if FAcceptDrag and Assigned(FControl) and not (csDesigning in ComponentState) then\r\n begin\r\n if RegisterDragDrop(FControl.Handle, Self) <> S_OK then\r\n RaiseLastOSError;\r\n end;\r\nend;\r\n\r\nprocedure TJvDropTarget.UnregisterControl;\r\nbegin\r\n if FAcceptDrag and Assigned(FControl) and not (csDesigning in ComponentState) then\r\n if FControl.HandleAllocated then\r\n RevokeDragDrop(FControl.Handle);\r\nend;\r\n\r\nprocedure TJvDropTarget.SetAcceptDrag(Value: Boolean);\r\nbegin\r\n if csLoading in ComponentState then\r\n FStreamedAcceptDrag := Value\r\n else\r\n if Value <> FAcceptDrag then\r\n begin\r\n UnregisterControl;\r\n FAcceptDrag := Value;\r\n RegisterControl;\r\n end;\r\nend;\r\n\r\nprocedure TJvDropTarget.Loaded;\r\nbegin\r\n inherited Loaded;\r\n AcceptDrag := FStreamedAcceptDrag;\r\nend;\r\n\r\nprocedure TJvDropTarget.Notification(AComponent: TComponent;\r\n Operation: TOperation);\r\nbegin\r\n inherited Notification(AComponent, Operation);\r\n if (Operation = opRemove) and (AComponent = FControl) then\r\n Control := nil;\r\nend;\r\n\r\nfunction TJvDropTarget.GetFileDescrNames(List: TStrings): Integer;\r\nvar\r\n FileGroupDescr: PFileGroupDescriptor;\r\n Medium: TStgMedium;\r\n I: Integer;\r\n S: string;\r\nbegin\r\n Result := 0;\r\n if FDataObject.GetData(FileDescriptorFormatEtc, Medium) = S_OK then\r\n begin\r\n try\r\n try\r\n FileGroupDescr := GlobalLock(Medium.hGlobal);\r\n try\r\n if List <> nil then\r\n for I := 0 to FileGroupDescr.cItems - 1 do\r\n begin\r\n SetString(S, FileGroupDescr^.fgd[I].cFileName, StrLen(FileGroupDescr^.fgd[I].cFileName));\r\n List.Add(S);\r\n end;\r\n Result := FileGroupDescr.cItems;\r\n finally\r\n GlobalUnlock(Medium.hGlobal);\r\n end;\r\n finally\r\n ReleaseStgMedium(Medium);\r\n end;\r\n except\r\n Result := 0;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJvDropTarget.GetFileDescrCount: Integer;\r\nvar\r\n FileGroupDescr: PFileGroupDescriptor;\r\n Medium: TStgMedium;\r\nbegin\r\n Result := 0;\r\n if FDataObject.GetData(FileDescriptorFormatEtc, Medium) = S_OK then\r\n try\r\n try\r\n FileGroupDescr := GlobalLock(Medium.hGlobal);\r\n try\r\n Result := FileGroupDescr.cItems;\r\n finally\r\n GlobalUnlock(Medium.hGlobal);\r\n end;\r\n finally\r\n ReleaseStgMedium(Medium);\r\n end;\r\n except\r\n Result := 0;\r\n end;\r\nend;\r\n\r\nfunction TJvDropTarget.GetFilenames(List: TStrings): Integer;\r\nvar\r\n DragH: HDROP;\r\n Medium: TStgMedium;\r\n Name: string;\r\n I, Count, Len: Integer;\r\nbegin\r\n Result := 0;\r\n if FDataObject.GetData(FileDropFormatEtc, Medium) = S_OK then\r\n try\r\n try\r\n DragH := HDROP(GlobalLock(Medium.hGlobal));\r\n try\r\n Count := DragQueryFile(DragH, Cardinal(-1), nil, 0);\r\n if List <> nil then\r\n for I := 0 to Count - 1 do\r\n begin\r\n Len := DragQueryFile(DragH, I, nil, 0);\r\n if Len > 0 then\r\n begin\r\n SetLength(Name, Len + 1);\r\n DragQueryFile(DragH, I, PChar(Name), Len + 1);\r\n SetLength(Name, Len);\r\n List.Add(Name);\r\n end;\r\n end;\r\n Result := Count;\r\n finally\r\n GlobalUnlock(Medium.hGlobal);\r\n end;\r\n finally\r\n ReleaseStgMedium(Medium);\r\n end;\r\n except\r\n Result := 0;\r\n end;\r\nend;\r\n\r\nfunction TJvDropTarget.GetFilenamesW(List: TWideStrings): Integer;\r\nvar\r\n DragH: HDROP;\r\n Medium: TStgMedium;\r\n Name: widestring;\r\n I, Count, Len: Integer;\r\nbegin\r\n Result := 0;\r\n if FDataObject.GetData(FileDropFormatEtc, Medium) = S_OK then\r\n try\r\n try\r\n DragH := HDROP(GlobalLock(Medium.hGlobal));\r\n try\r\n Count := DragQueryFileW(DragH, Cardinal(-1), nil, 0);\r\n if List <> nil then\r\n for I := 0 to Count - 1 do\r\n begin\r\n Len := DragQueryFileW(DragH, I, nil, 0);\r\n if Len > 0 then\r\n begin\r\n SetLength(Name, Len + 1);\r\n DragQueryFileW(DragH, I, PwideChar(Name), Len + 1);\r\n SetLength(Name, Len);\r\n List.Append(Name);\r\n end;\r\n end;\r\n Result := Count;\r\n finally\r\n GlobalUnlock(Medium.hGlobal);\r\n end;\r\n finally\r\n ReleaseStgMedium(Medium);\r\n end;\r\n except\r\n Result := 0;\r\n end;\r\nend;\r\n\r\nfunction TJvDropTarget.GetFileContent(Index: Integer; Stream: TStream): Boolean;\r\nconst\r\n MaxBufSize = 100 * 1024;\r\nvar\r\n Medium: TStgMedium;\r\n InStream: IStream;\r\n Stat: TStatStg;\r\n\r\n Buf: Pointer;\r\n BufSize: Integer;\r\n Num: Int64;\r\n Position: Int64;\r\nbegin\r\n Result := False;\r\n if (Stream = nil) or (Index < 0) or (Index >= GetFileDescrCount) then\r\n Exit;\r\n\r\n FileContentFormatEtc.lindex := Index;\r\n if FDataObject.GetData(FileContentFormatEtc, Medium) = S_OK then\r\n try\r\n try\r\n if Medium.tymed and TYMED_ISTREAM <> 0 then\r\n begin\r\n InStream := IStream(Medium.stm);\r\n InStream.Stat(Stat, STATFLAG_NONAME);\r\n Num := Stat.cbSize;\r\n if Num > 0 then\r\n begin\r\n GetMem(Buf, MaxBufSize);\r\n try\r\n // Speicherbereich reservieren\r\n Position := Stream.Position;\r\n Stream.Size := Stream.Size + Num;\r\n Stream.Position := Position;\r\n\r\n while Num > 0 do\r\n begin\r\n if Num < MaxBufSize then\r\n BufSize := Num\r\n else\r\n BufSize := MaxBufSize;\r\n InStream.Read(Buf, BufSize, nil);\r\n Stream.Write(Buf^, BufSize);\r\n Dec(Num, BufSize);\r\n end;\r\n finally\r\n FreeMem(Buf);\r\n end;\r\n end;\r\n end\r\n else\r\n Result := False;\r\n finally\r\n ReleaseStgMedium(Medium);\r\n end;\r\n except\r\n Result := False;\r\n end;\r\nend;\r\n\r\ninitialization\r\n {$IFDEF UNITVERSIONING}\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n {$ENDIF UNITVERSIONING}\r\n OleInitialize(nil);\r\n\r\nfinalization\r\n OleUninitialize;\r\n {$IFDEF UNITVERSIONING}\r\n UnregisterUnitVersion(HInstance);\r\n {$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvDrawImage.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvDrawImage.PAS, released on 2002-06-15.\r\n\r\nThe Initial Developer of the Original Code is Jan Verhoeven [jan1 dott verhoeven att wxs dott nl]\r\nPortions created by Jan Verhoeven are Copyright (C) 2002 Jan Verhoeven.\r\nAll Rights Reserved.\r\n\r\nContributor(s): Robert Love [rlove att slcdug dott org].\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvDrawImage.pas 13104 2011-09-07 06:50:43Z obones $\r\n\r\nunit JvDrawImage;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows,\r\n Messages,\r\n Classes, Graphics, Controls, ExtCtrls,\r\n JvAirBrush, JvPaintFX;\r\n\r\ntype\r\n TSmartResizeMode = (rmWidth, rmHeight, rmSquare);\r\n TMorphBrush = (mbVerBox, mbHorBox, mbVerOval, mbHorOval);\r\n TDigitalFilter = array [0..4, 0..4] of Smallint;\r\n TColorPicked = procedure(Sender: TObject; AColor: TColor) of object;\r\n TGonio = array [0..180, 0..1] of Extended;\r\n TSinPix = array [0..255] of Byte;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvDrawImage = class(TImage)\r\n private\r\n FGonio: TGonio;\r\n FSinPixs: TSinPix;\r\n FShape: string;\r\n FShapes: TStringList;\r\n FZoomClip: TBitmap;\r\n FAirBrush: TJvAirBrush;\r\n FPolygonChecked: Boolean;\r\n FOnColorPicked: TColorPicked;\r\n FBlocks: Integer;\r\n FStars: Integer;\r\n FStarPoints: Integer;\r\n FSpirals: Integer;\r\n function GetShapes: TStrings;\r\n procedure EscapePaint(X, Y: Integer; Shift: TShiftState);\r\n procedure CopyClip;\r\n procedure SetClip(AColor: TColor);\r\n procedure InitPlasma;\r\n function MixColors(Color1, Color2: TColor): TColor;\r\n function GetBlue(AColor: TColor): Byte;\r\n function GetGreen(AColor: TColor): Byte;\r\n function GetRed(AColor: TColor): Byte;\r\n procedure SetSyms(X, Y: Integer);\r\n function Rotate(Origin, Endpoint: TPoint; Angle: Real): TPoint;\r\n procedure DrawPlasma(X, Y: Integer; Amount: Extended);\r\n procedure DrawEffectBrush(X, Y, Radius: Integer; Amount: Extended;\r\n Style: TLightBrush);\r\n procedure Rimple(Src, Dst: TBitmap; Amount: Extended);\r\n procedure DrawStretchBrush(X, Y, Radius: Integer; Amount: Extended;\r\n Style: TMorphBrush);\r\n procedure SampleStretch(Src, Dst: TBitmap);\r\n procedure DrawLightBrush(X, Y, Radius, Amount: Integer;\r\n Style: TLightBrush);\r\n procedure DrawColorCircle(X, Y, Mode: Integer);\r\n procedure ColorCircle(var bm: TBitmap; center: TPoint; Radius,\r\n Mode: Integer);\r\n procedure DrawDarkerCircle(X, Y, Mode: Integer);\r\n procedure DrawLighterCircle(X, Y, Mode: Integer);\r\n procedure DrawGradientBrush(Color1, Color2: TColor; X1, X2,\r\n Y: Integer);\r\n procedure HorGradientLine(Bitmap: TBitmap; XOrigin, XFinal, Y: Integer;\r\n R1, G1, B1, R2, G2, B2: Byte; Smooth: Boolean);\r\n procedure SmoothPnt(Bitmap: TBitmap; xk, yk: Integer);\r\n procedure DrawVGradientBrush(Color1, Color2: TColor; Y1, Y2,\r\n X: Integer);\r\n procedure VerGradientLine(Bitmap: TBitmap; YOrigin, YFinal, X: Integer;\r\n R1, G1, B1, R2, G2, B2: Byte; Smooth: Boolean);\r\n procedure DrawCube;\r\n function PointToBlock(X, Y: Integer): TRect;\r\n procedure DrawSkew;\r\n procedure DrawTriangle;\r\n procedure PutClip(M: TRect);\r\n procedure DrawSyms(X, Y: Integer);\r\n procedure DrawTexLines(X0, Y0, X, Y: Integer);\r\n function BlendColors(const Color1, Color2: Integer;\r\n Opacity: Integer): Longint;\r\n function TexHighlight(Colr: Integer): Longint;\r\n function TexShadow(Colr: Integer): Longint;\r\n procedure DrawTexOvals(X0, Y0, X, Y: Integer);\r\n procedure DrawBlurOvals(X0, Y0, X, Y: Integer);\r\n procedure DrawTexCurves(X0, Y0, X, Y: Integer);\r\n procedure DrawBlurCurves(X0, Y0, X, Y: Integer);\r\n procedure DrawTexPoly(X0, Y0, X, Y: Integer);\r\n procedure DrawBlurPoly(X0, Y0, X, Y: Integer);\r\n procedure DrawTexRects(X0, Y0, X, Y: Integer);\r\n procedure DrawBlurRects(X0, Y0, X, Y: Integer);\r\n procedure DrawBlurLines(X0, Y0, X, Y: Integer);\r\n procedure InterpRect(X1, Y1, X2, Y2: Integer);\r\n procedure InterpolateRect(Bmp: TBitmap; X1, Y1, X2, Y2: Integer);\r\n procedure DrawColumn(X1, Y1, X2, Y2: Integer);\r\n procedure Column(Bitmap: TBitmap; XOrigin, XFinal, YOrigin,\r\n YFinal: Integer; R1, G1, B1, R2, G2, B2: Byte; Smooth: Boolean);\r\n procedure DrawSphere(Color1, Color2: TColor; X1, Y1, X2, Y2: Integer);\r\n procedure Sphere(Bitmap: TBitmap; xcenter, a, ycenter, b: Integer; R1,\r\n G1, B1, R2, G2, B2: Byte; Smooth: Boolean);\r\n procedure DrawMultiSphere(Color1, Color2: TColor; X1, Y1, X2,\r\n Y2: Integer);\r\n procedure DrawDropletSphere(Color1, Color2: TColor; X1, Y1, X2,\r\n Y2: Integer);\r\n procedure DrawWaveSphere(Color1, Color2: TColor; X1, Y1, X2,\r\n Y2: Integer);\r\n procedure DrawRisingWaveSphere(Color1, Color2: TColor; X1, Y1, X2,\r\n Y2: Integer);\r\n// function GetAngle(Origin, Endpoint: TPoint): Integer;\r\n// procedure TextRotate(X, Y, Angle: Integer; AText: string; AFont: TFont);\r\n function ReduceVector(Origin, Endpoint: TPoint; Factor: Real): TPoint;\r\n procedure Star(X, Y: Integer);\r\n procedure SetPolygonChecked(const Value: Boolean);\r\n procedure DrawSpiro(center, Radius: TPoint);\r\n procedure DrawBars(X1, Y1, X2, Y2: Integer);\r\n procedure Drawborders(X1, Y1, X2, Y2: Integer);\r\n procedure SetonColorPicked(const Value: TColorPicked);\r\n procedure SetShape(const Value: string);\r\n procedure SetAirBrush(const Value: TJvAirBrush);\r\n procedure SetTransformer(const Value: TJvPaintFX);\r\n procedure BuildShapeList;\r\n procedure SetBlocks(const Value: Integer);\r\n procedure SetSpirals(const Value: Integer);\r\n procedure SetStarPoints(const Value: Integer);\r\n procedure SetStars(const Value: Integer);\r\n procedure FillGonio;\r\n procedure FillSinPixs;\r\n procedure Shear(ABitmap: TBitmap; Amount: Integer);\r\n procedure XFormA(Amount: Integer);\r\n protected\r\n procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;\r\n procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;\r\n procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;\r\n procedure ColorPicked(AColor: TColor);\r\n procedure Loaded; override;\r\n public\r\n Clip: TBitmap;\r\n TraceB: Byte;\r\n FX: TJvPaintFX;\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n procedure ClipAll;\r\n procedure Effects;\r\n procedure Backgrounds;\r\n procedure Preview(ABitmap: TBitmap);\r\n procedure ApplyFilter(var Dst: TBitmap; DF: TDigitalFilter);\r\n procedure BlurBarChange(Sender: TObject);\r\n procedure ColorNoiseBarChange(Sender: TObject);\r\n procedure ContrastBarChange(Sender: TObject);\r\n procedure DrawBlend;\r\n procedure DrawMandelJulia(Mandel: Boolean);\r\n procedure DrawMap;\r\n procedure DrawSolarize;\r\n procedure DrawTriangles;\r\n procedure EmbossBarChange;\r\n procedure FilterBlueBarChange;\r\n procedure FilterGreenBarChange;\r\n procedure FilterRedBarChange;\r\n procedure FilterXBlueBarChange;\r\n procedure FilterXGreenBarChange;\r\n procedure FilterXRedBarChange;\r\n procedure FisheyeBarChange;\r\n procedure LightnessBarChange(Sender: TObject);\r\n procedure Marble2BarChange;\r\n procedure Marble3BarChange;\r\n procedure Marble4BarChange;\r\n procedure Marble5BarChange;\r\n procedure Marble6BarChange;\r\n procedure Marble7BarChange;\r\n procedure Marble8BarChange;\r\n procedure MarbleBarChange;\r\n procedure MonoNoiseBarChange(Sender: TObject);\r\n procedure MosaicBarChange;\r\n procedure PlasmaBarChange;\r\n procedure Posterize;\r\n procedure RippleRandom;\r\n procedure RippleTooth;\r\n procedure RippleTriangle;\r\n procedure RotateBar;\r\n procedure SaturationBarChange(Sender: TObject);\r\n procedure SeamBarChange;\r\n procedure ShearBarChange;\r\n procedure SmoothBarChange(Sender: TObject);\r\n procedure SplitBlurBarChange(Sender: TObject);\r\n procedure SplitRoundBarChange;\r\n procedure SplitWasteBarChange;\r\n procedure SqueezeBotBarChange;\r\n procedure SqueezeDiamondBarChange;\r\n procedure SqueezeHorBarChange;\r\n procedure SqueezeRound2BarChange;\r\n procedure SqueezeRoundBarChange;\r\n procedure SqueezeTopBarChange;\r\n procedure SqueezeWasteBarChange;\r\n procedure TexturizeOverlap;\r\n procedure TexturizeTile;\r\n procedure TwistBarChange;\r\n procedure WaveBarChange;\r\n procedure WaveExtraChange;\r\n procedure WaveInfChange;\r\n procedure XFormABarChange;\r\n procedure Trace;\r\n property AirBrush: TJvAirBrush read FAirBrush write SetAirBrush;\r\n property Transformer: TJvPaintFX read FX write SetTransformer;\r\n property Shapes: TStrings read GetShapes;\r\n published\r\n property Shape: string read FShape write SetShape;\r\n property PolygonChecked: Boolean read FPolygonChecked write SetPolygonChecked;\r\n property Stars: Integer read FStars write SetStars;\r\n property StarPoints: Integer read FStarPoints write SetStarPoints;\r\n property Blocks: Integer read FBlocks write SetBlocks;\r\n property Spirals: Integer read FSpirals write SetSpirals;\r\n property OnColorPicked: TColorPicked read FOnColorPicked write SetOnColorPicked;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvDrawImage.pas $';\r\n Revision: '$Revision: 13104 $';\r\n Date: '$Date: 2011-09-07 08:50:43 +0200 (mer. 07 sept. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n SysUtils, Math, Dialogs, Clipbrd,\r\n JvResample, JvPainterEffectsForm, JvQuickPreviewForm, JvPainterQBForm,\r\n JvTypes, JvResources;\r\n\r\nconst\r\n // Texture constants\r\n DarkStrength = 0.82;\r\n StrongBlend = 52;\r\n WeakBlend = 36;\r\n\r\n BlurFilter: TDigitalFilter =\r\n ((1, 1, 1, 1, 1),\r\n (1, 0, 0, 0, 1),\r\n (1, 0, 0, 0, 1),\r\n (1, 0, 0, 0, 1),\r\n (1, 1, 1, 1, 1));\r\n\r\ntype\r\n TFColor = record\r\n B: Byte;\r\n G: Byte;\r\n R: Byte;\r\n end;\r\n\r\n Tmybezier = array [0..3] of TPoint;\r\n Tmyskew = array [0..4] of TPoint;\r\n Tmychord = array [1..8] of Integer;\r\n Tpointarray = array [0..12] of TPoint;\r\n Tfreepoly = array [0..100] of TPoint;\r\n\r\nvar\r\n PainterEffectsF: TPainterEffectsForm;\r\n QuickPreviewF: TQuickPreviewForm;\r\n PainterQBF: TPainterQBForm;\r\n\r\n mycliprect: TRect;\r\n UserFilter: TDigitalFilter;\r\n\r\n RangeTransColor: TColor;\r\n\r\n NSpiro: Integer;\r\n Wavepen, Wavebrush: TColor;\r\n decoX, decoY: Integer;\r\n \r\n mybezier: Tmybezier;\r\n myskew: Tmyskew;\r\n mychord: Tmychord;\r\n myorigin, myprevpoint: TPoint;\r\n myslinedir: string;\r\n myslinetol: Integer;\r\n myDraw: Boolean;\r\n mypen: TPenMode;\r\n mypenstyle: TPenStyle;\r\n myoldbrushstyle: TBrushStyle;\r\n myoldpenwidth: Integer;\r\n myround: Integer;\r\n\r\n clipcm: TCopyMode;\r\n\r\n pointarray: Tpointarray;\r\n spiralfactor: Real;\r\n spiraldir: Integer;\r\n TargetPoint: TPoint;\r\n zoomrect: TRect;\r\n freepoly: Tfreepoly;\r\n freepolycount: Integer;\r\n bezierfix1, bezierfix2: Boolean;\r\n\r\nfunction TrimInt(N, Min, Max: Integer): Integer;\r\nbegin\r\n if N > Max then\r\n Result := Max\r\n else\r\n if N < Min then\r\n Result := Min\r\n else\r\n Result := N;\r\nend;\r\n\r\nfunction IntToByte(N: Integer): Byte;\r\nbegin\r\n if N > 255 then\r\n Result := 255\r\n else\r\n if N < 0 then\r\n Result := 0\r\n else\r\n Result := N;\r\nend;\r\n\r\nconstructor TJvDrawImage.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n Width := 256;\r\n Height := 256;\r\n Clip := TBitmap.Create;\r\n FZoomClip := TBitmap.Create;\r\n FAirBrush := TJvAirBrush.Create(Self);\r\n FX := TJvPaintFX.Create(Self);\r\n TargetPoint := Point(0, 0);\r\n NSpiro := 40;\r\n RangeTransColor := clWhite;\r\n zoomrect := Rect(0, 0, 50, 50);\r\n mycliprect := Rect(0, 0, 256, 256);\r\n //spiral number, direction and Factor\r\n Spirals := 3;\r\n spiralfactor := 0.99;\r\n spiraldir := 1;\r\n // number of points for Star shape\r\n StarPoints := 5;\r\n Stars := 1;\r\n // tolerance for straight line Drawing\r\n myslinetol := 5;\r\n\r\n mypenstyle := psSolid;\r\n // number of Blocks wide and heigh\r\n Blocks := 32;\r\n // rounding of roundrect\r\n myround := 10;\r\n // default Drawing Mode\r\n Shape := 'line';\r\n FillSinPixs;\r\n FillGonio;\r\n TraceB := $00;\r\n FShapes := TStringList.Create;\r\n BuildShapeList;\r\n PainterEffectsF := TPainterEffectsForm.Create(Self);\r\n PainterEffectsF.setDrawImage(Self);\r\n QuickPreviewF := TQuickPreviewForm.Create(Self);\r\n QuickPreviewF.SetDrawImage(Self);\r\n PainterQBF := TPainterQBForm.Create(Self);\r\n PainterQBF.setDrawImage(Self);\r\nend;\r\n\r\ndestructor TJvDrawImage.Destroy;\r\nbegin\r\n FShapes.Free;\r\n Clip.Free;\r\n FZoomClip.Free;\r\n FAirBrush.Free;\r\n FX.Free;\r\n PainterEffectsF.Free;\r\n QuickPreviewF.Free;\r\n PainterQBF.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJvDrawImage.GetShapes: TStrings;\r\nbegin\r\n Result := FShapes;\r\nend;\r\n\r\n// Start of filter procedures\r\n\r\nprocedure TJvDrawImage.FillGonio;\r\nvar\r\n A0: Extended;\r\n I: Integer;\r\nbegin\r\n A0 := Pi / 180;\r\n for I := 0 to 180 do\r\n SinCos(A0 * (I - 90), FGonio[I, 0], FGonio[I, 1]);\r\nend;\r\n\r\nprocedure TJvDrawImage.FillSinPixs;\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := 0 to 255 do\r\n FSinPixs[I] := Variant(Sin(I / 255 * Pi / 2) * 255);\r\nend;\r\n\r\nprocedure TJvDrawImage.Shear(ABitmap: TBitmap; Amount: Integer);\r\nvar\r\n bm: TBitmap;\r\n p1, p2: PByteArray;\r\n X, dx, Y, h, w, c1, c2: Integer;\r\n f: Extended;\r\nbegin\r\n bm := TBitmap.Create;\r\n h := ABitmap.Height;\r\n w := ABitmap.Width;\r\n bm.Width := w;\r\n bm.Height := h;\r\n f := w / (w + (Amount / 100) * h);\r\n bm.PixelFormat := pf24bit;\r\n ABitmap.PixelFormat := pf24bit;\r\n for Y := 0 to h - 1 do\r\n begin\r\n p1 := ABitmap.ScanLine[Y];\r\n p2 := bm.ScanLine[Y];\r\n dx := Round(Amount / 100 * Y);\r\n for X := 0 to w - 1 do\r\n begin\r\n c1 := X * 3;\r\n c2 := Round(f * (X + dx)) * 3;\r\n p2[c2] := p1[c1];\r\n p2[c2 + 1] := p1[c1 + 1];\r\n p2[c2 + 2] := p1[c1 + 2];\r\n end;\r\n end;\r\n ABitmap.Assign(bm);\r\n bm.Free;\r\nend;\r\n\r\nprocedure TJvDrawImage.XFormA(Amount: Integer);\r\nvar\r\n X, Y, i: Integer;\r\n p1: pbytearray;\r\nbegin\r\n for i := 1 to Amount do\r\n for Y := 0 to Clip.Height - 1 do\r\n begin\r\n p1 := Clip.ScanLine[Y];\r\n for X := 0 to Clip.Width - 1 do\r\n begin\r\n p1[X * 3] := FSinPixs[p1[X * 3]];\r\n p1[X * 3 + 1] := FSinPixs[p1[X * 3 + 1]];\r\n p1[X * 3 + 2] := FSinPixs[p1[X * 3 + 2]];\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvDrawImage.Drawborders(X1, Y1, X2, Y2: Integer);\r\nvar\r\n h, w: Integer;\r\nbegin\r\n h := clientheight;\r\n w := clientwidth;\r\n Canvas.FillRect(Rect(0, 0, w, Y2 - Y1));\r\n Canvas.FillRect(Rect(0, h - (Y2 - Y1), w, h));\r\n Canvas.FillRect(Rect(0, 0, X2 - X1, h));\r\n Canvas.FillRect(Rect(w - (X2 - X1), 0, w, h));\r\nend;\r\n\r\nprocedure TJvDrawImage.DrawBars(X1, Y1, X2, Y2: Integer);\r\nvar\r\n h, w: Integer;\r\nbegin\r\n h := clientheight;\r\n w := clientwidth;\r\n if Y1 < 10 then\r\n Y1 := 0;\r\n if Y2 > (h - 10) then\r\n Y2 := h;\r\n X1 := 0;\r\n X2 := w;\r\n Canvas.FillRect(Rect(X1, Y1, X2, Y2));\r\nend;\r\n\r\nprocedure TJvDrawImage.DrawSpiro(center, Radius: TPoint);\r\nvar\r\n X0, X1, Y0, Y1, a0, a1, da0, da1: Real;\r\n xs, ys, X, Y, r0, R1: Integer;\r\n i: Integer;\r\nbegin\r\n xs := Picture.Bitmap.Width div 2;\r\n ys := Picture.Bitmap.Height div 2;\r\n if xs <> ys then\r\n begin\r\n ShowMessage(RsImageMustBeSquare);\r\n Exit;\r\n end;\r\n r0 := Variant(Sqrt(Sqr(center.X - xs) + Sqr(center.Y - ys)));\r\n R1 := Variant(Sqrt(Sqr(Radius.X - center.X) + Sqr(Radius.Y - center.Y)));\r\n if (r0 + R1) > xs then\r\n begin\r\n ShowMessage(RsSumOfRadiTolarge);\r\n Exit;\r\n end;\r\n if (r0 < 5) or (R1 < 5) then\r\n begin\r\n ShowMessage(Format(RsBothRadiMustBeGr, [5]));\r\n Exit;\r\n end;\r\n da1 := 2 * pi / 36;\r\n da0 := R1 / r0 * da1;\r\n a0 := 0;\r\n a1 := 0;\r\n Canvas.MoveTo(xs + r0 + R1, ys);\r\n for i := 1 to 36 * NSpiro do\r\n begin\r\n X1 := R1 * Cos(a1);\r\n Y1 := R1 * Sin(a1);\r\n a1 := a1 + da1;\r\n X0 := r0 * Cos(a0);\r\n Y0 := r0 * Sin(a0);\r\n a0 := a0 + da0;\r\n X := Variant(xs + X0 + X1);\r\n Y := Variant(ys + Y0 + Y1);\r\n Canvas.LineTo(X, Y)\r\n end;\r\nend;\r\n\r\nprocedure TJvDrawImage.Star(X, Y: Integer);\r\nvar\r\n i, X0, Y0, damult: Integer;\r\n apoint: TPoint;\r\n da: Real;\r\nbegin\r\n X0 := myorigin.X;\r\n Y0 := myorigin.Y;\r\n//777 d := Abs(Y - Y0);\r\n damult := 1;\r\n if not PolygonChecked then\r\n begin\r\n case StarPoints of\r\n 5: damult := 2;\r\n 7: damult := 3;\r\n 9: damult := 4;\r\n 11: damult := 5;\r\n end;\r\n end;\r\n da := damult * 2 * pi / StarPoints;\r\n with Canvas do\r\n begin\r\n pointarray[0] := Point(X, Y);\r\n // MoveTo(X,Y);\r\n apoint := Point(X, Y);\r\n for i := 1 to StarPoints - 1 do\r\n begin\r\n // apoint:=Rotate(Point(X0,Y0),apoint,da);\r\n // LineTo(apoint.X,apoint.Y);\r\n apoint := Rotate(Point(X0, Y0), apoint, da);\r\n pointarray[i] := apoint;\r\n end;\r\n // LineTo(X,Y);\r\n Polygon(Slice(PointArray, StarPoints))\r\n end;\r\nend;\r\n\r\nfunction TJvDrawImage.ReduceVector(Origin, Endpoint: TPoint;\r\n Factor: Real): TPoint;\r\nvar\r\n a, d, r: Real;\r\nbegin\r\n r := Sqrt(Sqr(Endpoint.X - Origin.X) + Sqr(Endpoint.Y - Origin.Y));\r\n d := Endpoint.X - Origin.X;\r\n if (d >= 0) and (d < 0.001) then\r\n d := 0.001;\r\n if (d < 0) and (d > -0.001) then\r\n d := -0.001;\r\n a := ArcTan2((Endpoint.Y - Origin.Y), d);\r\n r := r * Factor;\r\n Result.X := Origin.X + Variant(r * Cos(a));\r\n Result.Y := Origin.Y + Variant(r * Sin(a));\r\nend;\r\n(*)\r\nprocedure TJvDrawImage.TextRotate(X, Y, Angle: Integer; aText: string;\r\n afont: tfont);\r\nvar\r\n dc: hdc;\r\n fnt: LogFont;\r\n hfnt, hfntPrev: hfont;\r\n i: Integer;\r\n fname, s: string;\r\nbegin\r\n s := aText;\r\n fnt.lfEscapement := Angle * 10;\r\n fnt.lfOrientation := Angle * 10;\r\n if fsbold in afont.Style then\r\n fnt.lfWeight := FW_Bold\r\n else\r\n fnt.lfWeight := FW_NORMAL;\r\n if fsitalic in afont.Style then\r\n fnt.lfItalic := 1\r\n else\r\n fnt.lfItalic := 0;\r\n if fsunderline in afont.Style then\r\n fnt.lfUnderline := 1\r\n else\r\n fnt.lfUnderline := 0;\r\n fnt.lfStrikeOut := 0;\r\n fnt.lfHeight := Abs(afont.Height);\r\n fname := afont.Name;\r\n for i := 1 to length(fname) do\r\n fnt.lffacename[i - 1] := fname[i];\r\n fnt.lfFaceName[length(fname)] := #0;\r\n hfnt := CreateFontIndirect(fnt);\r\n dc := Canvas.handle;\r\n SetBkMode(dc, windows.TRANSPARENT);\r\n SetTextColor(dc, afont.Color);\r\n hfntPrev := SelectObject(dc, hfnt);\r\n //Textout(dc,X,Y,@aText[1],length(aText));\r\n Textout(dc, X, Y, @s[1], length(s));\r\n SelectObject(dc, hfntPrev);\r\n DeleteObject(hfnt);\r\n Repaint;\r\nend;\r\n(*)\r\n(*)\r\nfunction TJvDrawImage.GetAngle(Origin, Endpoint: TPoint): Integer;\r\nvar\r\n a, d: Real;\r\nbegin\r\n// r := Sqrt(Sqr(Endpoint.X - Origin.X) + Sqr(Endpoint.Y - Origin.Y));\r\n d := Endpoint.X - Origin.X;\r\n if (d >= 0) and (d < 0.001) then\r\n d := 0.001;\r\n if (d < 0) and (d > -0.001) then\r\n d := -0.001;\r\n a := ArcTan2((Endpoint.Y - Origin.Y), d);\r\n a := a * 360 / (2 * pi);\r\n Result := Variant(-a);\r\nend;\r\n(*)\r\nprocedure TJvDrawImage.DrawRisingWaveSphere(Color1, Color2: TColor; X1, Y1, X2, Y2: Integer);\r\nvar\r\n t, xcenter, a, ycenter, b: Integer;\r\n R1, G1, B1, R2, G2, B2: Byte;\r\n i, dx, dy, xo, yo, r, bl: Integer;\r\nbegin\r\n Picture.Bitmap.pixelformat := pf24bit;\r\n Clip.Assign(Picture.Bitmap);\r\n Clip.PixelFormat := pf24bit;\r\n if X1 > X2 then\r\n begin\r\n t := X1;\r\n X1 := X2;\r\n X2 := t;\r\n end;\r\n if Y1 > Y2 then\r\n begin\r\n t := Y1;\r\n Y1 := Y2;\r\n Y2 := t;\r\n end;\r\n a := (X2 - X1) div 2;\r\n b := (Y2 - Y1) div 2;\r\n if a > b then\r\n bl := a div (b + 1)\r\n else\r\n bl := b div (a + 1);\r\n\r\n xcenter := X1 + a;\r\n ycenter := Y1 + b;\r\n\r\n dx := (X2 - X1) div bl;\r\n dy := (Y2 - Y1) div bl;\r\n if dx > dy then\r\n begin\r\n a := (dx div 2) * 4 div 5;\r\n ycenter := Y1 + b;\r\n b := a;\r\n end\r\n else\r\n begin\r\n b := (dy div 2) * 4 div 5;\r\n xcenter := X1 + a;\r\n a := b;\r\n end;\r\n Color1 := ColorToRGB(Color1);\r\n R1 := GetRValue(Color1);\r\n G1 := GetGValue(Color1);\r\n B1 := GetBValue(Color1);\r\n Color2 := ColorToRGB(Color2);\r\n R2 := GetRValue(Color2);\r\n G2 := GetGValue(Color2);\r\n B2 := GetBValue(Color2);\r\n for i := 0 to bl - 1 do\r\n begin\r\n if dx > dy then\r\n begin\r\n xo := i * dx + a;\r\n r := Abs(Round(a * Sin(pi * xo / (X2 - X1))));\r\n Sphere(Clip, X1 + xo, r, ycenter, r, R1, G1, B1, R2, G2, B2, True);\r\n end\r\n else\r\n begin\r\n yo := i * dy + b;\r\n r := Abs(Round(b * Sin(pi * yo / (Y2 - Y1) - pi / 2)));\r\n Sphere(Clip, xcenter, r, Y1 + yo, r, R1, G1, B1, R2, G2, B2, True);\r\n end;\r\n end;\r\n Picture.Bitmap.Assign(Clip);\r\nend;\r\n\r\nprocedure TJvDrawImage.DrawWaveSphere(Color1, Color2: TColor; X1, Y1, X2, Y2: Integer);\r\nvar\r\n t, xcenter, a, ycenter, b: Integer;\r\n R1, G1, B1, R2, G2, B2: Byte;\r\n i, dx, dy, xo, yo, r, bl: Integer;\r\nbegin\r\n Picture.Bitmap.pixelformat := pf24bit;\r\n Clip.Assign(Picture.Bitmap);\r\n Clip.PixelFormat := pf24bit;\r\n if X1 > X2 then\r\n begin\r\n t := X1;\r\n X1 := X2;\r\n X2 := t;\r\n end;\r\n if Y1 > Y2 then\r\n begin\r\n t := Y1;\r\n Y1 := Y2;\r\n Y2 := t;\r\n end;\r\n a := (X2 - X1) div 2;\r\n b := (Y2 - Y1) div 2;\r\n if a > b then\r\n bl := a div (b + 1)\r\n else\r\n bl := b div (a + 1);\r\n\r\n xcenter := X1 + a;\r\n ycenter := Y1 + b;\r\n\r\n dx := (X2 - X1) div bl;\r\n dy := (Y2 - Y1) div bl;\r\n if dx > dy then\r\n begin\r\n a := (dx div 2) * 4 div 5;\r\n ycenter := Y1 + b;\r\n b := a;\r\n end\r\n else\r\n begin\r\n b := (dy div 2) * 4 div 5;\r\n xcenter := X1 + a;\r\n a := b;\r\n end;\r\n Color1 := ColorToRGB(Color1);\r\n R1 := GetRValue(Color1);\r\n G1 := GetGValue(Color1);\r\n B1 := GetBValue(Color1);\r\n Color2 := ColorToRGB(Color2);\r\n R2 := GetRValue(Color2);\r\n G2 := GetGValue(Color2);\r\n B2 := GetBValue(Color2);\r\n for i := 0 to bl - 1 do\r\n begin\r\n if dx > dy then\r\n begin\r\n xo := i * dx + a;\r\n r := Abs(Round(a * Sin(pi * xo / (X2 - X1) - pi / 2)));\r\n Sphere(Clip, X1 + xo, r, ycenter, r, R1, G1, B1, R2, G2, B2, True);\r\n end\r\n else\r\n begin\r\n yo := i * dy + b;\r\n r := Abs(Round(b * Sin(pi * yo / (Y2 - Y1) - pi / 2)));\r\n Sphere(Clip, xcenter, r, Y1 + yo, r, R1, G1, B1, R2, G2, B2, True);\r\n end;\r\n end;\r\n Picture.Bitmap.Assign(Clip);\r\nend;\r\n\r\nprocedure TJvDrawImage.DrawDropletSphere(Color1, Color2: TColor; X1, Y1, X2, Y2: Integer);\r\nvar\r\n t, xcenter, a, ycenter, b: Integer;\r\n R1, G1, B1, R2, G2, B2: Byte;\r\n i, dx, dy, bl: Integer;\r\nbegin\r\n Picture.Bitmap.pixelformat := pf24bit;\r\n Clip.Assign(Picture.Bitmap);\r\n Clip.PixelFormat := pf24bit;\r\n if X1 > X2 then\r\n begin\r\n t := X1;\r\n X1 := X2;\r\n X2 := t;\r\n end;\r\n if Y1 > Y2 then\r\n begin\r\n t := Y1;\r\n Y1 := Y2;\r\n Y2 := t;\r\n end;\r\n a := (X2 - X1) div 2;\r\n b := (Y2 - Y1) div 2;\r\n if a > b then\r\n bl := a div (b + 1)\r\n else\r\n bl := b div (a + 1);\r\n\r\n xcenter := X1 + a;\r\n ycenter := Y1 + b;\r\n\r\n dx := (X2 - X1) div bl;\r\n dy := (Y2 - Y1) div bl;\r\n if dx > dy then\r\n begin\r\n a := (dx div 2) * 4 div 5;\r\n ycenter := Y1 + b;\r\n end\r\n else\r\n begin\r\n b := (dy div 2) * 4 div 5;\r\n xcenter := X1 + a;\r\n end;\r\n Color1 := ColorToRGB(Color1);\r\n R1 := GetRValue(Color1);\r\n G1 := GetGValue(Color1);\r\n B1 := GetBValue(Color1);\r\n Color2 := ColorToRGB(Color2);\r\n R2 := GetRValue(Color2);\r\n G2 := GetGValue(Color2);\r\n B2 := GetBValue(Color2);\r\n for i := 0 to bl - 1 do\r\n begin\r\n if dx > dy then\r\n Sphere(Clip, X1 + i * dx + a, a, ycenter, a, R1, G1, B1, R2, G2, B2, True)\r\n else\r\n Sphere(Clip, xcenter, b, Y1 + i * dy + b, b, R1, G1, B1, R2, G2, B2, True);\r\n end;\r\n Picture.Bitmap.Assign(Clip);\r\nend;\r\n\r\nprocedure TJvDrawImage.DrawMultiSphere(Color1, Color2: TColor; X1, Y1, X2, Y2: Integer);\r\nvar\r\n t, xcenter, a, ycenter, b: Integer;\r\n R1, G1, B1, R2, G2, B2: Byte;\r\n i, dx, dy, bl: Integer;\r\nbegin\r\n Picture.Bitmap.pixelformat := pf24bit;\r\n Clip.Assign(Picture.Bitmap);\r\n Clip.PixelFormat := pf24bit;\r\n if X1 > X2 then\r\n begin\r\n t := X1;\r\n X1 := X2;\r\n X2 := t;\r\n end;\r\n if Y1 > Y2 then\r\n begin\r\n t := Y1;\r\n Y1 := Y2;\r\n Y2 := t;\r\n end;\r\n a := (X2 - X1) div 2;\r\n b := (Y2 - Y1) div 2;\r\n xcenter := X1 + a;\r\n ycenter := Y1 + b;\r\n if a > b then\r\n bl := a div (b + 1)\r\n else\r\n bl := b div (a + 1);\r\n dx := (X2 - X1) div bl;\r\n dy := (Y2 - Y1) div bl;\r\n if dx > dy then\r\n begin\r\n a := dx div 2;\r\n ycenter := Y1 + b;\r\n end\r\n else\r\n begin\r\n b := dy div 2;\r\n xcenter := X1 + a;\r\n end;\r\n Color1 := ColorToRGB(Color1);\r\n R1 := GetRValue(Color1);\r\n G1 := GetGValue(Color1);\r\n B1 := GetBValue(Color1);\r\n Color2 := ColorToRGB(Color2);\r\n R2 := GetRValue(Color2);\r\n G2 := GetGValue(Color2);\r\n B2 := GetBValue(Color2);\r\n for i := 0 to bl - 1 do\r\n begin\r\n if dx > dy then\r\n Sphere(Clip, X1 + i * dx + a, a, ycenter, a, R1, G1, B1, R2, G2, B2, True)\r\n else\r\n Sphere(Clip, xcenter, b, Y1 + i * dy + b, b, R1, G1, B1, R2, G2, B2, True);\r\n end;\r\n Picture.Bitmap.Assign(Clip);\r\nend;\r\n\r\nprocedure TJvDrawImage.Sphere(Bitmap: TBitmap;\r\n xcenter, a, ycenter, b: Integer; R1, G1, B1, R2, G2, B2: Byte; Smooth: Boolean);\r\nvar (* Dessine un disque Color *)\r\n xx, yy: Integer; (* par remplissage avec Couleur1-2 *)\r\n compt, x_ll, y_ll, x_ray, y_ray: Longint;\r\nbegin\r\n xx := 0;\r\n yy := b;\r\n x_ray := 2 * a * a;\r\n y_ray := 2 * b * b;\r\n x_ll := 1;\r\n y_ll := x_ray * b - 1;\r\n compt := y_ll div 2;\r\n while yy >= 0 do\r\n begin\r\n HorGradientLine(Bitmap, xcenter - xx, xcenter + xx, ycenter + yy, R1, G1, B1, R2, G2, B2, Smooth);\r\n HorGradientLine(Bitmap, xcenter - xx, xcenter + xx, ycenter - yy, R1, G1, B1, R2, G2, B2, Smooth);\r\n if compt >= 0 then\r\n begin\r\n x_ll := x_ll + y_ray;\r\n compt := compt - x_ll - 1;\r\n xx := xx + 1;\r\n end;\r\n if compt < 0 then\r\n begin\r\n y_ll := y_ll - x_ray;\r\n compt := compt + y_ll - 1;\r\n yy := yy - 1;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvDrawImage.DrawSphere(Color1, Color2: TColor; X1, Y1, X2, Y2: Integer);\r\nvar\r\n t, xcenter, a, ycenter, b: Integer;\r\n R1, G1, B1, R2, G2, B2: Byte;\r\nbegin\r\n Picture.Bitmap.pixelformat := pf24bit;\r\n Clip.Assign(Picture.Bitmap);\r\n Clip.PixelFormat := pf24bit;\r\n if X1 > X2 then\r\n begin\r\n t := X1;\r\n X1 := X2;\r\n X2 := t;\r\n end;\r\n if Y1 > Y2 then\r\n begin\r\n t := Y1;\r\n Y1 := Y2;\r\n Y2 := t;\r\n end;\r\n a := ((X2 - X1) div 2);\r\n xcenter := X1 + a;\r\n b := ((Y2 - Y1) div 2);\r\n ycenter := Y1 + b;\r\n Color1 := ColorToRGB(Color1);\r\n R1 := GetRValue(Color1);\r\n G1 := GetGValue(Color1);\r\n B1 := GetBValue(Color1);\r\n Color2 := ColorToRGB(Color2);\r\n R2 := GetRValue(Color2);\r\n G2 := GetGValue(Color2);\r\n B2 := GetBValue(Color2);\r\n Sphere(Clip, xcenter, a, ycenter, b, R1, G1, B1, R2, G2, B2, True);\r\n Picture.Bitmap.Assign(Clip);\r\nend;\r\n\r\nprocedure TJvDrawImage.Column(Bitmap: TBitmap; XOrigin, XFinal, YOrigin, YFinal: Integer; R1, G1, B1, R2, G2, B2: Byte; Smooth: Boolean);\r\nvar\r\n j: Integer;\r\nbegin\r\n for j := YOrigin to YFinal do\r\n HorGradientLine(Bitmap, XOrigin, XFinal, j, R1, G1, B1, R2, G2, B2, Smooth);\r\nend;\r\n\r\nprocedure TJvDrawImage.DrawColumn(X1, Y1, X2, Y2: Integer);\r\nvar\r\n t: Integer;\r\n R1, G1, B1, R2, G2, B2: Byte;\r\n line: pbytearray;\r\nbegin\r\n Picture.Bitmap.pixelformat := pf24bit;\r\n Clip.Assign(Picture.Bitmap);\r\n Clip.PixelFormat := pf24bit;\r\n if X1 > X2 then\r\n begin\r\n t := X1;\r\n X1 := X2;\r\n X2 := t;\r\n end;\r\n if Y1 > Y2 then\r\n begin\r\n t := Y1;\r\n Y1 := Y2;\r\n Y2 := t;\r\n end;\r\n line := Clip.ScanLine[Y1];\r\n R1 := line[0];\r\n G1 := line[1];\r\n B1 := line[2];\r\n line := Clip.ScanLine[Y2];\r\n R2 := line[X2 * 3];\r\n G2 := line[X2 * 3 + 1];\r\n B2 := line[X2 * 3 + 2];\r\n Column(Clip, X1, X2, Y1, Y2, R1, G1, B1, R2, G2, B2, True);\r\n Picture.Bitmap.Assign(Clip);\r\nend;\r\n\r\nprocedure TJvDrawImage.InterpolateRect(Bmp: TBitmap; X1, Y1, X2, Y2: Integer);\r\n// Draws rectangle, which will have different Color in each corner and\r\n// will blend from one Color to another\r\n// ( c[0,0] c[1,0]\r\n// c[0,1] c[1,1] )\r\ntype\r\n TFColor = record b, g, r: Byte\r\n end;\r\nvar\r\n xCount, yCount,\r\n t, t2, z, iz,\r\n rp, rp2, gp,\r\n gp2, bp, bp2,\r\n xx: Integer;\r\n pb: PByteArray;\r\n c00, c10, c01, c11: TFColor;\r\nbegin\r\n t := 0;\r\n t2 := 0;\r\n if X2 < X1 then\r\n begin\r\n t := X2;\r\n X2 := X1;\r\n X1 := t;\r\n end;\r\n if Y2 < Y1 then\r\n begin\r\n t := Y2;\r\n Y2 := Y1;\r\n Y1 := t;\r\n end;\r\n if (X1 < 0) or (Y1 < 0) or (X2 > Bmp.Width - 1) or (Y2 > Bmp.Height - 1) then\r\n Exit;\r\n z := 0;\r\n iz := $100000;\r\n if X2 <> X1 then\r\n t := $100000 div (X2 - X1);\r\n if Y2 <> Y1 then\r\n t2 := $100000 div (Y2 - Y1);\r\n///// dx := X2 - X1;\r\n pb := bmp.ScanLine[Y1];\r\n c00.r := pb[X1 * 3];\r\n c00.g := pb[X1 * 3 + 1];\r\n c00.b := pb[X1 * 3 + 2];\r\n c01.r := pb[X2 * 3];\r\n c01.g := pb[X2 * 3 + 1];\r\n c01.b := pb[X2 * 3 + 2];\r\n pb := bmp.ScanLine[Y2];\r\n c10.r := pb[X1 * 3];\r\n c10.g := pb[X1 * 3 + 1];\r\n c10.b := pb[X1 * 3 + 2];\r\n c11.r := pb[X2 * 3];\r\n c11.g := pb[X2 * 3 + 1];\r\n c11.b := pb[X2 * 3 + 2];\r\n for yCount := Y1 to Y2 do\r\n begin\r\n xx := ((c00.r * iz + c01.r * z) shr 20);\r\n rp := xx shl 20;\r\n rp2 := (((c10.r * iz + c11.r * z) shr 20) - xx) * t;\r\n xx := ((c00.g * iz + c01.g * z) shr 20);\r\n gp := xx shl 20;\r\n gp2 := (((c10.g * iz + c11.g * z) shr 20) - xx) * t;\r\n xx := ((c00.b * iz + c01.b * z) shr 20);\r\n bp := xx shl 20;\r\n bp2 := (((c10.b * iz + c11.b * z) shr 20) - xx) * t;\r\n pb := bmp.ScanLine[ycount];\r\n // pb:=@Bmp.Pixels[yCount,X1];\r\n for xCount := X1 to X2 do\r\n begin\r\n pb[xcount * 3 + 2] := bp shr 20;\r\n Inc(bp, bp2);\r\n pb[xcount * 3 + 1] := gp shr 20;\r\n Inc(gp, gp2);\r\n pb[xcount * 3] := rp shr 20;\r\n Inc(rp, rp2);\r\n end;\r\n Inc(z, t2);\r\n Dec(iz, t2);\r\n end;\r\nend;\r\n\r\nprocedure TJvDrawImage.InterpRect(X1, Y1, X2, Y2: Integer);\r\nbegin\r\n Picture.Bitmap.pixelformat := pf24bit;\r\n Clip.Assign(Picture.Bitmap);\r\n Clip.PixelFormat := pf24bit;\r\n Interpolaterect(Clip, X1, Y1, X2, Y2);\r\n Picture.Bitmap.Assign(Clip);\r\nend;\r\n\r\nprocedure TJvDrawImage.DrawBlurLines(X0, Y0, X, Y: Integer);\r\nbegin\r\n DrawTexLines(X0, Y0, X, Y);\r\n ClipAll;\r\n Clip.PixelFormat := pf24bit;\r\n //GaussianBlur(4);\r\n UserFilter := Blurfilter;\r\n applyfilter(Clip, UserFilter);\r\n Picture.Bitmap.Assign(Clip);\r\nend;\r\n\r\nprocedure TJvDrawImage.DrawBlurRects(X0, Y0, X, Y: Integer);\r\nbegin\r\n DrawTexRects(X0, Y0, X, Y);\r\n ClipAll;\r\n Clip.PixelFormat := pf24bit;\r\n FX.GaussianBlur(Clip, 4);\r\n UserFilter := Blurfilter;\r\n applyfilter(Clip, UserFilter);\r\n Picture.Bitmap.Assign(Clip);\r\nend;\r\n\r\nprocedure TJvDrawImage.DrawTexRects(X0, Y0, X, Y: Integer);\r\nvar\r\n dx, dy, xr, yr, X1, Y1, X2, Y2, i, w, h, xi, yi: Integer;\r\n bcolor, pcolor, hcolor, scolor: TColor;\r\nbegin\r\n w := Width;\r\n h := Height;\r\n pcolor := Canvas.Pen.Color;\r\n bcolor := Canvas.Brush.Color;\r\n Canvas.Brush.Color := pcolor;\r\n Canvas.Brush.Style := bssolid;\r\n hcolor := Texhighlight(pcolor);\r\n scolor := TexShadow(pcolor);\r\n xr := Abs(Round(Sqrt(Sqr(X - X0) + Sqr(Y - Y0))));\r\n dx := Abs(X - X0);\r\n dy := Abs(Y - Y0);\r\n if dy < 3 then\r\n dy := 3;\r\n if dx < 3 then\r\n dx := 3;\r\n// tx := w div dx;\r\n// ty := h div dy;\r\n yr := Round(dy / dx * xr);\r\n yi := 0;\r\n repeat\r\n xi := 0;\r\n repeat\r\n for i := 1 to 3 do\r\n with Canvas do\r\n begin\r\n X1 := xi + random(xr);\r\n Y1 := yi + random(yr);\r\n X2 := xi + random(xr);\r\n Y2 := yi + random(yr);\r\n Pen.Color := scolor;\r\n Brush.Color := scolor;\r\n Rectangle(X1, Y1, X2 + 2, Y2 + 2);\r\n Pen.Color := hcolor;\r\n Brush.Color := hcolor;\r\n Rectangle(X1 - 2, Y1 - 2, X2, Y2);\r\n Pen.Color := pcolor;\r\n Brush.Color := pcolor;\r\n Rectangle(X1, Y1, X2, Y2);\r\n end;\r\n inc(xi, dx);\r\n until xi > w - 1;\r\n inc(yi, dy);\r\n until yi > h - 1;\r\n Canvas.Pen.Color := pcolor;\r\n Canvas.Brush.Color := bcolor;\r\nend;\r\n\r\nprocedure TJvDrawImage.DrawBlurPoly(X0, Y0, X, Y: Integer);\r\nbegin\r\n DrawTexPoly(X0, Y0, X, Y);\r\n ClipAll;\r\n Clip.PixelFormat := pf24bit;\r\n //GaussianBlur(4);\r\n UserFilter := Blurfilter;\r\n applyfilter(Clip, UserFilter);\r\n Picture.Bitmap.Assign(Clip);\r\nend;\r\n\r\nprocedure TJvDrawImage.DrawTexPoly(X0, Y0, X, Y: Integer);\r\nvar\r\n dx, dy, xr, yr, X1, Y1, X2, Y2, i, w, h, xi, yi: Integer;\r\n pcolor: TColor;\r\n points: array[0..3] of TPoint;\r\nbegin\r\n w := Width;\r\n h := Height;\r\n pcolor := Canvas.Pen.Color;\r\n// hcolor := Texhighlight(pcolor);\r\n// scolor := TexShadow(pcolor);\r\n xr := Abs(Round(Sqrt(Sqr(X - X0) + Sqr(Y - Y0))));\r\n dx := Abs(X - X0);\r\n dy := Abs(Y - Y0);\r\n if dy < 3 then\r\n dy := 3;\r\n if dx < 3 then\r\n dx := 3;\r\n// tx := w div dx;\r\n// ty := h div dy;\r\n yr := Round(dy / dx * xr);\r\n yi := 0;\r\n repeat\r\n xi := 0;\r\n repeat\r\n for i := 1 to 10 do\r\n with Canvas do\r\n begin\r\n X1 := xi + random(xr);\r\n Y1 := yi + random(yr);\r\n X2 := xi + random(xr);\r\n Y2 := yi + random(yr);\r\n points[0] := Point(X1, Y1);\r\n points[3] := Point(X2, Y2);\r\n X1 := xi + random(xr);\r\n Y1 := yi + random(yr);\r\n X2 := xi + random(xr);\r\n Y2 := yi + random(yr);\r\n points[1] := Point(X1, Y1);\r\n points[2] := Point(X2, Y2);\r\n Pen.Color := pcolor;\r\n polyline(points);\r\n end;\r\n inc(xi, dx);\r\n until xi > w - 1;\r\n inc(yi, dy);\r\n until yi > h - 1;\r\n Canvas.Pen.Color := pcolor;\r\nend;\r\n\r\nprocedure TJvDrawImage.DrawBlurCurves(X0, Y0, X, Y: Integer);\r\nbegin\r\n DrawTexCurves(X0, Y0, X, Y);\r\n ClipAll;\r\n Clip.PixelFormat := pf24bit;\r\n //GaussianBlur(4);\r\n UserFilter := Blurfilter;\r\n applyfilter(Clip, UserFilter);\r\n Picture.Bitmap.Assign(Clip);\r\nend;\r\n\r\nprocedure TJvDrawImage.DrawTexCurves(X0, Y0, X, Y: Integer);\r\nvar\r\n dx, dy, xr, yr, X1, Y1, X2, Y2, i, w, h, xi, yi: Integer;\r\n pcolor: TColor;\r\n points: array[0..3] of TPoint;\r\nbegin\r\n w := Width;\r\n h := Height;\r\n pcolor := Canvas.Pen.Color;\r\n// hcolor := Texhighlight(pcolor);\r\n// scolor := TexShadow(pcolor);\r\n xr := Abs(Round(Sqrt(Sqr(X - X0) + Sqr(Y - Y0))));\r\n dx := Abs(X - X0);\r\n dy := Abs(Y - Y0);\r\n if dy < 3 then\r\n dy := 3;\r\n if dx < 3 then\r\n dx := 3;\r\n// tx := w div dx;\r\n// ty := h div dy;\r\n yr := Round(dy / dx * xr);\r\n yi := 0;\r\n repeat\r\n xi := 0;\r\n repeat\r\n for i := 1 to 10 do\r\n with Canvas do\r\n begin\r\n X1 := xi + random(xr);\r\n Y1 := yi + random(yr);\r\n X2 := xi + random(xr);\r\n Y2 := yi + random(yr);\r\n points[0] := Point(X1, Y1);\r\n points[3] := Point(X2, Y2);\r\n X1 := xi + random(xr);\r\n Y1 := yi + random(yr);\r\n X2 := xi + random(xr);\r\n Y2 := yi + random(yr);\r\n points[1] := Point(X1, Y1);\r\n points[2] := Point(X2, Y2);\r\n Pen.Color := pcolor;\r\n PolyBezier(points);\r\n end;\r\n inc(xi, dx);\r\n until xi > w - 1;\r\n inc(yi, dy);\r\n until yi > h - 1;\r\n Canvas.Pen.Color := pcolor;\r\nend;\r\n\r\nprocedure TJvDrawImage.ApplyFilter(var Dst: TBitmap; DF: TDigitalFilter);\r\nvar\r\n i, j, X, Y, tmpx, tmpy: Integer;\r\n Sum,\r\n Red,\r\n Green,\r\n Blue: Integer; //total value\r\n Tmp,\r\n Color: TFColor;\r\n Ptmp, Pcolor: pbytearray;\r\n bm: TBitmap;\r\n R: TRect;\r\nbegin\r\n bm := TBitmap.Create;\r\n bm.pixelformat := pf24bit;\r\n bm.Width := Dst.Width;\r\n bm.Height := Dst.Height;\r\n R := Rect(0, 0, bm.Width, bm.Height);\r\n bm.Canvas.CopyRect(R, Dst.Canvas, R);\r\n sum := 0;\r\n for Y := 0 to 4 do\r\n for X := 0 to 4 do\r\n sum := sum + DF[X, Y];\r\n if Sum = 0 then\r\n Sum := 1;\r\n for Y := 0 to Dst.Height - 1 do\r\n begin\r\n Pcolor := Dst.ScanLine[Y];\r\n for X := 0 to bm.Width - 1 do\r\n begin\r\n Red := 0;\r\n Green := 0;\r\n Blue := 0;\r\n for i := 0 to 4 do\r\n for j := 0 to 4 do\r\n begin\r\n Tmpy := TrimInt(Y + j - 2, 0, bm.Height - 1);\r\n Tmpx := TrimInt(X + i - 2, 0, bm.Width - 1);\r\n ptmp := bm.ScanLine[Tmpy];\r\n Tmp.r := ptmp[tmpx * 3];\r\n Tmp.g := ptmp[tmpx * 3 + 1];\r\n Tmp.b := ptmp[tmpx * 3 + 2];\r\n // Tmp:=@Dst.Pixels[TrimInt(Y+j-1,0,Dst.Height-1),\r\n // TrimInt(X+i-1,0,Dst.Width-1)];\r\n Inc(Blue, DF[i, j] * Tmp.b);\r\n Inc(Green, DF[i, j] * Tmp.g);\r\n Inc(Red, DF[i, j] * Tmp.r);\r\n end;\r\n Color.b := IntToByte(Blue div Sum);\r\n Color.g := IntToByte(Green div Sum);\r\n Color.r := IntToByte(Red div Sum);\r\n PColor[X * 3] := Color.r;\r\n Pcolor[X * 3 + 1] := Color.g;\r\n Pcolor[X * 3 + 2] := Color.b;\r\n end;\r\n end;\r\n bm.Free;\r\nend;\r\n\r\nprocedure TJvDrawImage.DrawBlurOvals(X0, Y0, X, Y: Integer);\r\nbegin\r\n DrawTexOvals(X0, Y0, X, Y);\r\n ClipAll;\r\n Clip.PixelFormat := pf24bit;\r\n FX.GaussianBlur(Clip, 4);\r\n UserFilter := Blurfilter;\r\n applyfilter(Clip, UserFilter);\r\n Picture.Bitmap.Assign(Clip);\r\n\r\nend;\r\n\r\nprocedure TJvDrawImage.DrawTexOvals(X0, Y0, X, Y: Integer);\r\nvar\r\n dx, dy, xr, yr, X1, Y1, X2, Y2, i, w, h, xi, yi: Integer;\r\n bcolor, pcolor, hcolor, scolor: TColor;\r\nbegin\r\n w := Width;\r\n h := Height;\r\n pcolor := Canvas.Pen.Color;\r\n bcolor := Canvas.Brush.Color;\r\n Canvas.Brush.Color := pcolor;\r\n Canvas.Brush.Style := bssolid;\r\n hcolor := Texhighlight(pcolor);\r\n scolor := TexShadow(pcolor);\r\n xr := Abs(Round(Sqrt(Sqr(X - X0) + Sqr(Y - Y0))));\r\n dx := Abs(X - X0);\r\n dy := Abs(Y - Y0);\r\n if dy < 3 then\r\n dy := 3;\r\n if dx < 3 then\r\n dx := 3;\r\n// tx := w div dx;\r\n// ty := h div dy;\r\n yr := Round(dy / dx * xr);\r\n yi := 0;\r\n repeat\r\n xi := 0;\r\n repeat\r\n for i := 1 to 3 do\r\n with Canvas do\r\n begin\r\n X1 := xi + random(xr);\r\n Y1 := yi + random(yr);\r\n X2 := xi + random(xr);\r\n Y2 := yi + random(yr);\r\n Pen.Color := scolor;\r\n Brush.Color := scolor;\r\n Ellipse(X1, Y1, X2 + 2, Y2 + 2);\r\n Pen.Color := hcolor;\r\n Brush.Color := hcolor;\r\n Ellipse(X1 - 2, Y1 - 2, X2, Y2);\r\n Pen.Color := pcolor;\r\n Brush.Color := pcolor;\r\n Ellipse(X1, Y1, X2, Y2);\r\n end;\r\n inc(xi, dx);\r\n until xi > w - 1;\r\n inc(yi, dy);\r\n until yi > h - 1;\r\n Canvas.Pen.Color := pcolor;\r\n Canvas.Brush.Color := bcolor;\r\nend;\r\n\r\nfunction TJvDrawImage.BlendColors(const Color1, Color2: Longint; Opacity: Integer): Longint;\r\nvar\r\n R, R1, R2, G, G1, G2, B, B1, B2: Integer;\r\nbegin\r\n Opacity := Abs(Opacity);\r\n if Opacity > 100 then\r\n Opacity := 100;\r\n R1 := GetRValue(ColorToRGB(Color1));\r\n G1 := GetGValue(ColorToRGB(Color1));\r\n B1 := GetBValue(ColorToRGB(Color1));\r\n R2 := GetRValue(ColorToRGB(Color2));\r\n G2 := GetGValue(ColorToRGB(Color2));\r\n B2 := GetBValue(ColorToRGB(Color2));\r\n R := trunc(R1 * Opacity / 100) + trunc(R2 * (100 - Opacity) / 100);\r\n G := trunc(G1 * Opacity / 100) + trunc(G2 * (100 - Opacity) / 100);\r\n B := trunc(B1 * Opacity / 100) + trunc(B2 * (100 - Opacity) / 100);\r\n Result := RGB(R, G, B);\r\nend; { BlendColors }\r\n\r\nfunction TJvDrawImage.TexHighlight(Colr: Longint): Longint;\r\nvar\r\n avg, r, g, b: Integer;\r\n tmp: Longint;\r\nbegin\r\n r := GetRValue(Colr);\r\n g := GetGValue(Colr);\r\n b := GetBValue(Colr);\r\n avg := (r + g + b) div 3;\r\n r := (255 + 255 + avg + r) div 4;\r\n g := (255 + 255 + avg + g) div 4;\r\n b := (255 + 255 + avg + b) div 4;\r\n tmp := RGB(r, g, b);\r\n Result := BlendColors(Colr, tmp, WeakBlend);\r\nend; { Highlight }\r\n\r\nfunction TJvDrawImage.TexShadow(Colr: Longint): Longint;\r\nvar\r\n r, g, b: Integer;\r\n tmp: Longint;\r\nbegin\r\n r := GetRValue(Colr);\r\n g := GetGValue(Colr);\r\n b := GetBValue(Colr);\r\n tmp := RGB(trunc(DarkStrength * r), trunc(DarkStrength * g),\r\n trunc(DarkStrength * b));\r\n Result := BlendColors(Colr, tmp, StrongBlend);\r\nend; { Shadow }\r\n\r\nprocedure TJvDrawImage.DrawTexLines(X0, Y0, X, Y: Integer);\r\nvar\r\n dx, dy, xr, yr, X1, Y1, X2, Y2, i, w, h, xi, yi: Integer;\r\n pcolor, hcolor, scolor: TColor;\r\nbegin\r\n w := Width;\r\n h := Height;\r\n pcolor := Canvas.Pen.Color;\r\n hcolor := Texhighlight(pcolor);\r\n scolor := TexShadow(pcolor);\r\n xr := Abs(Round(Sqrt(Sqr(X - X0) + Sqr(Y - Y0))));\r\n dx := Abs(X - X0);\r\n dy := Abs(Y - Y0);\r\n if dy = 0 then\r\n dy := 1;\r\n if dx = 0 then\r\n dx := 1;\r\n// tx := w div dx;\r\n// ty := h div dy;\r\n yr := Round(dy / dx * xr);\r\n yi := 0;\r\n repeat\r\n xi := 0;\r\n repeat\r\n for i := 1 to 10 do\r\n with Canvas do\r\n begin\r\n X1 := xi + random(xr);\r\n Y1 := yi + random(yr);\r\n X2 := xi + random(xr);\r\n Y2 := yi + random(yr);\r\n Pen.Color := pcolor;\r\n MoveTo(X1, Y1);\r\n LineTo(X2, Y2);\r\n Pen.Color := hcolor;\r\n MoveTo(X1 - 1, Y1 - 1);\r\n LineTo(X2 - 1, Y2 - 1);\r\n Pen.Color := scolor;\r\n MoveTo(X1 + 1, Y1 + 1);\r\n LineTo(X2 + 1, Y2 + 1);\r\n end;\r\n inc(xi, dx);\r\n until xi > w - 1;\r\n inc(yi, dy);\r\n until yi > h - 1;\r\n Canvas.Pen.Color := pcolor;\r\nend;\r\n\r\nprocedure TJvDrawImage.DrawSyms(X, Y: Integer);\r\nvar\r\n X0, Y0, i: Integer;\r\n da: Real;\r\n apoint: TPoint;\r\nbegin\r\n X0 := Picture.Bitmap.Width div 2;\r\n Y0 := Picture.Bitmap.Height div 2;\r\n da := 2 * pi / StarPoints;\r\n apoint := Point(X, Y);\r\n for i := 0 to StarPoints - 1 do\r\n begin\r\n with Canvas do\r\n begin\r\n MoveTo(pointarray[i].X, pointarray[i].Y);\r\n LineTo(apoint.X, apoint.Y);\r\n pointarray[i] := apoint;\r\n apoint := Rotate(Point(X0, Y0), apoint, da);\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvDrawImage.PutClip(M: TRect);\r\nvar\r\n dest: TRect;\r\nbegin\r\n Clip.Width := (m.Right - m.Left + 1);\r\n Clip.Height := (m.Bottom - m.Top + 1);\r\n dest := Rect(0, 0, Clip.Width, Clip.Height);\r\n Clip.Canvas.CopyMode := cmsrccopy;\r\n Clip.pixelformat := Picture.Bitmap.pixelformat;\r\n Clip.Canvas.CopyRect(dest, Canvas, m);\r\nend;\r\n\r\nprocedure TJvDrawImage.DrawTriangle;\r\nbegin\r\n with Canvas do\r\n begin\r\n MoveTo(myskew[0].X, myskew[0].Y);\r\n LineTo(myskew[1].X, myskew[1].Y);\r\n LineTo(myskew[2].X, myskew[2].Y);\r\n LineTo(myskew[0].X, myskew[0].Y);\r\n end;\r\nend;\r\n\r\nprocedure TJvDrawImage.DrawSkew;\r\nbegin\r\n with Canvas do\r\n begin\r\n MoveTo(myskew[0].X, myskew[0].Y);\r\n LineTo(myskew[1].X, myskew[1].Y);\r\n LineTo(myskew[2].X, myskew[2].Y);\r\n LineTo(myskew[3].X, myskew[3].Y);\r\n LineTo(myskew[0].X, myskew[0].Y);\r\n end;\r\nend;\r\n\r\nfunction TJvDrawImage.PointToBlock(X, Y: Integer): TRect;\r\nvar\r\n xb, yb, w, h: Integer;\r\nbegin\r\n w := Picture.Bitmap.Width;\r\n h := Picture.Bitmap.Height;\r\n xb := w div Blocks;\r\n yb := h div Blocks;\r\n Result.Left := (X div xb) * xb;\r\n Result.Top := (Y div yb) * yb;\r\n Result.Right := Result.Left + xb;\r\n Result.Bottom := Result.Top + yb;\r\nend;\r\n\r\nprocedure TJvDrawImage.DrawCube;\r\nvar\r\n dx, dy: Integer;\r\nbegin\r\n with Canvas do\r\n begin\r\n dx := myskew[4].X - myskew[2].X;\r\n dy := myskew[4].Y - myskew[2].Y;\r\n MoveTo(myskew[0].X, myskew[0].Y);\r\n LineTo(myskew[1].X, myskew[1].Y);\r\n LineTo(myskew[2].X, myskew[2].Y);\r\n LineTo(myskew[3].X, myskew[3].Y);\r\n LineTo(myskew[0].X, myskew[0].Y);\r\n if (dx >= 0) and (dy <= 0) then\r\n begin\r\n MoveTo(myskew[0].X, myskew[0].Y);\r\n LineTo(myskew[0].X + dx, myskew[0].Y + dy);\r\n LineTo(myskew[1].X + dx, myskew[1].Y + dy);\r\n LineTo(myskew[2].X + dx, myskew[2].Y + dy);\r\n LineTo(myskew[2].X, myskew[2].Y);\r\n MoveTo(myskew[1].X, myskew[1].Y);\r\n LineTo(myskew[1].X + dx, myskew[1].Y + dy);\r\n end\r\n else\r\n if (dx >= 0) and (dy > 0) then\r\n begin\r\n MoveTo(myskew[1].X, myskew[1].Y);\r\n LineTo(myskew[1].X + dx, myskew[1].Y + dy);\r\n LineTo(myskew[2].X + dx, myskew[2].Y + dy);\r\n LineTo(myskew[3].X + dx, myskew[3].Y + dy);\r\n LineTo(myskew[3].X, myskew[3].Y);\r\n MoveTo(myskew[2].X, myskew[2].Y);\r\n LineTo(myskew[2].X + dx, myskew[2].Y + dy);\r\n end\r\n else\r\n if (dx < 0) and (dy > 0) then\r\n begin\r\n MoveTo(myskew[0].X, myskew[0].Y);\r\n LineTo(myskew[0].X + dx, myskew[0].Y + dy);\r\n LineTo(myskew[3].X + dx, myskew[3].Y + dy);\r\n LineTo(myskew[2].X + dx, myskew[2].Y + dy);\r\n LineTo(myskew[2].X, myskew[2].Y);\r\n MoveTo(myskew[3].X, myskew[3].Y);\r\n LineTo(myskew[3].X + dx, myskew[3].Y + dy);\r\n end\r\n else\r\n if (dx < 0) and (dy < 0) then\r\n begin\r\n MoveTo(myskew[1].X, myskew[1].Y);\r\n LineTo(myskew[1].X + dx, myskew[1].Y + dy);\r\n LineTo(myskew[0].X + dx, myskew[0].Y + dy);\r\n LineTo(myskew[3].X + dx, myskew[3].Y + dy);\r\n LineTo(myskew[3].X, myskew[3].Y);\r\n MoveTo(myskew[0].X, myskew[0].Y);\r\n LineTo(myskew[0].X + dx, myskew[0].Y + dy);\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvDrawImage.VerGradientLine(Bitmap: TBitmap;\r\n YOrigin, YFinal, X: Integer; R1, G1, B1, R2, G2, B2: Byte; Smooth: Boolean);\r\nvar\r\n r, g, b, i: Integer;\r\n valueR, ValueG, ValueB, advalR, advalB, advalG: single;\r\n Line: PByteArray;\r\nbegin\r\n if (X >= 0) and (X < Bitmap.Width) then\r\n begin\r\n if YOrigin > YFinal then\r\n begin\r\n i := YOrigin;\r\n YOrigin := YFinal;\r\n YFinal := i;\r\n end;\r\n if YFinal <> YOrigin then\r\n begin\r\n advalR := (R2 - R1) / (YFinal - YOrigin);\r\n advalG := (G2 - G1) / (YFinal - YOrigin);\r\n advalB := (B2 - B1) / (YFinal - YOrigin);\r\n end\r\n else\r\n begin\r\n advalR := 0;\r\n advalG := 0;\r\n advalB := 0;\r\n end;\r\n\r\n valueR := R1;\r\n valueG := G1;\r\n valueB := B1;\r\n\r\n for i := YOrigin to YFinal do\r\n begin\r\n Line := Bitmap.ScanLine[i];\r\n valueR := valueR + advalR;\r\n r := Round(ValueR);\r\n if r > 255 then\r\n r := 255;\r\n if r < 0 then\r\n r := 0;\r\n valueG := valueG + advalG;\r\n g := Round(ValueG);\r\n if g > 255 then\r\n g := 255;\r\n if g < 0 then\r\n g := 0;\r\n valueB := valueB + advalB;\r\n b := Round(ValueB);\r\n if b > 255 then\r\n b := 255;\r\n if b < 0 then\r\n b := 0;\r\n if (X >= 0) and (X < Bitmap.Width) then\r\n begin\r\n Line[X * 3] := b;\r\n Line[X * 3 + 1] := g;\r\n Line[X * 3 + 2] := r;\r\n end;\r\n end;\r\n if Smooth then\r\n begin\r\n SmoothPnt(Bitmap, X, YOrigin - 1);\r\n SmoothPnt(Bitmap, X, YFinal + 1);\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvDrawImage.DrawVGradientBrush(Color1, Color2: TColor; Y1, Y2, X: Integer);\r\nvar\r\n R1, G1, B1, R2, G2, B2: Byte;\r\nbegin\r\n Picture.Bitmap.pixelformat := pf24bit;\r\n Clip.Assign(Picture.Bitmap);\r\n Clip.PixelFormat := pf24bit;\r\n Color1 := ColorToRGB(Color1);\r\n R1 := GetRValue(Color1);\r\n G1 := GetGValue(Color1);\r\n B1 := GetBValue(Color1);\r\n Color2 := ColorToRGB(Color2);\r\n R2 := GetRValue(Color2);\r\n G2 := GetGValue(Color2);\r\n B2 := GetBValue(Color2);\r\n vergradientline(Clip, Y1, Y2, X, R1, G1, B1, R2, G2, B2, True);\r\n Picture.Bitmap.Assign(Clip);\r\nend;\r\n\r\nprocedure TJvDrawImage.SmoothPnt(Bitmap: TBitmap; xk, yk: Integer);\r\ntype\r\n TFColor = record b, g, r: Byte\r\n end;\r\nvar\r\n Bleu, Vert, Rouge: Integer;\r\n Color: TFColor;\r\n BB, GG, RR: array[1..5] of Integer;\r\n Line: pbytearray;\r\nbegin\r\n if (xk > 0) and (yk > 0) and (xk < Bitmap.Width - 1) and (yk < Bitmap.Height - 1) then\r\n begin\r\n line := Bitmap.ScanLine[yk - 1];\r\n Color.r := line[xk * 3];\r\n Color.g := line[xk * 3 + 1];\r\n Color.b := line[xk * 3 + 2];\r\n RR[1] := Color.r;\r\n GG[1] := Color.g;\r\n BB[1] := Color.b;\r\n line := Bitmap.ScanLine[yk];\r\n Color.r := line[(xk + 1) * 3];\r\n Color.g := line[(xk + 1) * 3 + 1];\r\n Color.b := line[(xk + 1) * 3 + 2];\r\n RR[2] := Color.r;\r\n GG[2] := Color.g;\r\n BB[2] := Color.b;\r\n line := Bitmap.ScanLine[yk + 1];\r\n Color.r := line[xk * 3];\r\n Color.g := line[xk * 3 + 1];\r\n Color.b := line[xk * 3 + 2];\r\n RR[3] := Color.r;\r\n GG[3] := Color.g;\r\n BB[3] := Color.b;\r\n line := Bitmap.ScanLine[yk];\r\n Color.r := line[(xk - 1) * 3];\r\n Color.g := line[(xk - 1) * 3 + 1];\r\n Color.b := line[(xk - 1) * 3 + 2];\r\n RR[4] := Color.r;\r\n GG[4] := Color.g;\r\n BB[4] := Color.b;\r\n Bleu := (BB[1] + (BB[2] + BB[3] + BB[4])) div 4; (* Valeur moyenne *)\r\n Vert := (GG[1] + (GG[2] + GG[3] + GG[4])) div 4; (* en cours d'valuation *)\r\n Rouge := (RR[1] + (RR[2] + RR[3] + RR[4])) div 4;\r\n Color.r := rouge;\r\n Color.g := vert;\r\n Color.b := bleu;\r\n line := Bitmap.ScanLine[yk];\r\n line[xk * 3] := Color.r;\r\n line[xk * 3 + 1] := Color.g;\r\n line[xk * 3 + 2] := Color.b;\r\n end;\r\nend;\r\n\r\nprocedure TJvDrawImage.HorGradientLine(Bitmap: TBitmap;\r\n XOrigin, XFinal, Y: Integer; R1, G1, B1, R2, G2, B2: Byte; Smooth: Boolean);\r\nvar\r\n r, g, b, i: Integer;\r\n valueR, ValueG, ValueB, advalR, advalB, advalG: single;\r\n Line: PByteArray;\r\nbegin\r\n if (Y >= 0) and (Y < Bitmap.Height) then\r\n begin\r\n if XOrigin > XFinal then\r\n begin\r\n i := XOrigin;\r\n XOrigin := XFinal;\r\n XFinal := i;\r\n end;\r\n if XFinal <> XOrigin then\r\n begin\r\n advalR := (R2 - R1) / (XFinal - XOrigin);\r\n advalG := (G2 - G1) / (XFinal - XOrigin);\r\n advalB := (B2 - B1) / (XFinal - XOrigin);\r\n end\r\n else\r\n begin\r\n advalR := 0;\r\n advalG := 0;\r\n advalB := 0;\r\n end;\r\n\r\n valueR := R1;\r\n valueG := G1;\r\n valueB := B1;\r\n Line := Bitmap.ScanLine[Y];\r\n for i := XOrigin to XFinal do\r\n begin\r\n valueR := valueR + advalR;\r\n r := Round(ValueR);\r\n if r > 255 then\r\n r := 255;\r\n if r < 0 then\r\n r := 0;\r\n valueG := valueG + advalG;\r\n g := Round(ValueG);\r\n if g > 255 then\r\n g := 255;\r\n if g < 0 then\r\n g := 0;\r\n valueB := valueB + advalB;\r\n b := Round(ValueB);\r\n if b > 255 then\r\n b := 255;\r\n if b < 0 then\r\n b := 0;\r\n if (i >= 0) and (i < Bitmap.Width) then\r\n begin\r\n Line[i * 3] := b;\r\n Line[i * 3 + 1] := g;\r\n Line[i * 3 + 2] := r;\r\n end;\r\n end;\r\n if Smooth then\r\n begin\r\n SmoothPnt(Bitmap, XOrigin - 1, Y);\r\n SmoothPnt(Bitmap, XFinal + 1, Y);\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvDrawImage.DrawGradientBrush(Color1, Color2: TColor; X1, X2, Y: Integer);\r\nvar\r\n R1, G1, B1, R2, G2, B2: Byte;\r\nbegin\r\n Picture.Bitmap.pixelformat := pf24bit;\r\n Clip.Assign(Picture.Bitmap);\r\n Clip.PixelFormat := pf24bit;\r\n Color1 := ColorToRGB(Color1);\r\n R1 := GetRValue(Color1);\r\n G1 := GetGValue(Color1);\r\n B1 := GetBValue(Color1);\r\n Color2 := ColorToRGB(Color2);\r\n R2 := GetRValue(Color2);\r\n G2 := GetGValue(Color2);\r\n B2 := GetBValue(Color2);\r\n horgradientline(Clip, X1, X2, Y, R1, G1, B1, R2, G2, B2, True);\r\n Picture.Bitmap.Assign(Clip);\r\nend;\r\n\r\nprocedure TJvDrawImage.DrawLighterCircle(X, Y, Mode: Integer);\r\nvar\r\n r: Integer;\r\nbegin\r\n r := Canvas.Pen.Width;\r\n if r < 5 then\r\n r := 5;\r\n ColorCircle(Clip, Point(X, Y), r, Mode);\r\n Picture.Bitmap.Assign(Clip);\r\nend;\r\n\r\nprocedure TJvDrawImage.DrawDarkerCircle(X, Y, Mode: Integer);\r\nvar\r\n r: Integer;\r\nbegin\r\n r := Canvas.Pen.Width;\r\n if r < 5 then\r\n r := 5;\r\n ColorCircle(Clip, Point(X, Y), r, Mode);\r\n Picture.Bitmap.Assign(Clip);\r\n\r\nend;\r\n\r\nprocedure TJvDrawImage.ColorCircle(var bm: TBitmap; center: TPoint; Radius, Mode: Integer);\r\nvar\r\n p, p0, p1: pbytearray;\r\n (*dx, *)X, Y, w, h, i, j, sum, c: Integer;\r\n cm, tm: TBitmap;\r\n Rs, Rd: TRect;\r\nbegin\r\n X := center.X;\r\n Y := center.Y;\r\n w := bm.Width;\r\n h := bm.Height;\r\n cm := TBitmap.Create;\r\n cm.Width := 2 * Radius;\r\n cm.Height := 2 * Radius;\r\n cm.PixelFormat := pf24bit;\r\n tm := TBitmap.Create;\r\n tm.Width := 2 * Radius;\r\n tm.Height := 2 * Radius;\r\n tm.PixelFormat := pf24bit;\r\n tm.Canvas.Brush.Color := clBlack;\r\n tm.Canvas.Ellipse(0, 0, tm.Width - 1, tm.Height - 1);\r\n tm.Transparent := True;\r\n tm.TransparentColor := clBlack;\r\n Rd := Rect(0, 0, cm.Width, cm.Height);\r\n Rs := Rect(X - Radius, Y - Radius, X + Radius, Y + Radius);\r\n cm.Canvas.CopyRect(Rd, bm.Canvas, RS);\r\n p0 := nil;\r\n p1 := nil;\r\n for j := 0 to cm.Height - 1 do\r\n begin\r\n p := cm.ScanLine[j];\r\n if j > 0 then\r\n p0 := cm.ScanLine[j - 1];\r\n if j < (h - 1) then\r\n p1 := cm.ScanLine[j + 1];\r\n for i := 0 to cm.Width - 1 do\r\n begin\r\n case Mode of\r\n 0: //Blue\r\n begin\r\n p[i * 3 + 1] := 0;\r\n p[i * 3 + 2] := 0;\r\n end;\r\n 1: //Green\r\n begin\r\n p[i * 3] := 0;\r\n p[i * 3 + 2] := 0;\r\n end;\r\n 2: //Red\r\n begin\r\n p[i * 3] := 0;\r\n p[i * 3 + 1] := 0;\r\n end;\r\n 3: //not Blue\r\n begin\r\n p[i * 3] := 0;\r\n end;\r\n 4: //not Green\r\n begin\r\n p[i * 3 + 1] := 0;\r\n end;\r\n 5: //not Red\r\n begin\r\n p[i * 3 + 2] := 0;\r\n end;\r\n 6: //half Blue\r\n begin\r\n p[i * 3] := p[i * 3] * 9 div 10;\r\n end;\r\n 7: //half Green\r\n begin\r\n p[i * 3 + 1] := p[i * 3 + 1] * 9 div 10;\r\n end;\r\n 8: //half Red\r\n begin\r\n p[i * 3 + 2] := p[i * 3 + 2] * 9 div 10;\r\n end;\r\n 9: // darker\r\n begin\r\n p[i * 3] := Round(p[i * 3] * 10 / 11);\r\n p[i * 3 + 1] := Round(p[i * 3 + 1] * 10 / 11);\r\n p[i * 3 + 2] := Round(p[i * 3 + 2] * 10 / 11);\r\n end;\r\n 10: // lighter\r\n begin\r\n p[i * 3] := Round(p[i * 3] * 11 / 10);\r\n p[i * 3 + 1] := Round(p[i * 3 + 1] * 11 / 10);\r\n p[i * 3 + 2] := Round(p[i * 3 + 2] * 11 / 10);\r\n end;\r\n 11: // gray\r\n begin\r\n sum := Round((p[i * 3] + p[i * 3 + 1] + p[i * 3 + 2]) / 3);\r\n p[i * 3] := sum;\r\n p[i * 3 + 1] := sum;\r\n p[i * 3 + 2] := sum;\r\n end;\r\n 12: // mix\r\n begin\r\n c := p[i * 3];\r\n p[i * 3] := p[i * 3 + 1];\r\n p[i * 3 + 1] := p[i * 3 + 2];\r\n p[i * 3 + 2] := c;\r\n end;\r\n 13: //Smooth\r\n begin\r\n if ((j > 0) and (j < (h - 1)) and (i > 0) and (i < (w - 1))) then\r\n begin\r\n p[i * 3] := Round((p[(i - 1) * 3] + p[(i + 1) * 3] + p0[i * 3] + p1[i * 3]) / 4);\r\n p[i * 3 + 1] := Round((p[(i - 1) * 3 + 1] + p[(i + 1) * 3 + 1] + p0[i * 3 + 1] + p1[i * 3 + 1]) / 4);\r\n p[i * 3 + 2] := Round((p[(i - 1) * 3 + 2] + p[(i + 1) * 3 + 2] + p0[i * 3 + 2] + p1[i * 3 + 2]) / 4);\r\n end;\r\n end;\r\n end;\r\n end;\r\n end;\r\n cm.Canvas.Draw(0, 0, tm);\r\n cm.Transparent := True;\r\n cm.transparentcolor := clWhite;\r\n bm.Canvas.Draw(X - Radius, Y - Radius, cm);\r\n cm.Free;\r\n tm.Free;\r\nend;\r\n\r\nprocedure TJvDrawImage.DrawColorCircle(X, Y, Mode: Integer);\r\nvar\r\n r: Integer;\r\nbegin\r\n Picture.Bitmap.pixelformat := pf24bit;\r\n Clip.Assign(Picture.Bitmap);\r\n Clip.PixelFormat := pf24bit;\r\n r := Canvas.Pen.Width;\r\n if r < 5 then\r\n r := 5;\r\n ColorCircle(Clip, Point(X, Y), r, Mode);\r\n Picture.Bitmap.Assign(Clip);\r\nend;\r\n\r\nprocedure TJvDrawImage.DrawLightBrush(X, Y, Radius, Amount: Integer; Style: TLightBrush);\r\nvar\r\n Src, Dst: TBitmap;\r\n Rclip, Rsrc: TRect;\r\nbegin\r\n if X < Radius then\r\n X := Radius;\r\n if Y < Radius then\r\n Y := Radius;\r\n if (X + Radius) > Clip.Width - 1 then\r\n X := Clip.Width - 1 - Radius;\r\n if (Y + Radius) > Clip.Height - 1 then\r\n Y := Clip.Height - 1 - Radius;\r\n Src := TBitmap.Create;\r\n Src.PixelFormat := pf24bit;\r\n Dst := TBitmap.Create;\r\n Dst.PixelFormat := pf24bit;\r\n Rclip := Rect(X - Radius, Y - Radius, X + Radius, Y + Radius);\r\n Src.Width := Rclip.Right - Rclip.Left;\r\n Src.Height := RClip.Bottom - Rclip.Top;\r\n Dst.Width := Src.Width;\r\n Dst.Height := Src.Height;\r\n Rsrc := Rect(0, 0, Src.Width, Src.Height);\r\n Dst.Canvas.CopyRect(Rsrc, Clip.Canvas, Rclip);\r\n case Style of\r\n lbBrightness: FX.lightness(Dst, Amount);\r\n lbSaturation: FX.saturation(Dst, Amount);\r\n lbContrast: FX.contrast(Dst, Amount);\r\n end;\r\n // mask code\r\n Src.Canvas.Brush.Color := clWhite;\r\n Src.Canvas.FillRect(Rsrc);\r\n Src.Canvas.Brush.Style := bssolid;\r\n Src.Canvas.Brush.Color := clBlack;\r\n Src.Canvas.Ellipse(0, 0, Src.Width - 1, Src.Height - 1);\r\n Src.Transparent := True;\r\n Src.TransparentColor := clBlack;\r\n Dst.Canvas.Draw(0, 0, Src);\r\n Dst.Transparent := True;\r\n Dst.TransparentColor := clWhite;\r\n Canvas.Draw(0, 0, Clip);\r\n Canvas.Draw(X - Radius, Y - Radius, Dst);\r\n Src.Free;\r\n Dst.Free;\r\nend;\r\n\r\nprocedure TJvDrawImage.SampleStretch(Src, Dst: TBitmap);\r\nbegin\r\n // use mitchelfilter from resample unit\r\n ImgStretch(Src, Dst,\r\n ResampleFilters[6].Filter, ResampleFilters[6].Width);\r\nend;\r\n\r\nprocedure TJvDrawImage.DrawStretchBrush(X, Y, Radius: Integer; Amount: Extended; Style: TMorphBrush);\r\nvar\r\n Src, Dst: TBitmap;\r\n Rclip, Rsrc: TRect;\r\n dr: Integer;\r\nbegin\r\n if X < Radius then\r\n X := Radius;\r\n if Y < Radius then\r\n Y := Radius;\r\n if (X + Radius) > Clip.Width - 1 then\r\n X := Clip.Width - 1 - Radius;\r\n if (Y + Radius) > Clip.Height - 1 then\r\n Y := Clip.Height - 1 - Radius;\r\n Src := TBitmap.Create;\r\n Src.PixelFormat := pf24bit;\r\n Dst := TBitmap.Create;\r\n Dst.PixelFormat := pf24bit;\r\n Rclip := Rect(X - Radius, Y - Radius, X + Radius, Y + Radius);\r\n Dst.Width := Rclip.Right - Rclip.Left;\r\n Dst.Height := RClip.Bottom - Rclip.Top;\r\n // now Change to Reduce\r\n Amount := Abs(Amount);\r\n if Amount < 1 then\r\n Amount := 1;\r\n dr := Round(Radius * Amount / 180);\r\n if dr < 5 then\r\n dr := 5;\r\n if dr > Radius then\r\n dr := Radius;\r\n //(mbVerBox,mbHorBox,mbVerOval,mbHorOval);\r\n case Style of\r\n mbVerOval, mbVerbox: Rclip := Rect(X - Radius, Y - dr, X + Radius, Y + dr);\r\n mbHorOval, mbHorBox: Rclip := Rect(X - dr, Y - Radius, X + dr, Y + Radius);\r\n end;\r\n Src.Width := Rclip.Right - Rclip.Left;\r\n Src.Height := RClip.Bottom - Rclip.Top;\r\n Rsrc := Rect(0, 0, Src.Width, Src.Height);\r\n Src.Canvas.CopyRect(Rsrc, Clip.Canvas, Rclip);\r\n SampleStretch(Src, Dst);\r\n // mask code\r\n // reset Src dimensions for masking\r\n if Style in [mbHorOval, mbVerOval] then\r\n begin\r\n Src.Width := Dst.Width;\r\n Src.Height := Dst.Height;\r\n Src.Canvas.Brush.Color := clWhite;\r\n Src.Canvas.FillRect(Rsrc);\r\n Src.Canvas.Brush.Style := bssolid;\r\n Src.Canvas.Brush.Color := clBlack;\r\n Src.Canvas.Ellipse(0, 0, Src.Width - 1, Src.Height - 1);\r\n Src.Transparent := True;\r\n Src.TransparentColor := clBlack;\r\n Dst.Canvas.Draw(0, 0, Src);\r\n Dst.Transparent := True;\r\n Dst.TransparentColor := clWhite;\r\n Canvas.Draw(0, 0, Clip);\r\n end;\r\n Canvas.Draw(X - Radius, Y - Radius, Dst);\r\n Src.Free;\r\n Dst.Free;\r\nend;\r\n\r\nprocedure TJvDrawImage.Rimple(Src, Dst: TBitmap; Amount: Extended);\r\nvar\r\n ca, sa, a, dx, dy, r, sr, fr: Extended;\r\n w, h, X, Y, cx, cy, i, j, c, ci: Integer;\r\n p1, p2: pbytearray;\r\nbegin\r\n w := Src.Width;\r\n h := Src.Height;\r\n cx := w div 2;\r\n cy := h div 2;\r\n if Amount < 1 then\r\n Amount := 1;\r\n fr := cx / Amount;\r\n for Y := 0 to h - 1 do\r\n begin\r\n p1 := Src.ScanLine[Y];\r\n for X := 0 to w - 1 do\r\n begin\r\n dx := X - cx;\r\n dy := -(Y - cx);\r\n r := Sqrt(Sqr(dx) + Sqr(dy));\r\n sr := fr * Sin(r / cx * Amount * 2 * pi);\r\n if (r + sr < cx) and (r + sr > 0) then\r\n begin\r\n a := ArcTan2(dy, dx);\r\n sincos(a, sa, ca);\r\n i := cx + Round((r + sr) * ca);\r\n j := cy + Round((r + sr) * sa);\r\n p2 := Dst.ScanLine[j];\r\n c := X * 3;\r\n ci := i * 3;\r\n p2[ci] := p1[c];\r\n p2[ci + 1] := p1[c + 1];\r\n p2[ci + 2] := p1[c + 2];\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvDrawImage.DrawEffectBrush(X, Y, Radius: Integer; Amount: Extended; Style: TLightBrush);\r\nvar\r\n Src, Dst: TBitmap;\r\n Rclip, Rsrc: TRect;\r\nbegin\r\n if X < Radius then\r\n X := Radius;\r\n if Y < Radius then\r\n Y := Radius;\r\n if (X + Radius) > Clip.Width - 1 then\r\n X := Clip.Width - 1 - Radius;\r\n if (Y + Radius) > Clip.Height - 1 then\r\n Y := Clip.Height - 1 - Radius;\r\n Src := TBitmap.Create;\r\n Src.PixelFormat := pf24bit;\r\n Dst := TBitmap.Create;\r\n Dst.PixelFormat := pf24bit;\r\n Rclip := Rect(X - Radius, Y - Radius, X + Radius, Y + Radius);\r\n Src.Width := Rclip.Right - Rclip.Left;\r\n Src.Height := RClip.Bottom - Rclip.Top;\r\n Dst.Width := Src.Width;\r\n Dst.Height := Src.Height;\r\n Rsrc := Rect(0, 0, Src.Width, Src.Height);\r\n Src.Canvas.CopyRect(Rsrc, Clip.Canvas, Rclip);\r\n case Style of\r\n lbfisheye: FX.fisheye(Src, Dst, Amount);\r\n lbrotate: FX.smoothrotate(Src, Dst, Src.Width div 2, Src.Height div 2, Amount);\r\n lbtwist: FX.twist(Src, Dst, Round(Amount));\r\n lbrimple: Rimple(Src, Dst, Amount);\r\n mbHor, mbTop, mbBottom, mbDiamond, mbWaste, mbRound, mbRound2:\r\n FX.SqueezeHor(Src, Dst, Round(Amount), Style);\r\n mbSplitRound, mbSplitWaste:\r\n FX.SplitRound(Src, Dst, Round(Amount), Style);\r\n end;\r\n // mask code\r\n Src.Canvas.Brush.Color := clWhite;\r\n Src.Canvas.FillRect(Rsrc);\r\n Src.Canvas.Brush.Style := bssolid;\r\n Src.Canvas.Brush.Color := clBlack;\r\n Src.Canvas.Ellipse(0, 0, Src.Width - 1, Src.Height - 1);\r\n Src.Transparent := True;\r\n Src.TransparentColor := clBlack;\r\n Dst.Canvas.Draw(0, 0, Src);\r\n Dst.Transparent := True;\r\n Dst.TransparentColor := clWhite;\r\n Canvas.Draw(0, 0, Clip);\r\n Canvas.Draw(X - Radius, Y - Radius, Dst);\r\n Src.Free;\r\n Dst.Free;\r\nend;\r\n\r\nprocedure TJvDrawImage.DrawPlasma(X, Y: Integer; Amount: Extended);\r\nvar\r\n Src: TBitmap;\r\n Rs: TRect;\r\n h, w, ra: Integer;\r\nbegin\r\n Src := TBitmap.Create;\r\n ra := Round(Amount);\r\n zoomrect := Rect(X - ra, Y - ra, X + ra, Y + ra);\r\n if zoomrect.Left < 0 then\r\n zoomrect.Left := 0;\r\n if zoomrect.Top < 0 then\r\n zoomrect.Top := 0;\r\n if zoomrect.Right > (FZoomClip.Width - 1) then\r\n zoomrect.Right := FZoomClip.Width - 1;\r\n if zoomrect.Bottom > (FZoomClip.Height - 1) then\r\n zoomrect.Bottom := FZoomClip.Height - 1;\r\n w := zoomrect.Right - zoomrect.Left + 1;\r\n h := zoomrect.Bottom - zoomrect.Top + 1;\r\n Src.Width := w;\r\n Src.Height := h;\r\n Src.PixelFormat := pf24bit;\r\n Rs := Rect(0, 0, w, h);\r\n Src.Canvas.CopyRect(Rs, FZoomClip.Canvas, zoomrect);\r\n Canvas.stretchDraw(Rect(0, 0, FZoomClip.Width, FZoomClip.Height), Src);\r\n Src.Free;\r\nend;\r\n\r\nfunction TJvDrawImage.Rotate(Origin, Endpoint: TPoint; Angle: Real): TPoint;\r\nvar\r\n a, d, r: Real;\r\nbegin\r\n r := Sqrt(Sqr(Endpoint.X - Origin.X) + Sqr(Endpoint.Y - Origin.Y));\r\n d := Endpoint.X - Origin.X;\r\n if (d >= 0) and (d < 0.001) then\r\n d := 0.001;\r\n if (d < 0) and (d > -0.001) then\r\n d := -0.001;\r\n a := ArcTan2((Endpoint.Y - Origin.Y), d);\r\n a := a + Angle;\r\n Result.X := Origin.X + Variant(r * Cos(a));\r\n Result.Y := Origin.Y + Variant(r * Sin(a));\r\nend;\r\n\r\nprocedure TJvDrawImage.SetSyms(X, Y: Integer);\r\nvar\r\n X0, Y0, i: Integer;\r\n da: Real;\r\n apoint: TPoint;\r\nbegin\r\n X0 := Picture.Bitmap.Width div 2;\r\n Y0 := Picture.Bitmap.Height div 2;\r\n da := 2 * pi / StarPoints;\r\n apoint := Point(X, Y);\r\n pointarray[0] := apoint;\r\n for i := 1 to StarPoints - 1 do\r\n begin\r\n apoint := Rotate(Point(X0, Y0), apoint, da);\r\n pointarray[i] := apoint;\r\n end;\r\nend;\r\n\r\nfunction TJvDrawImage.GetBlue(AColor: TColor): Byte;\r\nbegin\r\n Result := GetBValue(ColorToRGB(AColor));\r\nend;\r\n\r\nfunction TJvDrawImage.GetGreen(AColor: TColor): Byte;\r\nbegin\r\n Result := GetGValue(ColorToRGB(AColor));\r\nend;\r\n\r\nfunction TJvDrawImage.GetRed(AColor: TColor): Byte;\r\nbegin\r\n Result := GetRValue(ColorToRGB(AColor));\r\nend;\r\n\r\nfunction TJvDrawImage.MixColors(Color1, Color2: TColor): TColor;\r\nvar\r\n R1, G1, B1: Byte;\r\nbegin\r\n Color1 := ColorToRGB(Color1);\r\n Color2 := ColorToRGB(Color2);\r\n R1 := (GetRed(Color1) + GetRed(Color2)) div 2;\r\n G1 := (GetGreen(Color1) + GetGreen(Color2)) div 2;\r\n B1 := (GetBlue(Color1) + GetBlue(Color2)) div 2;\r\n Result := rgb(R1, G1, B1);\r\nend;\r\n\r\nprocedure TJvDrawImage.InitPlasma;\r\nvar\r\n w, h: Integer;\r\nbegin\r\n with Picture.Bitmap do\r\n begin\r\n w := Width;\r\n h := Height;\r\n FZoomClip.Width := w;\r\n FZoomClip.Height := h;\r\n end;\r\n FZoomClip.PixelFormat := pf24bit;\r\n FZoomClip.Canvas.Draw(0, 0, Picture.Bitmap);\r\nend;\r\n\r\nprocedure TJvDrawImage.CopyClip;\r\nvar\r\n m, dest: TRect;\r\nbegin\r\n m := mycliprect;\r\n Clip.Width := m.Right - m.Left + 1;\r\n Clip.Height := m.Bottom - m.Top + 1;\r\n dest := Rect(0, 0, Clip.Width, Clip.Height);\r\n Clip.Canvas.CopyMode := clipcm;\r\n Clip.Canvas.CopyRect(dest, Canvas, m);\r\n Clip.pixelformat := pf24bit;\r\nend;\r\n\r\nprocedure TJvDrawImage.ClipAll;\r\nbegin\r\n mycliprect := Rect(0, 0, Picture.Bitmap.Width - 1, Picture.Bitmap.Height - 1);\r\n clipcm := cmsrccopy;\r\n SetClip(clWhite);\r\n CopyClip;\r\nend;\r\n\r\nprocedure TJvDrawImage.SetClip(AColor: TColor);\r\nvar\r\n m, dest: TRect;\r\nbegin\r\n m := mycliprect;\r\n Clip.Width := (m.Right - m.Left) + 1;\r\n Clip.Height := (m.Bottom - m.Top) + 1;\r\n dest := Rect(0, 0, Clip.Width, Clip.Height);\r\n Clip.Canvas.Brush.Color := AColor;\r\n Clip.Canvas.FillRect(dest);\r\nend;\r\n\r\nprocedure TJvDrawImage.EscapePaint(X, Y: Integer; Shift: TShiftState);\r\nbegin\r\n if Shape = 'Polygon' then\r\n begin\r\n if freepolycount > 2 then\r\n Canvas.Polygon(slice(freepoly, freepolycount));\r\n freepolycount := 0;\r\n myDraw := False;\r\n end;\r\n if Shape = 'polyline' then\r\n begin\r\n freepolycount := 0;\r\n myDraw := False;\r\n end;\r\n if Shape = 'polybezier' then\r\n begin\r\n bezierfix1 := False;\r\n bezierfix2 := False;\r\n myorigin := Point(X, Y);\r\n myprevpoint := myorigin;\r\n if ssAlt in Shift then\r\n myDraw := False;\r\n end;\r\n\r\n Canvas.Pen.Mode := mypen;\r\n TargetPoint := Point(X, Y);\r\nend;\r\n\r\nprocedure TJvDrawImage.MouseDown(Button: TMouseButton;\r\n Shift: TShiftState; X, Y: Integer);\r\nbegin\r\n Wavepen := Canvas.Pen.Color;\r\n Wavebrush := Canvas.Brush.Color;\r\n if button = mbright then\r\n begin\r\n EscapePaint(X, Y, Shift);\r\n Exit;\r\n end;\r\n if ((ssCtrl in Shift) and (ssShift in Shift)) then\r\n begin\r\n X := targetpoint.X;\r\n Y := targetpoint.Y;\r\n mouse.CursorPos := clienttoscreen(Point(X, Y));\r\n end;\r\n Canvas.MoveTo(X, Y);\r\n myorigin := Point(X, Y);\r\n myprevpoint := myorigin;\r\n myslinedir := 'none';\r\n myDraw := True;\r\n mypen := Canvas.Pen.Mode;\r\n if (Shape = 'rangemove') or (Shape = 'rangesmear') then\r\n begin\r\n clipcm := cmSrcInvert;\r\n SetClip(clWhite);\r\n CopyClip;\r\n with Canvas do\r\n begin\r\n copymode := cmSrcInvert;\r\n Draw(X, Y, Clip);\r\n end;\r\n end;\r\n\r\n if Shape = 'darkerbrush' then\r\n ClipAll;\r\n if Shape = 'mbHorOval' then\r\n ClipAll;\r\n if Shape = 'mbVerOval' then\r\n ClipAll;\r\n if Shape = 'mbVerBox' then\r\n ClipAll;\r\n if Shape = 'mbHorBox' then\r\n ClipAll;\r\n if Shape = 'mbHor' then\r\n ClipAll;\r\n if Shape = 'mbTop' then\r\n ClipAll;\r\n if Shape = 'mbBottom' then\r\n ClipAll;\r\n if Shape = 'mbDiamond' then\r\n ClipAll;\r\n if Shape = 'mbWaste' then\r\n ClipAll;\r\n if Shape = 'mbRound' then\r\n ClipAll;\r\n if Shape = 'mbRound2' then\r\n ClipAll;\r\n if Shape = 'mbSplitRound' then\r\n ClipAll;\r\n if Shape = 'mbSplitWaste' then\r\n ClipAll;\r\n if Shape = 'zoombrush' then\r\n InitPlasma;\r\n if Shape = 'zoomkeepbrush' then\r\n InitPlasma;\r\n if Shape = 'brightnessbrush' then\r\n ClipAll;\r\n if Shape = 'contrastbrush' then\r\n ClipAll;\r\n if Shape = 'saturationbrush' then\r\n ClipAll;\r\n if Shape = 'fisheyebrush' then\r\n ClipAll;\r\n if Shape = 'fisheyefixbrush' then\r\n ClipAll;\r\n if Shape = 'rotatebrush' then\r\n ClipAll;\r\n if Shape = 'twistbrush' then\r\n ClipAll;\r\n if Shape = 'rimplebrush' then\r\n ClipAll;\r\n if Shape = 'lighterbrush' then\r\n ClipAll;\r\n if Shape = 'graybrush' then\r\n ClipAll;\r\n if Shape = 'rollmixbrush' then\r\n ClipAll;\r\n if Shape = 'smoothbrush' then\r\n ClipAll;\r\n\r\n if Shape = 'gradientbrush' then\r\n begin\r\n Picture.Bitmap.PixelFormat := pf24bit;\r\n end;\r\n if Shape = 'mixbrush' then\r\n begin\r\n with Canvas do\r\n begin\r\n if ssAlt in Shift then\r\n Pen.Color := MixColors(Pixels[X, Y - Pen.Width], Pixels[X, Y + Pen.Width])\r\n else\r\n Pen.Color := MixColors(Pixels[X - Pen.Width, Y], Pixels[X + Pen.Width, Y]);\r\n end;\r\n end;\r\n if Shape = 'sym' then\r\n SetSyms(X, Y);\r\n if Shape = 'chord3' then\r\n Shape := 'chord';\r\n if Shape = 'pie3' then\r\n Shape := 'pie';\r\n if Shape = 'arc3' then\r\n Shape := 'arc';\r\n if Shape = 'bezier3' then\r\n Shape := 'bezier';\r\n if Shape = 'skewrect2' then\r\n Shape := 'skewrect';\r\n if Shape = 'triangle2' then\r\n Shape := 'triangle';\r\n if Shape = 'cube2' then\r\n Shape := 'cube';\r\n if (Shape = 'snapshot') then\r\n begin\r\n myoldbrushstyle := Canvas.Brush.Style;\r\n Canvas.Brush.Style := bsClear;\r\n myoldpenwidth := Canvas.Pen.Width;\r\n Canvas.Pen.Width := 1;\r\n end;\r\n if (Shape = 'bezier1') then\r\n with Canvas do\r\n begin\r\n Pen.Mode := pmNotXor;\r\n PolyBezier(mybezier);\r\n mybezier[1] := Point(X, Y);\r\n PolyBezier(mybezier);\r\n end;\r\n if (Shape = 'bezier2') then\r\n with Canvas do\r\n begin\r\n Pen.Mode := pmNotXor;\r\n PolyBezier(mybezier);\r\n mybezier[2] := Point(X, Y);\r\n PolyBezier(mybezier);\r\n end;\r\n Canvas.Pen.Mode := mypen;\r\nend;\r\n\r\nprocedure TJvDrawImage.MouseMove(Shift: TShiftState;\r\n X, Y: Integer);\r\nvar\r\n xp, yp, i, (*j, *)X1, Y1, X2, Y2, (*h, *)w, pw, movex, movey: Integer;\r\n myrect: TRect;\r\n Color1, Color2: TColor;\r\n// R1, G1, B1, R2, B2, G2: Byte;\r\n dx, dy, Angle: Extended;\r\n\r\n function rr: Integer;\r\n begin\r\n Result := Round(Sqrt(Sqr(X - myorigin.X) + Sqr(Y - myorigin.Y)));\r\n if Result < 10 then\r\n Result := 10;\r\n end;\r\n\r\n procedure MoveOrigin;\r\n begin\r\n myorigin.X := myorigin.X + movex;\r\n myorigin.Y := myorigin.Y + movey;\r\n end;\r\n\r\nbegin\r\n decoX := X;\r\n decoY := Y;\r\n movex := X - myprevpoint.X;\r\n movey := Y - myprevpoint.Y;\r\n // test for scripting\r\n if ((ssCtrl in Shift) and (ssAlt in Shift)) then\r\n Exit;\r\n mypen := Canvas.Pen.Mode;\r\n// h := Abs(Y - myorigin.Y);\r\n// w := Abs(X - myorigin.X);\r\n if myDraw then\r\n begin\r\n if (Shape = 'rangemove') or (Shape = 'rangesmear') then\r\n begin\r\n with Canvas do\r\n begin\r\n copymode := cmSrcInvert;\r\n if Shape = 'rangemove' then\r\n Draw(myprevpoint.X, myprevpoint.Y, Clip);\r\n Draw(X, Y, Clip);\r\n myprevpoint := Point(X, Y);\r\n end;\r\n end;\r\n if Shape = 'airbrush' then\r\n if AirBrush.Air then\r\n AirBrush.Draw(Canvas, X, Y);\r\n if (Shape = 'zoombrush') or (Shape = 'zoomkeepbrush') then\r\n begin\r\n w := Canvas.Pen.Width;\r\n if w < 5 then\r\n w := 50;\r\n DrawPlasma(X, Y, w);\r\n end;\r\n if Shape = 'fisheyebrush' then\r\n begin\r\n w := Canvas.Pen.Width;\r\n if w < 5 then\r\n w := 50;\r\n DrawEffectBrush(X, Y, w, 0.9, lbfisheye);\r\n end;\r\n if Shape = 'fisheyefixbrush' then\r\n begin\r\n if ssAlt in Shift then\r\n MoveOrigin;\r\n dx := X - myorigin.X;\r\n if dx = 0 then\r\n dx := 0.01;\r\n dy := Y - myorigin.Y;\r\n Angle := ArcTan2(dy, dx) / pi * 0.5 + 0.5;\r\n if Angle < 0.55 then\r\n Angle := 0.55;\r\n if Angle > 0.99 then\r\n Angle := 0.99;\r\n DrawEffectBrush(myorigin.X, myorigin.Y, rr, Angle, lbfisheye);\r\n end;\r\n if Shape = 'twistbrush' then\r\n begin\r\n if ssAlt in Shift then\r\n MoveOrigin;\r\n dx := X - myorigin.X;\r\n if dx = 0 then\r\n dx := 0.01;\r\n dy := Y - myorigin.Y;\r\n Angle := Abs(ArcTan2(dy, dx) * 25 / pi) + 1;\r\n DrawEffectBrush(myorigin.X, myorigin.Y, rr, Round(Angle), lbtwist);\r\n end;\r\n if Shape = 'mbHorOval' then\r\n begin\r\n if ssAlt in Shift then\r\n MoveOrigin;\r\n dx := X - myorigin.X;\r\n if dx = 0 then\r\n dx := 0.01;\r\n dy := Y - myorigin.Y;\r\n Angle := ArcTan2(dy, dx) * 180 / pi;\r\n DrawStretchBrush(myorigin.X, myorigin.Y, rr, Angle, mbHorOval);\r\n end;\r\n if Shape = 'mbHorBox' then\r\n begin\r\n if ssAlt in Shift then\r\n MoveOrigin;\r\n dx := X - myorigin.X;\r\n if dx = 0 then\r\n dx := 0.01;\r\n dy := Y - myorigin.Y;\r\n Angle := ArcTan2(dy, dx) * 180 / pi;\r\n DrawStretchBrush(myorigin.X, myorigin.Y, rr, Angle, mbHorBox);\r\n end;\r\n\r\n if Shape = 'mbVerOval' then\r\n begin\r\n if ssAlt in Shift then\r\n MoveOrigin;\r\n dx := X - myorigin.X;\r\n if dx = 0 then\r\n dx := 0.01;\r\n dy := Y - myorigin.Y;\r\n Angle := ArcTan2(dy, dx) * 180 / pi;\r\n DrawStretchBrush(myorigin.X, myorigin.Y, rr, Angle, mbVerOval);\r\n end;\r\n\r\n if Shape = 'mbVerBox' then\r\n begin\r\n if ssAlt in Shift then\r\n MoveOrigin;\r\n dx := X - myorigin.X;\r\n if dx = 0 then\r\n dx := 0.01;\r\n dy := Y - myorigin.Y;\r\n Angle := ArcTan2(dy, dx) * 180 / pi;\r\n DrawStretchBrush(myorigin.X, myorigin.Y, rr, Angle, mbVerBox);\r\n end;\r\n\r\n if Shape = 'mbHor' then\r\n begin\r\n if ssAlt in Shift then\r\n MoveOrigin;\r\n dx := X - myorigin.X;\r\n if dx = 0 then\r\n dx := 0.01;\r\n dy := Y - myorigin.Y;\r\n Angle := ArcTan2(dy, dx) * 180 / pi;\r\n DrawEffectBrush(myorigin.X, myorigin.Y, rr, Angle, mbHor);\r\n end;\r\n\r\n if Shape = 'mbTop' then\r\n begin\r\n if ssAlt in Shift then\r\n MoveOrigin;\r\n dx := X - myorigin.X;\r\n if dx = 0 then\r\n dx := 0.01;\r\n dy := Y - myorigin.Y;\r\n Angle := ArcTan2(dy, dx) * 180 / pi;\r\n DrawEffectBrush(myorigin.X, myorigin.Y, rr, Angle, mbTop);\r\n end;\r\n\r\n if Shape = 'mbBottom' then\r\n begin\r\n if ssAlt in Shift then\r\n MoveOrigin;\r\n dx := X - myorigin.X;\r\n if dx = 0 then\r\n dx := 0.01;\r\n dy := Y - myorigin.Y;\r\n Angle := ArcTan2(dy, dx) * 180 / pi;\r\n DrawEffectBrush(myorigin.X, myorigin.Y, rr, Angle, mbBottom);\r\n end;\r\n if Shape = 'mbWaste' then\r\n begin\r\n if ssAlt in Shift then\r\n MoveOrigin;\r\n dx := X - myorigin.X;\r\n if dx = 0 then\r\n dx := 0.01;\r\n dy := Y - myorigin.Y;\r\n Angle := ArcTan2(dy, dx) * 180 / pi;\r\n DrawEffectBrush(myorigin.X, myorigin.Y, rr, Angle, mbWaste);\r\n end;\r\n if Shape = 'mbRound' then\r\n begin\r\n if ssAlt in Shift then\r\n MoveOrigin;\r\n dx := X - myorigin.X;\r\n if dx = 0 then\r\n dx := 0.01;\r\n dy := Y - myorigin.Y;\r\n Angle := ArcTan2(dy, dx) * 180 / pi;\r\n DrawEffectBrush(myorigin.X, myorigin.Y, rr, Angle, mbRound);\r\n end;\r\n if Shape = 'mbRound2' then\r\n begin\r\n if ssAlt in Shift then\r\n MoveOrigin;\r\n dx := X - myorigin.X;\r\n if dx = 0 then\r\n dx := 0.01;\r\n dy := Y - myorigin.Y;\r\n Angle := ArcTan2(dy, dx) * 180 / pi;\r\n DrawEffectBrush(myorigin.X, myorigin.Y, rr, Angle, mbRound2);\r\n end;\r\n\r\n if Shape = 'mbDiamond' then\r\n begin\r\n if ssAlt in Shift then\r\n MoveOrigin;\r\n dx := X - myorigin.X;\r\n if dx = 0 then\r\n dx := 0.01;\r\n dy := Y - myorigin.Y;\r\n Angle := ArcTan2(dy, dx) * 180 / pi;\r\n DrawEffectBrush(myorigin.X, myorigin.Y, rr, Angle, mbDiamond);\r\n end;\r\n if Shape = 'mbSplitRound' then\r\n begin\r\n if ssAlt in Shift then\r\n MoveOrigin;\r\n dx := X - myorigin.X;\r\n if dx = 0 then\r\n dx := 0.01;\r\n dy := Y - myorigin.Y;\r\n Angle := ArcTan2(dy, dx) * 180 / pi;\r\n DrawEffectBrush(myorigin.X, myorigin.Y, rr, Angle, mbSplitRound);\r\n end;\r\n if Shape = 'mbSplitWaste' then\r\n begin\r\n if ssAlt in Shift then\r\n MoveOrigin;\r\n dx := X - myorigin.X;\r\n if dx = 0 then\r\n dx := 0.01;\r\n dy := Y - myorigin.Y;\r\n Angle := ArcTan2(dy, dx) * 180 / pi;\r\n DrawEffectBrush(myorigin.X, myorigin.Y, rr, Angle, mbSplitWaste);\r\n end;\r\n\r\n if Shape = 'rimplebrush' then\r\n begin\r\n if ssAlt in Shift then\r\n MoveOrigin;\r\n dx := X - myorigin.X;\r\n if dx = 0 then\r\n dx := 0.01;\r\n dy := Y - myorigin.Y;\r\n Angle := ArcTan2(dy, dx) * 10 / pi + 1;\r\n DrawEffectBrush(myorigin.X, myorigin.Y, rr, Angle, lbrimple);\r\n end;\r\n\r\n if Shape = 'rotatebrush' then\r\n begin\r\n if ssAlt in Shift then\r\n MoveOrigin;\r\n dx := X - myorigin.X;\r\n if dx = 0 then\r\n dx := 0.01;\r\n dy := Y - myorigin.Y;\r\n Angle := ArcTan2(dy, dx) * 180 / pi;\r\n DrawEffectBrush(myorigin.X, myorigin.Y, rr, Angle, lbrotate);\r\n end;\r\n if Shape = 'brightnessbrush' then\r\n begin\r\n if ssAlt in Shift then\r\n MoveOrigin;\r\n dx := X - myorigin.X;\r\n if dx = 0 then\r\n dx := 0.01;\r\n dy := Y - myorigin.Y;\r\n Angle := ArcTan2(dy, dx) * 100 / pi;\r\n DrawLightBrush(myorigin.X, myorigin.Y,\r\n rr, Round(Angle), lbBrightness);\r\n end;\r\n if Shape = 'contrastbrush' then\r\n begin\r\n if ssAlt in Shift then\r\n MoveOrigin;\r\n dx := X - myorigin.X;\r\n if dx = 0 then\r\n dx := 0.01;\r\n dy := Y - myorigin.Y;\r\n Angle := ArcTan2(dy, dx) * 100 / pi;\r\n DrawLightBrush(myorigin.X, myorigin.Y,\r\n rr, Round(Angle), lbContrast);\r\n end;\r\n if Shape = 'saturationbrush' then\r\n begin\r\n if ssAlt in Shift then\r\n MoveOrigin;\r\n dx := X - myorigin.X;\r\n if dx = 0 then\r\n dx := 0.01;\r\n dy := Y - myorigin.Y;\r\n Angle := ArcTan2(dy, dx) * 100 / pi;\r\n DrawLightBrush(myorigin.X, myorigin.Y,\r\n rr, Round(Angle), lbContrast);\r\n end;\r\n\r\n if Shape = 'Bluebrush' then\r\n DrawColorCircle(X, Y, 0);\r\n if Shape = 'Greenbrush' then\r\n DrawColorCircle(X, Y, 1);\r\n if Shape = 'redbrush' then\r\n DrawColorCircle(X, Y, 2);\r\n if Shape = 'notBluebrush' then\r\n DrawColorCircle(X, Y, 3);\r\n if Shape = 'notGreenbrush' then\r\n DrawColorCircle(X, Y, 4);\r\n if Shape = 'notredbrush' then\r\n DrawColorCircle(X, Y, 5);\r\n if Shape = 'halfBluebrush' then\r\n DrawColorCircle(X, Y, 6);\r\n if Shape = 'halfGreenbrush' then\r\n DrawColorCircle(X, Y, 7);\r\n if Shape = 'halfredbrush' then\r\n DrawColorCircle(X, Y, 8);\r\n if Shape = 'darkerbrush' then\r\n DrawDarkerCircle(X, Y, 9);\r\n if Shape = 'lighterbrush' then\r\n DrawLighterCircle(X, Y, 10);\r\n if Shape = 'graybrush' then\r\n DrawLighterCircle(X, Y, 11);\r\n if Shape = 'rollmixbrush' then\r\n DrawLighterCircle(X, Y, 12);\r\n if Shape = 'smoothbrush' then\r\n DrawLighterCircle(X, Y, 13);\r\n\r\n if Shape = 'gradientbrush' then\r\n begin\r\n with Canvas do\r\n begin\r\n if ssAlt in Shift then\r\n begin\r\n Color1 := Pixels[X, Y - Pen.Width];\r\n Color2 := Pixels[X, Y + Pen.Width];\r\n DrawVGradientBrush(Color1, Color2, Y - Pen.Width, Y + Pen.Width, X);\r\n DrawVGradientBrush(Color1, Color2, Y - Pen.Width, Y + Pen.Width, X - 1);\r\n DrawVGradientBrush(Color1, Color2, Y - Pen.Width, Y + Pen.Width, X - 2);\r\n end\r\n else\r\n begin\r\n Color1 := Pixels[X - Pen.Width, Y];\r\n Color2 := Pixels[X + Pen.Width, Y];\r\n DrawGradientBrush(Color1, Color2, X - Pen.Width, X + Pen.Width, Y);\r\n DrawGradientBrush(Color1, Color2, X - Pen.Width, X + Pen.Width, Y + 1);\r\n DrawGradientBrush(Color1, Color2, X - Pen.Width, X + Pen.Width, Y + 2);\r\n end;\r\n end;\r\n end;\r\n\r\n if Shape = 'cube1' then\r\n with Canvas do\r\n begin\r\n Pen.Mode := pmNotXor;\r\n DrawCube;\r\n myskew[4] := Point(X, Y);\r\n DrawCube;\r\n end;\r\n if (Shape = 'rectangle') or (Shape = 'cube') or (Shape = 'maze') or\r\n (Shape = 'Interprect') or (Shape = 'interColumn') then\r\n with Canvas do\r\n begin\r\n Pen.Mode := pmNotXor;\r\n Rectangle(myorigin.X, myorigin.Y, myprevpoint.X, myprevpoint.Y);\r\n Rectangle(myorigin.X, myorigin.Y, X, Y);\r\n myprevpoint := Point(X, Y);\r\n end;\r\n\r\n if Shape = 'roundrect' then\r\n with Canvas do\r\n begin\r\n Pen.Mode := pmNotXor;\r\n RoundRect(myorigin.X, myorigin.Y, myprevpoint.X, myprevpoint.Y, myround, myround);\r\n RoundRect(myorigin.X, myorigin.Y, X, Y, myround, myround);\r\n myprevpoint := Point(X, Y);\r\n end;\r\n if Shape = 'Blocks' then\r\n Canvas.FillRect(PointToBlock(X, Y));\r\n\r\n if (Shape = 'ellipse') or (Shape = 'globe') or (Shape = 'interSphere') or\r\n (Shape = 'MultiSphere') or (Shape = 'DropletSphere') or\r\n (Shape = 'WaveSphere') or (Shape = 'RisingWaveSphere') or\r\n (Shape = 'decooval') then\r\n with Canvas do\r\n begin\r\n Pen.Mode := pmNotXor;\r\n Ellipse(myorigin.X, myorigin.Y, myprevpoint.X, myprevpoint.Y);\r\n Ellipse(myorigin.X, myorigin.Y, X, Y);\r\n myprevpoint := Point(X, Y);\r\n end;\r\n if (Shape = 'chord') or (Shape = 'pie') or (Shape = 'arc') then\r\n with Canvas do\r\n begin\r\n Pen.Mode := pmNotXor;\r\n Ellipse(myorigin.X, myorigin.Y, myprevpoint.X, myprevpoint.Y);\r\n Ellipse(myorigin.X, myorigin.Y, X, Y);\r\n myprevpoint := Point(X, Y);\r\n end;\r\n if Shape = 'skewrect1' then\r\n with Canvas do\r\n begin\r\n Pen.Mode := pmNotXor;\r\n DrawSkew;\r\n myskew[2] := Point(X, Y);\r\n myskew[3].X := myskew[0].X + (myskew[2].X - myskew[1].X);\r\n myskew[3].Y := myskew[0].Y + (myskew[2].Y - myskew[1].Y);\r\n DrawSkew;\r\n end;\r\n\r\n if Shape = 'triangle1' then\r\n with Canvas do\r\n begin\r\n Pen.Mode := pmNotXor;\r\n DrawTriangle;\r\n myskew[2] := Point(X, Y);\r\n DrawTriangle;\r\n end;\r\n if (Shape = 'polyline') or (Shape = 'Polygon') then\r\n with Canvas do\r\n begin\r\n Pen.Mode := pmNotXor;\r\n PenPos := Point(myorigin.X, myorigin.Y);\r\n LineTo(myprevpoint.X, myprevpoint.Y);\r\n PenPos := Point(myorigin.X, myorigin.Y);\r\n LineTo(X, Y);\r\n myprevpoint := Point(X, Y);\r\n end;\r\n\r\n if Shape = 'polybezier' then\r\n with Canvas do\r\n begin\r\n Pen.Mode := pmNotXor;\r\n mybezier[0] := Point(myorigin.X, myorigin.Y);\r\n mybezier[3] := Point(myprevpoint.X, myprevpoint.Y);\r\n if not bezierfix1 then\r\n begin\r\n mybezier[1].X := mybezier[0].X;\r\n mybezier[1].Y := mybezier[3].Y;\r\n end;\r\n if not bezierfix2 then\r\n begin\r\n mybezier[2].X := mybezier[3].X;\r\n mybezier[2].Y := mybezier[0].Y;\r\n end;\r\n PolyBezier(mybezier);\r\n mybezier[3] := Point(X, Y);\r\n if (ssCtrl in Shift) then\r\n begin\r\n bezierfix1 := True;\r\n mybezier[1] := mybezier[3];\r\n end;\r\n if not bezierfix1 then\r\n begin\r\n mybezier[1].X := mybezier[0].X;\r\n mybezier[1].Y := mybezier[3].Y;\r\n end;\r\n if (ssShift in Shift) then\r\n begin\r\n bezierfix2 := True;\r\n mybezier[2] := mybezier[3];\r\n end;\r\n if not bezierfix2 then\r\n begin\r\n mybezier[2].X := mybezier[3].X;\r\n mybezier[2].Y := mybezier[0].Y;\r\n end;\r\n\r\n PolyBezier(mybezier);\r\n myprevpoint := Point(X, Y);\r\n end;\r\n if (Shape = 'line') or (Shape = 'rotateText') or (Shape = 'Star') or\r\n (Shape = 'spiral') or (Shape = 'skewrect') or (Shape = 'triangle') or\r\n (Shape = 'cone') or (Shape = 'Spiro') or (Shape = 'decobar') then\r\n with Canvas do\r\n begin\r\n Pen.Mode := pmNotXor;\r\n PenPos := Point(myorigin.X, myorigin.Y);\r\n LineTo(myprevpoint.X, myprevpoint.Y);\r\n PenPos := Point(myorigin.X, myorigin.Y);\r\n LineTo(X, Y);\r\n myprevpoint := Point(X, Y);\r\n end;\r\n if (Shape = 'bezier') then\r\n with Canvas do\r\n begin\r\n Pen.Mode := pmNotXor;\r\n mybezier[0] := Point(myorigin.X, myorigin.Y);\r\n mybezier[1] := mybezier[0];\r\n mybezier[3] := Point(myprevpoint.X, myprevpoint.Y);\r\n mybezier[2] := mybezier[3];\r\n PolyBezier(mybezier);\r\n mybezier[3] := Point(X, Y);\r\n mybezier[2] := mybezier[3];\r\n PolyBezier(mybezier);\r\n myprevpoint := Point(X, Y);\r\n end;\r\n if (Shape = 'bezier1') then\r\n with Canvas do\r\n begin\r\n Pen.Mode := pmNotXor;\r\n PolyBezier(mybezier);\r\n mybezier[1] := Point(X, Y);\r\n PolyBezier(mybezier);\r\n end;\r\n if (Shape = 'bezier2') then\r\n with Canvas do\r\n begin\r\n Pen.Mode := pmNotXor;\r\n PolyBezier(mybezier);\r\n mybezier[2] := Point(X, Y);\r\n PolyBezier(mybezier);\r\n end;\r\n if Shape = 'spray' then\r\n for i := 1 to 10 do\r\n begin\r\n xp := random(30) - 15;\r\n yp := random(30) - 15;\r\n Canvas.Pixels[X + xp, Y + yp] := Canvas.Brush.Color;\r\n end;\r\n\r\n if (Shape = 'Waveline') or (Shape = 'fastWaveline') or\r\n (Shape = 'colorWaveline') then\r\n with Canvas do\r\n begin\r\n Canvas.LineTo(X, Y);\r\n myprevpoint := Point(X, Y);\r\n end;\r\n\r\n if Shape = 'borderWaveline' then\r\n begin\r\n Canvas.MoveTo(myprevpoint.X, myprevpoint.Y);\r\n Canvas.LineTo(X, Y);\r\n Canvas.MoveTo(Width - myprevpoint.X, Height - myprevpoint.Y);\r\n Canvas.LineTo(Width - X, Height - Y);\r\n myprevpoint := Point(X, Y);\r\n end;\r\n\r\n if Shape = 'decoline' then\r\n begin\r\n with Canvas do\r\n begin\r\n pw := Pen.Width;\r\n Pen.Color := Wavepen;\r\n Pen.Mode := pmCopy;\r\n MoveTo(myprevpoint.X, myprevpoint.Y);\r\n LineTo(X, Y);\r\n Pen.Width := pw * 2;\r\n Pen.Mode := pmmasknotpen;\r\n MoveTo(myprevpoint.X, myprevpoint.Y);\r\n LineTo(X, Y);\r\n myprevpoint := Point(X, Y);\r\n Pen.Width := pw;\r\n Pen.Mode := pmCopy;\r\n Pen.Mode := mypen;\r\n end;\r\n end;\r\n\r\n if (Shape = 'freehand') or (Shape = 'mixbrush') then\r\n with Canvas do\r\n begin\r\n Canvas.LineTo(X, Y);\r\n myprevpoint := Point(X, Y)\r\n end;\r\n if Shape = 'cloneall' then\r\n with Canvas do\r\n begin\r\n X1 := myorigin.X - TargetPoint.X;\r\n Y1 := myorigin.Y - Targetpoint.Y;\r\n X2 := X - X1;\r\n Y2 := Y - Y1;\r\n copymode := cmsrccopy;\r\n i := Pen.Width;\r\n copyrect(Rect(X, Y, X + i, Y + i), Canvas,\r\n Rect(X2, Y2, X2 + i, Y2 + i));\r\n end;\r\n\r\n if Shape = 'clonenottarget' then\r\n with Canvas do\r\n begin\r\n X1 := myorigin.X - TargetPoint.X;\r\n Y1 := myorigin.Y - Targetpoint.Y;\r\n X2 := X - X1;\r\n Y2 := Y - Y1;\r\n i := Pen.Width;\r\n PutClip(Rect(X2, Y2, X2 + i, Y2 + i));\r\n Clip.Transparent := True;\r\n Clip.TransparentColor := Pixels[Targetpoint.X, Targetpoint.Y];\r\n Draw(X, Y, Clip);\r\n Clip.Transparent := False;\r\n end;\r\n\r\n if (Shape = 'paste') and (ssShift in Shift) then\r\n begin\r\n myrect := Rect(0, 0, 0, 0);\r\n myrect.Left := X;\r\n myrect.Top := Y;\r\n myrect.Right := X + mycliprect.Right - mycliprect.Left;\r\n myrect.Bottom := Y + mycliprect.Bottom - mycliprect.Top;\r\n Canvas.CopyRect(myrect, Canvas, mycliprect);\r\n end;\r\n if Shape = 'sym' then\r\n DrawSyms(X, Y);\r\n if Shape = 'sline' then\r\n begin\r\n if myslinedir = 'none' then\r\n if Abs(X - myorigin.X) >= Abs(Y - myorigin.Y) then\r\n myslinedir := 'h'\r\n else\r\n myslinedir := 'v';\r\n if (myslinedir = 'h') and (Abs(Y - myprevpoint.Y) > myslinetol) then\r\n myslinedir := 'v';\r\n if (myslinedir = 'v') and (Abs(X - myprevpoint.X) > myslinetol) then\r\n myslinedir := 'h';\r\n if myslinedir = 'h' then\r\n begin\r\n Canvas.LineTo(X, myprevpoint.Y);\r\n myprevpoint.X := X;\r\n end;\r\n if myslinedir = 'v' then\r\n begin\r\n Canvas.LineTo(myprevpoint.X, Y);\r\n myprevpoint.Y := Y;\r\n end;\r\n end;\r\n\r\n if Shape = 'vmirror' then\r\n begin\r\n X1 := myprevpoint.X;\r\n Y1 := myprevpoint.Y;\r\n X2 := Width;\r\n// Y2 := Height;\r\n Canvas.PenPos := Point(X2 - X1, Y1);\r\n Canvas.LineTo(X2 - X, Y);\r\n Canvas.PenPos := Point(X1, Y1);\r\n Canvas.LineTo(X, Y);\r\n myprevpoint := Point(X, Y)\r\n end;\r\n if Shape = 'cmirror' then\r\n begin\r\n X1 := myprevpoint.X;\r\n Y1 := myprevpoint.Y;\r\n X2 := Width;\r\n Y2 := Height;\r\n Canvas.PenPos := Point(X2 - X1, Y2 - Y1);\r\n Canvas.LineTo(X2 - X, Y2 - Y);\r\n Canvas.PenPos := Point(X1, Y1);\r\n Canvas.LineTo(X, Y);\r\n myprevpoint := Point(X, Y)\r\n end;\r\n if Shape = 'mirror4' then\r\n begin\r\n X1 := myprevpoint.X;\r\n Y1 := myprevpoint.Y;\r\n X2 := Width;\r\n Y2 := Height;\r\n Canvas.PenPos := Point(X2 - X1, Y2 - Y1);\r\n Canvas.LineTo(X2 - X, Y2 - Y);\r\n Canvas.PenPos := Point(X2 - X1, Y1);\r\n Canvas.LineTo(X2 - X, Y);\r\n Canvas.PenPos := Point(X1, Y2 - Y1);\r\n Canvas.LineTo(X, Y2 - Y);\r\n Canvas.PenPos := Point(X1, Y1);\r\n Canvas.LineTo(X, Y);\r\n myprevpoint := Point(X, Y)\r\n end;\r\n if Shape = 'hmirror' then\r\n begin\r\n X1 := myprevpoint.X;\r\n Y1 := myprevpoint.Y;\r\n// X2 := Width;\r\n Y2 := Height;\r\n Canvas.PenPos := Point(X1, Y2 - Y1);\r\n Canvas.LineTo(X, Y2 - Y);\r\n Canvas.PenPos := Point(X1, Y1);\r\n Canvas.LineTo(X, Y);\r\n myprevpoint := Point(X, Y)\r\n end;\r\n if (Shape = 'snapshot') or (Shape = 'bars') or (Shape = 'border') then\r\n with Canvas do\r\n begin\r\n Pen.Mode := pmNotXor;\r\n Pen.Style := psDot;\r\n Rectangle(myorigin.X, myorigin.Y, myprevpoint.X, myprevpoint.Y);\r\n Rectangle(myorigin.X, myorigin.Y, X, Y);\r\n myprevpoint := Point(X, Y);\r\n Pen.Style := psSolid;\r\n end;\r\n end;\r\n Canvas.Pen.Mode := mypen;\r\n myprevpoint := Point(X, Y);\r\nend;\r\n\r\nprocedure TJvDrawImage.MouseUp(Button: TMouseButton;\r\n Shift: TShiftState; X, Y: Integer);\r\nvar\r\n myrect: TRect;\r\n xs, ys, xt, yt, i(*, tangle*): Integer;\r\n// c: TColor;\r\n// drw: string;\r\n apoint: TPoint;\r\n// Bitmap: TBitmap;\r\n// X1, Y1, X2, Y2: Integer;\r\n// dcurve: array [0..3] of TPoint;\r\n// rgn: HRGN;\r\n R1, G1, B1, R2, G2, B2: Byte;\r\n r, g, b, dr, dg, DB: Extended;\r\n AColor, pcolor: TColor;\r\n pw: Integer;\r\nbegin\r\n //Canvas.Pen.Color:=Wavepen;\r\n //Canvas.Brush.Color:=Wavebrush;\r\n\r\n if ((ssCtrl in Shift) and (ssAlt in Shift)) then\r\n Exit;\r\n if button = mbright then\r\n Exit;\r\n mypen := Canvas.Pen.Mode;\r\n\r\n if Shape = 'zoombrush' then\r\n Canvas.Draw(0, 0, FZoomClip);\r\n if Shape = 'transcopy' then\r\n begin\r\n clipcm := cmSrcCopy;\r\n SetClip(clWhite);\r\n CopyClip;\r\n myrect := Rect(X, Y, X + Clip.Width - 1, Y + Clip.Height - 1);\r\n With Canvas do\r\n BrushCopy( myrect, Clip,\r\n Rect(0, 0, Clip.Width, Clip.Height), RangeTransColor);\r\n myDraw := False;\r\n end;\r\n if Shape = 'cube1' then\r\n begin\r\n if mypen <> pmNotXor then\r\n DrawCube;\r\n Shape := 'cube2';\r\n end;\r\n\r\n if Shape = 'TexLines' then\r\n begin\r\n DrawTexLines(myorigin.X, myorigin.Y, X, Y);\r\n end;\r\n if Shape = 'Texovals' then\r\n begin\r\n DrawTexOvals(myorigin.X, myorigin.Y, X, Y);\r\n end;\r\n if Shape = 'Blurovals' then\r\n begin\r\n DrawBlurOvals(myorigin.X, myorigin.Y, X, Y);\r\n end;\r\n if Shape = 'Texcurves' then\r\n begin\r\n DrawTexCurves(myorigin.X, myorigin.Y, X, Y);\r\n end;\r\n if Shape = 'Blurcurves' then\r\n begin\r\n DrawBlurCurves(myorigin.X, myorigin.Y, X, Y);\r\n end;\r\n if Shape = 'Texpoly' then\r\n begin\r\n DrawTexPoly(myorigin.X, myorigin.Y, X, Y);\r\n end;\r\n if Shape = 'Blurpoly' then\r\n begin\r\n DrawBlurPoly(myorigin.X, myorigin.Y, X, Y);\r\n end;\r\n if Shape = 'TexRects' then\r\n begin\r\n DrawTexRects(myorigin.X, myorigin.Y, X, Y);\r\n end;\r\n if Shape = 'BlurRects' then\r\n begin\r\n DrawBlurRects(myorigin.X, myorigin.Y, X, Y);\r\n end;\r\n if Shape = 'BlurLines' then\r\n begin\r\n DrawBlurLines(myorigin.X, myorigin.Y, X, Y);\r\n end;\r\n\r\n if Shape = 'cube' then\r\n begin\r\n myskew[0] := myorigin;\r\n myskew[2] := Point(X, Y);\r\n myskew[4] := myskew[2];\r\n myskew[1].X := myskew[2].X;\r\n myskew[1].Y := myskew[0].Y;\r\n myskew[3].X := myskew[0].X;\r\n myskew[3].Y := myskew[2].Y;\r\n DrawCube;\r\n Shape := 'cube1';\r\n end;\r\n\r\n if Shape = 'Interprect' then\r\n InterpRect(myorigin.X, myorigin.Y, X, Y);\r\n\r\n if Shape = 'interColumn' then\r\n DrawColumn(myorigin.X, myorigin.Y, X, Y);\r\n\r\n if Shape = 'interSphere' then\r\n if ((myorigin.X <> X) and (myorigin.Y <> Y)) then\r\n begin\r\n if ssAlt in Shift then\r\n DrawSphere(Canvas.Pixels[myorigin.X, myorigin.Y],\r\n Canvas.Pixels[X, Y], myorigin.X, myorigin.Y, X, Y)\r\n else\r\n DrawSphere(Wavepen, Wavebrush, myorigin.X, myorigin.Y, X, Y)\r\n end;\r\n\r\n if Shape = 'MultiSphere' then\r\n begin\r\n Canvas.Pen.Mode := pmNotXor;\r\n Canvas.Ellipse(myorigin.X, myorigin.Y, X, Y);\r\n Canvas.Pen.Mode := pmCopy;\r\n if ((myorigin.X <> X) and (myorigin.Y <> Y)) then\r\n begin\r\n if ssAlt in Shift then\r\n DrawMultiSphere(Canvas.Pixels[myorigin.X, myorigin.Y],\r\n Canvas.Pixels[X, Y], myorigin.X, myorigin.Y, X, Y)\r\n else\r\n DrawMultiSphere(Wavepen, Wavebrush, myorigin.X, myorigin.Y, X, Y)\r\n end;\r\n end;\r\n\r\n if Shape = 'DropletSphere' then\r\n begin\r\n Canvas.Pen.Mode := pmNotXor;\r\n Canvas.Ellipse(myorigin.X, myorigin.Y, X, Y);\r\n Canvas.Pen.Mode := pmCopy;\r\n if ((myorigin.X <> X) and (myorigin.Y <> Y)) then\r\n begin\r\n if ssAlt in Shift then\r\n DrawDropletSphere(Canvas.Pixels[myorigin.X, myorigin.Y],\r\n Canvas.Pixels[X, Y], myorigin.X, myorigin.Y, X, Y)\r\n else\r\n DrawDropletSphere(Wavepen, Wavebrush, myorigin.X, myorigin.Y, X, Y)\r\n end;\r\n end;\r\n\r\n if Shape = 'WaveSphere' then\r\n begin\r\n Canvas.Pen.Mode := pmNotXor;\r\n Canvas.Ellipse(myorigin.X, myorigin.Y, X, Y);\r\n Canvas.Pen.Mode := pmCopy;\r\n if ((myorigin.X <> X) and (myorigin.Y <> Y)) then\r\n begin\r\n if ssAlt in Shift then\r\n DrawWaveSphere(Canvas.Pixels[myorigin.X, myorigin.Y],\r\n Canvas.Pixels[X, Y], myorigin.X, myorigin.Y, X, Y)\r\n else\r\n DrawWaveSphere(Wavepen, Wavebrush, myorigin.X, myorigin.Y, X, Y)\r\n end;\r\n end;\r\n\r\n if Shape = 'RisingWaveSphere' then\r\n begin\r\n Canvas.Pen.Mode := pmNotXor;\r\n Canvas.Ellipse(myorigin.X, myorigin.Y, X, Y);\r\n Canvas.Pen.Mode := pmCopy;\r\n if ((myorigin.X <> X) and (myorigin.Y <> Y)) then\r\n begin\r\n if ssAlt in Shift then\r\n DrawRisingWaveSphere(Canvas.Pixels[myorigin.X, myorigin.Y],\r\n Canvas.Pixels[X, Y], myorigin.X, myorigin.Y, X, Y)\r\n else\r\n DrawRisingWaveSphere(Wavepen, Wavebrush, myorigin.X, myorigin.Y, X, Y)\r\n end;\r\n end;\r\n\r\n if Shape = 'rectangle' then\r\n begin\r\n if mypen <> pmNotXor then\r\n Canvas.Rectangle(myorigin.X, myorigin.Y, X, Y);\r\n if Stars > 1 then\r\n begin\r\n xs := (X - myorigin.X) div 2 div Stars;\r\n ys := (Y - myorigin.Y) div 2 div Stars;\r\n for i := 1 to Stars - 1 do\r\n begin\r\n Canvas.Rectangle(myorigin.X + i * xs, myorigin.Y + i * ys, X - i * xs, Y - i * ys);\r\n end;\r\n end;\r\n end;\r\n\r\n if Shape = 'maze' then\r\n begin\r\n if mypen <> pmNotXor then\r\n Canvas.Rectangle(myorigin.X, myorigin.Y, X, Y);\r\n xs := (X - myorigin.X) div 10;\r\n ys := (Y - myorigin.Y) div 10;\r\n xt := myorigin.X;\r\n yt := myorigin.Y;\r\n for i := 1 to 10 do\r\n begin\r\n Canvas.MoveTo(xt + i * xs, Y);\r\n Canvas.LineTo(X, Y - i * ys);\r\n Canvas.MoveTo(X, Y - i * ys);\r\n Canvas.LineTo(X - i * xs, yt);\r\n Canvas.MoveTo(X - i * xs, yt);\r\n Canvas.LineTo(xt, yt + i * ys);\r\n Canvas.MoveTo(xt, yt + i * ys);\r\n Canvas.LineTo(xt + i * xs, Y);\r\n end;\r\n end;\r\n\r\n if Shape = 'roundrect' then\r\n begin\r\n if mypen <> pmNotXor then\r\n Canvas.RoundRect(myorigin.X, myorigin.Y, X, Y, myround, myround);\r\n if Stars > 1 then\r\n begin\r\n xs := (X - myorigin.X) div 2 div Stars;\r\n ys := (Y - myorigin.Y) div 2 div Stars;\r\n for i := 1 to Stars - 1 do\r\n begin\r\n Canvas.RoundRect(myorigin.X + i * xs, myorigin.Y + i * ys, X - i * xs, Y - i * ys, myround, myround);\r\n end;\r\n end;\r\n end;\r\n\r\n if Shape = 'Blocks' then\r\n Canvas.FillRect(PointToBlock(X, Y));\r\n\r\n if Shape = 'Star' then\r\n begin\r\n with Canvas do\r\n begin\r\n Pen.Mode := pmNotXor;\r\n PenPos := Point(myorigin.X, myorigin.Y);\r\n LineTo(myprevpoint.X, myprevpoint.Y);\r\n end;\r\n Canvas.Pen.Mode := mypen;\r\n for i := 1 to Stars do\r\n begin\r\n apoint := ReduceVector(myorigin, Point(X, Y), i / Stars);\r\n Star(apoint.X, apoint.Y);\r\n end;\r\n end;\r\n\r\n if Shape = 'spiral' then\r\n begin\r\n with Canvas do\r\n begin\r\n Pen.Mode := pmNotXor;\r\n PenPos := Point(myorigin.X, myorigin.Y);\r\n LineTo(myprevpoint.X, myprevpoint.Y);\r\n end;\r\n Canvas.Pen.Mode := mypen;\r\n apoint := Point(100 * X, 100 * Y);\r\n myorigin.X := 100 * myorigin.X;\r\n myorigin.Y := 100 * myorigin.Y;\r\n for i := 1 to Variant(Spirals * 36) do\r\n begin\r\n apoint := Rotate(myorigin, apoint, spiraldir * pi / 18);\r\n apoint := ReduceVector(myorigin, apoint, spiralfactor);\r\n Canvas.LineTo(apoint.X div 100, apoint.Y div 100);\r\n end;\r\n end;\r\n\r\n if Shape = 'ellipse' then\r\n begin\r\n if mypen <> pmNotXor then\r\n Canvas.Ellipse(myorigin.X, myorigin.Y, X, Y);\r\n if Stars > 1 then\r\n begin\r\n xs := (X - myorigin.X) div 2 div Stars;\r\n ys := (Y - myorigin.Y) div 2 div Stars;\r\n for i := 1 to Stars - 1 do\r\n begin\r\n Canvas.Ellipse(myorigin.X + i * xs, myorigin.Y + i * ys, X - i * xs, Y - i * ys);\r\n end;\r\n end;\r\n end;\r\n\r\n if Shape = 'globe' then\r\n begin\r\n if mypen <> pmNotXor then\r\n Canvas.Ellipse(myorigin.X, myorigin.Y, X, Y);\r\n xs := (X - myorigin.X) div 20;\r\n ys := (Y - myorigin.Y) div 20;\r\n for i := 1 to 10 do\r\n begin\r\n Canvas.Ellipse(myorigin.X + i * xs, myorigin.Y, X - i * xs, Y);\r\n Canvas.Ellipse(myorigin.X, myorigin.Y + i * ys, X, Y - i * ys);\r\n end;\r\n end;\r\n\r\n if Shape = 'chord2' then\r\n begin\r\n mychord[7] := X;\r\n mychord[8] := Y;\r\n Shape := 'chord3';\r\n Canvas.Pen.Mode := pmNotXor;\r\n Canvas.Ellipse(mychord[1], mychord[2], mychord[3], mychord[4]);\r\n Canvas.Pen.Mode := mypen;\r\n Canvas.Chord(mychord[1], mychord[2], mychord[3], mychord[4], mychord[5], mychord[6], mychord[7], mychord[8]);\r\n end;\r\n\r\n if Shape = 'chord1' then\r\n begin\r\n mychord[5] := X;\r\n mychord[6] := Y;\r\n Shape := 'chord2';\r\n end;\r\n\r\n if Shape = 'chord' then\r\n begin\r\n mychord[1] := myorigin.X;\r\n mychord[2] := myorigin.Y;\r\n mychord[3] := X;\r\n mychord[4] := Y;\r\n Shape := 'chord1';\r\n end;\r\n\r\n if Shape = 'arc2' then\r\n begin\r\n mychord[7] := X;\r\n mychord[8] := Y;\r\n Shape := 'arc3';\r\n Canvas.Pen.Mode := pmNotXor;\r\n Canvas.Ellipse(mychord[1], mychord[2], mychord[3], mychord[4]);\r\n Canvas.Pen.Mode := mypen;\r\n Canvas.Arc(mychord[1], mychord[2], mychord[3], mychord[4], mychord[5], mychord[6], mychord[7], mychord[8]);\r\n end;\r\n\r\n if Shape = 'arc1' then\r\n begin\r\n mychord[5] := X;\r\n mychord[6] := Y;\r\n Shape := 'arc2';\r\n end;\r\n\r\n if Shape = 'arc' then\r\n begin\r\n mychord[1] := myorigin.X;\r\n mychord[2] := myorigin.Y;\r\n mychord[3] := X;\r\n mychord[4] := Y;\r\n Shape := 'arc1';\r\n end;\r\n\r\n if Shape = 'pie2' then\r\n begin\r\n mychord[7] := X;\r\n mychord[8] := Y;\r\n Shape := 'pie3';\r\n Canvas.Pen.Mode := pmNotXor;\r\n Canvas.Ellipse(mychord[1], mychord[2], mychord[3], mychord[4]);\r\n Canvas.Pen.Mode := mypen;\r\n Canvas.Pie(mychord[1], mychord[2], mychord[3], mychord[4], mychord[5], mychord[6], mychord[7], mychord[8]);\r\n end;\r\n\r\n if Shape = 'pie1' then\r\n begin\r\n mychord[5] := X;\r\n mychord[6] := Y;\r\n Shape := 'pie2';\r\n end;\r\n\r\n if Shape = 'pie' then\r\n begin\r\n mychord[1] := myorigin.X;\r\n mychord[2] := myorigin.Y;\r\n mychord[3] := X;\r\n mychord[4] := Y;\r\n Shape := 'pie1';\r\n end;\r\n\r\n if Shape = 'skewrect1' then\r\n begin\r\n if mypen <> pmNotXor then\r\n DrawSkew;\r\n Shape := 'skewrect2';\r\n end;\r\n\r\n if Shape = 'skewrect' then\r\n begin\r\n Canvas.PenPos := Point(myorigin.X, myorigin.Y);\r\n if mypen <> pmNotXor then\r\n Canvas.LineTo(X, Y);\r\n myskew[0] := myorigin;\r\n myskew[1] := Point(X, Y);\r\n myskew[2] := myskew[1];\r\n myskew[3] := myskew[0];\r\n Shape := 'skewrect1';\r\n end;\r\n\r\n if Shape = 'triangle1' then\r\n begin\r\n if mypen <> pmNotXor then\r\n DrawTriangle;\r\n Shape := 'triangle2';\r\n end;\r\n\r\n if Shape = 'triangle' then\r\n begin\r\n Canvas.PenPos := Point(myorigin.X, myorigin.Y);\r\n if mypen <> pmNotXor then\r\n Canvas.LineTo(X, Y);\r\n myskew[0] := myorigin;\r\n myskew[1] := Point(X, Y);\r\n myskew[2] := myskew[1];\r\n Shape := 'triangle1';\r\n end;\r\n\r\n if Shape = 'decobar' then\r\n begin\r\n Picture.Bitmap.PixelFormat := pf24bit;\r\n with Canvas do\r\n begin\r\n pw := Pen.Width;\r\n pcolor := Pen.Color;\r\n AColor := ColorToRGB(Wavebrush);\r\n R1 := GetRed(AColor);\r\n r := R1;\r\n G1 := GetGreen(AColor);\r\n g := G1;\r\n B1 := GetBlue(AColor);\r\n b := B1;\r\n AColor := ColorToRGB(Pen.Color);\r\n R2 := GetRed(AColor);\r\n G2 := GetGreen(AColor);\r\n B2 := GetBlue(AColor);\r\n dr := (R1 - R2) / (pw / 3);\r\n dg := (G1 - G2) / (pw / 3);\r\n DB := (B1 - B2) / (pw / 3);\r\n if pw < 30 then\r\n Pen.Width := 30;\r\n for i := 1 to Pen.Width div 3 do\r\n begin\r\n r := r - dr;\r\n g := g - dg;\r\n b := b - DB;\r\n Pen.Color := rgb(Round(r), Round(g), Round(b));\r\n MoveTo(myorigin.X, myorigin.Y);\r\n LineTo(X, Y);\r\n Pen.Width := Pen.Width - 2;\r\n end;\r\n Pen.Width := pw;\r\n Pen.Color := pcolor;\r\n end;\r\n end;\r\n\r\n if Shape = 'decooval' then\r\n begin\r\n Picture.Bitmap.PixelFormat := pf24bit;\r\n with Canvas do\r\n begin\r\n Pen.Mode := pmNotXor;\r\n Ellipse(myorigin.X, myorigin.Y, myprevpoint.X, myprevpoint.Y);\r\n Pen.Mode := pmCopy;\r\n pw := Pen.Width;\r\n Brush.Style := bsClear;\r\n AColor := ColorToRGB(Wavebrush);\r\n R1 := GetRed(AColor);\r\n r := R1;\r\n G1 := GetGreen(AColor);\r\n g := G1;\r\n B1 := GetBlue(AColor);\r\n b := B1;\r\n AColor := ColorToRGB(Wavepen);\r\n R2 := GetRed(AColor);\r\n G2 := GetGreen(AColor);\r\n B2 := GetBlue(AColor);\r\n dr := (R1 - R2) / (pw / 3);\r\n dg := (G1 - G2) / (pw / 3);\r\n DB := (B1 - B2) / (pw / 3);\r\n if pw < 30 then\r\n Pen.Width := 30;\r\n for i := 1 to Pen.Width div 3 do\r\n begin\r\n Pen.Width := Pen.Width - 2;\r\n r := r - dr;\r\n g := g - dg;\r\n b := b - DB;\r\n Pen.Color := rgb(Round(r), Round(g), Round(b));\r\n Ellipse(myorigin.X, myorigin.Y, X, Y);\r\n end;\r\n Pen.Width := pw;\r\n end;\r\n end;\r\n\r\n if (Shape = 'polyline') or (Shape = 'Polygon') then\r\n begin\r\n Canvas.PenPos := Point(myorigin.X, myorigin.Y);\r\n if mypen <> pmNotXor then\r\n Canvas.LineTo(X, Y);\r\n if freepolycount = 0 then\r\n begin\r\n freepoly[0] := myorigin;\r\n inc(freepolycount);\r\n end\r\n else\r\n begin\r\n freepoly[freepolycount] := Point(X, Y);\r\n if freepolycount < 100 then\r\n inc(freepolycount);\r\n end;\r\n end;\r\n\r\n if Shape = 'line' then\r\n begin\r\n Canvas.PenPos := Point(myorigin.X, myorigin.Y);\r\n if mypen <> pmNotXor then\r\n begin\r\n Canvas.LineTo(X, Y);\r\n end;\r\n end;\r\n\r\n if Shape = 'Spiro' then\r\n begin\r\n Canvas.PenPos := Point(myorigin.X, myorigin.Y);\r\n Canvas.Pen.Mode := pmNotXor;\r\n Canvas.LineTo(X, Y);\r\n Canvas.Pen.Mode := mypen;\r\n DrawSpiro(myorigin, Point(X, Y));\r\n end;\r\n\r\n if Shape = 'cone' then\r\n begin\r\n Canvas.PenPos := Point(myorigin.X, myorigin.Y);\r\n Canvas.Pen.Mode := pmNotXor;\r\n Canvas.LineTo(X, Y);\r\n Canvas.Pen.Mode := mypen;\r\n xt := (Picture.Bitmap.Width - 2 * myorigin.X) div 20;\r\n xs := (Picture.Bitmap.Width - 2 * X) div 20;\r\n X := Picture.Bitmap.Width div 2;\r\n with Canvas do\r\n begin\r\n for i := 0 to 10 do\r\n begin\r\n MoveTo(X + i * xt, myorigin.Y);\r\n LineTo(X + i * xs, Y);\r\n MoveTo(X - i * xt, myorigin.Y);\r\n LineTo(X - i * xs, Y);\r\n end;\r\n MoveTo(X + 10 * xt, myorigin.Y);\r\n LineTo(X - 10 * xt, myorigin.Y);\r\n MoveTo(X + 10 * xs, Y);\r\n LineTo(X - 10 * xs, Y);\r\n end;\r\n end;\r\n\r\n {if Shape='polybezier' then\r\n begin\r\n Canvas.PenPos:=Point(myorigin.X,myorigin.Y);\r\n if mypen<>pmNotXor then\r\n begin\r\n mybezier[0]:=myorigin;\r\n mybezier[3]:=Point(X,Y);\r\n if not bezierfix1 then\r\n begin\r\n mybezier[1].X:=mybezier[0].X;\r\n mybezier[1].Y:=mybezier[3].Y;\r\n end;\r\n if not bezierfix2 then\r\n begin\r\n mybezier[2].X:=mybezier[3].X;\r\n mybezier[2].Y:=mybezier[0].Y;\r\n end;\r\n Canvas.PolyBezier(mybezier);\r\n bezierfix1:=False;\r\n bezierfix2:=False;\r\n end;\r\n end;}\r\n\r\n if Shape = 'bezier2' then\r\n begin\r\n Canvas.PenPos := Point(myorigin.X, myorigin.Y);\r\n if mypen <> pmNotXor then\r\n begin\r\n mybezier[2] := Point(X, Y);\r\n Canvas.PolyBezier(mybezier);\r\n end;\r\n Shape := 'bezier3';\r\n end;\r\n\r\n if Shape = 'bezier1' then\r\n Shape := 'bezier2';\r\n if Shape = 'bezier' then\r\n Shape := 'bezier1';\r\n if Shape = 'bezier3' then\r\n Shape := 'bezier';\r\n if Shape = 'floodfill' then\r\n begin\r\n if ssAlt in Shift then\r\n Canvas.FloodFill(X, Y, Canvas.Pen.Color, fsborder)\r\n else\r\n Canvas.FloodFill(X, Y, Canvas.Pixels[X, Y], fssurface);\r\n end;\r\n if Shape = 'snapshot' then\r\n begin\r\n with Canvas do\r\n begin\r\n Pen.Mode := pmNotXor;\r\n Pen.Style := psDot;\r\n Rectangle(myorigin.X, myorigin.Y, X, Y);\r\n Pen.Style := psSolid;\r\n end;\r\n mycliprect := Rect(myorigin.X, myorigin.Y, X, Y);\r\n Canvas.Brush.Style := myoldbrushstyle;\r\n Canvas.Pen.Width := myoldpenwidth;\r\n Shape := '';\r\n end;\r\n\r\n if Shape = 'bars' then\r\n begin\r\n with Canvas do\r\n begin\r\n Pen.Mode := pmNotXor;\r\n Pen.Style := psDot;\r\n Rectangle(myorigin.X, myorigin.Y, X, Y);\r\n Pen.Style := psSolid;\r\n end;\r\n DrawBars(myorigin.X, myorigin.Y, X, Y);\r\n end;\r\n\r\n if Shape = 'border' then\r\n begin\r\n with Canvas do\r\n begin\r\n Pen.Mode := pmNotXor;\r\n Pen.Style := psDot;\r\n Rectangle(myorigin.X, myorigin.Y, X, Y);\r\n Pen.Style := psSolid;\r\n end;\r\n Drawborders(myorigin.X, myorigin.Y, X, Y);\r\n end;\r\n\r\n if Shape = 'paste' then\r\n begin\r\n myrect := Rect(0, 0, 0, 0);\r\n myrect.Left := X;\r\n myrect.Top := Y;\r\n myrect.Right := X + mycliprect.Right - mycliprect.Left;\r\n myrect.Bottom := Y + mycliprect.Bottom - mycliprect.Top;\r\n Canvas.CopyRect(myrect, Canvas, mycliprect);\r\n end;\r\n\r\n if Shape = 'pastecolor' then\r\n begin\r\n clipcm := cmsrccopy;\r\n SetClip(clWhite);\r\n CopyClip;\r\n FX.ExtractColor(Clip, Canvas.Brush.Color);\r\n Canvas.Draw(X, Y, Clip);\r\n Clip.Transparent := False;\r\n end;\r\n\r\n if Shape = 'pastecolorx' then\r\n begin\r\n clipcm := cmsrccopy;\r\n SetClip(clWhite);\r\n CopyClip;\r\n FX.ExcludeColor(Clip, Canvas.Brush.Color);\r\n Canvas.Draw(X, Y, Clip);\r\n Clip.Transparent := False;\r\n end;\r\n\r\n if Shape = 'zoomkeepbrush' then\r\n begin\r\n Shape := 'freehand';\r\n Canvas.Pen.Width := 2;\r\n end;\r\n\r\n if Shape = 'paintpick' then\r\n begin\r\n if ssAlt in Shift then\r\n Canvas.Brush.Color := MixColors(\r\n Canvas.Pixels[X - 5, Y],\r\n Canvas.Pixels[X + 5, Y])\r\n else\r\n Canvas.Brush.Color := Canvas.Pixels[X, Y];\r\n ColorPicked(Canvas.Brush.Color);\r\n Shape := '';\r\n end;\r\n Canvas.Pen.Mode := mypen;\r\n if not ((Shape = 'Polygon') or\r\n (Shape = 'polyline') or\r\n (Shape = 'polybezier')) then\r\n begin\r\n myDraw := False;\r\n end;\r\nend;\r\n\r\nprocedure TJvDrawImage.BuildShapeList;\r\nconst\r\n Names: array [0..99] of PChar =\r\n (\r\n 'airbrush',\r\n 'arc',\r\n 'bars',\r\n 'bezier',\r\n 'Blocks',\r\n 'Bluebrush',\r\n 'Blurcurves',\r\n 'BlurLines',\r\n 'Blurovals',\r\n 'Blurpoly',\r\n 'BlurRects',\r\n 'border',\r\n 'brightnessbrush',\r\n 'chord',\r\n 'cloneall',\r\n 'clonenottarget',\r\n 'cmirror',\r\n 'cone',\r\n 'contrastbrush',\r\n 'cube',\r\n 'darkerbrush',\r\n 'decobar',\r\n 'decoval',\r\n 'DropletSphere',\r\n 'ellipse',\r\n 'fisheyebrush',\r\n 'fisheyefixbrush',\r\n 'floodfill',\r\n 'freehand',\r\n 'globe',\r\n 'gradientbrush',\r\n 'graybrush',\r\n 'Greenbrush',\r\n 'halfBluebrush',\r\n 'halfGreenbrush',\r\n 'halfredbrush',\r\n 'hmirror',\r\n 'interColumn',\r\n 'Interprect',\r\n 'interSphere',\r\n 'lighterbrush',\r\n 'line',\r\n 'maze',\r\n 'mbBottom',\r\n 'mbDiamond',\r\n 'mbHor',\r\n 'mbHorBox',\r\n 'mbHorOval',\r\n 'mbRound',\r\n 'mbRound2',\r\n 'mbSplitRound',\r\n 'mbSplitWaste',\r\n 'mbTop',\r\n 'mbVerBox',\r\n 'mbVerOval',\r\n 'mbWaste',\r\n 'mirror4',\r\n 'mixbrush',\r\n 'MultiSphere',\r\n 'notBluebrush',\r\n 'notGreenbrush',\r\n 'notredbrush',\r\n 'paintpick',\r\n 'paste',\r\n 'pastecolor',\r\n 'pastecolorx',\r\n 'pie',\r\n 'polybezier',\r\n 'Polygon',\r\n 'polyline',\r\n 'rangemove',\r\n 'rangesmear',\r\n 'rectangle',\r\n 'redbrush',\r\n 'rimplebrush',\r\n 'RisingWaveSphere',\r\n 'rollmixbrush',\r\n 'rotatebrush',\r\n 'roundrect',\r\n 'saturationbrush',\r\n 'skewrect',\r\n 'sline',\r\n 'smoothbrush',\r\n 'snapshot',\r\n 'spiral',\r\n 'Spiro',\r\n 'Star',\r\n 'sym',\r\n 'Texcurves',\r\n 'TexLines',\r\n 'Texovals',\r\n 'Texpoly',\r\n 'TexRects',\r\n 'transcopy',\r\n 'triangle',\r\n 'twistbrush',\r\n 'vmirror',\r\n 'WaveSphere',\r\n 'zoombrush',\r\n 'zoomkeepbrush'\r\n );\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := Low(Names) to High(Names) do\r\n Shapes.Append(Names[I]);\r\nend;\r\n\r\nprocedure TJvDrawImage.SetPolygonChecked(const Value: Boolean);\r\nbegin\r\n FPolygonChecked := Value;\r\nend;\r\n\r\nprocedure TJvDrawImage.ColorPicked(AColor: TColor);\r\nbegin\r\n if Assigned(FOnColorPicked) then\r\n FOnColorPicked(Self, AColor);\r\nend;\r\n\r\nprocedure TJvDrawImage.SetOnColorPicked(const Value: TColorPicked);\r\nbegin\r\n FOnColorPicked := Value;\r\nend;\r\n\r\nprocedure TJvDrawImage.SetShape(const Value: string);\r\nbegin\r\n FShape := Value;\r\nend;\r\n\r\nprocedure TJvDrawImage.Loaded;\r\nbegin\r\n inherited Loaded;\r\n autosize := True;\r\n Picture.Bitmap.Height := 256;\r\n Picture.Bitmap.Width := 256;\r\n Canvas.Brush.Color := clWhite;\r\n Picture.Bitmap.Canvas.FillRect(Rect(0, 0, Picture.Bitmap.Width, Picture.Bitmap.Height));\r\n Canvas.Brush.Style := bsClear;\r\n Canvas.Pen.Color := clWhite;\r\n Canvas.MoveTo(100, 100);\r\n Canvas.LineTo(128, 128);\r\n Canvas.Pen.Color := clBlack;\r\nend;\r\n\r\nprocedure TJvDrawImage.SetAirBrush(const Value: TJvAirBrush);\r\nbegin\r\n FAirBrush.Assign(Value);\r\nend;\r\n\r\nprocedure TJvDrawImage.SetTransformer(const Value: TJvPaintFX);\r\nbegin\r\n FX.Assign(Value);\r\nend;\r\n\r\nprocedure TJvDrawImage.SetBlocks(const Value: Integer);\r\nbegin\r\n FBlocks := Value;\r\nend;\r\n\r\nprocedure TJvDrawImage.SetSpirals(const Value: Integer);\r\nbegin\r\n FSpirals := Value;\r\nend;\r\n\r\nprocedure TJvDrawImage.SetStarPoints(const Value: Integer);\r\nbegin\r\n FStarPoints := Value;\r\nend;\r\n\r\nprocedure TJvDrawImage.SetStars(const Value: Integer);\r\nbegin\r\n FStars := Value;\r\nend;\r\n\r\nprocedure TJvDrawImage.contrastBarChange(Sender: TObject);\r\nbegin\r\n ClipAll;\r\n Clip.PixelFormat := pf24bit;\r\n FX.contrast(Clip, painterEffectsF.EBar.Position);\r\n QuickPreviewF.Show;\r\n QuickPreviewF.PreviewImage.Picture.Bitmap.Assign(Clip);\r\n QuickPreviewF.PreviewImage.Update;\r\nend;\r\n\r\nprocedure TJvDrawImage.saturationBarChange(Sender: TObject);\r\nbegin\r\n ClipAll;\r\n Clip.PixelFormat := pf24bit;\r\n FX.saturation(Clip, painterEffectsF.EBar.Position);\r\n QuickPreviewF.Show;\r\n QuickPreviewF.PreviewImage.Picture.Bitmap.Assign(Clip);\r\n QuickPreviewF.PreviewImage.Update;\r\nend;\r\n\r\nprocedure TJvDrawImage.lightnessBarChange(Sender: TObject);\r\nbegin\r\n ClipAll;\r\n Clip.PixelFormat := pf24bit;\r\n FX.lightness(Clip, painterEffectsF.Ebar.Position);\r\n QuickPreviewF.Show;\r\n QuickPreviewF.PreviewImage.Picture.Bitmap.Assign(Clip);\r\n QuickPreviewF.PreviewImage.Update;\r\nend;\r\n\r\nprocedure TJvDrawImage.BlurBarChange(Sender: TObject);\r\nbegin\r\n ClipAll;\r\n Clip.PixelFormat := pf24bit;\r\n FX.GaussianBlur(Clip, painterEffectsF.Ebar.Position);\r\n QuickPreviewF.Show;\r\n QuickPreviewF.PreviewImage.Picture.Bitmap.Assign(Clip);\r\n QuickPreviewF.PreviewImage.Update;\r\nend;\r\n\r\nprocedure TJvDrawImage.splitBlurBarChange(Sender: TObject);\r\nbegin\r\n ClipAll;\r\n Clip.PixelFormat := pf24bit;\r\n FX.SplitBlur(Clip, painterEffectsF.Ebar.Position);\r\n QuickPreviewF.Show;\r\n QuickPreviewF.PreviewImage.Picture.Bitmap.Assign(Clip);\r\n QuickPreviewF.PreviewImage.Update;\r\nend;\r\n\r\nprocedure TJvDrawImage.colornoiseBarChange(Sender: TObject);\r\nbegin\r\n ClipAll;\r\n Clip.PixelFormat := pf24bit;\r\n FX.AddColorNoise(Clip, painterEffectsF.Ebar.Position);\r\n QuickPreviewF.Show;\r\n QuickPreviewF.PreviewImage.Picture.Bitmap.Assign(Clip);\r\n QuickPreviewF.PreviewImage.Update;\r\nend;\r\n\r\nprocedure TJvDrawImage.mononoiseBarChange(Sender: TObject);\r\nbegin\r\n ClipAll;\r\n Clip.PixelFormat := pf24bit;\r\n FX.AddmonoNoise(Clip, painterEffectsF.Ebar.Position);\r\n QuickPreviewF.Show;\r\n QuickPreviewF.PreviewImage.Picture.Bitmap.Assign(Clip);\r\n QuickPreviewF.PreviewImage.Update;\r\nend;\r\n\r\nprocedure TJvDrawImage.smoothBarChange(Sender: TObject);\r\nbegin\r\n ClipAll;\r\n Clip.PixelFormat := pf24bit;\r\n FX.Smooth(Clip, painterEffectsF.EBar.Position);\r\n QuickPreviewF.Show;\r\n QuickPreviewF.PreviewImage.Picture.Bitmap.Assign(Clip);\r\n QuickPreviewF.PreviewImage.Update;\r\nend;\r\n\r\nprocedure TJvDrawImage.Effects;\r\nbegin\r\n with PainterEffectsF do\r\n begin\r\n cxbar.Max := Width;\r\n cybar.Max := Height;\r\n cxbar.Position := cxbar.Max div 2;\r\n cybar.Position := cybar.Max div 2;\r\n Show;\r\n end;\r\nend;\r\n\r\nprocedure TJvDrawImage.seamBarChange;\r\nbegin\r\n ClipAll;\r\n Clip.PixelFormat := pf24bit;\r\n FX.MakeSeamlessClip(Clip, painterEffectsF.Ebar.Position);\r\n QuickPreviewF.Show;\r\n QuickPreviewF.PreviewImage.Picture.Bitmap.Assign(Clip);\r\n QuickPreviewF.PreviewImage.Update;\r\nend;\r\n\r\nprocedure TJvDrawImage.mosaicBarChange;\r\nvar\r\n am: Integer;\r\nbegin\r\n ClipAll;\r\n Clip.PixelFormat := pf24bit;\r\n am := painterEffectsF.Ebar.Position;\r\n FX.mosaic(Clip, am);\r\n QuickPreviewF.Show;\r\n QuickPreviewF.PreviewImage.Picture.Bitmap.Assign(Clip);\r\n QuickPreviewF.PreviewImage.Update;\r\nend;\r\n\r\nprocedure TJvDrawImage.twistBarChange;\r\nvar\r\n bm2: TBitmap;\r\n am: Integer;\r\nbegin\r\n ClipAll;\r\n Clip.PixelFormat := pf24bit;\r\n bm2 := TBitmap.Create;\r\n bm2.Width := Clip.Width;\r\n bm2.Height := Clip.Height;\r\n bm2.pixelformat := pf24bit;\r\n am := painterEffectsF.Ebar.Position;\r\n FX.twist(Clip, bm2, am);\r\n QuickPreviewF.Show;\r\n QuickPreviewF.PreviewImage.Picture.Bitmap.Assign(bm2);\r\n QuickPreviewF.PreviewImage.Update;\r\n bm2.Free;\r\nend;\r\n\r\nprocedure TJvDrawImage.FisheyeBarChange;\r\nvar\r\n bm2: TBitmap;\r\n am: single;\r\nbegin\r\n ClipAll;\r\n Clip.PixelFormat := pf24bit;\r\n bm2 := TBitmap.Create;\r\n bm2.Width := Clip.Width;\r\n bm2.Height := Clip.Height;\r\n bm2.pixelformat := pf24bit;\r\n am := painterEffectsF.Ebar.Position / 100;\r\n FX.Fisheye(Clip, bm2, am);\r\n QuickPreviewF.Show;\r\n QuickPreviewF.PreviewImage.Picture.Bitmap.Assign(bm2);\r\n QuickPreviewF.PreviewImage.Update;\r\n bm2.Free;\r\nend;\r\n\r\nprocedure TJvDrawImage.WaveBarChange;\r\nvar\r\n am: Integer;\r\nbegin\r\n ClipAll;\r\n Clip.PixelFormat := pf24bit;\r\n am := painterEffectsF.Ebar.Position;\r\n FX.Wave(Clip, am, 0, 0);\r\n QuickPreviewF.Show;\r\n QuickPreviewF.PreviewImage.Picture.Bitmap.Assign(Clip);\r\n QuickPreviewF.PreviewImage.Update;\r\nend;\r\n\r\nprocedure TJvDrawImage.WaveExtraChange;\r\nvar\r\n am: Integer;\r\nbegin\r\n ClipAll;\r\n Clip.PixelFormat := pf24bit;\r\n am := painterEffectsF.EBar.Position;\r\n FX.Wave(Clip, am, 0, 1);\r\n QuickPreviewF.Show;\r\n QuickPreviewF.PreviewImage.Picture.Bitmap.Assign(Clip);\r\n QuickPreviewF.PreviewImage.Update;\r\nend;\r\n\r\nprocedure TJvDrawImage.WaveInfChange;\r\nvar\r\n wa, inf: Integer;\r\nbegin\r\n ClipAll;\r\n Clip.PixelFormat := pf24bit;\r\n inf := painterEffectsF.Ebar.Position;\r\n wa := paintereffectsF.ExtraBar.Position;\r\n FX.Wave(Clip, wa, inf, 2);\r\n QuickPreviewF.Show;\r\n QuickPreviewF.PreviewImage.Picture.Bitmap.Assign(Clip);\r\n QuickPreviewF.PreviewImage.Update;\r\nend;\r\n\r\nprocedure TJvDrawImage.RotateBar;\r\nvar\r\n am: Extended;\r\n Dst: TBitmap;\r\n dx, dy: Integer;\r\nbegin\r\n ClipAll;\r\n Clip.PixelFormat := pf24bit;\r\n Dst := TBitmap.Create;\r\n Dst.Width := Clip.Width;\r\n Dst.Height := Clip.Height;\r\n Dst.pixelformat := pf24bit;\r\n with PainterEffectsF do\r\n begin\r\n am := Ebar.Position;\r\n dx := cxBar.Position;\r\n dy := cyBar.Position;\r\n end;\r\n FX.SmoothRotate(Clip, Dst, dx, dy, am);\r\n QuickPreviewF.Show;\r\n QuickPreviewF.PreviewImage.Picture.Bitmap.Assign(Dst);\r\n QuickPreviewF.PreviewImage.Update;\r\n Dst.Free;\r\nend;\r\n\r\nprocedure TJvDrawImage.XFormABarChange;\r\nvar\r\n am: Integer;\r\nbegin\r\n ClipAll;\r\n Clip.PixelFormat := pf24bit;\r\n am := painterEffectsF.Ebar.Position;\r\n XFormA(am);\r\n QuickPreviewF.Show;\r\n QuickPreviewF.PreviewImage.Picture.Bitmap.Assign(Clip);\r\n QuickPreviewF.PreviewImage.Update;\r\nend;\r\n\r\nprocedure TJvDrawImage.MarbleBarChange;\r\nvar\r\n turbulence: Integer;\r\n Dst: TBitmap;\r\n scale: Extended;\r\nbegin\r\n ClipAll;\r\n Clip.PixelFormat := pf24bit;\r\n Dst := TBitmap.Create;\r\n Dst.PixelFormat := pf24bit;\r\n Dst.Width := Clip.Width;\r\n Dst.Height := Clip.Height;\r\n scale := painterEffectsF.ExtraBar.Position;\r\n turbulence := painterEffectsF.Ebar.Position;\r\n FX.Marble(Clip, Dst, scale, turbulence);\r\n QuickPreviewF.Show;\r\n QuickPreviewF.PreviewImage.Picture.Bitmap.Assign(Dst);\r\n QuickPreviewF.PreviewImage.Update;\r\n Dst.Free;\r\nend;\r\n\r\nprocedure TJvDrawImage.Marble2BarChange;\r\nvar\r\n turbulence: Integer;\r\n Dst: TBitmap;\r\n scale: Extended;\r\nbegin\r\n ClipAll;\r\n Clip.PixelFormat := pf24bit;\r\n Dst := TBitmap.Create;\r\n Dst.PixelFormat := pf24bit;\r\n Dst.Width := Clip.Width;\r\n Dst.Height := Clip.Height;\r\n scale := painterEffectsF.ExtraBar.Position;\r\n turbulence := painterEffectsF.Ebar.Position;\r\n FX.Marble2(Clip, Dst, scale, turbulence);\r\n QuickPreviewF.Show;\r\n QuickPreviewF.PreviewImage.Picture.Bitmap.Assign(Dst);\r\n QuickPreviewF.PreviewImage.Update;\r\n Dst.Free;\r\nend;\r\n\r\nprocedure TJvDrawImage.Marble3BarChange;\r\nvar\r\n turbulence: Integer;\r\n Dst: TBitmap;\r\n scale: Extended;\r\nbegin\r\n ClipAll;\r\n Clip.PixelFormat := pf24bit;\r\n Dst := TBitmap.Create;\r\n Dst.PixelFormat := pf24bit;\r\n Dst.Width := Clip.Width;\r\n Dst.Height := Clip.Height;\r\n scale := painterEffectsF.ExtraBar.Position;\r\n turbulence := painterEffectsF.Ebar.Position;\r\n FX.Marble3(Clip, Dst, scale, turbulence);\r\n QuickPreviewF.Show;\r\n QuickPreviewF.PreviewImage.Picture.Bitmap.Assign(Dst);\r\n QuickPreviewF.PreviewImage.Update;\r\n Dst.Free;\r\nend;\r\n\r\nprocedure TJvDrawImage.Marble4BarChange;\r\nvar\r\n turbulence: Integer;\r\n Dst: TBitmap;\r\n scale: Extended;\r\nbegin\r\n ClipAll;\r\n Clip.PixelFormat := pf24bit;\r\n Dst := TBitmap.Create;\r\n Dst.PixelFormat := pf24bit;\r\n Dst.Width := Clip.Width;\r\n Dst.Height := Clip.Height;\r\n scale := painterEffectsF.ExtraBar.Position;\r\n turbulence := painterEffectsF.Ebar.Position;\r\n FX.Marble4(Clip, Dst, scale, turbulence);\r\n QuickPreviewF.Show;\r\n QuickPreviewF.PreviewImage.Picture.Bitmap.Assign(Dst);\r\n QuickPreviewF.PreviewImage.Update;\r\n Dst.Free;\r\nend;\r\n\r\nprocedure TJvDrawImage.Marble5BarChange;\r\nvar\r\n turbulence: Integer;\r\n Dst: TBitmap;\r\n scale: Extended;\r\nbegin\r\n ClipAll;\r\n Clip.PixelFormat := pf24bit;\r\n Dst := TBitmap.Create;\r\n Dst.PixelFormat := pf24bit;\r\n Dst.Width := Clip.Width;\r\n Dst.Height := Clip.Height;\r\n scale := painterEffectsF.ExtraBar.Position;\r\n turbulence := painterEffectsF.EBar.Position;\r\n FX.Marble5(Clip, Dst, scale, turbulence);\r\n QuickPreviewF.Show;\r\n QuickPreviewF.PreviewImage.Picture.Bitmap.Assign(Dst);\r\n QuickPreviewF.PreviewImage.Update;\r\n Dst.Free;\r\nend;\r\n\r\nprocedure TJvDrawImage.Marble6barChange;\r\nvar\r\n turbulence: Integer;\r\n Dst: TBitmap;\r\n scale: Extended;\r\nbegin\r\n ClipAll;\r\n Clip.PixelFormat := pf24bit;\r\n Dst := TBitmap.Create;\r\n Dst.PixelFormat := pf24bit;\r\n Dst.Width := Clip.Width;\r\n Dst.Height := Clip.Height;\r\n scale := painterEffectsF.ExtraBar.Position;\r\n turbulence := painterEffectsF.Ebar.Position;\r\n FX.Marble6(Clip, Dst, scale, turbulence);\r\n QuickPreviewF.Show;\r\n QuickPreviewF.PreviewImage.Picture.Bitmap.Assign(Dst);\r\n QuickPreviewF.PreviewImage.Update;\r\n Dst.Free;\r\nend;\r\n\r\nprocedure TJvDrawImage.Marble7barChange;\r\nvar\r\n turbulence: Integer;\r\n Dst: TBitmap;\r\n scale: Extended;\r\nbegin\r\n ClipAll;\r\n Clip.PixelFormat := pf24bit;\r\n Dst := TBitmap.Create;\r\n Dst.PixelFormat := pf24bit;\r\n Dst.Width := Clip.Width;\r\n Dst.Height := Clip.Height;\r\n scale := painterEffectsF.ExtraBar.Position;\r\n turbulence := painterEffectsF.Ebar.Position;\r\n FX.Marble7(Clip, Dst, scale, turbulence);\r\n QuickPreviewF.Show;\r\n QuickPreviewF.PreviewImage.Picture.Bitmap.Assign(Dst);\r\n QuickPreviewF.PreviewImage.Update;\r\n Dst.Free;\r\nend;\r\n\r\nprocedure TJvDrawImage.Marble8barChange;\r\nvar\r\n turbulence: Integer;\r\n Dst: TBitmap;\r\n scale: Extended;\r\nbegin\r\n ClipAll;\r\n Clip.PixelFormat := pf24bit;\r\n Dst := TBitmap.Create;\r\n Dst.PixelFormat := pf24bit;\r\n Dst.Width := Clip.Width;\r\n Dst.Height := Clip.Height;\r\n scale := painterEffectsF.ExtraBar.Position;\r\n turbulence := painterEffectsF.Ebar.Position;\r\n FX.Marble8(Clip, Dst, scale, turbulence);\r\n QuickPreviewF.Show;\r\n QuickPreviewF.PreviewImage.Picture.Bitmap.Assign(Dst);\r\n QuickPreviewF.PreviewImage.Update;\r\n Dst.Free;\r\nend;\r\n\r\nprocedure TJvDrawImage.embossbarChange;\r\nbegin\r\n ClipAll;\r\n Clip.PixelFormat := pf24bit;\r\n FX.Emboss(Clip);\r\n QuickPreviewF.Show;\r\n QuickPreviewF.PreviewImage.Picture.Bitmap.Assign(Clip);\r\n QuickPreviewF.PreviewImage.Update;\r\nend;\r\n\r\nprocedure TJvDrawImage.filterRedbarChange;\r\nbegin\r\n ClipAll;\r\n Clip.PixelFormat := pf24bit;\r\n FX.filterRed(Clip, paintereffectsF.ExtraBar.Position, painterEffectsF.EBar.Position);\r\n QuickPreviewF.Show;\r\n QuickPreviewF.PreviewImage.Picture.Bitmap.Assign(Clip);\r\n QuickPreviewF.PreviewImage.Update;\r\nend;\r\n\r\nprocedure TJvDrawImage.filterGreenbarChange;\r\nbegin\r\n ClipAll;\r\n Clip.PixelFormat := pf24bit;\r\n FX.filterGreen(Clip, paintereffectsF.ExtraBar.Position, painterEffectsF.EBar.Position);\r\n QuickPreviewF.Show;\r\n QuickPreviewF.PreviewImage.Picture.Bitmap.Assign(Clip);\r\n QuickPreviewF.PreviewImage.Update;\r\nend;\r\n\r\nprocedure TJvDrawImage.filterBluebarChange;\r\nbegin\r\n ClipAll;\r\n Clip.PixelFormat := pf24bit;\r\n FX.filterBlue(Clip, paintereffectsF.ExtraBar.Position, painterEffectsF.EBar.Position);\r\n QuickPreviewF.Show;\r\n QuickPreviewF.PreviewImage.Picture.Bitmap.Assign(Clip);\r\n QuickPreviewF.PreviewImage.Update;\r\nend;\r\n\r\nprocedure TJvDrawImage.FilterXRedbarChange;\r\nbegin\r\n ClipAll;\r\n Clip.PixelFormat := pf24bit;\r\n FX.FilterXRed(Clip, paintereffectsF.ExtraBar.Position, painterEffectsF.EBar.Position);\r\n QuickPreviewF.Show;\r\n QuickPreviewF.PreviewImage.Picture.Bitmap.Assign(Clip);\r\n QuickPreviewF.PreviewImage.Update;\r\nend;\r\n\r\nprocedure TJvDrawImage.FilterXGreenbarChange;\r\nbegin\r\n ClipAll;\r\n Clip.PixelFormat := pf24bit;\r\n FX.FilterXGreen(Clip, paintereffectsF.ExtraBar.Position, painterEffectsF.EBar.Position);\r\n QuickPreviewF.Show;\r\n QuickPreviewF.PreviewImage.Picture.Bitmap.Assign(Clip);\r\n QuickPreviewF.PreviewImage.Update;\r\nend;\r\n\r\nprocedure TJvDrawImage.FilterXBluebarChange;\r\nbegin\r\n ClipAll;\r\n Clip.PixelFormat := pf24bit;\r\n FX.FilterXBlue(Clip, paintereffectsF.ExtraBar.Position, painterEffectsF.EBar.Position);\r\n QuickPreviewF.Show;\r\n QuickPreviewF.PreviewImage.Picture.Bitmap.Assign(Clip);\r\n QuickPreviewF.PreviewImage.Update;\r\nend;\r\n\r\nprocedure TJvDrawImage.SqueezeHorbarChange;\r\nvar\r\n bm2: TBitmap;\r\n am: Integer;\r\nbegin\r\n ClipAll;\r\n Clip.PixelFormat := pf24bit;\r\n bm2 := TBitmap.Create;\r\n bm2.Width := Clip.Width;\r\n bm2.Height := Clip.Height;\r\n bm2.pixelformat := pf24bit;\r\n am := painterEffectsF.Ebar.Position;\r\n FX.SqueezeHor(Clip, bm2, am, mbHor);\r\n QuickPreviewF.Show;\r\n QuickPreviewF.PreviewImage.Picture.Bitmap.Assign(bm2);\r\n QuickPreviewF.PreviewImage.Update;\r\n bm2.Free;\r\nend;\r\n\r\nprocedure TJvDrawImage.SqueezeTopbarChange;\r\nvar\r\n bm2: TBitmap;\r\n am: Integer;\r\nbegin\r\n ClipAll;\r\n Clip.PixelFormat := pf24bit;\r\n bm2 := TBitmap.Create;\r\n bm2.Width := Clip.Width;\r\n bm2.Height := Clip.Height;\r\n bm2.pixelformat := pf24bit;\r\n am := painterEffectsF.Ebar.Position;\r\n FX.SqueezeHor(Clip, bm2, am, mbTop);\r\n QuickPreviewF.Show;\r\n QuickPreviewF.PreviewImage.Picture.Bitmap.Assign(bm2);\r\n QuickPreviewF.PreviewImage.Update;\r\n bm2.Free;\r\nend;\r\n\r\nprocedure TJvDrawImage.SqueezeBotbarChange;\r\nvar\r\n bm2: TBitmap;\r\n am: Integer;\r\nbegin\r\n ClipAll;\r\n Clip.PixelFormat := pf24bit;\r\n bm2 := TBitmap.Create;\r\n bm2.Width := Clip.Width;\r\n bm2.Height := Clip.Height;\r\n bm2.pixelformat := pf24bit;\r\n am := painterEffectsF.Ebar.Position;\r\n FX.SqueezeHor(Clip, bm2, am, mbBottom);\r\n QuickPreviewF.Show;\r\n QuickPreviewF.PreviewImage.Picture.Bitmap.Assign(bm2);\r\n QuickPreviewF.PreviewImage.Update;\r\n bm2.Free;\r\nend;\r\n\r\nprocedure TJvDrawImage.SqueezeDiamondbarChange;\r\nvar\r\n bm2: TBitmap;\r\n am: Integer;\r\nbegin\r\n ClipAll;\r\n Clip.PixelFormat := pf24bit;\r\n bm2 := TBitmap.Create;\r\n bm2.Width := Clip.Width;\r\n bm2.Height := Clip.Height;\r\n bm2.pixelformat := pf24bit;\r\n am := painterEffectsF.Ebar.Position;\r\n FX.SqueezeHor(Clip, bm2, am, mbDiamond);\r\n QuickPreviewF.Show;\r\n QuickPreviewF.PreviewImage.Picture.Bitmap.Assign(bm2);\r\n QuickPreviewF.PreviewImage.Update;\r\n bm2.Free;\r\nend;\r\n\r\nprocedure TJvDrawImage.SqueezeWastebarChange;\r\nvar\r\n bm2: TBitmap;\r\n am: Integer;\r\nbegin\r\n ClipAll;\r\n Clip.PixelFormat := pf24bit;\r\n bm2 := TBitmap.Create;\r\n bm2.Width := Clip.Width;\r\n bm2.Height := Clip.Height;\r\n bm2.pixelformat := pf24bit;\r\n am := painterEffectsF.Ebar.Position;\r\n FX.SqueezeHor(Clip, bm2, am, mbwaste);\r\n QuickPreviewF.Show;\r\n QuickPreviewF.PreviewImage.Picture.Bitmap.Assign(bm2);\r\n QuickPreviewF.PreviewImage.Update;\r\n bm2.Free;\r\nend;\r\n\r\nprocedure TJvDrawImage.SqueezeRoundbarChange;\r\nvar\r\n bm2: TBitmap;\r\n am: Integer;\r\nbegin\r\n ClipAll;\r\n Clip.PixelFormat := pf24bit;\r\n bm2 := TBitmap.Create;\r\n bm2.Width := Clip.Width;\r\n bm2.Height := Clip.Height;\r\n bm2.pixelformat := pf24bit;\r\n am := painterEffectsF.Ebar.Position;\r\n FX.SqueezeHor(Clip, bm2, am, mbRound);\r\n QuickPreviewF.Show;\r\n QuickPreviewF.PreviewImage.Picture.Bitmap.Assign(bm2);\r\n QuickPreviewF.PreviewImage.Update;\r\n bm2.Free;\r\nend;\r\n\r\nprocedure TJvDrawImage.SqueezeRound2barChange;\r\nvar\r\n bm2: TBitmap;\r\n am: Integer;\r\nbegin\r\n ClipAll;\r\n Clip.PixelFormat := pf24bit;\r\n bm2 := TBitmap.Create;\r\n bm2.Width := Clip.Width;\r\n bm2.Height := Clip.Height;\r\n bm2.pixelformat := pf24bit;\r\n am := painterEffectsF.Ebar.Position;\r\n FX.SqueezeHor(Clip, bm2, am, mbround2);\r\n QuickPreviewF.Show;\r\n QuickPreviewF.PreviewImage.Picture.Bitmap.Assign(bm2);\r\n QuickPreviewF.PreviewImage.Update;\r\n bm2.Free;\r\nend;\r\n\r\nprocedure TJvDrawImage.SplitRoundbarChange;\r\nvar\r\n bm2: TBitmap;\r\n am: Integer;\r\nbegin\r\n ClipAll;\r\n Clip.PixelFormat := pf24bit;\r\n bm2 := TBitmap.Create;\r\n bm2.Width := Clip.Width;\r\n bm2.Height := Clip.Height;\r\n bm2.pixelformat := pf24bit;\r\n am := painterEffectsF.Ebar.Position;\r\n FX.SplitRound(Clip, bm2, am, mbSplitRound);\r\n QuickPreviewF.Show;\r\n QuickPreviewF.PreviewImage.Picture.Bitmap.Assign(bm2);\r\n QuickPreviewF.PreviewImage.Update;\r\n bm2.Free;\r\nend;\r\n\r\nprocedure TJvDrawImage.SplitWastebarChange;\r\nvar\r\n bm2: TBitmap;\r\n am: Integer;\r\nbegin\r\n ClipAll;\r\n Clip.PixelFormat := pf24bit;\r\n bm2 := TBitmap.Create;\r\n bm2.Width := Clip.Width;\r\n bm2.Height := Clip.Height;\r\n bm2.pixelformat := pf24bit;\r\n am := painterEffectsF.Ebar.Position;\r\n FX.SplitRound(Clip, bm2, am, mbSplitWaste);\r\n QuickPreviewF.Show;\r\n QuickPreviewF.PreviewImage.Picture.Bitmap.Assign(bm2);\r\n QuickPreviewF.PreviewImage.Update;\r\n bm2.Free;\r\nend;\r\n\r\nprocedure TJvDrawImage.ShearbarChange;\r\nvar\r\n am: Integer;\r\nbegin\r\n ClipAll;\r\n Clip.PixelFormat := pf24bit;\r\n am := painterEffectsF.Ebar.Position;\r\n Shear(Clip, am);\r\n QuickPreviewF.Show;\r\n QuickPreviewF.PreviewImage.Picture.Bitmap.Assign(Clip);\r\n QuickPreviewF.PreviewImage.Update;\r\nend;\r\n\r\nprocedure TJvDrawImage.plasmabarChange;\r\nvar\r\n am, turb, w, h: Integer;\r\n src1, src2: TBitmap;\r\nbegin\r\n ClipAll;\r\n Clip.PixelFormat := pf24bit;\r\n w := Clip.Width;\r\n h := Clip.Height;\r\n src1 := TBitmap.Create;\r\n src1.Width := w;\r\n src1.Height := h;\r\n src1.PixelFormat := pf24bit;\r\n src1.Canvas.Draw(0, 0, Clip);\r\n src2 := TBitmap.Create;\r\n src2.Width := w;\r\n src2.Height := h;\r\n src2.PixelFormat := pf24bit;\r\n src2.Canvas.Draw(0, 0, Clip);\r\n am := painterEffectsF.Ebar.Position;\r\n turb := painterEffectsF.ExtraBar.Position;\r\n if turb < 10 then\r\n begin\r\n painterEffectsF.ExtraBar.Position := 10;\r\n turb := 10;\r\n end;\r\n FX.Plasma(src1, src2, Clip, am, turb);\r\n QuickPreviewF.Show;\r\n QuickPreviewF.PreviewImage.Picture.Bitmap.Assign(Clip);\r\n QuickPreviewF.PreviewImage.Update;\r\n src2.Free;\r\n src1.Free;\r\nend;\r\n\r\nprocedure TJvDrawImage.DrawMandelJulia(Mandel: Boolean);\r\nvar\r\n xr, yr: Extended;\r\n X0, Y0, X1, Y1: Extended;\r\nbegin\r\n ClipAll;\r\n Clip.PixelFormat := pf24bit;\r\n xr := painterEffectsF.Ebar.Position * 0.028;\r\n yr := painterEffectsF.ExtraBar.Position * 0.009;\r\n X0 := -2.25 + xr;\r\n X1 := 0.75;\r\n Y0 := -1.5 + yr;\r\n Y1 := 1.5;\r\n FX.DrawMandelJulia(Clip, X0, Y0, X1, Y1, 16, Mandel);\r\n QuickPreviewF.Show;\r\n QuickPreviewF.PreviewImage.Picture.Bitmap.Assign(Clip);\r\n QuickPreviewF.PreviewImage.Update;\r\nend;\r\n\r\nprocedure TJvDrawImage.DrawTriangles;\r\nvar\r\n am: Integer;\r\nbegin\r\n ClipAll;\r\n Clip.PixelFormat := pf24bit;\r\n am := painterEffectsF.Ebar.Position;\r\n FX.Triangles(Clip, am);\r\n QuickPreviewF.Show;\r\n QuickPreviewF.PreviewImage.Picture.Bitmap.Assign(Clip);\r\n QuickPreviewF.PreviewImage.Update;\r\nend;\r\n\r\nprocedure TJvDrawImage.RippleTooth;\r\nvar\r\n am: Integer;\r\nbegin\r\n ClipAll;\r\n Clip.PixelFormat := pf24bit;\r\n am := painterEffectsF.Ebar.Position;\r\n FX.RippleTooth(Clip, am);\r\n QuickPreviewF.Show;\r\n QuickPreviewF.PreviewImage.Picture.Bitmap.Assign(Clip);\r\n QuickPreviewF.PreviewImage.Update;\r\nend;\r\n\r\nprocedure TJvDrawImage.RippleTriangle;\r\nvar\r\n am: Integer;\r\nbegin\r\n ClipAll;\r\n Clip.PixelFormat := pf24bit;\r\n am := painterEffectsF.Ebar.Position;\r\n FX.RippleTooth(Clip, am);\r\n QuickPreviewF.Show;\r\n QuickPreviewF.PreviewImage.Picture.Bitmap.Assign(Clip);\r\n QuickPreviewF.PreviewImage.Update;\r\nend;\r\n\r\nprocedure TJvDrawImage.RippleRandom;\r\nvar\r\n am: Integer;\r\nbegin\r\n ClipAll;\r\n Clip.PixelFormat := pf24bit;\r\n am := painterEffectsF.Ebar.Position;\r\n FX.RippleRandom(Clip, am);\r\n QuickPreviewF.Show;\r\n QuickPreviewF.PreviewImage.Picture.Bitmap.Assign(Clip);\r\n QuickPreviewF.PreviewImage.Update;\r\nend;\r\n\r\nprocedure TJvDrawImage.TexturizeTile;\r\nvar\r\n am: Integer;\r\nbegin\r\n ClipAll;\r\n Clip.PixelFormat := pf24bit;\r\n am := painterEffectsF.Ebar.Position;\r\n FX.TexturizeTile(Clip, am);\r\n QuickPreviewF.Show;\r\n QuickPreviewF.PreviewImage.Picture.Bitmap.Assign(Clip);\r\n QuickPreviewF.PreviewImage.Update;\r\nend;\r\n\r\nprocedure TJvDrawImage.TexturizeOverlap;\r\nvar\r\n am: Integer;\r\nbegin\r\n ClipAll;\r\n Clip.PixelFormat := pf24bit;\r\n am := painterEffectsF.Ebar.Position;\r\n FX.TexturizeOverlap(Clip, am);\r\n QuickPreviewF.Show;\r\n QuickPreviewF.PreviewImage.Picture.Bitmap.Assign(Clip);\r\n QuickPreviewF.PreviewImage.Update;\r\nend;\r\n\r\nprocedure TJvDrawImage.DrawMap;\r\nvar\r\n am: Integer;\r\nbegin\r\n ClipAll;\r\n Clip.PixelFormat := pf24bit;\r\n am := painterEffectsF.Ebar.Position;\r\n FX.HeightMap(Clip, am);\r\n QuickPreviewF.Show;\r\n QuickPreviewF.PreviewImage.Picture.Bitmap.Assign(Clip);\r\n QuickPreviewF.PreviewImage.Update;\r\nend;\r\n\r\nprocedure TJvDrawImage.DrawBlend;\r\nvar\r\n am, w, h: Integer;\r\n src2, Dst: TBitmap;\r\nbegin\r\n ClipAll;\r\n Clip.PixelFormat := pf24bit;\r\n am := painterEffectsF.Ebar.Position;\r\n w := Clip.Width;\r\n h := Clip.Height;\r\n if not Clipboard.HasFormat(CF_BITMAP) then\r\n Exit;\r\n src2 := TBitmap.Create;\r\n src2.Assign(Clipboard);\r\n src2.PixelFormat := pf24bit;\r\n if ((src2.Width <> w) or (src2.Height <> h)) then\r\n begin\r\n src2.Free;\r\n Exit;\r\n end;\r\n Dst := TBitmap.Create;\r\n Dst.Width := w;\r\n Dst.Height := h;\r\n Dst.PixelFormat := pf24bit;\r\n FX.Blend(Clip, src2, Dst, am / 100);\r\n QuickPreviewF.Show;\r\n QuickPreviewF.PreviewImage.Picture.Bitmap.Assign(Dst);\r\n QuickPreviewF.PreviewImage.Update;\r\n src2.Free;\r\n Dst.Free;\r\nend;\r\n\r\nprocedure TJvDrawImage.DrawSolarize;\r\nvar\r\n am, w, h: Integer;\r\n Dst: TBitmap;\r\nbegin\r\n ClipAll;\r\n Clip.PixelFormat := pf24bit;\r\n am := painterEffectsF.Ebar.Position;\r\n w := Clip.Width;\r\n h := Clip.Height;\r\n Dst := TBitmap.Create;\r\n Dst.Width := w;\r\n Dst.Height := h;\r\n Dst.PixelFormat := pf24bit;\r\n FX.Solarize(Clip, Dst, am);\r\n QuickPreviewF.Show;\r\n QuickPreviewF.PreviewImage.Picture.Bitmap.Assign(Dst);\r\n QuickPreviewF.PreviewImage.Update;\r\n Dst.Free;\r\nend;\r\n\r\nprocedure TJvDrawImage.Posterize;\r\nvar\r\n am, w, h: Integer;\r\n Dst: TBitmap;\r\nbegin\r\n ClipAll;\r\n Clip.PixelFormat := pf24bit;\r\n am := painterEffectsF.Ebar.Position;\r\n w := Clip.Width;\r\n h := Clip.Height;\r\n Dst := TBitmap.Create;\r\n Dst.Width := w;\r\n Dst.Height := h;\r\n Dst.PixelFormat := pf24bit;\r\n FX.Posterize(Clip, Dst, am);\r\n QuickPreviewF.Show;\r\n QuickPreviewF.PreviewImage.Picture.Bitmap.Assign(Dst);\r\n QuickPreviewF.PreviewImage.Update;\r\n Dst.Free;\r\nend;\r\n\r\nprocedure TJvDrawImage.Backgrounds;\r\nbegin\r\n PainterQBF.Show;\r\n PainterQBF.BringToFront;\r\nend;\r\n\r\nprocedure TJvDrawImage.Preview(ABitmap: TBitmap);\r\nbegin\r\n QuickPreviewF.Show;\r\n QuickPreviewF.PreviewImage.Picture.Bitmap.Assign(abitmap);\r\nend;\r\n\r\nprocedure TJvDrawImage.Trace;\r\nvar\r\n BitMap: TBitmap;\r\nbegin\r\n BitMap := TBitmap.Create;\r\n Bitmap.Assign(Picture.Bitmap);\r\n FX.Trace(BitMap, 1);\r\n Picture.Bitmap.Assign(Bitmap);\r\n BitMap.Free;\r\n Update;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvDriveCtrls.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvDriveCtrls.PAS, released on 2002-05-26.\r\n\r\nThe Initial Developer of the Original Code is Peter Thrnqvist [peter3 at sourceforge dot net]\r\nPortions created by Peter Thrnqvist are Copyright (C) 2002 Peter Thrnqvist.\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nDescription:\r\n Components to replace the TDriveComboBox from Borland that also adds a TDriveListBox.\r\n Uses the system Iconlist to display drive icons.\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvDriveCtrls.pas 13362 2012-06-18 12:23:29Z obones $\r\n\r\nunit JvDriveCtrls;\r\n\r\n{$I jvcl.inc}\r\n{$I windowsonly.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, Messages, Classes, Graphics, Controls, StdCtrls,\r\n FileCtrl,\r\n JvCombobox, JvListBox, JvSearchFiles, JvTypes, JVCLVer;\r\n\r\ntype\r\n // redclare so user don't have to add JvTypes to uses manually\r\n TJvDriveType = JvTypes.TJvDriveType;\r\n TJvDriveTypes = JvTypes.TJvDriveTypes;\r\n\r\nconst\r\n dtStandard: TJvDriveTypes = [dtFixed, dtRemote, dtCDROM];\r\n\r\ntype\r\n TJvDirectoryListBox = class;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvDriveCombo = class(TJvCustomComboBox)\r\n private\r\n FDrives: TStringList;\r\n FImages: TImageList;\r\n FImageWidth: Integer;\r\n FImageSize: TJvImageSize;\r\n FItemIndex: Integer;\r\n FOffset: Integer;\r\n FDrive: Char;\r\n FDriveTypes: TJvDriveTypes;\r\n FSmall: Integer;\r\n FLarge: Integer;\r\n FDisplayName: string;\r\n FDirList: TJvDirectoryListBox;\r\n FOnDriveChange: TNotifyEvent;\r\n procedure RecreateImageList;\r\n procedure ResetItemHeight;\r\n procedure SetImageSize(Value: TJvImageSize);\r\n procedure SetOffset(Value: Integer);\r\n function DriveChangeMessage(var Msg: TMessage): Boolean;\r\n protected\r\n procedure FontChanged; override;\r\n procedure CreateWnd; override;\r\n procedure SetDrive(Value: Char);\r\n procedure SetDriveTypes(Value: TJvDriveTypes);\r\n procedure CNDrawItem(var Msg: TWMDrawItem); message CN_DRAWITEM;\r\n procedure DrawItem(Index: Integer; Rect: TRect; State: TOwnerDrawState); override;\r\n procedure MeasureItem(Index: Integer; var Height: Integer); override;\r\n procedure CNCommand(var Msg: TWMCommand); message CN_COMMAND;\r\n procedure BuildList; virtual;\r\n procedure Change; override;\r\n property Items stored False;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n procedure Refresh; virtual;\r\n published\r\n property Align;\r\n property BevelInner;\r\n property BevelOuter;\r\n property BevelKind;\r\n property BevelWidth;\r\n property Drive: Char read FDrive write SetDrive stored False;\r\n property DriveTypes: TJvDriveTypes read FDriveTypes write SetDriveTypes;\r\n property Offset: Integer read FOffset write SetOffset;\r\n property ImageSize: TJvImageSize read FImageSize write SetImageSize default isSmall;\r\n property DisplayName: string read FDisplayName;\r\n property OnDriveChange: TNotifyEvent read FOnDriveChange write FOnDriveChange;\r\n property Color;\r\n property DragMode;\r\n property DragCursor;\r\n property Enabled;\r\n property Font;\r\n property ItemHeight;\r\n property ParentColor;\r\n property ParentFont;\r\n property ParentShowHint;\r\n property PopupMenu;\r\n property ShowHint;\r\n property TabOrder;\r\n property TabStop;\r\n property Visible;\r\n property OnChange;\r\n property OnClick;\r\n property OnDblClick;\r\n property OnDragDrop;\r\n property OnDragOver;\r\n property OnDropDown;\r\n property OnEndDrag;\r\n property OnEnter;\r\n property OnExit;\r\n property OnKeyDown;\r\n property OnKeyPress;\r\n property OnKeyUp;\r\n property OnStartDrag;\r\n property Anchors;\r\n property BiDiMode;\r\n property Constraints;\r\n property DragKind;\r\n property ImeMode;\r\n property ImeName;\r\n property ParentBiDiMode;\r\n property OnEndDock;\r\n property OnStartDock;\r\n end;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvDriveList = class(TJvCustomListBox)\r\n private\r\n FDrives: TStringList;\r\n FImages: TImageList;\r\n FImageWidth: Integer;\r\n FImageSize: TJvImageSize;\r\n FItemIndex: Integer;\r\n FOffset: Integer;\r\n FDrive: Char;\r\n FDriveTypes: TJvDriveTypes;\r\n FSmall: Integer;\r\n FLarge: Integer;\r\n FImageAlign: TJvImageAlign;\r\n FOnChange: TNotifyEvent;\r\n FOnDrawItem: TDrawItemEvent;\r\n FOnDriveChange: TNotifyEvent;\r\n procedure SetImageAlign(Value: TJvImageAlign);\r\n procedure ResetItemHeight;\r\n procedure SetImageSize(Value: TJvImageSize);\r\n procedure SetOffset(Value: Integer);\r\n function GetDrives(Index: Integer): string;\r\n function GetDriveCount: Integer;\r\n function DriveChangeMessage(var Msg: TMessage): Boolean;\r\n protected\r\n procedure Resize; override;\r\n procedure FontChanged; override;\r\n procedure SetDrive(Value: Char);\r\n procedure SetDriveTypes(Value: TJvDriveTypes);\r\n procedure CNDrawItem(var Msg: TWMDrawItem); message CN_DRAWITEM;\r\n procedure DrawItem(Index: Integer; Rect: TRect; State: TOwnerDrawState); override;\r\n procedure MeasureItem(Index: Integer; var Height: Integer); override;\r\n procedure CNCommand(var Msg: TWMCommand); message CN_COMMAND;\r\n procedure BuildList; virtual;\r\n procedure Change; dynamic;\r\n property Offset: Integer read FOffset write SetOffset;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n procedure CreateWnd; override;\r\n destructor Destroy; override;\r\n procedure Refresh; // ahuser: This hides the TControl.Refresh method, why was that name used\r\n property Drives[Index: Integer]: string read GetDrives;\r\n property DriveCount: Integer read GetDriveCount;\r\n property Items stored False;\r\n property Images: TImageList read FImages;\r\n published\r\n property MultiSelect;\r\n property ScrollBars default ssNone;\r\n property ImageAlign: TJvImageAlign read FImageAlign write SetImageAlign default iaCentered;\r\n property Drive: Char read FDrive write SetDrive stored False;\r\n property DriveTypes: TJvDriveTypes read FDriveTypes write SetDriveTypes;\r\n property ImageSize: TJvImageSize read FImageSize write SetImageSize;\r\n property OnDriveChange: TNotifyEvent read FOnDriveChange write FOnDriveChange;\r\n property Align;\r\n property BorderStyle;\r\n property Color;\r\n property Sorted;\r\n property Tag;\r\n property DragMode;\r\n property DragCursor;\r\n property Enabled;\r\n property Font;\r\n property IntegralHeight;\r\n property ItemHeight;\r\n property ParentColor;\r\n property ParentFont;\r\n property ParentShowHint;\r\n property PopupMenu;\r\n property ShowHint;\r\n property TabOrder;\r\n property TabStop;\r\n property Visible;\r\n property OnChange: TNotifyEvent read FOnChange write FOnChange;\r\n property OnDrawItem: TDrawItemEvent read FOnDrawItem write FOnDrawItem;\r\n property OnClick;\r\n property OnDblClick;\r\n property OnDragDrop;\r\n property OnDragOver;\r\n property OnEndDrag;\r\n property OnEnter;\r\n property OnExit;\r\n property OnKeyDown;\r\n property OnKeyPress;\r\n property OnKeyUp;\r\n property OnStartDrag;\r\n property Anchors;\r\n property BiDiMode;\r\n property Constraints;\r\n property DragKind;\r\n property ImeMode;\r\n property ImeName;\r\n property ParentBiDiMode;\r\n property OnEndDock;\r\n property OnStartDock;\r\n end;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvFileListBox = class(TFileListBox)\r\n private\r\n FAboutJVCL: TJVCLAboutInfo;\r\n FImages: TImageList;\r\n FForceFileExtensions: Boolean;\r\n FSearchFiles: TJvSearchFiles;\r\n procedure SetForceFileExtensions(const Value: Boolean);\r\n procedure SetDirectory(const Value: string);\r\n protected\r\n procedure DrawItem(Index: Integer; Rect: TRect; State: TOwnerDrawState); override;\r\n procedure CNDrawItem(var Msg: TWMDrawItem); message CN_DRAWITEM;\r\n procedure ReadFileNames; override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n procedure ApplyFilePath(const EditText: string); override;\r\n published\r\n property AboutJVCL: TJVCLAboutInfo read FAboutJVCL write FAboutJVCL stored False;\r\n property Directory write SetDirectory stored False;\r\n property FileName stored False;\r\n // set this property to True to force the display of filename extensions for all files even if\r\n // the user has activated the Explorer option \"Don't show extensions for known file types\"\r\n property ForceFileExtensions: Boolean read FForceFileExtensions write SetForceFileExtensions;\r\n property Columns;\r\n property BorderStyle;\r\n property Anchors;\r\n property BiDiMode;\r\n property Constraints;\r\n property DragKind;\r\n property ImeMode;\r\n property ImeName;\r\n property ParentBiDiMode;\r\n property OnEndDock;\r\n property OnStartDock;\r\n end;\r\n\r\n TJvDriveChangeError = procedure(Sender: TObject; var NewDrive: Char) of object;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvDirectoryListBox = class(TJvCustomListBox)\r\n private\r\n FFileList: TJvFileListBox;\r\n FDriveCombo: TJvDriveCombo;\r\n FDirLabel: TLabel;\r\n FInSetDir: Boolean;\r\n FPreserveCase: Boolean;\r\n FCaseSensitive: Boolean;\r\n FAutoExpand: Boolean;\r\n { (rb) Probably better to switch the values in FDisplayNames and the values\r\n in Items, see comment at TJvCustomListBox.LBAddString }\r\n FDisplayNames: TStringList;\r\n FOnDriveChangeError: TJvDriveChangeError;\r\n FShowAllFolders: Boolean;\r\n function GetDrive: Char;\r\n procedure SetFileList(Value: TJvFileListBox);\r\n procedure SetDirLabel(Value: TLabel);\r\n procedure SetDirLabelCaption;\r\n procedure SetDrive(Value: Char);\r\n procedure DriveChange(NewDrive: Char);\r\n procedure SetDir(const NewDirectory: string);\r\n procedure SetDirectory(const NewDirectory: string); virtual;\r\n procedure ResetItemHeight;\r\n procedure SetDriveCombo(const Value: TJvDriveCombo);\r\n procedure SetShowAllFolders(const Value: Boolean);\r\n protected\r\n FImages: TImageList;\r\n FDirectory: string;\r\n FOnChange: TNotifyEvent;\r\n procedure FontChanged; override;\r\n procedure Change; virtual;\r\n procedure DblClick; override;\r\n procedure ReadBitmaps; virtual;\r\n procedure DrawItem(Index: Integer; Rect: TRect; State: TOwnerDrawState); override;\r\n procedure CNDrawItem(var Msg: TWMDrawItem); message CN_DRAWITEM;\r\n function ReadDirectoryNames(const ParentDirectory: string; DirectoryList: TStrings): Integer;\r\n procedure BuildList; virtual;\r\n procedure KeyPress(var Key: Char); override;\r\n procedure Notification(AComponent: TComponent; Operation: TOperation); override;\r\n procedure Click; override;\r\n function DoDriveChangeError(var NewDrive: Char): Boolean; virtual;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n procedure CreateWnd; override;\r\n function GetItemPath(Index: Integer): string;\r\n procedure OpenCurrent;\r\n property Drive: Char read GetDrive write SetDrive stored False;\r\n procedure Update; reintroduce;\r\n property PreserveCase: Boolean read FPreserveCase;\r\n property CaseSensitive: Boolean read FCaseSensitive;\r\n published\r\n property Align;\r\n property AutoExpand: Boolean read FAutoExpand write FAutoExpand default True;\r\n property MultiSelect default False;\r\n property BorderStyle;\r\n property BevelInner;\r\n property BevelOuter;\r\n property BevelKind;\r\n property BevelWidth;\r\n property Color;\r\n property Directory: string read FDirectory write SetDirectory;\r\n property DirLabel: TLabel read FDirLabel write SetDirLabel;\r\n property DragCursor;\r\n property DragMode;\r\n property Enabled;\r\n property FileList: TJvFileListBox read FFileList write SetFileList;\r\n property DriveCombo: TJvDriveCombo read FDriveCombo write SetDriveCombo;\r\n property Font;\r\n property IntegralHeight;\r\n property ItemHeight;\r\n { No need to store the items, image indexes aren't stored thus need to call\r\n BuildList anyway }\r\n property Items stored False;\r\n property ParentColor;\r\n property ParentFont;\r\n property ParentShowHint;\r\n property PopupMenu;\r\n property ShowAllFolders: Boolean read FShowAllFolders write SetShowAllFolders default False;\r\n property ShowHint;\r\n property ScrollBars default ssNone;\r\n property TabOrder;\r\n property TabStop;\r\n property Visible;\r\n property OnChange: TNotifyEvent read FOnChange write FOnChange;\r\n property OnDriveChangeError: TJvDriveChangeError read FOnDriveChangeError write FOnDriveChangeError;\r\n property OnClick;\r\n property OnDblClick;\r\n property OnDragDrop;\r\n property OnDragOver;\r\n property OnEndDrag;\r\n property OnEnter;\r\n property OnExit;\r\n property OnKeyDown;\r\n property OnKeyPress;\r\n property OnKeyUp;\r\n property OnMouseDown;\r\n property OnMouseMove;\r\n property OnMouseUp;\r\n property OnStartDrag;\r\n property Anchors;\r\n property BiDiMode;\r\n property Constraints;\r\n property DragKind;\r\n property ImeMode;\r\n property ImeName;\r\n property ParentBiDiMode;\r\n property OnEndDock;\r\n property OnStartDock;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvDriveCtrls.pas $';\r\n Revision: '$Revision: 13362 $';\r\n Date: '$Date: 2012-06-18 14:23:29 +0200 (lun. 18 juin 2012) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n ShellAPI, SysUtils, Math, Forms, ImgList,\r\n DBT,\r\n JvJCLUtils, JvJVCLUtils, JvConsts;\r\n\r\nfunction GetItemHeight(Font: TFont): Integer;\r\nvar\r\n DC: HDC;\r\n SaveFont: HFONT;\r\n Metrics: TTextMetric;\r\nbegin\r\n DC := GetDC(HWND_DESKTOP);\r\n SaveFont := SelectObject(DC, Font.Handle);\r\n GetTextMetrics(DC, Metrics);\r\n SelectObject(DC, SaveFont);\r\n ReleaseDC(HWND_DESKTOP, DC);\r\n Result := Metrics.tmHeight;\r\nend;\r\n\r\nfunction IsValidDriveType(DriveTypes: TJvDriveTypes; DriveType: UINT): Boolean;\r\nconst\r\n cDriveMasks: array [TJvDriveType] of UINT =\r\n (DRIVE_UNKNOWN, DRIVE_REMOVABLE, DRIVE_FIXED, DRIVE_REMOTE, DRIVE_CDROM, DRIVE_RAMDISK);\r\nvar\r\n I: TJvDriveType;\r\nbegin\r\n Result := True;\r\n for I := Low(TJvDriveType) to High(TJvDriveType) do\r\n if (I in DriveTypes) and (DriveType = cDriveMasks[I]) then\r\n Exit;\r\n Result := False;\r\nend;\r\n\r\n//=== { TJvDriveCombo } ======================================================\r\n\r\nconstructor TJvDriveCombo.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n\r\n FLarge := GetSystemMetrics(SM_CXICON);\r\n FSmall := GetSystemMetrics(SM_CXSMICON);\r\n\r\n FDrives := TStringList.Create;\r\n FDriveTypes := dtStandard;\r\n\r\n FImageSize := isSmall;\r\n RecreateImageList;\r\n FImageWidth := FImages.Width;\r\n\r\n FItemIndex := 0;\r\n FOffset := 4;\r\n Color := clWindow;\r\n Style := csOwnerDrawFixed;\r\n ResetItemHeight;\r\n Application.HookMainWindow(DriveChangeMessage);\r\nend;\r\n\r\ndestructor TJvDriveCombo.Destroy;\r\nbegin\r\n Application.UnhookMainWindow(DriveChangeMessage);\r\n FDrives.Free;\r\n FImages.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJvDriveCombo.DriveChangeMessage(var Msg: TMessage): Boolean;\r\nbegin\r\n Result := False;\r\n if Msg.Msg = WM_DEVICECHANGE then\r\n if ((TWMDeviceChange(Msg).Event = DBT_DEVICEARRIVAL) or\r\n (TWMDeviceChange(Msg).Event = DBT_DEVICEREMOVECOMPLETE)) and\r\n (PDevBroadcastVolume(TWMDeviceChange(Msg).dwData)^.dbcv_devicetype = DBT_DEVTYP_VOLUME) then\r\n begin\r\n Refresh;\r\n if Assigned(FOnDriveChange) then\r\n FOnDriveChange(Self);\r\n end;\r\nend;\r\n\r\nprocedure TJvDriveCombo.RecreateImageList;\r\nbegin\r\n if FImageSize = isSmall then\r\n FImages := TImageList.CreateSize(FSmall, FSmall)\r\n else\r\n FImages := TImageList.CreateSize(FLarge, FLarge);\r\n\r\n FImages.DrawingStyle := dsTransparent;\r\n FImages.ShareImages := True;\r\nend;\r\n\r\nprocedure TJvDriveCombo.BuildList;\r\nvar\r\n Info: TSHFileInfo;\r\n S: string;\r\n Options: Integer;\r\n Drv: Char;\r\n LastErrorMode: Cardinal;\r\n Tmp: array [0..104] of Char; // 4 chars ('C:\\#0') * 26 possible drives + 1 terminating #0 = 105 chars\r\n P: PChar;\r\nbegin\r\n Drv := Drive;\r\n Items.Clear;\r\n FDrives.Clear;\r\n Options := SHGFI_SYSICONINDEX;\r\n if FImageSize = isSmall then\r\n Options := Options or SHGFI_SMALLICON\r\n else\r\n Options := Options or SHGFI_LARGEICON;\r\n\r\n FImages.Handle := SHGetFileInfo('', 0, Info, SizeOf(TSHFileInfo), Options);\r\n FImages.ShareImages := True;\r\n LastErrorMode := SetErrorMode(SEM_NOOPENFILEERRORBOX);\r\n try\r\n FillChar(Tmp[0], SizeOf(Tmp), #0);\r\n GetLogicalDriveStrings(SizeOf(Tmp), Tmp);\r\n P := Tmp;\r\n while P^ <> #0 do\r\n begin\r\n S := P;\r\n Inc(P, 4);\r\n if IsValidDriveType(DriveTypes, GetDriveType(PChar(S))) then\r\n begin\r\n SHGetFileInfo(PChar(S), 0, Info, SizeOf(TSHFileInfo), SHGFI_DISPLAYNAME or Options);\r\n Items.AddObject(Trim(Info.szDisplayName), TObject(Info.iIcon));\r\n FDrives.Add(S[1]);\r\n end\r\n end;\r\n Drive := Drv;\r\n Update;\r\n finally\r\n SetErrorMode(LastErrorMode);\r\n end;\r\nend;\r\n\r\nprocedure TJvDriveCombo.CreateWnd;\r\nbegin\r\n inherited CreateWnd;\r\n BuildList;\r\n if FDrive = #0 then\r\n begin\r\n if FDrives.IndexOf(GetCurrentDir[1]) > 0 then\r\n Drive := GetCurrentDir[1]\r\n else\r\n if FDrives.Count > 0 then\r\n Drive := FDrives[0][1];\r\n end;\r\nend;\r\n\r\nprocedure TJvDriveCombo.Refresh;\r\nbegin\r\n BuildList;\r\nend;\r\n\r\nprocedure TJvDriveCombo.CNDrawItem(var Msg: TWMDrawItem);\r\nvar\r\n State: TOwnerDrawState;\r\nbegin\r\n with Msg.DrawItemStruct^ do\r\n begin\r\n State := [];\r\n if (itemState and ODS_CHECKED) <> 0 then\r\n Include(State, odChecked);\r\n if (itemState and ODS_COMBOBOXEDIT) <> 0 then\r\n Include(State, odComboBoxEdit);\r\n if (itemState and ODS_DEFAULT) <> 0 then\r\n Include(State, odDefault);\r\n if (itemState and ODS_DISABLED) <> 0 then\r\n Include(State, odDisabled);\r\n if (itemState and ODS_FOCUS) <> 0 then\r\n Include(State, odFocused);\r\n if (itemState and ODS_GRAYED) <> 0 then\r\n Include(State, odGrayed);\r\n if (itemState and ODS_SELECTED) <> 0 then\r\n Include(State, odSelected);\r\n Canvas.Handle := hDC;\r\n Canvas.Font := Font;\r\n Canvas.Brush := Brush;\r\n if (Integer(itemID) >= 0) and (odSelected in State) then\r\n begin\r\n Canvas.Brush.Color := clHighlight;\r\n Canvas.Font.Color := clHighlightText\r\n end;\r\n if Integer(itemID) >= 0 then\r\n DrawItem(itemID, rcItem, State)\r\n else\r\n Canvas.FillRect(rcItem);\r\n Canvas.Handle := 0;\r\n end;\r\nend;\r\n\r\nprocedure TJvDriveCombo.DrawItem(Index: Integer; Rect: TRect; State: TOwnerDrawState);\r\nvar\r\n Offset, I: Integer;\r\nbegin\r\n // inherited;\r\n with Canvas do\r\n begin\r\n Offset := FImageWidth + FOffset + FOffset;\r\n if FImages.Count > 0 then\r\n begin\r\n I := Integer(Items.Objects[Index]);\r\n FImages.Draw(Canvas, Rect.Left + FOffset, Rect.Top, I);\r\n Rect.Left := Rect.Left + Offset;\r\n Rect.Right := Rect.Left + Canvas.TextWidth(Items[Index]) + 6;\r\n end;\r\n FillRect(Rect);\r\n if odSelected in State then\r\n DrawFocusRect(Rect);\r\n Inc(Rect.Left, 3);\r\n DrawText(Canvas, Items[Index], -1, Rect,\r\n DT_SINGLELINE or DT_VCENTER or DT_NOPREFIX);\r\n end;\r\nend;\r\n\r\nprocedure TJvDriveCombo.MeasureItem(Index: Integer; var Height: Integer);\r\nbegin\r\n Height := ItemHeight;\r\nend;\r\n\r\nprocedure TJvDriveCombo.FontChanged;\r\nbegin\r\n inherited FontChanged;\r\n ResetItemHeight;\r\n RecreateWnd;\r\nend;\r\n\r\nprocedure TJvDriveCombo.ResetItemHeight;\r\nvar\r\n NewHeight: Integer;\r\nbegin\r\n NewHeight := GetItemHeight(Font);\r\n if NewHeight < FImages.Height then\r\n NewHeight := FImages.Height;\r\n ItemHeight := NewHeight;\r\nend;\r\n\r\nprocedure TJvDriveCombo.SetDriveTypes(Value: TJvDriveTypes);\r\nbegin\r\n FDriveTypes := Value;\r\n if FDriveTypes = [] then\r\n FDriveTypes := [dtFixed];\r\n BuildList;\r\n Change;\r\n // Drive := FDrive;\r\nend;\r\n\r\nprocedure TJvDriveCombo.SetDrive(Value: Char);\r\nvar\r\n I, J: Integer;\r\nbegin\r\n J := 0;\r\n if FItemIndex <> -1 then\r\n J := FItemIndex;\r\n\r\n Value := UpCase(Value);\r\n if FDrive <> Value then\r\n begin\r\n I := FDrives.IndexOf(Value);\r\n if I > -1 then\r\n begin\r\n FDrive := Value;\r\n FItemIndex := I;\r\n ItemIndex := I;\r\n if FDirList <> nil then\r\n FDirList.DriveChange(FDrive);\r\n Change;\r\n end;\r\n end\r\n else\r\n ItemIndex := J;\r\nend;\r\n\r\nprocedure TJvDriveCombo.SetImageSize(Value: TJvImageSize);\r\nbegin\r\n if FImageSize <> Value then\r\n begin\r\n FImageSize := Value;\r\n\r\n if Items.Count > 0 then\r\n Items.Clear;\r\n\r\n RecreateImageList;\r\n FImageWidth := FImages.Width;\r\n ResetItemHeight;\r\n RecreateWnd;\r\n BuildList;\r\n Change;\r\n end;\r\nend;\r\n\r\nprocedure TJvDriveCombo.SetOffset(Value: Integer);\r\nbegin\r\n if FOffset <> Value then\r\n begin\r\n FOffset := Value;\r\n Refresh;\r\n end;\r\nend;\r\n\r\nprocedure TJvDriveCombo.Change;\r\n\r\n function FirstChar(const S: string): Char;\r\n begin\r\n if Length(S) > 0 then\r\n Result := S[1]\r\n else\r\n Result := #0;\r\n end;\r\n\r\nbegin\r\n if ItemIndex <> -1 then\r\n FItemIndex := ItemIndex\r\n else\r\n FItemIndex := 0;\r\n if (FItemIndex >= 0) and (FItemIndex < FDrives.Count) then\r\n Drive := FirstChar(FDrives[FItemIndex]);\r\n if (ItemIndex > -1) and (ItemIndex < Items.Count) then\r\n FDisplayName := Items[ItemIndex]\r\n else\r\n FDisplayName := '';\r\n inherited Change;\r\nend;\r\n\r\nprocedure TJvDriveCombo.CNCommand(var Msg: TWMCommand);\r\nbegin\r\n inherited;\r\n case Msg.NotifyCode of\r\n { CBN_EDITCHANGE:\r\n Change;}\r\n CBN_SELCHANGE:\r\n Change;\r\n end;\r\nend;\r\n\r\n//=== { TJvDriveList } =======================================================\r\n\r\nconstructor TJvDriveList.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n\r\n FLarge := GetSystemMetrics(SM_CXICON);\r\n FSmall := GetSystemMetrics(SM_CXSMICON);\r\n\r\n FDrives := TStringList.Create;\r\n FDriveTypes := dtStandard;\r\n FImageAlign := iaCentered;\r\n ScrollBars := ssNone;\r\n\r\n if FImageSize = isSmall then\r\n FImages := TImageList.CreateSize(FSmall, FSmall)\r\n else\r\n FImages := TImageList.CreateSize(FLarge, FLarge);\r\n\r\n FImages.DrawingStyle := dsTransparent;\r\n FImageWidth := FImages.Width;\r\n FImages.ShareImages := True;\r\n\r\n FItemIndex := 0;\r\n Color := clWindow;\r\n SetBounds(0, 0, FImageWidth * 6 + 16, 97);\r\n FOffset := 4;\r\n Style := lbOwnerDrawFixed;\r\n ResetItemHeight;\r\n Application.HookMainWindow(DriveChangeMessage);\r\nend;\r\n\r\ndestructor TJvDriveList.Destroy;\r\nbegin\r\n Application.UnhookMainWindow(DriveChangeMessage);\r\n FDrives.Free;\r\n FImages.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJvDriveList.DriveChangeMessage(var Msg: TMessage): Boolean;\r\nbegin\r\n Result := False;\r\n if Msg.Msg = WM_DEVICECHANGE then\r\n if ((TWMDeviceChange(Msg).Event = DBT_DEVICEARRIVAL) or\r\n (TWMDeviceChange(Msg).Event = DBT_DEVICEREMOVECOMPLETE)) and\r\n (PDevBroadcastVolume(TWMDeviceChange(Msg).dwData)^.dbcv_devicetype = DBT_DEVTYP_VOLUME) then\r\n begin\r\n Refresh;\r\n if Assigned(FOnDriveChange) then\r\n FOnDriveChange(Self);\r\n end;\r\nend;\r\n\r\nprocedure TJvDriveList.BuildList;\r\nvar\r\n Info: TSHFileInfo;\r\n S: string;\r\n Options: Integer;\r\n Drv: Char;\r\n Tmp: array [0..105] of Char;\r\n P: PChar;\r\n LastErrorMode: Cardinal;\r\nbegin\r\n Drv := Drive;\r\n if Items.Count > 0 then\r\n begin\r\n Items.Clear;\r\n FDrives.Clear;\r\n end;\r\n\r\n Options := SHGFI_SYSICONINDEX;\r\n if FImageSize = isSmall then\r\n Options := Options or SHGFI_SMALLICON\r\n else\r\n Options := Options or SHGFI_LARGEICON;\r\n\r\n FImages.Handle := SHGetFileInfo('', 0, Info, SizeOf(TSHFileInfo), Options);\r\n FImages.ShareImages := True;\r\n FillChar(Tmp[0], SizeOf(Tmp), #0);\r\n LastErrorMode := SetErrorMode(SEM_NOOPENFILEERRORBOX);\r\n try\r\n GetLogicalDriveStrings(Length(Tmp) - 1, Tmp);\r\n P := Tmp;\r\n while P^ <> #0 do\r\n begin\r\n S := P;\r\n Inc(P, 4);\r\n if IsValidDriveType(DriveTypes, GetDriveType(PChar(S))) then\r\n begin\r\n SHGetFileInfo(PChar(S), 0, Info, SizeOf(TSHFileInfo), SHGFI_DISPLAYNAME or Options);\r\n Items.AddObject(Trim(Info.szDisplayName), TObject(Info.iIcon));\r\n FDrives.Add(S[1]);\r\n end;\r\n end;\r\n Drive := Drv;\r\n Update;\r\n finally\r\n SetErrorMode(LastErrorMode);\r\n end;\r\nend;\r\n\r\nprocedure TJvDriveList.CreateWnd;\r\nbegin\r\n inherited CreateWnd;\r\n BuildList;\r\n if Drive = #0 then\r\n if FDrives.IndexOf(GetCurrentDir[1]) > 0 then\r\n Drive := GetCurrentDir[1]\r\n else\r\n if FDrives.Count > 0 then\r\n Drive := FDrives[0][1];\r\nend;\r\n\r\nprocedure TJvDriveList.Refresh;\r\nbegin\r\n BuildList;\r\nend;\r\n\r\nprocedure TJvDriveList.CNDrawItem(var Msg: TWMDrawItem);\r\nvar\r\n State: TOwnerDrawState;\r\nbegin\r\n with Msg.DrawItemStruct^ do\r\n begin\r\n State := [];\r\n if (itemState and ODS_CHECKED) <> 0 then\r\n Include(State, odChecked);\r\n if (itemState and ODS_COMBOBOXEDIT) <> 0 then\r\n Include(State, odComboBoxEdit);\r\n if (itemState and ODS_DEFAULT) <> 0 then\r\n Include(State, odDefault);\r\n if (itemState and ODS_DISABLED) <> 0 then\r\n Include(State, odDisabled);\r\n if (itemState and ODS_FOCUS) <> 0 then\r\n Include(State, odFocused);\r\n if (itemState and ODS_GRAYED) <> 0 then\r\n Include(State, odGrayed);\r\n if (itemState and ODS_SELECTED) <> 0 then\r\n Include(State, odSelected);\r\n Canvas.Handle := hDC;\r\n Canvas.Font := Font;\r\n Canvas.Brush := Brush;\r\n if (Integer(itemID) >= 0) and (odSelected in State) then\r\n begin\r\n Canvas.Brush.Color := clHighlight;\r\n Canvas.Font.Color := clHighlightText;\r\n end;\r\n if Integer(itemID) >= 0 then\r\n begin\r\n if Assigned(FOnDrawItem) then\r\n OnDrawItem(Self, itemID, rcItem, State)\r\n else\r\n DrawItem(itemID, rcItem, State);\r\n end\r\n else\r\n Canvas.FillRect(rcItem);\r\n\r\n Canvas.Handle := 0;\r\n end;\r\nend;\r\n\r\nprocedure TJvDriveList.DrawItem(Index: Integer; Rect: TRect; State: TOwnerDrawState);\r\nvar\r\n HOffset, I: Integer;\r\n tmpCol: TColor;\r\n tmpR: TRect;\r\nbegin\r\n with Canvas do\r\n begin\r\n tmpCol := Canvas.Brush.Color;\r\n Canvas.Brush.Color := Self.Color;\r\n FillRect(Rect);\r\n Canvas.Brush.Color := tmpCol;\r\n if FImageAlign = iaCentered then\r\n begin\r\n HOffset := (Rect.Right - Rect.Left) div 2 - FImageWidth div 2;\r\n if FImages.Count > 0 then\r\n begin\r\n I := Integer(Items.Objects[Index]);\r\n FImages.Draw(Canvas, HOffset, Rect.Top, I);\r\n end;\r\n InflateRect(Rect, 1, -6);\r\n tmpR := Rect;\r\n DrawText(Canvas, Items[Index], -1, tmpR,\r\n DT_SINGLELINE or DT_BOTTOM or DT_CENTER or DT_NOPREFIX or DT_CALCRECT);\r\n Rect.Top := tmpR.Bottom - CanvasMaxTextHeight(Canvas);\r\n Rect.Left := (Rect.Right - Rect.Left) div 2 - Canvas.TextWidth(PChar(Items[Index])) div 2;\r\n Rect.Right := Rect.Left + Canvas.TextWidth(PChar(Items[Index]));\r\n DrawText(Canvas, Items[Index], -1, Rect, DT_SINGLELINE or DT_CENTER or DT_NOPREFIX);\r\n end\r\n else\r\n begin\r\n if FImages.Count > 0 then\r\n begin\r\n I := Integer(Items.Objects[Index]);\r\n FImages.Draw(Canvas, Rect.Left + FOffset * 2, Rect.Top + FOffset * 2, I);\r\n end;\r\n tmpR := Rect;\r\n DrawText(Canvas, Items[Index], -1, tmpR,\r\n DT_SINGLELINE or DT_VCENTER or DT_CENTER or DT_NOPREFIX or DT_CALCRECT);\r\n Rect.Top := tmpR.Bottom - CanvasMaxTextHeight(Canvas);\r\n Rect.Bottom := Rect.Top + CanvasMaxTextHeight(Canvas);\r\n Rect.Left := FImageWidth + FOffset * 3;\r\n Rect.Right := Rect.Left + Canvas.TextWidth(PChar(Items[Index]));\r\n DrawText(Canvas, Items[Index], -1, Rect, DT_SINGLELINE or DT_TOP or DT_NOPREFIX);\r\n end;\r\n end;\r\n if odFocused in State then\r\n DrawFocusRect(Canvas.Handle, Rect);\r\nend;\r\n\r\nprocedure TJvDriveList.MeasureItem(Index: Integer; var Height: Integer);\r\nbegin\r\n if FImageAlign = iaCentered then\r\n Height := FImageWidth + GetItemHeight(Font)\r\n else\r\n Height := Max(GetItemHeight(Font), FImageWidth);\r\nend;\r\n\r\nprocedure TJvDriveList.SetImageAlign(Value: TJvImageAlign);\r\nbegin\r\n if FImageAlign <> Value then\r\n begin\r\n FImageAlign := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvDriveList.FontChanged;\r\nbegin\r\n inherited FontChanged;\r\n ResetItemHeight;\r\n RecreateWnd;\r\nend;\r\n\r\nprocedure TJvDriveList.ResetItemHeight;\r\nbegin\r\n ItemHeight := GetItemHeight(Font) + FImageWidth + 8;\r\nend;\r\n\r\nprocedure TJvDriveList.SetDriveTypes(Value: TJvDriveTypes);\r\nbegin\r\n FDriveTypes := Value;\r\n if FDriveTypes = [] then\r\n FDriveTypes := [dtFixed];\r\n BuildList;\r\nend;\r\n\r\nprocedure TJvDriveList.SetDrive(Value: Char);\r\nvar\r\n I, J: Integer;\r\nbegin\r\n J := 0;\r\n if FItemIndex <> -1 then\r\n J := FItemIndex;\r\n\r\n Value := UpCase(Value);\r\n if (FDrive <> Value) and (Value <> #0) then\r\n begin\r\n I := FDrives.IndexOf(Value);\r\n if I > -1 then\r\n begin\r\n FDrive := Value;\r\n FItemIndex := I;\r\n ItemIndex := I;\r\n end;\r\n end\r\n else\r\n ItemIndex := J;\r\nend;\r\n\r\nprocedure TJvDriveList.SetImageSize(Value: TJvImageSize);\r\nbegin\r\n if FImageSize <> Value then\r\n begin\r\n FImageSize := Value;\r\n if Items.Count > 0 then\r\n Items.Clear;\r\n if Assigned(FImages) then\r\n FImages.Free;\r\n\r\n if Value = isSmall then\r\n FImages := TImageList.CreateSize(FSmall, FSmall)\r\n else\r\n FImages := TImageList.CreateSize(FLarge, FLarge);\r\n\r\n FImages.DrawingStyle := dsTransparent;\r\n FImages.ShareImages := True;\r\n FImageWidth := FImages.Width;\r\n ResetItemHeight;\r\n RecreateWnd;\r\n BuildList;\r\n Change;\r\n end;\r\nend;\r\n\r\nprocedure TJvDriveList.SetOffset(Value: Integer);\r\nbegin\r\n if FOffset <> Value then\r\n begin\r\n FOffset := Value;\r\n Refresh;\r\n end;\r\nend;\r\n\r\nprocedure TJvDriveList.Resize;\r\nbegin\r\n inherited Resize;\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvDriveList.Change;\r\nbegin\r\n if ItemIndex <> -1 then\r\n FItemIndex := ItemIndex;\r\n if (FItemIndex >= 0) and (FItemIndex < FDrives.Count) then\r\n Drive := FDrives[FItemIndex][1];\r\n if Assigned(FOnChange) then\r\n FOnChange(Self);\r\nend;\r\n\r\nprocedure TJvDriveList.CNCommand(var Msg: TWMCommand);\r\nbegin\r\n inherited;\r\n case Msg.NotifyCode of\r\n { CBN_EDITCHANGE:\r\n Change;}\r\n CBN_SELCHANGE:\r\n Change;\r\n end;\r\nend;\r\n\r\n//=== { TJvDirectoryListBox } ================================================\r\n\r\nfunction AddPathBackslash(const Path: string): string;\r\nbegin\r\n Result := Path;\r\n if (Length(Path) > 1) and ({$IFDEF COMPILER12_UP}Path[Length(Path)]{$ELSE}AnsiLastChar(Path){$ENDIF COMPILER12_UP} <> '\\') then\r\n Result := Path + '\\';\r\nend;\r\n\r\nfunction DirLevel(const PathName: string): Integer; { counts '\\' in path }\r\nvar\r\n P: PChar;\r\nbegin\r\n Result := 0;\r\n P := AnsiStrScan(PChar(PathName), '\\');\r\n while P <> nil do\r\n begin\r\n Inc(Result);\r\n Inc(P);\r\n P := AnsiStrScan(P, '\\');\r\n end;\r\nend;\r\n\r\nfunction ConcatPaths(const Path, S: string): string;\r\nbegin\r\n if Path = '' then\r\n begin\r\n Result := AddPathBackslash(S);\r\n Exit;\r\n end;\r\n if AnsiLastChar(Path)^ <> '\\' then\r\n Result := Path + '\\' + S\r\n else\r\n Result := Path + S;\r\nend;\r\n\r\nconstructor TJvDirectoryListBox.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n Width := 145;\r\n Style := lbOwnerDrawFixed;\r\n Sorted := False;\r\n ScrollBars := ssNone;\r\n FAutoExpand := True;\r\n FImages := TImageList.Create(Self);\r\n FImages.ShareImages := True;\r\n FDisplayNames := TStringList.Create;\r\n ReadBitmaps;\r\n GetDir(0, FDirectory);\r\n MultiSelect := False;\r\n ResetItemHeight;\r\nend;\r\n\r\ndestructor TJvDirectoryListBox.Destroy;\r\nbegin\r\n FDisplayNames.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJvDirectoryListBox.DoDriveChangeError(var NewDrive: Char): Boolean;\r\nbegin\r\n Result := Assigned(FOnDriveChangeError);\r\n if Result then\r\n FOnDriveChangeError(Self, NewDrive);\r\nend;\r\n\r\nprocedure TJvDirectoryListBox.DriveChange(NewDrive: Char);\r\nvar\r\n VolFlags, MLength: DWORD;\r\n TmpDrive: Char;\r\nbegin\r\n if UpCase(NewDrive) <> UpCase(Drive) then\r\n begin\r\n if NewDrive <> #0 then\r\n begin\r\n if not SetCurrentDir(NewDrive + DriveDelim + PathDelim) then\r\n begin\r\n TmpDrive := NewDrive;\r\n if DoDriveChangeError(NewDrive) and (NewDrive <> TmpDrive) then\r\n begin\r\n DriveChange(NewDrive)\r\n end\r\n else\r\n if TmpDrive <> Drive then\r\n DriveChange(Drive); // ...if not, revert\r\n end;\r\n FDirectory := GetCurrentDir; { store correct directory name }\r\n GetVolumeInformation(PChar(NewDrive + ':\\'), nil, 0, nil, MLength, VolFlags, nil, 0);\r\n FPreserveCase := VolFlags and (FS_CASE_IS_PRESERVED or FS_CASE_SENSITIVE) <> 0;\r\n FCaseSensitive := (VolFlags and FS_CASE_SENSITIVE) <> 0;\r\n end;\r\n if not FInSetDir then\r\n begin\r\n BuildList;\r\n Change;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvDirectoryListBox.SetFileList(Value: TJvFileListBox);\r\nbegin\r\n if FFileList <> nil then\r\n FFileList.FDirList := nil;\r\n ReplaceComponentReference(Self, Value, TComponent(FFileList));\r\n if FFileList <> nil then\r\n FFileList.Directory := Directory;\r\nend;\r\n\r\nprocedure TJvDirectoryListBox.SetDirLabel(Value: TLabel);\r\nbegin\r\n ReplaceComponentReference(Self, Value, TComponent(FDirLabel));\r\n SetDirLabelCaption;\r\nend;\r\n\r\nprocedure TJvDirectoryListBox.SetDir(const NewDirectory: string);\r\nbegin\r\n if DirectoryExists(FDirectory) then\r\n SetCurrentDir(FDirectory);\r\n SetCurrentDir(NewDirectory); { exception raised if invalid dir }\r\n FDirectory := GetCurrentDir; { store correct directory name }\r\n BuildList;\r\n Change;\r\nend;\r\n\r\nprocedure TJvDirectoryListBox.OpenCurrent;\r\nbegin\r\n Directory := GetItemPath(ItemIndex);\r\nend;\r\n\r\nprocedure TJvDirectoryListBox.Update;\r\nbegin\r\n BuildList;\r\n Change;\r\nend;\r\n\r\nfunction TJvDirectoryListBox.ReadDirectoryNames(const ParentDirectory: string;\r\n DirectoryList: TStrings): Integer;\r\nconst\r\n cAttr: array [Boolean] of Integer = (faDirectory, faReadOnly or faHidden or faSysFile or faArchive or faDirectory);\r\nvar\r\n Status: Integer;\r\n SearchRec: TSearchRec;\r\nbegin\r\n Result := 0;\r\n DirectoryList.BeginUpdate;\r\n Status := FindFirst(ConcatPaths(ParentDirectory, AllFilePattern), cAttr[ShowAllFolders], SearchRec);\r\n try\r\n while Status = 0 do\r\n begin\r\n if (SearchRec.Attr and faDirectory) = faDirectory then\r\n begin\r\n if (SearchRec.Name <> '.') and (SearchRec.Name <> '..') then\r\n begin\r\n DirectoryList.Add(ConcatPaths(ParentDirectory, SearchRec.Name));\r\n Inc(Result);\r\n end;\r\n end;\r\n Status := FindNext(SearchRec);\r\n end;\r\n finally\r\n FindClose(SearchRec);\r\n DirectoryList.EndUpdate;\r\n end;\r\nend;\r\n\r\nprocedure TJvDirectoryListBox.BuildList;\r\nconst\r\n CFlagsDir = SHGFI_SYSICONINDEX or SHGFI_SMALLICON or\r\n SHGFI_SELECTED or SHGFI_OPENICON or SHGFI_DISPLAYNAME;\r\n CFlagsSubDirs = SHGFI_SYSICONINDEX or SHGFI_SMALLICON or\r\n SHGFI_DISPLAYNAME;\r\nvar\r\n TempPath: string;\r\n DirName: string;\r\n BackSlashPos: Integer;\r\n I: Integer;\r\n Siblings: TStringList;\r\n NewSelect: Integer;\r\n tmpFolder: string;\r\n psfi: TSHFileInfo;\r\nbegin\r\n Items.BeginUpdate;\r\n try\r\n Items.Clear;\r\n FDisplayNames.Clear;\r\n\r\n TempPath := Directory;\r\n tmpFolder := '';\r\n\r\n if Length(TempPath) > 0 then\r\n begin\r\n if AnsiLastChar(TempPath)^ <> '\\' then\r\n begin\r\n BackSlashPos := AnsiPos('\\', TempPath);\r\n while BackSlashPos <> 0 do\r\n begin\r\n DirName := Copy(TempPath, 1, BackSlashPos - 1);\r\n tmpFolder := ConcatPaths(tmpFolder, DirName);\r\n Delete(TempPath, 1, BackSlashPos);\r\n SHGetFileInfo(PChar(tmpFolder), 0, psfi, SizeOf(TSHFileInfo), CFlagsDir);\r\n Items.AddObject(tmpFolder, TObject(psfi.iIcon));\r\n FDisplayNames.Add(psfi.szDisplayName);\r\n BackSlashPos := AnsiPos('\\', TempPath);\r\n end;\r\n end;\r\n // add the selected dir:\r\n SHGetFileInfo(PChar(Directory), 0, psfi, SizeOf(TSHFileInfo), CFlagsDir);\r\n Items.AddObject(Directory, TObject(psfi.iIcon));\r\n FDisplayNames.Add(psfi.szDisplayName);\r\n end;\r\n NewSelect := Items.Count - 1;\r\n\r\n Siblings := TStringList.Create;\r\n try\r\n Siblings.Sorted := True;\r\n { read all the subdir names into Siblings }\r\n ReadDirectoryNames(Directory, Siblings);\r\n for I := 0 to Siblings.Count - 1 do\r\n begin\r\n SHGetFileInfo(PChar(Siblings[I]), 0, psfi, SizeOf(TSHFileInfo), CFlagsSubDirs);\r\n Items.AddObject(Siblings[I], TObject(psfi.iIcon));\r\n FDisplayNames.Add(psfi.szDisplayName);\r\n end;\r\n finally\r\n Siblings.Free;\r\n end;\r\n finally\r\n Items.EndUpdate;\r\n end;\r\n if HandleAllocated then\r\n ItemIndex := NewSelect;\r\nend;\r\n\r\nprocedure TJvDirectoryListBox.ReadBitmaps;\r\nvar\r\n psfi: TSHFileInfo;\r\nbegin\r\n FImages.Handle := SHGetFileInfo('', 0, psfi, SizeOf(TSHFileInfo), SHGFI_SYSICONINDEX or SHGFI_SMALLICON);\r\n FImages.ShareImages := True;\r\n FImages.DrawingStyle := dsTransparent;\r\nend;\r\n\r\nprocedure TJvDirectoryListBox.DblClick;\r\nbegin\r\n OpenCurrent;\r\n inherited DblClick;\r\nend;\r\n\r\nprocedure TJvDirectoryListBox.Change;\r\nbegin\r\n if FFileList <> nil then\r\n FFileList.Directory := Directory;\r\n if FDriveCombo <> nil then\r\n FDriveCombo.Drive := Drive;\r\n SetDirLabelCaption;\r\n if Assigned(FOnChange) then\r\n FOnChange(Self);\r\nend;\r\n\r\nprocedure TJvDirectoryListBox.CNDrawItem(var Msg: TWMDrawItem);\r\nvar\r\n State: TOwnerDrawState;\r\nbegin\r\n with Msg.DrawItemStruct^ do\r\n begin\r\n State := TOwnerDrawState(Lo(itemState));\r\n Canvas.Handle := hDC;\r\n Canvas.Font := Font;\r\n Canvas.Brush := Brush;\r\n if (Integer(itemID) >= 0) and (odSelected in State) then\r\n begin\r\n Canvas.Brush.Color := clHighlight;\r\n Canvas.Font.Color := clHighlightText;\r\n end;\r\n if Integer(itemID) >= 0 then\r\n DrawItem(itemID, rcItem, State)\r\n else\r\n begin\r\n Canvas.FillRect(rcItem);\r\n //if odFocused in State then\r\n // DrawFocusRect(hDC, rcItem);\r\n end;\r\n Canvas.Handle := 0;\r\n end;\r\nend;\r\n\r\nprocedure TJvDirectoryListBox.DrawItem(Index: Integer; Rect: TRect;\r\n State: TOwnerDrawState);\r\nvar\r\n BmpWidth: Integer;\r\n DirOffset: Integer;\r\n S: string;\r\n RectText: TRect;\r\nbegin\r\n with Canvas do\r\n begin\r\n FillRect(Rect);\r\n\r\n BmpWidth := FImages.Width;\r\n if Index = 0 then\r\n DirOffset := Rect.Left + 2\r\n else\r\n DirOffset := Rect.Left + (DirLevel(Items[Index]) + 1) * 4 + 2;\r\n FImages.Draw(Canvas, DirOffset, (Rect.Top + Rect.Bottom - FImages.Height) div 2,\r\n Integer(Items.Objects[Index]));\r\n\r\n S := FDisplayNames[Index];\r\n\r\n RectText := Rect;\r\n RectText.Left := RectText.Left + DirOffset + FImages.Width + 2;\r\n RectText.Right := RectText.Left + TextWidth(S) + 4;\r\n\r\n TextOut(Rect.Left + BmpWidth + DirOffset + 4, Rect.Top + 2, S);\r\n if odFocused in State then\r\n DrawFocusRect(RectText);\r\n end;\r\nend;\r\n\r\nfunction TJvDirectoryListBox.GetItemPath(Index: Integer): string;\r\nbegin\r\n Result := '';\r\n if Index < Items.Count then\r\n Result := Items[Index];\r\n Exit;\r\nend;\r\n\r\nprocedure TJvDirectoryListBox.CreateWnd;\r\nbegin\r\n inherited CreateWnd;\r\n BuildList;\r\n ItemIndex := DirLevel(Directory);\r\nend;\r\n\r\nprocedure TJvDirectoryListBox.FontChanged;\r\nbegin\r\n inherited FontChanged;\r\n ResetItemHeight;\r\nend;\r\n\r\nprocedure TJvDirectoryListBox.ResetItemHeight;\r\nvar\r\n NewHeight: Integer;\r\nbegin\r\n NewHeight := GetItemHeight(Font);\r\n if NewHeight < (FImages.Height + 1) then\r\n NewHeight := FImages.Height + 1;\r\n ItemHeight := NewHeight;\r\nend;\r\n\r\nfunction TJvDirectoryListBox.GetDrive: Char;\r\nbegin\r\n Result := FDirectory[1];\r\nend;\r\n\r\nprocedure TJvDirectoryListBox.SetDrive(Value: Char);\r\nbegin\r\n if UpCase(Value) <> UpCase(Drive) then\r\n SetDirectory(Format('%s:', [Value]));\r\nend;\r\n\r\nprocedure TJvDirectoryListBox.SetDirectory(const NewDirectory: string);\r\nvar\r\n NewDrive: string;\r\nbegin\r\n { When reading from the stream, always set the directory; if we don't do this\r\n the image indexes aren't initialized }\r\n if (Length(NewDirectory) = 0) or\r\n (SameFileName(NewDirectory, Directory) and not (csReading in ComponentState)) then\r\n Exit;\r\n NewDrive := ExtractFileDrive(NewDirectory);\r\n if Length(NewDrive) <> 2 then // we only support single Char drives (no UNC's)\r\n Exit;\r\n // ProcessPath(NewDirectory, NewDrive, DirPart, FilePart);\r\n try\r\n if Drive <> NewDrive[1] then\r\n begin\r\n FInSetDir := True;\r\n if FDriveCombo <> nil then\r\n FDriveCombo.Drive := NewDrive[1]\r\n else\r\n DriveChange(NewDrive[1]);\r\n end;\r\n finally\r\n FInSetDir := False;\r\n end;\r\n if not DirectoryExists(NewDirectory) then\r\n SetDir(GetCurrentDir) // we have to do this because we might have changed drive\r\n else\r\n SetDir(NewDirectory);\r\nend;\r\n\r\nprocedure TJvDirectoryListBox.KeyPress(var Key: Char);\r\nbegin\r\n inherited KeyPress(Key);\r\n if Word(Key) = VK_RETURN then\r\n OpenCurrent;\r\nend;\r\n\r\nprocedure TJvDirectoryListBox.Notification(AComponent: TComponent;\r\n Operation: TOperation);\r\nbegin\r\n inherited Notification(AComponent, Operation);\r\n if Operation = opRemove then\r\n begin\r\n if AComponent = FFileList then\r\n FFileList := nil\r\n else\r\n if AComponent = FDriveCombo then\r\n FDriveCombo := nil\r\n else\r\n if AComponent = FDirLabel then\r\n FDirLabel := nil;\r\n end;\r\nend;\r\n\r\nprocedure TJvDirectoryListBox.SetDirLabelCaption;\r\nvar\r\n DirWidth: Integer;\r\nbegin\r\n if FDirLabel <> nil then\r\n begin\r\n DirWidth := Width;\r\n if not FDirLabel.AutoSize then\r\n DirWidth := FDirLabel.Width;\r\n FDirLabel.Caption := MinimizeName(Directory, FDirLabel.Canvas, DirWidth);\r\n end;\r\nend;\r\n\r\nprocedure TJvDirectoryListBox.SetDriveCombo(const Value: TJvDriveCombo);\r\nbegin\r\n if FDriveCombo <> nil then\r\n FDriveCombo.FDirList := nil;\r\n ReplaceComponentReference(Self, Value, TComponent(FDriveCombo));\r\n if FDriveCombo <> nil then\r\n begin\r\n FDriveCombo.FDirList := Self;\r\n FDriveCombo.Drive := Drive;\r\n end;\r\nend;\r\n\r\nprocedure TJvDirectoryListBox.Click;\r\nbegin\r\n if FAutoExpand then\r\n OpenCurrent;\r\n inherited Click;\r\nend;\r\n\r\nprocedure TJvDirectoryListBox.SetShowAllFolders(const Value: Boolean);\r\nbegin\r\n if FShowAllFolders <> Value then\r\n begin\r\n FShowAllFolders := Value;\r\n BuildList;\r\n end;\r\nend;\r\n\r\n//=== { TJvFileListBox } =====================================================\r\n\r\nconstructor TJvFileListBox.Create(AOwner: TComponent);\r\nvar\r\n shi: TSHFileInfo;\r\nbegin\r\n inherited Create(AOwner);\r\n FImages := TImageList.CreateSize(16, 16);\r\n FImages.ShareImages := True;\r\n FillChar(shi, SizeOf(shi), 0);\r\n FImages.Handle := SHGetFileInfo('', 0, shi, SizeOf(shi), SHGFI_SYSICONINDEX or SHGFI_SMALLICON);\r\n FImages.DrawingStyle := dsTransparent;\r\n\r\n FSearchFiles := TJvSearchFiles.Create(Self);\r\n FSearchFiles.Options := [soAllowDuplicates,\r\n soSearchDirs, soSearchFiles, soStripDirs];\r\n FSearchFiles.DirOption := doExcludeSubDirs;\r\n FSearchFiles.FileParams.FileMaskSeperator := ';';\r\n FSearchFiles.FileParams.SearchTypes := [stAttribute, stFileMask];\r\n FSearchFiles.FileParams.Attributes.IncludeAttr := 0;\r\n { No filter on drives }\r\n FSearchFiles.DirParams.SearchTypes := [];\r\n FSearchFiles.ErrorResponse := erIgnore;\r\n\r\n // We sort the directory and file list ourself. This is necessary to fix Mantis #5295.\r\n // The control inserted a space character in front of all directory names to get them\r\n // sorted above all files. But this space character couldn't be removed before handling\r\n // the item's text to the user.\r\n inherited Sorted := False;\r\nend;\r\n\r\ndestructor TJvFileListBox.Destroy;\r\nbegin\r\n FImages.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvFileListBox.ReadFileNames;\r\nvar\r\n shinf: SHFILEINFO;\r\n I, J: Integer;\r\n Flags: Cardinal;\r\n AttrIndex: TFileAttr;\r\n AttrWord: DWORD;\r\n SaveCursor: TCursor;\r\nconst\r\n SHGFI_OVERLAYINDEX = $00000040;\r\n {TFileAttr = (ftReadOnly, ftHidden, ftSystem, ftVolumeID, ftDirectory,\r\n ftArchive, ftNormal);}\r\n Attributes: array [TFileAttr] of Word = (FILE_ATTRIBUTE_READONLY, FILE_ATTRIBUTE_HIDDEN,\r\n FILE_ATTRIBUTE_SYSTEM, 0 {faVolumeID}, 0 {faDirectory}, FILE_ATTRIBUTE_ARCHIVE,\r\n FILE_ATTRIBUTE_READONLY or FILE_ATTRIBUTE_ARCHIVE or FILE_ATTRIBUTE_NORMAL {faNormal});\r\n CAllAttributes = FILE_ATTRIBUTE_READONLY or FILE_ATTRIBUTE_HIDDEN or\r\n FILE_ATTRIBUTE_SYSTEM or FILE_ATTRIBUTE_ARCHIVE or FILE_ATTRIBUTE_NORMAL;\r\nbegin\r\n AttrWord := 0;\r\n if HandleAllocated then\r\n begin\r\n { Set attribute flags based on values in FileType }\r\n for AttrIndex := Low(TFileAttr) to High(TFileAttr) do\r\n if AttrIndex in FileType then\r\n AttrWord := AttrWord or Attributes[AttrIndex];\r\n SetCurrentDir(FDirectory); { go to the directory we want }\r\n Clear; { clear the list }\r\n\r\n SaveCursor := Screen.Cursor;\r\n try\r\n FSearchFiles.RootDirectory := GetCurrentDir;\r\n FSearchFiles.FileParams.FileMask := FMask;\r\n { CAllAttributes is used to ensure that we do not filter out some new\r\n Attributes, such as FILE_ATTRIBUTE_NOT_CONTENT_INDEXED etc }\r\n FSearchFiles.FileParams.Attributes.ExcludeAttr := not AttrWord and CAllAttributes;\r\n if ftDirectory in FileType then\r\n FSearchFiles.Options := FSearchFiles.Options + [soSearchDirs]\r\n else\r\n FSearchFiles.Options := FSearchFiles.Options - [soSearchDirs];\r\n\r\n FSearchFiles.Search;\r\n\r\n { Overlay included to display linked folders or files etc. }\r\n Flags := SHGFI_SYSICONINDEX or SHGFI_SMALLICON or SHGFI_DISPLAYNAME;\r\n if GetShellVersion >= $00050000 then\r\n Flags := Flags or SHGFI_OVERLAYINDEX;\r\n\r\n { First add directories.. }\r\n if FSearchFiles.Directories is TStringList then\r\n TStringList(FSearchFiles.Directories).Sort;\r\n with FSearchFiles.Directories do\r\n for J := 0 to Count - 1 do\r\n begin\r\n { Note that the strings in FSearchFiles.Directories do not include a path }\r\n FillChar(shinf, SizeOf(shinf), 0);\r\n SHGetFileInfo(PChar(Strings[J]), 0, shinf, SizeOf(shinf), Flags);\r\n if FForceFileExtensions then\r\n I := Items.Add(Strings[J])\r\n else\r\n I := Items.Add(string(shinf.szDisplayName));\r\n Items.Objects[I] := TObject(shinf.iIcon);\r\n if I = 100 then\r\n Screen.Cursor := crHourGlass;\r\n end;\r\n\r\n { ..then add files }\r\n if FSearchFiles.Files is TStringList then\r\n TStringList(FSearchFiles.Files).Sort;\r\n with FSearchFiles.Files do\r\n for J := 0 to Count - 1 do\r\n begin\r\n FillChar(shinf, SizeOf(shinf), 0);\r\n SHGetFileInfo(PChar(Strings[J]), 0, shinf, SizeOf(shinf), Flags);\r\n if FForceFileExtensions then\r\n I := Items.Add(Strings[J])\r\n else\r\n I := Items.Add(shinf.szDisplayName);\r\n Items.Objects[I] := TObject(shinf.iIcon);\r\n if I = 100 then\r\n Screen.Cursor := crHourGlass;\r\n end;\r\n finally\r\n Screen.Cursor := SaveCursor;\r\n end;\r\n Change;\r\n end;\r\nend;\r\n\r\nprocedure TJvFileListBox.SetDirectory(const Value: string);\r\nbegin\r\n // Mantis #5301. We split the Directory and FileName setter to handle them slightly different.\r\n // For FileName we must only change the directory if the file path changed.\r\n if (Value <> '') and\r\n (AnsiCompareFileName(ExcludeTrailingPathDelimiter(FileName), ExcludeTrailingPathDelimiter(Directory)) <> 0) then\r\n begin\r\n inherited ApplyFilePath(Value);\r\n ReadFileNames;\r\n end;\r\nend;\r\n\r\nprocedure TJvFileListBox.ApplyFilePath(const EditText: string);\r\nbegin\r\n if (EditText <> '') and\r\n (AnsiCompareFileName(ExtractFilePath(FileName), ExtractFilePath(EditText)) <> 0) then\r\n begin\r\n inherited ApplyFilePath(EditText);\r\n ReadFileNames;\r\n end;\r\nend;\r\n\r\nprocedure TJvFileListBox.SetForceFileExtensions(const Value: Boolean);\r\nbegin\r\n if FForceFileExtensions <> Value then\r\n begin\r\n FForceFileExtensions := Value;\r\n ReadFileNames;\r\n end;\r\nend;\r\n\r\nprocedure TJvFileListBox.CNDrawItem(var Msg: TWMDrawItem);\r\nvar\r\n State: TOwnerDrawState;\r\nbegin\r\n with Msg.DrawItemStruct^ do\r\n begin\r\n State := TOwnerDrawState(Lo(itemState));\r\n Canvas.Handle := hDC;\r\n Canvas.Font := Font;\r\n Canvas.Brush := Brush;\r\n if (Integer(itemID) >= 0) and (odSelected in State) then\r\n begin\r\n Canvas.Brush.Color := clHighlight;\r\n Canvas.Font.Color := clHighlightText\r\n end;\r\n if Integer(itemID) >= 0 then\r\n DrawItem(itemID, rcItem, State)\r\n else\r\n Canvas.FillRect(rcItem);\r\n // if odFocused in State then DrawFocusRect(hDC, rcItem);\r\n Canvas.Handle := 0;\r\n end;\r\nend;\r\n\r\nprocedure TJvFileListBox.DrawItem(Index: Integer; Rect: TRect;\r\n State: TOwnerDrawState);\r\nvar\r\n Offset: Integer;\r\n tmpR: TRect;\r\n ImageIndex: Integer;\r\n OverlayIndex: Integer;\r\nbegin\r\n with Canvas do\r\n begin\r\n // FillRect(Rect);\r\n Offset := 2;\r\n tmpR := Rect;\r\n if ShowGlyphs then\r\n begin\r\n ImageIndex := Integer(Items.Objects[Index]);\r\n OverlayIndex := (ImageIndex shr 24) - 1;\r\n if OverlayIndex >= 0 then\r\n FImages.DrawOverlay(Canvas, Rect.Left + 2, (Rect.Top + Rect.Bottom - FImages.Height) div 2,\r\n ImageIndex and $00FFFFFF, OverlayIndex)\r\n else\r\n FImages.Draw(Canvas, Rect.Left + 2, (Rect.Top + Rect.Bottom - FImages.Height) div 2,\r\n ImageIndex);\r\n Offset := FImages.Width + 6;\r\n end;\r\n\r\n tmpR.Left := tmpR.Left + Offset - 2;\r\n tmpR.Right := tmpR.Left + TextWidth(Items[Index]) + 4;\r\n FillRect(tmpR);\r\n TextOut(Rect.Left + Offset, Rect.Top, Items[Index]);\r\n\r\n if odFocused in State then\r\n DrawFocusRect(tmpR);\r\n end;\r\nend;\r\n\r\nfunction TJvDriveList.GetDrives(Index: Integer): string;\r\nbegin\r\n Result := FDrives[Index];\r\nend;\r\n\r\nfunction TJvDriveList.GetDriveCount: Integer;\r\nbegin\r\n Result := FDrives.Count;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvDropDownForm.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvDropDownForm, released on 2002-10-04.\r\n\r\nThe Initial Developer of the Original Code is Oliver Giesen [giesen att lucatec dott com]\r\nPortions created by Oliver Giesen are Copyright (C) 2002 Lucatec GmbH.\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\n Andreas Hausladen\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nDescription:\r\n A generic container form to be displayed as dropdown below a TCustomEdit\r\n descendant.\r\n\r\n There's still plenty of room for improvement here.\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvDropDownForm.pas 13138 2011-10-26 23:17:50Z jfudickar $\r\n\r\nunit JvDropDownForm;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, Messages,\r\n Classes, Controls, StdCtrls, Forms,\r\n JvTypes, JvExForms;\r\n\r\ntype\r\n TJvCustomDropDownForm = class(TJvExCustomForm)\r\n private\r\n FEntering: Boolean;\r\n FCloseOnLeave: Boolean;\r\n FLeaving: Boolean;\r\n FOnKillFocus: TJvFocusChangeEvent;\r\n FOnSetFocus: TJvFocusChangeEvent;\r\n protected\r\n function GetEdit: TCustomEdit;\r\n procedure FocusSet(PrevWnd: THandle); override;\r\n procedure FocusKilled(NextWnd: THandle); override;\r\n procedure DoFocusSet(const APreviousControl: TWinControl); dynamic;\r\n procedure DoFocusKilled(const ANextControl: TWinControl); dynamic;\r\n procedure DoClose(var Action: TCloseAction); override;\r\n procedure DoShow; override;\r\n procedure CreateParams(var AParams: TCreateParams); override;\r\n property Edit: TCustomEdit read GetEdit;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n property CloseOnLeave: Boolean read FCloseOnLeave write FCloseOnLeave; // (ahuser) meight have no function under VisualCLX\r\n property Entering: Boolean read FEntering;\r\n property Leaving: Boolean read FLeaving;\r\n property OnSetFocus: TJvFocusChangeEvent read FOnSetFocus write FOnSetFocus;\r\n property OnKillFocus: TJvFocusChangeEvent read FOnKillFocus write FOnKillFocus;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvDropDownForm.pas $';\r\n Revision: '$Revision: 13138 $';\r\n Date: '$Date: 2011-10-27 01:17:50 +0200 (jeu. 27 oct. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n SysUtils,\r\n JvResources, JvJVCLUtils;\r\n\r\ntype\r\n TCustomEditAccessProtected = class(TCustomEdit);\r\n\r\nconstructor TJvCustomDropDownForm.Create(AOwner: TComponent);\r\nbegin\r\n if not (AOwner is TCustomEdit) then\r\n raise EJVCLException.CreateRes(@RsETJvCustomDropDownFormCreateOwnerMus);\r\n\r\n inherited CreateNew(AOwner);\r\n\r\n BorderIcons := [];\r\n BorderStyle := bsNone;\r\n Font := TCustomEditAccessProtected(AOwner).Font;\r\n\r\n Position := poDesigned; // required for D2005\r\n FEntering := True;\r\n FLeaving := False;\r\n FCloseOnLeave := True;\r\nend;\r\n\r\n\r\nprocedure TJvCustomDropDownForm.CreateParams(var AParams: TCreateParams);\r\nbegin\r\n inherited CreateParams(AParams);\r\n AParams.Style := AParams.Style or WS_BORDER;\r\n\r\n // Fixing the Window Ghosting \"bug\"\r\n // This also fixes mantis 3409 where the popup would not appear if its\r\n // associated control was placed on a form with fsStayOnTop form style.\r\n AParams.Style := Aparams.Style or WS_POPUP;\r\n if Assigned(Screen.ActiveForm) then\r\n AParams.WndParent := Screen.ActiveForm.Handle\r\n else\r\n if Assigned (Application.MainForm) then\r\n AParams.WndParent := Application.MainForm.Handle\r\n else\r\n AParams.WndParent := Application.Handle;\r\nend;\r\n\r\n\r\n\r\n\r\nprocedure TJvCustomDropDownForm.DoClose(var Action: TCloseAction);\r\nbegin\r\n Action := caFree;\r\n inherited DoClose(Action);\r\nend;\r\n\r\nprocedure TJvCustomDropDownForm.DoShow;\r\nvar\r\n LScreenRect: TRect;\r\nbegin\r\n inherited DoShow;\r\n\r\n // Mantis 3357: Always reposition ourselves with respect to the owner\r\n // as it may have moved between two of our apparitions.\r\n with TWinControl(Owner) do\r\n begin\r\n Self.Left := ClientOrigin.X;\r\n Self.Top := ClientOrigin.Y + Height;\r\n end;\r\n\r\n if Screen.MonitorCount > 0 then\r\n begin\r\n LScreenRect := Monitor.WorkareaRect;\r\n if (Left + Width > LScreenRect.Right) then\r\n Left := LScreenRect.Right - Width;\r\n if (Top + Height > LScreenRect.Bottom) then\r\n Top := Self.Edit.ClientOrigin.Y - Height;\r\n end\r\n else\r\n begin\r\n if not SystemParametersInfo(SPI_GETWORKAREA, 0, @LScreenRect, 0) then\r\n LScreenRect := Rect(0, 0, Screen.Width, Screen.Height);\r\n if (Left + Width > LScreenRect.Right) then\r\n Left := LScreenRect.Right - Width;\r\n if (Top + Height > LScreenRect.Bottom) then\r\n Top := Self.Edit.ClientOrigin.Y - Height;\r\n end;\r\nend;\r\n\r\nfunction TJvCustomDropDownForm.GetEdit: TCustomEdit;\r\nbegin\r\n Result := TCustomEdit(Owner);\r\nend;\r\n\r\nprocedure TJvCustomDropDownForm.FocusKilled(NextWnd: THandle);\r\nbegin\r\n if IsChildWindow(NextWnd, Self.Handle) then\r\n inherited FocusKilled(NextWnd)\r\n else\r\n begin\r\n FLeaving := True;\r\n try\r\n inherited FocusKilled(NextWnd);\r\n DoFocusKilled(FindControl(NextWnd));\r\n finally\r\n FLeaving := False;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomDropDownForm.DoFocusKilled(const ANextControl: TWinControl);\r\nbegin\r\n if Assigned(FOnKillFocus) then\r\n FOnKillFocus(Self, ANextControl);\r\n if CloseOnLeave then\r\n Close;\r\nend;\r\n\r\nprocedure TJvCustomDropDownForm.FocusSet(PrevWnd: THandle);\r\nbegin\r\n if IsChildWindow(PrevWnd, Self.Handle) then\r\n inherited FocusSet(PrevWnd)\r\n else\r\n begin\r\n FEntering := True;\r\n try\r\n inherited FocusSet(PrevWnd);\r\n DoFocusSet(FindControl(PrevWnd));\r\n finally\r\n FEntering := False;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomDropDownForm.DoFocusSet(const APreviousControl: TWinControl);\r\nbegin\r\n if Assigned(FOnSetFocus) then\r\n FOnSetFocus(Self, APreviousControl);\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvDsgnIntf.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvDsgnIntf.PAS, released on 2002-07-04.\r\n\r\nThe Initial Developers of the Original Code are: Andrei Prygounkov \r\nCopyright (c) 1999, 2002 Andrei Prygounkov\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\ndescription : interface to design-time routines\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvDsgnIntf.pas 12461 2009-08-14 17:21:33Z obones $\r\n\r\nunit JvDsgnIntf;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, Classes, Graphics;\r\n\r\n{ DrawDesignFrame draws frame on the rect, Rect.\r\n JVCL uses this function to drawing frame around controls at design-time }\r\n\r\nprocedure DrawDesignFrame(Canvas: TCanvas; Rect: TRect);\r\n\r\nprocedure DesignerNotify(ASelf, Item: TComponent; Operation: TOperation);\r\nprocedure DesignerModified(ASelf: TComponent);\r\nprocedure DesignerSelectComponent(ASelf: TComponent);\r\n\r\nvar\r\n DrawDesignFrameProc: procedure(Canvas: TCanvas; Rect: TRect);\r\n DesignerNotifyProc: procedure(ASelf, Item: TComponent; Operation: TOperation);\r\n DesignerModifiedProc: procedure(ASelf: TComponent);\r\n DesignerSelectComponentProc: procedure(ASelf: TComponent);\r\n\r\ntype\r\n TGetProjectNameProc = function: string;\r\n\r\nvar\r\n GetProjectNameProc: TGetProjectNameProc = nil;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvDsgnIntf.pas $';\r\n Revision: '$Revision: 12461 $';\r\n Date: '$Date: 2009-08-14 19:21:33 +0200 (ven. 14 août 2009) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\n\r\nprocedure DrawDesignFrame(Canvas: TCanvas; Rect: TRect);\r\nbegin\r\n if Assigned(DrawDesignFrameProc) then\r\n DrawDesignFrameProc(Canvas, Rect);\r\nend;\r\n\r\nprocedure DesignerNotify(ASelf, Item: TComponent; Operation: TOperation);\r\nbegin\r\n if Assigned(DesignerNotifyProc) then\r\n DesignerNotifyProc(ASelf, Item, Operation);\r\nend;\r\n\r\nprocedure DesignerModified(ASelf: TComponent);\r\nbegin\r\n if Assigned(DesignerModifiedProc) then\r\n DesignerModifiedProc(ASelf);\r\nend;\r\n\r\nprocedure DesignerSelectComponent(ASelf: TComponent);\r\nbegin\r\n if Assigned(DesignerSelectComponentProc) then\r\n DesignerSelectComponentProc(ASelf);\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvDualList.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvDUALLIST.PAS, released on 2002-07-04.\r\n\r\nThe Initial Developers of the Original Code are: Fedor Koshevnikov, Igor Pavluk and Serge Korolev\r\nCopyright (c) 1997, 1998 Fedor Koshevnikov, Igor Pavluk and Serge Korolev\r\nCopyright (c) 2001,2002 SGB Software\r\nAll Rights Reserved.\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvDualList.pas 13415 2012-09-10 09:51:54Z obones $\r\n\r\nunit JvDualList;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, // inline\r\n Classes, Controls, StdCtrls,\r\n {$IFDEF HAS_UNIT_SYSTEM_UITYPES}\r\n System.UITypes,\r\n {$ENDIF HAS_UNIT_SYSTEM_UITYPES}\r\n JvComponentBase, Forms;\r\n\r\ntype\r\n TJvDualListCustomizeEvent = procedure(Sender: TObject; Form: TCustomForm) of object;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvDualListDialog = class(TJvComponent)\r\n private\r\n FSorted: Boolean;\r\n FTitle: string;\r\n FLabel1Caption: TCaption;\r\n FLabel2Caption: TCaption;\r\n FOkBtnCaption: TCaption;\r\n FCancelBtnCaption: TCaption;\r\n FHelpBtnCaption: TCaption;\r\n FHelpContext: THelpContext;\r\n FList1: TStrings;\r\n FList2: TStrings;\r\n FShowHelp: Boolean;\r\n FScrollBars: TScrollStyle;\r\n FWidth: Integer;\r\n FOnCustomize: TJvDualListCustomizeEvent;\r\n FHeight: Integer;\r\n FCenterOnControl: TControl;\r\n FResizable: Boolean;\r\n procedure SetList1(Value: TStrings);\r\n procedure SetList2(Value: TStrings);\r\n function IsLabel1Custom: Boolean;\r\n function IsLabel2Custom: Boolean;\r\n function IsOkBtnCustom: Boolean;\r\n function IsCancelBtnCustom: Boolean;\r\n function IsHelpBtnCustom: Boolean;\r\n procedure SetCenterOnControl(const Value: TControl);\r\n protected\r\n procedure CustomizeForm(AForm: TCustomForm); virtual;\r\n procedure Notification(AComponent: TComponent; Operation: TOperation); override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n function Execute: Boolean;\r\n published\r\n property Sorted: Boolean read FSorted write FSorted;\r\n property Title: string read FTitle write FTitle;\r\n property Label1Caption: TCaption read FLabel1Caption write FLabel1Caption stored IsLabel1Custom;\r\n property Label2Caption: TCaption read FLabel2Caption write FLabel2Caption stored IsLabel2Custom;\r\n property OkBtnCaption: TCaption read FOkBtnCaption write FOkBtnCaption stored IsOkBtnCustom;\r\n property CancelBtnCaption: TCaption read FCancelBtnCaption write FCancelBtnCaption stored IsCancelBtnCustom;\r\n property HelpBtnCaption: TCaption read FHelpBtnCaption write FHelpBtnCaption stored IsHelpBtnCustom;\r\n property HelpContext: THelpContext read FHelpContext write FHelpContext;\r\n property List1: TStrings read FList1 write SetList1;\r\n property List2: TStrings read FList2 write SetList2;\r\n property CenterOnControl: TControl read FCenterOnControl write SetCenterOnControl;\r\n property Width: Integer read FWidth write FWidth default 0;\r\n property Height: Integer read FHeight write FHeight default 0;\r\n property ShowHelp: Boolean read FShowHelp write FShowHelp default True;\r\n property ScrollBars: TScrollStyle read FScrollBars write FScrollBars default ssBoth;\r\n property Resizable: Boolean read FResizable write FResizable default True;\r\n property OnCustomize: TJvDualListCustomizeEvent read FOnCustomize write FOnCustomize;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvDualList.pas $';\r\n Revision: '$Revision: 13415 $';\r\n Date: '$Date: 2012-09-10 11:51:54 +0200 (lun. 10 sept. 2012) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n Types, Consts, SysUtils,\r\n JvDualListForm, JvResources, JvJVCLUtils;\r\n\r\nconstructor TJvDualListDialog.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FShowHelp := True;\r\n FResizable := True;\r\n FScrollBars := ssBoth;\r\n FList1 := TStringList.Create;\r\n FList2 := TStringList.Create;\r\n FLabel1Caption := RsDualListSrcCaption;\r\n FLabel2Caption := RsDualListDestCaption;\r\n OkBtnCaption := SOKButton;\r\n CancelBtnCaption := SCancelButton;\r\n HelpBtnCaption := SHelpButton;\r\nend;\r\n\r\ndestructor TJvDualListDialog.Destroy;\r\nbegin\r\n CenterOnControl := nil; // remove free notification\r\n List1.Free;\r\n List2.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvDualListDialog.CustomizeForm(AForm: TCustomForm);\r\nbegin\r\n if Assigned(FOnCustomize) then\r\n FOnCustomize(Self, AForm);\r\nend;\r\n\r\nprocedure TJvDualListDialog.SetCenterOnControl(const Value: TControl);\r\nbegin\r\n ReplaceComponentReference(Self, Value, TComponent(FCenterOnControl));\r\nend;\r\n\r\nprocedure TJvDualListDialog.SetList1(Value: TStrings);\r\nbegin\r\n FList1.Assign(Value);\r\nend;\r\n\r\nprocedure TJvDualListDialog.SetList2(Value: TStrings);\r\nbegin\r\n FList2.Assign(Value);\r\nend;\r\n\r\nfunction TJvDualListDialog.IsLabel1Custom: Boolean;\r\nbegin\r\n Result := AnsiCompareStr(Label1Caption, RsDualListSrcCaption) <> 0;\r\nend;\r\n\r\nfunction TJvDualListDialog.IsLabel2Custom: Boolean;\r\nbegin\r\n Result := AnsiCompareStr(Label2Caption, RsDualListDestCaption) <> 0;\r\nend;\r\n\r\nfunction TJvDualListDialog.IsOkBtnCustom: Boolean;\r\nbegin\r\n Result := AnsiCompareStr(OkBtnCaption, SOKButton) <> 0;\r\nend;\r\n\r\nprocedure TJvDualListDialog.Notification(AComponent: TComponent; Operation: TOperation);\r\nbegin\r\n inherited Notification(AComponent, Operation);\r\n if (Operation = opRemove) and (AComponent = CenterOnControl) then\r\n CenterOnControl := nil;\r\nend;\r\n\r\nfunction TJvDualListDialog.IsCancelBtnCustom: Boolean;\r\nbegin\r\n Result := AnsiCompareStr(CancelBtnCaption, SCancelButton) <> 0;\r\nend;\r\n\r\nfunction TJvDualListDialog.IsHelpBtnCustom: Boolean;\r\nbegin\r\n Result := AnsiCompareStr(HelpBtnCaption, SHelpButton) <> 0;\r\nend;\r\n\r\nfunction TJvDualListDialog.Execute: Boolean;\r\nvar\r\n Form: TJvDualListForm;\r\n Pt: TPoint;\r\nbegin\r\n Form := TJvDualListForm.Create(Application);\r\n try\r\n if Resizable then\r\n begin\r\n Form.BorderStyle := bsSizeable;\r\n Form.BorderIcons := Form.BorderIcons - [biMinimize, biMaximize] + [biSystemMenu];\r\n Form.Icon := nil;\r\n end;\r\n\r\n Form.SrcList.ScrollBars := FScrollBars;\r\n Form.DstList.ScrollBars := FScrollBars;\r\n Form.Font.Style := [];\r\n Form.ShowHelp := Self.ShowHelp;\r\n Form.SrcList.Sorted := Sorted;\r\n Form.DstList.Sorted := Sorted;\r\n Form.SrcList.Items := List1;\r\n Form.DstList.Items := List2;\r\n if Title <> '' then\r\n Form.Caption := Self.Title;\r\n if Label1Caption <> '' then\r\n Form.SrcLabel.Caption := Label1Caption;\r\n if Label2Caption <> '' then\r\n Form.DstLabel.Caption := Label2Caption;\r\n Form.OkBtn.Caption := OkBtnCaption;\r\n Form.CancelBtn.Caption := CancelBtnCaption;\r\n Form.HelpBtn.Caption := HelpBtnCaption;\r\n Form.HelpContext := Self.HelpContext;\r\n Form.HelpBtn.HelpContext := HelpContext;\r\n\r\n if Width <> 0 then\r\n Form.Width := Width;\r\n if Height <> 0 then\r\n Form.Height := Height;\r\n\r\n if CenterOnControl <> nil then\r\n begin\r\n Form.Position := poDesigned;\r\n Pt := CenterOnControl.ClientToScreen(Point(0, 0));\r\n Form.Left := Pt.X + (CenterOnControl.Width - Form.Width) div 2;\r\n Form.Top := Pt.Y + (CenterOnControl.Height - Form.Height) div 2;\r\n if Form.Left < 0 then\r\n Form.Left := 0;\r\n if Form.Top < 0 then\r\n Form.Top := 0;\r\n if Form.Left >= Screen.Width - Form.Width then\r\n Form.Left := Screen.Width - Form.Width;\r\n if Form.Top >= Screen.Height - Form.Height then\r\n Form.Top := Screen.Height - Form.Height;\r\n end;\r\n\r\n CustomizeForm(Form);\r\n Result := (Form.ShowModal = mrOk);\r\n if Result then\r\n begin\r\n List1 := Form.SrcList.Items;\r\n List2 := Form.DstList.Items;\r\n end;\r\n finally\r\n Form.Free;\r\n end;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\n\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvDualListForm.dfm", "content": "object JvDualListForm: TJvDualListForm\r\n Left = 198\r\n Top = 100\r\n ActiveControl = SrcList\r\n BorderIcons = []\r\n BorderStyle = bsSingle\r\n ClientHeight = 286\r\n ClientWidth = 398\r\n Color = clBtnFace\r\n Constraints.MinHeight = 320\r\n Constraints.MinWidth = 400\r\n Font.Charset = DEFAULT_CHARSET\r\n Font.Color = clWindowText\r\n Font.Height = -11\r\n Font.Name = 'MS Sans Serif'\r\n Font.Style = []\r\n Icon.Data = {\r\n 0000010001001010100001001000280100001600000028000000100000002000\r\n 00000100040000000000C0000000000000000000000000000000000000000000\r\n 0000000080000080000000808000800000008000800080800000C0C0C0008080\r\n 80000000FF0000FF000000FFFF00FF000000FF00FF00FFFF0000FFFFFF000000\r\n 00000000000000000BBBB0000000000BB000BB000000000BB0000B000000000B\r\n BB000BB00000000BBB000BB00000000000000BB00000000000000BB000000000\r\n 00000BB00000000000000BB00000000000000BB00000000000000BB000000000\r\n 00000BB0000000000000BBBB00000000000BBBBBB0000000000000000000FFFF\r\n 0000F87F0000E73F0000E7BF0000E39F0000E39F0000FF9F0000FF9F0000FF9F\r\n 0000FF9F0000FF9F0000FF9F0000FF9F0000FF0F0000FE070000FFFF0000}\r\n OldCreateOrder = True\r\n Position = poScreenCenter\r\n OnActivate = ListClick\r\n OnCreate = FormCreate\r\n OnResize = FormResize\r\n OnShow = ListClick\r\n DesignSize = (\r\n 398\r\n 286)\r\n PixelsPerInch = 96\r\n TextHeight = 13\r\n object Bevel1: TBevel\r\n Left = 4\r\n Top = 7\r\n Width = 384\r\n Height = 237\r\n Anchors = [akLeft, akTop, akRight, akBottom]\r\n ParentShowHint = False\r\n ShowHint = True\r\n end\r\n object SrcLabel: TLabel\r\n Left = 12\r\n Top = 12\r\n Width = 3\r\n Height = 13\r\n end\r\n object DstLabel: TLabel\r\n Left = 216\r\n Top = 12\r\n Width = 3\r\n Height = 13\r\n end\r\n object SrcList: TJvListBox\r\n Left = 12\r\n Top = 30\r\n Width = 164\r\n Height = 207\r\n Anchors = [akLeft, akTop, akBottom]\r\n DragMode = dmAutomatic\r\n ItemHeight = 13\r\n Background.FillMode = bfmTile\r\n Background.Visible = False\r\n MultiSelect = True\r\n ParentShowHint = False\r\n ShowHint = True\r\n Sorted = True\r\n TabOrder = 0\r\n OnClick = ListClick\r\n OnDblClick = IncBtnClick\r\n OnDragDrop = SrcListDragDrop\r\n OnDragOver = SrcListDragOver\r\n OnKeyDown = SrcListKeyDown\r\n end\r\n object DstList: TJvListBox\r\n Left = 216\r\n Top = 30\r\n Width = 164\r\n Height = 207\r\n Anchors = [akLeft, akTop, akBottom]\r\n DragMode = dmAutomatic\r\n ItemHeight = 13\r\n Background.FillMode = bfmTile\r\n Background.Visible = False\r\n MultiSelect = True\r\n ParentShowHint = False\r\n ShowHint = True\r\n Sorted = True\r\n TabOrder = 5\r\n OnClick = ListClick\r\n OnDblClick = ExclBtnClick\r\n OnDragDrop = DstListDragDrop\r\n OnDragOver = DstListDragOver\r\n OnKeyDown = DstListKeyDown\r\n end\r\n object IncBtn: TButton\r\n Left = 183\r\n Top = 32\r\n Width = 26\r\n Height = 26\r\n Caption = '>'\r\n Font.Charset = DEFAULT_CHARSET\r\n Font.Color = clBlack\r\n Font.Height = -12\r\n Font.Name = 'MS Sans Serif'\r\n Font.Style = [fsBold]\r\n ParentFont = False\r\n TabOrder = 1\r\n OnClick = IncBtnClick\r\n end\r\n object IncAllBtn: TButton\r\n Left = 183\r\n Top = 64\r\n Width = 26\r\n Height = 26\r\n Caption = '>>'\r\n Font.Charset = DEFAULT_CHARSET\r\n Font.Color = clBlack\r\n Font.Height = -12\r\n Font.Name = 'MS Sans Serif'\r\n Font.Style = [fsBold]\r\n ParentFont = False\r\n TabOrder = 2\r\n OnClick = IncAllBtnClick\r\n end\r\n object ExclBtn: TButton\r\n Left = 183\r\n Top = 97\r\n Width = 26\r\n Height = 26\r\n Caption = '<'\r\n Font.Charset = DEFAULT_CHARSET\r\n Font.Color = clBlack\r\n Font.Height = -12\r\n Font.Name = 'MS Sans Serif'\r\n Font.Style = [fsBold]\r\n ParentFont = False\r\n TabOrder = 3\r\n OnClick = ExclBtnClick\r\n end\r\n object ExclAllBtn: TButton\r\n Left = 183\r\n Top = 129\r\n Width = 26\r\n Height = 26\r\n Caption = '<<'\r\n Font.Charset = DEFAULT_CHARSET\r\n Font.Color = clBlack\r\n Font.Height = -12\r\n Font.Name = 'MS Sans Serif'\r\n Font.Style = [fsBold]\r\n ParentFont = False\r\n TabOrder = 4\r\n OnClick = ExclAllBtnClick\r\n end\r\n object PanelButtons: TPanel\r\n Left = 0\r\n Top = 248\r\n Width = 398\r\n Height = 38\r\n Align = alBottom\r\n BevelOuter = bvNone\r\n TabOrder = 6\r\n DesignSize = (\r\n 398\r\n 38)\r\n object OkBtn: TButton\r\n Left = 130\r\n Top = 5\r\n Width = 77\r\n Height = 25\r\n Anchors = [akTop, akRight]\r\n Caption = 'OK'\r\n Default = True\r\n ModalResult = 1\r\n TabOrder = 0\r\n end\r\n object CancelBtn: TButton\r\n Left = 213\r\n Top = 5\r\n Width = 77\r\n Height = 25\r\n Anchors = [akTop, akRight]\r\n Cancel = True\r\n Caption = 'Cancel'\r\n ModalResult = 2\r\n TabOrder = 1\r\n end\r\n object HelpBtn: TButton\r\n Left = 310\r\n Top = 5\r\n Width = 77\r\n Height = 25\r\n Anchors = [akTop, akRight]\r\n Caption = 'Help'\r\n TabOrder = 2\r\n OnClick = HelpBtnClick\r\n end\r\n end\r\nend\r\n" }, { "path": "External/Jedi/Jvcl/run/JvDualListForm.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvFDualLst.PAS, released on 2002-07-04.\r\n\r\nThe Initial Developers of the Original Code are: Fedor Koshevnikov, Igor Pavluk and Serge Korolev\r\nCopyright (c) 1997, 1998 Fedor Koshevnikov, Igor Pavluk and Serge Korolev\r\nCopyright (c) 2001,2002 SGB Software\r\nAll Rights Reserved.\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvDualListForm.pas 13138 2011-10-26 23:17:50Z jfudickar $\r\n\r\nunit JvDualListForm;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, Types, Classes, Graphics, Controls, Forms, StdCtrls, ExtCtrls,\r\n JvListBox,\r\n JvComponent;\r\n\r\ntype\r\n TJvDualListForm = class(TJvForm)\r\n SrcList: TJvListBox;\r\n DstList: TJvListBox;\r\n SrcLabel: TLabel;\r\n DstLabel: TLabel;\r\n IncBtn: TButton;\r\n IncAllBtn: TButton;\r\n ExclBtn: TButton;\r\n ExclAllBtn: TButton;\r\n Bevel1: TBevel;\r\n PanelButtons: TPanel;\r\n OkBtn: TButton;\r\n CancelBtn: TButton;\r\n HelpBtn: TButton;\r\n procedure IncBtnClick(Sender: TObject);\r\n procedure IncAllBtnClick(Sender: TObject);\r\n procedure ExclBtnClick(Sender: TObject);\r\n procedure ExclAllBtnClick(Sender: TObject);\r\n procedure SrcListDragOver(Sender, Source: TObject; X, Y: Integer;\r\n State: TDragState; var Accept: Boolean);\r\n procedure DstListDragOver(Sender, Source: TObject; X, Y: Integer;\r\n State: TDragState; var Accept: Boolean);\r\n procedure SrcListDragDrop(Sender, Source: TObject; X, Y: Integer);\r\n procedure DstListDragDrop(Sender, Source: TObject; X, Y: Integer);\r\n procedure SrcListKeyDown(Sender: TObject; var Key: Word;\r\n Shift: TShiftState);\r\n procedure DstListKeyDown(Sender: TObject; var Key: Word;\r\n Shift: TShiftState);\r\n procedure HelpBtnClick(Sender: TObject);\r\n procedure FormCreate(Sender: TObject);\r\n procedure ListClick(Sender: TObject);\r\n procedure FormResize(Sender: TObject);\r\n private\r\n function GetShowHelp: Boolean;\r\n procedure SetShowHelp(Value: Boolean);\r\n public\r\n procedure SetButtons;\r\n property ShowHelp: Boolean read GetShowHelp write SetShowHelp default True;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvDualListForm.pas $';\r\n Revision: '$Revision: 13138 $';\r\n Date: '$Date: 2011-10-27 01:17:50 +0200 (jeu. 27 oct. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n Consts,\r\n JvBoxProcs;\r\n\r\n{$R *.dfm}\r\n\r\nprocedure TJvDualListForm.SetButtons;\r\nvar\r\n SrcEmpty, DstEmpty: Boolean;\r\nbegin\r\n SrcEmpty := (SrcList.Items.Count = 0);\r\n DstEmpty := (DstList.Items.Count = 0);\r\n IncBtn.Enabled := not SrcEmpty and (SrcList.SelCount > 0);\r\n IncAllBtn.Enabled := not SrcEmpty;\r\n ExclBtn.Enabled := not DstEmpty and (DstList.SelCount > 0);\r\n ExclAllBtn.Enabled := not DstEmpty;\r\nend;\r\n\r\nfunction TJvDualListForm.GetShowHelp: Boolean;\r\nbegin\r\n Result := HelpBtn.Enabled and HelpBtn.Visible;\r\nend;\r\n\r\nprocedure TJvDualListForm.SetShowHelp(Value: Boolean);\r\nconst\r\n x_FrmBtn = 16;\r\n x_GrpBtn = 15;\r\n x_BtnBtn = 8;\r\nbegin\r\n with HelpBtn do\r\n begin\r\n Enabled := Value;\r\n Visible := Value;\r\n end;\r\n if Value then\r\n begin\r\n HelpBtn.Left := Width - HelpBtn.Width - x_FrmBtn;\r\n CancelBtn.Left := HelpBtn.Left - CancelBtn.Width - x_GrpBtn;\r\n OkBtn.Left := CancelBtn.Left - OkBtn.Width - x_BtnBtn;;\r\n end\r\n else\r\n begin\r\n CancelBtn.Left := Width - CancelBtn.Width - x_FrmBtn;\r\n OkBtn.Left := CancelBtn.Left - OkBtn.Width - x_BtnBtn;;\r\n end;\r\nend;\r\n\r\nprocedure TJvDualListForm.IncBtnClick(Sender: TObject);\r\nbegin\r\n BoxMoveSelectedItems(SrcList, DstList);\r\n SetButtons;\r\nend;\r\n\r\nprocedure TJvDualListForm.IncAllBtnClick(Sender: TObject);\r\nbegin\r\n BoxMoveAllItems(SrcList, DstList);\r\n SetButtons;\r\nend;\r\n\r\nprocedure TJvDualListForm.ExclBtnClick(Sender: TObject);\r\nbegin\r\n BoxMoveSelectedItems(DstList, SrcList);\r\n SetButtons;\r\nend;\r\n\r\nprocedure TJvDualListForm.ExclAllBtnClick(Sender: TObject);\r\nbegin\r\n BoxMoveAllItems(DstList, SrcList);\r\n SetButtons;\r\nend;\r\n\r\nprocedure TJvDualListForm.SrcListDragOver(Sender, Source: TObject;\r\n X, Y: Integer; State: TDragState; var Accept: Boolean);\r\nbegin\r\n BoxDragOver(SrcList, Source, X, Y, State, Accept, SrcList.Sorted);\r\n if State = dsDragLeave then\r\n (Source as TJvListBox).DragCursor := crDrag;\r\n if (State = dsDragEnter) and ((Source as TJvListBox).SelCount > 1) then\r\n (Source as TJvListBox).DragCursor := crMultiDrag;\r\nend;\r\n\r\nprocedure TJvDualListForm.DstListDragOver(Sender, Source: TObject;\r\n X, Y: Integer; State: TDragState; var Accept: Boolean);\r\nbegin\r\n BoxDragOver(DstList, Source, X, Y, State, Accept, DstList.Sorted);\r\n if State = dsDragLeave then\r\n (Source as TJvListBox).DragCursor := crDrag;\r\n if (State = dsDragEnter) and ((Source as TJvListBox).SelCount > 1) then\r\n (Source as TJvListBox).DragCursor := crMultiDrag;\r\nend;\r\n\r\nprocedure TJvDualListForm.SrcListDragDrop(Sender, Source: TObject;\r\n X, Y: Integer);\r\nbegin\r\n if Source = DstList then\r\n ExclBtnClick(SrcList)\r\n else\r\n if Source = SrcList then\r\n BoxMoveFocusedItem(SrcList, SrcList.ItemAtPos(Point(X, Y), True));\r\nend;\r\n\r\nprocedure TJvDualListForm.DstListDragDrop(Sender, Source: TObject;\r\n X, Y: Integer);\r\nbegin\r\n if Source = SrcList then\r\n IncBtnClick(DstList)\r\n else\r\n if Source = DstList then\r\n BoxMoveFocusedItem(DstList, DstList.ItemAtPos(Point(X, Y), True));\r\nend;\r\n\r\nprocedure TJvDualListForm.SrcListKeyDown(Sender: TObject; var Key: Word;\r\n Shift: TShiftState);\r\nvar\r\n Incr: Integer;\r\nbegin\r\n if not SrcList.Sorted then\r\n begin\r\n if (ssCtrl in Shift) and ((Key = VK_DOWN) or (Key = VK_UP)) then\r\n begin\r\n if Key = VK_DOWN then\r\n Incr := 1\r\n else\r\n Incr := -1;\r\n BoxMoveFocusedItem(SrcList, SrcList.ItemIndex + Incr);\r\n Key := 0;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvDualListForm.DstListKeyDown(Sender: TObject; var Key: Word;\r\n Shift: TShiftState);\r\nvar\r\n Incr: Integer;\r\nbegin\r\n if not DstList.Sorted then\r\n begin\r\n if (ssCtrl in Shift) and ((Key = VK_DOWN) or (Key = VK_UP)) then\r\n begin\r\n if Key = VK_DOWN then\r\n Incr := 1\r\n else\r\n Incr := -1;\r\n BoxMoveFocusedItem(DstList, DstList.ItemIndex + Incr);\r\n Key := 0;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvDualListForm.HelpBtnClick(Sender: TObject);\r\nbegin\r\n Application.HelpContext(HelpContext);\r\nend;\r\n\r\nprocedure TJvDualListForm.FormCreate(Sender: TObject);\r\nbegin\r\n OkBtn.Caption := SOKButton;\r\n CancelBtn.Caption := SCancelButton;\r\n HelpBtn.Caption := SHelpButton;\r\n Font.Style := [];\r\nend;\r\n\r\nprocedure TJvDualListForm.FormResize(Sender: TObject);\r\nbegin\r\n { Delphi 5, 6, 7 and 2005 compatible code }\r\n IncBtn.Left := 4 + (Bevel1.Width - IncBtn.Width) div 2;\r\n IncAllBtn.Left := IncBtn.Left;\r\n ExclBtn.Left := IncBtn.Left;\r\n ExclAllBtn.Left := IncBtn.Left;\r\n SrcList.Width := (Bevel1.Width - (8 + 7 + IncBtn.Width + 7 + 8)) div 2;\r\n SrcLabel.Left := SrcList.Left;\r\n DstList.Width := SrcList.Width;\r\n DstList.Left := IncBtn.Left + IncBtn.Width + 7;\r\n DstLabel.Left := DstList.Left;\r\nend;\r\n\r\nprocedure TJvDualListForm.ListClick(Sender: TObject);\r\nbegin\r\n SetButtons;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend." }, { "path": "External/Jedi/Jvcl/run/JvDynControlEngine.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Initial Developer of the Original Code is Jens Fudickar [jens dott fudickar att oratool dott de]\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\nJens Fudickar [jens dott fudickar att oratool dott de]\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvDynControlEngine.pas 13339 2012-06-13 08:26:12Z obones $\r\n\r\nunit JvDynControlEngine;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n SysUtils, Classes, Controls, Forms, StdCtrls, Graphics,\r\n Variants,\r\n JvDynControlEngineIntf;\r\n\r\ntype\r\n TJvDynControlType = string;\r\n\r\nconst\r\n jctLabel = TJvDynControlType('Label');\r\n jctStaticText = TJvDynControlType('StaticText');\r\n jctPanel = TJvDynControlType('Panel');\r\n jctScrollBox = TJvDynControlType('ScrollBox');\r\n jctEdit = TJvDynControlType('Edit');\r\n jctCheckBox = TJvDynControlType('CheckBox');\r\n jctComboBox = TJvDynControlType('ComboBox');\r\n jctGroupBox = TJvDynControlType('GroupBox');\r\n jctImage = TJvDynControlType('Image');\r\n jctRadioGroup = TJvDynControlType('RadioGroup');\r\n jctRadioButton = TJvDynControlType('RadioButton');\r\n jctMemo = TJvDynControlType('Memo');\r\n jctRichEdit = TJvDynControlType('RichEdit');\r\n jctListBox = TJvDynControlType('ListBox');\r\n jctCheckListBox = TJvDynControlType('CheckListBox');\r\n jctCheckComboBox = TJvDynControlType('CheckComboBox');\r\n jctDateTimeEdit = TJvDynControlType('DateTimeEdit');\r\n jctDateEdit = TJvDynControlType('DateEdit');\r\n jctTimeEdit = TJvDynControlType('TimeEdit');\r\n jctCalculateEdit = TJvDynControlType('CalculateEdit');\r\n jctSpinEdit = TJvDynControlType('SpinEdit');\r\n jctDirectoryEdit = TJvDynControlType('DirectoryEdit');\r\n jctFileNameEdit = TJvDynControlType('FileNameEdit');\r\n jctButton = TJvDynControlType('Button');\r\n jctButtonEdit = TJvDynControlType('ButtonEdit');\r\n jctTreeView = TJvDynControlType('TreeView');\r\n jctForm = TJvDynControlType('Form');\r\n jctProgressBar = TJvDynControlType('Progressbar');\r\n jctPageControl = TJvDynControlType('Pagecontrol');\r\n jctTabControl = TJvDynControlType('Tabcontrol');\r\n jctRTTIInspector = TJvDynControlType('RTTIInspector');\r\n jctColorComboBox = TJvDynControlType('ColorComboBox');\r\n\r\ntype\r\n TControlClass = class of TControl;\r\n\r\n TJvControlClassObject = class(TObject)\r\n private\r\n FControlClass: TControlClass;\r\n public\r\n property ControlClass: TControlClass read FControlClass write FControlClass;\r\n end;\r\n\r\n TJvAfterCreateControl = procedure(AControl: TControl) of object;\r\n\r\n TJvCustomDynControlEngine = class(TPersistent)\r\n private\r\n //FRegisteredControlTypes: array [TJvDynControlType] of TControlClass;\r\n FRegisteredControlTypes: TStringList;\r\n FRegisterControlsExecuted: Boolean;\r\n FAfterCreateControl: TJvAfterCreateControl;\r\n function GetPropName(Instance: TPersistent; Index: Integer): string;\r\n function GetPropCount(Instance: TPersistent): Integer;\r\n protected\r\n procedure SetPropertyValue(const APersistent: TPersistent; const APropertyName: string; const AValue: Variant);\r\n function GetPropertyValue(const APersistent: TPersistent; const APropertyName: string): Variant;\r\n procedure AfterCreateControl(AControl: TControl); virtual;\r\n procedure NeedRegisterControls;\r\n procedure RegisterControls; virtual;\r\n public\r\n constructor Create; virtual;\r\n destructor Destroy; override;\r\n\r\n function GetRegisteredControlClass(AControlType: TJvDynControlType): TControlClass;\r\n\r\n function CreateControl(AControlType: TJvDynControlType; AOwner: TComponent;\r\n AParentControl: TWinControl; AControlName: string): TControl; virtual;\r\n function CreateControlClass(AControlClass: TControlClass; AOwner: TComponent;\r\n AParentControl: TWinControl; AControlName: string): TControl; virtual;\r\n function GetControlTextWidth(aControl: TControl; aFont: TFont; const aText:\r\n string): Integer;\r\n\r\n function IsControlTypeRegistered(const ADynControlType: TJvDynControlType): Boolean;\r\n\r\n function IsControlTypeValid(const ADynControlType: TJvDynControlType;\r\n AControlClass: TControlClass): Boolean; virtual;\r\n procedure RegisterControlType(const ADynControlType: TJvDynControlType;\r\n AControlClass: TControlClass); virtual;\r\n\r\n procedure SetControlCaption(AControl: IJvDynControl; const Value: string);\r\n procedure SetControlTabOrder(AControl: IJvDynControl; Value: Integer);\r\n\r\n procedure SetControlOnEnter(AControl: IJvDynControl; Value: TNotifyEvent);\r\n procedure SetControlOnExit(AControl: IJvDynControl; Value: TNotifyEvent);\r\n procedure SetControlOnClick(AControl: IJvDynControl; Value: TNotifyEvent);\r\n published\r\n property OnAfterCreateControl: TJvAfterCreateControl read FAfterCreateControl write FAfterCreateControl;\r\n end;\r\n\r\n TJvDynControlEngine = class(TJvCustomDynControlEngine)\r\n private\r\n FDistanceBetweenLabelAndControlHorz: Integer;\r\n FDistanceBetweenLabelAndControlVert: Integer;\r\n protected\r\n public\r\n constructor Create; override;\r\n function CreateLabelControl(AOwner: TComponent; AParentControl: TWinControl;\r\n const AControlName, ACaption: string; AFocusControl: TWinControl = nil):\r\n TControl; virtual;\r\n function CreateStaticTextControl(AOwner: TComponent; AParentControl: TWinControl;\r\n const AControlName, ACaption: string): TWinControl; virtual;\r\n function CreatePanelControl(AOwner: TComponent; AParentControl: TWinControl;\r\n const AControlName, ACaption: string; AAlign: TAlign): TWinControl; virtual;\r\n function CreateScrollBoxControl(AOwner: TComponent; AParentControl: TWinControl;\r\n const AControlName: string): TWinControl; virtual;\r\n function CreateEditControl(AOwner: TComponent; AParentControl: TWinControl;\r\n const AControlName: string): TWinControl; virtual;\r\n function CreateCheckboxControl(AOwner: TComponent; AParentControl: TWinControl;\r\n const AControlName, ACaption: string): TWinControl; virtual;\r\n function CreateComboBoxControl(AOwner: TComponent; AParentControl: TWinControl;\r\n const AControlName: string; AItems: TStrings): TWinControl; virtual;\r\n function CreateGroupBoxControl(AOwner: TComponent; AParentControl: TWinControl;\r\n const AControlName, ACaption: string): TWinControl; virtual;\r\n function CreateImageControl(AOwner: TComponent; AParentControl: TWinControl;\r\n const AControlName: string): TWinControl; virtual;\r\n function CreateRadioGroupControl(AOwner: TComponent; AParentControl: TWinControl;\r\n const AControlName, ACaption: string; AItems: TStrings;\r\n AItemIndex: Integer = 0): TWinControl; virtual;\r\n function CreateMemoControl(AOwner: TComponent; AParentControl: TWinControl;\r\n const AControlName: string): TWinControl; virtual;\r\n function CreateRichEditControl(AOwner: TComponent; AParentControl: TWinControl;\r\n const AControlName: string): TWinControl; virtual;\r\n function CreateListBoxControl(AOwner: TComponent; AParentControl: TWinControl;\r\n const AControlName: string; AItems: TStrings): TWinControl; virtual;\r\n function CreateCheckListBoxControl(AOwner: TComponent; AParentControl: TWinControl; const AControlName: string; AItems:\r\n TStrings): TWinControl; virtual;\r\n function CreateDateTimeControl(AOwner: TComponent; AParentControl: TWinControl;\r\n const AControlName: string): TWinControl; virtual;\r\n function CreateDateControl(AOwner: TComponent; AParentControl: TWinControl;\r\n const AControlName: string): TWinControl; virtual;\r\n function CreateTimeControl(AOwner: TComponent; AParentControl: TWinControl;\r\n const AControlName: string): TWinControl; virtual;\r\n function CreateCalculateControl(AOwner: TComponent; AParentControl: TWinControl;\r\n const AControlName: string): TWinControl; virtual;\r\n function CreateSpinControl(AOwner: TComponent; AParentControl: TWinControl;\r\n const AControlName: string): TWinControl; virtual;\r\n function CreateDirectoryControl(AOwner: TComponent; AParentControl: TWinControl;\r\n const AControlName: string): TWinControl; virtual;\r\n function CreateFileNameControl(AOwner: TComponent; AParentControl: TWinControl;\r\n const AControlName: string): TWinControl; virtual;\r\n function CreateTreeViewControl(AOwner: TComponent; AParentControl: TWinControl;\r\n const AControlName: string): TWinControl; virtual;\r\n function CreatePageControlControl(AOwner: TComponent; AParentControl: TWinControl;\r\n const AControlName: string; APages : TStrings): TWinControl; virtual;\r\n function CreateTabControlControl(AOwner: TComponent; AParentControl: TWinControl;\r\n const AControlName: string; ATabs : TStrings): TWinControl; virtual;\r\n function CreateButton(AOwner: TComponent; AParentControl: TWinControl;\r\n const AButtonName, ACaption, AHint: string;\r\n AOnClick: TNotifyEvent; ADefault: Boolean = False;\r\n ACancel: Boolean = False): TButton; virtual;\r\n function CreateRadioButton(AOwner: TComponent; AParentControl: TWinControl;\r\n const ARadioButtonName, ACaption: string): TWinControl; virtual;\r\n function CreateButtonEditControl(AOwner: TComponent; AParentControl: TWinControl;\r\n const AControlName: string; AOnButtonClick: TNotifyEvent): TWinControl; virtual;\r\n function CreateCheckComboBoxControl(AOwner: TComponent; AParentControl: TWinControl; const AControlName: string;\r\n AItems: TStrings; ADelimiter: string): TWinControl; virtual;\r\n function CreateColorComboboxControl(AOwner: TComponent; AParentControl:\r\n TWinControl; const AControlName: string; ADefaultColor: TColor):\r\n TWinControl; virtual;\r\n function CreateForm(const ACaption, AHint: string): TCustomForm; virtual;\r\n\r\n function CreateLabelControlPanel(AOwner: TComponent; AParentControl: TWinControl;\r\n const AControlName, ACaption: string; AFocusControl: TWinControl;\r\n ALabelOnTop: Boolean = True; ALabelDefaultWidth: Integer = 0): TWinControl; virtual;\r\n function CreateProgressbarControl(AOwner: TComponent; AParentControl:\r\n TWinControl; const AControlName: string; AMin: Integer = 0; AMax: Integer =\r\n 100; AStep: Integer = 1): TWinControl; virtual;\r\n function CreateRTTIInspectorControl(AOwner: TComponent; AParentControl:\r\n TWinControl; const AControlName: string; AOnDisplayProperty:\r\n TJvDynControlInspectorControlOnDisplayPropertyEvent;\r\n AOnTranslatePropertyName:\r\n TJvDynControlInspectorControlOnTranslatePropertyNameEvent): TWinControl;\r\n virtual;\r\n published\r\n property DistanceBetweenLabelAndControlHorz: Integer read FDistanceBetweenLabelAndControlHorz write FDistanceBetweenLabelAndControlHorz default 4;\r\n property DistanceBetweenLabelAndControlVert: Integer read FDistanceBetweenLabelAndControlVert write FDistanceBetweenLabelAndControlVert default 1;\r\n end;\r\n\r\nfunction IntfCast(Instance: TObject; const Intf: TGUID): IUnknown; overload;\r\nprocedure IntfCast(Instance: TObject; const IID: TGUID; out Intf); overload;\r\n\r\nprocedure SetDefaultDynControlEngine(AEngine: TJvDynControlEngine);\r\nfunction DefaultDynControlEngine: TJvDynControlEngine;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvDynControlEngine.pas $';\r\n Revision: '$Revision: 13339 $';\r\n Date: '$Date: 2012-06-13 10:26:12 +0200 (mer. 13 juin 2012) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n TypInfo,\r\n JvResources, JvTypes, JvComponent,\r\n JvJVCLUtils;\r\n\r\nvar\r\n GlobalDefaultDynControlEngine: TJvDynControlEngine = nil;\r\n\r\nfunction IntfCast(Instance: TObject; const Intf: TGUID): IUnknown;\r\nbegin\r\n if not Supports(Instance, Intf, Result) then\r\n raise EIntfCastError.CreateRes(@RsEIntfCastError);\r\nend;\r\n\r\nprocedure IntfCast(Instance: TObject; const IID: TGUID; out Intf);\r\nbegin\r\n if not Supports(Instance, IID, Intf) then\r\n raise EIntfCastError.CreateRes(@RsEIntfCastError);\r\nend;\r\n\r\n//=== { TJvCustomDynControlEngine } ==========================================\r\n\r\nconstructor TJvCustomDynControlEngine.Create;\r\nbegin\r\n inherited Create;\r\n FRegisteredControlTypes := TStringList.Create;\r\nend;\r\n\r\ndestructor TJvCustomDynControlEngine.Destroy;\r\nvar\r\n Ind: Integer;\r\nbegin\r\n for Ind := 0 to FRegisteredControlTypes.Count - 1 do\r\n if Assigned(FRegisteredControlTypes.Objects[Ind]) then\r\n FRegisteredControlTypes.Objects[Ind].Free;\r\n FRegisteredControlTypes.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJvCustomDynControlEngine.IsControlTypeRegistered(const ADynControlType: TJvDynControlType): Boolean;\r\nvar\r\n Ind: Integer;\r\nbegin\r\n NeedRegisterControls;\r\n Ind := FRegisteredControlTypes.IndexOf(ADynControlType);\r\n if Ind >= 0 then\r\n Result := Assigned(FRegisteredControlTypes.Objects[Ind])\r\n else\r\n Result := False;\r\nend;\r\n\r\nfunction TJvCustomDynControlEngine.IsControlTypeValid(const ADynControlType: TJvDynControlType;\r\n AControlClass: TControlClass): Boolean;\r\nvar\r\n Valid: Boolean;\r\nbegin\r\n Valid := Supports(AControlClass, IJvDynControl);\r\n if ADynControlType = jctButton then\r\n Valid := Valid and Supports(AControlClass, IJvDynControlButton)\r\n else\r\n if ADynControlType = jctButtonEdit then\r\n Valid := Valid and Supports(AControlClass, IJvDynControlButton) and\r\n Supports(AControlClass, IJvDynControlData)\r\n else\r\n if ADynControlType = jctPanel then\r\n Valid := Valid and Supports(AControlClass, IJvDynControlPanel)\r\n else\r\n if ADynControlType = jctLabel then\r\n Valid := Valid and Supports(AControlClass, IJvDynControlLabel)\r\n else\r\n if ADynControlType = jctMemo then\r\n Valid := Valid and\r\n Supports(AControlClass, IJvDynControlItems) and\r\n Supports(AControlClass, IJvDynControlData) and\r\n Supports(AControlClass, IJvDynControlMemo)\r\n else\r\n if (ADynControlType = jctRadioGroup) or\r\n (ADynControlType = jctComboBox) then\r\n Valid := Valid and\r\n Supports(AControlClass, IJvDynControlItems) and\r\n Supports(AControlClass, IJvDynControlData)\r\n else\r\n if (ADynControlType = jctEdit) or\r\n (ADynControlType = jctCalculateEdit) or\r\n (ADynControlType = jctSpinEdit) or\r\n (ADynControlType = jctFileNameEdit) or\r\n (ADynControlType = jctDirectoryEdit) or\r\n (ADynControlType = jctCheckBox) or\r\n (ADynControlType = jctDateTimeEdit) or\r\n (ADynControlType = jctDateEdit) or\r\n (ADynControlType = jctTimeEdit) then\r\n Valid := Valid and Supports(AControlClass, IJvDynControlData);\r\n Result := Valid;\r\nend;\r\n\r\nprocedure TJvCustomDynControlEngine.RegisterControlType(const ADynControlType: TJvDynControlType;\r\n AControlClass: TControlClass);\r\nvar\r\n Ind: Integer;\r\n ControlClassObject: TJvControlClassObject;\r\nbegin\r\n NeedRegisterControls;\r\n Ind := FRegisteredControlTypes.IndexOf(ADynControlType);\r\n if Ind >= 0 then\r\n begin\r\n ControlClassObject := TJvControlClassObject(FRegisteredControlTypes.Objects[Ind]);\r\n if Assigned(ControlClassObject) then\r\n ControlClassObject.Free;\r\n FRegisteredControlTypes.Delete(Ind);\r\n end;\r\n if IsControlTypeValid(ADynControlType, AControlClass) then\r\n begin\r\n ControlClassObject := TJvControlClassObject.Create;\r\n ControlClassObject.ControlClass := AControlClass;\r\n FRegisteredControlTypes.AddObject(ADynControlType, ControlClassObject);\r\n end\r\n else\r\n raise EJVCLException.CreateResFmt(@RsEUnsupportedControlClass, [ADynControlType]);\r\nend;\r\n\r\nfunction TJvCustomDynControlEngine.GetPropCount(Instance: TPersistent): Integer;\r\nvar\r\n Data: PTypeData;\r\nbegin\r\n Data := GetTypeData(Instance.ClassInfo);\r\n Result := Data.PropCount;\r\nend;\r\n\r\nfunction TJvCustomDynControlEngine.GetPropName(Instance: TPersistent; Index: Integer): string;\r\nvar\r\n PropList: PPropList;\r\n PropInfo: PPropInfo;\r\n Data: PTypeData;\r\nbegin\r\n Result := '';\r\n Data := GetTypeData(Instance.ClassInfo);\r\n GetMem(PropList, Data^.PropCount * SizeOf(PPropInfo));\r\n try\r\n GetPropInfos(Instance.ClassInfo, PropList);\r\n PropInfo := PropList^[Index];\r\n Result := {$IFDEF SUPPORTS_UNICODE}UTF8ToString{$ENDIF SUPPORTS_UNICODE}(PropInfo^.Name);\r\n finally\r\n FreeMem(PropList, Data^.PropCount * SizeOf(PPropInfo));\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomDynControlEngine.SetPropertyValue(const APersistent: TPersistent;\r\n const APropertyName: string; const AValue: Variant);\r\nvar\r\n Index: Integer;\r\n PropName: string;\r\n SubObj: TObject;\r\n P: Integer;\r\n SearchName: string;\r\n LastName: string;\r\nbegin\r\n SearchName := Trim(APropertyName);\r\n P := Pos('.', SearchName);\r\n if P > 0 then\r\n begin\r\n LastName := Trim(Copy(SearchName, P + 1, Length(SearchName) - P));\r\n SearchName := Trim(Copy(SearchName, 1, P - 1));\r\n end\r\n else\r\n LastName := '';\r\n for Index := 0 to GetPropCount(APersistent) - 1 do\r\n begin\r\n PropName := GetPropName(APersistent, Index);\r\n if CompareText(SearchName, PropName) = 0 then\r\n begin\r\n case PropType(APersistent, PropName) of\r\n {$IFDEF UNICODE} tkUString, {$ENDIF}\r\n tkLString, tkWString, tkString:\r\n SetStrProp(APersistent, PropName, VarToStr(AValue));\r\n tkEnumeration, tkSet, tkChar, tkInteger:\r\n SetOrdProp(APersistent, PropName, AValue);\r\n// tkInt64:\r\n// SetInt64Prop(APersistent, PropName, AValue);\r\n tkFloat:\r\n SetFloatProp(APersistent, PropName, AValue);\r\n tkClass:\r\n begin\r\n SubObj := GetObjectProp(APersistent, PropName);\r\n if SubObj is TStrings then\r\n TStrings(SubObj).Text := AValue\r\n else\r\n if (SubObj is TPersistent) and (LastName <> '') then\r\n SetPropertyValue(TPersistent(SubObj), LastName, AValue);\r\n end;\r\n end;\r\n Break; // property was found and there can't be a second property with the same name\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJvCustomDynControlEngine.GetPropertyValue(const APersistent: TPersistent;\r\n const APropertyName: string): Variant;\r\nvar\r\n Index: Integer;\r\n PropName: string;\r\n SubObj: TObject;\r\n P: Integer;\r\n SearchName: string;\r\n LastName: string;\r\nbegin\r\n Result := Null;\r\n SearchName := Trim(APropertyName);\r\n P := Pos('.', SearchName);\r\n if P > 0 then\r\n begin\r\n LastName := Trim(Copy(SearchName, P + 1, Length(SearchName) - P));\r\n SearchName := Trim(Copy(SearchName, 1, P - 1));\r\n end\r\n else\r\n LastName := '';\r\n for Index := 0 to GetPropCount(APersistent) - 1 do\r\n begin\r\n PropName := GetPropName(APersistent, Index);\r\n if CompareText(SearchName, PropName) = 0 then\r\n begin\r\n case PropType(APersistent, PropName) of\r\n {$IFDEF UNICODE} tkUString, {$ENDIF}\r\n tkLString, tkWString, tkString:\r\n Result := GetStrProp(APersistent, PropName);\r\n tkEnumeration, tkSet, tkChar, tkInteger:\r\n Result := GetOrdProp(APersistent, PropName);\r\n tkInt64:\r\n Result := GetInt64Prop(APersistent, PropName);\r\n tkFloat:\r\n Result := GetFloatProp(APersistent, PropName);\r\n tkClass:\r\n begin\r\n SubObj := GetObjectProp(APersistent, PropName);\r\n if SubObj is TStrings then\r\n Result := TStrings(SubObj).Text\r\n else\r\n if (SubObj is TPersistent) and (LastName <> '') then\r\n Result := GetPropertyValue(TPersistent(SubObj), LastName);\r\n end;\r\n end;\r\n Break; // property was found and there can't be a second property with the same name\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomDynControlEngine.AfterCreateControl(AControl: TControl);\r\nbegin\r\n if Assigned(FAfterCreateControl) then\r\n FAfterCreateControl(AControl);\r\nend;\r\n\r\nfunction TJvCustomDynControlEngine.GetRegisteredControlClass(AControlType: TJvDynControlType): TControlClass;\r\nvar\r\n Ind: Integer;\r\nbegin\r\n NeedRegisterControls;\r\n Result := nil;\r\n Ind := FRegisteredControlTypes.IndexOf(AControlType);\r\n if Ind >= 0 then\r\n if Assigned(FRegisteredControlTypes.Objects[Ind]) and\r\n (FRegisteredControlTypes.Objects[Ind] is TJvControlClassObject) then\r\n Result := TJvControlClassObject(FRegisteredControlTypes.Objects[Ind]).ControlClass;\r\nend;\r\n\r\nfunction TJvCustomDynControlEngine.CreateControl(AControlType: TJvDynControlType;\r\n AOwner: TComponent; AParentControl: TWinControl; AControlName: string): TControl;\r\nbegin\r\n NeedRegisterControls;\r\n if Assigned(GetRegisteredControlClass(AControlType)) then\r\n Result := CreateControlClass(GetRegisteredControlClass(AControlType), AOwner,\r\n AParentControl, AControlName)\r\n else\r\n if AControlType = jctForm then\r\n begin\r\n Result := TControl(TJvForm.CreateNew(AOwner));\r\n if AControlName <> '' then\r\n Result.Name := AControlName;\r\n end\r\n else\r\n Result := nil;\r\n if Result = nil then\r\n raise EJVCLException.CreateResFmt(@RsENoRegisteredControlClass, [AControlType]);\r\n AfterCreateControl(Result);\r\nend;\r\n\r\nfunction TJvCustomDynControlEngine.CreateControlClass(AControlClass: TControlClass;\r\n AOwner: TComponent; AParentControl: TWinControl; AControlName: string): TControl;\r\nvar\r\n DynCtrl: IJvDynControl;\r\nbegin\r\n Result := TControl(AControlClass.Create(AOwner));\r\n IntfCast(Result, IJvDynControl, DynCtrl);\r\n DynCtrl.ControlSetDefaultProperties;\r\n if Assigned(AParentControl) then\r\n Result.Parent := AParentControl;\r\n if AControlName <> '' then\r\n Result.Name := GenerateUniqueComponentName(AOwner, Result, AControlName);\r\nend;\r\n\r\nfunction TJvCustomDynControlEngine.GetControlTextWidth(aControl: TControl;\r\n aFont: TFont; const aText: string): Integer;\r\nvar\r\n Canvas: TControlCanvas;\r\nbegin\r\n Canvas := TControlCanvas.Create;\r\n try\r\n Canvas.Control := aControl;\r\n Canvas.Font.Assign(aFont);\r\n Result := Canvas.TextWidth(aText);\r\n finally\r\n Canvas.free;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomDynControlEngine.SetControlCaption(AControl: IJvDynControl; const Value: string);\r\nbegin\r\nend;\r\n\r\nprocedure TJvCustomDynControlEngine.SetControlTabOrder(AControl: IJvDynControl; Value: Integer);\r\nbegin\r\nend;\r\n\r\nprocedure TJvCustomDynControlEngine.SetControlOnEnter(AControl: IJvDynControl; Value: TNotifyEvent);\r\nbegin\r\nend;\r\n\r\nprocedure TJvCustomDynControlEngine.SetControlOnExit(AControl: IJvDynControl; Value: TNotifyEvent);\r\nbegin\r\nend;\r\n\r\nprocedure TJvCustomDynControlEngine.SetControlOnClick(AControl: IJvDynControl; Value: TNotifyEvent);\r\nbegin\r\nend;\r\n\r\nprocedure TJvCustomDynControlEngine.NeedRegisterControls;\r\nbegin\r\n if not FRegisterControlsExecuted then\r\n begin\r\n FRegisterControlsExecuted := True;\r\n RegisterControls;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomDynControlEngine.RegisterControls;\r\nbegin\r\n // no registration\r\nend;\r\n\r\n//=== { TJvDynControlEngine } ================================================\r\n\r\nconstructor TJvDynControlEngine.Create;\r\nbegin\r\n inherited Create;\r\n FDistanceBetweenLabelAndControlHorz := 4;\r\n FDistanceBetweenLabelAndControlVert := 1;\r\nend;\r\n\r\nfunction TJvDynControlEngine.CreateLabelControl(AOwner: TComponent;\r\n AParentControl: TWinControl; const AControlName, ACaption: string;\r\n AFocusControl: TWinControl = nil): TControl;\r\nvar\r\n DynCtrlCaption: IJvDynControlCaption;\r\n DynCtrlLabel: IJvDynControlLabel;\r\nbegin\r\n Result := CreateControl(jctLabel, AOwner, AParentControl, AControlName);\r\n IntfCast(Result, IJvDynControlCaption, DynCtrlCaption);\r\n DynCtrlCaption.ControlSetCaption(ACaption);\r\n IntfCast(Result, IJvDynControlLabel, DynCtrlLabel);\r\n if Assigned(AFocusControl) then\r\n DynCtrlLabel.ControlSetFocusControl(AFocusControl);\r\nend;\r\n\r\nfunction TJvDynControlEngine.CreateStaticTextControl(AOwner: TComponent;\r\n AParentControl: TWinControl; const AControlName, ACaption: string): TWinControl;\r\nvar\r\n DynCtrlCaption: IJvDynControlCaption;\r\nbegin\r\n Result := TWinControl(CreateControl(jctStaticText, AOwner, AParentControl, AControlName));\r\n IntfCast(Result, IJvDynControlCaption, DynCtrlCaption);\r\n DynCtrlCaption.ControlSetCaption(ACaption);\r\nend;\r\n\r\nfunction TJvDynControlEngine.CreatePanelControl(AOwner: TComponent;\r\n AParentControl: TWinControl; const AControlName, ACaption: string;\r\n AAlign: TAlign): TWinControl;\r\nvar\r\n DynCtrlCaption: IJvDynControlCaption;\r\nbegin\r\n Result := TWinControl(CreateControl(jctPanel, AOwner, AParentControl, AControlName));\r\n IntfCast(Result, IJvDynControlCaption, DynCtrlCaption);\r\n DynCtrlCaption.ControlSetCaption(ACaption);\r\n Result.Align := AAlign;\r\nend;\r\n\r\nfunction TJvDynControlEngine.CreateScrollBoxControl(AOwner: TComponent;\r\n AParentControl: TWinControl; const AControlName: string): TWinControl;\r\nbegin\r\n Result := TWinControl(CreateControl(jctScrollBox, AOwner, AParentControl, AControlName));\r\nend;\r\n\r\nfunction TJvDynControlEngine.CreateEditControl(AOwner: TComponent;\r\n AParentControl: TWinControl; const AControlName: string): TWinControl;\r\nvar\r\n DynCtrlEdit: IJvDynControlEdit;\r\nbegin\r\n Result := TWinControl(CreateControl(jctEdit, AOwner, AParentControl, AControlName));\r\n IntfCast(Result, IJvDynControlEdit, DynCtrlEdit);\r\nend;\r\n\r\nfunction TJvDynControlEngine.CreateCheckboxControl(AOwner: TComponent;\r\n AParentControl: TWinControl; const AControlName, ACaption: string): TWinControl;\r\nvar\r\n DynCtrlCaption: IJvDynControlCaption;\r\n DynCtrlFont: IJvDynControlFont;\r\nbegin\r\n Result := TWinControl(CreateControl(jctCheckBox, AOwner, AParentControl, AControlName));\r\n IntfCast(Result, IJvDynControlCaption, DynCtrlCaption);\r\n DynCtrlCaption.ControlSetCaption(ACaption);\r\n if Supports(Result, IJvDynControlFont,DynCtrlFont) then\r\n Result.Width := GetControlTextWidth(Result, DynCtrlFont.ControlFont, ACaption+'XXXXXX');\r\nend;\r\n\r\nfunction TJvDynControlEngine.CreateComboBoxControl(AOwner: TComponent;\r\n AParentControl: TWinControl; const AControlName: string; AItems: TStrings): TWinControl;\r\nvar\r\n DynCtrlItems: IJvDynControlItems;\r\nbegin\r\n Result := TWinControl(CreateControl(jctComboBox, AOwner, AParentControl, AControlName));\r\n if Assigned(AItems) then\r\n begin\r\n IntfCast(Result, IJvDynControlItems, DynCtrlItems);\r\n DynCtrlItems.ControlSetItems(AItems);\r\n end;\r\nend;\r\n\r\nfunction TJvDynControlEngine.CreateGroupBoxControl(AOwner: TComponent;\r\n AParentControl: TWinControl; const AControlName, ACaption: string): TWinControl;\r\nvar\r\n DynCtrlCaption: IJvDynControlCaption;\r\nbegin\r\n Result := TWinControl(CreateControl(jctGroupBox, AOwner, AParentControl, AControlName));\r\n IntfCast(Result, IJvDynControlCaption, DynCtrlCaption);\r\n DynCtrlCaption.ControlSetCaption(ACaption);\r\nend;\r\n\r\nfunction TJvDynControlEngine.CreateImageControl(AOwner: TComponent;\r\n AParentControl: TWinControl; const AControlName: string): TWinControl;\r\nbegin\r\n Result := TWinControl(CreateControl(jctImage, AOwner, AParentControl, AControlName));\r\nend;\r\n\r\nfunction TJvDynControlEngine.CreateRadioGroupControl(AOwner: TComponent;\r\n AParentControl: TWinControl; const AControlName, ACaption: string;\r\n AItems: TStrings; AItemIndex: Integer = 0): TWinControl;\r\nvar\r\n DynCtrlCaption: IJvDynControlCaption;\r\n DynCtrlItems: IJvDynControlItems;\r\n DynCtrlData: IJvDynControlData;\r\nbegin\r\n Result := TWinControl(CreateControl(jctRadioGroup, AOwner, AParentControl, AControlName));\r\n IntfCast(Result, IJvDynControlCaption, DynCtrlCaption);\r\n DynCtrlCaption.ControlSetCaption(ACaption);\r\n IntfCast(Result, IJvDynControlItems, DynCtrlItems);\r\n DynCtrlItems.ControlSetItems(AItems);\r\n IntfCast(Result, IJvDynControlData, DynCtrlData);\r\n DynCtrlData.ControlValue := AItemIndex;\r\nend;\r\n\r\nfunction TJvDynControlEngine.CreateMemoControl(AOwner: TComponent;\r\n AParentControl: TWinControl; const AControlName: string): TWinControl;\r\nvar\r\n DynCtrlData: IJvDynControlData;\r\nbegin\r\n Result := TWinControl(CreateControl(jctMemo, AOwner, AParentControl, AControlName));\r\n IntfCast(Result, IJvDynControlData, DynCtrlData);\r\n DynCtrlData.ControlValue := '';\r\nend;\r\n\r\nfunction TJvDynControlEngine.CreateRichEditControl(AOwner: TComponent;\r\n AParentControl: TWinControl; const AControlName: string): TWinControl;\r\nbegin\r\n Result := TWinControl(CreateControl(jctRichEdit, AOwner, AParentControl, AControlName));\r\nend;\r\n\r\nfunction TJvDynControlEngine.CreateListBoxControl(AOwner: TComponent;\r\n AParentControl: TWinControl; const AControlName: string; AItems: TStrings): TWinControl;\r\nvar\r\n DynCtrlItems: IJvDynControlItems;\r\nbegin\r\n Result := TWinControl(CreateControl(jctListBox, AOwner, AParentControl, AControlName));\r\n if Assigned(AItems) then\r\n begin\r\n IntfCast(Result, IJvDynControlItems, DynCtrlItems);\r\n DynCtrlItems.ControlSetItems(AItems);\r\n end;\r\nend;\r\n\r\nfunction TJvDynControlEngine.CreateCheckListBoxControl(AOwner: TComponent; AParentControl: TWinControl; const\r\n AControlName: string; AItems: TStrings): TWinControl;\r\nvar\r\n DynCtrlItems: IJvDynControlItems;\r\nbegin\r\n Result := TWinControl(CreateControl(jctCheckListBox, AOwner, AParentControl, AControlName));\r\n if Assigned(AItems) then\r\n begin\r\n IntfCast(Result, IJvDynControlItems, DynCtrlItems);\r\n DynCtrlItems.ControlSetItems(AItems);\r\n end;\r\nend;\r\n\r\nfunction TJvDynControlEngine.CreateDateTimeControl(AOwner: TComponent;\r\n AParentControl: TWinControl; const AControlName: string): TWinControl;\r\nbegin\r\n Result := TWinControl(CreateControl(jctDateTimeEdit, AOwner, AParentControl, AControlName));\r\nend;\r\n\r\nfunction TJvDynControlEngine.CreateDateControl(AOwner: TComponent;\r\n AParentControl: TWinControl; const AControlName: string): TWinControl;\r\nbegin\r\n Result := TWinControl(CreateControl(jctDateEdit, AOwner, AParentControl, AControlName));\r\nend;\r\n\r\nfunction TJvDynControlEngine.CreateTimeControl(AOwner: TComponent;\r\n AParentControl: TWinControl; const AControlName: string): TWinControl;\r\nbegin\r\n Result := TWinControl(CreateControl(jctTimeEdit, AOwner, AParentControl, AControlName));\r\nend;\r\n\r\nfunction TJvDynControlEngine.CreateCalculateControl(AOwner: TComponent;\r\n AParentControl: TWinControl; const AControlName: string): TWinControl;\r\nbegin\r\n Result := TWinControl(CreateControl(jctCalculateEdit, AOwner, AParentControl, AControlName));\r\nend;\r\n\r\nfunction TJvDynControlEngine.CreateSpinControl(AOwner: TComponent;\r\n AParentControl: TWinControl; const AControlName: string): TWinControl;\r\nbegin\r\n Result := TWinControl(CreateControl(jctSpinEdit, AOwner, AParentControl, AControlName));\r\nend;\r\n\r\nfunction TJvDynControlEngine.CreateDirectoryControl(AOwner: TComponent;\r\n AParentControl: TWinControl; const AControlName: string): TWinControl;\r\nbegin\r\n Result := TWinControl(CreateControl(jctDirectoryEdit, AOwner, AParentControl, AControlName));\r\nend;\r\n\r\nfunction TJvDynControlEngine.CreateFileNameControl(AOwner: TComponent;\r\n AParentControl: TWinControl; const AControlName: string): TWinControl;\r\nbegin\r\n Result := TWinControl(CreateControl(jctFileNameEdit, AOwner, AParentControl, AControlName));\r\nend;\r\n\r\nfunction TJvDynControlEngine.CreateTreeViewControl(AOwner: TComponent; AParentControl: TWinControl;\r\n const AControlName: string): TWinControl;\r\nbegin\r\n Result := TWinControl(CreateControl(jctTreeView, AOwner, AParentControl, AControlName));\r\nend;\r\n\r\nfunction TJvDynControlEngine.CreatePageControlControl(AOwner: TComponent; AParentControl: TWinControl;\r\n const AControlName: string;APages : TStrings): TWinControl;\r\nvar\r\n DynTabControl: IJvDynControlTabControl;\r\n i: Integer;\r\nbegin\r\n Result := TWinControl(CreateControl(jctPageControl, AOwner, AParentControl, AControlName));\r\n if Assigned(APages) and (APages.Count > 0) then\r\n begin\r\n IntfCast(Result, IJvDynControlTabControl, DynTabControl);\r\n for i := 0 to APages.Count - 1 do\r\n DynTabControl.ControlCreateTab(APages[i]);\r\n end;\r\nend;\r\n\r\nfunction TJvDynControlEngine.CreateTabControlControl(AOwner: TComponent; AParentControl: TWinControl;\r\n const AControlName: string;ATabs : TStrings): TWinControl;\r\nvar\r\n DynTabControl: IJvDynControlTabControl;\r\n i: Integer;\r\nbegin\r\n Result := TWinControl(CreateControl(jctTabControl, AOwner, AParentControl, AControlName));\r\n if Assigned(ATabs) and (ATabs.Count > 0) then\r\n begin\r\n IntfCast(Result, IJvDynControlTabControl, DynTabControl);\r\n for i := 0 to ATabs.Count - 1 do\r\n DynTabControl.ControlCreateTab(ATabs[i]);\r\n end;\r\nend;\r\n\r\n\r\nfunction TJvDynControlEngine.CreateButton(AOwner: TComponent;\r\n AParentControl: TWinControl; const AButtonName, ACaption, AHint: string;\r\n AOnClick: TNotifyEvent; ADefault: Boolean = False; ACancel: Boolean = False): TButton;\r\nbegin\r\n Result := TButton(CreateControl(jctButton, AOwner, AParentControl, AButtonName));\r\n Result.Hint := AHint;\r\n Result.Caption := ACaption;\r\n Result.Default := ADefault;\r\n Result.Cancel := ACancel;\r\n Result.OnClick := AOnClick;\r\n Result.Width := GetControlTextWidth(Result, Result.Font, ACaption+'XXXX');\r\nend;\r\n\r\nfunction TJvDynControlEngine.CreateRadioButton(AOwner: TComponent; AParentControl: TWinControl;\r\n const ARadioButtonName, ACaption: string): TWinControl;\r\nvar\r\n DynCtrlCaption: IJvDynControlCaption;\r\nbegin\r\n Result := TWinControl(CreateControl(jctRadioButton, AOwner, AParentControl, ARadioButtonName));\r\n IntfCast(Result, IJvDynControlCaption, DynCtrlCaption);\r\n DynCtrlCaption.ControlSetCaption(ACaption);\r\nend;\r\n\r\nfunction TJvDynControlEngine.CreateButtonEditControl(AOwner: TComponent; AParentControl: TWinControl;\r\n const AControlName: string; AOnButtonClick: TNotifyEvent): TWinControl;\r\nvar\r\n DynCtrlButtonEdit: IJvDynControlButtonEdit;\r\nbegin\r\n Result := TWinControl(CreateControl(jctButtonEdit, AOwner, AParentControl, AControlName));\r\n IntfCast(Result, IJvDynControlButtonEdit, DynCtrlButtonEdit);\r\n DynCtrlButtonEdit.ControlSetOnButtonClick(AOnButtonClick);\r\nend;\r\n\r\nfunction TJvDynControlEngine.CreateCheckComboBoxControl(AOwner: TComponent; AParentControl: TWinControl; const\r\n AControlName: string; AItems: TStrings; ADelimiter: string): TWinControl;\r\nvar\r\n DynCtrlItems: IJvDynControlItems;\r\n DynControlCheckComboBox: IJvDynControlCheckComboBox;\r\nbegin\r\n Result := TWinControl(CreateControl(jctCheckComboBox, AOwner, AParentControl, AControlName));\r\n if Assigned(AItems) then\r\n begin\r\n IntfCast(Result, IJvDynControlItems, DynCtrlItems);\r\n DynCtrlItems.ControlSetItems(AItems);\r\n IntfCast(Result, IJvDynControlCheckComboBox, DynControlCheckComboBox);\r\n DynControlCheckComboBox.Delimiter := ADelimiter;\r\n end;\r\nend;\r\n\r\nfunction TJvDynControlEngine.CreateColorComboboxControl(AOwner: TComponent;\r\n AParentControl: TWinControl; const AControlName: string; ADefaultColor:\r\n TColor): TWinControl;\r\nvar\r\n DynControlColorComboBoxControl : IJvDynControlColorComboBoxControl;\r\nbegin\r\n Result := TWinControl(CreateControl(jctColorComboBox, AOwner, AParentControl, AControlName));\r\n IntfCast(Result, IJvDynControlColorComboBoxControl, DynControlColorComboBoxControl);\r\n DynControlColorComboBoxControl.ControlDefaultColor := ADefaultColor;\r\n DynControlColorComboBoxControl.ControlSelectedColor := ADefaultColor;\r\nend;\r\n\r\nfunction TJvDynControlEngine.CreateForm(const ACaption, AHint: string): TCustomForm;\r\nbegin\r\n Result := TCustomForm(CreateControl(jctForm, Application, nil, ''));\r\n Result.Caption := ACaption;\r\n Result.Hint := AHint;\r\nend;\r\n\r\nfunction TJvDynControlEngine.CreateLabelControlPanel(AOwner: TComponent;\r\n AParentControl: TWinControl; const AControlName, ACaption: string; AFocusControl: TWinControl;\r\n ALabelOnTop: Boolean = True; ALabelDefaultWidth: Integer = 0): TWinControl;\r\nvar\r\n Panel: TWinControl;\r\n LabelControl: TControl;\r\nbegin\r\n if not Assigned(AFocusControl) then\r\n raise EJVCLException.CreateRes(@RsENoFocusControl);\r\n Panel := CreatePanelControl(AOwner, AParentControl, '', '', alNone);\r\n LabelControl := CreateLabelControl(AOwner, Panel, '', ACaption, AFocusControl);\r\n AFocusControl.Parent := Panel;\r\n LabelControl.Top := 1;\r\n LabelControl.Left := 1;\r\n if ALabelOnTop then\r\n begin\r\n AFocusControl.Top := LabelControl.Height + DistanceBetweenLabelAndControlVert;\r\n AFocusControl.Left := 1;\r\n if LabelControl.Width > AFocusControl.Width then\r\n Panel.Width := LabelControl.Width\r\n else\r\n Panel.Width := AFocusControl.Width;\r\n Panel.Height := AFocusControl.Top + AFocusControl.Height;\r\n end\r\n else\r\n begin\r\n if ALabelDefaultWidth > 0 then\r\n LabelControl.Width := ALabelDefaultWidth;\r\n AFocusControl.Left := LabelControl.Width + DistanceBetweenLabelAndControlHorz;\r\n AFocusControl.Top := 1;\r\n if LabelControl.Height > AFocusControl.Height then\r\n Panel.Height := LabelControl.Height\r\n else\r\n Panel.Height := AFocusControl.Height;\r\n Panel.Width := AFocusControl.Width + AFocusControl.Left;\r\n end;\r\n Panel.Width := Panel.Width + 1;\r\n Panel.Height := Panel.Height + 1;\r\n Result := Panel;\r\nend;\r\n\r\nfunction TJvDynControlEngine.CreateProgressbarControl(AOwner: TComponent;\r\n AParentControl: TWinControl; const AControlName: string; AMin: Integer = 0;\r\n AMax: Integer = 100; AStep: Integer = 1): TWinControl;\r\nvar\r\n JvDynCtrlProgresBar: IJvDynControlProgressbar;\r\nbegin\r\n Result := TWinControl(CreateControl(jctProgressBar, AOwner, AParentControl, AControlName));\r\n IntfCast(Result, IJvDynControlProgressbar, JvDynCtrlProgresBar);\r\n JvDynCtrlProgresBar.ControlSetMin(AMin);\r\n JvDynCtrlProgresBar.ControlSetMax(AMax);\r\n JvDynCtrlProgresBar.ControlSetStep(AStep);\r\nend;\r\n\r\nfunction TJvDynControlEngine.CreateRTTIInspectorControl(AOwner: TComponent;\r\n AParentControl: TWinControl; const AControlName: string;\r\n AOnDisplayProperty:\r\n TJvDynControlInspectorControlOnDisplayPropertyEvent;\r\n AOnTranslatePropertyName:\r\n TJvDynControlInspectorControlOnTranslatePropertyNameEvent): TWinControl;\r\nvar\r\n RTTIInspectorControl : IJvDynControlRTTIInspectorControl;\r\nbegin\r\n Result := TWinControl(CreateControl(jctRTTIInspector, AOwner, AParentControl, AControlName));\r\n IntfCast(Result, IJvDynControlRTTIInspectorControl, RTTIInspectorControl);\r\n RTTIInspectorControl.ControlOnDisplayProperty := AOnDisplayProperty;\r\n RTTIInspectorControl.ControlOnTranslatePropertyName := AOnTranslatePropertyName;\r\nend;\r\n\r\n\r\nprocedure SetDefaultDynControlEngine(AEngine: TJvDynControlEngine);\r\nbegin\r\n if AEngine is TJvDynControlEngine then\r\n GlobalDefaultDynControlEngine := AEngine;\r\nend;\r\n\r\nfunction DefaultDynControlEngine: TJvDynControlEngine;\r\nbegin\r\n Assert(Assigned(GlobalDefaultDynControlEngine),'JvDynControlEngine: DefaultDynControlEngine not defined');\r\n Result := GlobalDefaultDynControlEngine;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvDynControlEngineDB.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Initial Developer of the Original Code is Jens Fudickar [jens dott fudickar att oratool dott de]\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\nJens Fudickar [jens dott fudickar att oratool dott de]\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvDynControlEngineDB.pas 13194 2012-01-25 10:54:30Z jfudickar $\r\n\r\nunit JvDynControlEngineDB;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Classes, Controls, DB,\r\n JvDynControlEngine, JvDynControlEngineDBIntf;\r\n\r\nconst\r\n jctDBEdit = TJvDynControlType('DBEdit');\r\n jctDBText = TJvDynControlType('DBText');\r\n jctDBListBox = TJvDynControlType('DBListBox');\r\n jctDBCheckBox = TJvDynControlType('DBCheckBox');\r\n jctDBComboBox = TJvDynControlType('DBComboBox');\r\n jctDBImage = TJvDynControlType('DBImage');\r\n jctDBRadioGroup = TJvDynControlType('DBRadioGroup');\r\n jctDBMemo = TJvDynControlType('DBMemo');\r\n jctDBDateTimeEdit = TJvDynControlType('DBDateTimeEdit');\r\n jctDBDateEdit = TJvDynControlType('DBDateEdit');\r\n jctDBTimeEdit = TJvDynControlType('DBTimeEdit');\r\n jctDBCalculateEdit = TJvDynControlType('DBCalculateEdit');\r\n jctDBSpinEdit = TJvDynControlType('DBSpinEdit');\r\n jctDBDirectoryEdit = TJvDynControlType('DBDirectoryEdit');\r\n jctDBFileNameEdit = TJvDynControlType('DBFileNameEdit');\r\n jctDBGrid = TJvDynControlType('DBGrid');\r\n jctDBButtonEdit = TJvDynControlType('DBButtonEdit');\r\n jctDBNavigator = TJvDynControlType('DBNavigator');\r\n\r\ntype\r\n TJvCreateDBFieldsOnControlOptions = class(TPersistent)\r\n private\r\n FShowInvisibleFields: Boolean ;\r\n FLabelOnTop: Boolean ;\r\n FLabelDefaultWidth: Integer ;\r\n FFieldDefaultWidth: Integer ;\r\n FFieldMinWidth: Integer ;\r\n FFieldMaxWidth: Integer ;\r\n FFieldWidthStep: Integer;\r\n FUseFieldSizeForWidth: Boolean;\r\n FUseParentColorForReadOnly: Boolean;\r\n protected\r\n procedure SetFieldWidthStep(Value: Integer);\r\n public\r\n constructor Create;\r\n procedure Assign (Source: TPersistent); override;\r\n published\r\n property ShowInvisibleFields: Boolean read FShowInvisibleFields write FShowInvisibleFields default False;\r\n property LabelOnTop: Boolean read FLabelOnTop write FLabelOnTop default True;\r\n property LabelDefaultWidth: Integer read FLabelDefaultWidth write FLabelDefaultWidth default 0;\r\n property FieldDefaultWidth: Integer read FFieldDefaultWidth write FFieldDefaultWidth default 0;\r\n property FieldMinWidth: Integer read FFieldMinWidth write FFieldMinWidth default 20;\r\n property FieldMaxWidth: Integer read FFieldMaxWidth write FFieldMaxWidth default 300;\r\n property FieldWidthStep: Integer read FFieldWidthStep write SetFieldWidthStep default 50;\r\n property UseFieldSizeForWidth: Boolean read FUseFieldSizeForWidth write FUseFieldSizeForWidth default True;\r\n property UseParentColorForReadOnly: Boolean read FUseParentColorForReadOnly write FUseParentColorForReadOnly default True;\r\n end;\r\n\r\n TJvDynControlEngineDB = class(TJvCustomDynControlEngine)\r\n private\r\n FDynControlEngine: TJvDynControlEngine;\r\n protected\r\n function GetDynControlEngine: TJvDynControlEngine;\r\n procedure SetDynControlEngine(ADynControlEngine: TJvDynControlEngine);\r\n public\r\n function IsControlTypeValid(const ADynControlType: TJvDynControlType;\r\n AControlClass: TControlClass): Boolean; override;\r\n function CreateDBFieldControl(AField: TField; AOwner: TComponent;\r\n AParentControl: TWinControl; AControlName: string; ADataSource: TDataSource): TWinControl; virtual;\r\n function CreateDBControl(AControlType: TJvDynControlType; AOwner: TComponent;\r\n AParentControl: TWinControl; AControlName: string;\r\n ADataSource: TDataSource; const ADataField: string): TControl; virtual;\r\n function CreateDBTextControl(AOwner: TComponent;\r\n AParentControl: TWinControl; const AControlName: string;\r\n ADataSource: TDataSource; const ADataField: string; const ACaption: string): TWinControl;\r\n function CreateDBEditControl(AOwner: TComponent; AParentControl: TWinControl;\r\n const AControlName: string; ADataSource: TDataSource; const ADataField: string): TWinControl; virtual;\r\n function CreateDBCheckboxControl(AOwner: TComponent; AParentControl: TWinControl;\r\n const AControlName: string; ADataSource: TDataSource;\r\n const ADataField, ACaption: string): TWinControl; virtual;\r\n function CreateDBComboBoxControl(AOwner: TComponent; AParentControl: TWinControl;\r\n const AControlName: string; ADataSource: TDataSource; const ADataField: string;\r\n AItems: TStrings): TWinControl; virtual;\r\n function CreateDBImageControl(AOwner: TComponent; AParentControl: TWinControl;\r\n const AControlName: string; ADataSource: TDataSource; const ADataField: string): TWinControl; virtual;\r\n function CreateDBRadioGroupControl(AOwner: TComponent; AParentControl: TWinControl;\r\n const AControlName: string; ADataSource: TDataSource; const ADataField, ACaption: string;\r\n AItems: TStrings): TWinControl; virtual;\r\n function CreateDBMemoControl(AOwner: TComponent; AParentControl: TWinControl;\r\n const AControlName: string; ADataSource: TDataSource; const ADataField: string): TWinControl; virtual;\r\n function CreateDBListBoxControl(AOwner: TComponent; AParentControl: TWinControl;\r\n const AControlName: string; ADataSource: TDataSource; const ADataField: string;\r\n AItems: TStrings): TWinControl; virtual;\r\n function CreateDBDateTimeControl(AOwner: TComponent; AParentControl: TWinControl;\r\n const AControlName: string; ADataSource: TDataSource; const ADataField: string): TWinControl; virtual;\r\n function CreateDBDateControl(AOwner: TComponent; AParentControl: TWinControl;\r\n const AControlName: string; ADataSource: TDataSource; const ADataField: string): TWinControl; virtual;\r\n function CreateDBTimeControl(AOwner: TComponent; AParentControl: TWinControl;\r\n const AControlName: string; ADataSource: TDataSource; const ADataField: string): TWinControl; virtual;\r\n function CreateDBCalculateControl(AOwner: TComponent; AParentControl: TWinControl;\r\n const AControlName: string; ADataSource: TDataSource; const ADataField: string): TWinControl; virtual;\r\n function CreateDBSpinControl(AOwner: TComponent; AParentControl: TWinControl;\r\n const AControlName: string; ADataSource: TDataSource; const ADataField: string): TWinControl; virtual;\r\n function CreateDBDirectoryControl(AOwner: TComponent; AParentControl: TWinControl;\r\n const AControlName: string; ADataSource: TDataSource; const ADataField: string): TWinControl;\r\n function CreateDBFileNameControl(AOwner: TComponent; AParentControl: TWinControl;\r\n const AControlName: string; ADataSource: TDataSource; const ADataField: string): TWinControl;\r\n function CreateDBGridControl(AOwner: TComponent; AParentControl: TWinControl;\r\n const AControlName: string; ADataSource: TDataSource): TWinControl; virtual;\r\n function CreateDBNavigatorControl(AOwner: TComponent; AParentControl: TWinControl;\r\n const AControlName: string; ADataSource: TDataSource): TWinControl; virtual;\r\n function CreateControlsFromDataSourceOnControl(ADataSource: TDataSource;\r\n AControl: TWinControl; AOptions: TJvCreateDBFieldsOnControlOptions): Boolean; virtual;\r\n function CreateControlsFromDataComponentOnControl(ADataComponent: TComponent;\r\n AControl: TWinControl; AOptions: TJvCreateDBFieldsOnControlOptions): Boolean; virtual;\r\n function GetDataSourceFromDataComponent(ADataComponent: TComponent): TDataSource; virtual;\r\n function GetFieldControlType(AField: TField): TJvDynControlType; virtual;\r\n function SupportsDataComponent(ADataComponent: TComponent): Boolean;\r\n property DynControlEngine: TJvDynControlEngine read GetDynControlEngine write SetDynControlEngine;\r\n end;\r\n\r\nprocedure SetDefaultDynControlEngineDB(AEngine: TJvDynControlEngineDB);\r\nfunction DefaultDynControlEngineDB: TJvDynControlEngineDB;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvDynControlEngineDB.pas $';\r\n Revision: '$Revision: 13194 $';\r\n Date: '$Date: 2012-01-25 11:54:30 +0100 (mer. 25 janv. 2012) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n Variants, SysUtils, TypInfo,\r\n JvResources, JvTypes, JvDynControlEngineIntf;\r\n\r\nvar\r\n GlobalDefaultDynControlEngineDB: TJvDynControlEngineDB = nil;\r\n\r\n//=== { TJvCreateDBFieldsOnControlOptions } ==================================\r\n\r\nconstructor TJvCreateDBFieldsOnControlOptions.Create;\r\nbegin\r\n inherited Create;\r\n FShowInvisibleFields := False;\r\n FLabelOnTop := True;\r\n FLabelDefaultWidth := 0;\r\n FFieldDefaultWidth := 0;\r\n FFieldMinWidth := 20;\r\n FFieldMaxWidth := 300;\r\n FFieldWidthStep := 50;\r\n FUseFieldSizeForWidth := True;\r\n FUseParentColorForReadOnly := True;\r\nend;\r\n\r\nprocedure TJvCreateDBFieldsOnControlOptions.Assign(Source: TPersistent);\r\nbegin\r\n if Assigned(Source) and (Source is TJvCreateDBFieldsOnControlOptions) then\r\n begin\r\n ShowInvisibleFields := TJvCreateDBFieldsOnControlOptions(Source).ShowInvisibleFields;\r\n LabelOnTop := TJvCreateDBFieldsOnControlOptions(Source).LabelOnTop;\r\n LabelDefaultWidth := TJvCreateDBFieldsOnControlOptions(Source).LabelDefaultWidth;\r\n FieldDefaultWidth := TJvCreateDBFieldsOnControlOptions(Source).FieldDefaultWidth;\r\n FieldMinWidth := TJvCreateDBFieldsOnControlOptions(Source).FieldMinWidth;\r\n FieldMaxWidth := TJvCreateDBFieldsOnControlOptions(Source).FieldMaxWidth;\r\n FieldWidthStep := TJvCreateDBFieldsOnControlOptions(Source).FieldWidthStep;\r\n UseFieldSizeForWidth := TJvCreateDBFieldsOnControlOptions(Source).UseFieldSizeForWidth;\r\n UseParentColorForReadOnly := TJvCreateDBFieldsOnControlOptions(Source).UseParentColorForReadOnly;\r\n end\r\n else\r\n inherited Assign(Source);\r\nend;\r\n\r\nprocedure TJvCreateDBFieldsOnControlOptions.SetFieldWidthStep(Value: Integer);\r\nbegin\r\n if Value < 1 then\r\n FFieldWidthStep := 1\r\n else\r\n FFieldWidthStep := Value;\r\nend;\r\n\r\n//=== { TJvDynControlEngineDB } ==============================================\r\n\r\nprocedure TJvDynControlEngineDB.SetDynControlEngine(ADynControlEngine: TJvDynControlEngine);\r\nbegin\r\n FDynControlEngine := ADynControlEngine;\r\nend;\r\n\r\nfunction TJvDynControlEngineDB.GetDynControlEngine: TJvDynControlEngine;\r\nbegin\r\n if Assigned(FDynControlEngine) then\r\n Result := FDynControlEngine\r\n else\r\n Result := DefaultDynControlEngine;\r\nend;\r\n\r\nfunction TJvDynControlEngineDB.IsControlTypeValid(const ADynControlType: TJvDynControlType;\r\n AControlClass: TControlClass): Boolean;\r\nvar\r\n Valid: Boolean;\r\nbegin\r\n Valid := inherited IsControlTypeValid(ADynControlType, AControlClass);\r\n// if ADynControlType = jctDBText then\r\n// Valid := Valid and Supports(AControlClass, IJvDynControlLabel)\r\n// else\r\n if ADynControlType = jctDBButtonEdit then\r\n Valid := Valid and\r\n Supports(AControlClass, IJvDynControlButton) and\r\n Supports(AControlClass, IJvDynControlData)\r\n else\r\n if ADynControlType = jctDBMemo then\r\n Valid := Valid and\r\n Supports(AControlClass, IJvDynControlItems) and\r\n Supports(AControlClass, IJvDynControlData) and\r\n Supports(AControlClass, IJvDynControlMemo)\r\n else\r\n if (ADynControlType = jctDBRadioGroup) or\r\n (ADynControlType = jctDBComboBox) then\r\n Valid := Valid and\r\n Supports(AControlClass, IJvDynControlItems) and\r\n Supports(AControlClass, IJvDynControlData)\r\n else\r\n if (ADynControlType = jctDBEdit) or\r\n (ADynControlType = jctDBCalculateEdit) or\r\n (ADynControlType = jctDBSpinEdit) or\r\n (ADynControlType = jctDBCheckBox) or\r\n (ADynControlType = jctDBDateTimeEdit) or\r\n (ADynControlType = jctDBDateEdit) or\r\n (ADynControlType = jctDBTimeEdit) or\r\n (ADynControlType = jctDBDirectoryEdit) or\r\n (ADynControlType = jctDBFileNameEdit) then\r\n Valid := Valid and Supports(AControlClass, IJvDynControlData);\r\n if (ADynControlType = jctDBEdit) or\r\n (ADynControlType = jctDBCalculateEdit) or\r\n (ADynControlType = jctDBSpinEdit) or\r\n (ADynControlType = jctDBCheckBox) or\r\n (ADynControlType = jctDBDateTimeEdit) or\r\n (ADynControlType = jctDBDateEdit) or\r\n (ADynControlType = jctDBTimeEdit) or\r\n (ADynControlType = jctDBDirectoryEdit) or\r\n (ADynControlType = jctDBFileNameEdit) or\r\n (ADynControlType = jctDBText) or\r\n (ADynControlType = jctDBListBox) or\r\n (ADynControlType = jctDBImage) or\r\n (ADynControlType = jctDBRadioGroup) or\r\n (ADynControlType = jctDBMemo) or\r\n (ADynControlType = jctDBGrid) then\r\n Valid := Valid and Supports(AControlClass, IJvDynControlDataBase);\r\n Result := Valid;\r\nend;\r\n\r\nfunction TJvDynControlEngineDB.GetFieldControlType(AField: TField): TJvDynControlType;\r\nbegin\r\n if not Assigned(AField) then\r\n raise EJVCLException.CreateRes(@RsEUnassignedField);\r\n case AField.DataType of\r\n ftOraClob, ftMemo, ftFmtMemo{$IFDEF COMPILER10_UP}, ftWideMemo{$ENDIF COMPILER10_UP}:\r\n Result := jctDBMemo;\r\n ftGraphic:\r\n Result := jctDBImage;\r\n ftString:\r\n Result := jctDBEdit;\r\n ftDate:\r\n Result := jctDBDateEdit;\r\n ftTime:\r\n Result := jctDBTimeEdit;\r\n ftDateTime, ftTimestamp \r\n {$IFDEF COMPILER10_UP}, ftOraTimestamp{$ENDIF COMPILER10_UP}:\r\n Result := jctDBDateTimeEdit;\r\n ftBoolean:\r\n Result := jctDBCheckBox;\r\n else\r\n Result := jctDBEdit;\r\n end;\r\nend;\r\n\r\nfunction TJvDynControlEngineDB.CreateDBFieldControl(AField: TField; AOwner: TComponent;\r\n AParentControl: TWinControl; AControlName: string; ADataSource: TDataSource): TWinControl;\r\nbegin\r\n Result := TWinControl(CreateDBControl(GetFieldControlType(AField), AOwner, AParentControl,\r\n AControlName, ADataSource, AField.FieldName));\r\nend;\r\n\r\nfunction TJvDynControlEngineDB.CreateDBControl(AControlType: TJvDynControlType;\r\n AOwner: TComponent; AParentControl: TWinControl; AControlName: string;\r\n ADataSource: TDataSource; const ADataField: string): TControl;\r\nvar\r\n DynCtrl: IJvDynControlDatabase;\r\nbegin\r\n Result := CreateControl(AControlType, AOwner, AParentControl, AControlName);\r\n if not Supports(Result, IJvDynControlDatabase, DynCtrl) then\r\n raise EIntfCastError.CreateRes(@RsEIntfCastError);\r\n DynCtrl.ControlSetDatasource(ADataSource);\r\n DynCtrl.ControlSetDatafield(ADataField);\r\nend;\r\n\r\nfunction TJvDynControlEngineDB.CreateDBTextControl(AOwner: TComponent;\r\n AParentControl: TWinControl; const AControlName: string;\r\n ADataSource: TDataSource; const ADataField: string; const ACaption: string): TWinControl;\r\nvar\r\n DynCtrl: IJvDynControlCaption;\r\nbegin\r\n Result := TWinControl(CreateDBControl(jctDBText, AOwner, AParentControl,\r\n AControlName, ADataSource, ADataField));\r\n if not Supports(Result, IJvDynControlCaption, DynCtrl) then\r\n raise EIntfCastError.CreateRes(@RsEIntfCastError);\r\n DynCtrl.ControlSetCaption(ACaption);\r\nend;\r\n\r\nfunction TJvDynControlEngineDB.CreateDBEditControl(AOwner: TComponent; AParentControl: TWinControl;\r\n const AControlName: string; ADataSource: TDataSource; const ADataField: string): TWinControl;\r\nvar\r\n DynCtrlEdit: IJvDynControlEdit;\r\nbegin\r\n Result := TWinControl(CreateDBControl(jctDBEdit, AOwner, AParentControl,\r\n AControlName, ADataSource, ADataField));\r\n if not Supports(Result, IJvDynControlEdit, DynCtrlEdit) then\r\n raise EIntfCastError.CreateRes(@RsEIntfCastError);\r\nend;\r\n\r\nfunction TJvDynControlEngineDB.CreateDBCheckboxControl(AOwner: TComponent; AParentControl: TWinControl;\r\n const AControlName: string; ADataSource: TDataSource; const ADataField, ACaption: string): TWinControl;\r\nvar\r\n DynCtrl: IJvDynControlCaption;\r\nbegin\r\n Result := TWinControl(CreateDBControl(jctDBCheckBox, AOwner, AParentControl,\r\n AControlName, ADataSource, ADataField));\r\n if not Supports(Result, IJvDynControlCaption, DynCtrl) then\r\n raise EIntfCastError.CreateRes(@RsEIntfCastError);\r\n DynCtrl.ControlSetCaption(ACaption);\r\nend;\r\n\r\nfunction TJvDynControlEngineDB.CreateDBComboBoxControl(AOwner: TComponent; AParentControl: TWinControl;\r\n const AControlName: string; ADataSource: TDataSource; const ADataField: string;\r\n AItems: TStrings): TWinControl;\r\nvar\r\n DynCtrlItems: IJvDynControlItems;\r\nbegin\r\n Result := TWinControl(CreateDBControl(jctDBComboBox, AOwner, AParentControl,\r\n AControlName, ADataSource, ADataField));\r\n if not Supports(Result, IJvDynControlItems, DynCtrlItems) then\r\n raise EIntfCastError.CreateRes(@RsEIntfCastError);\r\n DynCtrlItems.ControlSetItems(AItems);\r\nend;\r\n\r\nfunction TJvDynControlEngineDB.CreateDBImageControl(AOwner: TComponent; AParentControl: TWinControl;\r\n const AControlName: string; ADataSource: TDataSource; const ADataField: string): TWinControl;\r\nbegin\r\n Result := TWinControl(CreateDBControl(jctDBImage, AOwner, AParentControl,\r\n AControlName, ADataSource, ADataField));\r\nend;\r\n\r\nfunction TJvDynControlEngineDB.CreateDBRadioGroupControl(AOwner: TComponent;\r\n AParentControl: TWinControl; const AControlName: string; ADataSource: TDataSource;\r\n const ADataField, ACaption: string; AItems: TStrings): TWinControl;\r\nvar\r\n DynCtrl: IJvDynControlCaption;\r\n DynCtrlItems: IJvDynControlItems;\r\nbegin\r\n Result := TWinControl(CreateDBControl(jctDBRadioGroup, AOwner, AParentControl,\r\n AControlName, ADataSource, ADataField));\r\n if not Supports(Result, IJvDynControlCaption, DynCtrl) then\r\n raise EIntfCastError.CreateRes(@RsEIntfCastError);\r\n DynCtrl.ControlSetCaption(ACaption);\r\n if not Supports(Result, IJvDynControlItems, DynCtrlItems) then\r\n raise EIntfCastError.CreateRes(@RsEIntfCastError);\r\n DynCtrlItems.ControlSetItems(AItems);\r\nend;\r\n\r\nfunction TJvDynControlEngineDB.CreateDBMemoControl(AOwner: TComponent; AParentControl: TWinControl;\r\n const AControlName: string; ADataSource: TDataSource; const ADataField: string): TWinControl;\r\nbegin\r\n Result := TWinControl(CreateDBControl(jctDBMemo, AOwner, AParentControl,\r\n AControlName, ADataSource, ADataField));\r\nend;\r\n\r\nfunction TJvDynControlEngineDB.CreateDBListBoxControl(AOwner: TComponent; AParentControl: TWinControl;\r\n const AControlName: string; ADataSource: TDataSource; const ADataField: string;\r\n AItems: TStrings): TWinControl;\r\nvar\r\n DynCtrlItems: IJvDynControlItems;\r\nbegin\r\n Result := TWinControl(CreateDBControl(jctDBListBox, AOwner, AParentControl,\r\n AControlName, ADataSource, ADataField));\r\n if not Supports(Result, IJvDynControlItems, DynCtrlItems) then\r\n raise EIntfCastError.CreateRes(@RsEIntfCastError);\r\n DynCtrlItems.ControlSetItems(AItems);\r\nend;\r\n\r\nfunction TJvDynControlEngineDB.CreateDBDateTimeControl(AOwner: TComponent;\r\n AParentControl: TWinControl; const AControlName: string; ADataSource: TDataSource;\r\n const ADataField: string): TWinControl;\r\nbegin\r\n Result := TWinControl(CreateDBControl(jctDBDateTimeEdit, AOwner, AParentControl,\r\n AControlName, ADataSource, ADataField));\r\nend;\r\n\r\nfunction TJvDynControlEngineDB.CreateDBDateControl(AOwner: TComponent;\r\n AParentControl: TWinControl; const AControlName: string; ADataSource: TDataSource;\r\n const ADataField: string): TWinControl;\r\nbegin\r\n Result := TWinControl(CreateDBControl(jctDBDateEdit, AOwner, AParentControl,\r\n AControlName, ADataSource, ADataField));\r\nend;\r\n\r\nfunction TJvDynControlEngineDB.CreateDBTimeControl(AOwner: TComponent;\r\n AParentControl: TWinControl; const AControlName: string; ADataSource: TDataSource;\r\n const ADataField: string): TWinControl;\r\nbegin\r\n Result := TWinControl(CreateDBControl(jctDBTimeEdit, AOwner, AParentControl,\r\n AControlName, ADataSource, ADataField));\r\nend;\r\n\r\nfunction TJvDynControlEngineDB.CreateDBCalculateControl(AOwner: TComponent;\r\n AParentControl: TWinControl; const AControlName: string; ADataSource: TDataSource;\r\n const ADataField: string): TWinControl;\r\nbegin\r\n Result := TWinControl(CreateDBControl(jctDBCalculateEdit, AOwner, AParentControl,\r\n AControlName, ADataSource, ADataField));\r\nend;\r\n\r\nfunction TJvDynControlEngineDB.CreateDBSpinControl(AOwner: TComponent;\r\n AParentControl: TWinControl; const AControlName: string; ADataSource: TDataSource;\r\n const ADataField: string): TWinControl;\r\nbegin\r\n Result := TWinControl(CreateDBControl(jctDBSpinEdit, AOwner, AParentControl,\r\n AControlName, ADataSource, ADataField));\r\nend;\r\n\r\nfunction TJvDynControlEngineDB.CreateDBDirectoryControl(AOwner: TComponent;\r\n AParentControl: TWinControl; const AControlName: string; ADataSource: TDataSource;\r\n const ADataField: string): TWinControl;\r\nbegin\r\n Result := TWinControl(CreateDBControl(jctDBDirectoryEdit, AOwner, AParentControl,\r\n AControlName, ADataSource, ADataField));\r\nend;\r\n\r\nfunction TJvDynControlEngineDB.CreateDBFileNameControl(AOwner: TComponent;\r\n AParentControl: TWinControl; const AControlName: string; ADataSource: TDataSource;\r\n const ADataField: string): TWinControl;\r\nbegin\r\n Result := TWinControl(CreateDBControl(jctDBFileNameEdit, AOwner, AParentControl,\r\n AControlName, ADataSource, ADataField));\r\nend;\r\n\r\nfunction TJvDynControlEngineDB.CreateDBGridControl(AOwner: TComponent;\r\n AParentControl: TWinControl; const AControlName: string; ADataSource: TDataSource): TWinControl;\r\nbegin\r\n Result := TWinControl(CreateDBControl(jctDBGrid, AOwner, AParentControl,\r\n AControlName, ADataSource, ''));\r\nend;\r\n\r\nfunction TJvDynControlEngineDB.CreateDBNavigatorControl(AOwner: TComponent;\r\n AParentControl: TWinControl; const AControlName: string; ADataSource: TDataSource): TWinControl;\r\nbegin\r\n Result := TWinControl(CreateDBControl(jctDBNavigator, AOwner, AParentControl,\r\n AControlName, ADataSource, ''));\r\nend;\r\n\r\ntype\r\n TAccessCustomControl = class(TCustomControl);\r\n\r\nfunction TJvDynControlEngineDB.CreateControlsFromDataSourceOnControl(ADataSource: TDataSource;\r\n AControl: TWinControl; AOptions: TJvCreateDBFieldsOnControlOptions): Boolean;\r\nvar\r\n I: Integer;\r\n Control: TWinControl;\r\n LabelControl: TWinControl;\r\n CreateOptions: TJvCreateDBFieldsOnControlOptions;\r\nbegin\r\n //Result := False;\r\n if not Assigned(ADataSource) or not Assigned(ADataSource.DataSet) or not Assigned(AControl) then\r\n raise EJVCLException.CreateRes(@RsEUnassignedMultiple);\r\n if not ADataSource.DataSet.Active then\r\n raise EJVCLException.CreateRes(@RsEUnassignedDataSet);\r\n if not Assigned(AOptions) then\r\n CreateOptions := TJvCreateDBFieldsOnControlOptions.Create\r\n else\r\n CreateOptions := AOptions;\r\n try\r\n for I := 0 to ADataSource.DataSet.FieldCount - 1 do\r\n if ADataSource.DataSet.Fields[I].Visible or CreateOptions.ShowInvisibleFields then\r\n begin\r\n Control := CreateDBFieldControl(ADataSource.DataSet.Fields[I], AControl, AControl, '', ADataSource);\r\n if CreateOptions.FieldDefaultWidth > 0 then\r\n Control.Width := CreateOptions.FieldDefaultWidth\r\n else\r\n begin\r\n if CreateOptions.UseFieldSizeForWidth then\r\n if ADataSource.DataSet.Fields[I].Size > 0 then\r\n Control.Width :=\r\n TAccessCustomControl(AControl).Canvas.TextWidth('X') * ADataSource.DataSet.Fields[I].Size\r\n else\r\n if (GetFieldControlType(ADataSource.DataSet.Fields[I])= jctDBMemo) and (CreateOptions.FieldMaxWidth > 0) then\r\n Control.Width := CreateOptions.FieldMaxWidth\r\n else\r\n else\r\n if ADataSource.DataSet.Fields[I].DisplayWidth > 0 then\r\n Control.Width :=\r\n TAccessCustomControl(AControl).Canvas.TextWidth('X') * ADataSource.DataSet.Fields[I].DisplayWidth;\r\n if (CreateOptions.FieldMaxWidth > 0) and (Control.Width > CreateOptions.FieldMaxWidth) then\r\n Control.Width := CreateOptions.FieldMaxWidth\r\n else\r\n if (CreateOptions.FieldMinWidth > 0) and (Control.Width < CreateOptions.FieldMinWidth) then\r\n Control.Width := CreateOptions.FieldMinWidth\r\n end;\r\n\r\n if CreateOptions.UseParentColorForReadOnly then\r\n // Use ParentColor when the field is ReadOnly\r\n if not ADataSource.DataSet.CanModify or ADataSource.DataSet.Fields[I].ReadOnly then\r\n if isPublishedProp(Control, 'ParentColor') then\r\n SetOrdProp(Control, 'ParentColor', Ord(True));\r\n LabelControl := GetDynControlEngine.CreateLabelControlPanel(AControl, AControl,\r\n '', '&' + ADataSource.DataSet.Fields[I].DisplayLabel, Control, CreateOptions.LabelOnTop, CreateOptions.LabelDefaultWidth);\r\n if CreateOptions.FieldWidthStep > 0 then\r\n if (LabelControl.Width mod CreateOptions.FieldWidthStep) <> 0 then\r\n LabelControl.Width := ((LabelControl.Width div CreateOptions.FieldWidthStep) + 1) * CreateOptions.FieldWidthStep;\r\n end;\r\n finally\r\n if not Assigned(AOptions) then\r\n CreateOptions.Free;\r\n end;\r\n Result := True;\r\nend;\r\n\r\nfunction TJvDynControlEngineDB.GetDataSourceFromDataComponent(ADataComponent: TComponent): TDataSource;\r\nbegin\r\n if ADatacomponent is TDataSource then\r\n Result := TDataSource(ADataComponent)\r\n else\r\n Result := nil;\r\nend;\r\n\r\nfunction TJvDynControlEngineDB.SupportsDataComponent(ADataComponent: TComponent): Boolean;\r\nbegin\r\n Result := Assigned(ADataComponent) and Assigned(GetDataSourceFromDataComponent(ADataComponent));\r\nend;\r\n\r\nfunction TJvDynControlEngineDB.CreateControlsFromDataComponentOnControl(ADataComponent: TComponent;\r\n AControl: TWinControl; AOptions: TJvCreateDBFieldsOnControlOptions): Boolean;\r\nvar\r\n DS: TDataSource;\r\nbegin\r\n DS := GetDataSourceFromDataComponent(ADataComponent);\r\n if Assigned(DS) then\r\n Result := CreateControlsFromDataSourceOnControl(DS, AControl, AOptions)\r\n else\r\n Result := False;\r\nend;\r\n\r\nprocedure SetDefaultDynControlEngineDB(AEngine: TJvDynControlEngineDB);\r\nbegin\r\n if AEngine is TJvDynControlEngineDB then\r\n GlobalDefaultDynControlEngineDB := AEngine;\r\nend;\r\n\r\nfunction DefaultDynControlEngineDB: TJvDynControlEngineDB;\r\nbegin\r\n Assert(Assigned(GlobalDefaultDynControlEngineDB),'JvDynControlEngineDB: DefaultDynControlEngineDB not definded');\r\n Result := GlobalDefaultDynControlEngineDB;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvDynControlEngineDBIntf.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Initial Developer of the Original Code is Jens Fudickar [jens dott fudickar att oratool dott de]\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\nJens Fudickar [jens dott fudickar att oratool dott de]\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvDynControlEngineDBIntf.pas 12461 2009-08-14 17:21:33Z obones $\r\n\r\nunit JvDynControlEngineDBIntf;\r\n\r\n{$I jvcl.inc}\r\n{$I crossplatform.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Classes, DB;\r\n\r\ntype\r\n IJvDynControlDatabase = interface\r\n ['{E9F43566-9D52-4DB3-8D58-ABC3366FA1BA}']\r\n procedure ControlSetDatasource(Value: TDatasource);\r\n function ControlGetDatasource: TDatasource;\r\n procedure ControlSetDataField(const Value: string);\r\n function ControlGetDataField: string;\r\n property ControlDatasource: TDatasource read ControlGetDatasource write ControlSetDatasource;\r\n property ControlDataField: string read ControlGetDataField write ControlSetDataField;\r\n end;\r\n\r\n IJvDynControlDBCheckbox = interface\r\n ['{5C3BAC5F-1340-43BF-8D59-A9A56A73A3C4}']\r\n procedure ControlSetValueChecked(Value: Variant);\r\n procedure ControlSetValueUnChecked(Value: Variant);\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvDynControlEngineDBIntf.pas $';\r\n Revision: '$Revision: 12461 $';\r\n Date: '$Date: 2009-08-14 19:21:33 +0200 (ven. 14 août 2009) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend." }, { "path": "External/Jedi/Jvcl/run/JvDynControlEngineDBTools.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Initial Developer of the Original Code is Jens Fudickar [jens dott fudickar att oratool dott de]\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\nJens Fudickar [jens dott fudickar att oratool dott de]\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvDynControlEngineDBTools.pas 13138 2011-10-26 23:17:50Z jfudickar $\r\n\r\nunit JvDynControlEngineDBTools;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Controls, DB, Classes,\r\n ActnList, Forms, Graphics, JvTypes,\r\n JvPanel, JvDynControlEngine, JvDynControlEngineDB;\r\n\r\ntype\r\n TJvDataSourceEditDialogCreateDataControlsEvent = procedure(ADatacomponent :\r\n TComponent; ADynControlEngineDB: TJvDynControlEngineDB; AParentControl:\r\n TWinControl; AFieldCreateOptions: TJvCreateDBFieldsOnControlOptions) of\r\n object;\r\n TJvDataSourceEditDialogOnFormShowEvent = procedure(ADatacomponent :\r\n TComponent; ADynControlEngineDB: TJvDynControlEngineDB) of\r\n object;\r\n\r\n TJvDynControlDataSourceEditDialog = class(TJvPersistentProperty)\r\n procedure OnFormShow(Sender: TObject);\r\n private\r\n FForm: TCustomForm;\r\n FDynControlEngineDB: TJvDynControlEngineDB;\r\n FDataSource: TDataSource;\r\n FDataComponent: TComponent;\r\n FDialogCaption: string;\r\n FPostButtonCaption: string;\r\n FCancelButtonCaption: string;\r\n FCloseButtonCaption: string;\r\n FPostButtonGlyph: TBitmap;\r\n FCancelButtonGlyph: TBitmap;\r\n FCloseButtonGlyph: TBitmap;\r\n FIncludeNavigator: Boolean;\r\n FBorderStyle: TFormBorderStyle;\r\n FPosition: TPosition;\r\n FTop: Integer;\r\n FLeft: Integer;\r\n FWidth: Integer;\r\n FHeight: Integer;\r\n FOnCreateDataControlsEvent: TJvDataSourceEditDialogCreateDataControlsEvent;\r\n FArrangeConstraints: TSizeConstraints;\r\n FArrangeSettings: TJvArrangeSettings;\r\n FFieldCreateOptions: TJvCreateDBFieldsOnControlOptions;\r\n FScrollBox: TScrollBox;\r\n FNavigatorPanel: TJvPanel;\r\n FButtonPanel: TWinControl;\r\n FPostAction: TCustomAction;\r\n FCancelAction: TCustomAction;\r\n FOnFormShowEvent: TJvDataSourceEditDialogOnFormShowEvent;\r\n protected\r\n function GetDynControlEngineDB: TJvDynControlEngineDB;\r\n procedure SetDataComponent(Value: TComponent);\r\n procedure OnPostButtonClick(Sender: TObject);\r\n procedure OnCancelButtonClick(Sender: TObject);\r\n procedure OnCloseButtonClick(Sender: TObject);\r\n function CreateDynControlDialog(var AMainPanel: TWinControl): TCustomForm;\r\n procedure SetArrangeSettings(Value: TJvArrangeSettings);\r\n procedure SetArrangeConstraints(Value: TSizeConstraints);\r\n procedure SetFieldCreateOptions(Value: TJvCreateDBFieldsOnControlOptions);\r\n procedure ArrangePanelChangedWidth(Sender: TObject; ChangedSize: Integer);\r\n procedure ArrangePanelChangedHeight(Sender: TObject; ChangedSize: Integer);\r\n procedure CreateDataControls(ADatacomponent : TComponent; ADynControlEngineDB:\r\n TJvDynControlEngineDB; AParentControl: TWinControl; AFieldCreateOptions:\r\n TJvCreateDBFieldsOnControlOptions); virtual;\r\n property DataSource: TDataSource read FDataSource;\r\n public\r\n constructor Create(AOwner: TPersistent); override;\r\n destructor Destroy; override;\r\n function ShowDialog: TModalResult;\r\n published\r\n property DataComponent: TComponent read FDataComponent write SetDataComponent;\r\n property PostButtonCaption: string read FPostButtonCaption write FPostButtonCaption;\r\n property CancelButtonCaption: string read FCancelButtonCaption write FCancelButtonCaption;\r\n property CloseButtonCaption: string read FCloseButtonCaption write FCloseButtonCaption;\r\n property PostButtonGlyph: TBitmap read FPostButtonGlyph write FPostButtonGlyph;\r\n property CancelButtonGlyph: TBitmap read FCancelButtonGlyph write FCancelButtonGlyph;\r\n property CloseButtonGlyph: TBitmap read FCloseButtonGlyph write FCloseButtonGlyph;\r\n property DialogCaption: string read FDialogCaption write FDialogCaption;\r\n property DynControlEngineDB: TJvDynControlEngineDB read GetDynControlEngineDB write FDynControlEngineDB;\r\n property IncludeNavigator: Boolean read FIncludeNavigator write FIncludeNavigator;\r\n property BorderStyle: TFormBorderStyle read FBorderStyle write FBorderStyle default bsDialog;\r\n property Position: TPosition read FPosition write FPosition default poScreenCenter;\r\n property Top: Integer read FTop write FTop default 0;\r\n property Left: Integer read FLeft write FLeft default 0;\r\n property Width: Integer read FWidth write FWidth default 0;\r\n property Height: Integer read FHeight write FHeight default 0;\r\n property OnCreateDataControlsEvent: TJvDataSourceEditDialogCreateDataControlsEvent read FOnCreateDataControlsEvent write\r\n FOnCreateDataControlsEvent;\r\n property ArrangeConstraints: TSizeConstraints read FArrangeConstraints write SetArrangeConstraints;\r\n property ArrangeSettings: TJvArrangeSettings read FArrangeSettings write\r\n SetArrangeSettings;\r\n property FieldCreateOptions: TJvCreateDBFieldsOnControlOptions read\r\n FFieldCreateOptions write SetFieldCreateOptions;\r\n property OnFormShowEvent: TJvDataSourceEditDialogOnFormShowEvent read\r\n FOnFormShowEvent write FOnFormShowEvent;\r\n end;\r\n\r\n\r\nfunction ShowDataSourceEditDialog(ADataComponent: TComponent; const\r\n ADialogCaption, APostButtonCaption, ACancelButtonCaption,\r\n ACloseButtonCaption: string; AIncludeNavigator: Boolean;\r\n AFieldCreateOptions: TJvCreateDBFieldsOnControlOptions = nil;\r\n AArrangeConstraints: TSizeConstraints = nil; AArrangeSettings:\r\n TJvArrangeSettings = nil; ADynControlEngineDB: TJvDynControlEngineDB = nil;\r\n ACreateDataControlsEvent: TJvDataSourceEditDialogCreateDataControlsEvent =\r\n nil; AOnFormShowEvent: TJvDataSourceEditDialogOnFormShowEvent = nil):\r\n TModalResult;\r\n\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvDynControlEngineDBTools.pas $';\r\n Revision: '$Revision: 13138 $';\r\n Date: '$Date: 2011-10-27 01:17:50 +0200 (jeu. 27 oct. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n StdCtrls, SysUtils,\r\n JvDBActions, JvDynControlEngineIntf, JvResources;\r\n\r\nprocedure TJvDynControlDataSourceEditDialog.SetDataComponent(Value: TComponent);\r\nbegin\r\n FDataComponent := Value;\r\n FDataSource := DynControlengineDB.GetDataSourceFromDataComponent(Value);\r\nend;\r\n\r\nfunction TJvDynControlDataSourceEditDialog.GetDynControlEngineDB: TJvDynControlEngineDB;\r\nbegin\r\n if Assigned(FDynControlEngineDB) then\r\n Result := FDynControlEngineDB\r\n else\r\n Result := DefaultDynControlEngineDB;\r\nend;\r\n\r\nprocedure TJvDynControlDataSourceEditDialog.OnPostButtonClick(Sender: TObject);\r\nbegin\r\n if DataSource.Dataset.State in [dsInsert, dsEdit] then\r\n try\r\n DataSource.Dataset.Post;\r\n FForm.ModalResult := mrOk;\r\n except\r\n FForm.ModalResult := mrNone;\r\n end;\r\nend;\r\n\r\nprocedure TJvDynControlDataSourceEditDialog.OnCancelButtonClick(Sender: TObject);\r\nbegin\r\n if DataSource.Dataset.State in [dsInsert, dsEdit] then\r\n DataSource.Dataset.Cancel;\r\n FForm.ModalResult := mrCancel;\r\nend;\r\n\r\nprocedure TJvDynControlDataSourceEditDialog.OnCloseButtonClick(Sender: TObject);\r\nbegin\r\n FForm.ModalResult := mrAbort;\r\nend;\r\n\r\nconstructor TJvDynControlDataSourceEditDialog.Create(AOwner: TPersistent);\r\nbegin\r\n inherited Create(AOwner);\r\n \r\n FDialogCaption := '';\r\n FPostButtonCaption := RSSRWPostButtonCaption;\r\n FCancelButtonCaption := RSSRWCancelButtonCaption;\r\n FCloseButtonCaption := RSSRWCloseButtonCaption;\r\n FPostButtonGlyph := nil;\r\n FCancelButtonGlyph := nil;\r\n FCloseButtonGlyph := nil;\r\n FBorderStyle := bsDialog;\r\n FTop := 0;\r\n FLeft := 0;\r\n FWidth := 0;\r\n FHeight := 0;\r\n FPosition := poScreenCenter;\r\n FDynControlEngineDB := nil;\r\n FDataSource := nil;\r\n FArrangeSettings := TJvArrangeSettings.Create(Self);\r\n FArrangeSettings.AutoSize := asBoth;\r\n FArrangeSettings.DistanceHorizontal := 3;\r\n FArrangeSettings.DistanceVertical := 3;\r\n FArrangeSettings.BorderLeft := 3;\r\n FArrangeSettings.BorderTop := 3;\r\n FArrangeSettings.WrapControls := True;\r\n FArrangeConstraints := TSizeConstraints.Create(nil);\r\n FArrangeConstraints.MaxHeight := 480;\r\n FArrangeConstraints.MaxWidth := 640;\r\n FFieldCreateOptions := TJvCreateDBFieldsOnControlOptions.Create;\r\nend;\r\n\r\ndestructor TJvDynControlDataSourceEditDialog.Destroy;\r\nbegin\r\n FFieldCreateOptions.Free;\r\n FArrangeConstraints.Free;\r\n FArrangeSettings.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvDynControlDataSourceEditDialog.SetArrangeSettings(Value: TJvArrangeSettings);\r\nbegin\r\n FArrangeSettings.Assign(Value);\r\nend;\r\n\r\nprocedure TJvDynControlDataSourceEditDialog.SetArrangeConstraints(Value: TSizeConstraints);\r\nbegin\r\n FArrangeConstraints.Assign(Value);\r\nend;\r\n\r\nprocedure TJvDynControlDataSourceEditDialog.SetFieldCreateOptions(Value: TJvCreateDBFieldsOnControlOptions);\r\nbegin\r\n FFieldCreateOptions.Assign(Value);\r\nend;\r\n\r\nprocedure TJvDynControlDataSourceEditDialog.ArrangePanelChangedWidth(Sender: TObject; ChangedSize: Integer);\r\nbegin\r\n FForm.ClientWidth := ChangedSize;\r\nend;\r\n\r\nprocedure TJvDynControlDataSourceEditDialog.ArrangePanelChangedHeight(Sender: TObject; ChangedSize: Integer);\r\nbegin\r\n if Assigned(FNavigatorPanel) then\r\n FForm.ClientHeight := ChangedSize + FButtonPanel.Height + FNavigatorPanel.Height + 35\r\n else\r\n FForm.ClientHeight := ChangedSize + FButtonPanel.Height + 35;\r\nend;\r\n\r\ntype\r\n TAccessControl = class(TControl);\r\n\r\nprocedure TJvDynControlDataSourceEditDialog.CreateDataControls(ADatacomponent :\r\n TComponent; ADynControlEngineDB: TJvDynControlEngineDB; AParentControl:\r\n TWinControl; AFieldCreateOptions: TJvCreateDBFieldsOnControlOptions);\r\nbegin\r\n ADynControlEngineDB.CreateControlsFromDataComponentOnControl(ADataComponent, AParentControl, AFieldCreateOptions);\r\nend;\r\n\r\nfunction TJvDynControlDataSourceEditDialog.CreateDynControlDialog(var AMainPanel: TWinControl): TCustomForm;\r\nvar\r\n DynControlEngine: TJvDynControlEngine;\r\n Form: TCustomForm;\r\n PostButton, CancelButton, CloseButton: TButtonControl;\r\n LeftPos: Integer;\r\n DynCtrlButton: IJvDynControlButton;\r\n DynCtrlAction: IJvDynControlAction;\r\n\r\n function CalcButtonWidth(ACaptionWidth: Integer; AGlyph: TBitmap): Integer;\r\n begin\r\n Result := 4;\r\n if Assigned(AGlyph) then\r\n Result := Result + AGlyph.Width;\r\n if ACaptionWidth > 0 then\r\n begin\r\n Result := Result + ACaptionWidth;\r\n if ACaptionWidth > 0 then\r\n Result := Result + 4;\r\n end;\r\n end;\r\n\r\nbegin\r\n DynControlEngine := DynControlEngineDB.DynControlEngine;\r\n Form := DynControlEngine.CreateForm(DialogCaption, '');\r\n TForm(Form).Position := Position;\r\n TForm(Form).BorderStyle := BorderStyle;\r\n TForm(Form).FormStyle := fsNormal;\r\n TForm(Form).BorderIcons := [];\r\n\r\n FButtonPanel := DynControlEngine.CreatePanelControl(Form, Form, '', '', alBottom);\r\n FButtonPanel.Width := Form.ClientWidth;\r\n AMainPanel := DynControlEngine.CreatePanelControl(Form, Form, '', '', alClient);\r\n LeftPos := FButtonPanel.Width;\r\n if (CloseButtonCaption <> '') or Assigned(CloseButtonGlyph) then\r\n begin\r\n CloseButton := DynControlEngine.CreateButton(Form, FButtonPanel, '', CloseButtonCaption, '', OnCloseButtonClick,\r\n True, False);\r\n FButtonPanel.Height := CloseButton.Height + 6;\r\n CloseButton.Top := 3;\r\n CloseButton.Anchors := [akTop, akRight];\r\n CloseButton.Width := CalcButtonWidth(Form.Canvas.TextWidth(CloseButtonCaption), CloseButtonGlyph);\r\n CloseButton.Left := LeftPos - CloseButton.Width - 5;\r\n LeftPos := CloseButton.Left;\r\n CloseButton.TabOrder := 0;\r\n if Supports(CloseButton, IJvDynControlButton, DynCtrlButton) then\r\n begin\r\n DynCtrlButton.ControlSetDefault(True);\r\n DynCtrlButton.ControlSetCancel(True);\r\n if Assigned(CloseButtonGlyph) then\r\n DynCtrlButton.ControlSetGlyph(CloseButtonGlyph);\r\n end;\r\n end;\r\n if (CancelButtonCaption <> '') or Assigned(CancelButtonGlyph) then\r\n begin\r\n CancelButton := DynControlEngine.CreateButton(Form, FButtonPanel, '', CancelButtonCaption, '', OnCancelButtonClick,\r\n True, False);\r\n if Supports(CancelButton, IJvDynControlAction, DynCtrlAction) then\r\n begin\r\n FCancelAction := TJvDatabaseCancelAction.Create (Form);\r\n FCancelAction.Caption := CancelButtonCaption;\r\n DynCtrlAction.ControlSetAction(FCancelAction);\r\n end\r\n else\r\n FCancelAction := nil;\r\n FButtonPanel.Height := CancelButton.Height + 6;\r\n CancelButton.Top := 3;\r\n CancelButton.Anchors := [akTop, akRight];\r\n CancelButton.Width := CalcButtonWidth(Form.Canvas.TextWidth(CancelButtonCaption), CancelButtonGlyph);\r\n CancelButton.Left := LeftPos - CancelButton.Width - 5;\r\n LeftPos := CancelButton.Left;\r\n CancelButton.TabOrder := 0;\r\n if Supports(CancelButton, IJvDynControlButton, DynCtrlButton) then\r\n begin\r\n DynCtrlButton.ControlSetDefault (False);\r\n DynCtrlButton.ControlSetCancel(False);\r\n if Assigned(CancelButtonGlyph) then\r\n DynCtrlButton.ControlSetGlyph(CancelButtonGlyph);\r\n end;\r\n end;\r\n if (PostButtonCaption <> '') or Assigned(PostButtonGlyph) then\r\n begin\r\n PostButton := DynControlEngine.CreateButton(Form, FButtonPanel, '', PostButtonCaption, '', OnPostButtonClick, True,\r\n False);\r\n FButtonPanel.Height := PostButton.Height + 6;\r\n if Supports(PostButton, IJvDynControlAction, DynCtrlAction) then\r\n begin\r\n FPostAction := TJvDatabasePostAction.Create (Form);\r\n FPostAction.Caption := PostButtonCaption;\r\n DynCtrlAction.ControlSetAction(FPostAction);\r\n end\r\n else\r\n FPostAction := nil;\r\n PostButton.Top := 3;\r\n PostButton.Anchors := [akTop, akRight];\r\n PostButton.Width := CalcButtonWidth(Form.Canvas.TextWidth(PostButtonCaption), PostButtonGlyph);\r\n PostButton.Left := LeftPos - PostButton.Width - 5;\r\n PostButton.TabOrder := 0;\r\n if Supports(PostButton, IJvDynControlButton, DynCtrlButton) then\r\n begin\r\n DynCtrlButton.ControlSetDefault (False);\r\n DynCtrlButton.ControlSetCancel(False);\r\n if Assigned(PostButtonGlyph) then\r\n DynCtrlButton.ControlSetGlyph(PostButtonGlyph);\r\n end;\r\n end;\r\n TForm(Form).Top := Top;\r\n TForm(Form).Left := Left;\r\n TForm(Form).Height := Height;\r\n TForm(Form).Width := Width;\r\n Result := Form;\r\nend;\r\n\r\nprocedure TJvDynControlDataSourceEditDialog.OnFormShow(Sender: TObject);\r\nbegin\r\n if Assigned(OnFormShowEvent) then\r\n OnFormShowEvent(DataComponent, DynControlEngineDB);\r\nend;\r\n\r\nfunction TJvDynControlDataSourceEditDialog.ShowDialog: TModalResult;\r\nvar\r\n MainPanel: TWinControl;\r\n ArrangePanel: TJvPanel;\r\n Navigator: TControl;\r\nbegin\r\n FForm := CreateDynControlDialog(MainPanel);\r\n try\r\n FScrollBox := TScrollBox.Create(FForm);\r\n FScrollBox.Parent := MainPanel;\r\n FScrollBox.Align := alClient;\r\n FScrollBox.BorderStyle := bsNone;\r\n FScrollBox.AutoScroll := True;\r\n {$IFDEF COMPILER10_UP}\r\n FScrollBox.ParentBackground := True;\r\n {$ENDIF COMPILER10_UP}\r\n FForm.Constraints := ArrangeConstraints;\r\n ArrangePanel := TJvPanel.Create(FForm);\r\n ArrangePanel.Align := alTop;\r\n ArrangePanel.BevelInner := bvNone;\r\n ArrangePanel.BevelOuter := bvNone;\r\n ArrangePanel.Parent := FScrollBox;\r\n ArrangePanel.OnChangedWidth := ArrangePanelChangedWidth;\r\n ArrangePanel.OnChangedHeight := ArrangePanelChangedHeight;\r\n ArrangePanel.ArrangeSettings := ArrangeSettings;\r\n if ArrangeSettings.MaxWidth = 0 then\r\n ArrangePanel.ArrangeSettings.MaxWidth := ArrangeConstraints.MaxWidth;\r\n if ArrangeSettings.MaxWidth = 0 then\r\n ArrangeSettings.MaxWidth := Screen.Width;\r\n FNavigatorPanel := TJvPanel.Create(FForm);\r\n Navigator := DynControlEngineDB.CreateDBNavigatorControl(FForm, FNavigatorPanel, '', DataSource);\r\n Navigator.Left := 3;\r\n Navigator.Top := 3;\r\n FNavigatorPanel.Align := alBottom;\r\n FNavigatorPanel.BevelInner := bvNone;\r\n FNavigatorPanel.BevelOuter := bvNone;\r\n FNavigatorPanel.Parent := MainPanel;\r\n FNavigatorPanel.Height := Navigator.Height + 6;\r\n FNavigatorPanel.Visible := IncludeNavigator;\r\n if Assigned(OnCreateDataControlsEvent) then\r\n OnCreateDataControlsEvent(DataComponent, DynControlEngineDB, ArrangePanel, FieldCreateOptions)\r\n else\r\n CreateDataControls(DataComponent, DynControlEngineDB, ArrangePanel, FieldCreateOptions);\r\n if Assigned (FCancelAction) then\r\n TJvDatabaseCancelAction(FCancelAction).DataComponent := DataComponent;\r\n if Assigned (FPostAction) then\r\n TJvDatabaseCancelAction(FPostAction).DataComponent := DataComponent;\r\n TForm(FForm).Top := Top;\r\n TForm(FForm).Left := Left;\r\n TForm(FForm).Height := Height;\r\n TForm(FForm).Width := Width;\r\n TForm(FForm).OnShow := OnFormShow;\r\n ArrangePanel.ArrangeSettings.AutoArrange := True;\r\n MainPanel.TabOrder := 0;\r\n Result := FForm.ShowModal;\r\n finally\r\n FForm.Free;\r\n end;\r\nend;\r\n\r\nfunction ShowDataSourceEditDialog(ADataComponent: TComponent; const\r\n ADialogCaption, APostButtonCaption, ACancelButtonCaption,\r\n ACloseButtonCaption: string; AIncludeNavigator: Boolean;\r\n AFieldCreateOptions: TJvCreateDBFieldsOnControlOptions = nil;\r\n AArrangeConstraints: TSizeConstraints = nil; AArrangeSettings:\r\n TJvArrangeSettings = nil; ADynControlEngineDB: TJvDynControlEngineDB = nil;\r\n ACreateDataControlsEvent: TJvDataSourceEditDialogCreateDataControlsEvent =\r\n nil; AOnFormShowEvent: TJvDataSourceEditDialogOnFormShowEvent = nil):\r\n TModalResult;\r\nvar\r\n Dialog: TJvDynControlDataSourceEditDialog;\r\nbegin\r\n Dialog := TJvDynControlDataSourceEditDialog.Create(ADataComponent);\r\n try\r\n Dialog.DataComponent := ADataComponent;\r\n Dialog.DialogCaption := ADialogCaption;\r\n Dialog.PostButtonCaption := APostButtonCaption;\r\n Dialog.CancelButtonCaption := ACancelButtonCaption;\r\n Dialog.CloseButtonCaption := ACloseButtonCaption;\r\n Dialog.IncludeNavigator := AIncludeNavigator;\r\n Dialog.DynControlEngineDB := ADynControlEngineDB;\r\n if Assigned(AFieldCreateOptions) then\r\n Dialog.FieldCreateOptions := AFieldCreateOptions;\r\n if Assigned(AArrangeSettings) then\r\n Dialog.ArrangeSettings := AArrangeSettings;\r\n if Assigned(AArrangeConstraints) then\r\n Dialog.ArrangeConstraints := AArrangeConstraints;\r\n Dialog.OnCreateDataControlsEvent := ACreateDataControlsEvent;\r\n Dialog.OnFormShowEvent := AOnFormShowEvent;\r\n Result := Dialog.ShowDialog;\r\n finally\r\n Dialog.Free;\r\n end;\r\nend;\r\n\r\n\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n\r\n" }, { "path": "External/Jedi/Jvcl/run/JvDynControlEngineDBToolscxVGrid.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Initial Developer of the Original Code is Jens Fudickar [jens dott fudickar att oratool dott de]\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\nJens Fudickar [jens dott fudickar att oratool dott de]\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvDynControlEngineDBToolscxVGrid.pas 12806 2010-06-12 17:27:30Z uschuster $\r\n\r\nunit JvDynControlEngineDBToolscxVGrid;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Controls, DB, Classes,\r\n {$IFDEF USE_3RDPARTY_DEVEXPRESS_CXVERTICALGRID}\r\n cxDBVGrid, cxVGrid,\r\n {$IFDEF USE_3RDPARTY_DEVEXPRESS_CXGRID}\r\n cxGridCustomTableView,\r\n {$ENDIF USE_3RDPARTY_DEVEXPRESS_CXGRID}\r\n {$ENDIF USE_3RDPARTY_DEVEXPRESS_CXVERTICALGRID}\r\n JvDynControlEngineDBTools,\r\n //JvPanel,\r\n JvDynControlEngineTools, JvDynControlEngine, JvDynControlEngineDB;\r\n\r\n{$IFDEF USE_3RDPARTY_DEVEXPRESS_CXVERTICALGRID}\r\ntype\r\n TJvDataSourceEditDialogCreateDataControlscxVGridEventClass = class(TObject)\r\n private\r\n FInternalDBVGrid: TcxDBVerticalGrid;\r\n FLayoutStyle: TcxvgLayoutStyle;\r\n procedure CreateDefaultFieldsOnVerticalGrid(aGrid: tcxDBVerticalGrid;\r\n aHiddenFieldNames: string = ''; aVisibleFieldNames: string = '*';\r\n aMinLengthForMemo: Integer = 50);\r\n function GetOptionsBehavior: TcxvgMultiRecordsOptionsBehavior;\r\n function GetOptionsData: TcxvgMultiRecordsOptionsData;\r\n function GetOptionsView: TcxvgMultiRecordsOptionsView;\r\n procedure SetOptionsBehavior(const Value: TcxvgMultiRecordsOptionsBehavior);\r\n procedure SetOptionsData(const Value: TcxvgMultiRecordsOptionsData);\r\n procedure SetOptionsView(const Value: TcxvgMultiRecordsOptionsView);\r\n {$IFDEF USE_3RDPARTY_DEVEXPRESS_CXGRID}\r\n procedure TransferGridItemToVertGrid(aGridItem: TcxCustomGridTableItem; aVGrid:\r\n TcxCustomVerticalGrid; var aPos: Integer; aCreateColumn: Boolean = true);\r\n procedure TransferGridViewToVertGrid(aView: tcxCustomGridTableView; aVGrid:\r\n TcxCustomVerticalGrid; TransferGridMode: Boolean);\r\n {$ENDIF USE_3RDPARTY_DEVEXPRESS_CXGRID}\r\n public\r\n constructor Create;\r\n destructor Destroy; override;\r\n procedure CreateDataControls(ADatacomponent : TComponent; ADynControlEngineDB:\r\n TJvDynControlEngineDB; AParentControl: TWinControl; AFieldCreateOptions:\r\n TJvCreateDBFieldsOnControlOptions);\r\n property LayoutStyle: TcxvgLayoutStyle read FLayoutStyle write FLayoutStyle;\r\n property OptionsBehavior: TcxvgMultiRecordsOptionsBehavior read\r\n GetOptionsBehavior write SetOptionsBehavior;\r\n property OptionsData: TcxvgMultiRecordsOptionsData read GetOptionsData write\r\n SetOptionsData;\r\n property OptionsView: TcxvgMultiRecordsOptionsView read GetOptionsView write\r\n SetOptionsView;\r\n\r\n end;\r\n\r\nVar\r\n DefaultDataSourceEditDialogCreateDataControlscxVGridEventClass : TJvDataSourceEditDialogCreateDataControlscxVGridEventClass;\r\n{$ENDIF USE_3RDPARTY_DEVEXPRESS_CXVERTICALGRID}\r\n\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvDynControlEngineDBToolscxVGrid.pas $';\r\n Revision: '$Revision: 12806 $';\r\n Date: '$Date: 2010-06-12 19:27:30 +0200 (sam. 12 juin 2010) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n StdCtrls, SysUtils,\r\n JvDBActions, JvDynControlEngineIntf,\r\n{$IFDEF USE_3RDPARTY_DEVEXPRESS_CXVERTICALGRID}\r\n cxMemo, cxSpinEdit, cxCalc, cxCalendar,\r\n{$IFDEF USE_3RDPARTY_DEVEXPRESS_CXGRID}\r\n cxGrid, cxGridDBDataDefinitions, cxGridTableView, cxGridCustomView,\r\n cxGridBandedTableView,\r\n{$ENDIF USE_3RDPARTY_DEVEXPRESS_CXGRID}\r\n{$ENDIF USE_3RDPARTY_DEVEXPRESS_CXVERTICALGRID}\r\n JclStrings, JvPanel, JvJCLUtils;\r\n\r\ntype\r\n TAccessControl = class(TControl);\r\n\r\n{$IFDEF USE_3RDPARTY_DEVEXPRESS_CXVERTICALGRID}\r\n\r\nconstructor TJvDataSourceEditDialogCreateDataControlscxVGridEventClass.Create;\r\nbegin\r\n inherited Create;\r\n FInternalDBVGrid := TcxDBVerticalGrid.Create(nil);\r\nend;\r\n\r\ndestructor TJvDataSourceEditDialogCreateDataControlscxVGridEventClass.Destroy;\r\nbegin\r\n FreeAndNil(FInternalDBVGrid);\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure\r\n TJvDataSourceEditDialogCreateDataControlscxVGridEventClass.CreateDataControls(\r\n ADatacomponent : TComponent; ADynControlEngineDB: TJvDynControlEngineDB;\r\n AParentControl: TWinControl; AFieldCreateOptions:\r\n TJvCreateDBFieldsOnControlOptions);\r\nvar\r\n VGrid : TcxDBVerticalGrid;\r\nbegin\r\n if AParentControl is TJvPanel then\r\n begin\r\n TJvPanel (AParentControl).ArrangeSettings.AutoArrange := False;\r\n TJvPanel (AParentControl).ArrangeSettings.AutoSize := asNone;\r\n TJvPanel (AParentControl).Height:=0;\r\n end;\r\n VGrid := TcxDBVerticalGrid.Create (AParentControl.Parent);\r\n VGrid.Parent := AParentControl.Parent;\r\n VGrid.Align := alClient;\r\n VGrid.OptionsData := OptionsData;\r\n VGrid.OptionsBehavior := OptionsBehavior;\r\n VGrid.OptionsView := OptionsView;\r\n VGrid.LayoutStyle := LayoutStyle;\r\n VGrid.DataController.DataSource := ADynControlEngineDB.GetDataSourceFromDataComponent(ADatacomponent);\r\n {$IFDEF USE_3RDPARTY_DEVEXPRESS_CXGRID}\r\n if (aDataComponent is TcxGrid) and Assigned(tcxGrid(aDataComponent).ActiveView)\r\n and (tcxGrid(aDataComponent).ActiveView is tcxCustomGridTableView) then\r\n TransferGridViewToVertGrid(tcxCustomGridTableView(tcxGrid(aDataComponent).ActiveView), VGrid, False)\r\n else if (aDatacomponent is tcxCustomGridTableView) then\r\n TransferGridViewToVertGrid(tcxCustomGridTableView(aDatacomponent), VGrid, False)\r\n else\r\n {$ENDIF USE_3RDPARTY_DEVEXPRESS_CXGRID}\r\n CreateDefaultFieldsOnVerticalGrid (vGrid);\r\nend;\r\n\r\nprocedure\r\n TJvDataSourceEditDialogCreateDataControlscxVGridEventClass.CreateDefaultFieldsOnVerticalGrid(\r\n aGrid: tcxDBVerticalGrid; aHiddenFieldNames: string = '';\r\n aVisibleFieldNames: string = '*'; aMinLengthForMemo: Integer = 50);\r\nvar\r\n i, j: Integer;\r\n HiddenFields: tStringList;\r\n FieldNamesList: TStringList;\r\n Fieldfound: boolean;\r\n DBDatabinding: TcxDBVerticalGridItemDataBinding;\r\n CurrentRow: TcxDBEditorRow;\r\n Hiddenfound: Boolean;\r\n\r\n function GetFieldName(s: string): string;\r\n var\r\n i: Integer;\r\n begin\r\n s := Uppercase(s);\r\n if not CharInSet(s[1], ['A'..'Z', '_']) then\r\n s[1] := '_';\r\n for i := 2 to Length(s) do\r\n if not CharInSet(s[i], ['A'..'Z', '0'..'9', '_']) then\r\n s[i] := '_';\r\n Result := s;\r\n end;\r\n\r\nbegin\r\n if not Assigned(aGrid) then\r\n Exit;\r\n aGrid.BeginUpdate;\r\n HiddenFields := tStringList.Create;\r\n FieldNamesList := TStringList.Create;\r\n try\r\n HiddenFields.CommaText := Uppercase(aHiddenFieldNames);\r\n FieldNamesList.CommaText := Uppercase(aVisibleFieldNames);\r\n aGrid.DataController.Filter.Clear;\r\n aGrid.ClearRows;\r\n aGrid.DataController.GridMode := True;\r\n aGrid.DataController.CreateAllItems;\r\n for i := 0 to aGrid.Rows.Count - 1 do\r\n begin\r\n if (aGrid.Rows[i] is TcxDBEditorRow) then\r\n begin\r\n CurrentRow := TcxDBEditorRow(aGrid.Rows[i]);\r\n if not Assigned(CurrentRow) then\r\n Continue;\r\n DBDatabinding := CurrentRow.Properties.DataBinding;\r\n if not Assigned(DBDatabinding) or not Assigned(DBDatabinding.Field) then\r\n Continue;\r\n CurrentRow.Name := GetFieldName(aGrid.Name + ' Row ' + DBDatabinding.FieldName);\r\n Hiddenfound := False;\r\n for j := 0 to hiddenfields.Count - 1 do\r\n if (trim(HiddenFields[j]) <> '') and\r\n StrMatches(HiddenFields[j], Uppercase(DBDatabinding.FieldName), 1) then\r\n begin\r\n Hiddenfound := True;\r\n break;\r\n end;\r\n if Hiddenfound then\r\n CurrentRow.Visible := FALSE;\r\n Fieldfound := False;\r\n for j := 0 to FieldNamesList.Count - 1 do\r\n if (trim(FieldNamesList[j]) <> '') and\r\n StrMatches(FieldNamesList[j], Uppercase(DBDatabinding.FieldName), 1) then\r\n begin\r\n Fieldfound := True;\r\n break;\r\n end;\r\n if not Fieldfound then\r\n CurrentRow.Visible := FALSE;\r\n if DBDatabinding.Field.Datatype in [ftOraClob, ftMemo, ftFMTMemo{$IFDEF COMPILER10_UP}, ftWideMemo{$ENDIF COMPILER10_UP}] then\r\n begin\r\n CurrentRow.Properties.EditPropertiesClass := TcxMemoProperties;\r\n TcxMemoProperties(CurrentRow.Properties.EditProperties).Scrollbars := ssBoth;\r\n end\r\n else\r\n if DBDatabinding.Field.Datatype in [ftSmallint, ftInteger, ftWord, ftLargeint, ftAutoInc{$IFDEF COMPILER12_UP},ftLongWord, ftShortint{$ENDIF COMPILER12_UP}] then\r\n begin\r\n CurrentRow.Properties.EditPropertiesClass := TcxSpinEditProperties;\r\n TcxSpinEditProperties(CurrentRow.Properties.EditProperties).ValueType := vtInt;\r\n// TcxSpinEditPropertiesAccess(CurrentRow.Properties.EditProperties).Buttons[0].Visible := False;\r\n// TcxSpinEditPropertiesAccess(CurrentRow.Properties.EditProperties).Buttons[1].Visible := False;\r\n end\r\n else\r\n if DBDatabinding.Field.Datatype in [ftFloat, ftCurrency, ftBCD, ftFMTBcd{$IFDEF COMPILER12_UP},ftExtended{$ENDIF COMPILER12_UP}] then\r\n begin\r\n CurrentRow.Properties.EditPropertiesClass := TcxCalcEditProperties;\r\n end\r\n else\r\n if DBDatabinding.Field.Datatype in [ftDate, ftTime, ftDateTime {$IFDEF COMPILER10_UP},ftOraTimestamp{$ENDIF COMPILER10_UP}] then\r\n begin\r\n CurrentRow.Properties.EditPropertiesClass := TcxDateEditProperties;\r\n TcxDateEditProperties(CurrentRow.Properties.EditProperties).InputKind := ikStandard;\r\n TcxDateEditProperties(CurrentRow.Properties.EditProperties).SaveTime := True;\r\n TcxDateEditProperties(CurrentRow.Properties.EditProperties).ShowTime := True;\r\n end\r\n else\r\n if (aMinLengthForMemo > 0) and\r\n (DBDatabinding.Field.Datatype in [ftString, ftWideString]) and\r\n (DBDatabinding.Field.Size > aMinLengthForMemo) then\r\n CurrentRow.Properties.EditPropertiesClass := TcxMemoProperties;\r\n end\r\n end;\r\n\r\n finally\r\n HiddenFields.Free;\r\n aGrid.EndUpdate;\r\n end;\r\nend;\r\n\r\nfunction\r\n TJvDataSourceEditDialogCreateDataControlscxVGridEventClass.GetOptionsBehavior:\r\n TcxvgMultiRecordsOptionsBehavior;\r\nbegin\r\n Result := FInternalDBVGrid.OptionsBehavior;\r\nend;\r\n\r\nfunction\r\n TJvDataSourceEditDialogCreateDataControlscxVGridEventClass.GetOptionsData:\r\n TcxvgMultiRecordsOptionsData;\r\nbegin\r\n Result := FInternalDBVGrid.OptionsData;\r\nend;\r\n\r\nfunction\r\n TJvDataSourceEditDialogCreateDataControlscxVGridEventClass.GetOptionsView:\r\n TcxvgMultiRecordsOptionsView;\r\nbegin\r\n Result := FInternalDBVGrid.OptionsView;\r\nend;\r\n\r\nprocedure\r\n TJvDataSourceEditDialogCreateDataControlscxVGridEventClass.SetOptionsBehavior(\r\n const Value: TcxvgMultiRecordsOptionsBehavior);\r\nbegin\r\n FInternalDBVGrid.OptionsBehavior.Assign (Value);\r\nend;\r\n\r\nprocedure\r\n TJvDataSourceEditDialogCreateDataControlscxVGridEventClass.SetOptionsData(\r\n const Value: TcxvgMultiRecordsOptionsData);\r\nbegin\r\n FInternalDBVGrid.OptionsData.Assign (Value);\r\nend;\r\n\r\nprocedure\r\n TJvDataSourceEditDialogCreateDataControlscxVGridEventClass.SetOptionsView(\r\n const Value: TcxvgMultiRecordsOptionsView);\r\nbegin\r\n FInternalDBVGrid.OptionsView.Assign (Value);\r\nend;\r\n\r\n{$IFDEF USE_3RDPARTY_DEVEXPRESS_CXGRID}\r\nprocedure\r\n TJvDataSourceEditDialogCreateDataControlscxVGridEventClass.TransferGridItemToVertGrid(\r\n aGridItem: TcxCustomGridTableItem; aVGrid: TcxCustomVerticalGrid; var aPos:\r\n Integer; aCreateColumn: Boolean = true);\r\nvar\r\n j: Integer;\r\n GridDataBinding: TcxGridItemDBDataBinding;\r\n EditorRow: TcxDBEditorRow;\r\nbegin\r\n if not (aGridItem is TcxGridColumn) or\r\n not (aGridItem.DataBinding is TcxGridItemDBDataBinding) then\r\n Exit;\r\n EditorRow := nil;\r\n GridDataBinding := TcxGridItemDBDataBinding(aGridItem.DataBinding);\r\n if aCreateColumn then\r\n begin\r\n EditorRow := TcxDBEditorRow(aVGrid.Add(TcxDBEditorRow));\r\n EditorRow.Properties.DataBinding.FieldName := GridDataBinding.FieldName;\r\n EditorRow.Properties.Caption := EditorRow.Properties.DataBinding.DefaultCaption;\r\n end\r\n else\r\n for j := 0 to aVGrid.Rows.Count - 1 do\r\n begin\r\n if not (aVGrid.Rows.Items[j] is TcxDBEditorRow) then\r\n Continue;\r\n EditorRow := TcxDBEditorRow(aVGrid.Rows.Items[j]);\r\n if not (EditorRow.Properties.DataBinding is TcxDBVerticalGridItemDataBinding) then\r\n continue;\r\n if GridDataBinding.FieldName = EditorRow.Properties.DataBinding.FieldName then\r\n Break;\r\n EditorRow := nil;\r\n end;\r\n if Assigned(EditorRow) then\r\n begin\r\n EditorRow.Properties.EditPropertiesClass := TcxGridColumn(aGridItem).PropertiesClass;\r\n EditorRow.Properties.EditProperties := TcxGridColumn(aGridItem).Properties;\r\n EditorRow.Visible := TcxGridColumn(aGridItem).ActuallyVisible or\r\n (TcxGridColumn(aGridItem).GroupIndex >= 0);\r\n EditorRow.Index := aPos;\r\n Inc(aPos);\r\n end;\r\nend;\r\n\r\nprocedure\r\n TJvDataSourceEditDialogCreateDataControlscxVGridEventClass.TransferGridViewToVertGrid(\r\n aView: tcxCustomGridTableView; aVGrid: TcxCustomVerticalGrid;\r\n TransferGridMode: Boolean);\r\n\r\nvar\r\n dbVGrid: TcxDBVerticalGrid;\r\n GridDataController: TcxGridDBDataController;\r\n i: Integer;\r\n Position: Integer;\r\n b: Integer;\r\nbegin\r\n if not Assigned(aView) then\r\n raise Exception.Create('TJvDataSourceEditDialogCreateDataControlscxVGridEventClass.TransferGridViewToVertGrid : aView must be assigned');\r\n if not Assigned(aVGrid) then\r\n raise Exception.Create('TJvDataSourceEditDialogCreateDataControlscxVGridEventClass.TransferGridViewToVertGrid : aVGrid must be assigned');\r\n if (csDestroying in aView.ComponentState) or\r\n (csDestroying in aVGrid.ComponentState) then\r\n exit;\r\n if avGrid is TcxDBVerticalGrid then\r\n dbVGrid := TcxDBVerticalGrid(avGrid)\r\n else\r\n raise Exception.Create('TJvDataSourceEditDialogCreateDataControlscxVGridEventClass.TransferGridViewToVertGrid : aVGrid must TcxDBVerticalGrid');\r\n if tcxCustomGridView(aView).DataController is TcxGridDBDataController then\r\n GridDataController := TcxGridDBDataController(aView.DataController)\r\n else\r\n raise Exception.Create('TJvDataSourceEditDialogCreateDataControlscxVGridEventClass.TransferGridViewToVertGrid : aView.DataController must TcxGridDBDataController');\r\n if aView.Control is TCxGrid then\r\n dbVGrid.LookAndFeel := TCxGrid(aView.Control).lookAndFeel;\r\n dbVGrid.BeginUpdate;\r\n try\r\n dbVGrid.DataController.Filter.Clear;\r\n dbVGrid.ClearRows;\r\n dbVGrid.DataController.Datasource := nil;\r\n if TransferGridMode then\r\n dbVGrid.dataController.GridMode :=\r\n GridDataController.DatamodeController.GridMode\r\n else\r\n dbVGrid.dataController.GridMode := True;\r\n dbVGrid.dataController.Datasource := GridDataController.Datasource;\r\n Position := 0;\r\n for i := 0 to aView.GroupedItemCount - 1 do\r\n TransferGridItemToVertGrid(aView.GroupedItems[i], dbVGrid, Position, True);\r\n if aView is TcxGridBandedTableView then\r\n begin\r\n for b := 0 to TcxGridBandedTableView(aView).Bands.VisibleCount - 1 do\r\n for i := 0 to aView.VisibleItemCount - 1 do\r\n if (aView.VisibleItems[i] is TcxGridBandedColumn) and\r\n (TcxGridBandedColumn (aView.VisibleItems[i]).Position.VisibleBandIndex = b) then\r\n TransferGridItemToVertGrid(aView.VisibleItems[i], dbVGrid, Position, True);\r\n end\r\n else\r\n for i := 0 to aView.VisibleItemCount - 1 do\r\n TransferGridItemToVertGrid(aView.VisibleItems[i], dbVGrid, Position, True);\r\n finally\r\n dbVGrid.EndUpdate;\r\n end;\r\nend;\r\n{$ENDIF USE_3RDPARTY_DEVEXPRESS_CXGRID}\r\n{$ENDIF USE_3RDPARTY_DEVEXPRESS_CXVERTICALGRID}\r\n\r\n\r\ninitialization\r\n {$IFDEF UNITVERSIONING}\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n {$ENDIF UNITVERSIONING}\r\n {$IFDEF USE_3RDPARTY_DEVEXPRESS_CXVERTICALGRID}\r\n DefaultDataSourceEditDialogCreateDataControlscxVGridEventClass := TJvDataSourceEditDialogCreateDataControlscxVGridEventClass.Create;\r\n {$ENDIF USE_3RDPARTY_DEVEXPRESS_CXVERTICALGRID}\r\n\r\n\r\nfinalization\r\n {$IFDEF USE_3RDPARTY_DEVEXPRESS_CXVERTICALGRID}\r\n DefaultDataSourceEditDialogCreateDataControlscxVGridEventClass.Free;\r\n {$ENDIF USE_3RDPARTY_DEVEXPRESS_CXVERTICALGRID}\r\n {$IFDEF UNITVERSIONING}\r\n UnregisterUnitVersion(HInstance);\r\n {$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvDynControlEngineDevExpCx.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Initial Developer of the Original Code is Jens Fudickar [jens dott fudickar att oratool dott de]\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\nJens Fudickar [jens dott fudickar att oratool dott de]\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvDynControlEngineDevExpCx.pas 13075 2011-06-27 22:56:21Z jfudickar $\r\n\r\nunit JvDynControlEngineDevExpCx;\r\n\r\n{$I jvcl.inc}\r\n{$I windowsonly.inc}\r\n\r\ninterface\r\n\r\n{$IFNDEF USE_3RDPARTY_DEVEXPRESS_CXEDITOR}\r\n\r\n{$IFDEF UNITVERSIONING}\r\nuses\r\n JclUnitVersioning, JvDynControlEngineIntf, Graphics, ComCtrls, Classes,\r\n JvInspector, ExtCtrls;\r\n{$ENDIF UNITVERSIONING}\r\n\r\n{$ELSE}\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Classes, Controls, StdCtrls, ExtCtrls, ComCtrls, Mask, Forms, Graphics,\r\n Buttons, Dialogs, FileCtrl, ActnList, ImgList,\r\n cxLookAndFeels, cxMaskEdit, cxLabel, cxButtons, cxListBox, cxDropDownEdit,\r\n cxButtonEdit, cxCalendar, cxCheckBox, cxMemo, cxRadioGroup, cxImage, cxTreeView,\r\n cxEdit, cxCalc, cxSpinEdit, cxTimeEdit, cxCheckListBox, cxGroupBox, cxRichEdit,\r\n cxProgressBar, cxPC, cxColorComboBox, cxGraphics, cxCheckComboBox,\r\n {$IFDEF USE_3RDPARTY_DEVEXPRESS_CXVERTICALGRID}\r\n cxOi, cxVGrid, cxVGridViewInfo,\r\n {$ENDIF}\r\n JvDynControlEngine, JvDynControlEngineIntf;\r\n\r\ntype\r\n\r\n TCxDynControlWrapper = class(TPersistent)\r\n private\r\n FLookAndFeel: TcxLookAndFeel;\r\n FStyleController: TcxEditStyleController;\r\n protected\r\n procedure SetLookAndFeel(Value: TcxLookAndFeel);\r\n procedure SetStyleController(Value: TcxEditStyleController);\r\n public\r\n constructor Create; virtual;\r\n destructor Destroy; override;\r\n published\r\n property LookAndFeel: TcxLookAndFeel read FLookAndFeel write SetLookAndFeel;\r\n property StyleController: TcxEditStyleController read FStyleController write SetStyleController;\r\n end;\r\n\r\n IJvDynControlDevExpCx = interface\r\n ['{13F812FE-9F75-4529-8452-45F2D9DE5A91}']\r\n procedure ControlSetCxProperties(Value: TCxDynControlWrapper);\r\n end;\r\n\r\n TJvDynControlCxMaskEdit = class(TcxMaskEdit, IUnknown, IJvDynControl, IJvDynControlData,\r\n IJvDynControlDevExpCx, IJvDynControlReadOnly, IJvDynControlEdit)\r\n public\r\n procedure ControlSetDefaultProperties;\r\n procedure ControlSetReadOnly(Value: Boolean);\r\n procedure ControlSetTabOrder(Value: Integer);\r\n\r\n procedure ControlSetOnEnter(Value: TNotifyEvent);\r\n procedure ControlSetOnExit(Value: TNotifyEvent);\r\n procedure ControlSetOnChange(Value: TNotifyEvent);\r\n procedure ControlSetOnClick(Value: TNotifyEvent);\r\n procedure ControlSetHint(const Value: string);\r\n\r\n procedure ControlSetValue(Value: Variant);\r\n function ControlGetValue: Variant;\r\n procedure ControlSetAnchors(Value: TAnchors);\r\n\r\n procedure ControlSetCxProperties(Value: TCxDynControlWrapper);\r\n\r\n //IJvDynControlEdit\r\n procedure ControlSetPasswordChar(Value: Char);\r\n procedure ControlSetEditMask(const Value: string);\r\n end;\r\n\r\n TJvDynControlCxButtonEdit = class(TcxButtonEdit, IUnknown, IJvDynControl, IJvDynControlData,\r\n IJvDynControlDevExpCx, IJvDynControlReadOnly, IJvDynControlEdit, IJvDynControlButtonEdit,\r\n IJvDynControlButton)\r\n private\r\n FIntOnButtonClick: TNotifyEvent;\r\n protected\r\n procedure IntOnButtonClick(Sender: TObject; AButtonIndex: Integer);\r\n public\r\n procedure ControlSetDefaultProperties;\r\n procedure ControlSetReadOnly(Value: Boolean);\r\n procedure ControlSetTabOrder(Value: Integer);\r\n\r\n procedure ControlSetOnEnter(Value: TNotifyEvent);\r\n procedure ControlSetOnExit(Value: TNotifyEvent);\r\n procedure ControlSetOnChange(Value: TNotifyEvent);\r\n procedure ControlSetOnClick(Value: TNotifyEvent);\r\n procedure ControlSetHint(const Value: string);\r\n\r\n procedure ControlSetValue(Value: Variant);\r\n function ControlGetValue: Variant;\r\n procedure ControlSetAnchors(Value: TAnchors);\r\n\r\n procedure ControlSetCxProperties(Value: TCxDynControlWrapper);\r\n\r\n //IJvDynControlEdit\r\n procedure ControlSetPasswordChar(Value: Char);\r\n procedure ControlSetEditMask(const Value: string);\r\n\r\n //IJvDynControlButtonEdit\r\n procedure ControlSetOnButtonClick(Value: TNotifyEvent);\r\n procedure ControlSetButtonCaption(const Value: string);\r\n\r\n //IJvDynControlButton\r\n procedure ControlSetGlyph(Value: TBitmap);\r\n procedure ControlSetNumGlyphs(Value: Integer);\r\n procedure ControlSetLayout(Value: TButtonLayout);\r\n procedure ControlSetDefault(Value: Boolean);\r\n procedure ControlSetCancel(Value: Boolean);\r\n end;\r\n\r\n TJvDynControlCxCalcEdit = class(TcxCalcEdit, IUnknown, IJvDynControl, IJvDynControlData,\r\n IJvDynControlDevExpCx, IJvDynControlReadOnly)\r\n public\r\n procedure ControlSetDefaultProperties;\r\n procedure ControlSetReadOnly(Value: Boolean);\r\n procedure ControlSetTabOrder(Value: Integer);\r\n\r\n procedure ControlSetOnEnter(Value: TNotifyEvent);\r\n procedure ControlSetOnExit(Value: TNotifyEvent);\r\n procedure ControlSetOnChange(Value: TNotifyEvent);\r\n procedure ControlSetOnClick(Value: TNotifyEvent);\r\n procedure ControlSetHint(const Value: string);\r\n\r\n procedure ControlSetValue(Value: Variant);\r\n function ControlGetValue: Variant;\r\n procedure ControlSetAnchors(Value: TAnchors);\r\n\r\n procedure ControlSetCxProperties(Value: TCxDynControlWrapper);\r\n end;\r\n\r\n TJvDynControlCxSpinEdit = class(TcxSpinEdit, IUnknown, IJvDynControl, IJvDynControlData,\r\n IJvDynControlDevExpCx, IJvDynControlSpin, IJvDynControlReadOnly)\r\n public\r\n procedure ControlSetDefaultProperties;\r\n procedure ControlSetReadOnly(Value: Boolean);\r\n procedure ControlSetTabOrder(Value: Integer);\r\n\r\n procedure ControlSetOnEnter(Value: TNotifyEvent);\r\n procedure ControlSetOnExit(Value: TNotifyEvent);\r\n procedure ControlSetOnChange(Value: TNotifyEvent);\r\n procedure ControlSetOnClick(Value: TNotifyEvent);\r\n procedure ControlSetHint(const Value: string);\r\n\r\n procedure ControlSetValue(Value: Variant);\r\n function ControlGetValue: Variant;\r\n procedure ControlSetAnchors(Value: TAnchors);\r\n\r\n procedure ControlSetCxProperties(Value: TCxDynControlWrapper);\r\n\r\n // IJvDynControlSpin\r\n procedure ControlSetIncrement(Value: Integer);\r\n procedure ControlSetMinValue(Value: double);\r\n procedure ControlSetMaxValue(Value: double);\r\n procedure ControlSetUseForInteger(Value: Boolean);\r\n end;\r\n\r\n TJvDynControlCxFileNameEdit = class(TcxButtonEdit, IUnknown, IJvDynControl,\r\n IJvDynControlData, IJvDynControlDevExpCx, IJvDynControlFileName, IJvDynControlReadOnly)\r\n private\r\n FInitialDir: string;\r\n FFilterIndex: Integer;\r\n FFilter: string;\r\n FDialogOptions: TOpenOptions;\r\n FDialogKind: TJvDynControlFileNameDialogKind;\r\n FDialogTitle: string;\r\n FDefaultExt: string;\r\n public\r\n procedure DefaultOnButtonClick(Sender: TObject; AButtonIndex: Integer);\r\n\r\n procedure ControlSetDefaultProperties;\r\n procedure ControlSetReadOnly(Value: Boolean);\r\n procedure ControlSetTabOrder(Value: Integer);\r\n\r\n procedure ControlSetOnEnter(Value: TNotifyEvent);\r\n procedure ControlSetOnExit(Value: TNotifyEvent);\r\n procedure ControlSetOnChange(Value: TNotifyEvent);\r\n procedure ControlSetOnClick(Value: TNotifyEvent);\r\n procedure ControlSetHint(const Value: string);\r\n\r\n procedure ControlSetValue(Value: Variant);\r\n function ControlGetValue: Variant;\r\n procedure ControlSetAnchors(Value: TAnchors);\r\n\r\n procedure ControlSetCxProperties(Value: TCxDynControlWrapper);\r\n\r\n // IJvDynControlFileName\r\n procedure ControlSetInitialDir(const Value: string);\r\n procedure ControlSetDefaultExt(const Value: string);\r\n procedure ControlSetDialogTitle(const Value: string);\r\n procedure ControlSetDialogOptions(Value: TOpenOptions);\r\n procedure ControlSetFilter(const Value: string);\r\n procedure ControlSetFilterIndex(Value: Integer);\r\n procedure ControlSetDialogKind(Value: TJvDynControlFileNameDialogKind);\r\n end;\r\n\r\n TJvDynControlCxDirectoryEdit = class(TcxButtonEdit, IUnknown, IJvDynControl,\r\n IJvDynControlData, IJvDynControlDevExpCx, IJvDynControlDirectory, IJvDynControlReadOnly)\r\n private\r\n FInitialDir: string;\r\n FDialogOptions: TSelectDirOpts;\r\n FDialogTitle: string;\r\n public\r\n procedure DefaultOnButtonClick(Sender: TObject; AButtonIndex: Integer);\r\n\r\n procedure ControlSetDefaultProperties;\r\n procedure ControlSetReadOnly(Value: Boolean);\r\n procedure ControlSetTabOrder(Value: Integer);\r\n\r\n procedure ControlSetOnEnter(Value: TNotifyEvent);\r\n procedure ControlSetOnExit(Value: TNotifyEvent);\r\n procedure ControlSetOnChange(Value: TNotifyEvent);\r\n procedure ControlSetOnClick(Value: TNotifyEvent);\r\n procedure ControlSetHint(const Value: string);\r\n\r\n procedure ControlSetValue(Value: Variant);\r\n function ControlGetValue: Variant;\r\n procedure ControlSetAnchors(Value: TAnchors);\r\n\r\n procedure ControlSetCxProperties(Value: TCxDynControlWrapper);\r\n\r\n // IJvDynControlDirectory\r\n procedure ControlSetInitialDir(const Value: string);\r\n procedure ControlSetDialogTitle(const Value: string);\r\n procedure ControlSetDialogOptions(Value: TSelectDirOpts);\r\n end;\r\n\r\n TJvDynControlCxDateTimeEdit = class(TcxDateEdit, IUnknown, IJvDynControl,\r\n IJvDynControlData, IJvDynControlDevExpCx, IJvDynControlDate, IJvDynControlReadOnly)\r\n public\r\n procedure ControlSetDefaultProperties;\r\n procedure ControlSetReadOnly(Value: Boolean);\r\n procedure ControlSetTabOrder(Value: Integer);\r\n\r\n procedure ControlSetOnEnter(Value: TNotifyEvent);\r\n procedure ControlSetOnExit(Value: TNotifyEvent);\r\n procedure ControlSetOnChange(Value: TNotifyEvent);\r\n procedure ControlSetOnClick(Value: TNotifyEvent);\r\n procedure ControlSetHint(const Value: string);\r\n\r\n procedure ControlSetValue(Value: Variant);\r\n function ControlGetValue: Variant;\r\n procedure ControlSetAnchors(Value: TAnchors);\r\n\r\n // IJvDynControlDate\r\n procedure ControlSetMinDate(Value: TDateTime);\r\n procedure ControlSetMaxDate(Value: TDateTime);\r\n procedure ControlSetFormat(const Value: string);\r\n\r\n procedure ControlSetCxProperties(Value: TCxDynControlWrapper);\r\n end;\r\n\r\n TJvDynControlCxDateEdit = class(TcxDateEdit, IUnknown, IJvDynControl,\r\n IJvDynControlData, IJvDynControlDevExpCx, IJvDynControlDate, IJvDynControlReadOnly)\r\n public\r\n procedure ControlSetDefaultProperties;\r\n procedure ControlSetReadOnly(Value: Boolean);\r\n procedure ControlSetTabOrder(Value: Integer);\r\n\r\n procedure ControlSetOnEnter(Value: TNotifyEvent);\r\n procedure ControlSetOnExit(Value: TNotifyEvent);\r\n procedure ControlSetOnChange(Value: TNotifyEvent);\r\n procedure ControlSetOnClick(Value: TNotifyEvent);\r\n procedure ControlSetHint(const Value: string);\r\n\r\n procedure ControlSetValue(Value: Variant);\r\n function ControlGetValue: Variant;\r\n procedure ControlSetAnchors(Value: TAnchors);\r\n\r\n // IJvDynControlDate\r\n procedure ControlSetMinDate(Value: TDateTime);\r\n procedure ControlSetMaxDate(Value: TDateTime);\r\n procedure ControlSetFormat(const Value: string);\r\n\r\n procedure ControlSetCxProperties(Value: TCxDynControlWrapper);\r\n end;\r\n\r\n TJvDynControlCxTimeEdit = class(TcxTimeEdit, IUnknown, IJvDynControl,\r\n IJvDynControlData, IJvDynControlDevExpCx, IJvDynControlTime, IJvDynControlReadOnly)\r\n public\r\n procedure ControlSetDefaultProperties;\r\n procedure ControlSetReadOnly(Value: Boolean);\r\n procedure ControlSetTabOrder(Value: Integer);\r\n\r\n procedure ControlSetOnEnter(Value: TNotifyEvent);\r\n procedure ControlSetOnExit(Value: TNotifyEvent);\r\n procedure ControlSetOnChange(Value: TNotifyEvent);\r\n procedure ControlSetOnClick(Value: TNotifyEvent);\r\n procedure ControlSetHint(const Value: string);\r\n\r\n procedure ControlSetValue(Value: Variant);\r\n function ControlGetValue: Variant;\r\n procedure ControlSetAnchors(Value: TAnchors);\r\n\r\n procedure ControlSetCxProperties(Value: TCxDynControlWrapper);\r\n\r\n procedure ControlSetFormat(const Value: string);\r\n end;\r\n\r\n TJvDynControlCxCheckBox = class(TcxCheckBox, IUnknown, IJvDynControl,\r\n IJvDynControlCaption, IJvDynControlData, IJvDynControlDevExpCx, IJvDynControlReadOnly,\r\n IJvDynControlCheckBox, IJvDynControlFont)\r\n public\r\n function ControlGetCaption: string;\r\n procedure ControlSetDefaultProperties;\r\n procedure ControlSetReadOnly(Value: Boolean);\r\n procedure ControlSetCaption(const Value: string);\r\n procedure ControlSetTabOrder(Value: Integer);\r\n\r\n procedure ControlSetOnEnter(Value: TNotifyEvent);\r\n procedure ControlSetOnExit(Value: TNotifyEvent);\r\n procedure ControlSetOnChange(Value: TNotifyEvent);\r\n procedure ControlSetOnClick(Value: TNotifyEvent);\r\n procedure ControlSetHint(const Value: string);\r\n\r\n procedure ControlSetValue(Value: Variant);\r\n function ControlGetValue: Variant;\r\n procedure ControlSetAnchors(Value: TAnchors);\r\n\r\n //IJvDynControlCheckBox\r\n procedure ControlSetAllowGrayed(Value: Boolean);\r\n procedure ControlSetState(Value: TCheckBoxState);\r\n function ControlGetState: TCheckBoxState;\r\n\r\n procedure ControlSetCxProperties(Value: TCxDynControlWrapper);\r\n\r\n //IJvDynControlFont\r\n procedure ControlSetFont(Value: TFont);\r\n function ControlGetFont: TFont;\r\n end;\r\n\r\n TJvDynControlCxMemo = class(TcxMemo, IUnknown, IJvDynControl, IJvDynControlData,\r\n IJvDynControlItems, IJvDynControlMemo, IJvDynControlDevExpCx, IJvDynControlReadOnly,\r\n IJvDynControlAlignment, IJvDynControlFont)\r\n public\r\n //IJvDynControlFont\r\n procedure ControlSetDefaultProperties;\r\n procedure ControlSetReadOnly(Value: Boolean);\r\n procedure ControlSetTabOrder(Value: Integer);\r\n\r\n procedure ControlSetOnEnter(Value: TNotifyEvent);\r\n procedure ControlSetOnExit(Value: TNotifyEvent);\r\n procedure ControlSetOnChange(Value: TNotifyEvent);\r\n procedure ControlSetOnClick(Value: TNotifyEvent);\r\n procedure ControlSetHint(const Value: string);\r\n\r\n procedure ControlSetValue(Value: Variant);\r\n function ControlGetValue: Variant;\r\n\r\n procedure ControlSetSorted(Value: Boolean);\r\n procedure ControlSetItems(Value: TStrings);\r\n function ControlGetItems: TStrings;\r\n procedure ControlSetAnchors(Value: TAnchors);\r\n\r\n procedure ControlSetWantTabs(Value: Boolean);\r\n procedure ControlSetWantReturns(Value: Boolean);\r\n procedure ControlSetWordWrap(Value: Boolean);\r\n procedure ControlSetScrollBars(Value: TScrollStyle);\r\n\r\n procedure ControlSetCxProperties(Value: TCxDynControlWrapper);\r\n //IJvDynControlAlignment\r\n procedure ControlSetAlignment(Value: TAlignment);\r\n //IJvDynControlFont\r\n function ControlGetFont: TFont;\r\n procedure ControlSetFont(Value: TFont);\r\n end;\r\n\r\n TJvDynControlCxRichEdit = class(TcxRichEdit, IUnknown, IJvDynControl, IJvDynControlData,\r\n IJvDynControlItems, IJvDynControlMemo, IJvDynControlDevExpCx, IJvDynControlReadOnly, IJvDynControlFont)\r\n public\r\n procedure ControlSetDefaultProperties;\r\n procedure ControlSetReadOnly(Value: Boolean);\r\n procedure ControlSetTabOrder(Value: Integer);\r\n\r\n procedure ControlSetOnEnter(Value: TNotifyEvent);\r\n procedure ControlSetOnExit(Value: TNotifyEvent);\r\n procedure ControlSetOnChange(Value: TNotifyEvent);\r\n procedure ControlSetOnClick(Value: TNotifyEvent);\r\n procedure ControlSetHint(const Value: string);\r\n\r\n procedure ControlSetValue(Value: Variant);\r\n function ControlGetValue: Variant;\r\n\r\n procedure ControlSetSorted(Value: Boolean);\r\n procedure ControlSetItems(Value: TStrings);\r\n function ControlGetItems: TStrings;\r\n procedure ControlSetAnchors(Value: TAnchors);\r\n\r\n procedure ControlSetWantTabs(Value: Boolean);\r\n procedure ControlSetWantReturns(Value: Boolean);\r\n procedure ControlSetWordWrap(Value: Boolean);\r\n procedure ControlSetScrollBars(Value: TScrollStyle);\r\n\r\n procedure ControlSetCxProperties(Value: TCxDynControlWrapper);\r\n\r\n //IJvDynControlFont\r\n function ControlGetFont: TFont;\r\n procedure ControlSetFont(Value: TFont);\r\n end;\r\n\r\n TJvDynControlCxRadioGroup = class(TcxRadioGroup, IUnknown, IJvDynControl,\r\n IJvDynControlCaption, IJvDynControlData, IJvDynControlItems, IJvDynControlDevExpCx,\r\n IJvDynControlRadioGroup, IJvDynControlReadOnly)\r\n public\r\n function ControlGetCaption: string;\r\n procedure ControlSetDefaultProperties;\r\n procedure ControlSetReadOnly(Value: Boolean);\r\n procedure ControlSetCaption(const Value: string);\r\n procedure ControlSetTabOrder(Value: Integer);\r\n\r\n procedure ControlSetOnEnter(Value: TNotifyEvent);\r\n procedure ControlSetOnExit(Value: TNotifyEvent);\r\n procedure ControlSetOnChange(Value: TNotifyEvent);\r\n procedure ControlSetOnClick(Value: TNotifyEvent);\r\n procedure ControlSetHint(const Value: string);\r\n\r\n procedure ControlSetValue(Value: Variant);\r\n function ControlGetValue: Variant;\r\n\r\n procedure ControlSetSorted(Value: Boolean);\r\n procedure ControlSetItems(Value: TStrings);\r\n function ControlGetItems: TStrings;\r\n procedure ControlSetAnchors(Value: TAnchors);\r\n\r\n procedure ControlSetCxProperties(Value: TCxDynControlWrapper);\r\n\r\n procedure ControlSetColumns(Value: Integer);\r\n end;\r\n\r\n TJvDynControlCxListBox = class(TcxListBox, IUnknown, IJvDynControl, IJvDynControlData,\r\n IJvDynControlItems, IJvDynControlItemIndex, IJvDynControlDblClick, IJvDynControlDevExpCx, IJvDynControlReadOnly,\r\n IJvDynControlKey, IJvDynControlMouse)\r\n public\r\n function ControlGetItemIndex: Integer;\r\n procedure ControlSetDefaultProperties;\r\n procedure ControlSetReadOnly(Value: Boolean);\r\n procedure ControlSetTabOrder(Value: Integer);\r\n\r\n procedure ControlSetOnEnter(Value: TNotifyEvent);\r\n procedure ControlSetOnExit(Value: TNotifyEvent);\r\n procedure ControlSetOnChange(Value: TNotifyEvent);\r\n procedure ControlSetOnClick(Value: TNotifyEvent);\r\n procedure ControlSetHint(const Value: string);\r\n\r\n procedure ControlSetValue(Value: Variant);\r\n function ControlGetValue: Variant;\r\n\r\n procedure ControlSetSorted(Value: Boolean);\r\n procedure ControlSetItems(Value: TStrings);\r\n function ControlGetItems: TStrings;\r\n procedure ControlSetAnchors(Value: TAnchors);\r\n\r\n procedure ControlSetOnDblClick(Value: TNotifyEvent);\r\n\r\n procedure ControlSetCxProperties(Value: TCxDynControlWrapper);\r\n procedure ControlSetItemIndex(const Value: Integer);\r\n\r\n function ControlGetOnKeyDown: TKeyEvent;\r\n function ControlGetOnKeyPress: TKeyPressEvent;\r\n function ControlGetOnKeyUp: TKeyEvent;\r\n procedure ControlSetOnKeyDown(const Value: TKeyEvent);\r\n procedure ControlSetOnKeyPress(const Value: TKeyPressEvent);\r\n procedure ControlSetOnKeyUp(const Value: TKeyEvent);\r\n\r\n function ControlGetOnMouseDown: TMouseEvent;\r\n function ControlGetOnMouseEnter: TNotifyEvent;\r\n function ControlGetOnMouseLeave: TNotifyEvent;\r\n function ControlGetOnMouseMove: TMouseMoveEvent;\r\n function ControlGetOnMouseUp: TMouseEvent;\r\n procedure ControlSetOnMouseDown(const Value: TMouseEvent);\r\n procedure ControlSetOnMouseEnter(const Value: TNotifyEvent);\r\n procedure ControlSetOnMouseLeave(const Value: TNotifyEvent);\r\n procedure ControlSetOnMouseMove(const Value: TMouseMoveEvent);\r\n procedure ControlSetOnMouseUp(const Value: TMouseEvent);\r\n end;\r\n\r\n TJvDynControlCxCheckListBox = class(TcxCheckListBox, IUnknown, IJvDynControl, IJvDynControlData,\r\n IJvDynControlItems, IJvDynControlDblClick, IJvDynControlDevExpCx, IJvDynControlReadOnly,\r\n IJvDynControlCheckListBox)\r\n private\r\n FIntItems: TStrings;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n procedure ControlSetDefaultProperties;\r\n procedure ControlSetReadOnly(Value: Boolean);\r\n procedure ControlSetTabOrder(Value: Integer);\r\n\r\n procedure ControlSetOnEnter(Value: TNotifyEvent);\r\n procedure ControlSetOnExit(Value: TNotifyEvent);\r\n procedure ControlSetOnChange(Value: TNotifyEvent);\r\n procedure ControlSetOnClick(Value: TNotifyEvent);\r\n procedure ControlSetHint(const Value: string);\r\n\r\n procedure ControlSetValue(Value: Variant);\r\n function ControlGetValue: Variant;\r\n\r\n procedure ControlSetSorted(Value: Boolean);\r\n procedure ControlSetItems(Value: TStrings);\r\n function ControlGetItems: TStrings;\r\n\r\n procedure ControlSetOnDblClick(Value: TNotifyEvent);\r\n\r\n procedure ControlSetCxProperties(Value: TCxDynControlWrapper);\r\n\r\n //IJvDynControlCheckListBox = interface\r\n procedure ControlSetAllowGrayed(Value: Boolean);\r\n procedure ControlSetChecked(Index: Integer; Value: Boolean);\r\n procedure ControlSetItemEnabled(Index: Integer; Value: Boolean);\r\n procedure ControlSetHeader(Index: Integer; Value: Boolean);\r\n procedure ControlSetState(Index: Integer; Value: TCheckBoxState);\r\n function ControlGetChecked(Index: Integer): Boolean;\r\n function ControlGetItemEnabled(Index: Integer): Boolean;\r\n function ControlGetHeader(Index: Integer): Boolean;\r\n function ControlGetState(Index: Integer): TCheckBoxState;\r\n procedure ControlSetAnchors(Value: TAnchors);\r\n end;\r\n\r\n TJvDynControlCxComboBox = class(TcxComboBox, IUnknown, IJvDynControl, IJvDynControlData,\r\n IJvDynControlItems, IJvDynControlDevExpCx, IJvDynControlComboBox, IJvDynControlReadOnly)\r\n public\r\n procedure ControlSetDefaultProperties;\r\n procedure ControlSetReadOnly(Value: Boolean);\r\n procedure ControlSetTabOrder(Value: Integer);\r\n\r\n procedure ControlSetOnEnter(Value: TNotifyEvent);\r\n procedure ControlSetOnExit(Value: TNotifyEvent);\r\n procedure ControlSetOnChange(Value: TNotifyEvent);\r\n procedure ControlSetOnClick(Value: TNotifyEvent);\r\n procedure ControlSetHint(const Value: string);\r\n\r\n procedure ControlSetValue(Value: Variant);\r\n function ControlGetValue: Variant;\r\n\r\n procedure ControlSetSorted(Value: Boolean);\r\n procedure ControlSetItems(Value: TStrings);\r\n function ControlGetItems: TStrings;\r\n procedure ControlSetAnchors(Value: TAnchors);\r\n\r\n procedure ControlSetCxProperties(Value: TCxDynControlWrapper);\r\n\r\n procedure ControlSetNewEntriesAllowed(Value: Boolean);\r\n end;\r\n\r\n TJvDynControlCxGroupBox = class(TcxGroupBox, IUnknown, IJvDynControl,\r\n IJvDynControlCaption, IJvDynControlColor)\r\n public\r\n function ControlGetCaption: string;\r\n procedure ControlSetAnchors(Value: TAnchors);\r\n procedure ControlSetDefaultProperties;\r\n procedure ControlSetCaption(const Value: string);\r\n procedure ControlSetTabOrder(Value: Integer);\r\n\r\n procedure ControlSetOnEnter(Value: TNotifyEvent);\r\n procedure ControlSetOnExit(Value: TNotifyEvent);\r\n procedure ControlSetOnClick(Value: TNotifyEvent);\r\n procedure ControlSetHint(const Value: string);\r\n\r\n // IJvDynControlColor\r\n procedure ControlSetColor(Value: TColor);\r\n procedure ControlSetParentColor(Value: Boolean);\r\n end;\r\n\r\n TJvDynControlCxPanel = class(TcxGroupBox, IUnknown, IJvDynControl, IJvDynControlPanel,\r\n IJvDynControlAlign, IJvDynControlAutoSize, IJvDynControlBevelBorder, IJvDynControlColor,\r\n IJvDynControlCaption, IJvDynControlAlignment)\r\n public\r\n function ControlGetCaption: string;\r\n procedure ControlSetDefaultProperties;\r\n procedure ControlSetCaption(const Value: string);\r\n procedure ControlSetTabOrder(Value: Integer);\r\n\r\n procedure ControlSetOnEnter(Value: TNotifyEvent);\r\n procedure ControlSetOnExit(Value: TNotifyEvent);\r\n procedure ControlSetOnClick(Value: TNotifyEvent);\r\n procedure ControlSetHint(const Value: string);\r\n procedure ControlSetAnchors(Value: TAnchors);\r\n\r\n procedure ControlSetBorder(ABevelInner: TPanelBevel; ABevelOuter: TPanelBevel; ABevelWidth: Integer; ABorderStyle: TBorderStyle; ABorderWidth: Integer);\r\n\r\n // IJvDynControlAlign\r\n procedure ControlSetAlign(Value: TAlign);\r\n\r\n // IJvDynControlAutoSize\r\n procedure ControlSetAutoSize(Value: Boolean);\r\n\r\n // IJvDynControlBevelBorder\r\n procedure ControlSetBevelInner(Value: TBevelCut);\r\n procedure ControlSetBevelKind(Value: TBevelKind);\r\n procedure ControlSetBevelOuter(Value: TBevelCut);\r\n procedure ControlSetBorderStyle(Value: TBorderStyle);\r\n procedure ControlSetBorderWidth(Value: Integer);\r\n // IJvDynControlColor\r\n procedure ControlSetColor(Value: TColor);\r\n procedure ControlSetParentColor(Value: Boolean);\r\n //IJvDynControlAlignment\r\n procedure ControlSetAlignment(Value: TAlignment);\r\n end;\r\n\r\n TJvDynControlCxImage = class(TcxImage, IUnknown, IJvDynControl,\r\n IJvDynControlImage, IJvDynControlDevExpCx)\r\n public\r\n procedure ControlSetDefaultProperties;\r\n procedure ControlSetTabOrder(Value: Integer);\r\n\r\n procedure ControlSetOnEnter(Value: TNotifyEvent);\r\n procedure ControlSetOnExit(Value: TNotifyEvent);\r\n procedure ControlSetOnClick(Value: TNotifyEvent);\r\n procedure ControlSetHint(const Value: string);\r\n\r\n procedure ControlSetAutoSize(Value: Boolean);\r\n procedure ControlSetIncrementalDisplay(Value: Boolean);\r\n procedure ControlSetCenter(Value: Boolean);\r\n procedure ControlSetProportional(Value: Boolean);\r\n procedure ControlSetStretch(Value: Boolean);\r\n procedure ControlSetTransparent(Value: Boolean);\r\n procedure ControlSetPicture(Value: TPicture);\r\n procedure ControlSetGraphic(Value: TGraphic);\r\n function ControlGetPicture: TPicture;\r\n procedure ControlSetAnchors(Value: TAnchors);\r\n\r\n procedure ControlSetCxProperties(Value: TCxDynControlWrapper);\r\n end;\r\n\r\n // (rom) TScrollBox or TcxScrollBox?\r\n TJvDynControlCxScrollBox = class(TScrollBox, IJvDynControl, IJvDynControlCaption)\r\n public\r\n function ControlGetCaption: string;\r\n procedure ControlSetAnchors(Value: TAnchors);\r\n procedure ControlSetDefaultProperties;\r\n procedure ControlSetCaption(const Value: string);\r\n procedure ControlSetTabOrder(Value: Integer);\r\n\r\n procedure ControlSetOnEnter(Value: TNotifyEvent);\r\n procedure ControlSetOnExit(Value: TNotifyEvent);\r\n procedure ControlSetOnClick(Value: TNotifyEvent);\r\n procedure ControlSetHint(const Value: string);\r\n end;\r\n\r\n TJvDynControlCxLabel = class(TcxLabel, IUnknown, IJvDynControl, IJvDynControlLabel,\r\n IJvDynControlCaption, IJvDynControlDevExpCx, IJvDynControlAlign,\r\n IJvDynControlAutoSize, IJvDynControlColor,\r\n IJvDynControlAlignment, IJvDynControlFont)\r\n public\r\n function ControlGetCaption: string;\r\n procedure ControlSetAnchors(Value: TAnchors);\r\n procedure ControlSetDefaultProperties;\r\n procedure ControlSetCaption(const Value: string);\r\n procedure ControlSetTabOrder(Value: Integer);\r\n\r\n procedure ControlSetOnEnter(Value: TNotifyEvent);\r\n procedure ControlSetOnExit(Value: TNotifyEvent);\r\n procedure ControlSetOnClick(Value: TNotifyEvent);\r\n procedure ControlSetHint(const Value: string);\r\n\r\n procedure ControlSetFocusControl(Value: TWinControl);\r\n procedure ControlSetWordWrap(Value: Boolean);\r\n\r\n procedure ControlSetCxProperties(Value: TCxDynControlWrapper);\r\n\r\n // IJvDynControlAlign\r\n procedure ControlSetAlign(Value: TAlign);\r\n\r\n // IJvDynControlAutoSize\r\n procedure ControlSetAutoSize(Value: Boolean);\r\n\r\n // IJvDynControlColor\r\n procedure ControlSetColor(Value: TColor);\r\n procedure ControlSetParentColor(Value: Boolean);\r\n //IJvDynControlAlignment\r\n procedure ControlSetAlignment(Value: TAlignment);\r\n\r\n //IJvDynControlFont\r\n procedure ControlSetFont(Value: TFont);\r\n function ControlGetFont: TFont;\r\n end;\r\n\r\n // (rom) Warning! TStaticText and TLabel are very different.\r\n TJvDynControlCxStaticText = class(TcxLabel, IUnknown, IJvDynControl, IJvDynControlDevExpCx,\r\n IJvDynControlCaption, IJvDynControlAlign, IJvDynControlAutoSize, IJvDynControlColor,\r\n IJvDynControlAlignment, IJvDynControlFont)\r\n public\r\n function ControlGetCaption: string;\r\n procedure ControlSetAnchors(Value: TAnchors);\r\n procedure ControlSetDefaultProperties;\r\n procedure ControlSetCaption(const Value: string);\r\n procedure ControlSetTabOrder(Value: Integer);\r\n\r\n procedure ControlSetOnEnter(Value: TNotifyEvent);\r\n procedure ControlSetOnExit(Value: TNotifyEvent);\r\n procedure ControlSetOnClick(Value: TNotifyEvent);\r\n procedure ControlSetHint(const Value: string);\r\n\r\n procedure ControlSetCxProperties(Value: TCxDynControlWrapper);\r\n\r\n // IJvDynControlAlign\r\n procedure ControlSetAlign(Value: TAlign);\r\n\r\n // IJvDynControlAutoSize\r\n procedure ControlSetAutoSize(Value: Boolean);\r\n // IJvDynControlColor\r\n procedure ControlSetColor(Value: TColor);\r\n procedure ControlSetParentColor(Value: Boolean);\r\n //IJvDynControlAlignment\r\n procedure ControlSetAlignment(Value: TAlignment);\r\n //IJvDynControlFont\r\n procedure ControlSetFont(Value: TFont);\r\n function ControlGetFont: TFont;\r\n end;\r\n\r\n TJvDynControlCxButton = class(TcxButton, IUnknown, IJvDynControl, IJvDynControlButton,\r\n IJvDynControlCaption, IJvDynControlDevExpCx, IJvDynControlAction)\r\n public\r\n function ControlGetCaption: string;\r\n procedure ControlSetDefaultProperties;\r\n procedure ControlSetCaption(const Value: string);\r\n procedure ControlSetTabOrder(Value: Integer);\r\n\r\n procedure ControlSetOnEnter(Value: TNotifyEvent);\r\n procedure ControlSetOnExit(Value: TNotifyEvent);\r\n procedure ControlSetOnClick(Value: TNotifyEvent);\r\n procedure ControlSetHint(const Value: string);\r\n\r\n procedure ControlSetGlyph(Value: TBitmap);\r\n procedure ControlSetNumGlyphs(Value: Integer);\r\n procedure ControlSetLayout(Value: TButtonLayout);\r\n procedure ControlSetDefault(Value: Boolean);\r\n procedure ControlSetCancel(Value: Boolean);\r\n\r\n // IJvDynControlAction\r\n procedure ControlSetAction(Value: TCustomAction);\r\n procedure ControlSetAnchors(Value: TAnchors);\r\n\r\n procedure ControlSetCxProperties(Value: TCxDynControlWrapper);\r\n end;\r\n\r\n TJvDynControlCxRadioButton = class(TCxRadioButton, IUnknown,\r\n IJvDynControl, IJvDynControlCaption, IJvDynControlData, IJvDynControlDevExpCx)\r\n public\r\n function ControlGetCaption: string;\r\n procedure ControlSetDefaultProperties;\r\n procedure ControlSetCaption(const Value: string);\r\n procedure ControlSetTabOrder(Value: Integer);\r\n\r\n procedure ControlSetOnEnter(Value: TNotifyEvent);\r\n procedure ControlSetOnExit(Value: TNotifyEvent);\r\n procedure ControlSetOnClick(Value: TNotifyEvent);\r\n procedure ControlSetHint(const Value: string);\r\n\r\n // IJvDynControlData\r\n procedure ControlSetOnChange(Value: TNotifyEvent);\r\n procedure ControlSetValue(Value: Variant);\r\n function ControlGetValue: Variant;\r\n procedure ControlSetAnchors(Value: TAnchors);\r\n\r\n // IJvDynControlDevExpCx\r\n procedure ControlSetCxProperties(Value: TCxDynControlWrapper);\r\n end;\r\n\r\n TJvDynControlCxTreeView = class(TcxTreeView, IUnknown,\r\n IJvDynControl, IJvDynControlTreeView,\r\n IJvDynControlDevExpCx, IJvDynControlReadOnly, IJvDynControlDblClick,\r\n IJvDynControlMouse)\r\n public\r\n procedure ControlSetDefaultProperties;\r\n procedure ControlSetTabOrder(Value: Integer);\r\n\r\n procedure ControlSetOnEnter(Value: TNotifyEvent);\r\n procedure ControlSetOnExit(Value: TNotifyEvent);\r\n procedure ControlSetOnClick(Value: TNotifyEvent);\r\n procedure ControlSetHint(const Value: string);\r\n\r\n // IJvDynControlReadOnly\r\n procedure ControlSetReadOnly(Value: Boolean);\r\n\r\n // IJvDynControlTreeView\r\n procedure ControlSetAutoExpand(Value: Boolean);\r\n procedure ControlSetHotTrack(Value: Boolean);\r\n procedure ControlSetShowHint(Value: Boolean);\r\n procedure ControlSetShowLines(Value: Boolean);\r\n procedure ControlSetShowRoot(Value: Boolean);\r\n procedure ControlSetToolTips(Value: Boolean);\r\n procedure ControlSetItems(Value: TTreeNodes);\r\n function ControlGetItems: TTreeNodes;\r\n procedure ControlSetImages(Value: TCustomImageList);\r\n procedure ControlSetStateImages(Value: TCustomImageList);\r\n procedure ControlSetAnchors(Value: TAnchors);\r\n procedure ControlSetOnChange(Value: TTVChangedEvent);\r\n procedure ControlSetSortType(Value: TSortType);\r\n procedure ControlSortItems;\r\n function ControlGetSelected: TTreeNode;\r\n procedure ControlSetSelected(const Value: TTreeNode);\r\n procedure ControlSetOnChanging(Value: TTVChangingEvent);\r\n\r\n //IJvDynControlDblClick\r\n procedure ControlSetOnDblClick(Value: TNotifyEvent);\r\n\r\n // IJvDynControlDevExpCx\r\n procedure ControlSetCxProperties(Value: TCxDynControlWrapper);\r\n\r\n function ControlGetOnMouseDown: TMouseEvent;\r\n function ControlGetOnMouseEnter: TNotifyEvent;\r\n function ControlGetOnMouseLeave: TNotifyEvent;\r\n function ControlGetOnMouseMove: TMouseMoveEvent;\r\n function ControlGetOnMouseUp: TMouseEvent;\r\n procedure ControlSetOnMouseDown(const Value: TMouseEvent);\r\n procedure ControlSetOnMouseEnter(const Value: TNotifyEvent);\r\n procedure ControlSetOnMouseLeave(const Value: TNotifyEvent);\r\n procedure ControlSetOnMouseMove(const Value: TMouseMoveEvent);\r\n procedure ControlSetOnMouseUp(const Value: TMouseEvent);\r\n end;\r\n\r\n TJvDynControlCxProgressBar = class(TcxProgressBar, IUnknown, IJvDynControl,\r\n IJvDynControlProgressBar, IJvDynControlAlign, IJvDynControlDevExpCx)\r\n public\r\n procedure ControlSetAlign(Value: TAlign);\r\n procedure ControlSetAnchors(Value: TAnchors);\r\n procedure ControlSetCaption(const Value: string);\r\n // IJvDynControlDevExpCx\r\n procedure ControlSetCxProperties(Value: TCxDynControlWrapper);\r\n procedure ControlSetDefaultProperties;\r\n procedure ControlSetHint(const Value: string);\r\n //IJvDynControlProgressBar\r\n procedure ControlSetMarquee(Value: Boolean);\r\n procedure ControlSetMax(Value: Integer);\r\n procedure ControlSetMin(Value: Integer);\r\n procedure ControlSetOnClick(Value: TNotifyEvent);\r\n procedure ControlSetOnEnter(Value: TNotifyEvent);\r\n procedure ControlSetOnExit(Value: TNotifyEvent);\r\n procedure ControlSetOrientation(Value: TProgressBarOrientation);\r\n procedure ControlSetPosition(Value: Integer);\r\n procedure ControlSetSmooth(Value: Boolean);\r\n procedure ControlSetStep(Value: Integer);\r\n procedure ControlSetTabOrder(Value: Integer);\r\n end;\r\n\r\n\r\n TJvDynControlCxTabControl = class(TcxTabControl, IUnknown, IJvDynControl,\r\n IJvDynControlTabControl, IJvDynControlDevExpCx)\r\n public\r\n procedure ControlSetDefaultProperties;\r\n procedure ControlSetTabOrder(Value: Integer);\r\n\r\n procedure ControlSetOnEnter(Value: TNotifyEvent);\r\n procedure ControlSetOnExit(Value: TNotifyEvent);\r\n procedure ControlSetOnClick(Value: TNotifyEvent);\r\n procedure ControlSetHint(const Value: string);\r\n procedure ControlSetAnchors(Value: TAnchors);\r\n\r\n //IJvDynControlTabControl\r\n procedure ControlCreateTab(const AName: string);\r\n procedure ControlSetOnChangeTab(OnChangeEvent: TNotifyEvent);\r\n procedure ControlSetOnChangingTab(OnChangingEvent: TTabChangingEvent);\r\n procedure ControlSetTabIndex(Index: Integer);\r\n function ControlGetTabIndex: Integer;\r\n procedure ControlSetMultiLine(Value: Boolean);\r\n procedure ControlSetScrollOpposite(Value: Boolean);\r\n procedure ControlSetHotTrack(Value: Boolean);\r\n procedure ControlSetRaggedRight(Value: Boolean);\r\n // IJvDynControlDevExpCx\r\n procedure ControlSetCxProperties(Value: TCxDynControlWrapper);\r\n end;\r\n\r\n TJvDynControlCxPageControl = class(TcxPageControl, IUnknown,\r\n IJvDynControl, IJvDynControlTabControl, IJvDynControlPageControl, IJvDynControlDevExpCx)\r\n public\r\n procedure ControlSetDefaultProperties;\r\n procedure ControlSetTabOrder(Value: Integer);\r\n\r\n procedure ControlSetOnEnter(Value: TNotifyEvent);\r\n procedure ControlSetOnExit(Value: TNotifyEvent);\r\n procedure ControlSetOnClick(Value: TNotifyEvent);\r\n procedure ControlSetHint(const Value: string);\r\n procedure ControlSetAnchors(Value: TAnchors);\r\n\r\n //IJvDynControlTabControl\r\n procedure ControlCreateTab(const AName: string);\r\n procedure ControlSetOnChangeTab(OnChangeEvent: TNotifyEvent);\r\n procedure ControlSetOnChangingTab(OnChangingEvent: TTabChangingEvent);\r\n procedure ControlSetTabIndex(Index: Integer);\r\n function ControlGetTabIndex: Integer;\r\n procedure ControlSetMultiLine(Value: Boolean);\r\n procedure ControlSetScrollOpposite(Value: Boolean);\r\n procedure ControlSetHotTrack(Value: Boolean);\r\n procedure ControlSetRaggedRight(Value: Boolean);\r\n\r\n //IJvDynControlPageControl\r\n function ControlGetPage(const PageName: string): TWinControl;\r\n // IJvDynControlDevExpCx\r\n procedure ControlSetCxProperties(Value: TCxDynControlWrapper);\r\n end;\r\n\r\n {$IFDEF USE_3RDPARTY_DEVEXPRESS_CXVERTICALGRID}\r\n TJvDynControlCxRTTIInspectorControl = class(TcxRTTIInspector, IUnknown,\r\n IJvDynControl, IJvDynControlRTTIInspectorControl, IJvDynControlDevExpCx)\r\n private\r\n fControlOnPropertyChange: TJvDynControlInspectorControlOnPropertyChangeEvent;\r\n fOnDisplayProperty: TJvDynControlInspectorControlOnDisplayPropertyEvent;\r\n fOnTranslatePropertyName:\r\n TJvDynControlInspectorControlOnTranslatePropertyNameEvent;\r\n OldPropertyName: string;\r\n procedure InspectorOnFilterProperty(Sender: TObject; const PropertyName:\r\n string; var Accept: Boolean);\r\n procedure InspectorOnItemChanged(Sender: TObject; AOldRow: TcxCustomRow;\r\n AOldCellIndex: Integer);\r\n procedure ReplaceOnDrawRowHeader(Sender: TObject; ACanvas: TcxCanvas; APainter:\r\n TcxvgPainter; AHeaderViewInfo: TcxCustomRowHeaderInfo; var Done: Boolean);\r\n protected\r\n //IJvDynControlRTTIInspectorControl\r\n function ControlGetOnDisplayProperty:\r\n TJvDynControlInspectorControlOnDisplayPropertyEvent;\r\n function ControlGetOnTranslatePropertyName:\r\n TJvDynControlInspectorControlOnTranslatePropertyNameEvent;\r\n procedure ControlSetOnDisplayProperty(const Value:\r\n TJvDynControlInspectorControlOnDisplayPropertyEvent); overload;\r\n procedure ControlSetOnTranslatePropertyName(const Value:\r\n TJvDynControlInspectorControlOnTranslatePropertyNameEvent);\r\n function GetControlDividerWidth: Integer;\r\n procedure SetControlDividerWidth(const Value: Integer);\r\n public\r\n function ControlGetCurrentPropertyName: string;\r\n procedure ControlSetDefaultProperties;\r\n procedure ControlSetTabOrder(Value: Integer);\r\n\r\n procedure ControlSetOnEnter(Value: TNotifyEvent);\r\n procedure ControlSetOnExit(Value: TNotifyEvent);\r\n procedure ControlSetOnClick(Value: TNotifyEvent);\r\n procedure ControlSetHint(const Value: string);\r\n procedure ControlSetAnchors(Value: TAnchors);\r\n\r\n //IJvDynControlRTTIInspectorControl\r\n function ControlGetInspectedObject: TObject;\r\n function ControlGetVisibleItemsCount: Integer;\r\n function ControlIsPropertySupported(const aPropertyName : string): Boolean;\r\n procedure ControlSaveEditorValues;\r\n procedure ControlSetInspectedObject(const Value: TObject);\r\n\r\n // IJvDynControlDevExpCx\r\n procedure ControlSetCxProperties(Value: TCxDynControlWrapper);\r\n function GetControlOnPropertyChange:\r\n TJvDynControlInspectorControlOnPropertyChangeEvent;\r\n procedure SetControlOnPropertyChange(const Value:\r\n TJvDynControlInspectorControlOnPropertyChangeEvent);\r\n end;\r\n\r\n {$ENDIF}\r\n\r\n TJvDynControlCxColorComboBox = class(TcxColorComboBox, IUnknown, IJvDynControl,\r\n IJvDynControlColorComboBoxControl, IJvDynControlDevExpCx)\r\n public\r\n procedure ControlSetDefaultProperties;\r\n procedure ControlSetTabOrder(Value: Integer);\r\n\r\n procedure ControlSetOnEnter(Value: TNotifyEvent);\r\n procedure ControlSetOnExit(Value: TNotifyEvent);\r\n procedure ControlSetOnChange(Value: TNotifyEvent);\r\n procedure ControlSetOnClick(Value: TNotifyEvent);\r\n procedure ControlSetHint(const Value: string);\r\n procedure ControlSetAnchors(Value: TAnchors);\r\n\r\n procedure ControlSetValue(Value: Variant);\r\n function ControlGetValue: Variant;\r\n\r\n // IJvDynControlDevExpCx\r\n procedure ControlSetCxProperties(Value: TCxDynControlWrapper);\r\n\r\n //IJvDynControlColorComboBoxControl\r\n function ControlGetColorName(AColor: TColor): string;\r\n function ControlGetSelectedColor: TColor;\r\n procedure ControlSetSelectedColor(const Value: TColor);\r\n function GetControlDefaultColor: TColor; stdcall;\r\n procedure SetControlDefaultColor(const Value: TColor); stdcall;\r\n end;\r\n\r\n TJvDynControlEngineDevExpCx = class(TJvDynControlEngine)\r\n private\r\n FCxProperties: TCxDynControlWrapper;\r\n protected\r\n procedure SetcxProperties(Value: TCxDynControlWrapper);\r\n procedure RegisterControls; override;\r\n public\r\n constructor Create; override;\r\n destructor Destroy; override;\r\n function CreateControlClass(AControlClass: TControlClass; AOwner: TComponent; AParentControl: TWinControl; AControlName: string): TControl; override;\r\n published\r\n property CxProperties: TCxDynControlWrapper read FCxProperties write FCxProperties;\r\n end;\r\n\r\n TJvDynControlCxCheckComboBox = class(TcxCheckComboBox, IUnknown, IJvDynControl, IJvDynControlData, IJvDynControlItems,\r\n IJvDynControlDblClick, IJvDynControlDevExpCx, IJvDynControlReadOnly, IJvDynControlCheckComboBox)\r\n private\r\n FIntItems: TStrings;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n procedure ControlSetDefaultProperties;\r\n procedure ControlSetReadOnly(Value: Boolean);\r\n procedure ControlSetTabOrder(Value: Integer);\r\n\r\n procedure ControlSetOnEnter(Value: TNotifyEvent);\r\n procedure ControlSetOnExit(Value: TNotifyEvent);\r\n procedure ControlSetOnChange(Value: TNotifyEvent);\r\n procedure ControlSetOnClick(Value: TNotifyEvent);\r\n procedure ControlSetHint(const Value: string);\r\n\r\n procedure ControlSetValue(Value: Variant);\r\n function ControlGetValue: Variant;\r\n\r\n procedure ControlSetSorted(Value: Boolean);\r\n procedure ControlSetItems(Value: TStrings);\r\n function ControlGetItems: TStrings;\r\n\r\n procedure ControlSetOnDblClick(Value: TNotifyEvent);\r\n\r\n procedure ControlSetCxProperties(Value: TCxDynControlWrapper);\r\n\r\n function ControlGetDelimiter: string;\r\n procedure ControlSetAnchors(Value: TAnchors);\r\n procedure ControlSetDelimiter(Value: string);\r\n end;\r\n\r\n\r\n\r\nprocedure SetDynControlEngineDevExpCxDefault;\r\nfunction DynControlEngineDevExpCx: TJvDynControlEngineDevExpCx;\r\n\r\n{$ENDIF USE_3RDPARTY_DEVEXPRESS_CXEDITOR}\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvDynControlEngineDevExpCx.pas $';\r\n Revision: '$Revision: 13075 $';\r\n Date: '$Date: 2011-06-28 00:56:21 +0200 (mar. 28 juin 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\n{$IFDEF USE_3RDPARTY_DEVEXPRESS_CXEDITOR}\r\n\r\nuses\r\n SysUtils, ExtDlgs, Variants,\r\n {$IFNDEF USE_3RDPARTY_DEVEXPRESS_CXVERTICALGRID}\r\n JvDynControlEngineJVCL,\r\n {$ENDIF}\r\n cxTextEdit, cxControls,\r\n JvDynControlEngineVCL,\r\n JvJCLUtils, JvBrowseFolder, JvDynControlEngineTools,\r\n cxLookAndFeelPainters, TypInfo;\r\n\r\nvar\r\n IntDynControlEngineDevExpCx: TJvDynControlEngineDevExpCx = nil;\r\n\r\n//=== { TCxDynControlWrapper } ===============================================\r\n\r\nconstructor TCxDynControlWrapper.Create;\r\nbegin\r\n inherited Create;\r\n FLookAndFeel := TcxLookAndFeel.Create(nil);\r\n FStyleController := TcxEditStyleController.Create(nil);\r\nend;\r\n\r\ndestructor TCxDynControlWrapper.Destroy;\r\nbegin\r\n FreeAndNil(FStyleController);\r\n FreeAndNil(FLookAndFeel);\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TCxDynControlWrapper.SetLookAndFeel(Value: TcxLookAndFeel);\r\nbegin\r\n FLookAndFeel.Assign(Value);\r\nend;\r\n\r\nprocedure TCxDynControlWrapper.SetStyleController(Value: TcxEditStyleController);\r\nbegin\r\n FStyleController := Value;\r\nend;\r\n\r\n//=== { TJvDynControlCxMaskEdit } ============================================\r\n\r\nprocedure TJvDynControlCxMaskEdit.ControlSetDefaultProperties;\r\nbegin\r\n Properties.MaskKind := emkStandard;\r\nend;\r\n\r\nprocedure TJvDynControlCxMaskEdit.ControlSetReadOnly(Value: Boolean);\r\nbegin\r\n Properties.ReadOnly := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxMaskEdit.ControlSetTabOrder(Value: Integer);\r\nbegin\r\n TabOrder := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxMaskEdit.ControlSetOnEnter(Value: TNotifyEvent);\r\nbegin\r\n OnEnter := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxMaskEdit.ControlSetOnExit(Value: TNotifyEvent);\r\nbegin\r\n OnExit := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxMaskEdit.ControlSetOnChange(Value: TNotifyEvent);\r\nbegin\r\n Properties.OnChange := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxMaskEdit.ControlSetOnClick(Value: TNotifyEvent);\r\nbegin\r\n\r\nend;\r\n\r\nprocedure TJvDynControlCxMaskEdit.ControlSetHint(const Value: string);\r\nbegin\r\n Hint := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxMaskEdit.ControlSetValue(Value: Variant);\r\nbegin\r\n Text := VarToStr(Value);\r\nend;\r\n\r\nfunction TJvDynControlCxMaskEdit.ControlGetValue: Variant;\r\nbegin\r\n Result := Text;\r\nend;\r\n\r\nprocedure TJvDynControlCxMaskEdit.ControlSetAnchors(Value: TAnchors);\r\nbegin\r\n Anchors := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxMaskEdit.ControlSetCxProperties(Value: TCxDynControlWrapper);\r\nbegin\r\n Style.LookAndFeel.Assign(Value.LookAndFeel);\r\n Style.StyleController := Value.StyleController;\r\nend;\r\n\r\nprocedure TJvDynControlCxMaskEdit.ControlSetPasswordChar(Value: Char);\r\nbegin\r\n if Value <> #0 then\r\n Properties.EchoMode := eemPassword\r\n else\r\n Properties.EchoMode := eemNormal;\r\nend;\r\n\r\nprocedure TJvDynControlCxMaskEdit.ControlSetEditMask(const Value: string);\r\nbegin\r\n Properties.EditMask := Value;\r\n Properties.MaskKind := emkStandard;\r\nend;\r\n\r\n//=== { TJvDynControlCxButtonEdit } ==========================================\r\n\r\nprocedure TJvDynControlCxButtonEdit.ControlSetDefaultProperties;\r\nbegin\r\n Properties.OnButtonClick := IntOnButtonClick;\r\n Properties.MaskKind := emkStandard;\r\nend;\r\n\r\nprocedure TJvDynControlCxButtonEdit.ControlSetReadOnly(Value: Boolean);\r\nbegin\r\n Properties.ReadOnly := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxButtonEdit.ControlSetTabOrder(Value: Integer);\r\nbegin\r\n TabOrder := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxButtonEdit.ControlSetOnEnter(Value: TNotifyEvent);\r\nbegin\r\n OnEnter := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxButtonEdit.ControlSetOnExit(Value: TNotifyEvent);\r\nbegin\r\n OnExit := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxButtonEdit.ControlSetOnChange(Value: TNotifyEvent);\r\nbegin\r\n Properties.OnChange := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxButtonEdit.ControlSetOnClick(Value: TNotifyEvent);\r\nbegin\r\n\r\nend;\r\n\r\nprocedure TJvDynControlCxButtonEdit.ControlSetHint(const Value: string);\r\nbegin\r\n Hint := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxButtonEdit.ControlSetValue(Value: Variant);\r\nbegin\r\n Text := VarToStr(Value);\r\nend;\r\n\r\nfunction TJvDynControlCxButtonEdit.ControlGetValue: Variant;\r\nbegin\r\n Result := Text;\r\nend;\r\n\r\nprocedure TJvDynControlCxButtonEdit.ControlSetAnchors(Value: TAnchors);\r\nbegin\r\n Anchors := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxButtonEdit.ControlSetCxProperties(Value: TCxDynControlWrapper);\r\nbegin\r\n Style.LookAndFeel.Assign(Value.LookAndFeel);\r\n Style.StyleController := Value.StyleController;\r\nend;\r\n\r\nprocedure TJvDynControlCxButtonEdit.ControlSetPasswordChar(Value: Char);\r\nbegin\r\n if Value <> #0 then\r\n Properties.EchoMode := eemPassword\r\n else\r\n Properties.EchoMode := eemNormal;\r\nend;\r\n\r\nprocedure TJvDynControlCxButtonEdit.ControlSetEditMask(const Value: string);\r\nbegin\r\n Properties.EditMask := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxButtonEdit.ControlSetOnButtonClick(Value: TNotifyEvent);\r\nbegin\r\n FIntOnButtonClick := Value;;\r\nend;\r\n\r\nprocedure TJvDynControlCxButtonEdit.ControlSetButtonCaption(const Value: string);\r\nbegin\r\n Properties.Buttons[0].DisplayName := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxButtonEdit.ControlSetGlyph(Value: TBitmap);\r\nbegin\r\n Properties.Buttons[0].Glyph.Assign(Value);\r\nend;\r\n\r\nprocedure TJvDynControlCxButtonEdit.ControlSetNumGlyphs(Value: Integer);\r\nbegin\r\nend;\r\n\r\nprocedure TJvDynControlCxButtonEdit.ControlSetLayout(Value: TButtonLayout);\r\nbegin\r\nend;\r\n\r\nprocedure TJvDynControlCxButtonEdit.ControlSetDefault(Value: Boolean);\r\nbegin\r\nend;\r\n\r\nprocedure TJvDynControlCxButtonEdit.ControlSetCancel(Value: Boolean);\r\nbegin\r\nend;\r\n\r\n\r\nprocedure TJvDynControlCxButtonEdit.IntOnButtonClick(Sender: TObject;\r\n AButtonIndex: Integer);\r\nbegin\r\n if Assigned(FIntOnButtonClick) then\r\n FIntOnButtonClick(Sender);\r\nend;\r\n\r\n//=== { TJvDynControlCxCalcEdit } ============================================\r\n\r\nprocedure TJvDynControlCxCalcEdit.ControlSetDefaultProperties;\r\nbegin\r\nend;\r\n\r\nprocedure TJvDynControlCxCalcEdit.ControlSetReadOnly(Value: Boolean);\r\nbegin\r\n Properties.ReadOnly := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxCalcEdit.ControlSetTabOrder(Value: Integer);\r\nbegin\r\n TabOrder := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxCalcEdit.ControlSetOnEnter(Value: TNotifyEvent);\r\nbegin\r\n OnEnter := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxCalcEdit.ControlSetOnExit(Value: TNotifyEvent);\r\nbegin\r\n OnExit := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxCalcEdit.ControlSetOnChange(Value: TNotifyEvent);\r\nbegin\r\n Properties.OnChange := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxCalcEdit.ControlSetOnClick(Value: TNotifyEvent);\r\nbegin\r\n\r\nend;\r\n\r\nprocedure TJvDynControlCxCalcEdit.ControlSetHint(const Value: string);\r\nbegin\r\n Hint := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxCalcEdit.ControlSetValue(Value: Variant);\r\nbegin\r\n Self.Value := Value;\r\nend;\r\n\r\nfunction TJvDynControlCxCalcEdit.ControlGetValue: Variant;\r\nbegin\r\n Result := Text;\r\nend;\r\n\r\nprocedure TJvDynControlCxCalcEdit.ControlSetAnchors(Value: TAnchors);\r\nbegin\r\n Anchors := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxCalcEdit.ControlSetCxProperties(Value: TCxDynControlWrapper);\r\nbegin\r\n Style.LookAndFeel.Assign(Value.LookAndFeel);\r\n Style.StyleController := Value.StyleController;\r\nend;\r\n\r\n//=== { TJvDynControlCxSpinEdit } ============================================\r\n\r\nprocedure TJvDynControlCxSpinEdit.ControlSetDefaultProperties;\r\nbegin\r\n Text := '0';\r\nend;\r\n\r\nprocedure TJvDynControlCxSpinEdit.ControlSetReadOnly(Value: Boolean);\r\nbegin\r\n Properties.ReadOnly := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxSpinEdit.ControlSetTabOrder(Value: Integer);\r\nbegin\r\n TabOrder := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxSpinEdit.ControlSetOnEnter(Value: TNotifyEvent);\r\nbegin\r\n OnEnter := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxSpinEdit.ControlSetOnExit(Value: TNotifyEvent);\r\nbegin\r\n OnExit := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxSpinEdit.ControlSetOnChange(Value: TNotifyEvent);\r\nbegin\r\n Properties.OnChange := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxSpinEdit.ControlSetOnClick(Value: TNotifyEvent);\r\nbegin\r\n\r\nend;\r\n\r\nprocedure TJvDynControlCxSpinEdit.ControlSetHint(const Value: string);\r\nbegin\r\n Hint := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxSpinEdit.ControlSetValue(Value: Variant);\r\nbegin\r\n Self.Value := Value;\r\nend;\r\n\r\nfunction TJvDynControlCxSpinEdit.ControlGetValue: Variant;\r\nbegin\r\n Result := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxSpinEdit.ControlSetAnchors(Value: TAnchors);\r\nbegin\r\n Anchors := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxSpinEdit.ControlSetIncrement(Value: Integer);\r\nbegin\r\n Properties.Increment := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxSpinEdit.ControlSetMinValue(Value: double);\r\nbegin\r\n Properties.MinValue := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxSpinEdit.ControlSetMaxValue(Value: double);\r\nbegin\r\n Properties.MaxValue := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxSpinEdit.ControlSetUseForInteger(Value: Boolean);\r\nbegin\r\n if Value then\r\n Properties.ValueType := vtInt\r\n else\r\n Properties.ValueType := vtFloat;\r\nend;\r\n\r\nprocedure TJvDynControlCxSpinEdit.ControlSetCxProperties(Value: TCxDynControlWrapper);\r\nbegin\r\n Style.LookAndFeel.Assign(Value.LookAndFeel);\r\n Style.StyleController := Value.StyleController;\r\nend;\r\n\r\n//=== { TJvDynControlCxFileNameEdit } ========================================\r\n\r\nprocedure TJvDynControlCxFileNameEdit.DefaultOnButtonClick(Sender: TObject; AButtonIndex: Integer);\r\nbegin\r\n if not Properties.ReadOnly then\r\n begin\r\n case FDialogKind of\r\n jdkOpen:\r\n with TOpenDialog.Create(Self) do\r\n try\r\n Options := FDialogOptions;\r\n Title := FDialogTitle;\r\n Filter := FFilter;\r\n FilterIndex := FFilterIndex;\r\n InitialDir := FInitialDir;\r\n DefaultExt := FDefaultExt;\r\n FileName := ControlGetValue;\r\n if Execute then\r\n ControlSetValue(FileName);\r\n finally\r\n Free;\r\n end;\r\n jdkOpenPicture:\r\n with TOpenPictureDialog.Create(Self) do\r\n try\r\n Options := FDialogOptions;\r\n Title := FDialogTitle;\r\n Filter := FFilter;\r\n FilterIndex := FFilterIndex;\r\n InitialDir := FInitialDir;\r\n DefaultExt := FDefaultExt;\r\n FileName := ControlGetValue;\r\n if Execute then\r\n ControlSetValue(FileName);\r\n finally\r\n Free;\r\n end;\r\n jdkSave:\r\n with TSaveDialog.Create(Self) do\r\n try\r\n Options := FDialogOptions;\r\n Title := FDialogTitle;\r\n Filter := FFilter;\r\n FilterIndex := FFilterIndex;\r\n InitialDir := FInitialDir;\r\n DefaultExt := FDefaultExt;\r\n FileName := ControlGetValue;\r\n if Execute then\r\n ControlSetValue(FileName);\r\n finally\r\n Free;\r\n end;\r\n jdkSavePicture:\r\n with TSavePictureDialog.Create(Self) do\r\n try\r\n Options := FDialogOptions;\r\n Title := FDialogTitle;\r\n Filter := FFilter;\r\n FilterIndex := FFilterIndex;\r\n InitialDir := FInitialDir;\r\n DefaultExt := FDefaultExt;\r\n FileName := ControlGetValue;\r\n if Execute then\r\n ControlSetValue(FileName);\r\n finally\r\n Free;\r\n end;\r\n end;\r\n if CanFocus then\r\n SetFocus;\r\n end;\r\nend;\r\n\r\nprocedure TJvDynControlCxFileNameEdit.ControlSetDefaultProperties;\r\nbegin\r\n Properties.OnButtonClick := DefaultOnButtonClick;\r\nend;\r\n\r\nprocedure TJvDynControlCxFileNameEdit.ControlSetReadOnly(Value: Boolean);\r\nbegin\r\n Properties.ReadOnly := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxFileNameEdit.ControlSetTabOrder(Value: Integer);\r\nbegin\r\n TabOrder := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxFileNameEdit.ControlSetOnEnter(Value: TNotifyEvent);\r\nbegin\r\n OnEnter := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxFileNameEdit.ControlSetOnExit(Value: TNotifyEvent);\r\nbegin\r\n OnExit := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxFileNameEdit.ControlSetOnChange(Value: TNotifyEvent);\r\nbegin\r\n Properties.OnChange := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxFileNameEdit.ControlSetOnClick(Value: TNotifyEvent);\r\nbegin\r\nend;\r\n\r\nprocedure TJvDynControlCxFileNameEdit.ControlSetHint(const Value: string);\r\nbegin\r\n Hint := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxFileNameEdit.ControlSetValue(Value: Variant);\r\nbegin\r\n Text := VarToStr(Value);\r\nend;\r\n\r\nfunction TJvDynControlCxFileNameEdit.ControlGetValue: Variant;\r\nbegin\r\n Result := Text;\r\nend;\r\n\r\nprocedure TJvDynControlCxFileNameEdit.ControlSetAnchors(Value: TAnchors);\r\nbegin\r\n Anchors := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxFileNameEdit.ControlSetCxProperties(Value: TCxDynControlWrapper);\r\nbegin\r\n Style.LookAndFeel.Assign(Value.LookAndFeel);\r\n Style.StyleController := Value.StyleController;\r\nend;\r\n\r\nprocedure TJvDynControlCxFileNameEdit.ControlSetInitialDir(const Value: string);\r\nbegin\r\n FInitialDir := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxFileNameEdit.ControlSetDefaultExt(const Value: string);\r\nbegin\r\n FDefaultExt := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxFileNameEdit.ControlSetDialogTitle(const Value: string);\r\nbegin\r\n FDialogTitle := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxFileNameEdit.ControlSetDialogOptions(Value: TOpenOptions);\r\nbegin\r\n FDialogOptions := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxFileNameEdit.ControlSetFilter(const Value: string);\r\nbegin\r\n FFilter := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxFileNameEdit.ControlSetFilterIndex(Value: Integer);\r\nbegin\r\n FFilterIndex := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxFileNameEdit.ControlSetDialogKind(Value: TJvDynControlFileNameDialogKind);\r\nbegin\r\n FDialogKind := Value;\r\nend;\r\n\r\n//=== { TJvDynControlCxDirectoryEdit } =======================================\r\n\r\nprocedure TJvDynControlCxDirectoryEdit.DefaultOnButtonClick(Sender: TObject; AButtonIndex: Integer);\r\nvar\r\n Dir: string;\r\nbegin\r\n if not Properties.ReadOnly then\r\n begin\r\n Dir := ControlGetValue;\r\n if Dir = '' then\r\n begin\r\n if FInitialDir <> '' then\r\n Dir := FInitialDir\r\n else\r\n Dir := '\\';\r\n end;\r\n if not DirectoryExists(Dir) then\r\n Dir := '\\';\r\n if BrowseForFolder('', True, Dir, HelpContext) then\r\n// if SelectDirectory(Dir, FDialogOptions, HelpContext) then\r\n ControlSetValue(Dir);\r\n if CanFocus then\r\n SetFocus;\r\n end;\r\nend;\r\n\r\nprocedure TJvDynControlCxDirectoryEdit.ControlSetDefaultProperties;\r\nbegin\r\n Properties.OnButtonClick := DefaultOnButtonClick;\r\nend;\r\n\r\nprocedure TJvDynControlCxDirectoryEdit.ControlSetReadOnly(Value: Boolean);\r\nbegin\r\n Properties.ReadOnly := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxDirectoryEdit.ControlSetTabOrder(Value: Integer);\r\nbegin\r\n TabOrder := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxDirectoryEdit.ControlSetOnEnter(Value: TNotifyEvent);\r\nbegin\r\n OnEnter := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxDirectoryEdit.ControlSetOnExit(Value: TNotifyEvent);\r\nbegin\r\n OnExit := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxDirectoryEdit.ControlSetOnChange(Value: TNotifyEvent);\r\nbegin\r\n Properties.OnChange := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxDirectoryEdit.ControlSetOnClick(Value: TNotifyEvent);\r\nbegin\r\nend;\r\n\r\nprocedure TJvDynControlCxDirectoryEdit.ControlSetHint(const Value: string);\r\nbegin\r\n Hint := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxDirectoryEdit.ControlSetValue(Value: Variant);\r\nbegin\r\n Text := VarToStr(Value);\r\nend;\r\n\r\nfunction TJvDynControlCxDirectoryEdit.ControlGetValue: Variant;\r\nbegin\r\n Result := Text;\r\nend;\r\n\r\nprocedure TJvDynControlCxDirectoryEdit.ControlSetAnchors(Value: TAnchors);\r\nbegin\r\n Anchors := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxDirectoryEdit.ControlSetCxProperties(Value: TCxDynControlWrapper);\r\nbegin\r\n Style.LookAndFeel.Assign(Value.LookAndFeel);\r\n Style.StyleController := Value.StyleController;\r\nend;\r\n\r\nprocedure TJvDynControlCxDirectoryEdit.ControlSetInitialDir(const Value: string);\r\nbegin\r\n FInitialDir := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxDirectoryEdit.ControlSetDialogTitle(const Value: string);\r\nbegin\r\n FDialogTitle := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxDirectoryEdit.ControlSetDialogOptions(Value: TSelectDirOpts);\r\nbegin\r\n FDialogOptions := Value;\r\nend;\r\n\r\n//=== { TJvDynControlCxDateTimeEdit } ========================================\r\n\r\nprocedure TJvDynControlCxDateTimeEdit.ControlSetDefaultProperties;\r\nbegin\r\n Properties.ShowTime := True;\r\n Properties.SaveTime := False;\r\n Properties.InputKind := ikStandard;\r\nend;\r\n\r\nprocedure TJvDynControlCxDateTimeEdit.ControlSetReadOnly(Value: Boolean);\r\nbegin\r\n Properties.ReadOnly := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxDateTimeEdit.ControlSetTabOrder(Value: Integer);\r\nbegin\r\n TabOrder := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxDateTimeEdit.ControlSetOnEnter(Value: TNotifyEvent);\r\nbegin\r\n OnEnter := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxDateTimeEdit.ControlSetOnExit(Value: TNotifyEvent);\r\nbegin\r\n OnExit := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxDateTimeEdit.ControlSetOnChange(Value: TNotifyEvent);\r\nbegin\r\n Properties.OnChange := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxDateTimeEdit.ControlSetOnClick(Value: TNotifyEvent);\r\nbegin\r\nend;\r\n\r\nprocedure TJvDynControlCxDateTimeEdit.ControlSetHint(const Value: string);\r\nbegin\r\n Hint := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxDateTimeEdit.ControlSetValue(Value: Variant);\r\nbegin\r\n if VarIsStr(Value) then\r\n Date := StrToDateTime(Value)\r\n else\r\n Date := Value;\r\nend;\r\n\r\nfunction TJvDynControlCxDateTimeEdit.ControlGetValue: Variant;\r\nbegin\r\n if Text = '' then\r\n Result := Null\r\n else\r\n Result := Date;\r\nend;\r\n\r\nprocedure TJvDynControlCxDateTimeEdit.ControlSetAnchors(Value: TAnchors);\r\nbegin\r\n Anchors := Value;\r\nend;\r\n\r\n// IJvDynControlDate\r\nprocedure TJvDynControlCxDateTimeEdit.ControlSetMinDate(Value: TDateTime);\r\nbegin\r\n Properties.MinDate := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxDateTimeEdit.ControlSetMaxDate(Value: TDateTime);\r\nbegin\r\n Properties.MaxDate := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxDateTimeEdit.ControlSetFormat(const Value: string);\r\nbegin\r\n// Format := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxDateTimeEdit.ControlSetCxProperties(Value: TCxDynControlWrapper);\r\nbegin\r\n Style.LookAndFeel.Assign(Value.LookAndFeel);\r\n Style.StyleController := Value.StyleController;\r\nend;\r\n\r\n//=== { TJvDynControlCxDateEdit } ============================================\r\n\r\nprocedure TJvDynControlCxDateEdit.ControlSetDefaultProperties;\r\nbegin\r\n Properties.ShowTime := False;\r\n Properties.SaveTime := False;\r\n Properties.InputKind := ikStandard;\r\nend;\r\n\r\nprocedure TJvDynControlCxDateEdit.ControlSetReadOnly(Value: Boolean);\r\nbegin\r\n Properties.ReadOnly := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxDateEdit.ControlSetTabOrder(Value: Integer);\r\nbegin\r\n TabOrder := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxDateEdit.ControlSetOnEnter(Value: TNotifyEvent);\r\nbegin\r\n OnEnter := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxDateEdit.ControlSetOnExit(Value: TNotifyEvent);\r\nbegin\r\n OnExit := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxDateEdit.ControlSetOnChange(Value: TNotifyEvent);\r\nbegin\r\n Properties.OnChange := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxDateEdit.ControlSetOnClick(Value: TNotifyEvent);\r\nbegin\r\nend;\r\n\r\nprocedure TJvDynControlCxDateEdit.ControlSetHint(const Value: string);\r\nbegin\r\n Hint := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxDateEdit.ControlSetValue(Value: Variant);\r\nbegin\r\n if VarIsStr(Value) then\r\n Date := StrToDateTime(Value)\r\n else\r\n Date := Value;\r\nend;\r\n\r\nfunction TJvDynControlCxDateEdit.ControlGetValue: Variant;\r\nbegin\r\n if Text = '' then\r\n Result := Null\r\n else\r\n Result := Date;\r\nend;\r\n\r\nprocedure TJvDynControlCxDateEdit.ControlSetAnchors(Value: TAnchors);\r\nbegin\r\n Anchors := Value;\r\nend;\r\n\r\n// IJvDynControlDate\r\nprocedure TJvDynControlCxDateEdit.ControlSetMinDate(Value: TDateTime);\r\nbegin\r\n Properties.MinDate := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxDateEdit.ControlSetMaxDate(Value: TDateTime);\r\nbegin\r\n Properties.MaxDate := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxDateEdit.ControlSetFormat(const Value: string);\r\nbegin\r\n// Format := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxDateEdit.ControlSetCxProperties(Value: TCxDynControlWrapper);\r\nbegin\r\n Style.LookAndFeel.Assign(Value.LookAndFeel);\r\n Style.StyleController := Value.StyleController;\r\nend;\r\n\r\n//=== { TJvDynControlCxTimeEdit } ============================================\r\n\r\nprocedure TJvDynControlCxTimeEdit.ControlSetDefaultProperties;\r\nbegin\r\n Properties.ShowDate := False;\r\n Properties.UseCtrlIncrement := True;\r\nend;\r\n\r\nprocedure TJvDynControlCxTimeEdit.ControlSetReadOnly(Value: Boolean);\r\nbegin\r\n Properties.ReadOnly := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxTimeEdit.ControlSetTabOrder(Value: Integer);\r\nbegin\r\n TabOrder := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxTimeEdit.ControlSetOnEnter(Value: TNotifyEvent);\r\nbegin\r\n OnEnter := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxTimeEdit.ControlSetOnExit(Value: TNotifyEvent);\r\nbegin\r\n OnExit := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxTimeEdit.ControlSetOnChange(Value: TNotifyEvent);\r\nbegin\r\n Properties.OnChange := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxTimeEdit.ControlSetOnClick(Value: TNotifyEvent);\r\nbegin\r\nend;\r\n\r\nprocedure TJvDynControlCxTimeEdit.ControlSetHint(const Value: string);\r\nbegin\r\n Hint := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxTimeEdit.ControlSetValue(Value: Variant);\r\nbegin\r\n if VarIsStr(Value) then\r\n Time := StrToTime(Value)\r\n else\r\n Time := Value;\r\nend;\r\n\r\nfunction TJvDynControlCxTimeEdit.ControlGetValue: Variant;\r\nbegin\r\n if Text = '' then\r\n Result := Null\r\n else\r\n Result := Time;\r\nend;\r\n\r\nprocedure TJvDynControlCxTimeEdit.ControlSetAnchors(Value: TAnchors);\r\nbegin\r\n Anchors := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxTimeEdit.ControlSetCxProperties(Value: TCxDynControlWrapper);\r\nbegin\r\n Style.LookAndFeel.Assign(Value.LookAndFeel);\r\n Style.StyleController := Value.StyleController;\r\nend;\r\n\r\nprocedure TJvDynControlCxTimeEdit.ControlSetFormat(const Value: string);\r\nbegin\r\n// Properties.Format := Value;\r\n Properties.Use24HourFormat := (Pos('H', Value) > 0);\r\n if (Pos('s', Value) > 0) then\r\n Properties.TimeFormat := tfHourMinSec\r\n else\r\n if (Pos('m', Value) > 0) then\r\n Properties.TimeFormat := tfHourMin\r\n else\r\n Properties.TimeFormat := tfHour;\r\nend;\r\n\r\n//=== { TJvDynControlCxCheckBox } ===========================================\r\n\r\nfunction TJvDynControlCxCheckBox.ControlGetCaption: string;\r\nbegin\r\n Result := Properties.Caption;\r\nend;\r\n\r\nprocedure TJvDynControlCxCheckBox.ControlSetDefaultProperties;\r\nbegin\r\n Transparent := True;\r\nend;\r\n\r\nprocedure TJvDynControlCxCheckBox.ControlSetReadOnly(Value: Boolean);\r\nbegin\r\n Properties.ReadOnly := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxCheckBox.ControlSetCaption(const Value: string);\r\nbegin\r\n if Properties.Caption <> Value then\r\n Properties.Caption := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxCheckBox.ControlSetTabOrder(Value: Integer);\r\nbegin\r\n TabOrder := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxCheckBox.ControlSetOnEnter(Value: TNotifyEvent);\r\nbegin\r\n OnEnter := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxCheckBox.ControlSetOnExit(Value: TNotifyEvent);\r\nbegin\r\n OnExit := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxCheckBox.ControlSetOnChange(Value: TNotifyEvent);\r\nbegin\r\n Properties.OnChange := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxCheckBox.ControlSetOnClick(Value: TNotifyEvent);\r\nbegin\r\n OnClick := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxCheckBox.ControlSetHint(const Value: string);\r\nbegin\r\n Hint := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxCheckBox.ControlSetValue(Value: Variant);\r\nbegin\r\n Checked := JvDynControlVariantToBoolean(Value);\r\nend;\r\n\r\nfunction TJvDynControlCxCheckBox.ControlGetValue: Variant;\r\nbegin\r\n Result := Checked;\r\nend;\r\n\r\nprocedure TJvDynControlCxCheckBox.ControlSetAnchors(Value: TAnchors);\r\nbegin\r\n Anchors := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxCheckBox.ControlSetAllowGrayed(Value: Boolean);\r\nbegin\r\n Properties.AllowGrayed := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxCheckBox.ControlSetState(Value: TCheckBoxState);\r\nbegin\r\n case Value of\r\n cbUnchecked:\r\n State := cbsUnchecked;\r\n cbChecked:\r\n State := cbsChecked;\r\n cbGrayed:\r\n State := cbsGrayed;\r\n end;\r\nend;\r\n\r\nfunction TJvDynControlCxCheckBox.ControlGetState: TCheckBoxState;\r\nbegin\r\n case State of\r\n cbsUnchecked:\r\n Result := cbUnchecked;\r\n cbsChecked:\r\n Result := cbChecked;\r\n else\r\n Result := cbGrayed;\r\n end;\r\nend;\r\n\r\n\r\nprocedure TJvDynControlCxCheckBox.ControlSetCxProperties(Value: TCxDynControlWrapper);\r\nbegin\r\n Style.LookAndFeel.Assign(Value.LookAndFeel);\r\n Style.StyleController := Value.StyleController;\r\nend;\r\n\r\nprocedure TJvDynControlCxCheckBox.ControlSetFont(Value: TFont);\r\nbegin\r\n Font.Assign(Value);\r\nend;\r\n\r\nfunction TJvDynControlCxCheckBox.ControlGetFont: TFont;\r\nbegin\r\n Result := Font;\r\nend;\r\n\r\nfunction TJvDynControlCxMemo.ControlGetFont: TFont;\r\nbegin\r\n Result := Font;\r\nend;\r\n\r\n//=== { TJvDynControlCxMemo } ================================================\r\n\r\nprocedure TJvDynControlCxMemo.ControlSetDefaultProperties;\r\nbegin\r\nend;\r\n\r\nprocedure TJvDynControlCxMemo.ControlSetReadOnly(Value: Boolean);\r\nbegin\r\n Properties.ReadOnly := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxMemo.ControlSetTabOrder(Value: Integer);\r\nbegin\r\n TabOrder := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxMemo.ControlSetOnEnter(Value: TNotifyEvent);\r\nbegin\r\n OnEnter := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxMemo.ControlSetOnExit(Value: TNotifyEvent);\r\nbegin\r\n OnExit := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxMemo.ControlSetOnChange(Value: TNotifyEvent);\r\nbegin\r\n Properties.OnChange := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxMemo.ControlSetOnClick(Value: TNotifyEvent);\r\nbegin\r\n OnClick := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxMemo.ControlSetHint(const Value: string);\r\nbegin\r\n Hint := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxMemo.ControlSetValue(Value: Variant);\r\nbegin\r\n Text := VarToStr(Value);\r\nend;\r\n\r\nfunction TJvDynControlCxMemo.ControlGetValue: Variant;\r\nbegin\r\n Result := Text;\r\nend;\r\n\r\nprocedure TJvDynControlCxMemo.ControlSetSorted(Value: Boolean);\r\nbegin\r\nend;\r\n\r\nprocedure TJvDynControlCxMemo.ControlSetItems(Value: TStrings);\r\nbegin\r\n Lines.Assign(Value);\r\nend;\r\n\r\nfunction TJvDynControlCxMemo.ControlGetItems: TStrings;\r\nbegin\r\n Result := Lines;\r\nend;\r\n\r\nprocedure TJvDynControlCxMemo.ControlSetAnchors(Value: TAnchors);\r\nbegin\r\n Anchors := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxMemo.ControlSetWantTabs(Value: Boolean);\r\nbegin\r\n Properties.WantTabs := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxMemo.ControlSetWantReturns(Value: Boolean);\r\nbegin\r\n Properties.WantReturns := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxMemo.ControlSetWordWrap(Value: Boolean);\r\nbegin\r\n Properties.WordWrap := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxMemo.ControlSetScrollBars(Value: TScrollStyle);\r\nbegin\r\n Properties.ScrollBars := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxMemo.ControlSetCxProperties(Value: TCxDynControlWrapper);\r\nbegin\r\n Style.LookAndFeel.Assign(Value.LookAndFeel);\r\n Style.StyleController := Value.StyleController;\r\nend;\r\n\r\nprocedure TJvDynControlCxMemo.ControlSetAlignment(Value: TAlignment);\r\nbegin\r\n Properties.Alignment := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxMemo.ControlSetFont(Value: TFont);\r\nbegin\r\n Font.Assign(Value);\r\nend;\r\n\r\n\r\nfunction TJvDynControlCxRichEdit.ControlGetFont: TFont;\r\nbegin\r\n Result := Font;\r\nend;\r\n\r\n//=== { TJvDynControlCxRichEdit } ============================================\r\n\r\nprocedure TJvDynControlCxRichEdit.ControlSetDefaultProperties;\r\nbegin\r\nend;\r\n\r\nprocedure TJvDynControlCxRichEdit.ControlSetReadOnly(Value: Boolean);\r\nbegin\r\n Properties.ReadOnly := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxRichEdit.ControlSetTabOrder(Value: Integer);\r\nbegin\r\n TabOrder := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxRichEdit.ControlSetOnEnter(Value: TNotifyEvent);\r\nbegin\r\n OnEnter := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxRichEdit.ControlSetOnExit(Value: TNotifyEvent);\r\nbegin\r\n OnExit := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxRichEdit.ControlSetOnChange(Value: TNotifyEvent);\r\nbegin\r\n Properties.OnChange := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxRichEdit.ControlSetOnClick(Value: TNotifyEvent);\r\nbegin\r\n OnClick := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxRichEdit.ControlSetHint(const Value: string);\r\nbegin\r\n Hint := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxRichEdit.ControlSetValue(Value: Variant);\r\nbegin\r\n Text := VarToStr(Value);\r\nend;\r\n\r\nfunction TJvDynControlCxRichEdit.ControlGetValue: Variant;\r\nbegin\r\n Result := Text;\r\nend;\r\n\r\nprocedure TJvDynControlCxRichEdit.ControlSetSorted(Value: Boolean);\r\nbegin\r\nend;\r\n\r\nprocedure TJvDynControlCxRichEdit.ControlSetItems(Value: TStrings);\r\nbegin\r\n Lines.Assign(Value);\r\nend;\r\n\r\nfunction TJvDynControlCxRichEdit.ControlGetItems: TStrings;\r\nbegin\r\n Result := Lines;\r\nend;\r\n\r\nprocedure TJvDynControlCxRichEdit.ControlSetAnchors(Value: TAnchors);\r\nbegin\r\n Anchors := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxRichEdit.ControlSetWantTabs(Value: Boolean);\r\nbegin\r\n Properties.WantTabs := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxRichEdit.ControlSetWantReturns(Value: Boolean);\r\nbegin\r\n Properties.WantReturns := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxRichEdit.ControlSetWordWrap(Value: Boolean);\r\nbegin\r\n Properties.WordWrap := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxRichEdit.ControlSetScrollBars(Value: TScrollStyle);\r\nbegin\r\n Properties.ScrollBars := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxRichEdit.ControlSetCxProperties(Value: TCxDynControlWrapper);\r\nbegin\r\n Style.LookAndFeel.Assign(Value.LookAndFeel);\r\n Style.StyleController := Value.StyleController;\r\nend;\r\n\r\nprocedure TJvDynControlCxRichEdit.ControlSetFont(Value: TFont);\r\nbegin\r\n Font.Assign(Value);\r\nend;\r\n\r\n//=== { TJvDynControlCxRadioGroup } ===========================================\r\n\r\nfunction TJvDynControlCxRadioGroup.ControlGetCaption: string;\r\nbegin\r\n Result := Caption;\r\nend;\r\n\r\nprocedure TJvDynControlCxRadioGroup.ControlSetDefaultProperties;\r\nbegin\r\nend;\r\n\r\nprocedure TJvDynControlCxRadioGroup.ControlSetReadOnly(Value: Boolean);\r\nbegin\r\n Properties.ReadOnly := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxRadioGroup.ControlSetCaption(const Value: string);\r\nbegin\r\n if Caption <> Value then\r\n Caption := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxRadioGroup.ControlSetTabOrder(Value: Integer);\r\nbegin\r\n TabOrder := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxRadioGroup.ControlSetOnEnter(Value: TNotifyEvent);\r\nbegin\r\n OnEnter := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxRadioGroup.ControlSetOnExit(Value: TNotifyEvent);\r\nbegin\r\n OnExit := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxRadioGroup.ControlSetOnChange(Value: TNotifyEvent);\r\nbegin\r\n Properties.OnChange := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxRadioGroup.ControlSetOnClick(Value: TNotifyEvent);\r\nbegin\r\n OnClick := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxRadioGroup.ControlSetHint(const Value: string);\r\nbegin\r\n Hint := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxRadioGroup.ControlSetValue(Value: Variant);\r\nvar\r\n I: Integer;\r\nbegin\r\n if VarIsInt(Value) then\r\n ItemIndex := Value\r\n else\r\n begin\r\n ItemIndex := -1;\r\n for I := 0 to Properties.Items.Count - 1 do\r\n if TcxRadioGroupItem(Properties.Items[I]).Caption = Value then\r\n begin\r\n ItemIndex := I;\r\n Break;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJvDynControlCxRadioGroup.ControlGetValue: Variant;\r\nbegin\r\n Result := ItemIndex;\r\nend;\r\n\r\nprocedure TJvDynControlCxRadioGroup.ControlSetSorted(Value: Boolean);\r\nbegin\r\nend;\r\n\r\nprocedure TJvDynControlCxRadioGroup.ControlSetItems(Value: TStrings);\r\nvar\r\n I: Integer;\r\n Item: TcxRadioGroupItem;\r\nbegin\r\n Properties.Items.Clear;\r\n for I := 0 to Value.Count - 1 do\r\n begin\r\n Item := TcxRadioGroupItem(Properties.Items.Add);\r\n Item.Caption := Value[I];\r\n end;\r\nend;\r\n\r\nfunction TJvDynControlCxRadioGroup.ControlGetItems: TStrings;\r\nbegin\r\n// Result := TStrings(Properties.Items);\r\n Result := nil;\r\nend;\r\n\r\nprocedure TJvDynControlCxRadioGroup.ControlSetAnchors(Value: TAnchors);\r\nbegin\r\n Anchors := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxRadioGroup.ControlSetCxProperties(Value: TCxDynControlWrapper);\r\nbegin\r\n Style.LookAndFeel.Assign(Value.LookAndFeel);\r\n Style.StyleController := Value.StyleController;\r\nend;\r\n\r\nprocedure TJvDynControlCxRadioGroup.ControlSetColumns(Value: Integer);\r\nbegin\r\n Properties.Columns := Value;\r\nend;\r\n\r\nfunction TJvDynControlCxListBox.ControlGetItemIndex: Integer;\r\nbegin\r\n Result := ItemIndex;\r\nend;\r\n\r\n//=== { TJvDynControlCxListBox } =============================================\r\n\r\nprocedure TJvDynControlCxListBox.ControlSetDefaultProperties;\r\nbegin\r\nend;\r\n\r\nprocedure TJvDynControlCxListBox.ControlSetReadOnly(Value: Boolean);\r\nbegin\r\n ReadOnly := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxListBox.ControlSetTabOrder(Value: Integer);\r\nbegin\r\n TabOrder := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxListBox.ControlSetOnEnter(Value: TNotifyEvent);\r\nbegin\r\n OnEnter := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxListBox.ControlSetOnExit(Value: TNotifyEvent);\r\nbegin\r\n OnExit := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxListBox.ControlSetOnChange(Value: TNotifyEvent);\r\nbegin\r\nend;\r\n\r\nprocedure TJvDynControlCxListBox.ControlSetOnClick(Value: TNotifyEvent);\r\nbegin\r\n OnClick := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxListBox.ControlSetHint(const Value: string);\r\nbegin\r\n Hint := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxListBox.ControlSetValue(Value: Variant);\r\nbegin\r\n if VarIsInt(Value) then\r\n ItemIndex := Value\r\n else\r\n ItemIndex := Items.IndexOf(Value);\r\nend;\r\n\r\nfunction TJvDynControlCxListBox.ControlGetValue: Variant;\r\nbegin\r\n Result := ItemIndex;\r\nend;\r\n\r\nprocedure TJvDynControlCxListBox.ControlSetSorted(Value: Boolean);\r\nbegin\r\n Sorted := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxListBox.ControlSetItems(Value: TStrings);\r\nbegin\r\n Items.Assign(Value);\r\nend;\r\n\r\nfunction TJvDynControlCxListBox.ControlGetItems: TStrings;\r\nbegin\r\n Result := Items;\r\nend;\r\n\r\nprocedure TJvDynControlCxListBox.ControlSetAnchors(Value: TAnchors);\r\nbegin\r\n Anchors := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxListBox.ControlSetOnDblClick(Value: TNotifyEvent);\r\nbegin\r\n OnDblClick := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxListBox.ControlSetCxProperties(Value: TCxDynControlWrapper);\r\nbegin\r\n Style.LookAndFeel.Assign(Value.LookAndFeel);\r\n Style.StyleController := Value.StyleController;\r\nend;\r\n\r\nprocedure TJvDynControlCxListBox.ControlSetItemIndex(const Value: Integer);\r\nbegin\r\n ItemIndex := Value;\r\nend;\r\n\r\nfunction TJvDynControlCxListBox.ControlGetOnKeyDown: TKeyEvent;\r\nbegin\r\n Result := OnKeyDown;\r\nend;\r\n\r\nfunction TJvDynControlCxListBox.ControlGetOnKeyPress: TKeyPressEvent;\r\nbegin\r\n Result := OnKeyPress;\r\nend;\r\n\r\nfunction TJvDynControlCxListBox.ControlGetOnKeyUp: TKeyEvent;\r\nbegin\r\n Result := OnKeyUp;\r\nend;\r\n\r\nfunction TJvDynControlCxListBox.ControlGetOnMouseDown: TMouseEvent;\r\nbegin\r\n Result := OnMouseDown;\r\nend;\r\n\r\nfunction TJvDynControlCxListBox.ControlGetOnMouseEnter: TNotifyEvent;\r\nbegin\r\n {$IFDEF DELPHI2007_UP}\r\n Result := OnMouseEnter;\r\n {$ENDIF DELPHI2007_UP}\r\nend;\r\n\r\nfunction TJvDynControlCxListBox.ControlGetOnMouseLeave: TNotifyEvent;\r\nbegin\r\n {$IFDEF DELPHI2007_UP}\r\n Result := OnMouseLeave;\r\n {$ENDIF DELPHI2007_UP}\r\nend;\r\n\r\nfunction TJvDynControlCxListBox.ControlGetOnMouseMove: TMouseMoveEvent;\r\nbegin\r\n Result := OnMouseMove;\r\nend;\r\n\r\nfunction TJvDynControlCxListBox.ControlGetOnMouseUp: TMouseEvent;\r\nbegin\r\n Result := OnMouseUp;\r\nend;\r\n\r\nprocedure TJvDynControlCxListBox.ControlSetOnKeyDown(const Value: TKeyEvent);\r\nbegin\r\n OnKeyDown := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxListBox.ControlSetOnKeyPress(const Value: TKeyPressEvent);\r\nbegin\r\n OnKeyPress := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxListBox.ControlSetOnKeyUp(const Value: TKeyEvent);\r\nbegin\r\n OnKeyUp := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxListBox.ControlSetOnMouseDown(const Value: TMouseEvent);\r\nbegin\r\n OnMouseDown := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxListBox.ControlSetOnMouseEnter(const Value: TNotifyEvent);\r\nbegin\r\n {$IFDEF DELPHI2007_UP}\r\n OnMouseEnter := Value;\r\n {$ENDIF DELPHI2007_UP}\r\nend;\r\n\r\nprocedure TJvDynControlCxListBox.ControlSetOnMouseLeave(const Value: TNotifyEvent);\r\nbegin\r\n {$IFDEF DELPHI2007_UP}\r\n OnMouseEnter := Value;\r\n {$ENDIF DELPHI2007_UP}\r\nend;\r\n\r\nprocedure TJvDynControlCxListBox.ControlSetOnMouseMove(const Value: TMouseMoveEvent);\r\nbegin\r\n OnMouseMove := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxListBox.ControlSetOnMouseUp(const Value: TMouseEvent);\r\nbegin\r\n OnMouseUp := Value;\r\nend;\r\n\r\n//=== { TJvDynControlCxCheckListBox } ========================================\r\n\r\nconstructor TJvDynControlCxCheckListBox.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FIntItems := TStringList.Create;\r\nend;\r\n\r\ndestructor TJvDynControlCxCheckListBox.Destroy;\r\nbegin\r\n FIntItems.Free;\r\n Inherited Destroy;\r\nend;\r\n\r\nprocedure TJvDynControlCxCheckListBox.ControlSetDefaultProperties;\r\nbegin\r\nend;\r\n\r\nprocedure TJvDynControlCxCheckListBox.ControlSetReadOnly(Value: Boolean);\r\nbegin\r\n ReadOnly := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxCheckListBox.ControlSetTabOrder(Value: Integer);\r\nbegin\r\n TabOrder := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxCheckListBox.ControlSetOnEnter(Value: TNotifyEvent);\r\nbegin\r\n OnEnter := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxCheckListBox.ControlSetOnExit(Value: TNotifyEvent);\r\nbegin\r\n OnExit := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxCheckListBox.ControlSetOnChange(Value: TNotifyEvent);\r\nbegin\r\nend;\r\n\r\nprocedure TJvDynControlCxCheckListBox.ControlSetOnClick(Value: TNotifyEvent);\r\nbegin\r\n OnClick := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxCheckListBox.ControlSetHint(const Value: string);\r\nbegin\r\n Hint := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxCheckListBox.ControlSetValue(Value: Variant);\r\nbegin\r\n if VarIsInt(Value) then\r\n ItemIndex := Value\r\n else\r\n ItemIndex := Items.IndexOf(Value);\r\nend;\r\n\r\nfunction TJvDynControlCxCheckListBox.ControlGetValue: Variant;\r\nbegin\r\n Result := ItemIndex;\r\nend;\r\n\r\nprocedure TJvDynControlCxCheckListBox.ControlSetSorted(Value: Boolean);\r\nbegin\r\n Sorted := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxCheckListBox.ControlSetItems(Value: TStrings);\r\nvar\r\n I: Integer;\r\nbegin\r\n FIntItems.Assign(Value);\r\n Items.Clear;\r\n for I := 0 to FIntItems.Count-1 do\r\n with Items.Add do\r\n Text := FIntItems[I];\r\nend;\r\n\r\nfunction TJvDynControlCxCheckListBox.ControlGetItems: TStrings;\r\nvar\r\n I: Integer;\r\nbegin\r\n FIntItems.Clear;\r\n for I := 0 to Items.Count-1 do\r\n FIntItems.Add(Items[I].Text);\r\n Result := FIntItems;\r\nend;\r\n\r\nprocedure TJvDynControlCxCheckListBox.ControlSetOnDblClick(Value: TNotifyEvent);\r\nbegin\r\n OnDblClick := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxCheckListBox.ControlSetCxProperties(Value: TCxDynControlWrapper);\r\nbegin\r\n Style.LookAndFeel.Assign(Value.LookAndFeel);\r\n Style.StyleController := Value.StyleController;\r\nend;\r\n\r\n//IJvDynControlCheckListBox = interface\r\nprocedure TJvDynControlCxCheckListBox.ControlSetAllowGrayed(Value: Boolean);\r\nbegin\r\n AllowGrayed := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxCheckListBox.ControlSetChecked(Index: Integer; Value: Boolean);\r\nbegin\r\n Items[Index].Checked := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxCheckListBox.ControlSetItemEnabled(Index: Integer; Value: Boolean);\r\nbegin\r\n Items[Index].Enabled := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxCheckListBox.ControlSetHeader(Index: Integer; Value: Boolean);\r\nbegin\r\nend;\r\n\r\nprocedure TJvDynControlCxCheckListBox.ControlSetState(Index: Integer; Value: TCheckBoxState);\r\nbegin\r\n case Value of\r\n cbUnchecked:\r\n Items[Index].State := cbsUnchecked;\r\n cbChecked:\r\n Items[Index].State := cbsChecked;\r\n cbGrayed:\r\n Items[Index].State := cbsGrayed;\r\n end;\r\nend;\r\n\r\nfunction TJvDynControlCxCheckListBox.ControlGetChecked(Index: Integer): Boolean;\r\nbegin\r\n Result := Items[Index].Checked;\r\nend;\r\n\r\nfunction TJvDynControlCxCheckListBox.ControlGetItemEnabled(Index: Integer): Boolean;\r\nbegin\r\n Result := Items[Index].Enabled;\r\nend;\r\n\r\nfunction TJvDynControlCxCheckListBox.ControlGetHeader(Index: Integer): Boolean;\r\nbegin\r\n Result := False;\r\nend;\r\n\r\nfunction TJvDynControlCxCheckListBox.ControlGetState(Index: Integer): TCheckBoxState;\r\nbegin\r\n case Items[Index].State of\r\n cbsUnchecked:\r\n Result := cbUnchecked;\r\n cbsChecked:\r\n Result := cbChecked;\r\n else\r\n Result := cbGrayed;\r\n end;\r\nend;\r\n\r\nprocedure TJvDynControlCxCheckListBox.ControlSetAnchors(Value: TAnchors);\r\nbegin\r\n Anchors := Value;\r\nend;\r\n\r\n//=== { TJvDynControlCxComboBox } ============================================\r\n\r\nprocedure TJvDynControlCxComboBox.ControlSetDefaultProperties;\r\nbegin\r\nend;\r\n\r\nprocedure TJvDynControlCxComboBox.ControlSetReadOnly(Value: Boolean);\r\nbegin\r\n Properties.ReadOnly := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxComboBox.ControlSetTabOrder(Value: Integer);\r\nbegin\r\n TabOrder := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxComboBox.ControlSetOnEnter(Value: TNotifyEvent);\r\nbegin\r\n OnEnter := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxComboBox.ControlSetOnExit(Value: TNotifyEvent);\r\nbegin\r\n OnExit := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxComboBox.ControlSetOnChange(Value: TNotifyEvent);\r\nbegin\r\n Properties.OnChange := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxComboBox.ControlSetOnClick(Value: TNotifyEvent);\r\nbegin\r\n OnClick := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxComboBox.ControlSetHint(const Value: string);\r\nbegin\r\n Hint := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxComboBox.ControlSetValue(Value: Variant);\r\nbegin\r\n Text := VarToStr(Value);\r\nend;\r\n\r\nfunction TJvDynControlCxComboBox.ControlGetValue: Variant;\r\nbegin\r\n Result := Text;\r\nend;\r\n\r\nprocedure TJvDynControlCxComboBox.ControlSetSorted(Value: Boolean);\r\nbegin\r\n Properties.Sorted := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxComboBox.ControlSetItems(Value: TStrings);\r\nbegin\r\n Properties.Items.Assign(Value);\r\nend;\r\n\r\nfunction TJvDynControlCxComboBox.ControlGetItems: TStrings;\r\nbegin\r\n Result := Properties.Items;\r\nend;\r\n\r\nprocedure TJvDynControlCxComboBox.ControlSetAnchors(Value: TAnchors);\r\nbegin\r\n Anchors := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxComboBox.ControlSetCxProperties(Value: TCxDynControlWrapper);\r\nbegin\r\n Style.LookAndFeel.Assign(Value.LookAndFeel);\r\n Style.StyleController := Value.StyleController;\r\nend;\r\n\r\nprocedure TJvDynControlCxComboBox.ControlSetNewEntriesAllowed(Value: Boolean);\r\nbegin\r\n if Value then\r\n Properties.DropDownListStyle := lsEditList\r\n else\r\n Properties.DropDownListStyle := lsEditFixedList;\r\nend;\r\n\r\n//=== { TJvDynControlCxGroupBox } ===========================================\r\n\r\nfunction TJvDynControlCxGroupBox.ControlGetCaption: string;\r\nbegin\r\n Result := Caption;\r\nend;\r\n\r\nprocedure TJvDynControlCxGroupBox.ControlSetAnchors(Value: TAnchors);\r\nbegin\r\n Anchors := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxGroupBox.ControlSetDefaultProperties;\r\nbegin\r\nend;\r\n\r\nprocedure TJvDynControlCxGroupBox.ControlSetCaption(const Value: string);\r\nbegin\r\n if Caption <> Value then\r\n Caption := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxGroupBox.ControlSetColor(Value: TColor);\r\nbegin\r\n Style.Color := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxGroupBox.ControlSetTabOrder(Value: Integer);\r\nbegin\r\n TabOrder := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxGroupBox.ControlSetOnEnter(Value: TNotifyEvent);\r\nbegin\r\n OnEnter := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxGroupBox.ControlSetOnExit(Value: TNotifyEvent);\r\nbegin\r\n OnExit := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxGroupBox.ControlSetOnClick(Value: TNotifyEvent);\r\nbegin\r\nend;\r\n\r\nprocedure TJvDynControlCxGroupBox.ControlSetHint(const Value: string);\r\nbegin\r\n Hint := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxGroupBox.ControlSetParentColor(Value: Boolean);\r\nbegin\r\n Parentcolor := Value;\r\nend;\r\n\r\n//=== { TJvDynControlCxPanel } ===========================================\r\n\r\nfunction TJvDynControlCxPanel.ControlGetCaption: string;\r\nbegin\r\n Result := Caption;\r\nend;\r\n\r\nprocedure TJvDynControlCxPanel.ControlSetDefaultProperties;\r\nbegin\r\n BevelInner := bvNone;\r\n BevelOuter := bvNone;\r\n PanelStyle.Active := True;\r\n PanelStyle.BorderWidth := 0;\r\n Style.BorderStyle := ebsNone;\r\n Style.TransparentBorder := False;\r\nend;\r\n\r\nprocedure TJvDynControlCxPanel.ControlSetCaption(const Value: string);\r\nbegin\r\n if Caption <> Value then\r\n Caption := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxPanel.ControlSetTabOrder(Value: Integer);\r\nbegin\r\n TabOrder := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxPanel.ControlSetOnEnter(Value: TNotifyEvent);\r\nbegin\r\n OnEnter := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxPanel.ControlSetOnExit(Value: TNotifyEvent);\r\nbegin\r\n OnExit := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxPanel.ControlSetOnClick(Value: TNotifyEvent);\r\nbegin\r\nend;\r\n\r\nprocedure TJvDynControlCxPanel.ControlSetHint(const Value: string);\r\nbegin\r\n Hint := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxPanel.ControlSetBorder(ABevelInner: TPanelBevel; ABevelOuter: TPanelBevel; ABevelWidth: Integer; ABorderStyle: TBorderStyle; ABorderWidth: Integer);\r\nbegin\r\n ControlSetBorderWidth (ABorderWidth);\r\n ControlSetBorderStyle (ABorderStyle);\r\n ControlSetBevelInner (ABevelInner);\r\n ControlSetBevelOuter (ABevelOuter);\r\n BevelWidth := ABevelWidth;\r\nend;\r\n\r\n\r\nprocedure TJvDynControlCxPanel.ControlSetAlign(Value: TAlign);\r\nbegin\r\n Align := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxPanel.ControlSetAnchors(Value: TAnchors);\r\nbegin\r\n Anchors := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxPanel.ControlSetAutoSize(Value: Boolean);\r\nbegin\r\n AutoSize := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxPanel.ControlSetBevelInner(Value: TBevelCut);\r\nbegin\r\n BevelInner:= Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxPanel.ControlSetBevelKind(Value: TBevelKind);\r\nbegin\r\n BevelKind := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxPanel.ControlSetBevelOuter(Value: TBevelCut);\r\nbegin\r\n BevelOuter:= Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxPanel.ControlSetBorderStyle(Value: TBorderStyle);\r\nbegin\r\n if value = bsNone then\r\n BorderStyle := cxcbsNone\r\n else\r\n BorderStyle := cxcbsDefault;\r\n if BorderStyle = cxcbsNone then\r\n begin\r\n if Style.BorderStyle <> ebsNone then\r\n Style.BorderStyle := ebsNone;\r\n end\r\n else\r\n begin\r\n if svBorderStyle in Style.AssignedValues then\r\n Style.AssignedValues := Style.AssignedValues - [ svBorderStyle ];\r\n end;\r\nend;\r\n\r\nprocedure TJvDynControlCxPanel.ControlSetBorderWidth(Value: Integer);\r\nbegin\r\n PanelStyle.BorderWidth := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxPanel.ControlSetColor(Value: TColor);\r\nbegin\r\n Style.Color := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxPanel.ControlSetParentColor(Value: Boolean);\r\nbegin\r\n ParentColor := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxPanel.ControlSetAlignment(Value: TAlignment);\r\nbegin\r\n Properties.Alignment.Horz := Value;\r\nend;\r\n\r\n\r\n//=== { TJvDynControlCxImage } ===============================================\r\n\r\nprocedure TJvDynControlCxImage.ControlSetDefaultProperties;\r\nbegin\r\n Properties.GraphicTransparency := gtDefault;\r\n ParentColor := True;\r\nend;\r\n\r\nprocedure TJvDynControlCxImage.ControlSetTabOrder(Value: Integer);\r\nbegin\r\n TabOrder := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxImage.ControlSetOnEnter(Value: TNotifyEvent);\r\nbegin\r\n// OnEnter := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxImage.ControlSetOnExit(Value: TNotifyEvent);\r\nbegin\r\n// OnExit := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxImage.ControlSetOnClick(Value: TNotifyEvent);\r\nbegin\r\n OnClick := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxImage.ControlSetHint(const Value: string);\r\nbegin\r\n Hint := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxImage.ControlSetAutoSize(Value: Boolean);\r\nbegin\r\n AutoSize := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxImage.ControlSetIncrementalDisplay(Value: Boolean);\r\nbegin\r\n// Properties.IncrementalDisplay := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxImage.ControlSetCenter(Value: Boolean);\r\nbegin\r\n Properties.Center := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxImage.ControlSetProportional(Value: Boolean);\r\nbegin\r\n// Properties.Proportional := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxImage.ControlSetStretch(Value: Boolean);\r\nbegin\r\n Properties.Stretch := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxImage.ControlSetTransparent(Value: Boolean);\r\nbegin\r\n if Value then\r\n Properties.GraphicTransparency := gtDefault\r\n else\r\n Properties.GraphicTransparency := gtTransparent;\r\nend;\r\n\r\nprocedure TJvDynControlCxImage.ControlSetPicture(Value: TPicture);\r\nbegin\r\n Picture.Assign(Value);\r\nend;\r\n\r\nprocedure TJvDynControlCxImage.ControlSetGraphic(Value: TGraphic);\r\nbegin\r\n Picture.Assign(Value);\r\nend;\r\n\r\nfunction TJvDynControlCxImage.ControlGetPicture: TPicture;\r\nbegin\r\n Result := Picture;\r\nend;\r\n\r\nprocedure TJvDynControlCxImage.ControlSetAnchors(Value: TAnchors);\r\nbegin\r\n Anchors := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxImage.ControlSetCxProperties(Value: TCxDynControlWrapper);\r\nbegin\r\n Properties.Center := True;\r\n Style.LookAndFeel.Assign(Value.LookAndFeel);\r\n Properties.ShowFocusRect := False;\r\n if Assigned(Style.StyleController) then\r\n begin\r\n Style.StyleController := Value.StyleController;\r\n Style.StyleController.Style.BorderStyle := ebsNone;\r\n end;\r\nend;\r\n\r\n//=== { TJvDynControlCxScrollBox } ===========================================\r\n\r\nfunction TJvDynControlCxScrollBox.ControlGetCaption: string;\r\nbegin\r\n Result := Caption;\r\nend;\r\n\r\nprocedure TJvDynControlCxScrollBox.ControlSetAnchors(Value: TAnchors);\r\nbegin\r\n Anchors := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxScrollBox.ControlSetDefaultProperties;\r\nbegin\r\nend;\r\n\r\nprocedure TJvDynControlCxScrollBox.ControlSetCaption(const Value: string);\r\nbegin\r\n if Caption <> Value then\r\n Caption := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxScrollBox.ControlSetTabOrder(Value: Integer);\r\nbegin\r\n TabOrder := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxScrollBox.ControlSetOnEnter(Value: TNotifyEvent);\r\nbegin\r\n OnEnter := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxScrollBox.ControlSetOnExit(Value: TNotifyEvent);\r\nbegin\r\n OnExit := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxScrollBox.ControlSetOnClick(Value: TNotifyEvent);\r\nbegin\r\nend;\r\n\r\nprocedure TJvDynControlCxScrollBox.ControlSetHint(const Value: string);\r\nbegin\r\n Hint := Value;\r\nend;\r\n\r\n//=== { TJvDynControlCxLabel } ===========================================\r\n\r\nfunction TJvDynControlCxLabel.ControlGetCaption: string;\r\nbegin\r\n Result := Caption;\r\nend;\r\n\r\nprocedure TJvDynControlCxLabel.ControlSetAnchors(Value: TAnchors);\r\nbegin\r\n Anchors := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxLabel.ControlSetDefaultProperties;\r\nbegin\r\n AutoSize := False;\r\n Transparent := True;\r\n Style.BorderStyle := ebsNone;\r\nend;\r\n\r\nprocedure TJvDynControlCxLabel.ControlSetCaption(const Value: string);\r\nbegin\r\n if Caption <> Value then\r\n Caption := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxLabel.ControlSetTabOrder(Value: Integer);\r\nbegin\r\nend;\r\n\r\nprocedure TJvDynControlCxLabel.ControlSetOnEnter(Value: TNotifyEvent);\r\nbegin\r\nend;\r\n\r\nprocedure TJvDynControlCxLabel.ControlSetOnExit(Value: TNotifyEvent);\r\nbegin\r\nend;\r\n\r\nprocedure TJvDynControlCxLabel.ControlSetOnClick(Value: TNotifyEvent);\r\nbegin\r\nend;\r\n\r\nprocedure TJvDynControlCxLabel.ControlSetHint(const Value: string);\r\nbegin\r\n Hint := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxLabel.ControlSetFocusControl(Value: TWinControl);\r\nbegin\r\n FocusControl := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxLabel.ControlSetWordWrap(Value: Boolean);\r\nbegin\r\n Properties.WordWrap := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxLabel.ControlSetCxProperties(Value: TCxDynControlWrapper);\r\nbegin\r\n Style.LookAndFeel.Assign(Value.LookAndFeel);\r\n Style.StyleController := Value.StyleController;\r\nend;\r\n\r\nprocedure TJvDynControlCxLabel.ControlSetAlign(Value: TAlign);\r\nbegin\r\n Align := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxLabel.ControlSetAutoSize(Value: Boolean);\r\nbegin\r\n AutoSize := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxLabel.ControlSetColor(Value: TColor);\r\nbegin\r\n Style.Color := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxLabel.ControlSetParentColor(Value: Boolean);\r\nbegin\r\n ParentColor := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxLabel.ControlSetAlignment(Value: TAlignment);\r\nbegin\r\n Properties.Alignment.Horz := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxLabel.ControlSetFont(Value: TFont);\r\nbegin\r\n Font.Assign(Value);\r\nend;\r\n\r\nfunction TJvDynControlCxLabel.ControlGetFont: TFont;\r\nbegin\r\n Result := Font;\r\nend;\r\n\r\n//=== { TJvDynControlCxStaticText } ===========================================\r\n\r\nfunction TJvDynControlCxStaticText.ControlGetCaption: string;\r\nbegin\r\n Result := Caption;\r\nend;\r\n\r\nprocedure TJvDynControlCxStaticText.ControlSetAnchors(Value: TAnchors);\r\nbegin\r\n Anchors := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxStaticText.ControlSetDefaultProperties;\r\nbegin\r\n AutoSize := False;\r\n Transparent := True;\r\n Style.BorderStyle := ebsNone;\r\nend;\r\n\r\nprocedure TJvDynControlCxStaticText.ControlSetCaption(const Value: string);\r\nbegin\r\n if Caption <> Value then\r\n Caption := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxStaticText.ControlSetTabOrder(Value: Integer);\r\nbegin\r\nend;\r\n\r\nprocedure TJvDynControlCxStaticText.ControlSetOnEnter(Value: TNotifyEvent);\r\nbegin\r\nend;\r\n\r\nprocedure TJvDynControlCxStaticText.ControlSetOnExit(Value: TNotifyEvent);\r\nbegin\r\nend;\r\n\r\nprocedure TJvDynControlCxStaticText.ControlSetOnClick(Value: TNotifyEvent);\r\nbegin\r\nend;\r\n\r\nprocedure TJvDynControlCxStaticText.ControlSetHint(const Value: string);\r\nbegin\r\n Hint := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxStaticText.ControlSetCxProperties(Value: TCxDynControlWrapper);\r\nbegin\r\n Style.LookAndFeel.Assign(Value.LookAndFeel);\r\n Style.StyleController := Value.StyleController;\r\nend;\r\n\r\nprocedure TJvDynControlCxStaticText.ControlSetAlign(Value: TAlign);\r\nbegin\r\n Align := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxStaticText.ControlSetAutoSize(Value: Boolean);\r\nbegin\r\n AutoSize := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxStaticText.ControlSetColor(Value: TColor);\r\nbegin\r\n Style.Color := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxStaticText.ControlSetParentColor(Value: Boolean);\r\nbegin\r\n ParentColor := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxStaticText.ControlSetAlignment(Value: TAlignment);\r\nbegin\r\n Properties.Alignment.Horz := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxStaticText.ControlSetFont(Value: TFont);\r\nbegin\r\n Font.Assign(Value);\r\nend;\r\n\r\nfunction TJvDynControlCxStaticText.ControlGetFont: TFont;\r\nbegin\r\n Result := Font;\r\nend;\r\n\r\n\r\n//=== { TJvDynControlCxButton } ===========================================\r\n\r\nfunction TJvDynControlCxButton.ControlGetCaption: string;\r\nbegin\r\n Result := Caption;\r\nend;\r\n\r\nprocedure TJvDynControlCxButton.ControlSetDefaultProperties;\r\nbegin\r\nend;\r\n\r\nprocedure TJvDynControlCxButton.ControlSetCaption(const Value: string);\r\nbegin\r\n if Caption <> Value then\r\n Caption := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxButton.ControlSetTabOrder(Value: Integer);\r\nbegin\r\nend;\r\n\r\nprocedure TJvDynControlCxButton.ControlSetOnEnter(Value: TNotifyEvent);\r\nbegin\r\nend;\r\n\r\nprocedure TJvDynControlCxButton.ControlSetOnExit(Value: TNotifyEvent);\r\nbegin\r\nend;\r\n\r\nprocedure TJvDynControlCxButton.ControlSetOnClick(Value: TNotifyEvent);\r\nbegin\r\n OnClick := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxButton.ControlSetHint(const Value: string);\r\nbegin\r\n Hint := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxButton.ControlSetGlyph(Value: TBitmap);\r\nbegin\r\n Glyph.Assign(Value);\r\nend;\r\n\r\nprocedure TJvDynControlCxButton.ControlSetNumGlyphs(Value: Integer);\r\nbegin\r\n NumGlyphs := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxButton.ControlSetLayout(Value: TButtonLayout);\r\nbegin\r\n Layout := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxButton.ControlSetDefault(Value: Boolean);\r\nbegin\r\n Default := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxButton.ControlSetCancel(Value: Boolean);\r\nbegin\r\n Cancel := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxButton.ControlSetAction(Value: TCustomAction);\r\nbegin\r\n Action := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxButton.ControlSetAnchors(Value: TAnchors);\r\nbegin\r\n Anchors := Value;\r\nend;\r\n\r\n\r\nprocedure TJvDynControlCxButton.ControlSetCxProperties(Value: TCxDynControlWrapper);\r\nbegin\r\n LookAndFeel.Assign(Value.LookAndFeel);\r\nend;\r\n\r\n//=== { TJvDynControlCxTreeView } ============================================\r\n\r\nprocedure TJvDynControlCxTreeView.ControlSetDefaultProperties;\r\nbegin\r\nend;\r\n\r\nprocedure TJvDynControlCxTreeView.ControlSetTabOrder(Value: Integer);\r\nbegin\r\n TabOrder := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxTreeView.ControlSetOnEnter(Value: TNotifyEvent);\r\nbegin\r\n OnEnter := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxTreeView.ControlSetOnExit(Value: TNotifyEvent);\r\nbegin\r\n OnExit := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxTreeView.ControlSetOnClick(Value: TNotifyEvent);\r\nbegin\r\n OnClick := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxTreeView.ControlSetHint(const Value: string);\r\nbegin\r\n Hint := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxTreeView.ControlSetReadOnly(Value: Boolean);\r\nbegin\r\n ReadOnly := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxTreeView.ControlSetAutoExpand(Value: Boolean);\r\nbegin\r\n AutoExpand := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxTreeView.ControlSetHotTrack(Value: Boolean);\r\nbegin\r\n HotTrack := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxTreeView.ControlSetShowHint(Value: Boolean);\r\nbegin\r\n ShowHint := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxTreeView.ControlSetShowLines(Value: Boolean);\r\nbegin\r\n ShowLines := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxTreeView.ControlSetShowRoot(Value: Boolean);\r\nbegin\r\n ShowRoot := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxTreeView.ControlSetToolTips(Value: Boolean);\r\nbegin\r\n ToolTips := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxTreeView.ControlSetItems(Value: TTreeNodes);\r\nbegin\r\n// Items.Assign(Value);\r\n Items := Value;\r\nend;\r\n\r\nfunction TJvDynControlCxTreeView.ControlGetItems: TTreeNodes;\r\nbegin\r\n Result := Items;\r\nend;\r\n\r\nfunction TJvDynControlCxTreeView.ControlGetOnMouseDown: TMouseEvent;\r\nbegin\r\n Result := OnMouseDown;\r\nend;\r\n\r\nfunction TJvDynControlCxTreeView.ControlGetOnMouseEnter: TNotifyEvent;\r\nbegin\r\n {$IFDEF DELPHI2007_UP}\r\n Result := OnMouseEnter;\r\n {$ENDIF DELPHI2007_UP}\r\nend;\r\n\r\nfunction TJvDynControlCxTreeView.ControlGetOnMouseLeave: TNotifyEvent;\r\nbegin\r\n {$IFDEF DELPHI2007_UP}\r\n Result := OnMouseLeave;\r\n {$ENDIF DELPHI2007_UP}\r\nend;\r\n\r\nfunction TJvDynControlCxTreeView.ControlGetOnMouseMove: TMouseMoveEvent;\r\nbegin\r\n Result := OnMouseMove;\r\nend;\r\n\r\nfunction TJvDynControlCxTreeView.ControlGetOnMouseUp: TMouseEvent;\r\nbegin\r\n Result := OnMouseUp;\r\nend;\r\n\r\nprocedure TJvDynControlCxTreeView.ControlSetImages(Value: TCustomImageList);\r\nbegin\r\n Images.Assign(Value);\r\nend;\r\n\r\nprocedure TJvDynControlCxTreeView.ControlSetStateImages(Value: TCustomImageList);\r\nbegin\r\n StateImages.Assign(Value);\r\nend;\r\n\r\nprocedure TJvDynControlCxTreeView.ControlSetAnchors(Value: TAnchors);\r\nbegin\r\n Anchors := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxTreeView.ControlSetOnChange(Value: TTVChangedEvent);\r\nbegin\r\n OnChange := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxTreeView.ControlSetSortType(Value: TSortType);\r\nbegin\r\n SortType := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxTreeView.ControlSetOnDblClick(Value: TNotifyEvent);\r\nbegin\r\n OnDblClick := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxTreeView.ControlSetCxProperties(Value: TCxDynControlWrapper);\r\nbegin\r\n LookAndFeel.Assign(Value.LookAndFeel);\r\nend;\r\n\r\nprocedure TJvDynControlCxTreeView.ControlSetOnChanging(Value: TTVChangingEvent);\r\nbegin\r\n OnChanging := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxTreeView.ControlSortItems;\r\nbegin\r\n AlphaSort;\r\nend;\r\n\r\nfunction TJvDynControlCxTreeView.ControlGetSelected: TTreeNode;\r\nbegin\r\n Result := Selected;\r\nend;\r\n\r\nprocedure TJvDynControlCxTreeView.ControlSetOnMouseDown(const Value: TMouseEvent);\r\nbegin\r\n OnMouseDown := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxTreeView.ControlSetOnMouseEnter(const Value: TNotifyEvent);\r\nbegin\r\n {$IFDEF DELPHI2007_UP}\r\n OnMouseEnter := Value;\r\n {$ENDIF DELPHI2007_UP}\r\nend;\r\n\r\nprocedure TJvDynControlCxTreeView.ControlSetOnMouseLeave(const Value: TNotifyEvent);\r\nbegin\r\n {$IFDEF DELPHI2007_UP}\r\n OnMouseEnter := Value;\r\n {$ENDIF DELPHI2007_UP}\r\nend;\r\n\r\nprocedure TJvDynControlCxTreeView.ControlSetOnMouseMove(const Value: TMouseMoveEvent);\r\nbegin\r\n OnMouseMove := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxTreeView.ControlSetOnMouseUp(const Value: TMouseEvent);\r\nbegin\r\n OnMouseUp := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxTreeView.ControlSetSelected(const Value: TTreeNode);\r\nbegin\r\n Selected := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxProgressBar.ControlSetAlign(Value: TAlign);\r\nbegin\r\n Align := Value;\r\nend;\r\n\r\n//=== { TJvDynControlCxProgressbar } =========================================\r\n\r\nprocedure TJvDynControlCxProgressbar.ControlSetDefaultProperties;\r\nbegin\r\n Properties.ShowText := False;\r\n Properties.AnimationSpeed := 3;\r\nend;\r\n\r\nprocedure TJvDynControlCxProgressbar.ControlSetCaption(const Value: string);\r\nbegin\r\n if Caption <> Value then\r\n Caption := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxProgressbar.ControlSetTabOrder(Value: Integer);\r\nbegin\r\n TabOrder := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxProgressbar.ControlSetOnEnter(Value: TNotifyEvent);\r\nbegin\r\n OnEnter := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxProgressbar.ControlSetOnExit(Value: TNotifyEvent);\r\nbegin\r\n OnExit := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxProgressbar.ControlSetOnClick(Value: TNotifyEvent);\r\nbegin\r\n OnClick := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxProgressbar.ControlSetHint(const Value: string);\r\nbegin\r\n Hint := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxProgressbar.ControlSetAnchors(Value: TAnchors);\r\nbegin\r\n Anchors := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxProgressbar.ControlSetMax(Value: Integer);\r\nbegin\r\n Properties.Max := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxProgressbar.ControlSetMin(Value: Integer);\r\nbegin\r\n Properties.Min := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxProgressbar.ControlSetOrientation(Value: TProgressBarOrientation);\r\nbegin\r\n if Value = pbHorizontal then\r\n Properties.Orientation:= cxorHorizontal\r\n else\r\n Properties.Orientation:= cxorVertical;\r\nend;\r\n\r\nprocedure TJvDynControlCxProgressbar.ControlSetPosition(Value: Integer);\r\nbegin\r\n Position := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxProgressbar.ControlSetSmooth(Value: Boolean);\r\nbegin\r\n //Properties.Smooth := Value;\r\n if Value then\r\n Properties.BarStyle := cxbsSolid\r\n else\r\n Properties.BarStyle := cxbsLEDs;\r\nend;\r\n\r\nprocedure TJvDynControlCxProgressbar.ControlSetStep(Value: Integer);\r\nbegin\r\n// Step := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxProgressbar.ControlSetCxProperties(Value: TCxDynControlWrapper);\r\nbegin\r\n LookAndFeel.Assign(Value.LookAndFeel);\r\nend;\r\n\r\nprocedure TJvDynControlCxProgressBar.ControlSetMarquee(Value: Boolean);\r\nbegin\r\n Properties.Marquee := Value;\r\nend;\r\n\r\n\r\n\r\n//=== { TJvDynControlCxRadioButton } ===========================================\r\n\r\nfunction TJvDynControlCxRadioButton.ControlGetCaption: string;\r\nbegin\r\n Result := Caption;\r\nend;\r\n\r\nprocedure TJvDynControlCxRadioButton.ControlSetDefaultProperties;\r\nbegin\r\nend;\r\n\r\nprocedure TJvDynControlCxRadioButton.ControlSetCaption(const Value: string);\r\nbegin\r\n if Caption <> Value then\r\n Caption := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxRadioButton.ControlSetTabOrder(Value: Integer);\r\nbegin\r\n TabOrder := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxRadioButton.ControlSetOnEnter(Value: TNotifyEvent);\r\nbegin\r\n OnEnter := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxRadioButton.ControlSetOnExit(Value: TNotifyEvent);\r\nbegin\r\n OnExit := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxRadioButton.ControlSetOnClick(Value: TNotifyEvent);\r\nbegin\r\n OnClick := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxRadioButton.ControlSetHint(const Value: string);\r\nbegin\r\n Hint := Value;\r\nend;\r\n\r\n// IJvDynControlData\r\nprocedure TJvDynControlCxRadioButton.ControlSetOnChange(Value: TNotifyEvent);\r\nbegin\r\n OnClick := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxRadioButton.ControlSetValue(Value: Variant);\r\nbegin\r\n Checked := JvDynControlVariantToBoolean(Value);\r\nend;\r\n\r\nfunction TJvDynControlCxRadioButton.ControlGetValue: Variant;\r\nbegin\r\n Result := Checked;\r\nend;\r\n\r\nprocedure TJvDynControlCxRadioButton.ControlSetAnchors(Value: TAnchors);\r\nbegin\r\n Anchors := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxRadioButton.ControlSetCxProperties(Value: TCxDynControlWrapper);\r\nbegin\r\n LookAndFeel.Assign(Value.LookAndFeel);\r\nend;\r\n\r\n\r\n//=== { TJvDynControlCxTabControl } ==========================================\r\n\r\nprocedure TJvDynControlCxTabControl.ControlSetDefaultProperties;\r\nbegin\r\nend;\r\n\r\nprocedure TJvDynControlCxTabControl.ControlSetHint(const Value: string);\r\nbegin\r\n Hint := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxTabControl.ControlSetOnChangeTab(OnChangeEvent: TNotifyEvent);\r\nbegin\r\n OnChange := OnChangeEvent;\r\nend;\r\n\r\nprocedure TJvDynControlCxTabControl.ControlSetOnChangingTab(OnChangingEvent: TTabChangingEvent);\r\nbegin\r\n OnChanging := OnChangingEvent;\r\nend;\r\n\r\nprocedure TJvDynControlCxTabControl.ControlSetOnClick(Value: TNotifyEvent);\r\nbegin\r\n OnClick := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxTabControl.ControlSetOnEnter(Value: TNotifyEvent);\r\nbegin\r\n OnEnter := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxTabControl.ControlSetOnExit(Value: TNotifyEvent);\r\nbegin\r\n OnExit := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxTabControl.ControlSetTabIndex(Index: Integer);\r\nbegin\r\n TabIndex := Index;\r\nend;\r\n\r\nprocedure TJvDynControlCxTabControl.ControlSetTabOrder(Value: Integer);\r\nbegin\r\n TabOrder := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxTabControl.ControlCreateTab(const AName: string);\r\nbegin\r\n Tabs.Add(AName);\r\nend;\r\n\r\nfunction TJvDynControlCxTabControl.ControlGetTabIndex: Integer;\r\nbegin\r\n Result := TabIndex;\r\nend;\r\n\r\nprocedure TJvDynControlCxTabControl.ControlSetAnchors(Value: TAnchors);\r\nbegin\r\n Anchors := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxTabControl.ControlSetCxProperties(Value: TCxDynControlWrapper);\r\nbegin\r\n LookAndFeel.Assign(Value.LookAndFeel);\r\nend;\r\n\r\nprocedure TJvDynControlCxTabControl.ControlSetMultiLine(Value: Boolean);\r\nbegin\r\n MultiLine := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxTabControl.ControlSetScrollOpposite(Value: Boolean);\r\nbegin\r\n ScrollOpposite := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxTabControl.ControlSetHotTrack(Value: Boolean);\r\nbegin\r\n HotTrack := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxTabControl.ControlSetRaggedRight(Value: Boolean);\r\nbegin\r\n RaggedRight := Value;\r\nend;\r\n\r\n\r\n//=== { TJvDynControlCxPageControl } =========================================\r\n\r\nprocedure TJvDynControlCxPageControl.ControlSetDefaultProperties;\r\nbegin\r\nend;\r\n\r\nprocedure TJvDynControlCxPageControl.ControlSetTabOrder(Value: Integer);\r\nbegin\r\n TabOrder := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxPageControl.ControlSetOnEnter(Value: TNotifyEvent);\r\nbegin\r\n OnEnter := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxPageControl.ControlSetOnExit(Value: TNotifyEvent);\r\nbegin\r\n OnExit := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxPageControl.ControlSetOnClick(Value: TNotifyEvent);\r\nbegin\r\n OnClick := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxPageControl.ControlSetHint(const Value: string);\r\nbegin\r\n Hint := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxPageControl.ControlSetAnchors(Value: TAnchors);\r\nbegin\r\n Anchors := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxPageControl.ControlCreateTab(const AName: string);\r\nvar\r\n TabSheet: TcxTabSheet;\r\nbegin\r\n TabSheet := TcxTabSheet.Create(Self);\r\n TabSheet.Caption := AName;\r\n TabSheet.PageControl := Self;\r\n TabSheet.Parent := Self;\r\nend;\r\n\r\nprocedure TJvDynControlCxPageControl.ControlSetOnChangeTab(OnChangeEvent: TNotifyEvent);\r\nbegin\r\n OnChange := OnChangeEvent;\r\nend;\r\n\r\nprocedure TJvDynControlCxPageControl.ControlSetOnChangingTab(OnChangingEvent: TTabChangingEvent);\r\nbegin\r\n OnChanging := OnChangingEvent;\r\nend;\r\n\r\nprocedure TJvDynControlCxPageControl.ControlSetTabIndex(Index: Integer);\r\nbegin\r\n TabIndex := Index;\r\nend;\r\n\r\nfunction TJvDynControlCxPageControl.ControlGetTabIndex: Integer;\r\nbegin\r\n Result := TabIndex;\r\nend;\r\n\r\nprocedure TJvDynControlCxPageControl.ControlSetMultiLine(Value: Boolean);\r\nbegin\r\n MultiLine := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxPageControl.ControlSetScrollOpposite(Value: Boolean);\r\nbegin\r\n ScrollOpposite := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxPageControl.ControlSetHotTrack(Value: Boolean);\r\nbegin\r\n HotTrack := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxPageControl.ControlSetRaggedRight(Value: Boolean);\r\nbegin\r\n RaggedRight := Value;\r\nend;\r\n\r\nfunction TJvDynControlCxPageControl.ControlGetPage(const PageName: string): TWinControl;\r\nvar\r\n I: Integer;\r\nbegin\r\n I := Tabs.IndexOf(PageName);\r\n if (I >= 0) and (I < PageCount) then\r\n Result := TWinControl(Pages[I])\r\n else\r\n Result := nil;\r\nend;\r\n\r\nprocedure TJvDynControlCxPageControl.ControlSetCxProperties(Value: TCxDynControlWrapper);\r\nbegin\r\n LookAndFeel.Assign(Value.LookAndFeel);\r\nend;\r\n\r\n\r\n//=== { TJvDynControlEngineDevExpCx } ========================================\r\n\r\nconstructor TJvDynControlEngineDevExpCx.Create;\r\nbegin\r\n inherited Create;\r\n FCxProperties := TCxDynControlWrapper.Create;\r\nend;\r\n\r\ndestructor TJvDynControlEngineDevExpCx.Destroy;\r\nbegin\r\n FreeAndNil(FCxProperties);\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvDynControlEngineDevExpCx.SetcxProperties(Value: TCxDynControlWrapper);\r\nbegin\r\n if Value is TCxDynControlWrapper then\r\n begin\r\n FCxProperties.LookAndFeel := Value.LookAndFeel;\r\n FCxProperties.StyleController := Value.StyleController;\r\n end;\r\nend;\r\n\r\nprocedure TJvDynControlEngineDevExpCx.RegisterControls;\r\nbegin\r\n RegisterControlType(jctLabel, TJvDynControlCxLabel);\r\n RegisterControlType(jctStaticText, TJvDynControlCxStaticText);\r\n RegisterControlType(jctButton, TJvDynControlCxButton);\r\n RegisterControlType(jctRadioButton, TJvDynControlCxRadioButton);\r\n RegisterControlType(jctScrollBox, TJvDynControlCxScrollBox);\r\n RegisterControlType(jctGroupBox, TJvDynControlCxGroupBox);\r\n RegisterControlType(jctPanel, TJvDynControlCxPanel);\r\n RegisterControlType(jctImage, TJvDynControlCxImage);\r\n RegisterControlType(jctCheckBox, TJvDynControlCxCheckBox);\r\n RegisterControlType(jctComboBox, TJvDynControlCxComboBox);\r\n RegisterControlType(jctListBox, TJvDynControlCxListBox);\r\n RegisterControlType(jctCheckListBox, TJvDynControlCxCheckListBox);\r\n RegisterControlType(jctCheckComboBox, TJvDynControlCxCheckComboBox);\r\n RegisterControlType(jctRadioGroup, TJvDynControlCxRadioGroup);\r\n RegisterControlType(jctDateTimeEdit, TJvDynControlCxDateTimeEdit);\r\n RegisterControlType(jctTimeEdit, TJvDynControlCxTimeEdit);\r\n RegisterControlType(jctDateEdit, TJvDynControlCxDateEdit);\r\n RegisterControlType(jctEdit, TJvDynControlCxMaskEdit);\r\n RegisterControlType(jctCalculateEdit, TJvDynControlCxCalcEdit);\r\n RegisterControlType(jctSpinEdit, TJvDynControlCxSpinEdit);\r\n RegisterControlType(jctDirectoryEdit, TJvDynControlCxDirectoryEdit);\r\n RegisterControlType(jctFileNameEdit, TJvDynControlCxFileNameEdit);\r\n RegisterControlType(jctMemo, TJvDynControlCxMemo);\r\n RegisterControlType(jctRichEdit, TJvDynControlCxRichEdit);\r\n RegisterControlType(jctButtonEdit, TJvDynControlCxButtonEdit);\r\n RegisterControlType(jctTreeVIew, TJvDynControlCxTreeView);\r\n RegisterControlType(jctProgressbar, TJvDynControlCxProgressbar);\r\n RegisterControlType(jctTabControl, TJvDynControlCxTabControl);\r\n RegisterControlType(jctPageControl, TJvDynControlCxPageControl);\r\n {$IFDEF USE_3RDPARTY_DEVEXPRESS_CXVERTICALGRID}\r\n RegisterControlType(jctRTTIInspector, TJvDynControlCxRTTIInspectorControl);\r\n {$ELSE}\r\n //RegisterControlType(jctRTTIInspector, TJvDynControlCxRTTIInspectorControl);\r\n {$ENDIF}\r\n RegisterControlType(jctColorComboBox, TJvDynControlCxColorComboBox);\r\nend;\r\n\r\nfunction TJvDynControlEngineDevExpCx.CreateControlClass(AControlClass: TControlClass; AOwner: TComponent; AParentControl: TWinControl; AControlName: string): TControl;\r\nvar\r\n Control: TControl;\r\nbegin\r\n Control := inherited CreateControlClass(AControlClass, AOwner, AParentControl, AControlName);\r\n if Supports(Control, IJvDynControlDevExpCx) then\r\n with Control as IJvDynControlDevExpCx do\r\n ControlSetCxProperties(cxProperties);\r\n Result := Control;\r\nend;\r\n\r\n//=== { DynControlEngineDevExpCx } ===========================================\r\n\r\nprocedure SetDynControlEngineDevExpCxDefault;\r\nbegin\r\n SetDefaultDynControlEngine(IntDynControlEngineDevExpCx);\r\nend;\r\n\r\nfunction DynControlEngineDevExpCx: TJvDynControlEngineDevExpCx;\r\nbegin\r\n Result := IntDynControlEngineDevExpCx;\r\nend;\r\n\r\n{$IFDEF USE_3RDPARTY_DEVEXPRESS_CXVERTICALGRID}\r\n\r\n//=== { TJvDynControlCxRTTIInspectorControl } ========================================\r\n\r\nprocedure TJvDynControlCxRTTIInspectorControl.ControlSetDefaultProperties;\r\nbegin\r\n OnFilterProperty := InspectorOnFilterProperty;\r\n OnItemChanged := InspectorOnItemChanged;\r\n OnDrawRowHeader := ReplaceOnDrawRowHeader;\r\nend;\r\n\r\nfunction TJvDynControlCxRTTIInspectorControl.ControlGetCurrentPropertyName:\r\n string;\r\nbegin\r\n if Assigned (FocusedRow) and Assigned(TcxPropertyRow(FocusedRow).PropertyEditor) then\r\n Result := TcxPropertyRow(FocusedRow).PropertyEditor.GetName\r\n else\r\n Result := '';\r\nend;\r\n\r\nprocedure TJvDynControlCxRTTIInspectorControl.ControlSetTabOrder(Value: Integer);\r\nbegin\r\n TabOrder := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxRTTIInspectorControl.ControlSetOnEnter(Value: TNotifyEvent);\r\nbegin\r\n OnEnter := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxRTTIInspectorControl.ControlSetOnExit(Value: TNotifyEvent);\r\nbegin\r\n OnExit := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxRTTIInspectorControl.ControlSetOnClick(Value: TNotifyEvent);\r\nbegin\r\n OnClick := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxRTTIInspectorControl.ControlSetHint(const Value: string);\r\nbegin\r\n Hint := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxRTTIInspectorControl.ControlSetAnchors(Value: TAnchors);\r\nbegin\r\n Anchors := Value;\r\nend;\r\n\r\nfunction TJvDynControlCxRTTIInspectorControl.ControlGetInspectedObject: TObject;\r\nbegin\r\n Result := InspectedObject;\r\nend;\r\n\r\nfunction TJvDynControlCxRTTIInspectorControl.ControlGetOnDisplayProperty:\r\n TJvDynControlInspectorControlOnDisplayPropertyEvent;\r\nbegin\r\n Result := fOnDisplayProperty;\r\nend;\r\n\r\nfunction TJvDynControlCxRTTIInspectorControl.ControlGetOnTranslatePropertyName:\r\n TJvDynControlInspectorControlOnTranslatePropertyNameEvent;\r\nbegin\r\n Result := fOnTranslatePropertyName;\r\nend;\r\n\r\nfunction TJvDynControlCxRTTIInspectorControl.ControlGetVisibleItemsCount: Integer;\r\nbegin\r\n Result := Rows.Count;\r\nend;\r\n\r\nfunction TJvDynControlCxRTTIInspectorControl.ControlIsPropertySupported(const\r\n aPropertyName : string): Boolean;\r\nbegin\r\n if Assigned(InspectedObject) then\r\n if IsPublishedProp(InspectedObject, aPropertyName) then\r\n if PropIsType(InspectedObject, aPropertyName, tkClass) then\r\n Result := GetObjectProp(InspectedObject, aPropertyName) is TStringList\r\n else\r\n Result := True\r\n else\r\n Result := False\r\n else\r\n Result := True;\r\nend;\r\n\r\nprocedure TJvDynControlCxRTTIInspectorControl.ControlSaveEditorValues;\r\nbegin\r\n HideEdit;\r\nend;\r\n\r\nprocedure TJvDynControlCxRTTIInspectorControl.ControlSetCxProperties(Value:\r\n TCxDynControlWrapper);\r\nbegin\r\n LookAndFeel.Assign(Value.LookAndFeel);\r\nend;\r\n\r\nprocedure TJvDynControlCxRTTIInspectorControl.ControlSetInspectedObject(const\r\n Value: TObject);\r\nbegin\r\n if Value is TPersistent then\r\n InspectedObject := TPersistent(Value)\r\n else\r\n InspectedObject := nil;\r\n OldPropertyName := '';\r\n\r\nend;\r\n\r\nprocedure TJvDynControlCxRTTIInspectorControl.ControlSetOnDisplayProperty(const\r\n Value: TJvDynControlInspectorControlOnDisplayPropertyEvent);\r\nbegin\r\n fOnDisplayProperty := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxRTTIInspectorControl.ControlSetOnTranslatePropertyName(\r\n const Value: TJvDynControlInspectorControlOnTranslatePropertyNameEvent);\r\nbegin\r\n fOnTranslatePropertyName := Value;\r\nend;\r\n\r\nfunction TJvDynControlCxRTTIInspectorControl.GetControlDividerWidth: Integer;\r\nbegin\r\n Result := OptionsView.RowHeaderWidth;\r\nend;\r\n\r\nprocedure TJvDynControlCxRTTIInspectorControl.InspectorOnItemChanged(Sender:\r\n TObject; AOldRow: TcxCustomRow; AOldCellIndex: Integer);\r\nvar\r\n NewPropertyName: string;\r\nbegin\r\n NewPropertyName := ControlGetCurrentPropertyName;\r\n if NewPropertyName = '' then\r\n Exit;\r\n if Assigned(fControlOnPropertyChange) then\r\n fControlOnPropertyChange(OldPropertyName, NewPropertyName);\r\n OldPropertyName := NewPropertyName;\r\nend;\r\n\r\nfunction TJvDynControlCxRTTIInspectorControl.GetControlOnPropertyChange:\r\n TJvDynControlInspectorControlOnPropertyChangeEvent;\r\nbegin\r\n Result := fControlOnPropertyChange;\r\nend;\r\n\r\nprocedure TJvDynControlCxRTTIInspectorControl.InspectorOnFilterProperty(Sender:\r\n TObject; const PropertyName: string; var Accept: Boolean);\r\nbegin\r\n if Assigned(fonDisplayProperty) And IsPublishedProp(InspectedObject, PropertyName) then\r\n Accept := fOnDisplayProperty(PropertyName) and ControlIsPropertySupported(PropertyName);\r\nend;\r\n\r\nprocedure TJvDynControlCxRTTIInspectorControl.ReplaceOnDrawRowHeader(Sender:\r\n TObject; ACanvas: TcxCanvas; APainter: TcxvgPainter; AHeaderViewInfo:\r\n TcxCustomRowHeaderInfo; var Done: Boolean);\r\nbegin\r\n if (AHeaderViewInfo is TcxEditorRowHeaderInfo) and Assigned(fOnTranslatePropertyName)then\r\n TcxEditorRowHeaderInfo(AHeaderViewInfo).CaptionsInfo[0].Caption := fOnTranslatePropertyName(TcxEditorRowHeaderInfo(AHeaderViewInfo).CaptionsInfo[0].Caption);\r\nend;\r\n\r\nprocedure TJvDynControlCxRTTIInspectorControl.SetControlDividerWidth(const\r\n Value: Integer);\r\nbegin\r\n OptionsView.RowHeaderWidth := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxRTTIInspectorControl.SetControlOnPropertyChange(const\r\n Value: TJvDynControlInspectorControlOnPropertyChangeEvent);\r\nbegin\r\n fControlOnPropertyChange := Value;\r\nend;\r\n\r\nfunction TJvDynControlCxColorComboBox.ControlGetColorName(AColor: TColor):\r\n string;\r\nbegin\r\n Result := '';\r\nend;\r\n\r\nfunction TJvDynControlCxColorComboBox.ControlGetSelectedColor: TColor;\r\nbegin\r\n Result := ColorValue;\r\nend;\r\n\r\nprocedure TJvDynControlCxColorComboBox.ControlSetDefaultProperties;\r\nbegin\r\nend;\r\n\r\nprocedure TJvDynControlCxColorComboBox.ControlSetTabOrder(Value: Integer);\r\nbegin\r\n TabOrder := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxColorComboBox.ControlSetOnEnter(Value: TNotifyEvent);\r\nbegin\r\n OnEnter := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxColorComboBox.ControlSetOnExit(Value: TNotifyEvent);\r\nbegin\r\n OnExit := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxColorComboBox.ControlSetOnChange(Value: TNotifyEvent);\r\nbegin\r\n Properties.OnChange := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxColorComboBox.ControlSetOnClick(Value: TNotifyEvent);\r\nbegin\r\nend;\r\n\r\nprocedure TJvDynControlCxColorComboBox.ControlSetHint(const Value: string);\r\nbegin\r\n Hint := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxColorComboBox.ControlSetAnchors(Value: TAnchors);\r\nbegin\r\n Anchors := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxColorComboBox.ControlSetValue(Value: Variant);\r\nbegin\r\n Text := VarToStr(Value);\r\nend;\r\n\r\nfunction TJvDynControlCxColorComboBox.ControlGetValue: Variant;\r\nbegin\r\n Result := Text;\r\nend;\r\n\r\nprocedure TJvDynControlCxColorComboBox.ControlSetCxProperties(Value:\r\n TCxDynControlWrapper);\r\nbegin\r\n LookAndFeel.Assign(Value.LookAndFeel);\r\nend;\r\n\r\nprocedure TJvDynControlCxColorComboBox.ControlSetSelectedColor(const Value:\r\n TColor);\r\nbegin\r\n ColorValue := Value;\r\nend;\r\n\r\nfunction TJvDynControlCxColorComboBox.GetControlDefaultColor: TColor;\r\nbegin\r\n Result := Properties.DefaultColor;\r\nend;\r\n\r\nprocedure TJvDynControlCxColorComboBox.SetControlDefaultColor(const Value:\r\n TColor);\r\nbegin\r\n Properties.DefaultColor := Value;\r\nend;\r\n\r\n//=== { TJvDynControlCxCheckComboBox } ========================================\r\n\r\nconstructor TJvDynControlCxCheckComboBox.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FIntItems := TStringList.Create;\r\nend;\r\n\r\ndestructor TJvDynControlCxCheckComboBox.Destroy;\r\nbegin\r\n FIntItems.Free;\r\n Inherited Destroy;\r\nend;\r\n\r\nprocedure TJvDynControlCxCheckComboBox.ControlSetDefaultProperties;\r\nbegin\r\n Properties.EditValueFormat := cvfCaptions;\r\n Properties.ShowEmptyText := False;\r\nend;\r\n\r\nprocedure TJvDynControlCxCheckComboBox.ControlSetReadOnly(Value: Boolean);\r\nbegin\r\n Properties.ReadOnly := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxCheckComboBox.ControlSetTabOrder(Value: Integer);\r\nbegin\r\n TabOrder := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxCheckComboBox.ControlSetOnEnter(Value: TNotifyEvent);\r\nbegin\r\n OnEnter := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxCheckComboBox.ControlSetOnExit(Value: TNotifyEvent);\r\nbegin\r\n OnExit := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxCheckComboBox.ControlSetOnChange(Value: TNotifyEvent);\r\nbegin\r\n Properties.OnChange := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxCheckComboBox.ControlSetOnClick(Value: TNotifyEvent);\r\nbegin\r\n OnClick := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxCheckComboBox.ControlSetHint(const Value: string);\r\nbegin\r\n Hint := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxCheckComboBox.ControlSetValue(Value: Variant);\r\nvar\r\n ACheckStates: TcxCheckStates;\r\n I: Integer;\r\n st : tStringList;\r\nbegin\r\n// Self.Value := Value;\r\n st := tStringList.Create;\r\n Properties.Items.BeginUpdate;\r\n try\r\n st.Duplicates := dupIgnore;\r\n if Properties.Delimiter <> '' then\r\n st.Delimiter := Properties.Delimiter[1]\r\n else\r\n st.Delimiter := chr(0);\r\n {$IFDEF DELPHI2009_UP}\r\n st.StrictDelimiter := True;\r\n {$ENDIF DELPHI2009_UP}\r\n st.DelimitedText := Value;\r\n\r\n SetLength(ACheckStates, Properties.Items.Count);\r\n for i := 0 to Properties.Items.Count - 1 do\r\n if st.IndexOf(Properties.Items[I].Description) >= 0 then\r\n aCheckStates[i] := cbsChecked\r\n else\r\n aCheckStates[i] := cbsUnChecked;\r\n Self.Value := CalculateCheckStatesValue (aCheckStates, Properties.Items, Properties.EditValueFormat);\r\n finally\r\n Properties.Items.EndUpdate;\r\n St.Free;\r\n end;\r\nend;\r\n\r\nfunction TJvDynControlCxCheckComboBox.ControlGetValue: Variant;\r\nvar\r\n APCheckStates: ^TcxCheckStates;\r\n I: Integer;\r\nbegin\r\n New(APCheckStates);\r\n try\r\n CalculateCheckStates(Value, Properties.Items, Properties.EditValueFormat , APCheckStates^);\r\n for i := 0 to Properties.Items.Count - 1 do\r\n if APCheckStates^[I] = cbsChecked then\r\n if Result = '' then\r\n Result := Properties.Items[I].Description\r\n else\r\n Result := Result+Properties.Delimiter+Properties.Items[I].Description;\r\n finally\r\n Dispose(APCheckStates)\r\n end;\r\nend;\r\n\r\nprocedure TJvDynControlCxCheckComboBox.ControlSetSorted(Value: Boolean);\r\nbegin\r\n Properties.Sorted := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxCheckComboBox.ControlSetItems(Value: TStrings);\r\nvar\r\n I: Integer;\r\nbegin\r\n FIntItems.Assign(Value);\r\n Properties.Items.Clear;\r\n for I := 0 to FIntItems.Count-1 do\r\n Properties.Items.AddCheckItem (FIntItems[I]);\r\nend;\r\n\r\nfunction TJvDynControlCxCheckComboBox.ControlGetItems: TStrings;\r\nvar\r\n I: Integer;\r\nbegin\r\n FIntItems.Clear;\r\n for I := 0 to Properties.Items.Count-1 do\r\n FIntItems.Add(Properties.Items[I].Description);\r\n Result := FIntItems;\r\nend;\r\n\r\nprocedure TJvDynControlCxCheckComboBox.ControlSetOnDblClick(Value: TNotifyEvent);\r\nbegin\r\n OnDblClick := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxCheckComboBox.ControlSetCxProperties(Value: TCxDynControlWrapper);\r\nbegin\r\n Style.LookAndFeel.Assign(Value.LookAndFeel);\r\n Style.StyleController := Value.StyleController;\r\nend;\r\n\r\nfunction TJvDynControlCxCheckComboBox.ControlGetDelimiter: string;\r\nbegin\r\n Result := Properties.Delimiter;\r\nend;\r\n\r\nprocedure TJvDynControlCxCheckComboBox.ControlSetAnchors(Value: TAnchors);\r\nbegin\r\n Anchors := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxCheckComboBox.ControlSetDelimiter(Value: string);\r\nbegin\r\n Properties.Delimiter:= Value;\r\nend;\r\n\r\n{$ENDIF}\r\n\r\n{$ENDIF USE_3RDPARTY_DEVEXPRESS_CXEDITOR}\r\n\r\ninitialization\r\n {$IFDEF UNITVERSIONING}\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n {$ENDIF UNITVERSIONING}\r\n {$IFDEF USE_3RDPARTY_DEVEXPRESS_CXEDITOR}\r\n IntDynControlEngineDevExpCx := TJvDynControlEngineDevExpCx.Create;\r\n SetDefaultDynControlEngine(IntDynControlEngineDevExpCx);\r\n {$ENDIF USE_3RDPARTY_DEVEXPRESS_CXEDITOR}\r\n\r\nfinalization\r\n {$IFDEF USE_3RDPARTY_DEVEXPRESS_CXEDITOR}\r\n FreeAndNil(IntDynControlEngineDevExpCx);\r\n {$ENDIF USE_3RDPARTY_DEVEXPRESS_CXEDITOR}\r\n {$IFDEF UNITVERSIONING}\r\n UnregisterUnitVersion(HInstance);\r\n {$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvDynControlEngineDevExpCxDB.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Initial Developer of the Original Code is Jens Fudickar [jens dott fudickar att oratool dott de]\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\nJens Fudickar [jens dott fudickar att oratool dott de]\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvDynControlEngineDevExpCxDB.pas 13075 2011-06-27 22:56:21Z jfudickar $\r\n\r\nunit JvDynControlEngineDevExpCxDB;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\n{$IFNDEF USE_3RDPARTY_DEVEXPRESS_CXEDITOR}\r\n\r\n{$IFDEF UNITVERSIONING}\r\nuses\r\n JclUnitVersioning, JvDynControlEngineDevExpCx, JvDynControlEngineIntf;\r\n{$ENDIF UNITVERSIONING}\r\n\r\n{$ELSE}\r\n\r\nuses\r\n{$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n{$ENDIF UNITVERSIONING}\r\n Classes, ExtCtrls, ExtDlgs, Graphics, Buttons, Controls, Dialogs, FileCtrl,\r\n Forms, DBCtrls, DB, DBGrids, StdCtrls,\r\n cxDBEdit, cxDBNavigator,\r\n JvDynControlEngine, JvDynControlEngineDB, JvDynControlEngineIntf,\r\n JvDynControlEngineDevExpCx, JvDynControlEngineDBIntf;\r\n\r\ntype\r\n TJvDynControlCxDBEdit = class(TcxDBTextEdit, IUnknown,\r\n IJvDynControl, IJvDynControlDevExpCx, IJvDynControlData, IJvDynControlReadOnly, IJvDynControlEdit,\r\n IJvDynControlDatabase)\r\n public\r\n procedure ControlSetDefaultProperties;\r\n procedure ControlSetReadOnly(Value: Boolean);\r\n procedure ControlSetCaption(const Value: string);\r\n procedure ControlSetTabOrder(Value: Integer);\r\n procedure ControlSetHint(const Value: string);\r\n\r\n procedure ControlSetOnEnter(Value: TNotifyEvent);\r\n procedure ControlSetOnExit(Value: TNotifyEvent);\r\n procedure ControlSetOnChange(Value: TNotifyEvent);\r\n procedure ControlSetOnClick(Value: TNotifyEvent);\r\n\r\n procedure ControlSetValue(Value: Variant);\r\n function ControlGetValue: Variant;\r\n\r\n //IJvDynControlEdit\r\n procedure ControlSetPasswordChar(Value: Char);\r\n procedure ControlSetEditMask(const Value: string);\r\n\r\n //IJvDynControlDatabase\r\n procedure ControlSetDataSource(Value: TDataSource);\r\n function ControlGetDataSource: TDataSource;\r\n procedure ControlSetDataField(const Value: string);\r\n function ControlGetDataField: string;\r\n procedure ControlSetAnchors(Value: TAnchors);\r\n\r\n //IJvDynControlDevExpCx\r\n procedure ControlSetCxProperties(Value: TCxDynControlWrapper);\r\n end;\r\n\r\n TJvDynControlCxDBButtonEdit = class(TcxDBButtonEdit, IUnknown,\r\n IJvDynControl, IJvDynControlDevExpCx, IJvDynControlData, IJvDynControlReadOnly, IJvDynControlEdit,\r\n IJvDynControlButtonEdit, IJvDynControlButton, IJvDynControlDatabase)\r\n private\r\n FIntOnButtonClick: TNotifyEvent;\r\n protected\r\n procedure IntOnButtonClick(Sender: TObject; AButtonIndex: Integer);\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n\r\n procedure ControlSetDefaultProperties;\r\n procedure ControlSetReadOnly(Value: Boolean);\r\n procedure ControlSetCaption(const Value: string);\r\n procedure ControlSetTabOrder(Value: Integer);\r\n procedure ControlSetHint(const Value: string);\r\n\r\n procedure ControlSetOnEnter(Value: TNotifyEvent);\r\n procedure ControlSetOnExit(Value: TNotifyEvent);\r\n procedure ControlSetOnChange(Value: TNotifyEvent);\r\n procedure ControlSetOnClick(Value: TNotifyEvent);\r\n\r\n procedure ControlSetValue(Value: Variant);\r\n function ControlGetValue: Variant;\r\n\r\n //IJvDynControlEdit\r\n procedure ControlSetPasswordChar(Value: Char);\r\n procedure ControlSetEditMask(const Value: string);\r\n\r\n //IJvDynControlButtonEdit\r\n procedure ControlSetOnButtonClick(Value: TNotifyEvent);\r\n procedure ControlSetButtonCaption(const Value: string);\r\n\r\n //IJvDynControlButton\r\n procedure ControlSetGlyph(Value: TBitmap);\r\n procedure ControlSetNumGlyphs(Value: Integer);\r\n procedure ControlSetLayout(Value: TButtonLayout);\r\n procedure ControlSetDefault(Value: Boolean);\r\n procedure ControlSetCancel(Value: Boolean);\r\n\r\n //IJvDynControlDatabase\r\n procedure ControlSetDataSource(Value: TDataSource);\r\n function ControlGetDataSource: TDataSource;\r\n procedure ControlSetDataField(const Value: string);\r\n function ControlGetDataField: string;\r\n procedure ControlSetAnchors(Value: TAnchors);\r\n\r\n //IJvDynControlDevExpCx\r\n procedure ControlSetCxProperties(Value: TCxDynControlWrapper);\r\n end;\r\n\r\n TJvDynControlCxDBFileNameEdit = class(TcxDBButtonEdit, IUnknown,\r\n IJvDynControl, IJvDynControlDevExpCx, IJvDynControlData, IJvDynControlFileName,\r\n IJvDynControlReadOnly, IJvDynControlDatabase)\r\n private\r\n FInitialDir: string;\r\n FFilterIndex: Integer;\r\n FFilter: string;\r\n FDialogOptions: TOpenOptions;\r\n FDialogKind: TJvDynControlFileNameDialogKind;\r\n FDialogTitle: string;\r\n FDefaultExt: string;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n\r\n procedure DefaultOnButtonClick(Sender: TObject);\r\n\r\n procedure ControlSetDefaultProperties;\r\n procedure ControlSetReadOnly(Value: Boolean);\r\n procedure ControlSetCaption(const Value: string);\r\n procedure ControlSetTabOrder(Value: Integer);\r\n procedure ControlSetHint(const Value: string);\r\n\r\n procedure ControlSetOnEnter(Value: TNotifyEvent);\r\n procedure ControlSetOnExit(Value: TNotifyEvent);\r\n procedure ControlSetOnChange(Value: TNotifyEvent);\r\n procedure ControlSetOnClick(Value: TNotifyEvent);\r\n\r\n procedure ControlSetValue(Value: Variant);\r\n function ControlGetValue: Variant;\r\n\r\n // IJvDynControlFileName\r\n procedure ControlSetInitialDir(const Value: string);\r\n procedure ControlSetDefaultExt(const Value: string);\r\n procedure ControlSetDialogTitle(const Value: string);\r\n procedure ControlSetDialogOptions(Value: TOpenOptions);\r\n procedure ControlSetFilter(const Value: string);\r\n procedure ControlSetFilterIndex(Value: Integer);\r\n procedure ControlSetDialogKind(Value: TJvDynControlFileNameDialogKind);\r\n\r\n //IJvDynControlDatabase\r\n procedure ControlSetDataSource(Value: TDataSource);\r\n function ControlGetDataSource: TDataSource;\r\n procedure ControlSetDataField(const Value: string);\r\n function ControlGetDataField: string;\r\n procedure ControlSetAnchors(Value: TAnchors);\r\n\r\n //IJvDynControlDevExpCx\r\n procedure ControlSetCxProperties(Value: TCxDynControlWrapper);\r\n end;\r\n\r\n TJvDynControlCxDBDirectoryEdit = class(TcxDBButtonEdit, IUnknown,\r\n IJvDynControl, IJvDynControlDevExpCx, IJvDynControlData,\r\n IJvDynControlDirectory, IJvDynControlReadOnly, IJvDynControlDatabase)\r\n private\r\n FInitialDir: string;\r\n\r\n FDialogOptions: TSelectDirOpts;\r\n\r\n FDialogTitle: string;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n\r\n procedure DefaultOnButtonClick(Sender: TObject);\r\n\r\n procedure ControlSetDefaultProperties;\r\n procedure ControlSetReadOnly(Value: Boolean);\r\n procedure ControlSetCaption(const Value: string);\r\n procedure ControlSetTabOrder(Value: Integer);\r\n procedure ControlSetHint(const Value: string);\r\n\r\n procedure ControlSetOnEnter(Value: TNotifyEvent);\r\n procedure ControlSetOnExit(Value: TNotifyEvent);\r\n procedure ControlSetOnChange(Value: TNotifyEvent);\r\n procedure ControlSetOnClick(Value: TNotifyEvent);\r\n\r\n procedure ControlSetValue(Value: Variant);\r\n function ControlGetValue: Variant;\r\n\r\n // IJvDynControlDirectory\r\n procedure ControlSetInitialDir(const Value: string);\r\n procedure ControlSetDialogTitle(const Value: string);\r\n\r\n procedure ControlSetDialogOptions(Value: TSelectDirOpts);\r\n\r\n\r\n //IJvDynControlDatabase\r\n procedure ControlSetDataSource(Value: TDataSource);\r\n function ControlGetDataSource: TDataSource;\r\n procedure ControlSetDataField(const Value: string);\r\n function ControlGetDataField: string;\r\n procedure ControlSetAnchors(Value: TAnchors);\r\n\r\n //IJvDynControlDevExpCx\r\n procedure ControlSetCxProperties(Value: TCxDynControlWrapper);\r\n end;\r\n\r\n TJvDynControlCxDBCheckBox = class(TcxDBCheckBox, IUnknown,\r\n IJvDynControl, IJvDynControlDevExpCx, IJvDynControlData, IJvDynControlDatabase,\r\n IJvDynControlDBCheckbox)\r\n public\r\n procedure ControlSetDefaultProperties;\r\n procedure ControlSetCaption(const Value: string);\r\n procedure ControlSetTabOrder(Value: Integer);\r\n procedure ControlSetHint(const Value: string);\r\n\r\n procedure ControlSetOnEnter(Value: TNotifyEvent);\r\n procedure ControlSetOnExit(Value: TNotifyEvent);\r\n procedure ControlSetOnChange(Value: TNotifyEvent);\r\n procedure ControlSetOnClick(Value: TNotifyEvent);\r\n\r\n procedure ControlSetValue(Value: Variant);\r\n function ControlGetValue: Variant;\r\n\r\n //IJvDynControlDatabase\r\n procedure ControlSetDataSource(Value: TDataSource);\r\n function ControlGetDataSource: TDataSource;\r\n procedure ControlSetDataField(const Value: string);\r\n function ControlGetDataField: string;\r\n procedure ControlSetAnchors(Value: TAnchors);\r\n\r\n //IJvDynControlDBCheckbox\r\n procedure ControlSetValueChecked(Value: Variant);\r\n procedure ControlSetValueUnChecked(Value: Variant);\r\n\r\n //IJvDynControlDevExpCx\r\n procedure ControlSetCxProperties(Value: TCxDynControlWrapper);\r\n end;\r\n\r\n TJvDynControlCxDBMemo = class(TcxDBMemo, IUnknown, IJvDynControl, IJvDynControlDevExpCx, IJvDynControlData,\r\n IJvDynControlItems, IJvDynControlMemo, IJvDynControlReadOnly, IJvDynControlDatabase, IJvDynControlFont)\r\n public\r\n procedure ControlSetDefaultProperties;\r\n procedure ControlSetReadOnly(Value: Boolean);\r\n procedure ControlSetCaption(const Value: string);\r\n procedure ControlSetTabOrder(Value: Integer);\r\n procedure ControlSetHint(const Value: string);\r\n\r\n procedure ControlSetOnEnter(Value: TNotifyEvent);\r\n procedure ControlSetOnExit(Value: TNotifyEvent);\r\n procedure ControlSetOnChange(Value: TNotifyEvent);\r\n procedure ControlSetOnClick(Value: TNotifyEvent);\r\n\r\n procedure ControlSetValue(Value: Variant);\r\n function ControlGetValue: Variant;\r\n\r\n procedure ControlSetSorted(Value: Boolean);\r\n procedure ControlSetItems(Value: TStrings);\r\n function ControlGetItems: TStrings;\r\n\r\n procedure ControlSetWantTabs(Value: Boolean);\r\n procedure ControlSetWantReturns(Value: Boolean);\r\n procedure ControlSetWordWrap(Value: Boolean);\r\n procedure ControlSetScrollBars(Value: TScrollStyle);\r\n\r\n //IJvDynControlDatabase\r\n procedure ControlSetDataSource(Value: TDataSource);\r\n function ControlGetDataSource: TDataSource;\r\n procedure ControlSetDataField(const Value: string);\r\n function ControlGetDataField: string;\r\n procedure ControlSetAnchors(Value: TAnchors);\r\n\r\n //IJvDynControlDevExpCx\r\n procedure ControlSetCxProperties(Value: TCxDynControlWrapper);\r\n\r\n //IJvDynControlFont\r\n procedure ControlSetFont(Value: TFont);\r\n function ControlGetFont: TFont;\r\n\r\n end;\r\n\r\n TJvDynControlCxDBRadioGroup = class(TcxDBRadioGroup, IUnknown,\r\n IJvDynControl, IJvDynControlDevExpCx, IJvDynControlData, IJvDynControlItems,\r\n IJvDynControlRadioGroup, IJvDynControlDatabase)\r\n private\r\n FItems: TStrings;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n procedure ControlSetDefaultProperties;\r\n procedure ControlSetCaption(const Value: string);\r\n procedure ControlSetTabOrder(Value: Integer);\r\n procedure ControlSetHint(const Value: string);\r\n\r\n procedure ControlSetOnEnter(Value: TNotifyEvent);\r\n procedure ControlSetOnExit(Value: TNotifyEvent);\r\n procedure ControlSetOnChange(Value: TNotifyEvent);\r\n procedure ControlSetOnClick(Value: TNotifyEvent);\r\n\r\n procedure ControlSetValue(Value: Variant);\r\n function ControlGetValue: Variant;\r\n\r\n procedure ControlSetSorted(Value: Boolean);\r\n procedure ControlSetItems(Value: TStrings);\r\n function ControlGetItems: TStrings;\r\n\r\n procedure ControlSetColumns(Value: Integer);\r\n\r\n //IJvDynControlDatabase\r\n procedure ControlSetDataSource(Value: TDataSource);\r\n function ControlGetDataSource: TDataSource;\r\n procedure ControlSetDataField(const Value: string);\r\n function ControlGetDataField: string;\r\n procedure ControlSetAnchors(Value: TAnchors);\r\n\r\n //IJvDynControlDevExpCx\r\n procedure ControlSetCxProperties(Value: TCxDynControlWrapper);\r\n end;\r\n\r\n TJvDynControlCxDBListBox = class(TcxDBListBox, IUnknown,\r\n IJvDynControl, IJvDynControlDevExpCx, IJvDynControlData, IJvDynControlItems,\r\n IJvDynControlDblClick, IJvDynControlDatabase)\r\n public\r\n procedure ControlSetDefaultProperties;\r\n procedure ControlSetCaption(const Value: string);\r\n procedure ControlSetTabOrder(Value: Integer);\r\n procedure ControlSetHint(const Value: string);\r\n\r\n procedure ControlSetOnEnter(Value: TNotifyEvent);\r\n procedure ControlSetOnExit(Value: TNotifyEvent);\r\n procedure ControlSetOnChange(Value: TNotifyEvent);\r\n procedure ControlSetOnClick(Value: TNotifyEvent);\r\n\r\n procedure ControlSetValue(Value: Variant);\r\n function ControlGetValue: Variant;\r\n\r\n procedure ControlSetSorted(Value: Boolean);\r\n procedure ControlSetItems(Value: TStrings);\r\n function ControlGetItems: TStrings;\r\n\r\n procedure ControlSetOnDblClick(Value: TNotifyEvent);\r\n\r\n //IJvDynControlDatabase\r\n procedure ControlSetDataSource(Value: TDataSource);\r\n function ControlGetDataSource: TDataSource;\r\n procedure ControlSetDataField(const Value: string);\r\n function ControlGetDataField: string;\r\n procedure ControlSetAnchors(Value: TAnchors);\r\n\r\n //IJvDynControlDevExpCx\r\n procedure ControlSetCxProperties(Value: TCxDynControlWrapper);\r\n end;\r\n\r\n TJvDynControlCxDBComboBox = class(TcxDBComboBox, IUnknown,\r\n IJvDynControl, IJvDynControlDevExpCx, IJvDynControlData, IJvDynControlItems,\r\n IJvDynControlComboBox, IJvDynControlDatabase)\r\n public\r\n procedure ControlSetDefaultProperties;\r\n procedure ControlSetCaption(const Value: string);\r\n procedure ControlSetTabOrder(Value: Integer);\r\n procedure ControlSetHint(const Value: string);\r\n\r\n procedure ControlSetOnEnter(Value: TNotifyEvent);\r\n procedure ControlSetOnExit(Value: TNotifyEvent);\r\n procedure ControlSetOnChange(Value: TNotifyEvent);\r\n procedure ControlSetOnClick(Value: TNotifyEvent);\r\n\r\n procedure ControlSetValue(Value: Variant);\r\n function ControlGetValue: Variant;\r\n\r\n procedure ControlSetSorted(Value: Boolean);\r\n procedure ControlSetItems(Value: TStrings);\r\n function ControlGetItems: TStrings;\r\n\r\n procedure ControlSetNewEntriesAllowed(Value: Boolean);\r\n\r\n //IJvDynControlDatabase\r\n procedure ControlSetDataSource(Value: TDataSource);\r\n function ControlGetDataSource: TDataSource;\r\n procedure ControlSetDataField(const Value: string);\r\n function ControlGetDataField: string;\r\n procedure ControlSetAnchors(Value: TAnchors);\r\n\r\n //IJvDynControlDevExpCx\r\n procedure ControlSetCxProperties(Value: TCxDynControlWrapper);\r\n end;\r\n\r\n TJvDynControlCxDBImage = class(TcxDBImage, IUnknown,\r\n IJvDynControl, IJvDynControlDevExpCx, IJvDynControlImage, IJvDynControlDatabase)\r\n public\r\n procedure ControlSetDefaultProperties;\r\n procedure ControlSetCaption(const Value: string);\r\n procedure ControlSetTabOrder(Value: Integer);\r\n procedure ControlSetHint(const Value: string);\r\n\r\n procedure ControlSetOnEnter(Value: TNotifyEvent);\r\n procedure ControlSetOnExit(Value: TNotifyEvent);\r\n procedure ControlSetOnClick(Value: TNotifyEvent);\r\n\r\n procedure ControlSetAutoSize(Value: Boolean);\r\n procedure ControlSetIncrementalDisplay(Value: Boolean);\r\n procedure ControlSetCenter(Value: Boolean);\r\n\r\n procedure ControlSetProportional(Value: Boolean);\r\n\r\n procedure ControlSetStretch(Value: Boolean);\r\n procedure ControlSetTransparent(Value: Boolean);\r\n procedure ControlSetPicture(Value: TPicture);\r\n procedure ControlSetGraphic(Value: TGraphic);\r\n function ControlGetPicture: TPicture;\r\n\r\n //IJvDynControlDatabase\r\n procedure ControlSetDataSource(Value: TDataSource);\r\n function ControlGetDataSource: TDataSource;\r\n procedure ControlSetDataField(const Value: string);\r\n function ControlGetDataField: string;\r\n procedure ControlSetAnchors(Value: TAnchors);\r\n\r\n //IJvDynControlDevExpCx\r\n procedure ControlSetCxProperties(Value: TCxDynControlWrapper);\r\n end;\r\n\r\n TJvDynControlCxDBText = class(TcxDBTextEdit, IUnknown,\r\n IJvDynControl, IJvDynControlDevExpCx, IJvDynControlDatabase)\r\n public\r\n procedure ControlSetDefaultProperties;\r\n procedure ControlSetCaption(const Value: string);\r\n procedure ControlSetTabOrder(Value: Integer);\r\n procedure ControlSetHint(const Value: string);\r\n\r\n procedure ControlSetOnEnter(Value: TNotifyEvent);\r\n procedure ControlSetOnExit(Value: TNotifyEvent);\r\n procedure ControlSetOnClick(Value: TNotifyEvent);\r\n\r\n //IJvDynControlDatabase\r\n procedure ControlSetDataSource(Value: TDataSource);\r\n function ControlGetDataSource: TDataSource;\r\n procedure ControlSetDataField(const Value: string);\r\n function ControlGetDataField: string;\r\n procedure ControlSetAnchors(Value: TAnchors);\r\n\r\n //IJvDynControlDevExpCx\r\n procedure ControlSetCxProperties(Value: TCxDynControlWrapper);\r\n end;\r\n\r\n TJvDynControlCxDBNavigator = class(TcxDBNavigator, IUnknown,\r\n IJvDynControl, IJvDynControlDevExpCx, IJvDynControlDatabase)\r\n public\r\n procedure ControlSetDefaultProperties;\r\n procedure ControlSetCaption(const Value: string);\r\n procedure ControlSetTabOrder(Value: Integer);\r\n procedure ControlSetHint(const Value: string);\r\n\r\n procedure ControlSetOnEnter(Value: TNotifyEvent);\r\n procedure ControlSetOnExit(Value: TNotifyEvent);\r\n procedure ControlSetOnClick(Value: TNotifyEvent);\r\n\r\n //IJvDynControlDatabase\r\n procedure ControlSetDataSource(Value: TDataSource);\r\n function ControlGetDataSource: TDataSource;\r\n procedure ControlSetDataField(const Value: string);\r\n function ControlGetDataField: string;\r\n procedure ControlSetAnchors(Value: TAnchors);\r\n\r\n //IJvDynControlDevExpCx\r\n procedure ControlSetCxProperties(Value: TCxDynControlWrapper);\r\n\r\n end;\r\n\r\n TJvDynControlCxDBDateTimeEdit = class(TcxDBDateEdit, IUnknown, IJvDynControl,\r\n IJvDynControlData, IJvDynControlDevExpCx, IJvDynControlDate, IJvDynControlReadOnly,\r\n IJvDynControlDatabase)\r\n public\r\n procedure ControlSetDefaultProperties;\r\n procedure ControlSetReadOnly(Value: Boolean);\r\n procedure ControlSetCaption(const Value: string);\r\n procedure ControlSetTabOrder(Value: Integer);\r\n\r\n procedure ControlSetOnEnter(Value: TNotifyEvent);\r\n procedure ControlSetOnExit(Value: TNotifyEvent);\r\n procedure ControlSetOnChange(Value: TNotifyEvent);\r\n procedure ControlSetOnClick(Value: TNotifyEvent);\r\n procedure ControlSetHint(const Value: string);\r\n\r\n procedure ControlSetValue(Value: Variant);\r\n function ControlGetValue: Variant;\r\n\r\n // IJvDynControlDate\r\n procedure ControlSetMinDate(Value: TDateTime);\r\n procedure ControlSetMaxDate(Value: TDateTime);\r\n procedure ControlSetFormat(const Value: string);\r\n\r\n procedure ControlSetCxProperties(Value: TCxDynControlWrapper);\r\n\r\n //IJvDynControlDatabase\r\n procedure ControlSetDataSource(Value: TDataSource);\r\n function ControlGetDataSource: TDataSource;\r\n procedure ControlSetDataField(const Value: string);\r\n function ControlGetDataField: string;\r\n procedure ControlSetAnchors(Value: TAnchors);\r\n end;\r\n\r\n TJvDynControlCxDBDateEdit = class(TcxDBDateEdit, IUnknown, IJvDynControl,\r\n IJvDynControlData, IJvDynControlDevExpCx, IJvDynControlDate,\r\n IJvDynControlReadOnly, IJvDynControlDatabase)\r\n public\r\n procedure ControlSetDefaultProperties;\r\n procedure ControlSetReadOnly(Value: Boolean);\r\n procedure ControlSetCaption(const Value: string);\r\n procedure ControlSetTabOrder(Value: Integer);\r\n\r\n procedure ControlSetOnEnter(Value: TNotifyEvent);\r\n procedure ControlSetOnExit(Value: TNotifyEvent);\r\n procedure ControlSetOnChange(Value: TNotifyEvent);\r\n procedure ControlSetOnClick(Value: TNotifyEvent);\r\n procedure ControlSetHint(const Value: string);\r\n\r\n procedure ControlSetValue(Value: Variant);\r\n function ControlGetValue: Variant;\r\n\r\n // IJvDynControlDate\r\n procedure ControlSetMinDate(Value: TDateTime);\r\n procedure ControlSetMaxDate(Value: TDateTime);\r\n procedure ControlSetFormat(const Value: string);\r\n\r\n procedure ControlSetCxProperties(Value: TCxDynControlWrapper);\r\n //IJvDynControlDatabase\r\n procedure ControlSetDataSource(Value: TDataSource);\r\n function ControlGetDataSource: TDataSource;\r\n procedure ControlSetDataField(const Value: string);\r\n function ControlGetDataField: string;\r\n procedure ControlSetAnchors(Value: TAnchors);\r\n end;\r\n\r\n TJvDynControlCxDBTimeEdit = class(TcxDBTimeEdit, IUnknown, IJvDynControl,\r\n IJvDynControlData, IJvDynControlDevExpCx, IJvDynControlTime,\r\n IJvDynControlReadOnly, IJvDynControlDatabase)\r\n public\r\n procedure ControlSetDefaultProperties;\r\n procedure ControlSetReadOnly(Value: Boolean);\r\n procedure ControlSetCaption(const Value: string);\r\n procedure ControlSetTabOrder(Value: Integer);\r\n\r\n procedure ControlSetOnEnter(Value: TNotifyEvent);\r\n procedure ControlSetOnExit(Value: TNotifyEvent);\r\n procedure ControlSetOnChange(Value: TNotifyEvent);\r\n procedure ControlSetOnClick(Value: TNotifyEvent);\r\n procedure ControlSetHint(const Value: string);\r\n\r\n procedure ControlSetValue(Value: Variant);\r\n function ControlGetValue: Variant;\r\n\r\n procedure ControlSetCxProperties(Value: TCxDynControlWrapper);\r\n\r\n procedure ControlSetFormat(const Value: string);\r\n //IJvDynControlDatabase\r\n procedure ControlSetDataSource(Value: TDataSource);\r\n function ControlGetDataSource: TDataSource;\r\n procedure ControlSetDataField(const Value: string);\r\n function ControlGetDataField: string;\r\n procedure ControlSetAnchors(Value: TAnchors);\r\n end;\r\n\r\nfunction DynControlEngineCxDB: TJvDynControlEngineDB;\r\nprocedure SetDefaultDynControlEngineDBDevExp;\r\n\r\n{$ENDIF USE_3RDPARTY_DEVEXPRESS_CXEDITOR}\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvDynControlEngineDevExpCxDB.pas $';\r\n Revision: '$Revision: 13075 $';\r\n Date: '$Date: 2011-06-28 00:56:21 +0200 (mar. 28 juin 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n Variants, SysUtils, TypInfo,\r\n {$IFDEF USE_3RDPARTY_DEVEXPRESS_CXEDITOR}\r\n cxTextEdit, cxMaskEdit, cxRadioGroup, cxDropDownEdit, cxDBRichEdit,\r\n cxEdit, cxTimeEdit, cxDBLookupComboBox, cxMemo, cxCheckbox,\r\n cxGridTableView, cxGridCustomView,\r\n cxGrid, cxGridCustomTableView, cxGridDBDataDefinitions,\r\n {$ENDIF USE_3RDPARTY_DEVEXPRESS_CXEDITOR}\r\n JvDynControlEngineTools, JvConsts, JvJCLUtils;\r\n\r\n{$IFDEF USE_3RDPARTY_DEVEXPRESS_CXEDITOR}\r\n\r\nvar\r\n IntDynControlEngineCxDB: TJvDynControlEngineDB = nil;\r\n\r\n//=== { TJvDynControlCxDBEdit } ==============================================\r\n\r\nprocedure TJvDynControlCxDBEdit.ControlSetDefaultProperties;\r\nbegin\r\nend;\r\n\r\nprocedure TJvDynControlCxDBEdit.ControlSetReadOnly(Value: Boolean);\r\nbegin\r\n Properties.ReadOnly := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxDBEdit.ControlSetCaption(const Value: string);\r\nbegin\r\nend;\r\n\r\nprocedure TJvDynControlCxDBEdit.ControlSetTabOrder(Value: Integer);\r\nbegin\r\n TabOrder := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxDBEdit.ControlSetHint(const Value: string);\r\nbegin\r\n Hint := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxDBEdit.ControlSetOnEnter(Value: TNotifyEvent);\r\nbegin\r\n OnEnter := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxDBEdit.ControlSetOnExit(Value: TNotifyEvent);\r\nbegin\r\n OnExit := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxDBEdit.ControlSetOnChange(Value: TNotifyEvent);\r\nbegin\r\n Properties.OnChange := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxDBEdit.ControlSetOnClick(Value: TNotifyEvent);\r\nbegin\r\nend;\r\n\r\nprocedure TJvDynControlCxDBEdit.ControlSetValue(Value: Variant);\r\nbegin\r\n Text := Value;\r\nend;\r\n\r\nfunction TJvDynControlCxDBEdit.ControlGetValue: Variant;\r\nbegin\r\n Result := Text;\r\nend;\r\n\r\nprocedure TJvDynControlCxDBEdit.ControlSetPasswordChar(Value: Char);\r\nbegin\r\n if Value <> #0 then\r\n Properties.EchoMode := eemPassword\r\n else\r\n Properties.EchoMode := eemNormal;\r\nend;\r\n\r\nprocedure TJvDynControlCxDBEdit.ControlSetEditMask(const Value: string);\r\nbegin\r\n //EditMask := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxDBEdit.ControlSetDataSource(Value: TDataSource);\r\nbegin\r\n Databinding.DataSource := Value;\r\nend;\r\n\r\nfunction TJvDynControlCxDBEdit.ControlGetDataSource: TDataSource;\r\nbegin\r\n Result := DataBinding.DataSource;\r\nend;\r\n\r\nprocedure TJvDynControlCxDBEdit.ControlSetDataField(const Value: string);\r\nbegin\r\n Databinding.DataField := Value;\r\nend;\r\n\r\nfunction TJvDynControlCxDBEdit.ControlGetDataField: string;\r\nbegin\r\n Result := Databinding.DataField;\r\nend;\r\n\r\nprocedure TJvDynControlCxDBEdit.ControlSetAnchors(Value: TAnchors);\r\nbegin\r\n Anchors := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxDBEdit.ControlSetCxProperties(Value: TCxDynControlWrapper);\r\nbegin\r\n Style.LookAndFeel.Assign(Value.LookAndFeel);\r\n Style.StyleController := Value.StyleController;\r\nend;\r\n\r\n//=== { TJvDynControlCxDBButtonEdit } ========================================\r\n\r\nconstructor TJvDynControlCxDBButtonEdit.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\nend;\r\n\r\ndestructor TJvDynControlCxDBButtonEdit.Destroy;\r\nbegin\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvDynControlCxDBButtonEdit.IntOnButtonClick(Sender: TObject;\r\n AButtonIndex: Integer);\r\nbegin\r\n if Assigned(FIntOnButtonClick) then\r\n FIntOnButtonClick(Sender);\r\nend;\r\n\r\nprocedure TJvDynControlCxDBButtonEdit.ControlSetDefaultProperties;\r\nbegin\r\n Properties.OnButtonClick := IntOnButtonClick;\r\n Properties.MaskKind := emkStandard;\r\nend;\r\n\r\nprocedure TJvDynControlCxDBButtonEdit.ControlSetReadOnly(Value: Boolean);\r\nbegin\r\n Properties.ReadOnly := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxDBButtonEdit.ControlSetCaption(const Value: string);\r\nbegin\r\nend;\r\n\r\nprocedure TJvDynControlCxDBButtonEdit.ControlSetTabOrder(Value: Integer);\r\nbegin\r\n TabOrder := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxDBButtonEdit.ControlSetHint(const Value: string);\r\nbegin\r\n Hint := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxDBButtonEdit.ControlSetOnEnter(Value: TNotifyEvent);\r\nbegin\r\n OnEnter := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxDBButtonEdit.ControlSetOnExit(Value: TNotifyEvent);\r\nbegin\r\n OnExit := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxDBButtonEdit.ControlSetOnChange(Value: TNotifyEvent);\r\nbegin\r\n Properties.OnChange := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxDBButtonEdit.ControlSetOnClick(Value: TNotifyEvent);\r\nbegin\r\n OnClick := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxDBButtonEdit.ControlSetValue(Value: Variant);\r\nbegin\r\n Text := Value;\r\nend;\r\n\r\nfunction TJvDynControlCxDBButtonEdit.ControlGetValue: Variant;\r\nbegin\r\n Result := Text;\r\nend;\r\n\r\nprocedure TJvDynControlCxDBButtonEdit.ControlSetPasswordChar(Value: Char);\r\nbegin\r\n if Value <> #0 then\r\n Properties.EchoMode := eemPassword\r\n else\r\n Properties.EchoMode := eemNormal;\r\nend;\r\n\r\nprocedure TJvDynControlCxDBButtonEdit.ControlSetEditMask(const Value: string);\r\nbegin\r\n //FEditControl.EditMask := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxDBButtonEdit.ControlSetOnButtonClick(Value: TNotifyEvent);\r\nbegin\r\n FIntOnButtonClick := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxDBButtonEdit.ControlSetButtonCaption(const Value: string);\r\nbegin\r\n Properties.Buttons[0].Caption := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxDBButtonEdit.ControlSetGlyph(Value: TBitmap);\r\nbegin\r\n Properties.Buttons[0].Glyph.Assign(Value);\r\nend;\r\n\r\nprocedure TJvDynControlCxDBButtonEdit.ControlSetNumGlyphs(Value: Integer);\r\nbegin\r\nend;\r\n\r\nprocedure TJvDynControlCxDBButtonEdit.ControlSetLayout(Value: TButtonLayout);\r\nbegin\r\nend;\r\n\r\nprocedure TJvDynControlCxDBButtonEdit.ControlSetDefault(Value: Boolean);\r\nbegin\r\nend;\r\n\r\nprocedure TJvDynControlCxDBButtonEdit.ControlSetCancel(Value: Boolean);\r\nbegin\r\nend;\r\n\r\nprocedure TJvDynControlCxDBButtonEdit.ControlSetDataSource(Value: TDataSource);\r\nbegin\r\n Databinding.DataSource := Value;\r\nend;\r\n\r\nfunction TJvDynControlCxDBButtonEdit.ControlGetDataSource: TDataSource;\r\nbegin\r\n Result := Databinding.DataSource;\r\nend;\r\n\r\nprocedure TJvDynControlCxDBButtonEdit.ControlSetDataField(const Value: string);\r\nbegin\r\n Databinding.DataField := Value;\r\nend;\r\n\r\nfunction TJvDynControlCxDBButtonEdit.ControlGetDataField: string;\r\nbegin\r\n Result := Databinding.DataField;\r\nend;\r\n\r\nprocedure TJvDynControlCxDBButtonEdit.ControlSetAnchors(Value: TAnchors);\r\nbegin\r\n Anchors := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxDBButtonEdit.ControlSetCxProperties(Value: TCxDynControlWrapper);\r\nbegin\r\n Style.LookAndFeel.Assign(Value.LookAndFeel);\r\n Style.StyleController := Value.StyleController;\r\nend;\r\n\r\n//=== { TJvDynControlCxDBFileNameEdit } ======================================\r\n\r\nconstructor TJvDynControlCxDBFileNameEdit.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\nend;\r\n\r\ndestructor TJvDynControlCxDBFileNameEdit.Destroy;\r\nbegin\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvDynControlCxDBFileNameEdit.DefaultOnButtonClick(Sender: TObject);\r\nbegin\r\n case FDialogKind of\r\n jdkOpen:\r\n with TOpenDialog.Create(Self) do\r\n try\r\n Options := FDialogOptions;\r\n Title := FDialogTitle;\r\n Filter := FFilter;\r\n FilterIndex := FFilterIndex;\r\n InitialDir := FInitialDir;\r\n DefaultExt := FDefaultExt;\r\n FileName := ControlGetValue;\r\n if Execute then\r\n ControlSetValue(FileName);\r\n finally\r\n Free;\r\n end;\r\n jdkOpenPicture:\r\n with TOpenPictureDialog.Create(Self) do\r\n try\r\n Options := FDialogOptions;\r\n Title := FDialogTitle;\r\n Filter := FFilter;\r\n FilterIndex := FFilterIndex;\r\n InitialDir := FInitialDir;\r\n DefaultExt := FDefaultExt;\r\n FileName := ControlGetValue;\r\n if Execute then\r\n ControlSetValue(FileName);\r\n finally\r\n Free;\r\n end;\r\n jdkSave:\r\n with TSaveDialog.Create(Self) do\r\n try\r\n Options := FDialogOptions;\r\n Title := FDialogTitle;\r\n Filter := FFilter;\r\n FilterIndex := FFilterIndex;\r\n InitialDir := FInitialDir;\r\n DefaultExt := FDefaultExt;\r\n FileName := ControlGetValue;\r\n if Execute then\r\n ControlSetValue(FileName);\r\n finally\r\n Free;\r\n end;\r\n jdkSavePicture:\r\n with TSavePictureDialog.Create(Self) do\r\n try\r\n Options := FDialogOptions;\r\n Title := FDialogTitle;\r\n Filter := FFilter;\r\n FilterIndex := FFilterIndex;\r\n InitialDir := FInitialDir;\r\n DefaultExt := FDefaultExt;\r\n FileName := ControlGetValue;\r\n if Execute then\r\n ControlSetValue(FileName);\r\n finally\r\n Free;\r\n end;\r\n end;\r\n if CanFocus then\r\n SetFocus;\r\nend;\r\n\r\nprocedure TJvDynControlCxDBFileNameEdit.ControlSetDefaultProperties;\r\nbegin\r\n Caption := ' ';\r\nend;\r\n\r\nprocedure TJvDynControlCxDBFileNameEdit.ControlSetReadOnly(Value: Boolean);\r\nbegin\r\n Properties.ReadOnly := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxDBFileNameEdit.ControlSetCaption(const Value: string);\r\nbegin\r\nend;\r\n\r\nprocedure TJvDynControlCxDBFileNameEdit.ControlSetTabOrder(Value: Integer);\r\nbegin\r\n TabOrder := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxDBFileNameEdit.ControlSetHint(const Value: string);\r\nbegin\r\n Hint := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxDBFileNameEdit.ControlSetOnEnter(Value: TNotifyEvent);\r\nbegin\r\n OnEnter := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxDBFileNameEdit.ControlSetOnExit(Value: TNotifyEvent);\r\nbegin\r\n OnExit := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxDBFileNameEdit.ControlSetOnChange(Value: TNotifyEvent);\r\nbegin\r\n Properties.OnChange := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxDBFileNameEdit.ControlSetOnClick(Value: TNotifyEvent);\r\nbegin\r\nend;\r\n\r\nprocedure TJvDynControlCxDBFileNameEdit.ControlSetValue(Value: Variant);\r\nbegin\r\n Text := Value;\r\nend;\r\n\r\nfunction TJvDynControlCxDBFileNameEdit.ControlGetValue: Variant;\r\nbegin\r\n Result := Text;\r\nend;\r\n\r\n// IJvDynControlFileName\r\n\r\nprocedure TJvDynControlCxDBFileNameEdit.ControlSetInitialDir(const Value: string);\r\nbegin\r\n FInitialDir := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxDBFileNameEdit.ControlSetDefaultExt(const Value: string);\r\nbegin\r\n FDefaultExt := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxDBFileNameEdit.ControlSetDialogTitle(const Value: string);\r\nbegin\r\n FDialogTitle := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxDBFileNameEdit.ControlSetDialogOptions(Value: TOpenOptions);\r\nbegin\r\n FDialogOptions := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxDBFileNameEdit.ControlSetFilter(const Value: string);\r\nbegin\r\n FFilter := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxDBFileNameEdit.ControlSetFilterIndex(Value: Integer);\r\nbegin\r\n FFilterIndex := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxDBFileNameEdit.ControlSetDialogKind(Value: TJvDynControlFileNameDialogKind);\r\nbegin\r\n FDialogKind := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxDBFileNameEdit.ControlSetDataSource(Value: TDataSource);\r\nbegin\r\n Databinding.DataSource := Value;\r\nend;\r\n\r\nfunction TJvDynControlCxDBFileNameEdit.ControlGetDataSource: TDataSource;\r\nbegin\r\n Result := Databinding.DataSource;\r\nend;\r\n\r\nprocedure TJvDynControlCxDBFileNameEdit.ControlSetDataField(const Value: string);\r\nbegin\r\n Databinding.DataField := Value;\r\nend;\r\n\r\nfunction TJvDynControlCxDBFileNameEdit.ControlGetDataField: string;\r\nbegin\r\n Result := Databinding.DataField;\r\nend;\r\n\r\nprocedure TJvDynControlCxDBFileNameEdit.ControlSetAnchors(Value: TAnchors);\r\nbegin\r\n Anchors := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxDBFileNameEdit.ControlSetCxProperties(Value: TCxDynControlWrapper);\r\nbegin\r\n Style.LookAndFeel.Assign(Value.LookAndFeel);\r\n Style.StyleController := Value.StyleController;\r\nend;\r\n\r\n//=== { TJvDynControlCxDBDirectoryEdit } =====================================\r\n\r\nconstructor TJvDynControlCxDBDirectoryEdit.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\nend;\r\n\r\ndestructor TJvDynControlCxDBDirectoryEdit.Destroy;\r\nbegin\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvDynControlCxDBDirectoryEdit.DefaultOnButtonClick(Sender: TObject);\r\nvar\r\n Opt: TSelectDirOpts;\r\n Dir: string;\r\nbegin\r\n Dir := ControlGetValue;\r\n if Dir = '' then\r\n if FInitialDir <> '' then\r\n Dir := FInitialDir\r\n else\r\n Dir := PathDelim;\r\n if not DirectoryExists(Dir) then\r\n Dir := PathDelim;\r\n if SelectDirectory(Dir, Opt, HelpContext) then\r\n ControlSetValue(Dir);\r\n if CanFocus then\r\n SetFocus;\r\nend;\r\n\r\nprocedure TJvDynControlCxDBDirectoryEdit.ControlSetDefaultProperties;\r\nbegin\r\n Self.Caption := ' ';\r\nend;\r\n\r\nprocedure TJvDynControlCxDBDirectoryEdit.ControlSetReadOnly(Value: Boolean);\r\nbegin\r\n Properties.ReadOnly := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxDBDirectoryEdit.ControlSetCaption(const Value: string);\r\nbegin\r\nend;\r\n\r\nprocedure TJvDynControlCxDBDirectoryEdit.ControlSetTabOrder(Value: Integer);\r\nbegin\r\n TabOrder := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxDBDirectoryEdit.ControlSetHint(const Value: string);\r\nbegin\r\n Hint := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxDBDirectoryEdit.ControlSetOnEnter(Value: TNotifyEvent);\r\nbegin\r\n OnEnter := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxDBDirectoryEdit.ControlSetOnExit(Value: TNotifyEvent);\r\nbegin\r\n OnExit := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxDBDirectoryEdit.ControlSetOnChange(Value: TNotifyEvent);\r\nbegin\r\n Properties.OnChange := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxDBDirectoryEdit.ControlSetOnClick(Value: TNotifyEvent);\r\nbegin\r\nend;\r\n\r\nprocedure TJvDynControlCxDBDirectoryEdit.ControlSetValue(Value: Variant);\r\nbegin\r\n Text := Value;\r\nend;\r\n\r\nfunction TJvDynControlCxDBDirectoryEdit.ControlGetValue: Variant;\r\nbegin\r\n Result := Text;\r\nend;\r\n\r\nprocedure TJvDynControlCxDBDirectoryEdit.ControlSetInitialDir(const Value: string);\r\nbegin\r\n FInitialDir := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxDBDirectoryEdit.ControlSetDialogTitle(const Value: string);\r\nbegin\r\n FDialogTitle := Value;\r\nend;\r\n\r\n\r\nprocedure TJvDynControlCxDBDirectoryEdit.ControlSetDialogOptions(Value: TSelectDirOpts);\r\nbegin\r\n FDialogOptions := Value;\r\nend;\r\n\r\n\r\nprocedure TJvDynControlCxDBDirectoryEdit.ControlSetDataSource(Value: TDataSource);\r\nbegin\r\n Databinding.DataSource := Value;\r\nend;\r\n\r\nfunction TJvDynControlCxDBDirectoryEdit.ControlGetDataSource: TDataSource;\r\nbegin\r\n Result := Databinding.DataSource;\r\nend;\r\n\r\nprocedure TJvDynControlCxDBDirectoryEdit.ControlSetDataField(const Value: string);\r\nbegin\r\n Databinding.DataField := Value;\r\nend;\r\n\r\nfunction TJvDynControlCxDBDirectoryEdit.ControlGetDataField: string;\r\nbegin\r\n Result := Databinding.DataField;\r\nend;\r\n\r\nprocedure TJvDynControlCxDBDirectoryEdit.ControlSetAnchors(Value: TAnchors);\r\nbegin\r\n Anchors := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxDBDirectoryEdit.ControlSetCxProperties(Value: TCxDynControlWrapper);\r\nbegin\r\n Style.LookAndFeel.Assign(Value.LookAndFeel);\r\n Style.StyleController := Value.StyleController;\r\nend;\r\n\r\n//=== { TJvDynControlCxDBCheckBox } ==========================================\r\n\r\nprocedure TJvDynControlCxDBCheckBox.ControlSetDefaultProperties;\r\nbegin\r\nend;\r\n\r\nprocedure TJvDynControlCxDBCheckBox.ControlSetCaption(const Value: string);\r\nbegin\r\n Caption := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxDBCheckBox.ControlSetTabOrder(Value: Integer);\r\nbegin\r\n TabOrder := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxDBCheckBox.ControlSetHint(const Value: string);\r\nbegin\r\n Hint := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxDBCheckBox.ControlSetOnEnter(Value: TNotifyEvent);\r\nbegin\r\n OnEnter := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxDBCheckBox.ControlSetOnExit(Value: TNotifyEvent);\r\nbegin\r\n OnExit := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxDBCheckBox.ControlSetOnChange(Value: TNotifyEvent);\r\nbegin\r\n OnClick := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxDBCheckBox.ControlSetOnClick(Value: TNotifyEvent);\r\nbegin\r\n OnClick := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxDBCheckBox.ControlSetValue(Value: Variant);\r\nbegin\r\n Checked := JvDynControlVariantToBoolean(Value);\r\nend;\r\n\r\nfunction TJvDynControlCxDBCheckBox.ControlGetValue: Variant;\r\nbegin\r\n Result := Checked;\r\nend;\r\n\r\nprocedure TJvDynControlCxDBCheckBox.ControlSetDataSource(Value: TDataSource);\r\nbegin\r\n Databinding.DataSource := Value;\r\nend;\r\n\r\nfunction TJvDynControlCxDBCheckBox.ControlGetDataSource: TDataSource;\r\nbegin\r\n Result := DataBinding.DataSource;\r\nend;\r\n\r\nprocedure TJvDynControlCxDBCheckBox.ControlSetDataField(const Value: string);\r\nbegin\r\n Databinding.DataField := Value;\r\nend;\r\n\r\nfunction TJvDynControlCxDBCheckBox.ControlGetDataField: string;\r\nbegin\r\n Result := Databinding.DataField;\r\nend;\r\n\r\nprocedure TJvDynControlCxDBCheckBox.ControlSetAnchors(Value: TAnchors);\r\nbegin\r\n Anchors := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxDBCheckBox.ControlSetValueChecked(Value: Variant);\r\nbegin\r\n Properties.ValueChecked := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxDBCheckBox.ControlSetValueUnChecked(Value: Variant);\r\nbegin\r\n Properties.ValueUnChecked := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxDBCheckBox.ControlSetCxProperties(Value: TCxDynControlWrapper);\r\nbegin\r\n Style.LookAndFeel.Assign(Value.LookAndFeel);\r\n Style.StyleController := Value.StyleController;\r\nend;\r\n\r\n//=== { TJvDynControlCxDBMemo } ==============================================\r\n\r\nprocedure TJvDynControlCxDBMemo.ControlSetDefaultProperties;\r\nbegin\r\n Properties.ScrollBars := ssBoth;\r\n Properties.WantReturns := True;\r\n Properties.WantTabs := True;\r\nend;\r\n\r\nprocedure TJvDynControlCxDBMemo.ControlSetReadOnly(Value: Boolean);\r\nbegin\r\n Properties.ReadOnly := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxDBMemo.ControlSetCaption(const Value: string);\r\nbegin\r\nend;\r\n\r\nprocedure TJvDynControlCxDBMemo.ControlSetTabOrder(Value: Integer);\r\nbegin\r\n TabOrder := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxDBMemo.ControlSetHint(const Value: string);\r\nbegin\r\n Hint := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxDBMemo.ControlSetOnEnter(Value: TNotifyEvent);\r\nbegin\r\n OnEnter := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxDBMemo.ControlSetOnExit(Value: TNotifyEvent);\r\nbegin\r\n OnExit := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxDBMemo.ControlSetOnChange(Value: TNotifyEvent);\r\nbegin\r\n Properties.OnChange := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxDBMemo.ControlSetOnClick(Value: TNotifyEvent);\r\nbegin\r\n OnClick := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxDBMemo.ControlSetValue(Value: Variant);\r\nbegin\r\n Text := Value;\r\nend;\r\n\r\nfunction TJvDynControlCxDBMemo.ControlGetValue: Variant;\r\nbegin\r\n Result := Text;\r\nend;\r\n\r\nprocedure TJvDynControlCxDBMemo.ControlSetSorted(Value: Boolean);\r\nbegin\r\nend;\r\n\r\nprocedure TJvDynControlCxDBMemo.ControlSetItems(Value: TStrings);\r\nbegin\r\n Lines.Assign(Value);\r\nend;\r\n\r\nfunction TJvDynControlCxDBMemo.ControlGetItems: TStrings;\r\nbegin\r\n Result := Lines;\r\nend;\r\n\r\nprocedure TJvDynControlCxDBMemo.ControlSetWantTabs(Value: Boolean);\r\nbegin\r\n Properties.WantTabs := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxDBMemo.ControlSetWantReturns(Value: Boolean);\r\nbegin\r\n Properties.WantReturns := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxDBMemo.ControlSetWordWrap(Value: Boolean);\r\nbegin\r\n Properties.WordWrap := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxDBMemo.ControlSetScrollBars(Value: TScrollStyle);\r\nbegin\r\n ScrollBars := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxDBMemo.ControlSetDataSource(Value: TDataSource);\r\nbegin\r\n Databinding.DataSource := Value;\r\nend;\r\n\r\nfunction TJvDynControlCxDBMemo.ControlGetDataSource: TDataSource;\r\nbegin\r\n Result := DataBinding.DataSource;\r\nend;\r\n\r\nprocedure TJvDynControlCxDBMemo.ControlSetDataField(const Value: string);\r\nbegin\r\n Databinding.DataField := Value;\r\nend;\r\n\r\nfunction TJvDynControlCxDBMemo.ControlGetDataField: string;\r\nbegin\r\n Result := Databinding.DataField;\r\nend;\r\n\r\nfunction TJvDynControlCxDBMemo.ControlGetFont: TFont;\r\nbegin\r\n Result := Font;\r\nend;\r\n\r\nprocedure TJvDynControlCxDBMemo.ControlSetAnchors(Value: TAnchors);\r\nbegin\r\n Anchors := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxDBMemo.ControlSetCxProperties(Value: TCxDynControlWrapper);\r\nbegin\r\n Style.LookAndFeel.Assign(Value.LookAndFeel);\r\n Style.StyleController := Value.StyleController;\r\nend;\r\n\r\nprocedure TJvDynControlCxDBMemo.ControlSetFont(Value: TFont);\r\nbegin\r\n Font.Assign(Value);\r\nend;\r\n\r\n//=== { TJvDynControlCxDBRadioGroup } ========================================\r\n\r\nconstructor TJvDynControlCxDBRadioGroup.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FItems := TStringList.Create;\r\nend;\r\n\r\ndestructor TJvDynControlCxDBRadioGroup.Destroy;\r\nbegin\r\n FItems.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvDynControlCxDBRadioGroup.ControlSetDefaultProperties;\r\nbegin\r\nend;\r\n\r\nprocedure TJvDynControlCxDBRadioGroup.ControlSetCaption(const Value: string);\r\nbegin\r\n Caption := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxDBRadioGroup.ControlSetTabOrder(Value: Integer);\r\nbegin\r\n TabOrder := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxDBRadioGroup.ControlSetHint(const Value: string);\r\nbegin\r\n Hint := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxDBRadioGroup.ControlSetOnEnter(Value: TNotifyEvent);\r\nbegin\r\n OnEnter := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxDBRadioGroup.ControlSetOnExit(Value: TNotifyEvent);\r\nbegin\r\n OnExit := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxDBRadioGroup.ControlSetOnChange(Value: TNotifyEvent);\r\nbegin\r\n OnClick := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxDBRadioGroup.ControlSetOnClick(Value: TNotifyEvent);\r\nbegin\r\n OnClick := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxDBRadioGroup.ControlSetValue(Value: Variant);\r\nvar\r\n I: Integer;\r\nbegin\r\n if VarIsInt(Value) then\r\n ItemIndex := Value\r\n else\r\n begin\r\n ItemIndex := -1;\r\n for I := 0 to Properties.Items.Count - 1 do\r\n if TcxRadioGroupItem(Properties.Items[I]).Caption = Value then\r\n begin\r\n ItemIndex := I;\r\n Break;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJvDynControlCxDBRadioGroup.ControlGetValue: Variant;\r\nbegin\r\n Result := ItemIndex;\r\nend;\r\n\r\nprocedure TJvDynControlCxDBRadioGroup.ControlSetSorted(Value: Boolean);\r\nbegin\r\nend;\r\n\r\nprocedure TJvDynControlCxDBRadioGroup.ControlSetItems(Value: TStrings);\r\nvar\r\n I: Integer;\r\n Item: TcxRadioGroupItem;\r\nbegin\r\n FItems.Assign(Value);\r\n Properties.Items.Clear;\r\n for I := 0 to Value.Count - 1 do\r\n begin\r\n Item := TcxRadioGroupItem(Properties.Items.Add);\r\n Item.Caption := Value[I];\r\n end;\r\nend;\r\n\r\nfunction TJvDynControlCxDBRadioGroup.ControlGetItems: TStrings;\r\nbegin\r\n Result := FItems;\r\nend;\r\n\r\nprocedure TJvDynControlCxDBRadioGroup.ControlSetColumns(Value: Integer);\r\nbegin\r\n Properties.Columns := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxDBRadioGroup.ControlSetDataSource(Value: TDataSource);\r\nbegin\r\n Databinding.DataSource := Value;\r\nend;\r\n\r\nfunction TJvDynControlCxDBRadioGroup.ControlGetDataSource: TDataSource;\r\nbegin\r\n Result := DataBinding.DataSource;\r\nend;\r\n\r\nprocedure TJvDynControlCxDBRadioGroup.ControlSetDataField(const Value: string);\r\nbegin\r\n Databinding.DataField := Value;\r\nend;\r\n\r\nfunction TJvDynControlCxDBRadioGroup.ControlGetDataField: string;\r\nbegin\r\n Result := Databinding.DataField;\r\nend;\r\n\r\nprocedure TJvDynControlCxDBRadioGroup.ControlSetAnchors(Value: TAnchors);\r\nbegin\r\n Anchors := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxDBRadioGroup.ControlSetCxProperties(Value: TCxDynControlWrapper);\r\nbegin\r\n Style.LookAndFeel.Assign(Value.LookAndFeel);\r\n Style.StyleController := Value.StyleController;\r\nend;\r\n\r\n//=== { TJvDynControlCxDBListBox } ===========================================\r\n\r\nprocedure TJvDynControlCxDBListBox.ControlSetDefaultProperties;\r\nbegin\r\nend;\r\n\r\nprocedure TJvDynControlCxDBListBox.ControlSetCaption(const Value: string);\r\nbegin\r\nend;\r\n\r\nprocedure TJvDynControlCxDBListBox.ControlSetTabOrder(Value: Integer);\r\nbegin\r\n TabOrder := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxDBListBox.ControlSetHint(const Value: string);\r\nbegin\r\n Hint := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxDBListBox.ControlSetOnEnter(Value: TNotifyEvent);\r\nbegin\r\n OnEnter := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxDBListBox.ControlSetOnExit(Value: TNotifyEvent);\r\nbegin\r\n OnExit := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxDBListBox.ControlSetOnChange(Value: TNotifyEvent);\r\nbegin\r\n // Properties.OnChange := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxDBListBox.ControlSetOnClick(Value: TNotifyEvent);\r\nbegin\r\n OnClick := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxDBListBox.ControlSetValue(Value: Variant);\r\nbegin\r\n if VarIsInt(Value) then\r\n ItemIndex := Value\r\n else\r\n ItemIndex := Items.IndexOf(Value);\r\nend;\r\n\r\nfunction TJvDynControlCxDBListBox.ControlGetValue: Variant;\r\nbegin\r\n Result := ItemIndex;\r\nend;\r\n\r\nprocedure TJvDynControlCxDBListBox.ControlSetSorted(Value: Boolean);\r\nbegin\r\n Sorted := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxDBListBox.ControlSetItems(Value: TStrings);\r\nbegin\r\n Items.Assign(Value);\r\nend;\r\n\r\nfunction TJvDynControlCxDBListBox.ControlGetItems: TStrings;\r\nbegin\r\n Result := Items;\r\nend;\r\n\r\nprocedure TJvDynControlCxDBListBox.ControlSetOnDblClick(Value: TNotifyEvent);\r\nbegin\r\n OnDblClick := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxDBListBox.ControlSetDataSource(Value: TDataSource);\r\nbegin\r\n Databinding.DataSource := Value;\r\nend;\r\n\r\nfunction TJvDynControlCxDBListBox.ControlGetDataSource: TDataSource;\r\nbegin\r\n Result := DataBinding.DataSource;\r\nend;\r\n\r\nprocedure TJvDynControlCxDBListBox.ControlSetDataField(const Value: string);\r\nbegin\r\n Databinding.DataField := Value;\r\nend;\r\n\r\nfunction TJvDynControlCxDBListBox.ControlGetDataField: string;\r\nbegin\r\n Result := Databinding.DataField;\r\nend;\r\n\r\nprocedure TJvDynControlCxDBListBox.ControlSetAnchors(Value: TAnchors);\r\nbegin\r\n Anchors := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxDBListBox.ControlSetCxProperties(Value: TCxDynControlWrapper);\r\nbegin\r\n Style.LookAndFeel.Assign(Value.LookAndFeel);\r\n Style.StyleController := Value.StyleController;\r\nend;\r\n\r\n//=== { TJvDynControlCxDBComboBox } ==========================================\r\n\r\nprocedure TJvDynControlCxDBComboBox.ControlSetDefaultProperties;\r\nbegin\r\nend;\r\n\r\nprocedure TJvDynControlCxDBComboBox.ControlSetCaption(const Value: string);\r\nbegin\r\nend;\r\n\r\nprocedure TJvDynControlCxDBComboBox.ControlSetTabOrder(Value: Integer);\r\nbegin\r\n TabOrder := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxDBComboBox.ControlSetHint(const Value: string);\r\nbegin\r\n Hint := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxDBComboBox.ControlSetOnEnter(Value: TNotifyEvent);\r\nbegin\r\n OnEnter := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxDBComboBox.ControlSetOnExit(Value: TNotifyEvent);\r\nbegin\r\n OnExit := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxDBComboBox.ControlSetOnChange(Value: TNotifyEvent);\r\nbegin\r\n Properties.OnChange := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxDBComboBox.ControlSetOnClick(Value: TNotifyEvent);\r\nbegin\r\n OnClick := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxDBComboBox.ControlSetValue(Value: Variant);\r\nbegin\r\n Text := Value;\r\nend;\r\n\r\nfunction TJvDynControlCxDBComboBox.ControlGetValue: Variant;\r\nbegin\r\n Result := Text;\r\nend;\r\n\r\nprocedure TJvDynControlCxDBComboBox.ControlSetSorted(Value: Boolean);\r\nbegin\r\n Properties.Sorted := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxDBComboBox.ControlSetItems(Value: TStrings);\r\nbegin\r\n Properties.Items.Assign(Value);\r\nend;\r\n\r\nfunction TJvDynControlCxDBComboBox.ControlGetItems: TStrings;\r\nbegin\r\n Result := Properties.Items;\r\nend;\r\n\r\nprocedure TJvDynControlCxDBComboBox.ControlSetNewEntriesAllowed(Value: Boolean);\r\nbegin\r\n if Value then\r\n Properties.DropDownListStyle := lsEditList\r\n else\r\n Properties.DropDownListStyle := lsEditFixedList;\r\nend;\r\n\r\nprocedure TJvDynControlCxDBComboBox.ControlSetDataSource(Value: TDataSource);\r\nbegin\r\n Databinding.DataSource := Value;\r\nend;\r\n\r\nfunction TJvDynControlCxDBComboBox.ControlGetDataSource: TDataSource;\r\nbegin\r\n Result := DataBinding.DataSource;\r\nend;\r\n\r\nprocedure TJvDynControlCxDBComboBox.ControlSetDataField(const Value: string);\r\nbegin\r\n Databinding.DataField := Value;\r\nend;\r\n\r\nfunction TJvDynControlCxDBComboBox.ControlGetDataField: string;\r\nbegin\r\n Result := Databinding.DataField;\r\nend;\r\n\r\nprocedure TJvDynControlCxDBComboBox.ControlSetAnchors(Value: TAnchors);\r\nbegin\r\n Anchors := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxDBComboBox.ControlSetCxProperties(Value: TCxDynControlWrapper);\r\nbegin\r\n Style.LookAndFeel.Assign(Value.LookAndFeel);\r\n Style.StyleController := Value.StyleController;\r\nend;\r\n\r\n//=== { TJvDynControlCxDBImage } =============================================\r\n\r\nprocedure TJvDynControlCxDBImage.ControlSetDefaultProperties;\r\nbegin\r\nend;\r\n\r\nprocedure TJvDynControlCxDBImage.ControlSetCaption(const Value: string);\r\nbegin\r\n Caption := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxDBImage.ControlSetTabOrder(Value: Integer);\r\nbegin\r\n // TabOrder := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxDBImage.ControlSetHint(const Value: string);\r\nbegin\r\n Hint := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxDBImage.ControlSetOnEnter(Value: TNotifyEvent);\r\nbegin\r\n // OnEnter := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxDBImage.ControlSetOnExit(Value: TNotifyEvent);\r\nbegin\r\n // OnExit := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxDBImage.ControlSetOnClick(Value: TNotifyEvent);\r\nbegin\r\n OnClick := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxDBImage.ControlSetAutoSize(Value: Boolean);\r\nbegin\r\n AutoSize := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxDBImage.ControlSetIncrementalDisplay(Value: Boolean);\r\nbegin\r\n // IncrementalDisplay := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxDBImage.ControlSetCenter(Value: Boolean);\r\nbegin\r\n Properties.Center := Value;\r\nend;\r\n\r\n\r\nprocedure TJvDynControlCxDBImage.ControlSetProportional(Value: Boolean);\r\nbegin\r\n // Proportional := Value;\r\nend;\r\n\r\n\r\nprocedure TJvDynControlCxDBImage.ControlSetStretch(Value: Boolean);\r\nbegin\r\n Properties.Stretch := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxDBImage.ControlSetTransparent(Value: Boolean);\r\nbegin\r\n // Transparent := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxDBImage.ControlSetPicture(Value: TPicture);\r\nbegin\r\n Picture.Assign(Value);\r\nend;\r\n\r\nprocedure TJvDynControlCxDBImage.ControlSetGraphic(Value: TGraphic);\r\nbegin\r\n Picture.Assign(Value);\r\nend;\r\n\r\nfunction TJvDynControlCxDBImage.ControlGetPicture: TPicture;\r\nbegin\r\n Result := Picture;\r\nend;\r\n\r\nprocedure TJvDynControlCxDBImage.ControlSetDataSource(Value: TDataSource);\r\nbegin\r\n Databinding.DataSource := Value;\r\nend;\r\n\r\nfunction TJvDynControlCxDBImage.ControlGetDataSource: TDataSource;\r\nbegin\r\n Result := DataBinding.DataSource;\r\nend;\r\n\r\nprocedure TJvDynControlCxDBImage.ControlSetDataField(const Value: string);\r\nbegin\r\n Databinding.DataField := Value;\r\nend;\r\n\r\nfunction TJvDynControlCxDBImage.ControlGetDataField: string;\r\nbegin\r\n Result := Databinding.DataField;\r\nend;\r\n\r\nprocedure TJvDynControlCxDBImage.ControlSetAnchors(Value: TAnchors);\r\nbegin\r\n Anchors := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxDBImage.ControlSetCxProperties(Value: TCxDynControlWrapper);\r\nbegin\r\n Style.LookAndFeel.Assign(Value.LookAndFeel);\r\n Style.StyleController := Value.StyleController;\r\nend;\r\n\r\n//=== { TJvDynControlCxDBText } ==============================================\r\n\r\nprocedure TJvDynControlCxDBText.ControlSetDefaultProperties;\r\nbegin\r\nend;\r\n\r\nprocedure TJvDynControlCxDBText.ControlSetCaption(const Value: string);\r\nbegin\r\nend;\r\n\r\nprocedure TJvDynControlCxDBText.ControlSetTabOrder(Value: Integer);\r\nbegin\r\nend;\r\n\r\nprocedure TJvDynControlCxDBText.ControlSetHint(const Value: string);\r\nbegin\r\n Hint := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxDBText.ControlSetOnEnter(Value: TNotifyEvent);\r\nbegin\r\nend;\r\n\r\nprocedure TJvDynControlCxDBText.ControlSetOnExit(Value: TNotifyEvent);\r\nbegin\r\nend;\r\n\r\nprocedure TJvDynControlCxDBText.ControlSetOnClick(Value: TNotifyEvent);\r\nbegin\r\nend;\r\n\r\nprocedure TJvDynControlCxDBText.ControlSetDataSource(Value: TDataSource);\r\nbegin\r\n Databinding.DataSource := Value;\r\nend;\r\n\r\nfunction TJvDynControlCxDBText.ControlGetDataSource: TDataSource;\r\nbegin\r\n Result := DataBinding.DataSource;\r\nend;\r\n\r\nprocedure TJvDynControlCxDBText.ControlSetDataField(const Value: string);\r\nbegin\r\n Databinding.DataField := Value;\r\nend;\r\n\r\nfunction TJvDynControlCxDBText.ControlGetDataField: string;\r\nbegin\r\n Result := Databinding.DataField;\r\nend;\r\n\r\nprocedure TJvDynControlCxDBText.ControlSetAnchors(Value: TAnchors);\r\nbegin\r\n Anchors := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxDBText.ControlSetCxProperties(Value: TCxDynControlWrapper);\r\nbegin\r\n Style.LookAndFeel.Assign(Value.LookAndFeel);\r\n Style.StyleController := Value.StyleController;\r\nend;\r\n\r\n//=== { TJvDynControlCxDBNavigator } =========================================\r\n\r\nprocedure TJvDynControlCxDBNavigator.ControlSetDefaultProperties;\r\nbegin\r\nend;\r\n\r\nprocedure TJvDynControlCxDBNavigator.ControlSetCaption(const Value: string);\r\nbegin\r\nend;\r\n\r\nprocedure TJvDynControlCxDBNavigator.ControlSetTabOrder(Value: Integer);\r\nbegin\r\n TabOrder := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxDBNavigator.ControlSetHint(const Value: string);\r\nbegin\r\n Hint := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxDBNavigator.ControlSetOnEnter(Value: TNotifyEvent);\r\nbegin\r\n OnEnter := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxDBNavigator.ControlSetOnExit(Value: TNotifyEvent);\r\nbegin\r\n OnExit := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxDBNavigator.ControlSetOnClick(Value: TNotifyEvent);\r\nbegin\r\nend;\r\n\r\nprocedure TJvDynControlCxDBNavigator.ControlSetDataSource(Value: TDataSource);\r\nbegin\r\n DataSource := Value;\r\nend;\r\n\r\nfunction TJvDynControlCxDBNavigator.ControlGetDataSource: TDataSource;\r\nbegin\r\n Result := DataSource;\r\nend;\r\n\r\nprocedure TJvDynControlCxDBNavigator.ControlSetDataField(const Value: string);\r\nbegin\r\nend;\r\n\r\nfunction TJvDynControlCxDBNavigator.ControlGetDataField: string;\r\nbegin\r\n Result := '';\r\nend;\r\n\r\nprocedure TJvDynControlCxDBNavigator.ControlSetAnchors(Value: TAnchors);\r\nbegin\r\n Anchors := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxDBNavigator.ControlSetCxProperties(Value: TCxDynControlWrapper);\r\nbegin\r\n LookAndFeel.Assign(Value.LookAndFeel);\r\n //Style.StyleController := Value.StyleController;\r\nend;\r\n\r\n//=== { TJvDynControlCxDBDateTimeEdit } ======================================\r\n\r\nprocedure TJvDynControlCxDBDateTimeEdit.ControlSetDefaultProperties;\r\nbegin\r\n Properties.ShowTime := True;\r\n Properties.SaveTime := False;\r\n // Properties.InputKind := ikStandard;\r\nend;\r\n\r\nprocedure TJvDynControlCxDBDateTimeEdit.ControlSetReadOnly(Value: Boolean);\r\nbegin\r\n Properties.ReadOnly := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxDBDateTimeEdit.ControlSetCaption(const Value: string);\r\nbegin\r\nend;\r\n\r\nprocedure TJvDynControlCxDBDateTimeEdit.ControlSetTabOrder(Value: Integer);\r\nbegin\r\n TabOrder := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxDBDateTimeEdit.ControlSetOnEnter(Value: TNotifyEvent);\r\nbegin\r\n OnEnter := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxDBDateTimeEdit.ControlSetOnExit(Value: TNotifyEvent);\r\nbegin\r\n OnExit := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxDBDateTimeEdit.ControlSetOnChange(Value: TNotifyEvent);\r\nbegin\r\n Properties.OnChange := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxDBDateTimeEdit.ControlSetOnClick(Value: TNotifyEvent);\r\nbegin\r\nend;\r\n\r\nprocedure TJvDynControlCxDBDateTimeEdit.ControlSetHint(const Value: string);\r\nbegin\r\n Hint := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxDBDateTimeEdit.ControlSetValue(Value: Variant);\r\nbegin\r\n Text := Value;\r\nend;\r\n\r\nfunction TJvDynControlCxDBDateTimeEdit.ControlGetValue: Variant;\r\nbegin\r\n Result := Text;\r\nend;\r\n\r\n// IJvDynControlDate\r\n\r\nprocedure TJvDynControlCxDBDateTimeEdit.ControlSetMinDate(Value: TDateTime);\r\nbegin\r\n Properties.MinDate := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxDBDateTimeEdit.ControlSetMaxDate(Value: TDateTime);\r\nbegin\r\n Properties.MaxDate := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxDBDateTimeEdit.ControlSetFormat(const Value: string);\r\nbegin\r\n // Format := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxDBDateTimeEdit.ControlSetCxProperties(Value: TCxDynControlWrapper);\r\nbegin\r\n Style.LookAndFeel.Assign(Value.LookAndFeel);\r\n Style.StyleController := Value.StyleController;\r\nend;\r\n\r\nprocedure TJvDynControlCxDBDateTimeEdit.ControlSetDataSource(Value: TDataSource);\r\nbegin\r\n Databinding.DataSource := Value;\r\nend;\r\n\r\nfunction TJvDynControlCxDBDateTimeEdit.ControlGetDataSource: TDataSource;\r\nbegin\r\n Result := Databinding.DataSource;\r\nend;\r\n\r\nprocedure TJvDynControlCxDBDateTimeEdit.ControlSetDataField(const Value: string);\r\nbegin\r\n Databinding.DataField := Value;\r\nend;\r\n\r\nfunction TJvDynControlCxDBDateTimeEdit.ControlGetDataField: string;\r\nbegin\r\n Result := Databinding.DataField;\r\nend;\r\n\r\nprocedure TJvDynControlCxDBDateTimeEdit.ControlSetAnchors(Value: TAnchors);\r\nbegin\r\n Anchors := Value;\r\nend;\r\n\r\n//=== { TJvDynControlCxDBDateEdit } ==========================================\r\n\r\nprocedure TJvDynControlCxDBDateEdit.ControlSetDefaultProperties;\r\nbegin\r\n Properties.ShowTime := False;\r\n Properties.SaveTime := False;\r\n // Properties.InputKind := ikStandard;\r\nend;\r\n\r\nprocedure TJvDynControlCxDBDateEdit.ControlSetReadOnly(Value: Boolean);\r\nbegin\r\n Properties.ReadOnly := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxDBDateEdit.ControlSetCaption(const Value: string);\r\nbegin\r\nend;\r\n\r\nprocedure TJvDynControlCxDBDateEdit.ControlSetTabOrder(Value: Integer);\r\nbegin\r\n TabOrder := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxDBDateEdit.ControlSetOnEnter(Value: TNotifyEvent);\r\nbegin\r\n OnEnter := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxDBDateEdit.ControlSetOnExit(Value: TNotifyEvent);\r\nbegin\r\n OnExit := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxDBDateEdit.ControlSetOnChange(Value: TNotifyEvent);\r\nbegin\r\n Properties.OnChange := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxDBDateEdit.ControlSetOnClick(Value: TNotifyEvent);\r\nbegin\r\nend;\r\n\r\nprocedure TJvDynControlCxDBDateEdit.ControlSetHint(const Value: string);\r\nbegin\r\n Hint := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxDBDateEdit.ControlSetValue(Value: Variant);\r\nbegin\r\n Text := Value;\r\nend;\r\n\r\nfunction TJvDynControlCxDBDateEdit.ControlGetValue: Variant;\r\nbegin\r\n Result := Text;\r\nend;\r\n\r\n// IJvDynControlDate\r\n\r\nprocedure TJvDynControlCxDBDateEdit.ControlSetMinDate(Value: TDateTime);\r\nbegin\r\n Properties.MinDate := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxDBDateEdit.ControlSetMaxDate(Value: TDateTime);\r\nbegin\r\n Properties.MaxDate := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxDBDateEdit.ControlSetFormat(const Value: string);\r\nbegin\r\n // Format := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxDBDateEdit.ControlSetCxProperties(Value: TCxDynControlWrapper);\r\nbegin\r\n Style.LookAndFeel.Assign(Value.LookAndFeel);\r\n Style.StyleController := Value.StyleController;\r\nend;\r\n\r\nprocedure TJvDynControlCxDBDateEdit.ControlSetDataSource(Value: TDataSource);\r\nbegin\r\n Databinding.DataSource := Value;\r\nend;\r\n\r\nfunction TJvDynControlCxDBDateEdit.ControlGetDataSource: TDataSource;\r\nbegin\r\n Result := Databinding.DataSource;\r\nend;\r\n\r\nprocedure TJvDynControlCxDBDateEdit.ControlSetDataField(const Value: string);\r\nbegin\r\n Databinding.DataField := Value;\r\nend;\r\n\r\nfunction TJvDynControlCxDBDateEdit.ControlGetDataField: string;\r\nbegin\r\n Result := Databinding.DataField;\r\nend;\r\n\r\nprocedure TJvDynControlCxDBDateEdit.ControlSetAnchors(Value: TAnchors);\r\nbegin\r\n Anchors := Value;\r\nend;\r\n\r\n//=== { TJvDynControlCxDBTimeEdit } ==========================================\r\n\r\nprocedure TJvDynControlCxDBTimeEdit.ControlSetDefaultProperties;\r\nbegin\r\n Properties.ShowDate := False;\r\n Properties.UseCtrlIncrement := True;\r\nend;\r\n\r\nprocedure TJvDynControlCxDBTimeEdit.ControlSetReadOnly(Value: Boolean);\r\nbegin\r\n Properties.ReadOnly := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxDBTimeEdit.ControlSetCaption(const Value: string);\r\nbegin\r\nend;\r\n\r\nprocedure TJvDynControlCxDBTimeEdit.ControlSetTabOrder(Value: Integer);\r\nbegin\r\n TabOrder := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxDBTimeEdit.ControlSetOnEnter(Value: TNotifyEvent);\r\nbegin\r\n OnEnter := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxDBTimeEdit.ControlSetOnExit(Value: TNotifyEvent);\r\nbegin\r\n OnExit := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxDBTimeEdit.ControlSetOnChange(Value: TNotifyEvent);\r\nbegin\r\n Properties.OnChange := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxDBTimeEdit.ControlSetOnClick(Value: TNotifyEvent);\r\nbegin\r\nend;\r\n\r\nprocedure TJvDynControlCxDBTimeEdit.ControlSetHint(const Value: string);\r\nbegin\r\n Hint := Value;\r\nend;\r\n\r\nprocedure TJvDynControlCxDBTimeEdit.ControlSetValue(Value: Variant);\r\nbegin\r\n Text := Value;\r\nend;\r\n\r\nfunction TJvDynControlCxDBTimeEdit.ControlGetValue: Variant;\r\nbegin\r\n Result := Text;\r\nend;\r\n\r\nprocedure TJvDynControlCxDBTimeEdit.ControlSetCxProperties(Value: TCxDynControlWrapper);\r\nbegin\r\n Style.LookAndFeel.Assign(Value.LookAndFeel);\r\n Style.StyleController := Value.StyleController;\r\nend;\r\n\r\nprocedure TJvDynControlCxDBTimeEdit.ControlSetFormat(const Value: string);\r\nbegin\r\n // Properties.Format := Value;\r\n Properties.Use24HourFormat := (Pos('H', Value) > 0);\r\n if Pos('s', Value) > 0 then\r\n Properties.TimeFormat := tfHourMinSec\r\n else\r\n if Pos('m', Value) > 0 then\r\n Properties.TimeFormat := tfHourMin\r\n else\r\n Properties.TimeFormat := tfHour;\r\nend;\r\n\r\nprocedure TJvDynControlCxDBTimeEdit.ControlSetDataSource(Value: TDataSource);\r\nbegin\r\n Databinding.DataSource := Value;\r\nend;\r\n\r\nfunction TJvDynControlCxDBTimeEdit.ControlGetDataSource: TDataSource;\r\nbegin\r\n Result := Databinding.DataSource;\r\nend;\r\n\r\nprocedure TJvDynControlCxDBTimeEdit.ControlSetDataField(const Value: string);\r\nbegin\r\n Databinding.DataField := Value;\r\nend;\r\n\r\nfunction TJvDynControlCxDBTimeEdit.ControlGetDataField: string;\r\nbegin\r\n Result := Databinding.DataField;\r\nend;\r\n\r\nprocedure TJvDynControlCxDBTimeEdit.ControlSetAnchors(Value: TAnchors);\r\nbegin\r\n Anchors := Value;\r\nend;\r\n\r\n//=== { TJvDynControlEngineDevExpCxDB } ======================================\r\n\r\nfunction DynControlEngineCxDB: TJvDynControlEngineDB;\r\nbegin\r\n Result := IntDynControlEngineCxDB;\r\nend;\r\n\r\nprocedure SetDefaultDynControlEngineDBDevExp;\r\nbegin\r\n SetDefaultDynControlEngineDB(DynControlEngineCxDB);\r\nend;\r\n\r\ntype\r\n TJvDynControlEngineDevExpCxDB = class(TJvDynControlEngineDB)\r\n private\r\n FCxProperties: TCxDynControlWrapper;\r\n protected\r\n procedure SetcxProperties(Value: TCxDynControlWrapper);\r\n procedure RegisterControls; override;\r\n procedure TransferGridItemToControl(AGridItem: TcxCustomGridTableItem;\r\n ADataSource: TDataSource; AControl: TWinControl; AOptions: TJvCreateDBFieldsOnControlOptions);\r\n public\r\n constructor Create; override;\r\n destructor Destroy; override;\r\n function CreateControlClass(AControlClass: TControlClass; AOwner: TComponent; AParentControl: TWinControl;\r\n AControlName: string): TControl; override;\r\n function CreateControlsFromCxGridViewOnControl(AGridView: TcxCustomGridTableView;\r\n AControl: TWinControl; AOptions: TJvCreateDBFieldsOnControlOptions): Boolean;\r\n function CreateControlsFromDataComponentOnControl(ADataComponent: TComponent;\r\n AControl: TWinControl; AOptions: TJvCreateDBFieldsOnControlOptions): Boolean; override;\r\n function GetDataSourceFromDataComponent(ADataComponent: TComponent): TDataSource; override;\r\n published\r\n property CxProperties: TCxDynControlWrapper read FCxProperties write FCxProperties;\r\n end;\r\n\r\nconstructor TJvDynControlEngineDevExpCxDB.Create;\r\nbegin\r\n inherited Create;\r\n FCxProperties := TCxDynControlWrapper.Create;\r\nend;\r\n\r\ndestructor TJvDynControlEngineDevExpCxDB.Destroy;\r\nbegin\r\n FreeAndNil(FCxProperties);\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvDynControlEngineDevExpCxDB.SetcxProperties(Value: TCxDynControlWrapper);\r\nbegin\r\n if Value is TCxDynControlWrapper then\r\n FCxProperties.LookAndFeel.Assign(Value.LookAndFeel);\r\nend;\r\n\r\nfunction TJvDynControlEngineDevExpCxDB.CreateControlClass(AControlClass: TControlClass; AOwner: TComponent;\r\n AParentControl: TWinControl; AControlName: string): TControl;\r\nvar\r\n C: TControl;\r\nbegin\r\n C := inherited CreateControlClass(AControlClass, AOwner, AParentControl, AControlName);\r\n if Supports(C, IJvDynControlDevExpCx) then\r\n with C as IJvDynControlDevExpCx do\r\n ControlSetCxProperties(cxProperties);\r\n Result := C;\r\nend;\r\n\r\nprocedure TJvDynControlEngineDevExpCxDB.RegisterControls;\r\nbegin\r\n RegisterControlType(jctDBText, TJvDynControlCxDBText);\r\n RegisterControlType(jctDBEdit, TJvDynControlCxDBEdit);\r\n RegisterControlType(jctDBImage, TJvDynControlCxDBImage);\r\n RegisterControlType(jctDBCheckBox, TJvDynControlCxDBCheckBox);\r\n RegisterControlType(jctDBComboBox, TJvDynControlCxDBComboBox);\r\n RegisterControlType(jctDBListBox, TJvDynControlCxDBListBox);\r\n RegisterControlType(jctDBRadioGroup, TJvDynControlCxDBRadioGroup);\r\n RegisterControlType(jctDBDateTimeEdit, TJvDynControlCxDBDateTimeEdit);\r\n RegisterControlType(jctDBTimeEdit, TJvDynControlCxDBTimeEdit);\r\n RegisterControlType(jctDBDateEdit, TJvDynControlCxDBDateEdit);\r\n //// RegisterControlType(jctDBCalculateEdit, TJvDynControlCxDBEdit);\r\n //// RegisterControlType(jctDBSpinEdit, TJvDynControlCxDBEdit);\r\n RegisterControlType(jctDBDirectoryEdit, TJvDynControlCxDBDirectoryEdit);\r\n RegisterControlType(jctDBFileNameEdit, TJvDynControlCxDBFileNameEdit);\r\n RegisterControlType(jctDBMemo, TJvDynControlCxDBMemo);\r\n RegisterControlType(jctDBButtonEdit, TJvDynControlCxDBButtonEdit);\r\n // RegisterControlType(jctDBGrid, TJvDynControlCxDBGrid);\r\n RegisterControlType(jctDBNavigator, TJvDynControlCxDBNavigator);\r\nend;\r\n\r\nfunction TJvDynControlEngineDevExpCxDB.GetDataSourceFromDataComponent(ADataComponent: TComponent): TDataSource;\r\nbegin\r\n if not Assigned(ADataComponent) then\r\n Result := nil\r\n else\r\n if ADataComponent is TcxCustomGridTableView then\r\n if TcxCustomGridTableView(ADataComponent).DataController is TcxGridDBDataController then\r\n Result := TcxGridDBDataController(TcxCustomGridTableView(ADataComponent).DataController).DataSource\r\n else\r\n Result := nil\r\n else\r\n if (ADataComponent is TcxCustomGrid) and\r\n (TcxCustomGrid(ADataComponent).ActiveView is TcxCustomGridTableView) then\r\n if TcxCustomGridTableView(TcxCustomGrid(ADataComponent).ActiveView).DataController is TcxGridDBDataController\r\n then\r\n Result :=\r\n TcxGridDBDataController(TcxCustomGridTableView(TcxCustomGrid(ADataComponent).ActiveView).DataController).DataSource\r\n else\r\n Result := nil\r\n else\r\n if ADataComponent is TcxDBTextEdit then\r\n Result := TcxDBTextEdit(ADataComponent).Databinding.DataSource\r\n else\r\n if ADataComponent is TcxDBNavigator then\r\n Result := TcxDBNavigator(ADataComponent).DataSource\r\n else\r\n if ADataComponent is TcxDBListbox then\r\n Result := TcxDBListbox(ADataComponent).Databinding.DataSource\r\n else\r\n if ADataComponent is TcxDBLookupComboBox then\r\n Result := TcxDBLookupComboBox(ADataComponent).Databinding.DataSource\r\n else\r\n if ADataComponent is TcxDBImage then\r\n Result := TcxDBImage(ADataComponent).Databinding.DataSource\r\n else\r\n if ADataComponent is TcxDBMemo then\r\n Result := TcxDBMemo(ADataComponent).Databinding.DataSource\r\n else\r\n if ADataComponent is TcxDBRadioGroup then\r\n Result := TcxDBRadioGroup(ADataComponent).Databinding.DataSource\r\n else\r\n if ADataComponent is TcxDBRichEdit then\r\n Result := TcxDBRichEdit(ADataComponent).Databinding.DataSource\r\n else\r\n if ADataComponent is TcxDBCheckBox then\r\n Result := TcxDBCheckBox(ADataComponent).Databinding.DataSource\r\n else\r\n Result := inherited GetDataSourceFromDataComponent(ADataComponent);\r\nend;\r\n\r\ntype\r\n TAccesscxCustomGridTableItem = class(TcxCustomGridTableItem);\r\n TAccesscxCustomEdit = class(TcxCustomEdit);\r\n TAccessCustomControl = class(TCustomControl);\r\n\r\nprocedure TJvDynControlEngineDevExpCxDB.TransferGridItemToControl(AGridItem: TcxCustomGridTableItem;\r\n ADataSource: TDataSource; AControl: TWinControl; AOptions: TJvCreateDBFieldsOnControlOptions);\r\nvar\r\n Control: TWinControl;\r\n LabelControl: TWinControl;\r\n GridDataBinding: TcxGridItemDBDataBinding;\r\nbegin\r\n if not (AGridItem is TcxGridColumn) or\r\n not (AGridItem.DataBinding is TcxGridItemDBDataBinding) then\r\n Exit;\r\n GridDataBinding := TcxGridItemDBDataBinding(AGridItem.DataBinding);\r\n if not Assigned(GridDataBinding.Field) then\r\n Exit;\r\n with AOptions do\r\n begin\r\n if TcxGridColumn(AGridItem).Visible or\r\n (TcxGridColumn(AGridItem).GroupIndex >= 0) or\r\n ShowInvisibleFields then\r\n begin\r\n if aGridItem.PropertiesClass = TcxMemoProperties then\r\n begin\r\n Control := TWinControl(CreateDBControl(jctDBMemo, AControl, AControl, '', aDataSource,\r\n GridDataBinding.Field.FieldName));\r\n if Supports(Control, IJvDynControlMemo) and Assigned(TcxGridColumn(aGridItem).Properties) then\r\n with Control as IJvDynControlMemo do\r\n begin\r\n ControlSetScrollbars(TcxMemoProperties(TcxGridColumn(aGridItem).Properties).Scrollbars);\r\n ControlSetWantReturns(TcxMemoProperties(TcxGridColumn(aGridItem).Properties).WantReturns);\r\n ControlSetWantTabs(TcxMemoProperties(TcxGridColumn(aGridItem).Properties).WantTabs);\r\n ControlSetWordwrap(TcxMemoProperties(TcxGridColumn(aGridItem).Properties).WordWrap);\r\n end;\r\n end\r\n else\r\n if aGridItem.PropertiesClass = TcxCheckBoxProperties then\r\n begin\r\n Control := TWinControl(CreateDBControl(jctDBCheckBox, AControl, AControl, '', aDataSource,\r\n GridDataBinding.Field.FieldName));\r\n if Supports(Control, IJvDynControlDBCheckBox) and Assigned(TcxGridColumn(aGridItem).Properties) then\r\n with Control as IJvDynControlDBCheckBox do\r\n begin\r\n ControlSetValueChecked(TcxCheckBoxProperties(TcxGridColumn(aGridItem).Properties).ValueChecked);\r\n ControlSetValueUnChecked(TcxCheckBoxProperties(TcxGridColumn(aGridItem).Properties).ValueUnChecked);\r\n end;\r\n end\r\n else\r\n if aGridItem.PropertiesClass = TcxComboBoxProperties then\r\n begin\r\n Control := TWinControl(CreateDBControl(jctDBCheckBox, AControl, AControl, '', aDataSource,\r\n GridDataBinding.Field.FieldName));\r\n if Supports(Control, IJvDynControlDBCheckBox) and Assigned(TcxGridColumn(aGridItem).Properties) then\r\n with Control as IJvDynControlDBCheckBox do\r\n begin\r\n ControlSetValueChecked(TcxCheckBoxProperties(TcxGridColumn(aGridItem).Properties).ValueChecked);\r\n ControlSetValueUnChecked(TcxCheckBoxProperties(TcxGridColumn(aGridItem).Properties).ValueUnChecked);\r\n end;\r\n end\r\n else\r\n Control := CreateDBFieldControl(GridDataBinding.Field, AControl, AControl, '', ADataSource);\r\n if FieldDefaultWidth > 0 then\r\n Control.Width := FieldDefaultWidth\r\n else\r\n begin\r\n if UseFieldSizeForWidth then\r\n if GridDataBinding.Field.Size > 0 then\r\n Control.Width :=\r\n TAccessCustomControl(AControl).Canvas.TextWidth('X') * GridDataBinding.Field.Size\r\n else\r\n if (aGridItem.PropertiesClass = TcxMemoProperties) and (FieldMaxWidth > 0) then\r\n Control.Width := FieldMaxWidth\r\n else\r\n else\r\n if GridDataBinding.Field.DisplayWidth > 0 then\r\n Control.Width :=\r\n TAccessCustomControl(AControl).Canvas.TextWidth('X') * GridDataBinding.Field.DisplayWidth;\r\n if (FieldMaxWidth > 0) and (Control.Width > FieldMaxWidth) then\r\n Control.Width := FieldMaxWidth\r\n else\r\n if (FieldMinWidth > 0) and (Control.Width < FieldMinWidth) then\r\n Control.Width := FieldMinWidth\r\n end;\r\n if Assigned(TcxGridColumn(aGridItem).Properties) then\r\n if Supports(Control, IJvDynControlReadOnly) then\r\n with Control as IJvDynControlReadOnly do\r\n ControlSetReadOnly(TcxGridColumn(AGridItem).Properties.ReadOnly);\r\n\r\n if UseParentColorForReadOnly then\r\n // Use ParentColor when the field is ReadOnly\r\n if not ADataSource.DataSet.CanModify or GridDataBinding.Field.ReadOnly then\r\n if isPublishedProp(Control, 'ParentColor') then\r\n SetOrdProp(Control, 'ParentColor', Ord(True));\r\n\r\n LabelControl := GetDynControlEngine.CreateLabelControlPanel(AControl, AControl,\r\n '', '&' + AGridItem.Caption, Control, LabelOnTop, LabelDefaultWidth);\r\n if FieldWidthStep > 0 then\r\n if (LabelControl.Width mod FieldWidthStep) <> 0 then\r\n LabelControl.Width := ((LabelControl.Width div FieldWidthStep) + 1) * FieldWidthStep;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJvDynControlEngineDevExpCxDB.CreateControlsFromCxGridViewOnControl(AGridView: TcxCustomGridTableView;\r\n AControl: TWinControl; AOptions: TJvCreateDBFieldsOnControlOptions): Boolean;\r\nvar\r\n I: Integer;\r\n CreateOptions: TJvCreateDBFieldsOnControlOptions;\r\n GridDataController: TcxGridDBDataController;\r\nbegin\r\n Result := False;\r\n if not Assigned(AOptions) then\r\n CreateOptions := TJvCreateDBFieldsOnControlOptions.Create\r\n else\r\n CreateOptions := AOptions;\r\n try\r\n if tcxCustomGridView(AGridView).DataController is TcxGridDBDataController then\r\n GridDataController := TcxGridDBDataController(AGridView.DataController)\r\n else\r\n Exit;\r\n for I := 0 to AGridView.GroupedItemCount - 1 do\r\n TransferGridItemToControl(AGridView.GroupedItems[I], GridDataController.DataSource, AControl, CreateOptions);\r\n for I := 0 to AGridView.VisibleItemCount - 1 do\r\n TransferGridItemToControl(AGridView.VisibleItems[I], GridDataController.DataSource, AControl, CreateOptions);\r\n finally\r\n if not Assigned(AOptions) then\r\n CreateOptions.Free;\r\n end;\r\n Result := True;\r\nend;\r\n\r\nfunction TJvDynControlEngineDevExpCxDB.CreateControlsFromDataComponentOnControl(ADataComponent: TComponent;\r\n AControl: TWinControl; AOptions: TJvCreateDBFieldsOnControlOptions): Boolean;\r\nbegin\r\n if Assigned(ADataComponent) then\r\n if (ADataComponent is TcxGrid) and\r\n (TcxGrid(ADataComponent).ActiveView is TcxCustomGridTableView) then\r\n Result := CreateControlsFromcxGridViewOnControl(TcxCustomGridTableView(TcxGrid(ADataComponent).ActiveView),\r\n AControl, AOptions)\r\n else\r\n if ADataComponent is TcxCustomGridTableView then\r\n Result := CreateControlsFromcxGridViewOnControl(TcxCustomGridTableView(ADataComponent), AControl, AOptions)\r\n else\r\n Result := inherited CreateControlsFromDataComponentOnControl(ADataComponent, AControl, AOptions)\r\n else\r\n Result := False;\r\nend;\r\n\r\n{$ENDIF USE_3RDPARTY_DEVEXPRESS_CXEDITOR}\r\n\r\ninitialization\r\n {$IFDEF UNITVERSIONING}\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n {$ENDIF UNITVERSIONING}\r\n {$IFDEF USE_3RDPARTY_DEVEXPRESS_CXEDITOR}\r\n IntDynControlEngineCxDB := TJvDynControlEngineDevExpCxDB.Create;\r\n SetDefaultDynControlEngineDB(IntDynControlEngineCxDB);\r\n {$ENDIF USE_3RDPARTY_DEVEXPRESS_CXEDITOR}\r\n\r\nfinalization\r\n {$IFDEF USE_3RDPARTY_DEVEXPRESS_CXEDITOR}\r\n FreeAndNil(IntDynControlEngineCxDB);\r\n {$ENDIF USE_3RDPARTY_DEVEXPRESS_CXEDITOR}\r\n {$IFDEF UNITVERSIONING}\r\n UnregisterUnitVersion(HInstance);\r\n {$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvDynControlEngineIntf.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Initial Developer of the Original Code is Jens Fudickar [jens dott fudickar att oratool dott de]\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\nJens Fudickar [jens dott fudickar att oratool dott de]\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvDynControlEngineIntf.pas 13415 2012-09-10 09:51:54Z obones $\r\n\r\nunit JvDynControlEngineIntf;\r\n\r\n{$I jvcl.inc}\r\n{$I crossplatform.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n ActnList, Graphics, ComCtrls, ImgList,\r\n Classes, Controls, Forms, StdCtrls, ExtCtrls, Buttons, Dialogs,\r\n {$IFDEF HAS_UNIT_SYSTEM_UITYPES}\r\n System.UITypes,\r\n {$ENDIF HAS_UNIT_SYSTEM_UITYPES}\r\n FileCtrl, SysUtils;\r\n\r\ntype\r\n IJvDynControl = interface\r\n ['{E5A52F18-A7B2-4BE8-BAB6-D4F70A0999B3}']\r\n procedure ControlSetDefaultProperties;\r\n procedure ControlSetTabOrder(Value: Integer);\r\n procedure ControlSetOnEnter(Value: TNotifyEvent);\r\n procedure ControlSetOnExit(Value: TNotifyEvent);\r\n procedure ControlSetOnClick(Value: TNotifyEvent);\r\n procedure ControlSetHint(const Value: string);\r\n procedure ControlSetAnchors(Value: TAnchors);\r\n end;\r\n\r\n IJvDynControlCaption = interface\r\n ['{4D666A7B-5982-401F-915A-69FFD8264276}']\r\n procedure ControlSetCaption(const Value: string);\r\n function ControlGetCaption: string;\r\n property ControlCaption : string read ControlGetCaption write ControlSetCaption;\r\n end;\r\n\r\n IJvDynControlAction = interface\r\n ['{8AB9511C-A03A-4388-A00A-AB95B7041133}']\r\n procedure ControlSetAction(Value: TCustomAction);\r\n end;\r\n\r\n IJvDynControlData = interface\r\n ['{569BFBFD-DFFF-44CF-AAD9-C67A0E48EE15}']\r\n procedure ControlSetOnChange(Value: TNotifyEvent);\r\n procedure ControlSetValue(Value: Variant);\r\n function ControlGetValue: Variant;\r\n property ControlValue: Variant read ControlGetValue write ControlSetValue;\r\n end;\r\n\r\n IJvDynControlFont = interface\r\n ['{7D628739-6C27-4641-A116-5898B630AEF6}']\r\n procedure ControlSetFont (Value: TFont);\r\n function ControlGetFont: TFont;\r\n property ControlFont: TFont read ControlGetFont write ControlSetFont;\r\n end;\r\n\r\n IJvDynControlReadOnly = interface\r\n ['{24E45D23-AC66-4644-8403-81FF81E28B89}']\r\n procedure ControlSetReadOnly(Value: Boolean);\r\n end;\r\n\r\n IJvDynControlAutoSize = interface\r\n ['{8807045B-5FDB-4173-827D-B527D8018870}']\r\n procedure ControlSetAutoSize(Value: Boolean);\r\n end;\r\n\r\n IJvDynControlAlign = interface\r\n ['{03FF9D1F-6169-443C-A6AB-8FB1F6D1CA30}']\r\n procedure ControlSetAlign(Value: TAlign);\r\n end;\r\n\r\n IJvDynControlAlignment = interface\r\n ['{BBF3775F-61A5-4455-8C54-43DCDA05E149}']\r\n procedure ControlSetAlignment(Value: TAlignment);\r\n end;\r\n\r\n IJvDynControlColor = interface\r\n ['{D6E907A4-0E6F-4AB7-98D5-F9C7660660F0}']\r\n procedure ControlSetColor(Value: TColor);\r\n procedure ControlSetParentColor(Value: Boolean);\r\n end;\r\n\r\n IJvDynControlBevelBorder = interface\r\n ['{20DAC6BE-340D-456B-87C6-0BD71C4AA4E8}']\r\n procedure ControlSetBevelInner(Value: TBevelCut);\r\n procedure ControlSetBevelKind(Value: TBevelKind);\r\n procedure ControlSetBevelOuter(Value: TBevelCut);\r\n procedure ControlSetBorderStyle(Value: TBorderStyle);\r\n procedure ControlSetBorderWidth(Value: Integer);\r\n end;\r\n\r\n IJvDynControlItems = interface\r\n ['{A4391F0B-67AD-4937-B6D9-A6DBEECDFAE8}']\r\n procedure ControlSetSorted(Value: Boolean);\r\n procedure ControlSetItems(Value: TStrings);\r\n function ControlGetItems: TStrings;\r\n property ControlItems: TStrings read ControlGetItems write ControlSetItems;\r\n end;\r\n\r\n IJvDynControlCheckComboBox = interface\r\n ['{86D2DD54-5114-42B2-9E44-1D32ECFDA5D0}']\r\n procedure ControlSetDelimiter(Value: string);\r\n function ControlGetDelimiter: string;\r\n property Delimiter: string read ControlGetDelimiter write ControlSetDelimiter;\r\n end;\r\n\r\n IJvDynControlItemIndex = interface\r\n ['{C4C80378-EC64-4DE0-B4D0-6BE1E09B06A1}']\r\n function ControlGetItemIndex: Integer;\r\n procedure ControlSetItemIndex(const Value: Integer);\r\n property ControlItemIndex: Integer read ControlGetItemIndex write\r\n ControlSetItemIndex;\r\n end;\r\n\r\n IJvDynControlEdit = interface\r\n ['{8E70DDD2-2D22-4EA9-B8E2-A25DE3162942}']\r\n procedure ControlSetPasswordChar(Value: char);\r\n procedure ControlSetEditMask(const Value: string);\r\n end;\r\n\r\n IJvDynControlLabel = interface\r\n ['{247D29CD-ABA4-4F87-A25D-4987BD950F0C}']\r\n procedure ControlSetFocusControl(Value: TWinControl);\r\n procedure ControlSetWordWrap(Value: Boolean);\r\n end;\r\n\r\n TJvDynControlFileNameDialogKind = (jdkOpen, jdkOpenPicture, jdkSave, jdkSavePicture);\r\n\r\n IJvDynControlFileName = interface\r\n ['{2F75D45F-6837-4482-9BE5-499450B7350A}']\r\n procedure ControlSetInitialDir(const Value: string);\r\n procedure ControlSetDefaultExt(const Value: string);\r\n procedure ControlSetDialogTitle(const Value: string);\r\n procedure ControlSetDialogOptions(Value: TOpenOptions);\r\n procedure ControlSetFilter(const Value: string);\r\n procedure ControlSetFilterIndex(Value: Integer);\r\n procedure ControlSetDialogKind(Value: TJvDynControlFileNameDialogKind);\r\n end;\r\n\r\n IJvDynControlDirectory = interface\r\n ['{1EAC8D4D-F839-43FD-B859-627874E41874}']\r\n procedure ControlSetInitialDir(const Value: string);\r\n procedure ControlSetDialogTitle(const Value: string);\r\n procedure ControlSetDialogOptions(Value: TSelectDirOpts);\r\n end;\r\n\r\n IJvDynControlComboBox = interface\r\n ['{9E9B46D8-2BAD-4BAA-BFDC-88FA0F3C847D}']\r\n procedure ControlSetNewEntriesAllowed(Value: Boolean);\r\n end;\r\n\r\n IJvDynControlDate = interface\r\n ['{AB9EBBAB-5158-4371-A2CF-07F6D0AB86BB}']\r\n procedure ControlSetMinDate(Value: TDateTime);\r\n procedure ControlSetMaxDate(Value: TDateTime);\r\n procedure ControlSetFormat(const Value: string);\r\n end;\r\n\r\n IJvDynControlTime = interface\r\n ['{E4FF3356-62C4-4C80-B9D6-2C956D21058F}']\r\n procedure ControlSetFormat(const Value: string);\r\n end;\r\n\r\n IJvDynControlRadioGroup = interface\r\n ['{ED143973-5D21-41CF-85E1-5EE84E58BCEF}']\r\n procedure ControlSetColumns(Value: Integer);\r\n end;\r\n\r\n IJvDynControlSpin = interface\r\n ['{7E178DEE-6AC2-47F3-B2F8-D5D68B4EC579}']\r\n procedure ControlSetIncrement(Value: Integer);\r\n procedure ControlSetMinValue(Value: double);\r\n procedure ControlSetMaxValue(Value: double);\r\n procedure ControlSetUseForInteger(Value: Boolean);\r\n end;\r\n\r\n IJvDynControlPanel = interface\r\n ['{EB2435FE-D9A6-4D33-9F01-589D0C93C6AC}']\r\n procedure ControlSetBorder(ABevelInner: TPanelBevel;\r\n ABevelOuter: TPanelBevel; ABevelWidth: Integer; ABorderStyle: TBorderStyle;\r\n ABorderWidth: Integer);\r\n end;\r\n\r\n IJvDynControlImage = interface\r\n ['{2E07C9CD-A351-4F86-91F1-45E043455669}']\r\n procedure ControlSetAutoSize(Value: Boolean);\r\n procedure ControlSetIncrementalDisplay(Value: Boolean);\r\n procedure ControlSetCenter(Value: Boolean);\r\n procedure ControlSetProportional(Value: Boolean);\r\n procedure ControlSetStretch(Value: Boolean);\r\n procedure ControlSetTransparent(Value: Boolean);\r\n procedure ControlSetPicture(Value: TPicture);\r\n procedure ControlSetGraphic(Value: TGraphic);\r\n function ControlGetPicture: TPicture;\r\n end;\r\n\r\n IJvDynControlButton = interface\r\n ['{65193802-7E31-47FD-A4B8-E1201E0A2F38}']\r\n procedure ControlSetDefault(Value: Boolean);\r\n procedure ControlSetCancel(Value: Boolean);\r\n procedure ControlSetGlyph(Value: TBitmap);\r\n procedure ControlSetNumGlyphs(Value: Integer);\r\n procedure ControlSetLayout(Value: TButtonLayout);\r\n end;\r\n\r\n IJvDynControlButtonEdit = interface\r\n ['{F5A108E0-0B89-4CD7-9FAE-1547F00CEF62}']\r\n procedure ControlSetOnButtonClick(Value: TNotifyEvent);\r\n procedure ControlSetButtonCaption(const Value: string);\r\n end;\r\n\r\n IJvDynControlMemo = interface\r\n ['{3AF11540-A5D5-4C9D-9977-DD3D78F1F94F}']\r\n procedure ControlSetWantTabs(Value: Boolean);\r\n procedure ControlSetWantReturns(Value: Boolean);\r\n procedure ControlSetWordWrap(Value: Boolean);\r\n procedure ControlSetScrollbars(Value: TScrollStyle);\r\n end;\r\n\r\n IJvDynControlDblClick = interface\r\n ['{EB2435FE-D9A6-4D33-9F01-589D0C93C6AC}']\r\n procedure ControlSetOnDblClick(Value: TNotifyEvent);\r\n end;\r\n\r\n IJvDynControlCheckListBox = interface\r\n ['{9C50DD6C-E147-4719-A4E9-7F11AD45606C}']\r\n procedure ControlSetAllowGrayed(Value: Boolean);\r\n procedure ControlSetChecked(Index: Integer; Value: Boolean);\r\n procedure ControlSetItemEnabled(Index: Integer; Value: Boolean);\r\n procedure ControlSetHeader(Index: Integer; Value: Boolean);\r\n procedure ControlSetState(Index: Integer; Value: TCheckBoxState);\r\n function ControlGetChecked(Index: Integer): Boolean;\r\n function ControlGetItemEnabled(Index: Integer): Boolean;\r\n function ControlGetHeader(Index: Integer): Boolean;\r\n function ControlGetState(Index: Integer): TCheckBoxState;\r\n end;\r\n\r\n IJvDynControlCheckBox = interface\r\n ['{632BF70D-5F9F-4164-8137-4E344A5C41A3}']\r\n procedure ControlSetAllowGrayed(Value: Boolean);\r\n procedure ControlSetState(Value: TCheckBoxState);\r\n function ControlGetState: TCheckBoxState;\r\n property ControlState: TCheckBoxState read ControlGetState write ControlSetState;\r\n end;\r\n\r\n IJvDynControlTreeView = interface\r\n ['{8DFBBAB2-C9C4-4709-A71F-E522D3998650}']\r\n procedure ControlSetReadOnly(Value: Boolean);\r\n procedure ControlSetAutoExpand(Value: Boolean);\r\n procedure ControlSetHotTrack(Value: Boolean);\r\n procedure ControlSetShowHint(Value: Boolean);\r\n procedure ControlSetShowLines(Value: Boolean);\r\n procedure ControlSetShowRoot(Value: Boolean);\r\n procedure ControlSetToolTips(Value: Boolean);\r\n procedure ControlSetItems(Value: TTreeNodes);\r\n function ControlGetItems: TTreeNodes;\r\n function ControlGetSelected: TTreeNode;\r\n procedure ControlSetSelected(const Value: TTreeNode);\r\n procedure ControlSetImages(Value: TCustomImageList);\r\n procedure ControlSetStateImages(Value: TCustomImageList);\r\n procedure ControlSetOnChange(Value: TTVChangedEvent);\r\n procedure ControlSetOnChanging(Value: TTVChangingEvent);\r\n procedure ControlSetSortType(Value: TSortType);\r\n procedure ControlSortItems;\r\n property ControlItems: TTreeNodes read ControlGetItems write ControlSetItems;\r\n property ControlSelected: TTreeNode read ControlGetSelected write\r\n ControlSetSelected;\r\n end;\r\n\r\n IJvDynControlProgressbar = interface\r\n ['{BAC5B6CD-3B65-4EBA-910A-49D152671B06}']\r\n procedure ControlSetMarquee(Value: Boolean);\r\n procedure ControlSetMax(Value: Integer);\r\n procedure ControlSetMin(Value: Integer);\r\n procedure ControlSetOrientation(Value: TProgressBarOrientation);\r\n procedure ControlSetPosition(Value: Integer);\r\n procedure ControlSetSmooth(Value: Boolean);\r\n procedure ControlSetStep(Value: Integer);\r\n end;\r\n\r\n IJvDynControlTabControl = interface\r\n ['{1C9FA637-14CC-4329-886F-696FD08AE951}']\r\n procedure ControlCreateTab(const AName: string);\r\n procedure ControlSetOnChangeTab(OnChangeEvent: TNotifyEvent);\r\n procedure ControlSetOnChangingTab(OnChangingEvent: TTabChangingEvent);\r\n procedure ControlSetTabIndex(Index: Integer);\r\n function ControlGetTabIndex: Integer;\r\n property ControlTabIndex: Integer read ControlGetTabIndex write ControlSetTabIndex;\r\n procedure ControlSetMultiLine(Value: Boolean);\r\n procedure ControlSetScrollOpposite(Value: Boolean);\r\n procedure ControlSetHotTrack(Value: Boolean);\r\n procedure ControlSetRaggedRight(Value: Boolean);\r\n end;\r\n\r\n IJvDynControlPageControl = interface\r\n ['{6FCC9619-EA8D-43E6-BB66-D754A01B0720}']\r\n function ControlGetPage(const PageName: string): TWinControl;\r\n end;\r\n\r\n TJvDynControlInspectorControlOnTranslatePropertyNameEvent = function(const aPropertyName : String) : string of object;\r\n TJvDynControlInspectorControlOnDisplayPropertyEvent = function(const\r\n aPropertyName : String): boolean of object;\r\n TJvDynControlInspectorControlOnPropertyChangeEvent = procedure(var OldPropertyName, NewPropertyName : string) of object;\r\n\r\n IJvDynControlRTTIInspectorControl = interface\r\n ['{D7C445BF-1ED9-467B-BD01-7D40513016B4}']\r\n function ControlGetCurrentPropertyName: string;\r\n function ControlGetInspectedObject: TObject;\r\n function ControlGetOnDisplayProperty:\r\n TJvDynControlInspectorControlOnDisplayPropertyEvent;\r\n function ControlGetOnTranslatePropertyName:\r\n TJvDynControlInspectorControlOnTranslatePropertyNameEvent;\r\n function ControlGetVisibleItemsCount: Integer;\r\n function ControlIsPropertySupported(const aPropertyName : string): Boolean;\r\n procedure ControlSaveEditorValues;\r\n procedure ControlSetInspectedObject(const Value: TObject);\r\n procedure ControlSetOnDisplayProperty(const Value:\r\n TJvDynControlInspectorControlOnDisplayPropertyEvent);\r\n procedure ControlSetOnTranslatePropertyName(const Value:\r\n TJvDynControlInspectorControlOnTranslatePropertyNameEvent);\r\n function GetControlDividerWidth: Integer;\r\n function GetControlOnPropertyChange:\r\n TJvDynControlInspectorControlOnPropertyChangeEvent;\r\n procedure SetControlDividerWidth(const Value: Integer);\r\n procedure SetControlOnPropertyChange(const Value:\r\n TJvDynControlInspectorControlOnPropertyChangeEvent);\r\n property ControlDividerWidth: Integer read GetControlDividerWidth write\r\n SetControlDividerWidth;\r\n property ControlInspectedObject: TObject read ControlGetInspectedObject write\r\n ControlSetInspectedObject;\r\n property ControlOnDisplayProperty:\r\n TJvDynControlInspectorControlOnDisplayPropertyEvent read\r\n ControlGetOnDisplayProperty write ControlSetOnDisplayProperty;\r\n property ControlOnPropertyChange:\r\n TJvDynControlInspectorControlOnPropertyChangeEvent read\r\n GetControlOnPropertyChange write SetControlOnPropertyChange;\r\n property ControlOnTranslatePropertyName:\r\n TJvDynControlInspectorControlOnTranslatePropertyNameEvent read\r\n ControlGetOnTranslatePropertyName write ControlSetOnTranslatePropertyName;\r\n end;\r\n\r\n IJvDynControlColorComboBoxControl = interface\r\n ['{B95DDBED-DFB0-47D7-AA0C-1AB879EAD392}']\r\n function ControlGetColorName(AColor: TColor): string;\r\n function ControlGetSelectedColor: TColor;\r\n procedure ControlSetSelectedColor(const Value: TColor);\r\n function GetControlDefaultColor: TColor; stdcall;\r\n procedure SetControlDefaultColor(const Value: TColor); stdcall;\r\n property ControlSelectedColor: TColor read ControlGetSelectedColor write\r\n ControlSetSelectedColor;\r\n property ControlDefaultColor: TColor read GetControlDefaultColor write\r\n SetControlDefaultColor;\r\n\r\n end;\r\n\r\n IJvDynControlKey= interface\r\n ['{BE648BE4-857C-4423-A229-3484E3686ABD}']\r\n function ControlGetOnKeyDown: TKeyEvent;\r\n function ControlGetOnKeyPress: TKeyPressEvent;\r\n function ControlGetOnKeyUp: TKeyEvent;\r\n procedure ControlSetOnKeyDown(const Value: TKeyEvent);\r\n procedure ControlSetOnKeyPress(const Value: TKeyPressEvent);\r\n procedure ControlSetOnKeyUp(const Value: TKeyEvent);\r\n property ControlOnKeyDown: TKeyEvent read ControlGetOnKeyDown write ControlSetOnKeyDown;\r\n property ControlOnKeyPress: TKeyPressEvent read ControlGetOnKeyPress write ControlSetOnKeyPress;\r\n property ControlOnKeyUp: TKeyEvent read ControlGetOnKeyUp write ControlSetOnKeyUp;\r\n end;\r\n\r\n IJvDynControlMouse= interface\r\n ['{032FFE48-C7B8-4388-A63D-A275FF2FF619}']\r\n function ControlGetOnMouseDown: TMouseEvent;\r\n function ControlGetOnMouseEnter: TNotifyEvent;\r\n function ControlGetOnMouseLeave: TNotifyEvent;\r\n function ControlGetOnMouseMove: TMouseMoveEvent;\r\n function ControlGetOnMouseUp: TMouseEvent;\r\n procedure ControlSetOnMouseDown(const Value: TMouseEvent);\r\n procedure ControlSetOnMouseEnter(const Value: TNotifyEvent);\r\n procedure ControlSetOnMouseLeave(const Value: TNotifyEvent);\r\n procedure ControlSetOnMouseMove(const Value: TMouseMoveEvent);\r\n procedure ControlSetOnMouseUp(const Value: TMouseEvent);\r\n property ControlOnMouseDown: TMouseEvent read ControlGetOnMouseDown write ControlSetOnMouseDown;\r\n property ControlOnMouseEnter : TNotifyEvent read ControlGetOnMouseEnter write ControlSetOnMouseEnter;\r\n property ControlOnMouseLeave : TNotifyEvent read ControlGetOnMouseLeave write ControlSetOnMouseLeave;\r\n property ControlOnMousePress: TMouseMoveEvent read ControlGetOnMouseMove write ControlSetOnMouseMove;\r\n property ControlOnMouseUp: TMouseEvent read ControlGetOnMouseUp write ControlSetOnMouseUp;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvDynControlEngineIntf.pas $';\r\n Revision: '$Revision: 13415 $';\r\n Date: '$Date: 2012-09-10 11:51:54 +0200 (lun. 10 sept. 2012) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvDynControlEngineJVCL.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Initial Developer of the Original Code is Jens Fudickar [jens dott fudickar att oratool dott de]\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\nJens Fudickar [jens dott fudickar att oratool dott de]\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvDynControlEngineJVCL.pas 13415 2012-09-10 09:51:54Z obones $\r\n\r\nunit JvDynControlEngineJVCL;\r\n\r\n{$I jvcl.inc}\r\n\r\n{$IFDEF SUPPORTS_PLATFORM_WARNINGS}\r\n {$WARN UNIT_PLATFORM OFF}\r\n {$WARN SYMBOL_PLATFORM OFF}\r\n{$ENDIF SUPPORTS_PLATFORM_WARNINGS}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n ActnList, Graphics, ComCtrls, ImgList,\r\n Classes,\r\n Controls, StdCtrls, ExtCtrls, Mask, Forms,\r\n Buttons, Dialogs, FileCtrl,\r\n {$IFDEF HAS_UNIT_SYSTEM_UITYPES}\r\n System.UITypes,\r\n {$ENDIF HAS_UNIT_SYSTEM_UITYPES}\r\n JvMaskEdit, JvDateTimePicker, JvBitBtn, JvCheckBox, JvBaseEdits,\r\n JvLabel, JvListBox, JvMemo, JvRichEdit, JvPanel, JvRadioGroup, JvToolEdit,\r\n JvScrollBox, JvStaticText, JvCombobox, JvImage, JvSpin, JvCheckListBox,\r\n JvDynControlEngine, JvDynControlEngineIntf, JvGroupBox, JvComCtrls,\r\n JvProgressBar;\r\n\r\ntype\r\n TJvDynControlJVCLMaskEdit = class(TJvMaskEdit, IUnknown,\r\n IJvDynControl, IJvDynControlData, IJvDynControlReadOnly, IJvDynControlEdit)\r\n public\r\n procedure ControlSetDefaultProperties;\r\n procedure ControlSetReadOnly(Value: Boolean);\r\n procedure ControlSetTabOrder(Value: Integer);\r\n\r\n procedure ControlSetOnEnter(Value: TNotifyEvent);\r\n procedure ControlSetOnExit(Value: TNotifyEvent);\r\n procedure ControlSetOnChange(Value: TNotifyEvent);\r\n procedure ControlSetOnClick(Value: TNotifyEvent);\r\n procedure ControlSetHint(const Value: string);\r\n\r\n procedure ControlSetValue(Value: Variant);\r\n function ControlGetValue: Variant;\r\n procedure ControlSetAnchors(Value: TAnchors);\r\n\r\n //IJvDynControlEdit\r\n procedure ControlSetPasswordChar(Value: Char);\r\n procedure ControlSetEditMask(const Value: string);\r\n end;\r\n\r\n TJvDynControlJVCLButtonEdit = class(TJvPanel, IUnknown,\r\n IJvDynControl, IJvDynControlData, IJvDynControlReadOnly, IJvDynControlEdit,\r\n IJvDynControlButtonEdit, IJvDynControlButton)\r\n private\r\n FEditControl: TJvMaskEdit;\r\n FButton: TJvBitBtn;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n\r\n procedure ControlSetDefaultProperties;\r\n procedure ControlSetReadOnly(Value: Boolean);\r\n procedure ControlSetTabOrder(Value: Integer);\r\n\r\n procedure ControlSetOnEnter(Value: TNotifyEvent);\r\n procedure ControlSetOnExit(Value: TNotifyEvent);\r\n procedure ControlSetOnChange(Value: TNotifyEvent);\r\n procedure ControlSetOnClick(Value: TNotifyEvent);\r\n procedure ControlSetHint(const Value: string);\r\n\r\n procedure ControlSetValue(Value: Variant);\r\n function ControlGetValue: Variant;\r\n procedure ControlSetAnchors(Value: TAnchors);\r\n\r\n //IJvDynControlEdit\r\n procedure ControlSetPasswordChar(Value: Char);\r\n procedure ControlSetEditMask(const Value: string);\r\n\r\n //IJvDynControlButtonEdit\r\n procedure ControlSetOnButtonClick(Value: TNotifyEvent);\r\n procedure ControlSetButtonCaption(const Value: string);\r\n\r\n //IJvDynControlButton\r\n procedure ControlSetGlyph(Value: TBitmap);\r\n procedure ControlSetNumGlyphs(Value: Integer);\r\n procedure ControlSetLayout(Value: TButtonLayout);\r\n procedure ControlSetDefault(Value: Boolean);\r\n procedure ControlSetCancel(Value: Boolean);\r\n end;\r\n\r\n TJvDynControlJVCLCalcEdit = class(TJvCalcEdit, IUnknown, IJvDynControl,\r\n IJvDynControlData, IJvDynControlReadOnly)\r\n public\r\n procedure ControlSetDefaultProperties;\r\n procedure ControlSetReadOnly(Value: Boolean);\r\n procedure ControlSetTabOrder(Value: Integer);\r\n\r\n procedure ControlSetOnEnter(Value: TNotifyEvent);\r\n procedure ControlSetOnExit(Value: TNotifyEvent);\r\n procedure ControlSetOnChange(Value: TNotifyEvent);\r\n procedure ControlSetOnClick(Value: TNotifyEvent);\r\n procedure ControlSetHint(const Value: string);\r\n\r\n procedure ControlSetValue(Value: Variant);\r\n function ControlGetValue: Variant;\r\n procedure ControlSetAnchors(Value: TAnchors);\r\n end;\r\n\r\n TJvDynControlJVCLSpinEdit = class(TJvSpinEdit, IUnknown,\r\n IJvDynControl, IJvDynControlData, IJvDynControlSpin, IJvDynControlReadOnly)\r\n public\r\n procedure ControlSetDefaultProperties;\r\n procedure ControlSetReadOnly(Value: Boolean);\r\n procedure ControlSetTabOrder(Value: Integer);\r\n\r\n procedure ControlSetOnEnter(Value: TNotifyEvent);\r\n procedure ControlSetOnExit(Value: TNotifyEvent);\r\n procedure ControlSetOnChange(Value: TNotifyEvent);\r\n procedure ControlSetOnClick(Value: TNotifyEvent);\r\n procedure ControlSetHint(const Value: string);\r\n\r\n procedure ControlSetValue(Value: Variant);\r\n function ControlGetValue: Variant;\r\n procedure ControlSetAnchors(Value: TAnchors);\r\n\r\n // IJvDynControlSpin\r\n procedure ControlSetIncrement(Value: Integer);\r\n procedure ControlSetMinValue(Value: Double);\r\n procedure ControlSetMaxValue(Value: Double);\r\n procedure ControlSetUseForInteger(Value: Boolean);\r\n end;\r\n\r\n TJvDynControlJVCLFileNameEdit = class(TJvFileNameEdit, IUnknown,\r\n IJvDynControl, IJvDynControlData, IJvDynControlFileName,\r\n IJvDynControlReadOnly)\r\n public\r\n procedure ControlSetDefaultProperties;\r\n procedure ControlSetReadOnly(Value: Boolean);\r\n procedure ControlSetTabOrder(Value: Integer);\r\n\r\n procedure ControlSetOnEnter(Value: TNotifyEvent);\r\n procedure ControlSetOnExit(Value: TNotifyEvent);\r\n procedure ControlSetOnChange(Value: TNotifyEvent);\r\n procedure ControlSetOnClick(Value: TNotifyEvent);\r\n procedure ControlSetHint(const Value: string);\r\n\r\n procedure ControlSetValue(Value: Variant);\r\n function ControlGetValue: Variant;\r\n procedure ControlSetAnchors(Value: TAnchors);\r\n\r\n // IJvDynControlFileName\r\n procedure ControlSetInitialDir(const Value: string);\r\n procedure ControlSetDefaultExt(const Value: string);\r\n procedure ControlSetDialogTitle(const Value: string);\r\n procedure ControlSetDialogOptions(Value: TOpenOptions);\r\n procedure ControlSetFilter(const Value: string);\r\n procedure ControlSetFilterIndex(Value: Integer);\r\n procedure ControlSetDialogKind(Value: TJvDynControlFileNameDialogKind);\r\n end;\r\n\r\n TJvDynControlJVCLDirectoryEdit = class(TJvDirectoryEdit, IUnknown,\r\n IJvDynControl, IJvDynControlData, IJvDynControlDirectory,\r\n IJvDynControlReadOnly)\r\n public\r\n procedure ControlSetDefaultProperties;\r\n procedure ControlSetReadOnly(Value: Boolean);\r\n procedure ControlSetTabOrder(Value: Integer);\r\n\r\n procedure ControlSetOnEnter(Value: TNotifyEvent);\r\n procedure ControlSetOnExit(Value: TNotifyEvent);\r\n procedure ControlSetOnChange(Value: TNotifyEvent);\r\n procedure ControlSetOnClick(Value: TNotifyEvent);\r\n procedure ControlSetHint(const Value: string);\r\n\r\n procedure ControlSetValue(Value: Variant);\r\n function ControlGetValue: Variant;\r\n procedure ControlSetAnchors(Value: TAnchors);\r\n\r\n // IJvDynControlDirectory\r\n procedure ControlSetInitialDir(const Value: string);\r\n procedure ControlSetDialogTitle(const Value: string);\r\n procedure ControlSetDialogOptions(Value: TSelectDirOpts);\r\n end;\r\n\r\n TJvDynControlJVCLDateTimeEdit = class(TJvPanel, IUnknown,\r\n IJvDynControl, IJvDynControlData, IJvDynControlDate)\r\n private\r\n FDatePicker: TJvDateTimePicker;\r\n FTimePicker: TJvDateTimePicker;\r\n protected\r\n procedure ControlResize(Sender: TObject);\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n procedure ControlSetDefaultProperties;\r\n\r\n procedure ControlSetTabOrder(Value: Integer);\r\n\r\n procedure ControlSetOnEnter(Value: TNotifyEvent);\r\n procedure ControlSetOnExit(Value: TNotifyEvent);\r\n procedure ControlSetOnChange(Value: TNotifyEvent);\r\n procedure ControlSetOnClick(Value: TNotifyEvent);\r\n procedure ControlSetHint(const Value: string);\r\n\r\n procedure ControlSetValue(Value: Variant);\r\n function ControlGetValue: Variant;\r\n procedure ControlSetAnchors(Value: TAnchors);\r\n\r\n // IJvDynControlDate\r\n procedure ControlSetMinDate(Value: TDateTime);\r\n procedure ControlSetMaxDate(Value: TDateTime);\r\n procedure ControlSetFormat(const Value: string);\r\n end;\r\n\r\n TJvDynControlJVCLDateEdit = class(TJvDateTimePicker, IUnknown,\r\n IJvDynControl, IJvDynControlData, IJvDynControlDate)\r\n public\r\n procedure ControlSetDefaultProperties;\r\n\r\n procedure ControlSetTabOrder(Value: Integer);\r\n\r\n procedure ControlSetOnEnter(Value: TNotifyEvent);\r\n procedure ControlSetOnExit(Value: TNotifyEvent);\r\n procedure ControlSetOnChange(Value: TNotifyEvent);\r\n procedure ControlSetOnClick(Value: TNotifyEvent);\r\n procedure ControlSetHint(const Value: string);\r\n\r\n procedure ControlSetValue(Value: Variant);\r\n function ControlGetValue: Variant;\r\n procedure ControlSetAnchors(Value: TAnchors);\r\n\r\n // IJvDynControlDate\r\n procedure ControlSetMinDate(Value: TDateTime);\r\n procedure ControlSetMaxDate(Value: TDateTime);\r\n procedure ControlSetFormat(const Value: string);\r\n end;\r\n\r\n TJvDynControlJVCLTimeEdit = class(TJvDateTimePicker, IUnknown,\r\n IJvDynControl, IJvDynControlData, IJvDynControlTime)\r\n public\r\n procedure ControlSetDefaultProperties;\r\n\r\n procedure ControlSetTabOrder(Value: Integer);\r\n\r\n procedure ControlSetOnEnter(Value: TNotifyEvent);\r\n procedure ControlSetOnExit(Value: TNotifyEvent);\r\n procedure ControlSetOnChange(Value: TNotifyEvent);\r\n procedure ControlSetOnClick(Value: TNotifyEvent);\r\n procedure ControlSetHint(const Value: string);\r\n\r\n procedure ControlSetValue(Value: Variant);\r\n function ControlGetValue: Variant;\r\n procedure ControlSetAnchors(Value: TAnchors);\r\n\r\n procedure ControlSetFormat(const Value: string);\r\n end;\r\n\r\n TJvDynControlJVCLCheckBox = class(TJvCheckBox, IUnknown,\r\n IJvDynControl, IJvDynControlCaption, IJvDynControlData, IJvDynControlReadOnly,\r\n IJvDynControlCheckBox, IJvDynControlFont)\r\n public\r\n function ControlGetCaption: string;\r\n procedure ControlSetDefaultProperties;\r\n procedure ControlSetCaption(const Value: string);\r\n procedure ControlSetTabOrder(Value: Integer);\r\n procedure ControlSetReadOnly(Value: Boolean);\r\n\r\n procedure ControlSetOnEnter(Value: TNotifyEvent);\r\n procedure ControlSetOnExit(Value: TNotifyEvent);\r\n procedure ControlSetOnClick(Value: TNotifyEvent);\r\n procedure ControlSetHint(const Value: string);\r\n\r\n procedure ControlSetOnChange(Value: TNotifyEvent);\r\n procedure ControlSetValue(Value: Variant);\r\n function ControlGetValue: Variant;\r\n\r\n //IJvDynControlCheckBox\r\n procedure ControlSetAllowGrayed(Value: Boolean);\r\n procedure ControlSetState(Value: TCheckBoxState);\r\n function ControlGetState: TCheckBoxState;\r\n procedure ControlSetAnchors(Value: TAnchors);\r\n\r\n //IJvDynControlFont\r\n procedure ControlSetFont(Value: TFont);\r\n function ControlGetFont: TFont;\r\n end;\r\n\r\n TJvDynControlJVCLMemo = class(TJvMemo, IUnknown,\r\n IJvDynControl, IJvDynControlData, IJvDynControlItems, IJvDynControlMemo,\r\n IJvDynControlReadOnly,\r\n IJvDynControlAlignment, IJvDynControlFont)\r\n public\r\n //IJvDynControlFont\r\n function ControlGetFont: TFont;\r\n procedure ControlSetDefaultProperties;\r\n procedure ControlSetTabOrder(Value: Integer);\r\n procedure ControlSetReadOnly(Value: Boolean);\r\n\r\n procedure ControlSetOnEnter(Value: TNotifyEvent);\r\n procedure ControlSetOnExit(Value: TNotifyEvent);\r\n procedure ControlSetOnChange(Value: TNotifyEvent);\r\n procedure ControlSetOnClick(Value: TNotifyEvent);\r\n procedure ControlSetHint(const Value: string);\r\n\r\n procedure ControlSetValue(Value: Variant);\r\n function ControlGetValue: Variant;\r\n\r\n procedure ControlSetSorted(Value: Boolean);\r\n procedure ControlSetItems(Value: TStrings);\r\n function ControlGetItems: TStrings;\r\n procedure ControlSetAnchors(Value: TAnchors);\r\n\r\n procedure ControlSetWantTabs(Value: Boolean);\r\n procedure ControlSetWantReturns(Value: Boolean);\r\n procedure ControlSetWordWrap(Value: Boolean);\r\n procedure ControlSetScrollBars(Value: TScrollStyle);\r\n //IJvDynControlAlignment\r\n procedure ControlSetAlignment(Value: TAlignment);\r\n procedure ControlSetFont(Value: TFont);\r\n end;\r\n\r\n TJvDynControlJVCLRichEdit = class(TJvRichEdit, IUnknown,\r\n IJvDynControl, IJvDynControlData, IJvDynControlItems, IJvDynControlMemo,\r\n IJvDynControlReadOnly, IJvDynControlFont)\r\n public\r\n procedure ControlSetDefaultProperties;\r\n procedure ControlSetTabOrder(Value: Integer);\r\n procedure ControlSetReadOnly(Value: Boolean);\r\n\r\n procedure ControlSetOnEnter(Value: TNotifyEvent);\r\n procedure ControlSetOnExit(Value: TNotifyEvent);\r\n procedure ControlSetOnChange(Value: TNotifyEvent);\r\n procedure ControlSetOnClick(Value: TNotifyEvent);\r\n procedure ControlSetHint(const Value: string);\r\n\r\n procedure ControlSetValue(Value: Variant);\r\n function ControlGetValue: Variant;\r\n\r\n procedure ControlSetSorted(Value: Boolean);\r\n procedure ControlSetItems(Value: TStrings);\r\n function ControlGetItems: TStrings;\r\n procedure ControlSetAnchors(Value: TAnchors);\r\n\r\n procedure ControlSetWantTabs(Value: Boolean);\r\n procedure ControlSetWantReturns(Value: Boolean);\r\n procedure ControlSetWordWrap(Value: Boolean);\r\n procedure ControlSetScrollBars(Value: TScrollStyle);\r\n //IJvDynControlFont\r\n function ControlGetFont: TFont;\r\n procedure ControlSetFont(Value: TFont);\r\n end;\r\n\r\n TJvDynControlJVCLRadioGroup = class(TJvRadioGroup, IUnknown,\r\n IJvDynControl, IJvDynControlCaption, IJvDynControlData, IJvDynControlItems,\r\n IJvDynControlRadioGroup, IJvDynControlReadOnly)\r\n public\r\n function ControlGetCaption: string;\r\n procedure ControlSetDefaultProperties;\r\n procedure ControlSetReadOnly(Value: Boolean);\r\n procedure ControlSetCaption(const Value: string);\r\n procedure ControlSetTabOrder(Value: Integer);\r\n\r\n procedure ControlSetOnEnter(Value: TNotifyEvent);\r\n procedure ControlSetOnExit(Value: TNotifyEvent);\r\n procedure ControlSetOnChange(Value: TNotifyEvent);\r\n procedure ControlSetOnClick(Value: TNotifyEvent);\r\n procedure ControlSetHint(const Value: string);\r\n\r\n procedure ControlSetValue(Value: Variant);\r\n function ControlGetValue: Variant;\r\n\r\n procedure ControlSetSorted(Value: Boolean);\r\n procedure ControlSetItems(Value: TStrings);\r\n function ControlGetItems: TStrings;\r\n procedure ControlSetAnchors(Value: TAnchors);\r\n\r\n procedure ControlSetColumns(Value: Integer);\r\n end;\r\n\r\n TJvDynControlJVCLListBox = class(TJvListBox, IUnknown,\r\n IJvDynControl, IJvDynControlData, IJvDynControlItems, IJvDynControlItemIndex, IJvDynControlDblClick,\r\n IJvDynControlKey, IJvDynControlMouse)\r\n public\r\n function ControlGetItemIndex: Integer;\r\n procedure ControlSetDefaultProperties;\r\n procedure ControlSetTabOrder(Value: Integer);\r\n\r\n function ControlGetOnKeyDown: TKeyEvent;\r\n function ControlGetOnKeyPress: TKeyPressEvent;\r\n function ControlGetOnKeyUp: TKeyEvent;\r\n procedure ControlSetOnKeyDown(const Value: TKeyEvent);\r\n procedure ControlSetOnKeyPress(const Value: TKeyPressEvent);\r\n procedure ControlSetOnKeyUp(const Value: TKeyEvent);\r\n\r\n procedure ControlSetOnEnter(Value: TNotifyEvent);\r\n procedure ControlSetOnExit(Value: TNotifyEvent);\r\n procedure ControlSetOnChange(Value: TNotifyEvent);\r\n procedure ControlSetOnClick(Value: TNotifyEvent);\r\n procedure ControlSetHint(const Value: string);\r\n\r\n procedure ControlSetValue(Value: Variant);\r\n function ControlGetValue: Variant;\r\n\r\n procedure ControlSetSorted(Value: Boolean);\r\n procedure ControlSetItems(Value: TStrings);\r\n function ControlGetItems: TStrings;\r\n procedure ControlSetAnchors(Value: TAnchors);\r\n procedure ControlSetItemIndex(const Value: Integer);\r\n\r\n procedure ControlSetOnDblClick(Value: TNotifyEvent);\r\n\r\n function ControlGetOnMouseDown: TMouseEvent;\r\n function ControlGetOnMouseEnter: TNotifyEvent;\r\n function ControlGetOnMouseLeave: TNotifyEvent;\r\n function ControlGetOnMouseMove: TMouseMoveEvent;\r\n function ControlGetOnMouseUp: TMouseEvent;\r\n procedure ControlSetOnMouseDown(const Value: TMouseEvent);\r\n procedure ControlSetOnMouseEnter(const Value: TNotifyEvent);\r\n procedure ControlSetOnMouseLeave(const Value: TNotifyEvent);\r\n procedure ControlSetOnMouseMove(const Value: TMouseMoveEvent);\r\n procedure ControlSetOnMouseUp(const Value: TMouseEvent);\r\n end;\r\n\r\n TJvDynControlJVCLCheckListBox = class(TJvCheckListBox, IUnknown,\r\n IJvDynControl, IJvDynControlData, IJvDynControlItems, IJvDynControlDblClick,\r\n IJvDynControlCheckListBox)\r\n public\r\n procedure ControlSetDefaultProperties;\r\n procedure ControlSetTabOrder(Value: Integer);\r\n\r\n procedure ControlSetOnEnter(Value: TNotifyEvent);\r\n procedure ControlSetOnExit(Value: TNotifyEvent);\r\n procedure ControlSetOnChange(Value: TNotifyEvent);\r\n procedure ControlSetOnClick(Value: TNotifyEvent);\r\n procedure ControlSetHint(const Value: string);\r\n\r\n procedure ControlSetValue(Value: Variant);\r\n function ControlGetValue: Variant;\r\n\r\n procedure ControlSetSorted(Value: Boolean);\r\n procedure ControlSetItems(Value: TStrings);\r\n function ControlGetItems: TStrings;\r\n\r\n procedure ControlSetOnDblClick(Value: TNotifyEvent);\r\n\r\n //IJvDynControlCheckListBox = interface\r\n procedure ControlSetAllowGrayed(Value: Boolean);\r\n procedure ControlSetChecked(Index: Integer; Value: Boolean);\r\n procedure ControlSetItemEnabled(Index: Integer; Value: Boolean);\r\n procedure ControlSetHeader(Index: Integer; Value: Boolean);\r\n procedure ControlSetState(Index: Integer; Value: TCheckBoxState);\r\n function ControlGetChecked(Index: Integer): Boolean;\r\n function ControlGetItemEnabled(Index: Integer): Boolean;\r\n function ControlGetHeader(Index: Integer): Boolean;\r\n function ControlGetState(Index: Integer): TCheckBoxState;\r\n procedure ControlSetAnchors(Value: TAnchors);\r\n end;\r\n\r\n TJvDynControlJVCLComboBox = class(TJvComboBox, IUnknown,\r\n IJvDynControl, IJvDynControlData, IJvDynControlItems, IJvDynControlComboBox)\r\n public\r\n procedure ControlSetDefaultProperties;\r\n procedure ControlSetTabOrder(Value: Integer);\r\n\r\n procedure ControlSetOnEnter(Value: TNotifyEvent);\r\n procedure ControlSetOnExit(Value: TNotifyEvent);\r\n procedure ControlSetOnChange(Value: TNotifyEvent);\r\n procedure ControlSetOnClick(Value: TNotifyEvent);\r\n procedure ControlSetHint(const Value: string);\r\n\r\n procedure ControlSetValue(Value: Variant);\r\n function ControlGetValue: Variant;\r\n\r\n procedure ControlSetSorted(Value: Boolean);\r\n procedure ControlSetItems(Value: TStrings);\r\n function ControlGetItems: TStrings;\r\n procedure ControlSetAnchors(Value: TAnchors);\r\n\r\n procedure ControlSetNewEntriesAllowed(Value: Boolean);\r\n end;\r\n\r\n TJvDynControlJVCLGroupBox = class(TJvGroupBox, IUnknown,\r\n IJvDynControl, IJvDynControlCaption)\r\n public\r\n function ControlGetCaption: string;\r\n procedure ControlSetAnchors(Value: TAnchors);\r\n procedure ControlSetDefaultProperties;\r\n procedure ControlSetCaption(const Value: string);\r\n procedure ControlSetTabOrder(Value: Integer);\r\n\r\n procedure ControlSetOnEnter(Value: TNotifyEvent);\r\n procedure ControlSetOnExit(Value: TNotifyEvent);\r\n procedure ControlSetOnClick(Value: TNotifyEvent);\r\n procedure ControlSetHint(const Value: string);\r\n end;\r\n\r\n TJvDynControlJVCLPanel = class(TJvPanel, IUnknown,\r\n IJvDynControl, IJvDynControlCaption, IJvDynControlPanel, IJvDynControlAlign,\r\n IJvDynControlAutoSize, IJvDynControlBevelBorder, IJvDynControlColor,\r\n IJvDynControlAlignment)\r\n public\r\n function ControlGetCaption: string;\r\n procedure ControlSetDefaultProperties;\r\n procedure ControlSetCaption(const Value: string);\r\n procedure ControlSetTabOrder(Value: Integer);\r\n\r\n procedure ControlSetOnEnter(Value: TNotifyEvent);\r\n procedure ControlSetOnExit(Value: TNotifyEvent);\r\n procedure ControlSetOnClick(Value: TNotifyEvent);\r\n procedure ControlSetHint(const Value: string);\r\n procedure ControlSetAnchors(Value: TAnchors);\r\n\r\n procedure ControlSetBorder(ABevelInner: TPanelBevel; ABevelOuter: TPanelBevel;\r\n ABevelWidth: Integer; ABorderStyle: TBorderStyle; ABorderWidth: Integer);\r\n\r\n // IJvDynControlAlign\r\n procedure ControlSetAlign(Value: TAlign);\r\n\r\n // IJvDynControlAutoSize\r\n procedure ControlSetAutoSize(Value: Boolean);\r\n\r\n // IJvDynControlBevelBorder\r\n procedure ControlSetBevelInner(Value: TBevelCut);\r\n procedure ControlSetBevelKind(Value: TBevelKind);\r\n procedure ControlSetBevelOuter(Value: TBevelCut);\r\n procedure ControlSetBorderStyle(Value: TBorderStyle);\r\n procedure ControlSetBorderWidth(Value: Integer);\r\n // IJvDynControlColor\r\n procedure ControlSetColor(Value: TColor);\r\n procedure ControlSetParentColor(Value: Boolean);\r\n //IJvDynControlAlignment\r\n procedure ControlSetAlignment(Value: TAlignment);\r\n end;\r\n\r\n TJvDynControlJVCLImage = class(TJvImage, IUnknown,\r\n IJvDynControl, IJvDynControlImage)\r\n public\r\n procedure ControlSetDefaultProperties;\r\n procedure ControlSetTabOrder(Value: Integer);\r\n\r\n procedure ControlSetOnEnter(Value: TNotifyEvent);\r\n procedure ControlSetOnExit(Value: TNotifyEvent);\r\n procedure ControlSetOnClick(Value: TNotifyEvent);\r\n procedure ControlSetHint(const Value: string);\r\n\r\n procedure ControlSetAutoSize(Value: Boolean);\r\n procedure ControlSetIncrementalDisplay(Value: Boolean);\r\n procedure ControlSetCenter(Value: Boolean);\r\n procedure ControlSetProportional(Value: Boolean);\r\n procedure ControlSetStretch(Value: Boolean);\r\n procedure ControlSetTransparent(Value: Boolean);\r\n procedure ControlSetPicture(Value: TPicture);\r\n procedure ControlSetGraphic(Value: TGraphic);\r\n function ControlGetPicture: TPicture;\r\n procedure ControlSetAnchors(Value: TAnchors);\r\n end;\r\n\r\n TJvDynControlJVCLScrollBox = class(TJvScrollbox, IUnknown,\r\n IJvDynControl, IJvDynControlCaption)\r\n public\r\n function ControlGetCaption: string;\r\n procedure ControlSetAnchors(Value: TAnchors);\r\n procedure ControlSetDefaultProperties;\r\n procedure ControlSetCaption(const Value: string);\r\n procedure ControlSetTabOrder(Value: Integer);\r\n\r\n procedure ControlSetOnEnter(Value: TNotifyEvent);\r\n procedure ControlSetOnExit(Value: TNotifyEvent);\r\n procedure ControlSetOnClick(Value: TNotifyEvent);\r\n procedure ControlSetHint(const Value: string);\r\n end;\r\n\r\n TJvDynControlJVCLLabel = class(TJvLabel, IUnknown,\r\n IJvDynControl, IJvDynControlCaption, IJvDynControlLabel, IJvDynControlAlign,\r\n IJvDynControlAutoSize,\r\n IJvDynControlAlignment, IJvDynControlFont)\r\n public\r\n function ControlGetCaption: string;\r\n procedure ControlSetAnchors(Value: TAnchors);\r\n procedure ControlSetDefaultProperties;\r\n procedure ControlSetCaption(const Value: string);\r\n procedure ControlSetTabOrder(Value: Integer);\r\n\r\n procedure ControlSetOnEnter(Value: TNotifyEvent);\r\n procedure ControlSetOnExit(Value: TNotifyEvent);\r\n procedure ControlSetOnClick(Value: TNotifyEvent);\r\n procedure ControlSetHint(const Value: string);\r\n\r\n procedure ControlSetFocusControl(Value: TWinControl);\r\n procedure ControlSetWordWrap(Value: Boolean);\r\n // IJvDynControlAlign\r\n procedure ControlSetAlign(Value: TAlign);\r\n\r\n // IJvDynControlAutoSize\r\n procedure ControlSetAutoSize(Value: Boolean);\r\n // IJvDynControlColor\r\n procedure ControlSetColor(Value: TColor);\r\n procedure ControlSetParentColor(Value: Boolean);\r\n //IJvDynControlAlignment\r\n procedure ControlSetAlignment(Value: TAlignment);\r\n\r\n //IJvDynControlFont\r\n procedure ControlSetFont(Value: TFont);\r\n function ControlGetFont: TFont;\r\n end;\r\n\r\n TJvDynControlJVCLStaticText = class(TJvStaticText, IUnknown,\r\n IJvDynControl, IJvDynControlCaption, IJvDynControlAlign,\r\n IJvDynControlAutoSize, IJvDynControlColor,\r\n IJvDynControlAlignment, IJvDynControlFont)\r\n public\r\n function ControlGetCaption: string;\r\n procedure ControlSetAnchors(Value: TAnchors);\r\n procedure ControlSetDefaultProperties;\r\n procedure ControlSetCaption(const Value: string);\r\n procedure ControlSetTabOrder(Value: Integer);\r\n\r\n procedure ControlSetOnEnter(Value: TNotifyEvent);\r\n procedure ControlSetOnExit(Value: TNotifyEvent);\r\n procedure ControlSetOnClick(Value: TNotifyEvent);\r\n procedure ControlSetHint(const Value: string);\r\n // IJvDynControlAlign\r\n procedure ControlSetAlign(Value: TAlign);\r\n\r\n // IJvDynControlAutoSize\r\n procedure ControlSetAutoSize(Value: Boolean);\r\n // IJvDynControlColor\r\n procedure ControlSetColor(Value: TColor);\r\n procedure ControlSetParentColor(Value: Boolean);\r\n //IJvDynControlAlignment\r\n procedure ControlSetAlignment(Value: TAlignment);\r\n\r\n //IJvDynControlFont\r\n procedure ControlSetFont(Value: TFont);\r\n function ControlGetFont: TFont;\r\n end;\r\n\r\n TJvDynControlJVCLButton = class(TJvBitBtn, IUnknown,\r\n IJvDynControl, IJvDynControlCaption, IJvDynControlButton, IJvDynControlAction)\r\n public\r\n function ControlGetCaption: string;\r\n procedure ControlSetDefaultProperties;\r\n procedure ControlSetCaption(const Value: string);\r\n procedure ControlSetTabOrder(Value: Integer);\r\n\r\n procedure ControlSetOnEnter(Value: TNotifyEvent);\r\n procedure ControlSetOnExit(Value: TNotifyEvent);\r\n procedure ControlSetOnClick(Value: TNotifyEvent);\r\n procedure ControlSetHint(const Value: string);\r\n\r\n procedure ControlSetGlyph(Value: TBitmap);\r\n procedure ControlSetNumGlyphs(Value: Integer);\r\n procedure ControlSetLayout(Value: TButtonLayout);\r\n procedure ControlSetDefault(Value: Boolean);\r\n procedure ControlSetCancel(Value: Boolean);\r\n\r\n // IJvDynControlAction\r\n procedure ControlSetAction(Value: TCustomAction);\r\n procedure ControlSetAnchors(Value: TAnchors);\r\n end;\r\n\r\n TJvDynControlJVCLRadioButton = class(TRadioButton, IUnknown,\r\n IJvDynControl, IJvDynControlCaption, IJvDynControlData)\r\n public\r\n function ControlGetCaption: string;\r\n procedure ControlSetDefaultProperties;\r\n procedure ControlSetCaption(const Value: string);\r\n procedure ControlSetTabOrder(Value: Integer);\r\n\r\n procedure ControlSetOnEnter(Value: TNotifyEvent);\r\n procedure ControlSetOnExit(Value: TNotifyEvent);\r\n procedure ControlSetOnClick(Value: TNotifyEvent);\r\n procedure ControlSetHint(const Value: string);\r\n\r\n // IJvDynControlData\r\n procedure ControlSetOnChange(Value: TNotifyEvent);\r\n procedure ControlSetValue(Value: Variant);\r\n function ControlGetValue: Variant;\r\n procedure ControlSetAnchors(Value: TAnchors);\r\n end;\r\n\r\n TJvDynControlJVCLTreeView = class(TJvTreeView, IUnknown, IJvDynControl,\r\n IJvDynControlTreeView, IJvDynControlReadOnly, IJvDynControlDblClick,\r\n IJvDynControlMouse)\r\n public\r\n procedure ControlSetDefaultProperties;\r\n procedure ControlSetTabOrder(Value: Integer);\r\n\r\n procedure ControlSetOnEnter(Value: TNotifyEvent);\r\n procedure ControlSetOnExit(Value: TNotifyEvent);\r\n procedure ControlSetOnClick(Value: TNotifyEvent);\r\n procedure ControlSetHint(const Value: string);\r\n\r\n // IJvDynControlReadOnly\r\n procedure ControlSetReadOnly(Value: Boolean);\r\n\r\n // IJvDynControlTreeView\r\n procedure ControlSetAutoExpand(Value: Boolean);\r\n procedure ControlSetHotTrack(Value: Boolean);\r\n procedure ControlSetShowHint(Value: Boolean);\r\n procedure ControlSetShowLines(Value: Boolean);\r\n procedure ControlSetShowRoot(Value: Boolean);\r\n procedure ControlSetToolTips(Value: Boolean);\r\n procedure ControlSetItems(Value: TTreeNodes);\r\n function ControlGetItems: TTreeNodes;\r\n procedure ControlSetImages(Value: TCustomImageList);\r\n procedure ControlSetStateImages(Value: TCustomImageList);\r\n function ControlGetSelected: TTreeNode;\r\n procedure ControlSetSelected(const Value: TTreeNode);\r\n procedure ControlSetAnchors(Value: TAnchors);\r\n procedure ControlSetOnChange(Value: TTVChangedEvent);\r\n procedure ControlSetOnChanging(Value: TTVChangingEvent);\r\n procedure ControlSetSortType(Value: TSortType);\r\n procedure ControlSortItems;\r\n\r\n //IJvDynControlDblClick\r\n procedure ControlSetOnDblClick(Value: TNotifyEvent);\r\n\r\n function ControlGetOnMouseDown: TMouseEvent;\r\n function ControlGetOnMouseEnter: TNotifyEvent;\r\n function ControlGetOnMouseLeave: TNotifyEvent;\r\n function ControlGetOnMouseMove: TMouseMoveEvent;\r\n function ControlGetOnMouseUp: TMouseEvent;\r\n procedure ControlSetOnMouseDown(const Value: TMouseEvent);\r\n procedure ControlSetOnMouseEnter(const Value: TNotifyEvent);\r\n procedure ControlSetOnMouseLeave(const Value: TNotifyEvent);\r\n procedure ControlSetOnMouseMove(const Value: TMouseMoveEvent);\r\n procedure ControlSetOnMouseUp(const Value: TMouseEvent);\r\n end;\r\n\r\n TJvDynControlJVCLProgressBar = class(TJvProgressBar, IUnknown, IJvDynControl,\r\n IJvDynControlCaption, IJvDynControlAlign, IJvDynControlProgressBar)\r\n public\r\n function ControlGetCaption: string;\r\n procedure ControlSetAlign(Value: TAlign);\r\n procedure ControlSetAnchors(Value: TAnchors);\r\n procedure ControlSetCaption(const Value: string);\r\n procedure ControlSetDefaultProperties;\r\n procedure ControlSetHint(const Value: string);\r\n //IJvDynControlProgressBar\r\n procedure ControlSetMarquee(Value: Boolean);\r\n procedure ControlSetMax(Value: Integer);\r\n procedure ControlSetMin(Value: Integer);\r\n procedure ControlSetOnClick(Value: TNotifyEvent);\r\n procedure ControlSetOnEnter(Value: TNotifyEvent);\r\n procedure ControlSetOnExit(Value: TNotifyEvent);\r\n procedure ControlSetOrientation(Value: TProgressBarOrientation);\r\n procedure ControlSetPosition(Value: Integer);\r\n procedure ControlSetSmooth(Value: Boolean);\r\n procedure ControlSetStep(Value: Integer);\r\n procedure ControlSetTabOrder(Value: Integer);\r\n end;\r\n\r\ntype\r\n TJvDynControlJVCLTabControl = class(TJvTabControl, IUnknown, IJvDynControl,\r\n IJvDynControlTabControl)\r\n public\r\n procedure ControlSetDefaultProperties;\r\n procedure ControlSetTabOrder(Value: Integer);\r\n\r\n procedure ControlSetOnEnter(Value: TNotifyEvent);\r\n procedure ControlSetOnExit(Value: TNotifyEvent);\r\n procedure ControlSetOnClick(Value: TNotifyEvent);\r\n procedure ControlSetHint(const Value: string);\r\n procedure ControlSetAnchors(Value: TAnchors);\r\n\r\n //IJvDynControlTabControl\r\n procedure ControlCreateTab(const AName: string);\r\n procedure ControlSetOnChangeTab(OnChangeEvent: TNotifyEvent);\r\n procedure ControlSetOnChangingTab(OnChangingEvent: TTabChangingEvent);\r\n procedure ControlSetTabIndex(Index: Integer);\r\n function ControlGetTabIndex: Integer;\r\n procedure ControlSetMultiLine(Value: Boolean);\r\n procedure ControlSetScrollOpposite(Value: Boolean);\r\n procedure ControlSetHotTrack(Value: Boolean);\r\n procedure ControlSetRaggedRight(Value: Boolean);\r\n end;\r\n\r\n TJvDynControlJVCLPageControl = class(TJvPageControl, IUnknown,\r\n IJvDynControl, IJvDynControlTabControl, IJvDynControlPageControl)\r\n public\r\n procedure ControlSetDefaultProperties;\r\n procedure ControlSetTabOrder(Value: Integer);\r\n\r\n procedure ControlSetOnEnter(Value: TNotifyEvent);\r\n procedure ControlSetOnExit(Value: TNotifyEvent);\r\n procedure ControlSetOnClick(Value: TNotifyEvent);\r\n procedure ControlSetHint(const Value: string);\r\n procedure ControlSetAnchors(Value: TAnchors);\r\n\r\n //IJvDynControlTabControl\r\n procedure ControlCreateTab(const AName: string);\r\n procedure ControlSetOnChangeTab(OnChangeEvent: TNotifyEvent);\r\n procedure ControlSetOnChangingTab(OnChangingEvent: TTabChangingEvent);\r\n procedure ControlSetTabIndex(Index: Integer);\r\n function ControlGetTabIndex: Integer;\r\n procedure ControlSetMultiLine(Value: Boolean);\r\n procedure ControlSetScrollOpposite(Value: Boolean);\r\n procedure ControlSetHotTrack(Value: Boolean);\r\n procedure ControlSetRaggedRight(Value: Boolean);\r\n\r\n //IJvDynControlPageControl\r\n function ControlGetPage(const PageName: string): TWinControl;\r\n end;\r\n\r\ntype\r\n TJvDynControlJVCLCheckedComboBox = class(TJvCheckedComboBox, IUnknown, IJvDynControl, IJvDynControlData,\r\n IJvDynControlItems, IJvDynControlDblClick, IJvDynControlCheckComboBox)\r\n public\r\n function ControlGetDelimiter: string;\r\n procedure ControlSetDefaultProperties;\r\n procedure ControlSetTabOrder(Value: Integer);\r\n\r\n procedure ControlSetOnEnter(Value: TNotifyEvent);\r\n procedure ControlSetOnExit(Value: TNotifyEvent);\r\n procedure ControlSetOnChange(Value: TNotifyEvent);\r\n procedure ControlSetOnClick(Value: TNotifyEvent);\r\n procedure ControlSetHint(const Value: string);\r\n\r\n procedure ControlSetValue(Value: Variant);\r\n function ControlGetValue: Variant;\r\n\r\n procedure ControlSetSorted(Value: Boolean);\r\n procedure ControlSetItems(Value: TStrings);\r\n function ControlGetItems: TStrings;\r\n\r\n procedure ControlSetOnDblClick(Value: TNotifyEvent);\r\n\r\n procedure ControlSetAnchors(Value: TAnchors);\r\n procedure ControlSetDelimiter(Value: string);\r\n end;\r\n\r\n\r\nfunction DynControlEngineJVCL: TJvDynControlEngine;\r\nprocedure SetDynControlEngineJVCLDefault;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvDynControlEngineJVCL.pas $';\r\n Revision: '$Revision: 13415 $';\r\n Date: '$Date: 2012-09-10 11:51:54 +0200 (lun. 10 sept. 2012) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n SysUtils, Variants,\r\n JvDynControlEngineTools, JvDynControlEngineVCL, JvJCLUtils;\r\n\r\nvar\r\n IntDynControlEngineJVCL: TJvDynControlEngine = nil;\r\n\r\n//=== { TJvDynControlJVCLMaskEdit } ==========================================\r\n\r\nprocedure TJvDynControlJVCLMaskEdit.ControlSetDefaultProperties;\r\nbegin\r\n Button.Visible := False;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLMaskEdit.ControlSetReadOnly(Value: Boolean);\r\nbegin\r\n ReadOnly := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLMaskEdit.ControlSetTabOrder(Value: Integer);\r\nbegin\r\n TabOrder := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLMaskEdit.ControlSetOnEnter(Value: TNotifyEvent);\r\nbegin\r\n OnEnter := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLMaskEdit.ControlSetOnExit(Value: TNotifyEvent);\r\nbegin\r\n OnExit := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLMaskEdit.ControlSetOnChange(Value: TNotifyEvent);\r\nbegin\r\n OnChange := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLMaskEdit.ControlSetOnClick(Value: TNotifyEvent);\r\nbegin\r\n\r\nend;\r\n\r\nprocedure TJvDynControlJVCLMaskEdit.ControlSetHint(const Value: string);\r\nbegin\r\n Hint := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLMaskEdit.ControlSetValue(Value: Variant);\r\nbegin\r\n Text := VarToStr(Value);\r\nend;\r\n\r\nfunction TJvDynControlJVCLMaskEdit.ControlGetValue: Variant;\r\nbegin\r\n Result := Text;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLMaskEdit.ControlSetAnchors(Value: TAnchors);\r\nbegin\r\n Anchors := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLMaskEdit.ControlSetPasswordChar(Value: Char);\r\nbegin\r\n PasswordChar := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLMaskEdit.ControlSetEditMask(const Value: string);\r\nbegin\r\n EditMask := Value;\r\nend;\r\n\r\n//=== { TJvDynControlJVCLButtonEdit } ========================================\r\n\r\nconstructor TJvDynControlJVCLButtonEdit.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FEditControl := TJvMaskEdit.Create(AOwner);\r\n FEditControl.Parent := Self;\r\n FButton := TJvBitBtn.Create(AOwner);\r\n FButton.Parent := Self;\r\n FButton.Align := alRight;\r\n FButton.Caption := '...';\r\n Height := FEditControl.Height;\r\n FButton.Width := Height;\r\n FEditControl.Align := alClient;\r\n BevelInner := bvNone;\r\n BevelOuter := bvNone;\r\nend;\r\n\r\ndestructor TJvDynControlJVCLButtonEdit.Destroy;\r\nbegin\r\n FreeAndNil(FEditControl);\r\n FreeAndNil(FButton);\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLButtonEdit.ControlSetDefaultProperties;\r\nbegin\r\n Self.Caption := ' ';\r\nend;\r\n\r\nprocedure TJvDynControlJVCLButtonEdit.ControlSetReadOnly(Value: Boolean);\r\nbegin\r\n FEditControl.ReadOnly := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLButtonEdit.ControlSetTabOrder(Value: Integer);\r\nbegin\r\n TabOrder := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLButtonEdit.ControlSetOnEnter(Value: TNotifyEvent);\r\nbegin\r\n OnEnter := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLButtonEdit.ControlSetOnExit(Value: TNotifyEvent);\r\nbegin\r\n OnExit := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLButtonEdit.ControlSetOnChange(Value: TNotifyEvent);\r\nbegin\r\n FEditControl.OnChange := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLButtonEdit.ControlSetOnClick(Value: TNotifyEvent);\r\nbegin\r\n FEditControl.OnClick := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLButtonEdit.ControlSetHint(const Value: string);\r\nbegin\r\n Hint := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLButtonEdit.ControlSetValue(Value: Variant);\r\nbegin\r\n FEditControl.Text := VarToStr(Value);\r\nend;\r\n\r\nfunction TJvDynControlJVCLButtonEdit.ControlGetValue: Variant;\r\nbegin\r\n Result := FEditControl.Text;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLButtonEdit.ControlSetAnchors(Value: TAnchors);\r\nbegin\r\n Anchors := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLButtonEdit.ControlSetPasswordChar(Value: Char);\r\nbegin\r\n FEditControl.PasswordChar := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLButtonEdit.ControlSetEditMask(const Value: string);\r\nbegin\r\n FEditControl.EditMask := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLButtonEdit.ControlSetOnButtonClick(Value: TNotifyEvent);\r\nbegin\r\n FButton.OnClick := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLButtonEdit.ControlSetButtonCaption(const Value: string);\r\nbegin\r\n FButton.Caption := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLButtonEdit.ControlSetGlyph(Value: TBitmap);\r\nbegin\r\n FButton.Glyph.Assign(Value);\r\nend;\r\n\r\nprocedure TJvDynControlJVCLButtonEdit.ControlSetNumGlyphs(Value: Integer);\r\nbegin\r\n FButton.NumGlyphs := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLButtonEdit.ControlSetLayout(Value: TButtonLayout);\r\nbegin\r\n FButton.Layout := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLButtonEdit.ControlSetDefault(Value: Boolean);\r\nbegin\r\n FButton.Default := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLButtonEdit.ControlSetCancel(Value: Boolean);\r\nbegin\r\n FButton.Cancel := Value;\r\nend;\r\n\r\n\r\n//=== { TJvDynControlJVCLCalcEdit } ==========================================\r\n\r\nprocedure TJvDynControlJVCLCalcEdit.ControlSetDefaultProperties;\r\nbegin\r\nend;\r\n\r\nprocedure TJvDynControlJVCLCalcEdit.ControlSetReadOnly(Value: Boolean);\r\nbegin\r\n ReadOnly := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLCalcEdit.ControlSetTabOrder(Value: Integer);\r\nbegin\r\n TabOrder := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLCalcEdit.ControlSetOnEnter(Value: TNotifyEvent);\r\nbegin\r\n OnEnter := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLCalcEdit.ControlSetOnExit(Value: TNotifyEvent);\r\nbegin\r\n OnExit := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLCalcEdit.ControlSetOnChange(Value: TNotifyEvent);\r\nbegin\r\n OnChange := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLCalcEdit.ControlSetOnClick(Value: TNotifyEvent);\r\nbegin\r\n\r\nend;\r\n\r\nprocedure TJvDynControlJVCLCalcEdit.ControlSetHint(const Value: string);\r\nbegin\r\n Hint := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLCalcEdit.ControlSetValue(Value: Variant);\r\nbegin\r\n Text := VarToStr(Value);\r\nend;\r\n\r\nfunction TJvDynControlJVCLCalcEdit.ControlGetValue: Variant;\r\nbegin\r\n Result := Text;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLCalcEdit.ControlSetAnchors(Value: TAnchors);\r\nbegin\r\n Anchors := Value;\r\nend;\r\n\r\n//=== { TJvDynControlJVCLSpinEdit } ==========================================\r\n\r\nprocedure TJvDynControlJVCLSpinEdit.ControlSetDefaultProperties;\r\nbegin\r\n ButtonKind := bkDiagonal;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLSpinEdit.ControlSetReadOnly(Value: Boolean);\r\nbegin\r\n ReadOnly := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLSpinEdit.ControlSetTabOrder(Value: Integer);\r\nbegin\r\n TabOrder := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLSpinEdit.ControlSetOnEnter(Value: TNotifyEvent);\r\nbegin\r\n OnEnter := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLSpinEdit.ControlSetOnExit(Value: TNotifyEvent);\r\nbegin\r\n OnExit := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLSpinEdit.ControlSetOnChange(Value: TNotifyEvent);\r\nbegin\r\n OnChange := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLSpinEdit.ControlSetOnClick(Value: TNotifyEvent);\r\nbegin\r\nend;\r\n\r\nprocedure TJvDynControlJVCLSpinEdit.ControlSetHint(const Value: string);\r\nbegin\r\n Hint := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLSpinEdit.ControlSetValue(Value: Variant);\r\nbegin\r\n Text := VarToStr(Value);\r\nend;\r\n\r\nfunction TJvDynControlJVCLSpinEdit.ControlGetValue: Variant;\r\nbegin\r\n Result := Text;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLSpinEdit.ControlSetAnchors(Value: TAnchors);\r\nbegin\r\n Anchors := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLSpinEdit.ControlSetIncrement(Value: Integer);\r\nbegin\r\n Increment := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLSpinEdit.ControlSetMinValue(Value: Double);\r\nbegin\r\n MinValue := Value;\r\n CheckMinValue := (MaxValue <> 0) and (MinValue <> 0);\r\n CheckMaxValue := CheckMinValue;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLSpinEdit.ControlSetMaxValue(Value: Double);\r\nbegin\r\n MaxValue := Value;\r\n CheckMinValue := (MaxValue <> 0) and (MinValue <> 0);\r\n CheckMaxValue := CheckMinValue;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLSpinEdit.ControlSetUseForInteger(Value: Boolean);\r\nbegin\r\n if Value then\r\n {$IFDEF BCB}\r\n ValueType := TValueType(vtInteger)\r\n {$ELSE}\r\n ValueType := vtInteger\r\n {$ENDIF BCB}\r\n else\r\n ValueType := vtFloat;\r\nend;\r\n\r\n//=== { TJvDynControlJVCLFileNameEdit } ======================================\r\n\r\nprocedure TJvDynControlJVCLFileNameEdit.ControlSetDefaultProperties;\r\nbegin\r\nend;\r\n\r\nprocedure TJvDynControlJVCLFileNameEdit.ControlSetReadOnly(Value: Boolean);\r\nbegin\r\n ReadOnly := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLFileNameEdit.ControlSetTabOrder(Value: Integer);\r\nbegin\r\n TabOrder := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLFileNameEdit.ControlSetOnEnter(Value: TNotifyEvent);\r\nbegin\r\n OnEnter := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLFileNameEdit.ControlSetOnExit(Value: TNotifyEvent);\r\nbegin\r\n OnExit := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLFileNameEdit.ControlSetOnChange(Value: TNotifyEvent);\r\nbegin\r\n OnChange := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLFileNameEdit.ControlSetOnClick(Value: TNotifyEvent);\r\nbegin\r\nend;\r\n\r\nprocedure TJvDynControlJVCLFileNameEdit.ControlSetHint(const Value: string);\r\nbegin\r\n Hint := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLFileNameEdit.ControlSetValue(Value: Variant);\r\nbegin\r\n Text := VarToStr(Value);\r\nend;\r\n\r\nfunction TJvDynControlJVCLFileNameEdit.ControlGetValue: Variant;\r\nbegin\r\n Result := Text;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLFileNameEdit.ControlSetAnchors(Value: TAnchors);\r\nbegin\r\n Anchors := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLFileNameEdit.ControlSetInitialDir(const Value: string);\r\nbegin\r\n InitialDir := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLFileNameEdit.ControlSetDefaultExt(const Value: string);\r\nbegin\r\n DefaultExt := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLFileNameEdit.ControlSetDialogTitle(const Value: string);\r\nbegin\r\n DialogTitle := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLFileNameEdit.ControlSetDialogOptions(Value: TOpenOptions);\r\nbegin\r\n DialogOptions := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLFileNameEdit.ControlSetFilter(const Value: string);\r\nbegin\r\n Filter := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLFileNameEdit.ControlSetFilterIndex(Value: Integer);\r\nbegin\r\n FilterIndex := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLFileNameEdit.ControlSetDialogKind(Value: TJvDynControlFileNameDialogKind);\r\nbegin\r\n case Value of\r\n jdkOpen:\r\n DialogKind := dkOpen;\r\n jdkOpenPicture:\r\n DialogKind := dkOpenPicture;\r\n jdkSave:\r\n DialogKind := dkSave;\r\n jdkSavePicture:\r\n DialogKind := dkSavePicture;\r\n end;\r\nend;\r\n\r\n//=== { TJvDynControlJVCLDirectoryEdit } =====================================\r\n\r\nprocedure TJvDynControlJVCLDirectoryEdit.ControlSetDefaultProperties;\r\nbegin\r\n DialogKind := dkWin32;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDirectoryEdit.ControlSetReadOnly(Value: Boolean);\r\nbegin\r\n ReadOnly := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDirectoryEdit.ControlSetTabOrder(Value: Integer);\r\nbegin\r\n TabOrder := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDirectoryEdit.ControlSetOnEnter(Value: TNotifyEvent);\r\nbegin\r\n OnEnter := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDirectoryEdit.ControlSetOnExit(Value: TNotifyEvent);\r\nbegin\r\n OnExit := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDirectoryEdit.ControlSetOnChange(Value: TNotifyEvent);\r\nbegin\r\n OnChange := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDirectoryEdit.ControlSetOnClick(Value: TNotifyEvent);\r\nbegin\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDirectoryEdit.ControlSetHint(const Value: string);\r\nbegin\r\n Hint := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDirectoryEdit.ControlSetValue(Value: Variant);\r\nbegin\r\n Text := VarToStr(Value);\r\nend;\r\n\r\nfunction TJvDynControlJVCLDirectoryEdit.ControlGetValue: Variant;\r\nbegin\r\n Result := Text;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDirectoryEdit.ControlSetAnchors(Value: TAnchors);\r\nbegin\r\n Anchors := Value;\r\nend;\r\n\r\n\r\nprocedure TJvDynControlJVCLDirectoryEdit.ControlSetInitialDir(const Value: string);\r\nbegin\r\n InitialDir := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDirectoryEdit.ControlSetDialogTitle(const Value: string);\r\nbegin\r\n DialogText := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDirectoryEdit.ControlSetDialogOptions(Value: TSelectDirOpts);\r\nbegin\r\n DialogOptions := Value;\r\nend;\r\n\r\n//=== { TJvDynControlJVCLDateTimeEdit } ======================================\r\n\r\nconstructor TJvDynControlJVCLDateTimeEdit.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n Caption := '';\r\n BorderStyle := bsNone;\r\n BevelInner := bvNone;\r\n BevelOuter := bvNone;\r\n FDatePicker := TJvDateTimePicker.Create(Self);\r\n FDatePicker.Parent := Self;\r\n FDatePicker.Align := alLeft;\r\n FDatePicker.Top := 0;\r\n FDatePicker.Left := 0;\r\n FTimePicker := TJvDateTimePicker.Create(Self);\r\n FTimePicker.Align := alClient;\r\n FTimePicker.Parent := Self;\r\n FTimePicker.Top := 0;\r\n FTimePicker.Left := 0;\r\n Height := FDatePicker.Height;\r\n Width := FDatePicker.Width + FTimePicker.Width;\r\n OnResize := ControlResize;\r\n ControlResize(nil);\r\n FDatePicker.DateFormat := dfShort;\r\n FDatePicker.DateMode := dmComboBox;\r\n FDatePicker.Kind := dtkDate;\r\n FTimePicker.DateFormat := dfShort;\r\n FTimePicker.DateMode := dmUpDown;\r\n FTimePicker.Kind := dtkTime;\r\nend;\r\n\r\ndestructor TJvDynControlJVCLDateTimeEdit.Destroy;\r\nbegin\r\n FreeAndNil(FDatePicker);\r\n FreeAndNil(FTimePicker);\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDateTimeEdit.ControlResize(Sender: TObject);\r\nbegin\r\n FDatePicker.Height := Height div 2;\r\n FTimePicker.Height := Height;\r\n FDatePicker.Width := Width div 2;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDateTimeEdit.ControlSetDefaultProperties;\r\nbegin\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDateTimeEdit.ControlSetTabOrder(Value: Integer);\r\nbegin\r\n TabOrder := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDateTimeEdit.ControlSetOnEnter(Value: TNotifyEvent);\r\nbegin\r\n FDatePicker.OnEnter := Value;\r\n FTimePicker.OnEnter := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDateTimeEdit.ControlSetOnExit(Value: TNotifyEvent);\r\nbegin\r\n FDatePicker.OnExit := Value;\r\n FTimePicker.OnExit := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDateTimeEdit.ControlSetOnChange(Value: TNotifyEvent);\r\nbegin\r\n FDatePicker.OnChange := Value;\r\n FTimePicker.OnChange := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDateTimeEdit.ControlSetOnClick(Value: TNotifyEvent);\r\nbegin\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDateTimeEdit.ControlSetHint(const Value: string);\r\nbegin\r\n Hint := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDateTimeEdit.ControlSetValue(Value: Variant);\r\nbegin\r\n FDatePicker.Date := Value;\r\n FTimePicker.Time := Value;\r\nend;\r\n\r\nfunction TJvDynControlJVCLDateTimeEdit.ControlGetValue: Variant;\r\nbegin\r\n Result := Trunc(FDatePicker.Date) + (Trunc(FTimePicker.Time) - FTimePicker.Time);\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDateTimeEdit.ControlSetAnchors(Value: TAnchors);\r\nbegin\r\n Anchors := Value;\r\nend;\r\n\r\n// IJvDynControlDate\r\n\r\nprocedure TJvDynControlJVCLDateTimeEdit.ControlSetMinDate(Value: TDateTime);\r\nbegin\r\n FDatePicker.MinDate := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDateTimeEdit.ControlSetMaxDate(Value: TDateTime);\r\nbegin\r\n FDatePicker.MaxDate := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDateTimeEdit.ControlSetFormat(const Value: string);\r\nbegin\r\n FDatePicker.Format := Value;\r\n FTimePicker.Format := Value;\r\nend;\r\n\r\n//=== { TJvDynControlJVCLDateEdit } ==========================================\r\n\r\nprocedure TJvDynControlJVCLDateEdit.ControlSetDefaultProperties;\r\nbegin\r\n DateFormat := dfShort;\r\n DateMode := dmComboBox;\r\n Kind := dtkDate;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDateEdit.ControlSetTabOrder(Value: Integer);\r\nbegin\r\n TabOrder := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDateEdit.ControlSetOnEnter(Value: TNotifyEvent);\r\nbegin\r\n OnEnter := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDateEdit.ControlSetOnExit(Value: TNotifyEvent);\r\nbegin\r\n OnExit := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDateEdit.ControlSetOnChange(Value: TNotifyEvent);\r\nbegin\r\n OnChange := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDateEdit.ControlSetOnClick(Value: TNotifyEvent);\r\nbegin\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDateEdit.ControlSetHint(const Value: string);\r\nbegin\r\n Hint := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDateEdit.ControlSetValue(Value: Variant);\r\nbegin\r\n Date := Value;\r\nend;\r\n\r\nfunction TJvDynControlJVCLDateEdit.ControlGetValue: Variant;\r\nbegin\r\n Result := Date;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDateEdit.ControlSetAnchors(Value: TAnchors);\r\nbegin\r\n Anchors := Value;\r\nend;\r\n\r\n// IJvDynControlDate\r\n\r\nprocedure TJvDynControlJVCLDateEdit.ControlSetMinDate(Value: TDateTime);\r\nbegin\r\n MinDate := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDateEdit.ControlSetMaxDate(Value: TDateTime);\r\nbegin\r\n MaxDate := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDateEdit.ControlSetFormat(const Value: string);\r\nbegin\r\n Format := Value;\r\nend;\r\n\r\n//=== { TJvDynControlJVCLTimeEdit } ==========================================\r\n\r\nprocedure TJvDynControlJVCLTimeEdit.ControlSetDefaultProperties;\r\nbegin\r\n DateFormat := dfShort;\r\n Kind := dtkTime;\r\n DateMode := dmUpDown;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLTimeEdit.ControlSetTabOrder(Value: Integer);\r\nbegin\r\n TabOrder := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLTimeEdit.ControlSetOnEnter(Value: TNotifyEvent);\r\nbegin\r\n OnEnter := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLTimeEdit.ControlSetOnExit(Value: TNotifyEvent);\r\nbegin\r\n OnExit := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLTimeEdit.ControlSetOnChange(Value: TNotifyEvent);\r\nbegin\r\n OnChange := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLTimeEdit.ControlSetOnClick(Value: TNotifyEvent);\r\nbegin\r\nend;\r\n\r\nprocedure TJvDynControlJVCLTimeEdit.ControlSetHint(const Value: string);\r\nbegin\r\n Hint := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLTimeEdit.ControlSetValue(Value: Variant);\r\nbegin\r\n Time := Value;\r\nend;\r\n\r\nfunction TJvDynControlJVCLTimeEdit.ControlGetValue: Variant;\r\nbegin\r\n Result := Time;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLTimeEdit.ControlSetAnchors(Value: TAnchors);\r\nbegin\r\n Anchors := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLTimeEdit.ControlSetFormat(const Value: string);\r\nbegin\r\n Format := Value;\r\nend;\r\n\r\n//=== { TJvDynControlJVCLCheckBox } ===========================================\r\n\r\nfunction TJvDynControlJVCLCheckBox.ControlGetCaption: string;\r\nbegin\r\n Result := Caption;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLCheckBox.ControlSetDefaultProperties;\r\nbegin\r\nend;\r\n\r\nprocedure TJvDynControlJVCLCheckBox.ControlSetReadOnly(Value: Boolean);\r\nbegin\r\n Enabled := False;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLCheckBox.ControlSetCaption(const Value: string);\r\nbegin\r\n if Caption <> Value then\r\n Caption := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLCheckBox.ControlSetTabOrder(Value: Integer);\r\nbegin\r\n TabOrder := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLCheckBox.ControlSetOnEnter(Value: TNotifyEvent);\r\nbegin\r\n OnEnter := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLCheckBox.ControlSetOnExit(Value: TNotifyEvent);\r\nbegin\r\n OnExit := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLCheckBox.ControlSetOnClick(Value: TNotifyEvent);\r\nbegin\r\n OnClick := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLCheckBox.ControlSetHint(const Value: string);\r\nbegin\r\n Hint := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLCheckBox.ControlSetOnChange(Value: TNotifyEvent);\r\nbegin\r\n OnClick := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLCheckBox.ControlSetValue(Value: Variant);\r\nbegin\r\n Checked := JvDynControlVariantToBoolean(Value);\r\nend;\r\n\r\nfunction TJvDynControlJVCLCheckBox.ControlGetValue: Variant;\r\nbegin\r\n Result := Checked;\r\nend;\r\n\r\n//IJvDynControlCheckBox\r\nprocedure TJvDynControlJVCLCheckBox.ControlSetAllowGrayed(Value: Boolean);\r\nbegin\r\n AllowGrayed := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLCheckBox.ControlSetState(Value: TCheckBoxState);\r\nbegin\r\n State := Value;\r\nend;\r\n\r\nfunction TJvDynControlJVCLCheckBox.ControlGetState: TCheckBoxState;\r\nbegin\r\n Result := State;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLCheckBox.ControlSetAnchors(Value: TAnchors);\r\nbegin\r\n Anchors := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLCheckBox.ControlSetFont(Value: TFont);\r\nbegin\r\n Font.Assign(Value);\r\nend;\r\n\r\nfunction TJvDynControlJVCLCheckBox.ControlGetFont: TFont;\r\nbegin\r\n Result := Font;\r\nend;\r\n\r\n\r\nfunction TJvDynControlJVCLMemo.ControlGetFont: TFont;\r\nbegin\r\n Result := Font;\r\nend;\r\n\r\n//=== { TJvDynControlJVCLMemo } ==============================================\r\n\r\nprocedure TJvDynControlJVCLMemo.ControlSetDefaultProperties;\r\nbegin\r\nend;\r\n\r\nprocedure TJvDynControlJVCLMemo.ControlSetReadOnly(Value: Boolean);\r\nbegin\r\n ReadOnly := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLMemo.ControlSetTabOrder(Value: Integer);\r\nbegin\r\n TabOrder := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLMemo.ControlSetOnEnter(Value: TNotifyEvent);\r\nbegin\r\n OnEnter := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLMemo.ControlSetOnExit(Value: TNotifyEvent);\r\nbegin\r\n OnExit := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLMemo.ControlSetOnChange(Value: TNotifyEvent);\r\nbegin\r\n OnChange := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLMemo.ControlSetOnClick(Value: TNotifyEvent);\r\nbegin\r\n OnClick := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLMemo.ControlSetHint(const Value: string);\r\nbegin\r\n Hint := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLMemo.ControlSetValue(Value: Variant);\r\nbegin\r\n Text := VarToStr(Value);\r\nend;\r\n\r\nfunction TJvDynControlJVCLMemo.ControlGetValue: Variant;\r\nbegin\r\n Result := Text;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLMemo.ControlSetSorted(Value: Boolean);\r\nbegin\r\nend;\r\n\r\nprocedure TJvDynControlJVCLMemo.ControlSetItems(Value: TStrings);\r\nbegin\r\n Lines.Assign(Value);\r\nend;\r\n\r\nfunction TJvDynControlJVCLMemo.ControlGetItems: TStrings;\r\nbegin\r\n Result := Lines;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLMemo.ControlSetAnchors(Value: TAnchors);\r\nbegin\r\n Anchors := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLMemo.ControlSetWantTabs(Value: Boolean);\r\nbegin\r\n WantTabs := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLMemo.ControlSetWantReturns(Value: Boolean);\r\nbegin\r\n WantReturns := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLMemo.ControlSetWordWrap(Value: Boolean);\r\nbegin\r\n WordWrap := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLMemo.ControlSetScrollBars(Value: TScrollStyle);\r\nbegin\r\n ScrollBars := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLMemo.ControlSetAlignment(Value: TAlignment);\r\nbegin\r\n Alignment := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLMemo.ControlSetFont(Value: TFont);\r\nbegin\r\n Font.Assign(Value);\r\nend;\r\n\r\nfunction TJvDynControlJVCLRichEdit.ControlGetFont: TFont;\r\nbegin\r\n Result := Font;\r\nend;\r\n\r\n//=== { TJvDynControlJVCLRichEdit } ==========================================\r\n\r\nprocedure TJvDynControlJVCLRichEdit.ControlSetDefaultProperties;\r\nbegin\r\nend;\r\n\r\nprocedure TJvDynControlJVCLRichEdit.ControlSetReadOnly(Value: Boolean);\r\nbegin\r\n ReadOnly := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLRichEdit.ControlSetTabOrder(Value: Integer);\r\nbegin\r\n TabOrder := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLRichEdit.ControlSetOnEnter(Value: TNotifyEvent);\r\nbegin\r\n OnEnter := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLRichEdit.ControlSetOnExit(Value: TNotifyEvent);\r\nbegin\r\n OnExit := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLRichEdit.ControlSetOnChange(Value: TNotifyEvent);\r\nbegin\r\n OnChange := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLRichEdit.ControlSetOnClick(Value: TNotifyEvent);\r\nbegin\r\n OnClick := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLRichEdit.ControlSetHint(const Value: string);\r\nbegin\r\n Hint := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLRichEdit.ControlSetValue(Value: Variant);\r\nbegin\r\n Text := VarToStr(Value);\r\nend;\r\n\r\nfunction TJvDynControlJVCLRichEdit.ControlGetValue: Variant;\r\nbegin\r\n Result := Text;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLRichEdit.ControlSetSorted(Value: Boolean);\r\nbegin\r\nend;\r\n\r\nprocedure TJvDynControlJVCLRichEdit.ControlSetItems(Value: TStrings);\r\nbegin\r\n Lines.Assign(Value);\r\nend;\r\n\r\nfunction TJvDynControlJVCLRichEdit.ControlGetItems: TStrings;\r\nbegin\r\n Result := Lines;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLRichEdit.ControlSetAnchors(Value: TAnchors);\r\nbegin\r\n Anchors := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLRichEdit.ControlSetFont(Value: TFont);\r\nbegin\r\n Font.Assign(Value);\r\nend;\r\n\r\nprocedure TJvDynControlJVCLRichEdit.ControlSetWantTabs(Value: Boolean);\r\nbegin\r\n WantTabs := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLRichEdit.ControlSetWantReturns(Value: Boolean);\r\nbegin\r\n WantReturns := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLRichEdit.ControlSetWordWrap(Value: Boolean);\r\nbegin\r\n WordWrap := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLRichEdit.ControlSetScrollBars(Value: TScrollStyle);\r\nbegin\r\n ScrollBars := Value;\r\nend;\r\n\r\n//=== { TJvDynControlJVCLRadioGroup } ===========================================\r\n\r\nfunction TJvDynControlJVCLRadioGroup.ControlGetCaption: string;\r\nbegin\r\n Result := Caption;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLRadioGroup.ControlSetDefaultProperties;\r\nbegin\r\nend;\r\n\r\nprocedure TJvDynControlJVCLRadioGroup.ControlSetReadOnly(Value: Boolean);\r\nbegin\r\n ReadOnly := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLRadioGroup.ControlSetCaption(const Value: string);\r\nbegin\r\n if Caption <> Value then\r\n Caption := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLRadioGroup.ControlSetTabOrder(Value: Integer);\r\nbegin\r\n TabOrder := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLRadioGroup.ControlSetOnEnter(Value: TNotifyEvent);\r\nbegin\r\n OnEnter := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLRadioGroup.ControlSetOnExit(Value: TNotifyEvent);\r\nbegin\r\n OnExit := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLRadioGroup.ControlSetOnChange(Value: TNotifyEvent);\r\nbegin\r\n OnClick := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLRadioGroup.ControlSetOnClick(Value: TNotifyEvent);\r\nbegin\r\n OnClick := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLRadioGroup.ControlSetHint(const Value: string);\r\nbegin\r\n Hint := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLRadioGroup.ControlSetValue(Value: Variant);\r\nbegin\r\n if VarIsInt(Value) then\r\n ItemIndex := Value\r\n else\r\n ItemIndex := Items.IndexOf(Value);\r\nend;\r\n\r\nfunction TJvDynControlJVCLRadioGroup.ControlGetValue: Variant;\r\nbegin\r\n Result := ItemIndex;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLRadioGroup.ControlSetSorted(Value: Boolean);\r\nbegin\r\nend;\r\n\r\nprocedure TJvDynControlJVCLRadioGroup.ControlSetItems(Value: TStrings);\r\nbegin\r\n Items.Assign(Value);\r\nend;\r\n\r\nfunction TJvDynControlJVCLRadioGroup.ControlGetItems: TStrings;\r\nbegin\r\n Result := Items;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLRadioGroup.ControlSetAnchors(Value: TAnchors);\r\nbegin\r\n Anchors := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLRadioGroup.ControlSetColumns(Value: Integer);\r\nbegin\r\n Columns := Value;\r\nend;\r\n\r\nfunction TJvDynControlJVCLListBox.ControlGetItemIndex: Integer;\r\nbegin\r\n Result := ItemIndex;\r\nend;\r\n\r\n//=== { TJvDynControlJVCLListBox } ===========================================\r\n\r\nprocedure TJvDynControlJVCLListBox.ControlSetDefaultProperties;\r\nbegin\r\nend;\r\n\r\nprocedure TJvDynControlJVCLListBox.ControlSetTabOrder(Value: Integer);\r\nbegin\r\n TabOrder := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLListBox.ControlSetOnEnter(Value: TNotifyEvent);\r\nbegin\r\n OnEnter := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLListBox.ControlSetOnExit(Value: TNotifyEvent);\r\nbegin\r\n OnExit := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLListBox.ControlSetOnChange(Value: TNotifyEvent);\r\nbegin\r\n// OnChange := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLListBox.ControlSetOnClick(Value: TNotifyEvent);\r\nbegin\r\n OnClick := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLListBox.ControlSetHint(const Value: string);\r\nbegin\r\n Hint := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLListBox.ControlSetValue(Value: Variant);\r\nbegin\r\n if VarIsInt(Value) then\r\n ItemIndex := Value\r\n else\r\n ItemIndex := Items.IndexOf(Value);\r\nend;\r\n\r\nfunction TJvDynControlJVCLListBox.ControlGetValue: Variant;\r\nbegin\r\n Result := ItemIndex;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLListBox.ControlSetSorted(Value: Boolean);\r\nbegin\r\n Sorted := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLListBox.ControlSetItems(Value: TStrings);\r\nbegin\r\n Items.Assign(Value);\r\nend;\r\n\r\nfunction TJvDynControlJVCLListBox.ControlGetItems: TStrings;\r\nbegin\r\n Result := Items;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLListBox.ControlSetAnchors(Value: TAnchors);\r\nbegin\r\n Anchors := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLListBox.ControlSetItemIndex(const Value: Integer);\r\nbegin\r\n ItemIndex := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLListBox.ControlSetOnDblClick(Value: TNotifyEvent);\r\nbegin\r\n OnDblClick := Value;\r\nend;\r\n\r\nfunction TJvDynControlJVCLListBox.ControlGetOnKeyDown: TKeyEvent;\r\nbegin\r\n Result := OnKeyDown;\r\nend;\r\n\r\nfunction TJvDynControlJVCLListBox.ControlGetOnKeyPress: TKeyPressEvent;\r\nbegin\r\n Result := OnKeyPress;\r\nend;\r\n\r\nfunction TJvDynControlJVCLListBox.ControlGetOnKeyUp: TKeyEvent;\r\nbegin\r\n Result := OnKeyUp;\r\nend;\r\n\r\nfunction TJvDynControlJVCLListBox.ControlGetOnMouseDown: TMouseEvent;\r\nbegin\r\n Result := OnMouseDown;\r\nend;\r\n\r\nfunction TJvDynControlJVCLListBox.ControlGetOnMouseEnter: TNotifyEvent;\r\nbegin\r\n {$IFDEF DELPHI2007_UP}\r\n Result := OnMouseEnter;\r\n {$ENDIF DELPHI2007_UP}\r\nend;\r\n\r\nfunction TJvDynControlJVCLListBox.ControlGetOnMouseLeave: TNotifyEvent;\r\nbegin\r\n {$IFDEF DELPHI2007_UP}\r\n Result := OnMouseLeave;\r\n {$ENDIF DELPHI2007_UP}\r\nend;\r\n\r\nfunction TJvDynControlJVCLListBox.ControlGetOnMouseMove: TMouseMoveEvent;\r\nbegin\r\n Result := OnMouseMove;\r\nend;\r\n\r\nfunction TJvDynControlJVCLListBox.ControlGetOnMouseUp: TMouseEvent;\r\nbegin\r\n Result := OnMouseUp;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLListBox.ControlSetOnKeyDown(const Value: TKeyEvent);\r\nbegin\r\n OnKeyDown := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLListBox.ControlSetOnKeyPress(const Value: TKeyPressEvent);\r\nbegin\r\n OnKeyPress := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLListBox.ControlSetOnKeyUp(const Value: TKeyEvent);\r\nbegin\r\n OnKeyUp := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLListBox.ControlSetOnMouseDown(const Value: TMouseEvent);\r\nbegin\r\n OnMouseDown := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLListBox.ControlSetOnMouseEnter(const Value: TNotifyEvent);\r\nbegin\r\n {$IFDEF DELPHI2007_UP}\r\n OnMouseEnter := Value;\r\n {$ENDIF DELPHI2007_UP}\r\nend;\r\n\r\nprocedure TJvDynControlJVCLListBox.ControlSetOnMouseLeave(const Value: TNotifyEvent);\r\nbegin\r\n {$IFDEF DELPHI2007_UP}\r\n OnMouseEnter := Value;\r\n {$ENDIF DELPHI2007_UP}\r\nend;\r\n\r\nprocedure TJvDynControlJVCLListBox.ControlSetOnMouseMove(const Value: TMouseMoveEvent);\r\nbegin\r\n OnMouseMove := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLListBox.ControlSetOnMouseUp(const Value: TMouseEvent);\r\nbegin\r\n OnMouseUp := Value;\r\nend;\r\n\r\n//=== { TJvDynControlJVCLCheckListBox } ======================================\r\n\r\nprocedure TJvDynControlJVCLCheckListBox.ControlSetDefaultProperties;\r\nbegin\r\nend;\r\n\r\nprocedure TJvDynControlJVCLCheckListBox.ControlSetTabOrder(Value: Integer);\r\nbegin\r\n TabOrder := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLCheckListBox.ControlSetOnEnter(Value: TNotifyEvent);\r\nbegin\r\n OnEnter := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLCheckListBox.ControlSetOnExit(Value: TNotifyEvent);\r\nbegin\r\n OnExit := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLCheckListBox.ControlSetOnChange(Value: TNotifyEvent);\r\nbegin\r\n// OnChange := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLCheckListBox.ControlSetOnClick(Value: TNotifyEvent);\r\nbegin\r\n OnClick := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLCheckListBox.ControlSetHint(const Value: string);\r\nbegin\r\n Hint := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLCheckListBox.ControlSetValue(Value: Variant);\r\nbegin\r\n if VarIsInt(Value) then\r\n ItemIndex := Value\r\n else\r\n ItemIndex := Items.IndexOf(Value);\r\nend;\r\n\r\nfunction TJvDynControlJVCLCheckListBox.ControlGetValue: Variant;\r\nbegin\r\n Result := ItemIndex;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLCheckListBox.ControlSetSorted(Value: Boolean);\r\nbegin\r\n Sorted := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLCheckListBox.ControlSetItems(Value: TStrings);\r\nbegin\r\n Items.Assign(Value);\r\nend;\r\n\r\nfunction TJvDynControlJVCLCheckListBox.ControlGetItems: TStrings;\r\nbegin\r\n Result := Items;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLCheckListBox.ControlSetOnDblClick(Value: TNotifyEvent);\r\nbegin\r\n OnDblClick := Value;\r\nend;\r\n\r\n//IJvDynControlCheckListBox = interface\r\nprocedure TJvDynControlJVCLCheckListBox.ControlSetAllowGrayed(Value: Boolean);\r\nbegin\r\n AllowGrayed := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLCheckListBox.ControlSetChecked(Index: Integer; Value: Boolean);\r\nbegin\r\n Checked[Index] := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLCheckListBox.ControlSetItemEnabled(Index: Integer; Value: Boolean);\r\nbegin\r\n ItemEnabled[Index] := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLCheckListBox.ControlSetHeader(Index: Integer; Value: Boolean);\r\nbegin\r\n Header[Index] := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLCheckListBox.ControlSetState(Index: Integer; Value: TCheckBoxState);\r\nbegin\r\n State[Index] := Value;\r\nend;\r\n\r\nfunction TJvDynControlJVCLCheckListBox.ControlGetChecked(Index: Integer): Boolean;\r\nbegin\r\n Result := Checked[Index];\r\nend;\r\n\r\nfunction TJvDynControlJVCLCheckListBox.ControlGetItemEnabled(Index: Integer): Boolean;\r\nbegin\r\n Result := ItemEnabled[Index];\r\nend;\r\n\r\nfunction TJvDynControlJVCLCheckListBox.ControlGetHeader(Index: Integer): Boolean;\r\nbegin\r\n Result := Header[Index];\r\nend;\r\n\r\nfunction TJvDynControlJVCLCheckListBox.ControlGetState(Index: Integer): TCheckBoxState;\r\nbegin\r\n Result := State[Index];\r\nend;\r\n\r\nprocedure TJvDynControlJVCLCheckListBox.ControlSetAnchors(Value: TAnchors);\r\nbegin\r\n Anchors := Value;\r\nend;\r\n\r\n//=== { TJvDynControlJVCLComboBox } ==========================================\r\n\r\nprocedure TJvDynControlJVCLComboBox.ControlSetDefaultProperties;\r\nbegin\r\nend;\r\n\r\nprocedure TJvDynControlJVCLComboBox.ControlSetTabOrder(Value: Integer);\r\nbegin\r\n TabOrder := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLComboBox.ControlSetOnEnter(Value: TNotifyEvent);\r\nbegin\r\n OnEnter := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLComboBox.ControlSetOnExit(Value: TNotifyEvent);\r\nbegin\r\n OnExit := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLComboBox.ControlSetOnChange(Value: TNotifyEvent);\r\nbegin\r\n// OnChange := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLComboBox.ControlSetOnClick(Value: TNotifyEvent);\r\nbegin\r\n OnClick := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLComboBox.ControlSetHint(const Value: string);\r\nbegin\r\n Hint := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLComboBox.ControlSetValue(Value: Variant);\r\nbegin\r\n if (Style = csDropDownList) then\r\n if VarIsInt(Value) then\r\n ItemIndex := VarToInt(Value)\r\n else\r\n ItemIndex := Items.IndexOf(VarToStr(Value))\r\n else\r\n Text := VarToStr(Value);\r\nend;\r\n\r\nfunction TJvDynControlJVCLComboBox.ControlGetValue: Variant;\r\nbegin\r\n Result := Text;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLComboBox.ControlSetSorted(Value: Boolean);\r\nbegin\r\n Sorted := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLComboBox.ControlSetItems(Value: TStrings);\r\nbegin\r\n Items.Assign(Value);\r\nend;\r\n\r\nfunction TJvDynControlJVCLComboBox.ControlGetItems: TStrings;\r\nbegin\r\n Result := Items;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLComboBox.ControlSetAnchors(Value: TAnchors);\r\nbegin\r\n Anchors := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLComboBox.ControlSetNewEntriesAllowed(Value: Boolean);\r\nbegin\r\n if Value then\r\n Style := csDropDown\r\n else\r\n Style := csDropDownList;\r\nend;\r\n\r\n//=== { TJvDynControlJVCLGroupBox } ===========================================\r\n\r\nfunction TJvDynControlJVCLGroupBox.ControlGetCaption: string;\r\nbegin\r\n Result := Caption;\r\nend;\r\n\r\n//=== { TJvDynControlJVCLGroupBox } ==========================================\r\n\r\nprocedure TJvDynControlJVCLGroupBox.ControlSetAnchors(Value: TAnchors);\r\nbegin\r\n Anchors := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLGroupBox.ControlSetDefaultProperties;\r\nbegin\r\nend;\r\n\r\nprocedure TJvDynControlJVCLGroupBox.ControlSetCaption(const Value: string);\r\nbegin\r\n if Caption <> Value then\r\n Caption := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLGroupBox.ControlSetTabOrder(Value: Integer);\r\nbegin\r\n TabOrder := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLGroupBox.ControlSetOnEnter(Value: TNotifyEvent);\r\nbegin\r\n OnEnter := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLGroupBox.ControlSetOnExit(Value: TNotifyEvent);\r\nbegin\r\n OnExit := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLGroupBox.ControlSetOnClick(Value: TNotifyEvent);\r\nbegin\r\nend;\r\n\r\nprocedure TJvDynControlJVCLGroupBox.ControlSetHint(const Value: string);\r\nbegin\r\n Hint := Value;\r\nend;\r\n\r\n//=== { TJvDynControlJVCLPanel } ===========================================\r\n\r\nfunction TJvDynControlJVCLPanel.ControlGetCaption: string;\r\nbegin\r\n Result := Caption;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLPanel.ControlSetDefaultProperties;\r\nbegin\r\n BevelInner := bvNone;\r\n BevelOuter := bvNone;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLPanel.ControlSetCaption(const Value: string);\r\nbegin\r\n if Caption <> Value then\r\n Caption := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLPanel.ControlSetTabOrder(Value: Integer);\r\nbegin\r\n TabOrder := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLPanel.ControlSetOnEnter(Value: TNotifyEvent);\r\nbegin\r\n OnEnter := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLPanel.ControlSetOnExit(Value: TNotifyEvent);\r\nbegin\r\n OnExit := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLPanel.ControlSetOnClick(Value: TNotifyEvent);\r\nbegin\r\nend;\r\n\r\nprocedure TJvDynControlJVCLPanel.ControlSetHint(const Value: string);\r\nbegin\r\n Hint := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLPanel.ControlSetBorder(ABevelInner: TPanelBevel;\r\n ABevelOuter: TPanelBevel; ABevelWidth: Integer;\r\n ABorderStyle: TBorderStyle; ABorderWidth: Integer);\r\nbegin\r\n BorderWidth := ABorderWidth;\r\n BorderStyle := ABorderStyle;\r\n BevelInner := ABevelInner;\r\n BevelOuter := ABevelOuter;\r\n BevelWidth := ABevelWidth;\r\nend;\r\n\r\n\r\nprocedure TJvDynControlJVCLPanel.ControlSetAlign(Value: TAlign);\r\nbegin\r\n Align := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLPanel.ControlSetAnchors(Value: TAnchors);\r\nbegin\r\n Anchors := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLPanel.ControlSetAutoSize(Value: Boolean);\r\nbegin\r\n AutoSize := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLPanel.ControlSetBevelInner(Value: TBevelCut);\r\nbegin\r\n BevelInner:= Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLPanel.ControlSetBevelKind(Value: TBevelKind);\r\nbegin\r\n BevelKind := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLPanel.ControlSetBevelOuter(Value: TBevelCut);\r\nbegin\r\n BevelOuter:= Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLPanel.ControlSetBorderStyle(Value: TBorderStyle);\r\nbegin\r\n BorderStyle:= Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLPanel.ControlSetBorderWidth(Value: Integer);\r\nbegin\r\n BorderWidth := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLPanel.ControlSetColor(Value: TColor);\r\nbegin\r\n Color := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLPanel.ControlSetParentColor(Value: Boolean);\r\nbegin\r\n ParentColor := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLPanel.ControlSetAlignment(Value: TAlignment);\r\nbegin\r\n Alignment := Value;\r\nend;\r\n\r\n//=== { TJvDynControlJVCLImage } =============================================\r\n\r\nprocedure TJvDynControlJVCLImage.ControlSetDefaultProperties;\r\nbegin\r\nend;\r\n\r\nprocedure TJvDynControlJVCLImage.ControlSetTabOrder(Value: Integer);\r\nbegin\r\n// TabOrder := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLImage.ControlSetOnEnter(Value: TNotifyEvent);\r\nbegin\r\n// OnEnter := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLImage.ControlSetOnExit(Value: TNotifyEvent);\r\nbegin\r\n// OnExit := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLImage.ControlSetOnClick(Value: TNotifyEvent);\r\nbegin\r\n OnClick := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLImage.ControlSetHint(const Value: string);\r\nbegin\r\n Hint := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLImage.ControlSetAutoSize(Value: Boolean);\r\nbegin\r\n AutoSize := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLImage.ControlSetIncrementalDisplay(Value: Boolean);\r\nbegin\r\n IncrementalDisplay := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLImage.ControlSetCenter(Value: Boolean);\r\nbegin\r\n Center := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLImage.ControlSetProportional(Value: Boolean);\r\nbegin\r\n Proportional := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLImage.ControlSetStretch(Value: Boolean);\r\nbegin\r\n Stretch := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLImage.ControlSetTransparent(Value: Boolean);\r\nbegin\r\n Transparent := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLImage.ControlSetPicture(Value: TPicture);\r\nbegin\r\n Picture.Assign(Value);\r\nend;\r\n\r\nprocedure TJvDynControlJVCLImage.ControlSetGraphic(Value: TGraphic);\r\nbegin\r\n Picture.Assign(Value);\r\nend;\r\n\r\nfunction TJvDynControlJVCLImage.ControlGetPicture: TPicture;\r\nbegin\r\n Result := Picture;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLImage.ControlSetAnchors(Value: TAnchors);\r\nbegin\r\n Anchors := Value;\r\nend;\r\n\r\n//=== { TJvDynControlJVCLScrollBox } =========================================\r\n\r\nprocedure TJvDynControlJVCLScrollBox.ControlSetAnchors(Value: TAnchors);\r\nbegin\r\n Anchors := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLScrollBox.ControlSetDefaultProperties;\r\nbegin\r\nend;\r\n\r\nprocedure TJvDynControlJVCLScrollBox.ControlSetCaption(const Value: string);\r\nbegin\r\n if Caption <> Value then\r\n Caption := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLScrollBox.ControlSetTabOrder(Value: Integer);\r\nbegin\r\n TabOrder := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLScrollBox.ControlSetOnEnter(Value: TNotifyEvent);\r\nbegin\r\n OnEnter := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLScrollBox.ControlSetOnExit(Value: TNotifyEvent);\r\nbegin\r\n OnExit := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLScrollBox.ControlSetOnClick(Value: TNotifyEvent);\r\nbegin\r\nend;\r\n\r\n//=== { TJvDynControlJVCLLabel } =============================================\r\n\r\nprocedure TJvDynControlJVCLLabel.ControlSetAnchors(Value: TAnchors);\r\nbegin\r\n Anchors := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLLabel.ControlSetDefaultProperties;\r\nbegin\r\nend;\r\n\r\nprocedure TJvDynControlJVCLLabel.ControlSetCaption(const Value: string);\r\nbegin\r\n if Caption <> Value then\r\n Caption := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLLabel.ControlSetTabOrder(Value: Integer);\r\nbegin\r\nend;\r\n\r\nprocedure TJvDynControlJVCLLabel.ControlSetOnEnter(Value: TNotifyEvent);\r\nbegin\r\nend;\r\n\r\nprocedure TJvDynControlJVCLLabel.ControlSetOnExit(Value: TNotifyEvent);\r\nbegin\r\nend;\r\n\r\nprocedure TJvDynControlJVCLLabel.ControlSetOnClick(Value: TNotifyEvent);\r\nbegin\r\nend;\r\n\r\nprocedure TJvDynControlJVCLLabel.ControlSetHint(const Value: string);\r\nbegin\r\n Hint := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLLabel.ControlSetFocusControl(Value: TWinControl);\r\nbegin\r\n FocusControl := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLLabel.ControlSetWordWrap(Value: Boolean);\r\nbegin\r\n WordWrap := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLLabel.ControlSetAlign(Value: TAlign);\r\nbegin\r\n Align := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLLabel.ControlSetAutoSize(Value: Boolean);\r\nbegin\r\n AutoSize := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLLabel.ControlSetColor(Value: TColor);\r\nbegin\r\n Color := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLLabel.ControlSetParentColor(Value: Boolean);\r\nbegin\r\n ParentColor := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLLabel.ControlSetAlignment(Value: TAlignment);\r\nbegin\r\n Alignment := Value;\r\nend;\r\n\r\n//=== { TJvDynControlJVCLScrollBox } ===========================================\r\n\r\nfunction TJvDynControlJVCLScrollBox.ControlGetCaption: string;\r\nbegin\r\n Result := Caption;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLScrollBox.ControlSetHint(const Value: string);\r\nbegin\r\n Hint := Value;\r\nend;\r\n\r\n//=== { TJvDynControlJVCLLabel } ===========================================\r\n\r\nfunction TJvDynControlJVCLLabel.ControlGetCaption: string;\r\nbegin\r\n Result := Caption;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLLabel.ControlSetFont(Value: TFont);\r\nbegin\r\n Font.Assign(Value);\r\nend;\r\n\r\nfunction TJvDynControlJVCLLabel.ControlGetFont: TFont;\r\nbegin\r\n Result := Font;\r\nend;\r\n\r\n//=== { TJvDynControlJVCLStaticText } ===========================================\r\n\r\nfunction TJvDynControlJVCLStaticText.ControlGetCaption: string;\r\nbegin\r\n Result := Caption;\r\nend;\r\n\r\n//=== { TJvDynControlJVCLStaticText } ========================================\r\n\r\nprocedure TJvDynControlJVCLStaticText.ControlSetAnchors(Value: TAnchors);\r\nbegin\r\n Anchors := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLStaticText.ControlSetDefaultProperties;\r\nbegin\r\nend;\r\n\r\nprocedure TJvDynControlJVCLStaticText.ControlSetCaption(const Value: string);\r\nbegin\r\n if Caption <> Value then\r\n Caption := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLStaticText.ControlSetTabOrder(Value: Integer);\r\nbegin\r\nend;\r\n\r\nprocedure TJvDynControlJVCLStaticText.ControlSetOnEnter(Value: TNotifyEvent);\r\nbegin\r\nend;\r\n\r\nprocedure TJvDynControlJVCLStaticText.ControlSetOnExit(Value: TNotifyEvent);\r\nbegin\r\nend;\r\n\r\nprocedure TJvDynControlJVCLStaticText.ControlSetOnClick(Value: TNotifyEvent);\r\nbegin\r\nend;\r\n\r\nprocedure TJvDynControlJVCLStaticText.ControlSetHint(const Value: string);\r\nbegin\r\n Hint := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLStaticText.ControlSetAlign(Value: TAlign);\r\nbegin\r\n Align := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLStaticText.ControlSetAutoSize(Value: Boolean);\r\nbegin\r\n AutoSize := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLStaticText.ControlSetColor(Value: TColor);\r\nbegin\r\n Color := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLStaticText.ControlSetParentColor(Value: Boolean);\r\nbegin\r\n ParentColor := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLStaticText.ControlSetAlignment(Value: TAlignment);\r\nbegin\r\n Alignment := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLStaticText.ControlSetFont(Value: TFont);\r\nbegin\r\n Font.Assign(Value);\r\nend;\r\n\r\nfunction TJvDynControlJVCLStaticText.ControlGetFont: TFont;\r\nbegin\r\n Result := Font;\r\nend;\r\n\r\n//=== { TJvDynControlJVCLButton } ===========================================\r\n\r\nfunction TJvDynControlJVCLButton.ControlGetCaption: string;\r\nbegin\r\n Result := Caption;\r\nend;\r\n\r\n//=== { TJvDynControlJVCLButton } ============================================\r\n\r\nprocedure TJvDynControlJVCLButton.ControlSetDefaultProperties;\r\nbegin\r\nend;\r\n\r\nprocedure TJvDynControlJVCLButton.ControlSetCaption(const Value: string);\r\nbegin\r\n if Caption <> Value then\r\n Caption := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLButton.ControlSetTabOrder(Value: Integer);\r\nbegin\r\nend;\r\n\r\nprocedure TJvDynControlJVCLButton.ControlSetOnEnter(Value: TNotifyEvent);\r\nbegin\r\nend;\r\n\r\nprocedure TJvDynControlJVCLButton.ControlSetOnExit(Value: TNotifyEvent);\r\nbegin\r\nend;\r\n\r\nprocedure TJvDynControlJVCLButton.ControlSetOnClick(Value: TNotifyEvent);\r\nbegin\r\n OnClick := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLButton.ControlSetHint(const Value: string);\r\nbegin\r\n Hint := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLButton.ControlSetGlyph(Value: TBitmap);\r\nbegin\r\n Glyph.Assign(Value);\r\nend;\r\n\r\nprocedure TJvDynControlJVCLButton.ControlSetNumGlyphs(Value: Integer);\r\nbegin\r\n NumGlyphs := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLButton.ControlSetLayout(Value: TButtonLayout);\r\nbegin\r\n Layout := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLButton.ControlSetDefault(Value: Boolean);\r\nbegin\r\n Default := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLButton.ControlSetCancel(Value: Boolean);\r\nbegin\r\n Cancel := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLButton.ControlSetAction(Value: TCustomAction);\r\nbegin\r\n Action := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLButton.ControlSetAnchors(Value: TAnchors);\r\nbegin\r\n Anchors := Value;\r\nend;\r\n\r\n//=== { TJvDynControlJVCLRadioButton } ===========================================\r\n\r\nfunction TJvDynControlJVCLRadioButton.ControlGetCaption: string;\r\nbegin\r\n Result := Caption;\r\nend;\r\n\r\n//=== { TJvDynControlJVCLRadioButton } =======================================\r\n\r\nprocedure TJvDynControlJVCLRadioButton.ControlSetDefaultProperties;\r\nbegin\r\nend;\r\n\r\nprocedure TJvDynControlJVCLRadioButton.ControlSetCaption(const Value: string);\r\nbegin\r\n if Caption <> Value then\r\n Caption := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLRadioButton.ControlSetTabOrder(Value: Integer);\r\nbegin\r\n TabOrder := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLRadioButton.ControlSetOnEnter(Value: TNotifyEvent);\r\nbegin\r\n OnEnter := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLRadioButton.ControlSetOnExit(Value: TNotifyEvent);\r\nbegin\r\n OnExit := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLRadioButton.ControlSetOnClick(Value: TNotifyEvent);\r\nbegin\r\n OnClick := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLRadioButton.ControlSetHint(const Value: string);\r\nbegin\r\n Hint := Value;\r\nend;\r\n\r\n// IJvDynControlData\r\nprocedure TJvDynControlJVCLRadioButton.ControlSetOnChange(Value: TNotifyEvent);\r\nbegin\r\n OnClick := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLRadioButton.ControlSetValue(Value: Variant);\r\nbegin\r\n Checked := JvDynControlVariantToBoolean(Value);\r\nend;\r\n\r\nfunction TJvDynControlJVCLRadioButton.ControlGetValue: Variant;\r\nbegin\r\n Result := Checked;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLRadioButton.ControlSetAnchors(Value: TAnchors);\r\nbegin\r\n Anchors := Value;\r\nend;\r\n\r\n//=== { TJvDynControlJVCLTreeView } ==========================================\r\n\r\nprocedure TJvDynControlJVCLTreeView.ControlSetDefaultProperties;\r\nbegin\r\nend;\r\n\r\nprocedure TJvDynControlJVCLTreeView.ControlSetTabOrder(Value: Integer);\r\nbegin\r\n TabOrder := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLTreeView.ControlSetOnEnter(Value: TNotifyEvent);\r\nbegin\r\n OnEnter := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLTreeView.ControlSetOnExit(Value: TNotifyEvent);\r\nbegin\r\n OnExit := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLTreeView.ControlSetOnClick(Value: TNotifyEvent);\r\nbegin\r\n OnClick := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLTreeView.ControlSetHint(const Value: string);\r\nbegin\r\n Hint := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLTreeView.ControlSetReadOnly(Value: Boolean);\r\nbegin\r\n ReadOnly := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLTreeView.ControlSetAutoExpand(Value: Boolean);\r\nbegin\r\n AutoExpand := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLTreeView.ControlSetHotTrack(Value: Boolean);\r\nbegin\r\n HotTrack := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLTreeView.ControlSetShowHint(Value: Boolean);\r\nbegin\r\n ShowHint := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLTreeView.ControlSetShowLines(Value: Boolean);\r\nbegin\r\n ShowLines := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLTreeView.ControlSetShowRoot(Value: Boolean);\r\nbegin\r\n ShowRoot := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLTreeView.ControlSetToolTips(Value: Boolean);\r\nbegin\r\n ToolTips := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLTreeView.ControlSetItems(Value: TTreeNodes);\r\nbegin\r\n Items.Assign(Value);\r\nend;\r\n\r\nfunction TJvDynControlJVCLTreeView.ControlGetItems: TTreeNodes;\r\nbegin\r\n Result := Items;\r\nend;\r\n\r\nfunction TJvDynControlJVCLTreeView.ControlGetOnMouseDown: TMouseEvent;\r\nbegin\r\n Result := OnMouseDown;\r\nend;\r\n\r\nfunction TJvDynControlJVCLTreeView.ControlGetOnMouseEnter: TNotifyEvent;\r\nbegin\r\n {$IFDEF DELPHI2007_UP}\r\n Result := OnMouseEnter;\r\n {$ENDIF DELPHI2007_UP}\r\nend;\r\n\r\nfunction TJvDynControlJVCLTreeView.ControlGetOnMouseLeave: TNotifyEvent;\r\nbegin\r\n {$IFDEF DELPHI2007_UP}\r\n Result := OnMouseLeave;\r\n {$ENDIF DELPHI2007_UP}\r\nend;\r\n\r\nfunction TJvDynControlJVCLTreeView.ControlGetOnMouseMove: TMouseMoveEvent;\r\nbegin\r\n Result := OnMouseMove;\r\nend;\r\n\r\nfunction TJvDynControlJVCLTreeView.ControlGetOnMouseUp: TMouseEvent;\r\nbegin\r\n Result := OnMouseUp;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLTreeView.ControlSetImages(Value: TCustomImageList);\r\nbegin\r\n Images.Assign(Value);\r\nend;\r\n\r\nprocedure TJvDynControlJVCLTreeView.ControlSetStateImages(Value: TCustomImageList);\r\nbegin\r\n StateImages.Assign(Value);\r\nend;\r\n\r\nfunction TJvDynControlJVCLTreeView.ControlGetSelected: TTreeNode;\r\nbegin\r\n Result := Selected;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLTreeView.ControlSetAnchors(Value: TAnchors);\r\nbegin\r\n Anchors := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLTreeView.ControlSetOnChange(Value: TTVChangedEvent);\r\nbegin\r\n OnChange := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLTreeView.ControlSetOnChanging(Value:\r\n TTVChangingEvent);\r\nbegin\r\n OnChanging := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLTreeView.ControlSetSortType(Value: TSortType);\r\nbegin\r\n SortType := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLTreeView.ControlSetOnDblClick(Value: TNotifyEvent);\r\nbegin\r\n OnDblClick := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLTreeView.ControlSetOnMouseDown(const Value: TMouseEvent);\r\nbegin\r\n OnMouseDown := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLTreeView.ControlSetOnMouseEnter(const Value: TNotifyEvent);\r\nbegin\r\n {$IFDEF DELPHI2007_UP}\r\n OnMouseEnter := Value;\r\n {$ENDIF DELPHI2007_UP}\r\nend;\r\n\r\nprocedure TJvDynControlJVCLTreeView.ControlSetOnMouseLeave(const Value: TNotifyEvent);\r\nbegin\r\n {$IFDEF DELPHI2007_UP}\r\n OnMouseEnter := Value;\r\n {$ENDIF DELPHI2007_UP}\r\nend;\r\n\r\nprocedure TJvDynControlJVCLTreeView.ControlSetOnMouseMove(const Value: TMouseMoveEvent);\r\nbegin\r\n OnMouseMove := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLTreeView.ControlSetOnMouseUp(const Value: TMouseEvent);\r\nbegin\r\n OnMouseUp := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLTreeView.ControlSetSelected(const Value: TTreeNode);\r\nbegin\r\n Selected := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLTreeView.ControlSortItems;\r\nbegin\r\n AlphaSort;\r\nend;\r\n\r\n//=== { TJvDynControlJVCLProgressBar } ===========================================\r\n\r\nfunction TJvDynControlJVCLProgressBar.ControlGetCaption: string;\r\nbegin\r\n Result := Caption;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLProgressBar.ControlSetAlign(Value: TAlign);\r\nbegin\r\n Align := Value;\r\nend;\r\n\r\n//=== { TJvDynControlJVCLProgressbar } =======================================\r\n\r\nprocedure TJvDynControlJVCLProgressbar.ControlSetDefaultProperties;\r\nbegin\r\nend;\r\n\r\nprocedure TJvDynControlJVCLProgressbar.ControlSetCaption(const Value: string);\r\nbegin\r\n if Caption <> Value then\r\n Caption := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLProgressbar.ControlSetTabOrder(Value: Integer);\r\nbegin\r\n TabOrder := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLProgressbar.ControlSetOnEnter(Value: TNotifyEvent);\r\nbegin\r\n OnEnter := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLProgressbar.ControlSetOnExit(Value: TNotifyEvent);\r\nbegin\r\n OnExit := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLProgressbar.ControlSetOnClick(Value: TNotifyEvent);\r\nbegin\r\n OnClick := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLProgressbar.ControlSetHint(const Value: string);\r\nbegin\r\n Hint := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLProgressbar.ControlSetAnchors(Value: TAnchors);\r\nbegin\r\n Anchors := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLProgressBar.ControlSetMarquee(Value: Boolean);\r\nbegin\r\n {$IFDEF DELPHI2009_UP}\r\n if Value then\r\n Style := pbstMarquee\r\n else\r\n Style := pbstNormal;\r\n {$ENDIF DELPHI2009_UP}\r\nend;\r\n\r\nprocedure TJvDynControlJVCLProgressbar.ControlSetMax(Value: Integer);\r\nbegin\r\n Max := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLProgressbar.ControlSetMin(Value: Integer);\r\nbegin\r\n Min := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLProgressbar.ControlSetOrientation(Value: TProgressBarOrientation);\r\nbegin\r\n Orientation:= Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLProgressbar.ControlSetPosition(Value: Integer);\r\nbegin\r\n Position := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLProgressbar.ControlSetSmooth(Value: Boolean);\r\nbegin\r\n Smooth := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLProgressbar.ControlSetStep(Value: Integer);\r\nbegin\r\n Step := Value;\r\nend;\r\n\r\n//=== { TJvDynControlEngineJVCL } ============================================\r\n\r\ntype\r\n TJvDynControlEngineJVCL = class(TJvDynControlEngine)\r\n public\r\n procedure RegisterControls; override;\r\n end;\r\n\r\nfunction DynControlEngineJVCL: TJvDynControlEngine;\r\nbegin\r\n Result := IntDynControlEngineJVCL;\r\nend;\r\n\r\nprocedure SetDynControlEngineJVCLDefault;\r\nbegin\r\n SetDefaultDynControlEngine(IntDynControlEngineJVCL);\r\nend;\r\n\r\nprocedure TJvDynControlEngineJVCL.RegisterControls;\r\nbegin\r\n RegisterControlType(jctLabel, TJvDynControlJVCLLabel);\r\n RegisterControlType(jctStaticText, TJvDynControlJVCLStaticText);\r\n RegisterControlType(jctButton, TJvDynControlJVCLButton);\r\n RegisterControlType(jctRadioButton, TJvDynControlJVCLRadioButton);\r\n RegisterControlType(jctScrollBox, TJvDynControlJVCLScrollBox);\r\n RegisterControlType(jctGroupBox, TJvDynControlJVCLGroupBox);\r\n RegisterControlType(jctPanel, TJvDynControlJVCLPanel);\r\n RegisterControlType(jctImage, TJvDynControlVCLImage);\r\n RegisterControlType(jctCheckBox, TJvDynControlJVCLCheckBox);\r\n RegisterControlType(jctComboBox, TJvDynControlJVCLComboBox);\r\n RegisterControlType(jctListBox, TJvDynControlJVCLListBox);\r\n RegisterControlType(jctCheckListBox, TJvDynControlJVCLCheckListBox);\r\n RegisterControlType(jctCheckComboBox, TJvDynControlJVCLCheckedComboBox);\r\n RegisterControlType(jctRadioGroup, TJvDynControlJVCLRadioGroup);\r\n RegisterControlType(jctDateTimeEdit, TJvDynControlJVCLDateTimeEdit);\r\n RegisterControlType(jctTimeEdit, TJvDynControlJVCLTimeEdit);\r\n RegisterControlType(jctDateEdit, TJvDynControlJVCLDateEdit);\r\n RegisterControlType(jctEdit, TJvDynControlJVCLMaskEdit);\r\n RegisterControlType(jctCalculateEdit, TJvDynControlJVCLCalcEdit);\r\n RegisterControlType(jctSpinEdit, TJvDynControlJVCLSpinEdit);\r\n RegisterControlType(jctDirectoryEdit, TJvDynControlJVCLDirectoryEdit);\r\n RegisterControlType(jctFileNameEdit, TJvDynControlJVCLFileNameEdit);\r\n RegisterControlType(jctMemo, TJvDynControlJVCLMemo);\r\n RegisterControlType(jctRichEdit, TJvDynControlJVCLRichEdit);\r\n RegisterControlType(jctButtonEdit, TJvDynControlJVCLButtonEdit);\r\n RegisterControlType(jctTreeView, TJvDynControlJVCLTreeView);\r\n RegisterControlType(jctProgressbar, TJvDynControlJVCLProgressbar);\r\n RegisterControlType(jctTabControl, TJvDynControlJVCLTabControl);\r\n RegisterControlType(jctPageControl, TJvDynControlJVCLPageControl);\r\n RegisterControlType(jctColorComboBox, TJvDynControlVCLColorComboBox);\r\nend;\r\n\r\nprocedure TJvDynControlJVCLTabControl.ControlCreateTab(const AName: string);\r\nbegin\r\n Tabs.Add(AName);\r\nend;\r\n\r\nfunction TJvDynControlJVCLTabControl.ControlGetTabIndex: Integer;\r\nbegin\r\n Result := TabIndex;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLTabControl.ControlSetAnchors(Value: TAnchors);\r\nbegin\r\n Anchors := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLTabControl.ControlSetMultiLine(Value: Boolean);\r\nbegin\r\n MultiLine := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLTabControl.ControlSetScrollOpposite(Value: Boolean);\r\nbegin\r\n ScrollOpposite := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLTabControl.ControlSetHotTrack(Value: Boolean);\r\nbegin\r\n HotTrack := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLTabControl.ControlSetRaggedRight(Value: Boolean);\r\nbegin\r\n RaggedRight := Value;\r\nend;\r\n\r\n//=== { TJvDynControlJVCLPageControl } =======================================\r\n\r\nprocedure TJvDynControlJVCLPageControl.ControlSetDefaultProperties;\r\nbegin\r\nend;\r\n\r\nprocedure TJvDynControlJVCLPageControl.ControlSetTabOrder(Value: Integer);\r\nbegin\r\n TabOrder := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLPageControl.ControlSetOnEnter(Value: TNotifyEvent);\r\nbegin\r\n OnEnter := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLPageControl.ControlSetOnExit(Value: TNotifyEvent);\r\nbegin\r\n OnExit := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLPageControl.ControlSetOnClick(Value: TNotifyEvent);\r\nbegin\r\n OnClick := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLPageControl.ControlSetHint(const Value: string);\r\nbegin\r\n Hint := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLPageControl.ControlSetAnchors(Value: TAnchors);\r\nbegin\r\n Anchors := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLPageControl.ControlCreateTab(const AName: string);\r\nvar\r\n TabSheet: TTabSheet;\r\nbegin\r\n TabSheet := TTabSheet.Create(Self);\r\n TabSheet.Caption := AName;\r\n TabSheet.PageControl := Self;\r\n TabSheet.Parent := Self;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLPageControl.ControlSetOnChangeTab(OnChangeEvent: TNotifyEvent);\r\nbegin\r\n OnChange := OnChangeEvent;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLPageControl.ControlSetOnChangingTab(OnChangingEvent: TTabChangingEvent);\r\nbegin\r\n OnChanging := OnChangingEvent;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLPageControl.ControlSetTabIndex(Index: Integer);\r\nbegin\r\n TabIndex := Index;\r\nend;\r\n\r\nfunction TJvDynControlJVCLPageControl.ControlGetTabIndex: Integer;\r\nbegin\r\n Result := TabIndex;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLPageControl.ControlSetMultiLine(Value: Boolean);\r\nbegin\r\n MultiLine := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLPageControl.ControlSetScrollOpposite(Value: Boolean);\r\nbegin\r\n ScrollOpposite := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLPageControl.ControlSetHotTrack(Value: Boolean);\r\nbegin\r\n HotTrack := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLPageControl.ControlSetRaggedRight(Value: Boolean);\r\nbegin\r\n RaggedRight := Value;\r\nend;\r\n\r\nfunction TJvDynControlJVCLPageControl.ControlGetPage(const PageName: string): TWinControl;\r\nvar\r\n i: Integer;\r\nbegin\r\n i := Tabs.IndexOf(PageName);\r\n if (i >= 0) and (i < PageCount) then\r\n Result := TWinControl(Pages[i])\r\n else\r\n Result := nil;\r\nend;\r\n\r\n//=== { TJvDynControlJVCLTabControl } ========================================\r\n\r\nprocedure TJvDynControlJVCLTabControl.ControlSetDefaultProperties;\r\nbegin\r\nend;\r\n\r\nprocedure TJvDynControlJVCLTabControl.ControlSetHint(const Value: string);\r\nbegin\r\n Hint := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLTabControl.ControlSetOnChangeTab(OnChangeEvent: TNotifyEvent);\r\nbegin\r\n OnChange := OnChangeEvent;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLTabControl.ControlSetOnChangingTab(OnChangingEvent: TTabChangingEvent);\r\nbegin\r\n OnChanging := OnChangingEvent;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLTabControl.ControlSetOnClick(Value: TNotifyEvent);\r\nbegin\r\n OnClick := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLTabControl.ControlSetOnEnter(Value: TNotifyEvent);\r\nbegin\r\n OnEnter := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLTabControl.ControlSetOnExit(Value: TNotifyEvent);\r\nbegin\r\n OnExit := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLTabControl.ControlSetTabIndex(Index: Integer);\r\nbegin\r\n TabIndex := Index;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLTabControl.ControlSetTabOrder(Value: Integer);\r\nbegin\r\n TabOrder := Value;\r\nend;\r\n\r\n//=== { TJvDynControlJVCLCheckedComboBox } ======================================\r\n\r\nprocedure TJvDynControlJVCLCheckedComboBox.ControlSetDefaultProperties;\r\nbegin\r\nend;\r\n\r\nprocedure TJvDynControlJVCLCheckedComboBox.ControlSetTabOrder(Value: Integer);\r\nbegin\r\n TabOrder := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLCheckedComboBox.ControlSetOnEnter(Value: TNotifyEvent);\r\nbegin\r\n OnEnter := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLCheckedComboBox.ControlSetOnExit(Value: TNotifyEvent);\r\nbegin\r\n OnExit := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLCheckedComboBox.ControlSetOnChange(Value: TNotifyEvent);\r\nbegin\r\n// OnChange := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLCheckedComboBox.ControlSetOnClick(Value: TNotifyEvent);\r\nbegin\r\n OnClick := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLCheckedComboBox.ControlSetHint(const Value: string);\r\nbegin\r\n Hint := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLCheckedComboBox.ControlSetValue(Value: Variant);\r\nbegin\r\n Text := VarToStr(Value);\r\nend;\r\n\r\nfunction TJvDynControlJVCLCheckedComboBox.ControlGetValue: Variant;\r\nbegin\r\n Result := Text;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLCheckedComboBox.ControlSetSorted(Value: Boolean);\r\nbegin\r\n Sorted := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLCheckedComboBox.ControlSetItems(Value: TStrings);\r\nbegin\r\n Items.Assign(Value);\r\nend;\r\n\r\nfunction TJvDynControlJVCLCheckedComboBox.ControlGetItems: TStrings;\r\nbegin\r\n Result := Items;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLCheckedComboBox.ControlSetOnDblClick(Value: TNotifyEvent);\r\nbegin\r\n OnDblClick := Value;\r\nend;\r\n\r\nfunction TJvDynControlJVCLCheckedComboBox.ControlGetDelimiter: string;\r\nbegin\r\n Result := Delimiter;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLCheckedComboBox.ControlSetAnchors(Value: TAnchors);\r\nbegin\r\n Anchors := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLCheckedComboBox.ControlSetDelimiter(Value: string);\r\nbegin\r\n if Value <> '' then\r\n Delimiter:= Value[1]\r\n else\r\n Delimiter := chr(0);\r\nend;\r\n\r\ninitialization\r\n {$IFDEF UNITVERSIONING}\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n {$ENDIF UNITVERSIONING}\r\n IntDynControlEngineJVCL := TJvDynControlEngineJVCL.Create;\r\n SetDefaultDynControlEngine(IntDynControlEngineJVCL);\r\n\r\nfinalization\r\n FreeAndNil(IntDynControlEngineJVCL);\r\n {$IFDEF UNITVERSIONING}\r\n UnregisterUnitVersion(HInstance);\r\n {$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvDynControlEngineJVCLDB.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Initial Developer of the Original Code is Jens Fudickar [jens dott fudickar att oratool dott de]\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\nJens Fudickar [jens dott fudickar att oratool dott de]\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvDynControlEngineJVCLDB.pas 13415 2012-09-10 09:51:54Z obones $\r\n\r\nunit JvDynControlEngineJVCLDB;\r\n\r\n{$I jvcl.inc}\r\n{$I crossplatform.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Classes, ExtCtrls, ExtDlgs, Graphics, Buttons, Controls, Dialogs, FileCtrl,\r\n Forms, DBCtrls, DB, StdCtrls, ComCtrls,\r\n {$IFDEF HAS_UNIT_SYSTEM_UITYPES}\r\n System.UITypes,\r\n {$ENDIF HAS_UNIT_SYSTEM_UITYPES}\r\n JvDBGrid, JvDBControls, JvDBDateTimePicker, JvDBCombobox, JvDBImage,\r\n JvDynControlEngine, JvDynControlEngineDB, JvDynControlEngineIntf,\r\n JvDynControlEngineDBIntf;\r\n\r\ntype\r\n TJvDynControlJVCLDBEdit = class(TJvDBMaskEdit, IUnknown,\r\n IJvDynControl, IJvDynControlData, IJvDynControlReadOnly, IJvDynControlEdit,\r\n IJvDynControlDatabase)\r\n public\r\n procedure ControlSetDefaultProperties;\r\n procedure ControlSetReadOnly(Value: Boolean);\r\n procedure ControlSetCaption(const Value: string);\r\n procedure ControlSetTabOrder(Value: Integer);\r\n procedure ControlSetHint(const Value: string);\r\n\r\n procedure ControlSetOnEnter(Value: TNotifyEvent);\r\n procedure ControlSetOnExit(Value: TNotifyEvent);\r\n procedure ControlSetOnChange(Value: TNotifyEvent);\r\n procedure ControlSetOnClick(Value: TNotifyEvent);\r\n\r\n procedure ControlSetValue(Value: Variant);\r\n function ControlGetValue: Variant;\r\n\r\n //IJvDynControlEdit\r\n procedure ControlSetPasswordChar(Value: Char);\r\n procedure ControlSetEditMask(const Value: string);\r\n\r\n //IJvDynControlDatabase\r\n procedure ControlSetDataSource(Value: TDataSource);\r\n function ControlGetDataSource: TDataSource;\r\n procedure ControlSetDataField(const Value: string);\r\n function ControlGetDataField: string;\r\n procedure ControlSetAnchors(Value : TAnchors);\r\n end;\r\n\r\n TJvDynControlJVCLDBButtonEdit = class(TPanel, IUnknown,\r\n IJvDynControl, IJvDynControlData, IJvDynControlReadOnly, IJvDynControlEdit,\r\n IJvDynControlButtonEdit, IJvDynControlButton, IJvDynControlDatabase)\r\n private\r\n FEditControl: TJvDBMaskEdit;\r\n FButton: TBitBtn;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n\r\n procedure ControlSetDefaultProperties;\r\n procedure ControlSetReadOnly(Value: Boolean);\r\n procedure ControlSetCaption(const Value: string);\r\n procedure ControlSetTabOrder(Value: Integer);\r\n procedure ControlSetHint(const Value: string);\r\n\r\n procedure ControlSetOnEnter(Value: TNotifyEvent);\r\n procedure ControlSetOnExit(Value: TNotifyEvent);\r\n procedure ControlSetOnChange(Value: TNotifyEvent);\r\n procedure ControlSetOnClick(Value: TNotifyEvent);\r\n\r\n procedure ControlSetValue(Value: Variant);\r\n function ControlGetValue: Variant;\r\n\r\n //IJvDynControlEdit\r\n procedure ControlSetPasswordChar(Value: Char);\r\n procedure ControlSetEditMask(const Value: string);\r\n\r\n //IJvDynControlButtonEdit\r\n procedure ControlSetOnButtonClick(Value: TNotifyEvent);\r\n procedure ControlSetButtonCaption(const Value: string);\r\n\r\n //IJvDynControlButton\r\n procedure ControlSetGlyph(Value: TBitmap);\r\n procedure ControlSetNumGlyphs(Value: Integer);\r\n procedure ControlSetLayout(Value: TButtonLayout);\r\n procedure ControlSetDefault(Value: Boolean);\r\n procedure ControlSetCancel(Value: Boolean);\r\n\r\n //IJvDynControlDatabase\r\n procedure ControlSetDataSource(Value: TDataSource);\r\n function ControlGetDataSource: TDataSource;\r\n procedure ControlSetDataField(const Value: string);\r\n function ControlGetDataField: string;\r\n procedure ControlSetAnchors(Value : TAnchors);\r\n end;\r\n\r\n TJvDynControlJVCLDBFileNameEdit = class(TPanel, IUnknown,\r\n IJvDynControl, IJvDynControlData, IJvDynControlFileName,\r\n IJvDynControlReadOnly, IJvDynControlDatabase)\r\n private\r\n FEditControl: TJvDBMaskEdit;\r\n FButton: TBitBtn;\r\n FInitialDir: string;\r\n FFilterIndex: Integer;\r\n FFilter: string;\r\n FDialogOptions: TOpenOptions;\r\n FDialogKind: TJvDynControlFileNameDialogKind;\r\n FDialogTitle: string;\r\n FDefaultExt: string;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n\r\n procedure DefaultOnButtonClick(Sender: TObject);\r\n\r\n procedure ControlSetDefaultProperties;\r\n procedure ControlSetReadOnly(Value: Boolean);\r\n procedure ControlSetCaption(const Value: string);\r\n procedure ControlSetTabOrder(Value: Integer);\r\n procedure ControlSetHint(const Value: string);\r\n\r\n procedure ControlSetOnEnter(Value: TNotifyEvent);\r\n procedure ControlSetOnExit(Value: TNotifyEvent);\r\n procedure ControlSetOnChange(Value: TNotifyEvent);\r\n procedure ControlSetOnClick(Value: TNotifyEvent);\r\n\r\n procedure ControlSetValue(Value: Variant);\r\n function ControlGetValue: Variant;\r\n\r\n // IJvDynControlFileName\r\n procedure ControlSetInitialDir(const Value: string);\r\n procedure ControlSetDefaultExt(const Value: string);\r\n procedure ControlSetDialogTitle(const Value: string);\r\n procedure ControlSetDialogOptions(Value: TOpenOptions);\r\n procedure ControlSetFilter(const Value: string);\r\n procedure ControlSetFilterIndex(Value: Integer);\r\n procedure ControlSetDialogKind(Value: TJvDynControlFileNameDialogKind);\r\n\r\n //IJvDynControlDatabase\r\n procedure ControlSetDataSource(Value: TDataSource);\r\n function ControlGetDataSource: TDataSource;\r\n procedure ControlSetDataField(const Value: string);\r\n function ControlGetDataField: string;\r\n procedure ControlSetAnchors(Value : TAnchors);\r\n end;\r\n\r\n TJvDynControlJVCLDBDirectoryEdit = class(TPanel, IUnknown,\r\n IJvDynControl, IJvDynControlData, IJvDynControlDirectory,\r\n IJvDynControlReadOnly, IJvDynControlDatabase)\r\n private\r\n FEditControl: TJvDBMaskEdit;\r\n FButton: TBitBtn;\r\n FInitialDir: string;\r\n FDialogOptions: TSelectDirOpts;\r\n FDialogTitle: string;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n\r\n procedure DefaultOnButtonClick(Sender: TObject);\r\n\r\n procedure ControlSetDefaultProperties;\r\n procedure ControlSetReadOnly(Value: Boolean);\r\n procedure ControlSetCaption(const Value: string);\r\n procedure ControlSetTabOrder(Value: Integer);\r\n procedure ControlSetHint(const Value: string);\r\n\r\n procedure ControlSetOnEnter(Value: TNotifyEvent);\r\n procedure ControlSetOnExit(Value: TNotifyEvent);\r\n procedure ControlSetOnChange(Value: TNotifyEvent);\r\n procedure ControlSetOnClick(Value: TNotifyEvent);\r\n\r\n procedure ControlSetValue(Value: Variant);\r\n function ControlGetValue: Variant;\r\n\r\n // IJvDynControlDirectory\r\n procedure ControlSetInitialDir(const Value: string);\r\n procedure ControlSetDialogTitle(const Value: string);\r\n procedure ControlSetDialogOptions(Value: TSelectDirOpts);\r\n\r\n //IJvDynControlDatabase\r\n procedure ControlSetDataSource(Value: TDataSource);\r\n function ControlGetDataSource: TDataSource;\r\n procedure ControlSetDataField(const Value: string);\r\n function ControlGetDataField: string;\r\n procedure ControlSetAnchors(Value : TAnchors);\r\n end;\r\n\r\n TJvDynControlJVCLDBCheckBox = class(TDBCheckBox, IUnknown,\r\n IJvDynControl, IJvDynControlData, IJvDynControlDatabase,\r\n IJvDynControlDBCheckbox)\r\n public\r\n procedure ControlSetDefaultProperties;\r\n procedure ControlSetCaption(const Value: string);\r\n procedure ControlSetTabOrder(Value: Integer);\r\n procedure ControlSetHint(const Value: string);\r\n\r\n procedure ControlSetOnEnter(Value: TNotifyEvent);\r\n procedure ControlSetOnExit(Value: TNotifyEvent);\r\n procedure ControlSetOnChange(Value: TNotifyEvent);\r\n procedure ControlSetOnClick(Value: TNotifyEvent);\r\n\r\n procedure ControlSetValue(Value: Variant);\r\n function ControlGetValue: Variant;\r\n\r\n //IJvDynControlDatabase\r\n procedure ControlSetDataSource(Value: TDataSource);\r\n function ControlGetDataSource: TDataSource;\r\n procedure ControlSetDataField(const Value: string);\r\n function ControlGetDataField: string;\r\n procedure ControlSetAnchors(Value : TAnchors);\r\n\r\n //IJvDynControlDBCheckbox\r\n procedure ControlSetValueChecked(Value: Variant);\r\n procedure ControlSetValueUnChecked(Value: Variant);\r\n end;\r\n\r\n TJvDynControlJVCLDBMemo = class(TDBMemo, IUnknown,\r\n IJvDynControl, IJvDynControlData, IJvDynControlItems, IJvDynControlMemo,\r\n IJvDynControlReadOnly, IJvDynControlDatabase)\r\n public\r\n procedure ControlSetDefaultProperties;\r\n procedure ControlSetReadOnly(Value: Boolean);\r\n procedure ControlSetCaption(const Value: string);\r\n procedure ControlSetTabOrder(Value: Integer);\r\n procedure ControlSetHint(const Value: string);\r\n\r\n procedure ControlSetOnEnter(Value: TNotifyEvent);\r\n procedure ControlSetOnExit(Value: TNotifyEvent);\r\n procedure ControlSetOnChange(Value: TNotifyEvent);\r\n procedure ControlSetOnClick(Value: TNotifyEvent);\r\n\r\n procedure ControlSetValue(Value: Variant);\r\n function ControlGetValue: Variant;\r\n\r\n procedure ControlSetSorted(Value: Boolean);\r\n procedure ControlSetItems(Value: TStrings);\r\n function ControlGetItems: TStrings;\r\n\r\n procedure ControlSetWantTabs(Value: Boolean);\r\n procedure ControlSetWantReturns(Value: Boolean);\r\n procedure ControlSetWordWrap(Value: Boolean);\r\n procedure ControlSetScrollBars(Value: TScrollStyle);\r\n\r\n //IJvDynControlDatabase\r\n procedure ControlSetDataSource(Value: TDataSource);\r\n function ControlGetDataSource: TDataSource;\r\n procedure ControlSetDataField(const Value: string);\r\n function ControlGetDataField: string;\r\n procedure ControlSetAnchors(Value : TAnchors);\r\n end;\r\n\r\n TJvDynControlJVCLDBDateEdit = class(TJvDBDateTimePicker, IUnknown,\r\n IJvDynControl, IJvDynControlData, IJvDynControlDate, IJvDynControlDatabase)\r\n public\r\n procedure ControlSetDefaultProperties;\r\n\r\n procedure ControlSetCaption(const Value: string);\r\n procedure ControlSetTabOrder(Value: Integer);\r\n procedure ControlSetHint(const Value: string);\r\n\r\n procedure ControlSetOnEnter(Value: TNotifyEvent);\r\n procedure ControlSetOnExit(Value: TNotifyEvent);\r\n procedure ControlSetOnChange(Value: TNotifyEvent);\r\n procedure ControlSetOnClick(Value: TNotifyEvent);\r\n\r\n procedure ControlSetValue(Value: Variant);\r\n function ControlGetValue: Variant;\r\n\r\n // IJvDynControlDate\r\n procedure ControlSetMinDate(Value: TDateTime);\r\n procedure ControlSetMaxDate(Value: TDateTime);\r\n procedure ControlSetFormat(const Value: string);\r\n\r\n //IJvDynControlDatabase\r\n procedure ControlSetDataSource(Value: TDataSource);\r\n function ControlGetDataSource: TDataSource;\r\n procedure ControlSetDataField(const Value: string);\r\n function ControlGetDataField: string;\r\n procedure ControlSetAnchors(Value : TAnchors);\r\n end;\r\n\r\n TJvDynControlJVCLDBTimeEdit = class(TJvDBDateTimePicker, IUnknown,\r\n IJvDynControl, IJvDynControlData, IJvDynControlTime, IJvDynControlDatabase)\r\n public\r\n procedure ControlSetDefaultProperties;\r\n\r\n procedure ControlSetCaption(const Value: string);\r\n procedure ControlSetTabOrder(Value: Integer);\r\n procedure ControlSetHint(const Value: string);\r\n\r\n procedure ControlSetOnEnter(Value: TNotifyEvent);\r\n procedure ControlSetOnExit(Value: TNotifyEvent);\r\n procedure ControlSetOnChange(Value: TNotifyEvent);\r\n procedure ControlSetOnClick(Value: TNotifyEvent);\r\n\r\n procedure ControlSetValue(Value: Variant);\r\n function ControlGetValue: Variant;\r\n\r\n procedure ControlSetFormat(const Value: string);\r\n\r\n //IJvDynControlDatabase\r\n procedure ControlSetDataSource(Value: TDataSource);\r\n function ControlGetDataSource: TDataSource;\r\n procedure ControlSetDataField(const Value: string);\r\n function ControlGetDataField: string;\r\n procedure ControlSetAnchors(Value : TAnchors);\r\n end;\r\n\r\n TJvDynControlJVCLDBRadioGroup = class(TDBRadioGroup, IUnknown,\r\n IJvDynControl, IJvDynControlData, IJvDynControlItems,\r\n IJvDynControlRadioGroup, IJvDynControlDatabase)\r\n public\r\n procedure ControlSetDefaultProperties;\r\n procedure ControlSetCaption(const Value: string);\r\n procedure ControlSetTabOrder(Value: Integer);\r\n procedure ControlSetHint(const Value: string);\r\n\r\n procedure ControlSetOnEnter(Value: TNotifyEvent);\r\n procedure ControlSetOnExit(Value: TNotifyEvent);\r\n procedure ControlSetOnChange(Value: TNotifyEvent);\r\n procedure ControlSetOnClick(Value: TNotifyEvent);\r\n\r\n procedure ControlSetValue(Value: Variant);\r\n function ControlGetValue: Variant;\r\n\r\n procedure ControlSetSorted(Value: Boolean);\r\n procedure ControlSetItems(Value: TStrings);\r\n function ControlGetItems: TStrings;\r\n\r\n procedure ControlSetColumns(Value: Integer);\r\n\r\n //IJvDynControlDatabase\r\n procedure ControlSetDataSource(Value: TDataSource);\r\n function ControlGetDataSource: TDataSource;\r\n procedure ControlSetDataField(const Value: string);\r\n function ControlGetDataField: string;\r\n procedure ControlSetAnchors(Value : TAnchors);\r\n end;\r\n\r\n TJvDynControlJVCLDBListBox = class(TDBListBox, IUnknown,\r\n IJvDynControl, IJvDynControlData, IJvDynControlItems, IJvDynControlDblClick,\r\n IJvDynControlDatabase)\r\n public\r\n procedure ControlSetDefaultProperties;\r\n procedure ControlSetCaption(const Value: string);\r\n procedure ControlSetTabOrder(Value: Integer);\r\n procedure ControlSetHint(const Value: string);\r\n\r\n procedure ControlSetOnEnter(Value: TNotifyEvent);\r\n procedure ControlSetOnExit(Value: TNotifyEvent);\r\n procedure ControlSetOnChange(Value: TNotifyEvent);\r\n procedure ControlSetOnClick(Value: TNotifyEvent);\r\n\r\n procedure ControlSetValue(Value: Variant);\r\n function ControlGetValue: Variant;\r\n\r\n procedure ControlSetSorted(Value: Boolean);\r\n procedure ControlSetItems(Value: TStrings);\r\n function ControlGetItems: TStrings;\r\n\r\n procedure ControlSetOnDblClick(Value: TNotifyEvent);\r\n\r\n //IJvDynControlDatabase\r\n procedure ControlSetDataSource(Value: TDataSource);\r\n function ControlGetDataSource: TDataSource;\r\n procedure ControlSetDataField(const Value: string);\r\n function ControlGetDataField: string;\r\n procedure ControlSetAnchors(Value : TAnchors);\r\n end;\r\n\r\n TJvDynControlJVCLDBComboBox = class(TJvDBComboBox, IUnknown,\r\n IJvDynControl, IJvDynControlData, IJvDynControlItems, IJvDynControlComboBox,\r\n IJvDynControlDatabase)\r\n public\r\n procedure ControlSetDefaultProperties;\r\n procedure ControlSetCaption(const Value: string);\r\n procedure ControlSetTabOrder(Value: Integer);\r\n procedure ControlSetHint(const Value: string);\r\n\r\n procedure ControlSetOnEnter(Value: TNotifyEvent);\r\n procedure ControlSetOnExit(Value: TNotifyEvent);\r\n procedure ControlSetOnChange(Value: TNotifyEvent);\r\n procedure ControlSetOnClick(Value: TNotifyEvent);\r\n\r\n procedure ControlSetValue(Value: Variant);\r\n function ControlGetValue: Variant;\r\n\r\n procedure ControlSetSorted(Value: Boolean);\r\n procedure ControlSetItems(Value: TStrings);\r\n function ControlGetItems: TStrings;\r\n\r\n procedure ControlSetNewEntriesAllowed(Value: Boolean);\r\n\r\n //IJvDynControlDatabase\r\n procedure ControlSetDataSource(Value: TDataSource);\r\n function ControlGetDataSource: TDataSource;\r\n procedure ControlSetDataField(const Value: string);\r\n function ControlGetDataField: string;\r\n procedure ControlSetAnchors(Value : TAnchors);\r\n end;\r\n\r\n TJvDynControlJVCLDBImage = class(TJvDBImage, IUnknown,\r\n IJvDynControl, IJvDynControlImage, IJvDynControlDatabase)\r\n public\r\n procedure ControlSetDefaultProperties;\r\n procedure ControlSetCaption(const Value: string);\r\n procedure ControlSetTabOrder(Value: Integer);\r\n procedure ControlSetHint(const Value: string);\r\n\r\n procedure ControlSetOnEnter(Value: TNotifyEvent);\r\n procedure ControlSetOnExit(Value: TNotifyEvent);\r\n procedure ControlSetOnClick(Value: TNotifyEvent);\r\n\r\n procedure ControlSetAutoSize(Value: Boolean);\r\n procedure ControlSetIncrementalDisplay(Value: Boolean);\r\n procedure ControlSetCenter(Value: Boolean);\r\n procedure ControlSetProportional(Value: Boolean);\r\n procedure ControlSetStretch(Value: Boolean);\r\n procedure ControlSetTransparent(Value: Boolean);\r\n procedure ControlSetPicture(Value: TPicture);\r\n procedure ControlSetGraphic(Value: TGraphic);\r\n function ControlGetPicture: TPicture;\r\n\r\n //IJvDynControlDatabase\r\n procedure ControlSetDataSource(Value: TDataSource);\r\n function ControlGetDataSource: TDataSource;\r\n procedure ControlSetDataField(const Value: string);\r\n function ControlGetDataField: string;\r\n procedure ControlSetAnchors(Value : TAnchors);\r\n end;\r\n\r\n TJvDynControlJVCLDBText = class(TDBText, IUnknown,\r\n IJvDynControl, IJvDynControlDatabase)\r\n public\r\n procedure ControlSetDefaultProperties;\r\n procedure ControlSetCaption(const Value: string);\r\n procedure ControlSetTabOrder(Value: Integer);\r\n procedure ControlSetHint(const Value: string);\r\n\r\n procedure ControlSetOnEnter(Value: TNotifyEvent);\r\n procedure ControlSetOnExit(Value: TNotifyEvent);\r\n procedure ControlSetOnClick(Value: TNotifyEvent);\r\n\r\n //IJvDynControlDatabase\r\n procedure ControlSetDataSource(Value: TDataSource);\r\n function ControlGetDataSource: TDataSource;\r\n procedure ControlSetDataField(const Value: string);\r\n function ControlGetDataField: string;\r\n procedure ControlSetAnchors(Value : TAnchors);\r\n end;\r\n\r\n\r\n TJvDynControlJVCLDBGrid = class(TJvDBGrid, IUnknown,\r\n IJvDynControl, IJvDynControlDatabase)\r\n public\r\n procedure ControlSetDefaultProperties;\r\n procedure ControlSetCaption(const Value: string);\r\n procedure ControlSetTabOrder(Value: Integer);\r\n procedure ControlSetHint(const Value: string);\r\n\r\n procedure ControlSetOnEnter(Value: TNotifyEvent);\r\n procedure ControlSetOnExit(Value: TNotifyEvent);\r\n procedure ControlSetOnClick(Value: TNotifyEvent);\r\n\r\n //IJvDynControlDatabase\r\n procedure ControlSetDataSource(Value: TDataSource);\r\n function ControlGetDataSource: TDataSource;\r\n procedure ControlSetDataField(const Value: string);\r\n function ControlGetDataField: string;\r\n procedure ControlSetAnchors(Value : TAnchors);\r\n end;\r\n\r\n TJvDynControlJVCLDBNavigator = class(TDBNavigator, IUnknown,\r\n IJvDynControl, IJvDynControlDatabase)\r\n public\r\n procedure ControlSetDefaultProperties;\r\n procedure ControlSetCaption(const Value: string);\r\n procedure ControlSetTabOrder(Value: Integer);\r\n procedure ControlSetHint(const Value: string);\r\n\r\n procedure ControlSetOnEnter(Value: TNotifyEvent);\r\n procedure ControlSetOnExit(Value: TNotifyEvent);\r\n procedure ControlSetOnClick(Value: TNotifyEvent);\r\n\r\n //IJvDynControlDatabase\r\n procedure ControlSetDataSource(Value: TDataSource);\r\n function ControlGetDataSource: TDataSource;\r\n procedure ControlSetDataField(const Value: string);\r\n function ControlGetDataField: string;\r\n procedure ControlSetAnchors(Value : TAnchors);\r\n end;\r\n\r\nfunction DynControlEngineJVCLDB: TJvDynControlEngineDB;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvDynControlEngineJVCLDB.pas $';\r\n Revision: '$Revision: 13415 $';\r\n Date: '$Date: 2012-09-10 11:51:54 +0200 (lun. 10 sept. 2012) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n Variants, SysUtils,\r\n JvDynControlEngineVCLDB,\r\n JvDynControlEngineTools, JvJCLUtils;\r\n\r\nvar\r\n IntDynControlEngineJVCLDB: TJvDynControlEngineDB = nil;\r\n\r\n//=== { TJvDynControlJVCLDBEdit } ============================================\r\n\r\nprocedure TJvDynControlJVCLDBEdit.ControlSetDefaultProperties;\r\nbegin\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDBEdit.ControlSetReadOnly(Value: Boolean);\r\nbegin\r\n ReadOnly := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDBEdit.ControlSetCaption(const Value: string);\r\nbegin\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDBEdit.ControlSetTabOrder(Value: Integer);\r\nbegin\r\n TabOrder := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDBEdit.ControlSetHint(const Value: string);\r\nbegin\r\n Hint := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDBEdit.ControlSetOnEnter(Value: TNotifyEvent);\r\nbegin\r\n OnEnter := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDBEdit.ControlSetOnExit(Value: TNotifyEvent);\r\nbegin\r\n OnExit := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDBEdit.ControlSetOnChange(Value: TNotifyEvent);\r\nbegin\r\n OnChange := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDBEdit.ControlSetOnClick(Value: TNotifyEvent);\r\nbegin\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDBEdit.ControlSetValue(Value: Variant);\r\nbegin\r\n Text := Value;\r\nend;\r\n\r\nfunction TJvDynControlJVCLDBEdit.ControlGetValue: Variant;\r\nbegin\r\n Result := Text;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDBEdit.ControlSetPasswordChar(Value: Char);\r\nbegin\r\n PasswordChar := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDBEdit.ControlSetEditMask(const Value: string);\r\nbegin\r\n //EditMask := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDBEdit.ControlSetDataSource(Value: TDataSource);\r\nbegin\r\n DataSource := Value;\r\nend;\r\n\r\nfunction TJvDynControlJVCLDBEdit.ControlGetDataSource: TDataSource;\r\nbegin\r\n Result := DataSource;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDBEdit.ControlSetDataField(const Value: string);\r\nbegin\r\n DataField := Value;\r\nend;\r\n\r\n\r\nfunction TJvDynControlJVCLDBEdit.ControlGetDataField: string;\r\nbegin\r\n Result := DataField;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDBEdit.ControlSetAnchors(Value : TAnchors);\r\nbegin\r\n Anchors := Value;\r\nend;\r\n\r\n//=== { TJvDynControlJVCLDBButtonEdit } ======================================\r\n\r\nconstructor TJvDynControlJVCLDBButtonEdit.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FEditControl := TJvDBMaskEdit.Create(AOwner);\r\n FEditControl.Parent := Self;\r\n FButton := TBitBtn.Create(AOwner);\r\n FButton.Parent := Self;\r\n FButton.Align := alRight;\r\n FButton.Caption := '...';\r\n Height := FEditControl.Height;\r\n FButton.Width := Height;\r\n FEditControl.Align := alClient;\r\n BevelInner := bvNone;\r\n BevelOuter := bvNone;\r\nend;\r\n\r\ndestructor TJvDynControlJVCLDBButtonEdit.Destroy;\r\nbegin\r\n FreeAndNil(FEditControl);\r\n FreeAndNil(FButton);\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDBButtonEdit.ControlSetDefaultProperties;\r\nbegin\r\n Self.Caption := ' ';\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDBButtonEdit.ControlSetReadOnly(Value: Boolean);\r\nbegin\r\n FEditControl.ReadOnly := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDBButtonEdit.ControlSetCaption(const Value: string);\r\nbegin\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDBButtonEdit.ControlSetTabOrder(Value: Integer);\r\nbegin\r\n TabOrder := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDBButtonEdit.ControlSetHint(const Value: string);\r\nbegin\r\n Hint := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDBButtonEdit.ControlSetOnEnter(Value: TNotifyEvent);\r\nbegin\r\n OnEnter := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDBButtonEdit.ControlSetOnExit(Value: TNotifyEvent);\r\nbegin\r\n OnExit := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDBButtonEdit.ControlSetOnChange(Value: TNotifyEvent);\r\nbegin\r\n FEditControl.OnChange := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDBButtonEdit.ControlSetOnClick(Value: TNotifyEvent);\r\nbegin\r\n FEditControl.OnClick := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDBButtonEdit.ControlSetValue(Value: Variant);\r\nbegin\r\n FEditControl.Text := Value;\r\nend;\r\n\r\nfunction TJvDynControlJVCLDBButtonEdit.ControlGetValue: Variant;\r\nbegin\r\n Result := FEditControl.Text;\r\nend;\r\n\r\n\r\n\r\nprocedure TJvDynControlJVCLDBButtonEdit.ControlSetPasswordChar(Value: Char);\r\nbegin\r\n FEditControl.PasswordChar := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDBButtonEdit.ControlSetEditMask(const Value: string);\r\nbegin\r\n //FEditControl.EditMask := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDBButtonEdit.ControlSetOnButtonClick(Value: TNotifyEvent);\r\nbegin\r\n FButton.OnClick := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDBButtonEdit.ControlSetButtonCaption(const Value: string);\r\nbegin\r\n FButton.Caption := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDBButtonEdit.ControlSetGlyph(Value: TBitmap);\r\nbegin\r\n FButton.Glyph.Assign(Value);\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDBButtonEdit.ControlSetNumGlyphs(Value: Integer);\r\nbegin\r\n FButton.NumGlyphs := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDBButtonEdit.ControlSetLayout(Value: TButtonLayout);\r\nbegin\r\n FButton.Layout := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDBButtonEdit.ControlSetDefault(Value: Boolean);\r\nbegin\r\n FButton.Default := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDBButtonEdit.ControlSetCancel(Value: Boolean);\r\nbegin\r\n FButton.Cancel := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDBButtonEdit.ControlSetDataSource(Value: TDataSource);\r\nbegin\r\n FEditControl.DataSource := Value;\r\nend;\r\n\r\nfunction TJvDynControlJVCLDBButtonEdit.ControlGetDataSource: TDataSource;\r\nbegin\r\n Result := FEditControl.DataSource;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDBButtonEdit.ControlSetDataField(const Value: string);\r\nbegin\r\n FEditControl.DataField := Value;\r\nend;\r\n\r\nfunction TJvDynControlJVCLDBButtonEdit.ControlGetDataField: string;\r\nbegin\r\n Result := FEditControl.DataField;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDBButtonEdit.ControlSetAnchors(Value : TAnchors);\r\nbegin\r\n Anchors := Value;\r\nend;\r\n\r\n//=== { TJvDynControlJVCLDBFileNameEdit } ====================================\r\n\r\nconstructor TJvDynControlJVCLDBFileNameEdit.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FEditControl := TJvDBMaskEdit.Create(AOwner);\r\n FEditControl.Parent := Self;\r\n FButton := TBitBtn.Create(AOwner);\r\n FButton.Parent := Self;\r\n FButton.Align := alRight;\r\n FButton.OnClick := DefaultOnButtonClick;\r\n FButton.Caption := '...';\r\n Height := FEditControl.Height;\r\n FButton.Width := Height;\r\n FEditControl.Align := alClient;\r\n FDialogOptions := [ofHideReadOnly,ofEnableSizing];\r\n BevelInner := bvNone;\r\n BevelOuter := bvNone;\r\n FDialogKind := jdkOpen;\r\nend;\r\n\r\ndestructor TJvDynControlJVCLDBFileNameEdit.Destroy;\r\nbegin\r\n FreeAndNil(FEditControl);\r\n FreeAndNil(FButton);\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDBFileNameEdit.DefaultOnButtonClick(Sender: TObject);\r\nbegin\r\n case FDialogKind of\r\n jdkOpen:\r\n with TOpenDialog.Create(Self) do\r\n try\r\n Options := FDialogOptions;\r\n Title := FDialogTitle;\r\n Filter := FFilter;\r\n FilterIndex := FFilterIndex;\r\n InitialDir := FInitialDir;\r\n DefaultExt := FDefaultExt;\r\n FileName := ControlGetValue;\r\n if Execute then\r\n ControlSetValue(FileName);\r\n finally\r\n Free;\r\n end;\r\n jdkOpenPicture:\r\n with TOpenPictureDialog.Create(Self) do\r\n try\r\n Options := FDialogOptions;\r\n Title := FDialogTitle;\r\n Filter := FFilter;\r\n FilterIndex := FFilterIndex;\r\n InitialDir := FInitialDir;\r\n DefaultExt := FDefaultExt;\r\n FileName := ControlGetValue;\r\n if Execute then\r\n ControlSetValue(FileName);\r\n finally\r\n Free;\r\n end;\r\n jdkSave:\r\n with TSaveDialog.Create(Self) do\r\n try\r\n Options := FDialogOptions;\r\n Title := FDialogTitle;\r\n Filter := FFilter;\r\n FilterIndex := FFilterIndex;\r\n InitialDir := FInitialDir;\r\n DefaultExt := FDefaultExt;\r\n FileName := ControlGetValue;\r\n if Execute then\r\n ControlSetValue(FileName);\r\n finally\r\n Free;\r\n end;\r\n jdkSavePicture:\r\n with TSavePictureDialog.Create(Self) do\r\n try\r\n Options := FDialogOptions;\r\n Title := FDialogTitle;\r\n Filter := FFilter;\r\n FilterIndex := FFilterIndex;\r\n InitialDir := FInitialDir;\r\n DefaultExt := FDefaultExt;\r\n FileName := ControlGetValue;\r\n if Execute then\r\n ControlSetValue(FileName);\r\n finally\r\n Free;\r\n end;\r\n end;\r\n if FEditControl.CanFocus then\r\n FEditControl.SetFocus;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDBFileNameEdit.ControlSetDefaultProperties;\r\nbegin\r\n Caption := ' ';\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDBFileNameEdit.ControlSetReadOnly(Value: Boolean);\r\nbegin\r\n FEditControl.ReadOnly := Value;\r\n FButton.Enabled := not Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDBFileNameEdit.ControlSetCaption(const Value: string);\r\nbegin\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDBFileNameEdit.ControlSetTabOrder(Value: Integer);\r\nbegin\r\n TabOrder := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDBFileNameEdit.ControlSetHint(const Value: string);\r\nbegin\r\n Hint := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDBFileNameEdit.ControlSetOnEnter(Value: TNotifyEvent);\r\nbegin\r\n FEditControl.OnEnter := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDBFileNameEdit.ControlSetOnExit(Value: TNotifyEvent);\r\nbegin\r\n FEditControl.OnExit := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDBFileNameEdit.ControlSetOnChange(Value: TNotifyEvent);\r\nbegin\r\n FEditControl.OnChange := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDBFileNameEdit.ControlSetOnClick(Value: TNotifyEvent);\r\nbegin\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDBFileNameEdit.ControlSetValue(Value: Variant);\r\nbegin\r\n FEditControl.Text := Value;\r\nend;\r\n\r\nfunction TJvDynControlJVCLDBFileNameEdit.ControlGetValue: Variant;\r\nbegin\r\n Result := FEditControl.Text;\r\nend;\r\n\r\n// IJvDynControlFileName\r\nprocedure TJvDynControlJVCLDBFileNameEdit.ControlSetInitialDir(const Value: string);\r\nbegin\r\n FInitialDir := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDBFileNameEdit.ControlSetDefaultExt(const Value: string);\r\nbegin\r\n FDefaultExt := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDBFileNameEdit.ControlSetDialogTitle(const Value: string);\r\nbegin\r\n FDialogTitle := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDBFileNameEdit.ControlSetDialogOptions(Value: TOpenOptions);\r\nbegin\r\n FDialogOptions := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDBFileNameEdit.ControlSetFilter(const Value: string);\r\nbegin\r\n FFilter := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDBFileNameEdit.ControlSetFilterIndex(Value: Integer);\r\nbegin\r\n FFilterIndex := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDBFileNameEdit.ControlSetDialogKind(Value: TJvDynControlFileNameDialogKind);\r\nbegin\r\n FDialogKind := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDBFileNameEdit.ControlSetDataSource(Value: TDataSource);\r\nbegin\r\n FEditControl.DataSource := Value;\r\nend;\r\n\r\nfunction TJvDynControlJVCLDBFileNameEdit.ControlGetDataSource: TDataSource;\r\nbegin\r\n Result := FEditControl.DataSource;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDBFileNameEdit.ControlSetDataField(const Value: string);\r\nbegin\r\n FEditControl.DataField := Value;\r\nend;\r\n\r\nfunction TJvDynControlJVCLDBFileNameEdit.ControlGetDataField: string;\r\nbegin\r\n Result := FEditControl.DataField;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDBFileNameEdit.ControlSetAnchors(Value : TAnchors);\r\nbegin\r\n Anchors := Value;\r\nend;\r\n\r\n//=== { TJvDynControlJVCLDBDirectoryEdit } ===================================\r\n\r\nconstructor TJvDynControlJVCLDBDirectoryEdit.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FEditControl := TJvDBMaskEdit.Create(AOwner);\r\n FEditControl.Parent := Self;\r\n FButton := TBitBtn.Create(AOwner);\r\n FButton.Parent := Self;\r\n FButton.Align := alRight;\r\n FButton.OnClick := DefaultOnButtonClick;\r\n FButton.Caption := '...';\r\n Height := FEditControl.Height;\r\n FButton.Width := Height;\r\n FEditControl.Align := alClient;\r\n BevelInner := bvNone;\r\n BevelOuter := bvNone;\r\nend;\r\n\r\ndestructor TJvDynControlJVCLDBDirectoryEdit.Destroy;\r\nbegin\r\n FreeAndNil(FEditControl);\r\n FreeAndNil(FButton);\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDBDirectoryEdit.DefaultOnButtonClick(Sender: TObject);\r\nvar\r\n Opt: TSelectDirOpts;\r\n Dir: string;\r\nbegin\r\n Dir := ControlGetValue;\r\n if Dir = '' then\r\n if FInitialDir <> '' then\r\n Dir := FInitialDir\r\n else\r\n Dir := PathDelim;\r\n if not DirectoryExists(Dir) then\r\n Dir := PathDelim;\r\n if SelectDirectory(Dir, Opt, HelpContext) then\r\n ControlSetValue(Dir);\r\n if FEditControl.CanFocus then\r\n FEditControl.SetFocus;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDBDirectoryEdit.ControlSetDefaultProperties;\r\nbegin\r\n Self.Caption := ' ';\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDBDirectoryEdit.ControlSetReadOnly(Value: Boolean);\r\nbegin\r\n FEditControl.ReadOnly := Value;\r\n FButton.Enabled := not Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDBDirectoryEdit.ControlSetCaption(const Value: string);\r\nbegin\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDBDirectoryEdit.ControlSetTabOrder(Value: Integer);\r\nbegin\r\n TabOrder := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDBDirectoryEdit.ControlSetHint(const Value: string);\r\nbegin\r\n Hint := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDBDirectoryEdit.ControlSetOnEnter(Value: TNotifyEvent);\r\nbegin\r\n FEditControl.OnEnter := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDBDirectoryEdit.ControlSetOnExit(Value: TNotifyEvent);\r\nbegin\r\n FEditControl.OnExit := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDBDirectoryEdit.ControlSetOnChange(Value: TNotifyEvent);\r\nbegin\r\n FEditControl.OnChange := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDBDirectoryEdit.ControlSetOnClick(Value: TNotifyEvent);\r\nbegin\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDBDirectoryEdit.ControlSetValue(Value: Variant);\r\nbegin\r\n FEditControl.Text := Value;\r\nend;\r\n\r\nfunction TJvDynControlJVCLDBDirectoryEdit.ControlGetValue: Variant;\r\nbegin\r\n Result := FEditControl.Text;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDBDirectoryEdit.ControlSetInitialDir(const Value: string);\r\nbegin\r\n FInitialDir := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDBDirectoryEdit.ControlSetDialogTitle(const Value: string);\r\nbegin\r\n FDialogTitle := Value;\r\nend;\r\n\r\n\r\nprocedure TJvDynControlJVCLDBDirectoryEdit.ControlSetDialogOptions(Value: TSelectDirOpts);\r\nbegin\r\n FDialogOptions := Value;\r\nend;\r\n\r\n\r\nprocedure TJvDynControlJVCLDBDirectoryEdit.ControlSetDataSource(Value: TDataSource);\r\nbegin\r\n FEditControl.DataSource := Value;\r\nend;\r\n\r\nfunction TJvDynControlJVCLDBDirectoryEdit.ControlGetDataSource: TDataSource;\r\nbegin\r\n Result := FEditControl.DataSource;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDBDirectoryEdit.ControlSetDataField(const Value: string);\r\nbegin\r\n FEditControl.DataField := Value;\r\nend;\r\n\r\nfunction TJvDynControlJVCLDBDirectoryEdit.ControlGetDataField: string;\r\nbegin\r\n Result := FEditControl.DataField;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDBDirectoryEdit.ControlSetAnchors(Value : TAnchors);\r\nbegin\r\n Anchors := Value;\r\nend;\r\n\r\n//=== { TJvDynControlJVCLDBCheckBox } ========================================\r\n\r\nprocedure TJvDynControlJVCLDBCheckBox.ControlSetDefaultProperties;\r\nbegin\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDBCheckBox.ControlSetCaption(const Value: string);\r\nbegin\r\n Caption := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDBCheckBox.ControlSetTabOrder(Value: Integer);\r\nbegin\r\n TabOrder := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDBCheckBox.ControlSetHint(const Value: string);\r\nbegin\r\n Hint := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDBCheckBox.ControlSetOnEnter(Value: TNotifyEvent);\r\nbegin\r\n OnEnter := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDBCheckBox.ControlSetOnExit(Value: TNotifyEvent);\r\nbegin\r\n OnExit := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDBCheckBox.ControlSetOnChange(Value: TNotifyEvent);\r\nbegin\r\n OnClick := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDBCheckBox.ControlSetOnClick(Value: TNotifyEvent);\r\nbegin\r\n OnClick := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDBCheckBox.ControlSetValue(Value: Variant);\r\nbegin\r\n Checked := JvDynControlVariantToBoolean(Value);\r\nend;\r\n\r\nfunction TJvDynControlJVCLDBCheckBox.ControlGetValue: Variant;\r\nbegin\r\n Result := Checked;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDBCheckBox.ControlSetDataSource(Value: TDataSource);\r\nbegin\r\n DataSource := Value;\r\nend;\r\n\r\nfunction TJvDynControlJVCLDBCheckBox.ControlGetDataSource: TDataSource;\r\nbegin\r\n Result := DataSource;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDBCheckBox.ControlSetDataField(const Value: string);\r\nbegin\r\n DataField := Value;\r\nend;\r\n\r\nfunction TJvDynControlJVCLDBCheckBox.ControlGetDataField: string;\r\nbegin\r\n Result := DataField;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDBCheckBox.ControlSetAnchors(Value : TAnchors);\r\nbegin\r\n Anchors := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDBCheckBox.ControlSetValueChecked(Value: Variant);\r\nbegin\r\n ValueChecked := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDBCheckBox.ControlSetValueUnChecked(Value: Variant);\r\nbegin\r\n ValueUnChecked := Value;\r\nend;\r\n\r\n\r\n//=== { TJvDynControlJVCLDBMemo } ============================================\r\n\r\nprocedure TJvDynControlJVCLDBMemo.ControlSetDefaultProperties;\r\nbegin\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDBMemo.ControlSetReadOnly(Value: Boolean);\r\nbegin\r\n ReadOnly := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDBMemo.ControlSetCaption(const Value: string);\r\nbegin\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDBMemo.ControlSetTabOrder(Value: Integer);\r\nbegin\r\n TabOrder := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDBMemo.ControlSetHint(const Value: string);\r\nbegin\r\n Hint := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDBMemo.ControlSetOnEnter(Value: TNotifyEvent);\r\nbegin\r\n OnEnter := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDBMemo.ControlSetOnExit(Value: TNotifyEvent);\r\nbegin\r\n OnExit := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDBMemo.ControlSetOnChange(Value: TNotifyEvent);\r\nbegin\r\n OnChange := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDBMemo.ControlSetOnClick(Value: TNotifyEvent);\r\nbegin\r\n OnClick := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDBMemo.ControlSetValue(Value: Variant);\r\nbegin\r\n Text := Value;\r\nend;\r\n\r\nfunction TJvDynControlJVCLDBMemo.ControlGetValue: Variant;\r\nbegin\r\n Result := Text;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDBMemo.ControlSetSorted(Value: Boolean);\r\nbegin\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDBMemo.ControlSetItems(Value: TStrings);\r\nbegin\r\n Lines.Assign(Value);\r\nend;\r\n\r\nfunction TJvDynControlJVCLDBMemo.ControlGetItems: TStrings;\r\nbegin\r\n Result := Lines;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDBMemo.ControlSetWantTabs(Value: Boolean);\r\nbegin\r\n WantTabs := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDBMemo.ControlSetWantReturns(Value: Boolean);\r\nbegin\r\n WantReturns := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDBMemo.ControlSetWordWrap(Value: Boolean);\r\nbegin\r\n WordWrap := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDBMemo.ControlSetScrollBars(Value: TScrollStyle);\r\nbegin\r\n ScrollBars := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDBMemo.ControlSetDataSource(Value: TDataSource);\r\nbegin\r\n DataSource := Value;\r\nend;\r\n\r\nfunction TJvDynControlJVCLDBMemo.ControlGetDataSource: TDataSource;\r\nbegin\r\n Result := DataSource;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDBMemo.ControlSetDataField(const Value: string);\r\nbegin\r\n DataField := Value;\r\nend;\r\n\r\nfunction TJvDynControlJVCLDBMemo.ControlGetDataField: string;\r\nbegin\r\n Result := DataField;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDBMemo.ControlSetAnchors(Value : TAnchors);\r\nbegin\r\n Anchors := Value;\r\nend;\r\n\r\n//=== { TJvDynControlJVCLDBDateEdit } ========================================\r\n\r\nprocedure TJvDynControlJVCLDBDateEdit.ControlSetDefaultProperties;\r\nbegin\r\n DateFormat := dfShort;\r\n DateMode := dmComboBox;\r\n Kind := dtkDate;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDBDateEdit.ControlSetCaption(const Value: string);\r\nbegin\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDBDateEdit.ControlSetTabOrder(Value: Integer);\r\nbegin\r\n TabOrder := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDBDateEdit.ControlSetHint(const Value: string);\r\nbegin\r\n Hint := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDBDateEdit.ControlSetOnEnter(Value: TNotifyEvent);\r\nbegin\r\n OnEnter := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDBDateEdit.ControlSetOnExit(Value: TNotifyEvent);\r\nbegin\r\n OnExit := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDBDateEdit.ControlSetOnChange(Value: TNotifyEvent);\r\nbegin\r\n OnChange := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDBDateEdit.ControlSetOnClick(Value: TNotifyEvent);\r\nbegin\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDBDateEdit.ControlSetValue(Value: Variant);\r\nbegin\r\n Text := Value;\r\nend;\r\n\r\nfunction TJvDynControlJVCLDBDateEdit.ControlGetValue: Variant;\r\nbegin\r\n Result := Text;\r\nend;\r\n\r\n// IJvDynControlDate\r\nprocedure TJvDynControlJVCLDBDateEdit.ControlSetMinDate(Value: TDateTime);\r\nbegin\r\n MinDate := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDBDateEdit.ControlSetMaxDate(Value: TDateTime);\r\nbegin\r\n MaxDate := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDBDateEdit.ControlSetFormat(const Value: string);\r\nbegin\r\n Format := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDBDateEdit.ControlSetDataSource(Value: TDataSource);\r\nbegin\r\n DataSource := Value;\r\nend;\r\n\r\nfunction TJvDynControlJVCLDBDateEdit.ControlGetDataSource: TDataSource;\r\nbegin\r\n Result := DataSource;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDBDateEdit.ControlSetDataField(const Value: string);\r\nbegin\r\n DataField := Value;\r\nend;\r\n\r\nfunction TJvDynControlJVCLDBDateEdit.ControlGetDataField: string;\r\nbegin\r\n Result := DataField;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDBDateEdit.ControlSetAnchors(Value : TAnchors);\r\nbegin\r\n Anchors := Value;\r\nend;\r\n\r\n//=== { TJvDynControlJVCLDBTimeEdit } ========================================\r\n\r\nprocedure TJvDynControlJVCLDBTimeEdit.ControlSetDefaultProperties;\r\nbegin\r\n DateFormat := dfShort;\r\n Kind := dtkTime;\r\n DateMode := dmUpDown;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDBTimeEdit.ControlSetCaption(const Value: string);\r\nbegin\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDBTimeEdit.ControlSetTabOrder(Value: Integer);\r\nbegin\r\n TabOrder := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDBTimeEdit.ControlSetHint(const Value: string);\r\nbegin\r\n Hint := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDBTimeEdit.ControlSetOnEnter(Value: TNotifyEvent);\r\nbegin\r\n OnEnter := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDBTimeEdit.ControlSetOnExit(Value: TNotifyEvent);\r\nbegin\r\n OnExit := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDBTimeEdit.ControlSetOnChange(Value: TNotifyEvent);\r\nbegin\r\n OnChange := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDBTimeEdit.ControlSetOnClick(Value: TNotifyEvent);\r\nbegin\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDBTimeEdit.ControlSetValue(Value: Variant);\r\nbegin\r\n Text := Value;\r\nend;\r\n\r\nfunction TJvDynControlJVCLDBTimeEdit.ControlGetValue: Variant;\r\nbegin\r\n Result := Text;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDBTimeEdit.ControlSetFormat(const Value: string);\r\nbegin\r\n Format := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDBTimeEdit.ControlSetDataSource(Value: TDataSource);\r\nbegin\r\n DataSource := Value;\r\nend;\r\n\r\nfunction TJvDynControlJVCLDBTimeEdit.ControlGetDataSource: TDataSource;\r\nbegin\r\n Result := DataSource;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDBTimeEdit.ControlSetDataField(const Value: string);\r\nbegin\r\n DataField := Value;\r\nend;\r\n\r\nfunction TJvDynControlJVCLDBTimeEdit.ControlGetDataField: string;\r\nbegin\r\n Result := DataField;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDBTimeEdit.ControlSetAnchors(Value : TAnchors);\r\nbegin\r\n Anchors := Value;\r\nend;\r\n\r\n//=== { TJvDynControlJVCLDBRadioGroup } ======================================\r\n\r\nprocedure TJvDynControlJVCLDBRadioGroup.ControlSetDefaultProperties;\r\nbegin\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDBRadioGroup.ControlSetCaption(const Value: string);\r\nbegin\r\n Caption := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDBRadioGroup.ControlSetTabOrder(Value: Integer);\r\nbegin\r\n TabOrder := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDBRadioGroup.ControlSetHint(const Value: string);\r\nbegin\r\n Hint := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDBRadioGroup.ControlSetOnEnter(Value: TNotifyEvent);\r\nbegin\r\n OnEnter := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDBRadioGroup.ControlSetOnExit(Value: TNotifyEvent);\r\nbegin\r\n OnExit := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDBRadioGroup.ControlSetOnChange(Value: TNotifyEvent);\r\nbegin\r\n OnClick := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDBRadioGroup.ControlSetOnClick(Value: TNotifyEvent);\r\nbegin\r\n OnClick := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDBRadioGroup.ControlSetValue(Value: Variant);\r\nbegin\r\n if VarIsInt(Value) then\r\n ItemIndex := Value\r\n else\r\n ItemIndex := Items.IndexOf(Value);\r\nend;\r\n\r\nfunction TJvDynControlJVCLDBRadioGroup.ControlGetValue: Variant;\r\nbegin\r\n Result := ItemIndex;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDBRadioGroup.ControlSetSorted(Value: Boolean);\r\nbegin\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDBRadioGroup.ControlSetItems(Value: TStrings);\r\nbegin\r\n Items.Assign(Value);\r\nend;\r\n\r\nfunction TJvDynControlJVCLDBRadioGroup.ControlGetItems: TStrings;\r\nbegin\r\n Result := Items;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDBRadioGroup.ControlSetColumns(Value: Integer);\r\nbegin\r\n Columns := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDBRadioGroup.ControlSetDataSource(Value: TDataSource);\r\nbegin\r\n DataSource := Value;\r\nend;\r\n\r\nfunction TJvDynControlJVCLDBRadioGroup.ControlGetDataSource: TDataSource;\r\nbegin\r\n Result := DataSource;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDBRadioGroup.ControlSetDataField(const Value: string);\r\nbegin\r\n DataField := Value;\r\nend;\r\n\r\nfunction TJvDynControlJVCLDBRadioGroup.ControlGetDataField: string;\r\nbegin\r\n Result := DataField;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDBRadioGroup.ControlSetAnchors(Value : TAnchors);\r\nbegin\r\n Anchors := Value;\r\nend;\r\n\r\n//=== { TJvDynControlJVCLDBListBox } =========================================\r\n\r\nprocedure TJvDynControlJVCLDBListBox.ControlSetDefaultProperties;\r\nbegin\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDBListBox.ControlSetCaption(const Value: string);\r\nbegin\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDBListBox.ControlSetTabOrder(Value: Integer);\r\nbegin\r\n TabOrder := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDBListBox.ControlSetHint(const Value: string);\r\nbegin\r\n Hint := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDBListBox.ControlSetOnEnter(Value: TNotifyEvent);\r\nbegin\r\n OnEnter := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDBListBox.ControlSetOnExit(Value: TNotifyEvent);\r\nbegin\r\n OnExit := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDBListBox.ControlSetOnChange(Value: TNotifyEvent);\r\nbegin\r\n// OnChange := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDBListBox.ControlSetOnClick(Value: TNotifyEvent);\r\nbegin\r\n OnClick := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDBListBox.ControlSetValue(Value: Variant);\r\nbegin\r\n if VarIsInt(Value) then\r\n ItemIndex := Value\r\n else\r\n ItemIndex := Items.IndexOf(Value);\r\nend;\r\n\r\nfunction TJvDynControlJVCLDBListBox.ControlGetValue: Variant;\r\nbegin\r\n Result := ItemIndex;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDBListBox.ControlSetSorted(Value: Boolean);\r\nbegin\r\n Sorted := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDBListBox.ControlSetItems(Value: TStrings);\r\nbegin\r\n Items.Assign(Value);\r\nend;\r\n\r\nfunction TJvDynControlJVCLDBListBox.ControlGetItems: TStrings;\r\nbegin\r\n Result := Items;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDBListBox.ControlSetOnDblClick(Value: TNotifyEvent);\r\nbegin\r\n OnDblClick := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDBListBox.ControlSetDataSource(Value: TDataSource);\r\nbegin\r\n DataSource := Value;\r\nend;\r\n\r\nfunction TJvDynControlJVCLDBListBox.ControlGetDataSource: TDataSource;\r\nbegin\r\n Result := DataSource;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDBListBox.ControlSetDataField(const Value: string);\r\nbegin\r\n DataField := Value;\r\nend;\r\n\r\nfunction TJvDynControlJVCLDBListBox.ControlGetDataField: string;\r\nbegin\r\n Result := DataField;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDBListBox.ControlSetAnchors(Value : TAnchors);\r\nbegin\r\n Anchors := Value;\r\nend;\r\n\r\n//=== { TJvDynControlJVCLDBComboBox } ========================================\r\n\r\nprocedure TJvDynControlJVCLDBComboBox.ControlSetDefaultProperties;\r\nbegin\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDBComboBox.ControlSetCaption(const Value: string);\r\nbegin\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDBComboBox.ControlSetTabOrder(Value: Integer);\r\nbegin\r\n TabOrder := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDBComboBox.ControlSetHint(const Value: string);\r\nbegin\r\n Hint := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDBComboBox.ControlSetOnEnter(Value: TNotifyEvent);\r\nbegin\r\n OnEnter := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDBComboBox.ControlSetOnExit(Value: TNotifyEvent);\r\nbegin\r\n OnExit := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDBComboBox.ControlSetOnChange(Value: TNotifyEvent);\r\nbegin\r\n// OnChange := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDBComboBox.ControlSetOnClick(Value: TNotifyEvent);\r\nbegin\r\n OnClick := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDBComboBox.ControlSetValue(Value: Variant);\r\nbegin\r\n if Style = csDropDownList then\r\n ItemIndex := Items.IndexOf(Value)\r\n else\r\n Text := Value;\r\nend;\r\n\r\nfunction TJvDynControlJVCLDBComboBox.ControlGetValue: Variant;\r\nbegin\r\n Result := Text;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDBComboBox.ControlSetSorted(Value: Boolean);\r\nbegin\r\n Sorted := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDBComboBox.ControlSetItems(Value: TStrings);\r\nbegin\r\n Items.Assign(Value);\r\nend;\r\n\r\nfunction TJvDynControlJVCLDBComboBox.ControlGetItems: TStrings;\r\nbegin\r\n Result := Items;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDBComboBox.ControlSetNewEntriesAllowed(Value: Boolean);\r\nconst\r\n Styles: array [Boolean] of TComboBoxStyle =\r\n (csDropDownList, csDropDown);\r\nbegin\r\n Style := Styles[Value];\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDBComboBox.ControlSetDataSource(Value: TDataSource);\r\nbegin\r\n DataSource := Value;\r\nend;\r\n\r\nfunction TJvDynControlJVCLDBComboBox.ControlGetDataSource: TDataSource;\r\nbegin\r\n Result := DataSource;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDBComboBox.ControlSetDataField(const Value: string);\r\nbegin\r\n DataField := Value;\r\nend;\r\n\r\nfunction TJvDynControlJVCLDBComboBox.ControlGetDataField: string;\r\nbegin\r\n Result := DataField;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDBComboBox.ControlSetAnchors(Value : TAnchors);\r\nbegin\r\n Anchors := Value;\r\nend;\r\n\r\n//=== { TJvDynControlJVCLDBImage } ===========================================\r\n\r\nprocedure TJvDynControlJVCLDBImage.ControlSetDefaultProperties;\r\nbegin\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDBImage.ControlSetCaption(const Value: string);\r\nbegin\r\n Caption := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDBImage.ControlSetTabOrder(Value: Integer);\r\nbegin\r\n// TabOrder := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDBImage.ControlSetHint(const Value: string);\r\nbegin\r\n Hint := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDBImage.ControlSetOnEnter(Value: TNotifyEvent);\r\nbegin\r\n// OnEnter := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDBImage.ControlSetOnExit(Value: TNotifyEvent);\r\nbegin\r\n// OnExit := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDBImage.ControlSetOnClick(Value: TNotifyEvent);\r\nbegin\r\n OnClick := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDBImage.ControlSetAutoSize(Value: Boolean);\r\nbegin\r\n AutoSize := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDBImage.ControlSetIncrementalDisplay(Value: Boolean);\r\nbegin\r\n// IncrementalDisplay := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDBImage.ControlSetCenter(Value: Boolean);\r\nbegin\r\n Center := Value;\r\nend;\r\n\r\n\r\nprocedure TJvDynControlJVCLDBImage.ControlSetProportional(Value: Boolean);\r\nbegin\r\n// Proportional := Value;\r\nend;\r\n\r\n\r\nprocedure TJvDynControlJVCLDBImage.ControlSetStretch(Value: Boolean);\r\nbegin\r\n Stretch := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDBImage.ControlSetTransparent(Value: Boolean);\r\nbegin\r\n// Transparent := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDBImage.ControlSetPicture(Value: TPicture);\r\nbegin\r\n Picture.Assign(Value);\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDBImage.ControlSetGraphic(Value: TGraphic);\r\nbegin\r\n Picture.Assign(Value);\r\nend;\r\n\r\nfunction TJvDynControlJVCLDBImage.ControlGetPicture: TPicture;\r\nbegin\r\n Result := Picture;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDBImage.ControlSetDataSource(Value: TDataSource);\r\nbegin\r\n DataSource := Value;\r\nend;\r\n\r\nfunction TJvDynControlJVCLDBImage.ControlGetDataSource: TDataSource;\r\nbegin\r\n Result := DataSource;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDBImage.ControlSetDataField(const Value: string);\r\nbegin\r\n DataField := Value;\r\nend;\r\n\r\nfunction TJvDynControlJVCLDBImage.ControlGetDataField: string;\r\nbegin\r\n Result := DataField;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDBImage.ControlSetAnchors(Value : TAnchors);\r\nbegin\r\n Anchors := Value;\r\nend;\r\n\r\n//=== { TJvDynControlJVCLDBText } ============================================\r\n\r\nprocedure TJvDynControlJVCLDBText.ControlSetDefaultProperties;\r\nbegin\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDBText.ControlSetCaption(const Value: string);\r\nbegin\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDBText.ControlSetTabOrder(Value: Integer);\r\nbegin\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDBText.ControlSetHint(const Value: string);\r\nbegin\r\n Hint := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDBText.ControlSetOnEnter(Value: TNotifyEvent);\r\nbegin\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDBText.ControlSetOnExit(Value: TNotifyEvent);\r\nbegin\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDBText.ControlSetOnClick(Value: TNotifyEvent);\r\nbegin\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDBText.ControlSetDataSource(Value: TDataSource);\r\nbegin\r\n DataSource := Value;\r\nend;\r\n\r\nfunction TJvDynControlJVCLDBText.ControlGetDataSource: TDataSource;\r\nbegin\r\n Result := DataSource;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDBText.ControlSetDataField(const Value: string);\r\nbegin\r\n DataField := Value;\r\nend;\r\n\r\nfunction TJvDynControlJVCLDBText.ControlGetDataField: string;\r\nbegin\r\n Result := DataField;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDBText.ControlSetAnchors(Value : TAnchors);\r\nbegin\r\n Anchors := Value;\r\nend;\r\n\r\n//=== { TJvDynControlJVCLDBGrid } ============================================\r\n\r\nprocedure TJvDynControlJVCLDBGrid.ControlSetDefaultProperties;\r\nbegin\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDBGrid.ControlSetCaption(const Value: string);\r\nbegin\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDBGrid.ControlSetTabOrder(Value: Integer);\r\nbegin\r\n TabOrder := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDBGrid.ControlSetHint(const Value: string);\r\nbegin\r\n Hint := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDBGrid.ControlSetOnEnter(Value: TNotifyEvent);\r\nbegin\r\n OnEnter := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDBGrid.ControlSetOnExit(Value: TNotifyEvent);\r\nbegin\r\n OnExit := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDBGrid.ControlSetOnClick(Value: TNotifyEvent);\r\nbegin\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDBGrid.ControlSetDataSource(Value: TDataSource);\r\nbegin\r\n DataSource := Value;\r\nend;\r\n\r\nfunction TJvDynControlJVCLDBGrid.ControlGetDataSource: TDataSource;\r\nbegin\r\n Result := DataSource;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDBGrid.ControlSetDataField(const Value: string);\r\nbegin\r\nend;\r\n\r\nfunction TJvDynControlJVCLDBGrid.ControlGetDataField: string;\r\nbegin\r\n Result := '';\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDBGrid.ControlSetAnchors(Value : TAnchors);\r\nbegin\r\n Anchors := Value;\r\nend;\r\n\r\n//=== { TJvDynControlJVCLDBNavigator } =======================================\r\n\r\nprocedure TJvDynControlJVCLDBNavigator.ControlSetDefaultProperties;\r\nbegin\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDBNavigator.ControlSetCaption(const Value: string);\r\nbegin\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDBNavigator.ControlSetTabOrder(Value: Integer);\r\nbegin\r\n TabOrder := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDBNavigator.ControlSetHint(const Value: string);\r\nbegin\r\n Hint := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDBNavigator.ControlSetOnEnter(Value: TNotifyEvent);\r\nbegin\r\n OnEnter := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDBNavigator.ControlSetOnExit(Value: TNotifyEvent);\r\nbegin\r\n OnExit := Value;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDBNavigator.ControlSetOnClick(Value: TNotifyEvent);\r\nbegin\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDBNavigator.ControlSetDataSource(Value: TDataSource);\r\nbegin\r\n DataSource := Value;\r\nend;\r\n\r\nfunction TJvDynControlJVCLDBNavigator.ControlGetDataSource: TDataSource;\r\nbegin\r\n Result := DataSource;\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDBNavigator.ControlSetDataField(const Value: string);\r\nbegin\r\nend;\r\n\r\nfunction TJvDynControlJVCLDBNavigator.ControlGetDataField: string;\r\nbegin\r\n Result := '';\r\nend;\r\n\r\nprocedure TJvDynControlJVCLDBNavigator.ControlSetAnchors(Value : TAnchors);\r\nbegin\r\n Anchors := Value;\r\nend;\r\n\r\n//=== { TJvDynControlEngineJVCLDB } ==========================================\r\n\r\nfunction DynControlEngineJVCLDB: TJvDynControlEngineDB;\r\nbegin\r\n Result := IntDynControlEngineJVCLDB;\r\nend;\r\n\r\ntype\r\n TJvDynControlEngineJVCLDB = class(TJvDynControlEngineVCLDB)\r\n public\r\n procedure RegisterControls; override;\r\n end;\r\n\r\nprocedure TJvDynControlEngineJVCLDB.RegisterControls;\r\nbegin\r\n RegisterControlType(jctDBText, TJvDynControlJVCLDBText);\r\n RegisterControlType(jcTDBEdit, TJvDynControlJVCLDBEdit);\r\n RegisterControlType(jctDBImage, TJvDynControlJVCLDBImage);\r\n RegisterControlType(jctDBCheckBox, TJvDynControlJVCLDBCheckBox);\r\n RegisterControlType(jctDBComboBox, TJvDynControlJVCLDBComboBox);\r\n RegisterControlType(jctDBListBox, TJvDynControlJVCLDBListBox);\r\n RegisterControlType(jctDBRadioGroup, TJvDynControlJVCLDBRadioGroup);\r\n RegisterControlType(jctDBDateTimeEdit, TJvDynControlJVCLDBDateEdit);\r\n RegisterControlType(jctDBTimeEdit, TJvDynControlJVCLDBTimeEdit);\r\n RegisterControlType(jctDBDateEdit, TJvDynControlJVCLDBDateEdit);\r\n//// RegisterControlType(jctDBCalculateEdit, TJvDynControlJVCLDBEdit);\r\n//// RegisterControlType(jctDBSpinEdit, TJvDynControlJVCLDBEdit);\r\n RegisterControlType(jctDBDirectoryEdit, TJvDynControlJVCLDBDirectoryEdit);\r\n RegisterControlType(jctDBFileNameEdit, TJvDynControlJVCLDBFileNameEdit);\r\n RegisterControlType(jctDBMemo, TJvDynControlJVCLDBMemo);\r\n RegisterControlType(jctDBButtonEdit, TJvDynControlJVCLDBButtonEdit);\r\n RegisterControlType(jctDBGrid, TJvDynControlJVCLDBGrid);\r\n RegisterControlType(jctDBNavigator, TJvDynControlJVCLDBNavigator);\r\nend;\r\n\r\ninitialization\r\n {$IFDEF UNITVERSIONING}\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n {$ENDIF UNITVERSIONING}\r\n IntDynControlEngineJVCLDB := TJvDynControlEngineJVCLDB.Create;\r\n SetDefaultDynControlEngineDB(IntDynControlEngineJVCLDB);\r\n\r\nfinalization\r\n FreeAndNil(IntDynControlEngineJVCLDB);\r\n {$IFDEF UNITVERSIONING}\r\n UnregisterUnitVersion(HInstance);\r\n {$ENDIF UNITVERSIONING}\r\n\r\nend." }, { "path": "External/Jedi/Jvcl/run/JvDynControlEngineJVCLInspector.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Initial Developer of the Original Code is Jens Fudickar [jens dott fudickar att oratool dott de]\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\nJens Fudickar [jens dott fudickar att oratool dott de]\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvDynControlEngineJVCLInspector.pas 13155 2011-11-06 12:31:20Z ahuser $\r\n\r\nunit JvDynControlEngineJVCLInspector;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Graphics,\r\n Classes,\r\n Controls, JvInspector, JvDynControlEngineIntf, JvDynControlEngine;\r\n\r\ntype\r\n\r\n TJvDynControlRTTIInspectorControl = class(TJvInspector, IUnknown,\r\n IJvDynControl, IJvDynControlRTTIInspectorControl)\r\n private\r\n fControlOnPropertyChange: TJvDynControlInspectorControlOnPropertyChangeEvent;\r\n fOnDisplayProperty: TJvDynControlInspectorControlOnDisplayPropertyEvent;\r\n fOnTranslatePropertyName:\r\n TJvDynControlInspectorControlOnTranslatePropertyNameEvent;\r\n OldPropertyName: string;\r\n procedure JvInspectorAfterItemCreate(Sender: TObject; Item:\r\n TJvCustomInspectorItem);\r\n procedure JvInspectorBeforeItemCreate(Sender: TObject; Data:\r\n TJvCustomInspectorData; var ItemClass: TJvInspectorItemClass);\r\n procedure JvInspectorControlOnItemSelected(Sender: TObject);\r\n protected\r\n //IJvDynControlRTTIInspectorControl\r\n function ControlGetOnDisplayProperty:\r\n TJvDynControlInspectorControlOnDisplayPropertyEvent;\r\n function ControlGetOnTranslatePropertyName:\r\n TJvDynControlInspectorControlOnTranslatePropertyNameEvent;\r\n procedure ControlSetOnDisplayProperty(const Value:\r\n TJvDynControlInspectorControlOnDisplayPropertyEvent); overload;\r\n procedure ControlSetOnTranslatePropertyName(const Value:\r\n TJvDynControlInspectorControlOnTranslatePropertyNameEvent);\r\n function GetControlDividerWidth: Integer;\r\n procedure SetControlDividerWidth(const Value: Integer);\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n procedure ControlSetDefaultProperties;\r\n procedure ControlSetCaption(const Value: string);\r\n procedure ControlSetTabOrder(Value: Integer);\r\n\r\n procedure ControlSetOnEnter(Value: TNotifyEvent);\r\n procedure ControlSetOnExit(Value: TNotifyEvent);\r\n procedure ControlSetOnClick(Value: TNotifyEvent);\r\n procedure ControlSetHint(const Value: string);\r\n procedure ControlSetAnchors(Value: TAnchors);\r\n\r\n //IJvDynControlRTTIInspectorControl\r\n function ControlGetCurrentPropertyName: string;\r\n function ControlGetInspectedObject: TObject;\r\n function ControlGetVisibleItemsCount: Integer;\r\n procedure ControlSaveEditorValues;\r\n procedure ControlSetInspectedObject(const Value: TObject);\r\n function ControlIsPropertySupported(const aPropertyName : string): Boolean;\r\n function GetControlOnPropertyChange:\r\n TJvDynControlInspectorControlOnPropertyChangeEvent;\r\n procedure SetControlOnPropertyChange(const Value:\r\n TJvDynControlInspectorControlOnPropertyChangeEvent);\r\n end;\r\n\r\nprocedure RegisterJvDynControlRTTIInspectorControl(iEngine :\r\n TJvCustomDynControlEngine);\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvDynControlEngineJVCLInspector.pas $';\r\n Revision: '$Revision: 13155 $';\r\n Date: '$Date: 2011-11-06 13:31:20 +0100 (dim. 06 nov. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n SysUtils, Variants,\r\n JvJCLUtils;\r\n\r\n\r\n//=== { TJvDynControlRTTIInspectorControl } ========================================\r\n\r\nconstructor TJvDynControlRTTIInspectorControl.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n OldPropertyName := '';\r\nend;\r\n\r\nfunction TJvDynControlRTTIInspectorControl.ControlGetCurrentPropertyName:\r\n string;\r\nbegin\r\n if Assigned (Selected) then\r\n Result := Selected.Name\r\n else\r\n Result := '';\r\nend;\r\n\r\nprocedure TJvDynControlRTTIInspectorControl.ControlSetDefaultProperties;\r\nbegin\r\n AfterItemCreate := JvInspectorAfterItemCreate;\r\n BeforeItemCreate := JvInspectorBeforeItemCreate;\r\n OnItemSelected := JvInspectorControlOnItemSelected;\r\nend;\r\n\r\nprocedure TJvDynControlRTTIInspectorControl.ControlSetCaption(const Value: string);\r\nbegin\r\n Caption := Value;\r\nend;\r\n\r\nprocedure TJvDynControlRTTIInspectorControl.ControlSetTabOrder(Value: Integer);\r\nbegin\r\n TabOrder := Value;\r\nend;\r\n\r\nprocedure TJvDynControlRTTIInspectorControl.ControlSetOnEnter(Value: TNotifyEvent);\r\nbegin\r\n OnEnter := Value;\r\nend;\r\n\r\nprocedure TJvDynControlRTTIInspectorControl.ControlSetOnExit(Value: TNotifyEvent);\r\nbegin\r\n OnExit := Value;\r\nend;\r\n\r\nprocedure TJvDynControlRTTIInspectorControl.ControlSetOnClick(Value: TNotifyEvent);\r\nbegin\r\n OnClick := Value;\r\nend;\r\n\r\nprocedure TJvDynControlRTTIInspectorControl.ControlSetHint(const Value: string);\r\nbegin\r\n Hint := Value;\r\nend;\r\n\r\nprocedure TJvDynControlRTTIInspectorControl.ControlSetAnchors(Value: TAnchors);\r\nbegin\r\n Anchors := Value;\r\nend;\r\n\r\nfunction TJvDynControlRTTIInspectorControl.ControlGetInspectedObject: TObject;\r\nbegin\r\n Result := InspectObject;\r\nend;\r\n\r\nfunction TJvDynControlRTTIInspectorControl.ControlGetOnDisplayProperty:\r\n TJvDynControlInspectorControlOnDisplayPropertyEvent;\r\nbegin\r\n Result := fOnDisplayProperty;\r\nend;\r\n\r\nfunction TJvDynControlRTTIInspectorControl.ControlGetOnTranslatePropertyName:\r\n TJvDynControlInspectorControlOnTranslatePropertyNameEvent;\r\nbegin\r\n Result := fOnTranslatePropertyName;\r\nend;\r\n\r\nfunction TJvDynControlRTTIInspectorControl.ControlGetVisibleItemsCount: Integer;\r\nbegin\r\n Result := VisibleCount;\r\nend;\r\n\r\nfunction TJvDynControlRTTIInspectorControl.ControlIsPropertySupported(const\r\n aPropertyName : string): Boolean;\r\nbegin\r\n Result := True;\r\nend;\r\n\r\nprocedure TJvDynControlRTTIInspectorControl.JvInspectorAfterItemCreate(Sender:\r\n TObject; Item: TJvCustomInspectorItem);\r\nbegin\r\n if Assigned(Item) and Assigned(fOnTranslatePropertyName) then\r\n Item.DisplayName := fOnTranslatePropertyName(Item.Name);\r\nend;\r\n\r\nprocedure TJvDynControlRTTIInspectorControl.JvInspectorBeforeItemCreate(Sender:\r\n TObject; Data: TJvCustomInspectorData; var ItemClass:\r\n TJvInspectorItemClass);\r\nbegin\r\n if Assigned(fOnDisplayProperty)and\r\n Assigned(Data) and\r\n (Data is TJvInspectorPropData) and\r\n Assigned(TJvInspectorPropData(Data).Instance) then\r\n begin\r\n if not fOnDisplayProperty(Data.Name) then\r\n ItemClass := nil;\r\n end;\r\nend;\r\n\r\nprocedure TJvDynControlRTTIInspectorControl.ControlSaveEditorValues;\r\nbegin\r\n SaveValues;\r\nend;\r\n\r\nprocedure TJvDynControlRTTIInspectorControl.ControlSetInspectedObject(const\r\n Value: TObject);\r\nbegin\r\n InspectObject := Value;\r\nend;\r\n\r\nprocedure TJvDynControlRTTIInspectorControl.ControlSetOnDisplayProperty(const\r\n Value: TJvDynControlInspectorControlOnDisplayPropertyEvent);\r\nbegin\r\n fOnDisplayProperty := Value;\r\nend;\r\n\r\nprocedure TJvDynControlRTTIInspectorControl.ControlSetOnTranslatePropertyName(\r\n const Value: TJvDynControlInspectorControlOnTranslatePropertyNameEvent);\r\nbegin\r\n fOnTranslatePropertyName := Value;\r\nend;\r\n\r\nfunction TJvDynControlRTTIInspectorControl.GetControlDividerWidth: Integer;\r\nbegin\r\n Result := Divider;\r\nend;\r\n\r\nfunction TJvDynControlRTTIInspectorControl.GetControlOnPropertyChange:\r\n TJvDynControlInspectorControlOnPropertyChangeEvent;\r\nbegin\r\n Result := fControlOnPropertyChange;\r\nend;\r\n\r\nprocedure TJvDynControlRTTIInspectorControl.JvInspectorControlOnItemSelected(\r\n Sender: TObject);\r\nvar\r\n NewPropertyName: string;\r\nbegin\r\n NewPropertyName := ControlGetCurrentPropertyName;\r\n if Assigned(fControlOnPropertyChange) then\r\n fControlOnPropertyChange(OldPropertyName, NewPropertyName);\r\n OldPropertyName := NewPropertyName;\r\nend;\r\n\r\nprocedure TJvDynControlRTTIInspectorControl.SetControlDividerWidth(const Value:\r\n Integer);\r\nbegin\r\n Divider := Value;\r\nend;\r\n\r\nprocedure TJvDynControlRTTIInspectorControl.SetControlOnPropertyChange(const\r\n Value: TJvDynControlInspectorControlOnPropertyChangeEvent);\r\nbegin\r\n fControlOnPropertyChange := Value;\r\nend;\r\n\r\nprocedure RegisterJvDynControlRTTIInspectorControl(iEngine :\r\n TJvCustomDynControlEngine);\r\nbegin\r\n iEngine.RegisterControlType(jctRTTIInspector, TJvDynControlRTTIInspectorControl);\r\nend;\r\n\r\ninitialization\r\n {$IFDEF UNITVERSIONING}\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n {$ENDIF UNITVERSIONING}\r\n\r\nfinalization\r\n {$IFDEF UNITVERSIONING}\r\n UnregisterUnitVersion(HInstance);\r\n {$ENDIF UNITVERSIONING}\r\n\r\nend." }, { "path": "External/Jedi/Jvcl/run/JvDynControlEngineTools.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Initial Developer of the Original Code is Jens Fudickar [jens dott fudickar att oratool dott de]\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\nJens Fudickar [jens dott fudickar att oratool dott de]\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvDynControlEngineTools.pas 13138 2011-10-26 23:17:50Z jfudickar $\r\n\r\nunit JvDynControlEngineTools;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Variants, Classes, Controls, StdCtrls, Forms,\r\n JvDynControlEngine;\r\n\r\nfunction CreateDynControlDialog(const AFormCaption, AButton1Caption, AButton2Caption: string;\r\n const AButton1Click, AButton2Click: TNotifyEvent;\r\n var AMainPanel: TWinControl;\r\n ADynControlEngine: TJvDynControlEngine = nil): TCustomForm;\r\n\r\nfunction JvDynControlVariantToBoolean(Value: Variant): Boolean;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvDynControlEngineTools.pas $';\r\n Revision: '$Revision: 13138 $';\r\n Date: '$Date: 2011-10-27 01:17:50 +0200 (jeu. 27 oct. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n SysUtils;\r\n\r\nfunction CreateDynControlDialog(const AFormCaption, AButton1Caption, AButton2Caption: string;\r\n const AButton1Click, AButton2Click: TNotifyEvent;\r\n var AMainPanel: TWinControl;\r\n ADynControlEngine: TJvDynControlEngine = nil): TCustomForm;\r\nvar\r\n DynControlEngine: TJvDynControlEngine;\r\n ButtonPanel: TWinControl;\r\n Form: TCustomForm;\r\n Button1, Button2: TButtonControl;\r\nbegin\r\n if Assigned(ADynControlEngine) then\r\n DynControlEngine := ADynControlEngine\r\n else\r\n DynControlEngine := DefaultDynControlEngine;\r\n Form := DynControlEngine.CreateForm(AFormCaption, '');\r\n with TForm(Form) do\r\n begin\r\n FormStyle := fsNormal;\r\n Position := poScreenCenter;\r\n BorderIcons := [];\r\n BorderStyle := bsDialog;\r\n end;\r\n\r\n ButtonPanel := DynControlEngine.CreatePanelControl(Form, Form, '', '', alBottom);\r\n AMainPanel := DynControlEngine.CreatePanelControl(Form, Form, '', '', alClient);\r\n if AButton1Caption <> '' then\r\n begin\r\n Button1 := DynControlEngine.CreateButton(Form, ButtonPanel, '', AButton1Caption, '', AButton1Click, True, False);\r\n ButtonPanel.Height := Button1.Height + 6;\r\n Button1.Top := 3;\r\n Button1.Anchors := [akTop, akRight];\r\n end\r\n else\r\n Button1 := nil;\r\n if AButton2Caption <> '' then\r\n begin\r\n Button2 := DynControlEngine.CreateButton(Form, ButtonPanel, '', AButton2Caption, '', AButton2Click, True, False);\r\n ButtonPanel.Height := Button2.Height + 6;\r\n Button2.Top := 3;\r\n Button2.Anchors := [akTop, akRight];\r\n Button2.Left := ButtonPanel.Width - Button2.Width - 5;\r\n if Assigned(Button1) then\r\n Button1.Left := Button2.Left - Button1.Width - 5;\r\n end\r\n else\r\n if Assigned(Button1) then\r\n Button1.Left := ButtonPanel.Width - Button1.Width - 5;\r\n Result := Form;\r\nend;\r\n\r\nfunction JvDynControlVariantToBoolean(Value: Variant): Boolean;\r\nbegin\r\n if VarIsNull(Value) then\r\n Result := False\r\n else if VarType(Value) = varBoolean then\r\n Result := Value\r\n else\r\n Result := UpperCase(VarToStr(Value)) = 'TRUE';\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvDynControlEngineVCL.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Initial Developer of the Original Code is Jens Fudickar [jens dott fudickar att oratool dott de]\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\nJens Fudickar [jens dott fudickar att oratool dott de]\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvDynControlEngineVCL.pas 13415 2012-09-10 09:51:54Z obones $\r\n\r\nunit JvDynControlEngineVCL;\r\n\r\n{$I jvcl.inc}\r\n{$I crossplatform.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n {$IFDEF MSWINDOWS}\r\n ActnList, Graphics, ComCtrls, ImgList,\r\n {$ENDIF MSWINDOWS}\r\n Variants, Classes, Controls, StdCtrls, ExtCtrls, Mask, Forms,\r\n Buttons, Dialogs, FileCtrl, ExtDlgs, CheckLst,\r\n {$IFDEF HAS_UNIT_SYSTEM_UITYPES}\r\n System.UITypes,\r\n {$ENDIF HAS_UNIT_SYSTEM_UITYPES}\r\n JvDynControlEngine, JvDynControlEngineIntf;\r\n\r\ntype\r\n TJvDynControlEngineVCL = class(TJvDynControlEngine)\r\n protected\r\n procedure RegisterControls; override;\r\n end;\r\n\r\n TJvDynControlVCLMaskEdit = class(TMaskEdit, IUnknown,\r\n IJvDynControl, IJvDynControlData, IJvDynControlReadOnly, IJvDynControlEdit)\r\n public\r\n procedure ControlSetDefaultProperties;\r\n procedure ControlSetReadOnly(Value: Boolean);\r\n procedure ControlSetTabOrder(Value: Integer);\r\n\r\n procedure ControlSetOnEnter(Value: TNotifyEvent);\r\n procedure ControlSetOnExit(Value: TNotifyEvent);\r\n procedure ControlSetOnChange(Value: TNotifyEvent);\r\n procedure ControlSetOnClick(Value: TNotifyEvent);\r\n procedure ControlSetHint(const Value: string);\r\n procedure ControlSetAnchors(Value: TAnchors);\r\n\r\n procedure ControlSetValue(Value: Variant);\r\n function ControlGetValue: Variant;\r\n\r\n //IJvDynControlEdit\r\n procedure ControlSetPasswordChar(Value: Char);\r\n procedure ControlSetEditMask(const Value: string);\r\n end;\r\n\r\n TJvDynControlVCLButtonEdit = class(TPanel, IUnknown,\r\n IJvDynControl, IJvDynControlData, IJvDynControlReadOnly, IJvDynControlEdit,\r\n IJvDynControlButtonEdit, IJvDynControlButton)\r\n private\r\n FEditControl: TMaskEdit;\r\n FButton: TBitBtn;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n\r\n procedure ControlSetDefaultProperties;\r\n procedure ControlSetReadOnly(Value: Boolean);\r\n procedure ControlSetTabOrder(Value: Integer);\r\n\r\n procedure ControlSetOnEnter(Value: TNotifyEvent);\r\n procedure ControlSetOnExit(Value: TNotifyEvent);\r\n procedure ControlSetOnChange(Value: TNotifyEvent);\r\n procedure ControlSetOnClick(Value: TNotifyEvent);\r\n procedure ControlSetHint(const Value: string);\r\n procedure ControlSetAnchors(Value: TAnchors);\r\n\r\n procedure ControlSetValue(Value: Variant);\r\n function ControlGetValue: Variant;\r\n\r\n //IJvDynControlEdit\r\n procedure ControlSetPasswordChar(Value: Char);\r\n procedure ControlSetEditMask(const Value: string);\r\n\r\n //IJvDynControlButtonEdit\r\n procedure ControlSetOnButtonClick(Value: TNotifyEvent);\r\n procedure ControlSetButtonCaption(const Value: string);\r\n\r\n //IJvDynControlButton\r\n procedure ControlSetGlyph(Value: TBitmap);\r\n procedure ControlSetNumGlyphs(Value: Integer);\r\n procedure ControlSetLayout(Value: TButtonLayout);\r\n procedure ControlSetDefault(Value: Boolean);\r\n procedure ControlSetCancel(Value: Boolean);\r\n end;\r\n\r\n TJvDynControlVCLFileNameEdit = class(TPanel, IUnknown,\r\n IJvDynControl, IJvDynControlData, IJvDynControlFileName,\r\n IJvDynControlReadOnly)\r\n private\r\n FEditControl: TMaskEdit;\r\n FButton: TBitBtn;\r\n FInitialDir: string;\r\n FFilterIndex: Integer;\r\n FFilter: string;\r\n FDialogOptions: TOpenOptions;\r\n FDialogKind: TJvDynControlFileNameDialogKind;\r\n FDialogTitle: string;\r\n FDefaultExt: string;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n\r\n procedure DefaultOnButtonClick(Sender: TObject);\r\n\r\n procedure ControlSetDefaultProperties;\r\n procedure ControlSetReadOnly(Value: Boolean);\r\n procedure ControlSetTabOrder(Value: Integer);\r\n\r\n procedure ControlSetOnEnter(Value: TNotifyEvent);\r\n procedure ControlSetOnExit(Value: TNotifyEvent);\r\n procedure ControlSetOnChange(Value: TNotifyEvent);\r\n procedure ControlSetOnClick(Value: TNotifyEvent);\r\n procedure ControlSetHint(const Value: string);\r\n procedure ControlSetAnchors(Value: TAnchors);\r\n\r\n procedure ControlSetValue(Value: Variant);\r\n function ControlGetValue: Variant;\r\n\r\n // IJvDynControlFileName\r\n procedure ControlSetInitialDir(const Value: string);\r\n procedure ControlSetDefaultExt(const Value: string);\r\n procedure ControlSetDialogTitle(const Value: string);\r\n procedure ControlSetDialogOptions(Value: TOpenOptions);\r\n procedure ControlSetFilter(const Value: string);\r\n procedure ControlSetFilterIndex(Value: Integer);\r\n procedure ControlSetDialogKind(Value: TJvDynControlFileNameDialogKind);\r\n end;\r\n\r\n TJvDynControlVCLDirectoryEdit = class(TPanel, IUnknown,\r\n IJvDynControl, IJvDynControlData, IJvDynControlDirectory,\r\n IJvDynControlReadOnly)\r\n private\r\n FEditControl: TMaskEdit;\r\n FButton: TBitBtn;\r\n FInitialDir: string;\r\n FDialogOptions: TSelectDirOpts;\r\n FDialogTitle: string;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n\r\n procedure DefaultOnButtonClick(Sender: TObject);\r\n\r\n procedure ControlSetDefaultProperties;\r\n procedure ControlSetReadOnly(Value: Boolean);\r\n procedure ControlSetTabOrder(Value: Integer);\r\n\r\n procedure ControlSetOnEnter(Value: TNotifyEvent);\r\n procedure ControlSetOnExit(Value: TNotifyEvent);\r\n procedure ControlSetOnChange(Value: TNotifyEvent);\r\n procedure ControlSetOnClick(Value: TNotifyEvent);\r\n procedure ControlSetHint(const Value: string);\r\n procedure ControlSetAnchors(Value: TAnchors);\r\n\r\n procedure ControlSetValue(Value: Variant);\r\n function ControlGetValue: Variant;\r\n\r\n // IJvDynControlDirectory\r\n procedure ControlSetInitialDir(const Value: string);\r\n procedure ControlSetDialogTitle(const Value: string);\r\n procedure ControlSetDialogOptions(Value: TSelectDirOpts);\r\n end;\r\n\r\n TJvDynControlVCLDateTimeEdit = class(TPanel, IUnknown,\r\n IJvDynControl, IJvDynControlData, IJvDynControlDate)\r\n private\r\n FDatePicker: TDateTimePicker;\r\n FTimePicker: TDateTimePicker;\r\n protected\r\n procedure ControlResize(Sender: TObject);\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n procedure ControlSetDefaultProperties;\r\n procedure ControlSetTabOrder(Value: Integer);\r\n\r\n procedure ControlSetOnEnter(Value: TNotifyEvent);\r\n procedure ControlSetOnExit(Value: TNotifyEvent);\r\n procedure ControlSetOnChange(Value: TNotifyEvent);\r\n procedure ControlSetOnClick(Value: TNotifyEvent);\r\n procedure ControlSetHint(const Value: string);\r\n procedure ControlSetAnchors(Value: TAnchors);\r\n\r\n procedure ControlSetValue(Value: Variant);\r\n function ControlGetValue: Variant;\r\n\r\n // IJvDynControlDate\r\n procedure ControlSetMinDate(Value: TDateTime);\r\n procedure ControlSetMaxDate(Value: TDateTime);\r\n procedure ControlSetFormat(const Value: string);\r\n end;\r\n\r\n TJvDynControlVCLDateEdit = class(TDateTimePicker, IUnknown,\r\n IJvDynControl, IJvDynControlData, IJvDynControlDate)\r\n public\r\n procedure ControlSetDefaultProperties;\r\n procedure ControlSetTabOrder(Value: Integer);\r\n\r\n procedure ControlSetOnEnter(Value: TNotifyEvent);\r\n procedure ControlSetOnExit(Value: TNotifyEvent);\r\n procedure ControlSetOnChange(Value: TNotifyEvent);\r\n procedure ControlSetOnClick(Value: TNotifyEvent);\r\n procedure ControlSetHint(const Value: string);\r\n procedure ControlSetAnchors(Value: TAnchors);\r\n\r\n procedure ControlSetValue(Value: Variant);\r\n function ControlGetValue: Variant;\r\n\r\n // IJvDynControlDate\r\n procedure ControlSetMinDate(Value: TDateTime);\r\n procedure ControlSetMaxDate(Value: TDateTime);\r\n procedure ControlSetFormat(const Value: string);\r\n end;\r\n\r\n TJvDynControlVCLTimeEdit = class(TDateTimePicker, IUnknown,\r\n IJvDynControl, IJvDynControlData, IJvDynControlTime)\r\n public\r\n procedure ControlSetDefaultProperties;\r\n\r\n procedure ControlSetTabOrder(Value: Integer);\r\n\r\n procedure ControlSetOnEnter(Value: TNotifyEvent);\r\n procedure ControlSetOnExit(Value: TNotifyEvent);\r\n procedure ControlSetOnChange(Value: TNotifyEvent);\r\n procedure ControlSetOnClick(Value: TNotifyEvent);\r\n procedure ControlSetHint(const Value: string);\r\n procedure ControlSetAnchors(Value: TAnchors);\r\n\r\n procedure ControlSetValue(Value: Variant);\r\n function ControlGetValue: Variant;\r\n\r\n procedure ControlSetFormat(const Value: string);\r\n end;\r\n\r\n TJvDynControlVCLCheckBox = class(TCheckBox, IUnknown,\r\n IJvDynControl, IJvDynControlCaption, IJvDynControlData, IJvDynControlCheckBox, IJvDynControlFont)\r\n public\r\n function ControlGetCaption: string;\r\n procedure ControlSetDefaultProperties;\r\n procedure ControlSetCaption(const Value: string);\r\n procedure ControlSetTabOrder(Value: Integer);\r\n\r\n procedure ControlSetOnEnter(Value: TNotifyEvent);\r\n procedure ControlSetOnExit(Value: TNotifyEvent);\r\n procedure ControlSetOnChange(Value: TNotifyEvent);\r\n procedure ControlSetOnClick(Value: TNotifyEvent);\r\n procedure ControlSetHint(const Value: string);\r\n procedure ControlSetAnchors(Value: TAnchors);\r\n\r\n procedure ControlSetValue(Value: Variant);\r\n function ControlGetValue: Variant;\r\n\r\n //IJvDynControlCheckBox\r\n procedure ControlSetAllowGrayed(Value: Boolean);\r\n procedure ControlSetState(Value: TCheckBoxState);\r\n function ControlGetState: TCheckBoxState;\r\n\r\n //IJvDynControlFont\r\n procedure ControlSetFont(Value: TFont);\r\n function ControlGetFont: TFont;\r\n end;\r\n\r\n TJvDynControlVCLMemo = class(TMemo, IUnknown,\r\n IJvDynControl, IJvDynControlData, IJvDynControlItems, IJvDynControlMemo,\r\n IJvDynControlReadOnly, IJvDynControlAlignment,IJvDynControlFont)\r\n public\r\n procedure ControlSetDefaultProperties;\r\n procedure ControlSetReadOnly(Value: Boolean);\r\n procedure ControlSetTabOrder(Value: Integer);\r\n\r\n procedure ControlSetOnEnter(Value: TNotifyEvent);\r\n procedure ControlSetOnExit(Value: TNotifyEvent);\r\n procedure ControlSetOnChange(Value: TNotifyEvent);\r\n procedure ControlSetOnClick(Value: TNotifyEvent);\r\n procedure ControlSetHint(const Value: string);\r\n procedure ControlSetAnchors(Value: TAnchors);\r\n\r\n procedure ControlSetValue(Value: Variant);\r\n function ControlGetValue: Variant;\r\n\r\n procedure ControlSetSorted(Value: Boolean);\r\n procedure ControlSetItems(Value: TStrings);\r\n function ControlGetItems: TStrings;\r\n\r\n procedure ControlSetWantTabs(Value: Boolean);\r\n procedure ControlSetWantReturns(Value: Boolean);\r\n procedure ControlSetWordWrap(Value: Boolean);\r\n procedure ControlSetScrollBars(Value: TScrollStyle);\r\n //IJvDynControlAlignment\r\n procedure ControlSetAlignment(Value: TAlignment);\r\n //IJvDynControlFont\r\n procedure ControlSetFont(Value: TFont);\r\n function ControlGetFont: TFont;\r\n end;\r\n\r\n TJvDynControlVCLRichEdit = class(TRichEdit, IUnknown,\r\n IJvDynControl, IJvDynControlData, IJvDynControlItems, IJvDynControlMemo,\r\n IJvDynControlReadOnly,IJvDynControlFont)\r\n public\r\n procedure ControlSetDefaultProperties;\r\n procedure ControlSetReadOnly(Value: Boolean);\r\n procedure ControlSetTabOrder(Value: Integer);\r\n\r\n procedure ControlSetOnEnter(Value: TNotifyEvent);\r\n procedure ControlSetOnExit(Value: TNotifyEvent);\r\n procedure ControlSetOnChange(Value: TNotifyEvent);\r\n procedure ControlSetOnClick(Value: TNotifyEvent);\r\n procedure ControlSetHint(const Value: string);\r\n procedure ControlSetAnchors(Value: TAnchors);\r\n\r\n procedure ControlSetValue(Value: Variant);\r\n function ControlGetValue: Variant;\r\n\r\n procedure ControlSetSorted(Value: Boolean);\r\n procedure ControlSetItems(Value: TStrings);\r\n function ControlGetItems: TStrings;\r\n\r\n procedure ControlSetWantTabs(Value: Boolean);\r\n procedure ControlSetWantReturns(Value: Boolean);\r\n procedure ControlSetWordWrap(Value: Boolean);\r\n procedure ControlSetScrollBars(Value: TScrollStyle);\r\n\r\n //IJvDynControlFont\r\n function ControlGetFont: TFont;\r\n procedure ControlSetFont(Value: TFont);\r\n end;\r\n\r\n TJvDynControlVCLRadioGroup = class(TRadioGroup, IUnknown,\r\n IJvDynControl, IJvDynControlCaption, IJvDynControlData, IJvDynControlItems,\r\n IJvDynControlRadioGroup)\r\n public\r\n function ControlGetCaption: string;\r\n procedure ControlSetDefaultProperties;\r\n procedure ControlSetCaption(const Value: string);\r\n procedure ControlSetTabOrder(Value: Integer);\r\n\r\n procedure ControlSetOnEnter(Value: TNotifyEvent);\r\n procedure ControlSetOnExit(Value: TNotifyEvent);\r\n procedure ControlSetOnChange(Value: TNotifyEvent);\r\n procedure ControlSetOnClick(Value: TNotifyEvent);\r\n procedure ControlSetHint(const Value: string);\r\n procedure ControlSetAnchors(Value: TAnchors);\r\n\r\n procedure ControlSetValue(Value: Variant);\r\n function ControlGetValue: Variant;\r\n\r\n procedure ControlSetSorted(Value: Boolean);\r\n procedure ControlSetItems(Value: TStrings);\r\n function ControlGetItems: TStrings;\r\n\r\n procedure ControlSetColumns(Value: Integer);\r\n end;\r\n\r\n TJvDynControlVCLListBox = class(TListBox, IUnknown,\r\n IJvDynControl, IJvDynControlData, IJvDynControlItems, IJvDynControlItemIndex, IJvDynControlDblClick,\r\n IJvDynControlKey, IJvDynControlMouse)\r\n public\r\n function ControlGetItemIndex: Integer;\r\n procedure ControlSetDefaultProperties;\r\n procedure ControlSetTabOrder(Value: Integer);\r\n\r\n procedure ControlSetOnEnter(Value: TNotifyEvent);\r\n procedure ControlSetOnExit(Value: TNotifyEvent);\r\n procedure ControlSetOnChange(Value: TNotifyEvent);\r\n procedure ControlSetOnClick(Value: TNotifyEvent);\r\n procedure ControlSetHint(const Value: string);\r\n procedure ControlSetAnchors(Value: TAnchors);\r\n\r\n procedure ControlSetValue(Value: Variant);\r\n function ControlGetValue: Variant;\r\n\r\n procedure ControlSetSorted(Value: Boolean);\r\n procedure ControlSetItems(Value: TStrings);\r\n function ControlGetItems: TStrings;\r\n procedure ControlSetItemIndex(const Value: Integer);\r\n\r\n procedure ControlSetOnDblClick(Value: TNotifyEvent);\r\n function ControlGetOnKeyDown: TKeyEvent;\r\n function ControlGetOnKeyPress: TKeyPressEvent;\r\n function ControlGetOnKeyUp: TKeyEvent;\r\n procedure ControlSetOnKeyDown(const Value: TKeyEvent);\r\n procedure ControlSetOnKeyPress(const Value: TKeyPressEvent);\r\n\r\n function ControlGetOnMouseDown: TMouseEvent;\r\n function ControlGetOnMouseEnter: TNotifyEvent;\r\n function ControlGetOnMouseLeave: TNotifyEvent;\r\n function ControlGetOnMouseMove: TMouseMoveEvent;\r\n function ControlGetOnMouseUp: TMouseEvent;\r\n procedure ControlSetOnKeyUp(const Value: TKeyEvent);\r\n procedure ControlSetOnMouseDown(const Value: TMouseEvent);\r\n procedure ControlSetOnMouseEnter(const Value: TNotifyEvent);\r\n procedure ControlSetOnMouseLeave(const Value: TNotifyEvent);\r\n procedure ControlSetOnMouseMove(const Value: TMouseMoveEvent);\r\n procedure ControlSetOnMouseUp(const Value: TMouseEvent);\r\n end;\r\n\r\n TJvDynControlVCLCheckListBox = class(TCheckListBox, IUnknown,\r\n IJvDynControl, IJvDynControlData, IJvDynControlItems, IJvDynControlDblClick,\r\n IJvDynControlCheckListBox)\r\n public\r\n procedure ControlSetDefaultProperties;\r\n procedure ControlSetTabOrder(Value: Integer);\r\n\r\n procedure ControlSetOnEnter(Value: TNotifyEvent);\r\n procedure ControlSetOnExit(Value: TNotifyEvent);\r\n procedure ControlSetOnChange(Value: TNotifyEvent);\r\n procedure ControlSetOnClick(Value: TNotifyEvent);\r\n procedure ControlSetHint(const Value: string);\r\n procedure ControlSetAnchors(Value: TAnchors);\r\n\r\n procedure ControlSetValue(Value: Variant);\r\n function ControlGetValue: Variant;\r\n\r\n procedure ControlSetSorted(Value: Boolean);\r\n procedure ControlSetItems(Value: TStrings);\r\n function ControlGetItems: TStrings;\r\n\r\n procedure ControlSetOnDblClick(Value: TNotifyEvent);\r\n\r\n //IJvDynControlCheckListBox = interface\r\n procedure ControlSetAllowGrayed(Value: Boolean);\r\n procedure ControlSetChecked(Index: Integer; Value: Boolean);\r\n procedure ControlSetItemEnabled(Index: Integer; Value: Boolean);\r\n procedure ControlSetState(Index: Integer; Value: TCheckBoxState);\r\n function ControlGetChecked(Index: Integer): Boolean;\r\n function ControlGetItemEnabled(Index: Integer): Boolean;\r\n function ControlGetState(Index: Integer): TCheckBoxState;\r\n procedure ControlSetHeader(Index: Integer; Value: Boolean);\r\n function ControlGetHeader(Index: Integer): Boolean;\r\n end;\r\n\r\n TJvDynControlVCLComboBox = class(TComboBox, IUnknown,\r\n IJvDynControl, IJvDynControlData, IJvDynControlItems, IJvDynControlComboBox)\r\n public\r\n procedure ControlSetDefaultProperties;\r\n procedure ControlSetTabOrder(Value: Integer);\r\n\r\n procedure ControlSetOnEnter(Value: TNotifyEvent);\r\n procedure ControlSetOnExit(Value: TNotifyEvent);\r\n procedure ControlSetOnChange(Value: TNotifyEvent);\r\n procedure ControlSetOnClick(Value: TNotifyEvent);\r\n procedure ControlSetHint(const Value: string);\r\n procedure ControlSetAnchors(Value: TAnchors);\r\n\r\n procedure ControlSetValue(Value: Variant);\r\n function ControlGetValue: Variant;\r\n\r\n procedure ControlSetSorted(Value: Boolean);\r\n procedure ControlSetItems(Value: TStrings);\r\n function ControlGetItems: TStrings;\r\n\r\n procedure ControlSetNewEntriesAllowed(Value: Boolean);\r\n end;\r\n\r\n TJvDynControlVCLGroupBox = class(TGroupBox, IUnknown,\r\n IJvDynControl, IJvDynControlCaption)\r\n public\r\n function ControlGetCaption: string;\r\n procedure ControlSetDefaultProperties;\r\n procedure ControlSetCaption(const Value: string);\r\n procedure ControlSetTabOrder(Value: Integer);\r\n\r\n procedure ControlSetOnEnter(Value: TNotifyEvent);\r\n procedure ControlSetOnExit(Value: TNotifyEvent);\r\n procedure ControlSetOnClick(Value: TNotifyEvent);\r\n procedure ControlSetHint(const Value: string);\r\n procedure ControlSetAnchors(Value: TAnchors);\r\n end;\r\n\r\n TJvDynControlVCLPanel = class(TPanel, IUnknown,\r\n IJvDynControl, IJvDynControlCaption, IJvDynControlPanel, IJvDynControlAlign,\r\n IJvDynControlAutoSize, IJvDynControlBevelBorder, IJvDynControlColor,\r\n IJvDynControlAlignment)\r\n public\r\n function ControlGetCaption: string;\r\n procedure ControlSetDefaultProperties;\r\n procedure ControlSetCaption(const Value: string);\r\n procedure ControlSetTabOrder(Value: Integer);\r\n\r\n procedure ControlSetOnEnter(Value: TNotifyEvent);\r\n procedure ControlSetOnExit(Value: TNotifyEvent);\r\n procedure ControlSetOnClick(Value: TNotifyEvent);\r\n procedure ControlSetHint(const Value: string);\r\n procedure ControlSetAnchors(Value: TAnchors);\r\n\r\n procedure ControlSetBorder(ABevelInner: TPanelBevel; ABevelOuter: TPanelBevel;\r\n ABevelWidth: Integer; ABorderStyle: TBorderStyle; ABorderWidth: Integer);\r\n\r\n // IJvDynControlAlign\r\n procedure ControlSetAlign(Value: TAlign);\r\n\r\n // IJvDynControlAutoSize\r\n procedure ControlSetAutoSize(Value: Boolean);\r\n\r\n // IJvDynControlBevelBorder\r\n procedure ControlSetBevelInner(Value: TBevelCut);\r\n procedure ControlSetBevelKind(Value: TBevelKind);\r\n procedure ControlSetBevelOuter(Value: TBevelCut);\r\n procedure ControlSetBorderStyle(Value: TBorderStyle);\r\n procedure ControlSetBorderWidth(Value: Integer);\r\n // IJvDynControlColor\r\n procedure ControlSetColor(Value: TColor);\r\n procedure ControlSetParentColor(Value: Boolean);\r\n //IJvDynControlAlignment\r\n procedure ControlSetAlignment(Value: TAlignment);\r\n end;\r\n\r\n TJvDynControlVCLImage = class(TImage, IUnknown,\r\n IJvDynControl, IJvDynControlImage)\r\n public\r\n procedure ControlSetDefaultProperties;\r\n procedure ControlSetTabOrder(Value: Integer);\r\n\r\n procedure ControlSetOnEnter(Value: TNotifyEvent);\r\n procedure ControlSetOnExit(Value: TNotifyEvent);\r\n procedure ControlSetOnClick(Value: TNotifyEvent);\r\n procedure ControlSetHint(const Value: string);\r\n procedure ControlSetAnchors(Value: TAnchors);\r\n\r\n procedure ControlSetAutoSize(Value: Boolean);\r\n procedure ControlSetIncrementalDisplay(Value: Boolean);\r\n procedure ControlSetCenter(Value: Boolean);\r\n procedure ControlSetProportional(Value: Boolean);\r\n procedure ControlSetStretch(Value: Boolean);\r\n procedure ControlSetTransparent(Value: Boolean);\r\n procedure ControlSetPicture(Value: TPicture);\r\n procedure ControlSetGraphic(Value: TGraphic);\r\n function ControlGetPicture: TPicture;\r\n end;\r\n\r\n TJvDynControlVCLScrollBox = class(TScrollbox, IUnknown,\r\n IJvDynControl, IJvDynControlCaption)\r\n public\r\n function ControlGetCaption: string;\r\n procedure ControlSetDefaultProperties;\r\n procedure ControlSetCaption(const Value: string);\r\n procedure ControlSetTabOrder(Value: Integer);\r\n\r\n procedure ControlSetOnEnter(Value: TNotifyEvent);\r\n procedure ControlSetOnExit(Value: TNotifyEvent);\r\n procedure ControlSetOnClick(Value: TNotifyEvent);\r\n procedure ControlSetHint(const Value: string);\r\n procedure ControlSetAnchors(Value: TAnchors);\r\n end;\r\n\r\n TJvDynControlVCLLabel = class(TLabel, IUnknown,\r\n IJvDynControl, IJvDynControlCaption, IJvDynControlLabel, IJvDynControlAlign,\r\n IJvDynControlAutoSize, IJvDynControlColor,\r\n IJvDynControlAlignment, IJvDynControlFont)\r\n public\r\n function ControlGetCaption: string;\r\n procedure ControlSetDefaultProperties;\r\n procedure ControlSetCaption(const Value: string);\r\n procedure ControlSetTabOrder(Value: Integer);\r\n\r\n procedure ControlSetOnEnter(Value: TNotifyEvent);\r\n procedure ControlSetOnExit(Value: TNotifyEvent);\r\n procedure ControlSetOnClick(Value: TNotifyEvent);\r\n procedure ControlSetHint(const Value: string);\r\n procedure ControlSetAnchors(Value: TAnchors);\r\n\r\n procedure ControlSetFocusControl(Value: TWinControl);\r\n procedure ControlSetWordWrap(Value: Boolean);\r\n\r\n // IJvDynControlAlign\r\n procedure ControlSetAlign(Value: TAlign);\r\n\r\n // IJvDynControlAutoSize\r\n procedure ControlSetAutoSize(Value: Boolean);\r\n\r\n // IJvDynControlColor\r\n procedure ControlSetColor(Value: TColor);\r\n procedure ControlSetParentColor(Value: Boolean);\r\n\r\n //IJvDynControlAlignment\r\n procedure ControlSetAlignment(Value: TAlignment);\r\n\r\n //IJvDynControlFont\r\n procedure ControlSetFont(Value: TFont);\r\n function ControlGetFont: TFont;\r\n end;\r\n\r\n TJvDynControlVCLStaticText = class(TStaticText, IUnknown,\r\n IJvDynControl, IJvDynControlCaption, IJvDynControlAlign,\r\n IJvDynControlAutoSize, IJvDynControlColor,\r\n IJvDynControlAlignment, IJvDynControlFont)\r\n public\r\n function ControlGetCaption: string;\r\n procedure ControlSetDefaultProperties;\r\n procedure ControlSetCaption(const Value: string);\r\n procedure ControlSetTabOrder(Value: Integer);\r\n\r\n procedure ControlSetOnEnter(Value: TNotifyEvent);\r\n procedure ControlSetOnExit(Value: TNotifyEvent);\r\n procedure ControlSetOnClick(Value: TNotifyEvent);\r\n procedure ControlSetHint(const Value: string);\r\n procedure ControlSetAnchors(Value: TAnchors);\r\n\r\n // IJvDynControlAlign\r\n procedure ControlSetAlign(Value: TAlign);\r\n\r\n // IJvDynControlAutoSize\r\n procedure ControlSetAutoSize(Value: Boolean);\r\n // IJvDynControlColor\r\n procedure ControlSetColor(Value: TColor);\r\n procedure ControlSetParentColor(Value: Boolean);\r\n //IJvDynControlAlignment\r\n procedure ControlSetAlignment(Value: TAlignment);\r\n //IJvDynControlFont\r\n procedure ControlSetFont(Value: TFont);\r\n function ControlGetFont: TFont;\r\n end;\r\n\r\n TJvDynControlVCLButton = class(TBitBtn, IUnknown,\r\n IJvDynControl, IJvDynControlCaption, IJvDynControlButton, IJvDynControlAction)\r\n public\r\n function ControlGetCaption: string;\r\n procedure ControlSetDefaultProperties;\r\n procedure ControlSetCaption(const Value: string);\r\n procedure ControlSetTabOrder(Value: Integer);\r\n\r\n procedure ControlSetOnEnter(Value: TNotifyEvent);\r\n procedure ControlSetOnExit(Value: TNotifyEvent);\r\n procedure ControlSetOnClick(Value: TNotifyEvent);\r\n procedure ControlSetHint(const Value: string);\r\n procedure ControlSetAnchors(Value: TAnchors);\r\n\r\n procedure ControlSetGlyph(Value: TBitmap);\r\n procedure ControlSetNumGlyphs(Value: Integer);\r\n procedure ControlSetLayout(Value: TButtonLayout);\r\n procedure ControlSetDefault(Value: Boolean);\r\n procedure ControlSetCancel(Value: Boolean);\r\n\r\n // IJvDynControlAction\r\n procedure ControlSetAction(Value: TCustomAction);\r\n end;\r\n\r\n TJvDynControlVCLRadioButton = class(TRadioButton, IUnknown,\r\n IJvDynControl, IJvDynControlCaption, IJvDynControlData)\r\n public\r\n function ControlGetCaption: string;\r\n procedure ControlSetDefaultProperties;\r\n procedure ControlSetCaption(const Value: string);\r\n procedure ControlSetTabOrder(Value: Integer);\r\n\r\n procedure ControlSetOnEnter(Value: TNotifyEvent);\r\n procedure ControlSetOnExit(Value: TNotifyEvent);\r\n procedure ControlSetOnClick(Value: TNotifyEvent);\r\n procedure ControlSetHint(const Value: string);\r\n procedure ControlSetAnchors(Value: TAnchors);\r\n\r\n // IJvDynControlData\r\n procedure ControlSetOnChange(Value: TNotifyEvent);\r\n procedure ControlSetValue(Value: Variant);\r\n function ControlGetValue: Variant;\r\n end;\r\n\r\n TJvDynControlVCLTreeView = class(TTreeView, IUnknown,\r\n IJvDynControl, IJvDynControlTreeView, IJvDynControlReadOnly, IJvDynControlDblClick,\r\n IJvDynControlMouse)\r\n public\r\n procedure ControlSetDefaultProperties;\r\n procedure ControlSetTabOrder(Value: Integer);\r\n\r\n procedure ControlSetOnEnter(Value: TNotifyEvent);\r\n procedure ControlSetOnExit(Value: TNotifyEvent);\r\n procedure ControlSetOnClick(Value: TNotifyEvent);\r\n procedure ControlSetHint(const Value: string);\r\n procedure ControlSetAnchors(Value: TAnchors);\r\n\r\n // IJvDynControlReadOnly\r\n procedure ControlSetReadOnly(Value: Boolean);\r\n\r\n // IJvDynControlTreeView\r\n procedure ControlSetAutoExpand(Value: Boolean);\r\n procedure ControlSetHotTrack(Value: Boolean);\r\n procedure ControlSetShowHint(Value: Boolean);\r\n procedure ControlSetShowLines(Value: Boolean);\r\n procedure ControlSetShowRoot(Value: Boolean);\r\n procedure ControlSetToolTips(Value: Boolean);\r\n procedure ControlSetItems(Value: TTreeNodes);\r\n function ControlGetItems: TTreeNodes;\r\n procedure ControlSetImages(Value: TCustomImageList);\r\n procedure ControlSetStateImages(Value: TCustomImageList);\r\n function ControlGetSelected: TTreeNode;\r\n procedure ControlSetSelected(const Value: TTreeNode);\r\n procedure ControlSetOnChange(Value: TTVChangedEvent);\r\n procedure ControlSetOnChanging(Value: TTVChangingEvent);\r\n procedure ControlSetSortType(Value: TSortType);\r\n procedure ControlSortItems;\r\n\r\n //IJvDynControlDblClick = interface\r\n procedure ControlSetOnDblClick(Value: TNotifyEvent);\r\n\r\n function ControlGetOnMouseDown: TMouseEvent;\r\n function ControlGetOnMouseEnter: TNotifyEvent;\r\n function ControlGetOnMouseLeave: TNotifyEvent;\r\n function ControlGetOnMouseMove: TMouseMoveEvent;\r\n function ControlGetOnMouseUp: TMouseEvent;\r\n procedure ControlSetOnMouseDown(const Value: TMouseEvent);\r\n procedure ControlSetOnMouseEnter(const Value: TNotifyEvent);\r\n procedure ControlSetOnMouseLeave(const Value: TNotifyEvent);\r\n procedure ControlSetOnMouseMove(const Value: TMouseMoveEvent);\r\n procedure ControlSetOnMouseUp(const Value: TMouseEvent);\r\n end;\r\n\r\n TJvDynControlVCLProgressBar = class(TProgressBar, IUnknown, IJvDynControl,\r\n IJvDynControlCaption, IJvDynControlAlign, IJvDynControlProgressBar)\r\n public\r\n function ControlGetCaption: string;\r\n procedure ControlSetAlign(Value: TAlign);\r\n procedure ControlSetAnchors(Value: TAnchors);\r\n procedure ControlSetCaption(const Value: string);\r\n procedure ControlSetDefaultProperties;\r\n procedure ControlSetHint(const Value: string);\r\n //IJvDynControlProgressBar\r\n procedure ControlSetMarquee(Value: Boolean);\r\n procedure ControlSetMax(Value: Integer);\r\n procedure ControlSetMin(Value: Integer);\r\n procedure ControlSetOnClick(Value: TNotifyEvent);\r\n procedure ControlSetOnEnter(Value: TNotifyEvent);\r\n procedure ControlSetOnExit(Value: TNotifyEvent);\r\n procedure ControlSetOrientation(Value: TProgressBarOrientation);\r\n procedure ControlSetPosition(Value: Integer);\r\n procedure ControlSetSmooth(Value: Boolean);\r\n procedure ControlSetStep(Value: Integer);\r\n procedure ControlSetTabOrder(Value: Integer);\r\n end;\r\n\r\n TJvDynControlVCLTabControl = class(TTabControl, IUnknown,\r\n IJvDynControl, IJvDynControlTabControl)\r\n public\r\n procedure ControlSetDefaultProperties;\r\n procedure ControlSetTabOrder(Value: Integer);\r\n\r\n procedure ControlSetOnEnter(Value: TNotifyEvent);\r\n procedure ControlSetOnExit(Value: TNotifyEvent);\r\n procedure ControlSetOnClick(Value: TNotifyEvent);\r\n procedure ControlSetHint(const Value: string);\r\n procedure ControlSetAnchors(Value: TAnchors);\r\n\r\n //IJvDynControlTabControl\r\n procedure ControlCreateTab(const AName: string);\r\n procedure ControlSetOnChangeTab(OnChangeEvent: TNotifyEvent);\r\n procedure ControlSetOnChangingTab(OnChangingEvent: TTabChangingEvent);\r\n procedure ControlSetTabIndex(Index: Integer);\r\n function ControlGetTabIndex: Integer;\r\n procedure ControlSetMultiLine(Value: Boolean);\r\n procedure ControlSetScrollOpposite(Value: Boolean);\r\n procedure ControlSetHotTrack(Value: Boolean);\r\n procedure ControlSetRaggedRight(Value: Boolean);\r\n end;\r\n\r\n TJvDynControlVCLPageControl = class(TPageControl, IUnknown,\r\n IJvDynControl, IJvDynControlTabControl, IJvDynControlPageControl)\r\n public\r\n procedure ControlSetDefaultProperties;\r\n procedure ControlSetTabOrder(Value: Integer);\r\n\r\n procedure ControlSetOnEnter(Value: TNotifyEvent);\r\n procedure ControlSetOnExit(Value: TNotifyEvent);\r\n procedure ControlSetOnClick(Value: TNotifyEvent);\r\n procedure ControlSetHint(const Value: string);\r\n procedure ControlSetAnchors(Value: TAnchors);\r\n\r\n //IJvDynControlTabControl\r\n procedure ControlCreateTab(const AName: string);\r\n procedure ControlSetOnChangeTab(OnChangeEvent: TNotifyEvent);\r\n procedure ControlSetOnChangingTab(OnChangingEvent: TTabChangingEvent);\r\n procedure ControlSetTabIndex(Index: Integer);\r\n function ControlGetTabIndex: Integer;\r\n procedure ControlSetMultiLine(Value: Boolean);\r\n procedure ControlSetScrollOpposite(Value: Boolean);\r\n procedure ControlSetHotTrack(Value: Boolean);\r\n procedure ControlSetRaggedRight(Value: Boolean);\r\n\r\n //IJvDynControlPageControl\r\n function ControlGetPage(const PageName: string): TWinControl;\r\n end;\r\n\r\n TJvDynControlVCLColorComboBox = class(TColorBox, IUnknown, IJvDynControl,\r\n IJvDynControlColorComboBoxControl)\r\n public\r\n procedure ControlSetDefaultProperties;\r\n procedure ControlSetTabOrder(Value: Integer);\r\n\r\n procedure ControlSetOnEnter(Value: TNotifyEvent);\r\n procedure ControlSetOnExit(Value: TNotifyEvent);\r\n procedure ControlSetOnChange(Value: TNotifyEvent);\r\n procedure ControlSetOnClick(Value: TNotifyEvent);\r\n procedure ControlSetHint(const Value: string);\r\n procedure ControlSetAnchors(Value: TAnchors);\r\n\r\n procedure ControlSetValue(Value: Variant);\r\n function ControlGetValue: Variant;\r\n\r\n //IJvDynControlColorComboBoxControl\r\n function ControlGetColorName(AColor: TColor): string;\r\n function ControlGetSelectedColor: TColor;\r\n procedure ControlSetSelectedColor(const Value: TColor);\r\n function GetControlDefaultColor: TColor; stdcall;\r\n procedure SetControlDefaultColor(const Value: TColor); stdcall;\r\n end;\r\n\r\nfunction DynControlEngineVCL: TJvDynControlEngine;\r\nprocedure SetDynControlEngineVCLDefault;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvDynControlEngineVCL.pas $';\r\n Revision: '$Revision: 13415 $';\r\n Date: '$Date: 2012-09-10 11:51:54 +0200 (lun. 10 sept. 2012) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n SysUtils,\r\n JvDynControlEngineTools, JvJCLUtils;\r\n\r\nvar\r\n IntDynControlEngineVCL: TJvDynControlEngine = nil;\r\n\r\n//=== { TJvDynControlVCLMaskEdit } ===========================================\r\n\r\nprocedure TJvDynControlVCLMaskEdit.ControlSetDefaultProperties;\r\nbegin\r\nend;\r\n\r\nprocedure TJvDynControlVCLMaskEdit.ControlSetReadOnly(Value: Boolean);\r\nbegin\r\n ReadOnly := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLMaskEdit.ControlSetTabOrder(Value: Integer);\r\nbegin\r\n TabOrder := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLMaskEdit.ControlSetOnEnter(Value: TNotifyEvent);\r\nbegin\r\n OnEnter := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLMaskEdit.ControlSetOnExit(Value: TNotifyEvent);\r\nbegin\r\n OnExit := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLMaskEdit.ControlSetOnChange(Value: TNotifyEvent);\r\nbegin\r\n OnChange := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLMaskEdit.ControlSetOnClick(Value: TNotifyEvent);\r\nbegin\r\nend;\r\n\r\nprocedure TJvDynControlVCLMaskEdit.ControlSetHint(const Value: string);\r\nbegin\r\n Hint := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLMaskEdit.ControlSetAnchors(Value: TAnchors);\r\nbegin\r\n Anchors := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLMaskEdit.ControlSetValue(Value: Variant);\r\nbegin\r\n Text := VarToStr(Value);\r\nend;\r\n\r\nfunction TJvDynControlVCLMaskEdit.ControlGetValue: Variant;\r\nbegin\r\n Result := Text;\r\nend;\r\n\r\nprocedure TJvDynControlVCLMaskEdit.ControlSetPasswordChar(Value: Char);\r\nbegin\r\n PasswordChar := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLMaskEdit.ControlSetEditMask(const Value: string);\r\nbegin\r\n EditMask := Value;\r\nend;\r\n\r\n//=== { TJvDynControlVCLButtonEdit } =========================================\r\n\r\nconstructor TJvDynControlVCLButtonEdit.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FEditControl := TMaskEdit.Create(AOwner);\r\n FEditControl.Parent := Self;\r\n FButton := TBitBtn.Create(AOwner);\r\n FButton.Parent := Self;\r\n FButton.Align := alRight;\r\n FButton.Caption := '...';\r\n Height := FEditControl.Height;\r\n FButton.Width := Height;\r\n FEditControl.Align := alClient;\r\n BevelInner := bvNone;\r\n BevelOuter := bvNone;\r\nend;\r\n\r\ndestructor TJvDynControlVCLButtonEdit.Destroy;\r\nbegin\r\n FreeAndNil(FEditControl);\r\n FreeAndNil(FButton);\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvDynControlVCLButtonEdit.ControlSetDefaultProperties;\r\nbegin\r\n Self.Caption := ' ';\r\nend;\r\n\r\nprocedure TJvDynControlVCLButtonEdit.ControlSetReadOnly(Value: Boolean);\r\nbegin\r\n FEditControl.ReadOnly := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLButtonEdit.ControlSetTabOrder(Value: Integer);\r\nbegin\r\n TabOrder := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLButtonEdit.ControlSetOnEnter(Value: TNotifyEvent);\r\nbegin\r\n OnEnter := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLButtonEdit.ControlSetOnExit(Value: TNotifyEvent);\r\nbegin\r\n OnExit := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLButtonEdit.ControlSetOnChange(Value: TNotifyEvent);\r\nbegin\r\n FEditControl.OnChange := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLButtonEdit.ControlSetOnClick(Value: TNotifyEvent);\r\nbegin\r\n FEditControl.OnClick := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLButtonEdit.ControlSetHint(const Value: string);\r\nbegin\r\n Hint := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLButtonEdit.ControlSetAnchors(Value: TAnchors);\r\nbegin\r\n Anchors := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLButtonEdit.ControlSetValue(Value: Variant);\r\nbegin\r\n FEditControl.Text := VarToStr(Value);\r\nend;\r\n\r\nfunction TJvDynControlVCLButtonEdit.ControlGetValue: Variant;\r\nbegin\r\n Result := FEditControl.Text;\r\nend;\r\n\r\n\r\n\r\nprocedure TJvDynControlVCLButtonEdit.ControlSetPasswordChar(Value: Char);\r\nbegin\r\n FEditControl.PasswordChar := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLButtonEdit.ControlSetEditMask(const Value: string);\r\nbegin\r\n FEditControl.EditMask := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLButtonEdit.ControlSetOnButtonClick(Value: TNotifyEvent);\r\nbegin\r\n FButton.OnClick := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLButtonEdit.ControlSetButtonCaption(const Value: string);\r\nbegin\r\n FButton.Caption := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLButtonEdit.ControlSetGlyph(Value: TBitmap);\r\nbegin\r\n FButton.Glyph.Assign(Value);\r\nend;\r\n\r\nprocedure TJvDynControlVCLButtonEdit.ControlSetNumGlyphs(Value: Integer);\r\nbegin\r\n FButton.NumGlyphs := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLButtonEdit.ControlSetLayout(Value: TButtonLayout);\r\nbegin\r\n FButton.Layout := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLButtonEdit.ControlSetDefault(Value: Boolean);\r\nbegin\r\n FButton.Default := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLButtonEdit.ControlSetCancel(Value: Boolean);\r\nbegin\r\n FButton.Cancel := Value;\r\nend;\r\n\r\n//=== { TJvDynControlVCLFileNameEdit } =======================================\r\n\r\nconstructor TJvDynControlVCLFileNameEdit.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FEditControl := TMaskEdit.Create(AOwner);\r\n FEditControl.Parent := Self;\r\n FButton := TBitBtn.Create(AOwner);\r\n FButton.Parent := Self;\r\n FButton.Align := alRight;\r\n FButton.OnClick := DefaultOnButtonClick;\r\n FButton.Caption := '...';\r\n Height := FEditControl.Height;\r\n FButton.Width := Height;\r\n FEditControl.Align := alClient;\r\n FDialogOptions := [ofHideReadOnly, ofEnableSizing];\r\n BevelInner := bvNone;\r\n BevelOuter := bvNone;\r\n FDialogKind := jdkOpen;\r\nend;\r\n\r\ndestructor TJvDynControlVCLFileNameEdit.Destroy;\r\nbegin\r\n FreeAndNil(FEditControl);\r\n FreeAndNil(FButton);\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvDynControlVCLFileNameEdit.DefaultOnButtonClick(Sender: TObject);\r\nbegin\r\n case FDialogKind of\r\n jdkOpen:\r\n with TOpenDialog.Create(Self) do\r\n try\r\n Options := FDialogOptions;\r\n Title := FDialogTitle;\r\n Filter := FFilter;\r\n FilterIndex := FFilterIndex;\r\n InitialDir := FInitialDir;\r\n DefaultExt := FDefaultExt;\r\n FileName := ControlGetValue;\r\n if Execute then\r\n ControlSetValue(FileName);\r\n finally\r\n Free;\r\n end;\r\n jdkOpenPicture:\r\n with TOpenPictureDialog.Create(Self) do\r\n try\r\n Options := FDialogOptions;\r\n Title := FDialogTitle;\r\n Filter := FFilter;\r\n FilterIndex := FFilterIndex;\r\n InitialDir := FInitialDir;\r\n DefaultExt := FDefaultExt;\r\n FileName := ControlGetValue;\r\n if Execute then\r\n ControlSetValue(FileName);\r\n finally\r\n Free;\r\n end;\r\n jdkSave:\r\n with TSaveDialog.Create(Self) do\r\n try\r\n Options := FDialogOptions;\r\n Title := FDialogTitle;\r\n Filter := FFilter;\r\n FilterIndex := FFilterIndex;\r\n InitialDir := FInitialDir;\r\n DefaultExt := FDefaultExt;\r\n FileName := ControlGetValue;\r\n if Execute then\r\n ControlSetValue(FileName);\r\n finally\r\n Free;\r\n end;\r\n jdkSavePicture:\r\n with TSavePictureDialog.Create(Self) do\r\n try\r\n Options := FDialogOptions;\r\n Title := FDialogTitle;\r\n Filter := FFilter;\r\n FilterIndex := FFilterIndex;\r\n InitialDir := FInitialDir;\r\n DefaultExt := FDefaultExt;\r\n FileName := ControlGetValue;\r\n if Execute then\r\n ControlSetValue(FileName);\r\n finally\r\n Free;\r\n end;\r\n end;\r\n if FEditControl.CanFocus then\r\n FEditControl.SetFocus;\r\nend;\r\n\r\nprocedure TJvDynControlVCLFileNameEdit.ControlSetDefaultProperties;\r\nbegin\r\n Caption := ' ';\r\nend;\r\n\r\nprocedure TJvDynControlVCLFileNameEdit.ControlSetReadOnly(Value: Boolean);\r\nbegin\r\n FEditControl.ReadOnly := Value;\r\n FButton.Enabled := not Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLFileNameEdit.ControlSetTabOrder(Value: Integer);\r\nbegin\r\n TabOrder := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLFileNameEdit.ControlSetOnEnter(Value: TNotifyEvent);\r\nbegin\r\n FEditControl.OnEnter := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLFileNameEdit.ControlSetOnExit(Value: TNotifyEvent);\r\nbegin\r\n FEditControl.OnExit := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLFileNameEdit.ControlSetOnChange(Value: TNotifyEvent);\r\nbegin\r\n FEditControl.OnChange := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLFileNameEdit.ControlSetOnClick(Value: TNotifyEvent);\r\nbegin\r\nend;\r\n\r\nprocedure TJvDynControlVCLFileNameEdit.ControlSetHint(const Value: string);\r\nbegin\r\n Hint := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLFileNameEdit.ControlSetAnchors(Value: TAnchors);\r\nbegin\r\n Anchors := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLFileNameEdit.ControlSetValue(Value: Variant);\r\nbegin\r\n FEditControl.Text := VarToStr(Value);\r\nend;\r\n\r\nfunction TJvDynControlVCLFileNameEdit.ControlGetValue: Variant;\r\nbegin\r\n Result := FEditControl.Text;\r\nend;\r\n\r\n// IJvDynControlFileName\r\n\r\nprocedure TJvDynControlVCLFileNameEdit.ControlSetInitialDir(const Value: string);\r\nbegin\r\n FInitialDir := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLFileNameEdit.ControlSetDefaultExt(const Value: string);\r\nbegin\r\n FDefaultExt := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLFileNameEdit.ControlSetDialogTitle(const Value: string);\r\nbegin\r\n FDialogTitle := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLFileNameEdit.ControlSetDialogOptions(Value: TOpenOptions);\r\nbegin\r\n FDialogOptions := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLFileNameEdit.ControlSetFilter(const Value: string);\r\nbegin\r\n FFilter := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLFileNameEdit.ControlSetFilterIndex(Value: Integer);\r\nbegin\r\n FFilterIndex := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLFileNameEdit.ControlSetDialogKind(Value: TJvDynControlFileNameDialogKind);\r\nbegin\r\n FDialogKind := Value;\r\nend;\r\n\r\n//=== { TJvDynControlVCLDirectoryEdit } ======================================\r\n\r\nconstructor TJvDynControlVCLDirectoryEdit.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FEditControl := TMaskEdit.Create(AOwner);\r\n FEditControl.Parent := Self;\r\n FButton := TBitBtn.Create(AOwner);\r\n FButton.Parent := Self;\r\n FButton.Align := alRight;\r\n FButton.OnClick := DefaultOnButtonClick;\r\n FButton.Caption := '...';\r\n Height := FEditControl.Height;\r\n FButton.Width := Height;\r\n FEditControl.Align := alClient;\r\n BevelInner := bvNone;\r\n BevelOuter := bvNone;\r\nend;\r\n\r\ndestructor TJvDynControlVCLDirectoryEdit.Destroy;\r\nbegin\r\n FreeAndNil(FEditControl);\r\n FreeAndNil(FButton);\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvDynControlVCLDirectoryEdit.DefaultOnButtonClick(Sender: TObject);\r\nvar\r\n Opt: TSelectDirOpts;\r\n Dir: string;\r\nbegin\r\n Dir := ControlGetValue;\r\n if Dir = '' then\r\n if FInitialDir <> '' then\r\n Dir := FInitialDir\r\n else\r\n Dir := PathDelim;\r\n if not DirectoryExists(Dir) then\r\n Dir := PathDelim;\r\n if SelectDirectory(Dir, Opt, HelpContext) then\r\n ControlSetValue(Dir);\r\n if FEditControl.CanFocus then\r\n FEditControl.SetFocus;\r\nend;\r\n\r\nprocedure TJvDynControlVCLDirectoryEdit.ControlSetDefaultProperties;\r\nbegin\r\n Self.Caption := ' ';\r\nend;\r\n\r\nprocedure TJvDynControlVCLDirectoryEdit.ControlSetReadOnly(Value: Boolean);\r\nbegin\r\n FEditControl.ReadOnly := Value;\r\n FButton.Enabled := not Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLDirectoryEdit.ControlSetTabOrder(Value: Integer);\r\nbegin\r\n TabOrder := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLDirectoryEdit.ControlSetOnEnter(Value: TNotifyEvent);\r\nbegin\r\n FEditControl.OnEnter := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLDirectoryEdit.ControlSetOnExit(Value: TNotifyEvent);\r\nbegin\r\n FEditControl.OnExit := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLDirectoryEdit.ControlSetOnChange(Value: TNotifyEvent);\r\nbegin\r\n FEditControl.OnChange := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLDirectoryEdit.ControlSetOnClick(Value: TNotifyEvent);\r\nbegin\r\n\r\nend;\r\n\r\nprocedure TJvDynControlVCLDirectoryEdit.ControlSetHint(const Value: string);\r\nbegin\r\n Hint := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLDirectoryEdit.ControlSetAnchors(Value: TAnchors);\r\nbegin\r\n Anchors := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLDirectoryEdit.ControlSetValue(Value: Variant);\r\nbegin\r\n FEditControl.Text := VarToStr(Value);\r\nend;\r\n\r\nfunction TJvDynControlVCLDirectoryEdit.ControlGetValue: Variant;\r\nbegin\r\n Result := FEditControl.Text;\r\nend;\r\n\r\nprocedure TJvDynControlVCLDirectoryEdit.ControlSetInitialDir(const Value: string);\r\nbegin\r\n FInitialDir := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLDirectoryEdit.ControlSetDialogTitle(const Value: string);\r\nbegin\r\n FDialogTitle := Value;\r\nend;\r\n\r\n\r\nprocedure TJvDynControlVCLDirectoryEdit.ControlSetDialogOptions(Value: TSelectDirOpts);\r\nbegin\r\n FDialogOptions := Value;\r\nend;\r\n\r\n\r\n\r\n//=== { TJvDynControlVCLDateTimeEdit } =======================================\r\n\r\nconstructor TJvDynControlVCLDateTimeEdit.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n Caption := '';\r\n BorderStyle := bsNone;\r\n BevelInner := bvNone;\r\n BevelOuter := bvNone;\r\n FDatePicker := TDateTimePicker.Create(Self);\r\n FDatePicker.Parent := Self;\r\n FDatePicker.Align := alLeft;\r\n FDatePicker.Top := 0;\r\n FDatePicker.Left := 0;\r\n FTimePicker := TDateTimePicker.Create(Self);\r\n FTimePicker.Align := alClient;\r\n FTimePicker.Parent := Self;\r\n FTimePicker.Top := 0;\r\n FTimePicker.Left := 0;\r\n Height := FDatePicker.Height;\r\n Width := FDatePicker.Width + FTimePicker.Width;\r\n OnResize := ControlResize;\r\n ControlResize(nil);\r\n FDatePicker.DateFormat := dfShort;\r\n FDatePicker.DateMode := dmComboBox;\r\n FDatePicker.Kind := dtkDate;\r\n FTimePicker.DateFormat := dfShort;\r\n FTimePicker.DateMode := dmUpDown;\r\n FTimePicker.Kind := dtkTime;\r\nend;\r\n\r\ndestructor TJvDynControlVCLDateTimeEdit.Destroy;\r\nbegin\r\n FreeAndNil(FDatePicker);\r\n FreeAndNil(FTimePicker);\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvDynControlVCLDateTimeEdit.ControlResize(Sender: TObject);\r\nbegin\r\n FDatePicker.Height := Round(Height / 2);\r\n FTimePicker.Height := Height;\r\n FDatePicker.Width := Round(Width / 2);\r\nend;\r\n\r\nprocedure TJvDynControlVCLDateTimeEdit.ControlSetDefaultProperties;\r\nbegin\r\n Self.Caption := ' ';\r\nend;\r\n\r\nprocedure TJvDynControlVCLDateTimeEdit.ControlSetTabOrder(Value: Integer);\r\nbegin\r\n TabOrder := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLDateTimeEdit.ControlSetOnEnter(Value: TNotifyEvent);\r\nbegin\r\n FDatePicker.OnEnter := Value;\r\n FTimePicker.OnEnter := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLDateTimeEdit.ControlSetOnExit(Value: TNotifyEvent);\r\nbegin\r\n FDatePicker.OnExit := Value;\r\n FTimePicker.OnExit := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLDateTimeEdit.ControlSetOnChange(Value: TNotifyEvent);\r\nbegin\r\n FDatePicker.OnChange := Value;\r\n FTimePicker.OnChange := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLDateTimeEdit.ControlSetOnClick(Value: TNotifyEvent);\r\nbegin\r\nend;\r\n\r\nprocedure TJvDynControlVCLDateTimeEdit.ControlSetHint(const Value: string);\r\nbegin\r\n Hint := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLDateTimeEdit.ControlSetAnchors(Value: TAnchors);\r\nbegin\r\n Anchors := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLDateTimeEdit.ControlSetValue(Value: Variant);\r\nbegin\r\n FDatePicker.Date := Value;\r\n FTimePicker.Time := Value;\r\nend;\r\n\r\nfunction TJvDynControlVCLDateTimeEdit.ControlGetValue: Variant;\r\nbegin\r\n { TODO -oAHUser : Delphi.NET workaround }\r\n Result := Trunc(FDatePicker.Date) + (Trunc(FTimePicker.Time) - FTimePicker.Time);\r\nend;\r\n\r\n// IJvDynControlDate\r\n\r\nprocedure TJvDynControlVCLDateTimeEdit.ControlSetMinDate(Value: TDateTime);\r\nbegin\r\n FDatePicker.MinDate := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLDateTimeEdit.ControlSetMaxDate(Value: TDateTime);\r\nbegin\r\n FDatePicker.MaxDate := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLDateTimeEdit.ControlSetFormat(const Value: string);\r\nbegin\r\n FDatePicker.Format := Value;\r\n FTimePicker.Format := Value;\r\nend;\r\n\r\n//=== { TJvDynControlVCLDateEdit } ===========================================\r\n\r\nprocedure TJvDynControlVCLDateEdit.ControlSetDefaultProperties;\r\nbegin\r\n DateFormat := dfShort;\r\n DateMode := dmComboBox;\r\n Kind := dtkDate;\r\nend;\r\n\r\nprocedure TJvDynControlVCLDateEdit.ControlSetTabOrder(Value: Integer);\r\nbegin\r\n TabOrder := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLDateEdit.ControlSetOnEnter(Value: TNotifyEvent);\r\nbegin\r\n OnEnter := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLDateEdit.ControlSetOnExit(Value: TNotifyEvent);\r\nbegin\r\n OnExit := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLDateEdit.ControlSetOnChange(Value: TNotifyEvent);\r\nbegin\r\n OnChange := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLDateEdit.ControlSetOnClick(Value: TNotifyEvent);\r\nbegin\r\n\r\nend;\r\n\r\nprocedure TJvDynControlVCLDateEdit.ControlSetHint(const Value: string);\r\nbegin\r\n Hint := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLDateEdit.ControlSetAnchors(Value: TAnchors);\r\nbegin\r\n Anchors := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLDateEdit.ControlSetValue(Value: Variant);\r\nbegin\r\n Date := Value;\r\nend;\r\n\r\nfunction TJvDynControlVCLDateEdit.ControlGetValue: Variant;\r\nbegin\r\n Result := Date;\r\nend;\r\n\r\n// IJvDynControlDate\r\n\r\nprocedure TJvDynControlVCLDateEdit.ControlSetMinDate(Value: TDateTime);\r\nbegin\r\n MinDate := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLDateEdit.ControlSetMaxDate(Value: TDateTime);\r\nbegin\r\n MaxDate := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLDateEdit.ControlSetFormat(const Value: string);\r\nbegin\r\n Format := Value;\r\nend;\r\n\r\n//=== { TJvDynControlVCLTimeEdit } ===========================================\r\n\r\nprocedure TJvDynControlVCLTimeEdit.ControlSetDefaultProperties;\r\nbegin\r\n DateFormat := dfShort;\r\n Kind := dtkTime;\r\n DateMode := dmUpDown;\r\nend;\r\n\r\nprocedure TJvDynControlVCLTimeEdit.ControlSetTabOrder(Value: Integer);\r\nbegin\r\n TabOrder := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLTimeEdit.ControlSetOnEnter(Value: TNotifyEvent);\r\nbegin\r\n OnEnter := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLTimeEdit.ControlSetOnExit(Value: TNotifyEvent);\r\nbegin\r\n OnExit := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLTimeEdit.ControlSetOnChange(Value: TNotifyEvent);\r\nbegin\r\n OnChange := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLTimeEdit.ControlSetOnClick(Value: TNotifyEvent);\r\nbegin\r\nend;\r\n\r\nprocedure TJvDynControlVCLTimeEdit.ControlSetHint(const Value: string);\r\nbegin\r\n Hint := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLTimeEdit.ControlSetAnchors(Value: TAnchors);\r\nbegin\r\n Anchors := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLTimeEdit.ControlSetValue(Value: Variant);\r\nbegin\r\n Time := Value;\r\nend;\r\n\r\nfunction TJvDynControlVCLTimeEdit.ControlGetValue: Variant;\r\nbegin\r\n Result := Time;\r\nend;\r\n\r\nprocedure TJvDynControlVCLTimeEdit.ControlSetFormat(const Value: string);\r\nbegin\r\n Format := Value;\r\nend;\r\n\r\n\r\n\r\n//=== { TJvDynControlVCLCheckBox } ===========================================\r\n\r\nfunction TJvDynControlVCLCheckBox.ControlGetCaption: string;\r\nbegin\r\n Result := Caption;\r\nend;\r\n\r\nprocedure TJvDynControlVCLCheckBox.ControlSetDefaultProperties;\r\nbegin\r\nend;\r\n\r\nprocedure TJvDynControlVCLCheckBox.ControlSetCaption(const Value: string);\r\nbegin\r\n if Caption <> Value then\r\n Caption := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLCheckBox.ControlSetTabOrder(Value: Integer);\r\nbegin\r\n TabOrder := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLCheckBox.ControlSetOnEnter(Value: TNotifyEvent);\r\nbegin\r\n OnEnter := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLCheckBox.ControlSetOnExit(Value: TNotifyEvent);\r\nbegin\r\n OnExit := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLCheckBox.ControlSetOnChange(Value: TNotifyEvent);\r\nbegin\r\n OnClick := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLCheckBox.ControlSetOnClick(Value: TNotifyEvent);\r\nbegin\r\n OnClick := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLCheckBox.ControlSetHint(const Value: string);\r\nbegin\r\n Hint := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLCheckBox.ControlSetAnchors(Value: TAnchors);\r\nbegin\r\n Anchors := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLCheckBox.ControlSetValue(Value: Variant);\r\nbegin\r\n Checked := JvDynControlVariantToBoolean(Value);\r\nend;\r\n\r\nfunction TJvDynControlVCLCheckBox.ControlGetValue: Variant;\r\nbegin\r\n Result := Checked;\r\nend;\r\n\r\nprocedure TJvDynControlVCLCheckBox.ControlSetFont(Value: TFont);\r\nbegin\r\n Font.Assign(Value);\r\nend;\r\n\r\nfunction TJvDynControlVCLCheckBox.ControlGetFont: TFont;\r\nbegin\r\n Result := Font;\r\nend;\r\n\r\n//IJvDynControlCheckBox\r\n\r\nprocedure TJvDynControlVCLCheckBox.ControlSetAllowGrayed(Value: Boolean);\r\nbegin\r\n AllowGrayed := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLCheckBox.ControlSetState(Value: TCheckBoxState);\r\nbegin\r\n State := Value;\r\nend;\r\n\r\nfunction TJvDynControlVCLCheckBox.ControlGetState: TCheckBoxState;\r\nbegin\r\n Result := State;\r\nend;\r\n\r\nfunction TJvDynControlVCLMemo.ControlGetFont: TFont;\r\nbegin\r\n Result := Font;\r\nend;\r\n\r\n//=== { TJvDynControlVCLMemo } ===============================================\r\n\r\nprocedure TJvDynControlVCLMemo.ControlSetDefaultProperties;\r\nbegin\r\nend;\r\n\r\nprocedure TJvDynControlVCLMemo.ControlSetReadOnly(Value: Boolean);\r\nbegin\r\n ReadOnly := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLMemo.ControlSetTabOrder(Value: Integer);\r\nbegin\r\n TabOrder := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLMemo.ControlSetOnEnter(Value: TNotifyEvent);\r\nbegin\r\n OnEnter := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLMemo.ControlSetOnExit(Value: TNotifyEvent);\r\nbegin\r\n OnExit := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLMemo.ControlSetOnChange(Value: TNotifyEvent);\r\nbegin\r\n OnChange := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLMemo.ControlSetOnClick(Value: TNotifyEvent);\r\nbegin\r\n OnClick := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLMemo.ControlSetHint(const Value: string);\r\nbegin\r\n Hint := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLMemo.ControlSetAnchors(Value: TAnchors);\r\nbegin\r\n Anchors := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLMemo.ControlSetValue(Value: Variant);\r\nbegin\r\n Text := VarToStr(Value);\r\nend;\r\n\r\nfunction TJvDynControlVCLMemo.ControlGetValue: Variant;\r\nbegin\r\n Result := Text;\r\nend;\r\n\r\nprocedure TJvDynControlVCLMemo.ControlSetSorted(Value: Boolean);\r\nbegin\r\nend;\r\n\r\nprocedure TJvDynControlVCLMemo.ControlSetItems(Value: TStrings);\r\nbegin\r\n Lines.Assign(Value);\r\nend;\r\n\r\nfunction TJvDynControlVCLMemo.ControlGetItems: TStrings;\r\nbegin\r\n Result := Lines;\r\nend;\r\n\r\nprocedure TJvDynControlVCLMemo.ControlSetWantTabs(Value: Boolean);\r\nbegin\r\n WantTabs := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLMemo.ControlSetWantReturns(Value: Boolean);\r\nbegin\r\n WantReturns := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLMemo.ControlSetWordWrap(Value: Boolean);\r\nbegin\r\n WordWrap := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLMemo.ControlSetScrollBars(Value: TScrollStyle);\r\nbegin\r\n ScrollBars := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLMemo.ControlSetAlignment(Value: TAlignment);\r\nbegin\r\n Alignment := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLMemo.ControlSetFont(Value: TFont);\r\nbegin\r\n Font.Assign(Value);\r\nend;\r\n\r\nfunction TJvDynControlVCLRichEdit.ControlGetFont: TFont;\r\nbegin\r\n Result := Font;\r\nend;\r\n\r\n//=== { TJvDynControlVCLRichEdit } ===========================================\r\n\r\nprocedure TJvDynControlVCLRichEdit.ControlSetDefaultProperties;\r\nbegin\r\nend;\r\n\r\nprocedure TJvDynControlVCLRichEdit.ControlSetReadOnly(Value: Boolean);\r\nbegin\r\n ReadOnly := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLRichEdit.ControlSetTabOrder(Value: Integer);\r\nbegin\r\n TabOrder := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLRichEdit.ControlSetOnEnter(Value: TNotifyEvent);\r\nbegin\r\n OnEnter := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLRichEdit.ControlSetOnExit(Value: TNotifyEvent);\r\nbegin\r\n OnExit := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLRichEdit.ControlSetOnChange(Value: TNotifyEvent);\r\nbegin\r\n OnChange := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLRichEdit.ControlSetOnClick(Value: TNotifyEvent);\r\nbegin\r\n OnClick := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLRichEdit.ControlSetHint(const Value: string);\r\nbegin\r\n Hint := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLRichEdit.ControlSetAnchors(Value: TAnchors);\r\nbegin\r\n Anchors := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLRichEdit.ControlSetValue(Value: Variant);\r\nbegin\r\n Text := VarToStr(Value);\r\nend;\r\n\r\nfunction TJvDynControlVCLRichEdit.ControlGetValue: Variant;\r\nbegin\r\n Result := Text;\r\nend;\r\n\r\nprocedure TJvDynControlVCLRichEdit.ControlSetSorted(Value: Boolean);\r\nbegin\r\nend;\r\n\r\nprocedure TJvDynControlVCLRichEdit.ControlSetItems(Value: TStrings);\r\nbegin\r\n Lines.Assign(Value);\r\nend;\r\n\r\nfunction TJvDynControlVCLRichEdit.ControlGetItems: TStrings;\r\nbegin\r\n Result := Lines;\r\nend;\r\n\r\nprocedure TJvDynControlVCLRichEdit.ControlSetFont(Value: TFont);\r\nbegin\r\n Font.Assign(Value);\r\nend;\r\n\r\nprocedure TJvDynControlVCLRichEdit.ControlSetWantTabs(Value: Boolean);\r\nbegin\r\n WantTabs := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLRichEdit.ControlSetWantReturns(Value: Boolean);\r\nbegin\r\n WantReturns := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLRichEdit.ControlSetWordWrap(Value: Boolean);\r\nbegin\r\n WordWrap := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLRichEdit.ControlSetScrollBars(Value: TScrollStyle);\r\nbegin\r\n ScrollBars := Value;\r\nend;\r\n\r\n//=== { TJvDynControlVCLRadioGroup } ===========================================\r\n\r\nprocedure TJvDynControlVCLRadioGroup.ControlSetDefaultProperties;\r\nbegin\r\nend;\r\n\r\nfunction TJvDynControlVCLRadioGroup.ControlGetCaption: string;\r\nbegin\r\n Result := Caption;\r\nend;\r\n\r\nprocedure TJvDynControlVCLRadioGroup.ControlSetCaption(const Value: string);\r\nbegin\r\n if Caption <> Value then\r\n Caption := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLRadioGroup.ControlSetTabOrder(Value: Integer);\r\nbegin\r\n TabOrder := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLRadioGroup.ControlSetOnEnter(Value: TNotifyEvent);\r\nbegin\r\n OnEnter := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLRadioGroup.ControlSetOnExit(Value: TNotifyEvent);\r\nbegin\r\n OnExit := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLRadioGroup.ControlSetOnChange(Value: TNotifyEvent);\r\nbegin\r\n OnClick := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLRadioGroup.ControlSetOnClick(Value: TNotifyEvent);\r\nbegin\r\n OnClick := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLRadioGroup.ControlSetHint(const Value: string);\r\nbegin\r\n Hint := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLRadioGroup.ControlSetAnchors(Value: TAnchors);\r\nbegin\r\n Anchors := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLRadioGroup.ControlSetValue(Value: Variant);\r\nbegin\r\n if VarIsInt(Value) then\r\n ItemIndex := Value\r\n else\r\n ItemIndex := Items.IndexOf(VarToStr(Value));\r\nend;\r\n\r\nfunction TJvDynControlVCLRadioGroup.ControlGetValue: Variant;\r\nbegin\r\n Result := ItemIndex;\r\nend;\r\n\r\nprocedure TJvDynControlVCLRadioGroup.ControlSetSorted(Value: Boolean);\r\nbegin\r\nend;\r\n\r\nprocedure TJvDynControlVCLRadioGroup.ControlSetItems(Value: TStrings);\r\nbegin\r\n Items.Assign(Value);\r\nend;\r\n\r\nfunction TJvDynControlVCLRadioGroup.ControlGetItems: TStrings;\r\nbegin\r\n Result := Items;\r\nend;\r\n\r\nprocedure TJvDynControlVCLRadioGroup.ControlSetColumns(Value: Integer);\r\nbegin\r\n Columns := Value;\r\nend;\r\n\r\nfunction TJvDynControlVCLListBox.ControlGetItemIndex: Integer;\r\nbegin\r\n Result := ItemIndex;\r\nend;\r\n\r\n//=== { TJvDynControlVCLListBox } ============================================\r\n\r\nprocedure TJvDynControlVCLListBox.ControlSetDefaultProperties;\r\nbegin\r\nend;\r\n\r\nprocedure TJvDynControlVCLListBox.ControlSetTabOrder(Value: Integer);\r\nbegin\r\n TabOrder := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLListBox.ControlSetOnEnter(Value: TNotifyEvent);\r\nbegin\r\n OnEnter := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLListBox.ControlSetOnExit(Value: TNotifyEvent);\r\nbegin\r\n OnExit := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLListBox.ControlSetOnChange(Value: TNotifyEvent);\r\nbegin\r\n // OnChange := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLListBox.ControlSetOnClick(Value: TNotifyEvent);\r\nbegin\r\n OnClick := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLListBox.ControlSetHint(const Value: string);\r\nbegin\r\n Hint := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLListBox.ControlSetAnchors(Value: TAnchors);\r\nbegin\r\n Anchors := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLListBox.ControlSetValue(Value: Variant);\r\nbegin\r\n if VarIsInt(Value) then\r\n ItemIndex := Value\r\n else\r\n ItemIndex := Items.IndexOf(VarToStr(Value));\r\nend;\r\n\r\nfunction TJvDynControlVCLListBox.ControlGetValue: Variant;\r\nbegin\r\n Result := ItemIndex;\r\nend;\r\n\r\nprocedure TJvDynControlVCLListBox.ControlSetSorted(Value: Boolean);\r\nbegin\r\n Sorted := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLListBox.ControlSetItems(Value: TStrings);\r\nbegin\r\n Items.Assign(Value);\r\nend;\r\n\r\nfunction TJvDynControlVCLListBox.ControlGetItems: TStrings;\r\nbegin\r\n Result := Items;\r\nend;\r\n\r\nprocedure TJvDynControlVCLListBox.ControlSetItemIndex(const Value: Integer);\r\nbegin\r\n ItemIndex := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLListBox.ControlSetOnDblClick(Value: TNotifyEvent);\r\nbegin\r\n OnDblClick := Value;\r\nend;\r\n\r\nfunction TJvDynControlVCLListBox.ControlGetOnKeyDown: TKeyEvent;\r\nbegin\r\n Result := OnKeyDown;\r\nend;\r\n\r\nfunction TJvDynControlVCLListBox.ControlGetOnKeyPress: TKeyPressEvent;\r\nbegin\r\n Result := OnKeyPress;\r\nend;\r\n\r\nfunction TJvDynControlVCLListBox.ControlGetOnKeyUp: TKeyEvent;\r\nbegin\r\n Result := OnKeyUp;\r\nend;\r\n\r\nfunction TJvDynControlVCLListBox.ControlGetOnMouseDown: TMouseEvent;\r\nbegin\r\n Result := OnMouseDown;\r\nend;\r\n\r\nfunction TJvDynControlVCLListBox.ControlGetOnMouseEnter: TNotifyEvent;\r\nbegin\r\n {$IFDEF DELPHI2007_UP}\r\n Result := OnMouseEnter;\r\n {$ENDIF DELPHI2007_UP}\r\nend;\r\n\r\nfunction TJvDynControlVCLListBox.ControlGetOnMouseLeave: TNotifyEvent;\r\nbegin\r\n {$IFDEF DELPHI2007_UP}\r\n Result := OnMouseLeave;\r\n {$ENDIF DELPHI2007_UP}\r\nend;\r\n\r\nfunction TJvDynControlVCLListBox.ControlGetOnMouseMove: TMouseMoveEvent;\r\nbegin\r\n Result := OnMouseMove;\r\nend;\r\n\r\nfunction TJvDynControlVCLListBox.ControlGetOnMouseUp: TMouseEvent;\r\nbegin\r\n Result := OnMouseUp;\r\nend;\r\n\r\nprocedure TJvDynControlVCLListBox.ControlSetOnKeyDown(const Value: TKeyEvent);\r\nbegin\r\n OnKeyDown := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLListBox.ControlSetOnKeyPress(const Value: TKeyPressEvent);\r\nbegin\r\n OnKeyPress := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLListBox.ControlSetOnKeyUp(const Value: TKeyEvent);\r\nbegin\r\n OnKeyUp := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLListBox.ControlSetOnMouseDown(const Value: TMouseEvent);\r\nbegin\r\n OnMouseDown := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLListBox.ControlSetOnMouseEnter(const Value: TNotifyEvent);\r\nbegin\r\n {$IFDEF DELPHI2007_UP}\r\n OnMouseEnter := Value;\r\n {$ENDIF DELPHI2007_UP}\r\nend;\r\n\r\nprocedure TJvDynControlVCLListBox.ControlSetOnMouseLeave(const Value: TNotifyEvent);\r\nbegin\r\n {$IFDEF DELPHI2007_UP}\r\n OnMouseEnter := Value;\r\n {$ENDIF DELPHI2007_UP}\r\nend;\r\n\r\nprocedure TJvDynControlVCLListBox.ControlSetOnMouseMove(const Value: TMouseMoveEvent);\r\nbegin\r\n OnMouseMove := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLListBox.ControlSetOnMouseUp(const Value: TMouseEvent);\r\nbegin\r\n OnMouseUp := Value;\r\nend;\r\n\r\n//=== { TJvDynControlVCLCheckListBox } =======================================\r\n\r\nprocedure TJvDynControlVCLCheckListBox.ControlSetDefaultProperties;\r\nbegin\r\nend;\r\n\r\nprocedure TJvDynControlVCLCheckListBox.ControlSetTabOrder(Value: Integer);\r\nbegin\r\n TabOrder := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLCheckListBox.ControlSetOnEnter(Value: TNotifyEvent);\r\nbegin\r\n OnEnter := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLCheckListBox.ControlSetOnExit(Value: TNotifyEvent);\r\nbegin\r\n OnExit := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLCheckListBox.ControlSetOnChange(Value: TNotifyEvent);\r\nbegin\r\n // OnChange := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLCheckListBox.ControlSetOnClick(Value: TNotifyEvent);\r\nbegin\r\n OnClick := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLCheckListBox.ControlSetHint(const Value: string);\r\nbegin\r\n Hint := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLCheckListBox.ControlSetAnchors(Value: TAnchors);\r\nbegin\r\n Anchors := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLCheckListBox.ControlSetValue(Value: Variant);\r\nbegin\r\n if VarIsInt(Value) then\r\n ItemIndex := Value\r\n else\r\n ItemIndex := Items.IndexOf(VarToStr(Value));\r\nend;\r\n\r\nfunction TJvDynControlVCLCheckListBox.ControlGetValue: Variant;\r\nbegin\r\n Result := ItemIndex;\r\nend;\r\n\r\nprocedure TJvDynControlVCLCheckListBox.ControlSetSorted(Value: Boolean);\r\nbegin\r\n Sorted := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLCheckListBox.ControlSetItems(Value: TStrings);\r\nbegin\r\n Items.Assign(Value);\r\nend;\r\n\r\nfunction TJvDynControlVCLCheckListBox.ControlGetItems: TStrings;\r\nbegin\r\n Result := Items;\r\nend;\r\n\r\nprocedure TJvDynControlVCLCheckListBox.ControlSetOnDblClick(Value: TNotifyEvent);\r\nbegin\r\n OnDblClick := Value;\r\nend;\r\n\r\n//IJvDynControlCheckListBox = interface\r\n\r\nprocedure TJvDynControlVCLCheckListBox.ControlSetAllowGrayed(Value: Boolean);\r\nbegin\r\n AllowGrayed := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLCheckListBox.ControlSetChecked(Index: Integer; Value: Boolean);\r\nbegin\r\n Checked[Index] := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLCheckListBox.ControlSetItemEnabled(Index: Integer; Value: Boolean);\r\nbegin\r\n ItemEnabled[Index] := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLCheckListBox.ControlSetHeader(Index: Integer; Value: Boolean);\r\nbegin\r\n Header[Index] := Value;\r\nend;\r\n\r\nfunction TJvDynControlVCLCheckListBox.ControlGetHeader(Index: Integer): Boolean;\r\nbegin\r\n Result := Header[Index];\r\nend;\r\n\r\nprocedure TJvDynControlVCLCheckListBox.ControlSetState(Index: Integer; Value: TCheckBoxState);\r\nbegin\r\n State[Index] := Value;\r\nend;\r\n\r\nfunction TJvDynControlVCLCheckListBox.ControlGetChecked(Index: Integer): Boolean;\r\nbegin\r\n Result := Checked[Index];\r\nend;\r\n\r\nfunction TJvDynControlVCLCheckListBox.ControlGetItemEnabled(Index: Integer): Boolean;\r\nbegin\r\n Result := ItemEnabled[Index];\r\nend;\r\n\r\nfunction TJvDynControlVCLCheckListBox.ControlGetState(Index: Integer): TCheckBoxState;\r\nbegin\r\n Result := State[Index];\r\nend;\r\n\r\n//=== { TJvDynControlVCLComboBox } ===========================================\r\n\r\nprocedure TJvDynControlVCLComboBox.ControlSetDefaultProperties;\r\nbegin\r\nend;\r\n\r\nprocedure TJvDynControlVCLComboBox.ControlSetTabOrder(Value: Integer);\r\nbegin\r\n TabOrder := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLComboBox.ControlSetOnEnter(Value: TNotifyEvent);\r\nbegin\r\n OnEnter := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLComboBox.ControlSetOnExit(Value: TNotifyEvent);\r\nbegin\r\n OnExit := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLComboBox.ControlSetOnChange(Value: TNotifyEvent);\r\nbegin\r\n OnChange := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLComboBox.ControlSetOnClick(Value: TNotifyEvent);\r\nbegin\r\n OnClick := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLComboBox.ControlSetHint(const Value: string);\r\nbegin\r\n Hint := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLComboBox.ControlSetAnchors(Value: TAnchors);\r\nbegin\r\n Anchors := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLComboBox.ControlSetValue(Value: Variant);\r\nbegin\r\n if (Style = csDropDownList) then\r\n if VarIsInt(Value) then\r\n ItemIndex := VarToInt(Value)\r\n else\r\n ItemIndex := Items.IndexOf(VarToStr(Value))\r\n else\r\n Text := VarToStr(Value);\r\nend;\r\n\r\nfunction TJvDynControlVCLComboBox.ControlGetValue: Variant;\r\nbegin\r\n Result := Text;\r\nend;\r\n\r\nprocedure TJvDynControlVCLComboBox.ControlSetSorted(Value: Boolean);\r\nbegin\r\n Sorted := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLComboBox.ControlSetItems(Value: TStrings);\r\nbegin\r\n Items.Assign(Value);\r\nend;\r\n\r\nfunction TJvDynControlVCLComboBox.ControlGetItems: TStrings;\r\nbegin\r\n Result := Items;\r\nend;\r\n\r\nprocedure TJvDynControlVCLComboBox.ControlSetNewEntriesAllowed(Value: Boolean);\r\nconst\r\n Styles: array[Boolean] of TComboBoxStyle =\r\n (csDropDownList, csDropDown);\r\nbegin\r\n Style := Styles[Value];\r\nend;\r\n\r\nfunction TJvDynControlVCLGroupBox.ControlGetCaption: string;\r\nbegin\r\n Result := Caption;\r\nend;\r\n\r\n//=== { TJvDynControlVCLGroupBox } ===========================================\r\n\r\nprocedure TJvDynControlVCLGroupBox.ControlSetDefaultProperties;\r\nbegin\r\nend;\r\n\r\nprocedure TJvDynControlVCLGroupBox.ControlSetCaption(const Value: string);\r\nbegin\r\n if Caption <> Value then\r\n Caption := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLGroupBox.ControlSetTabOrder(Value: Integer);\r\nbegin\r\n TabOrder := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLGroupBox.ControlSetOnEnter(Value: TNotifyEvent);\r\nbegin\r\n OnEnter := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLGroupBox.ControlSetOnExit(Value: TNotifyEvent);\r\nbegin\r\n OnExit := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLGroupBox.ControlSetOnClick(Value: TNotifyEvent);\r\nbegin\r\nend;\r\n\r\nprocedure TJvDynControlVCLGroupBox.ControlSetHint(const Value: string);\r\nbegin\r\n Hint := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLGroupBox.ControlSetAnchors(Value: TAnchors);\r\nbegin\r\n Anchors := Value;\r\nend;\r\n\r\nfunction TJvDynControlVCLPanel.ControlGetCaption: string;\r\nbegin\r\n Result := Caption;\r\nend;\r\n\r\n//=== { TJvDynControlVCLPanel } ==============================================\r\n\r\nprocedure TJvDynControlVCLPanel.ControlSetDefaultProperties;\r\nbegin\r\n BevelInner := bvNone;\r\n BevelOuter := bvNone;\r\nend;\r\n\r\nprocedure TJvDynControlVCLPanel.ControlSetCaption(const Value: string);\r\nbegin\r\n if Caption <> Value then\r\n Caption := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLPanel.ControlSetTabOrder(Value: Integer);\r\nbegin\r\n TabOrder := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLPanel.ControlSetOnEnter(Value: TNotifyEvent);\r\nbegin\r\n OnEnter := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLPanel.ControlSetOnExit(Value: TNotifyEvent);\r\nbegin\r\n OnExit := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLPanel.ControlSetOnClick(Value: TNotifyEvent);\r\nbegin\r\nend;\r\n\r\nprocedure TJvDynControlVCLPanel.ControlSetHint(const Value: string);\r\nbegin\r\n Hint := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLPanel.ControlSetBorder(ABevelInner: TPanelBevel; ABevelOuter: TPanelBevel;\r\n ABevelWidth: Integer; ABorderStyle: TBorderStyle; ABorderWidth: Integer);\r\nbegin\r\n BorderWidth := ABorderWidth;\r\n BorderStyle := ABorderStyle;\r\n BevelInner := ABevelInner;\r\n BevelOuter := ABevelOuter;\r\n BevelWidth := ABevelWidth;\r\nend;\r\n\r\nprocedure TJvDynControlVCLPanel.ControlSetAlign(Value: TAlign);\r\nbegin\r\n Align := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLPanel.ControlSetAnchors(Value: TAnchors);\r\nbegin\r\n Anchors := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLPanel.ControlSetAutoSize(Value: Boolean);\r\nbegin\r\n AutoSize := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLPanel.ControlSetBevelInner(Value: TBevelCut);\r\nbegin\r\n BevelInner := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLPanel.ControlSetBevelKind(Value: TBevelKind);\r\nbegin\r\n BevelKind := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLPanel.ControlSetBevelOuter(Value: TBevelCut);\r\nbegin\r\n BevelOuter := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLPanel.ControlSetBorderStyle(Value: TBorderStyle);\r\nbegin\r\n BorderStyle := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLPanel.ControlSetBorderWidth(Value: Integer);\r\nbegin\r\n BorderWidth := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLPanel.ControlSetColor(Value: TColor);\r\nbegin\r\n Color := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLPanel.ControlSetParentColor(Value: Boolean);\r\nbegin\r\n ParentColor := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLPanel.ControlSetAlignment(Value: TAlignment);\r\nbegin\r\n Alignment := Value;\r\nend;\r\n\r\n//=== { TJvDynControlVCLImage } ==============================================\r\n\r\nprocedure TJvDynControlVCLImage.ControlSetDefaultProperties;\r\nbegin\r\nend;\r\n\r\nprocedure TJvDynControlVCLImage.ControlSetTabOrder(Value: Integer);\r\nbegin\r\n // TabOrder := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLImage.ControlSetOnEnter(Value: TNotifyEvent);\r\nbegin\r\n // OnEnter := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLImage.ControlSetOnExit(Value: TNotifyEvent);\r\nbegin\r\n // OnExit := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLImage.ControlSetOnClick(Value: TNotifyEvent);\r\nbegin\r\n OnClick := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLImage.ControlSetHint(const Value: string);\r\nbegin\r\n Hint := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLImage.ControlSetAnchors(Value: TAnchors);\r\nbegin\r\n Anchors := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLImage.ControlSetAutoSize(Value: Boolean);\r\nbegin\r\n AutoSize := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLImage.ControlSetIncrementalDisplay(Value: Boolean);\r\nbegin\r\n IncrementalDisplay := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLImage.ControlSetCenter(Value: Boolean);\r\nbegin\r\n Center := Value;\r\nend;\r\n\r\n\r\n\r\nprocedure TJvDynControlVCLImage.ControlSetProportional(Value: Boolean);\r\nbegin\r\n Proportional := Value;\r\nend;\r\n\r\n\r\nprocedure TJvDynControlVCLImage.ControlSetStretch(Value: Boolean);\r\nbegin\r\n Stretch := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLImage.ControlSetTransparent(Value: Boolean);\r\nbegin\r\n Transparent := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLImage.ControlSetPicture(Value: TPicture);\r\nbegin\r\n Picture.Assign(Value);\r\nend;\r\n\r\nprocedure TJvDynControlVCLImage.ControlSetGraphic(Value: TGraphic);\r\nbegin\r\n Picture.Assign(Value);\r\nend;\r\n\r\nfunction TJvDynControlVCLImage.ControlGetPicture: TPicture;\r\nbegin\r\n Result := Picture;\r\nend;\r\n\r\nfunction TJvDynControlVCLScrollBox.ControlGetCaption: string;\r\nbegin\r\n Result := Caption;\r\nend;\r\n\r\n//=== { TJvDynControlVCLScrollBox } ==========================================\r\n\r\nprocedure TJvDynControlVCLScrollBox.ControlSetDefaultProperties;\r\nbegin\r\nend;\r\n\r\nprocedure TJvDynControlVCLScrollBox.ControlSetCaption(const Value: string);\r\nbegin\r\n if Caption <> Value then\r\n Caption := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLScrollBox.ControlSetTabOrder(Value: Integer);\r\nbegin\r\n TabOrder := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLScrollBox.ControlSetOnEnter(Value: TNotifyEvent);\r\nbegin\r\n OnEnter := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLScrollBox.ControlSetOnExit(Value: TNotifyEvent);\r\nbegin\r\n OnExit := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLScrollBox.ControlSetOnClick(Value: TNotifyEvent);\r\nbegin\r\nend;\r\n\r\nprocedure TJvDynControlVCLScrollBox.ControlSetHint(const Value: string);\r\nbegin\r\n Hint := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLScrollBox.ControlSetAnchors(Value: TAnchors);\r\nbegin\r\n Anchors := Value;\r\nend;\r\n\r\nfunction TJvDynControlVCLLabel.ControlGetCaption: string;\r\nbegin\r\n Result := Caption;\r\nend;\r\n\r\n//=== { TJvDynControlVCLLabel } ==============================================\r\n\r\nprocedure TJvDynControlVCLLabel.ControlSetDefaultProperties;\r\nbegin\r\nend;\r\n\r\nprocedure TJvDynControlVCLLabel.ControlSetCaption(const Value: string);\r\nbegin\r\n if Caption <> Value then\r\n Caption := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLLabel.ControlSetTabOrder(Value: Integer);\r\nbegin\r\nend;\r\n\r\nprocedure TJvDynControlVCLLabel.ControlSetOnEnter(Value: TNotifyEvent);\r\nbegin\r\nend;\r\n\r\nprocedure TJvDynControlVCLLabel.ControlSetOnExit(Value: TNotifyEvent);\r\nbegin\r\nend;\r\n\r\nprocedure TJvDynControlVCLLabel.ControlSetOnClick(Value: TNotifyEvent);\r\nbegin\r\nend;\r\n\r\nprocedure TJvDynControlVCLLabel.ControlSetHint(const Value: string);\r\nbegin\r\n Hint := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLLabel.ControlSetFocusControl(Value: TWinControl);\r\nbegin\r\n FocusControl := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLLabel.ControlSetWordWrap(Value: Boolean);\r\nbegin\r\n WordWrap := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLLabel.ControlSetAnchors(Value: TAnchors);\r\nbegin\r\n Anchors := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLLabel.ControlSetAlign(Value: TAlign);\r\nbegin\r\n Align := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLLabel.ControlSetAutoSize(Value: Boolean);\r\nbegin\r\n AutoSize := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLLabel.ControlSetColor(Value: TColor);\r\nbegin\r\n Color := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLLabel.ControlSetParentColor(Value: Boolean);\r\nbegin\r\n ParentColor := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLLabel.ControlSetAlignment(Value: TAlignment);\r\nbegin\r\n Alignment := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLLabel.ControlSetFont(Value: TFont);\r\nbegin\r\n Font.Assign(Value);\r\nend;\r\n\r\nfunction TJvDynControlVCLLabel.ControlGetFont: TFont;\r\nbegin\r\n Result := Font;\r\nend;\r\n\r\nfunction TJvDynControlVCLStaticText.ControlGetCaption: string;\r\nbegin\r\n Result := Caption;\r\nend;\r\n\r\n//=== { TJvDynControlVCLStaticText } =========================================\r\n\r\n\r\nprocedure TJvDynControlVCLStaticText.ControlSetDefaultProperties;\r\nbegin\r\nend;\r\n\r\nprocedure TJvDynControlVCLStaticText.ControlSetCaption(const Value: string);\r\nbegin\r\n if Caption <> Value then\r\n Caption := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLStaticText.ControlSetTabOrder(Value: Integer);\r\nbegin\r\nend;\r\n\r\nprocedure TJvDynControlVCLStaticText.ControlSetOnEnter(Value: TNotifyEvent);\r\nbegin\r\nend;\r\n\r\nprocedure TJvDynControlVCLStaticText.ControlSetOnExit(Value: TNotifyEvent);\r\nbegin\r\nend;\r\n\r\nprocedure TJvDynControlVCLStaticText.ControlSetOnClick(Value: TNotifyEvent);\r\nbegin\r\nend;\r\n\r\nprocedure TJvDynControlVCLStaticText.ControlSetHint(const Value: string);\r\nbegin\r\n Hint := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLStaticText.ControlSetAlign(Value: TAlign);\r\nbegin\r\n Align := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLStaticText.ControlSetAnchors(Value: TAnchors);\r\nbegin\r\n Anchors := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLStaticText.ControlSetAutoSize(Value: Boolean);\r\nbegin\r\n AutoSize := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLStaticText.ControlSetColor(Value: TColor);\r\nbegin\r\n Color := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLStaticText.ControlSetParentColor(Value: Boolean);\r\nbegin\r\n ParentColor := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLStaticText.ControlSetAlignment(Value: TAlignment);\r\nbegin\r\n Alignment := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLStaticText.ControlSetFont(Value: TFont);\r\nbegin\r\n Font.Assign(Value);\r\nend;\r\n\r\nfunction TJvDynControlVCLStaticText.ControlGetFont: TFont;\r\nbegin\r\n Result := Font;\r\nend;\r\n\r\nfunction TJvDynControlVCLButton.ControlGetCaption: string;\r\nbegin\r\n Result := Caption;\r\nend;\r\n\r\n//=== { TJvDynControlVCLButton } =============================================\r\n\r\nprocedure TJvDynControlVCLButton.ControlSetDefaultProperties;\r\nbegin\r\nend;\r\n\r\nprocedure TJvDynControlVCLButton.ControlSetCaption(const Value: string);\r\nbegin\r\n if Caption <> Value then\r\n Caption := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLButton.ControlSetTabOrder(Value: Integer);\r\nbegin\r\nend;\r\n\r\nprocedure TJvDynControlVCLButton.ControlSetOnEnter(Value: TNotifyEvent);\r\nbegin\r\nend;\r\n\r\nprocedure TJvDynControlVCLButton.ControlSetOnExit(Value: TNotifyEvent);\r\nbegin\r\nend;\r\n\r\nprocedure TJvDynControlVCLButton.ControlSetOnClick(Value: TNotifyEvent);\r\nbegin\r\n OnClick := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLButton.ControlSetAnchors(Value: TAnchors);\r\nbegin\r\n Anchors := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLButton.ControlSetHint(const Value: string);\r\nbegin\r\n Hint := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLButton.ControlSetGlyph(Value: TBitmap);\r\nbegin\r\n Glyph.Assign(Value);\r\nend;\r\n\r\nprocedure TJvDynControlVCLButton.ControlSetNumGlyphs(Value: Integer);\r\nbegin\r\n NumGlyphs := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLButton.ControlSetLayout(Value: TButtonLayout);\r\nbegin\r\n Layout := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLButton.ControlSetDefault(Value: Boolean);\r\nbegin\r\n Default := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLButton.ControlSetCancel(Value: Boolean);\r\nbegin\r\n Cancel := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLButton.ControlSetAction(Value: TCustomAction);\r\nbegin\r\n Action := Value;\r\nend;\r\n\r\nfunction TJvDynControlVCLRadioButton.ControlGetCaption: string;\r\nbegin\r\n Result := Caption;\r\nend;\r\n\r\n//=== { TJvDynControlVCLRadioButton } ========================================\r\n\r\nprocedure TJvDynControlVCLRadioButton.ControlSetDefaultProperties;\r\nbegin\r\nend;\r\n\r\nprocedure TJvDynControlVCLRadioButton.ControlSetCaption(const Value: string);\r\nbegin\r\n if Caption <> Value then\r\n Caption := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLRadioButton.ControlSetTabOrder(Value: Integer);\r\nbegin\r\n TabOrder := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLRadioButton.ControlSetOnEnter(Value: TNotifyEvent);\r\nbegin\r\n OnEnter := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLRadioButton.ControlSetOnExit(Value: TNotifyEvent);\r\nbegin\r\n OnExit := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLRadioButton.ControlSetOnClick(Value: TNotifyEvent);\r\nbegin\r\n OnClick := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLRadioButton.ControlSetAnchors(Value: TAnchors);\r\nbegin\r\n Anchors := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLRadioButton.ControlSetHint(const Value: string);\r\nbegin\r\n Hint := Value;\r\nend;\r\n\r\n// IJvDynControlData\r\n\r\nprocedure TJvDynControlVCLRadioButton.ControlSetOnChange(Value: TNotifyEvent);\r\nbegin\r\n OnClick := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLRadioButton.ControlSetValue(Value: Variant);\r\nbegin\r\n Checked := JvDynControlVariantToBoolean(Value);\r\nend;\r\n\r\nfunction TJvDynControlVCLRadioButton.ControlGetValue: Variant;\r\nbegin\r\n Result := Checked;\r\nend;\r\n\r\n//=== { TJvDynControlVCLTreeView } ===========================================\r\n\r\nprocedure TJvDynControlVCLTreeView.ControlSetDefaultProperties;\r\nbegin\r\nend;\r\n\r\nprocedure TJvDynControlVCLTreeView.ControlSetTabOrder(Value: Integer);\r\nbegin\r\n TabOrder := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLTreeView.ControlSetOnEnter(Value: TNotifyEvent);\r\nbegin\r\n OnEnter := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLTreeView.ControlSetOnExit(Value: TNotifyEvent);\r\nbegin\r\n OnExit := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLTreeView.ControlSetOnClick(Value: TNotifyEvent);\r\nbegin\r\n OnClick := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLTreeView.ControlSetHint(const Value: string);\r\nbegin\r\n Hint := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLTreeView.ControlSetAnchors(Value: TAnchors);\r\nbegin\r\n Anchors := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLTreeView.ControlSetReadOnly(Value: Boolean);\r\nbegin\r\n ReadOnly := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLTreeView.ControlSetAutoExpand(Value: Boolean);\r\nbegin\r\n AutoExpand := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLTreeView.ControlSetHotTrack(Value: Boolean);\r\nbegin\r\n HotTrack := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLTreeView.ControlSetShowHint(Value: Boolean);\r\nbegin\r\n ShowHint := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLTreeView.ControlSetShowLines(Value: Boolean);\r\nbegin\r\n ShowLines := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLTreeView.ControlSetShowRoot(Value: Boolean);\r\nbegin\r\n ShowRoot := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLTreeView.ControlSetToolTips(Value: Boolean);\r\nbegin\r\n ToolTips := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLTreeView.ControlSetItems(Value: TTreeNodes);\r\nbegin\r\n Items.Assign(Value);\r\nend;\r\n\r\nfunction TJvDynControlVCLTreeView.ControlGetItems: TTreeNodes;\r\nbegin\r\n Result := Items;\r\nend;\r\n\r\nfunction TJvDynControlVCLTreeView.ControlGetOnMouseDown: TMouseEvent;\r\nbegin\r\n Result := OnMouseDown;\r\nend;\r\n\r\nfunction TJvDynControlVCLTreeView.ControlGetOnMouseEnter: TNotifyEvent;\r\nbegin\r\n {$IFDEF DELPHI2007_UP}\r\n Result := OnMouseEnter;\r\n {$ENDIF DELPHI2007_UP}\r\nend;\r\n\r\nfunction TJvDynControlVCLTreeView.ControlGetOnMouseLeave: TNotifyEvent;\r\nbegin\r\n {$IFDEF DELPHI2007_UP}\r\n Result := OnMouseLeave;\r\n {$ENDIF DELPHI2007_UP}\r\nend;\r\n\r\nfunction TJvDynControlVCLTreeView.ControlGetOnMouseMove: TMouseMoveEvent;\r\nbegin\r\n Result := OnMouseMove;\r\nend;\r\n\r\nfunction TJvDynControlVCLTreeView.ControlGetOnMouseUp: TMouseEvent;\r\nbegin\r\n Result := OnMouseUp;\r\nend;\r\n\r\nprocedure TJvDynControlVCLTreeView.ControlSetImages(Value: TCustomImageList);\r\nbegin\r\n Images.Assign(Value);\r\nend;\r\n\r\nprocedure TJvDynControlVCLTreeView.ControlSetStateImages(Value: TCustomImageList);\r\nbegin\r\n StateImages.Assign(Value);\r\nend;\r\n\r\nfunction TJvDynControlVCLTreeView.ControlGetSelected: TTreeNode;\r\nbegin\r\n Result := Selected;\r\nend;\r\n\r\nprocedure TJvDynControlVCLTreeView.ControlSetOnChange(Value: TTVChangedEvent);\r\nbegin\r\n OnChange := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLTreeView.ControlSetOnChanging(Value:\r\n TTVChangingEvent);\r\nbegin\r\n OnChanging := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLTreeView.ControlSetSortType(Value: TSortType);\r\nbegin\r\n SortType := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLTreeView.ControlSetOnDblClick(Value: TNotifyEvent);\r\nbegin\r\n OnDblClick := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLTreeView.ControlSetOnMouseDown(const Value: TMouseEvent);\r\nbegin\r\n OnMouseDown := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLTreeView.ControlSetOnMouseEnter(const Value: TNotifyEvent);\r\nbegin\r\n {$IFDEF DELPHI2007_UP}\r\n OnMouseEnter := Value;\r\n {$ENDIF DELPHI2007_UP}\r\nend;\r\n\r\nprocedure TJvDynControlVCLTreeView.ControlSetOnMouseLeave(const Value: TNotifyEvent);\r\nbegin\r\n {$IFDEF DELPHI2007_UP}\r\n OnMouseEnter := Value;\r\n {$ENDIF DELPHI2007_UP}\r\nend;\r\n\r\nprocedure TJvDynControlVCLTreeView.ControlSetOnMouseMove(const Value: TMouseMoveEvent);\r\nbegin\r\n OnMouseMove := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLTreeView.ControlSetOnMouseUp(const Value: TMouseEvent);\r\nbegin\r\n OnMouseUp := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLTreeView.ControlSortItems;\r\nbegin\r\n AlphaSort;\r\nend;\r\n\r\nprocedure TJvDynControlVCLTreeView.ControlSetSelected(const Value: TTreeNode);\r\nbegin\r\n Selected := Value;\r\nend;\r\n\r\nfunction TJvDynControlVCLProgressBar.ControlGetCaption: string;\r\nbegin\r\n Result := Caption;\r\nend;\r\n\r\nprocedure TJvDynControlVCLProgressBar.ControlSetAlign(Value: TAlign);\r\nbegin\r\n Align := Value;\r\nend;\r\n\r\n//=== { TJvDynControlVCLProgressbar } ========================================\r\n\r\nprocedure TJvDynControlVCLProgressbar.ControlSetDefaultProperties;\r\nbegin\r\nend;\r\n\r\nprocedure TJvDynControlVCLProgressbar.ControlSetCaption(const Value: string);\r\nbegin\r\n if Caption <> Value then\r\n Caption := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLProgressbar.ControlSetTabOrder(Value: Integer);\r\nbegin\r\n TabOrder := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLProgressbar.ControlSetOnEnter(Value: TNotifyEvent);\r\nbegin\r\n OnEnter := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLProgressbar.ControlSetOnExit(Value: TNotifyEvent);\r\nbegin\r\n OnExit := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLProgressbar.ControlSetOnClick(Value: TNotifyEvent);\r\nbegin\r\n OnClick := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLProgressbar.ControlSetHint(const Value: string);\r\nbegin\r\n Hint := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLProgressbar.ControlSetAnchors(Value: TAnchors);\r\nbegin\r\n Anchors := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLProgressBar.ControlSetMarquee(Value: Boolean);\r\nbegin\r\n {$IFDEF DELPHI2009_UP}\r\n if Value then\r\n Style := pbstMarquee\r\n else\r\n Style := pbstNormal;\r\n {$ENDIF DELPHI2009_UP}\r\nend;\r\n\r\nprocedure TJvDynControlVCLProgressbar.ControlSetMax(Value: Integer);\r\nbegin\r\n Max := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLProgressbar.ControlSetMin(Value: Integer);\r\nbegin\r\n Min := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLProgressbar.ControlSetOrientation(Value: TProgressBarOrientation);\r\nbegin\r\n Orientation := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLProgressbar.ControlSetPosition(Value: Integer);\r\nbegin\r\n Position := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLProgressbar.ControlSetSmooth(Value: Boolean);\r\nbegin\r\n Smooth := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLProgressbar.ControlSetStep(Value: Integer);\r\nbegin\r\n Step := Value;\r\nend;\r\n\r\n//=== { TJvDynControlVCLTabControl } =========================================\r\n\r\nprocedure TJvDynControlVCLTabControl.ControlSetDefaultProperties;\r\nbegin\r\nend;\r\n\r\nprocedure TJvDynControlVCLTabControl.ControlSetTabOrder(Value: Integer);\r\nbegin\r\n TabOrder := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLTabControl.ControlSetOnEnter(Value: TNotifyEvent);\r\nbegin\r\n OnEnter := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLTabControl.ControlSetOnExit(Value: TNotifyEvent);\r\nbegin\r\n OnExit := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLTabControl.ControlSetOnClick(Value: TNotifyEvent);\r\nbegin\r\n OnClick := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLTabControl.ControlSetHint(const Value: string);\r\nbegin\r\n Hint := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLTabControl.ControlSetAnchors(Value: TAnchors);\r\nbegin\r\n Anchors := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLTabControl.ControlCreateTab(const AName: string);\r\nbegin\r\n Tabs.Add(AName);\r\nend;\r\n\r\nprocedure TJvDynControlVCLTabControl.ControlSetOnChangeTab(OnChangeEvent: TNotifyEvent);\r\nbegin\r\n OnChange := OnChangeEvent;\r\nend;\r\n\r\nprocedure TJvDynControlVCLTabControl.ControlSetOnChangingTab(OnChangingEvent: TTabChangingEvent);\r\nbegin\r\n OnChanging := OnChangingEvent;\r\nend;\r\n\r\nprocedure TJvDynControlVCLTabControl.ControlSetTabIndex(Index: Integer);\r\nbegin\r\n TabIndex := Index;\r\nend;\r\n\r\nfunction TJvDynControlVCLTabControl.ControlGetTabIndex: Integer;\r\nbegin\r\n Result := TabIndex;\r\nend;\r\n\r\nprocedure TJvDynControlVCLTabControl.ControlSetMultiLine(Value: Boolean);\r\nbegin\r\n MultiLine := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLTabControl.ControlSetScrollOpposite(Value: Boolean);\r\nbegin\r\n ScrollOpposite := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLTabControl.ControlSetHotTrack(Value: Boolean);\r\nbegin\r\n HotTrack := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLTabControl.ControlSetRaggedRight(Value: Boolean);\r\nbegin\r\n RaggedRight := Value;\r\nend;\r\n\r\n//=== { TJvDynControlVCLPageControl } ========================================\r\n\r\nprocedure TJvDynControlVCLPageControl.ControlSetDefaultProperties;\r\nbegin\r\nend;\r\n\r\nprocedure TJvDynControlVCLPageControl.ControlSetTabOrder(Value: Integer);\r\nbegin\r\n TabOrder := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLPageControl.ControlSetOnEnter(Value: TNotifyEvent);\r\nbegin\r\n OnEnter := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLPageControl.ControlSetOnExit(Value: TNotifyEvent);\r\nbegin\r\n OnExit := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLPageControl.ControlSetOnClick(Value: TNotifyEvent);\r\nbegin\r\n OnClick := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLPageControl.ControlSetHint(const Value: string);\r\nbegin\r\n Hint := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLPageControl.ControlSetAnchors(Value: TAnchors);\r\nbegin\r\n Anchors := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLPageControl.ControlCreateTab(const AName: string);\r\nvar\r\n TabSheet: TTabSheet;\r\nbegin\r\n TabSheet := TTabSheet.Create(Self);\r\n TabSheet.Caption := AName;\r\n TabSheet.PageControl := Self;\r\n TabSheet.Parent := Self;\r\nend;\r\n\r\nprocedure TJvDynControlVCLPageControl.ControlSetOnChangeTab(OnChangeEvent: TNotifyEvent);\r\nbegin\r\n OnChange := OnChangeEvent;\r\nend;\r\n\r\nprocedure TJvDynControlVCLPageControl.ControlSetOnChangingTab(OnChangingEvent: TTabChangingEvent);\r\nbegin\r\n OnChanging := OnChangingEvent;\r\nend;\r\n\r\nprocedure TJvDynControlVCLPageControl.ControlSetTabIndex(Index: Integer);\r\nbegin\r\n TabIndex := Index;\r\nend;\r\n\r\nfunction TJvDynControlVCLPageControl.ControlGetTabIndex: Integer;\r\nbegin\r\n Result := TabIndex;\r\nend;\r\n\r\nprocedure TJvDynControlVCLPageControl.ControlSetMultiLine(Value: Boolean);\r\nbegin\r\n MultiLine := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLPageControl.ControlSetScrollOpposite(Value: Boolean);\r\nbegin\r\n ScrollOpposite := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLPageControl.ControlSetHotTrack(Value: Boolean);\r\nbegin\r\n HotTrack := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLPageControl.ControlSetRaggedRight(Value: Boolean);\r\nbegin\r\n RaggedRight := Value;\r\nend;\r\n\r\nfunction TJvDynControlVCLPageControl.ControlGetPage(const PageName: string): TWinControl;\r\nvar\r\n I: Integer;\r\nbegin\r\n I := Tabs.IndexOf(PageName);\r\n if (I >= 0) and (I < PageCount) then\r\n Result := TWinControl(Pages[I])\r\n else\r\n Result := nil;\r\nend;\r\n\r\n//=== { TJvDynControlVCLColorComboBox } ===========================================\r\n\r\nType TAccessCustomColorBox = class(TCustomColorBox);\r\n\r\nfunction TJvDynControlVCLColorComboBox.ControlGetColorName(AColor: TColor):\r\n string;\r\nvar\r\n i: Integer;\r\nbegin\r\n Result := '';\r\n for i := 0 to TAccessCustomColorBox(Self).ItemCount - 1 do\r\n if Colors[i] = AColor then\r\n Result := ColorNames[i];\r\nend;\r\n\r\nfunction TJvDynControlVCLColorComboBox.ControlGetSelectedColor: TColor;\r\nbegin\r\n Result := Selected;\r\nend;\r\n\r\nprocedure TJvDynControlVCLColorComboBox.ControlSetDefaultProperties;\r\nbegin\r\nend;\r\n\r\nprocedure TJvDynControlVCLColorComboBox.ControlSetTabOrder(Value: Integer);\r\nbegin\r\n TabOrder := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLColorComboBox.ControlSetOnEnter(Value: TNotifyEvent);\r\nbegin\r\n OnEnter := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLColorComboBox.ControlSetOnExit(Value: TNotifyEvent);\r\nbegin\r\n OnExit := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLColorComboBox.ControlSetOnChange(Value: TNotifyEvent);\r\nbegin\r\n OnChange := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLColorComboBox.ControlSetOnClick(Value: TNotifyEvent);\r\nbegin\r\nend;\r\n\r\nprocedure TJvDynControlVCLColorComboBox.ControlSetHint(const Value: string);\r\nbegin\r\n Hint := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLColorComboBox.ControlSetAnchors(Value: TAnchors);\r\nbegin\r\n Anchors := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLColorComboBox.ControlSetValue(Value: Variant);\r\nbegin\r\n Text := VarToStr(Value);\r\nend;\r\n\r\nfunction TJvDynControlVCLColorComboBox.ControlGetValue: Variant;\r\nbegin\r\n Result := Text;\r\nend;\r\n\r\nprocedure TJvDynControlVCLColorComboBox.ControlSetSelectedColor(const Value:\r\n TColor);\r\nbegin\r\n Selected := Value;\r\nend;\r\n\r\nfunction TJvDynControlVCLColorComboBox.GetControlDefaultColor: TColor;\r\nbegin\r\n Result := DefaultColorColor;\r\nend;\r\n\r\nprocedure TJvDynControlVCLColorComboBox.SetControlDefaultColor(const Value:\r\n TColor);\r\nbegin\r\n DefaultColorColor := Value;\r\nend;\r\n\r\n//=== { TJvDynControlEngineVCL } =============================================\r\n\r\nprocedure SetDynControlEngineVCLDefault;\r\nbegin\r\n SetDefaultDynControlEngine(IntDynControlEngineVCL);\r\nend;\r\n\r\nfunction DynControlEngineVCL: TJvDynControlEngine;\r\nbegin\r\n Result := IntDynControlEngineVCL;\r\nend;\r\n\r\nprocedure TJvDynControlEngineVCL.RegisterControls;\r\nbegin\r\n RegisterControlType(jctLabel, TJvDynControlVCLLabel);\r\n RegisterControlType(jctStaticText, TJvDynControlVCLStaticText);\r\n RegisterControlType(jctButton, TJvDynControlVCLButton);\r\n RegisterControlType(jctRadioButton, TJvDynControlVCLRadioButton);\r\n RegisterControlType(jctScrollBox, TJvDynControlVCLScrollBox);\r\n RegisterControlType(jctGroupBox, TJvDynControlVCLGroupBox);\r\n RegisterControlType(jctPanel, TJvDynControlVCLPanel);\r\n RegisterControlType(jctImage, TJvDynControlVCLImage);\r\n RegisterControlType(jctCheckBox, TJvDynControlVCLCheckBox);\r\n RegisterControlType(jctComboBox, TJvDynControlVCLComboBox);\r\n RegisterControlType(jctListBox, TJvDynControlVCLListBox);\r\n RegisterControlType(jctCheckListBox, TJvDynControlVCLCheckListBox);\r\n RegisterControlType(jctRadioGroup, TJvDynControlVCLRadioGroup);\r\n RegisterControlType(jctDateTimeEdit, TJvDynControlVCLDateTimeEdit);\r\n RegisterControlType(jctTimeEdit, TJvDynControlVCLTimeEdit);\r\n RegisterControlType(jctDateEdit, TJvDynControlVCLDateEdit);\r\n RegisterControlType(jctEdit, TJvDynControlVCLMaskEdit);\r\n // RegisterControlType(jctCalculateEdit, TJvDynControlVCLMaskEdit);\r\n // RegisterControlType(jctSpinEdit, TJvDynControlVCLMaskEdit);\r\n RegisterControlType(jctDirectoryEdit, TJvDynControlVCLDirectoryEdit);\r\n RegisterControlType(jctFileNameEdit, TJvDynControlVCLFileNameEdit);\r\n RegisterControlType(jctMemo, TJvDynControlVCLMemo);\r\n RegisterControlType(jctRichEdit, TJvDynControlVCLRichEdit);\r\n RegisterControlType(jctButtonEdit, TJvDynControlVCLButtonEdit);\r\n RegisterControlType(jctTreeView, TJvDynControlVCLTreeView);\r\n RegisterControlType(jctProgressbar, TJvDynControlVCLProgressbar);\r\n RegisterControlType(jctTabControl, TJvDynControlVCLTabControl);\r\n RegisterControlType(jctPageControl, TJvDynControlVCLPageControl);\r\n {$IFDEF DELPHI7_UP}\r\n RegisterControlType(jctColorComboBox, TJvDynControlVCLColorComboBox);\r\n {$ENDIF}\r\nend;\r\n\r\n\r\ninitialization\r\n {$IFDEF UNITVERSIONING}\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n {$ENDIF UNITVERSIONING}\r\n IntDynControlEngineVCL := TJvDynControlEngineVCL.Create;\r\n SetDynControlEngineVCLDefault;\r\n\r\nfinalization\r\n FreeAndNil(IntDynControlEngineVCL);\r\n {$IFDEF UNITVERSIONING}\r\n UnregisterUnitVersion(HInstance);\r\n {$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvDynControlEngineVCLDB.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Initial Developer of the Original Code is Jens Fudickar [jens dott fudickar att oratool dott de]\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\nJens Fudickar [jens dott fudickar att oratool dott de]\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvDynControlEngineVCLDB.pas 13415 2012-09-10 09:51:54Z obones $\r\n\r\nunit JvDynControlEngineVCLDB;\r\n\r\n{$I jvcl.inc}\r\n{$I crossplatform.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Classes, ExtCtrls, ExtDlgs, Graphics, Buttons, Controls, Dialogs, FileCtrl,\r\n Forms, DBCtrls, DB, DBGrids, StdCtrls,\r\n {$IFDEF HAS_UNIT_SYSTEM_UITYPES}\r\n System.UITypes,\r\n {$ENDIF HAS_UNIT_SYSTEM_UITYPES}\r\n JvDynControlEngine, JvDynControlEngineDB, JvDynControlEngineIntf,\r\n JvDynControlEngineDBIntf;\r\n\r\ntype\r\n TJvDynControlVCLDBEdit = class(TDBEdit, IUnknown,\r\n IJvDynControl, IJvDynControlData, IJvDynControlReadOnly, IJvDynControlEdit,\r\n IJvDynControlDatabase)\r\n public\r\n procedure ControlSetDefaultProperties;\r\n procedure ControlSetReadOnly(Value: Boolean);\r\n procedure ControlSetCaption(const Value: string);\r\n procedure ControlSetTabOrder(Value: Integer);\r\n procedure ControlSetHint(const Value: string);\r\n\r\n procedure ControlSetOnEnter(Value: TNotifyEvent);\r\n procedure ControlSetOnExit(Value: TNotifyEvent);\r\n procedure ControlSetOnChange(Value: TNotifyEvent);\r\n procedure ControlSetOnClick(Value: TNotifyEvent);\r\n\r\n procedure ControlSetValue(Value: Variant);\r\n function ControlGetValue: Variant;\r\n\r\n //IJvDynControlEdit\r\n procedure ControlSetPasswordChar(Value: Char);\r\n procedure ControlSetEditMask(const Value: string);\r\n\r\n //IJvDynControlDatabase\r\n procedure ControlSetDataSource(Value: TDataSource);\r\n function ControlGetDataSource: TDataSource;\r\n procedure ControlSetDataField(const Value: string);\r\n function ControlGetDataField: string;\r\n procedure ControlSetAnchors(Value : TAnchors);\r\n end;\r\n\r\n TJvDynControlVCLDBButtonEdit = class(TPanel, IUnknown,\r\n IJvDynControl, IJvDynControlData, IJvDynControlReadOnly, IJvDynControlEdit,\r\n IJvDynControlButtonEdit, IJvDynControlButton, IJvDynControlDatabase)\r\n private\r\n FEditControl: TDBEdit;\r\n FButton: TBitBtn;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n\r\n procedure ControlSetDefaultProperties;\r\n procedure ControlSetReadOnly(Value: Boolean);\r\n procedure ControlSetCaption(const Value: string);\r\n procedure ControlSetTabOrder(Value: Integer);\r\n procedure ControlSetHint(const Value: string);\r\n\r\n procedure ControlSetOnEnter(Value: TNotifyEvent);\r\n procedure ControlSetOnExit(Value: TNotifyEvent);\r\n procedure ControlSetOnChange(Value: TNotifyEvent);\r\n procedure ControlSetOnClick(Value: TNotifyEvent);\r\n\r\n procedure ControlSetValue(Value: Variant);\r\n function ControlGetValue: Variant;\r\n\r\n //IJvDynControlEdit\r\n procedure ControlSetPasswordChar(Value: Char);\r\n procedure ControlSetEditMask(const Value: string);\r\n\r\n //IJvDynControlButtonEdit\r\n procedure ControlSetOnButtonClick(Value: TNotifyEvent);\r\n procedure ControlSetButtonCaption(const Value: string);\r\n\r\n //IJvDynControlButton\r\n procedure ControlSetGlyph(Value: TBitmap);\r\n procedure ControlSetNumGlyphs(Value: Integer);\r\n procedure ControlSetLayout(Value: TButtonLayout);\r\n procedure ControlSetDefault(Value: Boolean);\r\n procedure ControlSetCancel(Value: Boolean);\r\n\r\n //IJvDynControlDatabase\r\n procedure ControlSetDataSource(Value: TDataSource);\r\n function ControlGetDataSource: TDataSource;\r\n procedure ControlSetDataField(const Value: string);\r\n function ControlGetDataField: string;\r\n procedure ControlSetAnchors(Value : TAnchors);\r\n end;\r\n\r\n TJvDynControlVCLDBFileNameEdit = class(TPanel, IUnknown,\r\n IJvDynControl, IJvDynControlData, IJvDynControlFileName,\r\n IJvDynControlReadOnly, IJvDynControlDatabase)\r\n private\r\n FEditControl: TDBEdit;\r\n FButton: TBitBtn;\r\n FInitialDir: string;\r\n FFilterIndex: Integer;\r\n FFilter: string;\r\n FDialogOptions: TOpenOptions;\r\n FDialogKind: TJvDynControlFileNameDialogKind;\r\n FDialogTitle: string;\r\n FDefaultExt: string;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n\r\n procedure DefaultOnButtonClick(Sender: TObject);\r\n\r\n procedure ControlSetDefaultProperties;\r\n procedure ControlSetReadOnly(Value: Boolean);\r\n procedure ControlSetCaption(const Value: string);\r\n procedure ControlSetTabOrder(Value: Integer);\r\n procedure ControlSetHint(const Value: string);\r\n\r\n procedure ControlSetOnEnter(Value: TNotifyEvent);\r\n procedure ControlSetOnExit(Value: TNotifyEvent);\r\n procedure ControlSetOnChange(Value: TNotifyEvent);\r\n procedure ControlSetOnClick(Value: TNotifyEvent);\r\n\r\n procedure ControlSetValue(Value: Variant);\r\n function ControlGetValue: Variant;\r\n\r\n // IJvDynControlFileName\r\n procedure ControlSetInitialDir(const Value: string);\r\n procedure ControlSetDefaultExt(const Value: string);\r\n procedure ControlSetDialogTitle(const Value: string);\r\n procedure ControlSetDialogOptions(Value: TOpenOptions);\r\n procedure ControlSetFilter(const Value: string);\r\n procedure ControlSetFilterIndex(Value: Integer);\r\n procedure ControlSetDialogKind(Value: TJvDynControlFileNameDialogKind);\r\n\r\n //IJvDynControlDatabase\r\n procedure ControlSetDataSource(Value: TDataSource);\r\n function ControlGetDataSource: TDataSource;\r\n procedure ControlSetDataField(const Value: string);\r\n function ControlGetDataField: string;\r\n procedure ControlSetAnchors(Value : TAnchors);\r\n end;\r\n\r\n TJvDynControlVCLDBDirectoryEdit = class(TPanel, IUnknown,\r\n IJvDynControl, IJvDynControlData, IJvDynControlDirectory,\r\n IJvDynControlReadOnly, IJvDynControlDatabase)\r\n private\r\n FEditControl: TDBEdit;\r\n FButton: TBitBtn;\r\n FInitialDir: string;\r\n FDialogOptions: TSelectDirOpts;\r\n FDialogTitle: string;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n\r\n procedure DefaultOnButtonClick(Sender: TObject);\r\n\r\n procedure ControlSetDefaultProperties;\r\n procedure ControlSetReadOnly(Value: Boolean);\r\n procedure ControlSetCaption(const Value: string);\r\n procedure ControlSetTabOrder(Value: Integer);\r\n procedure ControlSetHint(const Value: string);\r\n\r\n procedure ControlSetOnEnter(Value: TNotifyEvent);\r\n procedure ControlSetOnExit(Value: TNotifyEvent);\r\n procedure ControlSetOnChange(Value: TNotifyEvent);\r\n procedure ControlSetOnClick(Value: TNotifyEvent);\r\n\r\n procedure ControlSetValue(Value: Variant);\r\n function ControlGetValue: Variant;\r\n\r\n // IJvDynControlDirectory\r\n procedure ControlSetInitialDir(const Value: string);\r\n procedure ControlSetDialogTitle(const Value: string);\r\n procedure ControlSetDialogOptions(Value: TSelectDirOpts);\r\n\r\n //IJvDynControlDatabase\r\n procedure ControlSetDataSource(Value: TDataSource);\r\n function ControlGetDataSource: TDataSource;\r\n procedure ControlSetDataField(const Value: string);\r\n function ControlGetDataField: string;\r\n procedure ControlSetAnchors(Value : TAnchors);\r\n end;\r\n\r\n TJvDynControlVCLDBCheckBox = class(TDBCheckBox, IUnknown,\r\n IJvDynControl, IJvDynControlData, IJvDynControlDatabase,\r\n IJvDynControlDBCheckbox)\r\n public\r\n procedure ControlSetDefaultProperties;\r\n procedure ControlSetCaption(const Value: string);\r\n procedure ControlSetTabOrder(Value: Integer);\r\n procedure ControlSetHint(const Value: string);\r\n\r\n procedure ControlSetOnEnter(Value: TNotifyEvent);\r\n procedure ControlSetOnExit(Value: TNotifyEvent);\r\n procedure ControlSetOnChange(Value: TNotifyEvent);\r\n procedure ControlSetOnClick(Value: TNotifyEvent);\r\n\r\n procedure ControlSetValue(Value: Variant);\r\n function ControlGetValue: Variant;\r\n\r\n //IJvDynControlDatabase\r\n procedure ControlSetDataSource(Value: TDataSource);\r\n function ControlGetDataSource: TDataSource;\r\n procedure ControlSetDataField(const Value: string);\r\n function ControlGetDataField: string;\r\n procedure ControlSetAnchors(Value : TAnchors);\r\n\r\n //IJvDynControlDBCheckbox\r\n procedure ControlSetValueChecked(Value: Variant);\r\n procedure ControlSetValueUnChecked(Value: Variant);\r\n end;\r\n\r\n TJvDynControlVCLDBMemo = class(TDBMemo, IUnknown,\r\n IJvDynControl, IJvDynControlData, IJvDynControlItems, IJvDynControlMemo,\r\n IJvDynControlReadOnly, IJvDynControlDatabase)\r\n public\r\n procedure ControlSetDefaultProperties;\r\n procedure ControlSetReadOnly(Value: Boolean);\r\n procedure ControlSetCaption(const Value: string);\r\n procedure ControlSetTabOrder(Value: Integer);\r\n procedure ControlSetHint(const Value: string);\r\n\r\n procedure ControlSetOnEnter(Value: TNotifyEvent);\r\n procedure ControlSetOnExit(Value: TNotifyEvent);\r\n procedure ControlSetOnChange(Value: TNotifyEvent);\r\n procedure ControlSetOnClick(Value: TNotifyEvent);\r\n\r\n procedure ControlSetValue(Value: Variant);\r\n function ControlGetValue: Variant;\r\n\r\n procedure ControlSetSorted(Value: Boolean);\r\n procedure ControlSetItems(Value: TStrings);\r\n function ControlGetItems: TStrings;\r\n\r\n procedure ControlSetWantTabs(Value: Boolean);\r\n procedure ControlSetWantReturns(Value: Boolean);\r\n procedure ControlSetWordWrap(Value: Boolean);\r\n procedure ControlSetScrollBars(Value: TScrollStyle);\r\n\r\n //IJvDynControlDatabase\r\n procedure ControlSetDataSource(Value: TDataSource);\r\n function ControlGetDataSource: TDataSource;\r\n procedure ControlSetDataField(const Value: string);\r\n function ControlGetDataField: string;\r\n procedure ControlSetAnchors(Value : TAnchors);\r\n\r\n //IJvDynControlFont\r\n function ControlGetFont: TFont;\r\n procedure ControlSetFont(Value: TFont);\r\n end;\r\n\r\n TJvDynControlVCLDBRadioGroup = class(TDBRadioGroup, IUnknown,\r\n IJvDynControl, IJvDynControlData, IJvDynControlItems,\r\n IJvDynControlRadioGroup, IJvDynControlDatabase)\r\n public\r\n procedure ControlSetDefaultProperties;\r\n procedure ControlSetCaption(const Value: string);\r\n procedure ControlSetTabOrder(Value: Integer);\r\n procedure ControlSetHint(const Value: string);\r\n\r\n procedure ControlSetOnEnter(Value: TNotifyEvent);\r\n procedure ControlSetOnExit(Value: TNotifyEvent);\r\n procedure ControlSetOnChange(Value: TNotifyEvent);\r\n procedure ControlSetOnClick(Value: TNotifyEvent);\r\n\r\n procedure ControlSetValue(Value: Variant);\r\n function ControlGetValue: Variant;\r\n\r\n procedure ControlSetSorted(Value: Boolean);\r\n procedure ControlSetItems(Value: TStrings);\r\n function ControlGetItems: TStrings;\r\n\r\n procedure ControlSetColumns(Value: Integer);\r\n\r\n //IJvDynControlDatabase\r\n procedure ControlSetDataSource(Value: TDataSource);\r\n function ControlGetDataSource: TDataSource;\r\n procedure ControlSetDataField(const Value: string);\r\n function ControlGetDataField: string;\r\n procedure ControlSetAnchors(Value : TAnchors);\r\n end;\r\n\r\n TJvDynControlVCLDBListBox = class(TDBListBox, IUnknown,\r\n IJvDynControl, IJvDynControlData, IJvDynControlItems, IJvDynControlDblClick,\r\n IJvDynControlDatabase)\r\n public\r\n procedure ControlSetDefaultProperties;\r\n procedure ControlSetCaption(const Value: string);\r\n procedure ControlSetTabOrder(Value: Integer);\r\n procedure ControlSetHint(const Value: string);\r\n\r\n procedure ControlSetOnEnter(Value: TNotifyEvent);\r\n procedure ControlSetOnExit(Value: TNotifyEvent);\r\n procedure ControlSetOnChange(Value: TNotifyEvent);\r\n procedure ControlSetOnClick(Value: TNotifyEvent);\r\n\r\n procedure ControlSetValue(Value: Variant);\r\n function ControlGetValue: Variant;\r\n\r\n procedure ControlSetSorted(Value: Boolean);\r\n procedure ControlSetItems(Value: TStrings);\r\n function ControlGetItems: TStrings;\r\n\r\n procedure ControlSetOnDblClick(Value: TNotifyEvent);\r\n\r\n //IJvDynControlDatabase\r\n procedure ControlSetDataSource(Value: TDataSource);\r\n function ControlGetDataSource: TDataSource;\r\n procedure ControlSetDataField(const Value: string);\r\n function ControlGetDataField: string;\r\n procedure ControlSetAnchors(Value : TAnchors);\r\n end;\r\n\r\n TJvDynControlVCLDBComboBox = class(TDBComboBox, IUnknown,\r\n IJvDynControl, IJvDynControlData, IJvDynControlItems, IJvDynControlComboBox,\r\n IJvDynControlDatabase)\r\n public\r\n procedure ControlSetDefaultProperties;\r\n procedure ControlSetCaption(const Value: string);\r\n procedure ControlSetTabOrder(Value: Integer);\r\n procedure ControlSetHint(const Value: string);\r\n\r\n procedure ControlSetOnEnter(Value: TNotifyEvent);\r\n procedure ControlSetOnExit(Value: TNotifyEvent);\r\n procedure ControlSetOnChange(Value: TNotifyEvent);\r\n procedure ControlSetOnClick(Value: TNotifyEvent);\r\n\r\n procedure ControlSetValue(Value: Variant);\r\n function ControlGetValue: Variant;\r\n\r\n procedure ControlSetSorted(Value: Boolean);\r\n procedure ControlSetItems(Value: TStrings);\r\n function ControlGetItems: TStrings;\r\n\r\n procedure ControlSetNewEntriesAllowed(Value: Boolean);\r\n\r\n //IJvDynControlDatabase\r\n procedure ControlSetDataSource(Value: TDataSource);\r\n function ControlGetDataSource: TDataSource;\r\n procedure ControlSetDataField(const Value: string);\r\n function ControlGetDataField: string;\r\n procedure ControlSetAnchors(Value : TAnchors);\r\n end;\r\n\r\n TJvDynControlVCLDBImage = class(TDBImage, IUnknown,\r\n IJvDynControl, IJvDynControlImage, IJvDynControlDatabase)\r\n public\r\n procedure ControlSetDefaultProperties;\r\n procedure ControlSetCaption(const Value: string);\r\n procedure ControlSetTabOrder(Value: Integer);\r\n procedure ControlSetHint(const Value: string);\r\n\r\n procedure ControlSetOnEnter(Value: TNotifyEvent);\r\n procedure ControlSetOnExit(Value: TNotifyEvent);\r\n procedure ControlSetOnClick(Value: TNotifyEvent);\r\n\r\n procedure ControlSetAutoSize(Value: Boolean);\r\n procedure ControlSetIncrementalDisplay(Value: Boolean);\r\n procedure ControlSetCenter(Value: Boolean);\r\n procedure ControlSetProportional(Value: Boolean);\r\n procedure ControlSetStretch(Value: Boolean);\r\n procedure ControlSetTransparent(Value: Boolean);\r\n procedure ControlSetPicture(Value: TPicture);\r\n procedure ControlSetGraphic(Value: TGraphic);\r\n function ControlGetPicture: TPicture;\r\n\r\n //IJvDynControlDatabase\r\n procedure ControlSetDataSource(Value: TDataSource);\r\n function ControlGetDataSource: TDataSource;\r\n procedure ControlSetDataField(const Value: string);\r\n function ControlGetDataField: string;\r\n procedure ControlSetAnchors(Value : TAnchors);\r\n end;\r\n\r\n TJvDynControlVCLDBText = class(TDBText, IUnknown,\r\n IJvDynControl, IJvDynControlDatabase)\r\n public\r\n procedure ControlSetDefaultProperties;\r\n procedure ControlSetCaption(const Value: string);\r\n procedure ControlSetTabOrder(Value: Integer);\r\n procedure ControlSetHint(const Value: string);\r\n\r\n procedure ControlSetOnEnter(Value: TNotifyEvent);\r\n procedure ControlSetOnExit(Value: TNotifyEvent);\r\n procedure ControlSetOnClick(Value: TNotifyEvent);\r\n\r\n //IJvDynControlDatabase\r\n procedure ControlSetDataSource(Value: TDataSource);\r\n function ControlGetDataSource: TDataSource;\r\n procedure ControlSetDataField(const Value: string);\r\n function ControlGetDataField: string;\r\n procedure ControlSetAnchors(Value : TAnchors);\r\n end;\r\n\r\n TJvDynControlVCLDBGrid = class(TDBGrid, IUnknown,\r\n IJvDynControl, IJvDynControlDatabase)\r\n public\r\n procedure ControlSetDefaultProperties;\r\n procedure ControlSetCaption(const Value: string);\r\n procedure ControlSetTabOrder(Value: Integer);\r\n procedure ControlSetHint(const Value: string);\r\n\r\n procedure ControlSetOnEnter(Value: TNotifyEvent);\r\n procedure ControlSetOnExit(Value: TNotifyEvent);\r\n procedure ControlSetOnClick(Value: TNotifyEvent);\r\n\r\n //IJvDynControlDatabase\r\n procedure ControlSetDataSource(Value: TDataSource);\r\n function ControlGetDataSource: TDataSource;\r\n procedure ControlSetDataField(const Value: string);\r\n function ControlGetDataField: string;\r\n procedure ControlSetAnchors(Value : TAnchors);\r\n end;\r\n\r\n TJvDynControlVCLDBNavigator = class(TDBNavigator, IUnknown,\r\n IJvDynControl, IJvDynControlDatabase)\r\n public\r\n procedure ControlSetDefaultProperties;\r\n procedure ControlSetCaption(const Value: string);\r\n procedure ControlSetTabOrder(Value: Integer);\r\n procedure ControlSetHint(const Value: string);\r\n\r\n procedure ControlSetOnEnter(Value: TNotifyEvent);\r\n procedure ControlSetOnExit(Value: TNotifyEvent);\r\n procedure ControlSetOnClick(Value: TNotifyEvent);\r\n\r\n //IJvDynControlDatabase\r\n procedure ControlSetDataSource(Value: TDataSource);\r\n function ControlGetDataSource: TDataSource;\r\n procedure ControlSetDataField(const Value: string);\r\n function ControlGetDataField: string;\r\n procedure ControlSetAnchors(Value : TAnchors);\r\n end;\r\n\r\n TJvDynControlEngineVCLDB = class(TJvDynControlEngineDB)\r\n public\r\n function GetDataSourceFromDataComponent(ADataComponent: TComponent): TDataSource; override;\r\n procedure RegisterControls; override;\r\n end;\r\n\r\nfunction DynControlEngineVCLDB: TJvDynControlEngineDB;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvDynControlEngineVCLDB.pas $';\r\n Revision: '$Revision: 13415 $';\r\n Date: '$Date: 2012-09-10 11:51:54 +0200 (lun. 10 sept. 2012) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n Variants, SysUtils,\r\n JvDynControlEngineTools, JvJCLUtils;\r\n\r\nvar\r\n IntDynControlEngineVCLDB: TJvDynControlEngineDB = nil;\r\n\r\n//=== { TJvDynControlVCLDBEdit } =============================================\r\n\r\nprocedure TJvDynControlVCLDBEdit.ControlSetDefaultProperties;\r\nbegin\r\nend;\r\n\r\nprocedure TJvDynControlVCLDBEdit.ControlSetReadOnly(Value: Boolean);\r\nbegin\r\n ReadOnly := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLDBEdit.ControlSetCaption(const Value: string);\r\nbegin\r\nend;\r\n\r\nprocedure TJvDynControlVCLDBEdit.ControlSetTabOrder(Value: Integer);\r\nbegin\r\n TabOrder := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLDBEdit.ControlSetHint(const Value: string);\r\nbegin\r\n Hint := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLDBEdit.ControlSetOnEnter(Value: TNotifyEvent);\r\nbegin\r\n OnEnter := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLDBEdit.ControlSetOnExit(Value: TNotifyEvent);\r\nbegin\r\n OnExit := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLDBEdit.ControlSetOnChange(Value: TNotifyEvent);\r\nbegin\r\n OnChange := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLDBEdit.ControlSetOnClick(Value: TNotifyEvent);\r\nbegin\r\nend;\r\n\r\nprocedure TJvDynControlVCLDBEdit.ControlSetValue(Value: Variant);\r\nbegin\r\n Text := Value;\r\nend;\r\n\r\nfunction TJvDynControlVCLDBEdit.ControlGetValue: Variant;\r\nbegin\r\n Result := Text;\r\nend;\r\n\r\nprocedure TJvDynControlVCLDBEdit.ControlSetPasswordChar(Value: Char);\r\nbegin\r\n PasswordChar := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLDBEdit.ControlSetEditMask(const Value: string);\r\nbegin\r\n //EditMask := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLDBEdit.ControlSetDataSource(Value: TDataSource);\r\nbegin\r\n DataSource := Value;\r\nend;\r\n\r\nfunction TJvDynControlVCLDBEdit.ControlGetDataSource: TDataSource;\r\nbegin\r\n Result := DataSource;\r\nend;\r\n\r\nprocedure TJvDynControlVCLDBEdit.ControlSetDataField(const Value: string);\r\nbegin\r\n DataField := Value;\r\nend;\r\n\r\nfunction TJvDynControlVCLDBEdit.ControlGetDataField: string;\r\nbegin\r\n Result := DataField;\r\nend;\r\n\r\nprocedure TJvDynControlVCLDBEdit.ControlSetAnchors(Value : TAnchors);\r\nbegin\r\n Anchors := Value;\r\nend;\r\n\r\n//=== { TJvDynControlVCLDBButtonEdit } =======================================\r\n\r\nconstructor TJvDynControlVCLDBButtonEdit.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FEditControl := TDBEdit.Create(AOwner);\r\n FEditControl.Parent := Self;\r\n FButton := TBitBtn.Create(AOwner);\r\n FButton.Parent := Self;\r\n FButton.Align := alRight;\r\n FButton.Caption := '...';\r\n Height := FEditControl.Height;\r\n FButton.Width := Height;\r\n FEditControl.Align := alClient;\r\n BevelInner := bvNone;\r\n BevelOuter := bvNone;\r\nend;\r\n\r\ndestructor TJvDynControlVCLDBButtonEdit.Destroy;\r\nbegin\r\n FreeAndNil(FEditControl);\r\n FreeAndNil(FButton);\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvDynControlVCLDBButtonEdit.ControlSetDefaultProperties;\r\nbegin\r\n Self.Caption := ' ';\r\nend;\r\n\r\nprocedure TJvDynControlVCLDBButtonEdit.ControlSetReadOnly(Value: Boolean);\r\nbegin\r\n FEditControl.ReadOnly := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLDBButtonEdit.ControlSetCaption(const Value: string);\r\nbegin\r\nend;\r\n\r\nprocedure TJvDynControlVCLDBButtonEdit.ControlSetTabOrder(Value: Integer);\r\nbegin\r\n TabOrder := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLDBButtonEdit.ControlSetHint(const Value: string);\r\nbegin\r\n Hint := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLDBButtonEdit.ControlSetOnEnter(Value: TNotifyEvent);\r\nbegin\r\n OnEnter := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLDBButtonEdit.ControlSetOnExit(Value: TNotifyEvent);\r\nbegin\r\n OnExit := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLDBButtonEdit.ControlSetOnChange(Value: TNotifyEvent);\r\nbegin\r\n FEditControl.OnChange := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLDBButtonEdit.ControlSetOnClick(Value: TNotifyEvent);\r\nbegin\r\n FEditControl.OnClick := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLDBButtonEdit.ControlSetValue(Value: Variant);\r\nbegin\r\n FEditControl.Text := Value;\r\nend;\r\n\r\nfunction TJvDynControlVCLDBButtonEdit.ControlGetValue: Variant;\r\nbegin\r\n Result := FEditControl.Text;\r\nend;\r\n\r\n\r\n\r\nprocedure TJvDynControlVCLDBButtonEdit.ControlSetPasswordChar(Value: Char);\r\nbegin\r\n FEditControl.PasswordChar := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLDBButtonEdit.ControlSetEditMask(const Value: string);\r\nbegin\r\n //FEditControl.EditMask := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLDBButtonEdit.ControlSetOnButtonClick(Value: TNotifyEvent);\r\nbegin\r\n FButton.OnClick := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLDBButtonEdit.ControlSetButtonCaption(const Value: string);\r\nbegin\r\n FButton.Caption := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLDBButtonEdit.ControlSetGlyph(Value: TBitmap);\r\nbegin\r\n FButton.Glyph.Assign(Value);\r\nend;\r\n\r\nprocedure TJvDynControlVCLDBButtonEdit.ControlSetNumGlyphs(Value: Integer);\r\nbegin\r\n FButton.NumGlyphs := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLDBButtonEdit.ControlSetLayout(Value: TButtonLayout);\r\nbegin\r\n FButton.Layout := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLDBButtonEdit.ControlSetDefault(Value: Boolean);\r\nbegin\r\n FButton.Default := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLDBButtonEdit.ControlSetCancel(Value: Boolean);\r\nbegin\r\n FButton.Cancel := Value;\r\nend;\r\n\r\n\r\nprocedure TJvDynControlVCLDBButtonEdit.ControlSetDataSource(Value: TDataSource);\r\nbegin\r\n FEditControl.DataSource := Value;\r\nend;\r\n\r\nfunction TJvDynControlVCLDBButtonEdit.ControlGetDataSource: TDataSource;\r\nbegin\r\n Result := FEditControl.DataSource;\r\nend;\r\n\r\nprocedure TJvDynControlVCLDBButtonEdit.ControlSetDataField(const Value: string);\r\nbegin\r\n FEditControl.DataField := Value;\r\nend;\r\n\r\nfunction TJvDynControlVCLDBButtonEdit.ControlGetDataField: string;\r\nbegin\r\n Result := FEditControl.DataField;\r\nend;\r\n\r\nprocedure TJvDynControlVCLDBButtonEdit.ControlSetAnchors(Value : TAnchors);\r\nbegin\r\n Anchors := Value;\r\nend;\r\n\r\n//=== { TJvDynControlVCLDBFileNameEdit } =====================================\r\n\r\nconstructor TJvDynControlVCLDBFileNameEdit.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FEditControl := TDBEdit.Create(AOwner);\r\n FEditControl.Parent := Self;\r\n FButton := TBitBtn.Create(AOwner);\r\n FButton.Parent := Self;\r\n FButton.Align := alRight;\r\n FButton.OnClick := DefaultOnButtonClick;\r\n FButton.Caption := '...';\r\n Height := FEditControl.Height;\r\n FButton.Width := Height;\r\n FEditControl.Align := alClient;\r\n FDialogOptions := [ofHideReadOnly,ofEnableSizing];\r\n BevelInner := bvNone;\r\n BevelOuter := bvNone;\r\n FDialogKind := jdkOpen;\r\nend;\r\n\r\ndestructor TJvDynControlVCLDBFileNameEdit.Destroy;\r\nbegin\r\n FreeAndNil(FEditControl);\r\n FreeAndNil(FButton);\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvDynControlVCLDBFileNameEdit.DefaultOnButtonClick(Sender: TObject);\r\nbegin\r\n case FDialogKind of\r\n jdkOpen:\r\n with TOpenDialog.Create(Self) do\r\n try\r\n Options := FDialogOptions;\r\n Title := FDialogTitle;\r\n Filter := FFilter;\r\n FilterIndex := FFilterIndex;\r\n InitialDir := FInitialDir;\r\n DefaultExt := FDefaultExt;\r\n FileName := ControlGetValue;\r\n if Execute then\r\n ControlSetValue(FileName);\r\n finally\r\n Free;\r\n end;\r\n jdkOpenPicture:\r\n with TOpenPictureDialog.Create(Self) do\r\n try\r\n Options := FDialogOptions;\r\n Title := FDialogTitle;\r\n Filter := FFilter;\r\n FilterIndex := FFilterIndex;\r\n InitialDir := FInitialDir;\r\n DefaultExt := FDefaultExt;\r\n FileName := ControlGetValue;\r\n if Execute then\r\n ControlSetValue(FileName);\r\n finally\r\n Free;\r\n end;\r\n jdkSave:\r\n with TSaveDialog.Create(Self) do\r\n try\r\n Options := FDialogOptions;\r\n Title := FDialogTitle;\r\n Filter := FFilter;\r\n FilterIndex := FFilterIndex;\r\n InitialDir := FInitialDir;\r\n DefaultExt := FDefaultExt;\r\n FileName := ControlGetValue;\r\n if Execute then\r\n ControlSetValue(FileName);\r\n finally\r\n Free;\r\n end;\r\n jdkSavePicture:\r\n with TSavePictureDialog.Create(Self) do\r\n try\r\n Options := FDialogOptions;\r\n Title := FDialogTitle;\r\n Filter := FFilter;\r\n FilterIndex := FFilterIndex;\r\n InitialDir := FInitialDir;\r\n DefaultExt := FDefaultExt;\r\n FileName := ControlGetValue;\r\n if Execute then\r\n ControlSetValue(FileName);\r\n finally\r\n Free;\r\n end;\r\n end;\r\n if FEditControl.CanFocus then\r\n FEditControl.SetFocus;\r\nend;\r\n\r\nprocedure TJvDynControlVCLDBFileNameEdit.ControlSetDefaultProperties;\r\nbegin\r\n Caption := ' ';\r\nend;\r\n\r\nprocedure TJvDynControlVCLDBFileNameEdit.ControlSetReadOnly(Value: Boolean);\r\nbegin\r\n FEditControl.ReadOnly := Value;\r\n FButton.Enabled := not Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLDBFileNameEdit.ControlSetCaption(const Value: string);\r\nbegin\r\nend;\r\n\r\nprocedure TJvDynControlVCLDBFileNameEdit.ControlSetTabOrder(Value: Integer);\r\nbegin\r\n TabOrder := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLDBFileNameEdit.ControlSetHint(const Value: string);\r\nbegin\r\n Hint := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLDBFileNameEdit.ControlSetOnEnter(Value: TNotifyEvent);\r\nbegin\r\n FEditControl.OnEnter := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLDBFileNameEdit.ControlSetOnExit(Value: TNotifyEvent);\r\nbegin\r\n FEditControl.OnExit := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLDBFileNameEdit.ControlSetOnChange(Value: TNotifyEvent);\r\nbegin\r\n FEditControl.OnChange := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLDBFileNameEdit.ControlSetOnClick(Value: TNotifyEvent);\r\nbegin\r\nend;\r\n\r\nprocedure TJvDynControlVCLDBFileNameEdit.ControlSetValue(Value: Variant);\r\nbegin\r\n FEditControl.Text := Value;\r\nend;\r\n\r\nfunction TJvDynControlVCLDBFileNameEdit.ControlGetValue: Variant;\r\nbegin\r\n Result := FEditControl.Text;\r\nend;\r\n\r\n// IJvDynControlFileName\r\nprocedure TJvDynControlVCLDBFileNameEdit.ControlSetInitialDir(const Value: string);\r\nbegin\r\n FInitialDir := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLDBFileNameEdit.ControlSetDefaultExt(const Value: string);\r\nbegin\r\n FDefaultExt := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLDBFileNameEdit.ControlSetDialogTitle(const Value: string);\r\nbegin\r\n FDialogTitle := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLDBFileNameEdit.ControlSetDialogOptions(Value: TOpenOptions);\r\nbegin\r\n FDialogOptions := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLDBFileNameEdit.ControlSetFilter(const Value: string);\r\nbegin\r\n FFilter := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLDBFileNameEdit.ControlSetFilterIndex(Value: Integer);\r\nbegin\r\n FFilterIndex := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLDBFileNameEdit.ControlSetDialogKind(Value: TJvDynControlFileNameDialogKind);\r\nbegin\r\n FDialogKind := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLDBFileNameEdit.ControlSetDataSource(Value: TDataSource);\r\nbegin\r\n FEditControl.DataSource := Value;\r\nend;\r\n\r\nfunction TJvDynControlVCLDBFileNameEdit.ControlGetDataSource: TDataSource;\r\nbegin\r\n Result := FEditControl.DataSource;\r\nend;\r\n\r\nprocedure TJvDynControlVCLDBFileNameEdit.ControlSetDataField(const Value: string);\r\nbegin\r\n FEditControl.DataField := Value;\r\nend;\r\n\r\nfunction TJvDynControlVCLDBFileNameEdit.ControlGetDataField: string;\r\nbegin\r\n Result := FEditControl.DataField;\r\nend;\r\n\r\nprocedure TJvDynControlVCLDBFileNameEdit.ControlSetAnchors(Value : TAnchors);\r\nbegin\r\n Anchors := Value;\r\nend;\r\n\r\n//=== { TJvDynControlVCLDBDirectoryEdit } ====================================\r\n\r\nconstructor TJvDynControlVCLDBDirectoryEdit.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FEditControl := TDBEdit.Create(AOwner);\r\n FEditControl.Parent := Self;\r\n FButton := TBitBtn.Create(AOwner);\r\n FButton.Parent := Self;\r\n FButton.Align := alRight;\r\n FButton.OnClick := DefaultOnButtonClick;\r\n FButton.Caption := '...';\r\n Height := FEditControl.Height;\r\n FButton.Width := Height;\r\n FEditControl.Align := alClient;\r\n BevelInner := bvNone;\r\n BevelOuter := bvNone;\r\nend;\r\n\r\ndestructor TJvDynControlVCLDBDirectoryEdit.Destroy;\r\nbegin\r\n FreeAndNil(FEditControl);\r\n FreeAndNil(FButton);\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvDynControlVCLDBDirectoryEdit.DefaultOnButtonClick(Sender: TObject);\r\nvar\r\n Opt: TSelectDirOpts;\r\n Dir: string;\r\nbegin\r\n Dir := ControlGetValue;\r\n if Dir = '' then\r\n if FInitialDir <> '' then\r\n Dir := FInitialDir\r\n else\r\n Dir := PathDelim;\r\n if not DirectoryExists(Dir) then\r\n Dir := PathDelim;\r\n if SelectDirectory(Dir, Opt, HelpContext) then\r\n ControlSetValue(Dir);\r\n if FEditControl.CanFocus then\r\n FEditControl.SetFocus;\r\nend;\r\n\r\nprocedure TJvDynControlVCLDBDirectoryEdit.ControlSetDefaultProperties;\r\nbegin\r\n Self.Caption := ' ';\r\nend;\r\n\r\nprocedure TJvDynControlVCLDBDirectoryEdit.ControlSetReadOnly(Value: Boolean);\r\nbegin\r\n FEditControl.ReadOnly := Value;\r\n FButton.Enabled := not Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLDBDirectoryEdit.ControlSetCaption(const Value: string);\r\nbegin\r\nend;\r\n\r\nprocedure TJvDynControlVCLDBDirectoryEdit.ControlSetTabOrder(Value: Integer);\r\nbegin\r\n TabOrder := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLDBDirectoryEdit.ControlSetHint(const Value: string);\r\nbegin\r\n Hint := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLDBDirectoryEdit.ControlSetOnEnter(Value: TNotifyEvent);\r\nbegin\r\n FEditControl.OnEnter := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLDBDirectoryEdit.ControlSetOnExit(Value: TNotifyEvent);\r\nbegin\r\n FEditControl.OnExit := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLDBDirectoryEdit.ControlSetOnChange(Value: TNotifyEvent);\r\nbegin\r\n FEditControl.OnChange := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLDBDirectoryEdit.ControlSetOnClick(Value: TNotifyEvent);\r\nbegin\r\nend;\r\n\r\nprocedure TJvDynControlVCLDBDirectoryEdit.ControlSetValue(Value: Variant);\r\nbegin\r\n FEditControl.Text := Value;\r\nend;\r\n\r\nfunction TJvDynControlVCLDBDirectoryEdit.ControlGetValue: Variant;\r\nbegin\r\n Result := FEditControl.Text;\r\nend;\r\n\r\nprocedure TJvDynControlVCLDBDirectoryEdit.ControlSetInitialDir(const Value: string);\r\nbegin\r\n FInitialDir := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLDBDirectoryEdit.ControlSetDialogTitle(const Value: string);\r\nbegin\r\n FDialogTitle := Value;\r\nend;\r\n\r\n\r\nprocedure TJvDynControlVCLDBDirectoryEdit.ControlSetDialogOptions(Value: TSelectDirOpts);\r\nbegin\r\n FDialogOptions := Value;\r\nend;\r\n\r\n\r\nprocedure TJvDynControlVCLDBDirectoryEdit.ControlSetDataSource(Value: TDataSource);\r\nbegin\r\n FEditControl.DataSource := Value;\r\nend;\r\n\r\nfunction TJvDynControlVCLDBDirectoryEdit.ControlGetDataSource: TDataSource;\r\nbegin\r\n Result := FEditControl.DataSource;\r\nend;\r\n\r\nprocedure TJvDynControlVCLDBDirectoryEdit.ControlSetDataField(const Value: string);\r\nbegin\r\n FEditControl.DataField := Value;\r\nend;\r\n\r\nfunction TJvDynControlVCLDBDirectoryEdit.ControlGetDataField: string;\r\nbegin\r\n Result := FEditControl.DataField;\r\nend;\r\n\r\nprocedure TJvDynControlVCLDBDirectoryEdit.ControlSetAnchors(Value : TAnchors);\r\nbegin\r\n Anchors := Value;\r\nend;\r\n\r\n//=== { TJvDynControlVCLDBCheckBox } =========================================\r\n\r\nprocedure TJvDynControlVCLDBCheckBox.ControlSetDefaultProperties;\r\nbegin\r\nend;\r\n\r\nprocedure TJvDynControlVCLDBCheckBox.ControlSetCaption(const Value: string);\r\nbegin\r\n Caption := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLDBCheckBox.ControlSetTabOrder(Value: Integer);\r\nbegin\r\n TabOrder := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLDBCheckBox.ControlSetHint(const Value: string);\r\nbegin\r\n Hint := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLDBCheckBox.ControlSetOnEnter(Value: TNotifyEvent);\r\nbegin\r\n OnEnter := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLDBCheckBox.ControlSetOnExit(Value: TNotifyEvent);\r\nbegin\r\n OnExit := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLDBCheckBox.ControlSetOnChange(Value: TNotifyEvent);\r\nbegin\r\n OnClick := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLDBCheckBox.ControlSetOnClick(Value: TNotifyEvent);\r\nbegin\r\n OnClick := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLDBCheckBox.ControlSetValue(Value: Variant);\r\nbegin\r\n Checked := JvDynControlVariantToBoolean(Value);\r\nend;\r\n\r\nfunction TJvDynControlVCLDBCheckBox.ControlGetValue: Variant;\r\nbegin\r\n Result := Checked;\r\nend;\r\n\r\nprocedure TJvDynControlVCLDBCheckBox.ControlSetDataSource(Value: TDataSource);\r\nbegin\r\n DataSource := Value;\r\nend;\r\n\r\nfunction TJvDynControlVCLDBCheckBox.ControlGetDataSource: TDataSource;\r\nbegin\r\n Result := DataSource;\r\nend;\r\n\r\nprocedure TJvDynControlVCLDBCheckBox.ControlSetDataField(const Value: string);\r\nbegin\r\n DataField := Value;\r\nend;\r\n\r\nfunction TJvDynControlVCLDBCheckBox.ControlGetDataField: string;\r\nbegin\r\n Result := DataField;\r\nend;\r\n\r\nprocedure TJvDynControlVCLDBCheckBox.ControlSetAnchors(Value : TAnchors);\r\nbegin\r\n Anchors := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLDBCheckBox.ControlSetValueChecked(Value: Variant);\r\nbegin\r\n ValueChecked := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLDBCheckBox.ControlSetValueUnChecked(Value: Variant);\r\nbegin\r\n ValueUnChecked := Value;\r\nend;\r\n\r\n\r\n//=== { TJvDynControlVCLDBMemo } =============================================\r\n\r\nprocedure TJvDynControlVCLDBMemo.ControlSetDefaultProperties;\r\nbegin\r\nend;\r\n\r\nprocedure TJvDynControlVCLDBMemo.ControlSetReadOnly(Value: Boolean);\r\nbegin\r\n ReadOnly := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLDBMemo.ControlSetCaption(const Value: string);\r\nbegin\r\nend;\r\n\r\nprocedure TJvDynControlVCLDBMemo.ControlSetTabOrder(Value: Integer);\r\nbegin\r\n TabOrder := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLDBMemo.ControlSetHint(const Value: string);\r\nbegin\r\n Hint := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLDBMemo.ControlSetOnEnter(Value: TNotifyEvent);\r\nbegin\r\n OnEnter := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLDBMemo.ControlSetOnExit(Value: TNotifyEvent);\r\nbegin\r\n OnExit := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLDBMemo.ControlSetOnChange(Value: TNotifyEvent);\r\nbegin\r\n OnChange := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLDBMemo.ControlSetOnClick(Value: TNotifyEvent);\r\nbegin\r\n OnClick := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLDBMemo.ControlSetValue(Value: Variant);\r\nbegin\r\n Text := Value;\r\nend;\r\n\r\nfunction TJvDynControlVCLDBMemo.ControlGetValue: Variant;\r\nbegin\r\n Result := Text;\r\nend;\r\n\r\nprocedure TJvDynControlVCLDBMemo.ControlSetSorted(Value: Boolean);\r\nbegin\r\nend;\r\n\r\nprocedure TJvDynControlVCLDBMemo.ControlSetItems(Value: TStrings);\r\nbegin\r\n Lines.Assign(Value);\r\nend;\r\n\r\nfunction TJvDynControlVCLDBMemo.ControlGetItems: TStrings;\r\nbegin\r\n Result := Lines;\r\nend;\r\n\r\nprocedure TJvDynControlVCLDBMemo.ControlSetWantTabs(Value: Boolean);\r\nbegin\r\n WantTabs := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLDBMemo.ControlSetWantReturns(Value: Boolean);\r\nbegin\r\n WantReturns := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLDBMemo.ControlSetWordWrap(Value: Boolean);\r\nbegin\r\n WordWrap := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLDBMemo.ControlSetScrollBars(Value: TScrollStyle);\r\nbegin\r\n ScrollBars := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLDBMemo.ControlSetDataSource(Value: TDataSource);\r\nbegin\r\n DataSource := Value;\r\nend;\r\n\r\nfunction TJvDynControlVCLDBMemo.ControlGetDataSource: TDataSource;\r\nbegin\r\n Result := DataSource;\r\nend;\r\n\r\nprocedure TJvDynControlVCLDBMemo.ControlSetDataField(const Value: string);\r\nbegin\r\n DataField := Value;\r\nend;\r\n\r\nfunction TJvDynControlVCLDBMemo.ControlGetDataField: string;\r\nbegin\r\n Result := DataField;\r\nend;\r\n\r\nfunction TJvDynControlVCLDBMemo.ControlGetFont: TFont;\r\nbegin\r\n Result := Font;\r\nend;\r\n\r\nprocedure TJvDynControlVCLDBMemo.ControlSetAnchors(Value : TAnchors);\r\nbegin\r\n Anchors := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLDBMemo.ControlSetFont(Value: TFont);\r\nbegin\r\n Font.Assign(Value);\r\nend;\r\n\r\n//=== { TJvDynControlVCLDBRadioGroup } =======================================\r\n\r\nprocedure TJvDynControlVCLDBRadioGroup.ControlSetDefaultProperties;\r\nbegin\r\nend;\r\n\r\nprocedure TJvDynControlVCLDBRadioGroup.ControlSetCaption(const Value: string);\r\nbegin\r\n Caption := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLDBRadioGroup.ControlSetTabOrder(Value: Integer);\r\nbegin\r\n TabOrder := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLDBRadioGroup.ControlSetHint(const Value: string);\r\nbegin\r\n Hint := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLDBRadioGroup.ControlSetOnEnter(Value: TNotifyEvent);\r\nbegin\r\n OnEnter := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLDBRadioGroup.ControlSetOnExit(Value: TNotifyEvent);\r\nbegin\r\n OnExit := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLDBRadioGroup.ControlSetOnChange(Value: TNotifyEvent);\r\nbegin\r\n OnClick := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLDBRadioGroup.ControlSetOnClick(Value: TNotifyEvent);\r\nbegin\r\n OnClick := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLDBRadioGroup.ControlSetValue(Value: Variant);\r\nbegin\r\n if VarIsInt(Value) then\r\n ItemIndex := Value\r\n else\r\n ItemIndex := Items.IndexOf(Value);\r\nend;\r\n\r\nfunction TJvDynControlVCLDBRadioGroup.ControlGetValue: Variant;\r\nbegin\r\n Result := ItemIndex;\r\nend;\r\n\r\nprocedure TJvDynControlVCLDBRadioGroup.ControlSetSorted(Value: Boolean);\r\nbegin\r\nend;\r\n\r\nprocedure TJvDynControlVCLDBRadioGroup.ControlSetItems(Value: TStrings);\r\nbegin\r\n Items.Assign(Value);\r\nend;\r\n\r\nfunction TJvDynControlVCLDBRadioGroup.ControlGetItems: TStrings;\r\nbegin\r\n Result := Items;\r\nend;\r\n\r\nprocedure TJvDynControlVCLDBRadioGroup.ControlSetColumns(Value: Integer);\r\nbegin\r\n Columns := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLDBRadioGroup.ControlSetDataSource(Value: TDataSource);\r\nbegin\r\n DataSource := Value;\r\nend;\r\n\r\nfunction TJvDynControlVCLDBRadioGroup.ControlGetDataSource: TDataSource;\r\nbegin\r\n Result := DataSource;\r\nend;\r\n\r\nprocedure TJvDynControlVCLDBRadioGroup.ControlSetDataField(const Value: string);\r\nbegin\r\n DataField := Value;\r\nend;\r\n\r\nfunction TJvDynControlVCLDBRadioGroup.ControlGetDataField: string;\r\nbegin\r\n Result := DataField;\r\nend;\r\n\r\nprocedure TJvDynControlVCLDBRadioGroup.ControlSetAnchors(Value : TAnchors);\r\nbegin\r\n Anchors := Value;\r\nend;\r\n\r\n//=== { TJvDynControlVCLDBListBox } ==========================================\r\n\r\nprocedure TJvDynControlVCLDBListBox.ControlSetDefaultProperties;\r\nbegin\r\nend;\r\n\r\nprocedure TJvDynControlVCLDBListBox.ControlSetCaption(const Value: string);\r\nbegin\r\nend;\r\n\r\nprocedure TJvDynControlVCLDBListBox.ControlSetTabOrder(Value: Integer);\r\nbegin\r\n TabOrder := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLDBListBox.ControlSetHint(const Value: string);\r\nbegin\r\n Hint := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLDBListBox.ControlSetOnEnter(Value: TNotifyEvent);\r\nbegin\r\n OnEnter := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLDBListBox.ControlSetOnExit(Value: TNotifyEvent);\r\nbegin\r\n OnExit := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLDBListBox.ControlSetOnChange(Value: TNotifyEvent);\r\nbegin\r\n// OnChange := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLDBListBox.ControlSetOnClick(Value: TNotifyEvent);\r\nbegin\r\n OnClick := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLDBListBox.ControlSetValue(Value: Variant);\r\nbegin\r\n if VarIsInt(Value) then\r\n ItemIndex := Value\r\n else\r\n ItemIndex := Items.IndexOf(Value);\r\nend;\r\n\r\nfunction TJvDynControlVCLDBListBox.ControlGetValue: Variant;\r\nbegin\r\n Result := ItemIndex;\r\nend;\r\n\r\nprocedure TJvDynControlVCLDBListBox.ControlSetSorted(Value: Boolean);\r\nbegin\r\n Sorted := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLDBListBox.ControlSetItems(Value: TStrings);\r\nbegin\r\n Items.Assign(Value);\r\nend;\r\n\r\nfunction TJvDynControlVCLDBListBox.ControlGetItems: TStrings;\r\nbegin\r\n Result := Items;\r\nend;\r\n\r\nprocedure TJvDynControlVCLDBListBox.ControlSetOnDblClick(Value: TNotifyEvent);\r\nbegin\r\n OnDblClick := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLDBListBox.ControlSetDataSource(Value: TDataSource);\r\nbegin\r\n DataSource := Value;\r\nend;\r\n\r\nfunction TJvDynControlVCLDBListBox.ControlGetDataSource: TDataSource;\r\nbegin\r\n Result := DataSource;\r\nend;\r\n\r\nprocedure TJvDynControlVCLDBListBox.ControlSetDataField(const Value: string);\r\nbegin\r\n DataField := Value;\r\nend;\r\n\r\nfunction TJvDynControlVCLDBListBox.ControlGetDataField: string;\r\nbegin\r\n Result := DataField;\r\nend;\r\n\r\nprocedure TJvDynControlVCLDBListBox.ControlSetAnchors(Value : TAnchors);\r\nbegin\r\n Anchors := Value;\r\nend;\r\n\r\n//=== { TJvDynControlVCLDBComboBox } =========================================\r\n\r\nprocedure TJvDynControlVCLDBComboBox.ControlSetDefaultProperties;\r\nbegin\r\nend;\r\n\r\nprocedure TJvDynControlVCLDBComboBox.ControlSetCaption(const Value: string);\r\nbegin\r\nend;\r\n\r\nprocedure TJvDynControlVCLDBComboBox.ControlSetTabOrder(Value: Integer);\r\nbegin\r\n TabOrder := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLDBComboBox.ControlSetHint(const Value: string);\r\nbegin\r\n Hint := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLDBComboBox.ControlSetOnEnter(Value: TNotifyEvent);\r\nbegin\r\n OnEnter := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLDBComboBox.ControlSetOnExit(Value: TNotifyEvent);\r\nbegin\r\n OnExit := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLDBComboBox.ControlSetOnChange(Value: TNotifyEvent);\r\nbegin\r\n// OnChange := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLDBComboBox.ControlSetOnClick(Value: TNotifyEvent);\r\nbegin\r\n OnClick := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLDBComboBox.ControlSetValue(Value: Variant);\r\nbegin\r\n if Style = csDropDownList then\r\n ItemIndex := Items.IndexOf(Value)\r\n else\r\n Text := Value;\r\nend;\r\n\r\nfunction TJvDynControlVCLDBComboBox.ControlGetValue: Variant;\r\nbegin\r\n Result := Text;\r\nend;\r\n\r\nprocedure TJvDynControlVCLDBComboBox.ControlSetSorted(Value: Boolean);\r\nbegin\r\n Sorted := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLDBComboBox.ControlSetItems(Value: TStrings);\r\nbegin\r\n Items.Assign(Value);\r\nend;\r\n\r\nfunction TJvDynControlVCLDBComboBox.ControlGetItems: TStrings;\r\nbegin\r\n Result := Items;\r\nend;\r\n\r\nprocedure TJvDynControlVCLDBComboBox.ControlSetNewEntriesAllowed(Value: Boolean);\r\nconst\r\n Styles: array [Boolean] of TComboBoxStyle =\r\n (csDropDownList, csDropDown);\r\nbegin\r\n Style := Styles[Value];\r\nend;\r\n\r\nprocedure TJvDynControlVCLDBComboBox.ControlSetDataSource(Value: TDataSource);\r\nbegin\r\n DataSource := Value;\r\nend;\r\n\r\nfunction TJvDynControlVCLDBComboBox.ControlGetDataSource: TDataSource;\r\nbegin\r\n Result := DataSource;\r\nend;\r\n\r\nprocedure TJvDynControlVCLDBComboBox.ControlSetDataField(const Value: string);\r\nbegin\r\n DataField := Value;\r\nend;\r\n\r\nfunction TJvDynControlVCLDBComboBox.ControlGetDataField: string;\r\nbegin\r\n Result := DataField;\r\nend;\r\n\r\nprocedure TJvDynControlVCLDBComboBox.ControlSetAnchors(Value : TAnchors);\r\nbegin\r\n Anchors := Value;\r\nend;\r\n\r\n//=== { TJvDynControlVCLDBImage } ============================================\r\n\r\nprocedure TJvDynControlVCLDBImage.ControlSetDefaultProperties;\r\nbegin\r\nend;\r\n\r\nprocedure TJvDynControlVCLDBImage.ControlSetCaption(const Value: string);\r\nbegin\r\n Caption := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLDBImage.ControlSetTabOrder(Value: Integer);\r\nbegin\r\n// TabOrder := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLDBImage.ControlSetHint(const Value: string);\r\nbegin\r\n Hint := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLDBImage.ControlSetOnEnter(Value: TNotifyEvent);\r\nbegin\r\n// OnEnter := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLDBImage.ControlSetOnExit(Value: TNotifyEvent);\r\nbegin\r\n// OnExit := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLDBImage.ControlSetOnClick(Value: TNotifyEvent);\r\nbegin\r\n OnClick := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLDBImage.ControlSetAutoSize(Value: Boolean);\r\nbegin\r\n AutoSize := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLDBImage.ControlSetIncrementalDisplay(Value: Boolean);\r\nbegin\r\n// IncrementalDisplay := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLDBImage.ControlSetCenter(Value: Boolean);\r\nbegin\r\n Center := Value;\r\nend;\r\n\r\n\r\nprocedure TJvDynControlVCLDBImage.ControlSetProportional(Value: Boolean);\r\nbegin\r\n// Proportional := Value;\r\nend;\r\n\r\n\r\nprocedure TJvDynControlVCLDBImage.ControlSetStretch(Value: Boolean);\r\nbegin\r\n Stretch := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLDBImage.ControlSetTransparent(Value: Boolean);\r\nbegin\r\n// Transparent := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLDBImage.ControlSetPicture(Value: TPicture);\r\nbegin\r\n Picture.Assign(Value);\r\nend;\r\n\r\nprocedure TJvDynControlVCLDBImage.ControlSetGraphic(Value: TGraphic);\r\nbegin\r\n Picture.Assign(Value);\r\nend;\r\n\r\nfunction TJvDynControlVCLDBImage.ControlGetPicture: TPicture;\r\nbegin\r\n Result := Picture;\r\nend;\r\n\r\nprocedure TJvDynControlVCLDBImage.ControlSetDataSource(Value: TDataSource);\r\nbegin\r\n DataSource := Value;\r\nend;\r\n\r\nfunction TJvDynControlVCLDBImage.ControlGetDataSource: TDataSource;\r\nbegin\r\n Result := DataSource;\r\nend;\r\n\r\nprocedure TJvDynControlVCLDBImage.ControlSetDataField(const Value: string);\r\nbegin\r\n DataField := Value;\r\nend;\r\n\r\nfunction TJvDynControlVCLDBImage.ControlGetDataField: string;\r\nbegin\r\n Result := DataField;\r\nend;\r\n\r\nprocedure TJvDynControlVCLDBImage.ControlSetAnchors(Value : TAnchors);\r\nbegin\r\n Anchors := Value;\r\nend;\r\n\r\n//=== { TJvDynControlVCLDBText } =============================================\r\n\r\nprocedure TJvDynControlVCLDBText.ControlSetDefaultProperties;\r\nbegin\r\nend;\r\n\r\nprocedure TJvDynControlVCLDBText.ControlSetCaption(const Value: string);\r\nbegin\r\nend;\r\n\r\nprocedure TJvDynControlVCLDBText.ControlSetTabOrder(Value: Integer);\r\nbegin\r\nend;\r\n\r\nprocedure TJvDynControlVCLDBText.ControlSetHint(const Value: string);\r\nbegin\r\n Hint := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLDBText.ControlSetOnEnter(Value: TNotifyEvent);\r\nbegin\r\nend;\r\n\r\nprocedure TJvDynControlVCLDBText.ControlSetOnExit(Value: TNotifyEvent);\r\nbegin\r\nend;\r\n\r\nprocedure TJvDynControlVCLDBText.ControlSetOnClick(Value: TNotifyEvent);\r\nbegin\r\nend;\r\n\r\nprocedure TJvDynControlVCLDBText.ControlSetDataSource(Value: TDataSource);\r\nbegin\r\n DataSource := Value;\r\nend;\r\n\r\nfunction TJvDynControlVCLDBText.ControlGetDataSource: TDataSource;\r\nbegin\r\n Result := DataSource;\r\nend;\r\n\r\nprocedure TJvDynControlVCLDBText.ControlSetDataField(const Value: string);\r\nbegin\r\n DataField := Value;\r\nend;\r\n\r\nfunction TJvDynControlVCLDBText.ControlGetDataField: string;\r\nbegin\r\n Result := DataField;\r\nend;\r\n\r\nprocedure TJvDynControlVCLDBText.ControlSetAnchors(Value : TAnchors);\r\nbegin\r\n Anchors := Value;\r\nend;\r\n\r\n//=== { TJvDynControlVCLDBGrid } =============================================\r\n\r\nprocedure TJvDynControlVCLDBGrid.ControlSetDefaultProperties;\r\nbegin\r\nend;\r\n\r\nprocedure TJvDynControlVCLDBGrid.ControlSetCaption(const Value: string);\r\nbegin\r\nend;\r\n\r\nprocedure TJvDynControlVCLDBGrid.ControlSetTabOrder(Value: Integer);\r\nbegin\r\n TabOrder := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLDBGrid.ControlSetHint(const Value: string);\r\nbegin\r\n Hint := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLDBGrid.ControlSetOnEnter(Value: TNotifyEvent);\r\nbegin\r\n OnEnter := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLDBGrid.ControlSetOnExit(Value: TNotifyEvent);\r\nbegin\r\n OnExit := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLDBGrid.ControlSetOnClick(Value: TNotifyEvent);\r\nbegin\r\nend;\r\n\r\nprocedure TJvDynControlVCLDBGrid.ControlSetDataSource(Value: TDataSource);\r\nbegin\r\n DataSource := Value;\r\nend;\r\n\r\nfunction TJvDynControlVCLDBGrid.ControlGetDataSource: TDataSource;\r\nbegin\r\n Result := DataSource;\r\nend;\r\n\r\nprocedure TJvDynControlVCLDBGrid.ControlSetDataField(const Value: string);\r\nbegin\r\nend;\r\n\r\nfunction TJvDynControlVCLDBGrid.ControlGetDataField: string;\r\nbegin\r\n Result := '';\r\nend;\r\n\r\nprocedure TJvDynControlVCLDBGrid.ControlSetAnchors(Value : TAnchors);\r\nbegin\r\n Anchors := Value;\r\nend;\r\n\r\n//=== { TJvDynControlVCLDBNavigator } ========================================\r\n\r\nprocedure TJvDynControlVCLDBNavigator.ControlSetDefaultProperties;\r\nbegin\r\nend;\r\n\r\nprocedure TJvDynControlVCLDBNavigator.ControlSetCaption(const Value: string);\r\nbegin\r\nend;\r\n\r\nprocedure TJvDynControlVCLDBNavigator.ControlSetTabOrder(Value: Integer);\r\nbegin\r\n TabOrder := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLDBNavigator.ControlSetHint(const Value: string);\r\nbegin\r\n Hint := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLDBNavigator.ControlSetOnEnter(Value: TNotifyEvent);\r\nbegin\r\n OnEnter := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLDBNavigator.ControlSetOnExit(Value: TNotifyEvent);\r\nbegin\r\n OnExit := Value;\r\nend;\r\n\r\nprocedure TJvDynControlVCLDBNavigator.ControlSetOnClick(Value: TNotifyEvent);\r\nbegin\r\nend;\r\n\r\nprocedure TJvDynControlVCLDBNavigator.ControlSetDataSource(Value: TDataSource);\r\nbegin\r\n DataSource := Value;\r\nend;\r\n\r\nfunction TJvDynControlVCLDBNavigator.ControlGetDataSource: TDataSource;\r\nbegin\r\n Result := DataSource;\r\nend;\r\n\r\nprocedure TJvDynControlVCLDBNavigator.ControlSetDataField(const Value: string);\r\nbegin\r\nend;\r\n\r\nfunction TJvDynControlVCLDBNavigator.ControlGetDataField: string;\r\nbegin\r\n Result := '';\r\nend;\r\n\r\nprocedure TJvDynControlVCLDBNavigator.ControlSetAnchors(Value : TAnchors);\r\nbegin\r\n Anchors := Value;\r\nend;\r\n\r\n//=== { TJvDynControlEngineVCLDB } ===========================================\r\n\r\nfunction DynControlEngineVCLDB: TJvDynControlEngineDB;\r\nbegin\r\n Result := IntDynControlEngineVCLDB;\r\nend;\r\n\r\nprocedure TJvDynControlEngineVCLDB.RegisterControls;\r\nbegin\r\n RegisterControlType(jctDBText, TJvDynControlVCLDBText);\r\n RegisterControlType(jctDBEdit, TJvDynControlVCLDBEdit);\r\n RegisterControlType(jctDBImage, TJvDynControlVCLDBImage);\r\n RegisterControlType(jctDBCheckBox, TJvDynControlVCLDBCheckBox);\r\n RegisterControlType(jctDBComboBox, TJvDynControlVCLDBComboBox);\r\n RegisterControlType(jctDBListBox, TJvDynControlVCLDBListBox);\r\n RegisterControlType(jctDBRadioGroup, TJvDynControlVCLDBRadioGroup);\r\n RegisterControlType(jctDBDateTimeEdit, TJvDynControlVCLDBEdit);\r\n RegisterControlType(jctDBTimeEdit, TJvDynControlVCLDBEdit);\r\n RegisterControlType(jctDBDateEdit, TJvDynControlVCLDBEdit);\r\n//// RegisterControlType(jctDBCalculateEdit, TJvDynControlVCLDBEdit);\r\n//// RegisterControlType(jctDBSpinEdit, TJvDynControlVCLDBEdit);\r\n RegisterControlType(jctDBDirectoryEdit, TJvDynControlVCLDBDirectoryEdit);\r\n RegisterControlType(jctDBFileNameEdit, TJvDynControlVCLDBFileNameEdit);\r\n RegisterControlType(jctDBMemo, TJvDynControlVCLDBMemo);\r\n RegisterControlType(jctDBButtonEdit, TJvDynControlVCLDBButtonEdit);\r\n RegisterControlType(jctDBGrid, TJvDynControlVCLDBGrid);\r\n RegisterControlType(jctDBNavigator, TJvDynControlVCLDBNavigator);\r\nend;\r\ntype TAccessDBLookupControl = class(TDBLookupControl);\r\n\r\nfunction TJvDynControlEngineVCLDB.GetDataSourceFromDataComponent(ADataComponent: TComponent): TDataSource;\r\nbegin\r\n if not Assigned(ADataComponent) then\r\n Result := nil\r\n else\r\n if ADataComponent is TCustomDBGrid then\r\n Result := TCustomDBGrid(ADataComponent).DataSource\r\n else\r\n if ADataComponent is TDBEdit then\r\n Result := TDBEdit(ADataComponent).DataSource\r\n else\r\n if ADataComponent is TDBNavigator then\r\n Result := TDBNavigator(ADataComponent).DataSource\r\n else\r\n if ADataComponent is TDBListBox then\r\n Result := TDBListbox(ADataComponent).DataSource\r\n else\r\n if ADataComponent is TDBLookupControl then\r\n Result := TAccessDBLookupControl(ADataComponent).DataSource\r\n else\r\n if ADataComponent is TDBImage then\r\n Result := TDBImage(ADataComponent).DataSource\r\n else\r\n if ADataComponent is TDBMemo then\r\n Result := TDBMemo(ADataComponent).DataSource\r\n else\r\n if ADataComponent is TDBRadioGroup then\r\n Result := TDBRadioGroup(ADataComponent).DataSource\r\n else\r\n if ADataComponent is TDBRichEdit then\r\n Result := TDBRichEdit(ADataComponent).DataSource\r\n else\r\n if ADataComponent is TDBText then\r\n Result := TDBText(ADataComponent).DataSource\r\n else\r\n if ADataComponent is TDBCheckBox then\r\n Result := TDBCheckBox(ADataComponent).DataSource\r\n else\r\n Result := inherited GetDataSourceFromDataComponent(ADataComponent);\r\nend;\r\n\r\ninitialization\r\n {$IFDEF UNITVERSIONING}\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n {$ENDIF UNITVERSIONING}\r\n IntDynControlEngineVCLDB := TJvDynControlEngineVCLDB.Create;\r\n SetDefaultDynControlEngineDB(IntDynControlEngineVCLDB);\r\n\r\nfinalization\r\n FreeAndNil(IntDynControlEngineVCLDB);\r\n {$IFDEF UNITVERSIONING}\r\n UnregisterUnitVersion(HInstance);\r\n {$ENDIF UNITVERSIONING}\r\n\r\nend." }, { "path": "External/Jedi/Jvcl/run/JvEasterEgg.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvEasterEgg.PAS, released on 2001-02-28.\r\n\r\nThe Initial Developer of the Original Code is Sbastien Buysse [sbuysse att buypin dott com]\r\nPortions created by Sbastien Buysse are Copyright (C) 2001 Sbastien Buysse.\r\nAll Rights Reserved.\r\n\r\nContributor(s): Michael Beck [mbeck att bigfoot dott com].\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvEasterEgg.pas 13104 2011-09-07 06:50:43Z obones $\r\n\r\nunit JvEasterEgg;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, Messages, SysUtils, Classes, Controls, Forms,\r\n JvComponentBase;\r\n\r\ntype\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64 or pidOSX32)]\r\n {$ENDIF RTL230_UP}\r\n TJvEasterEgg = class(TJvComponent)\r\n private\r\n FActive: Boolean;\r\n FOnEggFound: TNotifyEvent;\r\n FControlKeys: TShiftState;\r\n FEgg: string;\r\n FForm: TCustomForm;\r\n FCurString: string;\r\n function NewWndProc(var Msg: TMessage): Boolean;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n published\r\n property Active: Boolean read FActive write FActive default True;\r\n property Egg: string read FEgg write FEgg;\r\n property ControlKeys: TShiftState read FControlKeys write FControlKeys default [ssAlt];\r\n property OnEggFound: TNotifyEvent read FOnEggFound write FOnEggFound;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvEasterEgg.pas $';\r\n Revision: '$Revision: 13104 $';\r\n Date: '$Date: 2011-09-07 08:50:43 +0200 (mer. 07 sept. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\n\r\nuses\r\n JvWndProcHook;\r\n\r\n\r\nfunction DownCase(Ch: Char): Char;\r\nbegin\r\n Result := Ch;\r\n case Result of\r\n 'A'..'Z':\r\n Inc(Result, Ord('a') - Ord('A'));\r\n end;\r\nend;\r\n\r\nconstructor TJvEasterEgg.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FActive := True;\r\n FControlKeys := [ssAlt];\r\n FForm := GetParentForm(TControl(AOwner));\r\n if (FForm <> nil) and not (csDesigning in ComponentState) then\r\n RegisterWndProcHook(FForm, NewWndProc, hoAfterMsg);\r\nend;\r\n\r\ndestructor TJvEasterEgg.Destroy;\r\nbegin\r\n if (FForm <> nil) and not (csDesigning in ComponentState) then\r\n UnregisterWndProcHook(FForm, NewWndProc, hoAfterMsg);\r\n inherited Destroy;\r\nend;\r\n\r\n\r\nfunction TJvEasterEgg.NewWndProc(var Msg: TMessage): Boolean;\r\nvar\r\n Shift: TShiftState;\r\n KeyState: TKeyBoardState;\r\nbegin\r\n Result := False;\r\n with Msg do\r\n begin\r\n if FActive and (FEgg <> '') then\r\n case Msg of\r\n WM_KEYUP, WM_SYSKEYUP:\r\n begin\r\n GetKeyboardState(KeyState);\r\n Shift := KeyboardStateToShiftState(KeyState);\r\n if Shift = FControlKeys then\r\n begin\r\n if ssShift in Shift then\r\n FCurString := FCurString + UpCase(Char(WParam))\r\n else\r\n FCurString := FCurString + DownCase(Char(WParam));\r\n if FCurString = FEgg then\r\n begin\r\n if Assigned(FOnEggFound) then\r\n FOnEggFound(Self);\r\n FCurString := '';\r\n end\r\n else\r\n if Length(FCurString) >= Length(FEgg) then\r\n FCurString := Copy(FCurString, 2, Length(FEgg));\r\n end;\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\n\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvEdit.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvNewEdit.PAS, released on 2002-mm-dd.\r\n\r\nThe Initial Developer of the Original Code is Sbastien Buysse [sbuysse att buypin dott com]\r\nPortions created by Sbastien Buysse are Copyright (C) 2001 Sbastien Buysse.\r\nAll Rights Reserved.\r\n\r\nThis unit is a merging of the original TJvEdit, TJvExEdit, TJvCaretEdit,TJvAlignedEdit,\r\nTJvSingleLineMemo.\r\nMerging done 2002-06-05 by Peter Thornqvist [peter3 at sourceforge dot net]\r\n\r\n MERGE NOTES:\r\n * TJvCustomEdit has been removed from JvComponent and put here instead.\r\n * The HotTrack property only works if BorderStyle := bsSingle and BevelKind := bvNone\r\n * Added ClipboardCommands\r\n\r\nContributor(s):\r\n Anthony Steele [asteele att iafrica dott com]\r\n Peter Below [100113 dott 1101 att compuserve dott com]\r\n Rob den Braasem [rbraasem att xs4all dott nl] (GroupIndex property - using several TJvEdits with the same GroupIndex\r\n will clear the text from the other edits when something is typed into one of them.\r\n To disable GroupIndex, set it to -1)\r\n Andr Snepvangers [asn att xs4all dott nl] ( clx compatible version )\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvEdit.pas 13415 2012-09-10 09:51:54Z obones $\r\n\r\nunit JvEdit;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, Messages,\r\n Classes, Graphics, Controls, Menus,\r\n JvCaret, JvMaxPixel, JvTypes, JvExStdCtrls, JvDataSourceIntf;\r\n\r\ntype\r\n TJvCustomEdit = class;\r\n\r\n TJvCustomEditDataConnector = class(TJvFieldDataConnector)\r\n private\r\n FEdit: TJvCustomEdit;\r\n protected\r\n procedure RecordChanged; override;\r\n procedure UpdateData; override;\r\n property Control: TJvCustomEdit read FEdit;\r\n public\r\n constructor Create(AEdit: TJvCustomEdit);\r\n end;\r\n\r\n TJvCustomEdit = class(TJvExCustomEdit)\r\n private\r\n FMaxPixel: TJvMaxPixel;\r\n FGroupIndex: Integer;\r\n FAlignment: TAlignment;\r\n FCaret: TJvCaret;\r\n FHotTrack: Boolean;\r\n FDisabledColor: TColor;\r\n FDisabledTextColor: TColor;\r\n FProtectPassword: Boolean;\r\n FStreamedSelLength: Integer;\r\n FStreamedSelStart: Integer;\r\n FUseFixedPopup: Boolean;\r\n FAutoHint: Boolean;\r\n FEmptyValue: string;\r\n FIsEmptyValue: Boolean;\r\n FEmptyFontColor: TColor;\r\n FOldFontColor: TColor;\r\n FIsLoaded: Boolean;\r\n FThemedPassword: Boolean;\r\n FThemedFont: TFont;\r\n FDataConnector: TJvFieldDataConnector;\r\n\r\n function GetPasswordChar: Char;\r\n function IsPasswordCharStored: Boolean;\r\n procedure SetAlignment(Value: TAlignment);\r\n procedure SetCaret(const Value: TJvCaret);\r\n procedure SetDisabledColor(const Value: TColor); virtual;\r\n procedure SetDisabledTextColor(const Value: TColor); virtual;\r\n procedure SetPasswordChar(Value: Char);\r\n procedure SetHotTrack(const Value: Boolean);\r\n procedure WMPaint(var Msg: TWMPaint); message WM_PAINT;\r\n procedure CMHintShow(var Msg: TMessage); message CM_HINTSHOW;\r\n function IsFlatStored: Boolean;\r\n procedure ReadCtl3D(Reader: TReader);\r\n procedure ReadParentCtl3D(Reader: TReader);\r\n procedure ReadModified(Reader: TReader);\r\n function GetParentFlat: Boolean;\r\n procedure SetParentFlat(const Value: Boolean);\r\n procedure SetEmptyValue(const Value: string);\r\n procedure SetGroupIndex(Value: Integer);\r\n function GetFlat: Boolean;\r\n procedure SetThemedPassword(const Value: Boolean);\r\n procedure WMSetFont(var Msg: TWMSetFont); message WM_SETFONT;\r\n function GetThemedFontHandle: HFONT;\r\n procedure SetDataConnector(const Value: TJvFieldDataConnector);\r\n protected\r\n function CreateDataConnector: TJvFieldDataConnector; virtual;\r\n\r\n procedure WMCut(var Msg: TMessage); message WM_CUT;\r\n procedure WMPaste(var Msg: TMessage); message WM_PASTE;\r\n procedure WMClear(var Msg: TMessage); message WM_CLEAR;\r\n procedure WMUndo(var Msg: TMessage); message WM_UNDO;\r\n\r\n { (rb) renamed from UpdateEdit }\r\n procedure UpdateGroup; virtual;\r\n procedure SetClipboardCommands(const Value: TJvClipboardCommands); override;\r\n procedure CaretChanged(Sender: TObject); dynamic;\r\n procedure Change; override;\r\n procedure KeyDown(var Key: Word; Shift: TShiftState); override;\r\n procedure KeyPress(var Key: Char); override;\r\n procedure MaxPixelChanged(Sender: TObject);\r\n procedure SetSelLength(Value: Integer); override;\r\n procedure SetSelStart(Value: Integer); override;\r\n function GetPopupMenu: TPopupMenu; override;\r\n\r\n function GetText: TCaption; virtual;\r\n procedure SetText(const Value: TCaption); virtual;\r\n procedure CreateHandle; override;\r\n procedure DestroyWnd; override;\r\n procedure DoEnter; override;\r\n procedure DoExit; override;\r\n procedure DoEmptyValueEnter; virtual;\r\n procedure DoEmptyValueExit; virtual;\r\n procedure FocusSet(PrevWnd: THandle); override;\r\n procedure FocusKilled(NextWnd: THandle); override;\r\n function DoEraseBackground(Canvas: TCanvas; Param: LPARAM): Boolean; override;\r\n procedure EnabledChanged; override;\r\n procedure SetFlat(Value: Boolean); virtual;\r\n procedure MouseEnter(AControl: TControl); override;\r\n procedure MouseLeave(AControl: TControl); override;\r\n\r\n procedure Loaded; override;\r\n procedure CreateParams(var Params: TCreateParams); override;\r\n procedure DefineProperties(Filer: TFiler); override;\r\n public\r\n function IsEmpty: Boolean;\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n procedure DefaultHandler(var Msg); override;\r\n protected\r\n property Alignment: TAlignment read FAlignment write SetAlignment default taLeftJustify;\r\n property AutoHint: Boolean read FAutoHint write FAutoHint default False;\r\n property Caret: TJvCaret read FCaret write SetCaret;\r\n property EmptyValue: string read FEmptyValue write SetEmptyValue;\r\n property EmptyFontColor: TColor read FEmptyFontColor write FEmptyFontColor default clGrayText;\r\n property HotTrack: Boolean read FHotTrack write SetHotTrack default False;\r\n property PasswordChar: Char read GetPasswordChar write SetPasswordChar stored IsPasswordCharStored;\r\n property ThemedPassword: Boolean read FThemedPassword write SetThemedPassword default False;\r\n // set to True to disable read/write of PasswordChar and read of Text\r\n property ProtectPassword: Boolean read FProtectPassword write FProtectPassword default False;\r\n property DisabledTextColor: TColor read FDisabledTextColor write SetDisabledTextColor default clGrayText;\r\n property DisabledColor: TColor read FDisabledColor write SetDisabledColor default clWindow;\r\n property Text: TCaption read GetText write SetText;\r\n property ParentFlat: Boolean read GetParentFlat write SetParentFlat default True;\r\n property UseFixedPopup: Boolean read FUseFixedPopup write FUseFixedPopup default True;\r\n property HintColor;\r\n property MaxPixel: TJvMaxPixel read FMaxPixel write FMaxPixel;\r\n property GroupIndex: Integer read FGroupIndex write SetGroupIndex default -1;\r\n property OnParentColorChange;\r\n property Flat: Boolean read GetFlat write SetFlat stored IsFlatStored;\r\n\r\n property DataConnector: TJvFieldDataConnector read FDataConnector write SetDataConnector;\r\n end;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvEdit = class(TJvCustomEdit)\r\n published\r\n property BevelEdges;\r\n property BevelInner;\r\n property BevelKind default bkNone;\r\n property BevelOuter;\r\n property BiDiMode;\r\n property DragCursor;\r\n property DragKind;\r\n property EmptyValue;\r\n property EmptyFontColor;\r\n property Flat;\r\n property ImeMode;\r\n property ImeName;\r\n property OEMConvert;\r\n property ParentBiDiMode;\r\n property ParentFlat;\r\n property UseFixedPopup;\r\n property Caret;\r\n property DisabledTextColor;\r\n property DisabledColor;\r\n property HotTrack;\r\n property PasswordChar;\r\n property PopupMenu;\r\n property ProtectPassword;\r\n property Align;\r\n property Alignment;\r\n property ClipboardCommands;\r\n property HintColor;\r\n property GroupIndex;\r\n property MaxPixel;\r\n property ThemedPassword;\r\n property OnMouseEnter;\r\n property OnMouseLeave;\r\n property OnParentColorChange;\r\n\r\n property Anchors;\r\n property AutoSelect;\r\n property AutoSize;\r\n property AutoHint;\r\n property BorderStyle;\r\n property CharCase;\r\n property Color;\r\n property Constraints;\r\n property DragMode;\r\n property Enabled;\r\n property Font;\r\n property HideSelection;\r\n property MaxLength;\r\n property ParentColor;\r\n property ParentFont;\r\n property ParentShowHint;\r\n property ReadOnly;\r\n property ShowHint;\r\n property TabOrder;\r\n property TabStop;\r\n property Text;\r\n property Visible;\r\n property OnChange;\r\n property OnClick;\r\n property OnContextPopup;\r\n property OnDblClick;\r\n property OnDragDrop;\r\n property OnDragOver;\r\n property OnEndDock;\r\n property OnStartDock;\r\n property OnEndDrag;\r\n property OnEnter;\r\n property OnExit;\r\n property OnKeyDown;\r\n property OnKeyPress;\r\n property OnKeyUp;\r\n property OnMouseDown;\r\n property OnMouseMove;\r\n property OnMouseUp;\r\n property OnStartDrag;\r\n\r\n property DataConnector;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvEdit.pas $';\r\n Revision: '$Revision: 13415 $';\r\n Date: '$Date: 2012-09-10 11:51:54 +0200 (lun. 10 sept. 2012) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n Types, SysUtils, Math, Forms,\r\n JvFixedEditPopUp, JvToolEdit;\r\n\r\n//=== Local procedures =======================================================\r\n\r\n// (rom) StrFillChar replaced by StringOfChar\r\n\r\nfunction TextFitsInCtrl(Control: TControl; const Text: string): Boolean;\r\nvar\r\n C: TControlCanvas;\r\n Size: TSize;\r\nbegin\r\n C := TControlCanvas.Create;\r\n try\r\n C.Control := Control;\r\n Result :=\r\n not GetTextExtentPoint32(C.Handle, PChar(Text), Length(Text), Size) or\r\n { (rb) ClientWidth is too big, should be EM_GETRECT }\r\n (Control.ClientWidth > Size.cx);\r\n finally\r\n C.Free;\r\n end;\r\nend;\r\n\r\n//=== { TJvCustomEditDataConnector } =========================================\r\n\r\nconstructor TJvCustomEditDataConnector.Create(AEdit: TJvCustomEdit);\r\nbegin\r\n inherited Create;\r\n FEdit := AEdit;\r\nend;\r\n\r\nprocedure TJvCustomEditDataConnector.RecordChanged;\r\nbegin\r\n if Field.IsValid then\r\n begin\r\n FEdit.ReadOnly := not Field.CanModify;\r\n FEdit.Text := Field.AsString;\r\n end\r\n else\r\n begin\r\n FEdit.Text := '';\r\n FEdit.ReadOnly := False;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomEditDataConnector.UpdateData;\r\nbegin\r\n Field.AsString := FEdit.Text;\r\n FEdit.Text := Field.AsString; // update to stored value\r\nend;\r\n\r\n//=== { TJvCustomEdit } ======================================================\r\n\r\nconstructor TJvCustomEdit.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FDataConnector := CreateDataConnector;\r\n\r\n FAlignment := taLeftJustify;\r\n ClipboardCommands := [caCopy..caUndo];\r\n FDisabledColor := clWindow;\r\n FDisabledTextColor := clGrayText;\r\n FHotTrack := False;\r\n FCaret := TJvCaret.Create(Self);\r\n FCaret.OnChanged := CaretChanged;\r\n FStreamedSelLength := 0;\r\n FStreamedSelStart := 0;\r\n FUseFixedPopup := True;\r\n FMaxPixel := TJvMaxPixel.Create(Self);\r\n FMaxPixel.OnChanged := MaxPixelChanged;\r\n FGroupIndex := -1;\r\n FEmptyFontColor := clGrayText;\r\nend;\r\n\r\ndestructor TJvCustomEdit.Destroy;\r\nbegin\r\n FreeAndNil(FDataConnector);\r\n FMaxPixel.Free;\r\n FCaret.Free;\r\n FThemedFont.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJvCustomEdit.CreateDataConnector: TJvFieldDataConnector;\r\nbegin\r\n Result := TJvCustomEditDataConnector.Create(Self);\r\nend;\r\n\r\nprocedure TJvCustomEdit.CaretChanged(Sender: TObject);\r\nbegin\r\n FCaret.CreateCaret;\r\nend;\r\n\r\nprocedure TJvCustomEdit.Change;\r\nvar\r\n St: string;\r\n Sel: Integer;\r\nbegin\r\n inherited Change;\r\n if not HasParent then\r\n Exit;\r\n St := Text;\r\n FMaxPixel.Test(St, Font);\r\n if St <> Text then\r\n begin\r\n Sel := SelStart;\r\n Text := St;\r\n SelStart := Min(Sel, Length(Text));\r\n end;\r\n if not (csLoading in ComponentState) then\r\n DataConnector.Modify;\r\nend;\r\n\r\n\r\nprocedure TJvCustomEdit.CMHintShow(var Msg: TMessage);\r\nbegin\r\n if AutoHint and not TextFitsInCtrl(Self, Self.Text) and (PasswordChar = #0) then\r\n with TCMHintShow(Msg) do\r\n begin\r\n HintInfo.HintPos := Self.ClientToScreen(Point(-2, Height - 2));\r\n HintInfo.HintStr := Self.Text;\r\n Result := 0;\r\n end\r\n else\r\n inherited;\r\nend;\r\n\r\nprocedure TJvCustomEdit.CreateHandle;\r\nbegin\r\n inherited CreateHandle;\r\n if Focused then\r\n DoEmptyValueEnter\r\n else\r\n DoEmptyValueExit;\r\nend;\r\n\r\nprocedure TJvCustomEdit.CreateParams(var Params: TCreateParams);\r\nconst\r\n Passwords: array [Boolean] of DWORD = (0, ES_PASSWORD);\r\n Styles: array [TAlignment] of DWORD = (ES_LEFT, ES_RIGHT, ES_CENTER);\r\nbegin\r\n inherited CreateParams(Params);\r\n Params.Style := Params.Style or Styles[FAlignment];\r\n Params.Style := Params.Style or Passwords[ThemedPassword];\r\n if (FAlignment <> taLeftJustify) and (Win32Platform = VER_PLATFORM_WIN32_WINDOWS) and\r\n (Win32MajorVersion = 4) and (Win32MinorVersion = 0) then\r\n Params.Style := Params.Style or ES_MULTILINE; // needed for Win95\r\nend;\r\n\r\nprocedure TJvCustomEdit.DefaultHandler(var Msg);\r\nbegin\r\n if ProtectPassword then\r\n with TMessage(Msg) do\r\n case Msg of\r\n WM_CUT, WM_COPY, WM_GETTEXT, WM_GETTEXTLENGTH, EM_SETPASSWORDCHAR:\r\n Result := 0;\r\n else\r\n inherited DefaultHandler(Msg);\r\n end\r\n else\r\n inherited DefaultHandler(Msg);\r\nend;\r\n\r\nprocedure TJvCustomEdit.DestroyWnd;\r\nvar\r\n Tmp: Boolean;\r\nbegin\r\n Tmp := ProtectPassword;\r\n try\r\n // TWinControl.DestroyWnd sends WM_GETTEXTLENGTH & WM_GETTEXT messages,\r\n // thus we have to temporarily set ProtectPassword to False.\r\n ProtectPassword := False;\r\n inherited DestroyWnd;\r\n finally\r\n ProtectPassword := Tmp;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomEdit.WMClear(var Msg: TMessage);\r\nbegin\r\n if not ReadOnly then\r\n inherited;\r\nend;\r\n\r\nprocedure TJvCustomEdit.WMCut(var Msg: TMessage);\r\nbegin\r\n if not ReadOnly then\r\n inherited;\r\nend;\r\n\r\nprocedure TJvCustomEdit.WMPaste(var Msg: TMessage);\r\nbegin\r\n if not ReadOnly then\r\n begin\r\n inherited;\r\n UpdateGroup;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomEdit.DoEmptyValueEnter;\r\nbegin\r\n if (csDesigning in ComponentState) or not FIsLoaded or (EmptyValue = '') then\r\n Exit;\r\n if EmptyValue <> '' then\r\n begin\r\n if (inherited Text) = EmptyValue then\r\n begin\r\n inherited Text := '';\r\n FIsEmptyValue := False;\r\n if not (csDesigning in ComponentState) then\r\n Font.Color := FOldFontColor;\r\n end;\r\n end\r\n else\r\n if not (csDesigning in ComponentState) then\r\n Font.Color := FOldFontColor;\r\nend;\r\n\r\nprocedure TJvCustomEdit.DoEmptyValueExit;\r\nbegin\r\n if (csDesigning in ComponentState) or not FIsLoaded or (EmptyValue = '') then\r\n Exit;\r\n if EmptyValue <> '' then\r\n begin\r\n if Text = '' then\r\n begin\r\n Text := EmptyValue;\r\n FIsEmptyValue := True;\r\n if not (csDesigning in ComponentState) then\r\n begin\r\n FOldFontColor := Font.Color;\r\n Font.Color := FEmptyFontColor;\r\n end;\r\n end;\r\n end\r\n else\r\n if not (csDesigning in ComponentState) then\r\n Font.Color := FOldFontColor;\r\nend;\r\n\r\nprocedure TJvCustomEdit.DoEnter;\r\nbegin\r\n inherited DoEnter;\r\n DoEmptyValueEnter;\r\nend;\r\n\r\nprocedure TJvCustomEdit.DoExit;\r\nbegin\r\n try\r\n DataConnector.UpdateRecord;\r\n except\r\n SetFocus;\r\n raise;\r\n end;\r\n inherited DoExit;\r\n DoEmptyValueExit;\r\nend;\r\n\r\nprocedure TJvCustomEdit.FocusKilled(NextWnd: THandle);\r\nbegin\r\n FCaret.DestroyCaret;\r\n inherited FocusKilled(NextWnd);\r\nend;\r\n\r\nfunction TJvCustomEdit.DoEraseBackground(Canvas: TCanvas; Param: LPARAM): Boolean;\r\nvar\r\n R: TRect;\r\nbegin\r\n if Enabled then\r\n Result := inherited DoEraseBackground(Canvas, Param)\r\n else\r\n begin\r\n Canvas.Brush.Color := FDisabledColor;\r\n Canvas.Brush.Style := bsSolid;\r\n R := ClientRect;\r\n Canvas.FillRect(R);\r\n Result := True;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomEdit.FocusSet(PrevWnd: THandle);\r\nbegin\r\n inherited FocusSet(PrevWnd);\r\n FCaret.CreateCaret;\r\nend;\r\n\r\nprocedure TJvCustomEdit.WMUndo(var Msg: TMessage);\r\nbegin\r\n if not ReadOnly then\r\n inherited;\r\nend;\r\n\r\nprocedure TJvCustomEdit.EnabledChanged;\r\nbegin\r\n inherited EnabledChanged;\r\n Invalidate;\r\nend;\r\n\r\nfunction TJvCustomEdit.GetFlat: Boolean;\r\nbegin\r\n Result := not Ctl3D;\r\nend;\r\n\r\nfunction TJvCustomEdit.GetParentFlat: Boolean;\r\nbegin\r\n Result := ParentCtl3D;\r\nend;\r\n\r\nprocedure TJvCustomEdit.SetParentFlat(const Value: Boolean);\r\nbegin\r\n ParentCtl3D := Value;\r\nend;\r\n\r\nfunction TJvCustomEdit.GetPasswordChar: Char;\r\nbegin\r\n if HandleAllocated then\r\n Result := Char(SendMessage(Handle, EM_GETPASSWORDCHAR, 0, 0))\r\n else\r\n Result := inherited PasswordChar;\r\nend;\r\n\r\nfunction TJvCustomEdit.GetPopupMenu: TPopupMenu;\r\nbegin\r\n Result := inherited GetPopupMenu;\r\n // user has not assigned his own popup menu, so use fixed default\r\n if (Result = nil) and UseFixedPopup then\r\n Result := FixedDefaultEditPopUp(Self);\r\nend;\r\n\r\nfunction TJvCustomEdit.GetText: TCaption;\r\nvar\r\n Tmp: Boolean;\r\nbegin\r\n Tmp := ProtectPassword;\r\n try\r\n ProtectPassword := False;\r\n Result := inherited Text;\r\n finally\r\n ProtectPassword := Tmp;\r\n end;\r\n\r\n if (Result = EmptyValue) and (EmptyValue <> '') then\r\n Result := '';\r\nend;\r\n\r\nfunction TJvCustomEdit.GetThemedFontHandle: HFONT;\r\nvar\r\n AFont: TLogFont;\r\nbegin\r\n GetObject(GetStockObject(DEFAULT_GUI_FONT), SizeOf(AFont), @AFont);\r\n AFont.lfHeight := Self.Font.Height;\r\n Result := CreateFontIndirect(AFont);\r\nend;\r\n\r\nfunction TJvCustomEdit.IsEmpty: Boolean;\r\nbegin\r\n Result := (Length(Text) = 0);\r\nend;\r\n\r\nfunction TJvCustomEdit.IsFlatStored: Boolean;\r\nbegin\r\n { Same as IsCtl3DStored }\r\n Result := not ParentCtl3D;\r\nend;\r\n\r\nfunction TJvCustomEdit.IsPasswordCharStored: Boolean;\r\nbegin\r\n Result := (PasswordChar <> #0) and not ThemedPassword;\r\nend;\r\n\r\nprocedure TJvCustomEdit.KeyDown(var Key: Word; Shift: TShiftState);\r\nbegin\r\n UpdateGroup;\r\n inherited KeyDown(Key, Shift);\r\nend;\r\n\r\nprocedure TJvCustomEdit.KeyPress(var Key: Char);\r\nbegin\r\n inherited KeyPress(Key);\r\n if Key = #27 then\r\n begin\r\n if DataConnector.Active and DataConnector.Field.CanModify then\r\n begin\r\n DataConnector.Reset;\r\n SelectAll;\r\n Key := #0;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomEdit.Loaded;\r\nbegin\r\n inherited Loaded;\r\n { (rb) I think that csLoading flag can be used instead of FIsLoaded.\r\n FIsLoaded is set a bit later to true than csLoading but that\r\n does not matter AFAICS\r\n }\r\n FIsLoaded := True;\r\n FOldFontColor := Font.Color;\r\n SelStart := FStreamedSelStart;\r\n SelLength := FStreamedSelLength;\r\n DataConnector.Reset;\r\nend;\r\n\r\nprocedure TJvCustomEdit.ReadCtl3D(Reader: TReader);\r\nbegin\r\n Flat := not Reader.ReadBoolean;\r\nend;\r\n\r\nprocedure TJvCustomEdit.ReadParentCtl3D(Reader: TReader);\r\nbegin\r\n ParentFlat := Reader.ReadBoolean;\r\nend;\r\n\r\nprocedure TJvCustomEdit.ReadModified(Reader: TReader);\r\nbegin\r\n Reader.ReadBoolean;\r\nend;\r\n\r\nprocedure TJvCustomEdit.DefineProperties(Filer: TFiler);\r\nbegin\r\n inherited DefineProperties(Filer);\r\n\r\n Filer.DefineProperty('Ctl3D', ReadCtl3D, nil, False);\r\n Filer.DefineProperty('ParentCtl3D', ReadParentCtl3D, nil, False);\r\n\r\n { \"inherited Modified\" was published what it shouldn't have been }\r\n Filer.DefineProperty('Modified', ReadModified, nil, False);\r\nend;\r\n\r\nprocedure TJvCustomEdit.MaxPixelChanged(Sender: TObject);\r\nvar\r\n St: string;\r\nbegin\r\n St := Text;\r\n FMaxPixel.Test(St, Font);\r\n if St <> Text then\r\n begin\r\n Text := St;\r\n SelStart := Min(SelStart, Length(Text));\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomEdit.MouseEnter(AControl: TControl);\r\nvar\r\n I, J: Integer;\r\nbegin\r\n if csDesigning in ComponentState then\r\n Exit;\r\n if not MouseOver then\r\n begin\r\n if FHotTrack then\r\n begin\r\n I := SelStart;\r\n J := SelLength;\r\n SelStart := I;\r\n SelLength := J;\r\n end;\r\n// UpdateAutoHint;\r\n inherited MouseEnter(AControl);\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomEdit.MouseLeave(AControl: TControl);\r\nvar\r\n I, J: Integer;\r\nbegin\r\n if MouseOver then\r\n begin\r\n if FHotTrack then\r\n begin\r\n I := SelStart;\r\n J := SelLength;\r\n SelStart := I;\r\n SelLength := J;\r\n end;\r\n inherited MouseLeave(AControl);\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomEdit.SetAlignment(Value: TAlignment);\r\nbegin\r\n if FAlignment <> Value then\r\n begin\r\n FAlignment := Value;\r\n RecreateWnd;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomEdit.SetCaret(const Value: TJvCaret);\r\nbegin\r\n FCaret.Assign(Value);\r\nend;\r\n\r\nprocedure TJvCustomEdit.SetClipboardCommands(const Value: TJvClipboardCommands);\r\nbegin\r\n if ClipboardCommands <> Value then\r\n begin\r\n inherited SetClipboardCommands(Value);\r\n ReadOnly := ClipboardCommands <= [caCopy];\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomEdit.SetDisabledColor(const Value: TColor);\r\nbegin\r\n if FDisabledColor <> Value then\r\n begin\r\n FDisabledColor := Value;\r\n if not Enabled then\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomEdit.SetDisabledTextColor(const Value: TColor);\r\nbegin\r\n if FDisabledTextColor <> Value then\r\n begin\r\n FDisabledTextColor := Value;\r\n if not Enabled then\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomEdit.SetEmptyValue(const Value: string);\r\nbegin\r\n FEmptyValue := Value;\r\n if HandleAllocated then\r\n if Focused then\r\n DoEmptyValueEnter\r\n else\r\n DoEmptyValueExit;\r\nend;\r\n\r\nprocedure TJvCustomEdit.SetFlat(Value: Boolean);\r\nbegin\r\n Ctl3D := not Value;\r\nend;\r\n\r\nprocedure TJvCustomEdit.SetGroupIndex(Value: Integer);\r\nbegin\r\n if Value <> FGroupIndex then\r\n begin\r\n FGroupIndex := Value;\r\n UpdateGroup;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomEdit.SetHotTrack(const Value: Boolean);\r\nbegin\r\n FHotTrack := Value;\r\n Flat := FHotTrack;\r\nend;\r\n\r\nprocedure TJvCustomEdit.SetPasswordChar(Value: Char);\r\nvar\r\n Tmp: Boolean;\r\nbegin\r\n Tmp := ProtectPassword;\r\n try\r\n ProtectPassword := False;\r\n if HandleAllocated then\r\n inherited PasswordChar := Char(SendMessage(Handle, EM_GETPASSWORDCHAR, 0, 0));\r\n inherited PasswordChar := Value;\r\n finally\r\n ProtectPassword := Tmp;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomEdit.SetSelLength(Value: Integer);\r\nbegin\r\n if csReading in ComponentState then\r\n FStreamedSelLength := Value\r\n else\r\n inherited SetSelLength(Value);\r\nend;\r\n\r\nprocedure TJvCustomEdit.SetSelStart(Value: Integer);\r\nbegin\r\n if csReading in ComponentState then\r\n FStreamedSelStart := Value\r\n else\r\n inherited SetSelStart(Value);\r\nend;\r\n\r\nprocedure TJvCustomEdit.SetText(const Value: TCaption);\r\nbegin\r\n if (csLoading in ComponentState) or not FIsLoaded then\r\n begin\r\n inherited Text := Value;\r\n Exit;\r\n end;\r\n FIsEmptyValue := (Value = '') and (EmptyValue <> '') and not Focused;\r\n if not FIsEmptyValue then\r\n begin\r\n Font.Color := FOldFontColor;\r\n inherited Text := Value;\r\n end\r\n else\r\n begin\r\n Font.Color := FEmptyFontColor;\r\n inherited Text := EmptyValue;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomEdit.SetThemedPassword(const Value: Boolean);\r\nbegin\r\n if FThemedPassword <> Value then\r\n begin\r\n FThemedPassword := Value;\r\n if not FThemedPassword then\r\n FreeAndNil(FThemedFont);\r\n PasswordChar := #0;\r\n RecreateWnd;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomEdit.UpdateGroup;\r\nvar\r\n I: Integer;\r\nbegin\r\n if (FGroupIndex <> -1) and (Owner <> nil) then\r\n for I := 0 to Owner.ComponentCount - 1 do\r\n if (Owner.Components[I] is TJvCustomEdit) and (Owner.Components[I] <> Self) and\r\n (TJvCustomEdit(Owner.Components[I]).GroupIndex = Self.GroupIndex) then\r\n TJvCustomEdit(Owner.Components[I]).Clear;\r\nend;\r\n\r\nprocedure TJvCustomEdit.WMPaint(var Msg: TWMPaint);\r\nvar\r\n Canvas: TControlCanvas;\r\n S: TCaption;\r\nbegin\r\n if csDestroying in ComponentState then\r\n Exit;\r\n { PaintEdit does not work well when the edit is themed (and ThemedPassword=true),\r\n as a workaround check if the disabled colors are set to the default so\r\n the edit can paint itself (We must check both colors, although only\r\n DisabledTextColor is passed on to PaintEdit; PaintEdit triggers a\r\n DoEraseBackground call) }\r\n if Enabled or\r\n ((ColorToRGB(DisabledTextColor) =\r\n ColorToRGB(clGrayText)) and (ColorToRGB(DisabledColor) = ColorToRGB(clWindow))) then\r\n inherited\r\n else\r\n begin\r\n if PasswordChar = #0 then\r\n S := Text\r\n else\r\n S := StringOfChar(PasswordChar, Length(Text));\r\n Canvas := nil;\r\n try\r\n if not PaintEdit(Self, S, FAlignment, False, {0,} FDisabledTextColor,\r\n Focused, Canvas, Msg) then\r\n inherited;\r\n finally\r\n Canvas.Free;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomEdit.WMSetFont(var Msg: TWMSetFont);\r\nbegin\r\n if ThemedPassword then\r\n begin\r\n // Retrieves MS Shell Dlg.\r\n // Other way is to use Screen.IconFont\r\n if FThemedFont = nil then\r\n FThemedFont := TFont.Create;\r\n FThemedFont.Handle := GetThemedFontHandle;\r\n Msg.Font := FThemedFont.Handle;\r\n end;\r\n inherited;\r\nend;\r\n\r\nprocedure TJvCustomEdit.SetDataConnector(const Value: TJvFieldDataConnector);\r\nbegin\r\n FDataConnector.Assign(Value);\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvEditor.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvEditor.PAS, released on 2002-07-04.\r\n\r\nThe Initial Developers of the Original Code are: Andrei Prygounkov \r\nCopyright (c) 1999, 2002 Andrei Prygounkov\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\nBurov Dmitry, translation of russian text.\r\nAndreas Hausladen\r\nPeter Thrnqvist\r\nRemko Bonte\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\ncomponent : TJvEditor\r\ndescription : 'Delphi IDE'-like Editor\r\n\r\nKnown Issues:\r\n Some russian comments were translated to english; these comments are marked\r\n with [translated]\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvEditor.pas 13407 2012-08-28 19:29:35Z ahuser $\r\n\r\nunit JvEditor;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, Messages, Classes, Controls,\r\n JvEditorCommon;\r\n\r\ntype\r\n TJvCustomEditor = class;\r\n\r\n TJvEditorStrings = class(TStringList)\r\n private\r\n FJvEditor: TJvCustomEditor;\r\n procedure StringsChanged(Sender: TObject);\r\n procedure SetInternal(Index: Integer; const Value: string);\r\n procedure ReLine;\r\n procedure SetLockText(const Text: string);\r\n protected\r\n procedure Put(Index: Integer; const S: string); override;\r\n procedure InternalPut(Index: Integer; const Value: string);\r\n\r\n property Internal[Index: Integer]: string write SetInternal;\r\n property JvEditor: TJvCustomEditor read FJvEditor;\r\n public\r\n constructor Create;\r\n destructor Destroy; override;\r\n procedure Assign(Source: TPersistent); override;\r\n procedure AddStrings(Strings: TStrings); override;\r\n procedure SetTextStr(const Value: string); override;\r\n function Add(const S: string): Integer; override;\r\n procedure Insert(Index: Integer; const S: string); override;\r\n procedure Delete(Index: Integer); override;\r\n procedure DeleteText(BegX, BegY, EndX, EndY: Integer);\r\n procedure InsertText(X, Y: Integer; const Text: string);\r\n procedure DeleteColumnText(BegX, BegY, EndX, EndY: Integer);\r\n procedure InsertColumnText(X, Y: Integer; const Text: string);\r\n end;\r\n\r\n TJvCompletion = class;\r\n TOnCompletionApply = procedure(Sender: TObject; const OldString: string;\r\n var NewString: string) of object;\r\n TJvGetLineAttrEvent = procedure(Sender: TObject; var Line: string; Index: Integer;\r\n var Attrs: TLineAttrs) of object;\r\n\r\n TJvCustomEditor = class(TJvCustomEditorBase)\r\n private\r\n { internal objects }\r\n FLines: TJvEditorStrings;\r\n { events }\r\n FOnGetLineAttr: TJvGetLineAttrEvent;\r\n FOnCompletionApply: TOnCompletionApply;\r\n\r\n { get/set for properties }\r\n function GetLines: TStrings;\r\n procedure SetLines(ALines: TStrings);\r\n function GetCompletion: TJvCompletion;\r\n procedure SetCompletion(const Value: TJvCompletion);\r\n protected\r\n function GetLineCount: Integer; override;\r\n function GetLineLength(Index: Integer): Integer; override;\r\n function FindNotBlankCharPosInLine(Line: Integer): Integer; override;\r\n\r\n function GetTextLine(Y: Integer; out Text: string): Boolean; override;\r\n function InternGetWordOnCaret: string; override;\r\n\r\n procedure ReLine; override;\r\n function GetTabStop(X, Y: Integer; Next: Boolean): Integer; override;\r\n function GetBackStop(X, Y: Integer): Integer; override;\r\n procedure TextAllChangedInternal(Unselect: Boolean); override;\r\n protected\r\n procedure PaintLineText(Line: Integer; ColBeg, ColEnd: Integer;\r\n var ColPainted: Integer); override;\r\n procedure InsertChar(const Value: Word); override;\r\n protected\r\n procedure SetLockText(const Text: string);\r\n function ExpandTabs(const S: string): string;\r\n function GetAutoIndentStop(Y: Integer): Integer; override;\r\n\r\n { triggers for descendants }\r\n procedure GetLineAttr(var Str: string; Line, ColBeg, ColEnd: Integer); virtual;\r\n function DoCommand(ACommand: TEditCommand; var X, Y: Integer;\r\n var CaretUndo: Boolean): Boolean; override;\r\n { TextModified is called when the editor content has changed. }\r\n procedure TextModified(ACaretX, ACaretY: Integer; Action: TModifiedAction;\r\n const Text: string); dynamic;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n\r\n procedure ClipboardCopy; override;\r\n procedure ClipboardPaste; override;\r\n procedure DeleteSelected; override;\r\n procedure Clear;\r\n\r\n function GetSelText: string;\r\n procedure SetSelText(const AValue: string);\r\n function GetWordOnCaret: string;\r\n procedure SelectWordOnCaret; override;\r\n function GetText: string; override;\r\n\r\n procedure InsertText(const Text: string);\r\n procedure InsertColumnText(X, Y: Integer; const Text: string);\r\n procedure ReplaceWord(const NewString: string);\r\n procedure ReplaceWord2(const NewString: string);\r\n procedure IndentColumns(X: Integer; BegY, EndY: Integer); override;\r\n procedure UnIndentColumns(X: Integer; BegY, EndY: Integer); override;\r\n\r\n property SelText: string read GetSelText write SetSelText;\r\n public\r\n { published in descendants }\r\n property Lines: TStrings read GetLines write SetLines;\r\n property Completion: TJvCompletion read GetCompletion write SetCompletion;\r\n property OnGetLineAttr: TJvGetLineAttrEvent read FOnGetLineAttr write FOnGetLineAttr;\r\n property OnCompletionApply: TOnCompletionApply read FOnCompletionApply write FOnCompletionApply;\r\n end;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvEditor = class(TJvCustomEditor)\r\n published\r\n property BeepOnError;\r\n property BorderStyle;\r\n property Lines;\r\n property ScrollBars;\r\n property GutterWidth;\r\n property GutterColor;\r\n property RightMarginVisible;\r\n property RightMargin;\r\n property RightMarginColor;\r\n property InsertMode;\r\n property ReadOnly;\r\n property DoubleClickLine;\r\n property HideCaret;\r\n property Completion;\r\n property TabStops;\r\n property SmartTab;\r\n property BackSpaceUnindents;\r\n property AutoIndent;\r\n property KeepTrailingBlanks;\r\n property CursorBeyondEOF;\r\n property CursorBeyondEOL;\r\n property BracketHighlighting;\r\n property SelForeColor;\r\n property SelBackColor;\r\n property SelBlockFormat;\r\n\r\n property OnGetLineAttr;\r\n property OnChangeStatus;\r\n property OnScroll;\r\n property OnResize;\r\n property OnKeyDown;\r\n property OnKeyPress;\r\n property OnKeyUp;\r\n property OnChange;\r\n property OnCaretChanged;\r\n property OnSelectionChange;\r\n property OnMouseDown;\r\n property OnMouseMove;\r\n property OnMouseUp;\r\n property OnDblClick;\r\n property OnPaintGutter;\r\n property OnGutterClick;\r\n property OnGutterDblClick;\r\n property OnCompletionIdentifier;\r\n property OnCompletionTemplate;\r\n property OnCompletionDrawItem;\r\n property OnCompletionMeasureItem;\r\n property OnCompletionApply;\r\n property OnLineInserted;\r\n property OnLineDeleted;\r\n\r\n { TControl }\r\n property DragMode;\r\n property DragKind;\r\n property DragCursor;\r\n property OnDragOver;\r\n property OnDragDrop;\r\n property OnStartDock;\r\n property OnStartDrag;\r\n property OnEndDock;\r\n property OnEndDrag;\r\n\r\n { TCustomControl }\r\n property Align;\r\n property Enabled;\r\n property Color;\r\n property Font;\r\n property ParentColor;\r\n property ParentFont;\r\n property ParentShowHint;\r\n property PopupMenu;\r\n property ShowHint;\r\n property TabStop;\r\n property Visible;\r\n property Anchors;\r\n property AutoSize;\r\n property BiDiMode;\r\n property Constraints;\r\n property UseDockManager;\r\n property DockSite;\r\n property ParentBiDiMode;\r\n property OnCanResize;\r\n property OnConstrainedResize;\r\n property OnDockDrop;\r\n property OnDockOver;\r\n property OnGetSiteInfo;\r\n property OnUnDock;\r\n property OnEnter;\r\n property OnExit;\r\n end;\r\n\r\n TJvCompletion = class(TJvCompletionBase)\r\n private\r\n FIdentifiers: TStringList;\r\n FTemplates: TStringList;\r\n FCaretChar: Char;\r\n FCRLF: string;\r\n FSeparator: string;\r\n function GetStrings(Index: Integer): TStrings;\r\n procedure SetStrings(Index: Integer; AValue: TStrings);\r\n procedure ReplaceWord(const NewString: string);\r\n protected\r\n procedure FindSelItem(var Eq: Boolean); override;\r\n procedure MakeItems; override;\r\n procedure ReplaceWordItemIndex(SubStrStart: Integer); override;\r\n function GetTemplateCount: Integer; override;\r\n function GetIdentifierCount: Integer; override;\r\n function GetSeparator: string; override;\r\n public\r\n constructor Create(AJvEditor: TJvCustomEditor);\r\n destructor Destroy; override;\r\n published\r\n property Identifiers: TStrings index 0 read GetStrings write SetStrings;\r\n property Templates: TStrings index 1 read GetStrings write SetStrings;\r\n property CaretChar: Char read FCaretChar write FCaretChar default '|';\r\n property CRLF: string read FCRLF write FCRLF;\r\n property Separator: string read FSeparator write FSeparator;\r\n end;\r\n\r\n TJvInsertUndo = class(TJvCaretUndo)\r\n private\r\n FText: string;\r\n function GetEditor: TJvCustomEditor;\r\n public\r\n constructor Create(AJvEditor: TJvCustomEditor; ACaretX, ACaretY: Integer;\r\n const AText: string);\r\n procedure Undo; override;\r\n end;\r\n\r\n TJvOverwriteUndo = class(TJvCaretUndo)\r\n private\r\n FOldText: string;\r\n FNewText: string;\r\n function GetEditor: TJvCustomEditor;\r\n public\r\n constructor Create(AJvEditor: TJvCustomEditor; ACaretX, ACaretY: Integer;\r\n const AOldText, ANewText: string);\r\n procedure Undo; override;\r\n end;\r\n\r\n TJvReLineUndo = class(TJvInsertUndo, IJvUndoCompound);\r\n\r\n TJvInsertTabUndo = class(TJvInsertUndo);\r\n\r\n TJvInsertColumnUndo = class(TJvInsertUndo)\r\n public\r\n procedure Undo; override;\r\n end;\r\n\r\n TJvDeleteUndo = class(TJvInsertUndo)\r\n public\r\n procedure Undo; override;\r\n end;\r\n\r\n TJvDeleteLineUndo = class(TJvInsertUndo)\r\n private\r\n FLastLineDelete: Boolean;\r\n public\r\n constructor Create(AJvEditor: TJvCustomEditor; ACaretX, ACaretY: Integer;\r\n const AText: string; ALastLineDelete: Boolean);\r\n procedure Undo; override;\r\n //procedure Redo; override;\r\n end;\r\n\r\n TJvDeleteTrailUndo = class(TJvDeleteUndo, IJvUndoCompound);\r\n\r\n TJvBackspaceUndo = class(TJvDeleteUndo, IJvBackspaceUndo)\r\n public\r\n procedure Undo; override;\r\n end;\r\n\r\n TJvBackspaceUnindentUndo = class(TJvDeleteUndo, IJvBackspaceUnindentUndo)\r\n public\r\n procedure Undo; override;\r\n end;\r\n\r\n TJvReplaceUndo = class(TJvCaretUndo)\r\n private\r\n FBegX: Integer;\r\n FBegY: Integer;\r\n FText: string;\r\n FNewText: string;\r\n function GetEditor: TJvCustomEditor;\r\n public\r\n constructor Create(AJvEditor: TJvCustomEditor; ACaretX, ACaretY: Integer;\r\n ABegX, ABegY: Integer; const AText, ANewText: string);\r\n procedure Undo; override;\r\n end;\r\n\r\n TJvDeleteSelectedUndo = class(TJvDeleteUndo)\r\n public\r\n constructor Create(AJvEditor: TJvCustomEditor; ACaretX, ACaretY: Integer;\r\n const AText: string);\r\n procedure Undo; override;\r\n end;\r\n\r\n(* // (ahuser) make Delphi 5 compiler happy\r\n TJvIndentColumnUndo = class(TJvInsertColumnUndo)\r\n private\r\n FNewCaretX: Integer;\r\n FNewCaretY: Integer;\r\n public\r\n constructor Create(AJvEditor: TJvCustomEditor; ACaretX, ACaretY: Integer;\r\n ABegX, ABegY: Integer; const AText: string);\r\n procedure Undo; override;\r\n end;\r\n*)\r\n\r\n TJvUnindentColumnUndo = class(TJvInsertUndo)\r\n private\r\n FBegX: Integer;\r\n FBegY: Integer;\r\n public\r\n constructor Create(AJvEditor: TJvCustomEditor; ACaretX, ACaretY,\r\n ABegX, ABegY: Integer; const AText: string);\r\n procedure Undo; override;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvEditor.pas $';\r\n Revision: '$Revision: 13407 $';\r\n Date: '$Date: 2012-08-28 21:29:35 +0200 (mar. 28 août 2012) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n SysUtils, Math, Graphics, Clipbrd,\r\n {$IFDEF UNICODE}\r\n Character,\r\n {$ENDIF UNICODE}\r\n JvUnicodeCanvas, JvJCLUtils, JvConsts, JvResources;\r\n\r\ntype\r\n TJvUndoBufferAccessProtected = class(TJvUndoBuffer);\r\n\r\n//=== { TJvEditorStrings } ===================================================\r\n\r\nconstructor TJvEditorStrings.Create;\r\nbegin\r\n inherited Create;\r\n OnChange := StringsChanged;\r\nend;\r\n\r\ndestructor TJvEditorStrings.Destroy;\r\nbegin\r\n OnChange := nil;\r\n OnChanging := nil;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvEditorStrings.Assign(Source: TPersistent);\r\nbegin\r\n JvEditor.BeginUpdate;\r\n try\r\n inherited Assign(Source);\r\n JvEditor.NotUndoable;\r\n JvEditor.TextAllChanged;\r\n finally\r\n JvEditor.EndUpdate;\r\n end;\r\nend;\r\n\r\nprocedure TJvEditorStrings.AddStrings(Strings: TStrings);\r\nbegin\r\n JvEditor.BeginUpdate;\r\n try\r\n inherited AddStrings(Strings);\r\n JvEditor.NotUndoable;\r\n finally\r\n JvEditor.EndUpdate;\r\n end;\r\nend;\r\n\r\nprocedure TJvEditorStrings.SetTextStr(const Value: string);\r\nbegin\r\n inherited SetTextStr(JvEditor.ExpandTabs(Value));\r\n if JvEditor.UpdateLock = 0 then\r\n JvEditor.NotUndoable;\r\n JvEditor.TextAllChanged;\r\nend;\r\n\r\nprocedure TJvEditorStrings.StringsChanged(Sender: TObject);\r\nbegin\r\n if JvEditor.UpdateLock = 0 then\r\n JvEditor.TextAllChanged;\r\nend;\r\n\r\nprocedure TJvEditorStrings.SetLockText(const Text: string);\r\nbegin\r\n JvEditor.LockUpdate;\r\n try\r\n inherited SetTextStr(Text)\r\n finally\r\n JvEditor.UnlockUpdate;\r\n end;\r\nend;\r\n\r\nprocedure TJvEditorStrings.SetInternal(Index: Integer; const Value: string);\r\nbegin\r\n JvEditor.LockUpdate;\r\n try\r\n InternalPut(Index, Value);\r\n finally\r\n JvEditor.UnlockUpdate;\r\n end;\r\nend;\r\n\r\nfunction TJvEditorStrings.Add(const S: string): Integer;\r\nbegin\r\n Result := inherited Add(JvEditor.ExpandTabs(S));\r\nend;\r\n\r\nprocedure TJvEditorStrings.Insert(Index: Integer; const S: string);\r\nbegin\r\n inherited Insert(Index, JvEditor.ExpandTabs(S));\r\n JvEditor.LineInserted(Index);\r\nend;\r\n\r\nprocedure TJvEditorStrings.Delete(Index: Integer);\r\nbegin\r\n inherited Delete(Index);\r\n JvEditor.LineDeleted(Index);\r\nend;\r\n\r\nprocedure TJvEditorStrings.Put(Index: Integer; const S: string);\r\nvar\r\n L: Integer;\r\nbegin\r\n if JvEditor.KeepTrailingBlanks then\r\n inherited Put(Index, S)\r\n else\r\n begin\r\n L := Length(S) - Length(TrimRight(S));\r\n if L = 0 then\r\n inherited Put(Index, S)\r\n else\r\n begin\r\n {--- UNDO ---}\r\n TJvDeleteTrailUndo.Create(JvEditor, Length(S), Index, Spaces(L));\r\n {--- /UNDO ---}\r\n inherited Put(Index, TrimRight(S));\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvEditorStrings.ReLine;\r\nvar\r\n L: Integer;\r\n S: string;\r\n Y: Integer;\r\nbegin\r\n Y := JvEditor.CaretY; // save because Add('') changes CaretY\r\n JvEditor.LockUpdate;\r\n try\r\n BeginUpdate;\r\n try\r\n if Count = 0 then\r\n L := JvEditor.CaretX\r\n else\r\n L := Length(Strings[Count - 1]);\r\n while Y > Count - 1 do\r\n begin\r\n {--- UNDO ---}\r\n TJvReLineUndo.Create(JvEditor, L, JvEditor.CaretY, sLineBreakStr);\r\n {--- /UNDO ---}\r\n L := 0;\r\n Add('');\r\n end;\r\n JvEditor.CaretY := Y; // restore CaretY\r\n S := Strings[Y];\r\n if JvEditor.CaretX > Length(S) then\r\n begin\r\n L := JvEditor.CaretX - Length(S);\r\n {--- UNDO ---}\r\n // TJvReLineUndo.Create(JvEditor, Length(S), Y, Spaces(L)); {disabled: moves the caret to wrong undo position }\r\n {--- /UNDO ---}\r\n inherited Put(Y, S + Spaces(L));\r\n end;\r\n finally\r\n EndUpdate;\r\n end;\r\n finally\r\n JvEditor.UnlockUpdate;\r\n end;\r\nend;\r\n\r\nprocedure TJvEditorStrings.InternalPut(Index: Integer; const Value: string);\r\nbegin\r\n if JvEditor.KeepTrailingBlanks then\r\n inherited Put(Index, JvEditor.ExpandTabs(Value))\r\n else\r\n inherited Put(Index, TrimRight(JvEditor.ExpandTabs(Value)));\r\nend;\r\n\r\n{ delete text from [BegX..EndY] [BegY..EndY] all inclusive.\r\n BegX, EndX: [0..Max_X] }\r\n\r\nprocedure TJvEditorStrings.DeleteText(BegX, BegY, EndX, EndY: Integer);\r\nvar\r\n BegLine, EndLine: string;\r\n I, L: Integer;\r\nbegin\r\n if BegY < 0 then\r\n begin\r\n BegY := 0;\r\n BegX := 0;\r\n end;\r\n if BegY >= Count then\r\n Exit; // nothing to delete\r\n if EndY >= Count then\r\n begin\r\n EndY := Count - 1;\r\n EndX := MaxInt - 1;\r\n end;\r\n if BegX < 0 then\r\n BegX := 0;\r\n\r\n JvEditor.LockUpdate;\r\n BeginUpdate;\r\n try\r\n BegLine := Strings[BegY];\r\n // expand BegLine if necessary\r\n L := (BegX + 1) - Length(BegLine) - 1;\r\n if L > 0 then\r\n BegLine := BegLine + Spaces(L);\r\n\r\n EndLine := Strings[EndY];\r\n\r\n // delete lines between and end line\r\n for I := EndY downto BegY + 1 do\r\n Delete(I);\r\n\r\n System.Delete(BegLine, BegX + 1, MaxInt);\r\n System.Delete(EndLine, 1, EndX + 1);\r\n\r\n Internal[BegY] := BegLine + EndLine;\r\n finally\r\n EndUpdate;\r\n JvEditor.UnlockUpdate;\r\n end;\r\nend;\r\n\r\n{ insert text on X:[0..Max_X], Y }\r\n\r\nprocedure TJvEditorStrings.InsertText(X, Y: Integer; const Text: string);\r\nvar\r\n BegLine, EndLine: string;\r\n YStart: Integer;\r\n F, P: PChar;\r\n S, FirstLine: string;\r\n Len: Integer;\r\nbegin\r\n Inc(X); // increment for string functions\r\n if Y < 0 then\r\n Y := 0;\r\n while Y >= Count do\r\n Add('');\r\n\r\n BegLine := Strings[Y];\r\n EndLine := System.Copy(BegLine, X, MaxInt);\r\n System.Delete(BegLine, X, MaxInt);\r\n\r\n // line is too small -> expand it with spaces\r\n Len := Length(BegLine);\r\n if Len < X then\r\n begin\r\n SetLength(BegLine, X - 1);\r\n P := PChar(BegLine) + Len;\r\n Len := X - Len - 1;\r\n while Len > 0 do\r\n begin\r\n P^ := ' ';\r\n Inc(P);\r\n Dec(Len);\r\n end;\r\n end;\r\n\r\n JvEditor.LockUpdate;\r\n BeginUpdate;\r\n try\r\n P := PChar(Text);\r\n F := P;\r\n while (P[0] <> #0) and (P[0] <> Lf) and (P[0] <> Cr) do\r\n Inc(P);\r\n\r\n SetString(S, F, P - F);\r\n\r\n YStart := Y;\r\n FirstLine := BegLine + S; // set Internal[YStart] later so we keep the trailing spaces for concat EndLine\r\n\r\n while P[0] <> #0 do\r\n begin\r\n if P[0] = Cr then\r\n Inc(P);\r\n if P[0] = Lf then\r\n Inc(P);\r\n F := P;\r\n\r\n while (P[0] <> #0) and (P[0] <> Lf) and (P[0] <> Cr) do\r\n Inc(P);\r\n SetString(S, F, P - F);\r\n Inc(Y);\r\n Insert(Y, S);\r\n end;\r\n\r\n if Y = YStart then\r\n Internal[YStart] := FirstLine + EndLine\r\n else\r\n begin\r\n Internal[YStart] := FirstLine;\r\n Internal[Y] := Strings[Y] + EndLine;\r\n end;\r\n finally\r\n EndUpdate;\r\n JvEditor.UnlockUpdate;\r\n end;\r\nend;\r\n\r\n{ delete column text from [BegX..EndY] [BegY..EndY] all inclusive.\r\n BegX, EndX: [0..Max_X] }\r\n\r\nprocedure TJvEditorStrings.DeleteColumnText(BegX, BegY, EndX, EndY: Integer);\r\nvar\r\n S: string;\r\n I: Integer;\r\nbegin\r\n if BegY < 0 then\r\n begin\r\n BegY := 0;\r\n BegX := 0;\r\n end;\r\n if BegY >= Count then\r\n Exit; // nothing to delete\r\n if EndY >= Count then\r\n begin\r\n EndY := Count - 1;\r\n EndX := MaxInt - 1;\r\n end;\r\n if BegX < 0 then\r\n BegX := 0;\r\n\r\n JvEditor.LockUpdate;\r\n BeginUpdate;\r\n try\r\n for I := BegY to EndY do\r\n begin\r\n S := JvEditor.FLines[I];\r\n System.Delete(S, BegX + 1, EndX - BegX + 1);\r\n JvEditor.FLines.Internal[I] := S;\r\n end;\r\n finally\r\n EndUpdate;\r\n JvEditor.UnlockUpdate;\r\n end;\r\nend;\r\n\r\n{ insert column text on X:[0..Max_X], Y }\r\n\r\nprocedure TJvEditorStrings.InsertColumnText(X, Y: Integer; const Text: string);\r\nvar\r\n S, Line: string;\r\n P, F: PChar;\r\n L: Integer;\r\nbegin\r\n Inc(X); // increment for string functions\r\n if Y < 0 then\r\n Y := 0;\r\n\r\n JvEditor.LockUpdate;\r\n BeginUpdate;\r\n try\r\n P := PChar(Text);\r\n F := P;\r\n while P[0] <> #0 do\r\n begin\r\n while (P[0] <> #0) and (P[0] <> Lf) and (P[0] <> Cr) do\r\n Inc(P);\r\n SetString(S, F, P - F);\r\n\r\n while Y >= Count do\r\n Add('');\r\n Line := Strings[Y];\r\n L := (X - 1) - Length(Line);\r\n if L > 0 then\r\n Line := Line + Spaces(L);\r\n System.Insert(S, Line, X);\r\n Internal[Y] := Line;\r\n\r\n if P[0] = Cr then\r\n Inc(P);\r\n if P[0] = Lf then\r\n Inc(P);\r\n F := P;\r\n Inc(Y);\r\n end;\r\n finally\r\n EndUpdate;\r\n JvEditor.UnlockUpdate;\r\n end;\r\nend;\r\n\r\n//=== { TJvCustomEditor } ====================================================\r\n\r\nconstructor TJvCustomEditor.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FLines := TJvEditorStrings.Create;\r\n FLines.FJvEditor := Self;\r\n FLines.OnChange := DoLinesChange;\r\n Completion := TJvCompletion.Create(Self);\r\nend;\r\n\r\ndestructor TJvCustomEditor.Destroy;\r\nbegin\r\n FLines.Free;\r\n Completion.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvCustomEditor.PaintLineText(Line: Integer; ColBeg, ColEnd: Integer;\r\n var ColPainted: Integer);\r\nvar\r\n Ch: string;\r\n iC, jC, SL, MX: Integer;\r\n R: TRect;\r\n S: string;\r\n LA: TLineAttr;\r\n jCStart, Len: Integer;\r\n MyDi: TDynIntArray;\r\n ColCount: Integer;\r\n {$IFDEF COMPILER12_UP}\r\n CharSize: Integer;\r\n {$ENDIF COMPILER12_UP}\r\nbegin\r\n with EditorClient do\r\n begin\r\n S := FLines[Line];\r\n\r\n Len := Max(Length(S), Max_X) + 1;\r\n if Len > Length(LineAttrs) then\r\n SetLength(LineAttrs, Len)\r\n else\r\n if Len + 128 < Length(LineAttrs) then\r\n SetLength(LineAttrs, Len);\r\n\r\n GetLineAttr(S, Line, ColBeg, ColEnd);\r\n\r\n {left line}\r\n if Canvas.Brush.Color <> LineAttrs[LeftCol + 1].BC then // change GDI object only if necessary\r\n Canvas.Brush.Color := LineAttrs[LeftCol + 1].BC;\r\n\r\n Canvas.FillRect(Bounds(EditorClient.Left, (Line - TopRow) *\r\n CellRect.Height, 1, CellRect.Height));\r\n {optimized, paint group of chars with identical attributes}\r\n SL := Length(S);\r\n MX := ColEnd;\r\n\r\n {TODO: This code hasn't any effect anymore because in the inner loop MyDi[] is changed. Rethink the whole implementation.}\r\n if Length(FMyDi) < MX then\r\n begin\r\n SetLength(MyDi, MX);\r\n for iC := 0 to High(MyDi) do\r\n MyDi[iC] := CellRect.Width;\r\n end\r\n else\r\n MyDi := FMyDi;\r\n\r\n while ColPainted < MX do\r\n begin\r\n with Canvas do\r\n begin\r\n iC := ColPainted + 1;\r\n LA := LineAttrs[iC];\r\n jC := iC + 1;\r\n if iC <= SL then\r\n Ch := S[iC]\r\n else\r\n Ch := ' ';\r\n jCStart := jC;\r\n while (jC <= MX + 1) and\r\n CompareMem(@LA, @LineAttrs[jC], SizeOf(LineAttrs[1])) do\r\n Inc(jC);\r\n Ch := Copy(S, jCStart - 1, jC - jCStart + 1);\r\n if jC > SL + 1 then\r\n Ch := Ch + Spaces(jC - SL - 1);\r\n Len := Length(Ch);\r\n\r\n if Brush.Color <> LA.BC then // change GDI object only if necessary\r\n Brush.Color := LA.BC;\r\n Font.Assign(FontCacheFind(LA));\r\n\r\n ColCount := 0;\r\n {$IFDEF COMPILER12_UP}\r\n for iC := 0 to High(MyDi) - 1 do\r\n begin\r\n {TODO: a cache for the TextWidth() call should be used and cleared if the font name changes. }\r\n if (iC < Len) and (Ch[iC + 1] >= #256) then\r\n begin\r\n CharSize := ((EditorClient.Canvas.TextWidth(Ch[iC + 1]) + (CellRect.Width - 1)) div CellRect.Width);\r\n MyDi[iC] := CellRect.Width * CharSize;\r\n Inc(ColCount, CharSize - 1);\r\n end\r\n else\r\n MyDi[iC] := CellRect.Width;\r\n end;\r\n {$ENDIF COMPILER12_UP}\r\n Inc(ColCount, Len);\r\n\r\n\r\n R := CalcCellRect(ColPainted - LeftCol, Line - TopRow);\r\n {bottom line}\r\n FillRect(Bounds(R.Left, R.Bottom - 1, CellRect.Width * ColCount, 1));\r\n\r\n TJvUnicodeCanvas(Canvas).ExtTextOut(R.Left, R.Top, [etoOpaque, etoClipped], nil, Ch, @MyDi[0]);\r\n ErrorHighlighting.PaintError(Canvas, ColPainted, Line, R, ColCount, MyDi);\r\n\r\n if LA.Border <> clNone then\r\n begin\r\n Pen.Color := LA.Border;\r\n R.Right := R.Left + CellRect.Width * ColCount;\r\n Dec(R.Left);\r\n Brush.Style := bsClear;\r\n Rectangle(R);\r\n Brush.Style := bsSolid;\r\n end;\r\n\r\n ColPainted := jC - 1;\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomEditor.GetLineAttr(var Str: string; Line, ColBeg, ColEnd: Integer);\r\nvar\r\n I: Integer;\r\nbegin\r\n if ColBeg < 0 then\r\n ColBeg := 0;\r\n if ColEnd > Max_X then\r\n ColEnd := Max_X;\r\n\r\n SetLength(LineAttrs, Max(Length(LineAttrs), Max_X + 1));\r\n\r\n LineAttrs[ColBeg].Style := Font.Style;\r\n LineAttrs[ColBeg].FC := Font.Color;\r\n LineAttrs[ColBeg].BC := Color;\r\n LineAttrs[ColBeg].Border := clNone;\r\n\r\n{ for I := ColBeg + 1 to ColEnd do\r\n Move(LineAttrs[ColBeg], LineAttrs[I], SizeOf(LineAttrs[1]));}\r\n for I := ColBeg + 1 to ColEnd do\r\n LineAttrs[I] := LineAttrs[ColBeg];\r\n\r\n GetAttr(Line, ColBeg, ColEnd);\r\n if Assigned(FOnGetLineAttr) then\r\n FOnGetLineAttr(Self, Str, Line, LineAttrs);\r\n ChangeAttr(Line, ColBeg, ColEnd);\r\nend;\r\n\r\nfunction TJvCustomEditor.GetTextLine(Y: Integer; out Text: string): Boolean;\r\nbegin\r\n if (Y >= 0) and (Y < Lines.Count) then\r\n begin\r\n Text := Lines[Y];\r\n Result := True;\r\n end\r\n else\r\n begin\r\n Text := '';\r\n Result := False;\r\n end;\r\nend;\r\n\r\nfunction TJvCustomEditor.InternGetWordOnCaret: string;\r\nbegin\r\n Result := GetWordOnCaret;\r\nend;\r\n\r\nprocedure TJvCustomEditor.ReLine;\r\nbegin\r\n FLines.ReLine;\r\nend;\r\n\r\nprocedure TJvCustomEditor.InsertChar(const Value: Word);\r\nvar\r\n S: string;\r\n X, Y, iBeg: Integer;\r\n WasSelected: Boolean;\r\n Key: Char;\r\nbegin\r\n Key := Char(Value);\r\n WasSelected := (FSelection.IsSelected) and (not PersistentBlocks);\r\n {$IFDEF UNICODE}\r\n if (Key >= #32) and ((Key <= #$FF) or not TCharacter.IsControl(Char(Value))) then\r\n {$ELSE}\r\n if CharInSet(Key, [#32..#255]) then\r\n {$ENDIF UNICODE}\r\n begin\r\n if not HasChar(Key, JvEditorCompletionChars) then\r\n Completion.DoKeyPress(Key);\r\n\r\n RemoveSelectedBlock;\r\n\r\n ReLine; // need ReLine after DeleteSelection\r\n S := FLines[CaretY];\r\n if InsertMode then\r\n begin\r\n {--- UNDO ---}\r\n TJvInsertUndo.Create(Self, CaretX, CaretY, Key);\r\n {--- /UNDO ---}\r\n Insert(Key, S, CaretX + 1);\r\n\r\n AdjustPersistentBlockSelection(CaretX, CaretY, amInsert, [1]);\r\n end\r\n else\r\n begin\r\n {--- UNDO ---}\r\n if CaretX + 1 <= Length(S) then\r\n TJvOverwriteUndo.Create(Self, CaretX, CaretY, S[CaretX + 1], Key)\r\n else\r\n TJvOverwriteUndo.Create(Self, CaretX, CaretY, '', Key);\r\n {--- /UNDO ---}\r\n if CaretX + 1 <= Length(S) then\r\n S[CaretX + 1] := Key\r\n else\r\n S := S + Key\r\n end;\r\n FLines.Internal[CaretY] := S;\r\n SetCaretInternal(CaretX + 1, CaretY);\r\n TextModified(CaretX, CaretY, maInsert, Key);\r\n PaintLine(CaretY, -1, -1);\r\n Changed;\r\n\r\n if HasChar(Key, JvEditorCompletionChars) then\r\n Completion.DoKeyPress(Key);\r\n end\r\n else\r\n case Key of\r\n Cr:\r\n begin\r\n if InsertMode then\r\n begin\r\n if WasSelected then // compound only on selection deletion\r\n BeginCompound;\r\n LockUpdate;\r\n try\r\n RemoveSelectedBlock; // adjusts CaretX, CaretY\r\n X := CaretX;\r\n Y := CaretY;\r\n { --- UNDO --- }\r\n TJvInsertUndo.Create(Self, CaretX, CaretY, sLineBreakStr);\r\n { --- /UNDO --- }\r\n if FLines.Count = 0 then\r\n FLines.Add('');\r\n ReLine;\r\n\r\n S := Copy(FLines[Y], X + 1, MaxInt);\r\n FLines.Insert(Y + 1, S);\r\n FLines.Internal[Y] := Copy(FLines[Y], 1, X);\r\n Inc(Y);\r\n { auto indent }\r\n if AutoIndent and\r\n (((Length(FLines[CaretY]) > 0) and\r\n (FLines[CaretY][1] = ' ')) or\r\n ((Trim(FLines[CaretY]) = '') and (X > 0))) then\r\n begin\r\n X := GetAutoIndentStop(Y);\r\n if X > 0 then\r\n begin\r\n { --- UNDO --- }\r\n TJvInsertUndo.Create(Self, 0, Y, Spaces(X));\r\n { --- /UNDO --- }\r\n FLines.Internal[Y] := Spaces(X) + FLines[Y];\r\n end;\r\n end\r\n else\r\n X := 0;\r\n\r\n // persistent blocks: adjust selection\r\n AdjustPersistentBlockSelection(CaretX, CaretY, amLineBreak, []);\r\n\r\n UpdateEditorSize;\r\n TextModified(CaretX - 1, CaretY, maInsert, sLineBreakStr);\r\n finally\r\n UnlockUpdate;\r\n if WasSelected then\r\n EndCompound;\r\n end;\r\n Invalidate;\r\n Changed;\r\n end\r\n else // Overwrite-mode\r\n begin\r\n if WasSelected then // compound only on selection deletion\r\n BeginCompound;\r\n try\r\n RemoveSelectedBlock;\r\n X := CaretX;\r\n Y := CaretY;\r\n Inc(Y);\r\n if Y >= FLines.Count then\r\n begin\r\n LockUpdate;\r\n try\r\n { --- UNDO --- }\r\n TJvInsertUndo.Create(Self, CaretX, CaretY, sLineBreakStr);\r\n { --- /UNDO --- }\r\n FLines.Add('');\r\n finally\r\n UnlockUpdate;\r\n end;\r\n TextModified(0, Y - 1, maInsert, sLineBreakStr);\r\n UpdateEditorSize;\r\n Invalidate;\r\n Changed;\r\n end;\r\n if Y < FLines.Count then\r\n begin\r\n S := FLines[Y];\r\n if Length(S) > 0 then\r\n begin\r\n iBeg := FindNotBlankCharPos(S) - 1;\r\n if iBeg < X then\r\n X := iBeg;\r\n end;\r\n end;\r\n finally\r\n if WasSelected then\r\n EndCompound;\r\n end;\r\n end;\r\n SetCaretInternal(X, Y);\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomEditor.SelectWordOnCaret;\r\nvar\r\n iBeg, iEnd: Integer;\r\nbegin\r\n if (CaretY >= 0) and (CaretY < LineCount) and (Trim(FLines[CaretY]) <> '') then\r\n begin\r\n iEnd := Length(TrimRight(FLines[CaretY]));\r\n if FCaretX < iEnd then\r\n while FLines[FCaretY][FCaretX + 1] <= ' ' do\r\n Inc(FCaretX)\r\n else\r\n begin\r\n FCaretX := iEnd - 1;\r\n while FLines[FCaretY][FCaretX + 1] <= ' ' do\r\n Dec(FCaretX);\r\n end;\r\n if GetWordOnPosEx(FLines[FCaretY] + ' ', FCaretX + 1, iBeg, iEnd) <> '' then\r\n begin\r\n PaintCaret(False);\r\n SetSel(iBeg - 1, FCaretY);\r\n SetSel(iEnd - 1, FCaretY);\r\n SetCaret(iEnd - 1, FCaretY);\r\n PaintCaret(True);\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJvCustomEditor.DoCommand(ACommand: TEditCommand; var X, Y: Integer;\r\n var CaretUndo: Boolean): Boolean;\r\n\r\ntype\r\n TPr = procedure of object;\r\n\r\n procedure DoAndCorrectXY(Pr: TPr);\r\n begin\r\n Pr;\r\n X := CaretX;\r\n Y := CaretY;\r\n CaretUndo := False;\r\n end;\r\n\r\n procedure SetSel1(X, Y: Integer);\r\n begin\r\n SetSel(X, Y);\r\n CaretUndo := False;\r\n end;\r\n\r\n procedure SetSelText1(const S: string);\r\n begin\r\n SelText := S;\r\n CaretUndo := False;\r\n end;\r\n\r\nvar\r\n F: Integer;\r\n S, S2: string;\r\n B: Boolean;\r\n iBeg, iEnd: Integer;\r\nbegin\r\n Result := True;\r\n X := CaretX;\r\n Y := CaretY;\r\n case ACommand of\r\n { caret movements }\r\n ecPrevWord, ecSelPrevWord, ecBackspaceWord:\r\n begin\r\n if (ACommand = ecSelPrevWord) and IsNewSelection then\r\n SetSel1(CaretX, CaretY);\r\n if Y >= FLines.Count then\r\n Exit;\r\n\r\n S := FLines[Y];\r\n B := False;\r\n if CaretX > Length(S) then\r\n begin\r\n X := Length(S);\r\n SetSel1(X, Y);\r\n end\r\n else\r\n begin\r\n for F := X - 1 downto 0 do\r\n begin\r\n if B then\r\n begin\r\n if CharInSet(AnsiChar(S[F + 1]), Separators) then\r\n begin\r\n X := F + 1;\r\n Break;\r\n end;\r\n end\r\n else\r\n if not CharInSet(AnsiChar(S[F + 1]), Separators) then\r\n B := True;\r\n end;\r\n\r\n if X = CaretX then\r\n X := 0;\r\n\r\n if ACommand <> ecBackspaceWord then\r\n begin\r\n { Jump to previous line and last word ending }\r\n if (X = 0) and (Y > 0) then\r\n begin\r\n if (Y > FLines.Count) or (CaretX = 0) or (FLines[Y] = '') or\r\n CharInSet(AnsiChar(FLines[Y][1]), Separators) then\r\n begin\r\n Y := Y - 1;\r\n X := Length(FLines[Y]);\r\n end;\r\n end;\r\n end;\r\n\r\n if ACommand = ecSelPrevWord then\r\n SetSel1(X, Y)\r\n else\r\n PersistentBlocksSetUnSelected;\r\n\r\n if (ACommand = ecBackspaceWord) and (Y >= 0) and (X <> CaretX) then\r\n begin\r\n if not ReadOnly then\r\n begin\r\n BeginCompound;\r\n try\r\n SelectRange(X, CaretY, CaretX, CaretY);\r\n DeleteSelected;\r\n finally\r\n EndCompound;\r\n end;\r\n ReLine;\r\n end;\r\n end;\r\n end;\r\n end;\r\n ecNextWord, ecSelNextWord:\r\n begin\r\n if (ACommand = ecSelNextWord) and IsNewSelection then\r\n SetSel1(CaretX, CaretY);\r\n if Y >= FLines.Count then\r\n begin\r\n Y := FLines.Count - 1;\r\n if Y < 0 then\r\n Exit;\r\n X := Length(FLines[Y]);\r\n end;\r\n S := FLines[Y];\r\n B := False;\r\n if CaretX >= Length(S) then\r\n begin\r\n if Y < FLines.Count - 1 then\r\n begin\r\n Y := CaretY + 1;\r\n X := 0;\r\n if Y < FLines.Count then\r\n while (X < Length(FLines[Y])) and (CharInSet(AnsiChar(FLines[Y][X + 1]), Separators)) do\r\n Inc(X);\r\n\r\n if ACommand = ecSelNextWord then // this code is copied from [ecPrevWord, ecSelPrevWord]\r\n SetSel1(X, Y)\r\n else\r\n PersistentBlocksSetUnSelected;\r\n end;\r\n end\r\n else\r\n begin\r\n for F := X to Length(S) - 1 do\r\n if B then\r\n begin\r\n if not CharInSet(AnsiChar(S[F + 1]), Separators) then\r\n begin\r\n X := F;\r\n Break;\r\n end\r\n end\r\n else\r\n if CharInSet(AnsiChar(S[F + 1]), Separators) then\r\n B := True;\r\n if X = CaretX then\r\n X := Length(S);\r\n if ACommand = ecSelNextWord then\r\n SetSel1(X, Y)\r\n else\r\n PersistentBlocksSetUnSelected;\r\n end;\r\n end;\r\n ecSelWord:\r\n if IsNewSelection and (GetWordOnPosEx(FLines[Y] + ' ', X + 1, iBeg,\r\n iEnd) <> '') then\r\n begin\r\n SetSel1(iBeg - 1, Y);\r\n SetSel1(iEnd - 1, Y);\r\n X := iEnd - 1;\r\n end;\r\n ecBackspace:\r\n if not ReadOnly then\r\n if X > 0 then\r\n begin\r\n // in the middle of line\r\n if not PersistentBlocks and FSelection.IsSelected then\r\n DoAndCorrectXY(RemoveSelectedBlock)\r\n else\r\n begin\r\n ReLine;\r\n if BackSpaceUnindents then\r\n X := GetBackStop(CaretX, CaretY)\r\n else\r\n X := CaretX - 1;\r\n\r\n S := Copy(FLines[CaretY], X + 1, CaretX - X);\r\n\r\n { --- UNDO --- }\r\n if X = CaretX - 1 then\r\n TJvBackspaceUndo.Create(Self, CaretX, CaretY, S)\r\n else\r\n TJvBackspaceUnindentUndo.Create(Self, CaretX, CaretY, S);\r\n CaretUndo := False;\r\n { --- /UNDO --- }\r\n\r\n // persistent blocks: adjust selection\r\n AdjustPersistentBlockSelection(CaretX, CaretY, amDelete, [1]);\r\n\r\n FLines.DeleteText(X, Y, CaretX - 1, Y);\r\n\r\n TextModified(CaretX, CaretY, maDelete, S);\r\n PaintLine(Y, -1, -1);\r\n end;\r\n Changed;\r\n end\r\n else\r\n if Y > 0 then\r\n begin\r\n // at the start of line\r\n if FSelection.IsSelected then\r\n begin\r\n BeginCompound;\r\n try\r\n DoAndCorrectXY(RemoveSelectedBlock);\r\n ReLine;\r\n finally\r\n EndCompound;\r\n end;\r\n end\r\n else\r\n begin\r\n LockUpdate;\r\n try\r\n X := Length(FLines[Y - 1]);\r\n\r\n { --- UNDO --- }\r\n TJvBackspaceUndo.Create(Self, X + 1, CaretY - 1, Lf);\r\n CaretUndo := False;\r\n { --- /UNDO --- }\r\n\r\n // persistent blocks: adjust selection\r\n AdjustPersistentBlockSelection(CaretX, CaretY, amLineConcat, [X, CaretY - 1]);\r\n\r\n FLines.DeleteText(X, Y - 1, -1, Y);\r\n Dec(Y);\r\n finally\r\n UnlockUpdate;\r\n end;\r\n UpdateEditorSize;\r\n TextModified(X, Y, maDelete, sLineBreakStr);\r\n Invalidate;\r\n Changed;\r\n end;\r\n end\r\n else\r\n if not PersistentBlocks and FSelection.IsSelected then\r\n DoCommand(ecDelete, X, Y, CaretUndo);\r\n ecDelete:\r\n if not ReadOnly then\r\n begin\r\n LockUpdate;\r\n try\r\n if FLines.Count = 0 then\r\n FLines.Add('');\r\n finally\r\n UnlockUpdate;\r\n end;\r\n if not PersistentBlocks and FSelection.IsSelected then\r\n DoAndCorrectXY(RemoveSelectedBlock)\r\n else\r\n if X < Length(FLines[Y]) then\r\n begin\r\n //{ inside line - }\r\n { --- UNDO --- }\r\n TJvDeleteUndo.Create(Self, CaretX, CaretY, FLines[Y][X + 1]);\r\n CaretUndo := False;\r\n { --- /UNDO --- }\r\n\r\n // persistent blocks: adjust selection (before DeleteText)\r\n AdjustPersistentBlockSelection(CaretX + 1, CaretY, amDelete, [1]);\r\n\r\n S := FLines[Y][X + 1];\r\n FLines.DeleteText(X, Y, X, Y);\r\n\r\n TextModified(CaretX, CaretY, maDelete, S);\r\n PaintLine(CaretY, -1, -1);\r\n Changed;\r\n end\r\n else\r\n if (Y >= 0) and (Y <= FLines.Count - 2) then\r\n begin\r\n //{ at the end of line - }\r\n { --- UNDO --- }\r\n TJvDeleteUndo.Create(Self, CaretX, CaretY, sLineBreakStr);\r\n CaretUndo := False;\r\n { --- /UNDO --- }\r\n // persistent blocks: adjust selection (before DeleteText)\r\n AdjustPersistentBlockSelection(0, CaretY + 1, amLineConcat, [CaretX, CaretY]);\r\n\r\n FLines.DeleteText(X, Y, -1, Y + 1);\r\n\r\n UpdateEditorSize;\r\n TextModified(CaretX, CaretY, maDelete, sLineBreakStr);\r\n Invalidate;\r\n Changed;\r\n end;\r\n end;\r\n ecTab, ecBackTab:\r\n begin\r\n X := GetTabStop(CaretX, CaretY, ACommand = ecTab);\r\n if not ReadOnly then\r\n begin\r\n if FSelection.IsSelected then\r\n if (ACommand = ecTab) and InsertMode then\r\n DeleteSelected;\r\n ReLine;\r\n if (ACommand = ecTab) and InsertMode then\r\n begin\r\n S := FLines[CaretY];\r\n S2 := Spaces(X - CaretX);\r\n { --- UNDO --- }\r\n TJvInsertTabUndo.Create(Self, CaretX, CaretY, S2);\r\n CaretUndo := False;\r\n { --- /UNDO --- }\r\n FLines.InsertText(CaretX, CaretY, S2);\r\n\r\n TextModified(CaretX, CaretY, maInsert, S2);\r\n PaintLine(CaretY, -1, -1);\r\n Changed;\r\n end;\r\n end;\r\n { else }\r\n { move cursor - oh yes!, it's already moved: X := GetTabStop(..); }\r\n end;\r\n ecDeleteLine:\r\n if not ReadOnly then\r\n begin\r\n if (CaretY >= 0) and (CaretY < FLines.Count) then\r\n begin\r\n S := FLines[CaretY];\r\n if (CaretY >= FLines.Count - 1) and (S = '') then\r\n Exit;\r\n\r\n LockUpdate;\r\n try\r\n { --- UNDO --- }\r\n TJvDeleteLineUndo.Create(Self, CaretX, CaretY, S, CaretY >= FLines.Count - 1);\r\n { --- /UNDO --- }\r\n if CaretY < FLines.Count - 1 then\r\n FLines.Delete(CaretY)\r\n else\r\n FLines[CaretY] := '';\r\n SetCaretInternal(0, CaretY); // set caret to 0/Y when in last line\r\n finally\r\n UnlockUpdate;\r\n end;\r\n AdjustPersistentBlockSelection(CaretX, CaretY, amDeleteLine, []);\r\n TextModified(0, CaretY, maDelete, S);\r\n Invalidate;\r\n Changed;\r\n end;\r\n Exit;\r\n end;\r\n ecToUpperCase:\r\n if not ReadOnly then\r\n SelText := AnsiUpperCase(SelText);\r\n ecToLowerCase:\r\n if not ReadOnly then\r\n SelText := AnsiLowerCase(SelText);\r\n ecChangeCase:\r\n if not ReadOnly then\r\n SelText := AnsiChangeCase(SelText);\r\n end;\r\n Result := False;\r\nend;\r\n\r\nfunction TJvCustomEditor.GetSelText: string;\r\nvar\r\n S: string;\r\n I: Integer;\r\n Len, CLen: Integer;\r\n P: PChar;\r\nbegin\r\n with FSelection do\r\n begin\r\n Len := GetSelLength; // memory size to allocate\r\n Result := '';\r\n if Len = 0 then\r\n Exit;\r\n SetLength(Result, Len);\r\n\r\n if SelBlockFormat = bfColumn then\r\n begin\r\n if Len > 0 then\r\n begin\r\n P := Pointer(Result);\r\n for I := SelBegY to SelEndY do\r\n begin\r\n S := FLines[I];\r\n CLen := Length(S) - SelBegX;\r\n if CLen < 0 then\r\n CLen := 0;\r\n if CLen > SelEndX - SelBegX + 1 then\r\n CLen := SelEndX - SelBegX + 1;\r\n if CLen <> 0 then\r\n begin\r\n Move(S[SelBegX + 1], P^, CLen * SizeOf(Char));\r\n Inc(P, CLen);\r\n end;\r\n\r\n if I < SelEndY then\r\n begin\r\n Move(sLineBreakStr[1], P^, sLineBreakLen * SizeOf(Char));\r\n Inc(P, sLineBreakLen);\r\n end;\r\n end;\r\n end;\r\n end\r\n else\r\n begin\r\n if SelBegY = SelEndY then\r\n Move(FLines[SelEndY][SelBegX + 1], Result[1], Len * SizeOf(Char))\r\n else\r\n begin\r\n P := PChar(Result);\r\n\r\n // first line\r\n S := FLines[SelBegY];\r\n CLen := Length(S) - SelBegX;\r\n if CLen > 0 then\r\n begin\r\n Move(S[SelBegX + 1], P^, CLen * SizeOf(Char));\r\n Inc(P, CLen);\r\n end;\r\n\r\n // line break\r\n Move(sLineBreakStr[1], P^, sLineBreakLen * SizeOf(Char));\r\n Inc(P, sLineBreakLen);\r\n\r\n // lines between\r\n for I := SelBegY + 1 to SelEndY - 1 do\r\n begin\r\n // line\r\n S := FLines[I];\r\n Move(S[1], P^, Length(S) * SizeOf(Char));\r\n Inc(P, Length(S));\r\n\r\n // line break\r\n Move(sLineBreakStr[1], P^, sLineBreakLen * SizeOf(Char));\r\n Inc(P, sLineBreakLen);\r\n end;\r\n\r\n // last line\r\n S := FLines[SelEndY];\r\n CLen := SelEndX + Ord(SelBlockFormat = bfInclusive);\r\n if CLen > Length(S) then\r\n CLen := Length(S);\r\n if CLen > 0 then\r\n Move(S[1], P^, CLen * SizeOf(Char));\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomEditor.SetSelText(const AValue: string);\r\nbegin\r\n BeginUpdate;\r\n BeginCompound;\r\n try\r\n with FSelection do\r\n begin\r\n if IsSelected then\r\n DeleteSelected\r\n else\r\n begin\r\n SelBegX := CaretX;\r\n SelBegY := CaretY;\r\n end;\r\n if FSelection.SelBlockFormat = bfColumn then\r\n InsertColumnText(FSelection.SelBegX, FSelection.SelBegY, AValue)\r\n else\r\n InsertText(AValue);\r\n\r\n IsSelected := Length(AValue) > 0;\r\n Selecting := False;\r\n GetEndPosCaret(AValue, SelBegX, SelBegY, SelEndX, SelEndY);\r\n if IsSelected then\r\n Inc(SelEndX);\r\n SetSelUpdateRegion(SelBegY, SelEndY);\r\n end;\r\n finally\r\n EndCompound;\r\n EndUpdate;\r\n end;\r\nend;\r\n\r\nfunction TJvCustomEditor.GetText: string;\r\nbegin\r\n Result := FLines.Text;\r\nend;\r\n\r\nprocedure TJvCustomEditor.ClipboardCopy;\r\nvar\r\n S: string;\r\nbegin\r\n S := GetSelText;\r\n Clipboard.SetTextBuf(PChar(S));\r\n SetClipboardBlockFormat(SelBlockFormat);\r\nend;\r\n\r\nprocedure TJvCustomEditor.InsertText(const Text: string);\r\nvar\r\n X, Y: Integer;\r\nbegin\r\n PaintCaret(False);\r\n try\r\n { --- UNDO --- }\r\n TJvInsertUndo.Create(Self, CaretX, CaretY, Text);\r\n { --- /UNDO --- }\r\n FLines.InsertText(CaretX, CaretY, Text);\r\n TextModified(CaretX, CaretY, maInsert, Text);\r\n\r\n GetEndPosCaret(Text, CaretX, CaretY, X, Y); // get new caret position\r\n SetCaretInternal(X + 1, Y);\r\n\r\n Changed;\r\n finally\r\n PaintCaret(True);\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomEditor.InsertColumnText(X, Y: Integer; const Text: string);\r\nbegin\r\n if X < 0 then\r\n X := 0;\r\n if Y < 0 then\r\n Y := 0;\r\n { --- UNDO --- }\r\n TJvInsertColumnUndo.Create(Self, X, Y, Text);\r\n { --- /UNDO --- }\r\n FLines.InsertColumnText(X, Y, Text);\r\n TextModified(X, Y, maInsertColumn, Text);\r\nend;\r\n\r\n// Substitutes a word in a cursor position on NewString\r\n// string NewString should not contain Cr, Lf [translated]\r\n\r\nprocedure TJvCustomEditor.ReplaceWord(const NewString: string);\r\nvar\r\n iBeg, iEnd: Integer;\r\n S, W: string;\r\n X: Integer;\r\nbegin\r\n BeginUpdate;\r\n PaintCaret(False);\r\n try\r\n S := FLines[CaretY];\r\n while CaretX > Length(S) do\r\n S := S + ' ';\r\n W := Trim(GetWordOnPos2(S, CaretX, iBeg, iEnd));\r\n if W = '' then\r\n begin\r\n iBeg := CaretX + 1;\r\n iEnd := CaretX\r\n end;\r\n { --- UNDO --- }\r\n NotUndoable;\r\n //TJvReplaceUndo.Create(Self, CaretX, CaretY, iBegSX - 1, CaretY, W, NewString);\r\n { --- /UNDO --- }\r\n Delete(S, iBeg, iEnd - iBeg);\r\n Insert(NewString, S, iBeg);\r\n FLines.Internal[CaretY] := S;\r\n X := iBeg + Length(NewString) - 1;\r\n TextModified(CaretX, CaretY, maInsert, NewString);\r\n PaintLine(CaretY, -1, -1);\r\n SetCaretInternal(X, CaretY);\r\n Changed;\r\n finally\r\n PaintCaret(True);\r\n EndUpdate;\r\n end;\r\nend;\r\n\r\n{ Substitutes a word on the cursor position by NewString [translated] }\r\n\r\nprocedure TJvCustomEditor.ReplaceWord2(const NewString: string);\r\nvar\r\n S, W: string;\r\n iBegSX, iEndSX: Integer; { [1..Length] }\r\n X, Y: Integer;\r\nbegin\r\n S := '';\r\n if CaretY < FLines.Count then\r\n S := FLines[CaretY];\r\n\r\n W := Trim(GetWordOnPosEx(S, CaretX + 1, iBegSX, iEndSX));\r\n if W <> NewString then\r\n begin\r\n PaintCaret(False);\r\n try\r\n BeginCompound;\r\n try\r\n ReLine;\r\n if Length(W) = 0 then\r\n begin\r\n iBegSX := CaretX + 1;\r\n iEndSX := CaretX;\r\n end;\r\n { --- UNDO --- }\r\n TJvReplaceUndo.Create(Self, CaretX, CaretY, iBegSX - 1, CaretY, W, NewString);\r\n { --- /UNDO --- }\r\n\r\n if iBegSX <= iEndSX then\r\n FLines.DeleteText(iBegSX - 1, CaretY, iEndSX - 1, CaretY);\r\n FLines.InsertText(iBegSX - 1, CaretY, NewString);\r\n TextModified(iBegSX - 1, CaretY, maReplace, NewString);\r\n\r\n GetEndPosCaret(NewString, iBegSX - 1, CaretY, X, Y); // get end caret position\r\n SetCaretInternal(X + 1, Y);\r\n finally\r\n EndCompound;\r\n end;\r\n Changed;\r\n finally\r\n PaintCaret(True);\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomEditor.IndentColumns(X, BegY, EndY: Integer);\r\nvar\r\n Y: Integer;\r\n S: string;\r\nbegin\r\n if BegY < 0 then\r\n BegY := 0;\r\n if BegY >= FLines.Count then\r\n BegY := FLines.Count - 1;\r\n if EndY < 0 then\r\n EndY := 0;\r\n if EndY >= FLines.Count then\r\n EndY := FLines.Count - 1;\r\n if EndY < BegY then\r\n Exit;\r\n if X < 0 then\r\n X := 0;\r\n\r\n S := Spaces(2);\r\n for Y := BegY to EndY - 1 do\r\n S := S + sLineBreakStr + Spaces(2);\r\n\r\n InsertColumnText(X, BegY, S);\r\n\r\n Changed;\r\n if UpdateLock = 0 then\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvCustomEditor.UnIndentColumns(X: Integer; BegY, EndY: Integer);\r\nvar\r\n S, UnindentedText: string;\r\n Y: Integer;\r\n Len, L: Integer;\r\nbegin\r\n if BegY < 0 then\r\n BegY := 0;\r\n if BegY >= FLines.Count then\r\n BegY := FLines.Count - 1;\r\n if EndY < 0 then\r\n EndY := 0;\r\n if EndY >= FLines.Count then\r\n EndY := FLines.Count - 1;\r\n if EndY < BegY then\r\n Exit;\r\n if X < 0 then\r\n X := 0;\r\n\r\n Inc(X); // for string operations\r\n\r\n LockUpdate;\r\n try\r\n UnindentedText := '';\r\n for Y := BegY to EndY do\r\n begin\r\n S := FLines[Y];\r\n Len := Length(S);\r\n\r\n // how many spaces to delete\r\n L := 0;\r\n while (X + L <= Len) and (L < 2) and (S[X + L] = ' ') do\r\n Inc(L);\r\n\r\n if L > 0 then\r\n begin\r\n UnindentedText := UnindentedText + Spaces(L);\r\n Delete(S, X, L);\r\n FLines.Internal[Y] := S;\r\n end;\r\n if Y < EndY then\r\n UnindentedText := UnindentedText + sLineBreakStr;\r\n end;\r\n finally\r\n UnlockUpdate;\r\n end;\r\n\r\n Dec(X); // for caret operations\r\n if Length(UnindentedText) > 0 then\r\n begin\r\n { --- UNDO --- }\r\n TJvUnindentColumnUndo.Create(Self, CaretX, CaretY, X, BegY, UnindentedText);\r\n { --- /UNDO --- }\r\n TextModified(X, BegY, maDelete, UnindentedText);\r\n\r\n Changed;\r\n if UpdateLock = 0 then\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomEditor.ClipboardPaste;\r\nvar\r\n ClipS: string;\r\n Len: Integer;\r\n H: THandle;\r\n X, Y, EndX, EndY: Integer;\r\nbegin\r\n if (CaretY > FLines.Count - 1) and (FLines.Count > 0) then\r\n if BeepOnError then\r\n Beep;\r\n H := Clipboard.GetAsHandle(CF_TEXT);\r\n Len := GlobalSize(H);\r\n if Len = 0 then\r\n Exit;\r\n\r\n BeginUpdate;\r\n try\r\n SetLength(ClipS, Len);\r\n SetLength(ClipS, Clipboard.GetTextBuf(PChar(ClipS), Len));\r\n ClipS := ExpandTabs(AdjustLineBreaks(ClipS));\r\n PaintCaret(False);\r\n\r\n ReLine;\r\n with FSelection do\r\n begin\r\n X := CaretX;\r\n Y := CaretY;\r\n BeginCompound;\r\n try\r\n if IsSelected then\r\n begin\r\n if BlockOverwrite and not PersistentBlocks then\r\n begin\r\n X := SelBegX;\r\n Y := SelBegY;\r\n end;\r\n RemoveSelectedBlock;\r\n end;\r\n if FLines.Count > 0 then\r\n ReLine;\r\n\r\n SelBlockFormat := GetClipboardBlockFormat;\r\n if SelBlockFormat in [bfInclusive, bfNonInclusive, bfLine] then\r\n begin\r\n // special line block mode handling\r\n if SelBlockFormat = bfLine then\r\n begin\r\n X := 0;\r\n if (ClipS = '') or (ClipS[Length(ClipS)] <> Lf) then\r\n ClipS := ClipS + sLineBreakStr;\r\n end;\r\n\r\n { --- UNDO --- }\r\n TJvInsertUndo.Create(Self, X, Y, ClipS);\r\n { --- /UNDO --- }\r\n\r\n FLines.InsertText(X, Y, ClipS);\r\n TextModified(X, Y, maInsert, ClipS);\r\n\r\n // get new caret position\r\n GetEndPosCaret(ClipS, X, Y, EndX, EndY);\r\n Inc(EndX);\r\n\r\n if PersistentBlocks then\r\n begin\r\n SelBegX := X;\r\n SelBegY := Y;\r\n // special line block mode handling\r\n if SelBlockFormat = bfLine then\r\n begin\r\n Dec(EndY);\r\n SelEndX := Max_X;\r\n end\r\n else\r\n SelEndX := EndX;\r\n\r\n SelEndY := EndY;\r\n IsSelected := True;\r\n Selecting := False;\r\n SetSelUpdateRegion(SelBegY, SelEndY);\r\n end;\r\n X := EndX;\r\n Y := EndY;\r\n end\r\n else\r\n if SelBlockFormat = bfColumn then\r\n begin\r\n InsertColumnText(X, Y, ClipS);\r\n GetEndPosCaret(ClipS, X, Y, X, Y);\r\n X := CaretX - 1;\r\n Inc(X);\r\n end;\r\n finally\r\n EndCompound;\r\n end;\r\n end;\r\n\r\n SetCaretInternal(X, Y);\r\n\r\n Changed;\r\n finally\r\n PaintCaret(True);\r\n EndUpdate; {!!! Causes copying all [translated] }\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomEditor.DeleteSelected;\r\nvar\r\n S: string;\r\n X, Y: Integer;\r\nbegin\r\n with FSelection do\r\n begin\r\n X := SelBegX;\r\n Y := SelBegY;\r\n if IsSelected then\r\n begin\r\n BeginUpdate;\r\n PaintCaret(False);\r\n try\r\n S := GetSelText;\r\n {--- UNDO ---}\r\n TJvDeleteSelectedUndo.Create(Self, CaretX, CaretY, S);\r\n {--- /UNDO ---}\r\n IsSelected := False;\r\n Selecting := False;\r\n if SelBlockFormat in [bfInclusive, bfNonInclusive, bfLine] then\r\n begin\r\n FLines.DeleteText(X, Y, SelEndX - 1 + Ord(SelBlockFormat = bfInclusive), SelEndY);\r\n TextModified(SelBegX, SelBegY, maDelete, S);\r\n end\r\n else\r\n if SelBlockFormat = bfColumn then\r\n begin\r\n Y := CaretY;\r\n FLines.DeleteColumnText(SelBegX, SelBegY, SelEndX, SelEndY);\r\n TextModified(SelBegX, SelBegY, maDeleteColumn, S);\r\n end;\r\n SetCaretInternal(X, Y);\r\n Changed;\r\n finally\r\n PaintCaret(True);\r\n EndUpdate;\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomEditor.Clear;\r\nbegin\r\n FLines.Clear;\r\nend;\r\n\r\nfunction TJvCustomEditor.GetLines: TStrings;\r\nbegin\r\n Result := FLines;\r\nend;\r\n\r\nprocedure TJvCustomEditor.SetLines(ALines: TStrings);\r\nbegin\r\n if ALines <> nil then\r\n FLines.Assign(ALines);\r\n {--- UNDO ---}\r\n NotUndoable;\r\n {--- /UNDO ---}\r\nend;\r\n\r\nprocedure TJvCustomEditor.TextAllChangedInternal(Unselect: Boolean);\r\nbegin\r\n inherited TextAllChangedInternal(Unselect);\r\n TextModified(0, 0, maAll, '');\r\n UpdateEditorView;\r\nend;\r\n\r\nfunction TJvCustomEditor.ExpandTabs(const S: string): string;\r\nvar\r\n ps, I: Integer;\r\n Sp: string;\r\n Tabs, LenSp: Integer;\r\n P: PChar;\r\nbegin\r\n // ahuser: I think we should reimplement that function with proper tab handling.\r\n ps := Pos(Tab, S);\r\n if ps > 0 then\r\n begin\r\n // How many Tab chars?\r\n Tabs := 1;\r\n for I := ps + 1 to Length(S) do\r\n if S[I] = Tab then\r\n Inc(Tabs);\r\n\r\n Sp := Spaces(GetDefTabStop(0, True));\r\n LenSp := Length(Sp);\r\n\r\n // needed memory\r\n SetLength(Result, Length(S) - Tabs + Tabs * LenSp);\r\n P := PChar(Result);\r\n\r\n // copy the chars before the Tab\r\n if ps > 1 then\r\n begin\r\n Move(S[1], P[0], ps * SizeOf(Char));\r\n Inc(P, ps);\r\n end;\r\n\r\n for I := ps to Length(S) do\r\n begin\r\n if S[I] <> Tab then\r\n begin\r\n P[0] := S[I];\r\n Inc(P);\r\n end\r\n else\r\n if LenSp > 0 then\r\n begin\r\n Move(Sp[1], P[0], LenSp * SizeOf(Char));\r\n Inc(P, LenSp);\r\n end;\r\n end;\r\n end\r\n else\r\n Result := S;\r\nend;\r\n\r\nprocedure TJvCustomEditor.TextModified(ACaretX, ACaretY: Integer; Action: TModifiedAction; const Text: string);\r\nbegin\r\n Invalidate;\r\nend;\r\n\r\nfunction TJvCustomEditor.GetLineCount: Integer;\r\nbegin\r\n Result := FLines.Count;\r\nend;\r\n\r\nfunction TJvCustomEditor.GetLineLength(Index: Integer): Integer;\r\nbegin\r\n Result := Length(FLines[Index]);\r\nend;\r\n\r\nfunction TJvCustomEditor.FindNotBlankCharPosInLine(Line: Integer): Integer;\r\nbegin\r\n Result := FindNotBlankCharPos(FLines[Line]);\r\nend;\r\n\r\nprocedure TJvCustomEditor.SetLockText(const Text: string);\r\nbegin\r\n FLines.SetLockText(Text);\r\nend;\r\n\r\nfunction TJvCustomEditor.GetWordOnCaret: string;\r\nbegin\r\n if CaretY < FLines.Count then\r\n Result := GetWordOnPos(FLines[CaretY], CaretX + 1)\r\n else\r\n Result := '';\r\nend;\r\n\r\nfunction TJvCustomEditor.GetAutoIndentStop(Y: Integer): Integer;\r\nvar\r\n I, Len: Integer;\r\n S: string;\r\nbegin\r\n Result := 0;\r\n\r\n // find non-empty line\r\n Dec(Y);\r\n while Y > 0 do\r\n begin\r\n S := FLines[Y];\r\n if Length(Trim(S)) > 0 then\r\n Break;\r\n Dec(Y);\r\n end;\r\n if Y < 0 then\r\n Exit;\r\n\r\n Len := Length(S);\r\n I := 1;\r\n while (I <= Len) and (S[I] = ' ') do\r\n Inc(I);\r\n Result := I - 1;\r\nend;\r\n\r\nfunction TJvCustomEditor.GetTabStop(X, Y: Integer; Next: Boolean): Integer;\r\nvar\r\n I: Integer;\r\n\r\n procedure UpdateTabStops;\r\n var\r\n S: string;\r\n J, I: Integer;\r\n begin\r\n FillChar(FTabPos, SizeOf(FTabPos), False);\r\n if SmartTab then\r\n begin\r\n J := 1;\r\n I := 1;\r\n while Y - J >= 0 do\r\n begin\r\n S := TrimRight(FLines[Y - J]);\r\n if Length(S) > I then\r\n FTabPos[Length(S)] := True;\r\n while I <= Length(S) do\r\n begin\r\n if CharInSet(S[I], IdentifierSymbols) then\r\n begin\r\n FTabPos[I - 1] := True;\r\n while (I <= Length(S)) and CharInSet(S[I], IdentifierSymbols) do\r\n Inc(I);\r\n end;\r\n Inc(I);\r\n end;\r\n\r\n if I >= Max_X_Scroll then\r\n Break;\r\n if J >= VisibleRowCount * 2 then\r\n Break;\r\n Inc(J);\r\n end;\r\n end;\r\n end;\r\n\r\nbegin\r\n UpdateTabStops;\r\n Result := X;\r\n if Next then\r\n begin\r\n for I := X + 1 to High(FTabPos) do\r\n if FTabPos[I] then\r\n begin\r\n Result := I;\r\n Exit;\r\n end;\r\n if Result = X then\r\n Result := GetDefTabStop(X, True);\r\n end\r\n else\r\n begin\r\n if Result = X then\r\n Result := GetDefTabStop(X, False);\r\n end;\r\nend;\r\n\r\nfunction TJvCustomEditor.GetBackStop(X, Y: Integer): Integer;\r\nvar\r\n I: Integer;\r\n S: string;\r\n\r\n procedure UpdateBackStops;\r\n var\r\n S: string;\r\n J, I, K: Integer;\r\n begin\r\n J := 1;\r\n I := X - 1;\r\n FillChar(FTabPos, SizeOf(FTabPos), False);\r\n FTabPos[0] := True;\r\n while Y - J >= 0 do\r\n begin\r\n S := FLines[Y - J];\r\n for K := 1 to Min(Length(S), I) do\r\n if S[K] <> ' ' then\r\n begin\r\n I := K;\r\n FTabPos[I - 1] := True;\r\n Break;\r\n end;\r\n if I = 1 then\r\n Break;\r\n if J >= VisibleRowCount * 2 then\r\n Break;\r\n Inc(J);\r\n end;\r\n end;\r\n\r\nbegin\r\n Result := X - 1;\r\n S := TrimRight(FLines[Y]);\r\n if (Trim(Copy(S, 1, X)) = '') and\r\n ((X + 1 > Length(S)) or (S[X + 1] <> ' ')) then\r\n begin\r\n UpdateBackStops;\r\n for I := X downto 0 do\r\n if FTabPos[I] then\r\n begin\r\n Result := I;\r\n Exit;\r\n end;\r\n end;\r\nend;\r\n\r\n//=== { TJvInsertUndo } ======================================================\r\n\r\nconstructor TJvInsertUndo.Create(AJvEditor: TJvCustomEditor;\r\n ACaretX, ACaretY: Integer; const AText: string);\r\nbegin\r\n inherited Create(AJvEditor, ACaretX, ACaretY);\r\n FText := AText;\r\n if JvEditor.PersistentBlocks then\r\n SaveSelection;\r\nend;\r\n\r\nfunction TJvInsertUndo.GetEditor: TJvCustomEditor;\r\nbegin\r\n Result := TJvCustomEditor(FJvEditor);\r\nend;\r\n\r\nprocedure TJvInsertUndo.Undo;\r\nvar\r\n Text: string;\r\n EndX, EndY: Integer;\r\n du: TJvInsertUndo;\r\nbegin\r\n Text := '';\r\n with TJvUndoBufferAccessProtected(UndoBuffer) do\r\n begin\r\n while (FPtr >= 0) and not IsNewGroup(Self) do\r\n begin\r\n Text := TJvInsertUndo(LastUndo).FText + Text;\r\n Dec(FPtr);\r\n if not JvEditor.GroupUndo then\r\n Break;\r\n end;\r\n Inc(FPtr);\r\n\r\n du := TJvInsertUndo(Items[FPtr]);\r\n end;\r\n\r\n GetEndPosCaret(Text, du.CaretX, du.CaretY, EndX, EndY); // get end caret position\r\n TJvCustomEditor(JvEditor).FLines.DeleteText(du.CaretX, du.CaretY, EndX, EndY);\r\n TJvCustomEditor(JvEditor).TextModified(du.CaretX, du.CaretY, maDelete, Text);\r\n\r\n TJvCustomEditor(JvEditor).SetCaretInternal(du.CaretX, du.CaretY);\r\nend;\r\n\r\n//=== { TJvOverwriteUndo } ===================================================\r\n\r\nconstructor TJvOverwriteUndo.Create(AJvEditor: TJvCustomEditor;\r\n ACaretX, ACaretY: Integer; const AOldText, ANewText: string);\r\nbegin\r\n inherited Create(AJvEditor, ACaretX, ACaretY);\r\n FOldText := AOldText;\r\n FNewText := ANewText;\r\nend;\r\n\r\nfunction TJvOverwriteUndo.GetEditor: TJvCustomEditor;\r\nbegin\r\n Result := TJvCustomEditor(FJvEditor);\r\nend;\r\n\r\nprocedure TJvOverwriteUndo.Undo;\r\nvar\r\n OldText, NewText: string;\r\n EndX, EndY: Integer;\r\n du: TJvOverwriteUndo;\r\nbegin\r\n OldText := '';\r\n NewText := '';\r\n with TJvUndoBufferAccessProtected(UndoBuffer) do\r\n begin\r\n while (FPtr >= 0) and not IsNewGroup(Self) do\r\n begin\r\n OldText := TJvOverwriteUndo(LastUndo).FOldText + OldText;\r\n NewText := TJvOverwriteUndo(LastUndo).FNewText + NewText;\r\n Dec(FPtr);\r\n if not GetEditor.GroupUndo then\r\n Break;\r\n end;\r\n Inc(FPtr);\r\n du := TJvOverwriteUndo(Items[FPtr]);\r\n end;\r\n with du do\r\n begin\r\n GetEndPosCaret(NewText, du.CaretX, du.CaretY, EndX, EndY); // get end caret position\r\n GetEditor.FLines.DeleteText(CaretX, CaretY, EndX, EndY);\r\n GetEditor.FLines.InsertText(CaretX, CaretY, OldText);\r\n GetEditor.TextModified(CaretX, CaretY, maReplace, OldText);\r\n\r\n GetEditor.SetCaretInternal(CaretX, CaretY);\r\n end;\r\nend;\r\n\r\n//=== { TJvInsertColumnUndo } ================================================\r\n\r\nprocedure TJvInsertColumnUndo.Undo;\r\nvar\r\n I: Integer;\r\n SS: TStringList;\r\n S: string;\r\nbegin\r\n { Do not call GetEditor.FLines.DeleteColumnText() here because it has not\r\n the functionality needed in this context. It deletes the columns from\r\n [BegX..EndX] even if the inserted line was not as long as EndX-BegX+1. }\r\n\r\n SS := TStringList.Create;\r\n try\r\n SS.Text := FText;\r\n for I := 0 to SS.Count - 1 do\r\n begin\r\n S := GetEditor.FLines[CaretY + I];\r\n Delete(S, CaretX + 1, Length(SS[I]));\r\n GetEditor.FLines.Internal[CaretY + I] := S;\r\n end;\r\n finally\r\n SS.Free;\r\n end;\r\n GetEditor.TextModified(CaretX, CaretY, maDelete, FText);\r\n\r\n GetEditor.SetCaretInternal(CaretX, CaretY);\r\nend;\r\n\r\n//=== { TJvUnindentColumnUndo } ==============================================\r\n\r\nconstructor TJvUnindentColumnUndo.Create(AJvEditor: TJvCustomEditor;\r\n ACaretX, ACaretY, ABegX, ABegY: Integer; const AText: string);\r\nbegin\r\n inherited Create(AJvEditor, ACaretX, ACaretY, AText);\r\n SaveSelection;\r\n FBegX := ABegX;\r\n FBegY := ABegY;\r\nend;\r\n\r\nprocedure TJvUnindentColumnUndo.Undo;\r\nvar\r\n BegX, BegY: Integer;\r\nbegin\r\n BegX := FBegX;\r\n BegY := FBegY;\r\n with TJvUndoBufferAccessProtected(UndoBuffer) do\r\n begin\r\n while (FPtr >= 0) and not IsNewGroup(Self) do\r\n begin\r\n with TJvUnindentColumnUndo(LastUndo) do\r\n begin\r\n GetEditor.FLines.InsertColumnText(FBegX, FBegY, FText);\r\n if BegX > FBegX then\r\n BegX := FBegX;\r\n if BegY > FBegY then\r\n BegY := FBegY;\r\n end;\r\n Dec(FPtr);\r\n if not GetEditor.GroupUndo then\r\n Break;\r\n end;\r\n Inc(FPtr);\r\n end;\r\n GetEditor.TextModified(BegX, BegY, maInsert, GetEditor.FLines[BegY]);\r\n\r\n RestoreSelection;\r\n with TJvUnindentColumnUndo(TJvUndoBufferAccessProtected(UndoBuffer).LastUndo) do\r\n GetEditor.SetCaretInternal(CaretX, CaretY);\r\nend;\r\n\r\n//=== { TJvDeleteUndo } ======================================================\r\n\r\nprocedure TJvDeleteUndo.Undo;\r\nvar\r\n Text: string;\r\nbegin\r\n Text := '';\r\n with TJvUndoBufferAccessProtected(UndoBuffer) do\r\n begin\r\n while (FPtr >= 0) and not IsNewGroup(Self) do\r\n begin\r\n Text := TJvDeleteUndo(LastUndo).FText + Text;\r\n Dec(FPtr);\r\n if not GetEditor.GroupUndo then\r\n Break;\r\n end;\r\n Inc(FPtr);\r\n\r\n with TJvDeleteUndo(Items[FPtr]) do\r\n begin\r\n GetEditor.FLines.InsertText(CaretX, CaretY, Text);\r\n GetEditor.TextModified(CaretX, CaretY, maInsert, Text);\r\n\r\n GetEditor.SetCaretInternal(CaretX, CaretY);\r\n end;\r\n end;\r\nend;\r\n\r\n//=== { TJvDeleteLineUndo } ==================================================\r\n\r\n{procedure TJvDeleteLineUndo.Redo;\r\nbegin\r\n GetEditor.FLines.Insert(CaretY, FText);\r\nend;}\r\n\r\nconstructor TJvDeleteLineUndo.Create(AJvEditor: TJvCustomEditor; ACaretX, ACaretY: Integer;\r\n const AText: string; ALastLineDelete: Boolean);\r\nbegin\r\n inherited Create(AJvEditor, ACaretX, ACaretY, AText);\r\n FLastLineDelete := ALastLineDelete;\r\nend;\r\n\r\nprocedure TJvDeleteLineUndo.Undo;\r\nbegin\r\n GetEditor.LockUpdate;\r\n try\r\n if FLastLineDelete then\r\n begin\r\n GetEditor.FLines[CaretY] := FText;\r\n GetEditor.TextModified(CaretX, CaretY, maReplace, FText);\r\n end\r\n else\r\n begin\r\n GetEditor.FLines.Insert(CaretY, FText);\r\n GetEditor.TextModified(CaretX, CaretY, maInsert, FText);\r\n end;\r\n finally\r\n GetEditor.UnlockUpdate;\r\n end;\r\n GetEditor.SetCaretInternal(CaretX, CaretY);\r\nend;\r\n\r\n//=== { TJvBackspaceUndo } ===================================================\r\n\r\nprocedure TJvBackspaceUndo.Undo;\r\nvar\r\n Text: string;\r\n StartPtr: Integer;\r\nbegin\r\n Text := '';\r\n with TJvUndoBufferAccessProtected(UndoBuffer) do\r\n begin\r\n StartPtr := FPtr;\r\n while (FPtr >= 0) and not IsNewGroup(Self) do\r\n begin\r\n Text := Text + TJvDeleteUndo(LastUndo).FText;\r\n Dec(FPtr);\r\n if not GetEditor.GroupUndo then\r\n Break;\r\n end;\r\n Inc(FPtr);\r\n end;\r\n\r\n with TJvDeleteUndo(UndoBuffer.Items[StartPtr]) do\r\n begin\r\n GetEditor.FLines.InsertText(CaretX - 1, CaretY, Text);\r\n GetEditor.TextModified(CaretX - 1, CaretY, maInsert, Text);\r\n end;\r\n\r\n // set caret on last backspace undo's position\r\n with TJvDeleteUndo(UndoBuffer.Items[TJvUndoBufferAccessProtected(UndoBuffer).FPtr]) do\r\n if (FText = Lf) or (FText = Cr) then // a line was removed by backspace\r\n GetEditor.SetCaretInternal(0, CaretY + 1)\r\n else\r\n GetEditor.SetCaretInternal(CaretX, CaretY);\r\nend;\r\n\r\nprocedure TJvBackspaceUnindentUndo.Undo;\r\nvar\r\n Text: string;\r\nbegin\r\n Text := '';\r\n with TJvUndoBufferAccessProtected(UndoBuffer) do\r\n begin\r\n while (FPtr >= 0) and not IsNewGroup(Self) do\r\n begin\r\n Text := Text + TJvDeleteUndo(LastUndo).FText;\r\n Dec(FPtr);\r\n if not GetEditor.GroupUndo then\r\n Break;\r\n end;\r\n Inc(FPtr);\r\n\r\n with TJvDeleteUndo(Items[FPtr]) do\r\n begin\r\n GetEditor.FLines.InsertText(CaretX - Length(Text), CaretY, Text);\r\n GetEditor.TextModified(CaretX - Length(Text), CaretY, maInsert, Text);\r\n // set caret on last backspace undo's position\r\n GetEditor.SetCaretInternal(CaretX, CaretY);\r\n end;\r\n end;\r\nend;\r\n\r\n//=== { TJvReplaceUndo } =====================================================\r\n\r\nconstructor TJvReplaceUndo.Create(AJvEditor: TJvCustomEditor;\r\n ACaretX, ACaretY: Integer; ABegX, ABegY: Integer; const AText, ANewText: string);\r\nbegin\r\n inherited Create(AJvEditor, ACaretX, ACaretY);\r\n FBegX := ABegX;\r\n FBegY := ABegY;\r\n FText := AText;\r\n FNewText := ANewText;\r\nend;\r\n\r\nfunction TJvReplaceUndo.GetEditor: TJvCustomEditor;\r\nbegin\r\n Result := TJvCustomEditor(FJvEditor);\r\nend;\r\n\r\nprocedure TJvReplaceUndo.Undo;\r\nvar\r\n EndX, EndY: Integer;\r\nbegin\r\n GetEndPosCaret(FNewText, FBegX, FBegY, EndX, EndY);\r\n GetEditor.FLines.DeleteText(FBegX, FBegY, EndX, EndY);\r\n GetEditor.FLines.InsertText(FBegX, FBegY, FText);\r\n GetEditor.TextModified(FBegX, FBegY, maReplace, FText);\r\n\r\n GetEditor.SetCaretInternal(CaretX, CaretY);\r\nend;\r\n\r\n//=== { TJvDeleteSelectedUndo } ==============================================\r\n\r\nconstructor TJvDeleteSelectedUndo.Create(AJvEditor: TJvCustomEditor;\r\n ACaretX, ACaretY: Integer; const AText: string);\r\nbegin\r\n inherited Create(AJvEditor, ACaretX, ACaretY, AText);\r\n SaveSelection;\r\nend;\r\n\r\nprocedure TJvDeleteSelectedUndo.Undo;\r\nvar\r\n S: string;\r\n I: Integer;\r\nbegin\r\n with FSelection^ do\r\n begin\r\n if SelBlockFormat in [bfInclusive, bfNonInclusive, bfLine] then\r\n begin\r\n GetEditor.FLines.InsertText(SelBegX, SelBegY, FText);\r\n GetEditor.TextModified(SelBegX, SelBegY, maInsert, FText);\r\n end\r\n else\r\n if SelBlockFormat = bfColumn then\r\n begin\r\n for I := SelBegY to SelEndY do\r\n begin\r\n S := GetEditor.FLines[I];\r\n Insert(SubStrBySeparator(FText, I - SelBegY, sLineBreakStr), S, SelBegX + 1);\r\n GetEditor.FLines.Internal[I] := S;\r\n end;\r\n GetEditor.TextModified(SelBegX, SelBegY, maInsertColumn, FText);\r\n end;\r\n\r\n RestoreSelection;\r\n GetEditor.SetCaretInternal(CaretX, CaretY);\r\n end;\r\nend;\r\n\r\n//=== { TJvEditorCompletion } ================================================\r\n\r\nconstructor TJvCompletion.Create(AJvEditor: TJvCustomEditor);\r\nbegin\r\n inherited Create(AJvEditor);\r\n FIdentifiers := TStringList.Create;\r\n FTemplates := TStringList.Create;\r\n FCaretChar := '|';\r\n FCRLF := '/n';\r\n FSeparator := '=';\r\nend;\r\n\r\ndestructor TJvCompletion.Destroy;\r\nbegin\r\n inherited Destroy;\r\n FIdentifiers.Free;\r\n FTemplates.Free;\r\nend;\r\n\r\n{ Substitutes word on the cursor position by NewString [translated] }\r\n\r\nprocedure TJvCompletion.ReplaceWord(const NewString: string);\r\nvar\r\n S, W: string;\r\n X, Y: Integer;\r\n iBegSX, iEndSX: Integer;\r\n NewCaret: Integer;\r\nbegin\r\n with TJvCustomEditor(JvEditor) do\r\n begin\r\n if CaretY < FLines.Count then\r\n S := FLines[CaretY];\r\n W := GetNextWordPosEx(S, CaretX, iBegSX, iEndSX);\r\n if W <> NewString then\r\n begin\r\n BeginUpdate;\r\n PaintCaret(False);\r\n try\r\n BeginCompound;\r\n try\r\n Deselect;\r\n ReLine;\r\n\r\n if Length(W) = 0 then\r\n begin\r\n iBegSX := CaretX + 1;\r\n iEndSX := CaretX;\r\n end;\r\n case Mode of\r\n cmIdentifiers:\r\n begin\r\n S := NewString;\r\n if Assigned(FOnCompletionApply) then\r\n FOnCompletionApply(Self, W, S);\r\n NewCaret := -1;\r\n end;\r\n cmTemplates:\r\n begin\r\n S := ReplaceString(NewString, FCRLF, sLineBreakStr + Spaces(CaretX -\r\n Length(W)));\r\n S := ReplaceString(S, FCaretChar, '');\r\n NewCaret := Pos(FCaretChar, ReplaceString(NewString, FCRLF, sLineBreakStr)) - 1;\r\n end;\r\n else\r\n raise EJvEditorError.CreateRes(@RsEInvalidCompletionMode);\r\n end;\r\n {--- UNDO ---}\r\n TJvReplaceUndo.Create(TJvCustomEditor(JvEditor), CaretX, CaretY,\r\n iBegSX - 1, CaretY, W, S);\r\n {--- /UNDO ---}\r\n if iBegSX <= iEndSX then\r\n FLines.DeleteText(iBegSX - 1, CaretY, iEndSX - 1, CaretY);\r\n FLines.InsertText(iBegSX - 1, CaretY, S);\r\n TextModified(iBegSX - 1, CaretY, maReplace, S);\r\n\r\n if NewCaret >= 0 then\r\n SetLength(S, NewCaret); // truncate S to the new caret position\r\n GetEndPosCaret(S, iBegSX - 1, CaretY, X, Y);\r\n SetCaretInternal(X + 1, Y);\r\n finally\r\n EndCompound;\r\n end;\r\n Changed;\r\n finally\r\n PaintCaret(True);\r\n EndUpdate;\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvCompletion.MakeItems;\r\nvar\r\n I: Integer;\r\n S: string;\r\nbegin\r\n Items.Clear;\r\n case Mode of\r\n cmIdentifiers:\r\n for I := 0 to FIdentifiers.Count - 1 do\r\n Items.Add(FIdentifiers[I]);\r\n cmTemplates:\r\n begin\r\n with TJvCustomEditor(JvEditor) do\r\n if FLines.Count > CaretY then\r\n S := GetWordOnPos(FLines[CaretY], CaretX)\r\n else\r\n S := '';\r\n for I := 0 to FTemplates.Count - 1 do\r\n if StrLIComp(PChar(FTemplates[I]), PChar(S), Length(S)) = 0 then\r\n Items.Add(FTemplates[I]);\r\n if Items.Count = 0 then\r\n Items.Assign(FTemplates);\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvCompletion.FindSelItem(var Eq: Boolean);\r\nvar\r\n S: string;\r\n\r\n function FindFirst(Strs: TStrings; S: string): Integer;\r\n var\r\n I: Integer;\r\n begin\r\n for I := 0 to Strs.Count - 1 do\r\n if StrLIComp(PChar(Strs[I]), PChar(S), Length(S)) = 0 then\r\n begin\r\n Result := I;\r\n Exit;\r\n end;\r\n Result := -1;\r\n end;\r\n\r\nbegin\r\n with TJvCustomEditor(JvEditor) do\r\n if FLines.Count > 0 then\r\n S := GetWordOnPos(FLines[CaretY], CaretX)\r\n else\r\n S := '';\r\n if Trim(S) = '' then\r\n ItemIndex := -1\r\n else\r\n ItemIndex := FindFirst(Items, S);\r\n Eq := (ItemIndex > -1) and SameText(Trim(SubStrBySeparator(Items[ItemIndex], 0, FSeparator)), S);\r\nend;\r\n\r\nfunction TJvCompletion.GetStrings(Index: Integer): TStrings;\r\nbegin\r\n case Index of\r\n 0:\r\n Result := FIdentifiers;\r\n 1:\r\n Result := FTemplates;\r\n else\r\n Result := nil;\r\n end;\r\nend;\r\n\r\nprocedure TJvCompletion.SetStrings(Index: Integer; AValue: TStrings);\r\nbegin\r\n case Index of\r\n 0:\r\n FIdentifiers.Assign(AValue);\r\n 1:\r\n FTemplates.Assign(AValue);\r\n end;\r\nend;\r\n\r\nfunction TJvCompletion.GetIdentifierCount: Integer;\r\nbegin\r\n Result := FIdentifiers.Count;\r\nend;\r\n\r\nfunction TJvCompletion.GetTemplateCount: Integer;\r\nbegin\r\n Result := FTemplates.Count;\r\nend;\r\n\r\nprocedure TJvCompletion.ReplaceWordItemIndex(SubStrStart: Integer);\r\nbegin\r\n ReplaceWord(SubStrBySeparator(Items[ItemIndex], SubStrStart, FSeparator));\r\nend;\r\n\r\nfunction TJvCustomEditor.GetCompletion: TJvCompletion;\r\nbegin\r\n Result := TJvCompletion(inherited Completion);\r\nend;\r\n\r\nprocedure TJvCustomEditor.SetCompletion(const Value: TJvCompletion);\r\nbegin\r\n inherited Completion := Value;\r\nend;\r\n\r\nfunction TJvCompletion.GetSeparator: string;\r\nbegin\r\n Result := FSeparator;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvEditorCommon.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvEditorCommon.PAS, released on 2004-01-25\r\n\r\nThe Initial Developers of the Original Code are: Andrei Prygounkov \r\nCopyright (c) 1999, 2002 Andrei Prygounkov\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\nBurov Dmitry, translation of russian text.\r\nAndreas Hausladen\r\nPeter Thrnqvist\r\nRemko Bonte\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvEditorCommon.pas 13415 2012-09-10 09:51:54Z obones $\r\n\r\n{ history\r\n (JVCL Library versions) :\r\n 1.00:\r\n - first release;\r\n 1.01:\r\n - reduce caret blinking - method KeyUp;\r\n - fix bug with setting SelLength to 0;\r\n - changing SelStart now reset SelLength to 0;\r\n - very simple tab - two blanks;\r\n 1.02:\r\n - SmartTab;\r\n - KeepTrailingBlanks;\r\n - CursorBeyondEOF;\r\n - AutoIndent;\r\n - BackSpaceUnindents;\r\n - two-key commands;\r\n - automatically expands tabs when setting Lines property;\r\n 1.04:\r\n - some bugs fixed in Completion;\r\n - fix bug with reading SelLength property;\r\n - new method TJvEditorStrings .SetLockText;\r\n - new dynamic method TextAllChanged;\r\n 1.11:\r\n - method StatusChanged;\r\n - fixed bug with setting Lines.Text property;\r\n - new method GetText with TIEditReader syntax;\r\n 1.14:\r\n - selected color intialized with system colors;\r\n 1.17:\r\n some improvements and bug fixes by Rafal Smotrzyk - rsmotrzyk att mikroplan dott com dott pl :\r\n - AutoIndent now worked when SmartTab Off;\r\n - method GetTextLen for TMemo compatibility;\r\n - Indent, Unindent commands;\r\n - WM_COPY, WM_CUT, WM_PASTE message handling;\r\n 1.17.1:\r\n - painting and scrolling changed:\r\n bug with scrolling JvEditor if other StayOnTop\r\n window overlapes JvEditor window FIXED;\r\n - right click now not unselect text;\r\n - changing RightMargin, RightMarginVisible and RightMarginColor\r\n Invalidates window;\r\n 1.17.2:\r\n another good stuf by Rafal Smotrzyk - rsmotrzyk att mikroplan dott com dott pl :\r\n - fixed bug with backspace pressed when text selected;\r\n - fixed bug with disabling Backspace Unindents when SmartTab off;\r\n - fixed bug in GetTabStop method when SmartTab off;\r\n - new commands: DeleteWord, DeleteLine, ToUpperCase, ToLowerCase;\r\n 1.17.3:\r\n - TabStops;\r\n 1.17.4:\r\n - undo for selection modifiers;\r\n - UndoBuffer.BeginCompound, UndoBuffer.EndCompound for\r\n compound commands, that must interpreted by UndoBuffer as one operation;\r\n now not implemented, but must be used for feature compatibility;\r\n - fixed bug with undoable Delete on end of line;\r\n - new command ChangeCase;\r\n 1.17.5:\r\n - UndoBuffer.BeginCompound, UndoBuffer.EndCompound fully implemented;\r\n - UndoBuffer property in TJvCustomEditor;\r\n 1.17.6:\r\n - fixed bug with compound undo;\r\n - fixed bug with scrolling (from v 1.171);\r\n 1.17.7:\r\n - UndoBuffer.BeginCompound and UndoBuffer.EndCompound moved to TJvCustomEditor;\r\n - Macro support: BeginRecord, EndRecord, PlayMacro; not complete;\r\n - additional support for compound operations: prevent updating and other;\r\n 1.17.8:\r\n - bug fixed with compound commands in macro;\r\n 1.21.2:\r\n - fixed bug with pressing End-key if CursorBeoyondEOF enabled\r\n (greetings to Martijn Laan)\r\n 1.21.4:\r\n - fixed bug in commands ecNextWord and ecPrevWord\r\n (greetings to Ildar Noureeslamov)\r\n 1.21.6:\r\n - in OnGetLineAttr now it is possible to change attributes of right\r\n trailing blanks.\r\n 1.23:\r\n - fixed bug in completion (range check error)\r\n (greetings to Willo vd Merwe)\r\n 1.51.1 (JVCL Library 1.51 with Update 1):\r\n - methods Lines.Add and Lines.Insert now properly updates editor window.\r\n 1.51.2 (JVCL Library 1.51 with Update 2):\r\n - \"Courier New\" is default font now.\r\n 1.51.3 (JVCL Library 1.51 with Update 2)::\r\n - fixed bug: double click on empty editor raise exception;\r\n - fixed bug: backspace at EOF raise exception;\r\n - fixed bug: gutter not repainted on vertical scrolling;\r\n 1.53:\r\n - fixed bug: GetWordOnCaret returns invalid Word if caret stays on start of Word;\r\n 1.54.1:\r\n - new: undo now works in overwrite mode;\r\n 1.54.2:\r\n - fixed bug: double click not selects Word on first line;\r\n - selection work better after consecutive moving to begin_of_line and\r\n end_of_line, and in other cases;\r\n - 4 block format supported now: NonInclusive (default), Inclusive,\r\n Line (initial support), Column;\r\n - painting was improved;\r\n 1.60:\r\n - DblClick work better (thanks to Constantin M. Lushnikov);\r\n - fixed bug: caret moved when mouse moves over JvEditor after\r\n click on any other windows placed over JvEditor, which loses focus\r\n after this click; (anyone understand me ? :)\r\n - bug fixed: accelerator key do not work on window,\r\n where JvEditor is placed (thanks to Luis David Cardenas Bucio);\r\n 1.61:\r\n - support for mouse with wheel (thanks to Michael Serpik);\r\n - ANY font can be used (thanks to Rients Politiek);\r\n - bug fixed: completion ranges error on first line\r\n (thanks to Walter Campelo);\r\n - new functions: CanCopy, CanPaste, CanCut in TJvCustomEditor\r\n and function CanUndo in TJvUndoBuffer (TJvCustomEditor.UndoBuffer);\r\n 2.00:\r\n - removed dependencies from JvUtils.pas unit;\r\n - bugfixed: TJvDeleteUndo and TJvBackspaceUndo do not work always properly\r\n (thanks to Pavel Chromy);\r\n - bugfixed: workaround bug with some fonts in Win9x\r\n (thanks to Dmitry Rubinstain);\r\n 2.10.2: (changes by Andreas Hausladen)\r\n - speed optimation (font cache, many Lines.Text references were removed)\r\n - fixed bug: TJvBackspaceUndo, TJvInsertUndo, TJvDeleteUndo still do not work\r\n always properly\r\n - fixed bug: caret movement and selections set Modified to TRUE\r\n - Undo restores Modified-field\r\n - added [Ctrl][Backspace] (ecBackspaceWord) and [Shift][Backspace] command\r\n - added [Shift]+MouseDown selections\r\n - added [Alt]+MouseDown selections (column)\r\n - new event TKeyboard.OnCommand2\r\n - fixed bug: CodeCompletition catches VK_HOME, VK_END\r\n - fixed bug: on empty editor pressing [Ctrl][End] raises \"Index out of\r\n bounds (-1)\"\r\n - fixed bug: caret moves into gutter on horz. scrolling\r\n - added OnGutterClick and OnGutterDblClick events\r\n - renamed all \"Identifer\" to \"Identifier\"\r\n 2.10.3 (changes by Andreas Hausladen)\r\n - added new mouse wheel functionality: [Ctrl]+Wheel and [Shift]+Wheel\r\n - faster TJvReplaceUndo and ReplaceWord/ReplaceWord2\r\n - bug fixed: first complete selected line stops drawing selection on cell 80\r\n - added SelectAll, ClearSelection\r\n - full support for SelBlockFormat = bfColumn and bfLine\r\n - improved TJvCompletion.ReplaceWord\r\n - undo system overworked\r\n - fixed bug: [Shift][Tab] is the same as [Tab]\r\n - reduced TextAllChanged() calls\r\n - added: Un-/IndentColumns, Un-/IndentLines, Un-/IndentSelLines\r\n - new Undo: TJvUnindentColumnUndo, TJvIndentColumnUndo\r\n - moved: FSelBegX, FSelBegY, ... FSelected into TJvSelectionRec\r\n - added GetAutoIndentStop and removed AutoIndent code from GetTabStop\r\n - fixed bug: CanPaste raises Exception SCannotOpenClipboard (new: catches exception)\r\n - fixed bug: in readonly mode [Return] does nothing\r\n - added BlockOverwrite property\r\n - added PeristentBlocks\r\n 2.10.4 (changed by peter3, Andreas Hausladen)\r\n - fixed bug where pressing Enter/Return while the completion list is open inserts a line break (andreas)\r\n - fixed GetNextWordPosEx (andreas)\r\n - added default popupmenu if none assigned (JvFixedEditPopup)\r\n - added handling of WM_CLEAR, WM_GETTEXTLENGTH, EM_SETREADONLY, EM_SETSEL, EM_GETSEL and EM_CANUNDO\r\n 3.0 (changes by Andreas Hausladen)\r\n - speed optimation: GetTextLen is now faster\r\n - fixed: GetSelStart returned caret position\r\n - fixed: ecBackspace with BackSpaceUnindents=True may destroy the line\r\n - fixed a bug in InsertText\r\n - optimized ExpandTabs\r\n\r\n 2004-01-25: file split into JvEditor and JvEditorCommon\r\n\r\n Further history: see CVS/SVN\r\n}\r\n\r\nunit JvEditorCommon;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, Messages, SysUtils, Classes, Contnrs, Graphics, Controls,\r\n Forms, StdCtrls, ExtCtrls, Menus,\r\n {$IFDEF HAS_UNIT_SYSTEM_UITYPES}\r\n System.UITypes,\r\n {$ENDIF HAS_UNIT_SYSTEM_UITYPES}\r\n JvConsts, JvFixedEditPopUp, JvStdEditActions, JvUnicodeCanvas, JvComponent,\r\n JvExControls;\r\n\r\nconst\r\n Max_X = 1024; {max symbols per row}\r\n Max_X_Scroll = Max_X;\r\n {max symbols per row for scrollbar}\r\n GutterRightMargin = 2;\r\n\r\n WM_EDITCOMMAND = WM_USER + $101;\r\n WM_COMPOUND = WM_USER + $102;\r\n\r\ntype\r\n EJvEditorError = class(Exception);\r\n TJvCustomEditorBase = class; // base class for both Ansi and Unicode editor\r\n TJvCompletionBase = class;\r\n\r\n TCellRect = record\r\n Width: Integer;\r\n Height: Integer;\r\n end;\r\n\r\n TLineAttr = packed record { CompareMem() requires \"packed\" }\r\n FC: TColor;\r\n BC: TColor;\r\n Style: TFontStyles;\r\n Border: TColor;\r\n end;\r\n\r\n TLineAttrs = array {[0..Max_X]} of TLineAttr;\r\n\r\n TDynIntArray = array of Integer;\r\n TDynBoolArray = array of Boolean;\r\n\r\n TModifiedAction =\r\n (maAll, maInsert, maDelete, maInsertColumn, maDeleteColumn, maReplace);\r\n\r\n TBookmark = record\r\n X: Integer;\r\n Y: Integer;\r\n Valid: Boolean;\r\n end;\r\n TBookmarkNum = 0..9;\r\n TBookmarks = array [TBookmarkNum] of TBookmark;\r\n\r\n { Borland Block Type:\r\n 00 - inclusive;\r\n 01 - line;\r\n 02 - column;\r\n 03 - noninclusive; }\r\n TJvSelBlockFormat = (bfInclusive, bfLine, bfColumn, bfNonInclusive);\r\n\r\n TOnPaintGutter = procedure(Sender: TObject; Canvas: TCanvas) of object;\r\n TOnGutterClick = procedure(Sender: TObject; Line: Integer) of object;\r\n\r\n TJvLineChangeEvent = procedure(Sender: TObject; Line: Integer) of object;\r\n TJvCaretChangedEvent = procedure(Sender: TObject; LastCaretX, LastCaretY: Integer) of object;\r\n\r\n {$IFDEF UNICODE}\r\n TEditCommand = type LongWord;\r\n {$ELSE}\r\n TEditCommand = type Word;\r\n {$ENDIF UNICODE}\r\n TMacro = string; { used as buffer (array of char) }\r\n\r\n TJvEditKey = class(TObject)\r\n public\r\n Key1: Word;\r\n Key2: Word;\r\n Shift1: TShiftState;\r\n Shift2: TShiftState;\r\n Command: TEditCommand;\r\n constructor Create(const ACommand: TEditCommand;\r\n const AKey1: Word; const AShift1: TShiftState);\r\n constructor Create2(const ACommand: TEditCommand;\r\n const AKey1: Word; const AShift1: TShiftState;\r\n const AKey2: Word; const AShift2: TShiftState);\r\n end;\r\n\r\n TCommand2Event = procedure(Sender: TObject; const Key1: Word; const Shift1: TShiftState;\r\n const Key2: Word; const Shift2: TShiftState; var Command: TEditCommand) of object;\r\n\r\n TJvKeyboard = class(TPersistent)\r\n private\r\n FList: TObjectList;\r\n FOnCommand2: TCommand2Event;\r\n public\r\n constructor Create;\r\n destructor Destroy; override;\r\n procedure Assign(Source: TPersistent); override;\r\n procedure Add(const ACommand: TEditCommand;\r\n const AKey1: Word; const AShift1: TShiftState);\r\n procedure Add2(const ACommand: TEditCommand;\r\n const AKey1: Word; const AShift1: TShiftState;\r\n const AKey2: Word; const AShift2: TShiftState);\r\n procedure Add2Ctrl(const ACommand: TEditCommand;\r\n const AKey1: Word; const AShift1: TShiftState; const AKey2: Word);\r\n procedure Remove(const AKey1: Word; const AShift1: TShiftState);\r\n procedure Remove2(const AKey1: Word; const AShift1: TShiftState;\r\n const AKey2: Word; const AShift2: TShiftState);\r\n procedure RemoveCtrl(const ACommand: TEditCommand);\r\n procedure Clear;\r\n function Command(const AKey: Word; const AShift: TShiftState): TEditCommand;\r\n function Command2(const AKey1: Word; const AShift1: TShiftState;\r\n const AKey2: Word; const AShift2: TShiftState): TEditCommand;\r\n procedure SetDefLayout;\r\n\r\n property OnCommand2: TCommand2Event read FOnCommand2 write FOnCommand2;\r\n end;\r\n\r\n { TJvSelectionRec contains all text selection information }\r\n PJvSelectionRec = ^TJvSelectionRec;\r\n TJvSelectionRec = record\r\n IsSelected: Boolean; // maybe a function that checks BegX/Y EndX/Y would be better\r\n Selecting: Boolean;\r\n SelBlockFormat: TJvSelBlockFormat;\r\n SelBegX: Integer;\r\n SelBegY: Integer;\r\n SelEndX: Integer;\r\n SelEndY: Integer;\r\n SelStartX: Integer;\r\n SelStartY: Integer;\r\n SelLineOrgBegX, SelLineOrgEndX: Integer;\r\n end;\r\n\r\n TJvLineSelectStyle =\r\n (lssUnselected, lssBreakpoint, lssDebugPoint, lssErrorPoint);\r\n\r\n TAdjustPersistentBlockMode =\r\n (amInsert, amDelete, amDeleteLine, amLineConcat, amLineBreak);\r\n\r\n TCompletionList = (cmIdentifiers, cmTemplates);\r\n TOnCompletion = procedure(Sender: TObject; var Cancel: Boolean) of object;\r\n\r\n TJvUndo = class;\r\n\r\n IJvUndoCompound = interface\r\n ['{D326A114-0A57-4654-A7F0-16D3BBD0A2CE}']\r\n end;\r\n IJvBackspaceUndo = interface\r\n ['{88BE2C69-2C5C-48C0-AC46-888146DD70AD}']\r\n end;\r\n IJvBackspaceUnindentUndo = interface\r\n ['{A78B524C-684E-43BD-B8A4-A540CD0B022D}']\r\n end;\r\n\r\n TJvUndoBuffer = class(TList)\r\n protected\r\n FJvEditor: TJvCustomEditorBase;\r\n FPtr: Integer;\r\n InUndo: Boolean;\r\n function LastUndo: TJvUndo;\r\n function IsNewGroup(AUndo: TJvUndo): Boolean;\r\n function CanRedo: Boolean;\r\n procedure ClearRedo;\r\n function IsCaretGroup: Boolean;\r\n public\r\n procedure Add(AUndo: TJvUndo);\r\n procedure Undo;\r\n procedure Redo;\r\n procedure Clear; override;\r\n procedure Delete;\r\n function CanUndo: Boolean;\r\n end;\r\n\r\n TJvUndo = class(TInterfacedObject)\r\n protected\r\n FJvEditor: TJvCustomEditorBase;\r\n FModified: Boolean; // Editor.FModified\r\n FSelection: PJvSelectionRec;\r\n function UndoBuffer: TJvUndoBuffer;\r\n protected\r\n property JvEditor: TJvCustomEditorBase read FJvEditor;\r\n public\r\n constructor Create(AJvEditor: TJvCustomEditorBase);\r\n destructor Destroy; override;\r\n procedure Undo; virtual; abstract;\r\n procedure Redo; virtual; {abstract;}\r\n procedure SaveSelection;\r\n procedure RestoreSelection;\r\n end;\r\n\r\n TJvCaretUndo = class(TJvUndo)\r\n protected\r\n FCaretX: Integer;\r\n FCaretY: Integer;\r\n property CaretX: Integer read FCaretX write FCaretX;\r\n property CaretY: Integer read FCaretY write FCaretY;\r\n public\r\n constructor Create(AJvEditor: TJvCustomEditorBase; ACaretX, ACaretY: Integer);\r\n procedure Undo; override;\r\n end;\r\n\r\n TJvSelectUndo = class(TJvCaretUndo)\r\n public\r\n constructor Create(AJvEditor: TJvCustomEditorBase; ACaretX, ACaretY: Integer);\r\n procedure Undo; override;\r\n end;\r\n\r\n TJvUnselectUndo = class(TJvSelectUndo);\r\n\r\n TJvBeginCompoundUndo = class(TJvUndo)\r\n public\r\n procedure Undo; override;\r\n end;\r\n\r\n TJvEndCompoundUndo = class(TJvBeginCompoundUndo);\r\n\r\n TJvControlScrollBar95 = class(TObject)\r\n private\r\n FKind: TScrollBarKind;\r\n FPosition: Integer;\r\n FMin: Integer;\r\n FMax: Integer;\r\n FSmallChange: TScrollBarInc;\r\n FLargeChange: TScrollBarInc;\r\n FPage: Integer;\r\n FHandle: THandle;\r\n FOnScroll: TScrollEvent;\r\n procedure SetParam(Index, Value: Integer);\r\n protected\r\n procedure Scroll(ScrollCode: TScrollCode; var ScrollPos: Integer); virtual;\r\n public\r\n constructor Create;\r\n procedure SetParams(AMin, AMax, APosition, APage: Integer);\r\n procedure DoScroll(var Msg: TWMScroll);\r\n property Kind: TScrollBarKind read FKind write FKind default sbHorizontal;\r\n property SmallChange: TScrollBarInc read FSmallChange write FSmallChange default 1;\r\n property LargeChange: TScrollBarInc read FLargeChange write FLargeChange default 1;\r\n property Min: Integer index 0 read FMin write SetParam default 0;\r\n property Max: Integer index 1 read FMax write SetParam default 100;\r\n property Position: Integer index 2 read FPosition write SetParam default 0;\r\n property Page: Integer index 3 read FPage write SetParam;\r\n property Handle: THandle read FHandle write FHandle;\r\n property OnScroll: TScrollEvent read FOnScroll write FOnScroll;\r\n end;\r\n\r\n TJvEditorClient = class(TObject)\r\n public\r\n FJvEditor: TJvCustomEditorBase;\r\n Top: Integer;\r\n function Left: Integer;\r\n function Height: Integer;\r\n function Width: Integer;\r\n function ClientWidth: Integer;\r\n function ClientHeight: Integer;\r\n function ClientRect: TRect;\r\n function BoundsRect: TRect;\r\n function GetCanvas: TJvUnicodeCanvas;\r\n property Canvas: TJvUnicodeCanvas read GetCanvas;\r\n end;\r\n\r\n TJvGutter = class(TObject)\r\n private\r\n FJvEditor: TJvCustomEditorBase;\r\n public\r\n procedure Paint;\r\n procedure Invalidate;\r\n end;\r\n\r\n TJvLineInformation = class(TObject)\r\n private\r\n FLine: Integer;\r\n FSelectStyle: TJvLineSelectStyle;\r\n FData: Pointer;\r\n FEditor: TJvCustomEditorBase;\r\n procedure SetLine(Value: Integer);\r\n procedure SetSelectStyle(const Value: TJvLineSelectStyle);\r\n protected\r\n procedure RepaintLine(LineNum: Integer); virtual;\r\n procedure CheckEmpty; virtual; // releases the object if Data=nil and SelectStyle=lssUnselected\r\n public\r\n constructor Create(AEditor: TJvCustomEditorBase; ALine: Integer);\r\n destructor Destroy; override;\r\n\r\n property Line: Integer read FLine write SetLine;\r\n property SelectStyle: TJvLineSelectStyle read FSelectStyle write SetSelectStyle;\r\n property Data: Pointer read FData write FData;\r\n property Editor: TJvCustomEditorBase read FEditor;\r\n end;\r\n\r\n TJvLineInformationList = class(TObject)\r\n private\r\n FEditor: TJvCustomEditorBase;\r\n FList: TObjectList;\r\n FDebugColor: TColor;\r\n FDebugTextColor: TColor;\r\n FBreakpointColor: TColor;\r\n FBreakpointTextColor: TColor;\r\n FErrorPointTextColor: TColor;\r\n FErrorPointColor: TColor;\r\n function GetCount: Integer;\r\n function GetData(Index: Integer): Pointer;\r\n function GetItems(Index: Integer): TJvLineInformation;\r\n function GetLineCount: Integer;\r\n function GetLines(Index: Integer): TJvLineInformation;\r\n function GetSelectStyle(Index: Integer): TJvLineSelectStyle;\r\n procedure SetData(Index: Integer; Value: Pointer);\r\n procedure SetSelectStyle(Index: Integer; const Value: TJvLineSelectStyle);\r\n procedure SetBreakpointColor(const Value: TColor);\r\n procedure SetBreakpointTextColor(const Value: TColor);\r\n procedure SetDebugColor(const Value: TColor);\r\n procedure SetDebugTextColor(const Value: TColor);\r\n procedure SetErrorPointColor(const Value: TColor);\r\n procedure SetErrorPointTextColor(const Value: TColor);\r\n protected\r\n function CreateLineInfo(Index: Integer): TJvLineInformation;\r\n // Returns the line information assoziated with the line or creates a new.\r\n // If Index not in [0..Count-1] the function raises EListError\r\n public\r\n constructor Create(AEditor: TJvCustomEditorBase);\r\n destructor Destroy; override;\r\n\r\n procedure Clear;\r\n // Clear() removes all extra line information objects\r\n procedure DeleteLine(Line: Integer);\r\n // DeleteLine() deletes all information for \"Line\" and updates all\r\n // following lines by decrementing their line number\r\n procedure InsertLine(Line: Integer);\r\n // InsertLine() updates all line information line number which are below\r\n // \"Line\"\r\n\r\n property Count: Integer read GetCount;\r\n property Items[Index: Integer]: TJvLineInformation read GetItems;\r\n\r\n property LineCount: Integer read GetLineCount;\r\n // LineCount returns Editor.Lines.Count\r\n property Lines[Index: Integer]: TJvLineInformation read GetLines; default;\r\n // Lines[] returns nil if the line has no extra information\r\n property SelectStyle[Index: Integer]: TJvLineSelectStyle read GetSelectStyle write SetSelectStyle;\r\n // SelectStyle[] returns/sets the select style for the line\r\n property Data[Index: Integer]: Pointer read GetData write SetData;\r\n // Data[] returns/sets the user defined data for the line\r\n\r\n property DebugPointColor: TColor read FDebugColor write SetDebugColor;\r\n property DebugPointTextColor: TColor read FDebugTextColor write SetDebugTextColor;\r\n property BreakpointColor: TColor read FBreakpointColor write SetBreakpointColor;\r\n property BreakpointTextColor: TColor read FBreakpointTextColor write SetBreakpointTextColor;\r\n property ErrorPointColor: TColor read FErrorPointColor write SetErrorPointColor;\r\n property ErrorPointTextColor: TColor read FErrorPointTextColor write SetErrorPointTextColor;\r\n\r\n property Editor: TJvCustomEditorBase read FEditor;\r\n end;\r\n\r\n TJvBracketHighlighting = class(TPersistent)\r\n private\r\n FStart: TRect;\r\n FStop: TRect;\r\n\r\n FActive: Boolean;\r\n FFontColor: TColor;\r\n FBorderColor: TColor;\r\n FColor: TColor;\r\n FWordPairs: TStrings;\r\n FCaseSensitiveWordPairs: Boolean;\r\n FStringChar: string;\r\n FCommentPairs: TStrings;\r\n FStringChars: string;\r\n FStringEscape: string;\r\n FShowBetweenHighlighting: Boolean;\r\n procedure SetWordPairs(Value: TStrings);\r\n procedure SetCommentPairs(const Value: TStrings);\r\n public\r\n constructor Create;\r\n destructor Destroy; override;\r\n procedure Assign(Source: TPersistent); override;\r\n\r\n function CreateStringMap(const Text: string): TDynBoolArray;\r\n published\r\n property Active: Boolean read FActive write FActive default False;\r\n property BorderColor: TColor read FBorderColor write FBorderColor default clSilver;\r\n property Color: TColor read FColor write FColor default clNone;\r\n property FontColor: TColor read FFontColor write FFontColor default clNone;\r\n property ShowBetweenHighlighting: Boolean read FShowBetweenHighlighting write FShowBetweenHighlighting default False;\r\n\r\n property CaseSensitiveWordPairs: Boolean read FCaseSensitiveWordPairs write FCaseSensitiveWordPairs default True;\r\n property WordPairs: TStrings read FWordPairs write SetWordPairs;\r\n { example: \"begin=end\", \"repeat=until\", \"for=do\", \"asm=end\" }\r\n property StringChars: string read FStringChars write FStringChars;\r\n { example: '\"''' }\r\n property StringEscape: string read FStringEscape write FStringEscape;\r\n { example: '\\\"' }\r\n property CommentPairs: TStrings read FCommentPairs write SetCommentPairs; // not implemented yet\r\n { example: \"/*=*/\", \"(*=*)\" }\r\n end;\r\n\r\n TJvErrorHighlighting = class;\r\n\r\n TJvErrorHighlightingItem = class(TObject)\r\n private\r\n FCol: Integer;\r\n FLine: Integer;\r\n FLen: Integer;\r\n FErrorText: string;\r\n FData: TObject;\r\n FTag: Integer;\r\n FOwner: TJvErrorHighlighting;\r\n procedure SetCol(const Value: Integer);\r\n procedure SetLine(const Value: Integer);\r\n public\r\n constructor Create(AOwner: TJvErrorHighlighting;\r\n ACol, ALine, ALen: Integer; const AErrorText: string);\r\n destructor Destroy; override;\r\n\r\n property Col: Integer read FCol write SetCol;\r\n property Line: Integer read FLine write SetLine;\r\n property Len: Integer read FLen;\r\n property ErrorText: string read FErrorText;\r\n property Data: TObject read FData write FData;\r\n property Tag: Integer read FTag write FTag;\r\n end;\r\n\r\n TJvErrorHighlighting = class(TObject)\r\n private\r\n FItems: TObjectList;\r\n FEditor: TJvCustomEditorBase;\r\n FNeedsRepaint: Boolean;\r\n FPaintLock: Integer;\r\n function GetCount: Integer;\r\n function GetItem(Index: Integer): TJvErrorHighlightingItem;\r\n protected\r\n procedure RepaintLine(Line: Integer);\r\n public\r\n constructor Create(AEditor: TJvCustomEditorBase);\r\n destructor Destroy; override;\r\n\r\n function Add(ACol, ALine, ALen: Integer; const AErrorText: string): Integer;\r\n procedure Remove(Item: TJvErrorHighlightingItem);\r\n procedure Delete(Index: Integer);\r\n procedure Clear;\r\n procedure BeginUpdate;\r\n procedure EndUpdate;\r\n\r\n procedure DeleteLine(Line: Integer);\r\n // DeleteLine() deletes all error information for \"Line\" and updates all\r\n // following lines by decrementing their line number\r\n procedure InsertLine(Line: Integer);\r\n // InsertLine() updates all error information line number which are below\r\n // \"Line\"\r\n\r\n function GetLineErrorMap(Y: Integer): TDynBoolArray;\r\n function ErrorAt(X, Y: Integer): TJvErrorHighlightingItem;\r\n procedure PaintError(Canvas: TCanvas; Col, Line: Integer; const R: TRect;\r\n Len: Integer; const MyDi: TDynIntArray);\r\n\r\n property Count: Integer read GetCount;\r\n property Items[Index: Integer]: TJvErrorHighlightingItem read GetItem; default;\r\n\r\n property Editor: TJvCustomEditorBase read FEditor;\r\n end;\r\n\r\n TJvCustomEditorBase = class(TJvCustomControl, IFixedPopupIntf, IStandardEditActions)\r\n private\r\n { internal objects }\r\n FScrollBarHorz: TJvControlScrollBar95;\r\n FScrollBarVert: TJvControlScrollBar95;\r\n FEditorClient: TJvEditorClient;\r\n FCompletion: TJvCompletionBase; // must be initialized by a decendent\r\n\r\n FGutter: TJvGutter;\r\n FKeyboard: TJvKeyboard;\r\n FUpdateLock: Integer;\r\n FUndoBuffer: TJvUndoBuffer;\r\n FGroupUndo: Boolean;\r\n FUndoAfterSave: Boolean;\r\n FBracketHighlighting: TJvBracketHighlighting;\r\n FErrorHighlighting: TJvErrorHighlighting;\r\n FCurrentLineHighlight: TColor;\r\n\r\n { internal - Columns and rows attributes }\r\n FCols: Integer;\r\n FRows: Integer;\r\n FLeftCol: Integer;\r\n FTopRow: Integer;\r\n // FLeftColMax, FTopRowMax : Integer;\r\n FLastVisibleCol: Integer;\r\n FLastVisibleRow: Integer;\r\n FVisibleColCount: Integer;\r\n FVisibleRowCount: Integer;\r\n\r\n { internal - other flags and attributes }\r\n FFontCache: TList; // collects all used fonts for faster font creation\r\n FAllRepaint: Boolean;\r\n FCellRect: TCellRect;\r\n IgnoreKeyPress: Boolean;\r\n WaitSecondKey: Boolean;\r\n Key1: Word;\r\n Shift1: TShiftState;\r\n\r\n { internal - selection attributes }\r\n FUpdateSelBegY: Integer;\r\n FUpdateSelEndY: Integer;\r\n FPersistentBlocksCaretChanged: Boolean;\r\n FSelBackColor: TColor;\r\n FSelForeColor: TColor;\r\n FLineInformations: TJvLineInformationList;\r\n\r\n { mouse support }\r\n TimerScroll: TTimer;\r\n MouseMoveY: Integer;\r\n MouseMoveXX: Integer;\r\n MouseMoveYY: Integer;\r\n FDoubleClick: Boolean;\r\n FMouseDown: Boolean;\r\n\r\n { internal }\r\n FTabStops: string;\r\n\r\n FCompound: Integer;\r\n\r\n { visual attributes - properties }\r\n FBorderStyle: TBorderStyle;\r\n FGutterColor: TColor;\r\n FGutterWidth: Integer;\r\n FRightMarginVisible: Boolean;\r\n FRightMargin: Integer;\r\n FRightMarginColor: TColor;\r\n FScrollBars: TScrollStyle;\r\n FDoubleClickLine: Boolean;\r\n FSmartTab: Boolean;\r\n FBackSpaceUnindents: Boolean;\r\n FAutoIndent: Boolean;\r\n FKeepTrailingBlanks: Boolean;\r\n FCursorBeyondEOF: Boolean;\r\n FCursorBeyondEOL: Boolean;\r\n FBlockOverwrite: Boolean;\r\n FPersistentBlocks: Boolean;\r\n FHideCaret: Boolean;\r\n\r\n { non-visual attributes - properties }\r\n FInsertMode: Boolean;\r\n FReadOnly: Boolean;\r\n FModified: Boolean;\r\n FRecording: Boolean;\r\n FBeepOnError: Boolean;\r\n FUseFixedPopup: Boolean;\r\n\r\n { events }\r\n FOnChange: TNotifyEvent;\r\n FOnSelectionChange: TNotifyEvent;\r\n FOnChangeStatus: TNotifyEvent;\r\n FOnScroll: TNotifyEvent;\r\n FOnResize: TNotifyEvent;\r\n FOnDblClick: TNotifyEvent;\r\n FOnPaintGutter: TOnPaintGutter;\r\n FOnGutterClick: TOnGutterClick;\r\n FOnGutterDblClick: TOnGutterClick;\r\n\r\n FOnCompletionIdentifier: TOnCompletion;\r\n FOnCompletionTemplate: TOnCompletion;\r\n FOnCompletionDrawItem: TDrawItemEvent;\r\n FOnCompletionMeasureItem: TMeasureItemEvent;\r\n\r\n FOnLineInserted: TJvLineChangeEvent;\r\n FOnLineDeleted: TJvLineChangeEvent;\r\n FOnCaretChanged: TJvCaretChangedEvent;\r\n\r\n function GetKeepTrailingBlanks: Boolean;\r\n\r\n { internal message processing }\r\n procedure WMEditCommand(var Msg: TMessage); message WM_EDITCOMMAND;\r\n procedure WMCompound(var Msg: TMessage); message WM_COMPOUND;\r\n procedure CMResetCaptureControl(var Msg: TMessage); message CM_RESETCAPTURECONTROL;\r\n procedure WMHScroll(var Msg: TWMHScroll); message WM_HSCROLL;\r\n procedure WMVScroll(var Msg: TWMVScroll); message WM_VSCROLL;\r\n procedure WMSetCursor(var Msg: TWMSetCursor); message WM_SETCURSOR;\r\n procedure WMCopy(var Msg: TMessage); message WM_COPY;\r\n procedure WMCut(var Msg: TMessage); message WM_CUT;\r\n procedure WMPaste(var Msg: TMessage); message WM_PASTE;\r\n procedure WMUndo(var Msg: TMessage); message WM_UNDO;\r\n\r\n // (p3) added to be compatible with JvFixedEditPopup\r\n procedure WMClear(var Msg: TMessage); message WM_CLEAR;\r\n procedure EMSetReadOnly(var Msg: TMessage); message EM_SETREADONLY;\r\n procedure EMSetSelection(var Msg: TMessage); message EM_SETSEL;\r\n procedure EMGetSelection(var Msg: TMessage); message EM_GETSEL;\r\n procedure EMCanUndo(var Msg: TMessage); message EM_CANUNDO;\r\n procedure WMGetText(var Msg: TWMGetText); message WM_GETTEXT;\r\n procedure WMGetTextLength(var Msg: TMessage); message WM_GETTEXTLENGTH;\r\n protected\r\n FMyDi: TDynIntArray; //array [0..Max_X] of Integer;\r\n FSelection: TJvSelectionRec;\r\n FCaretX: Integer;\r\n FCaretY: Integer;\r\n FTabPos: array [0..Max_X] of Boolean;\r\n { FMacro - buffer of TEditCommand, each command represents by two chars }\r\n FMacro: TMacro;\r\n FDefMacro: TMacro;\r\n\r\n procedure UpdateEditorSize; virtual;\r\n procedure UpdateEditorView; virtual;\r\n procedure ScrollTimer(Sender: TObject);\r\n\r\n function GetDefTabStop(X: Integer; Next: Boolean): Integer; virtual;\r\n function GetTabStop(X, Y: Integer; Next: Boolean): Integer; virtual; abstract;\r\n function GetBackStop(X, Y: Integer): Integer; virtual; abstract;\r\n function GetAutoIndentStop(Y: Integer): Integer; virtual; abstract;\r\n function GetTextLine(Y: Integer; out Text: string): Boolean; virtual; abstract;\r\n function InternGetWordOnCaret: string; virtual; abstract;\r\n\r\n { triggers when Lines changes }\r\n procedure DoLinesChange(Sender: TObject); virtual;\r\n procedure ReLine; virtual; abstract;\r\n procedure TextAllChangedInternal(Unselect: Boolean); virtual;\r\n\r\n { triggers for descendants }\r\n procedure Changed; virtual;\r\n procedure TextAllChanged; virtual;\r\n procedure StatusChanged; virtual;\r\n procedure SelectionChanged; virtual;\r\n procedure GetAttr(Line, ColBeg, ColEnd: Integer); virtual;\r\n procedure ChangeAttr(Line, ColBeg, ColEnd: Integer); virtual;\r\n procedure GutterPaint(Canvas: TCanvas); virtual;\r\n procedure GutterClick(Line: Integer); virtual;\r\n procedure GutterDblClick(Line: Integer); virtual;\r\n procedure BookmarkChanged(Bookmark: Integer); virtual;\r\n procedure CompletionIdentifier(var Cancel: Boolean); virtual;\r\n procedure CompletionTemplate(var Cancel: Boolean); virtual;\r\n procedure DoCompletionIdentifier(var Cancel: Boolean);\r\n procedure DoCompletionTemplate(var Cancel: Boolean);\r\n protected\r\n procedure Resize; override;\r\n procedure CreateWnd; override;\r\n procedure CreateParams(var Params: TCreateParams); override;\r\n procedure Loaded; override;\r\n procedure ScrollBarScroll(Sender: TObject; ScrollCode: TScrollCode; var\r\n ScrollPos: Integer);\r\n procedure Scroll(Vert: Boolean; ScrollPos: Integer); virtual;\r\n procedure KeyDown(var Key: Word; Shift: TShiftState); override;\r\n procedure KeyPress(var Key: Char); override;\r\n\r\n procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;\r\n procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;\r\n procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;\r\n function DoMouseWheel(Shift: TShiftState; WheelDelta: Integer; MousePos: TPoint): Boolean; override;\r\n procedure DblClick; override;\r\n\r\n procedure GetDlgCode(var Code: TDlgCodes); override;\r\n procedure FocusSet(PrevWnd: THandle); override;\r\n procedure FocusKilled(NextWnd: THandle); override;\r\n procedure DoPaste; virtual;\r\n procedure DoCopy; virtual;\r\n procedure DoCut; virtual;\r\n procedure CursorChanged; override;\r\n procedure FontChanged; override;\r\n function DoEraseBackground(Canvas: TCanvas; Param: LPARAM): Boolean; override;\r\n\r\n { IFixedPopupIntf method assignment }\r\n procedure IFixedPopupIntf.Cut = ClipboardCut;\r\n procedure IFixedPopupIntf.Copy = ClipboardCopy;\r\n procedure IFixedPopupIntf.Paste = ClipboardPaste;\r\n procedure IFixedPopupIntf.Delete = DeleteSelected;\r\n\r\n { IStandardEditActions method assignment }\r\n procedure IStandardEditActions.Cut = ClipboardCut;\r\n procedure IStandardEditActions.Copy = ClipboardCopy;\r\n procedure IStandardEditActions.Paste = ClipboardPaste;\r\n procedure IStandardEditActions.ClearSelection = DeleteSelected;\r\n protected\r\n { get/set methods for properties }\r\n procedure SetGutterWidth(AWidth: Integer);\r\n procedure SetGutterColor(AColor: TColor);\r\n procedure SetBorderStyle(Value: TBorderStyle);\r\n function GetSelStart: Integer;\r\n procedure SetSelStart(ASelStart: Integer);\r\n procedure SetSelLength(ASelLength: Integer);\r\n function GetSelLength: Integer;\r\n procedure SetSelBlockFormat(Value: TJvSelBlockFormat);\r\n function GetSelBlockFormat: TJvSelBlockFormat;\r\n procedure SetMode(Index: Integer; Value: Boolean);\r\n procedure SetCaretPosition(Index, Pos: Integer);\r\n procedure SetCols(ACols: Integer);\r\n procedure SetRows(ARows: Integer);\r\n procedure SetScrollBars(Value: TScrollStyle);\r\n procedure SetRightMarginVisible(Value: Boolean);\r\n procedure SetRightMargin(Value: Integer);\r\n procedure SetRightMarginColor(Value: TColor);\r\n procedure SetSelBackColor(const Value: TColor);\r\n procedure SetSelForeColor(const Value: TColor);\r\n procedure SetBracketHighlighting(Value: TJvBracketHighlighting);\r\n procedure SetCurrentLineHighlight(const Value: TColor);\r\n function GetPopupMenu: TPopupMenu; override;\r\n\r\n function GetLineCount: Integer; virtual; abstract;\r\n function GetLineLength(Index: Integer): Integer; virtual; abstract;\r\n function FindNotBlankCharPosInLine(Line: Integer): Integer; virtual; abstract;\r\n\r\n procedure LockUpdate;\r\n procedure UnlockUpdate;\r\n property UpdateLock: Integer read FUpdateLock;\r\n property Compound: Integer read FCompound;\r\n property EditorClient: TJvEditorClient read FEditorClient;\r\n protected\r\n function GetClipboardBlockFormat: TJvSelBlockFormat;\r\n procedure SetClipboardBlockFormat(const Value: TJvSelBlockFormat);\r\n procedure SetSel(SelX, SelY: Integer);\r\n function IsNewSelection: Boolean;\r\n function IsEmptySelection: Boolean;\r\n procedure PaintSelection;\r\n procedure SetUnSelected;\r\n procedure RemoveSelectedBlock;\r\n procedure PersistentBlocksSetUnSelected;\r\n procedure SetSelUpdateRegion(BegY, EndY: Integer);\r\n procedure AdjustSelLineMode(Restore: Boolean);\r\n procedure AdjustPersistentBlockSelection(X, Y: Integer;\r\n Mode: TAdjustPersistentBlockMode; Args: array of Integer);\r\n protected\r\n LineAttrs: TLineAttrs;\r\n\r\n procedure Paint; override;\r\n procedure PaintLine(Line: Integer; ColBeg, ColEnd: Integer); overload;\r\n procedure PaintLineText(Line: Integer; ColBeg, ColEnd: Integer;\r\n var ColPainted: Integer); virtual; abstract;\r\n procedure GetBracketHighlightAttr(Line: Integer; var Attrs: TLineAttrs); virtual;\r\n procedure HighlightBrackets(X, Y: Integer; BetweenSearch: Boolean = False); virtual;\r\n procedure GetBracketHighlightingWords(var Direction: Integer;\r\n const Start: string; var Stop: string; var CaseSensitive: Boolean); virtual;\r\n function FontCacheFind(LA: TLineAttr): TFont;\r\n procedure FontCacheClear;\r\n procedure InsertChar(const Key: Word); virtual; abstract;\r\n\r\n procedure Mouse2Cell(X, Y: Integer; var CX, CY: Integer);\r\n\r\n procedure DrawRightMargin;\r\n procedure SetCaretInternal(X, Y: Integer);\r\n procedure CheckBeyondEOL(var CX: Integer; CY: Integer);\r\n\r\n procedure NotUndoable;\r\n procedure NotRedoable;\r\n procedure ChangeBookmark(Bookmark: TBookmarkNum; Valid: Boolean);\r\n procedure BeginRecord;\r\n procedure EndRecord(var AMacro: TMacro);\r\n procedure PlayMacro(const AMacro: TMacro);\r\n\r\n function DoCommand(ACommand: TEditCommand; var X, Y: Integer;\r\n var CaretUndo: Boolean): Boolean; virtual; abstract;\r\n procedure LineDeleted(Line: Integer); virtual;\r\n procedure LineInserted(Line: Integer); virtual;\r\n\r\n property LineCount: Integer read GetLineCount;\r\n property LineLength[Index: Integer]: Integer read GetLineLength;\r\n\r\n property Completion: TJvCompletionBase read FCompletion write FCompletion;\r\n public\r\n Bookmarks: TBookmarks;\r\n\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n procedure Assign(Source: TPersistent); override;\r\n procedure SetLeftTop(ALeftCol, ATopRow: Integer);\r\n procedure PaintLine(Line: Integer); overload;\r\n\r\n function CanUndo: Boolean; { IFixedPopupIntf }\r\n function CanRedo: Boolean;\r\n function CanCopy: Boolean; { IFixedPopupIntf }\r\n function CanPaste: Boolean; { IFixedPopupIntf }\r\n function CanCut: Boolean; { IFixedPopupIntf }\r\n function CanSelectAll: Boolean; { IFixedPopupIntf }\r\n procedure SelectAll; { IFixedPopupIntf }\r\n function HasSelection: Boolean; { IFixedPopupIntf }\r\n\r\n procedure ClipboardCopy; virtual; abstract;\r\n procedure ClipboardPaste; virtual; abstract;\r\n procedure ClipboardCut; virtual;\r\n procedure DeleteSelected; virtual; abstract;\r\n procedure Deselect; virtual;\r\n\r\n procedure Undo;\r\n procedure Redo; // not implemented yet\r\n\r\n procedure CaretChanged(LastCaretX, LastCaretY: Integer); virtual;\r\n\r\n procedure SelectRange(BegX, BegY, EndX, EndY: Integer);\r\n function CalcCellRect(X, Y: Integer): TRect;\r\n procedure SetCaret(X, Y: Integer);\r\n procedure CaretFromPos(Pos: Integer; var X, Y: Integer);\r\n function PosFromCaret(X, Y: Integer): Integer;\r\n procedure Mouse2Caret(X, Y: Integer; var CX, CY: Integer);\r\n { MousePosToCell returns the cell position of the cell where the mouse\r\n cursor is. }\r\n procedure MousePosToCell(X, Y: Integer; var CX, CY: Integer);\r\n procedure CaretCoord(X, Y: Integer; var CX, CY: Integer);\r\n function PosFromMouse(X, Y: Integer): Integer;\r\n\r\n procedure PaintCaret(bShow: Boolean);\r\n function GetTextLen: Integer;\r\n function GetText: string; virtual; abstract;\r\n procedure SelectWordOnCaret; virtual; abstract;\r\n\r\n procedure BeginUpdate;\r\n procedure EndUpdate;\r\n procedure MakeRowVisible(ARow: Integer);\r\n\r\n procedure Command(ACommand: TEditCommand); virtual;\r\n procedure PostCommand(ACommand: TEditCommand);\r\n\r\n procedure IndentColumns(X: Integer; BegY, EndY: Integer); virtual; abstract;\r\n procedure UnIndentColumns(X: Integer; BegY, EndY: Integer); virtual; abstract;\r\n procedure IndentLines(UnIndent: Boolean; BegY, EndY: Integer);\r\n procedure IndentSelLines(UnIndent: Boolean);\r\n\r\n procedure BeginCompound;\r\n procedure EndCompound;\r\n procedure PostBeginCompound;\r\n procedure PostEndCompound;\r\n\r\n property Gutter: TJvGutter read FGutter;\r\n\r\n property LeftCol: Integer read FLeftCol;\r\n property TopRow: Integer read FTopRow;\r\n property VisibleColCount: Integer read FVisibleColCount;\r\n property VisibleRowCount: Integer read FVisibleRowCount;\r\n property LastVisibleCol: Integer read FLastVisibleCol;\r\n property LastVisibleRow: Integer read FLastVisibleRow;\r\n property Cols: Integer read FCols write SetCols;\r\n property Rows: Integer read FRows write SetRows;\r\n property CaretX: Integer index 0 read FCaretX write SetCaretPosition;\r\n property CaretY: Integer index 1 read FCaretY write SetCaretPosition;\r\n property Modified: Boolean read FModified write FModified;\r\n property SelBlockFormat: TJvSelBlockFormat read GetSelBlockFormat write SetSelBlockFormat default bfNonInclusive;\r\n property SelStart: Integer read GetSelStart write SetSelStart;\r\n property SelLength: Integer read GetSelLength write SetSelLength;\r\n property Keyboard: TJvKeyboard read FKeyboard;\r\n property CellRect: TCellRect read FCellRect;\r\n property UndoBuffer: TJvUndoBuffer read FUndoBuffer;\r\n property GroupUndo: Boolean read FGroupUndo write FGroupUndo default True;\r\n property UndoAfterSave: Boolean read FUndoAfterSave write FUndoAfterSave;\r\n property Recording: Boolean read FRecording;\r\n property UseFixedPopup: Boolean read FUseFixedPopup write FUseFixedPopup;\r\n\r\n property LineInformations: TJvLineInformationList read FLineInformations;\r\n public\r\n { published in descendants }\r\n property BeepOnError: Boolean read FBeepOnError write FBeepOnError default False;\r\n property BorderStyle: TBorderStyle read FBorderStyle write SetBorderStyle default bsSingle;\r\n property ScrollBars: TScrollStyle read FScrollBars write SetScrollBars default ssBoth;\r\n property Cursor default crIBeam;\r\n property Color default clWindow;\r\n property TabStop default True;\r\n property ParentFont default False;\r\n property ParentColor default False;\r\n\r\n property GutterWidth: Integer read FGutterWidth write SetGutterWidth default 0;\r\n property GutterColor: TColor read FGutterColor write SetGutterColor default clBtnFace;\r\n property RightMarginVisible: Boolean read FRightMarginVisible write SetRightMarginVisible default True;\r\n property RightMargin: Integer read FRightMargin write SetRightMargin default 80;\r\n property RightMarginColor: TColor read FRightMarginColor write SetRightMarginColor default clSilver;\r\n property InsertMode: Boolean index 0 read FInsertMode write SetMode default True;\r\n property ReadOnly: Boolean index 1 read FReadOnly write SetMode default False;\r\n property DoubleClickLine: Boolean read FDoubleClickLine write FDoubleClickLine default False;\r\n property TabStops: string read FTabStops write FTabStops;\r\n property SmartTab: Boolean read FSmartTab write FSmartTab default True;\r\n property BackSpaceUnindents: Boolean read FBackSpaceUnindents write FBackSpaceUnindents default True;\r\n property AutoIndent: Boolean read FAutoIndent write FAutoIndent default True;\r\n property KeepTrailingBlanks: Boolean read GetKeepTrailingBlanks write FKeepTrailingBlanks default False;\r\n property CursorBeyondEOF: Boolean read FCursorBeyondEOF write FCursorBeyondEOF default False;\r\n property CursorBeyondEOL: Boolean read FCursorBeyondEOL write FCursorBeyondEOL default True;\r\n property BlockOverwrite: Boolean read FBlockOverwrite write FBlockOverwrite default True;\r\n property PersistentBlocks: Boolean read FPersistentBlocks write FPersistentBlocks default False;\r\n property BracketHighlighting: TJvBracketHighlighting read FBracketHighlighting write SetBracketHighlighting;\r\n property SelForeColor: TColor read FSelForeColor write SetSelForeColor default clHighlightText;\r\n property SelBackColor: TColor read FSelBackColor write SetSelBackColor default clHighlight;\r\n property HideCaret: Boolean read FHideCaret write FHideCaret default False;\r\n property CurrentLineHighlight: TColor read FCurrentLineHighlight write SetCurrentLineHighlight default clNone;\r\n property ErrorHighlighting: TJvErrorHighlighting read FErrorHighlighting;\r\n\r\n property OnChangeStatus: TNotifyEvent read FOnChangeStatus write FOnChangeStatus;\r\n property OnScroll: TNotifyEvent read FOnScroll write FOnScroll;\r\n property OnResize: TNotifyEvent read FOnResize write FOnResize;\r\n property OnKeyDown;\r\n property OnKeyPress;\r\n property OnKeyUp;\r\n property OnChange: TNotifyEvent read FOnChange write FOnChange;\r\n property OnSelectionChange: TNotifyEvent read FOnSelectionChange write FOnSelectionChange;\r\n property OnMouseDown;\r\n property OnMouseMove;\r\n property OnMouseUp;\r\n property OnDblClick: TNotifyEvent read FOnDblClick write FOnDblClick;\r\n property OnPaintGutter: TOnPaintGutter read FOnPaintGutter write FOnPaintGutter;\r\n property OnGutterClick: TOnGutterClick read FOnGutterClick write FOnGutterClick;\r\n property OnGutterDblClick: TOnGutterClick read FOnGutterDblClick write FOnGutterDblClick;\r\n property OnCaretChanged: TJvCaretChangedEvent read FOnCaretChanged write FOnCaretChanged;\r\n\r\n property OnCompletionIdentifier: TOnCompletion read FOnCompletionIdentifier write FOnCompletionIdentifier;\r\n property OnCompletionTemplate: TOnCompletion read FOnCompletionTemplate write FOnCompletionTemplate;\r\n property OnCompletionDrawItem: TDrawItemEvent read FOnCompletionDrawItem write FOnCompletionDrawItem;\r\n property OnCompletionMeasureItem: TMeasureItemEvent read FOnCompletionMeasureItem write FOnCompletionMeasureItem;\r\n\r\n property OnLineInserted: TJvLineChangeEvent read FOnLineInserted write FOnLineInserted;\r\n property OnLineDeleted: TJvLineChangeEvent read FOnLineDeleted write FOnLineDeleted;\r\n\r\n property DockManager;\r\n end;\r\n\r\n TJvCompletionBase = class(TPersistent)\r\n private\r\n FJvEditor: TJvCustomEditorBase;\r\n FPopupList: TListBox;\r\n FItemIndex: Integer;\r\n FMode: TCompletionList;\r\n FDefMode: TCompletionList;\r\n FItemHeight: Integer;\r\n FTimer: TTimer;\r\n FEnabled: Boolean;\r\n FVisible: Boolean;\r\n FDropDownCount: Integer;\r\n FDropDownWidth: Integer;\r\n FListBoxStyle: TListBoxStyle;\r\n procedure OnTimer(Sender: TObject);\r\n function GetItemIndex: Integer;\r\n procedure SetItemIndex(AValue: Integer);\r\n function GetInterval: Cardinal;\r\n procedure SetInterval(AValue: Cardinal);\r\n function GetItems: TStrings;\r\n protected\r\n function DoKeyDown(Key: Word; Shift: TShiftState): Boolean; virtual;\r\n procedure DoKeyPress(Key: Char); virtual;\r\n\r\n procedure FindSelItem(var Eq: Boolean); virtual; abstract;\r\n procedure MakeItems; virtual; abstract;\r\n procedure ReplaceWordItemIndex(SubStrStart: Integer); virtual; abstract;\r\n function GetTemplateCount: Integer; virtual; abstract;\r\n function GetIdentifierCount: Integer; virtual; abstract;\r\n function GetSeparator: string; virtual; abstract;\r\n\r\n function GetItemCount: Integer;\r\n property JvEditor: TJvCustomEditorBase read FJvEditor;\r\n property Items: TStrings read GetItems;\r\n public\r\n constructor Create(AJvEditor: TJvCustomEditorBase);\r\n destructor Destroy; override;\r\n procedure DropDown(const AMode: TCompletionList; const ShowAlways: Boolean);\r\n procedure DoCompletion(const AMode: TCompletionList);\r\n procedure CloseUp(const Apply: Boolean);\r\n procedure SelectItem;\r\n property ItemIndex: Integer read GetItemIndex write SetItemIndex;\r\n property Visible: Boolean read FVisible write FVisible;\r\n property Mode: TCompletionList read FMode write FMode;\r\n published\r\n property DropDownCount: Integer read FDropDownCount write FDropDownCount default 6;\r\n property DropDownWidth: Integer read FDropDownWidth write FDropDownWidth default 300;\r\n property Enabled: Boolean read FEnabled write FEnabled default False;\r\n property ItemHeight: Integer read FItemHeight write FItemHeight;\r\n property Interval: Cardinal read GetInterval write SetInterval default 800;\r\n property ListBoxStyle: TListBoxStyle read FListBoxStyle write FListBoxStyle default lbStandard;\r\n end;\r\n\r\n//=== Highligther Editor =====================================================\r\n\r\ntype\r\n TJvHighlighter = (hlNone, hlPascal, hlCBuilder, hlSql, hlPython, hlJava, hlJScript, hlVB,\r\n hlHtml, hlPerl, hlIni, hlCocoR, hlPhp, hlNQC, hlCSharp,\r\n hlSyntaxHighlighter);\r\n TLongTokenType = 0..255;\r\n\r\nconst\r\n lgNone = TLongTokenType(0);\r\n lgComment1 = TLongTokenType(1);\r\n lgComment2 = TLongTokenType(2);\r\n lgString = TLongTokenType(4);\r\n lgTag = TLongTokenType(5);\r\n lgPreproc = TLongTokenType(6);\r\n lgPreproc1 = lgPreproc;\r\n lgPreproc2 = TLongTokenType(7);\r\n lgUndefined = High(TLongTokenType);\r\n\r\ntype\r\n TDelphiColor = record\r\n ForeColor, BackColor: TColor;\r\n Style: TFontStyles;\r\n end;\r\n\r\nconst\r\n DelphiColor_Comment: TDelphiColor = (ForeColor: clNavy; BackColor: clWindow; Style: [fsItalic]);\r\n DelphiColor_Preproc: TDelphiColor = (ForeColor: clGreen; BackColor: clWindow; Style: []);\r\n DelphiColor_Number: TDelphiColor = (ForeColor: clNavy; BackColor: clWindow; Style: []);\r\n DelphiColor_Strings: TDelphiColor = (ForeColor: clBlue; BackColor: clWindow; Style: []);\r\n DelphiColor_Symbol: TDelphiColor = (ForeColor: clBlack; BackColor: clWindow; Style: []);\r\n DelphiColor_Reserved: TDelphiColor = (ForeColor: clBlack; BackColor: clWindow; Style: [fsBold]);\r\n DelphiColor_Identifier: TDelphiColor = (ForeColor: clBlack; BackColor: clWindow; Style: []);\r\n DelphiColor_PlainText: TDelphiColor = (ForeColor: clWindowText; BackColor: clWindow; Style: []);\r\n\r\ntype\r\n TJvSymbolColor = class(TPersistent)\r\n private\r\n FStyle: TFontStyles;\r\n FForeColor: TColor;\r\n FBackColor: TColor;\r\n public\r\n constructor Create;\r\n procedure SetColor(const ForeColor, BackColor: TColor; const Style: TFontStyles);\r\n procedure Assign(Source: TPersistent); override;\r\n published\r\n property Style: TFontStyles read FStyle write FStyle default [];\r\n property ForeColor: TColor read FForeColor write FForeColor {default clWindowText}; // disabled, otherwise the default values are ignored\r\n property BackColor: TColor read FBackColor write FBackColor {default clWindow};\r\n end;\r\n\r\n TJvColors = class(TPersistent)\r\n private\r\n FComment: TJvSymbolColor;\r\n FNumber: TJvSymbolColor;\r\n FString: TJvSymbolColor;\r\n FSymbol: TJvSymbolColor;\r\n FReserved: TJvSymbolColor;\r\n FIdentifier: TJvSymbolColor;\r\n FPreproc: TJvSymbolColor;\r\n FFunctionCall: TJvSymbolColor;\r\n FDeclaration: TJvSymbolColor;\r\n FStatement: TJvSymbolColor;\r\n FPlainText: TJvSymbolColor;\r\n public\r\n constructor Create;\r\n destructor Destroy; override;\r\n procedure Assign(Source: TPersistent); override;\r\n published\r\n property Comment: TJvSymbolColor read FComment write FComment;\r\n property Number: TJvSymbolColor read FNumber write FNumber;\r\n property Strings: TJvSymbolColor read FString write FString;\r\n property Symbol: TJvSymbolColor read FSymbol write FSymbol;\r\n property Reserved: TJvSymbolColor read FReserved write FReserved;\r\n property Identifier: TJvSymbolColor read FIdentifier write FIdentifier;\r\n property Preproc: TJvSymbolColor read FPreproc write FPreproc;\r\n property FunctionCall: TJvSymbolColor read FFunctionCall write FFunctionCall;\r\n property Declaration: TJvSymbolColor read FDeclaration write FDeclaration;\r\n property Statement: TJvSymbolColor read FStatement write FStatement;\r\n property PlainText: TJvSymbolColor read FPlainText write FPlainText;\r\n end;\r\n\r\n IJvHLEditor = interface\r\n ['{E165FE73-AE7E-40A8-AC9B-7FD20D55A15E}']\r\n function GetColors: TJvColors;\r\n procedure SetColors(const Value: TJvColors);\r\n function GetSyntaxHighlighting: Boolean;\r\n procedure SetSyntaxHighlighting(Value: Boolean);\r\n function GetHighlighter: TJvHighlighter;\r\n procedure SetHighlighter(const Value: TJvHighlighter);\r\n property Colors: TJvColors read GetColors write SetColors;\r\n property SyntaxHighlighting: Boolean read GetSyntaxHighlighting write SetSyntaxHighlighting;\r\n property Highlighter: TJvHighlighter read GetHighlighter write SetHighlighter;\r\n end;\r\n\r\nconst\r\n { Editor commands }\r\n { When add new commands, please add them into JvInterpreter_JvEditor.pas unit also ! }\r\n ecCharFirst = $00;\r\n {$IFDEF UNICODE}\r\n ecCharLast = $FFFF;\r\n ecCommandFirst = $10000;\r\n ecIntern = $400000; { use on internal updates }\r\n ecUser = $800000; { use this for descendants }\r\n {$ELSE}\r\n ecCharLast = $FF;\r\n ecCommandFirst = $100;\r\n ecIntern = $1000; { use on internal updates }\r\n ecUser = $8000; { use this for descendants }\r\n {$ENDIF UNICODE}\r\n\r\n {Cursor}\r\n ecLeft = ecCommandFirst + 1;\r\n ecUp = ecLeft + 1;\r\n ecRight = ecLeft + 2;\r\n ecDown = ecLeft + 3;\r\n {Cursor with select}\r\n ecSelLeft = ecCommandFirst + 9;\r\n ecSelUp = ecSelLeft + 1;\r\n ecSelRight = ecSelLeft + 2;\r\n ecSelDown = ecSelLeft + 3;\r\n {Cursor with column select}\r\n ecSelColumnLeft = ecIntern + 0;\r\n ecSelColumnUp = ecSelColumnLeft + 1;\r\n ecSelColumnRight = ecSelColumnLeft + 2;\r\n ecSelColumnDown = ecSelColumnLeft + 3;\r\n {Cursor On words [translated] }\r\n ecPrevWord = ecSelDown + 1;\r\n ecNextWord = ecPrevWord + 1;\r\n ecSelPrevWord = ecPrevWord + 2;\r\n ecSelNextWord = ecPrevWord + 3;\r\n ecSelWord = ecPrevWord + 4;\r\n\r\n ecWindowTop = ecSelWord + 1;\r\n ecWindowBottom = ecWindowTop + 1;\r\n ecPrevPage = ecWindowTop + 2;\r\n ecNextPage = ecWindowTop + 3;\r\n ecSelPrevPage = ecWindowTop + 4;\r\n ecSelNextPage = ecWindowTop + 5;\r\n\r\n ecBeginLine = ecSelNextPage + 1;\r\n ecEndLine = ecBeginLine + 1;\r\n ecBeginDoc = ecBeginLine + 2;\r\n ecEndDoc = ecBeginLine + 3;\r\n ecSelBeginLine = ecBeginLine + 4;\r\n ecSelEndLine = ecBeginLine + 5;\r\n ecSelBeginDoc = ecBeginLine + 6;\r\n ecSelEndDoc = ecBeginLine + 7;\r\n ecSelAll = ecBeginLine + 8;\r\n\r\n ecScrollLineUp = ecSelAll + 1;\r\n ecScrollLineDown = ecScrollLineUp + 1;\r\n\r\n ecInclusiveBlock = ecCommandFirst + 100;\r\n ecLineBlock = ecCommandFirst + 101;\r\n ecColumnBlock = ecCommandFirst + 102;\r\n ecNonInclusiveBlock = ecCommandFirst + 103;\r\n\r\n ecInsertPara = ecCommandFirst + 121;\r\n ecBackspace = ecInsertPara + 1;\r\n ecDelete = ecInsertPara + 2;\r\n ecChangeInsertMode = ecInsertPara + 3;\r\n ecTab = ecInsertPara + 4;\r\n ecBackTab = ecInsertPara + 5;\r\n ecIndent = ecInsertPara + 6;\r\n ecUnindent = ecInsertPara + 7;\r\n ecBackspaceWord = ecIntern + 10;\r\n\r\n ecDeleteSelected = ecInsertPara + 10;\r\n ecClipboardCopy = ecInsertPara + 11;\r\n ecClipboardCut = ecClipboardCopy + 1;\r\n ecClipboardPaste = ecClipboardCopy + 2;\r\n\r\n ecDeleteLine = ecClipboardPaste + 1;\r\n ecDeleteWord = ecDeleteLine + 1;\r\n\r\n ecToUpperCase = ecDeleteLine + 2;\r\n ecToLowerCase = ecToUpperCase + 1;\r\n ecChangeCase = ecToUpperCase + 2;\r\n\r\n ecUndo = ecChangeCase + 1;\r\n ecRedo = ecUndo + 1;\r\n ecBeginCompound = ecUndo + 2;\r\n ecEndCompound = ecUndo + 3;\r\n\r\n ecBeginUpdate = ecUndo + 4;\r\n ecEndUpdate = ecUndo + 5;\r\n\r\n ecSetBookmark0 = ecEndUpdate + 1;\r\n ecSetBookmark1 = ecSetBookmark0 + 1;\r\n ecSetBookmark2 = ecSetBookmark0 + 2;\r\n ecSetBookmark3 = ecSetBookmark0 + 3;\r\n ecSetBookmark4 = ecSetBookmark0 + 4;\r\n ecSetBookmark5 = ecSetBookmark0 + 5;\r\n ecSetBookmark6 = ecSetBookmark0 + 6;\r\n ecSetBookmark7 = ecSetBookmark0 + 7;\r\n ecSetBookmark8 = ecSetBookmark0 + 8;\r\n ecSetBookmark9 = ecSetBookmark0 + 9;\r\n\r\n ecGotoBookmark0 = ecSetBookmark9 + 1;\r\n ecGotoBookmark1 = ecGotoBookmark0 + 1;\r\n ecGotoBookmark2 = ecGotoBookmark0 + 2;\r\n ecGotoBookmark3 = ecGotoBookmark0 + 3;\r\n ecGotoBookmark4 = ecGotoBookmark0 + 4;\r\n ecGotoBookmark5 = ecGotoBookmark0 + 5;\r\n ecGotoBookmark6 = ecGotoBookmark0 + 6;\r\n ecGotoBookmark7 = ecGotoBookmark0 + 7;\r\n ecGotoBookmark8 = ecGotoBookmark0 + 8;\r\n ecGotoBookmark9 = ecGotoBookmark0 + 9;\r\n\r\n ecCompletionIdentifiers = ecGotoBookmark9 + 1;\r\n ecCompletionTemplates = ecCompletionIdentifiers + 1;\r\n\r\n ecRecordMacro = ecCompletionTemplates + 1;\r\n ecPlayMacro = ecRecordMacro + 1;\r\n ecBeginRecord = ecRecordMacro + 2;\r\n ecEndRecord = ecRecordMacro + 3;\r\n\r\n twoKeyCommand = High(TEditCommand);\r\n\r\nfunction KeyPressed(VK: Integer): Boolean;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvEditorCommon.pas $';\r\n Revision: '$Revision: 13415 $';\r\n Date: '$Date: 2012-09-10 11:51:54 +0200 (lun. 10 sept. 2012) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n Consts,\r\n {$IFDEF SUPPORTS_INLINE}\r\n Types,\r\n {$ENDIF SUPPORTS_INLINE}\r\n RTLConsts, Math, Clipbrd,\r\n JvJCLUtils, JvThemes, JvResources;\r\n\r\ntype\r\n TJvEditorCompletionList = class(TListBox)\r\n private\r\n FTimer: TTimer;\r\n YY: Integer;\r\n // HintWindow : THintWindow;\r\n procedure CMHintShow(var Msg: TMessage); message CM_HINTSHOW;\r\n procedure WMCancelMode(var Msg: TMessage); message WM_CancelMode;\r\n procedure OnTimer(Sender: TObject);\r\n protected\r\n procedure CreateParams(var Params: TCreateParams); override;\r\n procedure CreateWnd; override;\r\n procedure DestroyWnd; override;\r\n procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;\r\n procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;\r\n procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;\r\n procedure DrawItem(Index: Integer; Rect: TRect; State: TOwnerDrawState); override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n end;\r\n\r\nfunction KeyPressed(VK: Integer): Boolean;\r\nbegin\r\n Result := GetKeyState(VK) and $8000 = $8000;\r\nend;\r\n\r\n//=== { TJvUndoBuffer } ======================================================\r\n\r\nprocedure RedoNotImplemented;\r\nbegin\r\n raise EJvEditorError.CreateRes(@RsERedoNotYetImplemented);\r\nend;\r\n\r\nprocedure TJvUndoBuffer.Add(AUndo: TJvUndo);\r\nbegin\r\n if InUndo then\r\n Exit;\r\n ClearRedo;\r\n inherited Add(AUndo);\r\n FPtr := Count - 1;\r\nend;\r\n\r\nprocedure TJvUndoBuffer.Undo;\r\n\r\n function IsIntf(AInstance: TObject; IID: TGUID): Boolean; overload;\r\n begin\r\n Result := (AInstance <> nil) and (AInstance.GetInterfaceEntry(IID) <> nil);\r\n end;\r\n\r\n function IsIntf(AClass: TClass; IID: TGUID): Boolean; overload;\r\n begin\r\n Result := (AClass <> nil) and (AClass.GetInterfaceEntry(IID) <> nil);\r\n end;\r\n\r\nvar\r\n UndoClass: TClass;\r\n Compound: Integer;\r\n IsOnlyCaret: Boolean;\r\n Selection: TJvSelectionRec;\r\n WasModified: Boolean;\r\nbegin\r\n if InUndo then\r\n Exit;\r\n\r\n Selection := FJvEditor.FSelection;\r\n WasModified := FJvEditor.Modified;\r\n\r\n IsOnlyCaret := True;\r\n InUndo := True;\r\n try\r\n if LastUndo <> nil then\r\n begin\r\n Compound := 0;\r\n UndoClass := LastUndo.ClassType;\r\n while (LastUndo <> nil) and\r\n ((UndoClass = LastUndo.ClassType) or\r\n {(LastUndo is TJvDeleteTrailUndo) or\r\n (LastUndo is TJvReLineUndo) or}\r\n IsIntf(LastUndo, IJvUndoCompound) or\r\n (Compound > 0)) or\r\n {((UndoClass = TJvBackspaceUndo) and\r\n (LastUndo is TJvBackspaceUnindentUndo)) do}\r\n IsIntf(UndoClass, IJvBackspaceUndo) and\r\n IsIntf(LastUndo, IJvBackspaceUnindentUndo) do\r\n begin\r\n if LastUndo.ClassType = TJvBeginCompoundUndo then\r\n begin\r\n Dec(Compound);\r\n UndoClass := nil;\r\n end\r\n else\r\n if LastUndo.ClassType = TJvEndCompoundUndo then\r\n Inc(Compound);\r\n LastUndo.Undo;\r\n if LastUndo <> nil then\r\n begin\r\n LastUndo.RestoreSelection;\r\n FJvEditor.Modified := LastUndo.FModified;\r\n end;\r\n Dec(FPtr);\r\n {if (UndoClass = TJvDeleteTrailUndo) or\r\n (UndoClass = TJvReLineUndo) then}\r\n if IsIntf(UndoClass, IJvUndoCompound) then\r\n UndoClass := LastUndo.ClassType;\r\n if (UndoClass <> TJvCaretUndo) and\r\n (UndoClass <> TJvSelectUndo) and\r\n (UndoClass <> TJvUnselectUndo) then\r\n IsOnlyCaret := False;\r\n if not FJvEditor.GroupUndo then\r\n Break;\r\n end;\r\n if not FJvEditor.Modified then\r\n IsOnlyCaret := True;\r\n\r\n // paint selection\r\n if not CompareMem(@Selection, @FJvEditor.FSelection, SizeOf(TJvSelectionRec)) then\r\n FJvEditor.PaintSelection;\r\n\r\n FJvEditor.UpdateEditorView;\r\n if FJvEditor.FUpdateLock = 0 then\r\n if not IsOnlyCaret then\r\n FJvEditor.Changed\r\n else\r\n if WasModified then\r\n FJvEditor.StatusChanged;\r\n end;\r\n finally\r\n InUndo := False;\r\n end;\r\nend;\r\n\r\nprocedure TJvUndoBuffer.Redo;\r\nbegin\r\n if CanRedo then\r\n begin\r\n Inc(FPtr);\r\n LastUndo.Redo;\r\n end;\r\nend;\r\n\r\nprocedure TJvUndoBuffer.Clear;\r\nbegin\r\n while Count > 0 do\r\n begin\r\n TJvUndo(Items[0]).Free;\r\n inherited Delete(0);\r\n end;\r\n inherited Clear;\r\nend;\r\n\r\nprocedure TJvUndoBuffer.ClearRedo;\r\nbegin\r\n while (Count > 0) and (FPtr < Count - 1) do\r\n begin\r\n TJvUndo(Items[FPtr + 1]).Free;\r\n inherited Delete(FPtr + 1);\r\n end;\r\nend;\r\n\r\nprocedure TJvUndoBuffer.Delete;\r\nbegin\r\n if Count > 0 then\r\n begin\r\n TJvUndo(Items[Count - 1]).Free;\r\n inherited Delete(Count - 1);\r\n end;\r\nend;\r\n\r\nfunction TJvUndoBuffer.LastUndo: TJvUndo;\r\nbegin\r\n if (FPtr >= 0) and (Count > 0) then\r\n Result := TJvUndo(Items[FPtr])\r\n else\r\n Result := nil;\r\nend;\r\n\r\nfunction TJvUndoBuffer.IsNewGroup(AUndo: TJvUndo): Boolean;\r\nbegin\r\n Result := (LastUndo = nil) or (LastUndo.ClassType <> AUndo.ClassType)\r\nend;\r\n\r\nfunction TJvUndoBuffer.IsCaretGroup: Boolean;\r\nbegin\r\n Result := (LastUndo <> nil) and (LastUndo.ClassType = TJvCaretUndo);\r\nend;\r\n\r\nfunction TJvUndoBuffer.CanUndo: Boolean;\r\nbegin\r\n Result := (LastUndo <> nil);\r\nend;\r\n\r\nfunction TJvUndoBuffer.CanRedo: Boolean;\r\nbegin\r\n{\r\n Result := FPtr < Count;\r\n}\r\n Result := False;\r\n ClearRedo;\r\nend;\r\n\r\n//=== { TJvUndo } ============================================================\r\n\r\nconstructor TJvUndo.Create(AJvEditor: TJvCustomEditorBase);\r\nbegin\r\n inherited Create;\r\n FJvEditor := AJvEditor;\r\n FModified := FJvEditor.FModified;\r\n UndoBuffer.Add(Self);\r\n FSelection := nil;\r\nend;\r\n\r\ndestructor TJvUndo.Destroy;\r\nbegin\r\n if Assigned(FSelection) then\r\n Dispose(FSelection);\r\n // (rom) added inherited Destroy\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvUndo.Redo;\r\nbegin\r\n RedoNotImplemented;\r\nend;\r\n\r\nprocedure TJvUndo.RestoreSelection;\r\nbegin\r\n if Assigned(FSelection) then\r\n begin\r\n FJvEditor.FSelection := FSelection^;\r\n FJvEditor.SetSelUpdateRegion(FSelection^.SelBegY, FSelection^.SelEndY);\r\n end;\r\nend;\r\n\r\nprocedure TJvUndo.SaveSelection;\r\nbegin\r\n if not Assigned(FSelection) then\r\n New(FSelection);\r\n FSelection^ := FJvEditor.FSelection;\r\nend;\r\n\r\nfunction TJvUndo.UndoBuffer: TJvUndoBuffer;\r\nbegin\r\n if FJvEditor <> nil then\r\n Result := FJvEditor.FUndoBuffer\r\n else\r\n Result := nil;\r\nend;\r\n\r\n//=== { TJvCaretUndo } =======================================================\r\n\r\nconstructor TJvCaretUndo.Create(AJvEditor: TJvCustomEditorBase;\r\n ACaretX, ACaretY: Integer);\r\nbegin\r\n inherited Create(AJvEditor);\r\n FCaretX := ACaretX;\r\n FCaretY := ACaretY;\r\nend;\r\n\r\nprocedure TJvCaretUndo.Undo;\r\nbegin\r\n with UndoBuffer do\r\n begin\r\n Dec(FPtr);\r\n while JvEditor.FGroupUndo and (FPtr >= 0) and not IsNewGroup(Self) do\r\n Dec(FPtr);\r\n Inc(FPtr);\r\n with TJvCaretUndo(Items[FPtr]) do\r\n JvEditor.SetCaretInternal(FCaretX, FCaretY);\r\n end;\r\nend;\r\n\r\n//=== { TJvSelectUndo } ======================================================\r\n\r\nconstructor TJvSelectUndo.Create(AJvEditor: TJvCustomEditorBase;\r\n ACaretX, ACaretY: Integer);\r\nbegin\r\n inherited Create(AJvEditor, ACaretX, ACaretY);\r\n SaveSelection;\r\nend;\r\n\r\nprocedure TJvSelectUndo.Undo;\r\nvar\r\n LastSel: TJvSelectUndo;\r\n LastCaret: TJvCaretUndo;\r\nbegin\r\n LastSel := Self;\r\n LastCaret := nil;\r\n { Undo TJvSelectUndo and TJvCaretUndo in one action. This prevents\r\n unnecessary caret movement with scolling. }\r\n with UndoBuffer do\r\n begin\r\n while (FPtr >= 0) and ((not IsNewGroup(Self)) or (IsCaretGroup)) do\r\n begin\r\n if LastUndo.ClassType = TJvCaretUndo then\r\n LastCaret := TJvCaretUndo(LastUndo)\r\n else\r\n LastSel := TJvSelectUndo(LastUndo);\r\n Dec(FPtr);\r\n if not FJvEditor.FGroupUndo then\r\n Break;\r\n end;\r\n Inc(FPtr);\r\n end;\r\n\r\n LastSel.RestoreSelection;\r\n\r\n if LastCaret <> nil then\r\n LastCaret.Undo\r\n else\r\n FJvEditor.SetCaretInternal(LastSel.FCaretX, LastSel.FCaretY);\r\nend;\r\n\r\n//=== { TJvBeginCompoundUndo } ===============================================\r\n\r\nprocedure TJvBeginCompoundUndo.Undo;\r\nbegin\r\n { nothing }\r\nend;\r\n\r\n//=== { TJvControlScrollBar95 } ==============================================\r\n\r\nconst\r\n SBKIND: array [TScrollBarKind] of Integer = (SB_HORZ, SB_VERT);\r\n\r\nconstructor TJvControlScrollBar95.Create;\r\nbegin\r\n inherited Create;\r\n FPage := 1;\r\n FSmallChange := 1;\r\n FLargeChange := 1;\r\nend;\r\n\r\nprocedure TJvControlScrollBar95.SetParams(AMin, AMax, APosition, APage: Integer);\r\nvar\r\n ScrollInfo: TScrollInfo;\r\nbegin\r\n if AMax < AMin then\r\n raise EInvalidOperation.CreateRes(@SScrollBarRange);\r\n if APosition < AMin then\r\n APosition := AMin;\r\n if APosition > AMax then\r\n APosition := AMax;\r\n if Handle > 0 then\r\n begin\r\n with ScrollInfo do\r\n begin\r\n cbSize := SizeOf(TScrollInfo);\r\n fMask := SIF_DISABLENOSCROLL;\r\n if (AMin >= 0) or (AMax >= 0) then\r\n fMask := fMask or SIF_RANGE;\r\n if APosition >= 0 then\r\n fMask := fMask or SIF_POS;\r\n if APage >= 0 then\r\n fMask := fMask or SIF_PAGE;\r\n nPos := APosition;\r\n nMin := AMin;\r\n nMax := AMax;\r\n nPage := APage;\r\n end;\r\n SetScrollInfo(\r\n Handle, // handle of window with scroll bar\r\n SBKIND[Kind], // scroll bar flag\r\n ScrollInfo, // pointer to structure with scroll parameters\r\n True); // redraw flag\r\n end;\r\nend;\r\n\r\nprocedure TJvControlScrollBar95.SetParam(Index, Value: Integer);\r\nbegin\r\n case Index of\r\n 0:\r\n FMin := Value;\r\n 1:\r\n FMax := Value;\r\n 2:\r\n FPosition := Value;\r\n 3:\r\n FPage := Value;\r\n end;\r\n if FMax < FMin then\r\n raise EInvalidOperation.CreateRes(@SScrollBarRange);\r\n if FPosition < FMin then\r\n FPosition := FMin;\r\n if FPosition > FMax then\r\n FPosition := FMax;\r\n SetParams(FMin, FMax, FPosition, FPage);\r\nend;\r\n\r\nprocedure TJvControlScrollBar95.DoScroll(var Msg: TWMScroll);\r\nvar\r\n ScrollPos: Integer;\r\n NewPos: Longint;\r\n ScrollInfo: TScrollInfo;\r\nbegin\r\n with Msg do\r\n begin\r\n NewPos := FPosition;\r\n case TScrollCode(ScrollCode) of\r\n scLineUp:\r\n Dec(NewPos, FSmallChange);\r\n scLineDown:\r\n Inc(NewPos, FSmallChange);\r\n scPageUp:\r\n Dec(NewPos, FLargeChange);\r\n scPageDown:\r\n Inc(NewPos, FLargeChange);\r\n scPosition, scTrack:\r\n with ScrollInfo do\r\n begin\r\n cbSize := SizeOf(ScrollInfo);\r\n fMask := SIF_ALL;\r\n GetScrollInfo(Handle, SBKIND[Kind], ScrollInfo);\r\n NewPos := nTrackPos;\r\n end;\r\n scTop:\r\n NewPos := FMin;\r\n scBottom:\r\n NewPos := FMax;\r\n end;\r\n if NewPos < FMin then\r\n NewPos := FMin;\r\n if NewPos > FMax then\r\n NewPos := FMax;\r\n ScrollPos := NewPos;\r\n Scroll(TScrollCode(ScrollCode), ScrollPos);\r\n end;\r\n Position := ScrollPos;\r\nend;\r\n\r\nprocedure TJvControlScrollBar95.Scroll(ScrollCode: TScrollCode; var ScrollPos: Integer);\r\nbegin\r\n if Assigned(FOnScroll) then\r\n FOnScroll(Self, ScrollCode, ScrollPos);\r\nend;\r\n\r\n//=== { TJvEditKey } =========================================================\r\n\r\nconstructor TJvEditKey.Create(const ACommand: TEditCommand; const AKey1: Word;\r\n const AShift1: TShiftState);\r\nbegin\r\n inherited Create;\r\n Key1 := AKey1;\r\n Shift1 := AShift1;\r\n Command := ACommand;\r\nend;\r\n\r\nconstructor TJvEditKey.Create2(const ACommand: TEditCommand; const AKey1: Word;\r\n const AShift1: TShiftState; const AKey2: Word; const AShift2: TShiftState);\r\nbegin\r\n inherited Create;\r\n Key1 := AKey1;\r\n Shift1 := AShift1;\r\n Key2 := AKey2;\r\n Shift2 := AShift2;\r\n Command := ACommand;\r\nend;\r\n\r\n//=== { TJvKeyboard } ========================================================\r\n\r\nconstructor TJvKeyboard.Create;\r\nbegin\r\n inherited Create;\r\n FList := TObjectList.Create;\r\nend;\r\n\r\ndestructor TJvKeyboard.Destroy;\r\nbegin\r\n FList.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvKeyboard.Assign(Source: TPersistent);\r\nvar\r\n I: Integer;\r\nbegin\r\n if Source is TJvKeyboard then\r\n begin\r\n Clear;\r\n for I := 0 to TJvKeyboard(Source).FList.Count - 1 do\r\n with TJvEditKey(TJvKeyboard(Source).FList[I]) do\r\n Add2(Command, Key1, Shift1, Key2, Shift2);\r\n end\r\n else\r\n inherited Assign(Source);\r\nend;\r\n\r\nprocedure TJvKeyboard.Add(const ACommand: TEditCommand; const AKey1: Word;\r\n const AShift1: TShiftState);\r\nbegin\r\n FList.Add(TJvEditKey.Create(ACommand, AKey1, AShift1));\r\nend;\r\n\r\nprocedure TJvKeyboard.Add2(const ACommand: TEditCommand; const AKey1: Word;\r\n const AShift1: TShiftState; const AKey2: Word; const AShift2: TShiftState);\r\nbegin\r\n FList.Add(TJvEditKey.Create2(ACommand, AKey1, AShift1, AKey2, AShift2));\r\nend;\r\n\r\nprocedure TJvKeyboard.Add2Ctrl(const ACommand: TEditCommand;\r\n const AKey1: Word; const AShift1: TShiftState; const AKey2: Word);\r\nbegin\r\n Add2(ACommand, AKey1, AShift1, AKey2, [ssCtrl]);\r\n Add2(ACommand, AKey1, AShift1, AKey2, []);\r\nend;\r\n\r\nprocedure TJvKeyboard.Remove(const AKey1: Word; const AShift1: TShiftState);\r\nbegin\r\n Remove2(AKey1, AShift1, 0, []);\r\nend;\r\n\r\nprocedure TJvKeyboard.Remove2(const AKey1: Word; const AShift1: TShiftState;\r\n const AKey2: Word; const AShift2: TShiftState);\r\nvar\r\n I: Integer;\r\n ek: TJvEditKey;\r\nbegin\r\n for I := FList.Count - 1 downto 0 do\r\n begin\r\n ek := TJvEditKey(FList[I]);\r\n if (ek.Key1 = AKey1) and (ek.Shift1 = AShift1) and\r\n (ek.Key2 = AKey2) and (ek.Shift2 = AShift2) then\r\n FList.Delete(I);\r\n end;\r\nend;\r\n\r\nprocedure TJvKeyboard.RemoveCtrl(const ACommand: TEditCommand);\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := FList.Count - 1 downto 0 do\r\n if TJvEditKey(FList[I]).Command = ACommand then\r\n FList.Delete(I);\r\nend;\r\n\r\nprocedure TJvKeyboard.Clear;\r\nbegin\r\n FList.Clear;\r\nend;\r\n\r\nfunction TJvKeyboard.Command(const AKey: Word; const AShift: TShiftState): TEditCommand;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := 0;\r\n for I := 0 to FList.Count - 1 do\r\n with TJvEditKey(FList[I]) do\r\n if (Key1 = AKey) and (Shift1 = AShift) then\r\n begin\r\n if Key2 = 0 then\r\n Result := Command\r\n else\r\n Result := twoKeyCommand;\r\n Exit;\r\n end;\r\nend;\r\n\r\nfunction TJvKeyboard.Command2(const AKey1: Word; const AShift1: TShiftState;\r\n const AKey2: Word; const AShift2: TShiftState): TEditCommand;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := 0;\r\n for I := 0 to FList.Count - 1 do\r\n with TJvEditKey(FList[I]) do\r\n if (Key1 = AKey1) and (Shift1 = AShift1) and\r\n (Key2 = AKey2) and (Shift2 = AShift2) then\r\n begin\r\n Result := Command;\r\n Exit;\r\n end;\r\n // no command found: trigger event\r\n if Assigned(FOnCommand2) then\r\n FOnCommand2(Self, AKey1, AShift1, AKey2, AShift2, Result);\r\nend;\r\n\r\nprocedure TJvKeyboard.SetDefLayout;\r\nbegin\r\n Clear;\r\n Add(ecLeft, VK_LEFT, []);\r\n Add(ecRight, VK_RIGHT, []);\r\n Add(ecUp, VK_UP, []);\r\n Add(ecDown, VK_DOWN, []);\r\n Add(ecSelLeft, VK_LEFT, [ssShift]);\r\n Add(ecSelRight, VK_RIGHT, [ssShift]);\r\n Add(ecSelUp, VK_UP, [ssShift]);\r\n Add(ecSelDown, VK_DOWN, [ssShift]);\r\n Add(ecSelColumnLeft, VK_LEFT, [ssShift, ssAlt]);\r\n Add(ecSelColumnRight, VK_RIGHT, [ssShift, ssAlt]);\r\n Add(ecSelColumnUp, VK_UP, [ssShift, ssAlt]);\r\n Add(ecSelColumnDown, VK_DOWN, [ssShift, ssAlt]);\r\n\r\n Add(ecBeginLine, VK_HOME, []);\r\n Add(ecSelBeginLine, VK_HOME, [ssShift]);\r\n Add(ecBeginDoc, VK_HOME, [ssCtrl]);\r\n Add(ecSelBeginDoc, VK_HOME, [ssCtrl, ssShift]);\r\n Add(ecEndLine, VK_END, []);\r\n Add(ecSelEndLine, VK_END, [ssShift]);\r\n Add(ecEndDoc, VK_END, [ssCtrl]);\r\n Add(ecSelEndDoc, VK_END, [ssCtrl, ssShift]);\r\n Add(ecPrevWord, VK_LEFT, [ssCtrl]);\r\n Add(ecNextWord, VK_RIGHT, [ssCtrl]);\r\n Add(ecSelPrevWord, VK_LEFT, [ssCtrl, ssShift]);\r\n Add(ecSelNextWord, VK_RIGHT, [ssCtrl, ssShift]);\r\n Add(ecSelAll, Ord('A'), [ssCtrl]);\r\n\r\n Add(ecWindowTop, VK_PRIOR, [ssCtrl]);\r\n Add(ecWindowBottom, VK_NEXT, [ssCtrl]);\r\n Add(ecPrevPage, VK_PRIOR, []);\r\n Add(ecNextPage, VK_NEXT, []);\r\n Add(ecSelPrevPage, VK_PRIOR, [ssShift]);\r\n Add(ecSelNextPage, VK_NEXT, [ssShift]);\r\n Add(ecScrollLineUp, VK_UP, [ssCtrl]);\r\n Add(ecScrollLineDown, VK_DOWN, [ssCtrl]);\r\n\r\n Add(ecChangeInsertMode, VK_INSERT, []);\r\n\r\n Add(ecInsertPara, VK_RETURN, []);\r\n Add(ecBackspace, VK_BACK, []);\r\n Add(ecBackspace, VK_BACK, [ssShift]);\r\n Add(ecBackspaceWord, VK_BACK, [ssCtrl]);\r\n Add(ecDelete, VK_DELETE, []);\r\n Add(ecTab, VK_TAB, []);\r\n Add(ecBackTab, VK_TAB, [ssShift]);\r\n Add(ecDeleteSelected, VK_DELETE, [ssCtrl]);\r\n Add(ecClipboardCopy, VK_INSERT, [ssCtrl]);\r\n Add(ecClipboardCut, VK_DELETE, [ssShift]);\r\n Add(ecClipboardPaste, VK_INSERT, [ssShift]);\r\n\r\n Add(ecClipboardCopy, Ord('C'), [ssCtrl]);\r\n Add(ecClipboardCut, Ord('X'), [ssCtrl]);\r\n Add(ecClipboardPaste, Ord('V'), [ssCtrl]);\r\n\r\n Add(ecSetBookmark0, Ord('0'), [ssCtrl, ssShift]);\r\n Add(ecSetBookmark1, Ord('1'), [ssCtrl, ssShift]);\r\n Add(ecSetBookmark2, Ord('2'), [ssCtrl, ssShift]);\r\n Add(ecSetBookmark3, Ord('3'), [ssCtrl, ssShift]);\r\n Add(ecSetBookmark4, Ord('4'), [ssCtrl, ssShift]);\r\n Add(ecSetBookmark5, Ord('5'), [ssCtrl, ssShift]);\r\n Add(ecSetBookmark6, Ord('6'), [ssCtrl, ssShift]);\r\n Add(ecSetBookmark7, Ord('7'), [ssCtrl, ssShift]);\r\n Add(ecSetBookmark8, Ord('8'), [ssCtrl, ssShift]);\r\n Add(ecSetBookmark9, Ord('9'), [ssCtrl, ssShift]);\r\n\r\n Add(ecGotoBookmark0, Ord('0'), [ssCtrl]);\r\n Add(ecGotoBookmark1, Ord('1'), [ssCtrl]);\r\n Add(ecGotoBookmark2, Ord('2'), [ssCtrl]);\r\n Add(ecGotoBookmark3, Ord('3'), [ssCtrl]);\r\n Add(ecGotoBookmark4, Ord('4'), [ssCtrl]);\r\n Add(ecGotoBookmark5, Ord('5'), [ssCtrl]);\r\n Add(ecGotoBookmark6, Ord('6'), [ssCtrl]);\r\n Add(ecGotoBookmark7, Ord('7'), [ssCtrl]);\r\n Add(ecGotoBookmark8, Ord('8'), [ssCtrl]);\r\n Add(ecGotoBookmark9, Ord('9'), [ssCtrl]);\r\n\r\n Add2Ctrl(ecSetBookmark0, Ord('K'), [ssCtrl], Ord('0'));\r\n Add2Ctrl(ecSetBookmark1, Ord('K'), [ssCtrl], Ord('1'));\r\n Add2Ctrl(ecSetBookmark2, Ord('K'), [ssCtrl], Ord('2'));\r\n Add2Ctrl(ecSetBookmark3, Ord('K'), [ssCtrl], Ord('3'));\r\n Add2Ctrl(ecSetBookmark4, Ord('K'), [ssCtrl], Ord('4'));\r\n Add2Ctrl(ecSetBookmark5, Ord('K'), [ssCtrl], Ord('5'));\r\n Add2Ctrl(ecSetBookmark6, Ord('K'), [ssCtrl], Ord('6'));\r\n Add2Ctrl(ecSetBookmark7, Ord('K'), [ssCtrl], Ord('7'));\r\n Add2Ctrl(ecSetBookmark8, Ord('K'), [ssCtrl], Ord('8'));\r\n Add2Ctrl(ecSetBookmark9, Ord('K'), [ssCtrl], Ord('9'));\r\n\r\n Add2Ctrl(ecGotoBookmark0, Ord('Q'), [ssCtrl], Ord('0'));\r\n Add2Ctrl(ecGotoBookmark1, Ord('Q'), [ssCtrl], Ord('1'));\r\n Add2Ctrl(ecGotoBookmark2, Ord('Q'), [ssCtrl], Ord('2'));\r\n Add2Ctrl(ecGotoBookmark3, Ord('Q'), [ssCtrl], Ord('3'));\r\n Add2Ctrl(ecGotoBookmark4, Ord('Q'), [ssCtrl], Ord('4'));\r\n Add2Ctrl(ecGotoBookmark5, Ord('Q'), [ssCtrl], Ord('5'));\r\n Add2Ctrl(ecGotoBookmark6, Ord('Q'), [ssCtrl], Ord('6'));\r\n Add2Ctrl(ecGotoBookmark7, Ord('Q'), [ssCtrl], Ord('7'));\r\n Add2Ctrl(ecGotoBookmark8, Ord('Q'), [ssCtrl], Ord('8'));\r\n Add2Ctrl(ecGotoBookmark9, Ord('Q'), [ssCtrl], Ord('9'));\r\n\r\n Add2Ctrl(ecNonInclusiveBlock, Ord('O'), [ssCtrl], Ord('K'));\r\n Add2Ctrl(ecInclusiveBlock, Ord('O'), [ssCtrl], Ord('I'));\r\n Add2Ctrl(ecColumnBlock, Ord('O'), [ssCtrl], Ord('C'));\r\n Add2Ctrl(ecLineBlock, Ord('O'), [ssCtrl], Ord('L'));\r\n\r\n Add(ecUndo, Ord('Z'), [ssCtrl]);\r\n Add(ecUndo, VK_BACK, [ssAlt]);\r\n// Add(ecRedo, Ord('Z'), [ssShift, ssCtrl]);\r\n\r\n Add(ecCompletionIdentifiers, VK_SPACE, [ssCtrl]);\r\n Add(ecCompletionTemplates, Ord('J'), [ssCtrl]);\r\n\r\n { cursor movement - default and classic }\r\n Add2Ctrl(ecEndDoc, Ord('Q'), [ssCtrl], Ord('C'));\r\n Add2Ctrl(ecEndLine, Ord('Q'), [ssCtrl], Ord('D'));\r\n Add2Ctrl(ecWindowTop, Ord('Q'), [ssCtrl], Ord('E'));\r\n Add2Ctrl(ecBeginDoc, Ord('Q'), [ssCtrl], Ord('R'));\r\n Add2Ctrl(ecBeginLine, Ord('Q'), [ssCtrl], Ord('S'));\r\n Add2Ctrl(ecWindowTop, Ord('Q'), [ssCtrl], Ord('T'));\r\n Add2Ctrl(ecWindowBottom, Ord('Q'), [ssCtrl], Ord('U'));\r\n\r\n Add(ecDeleteWord, Ord('T'), [ssCtrl]);\r\n Add(ecInsertPara, Ord('N'), [ssCtrl]);\r\n Add(ecDeleteLine, Ord('Y'), [ssCtrl]);\r\n\r\n Add2Ctrl(ecSelWord, Ord('K'), [ssCtrl], Ord('T'));\r\n Add2Ctrl(ecToUpperCase, Ord('K'), [ssCtrl], Ord('O'));\r\n Add2Ctrl(ecToLowerCase, Ord('K'), [ssCtrl], Ord('N'));\r\n Add2Ctrl(ecChangeCase, Ord('O'), [ssCtrl], Ord('U'));\r\n Add2Ctrl(ecIndent, Ord('K'), [ssCtrl], Ord('I'));\r\n Add2Ctrl(ecUnindent, Ord('K'), [ssCtrl], Ord('U'));\r\n Add(ecIndent, Ord('I'), [ssShift, ssCtrl]);\r\n Add(ecUnindent, Ord('U'), [ssShift, ssCtrl]);\r\n\r\n Add(ecRecordMacro, Ord('R'), [ssCtrl, ssShift]);\r\n Add(ecPlayMacro, Ord('P'), [ssCtrl, ssShift]);\r\nend;\r\n\r\n//=== { TJvEditorClient } ====================================================\r\n\r\nfunction TJvEditorClient.GetCanvas: TJvUnicodeCanvas;\r\nbegin\r\n Result := TJvUnicodeCanvas(FJvEditor.Canvas);\r\nend;\r\n\r\nfunction TJvEditorClient.Left: Integer;\r\nbegin\r\n Result := FJvEditor.GutterWidth + 2;\r\nend;\r\n\r\nfunction TJvEditorClient.Height: Integer;\r\nbegin\r\n Result := FJvEditor.ClientHeight;\r\nend;\r\n\r\nfunction TJvEditorClient.Width: Integer;\r\nbegin\r\n Result := Max(FJvEditor.ClientWidth - Left, 0);\r\nend;\r\n\r\nfunction TJvEditorClient.ClientWidth: Integer;\r\nbegin\r\n Result := Width;\r\nend;\r\n\r\nfunction TJvEditorClient.ClientHeight: Integer;\r\nbegin\r\n Result := Height;\r\nend;\r\n\r\nfunction TJvEditorClient.ClientRect: TRect;\r\nbegin\r\n Result := Bounds(Left, Top, Width, Height);\r\nend;\r\n\r\nfunction TJvEditorClient.BoundsRect: TRect;\r\nbegin\r\n Result := Bounds(0, 0, Width, Height);\r\nend;\r\n\r\n//=== { TJvGutter } ==========================================================\r\n\r\nprocedure TJvGutter.Invalidate;\r\n{var\r\n R : TRect;}\r\nbegin\r\n // Owner.Invalidate;\r\n // R := Bounds(0, 0, FJvEditor.GutterWidth, FJvEditor.Height);\r\n // InvalidateRect(FJvEditor.Handle, @R, False);\r\n Paint;\r\nend;\r\n\r\nprocedure TJvGutter.Paint;\r\nbegin\r\n with FJvEditor, Canvas do\r\n begin\r\n Brush.Style := bsSolid;\r\n Brush.Color := FGutterColor;\r\n FillRect(Bounds(0, FEditorClient.Top, GutterWidth, FEditorClient.Height));\r\n Pen.Width := 1;\r\n Pen.Color := Color;\r\n MoveTo(GutterWidth - 2, FEditorClient.Top);\r\n LineTo(GutterWidth - 2, FEditorClient.Top + FEditorClient.Height);\r\n Pen.Width := 2;\r\n MoveTo(GutterWidth + 1, FEditorClient.Top);\r\n LineTo(GutterWidth + 1, FEditorClient.Top + FEditorClient.Height);\r\n Pen.Width := 1;\r\n Pen.Color := clGray;\r\n MoveTo(GutterWidth - 1, FEditorClient.Top);\r\n LineTo(GutterWidth - 1, FEditorClient.Top + FEditorClient.Height);\r\n\r\n GutterPaint(Canvas);\r\n end;\r\nend;\r\n\r\n//=== { TJvLineInformation } =================================================\r\n\r\nconstructor TJvLineInformation.Create(AEditor: TJvCustomEditorBase; ALine: Integer);\r\nbegin\r\n inherited Create;\r\n FEditor := AEditor;\r\n FLine := ALine;\r\n FSelectStyle := lssUnselected;\r\nend;\r\n\r\ndestructor TJvLineInformation.Destroy;\r\nbegin\r\n if not (csDestroying in Editor.ComponentState) then\r\n begin\r\n Editor.FLineInformations.FList.Extract(Self);\r\n RepaintLine(Line);\r\n end;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvLineInformation.CheckEmpty;\r\nbegin\r\n if (Data = nil) and (SelectStyle = lssUnselected) then\r\n Free;\r\nend;\r\n\r\nprocedure TJvLineInformation.RepaintLine(LineNum: Integer);\r\nbegin\r\n if Assigned(Editor) then\r\n if (LineNum >= 0) and (LineNum < Editor.LineCount) then\r\n Editor.PaintLine(Line, 0, Editor.VisibleColCount);\r\nend;\r\n\r\nprocedure TJvLineInformation.SetLine(Value: Integer);\r\nvar\r\n LastLine: Integer;\r\nbegin\r\n if Value <> FLine then\r\n begin\r\n LastLine := FLine;\r\n FLine := Value;\r\n RepaintLine(LastLine);\r\n RepaintLine(Line);\r\n CheckEmpty;\r\n end;\r\nend;\r\n\r\nprocedure TJvLineInformation.SetSelectStyle(const Value: TJvLineSelectStyle);\r\nbegin\r\n if Value <> FSelectStyle then\r\n begin\r\n FSelectStyle := Value;\r\n RepaintLine(Line);\r\n CheckEmpty;\r\n end;\r\nend;\r\n\r\n//=== { TJvLineInformationList } =============================================\r\n\r\nconstructor TJvLineInformationList.Create(AEditor: TJvCustomEditorBase);\r\nbegin\r\n inherited Create;\r\n FEditor := AEditor;\r\n FList := TObjectList.Create;\r\n FDebugColor := clNavy;\r\n FDebugTextColor := clWhite;\r\n FBreakpointColor := clRed;\r\n FBreakpointTextColor := clWhite;\r\n FErrorPointColor := clMaroon;\r\n FErrorPointTextColor := clWhite;\r\nend;\r\n\r\ndestructor TJvLineInformationList.Destroy;\r\nbegin\r\n FList.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvLineInformationList.Clear;\r\nbegin\r\n FList.Clear;\r\nend;\r\n\r\nprocedure TJvLineInformationList.DeleteLine(Line: Integer);\r\nvar\r\n I: Integer;\r\nbegin\r\n Dec(Line);\r\n for I := Count - 1 downto 0 do\r\n if Items[I].Line = Line then\r\n FList.Delete(I)\r\n else\r\n if Items[I].Line > Line then\r\n Items[I].Line := Items[I].Line - 1;\r\nend;\r\n\r\nprocedure TJvLineInformationList.InsertLine(Line: Integer);\r\nvar\r\n I: Integer;\r\nbegin\r\n Dec(Line);\r\n for I := 0 to Count - 1 do\r\n if Items[I].Line >= Line then\r\n Items[I].Line := Items[I].Line + 1;\r\nend;\r\n\r\nfunction TJvLineInformationList.GetCount: Integer;\r\nbegin\r\n Result := FList.Count;\r\nend;\r\n\r\nfunction TJvLineInformationList.GetData(Index: Integer): Pointer;\r\nvar\r\n Item: TJvLineInformation;\r\nbegin\r\n Item := Lines[Index];\r\n if Item <> nil then\r\n Result := Item.Data\r\n else\r\n Result := nil;\r\nend;\r\n\r\nfunction TJvLineInformationList.GetItems(Index: Integer): TJvLineInformation;\r\nbegin\r\n Result := TJvLineInformation(FList[Index]);\r\nend;\r\n\r\nfunction TJvLineInformationList.GetLineCount: Integer;\r\nbegin\r\n Result := Editor.LineCount;\r\nend;\r\n\r\nfunction TJvLineInformationList.GetLines(Index: Integer): TJvLineInformation;\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := 0 to Count - 1 do\r\n begin\r\n Result := TJvLineInformation(FList[I]);\r\n if Result.Line = Index then\r\n Exit;\r\n end;\r\n Result := nil;\r\nend;\r\n\r\nfunction TJvLineInformationList.GetSelectStyle(Index: Integer): TJvLineSelectStyle;\r\nvar\r\n Item: TJvLineInformation;\r\nbegin\r\n Item := Lines[Index];\r\n if Item <> nil then\r\n Result := Item.SelectStyle\r\n else\r\n Result := lssUnselected;\r\nend;\r\n\r\nprocedure TJvLineInformationList.SetData(Index: Integer; Value: Pointer);\r\nbegin\r\n CreateLineInfo(Index).Data := Value;\r\nend;\r\n\r\nprocedure TJvLineInformationList.SetSelectStyle(Index: Integer;\r\n const Value: TJvLineSelectStyle);\r\nbegin\r\n CreateLineInfo(Index).SelectStyle := Value;\r\nend;\r\n\r\nfunction TJvLineInformationList.CreateLineInfo(Index: Integer): TJvLineInformation;\r\nvar\r\n I: Integer;\r\nbegin\r\n if Index < 0 then\r\n raise EListError.CreateResFmt(@SListIndexError, [LineCount]);\r\n for I := 0 to Count - 1 do\r\n begin\r\n Result := TJvLineInformation(FList[I]);\r\n if Result.Line = Index then\r\n Exit;\r\n end;\r\n Result := TJvLineInformation.Create(FEditor, Index);\r\n FList.Add(Result);\r\nend;\r\n\r\nprocedure TJvLineInformationList.SetBreakpointColor(const Value: TColor);\r\nbegin\r\n if Value <> FBreakpointColor then\r\n begin\r\n FBreakpointColor := Value;\r\n if Count > 0 then\r\n Editor.Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvLineInformationList.SetBreakpointTextColor(const Value: TColor);\r\nbegin\r\n if Value <> FBreakpointTextColor then\r\n begin\r\n FBreakpointTextColor := Value;\r\n if Count > 0 then\r\n Editor.Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvLineInformationList.SetDebugColor(const Value: TColor);\r\nbegin\r\n if Value <> FDebugColor then\r\n begin\r\n FDebugColor := Value;\r\n if Count > 0 then\r\n Editor.Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvLineInformationList.SetDebugTextColor(const Value: TColor);\r\nbegin\r\n if Value <> FDebugTextColor then\r\n begin\r\n FDebugTextColor := Value;\r\n if Count > 0 then\r\n Editor.Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvLineInformationList.SetErrorPointColor(const Value: TColor);\r\nbegin\r\n if Value <> FErrorPointColor then\r\n begin\r\n FErrorPointColor := Value;\r\n if Count > 0 then\r\n Editor.Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvLineInformationList.SetErrorPointTextColor(const Value: TColor);\r\nbegin\r\n if Value <> FErrorPointTextColor then\r\n begin\r\n FErrorPointTextColor := Value;\r\n if Count > 0 then\r\n Editor.Invalidate;\r\n end;\r\nend;\r\n\r\n//=== { TJvBracketHighlighting } =============================================\r\n\r\nconstructor TJvBracketHighlighting.Create;\r\nbegin\r\n inherited Create;\r\n FStart.Left := -1;\r\n FStop.Left := -1;\r\n\r\n FWordPairs := TStringList.Create;\r\n FCommentPairs := TStringList.Create;\r\n FCaseSensitiveWordPairs := True;\r\n FStringChar := '''';\r\n FStringEscape := '''''';\r\n\r\n FActive := False;\r\n FBorderColor := clSilver;\r\n FColor := clNone;\r\n FFontColor := clNone;\r\nend;\r\n\r\ndestructor TJvBracketHighlighting.Destroy;\r\nbegin\r\n FCommentPairs.Free;\r\n FWordPairs.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvBracketHighlighting.Assign(Source: TPersistent);\r\nbegin\r\n if Source is TJvBracketHighlighting then\r\n begin\r\n with TJvBracketHighlighting(Source) do\r\n begin\r\n Self.FActive := FActive;\r\n Self.FFontColor := FFontColor;\r\n Self.FBorderColor := FBorderColor;\r\n Self.FColor := FColor;\r\n Self.FWordPairs.Assign(FWordPairs);\r\n Self.FCaseSensitiveWordPairs := FCaseSensitiveWordPairs;\r\n Self.FStringChar := FStringChar;\r\n Self.SetCommentPairs(FCommentPairs);\r\n end;\r\n end\r\n else\r\n inherited Assign(Source);\r\nend;\r\n\r\nprocedure TJvBracketHighlighting.SetWordPairs(Value: TStrings);\r\nbegin\r\n if Value <> FWordPairs then\r\n FWordPairs.Assign(Value);\r\nend;\r\n\r\nprocedure TJvBracketHighlighting.SetCommentPairs(const Value: TStrings);\r\nbegin\r\n if Value <> FCommentPairs then\r\n FCommentPairs.Assign(Value);\r\nend;\r\n\r\nfunction TJvBracketHighlighting.CreateStringMap(const Text: string): TDynBoolArray;\r\nvar\r\n LenText: Integer;\r\n i, j, Idx, InStr: Integer;\r\nbegin\r\n LenText := Length(Text);\r\n SetLength(Result, LenText);\r\n for i := 0 to High(Result) do\r\n Result[i] := False;\r\n\r\n if StringChars <> '' then\r\n begin\r\n InStr := 0;\r\n i := 0;\r\n while i < LenText do\r\n begin\r\n if (StringEscape <> '') and // skip string escape \"char\"\r\n IsSubString(Text, i + 1, StringEscape) then\r\n begin\r\n for j := 0 to Length(StringEscape) - 1 do\r\n Result[i + j] := True;\r\n Inc(i, Length(StringEscape));\r\n Continue;\r\n end;\r\n\r\n Idx := Pos(Text[i + 1], StringChars);\r\n if Idx > 0 then\r\n begin\r\n if InStr = Idx then\r\n InStr := 0 // string end\r\n else\r\n if InStr = 0 then\r\n InStr := Idx;\r\n end;\r\n if InStr <> 0 then\r\n Result[i] := True;\r\n Inc(i);\r\n end;\r\n end;\r\nend;\r\n\r\n//=== { TJvCustomEditorBase } ================================================\r\n\r\nvar\r\n BlockTypeFormat: Integer = 0;\r\n\r\nconstructor TJvCustomEditorBase.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n ControlStyle := [csCaptureMouse, csClickEvents {, csOpaque}, csDoubleClicks,\r\n csReplicatable];\r\n IncludeThemeStyle(Self, [csNeedsBorderPaint]);\r\n FInsertMode := True;\r\n FKeyboard := TJvKeyboard.Create;\r\n FRows := 1;\r\n FCols := 1;\r\n FUndoBuffer := TJvUndoBuffer.Create;\r\n FUndoBuffer.FJvEditor := Self;\r\n FGroupUndo := True;\r\n FBracketHighlighting := TJvBracketHighlighting.Create;\r\n FCurrentLineHighlight := clNone;\r\n FErrorHighlighting := TJvErrorHighlighting.Create(Self);\r\n\r\n FRightMarginVisible := True;\r\n FRightMargin := 80;\r\n FBorderStyle := bsSingle;\r\n Ctl3D := True;\r\n Height := 100;\r\n Width := 150;\r\n ParentColor := False;\r\n Cursor := crIBeam;\r\n TabStop := True;\r\n FTabStops := '3 5';\r\n FSmartTab := True;\r\n FBackSpaceUnindents := True;\r\n FAutoIndent := True;\r\n FKeepTrailingBlanks := False;\r\n FCursorBeyondEOF := False;\r\n FCursorBeyondEOL := True;\r\n FBlockOverwrite := True;\r\n FPersistentBlocks := False;\r\n FBeepOnError := False;\r\n\r\n FScrollBars := ssBoth;\r\n FScrollBarHorz := TJvControlScrollBar95.Create;\r\n FScrollBarVert := TJvControlScrollBar95.Create;\r\n FScrollBarVert.Kind := sbVertical;\r\n FScrollBarHorz.OnScroll := ScrollBarScroll;\r\n FScrollBarVert.OnScroll := ScrollBarScroll;\r\n\r\n Color := clWindow;\r\n FGutterColor := clBtnFace;\r\n FSelBackColor := clHighLight;\r\n FSelForeColor := clHighLightText;\r\n FRightMarginColor := clSilver;\r\n\r\n FEditorClient := TJvEditorClient.Create;\r\n FEditorClient.FJvEditor := Self;\r\n FGutter := TJvGutter.Create;\r\n FGutter.FJvEditor := Self;\r\n\r\n FLeftCol := 0;\r\n FTopRow := 0;\r\n FSelection.IsSelected := False;\r\n FSelection.Selecting := False;\r\n FCaretX := 0;\r\n FCaretY := 0;\r\n\r\n TimerScroll := TTimer.Create(Self);\r\n TimerScroll.Enabled := False;\r\n TimerScroll.Interval := 100;\r\n TimerScroll.OnTimer := ScrollTimer;\r\n\r\n FKeyboard.SetDefLayout;\r\n\r\n FSelection.SelBlockFormat := bfNonInclusive;\r\n if BlockTypeFormat = 0 then\r\n BlockTypeFormat := RegisterClipboardFormat('Borland IDE Block Type');\r\n\r\n { we can change font only after all objects are created }\r\n Font.Name := 'Courier New';\r\n Font.Size := 10;\r\n\r\n FFontCache := TList.Create;\r\n FLineInformations := TJvLineInformationList.Create(Self);\r\nend;\r\n\r\ndestructor TJvCustomEditorBase.Destroy;\r\nbegin\r\n FBracketHighlighting.Free;\r\n FErrorHighlighting.Free;\r\n FLineInformations.Free;\r\n FScrollBarHorz.Free;\r\n FScrollBarVert.Free;\r\n FEditorClient.Free;\r\n FKeyboard.Free;\r\n FUndoBuffer.Free;\r\n FGutter.Free;\r\n FontCacheClear; // free cached font instances\r\n FFontCache.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvCustomEditorBase.Assign(Source: TPersistent);\r\nvar\r\n Src: TJvCustomEditorBase;\r\nbegin\r\n if Source is TJvCustomEditorBase then\r\n begin\r\n BeginUpdate;\r\n try\r\n Src := TJvCustomEditorBase(Source);\r\n\r\n FSelForeColor := Src.SelForeColor;\r\n FSelBackColor := Src.SelBackColor;\r\n Color := Src.Color;\r\n RightMarginColor := Src.RightMarginColor;\r\n { The following options are set directly by JvHLEditorPropertyForm\r\n FKeyboard.Assign(Src.Keyboard);\r\n FGroupUndo := Src.GroupUndo;\r\n FUndoAfterSave := Src.UndoAfterSave;\r\n FTabStops := Src.TabStops;\r\n FDoubleClickLine := Src.DoubleClickLine;\r\n FSmartTab := Src.SmartTab;\r\n FBackSpaceUnindents := Src.BackSpaceUnindents;\r\n FAutoIndent := Src.AutoIndent;\r\n FKeepTrailingBlanks := Src.KeepTrailingBlanks;\r\n FCursorBeyondEOF := Src.CursorBeyondEOF;\r\n FCursorBeyondEOL := Src.CursorBeyondEOL;\r\n FBlockOverwrite := Src.BlockOverwrite;\r\n FPersistentBlocks := Src.PersistentBlocks;}\r\n finally\r\n EndUpdate;\r\n end;\r\n end\r\n else\r\n inherited Assign(Source);\r\nend;\r\n\r\nprocedure TJvCustomEditorBase.WMEditCommand(var Msg: TMessage);\r\nbegin\r\n Command(Msg.WParam);\r\n Msg.Result := Ord(True);\r\nend;\r\n\r\nprocedure TJvCustomEditorBase.WMCompound(var Msg: TMessage);\r\nbegin\r\n if Msg.WParam = 0 then\r\n BeginCompound\r\n else\r\n EndCompound;\r\n Msg.Result := Ord(True);\r\nend;\r\n\r\nprocedure TJvCustomEditorBase.CMResetCaptureControl(var Msg: TMessage);\r\nbegin\r\n SetCaptureControl(TControl(Msg.LParam));\r\nend;\r\n\r\nprocedure TJvCustomEditorBase.WMHScroll(var Msg: TWMHScroll);\r\nbegin\r\n FScrollBarHorz.DoScroll(Msg);\r\nend;\r\n\r\nprocedure TJvCustomEditorBase.WMVScroll(var Msg: TWMVScroll);\r\nbegin\r\n FScrollBarVert.DoScroll(Msg);\r\nend;\r\n\r\n\r\n\r\nprocedure TJvCustomEditorBase.WMSetCursor(var Msg: TWMSetCursor);\r\nvar\r\n P: TPoint;\r\nbegin\r\n GetCursorPos(P);\r\n P := ScreenToClient(P);\r\n if (P.X < GutterWidth) and (Cursor = crIBeam) then\r\n begin\r\n Msg.Result := 1;\r\n Windows.SetCursor(Screen.Cursors[crArrow])\r\n end\r\n else\r\n inherited;\r\nend;\r\n\r\nprocedure TJvCustomEditorBase.WMCopy(var Msg: TMessage);\r\nbegin\r\n DoCopy;\r\n Msg.Result := Ord(True);\r\nend;\r\n\r\nprocedure TJvCustomEditorBase.WMCut(var Msg: TMessage);\r\nbegin\r\n DoCut;\r\n Msg.Result := Ord(True);\r\nend;\r\n\r\nprocedure TJvCustomEditorBase.WMPaste(var Msg: TMessage);\r\nbegin\r\n DoPaste;\r\n Msg.Result := Ord(True);\r\nend;\r\n\r\nprocedure TJvCustomEditorBase.WMUndo(var Msg: TMessage);\r\nbegin\r\n Undo;\r\n Msg.Result := Ord(True);\r\nend;\r\n\r\nprocedure TJvCustomEditorBase.WMClear(var Msg: TMessage);\r\nbegin\r\n if not ReadOnly then\r\n DeleteSelected;\r\n Msg.Result := Ord(ReadOnly);\r\nend;\r\n\r\n\r\n\r\nprocedure TJvCustomEditorBase.EMSetReadOnly(var Msg: TMessage);\r\nbegin\r\n ReadOnly := Msg.WParam = 1;\r\nend;\r\n\r\nprocedure TJvCustomEditorBase.EMSetSelection(var Msg: TMessage);\r\nbegin\r\n if (Msg.WParam = 0) and (Msg.LParam = -1) then\r\n SelectAll\r\n else\r\n begin\r\n SelStart := Msg.WParam;\r\n SelLength := Msg.LParam;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomEditorBase.EMGetSelection(var Msg: TMessage);\r\nvar\r\n LSelStart, LSelEnd: Integer;\r\nbegin\r\n LSelStart := SelStart;\r\n LSelEnd := SelStart + SelLength;\r\n if Pointer(Msg.WParam) <> nil then\r\n PLongint(Msg.WParam)^ := LSelStart;\r\n if Pointer(Msg.LParam) <> nil then\r\n PLongint(Msg.LParam)^ := LSelEnd;\r\n if (LSelEnd > 65535) or (LSelStart > 65535) then\r\n Msg.Result := -1\r\n else\r\n begin\r\n Msg.ResultLo := LongRec(LSelStart).Lo;\r\n Msg.ResultHi := LongRec(LSelEnd).Lo;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomEditorBase.EMCanUndo(var Msg: TMessage);\r\nbegin\r\n Msg.Result := Ord(UndoBuffer.CanUndo);\r\nend;\r\n\r\nprocedure TJvCustomEditorBase.WMGetText(var Msg: TWMGetText);\r\nvar\r\n S: string;\r\nbegin\r\n if (Msg.Text = nil) or (csDestroying in ComponentState) then // stupid VCL wants to save the WindowText when the control is released\r\n Msg.Result := 0\r\n else\r\n begin\r\n S := GetText;\r\n Msg.Result := Min(Length(S), Msg.TextMax);\r\n if Msg.Result > 0 then\r\n Move(S[1], Msg.Text^, Msg.Result * SizeOf(Char));\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomEditorBase.WMGetTextLength(var Msg: TMessage);\r\nbegin\r\n if csDestroying in ComponentState then // stupid VCL wants to save the WindowText when the control is released\r\n Msg.Result := 0\r\n else\r\n Msg.Result := GetTextLen;\r\nend;\r\n\r\nprocedure TJvCustomEditorBase.UpdateEditorSize;\r\nconst\r\n BiggestSymbol = 'W';\r\nvar\r\n I: Integer;\r\nbegin\r\n if (csLoading in ComponentState) or\r\n not HandleAllocated then // CreateWnd calls this method in this case\r\n Exit;\r\n FEditorClient.Canvas.Font := Font;\r\n FontCacheClear; // clear font cache\r\n\r\n FCellRect.Height := FEditorClient.Canvas.TextHeight(BiggestSymbol) + 1;\r\n // workaround the bug in Windows-9x\r\n // fixed by Dmitry Rubinstain\r\n FCellRect.Width := FEditorClient.Canvas.TextWidth(BiggestSymbol + BiggestSymbol) div 2;\r\n\r\n SetLength(FMyDi, Max_X);\r\n for I := 0 to High(FMyDi) do\r\n FMyDi[I] := FCellRect.Width;\r\n\r\n FVisibleColCount := Trunc(FEditorClient.ClientWidth / FCellRect.Width);\r\n FVisibleRowCount := Trunc(FEditorClient.ClientHeight / FCellRect.Height);\r\n FLastVisibleCol := FLeftCol + FVisibleColCount - 1;\r\n FLastVisibleRow := FTopRow + FVisibleRowCount - 1;\r\n Rows := LineCount;\r\n Cols := Max_X_Scroll;\r\n FScrollBarHorz.Page := FVisibleColCount;\r\n FScrollBarVert.Page := FVisibleRowCount;\r\n FScrollBarHorz.LargeChange := Max(FVisibleColCount, 1);\r\n FScrollBarVert.LargeChange := Max(FVisibleRowCount, 1);\r\n FScrollBarVert.Max := Max(1, FRows - 1 + FVisibleRowCount - 1);\r\n\r\n FGutter.Invalidate;\r\nend;\r\n\r\nprocedure TJvCustomEditorBase.UpdateEditorView;\r\nbegin\r\n UpdateEditorSize;\r\n if Showing and (UpdateLock = 0) then\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvCustomEditorBase.ScrollTimer(Sender: TObject);\r\nbegin\r\n if (MouseMoveY < 0) or (MouseMoveY > ClientHeight) then\r\n begin\r\n if MouseMoveY < -20 then\r\n Dec(MouseMoveYY, FVisibleRowCount)\r\n else\r\n if MouseMoveY < 0 then\r\n Dec(MouseMoveYY)\r\n else\r\n if MouseMoveY > ClientHeight + 20 then\r\n Inc(MouseMoveYY, FVisibleRowCount)\r\n else\r\n if MouseMoveY > ClientHeight then\r\n Inc(MouseMoveYY);\r\n PaintCaret(False);\r\n SetSel(MouseMoveXX, MouseMoveYY);\r\n SetCaret(MouseMoveXX, MouseMoveYY);\r\n PaintCaret(True);\r\n end;\r\nend;\r\n\r\nfunction TJvCustomEditorBase.GetDefTabStop(X: Integer; Next: Boolean): Integer;\r\nvar\r\n I: Integer;\r\n S: string;\r\n A, B: Integer;\r\nbegin\r\n if Next then\r\n begin\r\n I := 0;\r\n S := Trim(SubStrBySeparator(FTabStops, I, ' '));\r\n A := 0;\r\n B := 1;\r\n while S <> '' do\r\n begin\r\n A := B;\r\n B := StrToInt(S) - 1;\r\n if B > X then\r\n begin\r\n Result := B;\r\n Exit;\r\n end;\r\n Inc(I);\r\n S := Trim(SubStrBySeparator(FTabStops, I, ' '));\r\n end;\r\n { after last tab pos }\r\n Result := X + ((B - A) - ((X - B) mod (B - A)));\r\n end\r\n else\r\n begin\r\n I := 0;\r\n S := Trim(SubStrBySeparator(FTabStops, I, ' '));\r\n A := 0;\r\n B := 0;\r\n while S <> '' do\r\n begin\r\n A := B;\r\n B := StrToInt(S) - 1;\r\n if B >= X then\r\n begin\r\n Result := A;\r\n Exit;\r\n end;\r\n Inc(I);\r\n S := Trim(SubStrBySeparator(FTabStops, I, ' '));\r\n end;\r\n { after last tab pos }\r\n Result := X - ((B - A) - ((X - B) mod (B - A)));\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomEditorBase.TextAllChangedInternal(Unselect: Boolean);\r\nbegin\r\n FontCacheClear;\r\n if Unselect then\r\n begin\r\n FSelection.IsSelected := False;\r\n FSelection.Selecting := False;\r\n end;\r\n HighlightBrackets(CaretX, CaretY);\r\nend;\r\n\r\nprocedure TJvCustomEditorBase.DoLinesChange(Sender: TObject);\r\nbegin\r\n if FUpdateLock = 0 then\r\n Repaint;\r\n if CaretY >= LineCount then\r\n begin\r\n if LineCount = 0 then\r\n CaretY := 0\r\n else\r\n CaretY := LineCount - 1;\r\n end;\r\n // Must update the number of rows or it would trigger Mantis 3905.\r\n Rows := LineCount;\r\n Changed;\r\nend;\r\n\r\nprocedure TJvCustomEditorBase.Changed;\r\nbegin\r\n FModified := True;\r\n if Assigned(FOnChange) then\r\n FOnChange(Self);\r\n StatusChanged;\r\nend;\r\n\r\nprocedure TJvCustomEditorBase.TextAllChanged;\r\nbegin\r\n TextAllChangedInternal(True);\r\nend;\r\n\r\nprocedure TJvCustomEditorBase.StatusChanged;\r\nbegin\r\n HighlightBrackets(CaretX, CaretY);\r\n if Assigned(FOnChangeStatus) then\r\n FOnChangeStatus(Self);\r\nend;\r\n\r\nprocedure TJvCustomEditorBase.SelectionChanged;\r\nbegin\r\nend;\r\n\r\nprocedure TJvCustomEditorBase.GetAttr(Line, ColBeg, ColEnd: Integer);\r\nbegin\r\nend;\r\n\r\nprocedure TJvCustomEditorBase.ChangeAttr(Line, ColBeg, ColEnd: Integer);\r\n\r\n procedure ChangeSelectedAttr(LineStyle: TJvLineSelectStyle);\r\n\r\n procedure DoChange(const iBeg, iEnd: Integer);\r\n var\r\n I: Integer;\r\n Color: TColor;\r\n begin\r\n if LineStyle = lssUnselected then\r\n for I := iBeg to iEnd do\r\n begin\r\n LineAttrs[I+1].FC := SelForeColor;\r\n LineAttrs[I+1].BC := SelBackColor;\r\n LineAttrs[I+1].Border := clNone;\r\n end\r\n else\r\n // exchange fore and background color\r\n for I := iBeg to iEnd do\r\n begin\r\n Color := LineAttrs[I+1].FC;\r\n LineAttrs[I+1].FC := LineAttrs[I+1].BC;\r\n LineAttrs[I+1].BC := Color;\r\n LineAttrs[I+1].Border := clNone;\r\n end;\r\n end;\r\n\r\n begin\r\n with FSelection do\r\n begin\r\n if SelBlockFormat = bfColumn then\r\n begin\r\n if (Line >= SelBegY) and (Line <= SelEndY) then\r\n DoChange(SelBegX, SelEndX - 1 + Ord(True)); {always Inclusive}\r\n end\r\n else\r\n begin\r\n if (Line = SelBegY) and (Line = SelEndY) then\r\n DoChange(SelBegX, SelEndX - 1 + Ord(SelBlockFormat = bfInclusive))\r\n else\r\n begin\r\n if Line = SelBegY then\r\n DoChange(SelBegX, LeftCol + SelBegX + VisibleColCount);\r\n if (Line > SelBegY) and (Line < SelEndY) then\r\n DoChange(ColBeg, ColEnd);\r\n if Line = SelEndY then\r\n DoChange(ColBeg, SelEndX - 1 + Ord(SelBlockFormat = bfInclusive));\r\n end;\r\n end;\r\n end;\r\n end;\r\n\r\nvar\r\n I, TmpI: Integer;\r\n LineStyle: TJvLineSelectStyle;\r\nbegin\r\n // line style\r\n LineStyle := LineInformations.SelectStyle[Line];\r\n case LineStyle of\r\n lssBreakpoint:\r\n begin\r\n LineAttrs[ColBeg].FC := LineInformations.BreakpointTextColor;\r\n LineAttrs[ColBeg].BC := LineInformations.BreakpointColor;\r\n end;\r\n lssDebugPoint:\r\n begin\r\n LineAttrs[ColBeg].FC := LineInformations.DebugPointTextColor;\r\n LineAttrs[ColBeg].BC := LineInformations.DebugPointColor;\r\n end;\r\n lssErrorPoint:\r\n begin\r\n LineAttrs[ColBeg].FC := LineInformations.ErrorPointTextColor;\r\n LineAttrs[ColBeg].BC := LineInformations.ErrorPointColor;\r\n end;\r\n end;\r\n if LineStyle <> lssUnselected then\r\n begin\r\n TmpI := ColEnd;\r\n if TmpI < Max_X then\r\n Inc(TmpI);\r\n for I := ColBeg + 1 to TmpI do\r\n begin\r\n LineAttrs[I].FC := LineAttrs[ColBeg].FC;\r\n LineAttrs[I].BC := LineAttrs[ColBeg].BC;\r\n LineAttrs[I].Border := LineAttrs[ColBeg].Border;\r\n end;\r\n end;\r\n\r\n GetBracketHighlightAttr(Line, LineAttrs);\r\n\r\n if (Line = CaretY) and (CurrentLineHighlight <> clNone) and (CurrentLineHighlight <> clDefault) then\r\n for I := ColBeg to ColEnd do\r\n if LineAttrs[I].BC = Color then\r\n LineAttrs[I].BC := CurrentLineHighlight;\r\n\r\n if FSelection.IsSelected then\r\n ChangeSelectedAttr(LineStyle); { we change the attributes of the chosen block [translated] }\r\nend;\r\n\r\nprocedure TJvCustomEditorBase.GutterPaint(Canvas: TCanvas);\r\nbegin\r\n if Assigned(FOnPaintGutter) then\r\n FOnPaintGutter(Self, Canvas);\r\nend;\r\n\r\nprocedure TJvCustomEditorBase.GutterClick(Line: Integer);\r\nbegin\r\n if Assigned(FOnGutterClick) then\r\n FOnGutterClick(Self, Line);\r\nend;\r\n\r\nprocedure TJvCustomEditorBase.GutterDblClick(Line: Integer);\r\nbegin\r\n if Assigned(FOnGutterDblClick) then\r\n FOnGutterDblClick(Self, Line);\r\nend;\r\n\r\nprocedure TJvCustomEditorBase.BookmarkChanged(Bookmark: Integer);\r\nbegin\r\n Gutter.Invalidate;\r\nend;\r\n\r\nprocedure TJvCustomEditorBase.CompletionIdentifier(var Cancel: Boolean);\r\nbegin\r\nend;\r\n\r\nprocedure TJvCustomEditorBase.CompletionTemplate(var Cancel: Boolean);\r\nbegin\r\nend;\r\n\r\nprocedure TJvCustomEditorBase.DoCompletionIdentifier(var Cancel: Boolean);\r\nbegin\r\n if not Focused then\r\n Cancel := True\r\n else\r\n begin\r\n CompletionIdentifier(Cancel);\r\n if Assigned(FOnCompletionIdentifier) then\r\n FOnCompletionIdentifier(Self, Cancel);\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomEditorBase.DoCompletionTemplate(var Cancel: Boolean);\r\nbegin\r\n if not Focused then\r\n Cancel := True\r\n else\r\n begin\r\n CompletionTemplate(Cancel);\r\n if Assigned(FOnCompletionTemplate) then\r\n FOnCompletionTemplate(Self, Cancel);\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomEditorBase.Resize;\r\nbegin\r\n UpdateEditorSize;\r\nend;\r\n\r\nprocedure TJvCustomEditorBase.CreateWnd;\r\nbegin\r\n inherited CreateWnd;\r\n if FScrollBars in [ssHorizontal, ssBoth] then\r\n FScrollBarHorz.Handle := Handle;\r\n if FScrollBars in [ssVertical, ssBoth] then\r\n FScrollBarVert.Handle := Handle;\r\n FAllRepaint := True;\r\n UpdateEditorSize;\r\nend;\r\n\r\nprocedure TJvCustomEditorBase.CreateParams(var Params: TCreateParams);\r\nconst\r\n BorderStyles: array [TBorderStyle] of Cardinal =\r\n (0, WS_BORDER);\r\n ScrollStyles: array [TScrollStyle] of Cardinal =\r\n (0, WS_HSCROLL, WS_VSCROLL, WS_HSCROLL or WS_VSCROLL);\r\nbegin\r\n inherited CreateParams(Params);\r\n with Params do\r\n begin\r\n Style := Style or BorderStyles[FBorderStyle] or ScrollStyles[FScrollBars];\r\n if Ctl3D and (FBorderStyle = bsSingle) then\r\n begin\r\n Style := Style and not WS_BORDER;\r\n ExStyle := ExStyle or WS_EX_CLIENTEDGE;\r\n end;\r\n WindowClass.style := WindowClass.style and not (CS_HREDRAW or CS_VREDRAW);\r\n\r\n if ReadOnly then\r\n Style := Style or ES_READONLY\r\n else\r\n Style := Style and not ES_READONLY;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomEditorBase.Loaded;\r\nbegin\r\n inherited Loaded;\r\n UpdateEditorSize;\r\nend;\r\n\r\n\r\n\r\nprocedure TJvCustomEditorBase.ScrollBarScroll(Sender: TObject; ScrollCode:\r\n TScrollCode; var ScrollPos: Integer);\r\nbegin\r\n case ScrollCode of\r\n scLineUp..scPageDown, {scPosition,} scTrack {, scEndScroll}:\r\n if Sender = FScrollBarVert then\r\n Scroll(True, ScrollPos)\r\n else\r\n if Sender = FScrollBarHorz then\r\n Scroll(False, ScrollPos);\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomEditorBase.Scroll(Vert: Boolean; ScrollPos: Integer);\r\nvar\r\n R, RClip, RUpdate: TRect;\r\n OldFTopRow: Integer;\r\n OldFLeftCol: Integer;\r\nbegin\r\n if UpdateLock = 0 then\r\n begin\r\n PaintCaret(False);\r\n if Vert then\r\n begin {Vertical Scroll}\r\n { optimized scrolling }\r\n OldFTopRow := FTopRow;\r\n FTopRow := ScrollPos;\r\n if Abs((OldFTopRow - ScrollPos) * FCellRect.Height) < FEditorClient.Height then\r\n begin\r\n R := FEditorClient.ClientRect;\r\n R.Bottom := R.Top + CellRect.Height * FVisibleRowCount;\r\n R.Left := 0; // update gutter\r\n RClip := R;\r\n Inc(RClip.Bottom, CellRect.Height);\r\n ScrollDC(\r\n FEditorClient.Canvas.Handle, // handle of device context\r\n 0, // horizontal scroll units\r\n (OldFTopRow - ScrollPos) * CellRect.Height, // vertical scroll units\r\n R, // address of structure for scrolling rectangle\r\n RClip, // address of structure for clipping rectangle\r\n 0, // handle of scrolling region\r\n @RUpdate // address of structure for update rectangle\r\n );\r\n // (ahuser) WinNT seams to have problems with ScrollDC in vertical direction. (Mantis #2528)\r\n if (Win32Platform = VER_PLATFORM_WIN32_NT) and not CheckWin32Version(5, 0) then\r\n Dec(RUpdate.Top, CellRect.Height);\r\n Inc(RUpdate.Bottom, CellRect.Height);\r\n Windows.InvalidateRect(Handle, @RUpdate, False);\r\n end\r\n else\r\n Invalidate;\r\n Update;\r\n end\r\n else {Horizontal Scroll}\r\n begin\r\n { optimized scrolling }\r\n OldFLeftCol := FLeftCol;\r\n FLeftCol := ScrollPos;\r\n if FLeftCol >= Max_X then\r\n FLeftCol := Max_X - 1;\r\n if Abs((OldFLeftCol - ScrollPos) * CellRect.Width) < FEditorClient.Width then\r\n begin\r\n R := FEditorClient.ClientRect;\r\n R.Right := R.Left + CellRect.Width * FVisibleColCount;\r\n RClip := R;\r\n Inc(RClip.Right, CellRect.Width);\r\n ScrollDC(\r\n FEditorClient.Canvas.Handle, // handle of device context\r\n (OldFLeftCol - ScrollPos) * CellRect.Width, // horizontal scroll units\r\n 0, // vertical scroll units\r\n R, // address of structure for scrolling rectangle\r\n RClip, // address of structure for clipping rectangle\r\n 0, // handle of scrolling region\r\n @RUpdate // address of structure for update rectangle\r\n );\r\n Inc(RUpdate.Right, CellRect.Width); // draw italic chars correctly\r\n Windows.InvalidateRect(Handle, @RUpdate, False);\r\n end\r\n else\r\n Invalidate;\r\n Update;\r\n end;\r\n end\r\n else { UpdateLock > 0 }\r\n begin\r\n if Vert then\r\n FTopRow := ScrollPos\r\n else\r\n FLeftCol := ScrollPos;\r\n\r\n if FLeftCol >= Max_X then\r\n FLeftCol := Max_X - 1;\r\n end;\r\n FLastVisibleRow := FTopRow + FVisibleRowCount - 1;\r\n FLastVisibleCol := FLeftCol + FVisibleColCount - 1;\r\n if UpdateLock = 0 then\r\n begin\r\n DrawRightMargin;\r\n PaintCaret(True);\r\n end;\r\n if Assigned(FOnScroll) then\r\n FOnScroll(Self);\r\nend;\r\n\r\nprocedure TJvCustomEditorBase.KeyDown(var Key: Word; Shift: TShiftState);\r\nvar\r\n Com: TEditCommand;\r\nbegin\r\n PaintCaret(False);\r\n try\r\n if Completion.Visible then\r\n begin\r\n if Completion.DoKeyDown(Key, Shift) then\r\n begin\r\n IgnoreKeyPress := True;\r\n Exit;\r\n end;\r\n end\r\n else\r\n Completion.FTimer.Enabled := False;\r\n\r\n if not (ssShift in Shift) and not FMouseDown then\r\n FSelection.Selecting := False;\r\n\r\n if WaitSecondKey then\r\n begin\r\n IgnoreKeyPress := True; { Set this before calling FKeyboard.Command2()\r\n because in FKeyboard.OnCommand2 the\r\n Editor-window can loose focus and so the\r\n second char will be printed. }\r\n Com := FKeyboard.Command2(Key1, Shift1, Key, Shift);\r\n WaitSecondKey := False;\r\n IgnoreKeyPress := True;\r\n end\r\n else\r\n begin\r\n inherited KeyDown(Key, Shift);\r\n Key1 := Key;\r\n Shift1 := Shift;\r\n Com := FKeyboard.Command(Key, Shift);\r\n if Com = twoKeyCommand then\r\n begin\r\n IgnoreKeyPress := True;\r\n WaitSecondKey := True;\r\n end\r\n else\r\n IgnoreKeyPress := Com > 0;\r\n end;\r\n\r\n if (Com > 0) and (Com <> twoKeyCommand) then\r\n begin\r\n Command(Com);\r\n if ssAlt in Shift then\r\n begin\r\n { Setting the capture control to the editor prevents the VM_MENU key to\r\n activate the mainmenu. }\r\n PostMessage(Handle, CM_RESETCAPTURECONTROL, 0, LPARAM(GetCaptureControl));\r\n SetCaptureControl(Self);\r\n end;\r\n Key := 0;\r\n end;\r\n\r\n if Com = ecBackspace then\r\n Completion.DoKeyPress(Backspace);\r\n finally\r\n PaintCaret(True);\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomEditorBase.KeyPress(var Key: Char);\r\nvar\r\n Ch: Char;\r\nbegin\r\n if IgnoreKeyPress or FReadOnly then\r\n begin\r\n IgnoreKeyPress := False;\r\n Exit;\r\n end;\r\n\r\n PaintCaret(False);\r\n try\r\n if Assigned(OnKeyPress) then // do the inherited action\r\n begin\r\n Ch := Char(Key);\r\n OnKeyPress(Self, Ch);\r\n Key := Char(Ch);\r\n end;\r\n Command(Ord(Key));\r\n finally\r\n PaintCaret(True);\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomEditorBase.MouseDown(Button: TMouseButton; Shift: TShiftState;\r\n X, Y: Integer);\r\nvar\r\n XX, YY, SX, SY: Integer;\r\nbegin\r\n if FDoubleClick then\r\n begin\r\n FDoubleClick := False;\r\n Exit;\r\n end;\r\n FSelection.Selecting := False;\r\n Completion.CloseUp(False);\r\n Mouse2Caret(X, Y, XX, YY);\r\n\r\n PaintCaret(False);\r\n if (Button = mbLeft) and not (ssShift in Shift) then\r\n begin\r\n if ssAlt in Shift then\r\n FSelection.SelBlockFormat := bfColumn\r\n else\r\n FSelection.SelBlockFormat := bfNonInclusive; // reset BlockFormat\r\n SetUnSelected;\r\n end;\r\n SetFocus;\r\n {$IFDEF MSWINDOWS}\r\n // in MDIChilds the focus meight not be set correctly (\"ActiveControl <> Control\" in TCustomForm.SetActiveControl)\r\n Windows.SetFocus(Handle);\r\n {$ENDIF MSWINDOWS}\r\n\r\n {--- UNDO ---}\r\n if Button = mbLeft then\r\n TJvBeginCompoundUndo.Create(Self);\r\n {--- /UNDO ---}\r\n if Button = mbLeft then\r\n begin\r\n if ssShift in Shift then\r\n begin\r\n if not FSelection.IsSelected then\r\n begin\r\n SetSel(FCaretX, FCaretY);\r\n end\r\n else\r\n begin\r\n SX := FSelection.SelStartX;\r\n SY := FSelection.SelStartY;\r\n SetUnSelected;\r\n SetSel(SX, SY);\r\n end;\r\n SetSel(XX, YY);\r\n end;\r\n SetCaret(XX, YY);\r\n end\r\n else\r\n if Button = mbRight then\r\n SetCaret(XX, YY);\r\n PaintCaret(True);\r\n FMouseDown := True;\r\n\r\n inherited MouseDown(Button, Shift, X, Y);\r\nend;\r\n\r\nprocedure TJvCustomEditorBase.MouseMove(Shift: TShiftState; X, Y: Integer);\r\nbegin\r\n if FMouseDown and (ssLeft in (Shift * [ssShift, ssLeft]) ) then\r\n begin\r\n PaintCaret(False);\r\n MouseMoveY := Y;\r\n Mouse2Caret(X, Y, MouseMoveXX, MouseMoveYY);\r\n\r\n if MouseMoveYY <= FLastVisibleRow then\r\n begin\r\n SetSel(MouseMoveXX, MouseMoveYY);\r\n SetCaret(MouseMoveXX, MouseMoveYY);\r\n end;\r\n TimerScroll.Enabled := (Y < 0) or (Y > ClientHeight);\r\n PaintCaret(True);\r\n end;\r\n inherited MouseMove(Shift, X, Y);\r\nend;\r\n\r\nprocedure TJvCustomEditorBase.MouseUp(Button: TMouseButton; Shift: TShiftState;\r\n X, Y: Integer);\r\nvar\r\n XX, YY: Integer;\r\nbegin\r\n if FMouseDown then\r\n TJvEndCompoundUndo.Create(Self);\r\n TimerScroll.Enabled := False;\r\n FMouseDown := False;\r\n inherited MouseUp(Button, Shift, X, Y);\r\n\r\n // Gutter click\r\n if (X >= 0) and (X < FGutterWidth) then\r\n begin\r\n Mouse2Caret(X, Y, XX, YY);\r\n GutterClick(YY);\r\n end;\r\nend;\r\n\r\nfunction TJvCustomEditorBase.DoMouseWheel(Shift: TShiftState; WheelDelta: Integer; MousePos: TPoint): Boolean;\r\nvar\r\n WheelDirection: Integer;\r\nbegin\r\n Result := True;\r\n if ssShift in Shift then\r\n begin\r\n // Shift+Wheel: move caret up and down\r\n if WheelDelta > 0 then\r\n Command(ecUp)\r\n else\r\n Command(ecDown);\r\n end\r\n else\r\n if ssCtrl in Shift then\r\n begin\r\n if WheelDelta < 0 then\r\n WheelDirection := -1\r\n else\r\n WheelDirection := 1;\r\n // Ctrl+Wheel: scrollbar large change\r\n FScrollBarVert.Position := FScrollBarVert.Position - WheelDirection * FScrollBarVert.LargeChange;\r\n Scroll(True, FScrollBarVert.Position);\r\n end\r\n else\r\n if Shift = [] then\r\n begin\r\n FScrollBarVert.Position := FScrollBarVert.Position - WheelDelta div 40;\r\n Scroll(True, FScrollBarVert.Position);\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomEditorBase.DblClick;\r\nvar\r\n pt: TPoint;\r\n XX, YY: Integer;\r\nbegin\r\n FDoubleClick := True;\r\n if Assigned(FOnDblClick) then\r\n FOnDblClick(Self);\r\n\r\n pt := ScreenToClient(Mouse.CursorPos);\r\n if (pt.X >= 0) and (pt.X < FGutterWidth) then\r\n begin\r\n Mouse2Caret(pt.X, pt.Y, XX, YY);\r\n GutterDblClick(YY);\r\n end\r\n else\r\n if FDoubleClickLine then\r\n begin\r\n PaintCaret(False);\r\n SetSel(0, FCaretY);\r\n if FCaretY = LineCount - 1 then\r\n begin\r\n SetSel(LineLength[FCaretY], FCaretY);\r\n SetCaret(LineLength[FCaretY], FCaretY);\r\n end\r\n else\r\n begin\r\n SetSel(0, FCaretY + 1);\r\n SetCaret(0, FCaretY + 1);\r\n end;\r\n PaintCaret(True);\r\n end\r\n else\r\n if LineCount > 0 then\r\n SelectWordOnCaret;\r\nend;\r\n\r\nprocedure TJvCustomEditorBase.GetDlgCode(var Code: TDlgCodes);\r\nbegin\r\n Code := [dcWantArrows, dcWantTab, dcWantChars, dcWantMessage];\r\nend;\r\n\r\nprocedure TJvCustomEditorBase.FocusSet(PrevWnd: THandle);\r\nbegin\r\n inherited FocusSet(PrevWnd);\r\n CreateCaret(Handle, 0, 2, CellRect.Height - 2);\r\n PaintCaret(True);\r\nend;\r\n\r\nprocedure TJvCustomEditorBase.FocusKilled(NextWnd: THandle);\r\nbegin\r\n inherited FocusKilled(NextWnd);\r\n Completion.CloseUp(False);\r\n DestroyCaret;\r\nend;\r\n\r\nprocedure TJvCustomEditorBase.DoPaste;\r\nbegin\r\n if not FReadOnly then\r\n PostCommand(ecClipboardPaste);\r\nend;\r\n\r\nprocedure TJvCustomEditorBase.DoCopy;\r\nbegin\r\n PostCommand(ecClipboardCopy);\r\nend;\r\n\r\nprocedure TJvCustomEditorBase.DoCut;\r\nbegin\r\n if not FReadOnly then\r\n PostCommand(ecClipboardCut);\r\nend;\r\n\r\nprocedure TJvCustomEditorBase.CursorChanged;\r\nvar\r\n P: TPoint;\r\nbegin\r\n inherited CursorChanged;\r\n if HandleAllocated then\r\n begin\r\n GetCursorPos(P);\r\n P := ScreenToClient(P);\r\n if (P.X < GutterWidth) and (Cursor = crIBeam) then\r\n SetCursor(Screen.Cursors[crArrow]);\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomEditorBase.FontChanged;\r\nbegin\r\n inherited FontChanged;\r\n if HandleAllocated then\r\n UpdateEditorSize;\r\nend;\r\n\r\nfunction TJvCustomEditorBase.DoEraseBackground(Canvas: TCanvas; Param: LPARAM): Boolean;\r\nbegin\r\n Result := False; // no background erase\r\nend;\r\n\r\nprocedure TJvCustomEditorBase.SetGutterWidth(AWidth: Integer);\r\nbegin\r\n if FGutterWidth <> AWidth then\r\n begin\r\n FGutterWidth := AWidth;\r\n UpdateEditorSize;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomEditorBase.SetGutterColor(AColor: TColor);\r\nbegin\r\n if FGutterColor <> AColor then\r\n begin\r\n FGutterColor := AColor;\r\n Gutter.Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomEditorBase.SetBorderStyle(Value: TBorderStyle);\r\nbegin\r\n if FBorderStyle <> Value then\r\n begin\r\n FBorderStyle := Value;\r\n RecreateWnd;\r\n end;\r\nend;\r\n\r\nfunction TJvCustomEditorBase.GetKeepTrailingBlanks: Boolean;\r\nbegin\r\n Result := FKeepTrailingBlanks or not FCursorBeyondEOL;\r\nend;\r\n\r\nfunction TJvCustomEditorBase.GetSelStart: Integer;\r\nbegin\r\n if FSelection.IsSelected then\r\n Result := PosFromCaret(FSelection.SelBegX, FSelection.SelBegY)\r\n else\r\n Result := PosFromCaret(FCaretX, FCaretY);\r\nend;\r\n\r\nprocedure TJvCustomEditorBase.SetSelStart(ASelStart: Integer);\r\nbegin\r\n with FSelection do\r\n begin\r\n IsSelected := False;\r\n Selecting := False;\r\n CaretFromPos(ASelStart, SelBegX, SelBegY);\r\n SetCaretInternal(SelBegX, SelBegY);\r\n SetSelLength(0);\r\n MakeRowVisible(SelBegY);\r\n // PaintSelection;\r\n // EditorPaint;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomEditorBase.SetSelLength(ASelLength: Integer);\r\nbegin\r\n with FSelection do\r\n begin\r\n IsSelected := ASelLength > 0;\r\n Selecting := False;\r\n CaretFromPos(SelStart + ASelLength, SelEndX, SelEndY);\r\n SetSelUpdateRegion(SelBegY, SelEndY);\r\n SetCaretInternal(SelEndX, SelEndY);\r\n //PaintSelection;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nfunction TJvCustomEditorBase.GetSelLength: Integer;\r\nvar\r\n I: Integer;\r\n Len, CLen: Integer;\r\nbegin\r\n Result := 0;\r\n with FSelection do\r\n begin\r\n if not IsSelected then\r\n Exit;\r\n\r\n if (SelBegY < 0) or (SelBegY > LineCount - 1) or (SelEndY < 0) or\r\n (SelEndY > LineCount - 1) then\r\n begin\r\n if BeepOnError then\r\n Beep;\r\n Exit;\r\n end;\r\n\r\n if SelBlockFormat = bfColumn then\r\n begin\r\n for I := SelBegY to SelEndY do\r\n begin\r\n CLen := LineLength[I] - SelBegX;\r\n if CLen < 0 then\r\n CLen := 0;\r\n if CLen > SelEndX - SelBegX + 1 then\r\n CLen := SelEndX - SelBegX + 1;\r\n\r\n Inc(Result, CLen + sLineBreakLen);\r\n end;\r\n if Result > 0 then\r\n Dec(Result, sLineBreakLen);\r\n end\r\n else\r\n begin\r\n if SelBegY = SelEndY then\r\n begin\r\n Result := SelEndX - SelBegX + Ord(SelBlockFormat = bfInclusive);\r\n if SelBegX + Result > LineLength[SelEndY] then\r\n Result := LineLength[SelEndY] - SelBegX;\r\n if Result < 0 then\r\n Result := 0;\r\n end\r\n else\r\n begin\r\n Result := LineLength[SelBegY] - SelBegX;\r\n if Result < 0 then\r\n Result := 0;\r\n for I := SelBegY + 1 to SelEndY - 1 do\r\n Inc(Result, sLineBreakLen + LineLength[I]);\r\n\r\n Len := SelEndX + Ord(SelBlockFormat = bfInclusive);\r\n if Len > LineLength[SelEndY] then\r\n Len := LineLength[SelEndY];\r\n Result := Result + sLineBreakLen + Len;\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomEditorBase.SetSelBlockFormat(Value: TJvSelBlockFormat);\r\nbegin\r\n Command(ecInclusiveBlock + Ord(Value));\r\nend;\r\n\r\nfunction TJvCustomEditorBase.GetSelBlockFormat: TJvSelBlockFormat;\r\nbegin\r\n Result := FSelection.SelBlockFormat;\r\nend;\r\n\r\nprocedure TJvCustomEditorBase.SetMode(Index: Integer; Value: Boolean);\r\nbegin\r\n if Index = 0 then\r\n begin\r\n if FInsertMode <> Value then\r\n begin\r\n FInsertMode := Value;\r\n StatusChanged;\r\n end;\r\n end\r\n else {1 :}\r\n begin\r\n if HandleAllocated then\r\n begin\r\n if Value then\r\n SetWindowLong(Handle, GWL_STYLE, GetWindowLong(Handle, GWL_STYLE) or ES_READONLY)\r\n else\r\n SetWindowLong(Handle, GWL_STYLE, GetWindowLong(Handle, GWL_STYLE) and not ES_READONLY);\r\n end;\r\n if FReadOnly <> Value then\r\n begin\r\n FReadOnly := Value;\r\n StatusChanged;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomEditorBase.SetCaretPosition(Index, Pos: Integer);\r\nbegin\r\n if Index = 0 then\r\n SetCaret(Pos, FCaretY)\r\n else\r\n SetCaret(FCaretX, Pos);\r\n\r\n // persistent blocks:\r\n if FSelection.IsSelected then\r\n begin\r\n with FSelection do\r\n if ((FCaretX < SelBegX) and (CaretY <= SelBegY)) or\r\n ((FCaretX >= SelEndX) and (CaretY >= SelEndY)) then\r\n FPersistentBlocksCaretChanged := True;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomEditorBase.SetCols(ACols: Integer);\r\nbegin\r\n if FCols <> ACols then\r\n begin\r\n FCols := Max(ACols, 1);\r\n FScrollBarHorz.Max := FCols - 1;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomEditorBase.SetRows(ARows: Integer);\r\nbegin\r\n if FRows <> ARows then\r\n begin\r\n FRows := Max(ARows, 1);\r\n FScrollBarVert.Max := Max(1, FRows - 1 + FVisibleRowCount - 1);\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomEditorBase.SetScrollBars(Value: TScrollStyle);\r\nbegin\r\n if FScrollBars <> Value then\r\n begin\r\n FScrollBars := Value;\r\n RecreateWnd;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomEditorBase.SetRightMarginVisible(Value: Boolean);\r\nbegin\r\n if FRightMarginVisible <> Value then\r\n begin\r\n FRightMarginVisible := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomEditorBase.SetRightMargin(Value: Integer);\r\nbegin\r\n if FRightMargin <> Value then\r\n begin\r\n FRightMargin := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomEditorBase.SetRightMarginColor(Value: TColor);\r\nbegin\r\n if FRightMarginColor <> Value then\r\n begin\r\n FRightMarginColor := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomEditorBase.SetSelBackColor(const Value: TColor);\r\nbegin\r\n if Value <> FSelBackColor then\r\n begin\r\n FSelBackColor := Value;\r\n if FSelection.IsSelected then\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomEditorBase.SetSelForeColor(const Value: TColor);\r\nbegin\r\n if Value <> FSelForeColor then\r\n begin\r\n FSelForeColor := Value;\r\n if FSelection.IsSelected then\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nfunction TJvCustomEditorBase.GetPopupMenu: TPopupMenu;\r\nbegin\r\n Result := inherited GetPopupMenu;\r\n if (Result = nil) and UseFixedPopup then\r\n Result := FixedDefaultEditPopup(Self);\r\nend;\r\n\r\nprocedure TJvCustomEditorBase.LockUpdate;\r\nbegin\r\n Inc(FUpdateLock);\r\nend;\r\n\r\nprocedure TJvCustomEditorBase.UnlockUpdate;\r\nbegin\r\n Dec(FUpdateLock);\r\nend;\r\n\r\nfunction TJvCustomEditorBase.GetClipboardBlockFormat: TJvSelBlockFormat;\r\nvar\r\n Data: THandle;\r\nbegin\r\n Result := bfNonInclusive;\r\n if Clipboard.HasFormat(BlockTypeFormat) then\r\n begin\r\n Clipboard.Open;\r\n Data := GetClipboardData(BlockTypeFormat);\r\n try\r\n if Data <> 0 then\r\n Result := TJvSelBlockFormat(PInteger(GlobalLock(Data))^);\r\n finally\r\n if Data <> 0 then\r\n GlobalUnlock(Data);\r\n Clipboard.Close;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomEditorBase.SetClipboardBlockFormat(const Value: TJvSelBlockFormat);\r\nvar\r\n Data: THandle;\r\n DataPtr: Pointer;\r\nbegin\r\n Clipboard.Open;\r\n try\r\n Data := GlobalAlloc(GMEM_MOVEABLE + GMEM_DDESHARE, 1);\r\n try\r\n DataPtr := GlobalLock(Data);\r\n try\r\n Move(Value, DataPtr^, 1);\r\n SetClipboardData(BlockTypeFormat, Data);\r\n finally\r\n GlobalUnlock(Data);\r\n end;\r\n except\r\n GlobalFree(Data);\r\n raise;\r\n end;\r\n finally\r\n Clipboard.Close;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomEditorBase.SetSel(SelX, SelY: Integer);\r\nvar\r\n LineLen: Integer;\r\n\r\n procedure UpdateSelected;\r\n var\r\n iR: Integer;\r\n begin\r\n with FSelection do\r\n begin\r\n if SelBlockFormat = bfColumn then\r\n begin\r\n if FUpdateSelBegY < SelBegY then\r\n for iR := FUpdateSelBegY to SelBegY do\r\n PaintLine(iR, -1, -1);\r\n for iR := SelBegY to SelEndY do\r\n PaintLine(iR, -1, -1);\r\n if FUpdateSelEndY > SelEndY then\r\n for iR := SelEndY to FUpdateSelEndY do\r\n PaintLine(iR, -1, -1);\r\n end\r\n else\r\n begin\r\n if FUpdateSelBegY < SelBegY then\r\n for iR := FUpdateSelBegY to SelBegY do\r\n PaintLine(iR, -1, -1)\r\n else\r\n for iR := SelBegY to FUpdateSelBegY do\r\n PaintLine(iR, -1, -1);\r\n if FUpdateSelEndY < SelEndY then\r\n for iR := FUpdateSelEndY to SelEndY do\r\n PaintLine(iR, -1, -1)\r\n else\r\n for iR := SelEndY to FUpdateSelEndY do\r\n PaintLine(iR, -1, -1);\r\n end;\r\n\r\n SelectionChanged;\r\n if Assigned(FOnSelectionChange) then\r\n FOnSelectionChange(Self);\r\n end;\r\n end;\r\n\r\nbegin\r\n with FSelection do\r\n begin\r\n {--- UNDO ---}\r\n TJvSelectUndo.Create(Self, FCaretX, FCaretY);\r\n {--- /UNDO ---}\r\n if SelX < 0 then\r\n SelX := 0;\r\n if SelY < 0 then\r\n SelY := 0;\r\n if SelY >= LineCount then\r\n begin\r\n if LineCount = 0 then\r\n SelY := 0 // select none\r\n else\r\n begin\r\n SelY := LineCount - 1; // select last line\r\n if not (FSelection.SelBlockFormat in [bfLine, bfColumn]) then\r\n SelX := LineLength[SelY]; // with all text\r\n end;\r\n end;\r\n if not (SelBlockFormat in [bfLine, bfColumn]) then\r\n begin\r\n if (LineCount > 0) and (SelY < LineCount) then\r\n begin\r\n LineLen := LineLength[SelY];\r\n if SelX > LineLen then\r\n SelX := LineLen; // only text not the whole line\r\n end;\r\n end;\r\n\r\n if FPersistentBlocks then\r\n begin\r\n if FPersistentBlocksCaretChanged then\r\n begin\r\n IsSelected := False;\r\n Selecting := False;\r\n end;\r\n FPersistentBlocksCaretChanged := False;\r\n end;\r\n\r\n if not Selecting then\r\n begin\r\n SelStartX := SelX;\r\n SelStartY := SelY;\r\n SelEndX := SelX;\r\n SelEndY := SelY;\r\n SelBegX := SelX;\r\n SelBegY := SelY;\r\n IsSelected := False;\r\n Selecting := True;\r\n if SelBlockFormat = bfLine then\r\n AdjustSelLineMode(False); // Restore\r\n end\r\n else\r\n begin\r\n if SelBlockFormat = bfLine then\r\n AdjustSelLineMode(True); // Restore\r\n\r\n FUpdateSelBegY := SelBegY;\r\n FUpdateSelEndY := SelEndY;\r\n\r\n if SelY <= SelStartY then\r\n begin\r\n SelBegY := SelY;\r\n SelEndY := SelStartY;\r\n end;\r\n if SelY >= SelStartY then\r\n begin\r\n SelBegY := SelStartY;\r\n SelEndY := SelY;\r\n end;\r\n\r\n if (SelY < SelStartY) or ((SelY = SelStartY) and (SelX <= SelStartX)) then\r\n if (SelBlockFormat = bfColumn) and (SelX > SelStartX) then\r\n begin\r\n SelBegX := SelStartX;\r\n SelEndX := SelX;\r\n end\r\n else\r\n begin\r\n SelBegX := SelX;\r\n SelEndX := SelStartX;\r\n end;\r\n if (SelY > SelStartY) or ((SelY = SelStartY) and (SelX >= SelStartX)) then\r\n if (SelBlockFormat = bfColumn) and (SelX < SelStartX) then\r\n begin\r\n SelBegX := SelX;\r\n SelEndX := SelStartX;\r\n end\r\n else\r\n begin\r\n SelBegX := SelStartX;\r\n SelEndX := SelX;\r\n end;\r\n\r\n if SelBlockFormat = bfLine then\r\n begin\r\n // save line mode X values\r\n SelLineOrgBegX := SelBegX;\r\n SelLineOrgEndX := SelEndX;\r\n SelBegX := 0;\r\n SelEndX := Max_X;\r\n end;\r\n\r\n if (SelBegY < SelEndY) or ((SelBegY = SelEndY) and (SelBegX < SelEndX)) then\r\n IsSelected := True\r\n else\r\n IsSelected := False;\r\n end;\r\n\r\n if FCompound = 0 then\r\n UpdateSelected;\r\n SetSelUpdateRegion(SelBegY, SelEndY);\r\n end;\r\nend;\r\n\r\nfunction TJvCustomEditorBase.IsNewSelection: Boolean;\r\nbegin\r\n if FPersistentBlocks then\r\n Result := (not FSelection.IsSelected) or FPersistentBlocksCaretChanged\r\n else\r\n Result := (not FSelection.IsSelected);\r\nend;\r\n\r\nfunction TJvCustomEditorBase.IsEmptySelection: Boolean;\r\nbegin\r\n with FSelection do\r\n Result := IsSelected and (SelBegX = SelEndX) and (SelBegY = SelEndY);\r\nend;\r\n\r\nprocedure TJvCustomEditorBase.PaintSelection;\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := FUpdateSelBegY to FUpdateSelEndY do\r\n PaintLine(I, -1, -1);\r\nend;\r\n\r\nprocedure TJvCustomEditorBase.SetUnSelected;\r\nbegin\r\n if FSelection.IsSelected then\r\n begin\r\n FSelection.IsSelected := False;\r\n FSelection.Selecting := False;\r\n {--- UNDO ---}\r\n TJvUnselectUndo.Create(Self, FCaretX, FCaretY);\r\n {--- /UNDO ---}\r\n PaintSelection;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomEditorBase.RemoveSelectedBlock;\r\nbegin\r\n if FSelection.IsSelected then\r\n begin\r\n if FBlockOverwrite and not FPersistentBlocks then\r\n DeleteSelected\r\n else\r\n if not FPersistentBlocks then\r\n SetUnSelected;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomEditorBase.PersistentBlocksSetUnSelected;\r\nbegin\r\n FPersistentBlocksCaretChanged := True;\r\n if not FPersistentBlocks then\r\n SetUnSelected;\r\nend;\r\n\r\nprocedure TJvCustomEditorBase.SetSelUpdateRegion(BegY, EndY: Integer);\r\nbegin\r\n if FUpdateSelBegY > BegY then\r\n FUpdateSelBegY := BegY;\r\n if FUpdateSelEndY < EndY then\r\n FUpdateSelEndY := EndY;\r\nend;\r\n\r\nprocedure TJvCustomEditorBase.AdjustSelLineMode(Restore: Boolean);\r\nbegin\r\n with FSelection do\r\n begin\r\n if not Restore then\r\n begin\r\n SelLineOrgBegX := SelBegX;\r\n SelLineOrgEndX := SelEndX;\r\n SelBegX := 0;\r\n SelEndX := Max_X;\r\n end\r\n else\r\n begin\r\n SelBegX := SelLineOrgBegX;\r\n SelEndX := SelLineOrgEndX;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomEditorBase.AdjustPersistentBlockSelection(X, Y: Integer;\r\n Mode: TAdjustPersistentBlockMode; Args: array of Integer);\r\nbegin\r\n // persistent blocks: adjust selection\r\n if (not FPersistentBlocks) or (not FSelection.IsSelected) then\r\n Exit;\r\n\r\n if (FSelection.SelBlockFormat = bfColumn) and\r\n not (Mode in [amDeleteLine, amLineConcat, amLineBreak]) then\r\n Exit;\r\n\r\n with FSelection do\r\n begin\r\n case Mode of\r\n amInsert: // X=InsertCaretX, Y=InsertCaretY, Args[0]=char count\r\n begin\r\n if (Y = SelBegY) and (X <= SelBegX) then\r\n Inc(SelBegX, Args[0]);\r\n if (Y = SelEndY) and (X < SelEndX) then\r\n Inc(SelEndX, Args[0]);\r\n end;\r\n amDelete: // X=InsertCaretX, Y=InsertCaretY, Args[0]=char count\r\n begin\r\n if (Y = SelBegY) and (X <= SelBegX) then\r\n Dec(SelBegX, Args[0]);\r\n if (Y = SelEndY) and (X <= SelEndX) then\r\n Dec(SelEndX, Args[0]);\r\n end;\r\n amDeleteLine: // Y=line to delete\r\n begin\r\n // one line selection\r\n if (Y = SelBegY) and (SelEndY = SelBegY) then\r\n begin\r\n IsSelected := False;\r\n Selecting := False;\r\n end\r\n else\r\n begin\r\n if Y < SelBegY then\r\n Dec(SelBegY);\r\n if Y < SelEndY then\r\n Dec(SelEndY);\r\n end;\r\n end;\r\n amLineBreak: // X=BreakCaretX, Y=BreakCaretY\r\n begin\r\n if Y < SelBegY then\r\n begin\r\n // move down\r\n Inc(SelBegY);\r\n Inc(SelEndY);\r\n end\r\n else\r\n if Y <= SelEndY then\r\n begin\r\n if (Y = SelBegY) and (X <= SelBegX) then\r\n begin\r\n // LineBreak in the first line\r\n Dec(SelBegX, X);\r\n if (SelBegY = SelEndY) and (SelBlockFormat <> bfColumn) then // one line selection\r\n Dec(SelEndX, X);\r\n Inc(SelBegY);\r\n Inc(SelEndY);\r\n end\r\n else\r\n if Y < SelEndY then\r\n begin\r\n // LineBreak in selection\r\n Inc(SelEndY);\r\n end\r\n else\r\n if {(Y = SelEndY) and} (X < SelEndX) and (SelBlockFormat <> bfColumn) then\r\n begin\r\n // LineBreak in the last line\r\n SelEndX := SelEndX - X;\r\n Inc(SelEndY);\r\n end;\r\n end;\r\n end;\r\n amLineConcat: // X=CaretX, Y=CaretY, Args[0]=ConcatCaretX, Args[1]=ConcatCaretY\r\n begin\r\n if Y < SelBegY then\r\n begin\r\n // move up\r\n Dec(SelBegY);\r\n Dec(SelEndY);\r\n end\r\n else\r\n if Y <= SelEndY then\r\n begin\r\n if (Y = SelBegY) and (X <= SelBegX) then\r\n begin\r\n // LineConcat in the first line\r\n Dec(SelBegX, X - Args[X]);\r\n if (SelBegY = SelEndY) and (SelBlockFormat <> bfColumn) then // one line selection\r\n Inc(SelEndX, X - Args[X]);\r\n Dec(SelBegY);\r\n Dec(SelEndY);\r\n end\r\n else\r\n if Y < SelEndY then\r\n // LineConcat in selection\r\n Dec(SelEndY)\r\n else\r\n if {(Y = SelEndY) and} (X <= SelEndX) and (SelBlockFormat <> bfColumn) then\r\n begin\r\n // LineConcat in the last line\r\n Inc(SelEndX, LineLength[Args[1]]);\r\n Dec(SelEndY);\r\n end;\r\n end;\r\n end;\r\n end; // case\r\n\r\n if SelBegY < 0 then\r\n SelBegY := 0;\r\n if (SelEndY < SelBegY) or (SelBegY >= LineCount) then\r\n SetUnSelected;\r\n if SelBegX < 0 then\r\n SelBegX := 0;\r\n if SelEndX > Max_X then\r\n SelEndX := Max_X;\r\n if (SelEndX < SelBegX) and (SelBegY = SelEndY) then\r\n SetUnSelected;\r\n\r\n // set update region\r\n SetSelUpdateRegion(SelBegY, SelEndY);\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomEditorBase.Paint;\r\nvar\r\n I: Integer;\r\n ECR: TRect;\r\n BX, EX, BY, EY: Integer;\r\nbegin\r\n if (UpdateLock > 0) or (CellRect.Width <= 1) or (CellRect.Height <= 1) then\r\n Exit;\r\n PaintCaret(False);\r\n\r\n ECR := FEditorClient.Canvas.ClipRect;\r\n OffsetRect(ECR, -FGutterWidth, 0);\r\n if FAllRepaint then\r\n ECR := FEditorClient.BoundsRect;\r\n BX := ECR.Left div CellRect.Width - 1;\r\n EX := ECR.Right div CellRect.Width + 1;\r\n BY := ECR.Top div CellRect.Height;\r\n EY := ECR.Bottom div CellRect.Height + 1;\r\n for I := BY to EY do\r\n PaintLine(FTopRow + I, FLeftCol + BX, FLeftCol + EX + 1);\r\n\r\n PaintCaret(True);\r\n FGutter.Paint;\r\n FAllRepaint := False;\r\nend;\r\n\r\nprocedure TJvCustomEditorBase.PaintLine(Line: Integer; ColBeg, ColEnd: Integer);\r\nvar\r\n R: TRect;\r\n ColPainted: Integer;\r\nbegin\r\n if (Line < FTopRow) or (Line > FTopRow + FVisibleRowCount) then\r\n Exit;\r\n if ColBeg < FLeftCol then\r\n ColBeg := FLeftCol;\r\n if (ColEnd < 0) or (ColEnd > FLeftCol + FVisibleColCount) then\r\n ColEnd := FLeftCol + FVisibleColCount;\r\n ColEnd := Min(ColEnd, Max_X - 1);\r\n\r\n ColPainted := ColBeg;\r\n if (Line >= 0) and (Line < LineCount) then\r\n PaintLineText(Line, ColBeg, ColEnd, ColPainted)\r\n else\r\n begin\r\n if (Line = CaretY) and (CurrentLineHighlight <> clNone) and (CurrentLineHighlight <> clDefault) then\r\n FEditorClient.Canvas.Brush.Color := CurrentLineHighlight\r\n else\r\n FEditorClient.Canvas.Brush.Color := Color;\r\n FEditorClient.Canvas.FillRect(Bounds(FEditorClient.Left, (Line - FTopRow) *\r\n CellRect.Height, 1, CellRect.Height));\r\n end;\r\n {right part}\r\n R := Bounds(CalcCellRect(ColPainted - FLeftCol, Line - FTopRow).Left,\r\n (Line - FTopRow) * CellRect.Height,\r\n (FLeftCol + FVisibleColCount - ColPainted + 2) * CellRect.Width,\r\n CellRect.Height);\r\n {if the line is selected, paint right empty space with selected background}\r\n if FSelection.IsSelected and (FSelection.SelBlockFormat in [bfInclusive, bfLine, bfNonInclusive]) and\r\n (Line >= FSelection.SelBegY) and (Line < FSelection.SelEndY) then\r\n FEditorClient.Canvas.Brush.Color := FSelBackColor\r\n else\r\n if (Line = CaretY) and (CurrentLineHighlight <> clNone) and (CurrentLineHighlight <> clDefault) then\r\n FEditorClient.Canvas.Brush.Color := CurrentLineHighlight\r\n else\r\n FEditorClient.Canvas.Brush.Color := Color;\r\n FEditorClient.Canvas.FillRect(R);\r\n DrawRightMargin;\r\nend;\r\n\r\nprocedure TJvCustomEditorBase.PaintLine(Line: Integer);\r\nbegin\r\n PaintLine(Line, -1, -1);\r\nend;\r\n\r\nprocedure TJvCustomEditorBase.GetBracketHighlightAttr(Line: Integer; var Attrs: TLineAttrs);\r\n\r\n procedure GetHighlightBeginEnd(const R: TRect);\r\n var\r\n I: Integer;\r\n begin\r\n if (R.Left >= 0) and // R valid\r\n (Line >= R.Top) and (Line <= R.Bottom) and (R.Left >= 0) and (R.Right <= Max_X) then\r\n for I := R.Left to R.Right do\r\n begin\r\n if BracketHighlighting.FontColor <> clNone then\r\n Attrs[I].FC := BracketHighlighting.FontColor;\r\n if BracketHighlighting.Color <> clNone then\r\n Attrs[I].BC := BracketHighlighting.Color;\r\n Attrs[I].Border := BracketHighlighting.BorderColor;\r\n end;\r\n end;\r\n\r\nbegin\r\n if BracketHighlighting.Active then\r\n begin\r\n GetHighlightBeginEnd(FBracketHighlighting.FStart);\r\n GetHighlightBeginEnd(FBracketHighlighting.FStop);\r\n end;\r\nend;\r\n\r\n{ *****************************************************************************}\r\n{ CompareInStrInternal and CompareInTextInternal are only used by\r\n HighlightBrackets(). They are too special in their parameters and should not\r\n be moved to JvJCLUtils.pas. }\r\n\r\nfunction CompareInStrInternal(const S: string; Index: Integer; const SubStr: string; LenSubStr: Integer): Boolean;\r\n { Index is zero based for speed optimization }\r\nvar\r\n J, I, EndIndex: Integer;\r\nbegin\r\n Result := False;\r\n EndIndex := Index + LenSubStr - 1;\r\n if EndIndex < Length(S) then\r\n begin\r\n J := 0;\r\n for I := Index to EndIndex do\r\n begin\r\n if S[I + 1] <> SubStr[J + 1] then\r\n Exit;\r\n Inc(J);\r\n end;\r\n Result := True;\r\n end;\r\nend;\r\n\r\nfunction CompareInTextInternal(const S: string; Index: Integer; const SubStr: string; LenSubStr: Integer): Boolean;\r\n { Index is zero based for speed optimization }\r\n { SubStr is always in lowercase }\r\nvar\r\n I, J, EndIndex: Integer;\r\n Ch: Char;\r\nbegin\r\n Result := False;\r\n EndIndex := Index + LenSubStr - 1;\r\n if EndIndex < Length(S) then\r\n begin\r\n J := 0;\r\n for I := Index to EndIndex do\r\n begin\r\n Ch := S[I + 1];\r\n if not CharInSet(Ch, ['A'..'Z']) then\r\n begin\r\n if Ch <> SubStr[J + 1] then\r\n Exit\r\n end\r\n else\r\n begin\r\n if Char(Byte(Ch) - Ord('A') + Ord('a')) <> SubStr[J + 1] then\r\n Exit;\r\n end;\r\n Inc(J);\r\n end;\r\n Result := True;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomEditorBase.HighlightBrackets(X, Y: Integer; BetweenSearch: Boolean = False);\r\nconst\r\n Separators: TSysCharSet = [#0, ' ', '-', #13, #10, '.', ',', '/', '\\', '#', '\"', '''',\r\n ':', '+', '%', '*', '(', ')', ';', '=', '{', '}', '[', ']', '{', '}', '<', '>'];\r\nvar\r\n Text: string;\r\n SearchDir: Integer;\r\n SearchStart: string;\r\n SearchEnd: string;\r\n SearchOpen: Integer;\r\n CaseSensitive: Boolean;\r\n IsBracketCompare: Boolean;\r\n LenSearchEnd, LenSearchStart, LenText: Integer;\r\n CmpProc: function(const S: string; Index: Integer; const SubStr: string; LenSubStr: Integer): Boolean;\r\n StringMap: TDynBoolArray;\r\n R: TRect;\r\nbegin\r\n StringMap := nil;\r\n { remove last highlighting }\r\n if BracketHighlighting.FStart.Left > -1 then\r\n begin\r\n BracketHighlighting.FStart.Left := -1; // invalidate\r\n PaintLine(BracketHighlighting.FStart.Top);\r\n end;\r\n if FBracketHighlighting.FStop.Left > -1 then\r\n begin\r\n BracketHighlighting.FStop.Left := -1; // invalidate\r\n PaintLine(BracketHighlighting.FStop.Top);\r\n end;\r\n\r\n if not BracketHighlighting.Active or not Visible or not Enabled then\r\n Exit;\r\n\r\n if (Y >= 0) and GetTextLine(Y, Text) and (X >= 0) and (X < Length(Text)) then\r\n begin\r\n LenText := Length(Text);\r\n\r\n // Create string map\r\n StringMap := BracketHighlighting.CreateStringMap(Text);\r\n if StringMap[X] then\r\n Exit; // we are in a string => nothing to do\r\n\r\n SearchDir := 0; // nothing to search\r\n CaseSensitive := False;\r\n IsBracketCompare := True;\r\n\r\n // obtain search direction and end-char\r\n if CharInSet(Text[X + 1], ['(', '{', '[']) then\r\n begin\r\n SearchDir := +1;\r\n SearchStart := Text[X + 1];\r\n case Text[X + 1] of\r\n '(': SearchEnd := ')';\r\n '{': SearchEnd := '}';\r\n '[': SearchEnd := ']';\r\n end;\r\n end\r\n else\r\n if CharInSet(Text[X + 1], [')', '}', ']']) then\r\n begin\r\n SearchDir := -1;\r\n SearchStart := Text[X + 1];\r\n case Text[X + 1] of\r\n ')': SearchEnd := '(';\r\n '}': SearchEnd := '{';\r\n ']': SearchEnd := '[';\r\n end;\r\n end\r\n else\r\n begin\r\n IsBracketCompare := False;\r\n // Text search\r\n SearchStart := InternGetWordOnCaret;\r\n while (X >= 0) and not CharInSet(Text[X + 1], Separators) do\r\n Dec(X);\r\n Inc(X);\r\n\r\n GetBracketHighlightingWords(SearchDir, SearchStart, SearchEnd, CaseSensitive);\r\n\r\n{ if (SearchDir = 0) or (SearchStart = '') or (SearchEnd = '') then\r\n begin\r\n GetBracketHighlightingComments(SearchDir, SearchStart, SearchEnd);\r\n end;}\r\n end;\r\n\r\n if (SearchDir <> 0) and (SearchStart <> '') and (SearchEnd <> '') then\r\n begin\r\n BracketHighlighting.FStart.TopLeft := Point(X + 1, Y);\r\n BracketHighlighting.FStart.BottomRight := Point(X + 1 + Length(SearchStart) - 1, Y);\r\n\r\n SearchOpen := 1;\r\n LenSearchStart := Length(SearchStart);\r\n LenSearchEnd := Length(SearchEnd);\r\n\r\n if (not CaseSensitive) and not IsBracketCompare then\r\n begin\r\n SearchStart := LowerCase(SearchStart); // not AnsiLowerCase, because CompareInText uses LoCase\r\n SearchEnd := LowerCase(SearchEnd); // not AnsiLowerCase, because CompareInText uses LoCase\r\n CmpProc := CompareInTextInternal;\r\n end\r\n else\r\n CmpProc := CompareInStrInternal;\r\n\r\n repeat\r\n Inc(X, SearchDir);\r\n\r\n // -1 direction\r\n if X < 0 then\r\n begin\r\n Dec(Y);\r\n if (Y < 0) or not GetTextLine(Y, Text) then\r\n Break;\r\n StringMap := BracketHighlighting.CreateStringMap(Text);\r\n X := Length(Text) - 1;\r\n if X < 0 then\r\n Continue;\r\n if CaretY - Y > 800 then\r\n Exit;\r\n end\r\n else // +1 direction\r\n if X >= Length(Text) then\r\n begin\r\n Inc(Y);\r\n if not GetTextLine(Y, Text) then\r\n Break;\r\n StringMap := BracketHighlighting.CreateStringMap(Text);\r\n X := 0;\r\n if X >= Length(Text) then\r\n Continue;\r\n if Y - CaretY > 800 then\r\n Exit;\r\n end;\r\n\r\n if not StringMap[X] then\r\n begin\r\n if IsBracketCompare then // it is faster to compare one char\r\n begin\r\n if Text[X + 1] = SearchEnd[1] then\r\n begin\r\n Dec(SearchOpen);\r\n if SearchOpen = 0 then\r\n begin\r\n BracketHighlighting.FStop.TopLeft := Point(X + 1, Y);\r\n BracketHighlighting.FStop.BottomRight := Point(X + 1, Y);\r\n Break;\r\n end;\r\n end\r\n else\r\n if Text[X + 1] = SearchStart[1] then\r\n Inc(SearchOpen);\r\n end\r\n else\r\n begin\r\n // word pairs\r\n if CmpProc(Text, X, SearchEnd, LenSearchEnd) then // case sensitive\r\n begin\r\n if ((X = 0) or CharInSet(Text[X + 1 - 1], Separators)) and\r\n ((X + 1 + LenSearchEnd < LenText) or CharInSet(Text[X + 1 + LenSearchEnd], Separators)) then\r\n begin\r\n Dec(SearchOpen);\r\n if SearchOpen = 0 then\r\n begin\r\n // found\r\n BracketHighlighting.FStop.TopLeft := Point(X + 1, Y);\r\n BracketHighlighting.FStop.BottomRight := Point(X + 1 + Length(SearchEnd) - 1, Y);\r\n Break;\r\n end;\r\n end;\r\n end\r\n else\r\n if CmpProc(Text, X, SearchStart, LenSearchStart) then // case sensitive\r\n begin\r\n if ((X = 0) or CharInSet(Text[X + 1 - 1], Separators)) and\r\n ((X + 1 + LenSearchStart < LenText) or CharInSet(Text[X + 1 + LenSearchStart], Separators)) then\r\n Inc(SearchOpen);\r\n end;\r\n end;\r\n end;\r\n until False;\r\n\r\n { sort Start and Stop \"char\" }\r\n if BracketHighlighting.FStart.Top > BracketHighlighting.FStop.Top then\r\n begin\r\n R := BracketHighlighting.FStart;\r\n BracketHighlighting.FStart := BracketHighlighting.FStop;\r\n BracketHighlighting.FStop := R;\r\n end\r\n else\r\n if (BracketHighlighting.FStart.Top = BracketHighlighting.FStop.Top) and\r\n (BracketHighlighting.FStart.Left > BracketHighlighting.FStop.Left) then\r\n begin\r\n R := BracketHighlighting.FStart;\r\n BracketHighlighting.FStart := BracketHighlighting.FStop;\r\n BracketHighlighting.FStop := R;\r\n end;\r\n\r\n { The caret must be between the start and stop \"char\" }\r\n if BracketHighlighting.FStart.Top = CaretY then\r\n begin\r\n if BracketHighlighting.FStart.Left > CaretX + 1 then\r\n BracketHighlighting.FStop.Left := -1; // invalidate\r\n end;\r\n if BracketHighlighting.FStop.Top = CaretY then\r\n begin\r\n if BracketHighlighting.FStop.Right < CaretX then\r\n BracketHighlighting.FStop.Left := -1; // invalidate\r\n end;\r\n if (BracketHighlighting.FStop.Top < CaretY) or (BracketHighlighting.FStart.Top > CaretY) then\r\n BracketHighlighting.FStop.Left := -1; // invalidate\r\n\r\n\r\n { Do only highlight if start and stop are found }\r\n if BracketHighlighting.FStop.Left = -1 then\r\n BracketHighlighting.FStart.Left := -1 // invalidate\r\n else\r\n begin\r\n PaintLine(BracketHighlighting.FStart.Top);\r\n PaintLine(BracketHighlighting.FStop.Top);\r\n end;\r\n end;\r\n end;\r\n\r\n if not BetweenSearch and BracketHighlighting.ShowBetweenHighlighting and\r\n (BracketHighlighting.FStop.Left = -1) and\r\n (Y >= 0) and (X >= 0) and GetTextLine(Y, Text) then\r\n begin\r\n // find ending bracket\r\n StringMap := BracketHighlighting.CreateStringMap(Text);\r\n SearchOpen := 1;\r\n repeat\r\n if X >= Length(Text) then\r\n begin\r\n Inc(Y);\r\n if not GetTextLine(Y, Text) then\r\n Break;\r\n StringMap := BracketHighlighting.CreateStringMap(Text);\r\n X := 0;\r\n if X >= Length(Text) then\r\n Continue;\r\n if Y - CaretY > 800 then\r\n Exit;\r\n end;\r\n\r\n if not StringMap[X] then\r\n begin\r\n case Text[X + 1] of\r\n '(', '{', '[':\r\n Inc(SearchOpen);\r\n ')', '}', ']':\r\n begin\r\n Dec(SearchOpen);\r\n if SearchOpen = 0 then\r\n begin\r\n HighlightBrackets(X, Y, True);\r\n Break;\r\n end;\r\n end;\r\n end;\r\n end;\r\n Inc(X);\r\n until False;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomEditorBase.GetBracketHighlightingWords(var Direction: Integer;\r\n const Start: string; var Stop: string; var CaseSensitive: Boolean);\r\nvar\r\n I, Ps: Integer;\r\n S: string;\r\n CmpProc: function(const S1, S2: string): Integer;\r\nbegin\r\n CaseSensitive := BracketHighlighting.CaseSensitiveWordPairs;\r\n if CaseSensitive then\r\n CmpProc := AnsiCompareStr\r\n else\r\n CmpProc := AnsiCompareText;\r\n\r\n for I := 0 to BracketHighlighting.WordPairs.Count - 1 do\r\n begin\r\n S := BracketHighlighting.WordPairs[I];\r\n Ps := Pos('=', S);\r\n if Ps > 0 then\r\n begin\r\n if CmpProc(Copy(S, 1, Ps - 1), Start) = 0 then\r\n begin\r\n Stop := Copy(S, Ps + 1, MaxInt);\r\n Direction := +1;\r\n Break;\r\n end;\r\n if CmpProc(Copy(S, Ps + 1, MaxInt), Start) = 0 then\r\n begin\r\n Stop := Copy(S, 1, Ps - 1);\r\n Direction := -1;\r\n Break;\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\n{ find the font resource for LA }\r\n\r\nfunction TJvCustomEditorBase.FontCacheFind(LA: TLineAttr): TFont;\r\nvar\r\n I: Integer;\r\nbegin\r\n // find the font instance\r\n for I := 0 to FFontCache.Count - 1 do\r\n begin\r\n Result := TFont(FFontCache.Items[I]);\r\n if (Result.Style = LA.Style) and (Result.Color = LA.FC) then\r\n Exit;\r\n end;\r\n // create a new font instance\r\n Result := TFont.Create;\r\n Result.Assign(FEditorClient.Canvas.Font); // copy default font\r\n Result.Style := LA.Style;\r\n Result.Color := LA.FC;\r\n FFontCache.Add(Result); { store in FontCache }\r\nend;\r\n\r\n{ clear the font resource cache }\r\n\r\nprocedure TJvCustomEditorBase.FontCacheClear;\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := 0 to FFontCache.Count - 1 do\r\n TFont(FFontCache.Items[I]).Free;\r\n FFontCache.Clear;\r\nend;\r\n\r\nprocedure TJvCustomEditorBase.DrawRightMargin;\r\nvar\r\n F: Integer;\r\nbegin\r\n if FRightMarginVisible and (FRightMargin > FLeftCol) and\r\n (FRightMargin < FLastVisibleCol + 3) then\r\n with FEditorClient.Canvas do\r\n begin\r\n { we paint RightMargin Line [translated] }\r\n Pen.Color := FRightMarginColor;\r\n F := CalcCellRect(FRightMargin - FLeftCol, 0).Left;\r\n MoveTo(F, FEditorClient.Top);\r\n LineTo(F, FEditorClient.Top + FEditorClient.Height);\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomEditorBase.CheckBeyondEOL(var CX: Integer; CY: Integer);\r\nbegin\r\n if not CursorBeyondEOL then\r\n begin\r\n if (CY >= 0) and (CY < LineCount) then\r\n begin\r\n if CX >= GetLineLength(CY) then\r\n CX := GetLineLength(CY);\r\n end\r\n else\r\n CX := 0;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomEditorBase.Mouse2Cell(X, Y: Integer; var CX, CY: Integer);\r\nbegin\r\n CX := Round((X - FEditorClient.Left) / CellRect.Width);\r\n CY := (Y - FEditorClient.Top) div CellRect.Height;\r\nend;\r\n\r\nprocedure TJvCustomEditorBase.Mouse2Caret(X, Y: Integer; var CX, CY: Integer);\r\nbegin\r\n Mouse2Cell(X, Y, CX, CY);\r\n if CX < 0 then\r\n CX := 0;\r\n if CY < 0 then\r\n CY := 0;\r\n CX := CX + FLeftCol;\r\n CY := CY + FTopRow;\r\n if CX > FLastVisibleCol then\r\n CX := FLastVisibleCol;\r\n if (CY > LineCount - 1) and not CursorBeyondEOF then\r\n CY := LineCount - 1;\r\n CheckBeyondEOL(CX, CY);\r\nend;\r\n\r\nprocedure TJvCustomEditorBase.MousePosToCell(X, Y: Integer; var CX, CY: Integer);\r\nbegin\r\n CX := (X - FEditorClient.Left) div CellRect.Width; // difference to Mouse2Caret\r\n CY := (Y - FEditorClient.Top) div CellRect.Height;\r\n if CX < 0 then\r\n CX := 0;\r\n if CY < 0 then\r\n CY := 0;\r\n CX := CX + FLeftCol;\r\n CY := CY + FTopRow;\r\n if CX > FLastVisibleCol then\r\n CX := FLastVisibleCol;\r\n if CY > LineCount - 1 then // difference to Mouse2Caret\r\n CY := LineCount - 1;\r\nend;\r\n\r\nprocedure TJvCustomEditorBase.CaretChanged(LastCaretX, LastCaretY: Integer);\r\nbegin\r\n if Assigned(FOnCaretChanged) then\r\n FOnCaretChanged(Self, LastCaretX, LastCaretY);\r\nend;\r\n\r\nprocedure TJvCustomEditorBase.CaretCoord(X, Y: Integer; var CX, CY: Integer);\r\nbegin\r\n CX := X - FLeftCol;\r\n CY := Y - FTopRow;\r\n if CX < 0 then\r\n CX := 0;\r\n if CY < 0 then\r\n CY := 0;\r\n CX := CellRect.Width * CX;\r\n CY := CellRect.Height * CY;\r\nend;\r\n\r\nfunction TJvCustomEditorBase.PosFromMouse(X, Y: Integer): Integer;\r\nvar\r\n X1, Y1: Integer;\r\nbegin\r\n Mouse2Caret(X, Y, X1, Y1);\r\n if (X1 < 0) or (Y1 < 0) then\r\n Result := -1\r\n else\r\n Result := PosFromCaret(X1, Y1);\r\nend;\r\n\r\nprocedure TJvCustomEditorBase.SetCaretInternal(X, Y: Integer);\r\nvar\r\n R: TRect;\r\n LastCaretX, LastCaretY: Integer;\r\nbegin\r\n if (X = FCaretX) and (Y = FCaretY) then\r\n Exit;\r\n // To scroll the image\r\n if not FCursorBeyondEOF then\r\n Y := Min(Y, LineCount - 1);\r\n Y := Max(Y, 0);\r\n X := Min(X, Max_X);\r\n X := Max(X, 0);\r\n CheckBeyondEOL(X, Y);\r\n\r\n if Y < FTopRow then\r\n SetLeftTop(FLeftCol, Y)\r\n else\r\n if Y > Max(FLastVisibleRow, 0) then\r\n SetLeftTop(FLeftCol, Y - FVisibleRowCount + 1);\r\n if X < 0 then\r\n X := 0;\r\n if X < FLeftCol then\r\n SetLeftTop(X, FTopRow)\r\n else\r\n if X > FLastVisibleCol then\r\n SetLeftTop(X - FVisibleColCount + 1, FTopRow);\r\n\r\n if Focused then {mac: do not move Caret when not focused!}\r\n begin\r\n R := CalcCellRect(X - FLeftCol, Y - FTopRow);\r\n SetCaretPos(R.Left - 1, R.Top + 1);\r\n end;\r\n\r\n if (FCaretX <> X) or (FCaretY <> Y) then\r\n begin\r\n LastCaretX := FCaretX;\r\n LastCaretY := FCaretY;\r\n FCaretX := X;\r\n FCaretY := Y;\r\n if (CurrentLineHighlight <> clNone) and (CurrentLineHighlight <> clDefault) then\r\n begin\r\n PaintLine(LastCaretY);\r\n PaintLine(FCaretY);\r\n end;\r\n StatusChanged;\r\n CaretChanged(LastCaretX, LastCaretY);\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomEditorBase.NotUndoable;\r\nbegin\r\n FUndoBuffer.Clear;\r\nend;\r\n\r\nprocedure TJvCustomEditorBase.NotRedoable;\r\nbegin\r\n FUndoBuffer.ClearRedo;\r\nend;\r\n\r\nprocedure TJvCustomEditorBase.LineDeleted(Line: Integer);\r\nbegin\r\n if Assigned(FOnLineDeleted) then\r\n FOnLineDeleted(Self, Line);\r\nend;\r\n\r\nprocedure TJvCustomEditorBase.LineInserted(Line: Integer);\r\nbegin\r\n if Assigned(FOnLineInserted) then\r\n FOnLineInserted(Self, Line);\r\nend;\r\n\r\nprocedure TJvCustomEditorBase.ChangeBookmark(Bookmark: TBookmarkNum;\r\n Valid: Boolean);\r\n\r\n procedure SetXY(X, Y: Integer);\r\n var\r\n X1, Y1: Integer;\r\n begin\r\n X1 := FLeftCol;\r\n Y1 := FTopRow;\r\n if (Y < FTopRow) or (Y > FLastVisibleRow) then\r\n Y1 := Y - (FVisibleRowCount div 2);\r\n if (X < FLeftCol) or (X > FVisibleColCount) then\r\n X1 := X - (FVisibleColCount div 2);\r\n SetLeftTop(X1, Y1);\r\n SetCaret(X, Y);\r\n end;\r\n\r\nbegin\r\n if Valid then\r\n if Bookmarks[Bookmark].Valid and (Bookmarks[Bookmark].Y = FCaretY) then\r\n Bookmarks[Bookmark].Valid := False\r\n else\r\n begin\r\n Bookmarks[Bookmark].X := FCaretX;\r\n Bookmarks[Bookmark].Y := FCaretY;\r\n Bookmarks[Bookmark].Valid := True;\r\n end\r\n else\r\n if Bookmarks[Bookmark].Valid then\r\n SetXY(Bookmarks[Bookmark].X, Bookmarks[Bookmark].Y);\r\n BookmarkChanged(Bookmark);\r\nend;\r\n\r\nprocedure TJvCustomEditorBase.BeginRecord;\r\nbegin\r\n FMacro := '';\r\n FRecording := True;\r\n StatusChanged;\r\nend;\r\n\r\nprocedure TJvCustomEditorBase.EndRecord(var AMacro: TMacro);\r\nbegin\r\n FRecording := False;\r\n AMacro := FMacro;\r\n StatusChanged;\r\nend;\r\n\r\nprocedure TJvCustomEditorBase.PlayMacro(const AMacro: TMacro);\r\nvar\r\n I: Integer;\r\nbegin\r\n BeginUpdate;\r\n BeginCompound;\r\n try\r\n I := 1;\r\n while I < Length(AMacro) do\r\n begin\r\n {$IFDEF UNICODE}\r\n Command(Word(AMacro[I]) + Word(AMacro[I + 1]) shl 16);\r\n {$ELSE}\r\n Command(Byte(AMacro[I]) + Byte(AMacro[I + 1]) shl 8);\r\n {$ENDIF UNICODE}\r\n Inc(I, 2);\r\n end;\r\n finally\r\n EndCompound;\r\n EndUpdate;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomEditorBase.SetLeftTop(ALeftCol, ATopRow: Integer);\r\nbegin\r\n if ALeftCol < 0 then\r\n ALeftCol := 0;\r\n if FLeftCol <> ALeftCol then\r\n begin\r\n FScrollBarHorz.Position := ALeftCol;\r\n Scroll(False, ALeftCol);\r\n end;\r\n if ATopRow < 0 then\r\n ATopRow := 0;\r\n if FTopRow <> ATopRow then\r\n begin\r\n FScrollBarVert.Position := ATopRow;\r\n Scroll(True, ATopRow);\r\n end;\r\nend;\r\n\r\nfunction TJvCustomEditorBase.CanUndo: Boolean;\r\nbegin\r\n Result := FUndoBuffer.CanUndo;\r\nend;\r\n\r\nfunction TJvCustomEditorBase.CanRedo: Boolean;\r\nbegin\r\n Result := FUndoBuffer.CanRedo;\r\nend;\r\n\r\nfunction TJvCustomEditorBase.CanCopy: Boolean;\r\nbegin\r\n Result := FSelection.IsSelected and not IsEmptySelection;\r\nend;\r\n\r\nfunction TJvCustomEditorBase.CanPaste: Boolean;\r\nvar\r\n H: THandle;\r\nbegin\r\n Result := False;\r\n if (FCaretY >= LineCount) and (LineCount > 0) then\r\n Exit;\r\n\r\n try\r\n H := Clipboard.GetAsHandle(CF_TEXT);\r\n if H <> 0 then\r\n Result := (GlobalSize(H) > 0);\r\n except\r\n Result := False;\r\n end;\r\nend;\r\n\r\nfunction TJvCustomEditorBase.CanCut: Boolean;\r\nbegin\r\n Result := CanCopy and not ReadOnly;\r\nend;\r\n\r\nfunction TJvCustomEditorBase.CanSelectAll: Boolean;\r\nvar\r\n MaxCol, MaxLine: Integer;\r\nbegin\r\n MaxLine := LineCount - 1;\r\n if MaxLine > 0 then\r\n MaxCol := LineLength[MaxLine]\r\n else\r\n MaxCol := 0;\r\n Result := (FSelection.SelBegX > 0) or (FSelection.SelBegY > 0) or\r\n (FSelection.SelEndX < MaxCol) or (FSelection.SelEndY < MaxLine);\r\nend;\r\n\r\nprocedure TJvCustomEditorBase.SelectAll;\r\nbegin\r\n SelectRange(0, 0, Max_X, MaxInt);\r\nend;\r\n\r\nfunction TJvCustomEditorBase.HasSelection: Boolean;\r\nbegin\r\n Result := FSelection.IsSelected and not IsEmptySelection;\r\nend;\r\n\r\nprocedure TJvCustomEditorBase.ClipboardCut;\r\nbegin\r\n ClipboardCopy;\r\n DeleteSelected;\r\nend;\r\n\r\nprocedure TJvCustomEditorBase.Deselect;\r\nbegin\r\n SetUnSelected;\r\nend;\r\n\r\nprocedure TJvCustomEditorBase.Redo;\r\nbegin\r\n FUndoBuffer.Redo;\r\nend;\r\n\r\nprocedure TJvCustomEditorBase.Undo;\r\nbegin\r\n FUndoBuffer.Undo;\r\nend;\r\n\r\nprocedure TJvCustomEditorBase.SelectRange(BegX, BegY, EndX, EndY: Integer);\r\nbegin\r\n { --- UNDO --- }\r\n TJvSelectUndo.Create(Self, FCaretX, FCaretY);\r\n { --- /UNDO ---}\r\n with FSelection do\r\n begin\r\n IsSelected := False;\r\n Selecting := False;\r\n\r\n if BegX < 0 then\r\n BegX := 0;\r\n if BegY < 0 then\r\n BegY := 0;\r\n if EndX > Max_X then\r\n EndX := Max_X;\r\n if (EndY < BegY) or (BegY >= LineCount) then\r\n Exit;\r\n if EndY >= LineCount then\r\n EndY := LineCount - 1;\r\n if EndY < 0 then\r\n Exit;\r\n\r\n SelBegX := BegX;\r\n SelBegY := BegY;\r\n SelEndX := EndX;\r\n SelEndY := EndY;\r\n SelLineOrgBegX := BegX;\r\n SelLineOrgEndX := BegY;\r\n IsSelected := not IsEmptySelection;\r\n Selecting := False;\r\n\r\n SetSelUpdateRegion(SelBegY, SelEndY);\r\n end;\r\n if FCompound = 0 then\r\n PaintSelection;\r\nend;\r\n\r\nfunction TJvCustomEditorBase.CalcCellRect(X, Y: Integer): TRect;\r\nbegin\r\n Result := Bounds(\r\n FEditorClient.Left + X * CellRect.Width + 1,\r\n FEditorClient.Top + Y * CellRect.Height,\r\n CellRect.Width,\r\n CellRect.Height)\r\nend;\r\n\r\nprocedure TJvCustomEditorBase.SetCaret(X, Y: Integer);\r\nbegin\r\n if (X = FCaretX) and (Y = FCaretY) then\r\n Exit;\r\n {--- UNDO ---}\r\n TJvCaretUndo.Create(Self, FCaretX, FCaretY);\r\n {--- /UNDO ---}\r\n SetCaretInternal(X, Y);\r\n if UpdateLock = 0 then\r\n StatusChanged;\r\nend;\r\n\r\n{ It returns on the index of pos - to the number of symbol - its coordinate.\r\n Returns on index Pos - to number of the character - his(its) coordinates.\r\n [translated]\r\n}\r\nprocedure TJvCustomEditorBase.CaretFromPos(Pos: Integer; var X, Y: Integer);\r\nvar\r\n I, Len, P: Integer;\r\nbegin\r\n X := -1;\r\n Y := -1;\r\n if Pos < 0 then\r\n Exit;\r\n P := 0;\r\n\r\n for I := 0 to LineCount - 1 do\r\n begin\r\n Len := LineLength[I];\r\n Inc(P, Len);\r\n if P >= Pos then\r\n begin\r\n Dec(P, Len);\r\n Y := I;\r\n X := Pos - P;\r\n Break;\r\n end;\r\n Inc(P, sLineBreakLen);\r\n end;\r\nend;\r\n\r\nfunction TJvCustomEditorBase.PosFromCaret(X, Y: Integer): Integer;\r\nvar\r\n I: Integer;\r\n Len: Integer;\r\nbegin\r\n if Cardinal(Y) >= Cardinal(LineCount) then\r\n Result := -1\r\n else\r\n begin\r\n Result := 0;\r\n for I := 0 to Y - 1 do\r\n Inc(Result, LineLength[I] + sLineBreakLen);\r\n Len := LineLength[Y];\r\n if X < Len then\r\n Inc(Result, X)\r\n else\r\n Inc(Result, Len);\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomEditorBase.PaintCaret(bShow: Boolean);\r\nvar\r\n R: TRect;\r\nbegin\r\n if FHideCaret then\r\n Exit;\r\n if not bShow then\r\n Windows.HideCaret(Handle)\r\n else\r\n if Focused then\r\n begin\r\n R := CalcCellRect(FCaretX - FLeftCol, FCaretY - FTopRow);\r\n if (R.Left >= 0) and (R.Left >= FGutterWidth) then\r\n SetCaretPos(R.Left - 1, R.Top + 1)\r\n else\r\n SetCaretPos(-MAXSHORT, -MAXSHORT); // hide caret without Windows.HideCaret\r\n ShowCaret(Handle);\r\n end\r\nend;\r\n\r\nfunction TJvCustomEditorBase.GetTextLen: Integer;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := 0;\r\n for I := 0 to LineCount - 1 do\r\n Inc(Result, LineLength[I] + sLineBreakLen);\r\nend;\r\n\r\nprocedure TJvCustomEditorBase.BeginUpdate;\r\nbegin\r\n LockUpdate;\r\nend;\r\n\r\nprocedure TJvCustomEditorBase.EndUpdate;\r\nbegin\r\n Assert(FUpdateLock > 0); { Error }\r\n UnlockUpdate;\r\n if UpdateLock = 0 then\r\n begin\r\n FAllRepaint := True;\r\n UpdateEditorSize;\r\n StatusChanged;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomEditorBase.MakeRowVisible(ARow: Integer);\r\nbegin\r\n if (ARow < FTopRow) or (ARow > FLastVisibleRow) then\r\n begin\r\n ARow := ARow - Trunc(VisibleRowCount / 2); {mac: bugfix - FCaretY}\r\n if ARow < 0 then\r\n ARow := 0;\r\n SetLeftTop(FLeftCol, ARow);\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomEditorBase.Command(ACommand: TEditCommand);\r\nvar\r\n X, Y: Integer;\r\n CaretUndo: Boolean;\r\n F: Integer;\r\n iBeg: Integer;\r\n BlockFormat: TJvSelBlockFormat;\r\ntype\r\n TPr = procedure of object;\r\n\r\n procedure DoAndCorrectXY(Pr: TPr);\r\n begin\r\n Pr;\r\n X := CaretX;\r\n Y := CaretY;\r\n CaretUndo := False;\r\n end;\r\n\r\n function Com(const Args: array of TEditCommand): Boolean;\r\n var\r\n I: Integer;\r\n begin\r\n for I := 0 to High(Args) do\r\n if Args[I] = ACommand then\r\n begin\r\n Result := True;\r\n Exit;\r\n end;\r\n Result := False;\r\n end;\r\n\r\n procedure SetSel1(X, Y: Integer);\r\n begin\r\n SetSel(X, Y);\r\n CaretUndo := False;\r\n end;\r\n\r\n procedure IncCaretX(var X, Y: Integer; XOffset: Integer);\r\n begin\r\n Inc(X, XOffset);\r\n if not CursorBeyondEOL then\r\n begin\r\n if X < 0 then\r\n begin\r\n if (Y > 0) and (Y <= LineCount) then\r\n begin\r\n Dec(Y);\r\n X := LineLength[Y];\r\n end;\r\n end\r\n else if (Y >= 0) and (Y < LineCount) and (X > LineLength[Y]) then\r\n begin\r\n if not CursorBeyondEOF and (Y < LineCount - 1) then\r\n begin\r\n Inc(Y);\r\n X := 0;\r\n end;\r\n end;\r\n end;\r\n end;\r\n\r\nbegin\r\n X := CaretX;\r\n Y := CaretY;\r\n CaretUndo := True;\r\n // LockUpdate;\r\n { macro recording }\r\n if Recording and not Com([ecRecordMacro, ecBeginCompound]) and (Compound = 0) then\r\n begin\r\n {$IFDEF UNICODE}\r\n FMacro := FMacro + Char(LoWord(ACommand)) + Char(HiWord(ACommand));\r\n {$ELSE}\r\n FMacro := FMacro + AnsiChar(Lo(ACommand)) + AnsiChar(Hi(ACommand));\r\n {$ENDIF UNICODE}\r\n end;\r\n\r\n PaintCaret(False);\r\n try\r\n case ACommand of\r\n { caret movements }\r\n ecLeft, ecRight, ecSelLeft, ecSelRight:\r\n begin\r\n if Com([ecSelLeft, ecSelRight]) and IsNewSelection then\r\n SetSel1(X, Y);\r\n if Com([ecLeft, ecSelLeft]) then\r\n IncCaretX(X, Y, -1)\r\n else\r\n IncCaretX(X, Y, +1);\r\n if Com([ecSelLeft, ecSelRight]) then\r\n SetSel1(X, Y)\r\n else\r\n PersistentBlocksSetUnSelected;\r\n end;\r\n ecUp, ecDown, ecSelUp, ecSelDown:\r\n if Com([ecUp, ecSelUp]) or (Y < Rows - 1) or CursorBeyondEOF then\r\n begin\r\n if Com([ecSelUp, ecSelDown]) and IsNewSelection then\r\n SetSel1(X, Y);\r\n if Com([ecUp, ecSelUp]) then\r\n Dec(Y)\r\n else\r\n Inc(Y);\r\n if Com([ecSelUp, ecSelDown]) then\r\n SetSel1(X, Y)\r\n else\r\n PersistentBlocksSetUnSelected;\r\n end;\r\n ecSelColumnLeft, ecSelColumnRight, ecSelColumnUp, ecSelColumnDown:\r\n begin\r\n FSelection.SelBlockFormat := bfColumn;\r\n case ACommand of\r\n ecSelColumnLeft: Command(ecSelLeft);\r\n ecSelColumnRight: Command(ecSelRight);\r\n ecSelColumnUp: Command(ecSelUp);\r\n ecSelColumnDown: Command(ecSelDown);\r\n end;\r\n Exit;\r\n end;\r\n ecScrollLineUp, ecScrollLineDown:\r\n begin\r\n if not ((ACommand = ecScrollLineDown) and\r\n (Y >= LineCount - 1) and (Y = TopRow)) then\r\n begin\r\n if ACommand = ecScrollLineUp then\r\n F := -1\r\n else\r\n F := 1;\r\n FScrollBarVert.Position := FScrollBarVert.Position + F;\r\n Scroll(True, FScrollBarVert.Position);\r\n end;\r\n if Y < FTopRow then\r\n Y := FTopRow\r\n else\r\n if Y > FLastVisibleRow then\r\n Y := FLastVisibleRow;\r\n end;\r\n ecBeginLine, ecSelBeginLine, ecBeginDoc, ecSelBeginDoc,\r\n ecEndLine, ecSelEndLine, ecEndDoc, ecSelEndDoc:\r\n begin\r\n if Com([ecSelBeginLine, ecSelBeginDoc, ecSelEndLine, ecSelEndDoc]) and\r\n IsNewSelection then\r\n SetSel1(CaretX, Y);\r\n if Com([ecBeginLine, ecSelBeginLine]) then\r\n X := 0\r\n else\r\n if Com([ecBeginDoc, ecSelBeginDoc]) then\r\n begin\r\n X := 0;\r\n Y := 0;\r\n SetLeftTop(0, 0);\r\n end\r\n else\r\n if Com([ecEndLine, ecSelEndLine]) then\r\n if Cardinal(Y) < Cardinal(LineCount) then\r\n X := LineLength[Y]\r\n else\r\n X := 0\r\n else\r\n if Com([ecEndDoc, ecSelEndDoc]) then\r\n begin\r\n Y := LineCount - 1;\r\n if Y >= 0 then\r\n begin\r\n X := LineLength[Y];\r\n SetLeftTop(X - FVisibleColCount, Y - FVisibleRowCount div 2);\r\n end;\r\n end;\r\n if Com([ecSelBeginLine, ecSelBeginDoc, ecSelEndLine, ecSelEndDoc]) then\r\n SetSel1(X, Y)\r\n else\r\n PersistentBlocksSetUnSelected;\r\n end;\r\n ecPrevPage:\r\n begin\r\n FScrollBarVert.Position := FScrollBarVert.Position - FScrollBarVert.LargeChange;\r\n Scroll(True, FScrollBarVert.Position);\r\n Y := Y - FVisibleRowCount;\r\n PersistentBlocksSetUnSelected;\r\n end;\r\n ecNextPage:\r\n begin\r\n FScrollBarVert.Position := FScrollBarVert.Position + FScrollBarVert.LargeChange;\r\n Scroll(True, FScrollBarVert.Position);\r\n Y := Y + FVisibleRowCount;\r\n PersistentBlocksSetUnSelected;\r\n end;\r\n ecSelPrevPage:\r\n begin\r\n BeginUpdate;\r\n SetSel1(X, Y);\r\n FScrollBarVert.Position := FScrollBarVert.Position - FScrollBarVert.LargeChange;\r\n Scroll(True, FScrollBarVert.Position);\r\n Y := Y - FVisibleRowCount;\r\n SetSel1(X, Y);\r\n EndUpdate;\r\n end;\r\n ecSelNextPage:\r\n begin\r\n BeginUpdate;\r\n SetSel1(X, Y);\r\n FScrollBarVert.Position := FScrollBarVert.Position + FScrollBarVert.LargeChange;\r\n Scroll(True, FScrollBarVert.Position);\r\n Y := Y + FVisibleRowCount;\r\n if Y <= LineCount - 1 then\r\n SetSel1(X, Y)\r\n else\r\n SetSel1(X, LineCount - 1);\r\n EndUpdate;\r\n end;\r\n ecWindowTop:\r\n Y := FTopRow;\r\n ecWindowBottom:\r\n Y := FTopRow + FVisibleRowCount - 1;\r\n { editing }\r\n ecCharFirst..ecCharLast:\r\n if not FReadOnly then\r\n begin\r\n InsertChar(Word(ACommand - ecCharFirst));\r\n Exit;\r\n end;\r\n ecInsertPara:\r\n if not FReadOnly then\r\n begin\r\n InsertChar(13);\r\n Exit;\r\n end\r\n else\r\n if Y < LineCount - 1 then\r\n begin\r\n Inc(Y);\r\n if LineLength[Y] > 0 then\r\n begin\r\n iBeg := FindNotBlankCharPosInLine(Y) - 1;\r\n if iBeg < X then\r\n X := iBeg;\r\n end;\r\n end;\r\n ecIndent:\r\n if not FReadOnly and FSelection.IsSelected then\r\n begin\r\n if FSelection.SelBlockFormat = bfColumn then\r\n IndentColumns(FSelection.SelBegX, FSelection.SelBegY, FSelection.SelEndY)\r\n else\r\n IndentSelLines(False);\r\n Exit;\r\n end;\r\n ecUnindent:\r\n if not FReadOnly and FSelection.IsSelected then\r\n begin\r\n if FSelection.SelBlockFormat = bfColumn then\r\n UnIndentColumns(FSelection.SelBegX, FSelection.SelBegY, FSelection.SelEndY)\r\n else\r\n IndentSelLines(True);\r\n Exit;\r\n end;\r\n ecChangeInsertMode:\r\n begin\r\n FInsertMode := not FInsertMode;\r\n StatusChanged;\r\n end;\r\n ecInclusiveBlock..ecNonInclusiveBlock:\r\n begin\r\n if FSelection.SelBlockFormat = TJvSelBlockFormat(ACommand - ecInclusiveBlock) then\r\n Exit;\r\n\r\n if FSelection.IsSelected then\r\n begin\r\n // convert line block to others and visi versa\r\n if ACommand <> ecLineBlock then\r\n begin\r\n if FSelection.SelBlockFormat = bfLine then\r\n AdjustSelLineMode(True); // Restore :=\r\n end\r\n else\r\n AdjustSelLineMode(False); // Restore :=\r\n end;\r\n\r\n FSelection.SelBlockFormat := TJvSelBlockFormat(ACommand - ecInclusiveBlock);\r\n PaintSelection;\r\n StatusChanged;\r\n end;\r\n ecClipboardCut:\r\n if not FReadOnly then\r\n DoAndCorrectXY(ClipboardCut);\r\n ecClipboardCopy:\r\n ClipboardCopy;\r\n ecClipboardPaste:\r\n if not FReadOnly then\r\n DoAndCorrectXY(ClipboardPaste);\r\n ecDeleteSelected:\r\n if not FReadOnly and FSelection.IsSelected then\r\n DoAndCorrectXY(DeleteSelected);\r\n ecDeleteWord:\r\n if not FReadOnly then\r\n begin\r\n Command(ecBeginCompound);\r\n Command(ecBeginUpdate);\r\n try\r\n BlockFormat := FSelection.SelBlockFormat;\r\n FSelection.SelBlockFormat := bfNonInclusive; // no bfLine, bfColumn, bfInclusive\r\n Command(ecSelNextWord);\r\n FSelection.SelBlockFormat := BlockFormat;\r\n\r\n Command(ecDeleteSelected);\r\n finally\r\n Command(ecEndUpdate);\r\n Command(ecEndCompound);\r\n end;\r\n Exit;\r\n end;\r\n ecSelAll:\r\n begin\r\n SelectAll;\r\n Exit;\r\n end;\r\n ecUndo:\r\n if not FReadOnly then\r\n begin\r\n FUndoBuffer.Undo;\r\n PaintCaret(True);\r\n Exit;\r\n end;\r\n ecRedo:\r\n if not FReadOnly then\r\n begin\r\n FUndoBuffer.Redo;\r\n PaintCaret(True);\r\n Exit;\r\n end;\r\n ecBeginCompound:\r\n BeginCompound;\r\n ecEndCompound:\r\n EndCompound;\r\n ecSetBookmark0..ecSetBookmark9:\r\n ChangeBookmark(ACommand - ecSetBookmark0, True);\r\n ecGotoBookmark0..ecGotoBookmark9:\r\n begin\r\n ChangeBookmark(ACommand - ecGotoBookmark0, False);\r\n X := CaretX;\r\n Y := CaretY;\r\n end;\r\n ecCompletionIdentifiers:\r\n if not FReadOnly then\r\n begin\r\n Completion.DoCompletion(cmIdentifiers);\r\n PaintCaret(True);\r\n Exit;\r\n end;\r\n ecCompletionTemplates:\r\n if not FReadOnly then\r\n begin\r\n Completion.DoCompletion(cmTemplates);\r\n PaintCaret(True);\r\n Exit;\r\n end;\r\n ecBeginUpdate:\r\n BeginUpdate;\r\n ecEndUpdate:\r\n EndUpdate;\r\n ecRecordMacro:\r\n if FRecording then\r\n EndRecord(FDefMacro)\r\n else\r\n BeginRecord;\r\n ecPlayMacro:\r\n begin\r\n PlayMacro(FDefMacro);\r\n Exit;\r\n end;\r\n else\r\n if DoCommand(ACommand, X, Y, CaretUndo) then\r\n Exit;\r\n end;\r\n\r\n if CaretUndo then\r\n SetCaret(X, Y)\r\n else\r\n SetCaretInternal(X, Y);\r\n finally\r\n // UnlockUpdate;\r\n PaintCaret(True);\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomEditorBase.PostCommand(ACommand: TEditCommand);\r\nbegin\r\n PostMessage(Handle, WM_EDITCOMMAND, ACommand, 0);\r\nend;\r\n\r\nprocedure TJvCustomEditorBase.IndentLines(UnIndent: Boolean; BegY, EndY: Integer);\r\nbegin\r\n if UnIndent then\r\n UnIndentColumns(0, BegY, EndY)\r\n else\r\n IndentColumns(0, BegY, EndY);\r\nend;\r\n\r\nprocedure TJvCustomEditorBase.IndentSelLines(UnIndent: Boolean);\r\nvar\r\n BegNotBlank, EndNotBlank: Integer;\r\n BegY, EndY: Integer;\r\nbegin\r\n with FSelection do\r\n begin\r\n if (not IsSelected) or (SelBlockFormat = bfColumn) then\r\n Exit;\r\n\r\n BegY := SelBegY;\r\n EndY := SelEndY;\r\n if SelEndX = 0 then\r\n Dec(EndY);\r\n if BegY > EndY then\r\n Exit;\r\n\r\n BegNotBlank := FindNotBlankCharPosInLine(BegY) - 1;\r\n EndNotBlank := FindNotBlankCharPosInLine(EndY) - 1;\r\n\r\n IndentLines(UnIndent, BegY, EndY);\r\n\r\n // to relative values\r\n BegNotBlank := (FindNotBlankCharPosInLine(BegY) - 1) - BegNotBlank;\r\n EndNotBlank := (FindNotBlankCharPosInLine(EndY) - 1) - EndNotBlank;\r\n\r\n if UnIndent then\r\n begin\r\n // adjust selection\r\n Inc(SelBegX, BegNotBlank);\r\n if SelBegX < 0 then\r\n SelBegX := 0;\r\n\r\n if SelEndX > 0 then\r\n Inc(SelEndX, EndNotBlank);\r\n if SelEndX < 0 then\r\n SelEndX := 0;\r\n end\r\n else\r\n begin\r\n // adjust selection\r\n Inc(SelBegX, BegNotBlank);\r\n if SelBegX > Max_X then\r\n SelBegX := Max_X;\r\n\r\n if SelEndX > 0 then\r\n Inc(SelEndX, EndNotBlank);\r\n if SelEndX > Max_X then\r\n SelEndX := Max_X;\r\n end;\r\n\r\n // adjust caret\r\n if (CaretY = SelEndY) and (SelEndX > 0) then\r\n SetCaretInternal(CaretX + EndNotBlank, CaretY)\r\n else\r\n if CaretY = SelBegY then\r\n SetCaretInternal(CaretX + BegNotBlank, CaretY);\r\n\r\n SetSelUpdateRegion(BegY, EndY);\r\n PaintSelection;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomEditorBase.BeginCompound;\r\nbegin\r\n Inc(FCompound);\r\n {--- UNDO ---}\r\n TJvBeginCompoundUndo.Create(Self);\r\n {--- /UNDO ---}\r\nend;\r\n\r\nprocedure TJvCustomEditorBase.EndCompound;\r\nbegin\r\n {--- UNDO ---}\r\n TJvEndCompoundUndo.Create(Self);\r\n {--- /UNDO ---}\r\n Dec(FCompound);\r\nend;\r\n\r\nprocedure TJvCustomEditorBase.PostBeginCompound;\r\nbegin\r\n PostMessage(Handle, WM_COMPOUND, 0, 0);\r\nend;\r\n\r\nprocedure TJvCustomEditorBase.PostEndCompound;\r\nbegin\r\n PostMessage(Handle, WM_COMPOUND, 1, 0);\r\nend;\r\n\r\nprocedure TJvCustomEditorBase.SetBracketHighlighting(Value: TJvBracketHighlighting);\r\nbegin\r\n if Value <> BracketHighlighting then\r\n BracketHighlighting.Assign(Value);\r\nend;\r\n\r\nprocedure TJvCustomEditorBase.SetCurrentLineHighlight(const Value: TColor);\r\nbegin\r\n if Value <> FCurrentLineHighlight then\r\n begin\r\n FCurrentLineHighlight := Value;\r\n if not (csLoading in ComponentState) and (CaretY >= 0) and (CaretY < LineCount) then\r\n PaintLine(CaretY);\r\n end;\r\nend;\r\n\r\n//=== { TJvErrorHighlightingItem } ===========================================\r\n\r\nconstructor TJvErrorHighlightingItem.Create(AOwner: TJvErrorHighlighting;\r\n ACol, ALine, ALen: Integer; const AErrorText: string);\r\nbegin\r\n inherited Create;\r\n FOwner := AOwner;\r\n FCol := ACol;\r\n FLine := ALine;\r\n FLen := ALen;\r\n FErrorText := AErrorText;\r\nend;\r\n\r\ndestructor TJvErrorHighlightingItem.Destroy;\r\nbegin\r\n if not (csDestroying in FOwner.Editor.ComponentState) then\r\n FOwner.FItems.Extract(Self);\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvErrorHighlightingItem.SetCol(const Value: Integer);\r\nbegin\r\n if Value <> FCol then\r\n begin\r\n FCol := Value;\r\n FOwner.RepaintLine(Line);\r\n end;\r\nend;\r\n\r\nprocedure TJvErrorHighlightingItem.SetLine(const Value: Integer);\r\nbegin\r\n if Value <> FLine then\r\n begin\r\n FLine := -1;\r\n FOwner.RepaintLine(Line);\r\n FLine := Value;\r\n FOwner.RepaintLine(Line);\r\n end;\r\nend;\r\n\r\n//=== { TJvErrorHighlighting } ===============================================\r\n\r\nconstructor TJvErrorHighlighting.Create(AEditor: TJvCustomEditorBase);\r\nbegin\r\n inherited Create;\r\n FEditor := AEditor;\r\n FItems := TObjectList.Create;\r\nend;\r\n\r\ndestructor TJvErrorHighlighting.Destroy;\r\nbegin\r\n FItems.Free;\r\n FEditor := nil;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJvErrorHighlighting.GetCount: Integer;\r\nbegin\r\n Result := FItems.Count;\r\nend;\r\n\r\nfunction TJvErrorHighlighting.Add(ACol, ALine, ALen: Integer; const AErrorText: string): Integer;\r\nbegin\r\n Result := FItems.Add(TJvErrorHighlightingItem.Create(Self, ACol, ALine, ALen, AErrorText));\r\n RepaintLine(ALine);\r\nend;\r\n\r\nfunction TJvErrorHighlighting.GetItem(Index: Integer): TJvErrorHighlightingItem;\r\nbegin\r\n Result := TJvErrorHighlightingItem(FItems[Index]);\r\nend;\r\n\r\nprocedure TJvErrorHighlighting.Remove(Item: TJvErrorHighlightingItem);\r\nvar\r\n Line: Integer;\r\nbegin\r\n if Assigned(Item) then\r\n begin\r\n Line := Item.Line;\r\n FItems.Remove(Item);\r\n RepaintLine(Line);\r\n end;\r\nend;\r\n\r\nprocedure TJvErrorHighlighting.Delete(Index: Integer);\r\nvar\r\n Line: Integer;\r\nbegin\r\n if (Index >= 0) and (Index < Count) then\r\n begin\r\n Line := Items[Index].Line;\r\n FItems.Delete(Index);\r\n RepaintLine(Line);\r\n end\r\n else\r\n FItems.Delete(Index);\r\nend;\r\n\r\nprocedure TJvErrorHighlighting.Clear;\r\nbegin\r\n BeginUpdate;\r\n try\r\n FNeedsRepaint := FItems.Count > 0;\r\n FItems.Clear;\r\n finally\r\n EndUpdate;\r\n end;\r\nend;\r\n\r\nprocedure TJvErrorHighlighting.RepaintLine(Line: Integer);\r\nbegin\r\n if FPaintLock > 0 then\r\n FNeedsRepaint := True\r\n else\r\n begin\r\n if Assigned(FEditor) then\r\n FEditor.PaintLine(Line);\r\n FNeedsRepaint := False;\r\n end;\r\nend;\r\n\r\nprocedure TJvErrorHighlighting.EndUpdate;\r\nbegin\r\n Assert(FPaintLock > 0, 'Unpaired call to EndUpdate');\r\n Dec(FPaintLock);\r\n if FNeedsRepaint then\r\n begin\r\n if Assigned(FEditor) then\r\n FEditor.Paint;\r\n FNeedsRepaint := False;\r\n end;\r\nend;\r\n\r\nprocedure TJvErrorHighlighting.BeginUpdate;\r\nbegin\r\n Inc(FPaintLock);\r\nend;\r\n\r\nprocedure TJvErrorHighlighting.DeleteLine(Line: Integer);\r\nvar\r\n I: Integer;\r\nbegin\r\n Dec(Line);\r\n BeginUpdate;\r\n try\r\n for I := Count - 1 downto 0 do\r\n if Items[I].Line = Line then\r\n Delete(I)\r\n else\r\n if Items[I].Line > Line then\r\n Items[I].Line := Items[I].Line - 1;\r\n finally\r\n EndUpdate;\r\n end;\r\nend;\r\n\r\nprocedure TJvErrorHighlighting.InsertLine(Line: Integer);\r\nvar\r\n I: Integer;\r\nbegin\r\n Dec(Line);\r\n BeginUpdate;\r\n try\r\n for I := 0 to Count - 1 do\r\n if Items[I].Line >= Line then\r\n Items[I].Line := Items[I].Line + 1;\r\n finally\r\n EndUpdate;\r\n end;\r\nend;\r\n\r\nfunction TJvErrorHighlighting.GetLineErrorMap(Y: Integer): TDynBoolArray;\r\nvar\r\n I, X: Integer;\r\n Item: TJvErrorHighlightingItem;\r\n MaxX: Integer;\r\nbegin\r\n MaxX := 0;\r\n for I := 0 to Count - 1 do\r\n begin\r\n Item := Items[I];\r\n if Item.Line = Y then\r\n if Item.Col + Item.Len > MaxX then\r\n MaxX := Item.Col + Item.Len;\r\n end;\r\n SetLength(Result, MaxX);\r\n\r\n if MaxX > 0 then\r\n begin\r\n for I := 0 to Count - 1 do\r\n begin\r\n Item := Items[I];\r\n if Item.Line = Y then\r\n for X := Item.Col to Item.Col + Item.Len - 1 do\r\n Result[X] := True;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJvErrorHighlighting.ErrorAt(X, Y: Integer): TJvErrorHighlightingItem;\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := 0 to Count - 1 do\r\n begin\r\n Result := Items[I];\r\n if (Result.Line = Y) and (X >= Result.Col) and (X < Result.Col + Result.Len) then\r\n Exit;\r\n end;\r\n Result := nil;\r\nend;\r\n\r\nprocedure TJvErrorHighlighting.PaintError(Canvas: TCanvas; Col, Line: Integer;\r\n const R: TRect; Len: Integer; const MyDi: TDynIntArray);\r\nvar\r\n I, Width, X: Integer;\r\n Errors: TDynBoolArray;\r\nbegin\r\n Errors := GetLineErrorMap(Line);\r\n X := R.Left;\r\n for I := Col to Col + Len - 1 do\r\n begin\r\n Width := MyDi[I];\r\n if (I <= High(Errors)) and Errors[I] then\r\n begin\r\n with Canvas do\r\n begin\r\n Pen.Color := clRed;\r\n MoveTo(X, R.Bottom - 1);\r\n LineTo(X + Width div 4, R.Bottom - 4);\r\n LineTo(X + Width div 4 * 2, R.Bottom - 1);\r\n LineTo(X + Width div 4 * 3, R.Bottom - 4);\r\n LineTo(X + Width, R.Bottom - 1);\r\n end;\r\n end;\r\n Inc(X, Width);\r\n end;\r\nend;\r\n\r\n//=== { TJvEditorCompletionList } ============================================\r\n\r\nconstructor TJvEditorCompletionList.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n Left := -1000;\r\n Visible := False;\r\n TabStop := False;\r\n ParentFont := False;\r\n Parent := Owner as TJvCustomEditorBase;\r\n Ctl3D := False;\r\n FTimer := TTimer.Create(nil);\r\n FTimer.Enabled := False;\r\n FTimer.Interval := 200;\r\n FTimer.OnTimer := OnTimer;\r\n Style := lbOwnerDrawFixed;\r\n ItemHeight := 13;\r\n\r\n // HintWindow := THintWindow.Create(Self);\r\nend;\r\n\r\ndestructor TJvEditorCompletionList.Destroy;\r\nbegin\r\n FTimer.Free;\r\n // HintWindow.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvEditorCompletionList.CreateParams(var Params: TCreateParams);\r\nbegin\r\n inherited CreateParams(Params);\r\n with Params do\r\n begin\r\n Style := Style {or WS_POPUP} or WS_BORDER;\r\n ExStyle := ExStyle or WS_EX_TOOLWINDOW;\r\n WindowClass.Style := WindowClass.Style or CS_SAVEBITS;\r\n end;\r\nend;\r\n\r\nprocedure TJvEditorCompletionList.CreateWnd;\r\nbegin\r\n inherited CreateWnd;\r\n if not (csDesigning in ComponentState) then\r\n Windows.SetParent(Handle, 0);\r\n // CallWindowProc(DefWndProc, Handle, WM_SETFOCUS, 0, 0); {??}\r\nend;\r\n\r\nprocedure TJvEditorCompletionList.DestroyWnd;\r\nbegin\r\n inherited DestroyWnd;\r\n // HintWindow.ReleaseHandle;\r\nend;\r\n\r\nprocedure TJvEditorCompletionList.MouseMove(Shift: TShiftState; X, Y: Integer);\r\nvar\r\n F: Integer;\r\nbegin\r\n YY := Y;\r\n F := ItemAtPos(Point(X, Y), True);\r\n if KeyPressed(VK_LBUTTON) then\r\n begin\r\n F := ItemAtPos(Point(X, Y), True);\r\n if F > -1 then\r\n ItemIndex := F;\r\n FTimer.Enabled := (Y < 0) or (Y > ClientHeight);\r\n if (Y < -ItemHeight) or (Y > ClientHeight + ItemHeight) then\r\n FTimer.Interval := 50\r\n else\r\n FTimer.Interval := 200;\r\n end;\r\n if (F > -1) and not FTimer.Enabled then\r\n begin\r\n //Application.CancelHint;\r\n // Hint := Items[F];\r\n // HintWindow.ActivateHint(Bounds(ClientOrigin.X + X, ClientOrigin.Y + Y, 300, ItemHeight), Items[F]);\r\n end;\r\nend;\r\n\r\nprocedure TJvEditorCompletionList.MouseDown(Button: TMouseButton; Shift:\r\n TShiftState; X, Y: Integer);\r\nvar\r\n F: Integer;\r\nbegin\r\n MouseCapture := True;\r\n F := ItemAtPos(Point(X, Y), True);\r\n if F > -1 then\r\n ItemIndex := F;\r\nend;\r\n\r\nprocedure TJvEditorCompletionList.MouseUp(Button: TMouseButton; Shift:\r\n TShiftState; X, Y: Integer);\r\nbegin\r\n MouseCapture := False;\r\n (Owner as TJvCustomEditorBase).Completion.CloseUp(\r\n (Button = mbLeft) and PtInRect(ClientRect, Point(X, Y)));\r\nend;\r\n\r\nprocedure TJvEditorCompletionList.OnTimer(Sender: TObject);\r\nbegin\r\n if YY < 0 then\r\n Perform(WM_VSCROLL, SB_LINEUP, 0)\r\n else\r\n if YY > ClientHeight then\r\n Perform(WM_VSCROLL, SB_LINEDOWN, 0);\r\nend;\r\n\r\nprocedure TJvEditorCompletionList.WMCancelMode(var Msg: TMessage);\r\nbegin\r\n (Owner as TJvCustomEditorBase).Completion.CloseUp(False);\r\nend;\r\n\r\nprocedure TJvEditorCompletionList.CMHintShow(var Msg: TMessage);\r\nbegin\r\n Msg.Result := 1;\r\nend;\r\n\r\nprocedure TJvEditorCompletionList.DrawItem(Index: Integer; Rect: TRect;\r\n State: TOwnerDrawState);\r\nvar\r\n Offset, W: Integer;\r\n S: string;\r\nbegin\r\n // this is a ANSI component\r\n if Assigned(OnDrawItem) then\r\n OnDrawItem(Self, Index, Rect, State)\r\n else\r\n begin\r\n Canvas.FillRect(Rect);\r\n Offset := 3;\r\n with (Owner as TJvCustomEditorBase).Completion do\r\n case Mode of\r\n cmIdentifiers:\r\n TJvUnicodeCanvas(Canvas).TextOut(Rect.Left + Offset, Rect.Top, SubStrBySeparator(Items[Index], 1,\r\n GetSeparator));\r\n cmTemplates:\r\n begin\r\n TJvUnicodeCanvas(Canvas).TextOut(Rect.Left + Offset, Rect.Top, SubStrBySeparator(Items[Index], 1,\r\n GetSeparator));\r\n Canvas.Font.Style := [fsBold];\r\n S := SubStrBySeparator(Items[Index], 0, GetSeparator);\r\n W := Canvas.TextWidth(S);\r\n TJvUnicodeCanvas(Canvas).TextOut(Rect.Right - 2 * Offset - W, Rect.Top, S);\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\n//=== { TJvEditorCompletion } ================================================\r\n\r\nconstructor TJvCompletionBase.Create(AJvEditor: TJvCustomEditorBase);\r\nbegin\r\n inherited Create;\r\n FJvEditor := AJvEditor;\r\n FPopupList := TJvEditorCompletionList.Create(FJvEditor);\r\n FItemHeight := FPopupList.ItemHeight;\r\n FDropDownCount := 6;\r\n FDropDownWidth := 300;\r\n FTimer := TTimer.Create(nil);\r\n FTimer.Enabled := False;\r\n FTimer.Interval := 800;\r\n FTimer.OnTimer := OnTimer;\r\n FDefMode := cmIdentifiers;\r\nend;\r\n\r\ndestructor TJvCompletionBase.Destroy;\r\nbegin\r\n inherited Destroy;\r\n // (ahuser) is this necessary ?\r\n FPopupList.Free;\r\n FTimer.Free;\r\nend;\r\n\r\nprocedure TJvCompletionBase.DoKeyPress(Key: Char);\r\nbegin\r\n if FVisible then\r\n if HasChar(Key, JvEditorCompletionChars) then\r\n SelectItem\r\n else\r\n CloseUp(True)\r\n else\r\n if FEnabled then\r\n FTimer.Enabled := True;\r\nend;\r\n\r\nfunction TJvCompletionBase.DoKeyDown(Key: Word; Shift: TShiftState): Boolean;\r\nbegin\r\n Result := True;\r\n case Key of\r\n VK_ESCAPE:\r\n CloseUp(False);\r\n VK_RETURN:\r\n CloseUp(True);\r\n VK_UP, VK_DOWN, VK_PRIOR, VK_NEXT, VK_HOME, VK_END:\r\n FPopupList.Perform(WM_KEYDOWN, Key, 0);\r\n else\r\n Result := False;\r\n end;\r\nend;\r\n\r\nprocedure TJvCompletionBase.DoCompletion(const AMode: TCompletionList);\r\nvar\r\n Eq: Boolean;\r\n Cancel: Boolean;\r\nbegin\r\n if FJvEditor.ReadOnly then\r\n Exit;\r\n if FPopupList.Visible then\r\n CloseUp(False);\r\n FMode := AMode;\r\n case FMode of\r\n cmIdentifiers:\r\n DropDown(AMode, True);\r\n cmTemplates:\r\n begin\r\n Cancel := False;\r\n // JvEditor.DoCompletionIdentifier(Cancel);\r\n FJvEditor.DoCompletionTemplate(Cancel);\r\n if Cancel or (GetTemplateCount = 0) then\r\n Exit;\r\n MakeItems;\r\n FindSelItem(Eq);\r\n if Eq then\r\n ReplaceWordItemIndex(2)\r\n else\r\n DropDown(AMode, True);\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvCompletionBase.DropDown(const AMode: TCompletionList; const ShowAlways:\r\n Boolean);\r\nvar\r\n ItemCount: Integer;\r\n P: TPoint;\r\n Y: Integer;\r\n PopupWidth, PopupHeight: Integer;\r\n SysBorderWidth, SysBorderHeight: Integer;\r\n R: TRect;\r\n Cancel: Boolean;\r\n Eq: Boolean;\r\nbegin\r\n CloseUp(False);\r\n FMode := AMode;\r\n with FJvEditor do\r\n begin\r\n Cancel := False;\r\n case FMode of\r\n cmIdentifiers:\r\n DoCompletionIdentifier(Cancel);\r\n cmTemplates:\r\n DoCompletionTemplate(Cancel)\r\n end;\r\n MakeItems;\r\n FindSelItem(Eq);\r\n // Cancel := not Visible and (ItemIndex = -1);\r\n if Cancel or (Items.Count = 0) or (((ItemIndex = -1) or Eq) and not ShowAlways) then\r\n Exit;\r\n FPopupList.ItemHeight := FItemHeight;\r\n FVisible := True;\r\n SetItemIndex(FItemIndex);\r\n if (FListBoxStyle in [lbStandard]) and Assigned(FJvEditor.OnCompletionDrawItem) then\r\n FPopupList.Style := lbOwnerDrawFixed\r\n else\r\n FPopupList.Style := FListBoxStyle;\r\n FPopupList.OnMeasureItem := FJvEditor.OnCompletionMeasureItem;\r\n FPopupList.OnDrawItem := FJvEditor.OnCompletionDrawItem;\r\n\r\n ItemCount := Items.Count;\r\n SysBorderWidth := GetSystemMetrics(SM_CXBORDER);\r\n SysBorderHeight := GetSystemMetrics(SM_CYBORDER);\r\n R := CalcCellRect(CaretX - LeftCol, CaretY - TopRow + 1);\r\n P := R.TopLeft;\r\n P.X := ClientOrigin.X + P.X;\r\n P.Y := ClientOrigin.Y + P.Y;\r\n Dec(P.X, 2 * SysBorderWidth);\r\n Dec(P.Y, SysBorderHeight);\r\n if ItemCount > FDropDownCount then\r\n ItemCount := FDropDownCount;\r\n PopupHeight := ItemHeight * ItemCount + 2;\r\n Y := P.Y;\r\n if (Y + PopupHeight) > Screen.Height then\r\n begin\r\n Y := P.Y - PopupHeight - CellRect.Height + 1;\r\n if Y < 0 then\r\n Y := P.Y;\r\n end;\r\n PopupWidth := FDropDownWidth;\r\n if PopupWidth = 0 then\r\n PopupWidth := Width + 2 * SysBorderWidth;\r\n end;\r\n FPopupList.Left := P.X;\r\n FPopupList.Top := Y;\r\n FPopupList.Width := PopupWidth;\r\n FPopupList.Height := PopupHeight;\r\n SetWindowPos(FPopupList.Handle, HWND_TOP, P.X, Y, 0, 0,\r\n SWP_NOSIZE or SWP_NOACTIVATE or SWP_SHOWWINDOW);\r\n FPopupList.Visible := True;\r\nend;\r\n\r\nprocedure TJvCompletionBase.SelectItem;\r\nvar\r\n Cancel: Boolean;\r\n Param: Boolean;\r\nbegin\r\n FindSelItem(Param);\r\n Cancel := not Visible and (ItemIndex = -1);\r\n case FMode of\r\n cmIdentifiers:\r\n FJvEditor.DoCompletionIdentifier(Cancel);\r\n cmTemplates:\r\n FJvEditor.DoCompletionTemplate(Cancel);\r\n end;\r\n if Cancel or (GetItemCount = 0) then\r\n CloseUp(False);\r\nend;\r\n\r\nprocedure TJvCompletionBase.CloseUp(const Apply: Boolean);\r\nbegin\r\n if not Visible then\r\n Exit;\r\n\r\n FItemIndex := ItemIndex;\r\n FPopupList.Visible := False;\r\n // (FPopupList as TJvEditorCompletionList).HintWindow.ReleaseHandle;\r\n FVisible := False;\r\n FTimer.Enabled := False;\r\n if Apply and (ItemIndex > -1) then\r\n case FMode of\r\n cmIdentifiers:\r\n ReplaceWordItemIndex(0);\r\n cmTemplates:\r\n ReplaceWordItemIndex(2);\r\n end;\r\nend;\r\n\r\nprocedure TJvCompletionBase.OnTimer(Sender: TObject);\r\nbegin\r\n DropDown(FDefMode, False);\r\nend;\r\n\r\nfunction TJvCompletionBase.GetItemIndex: Integer;\r\nbegin\r\n Result := FItemIndex;\r\n if FVisible then\r\n Result := FPopupList.ItemIndex;\r\nend;\r\n\r\nprocedure TJvCompletionBase.SetItemIndex(AValue: Integer);\r\nbegin\r\n FItemIndex := AValue;\r\n if FVisible then\r\n FPopupList.ItemIndex := FItemIndex;\r\nend;\r\n\r\nfunction TJvCompletionBase.GetInterval: Cardinal;\r\nbegin\r\n Result := FTimer.Interval;\r\nend;\r\n\r\nprocedure TJvCompletionBase.SetInterval(AValue: Cardinal);\r\nbegin\r\n FTimer.Interval := AValue;\r\nend;\r\n\r\nfunction TJvCompletionBase.GetItemCount: Integer;\r\nbegin\r\n case FMode of\r\n cmIdentifiers:\r\n Result := GetIdentifierCount;\r\n cmTemplates:\r\n Result := GetTemplateCount;\r\n else\r\n Result := 0;\r\n end;\r\nend;\r\n\r\nfunction TJvCompletionBase.GetItems: TStrings;\r\nbegin\r\n Result := FPopupList.Items;\r\nend;\r\n\r\n//=== { TJvSymbolColor } =====================================================\r\n\r\nconstructor TJvSymbolColor.Create;\r\nbegin\r\n inherited Create;\r\n FStyle := [];\r\n FForeColor := clWindowText;\r\n FBackColor := clWindow;\r\nend;\r\n\r\nprocedure TJvSymbolColor.SetColor(const ForeColor, BackColor: TColor; const Style: TFontStyles);\r\nbegin\r\n FForeColor := ForeColor;\r\n FBackColor := BackColor;\r\n FStyle := Style;\r\nend;\r\n\r\nprocedure TJvSymbolColor.Assign(Source: TPersistent);\r\nbegin\r\n if Source is TJvSymbolColor then\r\n begin\r\n FForeColor := TJvSymbolColor(Source).FForeColor;\r\n FBackColor := TJvSymbolColor(Source).FBackColor;\r\n FStyle := TJvSymbolColor(Source).FStyle;\r\n end\r\n else\r\n inherited Assign(Source);\r\nend;\r\n\r\n//=== { TJvColors } ==========================================================\r\n\r\nconstructor TJvColors.Create;\r\nbegin\r\n inherited Create;\r\n FComment := TJvSymbolColor.Create;\r\n FNumber := TJvSymbolColor.Create;\r\n FString := TJvSymbolColor.Create;\r\n FSymbol := TJvSymbolColor.Create;\r\n FReserved := TJvSymbolColor.Create;\r\n FStatement := TJvSymbolColor.Create;\r\n FIdentifier := TJvSymbolColor.Create;\r\n FPreproc := TJvSymbolColor.Create;\r\n FFunctionCall := TJvSymbolColor.Create;\r\n FDeclaration := TJvSymbolColor.Create;\r\n FPlainText := TJvSymbolColor.Create;\r\n Preproc.SetColor(clGreen, clWindow, []);\r\n Comment.SetColor(clOlive, clWindow, [fsItalic]);\r\n Number.SetColor(clNavy, clWindow, []);\r\n Strings.SetColor(clPurple, clWindow, []);\r\n Symbol.SetColor(clBlue, clWindow, []);\r\n Reserved.SetColor(clWindowText, clWindow, [fsBold]);\r\n Statement.SetColor(clWindowText, clWindow, [fsBold]);\r\n Identifier.SetColor(clWindowText, clWindow, []);\r\n FunctionCall.SetColor(clWindowText, clWindow, []);\r\n Declaration.SetColor(clWindowText, clWindow, []);\r\n PlainText.SetColor(clWindowText, clWindow, []);\r\nend;\r\n\r\ndestructor TJvColors.Destroy;\r\nbegin\r\n FComment.Free;\r\n FNumber.Free;\r\n FString.Free;\r\n FSymbol.Free;\r\n FReserved.Free;\r\n FStatement.Free;\r\n FIdentifier.Free;\r\n FPreproc.Free;\r\n FFunctionCall.Free;\r\n FDeclaration.Free;\r\n FPlainText.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvColors.Assign(Source: TPersistent);\r\nbegin\r\n if Source is TJvColors then\r\n begin\r\n Comment.Assign(TJvColors(Source).Comment);\r\n Number.Assign(TJvColors(Source).Number);\r\n Strings.Assign(TJvColors(Source).Strings);\r\n Symbol.Assign(TJvColors(Source).Symbol);\r\n Reserved.Assign(TJvColors(Source).Reserved);\r\n Statement.Assign(TJvColors(Source).Statement);\r\n Identifier.Assign(TJvColors(Source).Identifier);\r\n Preproc.Assign(TJvColors(Source).Preproc);\r\n FunctionCall.Assign(TJvColors(Source).FunctionCall);\r\n Declaration.Assign(TJvColors(Source).Declaration);\r\n PlainText.Assign(TJvColors(Source).PlainText);\r\n end\r\n else\r\n inherited Assign(Source);\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvEmbeddedForms.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvEmbeddedForms.PAS, released on 2004-06-11.\r\n\r\nThe Initial Developer of the Original Code is \"rossen\".\r\nPortions created by \"rossen\" are Copyright (C) 2004 \"rossen\".\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvEmbeddedForms.pas 13104 2011-09-07 06:50:43Z obones $\r\n\r\nunit JvEmbeddedForms;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, Forms, Classes,\r\n JvComponentBase, JvComponent;\r\n\r\ntype\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64 or pidOSX32)]\r\n {$ENDIF RTL230_UP}\r\n TJvEmbeddedFormLink = class(TJvComponent)\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n end;\r\n\r\n TJvEmbeddedPaintProcedure = procedure of object;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64 or pidOSX32)]\r\n {$ENDIF RTL230_UP}\r\n TJvEmbeddedFormPanel = class(TJvCustomControl)\r\n private\r\n FLink: TJvEmbeddedFormLink;\r\n FLinkedForm: TForm;\r\n FAlwaysVisible: Boolean;\r\n FPaintProcedure: TJvEmbeddedPaintProcedure;\r\n FOnFormDestroy: TNotifyEvent;\r\n procedure DrawFormImage;\r\n procedure SetLinkedForm;\r\n procedure UpdateLinkedForm;\r\n procedure DefaultPaint;\r\n procedure SetFormLink(const Value: TJvEmbeddedFormLink);\r\n protected\r\n procedure Paint; override;\r\n procedure InitLinkedForm; virtual;\r\n procedure ClearLinkedForm; virtual;\r\n procedure Notification(AComponent: TComponent; Operation: TOperation); override;\r\n procedure FormDestroy; virtual;\r\n public\r\n procedure DockLinkedForm; virtual;\r\n procedure UndockLinkedForm(ABorderStyle: TFormBorderStyle; APosition: TPosition); virtual;\r\n function IsLinkedFormDocked: Boolean;\r\n property LinkedForm: TForm read FLinkedForm;\r\n published\r\n property AlwaysVisible: Boolean read FAlwaysVisible write FAlwaysVisible;\r\n property FormLink: TJvEmbeddedFormLink read FLink write SetFormLink;\r\n property OnFormDestroy: TNotifyEvent read FOnFormDestroy write FOnFormDestroy;\r\n property Align;\r\n property Anchors;\r\n property Color;\r\n property Constraints;\r\n property Enabled;\r\n property ParentColor;\r\n property ParentShowHint;\r\n property ShowHint;\r\n property Visible;\r\n property OnClick;\r\n property OnDblClick;\r\n property OnContextPopup;\r\n property OnDockDrop;\r\n property OnDockOver;\r\n property OnDragDrop;\r\n property OnDragOver;\r\n property OnEndDock;\r\n property OnEndDrag;\r\n property OnEnter;\r\n property OnExit;\r\n property OnGetSiteInfo;\r\n property OnKeyDown;\r\n property OnKeyPress;\r\n property OnKeyUp;\r\n property OnMouseDown;\r\n property OnMouseEnter;\r\n property OnMouseLeave;\r\n property OnMouseMove;\r\n property OnMouseUp;\r\n property OnMouseWheel;\r\n property OnMouseWheelDown;\r\n property OnMouseWheelUp;\r\n property OnStartDock;\r\n property OnStartDrag;\r\n property OnUnDock;\r\n property BorderWidth;\r\n property BevelEdges;\r\n property BevelInner;\r\n property BevelKind;\r\n property BevelOuter;\r\n property BevelWidth;\r\n property DockManager;\r\n property DockSite;\r\n property DragCursor;\r\n property DragKind;\r\n property DragMode;\r\n property PopupMenu;\r\n property TabOrder;\r\n property TabStop;\r\n property UseDockManager;\r\n end;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64 or pidOSX32)]\r\n {$ENDIF RTL230_UP}\r\n TJvEmbeddedInstanceFormPanel = class(TJvEmbeddedFormPanel)\r\n private\r\n FFormClass: TFormClass;\r\n procedure CreateFormInstance;\r\n protected\r\n procedure InitLinkedForm; override;\r\n procedure ClearLinkedForm; override;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvEmbeddedForms.pas $';\r\n Revision: '$Revision: 13104 $';\r\n Date: '$Date: 2011-09-07 08:50:43 +0200 (mer. 07 sept. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n SysUtils, Graphics, Controls,\r\n JvResources, JvConsts, JvJVCLUtils;\r\n\r\n//=== { TJvEmbeddedFormLink } ================================================\r\n\r\nconstructor TJvEmbeddedFormLink.Create(AOwner: TComponent);\r\nvar\r\n I: Integer;\r\nbegin\r\n if (AOwner <> nil) and (csDesigning in AOwner.ComponentState) then\r\n for I := 0 to AOwner.ComponentCount - 1 do\r\n if AOwner.Components[I] is TJvEmbeddedFormLink then\r\n raise Exception.CreateRes(@RsEFormLinkSingleInstanceOnly);\r\n inherited Create(AOwner);\r\nend;\r\n\r\n//=== { TJvEmbeddedFormPanel } ===============================================\r\n\r\nprocedure TJvEmbeddedFormPanel.Paint;\r\nbegin\r\n// inherited;\r\n if Assigned(FPaintProcedure) then\r\n FPaintProcedure;\r\nend;\r\n\r\nprocedure TJvEmbeddedFormPanel.DrawFormImage;\r\nvar\r\n FBitmap: TBitmap;\r\n R: TRect;\r\nbegin\r\n FBitmap := FLinkedForm.GetFormImage;\r\n try\r\n DefaultPaint;\r\n Canvas.Draw(0, 0, FBitmap);\r\n if csDesigning in ComponentState then\r\n begin\r\n R := FLinkedForm.ClientRect;\r\n Canvas.Brush.Style := bsClear;\r\n Canvas.Pen.Style := psDot;\r\n Canvas.Rectangle(R);\r\n Canvas.Brush.Style := bsBDiagonal;\r\n Canvas.Rectangle(R);\r\n end;\r\n finally\r\n FBitmap.Free;\r\n end;\r\nend;\r\n\r\nprocedure TJvEmbeddedFormPanel.SetLinkedForm;\r\nbegin\r\n with FLinkedForm do\r\n begin\r\n Parent := Self;\r\n Align := alClient;\r\n BorderStyle := bsNone;\r\n Show;\r\n end;\r\nend;\r\n\r\nprocedure TJvEmbeddedFormPanel.UpdateLinkedForm;\r\n\r\n function IsParentFormActive: Boolean;\r\n var\r\n FParent: TWinControl;\r\n begin\r\n FParent := Parent;\r\n while (FParent <> nil) and (FParent.Parent <> nil) do\r\n FParent := FParent.Parent;\r\n Result := (FParent is TForm) and TForm(FParent).Active;\r\n end;\r\n\r\nbegin\r\n if (FLinkedForm.Parent <> Self) and (FLinkedForm.Parent <> nil) and IsParentFormActive then\r\n SetLinkedForm\r\n else\r\n if AlwaysVisible then\r\n DrawFormImage;\r\nend;\r\n\r\nprocedure TJvEmbeddedFormPanel.InitLinkedForm;\r\nbegin\r\n FLinkedForm := FLink.Owner as TForm;\r\n if FLinkedForm <> nil then\r\n begin\r\n FLinkedForm.FreeNotification(Self);\r\n// ClientWidth := FLinkedForm.ClientWidth;\r\n// ClientHeight := FLinkedForm.ClientHeight;\r\n// Color := FLinkedForm.Color;\r\n\r\n if csDesigning in ComponentState then\r\n begin\r\n DrawFormImage;\r\n FPaintProcedure := DrawFormImage;\r\n end\r\n else\r\n begin\r\n SetLinkedForm;\r\n FPaintProcedure := UpdateLinkedForm;\r\n end;\r\n end\r\n else\r\n FPaintProcedure := DefaultPaint;\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvEmbeddedFormPanel.ClearLinkedForm;\r\nbegin\r\n FLink := nil;\r\n FLinkedForm := nil;\r\n FPaintProcedure := DefaultPaint;\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvEmbeddedFormPanel.SetFormLink(const Value: TJvEmbeddedFormLink);\r\nbegin\r\n if Value <> FLink then\r\n begin\r\n if Value = nil then\r\n ClearLinkedForm\r\n else\r\n if Value.Owner = Owner then\r\n raise Exception.CreateRes(@RsELinkCircularRef)\r\n else\r\n begin\r\n ReplaceComponentReference(Self, Value, TComponent(FLink));\r\n InitLinkedForm;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvEmbeddedFormPanel.DefaultPaint;\r\nbegin\r\n Canvas.Brush.Style := bsSolid;\r\n Canvas.Brush.Color := Color;\r\n Canvas.FillRect(ClientRect);\r\nend;\r\n\r\nprocedure TJvEmbeddedFormPanel.Notification(AComponent: TComponent; Operation: TOperation);\r\nbegin\r\n inherited Notification(AComponent, Operation);\r\n if Operation = opRemove then\r\n begin\r\n if AComponent = FLinkedForm then\r\n FLinkedForm := nil\r\n else\r\n if AComponent = FormLink then\r\n begin\r\n FormLink := nil;\r\n try\r\n FormDestroy;\r\n except\r\n Application.HandleException(Self);\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvEmbeddedFormPanel.FormDestroy;\r\nbegin\r\n if Assigned(FOnFormDestroy) then\r\n FOnFormDestroy(Self);\r\nend;\r\n\r\nprocedure TJvEmbeddedFormPanel.DockLinkedForm;\r\nbegin\r\n if (FLinkedForm <> nil) and (FLinkedForm.Parent <> Self) then\r\n with FLinkedForm do\r\n begin\r\n Hide;\r\n BorderStyle := bsNone;\r\n Parent := Self;\r\n Align := alClient;\r\n Show;\r\n end;\r\nend;\r\n\r\nprocedure TJvEmbeddedFormPanel.UndockLinkedForm(ABorderStyle: TFormBorderStyle; APosition: TPosition);\r\nvar\r\n B: Boolean;\r\nbegin\r\n if (FLinkedForm <> nil) and (FLinkedForm.Parent = Self) then\r\n with FLinkedForm do\r\n begin\r\n B := AutoScroll;\r\n Hide;\r\n Align := alNone;\r\n Parent := nil;\r\n // IMPORTANT!!! Don't set BorderStyle unless Parent = nil!!!\r\n BorderStyle := ABorderStyle;\r\n Position := APosition;\r\n AutoScroll := B;\r\n Show;\r\n end;\r\nend;\r\n\r\nfunction TJvEmbeddedFormPanel.IsLinkedFormDocked: Boolean;\r\nbegin\r\n Result := (FLinkedForm <> nil) and (FLinkedForm.Parent = Self);\r\nend;\r\n\r\n//=== { TJvEmbeddedInstanceFormPanel } ======================================\r\n\r\nprocedure TJvEmbeddedInstanceFormPanel.CreateFormInstance;\r\nbegin\r\n FLinkedForm := FFormClass.Create(Self);\r\n FFormClass := nil;\r\n FPaintProcedure := DefaultPaint;\r\n SetLinkedForm;\r\nend;\r\n\r\nprocedure TJvEmbeddedInstanceFormPanel.ClearLinkedForm;\r\nbegin\r\n if not (csDesigning in ComponentState) then\r\n // (rom) FreeAndNil for safety\r\n FreeAndNil(FLinkedForm);\r\n\r\n FFormClass := nil;\r\n inherited ClearLinkedForm;\r\nend;\r\n\r\nprocedure TJvEmbeddedInstanceFormPanel.InitLinkedForm;\r\nbegin\r\n if csDesigning in ComponentState then\r\n inherited InitLinkedForm\r\n else\r\n begin\r\n FreeAndNil(FLinkedForm);\r\n FFormClass := nil;\r\n FPaintProcedure := DefaultPaint;\r\n FFormClass := TFormClass((FLink.Owner as TForm).ClassType);\r\n FPaintProcedure := CreateFormInstance;\r\n end;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvEnterTab.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvEnterTab.PAS, released on 2002-05-26.\r\n\r\nThe Initial Developer of the Original Code is Peter Thrnqvist [peter3 at sourceforge dot net]\r\nPortions created by Peter Thrnqvist are Copyright (C) 2002 Peter Thrnqvist.\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nDescription:\r\n A unit that converts all Enter keypresses to Tab keypresses.\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvEnterTab.pas 13104 2011-09-07 06:50:43Z obones $\r\n\r\nunit JvEnterTab;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, Messages, Classes, Graphics, Controls,\r\n JvComponentBase;\r\n\r\ntype\r\n TJvEnterAsTabEvent = procedure (Sender: TObject; AControl: TWinControl; var Handled: Boolean) of object;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64 or pidOSX32)]\r\n {$ENDIF RTL230_UP}\r\n TJvEnterAsTab = class(TJvComponent)\r\n private\r\n FEnterAsTab: Boolean;\r\n FAllowDefault: Boolean;\r\n FOnHandleEnter: TJvEnterAsTabEvent;\r\n procedure IgnoreValue(Reader: TReader);\r\n protected\r\n function EnterHandled(AControl: TWinControl): Boolean; virtual;\r\n procedure DefineProperties(Filer: TFiler); override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n published\r\n property EnterAsTab: Boolean read FEnterAsTab write FEnterAsTab default True;\r\n property AllowDefault: Boolean read FAllowDefault write FAllowDefault default True;\r\n // Assign a handler if you want to specify when the Enter key is not to be converted into a\r\n // Tab key. Only triggered if AllowDefault is true. If no event handler is assigned,\r\n // Enter keys will not be converted into Tab if the currently active control is a\r\n // TbuttonControl descendant\r\n property OnHandleEnter: TJvEnterAsTabEvent read FOnHandleEnter write FOnHandleEnter;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvEnterTab.pas $';\r\n Revision: '$Revision: 13104 $';\r\n Date: '$Date: 2011-09-07 08:50:43 +0200 (mer. 07 sept. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n Forms, StdCtrls;\r\n\r\ntype\r\n TJvEnterAsTabControl = class(TGraphicControl)\r\n protected\r\n procedure CMDialogKey(var Msg: TCMDialogKey); message CM_DIALOGKEY;\r\n end;\r\n\r\n{ TJvEnterAsTabControl }\r\n\r\nprocedure TJvEnterAsTabControl.CMDialogKey(var Msg: TCMDialogKey);\r\nvar\r\n Comp: TJvEnterAsTab;\r\nbegin\r\n Comp := (Owner as TJvEnterAsTab);\r\n if (Msg.CharCode = VK_RETURN) and Comp.EnterAsTab then\r\n begin\r\n if Comp.AllowDefault and Comp.EnterHandled(GetParentForm(Self).ActiveControl) then\r\n inherited\r\n else\r\n begin\r\n GetParentForm(Self).Perform(CM_DIALOGKEY, VK_TAB, 0);\r\n Msg.Result := 1;\r\n end;\r\n end\r\n else\r\n inherited;\r\nend;\r\n\r\n{ TJvEnterAsTab }\r\n\r\nconstructor TJvEnterAsTab.Create(AOwner: TComponent);\r\nvar\r\n Ctrl: TJvEnterAsTabControl;\r\nbegin\r\n inherited Create(AOwner);\r\n FEnterAsTab := True;\r\n FAllowDefault := True;\r\n if not (csDesigning in ComponentState) then\r\n begin\r\n Ctrl := TJvEnterAsTabControl.Create(Self);\r\n Ctrl.Visible := False;\r\n Ctrl.Parent := GetParentForm(AOwner as TControl);\r\n end;\r\nend;\r\n\r\nprocedure TJvEnterAsTab.DefineProperties(Filer: TFiler);\r\nbegin\r\n inherited DefineProperties(Filer);\r\n { TJvEnterAsTab was a TJvGraphicControl and now we have to ignore all the\r\n wrong properties. }\r\n Filer.DefineProperty('Width', IgnoreValue, nil, False);\r\n Filer.DefineProperty('Height', IgnoreValue, nil, False);\r\nend;\r\n\r\nfunction TJvEnterAsTab.EnterHandled(AControl: TWinControl): Boolean;\r\nbegin\r\n Result := AControl is TButtonControl;\r\n if Assigned(FOnHandleEnter) then\r\n FOnHandleEnter(Self, AControl, Result);\r\nend;\r\n\r\nprocedure TJvEnterAsTab.IgnoreValue(Reader: TReader);\r\nbegin\r\n Reader.SkipValue;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvErrorIndicator.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvErrorIndicator.pas, released on 2002-11-16.\r\n\r\nThe Initial Developer of the Original Code is Peter Thrnqvist .\r\nPortions created by Peter Thrnqvist are Copyright (C) 2002 Peter Thrnqvist .\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n* Setting AutoScroll to True for a form and displaying error icons beyond the form's right\r\nedge can make the form's scrollbars \"jump up and down\"\r\n* Resizing components while displaying error images, doesn't move the error image smoothly\r\n(this is caused by the image being moved only when the BlinkThread triggers)\r\n\r\nDescription:\r\n A component patterned on the ErrorProvider in .NET:\r\n \"Provides a user interface for indicating that a control\r\n on a form has an error associated with it.\"\r\n To set the error, use the Error property: an empty error string, removes the error image\r\n\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvErrorIndicator.pas 13104 2011-09-07 06:50:43Z obones $\r\n\r\nunit JvErrorIndicator;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, Classes, Graphics, Controls, ImgList,\r\n JvComponentBase;\r\n\r\ntype\r\n IJvErrorIndicatorClient = interface;\r\n\r\n // IJvErrorIndicator is implemented by the TJvErrorIndicator\r\n IJvErrorIndicator = interface\r\n ['{5BCB5404-9C17-4CC6-96EC-46567CA19A12}']\r\n procedure BeginUpdate;\r\n procedure EndUpdate;\r\n procedure SetError(AControl: TControl; const AErrorMessage: WideString);\r\n procedure SetClientError(const AClient: IJvErrorIndicatorClient);\r\n end;\r\n\r\n // IJvErrorIndicatorClient should be implemented by controls that wants to be able\r\n // to update the error indicator through it's own properties\r\n IJvErrorIndicatorClient = interface\r\n ['{9871F250-631E-4119-B073-71B28711C9B8}']\r\n procedure SetErrorIndicator(const Value: IJvErrorIndicator);\r\n function GetErrorIndicator: IJvErrorIndicator;\r\n function GetControl: TControl;\r\n procedure SetErrorMessage(const Value: WideString);\r\n function GetErrorMessage: WideString;\r\n\r\n property ErrorIndicator: IJvErrorIndicator read GetErrorIndicator write SetErrorIndicator;\r\n property ErrorMessage: WideString read GetErrorMessage write SetErrorMessage;\r\n end;\r\n\r\n TJvErrorBlinkStyle = (ebsAlwaysBlink, ebsBlinkIfDifferentError, ebsNeverBlink);\r\n TJvErrorImageAlignment = (eiaBottomLeft, eiaBottomRight, eiaMiddleLeft, eiaMiddleRight,\r\n eiaTopLeft, eiaTopRight);\r\n\r\n TJvErrorControl = class(TGraphicControl)\r\n private\r\n FImageList: TCustomImageList;\r\n FImageIndex: Integer;\r\n FImagePadding: Integer;\r\n FControl: TControl;\r\n FImageAlignment: TJvErrorImageAlignment;\r\n FBlinkCount: Integer;\r\n procedure SetError(const Value: string);\r\n function GetError: string;\r\n procedure SetImageIndex(const Value: Integer);\r\n procedure SetImageList(const Value: TCustomImageList);\r\n procedure SetControl(const Value: TControl);\r\n protected\r\n procedure Paint; override;\r\n procedure Notification(AComponent: TComponent; Operation: TOperation); override;\r\n public\r\n function CalcBoundsRect: TRect;\r\n property Images: TCustomImageList read FImageList write SetImageList;\r\n property ImageIndex: Integer read FImageIndex write SetImageIndex;\r\n property Control: TControl read FControl write SetControl;\r\n property Error: string read GetError write SetError;\r\n property BlinkCount: Integer read FBlinkCount write FBlinkCount;\r\n property ImageAlignment: TJvErrorImageAlignment read FImageAlignment write FImageAlignment;\r\n property ImagePadding: Integer read FImagePadding write FImagePadding;\r\n\r\n procedure DrawImage(Erase: Boolean);\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n property ShowHint default True;\r\n property Width default 16;\r\n property Height default 16;\r\n end;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64 or pidOSX32)]\r\n {$ENDIF RTL230_UP}\r\n TJvErrorIndicator = class(TJvComponent, IUnknown, IJvErrorIndicator)\r\n private\r\n FUpdateCount: Integer;\r\n FControls: TList;\r\n FBlinkRate: Integer;\r\n FImageList: TCustomImageList;\r\n FBlinkThread: TThread;\r\n FBlinkStyle: TJvErrorBlinkStyle;\r\n FChangeLink: TChangeLink;\r\n FImageIndex: Integer;\r\n FDefaultImage: TImageList;\r\n function GetError(AControl: TControl): string;\r\n function GetImageAlignment(AControl: TControl): TJvErrorImageAlignment;\r\n function GetImagePadding(AControl: TControl): Integer;\r\n procedure SetBlinkRate(const Value: Integer);\r\n procedure SetBlinkStyle(const Value: TJvErrorBlinkStyle);\r\n procedure SetError(AControl: TControl; const Value: string);\r\n procedure SetImageList(const Value: TCustomImageList);\r\n procedure SetImageAlignment(AControl: TControl; const Value: TJvErrorImageAlignment);\r\n procedure SetImagePadding(AControl: TControl; const Value: Integer);\r\n procedure SetImageIndex(const Value: Integer);\r\n procedure DoChangeLinkChange(Sender: TObject);\r\n procedure DoBlink(Sender: TObject; Erase: Boolean);\r\n procedure StopThread;\r\n procedure StartThread;\r\n function GetControl(Index: Integer): TJvErrorControl;\r\n function GetCount: Integer;\r\n protected\r\n { IJvErrorIndicator }\r\n procedure IJvErrorIndicator.SetError = IndicatorSetError;\r\n procedure IndicatorSetError(AControl: TControl; const ErrorMessage: WideString);\r\n procedure SetClientError(const AClient: IJvErrorIndicatorClient);\r\n procedure Notification(AComponent: TComponent; Operation: TOperation); override;\r\n function IndexOf(AControl: TControl): Integer;\r\n function Add(AControl: TControl): Integer;\r\n procedure UpdateControls;\r\n procedure Delete(Index: Integer);\r\n property Controls[Index: Integer]: TJvErrorControl read GetControl;\r\n property Count: Integer read GetCount;\r\n public\r\n constructor Create(AComponent: TComponent); override;\r\n destructor Destroy; override;\r\n\r\n // Call ClearErrors to remove all error images with one call\r\n // After a call to ClearErrors, the internal error image list is emptied\r\n // Calling ClearErrors is the same as setting Error[nil] := '' but is slightly faster\r\n procedure ClearErrors;\r\n // The BeginUpdate method suspends the blinking thread until the EndUpdate method is called.\r\n procedure BeginUpdate;\r\n // EndUpdate re-enables the blinking thread that was turned off with the BeginUpdate method.\r\n procedure EndUpdate;\r\n // Gets or sets the error message associated with a control\r\n // Setting the error message to an empty string removes the error image\r\n // (this is the only way to remove an error image for a single control)\r\n // Use Error[nil] := 'SomeValue'; to assign the error message 'SomeValue' to all controls\r\n // Using Error[nil] := ''; is equivalent to calling ClearErrors but ClearErrors is faster\r\n property Error[AControl: TControl]: string read GetError write SetError;\r\n // Gets or sets a value indicating where the error image should be placed in relation to the control.\r\n // The location can be further modified by assigning a non-zero value to ImagePadding\r\n // Possible values:\r\n // eiaBottomLeft - display the error image on the controls left side aligned to the bottom edge of the control\r\n // eiaBottomRight - display the error image on the controls right side aligned to the bottom edge of the control\r\n // eiaMiddleLeft - display the error image on the controls left side aligned to the middle of the control\r\n // eiaMiddleRight - display the error image on the controls right side aligned to the middle of the control\r\n // eiaTopLeft - display the error image on the controlsleft side aligned to the top edge of the control\r\n // eiaTopRight - display the error image on the controls right side aligned to the top edge of the control\r\n // Use AControl = nil to set the same Alignment for all controls\r\n property ImageAlignment[AControl: TControl]: TJvErrorImageAlignment read GetImageAlignment write SetImageAlignment;\r\n // Gets or sets the amount of extra space to leave between the specified control and the error image.\r\n // Use AControl = nil to set the same padding for all controls.\r\n property ImagePadding[AControl: TControl]: Integer read GetImagePadding write SetImagePadding;\r\n published\r\n // The rate at which the error image should flash. The rate is expressed in milliseconds. The default is 250 milliseconds.\r\n // A value of zero sets BlinkStyle to ebsNeverBlink.\r\n property BlinkRate: Integer read FBlinkRate write SetBlinkRate default 250;\r\n // The error Image flashes in the manner specified by the assigned BlinkStyle when an error occurs.\r\n // Possible values:\r\n // ebsBlinkIfDifferentError - blink if the new error message differs from the previous\r\n // ebsAlwaysBlink - always blink when the error message changes, even if it's the same message\r\n // ebsNeverBlink - never bink, just display the error image and the description\r\n // Setting the BlinkRate to zero sets the BlinkStyle to ebsNeverBlink.\r\n // The default is ebsBlinkIfDifferentError\r\n property BlinkStyle: TJvErrorBlinkStyle read FBlinkStyle write SetBlinkStyle default ebsBlinkIfDifferentError;\r\n // Gets or sets the ImageList where to retrieve an image to display next to a control when an error description\r\n // string has been set for the control.\r\n // This property is used in conjunction with ImageIndex to select the image to display\r\n // If either is nil, invalid or out of range, no error image is displayed\r\n property Images: TCustomImageList read FImageList write SetImageList;\r\n // Gets or sets the ImageIndex in ImageList to use when displaying an image next to a control\r\n property ImageIndex: Integer read FImageIndex write SetImageIndex;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvErrorIndicator.pas $';\r\n Revision: '$Revision: 13104 $';\r\n Date: '$Date: 2011-09-07 08:50:43 +0200 (mer. 07 sept. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n CommCtrl,\r\n SysUtils,\r\n JvTypes, JvResources, JvJVCLUtils;\r\n\r\n{$R JvErrorIndicator.res}\r\n\r\nconst\r\n cDefBlinkCount = 5;\r\n\r\ntype\r\n TJvBlinkThreadEvent = procedure(Sender: TObject; Erase: Boolean) of object;\r\n\r\n TJvBlinkThread = class(TJvCustomThread)\r\n private\r\n FBlinkRate: Integer;\r\n FErase: Boolean;\r\n FOnBlink: TJvBlinkThreadEvent;\r\n procedure Blink;\r\n protected\r\n procedure Execute; override;\r\n public\r\n constructor Create(BlinkRate: Integer; AOnBlink: TJvBlinkThreadEvent);\r\n end;\r\n\r\n//=== { TJvErrorIndicator } ==================================================\r\n\r\nconstructor TJvErrorIndicator.Create(AComponent: TComponent);\r\n\r\nbegin\r\n inherited Create(AComponent);\r\n FDefaultImage := TImageList.CreateSize(16, 16);\r\n ImageList_AddIcon(FDefaultImage.Handle,\r\n LoadImage(HInstance, PChar('XJVERRORINDICATORICON'), IMAGE_ICON, 16, 16, 0));\r\n FBlinkStyle := ebsBlinkIfDifferentError;\r\n FBlinkRate := 250;\r\n FControls := TList.Create;\r\n FChangeLink := TChangeLink.Create;\r\n FChangeLink.OnChange := DoChangeLinkChange;\r\nend;\r\n\r\ndestructor TJvErrorIndicator.Destroy;\r\nbegin\r\n StopThread;\r\n ClearErrors;\r\n FControls.Free;\r\n FChangeLink.Free;\r\n FDefaultImage.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJvErrorIndicator.Add(AControl: TControl): Integer;\r\nvar\r\n Ci: TJvErrorControl;\r\nbegin\r\n Result := IndexOf(AControl);\r\n if (Result < 0) and (AControl <> nil) then\r\n begin\r\n Ci := TJvErrorControl.Create(Self);\r\n Ci.Control := AControl;\r\n // Ci.Name := Ci.Control.Name + '_ErrorControl';\r\n Result := FControls.Add(Ci);\r\n end;\r\nend;\r\n\r\nprocedure TJvErrorIndicator.Delete(Index: Integer);\r\nbegin\r\n Controls[Index].Free; // removes itself from FControls[]\r\nend;\r\n\r\nfunction TJvErrorIndicator.GetError(AControl: TControl): string;\r\nvar\r\n I: Integer;\r\nbegin\r\n I := IndexOf(AControl);\r\n if I > -1 then\r\n Result := Controls[I].Error\r\n else\r\n raise EJVCLException.CreateRes(@RsEControlNotFoundInGetError);\r\nend;\r\n\r\nfunction TJvErrorIndicator.GetImageAlignment(AControl: TControl): TJvErrorImageAlignment;\r\nvar\r\n I: Integer;\r\nbegin\r\n I := IndexOf(AControl);\r\n if I > -1 then\r\n Result := Controls[I].ImageAlignment\r\n else\r\n raise EJVCLException.CreateRes(@RsEControlNotFoundInGetImageAlignment);\r\nend;\r\n\r\nfunction TJvErrorIndicator.GetImagePadding(AControl: TControl): Integer;\r\nvar\r\n I: Integer;\r\nbegin\r\n I := IndexOf(AControl);\r\n if I > -1 then\r\n Result := Controls[I].ImagePadding\r\n else\r\n raise EJVCLException.CreateRes(@RsEControlNotFoundInGetImagePadding);\r\nend;\r\n\r\nfunction TJvErrorIndicator.IndexOf(AControl: TControl): Integer;\r\nbegin\r\n if AControl <> nil then\r\n for Result := 0 to Count - 1 do\r\n if Controls[Result].Control = AControl then\r\n Exit;\r\n Result := -1;\r\nend;\r\n\r\nprocedure TJvErrorIndicator.Notification(AComponent: TComponent;\r\n Operation: TOperation);\r\nvar\r\n I: Integer;\r\nbegin\r\n inherited Notification(AComponent, Operation);\r\n if Operation = opRemove then\r\n begin\r\n if AComponent is TControl then\r\n I := IndexOf(TControl(AComponent))\r\n else\r\n I := -1;\r\n if I > -1 then\r\n Delete(I);\r\n if AComponent = Images then\r\n Images := nil;\r\n end;\r\nend;\r\n\r\nprocedure TJvErrorIndicator.SetBlinkRate(const Value: Integer);\r\nbegin\r\n if FBlinkRate <> Value then\r\n begin\r\n StopThread;\r\n FBlinkRate := Value;\r\n if FBlinkRate <= 0 then\r\n begin\r\n FBlinkRate := 0;\r\n FBlinkStyle := ebsNeverBlink;\r\n end;\r\n UpdateControls;\r\n end;\r\nend;\r\n\r\nprocedure TJvErrorIndicator.SetBlinkStyle(const Value: TJvErrorBlinkStyle);\r\nbegin\r\n if FBlinkStyle <> Value then\r\n begin\r\n StopThread;\r\n FBlinkStyle := Value;\r\n UpdateControls;\r\n end;\r\nend;\r\n\r\nprocedure TJvErrorIndicator.SetError(AControl: TControl;\r\n const Value: string);\r\nvar\r\n I: Integer;\r\n Ei: TJvErrorControl;\r\nbegin\r\n StopThread;\r\n if AControl = nil then\r\n begin\r\n if Value = '' then\r\n ClearErrors\r\n else\r\n for I := 0 to Count - 1 do\r\n begin\r\n Ei := Controls[I];\r\n if ((Ei.Error <> Value) and (BlinkStyle = ebsBlinkIfDifferentError)) or (BlinkStyle = ebsAlwaysBlink) then\r\n Ei.BlinkCount := cDefBlinkCount\r\n else\r\n if BlinkStyle = ebsNeverBlink then\r\n Ei.BlinkCount := 0;\r\n Ei.Error := Value;\r\n end;\r\n end\r\n else\r\n begin\r\n I := Add(AControl);\r\n if I > -1 then\r\n begin\r\n if Value = '' then\r\n Delete(I)\r\n else\r\n begin\r\n Ei := Controls[I];\r\n if ((Ei.Error <> Value) and (BlinkStyle = ebsBlinkIfDifferentError)) or\r\n (BlinkStyle = ebsAlwaysBlink) then\r\n begin\r\n Ei.Error := Value;\r\n Ei.BlinkCount := cDefBlinkCount;\r\n Ei.Visible := (csDesigning in ComponentState);\r\n if (FUpdateCount = 0) and (FBlinkThread = nil) then\r\n StartThread;\r\n end\r\n else\r\n if BlinkStyle = ebsNeverBlink then\r\n begin\r\n Ei.BlinkCount := 0;\r\n Ei.Error := Value;\r\n Ei.Visible := (Value <> '');\r\n end;\r\n end;\r\n UpdateControls;\r\n end\r\n else\r\n raise EJVCLException.CreateRes(@RsEUnableToAddControlInSetError);\r\n end;\r\nend;\r\n\r\nprocedure TJvErrorIndicator.SetImageAlignment(AControl: TControl;\r\n const Value: TJvErrorImageAlignment);\r\nvar\r\n I: Integer;\r\nbegin\r\n if AControl = nil then\r\n for I := 0 to Count - 1 do\r\n Controls[I].ImageAlignment := Value\r\n else\r\n begin\r\n I := Add(AControl);\r\n if I > -1 then\r\n Controls[I].ImageAlignment := Value\r\n else\r\n raise EJVCLException.CreateRes(@RsEUnableToAddControlInSetImageAlignme);\r\n end;\r\nend;\r\n\r\nprocedure TJvErrorIndicator.SetImagePadding(AControl: TControl;\r\n const Value: Integer);\r\nvar\r\n I: Integer;\r\nbegin\r\n if AControl = nil then\r\n for I := 0 to Count - 1 do\r\n Controls[I].ImagePadding := Value\r\n else\r\n begin\r\n I := Add(AControl);\r\n if I > 1 then\r\n Controls[I].ImagePadding := Value\r\n else\r\n raise EJVCLException.CreateRes(@RsEUnableToAddControlInSetImagePadding);\r\n end;\r\nend;\r\n\r\nprocedure TJvErrorIndicator.UpdateControls;\r\nvar\r\n I, J: Integer;\r\n IL: TCustomImageList;\r\nbegin\r\n if Images <> nil then\r\n begin\r\n IL := Images;\r\n J := ImageIndex;\r\n end\r\n else\r\n begin\r\n IL := FDefaultImage;\r\n J := 0;\r\n end;\r\n for I := 0 to Count - 1 do\r\n begin\r\n Controls[I].Images := IL;\r\n Controls[I].ImageIndex := J;\r\n end;\r\nend;\r\n\r\nprocedure TJvErrorIndicator.SetImageList(const Value: TCustomImageList);\r\nbegin\r\n if FImageList <> Value then\r\n begin\r\n StopThread;\r\n ReplaceImageListReference(Self, Value, FImageList, FChangeLink);\r\n UpdateControls;\r\n end;\r\nend;\r\n\r\nprocedure TJvErrorIndicator.SetImageIndex(const Value: Integer);\r\nbegin\r\n if FImageIndex <> Value then\r\n begin\r\n StopThread;\r\n FImageIndex := Value;\r\n UpdateControls;\r\n end;\r\nend;\r\n\r\nprocedure TJvErrorIndicator.DoChangeLinkChange(Sender: TObject);\r\nbegin\r\n UpdateControls;\r\nend;\r\n\r\nprocedure TJvErrorIndicator.ClearErrors;\r\nvar\r\n I: Integer;\r\nbegin\r\n StopThread;\r\n for I := Count - 1 downto 0 do\r\n Controls[I].Free;\r\n FControls.Clear;\r\nend;\r\n\r\nprocedure TJvErrorIndicator.BeginUpdate;\r\n{var\r\n I: Integer;}\r\nbegin\r\n Inc(FUpdateCount);\r\n StopThread;\r\n // ahuser: The following code produces flicker\r\n {for I := 0 to Count - 1 do\r\n Controls[I].Visible := False;}\r\nend;\r\n\r\nprocedure TJvErrorIndicator.EndUpdate;\r\nbegin\r\n if FUpdateCount > 0 then\r\n begin\r\n Dec(FUpdateCount);\r\n if FUpdateCount = 0 then\r\n begin\r\n UpdateControls;\r\n StartThread;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvErrorIndicator.StartThread;\r\nbegin\r\n if BlinkStyle <> ebsNeverBlink then\r\n FBlinkThread := TJvBlinkThread.Create(BlinkRate, DoBlink);\r\nend;\r\n\r\nprocedure TJvErrorIndicator.StopThread;\r\nbegin\r\n if FBlinkThread <> nil then\r\n try\r\n FBlinkThread.Terminate;\r\n FBlinkThread.WaitFor;\r\n finally\r\n FreeAndNil(FBlinkThread);\r\n end;\r\nend;\r\n\r\nprocedure TJvErrorIndicator.DoBlink(Sender: TObject; Erase: Boolean);\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := 0 to Count - 1 do\r\n Controls[I].DrawImage(Erase);\r\nend;\r\n\r\nfunction TJvErrorIndicator.GetControl(Index: Integer): TJvErrorControl;\r\nbegin\r\n Result := TJvErrorControl(FControls[Index]);\r\nend;\r\n\r\nfunction TJvErrorIndicator.GetCount: Integer;\r\nbegin\r\n Result := FControls.Count;\r\nend;\r\n\r\nprocedure TJvErrorIndicator.SetClientError(const AClient: IJvErrorIndicatorClient);\r\nbegin\r\n if AClient <> nil then\r\n SetError(AClient.GetControl, AClient.ErrorMessage);\r\nend;\r\n\r\nprocedure TJvErrorIndicator.IndicatorSetError(AControl: TControl;\r\n const ErrorMessage: WideString);\r\nbegin\r\n SetError(AControl, ErrorMessage);\r\nend;\r\n\r\n//=== { TJvErrorControl } ====================================================\r\n\r\nconstructor TJvErrorControl.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FImageAlignment := eiaMiddleRight;\r\n ShowHint := True;\r\n Visible := False;\r\n Width := 16;\r\n Height := 16;\r\nend;\r\n\r\ndestructor TJvErrorControl.Destroy;\r\nbegin\r\n TJvErrorIndicator(Owner).FControls.Extract(Self);\r\n Control := nil;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvErrorControl.DrawImage(Erase: Boolean);\r\nbegin\r\n if not Assigned(Control) or not Assigned(Control.Parent) or not Assigned(Images) then\r\n Exit;\r\n Visible := (Error <> '') and (not Erase or (BlinkCount < 2));\r\n if not Visible and (BlinkCount > 1) then\r\n Dec(FBlinkCount);\r\n if Visible then\r\n BoundsRect := CalcBoundsRect;\r\nend;\r\n\r\nfunction TJvErrorControl.CalcBoundsRect: TRect;\r\nbegin\r\n if (Control = nil) or (Images = nil) then\r\n Result := Rect(0, 0, 0, 0)\r\n else\r\n begin\r\n case ImageAlignment of\r\n eiaBottomLeft:\r\n begin\r\n // must qualify Result fully since Delphi confuses the TRect with the controls Top/Left properties\r\n Result.Right := Control.Left - 1;\r\n Result.Left := Result.Right - Images.Width;\r\n Result.Bottom := Control.Top + Control.Height;\r\n Result.Top := Result.Bottom - Images.Height;\r\n OffsetRect(Result, -ImagePadding, 0);\r\n end;\r\n eiaBottomRight:\r\n begin\r\n Result.Left := Control.Left + Control.Width + 1;\r\n Result.Right := Result.Left + Images.Width;\r\n Result.Bottom := Control.Top + Control.Height;\r\n Result.Top := Result.Bottom - Images.Height;\r\n OffsetRect(Result, ImagePadding, 0);\r\n end;\r\n eiaMiddleLeft:\r\n begin\r\n Result.Right := Control.Left - 1;\r\n Result.Left := Result.Right - Images.Width;\r\n Result.Top := Control.Top + (Control.Height - Images.Height) div 2;\r\n Result.Bottom := Result.Top + Images.Height;\r\n OffsetRect(Result, -ImagePadding, 0);\r\n end;\r\n eiaMiddleRight:\r\n begin\r\n Result.Left := Control.Left + Control.Width + 1;\r\n Result.Right := Result.Left + Images.Width;\r\n Result.Top := Control.Top + (Control.Height - Images.Height) div 2;\r\n Result.Bottom := Result.Top + Images.Height;\r\n OffsetRect(Result, ImagePadding, 0);\r\n end;\r\n eiaTopLeft:\r\n begin\r\n Result.Right := Control.Left - 1;\r\n Result.Left := Result.Right - Images.Width;\r\n Result.Top := Control.Top;\r\n Result.Bottom := Result.Top + Control.Height;\r\n OffsetRect(Result, -ImagePadding, 0);\r\n end;\r\n eiaTopRight:\r\n begin\r\n Result.Left := Control.Left + Control.Width + 1;\r\n Result.Right := Result.Left + Images.Width;\r\n Result.Top := Control.Top;\r\n Result.Bottom := Result.Top + Images.Height;\r\n OffsetRect(Result, ImagePadding, 0);\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvErrorControl.Paint;\r\nbegin\r\n // inherited Paint;\r\n if (Images <> nil) and Visible then\r\n Images.Draw(Canvas, 0, 0, ImageIndex, dsTransparent, itImage);\r\nend;\r\n\r\nprocedure TJvErrorControl.SetError(const Value: string);\r\nbegin\r\n Hint := Value;\r\nend;\r\n\r\nfunction TJvErrorControl.GetError: string;\r\nbegin\r\n Result := Hint;\r\nend;\r\n\r\nprocedure TJvErrorControl.SetImageIndex(const Value: Integer);\r\nbegin\r\n if FImageIndex <> Value then\r\n begin\r\n FImageIndex := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvErrorControl.SetImageList(const Value: TCustomImageList);\r\nbegin\r\n if ReplaceComponentReference(Self, Value, TComponent(FImageList)) then\r\n begin\r\n if FImageList <> nil then\r\n BoundsRect := CalcBoundsRect\r\n else\r\n SetBounds(Left, Top, 16, 16);\r\n // Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvErrorControl.SetControl(const Value: TControl);\r\nbegin\r\n if FControl <> Value then\r\n begin\r\n ReplaceComponentReference(Self, Value, TComponent(FControl));\r\n if FControl <> nil then\r\n Parent := FControl.Parent\r\n else\r\n Parent := nil;\r\n end;\r\nend;\r\n\r\nprocedure TJvErrorControl.Notification(AComponent: TComponent;\r\n Operation: TOperation);\r\nbegin\r\n inherited Notification(AComponent, Operation);\r\n if (Operation = opRemove) then\r\n if (AComponent = Control) then\r\n Control := nil\r\n else if (AComponent = FImageList) then\r\n FImageList := nil\r\nend;\r\n\r\n//=== { TJvBlinkThread } =====================================================\r\n\r\nconstructor TJvBlinkThread.Create(BlinkRate: Integer; AOnBlink: TJvBlinkThreadEvent);\r\nbegin\r\n inherited Create(False);\r\n FBlinkRate := BlinkRate;\r\n FErase := False;\r\n FOnBlink := AOnBlink;\r\nend;\r\n\r\nprocedure TJvBlinkThread.Blink;\r\nbegin\r\n if Assigned(FOnBlink) then\r\n FOnBlink(Self, FErase);\r\nend;\r\n\r\nprocedure TJvBlinkThread.Execute;\r\nbegin\r\n NameThread(ThreadName);\r\n FErase := False;\r\n while not Terminated and not Suspended do\r\n begin\r\n Sleep(FBlinkRate);\r\n Synchronize(Blink);\r\n if FBlinkRate = 0 then\r\n Exit;\r\n FErase := not FErase;\r\n end;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvExButtons.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvExButtons.pas, released on 2004-01-04\r\n\r\nThe Initial Developer of the Original Code is Andreas Hausladen [Andreas dott Hausladen att gmx dott de]\r\nPortions created by Andreas Hausladen are Copyright (C) 2004 Andreas Hausladen.\r\nAll Rights Reserved.\r\n\r\nContributor(s): -\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvExButtons.pas 13173 2011-11-19 12:43:58Z ahuser $\r\n\r\nunit JvExButtons;\r\n\r\n{$I jvcl.inc}\r\n{MACROINCLUDE JvExControls.macros}\r\n\r\n{*****************************************************************************\r\n * WARNING: Do not edit this file.\r\n * This file is autogenerated from the source in devtools/JvExVCL/src.\r\n * If you do it despite this warning your changes will be discarded by the next\r\n * update of this file. Do your changes in the template files.\r\n ****************************************************************************}\r\n{$D-} // do not step into this unit\r\n\r\ninterface\r\n\r\nuses\r\n Windows, Messages, Types,\r\n SysUtils, Classes, Graphics, Controls, Forms, Buttons, StdCtrls,\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n JvTypes, JvThemes, JVCLVer, JvExControls;\r\n\r\ntype\r\n TJvExSpeedButton = class(TSpeedButton, IJvExControl)\r\n private\r\n FAboutJVCL: TJVCLAboutInfo;\r\n FHintColor: TColor;\r\n FMouseOver: Boolean;\r\n FHintWindowClass: THintWindowClass;\r\n FOnMouseEnter: TNotifyEvent;\r\n FOnMouseLeave: TNotifyEvent;\r\n FOnParentColorChanged: TNotifyEvent;\r\n function BaseWndProc(Msg: Cardinal; WParam: WPARAM = 0; LParam: LPARAM = 0): LRESULT; overload;\r\n function BaseWndProc(Msg: Cardinal; WParam: WPARAM; LParam: TObject): LRESULT; overload;\r\n function BaseWndProcEx(Msg: Cardinal; WParam: WPARAM; var StructLParam): LRESULT;\r\n protected\r\n procedure WndProc(var Msg: TMessage); override;\r\n procedure FocusChanged(AControl: TWinControl); dynamic;\r\n procedure VisibleChanged; reintroduce; dynamic;\r\n procedure EnabledChanged; reintroduce; dynamic;\r\n procedure TextChanged; reintroduce; virtual;\r\n procedure ColorChanged; reintroduce; dynamic;\r\n procedure FontChanged; reintroduce; dynamic;\r\n procedure ParentFontChanged; reintroduce; dynamic;\r\n procedure ParentColorChanged; reintroduce; dynamic;\r\n procedure ParentShowHintChanged; reintroduce; dynamic;\r\n function WantKey(Key: Integer; Shift: TShiftState): Boolean; virtual;\r\n function HintShow(var HintInfo: THintInfo): Boolean; reintroduce; dynamic;\r\n function HitTest(X, Y: Integer): Boolean; reintroduce; virtual;\r\n procedure MouseEnter(AControl: TControl); reintroduce; dynamic;\r\n procedure MouseLeave(AControl: TControl); reintroduce; dynamic;\r\n property MouseOver: Boolean read FMouseOver write FMouseOver;\r\n property HintColor: TColor read FHintColor write FHintColor default clDefault;\r\n property OnMouseEnter: TNotifyEvent read FOnMouseEnter write FOnMouseEnter;\r\n property OnMouseLeave: TNotifyEvent read FOnMouseLeave write FOnMouseLeave;\r\n property OnParentColorChange: TNotifyEvent read FOnParentColorChanged write FOnParentColorChanged;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n property HintWindowClass: THintWindowClass read FHintWindowClass write FHintWindowClass;\r\n published\r\n property AboutJVCL: TJVCLAboutInfo read FAboutJVCL write FAboutJVCL stored False;\r\n end;\r\n\r\n TJvExBitBtn = class(TBitBtn, IJvExControl)\r\n private\r\n FAboutJVCL: TJVCLAboutInfo;\r\n FHintColor: TColor;\r\n FMouseOver: Boolean;\r\n FHintWindowClass: THintWindowClass;\r\n FOnMouseEnter: TNotifyEvent;\r\n FOnMouseLeave: TNotifyEvent;\r\n FOnParentColorChanged: TNotifyEvent;\r\n function BaseWndProc(Msg: Cardinal; WParam: WPARAM = 0; LParam: LPARAM = 0): LRESULT; overload;\r\n function BaseWndProc(Msg: Cardinal; WParam: WPARAM; LParam: TObject): LRESULT; overload;\r\n function BaseWndProcEx(Msg: Cardinal; WParam: WPARAM; var StructLParam): LRESULT;\r\n protected\r\n procedure WndProc(var Msg: TMessage); override;\r\n procedure FocusChanged(AControl: TWinControl); dynamic;\r\n procedure VisibleChanged; reintroduce; dynamic;\r\n procedure EnabledChanged; reintroduce; dynamic;\r\n procedure TextChanged; reintroduce; virtual;\r\n procedure ColorChanged; reintroduce; dynamic;\r\n procedure FontChanged; reintroduce; dynamic;\r\n procedure ParentFontChanged; reintroduce; dynamic;\r\n procedure ParentColorChanged; reintroduce; dynamic;\r\n procedure ParentShowHintChanged; reintroduce; dynamic;\r\n function WantKey(Key: Integer; Shift: TShiftState): Boolean; virtual;\r\n function HintShow(var HintInfo: THintInfo): Boolean; reintroduce; dynamic;\r\n function HitTest(X, Y: Integer): Boolean; reintroduce; virtual;\r\n procedure MouseEnter(AControl: TControl); reintroduce; dynamic;\r\n procedure MouseLeave(AControl: TControl); reintroduce; dynamic;\r\n property MouseOver: Boolean read FMouseOver write FMouseOver;\r\n property HintColor: TColor read FHintColor write FHintColor default clDefault;\r\n property OnMouseEnter: TNotifyEvent read FOnMouseEnter write FOnMouseEnter;\r\n property OnMouseLeave: TNotifyEvent read FOnMouseLeave write FOnMouseLeave;\r\n property OnParentColorChange: TNotifyEvent read FOnParentColorChanged write FOnParentColorChanged;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n property HintWindowClass: THintWindowClass read FHintWindowClass write FHintWindowClass;\r\n published\r\n property AboutJVCL: TJVCLAboutInfo read FAboutJVCL write FAboutJVCL stored False;\r\n private\r\n FDotNetHighlighting: Boolean;\r\n protected\r\n procedure BoundsChanged; reintroduce; virtual;\r\n procedure CursorChanged; reintroduce; dynamic;\r\n procedure ShowingChanged; reintroduce; dynamic;\r\n procedure ShowHintChanged; reintroduce; dynamic;\r\n procedure ControlsListChanging(Control: TControl; Inserting: Boolean); reintroduce; dynamic;\r\n procedure ControlsListChanged(Control: TControl; Inserting: Boolean); reintroduce; dynamic;\r\n procedure GetDlgCode(var Code: TDlgCodes); virtual;\r\n procedure FocusSet(PrevWnd: THandle); virtual;\r\n procedure FocusKilled(NextWnd: THandle); virtual;\r\n function DoEraseBackground(Canvas: TCanvas; Param: LPARAM): Boolean; virtual;\r\n {$IFDEF JVCLThemesEnabledD6}\r\n private\r\n function GetParentBackground: Boolean;\r\n protected\r\n procedure SetParentBackground(Value: Boolean); virtual;\r\n property ParentBackground: Boolean read GetParentBackground write SetParentBackground;\r\n {$ENDIF JVCLThemesEnabledD6}\r\n published\r\n property DotNetHighlighting: Boolean read FDotNetHighlighting write FDotNetHighlighting default False;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvExButtons.pas $';\r\n Revision: '$Revision: 13173 $';\r\n Date: '$Date: 2011-11-19 13:43:58 +0100 (sam. 19 nov. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nconstructor TJvExSpeedButton.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FHintColor := clDefault;\r\nend;\r\n\r\nfunction TJvExSpeedButton.BaseWndProc(Msg: Cardinal; WParam: WPARAM = 0; LParam: LPARAM = 0): LRESULT;\r\nvar\r\n Mesg: TMessage;\r\nbegin\r\n CreateWMMessage(Mesg, Msg, WParam, LParam);\r\n inherited WndProc(Mesg);\r\n Result := Mesg.Result;\r\nend;\r\n\r\nfunction TJvExSpeedButton.BaseWndProc(Msg: Cardinal; WParam: WPARAM; LParam: TObject): LRESULT;\r\nbegin\r\n Result := BaseWndProc(Msg, WParam, Windows.LPARAM(LParam));\r\nend;\r\n\r\nfunction TJvExSpeedButton.BaseWndProcEx(Msg: Cardinal; WParam: WPARAM; var StructLParam): LRESULT;\r\nbegin\r\n Result := BaseWndProc(Msg, WParam, Windows.LPARAM(@StructLParam));\r\nend;\r\n\r\nprocedure TJvExSpeedButton.VisibleChanged;\r\nbegin\r\n BaseWndProc(CM_VISIBLECHANGED);\r\nend;\r\n\r\nprocedure TJvExSpeedButton.EnabledChanged;\r\nbegin\r\n BaseWndProc(CM_ENABLEDCHANGED);\r\nend;\r\n\r\nprocedure TJvExSpeedButton.TextChanged;\r\nbegin\r\n BaseWndProc(CM_TEXTCHANGED);\r\nend;\r\n\r\nprocedure TJvExSpeedButton.FontChanged;\r\nbegin\r\n BaseWndProc(CM_FONTCHANGED);\r\nend;\r\n\r\nprocedure TJvExSpeedButton.ColorChanged;\r\nbegin\r\n BaseWndProc(CM_COLORCHANGED);\r\nend;\r\n\r\nprocedure TJvExSpeedButton.ParentFontChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTFONTCHANGED);\r\nend;\r\n\r\nprocedure TJvExSpeedButton.ParentColorChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTCOLORCHANGED);\r\n if Assigned(OnParentColorChange) then\r\n OnParentColorChange(Self);\r\nend;\r\n\r\nprocedure TJvExSpeedButton.ParentShowHintChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTSHOWHINTCHANGED);\r\nend;\r\n\r\nfunction TJvExSpeedButton.WantKey(Key: Integer; Shift: TShiftState): Boolean;\r\nbegin\r\n Result := BaseWndProc(CM_DIALOGCHAR, Word(Key), ShiftStateToKeyData(Shift)) <> 0;\r\nend;\r\n\r\nfunction TJvExSpeedButton.HitTest(X, Y: Integer): Boolean;\r\nbegin\r\n Result := BaseWndProc(CM_HITTEST, 0, SmallPointToLong(PointToSmallPoint(Point(X, Y)))) <> 0;\r\nend;\r\n\r\nfunction TJvExSpeedButton.HintShow(var HintInfo: THintInfo): Boolean;\r\nbegin\r\n GetHintColor(HintInfo, Self, FHintColor);\r\n if FHintWindowClass <> nil then\r\n HintInfo.HintWindowClass := FHintWindowClass;\r\n Result := BaseWndProcEx(CM_HINTSHOW, 0, HintInfo) <> 0;\r\nend;\r\n\r\nprocedure TJvExSpeedButton.MouseEnter(AControl: TControl);\r\nbegin\r\n FMouseOver := True;\r\n if Assigned(FOnMouseEnter) then\r\n FOnMouseEnter(Self);\r\n BaseWndProc(CM_MOUSEENTER, 0, AControl);\r\nend;\r\n\r\nprocedure TJvExSpeedButton.MouseLeave(AControl: TControl);\r\nbegin\r\n FMouseOver := False;\r\n BaseWndProc(CM_MOUSELEAVE, 0, AControl);\r\n if Assigned(FOnMouseLeave) then\r\n FOnMouseLeave(Self);\r\nend;\r\n\r\nprocedure TJvExSpeedButton.FocusChanged(AControl: TWinControl);\r\nbegin\r\n BaseWndProc(CM_FOCUSCHANGED, 0, AControl);\r\nend;\r\n\r\nprocedure TJvExSpeedButton.WndProc(var Msg: TMessage);\r\nbegin\r\n if not DispatchIsDesignMsg(Self, Msg) then\r\n case Msg.Msg of\r\n CM_DENYSUBCLASSING:\r\n Msg.Result := LRESULT(Ord(GetInterfaceEntry(IJvDenySubClassing) <> nil));\r\n CM_DIALOGCHAR:\r\n with TCMDialogChar{$IFDEF CLR}.Create{$ENDIF}(Msg) do\r\n Result := LRESULT(Ord(WantKey(CharCode, KeyDataToShiftState(KeyData))));\r\n CM_HINTSHOW:\r\n with TCMHintShow(Msg) do\r\n Result := LRESULT(HintShow(HintInfo^));\r\n CM_HITTEST:\r\n with TCMHitTest(Msg) do\r\n Result := LRESULT(HitTest(XPos, YPos));\r\n CM_MOUSEENTER:\r\n MouseEnter(TControl(Msg.LParam));\r\n CM_MOUSELEAVE:\r\n MouseLeave(TControl(Msg.LParam));\r\n CM_VISIBLECHANGED:\r\n VisibleChanged;\r\n CM_ENABLEDCHANGED:\r\n EnabledChanged;\r\n CM_TEXTCHANGED:\r\n TextChanged;\r\n CM_FONTCHANGED:\r\n FontChanged;\r\n CM_COLORCHANGED:\r\n ColorChanged;\r\n CM_FOCUSCHANGED:\r\n FocusChanged(TWinControl(Msg.LParam));\r\n CM_PARENTFONTCHANGED:\r\n ParentFontChanged;\r\n CM_PARENTCOLORCHANGED:\r\n ParentColorChanged;\r\n CM_PARENTSHOWHINTCHANGED:\r\n ParentShowHintChanged;\r\n else\r\n inherited WndProc(Msg);\r\n end;\r\nend;\r\n\r\n//============================================================================\r\n\r\nconstructor TJvExBitBtn.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FHintColor := clDefault;\r\nend;\r\n\r\nfunction TJvExBitBtn.BaseWndProc(Msg: Cardinal; WParam: WPARAM = 0; LParam: LPARAM = 0): LRESULT;\r\nvar\r\n Mesg: TMessage;\r\nbegin\r\n CreateWMMessage(Mesg, Msg, WParam, LParam);\r\n inherited WndProc(Mesg);\r\n Result := Mesg.Result;\r\nend;\r\n\r\nfunction TJvExBitBtn.BaseWndProc(Msg: Cardinal; WParam: WPARAM; LParam: TObject): LRESULT;\r\nbegin\r\n Result := BaseWndProc(Msg, WParam, Windows.LPARAM(LParam));\r\nend;\r\n\r\nfunction TJvExBitBtn.BaseWndProcEx(Msg: Cardinal; WParam: WPARAM; var StructLParam): LRESULT;\r\nbegin\r\n Result := BaseWndProc(Msg, WParam, Windows.LPARAM(@StructLParam));\r\nend;\r\n\r\nprocedure TJvExBitBtn.VisibleChanged;\r\nbegin\r\n BaseWndProc(CM_VISIBLECHANGED);\r\nend;\r\n\r\nprocedure TJvExBitBtn.EnabledChanged;\r\nbegin\r\n BaseWndProc(CM_ENABLEDCHANGED);\r\nend;\r\n\r\nprocedure TJvExBitBtn.TextChanged;\r\nbegin\r\n BaseWndProc(CM_TEXTCHANGED);\r\nend;\r\n\r\nprocedure TJvExBitBtn.FontChanged;\r\nbegin\r\n BaseWndProc(CM_FONTCHANGED);\r\nend;\r\n\r\nprocedure TJvExBitBtn.ColorChanged;\r\nbegin\r\n BaseWndProc(CM_COLORCHANGED);\r\nend;\r\n\r\nprocedure TJvExBitBtn.ParentFontChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTFONTCHANGED);\r\nend;\r\n\r\nprocedure TJvExBitBtn.ParentColorChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTCOLORCHANGED);\r\n if Assigned(OnParentColorChange) then\r\n OnParentColorChange(Self);\r\nend;\r\n\r\nprocedure TJvExBitBtn.ParentShowHintChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTSHOWHINTCHANGED);\r\nend;\r\n\r\nfunction TJvExBitBtn.WantKey(Key: Integer; Shift: TShiftState): Boolean;\r\nbegin\r\n Result := BaseWndProc(CM_DIALOGCHAR, Word(Key), ShiftStateToKeyData(Shift)) <> 0;\r\nend;\r\n\r\nfunction TJvExBitBtn.HitTest(X, Y: Integer): Boolean;\r\nbegin\r\n Result := BaseWndProc(CM_HITTEST, 0, SmallPointToLong(PointToSmallPoint(Point(X, Y)))) <> 0;\r\nend;\r\n\r\nfunction TJvExBitBtn.HintShow(var HintInfo: THintInfo): Boolean;\r\nbegin\r\n GetHintColor(HintInfo, Self, FHintColor);\r\n if FHintWindowClass <> nil then\r\n HintInfo.HintWindowClass := FHintWindowClass;\r\n Result := BaseWndProcEx(CM_HINTSHOW, 0, HintInfo) <> 0;\r\nend;\r\n\r\nprocedure TJvExBitBtn.MouseEnter(AControl: TControl);\r\nbegin\r\n FMouseOver := True;\r\n if Assigned(FOnMouseEnter) then\r\n FOnMouseEnter(Self);\r\n BaseWndProc(CM_MOUSEENTER, 0, AControl);\r\nend;\r\n\r\nprocedure TJvExBitBtn.MouseLeave(AControl: TControl);\r\nbegin\r\n FMouseOver := False;\r\n BaseWndProc(CM_MOUSELEAVE, 0, AControl);\r\n if Assigned(FOnMouseLeave) then\r\n FOnMouseLeave(Self);\r\nend;\r\n\r\nprocedure TJvExBitBtn.FocusChanged(AControl: TWinControl);\r\nbegin\r\n BaseWndProc(CM_FOCUSCHANGED, 0, AControl);\r\nend;\r\n\r\nprocedure TJvExBitBtn.BoundsChanged;\r\nbegin\r\nend;\r\n\r\nprocedure TJvExBitBtn.CursorChanged;\r\nbegin\r\n BaseWndProc(CM_CURSORCHANGED);\r\nend;\r\n\r\nprocedure TJvExBitBtn.ShowingChanged;\r\nbegin\r\n BaseWndProc(CM_SHOWINGCHANGED);\r\nend;\r\n\r\nprocedure TJvExBitBtn.ShowHintChanged;\r\nbegin\r\n BaseWndProc(CM_SHOWHINTCHANGED);\r\nend;\r\n\r\n{ VCL sends CM_CONTROLLISTCHANGE and CM_CONTROLCHANGE in a different order than\r\n the CLX methods are used. So we must correct it by evaluating \"Inserting\". }\r\nprocedure TJvExBitBtn.ControlsListChanging(Control: TControl; Inserting: Boolean);\r\nbegin\r\n if Inserting then\r\n BaseWndProc(CM_CONTROLLISTCHANGE, WPARAM(Control), LPARAM(Inserting))\r\n else\r\n BaseWndProc(CM_CONTROLCHANGE, WPARAM(Control), LPARAM(Inserting));\r\nend;\r\n\r\nprocedure TJvExBitBtn.ControlsListChanged(Control: TControl; Inserting: Boolean);\r\nbegin\r\n if not Inserting then\r\n BaseWndProc(CM_CONTROLLISTCHANGE, WPARAM(Control), LPARAM(Inserting))\r\n else\r\n BaseWndProc(CM_CONTROLCHANGE, WPARAM(Control), LPARAM(Inserting));\r\nend;\r\n\r\nprocedure TJvExBitBtn.GetDlgCode(var Code: TDlgCodes);\r\nbegin\r\nend;\r\n\r\nprocedure TJvExBitBtn.FocusSet(PrevWnd: THandle);\r\nbegin\r\n BaseWndProc(WM_SETFOCUS, WPARAM(PrevWnd), 0);\r\nend;\r\n\r\nprocedure TJvExBitBtn.FocusKilled(NextWnd: THandle);\r\nbegin\r\n BaseWndProc(WM_KILLFOCUS, WPARAM(NextWnd), 0);\r\nend;\r\n\r\nfunction TJvExBitBtn.DoEraseBackground(Canvas: TCanvas; Param: LPARAM): Boolean;\r\nbegin\r\n Result := BaseWndProc(WM_ERASEBKGND, Canvas.Handle, Param) <> 0;\r\nend;\r\n\r\n{$IFDEF JVCLThemesEnabledD6}\r\nfunction TJvExBitBtn.GetParentBackground: Boolean;\r\nbegin\r\n Result := JvThemes.GetParentBackground(Self);\r\nend;\r\n\r\nprocedure TJvExBitBtn.SetParentBackground(Value: Boolean);\r\nbegin\r\n JvThemes.SetParentBackground(Self, Value);\r\nend;\r\n{$ENDIF JVCLThemesEnabledD6}\r\n\r\nprocedure TJvExBitBtn.WndProc(var Msg: TMessage);\r\nvar\r\n IdSaveDC: Integer;\r\n DlgCodes: TDlgCodes;\r\n Canvas: TCanvas;\r\nbegin\r\n if not DispatchIsDesignMsg(Self, Msg) then\r\n begin\r\n case Msg.Msg of\r\n CM_DENYSUBCLASSING:\r\n Msg.Result := LRESULT(Ord(GetInterfaceEntry(IJvDenySubClassing) <> nil));\r\n CM_DIALOGCHAR:\r\n with TCMDialogChar{$IFDEF CLR}.Create{$ENDIF}(Msg) do\r\n Result := LRESULT(Ord(WantKey(CharCode, KeyDataToShiftState(KeyData))));\r\n CM_HINTSHOW:\r\n with TCMHintShow(Msg) do\r\n Result := LRESULT(HintShow(HintInfo^));\r\n CM_HITTEST:\r\n with TCMHitTest(Msg) do\r\n Result := LRESULT(HitTest(XPos, YPos));\r\n CM_MOUSEENTER:\r\n MouseEnter(TControl(Msg.LParam));\r\n CM_MOUSELEAVE:\r\n MouseLeave(TControl(Msg.LParam));\r\n CM_VISIBLECHANGED:\r\n VisibleChanged;\r\n CM_ENABLEDCHANGED:\r\n EnabledChanged;\r\n CM_TEXTCHANGED:\r\n TextChanged;\r\n CM_FONTCHANGED:\r\n FontChanged;\r\n CM_COLORCHANGED:\r\n ColorChanged;\r\n CM_FOCUSCHANGED:\r\n FocusChanged(TWinControl(Msg.LParam));\r\n CM_PARENTFONTCHANGED:\r\n ParentFontChanged;\r\n CM_PARENTCOLORCHANGED:\r\n ParentColorChanged;\r\n CM_PARENTSHOWHINTCHANGED:\r\n ParentShowHintChanged;\r\n CM_CURSORCHANGED:\r\n CursorChanged;\r\n CM_SHOWINGCHANGED:\r\n ShowingChanged;\r\n CM_SHOWHINTCHANGED:\r\n ShowHintChanged;\r\n CM_CONTROLLISTCHANGE:\r\n if Msg.LParam <> 0 then\r\n ControlsListChanging(TControl(Msg.WParam), True)\r\n else\r\n ControlsListChanged(TControl(Msg.WParam), False);\r\n CM_CONTROLCHANGE:\r\n if Msg.LParam = 0 then\r\n ControlsListChanging(TControl(Msg.WParam), False)\r\n else\r\n ControlsListChanged(TControl(Msg.WParam), True);\r\n WM_SETFOCUS:\r\n FocusSet(THandle(Msg.WParam));\r\n WM_KILLFOCUS:\r\n FocusKilled(THandle(Msg.WParam));\r\n WM_SIZE, WM_MOVE:\r\n begin\r\n inherited WndProc(Msg);\r\n BoundsChanged;\r\n end;\r\n WM_ERASEBKGND:\r\n if (Msg.WParam <> 0) and not IsDefaultEraseBackground(DoEraseBackground, @TJvExBitBtn.DoEraseBackground) then\r\n begin\r\n IdSaveDC := SaveDC(HDC(Msg.WParam)); // protect DC against Stock-Objects from Canvas\r\n Canvas := TCanvas.Create;\r\n try\r\n Canvas.Handle := HDC(Msg.WParam);\r\n Msg.Result := Ord(DoEraseBackground(Canvas, Msg.LParam));\r\n finally\r\n Canvas.Handle := 0;\r\n Canvas.Free;\r\n RestoreDC(HDC(Msg.WParam), IdSaveDC);\r\n end;\r\n end\r\n else\r\n inherited WndProc(Msg);\r\n {$IFNDEF DELPHI2007_UP}\r\n WM_PRINTCLIENT, WM_PRINT: // VCL bug fix\r\n begin\r\n IdSaveDC := SaveDC(HDC(Msg.WParam)); // protect DC against changes\r\n try\r\n inherited WndProc(Msg);\r\n finally\r\n RestoreDC(HDC(Msg.WParam), IdSaveDC);\r\n end;\r\n end;\r\n {$ENDIF ~DELPHI2007_UP}\r\n WM_GETDLGCODE:\r\n begin\r\n inherited WndProc(Msg);\r\n DlgCodes := [dcNative] + DlgcToDlgCodes(Msg.Result);\r\n GetDlgCode(DlgCodes);\r\n if not (dcNative in DlgCodes) then\r\n Msg.Result := DlgCodesToDlgc(DlgCodes);\r\n end;\r\n else\r\n inherited WndProc(Msg);\r\n end;\r\n case Msg.Msg of // precheck message to prevent access violations on released controls\r\n CM_MOUSEENTER, CM_MOUSELEAVE, WM_KILLFOCUS, WM_SETFOCUS, WM_NCPAINT:\r\n if DotNetHighlighting then\r\n HandleDotNetHighlighting(Self, Msg, MouseOver, Color);\r\n end;\r\n end;\r\nend;\r\n\r\n//============================================================================\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend." }, { "path": "External/Jedi/Jvcl/run/JvExCheckLst.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvExCheckLst.pas, released on 2004-01-04\r\n\r\nThe Initial Developer of the Original Code is Andreas Hausladen [Andreas dott Hausladen att gmx dott de]\r\nPortions created by Andreas Hausladen are Copyright (C) 2004 Andreas Hausladen.\r\nAll Rights Reserved.\r\n\r\nContributor(s): -\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvExCheckLst.pas 13173 2011-11-19 12:43:58Z ahuser $\r\n\r\nunit JvExCheckLst;\r\n\r\n{$I jvcl.inc}\r\n{MACROINCLUDE JvExControls.macros}\r\n\r\n{*****************************************************************************\r\n * WARNING: Do not edit this file.\r\n * This file is autogenerated from the source in devtools/JvExVCL/src.\r\n * If you do it despite this warning your changes will be discarded by the next\r\n * update of this file. Do your changes in the template files.\r\n ****************************************************************************}\r\n{$D-} // do not step into this unit\r\n\r\ninterface\r\n\r\nuses\r\n Windows, Messages, Types,\r\n SysUtils, Classes, Graphics, Controls, Forms, CheckLst,\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n JvTypes, JvThemes, JVCLVer, JvExControls;\r\n\r\ntype\r\n TJvExCheckListBox = class(TCheckListBox, IJvExControl)\r\n private\r\n FAboutJVCL: TJVCLAboutInfo;\r\n FHintColor: TColor;\r\n FMouseOver: Boolean;\r\n FHintWindowClass: THintWindowClass;\r\n FOnMouseEnter: TNotifyEvent;\r\n FOnMouseLeave: TNotifyEvent;\r\n FOnParentColorChanged: TNotifyEvent;\r\n function BaseWndProc(Msg: Cardinal; WParam: WPARAM = 0; LParam: LPARAM = 0): LRESULT; overload;\r\n function BaseWndProc(Msg: Cardinal; WParam: WPARAM; LParam: TObject): LRESULT; overload;\r\n function BaseWndProcEx(Msg: Cardinal; WParam: WPARAM; var StructLParam): LRESULT;\r\n protected\r\n procedure WndProc(var Msg: TMessage); override;\r\n procedure FocusChanged(AControl: TWinControl); dynamic;\r\n procedure VisibleChanged; reintroduce; dynamic;\r\n procedure EnabledChanged; reintroduce; dynamic;\r\n procedure TextChanged; reintroduce; virtual;\r\n procedure ColorChanged; reintroduce; dynamic;\r\n procedure FontChanged; reintroduce; dynamic;\r\n procedure ParentFontChanged; reintroduce; dynamic;\r\n procedure ParentColorChanged; reintroduce; dynamic;\r\n procedure ParentShowHintChanged; reintroduce; dynamic;\r\n function WantKey(Key: Integer; Shift: TShiftState): Boolean; virtual;\r\n function HintShow(var HintInfo: THintInfo): Boolean; reintroduce; dynamic;\r\n function HitTest(X, Y: Integer): Boolean; reintroduce; virtual;\r\n procedure MouseEnter(AControl: TControl); reintroduce; dynamic;\r\n procedure MouseLeave(AControl: TControl); reintroduce; dynamic;\r\n property MouseOver: Boolean read FMouseOver write FMouseOver;\r\n property HintColor: TColor read FHintColor write FHintColor default clDefault;\r\n property OnMouseEnter: TNotifyEvent read FOnMouseEnter write FOnMouseEnter;\r\n property OnMouseLeave: TNotifyEvent read FOnMouseLeave write FOnMouseLeave;\r\n property OnParentColorChange: TNotifyEvent read FOnParentColorChanged write FOnParentColorChanged;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n property HintWindowClass: THintWindowClass read FHintWindowClass write FHintWindowClass;\r\n published\r\n property AboutJVCL: TJVCLAboutInfo read FAboutJVCL write FAboutJVCL stored False;\r\n private\r\n FDotNetHighlighting: Boolean;\r\n protected\r\n procedure BoundsChanged; reintroduce; virtual;\r\n procedure CursorChanged; reintroduce; dynamic;\r\n procedure ShowingChanged; reintroduce; dynamic;\r\n procedure ShowHintChanged; reintroduce; dynamic;\r\n procedure ControlsListChanging(Control: TControl; Inserting: Boolean); reintroduce; dynamic;\r\n procedure ControlsListChanged(Control: TControl; Inserting: Boolean); reintroduce; dynamic;\r\n procedure GetDlgCode(var Code: TDlgCodes); virtual;\r\n procedure FocusSet(PrevWnd: THandle); virtual;\r\n procedure FocusKilled(NextWnd: THandle); virtual;\r\n function DoEraseBackground(Canvas: TCanvas; Param: LPARAM): Boolean; virtual;\r\n {$IFDEF JVCLThemesEnabledD6}\r\n private\r\n function GetParentBackground: Boolean;\r\n protected\r\n procedure SetParentBackground(Value: Boolean); virtual;\r\n property ParentBackground: Boolean read GetParentBackground write SetParentBackground;\r\n {$ENDIF JVCLThemesEnabledD6}\r\n published\r\n property DotNetHighlighting: Boolean read FDotNetHighlighting write FDotNetHighlighting default False;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvExCheckLst.pas $';\r\n Revision: '$Revision: 13173 $';\r\n Date: '$Date: 2011-11-19 13:43:58 +0100 (sam. 19 nov. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nconstructor TJvExCheckListBox.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FHintColor := clDefault;\r\nend;\r\n\r\nfunction TJvExCheckListBox.BaseWndProc(Msg: Cardinal; WParam: WPARAM = 0; LParam: LPARAM = 0): LRESULT;\r\nvar\r\n Mesg: TMessage;\r\nbegin\r\n CreateWMMessage(Mesg, Msg, WParam, LParam);\r\n inherited WndProc(Mesg);\r\n Result := Mesg.Result;\r\nend;\r\n\r\nfunction TJvExCheckListBox.BaseWndProc(Msg: Cardinal; WParam: WPARAM; LParam: TObject): LRESULT;\r\nbegin\r\n Result := BaseWndProc(Msg, WParam, Windows.LPARAM(LParam));\r\nend;\r\n\r\nfunction TJvExCheckListBox.BaseWndProcEx(Msg: Cardinal; WParam: WPARAM; var StructLParam): LRESULT;\r\nbegin\r\n Result := BaseWndProc(Msg, WParam, Windows.LPARAM(@StructLParam));\r\nend;\r\n\r\nprocedure TJvExCheckListBox.VisibleChanged;\r\nbegin\r\n BaseWndProc(CM_VISIBLECHANGED);\r\nend;\r\n\r\nprocedure TJvExCheckListBox.EnabledChanged;\r\nbegin\r\n BaseWndProc(CM_ENABLEDCHANGED);\r\nend;\r\n\r\nprocedure TJvExCheckListBox.TextChanged;\r\nbegin\r\n BaseWndProc(CM_TEXTCHANGED);\r\nend;\r\n\r\nprocedure TJvExCheckListBox.FontChanged;\r\nbegin\r\n BaseWndProc(CM_FONTCHANGED);\r\nend;\r\n\r\nprocedure TJvExCheckListBox.ColorChanged;\r\nbegin\r\n BaseWndProc(CM_COLORCHANGED);\r\nend;\r\n\r\nprocedure TJvExCheckListBox.ParentFontChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTFONTCHANGED);\r\nend;\r\n\r\nprocedure TJvExCheckListBox.ParentColorChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTCOLORCHANGED);\r\n if Assigned(OnParentColorChange) then\r\n OnParentColorChange(Self);\r\nend;\r\n\r\nprocedure TJvExCheckListBox.ParentShowHintChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTSHOWHINTCHANGED);\r\nend;\r\n\r\nfunction TJvExCheckListBox.WantKey(Key: Integer; Shift: TShiftState): Boolean;\r\nbegin\r\n Result := BaseWndProc(CM_DIALOGCHAR, Word(Key), ShiftStateToKeyData(Shift)) <> 0;\r\nend;\r\n\r\nfunction TJvExCheckListBox.HitTest(X, Y: Integer): Boolean;\r\nbegin\r\n Result := BaseWndProc(CM_HITTEST, 0, SmallPointToLong(PointToSmallPoint(Point(X, Y)))) <> 0;\r\nend;\r\n\r\nfunction TJvExCheckListBox.HintShow(var HintInfo: THintInfo): Boolean;\r\nbegin\r\n GetHintColor(HintInfo, Self, FHintColor);\r\n if FHintWindowClass <> nil then\r\n HintInfo.HintWindowClass := FHintWindowClass;\r\n Result := BaseWndProcEx(CM_HINTSHOW, 0, HintInfo) <> 0;\r\nend;\r\n\r\nprocedure TJvExCheckListBox.MouseEnter(AControl: TControl);\r\nbegin\r\n FMouseOver := True;\r\n if Assigned(FOnMouseEnter) then\r\n FOnMouseEnter(Self);\r\n BaseWndProc(CM_MOUSEENTER, 0, AControl);\r\nend;\r\n\r\nprocedure TJvExCheckListBox.MouseLeave(AControl: TControl);\r\nbegin\r\n FMouseOver := False;\r\n BaseWndProc(CM_MOUSELEAVE, 0, AControl);\r\n if Assigned(FOnMouseLeave) then\r\n FOnMouseLeave(Self);\r\nend;\r\n\r\nprocedure TJvExCheckListBox.FocusChanged(AControl: TWinControl);\r\nbegin\r\n BaseWndProc(CM_FOCUSCHANGED, 0, AControl);\r\nend;\r\n\r\nprocedure TJvExCheckListBox.BoundsChanged;\r\nbegin\r\nend;\r\n\r\nprocedure TJvExCheckListBox.CursorChanged;\r\nbegin\r\n BaseWndProc(CM_CURSORCHANGED);\r\nend;\r\n\r\nprocedure TJvExCheckListBox.ShowingChanged;\r\nbegin\r\n BaseWndProc(CM_SHOWINGCHANGED);\r\nend;\r\n\r\nprocedure TJvExCheckListBox.ShowHintChanged;\r\nbegin\r\n BaseWndProc(CM_SHOWHINTCHANGED);\r\nend;\r\n\r\n{ VCL sends CM_CONTROLLISTCHANGE and CM_CONTROLCHANGE in a different order than\r\n the CLX methods are used. So we must correct it by evaluating \"Inserting\". }\r\nprocedure TJvExCheckListBox.ControlsListChanging(Control: TControl; Inserting: Boolean);\r\nbegin\r\n if Inserting then\r\n BaseWndProc(CM_CONTROLLISTCHANGE, WPARAM(Control), LPARAM(Inserting))\r\n else\r\n BaseWndProc(CM_CONTROLCHANGE, WPARAM(Control), LPARAM(Inserting));\r\nend;\r\n\r\nprocedure TJvExCheckListBox.ControlsListChanged(Control: TControl; Inserting: Boolean);\r\nbegin\r\n if not Inserting then\r\n BaseWndProc(CM_CONTROLLISTCHANGE, WPARAM(Control), LPARAM(Inserting))\r\n else\r\n BaseWndProc(CM_CONTROLCHANGE, WPARAM(Control), LPARAM(Inserting));\r\nend;\r\n\r\nprocedure TJvExCheckListBox.GetDlgCode(var Code: TDlgCodes);\r\nbegin\r\nend;\r\n\r\nprocedure TJvExCheckListBox.FocusSet(PrevWnd: THandle);\r\nbegin\r\n BaseWndProc(WM_SETFOCUS, WPARAM(PrevWnd), 0);\r\nend;\r\n\r\nprocedure TJvExCheckListBox.FocusKilled(NextWnd: THandle);\r\nbegin\r\n BaseWndProc(WM_KILLFOCUS, WPARAM(NextWnd), 0);\r\nend;\r\n\r\nfunction TJvExCheckListBox.DoEraseBackground(Canvas: TCanvas; Param: LPARAM): Boolean;\r\nbegin\r\n Result := BaseWndProc(WM_ERASEBKGND, Canvas.Handle, Param) <> 0;\r\nend;\r\n\r\n{$IFDEF JVCLThemesEnabledD6}\r\nfunction TJvExCheckListBox.GetParentBackground: Boolean;\r\nbegin\r\n Result := JvThemes.GetParentBackground(Self);\r\nend;\r\n\r\nprocedure TJvExCheckListBox.SetParentBackground(Value: Boolean);\r\nbegin\r\n JvThemes.SetParentBackground(Self, Value);\r\nend;\r\n{$ENDIF JVCLThemesEnabledD6}\r\n\r\nprocedure TJvExCheckListBox.WndProc(var Msg: TMessage);\r\nvar\r\n IdSaveDC: Integer;\r\n DlgCodes: TDlgCodes;\r\n Canvas: TCanvas;\r\nbegin\r\n if not DispatchIsDesignMsg(Self, Msg) then\r\n begin\r\n case Msg.Msg of\r\n CM_DENYSUBCLASSING:\r\n Msg.Result := LRESULT(Ord(GetInterfaceEntry(IJvDenySubClassing) <> nil));\r\n CM_DIALOGCHAR:\r\n with TCMDialogChar{$IFDEF CLR}.Create{$ENDIF}(Msg) do\r\n Result := LRESULT(Ord(WantKey(CharCode, KeyDataToShiftState(KeyData))));\r\n CM_HINTSHOW:\r\n with TCMHintShow(Msg) do\r\n Result := LRESULT(HintShow(HintInfo^));\r\n CM_HITTEST:\r\n with TCMHitTest(Msg) do\r\n Result := LRESULT(HitTest(XPos, YPos));\r\n CM_MOUSEENTER:\r\n MouseEnter(TControl(Msg.LParam));\r\n CM_MOUSELEAVE:\r\n MouseLeave(TControl(Msg.LParam));\r\n CM_VISIBLECHANGED:\r\n VisibleChanged;\r\n CM_ENABLEDCHANGED:\r\n EnabledChanged;\r\n CM_TEXTCHANGED:\r\n TextChanged;\r\n CM_FONTCHANGED:\r\n FontChanged;\r\n CM_COLORCHANGED:\r\n ColorChanged;\r\n CM_FOCUSCHANGED:\r\n FocusChanged(TWinControl(Msg.LParam));\r\n CM_PARENTFONTCHANGED:\r\n ParentFontChanged;\r\n CM_PARENTCOLORCHANGED:\r\n ParentColorChanged;\r\n CM_PARENTSHOWHINTCHANGED:\r\n ParentShowHintChanged;\r\n CM_CURSORCHANGED:\r\n CursorChanged;\r\n CM_SHOWINGCHANGED:\r\n ShowingChanged;\r\n CM_SHOWHINTCHANGED:\r\n ShowHintChanged;\r\n CM_CONTROLLISTCHANGE:\r\n if Msg.LParam <> 0 then\r\n ControlsListChanging(TControl(Msg.WParam), True)\r\n else\r\n ControlsListChanged(TControl(Msg.WParam), False);\r\n CM_CONTROLCHANGE:\r\n if Msg.LParam = 0 then\r\n ControlsListChanging(TControl(Msg.WParam), False)\r\n else\r\n ControlsListChanged(TControl(Msg.WParam), True);\r\n WM_SETFOCUS:\r\n FocusSet(THandle(Msg.WParam));\r\n WM_KILLFOCUS:\r\n FocusKilled(THandle(Msg.WParam));\r\n WM_SIZE, WM_MOVE:\r\n begin\r\n inherited WndProc(Msg);\r\n BoundsChanged;\r\n end;\r\n WM_ERASEBKGND:\r\n if (Msg.WParam <> 0) and not IsDefaultEraseBackground(DoEraseBackground, @TJvExCheckListBox.DoEraseBackground) then\r\n begin\r\n IdSaveDC := SaveDC(HDC(Msg.WParam)); // protect DC against Stock-Objects from Canvas\r\n Canvas := TCanvas.Create;\r\n try\r\n Canvas.Handle := HDC(Msg.WParam);\r\n Msg.Result := Ord(DoEraseBackground(Canvas, Msg.LParam));\r\n finally\r\n Canvas.Handle := 0;\r\n Canvas.Free;\r\n RestoreDC(HDC(Msg.WParam), IdSaveDC);\r\n end;\r\n end\r\n else\r\n inherited WndProc(Msg);\r\n {$IFNDEF DELPHI2007_UP}\r\n WM_PRINTCLIENT, WM_PRINT: // VCL bug fix\r\n begin\r\n IdSaveDC := SaveDC(HDC(Msg.WParam)); // protect DC against changes\r\n try\r\n inherited WndProc(Msg);\r\n finally\r\n RestoreDC(HDC(Msg.WParam), IdSaveDC);\r\n end;\r\n end;\r\n {$ENDIF ~DELPHI2007_UP}\r\n WM_GETDLGCODE:\r\n begin\r\n inherited WndProc(Msg);\r\n DlgCodes := [dcNative] + DlgcToDlgCodes(Msg.Result);\r\n GetDlgCode(DlgCodes);\r\n if not (dcNative in DlgCodes) then\r\n Msg.Result := DlgCodesToDlgc(DlgCodes);\r\n end;\r\n else\r\n inherited WndProc(Msg);\r\n end;\r\n case Msg.Msg of // precheck message to prevent access violations on released controls\r\n CM_MOUSEENTER, CM_MOUSELEAVE, WM_KILLFOCUS, WM_SETFOCUS, WM_NCPAINT:\r\n if DotNetHighlighting then\r\n HandleDotNetHighlighting(Self, Msg, MouseOver, Color);\r\n end;\r\n end;\r\nend;\r\n\r\n//============================================================================\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend." }, { "path": "External/Jedi/Jvcl/run/JvExComCtrls.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvExComCtrls.pas, released on 2004-01-04\r\n\r\nThe Initial Developer of the Original Code is Andreas Hausladen [Andreas dott Hausladen att gmx dott de]\r\nPortions created by Andreas Hausladen are Copyright (C) 2004 Andreas Hausladen.\r\nAll Rights Reserved.\r\n\r\nContributor(s): -\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvExComCtrls.pas 13173 2011-11-19 12:43:58Z ahuser $\r\n\r\nunit JvExComCtrls;\r\n\r\n{$I jvcl.inc}\r\n{MACROINCLUDE JvExControls.macros}\r\n\r\n{*****************************************************************************\r\n * WARNING: Do not edit this file.\r\n * This file is autogenerated from the source in devtools/JvExVCL/src.\r\n * If you do it despite this warning your changes will be discarded by the next\r\n * update of this file. Do your changes in the template files.\r\n ****************************************************************************}\r\n{$D-} // do not step into this unit\r\n\r\ninterface\r\n\r\nuses\r\n Windows, Messages, Types,\r\n SysUtils, Classes, Graphics, Controls, Forms, ComCtrls,\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n JvTypes, JvThemes, JVCLVer, JvExControls;\r\n\r\ntype\r\n TJvExCustomHeaderControl = class(TCustomHeaderControl, IJvExControl)\r\n private\r\n FAboutJVCL: TJVCLAboutInfo;\r\n FHintColor: TColor;\r\n FMouseOver: Boolean;\r\n FHintWindowClass: THintWindowClass;\r\n FOnMouseEnter: TNotifyEvent;\r\n FOnMouseLeave: TNotifyEvent;\r\n FOnParentColorChanged: TNotifyEvent;\r\n function BaseWndProc(Msg: Cardinal; WParam: WPARAM = 0; LParam: LPARAM = 0): LRESULT; overload;\r\n function BaseWndProc(Msg: Cardinal; WParam: WPARAM; LParam: TObject): LRESULT; overload;\r\n function BaseWndProcEx(Msg: Cardinal; WParam: WPARAM; var StructLParam): LRESULT;\r\n protected\r\n procedure WndProc(var Msg: TMessage); override;\r\n procedure FocusChanged(AControl: TWinControl); dynamic;\r\n procedure VisibleChanged; reintroduce; dynamic;\r\n procedure EnabledChanged; reintroduce; dynamic;\r\n procedure TextChanged; reintroduce; virtual;\r\n procedure ColorChanged; reintroduce; dynamic;\r\n procedure FontChanged; reintroduce; dynamic;\r\n procedure ParentFontChanged; reintroduce; dynamic;\r\n procedure ParentColorChanged; reintroduce; dynamic;\r\n procedure ParentShowHintChanged; reintroduce; dynamic;\r\n function WantKey(Key: Integer; Shift: TShiftState): Boolean; virtual;\r\n function HintShow(var HintInfo: THintInfo): Boolean; reintroduce; dynamic;\r\n function HitTest(X, Y: Integer): Boolean; reintroduce; virtual;\r\n procedure MouseEnter(AControl: TControl); reintroduce; dynamic;\r\n procedure MouseLeave(AControl: TControl); reintroduce; dynamic;\r\n property MouseOver: Boolean read FMouseOver write FMouseOver;\r\n property HintColor: TColor read FHintColor write FHintColor default clDefault;\r\n property OnMouseEnter: TNotifyEvent read FOnMouseEnter write FOnMouseEnter;\r\n property OnMouseLeave: TNotifyEvent read FOnMouseLeave write FOnMouseLeave;\r\n property OnParentColorChange: TNotifyEvent read FOnParentColorChanged write FOnParentColorChanged;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n property HintWindowClass: THintWindowClass read FHintWindowClass write FHintWindowClass;\r\n published\r\n property AboutJVCL: TJVCLAboutInfo read FAboutJVCL write FAboutJVCL stored False;\r\n private\r\n FDotNetHighlighting: Boolean;\r\n protected\r\n procedure BoundsChanged; reintroduce; virtual;\r\n procedure CursorChanged; reintroduce; dynamic;\r\n procedure ShowingChanged; reintroduce; dynamic;\r\n procedure ShowHintChanged; reintroduce; dynamic;\r\n procedure ControlsListChanging(Control: TControl; Inserting: Boolean); reintroduce; dynamic;\r\n procedure ControlsListChanged(Control: TControl; Inserting: Boolean); reintroduce; dynamic;\r\n procedure GetDlgCode(var Code: TDlgCodes); virtual;\r\n procedure FocusSet(PrevWnd: THandle); virtual;\r\n procedure FocusKilled(NextWnd: THandle); virtual;\r\n function DoEraseBackground(Canvas: TCanvas; Param: LPARAM): Boolean; virtual;\r\n {$IFDEF JVCLThemesEnabledD6}\r\n private\r\n function GetParentBackground: Boolean;\r\n protected\r\n procedure SetParentBackground(Value: Boolean); virtual;\r\n property ParentBackground: Boolean read GetParentBackground write SetParentBackground;\r\n {$ENDIF JVCLThemesEnabledD6}\r\n published\r\n property DotNetHighlighting: Boolean read FDotNetHighlighting write FDotNetHighlighting default False;\r\n end;\r\n\r\n TJvExHeaderControl = class(THeaderControl, IJvExControl)\r\n private\r\n FAboutJVCL: TJVCLAboutInfo;\r\n FHintColor: TColor;\r\n FMouseOver: Boolean;\r\n FHintWindowClass: THintWindowClass;\r\n FOnMouseEnter: TNotifyEvent;\r\n FOnMouseLeave: TNotifyEvent;\r\n FOnParentColorChanged: TNotifyEvent;\r\n function BaseWndProc(Msg: Cardinal; WParam: WPARAM = 0; LParam: LPARAM = 0): LRESULT; overload;\r\n function BaseWndProc(Msg: Cardinal; WParam: WPARAM; LParam: TObject): LRESULT; overload;\r\n function BaseWndProcEx(Msg: Cardinal; WParam: WPARAM; var StructLParam): LRESULT;\r\n protected\r\n procedure WndProc(var Msg: TMessage); override;\r\n procedure FocusChanged(AControl: TWinControl); dynamic;\r\n procedure VisibleChanged; reintroduce; dynamic;\r\n procedure EnabledChanged; reintroduce; dynamic;\r\n procedure TextChanged; reintroduce; virtual;\r\n procedure ColorChanged; reintroduce; dynamic;\r\n procedure FontChanged; reintroduce; dynamic;\r\n procedure ParentFontChanged; reintroduce; dynamic;\r\n procedure ParentColorChanged; reintroduce; dynamic;\r\n procedure ParentShowHintChanged; reintroduce; dynamic;\r\n function WantKey(Key: Integer; Shift: TShiftState): Boolean; virtual;\r\n function HintShow(var HintInfo: THintInfo): Boolean; reintroduce; dynamic;\r\n function HitTest(X, Y: Integer): Boolean; reintroduce; virtual;\r\n procedure MouseEnter(AControl: TControl); reintroduce; dynamic;\r\n procedure MouseLeave(AControl: TControl); reintroduce; dynamic;\r\n property MouseOver: Boolean read FMouseOver write FMouseOver;\r\n property HintColor: TColor read FHintColor write FHintColor default clDefault;\r\n property OnMouseEnter: TNotifyEvent read FOnMouseEnter write FOnMouseEnter;\r\n property OnMouseLeave: TNotifyEvent read FOnMouseLeave write FOnMouseLeave;\r\n property OnParentColorChange: TNotifyEvent read FOnParentColorChanged write FOnParentColorChanged;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n property HintWindowClass: THintWindowClass read FHintWindowClass write FHintWindowClass;\r\n published\r\n property AboutJVCL: TJVCLAboutInfo read FAboutJVCL write FAboutJVCL stored False;\r\n private\r\n FDotNetHighlighting: Boolean;\r\n protected\r\n procedure BoundsChanged; reintroduce; virtual;\r\n procedure CursorChanged; reintroduce; dynamic;\r\n procedure ShowingChanged; reintroduce; dynamic;\r\n procedure ShowHintChanged; reintroduce; dynamic;\r\n procedure ControlsListChanging(Control: TControl; Inserting: Boolean); reintroduce; dynamic;\r\n procedure ControlsListChanged(Control: TControl; Inserting: Boolean); reintroduce; dynamic;\r\n procedure GetDlgCode(var Code: TDlgCodes); virtual;\r\n procedure FocusSet(PrevWnd: THandle); virtual;\r\n procedure FocusKilled(NextWnd: THandle); virtual;\r\n function DoEraseBackground(Canvas: TCanvas; Param: LPARAM): Boolean; virtual;\r\n {$IFDEF JVCLThemesEnabledD6}\r\n private\r\n function GetParentBackground: Boolean;\r\n protected\r\n procedure SetParentBackground(Value: Boolean); virtual;\r\n property ParentBackground: Boolean read GetParentBackground write SetParentBackground;\r\n {$ENDIF JVCLThemesEnabledD6}\r\n published\r\n property DotNetHighlighting: Boolean read FDotNetHighlighting write FDotNetHighlighting default False;\r\n end;\r\n\r\n TJvExCustomTreeView = class(TCustomTreeView, IJvExControl)\r\n private\r\n FAboutJVCL: TJVCLAboutInfo;\r\n FHintColor: TColor;\r\n FMouseOver: Boolean;\r\n FHintWindowClass: THintWindowClass;\r\n FOnMouseEnter: TNotifyEvent;\r\n FOnMouseLeave: TNotifyEvent;\r\n FOnParentColorChanged: TNotifyEvent;\r\n function BaseWndProc(Msg: Cardinal; WParam: WPARAM = 0; LParam: LPARAM = 0): LRESULT; overload;\r\n function BaseWndProc(Msg: Cardinal; WParam: WPARAM; LParam: TObject): LRESULT; overload;\r\n function BaseWndProcEx(Msg: Cardinal; WParam: WPARAM; var StructLParam): LRESULT;\r\n protected\r\n procedure WndProc(var Msg: TMessage); override;\r\n procedure FocusChanged(AControl: TWinControl); dynamic;\r\n procedure VisibleChanged; reintroduce; dynamic;\r\n procedure EnabledChanged; reintroduce; dynamic;\r\n procedure TextChanged; reintroduce; virtual;\r\n procedure ColorChanged; reintroduce; dynamic;\r\n procedure FontChanged; reintroduce; dynamic;\r\n procedure ParentFontChanged; reintroduce; dynamic;\r\n procedure ParentColorChanged; reintroduce; dynamic;\r\n procedure ParentShowHintChanged; reintroduce; dynamic;\r\n function WantKey(Key: Integer; Shift: TShiftState): Boolean; virtual;\r\n function HintShow(var HintInfo: THintInfo): Boolean; reintroduce; dynamic;\r\n function HitTest(X, Y: Integer): Boolean; reintroduce; virtual;\r\n procedure MouseEnter(AControl: TControl); reintroduce; dynamic;\r\n procedure MouseLeave(AControl: TControl); reintroduce; dynamic;\r\n property MouseOver: Boolean read FMouseOver write FMouseOver;\r\n property HintColor: TColor read FHintColor write FHintColor default clDefault;\r\n property OnMouseEnter: TNotifyEvent read FOnMouseEnter write FOnMouseEnter;\r\n property OnMouseLeave: TNotifyEvent read FOnMouseLeave write FOnMouseLeave;\r\n property OnParentColorChange: TNotifyEvent read FOnParentColorChanged write FOnParentColorChanged;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n property HintWindowClass: THintWindowClass read FHintWindowClass write FHintWindowClass;\r\n published\r\n property AboutJVCL: TJVCLAboutInfo read FAboutJVCL write FAboutJVCL stored False;\r\n private\r\n FDotNetHighlighting: Boolean;\r\n protected\r\n procedure BoundsChanged; reintroduce; virtual;\r\n procedure CursorChanged; reintroduce; dynamic;\r\n procedure ShowingChanged; reintroduce; dynamic;\r\n procedure ShowHintChanged; reintroduce; dynamic;\r\n procedure ControlsListChanging(Control: TControl; Inserting: Boolean); reintroduce; dynamic;\r\n procedure ControlsListChanged(Control: TControl; Inserting: Boolean); reintroduce; dynamic;\r\n procedure GetDlgCode(var Code: TDlgCodes); virtual;\r\n procedure FocusSet(PrevWnd: THandle); virtual;\r\n procedure FocusKilled(NextWnd: THandle); virtual;\r\n function DoEraseBackground(Canvas: TCanvas; Param: LPARAM): Boolean; virtual;\r\n {$IFDEF JVCLThemesEnabledD6}\r\n private\r\n function GetParentBackground: Boolean;\r\n protected\r\n procedure SetParentBackground(Value: Boolean); virtual;\r\n property ParentBackground: Boolean read GetParentBackground write SetParentBackground;\r\n {$ENDIF JVCLThemesEnabledD6}\r\n published\r\n property DotNetHighlighting: Boolean read FDotNetHighlighting write FDotNetHighlighting default False;\r\n end;\r\n\r\n TJvExTreeView = class(TTreeView, IJvExControl)\r\n private\r\n FAboutJVCL: TJVCLAboutInfo;\r\n FHintColor: TColor;\r\n FMouseOver: Boolean;\r\n FHintWindowClass: THintWindowClass;\r\n FOnMouseEnter: TNotifyEvent;\r\n FOnMouseLeave: TNotifyEvent;\r\n FOnParentColorChanged: TNotifyEvent;\r\n function BaseWndProc(Msg: Cardinal; WParam: WPARAM = 0; LParam: LPARAM = 0): LRESULT; overload;\r\n function BaseWndProc(Msg: Cardinal; WParam: WPARAM; LParam: TObject): LRESULT; overload;\r\n function BaseWndProcEx(Msg: Cardinal; WParam: WPARAM; var StructLParam): LRESULT;\r\n protected\r\n procedure WndProc(var Msg: TMessage); override;\r\n procedure FocusChanged(AControl: TWinControl); dynamic;\r\n procedure VisibleChanged; reintroduce; dynamic;\r\n procedure EnabledChanged; reintroduce; dynamic;\r\n procedure TextChanged; reintroduce; virtual;\r\n procedure ColorChanged; reintroduce; dynamic;\r\n procedure FontChanged; reintroduce; dynamic;\r\n procedure ParentFontChanged; reintroduce; dynamic;\r\n procedure ParentColorChanged; reintroduce; dynamic;\r\n procedure ParentShowHintChanged; reintroduce; dynamic;\r\n function WantKey(Key: Integer; Shift: TShiftState): Boolean; virtual;\r\n function HintShow(var HintInfo: THintInfo): Boolean; reintroduce; dynamic;\r\n function HitTest(X, Y: Integer): Boolean; reintroduce; virtual;\r\n procedure MouseEnter(AControl: TControl); reintroduce; dynamic;\r\n procedure MouseLeave(AControl: TControl); reintroduce; dynamic;\r\n property MouseOver: Boolean read FMouseOver write FMouseOver;\r\n property HintColor: TColor read FHintColor write FHintColor default clDefault;\r\n property OnMouseEnter: TNotifyEvent read FOnMouseEnter write FOnMouseEnter;\r\n property OnMouseLeave: TNotifyEvent read FOnMouseLeave write FOnMouseLeave;\r\n property OnParentColorChange: TNotifyEvent read FOnParentColorChanged write FOnParentColorChanged;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n property HintWindowClass: THintWindowClass read FHintWindowClass write FHintWindowClass;\r\n published\r\n property AboutJVCL: TJVCLAboutInfo read FAboutJVCL write FAboutJVCL stored False;\r\n private\r\n FDotNetHighlighting: Boolean;\r\n protected\r\n procedure BoundsChanged; reintroduce; virtual;\r\n procedure CursorChanged; reintroduce; dynamic;\r\n procedure ShowingChanged; reintroduce; dynamic;\r\n procedure ShowHintChanged; reintroduce; dynamic;\r\n procedure ControlsListChanging(Control: TControl; Inserting: Boolean); reintroduce; dynamic;\r\n procedure ControlsListChanged(Control: TControl; Inserting: Boolean); reintroduce; dynamic;\r\n procedure GetDlgCode(var Code: TDlgCodes); virtual;\r\n procedure FocusSet(PrevWnd: THandle); virtual;\r\n procedure FocusKilled(NextWnd: THandle); virtual;\r\n function DoEraseBackground(Canvas: TCanvas; Param: LPARAM): Boolean; virtual;\r\n {$IFDEF JVCLThemesEnabledD6}\r\n private\r\n function GetParentBackground: Boolean;\r\n protected\r\n procedure SetParentBackground(Value: Boolean); virtual;\r\n property ParentBackground: Boolean read GetParentBackground write SetParentBackground;\r\n {$ENDIF JVCLThemesEnabledD6}\r\n published\r\n property DotNetHighlighting: Boolean read FDotNetHighlighting write FDotNetHighlighting default False;\r\n end;\r\n\r\n TJvExCustomListView = class(TCustomListView, IJvExControl)\r\n private\r\n FAboutJVCL: TJVCLAboutInfo;\r\n FHintColor: TColor;\r\n FMouseOver: Boolean;\r\n FHintWindowClass: THintWindowClass;\r\n FOnMouseEnter: TNotifyEvent;\r\n FOnMouseLeave: TNotifyEvent;\r\n FOnParentColorChanged: TNotifyEvent;\r\n function BaseWndProc(Msg: Cardinal; WParam: WPARAM = 0; LParam: LPARAM = 0): LRESULT; overload;\r\n function BaseWndProc(Msg: Cardinal; WParam: WPARAM; LParam: TObject): LRESULT; overload;\r\n function BaseWndProcEx(Msg: Cardinal; WParam: WPARAM; var StructLParam): LRESULT;\r\n protected\r\n procedure WndProc(var Msg: TMessage); override;\r\n procedure FocusChanged(AControl: TWinControl); dynamic;\r\n procedure VisibleChanged; reintroduce; dynamic;\r\n procedure EnabledChanged; reintroduce; dynamic;\r\n procedure TextChanged; reintroduce; virtual;\r\n procedure ColorChanged; reintroduce; dynamic;\r\n procedure FontChanged; reintroduce; dynamic;\r\n procedure ParentFontChanged; reintroduce; dynamic;\r\n procedure ParentColorChanged; reintroduce; dynamic;\r\n procedure ParentShowHintChanged; reintroduce; dynamic;\r\n function WantKey(Key: Integer; Shift: TShiftState): Boolean; virtual;\r\n function HintShow(var HintInfo: THintInfo): Boolean; reintroduce; dynamic;\r\n function HitTest(X, Y: Integer): Boolean; reintroduce; virtual;\r\n procedure MouseEnter(AControl: TControl); reintroduce; dynamic;\r\n procedure MouseLeave(AControl: TControl); reintroduce; dynamic;\r\n property MouseOver: Boolean read FMouseOver write FMouseOver;\r\n property HintColor: TColor read FHintColor write FHintColor default clDefault;\r\n property OnMouseEnter: TNotifyEvent read FOnMouseEnter write FOnMouseEnter;\r\n property OnMouseLeave: TNotifyEvent read FOnMouseLeave write FOnMouseLeave;\r\n property OnParentColorChange: TNotifyEvent read FOnParentColorChanged write FOnParentColorChanged;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n property HintWindowClass: THintWindowClass read FHintWindowClass write FHintWindowClass;\r\n published\r\n property AboutJVCL: TJVCLAboutInfo read FAboutJVCL write FAboutJVCL stored False;\r\n private\r\n FDotNetHighlighting: Boolean;\r\n protected\r\n procedure BoundsChanged; reintroduce; virtual;\r\n procedure CursorChanged; reintroduce; dynamic;\r\n procedure ShowingChanged; reintroduce; dynamic;\r\n procedure ShowHintChanged; reintroduce; dynamic;\r\n procedure ControlsListChanging(Control: TControl; Inserting: Boolean); reintroduce; dynamic;\r\n procedure ControlsListChanged(Control: TControl; Inserting: Boolean); reintroduce; dynamic;\r\n procedure GetDlgCode(var Code: TDlgCodes); virtual;\r\n procedure FocusSet(PrevWnd: THandle); virtual;\r\n procedure FocusKilled(NextWnd: THandle); virtual;\r\n function DoEraseBackground(Canvas: TCanvas; Param: LPARAM): Boolean; virtual;\r\n {$IFDEF JVCLThemesEnabledD6}\r\n private\r\n function GetParentBackground: Boolean;\r\n protected\r\n procedure SetParentBackground(Value: Boolean); virtual;\r\n property ParentBackground: Boolean read GetParentBackground write SetParentBackground;\r\n {$ENDIF JVCLThemesEnabledD6}\r\n published\r\n property DotNetHighlighting: Boolean read FDotNetHighlighting write FDotNetHighlighting default False;\r\n end;\r\n\r\n TJvExListView = class(TListView, IJvExControl)\r\n private\r\n FAboutJVCL: TJVCLAboutInfo;\r\n FHintColor: TColor;\r\n FMouseOver: Boolean;\r\n FHintWindowClass: THintWindowClass;\r\n FOnMouseEnter: TNotifyEvent;\r\n FOnMouseLeave: TNotifyEvent;\r\n FOnParentColorChanged: TNotifyEvent;\r\n function BaseWndProc(Msg: Cardinal; WParam: WPARAM = 0; LParam: LPARAM = 0): LRESULT; overload;\r\n function BaseWndProc(Msg: Cardinal; WParam: WPARAM; LParam: TObject): LRESULT; overload;\r\n function BaseWndProcEx(Msg: Cardinal; WParam: WPARAM; var StructLParam): LRESULT;\r\n protected\r\n procedure WndProc(var Msg: TMessage); override;\r\n procedure FocusChanged(AControl: TWinControl); dynamic;\r\n procedure VisibleChanged; reintroduce; dynamic;\r\n procedure EnabledChanged; reintroduce; dynamic;\r\n procedure TextChanged; reintroduce; virtual;\r\n procedure ColorChanged; reintroduce; dynamic;\r\n procedure FontChanged; reintroduce; dynamic;\r\n procedure ParentFontChanged; reintroduce; dynamic;\r\n procedure ParentColorChanged; reintroduce; dynamic;\r\n procedure ParentShowHintChanged; reintroduce; dynamic;\r\n function WantKey(Key: Integer; Shift: TShiftState): Boolean; virtual;\r\n function HintShow(var HintInfo: THintInfo): Boolean; reintroduce; dynamic;\r\n function HitTest(X, Y: Integer): Boolean; reintroduce; virtual;\r\n procedure MouseEnter(AControl: TControl); reintroduce; dynamic;\r\n procedure MouseLeave(AControl: TControl); reintroduce; dynamic;\r\n property MouseOver: Boolean read FMouseOver write FMouseOver;\r\n property HintColor: TColor read FHintColor write FHintColor default clDefault;\r\n property OnMouseEnter: TNotifyEvent read FOnMouseEnter write FOnMouseEnter;\r\n property OnMouseLeave: TNotifyEvent read FOnMouseLeave write FOnMouseLeave;\r\n property OnParentColorChange: TNotifyEvent read FOnParentColorChanged write FOnParentColorChanged;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n property HintWindowClass: THintWindowClass read FHintWindowClass write FHintWindowClass;\r\n published\r\n property AboutJVCL: TJVCLAboutInfo read FAboutJVCL write FAboutJVCL stored False;\r\n private\r\n FDotNetHighlighting: Boolean;\r\n protected\r\n procedure BoundsChanged; reintroduce; virtual;\r\n procedure CursorChanged; reintroduce; dynamic;\r\n procedure ShowingChanged; reintroduce; dynamic;\r\n procedure ShowHintChanged; reintroduce; dynamic;\r\n procedure ControlsListChanging(Control: TControl; Inserting: Boolean); reintroduce; dynamic;\r\n procedure ControlsListChanged(Control: TControl; Inserting: Boolean); reintroduce; dynamic;\r\n procedure GetDlgCode(var Code: TDlgCodes); virtual;\r\n procedure FocusSet(PrevWnd: THandle); virtual;\r\n procedure FocusKilled(NextWnd: THandle); virtual;\r\n function DoEraseBackground(Canvas: TCanvas; Param: LPARAM): Boolean; virtual;\r\n {$IFDEF JVCLThemesEnabledD6}\r\n private\r\n function GetParentBackground: Boolean;\r\n protected\r\n procedure SetParentBackground(Value: Boolean); virtual;\r\n property ParentBackground: Boolean read GetParentBackground write SetParentBackground;\r\n {$ENDIF JVCLThemesEnabledD6}\r\n published\r\n property DotNetHighlighting: Boolean read FDotNetHighlighting write FDotNetHighlighting default False;\r\n end;\r\n\r\n TJvExPageControl = class(TPageControl, IJvExControl)\r\n private\r\n FAboutJVCL: TJVCLAboutInfo;\r\n FHintColor: TColor;\r\n FMouseOver: Boolean;\r\n FHintWindowClass: THintWindowClass;\r\n FOnMouseEnter: TNotifyEvent;\r\n FOnMouseLeave: TNotifyEvent;\r\n FOnParentColorChanged: TNotifyEvent;\r\n function BaseWndProc(Msg: Cardinal; WParam: WPARAM = 0; LParam: LPARAM = 0): LRESULT; overload;\r\n function BaseWndProc(Msg: Cardinal; WParam: WPARAM; LParam: TObject): LRESULT; overload;\r\n function BaseWndProcEx(Msg: Cardinal; WParam: WPARAM; var StructLParam): LRESULT;\r\n protected\r\n procedure WndProc(var Msg: TMessage); override;\r\n procedure FocusChanged(AControl: TWinControl); dynamic;\r\n procedure VisibleChanged; reintroduce; dynamic;\r\n procedure EnabledChanged; reintroduce; dynamic;\r\n procedure TextChanged; reintroduce; virtual;\r\n procedure ColorChanged; reintroduce; dynamic;\r\n procedure FontChanged; reintroduce; dynamic;\r\n procedure ParentFontChanged; reintroduce; dynamic;\r\n procedure ParentColorChanged; reintroduce; dynamic;\r\n procedure ParentShowHintChanged; reintroduce; dynamic;\r\n function WantKey(Key: Integer; Shift: TShiftState): Boolean; virtual;\r\n function HintShow(var HintInfo: THintInfo): Boolean; reintroduce; dynamic;\r\n function HitTest(X, Y: Integer): Boolean; reintroduce; virtual;\r\n procedure MouseEnter(AControl: TControl); reintroduce; dynamic;\r\n procedure MouseLeave(AControl: TControl); reintroduce; dynamic;\r\n property MouseOver: Boolean read FMouseOver write FMouseOver;\r\n property HintColor: TColor read FHintColor write FHintColor default clDefault;\r\n property OnMouseEnter: TNotifyEvent read FOnMouseEnter write FOnMouseEnter;\r\n property OnMouseLeave: TNotifyEvent read FOnMouseLeave write FOnMouseLeave;\r\n property OnParentColorChange: TNotifyEvent read FOnParentColorChanged write FOnParentColorChanged;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n property HintWindowClass: THintWindowClass read FHintWindowClass write FHintWindowClass;\r\n published\r\n property AboutJVCL: TJVCLAboutInfo read FAboutJVCL write FAboutJVCL stored False;\r\n private\r\n FDotNetHighlighting: Boolean;\r\n protected\r\n procedure BoundsChanged; reintroduce; virtual;\r\n procedure CursorChanged; reintroduce; dynamic;\r\n procedure ShowingChanged; reintroduce; dynamic;\r\n procedure ShowHintChanged; reintroduce; dynamic;\r\n procedure ControlsListChanging(Control: TControl; Inserting: Boolean); reintroduce; dynamic;\r\n procedure ControlsListChanged(Control: TControl; Inserting: Boolean); reintroduce; dynamic;\r\n procedure GetDlgCode(var Code: TDlgCodes); virtual;\r\n procedure FocusSet(PrevWnd: THandle); virtual;\r\n procedure FocusKilled(NextWnd: THandle); virtual;\r\n function DoEraseBackground(Canvas: TCanvas; Param: LPARAM): Boolean; virtual;\r\n {$IFDEF JVCLThemesEnabledD6}\r\n private\r\n function GetParentBackground: Boolean;\r\n protected\r\n procedure SetParentBackground(Value: Boolean); virtual;\r\n property ParentBackground: Boolean read GetParentBackground write SetParentBackground;\r\n {$ENDIF JVCLThemesEnabledD6}\r\n published\r\n property DotNetHighlighting: Boolean read FDotNetHighlighting write FDotNetHighlighting default False;\r\n end;\r\n\r\n TJvExCustomTabControl = class(TCustomTabControl, IJvExControl)\r\n private\r\n FAboutJVCL: TJVCLAboutInfo;\r\n FHintColor: TColor;\r\n FMouseOver: Boolean;\r\n FHintWindowClass: THintWindowClass;\r\n FOnMouseEnter: TNotifyEvent;\r\n FOnMouseLeave: TNotifyEvent;\r\n FOnParentColorChanged: TNotifyEvent;\r\n function BaseWndProc(Msg: Cardinal; WParam: WPARAM = 0; LParam: LPARAM = 0): LRESULT; overload;\r\n function BaseWndProc(Msg: Cardinal; WParam: WPARAM; LParam: TObject): LRESULT; overload;\r\n function BaseWndProcEx(Msg: Cardinal; WParam: WPARAM; var StructLParam): LRESULT;\r\n protected\r\n procedure WndProc(var Msg: TMessage); override;\r\n procedure FocusChanged(AControl: TWinControl); dynamic;\r\n procedure VisibleChanged; reintroduce; dynamic;\r\n procedure EnabledChanged; reintroduce; dynamic;\r\n procedure TextChanged; reintroduce; virtual;\r\n procedure ColorChanged; reintroduce; dynamic;\r\n procedure FontChanged; reintroduce; dynamic;\r\n procedure ParentFontChanged; reintroduce; dynamic;\r\n procedure ParentColorChanged; reintroduce; dynamic;\r\n procedure ParentShowHintChanged; reintroduce; dynamic;\r\n function WantKey(Key: Integer; Shift: TShiftState): Boolean; virtual;\r\n function HintShow(var HintInfo: THintInfo): Boolean; reintroduce; dynamic;\r\n function HitTest(X, Y: Integer): Boolean; reintroduce; virtual;\r\n procedure MouseEnter(AControl: TControl); reintroduce; dynamic;\r\n procedure MouseLeave(AControl: TControl); reintroduce; dynamic;\r\n property MouseOver: Boolean read FMouseOver write FMouseOver;\r\n property HintColor: TColor read FHintColor write FHintColor default clDefault;\r\n property OnMouseEnter: TNotifyEvent read FOnMouseEnter write FOnMouseEnter;\r\n property OnMouseLeave: TNotifyEvent read FOnMouseLeave write FOnMouseLeave;\r\n property OnParentColorChange: TNotifyEvent read FOnParentColorChanged write FOnParentColorChanged;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n property HintWindowClass: THintWindowClass read FHintWindowClass write FHintWindowClass;\r\n published\r\n property AboutJVCL: TJVCLAboutInfo read FAboutJVCL write FAboutJVCL stored False;\r\n private\r\n FDotNetHighlighting: Boolean;\r\n protected\r\n procedure BoundsChanged; reintroduce; virtual;\r\n procedure CursorChanged; reintroduce; dynamic;\r\n procedure ShowingChanged; reintroduce; dynamic;\r\n procedure ShowHintChanged; reintroduce; dynamic;\r\n procedure ControlsListChanging(Control: TControl; Inserting: Boolean); reintroduce; dynamic;\r\n procedure ControlsListChanged(Control: TControl; Inserting: Boolean); reintroduce; dynamic;\r\n procedure GetDlgCode(var Code: TDlgCodes); virtual;\r\n procedure FocusSet(PrevWnd: THandle); virtual;\r\n procedure FocusKilled(NextWnd: THandle); virtual;\r\n function DoEraseBackground(Canvas: TCanvas; Param: LPARAM): Boolean; virtual;\r\n {$IFDEF JVCLThemesEnabledD6}\r\n private\r\n function GetParentBackground: Boolean;\r\n protected\r\n procedure SetParentBackground(Value: Boolean); virtual;\r\n property ParentBackground: Boolean read GetParentBackground write SetParentBackground;\r\n {$ENDIF JVCLThemesEnabledD6}\r\n published\r\n property DotNetHighlighting: Boolean read FDotNetHighlighting write FDotNetHighlighting default False;\r\n end;\r\n\r\n TJvExTabControl = class(TTabControl, IJvExControl)\r\n private\r\n FAboutJVCL: TJVCLAboutInfo;\r\n FHintColor: TColor;\r\n FMouseOver: Boolean;\r\n FHintWindowClass: THintWindowClass;\r\n FOnMouseEnter: TNotifyEvent;\r\n FOnMouseLeave: TNotifyEvent;\r\n FOnParentColorChanged: TNotifyEvent;\r\n function BaseWndProc(Msg: Cardinal; WParam: WPARAM = 0; LParam: LPARAM = 0): LRESULT; overload;\r\n function BaseWndProc(Msg: Cardinal; WParam: WPARAM; LParam: TObject): LRESULT; overload;\r\n function BaseWndProcEx(Msg: Cardinal; WParam: WPARAM; var StructLParam): LRESULT;\r\n protected\r\n procedure WndProc(var Msg: TMessage); override;\r\n procedure FocusChanged(AControl: TWinControl); dynamic;\r\n procedure VisibleChanged; reintroduce; dynamic;\r\n procedure EnabledChanged; reintroduce; dynamic;\r\n procedure TextChanged; reintroduce; virtual;\r\n procedure ColorChanged; reintroduce; dynamic;\r\n procedure FontChanged; reintroduce; dynamic;\r\n procedure ParentFontChanged; reintroduce; dynamic;\r\n procedure ParentColorChanged; reintroduce; dynamic;\r\n procedure ParentShowHintChanged; reintroduce; dynamic;\r\n function WantKey(Key: Integer; Shift: TShiftState): Boolean; virtual;\r\n function HintShow(var HintInfo: THintInfo): Boolean; reintroduce; dynamic;\r\n function HitTest(X, Y: Integer): Boolean; reintroduce; virtual;\r\n procedure MouseEnter(AControl: TControl); reintroduce; dynamic;\r\n procedure MouseLeave(AControl: TControl); reintroduce; dynamic;\r\n property MouseOver: Boolean read FMouseOver write FMouseOver;\r\n property HintColor: TColor read FHintColor write FHintColor default clDefault;\r\n property OnMouseEnter: TNotifyEvent read FOnMouseEnter write FOnMouseEnter;\r\n property OnMouseLeave: TNotifyEvent read FOnMouseLeave write FOnMouseLeave;\r\n property OnParentColorChange: TNotifyEvent read FOnParentColorChanged write FOnParentColorChanged;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n property HintWindowClass: THintWindowClass read FHintWindowClass write FHintWindowClass;\r\n published\r\n property AboutJVCL: TJVCLAboutInfo read FAboutJVCL write FAboutJVCL stored False;\r\n private\r\n FDotNetHighlighting: Boolean;\r\n protected\r\n procedure BoundsChanged; reintroduce; virtual;\r\n procedure CursorChanged; reintroduce; dynamic;\r\n procedure ShowingChanged; reintroduce; dynamic;\r\n procedure ShowHintChanged; reintroduce; dynamic;\r\n procedure ControlsListChanging(Control: TControl; Inserting: Boolean); reintroduce; dynamic;\r\n procedure ControlsListChanged(Control: TControl; Inserting: Boolean); reintroduce; dynamic;\r\n procedure GetDlgCode(var Code: TDlgCodes); virtual;\r\n procedure FocusSet(PrevWnd: THandle); virtual;\r\n procedure FocusKilled(NextWnd: THandle); virtual;\r\n function DoEraseBackground(Canvas: TCanvas; Param: LPARAM): Boolean; virtual;\r\n {$IFDEF JVCLThemesEnabledD6}\r\n private\r\n function GetParentBackground: Boolean;\r\n protected\r\n procedure SetParentBackground(Value: Boolean); virtual;\r\n property ParentBackground: Boolean read GetParentBackground write SetParentBackground;\r\n {$ENDIF JVCLThemesEnabledD6}\r\n published\r\n property DotNetHighlighting: Boolean read FDotNetHighlighting write FDotNetHighlighting default False;\r\n end;\r\n\r\n TJvExTrackBar = class(TTrackBar, IJvExControl)\r\n private\r\n FAboutJVCL: TJVCLAboutInfo;\r\n FHintColor: TColor;\r\n FMouseOver: Boolean;\r\n FHintWindowClass: THintWindowClass;\r\n FOnMouseEnter: TNotifyEvent;\r\n FOnMouseLeave: TNotifyEvent;\r\n FOnParentColorChanged: TNotifyEvent;\r\n function BaseWndProc(Msg: Cardinal; WParam: WPARAM = 0; LParam: LPARAM = 0): LRESULT; overload;\r\n function BaseWndProc(Msg: Cardinal; WParam: WPARAM; LParam: TObject): LRESULT; overload;\r\n function BaseWndProcEx(Msg: Cardinal; WParam: WPARAM; var StructLParam): LRESULT;\r\n protected\r\n procedure WndProc(var Msg: TMessage); override;\r\n procedure FocusChanged(AControl: TWinControl); dynamic;\r\n procedure VisibleChanged; reintroduce; dynamic;\r\n procedure EnabledChanged; reintroduce; dynamic;\r\n procedure TextChanged; reintroduce; virtual;\r\n procedure ColorChanged; reintroduce; dynamic;\r\n procedure FontChanged; reintroduce; dynamic;\r\n procedure ParentFontChanged; reintroduce; dynamic;\r\n procedure ParentColorChanged; reintroduce; dynamic;\r\n procedure ParentShowHintChanged; reintroduce; dynamic;\r\n function WantKey(Key: Integer; Shift: TShiftState): Boolean; virtual;\r\n function HintShow(var HintInfo: THintInfo): Boolean; reintroduce; dynamic;\r\n function HitTest(X, Y: Integer): Boolean; reintroduce; virtual;\r\n procedure MouseEnter(AControl: TControl); reintroduce; dynamic;\r\n procedure MouseLeave(AControl: TControl); reintroduce; dynamic;\r\n property MouseOver: Boolean read FMouseOver write FMouseOver;\r\n property HintColor: TColor read FHintColor write FHintColor default clDefault;\r\n property OnMouseEnter: TNotifyEvent read FOnMouseEnter write FOnMouseEnter;\r\n property OnMouseLeave: TNotifyEvent read FOnMouseLeave write FOnMouseLeave;\r\n property OnParentColorChange: TNotifyEvent read FOnParentColorChanged write FOnParentColorChanged;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n property HintWindowClass: THintWindowClass read FHintWindowClass write FHintWindowClass;\r\n published\r\n property AboutJVCL: TJVCLAboutInfo read FAboutJVCL write FAboutJVCL stored False;\r\n private\r\n FDotNetHighlighting: Boolean;\r\n protected\r\n procedure BoundsChanged; reintroduce; virtual;\r\n procedure CursorChanged; reintroduce; dynamic;\r\n procedure ShowingChanged; reintroduce; dynamic;\r\n procedure ShowHintChanged; reintroduce; dynamic;\r\n procedure ControlsListChanging(Control: TControl; Inserting: Boolean); reintroduce; dynamic;\r\n procedure ControlsListChanged(Control: TControl; Inserting: Boolean); reintroduce; dynamic;\r\n procedure GetDlgCode(var Code: TDlgCodes); virtual;\r\n procedure FocusSet(PrevWnd: THandle); virtual;\r\n procedure FocusKilled(NextWnd: THandle); virtual;\r\n function DoEraseBackground(Canvas: TCanvas; Param: LPARAM): Boolean; virtual;\r\n {$IFDEF JVCLThemesEnabledD6}\r\n private\r\n function GetParentBackground: Boolean;\r\n protected\r\n procedure SetParentBackground(Value: Boolean); virtual;\r\n property ParentBackground: Boolean read GetParentBackground write SetParentBackground;\r\n {$ENDIF JVCLThemesEnabledD6}\r\n published\r\n property DotNetHighlighting: Boolean read FDotNetHighlighting write FDotNetHighlighting default False;\r\n end;\r\n\r\n TJvExAnimate = class(TAnimate, IJvExControl)\r\n private\r\n FAboutJVCL: TJVCLAboutInfo;\r\n FHintColor: TColor;\r\n FMouseOver: Boolean;\r\n FHintWindowClass: THintWindowClass;\r\n FOnMouseEnter: TNotifyEvent;\r\n FOnMouseLeave: TNotifyEvent;\r\n FOnParentColorChanged: TNotifyEvent;\r\n function BaseWndProc(Msg: Cardinal; WParam: WPARAM = 0; LParam: LPARAM = 0): LRESULT; overload;\r\n function BaseWndProc(Msg: Cardinal; WParam: WPARAM; LParam: TObject): LRESULT; overload;\r\n function BaseWndProcEx(Msg: Cardinal; WParam: WPARAM; var StructLParam): LRESULT;\r\n protected\r\n procedure WndProc(var Msg: TMessage); override;\r\n procedure FocusChanged(AControl: TWinControl); dynamic;\r\n procedure VisibleChanged; reintroduce; dynamic;\r\n procedure EnabledChanged; reintroduce; dynamic;\r\n procedure TextChanged; reintroduce; virtual;\r\n procedure ColorChanged; reintroduce; dynamic;\r\n procedure FontChanged; reintroduce; dynamic;\r\n procedure ParentFontChanged; reintroduce; dynamic;\r\n procedure ParentColorChanged; reintroduce; dynamic;\r\n procedure ParentShowHintChanged; reintroduce; dynamic;\r\n function WantKey(Key: Integer; Shift: TShiftState): Boolean; virtual;\r\n function HintShow(var HintInfo: THintInfo): Boolean; reintroduce; dynamic;\r\n function HitTest(X, Y: Integer): Boolean; reintroduce; virtual;\r\n procedure MouseEnter(AControl: TControl); reintroduce; dynamic;\r\n procedure MouseLeave(AControl: TControl); reintroduce; dynamic;\r\n property MouseOver: Boolean read FMouseOver write FMouseOver;\r\n property HintColor: TColor read FHintColor write FHintColor default clDefault;\r\n property OnMouseEnter: TNotifyEvent read FOnMouseEnter write FOnMouseEnter;\r\n property OnMouseLeave: TNotifyEvent read FOnMouseLeave write FOnMouseLeave;\r\n property OnParentColorChange: TNotifyEvent read FOnParentColorChanged write FOnParentColorChanged;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n property HintWindowClass: THintWindowClass read FHintWindowClass write FHintWindowClass;\r\n published\r\n property AboutJVCL: TJVCLAboutInfo read FAboutJVCL write FAboutJVCL stored False;\r\n private\r\n FDotNetHighlighting: Boolean;\r\n protected\r\n procedure BoundsChanged; reintroduce; virtual;\r\n procedure CursorChanged; reintroduce; dynamic;\r\n procedure ShowingChanged; reintroduce; dynamic;\r\n procedure ShowHintChanged; reintroduce; dynamic;\r\n procedure ControlsListChanging(Control: TControl; Inserting: Boolean); reintroduce; dynamic;\r\n procedure ControlsListChanged(Control: TControl; Inserting: Boolean); reintroduce; dynamic;\r\n procedure GetDlgCode(var Code: TDlgCodes); virtual;\r\n procedure FocusSet(PrevWnd: THandle); virtual;\r\n procedure FocusKilled(NextWnd: THandle); virtual;\r\n function DoEraseBackground(Canvas: TCanvas; Param: LPARAM): Boolean; virtual;\r\n {$IFDEF JVCLThemesEnabledD6}\r\n private\r\n function GetParentBackground: Boolean;\r\n protected\r\n procedure SetParentBackground(Value: Boolean); virtual;\r\n property ParentBackground: Boolean read GetParentBackground write SetParentBackground;\r\n {$ENDIF JVCLThemesEnabledD6}\r\n published\r\n property DotNetHighlighting: Boolean read FDotNetHighlighting write FDotNetHighlighting default False;\r\n end;\r\n\r\n TJvExCustomComboBoxEx = class(TCustomComboBoxEx, IJvExControl)\r\n private\r\n FAboutJVCL: TJVCLAboutInfo;\r\n FHintColor: TColor;\r\n FMouseOver: Boolean;\r\n FHintWindowClass: THintWindowClass;\r\n FOnMouseEnter: TNotifyEvent;\r\n FOnMouseLeave: TNotifyEvent;\r\n FOnParentColorChanged: TNotifyEvent;\r\n function BaseWndProc(Msg: Cardinal; WParam: WPARAM = 0; LParam: LPARAM = 0): LRESULT; overload;\r\n function BaseWndProc(Msg: Cardinal; WParam: WPARAM; LParam: TObject): LRESULT; overload;\r\n function BaseWndProcEx(Msg: Cardinal; WParam: WPARAM; var StructLParam): LRESULT;\r\n protected\r\n procedure WndProc(var Msg: TMessage); override;\r\n procedure FocusChanged(AControl: TWinControl); dynamic;\r\n procedure VisibleChanged; reintroduce; dynamic;\r\n procedure EnabledChanged; reintroduce; dynamic;\r\n procedure TextChanged; reintroduce; virtual;\r\n procedure ColorChanged; reintroduce; dynamic;\r\n procedure FontChanged; reintroduce; dynamic;\r\n procedure ParentFontChanged; reintroduce; dynamic;\r\n procedure ParentColorChanged; reintroduce; dynamic;\r\n procedure ParentShowHintChanged; reintroduce; dynamic;\r\n function WantKey(Key: Integer; Shift: TShiftState): Boolean; virtual;\r\n function HintShow(var HintInfo: THintInfo): Boolean; reintroduce; dynamic;\r\n function HitTest(X, Y: Integer): Boolean; reintroduce; virtual;\r\n procedure MouseEnter(AControl: TControl); reintroduce; dynamic;\r\n procedure MouseLeave(AControl: TControl); reintroduce; dynamic;\r\n property MouseOver: Boolean read FMouseOver write FMouseOver;\r\n property HintColor: TColor read FHintColor write FHintColor default clDefault;\r\n property OnMouseEnter: TNotifyEvent read FOnMouseEnter write FOnMouseEnter;\r\n property OnMouseLeave: TNotifyEvent read FOnMouseLeave write FOnMouseLeave;\r\n property OnParentColorChange: TNotifyEvent read FOnParentColorChanged write FOnParentColorChanged;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n property HintWindowClass: THintWindowClass read FHintWindowClass write FHintWindowClass;\r\n published\r\n property AboutJVCL: TJVCLAboutInfo read FAboutJVCL write FAboutJVCL stored False;\r\n private\r\n FDotNetHighlighting: Boolean;\r\n protected\r\n procedure BoundsChanged; reintroduce; virtual;\r\n procedure CursorChanged; reintroduce; dynamic;\r\n procedure ShowingChanged; reintroduce; dynamic;\r\n procedure ShowHintChanged; reintroduce; dynamic;\r\n procedure ControlsListChanging(Control: TControl; Inserting: Boolean); reintroduce; dynamic;\r\n procedure ControlsListChanged(Control: TControl; Inserting: Boolean); reintroduce; dynamic;\r\n procedure GetDlgCode(var Code: TDlgCodes); virtual;\r\n procedure FocusSet(PrevWnd: THandle); virtual;\r\n procedure FocusKilled(NextWnd: THandle); virtual;\r\n function DoEraseBackground(Canvas: TCanvas; Param: LPARAM): Boolean; virtual;\r\n {$IFDEF JVCLThemesEnabledD6}\r\n private\r\n function GetParentBackground: Boolean;\r\n protected\r\n procedure SetParentBackground(Value: Boolean); virtual;\r\n property ParentBackground: Boolean read GetParentBackground write SetParentBackground;\r\n {$ENDIF JVCLThemesEnabledD6}\r\n published\r\n property DotNetHighlighting: Boolean read FDotNetHighlighting write FDotNetHighlighting default False;\r\n end;\r\n\r\n TJvExCustomStatusBar = class(TCustomStatusBar, IJvExControl)\r\n private\r\n FAboutJVCL: TJVCLAboutInfo;\r\n FHintColor: TColor;\r\n FMouseOver: Boolean;\r\n FHintWindowClass: THintWindowClass;\r\n FOnMouseEnter: TNotifyEvent;\r\n FOnMouseLeave: TNotifyEvent;\r\n FOnParentColorChanged: TNotifyEvent;\r\n function BaseWndProc(Msg: Cardinal; WParam: WPARAM = 0; LParam: LPARAM = 0): LRESULT; overload;\r\n function BaseWndProc(Msg: Cardinal; WParam: WPARAM; LParam: TObject): LRESULT; overload;\r\n function BaseWndProcEx(Msg: Cardinal; WParam: WPARAM; var StructLParam): LRESULT;\r\n protected\r\n procedure WndProc(var Msg: TMessage); override;\r\n procedure FocusChanged(AControl: TWinControl); dynamic;\r\n procedure VisibleChanged; reintroduce; dynamic;\r\n procedure EnabledChanged; reintroduce; dynamic;\r\n procedure TextChanged; reintroduce; virtual;\r\n procedure ColorChanged; reintroduce; dynamic;\r\n procedure FontChanged; reintroduce; dynamic;\r\n procedure ParentFontChanged; reintroduce; dynamic;\r\n procedure ParentColorChanged; reintroduce; dynamic;\r\n procedure ParentShowHintChanged; reintroduce; dynamic;\r\n function WantKey(Key: Integer; Shift: TShiftState): Boolean; virtual;\r\n function HintShow(var HintInfo: THintInfo): Boolean; reintroduce; dynamic;\r\n function HitTest(X, Y: Integer): Boolean; reintroduce; virtual;\r\n procedure MouseEnter(AControl: TControl); reintroduce; dynamic;\r\n procedure MouseLeave(AControl: TControl); reintroduce; dynamic;\r\n property MouseOver: Boolean read FMouseOver write FMouseOver;\r\n property HintColor: TColor read FHintColor write FHintColor default clDefault;\r\n property OnMouseEnter: TNotifyEvent read FOnMouseEnter write FOnMouseEnter;\r\n property OnMouseLeave: TNotifyEvent read FOnMouseLeave write FOnMouseLeave;\r\n property OnParentColorChange: TNotifyEvent read FOnParentColorChanged write FOnParentColorChanged;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n property HintWindowClass: THintWindowClass read FHintWindowClass write FHintWindowClass;\r\n published\r\n property AboutJVCL: TJVCLAboutInfo read FAboutJVCL write FAboutJVCL stored False;\r\n private\r\n FDotNetHighlighting: Boolean;\r\n protected\r\n procedure BoundsChanged; reintroduce; virtual;\r\n procedure CursorChanged; reintroduce; dynamic;\r\n procedure ShowingChanged; reintroduce; dynamic;\r\n procedure ShowHintChanged; reintroduce; dynamic;\r\n procedure ControlsListChanging(Control: TControl; Inserting: Boolean); reintroduce; dynamic;\r\n procedure ControlsListChanged(Control: TControl; Inserting: Boolean); reintroduce; dynamic;\r\n procedure GetDlgCode(var Code: TDlgCodes); virtual;\r\n procedure FocusSet(PrevWnd: THandle); virtual;\r\n procedure FocusKilled(NextWnd: THandle); virtual;\r\n function DoEraseBackground(Canvas: TCanvas; Param: LPARAM): Boolean; virtual;\r\n {$IFDEF JVCLThemesEnabledD6}\r\n private\r\n function GetParentBackground: Boolean;\r\n protected\r\n procedure SetParentBackground(Value: Boolean); virtual;\r\n property ParentBackground: Boolean read GetParentBackground write SetParentBackground;\r\n {$ENDIF JVCLThemesEnabledD6}\r\n published\r\n property DotNetHighlighting: Boolean read FDotNetHighlighting write FDotNetHighlighting default False;\r\n end;\r\n\r\n TJvExComboBoxEx = class(TComboBoxEx, IJvExControl)\r\n private\r\n FAboutJVCL: TJVCLAboutInfo;\r\n FHintColor: TColor;\r\n FMouseOver: Boolean;\r\n FHintWindowClass: THintWindowClass;\r\n FOnMouseEnter: TNotifyEvent;\r\n FOnMouseLeave: TNotifyEvent;\r\n FOnParentColorChanged: TNotifyEvent;\r\n function BaseWndProc(Msg: Cardinal; WParam: WPARAM = 0; LParam: LPARAM = 0): LRESULT; overload;\r\n function BaseWndProc(Msg: Cardinal; WParam: WPARAM; LParam: TObject): LRESULT; overload;\r\n function BaseWndProcEx(Msg: Cardinal; WParam: WPARAM; var StructLParam): LRESULT;\r\n protected\r\n procedure WndProc(var Msg: TMessage); override;\r\n procedure FocusChanged(AControl: TWinControl); dynamic;\r\n procedure VisibleChanged; reintroduce; dynamic;\r\n procedure EnabledChanged; reintroduce; dynamic;\r\n procedure TextChanged; reintroduce; virtual;\r\n procedure ColorChanged; reintroduce; dynamic;\r\n procedure FontChanged; reintroduce; dynamic;\r\n procedure ParentFontChanged; reintroduce; dynamic;\r\n procedure ParentColorChanged; reintroduce; dynamic;\r\n procedure ParentShowHintChanged; reintroduce; dynamic;\r\n function WantKey(Key: Integer; Shift: TShiftState): Boolean; virtual;\r\n function HintShow(var HintInfo: THintInfo): Boolean; reintroduce; dynamic;\r\n function HitTest(X, Y: Integer): Boolean; reintroduce; virtual;\r\n procedure MouseEnter(AControl: TControl); reintroduce; dynamic;\r\n procedure MouseLeave(AControl: TControl); reintroduce; dynamic;\r\n property MouseOver: Boolean read FMouseOver write FMouseOver;\r\n property HintColor: TColor read FHintColor write FHintColor default clDefault;\r\n property OnMouseEnter: TNotifyEvent read FOnMouseEnter write FOnMouseEnter;\r\n property OnMouseLeave: TNotifyEvent read FOnMouseLeave write FOnMouseLeave;\r\n property OnParentColorChange: TNotifyEvent read FOnParentColorChanged write FOnParentColorChanged;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n property HintWindowClass: THintWindowClass read FHintWindowClass write FHintWindowClass;\r\n published\r\n property AboutJVCL: TJVCLAboutInfo read FAboutJVCL write FAboutJVCL stored False;\r\n private\r\n FDotNetHighlighting: Boolean;\r\n protected\r\n procedure BoundsChanged; reintroduce; virtual;\r\n procedure CursorChanged; reintroduce; dynamic;\r\n procedure ShowingChanged; reintroduce; dynamic;\r\n procedure ShowHintChanged; reintroduce; dynamic;\r\n procedure ControlsListChanging(Control: TControl; Inserting: Boolean); reintroduce; dynamic;\r\n procedure ControlsListChanged(Control: TControl; Inserting: Boolean); reintroduce; dynamic;\r\n procedure GetDlgCode(var Code: TDlgCodes); virtual;\r\n procedure FocusSet(PrevWnd: THandle); virtual;\r\n procedure FocusKilled(NextWnd: THandle); virtual;\r\n function DoEraseBackground(Canvas: TCanvas; Param: LPARAM): Boolean; virtual;\r\n {$IFDEF JVCLThemesEnabledD6}\r\n private\r\n function GetParentBackground: Boolean;\r\n protected\r\n procedure SetParentBackground(Value: Boolean); virtual;\r\n property ParentBackground: Boolean read GetParentBackground write SetParentBackground;\r\n {$ENDIF JVCLThemesEnabledD6}\r\n published\r\n property DotNetHighlighting: Boolean read FDotNetHighlighting write FDotNetHighlighting default False;\r\n end;\r\n\r\n TJvExCoolBar = class(TCoolBar, IJvExControl)\r\n private\r\n FAboutJVCL: TJVCLAboutInfo;\r\n FHintColor: TColor;\r\n FMouseOver: Boolean;\r\n FHintWindowClass: THintWindowClass;\r\n FOnMouseEnter: TNotifyEvent;\r\n FOnMouseLeave: TNotifyEvent;\r\n FOnParentColorChanged: TNotifyEvent;\r\n function BaseWndProc(Msg: Cardinal; WParam: WPARAM = 0; LParam: LPARAM = 0): LRESULT; overload;\r\n function BaseWndProc(Msg: Cardinal; WParam: WPARAM; LParam: TObject): LRESULT; overload;\r\n function BaseWndProcEx(Msg: Cardinal; WParam: WPARAM; var StructLParam): LRESULT;\r\n protected\r\n procedure WndProc(var Msg: TMessage); override;\r\n procedure FocusChanged(AControl: TWinControl); dynamic;\r\n procedure VisibleChanged; reintroduce; dynamic;\r\n procedure EnabledChanged; reintroduce; dynamic;\r\n procedure TextChanged; reintroduce; virtual;\r\n procedure ColorChanged; reintroduce; dynamic;\r\n procedure FontChanged; reintroduce; dynamic;\r\n procedure ParentFontChanged; reintroduce; dynamic;\r\n procedure ParentColorChanged; reintroduce; dynamic;\r\n procedure ParentShowHintChanged; reintroduce; dynamic;\r\n function WantKey(Key: Integer; Shift: TShiftState): Boolean; virtual;\r\n function HintShow(var HintInfo: THintInfo): Boolean; reintroduce; dynamic;\r\n function HitTest(X, Y: Integer): Boolean; reintroduce; virtual;\r\n procedure MouseEnter(AControl: TControl); reintroduce; dynamic;\r\n procedure MouseLeave(AControl: TControl); reintroduce; dynamic;\r\n property MouseOver: Boolean read FMouseOver write FMouseOver;\r\n property HintColor: TColor read FHintColor write FHintColor default clDefault;\r\n property OnMouseEnter: TNotifyEvent read FOnMouseEnter write FOnMouseEnter;\r\n property OnMouseLeave: TNotifyEvent read FOnMouseLeave write FOnMouseLeave;\r\n property OnParentColorChange: TNotifyEvent read FOnParentColorChanged write FOnParentColorChanged;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n property HintWindowClass: THintWindowClass read FHintWindowClass write FHintWindowClass;\r\n published\r\n property AboutJVCL: TJVCLAboutInfo read FAboutJVCL write FAboutJVCL stored False;\r\n private\r\n FDotNetHighlighting: Boolean;\r\n protected\r\n procedure BoundsChanged; reintroduce; virtual;\r\n procedure CursorChanged; reintroduce; dynamic;\r\n procedure ShowingChanged; reintroduce; dynamic;\r\n procedure ShowHintChanged; reintroduce; dynamic;\r\n procedure ControlsListChanging(Control: TControl; Inserting: Boolean); reintroduce; dynamic;\r\n procedure ControlsListChanged(Control: TControl; Inserting: Boolean); reintroduce; dynamic;\r\n procedure GetDlgCode(var Code: TDlgCodes); virtual;\r\n procedure FocusSet(PrevWnd: THandle); virtual;\r\n procedure FocusKilled(NextWnd: THandle); virtual;\r\n function DoEraseBackground(Canvas: TCanvas; Param: LPARAM): Boolean; virtual;\r\n {$IFDEF JVCLThemesEnabledD6}\r\n private\r\n function GetParentBackground: Boolean;\r\n protected\r\n procedure SetParentBackground(Value: Boolean); virtual;\r\n property ParentBackground: Boolean read GetParentBackground write SetParentBackground;\r\n {$ENDIF JVCLThemesEnabledD6}\r\n published\r\n property DotNetHighlighting: Boolean read FDotNetHighlighting write FDotNetHighlighting default False;\r\n end;\r\n\r\n TJvExCommonCalendar = class(TCommonCalendar, IJvExControl)\r\n private\r\n FAboutJVCL: TJVCLAboutInfo;\r\n FHintColor: TColor;\r\n FMouseOver: Boolean;\r\n FHintWindowClass: THintWindowClass;\r\n FOnMouseEnter: TNotifyEvent;\r\n FOnMouseLeave: TNotifyEvent;\r\n FOnParentColorChanged: TNotifyEvent;\r\n function BaseWndProc(Msg: Cardinal; WParam: WPARAM = 0; LParam: LPARAM = 0): LRESULT; overload;\r\n function BaseWndProc(Msg: Cardinal; WParam: WPARAM; LParam: TObject): LRESULT; overload;\r\n function BaseWndProcEx(Msg: Cardinal; WParam: WPARAM; var StructLParam): LRESULT;\r\n protected\r\n procedure WndProc(var Msg: TMessage); override;\r\n procedure FocusChanged(AControl: TWinControl); dynamic;\r\n procedure VisibleChanged; reintroduce; dynamic;\r\n procedure EnabledChanged; reintroduce; dynamic;\r\n procedure TextChanged; reintroduce; virtual;\r\n procedure ColorChanged; reintroduce; dynamic;\r\n procedure FontChanged; reintroduce; dynamic;\r\n procedure ParentFontChanged; reintroduce; dynamic;\r\n procedure ParentColorChanged; reintroduce; dynamic;\r\n procedure ParentShowHintChanged; reintroduce; dynamic;\r\n function WantKey(Key: Integer; Shift: TShiftState): Boolean; virtual;\r\n function HintShow(var HintInfo: THintInfo): Boolean; reintroduce; dynamic;\r\n function HitTest(X, Y: Integer): Boolean; reintroduce; virtual;\r\n procedure MouseEnter(AControl: TControl); reintroduce; dynamic;\r\n procedure MouseLeave(AControl: TControl); reintroduce; dynamic;\r\n property MouseOver: Boolean read FMouseOver write FMouseOver;\r\n property HintColor: TColor read FHintColor write FHintColor default clDefault;\r\n property OnMouseEnter: TNotifyEvent read FOnMouseEnter write FOnMouseEnter;\r\n property OnMouseLeave: TNotifyEvent read FOnMouseLeave write FOnMouseLeave;\r\n property OnParentColorChange: TNotifyEvent read FOnParentColorChanged write FOnParentColorChanged;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n property HintWindowClass: THintWindowClass read FHintWindowClass write FHintWindowClass;\r\n published\r\n property AboutJVCL: TJVCLAboutInfo read FAboutJVCL write FAboutJVCL stored False;\r\n private\r\n FDotNetHighlighting: Boolean;\r\n protected\r\n procedure BoundsChanged; reintroduce; virtual;\r\n procedure CursorChanged; reintroduce; dynamic;\r\n procedure ShowingChanged; reintroduce; dynamic;\r\n procedure ShowHintChanged; reintroduce; dynamic;\r\n procedure ControlsListChanging(Control: TControl; Inserting: Boolean); reintroduce; dynamic;\r\n procedure ControlsListChanged(Control: TControl; Inserting: Boolean); reintroduce; dynamic;\r\n procedure GetDlgCode(var Code: TDlgCodes); virtual;\r\n procedure FocusSet(PrevWnd: THandle); virtual;\r\n procedure FocusKilled(NextWnd: THandle); virtual;\r\n function DoEraseBackground(Canvas: TCanvas; Param: LPARAM): Boolean; virtual;\r\n {$IFDEF JVCLThemesEnabledD6}\r\n private\r\n function GetParentBackground: Boolean;\r\n protected\r\n procedure SetParentBackground(Value: Boolean); virtual;\r\n property ParentBackground: Boolean read GetParentBackground write SetParentBackground;\r\n {$ENDIF JVCLThemesEnabledD6}\r\n published\r\n property DotNetHighlighting: Boolean read FDotNetHighlighting write FDotNetHighlighting default False;\r\n end;\r\n\r\n TJvExMonthCalendar = class(TMonthCalendar, IJvExControl)\r\n private\r\n FAboutJVCL: TJVCLAboutInfo;\r\n FHintColor: TColor;\r\n FMouseOver: Boolean;\r\n FHintWindowClass: THintWindowClass;\r\n FOnMouseEnter: TNotifyEvent;\r\n FOnMouseLeave: TNotifyEvent;\r\n FOnParentColorChanged: TNotifyEvent;\r\n function BaseWndProc(Msg: Cardinal; WParam: WPARAM = 0; LParam: LPARAM = 0): LRESULT; overload;\r\n function BaseWndProc(Msg: Cardinal; WParam: WPARAM; LParam: TObject): LRESULT; overload;\r\n function BaseWndProcEx(Msg: Cardinal; WParam: WPARAM; var StructLParam): LRESULT;\r\n protected\r\n procedure WndProc(var Msg: TMessage); override;\r\n procedure FocusChanged(AControl: TWinControl); dynamic;\r\n procedure VisibleChanged; reintroduce; dynamic;\r\n procedure EnabledChanged; reintroduce; dynamic;\r\n procedure TextChanged; reintroduce; virtual;\r\n procedure ColorChanged; reintroduce; dynamic;\r\n procedure FontChanged; reintroduce; dynamic;\r\n procedure ParentFontChanged; reintroduce; dynamic;\r\n procedure ParentColorChanged; reintroduce; dynamic;\r\n procedure ParentShowHintChanged; reintroduce; dynamic;\r\n function WantKey(Key: Integer; Shift: TShiftState): Boolean; virtual;\r\n function HintShow(var HintInfo: THintInfo): Boolean; reintroduce; dynamic;\r\n function HitTest(X, Y: Integer): Boolean; reintroduce; virtual;\r\n procedure MouseEnter(AControl: TControl); reintroduce; dynamic;\r\n procedure MouseLeave(AControl: TControl); reintroduce; dynamic;\r\n property MouseOver: Boolean read FMouseOver write FMouseOver;\r\n property HintColor: TColor read FHintColor write FHintColor default clDefault;\r\n property OnMouseEnter: TNotifyEvent read FOnMouseEnter write FOnMouseEnter;\r\n property OnMouseLeave: TNotifyEvent read FOnMouseLeave write FOnMouseLeave;\r\n property OnParentColorChange: TNotifyEvent read FOnParentColorChanged write FOnParentColorChanged;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n property HintWindowClass: THintWindowClass read FHintWindowClass write FHintWindowClass;\r\n published\r\n property AboutJVCL: TJVCLAboutInfo read FAboutJVCL write FAboutJVCL stored False;\r\n private\r\n FDotNetHighlighting: Boolean;\r\n protected\r\n procedure BoundsChanged; reintroduce; virtual;\r\n procedure CursorChanged; reintroduce; dynamic;\r\n procedure ShowingChanged; reintroduce; dynamic;\r\n procedure ShowHintChanged; reintroduce; dynamic;\r\n procedure ControlsListChanging(Control: TControl; Inserting: Boolean); reintroduce; dynamic;\r\n procedure ControlsListChanged(Control: TControl; Inserting: Boolean); reintroduce; dynamic;\r\n procedure GetDlgCode(var Code: TDlgCodes); virtual;\r\n procedure FocusSet(PrevWnd: THandle); virtual;\r\n procedure FocusKilled(NextWnd: THandle); virtual;\r\n function DoEraseBackground(Canvas: TCanvas; Param: LPARAM): Boolean; virtual;\r\n {$IFDEF JVCLThemesEnabledD6}\r\n private\r\n function GetParentBackground: Boolean;\r\n protected\r\n procedure SetParentBackground(Value: Boolean); virtual;\r\n property ParentBackground: Boolean read GetParentBackground write SetParentBackground;\r\n {$ENDIF JVCLThemesEnabledD6}\r\n published\r\n property DotNetHighlighting: Boolean read FDotNetHighlighting write FDotNetHighlighting default False;\r\n end;\r\n\r\n TJvExCustomHotKey = class(TCustomHotKey, IJvExControl)\r\n private\r\n FAboutJVCL: TJVCLAboutInfo;\r\n FHintColor: TColor;\r\n FMouseOver: Boolean;\r\n FHintWindowClass: THintWindowClass;\r\n FOnMouseEnter: TNotifyEvent;\r\n FOnMouseLeave: TNotifyEvent;\r\n FOnParentColorChanged: TNotifyEvent;\r\n function BaseWndProc(Msg: Cardinal; WParam: WPARAM = 0; LParam: LPARAM = 0): LRESULT; overload;\r\n function BaseWndProc(Msg: Cardinal; WParam: WPARAM; LParam: TObject): LRESULT; overload;\r\n function BaseWndProcEx(Msg: Cardinal; WParam: WPARAM; var StructLParam): LRESULT;\r\n protected\r\n procedure WndProc(var Msg: TMessage); override;\r\n procedure FocusChanged(AControl: TWinControl); dynamic;\r\n procedure VisibleChanged; reintroduce; dynamic;\r\n procedure EnabledChanged; reintroduce; dynamic;\r\n procedure TextChanged; reintroduce; virtual;\r\n procedure ColorChanged; reintroduce; dynamic;\r\n procedure FontChanged; reintroduce; dynamic;\r\n procedure ParentFontChanged; reintroduce; dynamic;\r\n procedure ParentColorChanged; reintroduce; dynamic;\r\n procedure ParentShowHintChanged; reintroduce; dynamic;\r\n function WantKey(Key: Integer; Shift: TShiftState): Boolean; virtual;\r\n function HintShow(var HintInfo: THintInfo): Boolean; reintroduce; dynamic;\r\n function HitTest(X, Y: Integer): Boolean; reintroduce; virtual;\r\n procedure MouseEnter(AControl: TControl); reintroduce; dynamic;\r\n procedure MouseLeave(AControl: TControl); reintroduce; dynamic;\r\n property MouseOver: Boolean read FMouseOver write FMouseOver;\r\n property HintColor: TColor read FHintColor write FHintColor default clDefault;\r\n property OnMouseEnter: TNotifyEvent read FOnMouseEnter write FOnMouseEnter;\r\n property OnMouseLeave: TNotifyEvent read FOnMouseLeave write FOnMouseLeave;\r\n property OnParentColorChange: TNotifyEvent read FOnParentColorChanged write FOnParentColorChanged;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n property HintWindowClass: THintWindowClass read FHintWindowClass write FHintWindowClass;\r\n published\r\n property AboutJVCL: TJVCLAboutInfo read FAboutJVCL write FAboutJVCL stored False;\r\n private\r\n FDotNetHighlighting: Boolean;\r\n protected\r\n procedure BoundsChanged; reintroduce; virtual;\r\n procedure CursorChanged; reintroduce; dynamic;\r\n procedure ShowingChanged; reintroduce; dynamic;\r\n procedure ShowHintChanged; reintroduce; dynamic;\r\n procedure ControlsListChanging(Control: TControl; Inserting: Boolean); reintroduce; dynamic;\r\n procedure ControlsListChanged(Control: TControl; Inserting: Boolean); reintroduce; dynamic;\r\n procedure GetDlgCode(var Code: TDlgCodes); virtual;\r\n procedure FocusSet(PrevWnd: THandle); virtual;\r\n procedure FocusKilled(NextWnd: THandle); virtual;\r\n function DoEraseBackground(Canvas: TCanvas; Param: LPARAM): Boolean; virtual;\r\n {$IFDEF JVCLThemesEnabledD6}\r\n private\r\n function GetParentBackground: Boolean;\r\n protected\r\n procedure SetParentBackground(Value: Boolean); virtual;\r\n property ParentBackground: Boolean read GetParentBackground write SetParentBackground;\r\n {$ENDIF JVCLThemesEnabledD6}\r\n published\r\n property DotNetHighlighting: Boolean read FDotNetHighlighting write FDotNetHighlighting default False;\r\n end;\r\n\r\n TJvExHotKey = class(THotKey, IJvExControl)\r\n private\r\n FAboutJVCL: TJVCLAboutInfo;\r\n FHintColor: TColor;\r\n FMouseOver: Boolean;\r\n FHintWindowClass: THintWindowClass;\r\n FOnMouseEnter: TNotifyEvent;\r\n FOnMouseLeave: TNotifyEvent;\r\n FOnParentColorChanged: TNotifyEvent;\r\n function BaseWndProc(Msg: Cardinal; WParam: WPARAM = 0; LParam: LPARAM = 0): LRESULT; overload;\r\n function BaseWndProc(Msg: Cardinal; WParam: WPARAM; LParam: TObject): LRESULT; overload;\r\n function BaseWndProcEx(Msg: Cardinal; WParam: WPARAM; var StructLParam): LRESULT;\r\n protected\r\n procedure WndProc(var Msg: TMessage); override;\r\n procedure FocusChanged(AControl: TWinControl); dynamic;\r\n procedure VisibleChanged; reintroduce; dynamic;\r\n procedure EnabledChanged; reintroduce; dynamic;\r\n procedure TextChanged; reintroduce; virtual;\r\n procedure ColorChanged; reintroduce; dynamic;\r\n procedure FontChanged; reintroduce; dynamic;\r\n procedure ParentFontChanged; reintroduce; dynamic;\r\n procedure ParentColorChanged; reintroduce; dynamic;\r\n procedure ParentShowHintChanged; reintroduce; dynamic;\r\n function WantKey(Key: Integer; Shift: TShiftState): Boolean; virtual;\r\n function HintShow(var HintInfo: THintInfo): Boolean; reintroduce; dynamic;\r\n function HitTest(X, Y: Integer): Boolean; reintroduce; virtual;\r\n procedure MouseEnter(AControl: TControl); reintroduce; dynamic;\r\n procedure MouseLeave(AControl: TControl); reintroduce; dynamic;\r\n property MouseOver: Boolean read FMouseOver write FMouseOver;\r\n property HintColor: TColor read FHintColor write FHintColor default clDefault;\r\n property OnMouseEnter: TNotifyEvent read FOnMouseEnter write FOnMouseEnter;\r\n property OnMouseLeave: TNotifyEvent read FOnMouseLeave write FOnMouseLeave;\r\n property OnParentColorChange: TNotifyEvent read FOnParentColorChanged write FOnParentColorChanged;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n property HintWindowClass: THintWindowClass read FHintWindowClass write FHintWindowClass;\r\n published\r\n property AboutJVCL: TJVCLAboutInfo read FAboutJVCL write FAboutJVCL stored False;\r\n private\r\n FDotNetHighlighting: Boolean;\r\n protected\r\n procedure BoundsChanged; reintroduce; virtual;\r\n procedure CursorChanged; reintroduce; dynamic;\r\n procedure ShowingChanged; reintroduce; dynamic;\r\n procedure ShowHintChanged; reintroduce; dynamic;\r\n procedure ControlsListChanging(Control: TControl; Inserting: Boolean); reintroduce; dynamic;\r\n procedure ControlsListChanged(Control: TControl; Inserting: Boolean); reintroduce; dynamic;\r\n procedure GetDlgCode(var Code: TDlgCodes); virtual;\r\n procedure FocusSet(PrevWnd: THandle); virtual;\r\n procedure FocusKilled(NextWnd: THandle); virtual;\r\n function DoEraseBackground(Canvas: TCanvas; Param: LPARAM): Boolean; virtual;\r\n {$IFDEF JVCLThemesEnabledD6}\r\n private\r\n function GetParentBackground: Boolean;\r\n protected\r\n procedure SetParentBackground(Value: Boolean); virtual;\r\n property ParentBackground: Boolean read GetParentBackground write SetParentBackground;\r\n {$ENDIF JVCLThemesEnabledD6}\r\n published\r\n property DotNetHighlighting: Boolean read FDotNetHighlighting write FDotNetHighlighting default False;\r\n end;\r\n\r\n TJvExCustomUpDown = class(TCustomUpDown, IJvExControl)\r\n private\r\n FAboutJVCL: TJVCLAboutInfo;\r\n FHintColor: TColor;\r\n FMouseOver: Boolean;\r\n FHintWindowClass: THintWindowClass;\r\n FOnMouseEnter: TNotifyEvent;\r\n FOnMouseLeave: TNotifyEvent;\r\n FOnParentColorChanged: TNotifyEvent;\r\n function BaseWndProc(Msg: Cardinal; WParam: WPARAM = 0; LParam: LPARAM = 0): LRESULT; overload;\r\n function BaseWndProc(Msg: Cardinal; WParam: WPARAM; LParam: TObject): LRESULT; overload;\r\n function BaseWndProcEx(Msg: Cardinal; WParam: WPARAM; var StructLParam): LRESULT;\r\n protected\r\n procedure WndProc(var Msg: TMessage); override;\r\n procedure FocusChanged(AControl: TWinControl); dynamic;\r\n procedure VisibleChanged; reintroduce; dynamic;\r\n procedure EnabledChanged; reintroduce; dynamic;\r\n procedure TextChanged; reintroduce; virtual;\r\n procedure ColorChanged; reintroduce; dynamic;\r\n procedure FontChanged; reintroduce; dynamic;\r\n procedure ParentFontChanged; reintroduce; dynamic;\r\n procedure ParentColorChanged; reintroduce; dynamic;\r\n procedure ParentShowHintChanged; reintroduce; dynamic;\r\n function WantKey(Key: Integer; Shift: TShiftState): Boolean; virtual;\r\n function HintShow(var HintInfo: THintInfo): Boolean; reintroduce; dynamic;\r\n function HitTest(X, Y: Integer): Boolean; reintroduce; virtual;\r\n procedure MouseEnter(AControl: TControl); reintroduce; dynamic;\r\n procedure MouseLeave(AControl: TControl); reintroduce; dynamic;\r\n property MouseOver: Boolean read FMouseOver write FMouseOver;\r\n property HintColor: TColor read FHintColor write FHintColor default clDefault;\r\n property OnMouseEnter: TNotifyEvent read FOnMouseEnter write FOnMouseEnter;\r\n property OnMouseLeave: TNotifyEvent read FOnMouseLeave write FOnMouseLeave;\r\n property OnParentColorChange: TNotifyEvent read FOnParentColorChanged write FOnParentColorChanged;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n property HintWindowClass: THintWindowClass read FHintWindowClass write FHintWindowClass;\r\n published\r\n property AboutJVCL: TJVCLAboutInfo read FAboutJVCL write FAboutJVCL stored False;\r\n private\r\n FDotNetHighlighting: Boolean;\r\n protected\r\n procedure BoundsChanged; reintroduce; virtual;\r\n procedure CursorChanged; reintroduce; dynamic;\r\n procedure ShowingChanged; reintroduce; dynamic;\r\n procedure ShowHintChanged; reintroduce; dynamic;\r\n procedure ControlsListChanging(Control: TControl; Inserting: Boolean); reintroduce; dynamic;\r\n procedure ControlsListChanged(Control: TControl; Inserting: Boolean); reintroduce; dynamic;\r\n procedure GetDlgCode(var Code: TDlgCodes); virtual;\r\n procedure FocusSet(PrevWnd: THandle); virtual;\r\n procedure FocusKilled(NextWnd: THandle); virtual;\r\n function DoEraseBackground(Canvas: TCanvas; Param: LPARAM): Boolean; virtual;\r\n {$IFDEF JVCLThemesEnabledD6}\r\n private\r\n function GetParentBackground: Boolean;\r\n protected\r\n procedure SetParentBackground(Value: Boolean); virtual;\r\n property ParentBackground: Boolean read GetParentBackground write SetParentBackground;\r\n {$ENDIF JVCLThemesEnabledD6}\r\n published\r\n property DotNetHighlighting: Boolean read FDotNetHighlighting write FDotNetHighlighting default False;\r\n end;\r\n\r\n TJvExUpDown = class(TUpDown, IJvExControl)\r\n private\r\n FAboutJVCL: TJVCLAboutInfo;\r\n FHintColor: TColor;\r\n FMouseOver: Boolean;\r\n FHintWindowClass: THintWindowClass;\r\n FOnMouseEnter: TNotifyEvent;\r\n FOnMouseLeave: TNotifyEvent;\r\n FOnParentColorChanged: TNotifyEvent;\r\n function BaseWndProc(Msg: Cardinal; WParam: WPARAM = 0; LParam: LPARAM = 0): LRESULT; overload;\r\n function BaseWndProc(Msg: Cardinal; WParam: WPARAM; LParam: TObject): LRESULT; overload;\r\n function BaseWndProcEx(Msg: Cardinal; WParam: WPARAM; var StructLParam): LRESULT;\r\n protected\r\n procedure WndProc(var Msg: TMessage); override;\r\n procedure FocusChanged(AControl: TWinControl); dynamic;\r\n procedure VisibleChanged; reintroduce; dynamic;\r\n procedure EnabledChanged; reintroduce; dynamic;\r\n procedure TextChanged; reintroduce; virtual;\r\n procedure ColorChanged; reintroduce; dynamic;\r\n procedure FontChanged; reintroduce; dynamic;\r\n procedure ParentFontChanged; reintroduce; dynamic;\r\n procedure ParentColorChanged; reintroduce; dynamic;\r\n procedure ParentShowHintChanged; reintroduce; dynamic;\r\n function WantKey(Key: Integer; Shift: TShiftState): Boolean; virtual;\r\n function HintShow(var HintInfo: THintInfo): Boolean; reintroduce; dynamic;\r\n function HitTest(X, Y: Integer): Boolean; reintroduce; virtual;\r\n procedure MouseEnter(AControl: TControl); reintroduce; dynamic;\r\n procedure MouseLeave(AControl: TControl); reintroduce; dynamic;\r\n property MouseOver: Boolean read FMouseOver write FMouseOver;\r\n property HintColor: TColor read FHintColor write FHintColor default clDefault;\r\n property OnMouseEnter: TNotifyEvent read FOnMouseEnter write FOnMouseEnter;\r\n property OnMouseLeave: TNotifyEvent read FOnMouseLeave write FOnMouseLeave;\r\n property OnParentColorChange: TNotifyEvent read FOnParentColorChanged write FOnParentColorChanged;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n property HintWindowClass: THintWindowClass read FHintWindowClass write FHintWindowClass;\r\n published\r\n property AboutJVCL: TJVCLAboutInfo read FAboutJVCL write FAboutJVCL stored False;\r\n private\r\n FDotNetHighlighting: Boolean;\r\n protected\r\n procedure BoundsChanged; reintroduce; virtual;\r\n procedure CursorChanged; reintroduce; dynamic;\r\n procedure ShowingChanged; reintroduce; dynamic;\r\n procedure ShowHintChanged; reintroduce; dynamic;\r\n procedure ControlsListChanging(Control: TControl; Inserting: Boolean); reintroduce; dynamic;\r\n procedure ControlsListChanged(Control: TControl; Inserting: Boolean); reintroduce; dynamic;\r\n procedure GetDlgCode(var Code: TDlgCodes); virtual;\r\n procedure FocusSet(PrevWnd: THandle); virtual;\r\n procedure FocusKilled(NextWnd: THandle); virtual;\r\n function DoEraseBackground(Canvas: TCanvas; Param: LPARAM): Boolean; virtual;\r\n {$IFDEF JVCLThemesEnabledD6}\r\n private\r\n function GetParentBackground: Boolean;\r\n protected\r\n procedure SetParentBackground(Value: Boolean); virtual;\r\n property ParentBackground: Boolean read GetParentBackground write SetParentBackground;\r\n {$ENDIF JVCLThemesEnabledD6}\r\n published\r\n property DotNetHighlighting: Boolean read FDotNetHighlighting write FDotNetHighlighting default False;\r\n end;\r\n\r\n TJvExDateTimePicker = class(TDateTimePicker, IJvExControl)\r\n private\r\n FAboutJVCL: TJVCLAboutInfo;\r\n FHintColor: TColor;\r\n FMouseOver: Boolean;\r\n FHintWindowClass: THintWindowClass;\r\n FOnMouseEnter: TNotifyEvent;\r\n FOnMouseLeave: TNotifyEvent;\r\n FOnParentColorChanged: TNotifyEvent;\r\n function BaseWndProc(Msg: Cardinal; WParam: WPARAM = 0; LParam: LPARAM = 0): LRESULT; overload;\r\n function BaseWndProc(Msg: Cardinal; WParam: WPARAM; LParam: TObject): LRESULT; overload;\r\n function BaseWndProcEx(Msg: Cardinal; WParam: WPARAM; var StructLParam): LRESULT;\r\n protected\r\n procedure WndProc(var Msg: TMessage); override;\r\n procedure FocusChanged(AControl: TWinControl); dynamic;\r\n procedure VisibleChanged; reintroduce; dynamic;\r\n procedure EnabledChanged; reintroduce; dynamic;\r\n procedure TextChanged; reintroduce; virtual;\r\n procedure ColorChanged; reintroduce; dynamic;\r\n procedure FontChanged; reintroduce; dynamic;\r\n procedure ParentFontChanged; reintroduce; dynamic;\r\n procedure ParentColorChanged; reintroduce; dynamic;\r\n procedure ParentShowHintChanged; reintroduce; dynamic;\r\n function WantKey(Key: Integer; Shift: TShiftState): Boolean; virtual;\r\n function HintShow(var HintInfo: THintInfo): Boolean; reintroduce; dynamic;\r\n function HitTest(X, Y: Integer): Boolean; reintroduce; virtual;\r\n procedure MouseEnter(AControl: TControl); reintroduce; dynamic;\r\n procedure MouseLeave(AControl: TControl); reintroduce; dynamic;\r\n property MouseOver: Boolean read FMouseOver write FMouseOver;\r\n property HintColor: TColor read FHintColor write FHintColor default clDefault;\r\n property OnMouseEnter: TNotifyEvent read FOnMouseEnter write FOnMouseEnter;\r\n property OnMouseLeave: TNotifyEvent read FOnMouseLeave write FOnMouseLeave;\r\n property OnParentColorChange: TNotifyEvent read FOnParentColorChanged write FOnParentColorChanged;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n property HintWindowClass: THintWindowClass read FHintWindowClass write FHintWindowClass;\r\n published\r\n property AboutJVCL: TJVCLAboutInfo read FAboutJVCL write FAboutJVCL stored False;\r\n private\r\n FDotNetHighlighting: Boolean;\r\n protected\r\n procedure BoundsChanged; reintroduce; virtual;\r\n procedure CursorChanged; reintroduce; dynamic;\r\n procedure ShowingChanged; reintroduce; dynamic;\r\n procedure ShowHintChanged; reintroduce; dynamic;\r\n procedure ControlsListChanging(Control: TControl; Inserting: Boolean); reintroduce; dynamic;\r\n procedure ControlsListChanged(Control: TControl; Inserting: Boolean); reintroduce; dynamic;\r\n procedure GetDlgCode(var Code: TDlgCodes); virtual;\r\n procedure FocusSet(PrevWnd: THandle); virtual;\r\n procedure FocusKilled(NextWnd: THandle); virtual;\r\n function DoEraseBackground(Canvas: TCanvas; Param: LPARAM): Boolean; virtual;\r\n {$IFDEF JVCLThemesEnabledD6}\r\n private\r\n function GetParentBackground: Boolean;\r\n protected\r\n procedure SetParentBackground(Value: Boolean); virtual;\r\n property ParentBackground: Boolean read GetParentBackground write SetParentBackground;\r\n {$ENDIF JVCLThemesEnabledD6}\r\n published\r\n property DotNetHighlighting: Boolean read FDotNetHighlighting write FDotNetHighlighting default False;\r\n end;\r\n\r\n TJvExPageScroller = class(TPageScroller, IJvExControl)\r\n private\r\n FAboutJVCL: TJVCLAboutInfo;\r\n FHintColor: TColor;\r\n FMouseOver: Boolean;\r\n FHintWindowClass: THintWindowClass;\r\n FOnMouseEnter: TNotifyEvent;\r\n FOnMouseLeave: TNotifyEvent;\r\n FOnParentColorChanged: TNotifyEvent;\r\n function BaseWndProc(Msg: Cardinal; WParam: WPARAM = 0; LParam: LPARAM = 0): LRESULT; overload;\r\n function BaseWndProc(Msg: Cardinal; WParam: WPARAM; LParam: TObject): LRESULT; overload;\r\n function BaseWndProcEx(Msg: Cardinal; WParam: WPARAM; var StructLParam): LRESULT;\r\n protected\r\n procedure WndProc(var Msg: TMessage); override;\r\n procedure FocusChanged(AControl: TWinControl); dynamic;\r\n procedure VisibleChanged; reintroduce; dynamic;\r\n procedure EnabledChanged; reintroduce; dynamic;\r\n procedure TextChanged; reintroduce; virtual;\r\n procedure ColorChanged; reintroduce; dynamic;\r\n procedure FontChanged; reintroduce; dynamic;\r\n procedure ParentFontChanged; reintroduce; dynamic;\r\n procedure ParentColorChanged; reintroduce; dynamic;\r\n procedure ParentShowHintChanged; reintroduce; dynamic;\r\n function WantKey(Key: Integer; Shift: TShiftState): Boolean; virtual;\r\n function HintShow(var HintInfo: THintInfo): Boolean; reintroduce; dynamic;\r\n function HitTest(X, Y: Integer): Boolean; reintroduce; virtual;\r\n procedure MouseEnter(AControl: TControl); reintroduce; dynamic;\r\n procedure MouseLeave(AControl: TControl); reintroduce; dynamic;\r\n property MouseOver: Boolean read FMouseOver write FMouseOver;\r\n property HintColor: TColor read FHintColor write FHintColor default clDefault;\r\n property OnMouseEnter: TNotifyEvent read FOnMouseEnter write FOnMouseEnter;\r\n property OnMouseLeave: TNotifyEvent read FOnMouseLeave write FOnMouseLeave;\r\n property OnParentColorChange: TNotifyEvent read FOnParentColorChanged write FOnParentColorChanged;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n property HintWindowClass: THintWindowClass read FHintWindowClass write FHintWindowClass;\r\n published\r\n property AboutJVCL: TJVCLAboutInfo read FAboutJVCL write FAboutJVCL stored False;\r\n private\r\n FDotNetHighlighting: Boolean;\r\n protected\r\n procedure BoundsChanged; reintroduce; virtual;\r\n procedure CursorChanged; reintroduce; dynamic;\r\n procedure ShowingChanged; reintroduce; dynamic;\r\n procedure ShowHintChanged; reintroduce; dynamic;\r\n procedure ControlsListChanging(Control: TControl; Inserting: Boolean); reintroduce; dynamic;\r\n procedure ControlsListChanged(Control: TControl; Inserting: Boolean); reintroduce; dynamic;\r\n procedure GetDlgCode(var Code: TDlgCodes); virtual;\r\n procedure FocusSet(PrevWnd: THandle); virtual;\r\n procedure FocusKilled(NextWnd: THandle); virtual;\r\n function DoEraseBackground(Canvas: TCanvas; Param: LPARAM): Boolean; virtual;\r\n {$IFDEF JVCLThemesEnabledD6}\r\n private\r\n function GetParentBackground: Boolean;\r\n protected\r\n procedure SetParentBackground(Value: Boolean); virtual;\r\n property ParentBackground: Boolean read GetParentBackground write SetParentBackground;\r\n {$ENDIF JVCLThemesEnabledD6}\r\n published\r\n property DotNetHighlighting: Boolean read FDotNetHighlighting write FDotNetHighlighting default False;\r\n end;\r\n\r\n TJvExProgressBar = class(TProgressBar, IJvExControl)\r\n private\r\n FAboutJVCL: TJVCLAboutInfo;\r\n FHintColor: TColor;\r\n FMouseOver: Boolean;\r\n FHintWindowClass: THintWindowClass;\r\n FOnMouseEnter: TNotifyEvent;\r\n FOnMouseLeave: TNotifyEvent;\r\n FOnParentColorChanged: TNotifyEvent;\r\n function BaseWndProc(Msg: Cardinal; WParam: WPARAM = 0; LParam: LPARAM = 0): LRESULT; overload;\r\n function BaseWndProc(Msg: Cardinal; WParam: WPARAM; LParam: TObject): LRESULT; overload;\r\n function BaseWndProcEx(Msg: Cardinal; WParam: WPARAM; var StructLParam): LRESULT;\r\n protected\r\n procedure WndProc(var Msg: TMessage); override;\r\n procedure FocusChanged(AControl: TWinControl); dynamic;\r\n procedure VisibleChanged; reintroduce; dynamic;\r\n procedure EnabledChanged; reintroduce; dynamic;\r\n procedure TextChanged; reintroduce; virtual;\r\n procedure ColorChanged; reintroduce; dynamic;\r\n procedure FontChanged; reintroduce; dynamic;\r\n procedure ParentFontChanged; reintroduce; dynamic;\r\n procedure ParentColorChanged; reintroduce; dynamic;\r\n procedure ParentShowHintChanged; reintroduce; dynamic;\r\n function WantKey(Key: Integer; Shift: TShiftState): Boolean; virtual;\r\n function HintShow(var HintInfo: THintInfo): Boolean; reintroduce; dynamic;\r\n function HitTest(X, Y: Integer): Boolean; reintroduce; virtual;\r\n procedure MouseEnter(AControl: TControl); reintroduce; dynamic;\r\n procedure MouseLeave(AControl: TControl); reintroduce; dynamic;\r\n property MouseOver: Boolean read FMouseOver write FMouseOver;\r\n property HintColor: TColor read FHintColor write FHintColor default clDefault;\r\n property OnMouseEnter: TNotifyEvent read FOnMouseEnter write FOnMouseEnter;\r\n property OnMouseLeave: TNotifyEvent read FOnMouseLeave write FOnMouseLeave;\r\n property OnParentColorChange: TNotifyEvent read FOnParentColorChanged write FOnParentColorChanged;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n property HintWindowClass: THintWindowClass read FHintWindowClass write FHintWindowClass;\r\n published\r\n property AboutJVCL: TJVCLAboutInfo read FAboutJVCL write FAboutJVCL stored False;\r\n private\r\n FDotNetHighlighting: Boolean;\r\n protected\r\n procedure BoundsChanged; reintroduce; virtual;\r\n procedure CursorChanged; reintroduce; dynamic;\r\n procedure ShowingChanged; reintroduce; dynamic;\r\n procedure ShowHintChanged; reintroduce; dynamic;\r\n procedure ControlsListChanging(Control: TControl; Inserting: Boolean); reintroduce; dynamic;\r\n procedure ControlsListChanged(Control: TControl; Inserting: Boolean); reintroduce; dynamic;\r\n procedure GetDlgCode(var Code: TDlgCodes); virtual;\r\n procedure FocusSet(PrevWnd: THandle); virtual;\r\n procedure FocusKilled(NextWnd: THandle); virtual;\r\n function DoEraseBackground(Canvas: TCanvas; Param: LPARAM): Boolean; virtual;\r\n {$IFDEF JVCLThemesEnabledD6}\r\n private\r\n function GetParentBackground: Boolean;\r\n protected\r\n procedure SetParentBackground(Value: Boolean); virtual;\r\n property ParentBackground: Boolean read GetParentBackground write SetParentBackground;\r\n {$ENDIF JVCLThemesEnabledD6}\r\n published\r\n property DotNetHighlighting: Boolean read FDotNetHighlighting write FDotNetHighlighting default False;\r\n end;\r\n\r\n TJvExStatusBar = class(TStatusBar, IJvExControl)\r\n private\r\n FAboutJVCL: TJVCLAboutInfo;\r\n FHintColor: TColor;\r\n FMouseOver: Boolean;\r\n FHintWindowClass: THintWindowClass;\r\n FOnMouseEnter: TNotifyEvent;\r\n FOnMouseLeave: TNotifyEvent;\r\n FOnParentColorChanged: TNotifyEvent;\r\n function BaseWndProc(Msg: Cardinal; WParam: WPARAM = 0; LParam: LPARAM = 0): LRESULT; overload;\r\n function BaseWndProc(Msg: Cardinal; WParam: WPARAM; LParam: TObject): LRESULT; overload;\r\n function BaseWndProcEx(Msg: Cardinal; WParam: WPARAM; var StructLParam): LRESULT;\r\n protected\r\n procedure WndProc(var Msg: TMessage); override;\r\n procedure FocusChanged(AControl: TWinControl); dynamic;\r\n procedure VisibleChanged; reintroduce; dynamic;\r\n procedure EnabledChanged; reintroduce; dynamic;\r\n procedure TextChanged; reintroduce; virtual;\r\n procedure ColorChanged; reintroduce; dynamic;\r\n procedure FontChanged; reintroduce; dynamic;\r\n procedure ParentFontChanged; reintroduce; dynamic;\r\n procedure ParentColorChanged; reintroduce; dynamic;\r\n procedure ParentShowHintChanged; reintroduce; dynamic;\r\n function WantKey(Key: Integer; Shift: TShiftState): Boolean; virtual;\r\n function HintShow(var HintInfo: THintInfo): Boolean; reintroduce; dynamic;\r\n function HitTest(X, Y: Integer): Boolean; reintroduce; virtual;\r\n procedure MouseEnter(AControl: TControl); reintroduce; dynamic;\r\n procedure MouseLeave(AControl: TControl); reintroduce; dynamic;\r\n property MouseOver: Boolean read FMouseOver write FMouseOver;\r\n property HintColor: TColor read FHintColor write FHintColor default clDefault;\r\n property OnMouseEnter: TNotifyEvent read FOnMouseEnter write FOnMouseEnter;\r\n property OnMouseLeave: TNotifyEvent read FOnMouseLeave write FOnMouseLeave;\r\n property OnParentColorChange: TNotifyEvent read FOnParentColorChanged write FOnParentColorChanged;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n property HintWindowClass: THintWindowClass read FHintWindowClass write FHintWindowClass;\r\n published\r\n property AboutJVCL: TJVCLAboutInfo read FAboutJVCL write FAboutJVCL stored False;\r\n private\r\n FDotNetHighlighting: Boolean;\r\n protected\r\n procedure BoundsChanged; reintroduce; virtual;\r\n procedure CursorChanged; reintroduce; dynamic;\r\n procedure ShowingChanged; reintroduce; dynamic;\r\n procedure ShowHintChanged; reintroduce; dynamic;\r\n procedure ControlsListChanging(Control: TControl; Inserting: Boolean); reintroduce; dynamic;\r\n procedure ControlsListChanged(Control: TControl; Inserting: Boolean); reintroduce; dynamic;\r\n procedure GetDlgCode(var Code: TDlgCodes); virtual;\r\n procedure FocusSet(PrevWnd: THandle); virtual;\r\n procedure FocusKilled(NextWnd: THandle); virtual;\r\n function DoEraseBackground(Canvas: TCanvas; Param: LPARAM): Boolean; virtual;\r\n {$IFDEF JVCLThemesEnabledD6}\r\n private\r\n function GetParentBackground: Boolean;\r\n protected\r\n procedure SetParentBackground(Value: Boolean); virtual;\r\n property ParentBackground: Boolean read GetParentBackground write SetParentBackground;\r\n {$ENDIF JVCLThemesEnabledD6}\r\n published\r\n property DotNetHighlighting: Boolean read FDotNetHighlighting write FDotNetHighlighting default False;\r\n end;\r\n\r\n TJvExTabSheet = class(TTabSheet, IJvExControl)\r\n private\r\n FAboutJVCL: TJVCLAboutInfo;\r\n FHintColor: TColor;\r\n FMouseOver: Boolean;\r\n FHintWindowClass: THintWindowClass;\r\n FOnMouseEnter: TNotifyEvent;\r\n FOnMouseLeave: TNotifyEvent;\r\n FOnParentColorChanged: TNotifyEvent;\r\n function BaseWndProc(Msg: Cardinal; WParam: WPARAM = 0; LParam: LPARAM = 0): LRESULT; overload;\r\n function BaseWndProc(Msg: Cardinal; WParam: WPARAM; LParam: TObject): LRESULT; overload;\r\n function BaseWndProcEx(Msg: Cardinal; WParam: WPARAM; var StructLParam): LRESULT;\r\n protected\r\n procedure WndProc(var Msg: TMessage); override;\r\n procedure FocusChanged(AControl: TWinControl); dynamic;\r\n procedure VisibleChanged; reintroduce; dynamic;\r\n procedure EnabledChanged; reintroduce; dynamic;\r\n procedure TextChanged; reintroduce; virtual;\r\n procedure ColorChanged; reintroduce; dynamic;\r\n procedure FontChanged; reintroduce; dynamic;\r\n procedure ParentFontChanged; reintroduce; dynamic;\r\n procedure ParentColorChanged; reintroduce; dynamic;\r\n procedure ParentShowHintChanged; reintroduce; dynamic;\r\n function WantKey(Key: Integer; Shift: TShiftState): Boolean; virtual;\r\n function HintShow(var HintInfo: THintInfo): Boolean; reintroduce; dynamic;\r\n function HitTest(X, Y: Integer): Boolean; reintroduce; virtual;\r\n procedure MouseEnter(AControl: TControl); reintroduce; dynamic;\r\n procedure MouseLeave(AControl: TControl); reintroduce; dynamic;\r\n property MouseOver: Boolean read FMouseOver write FMouseOver;\r\n property HintColor: TColor read FHintColor write FHintColor default clDefault;\r\n property OnMouseEnter: TNotifyEvent read FOnMouseEnter write FOnMouseEnter;\r\n property OnMouseLeave: TNotifyEvent read FOnMouseLeave write FOnMouseLeave;\r\n property OnParentColorChange: TNotifyEvent read FOnParentColorChanged write FOnParentColorChanged;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n property HintWindowClass: THintWindowClass read FHintWindowClass write FHintWindowClass;\r\n published\r\n property AboutJVCL: TJVCLAboutInfo read FAboutJVCL write FAboutJVCL stored False;\r\n private\r\n FDotNetHighlighting: Boolean;\r\n protected\r\n procedure BoundsChanged; reintroduce; virtual;\r\n procedure CursorChanged; reintroduce; dynamic;\r\n procedure ShowingChanged; reintroduce; dynamic;\r\n procedure ShowHintChanged; reintroduce; dynamic;\r\n procedure ControlsListChanging(Control: TControl; Inserting: Boolean); reintroduce; dynamic;\r\n procedure ControlsListChanged(Control: TControl; Inserting: Boolean); reintroduce; dynamic;\r\n procedure GetDlgCode(var Code: TDlgCodes); virtual;\r\n procedure FocusSet(PrevWnd: THandle); virtual;\r\n procedure FocusKilled(NextWnd: THandle); virtual;\r\n function DoEraseBackground(Canvas: TCanvas; Param: LPARAM): Boolean; virtual;\r\n {$IFDEF JVCLThemesEnabledD6}\r\n private\r\n function GetParentBackground: Boolean;\r\n protected\r\n procedure SetParentBackground(Value: Boolean); virtual;\r\n property ParentBackground: Boolean read GetParentBackground write SetParentBackground;\r\n {$ENDIF JVCLThemesEnabledD6}\r\n published\r\n property DotNetHighlighting: Boolean read FDotNetHighlighting write FDotNetHighlighting default False;\r\n end;\r\n\r\n TJvExToolBar = class(TToolBar, IJvExControl)\r\n private\r\n FAboutJVCL: TJVCLAboutInfo;\r\n FHintColor: TColor;\r\n FMouseOver: Boolean;\r\n FHintWindowClass: THintWindowClass;\r\n FOnMouseEnter: TNotifyEvent;\r\n FOnMouseLeave: TNotifyEvent;\r\n FOnParentColorChanged: TNotifyEvent;\r\n function BaseWndProc(Msg: Cardinal; WParam: WPARAM = 0; LParam: LPARAM = 0): LRESULT; overload;\r\n function BaseWndProc(Msg: Cardinal; WParam: WPARAM; LParam: TObject): LRESULT; overload;\r\n function BaseWndProcEx(Msg: Cardinal; WParam: WPARAM; var StructLParam): LRESULT;\r\n protected\r\n procedure WndProc(var Msg: TMessage); override;\r\n procedure FocusChanged(AControl: TWinControl); dynamic;\r\n procedure VisibleChanged; reintroduce; dynamic;\r\n procedure EnabledChanged; reintroduce; dynamic;\r\n procedure TextChanged; reintroduce; virtual;\r\n procedure ColorChanged; reintroduce; dynamic;\r\n procedure FontChanged; reintroduce; dynamic;\r\n procedure ParentFontChanged; reintroduce; dynamic;\r\n procedure ParentColorChanged; reintroduce; dynamic;\r\n procedure ParentShowHintChanged; reintroduce; dynamic;\r\n function WantKey(Key: Integer; Shift: TShiftState): Boolean; virtual;\r\n function HintShow(var HintInfo: THintInfo): Boolean; reintroduce; dynamic;\r\n function HitTest(X, Y: Integer): Boolean; reintroduce; virtual;\r\n procedure MouseEnter(AControl: TControl); reintroduce; dynamic;\r\n procedure MouseLeave(AControl: TControl); reintroduce; dynamic;\r\n property MouseOver: Boolean read FMouseOver write FMouseOver;\r\n property HintColor: TColor read FHintColor write FHintColor default clDefault;\r\n property OnMouseEnter: TNotifyEvent read FOnMouseEnter write FOnMouseEnter;\r\n property OnMouseLeave: TNotifyEvent read FOnMouseLeave write FOnMouseLeave;\r\n property OnParentColorChange: TNotifyEvent read FOnParentColorChanged write FOnParentColorChanged;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n property HintWindowClass: THintWindowClass read FHintWindowClass write FHintWindowClass;\r\n published\r\n property AboutJVCL: TJVCLAboutInfo read FAboutJVCL write FAboutJVCL stored False;\r\n private\r\n FDotNetHighlighting: Boolean;\r\n protected\r\n procedure BoundsChanged; reintroduce; virtual;\r\n procedure CursorChanged; reintroduce; dynamic;\r\n procedure ShowingChanged; reintroduce; dynamic;\r\n procedure ShowHintChanged; reintroduce; dynamic;\r\n procedure ControlsListChanging(Control: TControl; Inserting: Boolean); reintroduce; dynamic;\r\n procedure ControlsListChanged(Control: TControl; Inserting: Boolean); reintroduce; dynamic;\r\n procedure GetDlgCode(var Code: TDlgCodes); virtual;\r\n procedure FocusSet(PrevWnd: THandle); virtual;\r\n procedure FocusKilled(NextWnd: THandle); virtual;\r\n function DoEraseBackground(Canvas: TCanvas; Param: LPARAM): Boolean; virtual;\r\n {$IFDEF JVCLThemesEnabledD6}\r\n private\r\n function GetParentBackground: Boolean;\r\n protected\r\n procedure SetParentBackground(Value: Boolean); virtual;\r\n property ParentBackground: Boolean read GetParentBackground write SetParentBackground;\r\n {$ENDIF JVCLThemesEnabledD6}\r\n published\r\n property DotNetHighlighting: Boolean read FDotNetHighlighting write FDotNetHighlighting default False;\r\n end;\r\n\r\n TJvExToolButton = class(TToolButton, IJvExControl)\r\n private\r\n FAboutJVCL: TJVCLAboutInfo;\r\n FHintColor: TColor;\r\n FMouseOver: Boolean;\r\n FHintWindowClass: THintWindowClass;\r\n FOnMouseEnter: TNotifyEvent;\r\n FOnMouseLeave: TNotifyEvent;\r\n FOnParentColorChanged: TNotifyEvent;\r\n function BaseWndProc(Msg: Cardinal; WParam: WPARAM = 0; LParam: LPARAM = 0): LRESULT; overload;\r\n function BaseWndProc(Msg: Cardinal; WParam: WPARAM; LParam: TObject): LRESULT; overload;\r\n function BaseWndProcEx(Msg: Cardinal; WParam: WPARAM; var StructLParam): LRESULT;\r\n protected\r\n procedure WndProc(var Msg: TMessage); override;\r\n procedure FocusChanged(AControl: TWinControl); dynamic;\r\n procedure VisibleChanged; reintroduce; dynamic;\r\n procedure EnabledChanged; reintroduce; dynamic;\r\n procedure TextChanged; reintroduce; virtual;\r\n procedure ColorChanged; reintroduce; dynamic;\r\n procedure FontChanged; reintroduce; dynamic;\r\n procedure ParentFontChanged; reintroduce; dynamic;\r\n procedure ParentColorChanged; reintroduce; dynamic;\r\n procedure ParentShowHintChanged; reintroduce; dynamic;\r\n function WantKey(Key: Integer; Shift: TShiftState): Boolean; virtual;\r\n function HintShow(var HintInfo: THintInfo): Boolean; reintroduce; dynamic;\r\n function HitTest(X, Y: Integer): Boolean; reintroduce; virtual;\r\n procedure MouseEnter(AControl: TControl); reintroduce; dynamic;\r\n procedure MouseLeave(AControl: TControl); reintroduce; dynamic;\r\n property MouseOver: Boolean read FMouseOver write FMouseOver;\r\n property HintColor: TColor read FHintColor write FHintColor default clDefault;\r\n property OnMouseEnter: TNotifyEvent read FOnMouseEnter write FOnMouseEnter;\r\n property OnMouseLeave: TNotifyEvent read FOnMouseLeave write FOnMouseLeave;\r\n property OnParentColorChange: TNotifyEvent read FOnParentColorChanged write FOnParentColorChanged;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n property HintWindowClass: THintWindowClass read FHintWindowClass write FHintWindowClass;\r\n published\r\n property AboutJVCL: TJVCLAboutInfo read FAboutJVCL write FAboutJVCL stored False;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvExComCtrls.pas $';\r\n Revision: '$Revision: 13173 $';\r\n Date: '$Date: 2011-11-19 13:43:58 +0100 (sam. 19 nov. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nconstructor TJvExCustomComboBoxEx.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FHintColor := clDefault;\r\nend;\r\n\r\nfunction TJvExCustomComboBoxEx.BaseWndProc(Msg: Cardinal; WParam: WPARAM = 0; LParam: LPARAM = 0): LRESULT;\r\nvar\r\n Mesg: TMessage;\r\nbegin\r\n CreateWMMessage(Mesg, Msg, WParam, LParam);\r\n inherited WndProc(Mesg);\r\n Result := Mesg.Result;\r\nend;\r\n\r\nfunction TJvExCustomComboBoxEx.BaseWndProc(Msg: Cardinal; WParam: WPARAM; LParam: TObject): LRESULT;\r\nbegin\r\n Result := BaseWndProc(Msg, WParam, Windows.LPARAM(LParam));\r\nend;\r\n\r\nfunction TJvExCustomComboBoxEx.BaseWndProcEx(Msg: Cardinal; WParam: WPARAM; var StructLParam): LRESULT;\r\nbegin\r\n Result := BaseWndProc(Msg, WParam, Windows.LPARAM(@StructLParam));\r\nend;\r\n\r\nprocedure TJvExCustomComboBoxEx.VisibleChanged;\r\nbegin\r\n BaseWndProc(CM_VISIBLECHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomComboBoxEx.EnabledChanged;\r\nbegin\r\n BaseWndProc(CM_ENABLEDCHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomComboBoxEx.TextChanged;\r\nbegin\r\n BaseWndProc(CM_TEXTCHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomComboBoxEx.FontChanged;\r\nbegin\r\n BaseWndProc(CM_FONTCHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomComboBoxEx.ColorChanged;\r\nbegin\r\n BaseWndProc(CM_COLORCHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomComboBoxEx.ParentFontChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTFONTCHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomComboBoxEx.ParentColorChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTCOLORCHANGED);\r\n if Assigned(OnParentColorChange) then\r\n OnParentColorChange(Self);\r\nend;\r\n\r\nprocedure TJvExCustomComboBoxEx.ParentShowHintChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTSHOWHINTCHANGED);\r\nend;\r\n\r\nfunction TJvExCustomComboBoxEx.WantKey(Key: Integer; Shift: TShiftState): Boolean;\r\nbegin\r\n Result := BaseWndProc(CM_DIALOGCHAR, Word(Key), ShiftStateToKeyData(Shift)) <> 0;\r\nend;\r\n\r\nfunction TJvExCustomComboBoxEx.HitTest(X, Y: Integer): Boolean;\r\nbegin\r\n Result := BaseWndProc(CM_HITTEST, 0, SmallPointToLong(PointToSmallPoint(Point(X, Y)))) <> 0;\r\nend;\r\n\r\nfunction TJvExCustomComboBoxEx.HintShow(var HintInfo: THintInfo): Boolean;\r\nbegin\r\n GetHintColor(HintInfo, Self, FHintColor);\r\n if FHintWindowClass <> nil then\r\n HintInfo.HintWindowClass := FHintWindowClass;\r\n Result := BaseWndProcEx(CM_HINTSHOW, 0, HintInfo) <> 0;\r\nend;\r\n\r\nprocedure TJvExCustomComboBoxEx.MouseEnter(AControl: TControl);\r\nbegin\r\n FMouseOver := True;\r\n if Assigned(FOnMouseEnter) then\r\n FOnMouseEnter(Self);\r\n BaseWndProc(CM_MOUSEENTER, 0, AControl);\r\nend;\r\n\r\nprocedure TJvExCustomComboBoxEx.MouseLeave(AControl: TControl);\r\nbegin\r\n FMouseOver := False;\r\n BaseWndProc(CM_MOUSELEAVE, 0, AControl);\r\n if Assigned(FOnMouseLeave) then\r\n FOnMouseLeave(Self);\r\nend;\r\n\r\nprocedure TJvExCustomComboBoxEx.FocusChanged(AControl: TWinControl);\r\nbegin\r\n BaseWndProc(CM_FOCUSCHANGED, 0, AControl);\r\nend;\r\n\r\nprocedure TJvExCustomComboBoxEx.BoundsChanged;\r\nbegin\r\nend;\r\n\r\nprocedure TJvExCustomComboBoxEx.CursorChanged;\r\nbegin\r\n BaseWndProc(CM_CURSORCHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomComboBoxEx.ShowingChanged;\r\nbegin\r\n BaseWndProc(CM_SHOWINGCHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomComboBoxEx.ShowHintChanged;\r\nbegin\r\n BaseWndProc(CM_SHOWHINTCHANGED);\r\nend;\r\n\r\n{ VCL sends CM_CONTROLLISTCHANGE and CM_CONTROLCHANGE in a different order than\r\n the CLX methods are used. So we must correct it by evaluating \"Inserting\". }\r\nprocedure TJvExCustomComboBoxEx.ControlsListChanging(Control: TControl; Inserting: Boolean);\r\nbegin\r\n if Inserting then\r\n BaseWndProc(CM_CONTROLLISTCHANGE, WPARAM(Control), LPARAM(Inserting))\r\n else\r\n BaseWndProc(CM_CONTROLCHANGE, WPARAM(Control), LPARAM(Inserting));\r\nend;\r\n\r\nprocedure TJvExCustomComboBoxEx.ControlsListChanged(Control: TControl; Inserting: Boolean);\r\nbegin\r\n if not Inserting then\r\n BaseWndProc(CM_CONTROLLISTCHANGE, WPARAM(Control), LPARAM(Inserting))\r\n else\r\n BaseWndProc(CM_CONTROLCHANGE, WPARAM(Control), LPARAM(Inserting));\r\nend;\r\n\r\nprocedure TJvExCustomComboBoxEx.GetDlgCode(var Code: TDlgCodes);\r\nbegin\r\nend;\r\n\r\nprocedure TJvExCustomComboBoxEx.FocusSet(PrevWnd: THandle);\r\nbegin\r\n BaseWndProc(WM_SETFOCUS, WPARAM(PrevWnd), 0);\r\nend;\r\n\r\nprocedure TJvExCustomComboBoxEx.FocusKilled(NextWnd: THandle);\r\nbegin\r\n BaseWndProc(WM_KILLFOCUS, WPARAM(NextWnd), 0);\r\nend;\r\n\r\nfunction TJvExCustomComboBoxEx.DoEraseBackground(Canvas: TCanvas; Param: LPARAM): Boolean;\r\nbegin\r\n Result := BaseWndProc(WM_ERASEBKGND, Canvas.Handle, Param) <> 0;\r\nend;\r\n\r\n{$IFDEF JVCLThemesEnabledD6}\r\nfunction TJvExCustomComboBoxEx.GetParentBackground: Boolean;\r\nbegin\r\n Result := JvThemes.GetParentBackground(Self);\r\nend;\r\n\r\nprocedure TJvExCustomComboBoxEx.SetParentBackground(Value: Boolean);\r\nbegin\r\n JvThemes.SetParentBackground(Self, Value);\r\nend;\r\n{$ENDIF JVCLThemesEnabledD6}\r\n\r\nprocedure TJvExCustomComboBoxEx.WndProc(var Msg: TMessage);\r\nvar\r\n IdSaveDC: Integer;\r\n DlgCodes: TDlgCodes;\r\n Canvas: TCanvas;\r\nbegin\r\n if not DispatchIsDesignMsg(Self, Msg) then\r\n begin\r\n case Msg.Msg of\r\n CM_DENYSUBCLASSING:\r\n Msg.Result := LRESULT(Ord(GetInterfaceEntry(IJvDenySubClassing) <> nil));\r\n CM_DIALOGCHAR:\r\n with TCMDialogChar{$IFDEF CLR}.Create{$ENDIF}(Msg) do\r\n Result := LRESULT(Ord(WantKey(CharCode, KeyDataToShiftState(KeyData))));\r\n CM_HINTSHOW:\r\n with TCMHintShow(Msg) do\r\n Result := LRESULT(HintShow(HintInfo^));\r\n CM_HITTEST:\r\n with TCMHitTest(Msg) do\r\n Result := LRESULT(HitTest(XPos, YPos));\r\n CM_MOUSEENTER:\r\n MouseEnter(TControl(Msg.LParam));\r\n CM_MOUSELEAVE:\r\n MouseLeave(TControl(Msg.LParam));\r\n CM_VISIBLECHANGED:\r\n VisibleChanged;\r\n CM_ENABLEDCHANGED:\r\n EnabledChanged;\r\n CM_TEXTCHANGED:\r\n TextChanged;\r\n CM_FONTCHANGED:\r\n FontChanged;\r\n CM_COLORCHANGED:\r\n ColorChanged;\r\n CM_FOCUSCHANGED:\r\n FocusChanged(TWinControl(Msg.LParam));\r\n CM_PARENTFONTCHANGED:\r\n ParentFontChanged;\r\n CM_PARENTCOLORCHANGED:\r\n ParentColorChanged;\r\n CM_PARENTSHOWHINTCHANGED:\r\n ParentShowHintChanged;\r\n CM_CURSORCHANGED:\r\n CursorChanged;\r\n CM_SHOWINGCHANGED:\r\n ShowingChanged;\r\n CM_SHOWHINTCHANGED:\r\n ShowHintChanged;\r\n CM_CONTROLLISTCHANGE:\r\n if Msg.LParam <> 0 then\r\n ControlsListChanging(TControl(Msg.WParam), True)\r\n else\r\n ControlsListChanged(TControl(Msg.WParam), False);\r\n CM_CONTROLCHANGE:\r\n if Msg.LParam = 0 then\r\n ControlsListChanging(TControl(Msg.WParam), False)\r\n else\r\n ControlsListChanged(TControl(Msg.WParam), True);\r\n WM_SETFOCUS:\r\n FocusSet(THandle(Msg.WParam));\r\n WM_KILLFOCUS:\r\n FocusKilled(THandle(Msg.WParam));\r\n WM_SIZE, WM_MOVE:\r\n begin\r\n inherited WndProc(Msg);\r\n BoundsChanged;\r\n end;\r\n WM_ERASEBKGND:\r\n if (Msg.WParam <> 0) and not IsDefaultEraseBackground(DoEraseBackground, @TJvExCustomComboBoxEx.DoEraseBackground) then\r\n begin\r\n IdSaveDC := SaveDC(HDC(Msg.WParam)); // protect DC against Stock-Objects from Canvas\r\n Canvas := TCanvas.Create;\r\n try\r\n Canvas.Handle := HDC(Msg.WParam);\r\n Msg.Result := Ord(DoEraseBackground(Canvas, Msg.LParam));\r\n finally\r\n Canvas.Handle := 0;\r\n Canvas.Free;\r\n RestoreDC(HDC(Msg.WParam), IdSaveDC);\r\n end;\r\n end\r\n else\r\n inherited WndProc(Msg);\r\n {$IFNDEF DELPHI2007_UP}\r\n WM_PRINTCLIENT, WM_PRINT: // VCL bug fix\r\n begin\r\n IdSaveDC := SaveDC(HDC(Msg.WParam)); // protect DC against changes\r\n try\r\n inherited WndProc(Msg);\r\n finally\r\n RestoreDC(HDC(Msg.WParam), IdSaveDC);\r\n end;\r\n end;\r\n {$ENDIF ~DELPHI2007_UP}\r\n WM_GETDLGCODE:\r\n begin\r\n inherited WndProc(Msg);\r\n DlgCodes := [dcNative] + DlgcToDlgCodes(Msg.Result);\r\n GetDlgCode(DlgCodes);\r\n if not (dcNative in DlgCodes) then\r\n Msg.Result := DlgCodesToDlgc(DlgCodes);\r\n end;\r\n else\r\n inherited WndProc(Msg);\r\n end;\r\n case Msg.Msg of // precheck message to prevent access violations on released controls\r\n CM_MOUSEENTER, CM_MOUSELEAVE, WM_KILLFOCUS, WM_SETFOCUS, WM_NCPAINT:\r\n if DotNetHighlighting then\r\n HandleDotNetHighlighting(Self, Msg, MouseOver, Color);\r\n end;\r\n end;\r\nend;\r\n\r\n//============================================================================\r\n\r\nconstructor TJvExCustomStatusBar.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FHintColor := clDefault;\r\nend;\r\n\r\nfunction TJvExCustomStatusBar.BaseWndProc(Msg: Cardinal; WParam: WPARAM = 0; LParam: LPARAM = 0): LRESULT;\r\nvar\r\n Mesg: TMessage;\r\nbegin\r\n CreateWMMessage(Mesg, Msg, WParam, LParam);\r\n inherited WndProc(Mesg);\r\n Result := Mesg.Result;\r\nend;\r\n\r\nfunction TJvExCustomStatusBar.BaseWndProc(Msg: Cardinal; WParam: WPARAM; LParam: TObject): LRESULT;\r\nbegin\r\n Result := BaseWndProc(Msg, WParam, Windows.LPARAM(LParam));\r\nend;\r\n\r\nfunction TJvExCustomStatusBar.BaseWndProcEx(Msg: Cardinal; WParam: WPARAM; var StructLParam): LRESULT;\r\nbegin\r\n Result := BaseWndProc(Msg, WParam, Windows.LPARAM(@StructLParam));\r\nend;\r\n\r\nprocedure TJvExCustomStatusBar.VisibleChanged;\r\nbegin\r\n BaseWndProc(CM_VISIBLECHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomStatusBar.EnabledChanged;\r\nbegin\r\n BaseWndProc(CM_ENABLEDCHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomStatusBar.TextChanged;\r\nbegin\r\n BaseWndProc(CM_TEXTCHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomStatusBar.FontChanged;\r\nbegin\r\n BaseWndProc(CM_FONTCHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomStatusBar.ColorChanged;\r\nbegin\r\n BaseWndProc(CM_COLORCHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomStatusBar.ParentFontChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTFONTCHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomStatusBar.ParentColorChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTCOLORCHANGED);\r\n if Assigned(OnParentColorChange) then\r\n OnParentColorChange(Self);\r\nend;\r\n\r\nprocedure TJvExCustomStatusBar.ParentShowHintChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTSHOWHINTCHANGED);\r\nend;\r\n\r\nfunction TJvExCustomStatusBar.WantKey(Key: Integer; Shift: TShiftState): Boolean;\r\nbegin\r\n Result := BaseWndProc(CM_DIALOGCHAR, Word(Key), ShiftStateToKeyData(Shift)) <> 0;\r\nend;\r\n\r\nfunction TJvExCustomStatusBar.HitTest(X, Y: Integer): Boolean;\r\nbegin\r\n Result := BaseWndProc(CM_HITTEST, 0, SmallPointToLong(PointToSmallPoint(Point(X, Y)))) <> 0;\r\nend;\r\n\r\nfunction TJvExCustomStatusBar.HintShow(var HintInfo: THintInfo): Boolean;\r\nbegin\r\n GetHintColor(HintInfo, Self, FHintColor);\r\n if FHintWindowClass <> nil then\r\n HintInfo.HintWindowClass := FHintWindowClass;\r\n Result := BaseWndProcEx(CM_HINTSHOW, 0, HintInfo) <> 0;\r\nend;\r\n\r\nprocedure TJvExCustomStatusBar.MouseEnter(AControl: TControl);\r\nbegin\r\n FMouseOver := True;\r\n if Assigned(FOnMouseEnter) then\r\n FOnMouseEnter(Self);\r\n BaseWndProc(CM_MOUSEENTER, 0, AControl);\r\nend;\r\n\r\nprocedure TJvExCustomStatusBar.MouseLeave(AControl: TControl);\r\nbegin\r\n FMouseOver := False;\r\n BaseWndProc(CM_MOUSELEAVE, 0, AControl);\r\n if Assigned(FOnMouseLeave) then\r\n FOnMouseLeave(Self);\r\nend;\r\n\r\nprocedure TJvExCustomStatusBar.FocusChanged(AControl: TWinControl);\r\nbegin\r\n BaseWndProc(CM_FOCUSCHANGED, 0, AControl);\r\nend;\r\n\r\nprocedure TJvExCustomStatusBar.BoundsChanged;\r\nbegin\r\nend;\r\n\r\nprocedure TJvExCustomStatusBar.CursorChanged;\r\nbegin\r\n BaseWndProc(CM_CURSORCHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomStatusBar.ShowingChanged;\r\nbegin\r\n BaseWndProc(CM_SHOWINGCHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomStatusBar.ShowHintChanged;\r\nbegin\r\n BaseWndProc(CM_SHOWHINTCHANGED);\r\nend;\r\n\r\n{ VCL sends CM_CONTROLLISTCHANGE and CM_CONTROLCHANGE in a different order than\r\n the CLX methods are used. So we must correct it by evaluating \"Inserting\". }\r\nprocedure TJvExCustomStatusBar.ControlsListChanging(Control: TControl; Inserting: Boolean);\r\nbegin\r\n if Inserting then\r\n BaseWndProc(CM_CONTROLLISTCHANGE, WPARAM(Control), LPARAM(Inserting))\r\n else\r\n BaseWndProc(CM_CONTROLCHANGE, WPARAM(Control), LPARAM(Inserting));\r\nend;\r\n\r\nprocedure TJvExCustomStatusBar.ControlsListChanged(Control: TControl; Inserting: Boolean);\r\nbegin\r\n if not Inserting then\r\n BaseWndProc(CM_CONTROLLISTCHANGE, WPARAM(Control), LPARAM(Inserting))\r\n else\r\n BaseWndProc(CM_CONTROLCHANGE, WPARAM(Control), LPARAM(Inserting));\r\nend;\r\n\r\nprocedure TJvExCustomStatusBar.GetDlgCode(var Code: TDlgCodes);\r\nbegin\r\nend;\r\n\r\nprocedure TJvExCustomStatusBar.FocusSet(PrevWnd: THandle);\r\nbegin\r\n BaseWndProc(WM_SETFOCUS, WPARAM(PrevWnd), 0);\r\nend;\r\n\r\nprocedure TJvExCustomStatusBar.FocusKilled(NextWnd: THandle);\r\nbegin\r\n BaseWndProc(WM_KILLFOCUS, WPARAM(NextWnd), 0);\r\nend;\r\n\r\nfunction TJvExCustomStatusBar.DoEraseBackground(Canvas: TCanvas; Param: LPARAM): Boolean;\r\nbegin\r\n Result := BaseWndProc(WM_ERASEBKGND, Canvas.Handle, Param) <> 0;\r\nend;\r\n\r\n{$IFDEF JVCLThemesEnabledD6}\r\nfunction TJvExCustomStatusBar.GetParentBackground: Boolean;\r\nbegin\r\n Result := JvThemes.GetParentBackground(Self);\r\nend;\r\n\r\nprocedure TJvExCustomStatusBar.SetParentBackground(Value: Boolean);\r\nbegin\r\n JvThemes.SetParentBackground(Self, Value);\r\nend;\r\n{$ENDIF JVCLThemesEnabledD6}\r\n\r\nprocedure TJvExCustomStatusBar.WndProc(var Msg: TMessage);\r\nvar\r\n IdSaveDC: Integer;\r\n DlgCodes: TDlgCodes;\r\n Canvas: TCanvas;\r\nbegin\r\n if not DispatchIsDesignMsg(Self, Msg) then\r\n begin\r\n case Msg.Msg of\r\n CM_DENYSUBCLASSING:\r\n Msg.Result := LRESULT(Ord(GetInterfaceEntry(IJvDenySubClassing) <> nil));\r\n CM_DIALOGCHAR:\r\n with TCMDialogChar{$IFDEF CLR}.Create{$ENDIF}(Msg) do\r\n Result := LRESULT(Ord(WantKey(CharCode, KeyDataToShiftState(KeyData))));\r\n CM_HINTSHOW:\r\n with TCMHintShow(Msg) do\r\n Result := LRESULT(HintShow(HintInfo^));\r\n CM_HITTEST:\r\n with TCMHitTest(Msg) do\r\n Result := LRESULT(HitTest(XPos, YPos));\r\n CM_MOUSEENTER:\r\n MouseEnter(TControl(Msg.LParam));\r\n CM_MOUSELEAVE:\r\n MouseLeave(TControl(Msg.LParam));\r\n CM_VISIBLECHANGED:\r\n VisibleChanged;\r\n CM_ENABLEDCHANGED:\r\n EnabledChanged;\r\n CM_TEXTCHANGED:\r\n TextChanged;\r\n CM_FONTCHANGED:\r\n FontChanged;\r\n CM_COLORCHANGED:\r\n ColorChanged;\r\n CM_FOCUSCHANGED:\r\n FocusChanged(TWinControl(Msg.LParam));\r\n CM_PARENTFONTCHANGED:\r\n ParentFontChanged;\r\n CM_PARENTCOLORCHANGED:\r\n ParentColorChanged;\r\n CM_PARENTSHOWHINTCHANGED:\r\n ParentShowHintChanged;\r\n CM_CURSORCHANGED:\r\n CursorChanged;\r\n CM_SHOWINGCHANGED:\r\n ShowingChanged;\r\n CM_SHOWHINTCHANGED:\r\n ShowHintChanged;\r\n CM_CONTROLLISTCHANGE:\r\n if Msg.LParam <> 0 then\r\n ControlsListChanging(TControl(Msg.WParam), True)\r\n else\r\n ControlsListChanged(TControl(Msg.WParam), False);\r\n CM_CONTROLCHANGE:\r\n if Msg.LParam = 0 then\r\n ControlsListChanging(TControl(Msg.WParam), False)\r\n else\r\n ControlsListChanged(TControl(Msg.WParam), True);\r\n WM_SETFOCUS:\r\n FocusSet(THandle(Msg.WParam));\r\n WM_KILLFOCUS:\r\n FocusKilled(THandle(Msg.WParam));\r\n WM_SIZE, WM_MOVE:\r\n begin\r\n inherited WndProc(Msg);\r\n BoundsChanged;\r\n end;\r\n WM_ERASEBKGND:\r\n if (Msg.WParam <> 0) and not IsDefaultEraseBackground(DoEraseBackground, @TJvExCustomStatusBar.DoEraseBackground) then\r\n begin\r\n IdSaveDC := SaveDC(HDC(Msg.WParam)); // protect DC against Stock-Objects from Canvas\r\n Canvas := TCanvas.Create;\r\n try\r\n Canvas.Handle := HDC(Msg.WParam);\r\n Msg.Result := Ord(DoEraseBackground(Canvas, Msg.LParam));\r\n finally\r\n Canvas.Handle := 0;\r\n Canvas.Free;\r\n RestoreDC(HDC(Msg.WParam), IdSaveDC);\r\n end;\r\n end\r\n else\r\n inherited WndProc(Msg);\r\n {$IFNDEF DELPHI2007_UP}\r\n WM_PRINTCLIENT, WM_PRINT: // VCL bug fix\r\n begin\r\n IdSaveDC := SaveDC(HDC(Msg.WParam)); // protect DC against changes\r\n try\r\n inherited WndProc(Msg);\r\n finally\r\n RestoreDC(HDC(Msg.WParam), IdSaveDC);\r\n end;\r\n end;\r\n {$ENDIF ~DELPHI2007_UP}\r\n WM_GETDLGCODE:\r\n begin\r\n inherited WndProc(Msg);\r\n DlgCodes := [dcNative] + DlgcToDlgCodes(Msg.Result);\r\n GetDlgCode(DlgCodes);\r\n if not (dcNative in DlgCodes) then\r\n Msg.Result := DlgCodesToDlgc(DlgCodes);\r\n end;\r\n else\r\n inherited WndProc(Msg);\r\n end;\r\n case Msg.Msg of // precheck message to prevent access violations on released controls\r\n CM_MOUSEENTER, CM_MOUSELEAVE, WM_KILLFOCUS, WM_SETFOCUS, WM_NCPAINT:\r\n if DotNetHighlighting then\r\n HandleDotNetHighlighting(Self, Msg, MouseOver, Color);\r\n end;\r\n end;\r\nend;\r\n\r\n//============================================================================\r\n\r\nconstructor TJvExComboBoxEx.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FHintColor := clDefault;\r\nend;\r\n\r\nfunction TJvExComboBoxEx.BaseWndProc(Msg: Cardinal; WParam: WPARAM = 0; LParam: LPARAM = 0): LRESULT;\r\nvar\r\n Mesg: TMessage;\r\nbegin\r\n CreateWMMessage(Mesg, Msg, WParam, LParam);\r\n inherited WndProc(Mesg);\r\n Result := Mesg.Result;\r\nend;\r\n\r\nfunction TJvExComboBoxEx.BaseWndProc(Msg: Cardinal; WParam: WPARAM; LParam: TObject): LRESULT;\r\nbegin\r\n Result := BaseWndProc(Msg, WParam, Windows.LPARAM(LParam));\r\nend;\r\n\r\nfunction TJvExComboBoxEx.BaseWndProcEx(Msg: Cardinal; WParam: WPARAM; var StructLParam): LRESULT;\r\nbegin\r\n Result := BaseWndProc(Msg, WParam, Windows.LPARAM(@StructLParam));\r\nend;\r\n\r\nprocedure TJvExComboBoxEx.VisibleChanged;\r\nbegin\r\n BaseWndProc(CM_VISIBLECHANGED);\r\nend;\r\n\r\nprocedure TJvExComboBoxEx.EnabledChanged;\r\nbegin\r\n BaseWndProc(CM_ENABLEDCHANGED);\r\nend;\r\n\r\nprocedure TJvExComboBoxEx.TextChanged;\r\nbegin\r\n BaseWndProc(CM_TEXTCHANGED);\r\nend;\r\n\r\nprocedure TJvExComboBoxEx.FontChanged;\r\nbegin\r\n BaseWndProc(CM_FONTCHANGED);\r\nend;\r\n\r\nprocedure TJvExComboBoxEx.ColorChanged;\r\nbegin\r\n BaseWndProc(CM_COLORCHANGED);\r\nend;\r\n\r\nprocedure TJvExComboBoxEx.ParentFontChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTFONTCHANGED);\r\nend;\r\n\r\nprocedure TJvExComboBoxEx.ParentColorChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTCOLORCHANGED);\r\n if Assigned(OnParentColorChange) then\r\n OnParentColorChange(Self);\r\nend;\r\n\r\nprocedure TJvExComboBoxEx.ParentShowHintChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTSHOWHINTCHANGED);\r\nend;\r\n\r\nfunction TJvExComboBoxEx.WantKey(Key: Integer; Shift: TShiftState): Boolean;\r\nbegin\r\n Result := BaseWndProc(CM_DIALOGCHAR, Word(Key), ShiftStateToKeyData(Shift)) <> 0;\r\nend;\r\n\r\nfunction TJvExComboBoxEx.HitTest(X, Y: Integer): Boolean;\r\nbegin\r\n Result := BaseWndProc(CM_HITTEST, 0, SmallPointToLong(PointToSmallPoint(Point(X, Y)))) <> 0;\r\nend;\r\n\r\nfunction TJvExComboBoxEx.HintShow(var HintInfo: THintInfo): Boolean;\r\nbegin\r\n GetHintColor(HintInfo, Self, FHintColor);\r\n if FHintWindowClass <> nil then\r\n HintInfo.HintWindowClass := FHintWindowClass;\r\n Result := BaseWndProcEx(CM_HINTSHOW, 0, HintInfo) <> 0;\r\nend;\r\n\r\nprocedure TJvExComboBoxEx.MouseEnter(AControl: TControl);\r\nbegin\r\n FMouseOver := True;\r\n if Assigned(FOnMouseEnter) then\r\n FOnMouseEnter(Self);\r\n BaseWndProc(CM_MOUSEENTER, 0, AControl);\r\nend;\r\n\r\nprocedure TJvExComboBoxEx.MouseLeave(AControl: TControl);\r\nbegin\r\n FMouseOver := False;\r\n BaseWndProc(CM_MOUSELEAVE, 0, AControl);\r\n if Assigned(FOnMouseLeave) then\r\n FOnMouseLeave(Self);\r\nend;\r\n\r\nprocedure TJvExComboBoxEx.FocusChanged(AControl: TWinControl);\r\nbegin\r\n BaseWndProc(CM_FOCUSCHANGED, 0, AControl);\r\nend;\r\n\r\nprocedure TJvExComboBoxEx.BoundsChanged;\r\nbegin\r\nend;\r\n\r\nprocedure TJvExComboBoxEx.CursorChanged;\r\nbegin\r\n BaseWndProc(CM_CURSORCHANGED);\r\nend;\r\n\r\nprocedure TJvExComboBoxEx.ShowingChanged;\r\nbegin\r\n BaseWndProc(CM_SHOWINGCHANGED);\r\nend;\r\n\r\nprocedure TJvExComboBoxEx.ShowHintChanged;\r\nbegin\r\n BaseWndProc(CM_SHOWHINTCHANGED);\r\nend;\r\n\r\n{ VCL sends CM_CONTROLLISTCHANGE and CM_CONTROLCHANGE in a different order than\r\n the CLX methods are used. So we must correct it by evaluating \"Inserting\". }\r\nprocedure TJvExComboBoxEx.ControlsListChanging(Control: TControl; Inserting: Boolean);\r\nbegin\r\n if Inserting then\r\n BaseWndProc(CM_CONTROLLISTCHANGE, WPARAM(Control), LPARAM(Inserting))\r\n else\r\n BaseWndProc(CM_CONTROLCHANGE, WPARAM(Control), LPARAM(Inserting));\r\nend;\r\n\r\nprocedure TJvExComboBoxEx.ControlsListChanged(Control: TControl; Inserting: Boolean);\r\nbegin\r\n if not Inserting then\r\n BaseWndProc(CM_CONTROLLISTCHANGE, WPARAM(Control), LPARAM(Inserting))\r\n else\r\n BaseWndProc(CM_CONTROLCHANGE, WPARAM(Control), LPARAM(Inserting));\r\nend;\r\n\r\nprocedure TJvExComboBoxEx.GetDlgCode(var Code: TDlgCodes);\r\nbegin\r\nend;\r\n\r\nprocedure TJvExComboBoxEx.FocusSet(PrevWnd: THandle);\r\nbegin\r\n BaseWndProc(WM_SETFOCUS, WPARAM(PrevWnd), 0);\r\nend;\r\n\r\nprocedure TJvExComboBoxEx.FocusKilled(NextWnd: THandle);\r\nbegin\r\n BaseWndProc(WM_KILLFOCUS, WPARAM(NextWnd), 0);\r\nend;\r\n\r\nfunction TJvExComboBoxEx.DoEraseBackground(Canvas: TCanvas; Param: LPARAM): Boolean;\r\nbegin\r\n Result := BaseWndProc(WM_ERASEBKGND, Canvas.Handle, Param) <> 0;\r\nend;\r\n\r\n{$IFDEF JVCLThemesEnabledD6}\r\nfunction TJvExComboBoxEx.GetParentBackground: Boolean;\r\nbegin\r\n Result := JvThemes.GetParentBackground(Self);\r\nend;\r\n\r\nprocedure TJvExComboBoxEx.SetParentBackground(Value: Boolean);\r\nbegin\r\n JvThemes.SetParentBackground(Self, Value);\r\nend;\r\n{$ENDIF JVCLThemesEnabledD6}\r\n\r\nprocedure TJvExComboBoxEx.WndProc(var Msg: TMessage);\r\nvar\r\n IdSaveDC: Integer;\r\n DlgCodes: TDlgCodes;\r\n Canvas: TCanvas;\r\nbegin\r\n if not DispatchIsDesignMsg(Self, Msg) then\r\n begin\r\n case Msg.Msg of\r\n CM_DENYSUBCLASSING:\r\n Msg.Result := LRESULT(Ord(GetInterfaceEntry(IJvDenySubClassing) <> nil));\r\n CM_DIALOGCHAR:\r\n with TCMDialogChar{$IFDEF CLR}.Create{$ENDIF}(Msg) do\r\n Result := LRESULT(Ord(WantKey(CharCode, KeyDataToShiftState(KeyData))));\r\n CM_HINTSHOW:\r\n with TCMHintShow(Msg) do\r\n Result := LRESULT(HintShow(HintInfo^));\r\n CM_HITTEST:\r\n with TCMHitTest(Msg) do\r\n Result := LRESULT(HitTest(XPos, YPos));\r\n CM_MOUSEENTER:\r\n MouseEnter(TControl(Msg.LParam));\r\n CM_MOUSELEAVE:\r\n MouseLeave(TControl(Msg.LParam));\r\n CM_VISIBLECHANGED:\r\n VisibleChanged;\r\n CM_ENABLEDCHANGED:\r\n EnabledChanged;\r\n CM_TEXTCHANGED:\r\n TextChanged;\r\n CM_FONTCHANGED:\r\n FontChanged;\r\n CM_COLORCHANGED:\r\n ColorChanged;\r\n CM_FOCUSCHANGED:\r\n FocusChanged(TWinControl(Msg.LParam));\r\n CM_PARENTFONTCHANGED:\r\n ParentFontChanged;\r\n CM_PARENTCOLORCHANGED:\r\n ParentColorChanged;\r\n CM_PARENTSHOWHINTCHANGED:\r\n ParentShowHintChanged;\r\n CM_CURSORCHANGED:\r\n CursorChanged;\r\n CM_SHOWINGCHANGED:\r\n ShowingChanged;\r\n CM_SHOWHINTCHANGED:\r\n ShowHintChanged;\r\n CM_CONTROLLISTCHANGE:\r\n if Msg.LParam <> 0 then\r\n ControlsListChanging(TControl(Msg.WParam), True)\r\n else\r\n ControlsListChanged(TControl(Msg.WParam), False);\r\n CM_CONTROLCHANGE:\r\n if Msg.LParam = 0 then\r\n ControlsListChanging(TControl(Msg.WParam), False)\r\n else\r\n ControlsListChanged(TControl(Msg.WParam), True);\r\n WM_SETFOCUS:\r\n FocusSet(THandle(Msg.WParam));\r\n WM_KILLFOCUS:\r\n FocusKilled(THandle(Msg.WParam));\r\n WM_SIZE, WM_MOVE:\r\n begin\r\n inherited WndProc(Msg);\r\n BoundsChanged;\r\n end;\r\n WM_ERASEBKGND:\r\n if (Msg.WParam <> 0) and not IsDefaultEraseBackground(DoEraseBackground, @TJvExComboBoxEx.DoEraseBackground) then\r\n begin\r\n IdSaveDC := SaveDC(HDC(Msg.WParam)); // protect DC against Stock-Objects from Canvas\r\n Canvas := TCanvas.Create;\r\n try\r\n Canvas.Handle := HDC(Msg.WParam);\r\n Msg.Result := Ord(DoEraseBackground(Canvas, Msg.LParam));\r\n finally\r\n Canvas.Handle := 0;\r\n Canvas.Free;\r\n RestoreDC(HDC(Msg.WParam), IdSaveDC);\r\n end;\r\n end\r\n else\r\n inherited WndProc(Msg);\r\n {$IFNDEF DELPHI2007_UP}\r\n WM_PRINTCLIENT, WM_PRINT: // VCL bug fix\r\n begin\r\n IdSaveDC := SaveDC(HDC(Msg.WParam)); // protect DC against changes\r\n try\r\n inherited WndProc(Msg);\r\n finally\r\n RestoreDC(HDC(Msg.WParam), IdSaveDC);\r\n end;\r\n end;\r\n {$ENDIF ~DELPHI2007_UP}\r\n WM_GETDLGCODE:\r\n begin\r\n inherited WndProc(Msg);\r\n DlgCodes := [dcNative] + DlgcToDlgCodes(Msg.Result);\r\n GetDlgCode(DlgCodes);\r\n if not (dcNative in DlgCodes) then\r\n Msg.Result := DlgCodesToDlgc(DlgCodes);\r\n end;\r\n else\r\n inherited WndProc(Msg);\r\n end;\r\n case Msg.Msg of // precheck message to prevent access violations on released controls\r\n CM_MOUSEENTER, CM_MOUSELEAVE, WM_KILLFOCUS, WM_SETFOCUS, WM_NCPAINT:\r\n if DotNetHighlighting then\r\n HandleDotNetHighlighting(Self, Msg, MouseOver, Color);\r\n end;\r\n end;\r\nend;\r\n\r\n//============================================================================\r\n\r\nconstructor TJvExCustomHeaderControl.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FHintColor := clDefault;\r\nend;\r\n\r\nfunction TJvExCustomHeaderControl.BaseWndProc(Msg: Cardinal; WParam: WPARAM = 0; LParam: LPARAM = 0): LRESULT;\r\nvar\r\n Mesg: TMessage;\r\nbegin\r\n CreateWMMessage(Mesg, Msg, WParam, LParam);\r\n inherited WndProc(Mesg);\r\n Result := Mesg.Result;\r\nend;\r\n\r\nfunction TJvExCustomHeaderControl.BaseWndProc(Msg: Cardinal; WParam: WPARAM; LParam: TObject): LRESULT;\r\nbegin\r\n Result := BaseWndProc(Msg, WParam, Windows.LPARAM(LParam));\r\nend;\r\n\r\nfunction TJvExCustomHeaderControl.BaseWndProcEx(Msg: Cardinal; WParam: WPARAM; var StructLParam): LRESULT;\r\nbegin\r\n Result := BaseWndProc(Msg, WParam, Windows.LPARAM(@StructLParam));\r\nend;\r\n\r\nprocedure TJvExCustomHeaderControl.VisibleChanged;\r\nbegin\r\n BaseWndProc(CM_VISIBLECHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomHeaderControl.EnabledChanged;\r\nbegin\r\n BaseWndProc(CM_ENABLEDCHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomHeaderControl.TextChanged;\r\nbegin\r\n BaseWndProc(CM_TEXTCHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomHeaderControl.FontChanged;\r\nbegin\r\n BaseWndProc(CM_FONTCHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomHeaderControl.ColorChanged;\r\nbegin\r\n BaseWndProc(CM_COLORCHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomHeaderControl.ParentFontChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTFONTCHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomHeaderControl.ParentColorChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTCOLORCHANGED);\r\n if Assigned(OnParentColorChange) then\r\n OnParentColorChange(Self);\r\nend;\r\n\r\nprocedure TJvExCustomHeaderControl.ParentShowHintChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTSHOWHINTCHANGED);\r\nend;\r\n\r\nfunction TJvExCustomHeaderControl.WantKey(Key: Integer; Shift: TShiftState): Boolean;\r\nbegin\r\n Result := BaseWndProc(CM_DIALOGCHAR, Word(Key), ShiftStateToKeyData(Shift)) <> 0;\r\nend;\r\n\r\nfunction TJvExCustomHeaderControl.HitTest(X, Y: Integer): Boolean;\r\nbegin\r\n Result := BaseWndProc(CM_HITTEST, 0, SmallPointToLong(PointToSmallPoint(Point(X, Y)))) <> 0;\r\nend;\r\n\r\nfunction TJvExCustomHeaderControl.HintShow(var HintInfo: THintInfo): Boolean;\r\nbegin\r\n GetHintColor(HintInfo, Self, FHintColor);\r\n if FHintWindowClass <> nil then\r\n HintInfo.HintWindowClass := FHintWindowClass;\r\n Result := BaseWndProcEx(CM_HINTSHOW, 0, HintInfo) <> 0;\r\nend;\r\n\r\nprocedure TJvExCustomHeaderControl.MouseEnter(AControl: TControl);\r\nbegin\r\n FMouseOver := True;\r\n if Assigned(FOnMouseEnter) then\r\n FOnMouseEnter(Self);\r\n BaseWndProc(CM_MOUSEENTER, 0, AControl);\r\nend;\r\n\r\nprocedure TJvExCustomHeaderControl.MouseLeave(AControl: TControl);\r\nbegin\r\n FMouseOver := False;\r\n BaseWndProc(CM_MOUSELEAVE, 0, AControl);\r\n if Assigned(FOnMouseLeave) then\r\n FOnMouseLeave(Self);\r\nend;\r\n\r\nprocedure TJvExCustomHeaderControl.FocusChanged(AControl: TWinControl);\r\nbegin\r\n BaseWndProc(CM_FOCUSCHANGED, 0, AControl);\r\nend;\r\n\r\nprocedure TJvExCustomHeaderControl.BoundsChanged;\r\nbegin\r\nend;\r\n\r\nprocedure TJvExCustomHeaderControl.CursorChanged;\r\nbegin\r\n BaseWndProc(CM_CURSORCHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomHeaderControl.ShowingChanged;\r\nbegin\r\n BaseWndProc(CM_SHOWINGCHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomHeaderControl.ShowHintChanged;\r\nbegin\r\n BaseWndProc(CM_SHOWHINTCHANGED);\r\nend;\r\n\r\n{ VCL sends CM_CONTROLLISTCHANGE and CM_CONTROLCHANGE in a different order than\r\n the CLX methods are used. So we must correct it by evaluating \"Inserting\". }\r\nprocedure TJvExCustomHeaderControl.ControlsListChanging(Control: TControl; Inserting: Boolean);\r\nbegin\r\n if Inserting then\r\n BaseWndProc(CM_CONTROLLISTCHANGE, WPARAM(Control), LPARAM(Inserting))\r\n else\r\n BaseWndProc(CM_CONTROLCHANGE, WPARAM(Control), LPARAM(Inserting));\r\nend;\r\n\r\nprocedure TJvExCustomHeaderControl.ControlsListChanged(Control: TControl; Inserting: Boolean);\r\nbegin\r\n if not Inserting then\r\n BaseWndProc(CM_CONTROLLISTCHANGE, WPARAM(Control), LPARAM(Inserting))\r\n else\r\n BaseWndProc(CM_CONTROLCHANGE, WPARAM(Control), LPARAM(Inserting));\r\nend;\r\n\r\nprocedure TJvExCustomHeaderControl.GetDlgCode(var Code: TDlgCodes);\r\nbegin\r\nend;\r\n\r\nprocedure TJvExCustomHeaderControl.FocusSet(PrevWnd: THandle);\r\nbegin\r\n BaseWndProc(WM_SETFOCUS, WPARAM(PrevWnd), 0);\r\nend;\r\n\r\nprocedure TJvExCustomHeaderControl.FocusKilled(NextWnd: THandle);\r\nbegin\r\n BaseWndProc(WM_KILLFOCUS, WPARAM(NextWnd), 0);\r\nend;\r\n\r\nfunction TJvExCustomHeaderControl.DoEraseBackground(Canvas: TCanvas; Param: LPARAM): Boolean;\r\nbegin\r\n Result := BaseWndProc(WM_ERASEBKGND, Canvas.Handle, Param) <> 0;\r\nend;\r\n\r\n{$IFDEF JVCLThemesEnabledD6}\r\nfunction TJvExCustomHeaderControl.GetParentBackground: Boolean;\r\nbegin\r\n Result := JvThemes.GetParentBackground(Self);\r\nend;\r\n\r\nprocedure TJvExCustomHeaderControl.SetParentBackground(Value: Boolean);\r\nbegin\r\n JvThemes.SetParentBackground(Self, Value);\r\nend;\r\n{$ENDIF JVCLThemesEnabledD6}\r\n\r\nprocedure TJvExCustomHeaderControl.WndProc(var Msg: TMessage);\r\nvar\r\n IdSaveDC: Integer;\r\n DlgCodes: TDlgCodes;\r\n Canvas: TCanvas;\r\nbegin\r\n if not DispatchIsDesignMsg(Self, Msg) then\r\n begin\r\n case Msg.Msg of\r\n CM_DENYSUBCLASSING:\r\n Msg.Result := LRESULT(Ord(GetInterfaceEntry(IJvDenySubClassing) <> nil));\r\n CM_DIALOGCHAR:\r\n with TCMDialogChar{$IFDEF CLR}.Create{$ENDIF}(Msg) do\r\n Result := LRESULT(Ord(WantKey(CharCode, KeyDataToShiftState(KeyData))));\r\n CM_HINTSHOW:\r\n with TCMHintShow(Msg) do\r\n Result := LRESULT(HintShow(HintInfo^));\r\n CM_HITTEST:\r\n with TCMHitTest(Msg) do\r\n Result := LRESULT(HitTest(XPos, YPos));\r\n CM_MOUSEENTER:\r\n MouseEnter(TControl(Msg.LParam));\r\n CM_MOUSELEAVE:\r\n MouseLeave(TControl(Msg.LParam));\r\n CM_VISIBLECHANGED:\r\n VisibleChanged;\r\n CM_ENABLEDCHANGED:\r\n EnabledChanged;\r\n CM_TEXTCHANGED:\r\n TextChanged;\r\n CM_FONTCHANGED:\r\n FontChanged;\r\n CM_COLORCHANGED:\r\n ColorChanged;\r\n CM_FOCUSCHANGED:\r\n FocusChanged(TWinControl(Msg.LParam));\r\n CM_PARENTFONTCHANGED:\r\n ParentFontChanged;\r\n CM_PARENTCOLORCHANGED:\r\n ParentColorChanged;\r\n CM_PARENTSHOWHINTCHANGED:\r\n ParentShowHintChanged;\r\n CM_CURSORCHANGED:\r\n CursorChanged;\r\n CM_SHOWINGCHANGED:\r\n ShowingChanged;\r\n CM_SHOWHINTCHANGED:\r\n ShowHintChanged;\r\n CM_CONTROLLISTCHANGE:\r\n if Msg.LParam <> 0 then\r\n ControlsListChanging(TControl(Msg.WParam), True)\r\n else\r\n ControlsListChanged(TControl(Msg.WParam), False);\r\n CM_CONTROLCHANGE:\r\n if Msg.LParam = 0 then\r\n ControlsListChanging(TControl(Msg.WParam), False)\r\n else\r\n ControlsListChanged(TControl(Msg.WParam), True);\r\n WM_SETFOCUS:\r\n FocusSet(THandle(Msg.WParam));\r\n WM_KILLFOCUS:\r\n FocusKilled(THandle(Msg.WParam));\r\n WM_SIZE, WM_MOVE:\r\n begin\r\n inherited WndProc(Msg);\r\n BoundsChanged;\r\n end;\r\n WM_ERASEBKGND:\r\n if (Msg.WParam <> 0) and not IsDefaultEraseBackground(DoEraseBackground, @TJvExCustomHeaderControl.DoEraseBackground) then\r\n begin\r\n IdSaveDC := SaveDC(HDC(Msg.WParam)); // protect DC against Stock-Objects from Canvas\r\n Canvas := TCanvas.Create;\r\n try\r\n Canvas.Handle := HDC(Msg.WParam);\r\n Msg.Result := Ord(DoEraseBackground(Canvas, Msg.LParam));\r\n finally\r\n Canvas.Handle := 0;\r\n Canvas.Free;\r\n RestoreDC(HDC(Msg.WParam), IdSaveDC);\r\n end;\r\n end\r\n else\r\n inherited WndProc(Msg);\r\n {$IFNDEF DELPHI2007_UP}\r\n WM_PRINTCLIENT, WM_PRINT: // VCL bug fix\r\n begin\r\n IdSaveDC := SaveDC(HDC(Msg.WParam)); // protect DC against changes\r\n try\r\n inherited WndProc(Msg);\r\n finally\r\n RestoreDC(HDC(Msg.WParam), IdSaveDC);\r\n end;\r\n end;\r\n {$ENDIF ~DELPHI2007_UP}\r\n WM_GETDLGCODE:\r\n begin\r\n inherited WndProc(Msg);\r\n DlgCodes := [dcNative] + DlgcToDlgCodes(Msg.Result);\r\n GetDlgCode(DlgCodes);\r\n if not (dcNative in DlgCodes) then\r\n Msg.Result := DlgCodesToDlgc(DlgCodes);\r\n end;\r\n else\r\n inherited WndProc(Msg);\r\n end;\r\n case Msg.Msg of // precheck message to prevent access violations on released controls\r\n CM_MOUSEENTER, CM_MOUSELEAVE, WM_KILLFOCUS, WM_SETFOCUS, WM_NCPAINT:\r\n if DotNetHighlighting then\r\n HandleDotNetHighlighting(Self, Msg, MouseOver, Color);\r\n end;\r\n end;\r\nend;\r\n\r\n//============================================================================\r\n\r\nconstructor TJvExHeaderControl.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FHintColor := clDefault;\r\nend;\r\n\r\nfunction TJvExHeaderControl.BaseWndProc(Msg: Cardinal; WParam: WPARAM = 0; LParam: LPARAM = 0): LRESULT;\r\nvar\r\n Mesg: TMessage;\r\nbegin\r\n CreateWMMessage(Mesg, Msg, WParam, LParam);\r\n inherited WndProc(Mesg);\r\n Result := Mesg.Result;\r\nend;\r\n\r\nfunction TJvExHeaderControl.BaseWndProc(Msg: Cardinal; WParam: WPARAM; LParam: TObject): LRESULT;\r\nbegin\r\n Result := BaseWndProc(Msg, WParam, Windows.LPARAM(LParam));\r\nend;\r\n\r\nfunction TJvExHeaderControl.BaseWndProcEx(Msg: Cardinal; WParam: WPARAM; var StructLParam): LRESULT;\r\nbegin\r\n Result := BaseWndProc(Msg, WParam, Windows.LPARAM(@StructLParam));\r\nend;\r\n\r\nprocedure TJvExHeaderControl.VisibleChanged;\r\nbegin\r\n BaseWndProc(CM_VISIBLECHANGED);\r\nend;\r\n\r\nprocedure TJvExHeaderControl.EnabledChanged;\r\nbegin\r\n BaseWndProc(CM_ENABLEDCHANGED);\r\nend;\r\n\r\nprocedure TJvExHeaderControl.TextChanged;\r\nbegin\r\n BaseWndProc(CM_TEXTCHANGED);\r\nend;\r\n\r\nprocedure TJvExHeaderControl.FontChanged;\r\nbegin\r\n BaseWndProc(CM_FONTCHANGED);\r\nend;\r\n\r\nprocedure TJvExHeaderControl.ColorChanged;\r\nbegin\r\n BaseWndProc(CM_COLORCHANGED);\r\nend;\r\n\r\nprocedure TJvExHeaderControl.ParentFontChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTFONTCHANGED);\r\nend;\r\n\r\nprocedure TJvExHeaderControl.ParentColorChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTCOLORCHANGED);\r\n if Assigned(OnParentColorChange) then\r\n OnParentColorChange(Self);\r\nend;\r\n\r\nprocedure TJvExHeaderControl.ParentShowHintChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTSHOWHINTCHANGED);\r\nend;\r\n\r\nfunction TJvExHeaderControl.WantKey(Key: Integer; Shift: TShiftState): Boolean;\r\nbegin\r\n Result := BaseWndProc(CM_DIALOGCHAR, Word(Key), ShiftStateToKeyData(Shift)) <> 0;\r\nend;\r\n\r\nfunction TJvExHeaderControl.HitTest(X, Y: Integer): Boolean;\r\nbegin\r\n Result := BaseWndProc(CM_HITTEST, 0, SmallPointToLong(PointToSmallPoint(Point(X, Y)))) <> 0;\r\nend;\r\n\r\nfunction TJvExHeaderControl.HintShow(var HintInfo: THintInfo): Boolean;\r\nbegin\r\n GetHintColor(HintInfo, Self, FHintColor);\r\n if FHintWindowClass <> nil then\r\n HintInfo.HintWindowClass := FHintWindowClass;\r\n Result := BaseWndProcEx(CM_HINTSHOW, 0, HintInfo) <> 0;\r\nend;\r\n\r\nprocedure TJvExHeaderControl.MouseEnter(AControl: TControl);\r\nbegin\r\n FMouseOver := True;\r\n if Assigned(FOnMouseEnter) then\r\n FOnMouseEnter(Self);\r\n BaseWndProc(CM_MOUSEENTER, 0, AControl);\r\nend;\r\n\r\nprocedure TJvExHeaderControl.MouseLeave(AControl: TControl);\r\nbegin\r\n FMouseOver := False;\r\n BaseWndProc(CM_MOUSELEAVE, 0, AControl);\r\n if Assigned(FOnMouseLeave) then\r\n FOnMouseLeave(Self);\r\nend;\r\n\r\nprocedure TJvExHeaderControl.FocusChanged(AControl: TWinControl);\r\nbegin\r\n BaseWndProc(CM_FOCUSCHANGED, 0, AControl);\r\nend;\r\n\r\nprocedure TJvExHeaderControl.BoundsChanged;\r\nbegin\r\nend;\r\n\r\nprocedure TJvExHeaderControl.CursorChanged;\r\nbegin\r\n BaseWndProc(CM_CURSORCHANGED);\r\nend;\r\n\r\nprocedure TJvExHeaderControl.ShowingChanged;\r\nbegin\r\n BaseWndProc(CM_SHOWINGCHANGED);\r\nend;\r\n\r\nprocedure TJvExHeaderControl.ShowHintChanged;\r\nbegin\r\n BaseWndProc(CM_SHOWHINTCHANGED);\r\nend;\r\n\r\n{ VCL sends CM_CONTROLLISTCHANGE and CM_CONTROLCHANGE in a different order than\r\n the CLX methods are used. So we must correct it by evaluating \"Inserting\". }\r\nprocedure TJvExHeaderControl.ControlsListChanging(Control: TControl; Inserting: Boolean);\r\nbegin\r\n if Inserting then\r\n BaseWndProc(CM_CONTROLLISTCHANGE, WPARAM(Control), LPARAM(Inserting))\r\n else\r\n BaseWndProc(CM_CONTROLCHANGE, WPARAM(Control), LPARAM(Inserting));\r\nend;\r\n\r\nprocedure TJvExHeaderControl.ControlsListChanged(Control: TControl; Inserting: Boolean);\r\nbegin\r\n if not Inserting then\r\n BaseWndProc(CM_CONTROLLISTCHANGE, WPARAM(Control), LPARAM(Inserting))\r\n else\r\n BaseWndProc(CM_CONTROLCHANGE, WPARAM(Control), LPARAM(Inserting));\r\nend;\r\n\r\nprocedure TJvExHeaderControl.GetDlgCode(var Code: TDlgCodes);\r\nbegin\r\nend;\r\n\r\nprocedure TJvExHeaderControl.FocusSet(PrevWnd: THandle);\r\nbegin\r\n BaseWndProc(WM_SETFOCUS, WPARAM(PrevWnd), 0);\r\nend;\r\n\r\nprocedure TJvExHeaderControl.FocusKilled(NextWnd: THandle);\r\nbegin\r\n BaseWndProc(WM_KILLFOCUS, WPARAM(NextWnd), 0);\r\nend;\r\n\r\nfunction TJvExHeaderControl.DoEraseBackground(Canvas: TCanvas; Param: LPARAM): Boolean;\r\nbegin\r\n Result := BaseWndProc(WM_ERASEBKGND, Canvas.Handle, Param) <> 0;\r\nend;\r\n\r\n{$IFDEF JVCLThemesEnabledD6}\r\nfunction TJvExHeaderControl.GetParentBackground: Boolean;\r\nbegin\r\n Result := JvThemes.GetParentBackground(Self);\r\nend;\r\n\r\nprocedure TJvExHeaderControl.SetParentBackground(Value: Boolean);\r\nbegin\r\n JvThemes.SetParentBackground(Self, Value);\r\nend;\r\n{$ENDIF JVCLThemesEnabledD6}\r\n\r\nprocedure TJvExHeaderControl.WndProc(var Msg: TMessage);\r\nvar\r\n IdSaveDC: Integer;\r\n DlgCodes: TDlgCodes;\r\n Canvas: TCanvas;\r\nbegin\r\n if not DispatchIsDesignMsg(Self, Msg) then\r\n begin\r\n case Msg.Msg of\r\n CM_DENYSUBCLASSING:\r\n Msg.Result := LRESULT(Ord(GetInterfaceEntry(IJvDenySubClassing) <> nil));\r\n CM_DIALOGCHAR:\r\n with TCMDialogChar{$IFDEF CLR}.Create{$ENDIF}(Msg) do\r\n Result := LRESULT(Ord(WantKey(CharCode, KeyDataToShiftState(KeyData))));\r\n CM_HINTSHOW:\r\n with TCMHintShow(Msg) do\r\n Result := LRESULT(HintShow(HintInfo^));\r\n CM_HITTEST:\r\n with TCMHitTest(Msg) do\r\n Result := LRESULT(HitTest(XPos, YPos));\r\n CM_MOUSEENTER:\r\n MouseEnter(TControl(Msg.LParam));\r\n CM_MOUSELEAVE:\r\n MouseLeave(TControl(Msg.LParam));\r\n CM_VISIBLECHANGED:\r\n VisibleChanged;\r\n CM_ENABLEDCHANGED:\r\n EnabledChanged;\r\n CM_TEXTCHANGED:\r\n TextChanged;\r\n CM_FONTCHANGED:\r\n FontChanged;\r\n CM_COLORCHANGED:\r\n ColorChanged;\r\n CM_FOCUSCHANGED:\r\n FocusChanged(TWinControl(Msg.LParam));\r\n CM_PARENTFONTCHANGED:\r\n ParentFontChanged;\r\n CM_PARENTCOLORCHANGED:\r\n ParentColorChanged;\r\n CM_PARENTSHOWHINTCHANGED:\r\n ParentShowHintChanged;\r\n CM_CURSORCHANGED:\r\n CursorChanged;\r\n CM_SHOWINGCHANGED:\r\n ShowingChanged;\r\n CM_SHOWHINTCHANGED:\r\n ShowHintChanged;\r\n CM_CONTROLLISTCHANGE:\r\n if Msg.LParam <> 0 then\r\n ControlsListChanging(TControl(Msg.WParam), True)\r\n else\r\n ControlsListChanged(TControl(Msg.WParam), False);\r\n CM_CONTROLCHANGE:\r\n if Msg.LParam = 0 then\r\n ControlsListChanging(TControl(Msg.WParam), False)\r\n else\r\n ControlsListChanged(TControl(Msg.WParam), True);\r\n WM_SETFOCUS:\r\n FocusSet(THandle(Msg.WParam));\r\n WM_KILLFOCUS:\r\n FocusKilled(THandle(Msg.WParam));\r\n WM_SIZE, WM_MOVE:\r\n begin\r\n inherited WndProc(Msg);\r\n BoundsChanged;\r\n end;\r\n WM_ERASEBKGND:\r\n if (Msg.WParam <> 0) and not IsDefaultEraseBackground(DoEraseBackground, @TJvExHeaderControl.DoEraseBackground) then\r\n begin\r\n IdSaveDC := SaveDC(HDC(Msg.WParam)); // protect DC against Stock-Objects from Canvas\r\n Canvas := TCanvas.Create;\r\n try\r\n Canvas.Handle := HDC(Msg.WParam);\r\n Msg.Result := Ord(DoEraseBackground(Canvas, Msg.LParam));\r\n finally\r\n Canvas.Handle := 0;\r\n Canvas.Free;\r\n RestoreDC(HDC(Msg.WParam), IdSaveDC);\r\n end;\r\n end\r\n else\r\n inherited WndProc(Msg);\r\n {$IFNDEF DELPHI2007_UP}\r\n WM_PRINTCLIENT, WM_PRINT: // VCL bug fix\r\n begin\r\n IdSaveDC := SaveDC(HDC(Msg.WParam)); // protect DC against changes\r\n try\r\n inherited WndProc(Msg);\r\n finally\r\n RestoreDC(HDC(Msg.WParam), IdSaveDC);\r\n end;\r\n end;\r\n {$ENDIF ~DELPHI2007_UP}\r\n WM_GETDLGCODE:\r\n begin\r\n inherited WndProc(Msg);\r\n DlgCodes := [dcNative] + DlgcToDlgCodes(Msg.Result);\r\n GetDlgCode(DlgCodes);\r\n if not (dcNative in DlgCodes) then\r\n Msg.Result := DlgCodesToDlgc(DlgCodes);\r\n end;\r\n else\r\n inherited WndProc(Msg);\r\n end;\r\n case Msg.Msg of // precheck message to prevent access violations on released controls\r\n CM_MOUSEENTER, CM_MOUSELEAVE, WM_KILLFOCUS, WM_SETFOCUS, WM_NCPAINT:\r\n if DotNetHighlighting then\r\n HandleDotNetHighlighting(Self, Msg, MouseOver, Color);\r\n end;\r\n end;\r\nend;\r\n\r\n//============================================================================\r\n\r\nconstructor TJvExCustomListView.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FHintColor := clDefault;\r\nend;\r\n\r\nfunction TJvExCustomListView.BaseWndProc(Msg: Cardinal; WParam: WPARAM = 0; LParam: LPARAM = 0): LRESULT;\r\nvar\r\n Mesg: TMessage;\r\nbegin\r\n CreateWMMessage(Mesg, Msg, WParam, LParam);\r\n inherited WndProc(Mesg);\r\n Result := Mesg.Result;\r\nend;\r\n\r\nfunction TJvExCustomListView.BaseWndProc(Msg: Cardinal; WParam: WPARAM; LParam: TObject): LRESULT;\r\nbegin\r\n Result := BaseWndProc(Msg, WParam, Windows.LPARAM(LParam));\r\nend;\r\n\r\nfunction TJvExCustomListView.BaseWndProcEx(Msg: Cardinal; WParam: WPARAM; var StructLParam): LRESULT;\r\nbegin\r\n Result := BaseWndProc(Msg, WParam, Windows.LPARAM(@StructLParam));\r\nend;\r\n\r\nprocedure TJvExCustomListView.VisibleChanged;\r\nbegin\r\n BaseWndProc(CM_VISIBLECHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomListView.EnabledChanged;\r\nbegin\r\n BaseWndProc(CM_ENABLEDCHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomListView.TextChanged;\r\nbegin\r\n BaseWndProc(CM_TEXTCHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomListView.FontChanged;\r\nbegin\r\n BaseWndProc(CM_FONTCHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomListView.ColorChanged;\r\nbegin\r\n BaseWndProc(CM_COLORCHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomListView.ParentFontChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTFONTCHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomListView.ParentColorChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTCOLORCHANGED);\r\n if Assigned(OnParentColorChange) then\r\n OnParentColorChange(Self);\r\nend;\r\n\r\nprocedure TJvExCustomListView.ParentShowHintChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTSHOWHINTCHANGED);\r\nend;\r\n\r\nfunction TJvExCustomListView.WantKey(Key: Integer; Shift: TShiftState): Boolean;\r\nbegin\r\n Result := BaseWndProc(CM_DIALOGCHAR, Word(Key), ShiftStateToKeyData(Shift)) <> 0;\r\nend;\r\n\r\nfunction TJvExCustomListView.HitTest(X, Y: Integer): Boolean;\r\nbegin\r\n Result := BaseWndProc(CM_HITTEST, 0, SmallPointToLong(PointToSmallPoint(Point(X, Y)))) <> 0;\r\nend;\r\n\r\nfunction TJvExCustomListView.HintShow(var HintInfo: THintInfo): Boolean;\r\nbegin\r\n GetHintColor(HintInfo, Self, FHintColor);\r\n if FHintWindowClass <> nil then\r\n HintInfo.HintWindowClass := FHintWindowClass;\r\n Result := BaseWndProcEx(CM_HINTSHOW, 0, HintInfo) <> 0;\r\nend;\r\n\r\nprocedure TJvExCustomListView.MouseEnter(AControl: TControl);\r\nbegin\r\n FMouseOver := True;\r\n if Assigned(FOnMouseEnter) then\r\n FOnMouseEnter(Self);\r\n BaseWndProc(CM_MOUSEENTER, 0, AControl);\r\nend;\r\n\r\nprocedure TJvExCustomListView.MouseLeave(AControl: TControl);\r\nbegin\r\n FMouseOver := False;\r\n BaseWndProc(CM_MOUSELEAVE, 0, AControl);\r\n if Assigned(FOnMouseLeave) then\r\n FOnMouseLeave(Self);\r\nend;\r\n\r\nprocedure TJvExCustomListView.FocusChanged(AControl: TWinControl);\r\nbegin\r\n BaseWndProc(CM_FOCUSCHANGED, 0, AControl);\r\nend;\r\n\r\nprocedure TJvExCustomListView.BoundsChanged;\r\nbegin\r\nend;\r\n\r\nprocedure TJvExCustomListView.CursorChanged;\r\nbegin\r\n BaseWndProc(CM_CURSORCHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomListView.ShowingChanged;\r\nbegin\r\n BaseWndProc(CM_SHOWINGCHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomListView.ShowHintChanged;\r\nbegin\r\n BaseWndProc(CM_SHOWHINTCHANGED);\r\nend;\r\n\r\n{ VCL sends CM_CONTROLLISTCHANGE and CM_CONTROLCHANGE in a different order than\r\n the CLX methods are used. So we must correct it by evaluating \"Inserting\". }\r\nprocedure TJvExCustomListView.ControlsListChanging(Control: TControl; Inserting: Boolean);\r\nbegin\r\n if Inserting then\r\n BaseWndProc(CM_CONTROLLISTCHANGE, WPARAM(Control), LPARAM(Inserting))\r\n else\r\n BaseWndProc(CM_CONTROLCHANGE, WPARAM(Control), LPARAM(Inserting));\r\nend;\r\n\r\nprocedure TJvExCustomListView.ControlsListChanged(Control: TControl; Inserting: Boolean);\r\nbegin\r\n if not Inserting then\r\n BaseWndProc(CM_CONTROLLISTCHANGE, WPARAM(Control), LPARAM(Inserting))\r\n else\r\n BaseWndProc(CM_CONTROLCHANGE, WPARAM(Control), LPARAM(Inserting));\r\nend;\r\n\r\nprocedure TJvExCustomListView.GetDlgCode(var Code: TDlgCodes);\r\nbegin\r\nend;\r\n\r\nprocedure TJvExCustomListView.FocusSet(PrevWnd: THandle);\r\nbegin\r\n BaseWndProc(WM_SETFOCUS, WPARAM(PrevWnd), 0);\r\nend;\r\n\r\nprocedure TJvExCustomListView.FocusKilled(NextWnd: THandle);\r\nbegin\r\n BaseWndProc(WM_KILLFOCUS, WPARAM(NextWnd), 0);\r\nend;\r\n\r\nfunction TJvExCustomListView.DoEraseBackground(Canvas: TCanvas; Param: LPARAM): Boolean;\r\nbegin\r\n Result := BaseWndProc(WM_ERASEBKGND, Canvas.Handle, Param) <> 0;\r\nend;\r\n\r\n{$IFDEF JVCLThemesEnabledD6}\r\nfunction TJvExCustomListView.GetParentBackground: Boolean;\r\nbegin\r\n Result := JvThemes.GetParentBackground(Self);\r\nend;\r\n\r\nprocedure TJvExCustomListView.SetParentBackground(Value: Boolean);\r\nbegin\r\n JvThemes.SetParentBackground(Self, Value);\r\nend;\r\n{$ENDIF JVCLThemesEnabledD6}\r\n\r\nprocedure TJvExCustomListView.WndProc(var Msg: TMessage);\r\nvar\r\n IdSaveDC: Integer;\r\n DlgCodes: TDlgCodes;\r\n Canvas: TCanvas;\r\nbegin\r\n if not DispatchIsDesignMsg(Self, Msg) then\r\n begin\r\n case Msg.Msg of\r\n CM_DENYSUBCLASSING:\r\n Msg.Result := LRESULT(Ord(GetInterfaceEntry(IJvDenySubClassing) <> nil));\r\n CM_DIALOGCHAR:\r\n with TCMDialogChar{$IFDEF CLR}.Create{$ENDIF}(Msg) do\r\n Result := LRESULT(Ord(WantKey(CharCode, KeyDataToShiftState(KeyData))));\r\n CM_HINTSHOW:\r\n with TCMHintShow(Msg) do\r\n Result := LRESULT(HintShow(HintInfo^));\r\n CM_HITTEST:\r\n with TCMHitTest(Msg) do\r\n Result := LRESULT(HitTest(XPos, YPos));\r\n CM_MOUSEENTER:\r\n MouseEnter(TControl(Msg.LParam));\r\n CM_MOUSELEAVE:\r\n MouseLeave(TControl(Msg.LParam));\r\n CM_VISIBLECHANGED:\r\n VisibleChanged;\r\n CM_ENABLEDCHANGED:\r\n EnabledChanged;\r\n CM_TEXTCHANGED:\r\n TextChanged;\r\n CM_FONTCHANGED:\r\n FontChanged;\r\n CM_COLORCHANGED:\r\n ColorChanged;\r\n CM_FOCUSCHANGED:\r\n FocusChanged(TWinControl(Msg.LParam));\r\n CM_PARENTFONTCHANGED:\r\n ParentFontChanged;\r\n CM_PARENTCOLORCHANGED:\r\n ParentColorChanged;\r\n CM_PARENTSHOWHINTCHANGED:\r\n ParentShowHintChanged;\r\n CM_CURSORCHANGED:\r\n CursorChanged;\r\n CM_SHOWINGCHANGED:\r\n ShowingChanged;\r\n CM_SHOWHINTCHANGED:\r\n ShowHintChanged;\r\n CM_CONTROLLISTCHANGE:\r\n if Msg.LParam <> 0 then\r\n ControlsListChanging(TControl(Msg.WParam), True)\r\n else\r\n ControlsListChanged(TControl(Msg.WParam), False);\r\n CM_CONTROLCHANGE:\r\n if Msg.LParam = 0 then\r\n ControlsListChanging(TControl(Msg.WParam), False)\r\n else\r\n ControlsListChanged(TControl(Msg.WParam), True);\r\n WM_SETFOCUS:\r\n FocusSet(THandle(Msg.WParam));\r\n WM_KILLFOCUS:\r\n FocusKilled(THandle(Msg.WParam));\r\n WM_SIZE, WM_MOVE:\r\n begin\r\n inherited WndProc(Msg);\r\n BoundsChanged;\r\n end;\r\n WM_ERASEBKGND:\r\n if (Msg.WParam <> 0) and not IsDefaultEraseBackground(DoEraseBackground, @TJvExCustomListView.DoEraseBackground) then\r\n begin\r\n IdSaveDC := SaveDC(HDC(Msg.WParam)); // protect DC against Stock-Objects from Canvas\r\n Canvas := TCanvas.Create;\r\n try\r\n Canvas.Handle := HDC(Msg.WParam);\r\n Msg.Result := Ord(DoEraseBackground(Canvas, Msg.LParam));\r\n finally\r\n Canvas.Handle := 0;\r\n Canvas.Free;\r\n RestoreDC(HDC(Msg.WParam), IdSaveDC);\r\n end;\r\n end\r\n else\r\n inherited WndProc(Msg);\r\n {$IFNDEF DELPHI2007_UP}\r\n WM_PRINTCLIENT, WM_PRINT: // VCL bug fix\r\n begin\r\n IdSaveDC := SaveDC(HDC(Msg.WParam)); // protect DC against changes\r\n try\r\n inherited WndProc(Msg);\r\n finally\r\n RestoreDC(HDC(Msg.WParam), IdSaveDC);\r\n end;\r\n end;\r\n {$ENDIF ~DELPHI2007_UP}\r\n WM_GETDLGCODE:\r\n begin\r\n inherited WndProc(Msg);\r\n DlgCodes := [dcNative] + DlgcToDlgCodes(Msg.Result);\r\n GetDlgCode(DlgCodes);\r\n if not (dcNative in DlgCodes) then\r\n Msg.Result := DlgCodesToDlgc(DlgCodes);\r\n end;\r\n else\r\n inherited WndProc(Msg);\r\n end;\r\n case Msg.Msg of // precheck message to prevent access violations on released controls\r\n CM_MOUSEENTER, CM_MOUSELEAVE, WM_KILLFOCUS, WM_SETFOCUS, WM_NCPAINT:\r\n if DotNetHighlighting then\r\n HandleDotNetHighlighting(Self, Msg, MouseOver, Color);\r\n end;\r\n end;\r\nend;\r\n\r\n//============================================================================\r\n\r\nconstructor TJvExListView.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FHintColor := clDefault;\r\nend;\r\n\r\nfunction TJvExListView.BaseWndProc(Msg: Cardinal; WParam: WPARAM = 0; LParam: LPARAM = 0): LRESULT;\r\nvar\r\n Mesg: TMessage;\r\nbegin\r\n CreateWMMessage(Mesg, Msg, WParam, LParam);\r\n inherited WndProc(Mesg);\r\n Result := Mesg.Result;\r\nend;\r\n\r\nfunction TJvExListView.BaseWndProc(Msg: Cardinal; WParam: WPARAM; LParam: TObject): LRESULT;\r\nbegin\r\n Result := BaseWndProc(Msg, WParam, Windows.LPARAM(LParam));\r\nend;\r\n\r\nfunction TJvExListView.BaseWndProcEx(Msg: Cardinal; WParam: WPARAM; var StructLParam): LRESULT;\r\nbegin\r\n Result := BaseWndProc(Msg, WParam, Windows.LPARAM(@StructLParam));\r\nend;\r\n\r\nprocedure TJvExListView.VisibleChanged;\r\nbegin\r\n BaseWndProc(CM_VISIBLECHANGED);\r\nend;\r\n\r\nprocedure TJvExListView.EnabledChanged;\r\nbegin\r\n BaseWndProc(CM_ENABLEDCHANGED);\r\nend;\r\n\r\nprocedure TJvExListView.TextChanged;\r\nbegin\r\n BaseWndProc(CM_TEXTCHANGED);\r\nend;\r\n\r\nprocedure TJvExListView.FontChanged;\r\nbegin\r\n BaseWndProc(CM_FONTCHANGED);\r\nend;\r\n\r\nprocedure TJvExListView.ColorChanged;\r\nbegin\r\n BaseWndProc(CM_COLORCHANGED);\r\nend;\r\n\r\nprocedure TJvExListView.ParentFontChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTFONTCHANGED);\r\nend;\r\n\r\nprocedure TJvExListView.ParentColorChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTCOLORCHANGED);\r\n if Assigned(OnParentColorChange) then\r\n OnParentColorChange(Self);\r\nend;\r\n\r\nprocedure TJvExListView.ParentShowHintChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTSHOWHINTCHANGED);\r\nend;\r\n\r\nfunction TJvExListView.WantKey(Key: Integer; Shift: TShiftState): Boolean;\r\nbegin\r\n Result := BaseWndProc(CM_DIALOGCHAR, Word(Key), ShiftStateToKeyData(Shift)) <> 0;\r\nend;\r\n\r\nfunction TJvExListView.HitTest(X, Y: Integer): Boolean;\r\nbegin\r\n Result := BaseWndProc(CM_HITTEST, 0, SmallPointToLong(PointToSmallPoint(Point(X, Y)))) <> 0;\r\nend;\r\n\r\nfunction TJvExListView.HintShow(var HintInfo: THintInfo): Boolean;\r\nbegin\r\n GetHintColor(HintInfo, Self, FHintColor);\r\n if FHintWindowClass <> nil then\r\n HintInfo.HintWindowClass := FHintWindowClass;\r\n Result := BaseWndProcEx(CM_HINTSHOW, 0, HintInfo) <> 0;\r\nend;\r\n\r\nprocedure TJvExListView.MouseEnter(AControl: TControl);\r\nbegin\r\n FMouseOver := True;\r\n if Assigned(FOnMouseEnter) then\r\n FOnMouseEnter(Self);\r\n BaseWndProc(CM_MOUSEENTER, 0, AControl);\r\nend;\r\n\r\nprocedure TJvExListView.MouseLeave(AControl: TControl);\r\nbegin\r\n FMouseOver := False;\r\n BaseWndProc(CM_MOUSELEAVE, 0, AControl);\r\n if Assigned(FOnMouseLeave) then\r\n FOnMouseLeave(Self);\r\nend;\r\n\r\nprocedure TJvExListView.FocusChanged(AControl: TWinControl);\r\nbegin\r\n BaseWndProc(CM_FOCUSCHANGED, 0, AControl);\r\nend;\r\n\r\nprocedure TJvExListView.BoundsChanged;\r\nbegin\r\nend;\r\n\r\nprocedure TJvExListView.CursorChanged;\r\nbegin\r\n BaseWndProc(CM_CURSORCHANGED);\r\nend;\r\n\r\nprocedure TJvExListView.ShowingChanged;\r\nbegin\r\n BaseWndProc(CM_SHOWINGCHANGED);\r\nend;\r\n\r\nprocedure TJvExListView.ShowHintChanged;\r\nbegin\r\n BaseWndProc(CM_SHOWHINTCHANGED);\r\nend;\r\n\r\n{ VCL sends CM_CONTROLLISTCHANGE and CM_CONTROLCHANGE in a different order than\r\n the CLX methods are used. So we must correct it by evaluating \"Inserting\". }\r\nprocedure TJvExListView.ControlsListChanging(Control: TControl; Inserting: Boolean);\r\nbegin\r\n if Inserting then\r\n BaseWndProc(CM_CONTROLLISTCHANGE, WPARAM(Control), LPARAM(Inserting))\r\n else\r\n BaseWndProc(CM_CONTROLCHANGE, WPARAM(Control), LPARAM(Inserting));\r\nend;\r\n\r\nprocedure TJvExListView.ControlsListChanged(Control: TControl; Inserting: Boolean);\r\nbegin\r\n if not Inserting then\r\n BaseWndProc(CM_CONTROLLISTCHANGE, WPARAM(Control), LPARAM(Inserting))\r\n else\r\n BaseWndProc(CM_CONTROLCHANGE, WPARAM(Control), LPARAM(Inserting));\r\nend;\r\n\r\nprocedure TJvExListView.GetDlgCode(var Code: TDlgCodes);\r\nbegin\r\nend;\r\n\r\nprocedure TJvExListView.FocusSet(PrevWnd: THandle);\r\nbegin\r\n BaseWndProc(WM_SETFOCUS, WPARAM(PrevWnd), 0);\r\nend;\r\n\r\nprocedure TJvExListView.FocusKilled(NextWnd: THandle);\r\nbegin\r\n BaseWndProc(WM_KILLFOCUS, WPARAM(NextWnd), 0);\r\nend;\r\n\r\nfunction TJvExListView.DoEraseBackground(Canvas: TCanvas; Param: LPARAM): Boolean;\r\nbegin\r\n Result := BaseWndProc(WM_ERASEBKGND, Canvas.Handle, Param) <> 0;\r\nend;\r\n\r\n{$IFDEF JVCLThemesEnabledD6}\r\nfunction TJvExListView.GetParentBackground: Boolean;\r\nbegin\r\n Result := JvThemes.GetParentBackground(Self);\r\nend;\r\n\r\nprocedure TJvExListView.SetParentBackground(Value: Boolean);\r\nbegin\r\n JvThemes.SetParentBackground(Self, Value);\r\nend;\r\n{$ENDIF JVCLThemesEnabledD6}\r\n\r\nprocedure TJvExListView.WndProc(var Msg: TMessage);\r\nvar\r\n IdSaveDC: Integer;\r\n DlgCodes: TDlgCodes;\r\n Canvas: TCanvas;\r\nbegin\r\n if not DispatchIsDesignMsg(Self, Msg) then\r\n begin\r\n case Msg.Msg of\r\n CM_DENYSUBCLASSING:\r\n Msg.Result := LRESULT(Ord(GetInterfaceEntry(IJvDenySubClassing) <> nil));\r\n CM_DIALOGCHAR:\r\n with TCMDialogChar{$IFDEF CLR}.Create{$ENDIF}(Msg) do\r\n Result := LRESULT(Ord(WantKey(CharCode, KeyDataToShiftState(KeyData))));\r\n CM_HINTSHOW:\r\n with TCMHintShow(Msg) do\r\n Result := LRESULT(HintShow(HintInfo^));\r\n CM_HITTEST:\r\n with TCMHitTest(Msg) do\r\n Result := LRESULT(HitTest(XPos, YPos));\r\n CM_MOUSEENTER:\r\n MouseEnter(TControl(Msg.LParam));\r\n CM_MOUSELEAVE:\r\n MouseLeave(TControl(Msg.LParam));\r\n CM_VISIBLECHANGED:\r\n VisibleChanged;\r\n CM_ENABLEDCHANGED:\r\n EnabledChanged;\r\n CM_TEXTCHANGED:\r\n TextChanged;\r\n CM_FONTCHANGED:\r\n FontChanged;\r\n CM_COLORCHANGED:\r\n ColorChanged;\r\n CM_FOCUSCHANGED:\r\n FocusChanged(TWinControl(Msg.LParam));\r\n CM_PARENTFONTCHANGED:\r\n ParentFontChanged;\r\n CM_PARENTCOLORCHANGED:\r\n ParentColorChanged;\r\n CM_PARENTSHOWHINTCHANGED:\r\n ParentShowHintChanged;\r\n CM_CURSORCHANGED:\r\n CursorChanged;\r\n CM_SHOWINGCHANGED:\r\n ShowingChanged;\r\n CM_SHOWHINTCHANGED:\r\n ShowHintChanged;\r\n CM_CONTROLLISTCHANGE:\r\n if Msg.LParam <> 0 then\r\n ControlsListChanging(TControl(Msg.WParam), True)\r\n else\r\n ControlsListChanged(TControl(Msg.WParam), False);\r\n CM_CONTROLCHANGE:\r\n if Msg.LParam = 0 then\r\n ControlsListChanging(TControl(Msg.WParam), False)\r\n else\r\n ControlsListChanged(TControl(Msg.WParam), True);\r\n WM_SETFOCUS:\r\n FocusSet(THandle(Msg.WParam));\r\n WM_KILLFOCUS:\r\n FocusKilled(THandle(Msg.WParam));\r\n WM_SIZE, WM_MOVE:\r\n begin\r\n inherited WndProc(Msg);\r\n BoundsChanged;\r\n end;\r\n WM_ERASEBKGND:\r\n if (Msg.WParam <> 0) and not IsDefaultEraseBackground(DoEraseBackground, @TJvExListView.DoEraseBackground) then\r\n begin\r\n IdSaveDC := SaveDC(HDC(Msg.WParam)); // protect DC against Stock-Objects from Canvas\r\n Canvas := TCanvas.Create;\r\n try\r\n Canvas.Handle := HDC(Msg.WParam);\r\n Msg.Result := Ord(DoEraseBackground(Canvas, Msg.LParam));\r\n finally\r\n Canvas.Handle := 0;\r\n Canvas.Free;\r\n RestoreDC(HDC(Msg.WParam), IdSaveDC);\r\n end;\r\n end\r\n else\r\n inherited WndProc(Msg);\r\n {$IFNDEF DELPHI2007_UP}\r\n WM_PRINTCLIENT, WM_PRINT: // VCL bug fix\r\n begin\r\n IdSaveDC := SaveDC(HDC(Msg.WParam)); // protect DC against changes\r\n try\r\n inherited WndProc(Msg);\r\n finally\r\n RestoreDC(HDC(Msg.WParam), IdSaveDC);\r\n end;\r\n end;\r\n {$ENDIF ~DELPHI2007_UP}\r\n WM_GETDLGCODE:\r\n begin\r\n inherited WndProc(Msg);\r\n DlgCodes := [dcNative] + DlgcToDlgCodes(Msg.Result);\r\n GetDlgCode(DlgCodes);\r\n if not (dcNative in DlgCodes) then\r\n Msg.Result := DlgCodesToDlgc(DlgCodes);\r\n end;\r\n else\r\n inherited WndProc(Msg);\r\n end;\r\n case Msg.Msg of // precheck message to prevent access violations on released controls\r\n CM_MOUSEENTER, CM_MOUSELEAVE, WM_KILLFOCUS, WM_SETFOCUS, WM_NCPAINT:\r\n if DotNetHighlighting then\r\n HandleDotNetHighlighting(Self, Msg, MouseOver, Color);\r\n end;\r\n end;\r\nend;\r\n\r\n//============================================================================\r\n\r\nconstructor TJvExCustomTreeView.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FHintColor := clDefault;\r\nend;\r\n\r\nfunction TJvExCustomTreeView.BaseWndProc(Msg: Cardinal; WParam: WPARAM = 0; LParam: LPARAM = 0): LRESULT;\r\nvar\r\n Mesg: TMessage;\r\nbegin\r\n CreateWMMessage(Mesg, Msg, WParam, LParam);\r\n inherited WndProc(Mesg);\r\n Result := Mesg.Result;\r\nend;\r\n\r\nfunction TJvExCustomTreeView.BaseWndProc(Msg: Cardinal; WParam: WPARAM; LParam: TObject): LRESULT;\r\nbegin\r\n Result := BaseWndProc(Msg, WParam, Windows.LPARAM(LParam));\r\nend;\r\n\r\nfunction TJvExCustomTreeView.BaseWndProcEx(Msg: Cardinal; WParam: WPARAM; var StructLParam): LRESULT;\r\nbegin\r\n Result := BaseWndProc(Msg, WParam, Windows.LPARAM(@StructLParam));\r\nend;\r\n\r\nprocedure TJvExCustomTreeView.VisibleChanged;\r\nbegin\r\n BaseWndProc(CM_VISIBLECHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomTreeView.EnabledChanged;\r\nbegin\r\n BaseWndProc(CM_ENABLEDCHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomTreeView.TextChanged;\r\nbegin\r\n BaseWndProc(CM_TEXTCHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomTreeView.FontChanged;\r\nbegin\r\n BaseWndProc(CM_FONTCHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomTreeView.ColorChanged;\r\nbegin\r\n BaseWndProc(CM_COLORCHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomTreeView.ParentFontChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTFONTCHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomTreeView.ParentColorChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTCOLORCHANGED);\r\n if Assigned(OnParentColorChange) then\r\n OnParentColorChange(Self);\r\nend;\r\n\r\nprocedure TJvExCustomTreeView.ParentShowHintChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTSHOWHINTCHANGED);\r\nend;\r\n\r\nfunction TJvExCustomTreeView.WantKey(Key: Integer; Shift: TShiftState): Boolean;\r\nbegin\r\n Result := BaseWndProc(CM_DIALOGCHAR, Word(Key), ShiftStateToKeyData(Shift)) <> 0;\r\nend;\r\n\r\nfunction TJvExCustomTreeView.HitTest(X, Y: Integer): Boolean;\r\nbegin\r\n Result := BaseWndProc(CM_HITTEST, 0, SmallPointToLong(PointToSmallPoint(Point(X, Y)))) <> 0;\r\nend;\r\n\r\nfunction TJvExCustomTreeView.HintShow(var HintInfo: THintInfo): Boolean;\r\nbegin\r\n GetHintColor(HintInfo, Self, FHintColor);\r\n if FHintWindowClass <> nil then\r\n HintInfo.HintWindowClass := FHintWindowClass;\r\n Result := BaseWndProcEx(CM_HINTSHOW, 0, HintInfo) <> 0;\r\nend;\r\n\r\nprocedure TJvExCustomTreeView.MouseEnter(AControl: TControl);\r\nbegin\r\n FMouseOver := True;\r\n if Assigned(FOnMouseEnter) then\r\n FOnMouseEnter(Self);\r\n BaseWndProc(CM_MOUSEENTER, 0, AControl);\r\nend;\r\n\r\nprocedure TJvExCustomTreeView.MouseLeave(AControl: TControl);\r\nbegin\r\n FMouseOver := False;\r\n BaseWndProc(CM_MOUSELEAVE, 0, AControl);\r\n if Assigned(FOnMouseLeave) then\r\n FOnMouseLeave(Self);\r\nend;\r\n\r\nprocedure TJvExCustomTreeView.FocusChanged(AControl: TWinControl);\r\nbegin\r\n BaseWndProc(CM_FOCUSCHANGED, 0, AControl);\r\nend;\r\n\r\nprocedure TJvExCustomTreeView.BoundsChanged;\r\nbegin\r\nend;\r\n\r\nprocedure TJvExCustomTreeView.CursorChanged;\r\nbegin\r\n BaseWndProc(CM_CURSORCHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomTreeView.ShowingChanged;\r\nbegin\r\n BaseWndProc(CM_SHOWINGCHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomTreeView.ShowHintChanged;\r\nbegin\r\n BaseWndProc(CM_SHOWHINTCHANGED);\r\nend;\r\n\r\n{ VCL sends CM_CONTROLLISTCHANGE and CM_CONTROLCHANGE in a different order than\r\n the CLX methods are used. So we must correct it by evaluating \"Inserting\". }\r\nprocedure TJvExCustomTreeView.ControlsListChanging(Control: TControl; Inserting: Boolean);\r\nbegin\r\n if Inserting then\r\n BaseWndProc(CM_CONTROLLISTCHANGE, WPARAM(Control), LPARAM(Inserting))\r\n else\r\n BaseWndProc(CM_CONTROLCHANGE, WPARAM(Control), LPARAM(Inserting));\r\nend;\r\n\r\nprocedure TJvExCustomTreeView.ControlsListChanged(Control: TControl; Inserting: Boolean);\r\nbegin\r\n if not Inserting then\r\n BaseWndProc(CM_CONTROLLISTCHANGE, WPARAM(Control), LPARAM(Inserting))\r\n else\r\n BaseWndProc(CM_CONTROLCHANGE, WPARAM(Control), LPARAM(Inserting));\r\nend;\r\n\r\nprocedure TJvExCustomTreeView.GetDlgCode(var Code: TDlgCodes);\r\nbegin\r\nend;\r\n\r\nprocedure TJvExCustomTreeView.FocusSet(PrevWnd: THandle);\r\nbegin\r\n BaseWndProc(WM_SETFOCUS, WPARAM(PrevWnd), 0);\r\nend;\r\n\r\nprocedure TJvExCustomTreeView.FocusKilled(NextWnd: THandle);\r\nbegin\r\n BaseWndProc(WM_KILLFOCUS, WPARAM(NextWnd), 0);\r\nend;\r\n\r\nfunction TJvExCustomTreeView.DoEraseBackground(Canvas: TCanvas; Param: LPARAM): Boolean;\r\nbegin\r\n Result := BaseWndProc(WM_ERASEBKGND, Canvas.Handle, Param) <> 0;\r\nend;\r\n\r\n{$IFDEF JVCLThemesEnabledD6}\r\nfunction TJvExCustomTreeView.GetParentBackground: Boolean;\r\nbegin\r\n Result := JvThemes.GetParentBackground(Self);\r\nend;\r\n\r\nprocedure TJvExCustomTreeView.SetParentBackground(Value: Boolean);\r\nbegin\r\n JvThemes.SetParentBackground(Self, Value);\r\nend;\r\n{$ENDIF JVCLThemesEnabledD6}\r\n\r\nprocedure TJvExCustomTreeView.WndProc(var Msg: TMessage);\r\nvar\r\n IdSaveDC: Integer;\r\n DlgCodes: TDlgCodes;\r\n Canvas: TCanvas;\r\nbegin\r\n if not DispatchIsDesignMsg(Self, Msg) then\r\n begin\r\n case Msg.Msg of\r\n CM_DENYSUBCLASSING:\r\n Msg.Result := LRESULT(Ord(GetInterfaceEntry(IJvDenySubClassing) <> nil));\r\n CM_DIALOGCHAR:\r\n with TCMDialogChar{$IFDEF CLR}.Create{$ENDIF}(Msg) do\r\n Result := LRESULT(Ord(WantKey(CharCode, KeyDataToShiftState(KeyData))));\r\n CM_HINTSHOW:\r\n with TCMHintShow(Msg) do\r\n Result := LRESULT(HintShow(HintInfo^));\r\n CM_HITTEST:\r\n with TCMHitTest(Msg) do\r\n Result := LRESULT(HitTest(XPos, YPos));\r\n CM_MOUSEENTER:\r\n MouseEnter(TControl(Msg.LParam));\r\n CM_MOUSELEAVE:\r\n MouseLeave(TControl(Msg.LParam));\r\n CM_VISIBLECHANGED:\r\n VisibleChanged;\r\n CM_ENABLEDCHANGED:\r\n EnabledChanged;\r\n CM_TEXTCHANGED:\r\n TextChanged;\r\n CM_FONTCHANGED:\r\n FontChanged;\r\n CM_COLORCHANGED:\r\n ColorChanged;\r\n CM_FOCUSCHANGED:\r\n FocusChanged(TWinControl(Msg.LParam));\r\n CM_PARENTFONTCHANGED:\r\n ParentFontChanged;\r\n CM_PARENTCOLORCHANGED:\r\n ParentColorChanged;\r\n CM_PARENTSHOWHINTCHANGED:\r\n ParentShowHintChanged;\r\n CM_CURSORCHANGED:\r\n CursorChanged;\r\n CM_SHOWINGCHANGED:\r\n ShowingChanged;\r\n CM_SHOWHINTCHANGED:\r\n ShowHintChanged;\r\n CM_CONTROLLISTCHANGE:\r\n if Msg.LParam <> 0 then\r\n ControlsListChanging(TControl(Msg.WParam), True)\r\n else\r\n ControlsListChanged(TControl(Msg.WParam), False);\r\n CM_CONTROLCHANGE:\r\n if Msg.LParam = 0 then\r\n ControlsListChanging(TControl(Msg.WParam), False)\r\n else\r\n ControlsListChanged(TControl(Msg.WParam), True);\r\n WM_SETFOCUS:\r\n FocusSet(THandle(Msg.WParam));\r\n WM_KILLFOCUS:\r\n FocusKilled(THandle(Msg.WParam));\r\n WM_SIZE, WM_MOVE:\r\n begin\r\n inherited WndProc(Msg);\r\n BoundsChanged;\r\n end;\r\n WM_ERASEBKGND:\r\n if (Msg.WParam <> 0) and not IsDefaultEraseBackground(DoEraseBackground, @TJvExCustomTreeView.DoEraseBackground) then\r\n begin\r\n IdSaveDC := SaveDC(HDC(Msg.WParam)); // protect DC against Stock-Objects from Canvas\r\n Canvas := TCanvas.Create;\r\n try\r\n Canvas.Handle := HDC(Msg.WParam);\r\n Msg.Result := Ord(DoEraseBackground(Canvas, Msg.LParam));\r\n finally\r\n Canvas.Handle := 0;\r\n Canvas.Free;\r\n RestoreDC(HDC(Msg.WParam), IdSaveDC);\r\n end;\r\n end\r\n else\r\n inherited WndProc(Msg);\r\n {$IFNDEF DELPHI2007_UP}\r\n WM_PRINTCLIENT, WM_PRINT: // VCL bug fix\r\n begin\r\n IdSaveDC := SaveDC(HDC(Msg.WParam)); // protect DC against changes\r\n try\r\n inherited WndProc(Msg);\r\n finally\r\n RestoreDC(HDC(Msg.WParam), IdSaveDC);\r\n end;\r\n end;\r\n {$ENDIF ~DELPHI2007_UP}\r\n WM_GETDLGCODE:\r\n begin\r\n inherited WndProc(Msg);\r\n DlgCodes := [dcNative] + DlgcToDlgCodes(Msg.Result);\r\n GetDlgCode(DlgCodes);\r\n if not (dcNative in DlgCodes) then\r\n Msg.Result := DlgCodesToDlgc(DlgCodes);\r\n end;\r\n else\r\n inherited WndProc(Msg);\r\n end;\r\n case Msg.Msg of // precheck message to prevent access violations on released controls\r\n CM_MOUSEENTER, CM_MOUSELEAVE, WM_KILLFOCUS, WM_SETFOCUS, WM_NCPAINT:\r\n if DotNetHighlighting then\r\n HandleDotNetHighlighting(Self, Msg, MouseOver, Color);\r\n end;\r\n end;\r\nend;\r\n\r\n//============================================================================\r\n\r\nconstructor TJvExTreeView.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FHintColor := clDefault;\r\nend;\r\n\r\nfunction TJvExTreeView.BaseWndProc(Msg: Cardinal; WParam: WPARAM = 0; LParam: LPARAM = 0): LRESULT;\r\nvar\r\n Mesg: TMessage;\r\nbegin\r\n CreateWMMessage(Mesg, Msg, WParam, LParam);\r\n inherited WndProc(Mesg);\r\n Result := Mesg.Result;\r\nend;\r\n\r\nfunction TJvExTreeView.BaseWndProc(Msg: Cardinal; WParam: WPARAM; LParam: TObject): LRESULT;\r\nbegin\r\n Result := BaseWndProc(Msg, WParam, Windows.LPARAM(LParam));\r\nend;\r\n\r\nfunction TJvExTreeView.BaseWndProcEx(Msg: Cardinal; WParam: WPARAM; var StructLParam): LRESULT;\r\nbegin\r\n Result := BaseWndProc(Msg, WParam, Windows.LPARAM(@StructLParam));\r\nend;\r\n\r\nprocedure TJvExTreeView.VisibleChanged;\r\nbegin\r\n BaseWndProc(CM_VISIBLECHANGED);\r\nend;\r\n\r\nprocedure TJvExTreeView.EnabledChanged;\r\nbegin\r\n BaseWndProc(CM_ENABLEDCHANGED);\r\nend;\r\n\r\nprocedure TJvExTreeView.TextChanged;\r\nbegin\r\n BaseWndProc(CM_TEXTCHANGED);\r\nend;\r\n\r\nprocedure TJvExTreeView.FontChanged;\r\nbegin\r\n BaseWndProc(CM_FONTCHANGED);\r\nend;\r\n\r\nprocedure TJvExTreeView.ColorChanged;\r\nbegin\r\n BaseWndProc(CM_COLORCHANGED);\r\nend;\r\n\r\nprocedure TJvExTreeView.ParentFontChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTFONTCHANGED);\r\nend;\r\n\r\nprocedure TJvExTreeView.ParentColorChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTCOLORCHANGED);\r\n if Assigned(OnParentColorChange) then\r\n OnParentColorChange(Self);\r\nend;\r\n\r\nprocedure TJvExTreeView.ParentShowHintChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTSHOWHINTCHANGED);\r\nend;\r\n\r\nfunction TJvExTreeView.WantKey(Key: Integer; Shift: TShiftState): Boolean;\r\nbegin\r\n Result := BaseWndProc(CM_DIALOGCHAR, Word(Key), ShiftStateToKeyData(Shift)) <> 0;\r\nend;\r\n\r\nfunction TJvExTreeView.HitTest(X, Y: Integer): Boolean;\r\nbegin\r\n Result := BaseWndProc(CM_HITTEST, 0, SmallPointToLong(PointToSmallPoint(Point(X, Y)))) <> 0;\r\nend;\r\n\r\nfunction TJvExTreeView.HintShow(var HintInfo: THintInfo): Boolean;\r\nbegin\r\n GetHintColor(HintInfo, Self, FHintColor);\r\n if FHintWindowClass <> nil then\r\n HintInfo.HintWindowClass := FHintWindowClass;\r\n Result := BaseWndProcEx(CM_HINTSHOW, 0, HintInfo) <> 0;\r\nend;\r\n\r\nprocedure TJvExTreeView.MouseEnter(AControl: TControl);\r\nbegin\r\n FMouseOver := True;\r\n if Assigned(FOnMouseEnter) then\r\n FOnMouseEnter(Self);\r\n BaseWndProc(CM_MOUSEENTER, 0, AControl);\r\nend;\r\n\r\nprocedure TJvExTreeView.MouseLeave(AControl: TControl);\r\nbegin\r\n FMouseOver := False;\r\n BaseWndProc(CM_MOUSELEAVE, 0, AControl);\r\n if Assigned(FOnMouseLeave) then\r\n FOnMouseLeave(Self);\r\nend;\r\n\r\nprocedure TJvExTreeView.FocusChanged(AControl: TWinControl);\r\nbegin\r\n BaseWndProc(CM_FOCUSCHANGED, 0, AControl);\r\nend;\r\n\r\nprocedure TJvExTreeView.BoundsChanged;\r\nbegin\r\nend;\r\n\r\nprocedure TJvExTreeView.CursorChanged;\r\nbegin\r\n BaseWndProc(CM_CURSORCHANGED);\r\nend;\r\n\r\nprocedure TJvExTreeView.ShowingChanged;\r\nbegin\r\n BaseWndProc(CM_SHOWINGCHANGED);\r\nend;\r\n\r\nprocedure TJvExTreeView.ShowHintChanged;\r\nbegin\r\n BaseWndProc(CM_SHOWHINTCHANGED);\r\nend;\r\n\r\n{ VCL sends CM_CONTROLLISTCHANGE and CM_CONTROLCHANGE in a different order than\r\n the CLX methods are used. So we must correct it by evaluating \"Inserting\". }\r\nprocedure TJvExTreeView.ControlsListChanging(Control: TControl; Inserting: Boolean);\r\nbegin\r\n if Inserting then\r\n BaseWndProc(CM_CONTROLLISTCHANGE, WPARAM(Control), LPARAM(Inserting))\r\n else\r\n BaseWndProc(CM_CONTROLCHANGE, WPARAM(Control), LPARAM(Inserting));\r\nend;\r\n\r\nprocedure TJvExTreeView.ControlsListChanged(Control: TControl; Inserting: Boolean);\r\nbegin\r\n if not Inserting then\r\n BaseWndProc(CM_CONTROLLISTCHANGE, WPARAM(Control), LPARAM(Inserting))\r\n else\r\n BaseWndProc(CM_CONTROLCHANGE, WPARAM(Control), LPARAM(Inserting));\r\nend;\r\n\r\nprocedure TJvExTreeView.GetDlgCode(var Code: TDlgCodes);\r\nbegin\r\nend;\r\n\r\nprocedure TJvExTreeView.FocusSet(PrevWnd: THandle);\r\nbegin\r\n BaseWndProc(WM_SETFOCUS, WPARAM(PrevWnd), 0);\r\nend;\r\n\r\nprocedure TJvExTreeView.FocusKilled(NextWnd: THandle);\r\nbegin\r\n BaseWndProc(WM_KILLFOCUS, WPARAM(NextWnd), 0);\r\nend;\r\n\r\nfunction TJvExTreeView.DoEraseBackground(Canvas: TCanvas; Param: LPARAM): Boolean;\r\nbegin\r\n Result := BaseWndProc(WM_ERASEBKGND, Canvas.Handle, Param) <> 0;\r\nend;\r\n\r\n{$IFDEF JVCLThemesEnabledD6}\r\nfunction TJvExTreeView.GetParentBackground: Boolean;\r\nbegin\r\n Result := JvThemes.GetParentBackground(Self);\r\nend;\r\n\r\nprocedure TJvExTreeView.SetParentBackground(Value: Boolean);\r\nbegin\r\n JvThemes.SetParentBackground(Self, Value);\r\nend;\r\n{$ENDIF JVCLThemesEnabledD6}\r\n\r\nprocedure TJvExTreeView.WndProc(var Msg: TMessage);\r\nvar\r\n IdSaveDC: Integer;\r\n DlgCodes: TDlgCodes;\r\n Canvas: TCanvas;\r\nbegin\r\n if not DispatchIsDesignMsg(Self, Msg) then\r\n begin\r\n case Msg.Msg of\r\n CM_DENYSUBCLASSING:\r\n Msg.Result := LRESULT(Ord(GetInterfaceEntry(IJvDenySubClassing) <> nil));\r\n CM_DIALOGCHAR:\r\n with TCMDialogChar{$IFDEF CLR}.Create{$ENDIF}(Msg) do\r\n Result := LRESULT(Ord(WantKey(CharCode, KeyDataToShiftState(KeyData))));\r\n CM_HINTSHOW:\r\n with TCMHintShow(Msg) do\r\n Result := LRESULT(HintShow(HintInfo^));\r\n CM_HITTEST:\r\n with TCMHitTest(Msg) do\r\n Result := LRESULT(HitTest(XPos, YPos));\r\n CM_MOUSEENTER:\r\n MouseEnter(TControl(Msg.LParam));\r\n CM_MOUSELEAVE:\r\n MouseLeave(TControl(Msg.LParam));\r\n CM_VISIBLECHANGED:\r\n VisibleChanged;\r\n CM_ENABLEDCHANGED:\r\n EnabledChanged;\r\n CM_TEXTCHANGED:\r\n TextChanged;\r\n CM_FONTCHANGED:\r\n FontChanged;\r\n CM_COLORCHANGED:\r\n ColorChanged;\r\n CM_FOCUSCHANGED:\r\n FocusChanged(TWinControl(Msg.LParam));\r\n CM_PARENTFONTCHANGED:\r\n ParentFontChanged;\r\n CM_PARENTCOLORCHANGED:\r\n ParentColorChanged;\r\n CM_PARENTSHOWHINTCHANGED:\r\n ParentShowHintChanged;\r\n CM_CURSORCHANGED:\r\n CursorChanged;\r\n CM_SHOWINGCHANGED:\r\n ShowingChanged;\r\n CM_SHOWHINTCHANGED:\r\n ShowHintChanged;\r\n CM_CONTROLLISTCHANGE:\r\n if Msg.LParam <> 0 then\r\n ControlsListChanging(TControl(Msg.WParam), True)\r\n else\r\n ControlsListChanged(TControl(Msg.WParam), False);\r\n CM_CONTROLCHANGE:\r\n if Msg.LParam = 0 then\r\n ControlsListChanging(TControl(Msg.WParam), False)\r\n else\r\n ControlsListChanged(TControl(Msg.WParam), True);\r\n WM_SETFOCUS:\r\n FocusSet(THandle(Msg.WParam));\r\n WM_KILLFOCUS:\r\n FocusKilled(THandle(Msg.WParam));\r\n WM_SIZE, WM_MOVE:\r\n begin\r\n inherited WndProc(Msg);\r\n BoundsChanged;\r\n end;\r\n WM_ERASEBKGND:\r\n if (Msg.WParam <> 0) and not IsDefaultEraseBackground(DoEraseBackground, @TJvExTreeView.DoEraseBackground) then\r\n begin\r\n IdSaveDC := SaveDC(HDC(Msg.WParam)); // protect DC against Stock-Objects from Canvas\r\n Canvas := TCanvas.Create;\r\n try\r\n Canvas.Handle := HDC(Msg.WParam);\r\n Msg.Result := Ord(DoEraseBackground(Canvas, Msg.LParam));\r\n finally\r\n Canvas.Handle := 0;\r\n Canvas.Free;\r\n RestoreDC(HDC(Msg.WParam), IdSaveDC);\r\n end;\r\n end\r\n else\r\n inherited WndProc(Msg);\r\n {$IFNDEF DELPHI2007_UP}\r\n WM_PRINTCLIENT, WM_PRINT: // VCL bug fix\r\n begin\r\n IdSaveDC := SaveDC(HDC(Msg.WParam)); // protect DC against changes\r\n try\r\n inherited WndProc(Msg);\r\n finally\r\n RestoreDC(HDC(Msg.WParam), IdSaveDC);\r\n end;\r\n end;\r\n {$ENDIF ~DELPHI2007_UP}\r\n WM_GETDLGCODE:\r\n begin\r\n inherited WndProc(Msg);\r\n DlgCodes := [dcNative] + DlgcToDlgCodes(Msg.Result);\r\n GetDlgCode(DlgCodes);\r\n if not (dcNative in DlgCodes) then\r\n Msg.Result := DlgCodesToDlgc(DlgCodes);\r\n end;\r\n else\r\n inherited WndProc(Msg);\r\n end;\r\n case Msg.Msg of // precheck message to prevent access violations on released controls\r\n CM_MOUSEENTER, CM_MOUSELEAVE, WM_KILLFOCUS, WM_SETFOCUS, WM_NCPAINT:\r\n if DotNetHighlighting then\r\n HandleDotNetHighlighting(Self, Msg, MouseOver, Color);\r\n end;\r\n end;\r\nend;\r\n\r\n//============================================================================\r\n\r\nconstructor TJvExTrackBar.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FHintColor := clDefault;\r\nend;\r\n\r\nfunction TJvExTrackBar.BaseWndProc(Msg: Cardinal; WParam: WPARAM = 0; LParam: LPARAM = 0): LRESULT;\r\nvar\r\n Mesg: TMessage;\r\nbegin\r\n CreateWMMessage(Mesg, Msg, WParam, LParam);\r\n inherited WndProc(Mesg);\r\n Result := Mesg.Result;\r\nend;\r\n\r\nfunction TJvExTrackBar.BaseWndProc(Msg: Cardinal; WParam: WPARAM; LParam: TObject): LRESULT;\r\nbegin\r\n Result := BaseWndProc(Msg, WParam, Windows.LPARAM(LParam));\r\nend;\r\n\r\nfunction TJvExTrackBar.BaseWndProcEx(Msg: Cardinal; WParam: WPARAM; var StructLParam): LRESULT;\r\nbegin\r\n Result := BaseWndProc(Msg, WParam, Windows.LPARAM(@StructLParam));\r\nend;\r\n\r\nprocedure TJvExTrackBar.VisibleChanged;\r\nbegin\r\n BaseWndProc(CM_VISIBLECHANGED);\r\nend;\r\n\r\nprocedure TJvExTrackBar.EnabledChanged;\r\nbegin\r\n BaseWndProc(CM_ENABLEDCHANGED);\r\nend;\r\n\r\nprocedure TJvExTrackBar.TextChanged;\r\nbegin\r\n BaseWndProc(CM_TEXTCHANGED);\r\nend;\r\n\r\nprocedure TJvExTrackBar.FontChanged;\r\nbegin\r\n BaseWndProc(CM_FONTCHANGED);\r\nend;\r\n\r\nprocedure TJvExTrackBar.ColorChanged;\r\nbegin\r\n BaseWndProc(CM_COLORCHANGED);\r\nend;\r\n\r\nprocedure TJvExTrackBar.ParentFontChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTFONTCHANGED);\r\nend;\r\n\r\nprocedure TJvExTrackBar.ParentColorChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTCOLORCHANGED);\r\n if Assigned(OnParentColorChange) then\r\n OnParentColorChange(Self);\r\nend;\r\n\r\nprocedure TJvExTrackBar.ParentShowHintChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTSHOWHINTCHANGED);\r\nend;\r\n\r\nfunction TJvExTrackBar.WantKey(Key: Integer; Shift: TShiftState): Boolean;\r\nbegin\r\n Result := BaseWndProc(CM_DIALOGCHAR, Word(Key), ShiftStateToKeyData(Shift)) <> 0;\r\nend;\r\n\r\nfunction TJvExTrackBar.HitTest(X, Y: Integer): Boolean;\r\nbegin\r\n Result := BaseWndProc(CM_HITTEST, 0, SmallPointToLong(PointToSmallPoint(Point(X, Y)))) <> 0;\r\nend;\r\n\r\nfunction TJvExTrackBar.HintShow(var HintInfo: THintInfo): Boolean;\r\nbegin\r\n GetHintColor(HintInfo, Self, FHintColor);\r\n if FHintWindowClass <> nil then\r\n HintInfo.HintWindowClass := FHintWindowClass;\r\n Result := BaseWndProcEx(CM_HINTSHOW, 0, HintInfo) <> 0;\r\nend;\r\n\r\nprocedure TJvExTrackBar.MouseEnter(AControl: TControl);\r\nbegin\r\n FMouseOver := True;\r\n if Assigned(FOnMouseEnter) then\r\n FOnMouseEnter(Self);\r\n BaseWndProc(CM_MOUSEENTER, 0, AControl);\r\nend;\r\n\r\nprocedure TJvExTrackBar.MouseLeave(AControl: TControl);\r\nbegin\r\n FMouseOver := False;\r\n BaseWndProc(CM_MOUSELEAVE, 0, AControl);\r\n if Assigned(FOnMouseLeave) then\r\n FOnMouseLeave(Self);\r\nend;\r\n\r\nprocedure TJvExTrackBar.FocusChanged(AControl: TWinControl);\r\nbegin\r\n BaseWndProc(CM_FOCUSCHANGED, 0, AControl);\r\nend;\r\n\r\nprocedure TJvExTrackBar.BoundsChanged;\r\nbegin\r\nend;\r\n\r\nprocedure TJvExTrackBar.CursorChanged;\r\nbegin\r\n BaseWndProc(CM_CURSORCHANGED);\r\nend;\r\n\r\nprocedure TJvExTrackBar.ShowingChanged;\r\nbegin\r\n BaseWndProc(CM_SHOWINGCHANGED);\r\nend;\r\n\r\nprocedure TJvExTrackBar.ShowHintChanged;\r\nbegin\r\n BaseWndProc(CM_SHOWHINTCHANGED);\r\nend;\r\n\r\n{ VCL sends CM_CONTROLLISTCHANGE and CM_CONTROLCHANGE in a different order than\r\n the CLX methods are used. So we must correct it by evaluating \"Inserting\". }\r\nprocedure TJvExTrackBar.ControlsListChanging(Control: TControl; Inserting: Boolean);\r\nbegin\r\n if Inserting then\r\n BaseWndProc(CM_CONTROLLISTCHANGE, WPARAM(Control), LPARAM(Inserting))\r\n else\r\n BaseWndProc(CM_CONTROLCHANGE, WPARAM(Control), LPARAM(Inserting));\r\nend;\r\n\r\nprocedure TJvExTrackBar.ControlsListChanged(Control: TControl; Inserting: Boolean);\r\nbegin\r\n if not Inserting then\r\n BaseWndProc(CM_CONTROLLISTCHANGE, WPARAM(Control), LPARAM(Inserting))\r\n else\r\n BaseWndProc(CM_CONTROLCHANGE, WPARAM(Control), LPARAM(Inserting));\r\nend;\r\n\r\nprocedure TJvExTrackBar.GetDlgCode(var Code: TDlgCodes);\r\nbegin\r\nend;\r\n\r\nprocedure TJvExTrackBar.FocusSet(PrevWnd: THandle);\r\nbegin\r\n BaseWndProc(WM_SETFOCUS, WPARAM(PrevWnd), 0);\r\nend;\r\n\r\nprocedure TJvExTrackBar.FocusKilled(NextWnd: THandle);\r\nbegin\r\n BaseWndProc(WM_KILLFOCUS, WPARAM(NextWnd), 0);\r\nend;\r\n\r\nfunction TJvExTrackBar.DoEraseBackground(Canvas: TCanvas; Param: LPARAM): Boolean;\r\nbegin\r\n Result := BaseWndProc(WM_ERASEBKGND, Canvas.Handle, Param) <> 0;\r\nend;\r\n\r\n{$IFDEF JVCLThemesEnabledD6}\r\nfunction TJvExTrackBar.GetParentBackground: Boolean;\r\nbegin\r\n Result := JvThemes.GetParentBackground(Self);\r\nend;\r\n\r\nprocedure TJvExTrackBar.SetParentBackground(Value: Boolean);\r\nbegin\r\n JvThemes.SetParentBackground(Self, Value);\r\nend;\r\n{$ENDIF JVCLThemesEnabledD6}\r\n\r\nprocedure TJvExTrackBar.WndProc(var Msg: TMessage);\r\nvar\r\n IdSaveDC: Integer;\r\n DlgCodes: TDlgCodes;\r\n Canvas: TCanvas;\r\nbegin\r\n if not DispatchIsDesignMsg(Self, Msg) then\r\n begin\r\n case Msg.Msg of\r\n CM_DENYSUBCLASSING:\r\n Msg.Result := LRESULT(Ord(GetInterfaceEntry(IJvDenySubClassing) <> nil));\r\n CM_DIALOGCHAR:\r\n with TCMDialogChar{$IFDEF CLR}.Create{$ENDIF}(Msg) do\r\n Result := LRESULT(Ord(WantKey(CharCode, KeyDataToShiftState(KeyData))));\r\n CM_HINTSHOW:\r\n with TCMHintShow(Msg) do\r\n Result := LRESULT(HintShow(HintInfo^));\r\n CM_HITTEST:\r\n with TCMHitTest(Msg) do\r\n Result := LRESULT(HitTest(XPos, YPos));\r\n CM_MOUSEENTER:\r\n MouseEnter(TControl(Msg.LParam));\r\n CM_MOUSELEAVE:\r\n MouseLeave(TControl(Msg.LParam));\r\n CM_VISIBLECHANGED:\r\n VisibleChanged;\r\n CM_ENABLEDCHANGED:\r\n EnabledChanged;\r\n CM_TEXTCHANGED:\r\n TextChanged;\r\n CM_FONTCHANGED:\r\n FontChanged;\r\n CM_COLORCHANGED:\r\n ColorChanged;\r\n CM_FOCUSCHANGED:\r\n FocusChanged(TWinControl(Msg.LParam));\r\n CM_PARENTFONTCHANGED:\r\n ParentFontChanged;\r\n CM_PARENTCOLORCHANGED:\r\n ParentColorChanged;\r\n CM_PARENTSHOWHINTCHANGED:\r\n ParentShowHintChanged;\r\n CM_CURSORCHANGED:\r\n CursorChanged;\r\n CM_SHOWINGCHANGED:\r\n ShowingChanged;\r\n CM_SHOWHINTCHANGED:\r\n ShowHintChanged;\r\n CM_CONTROLLISTCHANGE:\r\n if Msg.LParam <> 0 then\r\n ControlsListChanging(TControl(Msg.WParam), True)\r\n else\r\n ControlsListChanged(TControl(Msg.WParam), False);\r\n CM_CONTROLCHANGE:\r\n if Msg.LParam = 0 then\r\n ControlsListChanging(TControl(Msg.WParam), False)\r\n else\r\n ControlsListChanged(TControl(Msg.WParam), True);\r\n WM_SETFOCUS:\r\n FocusSet(THandle(Msg.WParam));\r\n WM_KILLFOCUS:\r\n FocusKilled(THandle(Msg.WParam));\r\n WM_SIZE, WM_MOVE:\r\n begin\r\n inherited WndProc(Msg);\r\n BoundsChanged;\r\n end;\r\n WM_ERASEBKGND:\r\n if (Msg.WParam <> 0) and not IsDefaultEraseBackground(DoEraseBackground, @TJvExTrackBar.DoEraseBackground) then\r\n begin\r\n IdSaveDC := SaveDC(HDC(Msg.WParam)); // protect DC against Stock-Objects from Canvas\r\n Canvas := TCanvas.Create;\r\n try\r\n Canvas.Handle := HDC(Msg.WParam);\r\n Msg.Result := Ord(DoEraseBackground(Canvas, Msg.LParam));\r\n finally\r\n Canvas.Handle := 0;\r\n Canvas.Free;\r\n RestoreDC(HDC(Msg.WParam), IdSaveDC);\r\n end;\r\n end\r\n else\r\n inherited WndProc(Msg);\r\n {$IFNDEF DELPHI2007_UP}\r\n WM_PRINTCLIENT, WM_PRINT: // VCL bug fix\r\n begin\r\n IdSaveDC := SaveDC(HDC(Msg.WParam)); // protect DC against changes\r\n try\r\n inherited WndProc(Msg);\r\n finally\r\n RestoreDC(HDC(Msg.WParam), IdSaveDC);\r\n end;\r\n end;\r\n {$ENDIF ~DELPHI2007_UP}\r\n WM_GETDLGCODE:\r\n begin\r\n inherited WndProc(Msg);\r\n DlgCodes := [dcNative] + DlgcToDlgCodes(Msg.Result);\r\n GetDlgCode(DlgCodes);\r\n if not (dcNative in DlgCodes) then\r\n Msg.Result := DlgCodesToDlgc(DlgCodes);\r\n end;\r\n else\r\n inherited WndProc(Msg);\r\n end;\r\n case Msg.Msg of // precheck message to prevent access violations on released controls\r\n CM_MOUSEENTER, CM_MOUSELEAVE, WM_KILLFOCUS, WM_SETFOCUS, WM_NCPAINT:\r\n if DotNetHighlighting then\r\n HandleDotNetHighlighting(Self, Msg, MouseOver, Color);\r\n end;\r\n end;\r\nend;\r\n\r\n//============================================================================\r\n\r\nconstructor TJvExAnimate.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FHintColor := clDefault;\r\nend;\r\n\r\nfunction TJvExAnimate.BaseWndProc(Msg: Cardinal; WParam: WPARAM = 0; LParam: LPARAM = 0): LRESULT;\r\nvar\r\n Mesg: TMessage;\r\nbegin\r\n CreateWMMessage(Mesg, Msg, WParam, LParam);\r\n inherited WndProc(Mesg);\r\n Result := Mesg.Result;\r\nend;\r\n\r\nfunction TJvExAnimate.BaseWndProc(Msg: Cardinal; WParam: WPARAM; LParam: TObject): LRESULT;\r\nbegin\r\n Result := BaseWndProc(Msg, WParam, Windows.LPARAM(LParam));\r\nend;\r\n\r\nfunction TJvExAnimate.BaseWndProcEx(Msg: Cardinal; WParam: WPARAM; var StructLParam): LRESULT;\r\nbegin\r\n Result := BaseWndProc(Msg, WParam, Windows.LPARAM(@StructLParam));\r\nend;\r\n\r\nprocedure TJvExAnimate.VisibleChanged;\r\nbegin\r\n BaseWndProc(CM_VISIBLECHANGED);\r\nend;\r\n\r\nprocedure TJvExAnimate.EnabledChanged;\r\nbegin\r\n BaseWndProc(CM_ENABLEDCHANGED);\r\nend;\r\n\r\nprocedure TJvExAnimate.TextChanged;\r\nbegin\r\n BaseWndProc(CM_TEXTCHANGED);\r\nend;\r\n\r\nprocedure TJvExAnimate.FontChanged;\r\nbegin\r\n BaseWndProc(CM_FONTCHANGED);\r\nend;\r\n\r\nprocedure TJvExAnimate.ColorChanged;\r\nbegin\r\n BaseWndProc(CM_COLORCHANGED);\r\nend;\r\n\r\nprocedure TJvExAnimate.ParentFontChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTFONTCHANGED);\r\nend;\r\n\r\nprocedure TJvExAnimate.ParentColorChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTCOLORCHANGED);\r\n if Assigned(OnParentColorChange) then\r\n OnParentColorChange(Self);\r\nend;\r\n\r\nprocedure TJvExAnimate.ParentShowHintChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTSHOWHINTCHANGED);\r\nend;\r\n\r\nfunction TJvExAnimate.WantKey(Key: Integer; Shift: TShiftState): Boolean;\r\nbegin\r\n Result := BaseWndProc(CM_DIALOGCHAR, Word(Key), ShiftStateToKeyData(Shift)) <> 0;\r\nend;\r\n\r\nfunction TJvExAnimate.HitTest(X, Y: Integer): Boolean;\r\nbegin\r\n Result := BaseWndProc(CM_HITTEST, 0, SmallPointToLong(PointToSmallPoint(Point(X, Y)))) <> 0;\r\nend;\r\n\r\nfunction TJvExAnimate.HintShow(var HintInfo: THintInfo): Boolean;\r\nbegin\r\n GetHintColor(HintInfo, Self, FHintColor);\r\n if FHintWindowClass <> nil then\r\n HintInfo.HintWindowClass := FHintWindowClass;\r\n Result := BaseWndProcEx(CM_HINTSHOW, 0, HintInfo) <> 0;\r\nend;\r\n\r\nprocedure TJvExAnimate.MouseEnter(AControl: TControl);\r\nbegin\r\n FMouseOver := True;\r\n if Assigned(FOnMouseEnter) then\r\n FOnMouseEnter(Self);\r\n BaseWndProc(CM_MOUSEENTER, 0, AControl);\r\nend;\r\n\r\nprocedure TJvExAnimate.MouseLeave(AControl: TControl);\r\nbegin\r\n FMouseOver := False;\r\n BaseWndProc(CM_MOUSELEAVE, 0, AControl);\r\n if Assigned(FOnMouseLeave) then\r\n FOnMouseLeave(Self);\r\nend;\r\n\r\nprocedure TJvExAnimate.FocusChanged(AControl: TWinControl);\r\nbegin\r\n BaseWndProc(CM_FOCUSCHANGED, 0, AControl);\r\nend;\r\n\r\nprocedure TJvExAnimate.BoundsChanged;\r\nbegin\r\nend;\r\n\r\nprocedure TJvExAnimate.CursorChanged;\r\nbegin\r\n BaseWndProc(CM_CURSORCHANGED);\r\nend;\r\n\r\nprocedure TJvExAnimate.ShowingChanged;\r\nbegin\r\n BaseWndProc(CM_SHOWINGCHANGED);\r\nend;\r\n\r\nprocedure TJvExAnimate.ShowHintChanged;\r\nbegin\r\n BaseWndProc(CM_SHOWHINTCHANGED);\r\nend;\r\n\r\n{ VCL sends CM_CONTROLLISTCHANGE and CM_CONTROLCHANGE in a different order than\r\n the CLX methods are used. So we must correct it by evaluating \"Inserting\". }\r\nprocedure TJvExAnimate.ControlsListChanging(Control: TControl; Inserting: Boolean);\r\nbegin\r\n if Inserting then\r\n BaseWndProc(CM_CONTROLLISTCHANGE, WPARAM(Control), LPARAM(Inserting))\r\n else\r\n BaseWndProc(CM_CONTROLCHANGE, WPARAM(Control), LPARAM(Inserting));\r\nend;\r\n\r\nprocedure TJvExAnimate.ControlsListChanged(Control: TControl; Inserting: Boolean);\r\nbegin\r\n if not Inserting then\r\n BaseWndProc(CM_CONTROLLISTCHANGE, WPARAM(Control), LPARAM(Inserting))\r\n else\r\n BaseWndProc(CM_CONTROLCHANGE, WPARAM(Control), LPARAM(Inserting));\r\nend;\r\n\r\nprocedure TJvExAnimate.GetDlgCode(var Code: TDlgCodes);\r\nbegin\r\nend;\r\n\r\nprocedure TJvExAnimate.FocusSet(PrevWnd: THandle);\r\nbegin\r\n BaseWndProc(WM_SETFOCUS, WPARAM(PrevWnd), 0);\r\nend;\r\n\r\nprocedure TJvExAnimate.FocusKilled(NextWnd: THandle);\r\nbegin\r\n BaseWndProc(WM_KILLFOCUS, WPARAM(NextWnd), 0);\r\nend;\r\n\r\nfunction TJvExAnimate.DoEraseBackground(Canvas: TCanvas; Param: LPARAM): Boolean;\r\nbegin\r\n Result := BaseWndProc(WM_ERASEBKGND, Canvas.Handle, Param) <> 0;\r\nend;\r\n\r\n{$IFDEF JVCLThemesEnabledD6}\r\nfunction TJvExAnimate.GetParentBackground: Boolean;\r\nbegin\r\n Result := JvThemes.GetParentBackground(Self);\r\nend;\r\n\r\nprocedure TJvExAnimate.SetParentBackground(Value: Boolean);\r\nbegin\r\n JvThemes.SetParentBackground(Self, Value);\r\nend;\r\n{$ENDIF JVCLThemesEnabledD6}\r\n\r\nprocedure TJvExAnimate.WndProc(var Msg: TMessage);\r\nvar\r\n IdSaveDC: Integer;\r\n DlgCodes: TDlgCodes;\r\n Canvas: TCanvas;\r\nbegin\r\n if not DispatchIsDesignMsg(Self, Msg) then\r\n begin\r\n case Msg.Msg of\r\n CM_DENYSUBCLASSING:\r\n Msg.Result := LRESULT(Ord(GetInterfaceEntry(IJvDenySubClassing) <> nil));\r\n CM_DIALOGCHAR:\r\n with TCMDialogChar{$IFDEF CLR}.Create{$ENDIF}(Msg) do\r\n Result := LRESULT(Ord(WantKey(CharCode, KeyDataToShiftState(KeyData))));\r\n CM_HINTSHOW:\r\n with TCMHintShow(Msg) do\r\n Result := LRESULT(HintShow(HintInfo^));\r\n CM_HITTEST:\r\n with TCMHitTest(Msg) do\r\n Result := LRESULT(HitTest(XPos, YPos));\r\n CM_MOUSEENTER:\r\n MouseEnter(TControl(Msg.LParam));\r\n CM_MOUSELEAVE:\r\n MouseLeave(TControl(Msg.LParam));\r\n CM_VISIBLECHANGED:\r\n VisibleChanged;\r\n CM_ENABLEDCHANGED:\r\n EnabledChanged;\r\n CM_TEXTCHANGED:\r\n TextChanged;\r\n CM_FONTCHANGED:\r\n FontChanged;\r\n CM_COLORCHANGED:\r\n ColorChanged;\r\n CM_FOCUSCHANGED:\r\n FocusChanged(TWinControl(Msg.LParam));\r\n CM_PARENTFONTCHANGED:\r\n ParentFontChanged;\r\n CM_PARENTCOLORCHANGED:\r\n ParentColorChanged;\r\n CM_PARENTSHOWHINTCHANGED:\r\n ParentShowHintChanged;\r\n CM_CURSORCHANGED:\r\n CursorChanged;\r\n CM_SHOWINGCHANGED:\r\n ShowingChanged;\r\n CM_SHOWHINTCHANGED:\r\n ShowHintChanged;\r\n CM_CONTROLLISTCHANGE:\r\n if Msg.LParam <> 0 then\r\n ControlsListChanging(TControl(Msg.WParam), True)\r\n else\r\n ControlsListChanged(TControl(Msg.WParam), False);\r\n CM_CONTROLCHANGE:\r\n if Msg.LParam = 0 then\r\n ControlsListChanging(TControl(Msg.WParam), False)\r\n else\r\n ControlsListChanged(TControl(Msg.WParam), True);\r\n WM_SETFOCUS:\r\n FocusSet(THandle(Msg.WParam));\r\n WM_KILLFOCUS:\r\n FocusKilled(THandle(Msg.WParam));\r\n WM_SIZE, WM_MOVE:\r\n begin\r\n inherited WndProc(Msg);\r\n BoundsChanged;\r\n end;\r\n WM_ERASEBKGND:\r\n if (Msg.WParam <> 0) and not IsDefaultEraseBackground(DoEraseBackground, @TJvExAnimate.DoEraseBackground) then\r\n begin\r\n IdSaveDC := SaveDC(HDC(Msg.WParam)); // protect DC against Stock-Objects from Canvas\r\n Canvas := TCanvas.Create;\r\n try\r\n Canvas.Handle := HDC(Msg.WParam);\r\n Msg.Result := Ord(DoEraseBackground(Canvas, Msg.LParam));\r\n finally\r\n Canvas.Handle := 0;\r\n Canvas.Free;\r\n RestoreDC(HDC(Msg.WParam), IdSaveDC);\r\n end;\r\n end\r\n else\r\n inherited WndProc(Msg);\r\n {$IFNDEF DELPHI2007_UP}\r\n WM_PRINTCLIENT, WM_PRINT: // VCL bug fix\r\n begin\r\n IdSaveDC := SaveDC(HDC(Msg.WParam)); // protect DC against changes\r\n try\r\n inherited WndProc(Msg);\r\n finally\r\n RestoreDC(HDC(Msg.WParam), IdSaveDC);\r\n end;\r\n end;\r\n {$ENDIF ~DELPHI2007_UP}\r\n WM_GETDLGCODE:\r\n begin\r\n inherited WndProc(Msg);\r\n DlgCodes := [dcNative] + DlgcToDlgCodes(Msg.Result);\r\n GetDlgCode(DlgCodes);\r\n if not (dcNative in DlgCodes) then\r\n Msg.Result := DlgCodesToDlgc(DlgCodes);\r\n end;\r\n else\r\n inherited WndProc(Msg);\r\n end;\r\n case Msg.Msg of // precheck message to prevent access violations on released controls\r\n CM_MOUSEENTER, CM_MOUSELEAVE, WM_KILLFOCUS, WM_SETFOCUS, WM_NCPAINT:\r\n if DotNetHighlighting then\r\n HandleDotNetHighlighting(Self, Msg, MouseOver, Color);\r\n end;\r\n end;\r\nend;\r\n\r\n//============================================================================\r\n\r\nconstructor TJvExCoolBar.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FHintColor := clDefault;\r\nend;\r\n\r\nfunction TJvExCoolBar.BaseWndProc(Msg: Cardinal; WParam: WPARAM = 0; LParam: LPARAM = 0): LRESULT;\r\nvar\r\n Mesg: TMessage;\r\nbegin\r\n CreateWMMessage(Mesg, Msg, WParam, LParam);\r\n inherited WndProc(Mesg);\r\n Result := Mesg.Result;\r\nend;\r\n\r\nfunction TJvExCoolBar.BaseWndProc(Msg: Cardinal; WParam: WPARAM; LParam: TObject): LRESULT;\r\nbegin\r\n Result := BaseWndProc(Msg, WParam, Windows.LPARAM(LParam));\r\nend;\r\n\r\nfunction TJvExCoolBar.BaseWndProcEx(Msg: Cardinal; WParam: WPARAM; var StructLParam): LRESULT;\r\nbegin\r\n Result := BaseWndProc(Msg, WParam, Windows.LPARAM(@StructLParam));\r\nend;\r\n\r\nprocedure TJvExCoolBar.VisibleChanged;\r\nbegin\r\n BaseWndProc(CM_VISIBLECHANGED);\r\nend;\r\n\r\nprocedure TJvExCoolBar.EnabledChanged;\r\nbegin\r\n BaseWndProc(CM_ENABLEDCHANGED);\r\nend;\r\n\r\nprocedure TJvExCoolBar.TextChanged;\r\nbegin\r\n BaseWndProc(CM_TEXTCHANGED);\r\nend;\r\n\r\nprocedure TJvExCoolBar.FontChanged;\r\nbegin\r\n BaseWndProc(CM_FONTCHANGED);\r\nend;\r\n\r\nprocedure TJvExCoolBar.ColorChanged;\r\nbegin\r\n BaseWndProc(CM_COLORCHANGED);\r\nend;\r\n\r\nprocedure TJvExCoolBar.ParentFontChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTFONTCHANGED);\r\nend;\r\n\r\nprocedure TJvExCoolBar.ParentColorChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTCOLORCHANGED);\r\n if Assigned(OnParentColorChange) then\r\n OnParentColorChange(Self);\r\nend;\r\n\r\nprocedure TJvExCoolBar.ParentShowHintChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTSHOWHINTCHANGED);\r\nend;\r\n\r\nfunction TJvExCoolBar.WantKey(Key: Integer; Shift: TShiftState): Boolean;\r\nbegin\r\n Result := BaseWndProc(CM_DIALOGCHAR, Word(Key), ShiftStateToKeyData(Shift)) <> 0;\r\nend;\r\n\r\nfunction TJvExCoolBar.HitTest(X, Y: Integer): Boolean;\r\nbegin\r\n Result := BaseWndProc(CM_HITTEST, 0, SmallPointToLong(PointToSmallPoint(Point(X, Y)))) <> 0;\r\nend;\r\n\r\nfunction TJvExCoolBar.HintShow(var HintInfo: THintInfo): Boolean;\r\nbegin\r\n GetHintColor(HintInfo, Self, FHintColor);\r\n if FHintWindowClass <> nil then\r\n HintInfo.HintWindowClass := FHintWindowClass;\r\n Result := BaseWndProcEx(CM_HINTSHOW, 0, HintInfo) <> 0;\r\nend;\r\n\r\nprocedure TJvExCoolBar.MouseEnter(AControl: TControl);\r\nbegin\r\n FMouseOver := True;\r\n if Assigned(FOnMouseEnter) then\r\n FOnMouseEnter(Self);\r\n BaseWndProc(CM_MOUSEENTER, 0, AControl);\r\nend;\r\n\r\nprocedure TJvExCoolBar.MouseLeave(AControl: TControl);\r\nbegin\r\n FMouseOver := False;\r\n BaseWndProc(CM_MOUSELEAVE, 0, AControl);\r\n if Assigned(FOnMouseLeave) then\r\n FOnMouseLeave(Self);\r\nend;\r\n\r\nprocedure TJvExCoolBar.FocusChanged(AControl: TWinControl);\r\nbegin\r\n BaseWndProc(CM_FOCUSCHANGED, 0, AControl);\r\nend;\r\n\r\nprocedure TJvExCoolBar.BoundsChanged;\r\nbegin\r\nend;\r\n\r\nprocedure TJvExCoolBar.CursorChanged;\r\nbegin\r\n BaseWndProc(CM_CURSORCHANGED);\r\nend;\r\n\r\nprocedure TJvExCoolBar.ShowingChanged;\r\nbegin\r\n BaseWndProc(CM_SHOWINGCHANGED);\r\nend;\r\n\r\nprocedure TJvExCoolBar.ShowHintChanged;\r\nbegin\r\n BaseWndProc(CM_SHOWHINTCHANGED);\r\nend;\r\n\r\n{ VCL sends CM_CONTROLLISTCHANGE and CM_CONTROLCHANGE in a different order than\r\n the CLX methods are used. So we must correct it by evaluating \"Inserting\". }\r\nprocedure TJvExCoolBar.ControlsListChanging(Control: TControl; Inserting: Boolean);\r\nbegin\r\n if Inserting then\r\n BaseWndProc(CM_CONTROLLISTCHANGE, WPARAM(Control), LPARAM(Inserting))\r\n else\r\n BaseWndProc(CM_CONTROLCHANGE, WPARAM(Control), LPARAM(Inserting));\r\nend;\r\n\r\nprocedure TJvExCoolBar.ControlsListChanged(Control: TControl; Inserting: Boolean);\r\nbegin\r\n if not Inserting then\r\n BaseWndProc(CM_CONTROLLISTCHANGE, WPARAM(Control), LPARAM(Inserting))\r\n else\r\n BaseWndProc(CM_CONTROLCHANGE, WPARAM(Control), LPARAM(Inserting));\r\nend;\r\n\r\nprocedure TJvExCoolBar.GetDlgCode(var Code: TDlgCodes);\r\nbegin\r\nend;\r\n\r\nprocedure TJvExCoolBar.FocusSet(PrevWnd: THandle);\r\nbegin\r\n BaseWndProc(WM_SETFOCUS, WPARAM(PrevWnd), 0);\r\nend;\r\n\r\nprocedure TJvExCoolBar.FocusKilled(NextWnd: THandle);\r\nbegin\r\n BaseWndProc(WM_KILLFOCUS, WPARAM(NextWnd), 0);\r\nend;\r\n\r\nfunction TJvExCoolBar.DoEraseBackground(Canvas: TCanvas; Param: LPARAM): Boolean;\r\nbegin\r\n Result := BaseWndProc(WM_ERASEBKGND, Canvas.Handle, Param) <> 0;\r\nend;\r\n\r\n{$IFDEF JVCLThemesEnabledD6}\r\nfunction TJvExCoolBar.GetParentBackground: Boolean;\r\nbegin\r\n Result := JvThemes.GetParentBackground(Self);\r\nend;\r\n\r\nprocedure TJvExCoolBar.SetParentBackground(Value: Boolean);\r\nbegin\r\n JvThemes.SetParentBackground(Self, Value);\r\nend;\r\n{$ENDIF JVCLThemesEnabledD6}\r\n\r\nprocedure TJvExCoolBar.WndProc(var Msg: TMessage);\r\nvar\r\n IdSaveDC: Integer;\r\n DlgCodes: TDlgCodes;\r\n Canvas: TCanvas;\r\nbegin\r\n if not DispatchIsDesignMsg(Self, Msg) then\r\n begin\r\n case Msg.Msg of\r\n CM_DENYSUBCLASSING:\r\n Msg.Result := LRESULT(Ord(GetInterfaceEntry(IJvDenySubClassing) <> nil));\r\n CM_DIALOGCHAR:\r\n with TCMDialogChar{$IFDEF CLR}.Create{$ENDIF}(Msg) do\r\n Result := LRESULT(Ord(WantKey(CharCode, KeyDataToShiftState(KeyData))));\r\n CM_HINTSHOW:\r\n with TCMHintShow(Msg) do\r\n Result := LRESULT(HintShow(HintInfo^));\r\n CM_HITTEST:\r\n with TCMHitTest(Msg) do\r\n Result := LRESULT(HitTest(XPos, YPos));\r\n CM_MOUSEENTER:\r\n MouseEnter(TControl(Msg.LParam));\r\n CM_MOUSELEAVE:\r\n MouseLeave(TControl(Msg.LParam));\r\n CM_VISIBLECHANGED:\r\n VisibleChanged;\r\n CM_ENABLEDCHANGED:\r\n EnabledChanged;\r\n CM_TEXTCHANGED:\r\n TextChanged;\r\n CM_FONTCHANGED:\r\n FontChanged;\r\n CM_COLORCHANGED:\r\n ColorChanged;\r\n CM_FOCUSCHANGED:\r\n FocusChanged(TWinControl(Msg.LParam));\r\n CM_PARENTFONTCHANGED:\r\n ParentFontChanged;\r\n CM_PARENTCOLORCHANGED:\r\n ParentColorChanged;\r\n CM_PARENTSHOWHINTCHANGED:\r\n ParentShowHintChanged;\r\n CM_CURSORCHANGED:\r\n CursorChanged;\r\n CM_SHOWINGCHANGED:\r\n ShowingChanged;\r\n CM_SHOWHINTCHANGED:\r\n ShowHintChanged;\r\n CM_CONTROLLISTCHANGE:\r\n if Msg.LParam <> 0 then\r\n ControlsListChanging(TControl(Msg.WParam), True)\r\n else\r\n ControlsListChanged(TControl(Msg.WParam), False);\r\n CM_CONTROLCHANGE:\r\n if Msg.LParam = 0 then\r\n ControlsListChanging(TControl(Msg.WParam), False)\r\n else\r\n ControlsListChanged(TControl(Msg.WParam), True);\r\n WM_SETFOCUS:\r\n FocusSet(THandle(Msg.WParam));\r\n WM_KILLFOCUS:\r\n FocusKilled(THandle(Msg.WParam));\r\n WM_SIZE, WM_MOVE:\r\n begin\r\n inherited WndProc(Msg);\r\n BoundsChanged;\r\n end;\r\n WM_ERASEBKGND:\r\n if (Msg.WParam <> 0) and not IsDefaultEraseBackground(DoEraseBackground, @TJvExCoolBar.DoEraseBackground) then\r\n begin\r\n IdSaveDC := SaveDC(HDC(Msg.WParam)); // protect DC against Stock-Objects from Canvas\r\n Canvas := TCanvas.Create;\r\n try\r\n Canvas.Handle := HDC(Msg.WParam);\r\n Msg.Result := Ord(DoEraseBackground(Canvas, Msg.LParam));\r\n finally\r\n Canvas.Handle := 0;\r\n Canvas.Free;\r\n RestoreDC(HDC(Msg.WParam), IdSaveDC);\r\n end;\r\n end\r\n else\r\n inherited WndProc(Msg);\r\n {$IFNDEF DELPHI2007_UP}\r\n WM_PRINTCLIENT, WM_PRINT: // VCL bug fix\r\n begin\r\n IdSaveDC := SaveDC(HDC(Msg.WParam)); // protect DC against changes\r\n try\r\n inherited WndProc(Msg);\r\n finally\r\n RestoreDC(HDC(Msg.WParam), IdSaveDC);\r\n end;\r\n end;\r\n {$ENDIF ~DELPHI2007_UP}\r\n WM_GETDLGCODE:\r\n begin\r\n inherited WndProc(Msg);\r\n DlgCodes := [dcNative] + DlgcToDlgCodes(Msg.Result);\r\n GetDlgCode(DlgCodes);\r\n if not (dcNative in DlgCodes) then\r\n Msg.Result := DlgCodesToDlgc(DlgCodes);\r\n end;\r\n else\r\n inherited WndProc(Msg);\r\n end;\r\n case Msg.Msg of // precheck message to prevent access violations on released controls\r\n CM_MOUSEENTER, CM_MOUSELEAVE, WM_KILLFOCUS, WM_SETFOCUS, WM_NCPAINT:\r\n if DotNetHighlighting then\r\n HandleDotNetHighlighting(Self, Msg, MouseOver, Color);\r\n end;\r\n end;\r\nend;\r\n\r\n//============================================================================\r\n\r\nconstructor TJvExCommonCalendar.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FHintColor := clDefault;\r\nend;\r\n\r\nfunction TJvExCommonCalendar.BaseWndProc(Msg: Cardinal; WParam: WPARAM = 0; LParam: LPARAM = 0): LRESULT;\r\nvar\r\n Mesg: TMessage;\r\nbegin\r\n CreateWMMessage(Mesg, Msg, WParam, LParam);\r\n inherited WndProc(Mesg);\r\n Result := Mesg.Result;\r\nend;\r\n\r\nfunction TJvExCommonCalendar.BaseWndProc(Msg: Cardinal; WParam: WPARAM; LParam: TObject): LRESULT;\r\nbegin\r\n Result := BaseWndProc(Msg, WParam, Windows.LPARAM(LParam));\r\nend;\r\n\r\nfunction TJvExCommonCalendar.BaseWndProcEx(Msg: Cardinal; WParam: WPARAM; var StructLParam): LRESULT;\r\nbegin\r\n Result := BaseWndProc(Msg, WParam, Windows.LPARAM(@StructLParam));\r\nend;\r\n\r\nprocedure TJvExCommonCalendar.VisibleChanged;\r\nbegin\r\n BaseWndProc(CM_VISIBLECHANGED);\r\nend;\r\n\r\nprocedure TJvExCommonCalendar.EnabledChanged;\r\nbegin\r\n BaseWndProc(CM_ENABLEDCHANGED);\r\nend;\r\n\r\nprocedure TJvExCommonCalendar.TextChanged;\r\nbegin\r\n BaseWndProc(CM_TEXTCHANGED);\r\nend;\r\n\r\nprocedure TJvExCommonCalendar.FontChanged;\r\nbegin\r\n BaseWndProc(CM_FONTCHANGED);\r\nend;\r\n\r\nprocedure TJvExCommonCalendar.ColorChanged;\r\nbegin\r\n BaseWndProc(CM_COLORCHANGED);\r\nend;\r\n\r\nprocedure TJvExCommonCalendar.ParentFontChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTFONTCHANGED);\r\nend;\r\n\r\nprocedure TJvExCommonCalendar.ParentColorChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTCOLORCHANGED);\r\n if Assigned(OnParentColorChange) then\r\n OnParentColorChange(Self);\r\nend;\r\n\r\nprocedure TJvExCommonCalendar.ParentShowHintChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTSHOWHINTCHANGED);\r\nend;\r\n\r\nfunction TJvExCommonCalendar.WantKey(Key: Integer; Shift: TShiftState): Boolean;\r\nbegin\r\n Result := BaseWndProc(CM_DIALOGCHAR, Word(Key), ShiftStateToKeyData(Shift)) <> 0;\r\nend;\r\n\r\nfunction TJvExCommonCalendar.HitTest(X, Y: Integer): Boolean;\r\nbegin\r\n Result := BaseWndProc(CM_HITTEST, 0, SmallPointToLong(PointToSmallPoint(Point(X, Y)))) <> 0;\r\nend;\r\n\r\nfunction TJvExCommonCalendar.HintShow(var HintInfo: THintInfo): Boolean;\r\nbegin\r\n GetHintColor(HintInfo, Self, FHintColor);\r\n if FHintWindowClass <> nil then\r\n HintInfo.HintWindowClass := FHintWindowClass;\r\n Result := BaseWndProcEx(CM_HINTSHOW, 0, HintInfo) <> 0;\r\nend;\r\n\r\nprocedure TJvExCommonCalendar.MouseEnter(AControl: TControl);\r\nbegin\r\n FMouseOver := True;\r\n if Assigned(FOnMouseEnter) then\r\n FOnMouseEnter(Self);\r\n BaseWndProc(CM_MOUSEENTER, 0, AControl);\r\nend;\r\n\r\nprocedure TJvExCommonCalendar.MouseLeave(AControl: TControl);\r\nbegin\r\n FMouseOver := False;\r\n BaseWndProc(CM_MOUSELEAVE, 0, AControl);\r\n if Assigned(FOnMouseLeave) then\r\n FOnMouseLeave(Self);\r\nend;\r\n\r\nprocedure TJvExCommonCalendar.FocusChanged(AControl: TWinControl);\r\nbegin\r\n BaseWndProc(CM_FOCUSCHANGED, 0, AControl);\r\nend;\r\n\r\nprocedure TJvExCommonCalendar.BoundsChanged;\r\nbegin\r\nend;\r\n\r\nprocedure TJvExCommonCalendar.CursorChanged;\r\nbegin\r\n BaseWndProc(CM_CURSORCHANGED);\r\nend;\r\n\r\nprocedure TJvExCommonCalendar.ShowingChanged;\r\nbegin\r\n BaseWndProc(CM_SHOWINGCHANGED);\r\nend;\r\n\r\nprocedure TJvExCommonCalendar.ShowHintChanged;\r\nbegin\r\n BaseWndProc(CM_SHOWHINTCHANGED);\r\nend;\r\n\r\n{ VCL sends CM_CONTROLLISTCHANGE and CM_CONTROLCHANGE in a different order than\r\n the CLX methods are used. So we must correct it by evaluating \"Inserting\". }\r\nprocedure TJvExCommonCalendar.ControlsListChanging(Control: TControl; Inserting: Boolean);\r\nbegin\r\n if Inserting then\r\n BaseWndProc(CM_CONTROLLISTCHANGE, WPARAM(Control), LPARAM(Inserting))\r\n else\r\n BaseWndProc(CM_CONTROLCHANGE, WPARAM(Control), LPARAM(Inserting));\r\nend;\r\n\r\nprocedure TJvExCommonCalendar.ControlsListChanged(Control: TControl; Inserting: Boolean);\r\nbegin\r\n if not Inserting then\r\n BaseWndProc(CM_CONTROLLISTCHANGE, WPARAM(Control), LPARAM(Inserting))\r\n else\r\n BaseWndProc(CM_CONTROLCHANGE, WPARAM(Control), LPARAM(Inserting));\r\nend;\r\n\r\nprocedure TJvExCommonCalendar.GetDlgCode(var Code: TDlgCodes);\r\nbegin\r\nend;\r\n\r\nprocedure TJvExCommonCalendar.FocusSet(PrevWnd: THandle);\r\nbegin\r\n BaseWndProc(WM_SETFOCUS, WPARAM(PrevWnd), 0);\r\nend;\r\n\r\nprocedure TJvExCommonCalendar.FocusKilled(NextWnd: THandle);\r\nbegin\r\n BaseWndProc(WM_KILLFOCUS, WPARAM(NextWnd), 0);\r\nend;\r\n\r\nfunction TJvExCommonCalendar.DoEraseBackground(Canvas: TCanvas; Param: LPARAM): Boolean;\r\nbegin\r\n Result := BaseWndProc(WM_ERASEBKGND, Canvas.Handle, Param) <> 0;\r\nend;\r\n\r\n{$IFDEF JVCLThemesEnabledD6}\r\nfunction TJvExCommonCalendar.GetParentBackground: Boolean;\r\nbegin\r\n Result := JvThemes.GetParentBackground(Self);\r\nend;\r\n\r\nprocedure TJvExCommonCalendar.SetParentBackground(Value: Boolean);\r\nbegin\r\n JvThemes.SetParentBackground(Self, Value);\r\nend;\r\n{$ENDIF JVCLThemesEnabledD6}\r\n\r\nprocedure TJvExCommonCalendar.WndProc(var Msg: TMessage);\r\nvar\r\n IdSaveDC: Integer;\r\n DlgCodes: TDlgCodes;\r\n Canvas: TCanvas;\r\nbegin\r\n if not DispatchIsDesignMsg(Self, Msg) then\r\n begin\r\n case Msg.Msg of\r\n CM_DENYSUBCLASSING:\r\n Msg.Result := LRESULT(Ord(GetInterfaceEntry(IJvDenySubClassing) <> nil));\r\n CM_DIALOGCHAR:\r\n with TCMDialogChar{$IFDEF CLR}.Create{$ENDIF}(Msg) do\r\n Result := LRESULT(Ord(WantKey(CharCode, KeyDataToShiftState(KeyData))));\r\n CM_HINTSHOW:\r\n with TCMHintShow(Msg) do\r\n Result := LRESULT(HintShow(HintInfo^));\r\n CM_HITTEST:\r\n with TCMHitTest(Msg) do\r\n Result := LRESULT(HitTest(XPos, YPos));\r\n CM_MOUSEENTER:\r\n MouseEnter(TControl(Msg.LParam));\r\n CM_MOUSELEAVE:\r\n MouseLeave(TControl(Msg.LParam));\r\n CM_VISIBLECHANGED:\r\n VisibleChanged;\r\n CM_ENABLEDCHANGED:\r\n EnabledChanged;\r\n CM_TEXTCHANGED:\r\n TextChanged;\r\n CM_FONTCHANGED:\r\n FontChanged;\r\n CM_COLORCHANGED:\r\n ColorChanged;\r\n CM_FOCUSCHANGED:\r\n FocusChanged(TWinControl(Msg.LParam));\r\n CM_PARENTFONTCHANGED:\r\n ParentFontChanged;\r\n CM_PARENTCOLORCHANGED:\r\n ParentColorChanged;\r\n CM_PARENTSHOWHINTCHANGED:\r\n ParentShowHintChanged;\r\n CM_CURSORCHANGED:\r\n CursorChanged;\r\n CM_SHOWINGCHANGED:\r\n ShowingChanged;\r\n CM_SHOWHINTCHANGED:\r\n ShowHintChanged;\r\n CM_CONTROLLISTCHANGE:\r\n if Msg.LParam <> 0 then\r\n ControlsListChanging(TControl(Msg.WParam), True)\r\n else\r\n ControlsListChanged(TControl(Msg.WParam), False);\r\n CM_CONTROLCHANGE:\r\n if Msg.LParam = 0 then\r\n ControlsListChanging(TControl(Msg.WParam), False)\r\n else\r\n ControlsListChanged(TControl(Msg.WParam), True);\r\n WM_SETFOCUS:\r\n FocusSet(THandle(Msg.WParam));\r\n WM_KILLFOCUS:\r\n FocusKilled(THandle(Msg.WParam));\r\n WM_SIZE, WM_MOVE:\r\n begin\r\n inherited WndProc(Msg);\r\n BoundsChanged;\r\n end;\r\n WM_ERASEBKGND:\r\n if (Msg.WParam <> 0) and not IsDefaultEraseBackground(DoEraseBackground, @TJvExCommonCalendar.DoEraseBackground) then\r\n begin\r\n IdSaveDC := SaveDC(HDC(Msg.WParam)); // protect DC against Stock-Objects from Canvas\r\n Canvas := TCanvas.Create;\r\n try\r\n Canvas.Handle := HDC(Msg.WParam);\r\n Msg.Result := Ord(DoEraseBackground(Canvas, Msg.LParam));\r\n finally\r\n Canvas.Handle := 0;\r\n Canvas.Free;\r\n RestoreDC(HDC(Msg.WParam), IdSaveDC);\r\n end;\r\n end\r\n else\r\n inherited WndProc(Msg);\r\n {$IFNDEF DELPHI2007_UP}\r\n WM_PRINTCLIENT, WM_PRINT: // VCL bug fix\r\n begin\r\n IdSaveDC := SaveDC(HDC(Msg.WParam)); // protect DC against changes\r\n try\r\n inherited WndProc(Msg);\r\n finally\r\n RestoreDC(HDC(Msg.WParam), IdSaveDC);\r\n end;\r\n end;\r\n {$ENDIF ~DELPHI2007_UP}\r\n WM_GETDLGCODE:\r\n begin\r\n inherited WndProc(Msg);\r\n DlgCodes := [dcNative] + DlgcToDlgCodes(Msg.Result);\r\n GetDlgCode(DlgCodes);\r\n if not (dcNative in DlgCodes) then\r\n Msg.Result := DlgCodesToDlgc(DlgCodes);\r\n end;\r\n else\r\n inherited WndProc(Msg);\r\n end;\r\n case Msg.Msg of // precheck message to prevent access violations on released controls\r\n CM_MOUSEENTER, CM_MOUSELEAVE, WM_KILLFOCUS, WM_SETFOCUS, WM_NCPAINT:\r\n if DotNetHighlighting then\r\n HandleDotNetHighlighting(Self, Msg, MouseOver, Color);\r\n end;\r\n end;\r\nend;\r\n\r\n//============================================================================\r\n\r\nconstructor TJvExMonthCalendar.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FHintColor := clDefault;\r\nend;\r\n\r\nfunction TJvExMonthCalendar.BaseWndProc(Msg: Cardinal; WParam: WPARAM = 0; LParam: LPARAM = 0): LRESULT;\r\nvar\r\n Mesg: TMessage;\r\nbegin\r\n CreateWMMessage(Mesg, Msg, WParam, LParam);\r\n inherited WndProc(Mesg);\r\n Result := Mesg.Result;\r\nend;\r\n\r\nfunction TJvExMonthCalendar.BaseWndProc(Msg: Cardinal; WParam: WPARAM; LParam: TObject): LRESULT;\r\nbegin\r\n Result := BaseWndProc(Msg, WParam, Windows.LPARAM(LParam));\r\nend;\r\n\r\nfunction TJvExMonthCalendar.BaseWndProcEx(Msg: Cardinal; WParam: WPARAM; var StructLParam): LRESULT;\r\nbegin\r\n Result := BaseWndProc(Msg, WParam, Windows.LPARAM(@StructLParam));\r\nend;\r\n\r\nprocedure TJvExMonthCalendar.VisibleChanged;\r\nbegin\r\n BaseWndProc(CM_VISIBLECHANGED);\r\nend;\r\n\r\nprocedure TJvExMonthCalendar.EnabledChanged;\r\nbegin\r\n BaseWndProc(CM_ENABLEDCHANGED);\r\nend;\r\n\r\nprocedure TJvExMonthCalendar.TextChanged;\r\nbegin\r\n BaseWndProc(CM_TEXTCHANGED);\r\nend;\r\n\r\nprocedure TJvExMonthCalendar.FontChanged;\r\nbegin\r\n BaseWndProc(CM_FONTCHANGED);\r\nend;\r\n\r\nprocedure TJvExMonthCalendar.ColorChanged;\r\nbegin\r\n BaseWndProc(CM_COLORCHANGED);\r\nend;\r\n\r\nprocedure TJvExMonthCalendar.ParentFontChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTFONTCHANGED);\r\nend;\r\n\r\nprocedure TJvExMonthCalendar.ParentColorChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTCOLORCHANGED);\r\n if Assigned(OnParentColorChange) then\r\n OnParentColorChange(Self);\r\nend;\r\n\r\nprocedure TJvExMonthCalendar.ParentShowHintChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTSHOWHINTCHANGED);\r\nend;\r\n\r\nfunction TJvExMonthCalendar.WantKey(Key: Integer; Shift: TShiftState): Boolean;\r\nbegin\r\n Result := BaseWndProc(CM_DIALOGCHAR, Word(Key), ShiftStateToKeyData(Shift)) <> 0;\r\nend;\r\n\r\nfunction TJvExMonthCalendar.HitTest(X, Y: Integer): Boolean;\r\nbegin\r\n Result := BaseWndProc(CM_HITTEST, 0, SmallPointToLong(PointToSmallPoint(Point(X, Y)))) <> 0;\r\nend;\r\n\r\nfunction TJvExMonthCalendar.HintShow(var HintInfo: THintInfo): Boolean;\r\nbegin\r\n GetHintColor(HintInfo, Self, FHintColor);\r\n if FHintWindowClass <> nil then\r\n HintInfo.HintWindowClass := FHintWindowClass;\r\n Result := BaseWndProcEx(CM_HINTSHOW, 0, HintInfo) <> 0;\r\nend;\r\n\r\nprocedure TJvExMonthCalendar.MouseEnter(AControl: TControl);\r\nbegin\r\n FMouseOver := True;\r\n if Assigned(FOnMouseEnter) then\r\n FOnMouseEnter(Self);\r\n BaseWndProc(CM_MOUSEENTER, 0, AControl);\r\nend;\r\n\r\nprocedure TJvExMonthCalendar.MouseLeave(AControl: TControl);\r\nbegin\r\n FMouseOver := False;\r\n BaseWndProc(CM_MOUSELEAVE, 0, AControl);\r\n if Assigned(FOnMouseLeave) then\r\n FOnMouseLeave(Self);\r\nend;\r\n\r\nprocedure TJvExMonthCalendar.FocusChanged(AControl: TWinControl);\r\nbegin\r\n BaseWndProc(CM_FOCUSCHANGED, 0, AControl);\r\nend;\r\n\r\nprocedure TJvExMonthCalendar.BoundsChanged;\r\nbegin\r\nend;\r\n\r\nprocedure TJvExMonthCalendar.CursorChanged;\r\nbegin\r\n BaseWndProc(CM_CURSORCHANGED);\r\nend;\r\n\r\nprocedure TJvExMonthCalendar.ShowingChanged;\r\nbegin\r\n BaseWndProc(CM_SHOWINGCHANGED);\r\nend;\r\n\r\nprocedure TJvExMonthCalendar.ShowHintChanged;\r\nbegin\r\n BaseWndProc(CM_SHOWHINTCHANGED);\r\nend;\r\n\r\n{ VCL sends CM_CONTROLLISTCHANGE and CM_CONTROLCHANGE in a different order than\r\n the CLX methods are used. So we must correct it by evaluating \"Inserting\". }\r\nprocedure TJvExMonthCalendar.ControlsListChanging(Control: TControl; Inserting: Boolean);\r\nbegin\r\n if Inserting then\r\n BaseWndProc(CM_CONTROLLISTCHANGE, WPARAM(Control), LPARAM(Inserting))\r\n else\r\n BaseWndProc(CM_CONTROLCHANGE, WPARAM(Control), LPARAM(Inserting));\r\nend;\r\n\r\nprocedure TJvExMonthCalendar.ControlsListChanged(Control: TControl; Inserting: Boolean);\r\nbegin\r\n if not Inserting then\r\n BaseWndProc(CM_CONTROLLISTCHANGE, WPARAM(Control), LPARAM(Inserting))\r\n else\r\n BaseWndProc(CM_CONTROLCHANGE, WPARAM(Control), LPARAM(Inserting));\r\nend;\r\n\r\nprocedure TJvExMonthCalendar.GetDlgCode(var Code: TDlgCodes);\r\nbegin\r\nend;\r\n\r\nprocedure TJvExMonthCalendar.FocusSet(PrevWnd: THandle);\r\nbegin\r\n BaseWndProc(WM_SETFOCUS, WPARAM(PrevWnd), 0);\r\nend;\r\n\r\nprocedure TJvExMonthCalendar.FocusKilled(NextWnd: THandle);\r\nbegin\r\n BaseWndProc(WM_KILLFOCUS, WPARAM(NextWnd), 0);\r\nend;\r\n\r\nfunction TJvExMonthCalendar.DoEraseBackground(Canvas: TCanvas; Param: LPARAM): Boolean;\r\nbegin\r\n Result := BaseWndProc(WM_ERASEBKGND, Canvas.Handle, Param) <> 0;\r\nend;\r\n\r\n{$IFDEF JVCLThemesEnabledD6}\r\nfunction TJvExMonthCalendar.GetParentBackground: Boolean;\r\nbegin\r\n Result := JvThemes.GetParentBackground(Self);\r\nend;\r\n\r\nprocedure TJvExMonthCalendar.SetParentBackground(Value: Boolean);\r\nbegin\r\n JvThemes.SetParentBackground(Self, Value);\r\nend;\r\n{$ENDIF JVCLThemesEnabledD6}\r\n\r\nprocedure TJvExMonthCalendar.WndProc(var Msg: TMessage);\r\nvar\r\n IdSaveDC: Integer;\r\n DlgCodes: TDlgCodes;\r\n Canvas: TCanvas;\r\nbegin\r\n if not DispatchIsDesignMsg(Self, Msg) then\r\n begin\r\n case Msg.Msg of\r\n CM_DENYSUBCLASSING:\r\n Msg.Result := LRESULT(Ord(GetInterfaceEntry(IJvDenySubClassing) <> nil));\r\n CM_DIALOGCHAR:\r\n with TCMDialogChar{$IFDEF CLR}.Create{$ENDIF}(Msg) do\r\n Result := LRESULT(Ord(WantKey(CharCode, KeyDataToShiftState(KeyData))));\r\n CM_HINTSHOW:\r\n with TCMHintShow(Msg) do\r\n Result := LRESULT(HintShow(HintInfo^));\r\n CM_HITTEST:\r\n with TCMHitTest(Msg) do\r\n Result := LRESULT(HitTest(XPos, YPos));\r\n CM_MOUSEENTER:\r\n MouseEnter(TControl(Msg.LParam));\r\n CM_MOUSELEAVE:\r\n MouseLeave(TControl(Msg.LParam));\r\n CM_VISIBLECHANGED:\r\n VisibleChanged;\r\n CM_ENABLEDCHANGED:\r\n EnabledChanged;\r\n CM_TEXTCHANGED:\r\n TextChanged;\r\n CM_FONTCHANGED:\r\n FontChanged;\r\n CM_COLORCHANGED:\r\n ColorChanged;\r\n CM_FOCUSCHANGED:\r\n FocusChanged(TWinControl(Msg.LParam));\r\n CM_PARENTFONTCHANGED:\r\n ParentFontChanged;\r\n CM_PARENTCOLORCHANGED:\r\n ParentColorChanged;\r\n CM_PARENTSHOWHINTCHANGED:\r\n ParentShowHintChanged;\r\n CM_CURSORCHANGED:\r\n CursorChanged;\r\n CM_SHOWINGCHANGED:\r\n ShowingChanged;\r\n CM_SHOWHINTCHANGED:\r\n ShowHintChanged;\r\n CM_CONTROLLISTCHANGE:\r\n if Msg.LParam <> 0 then\r\n ControlsListChanging(TControl(Msg.WParam), True)\r\n else\r\n ControlsListChanged(TControl(Msg.WParam), False);\r\n CM_CONTROLCHANGE:\r\n if Msg.LParam = 0 then\r\n ControlsListChanging(TControl(Msg.WParam), False)\r\n else\r\n ControlsListChanged(TControl(Msg.WParam), True);\r\n WM_SETFOCUS:\r\n FocusSet(THandle(Msg.WParam));\r\n WM_KILLFOCUS:\r\n FocusKilled(THandle(Msg.WParam));\r\n WM_SIZE, WM_MOVE:\r\n begin\r\n inherited WndProc(Msg);\r\n BoundsChanged;\r\n end;\r\n WM_ERASEBKGND:\r\n if (Msg.WParam <> 0) and not IsDefaultEraseBackground(DoEraseBackground, @TJvExMonthCalendar.DoEraseBackground) then\r\n begin\r\n IdSaveDC := SaveDC(HDC(Msg.WParam)); // protect DC against Stock-Objects from Canvas\r\n Canvas := TCanvas.Create;\r\n try\r\n Canvas.Handle := HDC(Msg.WParam);\r\n Msg.Result := Ord(DoEraseBackground(Canvas, Msg.LParam));\r\n finally\r\n Canvas.Handle := 0;\r\n Canvas.Free;\r\n RestoreDC(HDC(Msg.WParam), IdSaveDC);\r\n end;\r\n end\r\n else\r\n inherited WndProc(Msg);\r\n {$IFNDEF DELPHI2007_UP}\r\n WM_PRINTCLIENT, WM_PRINT: // VCL bug fix\r\n begin\r\n IdSaveDC := SaveDC(HDC(Msg.WParam)); // protect DC against changes\r\n try\r\n inherited WndProc(Msg);\r\n finally\r\n RestoreDC(HDC(Msg.WParam), IdSaveDC);\r\n end;\r\n end;\r\n {$ENDIF ~DELPHI2007_UP}\r\n WM_GETDLGCODE:\r\n begin\r\n inherited WndProc(Msg);\r\n DlgCodes := [dcNative] + DlgcToDlgCodes(Msg.Result);\r\n GetDlgCode(DlgCodes);\r\n if not (dcNative in DlgCodes) then\r\n Msg.Result := DlgCodesToDlgc(DlgCodes);\r\n end;\r\n else\r\n inherited WndProc(Msg);\r\n end;\r\n case Msg.Msg of // precheck message to prevent access violations on released controls\r\n CM_MOUSEENTER, CM_MOUSELEAVE, WM_KILLFOCUS, WM_SETFOCUS, WM_NCPAINT:\r\n if DotNetHighlighting then\r\n HandleDotNetHighlighting(Self, Msg, MouseOver, Color);\r\n end;\r\n end;\r\nend;\r\n\r\n//============================================================================\r\n\r\nconstructor TJvExCustomHotKey.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FHintColor := clDefault;\r\nend;\r\n\r\nfunction TJvExCustomHotKey.BaseWndProc(Msg: Cardinal; WParam: WPARAM = 0; LParam: LPARAM = 0): LRESULT;\r\nvar\r\n Mesg: TMessage;\r\nbegin\r\n CreateWMMessage(Mesg, Msg, WParam, LParam);\r\n inherited WndProc(Mesg);\r\n Result := Mesg.Result;\r\nend;\r\n\r\nfunction TJvExCustomHotKey.BaseWndProc(Msg: Cardinal; WParam: WPARAM; LParam: TObject): LRESULT;\r\nbegin\r\n Result := BaseWndProc(Msg, WParam, Windows.LPARAM(LParam));\r\nend;\r\n\r\nfunction TJvExCustomHotKey.BaseWndProcEx(Msg: Cardinal; WParam: WPARAM; var StructLParam): LRESULT;\r\nbegin\r\n Result := BaseWndProc(Msg, WParam, Windows.LPARAM(@StructLParam));\r\nend;\r\n\r\nprocedure TJvExCustomHotKey.VisibleChanged;\r\nbegin\r\n BaseWndProc(CM_VISIBLECHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomHotKey.EnabledChanged;\r\nbegin\r\n BaseWndProc(CM_ENABLEDCHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomHotKey.TextChanged;\r\nbegin\r\n BaseWndProc(CM_TEXTCHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomHotKey.FontChanged;\r\nbegin\r\n BaseWndProc(CM_FONTCHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomHotKey.ColorChanged;\r\nbegin\r\n BaseWndProc(CM_COLORCHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomHotKey.ParentFontChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTFONTCHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomHotKey.ParentColorChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTCOLORCHANGED);\r\n if Assigned(OnParentColorChange) then\r\n OnParentColorChange(Self);\r\nend;\r\n\r\nprocedure TJvExCustomHotKey.ParentShowHintChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTSHOWHINTCHANGED);\r\nend;\r\n\r\nfunction TJvExCustomHotKey.WantKey(Key: Integer; Shift: TShiftState): Boolean;\r\nbegin\r\n Result := BaseWndProc(CM_DIALOGCHAR, Word(Key), ShiftStateToKeyData(Shift)) <> 0;\r\nend;\r\n\r\nfunction TJvExCustomHotKey.HitTest(X, Y: Integer): Boolean;\r\nbegin\r\n Result := BaseWndProc(CM_HITTEST, 0, SmallPointToLong(PointToSmallPoint(Point(X, Y)))) <> 0;\r\nend;\r\n\r\nfunction TJvExCustomHotKey.HintShow(var HintInfo: THintInfo): Boolean;\r\nbegin\r\n GetHintColor(HintInfo, Self, FHintColor);\r\n if FHintWindowClass <> nil then\r\n HintInfo.HintWindowClass := FHintWindowClass;\r\n Result := BaseWndProcEx(CM_HINTSHOW, 0, HintInfo) <> 0;\r\nend;\r\n\r\nprocedure TJvExCustomHotKey.MouseEnter(AControl: TControl);\r\nbegin\r\n FMouseOver := True;\r\n if Assigned(FOnMouseEnter) then\r\n FOnMouseEnter(Self);\r\n BaseWndProc(CM_MOUSEENTER, 0, AControl);\r\nend;\r\n\r\nprocedure TJvExCustomHotKey.MouseLeave(AControl: TControl);\r\nbegin\r\n FMouseOver := False;\r\n BaseWndProc(CM_MOUSELEAVE, 0, AControl);\r\n if Assigned(FOnMouseLeave) then\r\n FOnMouseLeave(Self);\r\nend;\r\n\r\nprocedure TJvExCustomHotKey.FocusChanged(AControl: TWinControl);\r\nbegin\r\n BaseWndProc(CM_FOCUSCHANGED, 0, AControl);\r\nend;\r\n\r\nprocedure TJvExCustomHotKey.BoundsChanged;\r\nbegin\r\nend;\r\n\r\nprocedure TJvExCustomHotKey.CursorChanged;\r\nbegin\r\n BaseWndProc(CM_CURSORCHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomHotKey.ShowingChanged;\r\nbegin\r\n BaseWndProc(CM_SHOWINGCHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomHotKey.ShowHintChanged;\r\nbegin\r\n BaseWndProc(CM_SHOWHINTCHANGED);\r\nend;\r\n\r\n{ VCL sends CM_CONTROLLISTCHANGE and CM_CONTROLCHANGE in a different order than\r\n the CLX methods are used. So we must correct it by evaluating \"Inserting\". }\r\nprocedure TJvExCustomHotKey.ControlsListChanging(Control: TControl; Inserting: Boolean);\r\nbegin\r\n if Inserting then\r\n BaseWndProc(CM_CONTROLLISTCHANGE, WPARAM(Control), LPARAM(Inserting))\r\n else\r\n BaseWndProc(CM_CONTROLCHANGE, WPARAM(Control), LPARAM(Inserting));\r\nend;\r\n\r\nprocedure TJvExCustomHotKey.ControlsListChanged(Control: TControl; Inserting: Boolean);\r\nbegin\r\n if not Inserting then\r\n BaseWndProc(CM_CONTROLLISTCHANGE, WPARAM(Control), LPARAM(Inserting))\r\n else\r\n BaseWndProc(CM_CONTROLCHANGE, WPARAM(Control), LPARAM(Inserting));\r\nend;\r\n\r\nprocedure TJvExCustomHotKey.GetDlgCode(var Code: TDlgCodes);\r\nbegin\r\nend;\r\n\r\nprocedure TJvExCustomHotKey.FocusSet(PrevWnd: THandle);\r\nbegin\r\n BaseWndProc(WM_SETFOCUS, WPARAM(PrevWnd), 0);\r\nend;\r\n\r\nprocedure TJvExCustomHotKey.FocusKilled(NextWnd: THandle);\r\nbegin\r\n BaseWndProc(WM_KILLFOCUS, WPARAM(NextWnd), 0);\r\nend;\r\n\r\nfunction TJvExCustomHotKey.DoEraseBackground(Canvas: TCanvas; Param: LPARAM): Boolean;\r\nbegin\r\n Result := BaseWndProc(WM_ERASEBKGND, Canvas.Handle, Param) <> 0;\r\nend;\r\n\r\n{$IFDEF JVCLThemesEnabledD6}\r\nfunction TJvExCustomHotKey.GetParentBackground: Boolean;\r\nbegin\r\n Result := JvThemes.GetParentBackground(Self);\r\nend;\r\n\r\nprocedure TJvExCustomHotKey.SetParentBackground(Value: Boolean);\r\nbegin\r\n JvThemes.SetParentBackground(Self, Value);\r\nend;\r\n{$ENDIF JVCLThemesEnabledD6}\r\n\r\nprocedure TJvExCustomHotKey.WndProc(var Msg: TMessage);\r\nvar\r\n IdSaveDC: Integer;\r\n DlgCodes: TDlgCodes;\r\n Canvas: TCanvas;\r\nbegin\r\n if not DispatchIsDesignMsg(Self, Msg) then\r\n begin\r\n case Msg.Msg of\r\n CM_DENYSUBCLASSING:\r\n Msg.Result := LRESULT(Ord(GetInterfaceEntry(IJvDenySubClassing) <> nil));\r\n CM_DIALOGCHAR:\r\n with TCMDialogChar{$IFDEF CLR}.Create{$ENDIF}(Msg) do\r\n Result := LRESULT(Ord(WantKey(CharCode, KeyDataToShiftState(KeyData))));\r\n CM_HINTSHOW:\r\n with TCMHintShow(Msg) do\r\n Result := LRESULT(HintShow(HintInfo^));\r\n CM_HITTEST:\r\n with TCMHitTest(Msg) do\r\n Result := LRESULT(HitTest(XPos, YPos));\r\n CM_MOUSEENTER:\r\n MouseEnter(TControl(Msg.LParam));\r\n CM_MOUSELEAVE:\r\n MouseLeave(TControl(Msg.LParam));\r\n CM_VISIBLECHANGED:\r\n VisibleChanged;\r\n CM_ENABLEDCHANGED:\r\n EnabledChanged;\r\n CM_TEXTCHANGED:\r\n TextChanged;\r\n CM_FONTCHANGED:\r\n FontChanged;\r\n CM_COLORCHANGED:\r\n ColorChanged;\r\n CM_FOCUSCHANGED:\r\n FocusChanged(TWinControl(Msg.LParam));\r\n CM_PARENTFONTCHANGED:\r\n ParentFontChanged;\r\n CM_PARENTCOLORCHANGED:\r\n ParentColorChanged;\r\n CM_PARENTSHOWHINTCHANGED:\r\n ParentShowHintChanged;\r\n CM_CURSORCHANGED:\r\n CursorChanged;\r\n CM_SHOWINGCHANGED:\r\n ShowingChanged;\r\n CM_SHOWHINTCHANGED:\r\n ShowHintChanged;\r\n CM_CONTROLLISTCHANGE:\r\n if Msg.LParam <> 0 then\r\n ControlsListChanging(TControl(Msg.WParam), True)\r\n else\r\n ControlsListChanged(TControl(Msg.WParam), False);\r\n CM_CONTROLCHANGE:\r\n if Msg.LParam = 0 then\r\n ControlsListChanging(TControl(Msg.WParam), False)\r\n else\r\n ControlsListChanged(TControl(Msg.WParam), True);\r\n WM_SETFOCUS:\r\n FocusSet(THandle(Msg.WParam));\r\n WM_KILLFOCUS:\r\n FocusKilled(THandle(Msg.WParam));\r\n WM_SIZE, WM_MOVE:\r\n begin\r\n inherited WndProc(Msg);\r\n BoundsChanged;\r\n end;\r\n WM_ERASEBKGND:\r\n if (Msg.WParam <> 0) and not IsDefaultEraseBackground(DoEraseBackground, @TJvExCustomHotKey.DoEraseBackground) then\r\n begin\r\n IdSaveDC := SaveDC(HDC(Msg.WParam)); // protect DC against Stock-Objects from Canvas\r\n Canvas := TCanvas.Create;\r\n try\r\n Canvas.Handle := HDC(Msg.WParam);\r\n Msg.Result := Ord(DoEraseBackground(Canvas, Msg.LParam));\r\n finally\r\n Canvas.Handle := 0;\r\n Canvas.Free;\r\n RestoreDC(HDC(Msg.WParam), IdSaveDC);\r\n end;\r\n end\r\n else\r\n inherited WndProc(Msg);\r\n {$IFNDEF DELPHI2007_UP}\r\n WM_PRINTCLIENT, WM_PRINT: // VCL bug fix\r\n begin\r\n IdSaveDC := SaveDC(HDC(Msg.WParam)); // protect DC against changes\r\n try\r\n inherited WndProc(Msg);\r\n finally\r\n RestoreDC(HDC(Msg.WParam), IdSaveDC);\r\n end;\r\n end;\r\n {$ENDIF ~DELPHI2007_UP}\r\n WM_GETDLGCODE:\r\n begin\r\n inherited WndProc(Msg);\r\n DlgCodes := [dcNative] + DlgcToDlgCodes(Msg.Result);\r\n GetDlgCode(DlgCodes);\r\n if not (dcNative in DlgCodes) then\r\n Msg.Result := DlgCodesToDlgc(DlgCodes);\r\n end;\r\n else\r\n inherited WndProc(Msg);\r\n end;\r\n case Msg.Msg of // precheck message to prevent access violations on released controls\r\n CM_MOUSEENTER, CM_MOUSELEAVE, WM_KILLFOCUS, WM_SETFOCUS, WM_NCPAINT:\r\n if DotNetHighlighting then\r\n HandleDotNetHighlighting(Self, Msg, MouseOver, Color);\r\n end;\r\n end;\r\nend;\r\n\r\n//============================================================================\r\n\r\nconstructor TJvExHotKey.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FHintColor := clDefault;\r\nend;\r\n\r\nfunction TJvExHotKey.BaseWndProc(Msg: Cardinal; WParam: WPARAM = 0; LParam: LPARAM = 0): LRESULT;\r\nvar\r\n Mesg: TMessage;\r\nbegin\r\n CreateWMMessage(Mesg, Msg, WParam, LParam);\r\n inherited WndProc(Mesg);\r\n Result := Mesg.Result;\r\nend;\r\n\r\nfunction TJvExHotKey.BaseWndProc(Msg: Cardinal; WParam: WPARAM; LParam: TObject): LRESULT;\r\nbegin\r\n Result := BaseWndProc(Msg, WParam, Windows.LPARAM(LParam));\r\nend;\r\n\r\nfunction TJvExHotKey.BaseWndProcEx(Msg: Cardinal; WParam: WPARAM; var StructLParam): LRESULT;\r\nbegin\r\n Result := BaseWndProc(Msg, WParam, Windows.LPARAM(@StructLParam));\r\nend;\r\n\r\nprocedure TJvExHotKey.VisibleChanged;\r\nbegin\r\n BaseWndProc(CM_VISIBLECHANGED);\r\nend;\r\n\r\nprocedure TJvExHotKey.EnabledChanged;\r\nbegin\r\n BaseWndProc(CM_ENABLEDCHANGED);\r\nend;\r\n\r\nprocedure TJvExHotKey.TextChanged;\r\nbegin\r\n BaseWndProc(CM_TEXTCHANGED);\r\nend;\r\n\r\nprocedure TJvExHotKey.FontChanged;\r\nbegin\r\n BaseWndProc(CM_FONTCHANGED);\r\nend;\r\n\r\nprocedure TJvExHotKey.ColorChanged;\r\nbegin\r\n BaseWndProc(CM_COLORCHANGED);\r\nend;\r\n\r\nprocedure TJvExHotKey.ParentFontChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTFONTCHANGED);\r\nend;\r\n\r\nprocedure TJvExHotKey.ParentColorChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTCOLORCHANGED);\r\n if Assigned(OnParentColorChange) then\r\n OnParentColorChange(Self);\r\nend;\r\n\r\nprocedure TJvExHotKey.ParentShowHintChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTSHOWHINTCHANGED);\r\nend;\r\n\r\nfunction TJvExHotKey.WantKey(Key: Integer; Shift: TShiftState): Boolean;\r\nbegin\r\n Result := BaseWndProc(CM_DIALOGCHAR, Word(Key), ShiftStateToKeyData(Shift)) <> 0;\r\nend;\r\n\r\nfunction TJvExHotKey.HitTest(X, Y: Integer): Boolean;\r\nbegin\r\n Result := BaseWndProc(CM_HITTEST, 0, SmallPointToLong(PointToSmallPoint(Point(X, Y)))) <> 0;\r\nend;\r\n\r\nfunction TJvExHotKey.HintShow(var HintInfo: THintInfo): Boolean;\r\nbegin\r\n GetHintColor(HintInfo, Self, FHintColor);\r\n if FHintWindowClass <> nil then\r\n HintInfo.HintWindowClass := FHintWindowClass;\r\n Result := BaseWndProcEx(CM_HINTSHOW, 0, HintInfo) <> 0;\r\nend;\r\n\r\nprocedure TJvExHotKey.MouseEnter(AControl: TControl);\r\nbegin\r\n FMouseOver := True;\r\n if Assigned(FOnMouseEnter) then\r\n FOnMouseEnter(Self);\r\n BaseWndProc(CM_MOUSEENTER, 0, AControl);\r\nend;\r\n\r\nprocedure TJvExHotKey.MouseLeave(AControl: TControl);\r\nbegin\r\n FMouseOver := False;\r\n BaseWndProc(CM_MOUSELEAVE, 0, AControl);\r\n if Assigned(FOnMouseLeave) then\r\n FOnMouseLeave(Self);\r\nend;\r\n\r\nprocedure TJvExHotKey.FocusChanged(AControl: TWinControl);\r\nbegin\r\n BaseWndProc(CM_FOCUSCHANGED, 0, AControl);\r\nend;\r\n\r\nprocedure TJvExHotKey.BoundsChanged;\r\nbegin\r\nend;\r\n\r\nprocedure TJvExHotKey.CursorChanged;\r\nbegin\r\n BaseWndProc(CM_CURSORCHANGED);\r\nend;\r\n\r\nprocedure TJvExHotKey.ShowingChanged;\r\nbegin\r\n BaseWndProc(CM_SHOWINGCHANGED);\r\nend;\r\n\r\nprocedure TJvExHotKey.ShowHintChanged;\r\nbegin\r\n BaseWndProc(CM_SHOWHINTCHANGED);\r\nend;\r\n\r\n{ VCL sends CM_CONTROLLISTCHANGE and CM_CONTROLCHANGE in a different order than\r\n the CLX methods are used. So we must correct it by evaluating \"Inserting\". }\r\nprocedure TJvExHotKey.ControlsListChanging(Control: TControl; Inserting: Boolean);\r\nbegin\r\n if Inserting then\r\n BaseWndProc(CM_CONTROLLISTCHANGE, WPARAM(Control), LPARAM(Inserting))\r\n else\r\n BaseWndProc(CM_CONTROLCHANGE, WPARAM(Control), LPARAM(Inserting));\r\nend;\r\n\r\nprocedure TJvExHotKey.ControlsListChanged(Control: TControl; Inserting: Boolean);\r\nbegin\r\n if not Inserting then\r\n BaseWndProc(CM_CONTROLLISTCHANGE, WPARAM(Control), LPARAM(Inserting))\r\n else\r\n BaseWndProc(CM_CONTROLCHANGE, WPARAM(Control), LPARAM(Inserting));\r\nend;\r\n\r\nprocedure TJvExHotKey.GetDlgCode(var Code: TDlgCodes);\r\nbegin\r\nend;\r\n\r\nprocedure TJvExHotKey.FocusSet(PrevWnd: THandle);\r\nbegin\r\n BaseWndProc(WM_SETFOCUS, WPARAM(PrevWnd), 0);\r\nend;\r\n\r\nprocedure TJvExHotKey.FocusKilled(NextWnd: THandle);\r\nbegin\r\n BaseWndProc(WM_KILLFOCUS, WPARAM(NextWnd), 0);\r\nend;\r\n\r\nfunction TJvExHotKey.DoEraseBackground(Canvas: TCanvas; Param: LPARAM): Boolean;\r\nbegin\r\n Result := BaseWndProc(WM_ERASEBKGND, Canvas.Handle, Param) <> 0;\r\nend;\r\n\r\n{$IFDEF JVCLThemesEnabledD6}\r\nfunction TJvExHotKey.GetParentBackground: Boolean;\r\nbegin\r\n Result := JvThemes.GetParentBackground(Self);\r\nend;\r\n\r\nprocedure TJvExHotKey.SetParentBackground(Value: Boolean);\r\nbegin\r\n JvThemes.SetParentBackground(Self, Value);\r\nend;\r\n{$ENDIF JVCLThemesEnabledD6}\r\n\r\nprocedure TJvExHotKey.WndProc(var Msg: TMessage);\r\nvar\r\n IdSaveDC: Integer;\r\n DlgCodes: TDlgCodes;\r\n Canvas: TCanvas;\r\nbegin\r\n if not DispatchIsDesignMsg(Self, Msg) then\r\n begin\r\n case Msg.Msg of\r\n CM_DENYSUBCLASSING:\r\n Msg.Result := LRESULT(Ord(GetInterfaceEntry(IJvDenySubClassing) <> nil));\r\n CM_DIALOGCHAR:\r\n with TCMDialogChar{$IFDEF CLR}.Create{$ENDIF}(Msg) do\r\n Result := LRESULT(Ord(WantKey(CharCode, KeyDataToShiftState(KeyData))));\r\n CM_HINTSHOW:\r\n with TCMHintShow(Msg) do\r\n Result := LRESULT(HintShow(HintInfo^));\r\n CM_HITTEST:\r\n with TCMHitTest(Msg) do\r\n Result := LRESULT(HitTest(XPos, YPos));\r\n CM_MOUSEENTER:\r\n MouseEnter(TControl(Msg.LParam));\r\n CM_MOUSELEAVE:\r\n MouseLeave(TControl(Msg.LParam));\r\n CM_VISIBLECHANGED:\r\n VisibleChanged;\r\n CM_ENABLEDCHANGED:\r\n EnabledChanged;\r\n CM_TEXTCHANGED:\r\n TextChanged;\r\n CM_FONTCHANGED:\r\n FontChanged;\r\n CM_COLORCHANGED:\r\n ColorChanged;\r\n CM_FOCUSCHANGED:\r\n FocusChanged(TWinControl(Msg.LParam));\r\n CM_PARENTFONTCHANGED:\r\n ParentFontChanged;\r\n CM_PARENTCOLORCHANGED:\r\n ParentColorChanged;\r\n CM_PARENTSHOWHINTCHANGED:\r\n ParentShowHintChanged;\r\n CM_CURSORCHANGED:\r\n CursorChanged;\r\n CM_SHOWINGCHANGED:\r\n ShowingChanged;\r\n CM_SHOWHINTCHANGED:\r\n ShowHintChanged;\r\n CM_CONTROLLISTCHANGE:\r\n if Msg.LParam <> 0 then\r\n ControlsListChanging(TControl(Msg.WParam), True)\r\n else\r\n ControlsListChanged(TControl(Msg.WParam), False);\r\n CM_CONTROLCHANGE:\r\n if Msg.LParam = 0 then\r\n ControlsListChanging(TControl(Msg.WParam), False)\r\n else\r\n ControlsListChanged(TControl(Msg.WParam), True);\r\n WM_SETFOCUS:\r\n FocusSet(THandle(Msg.WParam));\r\n WM_KILLFOCUS:\r\n FocusKilled(THandle(Msg.WParam));\r\n WM_SIZE, WM_MOVE:\r\n begin\r\n inherited WndProc(Msg);\r\n BoundsChanged;\r\n end;\r\n WM_ERASEBKGND:\r\n if (Msg.WParam <> 0) and not IsDefaultEraseBackground(DoEraseBackground, @TJvExHotKey.DoEraseBackground) then\r\n begin\r\n IdSaveDC := SaveDC(HDC(Msg.WParam)); // protect DC against Stock-Objects from Canvas\r\n Canvas := TCanvas.Create;\r\n try\r\n Canvas.Handle := HDC(Msg.WParam);\r\n Msg.Result := Ord(DoEraseBackground(Canvas, Msg.LParam));\r\n finally\r\n Canvas.Handle := 0;\r\n Canvas.Free;\r\n RestoreDC(HDC(Msg.WParam), IdSaveDC);\r\n end;\r\n end\r\n else\r\n inherited WndProc(Msg);\r\n {$IFNDEF DELPHI2007_UP}\r\n WM_PRINTCLIENT, WM_PRINT: // VCL bug fix\r\n begin\r\n IdSaveDC := SaveDC(HDC(Msg.WParam)); // protect DC against changes\r\n try\r\n inherited WndProc(Msg);\r\n finally\r\n RestoreDC(HDC(Msg.WParam), IdSaveDC);\r\n end;\r\n end;\r\n {$ENDIF ~DELPHI2007_UP}\r\n WM_GETDLGCODE:\r\n begin\r\n inherited WndProc(Msg);\r\n DlgCodes := [dcNative] + DlgcToDlgCodes(Msg.Result);\r\n GetDlgCode(DlgCodes);\r\n if not (dcNative in DlgCodes) then\r\n Msg.Result := DlgCodesToDlgc(DlgCodes);\r\n end;\r\n else\r\n inherited WndProc(Msg);\r\n end;\r\n case Msg.Msg of // precheck message to prevent access violations on released controls\r\n CM_MOUSEENTER, CM_MOUSELEAVE, WM_KILLFOCUS, WM_SETFOCUS, WM_NCPAINT:\r\n if DotNetHighlighting then\r\n HandleDotNetHighlighting(Self, Msg, MouseOver, Color);\r\n end;\r\n end;\r\nend;\r\n\r\n//============================================================================\r\n\r\nconstructor TJvExCustomUpDown.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FHintColor := clDefault;\r\nend;\r\n\r\nfunction TJvExCustomUpDown.BaseWndProc(Msg: Cardinal; WParam: WPARAM = 0; LParam: LPARAM = 0): LRESULT;\r\nvar\r\n Mesg: TMessage;\r\nbegin\r\n CreateWMMessage(Mesg, Msg, WParam, LParam);\r\n inherited WndProc(Mesg);\r\n Result := Mesg.Result;\r\nend;\r\n\r\nfunction TJvExCustomUpDown.BaseWndProc(Msg: Cardinal; WParam: WPARAM; LParam: TObject): LRESULT;\r\nbegin\r\n Result := BaseWndProc(Msg, WParam, Windows.LPARAM(LParam));\r\nend;\r\n\r\nfunction TJvExCustomUpDown.BaseWndProcEx(Msg: Cardinal; WParam: WPARAM; var StructLParam): LRESULT;\r\nbegin\r\n Result := BaseWndProc(Msg, WParam, Windows.LPARAM(@StructLParam));\r\nend;\r\n\r\nprocedure TJvExCustomUpDown.VisibleChanged;\r\nbegin\r\n BaseWndProc(CM_VISIBLECHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomUpDown.EnabledChanged;\r\nbegin\r\n BaseWndProc(CM_ENABLEDCHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomUpDown.TextChanged;\r\nbegin\r\n BaseWndProc(CM_TEXTCHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomUpDown.FontChanged;\r\nbegin\r\n BaseWndProc(CM_FONTCHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomUpDown.ColorChanged;\r\nbegin\r\n BaseWndProc(CM_COLORCHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomUpDown.ParentFontChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTFONTCHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomUpDown.ParentColorChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTCOLORCHANGED);\r\n if Assigned(OnParentColorChange) then\r\n OnParentColorChange(Self);\r\nend;\r\n\r\nprocedure TJvExCustomUpDown.ParentShowHintChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTSHOWHINTCHANGED);\r\nend;\r\n\r\nfunction TJvExCustomUpDown.WantKey(Key: Integer; Shift: TShiftState): Boolean;\r\nbegin\r\n Result := BaseWndProc(CM_DIALOGCHAR, Word(Key), ShiftStateToKeyData(Shift)) <> 0;\r\nend;\r\n\r\nfunction TJvExCustomUpDown.HitTest(X, Y: Integer): Boolean;\r\nbegin\r\n Result := BaseWndProc(CM_HITTEST, 0, SmallPointToLong(PointToSmallPoint(Point(X, Y)))) <> 0;\r\nend;\r\n\r\nfunction TJvExCustomUpDown.HintShow(var HintInfo: THintInfo): Boolean;\r\nbegin\r\n GetHintColor(HintInfo, Self, FHintColor);\r\n if FHintWindowClass <> nil then\r\n HintInfo.HintWindowClass := FHintWindowClass;\r\n Result := BaseWndProcEx(CM_HINTSHOW, 0, HintInfo) <> 0;\r\nend;\r\n\r\nprocedure TJvExCustomUpDown.MouseEnter(AControl: TControl);\r\nbegin\r\n FMouseOver := True;\r\n if Assigned(FOnMouseEnter) then\r\n FOnMouseEnter(Self);\r\n BaseWndProc(CM_MOUSEENTER, 0, AControl);\r\nend;\r\n\r\nprocedure TJvExCustomUpDown.MouseLeave(AControl: TControl);\r\nbegin\r\n FMouseOver := False;\r\n BaseWndProc(CM_MOUSELEAVE, 0, AControl);\r\n if Assigned(FOnMouseLeave) then\r\n FOnMouseLeave(Self);\r\nend;\r\n\r\nprocedure TJvExCustomUpDown.FocusChanged(AControl: TWinControl);\r\nbegin\r\n BaseWndProc(CM_FOCUSCHANGED, 0, AControl);\r\nend;\r\n\r\nprocedure TJvExCustomUpDown.BoundsChanged;\r\nbegin\r\nend;\r\n\r\nprocedure TJvExCustomUpDown.CursorChanged;\r\nbegin\r\n BaseWndProc(CM_CURSORCHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomUpDown.ShowingChanged;\r\nbegin\r\n BaseWndProc(CM_SHOWINGCHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomUpDown.ShowHintChanged;\r\nbegin\r\n BaseWndProc(CM_SHOWHINTCHANGED);\r\nend;\r\n\r\n{ VCL sends CM_CONTROLLISTCHANGE and CM_CONTROLCHANGE in a different order than\r\n the CLX methods are used. So we must correct it by evaluating \"Inserting\". }\r\nprocedure TJvExCustomUpDown.ControlsListChanging(Control: TControl; Inserting: Boolean);\r\nbegin\r\n if Inserting then\r\n BaseWndProc(CM_CONTROLLISTCHANGE, WPARAM(Control), LPARAM(Inserting))\r\n else\r\n BaseWndProc(CM_CONTROLCHANGE, WPARAM(Control), LPARAM(Inserting));\r\nend;\r\n\r\nprocedure TJvExCustomUpDown.ControlsListChanged(Control: TControl; Inserting: Boolean);\r\nbegin\r\n if not Inserting then\r\n BaseWndProc(CM_CONTROLLISTCHANGE, WPARAM(Control), LPARAM(Inserting))\r\n else\r\n BaseWndProc(CM_CONTROLCHANGE, WPARAM(Control), LPARAM(Inserting));\r\nend;\r\n\r\nprocedure TJvExCustomUpDown.GetDlgCode(var Code: TDlgCodes);\r\nbegin\r\nend;\r\n\r\nprocedure TJvExCustomUpDown.FocusSet(PrevWnd: THandle);\r\nbegin\r\n BaseWndProc(WM_SETFOCUS, WPARAM(PrevWnd), 0);\r\nend;\r\n\r\nprocedure TJvExCustomUpDown.FocusKilled(NextWnd: THandle);\r\nbegin\r\n BaseWndProc(WM_KILLFOCUS, WPARAM(NextWnd), 0);\r\nend;\r\n\r\nfunction TJvExCustomUpDown.DoEraseBackground(Canvas: TCanvas; Param: LPARAM): Boolean;\r\nbegin\r\n Result := BaseWndProc(WM_ERASEBKGND, Canvas.Handle, Param) <> 0;\r\nend;\r\n\r\n{$IFDEF JVCLThemesEnabledD6}\r\nfunction TJvExCustomUpDown.GetParentBackground: Boolean;\r\nbegin\r\n Result := JvThemes.GetParentBackground(Self);\r\nend;\r\n\r\nprocedure TJvExCustomUpDown.SetParentBackground(Value: Boolean);\r\nbegin\r\n JvThemes.SetParentBackground(Self, Value);\r\nend;\r\n{$ENDIF JVCLThemesEnabledD6}\r\n\r\nprocedure TJvExCustomUpDown.WndProc(var Msg: TMessage);\r\nvar\r\n IdSaveDC: Integer;\r\n DlgCodes: TDlgCodes;\r\n Canvas: TCanvas;\r\nbegin\r\n if not DispatchIsDesignMsg(Self, Msg) then\r\n begin\r\n case Msg.Msg of\r\n CM_DENYSUBCLASSING:\r\n Msg.Result := LRESULT(Ord(GetInterfaceEntry(IJvDenySubClassing) <> nil));\r\n CM_DIALOGCHAR:\r\n with TCMDialogChar{$IFDEF CLR}.Create{$ENDIF}(Msg) do\r\n Result := LRESULT(Ord(WantKey(CharCode, KeyDataToShiftState(KeyData))));\r\n CM_HINTSHOW:\r\n with TCMHintShow(Msg) do\r\n Result := LRESULT(HintShow(HintInfo^));\r\n CM_HITTEST:\r\n with TCMHitTest(Msg) do\r\n Result := LRESULT(HitTest(XPos, YPos));\r\n CM_MOUSEENTER:\r\n MouseEnter(TControl(Msg.LParam));\r\n CM_MOUSELEAVE:\r\n MouseLeave(TControl(Msg.LParam));\r\n CM_VISIBLECHANGED:\r\n VisibleChanged;\r\n CM_ENABLEDCHANGED:\r\n EnabledChanged;\r\n CM_TEXTCHANGED:\r\n TextChanged;\r\n CM_FONTCHANGED:\r\n FontChanged;\r\n CM_COLORCHANGED:\r\n ColorChanged;\r\n CM_FOCUSCHANGED:\r\n FocusChanged(TWinControl(Msg.LParam));\r\n CM_PARENTFONTCHANGED:\r\n ParentFontChanged;\r\n CM_PARENTCOLORCHANGED:\r\n ParentColorChanged;\r\n CM_PARENTSHOWHINTCHANGED:\r\n ParentShowHintChanged;\r\n CM_CURSORCHANGED:\r\n CursorChanged;\r\n CM_SHOWINGCHANGED:\r\n ShowingChanged;\r\n CM_SHOWHINTCHANGED:\r\n ShowHintChanged;\r\n CM_CONTROLLISTCHANGE:\r\n if Msg.LParam <> 0 then\r\n ControlsListChanging(TControl(Msg.WParam), True)\r\n else\r\n ControlsListChanged(TControl(Msg.WParam), False);\r\n CM_CONTROLCHANGE:\r\n if Msg.LParam = 0 then\r\n ControlsListChanging(TControl(Msg.WParam), False)\r\n else\r\n ControlsListChanged(TControl(Msg.WParam), True);\r\n WM_SETFOCUS:\r\n FocusSet(THandle(Msg.WParam));\r\n WM_KILLFOCUS:\r\n FocusKilled(THandle(Msg.WParam));\r\n WM_SIZE, WM_MOVE:\r\n begin\r\n inherited WndProc(Msg);\r\n BoundsChanged;\r\n end;\r\n WM_ERASEBKGND:\r\n if (Msg.WParam <> 0) and not IsDefaultEraseBackground(DoEraseBackground, @TJvExCustomUpDown.DoEraseBackground) then\r\n begin\r\n IdSaveDC := SaveDC(HDC(Msg.WParam)); // protect DC against Stock-Objects from Canvas\r\n Canvas := TCanvas.Create;\r\n try\r\n Canvas.Handle := HDC(Msg.WParam);\r\n Msg.Result := Ord(DoEraseBackground(Canvas, Msg.LParam));\r\n finally\r\n Canvas.Handle := 0;\r\n Canvas.Free;\r\n RestoreDC(HDC(Msg.WParam), IdSaveDC);\r\n end;\r\n end\r\n else\r\n inherited WndProc(Msg);\r\n {$IFNDEF DELPHI2007_UP}\r\n WM_PRINTCLIENT, WM_PRINT: // VCL bug fix\r\n begin\r\n IdSaveDC := SaveDC(HDC(Msg.WParam)); // protect DC against changes\r\n try\r\n inherited WndProc(Msg);\r\n finally\r\n RestoreDC(HDC(Msg.WParam), IdSaveDC);\r\n end;\r\n end;\r\n {$ENDIF ~DELPHI2007_UP}\r\n WM_GETDLGCODE:\r\n begin\r\n inherited WndProc(Msg);\r\n DlgCodes := [dcNative] + DlgcToDlgCodes(Msg.Result);\r\n GetDlgCode(DlgCodes);\r\n if not (dcNative in DlgCodes) then\r\n Msg.Result := DlgCodesToDlgc(DlgCodes);\r\n end;\r\n else\r\n inherited WndProc(Msg);\r\n end;\r\n case Msg.Msg of // precheck message to prevent access violations on released controls\r\n CM_MOUSEENTER, CM_MOUSELEAVE, WM_KILLFOCUS, WM_SETFOCUS, WM_NCPAINT:\r\n if DotNetHighlighting then\r\n HandleDotNetHighlighting(Self, Msg, MouseOver, Color);\r\n end;\r\n end;\r\nend;\r\n\r\n//============================================================================\r\n\r\nconstructor TJvExUpDown.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FHintColor := clDefault;\r\nend;\r\n\r\nfunction TJvExUpDown.BaseWndProc(Msg: Cardinal; WParam: WPARAM = 0; LParam: LPARAM = 0): LRESULT;\r\nvar\r\n Mesg: TMessage;\r\nbegin\r\n CreateWMMessage(Mesg, Msg, WParam, LParam);\r\n inherited WndProc(Mesg);\r\n Result := Mesg.Result;\r\nend;\r\n\r\nfunction TJvExUpDown.BaseWndProc(Msg: Cardinal; WParam: WPARAM; LParam: TObject): LRESULT;\r\nbegin\r\n Result := BaseWndProc(Msg, WParam, Windows.LPARAM(LParam));\r\nend;\r\n\r\nfunction TJvExUpDown.BaseWndProcEx(Msg: Cardinal; WParam: WPARAM; var StructLParam): LRESULT;\r\nbegin\r\n Result := BaseWndProc(Msg, WParam, Windows.LPARAM(@StructLParam));\r\nend;\r\n\r\nprocedure TJvExUpDown.VisibleChanged;\r\nbegin\r\n BaseWndProc(CM_VISIBLECHANGED);\r\nend;\r\n\r\nprocedure TJvExUpDown.EnabledChanged;\r\nbegin\r\n BaseWndProc(CM_ENABLEDCHANGED);\r\nend;\r\n\r\nprocedure TJvExUpDown.TextChanged;\r\nbegin\r\n BaseWndProc(CM_TEXTCHANGED);\r\nend;\r\n\r\nprocedure TJvExUpDown.FontChanged;\r\nbegin\r\n BaseWndProc(CM_FONTCHANGED);\r\nend;\r\n\r\nprocedure TJvExUpDown.ColorChanged;\r\nbegin\r\n BaseWndProc(CM_COLORCHANGED);\r\nend;\r\n\r\nprocedure TJvExUpDown.ParentFontChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTFONTCHANGED);\r\nend;\r\n\r\nprocedure TJvExUpDown.ParentColorChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTCOLORCHANGED);\r\n if Assigned(OnParentColorChange) then\r\n OnParentColorChange(Self);\r\nend;\r\n\r\nprocedure TJvExUpDown.ParentShowHintChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTSHOWHINTCHANGED);\r\nend;\r\n\r\nfunction TJvExUpDown.WantKey(Key: Integer; Shift: TShiftState): Boolean;\r\nbegin\r\n Result := BaseWndProc(CM_DIALOGCHAR, Word(Key), ShiftStateToKeyData(Shift)) <> 0;\r\nend;\r\n\r\nfunction TJvExUpDown.HitTest(X, Y: Integer): Boolean;\r\nbegin\r\n Result := BaseWndProc(CM_HITTEST, 0, SmallPointToLong(PointToSmallPoint(Point(X, Y)))) <> 0;\r\nend;\r\n\r\nfunction TJvExUpDown.HintShow(var HintInfo: THintInfo): Boolean;\r\nbegin\r\n GetHintColor(HintInfo, Self, FHintColor);\r\n if FHintWindowClass <> nil then\r\n HintInfo.HintWindowClass := FHintWindowClass;\r\n Result := BaseWndProcEx(CM_HINTSHOW, 0, HintInfo) <> 0;\r\nend;\r\n\r\nprocedure TJvExUpDown.MouseEnter(AControl: TControl);\r\nbegin\r\n FMouseOver := True;\r\n if Assigned(FOnMouseEnter) then\r\n FOnMouseEnter(Self);\r\n BaseWndProc(CM_MOUSEENTER, 0, AControl);\r\nend;\r\n\r\nprocedure TJvExUpDown.MouseLeave(AControl: TControl);\r\nbegin\r\n FMouseOver := False;\r\n BaseWndProc(CM_MOUSELEAVE, 0, AControl);\r\n if Assigned(FOnMouseLeave) then\r\n FOnMouseLeave(Self);\r\nend;\r\n\r\nprocedure TJvExUpDown.FocusChanged(AControl: TWinControl);\r\nbegin\r\n BaseWndProc(CM_FOCUSCHANGED, 0, AControl);\r\nend;\r\n\r\nprocedure TJvExUpDown.BoundsChanged;\r\nbegin\r\nend;\r\n\r\nprocedure TJvExUpDown.CursorChanged;\r\nbegin\r\n BaseWndProc(CM_CURSORCHANGED);\r\nend;\r\n\r\nprocedure TJvExUpDown.ShowingChanged;\r\nbegin\r\n BaseWndProc(CM_SHOWINGCHANGED);\r\nend;\r\n\r\nprocedure TJvExUpDown.ShowHintChanged;\r\nbegin\r\n BaseWndProc(CM_SHOWHINTCHANGED);\r\nend;\r\n\r\n{ VCL sends CM_CONTROLLISTCHANGE and CM_CONTROLCHANGE in a different order than\r\n the CLX methods are used. So we must correct it by evaluating \"Inserting\". }\r\nprocedure TJvExUpDown.ControlsListChanging(Control: TControl; Inserting: Boolean);\r\nbegin\r\n if Inserting then\r\n BaseWndProc(CM_CONTROLLISTCHANGE, WPARAM(Control), LPARAM(Inserting))\r\n else\r\n BaseWndProc(CM_CONTROLCHANGE, WPARAM(Control), LPARAM(Inserting));\r\nend;\r\n\r\nprocedure TJvExUpDown.ControlsListChanged(Control: TControl; Inserting: Boolean);\r\nbegin\r\n if not Inserting then\r\n BaseWndProc(CM_CONTROLLISTCHANGE, WPARAM(Control), LPARAM(Inserting))\r\n else\r\n BaseWndProc(CM_CONTROLCHANGE, WPARAM(Control), LPARAM(Inserting));\r\nend;\r\n\r\nprocedure TJvExUpDown.GetDlgCode(var Code: TDlgCodes);\r\nbegin\r\nend;\r\n\r\nprocedure TJvExUpDown.FocusSet(PrevWnd: THandle);\r\nbegin\r\n BaseWndProc(WM_SETFOCUS, WPARAM(PrevWnd), 0);\r\nend;\r\n\r\nprocedure TJvExUpDown.FocusKilled(NextWnd: THandle);\r\nbegin\r\n BaseWndProc(WM_KILLFOCUS, WPARAM(NextWnd), 0);\r\nend;\r\n\r\nfunction TJvExUpDown.DoEraseBackground(Canvas: TCanvas; Param: LPARAM): Boolean;\r\nbegin\r\n Result := BaseWndProc(WM_ERASEBKGND, Canvas.Handle, Param) <> 0;\r\nend;\r\n\r\n{$IFDEF JVCLThemesEnabledD6}\r\nfunction TJvExUpDown.GetParentBackground: Boolean;\r\nbegin\r\n Result := JvThemes.GetParentBackground(Self);\r\nend;\r\n\r\nprocedure TJvExUpDown.SetParentBackground(Value: Boolean);\r\nbegin\r\n JvThemes.SetParentBackground(Self, Value);\r\nend;\r\n{$ENDIF JVCLThemesEnabledD6}\r\n\r\nprocedure TJvExUpDown.WndProc(var Msg: TMessage);\r\nvar\r\n IdSaveDC: Integer;\r\n DlgCodes: TDlgCodes;\r\n Canvas: TCanvas;\r\nbegin\r\n if not DispatchIsDesignMsg(Self, Msg) then\r\n begin\r\n case Msg.Msg of\r\n CM_DENYSUBCLASSING:\r\n Msg.Result := LRESULT(Ord(GetInterfaceEntry(IJvDenySubClassing) <> nil));\r\n CM_DIALOGCHAR:\r\n with TCMDialogChar{$IFDEF CLR}.Create{$ENDIF}(Msg) do\r\n Result := LRESULT(Ord(WantKey(CharCode, KeyDataToShiftState(KeyData))));\r\n CM_HINTSHOW:\r\n with TCMHintShow(Msg) do\r\n Result := LRESULT(HintShow(HintInfo^));\r\n CM_HITTEST:\r\n with TCMHitTest(Msg) do\r\n Result := LRESULT(HitTest(XPos, YPos));\r\n CM_MOUSEENTER:\r\n MouseEnter(TControl(Msg.LParam));\r\n CM_MOUSELEAVE:\r\n MouseLeave(TControl(Msg.LParam));\r\n CM_VISIBLECHANGED:\r\n VisibleChanged;\r\n CM_ENABLEDCHANGED:\r\n EnabledChanged;\r\n CM_TEXTCHANGED:\r\n TextChanged;\r\n CM_FONTCHANGED:\r\n FontChanged;\r\n CM_COLORCHANGED:\r\n ColorChanged;\r\n CM_FOCUSCHANGED:\r\n FocusChanged(TWinControl(Msg.LParam));\r\n CM_PARENTFONTCHANGED:\r\n ParentFontChanged;\r\n CM_PARENTCOLORCHANGED:\r\n ParentColorChanged;\r\n CM_PARENTSHOWHINTCHANGED:\r\n ParentShowHintChanged;\r\n CM_CURSORCHANGED:\r\n CursorChanged;\r\n CM_SHOWINGCHANGED:\r\n ShowingChanged;\r\n CM_SHOWHINTCHANGED:\r\n ShowHintChanged;\r\n CM_CONTROLLISTCHANGE:\r\n if Msg.LParam <> 0 then\r\n ControlsListChanging(TControl(Msg.WParam), True)\r\n else\r\n ControlsListChanged(TControl(Msg.WParam), False);\r\n CM_CONTROLCHANGE:\r\n if Msg.LParam = 0 then\r\n ControlsListChanging(TControl(Msg.WParam), False)\r\n else\r\n ControlsListChanged(TControl(Msg.WParam), True);\r\n WM_SETFOCUS:\r\n FocusSet(THandle(Msg.WParam));\r\n WM_KILLFOCUS:\r\n FocusKilled(THandle(Msg.WParam));\r\n WM_SIZE, WM_MOVE:\r\n begin\r\n inherited WndProc(Msg);\r\n BoundsChanged;\r\n end;\r\n WM_ERASEBKGND:\r\n if (Msg.WParam <> 0) and not IsDefaultEraseBackground(DoEraseBackground, @TJvExUpDown.DoEraseBackground) then\r\n begin\r\n IdSaveDC := SaveDC(HDC(Msg.WParam)); // protect DC against Stock-Objects from Canvas\r\n Canvas := TCanvas.Create;\r\n try\r\n Canvas.Handle := HDC(Msg.WParam);\r\n Msg.Result := Ord(DoEraseBackground(Canvas, Msg.LParam));\r\n finally\r\n Canvas.Handle := 0;\r\n Canvas.Free;\r\n RestoreDC(HDC(Msg.WParam), IdSaveDC);\r\n end;\r\n end\r\n else\r\n inherited WndProc(Msg);\r\n {$IFNDEF DELPHI2007_UP}\r\n WM_PRINTCLIENT, WM_PRINT: // VCL bug fix\r\n begin\r\n IdSaveDC := SaveDC(HDC(Msg.WParam)); // protect DC against changes\r\n try\r\n inherited WndProc(Msg);\r\n finally\r\n RestoreDC(HDC(Msg.WParam), IdSaveDC);\r\n end;\r\n end;\r\n {$ENDIF ~DELPHI2007_UP}\r\n WM_GETDLGCODE:\r\n begin\r\n inherited WndProc(Msg);\r\n DlgCodes := [dcNative] + DlgcToDlgCodes(Msg.Result);\r\n GetDlgCode(DlgCodes);\r\n if not (dcNative in DlgCodes) then\r\n Msg.Result := DlgCodesToDlgc(DlgCodes);\r\n end;\r\n else\r\n inherited WndProc(Msg);\r\n end;\r\n case Msg.Msg of // precheck message to prevent access violations on released controls\r\n CM_MOUSEENTER, CM_MOUSELEAVE, WM_KILLFOCUS, WM_SETFOCUS, WM_NCPAINT:\r\n if DotNetHighlighting then\r\n HandleDotNetHighlighting(Self, Msg, MouseOver, Color);\r\n end;\r\n end;\r\nend;\r\n\r\n//============================================================================\r\n\r\nconstructor TJvExDateTimePicker.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FHintColor := clDefault;\r\nend;\r\n\r\nfunction TJvExDateTimePicker.BaseWndProc(Msg: Cardinal; WParam: WPARAM = 0; LParam: LPARAM = 0): LRESULT;\r\nvar\r\n Mesg: TMessage;\r\nbegin\r\n CreateWMMessage(Mesg, Msg, WParam, LParam);\r\n inherited WndProc(Mesg);\r\n Result := Mesg.Result;\r\nend;\r\n\r\nfunction TJvExDateTimePicker.BaseWndProc(Msg: Cardinal; WParam: WPARAM; LParam: TObject): LRESULT;\r\nbegin\r\n Result := BaseWndProc(Msg, WParam, Windows.LPARAM(LParam));\r\nend;\r\n\r\nfunction TJvExDateTimePicker.BaseWndProcEx(Msg: Cardinal; WParam: WPARAM; var StructLParam): LRESULT;\r\nbegin\r\n Result := BaseWndProc(Msg, WParam, Windows.LPARAM(@StructLParam));\r\nend;\r\n\r\nprocedure TJvExDateTimePicker.VisibleChanged;\r\nbegin\r\n BaseWndProc(CM_VISIBLECHANGED);\r\nend;\r\n\r\nprocedure TJvExDateTimePicker.EnabledChanged;\r\nbegin\r\n BaseWndProc(CM_ENABLEDCHANGED);\r\nend;\r\n\r\nprocedure TJvExDateTimePicker.TextChanged;\r\nbegin\r\n BaseWndProc(CM_TEXTCHANGED);\r\nend;\r\n\r\nprocedure TJvExDateTimePicker.FontChanged;\r\nbegin\r\n BaseWndProc(CM_FONTCHANGED);\r\nend;\r\n\r\nprocedure TJvExDateTimePicker.ColorChanged;\r\nbegin\r\n BaseWndProc(CM_COLORCHANGED);\r\nend;\r\n\r\nprocedure TJvExDateTimePicker.ParentFontChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTFONTCHANGED);\r\nend;\r\n\r\nprocedure TJvExDateTimePicker.ParentColorChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTCOLORCHANGED);\r\n if Assigned(OnParentColorChange) then\r\n OnParentColorChange(Self);\r\nend;\r\n\r\nprocedure TJvExDateTimePicker.ParentShowHintChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTSHOWHINTCHANGED);\r\nend;\r\n\r\nfunction TJvExDateTimePicker.WantKey(Key: Integer; Shift: TShiftState): Boolean;\r\nbegin\r\n Result := BaseWndProc(CM_DIALOGCHAR, Word(Key), ShiftStateToKeyData(Shift)) <> 0;\r\nend;\r\n\r\nfunction TJvExDateTimePicker.HitTest(X, Y: Integer): Boolean;\r\nbegin\r\n Result := BaseWndProc(CM_HITTEST, 0, SmallPointToLong(PointToSmallPoint(Point(X, Y)))) <> 0;\r\nend;\r\n\r\nfunction TJvExDateTimePicker.HintShow(var HintInfo: THintInfo): Boolean;\r\nbegin\r\n GetHintColor(HintInfo, Self, FHintColor);\r\n if FHintWindowClass <> nil then\r\n HintInfo.HintWindowClass := FHintWindowClass;\r\n Result := BaseWndProcEx(CM_HINTSHOW, 0, HintInfo) <> 0;\r\nend;\r\n\r\nprocedure TJvExDateTimePicker.MouseEnter(AControl: TControl);\r\nbegin\r\n FMouseOver := True;\r\n if Assigned(FOnMouseEnter) then\r\n FOnMouseEnter(Self);\r\n BaseWndProc(CM_MOUSEENTER, 0, AControl);\r\nend;\r\n\r\nprocedure TJvExDateTimePicker.MouseLeave(AControl: TControl);\r\nbegin\r\n FMouseOver := False;\r\n BaseWndProc(CM_MOUSELEAVE, 0, AControl);\r\n if Assigned(FOnMouseLeave) then\r\n FOnMouseLeave(Self);\r\nend;\r\n\r\nprocedure TJvExDateTimePicker.FocusChanged(AControl: TWinControl);\r\nbegin\r\n BaseWndProc(CM_FOCUSCHANGED, 0, AControl);\r\nend;\r\n\r\nprocedure TJvExDateTimePicker.BoundsChanged;\r\nbegin\r\nend;\r\n\r\nprocedure TJvExDateTimePicker.CursorChanged;\r\nbegin\r\n BaseWndProc(CM_CURSORCHANGED);\r\nend;\r\n\r\nprocedure TJvExDateTimePicker.ShowingChanged;\r\nbegin\r\n BaseWndProc(CM_SHOWINGCHANGED);\r\nend;\r\n\r\nprocedure TJvExDateTimePicker.ShowHintChanged;\r\nbegin\r\n BaseWndProc(CM_SHOWHINTCHANGED);\r\nend;\r\n\r\n{ VCL sends CM_CONTROLLISTCHANGE and CM_CONTROLCHANGE in a different order than\r\n the CLX methods are used. So we must correct it by evaluating \"Inserting\". }\r\nprocedure TJvExDateTimePicker.ControlsListChanging(Control: TControl; Inserting: Boolean);\r\nbegin\r\n if Inserting then\r\n BaseWndProc(CM_CONTROLLISTCHANGE, WPARAM(Control), LPARAM(Inserting))\r\n else\r\n BaseWndProc(CM_CONTROLCHANGE, WPARAM(Control), LPARAM(Inserting));\r\nend;\r\n\r\nprocedure TJvExDateTimePicker.ControlsListChanged(Control: TControl; Inserting: Boolean);\r\nbegin\r\n if not Inserting then\r\n BaseWndProc(CM_CONTROLLISTCHANGE, WPARAM(Control), LPARAM(Inserting))\r\n else\r\n BaseWndProc(CM_CONTROLCHANGE, WPARAM(Control), LPARAM(Inserting));\r\nend;\r\n\r\nprocedure TJvExDateTimePicker.GetDlgCode(var Code: TDlgCodes);\r\nbegin\r\nend;\r\n\r\nprocedure TJvExDateTimePicker.FocusSet(PrevWnd: THandle);\r\nbegin\r\n BaseWndProc(WM_SETFOCUS, WPARAM(PrevWnd), 0);\r\nend;\r\n\r\nprocedure TJvExDateTimePicker.FocusKilled(NextWnd: THandle);\r\nbegin\r\n BaseWndProc(WM_KILLFOCUS, WPARAM(NextWnd), 0);\r\nend;\r\n\r\nfunction TJvExDateTimePicker.DoEraseBackground(Canvas: TCanvas; Param: LPARAM): Boolean;\r\nbegin\r\n Result := BaseWndProc(WM_ERASEBKGND, Canvas.Handle, Param) <> 0;\r\nend;\r\n\r\n{$IFDEF JVCLThemesEnabledD6}\r\nfunction TJvExDateTimePicker.GetParentBackground: Boolean;\r\nbegin\r\n Result := JvThemes.GetParentBackground(Self);\r\nend;\r\n\r\nprocedure TJvExDateTimePicker.SetParentBackground(Value: Boolean);\r\nbegin\r\n JvThemes.SetParentBackground(Self, Value);\r\nend;\r\n{$ENDIF JVCLThemesEnabledD6}\r\n\r\nprocedure TJvExDateTimePicker.WndProc(var Msg: TMessage);\r\nvar\r\n IdSaveDC: Integer;\r\n DlgCodes: TDlgCodes;\r\n Canvas: TCanvas;\r\nbegin\r\n if not DispatchIsDesignMsg(Self, Msg) then\r\n begin\r\n case Msg.Msg of\r\n CM_DENYSUBCLASSING:\r\n Msg.Result := LRESULT(Ord(GetInterfaceEntry(IJvDenySubClassing) <> nil));\r\n CM_DIALOGCHAR:\r\n with TCMDialogChar{$IFDEF CLR}.Create{$ENDIF}(Msg) do\r\n Result := LRESULT(Ord(WantKey(CharCode, KeyDataToShiftState(KeyData))));\r\n CM_HINTSHOW:\r\n with TCMHintShow(Msg) do\r\n Result := LRESULT(HintShow(HintInfo^));\r\n CM_HITTEST:\r\n with TCMHitTest(Msg) do\r\n Result := LRESULT(HitTest(XPos, YPos));\r\n CM_MOUSEENTER:\r\n MouseEnter(TControl(Msg.LParam));\r\n CM_MOUSELEAVE:\r\n MouseLeave(TControl(Msg.LParam));\r\n CM_VISIBLECHANGED:\r\n VisibleChanged;\r\n CM_ENABLEDCHANGED:\r\n EnabledChanged;\r\n CM_TEXTCHANGED:\r\n TextChanged;\r\n CM_FONTCHANGED:\r\n FontChanged;\r\n CM_COLORCHANGED:\r\n ColorChanged;\r\n CM_FOCUSCHANGED:\r\n FocusChanged(TWinControl(Msg.LParam));\r\n CM_PARENTFONTCHANGED:\r\n ParentFontChanged;\r\n CM_PARENTCOLORCHANGED:\r\n ParentColorChanged;\r\n CM_PARENTSHOWHINTCHANGED:\r\n ParentShowHintChanged;\r\n CM_CURSORCHANGED:\r\n CursorChanged;\r\n CM_SHOWINGCHANGED:\r\n ShowingChanged;\r\n CM_SHOWHINTCHANGED:\r\n ShowHintChanged;\r\n CM_CONTROLLISTCHANGE:\r\n if Msg.LParam <> 0 then\r\n ControlsListChanging(TControl(Msg.WParam), True)\r\n else\r\n ControlsListChanged(TControl(Msg.WParam), False);\r\n CM_CONTROLCHANGE:\r\n if Msg.LParam = 0 then\r\n ControlsListChanging(TControl(Msg.WParam), False)\r\n else\r\n ControlsListChanged(TControl(Msg.WParam), True);\r\n WM_SETFOCUS:\r\n FocusSet(THandle(Msg.WParam));\r\n WM_KILLFOCUS:\r\n FocusKilled(THandle(Msg.WParam));\r\n WM_SIZE, WM_MOVE:\r\n begin\r\n inherited WndProc(Msg);\r\n BoundsChanged;\r\n end;\r\n WM_ERASEBKGND:\r\n if (Msg.WParam <> 0) and not IsDefaultEraseBackground(DoEraseBackground, @TJvExDateTimePicker.DoEraseBackground) then\r\n begin\r\n IdSaveDC := SaveDC(HDC(Msg.WParam)); // protect DC against Stock-Objects from Canvas\r\n Canvas := TCanvas.Create;\r\n try\r\n Canvas.Handle := HDC(Msg.WParam);\r\n Msg.Result := Ord(DoEraseBackground(Canvas, Msg.LParam));\r\n finally\r\n Canvas.Handle := 0;\r\n Canvas.Free;\r\n RestoreDC(HDC(Msg.WParam), IdSaveDC);\r\n end;\r\n end\r\n else\r\n inherited WndProc(Msg);\r\n {$IFNDEF DELPHI2007_UP}\r\n WM_PRINTCLIENT, WM_PRINT: // VCL bug fix\r\n begin\r\n IdSaveDC := SaveDC(HDC(Msg.WParam)); // protect DC against changes\r\n try\r\n inherited WndProc(Msg);\r\n finally\r\n RestoreDC(HDC(Msg.WParam), IdSaveDC);\r\n end;\r\n end;\r\n {$ENDIF ~DELPHI2007_UP}\r\n WM_GETDLGCODE:\r\n begin\r\n inherited WndProc(Msg);\r\n DlgCodes := [dcNative] + DlgcToDlgCodes(Msg.Result);\r\n GetDlgCode(DlgCodes);\r\n if not (dcNative in DlgCodes) then\r\n Msg.Result := DlgCodesToDlgc(DlgCodes);\r\n end;\r\n else\r\n inherited WndProc(Msg);\r\n end;\r\n case Msg.Msg of // precheck message to prevent access violations on released controls\r\n CM_MOUSEENTER, CM_MOUSELEAVE, WM_KILLFOCUS, WM_SETFOCUS, WM_NCPAINT:\r\n if DotNetHighlighting then\r\n HandleDotNetHighlighting(Self, Msg, MouseOver, Color);\r\n end;\r\n end;\r\nend;\r\n\r\n//============================================================================\r\n\r\nconstructor TJvExProgressBar.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FHintColor := clDefault;\r\nend;\r\n\r\nfunction TJvExProgressBar.BaseWndProc(Msg: Cardinal; WParam: WPARAM = 0; LParam: LPARAM = 0): LRESULT;\r\nvar\r\n Mesg: TMessage;\r\nbegin\r\n CreateWMMessage(Mesg, Msg, WParam, LParam);\r\n inherited WndProc(Mesg);\r\n Result := Mesg.Result;\r\nend;\r\n\r\nfunction TJvExProgressBar.BaseWndProc(Msg: Cardinal; WParam: WPARAM; LParam: TObject): LRESULT;\r\nbegin\r\n Result := BaseWndProc(Msg, WParam, Windows.LPARAM(LParam));\r\nend;\r\n\r\nfunction TJvExProgressBar.BaseWndProcEx(Msg: Cardinal; WParam: WPARAM; var StructLParam): LRESULT;\r\nbegin\r\n Result := BaseWndProc(Msg, WParam, Windows.LPARAM(@StructLParam));\r\nend;\r\n\r\nprocedure TJvExProgressBar.VisibleChanged;\r\nbegin\r\n BaseWndProc(CM_VISIBLECHANGED);\r\nend;\r\n\r\nprocedure TJvExProgressBar.EnabledChanged;\r\nbegin\r\n BaseWndProc(CM_ENABLEDCHANGED);\r\nend;\r\n\r\nprocedure TJvExProgressBar.TextChanged;\r\nbegin\r\n BaseWndProc(CM_TEXTCHANGED);\r\nend;\r\n\r\nprocedure TJvExProgressBar.FontChanged;\r\nbegin\r\n BaseWndProc(CM_FONTCHANGED);\r\nend;\r\n\r\nprocedure TJvExProgressBar.ColorChanged;\r\nbegin\r\n BaseWndProc(CM_COLORCHANGED);\r\nend;\r\n\r\nprocedure TJvExProgressBar.ParentFontChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTFONTCHANGED);\r\nend;\r\n\r\nprocedure TJvExProgressBar.ParentColorChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTCOLORCHANGED);\r\n if Assigned(OnParentColorChange) then\r\n OnParentColorChange(Self);\r\nend;\r\n\r\nprocedure TJvExProgressBar.ParentShowHintChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTSHOWHINTCHANGED);\r\nend;\r\n\r\nfunction TJvExProgressBar.WantKey(Key: Integer; Shift: TShiftState): Boolean;\r\nbegin\r\n Result := BaseWndProc(CM_DIALOGCHAR, Word(Key), ShiftStateToKeyData(Shift)) <> 0;\r\nend;\r\n\r\nfunction TJvExProgressBar.HitTest(X, Y: Integer): Boolean;\r\nbegin\r\n Result := BaseWndProc(CM_HITTEST, 0, SmallPointToLong(PointToSmallPoint(Point(X, Y)))) <> 0;\r\nend;\r\n\r\nfunction TJvExProgressBar.HintShow(var HintInfo: THintInfo): Boolean;\r\nbegin\r\n GetHintColor(HintInfo, Self, FHintColor);\r\n if FHintWindowClass <> nil then\r\n HintInfo.HintWindowClass := FHintWindowClass;\r\n Result := BaseWndProcEx(CM_HINTSHOW, 0, HintInfo) <> 0;\r\nend;\r\n\r\nprocedure TJvExProgressBar.MouseEnter(AControl: TControl);\r\nbegin\r\n FMouseOver := True;\r\n if Assigned(FOnMouseEnter) then\r\n FOnMouseEnter(Self);\r\n BaseWndProc(CM_MOUSEENTER, 0, AControl);\r\nend;\r\n\r\nprocedure TJvExProgressBar.MouseLeave(AControl: TControl);\r\nbegin\r\n FMouseOver := False;\r\n BaseWndProc(CM_MOUSELEAVE, 0, AControl);\r\n if Assigned(FOnMouseLeave) then\r\n FOnMouseLeave(Self);\r\nend;\r\n\r\nprocedure TJvExProgressBar.FocusChanged(AControl: TWinControl);\r\nbegin\r\n BaseWndProc(CM_FOCUSCHANGED, 0, AControl);\r\nend;\r\n\r\nprocedure TJvExProgressBar.BoundsChanged;\r\nbegin\r\nend;\r\n\r\nprocedure TJvExProgressBar.CursorChanged;\r\nbegin\r\n BaseWndProc(CM_CURSORCHANGED);\r\nend;\r\n\r\nprocedure TJvExProgressBar.ShowingChanged;\r\nbegin\r\n BaseWndProc(CM_SHOWINGCHANGED);\r\nend;\r\n\r\nprocedure TJvExProgressBar.ShowHintChanged;\r\nbegin\r\n BaseWndProc(CM_SHOWHINTCHANGED);\r\nend;\r\n\r\n{ VCL sends CM_CONTROLLISTCHANGE and CM_CONTROLCHANGE in a different order than\r\n the CLX methods are used. So we must correct it by evaluating \"Inserting\". }\r\nprocedure TJvExProgressBar.ControlsListChanging(Control: TControl; Inserting: Boolean);\r\nbegin\r\n if Inserting then\r\n BaseWndProc(CM_CONTROLLISTCHANGE, WPARAM(Control), LPARAM(Inserting))\r\n else\r\n BaseWndProc(CM_CONTROLCHANGE, WPARAM(Control), LPARAM(Inserting));\r\nend;\r\n\r\nprocedure TJvExProgressBar.ControlsListChanged(Control: TControl; Inserting: Boolean);\r\nbegin\r\n if not Inserting then\r\n BaseWndProc(CM_CONTROLLISTCHANGE, WPARAM(Control), LPARAM(Inserting))\r\n else\r\n BaseWndProc(CM_CONTROLCHANGE, WPARAM(Control), LPARAM(Inserting));\r\nend;\r\n\r\nprocedure TJvExProgressBar.GetDlgCode(var Code: TDlgCodes);\r\nbegin\r\nend;\r\n\r\nprocedure TJvExProgressBar.FocusSet(PrevWnd: THandle);\r\nbegin\r\n BaseWndProc(WM_SETFOCUS, WPARAM(PrevWnd), 0);\r\nend;\r\n\r\nprocedure TJvExProgressBar.FocusKilled(NextWnd: THandle);\r\nbegin\r\n BaseWndProc(WM_KILLFOCUS, WPARAM(NextWnd), 0);\r\nend;\r\n\r\nfunction TJvExProgressBar.DoEraseBackground(Canvas: TCanvas; Param: LPARAM): Boolean;\r\nbegin\r\n Result := BaseWndProc(WM_ERASEBKGND, Canvas.Handle, Param) <> 0;\r\nend;\r\n\r\n{$IFDEF JVCLThemesEnabledD6}\r\nfunction TJvExProgressBar.GetParentBackground: Boolean;\r\nbegin\r\n Result := JvThemes.GetParentBackground(Self);\r\nend;\r\n\r\nprocedure TJvExProgressBar.SetParentBackground(Value: Boolean);\r\nbegin\r\n JvThemes.SetParentBackground(Self, Value);\r\nend;\r\n{$ENDIF JVCLThemesEnabledD6}\r\n\r\nprocedure TJvExProgressBar.WndProc(var Msg: TMessage);\r\nvar\r\n IdSaveDC: Integer;\r\n DlgCodes: TDlgCodes;\r\n Canvas: TCanvas;\r\nbegin\r\n if not DispatchIsDesignMsg(Self, Msg) then\r\n begin\r\n case Msg.Msg of\r\n CM_DENYSUBCLASSING:\r\n Msg.Result := LRESULT(Ord(GetInterfaceEntry(IJvDenySubClassing) <> nil));\r\n CM_DIALOGCHAR:\r\n with TCMDialogChar{$IFDEF CLR}.Create{$ENDIF}(Msg) do\r\n Result := LRESULT(Ord(WantKey(CharCode, KeyDataToShiftState(KeyData))));\r\n CM_HINTSHOW:\r\n with TCMHintShow(Msg) do\r\n Result := LRESULT(HintShow(HintInfo^));\r\n CM_HITTEST:\r\n with TCMHitTest(Msg) do\r\n Result := LRESULT(HitTest(XPos, YPos));\r\n CM_MOUSEENTER:\r\n MouseEnter(TControl(Msg.LParam));\r\n CM_MOUSELEAVE:\r\n MouseLeave(TControl(Msg.LParam));\r\n CM_VISIBLECHANGED:\r\n VisibleChanged;\r\n CM_ENABLEDCHANGED:\r\n EnabledChanged;\r\n CM_TEXTCHANGED:\r\n TextChanged;\r\n CM_FONTCHANGED:\r\n FontChanged;\r\n CM_COLORCHANGED:\r\n ColorChanged;\r\n CM_FOCUSCHANGED:\r\n FocusChanged(TWinControl(Msg.LParam));\r\n CM_PARENTFONTCHANGED:\r\n ParentFontChanged;\r\n CM_PARENTCOLORCHANGED:\r\n ParentColorChanged;\r\n CM_PARENTSHOWHINTCHANGED:\r\n ParentShowHintChanged;\r\n CM_CURSORCHANGED:\r\n CursorChanged;\r\n CM_SHOWINGCHANGED:\r\n ShowingChanged;\r\n CM_SHOWHINTCHANGED:\r\n ShowHintChanged;\r\n CM_CONTROLLISTCHANGE:\r\n if Msg.LParam <> 0 then\r\n ControlsListChanging(TControl(Msg.WParam), True)\r\n else\r\n ControlsListChanged(TControl(Msg.WParam), False);\r\n CM_CONTROLCHANGE:\r\n if Msg.LParam = 0 then\r\n ControlsListChanging(TControl(Msg.WParam), False)\r\n else\r\n ControlsListChanged(TControl(Msg.WParam), True);\r\n WM_SETFOCUS:\r\n FocusSet(THandle(Msg.WParam));\r\n WM_KILLFOCUS:\r\n FocusKilled(THandle(Msg.WParam));\r\n WM_SIZE, WM_MOVE:\r\n begin\r\n inherited WndProc(Msg);\r\n BoundsChanged;\r\n end;\r\n WM_ERASEBKGND:\r\n if (Msg.WParam <> 0) and not IsDefaultEraseBackground(DoEraseBackground, @TJvExProgressBar.DoEraseBackground) then\r\n begin\r\n IdSaveDC := SaveDC(HDC(Msg.WParam)); // protect DC against Stock-Objects from Canvas\r\n Canvas := TCanvas.Create;\r\n try\r\n Canvas.Handle := HDC(Msg.WParam);\r\n Msg.Result := Ord(DoEraseBackground(Canvas, Msg.LParam));\r\n finally\r\n Canvas.Handle := 0;\r\n Canvas.Free;\r\n RestoreDC(HDC(Msg.WParam), IdSaveDC);\r\n end;\r\n end\r\n else\r\n inherited WndProc(Msg);\r\n {$IFNDEF DELPHI2007_UP}\r\n WM_PRINTCLIENT, WM_PRINT: // VCL bug fix\r\n begin\r\n IdSaveDC := SaveDC(HDC(Msg.WParam)); // protect DC against changes\r\n try\r\n inherited WndProc(Msg);\r\n finally\r\n RestoreDC(HDC(Msg.WParam), IdSaveDC);\r\n end;\r\n end;\r\n {$ENDIF ~DELPHI2007_UP}\r\n WM_GETDLGCODE:\r\n begin\r\n inherited WndProc(Msg);\r\n DlgCodes := [dcNative] + DlgcToDlgCodes(Msg.Result);\r\n GetDlgCode(DlgCodes);\r\n if not (dcNative in DlgCodes) then\r\n Msg.Result := DlgCodesToDlgc(DlgCodes);\r\n end;\r\n else\r\n inherited WndProc(Msg);\r\n end;\r\n case Msg.Msg of // precheck message to prevent access violations on released controls\r\n CM_MOUSEENTER, CM_MOUSELEAVE, WM_KILLFOCUS, WM_SETFOCUS, WM_NCPAINT:\r\n if DotNetHighlighting then\r\n HandleDotNetHighlighting(Self, Msg, MouseOver, Color);\r\n end;\r\n end;\r\nend;\r\n\r\n//============================================================================\r\n\r\nconstructor TJvExPageControl.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FHintColor := clDefault;\r\nend;\r\n\r\nfunction TJvExPageControl.BaseWndProc(Msg: Cardinal; WParam: WPARAM = 0; LParam: LPARAM = 0): LRESULT;\r\nvar\r\n Mesg: TMessage;\r\nbegin\r\n CreateWMMessage(Mesg, Msg, WParam, LParam);\r\n inherited WndProc(Mesg);\r\n Result := Mesg.Result;\r\nend;\r\n\r\nfunction TJvExPageControl.BaseWndProc(Msg: Cardinal; WParam: WPARAM; LParam: TObject): LRESULT;\r\nbegin\r\n Result := BaseWndProc(Msg, WParam, Windows.LPARAM(LParam));\r\nend;\r\n\r\nfunction TJvExPageControl.BaseWndProcEx(Msg: Cardinal; WParam: WPARAM; var StructLParam): LRESULT;\r\nbegin\r\n Result := BaseWndProc(Msg, WParam, Windows.LPARAM(@StructLParam));\r\nend;\r\n\r\nprocedure TJvExPageControl.VisibleChanged;\r\nbegin\r\n BaseWndProc(CM_VISIBLECHANGED);\r\nend;\r\n\r\nprocedure TJvExPageControl.EnabledChanged;\r\nbegin\r\n BaseWndProc(CM_ENABLEDCHANGED);\r\nend;\r\n\r\nprocedure TJvExPageControl.TextChanged;\r\nbegin\r\n BaseWndProc(CM_TEXTCHANGED);\r\nend;\r\n\r\nprocedure TJvExPageControl.FontChanged;\r\nbegin\r\n BaseWndProc(CM_FONTCHANGED);\r\nend;\r\n\r\nprocedure TJvExPageControl.ColorChanged;\r\nbegin\r\n BaseWndProc(CM_COLORCHANGED);\r\nend;\r\n\r\nprocedure TJvExPageControl.ParentFontChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTFONTCHANGED);\r\nend;\r\n\r\nprocedure TJvExPageControl.ParentColorChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTCOLORCHANGED);\r\n if Assigned(OnParentColorChange) then\r\n OnParentColorChange(Self);\r\nend;\r\n\r\nprocedure TJvExPageControl.ParentShowHintChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTSHOWHINTCHANGED);\r\nend;\r\n\r\nfunction TJvExPageControl.WantKey(Key: Integer; Shift: TShiftState): Boolean;\r\nbegin\r\n Result := BaseWndProc(CM_DIALOGCHAR, Word(Key), ShiftStateToKeyData(Shift)) <> 0;\r\nend;\r\n\r\nfunction TJvExPageControl.HitTest(X, Y: Integer): Boolean;\r\nbegin\r\n Result := BaseWndProc(CM_HITTEST, 0, SmallPointToLong(PointToSmallPoint(Point(X, Y)))) <> 0;\r\nend;\r\n\r\nfunction TJvExPageControl.HintShow(var HintInfo: THintInfo): Boolean;\r\nbegin\r\n GetHintColor(HintInfo, Self, FHintColor);\r\n if FHintWindowClass <> nil then\r\n HintInfo.HintWindowClass := FHintWindowClass;\r\n Result := BaseWndProcEx(CM_HINTSHOW, 0, HintInfo) <> 0;\r\nend;\r\n\r\nprocedure TJvExPageControl.MouseEnter(AControl: TControl);\r\nbegin\r\n FMouseOver := True;\r\n if Assigned(FOnMouseEnter) then\r\n FOnMouseEnter(Self);\r\n BaseWndProc(CM_MOUSEENTER, 0, AControl);\r\nend;\r\n\r\nprocedure TJvExPageControl.MouseLeave(AControl: TControl);\r\nbegin\r\n FMouseOver := False;\r\n BaseWndProc(CM_MOUSELEAVE, 0, AControl);\r\n if Assigned(FOnMouseLeave) then\r\n FOnMouseLeave(Self);\r\nend;\r\n\r\nprocedure TJvExPageControl.FocusChanged(AControl: TWinControl);\r\nbegin\r\n BaseWndProc(CM_FOCUSCHANGED, 0, AControl);\r\nend;\r\n\r\nprocedure TJvExPageControl.BoundsChanged;\r\nbegin\r\nend;\r\n\r\nprocedure TJvExPageControl.CursorChanged;\r\nbegin\r\n BaseWndProc(CM_CURSORCHANGED);\r\nend;\r\n\r\nprocedure TJvExPageControl.ShowingChanged;\r\nbegin\r\n BaseWndProc(CM_SHOWINGCHANGED);\r\nend;\r\n\r\nprocedure TJvExPageControl.ShowHintChanged;\r\nbegin\r\n BaseWndProc(CM_SHOWHINTCHANGED);\r\nend;\r\n\r\n{ VCL sends CM_CONTROLLISTCHANGE and CM_CONTROLCHANGE in a different order than\r\n the CLX methods are used. So we must correct it by evaluating \"Inserting\". }\r\nprocedure TJvExPageControl.ControlsListChanging(Control: TControl; Inserting: Boolean);\r\nbegin\r\n if Inserting then\r\n BaseWndProc(CM_CONTROLLISTCHANGE, WPARAM(Control), LPARAM(Inserting))\r\n else\r\n BaseWndProc(CM_CONTROLCHANGE, WPARAM(Control), LPARAM(Inserting));\r\nend;\r\n\r\nprocedure TJvExPageControl.ControlsListChanged(Control: TControl; Inserting: Boolean);\r\nbegin\r\n if not Inserting then\r\n BaseWndProc(CM_CONTROLLISTCHANGE, WPARAM(Control), LPARAM(Inserting))\r\n else\r\n BaseWndProc(CM_CONTROLCHANGE, WPARAM(Control), LPARAM(Inserting));\r\nend;\r\n\r\nprocedure TJvExPageControl.GetDlgCode(var Code: TDlgCodes);\r\nbegin\r\nend;\r\n\r\nprocedure TJvExPageControl.FocusSet(PrevWnd: THandle);\r\nbegin\r\n BaseWndProc(WM_SETFOCUS, WPARAM(PrevWnd), 0);\r\nend;\r\n\r\nprocedure TJvExPageControl.FocusKilled(NextWnd: THandle);\r\nbegin\r\n BaseWndProc(WM_KILLFOCUS, WPARAM(NextWnd), 0);\r\nend;\r\n\r\nfunction TJvExPageControl.DoEraseBackground(Canvas: TCanvas; Param: LPARAM): Boolean;\r\nbegin\r\n Result := BaseWndProc(WM_ERASEBKGND, Canvas.Handle, Param) <> 0;\r\nend;\r\n\r\n{$IFDEF JVCLThemesEnabledD6}\r\nfunction TJvExPageControl.GetParentBackground: Boolean;\r\nbegin\r\n Result := JvThemes.GetParentBackground(Self);\r\nend;\r\n\r\nprocedure TJvExPageControl.SetParentBackground(Value: Boolean);\r\nbegin\r\n JvThemes.SetParentBackground(Self, Value);\r\nend;\r\n{$ENDIF JVCLThemesEnabledD6}\r\n\r\nprocedure TJvExPageControl.WndProc(var Msg: TMessage);\r\nvar\r\n IdSaveDC: Integer;\r\n DlgCodes: TDlgCodes;\r\n Canvas: TCanvas;\r\nbegin\r\n if not DispatchIsDesignMsg(Self, Msg) then\r\n begin\r\n case Msg.Msg of\r\n CM_DENYSUBCLASSING:\r\n Msg.Result := LRESULT(Ord(GetInterfaceEntry(IJvDenySubClassing) <> nil));\r\n CM_DIALOGCHAR:\r\n with TCMDialogChar{$IFDEF CLR}.Create{$ENDIF}(Msg) do\r\n Result := LRESULT(Ord(WantKey(CharCode, KeyDataToShiftState(KeyData))));\r\n CM_HINTSHOW:\r\n with TCMHintShow(Msg) do\r\n Result := LRESULT(HintShow(HintInfo^));\r\n CM_HITTEST:\r\n with TCMHitTest(Msg) do\r\n Result := LRESULT(HitTest(XPos, YPos));\r\n CM_MOUSEENTER:\r\n MouseEnter(TControl(Msg.LParam));\r\n CM_MOUSELEAVE:\r\n MouseLeave(TControl(Msg.LParam));\r\n CM_VISIBLECHANGED:\r\n VisibleChanged;\r\n CM_ENABLEDCHANGED:\r\n EnabledChanged;\r\n CM_TEXTCHANGED:\r\n TextChanged;\r\n CM_FONTCHANGED:\r\n FontChanged;\r\n CM_COLORCHANGED:\r\n ColorChanged;\r\n CM_FOCUSCHANGED:\r\n FocusChanged(TWinControl(Msg.LParam));\r\n CM_PARENTFONTCHANGED:\r\n ParentFontChanged;\r\n CM_PARENTCOLORCHANGED:\r\n ParentColorChanged;\r\n CM_PARENTSHOWHINTCHANGED:\r\n ParentShowHintChanged;\r\n CM_CURSORCHANGED:\r\n CursorChanged;\r\n CM_SHOWINGCHANGED:\r\n ShowingChanged;\r\n CM_SHOWHINTCHANGED:\r\n ShowHintChanged;\r\n CM_CONTROLLISTCHANGE:\r\n if Msg.LParam <> 0 then\r\n ControlsListChanging(TControl(Msg.WParam), True)\r\n else\r\n ControlsListChanged(TControl(Msg.WParam), False);\r\n CM_CONTROLCHANGE:\r\n if Msg.LParam = 0 then\r\n ControlsListChanging(TControl(Msg.WParam), False)\r\n else\r\n ControlsListChanged(TControl(Msg.WParam), True);\r\n WM_SETFOCUS:\r\n FocusSet(THandle(Msg.WParam));\r\n WM_KILLFOCUS:\r\n FocusKilled(THandle(Msg.WParam));\r\n WM_SIZE, WM_MOVE:\r\n begin\r\n inherited WndProc(Msg);\r\n BoundsChanged;\r\n end;\r\n WM_ERASEBKGND:\r\n if (Msg.WParam <> 0) and not IsDefaultEraseBackground(DoEraseBackground, @TJvExPageControl.DoEraseBackground) then\r\n begin\r\n IdSaveDC := SaveDC(HDC(Msg.WParam)); // protect DC against Stock-Objects from Canvas\r\n Canvas := TCanvas.Create;\r\n try\r\n Canvas.Handle := HDC(Msg.WParam);\r\n Msg.Result := Ord(DoEraseBackground(Canvas, Msg.LParam));\r\n finally\r\n Canvas.Handle := 0;\r\n Canvas.Free;\r\n RestoreDC(HDC(Msg.WParam), IdSaveDC);\r\n end;\r\n end\r\n else\r\n inherited WndProc(Msg);\r\n {$IFNDEF DELPHI2007_UP}\r\n WM_PRINTCLIENT, WM_PRINT: // VCL bug fix\r\n begin\r\n IdSaveDC := SaveDC(HDC(Msg.WParam)); // protect DC against changes\r\n try\r\n inherited WndProc(Msg);\r\n finally\r\n RestoreDC(HDC(Msg.WParam), IdSaveDC);\r\n end;\r\n end;\r\n {$ENDIF ~DELPHI2007_UP}\r\n WM_GETDLGCODE:\r\n begin\r\n inherited WndProc(Msg);\r\n DlgCodes := [dcNative] + DlgcToDlgCodes(Msg.Result);\r\n GetDlgCode(DlgCodes);\r\n if not (dcNative in DlgCodes) then\r\n Msg.Result := DlgCodesToDlgc(DlgCodes);\r\n end;\r\n else\r\n inherited WndProc(Msg);\r\n end;\r\n case Msg.Msg of // precheck message to prevent access violations on released controls\r\n CM_MOUSEENTER, CM_MOUSELEAVE, WM_KILLFOCUS, WM_SETFOCUS, WM_NCPAINT:\r\n if DotNetHighlighting then\r\n HandleDotNetHighlighting(Self, Msg, MouseOver, Color);\r\n end;\r\n end;\r\nend;\r\n\r\n//============================================================================\r\n\r\nconstructor TJvExPageScroller.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FHintColor := clDefault;\r\nend;\r\n\r\nfunction TJvExPageScroller.BaseWndProc(Msg: Cardinal; WParam: WPARAM = 0; LParam: LPARAM = 0): LRESULT;\r\nvar\r\n Mesg: TMessage;\r\nbegin\r\n CreateWMMessage(Mesg, Msg, WParam, LParam);\r\n inherited WndProc(Mesg);\r\n Result := Mesg.Result;\r\nend;\r\n\r\nfunction TJvExPageScroller.BaseWndProc(Msg: Cardinal; WParam: WPARAM; LParam: TObject): LRESULT;\r\nbegin\r\n Result := BaseWndProc(Msg, WParam, Windows.LPARAM(LParam));\r\nend;\r\n\r\nfunction TJvExPageScroller.BaseWndProcEx(Msg: Cardinal; WParam: WPARAM; var StructLParam): LRESULT;\r\nbegin\r\n Result := BaseWndProc(Msg, WParam, Windows.LPARAM(@StructLParam));\r\nend;\r\n\r\nprocedure TJvExPageScroller.VisibleChanged;\r\nbegin\r\n BaseWndProc(CM_VISIBLECHANGED);\r\nend;\r\n\r\nprocedure TJvExPageScroller.EnabledChanged;\r\nbegin\r\n BaseWndProc(CM_ENABLEDCHANGED);\r\nend;\r\n\r\nprocedure TJvExPageScroller.TextChanged;\r\nbegin\r\n BaseWndProc(CM_TEXTCHANGED);\r\nend;\r\n\r\nprocedure TJvExPageScroller.FontChanged;\r\nbegin\r\n BaseWndProc(CM_FONTCHANGED);\r\nend;\r\n\r\nprocedure TJvExPageScroller.ColorChanged;\r\nbegin\r\n BaseWndProc(CM_COLORCHANGED);\r\nend;\r\n\r\nprocedure TJvExPageScroller.ParentFontChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTFONTCHANGED);\r\nend;\r\n\r\nprocedure TJvExPageScroller.ParentColorChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTCOLORCHANGED);\r\n if Assigned(OnParentColorChange) then\r\n OnParentColorChange(Self);\r\nend;\r\n\r\nprocedure TJvExPageScroller.ParentShowHintChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTSHOWHINTCHANGED);\r\nend;\r\n\r\nfunction TJvExPageScroller.WantKey(Key: Integer; Shift: TShiftState): Boolean;\r\nbegin\r\n Result := BaseWndProc(CM_DIALOGCHAR, Word(Key), ShiftStateToKeyData(Shift)) <> 0;\r\nend;\r\n\r\nfunction TJvExPageScroller.HitTest(X, Y: Integer): Boolean;\r\nbegin\r\n Result := BaseWndProc(CM_HITTEST, 0, SmallPointToLong(PointToSmallPoint(Point(X, Y)))) <> 0;\r\nend;\r\n\r\nfunction TJvExPageScroller.HintShow(var HintInfo: THintInfo): Boolean;\r\nbegin\r\n GetHintColor(HintInfo, Self, FHintColor);\r\n if FHintWindowClass <> nil then\r\n HintInfo.HintWindowClass := FHintWindowClass;\r\n Result := BaseWndProcEx(CM_HINTSHOW, 0, HintInfo) <> 0;\r\nend;\r\n\r\nprocedure TJvExPageScroller.MouseEnter(AControl: TControl);\r\nbegin\r\n FMouseOver := True;\r\n if Assigned(FOnMouseEnter) then\r\n FOnMouseEnter(Self);\r\n BaseWndProc(CM_MOUSEENTER, 0, AControl);\r\nend;\r\n\r\nprocedure TJvExPageScroller.MouseLeave(AControl: TControl);\r\nbegin\r\n FMouseOver := False;\r\n BaseWndProc(CM_MOUSELEAVE, 0, AControl);\r\n if Assigned(FOnMouseLeave) then\r\n FOnMouseLeave(Self);\r\nend;\r\n\r\nprocedure TJvExPageScroller.FocusChanged(AControl: TWinControl);\r\nbegin\r\n BaseWndProc(CM_FOCUSCHANGED, 0, AControl);\r\nend;\r\n\r\nprocedure TJvExPageScroller.BoundsChanged;\r\nbegin\r\nend;\r\n\r\nprocedure TJvExPageScroller.CursorChanged;\r\nbegin\r\n BaseWndProc(CM_CURSORCHANGED);\r\nend;\r\n\r\nprocedure TJvExPageScroller.ShowingChanged;\r\nbegin\r\n BaseWndProc(CM_SHOWINGCHANGED);\r\nend;\r\n\r\nprocedure TJvExPageScroller.ShowHintChanged;\r\nbegin\r\n BaseWndProc(CM_SHOWHINTCHANGED);\r\nend;\r\n\r\n{ VCL sends CM_CONTROLLISTCHANGE and CM_CONTROLCHANGE in a different order than\r\n the CLX methods are used. So we must correct it by evaluating \"Inserting\". }\r\nprocedure TJvExPageScroller.ControlsListChanging(Control: TControl; Inserting: Boolean);\r\nbegin\r\n if Inserting then\r\n BaseWndProc(CM_CONTROLLISTCHANGE, WPARAM(Control), LPARAM(Inserting))\r\n else\r\n BaseWndProc(CM_CONTROLCHANGE, WPARAM(Control), LPARAM(Inserting));\r\nend;\r\n\r\nprocedure TJvExPageScroller.ControlsListChanged(Control: TControl; Inserting: Boolean);\r\nbegin\r\n if not Inserting then\r\n BaseWndProc(CM_CONTROLLISTCHANGE, WPARAM(Control), LPARAM(Inserting))\r\n else\r\n BaseWndProc(CM_CONTROLCHANGE, WPARAM(Control), LPARAM(Inserting));\r\nend;\r\n\r\nprocedure TJvExPageScroller.GetDlgCode(var Code: TDlgCodes);\r\nbegin\r\nend;\r\n\r\nprocedure TJvExPageScroller.FocusSet(PrevWnd: THandle);\r\nbegin\r\n BaseWndProc(WM_SETFOCUS, WPARAM(PrevWnd), 0);\r\nend;\r\n\r\nprocedure TJvExPageScroller.FocusKilled(NextWnd: THandle);\r\nbegin\r\n BaseWndProc(WM_KILLFOCUS, WPARAM(NextWnd), 0);\r\nend;\r\n\r\nfunction TJvExPageScroller.DoEraseBackground(Canvas: TCanvas; Param: LPARAM): Boolean;\r\nbegin\r\n Result := BaseWndProc(WM_ERASEBKGND, Canvas.Handle, Param) <> 0;\r\nend;\r\n\r\n{$IFDEF JVCLThemesEnabledD6}\r\nfunction TJvExPageScroller.GetParentBackground: Boolean;\r\nbegin\r\n Result := JvThemes.GetParentBackground(Self);\r\nend;\r\n\r\nprocedure TJvExPageScroller.SetParentBackground(Value: Boolean);\r\nbegin\r\n JvThemes.SetParentBackground(Self, Value);\r\nend;\r\n{$ENDIF JVCLThemesEnabledD6}\r\n\r\nprocedure TJvExPageScroller.WndProc(var Msg: TMessage);\r\nvar\r\n IdSaveDC: Integer;\r\n DlgCodes: TDlgCodes;\r\n Canvas: TCanvas;\r\nbegin\r\n if not DispatchIsDesignMsg(Self, Msg) then\r\n begin\r\n case Msg.Msg of\r\n CM_DENYSUBCLASSING:\r\n Msg.Result := LRESULT(Ord(GetInterfaceEntry(IJvDenySubClassing) <> nil));\r\n CM_DIALOGCHAR:\r\n with TCMDialogChar{$IFDEF CLR}.Create{$ENDIF}(Msg) do\r\n Result := LRESULT(Ord(WantKey(CharCode, KeyDataToShiftState(KeyData))));\r\n CM_HINTSHOW:\r\n with TCMHintShow(Msg) do\r\n Result := LRESULT(HintShow(HintInfo^));\r\n CM_HITTEST:\r\n with TCMHitTest(Msg) do\r\n Result := LRESULT(HitTest(XPos, YPos));\r\n CM_MOUSEENTER:\r\n MouseEnter(TControl(Msg.LParam));\r\n CM_MOUSELEAVE:\r\n MouseLeave(TControl(Msg.LParam));\r\n CM_VISIBLECHANGED:\r\n VisibleChanged;\r\n CM_ENABLEDCHANGED:\r\n EnabledChanged;\r\n CM_TEXTCHANGED:\r\n TextChanged;\r\n CM_FONTCHANGED:\r\n FontChanged;\r\n CM_COLORCHANGED:\r\n ColorChanged;\r\n CM_FOCUSCHANGED:\r\n FocusChanged(TWinControl(Msg.LParam));\r\n CM_PARENTFONTCHANGED:\r\n ParentFontChanged;\r\n CM_PARENTCOLORCHANGED:\r\n ParentColorChanged;\r\n CM_PARENTSHOWHINTCHANGED:\r\n ParentShowHintChanged;\r\n CM_CURSORCHANGED:\r\n CursorChanged;\r\n CM_SHOWINGCHANGED:\r\n ShowingChanged;\r\n CM_SHOWHINTCHANGED:\r\n ShowHintChanged;\r\n CM_CONTROLLISTCHANGE:\r\n if Msg.LParam <> 0 then\r\n ControlsListChanging(TControl(Msg.WParam), True)\r\n else\r\n ControlsListChanged(TControl(Msg.WParam), False);\r\n CM_CONTROLCHANGE:\r\n if Msg.LParam = 0 then\r\n ControlsListChanging(TControl(Msg.WParam), False)\r\n else\r\n ControlsListChanged(TControl(Msg.WParam), True);\r\n WM_SETFOCUS:\r\n FocusSet(THandle(Msg.WParam));\r\n WM_KILLFOCUS:\r\n FocusKilled(THandle(Msg.WParam));\r\n WM_SIZE, WM_MOVE:\r\n begin\r\n inherited WndProc(Msg);\r\n BoundsChanged;\r\n end;\r\n WM_ERASEBKGND:\r\n if (Msg.WParam <> 0) and not IsDefaultEraseBackground(DoEraseBackground, @TJvExPageScroller.DoEraseBackground) then\r\n begin\r\n IdSaveDC := SaveDC(HDC(Msg.WParam)); // protect DC against Stock-Objects from Canvas\r\n Canvas := TCanvas.Create;\r\n try\r\n Canvas.Handle := HDC(Msg.WParam);\r\n Msg.Result := Ord(DoEraseBackground(Canvas, Msg.LParam));\r\n finally\r\n Canvas.Handle := 0;\r\n Canvas.Free;\r\n RestoreDC(HDC(Msg.WParam), IdSaveDC);\r\n end;\r\n end\r\n else\r\n inherited WndProc(Msg);\r\n {$IFNDEF DELPHI2007_UP}\r\n WM_PRINTCLIENT, WM_PRINT: // VCL bug fix\r\n begin\r\n IdSaveDC := SaveDC(HDC(Msg.WParam)); // protect DC against changes\r\n try\r\n inherited WndProc(Msg);\r\n finally\r\n RestoreDC(HDC(Msg.WParam), IdSaveDC);\r\n end;\r\n end;\r\n {$ENDIF ~DELPHI2007_UP}\r\n WM_GETDLGCODE:\r\n begin\r\n inherited WndProc(Msg);\r\n DlgCodes := [dcNative] + DlgcToDlgCodes(Msg.Result);\r\n GetDlgCode(DlgCodes);\r\n if not (dcNative in DlgCodes) then\r\n Msg.Result := DlgCodesToDlgc(DlgCodes);\r\n end;\r\n else\r\n inherited WndProc(Msg);\r\n end;\r\n case Msg.Msg of // precheck message to prevent access violations on released controls\r\n CM_MOUSEENTER, CM_MOUSELEAVE, WM_KILLFOCUS, WM_SETFOCUS, WM_NCPAINT:\r\n if DotNetHighlighting then\r\n HandleDotNetHighlighting(Self, Msg, MouseOver, Color);\r\n end;\r\n end;\r\nend;\r\n\r\n//============================================================================\r\n\r\nconstructor TJvExCustomTabControl.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FHintColor := clDefault;\r\nend;\r\n\r\nfunction TJvExCustomTabControl.BaseWndProc(Msg: Cardinal; WParam: WPARAM = 0; LParam: LPARAM = 0): LRESULT;\r\nvar\r\n Mesg: TMessage;\r\nbegin\r\n CreateWMMessage(Mesg, Msg, WParam, LParam);\r\n inherited WndProc(Mesg);\r\n Result := Mesg.Result;\r\nend;\r\n\r\nfunction TJvExCustomTabControl.BaseWndProc(Msg: Cardinal; WParam: WPARAM; LParam: TObject): LRESULT;\r\nbegin\r\n Result := BaseWndProc(Msg, WParam, Windows.LPARAM(LParam));\r\nend;\r\n\r\nfunction TJvExCustomTabControl.BaseWndProcEx(Msg: Cardinal; WParam: WPARAM; var StructLParam): LRESULT;\r\nbegin\r\n Result := BaseWndProc(Msg, WParam, Windows.LPARAM(@StructLParam));\r\nend;\r\n\r\nprocedure TJvExCustomTabControl.VisibleChanged;\r\nbegin\r\n BaseWndProc(CM_VISIBLECHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomTabControl.EnabledChanged;\r\nbegin\r\n BaseWndProc(CM_ENABLEDCHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomTabControl.TextChanged;\r\nbegin\r\n BaseWndProc(CM_TEXTCHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomTabControl.FontChanged;\r\nbegin\r\n BaseWndProc(CM_FONTCHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomTabControl.ColorChanged;\r\nbegin\r\n BaseWndProc(CM_COLORCHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomTabControl.ParentFontChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTFONTCHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomTabControl.ParentColorChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTCOLORCHANGED);\r\n if Assigned(OnParentColorChange) then\r\n OnParentColorChange(Self);\r\nend;\r\n\r\nprocedure TJvExCustomTabControl.ParentShowHintChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTSHOWHINTCHANGED);\r\nend;\r\n\r\nfunction TJvExCustomTabControl.WantKey(Key: Integer; Shift: TShiftState): Boolean;\r\nbegin\r\n Result := BaseWndProc(CM_DIALOGCHAR, Word(Key), ShiftStateToKeyData(Shift)) <> 0;\r\nend;\r\n\r\nfunction TJvExCustomTabControl.HitTest(X, Y: Integer): Boolean;\r\nbegin\r\n Result := BaseWndProc(CM_HITTEST, 0, SmallPointToLong(PointToSmallPoint(Point(X, Y)))) <> 0;\r\nend;\r\n\r\nfunction TJvExCustomTabControl.HintShow(var HintInfo: THintInfo): Boolean;\r\nbegin\r\n GetHintColor(HintInfo, Self, FHintColor);\r\n if FHintWindowClass <> nil then\r\n HintInfo.HintWindowClass := FHintWindowClass;\r\n Result := BaseWndProcEx(CM_HINTSHOW, 0, HintInfo) <> 0;\r\nend;\r\n\r\nprocedure TJvExCustomTabControl.MouseEnter(AControl: TControl);\r\nbegin\r\n FMouseOver := True;\r\n if Assigned(FOnMouseEnter) then\r\n FOnMouseEnter(Self);\r\n BaseWndProc(CM_MOUSEENTER, 0, AControl);\r\nend;\r\n\r\nprocedure TJvExCustomTabControl.MouseLeave(AControl: TControl);\r\nbegin\r\n FMouseOver := False;\r\n BaseWndProc(CM_MOUSELEAVE, 0, AControl);\r\n if Assigned(FOnMouseLeave) then\r\n FOnMouseLeave(Self);\r\nend;\r\n\r\nprocedure TJvExCustomTabControl.FocusChanged(AControl: TWinControl);\r\nbegin\r\n BaseWndProc(CM_FOCUSCHANGED, 0, AControl);\r\nend;\r\n\r\nprocedure TJvExCustomTabControl.BoundsChanged;\r\nbegin\r\nend;\r\n\r\nprocedure TJvExCustomTabControl.CursorChanged;\r\nbegin\r\n BaseWndProc(CM_CURSORCHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomTabControl.ShowingChanged;\r\nbegin\r\n BaseWndProc(CM_SHOWINGCHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomTabControl.ShowHintChanged;\r\nbegin\r\n BaseWndProc(CM_SHOWHINTCHANGED);\r\nend;\r\n\r\n{ VCL sends CM_CONTROLLISTCHANGE and CM_CONTROLCHANGE in a different order than\r\n the CLX methods are used. So we must correct it by evaluating \"Inserting\". }\r\nprocedure TJvExCustomTabControl.ControlsListChanging(Control: TControl; Inserting: Boolean);\r\nbegin\r\n if Inserting then\r\n BaseWndProc(CM_CONTROLLISTCHANGE, WPARAM(Control), LPARAM(Inserting))\r\n else\r\n BaseWndProc(CM_CONTROLCHANGE, WPARAM(Control), LPARAM(Inserting));\r\nend;\r\n\r\nprocedure TJvExCustomTabControl.ControlsListChanged(Control: TControl; Inserting: Boolean);\r\nbegin\r\n if not Inserting then\r\n BaseWndProc(CM_CONTROLLISTCHANGE, WPARAM(Control), LPARAM(Inserting))\r\n else\r\n BaseWndProc(CM_CONTROLCHANGE, WPARAM(Control), LPARAM(Inserting));\r\nend;\r\n\r\nprocedure TJvExCustomTabControl.GetDlgCode(var Code: TDlgCodes);\r\nbegin\r\nend;\r\n\r\nprocedure TJvExCustomTabControl.FocusSet(PrevWnd: THandle);\r\nbegin\r\n BaseWndProc(WM_SETFOCUS, WPARAM(PrevWnd), 0);\r\nend;\r\n\r\nprocedure TJvExCustomTabControl.FocusKilled(NextWnd: THandle);\r\nbegin\r\n BaseWndProc(WM_KILLFOCUS, WPARAM(NextWnd), 0);\r\nend;\r\n\r\nfunction TJvExCustomTabControl.DoEraseBackground(Canvas: TCanvas; Param: LPARAM): Boolean;\r\nbegin\r\n Result := BaseWndProc(WM_ERASEBKGND, Canvas.Handle, Param) <> 0;\r\nend;\r\n\r\n{$IFDEF JVCLThemesEnabledD6}\r\nfunction TJvExCustomTabControl.GetParentBackground: Boolean;\r\nbegin\r\n Result := JvThemes.GetParentBackground(Self);\r\nend;\r\n\r\nprocedure TJvExCustomTabControl.SetParentBackground(Value: Boolean);\r\nbegin\r\n JvThemes.SetParentBackground(Self, Value);\r\nend;\r\n{$ENDIF JVCLThemesEnabledD6}\r\n\r\nprocedure TJvExCustomTabControl.WndProc(var Msg: TMessage);\r\nvar\r\n IdSaveDC: Integer;\r\n DlgCodes: TDlgCodes;\r\n Canvas: TCanvas;\r\nbegin\r\n if not DispatchIsDesignMsg(Self, Msg) then\r\n begin\r\n case Msg.Msg of\r\n CM_DENYSUBCLASSING:\r\n Msg.Result := LRESULT(Ord(GetInterfaceEntry(IJvDenySubClassing) <> nil));\r\n CM_DIALOGCHAR:\r\n with TCMDialogChar{$IFDEF CLR}.Create{$ENDIF}(Msg) do\r\n Result := LRESULT(Ord(WantKey(CharCode, KeyDataToShiftState(KeyData))));\r\n CM_HINTSHOW:\r\n with TCMHintShow(Msg) do\r\n Result := LRESULT(HintShow(HintInfo^));\r\n CM_HITTEST:\r\n with TCMHitTest(Msg) do\r\n Result := LRESULT(HitTest(XPos, YPos));\r\n CM_MOUSEENTER:\r\n MouseEnter(TControl(Msg.LParam));\r\n CM_MOUSELEAVE:\r\n MouseLeave(TControl(Msg.LParam));\r\n CM_VISIBLECHANGED:\r\n VisibleChanged;\r\n CM_ENABLEDCHANGED:\r\n EnabledChanged;\r\n CM_TEXTCHANGED:\r\n TextChanged;\r\n CM_FONTCHANGED:\r\n FontChanged;\r\n CM_COLORCHANGED:\r\n ColorChanged;\r\n CM_FOCUSCHANGED:\r\n FocusChanged(TWinControl(Msg.LParam));\r\n CM_PARENTFONTCHANGED:\r\n ParentFontChanged;\r\n CM_PARENTCOLORCHANGED:\r\n ParentColorChanged;\r\n CM_PARENTSHOWHINTCHANGED:\r\n ParentShowHintChanged;\r\n CM_CURSORCHANGED:\r\n CursorChanged;\r\n CM_SHOWINGCHANGED:\r\n ShowingChanged;\r\n CM_SHOWHINTCHANGED:\r\n ShowHintChanged;\r\n CM_CONTROLLISTCHANGE:\r\n if Msg.LParam <> 0 then\r\n ControlsListChanging(TControl(Msg.WParam), True)\r\n else\r\n ControlsListChanged(TControl(Msg.WParam), False);\r\n CM_CONTROLCHANGE:\r\n if Msg.LParam = 0 then\r\n ControlsListChanging(TControl(Msg.WParam), False)\r\n else\r\n ControlsListChanged(TControl(Msg.WParam), True);\r\n WM_SETFOCUS:\r\n FocusSet(THandle(Msg.WParam));\r\n WM_KILLFOCUS:\r\n FocusKilled(THandle(Msg.WParam));\r\n WM_SIZE, WM_MOVE:\r\n begin\r\n inherited WndProc(Msg);\r\n BoundsChanged;\r\n end;\r\n WM_ERASEBKGND:\r\n if (Msg.WParam <> 0) and not IsDefaultEraseBackground(DoEraseBackground, @TJvExCustomTabControl.DoEraseBackground) then\r\n begin\r\n IdSaveDC := SaveDC(HDC(Msg.WParam)); // protect DC against Stock-Objects from Canvas\r\n Canvas := TCanvas.Create;\r\n try\r\n Canvas.Handle := HDC(Msg.WParam);\r\n Msg.Result := Ord(DoEraseBackground(Canvas, Msg.LParam));\r\n finally\r\n Canvas.Handle := 0;\r\n Canvas.Free;\r\n RestoreDC(HDC(Msg.WParam), IdSaveDC);\r\n end;\r\n end\r\n else\r\n inherited WndProc(Msg);\r\n {$IFNDEF DELPHI2007_UP}\r\n WM_PRINTCLIENT, WM_PRINT: // VCL bug fix\r\n begin\r\n IdSaveDC := SaveDC(HDC(Msg.WParam)); // protect DC against changes\r\n try\r\n inherited WndProc(Msg);\r\n finally\r\n RestoreDC(HDC(Msg.WParam), IdSaveDC);\r\n end;\r\n end;\r\n {$ENDIF ~DELPHI2007_UP}\r\n WM_GETDLGCODE:\r\n begin\r\n inherited WndProc(Msg);\r\n DlgCodes := [dcNative] + DlgcToDlgCodes(Msg.Result);\r\n GetDlgCode(DlgCodes);\r\n if not (dcNative in DlgCodes) then\r\n Msg.Result := DlgCodesToDlgc(DlgCodes);\r\n end;\r\n else\r\n inherited WndProc(Msg);\r\n end;\r\n case Msg.Msg of // precheck message to prevent access violations on released controls\r\n CM_MOUSEENTER, CM_MOUSELEAVE, WM_KILLFOCUS, WM_SETFOCUS, WM_NCPAINT:\r\n if DotNetHighlighting then\r\n HandleDotNetHighlighting(Self, Msg, MouseOver, Color);\r\n end;\r\n end;\r\nend;\r\n\r\n//============================================================================\r\n\r\nconstructor TJvExTabControl.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FHintColor := clDefault;\r\nend;\r\n\r\nfunction TJvExTabControl.BaseWndProc(Msg: Cardinal; WParam: WPARAM = 0; LParam: LPARAM = 0): LRESULT;\r\nvar\r\n Mesg: TMessage;\r\nbegin\r\n CreateWMMessage(Mesg, Msg, WParam, LParam);\r\n inherited WndProc(Mesg);\r\n Result := Mesg.Result;\r\nend;\r\n\r\nfunction TJvExTabControl.BaseWndProc(Msg: Cardinal; WParam: WPARAM; LParam: TObject): LRESULT;\r\nbegin\r\n Result := BaseWndProc(Msg, WParam, Windows.LPARAM(LParam));\r\nend;\r\n\r\nfunction TJvExTabControl.BaseWndProcEx(Msg: Cardinal; WParam: WPARAM; var StructLParam): LRESULT;\r\nbegin\r\n Result := BaseWndProc(Msg, WParam, Windows.LPARAM(@StructLParam));\r\nend;\r\n\r\nprocedure TJvExTabControl.VisibleChanged;\r\nbegin\r\n BaseWndProc(CM_VISIBLECHANGED);\r\nend;\r\n\r\nprocedure TJvExTabControl.EnabledChanged;\r\nbegin\r\n BaseWndProc(CM_ENABLEDCHANGED);\r\nend;\r\n\r\nprocedure TJvExTabControl.TextChanged;\r\nbegin\r\n BaseWndProc(CM_TEXTCHANGED);\r\nend;\r\n\r\nprocedure TJvExTabControl.FontChanged;\r\nbegin\r\n BaseWndProc(CM_FONTCHANGED);\r\nend;\r\n\r\nprocedure TJvExTabControl.ColorChanged;\r\nbegin\r\n BaseWndProc(CM_COLORCHANGED);\r\nend;\r\n\r\nprocedure TJvExTabControl.ParentFontChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTFONTCHANGED);\r\nend;\r\n\r\nprocedure TJvExTabControl.ParentColorChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTCOLORCHANGED);\r\n if Assigned(OnParentColorChange) then\r\n OnParentColorChange(Self);\r\nend;\r\n\r\nprocedure TJvExTabControl.ParentShowHintChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTSHOWHINTCHANGED);\r\nend;\r\n\r\nfunction TJvExTabControl.WantKey(Key: Integer; Shift: TShiftState): Boolean;\r\nbegin\r\n Result := BaseWndProc(CM_DIALOGCHAR, Word(Key), ShiftStateToKeyData(Shift)) <> 0;\r\nend;\r\n\r\nfunction TJvExTabControl.HitTest(X, Y: Integer): Boolean;\r\nbegin\r\n Result := BaseWndProc(CM_HITTEST, 0, SmallPointToLong(PointToSmallPoint(Point(X, Y)))) <> 0;\r\nend;\r\n\r\nfunction TJvExTabControl.HintShow(var HintInfo: THintInfo): Boolean;\r\nbegin\r\n GetHintColor(HintInfo, Self, FHintColor);\r\n if FHintWindowClass <> nil then\r\n HintInfo.HintWindowClass := FHintWindowClass;\r\n Result := BaseWndProcEx(CM_HINTSHOW, 0, HintInfo) <> 0;\r\nend;\r\n\r\nprocedure TJvExTabControl.MouseEnter(AControl: TControl);\r\nbegin\r\n FMouseOver := True;\r\n if Assigned(FOnMouseEnter) then\r\n FOnMouseEnter(Self);\r\n BaseWndProc(CM_MOUSEENTER, 0, AControl);\r\nend;\r\n\r\nprocedure TJvExTabControl.MouseLeave(AControl: TControl);\r\nbegin\r\n FMouseOver := False;\r\n BaseWndProc(CM_MOUSELEAVE, 0, AControl);\r\n if Assigned(FOnMouseLeave) then\r\n FOnMouseLeave(Self);\r\nend;\r\n\r\nprocedure TJvExTabControl.FocusChanged(AControl: TWinControl);\r\nbegin\r\n BaseWndProc(CM_FOCUSCHANGED, 0, AControl);\r\nend;\r\n\r\nprocedure TJvExTabControl.BoundsChanged;\r\nbegin\r\nend;\r\n\r\nprocedure TJvExTabControl.CursorChanged;\r\nbegin\r\n BaseWndProc(CM_CURSORCHANGED);\r\nend;\r\n\r\nprocedure TJvExTabControl.ShowingChanged;\r\nbegin\r\n BaseWndProc(CM_SHOWINGCHANGED);\r\nend;\r\n\r\nprocedure TJvExTabControl.ShowHintChanged;\r\nbegin\r\n BaseWndProc(CM_SHOWHINTCHANGED);\r\nend;\r\n\r\n{ VCL sends CM_CONTROLLISTCHANGE and CM_CONTROLCHANGE in a different order than\r\n the CLX methods are used. So we must correct it by evaluating \"Inserting\". }\r\nprocedure TJvExTabControl.ControlsListChanging(Control: TControl; Inserting: Boolean);\r\nbegin\r\n if Inserting then\r\n BaseWndProc(CM_CONTROLLISTCHANGE, WPARAM(Control), LPARAM(Inserting))\r\n else\r\n BaseWndProc(CM_CONTROLCHANGE, WPARAM(Control), LPARAM(Inserting));\r\nend;\r\n\r\nprocedure TJvExTabControl.ControlsListChanged(Control: TControl; Inserting: Boolean);\r\nbegin\r\n if not Inserting then\r\n BaseWndProc(CM_CONTROLLISTCHANGE, WPARAM(Control), LPARAM(Inserting))\r\n else\r\n BaseWndProc(CM_CONTROLCHANGE, WPARAM(Control), LPARAM(Inserting));\r\nend;\r\n\r\nprocedure TJvExTabControl.GetDlgCode(var Code: TDlgCodes);\r\nbegin\r\nend;\r\n\r\nprocedure TJvExTabControl.FocusSet(PrevWnd: THandle);\r\nbegin\r\n BaseWndProc(WM_SETFOCUS, WPARAM(PrevWnd), 0);\r\nend;\r\n\r\nprocedure TJvExTabControl.FocusKilled(NextWnd: THandle);\r\nbegin\r\n BaseWndProc(WM_KILLFOCUS, WPARAM(NextWnd), 0);\r\nend;\r\n\r\nfunction TJvExTabControl.DoEraseBackground(Canvas: TCanvas; Param: LPARAM): Boolean;\r\nbegin\r\n Result := BaseWndProc(WM_ERASEBKGND, Canvas.Handle, Param) <> 0;\r\nend;\r\n\r\n{$IFDEF JVCLThemesEnabledD6}\r\nfunction TJvExTabControl.GetParentBackground: Boolean;\r\nbegin\r\n Result := JvThemes.GetParentBackground(Self);\r\nend;\r\n\r\nprocedure TJvExTabControl.SetParentBackground(Value: Boolean);\r\nbegin\r\n JvThemes.SetParentBackground(Self, Value);\r\nend;\r\n{$ENDIF JVCLThemesEnabledD6}\r\n\r\nprocedure TJvExTabControl.WndProc(var Msg: TMessage);\r\nvar\r\n IdSaveDC: Integer;\r\n DlgCodes: TDlgCodes;\r\n Canvas: TCanvas;\r\nbegin\r\n if not DispatchIsDesignMsg(Self, Msg) then\r\n begin\r\n case Msg.Msg of\r\n CM_DENYSUBCLASSING:\r\n Msg.Result := LRESULT(Ord(GetInterfaceEntry(IJvDenySubClassing) <> nil));\r\n CM_DIALOGCHAR:\r\n with TCMDialogChar{$IFDEF CLR}.Create{$ENDIF}(Msg) do\r\n Result := LRESULT(Ord(WantKey(CharCode, KeyDataToShiftState(KeyData))));\r\n CM_HINTSHOW:\r\n with TCMHintShow(Msg) do\r\n Result := LRESULT(HintShow(HintInfo^));\r\n CM_HITTEST:\r\n with TCMHitTest(Msg) do\r\n Result := LRESULT(HitTest(XPos, YPos));\r\n CM_MOUSEENTER:\r\n MouseEnter(TControl(Msg.LParam));\r\n CM_MOUSELEAVE:\r\n MouseLeave(TControl(Msg.LParam));\r\n CM_VISIBLECHANGED:\r\n VisibleChanged;\r\n CM_ENABLEDCHANGED:\r\n EnabledChanged;\r\n CM_TEXTCHANGED:\r\n TextChanged;\r\n CM_FONTCHANGED:\r\n FontChanged;\r\n CM_COLORCHANGED:\r\n ColorChanged;\r\n CM_FOCUSCHANGED:\r\n FocusChanged(TWinControl(Msg.LParam));\r\n CM_PARENTFONTCHANGED:\r\n ParentFontChanged;\r\n CM_PARENTCOLORCHANGED:\r\n ParentColorChanged;\r\n CM_PARENTSHOWHINTCHANGED:\r\n ParentShowHintChanged;\r\n CM_CURSORCHANGED:\r\n CursorChanged;\r\n CM_SHOWINGCHANGED:\r\n ShowingChanged;\r\n CM_SHOWHINTCHANGED:\r\n ShowHintChanged;\r\n CM_CONTROLLISTCHANGE:\r\n if Msg.LParam <> 0 then\r\n ControlsListChanging(TControl(Msg.WParam), True)\r\n else\r\n ControlsListChanged(TControl(Msg.WParam), False);\r\n CM_CONTROLCHANGE:\r\n if Msg.LParam = 0 then\r\n ControlsListChanging(TControl(Msg.WParam), False)\r\n else\r\n ControlsListChanged(TControl(Msg.WParam), True);\r\n WM_SETFOCUS:\r\n FocusSet(THandle(Msg.WParam));\r\n WM_KILLFOCUS:\r\n FocusKilled(THandle(Msg.WParam));\r\n WM_SIZE, WM_MOVE:\r\n begin\r\n inherited WndProc(Msg);\r\n BoundsChanged;\r\n end;\r\n WM_ERASEBKGND:\r\n if (Msg.WParam <> 0) and not IsDefaultEraseBackground(DoEraseBackground, @TJvExTabControl.DoEraseBackground) then\r\n begin\r\n IdSaveDC := SaveDC(HDC(Msg.WParam)); // protect DC against Stock-Objects from Canvas\r\n Canvas := TCanvas.Create;\r\n try\r\n Canvas.Handle := HDC(Msg.WParam);\r\n Msg.Result := Ord(DoEraseBackground(Canvas, Msg.LParam));\r\n finally\r\n Canvas.Handle := 0;\r\n Canvas.Free;\r\n RestoreDC(HDC(Msg.WParam), IdSaveDC);\r\n end;\r\n end\r\n else\r\n inherited WndProc(Msg);\r\n {$IFNDEF DELPHI2007_UP}\r\n WM_PRINTCLIENT, WM_PRINT: // VCL bug fix\r\n begin\r\n IdSaveDC := SaveDC(HDC(Msg.WParam)); // protect DC against changes\r\n try\r\n inherited WndProc(Msg);\r\n finally\r\n RestoreDC(HDC(Msg.WParam), IdSaveDC);\r\n end;\r\n end;\r\n {$ENDIF ~DELPHI2007_UP}\r\n WM_GETDLGCODE:\r\n begin\r\n inherited WndProc(Msg);\r\n DlgCodes := [dcNative] + DlgcToDlgCodes(Msg.Result);\r\n GetDlgCode(DlgCodes);\r\n if not (dcNative in DlgCodes) then\r\n Msg.Result := DlgCodesToDlgc(DlgCodes);\r\n end;\r\n else\r\n inherited WndProc(Msg);\r\n end;\r\n case Msg.Msg of // precheck message to prevent access violations on released controls\r\n CM_MOUSEENTER, CM_MOUSELEAVE, WM_KILLFOCUS, WM_SETFOCUS, WM_NCPAINT:\r\n if DotNetHighlighting then\r\n HandleDotNetHighlighting(Self, Msg, MouseOver, Color);\r\n end;\r\n end;\r\nend;\r\n\r\n//============================================================================\r\n\r\nconstructor TJvExTabSheet.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FHintColor := clDefault;\r\nend;\r\n\r\nfunction TJvExTabSheet.BaseWndProc(Msg: Cardinal; WParam: WPARAM = 0; LParam: LPARAM = 0): LRESULT;\r\nvar\r\n Mesg: TMessage;\r\nbegin\r\n CreateWMMessage(Mesg, Msg, WParam, LParam);\r\n inherited WndProc(Mesg);\r\n Result := Mesg.Result;\r\nend;\r\n\r\nfunction TJvExTabSheet.BaseWndProc(Msg: Cardinal; WParam: WPARAM; LParam: TObject): LRESULT;\r\nbegin\r\n Result := BaseWndProc(Msg, WParam, Windows.LPARAM(LParam));\r\nend;\r\n\r\nfunction TJvExTabSheet.BaseWndProcEx(Msg: Cardinal; WParam: WPARAM; var StructLParam): LRESULT;\r\nbegin\r\n Result := BaseWndProc(Msg, WParam, Windows.LPARAM(@StructLParam));\r\nend;\r\n\r\nprocedure TJvExTabSheet.VisibleChanged;\r\nbegin\r\n BaseWndProc(CM_VISIBLECHANGED);\r\nend;\r\n\r\nprocedure TJvExTabSheet.EnabledChanged;\r\nbegin\r\n BaseWndProc(CM_ENABLEDCHANGED);\r\nend;\r\n\r\nprocedure TJvExTabSheet.TextChanged;\r\nbegin\r\n BaseWndProc(CM_TEXTCHANGED);\r\nend;\r\n\r\nprocedure TJvExTabSheet.FontChanged;\r\nbegin\r\n BaseWndProc(CM_FONTCHANGED);\r\nend;\r\n\r\nprocedure TJvExTabSheet.ColorChanged;\r\nbegin\r\n BaseWndProc(CM_COLORCHANGED);\r\nend;\r\n\r\nprocedure TJvExTabSheet.ParentFontChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTFONTCHANGED);\r\nend;\r\n\r\nprocedure TJvExTabSheet.ParentColorChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTCOLORCHANGED);\r\n if Assigned(OnParentColorChange) then\r\n OnParentColorChange(Self);\r\nend;\r\n\r\nprocedure TJvExTabSheet.ParentShowHintChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTSHOWHINTCHANGED);\r\nend;\r\n\r\nfunction TJvExTabSheet.WantKey(Key: Integer; Shift: TShiftState): Boolean;\r\nbegin\r\n Result := BaseWndProc(CM_DIALOGCHAR, Word(Key), ShiftStateToKeyData(Shift)) <> 0;\r\nend;\r\n\r\nfunction TJvExTabSheet.HitTest(X, Y: Integer): Boolean;\r\nbegin\r\n Result := BaseWndProc(CM_HITTEST, 0, SmallPointToLong(PointToSmallPoint(Point(X, Y)))) <> 0;\r\nend;\r\n\r\nfunction TJvExTabSheet.HintShow(var HintInfo: THintInfo): Boolean;\r\nbegin\r\n GetHintColor(HintInfo, Self, FHintColor);\r\n if FHintWindowClass <> nil then\r\n HintInfo.HintWindowClass := FHintWindowClass;\r\n Result := BaseWndProcEx(CM_HINTSHOW, 0, HintInfo) <> 0;\r\nend;\r\n\r\nprocedure TJvExTabSheet.MouseEnter(AControl: TControl);\r\nbegin\r\n FMouseOver := True;\r\n if Assigned(FOnMouseEnter) then\r\n FOnMouseEnter(Self);\r\n BaseWndProc(CM_MOUSEENTER, 0, AControl);\r\nend;\r\n\r\nprocedure TJvExTabSheet.MouseLeave(AControl: TControl);\r\nbegin\r\n FMouseOver := False;\r\n BaseWndProc(CM_MOUSELEAVE, 0, AControl);\r\n if Assigned(FOnMouseLeave) then\r\n FOnMouseLeave(Self);\r\nend;\r\n\r\nprocedure TJvExTabSheet.FocusChanged(AControl: TWinControl);\r\nbegin\r\n BaseWndProc(CM_FOCUSCHANGED, 0, AControl);\r\nend;\r\n\r\nprocedure TJvExTabSheet.BoundsChanged;\r\nbegin\r\nend;\r\n\r\nprocedure TJvExTabSheet.CursorChanged;\r\nbegin\r\n BaseWndProc(CM_CURSORCHANGED);\r\nend;\r\n\r\nprocedure TJvExTabSheet.ShowingChanged;\r\nbegin\r\n BaseWndProc(CM_SHOWINGCHANGED);\r\nend;\r\n\r\nprocedure TJvExTabSheet.ShowHintChanged;\r\nbegin\r\n BaseWndProc(CM_SHOWHINTCHANGED);\r\nend;\r\n\r\n{ VCL sends CM_CONTROLLISTCHANGE and CM_CONTROLCHANGE in a different order than\r\n the CLX methods are used. So we must correct it by evaluating \"Inserting\". }\r\nprocedure TJvExTabSheet.ControlsListChanging(Control: TControl; Inserting: Boolean);\r\nbegin\r\n if Inserting then\r\n BaseWndProc(CM_CONTROLLISTCHANGE, WPARAM(Control), LPARAM(Inserting))\r\n else\r\n BaseWndProc(CM_CONTROLCHANGE, WPARAM(Control), LPARAM(Inserting));\r\nend;\r\n\r\nprocedure TJvExTabSheet.ControlsListChanged(Control: TControl; Inserting: Boolean);\r\nbegin\r\n if not Inserting then\r\n BaseWndProc(CM_CONTROLLISTCHANGE, WPARAM(Control), LPARAM(Inserting))\r\n else\r\n BaseWndProc(CM_CONTROLCHANGE, WPARAM(Control), LPARAM(Inserting));\r\nend;\r\n\r\nprocedure TJvExTabSheet.GetDlgCode(var Code: TDlgCodes);\r\nbegin\r\nend;\r\n\r\nprocedure TJvExTabSheet.FocusSet(PrevWnd: THandle);\r\nbegin\r\n BaseWndProc(WM_SETFOCUS, WPARAM(PrevWnd), 0);\r\nend;\r\n\r\nprocedure TJvExTabSheet.FocusKilled(NextWnd: THandle);\r\nbegin\r\n BaseWndProc(WM_KILLFOCUS, WPARAM(NextWnd), 0);\r\nend;\r\n\r\nfunction TJvExTabSheet.DoEraseBackground(Canvas: TCanvas; Param: LPARAM): Boolean;\r\nbegin\r\n Result := BaseWndProc(WM_ERASEBKGND, Canvas.Handle, Param) <> 0;\r\nend;\r\n\r\n{$IFDEF JVCLThemesEnabledD6}\r\nfunction TJvExTabSheet.GetParentBackground: Boolean;\r\nbegin\r\n Result := JvThemes.GetParentBackground(Self);\r\nend;\r\n\r\nprocedure TJvExTabSheet.SetParentBackground(Value: Boolean);\r\nbegin\r\n JvThemes.SetParentBackground(Self, Value);\r\nend;\r\n{$ENDIF JVCLThemesEnabledD6}\r\n\r\nprocedure TJvExTabSheet.WndProc(var Msg: TMessage);\r\nvar\r\n IdSaveDC: Integer;\r\n DlgCodes: TDlgCodes;\r\n Canvas: TCanvas;\r\nbegin\r\n if not DispatchIsDesignMsg(Self, Msg) then\r\n begin\r\n case Msg.Msg of\r\n CM_DENYSUBCLASSING:\r\n Msg.Result := LRESULT(Ord(GetInterfaceEntry(IJvDenySubClassing) <> nil));\r\n CM_DIALOGCHAR:\r\n with TCMDialogChar{$IFDEF CLR}.Create{$ENDIF}(Msg) do\r\n Result := LRESULT(Ord(WantKey(CharCode, KeyDataToShiftState(KeyData))));\r\n CM_HINTSHOW:\r\n with TCMHintShow(Msg) do\r\n Result := LRESULT(HintShow(HintInfo^));\r\n CM_HITTEST:\r\n with TCMHitTest(Msg) do\r\n Result := LRESULT(HitTest(XPos, YPos));\r\n CM_MOUSEENTER:\r\n MouseEnter(TControl(Msg.LParam));\r\n CM_MOUSELEAVE:\r\n MouseLeave(TControl(Msg.LParam));\r\n CM_VISIBLECHANGED:\r\n VisibleChanged;\r\n CM_ENABLEDCHANGED:\r\n EnabledChanged;\r\n CM_TEXTCHANGED:\r\n TextChanged;\r\n CM_FONTCHANGED:\r\n FontChanged;\r\n CM_COLORCHANGED:\r\n ColorChanged;\r\n CM_FOCUSCHANGED:\r\n FocusChanged(TWinControl(Msg.LParam));\r\n CM_PARENTFONTCHANGED:\r\n ParentFontChanged;\r\n CM_PARENTCOLORCHANGED:\r\n ParentColorChanged;\r\n CM_PARENTSHOWHINTCHANGED:\r\n ParentShowHintChanged;\r\n CM_CURSORCHANGED:\r\n CursorChanged;\r\n CM_SHOWINGCHANGED:\r\n ShowingChanged;\r\n CM_SHOWHINTCHANGED:\r\n ShowHintChanged;\r\n CM_CONTROLLISTCHANGE:\r\n if Msg.LParam <> 0 then\r\n ControlsListChanging(TControl(Msg.WParam), True)\r\n else\r\n ControlsListChanged(TControl(Msg.WParam), False);\r\n CM_CONTROLCHANGE:\r\n if Msg.LParam = 0 then\r\n ControlsListChanging(TControl(Msg.WParam), False)\r\n else\r\n ControlsListChanged(TControl(Msg.WParam), True);\r\n WM_SETFOCUS:\r\n FocusSet(THandle(Msg.WParam));\r\n WM_KILLFOCUS:\r\n FocusKilled(THandle(Msg.WParam));\r\n WM_SIZE, WM_MOVE:\r\n begin\r\n inherited WndProc(Msg);\r\n BoundsChanged;\r\n end;\r\n WM_ERASEBKGND:\r\n if (Msg.WParam <> 0) and not IsDefaultEraseBackground(DoEraseBackground, @TJvExTabSheet.DoEraseBackground) then\r\n begin\r\n IdSaveDC := SaveDC(HDC(Msg.WParam)); // protect DC against Stock-Objects from Canvas\r\n Canvas := TCanvas.Create;\r\n try\r\n Canvas.Handle := HDC(Msg.WParam);\r\n Msg.Result := Ord(DoEraseBackground(Canvas, Msg.LParam));\r\n finally\r\n Canvas.Handle := 0;\r\n Canvas.Free;\r\n RestoreDC(HDC(Msg.WParam), IdSaveDC);\r\n end;\r\n end\r\n else\r\n inherited WndProc(Msg);\r\n {$IFNDEF DELPHI2007_UP}\r\n WM_PRINTCLIENT, WM_PRINT: // VCL bug fix\r\n begin\r\n IdSaveDC := SaveDC(HDC(Msg.WParam)); // protect DC against changes\r\n try\r\n inherited WndProc(Msg);\r\n finally\r\n RestoreDC(HDC(Msg.WParam), IdSaveDC);\r\n end;\r\n end;\r\n {$ENDIF ~DELPHI2007_UP}\r\n WM_GETDLGCODE:\r\n begin\r\n inherited WndProc(Msg);\r\n DlgCodes := [dcNative] + DlgcToDlgCodes(Msg.Result);\r\n GetDlgCode(DlgCodes);\r\n if not (dcNative in DlgCodes) then\r\n Msg.Result := DlgCodesToDlgc(DlgCodes);\r\n end;\r\n else\r\n inherited WndProc(Msg);\r\n end;\r\n case Msg.Msg of // precheck message to prevent access violations on released controls\r\n CM_MOUSEENTER, CM_MOUSELEAVE, WM_KILLFOCUS, WM_SETFOCUS, WM_NCPAINT:\r\n if DotNetHighlighting then\r\n HandleDotNetHighlighting(Self, Msg, MouseOver, Color);\r\n end;\r\n end;\r\nend;\r\n\r\n//============================================================================\r\n\r\nconstructor TJvExToolBar.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FHintColor := clDefault;\r\nend;\r\n\r\nfunction TJvExToolBar.BaseWndProc(Msg: Cardinal; WParam: WPARAM = 0; LParam: LPARAM = 0): LRESULT;\r\nvar\r\n Mesg: TMessage;\r\nbegin\r\n CreateWMMessage(Mesg, Msg, WParam, LParam);\r\n inherited WndProc(Mesg);\r\n Result := Mesg.Result;\r\nend;\r\n\r\nfunction TJvExToolBar.BaseWndProc(Msg: Cardinal; WParam: WPARAM; LParam: TObject): LRESULT;\r\nbegin\r\n Result := BaseWndProc(Msg, WParam, Windows.LPARAM(LParam));\r\nend;\r\n\r\nfunction TJvExToolBar.BaseWndProcEx(Msg: Cardinal; WParam: WPARAM; var StructLParam): LRESULT;\r\nbegin\r\n Result := BaseWndProc(Msg, WParam, Windows.LPARAM(@StructLParam));\r\nend;\r\n\r\nprocedure TJvExToolBar.VisibleChanged;\r\nbegin\r\n BaseWndProc(CM_VISIBLECHANGED);\r\nend;\r\n\r\nprocedure TJvExToolBar.EnabledChanged;\r\nbegin\r\n BaseWndProc(CM_ENABLEDCHANGED);\r\nend;\r\n\r\nprocedure TJvExToolBar.TextChanged;\r\nbegin\r\n BaseWndProc(CM_TEXTCHANGED);\r\nend;\r\n\r\nprocedure TJvExToolBar.FontChanged;\r\nbegin\r\n BaseWndProc(CM_FONTCHANGED);\r\nend;\r\n\r\nprocedure TJvExToolBar.ColorChanged;\r\nbegin\r\n BaseWndProc(CM_COLORCHANGED);\r\nend;\r\n\r\nprocedure TJvExToolBar.ParentFontChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTFONTCHANGED);\r\nend;\r\n\r\nprocedure TJvExToolBar.ParentColorChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTCOLORCHANGED);\r\n if Assigned(OnParentColorChange) then\r\n OnParentColorChange(Self);\r\nend;\r\n\r\nprocedure TJvExToolBar.ParentShowHintChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTSHOWHINTCHANGED);\r\nend;\r\n\r\nfunction TJvExToolBar.WantKey(Key: Integer; Shift: TShiftState): Boolean;\r\nbegin\r\n Result := BaseWndProc(CM_DIALOGCHAR, Word(Key), ShiftStateToKeyData(Shift)) <> 0;\r\nend;\r\n\r\nfunction TJvExToolBar.HitTest(X, Y: Integer): Boolean;\r\nbegin\r\n Result := BaseWndProc(CM_HITTEST, 0, SmallPointToLong(PointToSmallPoint(Point(X, Y)))) <> 0;\r\nend;\r\n\r\nfunction TJvExToolBar.HintShow(var HintInfo: THintInfo): Boolean;\r\nbegin\r\n GetHintColor(HintInfo, Self, FHintColor);\r\n if FHintWindowClass <> nil then\r\n HintInfo.HintWindowClass := FHintWindowClass;\r\n Result := BaseWndProcEx(CM_HINTSHOW, 0, HintInfo) <> 0;\r\nend;\r\n\r\nprocedure TJvExToolBar.MouseEnter(AControl: TControl);\r\nbegin\r\n FMouseOver := True;\r\n if Assigned(FOnMouseEnter) then\r\n FOnMouseEnter(Self);\r\n BaseWndProc(CM_MOUSEENTER, 0, AControl);\r\nend;\r\n\r\nprocedure TJvExToolBar.MouseLeave(AControl: TControl);\r\nbegin\r\n FMouseOver := False;\r\n BaseWndProc(CM_MOUSELEAVE, 0, AControl);\r\n if Assigned(FOnMouseLeave) then\r\n FOnMouseLeave(Self);\r\nend;\r\n\r\nprocedure TJvExToolBar.FocusChanged(AControl: TWinControl);\r\nbegin\r\n BaseWndProc(CM_FOCUSCHANGED, 0, AControl);\r\nend;\r\n\r\nprocedure TJvExToolBar.BoundsChanged;\r\nbegin\r\nend;\r\n\r\nprocedure TJvExToolBar.CursorChanged;\r\nbegin\r\n BaseWndProc(CM_CURSORCHANGED);\r\nend;\r\n\r\nprocedure TJvExToolBar.ShowingChanged;\r\nbegin\r\n BaseWndProc(CM_SHOWINGCHANGED);\r\nend;\r\n\r\nprocedure TJvExToolBar.ShowHintChanged;\r\nbegin\r\n BaseWndProc(CM_SHOWHINTCHANGED);\r\nend;\r\n\r\n{ VCL sends CM_CONTROLLISTCHANGE and CM_CONTROLCHANGE in a different order than\r\n the CLX methods are used. So we must correct it by evaluating \"Inserting\". }\r\nprocedure TJvExToolBar.ControlsListChanging(Control: TControl; Inserting: Boolean);\r\nbegin\r\n if Inserting then\r\n BaseWndProc(CM_CONTROLLISTCHANGE, WPARAM(Control), LPARAM(Inserting))\r\n else\r\n BaseWndProc(CM_CONTROLCHANGE, WPARAM(Control), LPARAM(Inserting));\r\nend;\r\n\r\nprocedure TJvExToolBar.ControlsListChanged(Control: TControl; Inserting: Boolean);\r\nbegin\r\n if not Inserting then\r\n BaseWndProc(CM_CONTROLLISTCHANGE, WPARAM(Control), LPARAM(Inserting))\r\n else\r\n BaseWndProc(CM_CONTROLCHANGE, WPARAM(Control), LPARAM(Inserting));\r\nend;\r\n\r\nprocedure TJvExToolBar.GetDlgCode(var Code: TDlgCodes);\r\nbegin\r\nend;\r\n\r\nprocedure TJvExToolBar.FocusSet(PrevWnd: THandle);\r\nbegin\r\n BaseWndProc(WM_SETFOCUS, WPARAM(PrevWnd), 0);\r\nend;\r\n\r\nprocedure TJvExToolBar.FocusKilled(NextWnd: THandle);\r\nbegin\r\n BaseWndProc(WM_KILLFOCUS, WPARAM(NextWnd), 0);\r\nend;\r\n\r\nfunction TJvExToolBar.DoEraseBackground(Canvas: TCanvas; Param: LPARAM): Boolean;\r\nbegin\r\n Result := BaseWndProc(WM_ERASEBKGND, Canvas.Handle, Param) <> 0;\r\nend;\r\n\r\n{$IFDEF JVCLThemesEnabledD6}\r\nfunction TJvExToolBar.GetParentBackground: Boolean;\r\nbegin\r\n Result := JvThemes.GetParentBackground(Self);\r\nend;\r\n\r\nprocedure TJvExToolBar.SetParentBackground(Value: Boolean);\r\nbegin\r\n JvThemes.SetParentBackground(Self, Value);\r\nend;\r\n{$ENDIF JVCLThemesEnabledD6}\r\n\r\nprocedure TJvExToolBar.WndProc(var Msg: TMessage);\r\nvar\r\n IdSaveDC: Integer;\r\n DlgCodes: TDlgCodes;\r\n Canvas: TCanvas;\r\nbegin\r\n if not DispatchIsDesignMsg(Self, Msg) then\r\n begin\r\n case Msg.Msg of\r\n CM_DENYSUBCLASSING:\r\n Msg.Result := LRESULT(Ord(GetInterfaceEntry(IJvDenySubClassing) <> nil));\r\n CM_DIALOGCHAR:\r\n with TCMDialogChar{$IFDEF CLR}.Create{$ENDIF}(Msg) do\r\n Result := LRESULT(Ord(WantKey(CharCode, KeyDataToShiftState(KeyData))));\r\n CM_HINTSHOW:\r\n with TCMHintShow(Msg) do\r\n Result := LRESULT(HintShow(HintInfo^));\r\n CM_HITTEST:\r\n with TCMHitTest(Msg) do\r\n Result := LRESULT(HitTest(XPos, YPos));\r\n CM_MOUSEENTER:\r\n MouseEnter(TControl(Msg.LParam));\r\n CM_MOUSELEAVE:\r\n MouseLeave(TControl(Msg.LParam));\r\n CM_VISIBLECHANGED:\r\n VisibleChanged;\r\n CM_ENABLEDCHANGED:\r\n EnabledChanged;\r\n CM_TEXTCHANGED:\r\n TextChanged;\r\n CM_FONTCHANGED:\r\n FontChanged;\r\n CM_COLORCHANGED:\r\n ColorChanged;\r\n CM_FOCUSCHANGED:\r\n FocusChanged(TWinControl(Msg.LParam));\r\n CM_PARENTFONTCHANGED:\r\n ParentFontChanged;\r\n CM_PARENTCOLORCHANGED:\r\n ParentColorChanged;\r\n CM_PARENTSHOWHINTCHANGED:\r\n ParentShowHintChanged;\r\n CM_CURSORCHANGED:\r\n CursorChanged;\r\n CM_SHOWINGCHANGED:\r\n ShowingChanged;\r\n CM_SHOWHINTCHANGED:\r\n ShowHintChanged;\r\n CM_CONTROLLISTCHANGE:\r\n if Msg.LParam <> 0 then\r\n ControlsListChanging(TControl(Msg.WParam), True)\r\n else\r\n ControlsListChanged(TControl(Msg.WParam), False);\r\n CM_CONTROLCHANGE:\r\n if Msg.LParam = 0 then\r\n ControlsListChanging(TControl(Msg.WParam), False)\r\n else\r\n ControlsListChanged(TControl(Msg.WParam), True);\r\n WM_SETFOCUS:\r\n FocusSet(THandle(Msg.WParam));\r\n WM_KILLFOCUS:\r\n FocusKilled(THandle(Msg.WParam));\r\n WM_SIZE, WM_MOVE:\r\n begin\r\n inherited WndProc(Msg);\r\n BoundsChanged;\r\n end;\r\n WM_ERASEBKGND:\r\n if (Msg.WParam <> 0) and not IsDefaultEraseBackground(DoEraseBackground, @TJvExToolBar.DoEraseBackground) then\r\n begin\r\n IdSaveDC := SaveDC(HDC(Msg.WParam)); // protect DC against Stock-Objects from Canvas\r\n Canvas := TCanvas.Create;\r\n try\r\n Canvas.Handle := HDC(Msg.WParam);\r\n Msg.Result := Ord(DoEraseBackground(Canvas, Msg.LParam));\r\n finally\r\n Canvas.Handle := 0;\r\n Canvas.Free;\r\n RestoreDC(HDC(Msg.WParam), IdSaveDC);\r\n end;\r\n end\r\n else\r\n inherited WndProc(Msg);\r\n {$IFNDEF DELPHI2007_UP}\r\n WM_PRINTCLIENT, WM_PRINT: // VCL bug fix\r\n begin\r\n IdSaveDC := SaveDC(HDC(Msg.WParam)); // protect DC against changes\r\n try\r\n inherited WndProc(Msg);\r\n finally\r\n RestoreDC(HDC(Msg.WParam), IdSaveDC);\r\n end;\r\n end;\r\n {$ENDIF ~DELPHI2007_UP}\r\n WM_GETDLGCODE:\r\n begin\r\n inherited WndProc(Msg);\r\n DlgCodes := [dcNative] + DlgcToDlgCodes(Msg.Result);\r\n GetDlgCode(DlgCodes);\r\n if not (dcNative in DlgCodes) then\r\n Msg.Result := DlgCodesToDlgc(DlgCodes);\r\n end;\r\n else\r\n inherited WndProc(Msg);\r\n end;\r\n case Msg.Msg of // precheck message to prevent access violations on released controls\r\n CM_MOUSEENTER, CM_MOUSELEAVE, WM_KILLFOCUS, WM_SETFOCUS, WM_NCPAINT:\r\n if DotNetHighlighting then\r\n HandleDotNetHighlighting(Self, Msg, MouseOver, Color);\r\n end;\r\n end;\r\nend;\r\n\r\n//============================================================================\r\n\r\nconstructor TJvExStatusBar.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FHintColor := clDefault;\r\nend;\r\n\r\nfunction TJvExStatusBar.BaseWndProc(Msg: Cardinal; WParam: WPARAM = 0; LParam: LPARAM = 0): LRESULT;\r\nvar\r\n Mesg: TMessage;\r\nbegin\r\n CreateWMMessage(Mesg, Msg, WParam, LParam);\r\n inherited WndProc(Mesg);\r\n Result := Mesg.Result;\r\nend;\r\n\r\nfunction TJvExStatusBar.BaseWndProc(Msg: Cardinal; WParam: WPARAM; LParam: TObject): LRESULT;\r\nbegin\r\n Result := BaseWndProc(Msg, WParam, Windows.LPARAM(LParam));\r\nend;\r\n\r\nfunction TJvExStatusBar.BaseWndProcEx(Msg: Cardinal; WParam: WPARAM; var StructLParam): LRESULT;\r\nbegin\r\n Result := BaseWndProc(Msg, WParam, Windows.LPARAM(@StructLParam));\r\nend;\r\n\r\nprocedure TJvExStatusBar.VisibleChanged;\r\nbegin\r\n BaseWndProc(CM_VISIBLECHANGED);\r\nend;\r\n\r\nprocedure TJvExStatusBar.EnabledChanged;\r\nbegin\r\n BaseWndProc(CM_ENABLEDCHANGED);\r\nend;\r\n\r\nprocedure TJvExStatusBar.TextChanged;\r\nbegin\r\n BaseWndProc(CM_TEXTCHANGED);\r\nend;\r\n\r\nprocedure TJvExStatusBar.FontChanged;\r\nbegin\r\n BaseWndProc(CM_FONTCHANGED);\r\nend;\r\n\r\nprocedure TJvExStatusBar.ColorChanged;\r\nbegin\r\n BaseWndProc(CM_COLORCHANGED);\r\nend;\r\n\r\nprocedure TJvExStatusBar.ParentFontChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTFONTCHANGED);\r\nend;\r\n\r\nprocedure TJvExStatusBar.ParentColorChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTCOLORCHANGED);\r\n if Assigned(OnParentColorChange) then\r\n OnParentColorChange(Self);\r\nend;\r\n\r\nprocedure TJvExStatusBar.ParentShowHintChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTSHOWHINTCHANGED);\r\nend;\r\n\r\nfunction TJvExStatusBar.WantKey(Key: Integer; Shift: TShiftState): Boolean;\r\nbegin\r\n Result := BaseWndProc(CM_DIALOGCHAR, Word(Key), ShiftStateToKeyData(Shift)) <> 0;\r\nend;\r\n\r\nfunction TJvExStatusBar.HitTest(X, Y: Integer): Boolean;\r\nbegin\r\n Result := BaseWndProc(CM_HITTEST, 0, SmallPointToLong(PointToSmallPoint(Point(X, Y)))) <> 0;\r\nend;\r\n\r\nfunction TJvExStatusBar.HintShow(var HintInfo: THintInfo): Boolean;\r\nbegin\r\n GetHintColor(HintInfo, Self, FHintColor);\r\n if FHintWindowClass <> nil then\r\n HintInfo.HintWindowClass := FHintWindowClass;\r\n Result := BaseWndProcEx(CM_HINTSHOW, 0, HintInfo) <> 0;\r\nend;\r\n\r\nprocedure TJvExStatusBar.MouseEnter(AControl: TControl);\r\nbegin\r\n FMouseOver := True;\r\n if Assigned(FOnMouseEnter) then\r\n FOnMouseEnter(Self);\r\n BaseWndProc(CM_MOUSEENTER, 0, AControl);\r\nend;\r\n\r\nprocedure TJvExStatusBar.MouseLeave(AControl: TControl);\r\nbegin\r\n FMouseOver := False;\r\n BaseWndProc(CM_MOUSELEAVE, 0, AControl);\r\n if Assigned(FOnMouseLeave) then\r\n FOnMouseLeave(Self);\r\nend;\r\n\r\nprocedure TJvExStatusBar.FocusChanged(AControl: TWinControl);\r\nbegin\r\n BaseWndProc(CM_FOCUSCHANGED, 0, AControl);\r\nend;\r\n\r\nprocedure TJvExStatusBar.BoundsChanged;\r\nbegin\r\nend;\r\n\r\nprocedure TJvExStatusBar.CursorChanged;\r\nbegin\r\n BaseWndProc(CM_CURSORCHANGED);\r\nend;\r\n\r\nprocedure TJvExStatusBar.ShowingChanged;\r\nbegin\r\n BaseWndProc(CM_SHOWINGCHANGED);\r\nend;\r\n\r\nprocedure TJvExStatusBar.ShowHintChanged;\r\nbegin\r\n BaseWndProc(CM_SHOWHINTCHANGED);\r\nend;\r\n\r\n{ VCL sends CM_CONTROLLISTCHANGE and CM_CONTROLCHANGE in a different order than\r\n the CLX methods are used. So we must correct it by evaluating \"Inserting\". }\r\nprocedure TJvExStatusBar.ControlsListChanging(Control: TControl; Inserting: Boolean);\r\nbegin\r\n if Inserting then\r\n BaseWndProc(CM_CONTROLLISTCHANGE, WPARAM(Control), LPARAM(Inserting))\r\n else\r\n BaseWndProc(CM_CONTROLCHANGE, WPARAM(Control), LPARAM(Inserting));\r\nend;\r\n\r\nprocedure TJvExStatusBar.ControlsListChanged(Control: TControl; Inserting: Boolean);\r\nbegin\r\n if not Inserting then\r\n BaseWndProc(CM_CONTROLLISTCHANGE, WPARAM(Control), LPARAM(Inserting))\r\n else\r\n BaseWndProc(CM_CONTROLCHANGE, WPARAM(Control), LPARAM(Inserting));\r\nend;\r\n\r\nprocedure TJvExStatusBar.GetDlgCode(var Code: TDlgCodes);\r\nbegin\r\nend;\r\n\r\nprocedure TJvExStatusBar.FocusSet(PrevWnd: THandle);\r\nbegin\r\n BaseWndProc(WM_SETFOCUS, WPARAM(PrevWnd), 0);\r\nend;\r\n\r\nprocedure TJvExStatusBar.FocusKilled(NextWnd: THandle);\r\nbegin\r\n BaseWndProc(WM_KILLFOCUS, WPARAM(NextWnd), 0);\r\nend;\r\n\r\nfunction TJvExStatusBar.DoEraseBackground(Canvas: TCanvas; Param: LPARAM): Boolean;\r\nbegin\r\n Result := BaseWndProc(WM_ERASEBKGND, Canvas.Handle, Param) <> 0;\r\nend;\r\n\r\n{$IFDEF JVCLThemesEnabledD6}\r\nfunction TJvExStatusBar.GetParentBackground: Boolean;\r\nbegin\r\n Result := JvThemes.GetParentBackground(Self);\r\nend;\r\n\r\nprocedure TJvExStatusBar.SetParentBackground(Value: Boolean);\r\nbegin\r\n JvThemes.SetParentBackground(Self, Value);\r\nend;\r\n{$ENDIF JVCLThemesEnabledD6}\r\n\r\nprocedure TJvExStatusBar.WndProc(var Msg: TMessage);\r\nvar\r\n IdSaveDC: Integer;\r\n DlgCodes: TDlgCodes;\r\n Canvas: TCanvas;\r\nbegin\r\n if not DispatchIsDesignMsg(Self, Msg) then\r\n begin\r\n case Msg.Msg of\r\n CM_DENYSUBCLASSING:\r\n Msg.Result := LRESULT(Ord(GetInterfaceEntry(IJvDenySubClassing) <> nil));\r\n CM_DIALOGCHAR:\r\n with TCMDialogChar{$IFDEF CLR}.Create{$ENDIF}(Msg) do\r\n Result := LRESULT(Ord(WantKey(CharCode, KeyDataToShiftState(KeyData))));\r\n CM_HINTSHOW:\r\n with TCMHintShow(Msg) do\r\n Result := LRESULT(HintShow(HintInfo^));\r\n CM_HITTEST:\r\n with TCMHitTest(Msg) do\r\n Result := LRESULT(HitTest(XPos, YPos));\r\n CM_MOUSEENTER:\r\n MouseEnter(TControl(Msg.LParam));\r\n CM_MOUSELEAVE:\r\n MouseLeave(TControl(Msg.LParam));\r\n CM_VISIBLECHANGED:\r\n VisibleChanged;\r\n CM_ENABLEDCHANGED:\r\n EnabledChanged;\r\n CM_TEXTCHANGED:\r\n TextChanged;\r\n CM_FONTCHANGED:\r\n FontChanged;\r\n CM_COLORCHANGED:\r\n ColorChanged;\r\n CM_FOCUSCHANGED:\r\n FocusChanged(TWinControl(Msg.LParam));\r\n CM_PARENTFONTCHANGED:\r\n ParentFontChanged;\r\n CM_PARENTCOLORCHANGED:\r\n ParentColorChanged;\r\n CM_PARENTSHOWHINTCHANGED:\r\n ParentShowHintChanged;\r\n CM_CURSORCHANGED:\r\n CursorChanged;\r\n CM_SHOWINGCHANGED:\r\n ShowingChanged;\r\n CM_SHOWHINTCHANGED:\r\n ShowHintChanged;\r\n CM_CONTROLLISTCHANGE:\r\n if Msg.LParam <> 0 then\r\n ControlsListChanging(TControl(Msg.WParam), True)\r\n else\r\n ControlsListChanged(TControl(Msg.WParam), False);\r\n CM_CONTROLCHANGE:\r\n if Msg.LParam = 0 then\r\n ControlsListChanging(TControl(Msg.WParam), False)\r\n else\r\n ControlsListChanged(TControl(Msg.WParam), True);\r\n WM_SETFOCUS:\r\n FocusSet(THandle(Msg.WParam));\r\n WM_KILLFOCUS:\r\n FocusKilled(THandle(Msg.WParam));\r\n WM_SIZE, WM_MOVE:\r\n begin\r\n inherited WndProc(Msg);\r\n BoundsChanged;\r\n end;\r\n WM_ERASEBKGND:\r\n if (Msg.WParam <> 0) and not IsDefaultEraseBackground(DoEraseBackground, @TJvExStatusBar.DoEraseBackground) then\r\n begin\r\n IdSaveDC := SaveDC(HDC(Msg.WParam)); // protect DC against Stock-Objects from Canvas\r\n Canvas := TCanvas.Create;\r\n try\r\n Canvas.Handle := HDC(Msg.WParam);\r\n Msg.Result := Ord(DoEraseBackground(Canvas, Msg.LParam));\r\n finally\r\n Canvas.Handle := 0;\r\n Canvas.Free;\r\n RestoreDC(HDC(Msg.WParam), IdSaveDC);\r\n end;\r\n end\r\n else\r\n inherited WndProc(Msg);\r\n {$IFNDEF DELPHI2007_UP}\r\n WM_PRINTCLIENT, WM_PRINT: // VCL bug fix\r\n begin\r\n IdSaveDC := SaveDC(HDC(Msg.WParam)); // protect DC against changes\r\n try\r\n inherited WndProc(Msg);\r\n finally\r\n RestoreDC(HDC(Msg.WParam), IdSaveDC);\r\n end;\r\n end;\r\n {$ENDIF ~DELPHI2007_UP}\r\n WM_GETDLGCODE:\r\n begin\r\n inherited WndProc(Msg);\r\n DlgCodes := [dcNative] + DlgcToDlgCodes(Msg.Result);\r\n GetDlgCode(DlgCodes);\r\n if not (dcNative in DlgCodes) then\r\n Msg.Result := DlgCodesToDlgc(DlgCodes);\r\n end;\r\n else\r\n inherited WndProc(Msg);\r\n end;\r\n case Msg.Msg of // precheck message to prevent access violations on released controls\r\n CM_MOUSEENTER, CM_MOUSELEAVE, WM_KILLFOCUS, WM_SETFOCUS, WM_NCPAINT:\r\n if DotNetHighlighting then\r\n HandleDotNetHighlighting(Self, Msg, MouseOver, Color);\r\n end;\r\n end;\r\nend;\r\n\r\n//============================================================================\r\n\r\nconstructor TJvExToolButton.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FHintColor := clDefault;\r\nend;\r\n\r\nfunction TJvExToolButton.BaseWndProc(Msg: Cardinal; WParam: WPARAM = 0; LParam: LPARAM = 0): LRESULT;\r\nvar\r\n Mesg: TMessage;\r\nbegin\r\n CreateWMMessage(Mesg, Msg, WParam, LParam);\r\n inherited WndProc(Mesg);\r\n Result := Mesg.Result;\r\nend;\r\n\r\nfunction TJvExToolButton.BaseWndProc(Msg: Cardinal; WParam: WPARAM; LParam: TObject): LRESULT;\r\nbegin\r\n Result := BaseWndProc(Msg, WParam, Windows.LPARAM(LParam));\r\nend;\r\n\r\nfunction TJvExToolButton.BaseWndProcEx(Msg: Cardinal; WParam: WPARAM; var StructLParam): LRESULT;\r\nbegin\r\n Result := BaseWndProc(Msg, WParam, Windows.LPARAM(@StructLParam));\r\nend;\r\n\r\nprocedure TJvExToolButton.VisibleChanged;\r\nbegin\r\n BaseWndProc(CM_VISIBLECHANGED);\r\nend;\r\n\r\nprocedure TJvExToolButton.EnabledChanged;\r\nbegin\r\n BaseWndProc(CM_ENABLEDCHANGED);\r\nend;\r\n\r\nprocedure TJvExToolButton.TextChanged;\r\nbegin\r\n BaseWndProc(CM_TEXTCHANGED);\r\nend;\r\n\r\nprocedure TJvExToolButton.FontChanged;\r\nbegin\r\n BaseWndProc(CM_FONTCHANGED);\r\nend;\r\n\r\nprocedure TJvExToolButton.ColorChanged;\r\nbegin\r\n BaseWndProc(CM_COLORCHANGED);\r\nend;\r\n\r\nprocedure TJvExToolButton.ParentFontChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTFONTCHANGED);\r\nend;\r\n\r\nprocedure TJvExToolButton.ParentColorChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTCOLORCHANGED);\r\n if Assigned(OnParentColorChange) then\r\n OnParentColorChange(Self);\r\nend;\r\n\r\nprocedure TJvExToolButton.ParentShowHintChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTSHOWHINTCHANGED);\r\nend;\r\n\r\nfunction TJvExToolButton.WantKey(Key: Integer; Shift: TShiftState): Boolean;\r\nbegin\r\n Result := BaseWndProc(CM_DIALOGCHAR, Word(Key), ShiftStateToKeyData(Shift)) <> 0;\r\nend;\r\n\r\nfunction TJvExToolButton.HitTest(X, Y: Integer): Boolean;\r\nbegin\r\n Result := BaseWndProc(CM_HITTEST, 0, SmallPointToLong(PointToSmallPoint(Point(X, Y)))) <> 0;\r\nend;\r\n\r\nfunction TJvExToolButton.HintShow(var HintInfo: THintInfo): Boolean;\r\nbegin\r\n GetHintColor(HintInfo, Self, FHintColor);\r\n if FHintWindowClass <> nil then\r\n HintInfo.HintWindowClass := FHintWindowClass;\r\n Result := BaseWndProcEx(CM_HINTSHOW, 0, HintInfo) <> 0;\r\nend;\r\n\r\nprocedure TJvExToolButton.MouseEnter(AControl: TControl);\r\nbegin\r\n FMouseOver := True;\r\n if Assigned(FOnMouseEnter) then\r\n FOnMouseEnter(Self);\r\n BaseWndProc(CM_MOUSEENTER, 0, AControl);\r\nend;\r\n\r\nprocedure TJvExToolButton.MouseLeave(AControl: TControl);\r\nbegin\r\n FMouseOver := False;\r\n BaseWndProc(CM_MOUSELEAVE, 0, AControl);\r\n if Assigned(FOnMouseLeave) then\r\n FOnMouseLeave(Self);\r\nend;\r\n\r\nprocedure TJvExToolButton.FocusChanged(AControl: TWinControl);\r\nbegin\r\n BaseWndProc(CM_FOCUSCHANGED, 0, AControl);\r\nend;\r\n\r\nprocedure TJvExToolButton.WndProc(var Msg: TMessage);\r\nbegin\r\n if not DispatchIsDesignMsg(Self, Msg) then\r\n case Msg.Msg of\r\n CM_DENYSUBCLASSING:\r\n Msg.Result := LRESULT(Ord(GetInterfaceEntry(IJvDenySubClassing) <> nil));\r\n CM_DIALOGCHAR:\r\n with TCMDialogChar{$IFDEF CLR}.Create{$ENDIF}(Msg) do\r\n Result := LRESULT(Ord(WantKey(CharCode, KeyDataToShiftState(KeyData))));\r\n CM_HINTSHOW:\r\n with TCMHintShow(Msg) do\r\n Result := LRESULT(HintShow(HintInfo^));\r\n CM_HITTEST:\r\n with TCMHitTest(Msg) do\r\n Result := LRESULT(HitTest(XPos, YPos));\r\n CM_MOUSEENTER:\r\n MouseEnter(TControl(Msg.LParam));\r\n CM_MOUSELEAVE:\r\n MouseLeave(TControl(Msg.LParam));\r\n CM_VISIBLECHANGED:\r\n VisibleChanged;\r\n CM_ENABLEDCHANGED:\r\n EnabledChanged;\r\n CM_TEXTCHANGED:\r\n TextChanged;\r\n CM_FONTCHANGED:\r\n FontChanged;\r\n CM_COLORCHANGED:\r\n ColorChanged;\r\n CM_FOCUSCHANGED:\r\n FocusChanged(TWinControl(Msg.LParam));\r\n CM_PARENTFONTCHANGED:\r\n ParentFontChanged;\r\n CM_PARENTCOLORCHANGED:\r\n ParentColorChanged;\r\n CM_PARENTSHOWHINTCHANGED:\r\n ParentShowHintChanged;\r\n else\r\n inherited WndProc(Msg);\r\n end;\r\nend;\r\n\r\n//============================================================================\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend." }, { "path": "External/Jedi/Jvcl/run/JvExControls.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvExControls.pas, released on 2004-01-04\r\n\r\nThe Initial Developer of the Original Code is Andreas Hausladen [Andreas dott Hausladen att gmx dott de]\r\nPortions created by Andreas Hausladen are Copyright (C) 2004 Andreas Hausladen.\r\nAll Rights Reserved.\r\n\r\nContributor(s): -\r\n dejoy.\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvExControls.pas 13173 2011-11-19 12:43:58Z ahuser $\r\n\r\nunit JvExControls;\r\n\r\n{$I jvcl.inc}\r\n\r\n{*****************************************************************************\r\n * WARNING: Do not edit this file.\r\n * This file is autogenerated from the source in devtools/JvExVCL/src.\r\n * If you do it despite this warning your changes will be discarded by the next\r\n * update of this file. Do your changes in the template files.\r\n ****************************************************************************}\r\n{$D-} // do not step into this unit\r\n\r\ninterface\r\n\r\nuses\r\n Windows, Messages, Types,\r\n SysUtils, Classes, Graphics, Controls, Forms,\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n JvTypes, JvThemes, JVCLVer;\r\n\r\ntype\r\n TDlgCode =\r\n (dcWantAllKeys, dcWantArrows, dcWantChars, dcButton, dcHasSetSel, dcWantTab,\r\n dcNative); // if dcNative is in the set the native allowed keys are used and GetDlgCode is ignored\r\n TDlgCodes = set of TDlgCode;\r\n\r\nconst\r\n dcWantMessage = dcWantAllKeys;\r\n\r\ntype\r\n { IJvExControl is used for the identification of an JvExXxx control. }\r\n IJvExControl = interface\r\n ['{8E6579C3-D683-4562-AFAB-D23C8526E386}']\r\n end;\r\n\r\n { Add IJvDenySubClassing to the base class list if the control should not\r\n be themed by the ThemeManager (http://www.soft-gems.net Mike Lischke).\r\n This only works with JvExVCL derived classes. }\r\n IJvDenySubClassing = interface\r\n ['{76942BC0-2A6E-4DC4-BFC9-8E110DB7F601}']\r\n end;\r\n\r\nprocedure SetDotNetFrameColors(FocusedColor, UnfocusedColor: TColor);\r\nprocedure DrawDotNetControl(Control: TWinControl; AColor: TColor; InControl: Boolean); overload;\r\nprocedure DrawDotNetControl(DC: HDC; R: TRect; AColor: TColor; UseFocusedColor: Boolean); overload;\r\nprocedure HandleDotNetHighlighting(Control: TWinControl; const Msg: TMessage;\r\n MouseOver: Boolean; Color: TColor);\r\n\r\nprocedure CreateWMMessage(var Mesg: TMessage; Msg: Cardinal; WParam: WPARAM; LParam: LPARAM); overload; {$IFDEF SUPPORTS_INLINE} inline {$ENDIF}\r\nfunction SmallPointToLong(const Pt: TSmallPoint): Longint; {$IFDEF SUPPORTS_INLINE} inline {$ENDIF}\r\nfunction ShiftStateToKeyData(Shift: TShiftState): Longint;\r\nfunction GetFocusedControl(AControl: TControl): TWinControl;\r\nfunction DlgcToDlgCodes(Value: LPARAM): TDlgCodes;\r\nfunction DlgCodesToDlgc(const Value: TDlgCodes): LPARAM;\r\nprocedure GetHintColor(var HintInfo: THintInfo; AControl: TControl; HintColor: TColor);\r\nfunction DispatchIsDesignMsg(Control: TControl; var Msg: TMessage): Boolean;\r\n\r\ntype\r\n TJvDoEraseBackgroundMethod = function(Canvas: TCanvas; Param: LPARAM): Boolean of object;\r\n\r\nfunction IsDefaultEraseBackground(Method: TJvDoEraseBackgroundMethod; MethodPtr: Pointer): Boolean;\r\n\r\ntype\r\n TJvExControl = class(TControl, IJvExControl)\r\n private\r\n FAboutJVCL: TJVCLAboutInfo;\r\n FHintColor: TColor;\r\n FMouseOver: Boolean;\r\n FHintWindowClass: THintWindowClass;\r\n FOnMouseEnter: TNotifyEvent;\r\n FOnMouseLeave: TNotifyEvent;\r\n FOnParentColorChanged: TNotifyEvent;\r\n function BaseWndProc(Msg: Cardinal; WParam: WPARAM = 0; LParam: LPARAM = 0): LRESULT; overload;\r\n function BaseWndProc(Msg: Cardinal; WParam: WPARAM; LParam: TObject): LRESULT; overload;\r\n function BaseWndProcEx(Msg: Cardinal; WParam: WPARAM; var StructLParam): LRESULT;\r\n protected\r\n procedure WndProc(var Msg: TMessage); override;\r\n procedure FocusChanged(AControl: TWinControl); dynamic;\r\n procedure VisibleChanged; reintroduce; dynamic;\r\n procedure EnabledChanged; reintroduce; dynamic;\r\n procedure TextChanged; reintroduce; virtual;\r\n procedure ColorChanged; reintroduce; dynamic;\r\n procedure FontChanged; reintroduce; dynamic;\r\n procedure ParentFontChanged; reintroduce; dynamic;\r\n procedure ParentColorChanged; reintroduce; dynamic;\r\n procedure ParentShowHintChanged; reintroduce; dynamic;\r\n function WantKey(Key: Integer; Shift: TShiftState): Boolean; virtual;\r\n function HintShow(var HintInfo: THintInfo): Boolean; reintroduce; dynamic;\r\n function HitTest(X, Y: Integer): Boolean; reintroduce; virtual;\r\n procedure MouseEnter(AControl: TControl); reintroduce; dynamic;\r\n procedure MouseLeave(AControl: TControl); reintroduce; dynamic;\r\n property MouseOver: Boolean read FMouseOver write FMouseOver;\r\n property HintColor: TColor read FHintColor write FHintColor default clDefault;\r\n property OnMouseEnter: TNotifyEvent read FOnMouseEnter write FOnMouseEnter;\r\n property OnMouseLeave: TNotifyEvent read FOnMouseLeave write FOnMouseLeave;\r\n property OnParentColorChange: TNotifyEvent read FOnParentColorChanged write FOnParentColorChanged;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n property HintWindowClass: THintWindowClass read FHintWindowClass write FHintWindowClass;\r\n published\r\n property AboutJVCL: TJVCLAboutInfo read FAboutJVCL write FAboutJVCL stored False;\r\n end;\r\n\r\n TJvExWinControl = class(TWinControl, IJvExControl)\r\n private\r\n FAboutJVCL: TJVCLAboutInfo;\r\n FHintColor: TColor;\r\n FMouseOver: Boolean;\r\n FHintWindowClass: THintWindowClass;\r\n FOnMouseEnter: TNotifyEvent;\r\n FOnMouseLeave: TNotifyEvent;\r\n FOnParentColorChanged: TNotifyEvent;\r\n function BaseWndProc(Msg: Cardinal; WParam: WPARAM = 0; LParam: LPARAM = 0): LRESULT; overload;\r\n function BaseWndProc(Msg: Cardinal; WParam: WPARAM; LParam: TObject): LRESULT; overload;\r\n function BaseWndProcEx(Msg: Cardinal; WParam: WPARAM; var StructLParam): LRESULT;\r\n protected\r\n procedure WndProc(var Msg: TMessage); override;\r\n procedure FocusChanged(AControl: TWinControl); dynamic;\r\n procedure VisibleChanged; reintroduce; dynamic;\r\n procedure EnabledChanged; reintroduce; dynamic;\r\n procedure TextChanged; reintroduce; virtual;\r\n procedure ColorChanged; reintroduce; dynamic;\r\n procedure FontChanged; reintroduce; dynamic;\r\n procedure ParentFontChanged; reintroduce; dynamic;\r\n procedure ParentColorChanged; reintroduce; dynamic;\r\n procedure ParentShowHintChanged; reintroduce; dynamic;\r\n function WantKey(Key: Integer; Shift: TShiftState): Boolean; virtual;\r\n function HintShow(var HintInfo: THintInfo): Boolean; reintroduce; dynamic;\r\n function HitTest(X, Y: Integer): Boolean; reintroduce; virtual;\r\n procedure MouseEnter(AControl: TControl); reintroduce; dynamic;\r\n procedure MouseLeave(AControl: TControl); reintroduce; dynamic;\r\n property MouseOver: Boolean read FMouseOver write FMouseOver;\r\n property HintColor: TColor read FHintColor write FHintColor default clDefault;\r\n property OnMouseEnter: TNotifyEvent read FOnMouseEnter write FOnMouseEnter;\r\n property OnMouseLeave: TNotifyEvent read FOnMouseLeave write FOnMouseLeave;\r\n property OnParentColorChange: TNotifyEvent read FOnParentColorChanged write FOnParentColorChanged;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n property HintWindowClass: THintWindowClass read FHintWindowClass write FHintWindowClass;\r\n published\r\n property AboutJVCL: TJVCLAboutInfo read FAboutJVCL write FAboutJVCL stored False;\r\n private\r\n FDotNetHighlighting: Boolean;\r\n protected\r\n procedure BoundsChanged; reintroduce; virtual;\r\n procedure CursorChanged; reintroduce; dynamic;\r\n procedure ShowingChanged; reintroduce; dynamic;\r\n procedure ShowHintChanged; reintroduce; dynamic;\r\n procedure ControlsListChanging(Control: TControl; Inserting: Boolean); reintroduce; dynamic;\r\n procedure ControlsListChanged(Control: TControl; Inserting: Boolean); reintroduce; dynamic;\r\n procedure GetDlgCode(var Code: TDlgCodes); virtual;\r\n procedure FocusSet(PrevWnd: THandle); virtual;\r\n procedure FocusKilled(NextWnd: THandle); virtual;\r\n function DoEraseBackground(Canvas: TCanvas; Param: LPARAM): Boolean; virtual;\r\n {$IFDEF JVCLThemesEnabledD6}\r\n private\r\n function GetParentBackground: Boolean;\r\n protected\r\n procedure SetParentBackground(Value: Boolean); virtual;\r\n property ParentBackground: Boolean read GetParentBackground write SetParentBackground;\r\n {$ENDIF JVCLThemesEnabledD6}\r\n published\r\n property DotNetHighlighting: Boolean read FDotNetHighlighting write FDotNetHighlighting default False;\r\n end;\r\n\r\n TJvExCustomControl = class(TCustomControl, IJvExControl)\r\n private\r\n FAboutJVCL: TJVCLAboutInfo;\r\n FHintColor: TColor;\r\n FMouseOver: Boolean;\r\n FHintWindowClass: THintWindowClass;\r\n FOnMouseEnter: TNotifyEvent;\r\n FOnMouseLeave: TNotifyEvent;\r\n FOnParentColorChanged: TNotifyEvent;\r\n function BaseWndProc(Msg: Cardinal; WParam: WPARAM = 0; LParam: LPARAM = 0): LRESULT; overload;\r\n function BaseWndProc(Msg: Cardinal; WParam: WPARAM; LParam: TObject): LRESULT; overload;\r\n function BaseWndProcEx(Msg: Cardinal; WParam: WPARAM; var StructLParam): LRESULT;\r\n protected\r\n procedure WndProc(var Msg: TMessage); override;\r\n procedure FocusChanged(AControl: TWinControl); dynamic;\r\n procedure VisibleChanged; reintroduce; dynamic;\r\n procedure EnabledChanged; reintroduce; dynamic;\r\n procedure TextChanged; reintroduce; virtual;\r\n procedure ColorChanged; reintroduce; dynamic;\r\n procedure FontChanged; reintroduce; dynamic;\r\n procedure ParentFontChanged; reintroduce; dynamic;\r\n procedure ParentColorChanged; reintroduce; dynamic;\r\n procedure ParentShowHintChanged; reintroduce; dynamic;\r\n function WantKey(Key: Integer; Shift: TShiftState): Boolean; virtual;\r\n function HintShow(var HintInfo: THintInfo): Boolean; reintroduce; dynamic;\r\n function HitTest(X, Y: Integer): Boolean; reintroduce; virtual;\r\n procedure MouseEnter(AControl: TControl); reintroduce; dynamic;\r\n procedure MouseLeave(AControl: TControl); reintroduce; dynamic;\r\n property MouseOver: Boolean read FMouseOver write FMouseOver;\r\n property HintColor: TColor read FHintColor write FHintColor default clDefault;\r\n property OnMouseEnter: TNotifyEvent read FOnMouseEnter write FOnMouseEnter;\r\n property OnMouseLeave: TNotifyEvent read FOnMouseLeave write FOnMouseLeave;\r\n property OnParentColorChange: TNotifyEvent read FOnParentColorChanged write FOnParentColorChanged;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n property HintWindowClass: THintWindowClass read FHintWindowClass write FHintWindowClass;\r\n published\r\n property AboutJVCL: TJVCLAboutInfo read FAboutJVCL write FAboutJVCL stored False;\r\n private\r\n FDotNetHighlighting: Boolean;\r\n protected\r\n procedure BoundsChanged; reintroduce; virtual;\r\n procedure CursorChanged; reintroduce; dynamic;\r\n procedure ShowingChanged; reintroduce; dynamic;\r\n procedure ShowHintChanged; reintroduce; dynamic;\r\n procedure ControlsListChanging(Control: TControl; Inserting: Boolean); reintroduce; dynamic;\r\n procedure ControlsListChanged(Control: TControl; Inserting: Boolean); reintroduce; dynamic;\r\n procedure GetDlgCode(var Code: TDlgCodes); virtual;\r\n procedure FocusSet(PrevWnd: THandle); virtual;\r\n procedure FocusKilled(NextWnd: THandle); virtual;\r\n function DoEraseBackground(Canvas: TCanvas; Param: LPARAM): Boolean; virtual;\r\n {$IFDEF JVCLThemesEnabledD6}\r\n private\r\n function GetParentBackground: Boolean;\r\n protected\r\n procedure SetParentBackground(Value: Boolean); virtual;\r\n property ParentBackground: Boolean read GetParentBackground write SetParentBackground;\r\n {$ENDIF JVCLThemesEnabledD6}\r\n published\r\n property DotNetHighlighting: Boolean read FDotNetHighlighting write FDotNetHighlighting default False;\r\n end;\r\n\r\n TJvExGraphicControl = class(TGraphicControl, IJvExControl)\r\n private\r\n FAboutJVCL: TJVCLAboutInfo;\r\n FHintColor: TColor;\r\n FMouseOver: Boolean;\r\n FHintWindowClass: THintWindowClass;\r\n FOnMouseEnter: TNotifyEvent;\r\n FOnMouseLeave: TNotifyEvent;\r\n FOnParentColorChanged: TNotifyEvent;\r\n function BaseWndProc(Msg: Cardinal; WParam: WPARAM = 0; LParam: LPARAM = 0): LRESULT; overload;\r\n function BaseWndProc(Msg: Cardinal; WParam: WPARAM; LParam: TObject): LRESULT; overload;\r\n function BaseWndProcEx(Msg: Cardinal; WParam: WPARAM; var StructLParam): LRESULT;\r\n protected\r\n procedure WndProc(var Msg: TMessage); override;\r\n procedure FocusChanged(AControl: TWinControl); dynamic;\r\n procedure VisibleChanged; reintroduce; dynamic;\r\n procedure EnabledChanged; reintroduce; dynamic;\r\n procedure TextChanged; reintroduce; virtual;\r\n procedure ColorChanged; reintroduce; dynamic;\r\n procedure FontChanged; reintroduce; dynamic;\r\n procedure ParentFontChanged; reintroduce; dynamic;\r\n procedure ParentColorChanged; reintroduce; dynamic;\r\n procedure ParentShowHintChanged; reintroduce; dynamic;\r\n function WantKey(Key: Integer; Shift: TShiftState): Boolean; virtual;\r\n function HintShow(var HintInfo: THintInfo): Boolean; reintroduce; dynamic;\r\n function HitTest(X, Y: Integer): Boolean; reintroduce; virtual;\r\n procedure MouseEnter(AControl: TControl); reintroduce; dynamic;\r\n procedure MouseLeave(AControl: TControl); reintroduce; dynamic;\r\n property MouseOver: Boolean read FMouseOver write FMouseOver;\r\n property HintColor: TColor read FHintColor write FHintColor default clDefault;\r\n property OnMouseEnter: TNotifyEvent read FOnMouseEnter write FOnMouseEnter;\r\n property OnMouseLeave: TNotifyEvent read FOnMouseLeave write FOnMouseLeave;\r\n property OnParentColorChange: TNotifyEvent read FOnParentColorChanged write FOnParentColorChanged;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n property HintWindowClass: THintWindowClass read FHintWindowClass write FHintWindowClass;\r\n published\r\n property AboutJVCL: TJVCLAboutInfo read FAboutJVCL write FAboutJVCL stored False;\r\n end;\r\n\r\n TJvExHintWindow = class(THintWindow, IJvExControl)\r\n private\r\n FAboutJVCL: TJVCLAboutInfo;\r\n FHintColor: TColor;\r\n FMouseOver: Boolean;\r\n FHintWindowClass: THintWindowClass;\r\n FOnMouseEnter: TNotifyEvent;\r\n FOnMouseLeave: TNotifyEvent;\r\n FOnParentColorChanged: TNotifyEvent;\r\n function BaseWndProc(Msg: Cardinal; WParam: WPARAM = 0; LParam: LPARAM = 0): LRESULT; overload;\r\n function BaseWndProc(Msg: Cardinal; WParam: WPARAM; LParam: TObject): LRESULT; overload;\r\n function BaseWndProcEx(Msg: Cardinal; WParam: WPARAM; var StructLParam): LRESULT;\r\n protected\r\n procedure WndProc(var Msg: TMessage); override;\r\n procedure FocusChanged(AControl: TWinControl); dynamic;\r\n procedure VisibleChanged; reintroduce; dynamic;\r\n procedure EnabledChanged; reintroduce; dynamic;\r\n procedure TextChanged; reintroduce; virtual;\r\n procedure ColorChanged; reintroduce; dynamic;\r\n procedure FontChanged; reintroduce; dynamic;\r\n procedure ParentFontChanged; reintroduce; dynamic;\r\n procedure ParentColorChanged; reintroduce; dynamic;\r\n procedure ParentShowHintChanged; reintroduce; dynamic;\r\n function WantKey(Key: Integer; Shift: TShiftState): Boolean; virtual;\r\n function HintShow(var HintInfo: THintInfo): Boolean; reintroduce; dynamic;\r\n function HitTest(X, Y: Integer): Boolean; reintroduce; virtual;\r\n procedure MouseEnter(AControl: TControl); reintroduce; dynamic;\r\n procedure MouseLeave(AControl: TControl); reintroduce; dynamic;\r\n property MouseOver: Boolean read FMouseOver write FMouseOver;\r\n property HintColor: TColor read FHintColor write FHintColor default clDefault;\r\n property OnMouseEnter: TNotifyEvent read FOnMouseEnter write FOnMouseEnter;\r\n property OnMouseLeave: TNotifyEvent read FOnMouseLeave write FOnMouseLeave;\r\n property OnParentColorChange: TNotifyEvent read FOnParentColorChanged write FOnParentColorChanged;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n property HintWindowClass: THintWindowClass read FHintWindowClass write FHintWindowClass;\r\n published\r\n property AboutJVCL: TJVCLAboutInfo read FAboutJVCL write FAboutJVCL stored False;\r\n private\r\n FDotNetHighlighting: Boolean;\r\n protected\r\n procedure BoundsChanged; reintroduce; virtual;\r\n procedure CursorChanged; reintroduce; dynamic;\r\n procedure ShowingChanged; reintroduce; dynamic;\r\n procedure ShowHintChanged; reintroduce; dynamic;\r\n procedure ControlsListChanging(Control: TControl; Inserting: Boolean); reintroduce; dynamic;\r\n procedure ControlsListChanged(Control: TControl; Inserting: Boolean); reintroduce; dynamic;\r\n procedure GetDlgCode(var Code: TDlgCodes); virtual;\r\n procedure FocusSet(PrevWnd: THandle); virtual;\r\n procedure FocusKilled(NextWnd: THandle); virtual;\r\n function DoEraseBackground(Canvas: TCanvas; Param: LPARAM): Boolean; virtual;\r\n {$IFDEF JVCLThemesEnabledD6}\r\n private\r\n function GetParentBackground: Boolean;\r\n protected\r\n procedure SetParentBackground(Value: Boolean); virtual;\r\n property ParentBackground: Boolean read GetParentBackground write SetParentBackground;\r\n {$ENDIF JVCLThemesEnabledD6}\r\n published\r\n property DotNetHighlighting: Boolean read FDotNetHighlighting write FDotNetHighlighting default False;\r\n end;\r\n\r\n TJvExPubGraphicControl = class(TJvExGraphicControl)\r\n published\r\n property BiDiMode;\r\n property DragCursor;\r\n property DragKind;\r\n property DragMode;\r\n property ParentBiDiMode;\r\n property OnEndDock;\r\n property OnStartDock;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvExControls.pas $';\r\n Revision: '$Revision: 13173 $';\r\n Date: '$Date: 2011-11-19 13:43:58 +0100 (sam. 19 nov. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nvar\r\n InternalFocusedColor: TColor = TColor($00733800);\r\n InternalUnfocusedColor: TColor = clGray;\r\n\r\nprocedure SetDotNetFrameColors(FocusedColor, UnfocusedColor: TColor);\r\nbegin\r\n InternalFocusedColor := FocusedColor;\r\n InternalUnfocusedColor := UnfocusedColor;\r\nend;\r\n\r\nprocedure DrawDotNetControl(Control: TWinControl; AColor: TColor; InControl: Boolean);\r\nvar\r\n DC: HDC;\r\n R: TRect;\r\nbegin\r\n GetWindowRect(Control.Handle, R);\r\n OffsetRect(R, -R.Left, -R.Top);\r\n\r\n DC := GetWindowDC(Control.Handle);\r\n try\r\n DrawDotNetControl(DC, R, AColor, Control.Focused or InControl);\r\n finally\r\n ReleaseDC(Control.Handle, DC);\r\n end;\r\nend;\r\n\r\nprocedure DrawDotNetControl(DC: HDC; R: TRect; AColor: TColor; UseFocusedColor: Boolean);\r\nvar\r\n Brush: HBRUSH;\r\nbegin\r\n Brush := 0;\r\n try\r\n if UseFocusedColor then\r\n Brush := CreateSolidBrush(ColorToRGB(InternalFocusedColor))\r\n else\r\n Brush := CreateSolidBrush(ColorToRGB(InternalUnfocusedColor));\r\n\r\n FrameRect(DC, R, Brush);\r\n InflateRect(R, -1, -1);\r\n if not UseFocusedColor then\r\n begin\r\n DeleteObject(Brush);\r\n Brush := CreateSolidBrush(ColorToRGB(AColor));\r\n end;\r\n FrameRect(DC, R, Brush);\r\n finally\r\n if Brush <> 0 then\r\n DeleteObject(Brush);\r\n end;\r\nend;\r\n\r\nprocedure HandleDotNetHighlighting(Control: TWinControl; const Msg: TMessage;\r\n MouseOver: Boolean; Color: TColor);\r\nvar\r\n Rgn, SubRgn: HRGN;\r\nbegin\r\n if not (csDesigning in Control.ComponentState) then\r\n case Msg.Msg of\r\n CM_MOUSEENTER, CM_MOUSELEAVE, WM_KILLFOCUS, WM_SETFOCUS, WM_NCPAINT:\r\n begin\r\n DrawDotNetControl(Control, Color, MouseOver);\r\n if Msg.Msg = CM_MOUSELEAVE then\r\n begin\r\n Rgn := CreateRectRgn(0, 0, Control.Width - 1, Control.Height - 1);\r\n SubRgn := CreateRectRgn(2, 2, Control.Width - 3, Control.Height - 3);\r\n try\r\n CombineRgn(Rgn, Rgn, SubRgn, RGN_DIFF);\r\n InvalidateRgn(Control.Handle, Rgn, False); // redraw 3D border\r\n finally\r\n DeleteObject(SubRgn);\r\n DeleteObject(Rgn);\r\n end;\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure CreateWMMessage(var Mesg: TMessage; Msg: Cardinal; WParam: WPARAM; LParam: LPARAM);\r\nbegin\r\n Mesg.Msg := Msg;\r\n Mesg.WParam := WParam;\r\n Mesg.LParam := LParam;\r\n Mesg.Result := 0;\r\nend;\r\n\r\nfunction SmallPointToLong(const Pt: TSmallPoint): Longint;\r\nbegin\r\n Result := Longint(Pt);\r\nend;\r\n\r\nfunction ShiftStateToKeyData(Shift: TShiftState): Longint;\r\nconst\r\n AltMask = $20000000;\r\n CtrlMask = $10000000;\r\n ShiftMask = $08000000;\r\nbegin\r\n Result := 0;\r\n if ssAlt in Shift then\r\n Result := Result or AltMask;\r\n if ssCtrl in Shift then\r\n Result := Result or CtrlMask;\r\n if ssShift in Shift then\r\n Result := Result or ShiftMask;\r\nend;\r\n\r\nfunction GetFocusedControl(AControl: TControl): TWinControl;\r\nvar\r\n Form: TCustomForm;\r\nbegin\r\n Result := nil;\r\n Form := GetParentForm(AControl);\r\n if Assigned(Form) then\r\n Result := Form.ActiveControl;\r\nend;\r\n\r\nfunction DlgcToDlgCodes(Value: LPARAM): TDlgCodes;\r\nbegin\r\n Result := [];\r\n if (Value and DLGC_WANTARROWS) <> 0 then\r\n Include(Result, dcWantArrows);\r\n if (Value and DLGC_WANTTAB) <> 0 then\r\n Include(Result, dcWantTab);\r\n if (Value and DLGC_WANTALLKEYS) <> 0 then\r\n Include(Result, dcWantAllKeys);\r\n if (Value and DLGC_WANTCHARS) <> 0 then\r\n Include(Result, dcWantChars);\r\n if (Value and DLGC_BUTTON) <> 0 then\r\n Include(Result, dcButton);\r\n if (Value and DLGC_HASSETSEL) <> 0 then\r\n Include(Result, dcHasSetSel);\r\nend;\r\n\r\nfunction DlgCodesToDlgc(const Value: TDlgCodes): LPARAM;\r\nbegin\r\n Result := 0;\r\n if dcWantAllKeys in Value then\r\n Result := Result or DLGC_WANTALLKEYS;\r\n if dcWantArrows in Value then\r\n Result := Result or DLGC_WANTARROWS;\r\n if dcWantTab in Value then\r\n Result := Result or DLGC_WANTTAB;\r\n if dcWantChars in Value then\r\n Result := Result or DLGC_WANTCHARS;\r\n if dcButton in Value then\r\n Result := Result or DLGC_BUTTON;\r\n if dcHasSetSel in Value then\r\n Result := Result or DLGC_HASSETSEL;\r\nend;\r\n\r\nprocedure GetHintColor(var HintInfo: THintInfo; AControl: TControl; HintColor: TColor);\r\nvar\r\n AHintInfo: THintInfo;\r\nbegin\r\n case HintColor of\r\n clNone:\r\n HintInfo.HintColor := Application.HintColor;\r\n clDefault:\r\n begin\r\n if Assigned(AControl) and Assigned(AControl.Parent) then\r\n begin\r\n AHintInfo := HintInfo;\r\n AControl.Parent.Perform(CM_HINTSHOW, 0, LPARAM(@AHintInfo));\r\n HintInfo.HintColor := AHintInfo.HintColor;\r\n end;\r\n end;\r\n else\r\n HintInfo.HintColor := HintColor;\r\n end;\r\nend;\r\n\r\nfunction DispatchIsDesignMsg(Control: TControl; var Msg: TMessage): Boolean;\r\nvar\r\n Form: TCustomForm;\r\nbegin\r\n Result := False;\r\n case Msg.Msg of\r\n WM_SETFOCUS, WM_KILLFOCUS, WM_NCHITTEST,\r\n WM_MOUSEFIRST..WM_MOUSELAST,\r\n WM_KEYFIRST..WM_KEYLAST,\r\n WM_CANCELMODE:\r\n Exit; // These messages are handled in TWinControl.WndProc before IsDesignMsg() is called\r\n end;\r\n if (Control <> nil) and (csDesigning in Control.ComponentState) then\r\n begin\r\n Form := GetParentForm(Control);\r\n if (Form <> nil) and (Form.Designer <> nil) and Form.Designer.IsDesignMsg(Control, Msg) then\r\n Result := True;\r\n end;\r\nend;\r\n\r\nfunction IsDefaultEraseBackground(Method: TJvDoEraseBackgroundMethod; MethodPtr: Pointer): Boolean;\r\nbegin\r\n Result := TMethod(Method).Code = MethodPtr;\r\nend;\r\n\r\nconstructor TJvExControl.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FHintColor := clDefault;\r\nend;\r\n\r\nfunction TJvExControl.BaseWndProc(Msg: Cardinal; WParam: WPARAM = 0; LParam: LPARAM = 0): LRESULT;\r\nvar\r\n Mesg: TMessage;\r\nbegin\r\n CreateWMMessage(Mesg, Msg, WParam, LParam);\r\n inherited WndProc(Mesg);\r\n Result := Mesg.Result;\r\nend;\r\n\r\nfunction TJvExControl.BaseWndProc(Msg: Cardinal; WParam: WPARAM; LParam: TObject): LRESULT;\r\nbegin\r\n Result := BaseWndProc(Msg, WParam, Windows.LPARAM(LParam));\r\nend;\r\n\r\nfunction TJvExControl.BaseWndProcEx(Msg: Cardinal; WParam: WPARAM; var StructLParam): LRESULT;\r\nbegin\r\n Result := BaseWndProc(Msg, WParam, Windows.LPARAM(@StructLParam));\r\nend;\r\n\r\nprocedure TJvExControl.VisibleChanged;\r\nbegin\r\n BaseWndProc(CM_VISIBLECHANGED);\r\nend;\r\n\r\nprocedure TJvExControl.EnabledChanged;\r\nbegin\r\n BaseWndProc(CM_ENABLEDCHANGED);\r\nend;\r\n\r\nprocedure TJvExControl.TextChanged;\r\nbegin\r\n BaseWndProc(CM_TEXTCHANGED);\r\nend;\r\n\r\nprocedure TJvExControl.FontChanged;\r\nbegin\r\n BaseWndProc(CM_FONTCHANGED);\r\nend;\r\n\r\nprocedure TJvExControl.ColorChanged;\r\nbegin\r\n BaseWndProc(CM_COLORCHANGED);\r\nend;\r\n\r\nprocedure TJvExControl.ParentFontChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTFONTCHANGED);\r\nend;\r\n\r\nprocedure TJvExControl.ParentColorChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTCOLORCHANGED);\r\n if Assigned(OnParentColorChange) then\r\n OnParentColorChange(Self);\r\nend;\r\n\r\nprocedure TJvExControl.ParentShowHintChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTSHOWHINTCHANGED);\r\nend;\r\n\r\nfunction TJvExControl.WantKey(Key: Integer; Shift: TShiftState): Boolean;\r\nbegin\r\n Result := BaseWndProc(CM_DIALOGCHAR, Word(Key), ShiftStateToKeyData(Shift)) <> 0;\r\nend;\r\n\r\nfunction TJvExControl.HitTest(X, Y: Integer): Boolean;\r\nbegin\r\n Result := BaseWndProc(CM_HITTEST, 0, SmallPointToLong(PointToSmallPoint(Point(X, Y)))) <> 0;\r\nend;\r\n\r\nfunction TJvExControl.HintShow(var HintInfo: THintInfo): Boolean;\r\nbegin\r\n GetHintColor(HintInfo, Self, FHintColor);\r\n if FHintWindowClass <> nil then\r\n HintInfo.HintWindowClass := FHintWindowClass;\r\n Result := BaseWndProcEx(CM_HINTSHOW, 0, HintInfo) <> 0;\r\nend;\r\n\r\nprocedure TJvExControl.MouseEnter(AControl: TControl);\r\nbegin\r\n FMouseOver := True;\r\n if Assigned(FOnMouseEnter) then\r\n FOnMouseEnter(Self);\r\n BaseWndProc(CM_MOUSEENTER, 0, AControl);\r\nend;\r\n\r\nprocedure TJvExControl.MouseLeave(AControl: TControl);\r\nbegin\r\n FMouseOver := False;\r\n BaseWndProc(CM_MOUSELEAVE, 0, AControl);\r\n if Assigned(FOnMouseLeave) then\r\n FOnMouseLeave(Self);\r\nend;\r\n\r\nprocedure TJvExControl.FocusChanged(AControl: TWinControl);\r\nbegin\r\n BaseWndProc(CM_FOCUSCHANGED, 0, AControl);\r\nend;\r\n\r\nprocedure TJvExControl.WndProc(var Msg: TMessage);\r\nbegin\r\n if not DispatchIsDesignMsg(Self, Msg) then\r\n case Msg.Msg of\r\n CM_DENYSUBCLASSING:\r\n Msg.Result := LRESULT(Ord(GetInterfaceEntry(IJvDenySubClassing) <> nil));\r\n CM_DIALOGCHAR:\r\n with TCMDialogChar{$IFDEF CLR}.Create{$ENDIF}(Msg) do\r\n Result := LRESULT(Ord(WantKey(CharCode, KeyDataToShiftState(KeyData))));\r\n CM_HINTSHOW:\r\n with TCMHintShow(Msg) do\r\n Result := LRESULT(HintShow(HintInfo^));\r\n CM_HITTEST:\r\n with TCMHitTest(Msg) do\r\n Result := LRESULT(HitTest(XPos, YPos));\r\n CM_MOUSEENTER:\r\n MouseEnter(TControl(Msg.LParam));\r\n CM_MOUSELEAVE:\r\n MouseLeave(TControl(Msg.LParam));\r\n CM_VISIBLECHANGED:\r\n VisibleChanged;\r\n CM_ENABLEDCHANGED:\r\n EnabledChanged;\r\n CM_TEXTCHANGED:\r\n TextChanged;\r\n CM_FONTCHANGED:\r\n FontChanged;\r\n CM_COLORCHANGED:\r\n ColorChanged;\r\n CM_FOCUSCHANGED:\r\n FocusChanged(TWinControl(Msg.LParam));\r\n CM_PARENTFONTCHANGED:\r\n ParentFontChanged;\r\n CM_PARENTCOLORCHANGED:\r\n ParentColorChanged;\r\n CM_PARENTSHOWHINTCHANGED:\r\n ParentShowHintChanged;\r\n else\r\n inherited WndProc(Msg);\r\n end;\r\nend;\r\n\r\n//============================================================================\r\n\r\nconstructor TJvExWinControl.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FHintColor := clDefault;\r\nend;\r\n\r\nfunction TJvExWinControl.BaseWndProc(Msg: Cardinal; WParam: WPARAM = 0; LParam: LPARAM = 0): LRESULT;\r\nvar\r\n Mesg: TMessage;\r\nbegin\r\n CreateWMMessage(Mesg, Msg, WParam, LParam);\r\n inherited WndProc(Mesg);\r\n Result := Mesg.Result;\r\nend;\r\n\r\nfunction TJvExWinControl.BaseWndProc(Msg: Cardinal; WParam: WPARAM; LParam: TObject): LRESULT;\r\nbegin\r\n Result := BaseWndProc(Msg, WParam, Windows.LPARAM(LParam));\r\nend;\r\n\r\nfunction TJvExWinControl.BaseWndProcEx(Msg: Cardinal; WParam: WPARAM; var StructLParam): LRESULT;\r\nbegin\r\n Result := BaseWndProc(Msg, WParam, Windows.LPARAM(@StructLParam));\r\nend;\r\n\r\nprocedure TJvExWinControl.VisibleChanged;\r\nbegin\r\n BaseWndProc(CM_VISIBLECHANGED);\r\nend;\r\n\r\nprocedure TJvExWinControl.EnabledChanged;\r\nbegin\r\n BaseWndProc(CM_ENABLEDCHANGED);\r\nend;\r\n\r\nprocedure TJvExWinControl.TextChanged;\r\nbegin\r\n BaseWndProc(CM_TEXTCHANGED);\r\nend;\r\n\r\nprocedure TJvExWinControl.FontChanged;\r\nbegin\r\n BaseWndProc(CM_FONTCHANGED);\r\nend;\r\n\r\nprocedure TJvExWinControl.ColorChanged;\r\nbegin\r\n BaseWndProc(CM_COLORCHANGED);\r\nend;\r\n\r\nprocedure TJvExWinControl.ParentFontChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTFONTCHANGED);\r\nend;\r\n\r\nprocedure TJvExWinControl.ParentColorChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTCOLORCHANGED);\r\n if Assigned(OnParentColorChange) then\r\n OnParentColorChange(Self);\r\nend;\r\n\r\nprocedure TJvExWinControl.ParentShowHintChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTSHOWHINTCHANGED);\r\nend;\r\n\r\nfunction TJvExWinControl.WantKey(Key: Integer; Shift: TShiftState): Boolean;\r\nbegin\r\n Result := BaseWndProc(CM_DIALOGCHAR, Word(Key), ShiftStateToKeyData(Shift)) <> 0;\r\nend;\r\n\r\nfunction TJvExWinControl.HitTest(X, Y: Integer): Boolean;\r\nbegin\r\n Result := BaseWndProc(CM_HITTEST, 0, SmallPointToLong(PointToSmallPoint(Point(X, Y)))) <> 0;\r\nend;\r\n\r\nfunction TJvExWinControl.HintShow(var HintInfo: THintInfo): Boolean;\r\nbegin\r\n GetHintColor(HintInfo, Self, FHintColor);\r\n if FHintWindowClass <> nil then\r\n HintInfo.HintWindowClass := FHintWindowClass;\r\n Result := BaseWndProcEx(CM_HINTSHOW, 0, HintInfo) <> 0;\r\nend;\r\n\r\nprocedure TJvExWinControl.MouseEnter(AControl: TControl);\r\nbegin\r\n FMouseOver := True;\r\n if Assigned(FOnMouseEnter) then\r\n FOnMouseEnter(Self);\r\n BaseWndProc(CM_MOUSEENTER, 0, AControl);\r\nend;\r\n\r\nprocedure TJvExWinControl.MouseLeave(AControl: TControl);\r\nbegin\r\n FMouseOver := False;\r\n BaseWndProc(CM_MOUSELEAVE, 0, AControl);\r\n if Assigned(FOnMouseLeave) then\r\n FOnMouseLeave(Self);\r\nend;\r\n\r\nprocedure TJvExWinControl.FocusChanged(AControl: TWinControl);\r\nbegin\r\n BaseWndProc(CM_FOCUSCHANGED, 0, AControl);\r\nend;\r\n\r\nprocedure TJvExWinControl.BoundsChanged;\r\nbegin\r\nend;\r\n\r\nprocedure TJvExWinControl.CursorChanged;\r\nbegin\r\n BaseWndProc(CM_CURSORCHANGED);\r\nend;\r\n\r\nprocedure TJvExWinControl.ShowingChanged;\r\nbegin\r\n BaseWndProc(CM_SHOWINGCHANGED);\r\nend;\r\n\r\nprocedure TJvExWinControl.ShowHintChanged;\r\nbegin\r\n BaseWndProc(CM_SHOWHINTCHANGED);\r\nend;\r\n\r\n{ VCL sends CM_CONTROLLISTCHANGE and CM_CONTROLCHANGE in a different order than\r\n the CLX methods are used. So we must correct it by evaluating \"Inserting\". }\r\nprocedure TJvExWinControl.ControlsListChanging(Control: TControl; Inserting: Boolean);\r\nbegin\r\n if Inserting then\r\n BaseWndProc(CM_CONTROLLISTCHANGE, WPARAM(Control), LPARAM(Inserting))\r\n else\r\n BaseWndProc(CM_CONTROLCHANGE, WPARAM(Control), LPARAM(Inserting));\r\nend;\r\n\r\nprocedure TJvExWinControl.ControlsListChanged(Control: TControl; Inserting: Boolean);\r\nbegin\r\n if not Inserting then\r\n BaseWndProc(CM_CONTROLLISTCHANGE, WPARAM(Control), LPARAM(Inserting))\r\n else\r\n BaseWndProc(CM_CONTROLCHANGE, WPARAM(Control), LPARAM(Inserting));\r\nend;\r\n\r\nprocedure TJvExWinControl.GetDlgCode(var Code: TDlgCodes);\r\nbegin\r\nend;\r\n\r\nprocedure TJvExWinControl.FocusSet(PrevWnd: THandle);\r\nbegin\r\n BaseWndProc(WM_SETFOCUS, WPARAM(PrevWnd), 0);\r\nend;\r\n\r\nprocedure TJvExWinControl.FocusKilled(NextWnd: THandle);\r\nbegin\r\n BaseWndProc(WM_KILLFOCUS, WPARAM(NextWnd), 0);\r\nend;\r\n\r\nfunction TJvExWinControl.DoEraseBackground(Canvas: TCanvas; Param: LPARAM): Boolean;\r\nbegin\r\n Result := BaseWndProc(WM_ERASEBKGND, Canvas.Handle, Param) <> 0;\r\nend;\r\n\r\n{$IFDEF JVCLThemesEnabledD6}\r\nfunction TJvExWinControl.GetParentBackground: Boolean;\r\nbegin\r\n Result := JvThemes.GetParentBackground(Self);\r\nend;\r\n\r\nprocedure TJvExWinControl.SetParentBackground(Value: Boolean);\r\nbegin\r\n JvThemes.SetParentBackground(Self, Value);\r\nend;\r\n{$ENDIF JVCLThemesEnabledD6}\r\n\r\nprocedure TJvExWinControl.WndProc(var Msg: TMessage);\r\nvar\r\n IdSaveDC: Integer;\r\n DlgCodes: TDlgCodes;\r\n Canvas: TCanvas;\r\nbegin\r\n if not DispatchIsDesignMsg(Self, Msg) then\r\n begin\r\n case Msg.Msg of\r\n CM_DENYSUBCLASSING:\r\n Msg.Result := LRESULT(Ord(GetInterfaceEntry(IJvDenySubClassing) <> nil));\r\n CM_DIALOGCHAR:\r\n with TCMDialogChar{$IFDEF CLR}.Create{$ENDIF}(Msg) do\r\n Result := LRESULT(Ord(WantKey(CharCode, KeyDataToShiftState(KeyData))));\r\n CM_HINTSHOW:\r\n with TCMHintShow(Msg) do\r\n Result := LRESULT(HintShow(HintInfo^));\r\n CM_HITTEST:\r\n with TCMHitTest(Msg) do\r\n Result := LRESULT(HitTest(XPos, YPos));\r\n CM_MOUSEENTER:\r\n MouseEnter(TControl(Msg.LParam));\r\n CM_MOUSELEAVE:\r\n MouseLeave(TControl(Msg.LParam));\r\n CM_VISIBLECHANGED:\r\n VisibleChanged;\r\n CM_ENABLEDCHANGED:\r\n EnabledChanged;\r\n CM_TEXTCHANGED:\r\n TextChanged;\r\n CM_FONTCHANGED:\r\n FontChanged;\r\n CM_COLORCHANGED:\r\n ColorChanged;\r\n CM_FOCUSCHANGED:\r\n FocusChanged(TWinControl(Msg.LParam));\r\n CM_PARENTFONTCHANGED:\r\n ParentFontChanged;\r\n CM_PARENTCOLORCHANGED:\r\n ParentColorChanged;\r\n CM_PARENTSHOWHINTCHANGED:\r\n ParentShowHintChanged;\r\n CM_CURSORCHANGED:\r\n CursorChanged;\r\n CM_SHOWINGCHANGED:\r\n ShowingChanged;\r\n CM_SHOWHINTCHANGED:\r\n ShowHintChanged;\r\n CM_CONTROLLISTCHANGE:\r\n if Msg.LParam <> 0 then\r\n ControlsListChanging(TControl(Msg.WParam), True)\r\n else\r\n ControlsListChanged(TControl(Msg.WParam), False);\r\n CM_CONTROLCHANGE:\r\n if Msg.LParam = 0 then\r\n ControlsListChanging(TControl(Msg.WParam), False)\r\n else\r\n ControlsListChanged(TControl(Msg.WParam), True);\r\n WM_SETFOCUS:\r\n FocusSet(THandle(Msg.WParam));\r\n WM_KILLFOCUS:\r\n FocusKilled(THandle(Msg.WParam));\r\n WM_SIZE, WM_MOVE:\r\n begin\r\n inherited WndProc(Msg);\r\n BoundsChanged;\r\n end;\r\n WM_ERASEBKGND:\r\n if (Msg.WParam <> 0) and not IsDefaultEraseBackground(DoEraseBackground, @TJvExWinControl.DoEraseBackground) then\r\n begin\r\n IdSaveDC := SaveDC(HDC(Msg.WParam)); // protect DC against Stock-Objects from Canvas\r\n Canvas := TCanvas.Create;\r\n try\r\n Canvas.Handle := HDC(Msg.WParam);\r\n Msg.Result := Ord(DoEraseBackground(Canvas, Msg.LParam));\r\n finally\r\n Canvas.Handle := 0;\r\n Canvas.Free;\r\n RestoreDC(HDC(Msg.WParam), IdSaveDC);\r\n end;\r\n end\r\n else\r\n inherited WndProc(Msg);\r\n {$IFNDEF DELPHI2007_UP}\r\n WM_PRINTCLIENT, WM_PRINT: // VCL bug fix\r\n begin\r\n IdSaveDC := SaveDC(HDC(Msg.WParam)); // protect DC against changes\r\n try\r\n inherited WndProc(Msg);\r\n finally\r\n RestoreDC(HDC(Msg.WParam), IdSaveDC);\r\n end;\r\n end;\r\n {$ENDIF ~DELPHI2007_UP}\r\n WM_GETDLGCODE:\r\n begin\r\n inherited WndProc(Msg);\r\n DlgCodes := [dcNative] + DlgcToDlgCodes(Msg.Result);\r\n GetDlgCode(DlgCodes);\r\n if not (dcNative in DlgCodes) then\r\n Msg.Result := DlgCodesToDlgc(DlgCodes);\r\n end;\r\n else\r\n inherited WndProc(Msg);\r\n end;\r\n case Msg.Msg of // precheck message to prevent access violations on released controls\r\n CM_MOUSEENTER, CM_MOUSELEAVE, WM_KILLFOCUS, WM_SETFOCUS, WM_NCPAINT:\r\n if DotNetHighlighting then\r\n HandleDotNetHighlighting(Self, Msg, MouseOver, Color);\r\n end;\r\n end;\r\nend;\r\n\r\n//============================================================================\r\n\r\nconstructor TJvExGraphicControl.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FHintColor := clDefault;\r\nend;\r\n\r\nfunction TJvExGraphicControl.BaseWndProc(Msg: Cardinal; WParam: WPARAM = 0; LParam: LPARAM = 0): LRESULT;\r\nvar\r\n Mesg: TMessage;\r\nbegin\r\n CreateWMMessage(Mesg, Msg, WParam, LParam);\r\n inherited WndProc(Mesg);\r\n Result := Mesg.Result;\r\nend;\r\n\r\nfunction TJvExGraphicControl.BaseWndProc(Msg: Cardinal; WParam: WPARAM; LParam: TObject): LRESULT;\r\nbegin\r\n Result := BaseWndProc(Msg, WParam, Windows.LPARAM(LParam));\r\nend;\r\n\r\nfunction TJvExGraphicControl.BaseWndProcEx(Msg: Cardinal; WParam: WPARAM; var StructLParam): LRESULT;\r\nbegin\r\n Result := BaseWndProc(Msg, WParam, Windows.LPARAM(@StructLParam));\r\nend;\r\n\r\nprocedure TJvExGraphicControl.VisibleChanged;\r\nbegin\r\n BaseWndProc(CM_VISIBLECHANGED);\r\nend;\r\n\r\nprocedure TJvExGraphicControl.EnabledChanged;\r\nbegin\r\n BaseWndProc(CM_ENABLEDCHANGED);\r\nend;\r\n\r\nprocedure TJvExGraphicControl.TextChanged;\r\nbegin\r\n BaseWndProc(CM_TEXTCHANGED);\r\nend;\r\n\r\nprocedure TJvExGraphicControl.FontChanged;\r\nbegin\r\n BaseWndProc(CM_FONTCHANGED);\r\nend;\r\n\r\nprocedure TJvExGraphicControl.ColorChanged;\r\nbegin\r\n BaseWndProc(CM_COLORCHANGED);\r\nend;\r\n\r\nprocedure TJvExGraphicControl.ParentFontChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTFONTCHANGED);\r\nend;\r\n\r\nprocedure TJvExGraphicControl.ParentColorChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTCOLORCHANGED);\r\n if Assigned(OnParentColorChange) then\r\n OnParentColorChange(Self);\r\nend;\r\n\r\nprocedure TJvExGraphicControl.ParentShowHintChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTSHOWHINTCHANGED);\r\nend;\r\n\r\nfunction TJvExGraphicControl.WantKey(Key: Integer; Shift: TShiftState): Boolean;\r\nbegin\r\n Result := BaseWndProc(CM_DIALOGCHAR, Word(Key), ShiftStateToKeyData(Shift)) <> 0;\r\nend;\r\n\r\nfunction TJvExGraphicControl.HitTest(X, Y: Integer): Boolean;\r\nbegin\r\n Result := BaseWndProc(CM_HITTEST, 0, SmallPointToLong(PointToSmallPoint(Point(X, Y)))) <> 0;\r\nend;\r\n\r\nfunction TJvExGraphicControl.HintShow(var HintInfo: THintInfo): Boolean;\r\nbegin\r\n GetHintColor(HintInfo, Self, FHintColor);\r\n if FHintWindowClass <> nil then\r\n HintInfo.HintWindowClass := FHintWindowClass;\r\n Result := BaseWndProcEx(CM_HINTSHOW, 0, HintInfo) <> 0;\r\nend;\r\n\r\nprocedure TJvExGraphicControl.MouseEnter(AControl: TControl);\r\nbegin\r\n FMouseOver := True;\r\n if Assigned(FOnMouseEnter) then\r\n FOnMouseEnter(Self);\r\n BaseWndProc(CM_MOUSEENTER, 0, AControl);\r\nend;\r\n\r\nprocedure TJvExGraphicControl.MouseLeave(AControl: TControl);\r\nbegin\r\n FMouseOver := False;\r\n BaseWndProc(CM_MOUSELEAVE, 0, AControl);\r\n if Assigned(FOnMouseLeave) then\r\n FOnMouseLeave(Self);\r\nend;\r\n\r\nprocedure TJvExGraphicControl.FocusChanged(AControl: TWinControl);\r\nbegin\r\n BaseWndProc(CM_FOCUSCHANGED, 0, AControl);\r\nend;\r\n\r\nprocedure TJvExGraphicControl.WndProc(var Msg: TMessage);\r\nbegin\r\n if not DispatchIsDesignMsg(Self, Msg) then\r\n case Msg.Msg of\r\n CM_DENYSUBCLASSING:\r\n Msg.Result := LRESULT(Ord(GetInterfaceEntry(IJvDenySubClassing) <> nil));\r\n CM_DIALOGCHAR:\r\n with TCMDialogChar{$IFDEF CLR}.Create{$ENDIF}(Msg) do\r\n Result := LRESULT(Ord(WantKey(CharCode, KeyDataToShiftState(KeyData))));\r\n CM_HINTSHOW:\r\n with TCMHintShow(Msg) do\r\n Result := LRESULT(HintShow(HintInfo^));\r\n CM_HITTEST:\r\n with TCMHitTest(Msg) do\r\n Result := LRESULT(HitTest(XPos, YPos));\r\n CM_MOUSEENTER:\r\n MouseEnter(TControl(Msg.LParam));\r\n CM_MOUSELEAVE:\r\n MouseLeave(TControl(Msg.LParam));\r\n CM_VISIBLECHANGED:\r\n VisibleChanged;\r\n CM_ENABLEDCHANGED:\r\n EnabledChanged;\r\n CM_TEXTCHANGED:\r\n TextChanged;\r\n CM_FONTCHANGED:\r\n FontChanged;\r\n CM_COLORCHANGED:\r\n ColorChanged;\r\n CM_FOCUSCHANGED:\r\n FocusChanged(TWinControl(Msg.LParam));\r\n CM_PARENTFONTCHANGED:\r\n ParentFontChanged;\r\n CM_PARENTCOLORCHANGED:\r\n ParentColorChanged;\r\n CM_PARENTSHOWHINTCHANGED:\r\n ParentShowHintChanged;\r\n else\r\n inherited WndProc(Msg);\r\n end;\r\nend;\r\n\r\n//============================================================================\r\n\r\nconstructor TJvExCustomControl.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FHintColor := clDefault;\r\nend;\r\n\r\nfunction TJvExCustomControl.BaseWndProc(Msg: Cardinal; WParam: WPARAM = 0; LParam: LPARAM = 0): LRESULT;\r\nvar\r\n Mesg: TMessage;\r\nbegin\r\n CreateWMMessage(Mesg, Msg, WParam, LParam);\r\n inherited WndProc(Mesg);\r\n Result := Mesg.Result;\r\nend;\r\n\r\nfunction TJvExCustomControl.BaseWndProc(Msg: Cardinal; WParam: WPARAM; LParam: TObject): LRESULT;\r\nbegin\r\n Result := BaseWndProc(Msg, WParam, Windows.LPARAM(LParam));\r\nend;\r\n\r\nfunction TJvExCustomControl.BaseWndProcEx(Msg: Cardinal; WParam: WPARAM; var StructLParam): LRESULT;\r\nbegin\r\n Result := BaseWndProc(Msg, WParam, Windows.LPARAM(@StructLParam));\r\nend;\r\n\r\nprocedure TJvExCustomControl.VisibleChanged;\r\nbegin\r\n BaseWndProc(CM_VISIBLECHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomControl.EnabledChanged;\r\nbegin\r\n BaseWndProc(CM_ENABLEDCHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomControl.TextChanged;\r\nbegin\r\n BaseWndProc(CM_TEXTCHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomControl.FontChanged;\r\nbegin\r\n BaseWndProc(CM_FONTCHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomControl.ColorChanged;\r\nbegin\r\n BaseWndProc(CM_COLORCHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomControl.ParentFontChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTFONTCHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomControl.ParentColorChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTCOLORCHANGED);\r\n if Assigned(OnParentColorChange) then\r\n OnParentColorChange(Self);\r\nend;\r\n\r\nprocedure TJvExCustomControl.ParentShowHintChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTSHOWHINTCHANGED);\r\nend;\r\n\r\nfunction TJvExCustomControl.WantKey(Key: Integer; Shift: TShiftState): Boolean;\r\nbegin\r\n Result := BaseWndProc(CM_DIALOGCHAR, Word(Key), ShiftStateToKeyData(Shift)) <> 0;\r\nend;\r\n\r\nfunction TJvExCustomControl.HitTest(X, Y: Integer): Boolean;\r\nbegin\r\n Result := BaseWndProc(CM_HITTEST, 0, SmallPointToLong(PointToSmallPoint(Point(X, Y)))) <> 0;\r\nend;\r\n\r\nfunction TJvExCustomControl.HintShow(var HintInfo: THintInfo): Boolean;\r\nbegin\r\n GetHintColor(HintInfo, Self, FHintColor);\r\n if FHintWindowClass <> nil then\r\n HintInfo.HintWindowClass := FHintWindowClass;\r\n Result := BaseWndProcEx(CM_HINTSHOW, 0, HintInfo) <> 0;\r\nend;\r\n\r\nprocedure TJvExCustomControl.MouseEnter(AControl: TControl);\r\nbegin\r\n FMouseOver := True;\r\n if Assigned(FOnMouseEnter) then\r\n FOnMouseEnter(Self);\r\n BaseWndProc(CM_MOUSEENTER, 0, AControl);\r\nend;\r\n\r\nprocedure TJvExCustomControl.MouseLeave(AControl: TControl);\r\nbegin\r\n FMouseOver := False;\r\n BaseWndProc(CM_MOUSELEAVE, 0, AControl);\r\n if Assigned(FOnMouseLeave) then\r\n FOnMouseLeave(Self);\r\nend;\r\n\r\nprocedure TJvExCustomControl.FocusChanged(AControl: TWinControl);\r\nbegin\r\n BaseWndProc(CM_FOCUSCHANGED, 0, AControl);\r\nend;\r\n\r\nprocedure TJvExCustomControl.BoundsChanged;\r\nbegin\r\nend;\r\n\r\nprocedure TJvExCustomControl.CursorChanged;\r\nbegin\r\n BaseWndProc(CM_CURSORCHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomControl.ShowingChanged;\r\nbegin\r\n BaseWndProc(CM_SHOWINGCHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomControl.ShowHintChanged;\r\nbegin\r\n BaseWndProc(CM_SHOWHINTCHANGED);\r\nend;\r\n\r\n{ VCL sends CM_CONTROLLISTCHANGE and CM_CONTROLCHANGE in a different order than\r\n the CLX methods are used. So we must correct it by evaluating \"Inserting\". }\r\nprocedure TJvExCustomControl.ControlsListChanging(Control: TControl; Inserting: Boolean);\r\nbegin\r\n if Inserting then\r\n BaseWndProc(CM_CONTROLLISTCHANGE, WPARAM(Control), LPARAM(Inserting))\r\n else\r\n BaseWndProc(CM_CONTROLCHANGE, WPARAM(Control), LPARAM(Inserting));\r\nend;\r\n\r\nprocedure TJvExCustomControl.ControlsListChanged(Control: TControl; Inserting: Boolean);\r\nbegin\r\n if not Inserting then\r\n BaseWndProc(CM_CONTROLLISTCHANGE, WPARAM(Control), LPARAM(Inserting))\r\n else\r\n BaseWndProc(CM_CONTROLCHANGE, WPARAM(Control), LPARAM(Inserting));\r\nend;\r\n\r\nprocedure TJvExCustomControl.GetDlgCode(var Code: TDlgCodes);\r\nbegin\r\nend;\r\n\r\nprocedure TJvExCustomControl.FocusSet(PrevWnd: THandle);\r\nbegin\r\n BaseWndProc(WM_SETFOCUS, WPARAM(PrevWnd), 0);\r\nend;\r\n\r\nprocedure TJvExCustomControl.FocusKilled(NextWnd: THandle);\r\nbegin\r\n BaseWndProc(WM_KILLFOCUS, WPARAM(NextWnd), 0);\r\nend;\r\n\r\nfunction TJvExCustomControl.DoEraseBackground(Canvas: TCanvas; Param: LPARAM): Boolean;\r\nbegin\r\n Result := BaseWndProc(WM_ERASEBKGND, Canvas.Handle, Param) <> 0;\r\nend;\r\n\r\n{$IFDEF JVCLThemesEnabledD6}\r\nfunction TJvExCustomControl.GetParentBackground: Boolean;\r\nbegin\r\n Result := JvThemes.GetParentBackground(Self);\r\nend;\r\n\r\nprocedure TJvExCustomControl.SetParentBackground(Value: Boolean);\r\nbegin\r\n JvThemes.SetParentBackground(Self, Value);\r\nend;\r\n{$ENDIF JVCLThemesEnabledD6}\r\n\r\nprocedure TJvExCustomControl.WndProc(var Msg: TMessage);\r\nvar\r\n IdSaveDC: Integer;\r\n DlgCodes: TDlgCodes;\r\n Canvas: TCanvas;\r\nbegin\r\n if not DispatchIsDesignMsg(Self, Msg) then\r\n begin\r\n case Msg.Msg of\r\n CM_DENYSUBCLASSING:\r\n Msg.Result := LRESULT(Ord(GetInterfaceEntry(IJvDenySubClassing) <> nil));\r\n CM_DIALOGCHAR:\r\n with TCMDialogChar{$IFDEF CLR}.Create{$ENDIF}(Msg) do\r\n Result := LRESULT(Ord(WantKey(CharCode, KeyDataToShiftState(KeyData))));\r\n CM_HINTSHOW:\r\n with TCMHintShow(Msg) do\r\n Result := LRESULT(HintShow(HintInfo^));\r\n CM_HITTEST:\r\n with TCMHitTest(Msg) do\r\n Result := LRESULT(HitTest(XPos, YPos));\r\n CM_MOUSEENTER:\r\n MouseEnter(TControl(Msg.LParam));\r\n CM_MOUSELEAVE:\r\n MouseLeave(TControl(Msg.LParam));\r\n CM_VISIBLECHANGED:\r\n VisibleChanged;\r\n CM_ENABLEDCHANGED:\r\n EnabledChanged;\r\n CM_TEXTCHANGED:\r\n TextChanged;\r\n CM_FONTCHANGED:\r\n FontChanged;\r\n CM_COLORCHANGED:\r\n ColorChanged;\r\n CM_FOCUSCHANGED:\r\n FocusChanged(TWinControl(Msg.LParam));\r\n CM_PARENTFONTCHANGED:\r\n ParentFontChanged;\r\n CM_PARENTCOLORCHANGED:\r\n ParentColorChanged;\r\n CM_PARENTSHOWHINTCHANGED:\r\n ParentShowHintChanged;\r\n CM_CURSORCHANGED:\r\n CursorChanged;\r\n CM_SHOWINGCHANGED:\r\n ShowingChanged;\r\n CM_SHOWHINTCHANGED:\r\n ShowHintChanged;\r\n CM_CONTROLLISTCHANGE:\r\n if Msg.LParam <> 0 then\r\n ControlsListChanging(TControl(Msg.WParam), True)\r\n else\r\n ControlsListChanged(TControl(Msg.WParam), False);\r\n CM_CONTROLCHANGE:\r\n if Msg.LParam = 0 then\r\n ControlsListChanging(TControl(Msg.WParam), False)\r\n else\r\n ControlsListChanged(TControl(Msg.WParam), True);\r\n WM_SETFOCUS:\r\n FocusSet(THandle(Msg.WParam));\r\n WM_KILLFOCUS:\r\n FocusKilled(THandle(Msg.WParam));\r\n WM_SIZE, WM_MOVE:\r\n begin\r\n inherited WndProc(Msg);\r\n BoundsChanged;\r\n end;\r\n WM_ERASEBKGND:\r\n if (Msg.WParam <> 0) and not IsDefaultEraseBackground(DoEraseBackground, @TJvExCustomControl.DoEraseBackground) then\r\n begin\r\n IdSaveDC := SaveDC(HDC(Msg.WParam)); // protect DC against Stock-Objects from Canvas\r\n Canvas := TCanvas.Create;\r\n try\r\n Canvas.Handle := HDC(Msg.WParam);\r\n Msg.Result := Ord(DoEraseBackground(Canvas, Msg.LParam));\r\n finally\r\n Canvas.Handle := 0;\r\n Canvas.Free;\r\n RestoreDC(HDC(Msg.WParam), IdSaveDC);\r\n end;\r\n end\r\n else\r\n inherited WndProc(Msg);\r\n {$IFNDEF DELPHI2007_UP}\r\n WM_PRINTCLIENT, WM_PRINT: // VCL bug fix\r\n begin\r\n IdSaveDC := SaveDC(HDC(Msg.WParam)); // protect DC against changes\r\n try\r\n inherited WndProc(Msg);\r\n finally\r\n RestoreDC(HDC(Msg.WParam), IdSaveDC);\r\n end;\r\n end;\r\n {$ENDIF ~DELPHI2007_UP}\r\n WM_GETDLGCODE:\r\n begin\r\n inherited WndProc(Msg);\r\n DlgCodes := [dcNative] + DlgcToDlgCodes(Msg.Result);\r\n GetDlgCode(DlgCodes);\r\n if not (dcNative in DlgCodes) then\r\n Msg.Result := DlgCodesToDlgc(DlgCodes);\r\n end;\r\n else\r\n inherited WndProc(Msg);\r\n end;\r\n case Msg.Msg of // precheck message to prevent access violations on released controls\r\n CM_MOUSEENTER, CM_MOUSELEAVE, WM_KILLFOCUS, WM_SETFOCUS, WM_NCPAINT:\r\n if DotNetHighlighting then\r\n HandleDotNetHighlighting(Self, Msg, MouseOver, Color);\r\n end;\r\n end;\r\nend;\r\n\r\n//============================================================================\r\n\r\nconstructor TJvExHintWindow.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FHintColor := clDefault;\r\nend;\r\n\r\nfunction TJvExHintWindow.BaseWndProc(Msg: Cardinal; WParam: WPARAM = 0; LParam: LPARAM = 0): LRESULT;\r\nvar\r\n Mesg: TMessage;\r\nbegin\r\n CreateWMMessage(Mesg, Msg, WParam, LParam);\r\n inherited WndProc(Mesg);\r\n Result := Mesg.Result;\r\nend;\r\n\r\nfunction TJvExHintWindow.BaseWndProc(Msg: Cardinal; WParam: WPARAM; LParam: TObject): LRESULT;\r\nbegin\r\n Result := BaseWndProc(Msg, WParam, Windows.LPARAM(LParam));\r\nend;\r\n\r\nfunction TJvExHintWindow.BaseWndProcEx(Msg: Cardinal; WParam: WPARAM; var StructLParam): LRESULT;\r\nbegin\r\n Result := BaseWndProc(Msg, WParam, Windows.LPARAM(@StructLParam));\r\nend;\r\n\r\nprocedure TJvExHintWindow.VisibleChanged;\r\nbegin\r\n BaseWndProc(CM_VISIBLECHANGED);\r\nend;\r\n\r\nprocedure TJvExHintWindow.EnabledChanged;\r\nbegin\r\n BaseWndProc(CM_ENABLEDCHANGED);\r\nend;\r\n\r\nprocedure TJvExHintWindow.TextChanged;\r\nbegin\r\n BaseWndProc(CM_TEXTCHANGED);\r\nend;\r\n\r\nprocedure TJvExHintWindow.FontChanged;\r\nbegin\r\n BaseWndProc(CM_FONTCHANGED);\r\nend;\r\n\r\nprocedure TJvExHintWindow.ColorChanged;\r\nbegin\r\n BaseWndProc(CM_COLORCHANGED);\r\nend;\r\n\r\nprocedure TJvExHintWindow.ParentFontChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTFONTCHANGED);\r\nend;\r\n\r\nprocedure TJvExHintWindow.ParentColorChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTCOLORCHANGED);\r\n if Assigned(OnParentColorChange) then\r\n OnParentColorChange(Self);\r\nend;\r\n\r\nprocedure TJvExHintWindow.ParentShowHintChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTSHOWHINTCHANGED);\r\nend;\r\n\r\nfunction TJvExHintWindow.WantKey(Key: Integer; Shift: TShiftState): Boolean;\r\nbegin\r\n Result := BaseWndProc(CM_DIALOGCHAR, Word(Key), ShiftStateToKeyData(Shift)) <> 0;\r\nend;\r\n\r\nfunction TJvExHintWindow.HitTest(X, Y: Integer): Boolean;\r\nbegin\r\n Result := BaseWndProc(CM_HITTEST, 0, SmallPointToLong(PointToSmallPoint(Point(X, Y)))) <> 0;\r\nend;\r\n\r\nfunction TJvExHintWindow.HintShow(var HintInfo: THintInfo): Boolean;\r\nbegin\r\n GetHintColor(HintInfo, Self, FHintColor);\r\n if FHintWindowClass <> nil then\r\n HintInfo.HintWindowClass := FHintWindowClass;\r\n Result := BaseWndProcEx(CM_HINTSHOW, 0, HintInfo) <> 0;\r\nend;\r\n\r\nprocedure TJvExHintWindow.MouseEnter(AControl: TControl);\r\nbegin\r\n FMouseOver := True;\r\n if Assigned(FOnMouseEnter) then\r\n FOnMouseEnter(Self);\r\n BaseWndProc(CM_MOUSEENTER, 0, AControl);\r\nend;\r\n\r\nprocedure TJvExHintWindow.MouseLeave(AControl: TControl);\r\nbegin\r\n FMouseOver := False;\r\n BaseWndProc(CM_MOUSELEAVE, 0, AControl);\r\n if Assigned(FOnMouseLeave) then\r\n FOnMouseLeave(Self);\r\nend;\r\n\r\nprocedure TJvExHintWindow.FocusChanged(AControl: TWinControl);\r\nbegin\r\n BaseWndProc(CM_FOCUSCHANGED, 0, AControl);\r\nend;\r\n\r\nprocedure TJvExHintWindow.BoundsChanged;\r\nbegin\r\nend;\r\n\r\nprocedure TJvExHintWindow.CursorChanged;\r\nbegin\r\n BaseWndProc(CM_CURSORCHANGED);\r\nend;\r\n\r\nprocedure TJvExHintWindow.ShowingChanged;\r\nbegin\r\n BaseWndProc(CM_SHOWINGCHANGED);\r\nend;\r\n\r\nprocedure TJvExHintWindow.ShowHintChanged;\r\nbegin\r\n BaseWndProc(CM_SHOWHINTCHANGED);\r\nend;\r\n\r\n{ VCL sends CM_CONTROLLISTCHANGE and CM_CONTROLCHANGE in a different order than\r\n the CLX methods are used. So we must correct it by evaluating \"Inserting\". }\r\nprocedure TJvExHintWindow.ControlsListChanging(Control: TControl; Inserting: Boolean);\r\nbegin\r\n if Inserting then\r\n BaseWndProc(CM_CONTROLLISTCHANGE, WPARAM(Control), LPARAM(Inserting))\r\n else\r\n BaseWndProc(CM_CONTROLCHANGE, WPARAM(Control), LPARAM(Inserting));\r\nend;\r\n\r\nprocedure TJvExHintWindow.ControlsListChanged(Control: TControl; Inserting: Boolean);\r\nbegin\r\n if not Inserting then\r\n BaseWndProc(CM_CONTROLLISTCHANGE, WPARAM(Control), LPARAM(Inserting))\r\n else\r\n BaseWndProc(CM_CONTROLCHANGE, WPARAM(Control), LPARAM(Inserting));\r\nend;\r\n\r\nprocedure TJvExHintWindow.GetDlgCode(var Code: TDlgCodes);\r\nbegin\r\nend;\r\n\r\nprocedure TJvExHintWindow.FocusSet(PrevWnd: THandle);\r\nbegin\r\n BaseWndProc(WM_SETFOCUS, WPARAM(PrevWnd), 0);\r\nend;\r\n\r\nprocedure TJvExHintWindow.FocusKilled(NextWnd: THandle);\r\nbegin\r\n BaseWndProc(WM_KILLFOCUS, WPARAM(NextWnd), 0);\r\nend;\r\n\r\nfunction TJvExHintWindow.DoEraseBackground(Canvas: TCanvas; Param: LPARAM): Boolean;\r\nbegin\r\n Result := BaseWndProc(WM_ERASEBKGND, Canvas.Handle, Param) <> 0;\r\nend;\r\n\r\n{$IFDEF JVCLThemesEnabledD6}\r\nfunction TJvExHintWindow.GetParentBackground: Boolean;\r\nbegin\r\n Result := JvThemes.GetParentBackground(Self);\r\nend;\r\n\r\nprocedure TJvExHintWindow.SetParentBackground(Value: Boolean);\r\nbegin\r\n JvThemes.SetParentBackground(Self, Value);\r\nend;\r\n{$ENDIF JVCLThemesEnabledD6}\r\n\r\nprocedure TJvExHintWindow.WndProc(var Msg: TMessage);\r\nvar\r\n IdSaveDC: Integer;\r\n DlgCodes: TDlgCodes;\r\n Canvas: TCanvas;\r\nbegin\r\n if not DispatchIsDesignMsg(Self, Msg) then\r\n begin\r\n case Msg.Msg of\r\n CM_DENYSUBCLASSING:\r\n Msg.Result := LRESULT(Ord(GetInterfaceEntry(IJvDenySubClassing) <> nil));\r\n CM_DIALOGCHAR:\r\n with TCMDialogChar{$IFDEF CLR}.Create{$ENDIF}(Msg) do\r\n Result := LRESULT(Ord(WantKey(CharCode, KeyDataToShiftState(KeyData))));\r\n CM_HINTSHOW:\r\n with TCMHintShow(Msg) do\r\n Result := LRESULT(HintShow(HintInfo^));\r\n CM_HITTEST:\r\n with TCMHitTest(Msg) do\r\n Result := LRESULT(HitTest(XPos, YPos));\r\n CM_MOUSEENTER:\r\n MouseEnter(TControl(Msg.LParam));\r\n CM_MOUSELEAVE:\r\n MouseLeave(TControl(Msg.LParam));\r\n CM_VISIBLECHANGED:\r\n VisibleChanged;\r\n CM_ENABLEDCHANGED:\r\n EnabledChanged;\r\n CM_TEXTCHANGED:\r\n TextChanged;\r\n CM_FONTCHANGED:\r\n FontChanged;\r\n CM_COLORCHANGED:\r\n ColorChanged;\r\n CM_FOCUSCHANGED:\r\n FocusChanged(TWinControl(Msg.LParam));\r\n CM_PARENTFONTCHANGED:\r\n ParentFontChanged;\r\n CM_PARENTCOLORCHANGED:\r\n ParentColorChanged;\r\n CM_PARENTSHOWHINTCHANGED:\r\n ParentShowHintChanged;\r\n CM_CURSORCHANGED:\r\n CursorChanged;\r\n CM_SHOWINGCHANGED:\r\n ShowingChanged;\r\n CM_SHOWHINTCHANGED:\r\n ShowHintChanged;\r\n CM_CONTROLLISTCHANGE:\r\n if Msg.LParam <> 0 then\r\n ControlsListChanging(TControl(Msg.WParam), True)\r\n else\r\n ControlsListChanged(TControl(Msg.WParam), False);\r\n CM_CONTROLCHANGE:\r\n if Msg.LParam = 0 then\r\n ControlsListChanging(TControl(Msg.WParam), False)\r\n else\r\n ControlsListChanged(TControl(Msg.WParam), True);\r\n WM_SETFOCUS:\r\n FocusSet(THandle(Msg.WParam));\r\n WM_KILLFOCUS:\r\n FocusKilled(THandle(Msg.WParam));\r\n WM_SIZE, WM_MOVE:\r\n begin\r\n inherited WndProc(Msg);\r\n BoundsChanged;\r\n end;\r\n WM_ERASEBKGND:\r\n if (Msg.WParam <> 0) and not IsDefaultEraseBackground(DoEraseBackground, @TJvExHintWindow.DoEraseBackground) then\r\n begin\r\n IdSaveDC := SaveDC(HDC(Msg.WParam)); // protect DC against Stock-Objects from Canvas\r\n Canvas := TCanvas.Create;\r\n try\r\n Canvas.Handle := HDC(Msg.WParam);\r\n Msg.Result := Ord(DoEraseBackground(Canvas, Msg.LParam));\r\n finally\r\n Canvas.Handle := 0;\r\n Canvas.Free;\r\n RestoreDC(HDC(Msg.WParam), IdSaveDC);\r\n end;\r\n end\r\n else\r\n inherited WndProc(Msg);\r\n {$IFNDEF DELPHI2007_UP}\r\n WM_PRINTCLIENT, WM_PRINT: // VCL bug fix\r\n begin\r\n IdSaveDC := SaveDC(HDC(Msg.WParam)); // protect DC against changes\r\n try\r\n inherited WndProc(Msg);\r\n finally\r\n RestoreDC(HDC(Msg.WParam), IdSaveDC);\r\n end;\r\n end;\r\n {$ENDIF ~DELPHI2007_UP}\r\n WM_GETDLGCODE:\r\n begin\r\n inherited WndProc(Msg);\r\n DlgCodes := [dcNative] + DlgcToDlgCodes(Msg.Result);\r\n GetDlgCode(DlgCodes);\r\n if not (dcNative in DlgCodes) then\r\n Msg.Result := DlgCodesToDlgc(DlgCodes);\r\n end;\r\n else\r\n inherited WndProc(Msg);\r\n end;\r\n case Msg.Msg of // precheck message to prevent access violations on released controls\r\n CM_MOUSEENTER, CM_MOUSELEAVE, WM_KILLFOCUS, WM_SETFOCUS, WM_NCPAINT:\r\n if DotNetHighlighting then\r\n HandleDotNetHighlighting(Self, Msg, MouseOver, Color);\r\n end;\r\n end;\r\nend;\r\n\r\n//============================================================================\r\n\r\ninitialization\r\n {$IFDEF UNITVERSIONING}\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n {$ENDIF UNITVERSIONING}\r\n\r\nfinalization\r\n {$IFDEF UNITVERSIONING}\r\n UnregisterUnitVersion(HInstance);\r\n {$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n\r\n" }, { "path": "External/Jedi/Jvcl/run/JvExDBGrids.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvExDBGrids.pas, released on 2004-01-04\r\n\r\nThe Initial Developer of the Original Code is Andreas Hausladen [Andreas dott Hausladen att gmx dott de]\r\nPortions created by Andreas Hausladen are Copyright (C) 2004 Andreas Hausladen.\r\nAll Rights Reserved.\r\n\r\nContributor(s): -\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvExDBGrids.pas 13173 2011-11-19 12:43:58Z ahuser $\r\n\r\nunit JvExDBGrids;\r\n\r\n{$I jvcl.inc}\r\n{MACROINCLUDE JvExControls.macros}\r\n\r\n{*****************************************************************************\r\n * WARNING: Do not edit this file.\r\n * This file is autogenerated from the source in devtools/JvExVCL/src.\r\n * If you do it despite this warning your changes will be discarded by the next\r\n * update of this file. Do your changes in the template files.\r\n ****************************************************************************}\r\n{$D-} // do not step into this unit\r\n\r\ninterface\r\n\r\nuses\r\n Windows, Messages, Types,\r\n SysUtils, Classes, Graphics, Controls, Forms, DBGrids,\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n JvTypes, JvThemes, JVCLVer, JvExControls;\r\n\r\ntype\r\n TJvExCustomDBGrid = class(TCustomDBGrid, IJvExControl)\r\n private\r\n FAboutJVCL: TJVCLAboutInfo;\r\n FHintColor: TColor;\r\n FMouseOver: Boolean;\r\n FHintWindowClass: THintWindowClass;\r\n FOnMouseEnter: TNotifyEvent;\r\n FOnMouseLeave: TNotifyEvent;\r\n FOnParentColorChanged: TNotifyEvent;\r\n function BaseWndProc(Msg: Cardinal; WParam: WPARAM = 0; LParam: LPARAM = 0): LRESULT; overload;\r\n function BaseWndProc(Msg: Cardinal; WParam: WPARAM; LParam: TObject): LRESULT; overload;\r\n function BaseWndProcEx(Msg: Cardinal; WParam: WPARAM; var StructLParam): LRESULT;\r\n protected\r\n procedure WndProc(var Msg: TMessage); override;\r\n procedure FocusChanged(AControl: TWinControl); dynamic;\r\n procedure VisibleChanged; reintroduce; dynamic;\r\n procedure EnabledChanged; reintroduce; dynamic;\r\n procedure TextChanged; reintroduce; virtual;\r\n procedure ColorChanged; reintroduce; dynamic;\r\n procedure FontChanged; reintroduce; dynamic;\r\n procedure ParentFontChanged; reintroduce; dynamic;\r\n procedure ParentColorChanged; reintroduce; dynamic;\r\n procedure ParentShowHintChanged; reintroduce; dynamic;\r\n function WantKey(Key: Integer; Shift: TShiftState): Boolean; virtual;\r\n function HintShow(var HintInfo: THintInfo): Boolean; reintroduce; dynamic;\r\n function HitTest(X, Y: Integer): Boolean; reintroduce; virtual;\r\n procedure MouseEnter(AControl: TControl); reintroduce; dynamic;\r\n procedure MouseLeave(AControl: TControl); reintroduce; dynamic;\r\n property MouseOver: Boolean read FMouseOver write FMouseOver;\r\n property HintColor: TColor read FHintColor write FHintColor default clDefault;\r\n property OnMouseEnter: TNotifyEvent read FOnMouseEnter write FOnMouseEnter;\r\n property OnMouseLeave: TNotifyEvent read FOnMouseLeave write FOnMouseLeave;\r\n property OnParentColorChange: TNotifyEvent read FOnParentColorChanged write FOnParentColorChanged;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n property HintWindowClass: THintWindowClass read FHintWindowClass write FHintWindowClass;\r\n published\r\n property AboutJVCL: TJVCLAboutInfo read FAboutJVCL write FAboutJVCL stored False;\r\n private\r\n FDotNetHighlighting: Boolean;\r\n protected\r\n procedure BoundsChanged; reintroduce; virtual;\r\n procedure CursorChanged; reintroduce; dynamic;\r\n procedure ShowingChanged; reintroduce; dynamic;\r\n procedure ShowHintChanged; reintroduce; dynamic;\r\n procedure ControlsListChanging(Control: TControl; Inserting: Boolean); reintroduce; dynamic;\r\n procedure ControlsListChanged(Control: TControl; Inserting: Boolean); reintroduce; dynamic;\r\n procedure GetDlgCode(var Code: TDlgCodes); virtual;\r\n procedure FocusSet(PrevWnd: THandle); virtual;\r\n procedure FocusKilled(NextWnd: THandle); virtual;\r\n function DoEraseBackground(Canvas: TCanvas; Param: LPARAM): Boolean; virtual;\r\n {$IFDEF JVCLThemesEnabledD6}\r\n private\r\n function GetParentBackground: Boolean;\r\n protected\r\n procedure SetParentBackground(Value: Boolean); virtual;\r\n property ParentBackground: Boolean read GetParentBackground write SetParentBackground;\r\n {$ENDIF JVCLThemesEnabledD6}\r\n published\r\n property DotNetHighlighting: Boolean read FDotNetHighlighting write FDotNetHighlighting default False;\r\n end;\r\n\r\n TJvExDBGrid = class(TDBGrid, IJvExControl)\r\n private\r\n FAboutJVCL: TJVCLAboutInfo;\r\n FHintColor: TColor;\r\n FMouseOver: Boolean;\r\n FHintWindowClass: THintWindowClass;\r\n FOnMouseEnter: TNotifyEvent;\r\n FOnMouseLeave: TNotifyEvent;\r\n FOnParentColorChanged: TNotifyEvent;\r\n function BaseWndProc(Msg: Cardinal; WParam: WPARAM = 0; LParam: LPARAM = 0): LRESULT; overload;\r\n function BaseWndProc(Msg: Cardinal; WParam: WPARAM; LParam: TObject): LRESULT; overload;\r\n function BaseWndProcEx(Msg: Cardinal; WParam: WPARAM; var StructLParam): LRESULT;\r\n protected\r\n procedure WndProc(var Msg: TMessage); override;\r\n procedure FocusChanged(AControl: TWinControl); dynamic;\r\n procedure VisibleChanged; reintroduce; dynamic;\r\n procedure EnabledChanged; reintroduce; dynamic;\r\n procedure TextChanged; reintroduce; virtual;\r\n procedure ColorChanged; reintroduce; dynamic;\r\n procedure FontChanged; reintroduce; dynamic;\r\n procedure ParentFontChanged; reintroduce; dynamic;\r\n procedure ParentColorChanged; reintroduce; dynamic;\r\n procedure ParentShowHintChanged; reintroduce; dynamic;\r\n function WantKey(Key: Integer; Shift: TShiftState): Boolean; virtual;\r\n function HintShow(var HintInfo: THintInfo): Boolean; reintroduce; dynamic;\r\n function HitTest(X, Y: Integer): Boolean; reintroduce; virtual;\r\n procedure MouseEnter(AControl: TControl); reintroduce; dynamic;\r\n procedure MouseLeave(AControl: TControl); reintroduce; dynamic;\r\n property MouseOver: Boolean read FMouseOver write FMouseOver;\r\n property HintColor: TColor read FHintColor write FHintColor default clDefault;\r\n property OnMouseEnter: TNotifyEvent read FOnMouseEnter write FOnMouseEnter;\r\n property OnMouseLeave: TNotifyEvent read FOnMouseLeave write FOnMouseLeave;\r\n property OnParentColorChange: TNotifyEvent read FOnParentColorChanged write FOnParentColorChanged;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n property HintWindowClass: THintWindowClass read FHintWindowClass write FHintWindowClass;\r\n published\r\n property AboutJVCL: TJVCLAboutInfo read FAboutJVCL write FAboutJVCL stored False;\r\n private\r\n FDotNetHighlighting: Boolean;\r\n protected\r\n procedure BoundsChanged; reintroduce; virtual;\r\n procedure CursorChanged; reintroduce; dynamic;\r\n procedure ShowingChanged; reintroduce; dynamic;\r\n procedure ShowHintChanged; reintroduce; dynamic;\r\n procedure ControlsListChanging(Control: TControl; Inserting: Boolean); reintroduce; dynamic;\r\n procedure ControlsListChanged(Control: TControl; Inserting: Boolean); reintroduce; dynamic;\r\n procedure GetDlgCode(var Code: TDlgCodes); virtual;\r\n procedure FocusSet(PrevWnd: THandle); virtual;\r\n procedure FocusKilled(NextWnd: THandle); virtual;\r\n function DoEraseBackground(Canvas: TCanvas; Param: LPARAM): Boolean; virtual;\r\n {$IFDEF JVCLThemesEnabledD6}\r\n private\r\n function GetParentBackground: Boolean;\r\n protected\r\n procedure SetParentBackground(Value: Boolean); virtual;\r\n property ParentBackground: Boolean read GetParentBackground write SetParentBackground;\r\n {$ENDIF JVCLThemesEnabledD6}\r\n published\r\n property DotNetHighlighting: Boolean read FDotNetHighlighting write FDotNetHighlighting default False;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvExDBGrids.pas $';\r\n Revision: '$Revision: 13173 $';\r\n Date: '$Date: 2011-11-19 13:43:58 +0100 (sam. 19 nov. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nconstructor TJvExCustomDBGrid.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FHintColor := clDefault;\r\nend;\r\n\r\nfunction TJvExCustomDBGrid.BaseWndProc(Msg: Cardinal; WParam: WPARAM = 0; LParam: LPARAM = 0): LRESULT;\r\nvar\r\n Mesg: TMessage;\r\nbegin\r\n CreateWMMessage(Mesg, Msg, WParam, LParam);\r\n inherited WndProc(Mesg);\r\n Result := Mesg.Result;\r\nend;\r\n\r\nfunction TJvExCustomDBGrid.BaseWndProc(Msg: Cardinal; WParam: WPARAM; LParam: TObject): LRESULT;\r\nbegin\r\n Result := BaseWndProc(Msg, WParam, Windows.LPARAM(LParam));\r\nend;\r\n\r\nfunction TJvExCustomDBGrid.BaseWndProcEx(Msg: Cardinal; WParam: WPARAM; var StructLParam): LRESULT;\r\nbegin\r\n Result := BaseWndProc(Msg, WParam, Windows.LPARAM(@StructLParam));\r\nend;\r\n\r\nprocedure TJvExCustomDBGrid.VisibleChanged;\r\nbegin\r\n BaseWndProc(CM_VISIBLECHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomDBGrid.EnabledChanged;\r\nbegin\r\n BaseWndProc(CM_ENABLEDCHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomDBGrid.TextChanged;\r\nbegin\r\n BaseWndProc(CM_TEXTCHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomDBGrid.FontChanged;\r\nbegin\r\n BaseWndProc(CM_FONTCHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomDBGrid.ColorChanged;\r\nbegin\r\n BaseWndProc(CM_COLORCHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomDBGrid.ParentFontChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTFONTCHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomDBGrid.ParentColorChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTCOLORCHANGED);\r\n if Assigned(OnParentColorChange) then\r\n OnParentColorChange(Self);\r\nend;\r\n\r\nprocedure TJvExCustomDBGrid.ParentShowHintChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTSHOWHINTCHANGED);\r\nend;\r\n\r\nfunction TJvExCustomDBGrid.WantKey(Key: Integer; Shift: TShiftState): Boolean;\r\nbegin\r\n Result := BaseWndProc(CM_DIALOGCHAR, Word(Key), ShiftStateToKeyData(Shift)) <> 0;\r\nend;\r\n\r\nfunction TJvExCustomDBGrid.HitTest(X, Y: Integer): Boolean;\r\nbegin\r\n Result := BaseWndProc(CM_HITTEST, 0, SmallPointToLong(PointToSmallPoint(Point(X, Y)))) <> 0;\r\nend;\r\n\r\nfunction TJvExCustomDBGrid.HintShow(var HintInfo: THintInfo): Boolean;\r\nbegin\r\n GetHintColor(HintInfo, Self, FHintColor);\r\n if FHintWindowClass <> nil then\r\n HintInfo.HintWindowClass := FHintWindowClass;\r\n Result := BaseWndProcEx(CM_HINTSHOW, 0, HintInfo) <> 0;\r\nend;\r\n\r\nprocedure TJvExCustomDBGrid.MouseEnter(AControl: TControl);\r\nbegin\r\n FMouseOver := True;\r\n if Assigned(FOnMouseEnter) then\r\n FOnMouseEnter(Self);\r\n BaseWndProc(CM_MOUSEENTER, 0, AControl);\r\nend;\r\n\r\nprocedure TJvExCustomDBGrid.MouseLeave(AControl: TControl);\r\nbegin\r\n FMouseOver := False;\r\n BaseWndProc(CM_MOUSELEAVE, 0, AControl);\r\n if Assigned(FOnMouseLeave) then\r\n FOnMouseLeave(Self);\r\nend;\r\n\r\nprocedure TJvExCustomDBGrid.FocusChanged(AControl: TWinControl);\r\nbegin\r\n BaseWndProc(CM_FOCUSCHANGED, 0, AControl);\r\nend;\r\n\r\nprocedure TJvExCustomDBGrid.BoundsChanged;\r\nbegin\r\nend;\r\n\r\nprocedure TJvExCustomDBGrid.CursorChanged;\r\nbegin\r\n BaseWndProc(CM_CURSORCHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomDBGrid.ShowingChanged;\r\nbegin\r\n BaseWndProc(CM_SHOWINGCHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomDBGrid.ShowHintChanged;\r\nbegin\r\n BaseWndProc(CM_SHOWHINTCHANGED);\r\nend;\r\n\r\n{ VCL sends CM_CONTROLLISTCHANGE and CM_CONTROLCHANGE in a different order than\r\n the CLX methods are used. So we must correct it by evaluating \"Inserting\". }\r\nprocedure TJvExCustomDBGrid.ControlsListChanging(Control: TControl; Inserting: Boolean);\r\nbegin\r\n if Inserting then\r\n BaseWndProc(CM_CONTROLLISTCHANGE, WPARAM(Control), LPARAM(Inserting))\r\n else\r\n BaseWndProc(CM_CONTROLCHANGE, WPARAM(Control), LPARAM(Inserting));\r\nend;\r\n\r\nprocedure TJvExCustomDBGrid.ControlsListChanged(Control: TControl; Inserting: Boolean);\r\nbegin\r\n if not Inserting then\r\n BaseWndProc(CM_CONTROLLISTCHANGE, WPARAM(Control), LPARAM(Inserting))\r\n else\r\n BaseWndProc(CM_CONTROLCHANGE, WPARAM(Control), LPARAM(Inserting));\r\nend;\r\n\r\nprocedure TJvExCustomDBGrid.GetDlgCode(var Code: TDlgCodes);\r\nbegin\r\nend;\r\n\r\nprocedure TJvExCustomDBGrid.FocusSet(PrevWnd: THandle);\r\nbegin\r\n BaseWndProc(WM_SETFOCUS, WPARAM(PrevWnd), 0);\r\nend;\r\n\r\nprocedure TJvExCustomDBGrid.FocusKilled(NextWnd: THandle);\r\nbegin\r\n BaseWndProc(WM_KILLFOCUS, WPARAM(NextWnd), 0);\r\nend;\r\n\r\nfunction TJvExCustomDBGrid.DoEraseBackground(Canvas: TCanvas; Param: LPARAM): Boolean;\r\nbegin\r\n Result := BaseWndProc(WM_ERASEBKGND, Canvas.Handle, Param) <> 0;\r\nend;\r\n\r\n{$IFDEF JVCLThemesEnabledD6}\r\nfunction TJvExCustomDBGrid.GetParentBackground: Boolean;\r\nbegin\r\n Result := JvThemes.GetParentBackground(Self);\r\nend;\r\n\r\nprocedure TJvExCustomDBGrid.SetParentBackground(Value: Boolean);\r\nbegin\r\n JvThemes.SetParentBackground(Self, Value);\r\nend;\r\n{$ENDIF JVCLThemesEnabledD6}\r\n\r\nprocedure TJvExCustomDBGrid.WndProc(var Msg: TMessage);\r\nvar\r\n IdSaveDC: Integer;\r\n DlgCodes: TDlgCodes;\r\n Canvas: TCanvas;\r\nbegin\r\n if not DispatchIsDesignMsg(Self, Msg) then\r\n begin\r\n case Msg.Msg of\r\n CM_DENYSUBCLASSING:\r\n Msg.Result := LRESULT(Ord(GetInterfaceEntry(IJvDenySubClassing) <> nil));\r\n CM_DIALOGCHAR:\r\n with TCMDialogChar{$IFDEF CLR}.Create{$ENDIF}(Msg) do\r\n Result := LRESULT(Ord(WantKey(CharCode, KeyDataToShiftState(KeyData))));\r\n CM_HINTSHOW:\r\n with TCMHintShow(Msg) do\r\n Result := LRESULT(HintShow(HintInfo^));\r\n CM_HITTEST:\r\n with TCMHitTest(Msg) do\r\n Result := LRESULT(HitTest(XPos, YPos));\r\n CM_MOUSEENTER:\r\n MouseEnter(TControl(Msg.LParam));\r\n CM_MOUSELEAVE:\r\n MouseLeave(TControl(Msg.LParam));\r\n CM_VISIBLECHANGED:\r\n VisibleChanged;\r\n CM_ENABLEDCHANGED:\r\n EnabledChanged;\r\n CM_TEXTCHANGED:\r\n TextChanged;\r\n CM_FONTCHANGED:\r\n FontChanged;\r\n CM_COLORCHANGED:\r\n ColorChanged;\r\n CM_FOCUSCHANGED:\r\n FocusChanged(TWinControl(Msg.LParam));\r\n CM_PARENTFONTCHANGED:\r\n ParentFontChanged;\r\n CM_PARENTCOLORCHANGED:\r\n ParentColorChanged;\r\n CM_PARENTSHOWHINTCHANGED:\r\n ParentShowHintChanged;\r\n CM_CURSORCHANGED:\r\n CursorChanged;\r\n CM_SHOWINGCHANGED:\r\n ShowingChanged;\r\n CM_SHOWHINTCHANGED:\r\n ShowHintChanged;\r\n CM_CONTROLLISTCHANGE:\r\n if Msg.LParam <> 0 then\r\n ControlsListChanging(TControl(Msg.WParam), True)\r\n else\r\n ControlsListChanged(TControl(Msg.WParam), False);\r\n CM_CONTROLCHANGE:\r\n if Msg.LParam = 0 then\r\n ControlsListChanging(TControl(Msg.WParam), False)\r\n else\r\n ControlsListChanged(TControl(Msg.WParam), True);\r\n WM_SETFOCUS:\r\n FocusSet(THandle(Msg.WParam));\r\n WM_KILLFOCUS:\r\n FocusKilled(THandle(Msg.WParam));\r\n WM_SIZE, WM_MOVE:\r\n begin\r\n inherited WndProc(Msg);\r\n BoundsChanged;\r\n end;\r\n WM_ERASEBKGND:\r\n if (Msg.WParam <> 0) and not IsDefaultEraseBackground(DoEraseBackground, @TJvExCustomDBGrid.DoEraseBackground) then\r\n begin\r\n IdSaveDC := SaveDC(HDC(Msg.WParam)); // protect DC against Stock-Objects from Canvas\r\n Canvas := TCanvas.Create;\r\n try\r\n Canvas.Handle := HDC(Msg.WParam);\r\n Msg.Result := Ord(DoEraseBackground(Canvas, Msg.LParam));\r\n finally\r\n Canvas.Handle := 0;\r\n Canvas.Free;\r\n RestoreDC(HDC(Msg.WParam), IdSaveDC);\r\n end;\r\n end\r\n else\r\n inherited WndProc(Msg);\r\n {$IFNDEF DELPHI2007_UP}\r\n WM_PRINTCLIENT, WM_PRINT: // VCL bug fix\r\n begin\r\n IdSaveDC := SaveDC(HDC(Msg.WParam)); // protect DC against changes\r\n try\r\n inherited WndProc(Msg);\r\n finally\r\n RestoreDC(HDC(Msg.WParam), IdSaveDC);\r\n end;\r\n end;\r\n {$ENDIF ~DELPHI2007_UP}\r\n WM_GETDLGCODE:\r\n begin\r\n inherited WndProc(Msg);\r\n DlgCodes := [dcNative] + DlgcToDlgCodes(Msg.Result);\r\n GetDlgCode(DlgCodes);\r\n if not (dcNative in DlgCodes) then\r\n Msg.Result := DlgCodesToDlgc(DlgCodes);\r\n end;\r\n else\r\n inherited WndProc(Msg);\r\n end;\r\n case Msg.Msg of // precheck message to prevent access violations on released controls\r\n CM_MOUSEENTER, CM_MOUSELEAVE, WM_KILLFOCUS, WM_SETFOCUS, WM_NCPAINT:\r\n if DotNetHighlighting then\r\n HandleDotNetHighlighting(Self, Msg, MouseOver, Color);\r\n end;\r\n end;\r\nend;\r\n\r\n//============================================================================\r\n\r\nconstructor TJvExDBGrid.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FHintColor := clDefault;\r\nend;\r\n\r\nfunction TJvExDBGrid.BaseWndProc(Msg: Cardinal; WParam: WPARAM = 0; LParam: LPARAM = 0): LRESULT;\r\nvar\r\n Mesg: TMessage;\r\nbegin\r\n CreateWMMessage(Mesg, Msg, WParam, LParam);\r\n inherited WndProc(Mesg);\r\n Result := Mesg.Result;\r\nend;\r\n\r\nfunction TJvExDBGrid.BaseWndProc(Msg: Cardinal; WParam: WPARAM; LParam: TObject): LRESULT;\r\nbegin\r\n Result := BaseWndProc(Msg, WParam, Windows.LPARAM(LParam));\r\nend;\r\n\r\nfunction TJvExDBGrid.BaseWndProcEx(Msg: Cardinal; WParam: WPARAM; var StructLParam): LRESULT;\r\nbegin\r\n Result := BaseWndProc(Msg, WParam, Windows.LPARAM(@StructLParam));\r\nend;\r\n\r\nprocedure TJvExDBGrid.VisibleChanged;\r\nbegin\r\n BaseWndProc(CM_VISIBLECHANGED);\r\nend;\r\n\r\nprocedure TJvExDBGrid.EnabledChanged;\r\nbegin\r\n BaseWndProc(CM_ENABLEDCHANGED);\r\nend;\r\n\r\nprocedure TJvExDBGrid.TextChanged;\r\nbegin\r\n BaseWndProc(CM_TEXTCHANGED);\r\nend;\r\n\r\nprocedure TJvExDBGrid.FontChanged;\r\nbegin\r\n BaseWndProc(CM_FONTCHANGED);\r\nend;\r\n\r\nprocedure TJvExDBGrid.ColorChanged;\r\nbegin\r\n BaseWndProc(CM_COLORCHANGED);\r\nend;\r\n\r\nprocedure TJvExDBGrid.ParentFontChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTFONTCHANGED);\r\nend;\r\n\r\nprocedure TJvExDBGrid.ParentColorChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTCOLORCHANGED);\r\n if Assigned(OnParentColorChange) then\r\n OnParentColorChange(Self);\r\nend;\r\n\r\nprocedure TJvExDBGrid.ParentShowHintChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTSHOWHINTCHANGED);\r\nend;\r\n\r\nfunction TJvExDBGrid.WantKey(Key: Integer; Shift: TShiftState): Boolean;\r\nbegin\r\n Result := BaseWndProc(CM_DIALOGCHAR, Word(Key), ShiftStateToKeyData(Shift)) <> 0;\r\nend;\r\n\r\nfunction TJvExDBGrid.HitTest(X, Y: Integer): Boolean;\r\nbegin\r\n Result := BaseWndProc(CM_HITTEST, 0, SmallPointToLong(PointToSmallPoint(Point(X, Y)))) <> 0;\r\nend;\r\n\r\nfunction TJvExDBGrid.HintShow(var HintInfo: THintInfo): Boolean;\r\nbegin\r\n GetHintColor(HintInfo, Self, FHintColor);\r\n if FHintWindowClass <> nil then\r\n HintInfo.HintWindowClass := FHintWindowClass;\r\n Result := BaseWndProcEx(CM_HINTSHOW, 0, HintInfo) <> 0;\r\nend;\r\n\r\nprocedure TJvExDBGrid.MouseEnter(AControl: TControl);\r\nbegin\r\n FMouseOver := True;\r\n if Assigned(FOnMouseEnter) then\r\n FOnMouseEnter(Self);\r\n BaseWndProc(CM_MOUSEENTER, 0, AControl);\r\nend;\r\n\r\nprocedure TJvExDBGrid.MouseLeave(AControl: TControl);\r\nbegin\r\n FMouseOver := False;\r\n BaseWndProc(CM_MOUSELEAVE, 0, AControl);\r\n if Assigned(FOnMouseLeave) then\r\n FOnMouseLeave(Self);\r\nend;\r\n\r\nprocedure TJvExDBGrid.FocusChanged(AControl: TWinControl);\r\nbegin\r\n BaseWndProc(CM_FOCUSCHANGED, 0, AControl);\r\nend;\r\n\r\nprocedure TJvExDBGrid.BoundsChanged;\r\nbegin\r\nend;\r\n\r\nprocedure TJvExDBGrid.CursorChanged;\r\nbegin\r\n BaseWndProc(CM_CURSORCHANGED);\r\nend;\r\n\r\nprocedure TJvExDBGrid.ShowingChanged;\r\nbegin\r\n BaseWndProc(CM_SHOWINGCHANGED);\r\nend;\r\n\r\nprocedure TJvExDBGrid.ShowHintChanged;\r\nbegin\r\n BaseWndProc(CM_SHOWHINTCHANGED);\r\nend;\r\n\r\n{ VCL sends CM_CONTROLLISTCHANGE and CM_CONTROLCHANGE in a different order than\r\n the CLX methods are used. So we must correct it by evaluating \"Inserting\". }\r\nprocedure TJvExDBGrid.ControlsListChanging(Control: TControl; Inserting: Boolean);\r\nbegin\r\n if Inserting then\r\n BaseWndProc(CM_CONTROLLISTCHANGE, WPARAM(Control), LPARAM(Inserting))\r\n else\r\n BaseWndProc(CM_CONTROLCHANGE, WPARAM(Control), LPARAM(Inserting));\r\nend;\r\n\r\nprocedure TJvExDBGrid.ControlsListChanged(Control: TControl; Inserting: Boolean);\r\nbegin\r\n if not Inserting then\r\n BaseWndProc(CM_CONTROLLISTCHANGE, WPARAM(Control), LPARAM(Inserting))\r\n else\r\n BaseWndProc(CM_CONTROLCHANGE, WPARAM(Control), LPARAM(Inserting));\r\nend;\r\n\r\nprocedure TJvExDBGrid.GetDlgCode(var Code: TDlgCodes);\r\nbegin\r\nend;\r\n\r\nprocedure TJvExDBGrid.FocusSet(PrevWnd: THandle);\r\nbegin\r\n BaseWndProc(WM_SETFOCUS, WPARAM(PrevWnd), 0);\r\nend;\r\n\r\nprocedure TJvExDBGrid.FocusKilled(NextWnd: THandle);\r\nbegin\r\n BaseWndProc(WM_KILLFOCUS, WPARAM(NextWnd), 0);\r\nend;\r\n\r\nfunction TJvExDBGrid.DoEraseBackground(Canvas: TCanvas; Param: LPARAM): Boolean;\r\nbegin\r\n Result := BaseWndProc(WM_ERASEBKGND, Canvas.Handle, Param) <> 0;\r\nend;\r\n\r\n{$IFDEF JVCLThemesEnabledD6}\r\nfunction TJvExDBGrid.GetParentBackground: Boolean;\r\nbegin\r\n Result := JvThemes.GetParentBackground(Self);\r\nend;\r\n\r\nprocedure TJvExDBGrid.SetParentBackground(Value: Boolean);\r\nbegin\r\n JvThemes.SetParentBackground(Self, Value);\r\nend;\r\n{$ENDIF JVCLThemesEnabledD6}\r\n\r\nprocedure TJvExDBGrid.WndProc(var Msg: TMessage);\r\nvar\r\n IdSaveDC: Integer;\r\n DlgCodes: TDlgCodes;\r\n Canvas: TCanvas;\r\nbegin\r\n if not DispatchIsDesignMsg(Self, Msg) then\r\n begin\r\n case Msg.Msg of\r\n CM_DENYSUBCLASSING:\r\n Msg.Result := LRESULT(Ord(GetInterfaceEntry(IJvDenySubClassing) <> nil));\r\n CM_DIALOGCHAR:\r\n with TCMDialogChar{$IFDEF CLR}.Create{$ENDIF}(Msg) do\r\n Result := LRESULT(Ord(WantKey(CharCode, KeyDataToShiftState(KeyData))));\r\n CM_HINTSHOW:\r\n with TCMHintShow(Msg) do\r\n Result := LRESULT(HintShow(HintInfo^));\r\n CM_HITTEST:\r\n with TCMHitTest(Msg) do\r\n Result := LRESULT(HitTest(XPos, YPos));\r\n CM_MOUSEENTER:\r\n MouseEnter(TControl(Msg.LParam));\r\n CM_MOUSELEAVE:\r\n MouseLeave(TControl(Msg.LParam));\r\n CM_VISIBLECHANGED:\r\n VisibleChanged;\r\n CM_ENABLEDCHANGED:\r\n EnabledChanged;\r\n CM_TEXTCHANGED:\r\n TextChanged;\r\n CM_FONTCHANGED:\r\n FontChanged;\r\n CM_COLORCHANGED:\r\n ColorChanged;\r\n CM_FOCUSCHANGED:\r\n FocusChanged(TWinControl(Msg.LParam));\r\n CM_PARENTFONTCHANGED:\r\n ParentFontChanged;\r\n CM_PARENTCOLORCHANGED:\r\n ParentColorChanged;\r\n CM_PARENTSHOWHINTCHANGED:\r\n ParentShowHintChanged;\r\n CM_CURSORCHANGED:\r\n CursorChanged;\r\n CM_SHOWINGCHANGED:\r\n ShowingChanged;\r\n CM_SHOWHINTCHANGED:\r\n ShowHintChanged;\r\n CM_CONTROLLISTCHANGE:\r\n if Msg.LParam <> 0 then\r\n ControlsListChanging(TControl(Msg.WParam), True)\r\n else\r\n ControlsListChanged(TControl(Msg.WParam), False);\r\n CM_CONTROLCHANGE:\r\n if Msg.LParam = 0 then\r\n ControlsListChanging(TControl(Msg.WParam), False)\r\n else\r\n ControlsListChanged(TControl(Msg.WParam), True);\r\n WM_SETFOCUS:\r\n FocusSet(THandle(Msg.WParam));\r\n WM_KILLFOCUS:\r\n FocusKilled(THandle(Msg.WParam));\r\n WM_SIZE, WM_MOVE:\r\n begin\r\n inherited WndProc(Msg);\r\n BoundsChanged;\r\n end;\r\n WM_ERASEBKGND:\r\n if (Msg.WParam <> 0) and not IsDefaultEraseBackground(DoEraseBackground, @TJvExDBGrid.DoEraseBackground) then\r\n begin\r\n IdSaveDC := SaveDC(HDC(Msg.WParam)); // protect DC against Stock-Objects from Canvas\r\n Canvas := TCanvas.Create;\r\n try\r\n Canvas.Handle := HDC(Msg.WParam);\r\n Msg.Result := Ord(DoEraseBackground(Canvas, Msg.LParam));\r\n finally\r\n Canvas.Handle := 0;\r\n Canvas.Free;\r\n RestoreDC(HDC(Msg.WParam), IdSaveDC);\r\n end;\r\n end\r\n else\r\n inherited WndProc(Msg);\r\n {$IFNDEF DELPHI2007_UP}\r\n WM_PRINTCLIENT, WM_PRINT: // VCL bug fix\r\n begin\r\n IdSaveDC := SaveDC(HDC(Msg.WParam)); // protect DC against changes\r\n try\r\n inherited WndProc(Msg);\r\n finally\r\n RestoreDC(HDC(Msg.WParam), IdSaveDC);\r\n end;\r\n end;\r\n {$ENDIF ~DELPHI2007_UP}\r\n WM_GETDLGCODE:\r\n begin\r\n inherited WndProc(Msg);\r\n DlgCodes := [dcNative] + DlgcToDlgCodes(Msg.Result);\r\n GetDlgCode(DlgCodes);\r\n if not (dcNative in DlgCodes) then\r\n Msg.Result := DlgCodesToDlgc(DlgCodes);\r\n end;\r\n else\r\n inherited WndProc(Msg);\r\n end;\r\n case Msg.Msg of // precheck message to prevent access violations on released controls\r\n CM_MOUSEENTER, CM_MOUSELEAVE, WM_KILLFOCUS, WM_SETFOCUS, WM_NCPAINT:\r\n if DotNetHighlighting then\r\n HandleDotNetHighlighting(Self, Msg, MouseOver, Color);\r\n end;\r\n end;\r\nend;\r\n\r\n//============================================================================\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend." }, { "path": "External/Jedi/Jvcl/run/JvExExtCtrls.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvExExtCtrls.pas, released on 2004-01-04\r\n\r\nThe Initial Developer of the Original Code is Andreas Hausladen [Andreas dott Hausladen att gmx dott de]\r\nPortions created by Andreas Hausladen are Copyright (C) 2004 Andreas Hausladen.\r\nAll Rights Reserved.\r\n\r\nContributor(s): -\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvExExtCtrls.pas 13173 2011-11-19 12:43:58Z ahuser $\r\n\r\nunit JvExExtCtrls;\r\n\r\n{$I jvcl.inc}\r\n{MACROINCLUDE JvExControls.macros}\r\n\r\n{*****************************************************************************\r\n * WARNING: Do not edit this file.\r\n * This file is autogenerated from the source in devtools/JvExVCL/src.\r\n * If you do it despite this warning your changes will be discarded by the next\r\n * update of this file. Do your changes in the template files.\r\n ****************************************************************************}\r\n{$D-} // do not step into this unit\r\n\r\ninterface\r\n\r\nuses\r\n Windows, Messages, Types,\r\n SysUtils, Classes, Graphics, Controls, Forms, ExtCtrls,\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n JvTypes, JvThemes, JVCLVer, JvExControls;\r\n\r\ntype\r\n TJvExShape = class(TShape, IJvExControl)\r\n private\r\n FAboutJVCL: TJVCLAboutInfo;\r\n FHintColor: TColor;\r\n FMouseOver: Boolean;\r\n FHintWindowClass: THintWindowClass;\r\n FOnMouseEnter: TNotifyEvent;\r\n FOnMouseLeave: TNotifyEvent;\r\n FOnParentColorChanged: TNotifyEvent;\r\n function BaseWndProc(Msg: Cardinal; WParam: WPARAM = 0; LParam: LPARAM = 0): LRESULT; overload;\r\n function BaseWndProc(Msg: Cardinal; WParam: WPARAM; LParam: TObject): LRESULT; overload;\r\n function BaseWndProcEx(Msg: Cardinal; WParam: WPARAM; var StructLParam): LRESULT;\r\n protected\r\n procedure WndProc(var Msg: TMessage); override;\r\n procedure FocusChanged(AControl: TWinControl); dynamic;\r\n procedure VisibleChanged; reintroduce; dynamic;\r\n procedure EnabledChanged; reintroduce; dynamic;\r\n procedure TextChanged; reintroduce; virtual;\r\n procedure ColorChanged; reintroduce; dynamic;\r\n procedure FontChanged; reintroduce; dynamic;\r\n procedure ParentFontChanged; reintroduce; dynamic;\r\n procedure ParentColorChanged; reintroduce; dynamic;\r\n procedure ParentShowHintChanged; reintroduce; dynamic;\r\n function WantKey(Key: Integer; Shift: TShiftState): Boolean; virtual;\r\n function HintShow(var HintInfo: THintInfo): Boolean; reintroduce; dynamic;\r\n function HitTest(X, Y: Integer): Boolean; reintroduce; virtual;\r\n procedure MouseEnter(AControl: TControl); reintroduce; dynamic;\r\n procedure MouseLeave(AControl: TControl); reintroduce; dynamic;\r\n property MouseOver: Boolean read FMouseOver write FMouseOver;\r\n property HintColor: TColor read FHintColor write FHintColor default clDefault;\r\n property OnMouseEnter: TNotifyEvent read FOnMouseEnter write FOnMouseEnter;\r\n property OnMouseLeave: TNotifyEvent read FOnMouseLeave write FOnMouseLeave;\r\n property OnParentColorChange: TNotifyEvent read FOnParentColorChanged write FOnParentColorChanged;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n property HintWindowClass: THintWindowClass read FHintWindowClass write FHintWindowClass;\r\n published\r\n property AboutJVCL: TJVCLAboutInfo read FAboutJVCL write FAboutJVCL stored False;\r\n end;\r\n\r\n TJvExPaintBox = class(TPaintBox, IJvExControl)\r\n private\r\n FAboutJVCL: TJVCLAboutInfo;\r\n FHintColor: TColor;\r\n FMouseOver: Boolean;\r\n FHintWindowClass: THintWindowClass;\r\n FOnMouseEnter: TNotifyEvent;\r\n FOnMouseLeave: TNotifyEvent;\r\n FOnParentColorChanged: TNotifyEvent;\r\n function BaseWndProc(Msg: Cardinal; WParam: WPARAM = 0; LParam: LPARAM = 0): LRESULT; overload;\r\n function BaseWndProc(Msg: Cardinal; WParam: WPARAM; LParam: TObject): LRESULT; overload;\r\n function BaseWndProcEx(Msg: Cardinal; WParam: WPARAM; var StructLParam): LRESULT;\r\n protected\r\n procedure WndProc(var Msg: TMessage); override;\r\n procedure FocusChanged(AControl: TWinControl); dynamic;\r\n procedure VisibleChanged; reintroduce; dynamic;\r\n procedure EnabledChanged; reintroduce; dynamic;\r\n procedure TextChanged; reintroduce; virtual;\r\n procedure ColorChanged; reintroduce; dynamic;\r\n procedure FontChanged; reintroduce; dynamic;\r\n procedure ParentFontChanged; reintroduce; dynamic;\r\n procedure ParentColorChanged; reintroduce; dynamic;\r\n procedure ParentShowHintChanged; reintroduce; dynamic;\r\n function WantKey(Key: Integer; Shift: TShiftState): Boolean; virtual;\r\n function HintShow(var HintInfo: THintInfo): Boolean; reintroduce; dynamic;\r\n function HitTest(X, Y: Integer): Boolean; reintroduce; virtual;\r\n procedure MouseEnter(AControl: TControl); reintroduce; dynamic;\r\n procedure MouseLeave(AControl: TControl); reintroduce; dynamic;\r\n property MouseOver: Boolean read FMouseOver write FMouseOver;\r\n property HintColor: TColor read FHintColor write FHintColor default clDefault;\r\n property OnMouseEnter: TNotifyEvent read FOnMouseEnter write FOnMouseEnter;\r\n property OnMouseLeave: TNotifyEvent read FOnMouseLeave write FOnMouseLeave;\r\n property OnParentColorChange: TNotifyEvent read FOnParentColorChanged write FOnParentColorChanged;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n property HintWindowClass: THintWindowClass read FHintWindowClass write FHintWindowClass;\r\n published\r\n property AboutJVCL: TJVCLAboutInfo read FAboutJVCL write FAboutJVCL stored False;\r\n end;\r\n\r\n TJvExImage = class(TImage, IJvExControl)\r\n private\r\n FAboutJVCL: TJVCLAboutInfo;\r\n FHintColor: TColor;\r\n FMouseOver: Boolean;\r\n FHintWindowClass: THintWindowClass;\r\n FOnMouseEnter: TNotifyEvent;\r\n FOnMouseLeave: TNotifyEvent;\r\n FOnParentColorChanged: TNotifyEvent;\r\n function BaseWndProc(Msg: Cardinal; WParam: WPARAM = 0; LParam: LPARAM = 0): LRESULT; overload;\r\n function BaseWndProc(Msg: Cardinal; WParam: WPARAM; LParam: TObject): LRESULT; overload;\r\n function BaseWndProcEx(Msg: Cardinal; WParam: WPARAM; var StructLParam): LRESULT;\r\n protected\r\n procedure WndProc(var Msg: TMessage); override;\r\n procedure FocusChanged(AControl: TWinControl); dynamic;\r\n procedure VisibleChanged; reintroduce; dynamic;\r\n procedure EnabledChanged; reintroduce; dynamic;\r\n procedure TextChanged; reintroduce; virtual;\r\n procedure ColorChanged; reintroduce; dynamic;\r\n procedure FontChanged; reintroduce; dynamic;\r\n procedure ParentFontChanged; reintroduce; dynamic;\r\n procedure ParentColorChanged; reintroduce; dynamic;\r\n procedure ParentShowHintChanged; reintroduce; dynamic;\r\n function WantKey(Key: Integer; Shift: TShiftState): Boolean; virtual;\r\n function HintShow(var HintInfo: THintInfo): Boolean; reintroduce; dynamic;\r\n function HitTest(X, Y: Integer): Boolean; reintroduce; virtual;\r\n procedure MouseEnter(AControl: TControl); reintroduce; dynamic;\r\n procedure MouseLeave(AControl: TControl); reintroduce; dynamic;\r\n property MouseOver: Boolean read FMouseOver write FMouseOver;\r\n property HintColor: TColor read FHintColor write FHintColor default clDefault;\r\n property OnMouseEnter: TNotifyEvent read FOnMouseEnter write FOnMouseEnter;\r\n property OnMouseLeave: TNotifyEvent read FOnMouseLeave write FOnMouseLeave;\r\n property OnParentColorChange: TNotifyEvent read FOnParentColorChanged write FOnParentColorChanged;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n property HintWindowClass: THintWindowClass read FHintWindowClass write FHintWindowClass;\r\n published\r\n property AboutJVCL: TJVCLAboutInfo read FAboutJVCL write FAboutJVCL stored False;\r\n end;\r\n\r\n TJvExBevel = class(TBevel, IJvExControl)\r\n private\r\n FAboutJVCL: TJVCLAboutInfo;\r\n FHintColor: TColor;\r\n FMouseOver: Boolean;\r\n FHintWindowClass: THintWindowClass;\r\n FOnMouseEnter: TNotifyEvent;\r\n FOnMouseLeave: TNotifyEvent;\r\n FOnParentColorChanged: TNotifyEvent;\r\n function BaseWndProc(Msg: Cardinal; WParam: WPARAM = 0; LParam: LPARAM = 0): LRESULT; overload;\r\n function BaseWndProc(Msg: Cardinal; WParam: WPARAM; LParam: TObject): LRESULT; overload;\r\n function BaseWndProcEx(Msg: Cardinal; WParam: WPARAM; var StructLParam): LRESULT;\r\n protected\r\n procedure WndProc(var Msg: TMessage); override;\r\n procedure FocusChanged(AControl: TWinControl); dynamic;\r\n procedure VisibleChanged; reintroduce; dynamic;\r\n procedure EnabledChanged; reintroduce; dynamic;\r\n procedure TextChanged; reintroduce; virtual;\r\n procedure ColorChanged; reintroduce; dynamic;\r\n procedure FontChanged; reintroduce; dynamic;\r\n procedure ParentFontChanged; reintroduce; dynamic;\r\n procedure ParentColorChanged; reintroduce; dynamic;\r\n procedure ParentShowHintChanged; reintroduce; dynamic;\r\n function WantKey(Key: Integer; Shift: TShiftState): Boolean; virtual;\r\n function HintShow(var HintInfo: THintInfo): Boolean; reintroduce; dynamic;\r\n function HitTest(X, Y: Integer): Boolean; reintroduce; virtual;\r\n procedure MouseEnter(AControl: TControl); reintroduce; dynamic;\r\n procedure MouseLeave(AControl: TControl); reintroduce; dynamic;\r\n property MouseOver: Boolean read FMouseOver write FMouseOver;\r\n property HintColor: TColor read FHintColor write FHintColor default clDefault;\r\n property OnMouseEnter: TNotifyEvent read FOnMouseEnter write FOnMouseEnter;\r\n property OnMouseLeave: TNotifyEvent read FOnMouseLeave write FOnMouseLeave;\r\n property OnParentColorChange: TNotifyEvent read FOnParentColorChanged write FOnParentColorChanged;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n property HintWindowClass: THintWindowClass read FHintWindowClass write FHintWindowClass;\r\n published\r\n property AboutJVCL: TJVCLAboutInfo read FAboutJVCL write FAboutJVCL stored False;\r\n end;\r\n\r\n TJvExCustomPanel = class(TCustomPanel, IJvExControl)\r\n private\r\n FAboutJVCL: TJVCLAboutInfo;\r\n FHintColor: TColor;\r\n FMouseOver: Boolean;\r\n FHintWindowClass: THintWindowClass;\r\n FOnMouseEnter: TNotifyEvent;\r\n FOnMouseLeave: TNotifyEvent;\r\n FOnParentColorChanged: TNotifyEvent;\r\n function BaseWndProc(Msg: Cardinal; WParam: WPARAM = 0; LParam: LPARAM = 0): LRESULT; overload;\r\n function BaseWndProc(Msg: Cardinal; WParam: WPARAM; LParam: TObject): LRESULT; overload;\r\n function BaseWndProcEx(Msg: Cardinal; WParam: WPARAM; var StructLParam): LRESULT;\r\n protected\r\n procedure WndProc(var Msg: TMessage); override;\r\n procedure FocusChanged(AControl: TWinControl); dynamic;\r\n procedure VisibleChanged; reintroduce; dynamic;\r\n procedure EnabledChanged; reintroduce; dynamic;\r\n procedure TextChanged; reintroduce; virtual;\r\n procedure ColorChanged; reintroduce; dynamic;\r\n procedure FontChanged; reintroduce; dynamic;\r\n procedure ParentFontChanged; reintroduce; dynamic;\r\n procedure ParentColorChanged; reintroduce; dynamic;\r\n procedure ParentShowHintChanged; reintroduce; dynamic;\r\n function WantKey(Key: Integer; Shift: TShiftState): Boolean; virtual;\r\n function HintShow(var HintInfo: THintInfo): Boolean; reintroduce; dynamic;\r\n function HitTest(X, Y: Integer): Boolean; reintroduce; virtual;\r\n procedure MouseEnter(AControl: TControl); reintroduce; dynamic;\r\n procedure MouseLeave(AControl: TControl); reintroduce; dynamic;\r\n property MouseOver: Boolean read FMouseOver write FMouseOver;\r\n property HintColor: TColor read FHintColor write FHintColor default clDefault;\r\n property OnMouseEnter: TNotifyEvent read FOnMouseEnter write FOnMouseEnter;\r\n property OnMouseLeave: TNotifyEvent read FOnMouseLeave write FOnMouseLeave;\r\n property OnParentColorChange: TNotifyEvent read FOnParentColorChanged write FOnParentColorChanged;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n property HintWindowClass: THintWindowClass read FHintWindowClass write FHintWindowClass;\r\n published\r\n property AboutJVCL: TJVCLAboutInfo read FAboutJVCL write FAboutJVCL stored False;\r\n private\r\n FDotNetHighlighting: Boolean;\r\n protected\r\n procedure BoundsChanged; reintroduce; virtual;\r\n procedure CursorChanged; reintroduce; dynamic;\r\n procedure ShowingChanged; reintroduce; dynamic;\r\n procedure ShowHintChanged; reintroduce; dynamic;\r\n procedure ControlsListChanging(Control: TControl; Inserting: Boolean); reintroduce; dynamic;\r\n procedure ControlsListChanged(Control: TControl; Inserting: Boolean); reintroduce; dynamic;\r\n procedure GetDlgCode(var Code: TDlgCodes); virtual;\r\n procedure FocusSet(PrevWnd: THandle); virtual;\r\n procedure FocusKilled(NextWnd: THandle); virtual;\r\n function DoEraseBackground(Canvas: TCanvas; Param: LPARAM): Boolean; virtual;\r\n {$IFDEF JVCLThemesEnabledD6}\r\n private\r\n function GetParentBackground: Boolean;\r\n protected\r\n procedure SetParentBackground(Value: Boolean); virtual;\r\n property ParentBackground: Boolean read GetParentBackground write SetParentBackground;\r\n {$ENDIF JVCLThemesEnabledD6}\r\n published\r\n property DotNetHighlighting: Boolean read FDotNetHighlighting write FDotNetHighlighting default False;\r\n end;\r\n\r\n TJvExPubCustomPanel = class(TJvExCustomPanel)\r\n published\r\n property BiDiMode;\r\n property DragCursor;\r\n property DragKind;\r\n property DragMode;\r\n property ParentBiDiMode;\r\n property OnEndDock;\r\n property OnStartDock;\r\n end;\r\n \r\n TJvExCustomRadioGroup = class(TCustomRadioGroup, IJvExControl)\r\n private\r\n FAboutJVCL: TJVCLAboutInfo;\r\n FHintColor: TColor;\r\n FMouseOver: Boolean;\r\n FHintWindowClass: THintWindowClass;\r\n FOnMouseEnter: TNotifyEvent;\r\n FOnMouseLeave: TNotifyEvent;\r\n FOnParentColorChanged: TNotifyEvent;\r\n function BaseWndProc(Msg: Cardinal; WParam: WPARAM = 0; LParam: LPARAM = 0): LRESULT; overload;\r\n function BaseWndProc(Msg: Cardinal; WParam: WPARAM; LParam: TObject): LRESULT; overload;\r\n function BaseWndProcEx(Msg: Cardinal; WParam: WPARAM; var StructLParam): LRESULT;\r\n protected\r\n procedure WndProc(var Msg: TMessage); override;\r\n procedure FocusChanged(AControl: TWinControl); dynamic;\r\n procedure VisibleChanged; reintroduce; dynamic;\r\n procedure EnabledChanged; reintroduce; dynamic;\r\n procedure TextChanged; reintroduce; virtual;\r\n procedure ColorChanged; reintroduce; dynamic;\r\n procedure FontChanged; reintroduce; dynamic;\r\n procedure ParentFontChanged; reintroduce; dynamic;\r\n procedure ParentColorChanged; reintroduce; dynamic;\r\n procedure ParentShowHintChanged; reintroduce; dynamic;\r\n function WantKey(Key: Integer; Shift: TShiftState): Boolean; virtual;\r\n function HintShow(var HintInfo: THintInfo): Boolean; reintroduce; dynamic;\r\n function HitTest(X, Y: Integer): Boolean; reintroduce; virtual;\r\n procedure MouseEnter(AControl: TControl); reintroduce; dynamic;\r\n procedure MouseLeave(AControl: TControl); reintroduce; dynamic;\r\n property MouseOver: Boolean read FMouseOver write FMouseOver;\r\n property HintColor: TColor read FHintColor write FHintColor default clDefault;\r\n property OnMouseEnter: TNotifyEvent read FOnMouseEnter write FOnMouseEnter;\r\n property OnMouseLeave: TNotifyEvent read FOnMouseLeave write FOnMouseLeave;\r\n property OnParentColorChange: TNotifyEvent read FOnParentColorChanged write FOnParentColorChanged;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n property HintWindowClass: THintWindowClass read FHintWindowClass write FHintWindowClass;\r\n published\r\n property AboutJVCL: TJVCLAboutInfo read FAboutJVCL write FAboutJVCL stored False;\r\n private\r\n FDotNetHighlighting: Boolean;\r\n protected\r\n procedure BoundsChanged; reintroduce; virtual;\r\n procedure CursorChanged; reintroduce; dynamic;\r\n procedure ShowingChanged; reintroduce; dynamic;\r\n procedure ShowHintChanged; reintroduce; dynamic;\r\n procedure ControlsListChanging(Control: TControl; Inserting: Boolean); reintroduce; dynamic;\r\n procedure ControlsListChanged(Control: TControl; Inserting: Boolean); reintroduce; dynamic;\r\n procedure GetDlgCode(var Code: TDlgCodes); virtual;\r\n procedure FocusSet(PrevWnd: THandle); virtual;\r\n procedure FocusKilled(NextWnd: THandle); virtual;\r\n function DoEraseBackground(Canvas: TCanvas; Param: LPARAM): Boolean; virtual;\r\n {$IFDEF JVCLThemesEnabledD6}\r\n private\r\n function GetParentBackground: Boolean;\r\n protected\r\n procedure SetParentBackground(Value: Boolean); virtual;\r\n property ParentBackground: Boolean read GetParentBackground write SetParentBackground;\r\n {$ENDIF JVCLThemesEnabledD6}\r\n published\r\n property DotNetHighlighting: Boolean read FDotNetHighlighting write FDotNetHighlighting default False;\r\n end;\r\n\r\n TJvExSplitter = class(TSplitter, IJvExControl)\r\n private\r\n FAboutJVCL: TJVCLAboutInfo;\r\n FHintColor: TColor;\r\n FMouseOver: Boolean;\r\n FHintWindowClass: THintWindowClass;\r\n FOnMouseEnter: TNotifyEvent;\r\n FOnMouseLeave: TNotifyEvent;\r\n FOnParentColorChanged: TNotifyEvent;\r\n function BaseWndProc(Msg: Cardinal; WParam: WPARAM = 0; LParam: LPARAM = 0): LRESULT; overload;\r\n function BaseWndProc(Msg: Cardinal; WParam: WPARAM; LParam: TObject): LRESULT; overload;\r\n function BaseWndProcEx(Msg: Cardinal; WParam: WPARAM; var StructLParam): LRESULT;\r\n protected\r\n procedure WndProc(var Msg: TMessage); override;\r\n procedure FocusChanged(AControl: TWinControl); dynamic;\r\n procedure VisibleChanged; reintroduce; dynamic;\r\n procedure EnabledChanged; reintroduce; dynamic;\r\n procedure TextChanged; reintroduce; virtual;\r\n procedure ColorChanged; reintroduce; dynamic;\r\n procedure FontChanged; reintroduce; dynamic;\r\n procedure ParentFontChanged; reintroduce; dynamic;\r\n procedure ParentColorChanged; reintroduce; dynamic;\r\n procedure ParentShowHintChanged; reintroduce; dynamic;\r\n function WantKey(Key: Integer; Shift: TShiftState): Boolean; virtual;\r\n function HintShow(var HintInfo: THintInfo): Boolean; reintroduce; dynamic;\r\n function HitTest(X, Y: Integer): Boolean; reintroduce; virtual;\r\n procedure MouseEnter(AControl: TControl); reintroduce; dynamic;\r\n procedure MouseLeave(AControl: TControl); reintroduce; dynamic;\r\n property MouseOver: Boolean read FMouseOver write FMouseOver;\r\n property HintColor: TColor read FHintColor write FHintColor default clDefault;\r\n property OnMouseEnter: TNotifyEvent read FOnMouseEnter write FOnMouseEnter;\r\n property OnMouseLeave: TNotifyEvent read FOnMouseLeave write FOnMouseLeave;\r\n property OnParentColorChange: TNotifyEvent read FOnParentColorChanged write FOnParentColorChanged;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n property HintWindowClass: THintWindowClass read FHintWindowClass write FHintWindowClass;\r\n published\r\n property AboutJVCL: TJVCLAboutInfo read FAboutJVCL write FAboutJVCL stored False;\r\n protected\r\n procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;\r\n end;\r\n\r\n TJvExCustomControlBar = class(TCustomControlBar, IJvExControl)\r\n private\r\n FAboutJVCL: TJVCLAboutInfo;\r\n FHintColor: TColor;\r\n FMouseOver: Boolean;\r\n FHintWindowClass: THintWindowClass;\r\n FOnMouseEnter: TNotifyEvent;\r\n FOnMouseLeave: TNotifyEvent;\r\n FOnParentColorChanged: TNotifyEvent;\r\n function BaseWndProc(Msg: Cardinal; WParam: WPARAM = 0; LParam: LPARAM = 0): LRESULT; overload;\r\n function BaseWndProc(Msg: Cardinal; WParam: WPARAM; LParam: TObject): LRESULT; overload;\r\n function BaseWndProcEx(Msg: Cardinal; WParam: WPARAM; var StructLParam): LRESULT;\r\n protected\r\n procedure WndProc(var Msg: TMessage); override;\r\n procedure FocusChanged(AControl: TWinControl); dynamic;\r\n procedure VisibleChanged; reintroduce; dynamic;\r\n procedure EnabledChanged; reintroduce; dynamic;\r\n procedure TextChanged; reintroduce; virtual;\r\n procedure ColorChanged; reintroduce; dynamic;\r\n procedure FontChanged; reintroduce; dynamic;\r\n procedure ParentFontChanged; reintroduce; dynamic;\r\n procedure ParentColorChanged; reintroduce; dynamic;\r\n procedure ParentShowHintChanged; reintroduce; dynamic;\r\n function WantKey(Key: Integer; Shift: TShiftState): Boolean; virtual;\r\n function HintShow(var HintInfo: THintInfo): Boolean; reintroduce; dynamic;\r\n function HitTest(X, Y: Integer): Boolean; reintroduce; virtual;\r\n procedure MouseEnter(AControl: TControl); reintroduce; dynamic;\r\n procedure MouseLeave(AControl: TControl); reintroduce; dynamic;\r\n property MouseOver: Boolean read FMouseOver write FMouseOver;\r\n property HintColor: TColor read FHintColor write FHintColor default clDefault;\r\n property OnMouseEnter: TNotifyEvent read FOnMouseEnter write FOnMouseEnter;\r\n property OnMouseLeave: TNotifyEvent read FOnMouseLeave write FOnMouseLeave;\r\n property OnParentColorChange: TNotifyEvent read FOnParentColorChanged write FOnParentColorChanged;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n property HintWindowClass: THintWindowClass read FHintWindowClass write FHintWindowClass;\r\n published\r\n property AboutJVCL: TJVCLAboutInfo read FAboutJVCL write FAboutJVCL stored False;\r\n private\r\n FDotNetHighlighting: Boolean;\r\n protected\r\n procedure BoundsChanged; reintroduce; virtual;\r\n procedure CursorChanged; reintroduce; dynamic;\r\n procedure ShowingChanged; reintroduce; dynamic;\r\n procedure ShowHintChanged; reintroduce; dynamic;\r\n procedure ControlsListChanging(Control: TControl; Inserting: Boolean); reintroduce; dynamic;\r\n procedure ControlsListChanged(Control: TControl; Inserting: Boolean); reintroduce; dynamic;\r\n procedure GetDlgCode(var Code: TDlgCodes); virtual;\r\n procedure FocusSet(PrevWnd: THandle); virtual;\r\n procedure FocusKilled(NextWnd: THandle); virtual;\r\n function DoEraseBackground(Canvas: TCanvas; Param: LPARAM): Boolean; virtual;\r\n {$IFDEF JVCLThemesEnabledD6}\r\n private\r\n function GetParentBackground: Boolean;\r\n protected\r\n procedure SetParentBackground(Value: Boolean); virtual;\r\n property ParentBackground: Boolean read GetParentBackground write SetParentBackground;\r\n {$ENDIF JVCLThemesEnabledD6}\r\n published\r\n property DotNetHighlighting: Boolean read FDotNetHighlighting write FDotNetHighlighting default False;\r\n end;\r\n\r\n TJvExControlBar = class(TControlBar, IJvExControl)\r\n private\r\n FAboutJVCL: TJVCLAboutInfo;\r\n FHintColor: TColor;\r\n FMouseOver: Boolean;\r\n FHintWindowClass: THintWindowClass;\r\n FOnMouseEnter: TNotifyEvent;\r\n FOnMouseLeave: TNotifyEvent;\r\n FOnParentColorChanged: TNotifyEvent;\r\n function BaseWndProc(Msg: Cardinal; WParam: WPARAM = 0; LParam: LPARAM = 0): LRESULT; overload;\r\n function BaseWndProc(Msg: Cardinal; WParam: WPARAM; LParam: TObject): LRESULT; overload;\r\n function BaseWndProcEx(Msg: Cardinal; WParam: WPARAM; var StructLParam): LRESULT;\r\n protected\r\n procedure WndProc(var Msg: TMessage); override;\r\n procedure FocusChanged(AControl: TWinControl); dynamic;\r\n procedure VisibleChanged; reintroduce; dynamic;\r\n procedure EnabledChanged; reintroduce; dynamic;\r\n procedure TextChanged; reintroduce; virtual;\r\n procedure ColorChanged; reintroduce; dynamic;\r\n procedure FontChanged; reintroduce; dynamic;\r\n procedure ParentFontChanged; reintroduce; dynamic;\r\n procedure ParentColorChanged; reintroduce; dynamic;\r\n procedure ParentShowHintChanged; reintroduce; dynamic;\r\n function WantKey(Key: Integer; Shift: TShiftState): Boolean; virtual;\r\n function HintShow(var HintInfo: THintInfo): Boolean; reintroduce; dynamic;\r\n function HitTest(X, Y: Integer): Boolean; reintroduce; virtual;\r\n procedure MouseEnter(AControl: TControl); reintroduce; dynamic;\r\n procedure MouseLeave(AControl: TControl); reintroduce; dynamic;\r\n property MouseOver: Boolean read FMouseOver write FMouseOver;\r\n property HintColor: TColor read FHintColor write FHintColor default clDefault;\r\n property OnMouseEnter: TNotifyEvent read FOnMouseEnter write FOnMouseEnter;\r\n property OnMouseLeave: TNotifyEvent read FOnMouseLeave write FOnMouseLeave;\r\n property OnParentColorChange: TNotifyEvent read FOnParentColorChanged write FOnParentColorChanged;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n property HintWindowClass: THintWindowClass read FHintWindowClass write FHintWindowClass;\r\n published\r\n property AboutJVCL: TJVCLAboutInfo read FAboutJVCL write FAboutJVCL stored False;\r\n private\r\n FDotNetHighlighting: Boolean;\r\n protected\r\n procedure BoundsChanged; reintroduce; virtual;\r\n procedure CursorChanged; reintroduce; dynamic;\r\n procedure ShowingChanged; reintroduce; dynamic;\r\n procedure ShowHintChanged; reintroduce; dynamic;\r\n procedure ControlsListChanging(Control: TControl; Inserting: Boolean); reintroduce; dynamic;\r\n procedure ControlsListChanged(Control: TControl; Inserting: Boolean); reintroduce; dynamic;\r\n procedure GetDlgCode(var Code: TDlgCodes); virtual;\r\n procedure FocusSet(PrevWnd: THandle); virtual;\r\n procedure FocusKilled(NextWnd: THandle); virtual;\r\n function DoEraseBackground(Canvas: TCanvas; Param: LPARAM): Boolean; virtual;\r\n {$IFDEF JVCLThemesEnabledD6}\r\n private\r\n function GetParentBackground: Boolean;\r\n protected\r\n procedure SetParentBackground(Value: Boolean); virtual;\r\n property ParentBackground: Boolean read GetParentBackground write SetParentBackground;\r\n {$ENDIF JVCLThemesEnabledD6}\r\n published\r\n property DotNetHighlighting: Boolean read FDotNetHighlighting write FDotNetHighlighting default False;\r\n end;\r\n\r\n TJvExPanel = class(TPanel, IJvExControl)\r\n private\r\n FAboutJVCL: TJVCLAboutInfo;\r\n FHintColor: TColor;\r\n FMouseOver: Boolean;\r\n FHintWindowClass: THintWindowClass;\r\n FOnMouseEnter: TNotifyEvent;\r\n FOnMouseLeave: TNotifyEvent;\r\n FOnParentColorChanged: TNotifyEvent;\r\n function BaseWndProc(Msg: Cardinal; WParam: WPARAM = 0; LParam: LPARAM = 0): LRESULT; overload;\r\n function BaseWndProc(Msg: Cardinal; WParam: WPARAM; LParam: TObject): LRESULT; overload;\r\n function BaseWndProcEx(Msg: Cardinal; WParam: WPARAM; var StructLParam): LRESULT;\r\n protected\r\n procedure WndProc(var Msg: TMessage); override;\r\n procedure FocusChanged(AControl: TWinControl); dynamic;\r\n procedure VisibleChanged; reintroduce; dynamic;\r\n procedure EnabledChanged; reintroduce; dynamic;\r\n procedure TextChanged; reintroduce; virtual;\r\n procedure ColorChanged; reintroduce; dynamic;\r\n procedure FontChanged; reintroduce; dynamic;\r\n procedure ParentFontChanged; reintroduce; dynamic;\r\n procedure ParentColorChanged; reintroduce; dynamic;\r\n procedure ParentShowHintChanged; reintroduce; dynamic;\r\n function WantKey(Key: Integer; Shift: TShiftState): Boolean; virtual;\r\n function HintShow(var HintInfo: THintInfo): Boolean; reintroduce; dynamic;\r\n function HitTest(X, Y: Integer): Boolean; reintroduce; virtual;\r\n procedure MouseEnter(AControl: TControl); reintroduce; dynamic;\r\n procedure MouseLeave(AControl: TControl); reintroduce; dynamic;\r\n property MouseOver: Boolean read FMouseOver write FMouseOver;\r\n property HintColor: TColor read FHintColor write FHintColor default clDefault;\r\n property OnMouseEnter: TNotifyEvent read FOnMouseEnter write FOnMouseEnter;\r\n property OnMouseLeave: TNotifyEvent read FOnMouseLeave write FOnMouseLeave;\r\n property OnParentColorChange: TNotifyEvent read FOnParentColorChanged write FOnParentColorChanged;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n property HintWindowClass: THintWindowClass read FHintWindowClass write FHintWindowClass;\r\n published\r\n property AboutJVCL: TJVCLAboutInfo read FAboutJVCL write FAboutJVCL stored False;\r\n private\r\n FDotNetHighlighting: Boolean;\r\n protected\r\n procedure BoundsChanged; reintroduce; virtual;\r\n procedure CursorChanged; reintroduce; dynamic;\r\n procedure ShowingChanged; reintroduce; dynamic;\r\n procedure ShowHintChanged; reintroduce; dynamic;\r\n procedure ControlsListChanging(Control: TControl; Inserting: Boolean); reintroduce; dynamic;\r\n procedure ControlsListChanged(Control: TControl; Inserting: Boolean); reintroduce; dynamic;\r\n procedure GetDlgCode(var Code: TDlgCodes); virtual;\r\n procedure FocusSet(PrevWnd: THandle); virtual;\r\n procedure FocusKilled(NextWnd: THandle); virtual;\r\n function DoEraseBackground(Canvas: TCanvas; Param: LPARAM): Boolean; virtual;\r\n {$IFDEF JVCLThemesEnabledD6}\r\n private\r\n function GetParentBackground: Boolean;\r\n protected\r\n procedure SetParentBackground(Value: Boolean); virtual;\r\n property ParentBackground: Boolean read GetParentBackground write SetParentBackground;\r\n {$ENDIF JVCLThemesEnabledD6}\r\n published\r\n property DotNetHighlighting: Boolean read FDotNetHighlighting write FDotNetHighlighting default False;\r\n end;\r\n\r\n TJvExRadioGroup = class(TRadioGroup, IJvExControl)\r\n private\r\n FAboutJVCL: TJVCLAboutInfo;\r\n FHintColor: TColor;\r\n FMouseOver: Boolean;\r\n FHintWindowClass: THintWindowClass;\r\n FOnMouseEnter: TNotifyEvent;\r\n FOnMouseLeave: TNotifyEvent;\r\n FOnParentColorChanged: TNotifyEvent;\r\n function BaseWndProc(Msg: Cardinal; WParam: WPARAM = 0; LParam: LPARAM = 0): LRESULT; overload;\r\n function BaseWndProc(Msg: Cardinal; WParam: WPARAM; LParam: TObject): LRESULT; overload;\r\n function BaseWndProcEx(Msg: Cardinal; WParam: WPARAM; var StructLParam): LRESULT;\r\n protected\r\n procedure WndProc(var Msg: TMessage); override;\r\n procedure FocusChanged(AControl: TWinControl); dynamic;\r\n procedure VisibleChanged; reintroduce; dynamic;\r\n procedure EnabledChanged; reintroduce; dynamic;\r\n procedure TextChanged; reintroduce; virtual;\r\n procedure ColorChanged; reintroduce; dynamic;\r\n procedure FontChanged; reintroduce; dynamic;\r\n procedure ParentFontChanged; reintroduce; dynamic;\r\n procedure ParentColorChanged; reintroduce; dynamic;\r\n procedure ParentShowHintChanged; reintroduce; dynamic;\r\n function WantKey(Key: Integer; Shift: TShiftState): Boolean; virtual;\r\n function HintShow(var HintInfo: THintInfo): Boolean; reintroduce; dynamic;\r\n function HitTest(X, Y: Integer): Boolean; reintroduce; virtual;\r\n procedure MouseEnter(AControl: TControl); reintroduce; dynamic;\r\n procedure MouseLeave(AControl: TControl); reintroduce; dynamic;\r\n property MouseOver: Boolean read FMouseOver write FMouseOver;\r\n property HintColor: TColor read FHintColor write FHintColor default clDefault;\r\n property OnMouseEnter: TNotifyEvent read FOnMouseEnter write FOnMouseEnter;\r\n property OnMouseLeave: TNotifyEvent read FOnMouseLeave write FOnMouseLeave;\r\n property OnParentColorChange: TNotifyEvent read FOnParentColorChanged write FOnParentColorChanged;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n property HintWindowClass: THintWindowClass read FHintWindowClass write FHintWindowClass;\r\n published\r\n property AboutJVCL: TJVCLAboutInfo read FAboutJVCL write FAboutJVCL stored False;\r\n private\r\n FDotNetHighlighting: Boolean;\r\n protected\r\n procedure BoundsChanged; reintroduce; virtual;\r\n procedure CursorChanged; reintroduce; dynamic;\r\n procedure ShowingChanged; reintroduce; dynamic;\r\n procedure ShowHintChanged; reintroduce; dynamic;\r\n procedure ControlsListChanging(Control: TControl; Inserting: Boolean); reintroduce; dynamic;\r\n procedure ControlsListChanged(Control: TControl; Inserting: Boolean); reintroduce; dynamic;\r\n procedure GetDlgCode(var Code: TDlgCodes); virtual;\r\n procedure FocusSet(PrevWnd: THandle); virtual;\r\n procedure FocusKilled(NextWnd: THandle); virtual;\r\n function DoEraseBackground(Canvas: TCanvas; Param: LPARAM): Boolean; virtual;\r\n {$IFDEF JVCLThemesEnabledD6}\r\n private\r\n function GetParentBackground: Boolean;\r\n protected\r\n procedure SetParentBackground(Value: Boolean); virtual;\r\n property ParentBackground: Boolean read GetParentBackground write SetParentBackground;\r\n {$ENDIF JVCLThemesEnabledD6}\r\n published\r\n property DotNetHighlighting: Boolean read FDotNetHighlighting write FDotNetHighlighting default False;\r\n end;\r\n\r\n TJvExPage = class(TPage, IJvExControl)\r\n private\r\n FAboutJVCL: TJVCLAboutInfo;\r\n FHintColor: TColor;\r\n FMouseOver: Boolean;\r\n FHintWindowClass: THintWindowClass;\r\n FOnMouseEnter: TNotifyEvent;\r\n FOnMouseLeave: TNotifyEvent;\r\n FOnParentColorChanged: TNotifyEvent;\r\n function BaseWndProc(Msg: Cardinal; WParam: WPARAM = 0; LParam: LPARAM = 0): LRESULT; overload;\r\n function BaseWndProc(Msg: Cardinal; WParam: WPARAM; LParam: TObject): LRESULT; overload;\r\n function BaseWndProcEx(Msg: Cardinal; WParam: WPARAM; var StructLParam): LRESULT;\r\n protected\r\n procedure WndProc(var Msg: TMessage); override;\r\n procedure FocusChanged(AControl: TWinControl); dynamic;\r\n procedure VisibleChanged; reintroduce; dynamic;\r\n procedure EnabledChanged; reintroduce; dynamic;\r\n procedure TextChanged; reintroduce; virtual;\r\n procedure ColorChanged; reintroduce; dynamic;\r\n procedure FontChanged; reintroduce; dynamic;\r\n procedure ParentFontChanged; reintroduce; dynamic;\r\n procedure ParentColorChanged; reintroduce; dynamic;\r\n procedure ParentShowHintChanged; reintroduce; dynamic;\r\n function WantKey(Key: Integer; Shift: TShiftState): Boolean; virtual;\r\n function HintShow(var HintInfo: THintInfo): Boolean; reintroduce; dynamic;\r\n function HitTest(X, Y: Integer): Boolean; reintroduce; virtual;\r\n procedure MouseEnter(AControl: TControl); reintroduce; dynamic;\r\n procedure MouseLeave(AControl: TControl); reintroduce; dynamic;\r\n property MouseOver: Boolean read FMouseOver write FMouseOver;\r\n property HintColor: TColor read FHintColor write FHintColor default clDefault;\r\n property OnMouseEnter: TNotifyEvent read FOnMouseEnter write FOnMouseEnter;\r\n property OnMouseLeave: TNotifyEvent read FOnMouseLeave write FOnMouseLeave;\r\n property OnParentColorChange: TNotifyEvent read FOnParentColorChanged write FOnParentColorChanged;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n property HintWindowClass: THintWindowClass read FHintWindowClass write FHintWindowClass;\r\n published\r\n property AboutJVCL: TJVCLAboutInfo read FAboutJVCL write FAboutJVCL stored False;\r\n private\r\n FDotNetHighlighting: Boolean;\r\n protected\r\n procedure BoundsChanged; reintroduce; virtual;\r\n procedure CursorChanged; reintroduce; dynamic;\r\n procedure ShowingChanged; reintroduce; dynamic;\r\n procedure ShowHintChanged; reintroduce; dynamic;\r\n procedure ControlsListChanging(Control: TControl; Inserting: Boolean); reintroduce; dynamic;\r\n procedure ControlsListChanged(Control: TControl; Inserting: Boolean); reintroduce; dynamic;\r\n procedure GetDlgCode(var Code: TDlgCodes); virtual;\r\n procedure FocusSet(PrevWnd: THandle); virtual;\r\n procedure FocusKilled(NextWnd: THandle); virtual;\r\n function DoEraseBackground(Canvas: TCanvas; Param: LPARAM): Boolean; virtual;\r\n {$IFDEF JVCLThemesEnabledD6}\r\n private\r\n function GetParentBackground: Boolean;\r\n protected\r\n procedure SetParentBackground(Value: Boolean); virtual;\r\n property ParentBackground: Boolean read GetParentBackground write SetParentBackground;\r\n {$ENDIF JVCLThemesEnabledD6}\r\n published\r\n property DotNetHighlighting: Boolean read FDotNetHighlighting write FDotNetHighlighting default False;\r\n end;\r\n\r\n TJvExNotebook = class(TNotebook, IJvExControl)\r\n private\r\n FAboutJVCL: TJVCLAboutInfo;\r\n FHintColor: TColor;\r\n FMouseOver: Boolean;\r\n FHintWindowClass: THintWindowClass;\r\n FOnMouseEnter: TNotifyEvent;\r\n FOnMouseLeave: TNotifyEvent;\r\n FOnParentColorChanged: TNotifyEvent;\r\n function BaseWndProc(Msg: Cardinal; WParam: WPARAM = 0; LParam: LPARAM = 0): LRESULT; overload;\r\n function BaseWndProc(Msg: Cardinal; WParam: WPARAM; LParam: TObject): LRESULT; overload;\r\n function BaseWndProcEx(Msg: Cardinal; WParam: WPARAM; var StructLParam): LRESULT;\r\n protected\r\n procedure WndProc(var Msg: TMessage); override;\r\n procedure FocusChanged(AControl: TWinControl); dynamic;\r\n procedure VisibleChanged; reintroduce; dynamic;\r\n procedure EnabledChanged; reintroduce; dynamic;\r\n procedure TextChanged; reintroduce; virtual;\r\n procedure ColorChanged; reintroduce; dynamic;\r\n procedure FontChanged; reintroduce; dynamic;\r\n procedure ParentFontChanged; reintroduce; dynamic;\r\n procedure ParentColorChanged; reintroduce; dynamic;\r\n procedure ParentShowHintChanged; reintroduce; dynamic;\r\n function WantKey(Key: Integer; Shift: TShiftState): Boolean; virtual;\r\n function HintShow(var HintInfo: THintInfo): Boolean; reintroduce; dynamic;\r\n function HitTest(X, Y: Integer): Boolean; reintroduce; virtual;\r\n procedure MouseEnter(AControl: TControl); reintroduce; dynamic;\r\n procedure MouseLeave(AControl: TControl); reintroduce; dynamic;\r\n property MouseOver: Boolean read FMouseOver write FMouseOver;\r\n property HintColor: TColor read FHintColor write FHintColor default clDefault;\r\n property OnMouseEnter: TNotifyEvent read FOnMouseEnter write FOnMouseEnter;\r\n property OnMouseLeave: TNotifyEvent read FOnMouseLeave write FOnMouseLeave;\r\n property OnParentColorChange: TNotifyEvent read FOnParentColorChanged write FOnParentColorChanged;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n property HintWindowClass: THintWindowClass read FHintWindowClass write FHintWindowClass;\r\n published\r\n property AboutJVCL: TJVCLAboutInfo read FAboutJVCL write FAboutJVCL stored False;\r\n private\r\n FDotNetHighlighting: Boolean;\r\n protected\r\n procedure BoundsChanged; reintroduce; virtual;\r\n procedure CursorChanged; reintroduce; dynamic;\r\n procedure ShowingChanged; reintroduce; dynamic;\r\n procedure ShowHintChanged; reintroduce; dynamic;\r\n procedure ControlsListChanging(Control: TControl; Inserting: Boolean); reintroduce; dynamic;\r\n procedure ControlsListChanged(Control: TControl; Inserting: Boolean); reintroduce; dynamic;\r\n procedure GetDlgCode(var Code: TDlgCodes); virtual;\r\n procedure FocusSet(PrevWnd: THandle); virtual;\r\n procedure FocusKilled(NextWnd: THandle); virtual;\r\n function DoEraseBackground(Canvas: TCanvas; Param: LPARAM): Boolean; virtual;\r\n {$IFDEF JVCLThemesEnabledD6}\r\n private\r\n function GetParentBackground: Boolean;\r\n protected\r\n procedure SetParentBackground(Value: Boolean); virtual;\r\n property ParentBackground: Boolean read GetParentBackground write SetParentBackground;\r\n {$ENDIF JVCLThemesEnabledD6}\r\n published\r\n property DotNetHighlighting: Boolean read FDotNetHighlighting write FDotNetHighlighting default False;\r\n end;\r\n\r\n TJvExHeader = class(THeader, IJvExControl)\r\n private\r\n FAboutJVCL: TJVCLAboutInfo;\r\n FHintColor: TColor;\r\n FMouseOver: Boolean;\r\n FHintWindowClass: THintWindowClass;\r\n FOnMouseEnter: TNotifyEvent;\r\n FOnMouseLeave: TNotifyEvent;\r\n FOnParentColorChanged: TNotifyEvent;\r\n function BaseWndProc(Msg: Cardinal; WParam: WPARAM = 0; LParam: LPARAM = 0): LRESULT; overload;\r\n function BaseWndProc(Msg: Cardinal; WParam: WPARAM; LParam: TObject): LRESULT; overload;\r\n function BaseWndProcEx(Msg: Cardinal; WParam: WPARAM; var StructLParam): LRESULT;\r\n protected\r\n procedure WndProc(var Msg: TMessage); override;\r\n procedure FocusChanged(AControl: TWinControl); dynamic;\r\n procedure VisibleChanged; reintroduce; dynamic;\r\n procedure EnabledChanged; reintroduce; dynamic;\r\n procedure TextChanged; reintroduce; virtual;\r\n procedure ColorChanged; reintroduce; dynamic;\r\n procedure FontChanged; reintroduce; dynamic;\r\n procedure ParentFontChanged; reintroduce; dynamic;\r\n procedure ParentColorChanged; reintroduce; dynamic;\r\n procedure ParentShowHintChanged; reintroduce; dynamic;\r\n function WantKey(Key: Integer; Shift: TShiftState): Boolean; virtual;\r\n function HintShow(var HintInfo: THintInfo): Boolean; reintroduce; dynamic;\r\n function HitTest(X, Y: Integer): Boolean; reintroduce; virtual;\r\n procedure MouseEnter(AControl: TControl); reintroduce; dynamic;\r\n procedure MouseLeave(AControl: TControl); reintroduce; dynamic;\r\n property MouseOver: Boolean read FMouseOver write FMouseOver;\r\n property HintColor: TColor read FHintColor write FHintColor default clDefault;\r\n property OnMouseEnter: TNotifyEvent read FOnMouseEnter write FOnMouseEnter;\r\n property OnMouseLeave: TNotifyEvent read FOnMouseLeave write FOnMouseLeave;\r\n property OnParentColorChange: TNotifyEvent read FOnParentColorChanged write FOnParentColorChanged;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n property HintWindowClass: THintWindowClass read FHintWindowClass write FHintWindowClass;\r\n published\r\n property AboutJVCL: TJVCLAboutInfo read FAboutJVCL write FAboutJVCL stored False;\r\n private\r\n FDotNetHighlighting: Boolean;\r\n protected\r\n procedure BoundsChanged; reintroduce; virtual;\r\n procedure CursorChanged; reintroduce; dynamic;\r\n procedure ShowingChanged; reintroduce; dynamic;\r\n procedure ShowHintChanged; reintroduce; dynamic;\r\n procedure ControlsListChanging(Control: TControl; Inserting: Boolean); reintroduce; dynamic;\r\n procedure ControlsListChanged(Control: TControl; Inserting: Boolean); reintroduce; dynamic;\r\n procedure GetDlgCode(var Code: TDlgCodes); virtual;\r\n procedure FocusSet(PrevWnd: THandle); virtual;\r\n procedure FocusKilled(NextWnd: THandle); virtual;\r\n function DoEraseBackground(Canvas: TCanvas; Param: LPARAM): Boolean; virtual;\r\n {$IFDEF JVCLThemesEnabledD6}\r\n private\r\n function GetParentBackground: Boolean;\r\n protected\r\n procedure SetParentBackground(Value: Boolean); virtual;\r\n property ParentBackground: Boolean read GetParentBackground write SetParentBackground;\r\n {$ENDIF JVCLThemesEnabledD6}\r\n published\r\n property DotNetHighlighting: Boolean read FDotNetHighlighting write FDotNetHighlighting default False;\r\n end;\r\n\r\n TJvExBoundLabel = class(TBoundLabel, IJvExControl)\r\n private\r\n FAboutJVCL: TJVCLAboutInfo;\r\n FHintColor: TColor;\r\n FMouseOver: Boolean;\r\n FHintWindowClass: THintWindowClass;\r\n FOnMouseEnter: TNotifyEvent;\r\n FOnMouseLeave: TNotifyEvent;\r\n FOnParentColorChanged: TNotifyEvent;\r\n function BaseWndProc(Msg: Cardinal; WParam: WPARAM = 0; LParam: LPARAM = 0): LRESULT; overload;\r\n function BaseWndProc(Msg: Cardinal; WParam: WPARAM; LParam: TObject): LRESULT; overload;\r\n function BaseWndProcEx(Msg: Cardinal; WParam: WPARAM; var StructLParam): LRESULT;\r\n protected\r\n procedure WndProc(var Msg: TMessage); override;\r\n procedure FocusChanged(AControl: TWinControl); dynamic;\r\n procedure VisibleChanged; reintroduce; dynamic;\r\n procedure EnabledChanged; reintroduce; dynamic;\r\n procedure TextChanged; reintroduce; virtual;\r\n procedure ColorChanged; reintroduce; dynamic;\r\n procedure FontChanged; reintroduce; dynamic;\r\n procedure ParentFontChanged; reintroduce; dynamic;\r\n procedure ParentColorChanged; reintroduce; dynamic;\r\n procedure ParentShowHintChanged; reintroduce; dynamic;\r\n function WantKey(Key: Integer; Shift: TShiftState): Boolean; virtual;\r\n function HintShow(var HintInfo: THintInfo): Boolean; reintroduce; dynamic;\r\n function HitTest(X, Y: Integer): Boolean; reintroduce; virtual;\r\n procedure MouseEnter(AControl: TControl); reintroduce; dynamic;\r\n procedure MouseLeave(AControl: TControl); reintroduce; dynamic;\r\n property MouseOver: Boolean read FMouseOver write FMouseOver;\r\n property HintColor: TColor read FHintColor write FHintColor default clDefault;\r\n property OnMouseEnter: TNotifyEvent read FOnMouseEnter write FOnMouseEnter;\r\n property OnMouseLeave: TNotifyEvent read FOnMouseLeave write FOnMouseLeave;\r\n property OnParentColorChange: TNotifyEvent read FOnParentColorChanged write FOnParentColorChanged;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n property HintWindowClass: THintWindowClass read FHintWindowClass write FHintWindowClass;\r\n published\r\n property AboutJVCL: TJVCLAboutInfo read FAboutJVCL write FAboutJVCL stored False;\r\n end;\r\n\r\n TJvExCustomLabeledEdit = class(TCustomLabeledEdit, IJvExControl)\r\n private\r\n FAboutJVCL: TJVCLAboutInfo;\r\n FHintColor: TColor;\r\n FMouseOver: Boolean;\r\n FHintWindowClass: THintWindowClass;\r\n FOnMouseEnter: TNotifyEvent;\r\n FOnMouseLeave: TNotifyEvent;\r\n FOnParentColorChanged: TNotifyEvent;\r\n function BaseWndProc(Msg: Cardinal; WParam: WPARAM = 0; LParam: LPARAM = 0): LRESULT; overload;\r\n function BaseWndProc(Msg: Cardinal; WParam: WPARAM; LParam: TObject): LRESULT; overload;\r\n function BaseWndProcEx(Msg: Cardinal; WParam: WPARAM; var StructLParam): LRESULT;\r\n protected\r\n procedure WndProc(var Msg: TMessage); override;\r\n procedure FocusChanged(AControl: TWinControl); dynamic;\r\n procedure VisibleChanged; reintroduce; dynamic;\r\n procedure EnabledChanged; reintroduce; dynamic;\r\n procedure TextChanged; reintroduce; virtual;\r\n procedure ColorChanged; reintroduce; dynamic;\r\n procedure FontChanged; reintroduce; dynamic;\r\n procedure ParentFontChanged; reintroduce; dynamic;\r\n procedure ParentColorChanged; reintroduce; dynamic;\r\n procedure ParentShowHintChanged; reintroduce; dynamic;\r\n function WantKey(Key: Integer; Shift: TShiftState): Boolean; virtual;\r\n function HintShow(var HintInfo: THintInfo): Boolean; reintroduce; dynamic;\r\n function HitTest(X, Y: Integer): Boolean; reintroduce; virtual;\r\n procedure MouseEnter(AControl: TControl); reintroduce; dynamic;\r\n procedure MouseLeave(AControl: TControl); reintroduce; dynamic;\r\n property MouseOver: Boolean read FMouseOver write FMouseOver;\r\n property HintColor: TColor read FHintColor write FHintColor default clDefault;\r\n property OnMouseEnter: TNotifyEvent read FOnMouseEnter write FOnMouseEnter;\r\n property OnMouseLeave: TNotifyEvent read FOnMouseLeave write FOnMouseLeave;\r\n property OnParentColorChange: TNotifyEvent read FOnParentColorChanged write FOnParentColorChanged;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n property HintWindowClass: THintWindowClass read FHintWindowClass write FHintWindowClass;\r\n published\r\n property AboutJVCL: TJVCLAboutInfo read FAboutJVCL write FAboutJVCL stored False;\r\n private\r\n FDotNetHighlighting: Boolean;\r\n protected\r\n procedure BoundsChanged; reintroduce; virtual;\r\n procedure CursorChanged; reintroduce; dynamic;\r\n procedure ShowingChanged; reintroduce; dynamic;\r\n procedure ShowHintChanged; reintroduce; dynamic;\r\n procedure ControlsListChanging(Control: TControl; Inserting: Boolean); reintroduce; dynamic;\r\n procedure ControlsListChanged(Control: TControl; Inserting: Boolean); reintroduce; dynamic;\r\n procedure GetDlgCode(var Code: TDlgCodes); virtual;\r\n procedure FocusSet(PrevWnd: THandle); virtual;\r\n procedure FocusKilled(NextWnd: THandle); virtual;\r\n function DoEraseBackground(Canvas: TCanvas; Param: LPARAM): Boolean; virtual;\r\n {$IFDEF JVCLThemesEnabledD6}\r\n private\r\n function GetParentBackground: Boolean;\r\n protected\r\n procedure SetParentBackground(Value: Boolean); virtual;\r\n property ParentBackground: Boolean read GetParentBackground write SetParentBackground;\r\n {$ENDIF JVCLThemesEnabledD6}\r\n published\r\n property DotNetHighlighting: Boolean read FDotNetHighlighting write FDotNetHighlighting default False;\r\n end;\r\n\r\n TJvExLabeledEdit = class(TLabeledEdit, IJvExControl)\r\n private\r\n FAboutJVCL: TJVCLAboutInfo;\r\n FHintColor: TColor;\r\n FMouseOver: Boolean;\r\n FHintWindowClass: THintWindowClass;\r\n FOnMouseEnter: TNotifyEvent;\r\n FOnMouseLeave: TNotifyEvent;\r\n FOnParentColorChanged: TNotifyEvent;\r\n function BaseWndProc(Msg: Cardinal; WParam: WPARAM = 0; LParam: LPARAM = 0): LRESULT; overload;\r\n function BaseWndProc(Msg: Cardinal; WParam: WPARAM; LParam: TObject): LRESULT; overload;\r\n function BaseWndProcEx(Msg: Cardinal; WParam: WPARAM; var StructLParam): LRESULT;\r\n protected\r\n procedure WndProc(var Msg: TMessage); override;\r\n procedure FocusChanged(AControl: TWinControl); dynamic;\r\n procedure VisibleChanged; reintroduce; dynamic;\r\n procedure EnabledChanged; reintroduce; dynamic;\r\n procedure TextChanged; reintroduce; virtual;\r\n procedure ColorChanged; reintroduce; dynamic;\r\n procedure FontChanged; reintroduce; dynamic;\r\n procedure ParentFontChanged; reintroduce; dynamic;\r\n procedure ParentColorChanged; reintroduce; dynamic;\r\n procedure ParentShowHintChanged; reintroduce; dynamic;\r\n function WantKey(Key: Integer; Shift: TShiftState): Boolean; virtual;\r\n function HintShow(var HintInfo: THintInfo): Boolean; reintroduce; dynamic;\r\n function HitTest(X, Y: Integer): Boolean; reintroduce; virtual;\r\n procedure MouseEnter(AControl: TControl); reintroduce; dynamic;\r\n procedure MouseLeave(AControl: TControl); reintroduce; dynamic;\r\n property MouseOver: Boolean read FMouseOver write FMouseOver;\r\n property HintColor: TColor read FHintColor write FHintColor default clDefault;\r\n property OnMouseEnter: TNotifyEvent read FOnMouseEnter write FOnMouseEnter;\r\n property OnMouseLeave: TNotifyEvent read FOnMouseLeave write FOnMouseLeave;\r\n property OnParentColorChange: TNotifyEvent read FOnParentColorChanged write FOnParentColorChanged;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n property HintWindowClass: THintWindowClass read FHintWindowClass write FHintWindowClass;\r\n published\r\n property AboutJVCL: TJVCLAboutInfo read FAboutJVCL write FAboutJVCL stored False;\r\n private\r\n FDotNetHighlighting: Boolean;\r\n protected\r\n procedure BoundsChanged; reintroduce; virtual;\r\n procedure CursorChanged; reintroduce; dynamic;\r\n procedure ShowingChanged; reintroduce; dynamic;\r\n procedure ShowHintChanged; reintroduce; dynamic;\r\n procedure ControlsListChanging(Control: TControl; Inserting: Boolean); reintroduce; dynamic;\r\n procedure ControlsListChanged(Control: TControl; Inserting: Boolean); reintroduce; dynamic;\r\n procedure GetDlgCode(var Code: TDlgCodes); virtual;\r\n procedure FocusSet(PrevWnd: THandle); virtual;\r\n procedure FocusKilled(NextWnd: THandle); virtual;\r\n function DoEraseBackground(Canvas: TCanvas; Param: LPARAM): Boolean; virtual;\r\n {$IFDEF JVCLThemesEnabledD6}\r\n private\r\n function GetParentBackground: Boolean;\r\n protected\r\n procedure SetParentBackground(Value: Boolean); virtual;\r\n property ParentBackground: Boolean read GetParentBackground write SetParentBackground;\r\n {$ENDIF JVCLThemesEnabledD6}\r\n published\r\n property DotNetHighlighting: Boolean read FDotNetHighlighting write FDotNetHighlighting default False;\r\n end;\r\n\r\n TJvExCustomColorBox = class(TCustomColorBox, IJvExControl)\r\n private\r\n FAboutJVCL: TJVCLAboutInfo;\r\n FHintColor: TColor;\r\n FMouseOver: Boolean;\r\n FHintWindowClass: THintWindowClass;\r\n FOnMouseEnter: TNotifyEvent;\r\n FOnMouseLeave: TNotifyEvent;\r\n FOnParentColorChanged: TNotifyEvent;\r\n function BaseWndProc(Msg: Cardinal; WParam: WPARAM = 0; LParam: LPARAM = 0): LRESULT; overload;\r\n function BaseWndProc(Msg: Cardinal; WParam: WPARAM; LParam: TObject): LRESULT; overload;\r\n function BaseWndProcEx(Msg: Cardinal; WParam: WPARAM; var StructLParam): LRESULT;\r\n protected\r\n procedure WndProc(var Msg: TMessage); override;\r\n procedure FocusChanged(AControl: TWinControl); dynamic;\r\n procedure VisibleChanged; reintroduce; dynamic;\r\n procedure EnabledChanged; reintroduce; dynamic;\r\n procedure TextChanged; reintroduce; virtual;\r\n procedure ColorChanged; reintroduce; dynamic;\r\n procedure FontChanged; reintroduce; dynamic;\r\n procedure ParentFontChanged; reintroduce; dynamic;\r\n procedure ParentColorChanged; reintroduce; dynamic;\r\n procedure ParentShowHintChanged; reintroduce; dynamic;\r\n function WantKey(Key: Integer; Shift: TShiftState): Boolean; virtual;\r\n function HintShow(var HintInfo: THintInfo): Boolean; reintroduce; dynamic;\r\n function HitTest(X, Y: Integer): Boolean; reintroduce; virtual;\r\n procedure MouseEnter(AControl: TControl); reintroduce; dynamic;\r\n procedure MouseLeave(AControl: TControl); reintroduce; dynamic;\r\n property MouseOver: Boolean read FMouseOver write FMouseOver;\r\n property HintColor: TColor read FHintColor write FHintColor default clDefault;\r\n property OnMouseEnter: TNotifyEvent read FOnMouseEnter write FOnMouseEnter;\r\n property OnMouseLeave: TNotifyEvent read FOnMouseLeave write FOnMouseLeave;\r\n property OnParentColorChange: TNotifyEvent read FOnParentColorChanged write FOnParentColorChanged;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n property HintWindowClass: THintWindowClass read FHintWindowClass write FHintWindowClass;\r\n published\r\n property AboutJVCL: TJVCLAboutInfo read FAboutJVCL write FAboutJVCL stored False;\r\n private\r\n FDotNetHighlighting: Boolean;\r\n protected\r\n procedure BoundsChanged; reintroduce; virtual;\r\n procedure CursorChanged; reintroduce; dynamic;\r\n procedure ShowingChanged; reintroduce; dynamic;\r\n procedure ShowHintChanged; reintroduce; dynamic;\r\n procedure ControlsListChanging(Control: TControl; Inserting: Boolean); reintroduce; dynamic;\r\n procedure ControlsListChanged(Control: TControl; Inserting: Boolean); reintroduce; dynamic;\r\n procedure GetDlgCode(var Code: TDlgCodes); virtual;\r\n procedure FocusSet(PrevWnd: THandle); virtual;\r\n procedure FocusKilled(NextWnd: THandle); virtual;\r\n function DoEraseBackground(Canvas: TCanvas; Param: LPARAM): Boolean; virtual;\r\n {$IFDEF JVCLThemesEnabledD6}\r\n private\r\n function GetParentBackground: Boolean;\r\n protected\r\n procedure SetParentBackground(Value: Boolean); virtual;\r\n property ParentBackground: Boolean read GetParentBackground write SetParentBackground;\r\n {$ENDIF JVCLThemesEnabledD6}\r\n published\r\n property DotNetHighlighting: Boolean read FDotNetHighlighting write FDotNetHighlighting default False;\r\n end;\r\n\r\n TJvExColorBox = class(TColorBox, IJvExControl)\r\n private\r\n FAboutJVCL: TJVCLAboutInfo;\r\n FHintColor: TColor;\r\n FMouseOver: Boolean;\r\n FHintWindowClass: THintWindowClass;\r\n FOnMouseEnter: TNotifyEvent;\r\n FOnMouseLeave: TNotifyEvent;\r\n FOnParentColorChanged: TNotifyEvent;\r\n function BaseWndProc(Msg: Cardinal; WParam: WPARAM = 0; LParam: LPARAM = 0): LRESULT; overload;\r\n function BaseWndProc(Msg: Cardinal; WParam: WPARAM; LParam: TObject): LRESULT; overload;\r\n function BaseWndProcEx(Msg: Cardinal; WParam: WPARAM; var StructLParam): LRESULT;\r\n protected\r\n procedure WndProc(var Msg: TMessage); override;\r\n procedure FocusChanged(AControl: TWinControl); dynamic;\r\n procedure VisibleChanged; reintroduce; dynamic;\r\n procedure EnabledChanged; reintroduce; dynamic;\r\n procedure TextChanged; reintroduce; virtual;\r\n procedure ColorChanged; reintroduce; dynamic;\r\n procedure FontChanged; reintroduce; dynamic;\r\n procedure ParentFontChanged; reintroduce; dynamic;\r\n procedure ParentColorChanged; reintroduce; dynamic;\r\n procedure ParentShowHintChanged; reintroduce; dynamic;\r\n function WantKey(Key: Integer; Shift: TShiftState): Boolean; virtual;\r\n function HintShow(var HintInfo: THintInfo): Boolean; reintroduce; dynamic;\r\n function HitTest(X, Y: Integer): Boolean; reintroduce; virtual;\r\n procedure MouseEnter(AControl: TControl); reintroduce; dynamic;\r\n procedure MouseLeave(AControl: TControl); reintroduce; dynamic;\r\n property MouseOver: Boolean read FMouseOver write FMouseOver;\r\n property HintColor: TColor read FHintColor write FHintColor default clDefault;\r\n property OnMouseEnter: TNotifyEvent read FOnMouseEnter write FOnMouseEnter;\r\n property OnMouseLeave: TNotifyEvent read FOnMouseLeave write FOnMouseLeave;\r\n property OnParentColorChange: TNotifyEvent read FOnParentColorChanged write FOnParentColorChanged;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n property HintWindowClass: THintWindowClass read FHintWindowClass write FHintWindowClass;\r\n published\r\n property AboutJVCL: TJVCLAboutInfo read FAboutJVCL write FAboutJVCL stored False;\r\n private\r\n FDotNetHighlighting: Boolean;\r\n protected\r\n procedure BoundsChanged; reintroduce; virtual;\r\n procedure CursorChanged; reintroduce; dynamic;\r\n procedure ShowingChanged; reintroduce; dynamic;\r\n procedure ShowHintChanged; reintroduce; dynamic;\r\n procedure ControlsListChanging(Control: TControl; Inserting: Boolean); reintroduce; dynamic;\r\n procedure ControlsListChanged(Control: TControl; Inserting: Boolean); reintroduce; dynamic;\r\n procedure GetDlgCode(var Code: TDlgCodes); virtual;\r\n procedure FocusSet(PrevWnd: THandle); virtual;\r\n procedure FocusKilled(NextWnd: THandle); virtual;\r\n function DoEraseBackground(Canvas: TCanvas; Param: LPARAM): Boolean; virtual;\r\n {$IFDEF JVCLThemesEnabledD6}\r\n private\r\n function GetParentBackground: Boolean;\r\n protected\r\n procedure SetParentBackground(Value: Boolean); virtual;\r\n property ParentBackground: Boolean read GetParentBackground write SetParentBackground;\r\n {$ENDIF JVCLThemesEnabledD6}\r\n published\r\n property DotNetHighlighting: Boolean read FDotNetHighlighting write FDotNetHighlighting default False;\r\n end;\r\n\r\n// SplitterMouseDownFix fixes a bug in the VCL that causes the splitter to no\r\n// more work with the control in the left/top of it when the control has a size\r\n// of 0. This is actually a TWinControl.AlignControl bug.\r\nprocedure SplitterMouseDownFix(Splitter: TSplitter);\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvExExtCtrls.pas $';\r\n Revision: '$Revision: 13173 $';\r\n Date: '$Date: 2011-11-19 13:43:58 +0100 (sam. 19 nov. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nconstructor TJvExShape.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FHintColor := clDefault;\r\nend;\r\n\r\nfunction TJvExShape.BaseWndProc(Msg: Cardinal; WParam: WPARAM = 0; LParam: LPARAM = 0): LRESULT;\r\nvar\r\n Mesg: TMessage;\r\nbegin\r\n CreateWMMessage(Mesg, Msg, WParam, LParam);\r\n inherited WndProc(Mesg);\r\n Result := Mesg.Result;\r\nend;\r\n\r\nfunction TJvExShape.BaseWndProc(Msg: Cardinal; WParam: WPARAM; LParam: TObject): LRESULT;\r\nbegin\r\n Result := BaseWndProc(Msg, WParam, Windows.LPARAM(LParam));\r\nend;\r\n\r\nfunction TJvExShape.BaseWndProcEx(Msg: Cardinal; WParam: WPARAM; var StructLParam): LRESULT;\r\nbegin\r\n Result := BaseWndProc(Msg, WParam, Windows.LPARAM(@StructLParam));\r\nend;\r\n\r\nprocedure TJvExShape.VisibleChanged;\r\nbegin\r\n BaseWndProc(CM_VISIBLECHANGED);\r\nend;\r\n\r\nprocedure TJvExShape.EnabledChanged;\r\nbegin\r\n BaseWndProc(CM_ENABLEDCHANGED);\r\nend;\r\n\r\nprocedure TJvExShape.TextChanged;\r\nbegin\r\n BaseWndProc(CM_TEXTCHANGED);\r\nend;\r\n\r\nprocedure TJvExShape.FontChanged;\r\nbegin\r\n BaseWndProc(CM_FONTCHANGED);\r\nend;\r\n\r\nprocedure TJvExShape.ColorChanged;\r\nbegin\r\n BaseWndProc(CM_COLORCHANGED);\r\nend;\r\n\r\nprocedure TJvExShape.ParentFontChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTFONTCHANGED);\r\nend;\r\n\r\nprocedure TJvExShape.ParentColorChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTCOLORCHANGED);\r\n if Assigned(OnParentColorChange) then\r\n OnParentColorChange(Self);\r\nend;\r\n\r\nprocedure TJvExShape.ParentShowHintChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTSHOWHINTCHANGED);\r\nend;\r\n\r\nfunction TJvExShape.WantKey(Key: Integer; Shift: TShiftState): Boolean;\r\nbegin\r\n Result := BaseWndProc(CM_DIALOGCHAR, Word(Key), ShiftStateToKeyData(Shift)) <> 0;\r\nend;\r\n\r\nfunction TJvExShape.HitTest(X, Y: Integer): Boolean;\r\nbegin\r\n Result := BaseWndProc(CM_HITTEST, 0, SmallPointToLong(PointToSmallPoint(Point(X, Y)))) <> 0;\r\nend;\r\n\r\nfunction TJvExShape.HintShow(var HintInfo: THintInfo): Boolean;\r\nbegin\r\n GetHintColor(HintInfo, Self, FHintColor);\r\n if FHintWindowClass <> nil then\r\n HintInfo.HintWindowClass := FHintWindowClass;\r\n Result := BaseWndProcEx(CM_HINTSHOW, 0, HintInfo) <> 0;\r\nend;\r\n\r\nprocedure TJvExShape.MouseEnter(AControl: TControl);\r\nbegin\r\n FMouseOver := True;\r\n if Assigned(FOnMouseEnter) then\r\n FOnMouseEnter(Self);\r\n BaseWndProc(CM_MOUSEENTER, 0, AControl);\r\nend;\r\n\r\nprocedure TJvExShape.MouseLeave(AControl: TControl);\r\nbegin\r\n FMouseOver := False;\r\n BaseWndProc(CM_MOUSELEAVE, 0, AControl);\r\n if Assigned(FOnMouseLeave) then\r\n FOnMouseLeave(Self);\r\nend;\r\n\r\nprocedure TJvExShape.FocusChanged(AControl: TWinControl);\r\nbegin\r\n BaseWndProc(CM_FOCUSCHANGED, 0, AControl);\r\nend;\r\n\r\nprocedure TJvExShape.WndProc(var Msg: TMessage);\r\nbegin\r\n if not DispatchIsDesignMsg(Self, Msg) then\r\n case Msg.Msg of\r\n CM_DENYSUBCLASSING:\r\n Msg.Result := LRESULT(Ord(GetInterfaceEntry(IJvDenySubClassing) <> nil));\r\n CM_DIALOGCHAR:\r\n with TCMDialogChar{$IFDEF CLR}.Create{$ENDIF}(Msg) do\r\n Result := LRESULT(Ord(WantKey(CharCode, KeyDataToShiftState(KeyData))));\r\n CM_HINTSHOW:\r\n with TCMHintShow(Msg) do\r\n Result := LRESULT(HintShow(HintInfo^));\r\n CM_HITTEST:\r\n with TCMHitTest(Msg) do\r\n Result := LRESULT(HitTest(XPos, YPos));\r\n CM_MOUSEENTER:\r\n MouseEnter(TControl(Msg.LParam));\r\n CM_MOUSELEAVE:\r\n MouseLeave(TControl(Msg.LParam));\r\n CM_VISIBLECHANGED:\r\n VisibleChanged;\r\n CM_ENABLEDCHANGED:\r\n EnabledChanged;\r\n CM_TEXTCHANGED:\r\n TextChanged;\r\n CM_FONTCHANGED:\r\n FontChanged;\r\n CM_COLORCHANGED:\r\n ColorChanged;\r\n CM_FOCUSCHANGED:\r\n FocusChanged(TWinControl(Msg.LParam));\r\n CM_PARENTFONTCHANGED:\r\n ParentFontChanged;\r\n CM_PARENTCOLORCHANGED:\r\n ParentColorChanged;\r\n CM_PARENTSHOWHINTCHANGED:\r\n ParentShowHintChanged;\r\n else\r\n inherited WndProc(Msg);\r\n end;\r\nend;\r\n\r\n//============================================================================\r\n\r\nconstructor TJvExPaintBox.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FHintColor := clDefault;\r\nend;\r\n\r\nfunction TJvExPaintBox.BaseWndProc(Msg: Cardinal; WParam: WPARAM = 0; LParam: LPARAM = 0): LRESULT;\r\nvar\r\n Mesg: TMessage;\r\nbegin\r\n CreateWMMessage(Mesg, Msg, WParam, LParam);\r\n inherited WndProc(Mesg);\r\n Result := Mesg.Result;\r\nend;\r\n\r\nfunction TJvExPaintBox.BaseWndProc(Msg: Cardinal; WParam: WPARAM; LParam: TObject): LRESULT;\r\nbegin\r\n Result := BaseWndProc(Msg, WParam, Windows.LPARAM(LParam));\r\nend;\r\n\r\nfunction TJvExPaintBox.BaseWndProcEx(Msg: Cardinal; WParam: WPARAM; var StructLParam): LRESULT;\r\nbegin\r\n Result := BaseWndProc(Msg, WParam, Windows.LPARAM(@StructLParam));\r\nend;\r\n\r\nprocedure TJvExPaintBox.VisibleChanged;\r\nbegin\r\n BaseWndProc(CM_VISIBLECHANGED);\r\nend;\r\n\r\nprocedure TJvExPaintBox.EnabledChanged;\r\nbegin\r\n BaseWndProc(CM_ENABLEDCHANGED);\r\nend;\r\n\r\nprocedure TJvExPaintBox.TextChanged;\r\nbegin\r\n BaseWndProc(CM_TEXTCHANGED);\r\nend;\r\n\r\nprocedure TJvExPaintBox.FontChanged;\r\nbegin\r\n BaseWndProc(CM_FONTCHANGED);\r\nend;\r\n\r\nprocedure TJvExPaintBox.ColorChanged;\r\nbegin\r\n BaseWndProc(CM_COLORCHANGED);\r\nend;\r\n\r\nprocedure TJvExPaintBox.ParentFontChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTFONTCHANGED);\r\nend;\r\n\r\nprocedure TJvExPaintBox.ParentColorChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTCOLORCHANGED);\r\n if Assigned(OnParentColorChange) then\r\n OnParentColorChange(Self);\r\nend;\r\n\r\nprocedure TJvExPaintBox.ParentShowHintChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTSHOWHINTCHANGED);\r\nend;\r\n\r\nfunction TJvExPaintBox.WantKey(Key: Integer; Shift: TShiftState): Boolean;\r\nbegin\r\n Result := BaseWndProc(CM_DIALOGCHAR, Word(Key), ShiftStateToKeyData(Shift)) <> 0;\r\nend;\r\n\r\nfunction TJvExPaintBox.HitTest(X, Y: Integer): Boolean;\r\nbegin\r\n Result := BaseWndProc(CM_HITTEST, 0, SmallPointToLong(PointToSmallPoint(Point(X, Y)))) <> 0;\r\nend;\r\n\r\nfunction TJvExPaintBox.HintShow(var HintInfo: THintInfo): Boolean;\r\nbegin\r\n GetHintColor(HintInfo, Self, FHintColor);\r\n if FHintWindowClass <> nil then\r\n HintInfo.HintWindowClass := FHintWindowClass;\r\n Result := BaseWndProcEx(CM_HINTSHOW, 0, HintInfo) <> 0;\r\nend;\r\n\r\nprocedure TJvExPaintBox.MouseEnter(AControl: TControl);\r\nbegin\r\n FMouseOver := True;\r\n if Assigned(FOnMouseEnter) then\r\n FOnMouseEnter(Self);\r\n BaseWndProc(CM_MOUSEENTER, 0, AControl);\r\nend;\r\n\r\nprocedure TJvExPaintBox.MouseLeave(AControl: TControl);\r\nbegin\r\n FMouseOver := False;\r\n BaseWndProc(CM_MOUSELEAVE, 0, AControl);\r\n if Assigned(FOnMouseLeave) then\r\n FOnMouseLeave(Self);\r\nend;\r\n\r\nprocedure TJvExPaintBox.FocusChanged(AControl: TWinControl);\r\nbegin\r\n BaseWndProc(CM_FOCUSCHANGED, 0, AControl);\r\nend;\r\n\r\nprocedure TJvExPaintBox.WndProc(var Msg: TMessage);\r\nbegin\r\n if not DispatchIsDesignMsg(Self, Msg) then\r\n case Msg.Msg of\r\n CM_DENYSUBCLASSING:\r\n Msg.Result := LRESULT(Ord(GetInterfaceEntry(IJvDenySubClassing) <> nil));\r\n CM_DIALOGCHAR:\r\n with TCMDialogChar{$IFDEF CLR}.Create{$ENDIF}(Msg) do\r\n Result := LRESULT(Ord(WantKey(CharCode, KeyDataToShiftState(KeyData))));\r\n CM_HINTSHOW:\r\n with TCMHintShow(Msg) do\r\n Result := LRESULT(HintShow(HintInfo^));\r\n CM_HITTEST:\r\n with TCMHitTest(Msg) do\r\n Result := LRESULT(HitTest(XPos, YPos));\r\n CM_MOUSEENTER:\r\n MouseEnter(TControl(Msg.LParam));\r\n CM_MOUSELEAVE:\r\n MouseLeave(TControl(Msg.LParam));\r\n CM_VISIBLECHANGED:\r\n VisibleChanged;\r\n CM_ENABLEDCHANGED:\r\n EnabledChanged;\r\n CM_TEXTCHANGED:\r\n TextChanged;\r\n CM_FONTCHANGED:\r\n FontChanged;\r\n CM_COLORCHANGED:\r\n ColorChanged;\r\n CM_FOCUSCHANGED:\r\n FocusChanged(TWinControl(Msg.LParam));\r\n CM_PARENTFONTCHANGED:\r\n ParentFontChanged;\r\n CM_PARENTCOLORCHANGED:\r\n ParentColorChanged;\r\n CM_PARENTSHOWHINTCHANGED:\r\n ParentShowHintChanged;\r\n else\r\n inherited WndProc(Msg);\r\n end;\r\nend;\r\n\r\n//============================================================================\r\n\r\nconstructor TJvExImage.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FHintColor := clDefault;\r\nend;\r\n\r\nfunction TJvExImage.BaseWndProc(Msg: Cardinal; WParam: WPARAM = 0; LParam: LPARAM = 0): LRESULT;\r\nvar\r\n Mesg: TMessage;\r\nbegin\r\n CreateWMMessage(Mesg, Msg, WParam, LParam);\r\n inherited WndProc(Mesg);\r\n Result := Mesg.Result;\r\nend;\r\n\r\nfunction TJvExImage.BaseWndProc(Msg: Cardinal; WParam: WPARAM; LParam: TObject): LRESULT;\r\nbegin\r\n Result := BaseWndProc(Msg, WParam, Windows.LPARAM(LParam));\r\nend;\r\n\r\nfunction TJvExImage.BaseWndProcEx(Msg: Cardinal; WParam: WPARAM; var StructLParam): LRESULT;\r\nbegin\r\n Result := BaseWndProc(Msg, WParam, Windows.LPARAM(@StructLParam));\r\nend;\r\n\r\nprocedure TJvExImage.VisibleChanged;\r\nbegin\r\n BaseWndProc(CM_VISIBLECHANGED);\r\nend;\r\n\r\nprocedure TJvExImage.EnabledChanged;\r\nbegin\r\n BaseWndProc(CM_ENABLEDCHANGED);\r\nend;\r\n\r\nprocedure TJvExImage.TextChanged;\r\nbegin\r\n BaseWndProc(CM_TEXTCHANGED);\r\nend;\r\n\r\nprocedure TJvExImage.FontChanged;\r\nbegin\r\n BaseWndProc(CM_FONTCHANGED);\r\nend;\r\n\r\nprocedure TJvExImage.ColorChanged;\r\nbegin\r\n BaseWndProc(CM_COLORCHANGED);\r\nend;\r\n\r\nprocedure TJvExImage.ParentFontChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTFONTCHANGED);\r\nend;\r\n\r\nprocedure TJvExImage.ParentColorChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTCOLORCHANGED);\r\n if Assigned(OnParentColorChange) then\r\n OnParentColorChange(Self);\r\nend;\r\n\r\nprocedure TJvExImage.ParentShowHintChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTSHOWHINTCHANGED);\r\nend;\r\n\r\nfunction TJvExImage.WantKey(Key: Integer; Shift: TShiftState): Boolean;\r\nbegin\r\n Result := BaseWndProc(CM_DIALOGCHAR, Word(Key), ShiftStateToKeyData(Shift)) <> 0;\r\nend;\r\n\r\nfunction TJvExImage.HitTest(X, Y: Integer): Boolean;\r\nbegin\r\n Result := BaseWndProc(CM_HITTEST, 0, SmallPointToLong(PointToSmallPoint(Point(X, Y)))) <> 0;\r\nend;\r\n\r\nfunction TJvExImage.HintShow(var HintInfo: THintInfo): Boolean;\r\nbegin\r\n GetHintColor(HintInfo, Self, FHintColor);\r\n if FHintWindowClass <> nil then\r\n HintInfo.HintWindowClass := FHintWindowClass;\r\n Result := BaseWndProcEx(CM_HINTSHOW, 0, HintInfo) <> 0;\r\nend;\r\n\r\nprocedure TJvExImage.MouseEnter(AControl: TControl);\r\nbegin\r\n FMouseOver := True;\r\n if Assigned(FOnMouseEnter) then\r\n FOnMouseEnter(Self);\r\n BaseWndProc(CM_MOUSEENTER, 0, AControl);\r\nend;\r\n\r\nprocedure TJvExImage.MouseLeave(AControl: TControl);\r\nbegin\r\n FMouseOver := False;\r\n BaseWndProc(CM_MOUSELEAVE, 0, AControl);\r\n if Assigned(FOnMouseLeave) then\r\n FOnMouseLeave(Self);\r\nend;\r\n\r\nprocedure TJvExImage.FocusChanged(AControl: TWinControl);\r\nbegin\r\n BaseWndProc(CM_FOCUSCHANGED, 0, AControl);\r\nend;\r\n\r\nprocedure TJvExImage.WndProc(var Msg: TMessage);\r\nbegin\r\n if not DispatchIsDesignMsg(Self, Msg) then\r\n case Msg.Msg of\r\n CM_DENYSUBCLASSING:\r\n Msg.Result := LRESULT(Ord(GetInterfaceEntry(IJvDenySubClassing) <> nil));\r\n CM_DIALOGCHAR:\r\n with TCMDialogChar{$IFDEF CLR}.Create{$ENDIF}(Msg) do\r\n Result := LRESULT(Ord(WantKey(CharCode, KeyDataToShiftState(KeyData))));\r\n CM_HINTSHOW:\r\n with TCMHintShow(Msg) do\r\n Result := LRESULT(HintShow(HintInfo^));\r\n CM_HITTEST:\r\n with TCMHitTest(Msg) do\r\n Result := LRESULT(HitTest(XPos, YPos));\r\n CM_MOUSEENTER:\r\n MouseEnter(TControl(Msg.LParam));\r\n CM_MOUSELEAVE:\r\n MouseLeave(TControl(Msg.LParam));\r\n CM_VISIBLECHANGED:\r\n VisibleChanged;\r\n CM_ENABLEDCHANGED:\r\n EnabledChanged;\r\n CM_TEXTCHANGED:\r\n TextChanged;\r\n CM_FONTCHANGED:\r\n FontChanged;\r\n CM_COLORCHANGED:\r\n ColorChanged;\r\n CM_FOCUSCHANGED:\r\n FocusChanged(TWinControl(Msg.LParam));\r\n CM_PARENTFONTCHANGED:\r\n ParentFontChanged;\r\n CM_PARENTCOLORCHANGED:\r\n ParentColorChanged;\r\n CM_PARENTSHOWHINTCHANGED:\r\n ParentShowHintChanged;\r\n else\r\n inherited WndProc(Msg);\r\n end;\r\nend;\r\n\r\n//============================================================================\r\n\r\nconstructor TJvExBevel.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FHintColor := clDefault;\r\nend;\r\n\r\nfunction TJvExBevel.BaseWndProc(Msg: Cardinal; WParam: WPARAM = 0; LParam: LPARAM = 0): LRESULT;\r\nvar\r\n Mesg: TMessage;\r\nbegin\r\n CreateWMMessage(Mesg, Msg, WParam, LParam);\r\n inherited WndProc(Mesg);\r\n Result := Mesg.Result;\r\nend;\r\n\r\nfunction TJvExBevel.BaseWndProc(Msg: Cardinal; WParam: WPARAM; LParam: TObject): LRESULT;\r\nbegin\r\n Result := BaseWndProc(Msg, WParam, Windows.LPARAM(LParam));\r\nend;\r\n\r\nfunction TJvExBevel.BaseWndProcEx(Msg: Cardinal; WParam: WPARAM; var StructLParam): LRESULT;\r\nbegin\r\n Result := BaseWndProc(Msg, WParam, Windows.LPARAM(@StructLParam));\r\nend;\r\n\r\nprocedure TJvExBevel.VisibleChanged;\r\nbegin\r\n BaseWndProc(CM_VISIBLECHANGED);\r\nend;\r\n\r\nprocedure TJvExBevel.EnabledChanged;\r\nbegin\r\n BaseWndProc(CM_ENABLEDCHANGED);\r\nend;\r\n\r\nprocedure TJvExBevel.TextChanged;\r\nbegin\r\n BaseWndProc(CM_TEXTCHANGED);\r\nend;\r\n\r\nprocedure TJvExBevel.FontChanged;\r\nbegin\r\n BaseWndProc(CM_FONTCHANGED);\r\nend;\r\n\r\nprocedure TJvExBevel.ColorChanged;\r\nbegin\r\n BaseWndProc(CM_COLORCHANGED);\r\nend;\r\n\r\nprocedure TJvExBevel.ParentFontChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTFONTCHANGED);\r\nend;\r\n\r\nprocedure TJvExBevel.ParentColorChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTCOLORCHANGED);\r\n if Assigned(OnParentColorChange) then\r\n OnParentColorChange(Self);\r\nend;\r\n\r\nprocedure TJvExBevel.ParentShowHintChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTSHOWHINTCHANGED);\r\nend;\r\n\r\nfunction TJvExBevel.WantKey(Key: Integer; Shift: TShiftState): Boolean;\r\nbegin\r\n Result := BaseWndProc(CM_DIALOGCHAR, Word(Key), ShiftStateToKeyData(Shift)) <> 0;\r\nend;\r\n\r\nfunction TJvExBevel.HitTest(X, Y: Integer): Boolean;\r\nbegin\r\n Result := BaseWndProc(CM_HITTEST, 0, SmallPointToLong(PointToSmallPoint(Point(X, Y)))) <> 0;\r\nend;\r\n\r\nfunction TJvExBevel.HintShow(var HintInfo: THintInfo): Boolean;\r\nbegin\r\n GetHintColor(HintInfo, Self, FHintColor);\r\n if FHintWindowClass <> nil then\r\n HintInfo.HintWindowClass := FHintWindowClass;\r\n Result := BaseWndProcEx(CM_HINTSHOW, 0, HintInfo) <> 0;\r\nend;\r\n\r\nprocedure TJvExBevel.MouseEnter(AControl: TControl);\r\nbegin\r\n FMouseOver := True;\r\n if Assigned(FOnMouseEnter) then\r\n FOnMouseEnter(Self);\r\n BaseWndProc(CM_MOUSEENTER, 0, AControl);\r\nend;\r\n\r\nprocedure TJvExBevel.MouseLeave(AControl: TControl);\r\nbegin\r\n FMouseOver := False;\r\n BaseWndProc(CM_MOUSELEAVE, 0, AControl);\r\n if Assigned(FOnMouseLeave) then\r\n FOnMouseLeave(Self);\r\nend;\r\n\r\nprocedure TJvExBevel.FocusChanged(AControl: TWinControl);\r\nbegin\r\n BaseWndProc(CM_FOCUSCHANGED, 0, AControl);\r\nend;\r\n\r\nprocedure TJvExBevel.WndProc(var Msg: TMessage);\r\nbegin\r\n if not DispatchIsDesignMsg(Self, Msg) then\r\n case Msg.Msg of\r\n CM_DENYSUBCLASSING:\r\n Msg.Result := LRESULT(Ord(GetInterfaceEntry(IJvDenySubClassing) <> nil));\r\n CM_DIALOGCHAR:\r\n with TCMDialogChar{$IFDEF CLR}.Create{$ENDIF}(Msg) do\r\n Result := LRESULT(Ord(WantKey(CharCode, KeyDataToShiftState(KeyData))));\r\n CM_HINTSHOW:\r\n with TCMHintShow(Msg) do\r\n Result := LRESULT(HintShow(HintInfo^));\r\n CM_HITTEST:\r\n with TCMHitTest(Msg) do\r\n Result := LRESULT(HitTest(XPos, YPos));\r\n CM_MOUSEENTER:\r\n MouseEnter(TControl(Msg.LParam));\r\n CM_MOUSELEAVE:\r\n MouseLeave(TControl(Msg.LParam));\r\n CM_VISIBLECHANGED:\r\n VisibleChanged;\r\n CM_ENABLEDCHANGED:\r\n EnabledChanged;\r\n CM_TEXTCHANGED:\r\n TextChanged;\r\n CM_FONTCHANGED:\r\n FontChanged;\r\n CM_COLORCHANGED:\r\n ColorChanged;\r\n CM_FOCUSCHANGED:\r\n FocusChanged(TWinControl(Msg.LParam));\r\n CM_PARENTFONTCHANGED:\r\n ParentFontChanged;\r\n CM_PARENTCOLORCHANGED:\r\n ParentColorChanged;\r\n CM_PARENTSHOWHINTCHANGED:\r\n ParentShowHintChanged;\r\n else\r\n inherited WndProc(Msg);\r\n end;\r\nend;\r\n\r\n//============================================================================\r\n\r\nconstructor TJvExCustomPanel.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FHintColor := clDefault;\r\nend;\r\n\r\nfunction TJvExCustomPanel.BaseWndProc(Msg: Cardinal; WParam: WPARAM = 0; LParam: LPARAM = 0): LRESULT;\r\nvar\r\n Mesg: TMessage;\r\nbegin\r\n CreateWMMessage(Mesg, Msg, WParam, LParam);\r\n inherited WndProc(Mesg);\r\n Result := Mesg.Result;\r\nend;\r\n\r\nfunction TJvExCustomPanel.BaseWndProc(Msg: Cardinal; WParam: WPARAM; LParam: TObject): LRESULT;\r\nbegin\r\n Result := BaseWndProc(Msg, WParam, Windows.LPARAM(LParam));\r\nend;\r\n\r\nfunction TJvExCustomPanel.BaseWndProcEx(Msg: Cardinal; WParam: WPARAM; var StructLParam): LRESULT;\r\nbegin\r\n Result := BaseWndProc(Msg, WParam, Windows.LPARAM(@StructLParam));\r\nend;\r\n\r\nprocedure TJvExCustomPanel.VisibleChanged;\r\nbegin\r\n BaseWndProc(CM_VISIBLECHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomPanel.EnabledChanged;\r\nbegin\r\n BaseWndProc(CM_ENABLEDCHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomPanel.TextChanged;\r\nbegin\r\n BaseWndProc(CM_TEXTCHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomPanel.FontChanged;\r\nbegin\r\n BaseWndProc(CM_FONTCHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomPanel.ColorChanged;\r\nbegin\r\n BaseWndProc(CM_COLORCHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomPanel.ParentFontChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTFONTCHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomPanel.ParentColorChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTCOLORCHANGED);\r\n if Assigned(OnParentColorChange) then\r\n OnParentColorChange(Self);\r\nend;\r\n\r\nprocedure TJvExCustomPanel.ParentShowHintChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTSHOWHINTCHANGED);\r\nend;\r\n\r\nfunction TJvExCustomPanel.WantKey(Key: Integer; Shift: TShiftState): Boolean;\r\nbegin\r\n Result := BaseWndProc(CM_DIALOGCHAR, Word(Key), ShiftStateToKeyData(Shift)) <> 0;\r\nend;\r\n\r\nfunction TJvExCustomPanel.HitTest(X, Y: Integer): Boolean;\r\nbegin\r\n Result := BaseWndProc(CM_HITTEST, 0, SmallPointToLong(PointToSmallPoint(Point(X, Y)))) <> 0;\r\nend;\r\n\r\nfunction TJvExCustomPanel.HintShow(var HintInfo: THintInfo): Boolean;\r\nbegin\r\n GetHintColor(HintInfo, Self, FHintColor);\r\n if FHintWindowClass <> nil then\r\n HintInfo.HintWindowClass := FHintWindowClass;\r\n Result := BaseWndProcEx(CM_HINTSHOW, 0, HintInfo) <> 0;\r\nend;\r\n\r\nprocedure TJvExCustomPanel.MouseEnter(AControl: TControl);\r\nbegin\r\n FMouseOver := True;\r\n if Assigned(FOnMouseEnter) then\r\n FOnMouseEnter(Self);\r\n BaseWndProc(CM_MOUSEENTER, 0, AControl);\r\nend;\r\n\r\nprocedure TJvExCustomPanel.MouseLeave(AControl: TControl);\r\nbegin\r\n FMouseOver := False;\r\n BaseWndProc(CM_MOUSELEAVE, 0, AControl);\r\n if Assigned(FOnMouseLeave) then\r\n FOnMouseLeave(Self);\r\nend;\r\n\r\nprocedure TJvExCustomPanel.FocusChanged(AControl: TWinControl);\r\nbegin\r\n BaseWndProc(CM_FOCUSCHANGED, 0, AControl);\r\nend;\r\n\r\nprocedure TJvExCustomPanel.BoundsChanged;\r\nbegin\r\nend;\r\n\r\nprocedure TJvExCustomPanel.CursorChanged;\r\nbegin\r\n BaseWndProc(CM_CURSORCHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomPanel.ShowingChanged;\r\nbegin\r\n BaseWndProc(CM_SHOWINGCHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomPanel.ShowHintChanged;\r\nbegin\r\n BaseWndProc(CM_SHOWHINTCHANGED);\r\nend;\r\n\r\n{ VCL sends CM_CONTROLLISTCHANGE and CM_CONTROLCHANGE in a different order than\r\n the CLX methods are used. So we must correct it by evaluating \"Inserting\". }\r\nprocedure TJvExCustomPanel.ControlsListChanging(Control: TControl; Inserting: Boolean);\r\nbegin\r\n if Inserting then\r\n BaseWndProc(CM_CONTROLLISTCHANGE, WPARAM(Control), LPARAM(Inserting))\r\n else\r\n BaseWndProc(CM_CONTROLCHANGE, WPARAM(Control), LPARAM(Inserting));\r\nend;\r\n\r\nprocedure TJvExCustomPanel.ControlsListChanged(Control: TControl; Inserting: Boolean);\r\nbegin\r\n if not Inserting then\r\n BaseWndProc(CM_CONTROLLISTCHANGE, WPARAM(Control), LPARAM(Inserting))\r\n else\r\n BaseWndProc(CM_CONTROLCHANGE, WPARAM(Control), LPARAM(Inserting));\r\nend;\r\n\r\nprocedure TJvExCustomPanel.GetDlgCode(var Code: TDlgCodes);\r\nbegin\r\nend;\r\n\r\nprocedure TJvExCustomPanel.FocusSet(PrevWnd: THandle);\r\nbegin\r\n BaseWndProc(WM_SETFOCUS, WPARAM(PrevWnd), 0);\r\nend;\r\n\r\nprocedure TJvExCustomPanel.FocusKilled(NextWnd: THandle);\r\nbegin\r\n BaseWndProc(WM_KILLFOCUS, WPARAM(NextWnd), 0);\r\nend;\r\n\r\nfunction TJvExCustomPanel.DoEraseBackground(Canvas: TCanvas; Param: LPARAM): Boolean;\r\nbegin\r\n Result := BaseWndProc(WM_ERASEBKGND, Canvas.Handle, Param) <> 0;\r\nend;\r\n\r\n{$IFDEF JVCLThemesEnabledD6}\r\nfunction TJvExCustomPanel.GetParentBackground: Boolean;\r\nbegin\r\n Result := JvThemes.GetParentBackground(Self);\r\nend;\r\n\r\nprocedure TJvExCustomPanel.SetParentBackground(Value: Boolean);\r\nbegin\r\n JvThemes.SetParentBackground(Self, Value);\r\nend;\r\n{$ENDIF JVCLThemesEnabledD6}\r\n\r\nprocedure TJvExCustomPanel.WndProc(var Msg: TMessage);\r\nvar\r\n IdSaveDC: Integer;\r\n DlgCodes: TDlgCodes;\r\n Canvas: TCanvas;\r\nbegin\r\n if not DispatchIsDesignMsg(Self, Msg) then\r\n begin\r\n case Msg.Msg of\r\n CM_DENYSUBCLASSING:\r\n Msg.Result := LRESULT(Ord(GetInterfaceEntry(IJvDenySubClassing) <> nil));\r\n CM_DIALOGCHAR:\r\n with TCMDialogChar{$IFDEF CLR}.Create{$ENDIF}(Msg) do\r\n Result := LRESULT(Ord(WantKey(CharCode, KeyDataToShiftState(KeyData))));\r\n CM_HINTSHOW:\r\n with TCMHintShow(Msg) do\r\n Result := LRESULT(HintShow(HintInfo^));\r\n CM_HITTEST:\r\n with TCMHitTest(Msg) do\r\n Result := LRESULT(HitTest(XPos, YPos));\r\n CM_MOUSEENTER:\r\n MouseEnter(TControl(Msg.LParam));\r\n CM_MOUSELEAVE:\r\n MouseLeave(TControl(Msg.LParam));\r\n CM_VISIBLECHANGED:\r\n VisibleChanged;\r\n CM_ENABLEDCHANGED:\r\n EnabledChanged;\r\n CM_TEXTCHANGED:\r\n TextChanged;\r\n CM_FONTCHANGED:\r\n FontChanged;\r\n CM_COLORCHANGED:\r\n ColorChanged;\r\n CM_FOCUSCHANGED:\r\n FocusChanged(TWinControl(Msg.LParam));\r\n CM_PARENTFONTCHANGED:\r\n ParentFontChanged;\r\n CM_PARENTCOLORCHANGED:\r\n ParentColorChanged;\r\n CM_PARENTSHOWHINTCHANGED:\r\n ParentShowHintChanged;\r\n CM_CURSORCHANGED:\r\n CursorChanged;\r\n CM_SHOWINGCHANGED:\r\n ShowingChanged;\r\n CM_SHOWHINTCHANGED:\r\n ShowHintChanged;\r\n CM_CONTROLLISTCHANGE:\r\n if Msg.LParam <> 0 then\r\n ControlsListChanging(TControl(Msg.WParam), True)\r\n else\r\n ControlsListChanged(TControl(Msg.WParam), False);\r\n CM_CONTROLCHANGE:\r\n if Msg.LParam = 0 then\r\n ControlsListChanging(TControl(Msg.WParam), False)\r\n else\r\n ControlsListChanged(TControl(Msg.WParam), True);\r\n WM_SETFOCUS:\r\n FocusSet(THandle(Msg.WParam));\r\n WM_KILLFOCUS:\r\n FocusKilled(THandle(Msg.WParam));\r\n WM_SIZE, WM_MOVE:\r\n begin\r\n inherited WndProc(Msg);\r\n BoundsChanged;\r\n end;\r\n WM_ERASEBKGND:\r\n if (Msg.WParam <> 0) and not IsDefaultEraseBackground(DoEraseBackground, @TJvExCustomPanel.DoEraseBackground) then\r\n begin\r\n IdSaveDC := SaveDC(HDC(Msg.WParam)); // protect DC against Stock-Objects from Canvas\r\n Canvas := TCanvas.Create;\r\n try\r\n Canvas.Handle := HDC(Msg.WParam);\r\n Msg.Result := Ord(DoEraseBackground(Canvas, Msg.LParam));\r\n finally\r\n Canvas.Handle := 0;\r\n Canvas.Free;\r\n RestoreDC(HDC(Msg.WParam), IdSaveDC);\r\n end;\r\n end\r\n else\r\n inherited WndProc(Msg);\r\n {$IFNDEF DELPHI2007_UP}\r\n WM_PRINTCLIENT, WM_PRINT: // VCL bug fix\r\n begin\r\n IdSaveDC := SaveDC(HDC(Msg.WParam)); // protect DC against changes\r\n try\r\n inherited WndProc(Msg);\r\n finally\r\n RestoreDC(HDC(Msg.WParam), IdSaveDC);\r\n end;\r\n end;\r\n {$ENDIF ~DELPHI2007_UP}\r\n WM_GETDLGCODE:\r\n begin\r\n inherited WndProc(Msg);\r\n DlgCodes := [dcNative] + DlgcToDlgCodes(Msg.Result);\r\n GetDlgCode(DlgCodes);\r\n if not (dcNative in DlgCodes) then\r\n Msg.Result := DlgCodesToDlgc(DlgCodes);\r\n end;\r\n else\r\n inherited WndProc(Msg);\r\n end;\r\n case Msg.Msg of // precheck message to prevent access violations on released controls\r\n CM_MOUSEENTER, CM_MOUSELEAVE, WM_KILLFOCUS, WM_SETFOCUS, WM_NCPAINT:\r\n if DotNetHighlighting then\r\n HandleDotNetHighlighting(Self, Msg, MouseOver, Color);\r\n end;\r\n end;\r\nend;\r\n\r\n//============================================================================\r\n\r\nconstructor TJvExCustomRadioGroup.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FHintColor := clDefault;\r\nend;\r\n\r\nfunction TJvExCustomRadioGroup.BaseWndProc(Msg: Cardinal; WParam: WPARAM = 0; LParam: LPARAM = 0): LRESULT;\r\nvar\r\n Mesg: TMessage;\r\nbegin\r\n CreateWMMessage(Mesg, Msg, WParam, LParam);\r\n inherited WndProc(Mesg);\r\n Result := Mesg.Result;\r\nend;\r\n\r\nfunction TJvExCustomRadioGroup.BaseWndProc(Msg: Cardinal; WParam: WPARAM; LParam: TObject): LRESULT;\r\nbegin\r\n Result := BaseWndProc(Msg, WParam, Windows.LPARAM(LParam));\r\nend;\r\n\r\nfunction TJvExCustomRadioGroup.BaseWndProcEx(Msg: Cardinal; WParam: WPARAM; var StructLParam): LRESULT;\r\nbegin\r\n Result := BaseWndProc(Msg, WParam, Windows.LPARAM(@StructLParam));\r\nend;\r\n\r\nprocedure TJvExCustomRadioGroup.VisibleChanged;\r\nbegin\r\n BaseWndProc(CM_VISIBLECHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomRadioGroup.EnabledChanged;\r\nbegin\r\n BaseWndProc(CM_ENABLEDCHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomRadioGroup.TextChanged;\r\nbegin\r\n BaseWndProc(CM_TEXTCHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomRadioGroup.FontChanged;\r\nbegin\r\n BaseWndProc(CM_FONTCHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomRadioGroup.ColorChanged;\r\nbegin\r\n BaseWndProc(CM_COLORCHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomRadioGroup.ParentFontChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTFONTCHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomRadioGroup.ParentColorChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTCOLORCHANGED);\r\n if Assigned(OnParentColorChange) then\r\n OnParentColorChange(Self);\r\nend;\r\n\r\nprocedure TJvExCustomRadioGroup.ParentShowHintChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTSHOWHINTCHANGED);\r\nend;\r\n\r\nfunction TJvExCustomRadioGroup.WantKey(Key: Integer; Shift: TShiftState): Boolean;\r\nbegin\r\n Result := BaseWndProc(CM_DIALOGCHAR, Word(Key), ShiftStateToKeyData(Shift)) <> 0;\r\nend;\r\n\r\nfunction TJvExCustomRadioGroup.HitTest(X, Y: Integer): Boolean;\r\nbegin\r\n Result := BaseWndProc(CM_HITTEST, 0, SmallPointToLong(PointToSmallPoint(Point(X, Y)))) <> 0;\r\nend;\r\n\r\nfunction TJvExCustomRadioGroup.HintShow(var HintInfo: THintInfo): Boolean;\r\nbegin\r\n GetHintColor(HintInfo, Self, FHintColor);\r\n if FHintWindowClass <> nil then\r\n HintInfo.HintWindowClass := FHintWindowClass;\r\n Result := BaseWndProcEx(CM_HINTSHOW, 0, HintInfo) <> 0;\r\nend;\r\n\r\nprocedure TJvExCustomRadioGroup.MouseEnter(AControl: TControl);\r\nbegin\r\n FMouseOver := True;\r\n if Assigned(FOnMouseEnter) then\r\n FOnMouseEnter(Self);\r\n BaseWndProc(CM_MOUSEENTER, 0, AControl);\r\nend;\r\n\r\nprocedure TJvExCustomRadioGroup.MouseLeave(AControl: TControl);\r\nbegin\r\n FMouseOver := False;\r\n BaseWndProc(CM_MOUSELEAVE, 0, AControl);\r\n if Assigned(FOnMouseLeave) then\r\n FOnMouseLeave(Self);\r\nend;\r\n\r\nprocedure TJvExCustomRadioGroup.FocusChanged(AControl: TWinControl);\r\nbegin\r\n BaseWndProc(CM_FOCUSCHANGED, 0, AControl);\r\nend;\r\n\r\nprocedure TJvExCustomRadioGroup.BoundsChanged;\r\nbegin\r\nend;\r\n\r\nprocedure TJvExCustomRadioGroup.CursorChanged;\r\nbegin\r\n BaseWndProc(CM_CURSORCHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomRadioGroup.ShowingChanged;\r\nbegin\r\n BaseWndProc(CM_SHOWINGCHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomRadioGroup.ShowHintChanged;\r\nbegin\r\n BaseWndProc(CM_SHOWHINTCHANGED);\r\nend;\r\n\r\n{ VCL sends CM_CONTROLLISTCHANGE and CM_CONTROLCHANGE in a different order than\r\n the CLX methods are used. So we must correct it by evaluating \"Inserting\". }\r\nprocedure TJvExCustomRadioGroup.ControlsListChanging(Control: TControl; Inserting: Boolean);\r\nbegin\r\n if Inserting then\r\n BaseWndProc(CM_CONTROLLISTCHANGE, WPARAM(Control), LPARAM(Inserting))\r\n else\r\n BaseWndProc(CM_CONTROLCHANGE, WPARAM(Control), LPARAM(Inserting));\r\nend;\r\n\r\nprocedure TJvExCustomRadioGroup.ControlsListChanged(Control: TControl; Inserting: Boolean);\r\nbegin\r\n if not Inserting then\r\n BaseWndProc(CM_CONTROLLISTCHANGE, WPARAM(Control), LPARAM(Inserting))\r\n else\r\n BaseWndProc(CM_CONTROLCHANGE, WPARAM(Control), LPARAM(Inserting));\r\nend;\r\n\r\nprocedure TJvExCustomRadioGroup.GetDlgCode(var Code: TDlgCodes);\r\nbegin\r\nend;\r\n\r\nprocedure TJvExCustomRadioGroup.FocusSet(PrevWnd: THandle);\r\nbegin\r\n BaseWndProc(WM_SETFOCUS, WPARAM(PrevWnd), 0);\r\nend;\r\n\r\nprocedure TJvExCustomRadioGroup.FocusKilled(NextWnd: THandle);\r\nbegin\r\n BaseWndProc(WM_KILLFOCUS, WPARAM(NextWnd), 0);\r\nend;\r\n\r\nfunction TJvExCustomRadioGroup.DoEraseBackground(Canvas: TCanvas; Param: LPARAM): Boolean;\r\nbegin\r\n Result := BaseWndProc(WM_ERASEBKGND, Canvas.Handle, Param) <> 0;\r\nend;\r\n\r\n{$IFDEF JVCLThemesEnabledD6}\r\nfunction TJvExCustomRadioGroup.GetParentBackground: Boolean;\r\nbegin\r\n Result := JvThemes.GetParentBackground(Self);\r\nend;\r\n\r\nprocedure TJvExCustomRadioGroup.SetParentBackground(Value: Boolean);\r\nbegin\r\n JvThemes.SetParentBackground(Self, Value);\r\nend;\r\n{$ENDIF JVCLThemesEnabledD6}\r\n\r\nprocedure TJvExCustomRadioGroup.WndProc(var Msg: TMessage);\r\nvar\r\n IdSaveDC: Integer;\r\n DlgCodes: TDlgCodes;\r\n Canvas: TCanvas;\r\nbegin\r\n if not DispatchIsDesignMsg(Self, Msg) then\r\n begin\r\n case Msg.Msg of\r\n CM_DENYSUBCLASSING:\r\n Msg.Result := LRESULT(Ord(GetInterfaceEntry(IJvDenySubClassing) <> nil));\r\n CM_DIALOGCHAR:\r\n with TCMDialogChar{$IFDEF CLR}.Create{$ENDIF}(Msg) do\r\n Result := LRESULT(Ord(WantKey(CharCode, KeyDataToShiftState(KeyData))));\r\n CM_HINTSHOW:\r\n with TCMHintShow(Msg) do\r\n Result := LRESULT(HintShow(HintInfo^));\r\n CM_HITTEST:\r\n with TCMHitTest(Msg) do\r\n Result := LRESULT(HitTest(XPos, YPos));\r\n CM_MOUSEENTER:\r\n MouseEnter(TControl(Msg.LParam));\r\n CM_MOUSELEAVE:\r\n MouseLeave(TControl(Msg.LParam));\r\n CM_VISIBLECHANGED:\r\n VisibleChanged;\r\n CM_ENABLEDCHANGED:\r\n EnabledChanged;\r\n CM_TEXTCHANGED:\r\n TextChanged;\r\n CM_FONTCHANGED:\r\n FontChanged;\r\n CM_COLORCHANGED:\r\n ColorChanged;\r\n CM_FOCUSCHANGED:\r\n FocusChanged(TWinControl(Msg.LParam));\r\n CM_PARENTFONTCHANGED:\r\n ParentFontChanged;\r\n CM_PARENTCOLORCHANGED:\r\n ParentColorChanged;\r\n CM_PARENTSHOWHINTCHANGED:\r\n ParentShowHintChanged;\r\n CM_CURSORCHANGED:\r\n CursorChanged;\r\n CM_SHOWINGCHANGED:\r\n ShowingChanged;\r\n CM_SHOWHINTCHANGED:\r\n ShowHintChanged;\r\n CM_CONTROLLISTCHANGE:\r\n if Msg.LParam <> 0 then\r\n ControlsListChanging(TControl(Msg.WParam), True)\r\n else\r\n ControlsListChanged(TControl(Msg.WParam), False);\r\n CM_CONTROLCHANGE:\r\n if Msg.LParam = 0 then\r\n ControlsListChanging(TControl(Msg.WParam), False)\r\n else\r\n ControlsListChanged(TControl(Msg.WParam), True);\r\n WM_SETFOCUS:\r\n FocusSet(THandle(Msg.WParam));\r\n WM_KILLFOCUS:\r\n FocusKilled(THandle(Msg.WParam));\r\n WM_SIZE, WM_MOVE:\r\n begin\r\n inherited WndProc(Msg);\r\n BoundsChanged;\r\n end;\r\n WM_ERASEBKGND:\r\n if (Msg.WParam <> 0) and not IsDefaultEraseBackground(DoEraseBackground, @TJvExCustomRadioGroup.DoEraseBackground) then\r\n begin\r\n IdSaveDC := SaveDC(HDC(Msg.WParam)); // protect DC against Stock-Objects from Canvas\r\n Canvas := TCanvas.Create;\r\n try\r\n Canvas.Handle := HDC(Msg.WParam);\r\n Msg.Result := Ord(DoEraseBackground(Canvas, Msg.LParam));\r\n finally\r\n Canvas.Handle := 0;\r\n Canvas.Free;\r\n RestoreDC(HDC(Msg.WParam), IdSaveDC);\r\n end;\r\n end\r\n else\r\n inherited WndProc(Msg);\r\n {$IFNDEF DELPHI2007_UP}\r\n WM_PRINTCLIENT, WM_PRINT: // VCL bug fix\r\n begin\r\n IdSaveDC := SaveDC(HDC(Msg.WParam)); // protect DC against changes\r\n try\r\n inherited WndProc(Msg);\r\n finally\r\n RestoreDC(HDC(Msg.WParam), IdSaveDC);\r\n end;\r\n end;\r\n {$ENDIF ~DELPHI2007_UP}\r\n WM_GETDLGCODE:\r\n begin\r\n inherited WndProc(Msg);\r\n DlgCodes := [dcNative] + DlgcToDlgCodes(Msg.Result);\r\n GetDlgCode(DlgCodes);\r\n if not (dcNative in DlgCodes) then\r\n Msg.Result := DlgCodesToDlgc(DlgCodes);\r\n end;\r\n else\r\n inherited WndProc(Msg);\r\n end;\r\n case Msg.Msg of // precheck message to prevent access violations on released controls\r\n CM_MOUSEENTER, CM_MOUSELEAVE, WM_KILLFOCUS, WM_SETFOCUS, WM_NCPAINT:\r\n if DotNetHighlighting then\r\n HandleDotNetHighlighting(Self, Msg, MouseOver, Color);\r\n end;\r\n end;\r\nend;\r\n\r\n//============================================================================\r\n\r\nconstructor TJvExCustomControlBar.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FHintColor := clDefault;\r\nend;\r\n\r\nfunction TJvExCustomControlBar.BaseWndProc(Msg: Cardinal; WParam: WPARAM = 0; LParam: LPARAM = 0): LRESULT;\r\nvar\r\n Mesg: TMessage;\r\nbegin\r\n CreateWMMessage(Mesg, Msg, WParam, LParam);\r\n inherited WndProc(Mesg);\r\n Result := Mesg.Result;\r\nend;\r\n\r\nfunction TJvExCustomControlBar.BaseWndProc(Msg: Cardinal; WParam: WPARAM; LParam: TObject): LRESULT;\r\nbegin\r\n Result := BaseWndProc(Msg, WParam, Windows.LPARAM(LParam));\r\nend;\r\n\r\nfunction TJvExCustomControlBar.BaseWndProcEx(Msg: Cardinal; WParam: WPARAM; var StructLParam): LRESULT;\r\nbegin\r\n Result := BaseWndProc(Msg, WParam, Windows.LPARAM(@StructLParam));\r\nend;\r\n\r\nprocedure TJvExCustomControlBar.VisibleChanged;\r\nbegin\r\n BaseWndProc(CM_VISIBLECHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomControlBar.EnabledChanged;\r\nbegin\r\n BaseWndProc(CM_ENABLEDCHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomControlBar.TextChanged;\r\nbegin\r\n BaseWndProc(CM_TEXTCHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomControlBar.FontChanged;\r\nbegin\r\n BaseWndProc(CM_FONTCHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomControlBar.ColorChanged;\r\nbegin\r\n BaseWndProc(CM_COLORCHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomControlBar.ParentFontChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTFONTCHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomControlBar.ParentColorChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTCOLORCHANGED);\r\n if Assigned(OnParentColorChange) then\r\n OnParentColorChange(Self);\r\nend;\r\n\r\nprocedure TJvExCustomControlBar.ParentShowHintChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTSHOWHINTCHANGED);\r\nend;\r\n\r\nfunction TJvExCustomControlBar.WantKey(Key: Integer; Shift: TShiftState): Boolean;\r\nbegin\r\n Result := BaseWndProc(CM_DIALOGCHAR, Word(Key), ShiftStateToKeyData(Shift)) <> 0;\r\nend;\r\n\r\nfunction TJvExCustomControlBar.HitTest(X, Y: Integer): Boolean;\r\nbegin\r\n Result := BaseWndProc(CM_HITTEST, 0, SmallPointToLong(PointToSmallPoint(Point(X, Y)))) <> 0;\r\nend;\r\n\r\nfunction TJvExCustomControlBar.HintShow(var HintInfo: THintInfo): Boolean;\r\nbegin\r\n GetHintColor(HintInfo, Self, FHintColor);\r\n if FHintWindowClass <> nil then\r\n HintInfo.HintWindowClass := FHintWindowClass;\r\n Result := BaseWndProcEx(CM_HINTSHOW, 0, HintInfo) <> 0;\r\nend;\r\n\r\nprocedure TJvExCustomControlBar.MouseEnter(AControl: TControl);\r\nbegin\r\n FMouseOver := True;\r\n if Assigned(FOnMouseEnter) then\r\n FOnMouseEnter(Self);\r\n BaseWndProc(CM_MOUSEENTER, 0, AControl);\r\nend;\r\n\r\nprocedure TJvExCustomControlBar.MouseLeave(AControl: TControl);\r\nbegin\r\n FMouseOver := False;\r\n BaseWndProc(CM_MOUSELEAVE, 0, AControl);\r\n if Assigned(FOnMouseLeave) then\r\n FOnMouseLeave(Self);\r\nend;\r\n\r\nprocedure TJvExCustomControlBar.FocusChanged(AControl: TWinControl);\r\nbegin\r\n BaseWndProc(CM_FOCUSCHANGED, 0, AControl);\r\nend;\r\n\r\nprocedure TJvExCustomControlBar.BoundsChanged;\r\nbegin\r\nend;\r\n\r\nprocedure TJvExCustomControlBar.CursorChanged;\r\nbegin\r\n BaseWndProc(CM_CURSORCHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomControlBar.ShowingChanged;\r\nbegin\r\n BaseWndProc(CM_SHOWINGCHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomControlBar.ShowHintChanged;\r\nbegin\r\n BaseWndProc(CM_SHOWHINTCHANGED);\r\nend;\r\n\r\n{ VCL sends CM_CONTROLLISTCHANGE and CM_CONTROLCHANGE in a different order than\r\n the CLX methods are used. So we must correct it by evaluating \"Inserting\". }\r\nprocedure TJvExCustomControlBar.ControlsListChanging(Control: TControl; Inserting: Boolean);\r\nbegin\r\n if Inserting then\r\n BaseWndProc(CM_CONTROLLISTCHANGE, WPARAM(Control), LPARAM(Inserting))\r\n else\r\n BaseWndProc(CM_CONTROLCHANGE, WPARAM(Control), LPARAM(Inserting));\r\nend;\r\n\r\nprocedure TJvExCustomControlBar.ControlsListChanged(Control: TControl; Inserting: Boolean);\r\nbegin\r\n if not Inserting then\r\n BaseWndProc(CM_CONTROLLISTCHANGE, WPARAM(Control), LPARAM(Inserting))\r\n else\r\n BaseWndProc(CM_CONTROLCHANGE, WPARAM(Control), LPARAM(Inserting));\r\nend;\r\n\r\nprocedure TJvExCustomControlBar.GetDlgCode(var Code: TDlgCodes);\r\nbegin\r\nend;\r\n\r\nprocedure TJvExCustomControlBar.FocusSet(PrevWnd: THandle);\r\nbegin\r\n BaseWndProc(WM_SETFOCUS, WPARAM(PrevWnd), 0);\r\nend;\r\n\r\nprocedure TJvExCustomControlBar.FocusKilled(NextWnd: THandle);\r\nbegin\r\n BaseWndProc(WM_KILLFOCUS, WPARAM(NextWnd), 0);\r\nend;\r\n\r\nfunction TJvExCustomControlBar.DoEraseBackground(Canvas: TCanvas; Param: LPARAM): Boolean;\r\nbegin\r\n Result := BaseWndProc(WM_ERASEBKGND, Canvas.Handle, Param) <> 0;\r\nend;\r\n\r\n{$IFDEF JVCLThemesEnabledD6}\r\nfunction TJvExCustomControlBar.GetParentBackground: Boolean;\r\nbegin\r\n Result := JvThemes.GetParentBackground(Self);\r\nend;\r\n\r\nprocedure TJvExCustomControlBar.SetParentBackground(Value: Boolean);\r\nbegin\r\n JvThemes.SetParentBackground(Self, Value);\r\nend;\r\n{$ENDIF JVCLThemesEnabledD6}\r\n\r\nprocedure TJvExCustomControlBar.WndProc(var Msg: TMessage);\r\nvar\r\n IdSaveDC: Integer;\r\n DlgCodes: TDlgCodes;\r\n Canvas: TCanvas;\r\nbegin\r\n if not DispatchIsDesignMsg(Self, Msg) then\r\n begin\r\n case Msg.Msg of\r\n CM_DENYSUBCLASSING:\r\n Msg.Result := LRESULT(Ord(GetInterfaceEntry(IJvDenySubClassing) <> nil));\r\n CM_DIALOGCHAR:\r\n with TCMDialogChar{$IFDEF CLR}.Create{$ENDIF}(Msg) do\r\n Result := LRESULT(Ord(WantKey(CharCode, KeyDataToShiftState(KeyData))));\r\n CM_HINTSHOW:\r\n with TCMHintShow(Msg) do\r\n Result := LRESULT(HintShow(HintInfo^));\r\n CM_HITTEST:\r\n with TCMHitTest(Msg) do\r\n Result := LRESULT(HitTest(XPos, YPos));\r\n CM_MOUSEENTER:\r\n MouseEnter(TControl(Msg.LParam));\r\n CM_MOUSELEAVE:\r\n MouseLeave(TControl(Msg.LParam));\r\n CM_VISIBLECHANGED:\r\n VisibleChanged;\r\n CM_ENABLEDCHANGED:\r\n EnabledChanged;\r\n CM_TEXTCHANGED:\r\n TextChanged;\r\n CM_FONTCHANGED:\r\n FontChanged;\r\n CM_COLORCHANGED:\r\n ColorChanged;\r\n CM_FOCUSCHANGED:\r\n FocusChanged(TWinControl(Msg.LParam));\r\n CM_PARENTFONTCHANGED:\r\n ParentFontChanged;\r\n CM_PARENTCOLORCHANGED:\r\n ParentColorChanged;\r\n CM_PARENTSHOWHINTCHANGED:\r\n ParentShowHintChanged;\r\n CM_CURSORCHANGED:\r\n CursorChanged;\r\n CM_SHOWINGCHANGED:\r\n ShowingChanged;\r\n CM_SHOWHINTCHANGED:\r\n ShowHintChanged;\r\n CM_CONTROLLISTCHANGE:\r\n if Msg.LParam <> 0 then\r\n ControlsListChanging(TControl(Msg.WParam), True)\r\n else\r\n ControlsListChanged(TControl(Msg.WParam), False);\r\n CM_CONTROLCHANGE:\r\n if Msg.LParam = 0 then\r\n ControlsListChanging(TControl(Msg.WParam), False)\r\n else\r\n ControlsListChanged(TControl(Msg.WParam), True);\r\n WM_SETFOCUS:\r\n FocusSet(THandle(Msg.WParam));\r\n WM_KILLFOCUS:\r\n FocusKilled(THandle(Msg.WParam));\r\n WM_SIZE, WM_MOVE:\r\n begin\r\n inherited WndProc(Msg);\r\n BoundsChanged;\r\n end;\r\n WM_ERASEBKGND:\r\n if (Msg.WParam <> 0) and not IsDefaultEraseBackground(DoEraseBackground, @TJvExCustomControlBar.DoEraseBackground) then\r\n begin\r\n IdSaveDC := SaveDC(HDC(Msg.WParam)); // protect DC against Stock-Objects from Canvas\r\n Canvas := TCanvas.Create;\r\n try\r\n Canvas.Handle := HDC(Msg.WParam);\r\n Msg.Result := Ord(DoEraseBackground(Canvas, Msg.LParam));\r\n finally\r\n Canvas.Handle := 0;\r\n Canvas.Free;\r\n RestoreDC(HDC(Msg.WParam), IdSaveDC);\r\n end;\r\n end\r\n else\r\n inherited WndProc(Msg);\r\n {$IFNDEF DELPHI2007_UP}\r\n WM_PRINTCLIENT, WM_PRINT: // VCL bug fix\r\n begin\r\n IdSaveDC := SaveDC(HDC(Msg.WParam)); // protect DC against changes\r\n try\r\n inherited WndProc(Msg);\r\n finally\r\n RestoreDC(HDC(Msg.WParam), IdSaveDC);\r\n end;\r\n end;\r\n {$ENDIF ~DELPHI2007_UP}\r\n WM_GETDLGCODE:\r\n begin\r\n inherited WndProc(Msg);\r\n DlgCodes := [dcNative] + DlgcToDlgCodes(Msg.Result);\r\n GetDlgCode(DlgCodes);\r\n if not (dcNative in DlgCodes) then\r\n Msg.Result := DlgCodesToDlgc(DlgCodes);\r\n end;\r\n else\r\n inherited WndProc(Msg);\r\n end;\r\n case Msg.Msg of // precheck message to prevent access violations on released controls\r\n CM_MOUSEENTER, CM_MOUSELEAVE, WM_KILLFOCUS, WM_SETFOCUS, WM_NCPAINT:\r\n if DotNetHighlighting then\r\n HandleDotNetHighlighting(Self, Msg, MouseOver, Color);\r\n end;\r\n end;\r\nend;\r\n\r\n//============================================================================\r\n\r\nconstructor TJvExControlBar.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FHintColor := clDefault;\r\nend;\r\n\r\nfunction TJvExControlBar.BaseWndProc(Msg: Cardinal; WParam: WPARAM = 0; LParam: LPARAM = 0): LRESULT;\r\nvar\r\n Mesg: TMessage;\r\nbegin\r\n CreateWMMessage(Mesg, Msg, WParam, LParam);\r\n inherited WndProc(Mesg);\r\n Result := Mesg.Result;\r\nend;\r\n\r\nfunction TJvExControlBar.BaseWndProc(Msg: Cardinal; WParam: WPARAM; LParam: TObject): LRESULT;\r\nbegin\r\n Result := BaseWndProc(Msg, WParam, Windows.LPARAM(LParam));\r\nend;\r\n\r\nfunction TJvExControlBar.BaseWndProcEx(Msg: Cardinal; WParam: WPARAM; var StructLParam): LRESULT;\r\nbegin\r\n Result := BaseWndProc(Msg, WParam, Windows.LPARAM(@StructLParam));\r\nend;\r\n\r\nprocedure TJvExControlBar.VisibleChanged;\r\nbegin\r\n BaseWndProc(CM_VISIBLECHANGED);\r\nend;\r\n\r\nprocedure TJvExControlBar.EnabledChanged;\r\nbegin\r\n BaseWndProc(CM_ENABLEDCHANGED);\r\nend;\r\n\r\nprocedure TJvExControlBar.TextChanged;\r\nbegin\r\n BaseWndProc(CM_TEXTCHANGED);\r\nend;\r\n\r\nprocedure TJvExControlBar.FontChanged;\r\nbegin\r\n BaseWndProc(CM_FONTCHANGED);\r\nend;\r\n\r\nprocedure TJvExControlBar.ColorChanged;\r\nbegin\r\n BaseWndProc(CM_COLORCHANGED);\r\nend;\r\n\r\nprocedure TJvExControlBar.ParentFontChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTFONTCHANGED);\r\nend;\r\n\r\nprocedure TJvExControlBar.ParentColorChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTCOLORCHANGED);\r\n if Assigned(OnParentColorChange) then\r\n OnParentColorChange(Self);\r\nend;\r\n\r\nprocedure TJvExControlBar.ParentShowHintChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTSHOWHINTCHANGED);\r\nend;\r\n\r\nfunction TJvExControlBar.WantKey(Key: Integer; Shift: TShiftState): Boolean;\r\nbegin\r\n Result := BaseWndProc(CM_DIALOGCHAR, Word(Key), ShiftStateToKeyData(Shift)) <> 0;\r\nend;\r\n\r\nfunction TJvExControlBar.HitTest(X, Y: Integer): Boolean;\r\nbegin\r\n Result := BaseWndProc(CM_HITTEST, 0, SmallPointToLong(PointToSmallPoint(Point(X, Y)))) <> 0;\r\nend;\r\n\r\nfunction TJvExControlBar.HintShow(var HintInfo: THintInfo): Boolean;\r\nbegin\r\n GetHintColor(HintInfo, Self, FHintColor);\r\n if FHintWindowClass <> nil then\r\n HintInfo.HintWindowClass := FHintWindowClass;\r\n Result := BaseWndProcEx(CM_HINTSHOW, 0, HintInfo) <> 0;\r\nend;\r\n\r\nprocedure TJvExControlBar.MouseEnter(AControl: TControl);\r\nbegin\r\n FMouseOver := True;\r\n if Assigned(FOnMouseEnter) then\r\n FOnMouseEnter(Self);\r\n BaseWndProc(CM_MOUSEENTER, 0, AControl);\r\nend;\r\n\r\nprocedure TJvExControlBar.MouseLeave(AControl: TControl);\r\nbegin\r\n FMouseOver := False;\r\n BaseWndProc(CM_MOUSELEAVE, 0, AControl);\r\n if Assigned(FOnMouseLeave) then\r\n FOnMouseLeave(Self);\r\nend;\r\n\r\nprocedure TJvExControlBar.FocusChanged(AControl: TWinControl);\r\nbegin\r\n BaseWndProc(CM_FOCUSCHANGED, 0, AControl);\r\nend;\r\n\r\nprocedure TJvExControlBar.BoundsChanged;\r\nbegin\r\nend;\r\n\r\nprocedure TJvExControlBar.CursorChanged;\r\nbegin\r\n BaseWndProc(CM_CURSORCHANGED);\r\nend;\r\n\r\nprocedure TJvExControlBar.ShowingChanged;\r\nbegin\r\n BaseWndProc(CM_SHOWINGCHANGED);\r\nend;\r\n\r\nprocedure TJvExControlBar.ShowHintChanged;\r\nbegin\r\n BaseWndProc(CM_SHOWHINTCHANGED);\r\nend;\r\n\r\n{ VCL sends CM_CONTROLLISTCHANGE and CM_CONTROLCHANGE in a different order than\r\n the CLX methods are used. So we must correct it by evaluating \"Inserting\". }\r\nprocedure TJvExControlBar.ControlsListChanging(Control: TControl; Inserting: Boolean);\r\nbegin\r\n if Inserting then\r\n BaseWndProc(CM_CONTROLLISTCHANGE, WPARAM(Control), LPARAM(Inserting))\r\n else\r\n BaseWndProc(CM_CONTROLCHANGE, WPARAM(Control), LPARAM(Inserting));\r\nend;\r\n\r\nprocedure TJvExControlBar.ControlsListChanged(Control: TControl; Inserting: Boolean);\r\nbegin\r\n if not Inserting then\r\n BaseWndProc(CM_CONTROLLISTCHANGE, WPARAM(Control), LPARAM(Inserting))\r\n else\r\n BaseWndProc(CM_CONTROLCHANGE, WPARAM(Control), LPARAM(Inserting));\r\nend;\r\n\r\nprocedure TJvExControlBar.GetDlgCode(var Code: TDlgCodes);\r\nbegin\r\nend;\r\n\r\nprocedure TJvExControlBar.FocusSet(PrevWnd: THandle);\r\nbegin\r\n BaseWndProc(WM_SETFOCUS, WPARAM(PrevWnd), 0);\r\nend;\r\n\r\nprocedure TJvExControlBar.FocusKilled(NextWnd: THandle);\r\nbegin\r\n BaseWndProc(WM_KILLFOCUS, WPARAM(NextWnd), 0);\r\nend;\r\n\r\nfunction TJvExControlBar.DoEraseBackground(Canvas: TCanvas; Param: LPARAM): Boolean;\r\nbegin\r\n Result := BaseWndProc(WM_ERASEBKGND, Canvas.Handle, Param) <> 0;\r\nend;\r\n\r\n{$IFDEF JVCLThemesEnabledD6}\r\nfunction TJvExControlBar.GetParentBackground: Boolean;\r\nbegin\r\n Result := JvThemes.GetParentBackground(Self);\r\nend;\r\n\r\nprocedure TJvExControlBar.SetParentBackground(Value: Boolean);\r\nbegin\r\n JvThemes.SetParentBackground(Self, Value);\r\nend;\r\n{$ENDIF JVCLThemesEnabledD6}\r\n\r\nprocedure TJvExControlBar.WndProc(var Msg: TMessage);\r\nvar\r\n IdSaveDC: Integer;\r\n DlgCodes: TDlgCodes;\r\n Canvas: TCanvas;\r\nbegin\r\n if not DispatchIsDesignMsg(Self, Msg) then\r\n begin\r\n case Msg.Msg of\r\n CM_DENYSUBCLASSING:\r\n Msg.Result := LRESULT(Ord(GetInterfaceEntry(IJvDenySubClassing) <> nil));\r\n CM_DIALOGCHAR:\r\n with TCMDialogChar{$IFDEF CLR}.Create{$ENDIF}(Msg) do\r\n Result := LRESULT(Ord(WantKey(CharCode, KeyDataToShiftState(KeyData))));\r\n CM_HINTSHOW:\r\n with TCMHintShow(Msg) do\r\n Result := LRESULT(HintShow(HintInfo^));\r\n CM_HITTEST:\r\n with TCMHitTest(Msg) do\r\n Result := LRESULT(HitTest(XPos, YPos));\r\n CM_MOUSEENTER:\r\n MouseEnter(TControl(Msg.LParam));\r\n CM_MOUSELEAVE:\r\n MouseLeave(TControl(Msg.LParam));\r\n CM_VISIBLECHANGED:\r\n VisibleChanged;\r\n CM_ENABLEDCHANGED:\r\n EnabledChanged;\r\n CM_TEXTCHANGED:\r\n TextChanged;\r\n CM_FONTCHANGED:\r\n FontChanged;\r\n CM_COLORCHANGED:\r\n ColorChanged;\r\n CM_FOCUSCHANGED:\r\n FocusChanged(TWinControl(Msg.LParam));\r\n CM_PARENTFONTCHANGED:\r\n ParentFontChanged;\r\n CM_PARENTCOLORCHANGED:\r\n ParentColorChanged;\r\n CM_PARENTSHOWHINTCHANGED:\r\n ParentShowHintChanged;\r\n CM_CURSORCHANGED:\r\n CursorChanged;\r\n CM_SHOWINGCHANGED:\r\n ShowingChanged;\r\n CM_SHOWHINTCHANGED:\r\n ShowHintChanged;\r\n CM_CONTROLLISTCHANGE:\r\n if Msg.LParam <> 0 then\r\n ControlsListChanging(TControl(Msg.WParam), True)\r\n else\r\n ControlsListChanged(TControl(Msg.WParam), False);\r\n CM_CONTROLCHANGE:\r\n if Msg.LParam = 0 then\r\n ControlsListChanging(TControl(Msg.WParam), False)\r\n else\r\n ControlsListChanged(TControl(Msg.WParam), True);\r\n WM_SETFOCUS:\r\n FocusSet(THandle(Msg.WParam));\r\n WM_KILLFOCUS:\r\n FocusKilled(THandle(Msg.WParam));\r\n WM_SIZE, WM_MOVE:\r\n begin\r\n inherited WndProc(Msg);\r\n BoundsChanged;\r\n end;\r\n WM_ERASEBKGND:\r\n if (Msg.WParam <> 0) and not IsDefaultEraseBackground(DoEraseBackground, @TJvExControlBar.DoEraseBackground) then\r\n begin\r\n IdSaveDC := SaveDC(HDC(Msg.WParam)); // protect DC against Stock-Objects from Canvas\r\n Canvas := TCanvas.Create;\r\n try\r\n Canvas.Handle := HDC(Msg.WParam);\r\n Msg.Result := Ord(DoEraseBackground(Canvas, Msg.LParam));\r\n finally\r\n Canvas.Handle := 0;\r\n Canvas.Free;\r\n RestoreDC(HDC(Msg.WParam), IdSaveDC);\r\n end;\r\n end\r\n else\r\n inherited WndProc(Msg);\r\n {$IFNDEF DELPHI2007_UP}\r\n WM_PRINTCLIENT, WM_PRINT: // VCL bug fix\r\n begin\r\n IdSaveDC := SaveDC(HDC(Msg.WParam)); // protect DC against changes\r\n try\r\n inherited WndProc(Msg);\r\n finally\r\n RestoreDC(HDC(Msg.WParam), IdSaveDC);\r\n end;\r\n end;\r\n {$ENDIF ~DELPHI2007_UP}\r\n WM_GETDLGCODE:\r\n begin\r\n inherited WndProc(Msg);\r\n DlgCodes := [dcNative] + DlgcToDlgCodes(Msg.Result);\r\n GetDlgCode(DlgCodes);\r\n if not (dcNative in DlgCodes) then\r\n Msg.Result := DlgCodesToDlgc(DlgCodes);\r\n end;\r\n else\r\n inherited WndProc(Msg);\r\n end;\r\n case Msg.Msg of // precheck message to prevent access violations on released controls\r\n CM_MOUSEENTER, CM_MOUSELEAVE, WM_KILLFOCUS, WM_SETFOCUS, WM_NCPAINT:\r\n if DotNetHighlighting then\r\n HandleDotNetHighlighting(Self, Msg, MouseOver, Color);\r\n end;\r\n end;\r\nend;\r\n\r\n//============================================================================\r\n\r\nconstructor TJvExPanel.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FHintColor := clDefault;\r\nend;\r\n\r\nfunction TJvExPanel.BaseWndProc(Msg: Cardinal; WParam: WPARAM = 0; LParam: LPARAM = 0): LRESULT;\r\nvar\r\n Mesg: TMessage;\r\nbegin\r\n CreateWMMessage(Mesg, Msg, WParam, LParam);\r\n inherited WndProc(Mesg);\r\n Result := Mesg.Result;\r\nend;\r\n\r\nfunction TJvExPanel.BaseWndProc(Msg: Cardinal; WParam: WPARAM; LParam: TObject): LRESULT;\r\nbegin\r\n Result := BaseWndProc(Msg, WParam, Windows.LPARAM(LParam));\r\nend;\r\n\r\nfunction TJvExPanel.BaseWndProcEx(Msg: Cardinal; WParam: WPARAM; var StructLParam): LRESULT;\r\nbegin\r\n Result := BaseWndProc(Msg, WParam, Windows.LPARAM(@StructLParam));\r\nend;\r\n\r\nprocedure TJvExPanel.VisibleChanged;\r\nbegin\r\n BaseWndProc(CM_VISIBLECHANGED);\r\nend;\r\n\r\nprocedure TJvExPanel.EnabledChanged;\r\nbegin\r\n BaseWndProc(CM_ENABLEDCHANGED);\r\nend;\r\n\r\nprocedure TJvExPanel.TextChanged;\r\nbegin\r\n BaseWndProc(CM_TEXTCHANGED);\r\nend;\r\n\r\nprocedure TJvExPanel.FontChanged;\r\nbegin\r\n BaseWndProc(CM_FONTCHANGED);\r\nend;\r\n\r\nprocedure TJvExPanel.ColorChanged;\r\nbegin\r\n BaseWndProc(CM_COLORCHANGED);\r\nend;\r\n\r\nprocedure TJvExPanel.ParentFontChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTFONTCHANGED);\r\nend;\r\n\r\nprocedure TJvExPanel.ParentColorChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTCOLORCHANGED);\r\n if Assigned(OnParentColorChange) then\r\n OnParentColorChange(Self);\r\nend;\r\n\r\nprocedure TJvExPanel.ParentShowHintChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTSHOWHINTCHANGED);\r\nend;\r\n\r\nfunction TJvExPanel.WantKey(Key: Integer; Shift: TShiftState): Boolean;\r\nbegin\r\n Result := BaseWndProc(CM_DIALOGCHAR, Word(Key), ShiftStateToKeyData(Shift)) <> 0;\r\nend;\r\n\r\nfunction TJvExPanel.HitTest(X, Y: Integer): Boolean;\r\nbegin\r\n Result := BaseWndProc(CM_HITTEST, 0, SmallPointToLong(PointToSmallPoint(Point(X, Y)))) <> 0;\r\nend;\r\n\r\nfunction TJvExPanel.HintShow(var HintInfo: THintInfo): Boolean;\r\nbegin\r\n GetHintColor(HintInfo, Self, FHintColor);\r\n if FHintWindowClass <> nil then\r\n HintInfo.HintWindowClass := FHintWindowClass;\r\n Result := BaseWndProcEx(CM_HINTSHOW, 0, HintInfo) <> 0;\r\nend;\r\n\r\nprocedure TJvExPanel.MouseEnter(AControl: TControl);\r\nbegin\r\n FMouseOver := True;\r\n if Assigned(FOnMouseEnter) then\r\n FOnMouseEnter(Self);\r\n BaseWndProc(CM_MOUSEENTER, 0, AControl);\r\nend;\r\n\r\nprocedure TJvExPanel.MouseLeave(AControl: TControl);\r\nbegin\r\n FMouseOver := False;\r\n BaseWndProc(CM_MOUSELEAVE, 0, AControl);\r\n if Assigned(FOnMouseLeave) then\r\n FOnMouseLeave(Self);\r\nend;\r\n\r\nprocedure TJvExPanel.FocusChanged(AControl: TWinControl);\r\nbegin\r\n BaseWndProc(CM_FOCUSCHANGED, 0, AControl);\r\nend;\r\n\r\nprocedure TJvExPanel.BoundsChanged;\r\nbegin\r\nend;\r\n\r\nprocedure TJvExPanel.CursorChanged;\r\nbegin\r\n BaseWndProc(CM_CURSORCHANGED);\r\nend;\r\n\r\nprocedure TJvExPanel.ShowingChanged;\r\nbegin\r\n BaseWndProc(CM_SHOWINGCHANGED);\r\nend;\r\n\r\nprocedure TJvExPanel.ShowHintChanged;\r\nbegin\r\n BaseWndProc(CM_SHOWHINTCHANGED);\r\nend;\r\n\r\n{ VCL sends CM_CONTROLLISTCHANGE and CM_CONTROLCHANGE in a different order than\r\n the CLX methods are used. So we must correct it by evaluating \"Inserting\". }\r\nprocedure TJvExPanel.ControlsListChanging(Control: TControl; Inserting: Boolean);\r\nbegin\r\n if Inserting then\r\n BaseWndProc(CM_CONTROLLISTCHANGE, WPARAM(Control), LPARAM(Inserting))\r\n else\r\n BaseWndProc(CM_CONTROLCHANGE, WPARAM(Control), LPARAM(Inserting));\r\nend;\r\n\r\nprocedure TJvExPanel.ControlsListChanged(Control: TControl; Inserting: Boolean);\r\nbegin\r\n if not Inserting then\r\n BaseWndProc(CM_CONTROLLISTCHANGE, WPARAM(Control), LPARAM(Inserting))\r\n else\r\n BaseWndProc(CM_CONTROLCHANGE, WPARAM(Control), LPARAM(Inserting));\r\nend;\r\n\r\nprocedure TJvExPanel.GetDlgCode(var Code: TDlgCodes);\r\nbegin\r\nend;\r\n\r\nprocedure TJvExPanel.FocusSet(PrevWnd: THandle);\r\nbegin\r\n BaseWndProc(WM_SETFOCUS, WPARAM(PrevWnd), 0);\r\nend;\r\n\r\nprocedure TJvExPanel.FocusKilled(NextWnd: THandle);\r\nbegin\r\n BaseWndProc(WM_KILLFOCUS, WPARAM(NextWnd), 0);\r\nend;\r\n\r\nfunction TJvExPanel.DoEraseBackground(Canvas: TCanvas; Param: LPARAM): Boolean;\r\nbegin\r\n Result := BaseWndProc(WM_ERASEBKGND, Canvas.Handle, Param) <> 0;\r\nend;\r\n\r\n{$IFDEF JVCLThemesEnabledD6}\r\nfunction TJvExPanel.GetParentBackground: Boolean;\r\nbegin\r\n Result := JvThemes.GetParentBackground(Self);\r\nend;\r\n\r\nprocedure TJvExPanel.SetParentBackground(Value: Boolean);\r\nbegin\r\n JvThemes.SetParentBackground(Self, Value);\r\nend;\r\n{$ENDIF JVCLThemesEnabledD6}\r\n\r\nprocedure TJvExPanel.WndProc(var Msg: TMessage);\r\nvar\r\n IdSaveDC: Integer;\r\n DlgCodes: TDlgCodes;\r\n Canvas: TCanvas;\r\nbegin\r\n if not DispatchIsDesignMsg(Self, Msg) then\r\n begin\r\n case Msg.Msg of\r\n CM_DENYSUBCLASSING:\r\n Msg.Result := LRESULT(Ord(GetInterfaceEntry(IJvDenySubClassing) <> nil));\r\n CM_DIALOGCHAR:\r\n with TCMDialogChar{$IFDEF CLR}.Create{$ENDIF}(Msg) do\r\n Result := LRESULT(Ord(WantKey(CharCode, KeyDataToShiftState(KeyData))));\r\n CM_HINTSHOW:\r\n with TCMHintShow(Msg) do\r\n Result := LRESULT(HintShow(HintInfo^));\r\n CM_HITTEST:\r\n with TCMHitTest(Msg) do\r\n Result := LRESULT(HitTest(XPos, YPos));\r\n CM_MOUSEENTER:\r\n MouseEnter(TControl(Msg.LParam));\r\n CM_MOUSELEAVE:\r\n MouseLeave(TControl(Msg.LParam));\r\n CM_VISIBLECHANGED:\r\n VisibleChanged;\r\n CM_ENABLEDCHANGED:\r\n EnabledChanged;\r\n CM_TEXTCHANGED:\r\n TextChanged;\r\n CM_FONTCHANGED:\r\n FontChanged;\r\n CM_COLORCHANGED:\r\n ColorChanged;\r\n CM_FOCUSCHANGED:\r\n FocusChanged(TWinControl(Msg.LParam));\r\n CM_PARENTFONTCHANGED:\r\n ParentFontChanged;\r\n CM_PARENTCOLORCHANGED:\r\n ParentColorChanged;\r\n CM_PARENTSHOWHINTCHANGED:\r\n ParentShowHintChanged;\r\n CM_CURSORCHANGED:\r\n CursorChanged;\r\n CM_SHOWINGCHANGED:\r\n ShowingChanged;\r\n CM_SHOWHINTCHANGED:\r\n ShowHintChanged;\r\n CM_CONTROLLISTCHANGE:\r\n if Msg.LParam <> 0 then\r\n ControlsListChanging(TControl(Msg.WParam), True)\r\n else\r\n ControlsListChanged(TControl(Msg.WParam), False);\r\n CM_CONTROLCHANGE:\r\n if Msg.LParam = 0 then\r\n ControlsListChanging(TControl(Msg.WParam), False)\r\n else\r\n ControlsListChanged(TControl(Msg.WParam), True);\r\n WM_SETFOCUS:\r\n FocusSet(THandle(Msg.WParam));\r\n WM_KILLFOCUS:\r\n FocusKilled(THandle(Msg.WParam));\r\n WM_SIZE, WM_MOVE:\r\n begin\r\n inherited WndProc(Msg);\r\n BoundsChanged;\r\n end;\r\n WM_ERASEBKGND:\r\n if (Msg.WParam <> 0) and not IsDefaultEraseBackground(DoEraseBackground, @TJvExPanel.DoEraseBackground) then\r\n begin\r\n IdSaveDC := SaveDC(HDC(Msg.WParam)); // protect DC against Stock-Objects from Canvas\r\n Canvas := TCanvas.Create;\r\n try\r\n Canvas.Handle := HDC(Msg.WParam);\r\n Msg.Result := Ord(DoEraseBackground(Canvas, Msg.LParam));\r\n finally\r\n Canvas.Handle := 0;\r\n Canvas.Free;\r\n RestoreDC(HDC(Msg.WParam), IdSaveDC);\r\n end;\r\n end\r\n else\r\n inherited WndProc(Msg);\r\n {$IFNDEF DELPHI2007_UP}\r\n WM_PRINTCLIENT, WM_PRINT: // VCL bug fix\r\n begin\r\n IdSaveDC := SaveDC(HDC(Msg.WParam)); // protect DC against changes\r\n try\r\n inherited WndProc(Msg);\r\n finally\r\n RestoreDC(HDC(Msg.WParam), IdSaveDC);\r\n end;\r\n end;\r\n {$ENDIF ~DELPHI2007_UP}\r\n WM_GETDLGCODE:\r\n begin\r\n inherited WndProc(Msg);\r\n DlgCodes := [dcNative] + DlgcToDlgCodes(Msg.Result);\r\n GetDlgCode(DlgCodes);\r\n if not (dcNative in DlgCodes) then\r\n Msg.Result := DlgCodesToDlgc(DlgCodes);\r\n end;\r\n else\r\n inherited WndProc(Msg);\r\n end;\r\n case Msg.Msg of // precheck message to prevent access violations on released controls\r\n CM_MOUSEENTER, CM_MOUSELEAVE, WM_KILLFOCUS, WM_SETFOCUS, WM_NCPAINT:\r\n if DotNetHighlighting then\r\n HandleDotNetHighlighting(Self, Msg, MouseOver, Color);\r\n end;\r\n end;\r\nend;\r\n\r\n//============================================================================\r\n\r\nconstructor TJvExRadioGroup.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FHintColor := clDefault;\r\nend;\r\n\r\nfunction TJvExRadioGroup.BaseWndProc(Msg: Cardinal; WParam: WPARAM = 0; LParam: LPARAM = 0): LRESULT;\r\nvar\r\n Mesg: TMessage;\r\nbegin\r\n CreateWMMessage(Mesg, Msg, WParam, LParam);\r\n inherited WndProc(Mesg);\r\n Result := Mesg.Result;\r\nend;\r\n\r\nfunction TJvExRadioGroup.BaseWndProc(Msg: Cardinal; WParam: WPARAM; LParam: TObject): LRESULT;\r\nbegin\r\n Result := BaseWndProc(Msg, WParam, Windows.LPARAM(LParam));\r\nend;\r\n\r\nfunction TJvExRadioGroup.BaseWndProcEx(Msg: Cardinal; WParam: WPARAM; var StructLParam): LRESULT;\r\nbegin\r\n Result := BaseWndProc(Msg, WParam, Windows.LPARAM(@StructLParam));\r\nend;\r\n\r\nprocedure TJvExRadioGroup.VisibleChanged;\r\nbegin\r\n BaseWndProc(CM_VISIBLECHANGED);\r\nend;\r\n\r\nprocedure TJvExRadioGroup.EnabledChanged;\r\nbegin\r\n BaseWndProc(CM_ENABLEDCHANGED);\r\nend;\r\n\r\nprocedure TJvExRadioGroup.TextChanged;\r\nbegin\r\n BaseWndProc(CM_TEXTCHANGED);\r\nend;\r\n\r\nprocedure TJvExRadioGroup.FontChanged;\r\nbegin\r\n BaseWndProc(CM_FONTCHANGED);\r\nend;\r\n\r\nprocedure TJvExRadioGroup.ColorChanged;\r\nbegin\r\n BaseWndProc(CM_COLORCHANGED);\r\nend;\r\n\r\nprocedure TJvExRadioGroup.ParentFontChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTFONTCHANGED);\r\nend;\r\n\r\nprocedure TJvExRadioGroup.ParentColorChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTCOLORCHANGED);\r\n if Assigned(OnParentColorChange) then\r\n OnParentColorChange(Self);\r\nend;\r\n\r\nprocedure TJvExRadioGroup.ParentShowHintChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTSHOWHINTCHANGED);\r\nend;\r\n\r\nfunction TJvExRadioGroup.WantKey(Key: Integer; Shift: TShiftState): Boolean;\r\nbegin\r\n Result := BaseWndProc(CM_DIALOGCHAR, Word(Key), ShiftStateToKeyData(Shift)) <> 0;\r\nend;\r\n\r\nfunction TJvExRadioGroup.HitTest(X, Y: Integer): Boolean;\r\nbegin\r\n Result := BaseWndProc(CM_HITTEST, 0, SmallPointToLong(PointToSmallPoint(Point(X, Y)))) <> 0;\r\nend;\r\n\r\nfunction TJvExRadioGroup.HintShow(var HintInfo: THintInfo): Boolean;\r\nbegin\r\n GetHintColor(HintInfo, Self, FHintColor);\r\n if FHintWindowClass <> nil then\r\n HintInfo.HintWindowClass := FHintWindowClass;\r\n Result := BaseWndProcEx(CM_HINTSHOW, 0, HintInfo) <> 0;\r\nend;\r\n\r\nprocedure TJvExRadioGroup.MouseEnter(AControl: TControl);\r\nbegin\r\n FMouseOver := True;\r\n if Assigned(FOnMouseEnter) then\r\n FOnMouseEnter(Self);\r\n BaseWndProc(CM_MOUSEENTER, 0, AControl);\r\nend;\r\n\r\nprocedure TJvExRadioGroup.MouseLeave(AControl: TControl);\r\nbegin\r\n FMouseOver := False;\r\n BaseWndProc(CM_MOUSELEAVE, 0, AControl);\r\n if Assigned(FOnMouseLeave) then\r\n FOnMouseLeave(Self);\r\nend;\r\n\r\nprocedure TJvExRadioGroup.FocusChanged(AControl: TWinControl);\r\nbegin\r\n BaseWndProc(CM_FOCUSCHANGED, 0, AControl);\r\nend;\r\n\r\nprocedure TJvExRadioGroup.BoundsChanged;\r\nbegin\r\nend;\r\n\r\nprocedure TJvExRadioGroup.CursorChanged;\r\nbegin\r\n BaseWndProc(CM_CURSORCHANGED);\r\nend;\r\n\r\nprocedure TJvExRadioGroup.ShowingChanged;\r\nbegin\r\n BaseWndProc(CM_SHOWINGCHANGED);\r\nend;\r\n\r\nprocedure TJvExRadioGroup.ShowHintChanged;\r\nbegin\r\n BaseWndProc(CM_SHOWHINTCHANGED);\r\nend;\r\n\r\n{ VCL sends CM_CONTROLLISTCHANGE and CM_CONTROLCHANGE in a different order than\r\n the CLX methods are used. So we must correct it by evaluating \"Inserting\". }\r\nprocedure TJvExRadioGroup.ControlsListChanging(Control: TControl; Inserting: Boolean);\r\nbegin\r\n if Inserting then\r\n BaseWndProc(CM_CONTROLLISTCHANGE, WPARAM(Control), LPARAM(Inserting))\r\n else\r\n BaseWndProc(CM_CONTROLCHANGE, WPARAM(Control), LPARAM(Inserting));\r\nend;\r\n\r\nprocedure TJvExRadioGroup.ControlsListChanged(Control: TControl; Inserting: Boolean);\r\nbegin\r\n if not Inserting then\r\n BaseWndProc(CM_CONTROLLISTCHANGE, WPARAM(Control), LPARAM(Inserting))\r\n else\r\n BaseWndProc(CM_CONTROLCHANGE, WPARAM(Control), LPARAM(Inserting));\r\nend;\r\n\r\nprocedure TJvExRadioGroup.GetDlgCode(var Code: TDlgCodes);\r\nbegin\r\nend;\r\n\r\nprocedure TJvExRadioGroup.FocusSet(PrevWnd: THandle);\r\nbegin\r\n BaseWndProc(WM_SETFOCUS, WPARAM(PrevWnd), 0);\r\nend;\r\n\r\nprocedure TJvExRadioGroup.FocusKilled(NextWnd: THandle);\r\nbegin\r\n BaseWndProc(WM_KILLFOCUS, WPARAM(NextWnd), 0);\r\nend;\r\n\r\nfunction TJvExRadioGroup.DoEraseBackground(Canvas: TCanvas; Param: LPARAM): Boolean;\r\nbegin\r\n Result := BaseWndProc(WM_ERASEBKGND, Canvas.Handle, Param) <> 0;\r\nend;\r\n\r\n{$IFDEF JVCLThemesEnabledD6}\r\nfunction TJvExRadioGroup.GetParentBackground: Boolean;\r\nbegin\r\n Result := JvThemes.GetParentBackground(Self);\r\nend;\r\n\r\nprocedure TJvExRadioGroup.SetParentBackground(Value: Boolean);\r\nbegin\r\n JvThemes.SetParentBackground(Self, Value);\r\nend;\r\n{$ENDIF JVCLThemesEnabledD6}\r\n\r\nprocedure TJvExRadioGroup.WndProc(var Msg: TMessage);\r\nvar\r\n IdSaveDC: Integer;\r\n DlgCodes: TDlgCodes;\r\n Canvas: TCanvas;\r\nbegin\r\n if not DispatchIsDesignMsg(Self, Msg) then\r\n begin\r\n case Msg.Msg of\r\n CM_DENYSUBCLASSING:\r\n Msg.Result := LRESULT(Ord(GetInterfaceEntry(IJvDenySubClassing) <> nil));\r\n CM_DIALOGCHAR:\r\n with TCMDialogChar{$IFDEF CLR}.Create{$ENDIF}(Msg) do\r\n Result := LRESULT(Ord(WantKey(CharCode, KeyDataToShiftState(KeyData))));\r\n CM_HINTSHOW:\r\n with TCMHintShow(Msg) do\r\n Result := LRESULT(HintShow(HintInfo^));\r\n CM_HITTEST:\r\n with TCMHitTest(Msg) do\r\n Result := LRESULT(HitTest(XPos, YPos));\r\n CM_MOUSEENTER:\r\n MouseEnter(TControl(Msg.LParam));\r\n CM_MOUSELEAVE:\r\n MouseLeave(TControl(Msg.LParam));\r\n CM_VISIBLECHANGED:\r\n VisibleChanged;\r\n CM_ENABLEDCHANGED:\r\n EnabledChanged;\r\n CM_TEXTCHANGED:\r\n TextChanged;\r\n CM_FONTCHANGED:\r\n FontChanged;\r\n CM_COLORCHANGED:\r\n ColorChanged;\r\n CM_FOCUSCHANGED:\r\n FocusChanged(TWinControl(Msg.LParam));\r\n CM_PARENTFONTCHANGED:\r\n ParentFontChanged;\r\n CM_PARENTCOLORCHANGED:\r\n ParentColorChanged;\r\n CM_PARENTSHOWHINTCHANGED:\r\n ParentShowHintChanged;\r\n CM_CURSORCHANGED:\r\n CursorChanged;\r\n CM_SHOWINGCHANGED:\r\n ShowingChanged;\r\n CM_SHOWHINTCHANGED:\r\n ShowHintChanged;\r\n CM_CONTROLLISTCHANGE:\r\n if Msg.LParam <> 0 then\r\n ControlsListChanging(TControl(Msg.WParam), True)\r\n else\r\n ControlsListChanged(TControl(Msg.WParam), False);\r\n CM_CONTROLCHANGE:\r\n if Msg.LParam = 0 then\r\n ControlsListChanging(TControl(Msg.WParam), False)\r\n else\r\n ControlsListChanged(TControl(Msg.WParam), True);\r\n WM_SETFOCUS:\r\n FocusSet(THandle(Msg.WParam));\r\n WM_KILLFOCUS:\r\n FocusKilled(THandle(Msg.WParam));\r\n WM_SIZE, WM_MOVE:\r\n begin\r\n inherited WndProc(Msg);\r\n BoundsChanged;\r\n end;\r\n WM_ERASEBKGND:\r\n if (Msg.WParam <> 0) and not IsDefaultEraseBackground(DoEraseBackground, @TJvExRadioGroup.DoEraseBackground) then\r\n begin\r\n IdSaveDC := SaveDC(HDC(Msg.WParam)); // protect DC against Stock-Objects from Canvas\r\n Canvas := TCanvas.Create;\r\n try\r\n Canvas.Handle := HDC(Msg.WParam);\r\n Msg.Result := Ord(DoEraseBackground(Canvas, Msg.LParam));\r\n finally\r\n Canvas.Handle := 0;\r\n Canvas.Free;\r\n RestoreDC(HDC(Msg.WParam), IdSaveDC);\r\n end;\r\n end\r\n else\r\n inherited WndProc(Msg);\r\n {$IFNDEF DELPHI2007_UP}\r\n WM_PRINTCLIENT, WM_PRINT: // VCL bug fix\r\n begin\r\n IdSaveDC := SaveDC(HDC(Msg.WParam)); // protect DC against changes\r\n try\r\n inherited WndProc(Msg);\r\n finally\r\n RestoreDC(HDC(Msg.WParam), IdSaveDC);\r\n end;\r\n end;\r\n {$ENDIF ~DELPHI2007_UP}\r\n WM_GETDLGCODE:\r\n begin\r\n inherited WndProc(Msg);\r\n DlgCodes := [dcNative] + DlgcToDlgCodes(Msg.Result);\r\n GetDlgCode(DlgCodes);\r\n if not (dcNative in DlgCodes) then\r\n Msg.Result := DlgCodesToDlgc(DlgCodes);\r\n end;\r\n else\r\n inherited WndProc(Msg);\r\n end;\r\n case Msg.Msg of // precheck message to prevent access violations on released controls\r\n CM_MOUSEENTER, CM_MOUSELEAVE, WM_KILLFOCUS, WM_SETFOCUS, WM_NCPAINT:\r\n if DotNetHighlighting then\r\n HandleDotNetHighlighting(Self, Msg, MouseOver, Color);\r\n end;\r\n end;\r\nend;\r\n\r\n//============================================================================\r\n\r\nconstructor TJvExPage.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FHintColor := clDefault;\r\nend;\r\n\r\nfunction TJvExPage.BaseWndProc(Msg: Cardinal; WParam: WPARAM = 0; LParam: LPARAM = 0): LRESULT;\r\nvar\r\n Mesg: TMessage;\r\nbegin\r\n CreateWMMessage(Mesg, Msg, WParam, LParam);\r\n inherited WndProc(Mesg);\r\n Result := Mesg.Result;\r\nend;\r\n\r\nfunction TJvExPage.BaseWndProc(Msg: Cardinal; WParam: WPARAM; LParam: TObject): LRESULT;\r\nbegin\r\n Result := BaseWndProc(Msg, WParam, Windows.LPARAM(LParam));\r\nend;\r\n\r\nfunction TJvExPage.BaseWndProcEx(Msg: Cardinal; WParam: WPARAM; var StructLParam): LRESULT;\r\nbegin\r\n Result := BaseWndProc(Msg, WParam, Windows.LPARAM(@StructLParam));\r\nend;\r\n\r\nprocedure TJvExPage.VisibleChanged;\r\nbegin\r\n BaseWndProc(CM_VISIBLECHANGED);\r\nend;\r\n\r\nprocedure TJvExPage.EnabledChanged;\r\nbegin\r\n BaseWndProc(CM_ENABLEDCHANGED);\r\nend;\r\n\r\nprocedure TJvExPage.TextChanged;\r\nbegin\r\n BaseWndProc(CM_TEXTCHANGED);\r\nend;\r\n\r\nprocedure TJvExPage.FontChanged;\r\nbegin\r\n BaseWndProc(CM_FONTCHANGED);\r\nend;\r\n\r\nprocedure TJvExPage.ColorChanged;\r\nbegin\r\n BaseWndProc(CM_COLORCHANGED);\r\nend;\r\n\r\nprocedure TJvExPage.ParentFontChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTFONTCHANGED);\r\nend;\r\n\r\nprocedure TJvExPage.ParentColorChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTCOLORCHANGED);\r\n if Assigned(OnParentColorChange) then\r\n OnParentColorChange(Self);\r\nend;\r\n\r\nprocedure TJvExPage.ParentShowHintChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTSHOWHINTCHANGED);\r\nend;\r\n\r\nfunction TJvExPage.WantKey(Key: Integer; Shift: TShiftState): Boolean;\r\nbegin\r\n Result := BaseWndProc(CM_DIALOGCHAR, Word(Key), ShiftStateToKeyData(Shift)) <> 0;\r\nend;\r\n\r\nfunction TJvExPage.HitTest(X, Y: Integer): Boolean;\r\nbegin\r\n Result := BaseWndProc(CM_HITTEST, 0, SmallPointToLong(PointToSmallPoint(Point(X, Y)))) <> 0;\r\nend;\r\n\r\nfunction TJvExPage.HintShow(var HintInfo: THintInfo): Boolean;\r\nbegin\r\n GetHintColor(HintInfo, Self, FHintColor);\r\n if FHintWindowClass <> nil then\r\n HintInfo.HintWindowClass := FHintWindowClass;\r\n Result := BaseWndProcEx(CM_HINTSHOW, 0, HintInfo) <> 0;\r\nend;\r\n\r\nprocedure TJvExPage.MouseEnter(AControl: TControl);\r\nbegin\r\n FMouseOver := True;\r\n if Assigned(FOnMouseEnter) then\r\n FOnMouseEnter(Self);\r\n BaseWndProc(CM_MOUSEENTER, 0, AControl);\r\nend;\r\n\r\nprocedure TJvExPage.MouseLeave(AControl: TControl);\r\nbegin\r\n FMouseOver := False;\r\n BaseWndProc(CM_MOUSELEAVE, 0, AControl);\r\n if Assigned(FOnMouseLeave) then\r\n FOnMouseLeave(Self);\r\nend;\r\n\r\nprocedure TJvExPage.FocusChanged(AControl: TWinControl);\r\nbegin\r\n BaseWndProc(CM_FOCUSCHANGED, 0, AControl);\r\nend;\r\n\r\nprocedure TJvExPage.BoundsChanged;\r\nbegin\r\nend;\r\n\r\nprocedure TJvExPage.CursorChanged;\r\nbegin\r\n BaseWndProc(CM_CURSORCHANGED);\r\nend;\r\n\r\nprocedure TJvExPage.ShowingChanged;\r\nbegin\r\n BaseWndProc(CM_SHOWINGCHANGED);\r\nend;\r\n\r\nprocedure TJvExPage.ShowHintChanged;\r\nbegin\r\n BaseWndProc(CM_SHOWHINTCHANGED);\r\nend;\r\n\r\n{ VCL sends CM_CONTROLLISTCHANGE and CM_CONTROLCHANGE in a different order than\r\n the CLX methods are used. So we must correct it by evaluating \"Inserting\". }\r\nprocedure TJvExPage.ControlsListChanging(Control: TControl; Inserting: Boolean);\r\nbegin\r\n if Inserting then\r\n BaseWndProc(CM_CONTROLLISTCHANGE, WPARAM(Control), LPARAM(Inserting))\r\n else\r\n BaseWndProc(CM_CONTROLCHANGE, WPARAM(Control), LPARAM(Inserting));\r\nend;\r\n\r\nprocedure TJvExPage.ControlsListChanged(Control: TControl; Inserting: Boolean);\r\nbegin\r\n if not Inserting then\r\n BaseWndProc(CM_CONTROLLISTCHANGE, WPARAM(Control), LPARAM(Inserting))\r\n else\r\n BaseWndProc(CM_CONTROLCHANGE, WPARAM(Control), LPARAM(Inserting));\r\nend;\r\n\r\nprocedure TJvExPage.GetDlgCode(var Code: TDlgCodes);\r\nbegin\r\nend;\r\n\r\nprocedure TJvExPage.FocusSet(PrevWnd: THandle);\r\nbegin\r\n BaseWndProc(WM_SETFOCUS, WPARAM(PrevWnd), 0);\r\nend;\r\n\r\nprocedure TJvExPage.FocusKilled(NextWnd: THandle);\r\nbegin\r\n BaseWndProc(WM_KILLFOCUS, WPARAM(NextWnd), 0);\r\nend;\r\n\r\nfunction TJvExPage.DoEraseBackground(Canvas: TCanvas; Param: LPARAM): Boolean;\r\nbegin\r\n Result := BaseWndProc(WM_ERASEBKGND, Canvas.Handle, Param) <> 0;\r\nend;\r\n\r\n{$IFDEF JVCLThemesEnabledD6}\r\nfunction TJvExPage.GetParentBackground: Boolean;\r\nbegin\r\n Result := JvThemes.GetParentBackground(Self);\r\nend;\r\n\r\nprocedure TJvExPage.SetParentBackground(Value: Boolean);\r\nbegin\r\n JvThemes.SetParentBackground(Self, Value);\r\nend;\r\n{$ENDIF JVCLThemesEnabledD6}\r\n\r\nprocedure TJvExPage.WndProc(var Msg: TMessage);\r\nvar\r\n IdSaveDC: Integer;\r\n DlgCodes: TDlgCodes;\r\n Canvas: TCanvas;\r\nbegin\r\n if not DispatchIsDesignMsg(Self, Msg) then\r\n begin\r\n case Msg.Msg of\r\n CM_DENYSUBCLASSING:\r\n Msg.Result := LRESULT(Ord(GetInterfaceEntry(IJvDenySubClassing) <> nil));\r\n CM_DIALOGCHAR:\r\n with TCMDialogChar{$IFDEF CLR}.Create{$ENDIF}(Msg) do\r\n Result := LRESULT(Ord(WantKey(CharCode, KeyDataToShiftState(KeyData))));\r\n CM_HINTSHOW:\r\n with TCMHintShow(Msg) do\r\n Result := LRESULT(HintShow(HintInfo^));\r\n CM_HITTEST:\r\n with TCMHitTest(Msg) do\r\n Result := LRESULT(HitTest(XPos, YPos));\r\n CM_MOUSEENTER:\r\n MouseEnter(TControl(Msg.LParam));\r\n CM_MOUSELEAVE:\r\n MouseLeave(TControl(Msg.LParam));\r\n CM_VISIBLECHANGED:\r\n VisibleChanged;\r\n CM_ENABLEDCHANGED:\r\n EnabledChanged;\r\n CM_TEXTCHANGED:\r\n TextChanged;\r\n CM_FONTCHANGED:\r\n FontChanged;\r\n CM_COLORCHANGED:\r\n ColorChanged;\r\n CM_FOCUSCHANGED:\r\n FocusChanged(TWinControl(Msg.LParam));\r\n CM_PARENTFONTCHANGED:\r\n ParentFontChanged;\r\n CM_PARENTCOLORCHANGED:\r\n ParentColorChanged;\r\n CM_PARENTSHOWHINTCHANGED:\r\n ParentShowHintChanged;\r\n CM_CURSORCHANGED:\r\n CursorChanged;\r\n CM_SHOWINGCHANGED:\r\n ShowingChanged;\r\n CM_SHOWHINTCHANGED:\r\n ShowHintChanged;\r\n CM_CONTROLLISTCHANGE:\r\n if Msg.LParam <> 0 then\r\n ControlsListChanging(TControl(Msg.WParam), True)\r\n else\r\n ControlsListChanged(TControl(Msg.WParam), False);\r\n CM_CONTROLCHANGE:\r\n if Msg.LParam = 0 then\r\n ControlsListChanging(TControl(Msg.WParam), False)\r\n else\r\n ControlsListChanged(TControl(Msg.WParam), True);\r\n WM_SETFOCUS:\r\n FocusSet(THandle(Msg.WParam));\r\n WM_KILLFOCUS:\r\n FocusKilled(THandle(Msg.WParam));\r\n WM_SIZE, WM_MOVE:\r\n begin\r\n inherited WndProc(Msg);\r\n BoundsChanged;\r\n end;\r\n WM_ERASEBKGND:\r\n if (Msg.WParam <> 0) and not IsDefaultEraseBackground(DoEraseBackground, @TJvExPage.DoEraseBackground) then\r\n begin\r\n IdSaveDC := SaveDC(HDC(Msg.WParam)); // protect DC against Stock-Objects from Canvas\r\n Canvas := TCanvas.Create;\r\n try\r\n Canvas.Handle := HDC(Msg.WParam);\r\n Msg.Result := Ord(DoEraseBackground(Canvas, Msg.LParam));\r\n finally\r\n Canvas.Handle := 0;\r\n Canvas.Free;\r\n RestoreDC(HDC(Msg.WParam), IdSaveDC);\r\n end;\r\n end\r\n else\r\n inherited WndProc(Msg);\r\n {$IFNDEF DELPHI2007_UP}\r\n WM_PRINTCLIENT, WM_PRINT: // VCL bug fix\r\n begin\r\n IdSaveDC := SaveDC(HDC(Msg.WParam)); // protect DC against changes\r\n try\r\n inherited WndProc(Msg);\r\n finally\r\n RestoreDC(HDC(Msg.WParam), IdSaveDC);\r\n end;\r\n end;\r\n {$ENDIF ~DELPHI2007_UP}\r\n WM_GETDLGCODE:\r\n begin\r\n inherited WndProc(Msg);\r\n DlgCodes := [dcNative] + DlgcToDlgCodes(Msg.Result);\r\n GetDlgCode(DlgCodes);\r\n if not (dcNative in DlgCodes) then\r\n Msg.Result := DlgCodesToDlgc(DlgCodes);\r\n end;\r\n else\r\n inherited WndProc(Msg);\r\n end;\r\n case Msg.Msg of // precheck message to prevent access violations on released controls\r\n CM_MOUSEENTER, CM_MOUSELEAVE, WM_KILLFOCUS, WM_SETFOCUS, WM_NCPAINT:\r\n if DotNetHighlighting then\r\n HandleDotNetHighlighting(Self, Msg, MouseOver, Color);\r\n end;\r\n end;\r\nend;\r\n\r\n//============================================================================\r\n\r\nconstructor TJvExNotebook.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FHintColor := clDefault;\r\nend;\r\n\r\nfunction TJvExNotebook.BaseWndProc(Msg: Cardinal; WParam: WPARAM = 0; LParam: LPARAM = 0): LRESULT;\r\nvar\r\n Mesg: TMessage;\r\nbegin\r\n CreateWMMessage(Mesg, Msg, WParam, LParam);\r\n inherited WndProc(Mesg);\r\n Result := Mesg.Result;\r\nend;\r\n\r\nfunction TJvExNotebook.BaseWndProc(Msg: Cardinal; WParam: WPARAM; LParam: TObject): LRESULT;\r\nbegin\r\n Result := BaseWndProc(Msg, WParam, Windows.LPARAM(LParam));\r\nend;\r\n\r\nfunction TJvExNotebook.BaseWndProcEx(Msg: Cardinal; WParam: WPARAM; var StructLParam): LRESULT;\r\nbegin\r\n Result := BaseWndProc(Msg, WParam, Windows.LPARAM(@StructLParam));\r\nend;\r\n\r\nprocedure TJvExNotebook.VisibleChanged;\r\nbegin\r\n BaseWndProc(CM_VISIBLECHANGED);\r\nend;\r\n\r\nprocedure TJvExNotebook.EnabledChanged;\r\nbegin\r\n BaseWndProc(CM_ENABLEDCHANGED);\r\nend;\r\n\r\nprocedure TJvExNotebook.TextChanged;\r\nbegin\r\n BaseWndProc(CM_TEXTCHANGED);\r\nend;\r\n\r\nprocedure TJvExNotebook.FontChanged;\r\nbegin\r\n BaseWndProc(CM_FONTCHANGED);\r\nend;\r\n\r\nprocedure TJvExNotebook.ColorChanged;\r\nbegin\r\n BaseWndProc(CM_COLORCHANGED);\r\nend;\r\n\r\nprocedure TJvExNotebook.ParentFontChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTFONTCHANGED);\r\nend;\r\n\r\nprocedure TJvExNotebook.ParentColorChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTCOLORCHANGED);\r\n if Assigned(OnParentColorChange) then\r\n OnParentColorChange(Self);\r\nend;\r\n\r\nprocedure TJvExNotebook.ParentShowHintChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTSHOWHINTCHANGED);\r\nend;\r\n\r\nfunction TJvExNotebook.WantKey(Key: Integer; Shift: TShiftState): Boolean;\r\nbegin\r\n Result := BaseWndProc(CM_DIALOGCHAR, Word(Key), ShiftStateToKeyData(Shift)) <> 0;\r\nend;\r\n\r\nfunction TJvExNotebook.HitTest(X, Y: Integer): Boolean;\r\nbegin\r\n Result := BaseWndProc(CM_HITTEST, 0, SmallPointToLong(PointToSmallPoint(Point(X, Y)))) <> 0;\r\nend;\r\n\r\nfunction TJvExNotebook.HintShow(var HintInfo: THintInfo): Boolean;\r\nbegin\r\n GetHintColor(HintInfo, Self, FHintColor);\r\n if FHintWindowClass <> nil then\r\n HintInfo.HintWindowClass := FHintWindowClass;\r\n Result := BaseWndProcEx(CM_HINTSHOW, 0, HintInfo) <> 0;\r\nend;\r\n\r\nprocedure TJvExNotebook.MouseEnter(AControl: TControl);\r\nbegin\r\n FMouseOver := True;\r\n if Assigned(FOnMouseEnter) then\r\n FOnMouseEnter(Self);\r\n BaseWndProc(CM_MOUSEENTER, 0, AControl);\r\nend;\r\n\r\nprocedure TJvExNotebook.MouseLeave(AControl: TControl);\r\nbegin\r\n FMouseOver := False;\r\n BaseWndProc(CM_MOUSELEAVE, 0, AControl);\r\n if Assigned(FOnMouseLeave) then\r\n FOnMouseLeave(Self);\r\nend;\r\n\r\nprocedure TJvExNotebook.FocusChanged(AControl: TWinControl);\r\nbegin\r\n BaseWndProc(CM_FOCUSCHANGED, 0, AControl);\r\nend;\r\n\r\nprocedure TJvExNotebook.BoundsChanged;\r\nbegin\r\nend;\r\n\r\nprocedure TJvExNotebook.CursorChanged;\r\nbegin\r\n BaseWndProc(CM_CURSORCHANGED);\r\nend;\r\n\r\nprocedure TJvExNotebook.ShowingChanged;\r\nbegin\r\n BaseWndProc(CM_SHOWINGCHANGED);\r\nend;\r\n\r\nprocedure TJvExNotebook.ShowHintChanged;\r\nbegin\r\n BaseWndProc(CM_SHOWHINTCHANGED);\r\nend;\r\n\r\n{ VCL sends CM_CONTROLLISTCHANGE and CM_CONTROLCHANGE in a different order than\r\n the CLX methods are used. So we must correct it by evaluating \"Inserting\". }\r\nprocedure TJvExNotebook.ControlsListChanging(Control: TControl; Inserting: Boolean);\r\nbegin\r\n if Inserting then\r\n BaseWndProc(CM_CONTROLLISTCHANGE, WPARAM(Control), LPARAM(Inserting))\r\n else\r\n BaseWndProc(CM_CONTROLCHANGE, WPARAM(Control), LPARAM(Inserting));\r\nend;\r\n\r\nprocedure TJvExNotebook.ControlsListChanged(Control: TControl; Inserting: Boolean);\r\nbegin\r\n if not Inserting then\r\n BaseWndProc(CM_CONTROLLISTCHANGE, WPARAM(Control), LPARAM(Inserting))\r\n else\r\n BaseWndProc(CM_CONTROLCHANGE, WPARAM(Control), LPARAM(Inserting));\r\nend;\r\n\r\nprocedure TJvExNotebook.GetDlgCode(var Code: TDlgCodes);\r\nbegin\r\nend;\r\n\r\nprocedure TJvExNotebook.FocusSet(PrevWnd: THandle);\r\nbegin\r\n BaseWndProc(WM_SETFOCUS, WPARAM(PrevWnd), 0);\r\nend;\r\n\r\nprocedure TJvExNotebook.FocusKilled(NextWnd: THandle);\r\nbegin\r\n BaseWndProc(WM_KILLFOCUS, WPARAM(NextWnd), 0);\r\nend;\r\n\r\nfunction TJvExNotebook.DoEraseBackground(Canvas: TCanvas; Param: LPARAM): Boolean;\r\nbegin\r\n Result := BaseWndProc(WM_ERASEBKGND, Canvas.Handle, Param) <> 0;\r\nend;\r\n\r\n{$IFDEF JVCLThemesEnabledD6}\r\nfunction TJvExNotebook.GetParentBackground: Boolean;\r\nbegin\r\n Result := JvThemes.GetParentBackground(Self);\r\nend;\r\n\r\nprocedure TJvExNotebook.SetParentBackground(Value: Boolean);\r\nbegin\r\n JvThemes.SetParentBackground(Self, Value);\r\nend;\r\n{$ENDIF JVCLThemesEnabledD6}\r\n\r\nprocedure TJvExNotebook.WndProc(var Msg: TMessage);\r\nvar\r\n IdSaveDC: Integer;\r\n DlgCodes: TDlgCodes;\r\n Canvas: TCanvas;\r\nbegin\r\n if not DispatchIsDesignMsg(Self, Msg) then\r\n begin\r\n case Msg.Msg of\r\n CM_DENYSUBCLASSING:\r\n Msg.Result := LRESULT(Ord(GetInterfaceEntry(IJvDenySubClassing) <> nil));\r\n CM_DIALOGCHAR:\r\n with TCMDialogChar{$IFDEF CLR}.Create{$ENDIF}(Msg) do\r\n Result := LRESULT(Ord(WantKey(CharCode, KeyDataToShiftState(KeyData))));\r\n CM_HINTSHOW:\r\n with TCMHintShow(Msg) do\r\n Result := LRESULT(HintShow(HintInfo^));\r\n CM_HITTEST:\r\n with TCMHitTest(Msg) do\r\n Result := LRESULT(HitTest(XPos, YPos));\r\n CM_MOUSEENTER:\r\n MouseEnter(TControl(Msg.LParam));\r\n CM_MOUSELEAVE:\r\n MouseLeave(TControl(Msg.LParam));\r\n CM_VISIBLECHANGED:\r\n VisibleChanged;\r\n CM_ENABLEDCHANGED:\r\n EnabledChanged;\r\n CM_TEXTCHANGED:\r\n TextChanged;\r\n CM_FONTCHANGED:\r\n FontChanged;\r\n CM_COLORCHANGED:\r\n ColorChanged;\r\n CM_FOCUSCHANGED:\r\n FocusChanged(TWinControl(Msg.LParam));\r\n CM_PARENTFONTCHANGED:\r\n ParentFontChanged;\r\n CM_PARENTCOLORCHANGED:\r\n ParentColorChanged;\r\n CM_PARENTSHOWHINTCHANGED:\r\n ParentShowHintChanged;\r\n CM_CURSORCHANGED:\r\n CursorChanged;\r\n CM_SHOWINGCHANGED:\r\n ShowingChanged;\r\n CM_SHOWHINTCHANGED:\r\n ShowHintChanged;\r\n CM_CONTROLLISTCHANGE:\r\n if Msg.LParam <> 0 then\r\n ControlsListChanging(TControl(Msg.WParam), True)\r\n else\r\n ControlsListChanged(TControl(Msg.WParam), False);\r\n CM_CONTROLCHANGE:\r\n if Msg.LParam = 0 then\r\n ControlsListChanging(TControl(Msg.WParam), False)\r\n else\r\n ControlsListChanged(TControl(Msg.WParam), True);\r\n WM_SETFOCUS:\r\n FocusSet(THandle(Msg.WParam));\r\n WM_KILLFOCUS:\r\n FocusKilled(THandle(Msg.WParam));\r\n WM_SIZE, WM_MOVE:\r\n begin\r\n inherited WndProc(Msg);\r\n BoundsChanged;\r\n end;\r\n WM_ERASEBKGND:\r\n if (Msg.WParam <> 0) and not IsDefaultEraseBackground(DoEraseBackground, @TJvExNotebook.DoEraseBackground) then\r\n begin\r\n IdSaveDC := SaveDC(HDC(Msg.WParam)); // protect DC against Stock-Objects from Canvas\r\n Canvas := TCanvas.Create;\r\n try\r\n Canvas.Handle := HDC(Msg.WParam);\r\n Msg.Result := Ord(DoEraseBackground(Canvas, Msg.LParam));\r\n finally\r\n Canvas.Handle := 0;\r\n Canvas.Free;\r\n RestoreDC(HDC(Msg.WParam), IdSaveDC);\r\n end;\r\n end\r\n else\r\n inherited WndProc(Msg);\r\n {$IFNDEF DELPHI2007_UP}\r\n WM_PRINTCLIENT, WM_PRINT: // VCL bug fix\r\n begin\r\n IdSaveDC := SaveDC(HDC(Msg.WParam)); // protect DC against changes\r\n try\r\n inherited WndProc(Msg);\r\n finally\r\n RestoreDC(HDC(Msg.WParam), IdSaveDC);\r\n end;\r\n end;\r\n {$ENDIF ~DELPHI2007_UP}\r\n WM_GETDLGCODE:\r\n begin\r\n inherited WndProc(Msg);\r\n DlgCodes := [dcNative] + DlgcToDlgCodes(Msg.Result);\r\n GetDlgCode(DlgCodes);\r\n if not (dcNative in DlgCodes) then\r\n Msg.Result := DlgCodesToDlgc(DlgCodes);\r\n end;\r\n else\r\n inherited WndProc(Msg);\r\n end;\r\n case Msg.Msg of // precheck message to prevent access violations on released controls\r\n CM_MOUSEENTER, CM_MOUSELEAVE, WM_KILLFOCUS, WM_SETFOCUS, WM_NCPAINT:\r\n if DotNetHighlighting then\r\n HandleDotNetHighlighting(Self, Msg, MouseOver, Color);\r\n end;\r\n end;\r\nend;\r\n\r\n//============================================================================\r\n\r\nconstructor TJvExHeader.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FHintColor := clDefault;\r\nend;\r\n\r\nfunction TJvExHeader.BaseWndProc(Msg: Cardinal; WParam: WPARAM = 0; LParam: LPARAM = 0): LRESULT;\r\nvar\r\n Mesg: TMessage;\r\nbegin\r\n CreateWMMessage(Mesg, Msg, WParam, LParam);\r\n inherited WndProc(Mesg);\r\n Result := Mesg.Result;\r\nend;\r\n\r\nfunction TJvExHeader.BaseWndProc(Msg: Cardinal; WParam: WPARAM; LParam: TObject): LRESULT;\r\nbegin\r\n Result := BaseWndProc(Msg, WParam, Windows.LPARAM(LParam));\r\nend;\r\n\r\nfunction TJvExHeader.BaseWndProcEx(Msg: Cardinal; WParam: WPARAM; var StructLParam): LRESULT;\r\nbegin\r\n Result := BaseWndProc(Msg, WParam, Windows.LPARAM(@StructLParam));\r\nend;\r\n\r\nprocedure TJvExHeader.VisibleChanged;\r\nbegin\r\n BaseWndProc(CM_VISIBLECHANGED);\r\nend;\r\n\r\nprocedure TJvExHeader.EnabledChanged;\r\nbegin\r\n BaseWndProc(CM_ENABLEDCHANGED);\r\nend;\r\n\r\nprocedure TJvExHeader.TextChanged;\r\nbegin\r\n BaseWndProc(CM_TEXTCHANGED);\r\nend;\r\n\r\nprocedure TJvExHeader.FontChanged;\r\nbegin\r\n BaseWndProc(CM_FONTCHANGED);\r\nend;\r\n\r\nprocedure TJvExHeader.ColorChanged;\r\nbegin\r\n BaseWndProc(CM_COLORCHANGED);\r\nend;\r\n\r\nprocedure TJvExHeader.ParentFontChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTFONTCHANGED);\r\nend;\r\n\r\nprocedure TJvExHeader.ParentColorChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTCOLORCHANGED);\r\n if Assigned(OnParentColorChange) then\r\n OnParentColorChange(Self);\r\nend;\r\n\r\nprocedure TJvExHeader.ParentShowHintChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTSHOWHINTCHANGED);\r\nend;\r\n\r\nfunction TJvExHeader.WantKey(Key: Integer; Shift: TShiftState): Boolean;\r\nbegin\r\n Result := BaseWndProc(CM_DIALOGCHAR, Word(Key), ShiftStateToKeyData(Shift)) <> 0;\r\nend;\r\n\r\nfunction TJvExHeader.HitTest(X, Y: Integer): Boolean;\r\nbegin\r\n Result := BaseWndProc(CM_HITTEST, 0, SmallPointToLong(PointToSmallPoint(Point(X, Y)))) <> 0;\r\nend;\r\n\r\nfunction TJvExHeader.HintShow(var HintInfo: THintInfo): Boolean;\r\nbegin\r\n GetHintColor(HintInfo, Self, FHintColor);\r\n if FHintWindowClass <> nil then\r\n HintInfo.HintWindowClass := FHintWindowClass;\r\n Result := BaseWndProcEx(CM_HINTSHOW, 0, HintInfo) <> 0;\r\nend;\r\n\r\nprocedure TJvExHeader.MouseEnter(AControl: TControl);\r\nbegin\r\n FMouseOver := True;\r\n if Assigned(FOnMouseEnter) then\r\n FOnMouseEnter(Self);\r\n BaseWndProc(CM_MOUSEENTER, 0, AControl);\r\nend;\r\n\r\nprocedure TJvExHeader.MouseLeave(AControl: TControl);\r\nbegin\r\n FMouseOver := False;\r\n BaseWndProc(CM_MOUSELEAVE, 0, AControl);\r\n if Assigned(FOnMouseLeave) then\r\n FOnMouseLeave(Self);\r\nend;\r\n\r\nprocedure TJvExHeader.FocusChanged(AControl: TWinControl);\r\nbegin\r\n BaseWndProc(CM_FOCUSCHANGED, 0, AControl);\r\nend;\r\n\r\nprocedure TJvExHeader.BoundsChanged;\r\nbegin\r\nend;\r\n\r\nprocedure TJvExHeader.CursorChanged;\r\nbegin\r\n BaseWndProc(CM_CURSORCHANGED);\r\nend;\r\n\r\nprocedure TJvExHeader.ShowingChanged;\r\nbegin\r\n BaseWndProc(CM_SHOWINGCHANGED);\r\nend;\r\n\r\nprocedure TJvExHeader.ShowHintChanged;\r\nbegin\r\n BaseWndProc(CM_SHOWHINTCHANGED);\r\nend;\r\n\r\n{ VCL sends CM_CONTROLLISTCHANGE and CM_CONTROLCHANGE in a different order than\r\n the CLX methods are used. So we must correct it by evaluating \"Inserting\". }\r\nprocedure TJvExHeader.ControlsListChanging(Control: TControl; Inserting: Boolean);\r\nbegin\r\n if Inserting then\r\n BaseWndProc(CM_CONTROLLISTCHANGE, WPARAM(Control), LPARAM(Inserting))\r\n else\r\n BaseWndProc(CM_CONTROLCHANGE, WPARAM(Control), LPARAM(Inserting));\r\nend;\r\n\r\nprocedure TJvExHeader.ControlsListChanged(Control: TControl; Inserting: Boolean);\r\nbegin\r\n if not Inserting then\r\n BaseWndProc(CM_CONTROLLISTCHANGE, WPARAM(Control), LPARAM(Inserting))\r\n else\r\n BaseWndProc(CM_CONTROLCHANGE, WPARAM(Control), LPARAM(Inserting));\r\nend;\r\n\r\nprocedure TJvExHeader.GetDlgCode(var Code: TDlgCodes);\r\nbegin\r\nend;\r\n\r\nprocedure TJvExHeader.FocusSet(PrevWnd: THandle);\r\nbegin\r\n BaseWndProc(WM_SETFOCUS, WPARAM(PrevWnd), 0);\r\nend;\r\n\r\nprocedure TJvExHeader.FocusKilled(NextWnd: THandle);\r\nbegin\r\n BaseWndProc(WM_KILLFOCUS, WPARAM(NextWnd), 0);\r\nend;\r\n\r\nfunction TJvExHeader.DoEraseBackground(Canvas: TCanvas; Param: LPARAM): Boolean;\r\nbegin\r\n Result := BaseWndProc(WM_ERASEBKGND, Canvas.Handle, Param) <> 0;\r\nend;\r\n\r\n{$IFDEF JVCLThemesEnabledD6}\r\nfunction TJvExHeader.GetParentBackground: Boolean;\r\nbegin\r\n Result := JvThemes.GetParentBackground(Self);\r\nend;\r\n\r\nprocedure TJvExHeader.SetParentBackground(Value: Boolean);\r\nbegin\r\n JvThemes.SetParentBackground(Self, Value);\r\nend;\r\n{$ENDIF JVCLThemesEnabledD6}\r\n\r\nprocedure TJvExHeader.WndProc(var Msg: TMessage);\r\nvar\r\n IdSaveDC: Integer;\r\n DlgCodes: TDlgCodes;\r\n Canvas: TCanvas;\r\nbegin\r\n if not DispatchIsDesignMsg(Self, Msg) then\r\n begin\r\n case Msg.Msg of\r\n CM_DENYSUBCLASSING:\r\n Msg.Result := LRESULT(Ord(GetInterfaceEntry(IJvDenySubClassing) <> nil));\r\n CM_DIALOGCHAR:\r\n with TCMDialogChar{$IFDEF CLR}.Create{$ENDIF}(Msg) do\r\n Result := LRESULT(Ord(WantKey(CharCode, KeyDataToShiftState(KeyData))));\r\n CM_HINTSHOW:\r\n with TCMHintShow(Msg) do\r\n Result := LRESULT(HintShow(HintInfo^));\r\n CM_HITTEST:\r\n with TCMHitTest(Msg) do\r\n Result := LRESULT(HitTest(XPos, YPos));\r\n CM_MOUSEENTER:\r\n MouseEnter(TControl(Msg.LParam));\r\n CM_MOUSELEAVE:\r\n MouseLeave(TControl(Msg.LParam));\r\n CM_VISIBLECHANGED:\r\n VisibleChanged;\r\n CM_ENABLEDCHANGED:\r\n EnabledChanged;\r\n CM_TEXTCHANGED:\r\n TextChanged;\r\n CM_FONTCHANGED:\r\n FontChanged;\r\n CM_COLORCHANGED:\r\n ColorChanged;\r\n CM_FOCUSCHANGED:\r\n FocusChanged(TWinControl(Msg.LParam));\r\n CM_PARENTFONTCHANGED:\r\n ParentFontChanged;\r\n CM_PARENTCOLORCHANGED:\r\n ParentColorChanged;\r\n CM_PARENTSHOWHINTCHANGED:\r\n ParentShowHintChanged;\r\n CM_CURSORCHANGED:\r\n CursorChanged;\r\n CM_SHOWINGCHANGED:\r\n ShowingChanged;\r\n CM_SHOWHINTCHANGED:\r\n ShowHintChanged;\r\n CM_CONTROLLISTCHANGE:\r\n if Msg.LParam <> 0 then\r\n ControlsListChanging(TControl(Msg.WParam), True)\r\n else\r\n ControlsListChanged(TControl(Msg.WParam), False);\r\n CM_CONTROLCHANGE:\r\n if Msg.LParam = 0 then\r\n ControlsListChanging(TControl(Msg.WParam), False)\r\n else\r\n ControlsListChanged(TControl(Msg.WParam), True);\r\n WM_SETFOCUS:\r\n FocusSet(THandle(Msg.WParam));\r\n WM_KILLFOCUS:\r\n FocusKilled(THandle(Msg.WParam));\r\n WM_SIZE, WM_MOVE:\r\n begin\r\n inherited WndProc(Msg);\r\n BoundsChanged;\r\n end;\r\n WM_ERASEBKGND:\r\n if (Msg.WParam <> 0) and not IsDefaultEraseBackground(DoEraseBackground, @TJvExHeader.DoEraseBackground) then\r\n begin\r\n IdSaveDC := SaveDC(HDC(Msg.WParam)); // protect DC against Stock-Objects from Canvas\r\n Canvas := TCanvas.Create;\r\n try\r\n Canvas.Handle := HDC(Msg.WParam);\r\n Msg.Result := Ord(DoEraseBackground(Canvas, Msg.LParam));\r\n finally\r\n Canvas.Handle := 0;\r\n Canvas.Free;\r\n RestoreDC(HDC(Msg.WParam), IdSaveDC);\r\n end;\r\n end\r\n else\r\n inherited WndProc(Msg);\r\n {$IFNDEF DELPHI2007_UP}\r\n WM_PRINTCLIENT, WM_PRINT: // VCL bug fix\r\n begin\r\n IdSaveDC := SaveDC(HDC(Msg.WParam)); // protect DC against changes\r\n try\r\n inherited WndProc(Msg);\r\n finally\r\n RestoreDC(HDC(Msg.WParam), IdSaveDC);\r\n end;\r\n end;\r\n {$ENDIF ~DELPHI2007_UP}\r\n WM_GETDLGCODE:\r\n begin\r\n inherited WndProc(Msg);\r\n DlgCodes := [dcNative] + DlgcToDlgCodes(Msg.Result);\r\n GetDlgCode(DlgCodes);\r\n if not (dcNative in DlgCodes) then\r\n Msg.Result := DlgCodesToDlgc(DlgCodes);\r\n end;\r\n else\r\n inherited WndProc(Msg);\r\n end;\r\n case Msg.Msg of // precheck message to prevent access violations on released controls\r\n CM_MOUSEENTER, CM_MOUSELEAVE, WM_KILLFOCUS, WM_SETFOCUS, WM_NCPAINT:\r\n if DotNetHighlighting then\r\n HandleDotNetHighlighting(Self, Msg, MouseOver, Color);\r\n end;\r\n end;\r\nend;\r\n\r\n//============================================================================\r\n\r\nconstructor TJvExBoundLabel.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FHintColor := clDefault;\r\nend;\r\n\r\nfunction TJvExBoundLabel.BaseWndProc(Msg: Cardinal; WParam: WPARAM = 0; LParam: LPARAM = 0): LRESULT;\r\nvar\r\n Mesg: TMessage;\r\nbegin\r\n CreateWMMessage(Mesg, Msg, WParam, LParam);\r\n inherited WndProc(Mesg);\r\n Result := Mesg.Result;\r\nend;\r\n\r\nfunction TJvExBoundLabel.BaseWndProc(Msg: Cardinal; WParam: WPARAM; LParam: TObject): LRESULT;\r\nbegin\r\n Result := BaseWndProc(Msg, WParam, Windows.LPARAM(LParam));\r\nend;\r\n\r\nfunction TJvExBoundLabel.BaseWndProcEx(Msg: Cardinal; WParam: WPARAM; var StructLParam): LRESULT;\r\nbegin\r\n Result := BaseWndProc(Msg, WParam, Windows.LPARAM(@StructLParam));\r\nend;\r\n\r\nprocedure TJvExBoundLabel.VisibleChanged;\r\nbegin\r\n BaseWndProc(CM_VISIBLECHANGED);\r\nend;\r\n\r\nprocedure TJvExBoundLabel.EnabledChanged;\r\nbegin\r\n BaseWndProc(CM_ENABLEDCHANGED);\r\nend;\r\n\r\nprocedure TJvExBoundLabel.TextChanged;\r\nbegin\r\n BaseWndProc(CM_TEXTCHANGED);\r\nend;\r\n\r\nprocedure TJvExBoundLabel.FontChanged;\r\nbegin\r\n BaseWndProc(CM_FONTCHANGED);\r\nend;\r\n\r\nprocedure TJvExBoundLabel.ColorChanged;\r\nbegin\r\n BaseWndProc(CM_COLORCHANGED);\r\nend;\r\n\r\nprocedure TJvExBoundLabel.ParentFontChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTFONTCHANGED);\r\nend;\r\n\r\nprocedure TJvExBoundLabel.ParentColorChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTCOLORCHANGED);\r\n if Assigned(OnParentColorChange) then\r\n OnParentColorChange(Self);\r\nend;\r\n\r\nprocedure TJvExBoundLabel.ParentShowHintChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTSHOWHINTCHANGED);\r\nend;\r\n\r\nfunction TJvExBoundLabel.WantKey(Key: Integer; Shift: TShiftState): Boolean;\r\nbegin\r\n Result := BaseWndProc(CM_DIALOGCHAR, Word(Key), ShiftStateToKeyData(Shift)) <> 0;\r\nend;\r\n\r\nfunction TJvExBoundLabel.HitTest(X, Y: Integer): Boolean;\r\nbegin\r\n Result := BaseWndProc(CM_HITTEST, 0, SmallPointToLong(PointToSmallPoint(Point(X, Y)))) <> 0;\r\nend;\r\n\r\nfunction TJvExBoundLabel.HintShow(var HintInfo: THintInfo): Boolean;\r\nbegin\r\n GetHintColor(HintInfo, Self, FHintColor);\r\n if FHintWindowClass <> nil then\r\n HintInfo.HintWindowClass := FHintWindowClass;\r\n Result := BaseWndProcEx(CM_HINTSHOW, 0, HintInfo) <> 0;\r\nend;\r\n\r\nprocedure TJvExBoundLabel.MouseEnter(AControl: TControl);\r\nbegin\r\n FMouseOver := True;\r\n if Assigned(FOnMouseEnter) then\r\n FOnMouseEnter(Self);\r\n BaseWndProc(CM_MOUSEENTER, 0, AControl);\r\nend;\r\n\r\nprocedure TJvExBoundLabel.MouseLeave(AControl: TControl);\r\nbegin\r\n FMouseOver := False;\r\n BaseWndProc(CM_MOUSELEAVE, 0, AControl);\r\n if Assigned(FOnMouseLeave) then\r\n FOnMouseLeave(Self);\r\nend;\r\n\r\nprocedure TJvExBoundLabel.FocusChanged(AControl: TWinControl);\r\nbegin\r\n BaseWndProc(CM_FOCUSCHANGED, 0, AControl);\r\nend;\r\n\r\nprocedure TJvExBoundLabel.WndProc(var Msg: TMessage);\r\nbegin\r\n if not DispatchIsDesignMsg(Self, Msg) then\r\n case Msg.Msg of\r\n CM_DENYSUBCLASSING:\r\n Msg.Result := LRESULT(Ord(GetInterfaceEntry(IJvDenySubClassing) <> nil));\r\n CM_DIALOGCHAR:\r\n with TCMDialogChar{$IFDEF CLR}.Create{$ENDIF}(Msg) do\r\n Result := LRESULT(Ord(WantKey(CharCode, KeyDataToShiftState(KeyData))));\r\n CM_HINTSHOW:\r\n with TCMHintShow(Msg) do\r\n Result := LRESULT(HintShow(HintInfo^));\r\n CM_HITTEST:\r\n with TCMHitTest(Msg) do\r\n Result := LRESULT(HitTest(XPos, YPos));\r\n CM_MOUSEENTER:\r\n MouseEnter(TControl(Msg.LParam));\r\n CM_MOUSELEAVE:\r\n MouseLeave(TControl(Msg.LParam));\r\n CM_VISIBLECHANGED:\r\n VisibleChanged;\r\n CM_ENABLEDCHANGED:\r\n EnabledChanged;\r\n CM_TEXTCHANGED:\r\n TextChanged;\r\n CM_FONTCHANGED:\r\n FontChanged;\r\n CM_COLORCHANGED:\r\n ColorChanged;\r\n CM_FOCUSCHANGED:\r\n FocusChanged(TWinControl(Msg.LParam));\r\n CM_PARENTFONTCHANGED:\r\n ParentFontChanged;\r\n CM_PARENTCOLORCHANGED:\r\n ParentColorChanged;\r\n CM_PARENTSHOWHINTCHANGED:\r\n ParentShowHintChanged;\r\n else\r\n inherited WndProc(Msg);\r\n end;\r\nend;\r\n\r\n//============================================================================\r\n\r\nconstructor TJvExCustomLabeledEdit.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FHintColor := clDefault;\r\nend;\r\n\r\nfunction TJvExCustomLabeledEdit.BaseWndProc(Msg: Cardinal; WParam: WPARAM = 0; LParam: LPARAM = 0): LRESULT;\r\nvar\r\n Mesg: TMessage;\r\nbegin\r\n CreateWMMessage(Mesg, Msg, WParam, LParam);\r\n inherited WndProc(Mesg);\r\n Result := Mesg.Result;\r\nend;\r\n\r\nfunction TJvExCustomLabeledEdit.BaseWndProc(Msg: Cardinal; WParam: WPARAM; LParam: TObject): LRESULT;\r\nbegin\r\n Result := BaseWndProc(Msg, WParam, Windows.LPARAM(LParam));\r\nend;\r\n\r\nfunction TJvExCustomLabeledEdit.BaseWndProcEx(Msg: Cardinal; WParam: WPARAM; var StructLParam): LRESULT;\r\nbegin\r\n Result := BaseWndProc(Msg, WParam, Windows.LPARAM(@StructLParam));\r\nend;\r\n\r\nprocedure TJvExCustomLabeledEdit.VisibleChanged;\r\nbegin\r\n BaseWndProc(CM_VISIBLECHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomLabeledEdit.EnabledChanged;\r\nbegin\r\n BaseWndProc(CM_ENABLEDCHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomLabeledEdit.TextChanged;\r\nbegin\r\n BaseWndProc(CM_TEXTCHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomLabeledEdit.FontChanged;\r\nbegin\r\n BaseWndProc(CM_FONTCHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomLabeledEdit.ColorChanged;\r\nbegin\r\n BaseWndProc(CM_COLORCHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomLabeledEdit.ParentFontChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTFONTCHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomLabeledEdit.ParentColorChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTCOLORCHANGED);\r\n if Assigned(OnParentColorChange) then\r\n OnParentColorChange(Self);\r\nend;\r\n\r\nprocedure TJvExCustomLabeledEdit.ParentShowHintChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTSHOWHINTCHANGED);\r\nend;\r\n\r\nfunction TJvExCustomLabeledEdit.WantKey(Key: Integer; Shift: TShiftState): Boolean;\r\nbegin\r\n Result := BaseWndProc(CM_DIALOGCHAR, Word(Key), ShiftStateToKeyData(Shift)) <> 0;\r\nend;\r\n\r\nfunction TJvExCustomLabeledEdit.HitTest(X, Y: Integer): Boolean;\r\nbegin\r\n Result := BaseWndProc(CM_HITTEST, 0, SmallPointToLong(PointToSmallPoint(Point(X, Y)))) <> 0;\r\nend;\r\n\r\nfunction TJvExCustomLabeledEdit.HintShow(var HintInfo: THintInfo): Boolean;\r\nbegin\r\n GetHintColor(HintInfo, Self, FHintColor);\r\n if FHintWindowClass <> nil then\r\n HintInfo.HintWindowClass := FHintWindowClass;\r\n Result := BaseWndProcEx(CM_HINTSHOW, 0, HintInfo) <> 0;\r\nend;\r\n\r\nprocedure TJvExCustomLabeledEdit.MouseEnter(AControl: TControl);\r\nbegin\r\n FMouseOver := True;\r\n if Assigned(FOnMouseEnter) then\r\n FOnMouseEnter(Self);\r\n BaseWndProc(CM_MOUSEENTER, 0, AControl);\r\nend;\r\n\r\nprocedure TJvExCustomLabeledEdit.MouseLeave(AControl: TControl);\r\nbegin\r\n FMouseOver := False;\r\n BaseWndProc(CM_MOUSELEAVE, 0, AControl);\r\n if Assigned(FOnMouseLeave) then\r\n FOnMouseLeave(Self);\r\nend;\r\n\r\nprocedure TJvExCustomLabeledEdit.FocusChanged(AControl: TWinControl);\r\nbegin\r\n BaseWndProc(CM_FOCUSCHANGED, 0, AControl);\r\nend;\r\n\r\nprocedure TJvExCustomLabeledEdit.BoundsChanged;\r\nbegin\r\nend;\r\n\r\nprocedure TJvExCustomLabeledEdit.CursorChanged;\r\nbegin\r\n BaseWndProc(CM_CURSORCHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomLabeledEdit.ShowingChanged;\r\nbegin\r\n BaseWndProc(CM_SHOWINGCHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomLabeledEdit.ShowHintChanged;\r\nbegin\r\n BaseWndProc(CM_SHOWHINTCHANGED);\r\nend;\r\n\r\n{ VCL sends CM_CONTROLLISTCHANGE and CM_CONTROLCHANGE in a different order than\r\n the CLX methods are used. So we must correct it by evaluating \"Inserting\". }\r\nprocedure TJvExCustomLabeledEdit.ControlsListChanging(Control: TControl; Inserting: Boolean);\r\nbegin\r\n if Inserting then\r\n BaseWndProc(CM_CONTROLLISTCHANGE, WPARAM(Control), LPARAM(Inserting))\r\n else\r\n BaseWndProc(CM_CONTROLCHANGE, WPARAM(Control), LPARAM(Inserting));\r\nend;\r\n\r\nprocedure TJvExCustomLabeledEdit.ControlsListChanged(Control: TControl; Inserting: Boolean);\r\nbegin\r\n if not Inserting then\r\n BaseWndProc(CM_CONTROLLISTCHANGE, WPARAM(Control), LPARAM(Inserting))\r\n else\r\n BaseWndProc(CM_CONTROLCHANGE, WPARAM(Control), LPARAM(Inserting));\r\nend;\r\n\r\nprocedure TJvExCustomLabeledEdit.GetDlgCode(var Code: TDlgCodes);\r\nbegin\r\nend;\r\n\r\nprocedure TJvExCustomLabeledEdit.FocusSet(PrevWnd: THandle);\r\nbegin\r\n BaseWndProc(WM_SETFOCUS, WPARAM(PrevWnd), 0);\r\nend;\r\n\r\nprocedure TJvExCustomLabeledEdit.FocusKilled(NextWnd: THandle);\r\nbegin\r\n BaseWndProc(WM_KILLFOCUS, WPARAM(NextWnd), 0);\r\nend;\r\n\r\nfunction TJvExCustomLabeledEdit.DoEraseBackground(Canvas: TCanvas; Param: LPARAM): Boolean;\r\nbegin\r\n Result := BaseWndProc(WM_ERASEBKGND, Canvas.Handle, Param) <> 0;\r\nend;\r\n\r\n{$IFDEF JVCLThemesEnabledD6}\r\nfunction TJvExCustomLabeledEdit.GetParentBackground: Boolean;\r\nbegin\r\n Result := JvThemes.GetParentBackground(Self);\r\nend;\r\n\r\nprocedure TJvExCustomLabeledEdit.SetParentBackground(Value: Boolean);\r\nbegin\r\n JvThemes.SetParentBackground(Self, Value);\r\nend;\r\n{$ENDIF JVCLThemesEnabledD6}\r\n\r\nprocedure TJvExCustomLabeledEdit.WndProc(var Msg: TMessage);\r\nvar\r\n IdSaveDC: Integer;\r\n DlgCodes: TDlgCodes;\r\n Canvas: TCanvas;\r\nbegin\r\n if not DispatchIsDesignMsg(Self, Msg) then\r\n begin\r\n case Msg.Msg of\r\n CM_DENYSUBCLASSING:\r\n Msg.Result := LRESULT(Ord(GetInterfaceEntry(IJvDenySubClassing) <> nil));\r\n CM_DIALOGCHAR:\r\n with TCMDialogChar{$IFDEF CLR}.Create{$ENDIF}(Msg) do\r\n Result := LRESULT(Ord(WantKey(CharCode, KeyDataToShiftState(KeyData))));\r\n CM_HINTSHOW:\r\n with TCMHintShow(Msg) do\r\n Result := LRESULT(HintShow(HintInfo^));\r\n CM_HITTEST:\r\n with TCMHitTest(Msg) do\r\n Result := LRESULT(HitTest(XPos, YPos));\r\n CM_MOUSEENTER:\r\n MouseEnter(TControl(Msg.LParam));\r\n CM_MOUSELEAVE:\r\n MouseLeave(TControl(Msg.LParam));\r\n CM_VISIBLECHANGED:\r\n VisibleChanged;\r\n CM_ENABLEDCHANGED:\r\n EnabledChanged;\r\n CM_TEXTCHANGED:\r\n TextChanged;\r\n CM_FONTCHANGED:\r\n FontChanged;\r\n CM_COLORCHANGED:\r\n ColorChanged;\r\n CM_FOCUSCHANGED:\r\n FocusChanged(TWinControl(Msg.LParam));\r\n CM_PARENTFONTCHANGED:\r\n ParentFontChanged;\r\n CM_PARENTCOLORCHANGED:\r\n ParentColorChanged;\r\n CM_PARENTSHOWHINTCHANGED:\r\n ParentShowHintChanged;\r\n CM_CURSORCHANGED:\r\n CursorChanged;\r\n CM_SHOWINGCHANGED:\r\n ShowingChanged;\r\n CM_SHOWHINTCHANGED:\r\n ShowHintChanged;\r\n CM_CONTROLLISTCHANGE:\r\n if Msg.LParam <> 0 then\r\n ControlsListChanging(TControl(Msg.WParam), True)\r\n else\r\n ControlsListChanged(TControl(Msg.WParam), False);\r\n CM_CONTROLCHANGE:\r\n if Msg.LParam = 0 then\r\n ControlsListChanging(TControl(Msg.WParam), False)\r\n else\r\n ControlsListChanged(TControl(Msg.WParam), True);\r\n WM_SETFOCUS:\r\n FocusSet(THandle(Msg.WParam));\r\n WM_KILLFOCUS:\r\n FocusKilled(THandle(Msg.WParam));\r\n WM_SIZE, WM_MOVE:\r\n begin\r\n inherited WndProc(Msg);\r\n BoundsChanged;\r\n end;\r\n WM_ERASEBKGND:\r\n if (Msg.WParam <> 0) and not IsDefaultEraseBackground(DoEraseBackground, @TJvExCustomLabeledEdit.DoEraseBackground) then\r\n begin\r\n IdSaveDC := SaveDC(HDC(Msg.WParam)); // protect DC against Stock-Objects from Canvas\r\n Canvas := TCanvas.Create;\r\n try\r\n Canvas.Handle := HDC(Msg.WParam);\r\n Msg.Result := Ord(DoEraseBackground(Canvas, Msg.LParam));\r\n finally\r\n Canvas.Handle := 0;\r\n Canvas.Free;\r\n RestoreDC(HDC(Msg.WParam), IdSaveDC);\r\n end;\r\n end\r\n else\r\n inherited WndProc(Msg);\r\n {$IFNDEF DELPHI2007_UP}\r\n WM_PRINTCLIENT, WM_PRINT: // VCL bug fix\r\n begin\r\n IdSaveDC := SaveDC(HDC(Msg.WParam)); // protect DC against changes\r\n try\r\n inherited WndProc(Msg);\r\n finally\r\n RestoreDC(HDC(Msg.WParam), IdSaveDC);\r\n end;\r\n end;\r\n {$ENDIF ~DELPHI2007_UP}\r\n WM_GETDLGCODE:\r\n begin\r\n inherited WndProc(Msg);\r\n DlgCodes := [dcNative] + DlgcToDlgCodes(Msg.Result);\r\n GetDlgCode(DlgCodes);\r\n if not (dcNative in DlgCodes) then\r\n Msg.Result := DlgCodesToDlgc(DlgCodes);\r\n end;\r\n else\r\n inherited WndProc(Msg);\r\n end;\r\n case Msg.Msg of // precheck message to prevent access violations on released controls\r\n CM_MOUSEENTER, CM_MOUSELEAVE, WM_KILLFOCUS, WM_SETFOCUS, WM_NCPAINT:\r\n if DotNetHighlighting then\r\n HandleDotNetHighlighting(Self, Msg, MouseOver, Color);\r\n end;\r\n end;\r\nend;\r\n\r\n//============================================================================\r\n\r\nconstructor TJvExLabeledEdit.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FHintColor := clDefault;\r\nend;\r\n\r\nfunction TJvExLabeledEdit.BaseWndProc(Msg: Cardinal; WParam: WPARAM = 0; LParam: LPARAM = 0): LRESULT;\r\nvar\r\n Mesg: TMessage;\r\nbegin\r\n CreateWMMessage(Mesg, Msg, WParam, LParam);\r\n inherited WndProc(Mesg);\r\n Result := Mesg.Result;\r\nend;\r\n\r\nfunction TJvExLabeledEdit.BaseWndProc(Msg: Cardinal; WParam: WPARAM; LParam: TObject): LRESULT;\r\nbegin\r\n Result := BaseWndProc(Msg, WParam, Windows.LPARAM(LParam));\r\nend;\r\n\r\nfunction TJvExLabeledEdit.BaseWndProcEx(Msg: Cardinal; WParam: WPARAM; var StructLParam): LRESULT;\r\nbegin\r\n Result := BaseWndProc(Msg, WParam, Windows.LPARAM(@StructLParam));\r\nend;\r\n\r\nprocedure TJvExLabeledEdit.VisibleChanged;\r\nbegin\r\n BaseWndProc(CM_VISIBLECHANGED);\r\nend;\r\n\r\nprocedure TJvExLabeledEdit.EnabledChanged;\r\nbegin\r\n BaseWndProc(CM_ENABLEDCHANGED);\r\nend;\r\n\r\nprocedure TJvExLabeledEdit.TextChanged;\r\nbegin\r\n BaseWndProc(CM_TEXTCHANGED);\r\nend;\r\n\r\nprocedure TJvExLabeledEdit.FontChanged;\r\nbegin\r\n BaseWndProc(CM_FONTCHANGED);\r\nend;\r\n\r\nprocedure TJvExLabeledEdit.ColorChanged;\r\nbegin\r\n BaseWndProc(CM_COLORCHANGED);\r\nend;\r\n\r\nprocedure TJvExLabeledEdit.ParentFontChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTFONTCHANGED);\r\nend;\r\n\r\nprocedure TJvExLabeledEdit.ParentColorChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTCOLORCHANGED);\r\n if Assigned(OnParentColorChange) then\r\n OnParentColorChange(Self);\r\nend;\r\n\r\nprocedure TJvExLabeledEdit.ParentShowHintChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTSHOWHINTCHANGED);\r\nend;\r\n\r\nfunction TJvExLabeledEdit.WantKey(Key: Integer; Shift: TShiftState): Boolean;\r\nbegin\r\n Result := BaseWndProc(CM_DIALOGCHAR, Word(Key), ShiftStateToKeyData(Shift)) <> 0;\r\nend;\r\n\r\nfunction TJvExLabeledEdit.HitTest(X, Y: Integer): Boolean;\r\nbegin\r\n Result := BaseWndProc(CM_HITTEST, 0, SmallPointToLong(PointToSmallPoint(Point(X, Y)))) <> 0;\r\nend;\r\n\r\nfunction TJvExLabeledEdit.HintShow(var HintInfo: THintInfo): Boolean;\r\nbegin\r\n GetHintColor(HintInfo, Self, FHintColor);\r\n if FHintWindowClass <> nil then\r\n HintInfo.HintWindowClass := FHintWindowClass;\r\n Result := BaseWndProcEx(CM_HINTSHOW, 0, HintInfo) <> 0;\r\nend;\r\n\r\nprocedure TJvExLabeledEdit.MouseEnter(AControl: TControl);\r\nbegin\r\n FMouseOver := True;\r\n if Assigned(FOnMouseEnter) then\r\n FOnMouseEnter(Self);\r\n BaseWndProc(CM_MOUSEENTER, 0, AControl);\r\nend;\r\n\r\nprocedure TJvExLabeledEdit.MouseLeave(AControl: TControl);\r\nbegin\r\n FMouseOver := False;\r\n BaseWndProc(CM_MOUSELEAVE, 0, AControl);\r\n if Assigned(FOnMouseLeave) then\r\n FOnMouseLeave(Self);\r\nend;\r\n\r\nprocedure TJvExLabeledEdit.FocusChanged(AControl: TWinControl);\r\nbegin\r\n BaseWndProc(CM_FOCUSCHANGED, 0, AControl);\r\nend;\r\n\r\nprocedure TJvExLabeledEdit.BoundsChanged;\r\nbegin\r\nend;\r\n\r\nprocedure TJvExLabeledEdit.CursorChanged;\r\nbegin\r\n BaseWndProc(CM_CURSORCHANGED);\r\nend;\r\n\r\nprocedure TJvExLabeledEdit.ShowingChanged;\r\nbegin\r\n BaseWndProc(CM_SHOWINGCHANGED);\r\nend;\r\n\r\nprocedure TJvExLabeledEdit.ShowHintChanged;\r\nbegin\r\n BaseWndProc(CM_SHOWHINTCHANGED);\r\nend;\r\n\r\n{ VCL sends CM_CONTROLLISTCHANGE and CM_CONTROLCHANGE in a different order than\r\n the CLX methods are used. So we must correct it by evaluating \"Inserting\". }\r\nprocedure TJvExLabeledEdit.ControlsListChanging(Control: TControl; Inserting: Boolean);\r\nbegin\r\n if Inserting then\r\n BaseWndProc(CM_CONTROLLISTCHANGE, WPARAM(Control), LPARAM(Inserting))\r\n else\r\n BaseWndProc(CM_CONTROLCHANGE, WPARAM(Control), LPARAM(Inserting));\r\nend;\r\n\r\nprocedure TJvExLabeledEdit.ControlsListChanged(Control: TControl; Inserting: Boolean);\r\nbegin\r\n if not Inserting then\r\n BaseWndProc(CM_CONTROLLISTCHANGE, WPARAM(Control), LPARAM(Inserting))\r\n else\r\n BaseWndProc(CM_CONTROLCHANGE, WPARAM(Control), LPARAM(Inserting));\r\nend;\r\n\r\nprocedure TJvExLabeledEdit.GetDlgCode(var Code: TDlgCodes);\r\nbegin\r\nend;\r\n\r\nprocedure TJvExLabeledEdit.FocusSet(PrevWnd: THandle);\r\nbegin\r\n BaseWndProc(WM_SETFOCUS, WPARAM(PrevWnd), 0);\r\nend;\r\n\r\nprocedure TJvExLabeledEdit.FocusKilled(NextWnd: THandle);\r\nbegin\r\n BaseWndProc(WM_KILLFOCUS, WPARAM(NextWnd), 0);\r\nend;\r\n\r\nfunction TJvExLabeledEdit.DoEraseBackground(Canvas: TCanvas; Param: LPARAM): Boolean;\r\nbegin\r\n Result := BaseWndProc(WM_ERASEBKGND, Canvas.Handle, Param) <> 0;\r\nend;\r\n\r\n{$IFDEF JVCLThemesEnabledD6}\r\nfunction TJvExLabeledEdit.GetParentBackground: Boolean;\r\nbegin\r\n Result := JvThemes.GetParentBackground(Self);\r\nend;\r\n\r\nprocedure TJvExLabeledEdit.SetParentBackground(Value: Boolean);\r\nbegin\r\n JvThemes.SetParentBackground(Self, Value);\r\nend;\r\n{$ENDIF JVCLThemesEnabledD6}\r\n\r\nprocedure TJvExLabeledEdit.WndProc(var Msg: TMessage);\r\nvar\r\n IdSaveDC: Integer;\r\n DlgCodes: TDlgCodes;\r\n Canvas: TCanvas;\r\nbegin\r\n if not DispatchIsDesignMsg(Self, Msg) then\r\n begin\r\n case Msg.Msg of\r\n CM_DENYSUBCLASSING:\r\n Msg.Result := LRESULT(Ord(GetInterfaceEntry(IJvDenySubClassing) <> nil));\r\n CM_DIALOGCHAR:\r\n with TCMDialogChar{$IFDEF CLR}.Create{$ENDIF}(Msg) do\r\n Result := LRESULT(Ord(WantKey(CharCode, KeyDataToShiftState(KeyData))));\r\n CM_HINTSHOW:\r\n with TCMHintShow(Msg) do\r\n Result := LRESULT(HintShow(HintInfo^));\r\n CM_HITTEST:\r\n with TCMHitTest(Msg) do\r\n Result := LRESULT(HitTest(XPos, YPos));\r\n CM_MOUSEENTER:\r\n MouseEnter(TControl(Msg.LParam));\r\n CM_MOUSELEAVE:\r\n MouseLeave(TControl(Msg.LParam));\r\n CM_VISIBLECHANGED:\r\n VisibleChanged;\r\n CM_ENABLEDCHANGED:\r\n EnabledChanged;\r\n CM_TEXTCHANGED:\r\n TextChanged;\r\n CM_FONTCHANGED:\r\n FontChanged;\r\n CM_COLORCHANGED:\r\n ColorChanged;\r\n CM_FOCUSCHANGED:\r\n FocusChanged(TWinControl(Msg.LParam));\r\n CM_PARENTFONTCHANGED:\r\n ParentFontChanged;\r\n CM_PARENTCOLORCHANGED:\r\n ParentColorChanged;\r\n CM_PARENTSHOWHINTCHANGED:\r\n ParentShowHintChanged;\r\n CM_CURSORCHANGED:\r\n CursorChanged;\r\n CM_SHOWINGCHANGED:\r\n ShowingChanged;\r\n CM_SHOWHINTCHANGED:\r\n ShowHintChanged;\r\n CM_CONTROLLISTCHANGE:\r\n if Msg.LParam <> 0 then\r\n ControlsListChanging(TControl(Msg.WParam), True)\r\n else\r\n ControlsListChanged(TControl(Msg.WParam), False);\r\n CM_CONTROLCHANGE:\r\n if Msg.LParam = 0 then\r\n ControlsListChanging(TControl(Msg.WParam), False)\r\n else\r\n ControlsListChanged(TControl(Msg.WParam), True);\r\n WM_SETFOCUS:\r\n FocusSet(THandle(Msg.WParam));\r\n WM_KILLFOCUS:\r\n FocusKilled(THandle(Msg.WParam));\r\n WM_SIZE, WM_MOVE:\r\n begin\r\n inherited WndProc(Msg);\r\n BoundsChanged;\r\n end;\r\n WM_ERASEBKGND:\r\n if (Msg.WParam <> 0) and not IsDefaultEraseBackground(DoEraseBackground, @TJvExLabeledEdit.DoEraseBackground) then\r\n begin\r\n IdSaveDC := SaveDC(HDC(Msg.WParam)); // protect DC against Stock-Objects from Canvas\r\n Canvas := TCanvas.Create;\r\n try\r\n Canvas.Handle := HDC(Msg.WParam);\r\n Msg.Result := Ord(DoEraseBackground(Canvas, Msg.LParam));\r\n finally\r\n Canvas.Handle := 0;\r\n Canvas.Free;\r\n RestoreDC(HDC(Msg.WParam), IdSaveDC);\r\n end;\r\n end\r\n else\r\n inherited WndProc(Msg);\r\n {$IFNDEF DELPHI2007_UP}\r\n WM_PRINTCLIENT, WM_PRINT: // VCL bug fix\r\n begin\r\n IdSaveDC := SaveDC(HDC(Msg.WParam)); // protect DC against changes\r\n try\r\n inherited WndProc(Msg);\r\n finally\r\n RestoreDC(HDC(Msg.WParam), IdSaveDC);\r\n end;\r\n end;\r\n {$ENDIF ~DELPHI2007_UP}\r\n WM_GETDLGCODE:\r\n begin\r\n inherited WndProc(Msg);\r\n DlgCodes := [dcNative] + DlgcToDlgCodes(Msg.Result);\r\n GetDlgCode(DlgCodes);\r\n if not (dcNative in DlgCodes) then\r\n Msg.Result := DlgCodesToDlgc(DlgCodes);\r\n end;\r\n else\r\n inherited WndProc(Msg);\r\n end;\r\n case Msg.Msg of // precheck message to prevent access violations on released controls\r\n CM_MOUSEENTER, CM_MOUSELEAVE, WM_KILLFOCUS, WM_SETFOCUS, WM_NCPAINT:\r\n if DotNetHighlighting then\r\n HandleDotNetHighlighting(Self, Msg, MouseOver, Color);\r\n end;\r\n end;\r\nend;\r\n\r\n//============================================================================\r\n\r\nconstructor TJvExCustomColorBox.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FHintColor := clDefault;\r\nend;\r\n\r\nfunction TJvExCustomColorBox.BaseWndProc(Msg: Cardinal; WParam: WPARAM = 0; LParam: LPARAM = 0): LRESULT;\r\nvar\r\n Mesg: TMessage;\r\nbegin\r\n CreateWMMessage(Mesg, Msg, WParam, LParam);\r\n inherited WndProc(Mesg);\r\n Result := Mesg.Result;\r\nend;\r\n\r\nfunction TJvExCustomColorBox.BaseWndProc(Msg: Cardinal; WParam: WPARAM; LParam: TObject): LRESULT;\r\nbegin\r\n Result := BaseWndProc(Msg, WParam, Windows.LPARAM(LParam));\r\nend;\r\n\r\nfunction TJvExCustomColorBox.BaseWndProcEx(Msg: Cardinal; WParam: WPARAM; var StructLParam): LRESULT;\r\nbegin\r\n Result := BaseWndProc(Msg, WParam, Windows.LPARAM(@StructLParam));\r\nend;\r\n\r\nprocedure TJvExCustomColorBox.VisibleChanged;\r\nbegin\r\n BaseWndProc(CM_VISIBLECHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomColorBox.EnabledChanged;\r\nbegin\r\n BaseWndProc(CM_ENABLEDCHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomColorBox.TextChanged;\r\nbegin\r\n BaseWndProc(CM_TEXTCHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomColorBox.FontChanged;\r\nbegin\r\n BaseWndProc(CM_FONTCHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomColorBox.ColorChanged;\r\nbegin\r\n BaseWndProc(CM_COLORCHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomColorBox.ParentFontChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTFONTCHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomColorBox.ParentColorChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTCOLORCHANGED);\r\n if Assigned(OnParentColorChange) then\r\n OnParentColorChange(Self);\r\nend;\r\n\r\nprocedure TJvExCustomColorBox.ParentShowHintChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTSHOWHINTCHANGED);\r\nend;\r\n\r\nfunction TJvExCustomColorBox.WantKey(Key: Integer; Shift: TShiftState): Boolean;\r\nbegin\r\n Result := BaseWndProc(CM_DIALOGCHAR, Word(Key), ShiftStateToKeyData(Shift)) <> 0;\r\nend;\r\n\r\nfunction TJvExCustomColorBox.HitTest(X, Y: Integer): Boolean;\r\nbegin\r\n Result := BaseWndProc(CM_HITTEST, 0, SmallPointToLong(PointToSmallPoint(Point(X, Y)))) <> 0;\r\nend;\r\n\r\nfunction TJvExCustomColorBox.HintShow(var HintInfo: THintInfo): Boolean;\r\nbegin\r\n GetHintColor(HintInfo, Self, FHintColor);\r\n if FHintWindowClass <> nil then\r\n HintInfo.HintWindowClass := FHintWindowClass;\r\n Result := BaseWndProcEx(CM_HINTSHOW, 0, HintInfo) <> 0;\r\nend;\r\n\r\nprocedure TJvExCustomColorBox.MouseEnter(AControl: TControl);\r\nbegin\r\n FMouseOver := True;\r\n if Assigned(FOnMouseEnter) then\r\n FOnMouseEnter(Self);\r\n BaseWndProc(CM_MOUSEENTER, 0, AControl);\r\nend;\r\n\r\nprocedure TJvExCustomColorBox.MouseLeave(AControl: TControl);\r\nbegin\r\n FMouseOver := False;\r\n BaseWndProc(CM_MOUSELEAVE, 0, AControl);\r\n if Assigned(FOnMouseLeave) then\r\n FOnMouseLeave(Self);\r\nend;\r\n\r\nprocedure TJvExCustomColorBox.FocusChanged(AControl: TWinControl);\r\nbegin\r\n BaseWndProc(CM_FOCUSCHANGED, 0, AControl);\r\nend;\r\n\r\nprocedure TJvExCustomColorBox.BoundsChanged;\r\nbegin\r\nend;\r\n\r\nprocedure TJvExCustomColorBox.CursorChanged;\r\nbegin\r\n BaseWndProc(CM_CURSORCHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomColorBox.ShowingChanged;\r\nbegin\r\n BaseWndProc(CM_SHOWINGCHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomColorBox.ShowHintChanged;\r\nbegin\r\n BaseWndProc(CM_SHOWHINTCHANGED);\r\nend;\r\n\r\n{ VCL sends CM_CONTROLLISTCHANGE and CM_CONTROLCHANGE in a different order than\r\n the CLX methods are used. So we must correct it by evaluating \"Inserting\". }\r\nprocedure TJvExCustomColorBox.ControlsListChanging(Control: TControl; Inserting: Boolean);\r\nbegin\r\n if Inserting then\r\n BaseWndProc(CM_CONTROLLISTCHANGE, WPARAM(Control), LPARAM(Inserting))\r\n else\r\n BaseWndProc(CM_CONTROLCHANGE, WPARAM(Control), LPARAM(Inserting));\r\nend;\r\n\r\nprocedure TJvExCustomColorBox.ControlsListChanged(Control: TControl; Inserting: Boolean);\r\nbegin\r\n if not Inserting then\r\n BaseWndProc(CM_CONTROLLISTCHANGE, WPARAM(Control), LPARAM(Inserting))\r\n else\r\n BaseWndProc(CM_CONTROLCHANGE, WPARAM(Control), LPARAM(Inserting));\r\nend;\r\n\r\nprocedure TJvExCustomColorBox.GetDlgCode(var Code: TDlgCodes);\r\nbegin\r\nend;\r\n\r\nprocedure TJvExCustomColorBox.FocusSet(PrevWnd: THandle);\r\nbegin\r\n BaseWndProc(WM_SETFOCUS, WPARAM(PrevWnd), 0);\r\nend;\r\n\r\nprocedure TJvExCustomColorBox.FocusKilled(NextWnd: THandle);\r\nbegin\r\n BaseWndProc(WM_KILLFOCUS, WPARAM(NextWnd), 0);\r\nend;\r\n\r\nfunction TJvExCustomColorBox.DoEraseBackground(Canvas: TCanvas; Param: LPARAM): Boolean;\r\nbegin\r\n Result := BaseWndProc(WM_ERASEBKGND, Canvas.Handle, Param) <> 0;\r\nend;\r\n\r\n{$IFDEF JVCLThemesEnabledD6}\r\nfunction TJvExCustomColorBox.GetParentBackground: Boolean;\r\nbegin\r\n Result := JvThemes.GetParentBackground(Self);\r\nend;\r\n\r\nprocedure TJvExCustomColorBox.SetParentBackground(Value: Boolean);\r\nbegin\r\n JvThemes.SetParentBackground(Self, Value);\r\nend;\r\n{$ENDIF JVCLThemesEnabledD6}\r\n\r\nprocedure TJvExCustomColorBox.WndProc(var Msg: TMessage);\r\nvar\r\n IdSaveDC: Integer;\r\n DlgCodes: TDlgCodes;\r\n Canvas: TCanvas;\r\nbegin\r\n if not DispatchIsDesignMsg(Self, Msg) then\r\n begin\r\n case Msg.Msg of\r\n CM_DENYSUBCLASSING:\r\n Msg.Result := LRESULT(Ord(GetInterfaceEntry(IJvDenySubClassing) <> nil));\r\n CM_DIALOGCHAR:\r\n with TCMDialogChar{$IFDEF CLR}.Create{$ENDIF}(Msg) do\r\n Result := LRESULT(Ord(WantKey(CharCode, KeyDataToShiftState(KeyData))));\r\n CM_HINTSHOW:\r\n with TCMHintShow(Msg) do\r\n Result := LRESULT(HintShow(HintInfo^));\r\n CM_HITTEST:\r\n with TCMHitTest(Msg) do\r\n Result := LRESULT(HitTest(XPos, YPos));\r\n CM_MOUSEENTER:\r\n MouseEnter(TControl(Msg.LParam));\r\n CM_MOUSELEAVE:\r\n MouseLeave(TControl(Msg.LParam));\r\n CM_VISIBLECHANGED:\r\n VisibleChanged;\r\n CM_ENABLEDCHANGED:\r\n EnabledChanged;\r\n CM_TEXTCHANGED:\r\n TextChanged;\r\n CM_FONTCHANGED:\r\n FontChanged;\r\n CM_COLORCHANGED:\r\n ColorChanged;\r\n CM_FOCUSCHANGED:\r\n FocusChanged(TWinControl(Msg.LParam));\r\n CM_PARENTFONTCHANGED:\r\n ParentFontChanged;\r\n CM_PARENTCOLORCHANGED:\r\n ParentColorChanged;\r\n CM_PARENTSHOWHINTCHANGED:\r\n ParentShowHintChanged;\r\n CM_CURSORCHANGED:\r\n CursorChanged;\r\n CM_SHOWINGCHANGED:\r\n ShowingChanged;\r\n CM_SHOWHINTCHANGED:\r\n ShowHintChanged;\r\n CM_CONTROLLISTCHANGE:\r\n if Msg.LParam <> 0 then\r\n ControlsListChanging(TControl(Msg.WParam), True)\r\n else\r\n ControlsListChanged(TControl(Msg.WParam), False);\r\n CM_CONTROLCHANGE:\r\n if Msg.LParam = 0 then\r\n ControlsListChanging(TControl(Msg.WParam), False)\r\n else\r\n ControlsListChanged(TControl(Msg.WParam), True);\r\n WM_SETFOCUS:\r\n FocusSet(THandle(Msg.WParam));\r\n WM_KILLFOCUS:\r\n FocusKilled(THandle(Msg.WParam));\r\n WM_SIZE, WM_MOVE:\r\n begin\r\n inherited WndProc(Msg);\r\n BoundsChanged;\r\n end;\r\n WM_ERASEBKGND:\r\n if (Msg.WParam <> 0) and not IsDefaultEraseBackground(DoEraseBackground, @TJvExCustomColorBox.DoEraseBackground) then\r\n begin\r\n IdSaveDC := SaveDC(HDC(Msg.WParam)); // protect DC against Stock-Objects from Canvas\r\n Canvas := TCanvas.Create;\r\n try\r\n Canvas.Handle := HDC(Msg.WParam);\r\n Msg.Result := Ord(DoEraseBackground(Canvas, Msg.LParam));\r\n finally\r\n Canvas.Handle := 0;\r\n Canvas.Free;\r\n RestoreDC(HDC(Msg.WParam), IdSaveDC);\r\n end;\r\n end\r\n else\r\n inherited WndProc(Msg);\r\n {$IFNDEF DELPHI2007_UP}\r\n WM_PRINTCLIENT, WM_PRINT: // VCL bug fix\r\n begin\r\n IdSaveDC := SaveDC(HDC(Msg.WParam)); // protect DC against changes\r\n try\r\n inherited WndProc(Msg);\r\n finally\r\n RestoreDC(HDC(Msg.WParam), IdSaveDC);\r\n end;\r\n end;\r\n {$ENDIF ~DELPHI2007_UP}\r\n WM_GETDLGCODE:\r\n begin\r\n inherited WndProc(Msg);\r\n DlgCodes := [dcNative] + DlgcToDlgCodes(Msg.Result);\r\n GetDlgCode(DlgCodes);\r\n if not (dcNative in DlgCodes) then\r\n Msg.Result := DlgCodesToDlgc(DlgCodes);\r\n end;\r\n else\r\n inherited WndProc(Msg);\r\n end;\r\n case Msg.Msg of // precheck message to prevent access violations on released controls\r\n CM_MOUSEENTER, CM_MOUSELEAVE, WM_KILLFOCUS, WM_SETFOCUS, WM_NCPAINT:\r\n if DotNetHighlighting then\r\n HandleDotNetHighlighting(Self, Msg, MouseOver, Color);\r\n end;\r\n end;\r\nend;\r\n\r\n//============================================================================\r\n\r\nconstructor TJvExColorBox.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FHintColor := clDefault;\r\nend;\r\n\r\nfunction TJvExColorBox.BaseWndProc(Msg: Cardinal; WParam: WPARAM = 0; LParam: LPARAM = 0): LRESULT;\r\nvar\r\n Mesg: TMessage;\r\nbegin\r\n CreateWMMessage(Mesg, Msg, WParam, LParam);\r\n inherited WndProc(Mesg);\r\n Result := Mesg.Result;\r\nend;\r\n\r\nfunction TJvExColorBox.BaseWndProc(Msg: Cardinal; WParam: WPARAM; LParam: TObject): LRESULT;\r\nbegin\r\n Result := BaseWndProc(Msg, WParam, Windows.LPARAM(LParam));\r\nend;\r\n\r\nfunction TJvExColorBox.BaseWndProcEx(Msg: Cardinal; WParam: WPARAM; var StructLParam): LRESULT;\r\nbegin\r\n Result := BaseWndProc(Msg, WParam, Windows.LPARAM(@StructLParam));\r\nend;\r\n\r\nprocedure TJvExColorBox.VisibleChanged;\r\nbegin\r\n BaseWndProc(CM_VISIBLECHANGED);\r\nend;\r\n\r\nprocedure TJvExColorBox.EnabledChanged;\r\nbegin\r\n BaseWndProc(CM_ENABLEDCHANGED);\r\nend;\r\n\r\nprocedure TJvExColorBox.TextChanged;\r\nbegin\r\n BaseWndProc(CM_TEXTCHANGED);\r\nend;\r\n\r\nprocedure TJvExColorBox.FontChanged;\r\nbegin\r\n BaseWndProc(CM_FONTCHANGED);\r\nend;\r\n\r\nprocedure TJvExColorBox.ColorChanged;\r\nbegin\r\n BaseWndProc(CM_COLORCHANGED);\r\nend;\r\n\r\nprocedure TJvExColorBox.ParentFontChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTFONTCHANGED);\r\nend;\r\n\r\nprocedure TJvExColorBox.ParentColorChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTCOLORCHANGED);\r\n if Assigned(OnParentColorChange) then\r\n OnParentColorChange(Self);\r\nend;\r\n\r\nprocedure TJvExColorBox.ParentShowHintChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTSHOWHINTCHANGED);\r\nend;\r\n\r\nfunction TJvExColorBox.WantKey(Key: Integer; Shift: TShiftState): Boolean;\r\nbegin\r\n Result := BaseWndProc(CM_DIALOGCHAR, Word(Key), ShiftStateToKeyData(Shift)) <> 0;\r\nend;\r\n\r\nfunction TJvExColorBox.HitTest(X, Y: Integer): Boolean;\r\nbegin\r\n Result := BaseWndProc(CM_HITTEST, 0, SmallPointToLong(PointToSmallPoint(Point(X, Y)))) <> 0;\r\nend;\r\n\r\nfunction TJvExColorBox.HintShow(var HintInfo: THintInfo): Boolean;\r\nbegin\r\n GetHintColor(HintInfo, Self, FHintColor);\r\n if FHintWindowClass <> nil then\r\n HintInfo.HintWindowClass := FHintWindowClass;\r\n Result := BaseWndProcEx(CM_HINTSHOW, 0, HintInfo) <> 0;\r\nend;\r\n\r\nprocedure TJvExColorBox.MouseEnter(AControl: TControl);\r\nbegin\r\n FMouseOver := True;\r\n if Assigned(FOnMouseEnter) then\r\n FOnMouseEnter(Self);\r\n BaseWndProc(CM_MOUSEENTER, 0, AControl);\r\nend;\r\n\r\nprocedure TJvExColorBox.MouseLeave(AControl: TControl);\r\nbegin\r\n FMouseOver := False;\r\n BaseWndProc(CM_MOUSELEAVE, 0, AControl);\r\n if Assigned(FOnMouseLeave) then\r\n FOnMouseLeave(Self);\r\nend;\r\n\r\nprocedure TJvExColorBox.FocusChanged(AControl: TWinControl);\r\nbegin\r\n BaseWndProc(CM_FOCUSCHANGED, 0, AControl);\r\nend;\r\n\r\nprocedure TJvExColorBox.BoundsChanged;\r\nbegin\r\nend;\r\n\r\nprocedure TJvExColorBox.CursorChanged;\r\nbegin\r\n BaseWndProc(CM_CURSORCHANGED);\r\nend;\r\n\r\nprocedure TJvExColorBox.ShowingChanged;\r\nbegin\r\n BaseWndProc(CM_SHOWINGCHANGED);\r\nend;\r\n\r\nprocedure TJvExColorBox.ShowHintChanged;\r\nbegin\r\n BaseWndProc(CM_SHOWHINTCHANGED);\r\nend;\r\n\r\n{ VCL sends CM_CONTROLLISTCHANGE and CM_CONTROLCHANGE in a different order than\r\n the CLX methods are used. So we must correct it by evaluating \"Inserting\". }\r\nprocedure TJvExColorBox.ControlsListChanging(Control: TControl; Inserting: Boolean);\r\nbegin\r\n if Inserting then\r\n BaseWndProc(CM_CONTROLLISTCHANGE, WPARAM(Control), LPARAM(Inserting))\r\n else\r\n BaseWndProc(CM_CONTROLCHANGE, WPARAM(Control), LPARAM(Inserting));\r\nend;\r\n\r\nprocedure TJvExColorBox.ControlsListChanged(Control: TControl; Inserting: Boolean);\r\nbegin\r\n if not Inserting then\r\n BaseWndProc(CM_CONTROLLISTCHANGE, WPARAM(Control), LPARAM(Inserting))\r\n else\r\n BaseWndProc(CM_CONTROLCHANGE, WPARAM(Control), LPARAM(Inserting));\r\nend;\r\n\r\nprocedure TJvExColorBox.GetDlgCode(var Code: TDlgCodes);\r\nbegin\r\nend;\r\n\r\nprocedure TJvExColorBox.FocusSet(PrevWnd: THandle);\r\nbegin\r\n BaseWndProc(WM_SETFOCUS, WPARAM(PrevWnd), 0);\r\nend;\r\n\r\nprocedure TJvExColorBox.FocusKilled(NextWnd: THandle);\r\nbegin\r\n BaseWndProc(WM_KILLFOCUS, WPARAM(NextWnd), 0);\r\nend;\r\n\r\nfunction TJvExColorBox.DoEraseBackground(Canvas: TCanvas; Param: LPARAM): Boolean;\r\nbegin\r\n Result := BaseWndProc(WM_ERASEBKGND, Canvas.Handle, Param) <> 0;\r\nend;\r\n\r\n{$IFDEF JVCLThemesEnabledD6}\r\nfunction TJvExColorBox.GetParentBackground: Boolean;\r\nbegin\r\n Result := JvThemes.GetParentBackground(Self);\r\nend;\r\n\r\nprocedure TJvExColorBox.SetParentBackground(Value: Boolean);\r\nbegin\r\n JvThemes.SetParentBackground(Self, Value);\r\nend;\r\n{$ENDIF JVCLThemesEnabledD6}\r\n\r\nprocedure TJvExColorBox.WndProc(var Msg: TMessage);\r\nvar\r\n IdSaveDC: Integer;\r\n DlgCodes: TDlgCodes;\r\n Canvas: TCanvas;\r\nbegin\r\n if not DispatchIsDesignMsg(Self, Msg) then\r\n begin\r\n case Msg.Msg of\r\n CM_DENYSUBCLASSING:\r\n Msg.Result := LRESULT(Ord(GetInterfaceEntry(IJvDenySubClassing) <> nil));\r\n CM_DIALOGCHAR:\r\n with TCMDialogChar{$IFDEF CLR}.Create{$ENDIF}(Msg) do\r\n Result := LRESULT(Ord(WantKey(CharCode, KeyDataToShiftState(KeyData))));\r\n CM_HINTSHOW:\r\n with TCMHintShow(Msg) do\r\n Result := LRESULT(HintShow(HintInfo^));\r\n CM_HITTEST:\r\n with TCMHitTest(Msg) do\r\n Result := LRESULT(HitTest(XPos, YPos));\r\n CM_MOUSEENTER:\r\n MouseEnter(TControl(Msg.LParam));\r\n CM_MOUSELEAVE:\r\n MouseLeave(TControl(Msg.LParam));\r\n CM_VISIBLECHANGED:\r\n VisibleChanged;\r\n CM_ENABLEDCHANGED:\r\n EnabledChanged;\r\n CM_TEXTCHANGED:\r\n TextChanged;\r\n CM_FONTCHANGED:\r\n FontChanged;\r\n CM_COLORCHANGED:\r\n ColorChanged;\r\n CM_FOCUSCHANGED:\r\n FocusChanged(TWinControl(Msg.LParam));\r\n CM_PARENTFONTCHANGED:\r\n ParentFontChanged;\r\n CM_PARENTCOLORCHANGED:\r\n ParentColorChanged;\r\n CM_PARENTSHOWHINTCHANGED:\r\n ParentShowHintChanged;\r\n CM_CURSORCHANGED:\r\n CursorChanged;\r\n CM_SHOWINGCHANGED:\r\n ShowingChanged;\r\n CM_SHOWHINTCHANGED:\r\n ShowHintChanged;\r\n CM_CONTROLLISTCHANGE:\r\n if Msg.LParam <> 0 then\r\n ControlsListChanging(TControl(Msg.WParam), True)\r\n else\r\n ControlsListChanged(TControl(Msg.WParam), False);\r\n CM_CONTROLCHANGE:\r\n if Msg.LParam = 0 then\r\n ControlsListChanging(TControl(Msg.WParam), False)\r\n else\r\n ControlsListChanged(TControl(Msg.WParam), True);\r\n WM_SETFOCUS:\r\n FocusSet(THandle(Msg.WParam));\r\n WM_KILLFOCUS:\r\n FocusKilled(THandle(Msg.WParam));\r\n WM_SIZE, WM_MOVE:\r\n begin\r\n inherited WndProc(Msg);\r\n BoundsChanged;\r\n end;\r\n WM_ERASEBKGND:\r\n if (Msg.WParam <> 0) and not IsDefaultEraseBackground(DoEraseBackground, @TJvExColorBox.DoEraseBackground) then\r\n begin\r\n IdSaveDC := SaveDC(HDC(Msg.WParam)); // protect DC against Stock-Objects from Canvas\r\n Canvas := TCanvas.Create;\r\n try\r\n Canvas.Handle := HDC(Msg.WParam);\r\n Msg.Result := Ord(DoEraseBackground(Canvas, Msg.LParam));\r\n finally\r\n Canvas.Handle := 0;\r\n Canvas.Free;\r\n RestoreDC(HDC(Msg.WParam), IdSaveDC);\r\n end;\r\n end\r\n else\r\n inherited WndProc(Msg);\r\n {$IFNDEF DELPHI2007_UP}\r\n WM_PRINTCLIENT, WM_PRINT: // VCL bug fix\r\n begin\r\n IdSaveDC := SaveDC(HDC(Msg.WParam)); // protect DC against changes\r\n try\r\n inherited WndProc(Msg);\r\n finally\r\n RestoreDC(HDC(Msg.WParam), IdSaveDC);\r\n end;\r\n end;\r\n {$ENDIF ~DELPHI2007_UP}\r\n WM_GETDLGCODE:\r\n begin\r\n inherited WndProc(Msg);\r\n DlgCodes := [dcNative] + DlgcToDlgCodes(Msg.Result);\r\n GetDlgCode(DlgCodes);\r\n if not (dcNative in DlgCodes) then\r\n Msg.Result := DlgCodesToDlgc(DlgCodes);\r\n end;\r\n else\r\n inherited WndProc(Msg);\r\n end;\r\n case Msg.Msg of // precheck message to prevent access violations on released controls\r\n CM_MOUSEENTER, CM_MOUSELEAVE, WM_KILLFOCUS, WM_SETFOCUS, WM_NCPAINT:\r\n if DotNetHighlighting then\r\n HandleDotNetHighlighting(Self, Msg, MouseOver, Color);\r\n end;\r\n end;\r\nend;\r\n\r\n//============================================================================\r\n\r\nconstructor TJvExSplitter.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FHintColor := clDefault;\r\nend;\r\n\r\nfunction TJvExSplitter.BaseWndProc(Msg: Cardinal; WParam: WPARAM = 0; LParam: LPARAM = 0): LRESULT;\r\nvar\r\n Mesg: TMessage;\r\nbegin\r\n CreateWMMessage(Mesg, Msg, WParam, LParam);\r\n inherited WndProc(Mesg);\r\n Result := Mesg.Result;\r\nend;\r\n\r\nfunction TJvExSplitter.BaseWndProc(Msg: Cardinal; WParam: WPARAM; LParam: TObject): LRESULT;\r\nbegin\r\n Result := BaseWndProc(Msg, WParam, Windows.LPARAM(LParam));\r\nend;\r\n\r\nfunction TJvExSplitter.BaseWndProcEx(Msg: Cardinal; WParam: WPARAM; var StructLParam): LRESULT;\r\nbegin\r\n Result := BaseWndProc(Msg, WParam, Windows.LPARAM(@StructLParam));\r\nend;\r\n\r\nprocedure TJvExSplitter.VisibleChanged;\r\nbegin\r\n BaseWndProc(CM_VISIBLECHANGED);\r\nend;\r\n\r\nprocedure TJvExSplitter.EnabledChanged;\r\nbegin\r\n BaseWndProc(CM_ENABLEDCHANGED);\r\nend;\r\n\r\nprocedure TJvExSplitter.TextChanged;\r\nbegin\r\n BaseWndProc(CM_TEXTCHANGED);\r\nend;\r\n\r\nprocedure TJvExSplitter.FontChanged;\r\nbegin\r\n BaseWndProc(CM_FONTCHANGED);\r\nend;\r\n\r\nprocedure TJvExSplitter.ColorChanged;\r\nbegin\r\n BaseWndProc(CM_COLORCHANGED);\r\nend;\r\n\r\nprocedure TJvExSplitter.ParentFontChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTFONTCHANGED);\r\nend;\r\n\r\nprocedure TJvExSplitter.ParentColorChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTCOLORCHANGED);\r\n if Assigned(OnParentColorChange) then\r\n OnParentColorChange(Self);\r\nend;\r\n\r\nprocedure TJvExSplitter.ParentShowHintChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTSHOWHINTCHANGED);\r\nend;\r\n\r\nfunction TJvExSplitter.WantKey(Key: Integer; Shift: TShiftState): Boolean;\r\nbegin\r\n Result := BaseWndProc(CM_DIALOGCHAR, Word(Key), ShiftStateToKeyData(Shift)) <> 0;\r\nend;\r\n\r\nfunction TJvExSplitter.HitTest(X, Y: Integer): Boolean;\r\nbegin\r\n Result := BaseWndProc(CM_HITTEST, 0, SmallPointToLong(PointToSmallPoint(Point(X, Y)))) <> 0;\r\nend;\r\n\r\nfunction TJvExSplitter.HintShow(var HintInfo: THintInfo): Boolean;\r\nbegin\r\n GetHintColor(HintInfo, Self, FHintColor);\r\n if FHintWindowClass <> nil then\r\n HintInfo.HintWindowClass := FHintWindowClass;\r\n Result := BaseWndProcEx(CM_HINTSHOW, 0, HintInfo) <> 0;\r\nend;\r\n\r\nprocedure TJvExSplitter.MouseEnter(AControl: TControl);\r\nbegin\r\n FMouseOver := True;\r\n if Assigned(FOnMouseEnter) then\r\n FOnMouseEnter(Self);\r\n BaseWndProc(CM_MOUSEENTER, 0, AControl);\r\nend;\r\n\r\nprocedure TJvExSplitter.MouseLeave(AControl: TControl);\r\nbegin\r\n FMouseOver := False;\r\n BaseWndProc(CM_MOUSELEAVE, 0, AControl);\r\n if Assigned(FOnMouseLeave) then\r\n FOnMouseLeave(Self);\r\nend;\r\n\r\nprocedure TJvExSplitter.FocusChanged(AControl: TWinControl);\r\nbegin\r\n BaseWndProc(CM_FOCUSCHANGED, 0, AControl);\r\nend;\r\n\r\nprocedure TJvExSplitter.WndProc(var Msg: TMessage);\r\nbegin\r\n if not DispatchIsDesignMsg(Self, Msg) then\r\n case Msg.Msg of\r\n CM_DENYSUBCLASSING:\r\n Msg.Result := LRESULT(Ord(GetInterfaceEntry(IJvDenySubClassing) <> nil));\r\n CM_DIALOGCHAR:\r\n with TCMDialogChar{$IFDEF CLR}.Create{$ENDIF}(Msg) do\r\n Result := LRESULT(Ord(WantKey(CharCode, KeyDataToShiftState(KeyData))));\r\n CM_HINTSHOW:\r\n with TCMHintShow(Msg) do\r\n Result := LRESULT(HintShow(HintInfo^));\r\n CM_HITTEST:\r\n with TCMHitTest(Msg) do\r\n Result := LRESULT(HitTest(XPos, YPos));\r\n CM_MOUSEENTER:\r\n MouseEnter(TControl(Msg.LParam));\r\n CM_MOUSELEAVE:\r\n MouseLeave(TControl(Msg.LParam));\r\n CM_VISIBLECHANGED:\r\n VisibleChanged;\r\n CM_ENABLEDCHANGED:\r\n EnabledChanged;\r\n CM_TEXTCHANGED:\r\n TextChanged;\r\n CM_FONTCHANGED:\r\n FontChanged;\r\n CM_COLORCHANGED:\r\n ColorChanged;\r\n CM_FOCUSCHANGED:\r\n FocusChanged(TWinControl(Msg.LParam));\r\n CM_PARENTFONTCHANGED:\r\n ParentFontChanged;\r\n CM_PARENTCOLORCHANGED:\r\n ParentColorChanged;\r\n CM_PARENTSHOWHINTCHANGED:\r\n ParentShowHintChanged;\r\n else\r\n inherited WndProc(Msg);\r\n end;\r\nend;\r\n\r\n//============================================================================\r\n\r\nprocedure TJvExSplitter.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);\r\nbegin\r\n SplitterMouseDownFix(Self);\r\n inherited MouseDown(Button, Shift, X, Y);\r\nend;\r\n\r\n\r\n// SplitterMouseDownFix fixes a bug in the VCL that causes the splitter to no\r\n// more work with the control in the left/top of it when the control has a size\r\n// of 0. This is actually a TWinControl.AlignControl bug.\r\nprocedure SplitterMouseDownFix(Splitter: TSplitter);\r\nvar\r\n Control: TControl;\r\n Pt: TPoint;\r\n R: TRect;\r\n I, Size: Integer;\r\nbegin\r\n with Splitter do\r\n begin\r\n if Align in [alLeft, alTop] then\r\n begin\r\n Control := nil;\r\n Pt := Point(Left, Top);\r\n if Align = alLeft then\r\n Dec(Pt.X)\r\n else //if Align = alTop then\r\n Dec(Pt.Y);\r\n\r\n for I := 0 to Parent.ControlCount - 1 do\r\n begin\r\n Control := Parent.Controls[I];\r\n R := Control.BoundsRect;\r\n if Align = alLeft then\r\n Size := R.Right - R.Left\r\n else //if Align = alTop then\r\n Size := R.Bottom - R.Top;\r\n\r\n if Control.Visible and Control.Enabled and (Size = 0) then\r\n begin\r\n if Align = alLeft then\r\n Dec(R.Left)\r\n else // Align = alTop then\r\n Dec(R.Top);\r\n\r\n if PtInRect(R, Pt) then\r\n Break;\r\n end;\r\n Control := nil;\r\n end;\r\n\r\n if Control = nil then\r\n begin\r\n // Check for the control that is zero-sized but after the splitter.\r\n // TWinControl.AlignControls does not work properly with alLeft/alTop.\r\n if Align = alLeft then\r\n Pt := Point(Left + Width - 1, Top)\r\n else // if Align = alTop then\r\n Pt := Point(Left, Top + Height - 1);\r\n\r\n for I := 0 to Parent.ControlCount - 1 do\r\n begin\r\n Control := Parent.Controls[I];\r\n R := Control.BoundsRect;\r\n if Align = alLeft then\r\n Size := R.Right - R.Left\r\n else //if Align = alTop then\r\n Size := R.Bottom - R.Top;\r\n\r\n if Control.Visible and Control.Enabled and (Size = 0) then\r\n begin\r\n if Align = alLeft then\r\n Dec(R.Left)\r\n else // Align = alTop then\r\n Dec(R.Top);\r\n\r\n if PtInRect(R, Pt) then\r\n Break;\r\n end;\r\n Control := nil;\r\n end;\r\n\r\n if Control <> nil then\r\n begin\r\n // realign left/top control\r\n if Align = alLeft then\r\n Control.Left := -1\r\n else // if Align = alTop then\r\n Control.Top := -1;\r\n end;\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend." }, { "path": "External/Jedi/Jvcl/run/JvExForms.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvExForms.pas, released on 2004-01-04\r\n\r\nThe Initial Developer of the Original Code is Andreas Hausladen [Andreas dott Hausladen att gmx dott de]\r\nPortions created by Andreas Hausladen are Copyright (C) 2004 Andreas Hausladen.\r\nAll Rights Reserved.\r\n\r\nContributor(s): -\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvExForms.pas 13173 2011-11-19 12:43:58Z ahuser $\r\n\r\nunit JvExForms;\r\n\r\n{$I jvcl.inc}\r\n{MACROINCLUDE JvExControls.macros}\r\n\r\n{*****************************************************************************\r\n * WARNING: Do not edit this file.\r\n * This file is autogenerated from the source in devtools/JvExVCL/src.\r\n * If you do it despite this warning your changes will be discarded by the next\r\n * update of this file. Do your changes in the template files.\r\n ****************************************************************************}\r\n{$D-} // do not step into this unit\r\n\r\ninterface\r\n\r\nuses\r\n Windows, Messages, Graphics, Controls, Forms, ToolWin, Types,\r\n Classes, SysUtils,\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n JvTypes, JvThemes, JVCLVer, JvExControls;\r\n\r\ntype\r\n TJvExScrollingWinControl = class(TScrollingWinControl, IJvExControl)\r\n private\r\n FAboutJVCL: TJVCLAboutInfo;\r\n FHintColor: TColor;\r\n FMouseOver: Boolean;\r\n FHintWindowClass: THintWindowClass;\r\n FOnMouseEnter: TNotifyEvent;\r\n FOnMouseLeave: TNotifyEvent;\r\n FOnParentColorChanged: TNotifyEvent;\r\n function BaseWndProc(Msg: Cardinal; WParam: WPARAM = 0; LParam: LPARAM = 0): LRESULT; overload;\r\n function BaseWndProc(Msg: Cardinal; WParam: WPARAM; LParam: TObject): LRESULT; overload;\r\n function BaseWndProcEx(Msg: Cardinal; WParam: WPARAM; var StructLParam): LRESULT;\r\n protected\r\n procedure WndProc(var Msg: TMessage); override;\r\n procedure FocusChanged(AControl: TWinControl); dynamic;\r\n procedure VisibleChanged; reintroduce; dynamic;\r\n procedure EnabledChanged; reintroduce; dynamic;\r\n procedure TextChanged; reintroduce; virtual;\r\n procedure ColorChanged; reintroduce; dynamic;\r\n procedure FontChanged; reintroduce; dynamic;\r\n procedure ParentFontChanged; reintroduce; dynamic;\r\n procedure ParentColorChanged; reintroduce; dynamic;\r\n procedure ParentShowHintChanged; reintroduce; dynamic;\r\n function WantKey(Key: Integer; Shift: TShiftState): Boolean; virtual;\r\n function HintShow(var HintInfo: THintInfo): Boolean; reintroduce; dynamic;\r\n function HitTest(X, Y: Integer): Boolean; reintroduce; virtual;\r\n procedure MouseEnter(AControl: TControl); reintroduce; dynamic;\r\n procedure MouseLeave(AControl: TControl); reintroduce; dynamic;\r\n property MouseOver: Boolean read FMouseOver write FMouseOver;\r\n property HintColor: TColor read FHintColor write FHintColor default clDefault;\r\n property OnMouseEnter: TNotifyEvent read FOnMouseEnter write FOnMouseEnter;\r\n property OnMouseLeave: TNotifyEvent read FOnMouseLeave write FOnMouseLeave;\r\n property OnParentColorChange: TNotifyEvent read FOnParentColorChanged write FOnParentColorChanged;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n property HintWindowClass: THintWindowClass read FHintWindowClass write FHintWindowClass;\r\n published\r\n property AboutJVCL: TJVCLAboutInfo read FAboutJVCL write FAboutJVCL stored False;\r\n private\r\n FDotNetHighlighting: Boolean;\r\n protected\r\n procedure BoundsChanged; reintroduce; virtual;\r\n procedure CursorChanged; reintroduce; dynamic;\r\n procedure ShowingChanged; reintroduce; dynamic;\r\n procedure ShowHintChanged; reintroduce; dynamic;\r\n procedure ControlsListChanging(Control: TControl; Inserting: Boolean); reintroduce; dynamic;\r\n procedure ControlsListChanged(Control: TControl; Inserting: Boolean); reintroduce; dynamic;\r\n procedure GetDlgCode(var Code: TDlgCodes); virtual;\r\n procedure FocusSet(PrevWnd: THandle); virtual;\r\n procedure FocusKilled(NextWnd: THandle); virtual;\r\n function DoEraseBackground(Canvas: TCanvas; Param: LPARAM): Boolean; virtual;\r\n {$IFDEF JVCLThemesEnabledD6}\r\n private\r\n function GetParentBackground: Boolean;\r\n protected\r\n procedure SetParentBackground(Value: Boolean); virtual;\r\n property ParentBackground: Boolean read GetParentBackground write SetParentBackground;\r\n {$ENDIF JVCLThemesEnabledD6}\r\n published\r\n property DotNetHighlighting: Boolean read FDotNetHighlighting write FDotNetHighlighting default False;\r\n end;\r\n\r\n TJvExScrollBox = class(TScrollBox, IJvExControl)\r\n private\r\n FAboutJVCL: TJVCLAboutInfo;\r\n FHintColor: TColor;\r\n FMouseOver: Boolean;\r\n FHintWindowClass: THintWindowClass;\r\n FOnMouseEnter: TNotifyEvent;\r\n FOnMouseLeave: TNotifyEvent;\r\n FOnParentColorChanged: TNotifyEvent;\r\n function BaseWndProc(Msg: Cardinal; WParam: WPARAM = 0; LParam: LPARAM = 0): LRESULT; overload;\r\n function BaseWndProc(Msg: Cardinal; WParam: WPARAM; LParam: TObject): LRESULT; overload;\r\n function BaseWndProcEx(Msg: Cardinal; WParam: WPARAM; var StructLParam): LRESULT;\r\n protected\r\n procedure WndProc(var Msg: TMessage); override;\r\n procedure FocusChanged(AControl: TWinControl); dynamic;\r\n procedure VisibleChanged; reintroduce; dynamic;\r\n procedure EnabledChanged; reintroduce; dynamic;\r\n procedure TextChanged; reintroduce; virtual;\r\n procedure ColorChanged; reintroduce; dynamic;\r\n procedure FontChanged; reintroduce; dynamic;\r\n procedure ParentFontChanged; reintroduce; dynamic;\r\n procedure ParentColorChanged; reintroduce; dynamic;\r\n procedure ParentShowHintChanged; reintroduce; dynamic;\r\n function WantKey(Key: Integer; Shift: TShiftState): Boolean; virtual;\r\n function HintShow(var HintInfo: THintInfo): Boolean; reintroduce; dynamic;\r\n function HitTest(X, Y: Integer): Boolean; reintroduce; virtual;\r\n procedure MouseEnter(AControl: TControl); reintroduce; dynamic;\r\n procedure MouseLeave(AControl: TControl); reintroduce; dynamic;\r\n property MouseOver: Boolean read FMouseOver write FMouseOver;\r\n property HintColor: TColor read FHintColor write FHintColor default clDefault;\r\n property OnMouseEnter: TNotifyEvent read FOnMouseEnter write FOnMouseEnter;\r\n property OnMouseLeave: TNotifyEvent read FOnMouseLeave write FOnMouseLeave;\r\n property OnParentColorChange: TNotifyEvent read FOnParentColorChanged write FOnParentColorChanged;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n property HintWindowClass: THintWindowClass read FHintWindowClass write FHintWindowClass;\r\n published\r\n property AboutJVCL: TJVCLAboutInfo read FAboutJVCL write FAboutJVCL stored False;\r\n private\r\n FDotNetHighlighting: Boolean;\r\n protected\r\n procedure BoundsChanged; reintroduce; virtual;\r\n procedure CursorChanged; reintroduce; dynamic;\r\n procedure ShowingChanged; reintroduce; dynamic;\r\n procedure ShowHintChanged; reintroduce; dynamic;\r\n procedure ControlsListChanging(Control: TControl; Inserting: Boolean); reintroduce; dynamic;\r\n procedure ControlsListChanged(Control: TControl; Inserting: Boolean); reintroduce; dynamic;\r\n procedure GetDlgCode(var Code: TDlgCodes); virtual;\r\n procedure FocusSet(PrevWnd: THandle); virtual;\r\n procedure FocusKilled(NextWnd: THandle); virtual;\r\n function DoEraseBackground(Canvas: TCanvas; Param: LPARAM): Boolean; virtual;\r\n {$IFDEF JVCLThemesEnabledD6}\r\n private\r\n function GetParentBackground: Boolean;\r\n protected\r\n procedure SetParentBackground(Value: Boolean); virtual;\r\n property ParentBackground: Boolean read GetParentBackground write SetParentBackground;\r\n {$ENDIF JVCLThemesEnabledD6}\r\n published\r\n property DotNetHighlighting: Boolean read FDotNetHighlighting write FDotNetHighlighting default False;\r\n end;\r\n\r\n TJvExCustomFrame = class(TCustomFrame, IJvExControl)\r\n private\r\n FAboutJVCL: TJVCLAboutInfo;\r\n FHintColor: TColor;\r\n FMouseOver: Boolean;\r\n FHintWindowClass: THintWindowClass;\r\n FOnMouseEnter: TNotifyEvent;\r\n FOnMouseLeave: TNotifyEvent;\r\n FOnParentColorChanged: TNotifyEvent;\r\n function BaseWndProc(Msg: Cardinal; WParam: WPARAM = 0; LParam: LPARAM = 0): LRESULT; overload;\r\n function BaseWndProc(Msg: Cardinal; WParam: WPARAM; LParam: TObject): LRESULT; overload;\r\n function BaseWndProcEx(Msg: Cardinal; WParam: WPARAM; var StructLParam): LRESULT;\r\n protected\r\n procedure WndProc(var Msg: TMessage); override;\r\n procedure FocusChanged(AControl: TWinControl); dynamic;\r\n procedure VisibleChanged; reintroduce; dynamic;\r\n procedure EnabledChanged; reintroduce; dynamic;\r\n procedure TextChanged; reintroduce; virtual;\r\n procedure ColorChanged; reintroduce; dynamic;\r\n procedure FontChanged; reintroduce; dynamic;\r\n procedure ParentFontChanged; reintroduce; dynamic;\r\n procedure ParentColorChanged; reintroduce; dynamic;\r\n procedure ParentShowHintChanged; reintroduce; dynamic;\r\n function WantKey(Key: Integer; Shift: TShiftState): Boolean; virtual;\r\n function HintShow(var HintInfo: THintInfo): Boolean; reintroduce; dynamic;\r\n function HitTest(X, Y: Integer): Boolean; reintroduce; virtual;\r\n procedure MouseEnter(AControl: TControl); reintroduce; dynamic;\r\n procedure MouseLeave(AControl: TControl); reintroduce; dynamic;\r\n property MouseOver: Boolean read FMouseOver write FMouseOver;\r\n property HintColor: TColor read FHintColor write FHintColor default clDefault;\r\n property OnMouseEnter: TNotifyEvent read FOnMouseEnter write FOnMouseEnter;\r\n property OnMouseLeave: TNotifyEvent read FOnMouseLeave write FOnMouseLeave;\r\n property OnParentColorChange: TNotifyEvent read FOnParentColorChanged write FOnParentColorChanged;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n property HintWindowClass: THintWindowClass read FHintWindowClass write FHintWindowClass;\r\n published\r\n property AboutJVCL: TJVCLAboutInfo read FAboutJVCL write FAboutJVCL stored False;\r\n private\r\n FDotNetHighlighting: Boolean;\r\n protected\r\n procedure BoundsChanged; reintroduce; virtual;\r\n procedure CursorChanged; reintroduce; dynamic;\r\n procedure ShowingChanged; reintroduce; dynamic;\r\n procedure ShowHintChanged; reintroduce; dynamic;\r\n procedure ControlsListChanging(Control: TControl; Inserting: Boolean); reintroduce; dynamic;\r\n procedure ControlsListChanged(Control: TControl; Inserting: Boolean); reintroduce; dynamic;\r\n procedure GetDlgCode(var Code: TDlgCodes); virtual;\r\n procedure FocusSet(PrevWnd: THandle); virtual;\r\n procedure FocusKilled(NextWnd: THandle); virtual;\r\n function DoEraseBackground(Canvas: TCanvas; Param: LPARAM): Boolean; virtual;\r\n {$IFDEF JVCLThemesEnabledD6}\r\n private\r\n function GetParentBackground: Boolean;\r\n protected\r\n procedure SetParentBackground(Value: Boolean); virtual;\r\n property ParentBackground: Boolean read GetParentBackground write SetParentBackground;\r\n {$ENDIF JVCLThemesEnabledD6}\r\n published\r\n property DotNetHighlighting: Boolean read FDotNetHighlighting write FDotNetHighlighting default False;\r\n end;\r\n\r\n TJvExFrame = class(TFrame, IJvExControl)\r\n private\r\n FAboutJVCL: TJVCLAboutInfo;\r\n FHintColor: TColor;\r\n FMouseOver: Boolean;\r\n FHintWindowClass: THintWindowClass;\r\n FOnMouseEnter: TNotifyEvent;\r\n FOnMouseLeave: TNotifyEvent;\r\n FOnParentColorChanged: TNotifyEvent;\r\n function BaseWndProc(Msg: Cardinal; WParam: WPARAM = 0; LParam: LPARAM = 0): LRESULT; overload;\r\n function BaseWndProc(Msg: Cardinal; WParam: WPARAM; LParam: TObject): LRESULT; overload;\r\n function BaseWndProcEx(Msg: Cardinal; WParam: WPARAM; var StructLParam): LRESULT;\r\n protected\r\n procedure WndProc(var Msg: TMessage); override;\r\n procedure FocusChanged(AControl: TWinControl); dynamic;\r\n procedure VisibleChanged; reintroduce; dynamic;\r\n procedure EnabledChanged; reintroduce; dynamic;\r\n procedure TextChanged; reintroduce; virtual;\r\n procedure ColorChanged; reintroduce; dynamic;\r\n procedure FontChanged; reintroduce; dynamic;\r\n procedure ParentFontChanged; reintroduce; dynamic;\r\n procedure ParentColorChanged; reintroduce; dynamic;\r\n procedure ParentShowHintChanged; reintroduce; dynamic;\r\n function WantKey(Key: Integer; Shift: TShiftState): Boolean; virtual;\r\n function HintShow(var HintInfo: THintInfo): Boolean; reintroduce; dynamic;\r\n function HitTest(X, Y: Integer): Boolean; reintroduce; virtual;\r\n procedure MouseEnter(AControl: TControl); reintroduce; dynamic;\r\n procedure MouseLeave(AControl: TControl); reintroduce; dynamic;\r\n property MouseOver: Boolean read FMouseOver write FMouseOver;\r\n property HintColor: TColor read FHintColor write FHintColor default clDefault;\r\n property OnMouseEnter: TNotifyEvent read FOnMouseEnter write FOnMouseEnter;\r\n property OnMouseLeave: TNotifyEvent read FOnMouseLeave write FOnMouseLeave;\r\n property OnParentColorChange: TNotifyEvent read FOnParentColorChanged write FOnParentColorChanged;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n property HintWindowClass: THintWindowClass read FHintWindowClass write FHintWindowClass;\r\n published\r\n property AboutJVCL: TJVCLAboutInfo read FAboutJVCL write FAboutJVCL stored False;\r\n private\r\n FDotNetHighlighting: Boolean;\r\n protected\r\n procedure BoundsChanged; reintroduce; virtual;\r\n procedure CursorChanged; reintroduce; dynamic;\r\n procedure ShowingChanged; reintroduce; dynamic;\r\n procedure ShowHintChanged; reintroduce; dynamic;\r\n procedure ControlsListChanging(Control: TControl; Inserting: Boolean); reintroduce; dynamic;\r\n procedure ControlsListChanged(Control: TControl; Inserting: Boolean); reintroduce; dynamic;\r\n procedure GetDlgCode(var Code: TDlgCodes); virtual;\r\n procedure FocusSet(PrevWnd: THandle); virtual;\r\n procedure FocusKilled(NextWnd: THandle); virtual;\r\n function DoEraseBackground(Canvas: TCanvas; Param: LPARAM): Boolean; virtual;\r\n {$IFDEF JVCLThemesEnabledD6}\r\n private\r\n function GetParentBackground: Boolean;\r\n protected\r\n procedure SetParentBackground(Value: Boolean); virtual;\r\n property ParentBackground: Boolean read GetParentBackground write SetParentBackground;\r\n {$ENDIF JVCLThemesEnabledD6}\r\n published\r\n property DotNetHighlighting: Boolean read FDotNetHighlighting write FDotNetHighlighting default False;\r\n end;\r\n\r\n TJvExToolWindow = class(TToolWindow, IJvExControl)\r\n private\r\n FAboutJVCL: TJVCLAboutInfo;\r\n FHintColor: TColor;\r\n FMouseOver: Boolean;\r\n FHintWindowClass: THintWindowClass;\r\n FOnMouseEnter: TNotifyEvent;\r\n FOnMouseLeave: TNotifyEvent;\r\n FOnParentColorChanged: TNotifyEvent;\r\n function BaseWndProc(Msg: Cardinal; WParam: WPARAM = 0; LParam: LPARAM = 0): LRESULT; overload;\r\n function BaseWndProc(Msg: Cardinal; WParam: WPARAM; LParam: TObject): LRESULT; overload;\r\n function BaseWndProcEx(Msg: Cardinal; WParam: WPARAM; var StructLParam): LRESULT;\r\n protected\r\n procedure WndProc(var Msg: TMessage); override;\r\n procedure FocusChanged(AControl: TWinControl); dynamic;\r\n procedure VisibleChanged; reintroduce; dynamic;\r\n procedure EnabledChanged; reintroduce; dynamic;\r\n procedure TextChanged; reintroduce; virtual;\r\n procedure ColorChanged; reintroduce; dynamic;\r\n procedure FontChanged; reintroduce; dynamic;\r\n procedure ParentFontChanged; reintroduce; dynamic;\r\n procedure ParentColorChanged; reintroduce; dynamic;\r\n procedure ParentShowHintChanged; reintroduce; dynamic;\r\n function WantKey(Key: Integer; Shift: TShiftState): Boolean; virtual;\r\n function HintShow(var HintInfo: THintInfo): Boolean; reintroduce; dynamic;\r\n function HitTest(X, Y: Integer): Boolean; reintroduce; virtual;\r\n procedure MouseEnter(AControl: TControl); reintroduce; dynamic;\r\n procedure MouseLeave(AControl: TControl); reintroduce; dynamic;\r\n property MouseOver: Boolean read FMouseOver write FMouseOver;\r\n property HintColor: TColor read FHintColor write FHintColor default clDefault;\r\n property OnMouseEnter: TNotifyEvent read FOnMouseEnter write FOnMouseEnter;\r\n property OnMouseLeave: TNotifyEvent read FOnMouseLeave write FOnMouseLeave;\r\n property OnParentColorChange: TNotifyEvent read FOnParentColorChanged write FOnParentColorChanged;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n property HintWindowClass: THintWindowClass read FHintWindowClass write FHintWindowClass;\r\n published\r\n property AboutJVCL: TJVCLAboutInfo read FAboutJVCL write FAboutJVCL stored False;\r\n private\r\n FDotNetHighlighting: Boolean;\r\n protected\r\n procedure BoundsChanged; reintroduce; virtual;\r\n procedure CursorChanged; reintroduce; dynamic;\r\n procedure ShowingChanged; reintroduce; dynamic;\r\n procedure ShowHintChanged; reintroduce; dynamic;\r\n procedure ControlsListChanging(Control: TControl; Inserting: Boolean); reintroduce; dynamic;\r\n procedure ControlsListChanged(Control: TControl; Inserting: Boolean); reintroduce; dynamic;\r\n procedure GetDlgCode(var Code: TDlgCodes); virtual;\r\n procedure FocusSet(PrevWnd: THandle); virtual;\r\n procedure FocusKilled(NextWnd: THandle); virtual;\r\n function DoEraseBackground(Canvas: TCanvas; Param: LPARAM): Boolean; virtual;\r\n {$IFDEF JVCLThemesEnabledD6}\r\n private\r\n function GetParentBackground: Boolean;\r\n protected\r\n procedure SetParentBackground(Value: Boolean); virtual;\r\n property ParentBackground: Boolean read GetParentBackground write SetParentBackground;\r\n {$ENDIF JVCLThemesEnabledD6}\r\n published\r\n property DotNetHighlighting: Boolean read FDotNetHighlighting write FDotNetHighlighting default False;\r\n end;\r\n\r\n TJvExCustomForm = class(TCustomForm, IJvExControl)\r\n private\r\n FAboutJVCL: TJVCLAboutInfo;\r\n FHintColor: TColor;\r\n FMouseOver: Boolean;\r\n FHintWindowClass: THintWindowClass;\r\n FOnMouseEnter: TNotifyEvent;\r\n FOnMouseLeave: TNotifyEvent;\r\n FOnParentColorChanged: TNotifyEvent;\r\n function BaseWndProc(Msg: Cardinal; WParam: WPARAM = 0; LParam: LPARAM = 0): LRESULT; overload;\r\n function BaseWndProc(Msg: Cardinal; WParam: WPARAM; LParam: TObject): LRESULT; overload;\r\n function BaseWndProcEx(Msg: Cardinal; WParam: WPARAM; var StructLParam): LRESULT;\r\n protected\r\n procedure WndProc(var Msg: TMessage); override;\r\n procedure FocusChanged(AControl: TWinControl); dynamic;\r\n procedure VisibleChanged; reintroduce; dynamic;\r\n procedure EnabledChanged; reintroduce; dynamic;\r\n procedure TextChanged; reintroduce; virtual;\r\n procedure ColorChanged; reintroduce; dynamic;\r\n procedure FontChanged; reintroduce; dynamic;\r\n procedure ParentFontChanged; reintroduce; dynamic;\r\n procedure ParentColorChanged; reintroduce; dynamic;\r\n procedure ParentShowHintChanged; reintroduce; dynamic;\r\n function WantKey(Key: Integer; Shift: TShiftState): Boolean; virtual;\r\n function HintShow(var HintInfo: THintInfo): Boolean; reintroduce; dynamic;\r\n function HitTest(X, Y: Integer): Boolean; reintroduce; virtual;\r\n procedure MouseEnter(AControl: TControl); reintroduce; dynamic;\r\n procedure MouseLeave(AControl: TControl); reintroduce; dynamic;\r\n property MouseOver: Boolean read FMouseOver write FMouseOver;\r\n property HintColor: TColor read FHintColor write FHintColor default clDefault;\r\n property OnMouseEnter: TNotifyEvent read FOnMouseEnter write FOnMouseEnter;\r\n property OnMouseLeave: TNotifyEvent read FOnMouseLeave write FOnMouseLeave;\r\n property OnParentColorChange: TNotifyEvent read FOnParentColorChanged write FOnParentColorChanged;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n property HintWindowClass: THintWindowClass read FHintWindowClass write FHintWindowClass;\r\n published\r\n property AboutJVCL: TJVCLAboutInfo read FAboutJVCL write FAboutJVCL stored False;\r\n private\r\n FDotNetHighlighting: Boolean;\r\n protected\r\n procedure BoundsChanged; reintroduce; virtual;\r\n procedure CursorChanged; reintroduce; dynamic;\r\n procedure ShowingChanged; reintroduce; dynamic;\r\n procedure ShowHintChanged; reintroduce; dynamic;\r\n procedure ControlsListChanging(Control: TControl; Inserting: Boolean); reintroduce; dynamic;\r\n procedure ControlsListChanged(Control: TControl; Inserting: Boolean); reintroduce; dynamic;\r\n procedure GetDlgCode(var Code: TDlgCodes); virtual;\r\n procedure FocusSet(PrevWnd: THandle); virtual;\r\n procedure FocusKilled(NextWnd: THandle); virtual;\r\n function DoEraseBackground(Canvas: TCanvas; Param: LPARAM): Boolean; virtual;\r\n {$IFDEF JVCLThemesEnabledD6}\r\n private\r\n function GetParentBackground: Boolean;\r\n protected\r\n procedure SetParentBackground(Value: Boolean); virtual;\r\n property ParentBackground: Boolean read GetParentBackground write SetParentBackground;\r\n {$ENDIF JVCLThemesEnabledD6}\r\n published\r\n property DotNetHighlighting: Boolean read FDotNetHighlighting write FDotNetHighlighting default False;\r\n protected\r\n procedure CMShowingChanged(var Msg: TMessage); message CM_SHOWINGCHANGED;\r\n procedure CMDialogKey(var Msg: TCMDialogKey); message CM_DIALOGKEY;\r\n procedure InitializeNewForm; {$IFDEF COMPILER12_UP}override;{$ELSE}dynamic;{$ENDIF}\r\n {$IFNDEF COMPILER12_UP}\r\n public\r\n constructor CreateNew(AOwner: TComponent; Dummy: Integer = 0); override;\r\n {$ENDIF ~COMPILER12_UP}\r\n end;\r\n\r\n TJvExForm = class(TForm, IJvExControl)\r\n private\r\n FAboutJVCL: TJVCLAboutInfo;\r\n FHintColor: TColor;\r\n FMouseOver: Boolean;\r\n FHintWindowClass: THintWindowClass;\r\n FOnMouseEnter: TNotifyEvent;\r\n FOnMouseLeave: TNotifyEvent;\r\n FOnParentColorChanged: TNotifyEvent;\r\n function BaseWndProc(Msg: Cardinal; WParam: WPARAM = 0; LParam: LPARAM = 0): LRESULT; overload;\r\n function BaseWndProc(Msg: Cardinal; WParam: WPARAM; LParam: TObject): LRESULT; overload;\r\n function BaseWndProcEx(Msg: Cardinal; WParam: WPARAM; var StructLParam): LRESULT;\r\n protected\r\n procedure WndProc(var Msg: TMessage); override;\r\n procedure FocusChanged(AControl: TWinControl); dynamic;\r\n procedure VisibleChanged; reintroduce; dynamic;\r\n procedure EnabledChanged; reintroduce; dynamic;\r\n procedure TextChanged; reintroduce; virtual;\r\n procedure ColorChanged; reintroduce; dynamic;\r\n procedure FontChanged; reintroduce; dynamic;\r\n procedure ParentFontChanged; reintroduce; dynamic;\r\n procedure ParentColorChanged; reintroduce; dynamic;\r\n procedure ParentShowHintChanged; reintroduce; dynamic;\r\n function WantKey(Key: Integer; Shift: TShiftState): Boolean; virtual;\r\n function HintShow(var HintInfo: THintInfo): Boolean; reintroduce; dynamic;\r\n function HitTest(X, Y: Integer): Boolean; reintroduce; virtual;\r\n procedure MouseEnter(AControl: TControl); reintroduce; dynamic;\r\n procedure MouseLeave(AControl: TControl); reintroduce; dynamic;\r\n property MouseOver: Boolean read FMouseOver write FMouseOver;\r\n property HintColor: TColor read FHintColor write FHintColor default clDefault;\r\n property OnMouseEnter: TNotifyEvent read FOnMouseEnter write FOnMouseEnter;\r\n property OnMouseLeave: TNotifyEvent read FOnMouseLeave write FOnMouseLeave;\r\n property OnParentColorChange: TNotifyEvent read FOnParentColorChanged write FOnParentColorChanged;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n property HintWindowClass: THintWindowClass read FHintWindowClass write FHintWindowClass;\r\n published\r\n property AboutJVCL: TJVCLAboutInfo read FAboutJVCL write FAboutJVCL stored False;\r\n private\r\n FDotNetHighlighting: Boolean;\r\n protected\r\n procedure BoundsChanged; reintroduce; virtual;\r\n procedure CursorChanged; reintroduce; dynamic;\r\n procedure ShowingChanged; reintroduce; dynamic;\r\n procedure ShowHintChanged; reintroduce; dynamic;\r\n procedure ControlsListChanging(Control: TControl; Inserting: Boolean); reintroduce; dynamic;\r\n procedure ControlsListChanged(Control: TControl; Inserting: Boolean); reintroduce; dynamic;\r\n procedure GetDlgCode(var Code: TDlgCodes); virtual;\r\n procedure FocusSet(PrevWnd: THandle); virtual;\r\n procedure FocusKilled(NextWnd: THandle); virtual;\r\n function DoEraseBackground(Canvas: TCanvas; Param: LPARAM): Boolean; virtual;\r\n {$IFDEF JVCLThemesEnabledD6}\r\n private\r\n function GetParentBackground: Boolean;\r\n protected\r\n procedure SetParentBackground(Value: Boolean); virtual;\r\n property ParentBackground: Boolean read GetParentBackground write SetParentBackground;\r\n {$ENDIF JVCLThemesEnabledD6}\r\n published\r\n property DotNetHighlighting: Boolean read FDotNetHighlighting write FDotNetHighlighting default False;\r\n protected\r\n procedure CMShowingChanged(var Msg: TMessage); message CM_SHOWINGCHANGED;\r\n procedure CMDialogKey(var Msg: TCMDialogKey); message CM_DIALOGKEY;\r\n procedure InitializeNewForm; {$IFDEF COMPILER12_UP}override;{$ELSE}dynamic;{$ENDIF}\r\n {$IFNDEF COMPILER12_UP}\r\n public\r\n constructor CreateNew(AOwner: TComponent; Dummy: Integer = 0); override;\r\n {$ENDIF ~COMPILER12_UP}\r\n end;\r\n\r\n TJvExCustomDockForm = class(TCustomDockForm, IJvExControl)\r\n private\r\n FAboutJVCL: TJVCLAboutInfo;\r\n FHintColor: TColor;\r\n FMouseOver: Boolean;\r\n FHintWindowClass: THintWindowClass;\r\n FOnMouseEnter: TNotifyEvent;\r\n FOnMouseLeave: TNotifyEvent;\r\n FOnParentColorChanged: TNotifyEvent;\r\n function BaseWndProc(Msg: Cardinal; WParam: WPARAM = 0; LParam: LPARAM = 0): LRESULT; overload;\r\n function BaseWndProc(Msg: Cardinal; WParam: WPARAM; LParam: TObject): LRESULT; overload;\r\n function BaseWndProcEx(Msg: Cardinal; WParam: WPARAM; var StructLParam): LRESULT;\r\n protected\r\n procedure WndProc(var Msg: TMessage); override;\r\n procedure FocusChanged(AControl: TWinControl); dynamic;\r\n procedure VisibleChanged; reintroduce; dynamic;\r\n procedure EnabledChanged; reintroduce; dynamic;\r\n procedure TextChanged; reintroduce; virtual;\r\n procedure ColorChanged; reintroduce; dynamic;\r\n procedure FontChanged; reintroduce; dynamic;\r\n procedure ParentFontChanged; reintroduce; dynamic;\r\n procedure ParentColorChanged; reintroduce; dynamic;\r\n procedure ParentShowHintChanged; reintroduce; dynamic;\r\n function WantKey(Key: Integer; Shift: TShiftState): Boolean; virtual;\r\n function HintShow(var HintInfo: THintInfo): Boolean; reintroduce; dynamic;\r\n function HitTest(X, Y: Integer): Boolean; reintroduce; virtual;\r\n procedure MouseEnter(AControl: TControl); reintroduce; dynamic;\r\n procedure MouseLeave(AControl: TControl); reintroduce; dynamic;\r\n property MouseOver: Boolean read FMouseOver write FMouseOver;\r\n property HintColor: TColor read FHintColor write FHintColor default clDefault;\r\n property OnMouseEnter: TNotifyEvent read FOnMouseEnter write FOnMouseEnter;\r\n property OnMouseLeave: TNotifyEvent read FOnMouseLeave write FOnMouseLeave;\r\n property OnParentColorChange: TNotifyEvent read FOnParentColorChanged write FOnParentColorChanged;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n property HintWindowClass: THintWindowClass read FHintWindowClass write FHintWindowClass;\r\n published\r\n property AboutJVCL: TJVCLAboutInfo read FAboutJVCL write FAboutJVCL stored False;\r\n private\r\n FDotNetHighlighting: Boolean;\r\n protected\r\n procedure BoundsChanged; reintroduce; virtual;\r\n procedure CursorChanged; reintroduce; dynamic;\r\n procedure ShowingChanged; reintroduce; dynamic;\r\n procedure ShowHintChanged; reintroduce; dynamic;\r\n procedure ControlsListChanging(Control: TControl; Inserting: Boolean); reintroduce; dynamic;\r\n procedure ControlsListChanged(Control: TControl; Inserting: Boolean); reintroduce; dynamic;\r\n procedure GetDlgCode(var Code: TDlgCodes); virtual;\r\n procedure FocusSet(PrevWnd: THandle); virtual;\r\n procedure FocusKilled(NextWnd: THandle); virtual;\r\n function DoEraseBackground(Canvas: TCanvas; Param: LPARAM): Boolean; virtual;\r\n {$IFDEF JVCLThemesEnabledD6}\r\n private\r\n function GetParentBackground: Boolean;\r\n protected\r\n procedure SetParentBackground(Value: Boolean); virtual;\r\n property ParentBackground: Boolean read GetParentBackground write SetParentBackground;\r\n {$ENDIF JVCLThemesEnabledD6}\r\n published\r\n property DotNetHighlighting: Boolean read FDotNetHighlighting write FDotNetHighlighting default False;\r\n protected\r\n procedure CMShowingChanged(var Msg: TMessage); message CM_SHOWINGCHANGED;\r\n procedure CMDialogKey(var Msg: TCMDialogKey); message CM_DIALOGKEY;\r\n procedure InitializeNewForm; {$IFDEF COMPILER12_UP}override;{$ELSE}dynamic;{$ENDIF}\r\n {$IFNDEF COMPILER12_UP}\r\n public\r\n constructor CreateNew(AOwner: TComponent; Dummy: Integer = 0); override;\r\n {$ENDIF ~COMPILER12_UP}\r\n end;\r\n\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvExForms.pas $';\r\n Revision: '$Revision: 13173 $';\r\n Date: '$Date: 2011-11-19 13:43:58 +0100 (sam. 19 nov. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nconst\r\n UISF_HIDEFOCUS = 1;\r\n UISF_HIDEACCEL = 2;\r\n UIS_SET = 1;\r\n UIS_CLEAR = 2;\r\n UIS_INITIALIZE = 3;\r\n\r\nconstructor TJvExScrollingWinControl.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FHintColor := clDefault;\r\nend;\r\n\r\nfunction TJvExScrollingWinControl.BaseWndProc(Msg: Cardinal; WParam: WPARAM = 0; LParam: LPARAM = 0): LRESULT;\r\nvar\r\n Mesg: TMessage;\r\nbegin\r\n CreateWMMessage(Mesg, Msg, WParam, LParam);\r\n inherited WndProc(Mesg);\r\n Result := Mesg.Result;\r\nend;\r\n\r\nfunction TJvExScrollingWinControl.BaseWndProc(Msg: Cardinal; WParam: WPARAM; LParam: TObject): LRESULT;\r\nbegin\r\n Result := BaseWndProc(Msg, WParam, Windows.LPARAM(LParam));\r\nend;\r\n\r\nfunction TJvExScrollingWinControl.BaseWndProcEx(Msg: Cardinal; WParam: WPARAM; var StructLParam): LRESULT;\r\nbegin\r\n Result := BaseWndProc(Msg, WParam, Windows.LPARAM(@StructLParam));\r\nend;\r\n\r\nprocedure TJvExScrollingWinControl.VisibleChanged;\r\nbegin\r\n BaseWndProc(CM_VISIBLECHANGED);\r\nend;\r\n\r\nprocedure TJvExScrollingWinControl.EnabledChanged;\r\nbegin\r\n BaseWndProc(CM_ENABLEDCHANGED);\r\nend;\r\n\r\nprocedure TJvExScrollingWinControl.TextChanged;\r\nbegin\r\n BaseWndProc(CM_TEXTCHANGED);\r\nend;\r\n\r\nprocedure TJvExScrollingWinControl.FontChanged;\r\nbegin\r\n BaseWndProc(CM_FONTCHANGED);\r\nend;\r\n\r\nprocedure TJvExScrollingWinControl.ColorChanged;\r\nbegin\r\n BaseWndProc(CM_COLORCHANGED);\r\nend;\r\n\r\nprocedure TJvExScrollingWinControl.ParentFontChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTFONTCHANGED);\r\nend;\r\n\r\nprocedure TJvExScrollingWinControl.ParentColorChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTCOLORCHANGED);\r\n if Assigned(OnParentColorChange) then\r\n OnParentColorChange(Self);\r\nend;\r\n\r\nprocedure TJvExScrollingWinControl.ParentShowHintChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTSHOWHINTCHANGED);\r\nend;\r\n\r\nfunction TJvExScrollingWinControl.WantKey(Key: Integer; Shift: TShiftState): Boolean;\r\nbegin\r\n Result := BaseWndProc(CM_DIALOGCHAR, Word(Key), ShiftStateToKeyData(Shift)) <> 0;\r\nend;\r\n\r\nfunction TJvExScrollingWinControl.HitTest(X, Y: Integer): Boolean;\r\nbegin\r\n Result := BaseWndProc(CM_HITTEST, 0, SmallPointToLong(PointToSmallPoint(Point(X, Y)))) <> 0;\r\nend;\r\n\r\nfunction TJvExScrollingWinControl.HintShow(var HintInfo: THintInfo): Boolean;\r\nbegin\r\n GetHintColor(HintInfo, Self, FHintColor);\r\n if FHintWindowClass <> nil then\r\n HintInfo.HintWindowClass := FHintWindowClass;\r\n Result := BaseWndProcEx(CM_HINTSHOW, 0, HintInfo) <> 0;\r\nend;\r\n\r\nprocedure TJvExScrollingWinControl.MouseEnter(AControl: TControl);\r\nbegin\r\n FMouseOver := True;\r\n if Assigned(FOnMouseEnter) then\r\n FOnMouseEnter(Self);\r\n BaseWndProc(CM_MOUSEENTER, 0, AControl);\r\nend;\r\n\r\nprocedure TJvExScrollingWinControl.MouseLeave(AControl: TControl);\r\nbegin\r\n FMouseOver := False;\r\n BaseWndProc(CM_MOUSELEAVE, 0, AControl);\r\n if Assigned(FOnMouseLeave) then\r\n FOnMouseLeave(Self);\r\nend;\r\n\r\nprocedure TJvExScrollingWinControl.FocusChanged(AControl: TWinControl);\r\nbegin\r\n BaseWndProc(CM_FOCUSCHANGED, 0, AControl);\r\nend;\r\n\r\nprocedure TJvExScrollingWinControl.BoundsChanged;\r\nbegin\r\nend;\r\n\r\nprocedure TJvExScrollingWinControl.CursorChanged;\r\nbegin\r\n BaseWndProc(CM_CURSORCHANGED);\r\nend;\r\n\r\nprocedure TJvExScrollingWinControl.ShowingChanged;\r\nbegin\r\n BaseWndProc(CM_SHOWINGCHANGED);\r\nend;\r\n\r\nprocedure TJvExScrollingWinControl.ShowHintChanged;\r\nbegin\r\n BaseWndProc(CM_SHOWHINTCHANGED);\r\nend;\r\n\r\n{ VCL sends CM_CONTROLLISTCHANGE and CM_CONTROLCHANGE in a different order than\r\n the CLX methods are used. So we must correct it by evaluating \"Inserting\". }\r\nprocedure TJvExScrollingWinControl.ControlsListChanging(Control: TControl; Inserting: Boolean);\r\nbegin\r\n if Inserting then\r\n BaseWndProc(CM_CONTROLLISTCHANGE, WPARAM(Control), LPARAM(Inserting))\r\n else\r\n BaseWndProc(CM_CONTROLCHANGE, WPARAM(Control), LPARAM(Inserting));\r\nend;\r\n\r\nprocedure TJvExScrollingWinControl.ControlsListChanged(Control: TControl; Inserting: Boolean);\r\nbegin\r\n if not Inserting then\r\n BaseWndProc(CM_CONTROLLISTCHANGE, WPARAM(Control), LPARAM(Inserting))\r\n else\r\n BaseWndProc(CM_CONTROLCHANGE, WPARAM(Control), LPARAM(Inserting));\r\nend;\r\n\r\nprocedure TJvExScrollingWinControl.GetDlgCode(var Code: TDlgCodes);\r\nbegin\r\nend;\r\n\r\nprocedure TJvExScrollingWinControl.FocusSet(PrevWnd: THandle);\r\nbegin\r\n BaseWndProc(WM_SETFOCUS, WPARAM(PrevWnd), 0);\r\nend;\r\n\r\nprocedure TJvExScrollingWinControl.FocusKilled(NextWnd: THandle);\r\nbegin\r\n BaseWndProc(WM_KILLFOCUS, WPARAM(NextWnd), 0);\r\nend;\r\n\r\nfunction TJvExScrollingWinControl.DoEraseBackground(Canvas: TCanvas; Param: LPARAM): Boolean;\r\nbegin\r\n Result := BaseWndProc(WM_ERASEBKGND, Canvas.Handle, Param) <> 0;\r\nend;\r\n\r\n{$IFDEF JVCLThemesEnabledD6}\r\nfunction TJvExScrollingWinControl.GetParentBackground: Boolean;\r\nbegin\r\n Result := JvThemes.GetParentBackground(Self);\r\nend;\r\n\r\nprocedure TJvExScrollingWinControl.SetParentBackground(Value: Boolean);\r\nbegin\r\n JvThemes.SetParentBackground(Self, Value);\r\nend;\r\n{$ENDIF JVCLThemesEnabledD6}\r\n\r\nprocedure TJvExScrollingWinControl.WndProc(var Msg: TMessage);\r\nvar\r\n IdSaveDC: Integer;\r\n DlgCodes: TDlgCodes;\r\n Canvas: TCanvas;\r\nbegin\r\n if not DispatchIsDesignMsg(Self, Msg) then\r\n begin\r\n case Msg.Msg of\r\n CM_DENYSUBCLASSING:\r\n Msg.Result := LRESULT(Ord(GetInterfaceEntry(IJvDenySubClassing) <> nil));\r\n CM_DIALOGCHAR:\r\n with TCMDialogChar{$IFDEF CLR}.Create{$ENDIF}(Msg) do\r\n Result := LRESULT(Ord(WantKey(CharCode, KeyDataToShiftState(KeyData))));\r\n CM_HINTSHOW:\r\n with TCMHintShow(Msg) do\r\n Result := LRESULT(HintShow(HintInfo^));\r\n CM_HITTEST:\r\n with TCMHitTest(Msg) do\r\n Result := LRESULT(HitTest(XPos, YPos));\r\n CM_MOUSEENTER:\r\n MouseEnter(TControl(Msg.LParam));\r\n CM_MOUSELEAVE:\r\n MouseLeave(TControl(Msg.LParam));\r\n CM_VISIBLECHANGED:\r\n VisibleChanged;\r\n CM_ENABLEDCHANGED:\r\n EnabledChanged;\r\n CM_TEXTCHANGED:\r\n TextChanged;\r\n CM_FONTCHANGED:\r\n FontChanged;\r\n CM_COLORCHANGED:\r\n ColorChanged;\r\n CM_FOCUSCHANGED:\r\n FocusChanged(TWinControl(Msg.LParam));\r\n CM_PARENTFONTCHANGED:\r\n ParentFontChanged;\r\n CM_PARENTCOLORCHANGED:\r\n ParentColorChanged;\r\n CM_PARENTSHOWHINTCHANGED:\r\n ParentShowHintChanged;\r\n CM_CURSORCHANGED:\r\n CursorChanged;\r\n CM_SHOWINGCHANGED:\r\n ShowingChanged;\r\n CM_SHOWHINTCHANGED:\r\n ShowHintChanged;\r\n CM_CONTROLLISTCHANGE:\r\n if Msg.LParam <> 0 then\r\n ControlsListChanging(TControl(Msg.WParam), True)\r\n else\r\n ControlsListChanged(TControl(Msg.WParam), False);\r\n CM_CONTROLCHANGE:\r\n if Msg.LParam = 0 then\r\n ControlsListChanging(TControl(Msg.WParam), False)\r\n else\r\n ControlsListChanged(TControl(Msg.WParam), True);\r\n WM_SETFOCUS:\r\n FocusSet(THandle(Msg.WParam));\r\n WM_KILLFOCUS:\r\n FocusKilled(THandle(Msg.WParam));\r\n WM_SIZE, WM_MOVE:\r\n begin\r\n inherited WndProc(Msg);\r\n BoundsChanged;\r\n end;\r\n WM_ERASEBKGND:\r\n if (Msg.WParam <> 0) and not IsDefaultEraseBackground(DoEraseBackground, @TJvExScrollingWinControl.DoEraseBackground) then\r\n begin\r\n IdSaveDC := SaveDC(HDC(Msg.WParam)); // protect DC against Stock-Objects from Canvas\r\n Canvas := TCanvas.Create;\r\n try\r\n Canvas.Handle := HDC(Msg.WParam);\r\n Msg.Result := Ord(DoEraseBackground(Canvas, Msg.LParam));\r\n finally\r\n Canvas.Handle := 0;\r\n Canvas.Free;\r\n RestoreDC(HDC(Msg.WParam), IdSaveDC);\r\n end;\r\n end\r\n else\r\n inherited WndProc(Msg);\r\n {$IFNDEF DELPHI2007_UP}\r\n WM_PRINTCLIENT, WM_PRINT: // VCL bug fix\r\n begin\r\n IdSaveDC := SaveDC(HDC(Msg.WParam)); // protect DC against changes\r\n try\r\n inherited WndProc(Msg);\r\n finally\r\n RestoreDC(HDC(Msg.WParam), IdSaveDC);\r\n end;\r\n end;\r\n {$ENDIF ~DELPHI2007_UP}\r\n WM_GETDLGCODE:\r\n begin\r\n inherited WndProc(Msg);\r\n DlgCodes := [dcNative] + DlgcToDlgCodes(Msg.Result);\r\n GetDlgCode(DlgCodes);\r\n if not (dcNative in DlgCodes) then\r\n Msg.Result := DlgCodesToDlgc(DlgCodes);\r\n end;\r\n else\r\n inherited WndProc(Msg);\r\n end;\r\n case Msg.Msg of // precheck message to prevent access violations on released controls\r\n CM_MOUSEENTER, CM_MOUSELEAVE, WM_KILLFOCUS, WM_SETFOCUS, WM_NCPAINT:\r\n if DotNetHighlighting then\r\n HandleDotNetHighlighting(Self, Msg, MouseOver, Color);\r\n end;\r\n end;\r\nend;\r\n\r\n//============================================================================\r\n\r\nconstructor TJvExScrollBox.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FHintColor := clDefault;\r\nend;\r\n\r\nfunction TJvExScrollBox.BaseWndProc(Msg: Cardinal; WParam: WPARAM = 0; LParam: LPARAM = 0): LRESULT;\r\nvar\r\n Mesg: TMessage;\r\nbegin\r\n CreateWMMessage(Mesg, Msg, WParam, LParam);\r\n inherited WndProc(Mesg);\r\n Result := Mesg.Result;\r\nend;\r\n\r\nfunction TJvExScrollBox.BaseWndProc(Msg: Cardinal; WParam: WPARAM; LParam: TObject): LRESULT;\r\nbegin\r\n Result := BaseWndProc(Msg, WParam, Windows.LPARAM(LParam));\r\nend;\r\n\r\nfunction TJvExScrollBox.BaseWndProcEx(Msg: Cardinal; WParam: WPARAM; var StructLParam): LRESULT;\r\nbegin\r\n Result := BaseWndProc(Msg, WParam, Windows.LPARAM(@StructLParam));\r\nend;\r\n\r\nprocedure TJvExScrollBox.VisibleChanged;\r\nbegin\r\n BaseWndProc(CM_VISIBLECHANGED);\r\nend;\r\n\r\nprocedure TJvExScrollBox.EnabledChanged;\r\nbegin\r\n BaseWndProc(CM_ENABLEDCHANGED);\r\nend;\r\n\r\nprocedure TJvExScrollBox.TextChanged;\r\nbegin\r\n BaseWndProc(CM_TEXTCHANGED);\r\nend;\r\n\r\nprocedure TJvExScrollBox.FontChanged;\r\nbegin\r\n BaseWndProc(CM_FONTCHANGED);\r\nend;\r\n\r\nprocedure TJvExScrollBox.ColorChanged;\r\nbegin\r\n BaseWndProc(CM_COLORCHANGED);\r\nend;\r\n\r\nprocedure TJvExScrollBox.ParentFontChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTFONTCHANGED);\r\nend;\r\n\r\nprocedure TJvExScrollBox.ParentColorChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTCOLORCHANGED);\r\n if Assigned(OnParentColorChange) then\r\n OnParentColorChange(Self);\r\nend;\r\n\r\nprocedure TJvExScrollBox.ParentShowHintChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTSHOWHINTCHANGED);\r\nend;\r\n\r\nfunction TJvExScrollBox.WantKey(Key: Integer; Shift: TShiftState): Boolean;\r\nbegin\r\n Result := BaseWndProc(CM_DIALOGCHAR, Word(Key), ShiftStateToKeyData(Shift)) <> 0;\r\nend;\r\n\r\nfunction TJvExScrollBox.HitTest(X, Y: Integer): Boolean;\r\nbegin\r\n Result := BaseWndProc(CM_HITTEST, 0, SmallPointToLong(PointToSmallPoint(Point(X, Y)))) <> 0;\r\nend;\r\n\r\nfunction TJvExScrollBox.HintShow(var HintInfo: THintInfo): Boolean;\r\nbegin\r\n GetHintColor(HintInfo, Self, FHintColor);\r\n if FHintWindowClass <> nil then\r\n HintInfo.HintWindowClass := FHintWindowClass;\r\n Result := BaseWndProcEx(CM_HINTSHOW, 0, HintInfo) <> 0;\r\nend;\r\n\r\nprocedure TJvExScrollBox.MouseEnter(AControl: TControl);\r\nbegin\r\n FMouseOver := True;\r\n if Assigned(FOnMouseEnter) then\r\n FOnMouseEnter(Self);\r\n BaseWndProc(CM_MOUSEENTER, 0, AControl);\r\nend;\r\n\r\nprocedure TJvExScrollBox.MouseLeave(AControl: TControl);\r\nbegin\r\n FMouseOver := False;\r\n BaseWndProc(CM_MOUSELEAVE, 0, AControl);\r\n if Assigned(FOnMouseLeave) then\r\n FOnMouseLeave(Self);\r\nend;\r\n\r\nprocedure TJvExScrollBox.FocusChanged(AControl: TWinControl);\r\nbegin\r\n BaseWndProc(CM_FOCUSCHANGED, 0, AControl);\r\nend;\r\n\r\nprocedure TJvExScrollBox.BoundsChanged;\r\nbegin\r\nend;\r\n\r\nprocedure TJvExScrollBox.CursorChanged;\r\nbegin\r\n BaseWndProc(CM_CURSORCHANGED);\r\nend;\r\n\r\nprocedure TJvExScrollBox.ShowingChanged;\r\nbegin\r\n BaseWndProc(CM_SHOWINGCHANGED);\r\nend;\r\n\r\nprocedure TJvExScrollBox.ShowHintChanged;\r\nbegin\r\n BaseWndProc(CM_SHOWHINTCHANGED);\r\nend;\r\n\r\n{ VCL sends CM_CONTROLLISTCHANGE and CM_CONTROLCHANGE in a different order than\r\n the CLX methods are used. So we must correct it by evaluating \"Inserting\". }\r\nprocedure TJvExScrollBox.ControlsListChanging(Control: TControl; Inserting: Boolean);\r\nbegin\r\n if Inserting then\r\n BaseWndProc(CM_CONTROLLISTCHANGE, WPARAM(Control), LPARAM(Inserting))\r\n else\r\n BaseWndProc(CM_CONTROLCHANGE, WPARAM(Control), LPARAM(Inserting));\r\nend;\r\n\r\nprocedure TJvExScrollBox.ControlsListChanged(Control: TControl; Inserting: Boolean);\r\nbegin\r\n if not Inserting then\r\n BaseWndProc(CM_CONTROLLISTCHANGE, WPARAM(Control), LPARAM(Inserting))\r\n else\r\n BaseWndProc(CM_CONTROLCHANGE, WPARAM(Control), LPARAM(Inserting));\r\nend;\r\n\r\nprocedure TJvExScrollBox.GetDlgCode(var Code: TDlgCodes);\r\nbegin\r\nend;\r\n\r\nprocedure TJvExScrollBox.FocusSet(PrevWnd: THandle);\r\nbegin\r\n BaseWndProc(WM_SETFOCUS, WPARAM(PrevWnd), 0);\r\nend;\r\n\r\nprocedure TJvExScrollBox.FocusKilled(NextWnd: THandle);\r\nbegin\r\n BaseWndProc(WM_KILLFOCUS, WPARAM(NextWnd), 0);\r\nend;\r\n\r\nfunction TJvExScrollBox.DoEraseBackground(Canvas: TCanvas; Param: LPARAM): Boolean;\r\nbegin\r\n Result := BaseWndProc(WM_ERASEBKGND, Canvas.Handle, Param) <> 0;\r\nend;\r\n\r\n{$IFDEF JVCLThemesEnabledD6}\r\nfunction TJvExScrollBox.GetParentBackground: Boolean;\r\nbegin\r\n Result := JvThemes.GetParentBackground(Self);\r\nend;\r\n\r\nprocedure TJvExScrollBox.SetParentBackground(Value: Boolean);\r\nbegin\r\n JvThemes.SetParentBackground(Self, Value);\r\nend;\r\n{$ENDIF JVCLThemesEnabledD6}\r\n\r\nprocedure TJvExScrollBox.WndProc(var Msg: TMessage);\r\nvar\r\n IdSaveDC: Integer;\r\n DlgCodes: TDlgCodes;\r\n Canvas: TCanvas;\r\nbegin\r\n if not DispatchIsDesignMsg(Self, Msg) then\r\n begin\r\n case Msg.Msg of\r\n CM_DENYSUBCLASSING:\r\n Msg.Result := LRESULT(Ord(GetInterfaceEntry(IJvDenySubClassing) <> nil));\r\n CM_DIALOGCHAR:\r\n with TCMDialogChar{$IFDEF CLR}.Create{$ENDIF}(Msg) do\r\n Result := LRESULT(Ord(WantKey(CharCode, KeyDataToShiftState(KeyData))));\r\n CM_HINTSHOW:\r\n with TCMHintShow(Msg) do\r\n Result := LRESULT(HintShow(HintInfo^));\r\n CM_HITTEST:\r\n with TCMHitTest(Msg) do\r\n Result := LRESULT(HitTest(XPos, YPos));\r\n CM_MOUSEENTER:\r\n MouseEnter(TControl(Msg.LParam));\r\n CM_MOUSELEAVE:\r\n MouseLeave(TControl(Msg.LParam));\r\n CM_VISIBLECHANGED:\r\n VisibleChanged;\r\n CM_ENABLEDCHANGED:\r\n EnabledChanged;\r\n CM_TEXTCHANGED:\r\n TextChanged;\r\n CM_FONTCHANGED:\r\n FontChanged;\r\n CM_COLORCHANGED:\r\n ColorChanged;\r\n CM_FOCUSCHANGED:\r\n FocusChanged(TWinControl(Msg.LParam));\r\n CM_PARENTFONTCHANGED:\r\n ParentFontChanged;\r\n CM_PARENTCOLORCHANGED:\r\n ParentColorChanged;\r\n CM_PARENTSHOWHINTCHANGED:\r\n ParentShowHintChanged;\r\n CM_CURSORCHANGED:\r\n CursorChanged;\r\n CM_SHOWINGCHANGED:\r\n ShowingChanged;\r\n CM_SHOWHINTCHANGED:\r\n ShowHintChanged;\r\n CM_CONTROLLISTCHANGE:\r\n if Msg.LParam <> 0 then\r\n ControlsListChanging(TControl(Msg.WParam), True)\r\n else\r\n ControlsListChanged(TControl(Msg.WParam), False);\r\n CM_CONTROLCHANGE:\r\n if Msg.LParam = 0 then\r\n ControlsListChanging(TControl(Msg.WParam), False)\r\n else\r\n ControlsListChanged(TControl(Msg.WParam), True);\r\n WM_SETFOCUS:\r\n FocusSet(THandle(Msg.WParam));\r\n WM_KILLFOCUS:\r\n FocusKilled(THandle(Msg.WParam));\r\n WM_SIZE, WM_MOVE:\r\n begin\r\n inherited WndProc(Msg);\r\n BoundsChanged;\r\n end;\r\n WM_ERASEBKGND:\r\n if (Msg.WParam <> 0) and not IsDefaultEraseBackground(DoEraseBackground, @TJvExScrollBox.DoEraseBackground) then\r\n begin\r\n IdSaveDC := SaveDC(HDC(Msg.WParam)); // protect DC against Stock-Objects from Canvas\r\n Canvas := TCanvas.Create;\r\n try\r\n Canvas.Handle := HDC(Msg.WParam);\r\n Msg.Result := Ord(DoEraseBackground(Canvas, Msg.LParam));\r\n finally\r\n Canvas.Handle := 0;\r\n Canvas.Free;\r\n RestoreDC(HDC(Msg.WParam), IdSaveDC);\r\n end;\r\n end\r\n else\r\n inherited WndProc(Msg);\r\n {$IFNDEF DELPHI2007_UP}\r\n WM_PRINTCLIENT, WM_PRINT: // VCL bug fix\r\n begin\r\n IdSaveDC := SaveDC(HDC(Msg.WParam)); // protect DC against changes\r\n try\r\n inherited WndProc(Msg);\r\n finally\r\n RestoreDC(HDC(Msg.WParam), IdSaveDC);\r\n end;\r\n end;\r\n {$ENDIF ~DELPHI2007_UP}\r\n WM_GETDLGCODE:\r\n begin\r\n inherited WndProc(Msg);\r\n DlgCodes := [dcNative] + DlgcToDlgCodes(Msg.Result);\r\n GetDlgCode(DlgCodes);\r\n if not (dcNative in DlgCodes) then\r\n Msg.Result := DlgCodesToDlgc(DlgCodes);\r\n end;\r\n else\r\n inherited WndProc(Msg);\r\n end;\r\n case Msg.Msg of // precheck message to prevent access violations on released controls\r\n CM_MOUSEENTER, CM_MOUSELEAVE, WM_KILLFOCUS, WM_SETFOCUS, WM_NCPAINT:\r\n if DotNetHighlighting then\r\n HandleDotNetHighlighting(Self, Msg, MouseOver, Color);\r\n end;\r\n end;\r\nend;\r\n\r\n//============================================================================\r\n\r\nconstructor TJvExCustomFrame.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FHintColor := clDefault;\r\nend;\r\n\r\nfunction TJvExCustomFrame.BaseWndProc(Msg: Cardinal; WParam: WPARAM = 0; LParam: LPARAM = 0): LRESULT;\r\nvar\r\n Mesg: TMessage;\r\nbegin\r\n CreateWMMessage(Mesg, Msg, WParam, LParam);\r\n inherited WndProc(Mesg);\r\n Result := Mesg.Result;\r\nend;\r\n\r\nfunction TJvExCustomFrame.BaseWndProc(Msg: Cardinal; WParam: WPARAM; LParam: TObject): LRESULT;\r\nbegin\r\n Result := BaseWndProc(Msg, WParam, Windows.LPARAM(LParam));\r\nend;\r\n\r\nfunction TJvExCustomFrame.BaseWndProcEx(Msg: Cardinal; WParam: WPARAM; var StructLParam): LRESULT;\r\nbegin\r\n Result := BaseWndProc(Msg, WParam, Windows.LPARAM(@StructLParam));\r\nend;\r\n\r\nprocedure TJvExCustomFrame.VisibleChanged;\r\nbegin\r\n BaseWndProc(CM_VISIBLECHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomFrame.EnabledChanged;\r\nbegin\r\n BaseWndProc(CM_ENABLEDCHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomFrame.TextChanged;\r\nbegin\r\n BaseWndProc(CM_TEXTCHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomFrame.FontChanged;\r\nbegin\r\n BaseWndProc(CM_FONTCHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomFrame.ColorChanged;\r\nbegin\r\n BaseWndProc(CM_COLORCHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomFrame.ParentFontChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTFONTCHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomFrame.ParentColorChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTCOLORCHANGED);\r\n if Assigned(OnParentColorChange) then\r\n OnParentColorChange(Self);\r\nend;\r\n\r\nprocedure TJvExCustomFrame.ParentShowHintChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTSHOWHINTCHANGED);\r\nend;\r\n\r\nfunction TJvExCustomFrame.WantKey(Key: Integer; Shift: TShiftState): Boolean;\r\nbegin\r\n Result := BaseWndProc(CM_DIALOGCHAR, Word(Key), ShiftStateToKeyData(Shift)) <> 0;\r\nend;\r\n\r\nfunction TJvExCustomFrame.HitTest(X, Y: Integer): Boolean;\r\nbegin\r\n Result := BaseWndProc(CM_HITTEST, 0, SmallPointToLong(PointToSmallPoint(Point(X, Y)))) <> 0;\r\nend;\r\n\r\nfunction TJvExCustomFrame.HintShow(var HintInfo: THintInfo): Boolean;\r\nbegin\r\n GetHintColor(HintInfo, Self, FHintColor);\r\n if FHintWindowClass <> nil then\r\n HintInfo.HintWindowClass := FHintWindowClass;\r\n Result := BaseWndProcEx(CM_HINTSHOW, 0, HintInfo) <> 0;\r\nend;\r\n\r\nprocedure TJvExCustomFrame.MouseEnter(AControl: TControl);\r\nbegin\r\n FMouseOver := True;\r\n if Assigned(FOnMouseEnter) then\r\n FOnMouseEnter(Self);\r\n BaseWndProc(CM_MOUSEENTER, 0, AControl);\r\nend;\r\n\r\nprocedure TJvExCustomFrame.MouseLeave(AControl: TControl);\r\nbegin\r\n FMouseOver := False;\r\n BaseWndProc(CM_MOUSELEAVE, 0, AControl);\r\n if Assigned(FOnMouseLeave) then\r\n FOnMouseLeave(Self);\r\nend;\r\n\r\nprocedure TJvExCustomFrame.FocusChanged(AControl: TWinControl);\r\nbegin\r\n BaseWndProc(CM_FOCUSCHANGED, 0, AControl);\r\nend;\r\n\r\nprocedure TJvExCustomFrame.BoundsChanged;\r\nbegin\r\nend;\r\n\r\nprocedure TJvExCustomFrame.CursorChanged;\r\nbegin\r\n BaseWndProc(CM_CURSORCHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomFrame.ShowingChanged;\r\nbegin\r\n BaseWndProc(CM_SHOWINGCHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomFrame.ShowHintChanged;\r\nbegin\r\n BaseWndProc(CM_SHOWHINTCHANGED);\r\nend;\r\n\r\n{ VCL sends CM_CONTROLLISTCHANGE and CM_CONTROLCHANGE in a different order than\r\n the CLX methods are used. So we must correct it by evaluating \"Inserting\". }\r\nprocedure TJvExCustomFrame.ControlsListChanging(Control: TControl; Inserting: Boolean);\r\nbegin\r\n if Inserting then\r\n BaseWndProc(CM_CONTROLLISTCHANGE, WPARAM(Control), LPARAM(Inserting))\r\n else\r\n BaseWndProc(CM_CONTROLCHANGE, WPARAM(Control), LPARAM(Inserting));\r\nend;\r\n\r\nprocedure TJvExCustomFrame.ControlsListChanged(Control: TControl; Inserting: Boolean);\r\nbegin\r\n if not Inserting then\r\n BaseWndProc(CM_CONTROLLISTCHANGE, WPARAM(Control), LPARAM(Inserting))\r\n else\r\n BaseWndProc(CM_CONTROLCHANGE, WPARAM(Control), LPARAM(Inserting));\r\nend;\r\n\r\nprocedure TJvExCustomFrame.GetDlgCode(var Code: TDlgCodes);\r\nbegin\r\nend;\r\n\r\nprocedure TJvExCustomFrame.FocusSet(PrevWnd: THandle);\r\nbegin\r\n BaseWndProc(WM_SETFOCUS, WPARAM(PrevWnd), 0);\r\nend;\r\n\r\nprocedure TJvExCustomFrame.FocusKilled(NextWnd: THandle);\r\nbegin\r\n BaseWndProc(WM_KILLFOCUS, WPARAM(NextWnd), 0);\r\nend;\r\n\r\nfunction TJvExCustomFrame.DoEraseBackground(Canvas: TCanvas; Param: LPARAM): Boolean;\r\nbegin\r\n Result := BaseWndProc(WM_ERASEBKGND, Canvas.Handle, Param) <> 0;\r\nend;\r\n\r\n{$IFDEF JVCLThemesEnabledD6}\r\nfunction TJvExCustomFrame.GetParentBackground: Boolean;\r\nbegin\r\n Result := JvThemes.GetParentBackground(Self);\r\nend;\r\n\r\nprocedure TJvExCustomFrame.SetParentBackground(Value: Boolean);\r\nbegin\r\n JvThemes.SetParentBackground(Self, Value);\r\nend;\r\n{$ENDIF JVCLThemesEnabledD6}\r\n\r\nprocedure TJvExCustomFrame.WndProc(var Msg: TMessage);\r\nvar\r\n IdSaveDC: Integer;\r\n DlgCodes: TDlgCodes;\r\n Canvas: TCanvas;\r\nbegin\r\n if not DispatchIsDesignMsg(Self, Msg) then\r\n begin\r\n case Msg.Msg of\r\n CM_DENYSUBCLASSING:\r\n Msg.Result := LRESULT(Ord(GetInterfaceEntry(IJvDenySubClassing) <> nil));\r\n CM_DIALOGCHAR:\r\n with TCMDialogChar{$IFDEF CLR}.Create{$ENDIF}(Msg) do\r\n Result := LRESULT(Ord(WantKey(CharCode, KeyDataToShiftState(KeyData))));\r\n CM_HINTSHOW:\r\n with TCMHintShow(Msg) do\r\n Result := LRESULT(HintShow(HintInfo^));\r\n CM_HITTEST:\r\n with TCMHitTest(Msg) do\r\n Result := LRESULT(HitTest(XPos, YPos));\r\n CM_MOUSEENTER:\r\n MouseEnter(TControl(Msg.LParam));\r\n CM_MOUSELEAVE:\r\n MouseLeave(TControl(Msg.LParam));\r\n CM_VISIBLECHANGED:\r\n VisibleChanged;\r\n CM_ENABLEDCHANGED:\r\n EnabledChanged;\r\n CM_TEXTCHANGED:\r\n TextChanged;\r\n CM_FONTCHANGED:\r\n FontChanged;\r\n CM_COLORCHANGED:\r\n ColorChanged;\r\n CM_FOCUSCHANGED:\r\n FocusChanged(TWinControl(Msg.LParam));\r\n CM_PARENTFONTCHANGED:\r\n ParentFontChanged;\r\n CM_PARENTCOLORCHANGED:\r\n ParentColorChanged;\r\n CM_PARENTSHOWHINTCHANGED:\r\n ParentShowHintChanged;\r\n CM_CURSORCHANGED:\r\n CursorChanged;\r\n CM_SHOWINGCHANGED:\r\n ShowingChanged;\r\n CM_SHOWHINTCHANGED:\r\n ShowHintChanged;\r\n CM_CONTROLLISTCHANGE:\r\n if Msg.LParam <> 0 then\r\n ControlsListChanging(TControl(Msg.WParam), True)\r\n else\r\n ControlsListChanged(TControl(Msg.WParam), False);\r\n CM_CONTROLCHANGE:\r\n if Msg.LParam = 0 then\r\n ControlsListChanging(TControl(Msg.WParam), False)\r\n else\r\n ControlsListChanged(TControl(Msg.WParam), True);\r\n WM_SETFOCUS:\r\n FocusSet(THandle(Msg.WParam));\r\n WM_KILLFOCUS:\r\n FocusKilled(THandle(Msg.WParam));\r\n WM_SIZE, WM_MOVE:\r\n begin\r\n inherited WndProc(Msg);\r\n BoundsChanged;\r\n end;\r\n WM_ERASEBKGND:\r\n if (Msg.WParam <> 0) and not IsDefaultEraseBackground(DoEraseBackground, @TJvExCustomFrame.DoEraseBackground) then\r\n begin\r\n IdSaveDC := SaveDC(HDC(Msg.WParam)); // protect DC against Stock-Objects from Canvas\r\n Canvas := TCanvas.Create;\r\n try\r\n Canvas.Handle := HDC(Msg.WParam);\r\n Msg.Result := Ord(DoEraseBackground(Canvas, Msg.LParam));\r\n finally\r\n Canvas.Handle := 0;\r\n Canvas.Free;\r\n RestoreDC(HDC(Msg.WParam), IdSaveDC);\r\n end;\r\n end\r\n else\r\n inherited WndProc(Msg);\r\n {$IFNDEF DELPHI2007_UP}\r\n WM_PRINTCLIENT, WM_PRINT: // VCL bug fix\r\n begin\r\n IdSaveDC := SaveDC(HDC(Msg.WParam)); // protect DC against changes\r\n try\r\n inherited WndProc(Msg);\r\n finally\r\n RestoreDC(HDC(Msg.WParam), IdSaveDC);\r\n end;\r\n end;\r\n {$ENDIF ~DELPHI2007_UP}\r\n WM_GETDLGCODE:\r\n begin\r\n inherited WndProc(Msg);\r\n DlgCodes := [dcNative] + DlgcToDlgCodes(Msg.Result);\r\n GetDlgCode(DlgCodes);\r\n if not (dcNative in DlgCodes) then\r\n Msg.Result := DlgCodesToDlgc(DlgCodes);\r\n end;\r\n else\r\n inherited WndProc(Msg);\r\n end;\r\n case Msg.Msg of // precheck message to prevent access violations on released controls\r\n CM_MOUSEENTER, CM_MOUSELEAVE, WM_KILLFOCUS, WM_SETFOCUS, WM_NCPAINT:\r\n if DotNetHighlighting then\r\n HandleDotNetHighlighting(Self, Msg, MouseOver, Color);\r\n end;\r\n end;\r\nend;\r\n\r\n//============================================================================\r\n\r\nconstructor TJvExFrame.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FHintColor := clDefault;\r\nend;\r\n\r\nfunction TJvExFrame.BaseWndProc(Msg: Cardinal; WParam: WPARAM = 0; LParam: LPARAM = 0): LRESULT;\r\nvar\r\n Mesg: TMessage;\r\nbegin\r\n CreateWMMessage(Mesg, Msg, WParam, LParam);\r\n inherited WndProc(Mesg);\r\n Result := Mesg.Result;\r\nend;\r\n\r\nfunction TJvExFrame.BaseWndProc(Msg: Cardinal; WParam: WPARAM; LParam: TObject): LRESULT;\r\nbegin\r\n Result := BaseWndProc(Msg, WParam, Windows.LPARAM(LParam));\r\nend;\r\n\r\nfunction TJvExFrame.BaseWndProcEx(Msg: Cardinal; WParam: WPARAM; var StructLParam): LRESULT;\r\nbegin\r\n Result := BaseWndProc(Msg, WParam, Windows.LPARAM(@StructLParam));\r\nend;\r\n\r\nprocedure TJvExFrame.VisibleChanged;\r\nbegin\r\n BaseWndProc(CM_VISIBLECHANGED);\r\nend;\r\n\r\nprocedure TJvExFrame.EnabledChanged;\r\nbegin\r\n BaseWndProc(CM_ENABLEDCHANGED);\r\nend;\r\n\r\nprocedure TJvExFrame.TextChanged;\r\nbegin\r\n BaseWndProc(CM_TEXTCHANGED);\r\nend;\r\n\r\nprocedure TJvExFrame.FontChanged;\r\nbegin\r\n BaseWndProc(CM_FONTCHANGED);\r\nend;\r\n\r\nprocedure TJvExFrame.ColorChanged;\r\nbegin\r\n BaseWndProc(CM_COLORCHANGED);\r\nend;\r\n\r\nprocedure TJvExFrame.ParentFontChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTFONTCHANGED);\r\nend;\r\n\r\nprocedure TJvExFrame.ParentColorChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTCOLORCHANGED);\r\n if Assigned(OnParentColorChange) then\r\n OnParentColorChange(Self);\r\nend;\r\n\r\nprocedure TJvExFrame.ParentShowHintChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTSHOWHINTCHANGED);\r\nend;\r\n\r\nfunction TJvExFrame.WantKey(Key: Integer; Shift: TShiftState): Boolean;\r\nbegin\r\n Result := BaseWndProc(CM_DIALOGCHAR, Word(Key), ShiftStateToKeyData(Shift)) <> 0;\r\nend;\r\n\r\nfunction TJvExFrame.HitTest(X, Y: Integer): Boolean;\r\nbegin\r\n Result := BaseWndProc(CM_HITTEST, 0, SmallPointToLong(PointToSmallPoint(Point(X, Y)))) <> 0;\r\nend;\r\n\r\nfunction TJvExFrame.HintShow(var HintInfo: THintInfo): Boolean;\r\nbegin\r\n GetHintColor(HintInfo, Self, FHintColor);\r\n if FHintWindowClass <> nil then\r\n HintInfo.HintWindowClass := FHintWindowClass;\r\n Result := BaseWndProcEx(CM_HINTSHOW, 0, HintInfo) <> 0;\r\nend;\r\n\r\nprocedure TJvExFrame.MouseEnter(AControl: TControl);\r\nbegin\r\n FMouseOver := True;\r\n if Assigned(FOnMouseEnter) then\r\n FOnMouseEnter(Self);\r\n BaseWndProc(CM_MOUSEENTER, 0, AControl);\r\nend;\r\n\r\nprocedure TJvExFrame.MouseLeave(AControl: TControl);\r\nbegin\r\n FMouseOver := False;\r\n BaseWndProc(CM_MOUSELEAVE, 0, AControl);\r\n if Assigned(FOnMouseLeave) then\r\n FOnMouseLeave(Self);\r\nend;\r\n\r\nprocedure TJvExFrame.FocusChanged(AControl: TWinControl);\r\nbegin\r\n BaseWndProc(CM_FOCUSCHANGED, 0, AControl);\r\nend;\r\n\r\nprocedure TJvExFrame.BoundsChanged;\r\nbegin\r\nend;\r\n\r\nprocedure TJvExFrame.CursorChanged;\r\nbegin\r\n BaseWndProc(CM_CURSORCHANGED);\r\nend;\r\n\r\nprocedure TJvExFrame.ShowingChanged;\r\nbegin\r\n BaseWndProc(CM_SHOWINGCHANGED);\r\nend;\r\n\r\nprocedure TJvExFrame.ShowHintChanged;\r\nbegin\r\n BaseWndProc(CM_SHOWHINTCHANGED);\r\nend;\r\n\r\n{ VCL sends CM_CONTROLLISTCHANGE and CM_CONTROLCHANGE in a different order than\r\n the CLX methods are used. So we must correct it by evaluating \"Inserting\". }\r\nprocedure TJvExFrame.ControlsListChanging(Control: TControl; Inserting: Boolean);\r\nbegin\r\n if Inserting then\r\n BaseWndProc(CM_CONTROLLISTCHANGE, WPARAM(Control), LPARAM(Inserting))\r\n else\r\n BaseWndProc(CM_CONTROLCHANGE, WPARAM(Control), LPARAM(Inserting));\r\nend;\r\n\r\nprocedure TJvExFrame.ControlsListChanged(Control: TControl; Inserting: Boolean);\r\nbegin\r\n if not Inserting then\r\n BaseWndProc(CM_CONTROLLISTCHANGE, WPARAM(Control), LPARAM(Inserting))\r\n else\r\n BaseWndProc(CM_CONTROLCHANGE, WPARAM(Control), LPARAM(Inserting));\r\nend;\r\n\r\nprocedure TJvExFrame.GetDlgCode(var Code: TDlgCodes);\r\nbegin\r\nend;\r\n\r\nprocedure TJvExFrame.FocusSet(PrevWnd: THandle);\r\nbegin\r\n BaseWndProc(WM_SETFOCUS, WPARAM(PrevWnd), 0);\r\nend;\r\n\r\nprocedure TJvExFrame.FocusKilled(NextWnd: THandle);\r\nbegin\r\n BaseWndProc(WM_KILLFOCUS, WPARAM(NextWnd), 0);\r\nend;\r\n\r\nfunction TJvExFrame.DoEraseBackground(Canvas: TCanvas; Param: LPARAM): Boolean;\r\nbegin\r\n Result := BaseWndProc(WM_ERASEBKGND, Canvas.Handle, Param) <> 0;\r\nend;\r\n\r\n{$IFDEF JVCLThemesEnabledD6}\r\nfunction TJvExFrame.GetParentBackground: Boolean;\r\nbegin\r\n Result := JvThemes.GetParentBackground(Self);\r\nend;\r\n\r\nprocedure TJvExFrame.SetParentBackground(Value: Boolean);\r\nbegin\r\n JvThemes.SetParentBackground(Self, Value);\r\nend;\r\n{$ENDIF JVCLThemesEnabledD6}\r\n\r\nprocedure TJvExFrame.WndProc(var Msg: TMessage);\r\nvar\r\n IdSaveDC: Integer;\r\n DlgCodes: TDlgCodes;\r\n Canvas: TCanvas;\r\nbegin\r\n if not DispatchIsDesignMsg(Self, Msg) then\r\n begin\r\n case Msg.Msg of\r\n CM_DENYSUBCLASSING:\r\n Msg.Result := LRESULT(Ord(GetInterfaceEntry(IJvDenySubClassing) <> nil));\r\n CM_DIALOGCHAR:\r\n with TCMDialogChar{$IFDEF CLR}.Create{$ENDIF}(Msg) do\r\n Result := LRESULT(Ord(WantKey(CharCode, KeyDataToShiftState(KeyData))));\r\n CM_HINTSHOW:\r\n with TCMHintShow(Msg) do\r\n Result := LRESULT(HintShow(HintInfo^));\r\n CM_HITTEST:\r\n with TCMHitTest(Msg) do\r\n Result := LRESULT(HitTest(XPos, YPos));\r\n CM_MOUSEENTER:\r\n MouseEnter(TControl(Msg.LParam));\r\n CM_MOUSELEAVE:\r\n MouseLeave(TControl(Msg.LParam));\r\n CM_VISIBLECHANGED:\r\n VisibleChanged;\r\n CM_ENABLEDCHANGED:\r\n EnabledChanged;\r\n CM_TEXTCHANGED:\r\n TextChanged;\r\n CM_FONTCHANGED:\r\n FontChanged;\r\n CM_COLORCHANGED:\r\n ColorChanged;\r\n CM_FOCUSCHANGED:\r\n FocusChanged(TWinControl(Msg.LParam));\r\n CM_PARENTFONTCHANGED:\r\n ParentFontChanged;\r\n CM_PARENTCOLORCHANGED:\r\n ParentColorChanged;\r\n CM_PARENTSHOWHINTCHANGED:\r\n ParentShowHintChanged;\r\n CM_CURSORCHANGED:\r\n CursorChanged;\r\n CM_SHOWINGCHANGED:\r\n ShowingChanged;\r\n CM_SHOWHINTCHANGED:\r\n ShowHintChanged;\r\n CM_CONTROLLISTCHANGE:\r\n if Msg.LParam <> 0 then\r\n ControlsListChanging(TControl(Msg.WParam), True)\r\n else\r\n ControlsListChanged(TControl(Msg.WParam), False);\r\n CM_CONTROLCHANGE:\r\n if Msg.LParam = 0 then\r\n ControlsListChanging(TControl(Msg.WParam), False)\r\n else\r\n ControlsListChanged(TControl(Msg.WParam), True);\r\n WM_SETFOCUS:\r\n FocusSet(THandle(Msg.WParam));\r\n WM_KILLFOCUS:\r\n FocusKilled(THandle(Msg.WParam));\r\n WM_SIZE, WM_MOVE:\r\n begin\r\n inherited WndProc(Msg);\r\n BoundsChanged;\r\n end;\r\n WM_ERASEBKGND:\r\n if (Msg.WParam <> 0) and not IsDefaultEraseBackground(DoEraseBackground, @TJvExFrame.DoEraseBackground) then\r\n begin\r\n IdSaveDC := SaveDC(HDC(Msg.WParam)); // protect DC against Stock-Objects from Canvas\r\n Canvas := TCanvas.Create;\r\n try\r\n Canvas.Handle := HDC(Msg.WParam);\r\n Msg.Result := Ord(DoEraseBackground(Canvas, Msg.LParam));\r\n finally\r\n Canvas.Handle := 0;\r\n Canvas.Free;\r\n RestoreDC(HDC(Msg.WParam), IdSaveDC);\r\n end;\r\n end\r\n else\r\n inherited WndProc(Msg);\r\n {$IFNDEF DELPHI2007_UP}\r\n WM_PRINTCLIENT, WM_PRINT: // VCL bug fix\r\n begin\r\n IdSaveDC := SaveDC(HDC(Msg.WParam)); // protect DC against changes\r\n try\r\n inherited WndProc(Msg);\r\n finally\r\n RestoreDC(HDC(Msg.WParam), IdSaveDC);\r\n end;\r\n end;\r\n {$ENDIF ~DELPHI2007_UP}\r\n WM_GETDLGCODE:\r\n begin\r\n inherited WndProc(Msg);\r\n DlgCodes := [dcNative] + DlgcToDlgCodes(Msg.Result);\r\n GetDlgCode(DlgCodes);\r\n if not (dcNative in DlgCodes) then\r\n Msg.Result := DlgCodesToDlgc(DlgCodes);\r\n end;\r\n else\r\n inherited WndProc(Msg);\r\n end;\r\n case Msg.Msg of // precheck message to prevent access violations on released controls\r\n CM_MOUSEENTER, CM_MOUSELEAVE, WM_KILLFOCUS, WM_SETFOCUS, WM_NCPAINT:\r\n if DotNetHighlighting then\r\n HandleDotNetHighlighting(Self, Msg, MouseOver, Color);\r\n end;\r\n end;\r\nend;\r\n\r\n//============================================================================\r\n\r\nconstructor TJvExToolWindow.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FHintColor := clDefault;\r\nend;\r\n\r\nfunction TJvExToolWindow.BaseWndProc(Msg: Cardinal; WParam: WPARAM = 0; LParam: LPARAM = 0): LRESULT;\r\nvar\r\n Mesg: TMessage;\r\nbegin\r\n CreateWMMessage(Mesg, Msg, WParam, LParam);\r\n inherited WndProc(Mesg);\r\n Result := Mesg.Result;\r\nend;\r\n\r\nfunction TJvExToolWindow.BaseWndProc(Msg: Cardinal; WParam: WPARAM; LParam: TObject): LRESULT;\r\nbegin\r\n Result := BaseWndProc(Msg, WParam, Windows.LPARAM(LParam));\r\nend;\r\n\r\nfunction TJvExToolWindow.BaseWndProcEx(Msg: Cardinal; WParam: WPARAM; var StructLParam): LRESULT;\r\nbegin\r\n Result := BaseWndProc(Msg, WParam, Windows.LPARAM(@StructLParam));\r\nend;\r\n\r\nprocedure TJvExToolWindow.VisibleChanged;\r\nbegin\r\n BaseWndProc(CM_VISIBLECHANGED);\r\nend;\r\n\r\nprocedure TJvExToolWindow.EnabledChanged;\r\nbegin\r\n BaseWndProc(CM_ENABLEDCHANGED);\r\nend;\r\n\r\nprocedure TJvExToolWindow.TextChanged;\r\nbegin\r\n BaseWndProc(CM_TEXTCHANGED);\r\nend;\r\n\r\nprocedure TJvExToolWindow.FontChanged;\r\nbegin\r\n BaseWndProc(CM_FONTCHANGED);\r\nend;\r\n\r\nprocedure TJvExToolWindow.ColorChanged;\r\nbegin\r\n BaseWndProc(CM_COLORCHANGED);\r\nend;\r\n\r\nprocedure TJvExToolWindow.ParentFontChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTFONTCHANGED);\r\nend;\r\n\r\nprocedure TJvExToolWindow.ParentColorChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTCOLORCHANGED);\r\n if Assigned(OnParentColorChange) then\r\n OnParentColorChange(Self);\r\nend;\r\n\r\nprocedure TJvExToolWindow.ParentShowHintChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTSHOWHINTCHANGED);\r\nend;\r\n\r\nfunction TJvExToolWindow.WantKey(Key: Integer; Shift: TShiftState): Boolean;\r\nbegin\r\n Result := BaseWndProc(CM_DIALOGCHAR, Word(Key), ShiftStateToKeyData(Shift)) <> 0;\r\nend;\r\n\r\nfunction TJvExToolWindow.HitTest(X, Y: Integer): Boolean;\r\nbegin\r\n Result := BaseWndProc(CM_HITTEST, 0, SmallPointToLong(PointToSmallPoint(Point(X, Y)))) <> 0;\r\nend;\r\n\r\nfunction TJvExToolWindow.HintShow(var HintInfo: THintInfo): Boolean;\r\nbegin\r\n GetHintColor(HintInfo, Self, FHintColor);\r\n if FHintWindowClass <> nil then\r\n HintInfo.HintWindowClass := FHintWindowClass;\r\n Result := BaseWndProcEx(CM_HINTSHOW, 0, HintInfo) <> 0;\r\nend;\r\n\r\nprocedure TJvExToolWindow.MouseEnter(AControl: TControl);\r\nbegin\r\n FMouseOver := True;\r\n if Assigned(FOnMouseEnter) then\r\n FOnMouseEnter(Self);\r\n BaseWndProc(CM_MOUSEENTER, 0, AControl);\r\nend;\r\n\r\nprocedure TJvExToolWindow.MouseLeave(AControl: TControl);\r\nbegin\r\n FMouseOver := False;\r\n BaseWndProc(CM_MOUSELEAVE, 0, AControl);\r\n if Assigned(FOnMouseLeave) then\r\n FOnMouseLeave(Self);\r\nend;\r\n\r\nprocedure TJvExToolWindow.FocusChanged(AControl: TWinControl);\r\nbegin\r\n BaseWndProc(CM_FOCUSCHANGED, 0, AControl);\r\nend;\r\n\r\nprocedure TJvExToolWindow.BoundsChanged;\r\nbegin\r\nend;\r\n\r\nprocedure TJvExToolWindow.CursorChanged;\r\nbegin\r\n BaseWndProc(CM_CURSORCHANGED);\r\nend;\r\n\r\nprocedure TJvExToolWindow.ShowingChanged;\r\nbegin\r\n BaseWndProc(CM_SHOWINGCHANGED);\r\nend;\r\n\r\nprocedure TJvExToolWindow.ShowHintChanged;\r\nbegin\r\n BaseWndProc(CM_SHOWHINTCHANGED);\r\nend;\r\n\r\n{ VCL sends CM_CONTROLLISTCHANGE and CM_CONTROLCHANGE in a different order than\r\n the CLX methods are used. So we must correct it by evaluating \"Inserting\". }\r\nprocedure TJvExToolWindow.ControlsListChanging(Control: TControl; Inserting: Boolean);\r\nbegin\r\n if Inserting then\r\n BaseWndProc(CM_CONTROLLISTCHANGE, WPARAM(Control), LPARAM(Inserting))\r\n else\r\n BaseWndProc(CM_CONTROLCHANGE, WPARAM(Control), LPARAM(Inserting));\r\nend;\r\n\r\nprocedure TJvExToolWindow.ControlsListChanged(Control: TControl; Inserting: Boolean);\r\nbegin\r\n if not Inserting then\r\n BaseWndProc(CM_CONTROLLISTCHANGE, WPARAM(Control), LPARAM(Inserting))\r\n else\r\n BaseWndProc(CM_CONTROLCHANGE, WPARAM(Control), LPARAM(Inserting));\r\nend;\r\n\r\nprocedure TJvExToolWindow.GetDlgCode(var Code: TDlgCodes);\r\nbegin\r\nend;\r\n\r\nprocedure TJvExToolWindow.FocusSet(PrevWnd: THandle);\r\nbegin\r\n BaseWndProc(WM_SETFOCUS, WPARAM(PrevWnd), 0);\r\nend;\r\n\r\nprocedure TJvExToolWindow.FocusKilled(NextWnd: THandle);\r\nbegin\r\n BaseWndProc(WM_KILLFOCUS, WPARAM(NextWnd), 0);\r\nend;\r\n\r\nfunction TJvExToolWindow.DoEraseBackground(Canvas: TCanvas; Param: LPARAM): Boolean;\r\nbegin\r\n Result := BaseWndProc(WM_ERASEBKGND, Canvas.Handle, Param) <> 0;\r\nend;\r\n\r\n{$IFDEF JVCLThemesEnabledD6}\r\nfunction TJvExToolWindow.GetParentBackground: Boolean;\r\nbegin\r\n Result := JvThemes.GetParentBackground(Self);\r\nend;\r\n\r\nprocedure TJvExToolWindow.SetParentBackground(Value: Boolean);\r\nbegin\r\n JvThemes.SetParentBackground(Self, Value);\r\nend;\r\n{$ENDIF JVCLThemesEnabledD6}\r\n\r\nprocedure TJvExToolWindow.WndProc(var Msg: TMessage);\r\nvar\r\n IdSaveDC: Integer;\r\n DlgCodes: TDlgCodes;\r\n Canvas: TCanvas;\r\nbegin\r\n if not DispatchIsDesignMsg(Self, Msg) then\r\n begin\r\n case Msg.Msg of\r\n CM_DENYSUBCLASSING:\r\n Msg.Result := LRESULT(Ord(GetInterfaceEntry(IJvDenySubClassing) <> nil));\r\n CM_DIALOGCHAR:\r\n with TCMDialogChar{$IFDEF CLR}.Create{$ENDIF}(Msg) do\r\n Result := LRESULT(Ord(WantKey(CharCode, KeyDataToShiftState(KeyData))));\r\n CM_HINTSHOW:\r\n with TCMHintShow(Msg) do\r\n Result := LRESULT(HintShow(HintInfo^));\r\n CM_HITTEST:\r\n with TCMHitTest(Msg) do\r\n Result := LRESULT(HitTest(XPos, YPos));\r\n CM_MOUSEENTER:\r\n MouseEnter(TControl(Msg.LParam));\r\n CM_MOUSELEAVE:\r\n MouseLeave(TControl(Msg.LParam));\r\n CM_VISIBLECHANGED:\r\n VisibleChanged;\r\n CM_ENABLEDCHANGED:\r\n EnabledChanged;\r\n CM_TEXTCHANGED:\r\n TextChanged;\r\n CM_FONTCHANGED:\r\n FontChanged;\r\n CM_COLORCHANGED:\r\n ColorChanged;\r\n CM_FOCUSCHANGED:\r\n FocusChanged(TWinControl(Msg.LParam));\r\n CM_PARENTFONTCHANGED:\r\n ParentFontChanged;\r\n CM_PARENTCOLORCHANGED:\r\n ParentColorChanged;\r\n CM_PARENTSHOWHINTCHANGED:\r\n ParentShowHintChanged;\r\n CM_CURSORCHANGED:\r\n CursorChanged;\r\n CM_SHOWINGCHANGED:\r\n ShowingChanged;\r\n CM_SHOWHINTCHANGED:\r\n ShowHintChanged;\r\n CM_CONTROLLISTCHANGE:\r\n if Msg.LParam <> 0 then\r\n ControlsListChanging(TControl(Msg.WParam), True)\r\n else\r\n ControlsListChanged(TControl(Msg.WParam), False);\r\n CM_CONTROLCHANGE:\r\n if Msg.LParam = 0 then\r\n ControlsListChanging(TControl(Msg.WParam), False)\r\n else\r\n ControlsListChanged(TControl(Msg.WParam), True);\r\n WM_SETFOCUS:\r\n FocusSet(THandle(Msg.WParam));\r\n WM_KILLFOCUS:\r\n FocusKilled(THandle(Msg.WParam));\r\n WM_SIZE, WM_MOVE:\r\n begin\r\n inherited WndProc(Msg);\r\n BoundsChanged;\r\n end;\r\n WM_ERASEBKGND:\r\n if (Msg.WParam <> 0) and not IsDefaultEraseBackground(DoEraseBackground, @TJvExToolWindow.DoEraseBackground) then\r\n begin\r\n IdSaveDC := SaveDC(HDC(Msg.WParam)); // protect DC against Stock-Objects from Canvas\r\n Canvas := TCanvas.Create;\r\n try\r\n Canvas.Handle := HDC(Msg.WParam);\r\n Msg.Result := Ord(DoEraseBackground(Canvas, Msg.LParam));\r\n finally\r\n Canvas.Handle := 0;\r\n Canvas.Free;\r\n RestoreDC(HDC(Msg.WParam), IdSaveDC);\r\n end;\r\n end\r\n else\r\n inherited WndProc(Msg);\r\n {$IFNDEF DELPHI2007_UP}\r\n WM_PRINTCLIENT, WM_PRINT: // VCL bug fix\r\n begin\r\n IdSaveDC := SaveDC(HDC(Msg.WParam)); // protect DC against changes\r\n try\r\n inherited WndProc(Msg);\r\n finally\r\n RestoreDC(HDC(Msg.WParam), IdSaveDC);\r\n end;\r\n end;\r\n {$ENDIF ~DELPHI2007_UP}\r\n WM_GETDLGCODE:\r\n begin\r\n inherited WndProc(Msg);\r\n DlgCodes := [dcNative] + DlgcToDlgCodes(Msg.Result);\r\n GetDlgCode(DlgCodes);\r\n if not (dcNative in DlgCodes) then\r\n Msg.Result := DlgCodesToDlgc(DlgCodes);\r\n end;\r\n else\r\n inherited WndProc(Msg);\r\n end;\r\n case Msg.Msg of // precheck message to prevent access violations on released controls\r\n CM_MOUSEENTER, CM_MOUSELEAVE, WM_KILLFOCUS, WM_SETFOCUS, WM_NCPAINT:\r\n if DotNetHighlighting then\r\n HandleDotNetHighlighting(Self, Msg, MouseOver, Color);\r\n end;\r\n end;\r\nend;\r\n\r\n//============================================================================\r\n\r\nconstructor TJvExCustomForm.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FHintColor := clDefault;\r\nend;\r\n\r\nfunction TJvExCustomForm.BaseWndProc(Msg: Cardinal; WParam: WPARAM = 0; LParam: LPARAM = 0): LRESULT;\r\nvar\r\n Mesg: TMessage;\r\nbegin\r\n CreateWMMessage(Mesg, Msg, WParam, LParam);\r\n inherited WndProc(Mesg);\r\n Result := Mesg.Result;\r\nend;\r\n\r\nfunction TJvExCustomForm.BaseWndProc(Msg: Cardinal; WParam: WPARAM; LParam: TObject): LRESULT;\r\nbegin\r\n Result := BaseWndProc(Msg, WParam, Windows.LPARAM(LParam));\r\nend;\r\n\r\nfunction TJvExCustomForm.BaseWndProcEx(Msg: Cardinal; WParam: WPARAM; var StructLParam): LRESULT;\r\nbegin\r\n Result := BaseWndProc(Msg, WParam, Windows.LPARAM(@StructLParam));\r\nend;\r\n\r\nprocedure TJvExCustomForm.VisibleChanged;\r\nbegin\r\n BaseWndProc(CM_VISIBLECHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomForm.EnabledChanged;\r\nbegin\r\n BaseWndProc(CM_ENABLEDCHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomForm.TextChanged;\r\nbegin\r\n BaseWndProc(CM_TEXTCHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomForm.FontChanged;\r\nbegin\r\n BaseWndProc(CM_FONTCHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomForm.ColorChanged;\r\nbegin\r\n BaseWndProc(CM_COLORCHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomForm.ParentFontChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTFONTCHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomForm.ParentColorChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTCOLORCHANGED);\r\n if Assigned(OnParentColorChange) then\r\n OnParentColorChange(Self);\r\nend;\r\n\r\nprocedure TJvExCustomForm.ParentShowHintChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTSHOWHINTCHANGED);\r\nend;\r\n\r\nfunction TJvExCustomForm.WantKey(Key: Integer; Shift: TShiftState): Boolean;\r\nbegin\r\n Result := BaseWndProc(CM_DIALOGCHAR, Word(Key), ShiftStateToKeyData(Shift)) <> 0;\r\nend;\r\n\r\nfunction TJvExCustomForm.HitTest(X, Y: Integer): Boolean;\r\nbegin\r\n Result := BaseWndProc(CM_HITTEST, 0, SmallPointToLong(PointToSmallPoint(Point(X, Y)))) <> 0;\r\nend;\r\n\r\nfunction TJvExCustomForm.HintShow(var HintInfo: THintInfo): Boolean;\r\nbegin\r\n GetHintColor(HintInfo, Self, FHintColor);\r\n if FHintWindowClass <> nil then\r\n HintInfo.HintWindowClass := FHintWindowClass;\r\n Result := BaseWndProcEx(CM_HINTSHOW, 0, HintInfo) <> 0;\r\nend;\r\n\r\nprocedure TJvExCustomForm.MouseEnter(AControl: TControl);\r\nbegin\r\n FMouseOver := True;\r\n if Assigned(FOnMouseEnter) then\r\n FOnMouseEnter(Self);\r\n BaseWndProc(CM_MOUSEENTER, 0, AControl);\r\nend;\r\n\r\nprocedure TJvExCustomForm.MouseLeave(AControl: TControl);\r\nbegin\r\n FMouseOver := False;\r\n BaseWndProc(CM_MOUSELEAVE, 0, AControl);\r\n if Assigned(FOnMouseLeave) then\r\n FOnMouseLeave(Self);\r\nend;\r\n\r\nprocedure TJvExCustomForm.FocusChanged(AControl: TWinControl);\r\nbegin\r\n BaseWndProc(CM_FOCUSCHANGED, 0, AControl);\r\nend;\r\n\r\nprocedure TJvExCustomForm.BoundsChanged;\r\nbegin\r\nend;\r\n\r\nprocedure TJvExCustomForm.CursorChanged;\r\nbegin\r\n BaseWndProc(CM_CURSORCHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomForm.ShowingChanged;\r\nbegin\r\n BaseWndProc(CM_SHOWINGCHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomForm.ShowHintChanged;\r\nbegin\r\n BaseWndProc(CM_SHOWHINTCHANGED);\r\nend;\r\n\r\n{ VCL sends CM_CONTROLLISTCHANGE and CM_CONTROLCHANGE in a different order than\r\n the CLX methods are used. So we must correct it by evaluating \"Inserting\". }\r\nprocedure TJvExCustomForm.ControlsListChanging(Control: TControl; Inserting: Boolean);\r\nbegin\r\n if Inserting then\r\n BaseWndProc(CM_CONTROLLISTCHANGE, WPARAM(Control), LPARAM(Inserting))\r\n else\r\n BaseWndProc(CM_CONTROLCHANGE, WPARAM(Control), LPARAM(Inserting));\r\nend;\r\n\r\nprocedure TJvExCustomForm.ControlsListChanged(Control: TControl; Inserting: Boolean);\r\nbegin\r\n if not Inserting then\r\n BaseWndProc(CM_CONTROLLISTCHANGE, WPARAM(Control), LPARAM(Inserting))\r\n else\r\n BaseWndProc(CM_CONTROLCHANGE, WPARAM(Control), LPARAM(Inserting));\r\nend;\r\n\r\nprocedure TJvExCustomForm.GetDlgCode(var Code: TDlgCodes);\r\nbegin\r\nend;\r\n\r\nprocedure TJvExCustomForm.FocusSet(PrevWnd: THandle);\r\nbegin\r\n BaseWndProc(WM_SETFOCUS, WPARAM(PrevWnd), 0);\r\nend;\r\n\r\nprocedure TJvExCustomForm.FocusKilled(NextWnd: THandle);\r\nbegin\r\n BaseWndProc(WM_KILLFOCUS, WPARAM(NextWnd), 0);\r\nend;\r\n\r\nfunction TJvExCustomForm.DoEraseBackground(Canvas: TCanvas; Param: LPARAM): Boolean;\r\nbegin\r\n Result := BaseWndProc(WM_ERASEBKGND, Canvas.Handle, Param) <> 0;\r\nend;\r\n\r\n{$IFDEF JVCLThemesEnabledD6}\r\nfunction TJvExCustomForm.GetParentBackground: Boolean;\r\nbegin\r\n Result := JvThemes.GetParentBackground(Self);\r\nend;\r\n\r\nprocedure TJvExCustomForm.SetParentBackground(Value: Boolean);\r\nbegin\r\n JvThemes.SetParentBackground(Self, Value);\r\nend;\r\n{$ENDIF JVCLThemesEnabledD6}\r\n\r\nprocedure TJvExCustomForm.WndProc(var Msg: TMessage);\r\nvar\r\n IdSaveDC: Integer;\r\n DlgCodes: TDlgCodes;\r\n Canvas: TCanvas;\r\nbegin\r\n if not DispatchIsDesignMsg(Self, Msg) then\r\n begin\r\n case Msg.Msg of\r\n CM_DENYSUBCLASSING:\r\n Msg.Result := LRESULT(Ord(GetInterfaceEntry(IJvDenySubClassing) <> nil));\r\n CM_DIALOGCHAR:\r\n with TCMDialogChar{$IFDEF CLR}.Create{$ENDIF}(Msg) do\r\n Result := LRESULT(Ord(WantKey(CharCode, KeyDataToShiftState(KeyData))));\r\n CM_HINTSHOW:\r\n with TCMHintShow(Msg) do\r\n Result := LRESULT(HintShow(HintInfo^));\r\n CM_HITTEST:\r\n with TCMHitTest(Msg) do\r\n Result := LRESULT(HitTest(XPos, YPos));\r\n CM_MOUSEENTER:\r\n MouseEnter(TControl(Msg.LParam));\r\n CM_MOUSELEAVE:\r\n MouseLeave(TControl(Msg.LParam));\r\n CM_VISIBLECHANGED:\r\n VisibleChanged;\r\n CM_ENABLEDCHANGED:\r\n EnabledChanged;\r\n CM_TEXTCHANGED:\r\n TextChanged;\r\n CM_FONTCHANGED:\r\n FontChanged;\r\n CM_COLORCHANGED:\r\n ColorChanged;\r\n CM_FOCUSCHANGED:\r\n FocusChanged(TWinControl(Msg.LParam));\r\n CM_PARENTFONTCHANGED:\r\n ParentFontChanged;\r\n CM_PARENTCOLORCHANGED:\r\n ParentColorChanged;\r\n CM_PARENTSHOWHINTCHANGED:\r\n ParentShowHintChanged;\r\n CM_CURSORCHANGED:\r\n CursorChanged;\r\n CM_SHOWINGCHANGED:\r\n ShowingChanged;\r\n CM_SHOWHINTCHANGED:\r\n ShowHintChanged;\r\n CM_CONTROLLISTCHANGE:\r\n if Msg.LParam <> 0 then\r\n ControlsListChanging(TControl(Msg.WParam), True)\r\n else\r\n ControlsListChanged(TControl(Msg.WParam), False);\r\n CM_CONTROLCHANGE:\r\n if Msg.LParam = 0 then\r\n ControlsListChanging(TControl(Msg.WParam), False)\r\n else\r\n ControlsListChanged(TControl(Msg.WParam), True);\r\n WM_SETFOCUS:\r\n FocusSet(THandle(Msg.WParam));\r\n WM_KILLFOCUS:\r\n FocusKilled(THandle(Msg.WParam));\r\n WM_SIZE, WM_MOVE:\r\n begin\r\n inherited WndProc(Msg);\r\n BoundsChanged;\r\n end;\r\n WM_ERASEBKGND:\r\n if (Msg.WParam <> 0) and not IsDefaultEraseBackground(DoEraseBackground, @TJvExCustomForm.DoEraseBackground) then\r\n begin\r\n IdSaveDC := SaveDC(HDC(Msg.WParam)); // protect DC against Stock-Objects from Canvas\r\n Canvas := TCanvas.Create;\r\n try\r\n Canvas.Handle := HDC(Msg.WParam);\r\n Msg.Result := Ord(DoEraseBackground(Canvas, Msg.LParam));\r\n finally\r\n Canvas.Handle := 0;\r\n Canvas.Free;\r\n RestoreDC(HDC(Msg.WParam), IdSaveDC);\r\n end;\r\n end\r\n else\r\n inherited WndProc(Msg);\r\n {$IFNDEF DELPHI2007_UP}\r\n WM_PRINTCLIENT, WM_PRINT: // VCL bug fix\r\n begin\r\n IdSaveDC := SaveDC(HDC(Msg.WParam)); // protect DC against changes\r\n try\r\n inherited WndProc(Msg);\r\n finally\r\n RestoreDC(HDC(Msg.WParam), IdSaveDC);\r\n end;\r\n end;\r\n {$ENDIF ~DELPHI2007_UP}\r\n WM_GETDLGCODE:\r\n begin\r\n inherited WndProc(Msg);\r\n DlgCodes := [dcNative] + DlgcToDlgCodes(Msg.Result);\r\n GetDlgCode(DlgCodes);\r\n if not (dcNative in DlgCodes) then\r\n Msg.Result := DlgCodesToDlgc(DlgCodes);\r\n end;\r\n else\r\n inherited WndProc(Msg);\r\n end;\r\n case Msg.Msg of // precheck message to prevent access violations on released controls\r\n CM_MOUSEENTER, CM_MOUSELEAVE, WM_KILLFOCUS, WM_SETFOCUS, WM_NCPAINT:\r\n if DotNetHighlighting then\r\n HandleDotNetHighlighting(Self, Msg, MouseOver, Color);\r\n end;\r\n end;\r\nend;\r\n\r\n//============================================================================\r\n\r\n{$IFNDEF COMPILER12_UP}\r\nconstructor TJvExCustomForm.CreateNew(AOwner: TComponent; Dummy: Integer);\r\nbegin\r\n inherited CreateNew(AOwner, Dummy);\r\n InitializeNewForm;\r\nend;\r\n{$ENDIF ~COMPILER12_UP}\r\n\r\nprocedure TJvExCustomForm.InitializeNewForm;\r\nbegin\r\n {$IFDEF COMPILER12_UP}\r\n inherited InitializeNewForm;\r\n {$ENDIF COMPILER12_UP}\r\n FHintColor := clDefault;\r\nend;\r\n\r\nprocedure TJvExCustomForm.CMShowingChanged(var Msg: TMessage);\r\nbegin\r\n if Showing then\r\n SendMessage(Handle, WM_CHANGEUISTATE, UIS_INITIALIZE, 0);\r\n inherited;\r\nend;\r\n\r\nprocedure TJvExCustomForm.CMDialogKey(var Msg: TCMDialogKey);\r\nbegin\r\n case Msg.CharCode of\r\n VK_LEFT..VK_DOWN, VK_TAB:\r\n SendMessage(Handle, WM_CHANGEUISTATE, MakeLong(UIS_CLEAR, UISF_HIDEFOCUS), 0);\r\n VK_MENU:\r\n SendMessage(Handle, WM_CHANGEUISTATE, MakeLong(UIS_CLEAR, UISF_HIDEFOCUS or UISF_HIDEACCEL), 0);\r\n end;\r\n inherited;\r\nend;\r\n\r\nconstructor TJvExForm.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FHintColor := clDefault;\r\nend;\r\n\r\nfunction TJvExForm.BaseWndProc(Msg: Cardinal; WParam: WPARAM = 0; LParam: LPARAM = 0): LRESULT;\r\nvar\r\n Mesg: TMessage;\r\nbegin\r\n CreateWMMessage(Mesg, Msg, WParam, LParam);\r\n inherited WndProc(Mesg);\r\n Result := Mesg.Result;\r\nend;\r\n\r\nfunction TJvExForm.BaseWndProc(Msg: Cardinal; WParam: WPARAM; LParam: TObject): LRESULT;\r\nbegin\r\n Result := BaseWndProc(Msg, WParam, Windows.LPARAM(LParam));\r\nend;\r\n\r\nfunction TJvExForm.BaseWndProcEx(Msg: Cardinal; WParam: WPARAM; var StructLParam): LRESULT;\r\nbegin\r\n Result := BaseWndProc(Msg, WParam, Windows.LPARAM(@StructLParam));\r\nend;\r\n\r\nprocedure TJvExForm.VisibleChanged;\r\nbegin\r\n BaseWndProc(CM_VISIBLECHANGED);\r\nend;\r\n\r\nprocedure TJvExForm.EnabledChanged;\r\nbegin\r\n BaseWndProc(CM_ENABLEDCHANGED);\r\nend;\r\n\r\nprocedure TJvExForm.TextChanged;\r\nbegin\r\n BaseWndProc(CM_TEXTCHANGED);\r\nend;\r\n\r\nprocedure TJvExForm.FontChanged;\r\nbegin\r\n BaseWndProc(CM_FONTCHANGED);\r\nend;\r\n\r\nprocedure TJvExForm.ColorChanged;\r\nbegin\r\n BaseWndProc(CM_COLORCHANGED);\r\nend;\r\n\r\nprocedure TJvExForm.ParentFontChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTFONTCHANGED);\r\nend;\r\n\r\nprocedure TJvExForm.ParentColorChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTCOLORCHANGED);\r\n if Assigned(OnParentColorChange) then\r\n OnParentColorChange(Self);\r\nend;\r\n\r\nprocedure TJvExForm.ParentShowHintChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTSHOWHINTCHANGED);\r\nend;\r\n\r\nfunction TJvExForm.WantKey(Key: Integer; Shift: TShiftState): Boolean;\r\nbegin\r\n Result := BaseWndProc(CM_DIALOGCHAR, Word(Key), ShiftStateToKeyData(Shift)) <> 0;\r\nend;\r\n\r\nfunction TJvExForm.HitTest(X, Y: Integer): Boolean;\r\nbegin\r\n Result := BaseWndProc(CM_HITTEST, 0, SmallPointToLong(PointToSmallPoint(Point(X, Y)))) <> 0;\r\nend;\r\n\r\nfunction TJvExForm.HintShow(var HintInfo: THintInfo): Boolean;\r\nbegin\r\n GetHintColor(HintInfo, Self, FHintColor);\r\n if FHintWindowClass <> nil then\r\n HintInfo.HintWindowClass := FHintWindowClass;\r\n Result := BaseWndProcEx(CM_HINTSHOW, 0, HintInfo) <> 0;\r\nend;\r\n\r\nprocedure TJvExForm.MouseEnter(AControl: TControl);\r\nbegin\r\n FMouseOver := True;\r\n if Assigned(FOnMouseEnter) then\r\n FOnMouseEnter(Self);\r\n BaseWndProc(CM_MOUSEENTER, 0, AControl);\r\nend;\r\n\r\nprocedure TJvExForm.MouseLeave(AControl: TControl);\r\nbegin\r\n FMouseOver := False;\r\n BaseWndProc(CM_MOUSELEAVE, 0, AControl);\r\n if Assigned(FOnMouseLeave) then\r\n FOnMouseLeave(Self);\r\nend;\r\n\r\nprocedure TJvExForm.FocusChanged(AControl: TWinControl);\r\nbegin\r\n BaseWndProc(CM_FOCUSCHANGED, 0, AControl);\r\nend;\r\n\r\nprocedure TJvExForm.BoundsChanged;\r\nbegin\r\nend;\r\n\r\nprocedure TJvExForm.CursorChanged;\r\nbegin\r\n BaseWndProc(CM_CURSORCHANGED);\r\nend;\r\n\r\nprocedure TJvExForm.ShowingChanged;\r\nbegin\r\n BaseWndProc(CM_SHOWINGCHANGED);\r\nend;\r\n\r\nprocedure TJvExForm.ShowHintChanged;\r\nbegin\r\n BaseWndProc(CM_SHOWHINTCHANGED);\r\nend;\r\n\r\n{ VCL sends CM_CONTROLLISTCHANGE and CM_CONTROLCHANGE in a different order than\r\n the CLX methods are used. So we must correct it by evaluating \"Inserting\". }\r\nprocedure TJvExForm.ControlsListChanging(Control: TControl; Inserting: Boolean);\r\nbegin\r\n if Inserting then\r\n BaseWndProc(CM_CONTROLLISTCHANGE, WPARAM(Control), LPARAM(Inserting))\r\n else\r\n BaseWndProc(CM_CONTROLCHANGE, WPARAM(Control), LPARAM(Inserting));\r\nend;\r\n\r\nprocedure TJvExForm.ControlsListChanged(Control: TControl; Inserting: Boolean);\r\nbegin\r\n if not Inserting then\r\n BaseWndProc(CM_CONTROLLISTCHANGE, WPARAM(Control), LPARAM(Inserting))\r\n else\r\n BaseWndProc(CM_CONTROLCHANGE, WPARAM(Control), LPARAM(Inserting));\r\nend;\r\n\r\nprocedure TJvExForm.GetDlgCode(var Code: TDlgCodes);\r\nbegin\r\nend;\r\n\r\nprocedure TJvExForm.FocusSet(PrevWnd: THandle);\r\nbegin\r\n BaseWndProc(WM_SETFOCUS, WPARAM(PrevWnd), 0);\r\nend;\r\n\r\nprocedure TJvExForm.FocusKilled(NextWnd: THandle);\r\nbegin\r\n BaseWndProc(WM_KILLFOCUS, WPARAM(NextWnd), 0);\r\nend;\r\n\r\nfunction TJvExForm.DoEraseBackground(Canvas: TCanvas; Param: LPARAM): Boolean;\r\nbegin\r\n Result := BaseWndProc(WM_ERASEBKGND, Canvas.Handle, Param) <> 0;\r\nend;\r\n\r\n{$IFDEF JVCLThemesEnabledD6}\r\nfunction TJvExForm.GetParentBackground: Boolean;\r\nbegin\r\n Result := JvThemes.GetParentBackground(Self);\r\nend;\r\n\r\nprocedure TJvExForm.SetParentBackground(Value: Boolean);\r\nbegin\r\n JvThemes.SetParentBackground(Self, Value);\r\nend;\r\n{$ENDIF JVCLThemesEnabledD6}\r\n\r\nprocedure TJvExForm.WndProc(var Msg: TMessage);\r\nvar\r\n IdSaveDC: Integer;\r\n DlgCodes: TDlgCodes;\r\n Canvas: TCanvas;\r\nbegin\r\n if not DispatchIsDesignMsg(Self, Msg) then\r\n begin\r\n case Msg.Msg of\r\n CM_DENYSUBCLASSING:\r\n Msg.Result := LRESULT(Ord(GetInterfaceEntry(IJvDenySubClassing) <> nil));\r\n CM_DIALOGCHAR:\r\n with TCMDialogChar{$IFDEF CLR}.Create{$ENDIF}(Msg) do\r\n Result := LRESULT(Ord(WantKey(CharCode, KeyDataToShiftState(KeyData))));\r\n CM_HINTSHOW:\r\n with TCMHintShow(Msg) do\r\n Result := LRESULT(HintShow(HintInfo^));\r\n CM_HITTEST:\r\n with TCMHitTest(Msg) do\r\n Result := LRESULT(HitTest(XPos, YPos));\r\n CM_MOUSEENTER:\r\n MouseEnter(TControl(Msg.LParam));\r\n CM_MOUSELEAVE:\r\n MouseLeave(TControl(Msg.LParam));\r\n CM_VISIBLECHANGED:\r\n VisibleChanged;\r\n CM_ENABLEDCHANGED:\r\n EnabledChanged;\r\n CM_TEXTCHANGED:\r\n TextChanged;\r\n CM_FONTCHANGED:\r\n FontChanged;\r\n CM_COLORCHANGED:\r\n ColorChanged;\r\n CM_FOCUSCHANGED:\r\n FocusChanged(TWinControl(Msg.LParam));\r\n CM_PARENTFONTCHANGED:\r\n ParentFontChanged;\r\n CM_PARENTCOLORCHANGED:\r\n ParentColorChanged;\r\n CM_PARENTSHOWHINTCHANGED:\r\n ParentShowHintChanged;\r\n CM_CURSORCHANGED:\r\n CursorChanged;\r\n CM_SHOWINGCHANGED:\r\n ShowingChanged;\r\n CM_SHOWHINTCHANGED:\r\n ShowHintChanged;\r\n CM_CONTROLLISTCHANGE:\r\n if Msg.LParam <> 0 then\r\n ControlsListChanging(TControl(Msg.WParam), True)\r\n else\r\n ControlsListChanged(TControl(Msg.WParam), False);\r\n CM_CONTROLCHANGE:\r\n if Msg.LParam = 0 then\r\n ControlsListChanging(TControl(Msg.WParam), False)\r\n else\r\n ControlsListChanged(TControl(Msg.WParam), True);\r\n WM_SETFOCUS:\r\n FocusSet(THandle(Msg.WParam));\r\n WM_KILLFOCUS:\r\n FocusKilled(THandle(Msg.WParam));\r\n WM_SIZE, WM_MOVE:\r\n begin\r\n inherited WndProc(Msg);\r\n BoundsChanged;\r\n end;\r\n WM_ERASEBKGND:\r\n if (Msg.WParam <> 0) and not IsDefaultEraseBackground(DoEraseBackground, @TJvExForm.DoEraseBackground) then\r\n begin\r\n IdSaveDC := SaveDC(HDC(Msg.WParam)); // protect DC against Stock-Objects from Canvas\r\n Canvas := TCanvas.Create;\r\n try\r\n Canvas.Handle := HDC(Msg.WParam);\r\n Msg.Result := Ord(DoEraseBackground(Canvas, Msg.LParam));\r\n finally\r\n Canvas.Handle := 0;\r\n Canvas.Free;\r\n RestoreDC(HDC(Msg.WParam), IdSaveDC);\r\n end;\r\n end\r\n else\r\n inherited WndProc(Msg);\r\n {$IFNDEF DELPHI2007_UP}\r\n WM_PRINTCLIENT, WM_PRINT: // VCL bug fix\r\n begin\r\n IdSaveDC := SaveDC(HDC(Msg.WParam)); // protect DC against changes\r\n try\r\n inherited WndProc(Msg);\r\n finally\r\n RestoreDC(HDC(Msg.WParam), IdSaveDC);\r\n end;\r\n end;\r\n {$ENDIF ~DELPHI2007_UP}\r\n WM_GETDLGCODE:\r\n begin\r\n inherited WndProc(Msg);\r\n DlgCodes := [dcNative] + DlgcToDlgCodes(Msg.Result);\r\n GetDlgCode(DlgCodes);\r\n if not (dcNative in DlgCodes) then\r\n Msg.Result := DlgCodesToDlgc(DlgCodes);\r\n end;\r\n else\r\n inherited WndProc(Msg);\r\n end;\r\n case Msg.Msg of // precheck message to prevent access violations on released controls\r\n CM_MOUSEENTER, CM_MOUSELEAVE, WM_KILLFOCUS, WM_SETFOCUS, WM_NCPAINT:\r\n if DotNetHighlighting then\r\n HandleDotNetHighlighting(Self, Msg, MouseOver, Color);\r\n end;\r\n end;\r\nend;\r\n\r\n//============================================================================\r\n\r\n{$IFNDEF COMPILER12_UP}\r\nconstructor TJvExForm.CreateNew(AOwner: TComponent; Dummy: Integer);\r\nbegin\r\n inherited CreateNew(AOwner, Dummy);\r\n InitializeNewForm;\r\nend;\r\n{$ENDIF ~COMPILER12_UP}\r\n\r\nprocedure TJvExForm.InitializeNewForm;\r\nbegin\r\n {$IFDEF COMPILER12_UP}\r\n inherited InitializeNewForm;\r\n {$ENDIF COMPILER12_UP}\r\n FHintColor := clDefault;\r\nend;\r\n\r\nprocedure TJvExForm.CMShowingChanged(var Msg: TMessage);\r\nbegin\r\n if Showing then\r\n SendMessage(Handle, WM_CHANGEUISTATE, UIS_INITIALIZE, 0);\r\n inherited;\r\nend;\r\n\r\nprocedure TJvExForm.CMDialogKey(var Msg: TCMDialogKey);\r\nbegin\r\n case Msg.CharCode of\r\n VK_LEFT..VK_DOWN, VK_TAB:\r\n SendMessage(Handle, WM_CHANGEUISTATE, MakeLong(UIS_CLEAR, UISF_HIDEFOCUS), 0);\r\n VK_MENU:\r\n SendMessage(Handle, WM_CHANGEUISTATE, MakeLong(UIS_CLEAR, UISF_HIDEFOCUS or UISF_HIDEACCEL), 0);\r\n end;\r\n inherited;\r\nend;\r\n\r\nconstructor TJvExCustomDockForm.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FHintColor := clDefault;\r\nend;\r\n\r\nfunction TJvExCustomDockForm.BaseWndProc(Msg: Cardinal; WParam: WPARAM = 0; LParam: LPARAM = 0): LRESULT;\r\nvar\r\n Mesg: TMessage;\r\nbegin\r\n CreateWMMessage(Mesg, Msg, WParam, LParam);\r\n inherited WndProc(Mesg);\r\n Result := Mesg.Result;\r\nend;\r\n\r\nfunction TJvExCustomDockForm.BaseWndProc(Msg: Cardinal; WParam: WPARAM; LParam: TObject): LRESULT;\r\nbegin\r\n Result := BaseWndProc(Msg, WParam, Windows.LPARAM(LParam));\r\nend;\r\n\r\nfunction TJvExCustomDockForm.BaseWndProcEx(Msg: Cardinal; WParam: WPARAM; var StructLParam): LRESULT;\r\nbegin\r\n Result := BaseWndProc(Msg, WParam, Windows.LPARAM(@StructLParam));\r\nend;\r\n\r\nprocedure TJvExCustomDockForm.VisibleChanged;\r\nbegin\r\n BaseWndProc(CM_VISIBLECHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomDockForm.EnabledChanged;\r\nbegin\r\n BaseWndProc(CM_ENABLEDCHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomDockForm.TextChanged;\r\nbegin\r\n BaseWndProc(CM_TEXTCHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomDockForm.FontChanged;\r\nbegin\r\n BaseWndProc(CM_FONTCHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomDockForm.ColorChanged;\r\nbegin\r\n BaseWndProc(CM_COLORCHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomDockForm.ParentFontChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTFONTCHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomDockForm.ParentColorChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTCOLORCHANGED);\r\n if Assigned(OnParentColorChange) then\r\n OnParentColorChange(Self);\r\nend;\r\n\r\nprocedure TJvExCustomDockForm.ParentShowHintChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTSHOWHINTCHANGED);\r\nend;\r\n\r\nfunction TJvExCustomDockForm.WantKey(Key: Integer; Shift: TShiftState): Boolean;\r\nbegin\r\n Result := BaseWndProc(CM_DIALOGCHAR, Word(Key), ShiftStateToKeyData(Shift)) <> 0;\r\nend;\r\n\r\nfunction TJvExCustomDockForm.HitTest(X, Y: Integer): Boolean;\r\nbegin\r\n Result := BaseWndProc(CM_HITTEST, 0, SmallPointToLong(PointToSmallPoint(Point(X, Y)))) <> 0;\r\nend;\r\n\r\nfunction TJvExCustomDockForm.HintShow(var HintInfo: THintInfo): Boolean;\r\nbegin\r\n GetHintColor(HintInfo, Self, FHintColor);\r\n if FHintWindowClass <> nil then\r\n HintInfo.HintWindowClass := FHintWindowClass;\r\n Result := BaseWndProcEx(CM_HINTSHOW, 0, HintInfo) <> 0;\r\nend;\r\n\r\nprocedure TJvExCustomDockForm.MouseEnter(AControl: TControl);\r\nbegin\r\n FMouseOver := True;\r\n if Assigned(FOnMouseEnter) then\r\n FOnMouseEnter(Self);\r\n BaseWndProc(CM_MOUSEENTER, 0, AControl);\r\nend;\r\n\r\nprocedure TJvExCustomDockForm.MouseLeave(AControl: TControl);\r\nbegin\r\n FMouseOver := False;\r\n BaseWndProc(CM_MOUSELEAVE, 0, AControl);\r\n if Assigned(FOnMouseLeave) then\r\n FOnMouseLeave(Self);\r\nend;\r\n\r\nprocedure TJvExCustomDockForm.FocusChanged(AControl: TWinControl);\r\nbegin\r\n BaseWndProc(CM_FOCUSCHANGED, 0, AControl);\r\nend;\r\n\r\nprocedure TJvExCustomDockForm.BoundsChanged;\r\nbegin\r\nend;\r\n\r\nprocedure TJvExCustomDockForm.CursorChanged;\r\nbegin\r\n BaseWndProc(CM_CURSORCHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomDockForm.ShowingChanged;\r\nbegin\r\n BaseWndProc(CM_SHOWINGCHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomDockForm.ShowHintChanged;\r\nbegin\r\n BaseWndProc(CM_SHOWHINTCHANGED);\r\nend;\r\n\r\n{ VCL sends CM_CONTROLLISTCHANGE and CM_CONTROLCHANGE in a different order than\r\n the CLX methods are used. So we must correct it by evaluating \"Inserting\". }\r\nprocedure TJvExCustomDockForm.ControlsListChanging(Control: TControl; Inserting: Boolean);\r\nbegin\r\n if Inserting then\r\n BaseWndProc(CM_CONTROLLISTCHANGE, WPARAM(Control), LPARAM(Inserting))\r\n else\r\n BaseWndProc(CM_CONTROLCHANGE, WPARAM(Control), LPARAM(Inserting));\r\nend;\r\n\r\nprocedure TJvExCustomDockForm.ControlsListChanged(Control: TControl; Inserting: Boolean);\r\nbegin\r\n if not Inserting then\r\n BaseWndProc(CM_CONTROLLISTCHANGE, WPARAM(Control), LPARAM(Inserting))\r\n else\r\n BaseWndProc(CM_CONTROLCHANGE, WPARAM(Control), LPARAM(Inserting));\r\nend;\r\n\r\nprocedure TJvExCustomDockForm.GetDlgCode(var Code: TDlgCodes);\r\nbegin\r\nend;\r\n\r\nprocedure TJvExCustomDockForm.FocusSet(PrevWnd: THandle);\r\nbegin\r\n BaseWndProc(WM_SETFOCUS, WPARAM(PrevWnd), 0);\r\nend;\r\n\r\nprocedure TJvExCustomDockForm.FocusKilled(NextWnd: THandle);\r\nbegin\r\n BaseWndProc(WM_KILLFOCUS, WPARAM(NextWnd), 0);\r\nend;\r\n\r\nfunction TJvExCustomDockForm.DoEraseBackground(Canvas: TCanvas; Param: LPARAM): Boolean;\r\nbegin\r\n Result := BaseWndProc(WM_ERASEBKGND, Canvas.Handle, Param) <> 0;\r\nend;\r\n\r\n{$IFDEF JVCLThemesEnabledD6}\r\nfunction TJvExCustomDockForm.GetParentBackground: Boolean;\r\nbegin\r\n Result := JvThemes.GetParentBackground(Self);\r\nend;\r\n\r\nprocedure TJvExCustomDockForm.SetParentBackground(Value: Boolean);\r\nbegin\r\n JvThemes.SetParentBackground(Self, Value);\r\nend;\r\n{$ENDIF JVCLThemesEnabledD6}\r\n\r\nprocedure TJvExCustomDockForm.WndProc(var Msg: TMessage);\r\nvar\r\n IdSaveDC: Integer;\r\n DlgCodes: TDlgCodes;\r\n Canvas: TCanvas;\r\nbegin\r\n if not DispatchIsDesignMsg(Self, Msg) then\r\n begin\r\n case Msg.Msg of\r\n CM_DENYSUBCLASSING:\r\n Msg.Result := LRESULT(Ord(GetInterfaceEntry(IJvDenySubClassing) <> nil));\r\n CM_DIALOGCHAR:\r\n with TCMDialogChar{$IFDEF CLR}.Create{$ENDIF}(Msg) do\r\n Result := LRESULT(Ord(WantKey(CharCode, KeyDataToShiftState(KeyData))));\r\n CM_HINTSHOW:\r\n with TCMHintShow(Msg) do\r\n Result := LRESULT(HintShow(HintInfo^));\r\n CM_HITTEST:\r\n with TCMHitTest(Msg) do\r\n Result := LRESULT(HitTest(XPos, YPos));\r\n CM_MOUSEENTER:\r\n MouseEnter(TControl(Msg.LParam));\r\n CM_MOUSELEAVE:\r\n MouseLeave(TControl(Msg.LParam));\r\n CM_VISIBLECHANGED:\r\n VisibleChanged;\r\n CM_ENABLEDCHANGED:\r\n EnabledChanged;\r\n CM_TEXTCHANGED:\r\n TextChanged;\r\n CM_FONTCHANGED:\r\n FontChanged;\r\n CM_COLORCHANGED:\r\n ColorChanged;\r\n CM_FOCUSCHANGED:\r\n FocusChanged(TWinControl(Msg.LParam));\r\n CM_PARENTFONTCHANGED:\r\n ParentFontChanged;\r\n CM_PARENTCOLORCHANGED:\r\n ParentColorChanged;\r\n CM_PARENTSHOWHINTCHANGED:\r\n ParentShowHintChanged;\r\n CM_CURSORCHANGED:\r\n CursorChanged;\r\n CM_SHOWINGCHANGED:\r\n ShowingChanged;\r\n CM_SHOWHINTCHANGED:\r\n ShowHintChanged;\r\n CM_CONTROLLISTCHANGE:\r\n if Msg.LParam <> 0 then\r\n ControlsListChanging(TControl(Msg.WParam), True)\r\n else\r\n ControlsListChanged(TControl(Msg.WParam), False);\r\n CM_CONTROLCHANGE:\r\n if Msg.LParam = 0 then\r\n ControlsListChanging(TControl(Msg.WParam), False)\r\n else\r\n ControlsListChanged(TControl(Msg.WParam), True);\r\n WM_SETFOCUS:\r\n FocusSet(THandle(Msg.WParam));\r\n WM_KILLFOCUS:\r\n FocusKilled(THandle(Msg.WParam));\r\n WM_SIZE, WM_MOVE:\r\n begin\r\n inherited WndProc(Msg);\r\n BoundsChanged;\r\n end;\r\n WM_ERASEBKGND:\r\n if (Msg.WParam <> 0) and not IsDefaultEraseBackground(DoEraseBackground, @TJvExCustomDockForm.DoEraseBackground) then\r\n begin\r\n IdSaveDC := SaveDC(HDC(Msg.WParam)); // protect DC against Stock-Objects from Canvas\r\n Canvas := TCanvas.Create;\r\n try\r\n Canvas.Handle := HDC(Msg.WParam);\r\n Msg.Result := Ord(DoEraseBackground(Canvas, Msg.LParam));\r\n finally\r\n Canvas.Handle := 0;\r\n Canvas.Free;\r\n RestoreDC(HDC(Msg.WParam), IdSaveDC);\r\n end;\r\n end\r\n else\r\n inherited WndProc(Msg);\r\n {$IFNDEF DELPHI2007_UP}\r\n WM_PRINTCLIENT, WM_PRINT: // VCL bug fix\r\n begin\r\n IdSaveDC := SaveDC(HDC(Msg.WParam)); // protect DC against changes\r\n try\r\n inherited WndProc(Msg);\r\n finally\r\n RestoreDC(HDC(Msg.WParam), IdSaveDC);\r\n end;\r\n end;\r\n {$ENDIF ~DELPHI2007_UP}\r\n WM_GETDLGCODE:\r\n begin\r\n inherited WndProc(Msg);\r\n DlgCodes := [dcNative] + DlgcToDlgCodes(Msg.Result);\r\n GetDlgCode(DlgCodes);\r\n if not (dcNative in DlgCodes) then\r\n Msg.Result := DlgCodesToDlgc(DlgCodes);\r\n end;\r\n else\r\n inherited WndProc(Msg);\r\n end;\r\n case Msg.Msg of // precheck message to prevent access violations on released controls\r\n CM_MOUSEENTER, CM_MOUSELEAVE, WM_KILLFOCUS, WM_SETFOCUS, WM_NCPAINT:\r\n if DotNetHighlighting then\r\n HandleDotNetHighlighting(Self, Msg, MouseOver, Color);\r\n end;\r\n end;\r\nend;\r\n\r\n//============================================================================\r\n\r\n{$IFNDEF COMPILER12_UP}\r\nconstructor TJvExCustomDockForm.CreateNew(AOwner: TComponent; Dummy: Integer);\r\nbegin\r\n inherited CreateNew(AOwner, Dummy);\r\n InitializeNewForm;\r\nend;\r\n{$ENDIF ~COMPILER12_UP}\r\n\r\nprocedure TJvExCustomDockForm.InitializeNewForm;\r\nbegin\r\n {$IFDEF COMPILER12_UP}\r\n inherited InitializeNewForm;\r\n {$ENDIF COMPILER12_UP}\r\n FHintColor := clDefault;\r\nend;\r\n\r\nprocedure TJvExCustomDockForm.CMShowingChanged(var Msg: TMessage);\r\nbegin\r\n if Showing then\r\n SendMessage(Handle, WM_CHANGEUISTATE, UIS_INITIALIZE, 0);\r\n inherited;\r\nend;\r\n\r\nprocedure TJvExCustomDockForm.CMDialogKey(var Msg: TCMDialogKey);\r\nbegin\r\n case Msg.CharCode of\r\n VK_LEFT..VK_DOWN, VK_TAB:\r\n SendMessage(Handle, WM_CHANGEUISTATE, MakeLong(UIS_CLEAR, UISF_HIDEFOCUS), 0);\r\n VK_MENU:\r\n SendMessage(Handle, WM_CHANGEUISTATE, MakeLong(UIS_CLEAR, UISF_HIDEFOCUS or UISF_HIDEACCEL), 0);\r\n end;\r\n inherited;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend." }, { "path": "External/Jedi/Jvcl/run/JvExGrids.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvExGrids.pas, released on 2004-01-04\r\n\r\nThe Initial Developer of the Original Code is Andreas Hausladen [Andreas dott Hausladen att gmx dott de]\r\nPortions created by Andreas Hausladen are Copyright (C) 2004 Andreas Hausladen.\r\nAll Rights Reserved.\r\n\r\nContributor(s): -\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvExGrids.pas 13221 2012-02-24 14:12:04Z obones $\r\n\r\nunit JvExGrids;\r\n\r\n{$I jvcl.inc}\r\n{MACROINCLUDE JvExControls.macros}\r\n\r\n{*****************************************************************************\r\n * WARNING: Do not edit this file.\r\n * This file is autogenerated from the source in devtools/JvExVCL/src.\r\n * If you do it despite this warning your changes will be discarded by the next\r\n * update of this file. Do your changes in the template files.\r\n ****************************************************************************}\r\n{$D-} // do not step into this unit\r\n\r\ninterface\r\n\r\nuses\r\n Windows, Messages, Types,\r\n SysUtils, Classes, Graphics, Controls, Forms, Grids,\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n JvTypes, JvThemes, JVCLVer, JvExControls;\r\n\r\ntype\r\n TJvExInplaceEdit = class(TInplaceEdit, IJvExControl)\r\n private\r\n FAboutJVCL: TJVCLAboutInfo;\r\n FHintColor: TColor;\r\n FMouseOver: Boolean;\r\n FHintWindowClass: THintWindowClass;\r\n FOnMouseEnter: TNotifyEvent;\r\n FOnMouseLeave: TNotifyEvent;\r\n FOnParentColorChanged: TNotifyEvent;\r\n function BaseWndProc(Msg: Cardinal; WParam: WPARAM = 0; LParam: LPARAM = 0): LRESULT; overload;\r\n function BaseWndProc(Msg: Cardinal; WParam: WPARAM; LParam: TObject): LRESULT; overload;\r\n function BaseWndProcEx(Msg: Cardinal; WParam: WPARAM; var StructLParam): LRESULT;\r\n protected\r\n procedure WndProc(var Msg: TMessage); override;\r\n procedure FocusChanged(AControl: TWinControl); dynamic;\r\n procedure VisibleChanged; reintroduce; dynamic;\r\n procedure EnabledChanged; reintroduce; dynamic;\r\n procedure TextChanged; reintroduce; virtual;\r\n procedure ColorChanged; reintroduce; dynamic;\r\n procedure FontChanged; reintroduce; dynamic;\r\n procedure ParentFontChanged; reintroduce; dynamic;\r\n procedure ParentColorChanged; reintroduce; dynamic;\r\n procedure ParentShowHintChanged; reintroduce; dynamic;\r\n function WantKey(Key: Integer; Shift: TShiftState): Boolean; virtual;\r\n function HintShow(var HintInfo: THintInfo): Boolean; reintroduce; dynamic;\r\n function HitTest(X, Y: Integer): Boolean; reintroduce; virtual;\r\n procedure MouseEnter(AControl: TControl); reintroduce; dynamic;\r\n procedure MouseLeave(AControl: TControl); reintroduce; dynamic;\r\n property MouseOver: Boolean read FMouseOver write FMouseOver;\r\n property HintColor: TColor read FHintColor write FHintColor default clDefault;\r\n property OnMouseEnter: TNotifyEvent read FOnMouseEnter write FOnMouseEnter;\r\n property OnMouseLeave: TNotifyEvent read FOnMouseLeave write FOnMouseLeave;\r\n property OnParentColorChange: TNotifyEvent read FOnParentColorChanged write FOnParentColorChanged;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n property HintWindowClass: THintWindowClass read FHintWindowClass write FHintWindowClass;\r\n published\r\n property AboutJVCL: TJVCLAboutInfo read FAboutJVCL write FAboutJVCL stored False;\r\n private\r\n FDotNetHighlighting: Boolean;\r\n protected\r\n procedure BoundsChanged; reintroduce; virtual;\r\n procedure CursorChanged; reintroduce; dynamic;\r\n procedure ShowingChanged; reintroduce; dynamic;\r\n procedure ShowHintChanged; reintroduce; dynamic;\r\n procedure ControlsListChanging(Control: TControl; Inserting: Boolean); reintroduce; dynamic;\r\n procedure ControlsListChanged(Control: TControl; Inserting: Boolean); reintroduce; dynamic;\r\n procedure GetDlgCode(var Code: TDlgCodes); virtual;\r\n procedure FocusSet(PrevWnd: THandle); virtual;\r\n procedure FocusKilled(NextWnd: THandle); virtual;\r\n function DoEraseBackground(Canvas: TCanvas; Param: LPARAM): Boolean; virtual;\r\n {$IFDEF JVCLThemesEnabledD6}\r\n private\r\n function GetParentBackground: Boolean;\r\n protected\r\n procedure SetParentBackground(Value: Boolean); virtual;\r\n property ParentBackground: Boolean read GetParentBackground write SetParentBackground;\r\n {$ENDIF JVCLThemesEnabledD6}\r\n published\r\n property DotNetHighlighting: Boolean read FDotNetHighlighting write FDotNetHighlighting default False;\r\n end;\r\n\r\n TJvExCustomGrid = class(TCustomGrid, IJvExControl)\r\n private\r\n FAboutJVCL: TJVCLAboutInfo;\r\n FHintColor: TColor;\r\n FMouseOver: Boolean;\r\n FHintWindowClass: THintWindowClass;\r\n FOnMouseEnter: TNotifyEvent;\r\n FOnMouseLeave: TNotifyEvent;\r\n FOnParentColorChanged: TNotifyEvent;\r\n function BaseWndProc(Msg: Cardinal; WParam: WPARAM = 0; LParam: LPARAM = 0): LRESULT; overload;\r\n function BaseWndProc(Msg: Cardinal; WParam: WPARAM; LParam: TObject): LRESULT; overload;\r\n function BaseWndProcEx(Msg: Cardinal; WParam: WPARAM; var StructLParam): LRESULT;\r\n protected\r\n procedure WndProc(var Msg: TMessage); override;\r\n procedure FocusChanged(AControl: TWinControl); dynamic;\r\n procedure VisibleChanged; reintroduce; dynamic;\r\n procedure EnabledChanged; reintroduce; dynamic;\r\n procedure TextChanged; reintroduce; virtual;\r\n procedure ColorChanged; reintroduce; dynamic;\r\n procedure FontChanged; reintroduce; dynamic;\r\n procedure ParentFontChanged; reintroduce; dynamic;\r\n procedure ParentColorChanged; reintroduce; dynamic;\r\n procedure ParentShowHintChanged; reintroduce; dynamic;\r\n function WantKey(Key: Integer; Shift: TShiftState): Boolean; virtual;\r\n function HintShow(var HintInfo: THintInfo): Boolean; reintroduce; dynamic;\r\n function HitTest(X, Y: Integer): Boolean; reintroduce; virtual;\r\n procedure MouseEnter(AControl: TControl); reintroduce; dynamic;\r\n procedure MouseLeave(AControl: TControl); reintroduce; dynamic;\r\n property MouseOver: Boolean read FMouseOver write FMouseOver;\r\n property HintColor: TColor read FHintColor write FHintColor default clDefault;\r\n property OnMouseEnter: TNotifyEvent read FOnMouseEnter write FOnMouseEnter;\r\n property OnMouseLeave: TNotifyEvent read FOnMouseLeave write FOnMouseLeave;\r\n property OnParentColorChange: TNotifyEvent read FOnParentColorChanged write FOnParentColorChanged;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n property HintWindowClass: THintWindowClass read FHintWindowClass write FHintWindowClass;\r\n published\r\n property AboutJVCL: TJVCLAboutInfo read FAboutJVCL write FAboutJVCL stored False;\r\n private\r\n FDotNetHighlighting: Boolean;\r\n protected\r\n procedure BoundsChanged; reintroduce; virtual;\r\n procedure CursorChanged; reintroduce; dynamic;\r\n procedure ShowingChanged; reintroduce; dynamic;\r\n procedure ShowHintChanged; reintroduce; dynamic;\r\n procedure ControlsListChanging(Control: TControl; Inserting: Boolean); reintroduce; dynamic;\r\n procedure ControlsListChanged(Control: TControl; Inserting: Boolean); reintroduce; dynamic;\r\n procedure GetDlgCode(var Code: TDlgCodes); virtual;\r\n procedure FocusSet(PrevWnd: THandle); virtual;\r\n procedure FocusKilled(NextWnd: THandle); virtual;\r\n function DoEraseBackground(Canvas: TCanvas; Param: LPARAM): Boolean; virtual;\r\n {$IFDEF JVCLThemesEnabledD6}\r\n private\r\n function GetParentBackground: Boolean;\r\n protected\r\n procedure SetParentBackground(Value: Boolean); virtual;\r\n property ParentBackground: Boolean read GetParentBackground write SetParentBackground;\r\n {$ENDIF JVCLThemesEnabledD6}\r\n published\r\n property DotNetHighlighting: Boolean read FDotNetHighlighting write FDotNetHighlighting default False;\r\n end;\r\n\r\n TJvExCustomDrawGrid = class(TCustomDrawGrid, IJvExControl)\r\n private\r\n FAboutJVCL: TJVCLAboutInfo;\r\n FHintColor: TColor;\r\n FMouseOver: Boolean;\r\n FHintWindowClass: THintWindowClass;\r\n FOnMouseEnter: TNotifyEvent;\r\n FOnMouseLeave: TNotifyEvent;\r\n FOnParentColorChanged: TNotifyEvent;\r\n function BaseWndProc(Msg: Cardinal; WParam: WPARAM = 0; LParam: LPARAM = 0): LRESULT; overload;\r\n function BaseWndProc(Msg: Cardinal; WParam: WPARAM; LParam: TObject): LRESULT; overload;\r\n function BaseWndProcEx(Msg: Cardinal; WParam: WPARAM; var StructLParam): LRESULT;\r\n protected\r\n procedure WndProc(var Msg: TMessage); override;\r\n procedure FocusChanged(AControl: TWinControl); dynamic;\r\n procedure VisibleChanged; reintroduce; dynamic;\r\n procedure EnabledChanged; reintroduce; dynamic;\r\n procedure TextChanged; reintroduce; virtual;\r\n procedure ColorChanged; reintroduce; dynamic;\r\n procedure FontChanged; reintroduce; dynamic;\r\n procedure ParentFontChanged; reintroduce; dynamic;\r\n procedure ParentColorChanged; reintroduce; dynamic;\r\n procedure ParentShowHintChanged; reintroduce; dynamic;\r\n function WantKey(Key: Integer; Shift: TShiftState): Boolean; virtual;\r\n function HintShow(var HintInfo: THintInfo): Boolean; reintroduce; dynamic;\r\n function HitTest(X, Y: Integer): Boolean; reintroduce; virtual;\r\n procedure MouseEnter(AControl: TControl); reintroduce; dynamic;\r\n procedure MouseLeave(AControl: TControl); reintroduce; dynamic;\r\n property MouseOver: Boolean read FMouseOver write FMouseOver;\r\n property HintColor: TColor read FHintColor write FHintColor default clDefault;\r\n property OnMouseEnter: TNotifyEvent read FOnMouseEnter write FOnMouseEnter;\r\n property OnMouseLeave: TNotifyEvent read FOnMouseLeave write FOnMouseLeave;\r\n property OnParentColorChange: TNotifyEvent read FOnParentColorChanged write FOnParentColorChanged;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n property HintWindowClass: THintWindowClass read FHintWindowClass write FHintWindowClass;\r\n published\r\n property AboutJVCL: TJVCLAboutInfo read FAboutJVCL write FAboutJVCL stored False;\r\n private\r\n FDotNetHighlighting: Boolean;\r\n protected\r\n procedure BoundsChanged; reintroduce; virtual;\r\n procedure CursorChanged; reintroduce; dynamic;\r\n procedure ShowingChanged; reintroduce; dynamic;\r\n procedure ShowHintChanged; reintroduce; dynamic;\r\n procedure ControlsListChanging(Control: TControl; Inserting: Boolean); reintroduce; dynamic;\r\n procedure ControlsListChanged(Control: TControl; Inserting: Boolean); reintroduce; dynamic;\r\n procedure GetDlgCode(var Code: TDlgCodes); virtual;\r\n procedure FocusSet(PrevWnd: THandle); virtual;\r\n procedure FocusKilled(NextWnd: THandle); virtual;\r\n function DoEraseBackground(Canvas: TCanvas; Param: LPARAM): Boolean; virtual;\r\n {$IFDEF JVCLThemesEnabledD6}\r\n private\r\n function GetParentBackground: Boolean;\r\n protected\r\n procedure SetParentBackground(Value: Boolean); virtual;\r\n property ParentBackground: Boolean read GetParentBackground write SetParentBackground;\r\n {$ENDIF JVCLThemesEnabledD6}\r\n published\r\n property DotNetHighlighting: Boolean read FDotNetHighlighting write FDotNetHighlighting default False;\r\n end;\r\n\r\n TJvExInplaceEditList = class(TInplaceEditList, IJvExControl)\r\n private\r\n FAboutJVCL: TJVCLAboutInfo;\r\n FHintColor: TColor;\r\n FMouseOver: Boolean;\r\n FHintWindowClass: THintWindowClass;\r\n FOnMouseEnter: TNotifyEvent;\r\n FOnMouseLeave: TNotifyEvent;\r\n FOnParentColorChanged: TNotifyEvent;\r\n function BaseWndProc(Msg: Cardinal; WParam: WPARAM = 0; LParam: LPARAM = 0): LRESULT; overload;\r\n function BaseWndProc(Msg: Cardinal; WParam: WPARAM; LParam: TObject): LRESULT; overload;\r\n function BaseWndProcEx(Msg: Cardinal; WParam: WPARAM; var StructLParam): LRESULT;\r\n protected\r\n procedure WndProc(var Msg: TMessage); override;\r\n procedure FocusChanged(AControl: TWinControl); dynamic;\r\n procedure VisibleChanged; reintroduce; dynamic;\r\n procedure EnabledChanged; reintroduce; dynamic;\r\n procedure TextChanged; reintroduce; virtual;\r\n procedure ColorChanged; reintroduce; dynamic;\r\n procedure FontChanged; reintroduce; dynamic;\r\n procedure ParentFontChanged; reintroduce; dynamic;\r\n procedure ParentColorChanged; reintroduce; dynamic;\r\n procedure ParentShowHintChanged; reintroduce; dynamic;\r\n function WantKey(Key: Integer; Shift: TShiftState): Boolean; virtual;\r\n function HintShow(var HintInfo: THintInfo): Boolean; reintroduce; dynamic;\r\n function HitTest(X, Y: Integer): Boolean; reintroduce; virtual;\r\n procedure MouseEnter(AControl: TControl); reintroduce; dynamic;\r\n procedure MouseLeave(AControl: TControl); reintroduce; dynamic;\r\n property MouseOver: Boolean read FMouseOver write FMouseOver;\r\n property HintColor: TColor read FHintColor write FHintColor default clDefault;\r\n property OnMouseEnter: TNotifyEvent read FOnMouseEnter write FOnMouseEnter;\r\n property OnMouseLeave: TNotifyEvent read FOnMouseLeave write FOnMouseLeave;\r\n property OnParentColorChange: TNotifyEvent read FOnParentColorChanged write FOnParentColorChanged;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n property HintWindowClass: THintWindowClass read FHintWindowClass write FHintWindowClass;\r\n published\r\n property AboutJVCL: TJVCLAboutInfo read FAboutJVCL write FAboutJVCL stored False;\r\n private\r\n FDotNetHighlighting: Boolean;\r\n protected\r\n procedure BoundsChanged; reintroduce; virtual;\r\n procedure CursorChanged; reintroduce; dynamic;\r\n procedure ShowingChanged; reintroduce; dynamic;\r\n procedure ShowHintChanged; reintroduce; dynamic;\r\n procedure ControlsListChanging(Control: TControl; Inserting: Boolean); reintroduce; dynamic;\r\n procedure ControlsListChanged(Control: TControl; Inserting: Boolean); reintroduce; dynamic;\r\n procedure GetDlgCode(var Code: TDlgCodes); virtual;\r\n procedure FocusSet(PrevWnd: THandle); virtual;\r\n procedure FocusKilled(NextWnd: THandle); virtual;\r\n function DoEraseBackground(Canvas: TCanvas; Param: LPARAM): Boolean; virtual;\r\n {$IFDEF JVCLThemesEnabledD6}\r\n private\r\n function GetParentBackground: Boolean;\r\n protected\r\n procedure SetParentBackground(Value: Boolean); virtual;\r\n property ParentBackground: Boolean read GetParentBackground write SetParentBackground;\r\n {$ENDIF JVCLThemesEnabledD6}\r\n published\r\n property DotNetHighlighting: Boolean read FDotNetHighlighting write FDotNetHighlighting default False;\r\n end;\r\n\r\n TJvExPubInplaceEditList = class(TJvExInplaceEditList)\r\n published\r\n property BiDiMode;\r\n property DragCursor;\r\n property DragKind;\r\n property DragMode;\r\n property ParentBiDiMode;\r\n property OnEndDock;\r\n property OnStartDock;\r\n end;\r\n\r\n TJvExDrawGrid = class(TDrawGrid, IJvExControl)\r\n private\r\n FAboutJVCL: TJVCLAboutInfo;\r\n FHintColor: TColor;\r\n FMouseOver: Boolean;\r\n FHintWindowClass: THintWindowClass;\r\n FOnMouseEnter: TNotifyEvent;\r\n FOnMouseLeave: TNotifyEvent;\r\n FOnParentColorChanged: TNotifyEvent;\r\n function BaseWndProc(Msg: Cardinal; WParam: WPARAM = 0; LParam: LPARAM = 0): LRESULT; overload;\r\n function BaseWndProc(Msg: Cardinal; WParam: WPARAM; LParam: TObject): LRESULT; overload;\r\n function BaseWndProcEx(Msg: Cardinal; WParam: WPARAM; var StructLParam): LRESULT;\r\n protected\r\n procedure WndProc(var Msg: TMessage); override;\r\n procedure FocusChanged(AControl: TWinControl); dynamic;\r\n procedure VisibleChanged; reintroduce; dynamic;\r\n procedure EnabledChanged; reintroduce; dynamic;\r\n procedure TextChanged; reintroduce; virtual;\r\n procedure ColorChanged; reintroduce; dynamic;\r\n procedure FontChanged; reintroduce; dynamic;\r\n procedure ParentFontChanged; reintroduce; dynamic;\r\n procedure ParentColorChanged; reintroduce; dynamic;\r\n procedure ParentShowHintChanged; reintroduce; dynamic;\r\n function WantKey(Key: Integer; Shift: TShiftState): Boolean; virtual;\r\n function HintShow(var HintInfo: THintInfo): Boolean; reintroduce; dynamic;\r\n function HitTest(X, Y: Integer): Boolean; reintroduce; virtual;\r\n procedure MouseEnter(AControl: TControl); reintroduce; dynamic;\r\n procedure MouseLeave(AControl: TControl); reintroduce; dynamic;\r\n property MouseOver: Boolean read FMouseOver write FMouseOver;\r\n property HintColor: TColor read FHintColor write FHintColor default clDefault;\r\n property OnMouseEnter: TNotifyEvent read FOnMouseEnter write FOnMouseEnter;\r\n property OnMouseLeave: TNotifyEvent read FOnMouseLeave write FOnMouseLeave;\r\n property OnParentColorChange: TNotifyEvent read FOnParentColorChanged write FOnParentColorChanged;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n property HintWindowClass: THintWindowClass read FHintWindowClass write FHintWindowClass;\r\n published\r\n property AboutJVCL: TJVCLAboutInfo read FAboutJVCL write FAboutJVCL stored False;\r\n private\r\n FDotNetHighlighting: Boolean;\r\n protected\r\n procedure BoundsChanged; reintroduce; virtual;\r\n procedure CursorChanged; reintroduce; dynamic;\r\n procedure ShowingChanged; reintroduce; dynamic;\r\n procedure ShowHintChanged; reintroduce; dynamic;\r\n procedure ControlsListChanging(Control: TControl; Inserting: Boolean); reintroduce; dynamic;\r\n procedure ControlsListChanged(Control: TControl; Inserting: Boolean); reintroduce; dynamic;\r\n procedure GetDlgCode(var Code: TDlgCodes); virtual;\r\n procedure FocusSet(PrevWnd: THandle); virtual;\r\n procedure FocusKilled(NextWnd: THandle); virtual;\r\n function DoEraseBackground(Canvas: TCanvas; Param: LPARAM): Boolean; virtual;\r\n {$IFDEF JVCLThemesEnabledD6}\r\n private\r\n function GetParentBackground: Boolean;\r\n protected\r\n procedure SetParentBackground(Value: Boolean); virtual;\r\n property ParentBackground: Boolean read GetParentBackground write SetParentBackground;\r\n {$ENDIF JVCLThemesEnabledD6}\r\n published\r\n property DotNetHighlighting: Boolean read FDotNetHighlighting write FDotNetHighlighting default False;\r\n end;\r\n\r\n TJvExStringGrid = class(TStringGrid, IJvExControl)\r\n private\r\n FAboutJVCL: TJVCLAboutInfo;\r\n FHintColor: TColor;\r\n FMouseOver: Boolean;\r\n FHintWindowClass: THintWindowClass;\r\n FOnMouseEnter: TNotifyEvent;\r\n FOnMouseLeave: TNotifyEvent;\r\n FOnParentColorChanged: TNotifyEvent;\r\n function BaseWndProc(Msg: Cardinal; WParam: WPARAM = 0; LParam: LPARAM = 0): LRESULT; overload;\r\n function BaseWndProc(Msg: Cardinal; WParam: WPARAM; LParam: TObject): LRESULT; overload;\r\n function BaseWndProcEx(Msg: Cardinal; WParam: WPARAM; var StructLParam): LRESULT;\r\n protected\r\n procedure WndProc(var Msg: TMessage); override;\r\n procedure FocusChanged(AControl: TWinControl); dynamic;\r\n procedure VisibleChanged; reintroduce; dynamic;\r\n procedure EnabledChanged; reintroduce; dynamic;\r\n procedure TextChanged; reintroduce; virtual;\r\n procedure ColorChanged; reintroduce; dynamic;\r\n procedure FontChanged; reintroduce; dynamic;\r\n procedure ParentFontChanged; reintroduce; dynamic;\r\n procedure ParentColorChanged; reintroduce; dynamic;\r\n procedure ParentShowHintChanged; reintroduce; dynamic;\r\n function WantKey(Key: Integer; Shift: TShiftState): Boolean; virtual;\r\n function HintShow(var HintInfo: THintInfo): Boolean; reintroduce; dynamic;\r\n function HitTest(X, Y: Integer): Boolean; reintroduce; virtual;\r\n procedure MouseEnter(AControl: TControl); reintroduce; dynamic;\r\n procedure MouseLeave(AControl: TControl); reintroduce; dynamic;\r\n property MouseOver: Boolean read FMouseOver write FMouseOver;\r\n property HintColor: TColor read FHintColor write FHintColor default clDefault;\r\n property GridState: TGridState read FGridState;\r\n property OnMouseEnter: TNotifyEvent read FOnMouseEnter write FOnMouseEnter;\r\n property OnMouseLeave: TNotifyEvent read FOnMouseLeave write FOnMouseLeave;\r\n property OnParentColorChange: TNotifyEvent read FOnParentColorChanged write FOnParentColorChanged;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n property HintWindowClass: THintWindowClass read FHintWindowClass write FHintWindowClass;\r\n published\r\n property AboutJVCL: TJVCLAboutInfo read FAboutJVCL write FAboutJVCL stored False;\r\n private\r\n FDotNetHighlighting: Boolean;\r\n protected\r\n procedure BoundsChanged; reintroduce; virtual;\r\n procedure CursorChanged; reintroduce; dynamic;\r\n procedure ShowingChanged; reintroduce; dynamic;\r\n procedure ShowHintChanged; reintroduce; dynamic;\r\n procedure ControlsListChanging(Control: TControl; Inserting: Boolean); reintroduce; dynamic;\r\n procedure ControlsListChanged(Control: TControl; Inserting: Boolean); reintroduce; dynamic;\r\n procedure GetDlgCode(var Code: TDlgCodes); virtual;\r\n procedure FocusSet(PrevWnd: THandle); virtual;\r\n procedure FocusKilled(NextWnd: THandle); virtual;\r\n function DoEraseBackground(Canvas: TCanvas; Param: LPARAM): Boolean; virtual;\r\n {$IFDEF JVCLThemesEnabledD6}\r\n private\r\n function GetParentBackground: Boolean;\r\n protected\r\n procedure SetParentBackground(Value: Boolean); virtual;\r\n property ParentBackground: Boolean read GetParentBackground write SetParentBackground;\r\n {$ENDIF JVCLThemesEnabledD6}\r\n published\r\n property DotNetHighlighting: Boolean read FDotNetHighlighting write FDotNetHighlighting default False;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvExGrids.pas $';\r\n Revision: '$Revision: 13221 $';\r\n Date: '$Date: 2012-02-24 15:12:04 +0100 (ven. 24 févr. 2012) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nconstructor TJvExInplaceEdit.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FHintColor := clDefault;\r\nend;\r\n\r\nfunction TJvExInplaceEdit.BaseWndProc(Msg: Cardinal; WParam: WPARAM = 0; LParam: LPARAM = 0): LRESULT;\r\nvar\r\n Mesg: TMessage;\r\nbegin\r\n CreateWMMessage(Mesg, Msg, WParam, LParam);\r\n inherited WndProc(Mesg);\r\n Result := Mesg.Result;\r\nend;\r\n\r\nfunction TJvExInplaceEdit.BaseWndProc(Msg: Cardinal; WParam: WPARAM; LParam: TObject): LRESULT;\r\nbegin\r\n Result := BaseWndProc(Msg, WParam, Windows.LPARAM(LParam));\r\nend;\r\n\r\nfunction TJvExInplaceEdit.BaseWndProcEx(Msg: Cardinal; WParam: WPARAM; var StructLParam): LRESULT;\r\nbegin\r\n Result := BaseWndProc(Msg, WParam, Windows.LPARAM(@StructLParam));\r\nend;\r\n\r\nprocedure TJvExInplaceEdit.VisibleChanged;\r\nbegin\r\n BaseWndProc(CM_VISIBLECHANGED);\r\nend;\r\n\r\nprocedure TJvExInplaceEdit.EnabledChanged;\r\nbegin\r\n BaseWndProc(CM_ENABLEDCHANGED);\r\nend;\r\n\r\nprocedure TJvExInplaceEdit.TextChanged;\r\nbegin\r\n BaseWndProc(CM_TEXTCHANGED);\r\nend;\r\n\r\nprocedure TJvExInplaceEdit.FontChanged;\r\nbegin\r\n BaseWndProc(CM_FONTCHANGED);\r\nend;\r\n\r\nprocedure TJvExInplaceEdit.ColorChanged;\r\nbegin\r\n BaseWndProc(CM_COLORCHANGED);\r\nend;\r\n\r\nprocedure TJvExInplaceEdit.ParentFontChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTFONTCHANGED);\r\nend;\r\n\r\nprocedure TJvExInplaceEdit.ParentColorChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTCOLORCHANGED);\r\n if Assigned(OnParentColorChange) then\r\n OnParentColorChange(Self);\r\nend;\r\n\r\nprocedure TJvExInplaceEdit.ParentShowHintChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTSHOWHINTCHANGED);\r\nend;\r\n\r\nfunction TJvExInplaceEdit.WantKey(Key: Integer; Shift: TShiftState): Boolean;\r\nbegin\r\n Result := BaseWndProc(CM_DIALOGCHAR, Word(Key), ShiftStateToKeyData(Shift)) <> 0;\r\nend;\r\n\r\nfunction TJvExInplaceEdit.HitTest(X, Y: Integer): Boolean;\r\nbegin\r\n Result := BaseWndProc(CM_HITTEST, 0, SmallPointToLong(PointToSmallPoint(Point(X, Y)))) <> 0;\r\nend;\r\n\r\nfunction TJvExInplaceEdit.HintShow(var HintInfo: THintInfo): Boolean;\r\nbegin\r\n GetHintColor(HintInfo, Self, FHintColor);\r\n if FHintWindowClass <> nil then\r\n HintInfo.HintWindowClass := FHintWindowClass;\r\n Result := BaseWndProcEx(CM_HINTSHOW, 0, HintInfo) <> 0;\r\nend;\r\n\r\nprocedure TJvExInplaceEdit.MouseEnter(AControl: TControl);\r\nbegin\r\n FMouseOver := True;\r\n if Assigned(FOnMouseEnter) then\r\n FOnMouseEnter(Self);\r\n BaseWndProc(CM_MOUSEENTER, 0, AControl);\r\nend;\r\n\r\nprocedure TJvExInplaceEdit.MouseLeave(AControl: TControl);\r\nbegin\r\n FMouseOver := False;\r\n BaseWndProc(CM_MOUSELEAVE, 0, AControl);\r\n if Assigned(FOnMouseLeave) then\r\n FOnMouseLeave(Self);\r\nend;\r\n\r\nprocedure TJvExInplaceEdit.FocusChanged(AControl: TWinControl);\r\nbegin\r\n BaseWndProc(CM_FOCUSCHANGED, 0, AControl);\r\nend;\r\n\r\nprocedure TJvExInplaceEdit.BoundsChanged;\r\nbegin\r\nend;\r\n\r\nprocedure TJvExInplaceEdit.CursorChanged;\r\nbegin\r\n BaseWndProc(CM_CURSORCHANGED);\r\nend;\r\n\r\nprocedure TJvExInplaceEdit.ShowingChanged;\r\nbegin\r\n BaseWndProc(CM_SHOWINGCHANGED);\r\nend;\r\n\r\nprocedure TJvExInplaceEdit.ShowHintChanged;\r\nbegin\r\n BaseWndProc(CM_SHOWHINTCHANGED);\r\nend;\r\n\r\n{ VCL sends CM_CONTROLLISTCHANGE and CM_CONTROLCHANGE in a different order than\r\n the CLX methods are used. So we must correct it by evaluating \"Inserting\". }\r\nprocedure TJvExInplaceEdit.ControlsListChanging(Control: TControl; Inserting: Boolean);\r\nbegin\r\n if Inserting then\r\n BaseWndProc(CM_CONTROLLISTCHANGE, WPARAM(Control), LPARAM(Inserting))\r\n else\r\n BaseWndProc(CM_CONTROLCHANGE, WPARAM(Control), LPARAM(Inserting));\r\nend;\r\n\r\nprocedure TJvExInplaceEdit.ControlsListChanged(Control: TControl; Inserting: Boolean);\r\nbegin\r\n if not Inserting then\r\n BaseWndProc(CM_CONTROLLISTCHANGE, WPARAM(Control), LPARAM(Inserting))\r\n else\r\n BaseWndProc(CM_CONTROLCHANGE, WPARAM(Control), LPARAM(Inserting));\r\nend;\r\n\r\nprocedure TJvExInplaceEdit.GetDlgCode(var Code: TDlgCodes);\r\nbegin\r\nend;\r\n\r\nprocedure TJvExInplaceEdit.FocusSet(PrevWnd: THandle);\r\nbegin\r\n BaseWndProc(WM_SETFOCUS, WPARAM(PrevWnd), 0);\r\nend;\r\n\r\nprocedure TJvExInplaceEdit.FocusKilled(NextWnd: THandle);\r\nbegin\r\n BaseWndProc(WM_KILLFOCUS, WPARAM(NextWnd), 0);\r\nend;\r\n\r\nfunction TJvExInplaceEdit.DoEraseBackground(Canvas: TCanvas; Param: LPARAM): Boolean;\r\nbegin\r\n Result := BaseWndProc(WM_ERASEBKGND, Canvas.Handle, Param) <> 0;\r\nend;\r\n\r\n{$IFDEF JVCLThemesEnabledD6}\r\nfunction TJvExInplaceEdit.GetParentBackground: Boolean;\r\nbegin\r\n Result := JvThemes.GetParentBackground(Self);\r\nend;\r\n\r\nprocedure TJvExInplaceEdit.SetParentBackground(Value: Boolean);\r\nbegin\r\n JvThemes.SetParentBackground(Self, Value);\r\nend;\r\n{$ENDIF JVCLThemesEnabledD6}\r\n\r\nprocedure TJvExInplaceEdit.WndProc(var Msg: TMessage);\r\nvar\r\n IdSaveDC: Integer;\r\n DlgCodes: TDlgCodes;\r\n Canvas: TCanvas;\r\nbegin\r\n if not DispatchIsDesignMsg(Self, Msg) then\r\n begin\r\n case Msg.Msg of\r\n CM_DENYSUBCLASSING:\r\n Msg.Result := LRESULT(Ord(GetInterfaceEntry(IJvDenySubClassing) <> nil));\r\n CM_DIALOGCHAR:\r\n with TCMDialogChar{$IFDEF CLR}.Create{$ENDIF}(Msg) do\r\n Result := LRESULT(Ord(WantKey(CharCode, KeyDataToShiftState(KeyData))));\r\n CM_HINTSHOW:\r\n with TCMHintShow(Msg) do\r\n Result := LRESULT(HintShow(HintInfo^));\r\n CM_HITTEST:\r\n with TCMHitTest(Msg) do\r\n Result := LRESULT(HitTest(XPos, YPos));\r\n CM_MOUSEENTER:\r\n MouseEnter(TControl(Msg.LParam));\r\n CM_MOUSELEAVE:\r\n MouseLeave(TControl(Msg.LParam));\r\n CM_VISIBLECHANGED:\r\n VisibleChanged;\r\n CM_ENABLEDCHANGED:\r\n EnabledChanged;\r\n CM_TEXTCHANGED:\r\n TextChanged;\r\n CM_FONTCHANGED:\r\n FontChanged;\r\n CM_COLORCHANGED:\r\n ColorChanged;\r\n CM_FOCUSCHANGED:\r\n FocusChanged(TWinControl(Msg.LParam));\r\n CM_PARENTFONTCHANGED:\r\n ParentFontChanged;\r\n CM_PARENTCOLORCHANGED:\r\n ParentColorChanged;\r\n CM_PARENTSHOWHINTCHANGED:\r\n ParentShowHintChanged;\r\n CM_CURSORCHANGED:\r\n CursorChanged;\r\n CM_SHOWINGCHANGED:\r\n ShowingChanged;\r\n CM_SHOWHINTCHANGED:\r\n ShowHintChanged;\r\n CM_CONTROLLISTCHANGE:\r\n if Msg.LParam <> 0 then\r\n ControlsListChanging(TControl(Msg.WParam), True)\r\n else\r\n ControlsListChanged(TControl(Msg.WParam), False);\r\n CM_CONTROLCHANGE:\r\n if Msg.LParam = 0 then\r\n ControlsListChanging(TControl(Msg.WParam), False)\r\n else\r\n ControlsListChanged(TControl(Msg.WParam), True);\r\n WM_SETFOCUS:\r\n FocusSet(THandle(Msg.WParam));\r\n WM_KILLFOCUS:\r\n FocusKilled(THandle(Msg.WParam));\r\n WM_SIZE, WM_MOVE:\r\n begin\r\n inherited WndProc(Msg);\r\n BoundsChanged;\r\n end;\r\n WM_ERASEBKGND:\r\n if (Msg.WParam <> 0) and not IsDefaultEraseBackground(DoEraseBackground, @TJvExInplaceEdit.DoEraseBackground) then\r\n begin\r\n IdSaveDC := SaveDC(HDC(Msg.WParam)); // protect DC against Stock-Objects from Canvas\r\n Canvas := TCanvas.Create;\r\n try\r\n Canvas.Handle := HDC(Msg.WParam);\r\n Msg.Result := Ord(DoEraseBackground(Canvas, Msg.LParam));\r\n finally\r\n Canvas.Handle := 0;\r\n Canvas.Free;\r\n RestoreDC(HDC(Msg.WParam), IdSaveDC);\r\n end;\r\n end\r\n else\r\n inherited WndProc(Msg);\r\n {$IFNDEF DELPHI2007_UP}\r\n WM_PRINTCLIENT, WM_PRINT: // VCL bug fix\r\n begin\r\n IdSaveDC := SaveDC(HDC(Msg.WParam)); // protect DC against changes\r\n try\r\n inherited WndProc(Msg);\r\n finally\r\n RestoreDC(HDC(Msg.WParam), IdSaveDC);\r\n end;\r\n end;\r\n {$ENDIF ~DELPHI2007_UP}\r\n WM_GETDLGCODE:\r\n begin\r\n inherited WndProc(Msg);\r\n DlgCodes := [dcNative] + DlgcToDlgCodes(Msg.Result);\r\n GetDlgCode(DlgCodes);\r\n if not (dcNative in DlgCodes) then\r\n Msg.Result := DlgCodesToDlgc(DlgCodes);\r\n end;\r\n else\r\n inherited WndProc(Msg);\r\n end;\r\n case Msg.Msg of // precheck message to prevent access violations on released controls\r\n CM_MOUSEENTER, CM_MOUSELEAVE, WM_KILLFOCUS, WM_SETFOCUS, WM_NCPAINT:\r\n if DotNetHighlighting then\r\n HandleDotNetHighlighting(Self, Msg, MouseOver, Color);\r\n end;\r\n end;\r\nend;\r\n\r\n//============================================================================\r\n\r\nconstructor TJvExCustomGrid.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FHintColor := clDefault;\r\nend;\r\n\r\nfunction TJvExCustomGrid.BaseWndProc(Msg: Cardinal; WParam: WPARAM = 0; LParam: LPARAM = 0): LRESULT;\r\nvar\r\n Mesg: TMessage;\r\nbegin\r\n CreateWMMessage(Mesg, Msg, WParam, LParam);\r\n inherited WndProc(Mesg);\r\n Result := Mesg.Result;\r\nend;\r\n\r\nfunction TJvExCustomGrid.BaseWndProc(Msg: Cardinal; WParam: WPARAM; LParam: TObject): LRESULT;\r\nbegin\r\n Result := BaseWndProc(Msg, WParam, Windows.LPARAM(LParam));\r\nend;\r\n\r\nfunction TJvExCustomGrid.BaseWndProcEx(Msg: Cardinal; WParam: WPARAM; var StructLParam): LRESULT;\r\nbegin\r\n Result := BaseWndProc(Msg, WParam, Windows.LPARAM(@StructLParam));\r\nend;\r\n\r\nprocedure TJvExCustomGrid.VisibleChanged;\r\nbegin\r\n BaseWndProc(CM_VISIBLECHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomGrid.EnabledChanged;\r\nbegin\r\n BaseWndProc(CM_ENABLEDCHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomGrid.TextChanged;\r\nbegin\r\n BaseWndProc(CM_TEXTCHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomGrid.FontChanged;\r\nbegin\r\n BaseWndProc(CM_FONTCHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomGrid.ColorChanged;\r\nbegin\r\n BaseWndProc(CM_COLORCHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomGrid.ParentFontChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTFONTCHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomGrid.ParentColorChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTCOLORCHANGED);\r\n if Assigned(OnParentColorChange) then\r\n OnParentColorChange(Self);\r\nend;\r\n\r\nprocedure TJvExCustomGrid.ParentShowHintChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTSHOWHINTCHANGED);\r\nend;\r\n\r\nfunction TJvExCustomGrid.WantKey(Key: Integer; Shift: TShiftState): Boolean;\r\nbegin\r\n Result := BaseWndProc(CM_DIALOGCHAR, Word(Key), ShiftStateToKeyData(Shift)) <> 0;\r\nend;\r\n\r\nfunction TJvExCustomGrid.HitTest(X, Y: Integer): Boolean;\r\nbegin\r\n Result := BaseWndProc(CM_HITTEST, 0, SmallPointToLong(PointToSmallPoint(Point(X, Y)))) <> 0;\r\nend;\r\n\r\nfunction TJvExCustomGrid.HintShow(var HintInfo: THintInfo): Boolean;\r\nbegin\r\n GetHintColor(HintInfo, Self, FHintColor);\r\n if FHintWindowClass <> nil then\r\n HintInfo.HintWindowClass := FHintWindowClass;\r\n Result := BaseWndProcEx(CM_HINTSHOW, 0, HintInfo) <> 0;\r\nend;\r\n\r\nprocedure TJvExCustomGrid.MouseEnter(AControl: TControl);\r\nbegin\r\n FMouseOver := True;\r\n if Assigned(FOnMouseEnter) then\r\n FOnMouseEnter(Self);\r\n BaseWndProc(CM_MOUSEENTER, 0, AControl);\r\nend;\r\n\r\nprocedure TJvExCustomGrid.MouseLeave(AControl: TControl);\r\nbegin\r\n FMouseOver := False;\r\n BaseWndProc(CM_MOUSELEAVE, 0, AControl);\r\n if Assigned(FOnMouseLeave) then\r\n FOnMouseLeave(Self);\r\nend;\r\n\r\nprocedure TJvExCustomGrid.FocusChanged(AControl: TWinControl);\r\nbegin\r\n BaseWndProc(CM_FOCUSCHANGED, 0, AControl);\r\nend;\r\n\r\nprocedure TJvExCustomGrid.BoundsChanged;\r\nbegin\r\nend;\r\n\r\nprocedure TJvExCustomGrid.CursorChanged;\r\nbegin\r\n BaseWndProc(CM_CURSORCHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomGrid.ShowingChanged;\r\nbegin\r\n BaseWndProc(CM_SHOWINGCHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomGrid.ShowHintChanged;\r\nbegin\r\n BaseWndProc(CM_SHOWHINTCHANGED);\r\nend;\r\n\r\n{ VCL sends CM_CONTROLLISTCHANGE and CM_CONTROLCHANGE in a different order than\r\n the CLX methods are used. So we must correct it by evaluating \"Inserting\". }\r\nprocedure TJvExCustomGrid.ControlsListChanging(Control: TControl; Inserting: Boolean);\r\nbegin\r\n if Inserting then\r\n BaseWndProc(CM_CONTROLLISTCHANGE, WPARAM(Control), LPARAM(Inserting))\r\n else\r\n BaseWndProc(CM_CONTROLCHANGE, WPARAM(Control), LPARAM(Inserting));\r\nend;\r\n\r\nprocedure TJvExCustomGrid.ControlsListChanged(Control: TControl; Inserting: Boolean);\r\nbegin\r\n if not Inserting then\r\n BaseWndProc(CM_CONTROLLISTCHANGE, WPARAM(Control), LPARAM(Inserting))\r\n else\r\n BaseWndProc(CM_CONTROLCHANGE, WPARAM(Control), LPARAM(Inserting));\r\nend;\r\n\r\nprocedure TJvExCustomGrid.GetDlgCode(var Code: TDlgCodes);\r\nbegin\r\nend;\r\n\r\nprocedure TJvExCustomGrid.FocusSet(PrevWnd: THandle);\r\nbegin\r\n BaseWndProc(WM_SETFOCUS, WPARAM(PrevWnd), 0);\r\nend;\r\n\r\nprocedure TJvExCustomGrid.FocusKilled(NextWnd: THandle);\r\nbegin\r\n BaseWndProc(WM_KILLFOCUS, WPARAM(NextWnd), 0);\r\nend;\r\n\r\nfunction TJvExCustomGrid.DoEraseBackground(Canvas: TCanvas; Param: LPARAM): Boolean;\r\nbegin\r\n Result := BaseWndProc(WM_ERASEBKGND, Canvas.Handle, Param) <> 0;\r\nend;\r\n\r\n{$IFDEF JVCLThemesEnabledD6}\r\nfunction TJvExCustomGrid.GetParentBackground: Boolean;\r\nbegin\r\n Result := JvThemes.GetParentBackground(Self);\r\nend;\r\n\r\nprocedure TJvExCustomGrid.SetParentBackground(Value: Boolean);\r\nbegin\r\n JvThemes.SetParentBackground(Self, Value);\r\nend;\r\n{$ENDIF JVCLThemesEnabledD6}\r\n\r\nprocedure TJvExCustomGrid.WndProc(var Msg: TMessage);\r\nvar\r\n IdSaveDC: Integer;\r\n DlgCodes: TDlgCodes;\r\n Canvas: TCanvas;\r\nbegin\r\n if not DispatchIsDesignMsg(Self, Msg) then\r\n begin\r\n case Msg.Msg of\r\n CM_DENYSUBCLASSING:\r\n Msg.Result := LRESULT(Ord(GetInterfaceEntry(IJvDenySubClassing) <> nil));\r\n CM_DIALOGCHAR:\r\n with TCMDialogChar{$IFDEF CLR}.Create{$ENDIF}(Msg) do\r\n Result := LRESULT(Ord(WantKey(CharCode, KeyDataToShiftState(KeyData))));\r\n CM_HINTSHOW:\r\n with TCMHintShow(Msg) do\r\n Result := LRESULT(HintShow(HintInfo^));\r\n CM_HITTEST:\r\n with TCMHitTest(Msg) do\r\n Result := LRESULT(HitTest(XPos, YPos));\r\n CM_MOUSEENTER:\r\n MouseEnter(TControl(Msg.LParam));\r\n CM_MOUSELEAVE:\r\n MouseLeave(TControl(Msg.LParam));\r\n CM_VISIBLECHANGED:\r\n VisibleChanged;\r\n CM_ENABLEDCHANGED:\r\n EnabledChanged;\r\n CM_TEXTCHANGED:\r\n TextChanged;\r\n CM_FONTCHANGED:\r\n FontChanged;\r\n CM_COLORCHANGED:\r\n ColorChanged;\r\n CM_FOCUSCHANGED:\r\n FocusChanged(TWinControl(Msg.LParam));\r\n CM_PARENTFONTCHANGED:\r\n ParentFontChanged;\r\n CM_PARENTCOLORCHANGED:\r\n ParentColorChanged;\r\n CM_PARENTSHOWHINTCHANGED:\r\n ParentShowHintChanged;\r\n CM_CURSORCHANGED:\r\n CursorChanged;\r\n CM_SHOWINGCHANGED:\r\n ShowingChanged;\r\n CM_SHOWHINTCHANGED:\r\n ShowHintChanged;\r\n CM_CONTROLLISTCHANGE:\r\n if Msg.LParam <> 0 then\r\n ControlsListChanging(TControl(Msg.WParam), True)\r\n else\r\n ControlsListChanged(TControl(Msg.WParam), False);\r\n CM_CONTROLCHANGE:\r\n if Msg.LParam = 0 then\r\n ControlsListChanging(TControl(Msg.WParam), False)\r\n else\r\n ControlsListChanged(TControl(Msg.WParam), True);\r\n WM_SETFOCUS:\r\n FocusSet(THandle(Msg.WParam));\r\n WM_KILLFOCUS:\r\n FocusKilled(THandle(Msg.WParam));\r\n WM_SIZE, WM_MOVE:\r\n begin\r\n inherited WndProc(Msg);\r\n BoundsChanged;\r\n end;\r\n WM_ERASEBKGND:\r\n if (Msg.WParam <> 0) and not IsDefaultEraseBackground(DoEraseBackground, @TJvExCustomGrid.DoEraseBackground) then\r\n begin\r\n IdSaveDC := SaveDC(HDC(Msg.WParam)); // protect DC against Stock-Objects from Canvas\r\n Canvas := TCanvas.Create;\r\n try\r\n Canvas.Handle := HDC(Msg.WParam);\r\n Msg.Result := Ord(DoEraseBackground(Canvas, Msg.LParam));\r\n finally\r\n Canvas.Handle := 0;\r\n Canvas.Free;\r\n RestoreDC(HDC(Msg.WParam), IdSaveDC);\r\n end;\r\n end\r\n else\r\n inherited WndProc(Msg);\r\n {$IFNDEF DELPHI2007_UP}\r\n WM_PRINTCLIENT, WM_PRINT: // VCL bug fix\r\n begin\r\n IdSaveDC := SaveDC(HDC(Msg.WParam)); // protect DC against changes\r\n try\r\n inherited WndProc(Msg);\r\n finally\r\n RestoreDC(HDC(Msg.WParam), IdSaveDC);\r\n end;\r\n end;\r\n {$ENDIF ~DELPHI2007_UP}\r\n WM_GETDLGCODE:\r\n begin\r\n inherited WndProc(Msg);\r\n DlgCodes := [dcNative] + DlgcToDlgCodes(Msg.Result);\r\n GetDlgCode(DlgCodes);\r\n if not (dcNative in DlgCodes) then\r\n Msg.Result := DlgCodesToDlgc(DlgCodes);\r\n end;\r\n else\r\n inherited WndProc(Msg);\r\n end;\r\n case Msg.Msg of // precheck message to prevent access violations on released controls\r\n CM_MOUSEENTER, CM_MOUSELEAVE, WM_KILLFOCUS, WM_SETFOCUS, WM_NCPAINT:\r\n if DotNetHighlighting then\r\n HandleDotNetHighlighting(Self, Msg, MouseOver, Color);\r\n end;\r\n end;\r\nend;\r\n\r\n//============================================================================\r\n\r\nconstructor TJvExCustomDrawGrid.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FHintColor := clDefault;\r\nend;\r\n\r\nfunction TJvExCustomDrawGrid.BaseWndProc(Msg: Cardinal; WParam: WPARAM = 0; LParam: LPARAM = 0): LRESULT;\r\nvar\r\n Mesg: TMessage;\r\nbegin\r\n CreateWMMessage(Mesg, Msg, WParam, LParam);\r\n inherited WndProc(Mesg);\r\n Result := Mesg.Result;\r\nend;\r\n\r\nfunction TJvExCustomDrawGrid.BaseWndProc(Msg: Cardinal; WParam: WPARAM; LParam: TObject): LRESULT;\r\nbegin\r\n Result := BaseWndProc(Msg, WParam, Windows.LPARAM(LParam));\r\nend;\r\n\r\nfunction TJvExCustomDrawGrid.BaseWndProcEx(Msg: Cardinal; WParam: WPARAM; var StructLParam): LRESULT;\r\nbegin\r\n Result := BaseWndProc(Msg, WParam, Windows.LPARAM(@StructLParam));\r\nend;\r\n\r\nprocedure TJvExCustomDrawGrid.VisibleChanged;\r\nbegin\r\n BaseWndProc(CM_VISIBLECHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomDrawGrid.EnabledChanged;\r\nbegin\r\n BaseWndProc(CM_ENABLEDCHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomDrawGrid.TextChanged;\r\nbegin\r\n BaseWndProc(CM_TEXTCHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomDrawGrid.FontChanged;\r\nbegin\r\n BaseWndProc(CM_FONTCHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomDrawGrid.ColorChanged;\r\nbegin\r\n BaseWndProc(CM_COLORCHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomDrawGrid.ParentFontChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTFONTCHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomDrawGrid.ParentColorChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTCOLORCHANGED);\r\n if Assigned(OnParentColorChange) then\r\n OnParentColorChange(Self);\r\nend;\r\n\r\nprocedure TJvExCustomDrawGrid.ParentShowHintChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTSHOWHINTCHANGED);\r\nend;\r\n\r\nfunction TJvExCustomDrawGrid.WantKey(Key: Integer; Shift: TShiftState): Boolean;\r\nbegin\r\n Result := BaseWndProc(CM_DIALOGCHAR, Word(Key), ShiftStateToKeyData(Shift)) <> 0;\r\nend;\r\n\r\nfunction TJvExCustomDrawGrid.HitTest(X, Y: Integer): Boolean;\r\nbegin\r\n Result := BaseWndProc(CM_HITTEST, 0, SmallPointToLong(PointToSmallPoint(Point(X, Y)))) <> 0;\r\nend;\r\n\r\nfunction TJvExCustomDrawGrid.HintShow(var HintInfo: THintInfo): Boolean;\r\nbegin\r\n GetHintColor(HintInfo, Self, FHintColor);\r\n if FHintWindowClass <> nil then\r\n HintInfo.HintWindowClass := FHintWindowClass;\r\n Result := BaseWndProcEx(CM_HINTSHOW, 0, HintInfo) <> 0;\r\nend;\r\n\r\nprocedure TJvExCustomDrawGrid.MouseEnter(AControl: TControl);\r\nbegin\r\n FMouseOver := True;\r\n if Assigned(FOnMouseEnter) then\r\n FOnMouseEnter(Self);\r\n BaseWndProc(CM_MOUSEENTER, 0, AControl);\r\nend;\r\n\r\nprocedure TJvExCustomDrawGrid.MouseLeave(AControl: TControl);\r\nbegin\r\n FMouseOver := False;\r\n BaseWndProc(CM_MOUSELEAVE, 0, AControl);\r\n if Assigned(FOnMouseLeave) then\r\n FOnMouseLeave(Self);\r\nend;\r\n\r\nprocedure TJvExCustomDrawGrid.FocusChanged(AControl: TWinControl);\r\nbegin\r\n BaseWndProc(CM_FOCUSCHANGED, 0, AControl);\r\nend;\r\n\r\nprocedure TJvExCustomDrawGrid.BoundsChanged;\r\nbegin\r\nend;\r\n\r\nprocedure TJvExCustomDrawGrid.CursorChanged;\r\nbegin\r\n BaseWndProc(CM_CURSORCHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomDrawGrid.ShowingChanged;\r\nbegin\r\n BaseWndProc(CM_SHOWINGCHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomDrawGrid.ShowHintChanged;\r\nbegin\r\n BaseWndProc(CM_SHOWHINTCHANGED);\r\nend;\r\n\r\n{ VCL sends CM_CONTROLLISTCHANGE and CM_CONTROLCHANGE in a different order than\r\n the CLX methods are used. So we must correct it by evaluating \"Inserting\". }\r\nprocedure TJvExCustomDrawGrid.ControlsListChanging(Control: TControl; Inserting: Boolean);\r\nbegin\r\n if Inserting then\r\n BaseWndProc(CM_CONTROLLISTCHANGE, WPARAM(Control), LPARAM(Inserting))\r\n else\r\n BaseWndProc(CM_CONTROLCHANGE, WPARAM(Control), LPARAM(Inserting));\r\nend;\r\n\r\nprocedure TJvExCustomDrawGrid.ControlsListChanged(Control: TControl; Inserting: Boolean);\r\nbegin\r\n if not Inserting then\r\n BaseWndProc(CM_CONTROLLISTCHANGE, WPARAM(Control), LPARAM(Inserting))\r\n else\r\n BaseWndProc(CM_CONTROLCHANGE, WPARAM(Control), LPARAM(Inserting));\r\nend;\r\n\r\nprocedure TJvExCustomDrawGrid.GetDlgCode(var Code: TDlgCodes);\r\nbegin\r\nend;\r\n\r\nprocedure TJvExCustomDrawGrid.FocusSet(PrevWnd: THandle);\r\nbegin\r\n BaseWndProc(WM_SETFOCUS, WPARAM(PrevWnd), 0);\r\nend;\r\n\r\nprocedure TJvExCustomDrawGrid.FocusKilled(NextWnd: THandle);\r\nbegin\r\n BaseWndProc(WM_KILLFOCUS, WPARAM(NextWnd), 0);\r\nend;\r\n\r\nfunction TJvExCustomDrawGrid.DoEraseBackground(Canvas: TCanvas; Param: LPARAM): Boolean;\r\nbegin\r\n Result := BaseWndProc(WM_ERASEBKGND, Canvas.Handle, Param) <> 0;\r\nend;\r\n\r\n{$IFDEF JVCLThemesEnabledD6}\r\nfunction TJvExCustomDrawGrid.GetParentBackground: Boolean;\r\nbegin\r\n Result := JvThemes.GetParentBackground(Self);\r\nend;\r\n\r\nprocedure TJvExCustomDrawGrid.SetParentBackground(Value: Boolean);\r\nbegin\r\n JvThemes.SetParentBackground(Self, Value);\r\nend;\r\n{$ENDIF JVCLThemesEnabledD6}\r\n\r\nprocedure TJvExCustomDrawGrid.WndProc(var Msg: TMessage);\r\nvar\r\n IdSaveDC: Integer;\r\n DlgCodes: TDlgCodes;\r\n Canvas: TCanvas;\r\nbegin\r\n if not DispatchIsDesignMsg(Self, Msg) then\r\n begin\r\n case Msg.Msg of\r\n CM_DENYSUBCLASSING:\r\n Msg.Result := LRESULT(Ord(GetInterfaceEntry(IJvDenySubClassing) <> nil));\r\n CM_DIALOGCHAR:\r\n with TCMDialogChar{$IFDEF CLR}.Create{$ENDIF}(Msg) do\r\n Result := LRESULT(Ord(WantKey(CharCode, KeyDataToShiftState(KeyData))));\r\n CM_HINTSHOW:\r\n with TCMHintShow(Msg) do\r\n Result := LRESULT(HintShow(HintInfo^));\r\n CM_HITTEST:\r\n with TCMHitTest(Msg) do\r\n Result := LRESULT(HitTest(XPos, YPos));\r\n CM_MOUSEENTER:\r\n MouseEnter(TControl(Msg.LParam));\r\n CM_MOUSELEAVE:\r\n MouseLeave(TControl(Msg.LParam));\r\n CM_VISIBLECHANGED:\r\n VisibleChanged;\r\n CM_ENABLEDCHANGED:\r\n EnabledChanged;\r\n CM_TEXTCHANGED:\r\n TextChanged;\r\n CM_FONTCHANGED:\r\n FontChanged;\r\n CM_COLORCHANGED:\r\n ColorChanged;\r\n CM_FOCUSCHANGED:\r\n FocusChanged(TWinControl(Msg.LParam));\r\n CM_PARENTFONTCHANGED:\r\n ParentFontChanged;\r\n CM_PARENTCOLORCHANGED:\r\n ParentColorChanged;\r\n CM_PARENTSHOWHINTCHANGED:\r\n ParentShowHintChanged;\r\n CM_CURSORCHANGED:\r\n CursorChanged;\r\n CM_SHOWINGCHANGED:\r\n ShowingChanged;\r\n CM_SHOWHINTCHANGED:\r\n ShowHintChanged;\r\n CM_CONTROLLISTCHANGE:\r\n if Msg.LParam <> 0 then\r\n ControlsListChanging(TControl(Msg.WParam), True)\r\n else\r\n ControlsListChanged(TControl(Msg.WParam), False);\r\n CM_CONTROLCHANGE:\r\n if Msg.LParam = 0 then\r\n ControlsListChanging(TControl(Msg.WParam), False)\r\n else\r\n ControlsListChanged(TControl(Msg.WParam), True);\r\n WM_SETFOCUS:\r\n FocusSet(THandle(Msg.WParam));\r\n WM_KILLFOCUS:\r\n FocusKilled(THandle(Msg.WParam));\r\n WM_SIZE, WM_MOVE:\r\n begin\r\n inherited WndProc(Msg);\r\n BoundsChanged;\r\n end;\r\n WM_ERASEBKGND:\r\n if (Msg.WParam <> 0) and not IsDefaultEraseBackground(DoEraseBackground, @TJvExCustomDrawGrid.DoEraseBackground) then\r\n begin\r\n IdSaveDC := SaveDC(HDC(Msg.WParam)); // protect DC against Stock-Objects from Canvas\r\n Canvas := TCanvas.Create;\r\n try\r\n Canvas.Handle := HDC(Msg.WParam);\r\n Msg.Result := Ord(DoEraseBackground(Canvas, Msg.LParam));\r\n finally\r\n Canvas.Handle := 0;\r\n Canvas.Free;\r\n RestoreDC(HDC(Msg.WParam), IdSaveDC);\r\n end;\r\n end\r\n else\r\n inherited WndProc(Msg);\r\n {$IFNDEF DELPHI2007_UP}\r\n WM_PRINTCLIENT, WM_PRINT: // VCL bug fix\r\n begin\r\n IdSaveDC := SaveDC(HDC(Msg.WParam)); // protect DC against changes\r\n try\r\n inherited WndProc(Msg);\r\n finally\r\n RestoreDC(HDC(Msg.WParam), IdSaveDC);\r\n end;\r\n end;\r\n {$ENDIF ~DELPHI2007_UP}\r\n WM_GETDLGCODE:\r\n begin\r\n inherited WndProc(Msg);\r\n DlgCodes := [dcNative] + DlgcToDlgCodes(Msg.Result);\r\n GetDlgCode(DlgCodes);\r\n if not (dcNative in DlgCodes) then\r\n Msg.Result := DlgCodesToDlgc(DlgCodes);\r\n end;\r\n else\r\n inherited WndProc(Msg);\r\n end;\r\n case Msg.Msg of // precheck message to prevent access violations on released controls\r\n CM_MOUSEENTER, CM_MOUSELEAVE, WM_KILLFOCUS, WM_SETFOCUS, WM_NCPAINT:\r\n if DotNetHighlighting then\r\n HandleDotNetHighlighting(Self, Msg, MouseOver, Color);\r\n end;\r\n end;\r\nend;\r\n\r\n//============================================================================\r\n\r\nconstructor TJvExInplaceEditList.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FHintColor := clDefault;\r\nend;\r\n\r\nfunction TJvExInplaceEditList.BaseWndProc(Msg: Cardinal; WParam: WPARAM = 0; LParam: LPARAM = 0): LRESULT;\r\nvar\r\n Mesg: TMessage;\r\nbegin\r\n CreateWMMessage(Mesg, Msg, WParam, LParam);\r\n inherited WndProc(Mesg);\r\n Result := Mesg.Result;\r\nend;\r\n\r\nfunction TJvExInplaceEditList.BaseWndProc(Msg: Cardinal; WParam: WPARAM; LParam: TObject): LRESULT;\r\nbegin\r\n Result := BaseWndProc(Msg, WParam, Windows.LPARAM(LParam));\r\nend;\r\n\r\nfunction TJvExInplaceEditList.BaseWndProcEx(Msg: Cardinal; WParam: WPARAM; var StructLParam): LRESULT;\r\nbegin\r\n Result := BaseWndProc(Msg, WParam, Windows.LPARAM(@StructLParam));\r\nend;\r\n\r\nprocedure TJvExInplaceEditList.VisibleChanged;\r\nbegin\r\n BaseWndProc(CM_VISIBLECHANGED);\r\nend;\r\n\r\nprocedure TJvExInplaceEditList.EnabledChanged;\r\nbegin\r\n BaseWndProc(CM_ENABLEDCHANGED);\r\nend;\r\n\r\nprocedure TJvExInplaceEditList.TextChanged;\r\nbegin\r\n BaseWndProc(CM_TEXTCHANGED);\r\nend;\r\n\r\nprocedure TJvExInplaceEditList.FontChanged;\r\nbegin\r\n BaseWndProc(CM_FONTCHANGED);\r\nend;\r\n\r\nprocedure TJvExInplaceEditList.ColorChanged;\r\nbegin\r\n BaseWndProc(CM_COLORCHANGED);\r\nend;\r\n\r\nprocedure TJvExInplaceEditList.ParentFontChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTFONTCHANGED);\r\nend;\r\n\r\nprocedure TJvExInplaceEditList.ParentColorChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTCOLORCHANGED);\r\n if Assigned(OnParentColorChange) then\r\n OnParentColorChange(Self);\r\nend;\r\n\r\nprocedure TJvExInplaceEditList.ParentShowHintChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTSHOWHINTCHANGED);\r\nend;\r\n\r\nfunction TJvExInplaceEditList.WantKey(Key: Integer; Shift: TShiftState): Boolean;\r\nbegin\r\n Result := BaseWndProc(CM_DIALOGCHAR, Word(Key), ShiftStateToKeyData(Shift)) <> 0;\r\nend;\r\n\r\nfunction TJvExInplaceEditList.HitTest(X, Y: Integer): Boolean;\r\nbegin\r\n Result := BaseWndProc(CM_HITTEST, 0, SmallPointToLong(PointToSmallPoint(Point(X, Y)))) <> 0;\r\nend;\r\n\r\nfunction TJvExInplaceEditList.HintShow(var HintInfo: THintInfo): Boolean;\r\nbegin\r\n GetHintColor(HintInfo, Self, FHintColor);\r\n if FHintWindowClass <> nil then\r\n HintInfo.HintWindowClass := FHintWindowClass;\r\n Result := BaseWndProcEx(CM_HINTSHOW, 0, HintInfo) <> 0;\r\nend;\r\n\r\nprocedure TJvExInplaceEditList.MouseEnter(AControl: TControl);\r\nbegin\r\n FMouseOver := True;\r\n if Assigned(FOnMouseEnter) then\r\n FOnMouseEnter(Self);\r\n BaseWndProc(CM_MOUSEENTER, 0, AControl);\r\nend;\r\n\r\nprocedure TJvExInplaceEditList.MouseLeave(AControl: TControl);\r\nbegin\r\n FMouseOver := False;\r\n BaseWndProc(CM_MOUSELEAVE, 0, AControl);\r\n if Assigned(FOnMouseLeave) then\r\n FOnMouseLeave(Self);\r\nend;\r\n\r\nprocedure TJvExInplaceEditList.FocusChanged(AControl: TWinControl);\r\nbegin\r\n BaseWndProc(CM_FOCUSCHANGED, 0, AControl);\r\nend;\r\n\r\nprocedure TJvExInplaceEditList.BoundsChanged;\r\nbegin\r\nend;\r\n\r\nprocedure TJvExInplaceEditList.CursorChanged;\r\nbegin\r\n BaseWndProc(CM_CURSORCHANGED);\r\nend;\r\n\r\nprocedure TJvExInplaceEditList.ShowingChanged;\r\nbegin\r\n BaseWndProc(CM_SHOWINGCHANGED);\r\nend;\r\n\r\nprocedure TJvExInplaceEditList.ShowHintChanged;\r\nbegin\r\n BaseWndProc(CM_SHOWHINTCHANGED);\r\nend;\r\n\r\n{ VCL sends CM_CONTROLLISTCHANGE and CM_CONTROLCHANGE in a different order than\r\n the CLX methods are used. So we must correct it by evaluating \"Inserting\". }\r\nprocedure TJvExInplaceEditList.ControlsListChanging(Control: TControl; Inserting: Boolean);\r\nbegin\r\n if Inserting then\r\n BaseWndProc(CM_CONTROLLISTCHANGE, WPARAM(Control), LPARAM(Inserting))\r\n else\r\n BaseWndProc(CM_CONTROLCHANGE, WPARAM(Control), LPARAM(Inserting));\r\nend;\r\n\r\nprocedure TJvExInplaceEditList.ControlsListChanged(Control: TControl; Inserting: Boolean);\r\nbegin\r\n if not Inserting then\r\n BaseWndProc(CM_CONTROLLISTCHANGE, WPARAM(Control), LPARAM(Inserting))\r\n else\r\n BaseWndProc(CM_CONTROLCHANGE, WPARAM(Control), LPARAM(Inserting));\r\nend;\r\n\r\nprocedure TJvExInplaceEditList.GetDlgCode(var Code: TDlgCodes);\r\nbegin\r\nend;\r\n\r\nprocedure TJvExInplaceEditList.FocusSet(PrevWnd: THandle);\r\nbegin\r\n BaseWndProc(WM_SETFOCUS, WPARAM(PrevWnd), 0);\r\nend;\r\n\r\nprocedure TJvExInplaceEditList.FocusKilled(NextWnd: THandle);\r\nbegin\r\n BaseWndProc(WM_KILLFOCUS, WPARAM(NextWnd), 0);\r\nend;\r\n\r\nfunction TJvExInplaceEditList.DoEraseBackground(Canvas: TCanvas; Param: LPARAM): Boolean;\r\nbegin\r\n Result := BaseWndProc(WM_ERASEBKGND, Canvas.Handle, Param) <> 0;\r\nend;\r\n\r\n{$IFDEF JVCLThemesEnabledD6}\r\nfunction TJvExInplaceEditList.GetParentBackground: Boolean;\r\nbegin\r\n Result := JvThemes.GetParentBackground(Self);\r\nend;\r\n\r\nprocedure TJvExInplaceEditList.SetParentBackground(Value: Boolean);\r\nbegin\r\n JvThemes.SetParentBackground(Self, Value);\r\nend;\r\n{$ENDIF JVCLThemesEnabledD6}\r\n\r\nprocedure TJvExInplaceEditList.WndProc(var Msg: TMessage);\r\nvar\r\n IdSaveDC: Integer;\r\n DlgCodes: TDlgCodes;\r\n Canvas: TCanvas;\r\nbegin\r\n if not DispatchIsDesignMsg(Self, Msg) then\r\n begin\r\n case Msg.Msg of\r\n CM_DENYSUBCLASSING:\r\n Msg.Result := LRESULT(Ord(GetInterfaceEntry(IJvDenySubClassing) <> nil));\r\n CM_DIALOGCHAR:\r\n with TCMDialogChar{$IFDEF CLR}.Create{$ENDIF}(Msg) do\r\n Result := LRESULT(Ord(WantKey(CharCode, KeyDataToShiftState(KeyData))));\r\n CM_HINTSHOW:\r\n with TCMHintShow(Msg) do\r\n Result := LRESULT(HintShow(HintInfo^));\r\n CM_HITTEST:\r\n with TCMHitTest(Msg) do\r\n Result := LRESULT(HitTest(XPos, YPos));\r\n CM_MOUSEENTER:\r\n MouseEnter(TControl(Msg.LParam));\r\n CM_MOUSELEAVE:\r\n MouseLeave(TControl(Msg.LParam));\r\n CM_VISIBLECHANGED:\r\n VisibleChanged;\r\n CM_ENABLEDCHANGED:\r\n EnabledChanged;\r\n CM_TEXTCHANGED:\r\n TextChanged;\r\n CM_FONTCHANGED:\r\n FontChanged;\r\n CM_COLORCHANGED:\r\n ColorChanged;\r\n CM_FOCUSCHANGED:\r\n FocusChanged(TWinControl(Msg.LParam));\r\n CM_PARENTFONTCHANGED:\r\n ParentFontChanged;\r\n CM_PARENTCOLORCHANGED:\r\n ParentColorChanged;\r\n CM_PARENTSHOWHINTCHANGED:\r\n ParentShowHintChanged;\r\n CM_CURSORCHANGED:\r\n CursorChanged;\r\n CM_SHOWINGCHANGED:\r\n ShowingChanged;\r\n CM_SHOWHINTCHANGED:\r\n ShowHintChanged;\r\n CM_CONTROLLISTCHANGE:\r\n if Msg.LParam <> 0 then\r\n ControlsListChanging(TControl(Msg.WParam), True)\r\n else\r\n ControlsListChanged(TControl(Msg.WParam), False);\r\n CM_CONTROLCHANGE:\r\n if Msg.LParam = 0 then\r\n ControlsListChanging(TControl(Msg.WParam), False)\r\n else\r\n ControlsListChanged(TControl(Msg.WParam), True);\r\n WM_SETFOCUS:\r\n FocusSet(THandle(Msg.WParam));\r\n WM_KILLFOCUS:\r\n FocusKilled(THandle(Msg.WParam));\r\n WM_SIZE, WM_MOVE:\r\n begin\r\n inherited WndProc(Msg);\r\n BoundsChanged;\r\n end;\r\n WM_ERASEBKGND:\r\n if (Msg.WParam <> 0) and not IsDefaultEraseBackground(DoEraseBackground, @TJvExInplaceEditList.DoEraseBackground) then\r\n begin\r\n IdSaveDC := SaveDC(HDC(Msg.WParam)); // protect DC against Stock-Objects from Canvas\r\n Canvas := TCanvas.Create;\r\n try\r\n Canvas.Handle := HDC(Msg.WParam);\r\n Msg.Result := Ord(DoEraseBackground(Canvas, Msg.LParam));\r\n finally\r\n Canvas.Handle := 0;\r\n Canvas.Free;\r\n RestoreDC(HDC(Msg.WParam), IdSaveDC);\r\n end;\r\n end\r\n else\r\n inherited WndProc(Msg);\r\n {$IFNDEF DELPHI2007_UP}\r\n WM_PRINTCLIENT, WM_PRINT: // VCL bug fix\r\n begin\r\n IdSaveDC := SaveDC(HDC(Msg.WParam)); // protect DC against changes\r\n try\r\n inherited WndProc(Msg);\r\n finally\r\n RestoreDC(HDC(Msg.WParam), IdSaveDC);\r\n end;\r\n end;\r\n {$ENDIF ~DELPHI2007_UP}\r\n WM_GETDLGCODE:\r\n begin\r\n inherited WndProc(Msg);\r\n DlgCodes := [dcNative] + DlgcToDlgCodes(Msg.Result);\r\n GetDlgCode(DlgCodes);\r\n if not (dcNative in DlgCodes) then\r\n Msg.Result := DlgCodesToDlgc(DlgCodes);\r\n end;\r\n else\r\n inherited WndProc(Msg);\r\n end;\r\n case Msg.Msg of // precheck message to prevent access violations on released controls\r\n CM_MOUSEENTER, CM_MOUSELEAVE, WM_KILLFOCUS, WM_SETFOCUS, WM_NCPAINT:\r\n if DotNetHighlighting then\r\n HandleDotNetHighlighting(Self, Msg, MouseOver, Color);\r\n end;\r\n end;\r\nend;\r\n\r\n//============================================================================\r\n\r\nconstructor TJvExDrawGrid.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FHintColor := clDefault;\r\nend;\r\n\r\nfunction TJvExDrawGrid.BaseWndProc(Msg: Cardinal; WParam: WPARAM = 0; LParam: LPARAM = 0): LRESULT;\r\nvar\r\n Mesg: TMessage;\r\nbegin\r\n CreateWMMessage(Mesg, Msg, WParam, LParam);\r\n inherited WndProc(Mesg);\r\n Result := Mesg.Result;\r\nend;\r\n\r\nfunction TJvExDrawGrid.BaseWndProc(Msg: Cardinal; WParam: WPARAM; LParam: TObject): LRESULT;\r\nbegin\r\n Result := BaseWndProc(Msg, WParam, Windows.LPARAM(LParam));\r\nend;\r\n\r\nfunction TJvExDrawGrid.BaseWndProcEx(Msg: Cardinal; WParam: WPARAM; var StructLParam): LRESULT;\r\nbegin\r\n Result := BaseWndProc(Msg, WParam, Windows.LPARAM(@StructLParam));\r\nend;\r\n\r\nprocedure TJvExDrawGrid.VisibleChanged;\r\nbegin\r\n BaseWndProc(CM_VISIBLECHANGED);\r\nend;\r\n\r\nprocedure TJvExDrawGrid.EnabledChanged;\r\nbegin\r\n BaseWndProc(CM_ENABLEDCHANGED);\r\nend;\r\n\r\nprocedure TJvExDrawGrid.TextChanged;\r\nbegin\r\n BaseWndProc(CM_TEXTCHANGED);\r\nend;\r\n\r\nprocedure TJvExDrawGrid.FontChanged;\r\nbegin\r\n BaseWndProc(CM_FONTCHANGED);\r\nend;\r\n\r\nprocedure TJvExDrawGrid.ColorChanged;\r\nbegin\r\n BaseWndProc(CM_COLORCHANGED);\r\nend;\r\n\r\nprocedure TJvExDrawGrid.ParentFontChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTFONTCHANGED);\r\nend;\r\n\r\nprocedure TJvExDrawGrid.ParentColorChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTCOLORCHANGED);\r\n if Assigned(OnParentColorChange) then\r\n OnParentColorChange(Self);\r\nend;\r\n\r\nprocedure TJvExDrawGrid.ParentShowHintChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTSHOWHINTCHANGED);\r\nend;\r\n\r\nfunction TJvExDrawGrid.WantKey(Key: Integer; Shift: TShiftState): Boolean;\r\nbegin\r\n Result := BaseWndProc(CM_DIALOGCHAR, Word(Key), ShiftStateToKeyData(Shift)) <> 0;\r\nend;\r\n\r\nfunction TJvExDrawGrid.HitTest(X, Y: Integer): Boolean;\r\nbegin\r\n Result := BaseWndProc(CM_HITTEST, 0, SmallPointToLong(PointToSmallPoint(Point(X, Y)))) <> 0;\r\nend;\r\n\r\nfunction TJvExDrawGrid.HintShow(var HintInfo: THintInfo): Boolean;\r\nbegin\r\n GetHintColor(HintInfo, Self, FHintColor);\r\n if FHintWindowClass <> nil then\r\n HintInfo.HintWindowClass := FHintWindowClass;\r\n Result := BaseWndProcEx(CM_HINTSHOW, 0, HintInfo) <> 0;\r\nend;\r\n\r\nprocedure TJvExDrawGrid.MouseEnter(AControl: TControl);\r\nbegin\r\n FMouseOver := True;\r\n if Assigned(FOnMouseEnter) then\r\n FOnMouseEnter(Self);\r\n BaseWndProc(CM_MOUSEENTER, 0, AControl);\r\nend;\r\n\r\nprocedure TJvExDrawGrid.MouseLeave(AControl: TControl);\r\nbegin\r\n FMouseOver := False;\r\n BaseWndProc(CM_MOUSELEAVE, 0, AControl);\r\n if Assigned(FOnMouseLeave) then\r\n FOnMouseLeave(Self);\r\nend;\r\n\r\nprocedure TJvExDrawGrid.FocusChanged(AControl: TWinControl);\r\nbegin\r\n BaseWndProc(CM_FOCUSCHANGED, 0, AControl);\r\nend;\r\n\r\nprocedure TJvExDrawGrid.BoundsChanged;\r\nbegin\r\nend;\r\n\r\nprocedure TJvExDrawGrid.CursorChanged;\r\nbegin\r\n BaseWndProc(CM_CURSORCHANGED);\r\nend;\r\n\r\nprocedure TJvExDrawGrid.ShowingChanged;\r\nbegin\r\n BaseWndProc(CM_SHOWINGCHANGED);\r\nend;\r\n\r\nprocedure TJvExDrawGrid.ShowHintChanged;\r\nbegin\r\n BaseWndProc(CM_SHOWHINTCHANGED);\r\nend;\r\n\r\n{ VCL sends CM_CONTROLLISTCHANGE and CM_CONTROLCHANGE in a different order than\r\n the CLX methods are used. So we must correct it by evaluating \"Inserting\". }\r\nprocedure TJvExDrawGrid.ControlsListChanging(Control: TControl; Inserting: Boolean);\r\nbegin\r\n if Inserting then\r\n BaseWndProc(CM_CONTROLLISTCHANGE, WPARAM(Control), LPARAM(Inserting))\r\n else\r\n BaseWndProc(CM_CONTROLCHANGE, WPARAM(Control), LPARAM(Inserting));\r\nend;\r\n\r\nprocedure TJvExDrawGrid.ControlsListChanged(Control: TControl; Inserting: Boolean);\r\nbegin\r\n if not Inserting then\r\n BaseWndProc(CM_CONTROLLISTCHANGE, WPARAM(Control), LPARAM(Inserting))\r\n else\r\n BaseWndProc(CM_CONTROLCHANGE, WPARAM(Control), LPARAM(Inserting));\r\nend;\r\n\r\nprocedure TJvExDrawGrid.GetDlgCode(var Code: TDlgCodes);\r\nbegin\r\nend;\r\n\r\nprocedure TJvExDrawGrid.FocusSet(PrevWnd: THandle);\r\nbegin\r\n BaseWndProc(WM_SETFOCUS, WPARAM(PrevWnd), 0);\r\nend;\r\n\r\nprocedure TJvExDrawGrid.FocusKilled(NextWnd: THandle);\r\nbegin\r\n BaseWndProc(WM_KILLFOCUS, WPARAM(NextWnd), 0);\r\nend;\r\n\r\nfunction TJvExDrawGrid.DoEraseBackground(Canvas: TCanvas; Param: LPARAM): Boolean;\r\nbegin\r\n Result := BaseWndProc(WM_ERASEBKGND, Canvas.Handle, Param) <> 0;\r\nend;\r\n\r\n{$IFDEF JVCLThemesEnabledD6}\r\nfunction TJvExDrawGrid.GetParentBackground: Boolean;\r\nbegin\r\n Result := JvThemes.GetParentBackground(Self);\r\nend;\r\n\r\nprocedure TJvExDrawGrid.SetParentBackground(Value: Boolean);\r\nbegin\r\n JvThemes.SetParentBackground(Self, Value);\r\nend;\r\n{$ENDIF JVCLThemesEnabledD6}\r\n\r\nprocedure TJvExDrawGrid.WndProc(var Msg: TMessage);\r\nvar\r\n IdSaveDC: Integer;\r\n DlgCodes: TDlgCodes;\r\n Canvas: TCanvas;\r\nbegin\r\n if not DispatchIsDesignMsg(Self, Msg) then\r\n begin\r\n case Msg.Msg of\r\n CM_DENYSUBCLASSING:\r\n Msg.Result := LRESULT(Ord(GetInterfaceEntry(IJvDenySubClassing) <> nil));\r\n CM_DIALOGCHAR:\r\n with TCMDialogChar{$IFDEF CLR}.Create{$ENDIF}(Msg) do\r\n Result := LRESULT(Ord(WantKey(CharCode, KeyDataToShiftState(KeyData))));\r\n CM_HINTSHOW:\r\n with TCMHintShow(Msg) do\r\n Result := LRESULT(HintShow(HintInfo^));\r\n CM_HITTEST:\r\n with TCMHitTest(Msg) do\r\n Result := LRESULT(HitTest(XPos, YPos));\r\n CM_MOUSEENTER:\r\n MouseEnter(TControl(Msg.LParam));\r\n CM_MOUSELEAVE:\r\n MouseLeave(TControl(Msg.LParam));\r\n CM_VISIBLECHANGED:\r\n VisibleChanged;\r\n CM_ENABLEDCHANGED:\r\n EnabledChanged;\r\n CM_TEXTCHANGED:\r\n TextChanged;\r\n CM_FONTCHANGED:\r\n FontChanged;\r\n CM_COLORCHANGED:\r\n ColorChanged;\r\n CM_FOCUSCHANGED:\r\n FocusChanged(TWinControl(Msg.LParam));\r\n CM_PARENTFONTCHANGED:\r\n ParentFontChanged;\r\n CM_PARENTCOLORCHANGED:\r\n ParentColorChanged;\r\n CM_PARENTSHOWHINTCHANGED:\r\n ParentShowHintChanged;\r\n CM_CURSORCHANGED:\r\n CursorChanged;\r\n CM_SHOWINGCHANGED:\r\n ShowingChanged;\r\n CM_SHOWHINTCHANGED:\r\n ShowHintChanged;\r\n CM_CONTROLLISTCHANGE:\r\n if Msg.LParam <> 0 then\r\n ControlsListChanging(TControl(Msg.WParam), True)\r\n else\r\n ControlsListChanged(TControl(Msg.WParam), False);\r\n CM_CONTROLCHANGE:\r\n if Msg.LParam = 0 then\r\n ControlsListChanging(TControl(Msg.WParam), False)\r\n else\r\n ControlsListChanged(TControl(Msg.WParam), True);\r\n WM_SETFOCUS:\r\n FocusSet(THandle(Msg.WParam));\r\n WM_KILLFOCUS:\r\n FocusKilled(THandle(Msg.WParam));\r\n WM_SIZE, WM_MOVE:\r\n begin\r\n inherited WndProc(Msg);\r\n BoundsChanged;\r\n end;\r\n WM_ERASEBKGND:\r\n if (Msg.WParam <> 0) and not IsDefaultEraseBackground(DoEraseBackground, @TJvExDrawGrid.DoEraseBackground) then\r\n begin\r\n IdSaveDC := SaveDC(HDC(Msg.WParam)); // protect DC against Stock-Objects from Canvas\r\n Canvas := TCanvas.Create;\r\n try\r\n Canvas.Handle := HDC(Msg.WParam);\r\n Msg.Result := Ord(DoEraseBackground(Canvas, Msg.LParam));\r\n finally\r\n Canvas.Handle := 0;\r\n Canvas.Free;\r\n RestoreDC(HDC(Msg.WParam), IdSaveDC);\r\n end;\r\n end\r\n else\r\n inherited WndProc(Msg);\r\n {$IFNDEF DELPHI2007_UP}\r\n WM_PRINTCLIENT, WM_PRINT: // VCL bug fix\r\n begin\r\n IdSaveDC := SaveDC(HDC(Msg.WParam)); // protect DC against changes\r\n try\r\n inherited WndProc(Msg);\r\n finally\r\n RestoreDC(HDC(Msg.WParam), IdSaveDC);\r\n end;\r\n end;\r\n {$ENDIF ~DELPHI2007_UP}\r\n WM_GETDLGCODE:\r\n begin\r\n inherited WndProc(Msg);\r\n DlgCodes := [dcNative] + DlgcToDlgCodes(Msg.Result);\r\n GetDlgCode(DlgCodes);\r\n if not (dcNative in DlgCodes) then\r\n Msg.Result := DlgCodesToDlgc(DlgCodes);\r\n end;\r\n else\r\n inherited WndProc(Msg);\r\n end;\r\n case Msg.Msg of // precheck message to prevent access violations on released controls\r\n CM_MOUSEENTER, CM_MOUSELEAVE, WM_KILLFOCUS, WM_SETFOCUS, WM_NCPAINT:\r\n if DotNetHighlighting then\r\n HandleDotNetHighlighting(Self, Msg, MouseOver, Color);\r\n end;\r\n end;\r\nend;\r\n\r\n//============================================================================\r\n\r\nconstructor TJvExStringGrid.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FHintColor := clDefault;\r\nend;\r\n\r\nfunction TJvExStringGrid.BaseWndProc(Msg: Cardinal; WParam: WPARAM = 0; LParam: LPARAM = 0): LRESULT;\r\nvar\r\n Mesg: TMessage;\r\nbegin\r\n CreateWMMessage(Mesg, Msg, WParam, LParam);\r\n inherited WndProc(Mesg);\r\n Result := Mesg.Result;\r\nend;\r\n\r\nfunction TJvExStringGrid.BaseWndProc(Msg: Cardinal; WParam: WPARAM; LParam: TObject): LRESULT;\r\nbegin\r\n Result := BaseWndProc(Msg, WParam, Windows.LPARAM(LParam));\r\nend;\r\n\r\nfunction TJvExStringGrid.BaseWndProcEx(Msg: Cardinal; WParam: WPARAM; var StructLParam): LRESULT;\r\nbegin\r\n Result := BaseWndProc(Msg, WParam, Windows.LPARAM(@StructLParam));\r\nend;\r\n\r\nprocedure TJvExStringGrid.VisibleChanged;\r\nbegin\r\n BaseWndProc(CM_VISIBLECHANGED);\r\nend;\r\n\r\nprocedure TJvExStringGrid.EnabledChanged;\r\nbegin\r\n BaseWndProc(CM_ENABLEDCHANGED);\r\nend;\r\n\r\nprocedure TJvExStringGrid.TextChanged;\r\nbegin\r\n BaseWndProc(CM_TEXTCHANGED);\r\nend;\r\n\r\nprocedure TJvExStringGrid.FontChanged;\r\nbegin\r\n BaseWndProc(CM_FONTCHANGED);\r\nend;\r\n\r\nprocedure TJvExStringGrid.ColorChanged;\r\nbegin\r\n BaseWndProc(CM_COLORCHANGED);\r\nend;\r\n\r\nprocedure TJvExStringGrid.ParentFontChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTFONTCHANGED);\r\nend;\r\n\r\nprocedure TJvExStringGrid.ParentColorChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTCOLORCHANGED);\r\n if Assigned(OnParentColorChange) then\r\n OnParentColorChange(Self);\r\nend;\r\n\r\nprocedure TJvExStringGrid.ParentShowHintChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTSHOWHINTCHANGED);\r\nend;\r\n\r\nfunction TJvExStringGrid.WantKey(Key: Integer; Shift: TShiftState): Boolean;\r\nbegin\r\n Result := BaseWndProc(CM_DIALOGCHAR, Word(Key), ShiftStateToKeyData(Shift)) <> 0;\r\nend;\r\n\r\nfunction TJvExStringGrid.HitTest(X, Y: Integer): Boolean;\r\nbegin\r\n Result := BaseWndProc(CM_HITTEST, 0, SmallPointToLong(PointToSmallPoint(Point(X, Y)))) <> 0;\r\nend;\r\n\r\nfunction TJvExStringGrid.HintShow(var HintInfo: THintInfo): Boolean;\r\nbegin\r\n GetHintColor(HintInfo, Self, FHintColor);\r\n if FHintWindowClass <> nil then\r\n HintInfo.HintWindowClass := FHintWindowClass;\r\n Result := BaseWndProcEx(CM_HINTSHOW, 0, HintInfo) <> 0;\r\nend;\r\n\r\nprocedure TJvExStringGrid.MouseEnter(AControl: TControl);\r\nbegin\r\n FMouseOver := True;\r\n if Assigned(FOnMouseEnter) then\r\n FOnMouseEnter(Self);\r\n BaseWndProc(CM_MOUSEENTER, 0, AControl);\r\nend;\r\n\r\nprocedure TJvExStringGrid.MouseLeave(AControl: TControl);\r\nbegin\r\n FMouseOver := False;\r\n BaseWndProc(CM_MOUSELEAVE, 0, AControl);\r\n if Assigned(FOnMouseLeave) then\r\n FOnMouseLeave(Self);\r\nend;\r\n\r\nprocedure TJvExStringGrid.FocusChanged(AControl: TWinControl);\r\nbegin\r\n BaseWndProc(CM_FOCUSCHANGED, 0, AControl);\r\nend;\r\n\r\nprocedure TJvExStringGrid.BoundsChanged;\r\nbegin\r\nend;\r\n\r\nprocedure TJvExStringGrid.CursorChanged;\r\nbegin\r\n BaseWndProc(CM_CURSORCHANGED);\r\nend;\r\n\r\nprocedure TJvExStringGrid.ShowingChanged;\r\nbegin\r\n BaseWndProc(CM_SHOWINGCHANGED);\r\nend;\r\n\r\nprocedure TJvExStringGrid.ShowHintChanged;\r\nbegin\r\n BaseWndProc(CM_SHOWHINTCHANGED);\r\nend;\r\n\r\n{ VCL sends CM_CONTROLLISTCHANGE and CM_CONTROLCHANGE in a different order than\r\n the CLX methods are used. So we must correct it by evaluating \"Inserting\". }\r\nprocedure TJvExStringGrid.ControlsListChanging(Control: TControl; Inserting: Boolean);\r\nbegin\r\n if Inserting then\r\n BaseWndProc(CM_CONTROLLISTCHANGE, WPARAM(Control), LPARAM(Inserting))\r\n else\r\n BaseWndProc(CM_CONTROLCHANGE, WPARAM(Control), LPARAM(Inserting));\r\nend;\r\n\r\nprocedure TJvExStringGrid.ControlsListChanged(Control: TControl; Inserting: Boolean);\r\nbegin\r\n if not Inserting then\r\n BaseWndProc(CM_CONTROLLISTCHANGE, WPARAM(Control), LPARAM(Inserting))\r\n else\r\n BaseWndProc(CM_CONTROLCHANGE, WPARAM(Control), LPARAM(Inserting));\r\nend;\r\n\r\nprocedure TJvExStringGrid.GetDlgCode(var Code: TDlgCodes);\r\nbegin\r\nend;\r\n\r\nprocedure TJvExStringGrid.FocusSet(PrevWnd: THandle);\r\nbegin\r\n BaseWndProc(WM_SETFOCUS, WPARAM(PrevWnd), 0);\r\nend;\r\n\r\nprocedure TJvExStringGrid.FocusKilled(NextWnd: THandle);\r\nbegin\r\n BaseWndProc(WM_KILLFOCUS, WPARAM(NextWnd), 0);\r\nend;\r\n\r\nfunction TJvExStringGrid.DoEraseBackground(Canvas: TCanvas; Param: LPARAM): Boolean;\r\nbegin\r\n Result := BaseWndProc(WM_ERASEBKGND, Canvas.Handle, Param) <> 0;\r\nend;\r\n\r\n{$IFDEF JVCLThemesEnabledD6}\r\nfunction TJvExStringGrid.GetParentBackground: Boolean;\r\nbegin\r\n Result := JvThemes.GetParentBackground(Self);\r\nend;\r\n\r\nprocedure TJvExStringGrid.SetParentBackground(Value: Boolean);\r\nbegin\r\n JvThemes.SetParentBackground(Self, Value);\r\nend;\r\n{$ENDIF JVCLThemesEnabledD6}\r\n\r\nprocedure TJvExStringGrid.WndProc(var Msg: TMessage);\r\nvar\r\n IdSaveDC: Integer;\r\n DlgCodes: TDlgCodes;\r\n Canvas: TCanvas;\r\nbegin\r\n if not DispatchIsDesignMsg(Self, Msg) then\r\n begin\r\n case Msg.Msg of\r\n CM_DENYSUBCLASSING:\r\n Msg.Result := LRESULT(Ord(GetInterfaceEntry(IJvDenySubClassing) <> nil));\r\n CM_DIALOGCHAR:\r\n with TCMDialogChar{$IFDEF CLR}.Create{$ENDIF}(Msg) do\r\n Result := LRESULT(Ord(WantKey(CharCode, KeyDataToShiftState(KeyData))));\r\n CM_HINTSHOW:\r\n with TCMHintShow(Msg) do\r\n Result := LRESULT(HintShow(HintInfo^));\r\n CM_HITTEST:\r\n with TCMHitTest(Msg) do\r\n Result := LRESULT(HitTest(XPos, YPos));\r\n CM_MOUSEENTER:\r\n MouseEnter(TControl(Msg.LParam));\r\n CM_MOUSELEAVE:\r\n MouseLeave(TControl(Msg.LParam));\r\n CM_VISIBLECHANGED:\r\n VisibleChanged;\r\n CM_ENABLEDCHANGED:\r\n EnabledChanged;\r\n CM_TEXTCHANGED:\r\n TextChanged;\r\n CM_FONTCHANGED:\r\n FontChanged;\r\n CM_COLORCHANGED:\r\n ColorChanged;\r\n CM_FOCUSCHANGED:\r\n FocusChanged(TWinControl(Msg.LParam));\r\n CM_PARENTFONTCHANGED:\r\n ParentFontChanged;\r\n CM_PARENTCOLORCHANGED:\r\n ParentColorChanged;\r\n CM_PARENTSHOWHINTCHANGED:\r\n ParentShowHintChanged;\r\n CM_CURSORCHANGED:\r\n CursorChanged;\r\n CM_SHOWINGCHANGED:\r\n ShowingChanged;\r\n CM_SHOWHINTCHANGED:\r\n ShowHintChanged;\r\n CM_CONTROLLISTCHANGE:\r\n if Msg.LParam <> 0 then\r\n ControlsListChanging(TControl(Msg.WParam), True)\r\n else\r\n ControlsListChanged(TControl(Msg.WParam), False);\r\n CM_CONTROLCHANGE:\r\n if Msg.LParam = 0 then\r\n ControlsListChanging(TControl(Msg.WParam), False)\r\n else\r\n ControlsListChanged(TControl(Msg.WParam), True);\r\n WM_SETFOCUS:\r\n FocusSet(THandle(Msg.WParam));\r\n WM_KILLFOCUS:\r\n FocusKilled(THandle(Msg.WParam));\r\n WM_SIZE, WM_MOVE:\r\n begin\r\n inherited WndProc(Msg);\r\n BoundsChanged;\r\n end;\r\n WM_ERASEBKGND:\r\n if (Msg.WParam <> 0) and not IsDefaultEraseBackground(DoEraseBackground, @TJvExStringGrid.DoEraseBackground) then\r\n begin\r\n IdSaveDC := SaveDC(HDC(Msg.WParam)); // protect DC against Stock-Objects from Canvas\r\n Canvas := TCanvas.Create;\r\n try\r\n Canvas.Handle := HDC(Msg.WParam);\r\n Msg.Result := Ord(DoEraseBackground(Canvas, Msg.LParam));\r\n finally\r\n Canvas.Handle := 0;\r\n Canvas.Free;\r\n RestoreDC(HDC(Msg.WParam), IdSaveDC);\r\n end;\r\n end\r\n else\r\n inherited WndProc(Msg);\r\n {$IFNDEF DELPHI2007_UP}\r\n WM_PRINTCLIENT, WM_PRINT: // VCL bug fix\r\n begin\r\n IdSaveDC := SaveDC(HDC(Msg.WParam)); // protect DC against changes\r\n try\r\n inherited WndProc(Msg);\r\n finally\r\n RestoreDC(HDC(Msg.WParam), IdSaveDC);\r\n end;\r\n end;\r\n {$ENDIF ~DELPHI2007_UP}\r\n WM_GETDLGCODE:\r\n begin\r\n inherited WndProc(Msg);\r\n DlgCodes := [dcNative] + DlgcToDlgCodes(Msg.Result);\r\n GetDlgCode(DlgCodes);\r\n if not (dcNative in DlgCodes) then\r\n Msg.Result := DlgCodesToDlgc(DlgCodes);\r\n end;\r\n else\r\n inherited WndProc(Msg);\r\n end;\r\n case Msg.Msg of // precheck message to prevent access violations on released controls\r\n CM_MOUSEENTER, CM_MOUSELEAVE, WM_KILLFOCUS, WM_SETFOCUS, WM_NCPAINT:\r\n if DotNetHighlighting then\r\n HandleDotNetHighlighting(Self, Msg, MouseOver, Color);\r\n end;\r\n end;\r\nend;\r\n\r\n//============================================================================\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend." }, { "path": "External/Jedi/Jvcl/run/JvExMask.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvExMask.pas, released on 2004-01-04\r\n\r\nThe Initial Developer of the Original Code is Andreas Hausladen [Andreas dott Hausladen att gmx dott de]\r\nPortions created by Andreas Hausladen are Copyright (C) 2004 Andreas Hausladen.\r\nAll Rights Reserved.\r\n\r\nContributor(s): -\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvExMask.pas 13173 2011-11-19 12:43:58Z ahuser $\r\n\r\nunit JvExMask;\r\n\r\n{$I jvcl.inc}\r\n{MACROINCLUDE JvExControls.macros}\r\n\r\n{*****************************************************************************\r\n * WARNING: Do not edit this file.\r\n * This file is autogenerated from the source in devtools/JvExVCL/src.\r\n * If you do it despite this warning your changes will be discarded by the next\r\n * update of this file. Do your changes in the template files.\r\n ****************************************************************************}\r\n{$D-} // do not step into this unit\r\n\r\ninterface\r\n\r\nuses\r\n Windows, Messages, Types,\r\n SysUtils, Classes, Graphics, Controls, Forms, Mask,\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n JvTypes, JvThemes, JVCLVer, JvExControls;\r\n\r\ntype\r\n TJvExCustomMaskEdit = class(TCustomMaskEdit, IJvExControl)\r\n private\r\n FAboutJVCL: TJVCLAboutInfo;\r\n FHintColor: TColor;\r\n FMouseOver: Boolean;\r\n FHintWindowClass: THintWindowClass;\r\n FOnMouseEnter: TNotifyEvent;\r\n FOnMouseLeave: TNotifyEvent;\r\n FOnParentColorChanged: TNotifyEvent;\r\n function BaseWndProc(Msg: Cardinal; WParam: WPARAM = 0; LParam: LPARAM = 0): LRESULT; overload;\r\n function BaseWndProc(Msg: Cardinal; WParam: WPARAM; LParam: TObject): LRESULT; overload;\r\n function BaseWndProcEx(Msg: Cardinal; WParam: WPARAM; var StructLParam): LRESULT;\r\n protected\r\n procedure WndProc(var Msg: TMessage); override;\r\n procedure FocusChanged(AControl: TWinControl); dynamic;\r\n procedure VisibleChanged; reintroduce; dynamic;\r\n procedure EnabledChanged; reintroduce; dynamic;\r\n procedure TextChanged; reintroduce; virtual;\r\n procedure ColorChanged; reintroduce; dynamic;\r\n procedure FontChanged; reintroduce; dynamic;\r\n procedure ParentFontChanged; reintroduce; dynamic;\r\n procedure ParentColorChanged; reintroduce; dynamic;\r\n procedure ParentShowHintChanged; reintroduce; dynamic;\r\n function WantKey(Key: Integer; Shift: TShiftState): Boolean; virtual;\r\n function HintShow(var HintInfo: THintInfo): Boolean; reintroduce; dynamic;\r\n function HitTest(X, Y: Integer): Boolean; reintroduce; virtual;\r\n procedure MouseEnter(AControl: TControl); reintroduce; dynamic;\r\n procedure MouseLeave(AControl: TControl); reintroduce; dynamic;\r\n property MouseOver: Boolean read FMouseOver write FMouseOver;\r\n property HintColor: TColor read FHintColor write FHintColor default clDefault;\r\n property OnMouseEnter: TNotifyEvent read FOnMouseEnter write FOnMouseEnter;\r\n property OnMouseLeave: TNotifyEvent read FOnMouseLeave write FOnMouseLeave;\r\n property OnParentColorChange: TNotifyEvent read FOnParentColorChanged write FOnParentColorChanged;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n property HintWindowClass: THintWindowClass read FHintWindowClass write FHintWindowClass;\r\n published\r\n property AboutJVCL: TJVCLAboutInfo read FAboutJVCL write FAboutJVCL stored False;\r\n private\r\n FDotNetHighlighting: Boolean;\r\n protected\r\n procedure BoundsChanged; reintroduce; virtual;\r\n procedure CursorChanged; reintroduce; dynamic;\r\n procedure ShowingChanged; reintroduce; dynamic;\r\n procedure ShowHintChanged; reintroduce; dynamic;\r\n procedure ControlsListChanging(Control: TControl; Inserting: Boolean); reintroduce; dynamic;\r\n procedure ControlsListChanged(Control: TControl; Inserting: Boolean); reintroduce; dynamic;\r\n procedure GetDlgCode(var Code: TDlgCodes); virtual;\r\n procedure FocusSet(PrevWnd: THandle); virtual;\r\n procedure FocusKilled(NextWnd: THandle); virtual;\r\n function DoEraseBackground(Canvas: TCanvas; Param: LPARAM): Boolean; virtual;\r\n {$IFDEF JVCLThemesEnabledD6}\r\n private\r\n function GetParentBackground: Boolean;\r\n protected\r\n procedure SetParentBackground(Value: Boolean); virtual;\r\n property ParentBackground: Boolean read GetParentBackground write SetParentBackground;\r\n {$ENDIF JVCLThemesEnabledD6}\r\n published\r\n property DotNetHighlighting: Boolean read FDotNetHighlighting write FDotNetHighlighting default False;\r\n private\r\n FClipboardCommands: TJvClipboardCommands;\r\n protected\r\n procedure SetClipboardCommands(const Value: TJvClipboardCommands); virtual;\r\n property ClipboardCommands: TJvClipboardCommands read FClipboardCommands write SetClipboardCommands default [caCopy..caUndo];\r\n private\r\n FBeepOnError: Boolean;\r\n protected\r\n procedure DoBeepOnError; dynamic;\r\n procedure SetBeepOnError(Value: Boolean); virtual;\r\n property BeepOnError: Boolean read FBeepOnError write SetBeepOnError default True;\r\n end;\r\n\r\n TJvExMaskEdit = class(TMaskEdit, IJvExControl)\r\n private\r\n FAboutJVCL: TJVCLAboutInfo;\r\n FHintColor: TColor;\r\n FMouseOver: Boolean;\r\n FHintWindowClass: THintWindowClass;\r\n FOnMouseEnter: TNotifyEvent;\r\n FOnMouseLeave: TNotifyEvent;\r\n FOnParentColorChanged: TNotifyEvent;\r\n function BaseWndProc(Msg: Cardinal; WParam: WPARAM = 0; LParam: LPARAM = 0): LRESULT; overload;\r\n function BaseWndProc(Msg: Cardinal; WParam: WPARAM; LParam: TObject): LRESULT; overload;\r\n function BaseWndProcEx(Msg: Cardinal; WParam: WPARAM; var StructLParam): LRESULT;\r\n protected\r\n procedure WndProc(var Msg: TMessage); override;\r\n procedure FocusChanged(AControl: TWinControl); dynamic;\r\n procedure VisibleChanged; reintroduce; dynamic;\r\n procedure EnabledChanged; reintroduce; dynamic;\r\n procedure TextChanged; reintroduce; virtual;\r\n procedure ColorChanged; reintroduce; dynamic;\r\n procedure FontChanged; reintroduce; dynamic;\r\n procedure ParentFontChanged; reintroduce; dynamic;\r\n procedure ParentColorChanged; reintroduce; dynamic;\r\n procedure ParentShowHintChanged; reintroduce; dynamic;\r\n function WantKey(Key: Integer; Shift: TShiftState): Boolean; virtual;\r\n function HintShow(var HintInfo: THintInfo): Boolean; reintroduce; dynamic;\r\n function HitTest(X, Y: Integer): Boolean; reintroduce; virtual;\r\n procedure MouseEnter(AControl: TControl); reintroduce; dynamic;\r\n procedure MouseLeave(AControl: TControl); reintroduce; dynamic;\r\n property MouseOver: Boolean read FMouseOver write FMouseOver;\r\n property HintColor: TColor read FHintColor write FHintColor default clDefault;\r\n property OnMouseEnter: TNotifyEvent read FOnMouseEnter write FOnMouseEnter;\r\n property OnMouseLeave: TNotifyEvent read FOnMouseLeave write FOnMouseLeave;\r\n property OnParentColorChange: TNotifyEvent read FOnParentColorChanged write FOnParentColorChanged;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n property HintWindowClass: THintWindowClass read FHintWindowClass write FHintWindowClass;\r\n published\r\n property AboutJVCL: TJVCLAboutInfo read FAboutJVCL write FAboutJVCL stored False;\r\n private\r\n FDotNetHighlighting: Boolean;\r\n protected\r\n procedure BoundsChanged; reintroduce; virtual;\r\n procedure CursorChanged; reintroduce; dynamic;\r\n procedure ShowingChanged; reintroduce; dynamic;\r\n procedure ShowHintChanged; reintroduce; dynamic;\r\n procedure ControlsListChanging(Control: TControl; Inserting: Boolean); reintroduce; dynamic;\r\n procedure ControlsListChanged(Control: TControl; Inserting: Boolean); reintroduce; dynamic;\r\n procedure GetDlgCode(var Code: TDlgCodes); virtual;\r\n procedure FocusSet(PrevWnd: THandle); virtual;\r\n procedure FocusKilled(NextWnd: THandle); virtual;\r\n function DoEraseBackground(Canvas: TCanvas; Param: LPARAM): Boolean; virtual;\r\n {$IFDEF JVCLThemesEnabledD6}\r\n private\r\n function GetParentBackground: Boolean;\r\n protected\r\n procedure SetParentBackground(Value: Boolean); virtual;\r\n property ParentBackground: Boolean read GetParentBackground write SetParentBackground;\r\n {$ENDIF JVCLThemesEnabledD6}\r\n published\r\n property DotNetHighlighting: Boolean read FDotNetHighlighting write FDotNetHighlighting default False;\r\n private\r\n FClipboardCommands: TJvClipboardCommands;\r\n protected\r\n procedure SetClipboardCommands(const Value: TJvClipboardCommands); virtual;\r\n property ClipboardCommands: TJvClipboardCommands read FClipboardCommands write SetClipboardCommands default [caCopy..caUndo];\r\n private\r\n FBeepOnError: Boolean;\r\n protected\r\n procedure DoBeepOnError; dynamic;\r\n procedure SetBeepOnError(Value: Boolean); virtual;\r\n property BeepOnError: Boolean read FBeepOnError write SetBeepOnError default True;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvExMask.pas $';\r\n Revision: '$Revision: 13173 $';\r\n Date: '$Date: 2011-11-19 13:43:58 +0100 (sam. 19 nov. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nconstructor TJvExCustomMaskEdit.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FHintColor := clDefault;\r\n FClipboardCommands := [caCopy..caUndo];\r\n FBeepOnError := True;\r\nend;\r\n\r\nfunction TJvExCustomMaskEdit.BaseWndProc(Msg: Cardinal; WParam: WPARAM = 0; LParam: LPARAM = 0): LRESULT;\r\nvar\r\n Mesg: TMessage;\r\nbegin\r\n CreateWMMessage(Mesg, Msg, WParam, LParam);\r\n inherited WndProc(Mesg);\r\n Result := Mesg.Result;\r\nend;\r\n\r\nfunction TJvExCustomMaskEdit.BaseWndProc(Msg: Cardinal; WParam: WPARAM; LParam: TObject): LRESULT;\r\nbegin\r\n Result := BaseWndProc(Msg, WParam, Windows.LPARAM(LParam));\r\nend;\r\n\r\nfunction TJvExCustomMaskEdit.BaseWndProcEx(Msg: Cardinal; WParam: WPARAM; var StructLParam): LRESULT;\r\nbegin\r\n Result := BaseWndProc(Msg, WParam, Windows.LPARAM(@StructLParam));\r\nend;\r\n\r\nprocedure TJvExCustomMaskEdit.VisibleChanged;\r\nbegin\r\n BaseWndProc(CM_VISIBLECHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomMaskEdit.EnabledChanged;\r\nbegin\r\n BaseWndProc(CM_ENABLEDCHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomMaskEdit.TextChanged;\r\nbegin\r\n BaseWndProc(CM_TEXTCHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomMaskEdit.FontChanged;\r\nbegin\r\n BaseWndProc(CM_FONTCHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomMaskEdit.ColorChanged;\r\nbegin\r\n BaseWndProc(CM_COLORCHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomMaskEdit.ParentFontChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTFONTCHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomMaskEdit.ParentColorChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTCOLORCHANGED);\r\n if Assigned(OnParentColorChange) then\r\n OnParentColorChange(Self);\r\nend;\r\n\r\nprocedure TJvExCustomMaskEdit.ParentShowHintChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTSHOWHINTCHANGED);\r\nend;\r\n\r\nfunction TJvExCustomMaskEdit.WantKey(Key: Integer; Shift: TShiftState): Boolean;\r\nbegin\r\n Result := BaseWndProc(CM_DIALOGCHAR, Word(Key), ShiftStateToKeyData(Shift)) <> 0;\r\nend;\r\n\r\nfunction TJvExCustomMaskEdit.HitTest(X, Y: Integer): Boolean;\r\nbegin\r\n Result := BaseWndProc(CM_HITTEST, 0, SmallPointToLong(PointToSmallPoint(Point(X, Y)))) <> 0;\r\nend;\r\n\r\nfunction TJvExCustomMaskEdit.HintShow(var HintInfo: THintInfo): Boolean;\r\nbegin\r\n GetHintColor(HintInfo, Self, FHintColor);\r\n if FHintWindowClass <> nil then\r\n HintInfo.HintWindowClass := FHintWindowClass;\r\n Result := BaseWndProcEx(CM_HINTSHOW, 0, HintInfo) <> 0;\r\nend;\r\n\r\nprocedure TJvExCustomMaskEdit.MouseEnter(AControl: TControl);\r\nbegin\r\n FMouseOver := True;\r\n if Assigned(FOnMouseEnter) then\r\n FOnMouseEnter(Self);\r\n BaseWndProc(CM_MOUSEENTER, 0, AControl);\r\nend;\r\n\r\nprocedure TJvExCustomMaskEdit.MouseLeave(AControl: TControl);\r\nbegin\r\n FMouseOver := False;\r\n BaseWndProc(CM_MOUSELEAVE, 0, AControl);\r\n if Assigned(FOnMouseLeave) then\r\n FOnMouseLeave(Self);\r\nend;\r\n\r\nprocedure TJvExCustomMaskEdit.FocusChanged(AControl: TWinControl);\r\nbegin\r\n BaseWndProc(CM_FOCUSCHANGED, 0, AControl);\r\nend;\r\n\r\nprocedure TJvExCustomMaskEdit.BoundsChanged;\r\nbegin\r\nend;\r\n\r\nprocedure TJvExCustomMaskEdit.CursorChanged;\r\nbegin\r\n BaseWndProc(CM_CURSORCHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomMaskEdit.ShowingChanged;\r\nbegin\r\n BaseWndProc(CM_SHOWINGCHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomMaskEdit.ShowHintChanged;\r\nbegin\r\n BaseWndProc(CM_SHOWHINTCHANGED);\r\nend;\r\n\r\n{ VCL sends CM_CONTROLLISTCHANGE and CM_CONTROLCHANGE in a different order than\r\n the CLX methods are used. So we must correct it by evaluating \"Inserting\". }\r\nprocedure TJvExCustomMaskEdit.ControlsListChanging(Control: TControl; Inserting: Boolean);\r\nbegin\r\n if Inserting then\r\n BaseWndProc(CM_CONTROLLISTCHANGE, WPARAM(Control), LPARAM(Inserting))\r\n else\r\n BaseWndProc(CM_CONTROLCHANGE, WPARAM(Control), LPARAM(Inserting));\r\nend;\r\n\r\nprocedure TJvExCustomMaskEdit.ControlsListChanged(Control: TControl; Inserting: Boolean);\r\nbegin\r\n if not Inserting then\r\n BaseWndProc(CM_CONTROLLISTCHANGE, WPARAM(Control), LPARAM(Inserting))\r\n else\r\n BaseWndProc(CM_CONTROLCHANGE, WPARAM(Control), LPARAM(Inserting));\r\nend;\r\n\r\nprocedure TJvExCustomMaskEdit.GetDlgCode(var Code: TDlgCodes);\r\nbegin\r\nend;\r\n\r\nprocedure TJvExCustomMaskEdit.FocusSet(PrevWnd: THandle);\r\nbegin\r\n BaseWndProc(WM_SETFOCUS, WPARAM(PrevWnd), 0);\r\nend;\r\n\r\nprocedure TJvExCustomMaskEdit.FocusKilled(NextWnd: THandle);\r\nbegin\r\n BaseWndProc(WM_KILLFOCUS, WPARAM(NextWnd), 0);\r\nend;\r\n\r\nfunction TJvExCustomMaskEdit.DoEraseBackground(Canvas: TCanvas; Param: LPARAM): Boolean;\r\nbegin\r\n Result := BaseWndProc(WM_ERASEBKGND, Canvas.Handle, Param) <> 0;\r\nend;\r\n\r\n{$IFDEF JVCLThemesEnabledD6}\r\nfunction TJvExCustomMaskEdit.GetParentBackground: Boolean;\r\nbegin\r\n Result := JvThemes.GetParentBackground(Self);\r\nend;\r\n\r\nprocedure TJvExCustomMaskEdit.SetParentBackground(Value: Boolean);\r\nbegin\r\n JvThemes.SetParentBackground(Self, Value);\r\nend;\r\n{$ENDIF JVCLThemesEnabledD6}\r\n\r\nprocedure TJvExCustomMaskEdit.SetClipboardCommands(const Value: TJvClipboardCommands);\r\nbegin\r\n FClipboardCommands := Value;\r\nend;\r\n\r\nprocedure TJvExCustomMaskEdit.WndProc(var Msg: TMessage);\r\nvar\r\n IdSaveDC: Integer;\r\n DlgCodes: TDlgCodes;\r\n Canvas: TCanvas;\r\nbegin\r\n if not DispatchIsDesignMsg(Self, Msg) then\r\n begin\r\n case Msg.Msg of\r\n CM_DENYSUBCLASSING:\r\n Msg.Result := LRESULT(Ord(GetInterfaceEntry(IJvDenySubClassing) <> nil));\r\n CM_DIALOGCHAR:\r\n with TCMDialogChar{$IFDEF CLR}.Create{$ENDIF}(Msg) do\r\n Result := LRESULT(Ord(WantKey(CharCode, KeyDataToShiftState(KeyData))));\r\n CM_HINTSHOW:\r\n with TCMHintShow(Msg) do\r\n Result := LRESULT(HintShow(HintInfo^));\r\n CM_HITTEST:\r\n with TCMHitTest(Msg) do\r\n Result := LRESULT(HitTest(XPos, YPos));\r\n CM_MOUSEENTER:\r\n MouseEnter(TControl(Msg.LParam));\r\n CM_MOUSELEAVE:\r\n MouseLeave(TControl(Msg.LParam));\r\n CM_VISIBLECHANGED:\r\n VisibleChanged;\r\n CM_ENABLEDCHANGED:\r\n EnabledChanged;\r\n CM_TEXTCHANGED:\r\n TextChanged;\r\n CM_FONTCHANGED:\r\n FontChanged;\r\n CM_COLORCHANGED:\r\n ColorChanged;\r\n CM_FOCUSCHANGED:\r\n FocusChanged(TWinControl(Msg.LParam));\r\n CM_PARENTFONTCHANGED:\r\n ParentFontChanged;\r\n CM_PARENTCOLORCHANGED:\r\n ParentColorChanged;\r\n CM_PARENTSHOWHINTCHANGED:\r\n ParentShowHintChanged;\r\n CM_CURSORCHANGED:\r\n CursorChanged;\r\n CM_SHOWINGCHANGED:\r\n ShowingChanged;\r\n CM_SHOWHINTCHANGED:\r\n ShowHintChanged;\r\n CM_CONTROLLISTCHANGE:\r\n if Msg.LParam <> 0 then\r\n ControlsListChanging(TControl(Msg.WParam), True)\r\n else\r\n ControlsListChanged(TControl(Msg.WParam), False);\r\n CM_CONTROLCHANGE:\r\n if Msg.LParam = 0 then\r\n ControlsListChanging(TControl(Msg.WParam), False)\r\n else\r\n ControlsListChanged(TControl(Msg.WParam), True);\r\n WM_SETFOCUS:\r\n FocusSet(THandle(Msg.WParam));\r\n WM_KILLFOCUS:\r\n FocusKilled(THandle(Msg.WParam));\r\n WM_SIZE, WM_MOVE:\r\n begin\r\n inherited WndProc(Msg);\r\n BoundsChanged;\r\n end;\r\n WM_ERASEBKGND:\r\n if (Msg.WParam <> 0) and not IsDefaultEraseBackground(DoEraseBackground, @TJvExCustomMaskEdit.DoEraseBackground) then\r\n begin\r\n IdSaveDC := SaveDC(HDC(Msg.WParam)); // protect DC against Stock-Objects from Canvas\r\n Canvas := TCanvas.Create;\r\n try\r\n Canvas.Handle := HDC(Msg.WParam);\r\n Msg.Result := Ord(DoEraseBackground(Canvas, Msg.LParam));\r\n finally\r\n Canvas.Handle := 0;\r\n Canvas.Free;\r\n RestoreDC(HDC(Msg.WParam), IdSaveDC);\r\n end;\r\n end\r\n else\r\n inherited WndProc(Msg);\r\n {$IFNDEF DELPHI2007_UP}\r\n WM_PRINTCLIENT, WM_PRINT: // VCL bug fix\r\n begin\r\n IdSaveDC := SaveDC(HDC(Msg.WParam)); // protect DC against changes\r\n try\r\n inherited WndProc(Msg);\r\n finally\r\n RestoreDC(HDC(Msg.WParam), IdSaveDC);\r\n end;\r\n end;\r\n {$ENDIF ~DELPHI2007_UP}\r\n WM_GETDLGCODE:\r\n begin\r\n inherited WndProc(Msg);\r\n DlgCodes := [dcNative] + DlgcToDlgCodes(Msg.Result);\r\n GetDlgCode(DlgCodes);\r\n if not (dcNative in DlgCodes) then\r\n Msg.Result := DlgCodesToDlgc(DlgCodes);\r\n end;\r\n WM_CLEAR:\r\n if caClear in ClipboardCommands then\r\n inherited WndProc(Msg)\r\n else\r\n Msg.Result := 1;\r\n WM_UNDO, EM_UNDO:\r\n if caUndo in ClipboardCommands then\r\n inherited WndProc(Msg)\r\n else\r\n Msg.Result := 1;\r\n WM_COPY:\r\n if caCopy in ClipboardCommands then\r\n inherited WndProc(Msg)\r\n else\r\n Msg.Result := 1;\r\n WM_CUT:\r\n if caCut in ClipboardCommands then\r\n inherited WndProc(Msg)\r\n else\r\n Msg.Result := 1;\r\n WM_PASTE:\r\n if caPaste in ClipboardCommands then\r\n inherited WndProc(Msg)\r\n else\r\n Msg.Result := 1;\r\n else\r\n inherited WndProc(Msg);\r\n end;\r\n case Msg.Msg of // precheck message to prevent access violations on released controls\r\n CM_MOUSEENTER, CM_MOUSELEAVE, WM_KILLFOCUS, WM_SETFOCUS, WM_NCPAINT:\r\n if DotNetHighlighting then\r\n HandleDotNetHighlighting(Self, Msg, MouseOver, Color);\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvExCustomMaskEdit.DoBeepOnError;\r\nbegin\r\n if FBeepOnError then\r\n SysUtils.Beep;\r\nend;\r\n\r\nprocedure TJvExCustomMaskEdit.SetBeepOnError(Value: Boolean);\r\nbegin\r\n FBeepOnError := Value;\r\nend;\r\n\r\nconstructor TJvExMaskEdit.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FHintColor := clDefault;\r\n FClipboardCommands := [caCopy..caUndo];\r\n FBeepOnError := True;\r\nend;\r\n\r\nfunction TJvExMaskEdit.BaseWndProc(Msg: Cardinal; WParam: WPARAM = 0; LParam: LPARAM = 0): LRESULT;\r\nvar\r\n Mesg: TMessage;\r\nbegin\r\n CreateWMMessage(Mesg, Msg, WParam, LParam);\r\n inherited WndProc(Mesg);\r\n Result := Mesg.Result;\r\nend;\r\n\r\nfunction TJvExMaskEdit.BaseWndProc(Msg: Cardinal; WParam: WPARAM; LParam: TObject): LRESULT;\r\nbegin\r\n Result := BaseWndProc(Msg, WParam, Windows.LPARAM(LParam));\r\nend;\r\n\r\nfunction TJvExMaskEdit.BaseWndProcEx(Msg: Cardinal; WParam: WPARAM; var StructLParam): LRESULT;\r\nbegin\r\n Result := BaseWndProc(Msg, WParam, Windows.LPARAM(@StructLParam));\r\nend;\r\n\r\nprocedure TJvExMaskEdit.VisibleChanged;\r\nbegin\r\n BaseWndProc(CM_VISIBLECHANGED);\r\nend;\r\n\r\nprocedure TJvExMaskEdit.EnabledChanged;\r\nbegin\r\n BaseWndProc(CM_ENABLEDCHANGED);\r\nend;\r\n\r\nprocedure TJvExMaskEdit.TextChanged;\r\nbegin\r\n BaseWndProc(CM_TEXTCHANGED);\r\nend;\r\n\r\nprocedure TJvExMaskEdit.FontChanged;\r\nbegin\r\n BaseWndProc(CM_FONTCHANGED);\r\nend;\r\n\r\nprocedure TJvExMaskEdit.ColorChanged;\r\nbegin\r\n BaseWndProc(CM_COLORCHANGED);\r\nend;\r\n\r\nprocedure TJvExMaskEdit.ParentFontChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTFONTCHANGED);\r\nend;\r\n\r\nprocedure TJvExMaskEdit.ParentColorChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTCOLORCHANGED);\r\n if Assigned(OnParentColorChange) then\r\n OnParentColorChange(Self);\r\nend;\r\n\r\nprocedure TJvExMaskEdit.ParentShowHintChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTSHOWHINTCHANGED);\r\nend;\r\n\r\nfunction TJvExMaskEdit.WantKey(Key: Integer; Shift: TShiftState): Boolean;\r\nbegin\r\n Result := BaseWndProc(CM_DIALOGCHAR, Word(Key), ShiftStateToKeyData(Shift)) <> 0;\r\nend;\r\n\r\nfunction TJvExMaskEdit.HitTest(X, Y: Integer): Boolean;\r\nbegin\r\n Result := BaseWndProc(CM_HITTEST, 0, SmallPointToLong(PointToSmallPoint(Point(X, Y)))) <> 0;\r\nend;\r\n\r\nfunction TJvExMaskEdit.HintShow(var HintInfo: THintInfo): Boolean;\r\nbegin\r\n GetHintColor(HintInfo, Self, FHintColor);\r\n if FHintWindowClass <> nil then\r\n HintInfo.HintWindowClass := FHintWindowClass;\r\n Result := BaseWndProcEx(CM_HINTSHOW, 0, HintInfo) <> 0;\r\nend;\r\n\r\nprocedure TJvExMaskEdit.MouseEnter(AControl: TControl);\r\nbegin\r\n FMouseOver := True;\r\n if Assigned(FOnMouseEnter) then\r\n FOnMouseEnter(Self);\r\n BaseWndProc(CM_MOUSEENTER, 0, AControl);\r\nend;\r\n\r\nprocedure TJvExMaskEdit.MouseLeave(AControl: TControl);\r\nbegin\r\n FMouseOver := False;\r\n BaseWndProc(CM_MOUSELEAVE, 0, AControl);\r\n if Assigned(FOnMouseLeave) then\r\n FOnMouseLeave(Self);\r\nend;\r\n\r\nprocedure TJvExMaskEdit.FocusChanged(AControl: TWinControl);\r\nbegin\r\n BaseWndProc(CM_FOCUSCHANGED, 0, AControl);\r\nend;\r\n\r\nprocedure TJvExMaskEdit.BoundsChanged;\r\nbegin\r\nend;\r\n\r\nprocedure TJvExMaskEdit.CursorChanged;\r\nbegin\r\n BaseWndProc(CM_CURSORCHANGED);\r\nend;\r\n\r\nprocedure TJvExMaskEdit.ShowingChanged;\r\nbegin\r\n BaseWndProc(CM_SHOWINGCHANGED);\r\nend;\r\n\r\nprocedure TJvExMaskEdit.ShowHintChanged;\r\nbegin\r\n BaseWndProc(CM_SHOWHINTCHANGED);\r\nend;\r\n\r\n{ VCL sends CM_CONTROLLISTCHANGE and CM_CONTROLCHANGE in a different order than\r\n the CLX methods are used. So we must correct it by evaluating \"Inserting\". }\r\nprocedure TJvExMaskEdit.ControlsListChanging(Control: TControl; Inserting: Boolean);\r\nbegin\r\n if Inserting then\r\n BaseWndProc(CM_CONTROLLISTCHANGE, WPARAM(Control), LPARAM(Inserting))\r\n else\r\n BaseWndProc(CM_CONTROLCHANGE, WPARAM(Control), LPARAM(Inserting));\r\nend;\r\n\r\nprocedure TJvExMaskEdit.ControlsListChanged(Control: TControl; Inserting: Boolean);\r\nbegin\r\n if not Inserting then\r\n BaseWndProc(CM_CONTROLLISTCHANGE, WPARAM(Control), LPARAM(Inserting))\r\n else\r\n BaseWndProc(CM_CONTROLCHANGE, WPARAM(Control), LPARAM(Inserting));\r\nend;\r\n\r\nprocedure TJvExMaskEdit.GetDlgCode(var Code: TDlgCodes);\r\nbegin\r\nend;\r\n\r\nprocedure TJvExMaskEdit.FocusSet(PrevWnd: THandle);\r\nbegin\r\n BaseWndProc(WM_SETFOCUS, WPARAM(PrevWnd), 0);\r\nend;\r\n\r\nprocedure TJvExMaskEdit.FocusKilled(NextWnd: THandle);\r\nbegin\r\n BaseWndProc(WM_KILLFOCUS, WPARAM(NextWnd), 0);\r\nend;\r\n\r\nfunction TJvExMaskEdit.DoEraseBackground(Canvas: TCanvas; Param: LPARAM): Boolean;\r\nbegin\r\n Result := BaseWndProc(WM_ERASEBKGND, Canvas.Handle, Param) <> 0;\r\nend;\r\n\r\n{$IFDEF JVCLThemesEnabledD6}\r\nfunction TJvExMaskEdit.GetParentBackground: Boolean;\r\nbegin\r\n Result := JvThemes.GetParentBackground(Self);\r\nend;\r\n\r\nprocedure TJvExMaskEdit.SetParentBackground(Value: Boolean);\r\nbegin\r\n JvThemes.SetParentBackground(Self, Value);\r\nend;\r\n{$ENDIF JVCLThemesEnabledD6}\r\n\r\nprocedure TJvExMaskEdit.SetClipboardCommands(const Value: TJvClipboardCommands);\r\nbegin\r\n FClipboardCommands := Value;\r\nend;\r\n\r\nprocedure TJvExMaskEdit.WndProc(var Msg: TMessage);\r\nvar\r\n IdSaveDC: Integer;\r\n DlgCodes: TDlgCodes;\r\n Canvas: TCanvas;\r\nbegin\r\n if not DispatchIsDesignMsg(Self, Msg) then\r\n begin\r\n case Msg.Msg of\r\n CM_DENYSUBCLASSING:\r\n Msg.Result := LRESULT(Ord(GetInterfaceEntry(IJvDenySubClassing) <> nil));\r\n CM_DIALOGCHAR:\r\n with TCMDialogChar{$IFDEF CLR}.Create{$ENDIF}(Msg) do\r\n Result := LRESULT(Ord(WantKey(CharCode, KeyDataToShiftState(KeyData))));\r\n CM_HINTSHOW:\r\n with TCMHintShow(Msg) do\r\n Result := LRESULT(HintShow(HintInfo^));\r\n CM_HITTEST:\r\n with TCMHitTest(Msg) do\r\n Result := LRESULT(HitTest(XPos, YPos));\r\n CM_MOUSEENTER:\r\n MouseEnter(TControl(Msg.LParam));\r\n CM_MOUSELEAVE:\r\n MouseLeave(TControl(Msg.LParam));\r\n CM_VISIBLECHANGED:\r\n VisibleChanged;\r\n CM_ENABLEDCHANGED:\r\n EnabledChanged;\r\n CM_TEXTCHANGED:\r\n TextChanged;\r\n CM_FONTCHANGED:\r\n FontChanged;\r\n CM_COLORCHANGED:\r\n ColorChanged;\r\n CM_FOCUSCHANGED:\r\n FocusChanged(TWinControl(Msg.LParam));\r\n CM_PARENTFONTCHANGED:\r\n ParentFontChanged;\r\n CM_PARENTCOLORCHANGED:\r\n ParentColorChanged;\r\n CM_PARENTSHOWHINTCHANGED:\r\n ParentShowHintChanged;\r\n CM_CURSORCHANGED:\r\n CursorChanged;\r\n CM_SHOWINGCHANGED:\r\n ShowingChanged;\r\n CM_SHOWHINTCHANGED:\r\n ShowHintChanged;\r\n CM_CONTROLLISTCHANGE:\r\n if Msg.LParam <> 0 then\r\n ControlsListChanging(TControl(Msg.WParam), True)\r\n else\r\n ControlsListChanged(TControl(Msg.WParam), False);\r\n CM_CONTROLCHANGE:\r\n if Msg.LParam = 0 then\r\n ControlsListChanging(TControl(Msg.WParam), False)\r\n else\r\n ControlsListChanged(TControl(Msg.WParam), True);\r\n WM_SETFOCUS:\r\n FocusSet(THandle(Msg.WParam));\r\n WM_KILLFOCUS:\r\n FocusKilled(THandle(Msg.WParam));\r\n WM_SIZE, WM_MOVE:\r\n begin\r\n inherited WndProc(Msg);\r\n BoundsChanged;\r\n end;\r\n WM_ERASEBKGND:\r\n if (Msg.WParam <> 0) and not IsDefaultEraseBackground(DoEraseBackground, @TJvExMaskEdit.DoEraseBackground) then\r\n begin\r\n IdSaveDC := SaveDC(HDC(Msg.WParam)); // protect DC against Stock-Objects from Canvas\r\n Canvas := TCanvas.Create;\r\n try\r\n Canvas.Handle := HDC(Msg.WParam);\r\n Msg.Result := Ord(DoEraseBackground(Canvas, Msg.LParam));\r\n finally\r\n Canvas.Handle := 0;\r\n Canvas.Free;\r\n RestoreDC(HDC(Msg.WParam), IdSaveDC);\r\n end;\r\n end\r\n else\r\n inherited WndProc(Msg);\r\n {$IFNDEF DELPHI2007_UP}\r\n WM_PRINTCLIENT, WM_PRINT: // VCL bug fix\r\n begin\r\n IdSaveDC := SaveDC(HDC(Msg.WParam)); // protect DC against changes\r\n try\r\n inherited WndProc(Msg);\r\n finally\r\n RestoreDC(HDC(Msg.WParam), IdSaveDC);\r\n end;\r\n end;\r\n {$ENDIF ~DELPHI2007_UP}\r\n WM_GETDLGCODE:\r\n begin\r\n inherited WndProc(Msg);\r\n DlgCodes := [dcNative] + DlgcToDlgCodes(Msg.Result);\r\n GetDlgCode(DlgCodes);\r\n if not (dcNative in DlgCodes) then\r\n Msg.Result := DlgCodesToDlgc(DlgCodes);\r\n end;\r\n WM_CLEAR:\r\n if caClear in ClipboardCommands then\r\n inherited WndProc(Msg)\r\n else\r\n Msg.Result := 1;\r\n WM_UNDO, EM_UNDO:\r\n if caUndo in ClipboardCommands then\r\n inherited WndProc(Msg)\r\n else\r\n Msg.Result := 1;\r\n WM_COPY:\r\n if caCopy in ClipboardCommands then\r\n inherited WndProc(Msg)\r\n else\r\n Msg.Result := 1;\r\n WM_CUT:\r\n if caCut in ClipboardCommands then\r\n inherited WndProc(Msg)\r\n else\r\n Msg.Result := 1;\r\n WM_PASTE:\r\n if caPaste in ClipboardCommands then\r\n inherited WndProc(Msg)\r\n else\r\n Msg.Result := 1;\r\n else\r\n inherited WndProc(Msg);\r\n end;\r\n case Msg.Msg of // precheck message to prevent access violations on released controls\r\n CM_MOUSEENTER, CM_MOUSELEAVE, WM_KILLFOCUS, WM_SETFOCUS, WM_NCPAINT:\r\n if DotNetHighlighting then\r\n HandleDotNetHighlighting(Self, Msg, MouseOver, Color);\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvExMaskEdit.DoBeepOnError;\r\nbegin\r\n if FBeepOnError then\r\n SysUtils.Beep;\r\nend;\r\n\r\nprocedure TJvExMaskEdit.SetBeepOnError(Value: Boolean);\r\nbegin\r\n FBeepOnError := Value;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\n{$UNDEF CONSTRUCTOR_CODE} // undefine at file end\r\n\r\nend." }, { "path": "External/Jedi/Jvcl/run/JvExStdCtrls.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvExStdCtrls.pas, released on 2004-01-04\r\n\r\nThe Initial Developer of the Original Code is Andreas Hausladen [Andreas dott Hausladen att gmx dott de]\r\nPortions created by Andreas Hausladen are Copyright (C) 2003 Andreas Hausladen.\r\nAll Rights Reserved.\r\n\r\nContributor(s): -\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvExStdCtrls.pas 13173 2011-11-19 12:43:58Z ahuser $\r\n\r\nunit JvExStdCtrls;\r\n\r\n{$I jvcl.inc}\r\n{MACROINCLUDE JvExControls.macros}\r\n\r\n{*****************************************************************************\r\n * WARNING: Do not edit this file.\r\n * This file is autogenerated from the source in devtools/JvExVCL/src.\r\n * If you do it despite this warning your changes will be discarded by the next\r\n * update of this file. Do your changes in the template files.\r\n ****************************************************************************}\r\n{$D-} // do not step into this unit\r\n\r\ninterface\r\n\r\nuses\r\n Windows, Messages, Types,\r\n SysUtils, Classes, Graphics, Controls, Forms, StdCtrls,\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n JvTypes, JvThemes, JVCLVer, JvExControls;\r\n\r\ntype\r\n TJvExCustomGroupBox = class(TCustomGroupBox, IJvExControl)\r\n private\r\n FAboutJVCL: TJVCLAboutInfo;\r\n FHintColor: TColor;\r\n FMouseOver: Boolean;\r\n FHintWindowClass: THintWindowClass;\r\n FOnMouseEnter: TNotifyEvent;\r\n FOnMouseLeave: TNotifyEvent;\r\n FOnParentColorChanged: TNotifyEvent;\r\n function BaseWndProc(Msg: Cardinal; WParam: WPARAM = 0; LParam: LPARAM = 0): LRESULT; overload;\r\n function BaseWndProc(Msg: Cardinal; WParam: WPARAM; LParam: TObject): LRESULT; overload;\r\n function BaseWndProcEx(Msg: Cardinal; WParam: WPARAM; var StructLParam): LRESULT;\r\n protected\r\n procedure WndProc(var Msg: TMessage); override;\r\n procedure FocusChanged(AControl: TWinControl); dynamic;\r\n procedure VisibleChanged; reintroduce; dynamic;\r\n procedure EnabledChanged; reintroduce; dynamic;\r\n procedure TextChanged; reintroduce; virtual;\r\n procedure ColorChanged; reintroduce; dynamic;\r\n procedure FontChanged; reintroduce; dynamic;\r\n procedure ParentFontChanged; reintroduce; dynamic;\r\n procedure ParentColorChanged; reintroduce; dynamic;\r\n procedure ParentShowHintChanged; reintroduce; dynamic;\r\n function WantKey(Key: Integer; Shift: TShiftState): Boolean; virtual;\r\n function HintShow(var HintInfo: THintInfo): Boolean; reintroduce; dynamic;\r\n function HitTest(X, Y: Integer): Boolean; reintroduce; virtual;\r\n procedure MouseEnter(AControl: TControl); reintroduce; dynamic;\r\n procedure MouseLeave(AControl: TControl); reintroduce; dynamic;\r\n property MouseOver: Boolean read FMouseOver write FMouseOver;\r\n property HintColor: TColor read FHintColor write FHintColor default clDefault;\r\n property OnMouseEnter: TNotifyEvent read FOnMouseEnter write FOnMouseEnter;\r\n property OnMouseLeave: TNotifyEvent read FOnMouseLeave write FOnMouseLeave;\r\n property OnParentColorChange: TNotifyEvent read FOnParentColorChanged write FOnParentColorChanged;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n property HintWindowClass: THintWindowClass read FHintWindowClass write FHintWindowClass;\r\n published\r\n property AboutJVCL: TJVCLAboutInfo read FAboutJVCL write FAboutJVCL stored False;\r\n private\r\n FDotNetHighlighting: Boolean;\r\n protected\r\n procedure BoundsChanged; reintroduce; virtual;\r\n procedure CursorChanged; reintroduce; dynamic;\r\n procedure ShowingChanged; reintroduce; dynamic;\r\n procedure ShowHintChanged; reintroduce; dynamic;\r\n procedure ControlsListChanging(Control: TControl; Inserting: Boolean); reintroduce; dynamic;\r\n procedure ControlsListChanged(Control: TControl; Inserting: Boolean); reintroduce; dynamic;\r\n procedure GetDlgCode(var Code: TDlgCodes); virtual;\r\n procedure FocusSet(PrevWnd: THandle); virtual;\r\n procedure FocusKilled(NextWnd: THandle); virtual;\r\n function DoEraseBackground(Canvas: TCanvas; Param: LPARAM): Boolean; virtual;\r\n {$IFDEF JVCLThemesEnabledD6}\r\n private\r\n function GetParentBackground: Boolean;\r\n protected\r\n procedure SetParentBackground(Value: Boolean); virtual;\r\n property ParentBackground: Boolean read GetParentBackground write SetParentBackground;\r\n {$ENDIF JVCLThemesEnabledD6}\r\n published\r\n property DotNetHighlighting: Boolean read FDotNetHighlighting write FDotNetHighlighting default False;\r\n end;\r\n\r\n {$DEFINE HASAUTOSIZE}\r\n\r\n TJvExCustomLabel = class(TCustomLabel, IJvExControl)\r\n private\r\n FAboutJVCL: TJVCLAboutInfo;\r\n FHintColor: TColor;\r\n FMouseOver: Boolean;\r\n FHintWindowClass: THintWindowClass;\r\n FOnMouseEnter: TNotifyEvent;\r\n FOnMouseLeave: TNotifyEvent;\r\n FOnParentColorChanged: TNotifyEvent;\r\n function BaseWndProc(Msg: Cardinal; WParam: WPARAM = 0; LParam: LPARAM = 0): LRESULT; overload;\r\n function BaseWndProc(Msg: Cardinal; WParam: WPARAM; LParam: TObject): LRESULT; overload;\r\n function BaseWndProcEx(Msg: Cardinal; WParam: WPARAM; var StructLParam): LRESULT;\r\n protected\r\n procedure WndProc(var Msg: TMessage); override;\r\n procedure FocusChanged(AControl: TWinControl); dynamic;\r\n procedure VisibleChanged; reintroduce; dynamic;\r\n procedure EnabledChanged; reintroduce; dynamic;\r\n procedure TextChanged; reintroduce; virtual;\r\n procedure ColorChanged; reintroduce; dynamic;\r\n procedure FontChanged; reintroduce; dynamic;\r\n procedure ParentFontChanged; reintroduce; dynamic;\r\n procedure ParentColorChanged; reintroduce; dynamic;\r\n procedure ParentShowHintChanged; reintroduce; dynamic;\r\n function WantKey(Key: Integer; Shift: TShiftState): Boolean; virtual;\r\n function HintShow(var HintInfo: THintInfo): Boolean; reintroduce; dynamic;\r\n function HitTest(X, Y: Integer): Boolean; reintroduce; virtual;\r\n procedure MouseEnter(AControl: TControl); reintroduce; dynamic;\r\n procedure MouseLeave(AControl: TControl); reintroduce; dynamic;\r\n property MouseOver: Boolean read FMouseOver write FMouseOver;\r\n property HintColor: TColor read FHintColor write FHintColor default clDefault;\r\n property OnMouseEnter: TNotifyEvent read FOnMouseEnter write FOnMouseEnter;\r\n property OnMouseLeave: TNotifyEvent read FOnMouseLeave write FOnMouseLeave;\r\n property OnParentColorChange: TNotifyEvent read FOnParentColorChanged write FOnParentColorChanged;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n property HintWindowClass: THintWindowClass read FHintWindowClass write FHintWindowClass;\r\n published\r\n property AboutJVCL: TJVCLAboutInfo read FAboutJVCL write FAboutJVCL stored False;\r\n end;\r\n\r\n TJvExLabel = class(TLabel, IJvExControl)\r\n private\r\n FAboutJVCL: TJVCLAboutInfo;\r\n FHintColor: TColor;\r\n FMouseOver: Boolean;\r\n FHintWindowClass: THintWindowClass;\r\n FOnMouseEnter: TNotifyEvent;\r\n FOnMouseLeave: TNotifyEvent;\r\n FOnParentColorChanged: TNotifyEvent;\r\n function BaseWndProc(Msg: Cardinal; WParam: WPARAM = 0; LParam: LPARAM = 0): LRESULT; overload;\r\n function BaseWndProc(Msg: Cardinal; WParam: WPARAM; LParam: TObject): LRESULT; overload;\r\n function BaseWndProcEx(Msg: Cardinal; WParam: WPARAM; var StructLParam): LRESULT;\r\n protected\r\n procedure WndProc(var Msg: TMessage); override;\r\n procedure FocusChanged(AControl: TWinControl); dynamic;\r\n procedure VisibleChanged; reintroduce; dynamic;\r\n procedure EnabledChanged; reintroduce; dynamic;\r\n procedure TextChanged; reintroduce; virtual;\r\n procedure ColorChanged; reintroduce; dynamic;\r\n procedure FontChanged; reintroduce; dynamic;\r\n procedure ParentFontChanged; reintroduce; dynamic;\r\n procedure ParentColorChanged; reintroduce; dynamic;\r\n procedure ParentShowHintChanged; reintroduce; dynamic;\r\n function WantKey(Key: Integer; Shift: TShiftState): Boolean; virtual;\r\n function HintShow(var HintInfo: THintInfo): Boolean; reintroduce; dynamic;\r\n function HitTest(X, Y: Integer): Boolean; reintroduce; virtual;\r\n procedure MouseEnter(AControl: TControl); reintroduce; dynamic;\r\n procedure MouseLeave(AControl: TControl); reintroduce; dynamic;\r\n property MouseOver: Boolean read FMouseOver write FMouseOver;\r\n property HintColor: TColor read FHintColor write FHintColor default clDefault;\r\n property OnMouseEnter: TNotifyEvent read FOnMouseEnter write FOnMouseEnter;\r\n property OnMouseLeave: TNotifyEvent read FOnMouseLeave write FOnMouseLeave;\r\n property OnParentColorChange: TNotifyEvent read FOnParentColorChanged write FOnParentColorChanged;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n property HintWindowClass: THintWindowClass read FHintWindowClass write FHintWindowClass;\r\n published\r\n property AboutJVCL: TJVCLAboutInfo read FAboutJVCL write FAboutJVCL stored False;\r\n end;\r\n\r\n {$UNDEF HASAUTOSIZE}\r\n\r\n TJvExCustomEdit = class(TCustomEdit, IJvExControl)\r\n private\r\n FAboutJVCL: TJVCLAboutInfo;\r\n FHintColor: TColor;\r\n FMouseOver: Boolean;\r\n FHintWindowClass: THintWindowClass;\r\n FOnMouseEnter: TNotifyEvent;\r\n FOnMouseLeave: TNotifyEvent;\r\n FOnParentColorChanged: TNotifyEvent;\r\n function BaseWndProc(Msg: Cardinal; WParam: WPARAM = 0; LParam: LPARAM = 0): LRESULT; overload;\r\n function BaseWndProc(Msg: Cardinal; WParam: WPARAM; LParam: TObject): LRESULT; overload;\r\n function BaseWndProcEx(Msg: Cardinal; WParam: WPARAM; var StructLParam): LRESULT;\r\n protected\r\n procedure WndProc(var Msg: TMessage); override;\r\n procedure FocusChanged(AControl: TWinControl); dynamic;\r\n procedure VisibleChanged; reintroduce; dynamic;\r\n procedure EnabledChanged; reintroduce; dynamic;\r\n procedure TextChanged; reintroduce; virtual;\r\n procedure ColorChanged; reintroduce; dynamic;\r\n procedure FontChanged; reintroduce; dynamic;\r\n procedure ParentFontChanged; reintroduce; dynamic;\r\n procedure ParentColorChanged; reintroduce; dynamic;\r\n procedure ParentShowHintChanged; reintroduce; dynamic;\r\n function WantKey(Key: Integer; Shift: TShiftState): Boolean; virtual;\r\n function HintShow(var HintInfo: THintInfo): Boolean; reintroduce; dynamic;\r\n function HitTest(X, Y: Integer): Boolean; reintroduce; virtual;\r\n procedure MouseEnter(AControl: TControl); reintroduce; dynamic;\r\n procedure MouseLeave(AControl: TControl); reintroduce; dynamic;\r\n property MouseOver: Boolean read FMouseOver write FMouseOver;\r\n property HintColor: TColor read FHintColor write FHintColor default clDefault;\r\n property OnMouseEnter: TNotifyEvent read FOnMouseEnter write FOnMouseEnter;\r\n property OnMouseLeave: TNotifyEvent read FOnMouseLeave write FOnMouseLeave;\r\n property OnParentColorChange: TNotifyEvent read FOnParentColorChanged write FOnParentColorChanged;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n property HintWindowClass: THintWindowClass read FHintWindowClass write FHintWindowClass;\r\n published\r\n property AboutJVCL: TJVCLAboutInfo read FAboutJVCL write FAboutJVCL stored False;\r\n private\r\n FDotNetHighlighting: Boolean;\r\n protected\r\n procedure BoundsChanged; reintroduce; virtual;\r\n procedure CursorChanged; reintroduce; dynamic;\r\n procedure ShowingChanged; reintroduce; dynamic;\r\n procedure ShowHintChanged; reintroduce; dynamic;\r\n procedure ControlsListChanging(Control: TControl; Inserting: Boolean); reintroduce; dynamic;\r\n procedure ControlsListChanged(Control: TControl; Inserting: Boolean); reintroduce; dynamic;\r\n procedure GetDlgCode(var Code: TDlgCodes); virtual;\r\n procedure FocusSet(PrevWnd: THandle); virtual;\r\n procedure FocusKilled(NextWnd: THandle); virtual;\r\n function DoEraseBackground(Canvas: TCanvas; Param: LPARAM): Boolean; virtual;\r\n {$IFDEF JVCLThemesEnabledD6}\r\n private\r\n function GetParentBackground: Boolean;\r\n protected\r\n procedure SetParentBackground(Value: Boolean); virtual;\r\n property ParentBackground: Boolean read GetParentBackground write SetParentBackground;\r\n {$ENDIF JVCLThemesEnabledD6}\r\n published\r\n property DotNetHighlighting: Boolean read FDotNetHighlighting write FDotNetHighlighting default False;\r\n private\r\n FClipboardCommands: TJvClipboardCommands;\r\n protected\r\n procedure SetClipboardCommands(const Value: TJvClipboardCommands); virtual;\r\n property ClipboardCommands: TJvClipboardCommands read FClipboardCommands write SetClipboardCommands default [caCopy..caUndo];\r\n end;\r\n\r\n TJvExCustomMemo = class(TCustomMemo, IJvExControl)\r\n private\r\n FAboutJVCL: TJVCLAboutInfo;\r\n FHintColor: TColor;\r\n FMouseOver: Boolean;\r\n FHintWindowClass: THintWindowClass;\r\n FOnMouseEnter: TNotifyEvent;\r\n FOnMouseLeave: TNotifyEvent;\r\n FOnParentColorChanged: TNotifyEvent;\r\n function BaseWndProc(Msg: Cardinal; WParam: WPARAM = 0; LParam: LPARAM = 0): LRESULT; overload;\r\n function BaseWndProc(Msg: Cardinal; WParam: WPARAM; LParam: TObject): LRESULT; overload;\r\n function BaseWndProcEx(Msg: Cardinal; WParam: WPARAM; var StructLParam): LRESULT;\r\n protected\r\n procedure WndProc(var Msg: TMessage); override;\r\n procedure FocusChanged(AControl: TWinControl); dynamic;\r\n procedure VisibleChanged; reintroduce; dynamic;\r\n procedure EnabledChanged; reintroduce; dynamic;\r\n procedure TextChanged; reintroduce; virtual;\r\n procedure ColorChanged; reintroduce; dynamic;\r\n procedure FontChanged; reintroduce; dynamic;\r\n procedure ParentFontChanged; reintroduce; dynamic;\r\n procedure ParentColorChanged; reintroduce; dynamic;\r\n procedure ParentShowHintChanged; reintroduce; dynamic;\r\n function WantKey(Key: Integer; Shift: TShiftState): Boolean; virtual;\r\n function HintShow(var HintInfo: THintInfo): Boolean; reintroduce; dynamic;\r\n function HitTest(X, Y: Integer): Boolean; reintroduce; virtual;\r\n procedure MouseEnter(AControl: TControl); reintroduce; dynamic;\r\n procedure MouseLeave(AControl: TControl); reintroduce; dynamic;\r\n property MouseOver: Boolean read FMouseOver write FMouseOver;\r\n property HintColor: TColor read FHintColor write FHintColor default clDefault;\r\n property OnMouseEnter: TNotifyEvent read FOnMouseEnter write FOnMouseEnter;\r\n property OnMouseLeave: TNotifyEvent read FOnMouseLeave write FOnMouseLeave;\r\n property OnParentColorChange: TNotifyEvent read FOnParentColorChanged write FOnParentColorChanged;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n property HintWindowClass: THintWindowClass read FHintWindowClass write FHintWindowClass;\r\n published\r\n property AboutJVCL: TJVCLAboutInfo read FAboutJVCL write FAboutJVCL stored False;\r\n private\r\n FDotNetHighlighting: Boolean;\r\n protected\r\n procedure BoundsChanged; reintroduce; virtual;\r\n procedure CursorChanged; reintroduce; dynamic;\r\n procedure ShowingChanged; reintroduce; dynamic;\r\n procedure ShowHintChanged; reintroduce; dynamic;\r\n procedure ControlsListChanging(Control: TControl; Inserting: Boolean); reintroduce; dynamic;\r\n procedure ControlsListChanged(Control: TControl; Inserting: Boolean); reintroduce; dynamic;\r\n procedure GetDlgCode(var Code: TDlgCodes); virtual;\r\n procedure FocusSet(PrevWnd: THandle); virtual;\r\n procedure FocusKilled(NextWnd: THandle); virtual;\r\n function DoEraseBackground(Canvas: TCanvas; Param: LPARAM): Boolean; virtual;\r\n {$IFDEF JVCLThemesEnabledD6}\r\n private\r\n function GetParentBackground: Boolean;\r\n protected\r\n procedure SetParentBackground(Value: Boolean); virtual;\r\n property ParentBackground: Boolean read GetParentBackground write SetParentBackground;\r\n {$ENDIF JVCLThemesEnabledD6}\r\n published\r\n property DotNetHighlighting: Boolean read FDotNetHighlighting write FDotNetHighlighting default False;\r\n private\r\n FClipboardCommands: TJvClipboardCommands;\r\n protected\r\n procedure SetClipboardCommands(const Value: TJvClipboardCommands); virtual;\r\n property ClipboardCommands: TJvClipboardCommands read FClipboardCommands write SetClipboardCommands default [caCopy..caUndo];\r\n end;\r\n\r\n TJvExCustomCombo = class(TCustomCombo, IJvExControl)\r\n private\r\n FAboutJVCL: TJVCLAboutInfo;\r\n FHintColor: TColor;\r\n FMouseOver: Boolean;\r\n FHintWindowClass: THintWindowClass;\r\n FOnMouseEnter: TNotifyEvent;\r\n FOnMouseLeave: TNotifyEvent;\r\n FOnParentColorChanged: TNotifyEvent;\r\n function BaseWndProc(Msg: Cardinal; WParam: WPARAM = 0; LParam: LPARAM = 0): LRESULT; overload;\r\n function BaseWndProc(Msg: Cardinal; WParam: WPARAM; LParam: TObject): LRESULT; overload;\r\n function BaseWndProcEx(Msg: Cardinal; WParam: WPARAM; var StructLParam): LRESULT;\r\n protected\r\n procedure WndProc(var Msg: TMessage); override;\r\n procedure FocusChanged(AControl: TWinControl); dynamic;\r\n procedure VisibleChanged; reintroduce; dynamic;\r\n procedure EnabledChanged; reintroduce; dynamic;\r\n procedure TextChanged; reintroduce; virtual;\r\n procedure ColorChanged; reintroduce; dynamic;\r\n procedure FontChanged; reintroduce; dynamic;\r\n procedure ParentFontChanged; reintroduce; dynamic;\r\n procedure ParentColorChanged; reintroduce; dynamic;\r\n procedure ParentShowHintChanged; reintroduce; dynamic;\r\n function WantKey(Key: Integer; Shift: TShiftState): Boolean; virtual;\r\n function HintShow(var HintInfo: THintInfo): Boolean; reintroduce; dynamic;\r\n function HitTest(X, Y: Integer): Boolean; reintroduce; virtual;\r\n procedure MouseEnter(AControl: TControl); reintroduce; dynamic;\r\n procedure MouseLeave(AControl: TControl); reintroduce; dynamic;\r\n property MouseOver: Boolean read FMouseOver write FMouseOver;\r\n property HintColor: TColor read FHintColor write FHintColor default clDefault;\r\n property OnMouseEnter: TNotifyEvent read FOnMouseEnter write FOnMouseEnter;\r\n property OnMouseLeave: TNotifyEvent read FOnMouseLeave write FOnMouseLeave;\r\n property OnParentColorChange: TNotifyEvent read FOnParentColorChanged write FOnParentColorChanged;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n property HintWindowClass: THintWindowClass read FHintWindowClass write FHintWindowClass;\r\n published\r\n property AboutJVCL: TJVCLAboutInfo read FAboutJVCL write FAboutJVCL stored False;\r\n private\r\n FDotNetHighlighting: Boolean;\r\n protected\r\n procedure BoundsChanged; reintroduce; virtual;\r\n procedure CursorChanged; reintroduce; dynamic;\r\n procedure ShowingChanged; reintroduce; dynamic;\r\n procedure ShowHintChanged; reintroduce; dynamic;\r\n procedure ControlsListChanging(Control: TControl; Inserting: Boolean); reintroduce; dynamic;\r\n procedure ControlsListChanged(Control: TControl; Inserting: Boolean); reintroduce; dynamic;\r\n procedure GetDlgCode(var Code: TDlgCodes); virtual;\r\n procedure FocusSet(PrevWnd: THandle); virtual;\r\n procedure FocusKilled(NextWnd: THandle); virtual;\r\n function DoEraseBackground(Canvas: TCanvas; Param: LPARAM): Boolean; virtual;\r\n {$IFDEF JVCLThemesEnabledD6}\r\n private\r\n function GetParentBackground: Boolean;\r\n protected\r\n procedure SetParentBackground(Value: Boolean); virtual;\r\n property ParentBackground: Boolean read GetParentBackground write SetParentBackground;\r\n {$ENDIF JVCLThemesEnabledD6}\r\n published\r\n property DotNetHighlighting: Boolean read FDotNetHighlighting write FDotNetHighlighting default False;\r\n end;\r\n\r\n TJvExCustomComboBox = class(TCustomComboBox, IJvExControl)\r\n private\r\n FAboutJVCL: TJVCLAboutInfo;\r\n FHintColor: TColor;\r\n FMouseOver: Boolean;\r\n FHintWindowClass: THintWindowClass;\r\n FOnMouseEnter: TNotifyEvent;\r\n FOnMouseLeave: TNotifyEvent;\r\n FOnParentColorChanged: TNotifyEvent;\r\n function BaseWndProc(Msg: Cardinal; WParam: WPARAM = 0; LParam: LPARAM = 0): LRESULT; overload;\r\n function BaseWndProc(Msg: Cardinal; WParam: WPARAM; LParam: TObject): LRESULT; overload;\r\n function BaseWndProcEx(Msg: Cardinal; WParam: WPARAM; var StructLParam): LRESULT;\r\n protected\r\n procedure WndProc(var Msg: TMessage); override;\r\n procedure FocusChanged(AControl: TWinControl); dynamic;\r\n procedure VisibleChanged; reintroduce; dynamic;\r\n procedure EnabledChanged; reintroduce; dynamic;\r\n procedure TextChanged; reintroduce; virtual;\r\n procedure ColorChanged; reintroduce; dynamic;\r\n procedure FontChanged; reintroduce; dynamic;\r\n procedure ParentFontChanged; reintroduce; dynamic;\r\n procedure ParentColorChanged; reintroduce; dynamic;\r\n procedure ParentShowHintChanged; reintroduce; dynamic;\r\n function WantKey(Key: Integer; Shift: TShiftState): Boolean; virtual;\r\n function HintShow(var HintInfo: THintInfo): Boolean; reintroduce; dynamic;\r\n function HitTest(X, Y: Integer): Boolean; reintroduce; virtual;\r\n procedure MouseEnter(AControl: TControl); reintroduce; dynamic;\r\n procedure MouseLeave(AControl: TControl); reintroduce; dynamic;\r\n property MouseOver: Boolean read FMouseOver write FMouseOver;\r\n property HintColor: TColor read FHintColor write FHintColor default clDefault;\r\n property OnMouseEnter: TNotifyEvent read FOnMouseEnter write FOnMouseEnter;\r\n property OnMouseLeave: TNotifyEvent read FOnMouseLeave write FOnMouseLeave;\r\n property OnParentColorChange: TNotifyEvent read FOnParentColorChanged write FOnParentColorChanged;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n property HintWindowClass: THintWindowClass read FHintWindowClass write FHintWindowClass;\r\n published\r\n property AboutJVCL: TJVCLAboutInfo read FAboutJVCL write FAboutJVCL stored False;\r\n private\r\n FDotNetHighlighting: Boolean;\r\n protected\r\n procedure BoundsChanged; reintroduce; virtual;\r\n procedure CursorChanged; reintroduce; dynamic;\r\n procedure ShowingChanged; reintroduce; dynamic;\r\n procedure ShowHintChanged; reintroduce; dynamic;\r\n procedure ControlsListChanging(Control: TControl; Inserting: Boolean); reintroduce; dynamic;\r\n procedure ControlsListChanged(Control: TControl; Inserting: Boolean); reintroduce; dynamic;\r\n procedure GetDlgCode(var Code: TDlgCodes); virtual;\r\n procedure FocusSet(PrevWnd: THandle); virtual;\r\n procedure FocusKilled(NextWnd: THandle); virtual;\r\n function DoEraseBackground(Canvas: TCanvas; Param: LPARAM): Boolean; virtual;\r\n {$IFDEF JVCLThemesEnabledD6}\r\n private\r\n function GetParentBackground: Boolean;\r\n protected\r\n procedure SetParentBackground(Value: Boolean); virtual;\r\n property ParentBackground: Boolean read GetParentBackground write SetParentBackground;\r\n {$ENDIF JVCLThemesEnabledD6}\r\n published\r\n property DotNetHighlighting: Boolean read FDotNetHighlighting write FDotNetHighlighting default False;\r\n end;\r\n\r\n TJvExButtonControl = class(TButtonControl, IJvExControl)\r\n private\r\n FAboutJVCL: TJVCLAboutInfo;\r\n FHintColor: TColor;\r\n FMouseOver: Boolean;\r\n FHintWindowClass: THintWindowClass;\r\n FOnMouseEnter: TNotifyEvent;\r\n FOnMouseLeave: TNotifyEvent;\r\n FOnParentColorChanged: TNotifyEvent;\r\n function BaseWndProc(Msg: Cardinal; WParam: WPARAM = 0; LParam: LPARAM = 0): LRESULT; overload;\r\n function BaseWndProc(Msg: Cardinal; WParam: WPARAM; LParam: TObject): LRESULT; overload;\r\n function BaseWndProcEx(Msg: Cardinal; WParam: WPARAM; var StructLParam): LRESULT;\r\n protected\r\n procedure WndProc(var Msg: TMessage); override;\r\n procedure FocusChanged(AControl: TWinControl); dynamic;\r\n procedure VisibleChanged; reintroduce; dynamic;\r\n procedure EnabledChanged; reintroduce; dynamic;\r\n procedure TextChanged; reintroduce; virtual;\r\n procedure ColorChanged; reintroduce; dynamic;\r\n procedure FontChanged; reintroduce; dynamic;\r\n procedure ParentFontChanged; reintroduce; dynamic;\r\n procedure ParentColorChanged; reintroduce; dynamic;\r\n procedure ParentShowHintChanged; reintroduce; dynamic;\r\n function WantKey(Key: Integer; Shift: TShiftState): Boolean; virtual;\r\n function HintShow(var HintInfo: THintInfo): Boolean; reintroduce; dynamic;\r\n function HitTest(X, Y: Integer): Boolean; reintroduce; virtual;\r\n procedure MouseEnter(AControl: TControl); reintroduce; dynamic;\r\n procedure MouseLeave(AControl: TControl); reintroduce; dynamic;\r\n property MouseOver: Boolean read FMouseOver write FMouseOver;\r\n property HintColor: TColor read FHintColor write FHintColor default clDefault;\r\n property OnMouseEnter: TNotifyEvent read FOnMouseEnter write FOnMouseEnter;\r\n property OnMouseLeave: TNotifyEvent read FOnMouseLeave write FOnMouseLeave;\r\n property OnParentColorChange: TNotifyEvent read FOnParentColorChanged write FOnParentColorChanged;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n property HintWindowClass: THintWindowClass read FHintWindowClass write FHintWindowClass;\r\n published\r\n property AboutJVCL: TJVCLAboutInfo read FAboutJVCL write FAboutJVCL stored False;\r\n private\r\n FDotNetHighlighting: Boolean;\r\n protected\r\n procedure BoundsChanged; reintroduce; virtual;\r\n procedure CursorChanged; reintroduce; dynamic;\r\n procedure ShowingChanged; reintroduce; dynamic;\r\n procedure ShowHintChanged; reintroduce; dynamic;\r\n procedure ControlsListChanging(Control: TControl; Inserting: Boolean); reintroduce; dynamic;\r\n procedure ControlsListChanged(Control: TControl; Inserting: Boolean); reintroduce; dynamic;\r\n procedure GetDlgCode(var Code: TDlgCodes); virtual;\r\n procedure FocusSet(PrevWnd: THandle); virtual;\r\n procedure FocusKilled(NextWnd: THandle); virtual;\r\n function DoEraseBackground(Canvas: TCanvas; Param: LPARAM): Boolean; virtual;\r\n {$IFDEF JVCLThemesEnabledD6}\r\n private\r\n function GetParentBackground: Boolean;\r\n protected\r\n procedure SetParentBackground(Value: Boolean); virtual;\r\n property ParentBackground: Boolean read GetParentBackground write SetParentBackground;\r\n {$ENDIF JVCLThemesEnabledD6}\r\n published\r\n property DotNetHighlighting: Boolean read FDotNetHighlighting write FDotNetHighlighting default False;\r\n end;\r\n\r\n TJvExButton = class(TButton, IJvExControl)\r\n private\r\n FAboutJVCL: TJVCLAboutInfo;\r\n FHintColor: TColor;\r\n FMouseOver: Boolean;\r\n FHintWindowClass: THintWindowClass;\r\n FOnMouseEnter: TNotifyEvent;\r\n FOnMouseLeave: TNotifyEvent;\r\n FOnParentColorChanged: TNotifyEvent;\r\n function BaseWndProc(Msg: Cardinal; WParam: WPARAM = 0; LParam: LPARAM = 0): LRESULT; overload;\r\n function BaseWndProc(Msg: Cardinal; WParam: WPARAM; LParam: TObject): LRESULT; overload;\r\n function BaseWndProcEx(Msg: Cardinal; WParam: WPARAM; var StructLParam): LRESULT;\r\n protected\r\n procedure WndProc(var Msg: TMessage); override;\r\n procedure FocusChanged(AControl: TWinControl); dynamic;\r\n procedure VisibleChanged; reintroduce; dynamic;\r\n procedure EnabledChanged; reintroduce; dynamic;\r\n procedure TextChanged; reintroduce; virtual;\r\n procedure ColorChanged; reintroduce; dynamic;\r\n procedure FontChanged; reintroduce; dynamic;\r\n procedure ParentFontChanged; reintroduce; dynamic;\r\n procedure ParentColorChanged; reintroduce; dynamic;\r\n procedure ParentShowHintChanged; reintroduce; dynamic;\r\n function WantKey(Key: Integer; Shift: TShiftState): Boolean; virtual;\r\n function HintShow(var HintInfo: THintInfo): Boolean; reintroduce; dynamic;\r\n function HitTest(X, Y: Integer): Boolean; reintroduce; virtual;\r\n procedure MouseEnter(AControl: TControl); reintroduce; dynamic;\r\n procedure MouseLeave(AControl: TControl); reintroduce; dynamic;\r\n property MouseOver: Boolean read FMouseOver write FMouseOver;\r\n property HintColor: TColor read FHintColor write FHintColor default clDefault;\r\n property OnMouseEnter: TNotifyEvent read FOnMouseEnter write FOnMouseEnter;\r\n property OnMouseLeave: TNotifyEvent read FOnMouseLeave write FOnMouseLeave;\r\n property OnParentColorChange: TNotifyEvent read FOnParentColorChanged write FOnParentColorChanged;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n property HintWindowClass: THintWindowClass read FHintWindowClass write FHintWindowClass;\r\n published\r\n property AboutJVCL: TJVCLAboutInfo read FAboutJVCL write FAboutJVCL stored False;\r\n private\r\n FDotNetHighlighting: Boolean;\r\n protected\r\n procedure BoundsChanged; reintroduce; virtual;\r\n procedure CursorChanged; reintroduce; dynamic;\r\n procedure ShowingChanged; reintroduce; dynamic;\r\n procedure ShowHintChanged; reintroduce; dynamic;\r\n procedure ControlsListChanging(Control: TControl; Inserting: Boolean); reintroduce; dynamic;\r\n procedure ControlsListChanged(Control: TControl; Inserting: Boolean); reintroduce; dynamic;\r\n procedure GetDlgCode(var Code: TDlgCodes); virtual;\r\n procedure FocusSet(PrevWnd: THandle); virtual;\r\n procedure FocusKilled(NextWnd: THandle); virtual;\r\n function DoEraseBackground(Canvas: TCanvas; Param: LPARAM): Boolean; virtual;\r\n {$IFDEF JVCLThemesEnabledD6}\r\n private\r\n function GetParentBackground: Boolean;\r\n protected\r\n procedure SetParentBackground(Value: Boolean); virtual;\r\n property ParentBackground: Boolean read GetParentBackground write SetParentBackground;\r\n {$ENDIF JVCLThemesEnabledD6}\r\n published\r\n property DotNetHighlighting: Boolean read FDotNetHighlighting write FDotNetHighlighting default False;\r\n end;\r\n\r\n TJvExCustomCheckBox = class(TCustomCheckBox, IJvExControl)\r\n private\r\n FAboutJVCL: TJVCLAboutInfo;\r\n FHintColor: TColor;\r\n FMouseOver: Boolean;\r\n FHintWindowClass: THintWindowClass;\r\n FOnMouseEnter: TNotifyEvent;\r\n FOnMouseLeave: TNotifyEvent;\r\n FOnParentColorChanged: TNotifyEvent;\r\n function BaseWndProc(Msg: Cardinal; WParam: WPARAM = 0; LParam: LPARAM = 0): LRESULT; overload;\r\n function BaseWndProc(Msg: Cardinal; WParam: WPARAM; LParam: TObject): LRESULT; overload;\r\n function BaseWndProcEx(Msg: Cardinal; WParam: WPARAM; var StructLParam): LRESULT;\r\n protected\r\n procedure WndProc(var Msg: TMessage); override;\r\n procedure FocusChanged(AControl: TWinControl); dynamic;\r\n procedure VisibleChanged; reintroduce; dynamic;\r\n procedure EnabledChanged; reintroduce; dynamic;\r\n procedure TextChanged; reintroduce; virtual;\r\n procedure ColorChanged; reintroduce; dynamic;\r\n procedure FontChanged; reintroduce; dynamic;\r\n procedure ParentFontChanged; reintroduce; dynamic;\r\n procedure ParentColorChanged; reintroduce; dynamic;\r\n procedure ParentShowHintChanged; reintroduce; dynamic;\r\n function WantKey(Key: Integer; Shift: TShiftState): Boolean; virtual;\r\n function HintShow(var HintInfo: THintInfo): Boolean; reintroduce; dynamic;\r\n function HitTest(X, Y: Integer): Boolean; reintroduce; virtual;\r\n procedure MouseEnter(AControl: TControl); reintroduce; dynamic;\r\n procedure MouseLeave(AControl: TControl); reintroduce; dynamic;\r\n property MouseOver: Boolean read FMouseOver write FMouseOver;\r\n property HintColor: TColor read FHintColor write FHintColor default clDefault;\r\n property OnMouseEnter: TNotifyEvent read FOnMouseEnter write FOnMouseEnter;\r\n property OnMouseLeave: TNotifyEvent read FOnMouseLeave write FOnMouseLeave;\r\n property OnParentColorChange: TNotifyEvent read FOnParentColorChanged write FOnParentColorChanged;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n property HintWindowClass: THintWindowClass read FHintWindowClass write FHintWindowClass;\r\n published\r\n property AboutJVCL: TJVCLAboutInfo read FAboutJVCL write FAboutJVCL stored False;\r\n private\r\n FDotNetHighlighting: Boolean;\r\n protected\r\n procedure BoundsChanged; reintroduce; virtual;\r\n procedure CursorChanged; reintroduce; dynamic;\r\n procedure ShowingChanged; reintroduce; dynamic;\r\n procedure ShowHintChanged; reintroduce; dynamic;\r\n procedure ControlsListChanging(Control: TControl; Inserting: Boolean); reintroduce; dynamic;\r\n procedure ControlsListChanged(Control: TControl; Inserting: Boolean); reintroduce; dynamic;\r\n procedure GetDlgCode(var Code: TDlgCodes); virtual;\r\n procedure FocusSet(PrevWnd: THandle); virtual;\r\n procedure FocusKilled(NextWnd: THandle); virtual;\r\n function DoEraseBackground(Canvas: TCanvas; Param: LPARAM): Boolean; virtual;\r\n {$IFDEF JVCLThemesEnabledD6}\r\n private\r\n function GetParentBackground: Boolean;\r\n protected\r\n procedure SetParentBackground(Value: Boolean); virtual;\r\n property ParentBackground: Boolean read GetParentBackground write SetParentBackground;\r\n {$ENDIF JVCLThemesEnabledD6}\r\n published\r\n property DotNetHighlighting: Boolean read FDotNetHighlighting write FDotNetHighlighting default False;\r\n end;\r\n\r\n TJvExRadioButton = class(TRadioButton, IJvExControl)\r\n private\r\n FAboutJVCL: TJVCLAboutInfo;\r\n FHintColor: TColor;\r\n FMouseOver: Boolean;\r\n FHintWindowClass: THintWindowClass;\r\n FOnMouseEnter: TNotifyEvent;\r\n FOnMouseLeave: TNotifyEvent;\r\n FOnParentColorChanged: TNotifyEvent;\r\n function BaseWndProc(Msg: Cardinal; WParam: WPARAM = 0; LParam: LPARAM = 0): LRESULT; overload;\r\n function BaseWndProc(Msg: Cardinal; WParam: WPARAM; LParam: TObject): LRESULT; overload;\r\n function BaseWndProcEx(Msg: Cardinal; WParam: WPARAM; var StructLParam): LRESULT;\r\n protected\r\n procedure WndProc(var Msg: TMessage); override;\r\n procedure FocusChanged(AControl: TWinControl); dynamic;\r\n procedure VisibleChanged; reintroduce; dynamic;\r\n procedure EnabledChanged; reintroduce; dynamic;\r\n procedure TextChanged; reintroduce; virtual;\r\n procedure ColorChanged; reintroduce; dynamic;\r\n procedure FontChanged; reintroduce; dynamic;\r\n procedure ParentFontChanged; reintroduce; dynamic;\r\n procedure ParentColorChanged; reintroduce; dynamic;\r\n procedure ParentShowHintChanged; reintroduce; dynamic;\r\n function WantKey(Key: Integer; Shift: TShiftState): Boolean; virtual;\r\n function HintShow(var HintInfo: THintInfo): Boolean; reintroduce; dynamic;\r\n function HitTest(X, Y: Integer): Boolean; reintroduce; virtual;\r\n procedure MouseEnter(AControl: TControl); reintroduce; dynamic;\r\n procedure MouseLeave(AControl: TControl); reintroduce; dynamic;\r\n property MouseOver: Boolean read FMouseOver write FMouseOver;\r\n property HintColor: TColor read FHintColor write FHintColor default clDefault;\r\n property OnMouseEnter: TNotifyEvent read FOnMouseEnter write FOnMouseEnter;\r\n property OnMouseLeave: TNotifyEvent read FOnMouseLeave write FOnMouseLeave;\r\n property OnParentColorChange: TNotifyEvent read FOnParentColorChanged write FOnParentColorChanged;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n property HintWindowClass: THintWindowClass read FHintWindowClass write FHintWindowClass;\r\n published\r\n property AboutJVCL: TJVCLAboutInfo read FAboutJVCL write FAboutJVCL stored False;\r\n private\r\n FDotNetHighlighting: Boolean;\r\n protected\r\n procedure BoundsChanged; reintroduce; virtual;\r\n procedure CursorChanged; reintroduce; dynamic;\r\n procedure ShowingChanged; reintroduce; dynamic;\r\n procedure ShowHintChanged; reintroduce; dynamic;\r\n procedure ControlsListChanging(Control: TControl; Inserting: Boolean); reintroduce; dynamic;\r\n procedure ControlsListChanged(Control: TControl; Inserting: Boolean); reintroduce; dynamic;\r\n procedure GetDlgCode(var Code: TDlgCodes); virtual;\r\n procedure FocusSet(PrevWnd: THandle); virtual;\r\n procedure FocusKilled(NextWnd: THandle); virtual;\r\n function DoEraseBackground(Canvas: TCanvas; Param: LPARAM): Boolean; virtual;\r\n {$IFDEF JVCLThemesEnabledD6}\r\n private\r\n function GetParentBackground: Boolean;\r\n protected\r\n procedure SetParentBackground(Value: Boolean); virtual;\r\n property ParentBackground: Boolean read GetParentBackground write SetParentBackground;\r\n {$ENDIF JVCLThemesEnabledD6}\r\n published\r\n property DotNetHighlighting: Boolean read FDotNetHighlighting write FDotNetHighlighting default False;\r\n end;\r\n\r\n TJvExCustomListBox = class(TCustomListBox, IJvExControl)\r\n private\r\n FAboutJVCL: TJVCLAboutInfo;\r\n FHintColor: TColor;\r\n FMouseOver: Boolean;\r\n FHintWindowClass: THintWindowClass;\r\n FOnMouseEnter: TNotifyEvent;\r\n FOnMouseLeave: TNotifyEvent;\r\n FOnParentColorChanged: TNotifyEvent;\r\n function BaseWndProc(Msg: Cardinal; WParam: WPARAM = 0; LParam: LPARAM = 0): LRESULT; overload;\r\n function BaseWndProc(Msg: Cardinal; WParam: WPARAM; LParam: TObject): LRESULT; overload;\r\n function BaseWndProcEx(Msg: Cardinal; WParam: WPARAM; var StructLParam): LRESULT;\r\n protected\r\n procedure WndProc(var Msg: TMessage); override;\r\n procedure FocusChanged(AControl: TWinControl); dynamic;\r\n procedure VisibleChanged; reintroduce; dynamic;\r\n procedure EnabledChanged; reintroduce; dynamic;\r\n procedure TextChanged; reintroduce; virtual;\r\n procedure ColorChanged; reintroduce; dynamic;\r\n procedure FontChanged; reintroduce; dynamic;\r\n procedure ParentFontChanged; reintroduce; dynamic;\r\n procedure ParentColorChanged; reintroduce; dynamic;\r\n procedure ParentShowHintChanged; reintroduce; dynamic;\r\n function WantKey(Key: Integer; Shift: TShiftState): Boolean; virtual;\r\n function HintShow(var HintInfo: THintInfo): Boolean; reintroduce; dynamic;\r\n function HitTest(X, Y: Integer): Boolean; reintroduce; virtual;\r\n procedure MouseEnter(AControl: TControl); reintroduce; dynamic;\r\n procedure MouseLeave(AControl: TControl); reintroduce; dynamic;\r\n property MouseOver: Boolean read FMouseOver write FMouseOver;\r\n property HintColor: TColor read FHintColor write FHintColor default clDefault;\r\n property OnMouseEnter: TNotifyEvent read FOnMouseEnter write FOnMouseEnter;\r\n property OnMouseLeave: TNotifyEvent read FOnMouseLeave write FOnMouseLeave;\r\n property OnParentColorChange: TNotifyEvent read FOnParentColorChanged write FOnParentColorChanged;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n property HintWindowClass: THintWindowClass read FHintWindowClass write FHintWindowClass;\r\n published\r\n property AboutJVCL: TJVCLAboutInfo read FAboutJVCL write FAboutJVCL stored False;\r\n private\r\n FDotNetHighlighting: Boolean;\r\n protected\r\n procedure BoundsChanged; reintroduce; virtual;\r\n procedure CursorChanged; reintroduce; dynamic;\r\n procedure ShowingChanged; reintroduce; dynamic;\r\n procedure ShowHintChanged; reintroduce; dynamic;\r\n procedure ControlsListChanging(Control: TControl; Inserting: Boolean); reintroduce; dynamic;\r\n procedure ControlsListChanged(Control: TControl; Inserting: Boolean); reintroduce; dynamic;\r\n procedure GetDlgCode(var Code: TDlgCodes); virtual;\r\n procedure FocusSet(PrevWnd: THandle); virtual;\r\n procedure FocusKilled(NextWnd: THandle); virtual;\r\n function DoEraseBackground(Canvas: TCanvas; Param: LPARAM): Boolean; virtual;\r\n {$IFDEF JVCLThemesEnabledD6}\r\n private\r\n function GetParentBackground: Boolean;\r\n protected\r\n procedure SetParentBackground(Value: Boolean); virtual;\r\n property ParentBackground: Boolean read GetParentBackground write SetParentBackground;\r\n {$ENDIF JVCLThemesEnabledD6}\r\n published\r\n property DotNetHighlighting: Boolean read FDotNetHighlighting write FDotNetHighlighting default False;\r\n end;\r\n\r\n TJvExScrollBar = class(TScrollBar, IJvExControl)\r\n private\r\n FAboutJVCL: TJVCLAboutInfo;\r\n FHintColor: TColor;\r\n FMouseOver: Boolean;\r\n FHintWindowClass: THintWindowClass;\r\n FOnMouseEnter: TNotifyEvent;\r\n FOnMouseLeave: TNotifyEvent;\r\n FOnParentColorChanged: TNotifyEvent;\r\n function BaseWndProc(Msg: Cardinal; WParam: WPARAM = 0; LParam: LPARAM = 0): LRESULT; overload;\r\n function BaseWndProc(Msg: Cardinal; WParam: WPARAM; LParam: TObject): LRESULT; overload;\r\n function BaseWndProcEx(Msg: Cardinal; WParam: WPARAM; var StructLParam): LRESULT;\r\n protected\r\n procedure WndProc(var Msg: TMessage); override;\r\n procedure FocusChanged(AControl: TWinControl); dynamic;\r\n procedure VisibleChanged; reintroduce; dynamic;\r\n procedure EnabledChanged; reintroduce; dynamic;\r\n procedure TextChanged; reintroduce; virtual;\r\n procedure ColorChanged; reintroduce; dynamic;\r\n procedure FontChanged; reintroduce; dynamic;\r\n procedure ParentFontChanged; reintroduce; dynamic;\r\n procedure ParentColorChanged; reintroduce; dynamic;\r\n procedure ParentShowHintChanged; reintroduce; dynamic;\r\n function WantKey(Key: Integer; Shift: TShiftState): Boolean; virtual;\r\n function HintShow(var HintInfo: THintInfo): Boolean; reintroduce; dynamic;\r\n function HitTest(X, Y: Integer): Boolean; reintroduce; virtual;\r\n procedure MouseEnter(AControl: TControl); reintroduce; dynamic;\r\n procedure MouseLeave(AControl: TControl); reintroduce; dynamic;\r\n property MouseOver: Boolean read FMouseOver write FMouseOver;\r\n property HintColor: TColor read FHintColor write FHintColor default clDefault;\r\n property OnMouseEnter: TNotifyEvent read FOnMouseEnter write FOnMouseEnter;\r\n property OnMouseLeave: TNotifyEvent read FOnMouseLeave write FOnMouseLeave;\r\n property OnParentColorChange: TNotifyEvent read FOnParentColorChanged write FOnParentColorChanged;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n property HintWindowClass: THintWindowClass read FHintWindowClass write FHintWindowClass;\r\n published\r\n property AboutJVCL: TJVCLAboutInfo read FAboutJVCL write FAboutJVCL stored False;\r\n private\r\n FDotNetHighlighting: Boolean;\r\n protected\r\n procedure BoundsChanged; reintroduce; virtual;\r\n procedure CursorChanged; reintroduce; dynamic;\r\n procedure ShowingChanged; reintroduce; dynamic;\r\n procedure ShowHintChanged; reintroduce; dynamic;\r\n procedure ControlsListChanging(Control: TControl; Inserting: Boolean); reintroduce; dynamic;\r\n procedure ControlsListChanged(Control: TControl; Inserting: Boolean); reintroduce; dynamic;\r\n procedure GetDlgCode(var Code: TDlgCodes); virtual;\r\n procedure FocusSet(PrevWnd: THandle); virtual;\r\n procedure FocusKilled(NextWnd: THandle); virtual;\r\n function DoEraseBackground(Canvas: TCanvas; Param: LPARAM): Boolean; virtual;\r\n {$IFDEF JVCLThemesEnabledD6}\r\n private\r\n function GetParentBackground: Boolean;\r\n protected\r\n procedure SetParentBackground(Value: Boolean); virtual;\r\n property ParentBackground: Boolean read GetParentBackground write SetParentBackground;\r\n {$ENDIF JVCLThemesEnabledD6}\r\n published\r\n property DotNetHighlighting: Boolean read FDotNetHighlighting write FDotNetHighlighting default False;\r\n end;\r\n\r\n TJvExGroupBox = class(TGroupBox, IJvExControl)\r\n private\r\n FAboutJVCL: TJVCLAboutInfo;\r\n FHintColor: TColor;\r\n FMouseOver: Boolean;\r\n FHintWindowClass: THintWindowClass;\r\n FOnMouseEnter: TNotifyEvent;\r\n FOnMouseLeave: TNotifyEvent;\r\n FOnParentColorChanged: TNotifyEvent;\r\n function BaseWndProc(Msg: Cardinal; WParam: WPARAM = 0; LParam: LPARAM = 0): LRESULT; overload;\r\n function BaseWndProc(Msg: Cardinal; WParam: WPARAM; LParam: TObject): LRESULT; overload;\r\n function BaseWndProcEx(Msg: Cardinal; WParam: WPARAM; var StructLParam): LRESULT;\r\n protected\r\n procedure WndProc(var Msg: TMessage); override;\r\n procedure FocusChanged(AControl: TWinControl); dynamic;\r\n procedure VisibleChanged; reintroduce; dynamic;\r\n procedure EnabledChanged; reintroduce; dynamic;\r\n procedure TextChanged; reintroduce; virtual;\r\n procedure ColorChanged; reintroduce; dynamic;\r\n procedure FontChanged; reintroduce; dynamic;\r\n procedure ParentFontChanged; reintroduce; dynamic;\r\n procedure ParentColorChanged; reintroduce; dynamic;\r\n procedure ParentShowHintChanged; reintroduce; dynamic;\r\n function WantKey(Key: Integer; Shift: TShiftState): Boolean; virtual;\r\n function HintShow(var HintInfo: THintInfo): Boolean; reintroduce; dynamic;\r\n function HitTest(X, Y: Integer): Boolean; reintroduce; virtual;\r\n procedure MouseEnter(AControl: TControl); reintroduce; dynamic;\r\n procedure MouseLeave(AControl: TControl); reintroduce; dynamic;\r\n property MouseOver: Boolean read FMouseOver write FMouseOver;\r\n property HintColor: TColor read FHintColor write FHintColor default clDefault;\r\n property OnMouseEnter: TNotifyEvent read FOnMouseEnter write FOnMouseEnter;\r\n property OnMouseLeave: TNotifyEvent read FOnMouseLeave write FOnMouseLeave;\r\n property OnParentColorChange: TNotifyEvent read FOnParentColorChanged write FOnParentColorChanged;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n property HintWindowClass: THintWindowClass read FHintWindowClass write FHintWindowClass;\r\n published\r\n property AboutJVCL: TJVCLAboutInfo read FAboutJVCL write FAboutJVCL stored False;\r\n private\r\n FDotNetHighlighting: Boolean;\r\n protected\r\n procedure BoundsChanged; reintroduce; virtual;\r\n procedure CursorChanged; reintroduce; dynamic;\r\n procedure ShowingChanged; reintroduce; dynamic;\r\n procedure ShowHintChanged; reintroduce; dynamic;\r\n procedure ControlsListChanging(Control: TControl; Inserting: Boolean); reintroduce; dynamic;\r\n procedure ControlsListChanged(Control: TControl; Inserting: Boolean); reintroduce; dynamic;\r\n procedure GetDlgCode(var Code: TDlgCodes); virtual;\r\n procedure FocusSet(PrevWnd: THandle); virtual;\r\n procedure FocusKilled(NextWnd: THandle); virtual;\r\n function DoEraseBackground(Canvas: TCanvas; Param: LPARAM): Boolean; virtual;\r\n {$IFDEF JVCLThemesEnabledD6}\r\n private\r\n function GetParentBackground: Boolean;\r\n protected\r\n procedure SetParentBackground(Value: Boolean); virtual;\r\n property ParentBackground: Boolean read GetParentBackground write SetParentBackground;\r\n {$ENDIF JVCLThemesEnabledD6}\r\n published\r\n property DotNetHighlighting: Boolean read FDotNetHighlighting write FDotNetHighlighting default False;\r\n end;\r\n\r\n TJvExCheckBox = class(TCheckBox, IJvExControl)\r\n private\r\n FAboutJVCL: TJVCLAboutInfo;\r\n FHintColor: TColor;\r\n FMouseOver: Boolean;\r\n FHintWindowClass: THintWindowClass;\r\n FOnMouseEnter: TNotifyEvent;\r\n FOnMouseLeave: TNotifyEvent;\r\n FOnParentColorChanged: TNotifyEvent;\r\n function BaseWndProc(Msg: Cardinal; WParam: WPARAM = 0; LParam: LPARAM = 0): LRESULT; overload;\r\n function BaseWndProc(Msg: Cardinal; WParam: WPARAM; LParam: TObject): LRESULT; overload;\r\n function BaseWndProcEx(Msg: Cardinal; WParam: WPARAM; var StructLParam): LRESULT;\r\n protected\r\n procedure WndProc(var Msg: TMessage); override;\r\n procedure FocusChanged(AControl: TWinControl); dynamic;\r\n procedure VisibleChanged; reintroduce; dynamic;\r\n procedure EnabledChanged; reintroduce; dynamic;\r\n procedure TextChanged; reintroduce; virtual;\r\n procedure ColorChanged; reintroduce; dynamic;\r\n procedure FontChanged; reintroduce; dynamic;\r\n procedure ParentFontChanged; reintroduce; dynamic;\r\n procedure ParentColorChanged; reintroduce; dynamic;\r\n procedure ParentShowHintChanged; reintroduce; dynamic;\r\n function WantKey(Key: Integer; Shift: TShiftState): Boolean; virtual;\r\n function HintShow(var HintInfo: THintInfo): Boolean; reintroduce; dynamic;\r\n function HitTest(X, Y: Integer): Boolean; reintroduce; virtual;\r\n procedure MouseEnter(AControl: TControl); reintroduce; dynamic;\r\n procedure MouseLeave(AControl: TControl); reintroduce; dynamic;\r\n property MouseOver: Boolean read FMouseOver write FMouseOver;\r\n property HintColor: TColor read FHintColor write FHintColor default clDefault;\r\n property OnMouseEnter: TNotifyEvent read FOnMouseEnter write FOnMouseEnter;\r\n property OnMouseLeave: TNotifyEvent read FOnMouseLeave write FOnMouseLeave;\r\n property OnParentColorChange: TNotifyEvent read FOnParentColorChanged write FOnParentColorChanged;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n property HintWindowClass: THintWindowClass read FHintWindowClass write FHintWindowClass;\r\n published\r\n property AboutJVCL: TJVCLAboutInfo read FAboutJVCL write FAboutJVCL stored False;\r\n private\r\n FDotNetHighlighting: Boolean;\r\n protected\r\n procedure BoundsChanged; reintroduce; virtual;\r\n procedure CursorChanged; reintroduce; dynamic;\r\n procedure ShowingChanged; reintroduce; dynamic;\r\n procedure ShowHintChanged; reintroduce; dynamic;\r\n procedure ControlsListChanging(Control: TControl; Inserting: Boolean); reintroduce; dynamic;\r\n procedure ControlsListChanged(Control: TControl; Inserting: Boolean); reintroduce; dynamic;\r\n procedure GetDlgCode(var Code: TDlgCodes); virtual;\r\n procedure FocusSet(PrevWnd: THandle); virtual;\r\n procedure FocusKilled(NextWnd: THandle); virtual;\r\n function DoEraseBackground(Canvas: TCanvas; Param: LPARAM): Boolean; virtual;\r\n {$IFDEF JVCLThemesEnabledD6}\r\n private\r\n function GetParentBackground: Boolean;\r\n protected\r\n procedure SetParentBackground(Value: Boolean); virtual;\r\n property ParentBackground: Boolean read GetParentBackground write SetParentBackground;\r\n {$ENDIF JVCLThemesEnabledD6}\r\n published\r\n property DotNetHighlighting: Boolean read FDotNetHighlighting write FDotNetHighlighting default False;\r\n end;\r\n\r\n TJvExCustomStaticText = class(TCustomStaticText, IJvExControl)\r\n private\r\n FAboutJVCL: TJVCLAboutInfo;\r\n FHintColor: TColor;\r\n FMouseOver: Boolean;\r\n FHintWindowClass: THintWindowClass;\r\n FOnMouseEnter: TNotifyEvent;\r\n FOnMouseLeave: TNotifyEvent;\r\n FOnParentColorChanged: TNotifyEvent;\r\n function BaseWndProc(Msg: Cardinal; WParam: WPARAM = 0; LParam: LPARAM = 0): LRESULT; overload;\r\n function BaseWndProc(Msg: Cardinal; WParam: WPARAM; LParam: TObject): LRESULT; overload;\r\n function BaseWndProcEx(Msg: Cardinal; WParam: WPARAM; var StructLParam): LRESULT;\r\n protected\r\n procedure WndProc(var Msg: TMessage); override;\r\n procedure FocusChanged(AControl: TWinControl); dynamic;\r\n procedure VisibleChanged; reintroduce; dynamic;\r\n procedure EnabledChanged; reintroduce; dynamic;\r\n procedure TextChanged; reintroduce; virtual;\r\n procedure ColorChanged; reintroduce; dynamic;\r\n procedure FontChanged; reintroduce; dynamic;\r\n procedure ParentFontChanged; reintroduce; dynamic;\r\n procedure ParentColorChanged; reintroduce; dynamic;\r\n procedure ParentShowHintChanged; reintroduce; dynamic;\r\n function WantKey(Key: Integer; Shift: TShiftState): Boolean; virtual;\r\n function HintShow(var HintInfo: THintInfo): Boolean; reintroduce; dynamic;\r\n function HitTest(X, Y: Integer): Boolean; reintroduce; virtual;\r\n procedure MouseEnter(AControl: TControl); reintroduce; dynamic;\r\n procedure MouseLeave(AControl: TControl); reintroduce; dynamic;\r\n property MouseOver: Boolean read FMouseOver write FMouseOver;\r\n property HintColor: TColor read FHintColor write FHintColor default clDefault;\r\n property OnMouseEnter: TNotifyEvent read FOnMouseEnter write FOnMouseEnter;\r\n property OnMouseLeave: TNotifyEvent read FOnMouseLeave write FOnMouseLeave;\r\n property OnParentColorChange: TNotifyEvent read FOnParentColorChanged write FOnParentColorChanged;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n property HintWindowClass: THintWindowClass read FHintWindowClass write FHintWindowClass;\r\n published\r\n property AboutJVCL: TJVCLAboutInfo read FAboutJVCL write FAboutJVCL stored False;\r\n private\r\n FDotNetHighlighting: Boolean;\r\n protected\r\n procedure BoundsChanged; reintroduce; virtual;\r\n procedure CursorChanged; reintroduce; dynamic;\r\n procedure ShowingChanged; reintroduce; dynamic;\r\n procedure ShowHintChanged; reintroduce; dynamic;\r\n procedure ControlsListChanging(Control: TControl; Inserting: Boolean); reintroduce; dynamic;\r\n procedure ControlsListChanged(Control: TControl; Inserting: Boolean); reintroduce; dynamic;\r\n procedure GetDlgCode(var Code: TDlgCodes); virtual;\r\n procedure FocusSet(PrevWnd: THandle); virtual;\r\n procedure FocusKilled(NextWnd: THandle); virtual;\r\n function DoEraseBackground(Canvas: TCanvas; Param: LPARAM): Boolean; virtual;\r\n {$IFDEF JVCLThemesEnabledD6}\r\n private\r\n function GetParentBackground: Boolean;\r\n protected\r\n procedure SetParentBackground(Value: Boolean); virtual;\r\n property ParentBackground: Boolean read GetParentBackground write SetParentBackground;\r\n {$ENDIF JVCLThemesEnabledD6}\r\n published\r\n property DotNetHighlighting: Boolean read FDotNetHighlighting write FDotNetHighlighting default False;\r\n end;\r\n\r\n TJvExStaticText = class(TStaticText, IJvExControl)\r\n private\r\n FAboutJVCL: TJVCLAboutInfo;\r\n FHintColor: TColor;\r\n FMouseOver: Boolean;\r\n FHintWindowClass: THintWindowClass;\r\n FOnMouseEnter: TNotifyEvent;\r\n FOnMouseLeave: TNotifyEvent;\r\n FOnParentColorChanged: TNotifyEvent;\r\n function BaseWndProc(Msg: Cardinal; WParam: WPARAM = 0; LParam: LPARAM = 0): LRESULT; overload;\r\n function BaseWndProc(Msg: Cardinal; WParam: WPARAM; LParam: TObject): LRESULT; overload;\r\n function BaseWndProcEx(Msg: Cardinal; WParam: WPARAM; var StructLParam): LRESULT;\r\n protected\r\n procedure WndProc(var Msg: TMessage); override;\r\n procedure FocusChanged(AControl: TWinControl); dynamic;\r\n procedure VisibleChanged; reintroduce; dynamic;\r\n procedure EnabledChanged; reintroduce; dynamic;\r\n procedure TextChanged; reintroduce; virtual;\r\n procedure ColorChanged; reintroduce; dynamic;\r\n procedure FontChanged; reintroduce; dynamic;\r\n procedure ParentFontChanged; reintroduce; dynamic;\r\n procedure ParentColorChanged; reintroduce; dynamic;\r\n procedure ParentShowHintChanged; reintroduce; dynamic;\r\n function WantKey(Key: Integer; Shift: TShiftState): Boolean; virtual;\r\n function HintShow(var HintInfo: THintInfo): Boolean; reintroduce; dynamic;\r\n function HitTest(X, Y: Integer): Boolean; reintroduce; virtual;\r\n procedure MouseEnter(AControl: TControl); reintroduce; dynamic;\r\n procedure MouseLeave(AControl: TControl); reintroduce; dynamic;\r\n property MouseOver: Boolean read FMouseOver write FMouseOver;\r\n property HintColor: TColor read FHintColor write FHintColor default clDefault;\r\n property OnMouseEnter: TNotifyEvent read FOnMouseEnter write FOnMouseEnter;\r\n property OnMouseLeave: TNotifyEvent read FOnMouseLeave write FOnMouseLeave;\r\n property OnParentColorChange: TNotifyEvent read FOnParentColorChanged write FOnParentColorChanged;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n property HintWindowClass: THintWindowClass read FHintWindowClass write FHintWindowClass;\r\n published\r\n property AboutJVCL: TJVCLAboutInfo read FAboutJVCL write FAboutJVCL stored False;\r\n private\r\n FDotNetHighlighting: Boolean;\r\n protected\r\n procedure BoundsChanged; reintroduce; virtual;\r\n procedure CursorChanged; reintroduce; dynamic;\r\n procedure ShowingChanged; reintroduce; dynamic;\r\n procedure ShowHintChanged; reintroduce; dynamic;\r\n procedure ControlsListChanging(Control: TControl; Inserting: Boolean); reintroduce; dynamic;\r\n procedure ControlsListChanged(Control: TControl; Inserting: Boolean); reintroduce; dynamic;\r\n procedure GetDlgCode(var Code: TDlgCodes); virtual;\r\n procedure FocusSet(PrevWnd: THandle); virtual;\r\n procedure FocusKilled(NextWnd: THandle); virtual;\r\n function DoEraseBackground(Canvas: TCanvas; Param: LPARAM): Boolean; virtual;\r\n {$IFDEF JVCLThemesEnabledD6}\r\n private\r\n function GetParentBackground: Boolean;\r\n protected\r\n procedure SetParentBackground(Value: Boolean); virtual;\r\n property ParentBackground: Boolean read GetParentBackground write SetParentBackground;\r\n {$ENDIF JVCLThemesEnabledD6}\r\n published\r\n property DotNetHighlighting: Boolean read FDotNetHighlighting write FDotNetHighlighting default False;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvExStdCtrls.pas $';\r\n Revision: '$Revision: 13173 $';\r\n Date: '$Date: 2011-11-19 13:43:58 +0100 (sam. 19 nov. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nconstructor TJvExCustomGroupBox.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FHintColor := clDefault;\r\nend;\r\n\r\nfunction TJvExCustomGroupBox.BaseWndProc(Msg: Cardinal; WParam: WPARAM = 0; LParam: LPARAM = 0): LRESULT;\r\nvar\r\n Mesg: TMessage;\r\nbegin\r\n CreateWMMessage(Mesg, Msg, WParam, LParam);\r\n inherited WndProc(Mesg);\r\n Result := Mesg.Result;\r\nend;\r\n\r\nfunction TJvExCustomGroupBox.BaseWndProc(Msg: Cardinal; WParam: WPARAM; LParam: TObject): LRESULT;\r\nbegin\r\n Result := BaseWndProc(Msg, WParam, Windows.LPARAM(LParam));\r\nend;\r\n\r\nfunction TJvExCustomGroupBox.BaseWndProcEx(Msg: Cardinal; WParam: WPARAM; var StructLParam): LRESULT;\r\nbegin\r\n Result := BaseWndProc(Msg, WParam, Windows.LPARAM(@StructLParam));\r\nend;\r\n\r\nprocedure TJvExCustomGroupBox.VisibleChanged;\r\nbegin\r\n BaseWndProc(CM_VISIBLECHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomGroupBox.EnabledChanged;\r\nbegin\r\n BaseWndProc(CM_ENABLEDCHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomGroupBox.TextChanged;\r\nbegin\r\n BaseWndProc(CM_TEXTCHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomGroupBox.FontChanged;\r\nbegin\r\n BaseWndProc(CM_FONTCHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomGroupBox.ColorChanged;\r\nbegin\r\n BaseWndProc(CM_COLORCHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomGroupBox.ParentFontChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTFONTCHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomGroupBox.ParentColorChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTCOLORCHANGED);\r\n if Assigned(OnParentColorChange) then\r\n OnParentColorChange(Self);\r\nend;\r\n\r\nprocedure TJvExCustomGroupBox.ParentShowHintChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTSHOWHINTCHANGED);\r\nend;\r\n\r\nfunction TJvExCustomGroupBox.WantKey(Key: Integer; Shift: TShiftState): Boolean;\r\nbegin\r\n Result := BaseWndProc(CM_DIALOGCHAR, Word(Key), ShiftStateToKeyData(Shift)) <> 0;\r\nend;\r\n\r\nfunction TJvExCustomGroupBox.HitTest(X, Y: Integer): Boolean;\r\nbegin\r\n Result := BaseWndProc(CM_HITTEST, 0, SmallPointToLong(PointToSmallPoint(Point(X, Y)))) <> 0;\r\nend;\r\n\r\nfunction TJvExCustomGroupBox.HintShow(var HintInfo: THintInfo): Boolean;\r\nbegin\r\n GetHintColor(HintInfo, Self, FHintColor);\r\n if FHintWindowClass <> nil then\r\n HintInfo.HintWindowClass := FHintWindowClass;\r\n Result := BaseWndProcEx(CM_HINTSHOW, 0, HintInfo) <> 0;\r\nend;\r\n\r\nprocedure TJvExCustomGroupBox.MouseEnter(AControl: TControl);\r\nbegin\r\n FMouseOver := True;\r\n if Assigned(FOnMouseEnter) then\r\n FOnMouseEnter(Self);\r\n BaseWndProc(CM_MOUSEENTER, 0, AControl);\r\nend;\r\n\r\nprocedure TJvExCustomGroupBox.MouseLeave(AControl: TControl);\r\nbegin\r\n FMouseOver := False;\r\n BaseWndProc(CM_MOUSELEAVE, 0, AControl);\r\n if Assigned(FOnMouseLeave) then\r\n FOnMouseLeave(Self);\r\nend;\r\n\r\nprocedure TJvExCustomGroupBox.FocusChanged(AControl: TWinControl);\r\nbegin\r\n BaseWndProc(CM_FOCUSCHANGED, 0, AControl);\r\nend;\r\n\r\nprocedure TJvExCustomGroupBox.BoundsChanged;\r\nbegin\r\nend;\r\n\r\nprocedure TJvExCustomGroupBox.CursorChanged;\r\nbegin\r\n BaseWndProc(CM_CURSORCHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomGroupBox.ShowingChanged;\r\nbegin\r\n BaseWndProc(CM_SHOWINGCHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomGroupBox.ShowHintChanged;\r\nbegin\r\n BaseWndProc(CM_SHOWHINTCHANGED);\r\nend;\r\n\r\n{ VCL sends CM_CONTROLLISTCHANGE and CM_CONTROLCHANGE in a different order than\r\n the CLX methods are used. So we must correct it by evaluating \"Inserting\". }\r\nprocedure TJvExCustomGroupBox.ControlsListChanging(Control: TControl; Inserting: Boolean);\r\nbegin\r\n if Inserting then\r\n BaseWndProc(CM_CONTROLLISTCHANGE, WPARAM(Control), LPARAM(Inserting))\r\n else\r\n BaseWndProc(CM_CONTROLCHANGE, WPARAM(Control), LPARAM(Inserting));\r\nend;\r\n\r\nprocedure TJvExCustomGroupBox.ControlsListChanged(Control: TControl; Inserting: Boolean);\r\nbegin\r\n if not Inserting then\r\n BaseWndProc(CM_CONTROLLISTCHANGE, WPARAM(Control), LPARAM(Inserting))\r\n else\r\n BaseWndProc(CM_CONTROLCHANGE, WPARAM(Control), LPARAM(Inserting));\r\nend;\r\n\r\nprocedure TJvExCustomGroupBox.GetDlgCode(var Code: TDlgCodes);\r\nbegin\r\nend;\r\n\r\nprocedure TJvExCustomGroupBox.FocusSet(PrevWnd: THandle);\r\nbegin\r\n BaseWndProc(WM_SETFOCUS, WPARAM(PrevWnd), 0);\r\nend;\r\n\r\nprocedure TJvExCustomGroupBox.FocusKilled(NextWnd: THandle);\r\nbegin\r\n BaseWndProc(WM_KILLFOCUS, WPARAM(NextWnd), 0);\r\nend;\r\n\r\nfunction TJvExCustomGroupBox.DoEraseBackground(Canvas: TCanvas; Param: LPARAM): Boolean;\r\nbegin\r\n Result := BaseWndProc(WM_ERASEBKGND, Canvas.Handle, Param) <> 0;\r\nend;\r\n\r\n{$IFDEF JVCLThemesEnabledD6}\r\nfunction TJvExCustomGroupBox.GetParentBackground: Boolean;\r\nbegin\r\n Result := JvThemes.GetParentBackground(Self);\r\nend;\r\n\r\nprocedure TJvExCustomGroupBox.SetParentBackground(Value: Boolean);\r\nbegin\r\n JvThemes.SetParentBackground(Self, Value);\r\nend;\r\n{$ENDIF JVCLThemesEnabledD6}\r\n\r\nprocedure TJvExCustomGroupBox.WndProc(var Msg: TMessage);\r\nvar\r\n IdSaveDC: Integer;\r\n DlgCodes: TDlgCodes;\r\n Canvas: TCanvas;\r\nbegin\r\n if not DispatchIsDesignMsg(Self, Msg) then\r\n begin\r\n case Msg.Msg of\r\n CM_DENYSUBCLASSING:\r\n Msg.Result := LRESULT(Ord(GetInterfaceEntry(IJvDenySubClassing) <> nil));\r\n CM_DIALOGCHAR:\r\n with TCMDialogChar{$IFDEF CLR}.Create{$ENDIF}(Msg) do\r\n Result := LRESULT(Ord(WantKey(CharCode, KeyDataToShiftState(KeyData))));\r\n CM_HINTSHOW:\r\n with TCMHintShow(Msg) do\r\n Result := LRESULT(HintShow(HintInfo^));\r\n CM_HITTEST:\r\n with TCMHitTest(Msg) do\r\n Result := LRESULT(HitTest(XPos, YPos));\r\n CM_MOUSEENTER:\r\n MouseEnter(TControl(Msg.LParam));\r\n CM_MOUSELEAVE:\r\n MouseLeave(TControl(Msg.LParam));\r\n CM_VISIBLECHANGED:\r\n VisibleChanged;\r\n CM_ENABLEDCHANGED:\r\n EnabledChanged;\r\n CM_TEXTCHANGED:\r\n TextChanged;\r\n CM_FONTCHANGED:\r\n FontChanged;\r\n CM_COLORCHANGED:\r\n ColorChanged;\r\n CM_FOCUSCHANGED:\r\n FocusChanged(TWinControl(Msg.LParam));\r\n CM_PARENTFONTCHANGED:\r\n ParentFontChanged;\r\n CM_PARENTCOLORCHANGED:\r\n ParentColorChanged;\r\n CM_PARENTSHOWHINTCHANGED:\r\n ParentShowHintChanged;\r\n CM_CURSORCHANGED:\r\n CursorChanged;\r\n CM_SHOWINGCHANGED:\r\n ShowingChanged;\r\n CM_SHOWHINTCHANGED:\r\n ShowHintChanged;\r\n CM_CONTROLLISTCHANGE:\r\n if Msg.LParam <> 0 then\r\n ControlsListChanging(TControl(Msg.WParam), True)\r\n else\r\n ControlsListChanged(TControl(Msg.WParam), False);\r\n CM_CONTROLCHANGE:\r\n if Msg.LParam = 0 then\r\n ControlsListChanging(TControl(Msg.WParam), False)\r\n else\r\n ControlsListChanged(TControl(Msg.WParam), True);\r\n WM_SETFOCUS:\r\n FocusSet(THandle(Msg.WParam));\r\n WM_KILLFOCUS:\r\n FocusKilled(THandle(Msg.WParam));\r\n WM_SIZE, WM_MOVE:\r\n begin\r\n inherited WndProc(Msg);\r\n BoundsChanged;\r\n end;\r\n WM_ERASEBKGND:\r\n if (Msg.WParam <> 0) and not IsDefaultEraseBackground(DoEraseBackground, @TJvExCustomGroupBox.DoEraseBackground) then\r\n begin\r\n IdSaveDC := SaveDC(HDC(Msg.WParam)); // protect DC against Stock-Objects from Canvas\r\n Canvas := TCanvas.Create;\r\n try\r\n Canvas.Handle := HDC(Msg.WParam);\r\n Msg.Result := Ord(DoEraseBackground(Canvas, Msg.LParam));\r\n finally\r\n Canvas.Handle := 0;\r\n Canvas.Free;\r\n RestoreDC(HDC(Msg.WParam), IdSaveDC);\r\n end;\r\n end\r\n else\r\n inherited WndProc(Msg);\r\n {$IFNDEF DELPHI2007_UP}\r\n WM_PRINTCLIENT, WM_PRINT: // VCL bug fix\r\n begin\r\n IdSaveDC := SaveDC(HDC(Msg.WParam)); // protect DC against changes\r\n try\r\n inherited WndProc(Msg);\r\n finally\r\n RestoreDC(HDC(Msg.WParam), IdSaveDC);\r\n end;\r\n end;\r\n {$ENDIF ~DELPHI2007_UP}\r\n WM_GETDLGCODE:\r\n begin\r\n inherited WndProc(Msg);\r\n DlgCodes := [dcNative] + DlgcToDlgCodes(Msg.Result);\r\n GetDlgCode(DlgCodes);\r\n if not (dcNative in DlgCodes) then\r\n Msg.Result := DlgCodesToDlgc(DlgCodes);\r\n end;\r\n else\r\n inherited WndProc(Msg);\r\n end;\r\n case Msg.Msg of // precheck message to prevent access violations on released controls\r\n CM_MOUSEENTER, CM_MOUSELEAVE, WM_KILLFOCUS, WM_SETFOCUS, WM_NCPAINT:\r\n if DotNetHighlighting then\r\n HandleDotNetHighlighting(Self, Msg, MouseOver, Color);\r\n end;\r\n end;\r\nend;\r\n\r\n//============================================================================\r\n\r\n{$DEFINE HASAUTOSIZE}\r\n\r\nconstructor TJvExCustomLabel.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FHintColor := clDefault;\r\nend;\r\n\r\nfunction TJvExCustomLabel.BaseWndProc(Msg: Cardinal; WParam: WPARAM = 0; LParam: LPARAM = 0): LRESULT;\r\nvar\r\n Mesg: TMessage;\r\nbegin\r\n CreateWMMessage(Mesg, Msg, WParam, LParam);\r\n inherited WndProc(Mesg);\r\n Result := Mesg.Result;\r\nend;\r\n\r\nfunction TJvExCustomLabel.BaseWndProc(Msg: Cardinal; WParam: WPARAM; LParam: TObject): LRESULT;\r\nbegin\r\n Result := BaseWndProc(Msg, WParam, Windows.LPARAM(LParam));\r\nend;\r\n\r\nfunction TJvExCustomLabel.BaseWndProcEx(Msg: Cardinal; WParam: WPARAM; var StructLParam): LRESULT;\r\nbegin\r\n Result := BaseWndProc(Msg, WParam, Windows.LPARAM(@StructLParam));\r\nend;\r\n\r\nprocedure TJvExCustomLabel.VisibleChanged;\r\nbegin\r\n BaseWndProc(CM_VISIBLECHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomLabel.EnabledChanged;\r\nbegin\r\n BaseWndProc(CM_ENABLEDCHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomLabel.TextChanged;\r\nbegin\r\n BaseWndProc(CM_TEXTCHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomLabel.FontChanged;\r\nbegin\r\n BaseWndProc(CM_FONTCHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomLabel.ColorChanged;\r\nbegin\r\n BaseWndProc(CM_COLORCHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomLabel.ParentFontChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTFONTCHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomLabel.ParentColorChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTCOLORCHANGED);\r\n if Assigned(OnParentColorChange) then\r\n OnParentColorChange(Self);\r\nend;\r\n\r\nprocedure TJvExCustomLabel.ParentShowHintChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTSHOWHINTCHANGED);\r\nend;\r\n\r\nfunction TJvExCustomLabel.WantKey(Key: Integer; Shift: TShiftState): Boolean;\r\nbegin\r\n Result := BaseWndProc(CM_DIALOGCHAR, Word(Key), ShiftStateToKeyData(Shift)) <> 0;\r\nend;\r\n\r\nfunction TJvExCustomLabel.HitTest(X, Y: Integer): Boolean;\r\nbegin\r\n Result := BaseWndProc(CM_HITTEST, 0, SmallPointToLong(PointToSmallPoint(Point(X, Y)))) <> 0;\r\nend;\r\n\r\nfunction TJvExCustomLabel.HintShow(var HintInfo: THintInfo): Boolean;\r\nbegin\r\n GetHintColor(HintInfo, Self, FHintColor);\r\n if FHintWindowClass <> nil then\r\n HintInfo.HintWindowClass := FHintWindowClass;\r\n Result := BaseWndProcEx(CM_HINTSHOW, 0, HintInfo) <> 0;\r\nend;\r\n\r\nprocedure TJvExCustomLabel.MouseEnter(AControl: TControl);\r\nbegin\r\n FMouseOver := True;\r\n if Assigned(FOnMouseEnter) then\r\n FOnMouseEnter(Self);\r\n BaseWndProc(CM_MOUSEENTER, 0, AControl);\r\nend;\r\n\r\nprocedure TJvExCustomLabel.MouseLeave(AControl: TControl);\r\nbegin\r\n FMouseOver := False;\r\n BaseWndProc(CM_MOUSELEAVE, 0, AControl);\r\n if Assigned(FOnMouseLeave) then\r\n FOnMouseLeave(Self);\r\nend;\r\n\r\nprocedure TJvExCustomLabel.FocusChanged(AControl: TWinControl);\r\nbegin\r\n BaseWndProc(CM_FOCUSCHANGED, 0, AControl);\r\nend;\r\n\r\nprocedure TJvExCustomLabel.WndProc(var Msg: TMessage);\r\nbegin\r\n if not DispatchIsDesignMsg(Self, Msg) then\r\n case Msg.Msg of\r\n CM_DENYSUBCLASSING:\r\n Msg.Result := LRESULT(Ord(GetInterfaceEntry(IJvDenySubClassing) <> nil));\r\n CM_DIALOGCHAR:\r\n with TCMDialogChar{$IFDEF CLR}.Create{$ENDIF}(Msg) do\r\n Result := LRESULT(Ord(WantKey(CharCode, KeyDataToShiftState(KeyData))));\r\n CM_HINTSHOW:\r\n with TCMHintShow(Msg) do\r\n Result := LRESULT(HintShow(HintInfo^));\r\n CM_HITTEST:\r\n with TCMHitTest(Msg) do\r\n Result := LRESULT(HitTest(XPos, YPos));\r\n CM_MOUSEENTER:\r\n MouseEnter(TControl(Msg.LParam));\r\n CM_MOUSELEAVE:\r\n MouseLeave(TControl(Msg.LParam));\r\n CM_VISIBLECHANGED:\r\n VisibleChanged;\r\n CM_ENABLEDCHANGED:\r\n EnabledChanged;\r\n CM_TEXTCHANGED:\r\n TextChanged;\r\n CM_FONTCHANGED:\r\n FontChanged;\r\n CM_COLORCHANGED:\r\n ColorChanged;\r\n CM_FOCUSCHANGED:\r\n FocusChanged(TWinControl(Msg.LParam));\r\n CM_PARENTFONTCHANGED:\r\n ParentFontChanged;\r\n CM_PARENTCOLORCHANGED:\r\n ParentColorChanged;\r\n CM_PARENTSHOWHINTCHANGED:\r\n ParentShowHintChanged;\r\n else\r\n inherited WndProc(Msg);\r\n end;\r\nend;\r\n\r\n//============================================================================\r\n\r\nconstructor TJvExLabel.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FHintColor := clDefault;\r\nend;\r\n\r\nfunction TJvExLabel.BaseWndProc(Msg: Cardinal; WParam: WPARAM = 0; LParam: LPARAM = 0): LRESULT;\r\nvar\r\n Mesg: TMessage;\r\nbegin\r\n CreateWMMessage(Mesg, Msg, WParam, LParam);\r\n inherited WndProc(Mesg);\r\n Result := Mesg.Result;\r\nend;\r\n\r\nfunction TJvExLabel.BaseWndProc(Msg: Cardinal; WParam: WPARAM; LParam: TObject): LRESULT;\r\nbegin\r\n Result := BaseWndProc(Msg, WParam, Windows.LPARAM(LParam));\r\nend;\r\n\r\nfunction TJvExLabel.BaseWndProcEx(Msg: Cardinal; WParam: WPARAM; var StructLParam): LRESULT;\r\nbegin\r\n Result := BaseWndProc(Msg, WParam, Windows.LPARAM(@StructLParam));\r\nend;\r\n\r\nprocedure TJvExLabel.VisibleChanged;\r\nbegin\r\n BaseWndProc(CM_VISIBLECHANGED);\r\nend;\r\n\r\nprocedure TJvExLabel.EnabledChanged;\r\nbegin\r\n BaseWndProc(CM_ENABLEDCHANGED);\r\nend;\r\n\r\nprocedure TJvExLabel.TextChanged;\r\nbegin\r\n BaseWndProc(CM_TEXTCHANGED);\r\nend;\r\n\r\nprocedure TJvExLabel.FontChanged;\r\nbegin\r\n BaseWndProc(CM_FONTCHANGED);\r\nend;\r\n\r\nprocedure TJvExLabel.ColorChanged;\r\nbegin\r\n BaseWndProc(CM_COLORCHANGED);\r\nend;\r\n\r\nprocedure TJvExLabel.ParentFontChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTFONTCHANGED);\r\nend;\r\n\r\nprocedure TJvExLabel.ParentColorChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTCOLORCHANGED);\r\n if Assigned(OnParentColorChange) then\r\n OnParentColorChange(Self);\r\nend;\r\n\r\nprocedure TJvExLabel.ParentShowHintChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTSHOWHINTCHANGED);\r\nend;\r\n\r\nfunction TJvExLabel.WantKey(Key: Integer; Shift: TShiftState): Boolean;\r\nbegin\r\n Result := BaseWndProc(CM_DIALOGCHAR, Word(Key), ShiftStateToKeyData(Shift)) <> 0;\r\nend;\r\n\r\nfunction TJvExLabel.HitTest(X, Y: Integer): Boolean;\r\nbegin\r\n Result := BaseWndProc(CM_HITTEST, 0, SmallPointToLong(PointToSmallPoint(Point(X, Y)))) <> 0;\r\nend;\r\n\r\nfunction TJvExLabel.HintShow(var HintInfo: THintInfo): Boolean;\r\nbegin\r\n GetHintColor(HintInfo, Self, FHintColor);\r\n if FHintWindowClass <> nil then\r\n HintInfo.HintWindowClass := FHintWindowClass;\r\n Result := BaseWndProcEx(CM_HINTSHOW, 0, HintInfo) <> 0;\r\nend;\r\n\r\nprocedure TJvExLabel.MouseEnter(AControl: TControl);\r\nbegin\r\n FMouseOver := True;\r\n if Assigned(FOnMouseEnter) then\r\n FOnMouseEnter(Self);\r\n BaseWndProc(CM_MOUSEENTER, 0, AControl);\r\nend;\r\n\r\nprocedure TJvExLabel.MouseLeave(AControl: TControl);\r\nbegin\r\n FMouseOver := False;\r\n BaseWndProc(CM_MOUSELEAVE, 0, AControl);\r\n if Assigned(FOnMouseLeave) then\r\n FOnMouseLeave(Self);\r\nend;\r\n\r\nprocedure TJvExLabel.FocusChanged(AControl: TWinControl);\r\nbegin\r\n BaseWndProc(CM_FOCUSCHANGED, 0, AControl);\r\nend;\r\n\r\nprocedure TJvExLabel.WndProc(var Msg: TMessage);\r\nbegin\r\n if not DispatchIsDesignMsg(Self, Msg) then\r\n case Msg.Msg of\r\n CM_DENYSUBCLASSING:\r\n Msg.Result := LRESULT(Ord(GetInterfaceEntry(IJvDenySubClassing) <> nil));\r\n CM_DIALOGCHAR:\r\n with TCMDialogChar{$IFDEF CLR}.Create{$ENDIF}(Msg) do\r\n Result := LRESULT(Ord(WantKey(CharCode, KeyDataToShiftState(KeyData))));\r\n CM_HINTSHOW:\r\n with TCMHintShow(Msg) do\r\n Result := LRESULT(HintShow(HintInfo^));\r\n CM_HITTEST:\r\n with TCMHitTest(Msg) do\r\n Result := LRESULT(HitTest(XPos, YPos));\r\n CM_MOUSEENTER:\r\n MouseEnter(TControl(Msg.LParam));\r\n CM_MOUSELEAVE:\r\n MouseLeave(TControl(Msg.LParam));\r\n CM_VISIBLECHANGED:\r\n VisibleChanged;\r\n CM_ENABLEDCHANGED:\r\n EnabledChanged;\r\n CM_TEXTCHANGED:\r\n TextChanged;\r\n CM_FONTCHANGED:\r\n FontChanged;\r\n CM_COLORCHANGED:\r\n ColorChanged;\r\n CM_FOCUSCHANGED:\r\n FocusChanged(TWinControl(Msg.LParam));\r\n CM_PARENTFONTCHANGED:\r\n ParentFontChanged;\r\n CM_PARENTCOLORCHANGED:\r\n ParentColorChanged;\r\n CM_PARENTSHOWHINTCHANGED:\r\n ParentShowHintChanged;\r\n else\r\n inherited WndProc(Msg);\r\n end;\r\nend;\r\n\r\n//============================================================================\r\n\r\n{$UNDEF HASAUTOSIZE}\r\n\r\nconstructor TJvExCustomEdit.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FHintColor := clDefault;\r\n FClipboardCommands := [caCopy..caUndo];\r\nend;\r\n\r\nfunction TJvExCustomEdit.BaseWndProc(Msg: Cardinal; WParam: WPARAM = 0; LParam: LPARAM = 0): LRESULT;\r\nvar\r\n Mesg: TMessage;\r\nbegin\r\n CreateWMMessage(Mesg, Msg, WParam, LParam);\r\n inherited WndProc(Mesg);\r\n Result := Mesg.Result;\r\nend;\r\n\r\nfunction TJvExCustomEdit.BaseWndProc(Msg: Cardinal; WParam: WPARAM; LParam: TObject): LRESULT;\r\nbegin\r\n Result := BaseWndProc(Msg, WParam, Windows.LPARAM(LParam));\r\nend;\r\n\r\nfunction TJvExCustomEdit.BaseWndProcEx(Msg: Cardinal; WParam: WPARAM; var StructLParam): LRESULT;\r\nbegin\r\n Result := BaseWndProc(Msg, WParam, Windows.LPARAM(@StructLParam));\r\nend;\r\n\r\nprocedure TJvExCustomEdit.VisibleChanged;\r\nbegin\r\n BaseWndProc(CM_VISIBLECHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomEdit.EnabledChanged;\r\nbegin\r\n BaseWndProc(CM_ENABLEDCHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomEdit.TextChanged;\r\nbegin\r\n BaseWndProc(CM_TEXTCHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomEdit.FontChanged;\r\nbegin\r\n BaseWndProc(CM_FONTCHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomEdit.ColorChanged;\r\nbegin\r\n BaseWndProc(CM_COLORCHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomEdit.ParentFontChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTFONTCHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomEdit.ParentColorChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTCOLORCHANGED);\r\n if Assigned(OnParentColorChange) then\r\n OnParentColorChange(Self);\r\nend;\r\n\r\nprocedure TJvExCustomEdit.ParentShowHintChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTSHOWHINTCHANGED);\r\nend;\r\n\r\nfunction TJvExCustomEdit.WantKey(Key: Integer; Shift: TShiftState): Boolean;\r\nbegin\r\n Result := BaseWndProc(CM_DIALOGCHAR, Word(Key), ShiftStateToKeyData(Shift)) <> 0;\r\nend;\r\n\r\nfunction TJvExCustomEdit.HitTest(X, Y: Integer): Boolean;\r\nbegin\r\n Result := BaseWndProc(CM_HITTEST, 0, SmallPointToLong(PointToSmallPoint(Point(X, Y)))) <> 0;\r\nend;\r\n\r\nfunction TJvExCustomEdit.HintShow(var HintInfo: THintInfo): Boolean;\r\nbegin\r\n GetHintColor(HintInfo, Self, FHintColor);\r\n if FHintWindowClass <> nil then\r\n HintInfo.HintWindowClass := FHintWindowClass;\r\n Result := BaseWndProcEx(CM_HINTSHOW, 0, HintInfo) <> 0;\r\nend;\r\n\r\nprocedure TJvExCustomEdit.MouseEnter(AControl: TControl);\r\nbegin\r\n FMouseOver := True;\r\n if Assigned(FOnMouseEnter) then\r\n FOnMouseEnter(Self);\r\n BaseWndProc(CM_MOUSEENTER, 0, AControl);\r\nend;\r\n\r\nprocedure TJvExCustomEdit.MouseLeave(AControl: TControl);\r\nbegin\r\n FMouseOver := False;\r\n BaseWndProc(CM_MOUSELEAVE, 0, AControl);\r\n if Assigned(FOnMouseLeave) then\r\n FOnMouseLeave(Self);\r\nend;\r\n\r\nprocedure TJvExCustomEdit.FocusChanged(AControl: TWinControl);\r\nbegin\r\n BaseWndProc(CM_FOCUSCHANGED, 0, AControl);\r\nend;\r\n\r\nprocedure TJvExCustomEdit.BoundsChanged;\r\nbegin\r\nend;\r\n\r\nprocedure TJvExCustomEdit.CursorChanged;\r\nbegin\r\n BaseWndProc(CM_CURSORCHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomEdit.ShowingChanged;\r\nbegin\r\n BaseWndProc(CM_SHOWINGCHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomEdit.ShowHintChanged;\r\nbegin\r\n BaseWndProc(CM_SHOWHINTCHANGED);\r\nend;\r\n\r\n{ VCL sends CM_CONTROLLISTCHANGE and CM_CONTROLCHANGE in a different order than\r\n the CLX methods are used. So we must correct it by evaluating \"Inserting\". }\r\nprocedure TJvExCustomEdit.ControlsListChanging(Control: TControl; Inserting: Boolean);\r\nbegin\r\n if Inserting then\r\n BaseWndProc(CM_CONTROLLISTCHANGE, WPARAM(Control), LPARAM(Inserting))\r\n else\r\n BaseWndProc(CM_CONTROLCHANGE, WPARAM(Control), LPARAM(Inserting));\r\nend;\r\n\r\nprocedure TJvExCustomEdit.ControlsListChanged(Control: TControl; Inserting: Boolean);\r\nbegin\r\n if not Inserting then\r\n BaseWndProc(CM_CONTROLLISTCHANGE, WPARAM(Control), LPARAM(Inserting))\r\n else\r\n BaseWndProc(CM_CONTROLCHANGE, WPARAM(Control), LPARAM(Inserting));\r\nend;\r\n\r\nprocedure TJvExCustomEdit.GetDlgCode(var Code: TDlgCodes);\r\nbegin\r\nend;\r\n\r\nprocedure TJvExCustomEdit.FocusSet(PrevWnd: THandle);\r\nbegin\r\n BaseWndProc(WM_SETFOCUS, WPARAM(PrevWnd), 0);\r\nend;\r\n\r\nprocedure TJvExCustomEdit.FocusKilled(NextWnd: THandle);\r\nbegin\r\n BaseWndProc(WM_KILLFOCUS, WPARAM(NextWnd), 0);\r\nend;\r\n\r\nfunction TJvExCustomEdit.DoEraseBackground(Canvas: TCanvas; Param: LPARAM): Boolean;\r\nbegin\r\n Result := BaseWndProc(WM_ERASEBKGND, Canvas.Handle, Param) <> 0;\r\nend;\r\n\r\n{$IFDEF JVCLThemesEnabledD6}\r\nfunction TJvExCustomEdit.GetParentBackground: Boolean;\r\nbegin\r\n Result := JvThemes.GetParentBackground(Self);\r\nend;\r\n\r\nprocedure TJvExCustomEdit.SetParentBackground(Value: Boolean);\r\nbegin\r\n JvThemes.SetParentBackground(Self, Value);\r\nend;\r\n{$ENDIF JVCLThemesEnabledD6}\r\n\r\nprocedure TJvExCustomEdit.SetClipboardCommands(const Value: TJvClipboardCommands);\r\nbegin\r\n FClipboardCommands := Value;\r\nend;\r\n\r\nprocedure TJvExCustomEdit.WndProc(var Msg: TMessage);\r\nvar\r\n IdSaveDC: Integer;\r\n DlgCodes: TDlgCodes;\r\n Canvas: TCanvas;\r\nbegin\r\n if not DispatchIsDesignMsg(Self, Msg) then\r\n begin\r\n case Msg.Msg of\r\n CM_DENYSUBCLASSING:\r\n Msg.Result := LRESULT(Ord(GetInterfaceEntry(IJvDenySubClassing) <> nil));\r\n CM_DIALOGCHAR:\r\n with TCMDialogChar{$IFDEF CLR}.Create{$ENDIF}(Msg) do\r\n Result := LRESULT(Ord(WantKey(CharCode, KeyDataToShiftState(KeyData))));\r\n CM_HINTSHOW:\r\n with TCMHintShow(Msg) do\r\n Result := LRESULT(HintShow(HintInfo^));\r\n CM_HITTEST:\r\n with TCMHitTest(Msg) do\r\n Result := LRESULT(HitTest(XPos, YPos));\r\n CM_MOUSEENTER:\r\n MouseEnter(TControl(Msg.LParam));\r\n CM_MOUSELEAVE:\r\n MouseLeave(TControl(Msg.LParam));\r\n CM_VISIBLECHANGED:\r\n VisibleChanged;\r\n CM_ENABLEDCHANGED:\r\n EnabledChanged;\r\n CM_TEXTCHANGED:\r\n TextChanged;\r\n CM_FONTCHANGED:\r\n FontChanged;\r\n CM_COLORCHANGED:\r\n ColorChanged;\r\n CM_FOCUSCHANGED:\r\n FocusChanged(TWinControl(Msg.LParam));\r\n CM_PARENTFONTCHANGED:\r\n ParentFontChanged;\r\n CM_PARENTCOLORCHANGED:\r\n ParentColorChanged;\r\n CM_PARENTSHOWHINTCHANGED:\r\n ParentShowHintChanged;\r\n CM_CURSORCHANGED:\r\n CursorChanged;\r\n CM_SHOWINGCHANGED:\r\n ShowingChanged;\r\n CM_SHOWHINTCHANGED:\r\n ShowHintChanged;\r\n CM_CONTROLLISTCHANGE:\r\n if Msg.LParam <> 0 then\r\n ControlsListChanging(TControl(Msg.WParam), True)\r\n else\r\n ControlsListChanged(TControl(Msg.WParam), False);\r\n CM_CONTROLCHANGE:\r\n if Msg.LParam = 0 then\r\n ControlsListChanging(TControl(Msg.WParam), False)\r\n else\r\n ControlsListChanged(TControl(Msg.WParam), True);\r\n WM_SETFOCUS:\r\n FocusSet(THandle(Msg.WParam));\r\n WM_KILLFOCUS:\r\n FocusKilled(THandle(Msg.WParam));\r\n WM_SIZE, WM_MOVE:\r\n begin\r\n inherited WndProc(Msg);\r\n BoundsChanged;\r\n end;\r\n WM_ERASEBKGND:\r\n if (Msg.WParam <> 0) and not IsDefaultEraseBackground(DoEraseBackground, @TJvExCustomEdit.DoEraseBackground) then\r\n begin\r\n IdSaveDC := SaveDC(HDC(Msg.WParam)); // protect DC against Stock-Objects from Canvas\r\n Canvas := TCanvas.Create;\r\n try\r\n Canvas.Handle := HDC(Msg.WParam);\r\n Msg.Result := Ord(DoEraseBackground(Canvas, Msg.LParam));\r\n finally\r\n Canvas.Handle := 0;\r\n Canvas.Free;\r\n RestoreDC(HDC(Msg.WParam), IdSaveDC);\r\n end;\r\n end\r\n else\r\n inherited WndProc(Msg);\r\n {$IFNDEF DELPHI2007_UP}\r\n WM_PRINTCLIENT, WM_PRINT: // VCL bug fix\r\n begin\r\n IdSaveDC := SaveDC(HDC(Msg.WParam)); // protect DC against changes\r\n try\r\n inherited WndProc(Msg);\r\n finally\r\n RestoreDC(HDC(Msg.WParam), IdSaveDC);\r\n end;\r\n end;\r\n {$ENDIF ~DELPHI2007_UP}\r\n WM_GETDLGCODE:\r\n begin\r\n inherited WndProc(Msg);\r\n DlgCodes := [dcNative] + DlgcToDlgCodes(Msg.Result);\r\n GetDlgCode(DlgCodes);\r\n if not (dcNative in DlgCodes) then\r\n Msg.Result := DlgCodesToDlgc(DlgCodes);\r\n end;\r\n WM_CLEAR:\r\n if caClear in ClipboardCommands then\r\n inherited WndProc(Msg)\r\n else\r\n Msg.Result := 1;\r\n WM_UNDO, EM_UNDO:\r\n if caUndo in ClipboardCommands then\r\n inherited WndProc(Msg)\r\n else\r\n Msg.Result := 1;\r\n WM_COPY:\r\n if caCopy in ClipboardCommands then\r\n inherited WndProc(Msg)\r\n else\r\n Msg.Result := 1;\r\n WM_CUT:\r\n if caCut in ClipboardCommands then\r\n inherited WndProc(Msg)\r\n else\r\n Msg.Result := 1;\r\n WM_PASTE:\r\n if caPaste in ClipboardCommands then\r\n inherited WndProc(Msg)\r\n else\r\n Msg.Result := 1;\r\n else\r\n inherited WndProc(Msg);\r\n end;\r\n case Msg.Msg of // precheck message to prevent access violations on released controls\r\n CM_MOUSEENTER, CM_MOUSELEAVE, WM_KILLFOCUS, WM_SETFOCUS, WM_NCPAINT:\r\n if DotNetHighlighting then\r\n HandleDotNetHighlighting(Self, Msg, MouseOver, Color);\r\n end;\r\n end;\r\nend;\r\n\r\n//============================================================================\r\n\r\nconstructor TJvExCustomMemo.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FHintColor := clDefault;\r\n FClipboardCommands := [caCopy..caUndo];\r\nend;\r\n\r\nfunction TJvExCustomMemo.BaseWndProc(Msg: Cardinal; WParam: WPARAM = 0; LParam: LPARAM = 0): LRESULT;\r\nvar\r\n Mesg: TMessage;\r\nbegin\r\n CreateWMMessage(Mesg, Msg, WParam, LParam);\r\n inherited WndProc(Mesg);\r\n Result := Mesg.Result;\r\nend;\r\n\r\nfunction TJvExCustomMemo.BaseWndProc(Msg: Cardinal; WParam: WPARAM; LParam: TObject): LRESULT;\r\nbegin\r\n Result := BaseWndProc(Msg, WParam, Windows.LPARAM(LParam));\r\nend;\r\n\r\nfunction TJvExCustomMemo.BaseWndProcEx(Msg: Cardinal; WParam: WPARAM; var StructLParam): LRESULT;\r\nbegin\r\n Result := BaseWndProc(Msg, WParam, Windows.LPARAM(@StructLParam));\r\nend;\r\n\r\nprocedure TJvExCustomMemo.VisibleChanged;\r\nbegin\r\n BaseWndProc(CM_VISIBLECHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomMemo.EnabledChanged;\r\nbegin\r\n BaseWndProc(CM_ENABLEDCHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomMemo.TextChanged;\r\nbegin\r\n BaseWndProc(CM_TEXTCHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomMemo.FontChanged;\r\nbegin\r\n BaseWndProc(CM_FONTCHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomMemo.ColorChanged;\r\nbegin\r\n BaseWndProc(CM_COLORCHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomMemo.ParentFontChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTFONTCHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomMemo.ParentColorChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTCOLORCHANGED);\r\n if Assigned(OnParentColorChange) then\r\n OnParentColorChange(Self);\r\nend;\r\n\r\nprocedure TJvExCustomMemo.ParentShowHintChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTSHOWHINTCHANGED);\r\nend;\r\n\r\nfunction TJvExCustomMemo.WantKey(Key: Integer; Shift: TShiftState): Boolean;\r\nbegin\r\n Result := BaseWndProc(CM_DIALOGCHAR, Word(Key), ShiftStateToKeyData(Shift)) <> 0;\r\nend;\r\n\r\nfunction TJvExCustomMemo.HitTest(X, Y: Integer): Boolean;\r\nbegin\r\n Result := BaseWndProc(CM_HITTEST, 0, SmallPointToLong(PointToSmallPoint(Point(X, Y)))) <> 0;\r\nend;\r\n\r\nfunction TJvExCustomMemo.HintShow(var HintInfo: THintInfo): Boolean;\r\nbegin\r\n GetHintColor(HintInfo, Self, FHintColor);\r\n if FHintWindowClass <> nil then\r\n HintInfo.HintWindowClass := FHintWindowClass;\r\n Result := BaseWndProcEx(CM_HINTSHOW, 0, HintInfo) <> 0;\r\nend;\r\n\r\nprocedure TJvExCustomMemo.MouseEnter(AControl: TControl);\r\nbegin\r\n FMouseOver := True;\r\n if Assigned(FOnMouseEnter) then\r\n FOnMouseEnter(Self);\r\n BaseWndProc(CM_MOUSEENTER, 0, AControl);\r\nend;\r\n\r\nprocedure TJvExCustomMemo.MouseLeave(AControl: TControl);\r\nbegin\r\n FMouseOver := False;\r\n BaseWndProc(CM_MOUSELEAVE, 0, AControl);\r\n if Assigned(FOnMouseLeave) then\r\n FOnMouseLeave(Self);\r\nend;\r\n\r\nprocedure TJvExCustomMemo.FocusChanged(AControl: TWinControl);\r\nbegin\r\n BaseWndProc(CM_FOCUSCHANGED, 0, AControl);\r\nend;\r\n\r\nprocedure TJvExCustomMemo.BoundsChanged;\r\nbegin\r\nend;\r\n\r\nprocedure TJvExCustomMemo.CursorChanged;\r\nbegin\r\n BaseWndProc(CM_CURSORCHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomMemo.ShowingChanged;\r\nbegin\r\n BaseWndProc(CM_SHOWINGCHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomMemo.ShowHintChanged;\r\nbegin\r\n BaseWndProc(CM_SHOWHINTCHANGED);\r\nend;\r\n\r\n{ VCL sends CM_CONTROLLISTCHANGE and CM_CONTROLCHANGE in a different order than\r\n the CLX methods are used. So we must correct it by evaluating \"Inserting\". }\r\nprocedure TJvExCustomMemo.ControlsListChanging(Control: TControl; Inserting: Boolean);\r\nbegin\r\n if Inserting then\r\n BaseWndProc(CM_CONTROLLISTCHANGE, WPARAM(Control), LPARAM(Inserting))\r\n else\r\n BaseWndProc(CM_CONTROLCHANGE, WPARAM(Control), LPARAM(Inserting));\r\nend;\r\n\r\nprocedure TJvExCustomMemo.ControlsListChanged(Control: TControl; Inserting: Boolean);\r\nbegin\r\n if not Inserting then\r\n BaseWndProc(CM_CONTROLLISTCHANGE, WPARAM(Control), LPARAM(Inserting))\r\n else\r\n BaseWndProc(CM_CONTROLCHANGE, WPARAM(Control), LPARAM(Inserting));\r\nend;\r\n\r\nprocedure TJvExCustomMemo.GetDlgCode(var Code: TDlgCodes);\r\nbegin\r\nend;\r\n\r\nprocedure TJvExCustomMemo.FocusSet(PrevWnd: THandle);\r\nbegin\r\n BaseWndProc(WM_SETFOCUS, WPARAM(PrevWnd), 0);\r\nend;\r\n\r\nprocedure TJvExCustomMemo.FocusKilled(NextWnd: THandle);\r\nbegin\r\n BaseWndProc(WM_KILLFOCUS, WPARAM(NextWnd), 0);\r\nend;\r\n\r\nfunction TJvExCustomMemo.DoEraseBackground(Canvas: TCanvas; Param: LPARAM): Boolean;\r\nbegin\r\n Result := BaseWndProc(WM_ERASEBKGND, Canvas.Handle, Param) <> 0;\r\nend;\r\n\r\n{$IFDEF JVCLThemesEnabledD6}\r\nfunction TJvExCustomMemo.GetParentBackground: Boolean;\r\nbegin\r\n Result := JvThemes.GetParentBackground(Self);\r\nend;\r\n\r\nprocedure TJvExCustomMemo.SetParentBackground(Value: Boolean);\r\nbegin\r\n JvThemes.SetParentBackground(Self, Value);\r\nend;\r\n{$ENDIF JVCLThemesEnabledD6}\r\n\r\nprocedure TJvExCustomMemo.SetClipboardCommands(const Value: TJvClipboardCommands);\r\nbegin\r\n FClipboardCommands := Value;\r\nend;\r\n\r\nprocedure TJvExCustomMemo.WndProc(var Msg: TMessage);\r\nvar\r\n IdSaveDC: Integer;\r\n DlgCodes: TDlgCodes;\r\n Canvas: TCanvas;\r\nbegin\r\n if not DispatchIsDesignMsg(Self, Msg) then\r\n begin\r\n case Msg.Msg of\r\n CM_DENYSUBCLASSING:\r\n Msg.Result := LRESULT(Ord(GetInterfaceEntry(IJvDenySubClassing) <> nil));\r\n CM_DIALOGCHAR:\r\n with TCMDialogChar{$IFDEF CLR}.Create{$ENDIF}(Msg) do\r\n Result := LRESULT(Ord(WantKey(CharCode, KeyDataToShiftState(KeyData))));\r\n CM_HINTSHOW:\r\n with TCMHintShow(Msg) do\r\n Result := LRESULT(HintShow(HintInfo^));\r\n CM_HITTEST:\r\n with TCMHitTest(Msg) do\r\n Result := LRESULT(HitTest(XPos, YPos));\r\n CM_MOUSEENTER:\r\n MouseEnter(TControl(Msg.LParam));\r\n CM_MOUSELEAVE:\r\n MouseLeave(TControl(Msg.LParam));\r\n CM_VISIBLECHANGED:\r\n VisibleChanged;\r\n CM_ENABLEDCHANGED:\r\n EnabledChanged;\r\n CM_TEXTCHANGED:\r\n TextChanged;\r\n CM_FONTCHANGED:\r\n FontChanged;\r\n CM_COLORCHANGED:\r\n ColorChanged;\r\n CM_FOCUSCHANGED:\r\n FocusChanged(TWinControl(Msg.LParam));\r\n CM_PARENTFONTCHANGED:\r\n ParentFontChanged;\r\n CM_PARENTCOLORCHANGED:\r\n ParentColorChanged;\r\n CM_PARENTSHOWHINTCHANGED:\r\n ParentShowHintChanged;\r\n CM_CURSORCHANGED:\r\n CursorChanged;\r\n CM_SHOWINGCHANGED:\r\n ShowingChanged;\r\n CM_SHOWHINTCHANGED:\r\n ShowHintChanged;\r\n CM_CONTROLLISTCHANGE:\r\n if Msg.LParam <> 0 then\r\n ControlsListChanging(TControl(Msg.WParam), True)\r\n else\r\n ControlsListChanged(TControl(Msg.WParam), False);\r\n CM_CONTROLCHANGE:\r\n if Msg.LParam = 0 then\r\n ControlsListChanging(TControl(Msg.WParam), False)\r\n else\r\n ControlsListChanged(TControl(Msg.WParam), True);\r\n WM_SETFOCUS:\r\n FocusSet(THandle(Msg.WParam));\r\n WM_KILLFOCUS:\r\n FocusKilled(THandle(Msg.WParam));\r\n WM_SIZE, WM_MOVE:\r\n begin\r\n inherited WndProc(Msg);\r\n BoundsChanged;\r\n end;\r\n WM_ERASEBKGND:\r\n if (Msg.WParam <> 0) and not IsDefaultEraseBackground(DoEraseBackground, @TJvExCustomMemo.DoEraseBackground) then\r\n begin\r\n IdSaveDC := SaveDC(HDC(Msg.WParam)); // protect DC against Stock-Objects from Canvas\r\n Canvas := TCanvas.Create;\r\n try\r\n Canvas.Handle := HDC(Msg.WParam);\r\n Msg.Result := Ord(DoEraseBackground(Canvas, Msg.LParam));\r\n finally\r\n Canvas.Handle := 0;\r\n Canvas.Free;\r\n RestoreDC(HDC(Msg.WParam), IdSaveDC);\r\n end;\r\n end\r\n else\r\n inherited WndProc(Msg);\r\n {$IFNDEF DELPHI2007_UP}\r\n WM_PRINTCLIENT, WM_PRINT: // VCL bug fix\r\n begin\r\n IdSaveDC := SaveDC(HDC(Msg.WParam)); // protect DC against changes\r\n try\r\n inherited WndProc(Msg);\r\n finally\r\n RestoreDC(HDC(Msg.WParam), IdSaveDC);\r\n end;\r\n end;\r\n {$ENDIF ~DELPHI2007_UP}\r\n WM_GETDLGCODE:\r\n begin\r\n inherited WndProc(Msg);\r\n DlgCodes := [dcNative] + DlgcToDlgCodes(Msg.Result);\r\n GetDlgCode(DlgCodes);\r\n if not (dcNative in DlgCodes) then\r\n Msg.Result := DlgCodesToDlgc(DlgCodes);\r\n end;\r\n WM_CLEAR:\r\n if caClear in ClipboardCommands then\r\n inherited WndProc(Msg)\r\n else\r\n Msg.Result := 1;\r\n WM_UNDO, EM_UNDO:\r\n if caUndo in ClipboardCommands then\r\n inherited WndProc(Msg)\r\n else\r\n Msg.Result := 1;\r\n WM_COPY:\r\n if caCopy in ClipboardCommands then\r\n inherited WndProc(Msg)\r\n else\r\n Msg.Result := 1;\r\n WM_CUT:\r\n if caCut in ClipboardCommands then\r\n inherited WndProc(Msg)\r\n else\r\n Msg.Result := 1;\r\n WM_PASTE:\r\n if caPaste in ClipboardCommands then\r\n inherited WndProc(Msg)\r\n else\r\n Msg.Result := 1;\r\n else\r\n inherited WndProc(Msg);\r\n end;\r\n case Msg.Msg of // precheck message to prevent access violations on released controls\r\n CM_MOUSEENTER, CM_MOUSELEAVE, WM_KILLFOCUS, WM_SETFOCUS, WM_NCPAINT:\r\n if DotNetHighlighting then\r\n HandleDotNetHighlighting(Self, Msg, MouseOver, Color);\r\n end;\r\n end;\r\nend;\r\n\r\n//============================================================================\r\n\r\nconstructor TJvExCustomCombo.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FHintColor := clDefault;\r\nend;\r\n\r\nfunction TJvExCustomCombo.BaseWndProc(Msg: Cardinal; WParam: WPARAM = 0; LParam: LPARAM = 0): LRESULT;\r\nvar\r\n Mesg: TMessage;\r\nbegin\r\n CreateWMMessage(Mesg, Msg, WParam, LParam);\r\n inherited WndProc(Mesg);\r\n Result := Mesg.Result;\r\nend;\r\n\r\nfunction TJvExCustomCombo.BaseWndProc(Msg: Cardinal; WParam: WPARAM; LParam: TObject): LRESULT;\r\nbegin\r\n Result := BaseWndProc(Msg, WParam, Windows.LPARAM(LParam));\r\nend;\r\n\r\nfunction TJvExCustomCombo.BaseWndProcEx(Msg: Cardinal; WParam: WPARAM; var StructLParam): LRESULT;\r\nbegin\r\n Result := BaseWndProc(Msg, WParam, Windows.LPARAM(@StructLParam));\r\nend;\r\n\r\nprocedure TJvExCustomCombo.VisibleChanged;\r\nbegin\r\n BaseWndProc(CM_VISIBLECHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomCombo.EnabledChanged;\r\nbegin\r\n BaseWndProc(CM_ENABLEDCHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomCombo.TextChanged;\r\nbegin\r\n BaseWndProc(CM_TEXTCHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomCombo.FontChanged;\r\nbegin\r\n BaseWndProc(CM_FONTCHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomCombo.ColorChanged;\r\nbegin\r\n BaseWndProc(CM_COLORCHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomCombo.ParentFontChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTFONTCHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomCombo.ParentColorChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTCOLORCHANGED);\r\n if Assigned(OnParentColorChange) then\r\n OnParentColorChange(Self);\r\nend;\r\n\r\nprocedure TJvExCustomCombo.ParentShowHintChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTSHOWHINTCHANGED);\r\nend;\r\n\r\nfunction TJvExCustomCombo.WantKey(Key: Integer; Shift: TShiftState): Boolean;\r\nbegin\r\n Result := BaseWndProc(CM_DIALOGCHAR, Word(Key), ShiftStateToKeyData(Shift)) <> 0;\r\nend;\r\n\r\nfunction TJvExCustomCombo.HitTest(X, Y: Integer): Boolean;\r\nbegin\r\n Result := BaseWndProc(CM_HITTEST, 0, SmallPointToLong(PointToSmallPoint(Point(X, Y)))) <> 0;\r\nend;\r\n\r\nfunction TJvExCustomCombo.HintShow(var HintInfo: THintInfo): Boolean;\r\nbegin\r\n GetHintColor(HintInfo, Self, FHintColor);\r\n if FHintWindowClass <> nil then\r\n HintInfo.HintWindowClass := FHintWindowClass;\r\n Result := BaseWndProcEx(CM_HINTSHOW, 0, HintInfo) <> 0;\r\nend;\r\n\r\nprocedure TJvExCustomCombo.MouseEnter(AControl: TControl);\r\nbegin\r\n FMouseOver := True;\r\n if Assigned(FOnMouseEnter) then\r\n FOnMouseEnter(Self);\r\n BaseWndProc(CM_MOUSEENTER, 0, AControl);\r\nend;\r\n\r\nprocedure TJvExCustomCombo.MouseLeave(AControl: TControl);\r\nbegin\r\n FMouseOver := False;\r\n BaseWndProc(CM_MOUSELEAVE, 0, AControl);\r\n if Assigned(FOnMouseLeave) then\r\n FOnMouseLeave(Self);\r\nend;\r\n\r\nprocedure TJvExCustomCombo.FocusChanged(AControl: TWinControl);\r\nbegin\r\n BaseWndProc(CM_FOCUSCHANGED, 0, AControl);\r\nend;\r\n\r\nprocedure TJvExCustomCombo.BoundsChanged;\r\nbegin\r\nend;\r\n\r\nprocedure TJvExCustomCombo.CursorChanged;\r\nbegin\r\n BaseWndProc(CM_CURSORCHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomCombo.ShowingChanged;\r\nbegin\r\n BaseWndProc(CM_SHOWINGCHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomCombo.ShowHintChanged;\r\nbegin\r\n BaseWndProc(CM_SHOWHINTCHANGED);\r\nend;\r\n\r\n{ VCL sends CM_CONTROLLISTCHANGE and CM_CONTROLCHANGE in a different order than\r\n the CLX methods are used. So we must correct it by evaluating \"Inserting\". }\r\nprocedure TJvExCustomCombo.ControlsListChanging(Control: TControl; Inserting: Boolean);\r\nbegin\r\n if Inserting then\r\n BaseWndProc(CM_CONTROLLISTCHANGE, WPARAM(Control), LPARAM(Inserting))\r\n else\r\n BaseWndProc(CM_CONTROLCHANGE, WPARAM(Control), LPARAM(Inserting));\r\nend;\r\n\r\nprocedure TJvExCustomCombo.ControlsListChanged(Control: TControl; Inserting: Boolean);\r\nbegin\r\n if not Inserting then\r\n BaseWndProc(CM_CONTROLLISTCHANGE, WPARAM(Control), LPARAM(Inserting))\r\n else\r\n BaseWndProc(CM_CONTROLCHANGE, WPARAM(Control), LPARAM(Inserting));\r\nend;\r\n\r\nprocedure TJvExCustomCombo.GetDlgCode(var Code: TDlgCodes);\r\nbegin\r\nend;\r\n\r\nprocedure TJvExCustomCombo.FocusSet(PrevWnd: THandle);\r\nbegin\r\n BaseWndProc(WM_SETFOCUS, WPARAM(PrevWnd), 0);\r\nend;\r\n\r\nprocedure TJvExCustomCombo.FocusKilled(NextWnd: THandle);\r\nbegin\r\n BaseWndProc(WM_KILLFOCUS, WPARAM(NextWnd), 0);\r\nend;\r\n\r\nfunction TJvExCustomCombo.DoEraseBackground(Canvas: TCanvas; Param: LPARAM): Boolean;\r\nbegin\r\n Result := BaseWndProc(WM_ERASEBKGND, Canvas.Handle, Param) <> 0;\r\nend;\r\n\r\n{$IFDEF JVCLThemesEnabledD6}\r\nfunction TJvExCustomCombo.GetParentBackground: Boolean;\r\nbegin\r\n Result := JvThemes.GetParentBackground(Self);\r\nend;\r\n\r\nprocedure TJvExCustomCombo.SetParentBackground(Value: Boolean);\r\nbegin\r\n JvThemes.SetParentBackground(Self, Value);\r\nend;\r\n{$ENDIF JVCLThemesEnabledD6}\r\n\r\nprocedure TJvExCustomCombo.WndProc(var Msg: TMessage);\r\nvar\r\n IdSaveDC: Integer;\r\n DlgCodes: TDlgCodes;\r\n Canvas: TCanvas;\r\nbegin\r\n if not DispatchIsDesignMsg(Self, Msg) then\r\n begin\r\n case Msg.Msg of\r\n CM_DENYSUBCLASSING:\r\n Msg.Result := LRESULT(Ord(GetInterfaceEntry(IJvDenySubClassing) <> nil));\r\n CM_DIALOGCHAR:\r\n with TCMDialogChar{$IFDEF CLR}.Create{$ENDIF}(Msg) do\r\n Result := LRESULT(Ord(WantKey(CharCode, KeyDataToShiftState(KeyData))));\r\n CM_HINTSHOW:\r\n with TCMHintShow(Msg) do\r\n Result := LRESULT(HintShow(HintInfo^));\r\n CM_HITTEST:\r\n with TCMHitTest(Msg) do\r\n Result := LRESULT(HitTest(XPos, YPos));\r\n CM_MOUSEENTER:\r\n MouseEnter(TControl(Msg.LParam));\r\n CM_MOUSELEAVE:\r\n MouseLeave(TControl(Msg.LParam));\r\n CM_VISIBLECHANGED:\r\n VisibleChanged;\r\n CM_ENABLEDCHANGED:\r\n EnabledChanged;\r\n CM_TEXTCHANGED:\r\n TextChanged;\r\n CM_FONTCHANGED:\r\n FontChanged;\r\n CM_COLORCHANGED:\r\n ColorChanged;\r\n CM_FOCUSCHANGED:\r\n FocusChanged(TWinControl(Msg.LParam));\r\n CM_PARENTFONTCHANGED:\r\n ParentFontChanged;\r\n CM_PARENTCOLORCHANGED:\r\n ParentColorChanged;\r\n CM_PARENTSHOWHINTCHANGED:\r\n ParentShowHintChanged;\r\n CM_CURSORCHANGED:\r\n CursorChanged;\r\n CM_SHOWINGCHANGED:\r\n ShowingChanged;\r\n CM_SHOWHINTCHANGED:\r\n ShowHintChanged;\r\n CM_CONTROLLISTCHANGE:\r\n if Msg.LParam <> 0 then\r\n ControlsListChanging(TControl(Msg.WParam), True)\r\n else\r\n ControlsListChanged(TControl(Msg.WParam), False);\r\n CM_CONTROLCHANGE:\r\n if Msg.LParam = 0 then\r\n ControlsListChanging(TControl(Msg.WParam), False)\r\n else\r\n ControlsListChanged(TControl(Msg.WParam), True);\r\n WM_SETFOCUS:\r\n FocusSet(THandle(Msg.WParam));\r\n WM_KILLFOCUS:\r\n FocusKilled(THandle(Msg.WParam));\r\n WM_SIZE, WM_MOVE:\r\n begin\r\n inherited WndProc(Msg);\r\n BoundsChanged;\r\n end;\r\n WM_ERASEBKGND:\r\n if (Msg.WParam <> 0) and not IsDefaultEraseBackground(DoEraseBackground, @TJvExCustomCombo.DoEraseBackground) then\r\n begin\r\n IdSaveDC := SaveDC(HDC(Msg.WParam)); // protect DC against Stock-Objects from Canvas\r\n Canvas := TCanvas.Create;\r\n try\r\n Canvas.Handle := HDC(Msg.WParam);\r\n Msg.Result := Ord(DoEraseBackground(Canvas, Msg.LParam));\r\n finally\r\n Canvas.Handle := 0;\r\n Canvas.Free;\r\n RestoreDC(HDC(Msg.WParam), IdSaveDC);\r\n end;\r\n end\r\n else\r\n inherited WndProc(Msg);\r\n {$IFNDEF DELPHI2007_UP}\r\n WM_PRINTCLIENT, WM_PRINT: // VCL bug fix\r\n begin\r\n IdSaveDC := SaveDC(HDC(Msg.WParam)); // protect DC against changes\r\n try\r\n inherited WndProc(Msg);\r\n finally\r\n RestoreDC(HDC(Msg.WParam), IdSaveDC);\r\n end;\r\n end;\r\n {$ENDIF ~DELPHI2007_UP}\r\n WM_GETDLGCODE:\r\n begin\r\n inherited WndProc(Msg);\r\n DlgCodes := [dcNative] + DlgcToDlgCodes(Msg.Result);\r\n GetDlgCode(DlgCodes);\r\n if not (dcNative in DlgCodes) then\r\n Msg.Result := DlgCodesToDlgc(DlgCodes);\r\n end;\r\n else\r\n inherited WndProc(Msg);\r\n end;\r\n case Msg.Msg of // precheck message to prevent access violations on released controls\r\n CM_MOUSEENTER, CM_MOUSELEAVE, WM_KILLFOCUS, WM_SETFOCUS, WM_NCPAINT:\r\n if DotNetHighlighting then\r\n HandleDotNetHighlighting(Self, Msg, MouseOver, Color);\r\n end;\r\n end;\r\nend;\r\n\r\n//============================================================================\r\n\r\nconstructor TJvExCustomComboBox.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FHintColor := clDefault;\r\nend;\r\n\r\nfunction TJvExCustomComboBox.BaseWndProc(Msg: Cardinal; WParam: WPARAM = 0; LParam: LPARAM = 0): LRESULT;\r\nvar\r\n Mesg: TMessage;\r\nbegin\r\n CreateWMMessage(Mesg, Msg, WParam, LParam);\r\n inherited WndProc(Mesg);\r\n Result := Mesg.Result;\r\nend;\r\n\r\nfunction TJvExCustomComboBox.BaseWndProc(Msg: Cardinal; WParam: WPARAM; LParam: TObject): LRESULT;\r\nbegin\r\n Result := BaseWndProc(Msg, WParam, Windows.LPARAM(LParam));\r\nend;\r\n\r\nfunction TJvExCustomComboBox.BaseWndProcEx(Msg: Cardinal; WParam: WPARAM; var StructLParam): LRESULT;\r\nbegin\r\n Result := BaseWndProc(Msg, WParam, Windows.LPARAM(@StructLParam));\r\nend;\r\n\r\nprocedure TJvExCustomComboBox.VisibleChanged;\r\nbegin\r\n BaseWndProc(CM_VISIBLECHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomComboBox.EnabledChanged;\r\nbegin\r\n BaseWndProc(CM_ENABLEDCHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomComboBox.TextChanged;\r\nbegin\r\n BaseWndProc(CM_TEXTCHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomComboBox.FontChanged;\r\nbegin\r\n BaseWndProc(CM_FONTCHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomComboBox.ColorChanged;\r\nbegin\r\n BaseWndProc(CM_COLORCHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomComboBox.ParentFontChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTFONTCHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomComboBox.ParentColorChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTCOLORCHANGED);\r\n if Assigned(OnParentColorChange) then\r\n OnParentColorChange(Self);\r\nend;\r\n\r\nprocedure TJvExCustomComboBox.ParentShowHintChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTSHOWHINTCHANGED);\r\nend;\r\n\r\nfunction TJvExCustomComboBox.WantKey(Key: Integer; Shift: TShiftState): Boolean;\r\nbegin\r\n Result := BaseWndProc(CM_DIALOGCHAR, Word(Key), ShiftStateToKeyData(Shift)) <> 0;\r\nend;\r\n\r\nfunction TJvExCustomComboBox.HitTest(X, Y: Integer): Boolean;\r\nbegin\r\n Result := BaseWndProc(CM_HITTEST, 0, SmallPointToLong(PointToSmallPoint(Point(X, Y)))) <> 0;\r\nend;\r\n\r\nfunction TJvExCustomComboBox.HintShow(var HintInfo: THintInfo): Boolean;\r\nbegin\r\n GetHintColor(HintInfo, Self, FHintColor);\r\n if FHintWindowClass <> nil then\r\n HintInfo.HintWindowClass := FHintWindowClass;\r\n Result := BaseWndProcEx(CM_HINTSHOW, 0, HintInfo) <> 0;\r\nend;\r\n\r\nprocedure TJvExCustomComboBox.MouseEnter(AControl: TControl);\r\nbegin\r\n FMouseOver := True;\r\n if Assigned(FOnMouseEnter) then\r\n FOnMouseEnter(Self);\r\n BaseWndProc(CM_MOUSEENTER, 0, AControl);\r\nend;\r\n\r\nprocedure TJvExCustomComboBox.MouseLeave(AControl: TControl);\r\nbegin\r\n FMouseOver := False;\r\n BaseWndProc(CM_MOUSELEAVE, 0, AControl);\r\n if Assigned(FOnMouseLeave) then\r\n FOnMouseLeave(Self);\r\nend;\r\n\r\nprocedure TJvExCustomComboBox.FocusChanged(AControl: TWinControl);\r\nbegin\r\n BaseWndProc(CM_FOCUSCHANGED, 0, AControl);\r\nend;\r\n\r\nprocedure TJvExCustomComboBox.BoundsChanged;\r\nbegin\r\nend;\r\n\r\nprocedure TJvExCustomComboBox.CursorChanged;\r\nbegin\r\n BaseWndProc(CM_CURSORCHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomComboBox.ShowingChanged;\r\nbegin\r\n BaseWndProc(CM_SHOWINGCHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomComboBox.ShowHintChanged;\r\nbegin\r\n BaseWndProc(CM_SHOWHINTCHANGED);\r\nend;\r\n\r\n{ VCL sends CM_CONTROLLISTCHANGE and CM_CONTROLCHANGE in a different order than\r\n the CLX methods are used. So we must correct it by evaluating \"Inserting\". }\r\nprocedure TJvExCustomComboBox.ControlsListChanging(Control: TControl; Inserting: Boolean);\r\nbegin\r\n if Inserting then\r\n BaseWndProc(CM_CONTROLLISTCHANGE, WPARAM(Control), LPARAM(Inserting))\r\n else\r\n BaseWndProc(CM_CONTROLCHANGE, WPARAM(Control), LPARAM(Inserting));\r\nend;\r\n\r\nprocedure TJvExCustomComboBox.ControlsListChanged(Control: TControl; Inserting: Boolean);\r\nbegin\r\n if not Inserting then\r\n BaseWndProc(CM_CONTROLLISTCHANGE, WPARAM(Control), LPARAM(Inserting))\r\n else\r\n BaseWndProc(CM_CONTROLCHANGE, WPARAM(Control), LPARAM(Inserting));\r\nend;\r\n\r\nprocedure TJvExCustomComboBox.GetDlgCode(var Code: TDlgCodes);\r\nbegin\r\nend;\r\n\r\nprocedure TJvExCustomComboBox.FocusSet(PrevWnd: THandle);\r\nbegin\r\n BaseWndProc(WM_SETFOCUS, WPARAM(PrevWnd), 0);\r\nend;\r\n\r\nprocedure TJvExCustomComboBox.FocusKilled(NextWnd: THandle);\r\nbegin\r\n BaseWndProc(WM_KILLFOCUS, WPARAM(NextWnd), 0);\r\nend;\r\n\r\nfunction TJvExCustomComboBox.DoEraseBackground(Canvas: TCanvas; Param: LPARAM): Boolean;\r\nbegin\r\n Result := BaseWndProc(WM_ERASEBKGND, Canvas.Handle, Param) <> 0;\r\nend;\r\n\r\n{$IFDEF JVCLThemesEnabledD6}\r\nfunction TJvExCustomComboBox.GetParentBackground: Boolean;\r\nbegin\r\n Result := JvThemes.GetParentBackground(Self);\r\nend;\r\n\r\nprocedure TJvExCustomComboBox.SetParentBackground(Value: Boolean);\r\nbegin\r\n JvThemes.SetParentBackground(Self, Value);\r\nend;\r\n{$ENDIF JVCLThemesEnabledD6}\r\n\r\nprocedure TJvExCustomComboBox.WndProc(var Msg: TMessage);\r\nvar\r\n IdSaveDC: Integer;\r\n DlgCodes: TDlgCodes;\r\n Canvas: TCanvas;\r\nbegin\r\n if not DispatchIsDesignMsg(Self, Msg) then\r\n begin\r\n case Msg.Msg of\r\n CM_DENYSUBCLASSING:\r\n Msg.Result := LRESULT(Ord(GetInterfaceEntry(IJvDenySubClassing) <> nil));\r\n CM_DIALOGCHAR:\r\n with TCMDialogChar{$IFDEF CLR}.Create{$ENDIF}(Msg) do\r\n Result := LRESULT(Ord(WantKey(CharCode, KeyDataToShiftState(KeyData))));\r\n CM_HINTSHOW:\r\n with TCMHintShow(Msg) do\r\n Result := LRESULT(HintShow(HintInfo^));\r\n CM_HITTEST:\r\n with TCMHitTest(Msg) do\r\n Result := LRESULT(HitTest(XPos, YPos));\r\n CM_MOUSEENTER:\r\n MouseEnter(TControl(Msg.LParam));\r\n CM_MOUSELEAVE:\r\n MouseLeave(TControl(Msg.LParam));\r\n CM_VISIBLECHANGED:\r\n VisibleChanged;\r\n CM_ENABLEDCHANGED:\r\n EnabledChanged;\r\n CM_TEXTCHANGED:\r\n TextChanged;\r\n CM_FONTCHANGED:\r\n FontChanged;\r\n CM_COLORCHANGED:\r\n ColorChanged;\r\n CM_FOCUSCHANGED:\r\n FocusChanged(TWinControl(Msg.LParam));\r\n CM_PARENTFONTCHANGED:\r\n ParentFontChanged;\r\n CM_PARENTCOLORCHANGED:\r\n ParentColorChanged;\r\n CM_PARENTSHOWHINTCHANGED:\r\n ParentShowHintChanged;\r\n CM_CURSORCHANGED:\r\n CursorChanged;\r\n CM_SHOWINGCHANGED:\r\n ShowingChanged;\r\n CM_SHOWHINTCHANGED:\r\n ShowHintChanged;\r\n CM_CONTROLLISTCHANGE:\r\n if Msg.LParam <> 0 then\r\n ControlsListChanging(TControl(Msg.WParam), True)\r\n else\r\n ControlsListChanged(TControl(Msg.WParam), False);\r\n CM_CONTROLCHANGE:\r\n if Msg.LParam = 0 then\r\n ControlsListChanging(TControl(Msg.WParam), False)\r\n else\r\n ControlsListChanged(TControl(Msg.WParam), True);\r\n WM_SETFOCUS:\r\n FocusSet(THandle(Msg.WParam));\r\n WM_KILLFOCUS:\r\n FocusKilled(THandle(Msg.WParam));\r\n WM_SIZE, WM_MOVE:\r\n begin\r\n inherited WndProc(Msg);\r\n BoundsChanged;\r\n end;\r\n WM_ERASEBKGND:\r\n if (Msg.WParam <> 0) and not IsDefaultEraseBackground(DoEraseBackground, @TJvExCustomComboBox.DoEraseBackground) then\r\n begin\r\n IdSaveDC := SaveDC(HDC(Msg.WParam)); // protect DC against Stock-Objects from Canvas\r\n Canvas := TCanvas.Create;\r\n try\r\n Canvas.Handle := HDC(Msg.WParam);\r\n Msg.Result := Ord(DoEraseBackground(Canvas, Msg.LParam));\r\n finally\r\n Canvas.Handle := 0;\r\n Canvas.Free;\r\n RestoreDC(HDC(Msg.WParam), IdSaveDC);\r\n end;\r\n end\r\n else\r\n inherited WndProc(Msg);\r\n {$IFNDEF DELPHI2007_UP}\r\n WM_PRINTCLIENT, WM_PRINT: // VCL bug fix\r\n begin\r\n IdSaveDC := SaveDC(HDC(Msg.WParam)); // protect DC against changes\r\n try\r\n inherited WndProc(Msg);\r\n finally\r\n RestoreDC(HDC(Msg.WParam), IdSaveDC);\r\n end;\r\n end;\r\n {$ENDIF ~DELPHI2007_UP}\r\n WM_GETDLGCODE:\r\n begin\r\n inherited WndProc(Msg);\r\n DlgCodes := [dcNative] + DlgcToDlgCodes(Msg.Result);\r\n GetDlgCode(DlgCodes);\r\n if not (dcNative in DlgCodes) then\r\n Msg.Result := DlgCodesToDlgc(DlgCodes);\r\n end;\r\n else\r\n inherited WndProc(Msg);\r\n end;\r\n case Msg.Msg of // precheck message to prevent access violations on released controls\r\n CM_MOUSEENTER, CM_MOUSELEAVE, WM_KILLFOCUS, WM_SETFOCUS, WM_NCPAINT:\r\n if DotNetHighlighting then\r\n HandleDotNetHighlighting(Self, Msg, MouseOver, Color);\r\n end;\r\n end;\r\nend;\r\n\r\n//============================================================================\r\n\r\nconstructor TJvExButtonControl.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FHintColor := clDefault;\r\nend;\r\n\r\nfunction TJvExButtonControl.BaseWndProc(Msg: Cardinal; WParam: WPARAM = 0; LParam: LPARAM = 0): LRESULT;\r\nvar\r\n Mesg: TMessage;\r\nbegin\r\n CreateWMMessage(Mesg, Msg, WParam, LParam);\r\n inherited WndProc(Mesg);\r\n Result := Mesg.Result;\r\nend;\r\n\r\nfunction TJvExButtonControl.BaseWndProc(Msg: Cardinal; WParam: WPARAM; LParam: TObject): LRESULT;\r\nbegin\r\n Result := BaseWndProc(Msg, WParam, Windows.LPARAM(LParam));\r\nend;\r\n\r\nfunction TJvExButtonControl.BaseWndProcEx(Msg: Cardinal; WParam: WPARAM; var StructLParam): LRESULT;\r\nbegin\r\n Result := BaseWndProc(Msg, WParam, Windows.LPARAM(@StructLParam));\r\nend;\r\n\r\nprocedure TJvExButtonControl.VisibleChanged;\r\nbegin\r\n BaseWndProc(CM_VISIBLECHANGED);\r\nend;\r\n\r\nprocedure TJvExButtonControl.EnabledChanged;\r\nbegin\r\n BaseWndProc(CM_ENABLEDCHANGED);\r\nend;\r\n\r\nprocedure TJvExButtonControl.TextChanged;\r\nbegin\r\n BaseWndProc(CM_TEXTCHANGED);\r\nend;\r\n\r\nprocedure TJvExButtonControl.FontChanged;\r\nbegin\r\n BaseWndProc(CM_FONTCHANGED);\r\nend;\r\n\r\nprocedure TJvExButtonControl.ColorChanged;\r\nbegin\r\n BaseWndProc(CM_COLORCHANGED);\r\nend;\r\n\r\nprocedure TJvExButtonControl.ParentFontChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTFONTCHANGED);\r\nend;\r\n\r\nprocedure TJvExButtonControl.ParentColorChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTCOLORCHANGED);\r\n if Assigned(OnParentColorChange) then\r\n OnParentColorChange(Self);\r\nend;\r\n\r\nprocedure TJvExButtonControl.ParentShowHintChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTSHOWHINTCHANGED);\r\nend;\r\n\r\nfunction TJvExButtonControl.WantKey(Key: Integer; Shift: TShiftState): Boolean;\r\nbegin\r\n Result := BaseWndProc(CM_DIALOGCHAR, Word(Key), ShiftStateToKeyData(Shift)) <> 0;\r\nend;\r\n\r\nfunction TJvExButtonControl.HitTest(X, Y: Integer): Boolean;\r\nbegin\r\n Result := BaseWndProc(CM_HITTEST, 0, SmallPointToLong(PointToSmallPoint(Point(X, Y)))) <> 0;\r\nend;\r\n\r\nfunction TJvExButtonControl.HintShow(var HintInfo: THintInfo): Boolean;\r\nbegin\r\n GetHintColor(HintInfo, Self, FHintColor);\r\n if FHintWindowClass <> nil then\r\n HintInfo.HintWindowClass := FHintWindowClass;\r\n Result := BaseWndProcEx(CM_HINTSHOW, 0, HintInfo) <> 0;\r\nend;\r\n\r\nprocedure TJvExButtonControl.MouseEnter(AControl: TControl);\r\nbegin\r\n FMouseOver := True;\r\n if Assigned(FOnMouseEnter) then\r\n FOnMouseEnter(Self);\r\n BaseWndProc(CM_MOUSEENTER, 0, AControl);\r\nend;\r\n\r\nprocedure TJvExButtonControl.MouseLeave(AControl: TControl);\r\nbegin\r\n FMouseOver := False;\r\n BaseWndProc(CM_MOUSELEAVE, 0, AControl);\r\n if Assigned(FOnMouseLeave) then\r\n FOnMouseLeave(Self);\r\nend;\r\n\r\nprocedure TJvExButtonControl.FocusChanged(AControl: TWinControl);\r\nbegin\r\n BaseWndProc(CM_FOCUSCHANGED, 0, AControl);\r\nend;\r\n\r\nprocedure TJvExButtonControl.BoundsChanged;\r\nbegin\r\nend;\r\n\r\nprocedure TJvExButtonControl.CursorChanged;\r\nbegin\r\n BaseWndProc(CM_CURSORCHANGED);\r\nend;\r\n\r\nprocedure TJvExButtonControl.ShowingChanged;\r\nbegin\r\n BaseWndProc(CM_SHOWINGCHANGED);\r\nend;\r\n\r\nprocedure TJvExButtonControl.ShowHintChanged;\r\nbegin\r\n BaseWndProc(CM_SHOWHINTCHANGED);\r\nend;\r\n\r\n{ VCL sends CM_CONTROLLISTCHANGE and CM_CONTROLCHANGE in a different order than\r\n the CLX methods are used. So we must correct it by evaluating \"Inserting\". }\r\nprocedure TJvExButtonControl.ControlsListChanging(Control: TControl; Inserting: Boolean);\r\nbegin\r\n if Inserting then\r\n BaseWndProc(CM_CONTROLLISTCHANGE, WPARAM(Control), LPARAM(Inserting))\r\n else\r\n BaseWndProc(CM_CONTROLCHANGE, WPARAM(Control), LPARAM(Inserting));\r\nend;\r\n\r\nprocedure TJvExButtonControl.ControlsListChanged(Control: TControl; Inserting: Boolean);\r\nbegin\r\n if not Inserting then\r\n BaseWndProc(CM_CONTROLLISTCHANGE, WPARAM(Control), LPARAM(Inserting))\r\n else\r\n BaseWndProc(CM_CONTROLCHANGE, WPARAM(Control), LPARAM(Inserting));\r\nend;\r\n\r\nprocedure TJvExButtonControl.GetDlgCode(var Code: TDlgCodes);\r\nbegin\r\nend;\r\n\r\nprocedure TJvExButtonControl.FocusSet(PrevWnd: THandle);\r\nbegin\r\n BaseWndProc(WM_SETFOCUS, WPARAM(PrevWnd), 0);\r\nend;\r\n\r\nprocedure TJvExButtonControl.FocusKilled(NextWnd: THandle);\r\nbegin\r\n BaseWndProc(WM_KILLFOCUS, WPARAM(NextWnd), 0);\r\nend;\r\n\r\nfunction TJvExButtonControl.DoEraseBackground(Canvas: TCanvas; Param: LPARAM): Boolean;\r\nbegin\r\n Result := BaseWndProc(WM_ERASEBKGND, Canvas.Handle, Param) <> 0;\r\nend;\r\n\r\n{$IFDEF JVCLThemesEnabledD6}\r\nfunction TJvExButtonControl.GetParentBackground: Boolean;\r\nbegin\r\n Result := JvThemes.GetParentBackground(Self);\r\nend;\r\n\r\nprocedure TJvExButtonControl.SetParentBackground(Value: Boolean);\r\nbegin\r\n JvThemes.SetParentBackground(Self, Value);\r\nend;\r\n{$ENDIF JVCLThemesEnabledD6}\r\n\r\nprocedure TJvExButtonControl.WndProc(var Msg: TMessage);\r\nvar\r\n IdSaveDC: Integer;\r\n DlgCodes: TDlgCodes;\r\n Canvas: TCanvas;\r\nbegin\r\n if not DispatchIsDesignMsg(Self, Msg) then\r\n begin\r\n case Msg.Msg of\r\n CM_DENYSUBCLASSING:\r\n Msg.Result := LRESULT(Ord(GetInterfaceEntry(IJvDenySubClassing) <> nil));\r\n CM_DIALOGCHAR:\r\n with TCMDialogChar{$IFDEF CLR}.Create{$ENDIF}(Msg) do\r\n Result := LRESULT(Ord(WantKey(CharCode, KeyDataToShiftState(KeyData))));\r\n CM_HINTSHOW:\r\n with TCMHintShow(Msg) do\r\n Result := LRESULT(HintShow(HintInfo^));\r\n CM_HITTEST:\r\n with TCMHitTest(Msg) do\r\n Result := LRESULT(HitTest(XPos, YPos));\r\n CM_MOUSEENTER:\r\n MouseEnter(TControl(Msg.LParam));\r\n CM_MOUSELEAVE:\r\n MouseLeave(TControl(Msg.LParam));\r\n CM_VISIBLECHANGED:\r\n VisibleChanged;\r\n CM_ENABLEDCHANGED:\r\n EnabledChanged;\r\n CM_TEXTCHANGED:\r\n TextChanged;\r\n CM_FONTCHANGED:\r\n FontChanged;\r\n CM_COLORCHANGED:\r\n ColorChanged;\r\n CM_FOCUSCHANGED:\r\n FocusChanged(TWinControl(Msg.LParam));\r\n CM_PARENTFONTCHANGED:\r\n ParentFontChanged;\r\n CM_PARENTCOLORCHANGED:\r\n ParentColorChanged;\r\n CM_PARENTSHOWHINTCHANGED:\r\n ParentShowHintChanged;\r\n CM_CURSORCHANGED:\r\n CursorChanged;\r\n CM_SHOWINGCHANGED:\r\n ShowingChanged;\r\n CM_SHOWHINTCHANGED:\r\n ShowHintChanged;\r\n CM_CONTROLLISTCHANGE:\r\n if Msg.LParam <> 0 then\r\n ControlsListChanging(TControl(Msg.WParam), True)\r\n else\r\n ControlsListChanged(TControl(Msg.WParam), False);\r\n CM_CONTROLCHANGE:\r\n if Msg.LParam = 0 then\r\n ControlsListChanging(TControl(Msg.WParam), False)\r\n else\r\n ControlsListChanged(TControl(Msg.WParam), True);\r\n WM_SETFOCUS:\r\n FocusSet(THandle(Msg.WParam));\r\n WM_KILLFOCUS:\r\n FocusKilled(THandle(Msg.WParam));\r\n WM_SIZE, WM_MOVE:\r\n begin\r\n inherited WndProc(Msg);\r\n BoundsChanged;\r\n end;\r\n WM_ERASEBKGND:\r\n if (Msg.WParam <> 0) and not IsDefaultEraseBackground(DoEraseBackground, @TJvExButtonControl.DoEraseBackground) then\r\n begin\r\n IdSaveDC := SaveDC(HDC(Msg.WParam)); // protect DC against Stock-Objects from Canvas\r\n Canvas := TCanvas.Create;\r\n try\r\n Canvas.Handle := HDC(Msg.WParam);\r\n Msg.Result := Ord(DoEraseBackground(Canvas, Msg.LParam));\r\n finally\r\n Canvas.Handle := 0;\r\n Canvas.Free;\r\n RestoreDC(HDC(Msg.WParam), IdSaveDC);\r\n end;\r\n end\r\n else\r\n inherited WndProc(Msg);\r\n {$IFNDEF DELPHI2007_UP}\r\n WM_PRINTCLIENT, WM_PRINT: // VCL bug fix\r\n begin\r\n IdSaveDC := SaveDC(HDC(Msg.WParam)); // protect DC against changes\r\n try\r\n inherited WndProc(Msg);\r\n finally\r\n RestoreDC(HDC(Msg.WParam), IdSaveDC);\r\n end;\r\n end;\r\n {$ENDIF ~DELPHI2007_UP}\r\n WM_GETDLGCODE:\r\n begin\r\n inherited WndProc(Msg);\r\n DlgCodes := [dcNative] + DlgcToDlgCodes(Msg.Result);\r\n GetDlgCode(DlgCodes);\r\n if not (dcNative in DlgCodes) then\r\n Msg.Result := DlgCodesToDlgc(DlgCodes);\r\n end;\r\n else\r\n inherited WndProc(Msg);\r\n end;\r\n case Msg.Msg of // precheck message to prevent access violations on released controls\r\n CM_MOUSEENTER, CM_MOUSELEAVE, WM_KILLFOCUS, WM_SETFOCUS, WM_NCPAINT:\r\n if DotNetHighlighting then\r\n HandleDotNetHighlighting(Self, Msg, MouseOver, Color);\r\n end;\r\n end;\r\nend;\r\n\r\n//============================================================================\r\n\r\nconstructor TJvExButton.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FHintColor := clDefault;\r\nend;\r\n\r\nfunction TJvExButton.BaseWndProc(Msg: Cardinal; WParam: WPARAM = 0; LParam: LPARAM = 0): LRESULT;\r\nvar\r\n Mesg: TMessage;\r\nbegin\r\n CreateWMMessage(Mesg, Msg, WParam, LParam);\r\n inherited WndProc(Mesg);\r\n Result := Mesg.Result;\r\nend;\r\n\r\nfunction TJvExButton.BaseWndProc(Msg: Cardinal; WParam: WPARAM; LParam: TObject): LRESULT;\r\nbegin\r\n Result := BaseWndProc(Msg, WParam, Windows.LPARAM(LParam));\r\nend;\r\n\r\nfunction TJvExButton.BaseWndProcEx(Msg: Cardinal; WParam: WPARAM; var StructLParam): LRESULT;\r\nbegin\r\n Result := BaseWndProc(Msg, WParam, Windows.LPARAM(@StructLParam));\r\nend;\r\n\r\nprocedure TJvExButton.VisibleChanged;\r\nbegin\r\n BaseWndProc(CM_VISIBLECHANGED);\r\nend;\r\n\r\nprocedure TJvExButton.EnabledChanged;\r\nbegin\r\n BaseWndProc(CM_ENABLEDCHANGED);\r\nend;\r\n\r\nprocedure TJvExButton.TextChanged;\r\nbegin\r\n BaseWndProc(CM_TEXTCHANGED);\r\nend;\r\n\r\nprocedure TJvExButton.FontChanged;\r\nbegin\r\n BaseWndProc(CM_FONTCHANGED);\r\nend;\r\n\r\nprocedure TJvExButton.ColorChanged;\r\nbegin\r\n BaseWndProc(CM_COLORCHANGED);\r\nend;\r\n\r\nprocedure TJvExButton.ParentFontChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTFONTCHANGED);\r\nend;\r\n\r\nprocedure TJvExButton.ParentColorChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTCOLORCHANGED);\r\n if Assigned(OnParentColorChange) then\r\n OnParentColorChange(Self);\r\nend;\r\n\r\nprocedure TJvExButton.ParentShowHintChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTSHOWHINTCHANGED);\r\nend;\r\n\r\nfunction TJvExButton.WantKey(Key: Integer; Shift: TShiftState): Boolean;\r\nbegin\r\n Result := BaseWndProc(CM_DIALOGCHAR, Word(Key), ShiftStateToKeyData(Shift)) <> 0;\r\nend;\r\n\r\nfunction TJvExButton.HitTest(X, Y: Integer): Boolean;\r\nbegin\r\n Result := BaseWndProc(CM_HITTEST, 0, SmallPointToLong(PointToSmallPoint(Point(X, Y)))) <> 0;\r\nend;\r\n\r\nfunction TJvExButton.HintShow(var HintInfo: THintInfo): Boolean;\r\nbegin\r\n GetHintColor(HintInfo, Self, FHintColor);\r\n if FHintWindowClass <> nil then\r\n HintInfo.HintWindowClass := FHintWindowClass;\r\n Result := BaseWndProcEx(CM_HINTSHOW, 0, HintInfo) <> 0;\r\nend;\r\n\r\nprocedure TJvExButton.MouseEnter(AControl: TControl);\r\nbegin\r\n FMouseOver := True;\r\n if Assigned(FOnMouseEnter) then\r\n FOnMouseEnter(Self);\r\n BaseWndProc(CM_MOUSEENTER, 0, AControl);\r\nend;\r\n\r\nprocedure TJvExButton.MouseLeave(AControl: TControl);\r\nbegin\r\n FMouseOver := False;\r\n BaseWndProc(CM_MOUSELEAVE, 0, AControl);\r\n if Assigned(FOnMouseLeave) then\r\n FOnMouseLeave(Self);\r\nend;\r\n\r\nprocedure TJvExButton.FocusChanged(AControl: TWinControl);\r\nbegin\r\n BaseWndProc(CM_FOCUSCHANGED, 0, AControl);\r\nend;\r\n\r\nprocedure TJvExButton.BoundsChanged;\r\nbegin\r\nend;\r\n\r\nprocedure TJvExButton.CursorChanged;\r\nbegin\r\n BaseWndProc(CM_CURSORCHANGED);\r\nend;\r\n\r\nprocedure TJvExButton.ShowingChanged;\r\nbegin\r\n BaseWndProc(CM_SHOWINGCHANGED);\r\nend;\r\n\r\nprocedure TJvExButton.ShowHintChanged;\r\nbegin\r\n BaseWndProc(CM_SHOWHINTCHANGED);\r\nend;\r\n\r\n{ VCL sends CM_CONTROLLISTCHANGE and CM_CONTROLCHANGE in a different order than\r\n the CLX methods are used. So we must correct it by evaluating \"Inserting\". }\r\nprocedure TJvExButton.ControlsListChanging(Control: TControl; Inserting: Boolean);\r\nbegin\r\n if Inserting then\r\n BaseWndProc(CM_CONTROLLISTCHANGE, WPARAM(Control), LPARAM(Inserting))\r\n else\r\n BaseWndProc(CM_CONTROLCHANGE, WPARAM(Control), LPARAM(Inserting));\r\nend;\r\n\r\nprocedure TJvExButton.ControlsListChanged(Control: TControl; Inserting: Boolean);\r\nbegin\r\n if not Inserting then\r\n BaseWndProc(CM_CONTROLLISTCHANGE, WPARAM(Control), LPARAM(Inserting))\r\n else\r\n BaseWndProc(CM_CONTROLCHANGE, WPARAM(Control), LPARAM(Inserting));\r\nend;\r\n\r\nprocedure TJvExButton.GetDlgCode(var Code: TDlgCodes);\r\nbegin\r\nend;\r\n\r\nprocedure TJvExButton.FocusSet(PrevWnd: THandle);\r\nbegin\r\n BaseWndProc(WM_SETFOCUS, WPARAM(PrevWnd), 0);\r\nend;\r\n\r\nprocedure TJvExButton.FocusKilled(NextWnd: THandle);\r\nbegin\r\n BaseWndProc(WM_KILLFOCUS, WPARAM(NextWnd), 0);\r\nend;\r\n\r\nfunction TJvExButton.DoEraseBackground(Canvas: TCanvas; Param: LPARAM): Boolean;\r\nbegin\r\n Result := BaseWndProc(WM_ERASEBKGND, Canvas.Handle, Param) <> 0;\r\nend;\r\n\r\n{$IFDEF JVCLThemesEnabledD6}\r\nfunction TJvExButton.GetParentBackground: Boolean;\r\nbegin\r\n Result := JvThemes.GetParentBackground(Self);\r\nend;\r\n\r\nprocedure TJvExButton.SetParentBackground(Value: Boolean);\r\nbegin\r\n JvThemes.SetParentBackground(Self, Value);\r\nend;\r\n{$ENDIF JVCLThemesEnabledD6}\r\n\r\nprocedure TJvExButton.WndProc(var Msg: TMessage);\r\nvar\r\n IdSaveDC: Integer;\r\n DlgCodes: TDlgCodes;\r\n Canvas: TCanvas;\r\nbegin\r\n if not DispatchIsDesignMsg(Self, Msg) then\r\n begin\r\n case Msg.Msg of\r\n CM_DENYSUBCLASSING:\r\n Msg.Result := LRESULT(Ord(GetInterfaceEntry(IJvDenySubClassing) <> nil));\r\n CM_DIALOGCHAR:\r\n with TCMDialogChar{$IFDEF CLR}.Create{$ENDIF}(Msg) do\r\n Result := LRESULT(Ord(WantKey(CharCode, KeyDataToShiftState(KeyData))));\r\n CM_HINTSHOW:\r\n with TCMHintShow(Msg) do\r\n Result := LRESULT(HintShow(HintInfo^));\r\n CM_HITTEST:\r\n with TCMHitTest(Msg) do\r\n Result := LRESULT(HitTest(XPos, YPos));\r\n CM_MOUSEENTER:\r\n MouseEnter(TControl(Msg.LParam));\r\n CM_MOUSELEAVE:\r\n MouseLeave(TControl(Msg.LParam));\r\n CM_VISIBLECHANGED:\r\n VisibleChanged;\r\n CM_ENABLEDCHANGED:\r\n EnabledChanged;\r\n CM_TEXTCHANGED:\r\n TextChanged;\r\n CM_FONTCHANGED:\r\n FontChanged;\r\n CM_COLORCHANGED:\r\n ColorChanged;\r\n CM_FOCUSCHANGED:\r\n FocusChanged(TWinControl(Msg.LParam));\r\n CM_PARENTFONTCHANGED:\r\n ParentFontChanged;\r\n CM_PARENTCOLORCHANGED:\r\n ParentColorChanged;\r\n CM_PARENTSHOWHINTCHANGED:\r\n ParentShowHintChanged;\r\n CM_CURSORCHANGED:\r\n CursorChanged;\r\n CM_SHOWINGCHANGED:\r\n ShowingChanged;\r\n CM_SHOWHINTCHANGED:\r\n ShowHintChanged;\r\n CM_CONTROLLISTCHANGE:\r\n if Msg.LParam <> 0 then\r\n ControlsListChanging(TControl(Msg.WParam), True)\r\n else\r\n ControlsListChanged(TControl(Msg.WParam), False);\r\n CM_CONTROLCHANGE:\r\n if Msg.LParam = 0 then\r\n ControlsListChanging(TControl(Msg.WParam), False)\r\n else\r\n ControlsListChanged(TControl(Msg.WParam), True);\r\n WM_SETFOCUS:\r\n FocusSet(THandle(Msg.WParam));\r\n WM_KILLFOCUS:\r\n FocusKilled(THandle(Msg.WParam));\r\n WM_SIZE, WM_MOVE:\r\n begin\r\n inherited WndProc(Msg);\r\n BoundsChanged;\r\n end;\r\n WM_ERASEBKGND:\r\n if (Msg.WParam <> 0) and not IsDefaultEraseBackground(DoEraseBackground, @TJvExButton.DoEraseBackground) then\r\n begin\r\n IdSaveDC := SaveDC(HDC(Msg.WParam)); // protect DC against Stock-Objects from Canvas\r\n Canvas := TCanvas.Create;\r\n try\r\n Canvas.Handle := HDC(Msg.WParam);\r\n Msg.Result := Ord(DoEraseBackground(Canvas, Msg.LParam));\r\n finally\r\n Canvas.Handle := 0;\r\n Canvas.Free;\r\n RestoreDC(HDC(Msg.WParam), IdSaveDC);\r\n end;\r\n end\r\n else\r\n inherited WndProc(Msg);\r\n {$IFNDEF DELPHI2007_UP}\r\n WM_PRINTCLIENT, WM_PRINT: // VCL bug fix\r\n begin\r\n IdSaveDC := SaveDC(HDC(Msg.WParam)); // protect DC against changes\r\n try\r\n inherited WndProc(Msg);\r\n finally\r\n RestoreDC(HDC(Msg.WParam), IdSaveDC);\r\n end;\r\n end;\r\n {$ENDIF ~DELPHI2007_UP}\r\n WM_GETDLGCODE:\r\n begin\r\n inherited WndProc(Msg);\r\n DlgCodes := [dcNative] + DlgcToDlgCodes(Msg.Result);\r\n GetDlgCode(DlgCodes);\r\n if not (dcNative in DlgCodes) then\r\n Msg.Result := DlgCodesToDlgc(DlgCodes);\r\n end;\r\n else\r\n inherited WndProc(Msg);\r\n end;\r\n case Msg.Msg of // precheck message to prevent access violations on released controls\r\n CM_MOUSEENTER, CM_MOUSELEAVE, WM_KILLFOCUS, WM_SETFOCUS, WM_NCPAINT:\r\n if DotNetHighlighting then\r\n HandleDotNetHighlighting(Self, Msg, MouseOver, Color);\r\n end;\r\n end;\r\nend;\r\n\r\n//============================================================================\r\n\r\nconstructor TJvExCustomCheckBox.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FHintColor := clDefault;\r\nend;\r\n\r\nfunction TJvExCustomCheckBox.BaseWndProc(Msg: Cardinal; WParam: WPARAM = 0; LParam: LPARAM = 0): LRESULT;\r\nvar\r\n Mesg: TMessage;\r\nbegin\r\n CreateWMMessage(Mesg, Msg, WParam, LParam);\r\n inherited WndProc(Mesg);\r\n Result := Mesg.Result;\r\nend;\r\n\r\nfunction TJvExCustomCheckBox.BaseWndProc(Msg: Cardinal; WParam: WPARAM; LParam: TObject): LRESULT;\r\nbegin\r\n Result := BaseWndProc(Msg, WParam, Windows.LPARAM(LParam));\r\nend;\r\n\r\nfunction TJvExCustomCheckBox.BaseWndProcEx(Msg: Cardinal; WParam: WPARAM; var StructLParam): LRESULT;\r\nbegin\r\n Result := BaseWndProc(Msg, WParam, Windows.LPARAM(@StructLParam));\r\nend;\r\n\r\nprocedure TJvExCustomCheckBox.VisibleChanged;\r\nbegin\r\n BaseWndProc(CM_VISIBLECHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomCheckBox.EnabledChanged;\r\nbegin\r\n BaseWndProc(CM_ENABLEDCHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomCheckBox.TextChanged;\r\nbegin\r\n BaseWndProc(CM_TEXTCHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomCheckBox.FontChanged;\r\nbegin\r\n BaseWndProc(CM_FONTCHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomCheckBox.ColorChanged;\r\nbegin\r\n BaseWndProc(CM_COLORCHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomCheckBox.ParentFontChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTFONTCHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomCheckBox.ParentColorChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTCOLORCHANGED);\r\n if Assigned(OnParentColorChange) then\r\n OnParentColorChange(Self);\r\nend;\r\n\r\nprocedure TJvExCustomCheckBox.ParentShowHintChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTSHOWHINTCHANGED);\r\nend;\r\n\r\nfunction TJvExCustomCheckBox.WantKey(Key: Integer; Shift: TShiftState): Boolean;\r\nbegin\r\n Result := BaseWndProc(CM_DIALOGCHAR, Word(Key), ShiftStateToKeyData(Shift)) <> 0;\r\nend;\r\n\r\nfunction TJvExCustomCheckBox.HitTest(X, Y: Integer): Boolean;\r\nbegin\r\n Result := BaseWndProc(CM_HITTEST, 0, SmallPointToLong(PointToSmallPoint(Point(X, Y)))) <> 0;\r\nend;\r\n\r\nfunction TJvExCustomCheckBox.HintShow(var HintInfo: THintInfo): Boolean;\r\nbegin\r\n GetHintColor(HintInfo, Self, FHintColor);\r\n if FHintWindowClass <> nil then\r\n HintInfo.HintWindowClass := FHintWindowClass;\r\n Result := BaseWndProcEx(CM_HINTSHOW, 0, HintInfo) <> 0;\r\nend;\r\n\r\nprocedure TJvExCustomCheckBox.MouseEnter(AControl: TControl);\r\nbegin\r\n FMouseOver := True;\r\n if Assigned(FOnMouseEnter) then\r\n FOnMouseEnter(Self);\r\n BaseWndProc(CM_MOUSEENTER, 0, AControl);\r\nend;\r\n\r\nprocedure TJvExCustomCheckBox.MouseLeave(AControl: TControl);\r\nbegin\r\n FMouseOver := False;\r\n BaseWndProc(CM_MOUSELEAVE, 0, AControl);\r\n if Assigned(FOnMouseLeave) then\r\n FOnMouseLeave(Self);\r\nend;\r\n\r\nprocedure TJvExCustomCheckBox.FocusChanged(AControl: TWinControl);\r\nbegin\r\n BaseWndProc(CM_FOCUSCHANGED, 0, AControl);\r\nend;\r\n\r\nprocedure TJvExCustomCheckBox.BoundsChanged;\r\nbegin\r\nend;\r\n\r\nprocedure TJvExCustomCheckBox.CursorChanged;\r\nbegin\r\n BaseWndProc(CM_CURSORCHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomCheckBox.ShowingChanged;\r\nbegin\r\n BaseWndProc(CM_SHOWINGCHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomCheckBox.ShowHintChanged;\r\nbegin\r\n BaseWndProc(CM_SHOWHINTCHANGED);\r\nend;\r\n\r\n{ VCL sends CM_CONTROLLISTCHANGE and CM_CONTROLCHANGE in a different order than\r\n the CLX methods are used. So we must correct it by evaluating \"Inserting\". }\r\nprocedure TJvExCustomCheckBox.ControlsListChanging(Control: TControl; Inserting: Boolean);\r\nbegin\r\n if Inserting then\r\n BaseWndProc(CM_CONTROLLISTCHANGE, WPARAM(Control), LPARAM(Inserting))\r\n else\r\n BaseWndProc(CM_CONTROLCHANGE, WPARAM(Control), LPARAM(Inserting));\r\nend;\r\n\r\nprocedure TJvExCustomCheckBox.ControlsListChanged(Control: TControl; Inserting: Boolean);\r\nbegin\r\n if not Inserting then\r\n BaseWndProc(CM_CONTROLLISTCHANGE, WPARAM(Control), LPARAM(Inserting))\r\n else\r\n BaseWndProc(CM_CONTROLCHANGE, WPARAM(Control), LPARAM(Inserting));\r\nend;\r\n\r\nprocedure TJvExCustomCheckBox.GetDlgCode(var Code: TDlgCodes);\r\nbegin\r\nend;\r\n\r\nprocedure TJvExCustomCheckBox.FocusSet(PrevWnd: THandle);\r\nbegin\r\n BaseWndProc(WM_SETFOCUS, WPARAM(PrevWnd), 0);\r\nend;\r\n\r\nprocedure TJvExCustomCheckBox.FocusKilled(NextWnd: THandle);\r\nbegin\r\n BaseWndProc(WM_KILLFOCUS, WPARAM(NextWnd), 0);\r\nend;\r\n\r\nfunction TJvExCustomCheckBox.DoEraseBackground(Canvas: TCanvas; Param: LPARAM): Boolean;\r\nbegin\r\n Result := BaseWndProc(WM_ERASEBKGND, Canvas.Handle, Param) <> 0;\r\nend;\r\n\r\n{$IFDEF JVCLThemesEnabledD6}\r\nfunction TJvExCustomCheckBox.GetParentBackground: Boolean;\r\nbegin\r\n Result := JvThemes.GetParentBackground(Self);\r\nend;\r\n\r\nprocedure TJvExCustomCheckBox.SetParentBackground(Value: Boolean);\r\nbegin\r\n JvThemes.SetParentBackground(Self, Value);\r\nend;\r\n{$ENDIF JVCLThemesEnabledD6}\r\n\r\nprocedure TJvExCustomCheckBox.WndProc(var Msg: TMessage);\r\nvar\r\n IdSaveDC: Integer;\r\n DlgCodes: TDlgCodes;\r\n Canvas: TCanvas;\r\nbegin\r\n if not DispatchIsDesignMsg(Self, Msg) then\r\n begin\r\n case Msg.Msg of\r\n CM_DENYSUBCLASSING:\r\n Msg.Result := LRESULT(Ord(GetInterfaceEntry(IJvDenySubClassing) <> nil));\r\n CM_DIALOGCHAR:\r\n with TCMDialogChar{$IFDEF CLR}.Create{$ENDIF}(Msg) do\r\n Result := LRESULT(Ord(WantKey(CharCode, KeyDataToShiftState(KeyData))));\r\n CM_HINTSHOW:\r\n with TCMHintShow(Msg) do\r\n Result := LRESULT(HintShow(HintInfo^));\r\n CM_HITTEST:\r\n with TCMHitTest(Msg) do\r\n Result := LRESULT(HitTest(XPos, YPos));\r\n CM_MOUSEENTER:\r\n MouseEnter(TControl(Msg.LParam));\r\n CM_MOUSELEAVE:\r\n MouseLeave(TControl(Msg.LParam));\r\n CM_VISIBLECHANGED:\r\n VisibleChanged;\r\n CM_ENABLEDCHANGED:\r\n EnabledChanged;\r\n CM_TEXTCHANGED:\r\n TextChanged;\r\n CM_FONTCHANGED:\r\n FontChanged;\r\n CM_COLORCHANGED:\r\n ColorChanged;\r\n CM_FOCUSCHANGED:\r\n FocusChanged(TWinControl(Msg.LParam));\r\n CM_PARENTFONTCHANGED:\r\n ParentFontChanged;\r\n CM_PARENTCOLORCHANGED:\r\n ParentColorChanged;\r\n CM_PARENTSHOWHINTCHANGED:\r\n ParentShowHintChanged;\r\n CM_CURSORCHANGED:\r\n CursorChanged;\r\n CM_SHOWINGCHANGED:\r\n ShowingChanged;\r\n CM_SHOWHINTCHANGED:\r\n ShowHintChanged;\r\n CM_CONTROLLISTCHANGE:\r\n if Msg.LParam <> 0 then\r\n ControlsListChanging(TControl(Msg.WParam), True)\r\n else\r\n ControlsListChanged(TControl(Msg.WParam), False);\r\n CM_CONTROLCHANGE:\r\n if Msg.LParam = 0 then\r\n ControlsListChanging(TControl(Msg.WParam), False)\r\n else\r\n ControlsListChanged(TControl(Msg.WParam), True);\r\n WM_SETFOCUS:\r\n FocusSet(THandle(Msg.WParam));\r\n WM_KILLFOCUS:\r\n FocusKilled(THandle(Msg.WParam));\r\n WM_SIZE, WM_MOVE:\r\n begin\r\n inherited WndProc(Msg);\r\n BoundsChanged;\r\n end;\r\n WM_ERASEBKGND:\r\n if (Msg.WParam <> 0) and not IsDefaultEraseBackground(DoEraseBackground, @TJvExCustomCheckBox.DoEraseBackground) then\r\n begin\r\n IdSaveDC := SaveDC(HDC(Msg.WParam)); // protect DC against Stock-Objects from Canvas\r\n Canvas := TCanvas.Create;\r\n try\r\n Canvas.Handle := HDC(Msg.WParam);\r\n Msg.Result := Ord(DoEraseBackground(Canvas, Msg.LParam));\r\n finally\r\n Canvas.Handle := 0;\r\n Canvas.Free;\r\n RestoreDC(HDC(Msg.WParam), IdSaveDC);\r\n end;\r\n end\r\n else\r\n inherited WndProc(Msg);\r\n {$IFNDEF DELPHI2007_UP}\r\n WM_PRINTCLIENT, WM_PRINT: // VCL bug fix\r\n begin\r\n IdSaveDC := SaveDC(HDC(Msg.WParam)); // protect DC against changes\r\n try\r\n inherited WndProc(Msg);\r\n finally\r\n RestoreDC(HDC(Msg.WParam), IdSaveDC);\r\n end;\r\n end;\r\n {$ENDIF ~DELPHI2007_UP}\r\n WM_GETDLGCODE:\r\n begin\r\n inherited WndProc(Msg);\r\n DlgCodes := [dcNative] + DlgcToDlgCodes(Msg.Result);\r\n GetDlgCode(DlgCodes);\r\n if not (dcNative in DlgCodes) then\r\n Msg.Result := DlgCodesToDlgc(DlgCodes);\r\n end;\r\n else\r\n inherited WndProc(Msg);\r\n end;\r\n case Msg.Msg of // precheck message to prevent access violations on released controls\r\n CM_MOUSEENTER, CM_MOUSELEAVE, WM_KILLFOCUS, WM_SETFOCUS, WM_NCPAINT:\r\n if DotNetHighlighting then\r\n HandleDotNetHighlighting(Self, Msg, MouseOver, Color);\r\n end;\r\n end;\r\nend;\r\n\r\n//============================================================================\r\n\r\nconstructor TJvExRadioButton.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FHintColor := clDefault;\r\nend;\r\n\r\nfunction TJvExRadioButton.BaseWndProc(Msg: Cardinal; WParam: WPARAM = 0; LParam: LPARAM = 0): LRESULT;\r\nvar\r\n Mesg: TMessage;\r\nbegin\r\n CreateWMMessage(Mesg, Msg, WParam, LParam);\r\n inherited WndProc(Mesg);\r\n Result := Mesg.Result;\r\nend;\r\n\r\nfunction TJvExRadioButton.BaseWndProc(Msg: Cardinal; WParam: WPARAM; LParam: TObject): LRESULT;\r\nbegin\r\n Result := BaseWndProc(Msg, WParam, Windows.LPARAM(LParam));\r\nend;\r\n\r\nfunction TJvExRadioButton.BaseWndProcEx(Msg: Cardinal; WParam: WPARAM; var StructLParam): LRESULT;\r\nbegin\r\n Result := BaseWndProc(Msg, WParam, Windows.LPARAM(@StructLParam));\r\nend;\r\n\r\nprocedure TJvExRadioButton.VisibleChanged;\r\nbegin\r\n BaseWndProc(CM_VISIBLECHANGED);\r\nend;\r\n\r\nprocedure TJvExRadioButton.EnabledChanged;\r\nbegin\r\n BaseWndProc(CM_ENABLEDCHANGED);\r\nend;\r\n\r\nprocedure TJvExRadioButton.TextChanged;\r\nbegin\r\n BaseWndProc(CM_TEXTCHANGED);\r\nend;\r\n\r\nprocedure TJvExRadioButton.FontChanged;\r\nbegin\r\n BaseWndProc(CM_FONTCHANGED);\r\nend;\r\n\r\nprocedure TJvExRadioButton.ColorChanged;\r\nbegin\r\n BaseWndProc(CM_COLORCHANGED);\r\nend;\r\n\r\nprocedure TJvExRadioButton.ParentFontChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTFONTCHANGED);\r\nend;\r\n\r\nprocedure TJvExRadioButton.ParentColorChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTCOLORCHANGED);\r\n if Assigned(OnParentColorChange) then\r\n OnParentColorChange(Self);\r\nend;\r\n\r\nprocedure TJvExRadioButton.ParentShowHintChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTSHOWHINTCHANGED);\r\nend;\r\n\r\nfunction TJvExRadioButton.WantKey(Key: Integer; Shift: TShiftState): Boolean;\r\nbegin\r\n Result := BaseWndProc(CM_DIALOGCHAR, Word(Key), ShiftStateToKeyData(Shift)) <> 0;\r\nend;\r\n\r\nfunction TJvExRadioButton.HitTest(X, Y: Integer): Boolean;\r\nbegin\r\n Result := BaseWndProc(CM_HITTEST, 0, SmallPointToLong(PointToSmallPoint(Point(X, Y)))) <> 0;\r\nend;\r\n\r\nfunction TJvExRadioButton.HintShow(var HintInfo: THintInfo): Boolean;\r\nbegin\r\n GetHintColor(HintInfo, Self, FHintColor);\r\n if FHintWindowClass <> nil then\r\n HintInfo.HintWindowClass := FHintWindowClass;\r\n Result := BaseWndProcEx(CM_HINTSHOW, 0, HintInfo) <> 0;\r\nend;\r\n\r\nprocedure TJvExRadioButton.MouseEnter(AControl: TControl);\r\nbegin\r\n FMouseOver := True;\r\n if Assigned(FOnMouseEnter) then\r\n FOnMouseEnter(Self);\r\n BaseWndProc(CM_MOUSEENTER, 0, AControl);\r\nend;\r\n\r\nprocedure TJvExRadioButton.MouseLeave(AControl: TControl);\r\nbegin\r\n FMouseOver := False;\r\n BaseWndProc(CM_MOUSELEAVE, 0, AControl);\r\n if Assigned(FOnMouseLeave) then\r\n FOnMouseLeave(Self);\r\nend;\r\n\r\nprocedure TJvExRadioButton.FocusChanged(AControl: TWinControl);\r\nbegin\r\n BaseWndProc(CM_FOCUSCHANGED, 0, AControl);\r\nend;\r\n\r\nprocedure TJvExRadioButton.BoundsChanged;\r\nbegin\r\nend;\r\n\r\nprocedure TJvExRadioButton.CursorChanged;\r\nbegin\r\n BaseWndProc(CM_CURSORCHANGED);\r\nend;\r\n\r\nprocedure TJvExRadioButton.ShowingChanged;\r\nbegin\r\n BaseWndProc(CM_SHOWINGCHANGED);\r\nend;\r\n\r\nprocedure TJvExRadioButton.ShowHintChanged;\r\nbegin\r\n BaseWndProc(CM_SHOWHINTCHANGED);\r\nend;\r\n\r\n{ VCL sends CM_CONTROLLISTCHANGE and CM_CONTROLCHANGE in a different order than\r\n the CLX methods are used. So we must correct it by evaluating \"Inserting\". }\r\nprocedure TJvExRadioButton.ControlsListChanging(Control: TControl; Inserting: Boolean);\r\nbegin\r\n if Inserting then\r\n BaseWndProc(CM_CONTROLLISTCHANGE, WPARAM(Control), LPARAM(Inserting))\r\n else\r\n BaseWndProc(CM_CONTROLCHANGE, WPARAM(Control), LPARAM(Inserting));\r\nend;\r\n\r\nprocedure TJvExRadioButton.ControlsListChanged(Control: TControl; Inserting: Boolean);\r\nbegin\r\n if not Inserting then\r\n BaseWndProc(CM_CONTROLLISTCHANGE, WPARAM(Control), LPARAM(Inserting))\r\n else\r\n BaseWndProc(CM_CONTROLCHANGE, WPARAM(Control), LPARAM(Inserting));\r\nend;\r\n\r\nprocedure TJvExRadioButton.GetDlgCode(var Code: TDlgCodes);\r\nbegin\r\nend;\r\n\r\nprocedure TJvExRadioButton.FocusSet(PrevWnd: THandle);\r\nbegin\r\n BaseWndProc(WM_SETFOCUS, WPARAM(PrevWnd), 0);\r\nend;\r\n\r\nprocedure TJvExRadioButton.FocusKilled(NextWnd: THandle);\r\nbegin\r\n BaseWndProc(WM_KILLFOCUS, WPARAM(NextWnd), 0);\r\nend;\r\n\r\nfunction TJvExRadioButton.DoEraseBackground(Canvas: TCanvas; Param: LPARAM): Boolean;\r\nbegin\r\n Result := BaseWndProc(WM_ERASEBKGND, Canvas.Handle, Param) <> 0;\r\nend;\r\n\r\n{$IFDEF JVCLThemesEnabledD6}\r\nfunction TJvExRadioButton.GetParentBackground: Boolean;\r\nbegin\r\n Result := JvThemes.GetParentBackground(Self);\r\nend;\r\n\r\nprocedure TJvExRadioButton.SetParentBackground(Value: Boolean);\r\nbegin\r\n JvThemes.SetParentBackground(Self, Value);\r\nend;\r\n{$ENDIF JVCLThemesEnabledD6}\r\n\r\nprocedure TJvExRadioButton.WndProc(var Msg: TMessage);\r\nvar\r\n IdSaveDC: Integer;\r\n DlgCodes: TDlgCodes;\r\n Canvas: TCanvas;\r\nbegin\r\n if not DispatchIsDesignMsg(Self, Msg) then\r\n begin\r\n case Msg.Msg of\r\n CM_DENYSUBCLASSING:\r\n Msg.Result := LRESULT(Ord(GetInterfaceEntry(IJvDenySubClassing) <> nil));\r\n CM_DIALOGCHAR:\r\n with TCMDialogChar{$IFDEF CLR}.Create{$ENDIF}(Msg) do\r\n Result := LRESULT(Ord(WantKey(CharCode, KeyDataToShiftState(KeyData))));\r\n CM_HINTSHOW:\r\n with TCMHintShow(Msg) do\r\n Result := LRESULT(HintShow(HintInfo^));\r\n CM_HITTEST:\r\n with TCMHitTest(Msg) do\r\n Result := LRESULT(HitTest(XPos, YPos));\r\n CM_MOUSEENTER:\r\n MouseEnter(TControl(Msg.LParam));\r\n CM_MOUSELEAVE:\r\n MouseLeave(TControl(Msg.LParam));\r\n CM_VISIBLECHANGED:\r\n VisibleChanged;\r\n CM_ENABLEDCHANGED:\r\n EnabledChanged;\r\n CM_TEXTCHANGED:\r\n TextChanged;\r\n CM_FONTCHANGED:\r\n FontChanged;\r\n CM_COLORCHANGED:\r\n ColorChanged;\r\n CM_FOCUSCHANGED:\r\n FocusChanged(TWinControl(Msg.LParam));\r\n CM_PARENTFONTCHANGED:\r\n ParentFontChanged;\r\n CM_PARENTCOLORCHANGED:\r\n ParentColorChanged;\r\n CM_PARENTSHOWHINTCHANGED:\r\n ParentShowHintChanged;\r\n CM_CURSORCHANGED:\r\n CursorChanged;\r\n CM_SHOWINGCHANGED:\r\n ShowingChanged;\r\n CM_SHOWHINTCHANGED:\r\n ShowHintChanged;\r\n CM_CONTROLLISTCHANGE:\r\n if Msg.LParam <> 0 then\r\n ControlsListChanging(TControl(Msg.WParam), True)\r\n else\r\n ControlsListChanged(TControl(Msg.WParam), False);\r\n CM_CONTROLCHANGE:\r\n if Msg.LParam = 0 then\r\n ControlsListChanging(TControl(Msg.WParam), False)\r\n else\r\n ControlsListChanged(TControl(Msg.WParam), True);\r\n WM_SETFOCUS:\r\n FocusSet(THandle(Msg.WParam));\r\n WM_KILLFOCUS:\r\n FocusKilled(THandle(Msg.WParam));\r\n WM_SIZE, WM_MOVE:\r\n begin\r\n inherited WndProc(Msg);\r\n BoundsChanged;\r\n end;\r\n WM_ERASEBKGND:\r\n if (Msg.WParam <> 0) and not IsDefaultEraseBackground(DoEraseBackground, @TJvExRadioButton.DoEraseBackground) then\r\n begin\r\n IdSaveDC := SaveDC(HDC(Msg.WParam)); // protect DC against Stock-Objects from Canvas\r\n Canvas := TCanvas.Create;\r\n try\r\n Canvas.Handle := HDC(Msg.WParam);\r\n Msg.Result := Ord(DoEraseBackground(Canvas, Msg.LParam));\r\n finally\r\n Canvas.Handle := 0;\r\n Canvas.Free;\r\n RestoreDC(HDC(Msg.WParam), IdSaveDC);\r\n end;\r\n end\r\n else\r\n inherited WndProc(Msg);\r\n {$IFNDEF DELPHI2007_UP}\r\n WM_PRINTCLIENT, WM_PRINT: // VCL bug fix\r\n begin\r\n IdSaveDC := SaveDC(HDC(Msg.WParam)); // protect DC against changes\r\n try\r\n inherited WndProc(Msg);\r\n finally\r\n RestoreDC(HDC(Msg.WParam), IdSaveDC);\r\n end;\r\n end;\r\n {$ENDIF ~DELPHI2007_UP}\r\n WM_GETDLGCODE:\r\n begin\r\n inherited WndProc(Msg);\r\n DlgCodes := [dcNative] + DlgcToDlgCodes(Msg.Result);\r\n GetDlgCode(DlgCodes);\r\n if not (dcNative in DlgCodes) then\r\n Msg.Result := DlgCodesToDlgc(DlgCodes);\r\n end;\r\n else\r\n inherited WndProc(Msg);\r\n end;\r\n case Msg.Msg of // precheck message to prevent access violations on released controls\r\n CM_MOUSEENTER, CM_MOUSELEAVE, WM_KILLFOCUS, WM_SETFOCUS, WM_NCPAINT:\r\n if DotNetHighlighting then\r\n HandleDotNetHighlighting(Self, Msg, MouseOver, Color);\r\n end;\r\n end;\r\nend;\r\n\r\n//============================================================================\r\n\r\nconstructor TJvExCustomListBox.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FHintColor := clDefault;\r\nend;\r\n\r\nfunction TJvExCustomListBox.BaseWndProc(Msg: Cardinal; WParam: WPARAM = 0; LParam: LPARAM = 0): LRESULT;\r\nvar\r\n Mesg: TMessage;\r\nbegin\r\n CreateWMMessage(Mesg, Msg, WParam, LParam);\r\n inherited WndProc(Mesg);\r\n Result := Mesg.Result;\r\nend;\r\n\r\nfunction TJvExCustomListBox.BaseWndProc(Msg: Cardinal; WParam: WPARAM; LParam: TObject): LRESULT;\r\nbegin\r\n Result := BaseWndProc(Msg, WParam, Windows.LPARAM(LParam));\r\nend;\r\n\r\nfunction TJvExCustomListBox.BaseWndProcEx(Msg: Cardinal; WParam: WPARAM; var StructLParam): LRESULT;\r\nbegin\r\n Result := BaseWndProc(Msg, WParam, Windows.LPARAM(@StructLParam));\r\nend;\r\n\r\nprocedure TJvExCustomListBox.VisibleChanged;\r\nbegin\r\n BaseWndProc(CM_VISIBLECHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomListBox.EnabledChanged;\r\nbegin\r\n BaseWndProc(CM_ENABLEDCHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomListBox.TextChanged;\r\nbegin\r\n BaseWndProc(CM_TEXTCHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomListBox.FontChanged;\r\nbegin\r\n BaseWndProc(CM_FONTCHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomListBox.ColorChanged;\r\nbegin\r\n BaseWndProc(CM_COLORCHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomListBox.ParentFontChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTFONTCHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomListBox.ParentColorChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTCOLORCHANGED);\r\n if Assigned(OnParentColorChange) then\r\n OnParentColorChange(Self);\r\nend;\r\n\r\nprocedure TJvExCustomListBox.ParentShowHintChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTSHOWHINTCHANGED);\r\nend;\r\n\r\nfunction TJvExCustomListBox.WantKey(Key: Integer; Shift: TShiftState): Boolean;\r\nbegin\r\n Result := BaseWndProc(CM_DIALOGCHAR, Word(Key), ShiftStateToKeyData(Shift)) <> 0;\r\nend;\r\n\r\nfunction TJvExCustomListBox.HitTest(X, Y: Integer): Boolean;\r\nbegin\r\n Result := BaseWndProc(CM_HITTEST, 0, SmallPointToLong(PointToSmallPoint(Point(X, Y)))) <> 0;\r\nend;\r\n\r\nfunction TJvExCustomListBox.HintShow(var HintInfo: THintInfo): Boolean;\r\nbegin\r\n GetHintColor(HintInfo, Self, FHintColor);\r\n if FHintWindowClass <> nil then\r\n HintInfo.HintWindowClass := FHintWindowClass;\r\n Result := BaseWndProcEx(CM_HINTSHOW, 0, HintInfo) <> 0;\r\nend;\r\n\r\nprocedure TJvExCustomListBox.MouseEnter(AControl: TControl);\r\nbegin\r\n FMouseOver := True;\r\n if Assigned(FOnMouseEnter) then\r\n FOnMouseEnter(Self);\r\n BaseWndProc(CM_MOUSEENTER, 0, AControl);\r\nend;\r\n\r\nprocedure TJvExCustomListBox.MouseLeave(AControl: TControl);\r\nbegin\r\n FMouseOver := False;\r\n BaseWndProc(CM_MOUSELEAVE, 0, AControl);\r\n if Assigned(FOnMouseLeave) then\r\n FOnMouseLeave(Self);\r\nend;\r\n\r\nprocedure TJvExCustomListBox.FocusChanged(AControl: TWinControl);\r\nbegin\r\n BaseWndProc(CM_FOCUSCHANGED, 0, AControl);\r\nend;\r\n\r\nprocedure TJvExCustomListBox.BoundsChanged;\r\nbegin\r\nend;\r\n\r\nprocedure TJvExCustomListBox.CursorChanged;\r\nbegin\r\n BaseWndProc(CM_CURSORCHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomListBox.ShowingChanged;\r\nbegin\r\n BaseWndProc(CM_SHOWINGCHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomListBox.ShowHintChanged;\r\nbegin\r\n BaseWndProc(CM_SHOWHINTCHANGED);\r\nend;\r\n\r\n{ VCL sends CM_CONTROLLISTCHANGE and CM_CONTROLCHANGE in a different order than\r\n the CLX methods are used. So we must correct it by evaluating \"Inserting\". }\r\nprocedure TJvExCustomListBox.ControlsListChanging(Control: TControl; Inserting: Boolean);\r\nbegin\r\n if Inserting then\r\n BaseWndProc(CM_CONTROLLISTCHANGE, WPARAM(Control), LPARAM(Inserting))\r\n else\r\n BaseWndProc(CM_CONTROLCHANGE, WPARAM(Control), LPARAM(Inserting));\r\nend;\r\n\r\nprocedure TJvExCustomListBox.ControlsListChanged(Control: TControl; Inserting: Boolean);\r\nbegin\r\n if not Inserting then\r\n BaseWndProc(CM_CONTROLLISTCHANGE, WPARAM(Control), LPARAM(Inserting))\r\n else\r\n BaseWndProc(CM_CONTROLCHANGE, WPARAM(Control), LPARAM(Inserting));\r\nend;\r\n\r\nprocedure TJvExCustomListBox.GetDlgCode(var Code: TDlgCodes);\r\nbegin\r\nend;\r\n\r\nprocedure TJvExCustomListBox.FocusSet(PrevWnd: THandle);\r\nbegin\r\n BaseWndProc(WM_SETFOCUS, WPARAM(PrevWnd), 0);\r\nend;\r\n\r\nprocedure TJvExCustomListBox.FocusKilled(NextWnd: THandle);\r\nbegin\r\n BaseWndProc(WM_KILLFOCUS, WPARAM(NextWnd), 0);\r\nend;\r\n\r\nfunction TJvExCustomListBox.DoEraseBackground(Canvas: TCanvas; Param: LPARAM): Boolean;\r\nbegin\r\n Result := BaseWndProc(WM_ERASEBKGND, Canvas.Handle, Param) <> 0;\r\nend;\r\n\r\n{$IFDEF JVCLThemesEnabledD6}\r\nfunction TJvExCustomListBox.GetParentBackground: Boolean;\r\nbegin\r\n Result := JvThemes.GetParentBackground(Self);\r\nend;\r\n\r\nprocedure TJvExCustomListBox.SetParentBackground(Value: Boolean);\r\nbegin\r\n JvThemes.SetParentBackground(Self, Value);\r\nend;\r\n{$ENDIF JVCLThemesEnabledD6}\r\n\r\nprocedure TJvExCustomListBox.WndProc(var Msg: TMessage);\r\nvar\r\n IdSaveDC: Integer;\r\n DlgCodes: TDlgCodes;\r\n Canvas: TCanvas;\r\nbegin\r\n if not DispatchIsDesignMsg(Self, Msg) then\r\n begin\r\n case Msg.Msg of\r\n CM_DENYSUBCLASSING:\r\n Msg.Result := LRESULT(Ord(GetInterfaceEntry(IJvDenySubClassing) <> nil));\r\n CM_DIALOGCHAR:\r\n with TCMDialogChar{$IFDEF CLR}.Create{$ENDIF}(Msg) do\r\n Result := LRESULT(Ord(WantKey(CharCode, KeyDataToShiftState(KeyData))));\r\n CM_HINTSHOW:\r\n with TCMHintShow(Msg) do\r\n Result := LRESULT(HintShow(HintInfo^));\r\n CM_HITTEST:\r\n with TCMHitTest(Msg) do\r\n Result := LRESULT(HitTest(XPos, YPos));\r\n CM_MOUSEENTER:\r\n MouseEnter(TControl(Msg.LParam));\r\n CM_MOUSELEAVE:\r\n MouseLeave(TControl(Msg.LParam));\r\n CM_VISIBLECHANGED:\r\n VisibleChanged;\r\n CM_ENABLEDCHANGED:\r\n EnabledChanged;\r\n CM_TEXTCHANGED:\r\n TextChanged;\r\n CM_FONTCHANGED:\r\n FontChanged;\r\n CM_COLORCHANGED:\r\n ColorChanged;\r\n CM_FOCUSCHANGED:\r\n FocusChanged(TWinControl(Msg.LParam));\r\n CM_PARENTFONTCHANGED:\r\n ParentFontChanged;\r\n CM_PARENTCOLORCHANGED:\r\n ParentColorChanged;\r\n CM_PARENTSHOWHINTCHANGED:\r\n ParentShowHintChanged;\r\n CM_CURSORCHANGED:\r\n CursorChanged;\r\n CM_SHOWINGCHANGED:\r\n ShowingChanged;\r\n CM_SHOWHINTCHANGED:\r\n ShowHintChanged;\r\n CM_CONTROLLISTCHANGE:\r\n if Msg.LParam <> 0 then\r\n ControlsListChanging(TControl(Msg.WParam), True)\r\n else\r\n ControlsListChanged(TControl(Msg.WParam), False);\r\n CM_CONTROLCHANGE:\r\n if Msg.LParam = 0 then\r\n ControlsListChanging(TControl(Msg.WParam), False)\r\n else\r\n ControlsListChanged(TControl(Msg.WParam), True);\r\n WM_SETFOCUS:\r\n FocusSet(THandle(Msg.WParam));\r\n WM_KILLFOCUS:\r\n FocusKilled(THandle(Msg.WParam));\r\n WM_SIZE, WM_MOVE:\r\n begin\r\n inherited WndProc(Msg);\r\n BoundsChanged;\r\n end;\r\n WM_ERASEBKGND:\r\n if (Msg.WParam <> 0) and not IsDefaultEraseBackground(DoEraseBackground, @TJvExCustomListBox.DoEraseBackground) then\r\n begin\r\n IdSaveDC := SaveDC(HDC(Msg.WParam)); // protect DC against Stock-Objects from Canvas\r\n Canvas := TCanvas.Create;\r\n try\r\n Canvas.Handle := HDC(Msg.WParam);\r\n Msg.Result := Ord(DoEraseBackground(Canvas, Msg.LParam));\r\n finally\r\n Canvas.Handle := 0;\r\n Canvas.Free;\r\n RestoreDC(HDC(Msg.WParam), IdSaveDC);\r\n end;\r\n end\r\n else\r\n inherited WndProc(Msg);\r\n {$IFNDEF DELPHI2007_UP}\r\n WM_PRINTCLIENT, WM_PRINT: // VCL bug fix\r\n begin\r\n IdSaveDC := SaveDC(HDC(Msg.WParam)); // protect DC against changes\r\n try\r\n inherited WndProc(Msg);\r\n finally\r\n RestoreDC(HDC(Msg.WParam), IdSaveDC);\r\n end;\r\n end;\r\n {$ENDIF ~DELPHI2007_UP}\r\n WM_GETDLGCODE:\r\n begin\r\n inherited WndProc(Msg);\r\n DlgCodes := [dcNative] + DlgcToDlgCodes(Msg.Result);\r\n GetDlgCode(DlgCodes);\r\n if not (dcNative in DlgCodes) then\r\n Msg.Result := DlgCodesToDlgc(DlgCodes);\r\n end;\r\n else\r\n inherited WndProc(Msg);\r\n end;\r\n case Msg.Msg of // precheck message to prevent access violations on released controls\r\n CM_MOUSEENTER, CM_MOUSELEAVE, WM_KILLFOCUS, WM_SETFOCUS, WM_NCPAINT:\r\n if DotNetHighlighting then\r\n HandleDotNetHighlighting(Self, Msg, MouseOver, Color);\r\n end;\r\n end;\r\nend;\r\n\r\n//============================================================================\r\n\r\nconstructor TJvExScrollBar.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FHintColor := clDefault;\r\nend;\r\n\r\nfunction TJvExScrollBar.BaseWndProc(Msg: Cardinal; WParam: WPARAM = 0; LParam: LPARAM = 0): LRESULT;\r\nvar\r\n Mesg: TMessage;\r\nbegin\r\n CreateWMMessage(Mesg, Msg, WParam, LParam);\r\n inherited WndProc(Mesg);\r\n Result := Mesg.Result;\r\nend;\r\n\r\nfunction TJvExScrollBar.BaseWndProc(Msg: Cardinal; WParam: WPARAM; LParam: TObject): LRESULT;\r\nbegin\r\n Result := BaseWndProc(Msg, WParam, Windows.LPARAM(LParam));\r\nend;\r\n\r\nfunction TJvExScrollBar.BaseWndProcEx(Msg: Cardinal; WParam: WPARAM; var StructLParam): LRESULT;\r\nbegin\r\n Result := BaseWndProc(Msg, WParam, Windows.LPARAM(@StructLParam));\r\nend;\r\n\r\nprocedure TJvExScrollBar.VisibleChanged;\r\nbegin\r\n BaseWndProc(CM_VISIBLECHANGED);\r\nend;\r\n\r\nprocedure TJvExScrollBar.EnabledChanged;\r\nbegin\r\n BaseWndProc(CM_ENABLEDCHANGED);\r\nend;\r\n\r\nprocedure TJvExScrollBar.TextChanged;\r\nbegin\r\n BaseWndProc(CM_TEXTCHANGED);\r\nend;\r\n\r\nprocedure TJvExScrollBar.FontChanged;\r\nbegin\r\n BaseWndProc(CM_FONTCHANGED);\r\nend;\r\n\r\nprocedure TJvExScrollBar.ColorChanged;\r\nbegin\r\n BaseWndProc(CM_COLORCHANGED);\r\nend;\r\n\r\nprocedure TJvExScrollBar.ParentFontChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTFONTCHANGED);\r\nend;\r\n\r\nprocedure TJvExScrollBar.ParentColorChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTCOLORCHANGED);\r\n if Assigned(OnParentColorChange) then\r\n OnParentColorChange(Self);\r\nend;\r\n\r\nprocedure TJvExScrollBar.ParentShowHintChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTSHOWHINTCHANGED);\r\nend;\r\n\r\nfunction TJvExScrollBar.WantKey(Key: Integer; Shift: TShiftState): Boolean;\r\nbegin\r\n Result := BaseWndProc(CM_DIALOGCHAR, Word(Key), ShiftStateToKeyData(Shift)) <> 0;\r\nend;\r\n\r\nfunction TJvExScrollBar.HitTest(X, Y: Integer): Boolean;\r\nbegin\r\n Result := BaseWndProc(CM_HITTEST, 0, SmallPointToLong(PointToSmallPoint(Point(X, Y)))) <> 0;\r\nend;\r\n\r\nfunction TJvExScrollBar.HintShow(var HintInfo: THintInfo): Boolean;\r\nbegin\r\n GetHintColor(HintInfo, Self, FHintColor);\r\n if FHintWindowClass <> nil then\r\n HintInfo.HintWindowClass := FHintWindowClass;\r\n Result := BaseWndProcEx(CM_HINTSHOW, 0, HintInfo) <> 0;\r\nend;\r\n\r\nprocedure TJvExScrollBar.MouseEnter(AControl: TControl);\r\nbegin\r\n FMouseOver := True;\r\n if Assigned(FOnMouseEnter) then\r\n FOnMouseEnter(Self);\r\n BaseWndProc(CM_MOUSEENTER, 0, AControl);\r\nend;\r\n\r\nprocedure TJvExScrollBar.MouseLeave(AControl: TControl);\r\nbegin\r\n FMouseOver := False;\r\n BaseWndProc(CM_MOUSELEAVE, 0, AControl);\r\n if Assigned(FOnMouseLeave) then\r\n FOnMouseLeave(Self);\r\nend;\r\n\r\nprocedure TJvExScrollBar.FocusChanged(AControl: TWinControl);\r\nbegin\r\n BaseWndProc(CM_FOCUSCHANGED, 0, AControl);\r\nend;\r\n\r\nprocedure TJvExScrollBar.BoundsChanged;\r\nbegin\r\nend;\r\n\r\nprocedure TJvExScrollBar.CursorChanged;\r\nbegin\r\n BaseWndProc(CM_CURSORCHANGED);\r\nend;\r\n\r\nprocedure TJvExScrollBar.ShowingChanged;\r\nbegin\r\n BaseWndProc(CM_SHOWINGCHANGED);\r\nend;\r\n\r\nprocedure TJvExScrollBar.ShowHintChanged;\r\nbegin\r\n BaseWndProc(CM_SHOWHINTCHANGED);\r\nend;\r\n\r\n{ VCL sends CM_CONTROLLISTCHANGE and CM_CONTROLCHANGE in a different order than\r\n the CLX methods are used. So we must correct it by evaluating \"Inserting\". }\r\nprocedure TJvExScrollBar.ControlsListChanging(Control: TControl; Inserting: Boolean);\r\nbegin\r\n if Inserting then\r\n BaseWndProc(CM_CONTROLLISTCHANGE, WPARAM(Control), LPARAM(Inserting))\r\n else\r\n BaseWndProc(CM_CONTROLCHANGE, WPARAM(Control), LPARAM(Inserting));\r\nend;\r\n\r\nprocedure TJvExScrollBar.ControlsListChanged(Control: TControl; Inserting: Boolean);\r\nbegin\r\n if not Inserting then\r\n BaseWndProc(CM_CONTROLLISTCHANGE, WPARAM(Control), LPARAM(Inserting))\r\n else\r\n BaseWndProc(CM_CONTROLCHANGE, WPARAM(Control), LPARAM(Inserting));\r\nend;\r\n\r\nprocedure TJvExScrollBar.GetDlgCode(var Code: TDlgCodes);\r\nbegin\r\nend;\r\n\r\nprocedure TJvExScrollBar.FocusSet(PrevWnd: THandle);\r\nbegin\r\n BaseWndProc(WM_SETFOCUS, WPARAM(PrevWnd), 0);\r\nend;\r\n\r\nprocedure TJvExScrollBar.FocusKilled(NextWnd: THandle);\r\nbegin\r\n BaseWndProc(WM_KILLFOCUS, WPARAM(NextWnd), 0);\r\nend;\r\n\r\nfunction TJvExScrollBar.DoEraseBackground(Canvas: TCanvas; Param: LPARAM): Boolean;\r\nbegin\r\n Result := BaseWndProc(WM_ERASEBKGND, Canvas.Handle, Param) <> 0;\r\nend;\r\n\r\n{$IFDEF JVCLThemesEnabledD6}\r\nfunction TJvExScrollBar.GetParentBackground: Boolean;\r\nbegin\r\n Result := JvThemes.GetParentBackground(Self);\r\nend;\r\n\r\nprocedure TJvExScrollBar.SetParentBackground(Value: Boolean);\r\nbegin\r\n JvThemes.SetParentBackground(Self, Value);\r\nend;\r\n{$ENDIF JVCLThemesEnabledD6}\r\n\r\nprocedure TJvExScrollBar.WndProc(var Msg: TMessage);\r\nvar\r\n IdSaveDC: Integer;\r\n DlgCodes: TDlgCodes;\r\n Canvas: TCanvas;\r\nbegin\r\n if not DispatchIsDesignMsg(Self, Msg) then\r\n begin\r\n case Msg.Msg of\r\n CM_DENYSUBCLASSING:\r\n Msg.Result := LRESULT(Ord(GetInterfaceEntry(IJvDenySubClassing) <> nil));\r\n CM_DIALOGCHAR:\r\n with TCMDialogChar{$IFDEF CLR}.Create{$ENDIF}(Msg) do\r\n Result := LRESULT(Ord(WantKey(CharCode, KeyDataToShiftState(KeyData))));\r\n CM_HINTSHOW:\r\n with TCMHintShow(Msg) do\r\n Result := LRESULT(HintShow(HintInfo^));\r\n CM_HITTEST:\r\n with TCMHitTest(Msg) do\r\n Result := LRESULT(HitTest(XPos, YPos));\r\n CM_MOUSEENTER:\r\n MouseEnter(TControl(Msg.LParam));\r\n CM_MOUSELEAVE:\r\n MouseLeave(TControl(Msg.LParam));\r\n CM_VISIBLECHANGED:\r\n VisibleChanged;\r\n CM_ENABLEDCHANGED:\r\n EnabledChanged;\r\n CM_TEXTCHANGED:\r\n TextChanged;\r\n CM_FONTCHANGED:\r\n FontChanged;\r\n CM_COLORCHANGED:\r\n ColorChanged;\r\n CM_FOCUSCHANGED:\r\n FocusChanged(TWinControl(Msg.LParam));\r\n CM_PARENTFONTCHANGED:\r\n ParentFontChanged;\r\n CM_PARENTCOLORCHANGED:\r\n ParentColorChanged;\r\n CM_PARENTSHOWHINTCHANGED:\r\n ParentShowHintChanged;\r\n CM_CURSORCHANGED:\r\n CursorChanged;\r\n CM_SHOWINGCHANGED:\r\n ShowingChanged;\r\n CM_SHOWHINTCHANGED:\r\n ShowHintChanged;\r\n CM_CONTROLLISTCHANGE:\r\n if Msg.LParam <> 0 then\r\n ControlsListChanging(TControl(Msg.WParam), True)\r\n else\r\n ControlsListChanged(TControl(Msg.WParam), False);\r\n CM_CONTROLCHANGE:\r\n if Msg.LParam = 0 then\r\n ControlsListChanging(TControl(Msg.WParam), False)\r\n else\r\n ControlsListChanged(TControl(Msg.WParam), True);\r\n WM_SETFOCUS:\r\n FocusSet(THandle(Msg.WParam));\r\n WM_KILLFOCUS:\r\n FocusKilled(THandle(Msg.WParam));\r\n WM_SIZE, WM_MOVE:\r\n begin\r\n inherited WndProc(Msg);\r\n BoundsChanged;\r\n end;\r\n WM_ERASEBKGND:\r\n if (Msg.WParam <> 0) and not IsDefaultEraseBackground(DoEraseBackground, @TJvExScrollBar.DoEraseBackground) then\r\n begin\r\n IdSaveDC := SaveDC(HDC(Msg.WParam)); // protect DC against Stock-Objects from Canvas\r\n Canvas := TCanvas.Create;\r\n try\r\n Canvas.Handle := HDC(Msg.WParam);\r\n Msg.Result := Ord(DoEraseBackground(Canvas, Msg.LParam));\r\n finally\r\n Canvas.Handle := 0;\r\n Canvas.Free;\r\n RestoreDC(HDC(Msg.WParam), IdSaveDC);\r\n end;\r\n end\r\n else\r\n inherited WndProc(Msg);\r\n {$IFNDEF DELPHI2007_UP}\r\n WM_PRINTCLIENT, WM_PRINT: // VCL bug fix\r\n begin\r\n IdSaveDC := SaveDC(HDC(Msg.WParam)); // protect DC against changes\r\n try\r\n inherited WndProc(Msg);\r\n finally\r\n RestoreDC(HDC(Msg.WParam), IdSaveDC);\r\n end;\r\n end;\r\n {$ENDIF ~DELPHI2007_UP}\r\n WM_GETDLGCODE:\r\n begin\r\n inherited WndProc(Msg);\r\n DlgCodes := [dcNative] + DlgcToDlgCodes(Msg.Result);\r\n GetDlgCode(DlgCodes);\r\n if not (dcNative in DlgCodes) then\r\n Msg.Result := DlgCodesToDlgc(DlgCodes);\r\n end;\r\n else\r\n inherited WndProc(Msg);\r\n end;\r\n case Msg.Msg of // precheck message to prevent access violations on released controls\r\n CM_MOUSEENTER, CM_MOUSELEAVE, WM_KILLFOCUS, WM_SETFOCUS, WM_NCPAINT:\r\n if DotNetHighlighting then\r\n HandleDotNetHighlighting(Self, Msg, MouseOver, Color);\r\n end;\r\n end;\r\nend;\r\n\r\n//============================================================================\r\n\r\nconstructor TJvExGroupBox.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FHintColor := clDefault;\r\nend;\r\n\r\nfunction TJvExGroupBox.BaseWndProc(Msg: Cardinal; WParam: WPARAM = 0; LParam: LPARAM = 0): LRESULT;\r\nvar\r\n Mesg: TMessage;\r\nbegin\r\n CreateWMMessage(Mesg, Msg, WParam, LParam);\r\n inherited WndProc(Mesg);\r\n Result := Mesg.Result;\r\nend;\r\n\r\nfunction TJvExGroupBox.BaseWndProc(Msg: Cardinal; WParam: WPARAM; LParam: TObject): LRESULT;\r\nbegin\r\n Result := BaseWndProc(Msg, WParam, Windows.LPARAM(LParam));\r\nend;\r\n\r\nfunction TJvExGroupBox.BaseWndProcEx(Msg: Cardinal; WParam: WPARAM; var StructLParam): LRESULT;\r\nbegin\r\n Result := BaseWndProc(Msg, WParam, Windows.LPARAM(@StructLParam));\r\nend;\r\n\r\nprocedure TJvExGroupBox.VisibleChanged;\r\nbegin\r\n BaseWndProc(CM_VISIBLECHANGED);\r\nend;\r\n\r\nprocedure TJvExGroupBox.EnabledChanged;\r\nbegin\r\n BaseWndProc(CM_ENABLEDCHANGED);\r\nend;\r\n\r\nprocedure TJvExGroupBox.TextChanged;\r\nbegin\r\n BaseWndProc(CM_TEXTCHANGED);\r\nend;\r\n\r\nprocedure TJvExGroupBox.FontChanged;\r\nbegin\r\n BaseWndProc(CM_FONTCHANGED);\r\nend;\r\n\r\nprocedure TJvExGroupBox.ColorChanged;\r\nbegin\r\n BaseWndProc(CM_COLORCHANGED);\r\nend;\r\n\r\nprocedure TJvExGroupBox.ParentFontChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTFONTCHANGED);\r\nend;\r\n\r\nprocedure TJvExGroupBox.ParentColorChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTCOLORCHANGED);\r\n if Assigned(OnParentColorChange) then\r\n OnParentColorChange(Self);\r\nend;\r\n\r\nprocedure TJvExGroupBox.ParentShowHintChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTSHOWHINTCHANGED);\r\nend;\r\n\r\nfunction TJvExGroupBox.WantKey(Key: Integer; Shift: TShiftState): Boolean;\r\nbegin\r\n Result := BaseWndProc(CM_DIALOGCHAR, Word(Key), ShiftStateToKeyData(Shift)) <> 0;\r\nend;\r\n\r\nfunction TJvExGroupBox.HitTest(X, Y: Integer): Boolean;\r\nbegin\r\n Result := BaseWndProc(CM_HITTEST, 0, SmallPointToLong(PointToSmallPoint(Point(X, Y)))) <> 0;\r\nend;\r\n\r\nfunction TJvExGroupBox.HintShow(var HintInfo: THintInfo): Boolean;\r\nbegin\r\n GetHintColor(HintInfo, Self, FHintColor);\r\n if FHintWindowClass <> nil then\r\n HintInfo.HintWindowClass := FHintWindowClass;\r\n Result := BaseWndProcEx(CM_HINTSHOW, 0, HintInfo) <> 0;\r\nend;\r\n\r\nprocedure TJvExGroupBox.MouseEnter(AControl: TControl);\r\nbegin\r\n FMouseOver := True;\r\n if Assigned(FOnMouseEnter) then\r\n FOnMouseEnter(Self);\r\n BaseWndProc(CM_MOUSEENTER, 0, AControl);\r\nend;\r\n\r\nprocedure TJvExGroupBox.MouseLeave(AControl: TControl);\r\nbegin\r\n FMouseOver := False;\r\n BaseWndProc(CM_MOUSELEAVE, 0, AControl);\r\n if Assigned(FOnMouseLeave) then\r\n FOnMouseLeave(Self);\r\nend;\r\n\r\nprocedure TJvExGroupBox.FocusChanged(AControl: TWinControl);\r\nbegin\r\n BaseWndProc(CM_FOCUSCHANGED, 0, AControl);\r\nend;\r\n\r\nprocedure TJvExGroupBox.BoundsChanged;\r\nbegin\r\nend;\r\n\r\nprocedure TJvExGroupBox.CursorChanged;\r\nbegin\r\n BaseWndProc(CM_CURSORCHANGED);\r\nend;\r\n\r\nprocedure TJvExGroupBox.ShowingChanged;\r\nbegin\r\n BaseWndProc(CM_SHOWINGCHANGED);\r\nend;\r\n\r\nprocedure TJvExGroupBox.ShowHintChanged;\r\nbegin\r\n BaseWndProc(CM_SHOWHINTCHANGED);\r\nend;\r\n\r\n{ VCL sends CM_CONTROLLISTCHANGE and CM_CONTROLCHANGE in a different order than\r\n the CLX methods are used. So we must correct it by evaluating \"Inserting\". }\r\nprocedure TJvExGroupBox.ControlsListChanging(Control: TControl; Inserting: Boolean);\r\nbegin\r\n if Inserting then\r\n BaseWndProc(CM_CONTROLLISTCHANGE, WPARAM(Control), LPARAM(Inserting))\r\n else\r\n BaseWndProc(CM_CONTROLCHANGE, WPARAM(Control), LPARAM(Inserting));\r\nend;\r\n\r\nprocedure TJvExGroupBox.ControlsListChanged(Control: TControl; Inserting: Boolean);\r\nbegin\r\n if not Inserting then\r\n BaseWndProc(CM_CONTROLLISTCHANGE, WPARAM(Control), LPARAM(Inserting))\r\n else\r\n BaseWndProc(CM_CONTROLCHANGE, WPARAM(Control), LPARAM(Inserting));\r\nend;\r\n\r\nprocedure TJvExGroupBox.GetDlgCode(var Code: TDlgCodes);\r\nbegin\r\nend;\r\n\r\nprocedure TJvExGroupBox.FocusSet(PrevWnd: THandle);\r\nbegin\r\n BaseWndProc(WM_SETFOCUS, WPARAM(PrevWnd), 0);\r\nend;\r\n\r\nprocedure TJvExGroupBox.FocusKilled(NextWnd: THandle);\r\nbegin\r\n BaseWndProc(WM_KILLFOCUS, WPARAM(NextWnd), 0);\r\nend;\r\n\r\nfunction TJvExGroupBox.DoEraseBackground(Canvas: TCanvas; Param: LPARAM): Boolean;\r\nbegin\r\n Result := BaseWndProc(WM_ERASEBKGND, Canvas.Handle, Param) <> 0;\r\nend;\r\n\r\n{$IFDEF JVCLThemesEnabledD6}\r\nfunction TJvExGroupBox.GetParentBackground: Boolean;\r\nbegin\r\n Result := JvThemes.GetParentBackground(Self);\r\nend;\r\n\r\nprocedure TJvExGroupBox.SetParentBackground(Value: Boolean);\r\nbegin\r\n JvThemes.SetParentBackground(Self, Value);\r\nend;\r\n{$ENDIF JVCLThemesEnabledD6}\r\n\r\nprocedure TJvExGroupBox.WndProc(var Msg: TMessage);\r\nvar\r\n IdSaveDC: Integer;\r\n DlgCodes: TDlgCodes;\r\n Canvas: TCanvas;\r\nbegin\r\n if not DispatchIsDesignMsg(Self, Msg) then\r\n begin\r\n case Msg.Msg of\r\n CM_DENYSUBCLASSING:\r\n Msg.Result := LRESULT(Ord(GetInterfaceEntry(IJvDenySubClassing) <> nil));\r\n CM_DIALOGCHAR:\r\n with TCMDialogChar{$IFDEF CLR}.Create{$ENDIF}(Msg) do\r\n Result := LRESULT(Ord(WantKey(CharCode, KeyDataToShiftState(KeyData))));\r\n CM_HINTSHOW:\r\n with TCMHintShow(Msg) do\r\n Result := LRESULT(HintShow(HintInfo^));\r\n CM_HITTEST:\r\n with TCMHitTest(Msg) do\r\n Result := LRESULT(HitTest(XPos, YPos));\r\n CM_MOUSEENTER:\r\n MouseEnter(TControl(Msg.LParam));\r\n CM_MOUSELEAVE:\r\n MouseLeave(TControl(Msg.LParam));\r\n CM_VISIBLECHANGED:\r\n VisibleChanged;\r\n CM_ENABLEDCHANGED:\r\n EnabledChanged;\r\n CM_TEXTCHANGED:\r\n TextChanged;\r\n CM_FONTCHANGED:\r\n FontChanged;\r\n CM_COLORCHANGED:\r\n ColorChanged;\r\n CM_FOCUSCHANGED:\r\n FocusChanged(TWinControl(Msg.LParam));\r\n CM_PARENTFONTCHANGED:\r\n ParentFontChanged;\r\n CM_PARENTCOLORCHANGED:\r\n ParentColorChanged;\r\n CM_PARENTSHOWHINTCHANGED:\r\n ParentShowHintChanged;\r\n CM_CURSORCHANGED:\r\n CursorChanged;\r\n CM_SHOWINGCHANGED:\r\n ShowingChanged;\r\n CM_SHOWHINTCHANGED:\r\n ShowHintChanged;\r\n CM_CONTROLLISTCHANGE:\r\n if Msg.LParam <> 0 then\r\n ControlsListChanging(TControl(Msg.WParam), True)\r\n else\r\n ControlsListChanged(TControl(Msg.WParam), False);\r\n CM_CONTROLCHANGE:\r\n if Msg.LParam = 0 then\r\n ControlsListChanging(TControl(Msg.WParam), False)\r\n else\r\n ControlsListChanged(TControl(Msg.WParam), True);\r\n WM_SETFOCUS:\r\n FocusSet(THandle(Msg.WParam));\r\n WM_KILLFOCUS:\r\n FocusKilled(THandle(Msg.WParam));\r\n WM_SIZE, WM_MOVE:\r\n begin\r\n inherited WndProc(Msg);\r\n BoundsChanged;\r\n end;\r\n WM_ERASEBKGND:\r\n if (Msg.WParam <> 0) and not IsDefaultEraseBackground(DoEraseBackground, @TJvExGroupBox.DoEraseBackground) then\r\n begin\r\n IdSaveDC := SaveDC(HDC(Msg.WParam)); // protect DC against Stock-Objects from Canvas\r\n Canvas := TCanvas.Create;\r\n try\r\n Canvas.Handle := HDC(Msg.WParam);\r\n Msg.Result := Ord(DoEraseBackground(Canvas, Msg.LParam));\r\n finally\r\n Canvas.Handle := 0;\r\n Canvas.Free;\r\n RestoreDC(HDC(Msg.WParam), IdSaveDC);\r\n end;\r\n end\r\n else\r\n inherited WndProc(Msg);\r\n {$IFNDEF DELPHI2007_UP}\r\n WM_PRINTCLIENT, WM_PRINT: // VCL bug fix\r\n begin\r\n IdSaveDC := SaveDC(HDC(Msg.WParam)); // protect DC against changes\r\n try\r\n inherited WndProc(Msg);\r\n finally\r\n RestoreDC(HDC(Msg.WParam), IdSaveDC);\r\n end;\r\n end;\r\n {$ENDIF ~DELPHI2007_UP}\r\n WM_GETDLGCODE:\r\n begin\r\n inherited WndProc(Msg);\r\n DlgCodes := [dcNative] + DlgcToDlgCodes(Msg.Result);\r\n GetDlgCode(DlgCodes);\r\n if not (dcNative in DlgCodes) then\r\n Msg.Result := DlgCodesToDlgc(DlgCodes);\r\n end;\r\n else\r\n inherited WndProc(Msg);\r\n end;\r\n case Msg.Msg of // precheck message to prevent access violations on released controls\r\n CM_MOUSEENTER, CM_MOUSELEAVE, WM_KILLFOCUS, WM_SETFOCUS, WM_NCPAINT:\r\n if DotNetHighlighting then\r\n HandleDotNetHighlighting(Self, Msg, MouseOver, Color);\r\n end;\r\n end;\r\nend;\r\n\r\n//============================================================================\r\n\r\nconstructor TJvExCheckBox.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FHintColor := clDefault;\r\nend;\r\n\r\nfunction TJvExCheckBox.BaseWndProc(Msg: Cardinal; WParam: WPARAM = 0; LParam: LPARAM = 0): LRESULT;\r\nvar\r\n Mesg: TMessage;\r\nbegin\r\n CreateWMMessage(Mesg, Msg, WParam, LParam);\r\n inherited WndProc(Mesg);\r\n Result := Mesg.Result;\r\nend;\r\n\r\nfunction TJvExCheckBox.BaseWndProc(Msg: Cardinal; WParam: WPARAM; LParam: TObject): LRESULT;\r\nbegin\r\n Result := BaseWndProc(Msg, WParam, Windows.LPARAM(LParam));\r\nend;\r\n\r\nfunction TJvExCheckBox.BaseWndProcEx(Msg: Cardinal; WParam: WPARAM; var StructLParam): LRESULT;\r\nbegin\r\n Result := BaseWndProc(Msg, WParam, Windows.LPARAM(@StructLParam));\r\nend;\r\n\r\nprocedure TJvExCheckBox.VisibleChanged;\r\nbegin\r\n BaseWndProc(CM_VISIBLECHANGED);\r\nend;\r\n\r\nprocedure TJvExCheckBox.EnabledChanged;\r\nbegin\r\n BaseWndProc(CM_ENABLEDCHANGED);\r\nend;\r\n\r\nprocedure TJvExCheckBox.TextChanged;\r\nbegin\r\n BaseWndProc(CM_TEXTCHANGED);\r\nend;\r\n\r\nprocedure TJvExCheckBox.FontChanged;\r\nbegin\r\n BaseWndProc(CM_FONTCHANGED);\r\nend;\r\n\r\nprocedure TJvExCheckBox.ColorChanged;\r\nbegin\r\n BaseWndProc(CM_COLORCHANGED);\r\nend;\r\n\r\nprocedure TJvExCheckBox.ParentFontChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTFONTCHANGED);\r\nend;\r\n\r\nprocedure TJvExCheckBox.ParentColorChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTCOLORCHANGED);\r\n if Assigned(OnParentColorChange) then\r\n OnParentColorChange(Self);\r\nend;\r\n\r\nprocedure TJvExCheckBox.ParentShowHintChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTSHOWHINTCHANGED);\r\nend;\r\n\r\nfunction TJvExCheckBox.WantKey(Key: Integer; Shift: TShiftState): Boolean;\r\nbegin\r\n Result := BaseWndProc(CM_DIALOGCHAR, Word(Key), ShiftStateToKeyData(Shift)) <> 0;\r\nend;\r\n\r\nfunction TJvExCheckBox.HitTest(X, Y: Integer): Boolean;\r\nbegin\r\n Result := BaseWndProc(CM_HITTEST, 0, SmallPointToLong(PointToSmallPoint(Point(X, Y)))) <> 0;\r\nend;\r\n\r\nfunction TJvExCheckBox.HintShow(var HintInfo: THintInfo): Boolean;\r\nbegin\r\n GetHintColor(HintInfo, Self, FHintColor);\r\n if FHintWindowClass <> nil then\r\n HintInfo.HintWindowClass := FHintWindowClass;\r\n Result := BaseWndProcEx(CM_HINTSHOW, 0, HintInfo) <> 0;\r\nend;\r\n\r\nprocedure TJvExCheckBox.MouseEnter(AControl: TControl);\r\nbegin\r\n FMouseOver := True;\r\n if Assigned(FOnMouseEnter) then\r\n FOnMouseEnter(Self);\r\n BaseWndProc(CM_MOUSEENTER, 0, AControl);\r\nend;\r\n\r\nprocedure TJvExCheckBox.MouseLeave(AControl: TControl);\r\nbegin\r\n FMouseOver := False;\r\n BaseWndProc(CM_MOUSELEAVE, 0, AControl);\r\n if Assigned(FOnMouseLeave) then\r\n FOnMouseLeave(Self);\r\nend;\r\n\r\nprocedure TJvExCheckBox.FocusChanged(AControl: TWinControl);\r\nbegin\r\n BaseWndProc(CM_FOCUSCHANGED, 0, AControl);\r\nend;\r\n\r\nprocedure TJvExCheckBox.BoundsChanged;\r\nbegin\r\nend;\r\n\r\nprocedure TJvExCheckBox.CursorChanged;\r\nbegin\r\n BaseWndProc(CM_CURSORCHANGED);\r\nend;\r\n\r\nprocedure TJvExCheckBox.ShowingChanged;\r\nbegin\r\n BaseWndProc(CM_SHOWINGCHANGED);\r\nend;\r\n\r\nprocedure TJvExCheckBox.ShowHintChanged;\r\nbegin\r\n BaseWndProc(CM_SHOWHINTCHANGED);\r\nend;\r\n\r\n{ VCL sends CM_CONTROLLISTCHANGE and CM_CONTROLCHANGE in a different order than\r\n the CLX methods are used. So we must correct it by evaluating \"Inserting\". }\r\nprocedure TJvExCheckBox.ControlsListChanging(Control: TControl; Inserting: Boolean);\r\nbegin\r\n if Inserting then\r\n BaseWndProc(CM_CONTROLLISTCHANGE, WPARAM(Control), LPARAM(Inserting))\r\n else\r\n BaseWndProc(CM_CONTROLCHANGE, WPARAM(Control), LPARAM(Inserting));\r\nend;\r\n\r\nprocedure TJvExCheckBox.ControlsListChanged(Control: TControl; Inserting: Boolean);\r\nbegin\r\n if not Inserting then\r\n BaseWndProc(CM_CONTROLLISTCHANGE, WPARAM(Control), LPARAM(Inserting))\r\n else\r\n BaseWndProc(CM_CONTROLCHANGE, WPARAM(Control), LPARAM(Inserting));\r\nend;\r\n\r\nprocedure TJvExCheckBox.GetDlgCode(var Code: TDlgCodes);\r\nbegin\r\nend;\r\n\r\nprocedure TJvExCheckBox.FocusSet(PrevWnd: THandle);\r\nbegin\r\n BaseWndProc(WM_SETFOCUS, WPARAM(PrevWnd), 0);\r\nend;\r\n\r\nprocedure TJvExCheckBox.FocusKilled(NextWnd: THandle);\r\nbegin\r\n BaseWndProc(WM_KILLFOCUS, WPARAM(NextWnd), 0);\r\nend;\r\n\r\nfunction TJvExCheckBox.DoEraseBackground(Canvas: TCanvas; Param: LPARAM): Boolean;\r\nbegin\r\n Result := BaseWndProc(WM_ERASEBKGND, Canvas.Handle, Param) <> 0;\r\nend;\r\n\r\n{$IFDEF JVCLThemesEnabledD6}\r\nfunction TJvExCheckBox.GetParentBackground: Boolean;\r\nbegin\r\n Result := JvThemes.GetParentBackground(Self);\r\nend;\r\n\r\nprocedure TJvExCheckBox.SetParentBackground(Value: Boolean);\r\nbegin\r\n JvThemes.SetParentBackground(Self, Value);\r\nend;\r\n{$ENDIF JVCLThemesEnabledD6}\r\n\r\nprocedure TJvExCheckBox.WndProc(var Msg: TMessage);\r\nvar\r\n IdSaveDC: Integer;\r\n DlgCodes: TDlgCodes;\r\n Canvas: TCanvas;\r\nbegin\r\n if not DispatchIsDesignMsg(Self, Msg) then\r\n begin\r\n case Msg.Msg of\r\n CM_DENYSUBCLASSING:\r\n Msg.Result := LRESULT(Ord(GetInterfaceEntry(IJvDenySubClassing) <> nil));\r\n CM_DIALOGCHAR:\r\n with TCMDialogChar{$IFDEF CLR}.Create{$ENDIF}(Msg) do\r\n Result := LRESULT(Ord(WantKey(CharCode, KeyDataToShiftState(KeyData))));\r\n CM_HINTSHOW:\r\n with TCMHintShow(Msg) do\r\n Result := LRESULT(HintShow(HintInfo^));\r\n CM_HITTEST:\r\n with TCMHitTest(Msg) do\r\n Result := LRESULT(HitTest(XPos, YPos));\r\n CM_MOUSEENTER:\r\n MouseEnter(TControl(Msg.LParam));\r\n CM_MOUSELEAVE:\r\n MouseLeave(TControl(Msg.LParam));\r\n CM_VISIBLECHANGED:\r\n VisibleChanged;\r\n CM_ENABLEDCHANGED:\r\n EnabledChanged;\r\n CM_TEXTCHANGED:\r\n TextChanged;\r\n CM_FONTCHANGED:\r\n FontChanged;\r\n CM_COLORCHANGED:\r\n ColorChanged;\r\n CM_FOCUSCHANGED:\r\n FocusChanged(TWinControl(Msg.LParam));\r\n CM_PARENTFONTCHANGED:\r\n ParentFontChanged;\r\n CM_PARENTCOLORCHANGED:\r\n ParentColorChanged;\r\n CM_PARENTSHOWHINTCHANGED:\r\n ParentShowHintChanged;\r\n CM_CURSORCHANGED:\r\n CursorChanged;\r\n CM_SHOWINGCHANGED:\r\n ShowingChanged;\r\n CM_SHOWHINTCHANGED:\r\n ShowHintChanged;\r\n CM_CONTROLLISTCHANGE:\r\n if Msg.LParam <> 0 then\r\n ControlsListChanging(TControl(Msg.WParam), True)\r\n else\r\n ControlsListChanged(TControl(Msg.WParam), False);\r\n CM_CONTROLCHANGE:\r\n if Msg.LParam = 0 then\r\n ControlsListChanging(TControl(Msg.WParam), False)\r\n else\r\n ControlsListChanged(TControl(Msg.WParam), True);\r\n WM_SETFOCUS:\r\n FocusSet(THandle(Msg.WParam));\r\n WM_KILLFOCUS:\r\n FocusKilled(THandle(Msg.WParam));\r\n WM_SIZE, WM_MOVE:\r\n begin\r\n inherited WndProc(Msg);\r\n BoundsChanged;\r\n end;\r\n WM_ERASEBKGND:\r\n if (Msg.WParam <> 0) and not IsDefaultEraseBackground(DoEraseBackground, @TJvExCheckBox.DoEraseBackground) then\r\n begin\r\n IdSaveDC := SaveDC(HDC(Msg.WParam)); // protect DC against Stock-Objects from Canvas\r\n Canvas := TCanvas.Create;\r\n try\r\n Canvas.Handle := HDC(Msg.WParam);\r\n Msg.Result := Ord(DoEraseBackground(Canvas, Msg.LParam));\r\n finally\r\n Canvas.Handle := 0;\r\n Canvas.Free;\r\n RestoreDC(HDC(Msg.WParam), IdSaveDC);\r\n end;\r\n end\r\n else\r\n inherited WndProc(Msg);\r\n {$IFNDEF DELPHI2007_UP}\r\n WM_PRINTCLIENT, WM_PRINT: // VCL bug fix\r\n begin\r\n IdSaveDC := SaveDC(HDC(Msg.WParam)); // protect DC against changes\r\n try\r\n inherited WndProc(Msg);\r\n finally\r\n RestoreDC(HDC(Msg.WParam), IdSaveDC);\r\n end;\r\n end;\r\n {$ENDIF ~DELPHI2007_UP}\r\n WM_GETDLGCODE:\r\n begin\r\n inherited WndProc(Msg);\r\n DlgCodes := [dcNative] + DlgcToDlgCodes(Msg.Result);\r\n GetDlgCode(DlgCodes);\r\n if not (dcNative in DlgCodes) then\r\n Msg.Result := DlgCodesToDlgc(DlgCodes);\r\n end;\r\n else\r\n inherited WndProc(Msg);\r\n end;\r\n case Msg.Msg of // precheck message to prevent access violations on released controls\r\n CM_MOUSEENTER, CM_MOUSELEAVE, WM_KILLFOCUS, WM_SETFOCUS, WM_NCPAINT:\r\n if DotNetHighlighting then\r\n HandleDotNetHighlighting(Self, Msg, MouseOver, Color);\r\n end;\r\n end;\r\nend;\r\n\r\n//============================================================================\r\n\r\nconstructor TJvExCustomStaticText.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FHintColor := clDefault;\r\nend;\r\n\r\nfunction TJvExCustomStaticText.BaseWndProc(Msg: Cardinal; WParam: WPARAM = 0; LParam: LPARAM = 0): LRESULT;\r\nvar\r\n Mesg: TMessage;\r\nbegin\r\n CreateWMMessage(Mesg, Msg, WParam, LParam);\r\n inherited WndProc(Mesg);\r\n Result := Mesg.Result;\r\nend;\r\n\r\nfunction TJvExCustomStaticText.BaseWndProc(Msg: Cardinal; WParam: WPARAM; LParam: TObject): LRESULT;\r\nbegin\r\n Result := BaseWndProc(Msg, WParam, Windows.LPARAM(LParam));\r\nend;\r\n\r\nfunction TJvExCustomStaticText.BaseWndProcEx(Msg: Cardinal; WParam: WPARAM; var StructLParam): LRESULT;\r\nbegin\r\n Result := BaseWndProc(Msg, WParam, Windows.LPARAM(@StructLParam));\r\nend;\r\n\r\nprocedure TJvExCustomStaticText.VisibleChanged;\r\nbegin\r\n BaseWndProc(CM_VISIBLECHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomStaticText.EnabledChanged;\r\nbegin\r\n BaseWndProc(CM_ENABLEDCHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomStaticText.TextChanged;\r\nbegin\r\n BaseWndProc(CM_TEXTCHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomStaticText.FontChanged;\r\nbegin\r\n BaseWndProc(CM_FONTCHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomStaticText.ColorChanged;\r\nbegin\r\n BaseWndProc(CM_COLORCHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomStaticText.ParentFontChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTFONTCHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomStaticText.ParentColorChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTCOLORCHANGED);\r\n if Assigned(OnParentColorChange) then\r\n OnParentColorChange(Self);\r\nend;\r\n\r\nprocedure TJvExCustomStaticText.ParentShowHintChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTSHOWHINTCHANGED);\r\nend;\r\n\r\nfunction TJvExCustomStaticText.WantKey(Key: Integer; Shift: TShiftState): Boolean;\r\nbegin\r\n Result := BaseWndProc(CM_DIALOGCHAR, Word(Key), ShiftStateToKeyData(Shift)) <> 0;\r\nend;\r\n\r\nfunction TJvExCustomStaticText.HitTest(X, Y: Integer): Boolean;\r\nbegin\r\n Result := BaseWndProc(CM_HITTEST, 0, SmallPointToLong(PointToSmallPoint(Point(X, Y)))) <> 0;\r\nend;\r\n\r\nfunction TJvExCustomStaticText.HintShow(var HintInfo: THintInfo): Boolean;\r\nbegin\r\n GetHintColor(HintInfo, Self, FHintColor);\r\n if FHintWindowClass <> nil then\r\n HintInfo.HintWindowClass := FHintWindowClass;\r\n Result := BaseWndProcEx(CM_HINTSHOW, 0, HintInfo) <> 0;\r\nend;\r\n\r\nprocedure TJvExCustomStaticText.MouseEnter(AControl: TControl);\r\nbegin\r\n FMouseOver := True;\r\n if Assigned(FOnMouseEnter) then\r\n FOnMouseEnter(Self);\r\n BaseWndProc(CM_MOUSEENTER, 0, AControl);\r\nend;\r\n\r\nprocedure TJvExCustomStaticText.MouseLeave(AControl: TControl);\r\nbegin\r\n FMouseOver := False;\r\n BaseWndProc(CM_MOUSELEAVE, 0, AControl);\r\n if Assigned(FOnMouseLeave) then\r\n FOnMouseLeave(Self);\r\nend;\r\n\r\nprocedure TJvExCustomStaticText.FocusChanged(AControl: TWinControl);\r\nbegin\r\n BaseWndProc(CM_FOCUSCHANGED, 0, AControl);\r\nend;\r\n\r\nprocedure TJvExCustomStaticText.BoundsChanged;\r\nbegin\r\nend;\r\n\r\nprocedure TJvExCustomStaticText.CursorChanged;\r\nbegin\r\n BaseWndProc(CM_CURSORCHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomStaticText.ShowingChanged;\r\nbegin\r\n BaseWndProc(CM_SHOWINGCHANGED);\r\nend;\r\n\r\nprocedure TJvExCustomStaticText.ShowHintChanged;\r\nbegin\r\n BaseWndProc(CM_SHOWHINTCHANGED);\r\nend;\r\n\r\n{ VCL sends CM_CONTROLLISTCHANGE and CM_CONTROLCHANGE in a different order than\r\n the CLX methods are used. So we must correct it by evaluating \"Inserting\". }\r\nprocedure TJvExCustomStaticText.ControlsListChanging(Control: TControl; Inserting: Boolean);\r\nbegin\r\n if Inserting then\r\n BaseWndProc(CM_CONTROLLISTCHANGE, WPARAM(Control), LPARAM(Inserting))\r\n else\r\n BaseWndProc(CM_CONTROLCHANGE, WPARAM(Control), LPARAM(Inserting));\r\nend;\r\n\r\nprocedure TJvExCustomStaticText.ControlsListChanged(Control: TControl; Inserting: Boolean);\r\nbegin\r\n if not Inserting then\r\n BaseWndProc(CM_CONTROLLISTCHANGE, WPARAM(Control), LPARAM(Inserting))\r\n else\r\n BaseWndProc(CM_CONTROLCHANGE, WPARAM(Control), LPARAM(Inserting));\r\nend;\r\n\r\nprocedure TJvExCustomStaticText.GetDlgCode(var Code: TDlgCodes);\r\nbegin\r\nend;\r\n\r\nprocedure TJvExCustomStaticText.FocusSet(PrevWnd: THandle);\r\nbegin\r\n BaseWndProc(WM_SETFOCUS, WPARAM(PrevWnd), 0);\r\nend;\r\n\r\nprocedure TJvExCustomStaticText.FocusKilled(NextWnd: THandle);\r\nbegin\r\n BaseWndProc(WM_KILLFOCUS, WPARAM(NextWnd), 0);\r\nend;\r\n\r\nfunction TJvExCustomStaticText.DoEraseBackground(Canvas: TCanvas; Param: LPARAM): Boolean;\r\nbegin\r\n Result := BaseWndProc(WM_ERASEBKGND, Canvas.Handle, Param) <> 0;\r\nend;\r\n\r\n{$IFDEF JVCLThemesEnabledD6}\r\nfunction TJvExCustomStaticText.GetParentBackground: Boolean;\r\nbegin\r\n Result := JvThemes.GetParentBackground(Self);\r\nend;\r\n\r\nprocedure TJvExCustomStaticText.SetParentBackground(Value: Boolean);\r\nbegin\r\n JvThemes.SetParentBackground(Self, Value);\r\nend;\r\n{$ENDIF JVCLThemesEnabledD6}\r\n\r\nprocedure TJvExCustomStaticText.WndProc(var Msg: TMessage);\r\nvar\r\n IdSaveDC: Integer;\r\n DlgCodes: TDlgCodes;\r\n Canvas: TCanvas;\r\nbegin\r\n if not DispatchIsDesignMsg(Self, Msg) then\r\n begin\r\n case Msg.Msg of\r\n CM_DENYSUBCLASSING:\r\n Msg.Result := LRESULT(Ord(GetInterfaceEntry(IJvDenySubClassing) <> nil));\r\n CM_DIALOGCHAR:\r\n with TCMDialogChar{$IFDEF CLR}.Create{$ENDIF}(Msg) do\r\n Result := LRESULT(Ord(WantKey(CharCode, KeyDataToShiftState(KeyData))));\r\n CM_HINTSHOW:\r\n with TCMHintShow(Msg) do\r\n Result := LRESULT(HintShow(HintInfo^));\r\n CM_HITTEST:\r\n with TCMHitTest(Msg) do\r\n Result := LRESULT(HitTest(XPos, YPos));\r\n CM_MOUSEENTER:\r\n MouseEnter(TControl(Msg.LParam));\r\n CM_MOUSELEAVE:\r\n MouseLeave(TControl(Msg.LParam));\r\n CM_VISIBLECHANGED:\r\n VisibleChanged;\r\n CM_ENABLEDCHANGED:\r\n EnabledChanged;\r\n CM_TEXTCHANGED:\r\n TextChanged;\r\n CM_FONTCHANGED:\r\n FontChanged;\r\n CM_COLORCHANGED:\r\n ColorChanged;\r\n CM_FOCUSCHANGED:\r\n FocusChanged(TWinControl(Msg.LParam));\r\n CM_PARENTFONTCHANGED:\r\n ParentFontChanged;\r\n CM_PARENTCOLORCHANGED:\r\n ParentColorChanged;\r\n CM_PARENTSHOWHINTCHANGED:\r\n ParentShowHintChanged;\r\n CM_CURSORCHANGED:\r\n CursorChanged;\r\n CM_SHOWINGCHANGED:\r\n ShowingChanged;\r\n CM_SHOWHINTCHANGED:\r\n ShowHintChanged;\r\n CM_CONTROLLISTCHANGE:\r\n if Msg.LParam <> 0 then\r\n ControlsListChanging(TControl(Msg.WParam), True)\r\n else\r\n ControlsListChanged(TControl(Msg.WParam), False);\r\n CM_CONTROLCHANGE:\r\n if Msg.LParam = 0 then\r\n ControlsListChanging(TControl(Msg.WParam), False)\r\n else\r\n ControlsListChanged(TControl(Msg.WParam), True);\r\n WM_SETFOCUS:\r\n FocusSet(THandle(Msg.WParam));\r\n WM_KILLFOCUS:\r\n FocusKilled(THandle(Msg.WParam));\r\n WM_SIZE, WM_MOVE:\r\n begin\r\n inherited WndProc(Msg);\r\n BoundsChanged;\r\n end;\r\n WM_ERASEBKGND:\r\n if (Msg.WParam <> 0) and not IsDefaultEraseBackground(DoEraseBackground, @TJvExCustomStaticText.DoEraseBackground) then\r\n begin\r\n IdSaveDC := SaveDC(HDC(Msg.WParam)); // protect DC against Stock-Objects from Canvas\r\n Canvas := TCanvas.Create;\r\n try\r\n Canvas.Handle := HDC(Msg.WParam);\r\n Msg.Result := Ord(DoEraseBackground(Canvas, Msg.LParam));\r\n finally\r\n Canvas.Handle := 0;\r\n Canvas.Free;\r\n RestoreDC(HDC(Msg.WParam), IdSaveDC);\r\n end;\r\n end\r\n else\r\n inherited WndProc(Msg);\r\n {$IFNDEF DELPHI2007_UP}\r\n WM_PRINTCLIENT, WM_PRINT: // VCL bug fix\r\n begin\r\n IdSaveDC := SaveDC(HDC(Msg.WParam)); // protect DC against changes\r\n try\r\n inherited WndProc(Msg);\r\n finally\r\n RestoreDC(HDC(Msg.WParam), IdSaveDC);\r\n end;\r\n end;\r\n {$ENDIF ~DELPHI2007_UP}\r\n WM_GETDLGCODE:\r\n begin\r\n inherited WndProc(Msg);\r\n DlgCodes := [dcNative] + DlgcToDlgCodes(Msg.Result);\r\n GetDlgCode(DlgCodes);\r\n if not (dcNative in DlgCodes) then\r\n Msg.Result := DlgCodesToDlgc(DlgCodes);\r\n end;\r\n else\r\n inherited WndProc(Msg);\r\n end;\r\n case Msg.Msg of // precheck message to prevent access violations on released controls\r\n CM_MOUSEENTER, CM_MOUSELEAVE, WM_KILLFOCUS, WM_SETFOCUS, WM_NCPAINT:\r\n if DotNetHighlighting then\r\n HandleDotNetHighlighting(Self, Msg, MouseOver, Color);\r\n end;\r\n end;\r\nend;\r\n\r\n//============================================================================\r\n\r\nconstructor TJvExStaticText.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FHintColor := clDefault;\r\nend;\r\n\r\nfunction TJvExStaticText.BaseWndProc(Msg: Cardinal; WParam: WPARAM = 0; LParam: LPARAM = 0): LRESULT;\r\nvar\r\n Mesg: TMessage;\r\nbegin\r\n CreateWMMessage(Mesg, Msg, WParam, LParam);\r\n inherited WndProc(Mesg);\r\n Result := Mesg.Result;\r\nend;\r\n\r\nfunction TJvExStaticText.BaseWndProc(Msg: Cardinal; WParam: WPARAM; LParam: TObject): LRESULT;\r\nbegin\r\n Result := BaseWndProc(Msg, WParam, Windows.LPARAM(LParam));\r\nend;\r\n\r\nfunction TJvExStaticText.BaseWndProcEx(Msg: Cardinal; WParam: WPARAM; var StructLParam): LRESULT;\r\nbegin\r\n Result := BaseWndProc(Msg, WParam, Windows.LPARAM(@StructLParam));\r\nend;\r\n\r\nprocedure TJvExStaticText.VisibleChanged;\r\nbegin\r\n BaseWndProc(CM_VISIBLECHANGED);\r\nend;\r\n\r\nprocedure TJvExStaticText.EnabledChanged;\r\nbegin\r\n BaseWndProc(CM_ENABLEDCHANGED);\r\nend;\r\n\r\nprocedure TJvExStaticText.TextChanged;\r\nbegin\r\n BaseWndProc(CM_TEXTCHANGED);\r\nend;\r\n\r\nprocedure TJvExStaticText.FontChanged;\r\nbegin\r\n BaseWndProc(CM_FONTCHANGED);\r\nend;\r\n\r\nprocedure TJvExStaticText.ColorChanged;\r\nbegin\r\n BaseWndProc(CM_COLORCHANGED);\r\nend;\r\n\r\nprocedure TJvExStaticText.ParentFontChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTFONTCHANGED);\r\nend;\r\n\r\nprocedure TJvExStaticText.ParentColorChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTCOLORCHANGED);\r\n if Assigned(OnParentColorChange) then\r\n OnParentColorChange(Self);\r\nend;\r\n\r\nprocedure TJvExStaticText.ParentShowHintChanged;\r\nbegin\r\n BaseWndProc(CM_PARENTSHOWHINTCHANGED);\r\nend;\r\n\r\nfunction TJvExStaticText.WantKey(Key: Integer; Shift: TShiftState): Boolean;\r\nbegin\r\n Result := BaseWndProc(CM_DIALOGCHAR, Word(Key), ShiftStateToKeyData(Shift)) <> 0;\r\nend;\r\n\r\nfunction TJvExStaticText.HitTest(X, Y: Integer): Boolean;\r\nbegin\r\n Result := BaseWndProc(CM_HITTEST, 0, SmallPointToLong(PointToSmallPoint(Point(X, Y)))) <> 0;\r\nend;\r\n\r\nfunction TJvExStaticText.HintShow(var HintInfo: THintInfo): Boolean;\r\nbegin\r\n GetHintColor(HintInfo, Self, FHintColor);\r\n if FHintWindowClass <> nil then\r\n HintInfo.HintWindowClass := FHintWindowClass;\r\n Result := BaseWndProcEx(CM_HINTSHOW, 0, HintInfo) <> 0;\r\nend;\r\n\r\nprocedure TJvExStaticText.MouseEnter(AControl: TControl);\r\nbegin\r\n FMouseOver := True;\r\n if Assigned(FOnMouseEnter) then\r\n FOnMouseEnter(Self);\r\n BaseWndProc(CM_MOUSEENTER, 0, AControl);\r\nend;\r\n\r\nprocedure TJvExStaticText.MouseLeave(AControl: TControl);\r\nbegin\r\n FMouseOver := False;\r\n BaseWndProc(CM_MOUSELEAVE, 0, AControl);\r\n if Assigned(FOnMouseLeave) then\r\n FOnMouseLeave(Self);\r\nend;\r\n\r\nprocedure TJvExStaticText.FocusChanged(AControl: TWinControl);\r\nbegin\r\n BaseWndProc(CM_FOCUSCHANGED, 0, AControl);\r\nend;\r\n\r\nprocedure TJvExStaticText.BoundsChanged;\r\nbegin\r\nend;\r\n\r\nprocedure TJvExStaticText.CursorChanged;\r\nbegin\r\n BaseWndProc(CM_CURSORCHANGED);\r\nend;\r\n\r\nprocedure TJvExStaticText.ShowingChanged;\r\nbegin\r\n BaseWndProc(CM_SHOWINGCHANGED);\r\nend;\r\n\r\nprocedure TJvExStaticText.ShowHintChanged;\r\nbegin\r\n BaseWndProc(CM_SHOWHINTCHANGED);\r\nend;\r\n\r\n{ VCL sends CM_CONTROLLISTCHANGE and CM_CONTROLCHANGE in a different order than\r\n the CLX methods are used. So we must correct it by evaluating \"Inserting\". }\r\nprocedure TJvExStaticText.ControlsListChanging(Control: TControl; Inserting: Boolean);\r\nbegin\r\n if Inserting then\r\n BaseWndProc(CM_CONTROLLISTCHANGE, WPARAM(Control), LPARAM(Inserting))\r\n else\r\n BaseWndProc(CM_CONTROLCHANGE, WPARAM(Control), LPARAM(Inserting));\r\nend;\r\n\r\nprocedure TJvExStaticText.ControlsListChanged(Control: TControl; Inserting: Boolean);\r\nbegin\r\n if not Inserting then\r\n BaseWndProc(CM_CONTROLLISTCHANGE, WPARAM(Control), LPARAM(Inserting))\r\n else\r\n BaseWndProc(CM_CONTROLCHANGE, WPARAM(Control), LPARAM(Inserting));\r\nend;\r\n\r\nprocedure TJvExStaticText.GetDlgCode(var Code: TDlgCodes);\r\nbegin\r\nend;\r\n\r\nprocedure TJvExStaticText.FocusSet(PrevWnd: THandle);\r\nbegin\r\n BaseWndProc(WM_SETFOCUS, WPARAM(PrevWnd), 0);\r\nend;\r\n\r\nprocedure TJvExStaticText.FocusKilled(NextWnd: THandle);\r\nbegin\r\n BaseWndProc(WM_KILLFOCUS, WPARAM(NextWnd), 0);\r\nend;\r\n\r\nfunction TJvExStaticText.DoEraseBackground(Canvas: TCanvas; Param: LPARAM): Boolean;\r\nbegin\r\n Result := BaseWndProc(WM_ERASEBKGND, Canvas.Handle, Param) <> 0;\r\nend;\r\n\r\n{$IFDEF JVCLThemesEnabledD6}\r\nfunction TJvExStaticText.GetParentBackground: Boolean;\r\nbegin\r\n Result := JvThemes.GetParentBackground(Self);\r\nend;\r\n\r\nprocedure TJvExStaticText.SetParentBackground(Value: Boolean);\r\nbegin\r\n JvThemes.SetParentBackground(Self, Value);\r\nend;\r\n{$ENDIF JVCLThemesEnabledD6}\r\n\r\nprocedure TJvExStaticText.WndProc(var Msg: TMessage);\r\nvar\r\n IdSaveDC: Integer;\r\n DlgCodes: TDlgCodes;\r\n Canvas: TCanvas;\r\nbegin\r\n if not DispatchIsDesignMsg(Self, Msg) then\r\n begin\r\n case Msg.Msg of\r\n CM_DENYSUBCLASSING:\r\n Msg.Result := LRESULT(Ord(GetInterfaceEntry(IJvDenySubClassing) <> nil));\r\n CM_DIALOGCHAR:\r\n with TCMDialogChar{$IFDEF CLR}.Create{$ENDIF}(Msg) do\r\n Result := LRESULT(Ord(WantKey(CharCode, KeyDataToShiftState(KeyData))));\r\n CM_HINTSHOW:\r\n with TCMHintShow(Msg) do\r\n Result := LRESULT(HintShow(HintInfo^));\r\n CM_HITTEST:\r\n with TCMHitTest(Msg) do\r\n Result := LRESULT(HitTest(XPos, YPos));\r\n CM_MOUSEENTER:\r\n MouseEnter(TControl(Msg.LParam));\r\n CM_MOUSELEAVE:\r\n MouseLeave(TControl(Msg.LParam));\r\n CM_VISIBLECHANGED:\r\n VisibleChanged;\r\n CM_ENABLEDCHANGED:\r\n EnabledChanged;\r\n CM_TEXTCHANGED:\r\n TextChanged;\r\n CM_FONTCHANGED:\r\n FontChanged;\r\n CM_COLORCHANGED:\r\n ColorChanged;\r\n CM_FOCUSCHANGED:\r\n FocusChanged(TWinControl(Msg.LParam));\r\n CM_PARENTFONTCHANGED:\r\n ParentFontChanged;\r\n CM_PARENTCOLORCHANGED:\r\n ParentColorChanged;\r\n CM_PARENTSHOWHINTCHANGED:\r\n ParentShowHintChanged;\r\n CM_CURSORCHANGED:\r\n CursorChanged;\r\n CM_SHOWINGCHANGED:\r\n ShowingChanged;\r\n CM_SHOWHINTCHANGED:\r\n ShowHintChanged;\r\n CM_CONTROLLISTCHANGE:\r\n if Msg.LParam <> 0 then\r\n ControlsListChanging(TControl(Msg.WParam), True)\r\n else\r\n ControlsListChanged(TControl(Msg.WParam), False);\r\n CM_CONTROLCHANGE:\r\n if Msg.LParam = 0 then\r\n ControlsListChanging(TControl(Msg.WParam), False)\r\n else\r\n ControlsListChanged(TControl(Msg.WParam), True);\r\n WM_SETFOCUS:\r\n FocusSet(THandle(Msg.WParam));\r\n WM_KILLFOCUS:\r\n FocusKilled(THandle(Msg.WParam));\r\n WM_SIZE, WM_MOVE:\r\n begin\r\n inherited WndProc(Msg);\r\n BoundsChanged;\r\n end;\r\n WM_ERASEBKGND:\r\n if (Msg.WParam <> 0) and not IsDefaultEraseBackground(DoEraseBackground, @TJvExStaticText.DoEraseBackground) then\r\n begin\r\n IdSaveDC := SaveDC(HDC(Msg.WParam)); // protect DC against Stock-Objects from Canvas\r\n Canvas := TCanvas.Create;\r\n try\r\n Canvas.Handle := HDC(Msg.WParam);\r\n Msg.Result := Ord(DoEraseBackground(Canvas, Msg.LParam));\r\n finally\r\n Canvas.Handle := 0;\r\n Canvas.Free;\r\n RestoreDC(HDC(Msg.WParam), IdSaveDC);\r\n end;\r\n end\r\n else\r\n inherited WndProc(Msg);\r\n {$IFNDEF DELPHI2007_UP}\r\n WM_PRINTCLIENT, WM_PRINT: // VCL bug fix\r\n begin\r\n IdSaveDC := SaveDC(HDC(Msg.WParam)); // protect DC against changes\r\n try\r\n inherited WndProc(Msg);\r\n finally\r\n RestoreDC(HDC(Msg.WParam), IdSaveDC);\r\n end;\r\n end;\r\n {$ENDIF ~DELPHI2007_UP}\r\n WM_GETDLGCODE:\r\n begin\r\n inherited WndProc(Msg);\r\n DlgCodes := [dcNative] + DlgcToDlgCodes(Msg.Result);\r\n GetDlgCode(DlgCodes);\r\n if not (dcNative in DlgCodes) then\r\n Msg.Result := DlgCodesToDlgc(DlgCodes);\r\n end;\r\n else\r\n inherited WndProc(Msg);\r\n end;\r\n case Msg.Msg of // precheck message to prevent access violations on released controls\r\n CM_MOUSEENTER, CM_MOUSELEAVE, WM_KILLFOCUS, WM_SETFOCUS, WM_NCPAINT:\r\n if DotNetHighlighting then\r\n HandleDotNetHighlighting(Self, Msg, MouseOver, Color);\r\n end;\r\n end;\r\nend;\r\n\r\n//============================================================================\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend." }, { "path": "External/Jedi/Jvcl/run/JvExceptionForm.dfm", "content": "object JvErrorDialog: TJvErrorDialog\r\n Left = 202\r\n Top = 100\r\n ActiveControl = OKBtn\r\n BorderIcons = [biSystemMenu]\r\n BorderStyle = bsDialog\r\n ClientHeight = 252\r\n ClientWidth = 380\r\n Color = clBtnFace\r\n Font.Charset = DEFAULT_CHARSET\r\n Font.Color = clWindowText\r\n Font.Height = -11\r\n Font.Name = 'MS Sans Serif'\r\n Font.Style = []\r\n FormStyle = fsStayOnTop\r\n OldCreateOrder = True\r\n Position = poScreenCenter\r\n OnCreate = FormCreate\r\n OnDestroy = FormDestroy\r\n OnKeyUp = FormKeyUp\r\n OnShow = FormShow\r\n PixelsPerInch = 96\r\n TextHeight = 13\r\n object BasicPanel: TPanel\r\n Left = 0\r\n Top = 0\r\n Width = 288\r\n Height = 108\r\n Align = alClient\r\n BevelOuter = bvNone\r\n TabOrder = 0\r\n object ErrorText: TLabel\r\n Left = 53\r\n Top = 10\r\n Width = 3\r\n Height = 13\r\n Align = alClient\r\n WordWrap = True\r\n end\r\n object IconPanel: TPanel\r\n Left = 0\r\n Top = 10\r\n Width = 53\r\n Height = 88\r\n Align = alLeft\r\n BevelOuter = bvNone\r\n TabOrder = 0\r\n object IconImage: TImage\r\n Left = 8\r\n Top = 1\r\n Width = 34\r\n Height = 34\r\n end\r\n end\r\n object TopPanel: TPanel\r\n Left = 0\r\n Top = 0\r\n Width = 288\r\n Height = 10\r\n Align = alTop\r\n BevelOuter = bvNone\r\n TabOrder = 1\r\n end\r\n object RightPanel: TPanel\r\n Left = 280\r\n Top = 10\r\n Width = 8\r\n Height = 88\r\n Align = alRight\r\n BevelOuter = bvNone\r\n TabOrder = 2\r\n end\r\n object BottomPanel: TPanel\r\n Left = 0\r\n Top = 98\r\n Width = 288\r\n Height = 10\r\n Align = alBottom\r\n BevelOuter = bvNone\r\n TabOrder = 3\r\n end\r\n end\r\n object DetailsPanel: TPanel\r\n Left = 0\r\n Top = 108\r\n Width = 380\r\n Height = 144\r\n Align = alBottom\r\n BevelInner = bvLowered\r\n BevelOuter = bvLowered\r\n TabOrder = 2\r\n object AddrLabel: TJvLabel\r\n Left = 53\r\n Top = 11\r\n Width = 121\r\n Height = 13\r\n Alignment = taRightJustify\r\n AutoSize = False\r\n Caption = 'Error address: '\r\n Transparent = True\r\n AutoOpenURL = False\r\n HotTrackFont.Charset = DEFAULT_CHARSET\r\n HotTrackFont.Color = clWindowText\r\n HotTrackFont.Height = -11\r\n HotTrackFont.Name = 'MS Sans Serif'\r\n HotTrackFont.Style = []\r\n end\r\n object TypeLabel: TJvLabel\r\n Left = 53\r\n Top = 30\r\n Width = 121\r\n Height = 13\r\n Alignment = taRightJustify\r\n AutoSize = False\r\n Caption = 'Error Type: '\r\n Transparent = True\r\n AutoOpenURL = False\r\n HotTrackFont.Charset = DEFAULT_CHARSET\r\n HotTrackFont.Color = clWindowText\r\n HotTrackFont.Height = -11\r\n HotTrackFont.Name = 'MS Sans Serif'\r\n HotTrackFont.Style = []\r\n end\r\n object MessageText: TMemo\r\n Left = 7\r\n Top = 53\r\n Width = 366\r\n Height = 84\r\n TabStop = False\r\n Color = clBtnFace\r\n ReadOnly = True\r\n TabOrder = 0\r\n WantReturns = False\r\n end\r\n object ErrorAddress: TEdit\r\n Left = 180\r\n Top = 8\r\n Width = 192\r\n Height = 21\r\n TabStop = False\r\n ParentColor = True\r\n ReadOnly = True\r\n TabOrder = 1\r\n end\r\n object ErrorType: TEdit\r\n Left = 180\r\n Top = 27\r\n Width = 192\r\n Height = 21\r\n TabStop = False\r\n ParentColor = True\r\n ReadOnly = True\r\n TabOrder = 2\r\n end\r\n end\r\n object ButtonPanel: TPanel\r\n Left = 288\r\n Top = 0\r\n Width = 92\r\n Height = 108\r\n Align = alRight\r\n BevelOuter = bvNone\r\n TabOrder = 1\r\n object DetailsBtn: TButton\r\n Left = 7\r\n Top = 65\r\n Width = 79\r\n Height = 25\r\n TabOrder = 1\r\n OnClick = DetailsBtnClick\r\n end\r\n object OKBtn: TButton\r\n Left = 7\r\n Top = 12\r\n Width = 79\r\n Height = 25\r\n Cancel = True\r\n Default = True\r\n ModalResult = 1\r\n TabOrder = 0\r\n end\r\n end\r\nend\r\n" }, { "path": "External/Jedi/Jvcl/run/JvExceptionForm.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvExcptDlg.PAS, released on 2002-07-04.\r\n\r\nThe Initial Developers of the Original Code are: Fedor Koshevnikov, Igor Pavluk and Serge Korolev\r\nCopyright (c) 1997, 1998 Fedor Koshevnikov, Igor Pavluk and Serge Korolev\r\nCopyright (c) 2001,2002 SGB Software\r\nAll Rights Reserved.\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvExceptionForm.pas 13145 2011-11-02 21:15:19Z ahuser $\r\n\r\nunit JvExceptionForm;\r\n\r\n{$I jvcl.inc}\r\n{$I crossplatform.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows,\r\n Messages, ComObj,\r\n SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls, ExtCtrls,\r\n JvLabel, JvComponent;\r\n\r\ntype\r\n TJvErrorEvent = procedure(Error: Exception; var Msg: string) of object;\r\n\r\n TJvErrorDialog = class(TJvForm)\r\n BasicPanel: TPanel;\r\n ErrorText: TLabel;\r\n IconPanel: TPanel;\r\n IconImage: TImage;\r\n TopPanel: TPanel;\r\n RightPanel: TPanel;\r\n DetailsPanel: TPanel;\r\n MessageText: TMemo;\r\n ErrorAddress: TEdit;\r\n ErrorType: TEdit;\r\n ButtonPanel: TPanel;\r\n DetailsBtn: TButton;\r\n OKBtn: TButton;\r\n AddrLabel: TJvLabel;\r\n TypeLabel: TJvLabel;\r\n BottomPanel: TPanel;\r\n procedure FormCreate(Sender: TObject);\r\n procedure FormDestroy(Sender: TObject);\r\n procedure FormShow(Sender: TObject);\r\n procedure DetailsBtnClick(Sender: TObject);\r\n procedure ErrorInfo(var LogicalAddress: Pointer; var ModuleName: string);\r\n procedure FormKeyUp(Sender: TObject; var Key: Word; Shift: TShiftState);\r\n private\r\n FDetails: Boolean;\r\n FDetailsHeight: Integer;\r\n FExceptObj: Exception;\r\n FPrevOnException: TExceptionEvent;\r\n FOnErrorMsg: TJvErrorEvent;\r\n FHelpFile: string;\r\n procedure WMHelp(var Msg: TWMHelp); message WM_HELP;\r\n procedure GetErrorMsg(var Msg: string);\r\n procedure ShowError;\r\n procedure SetShowDetails(Value: Boolean);\r\n public\r\n procedure ShowException(Sender: TObject; E: Exception);\r\n property OnErrorMsg: TJvErrorEvent read FOnErrorMsg write FOnErrorMsg;\r\n end;\r\n\r\nprocedure JvErrorIntercept;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvExceptionForm.pas $';\r\n Revision: '$Revision: 13145 $';\r\n Date: '$Date: 2011-11-02 22:15:19 +0100 (mer. 02 nov. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n Consts,\r\n JvJCLUtils, JvConsts, JvResources;\r\n\r\n{$R *.dfm}\r\n\r\nvar\r\n JvErrorDialog: TJvErrorDialog = nil;\r\n\r\nprocedure JvErrorIntercept;\r\nbegin\r\n JvErrorDialog.Free;\r\n JvErrorDialog := TJvErrorDialog.Create(Application);\r\nend;\r\n\r\nprocedure TJvErrorDialog.ShowException(Sender: TObject; E: Exception);\r\nbegin\r\n Screen.Cursor := crDefault;\r\n Application.NormalizeTopMosts;\r\n try\r\n if Assigned(FPrevOnException) then\r\n FPrevOnException(Sender, E)\r\n else\r\n if (FExceptObj = nil) and not Application.Terminated then\r\n begin\r\n FExceptObj := E;\r\n try\r\n ShowModal;\r\n finally\r\n FExceptObj := nil;\r\n end;\r\n end\r\n else\r\n begin\r\n Application.ShowException(E);\r\n end;\r\n except\r\n { ignore any exceptions }\r\n end;\r\n Application.RestoreTopMosts;\r\nend;\r\n\r\n// (rom) i see no reason for assembler here\r\n\r\nfunction ConvertAddr(Address: Pointer): Pointer; assembler;\r\nasm\r\n TEST EAX,EAX\r\n JE @@1\r\n SUB EAX, $1000\r\n@@1:\r\nend;\r\n\r\n{$IFDEF MSWINDOWS}\r\n{$IFNDEF RTL230_UP}\r\ntype\r\n INT_PTR = Integer;\r\n{$ENDIF ~RTL230_UP}\r\nprocedure TJvErrorDialog.ErrorInfo(var LogicalAddress: Pointer; var ModuleName: string);\r\nvar\r\n Info: TMemoryBasicInformation;\r\n Temp, ModName: array [0..MAX_PATH] of Char;\r\nbegin\r\n VirtualQuery(ExceptAddr, Info, SizeOf(Info));\r\n if (Info.State <> MEM_COMMIT) or\r\n (GetModuleFileName(THandle(Info.AllocationBase), Temp, SizeOf(Temp)) = 0) then\r\n begin\r\n GetModuleFileName(HInstance, Temp, SizeOf(Temp));\r\n LogicalAddress := ConvertAddr(LogicalAddress);\r\n end\r\n else\r\n INT_PTR(LogicalAddress) := INT_PTR(LogicalAddress) - INT_PTR(Info.AllocationBase);\r\n StrLCopy(ModName, AnsiStrRScan(Temp, PathDelim) + 1, SizeOf(ModName) - 1);\r\n ModuleName := StrPas(ModName);\r\nend;\r\n{$ENDIF MSWINDOWS}\r\n{$IFDEF UNIX}\r\nprocedure TJvErrorDialog.ErrorInfo(var LogicalAddress: Pointer; var ModuleName: string);\r\nvar\r\n Temp, ModName: array [0..MAX_PATH] of Char;\r\nbegin\r\n GetModuleFileName(HInstance, Temp, SizeOf(Temp));\r\n LogicalAddress := ConvertAddr(LogicalAddress);\r\n StrLCopy(ModName, AnsiStrRScan(Temp, PathDelim) + 1, SizeOf(ModName) - 1);\r\n ModuleName := StrPas(ModName);\r\nend;\r\n{$ENDIF UNIX}\r\n\r\nprocedure TJvErrorDialog.ShowError;\r\nvar\r\n S, ModuleName: string;\r\n P: Pointer;\r\nbegin\r\n P := ExceptAddr;\r\n ModuleName := '';\r\n ErrorInfo(P, ModuleName);\r\n AddrLabel.Enabled := (P <> nil);\r\n ErrorAddress.Text := Format('%p', [ExceptAddr]);\r\n ErrorType.Text := FExceptObj.ClassName;\r\n TypeLabel.Enabled := ErrorType.Text <> '';\r\n S := Trim(FExceptObj.Message);\r\n if Pos(CrLf, S) = 0 then\r\n S := ReplaceStr(S, Lf, CrLf);\r\n if FExceptObj is EInOutError then\r\n S := Format(RsCodeError, [S, EInOutError(FExceptObj).ErrorCode])\r\n else\r\n if FExceptObj is EOleException then\r\n begin\r\n with EOleException(FExceptObj) do\r\n if (Source <> '') and (AnsiCompareText(S, Trim(Source)) <> 0) then\r\n S := S + CrLf + Trim(Source);\r\n S := Format(RsCodeError, [S, EOleException(FExceptObj).ErrorCode])\r\n end\r\n else\r\n if FExceptObj is EOleSysError then\r\n S := Format(RsCodeError, [S, EOleSysError(FExceptObj).ErrorCode])\r\n else\r\n if FExceptObj is EExternalException then\r\n S := Format(RsCodeError, [S,\r\n EExternalException(FExceptObj).ExceptionRecord^.ExceptionCode])\r\n else\r\n if FExceptObj is EOSError then\r\n S := Format(RsCodeError,\r\n [S, EOSError(FExceptObj).ErrorCode])\r\n else\r\n S := S + '.';\r\n MessageText.Text := Format(RsModuleError, [ModuleName, S]);\r\nend;\r\n\r\nprocedure TJvErrorDialog.SetShowDetails(Value: Boolean);\r\nbegin\r\n DisableAlign;\r\n try\r\n if Value then\r\n begin\r\n DetailsPanel.Height := FDetailsHeight;\r\n ClientHeight := DetailsPanel.Height + BasicPanel.Height;\r\n DetailsBtn.Caption := RsDetailsLeftCaption;\r\n ShowError;\r\n end\r\n else\r\n begin\r\n ClientHeight := BasicPanel.Height;\r\n DetailsPanel.Height := 0;\r\n DetailsBtn.Caption := RsDetailsRightCaption;\r\n end;\r\n DetailsPanel.Enabled := Value;\r\n FDetails := Value;\r\n finally\r\n EnableAlign;\r\n end;\r\nend;\r\n\r\nprocedure TJvErrorDialog.GetErrorMsg(var Msg: string);\r\nvar\r\n I: Integer;\r\nbegin\r\n I := Pos(CrLf, Msg);\r\n if I > 0 then\r\n System.Delete(Msg, I, MaxInt);\r\n if Assigned(FOnErrorMsg) then\r\n try\r\n FOnErrorMsg(FExceptObj, Msg);\r\n except\r\n end;\r\nend;\r\n\r\n\r\nprocedure TJvErrorDialog.WMHelp(var Msg: TWMHelp);\r\nvar\r\n AppHelpFile: string;\r\nbegin\r\n AppHelpFile := Application.HelpFile;\r\n try\r\n if FHelpFile <> '' then\r\n Application.HelpFile := FHelpFile;\r\n inherited;\r\n finally\r\n Application.HelpFile := AppHelpFile;\r\n end;\r\nend;\r\n\r\n\r\nprocedure TJvErrorDialog.FormCreate(Sender: TObject);\r\nbegin\r\n BorderIcons := [biSystemMenu, biHelp];\r\n FDetailsHeight := DetailsPanel.Height;\r\n Icon.Handle := LoadIcon(0, IDI_HAND);\r\n IconImage.Picture.Icon := Icon;\r\n { Load string resources }\r\n Caption := SMsgDlgError;\r\n OKBtn.Caption := SOKButton;\r\n { Set exception handler }\r\n FPrevOnException := Application.OnException;\r\n Application.OnException := ShowException;\r\nend;\r\n\r\nprocedure TJvErrorDialog.FormDestroy(Sender: TObject);\r\nbegin\r\n Application.OnException := FPrevOnException;\r\nend;\r\n\r\nprocedure TJvErrorDialog.FormShow(Sender: TObject);\r\nvar\r\n S: string;\r\n ExStyle: Longint;\r\nbegin\r\n if FExceptObj.HelpContext <> 0 then\r\n HelpContext := FExceptObj.HelpContext\r\n else\r\n HelpContext := THelpContext(0);\r\n if FExceptObj is EOleException then\r\n FHelpFile := EOleException(FExceptObj).HelpFile\r\n else\r\n FHelpFile := '';\r\n ExStyle := GetWindowLong(Handle, GWL_EXSTYLE);\r\n if HelpContext <> 0 then\r\n ExStyle := ExStyle or WS_EX_CONTEXTHELP\r\n else\r\n ExStyle := ExStyle and not WS_EX_CONTEXTHELP;\r\n SetWindowLong(Handle, GWL_EXSTYLE, ExStyle);\r\n S := Trim(FExceptObj.Message) + '.';\r\n GetErrorMsg(S);\r\n ErrorText.Caption := S;\r\n SetShowDetails(False);\r\n DetailsBtn.Enabled := True;\r\nend;\r\n\r\nprocedure TJvErrorDialog.DetailsBtnClick(Sender: TObject);\r\nbegin\r\n SetShowDetails(not FDetails);\r\nend;\r\n\r\nprocedure TJvErrorDialog.FormKeyUp(Sender: TObject; var Key: Word;\r\n Shift: TShiftState);\r\n\r\nvar\r\n Info: THelpInfo;\r\n\r\nbegin\r\n\r\n if (Key = VK_F1) and (HelpContext <> 0) then\r\n begin\r\n with Info do\r\n begin\r\n cbSize := SizeOf(THelpInfo);\r\n iContextType := HELPINFO_WINDOW;\r\n iCtrlId := 0;\r\n hItemHandle := Handle;\r\n dwContextId := HelpContext;\r\n GetCursorPos(MousePos);\r\n end;\r\n Perform(WM_HELP, 0, LPARAM(@Info));\r\n end;\r\n\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvExplorerBar.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvExplorerBar.pas, released on 2010-11-28.\r\n\r\nThe Initial Developers of the Original Code is: Max Evans\r\nCopyright (c) 2009 Max Events\r\nAll Rights Reserved.\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nContributor(s):\r\n Andreas Hausladen (bugfixing, additional features)\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvExplorerBar.pas 13104 2011-09-07 06:50:43Z obones $\r\n\r\nunit JvExplorerBar;\r\n\r\n// ahuser: TODO: All the \"Repaint\" must be changed to Invalidate()\r\n\r\ninterface\r\n\r\n{$I jvcl.inc}\r\n\r\nuses\r\n Windows, Messages, Types,\r\n SysUtils, Classes, Contnrs, Math,\r\n Graphics, Controls, ExtCtrls, Forms, ImgList;\r\n\r\nconst\r\n JvExplorerConstDefaultWidth = 218;\r\n JvExplorerConstDefaultHeight = 300;\r\n JvExplorerConstDefaultItemHeight = 23;\r\n JvExplorerConstYOffset = 8;\r\n JvExplorerConstLineYOffset = 3;\r\n JvExplorerConstIconSide = 32;\r\n JvExplorerConstXOffset = 12;\r\n JvExplorerConstIconOffset = 4;\r\n JvExplorerConstUnknownValue = -1;\r\n JvExplorerConstUnknownRect: TRect = (Left: -1; Top: -1; Right: -1; Bottom: -1);\r\n JvExplorerConstAnimationSpeed = 30; // Timer.Interval\r\n JvExplorerConstAnimatinoCount = 10;\r\n JvExplorerConstScollbarWidth = 17;\r\n JvExplorerConstSkinLeftPartWidth = 5;\r\n JvExplorerConstSkinRightPartWidth = 25;\r\n JvExplorerConstXGap = 3;\r\n\r\ntype\r\n TJvExplorerHotStyle = set of (hsUnderline, hsBold, hsItalic, hsStrikeOut);\r\n //TCheckBoxState = (cbUnchecked, cbChecked, cbGrayed);\r\n TJvExplorerIconSource = (isImageList, isBitmap, isNone);\r\n TJvExplorerGroupState = (gsOpen, gsClosed, gsOpening, gsClosing);\r\n TJvExplorerBarItemStates = (bisNormal, bisSelected, bisHot, bisChecked, bisPushed);\r\n TJvExplorerBarItemState = set of TJvExplorerBarItemStates;\r\n TJvExplorerMouseHotTrackPosition = (mhtTitle, mhtBody, mhtNone, mhtItem);\r\n\r\n TJvExplorerThemeElementRectType = (\r\n terTitleLeft,\r\n terTitleCenter,\r\n terTitleRightUpOff,\r\n terTitleRightUpOn,\r\n terTitleRightDownOff,\r\n terTitleRightDownOn,\r\n terSpecialTitleLeft,\r\n terSpecialTitleCenter,\r\n terSpecialTitleRightUpOff,\r\n terSpecialTitleRightUpOn,\r\n terSpecialTitleRightDownOff,\r\n terSpecialTitleRightDownOn\r\n );\r\n\r\n TJvExplorerTheme = (\r\n etBlue,\r\n etSilver,\r\n etOlive,\r\n etOrange,\r\n etBlueFlat\r\n );\r\n\r\nconst\r\n JvExplorerThemeNames: array[TJvExplorerTheme] of string = (\r\n 'Blue',\r\n 'Silver',\r\n 'Olive',\r\n 'Orange',\r\n 'Blue Flat'\r\n );\r\n\r\ntype\r\n { flickerfree paint box OnPaint event type }\r\n TJvExplorerFFPaintEvent = procedure(Sender: TObject; Buffer: TBitmap) of object;\r\n\r\n { a flickerfree paint box }\r\n TJvExplorerPaintBox = class(TCustomControl)\r\n private\r\n FOnFFPaint: TJvExplorerFFPaintEvent;\r\n FBuffer: TBitmap; // buffered bitmap (filled when Repaint method is called)\r\n FDrawing: Boolean;\r\n FNeedRepaint: Boolean;\r\n FDeformHorz: Extended;\r\n FDeformVert: Extended;\r\n FDeformAlpha: Extended;\r\n FApplyDeform: Boolean;\r\n protected\r\n procedure Paint; override;\r\n procedure Resize; override;\r\n procedure WMEraseBkgnd(var Msg: TWMEraseBkgnd); message WM_ERASEBKGND;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n procedure Repaint; override;\r\n procedure ApplyDeform(Horz, Vert, Alpha: Extended);\r\n procedure NoDeform;\r\n\r\n property OnPaint: TJvExplorerFFPaintEvent read FOnFFPaint write FOnFFPaint;\r\n end;\r\n\r\n TJvExplorerBar = class;\r\n TJvExplorerBarGroupItem = class;\r\n TJvExplorerMenuItemClickEvent = procedure(Sender: TObject; Id: Integer) of object;\r\n TJvExplorerItemClickEvent = procedure(Sender: TObject; Item: TJvExplorerBarGroupItem; ItemIndex, GroupIndex: Integer) of object;\r\n TJvExplorerCustomDrawBarItem = procedure(Sender: TObject; BarItem: TObject; Bitmap: TBitmap; var X, Y, Width: Integer) of object;\r\n TJvExplorerCustomMeasureBarItem = procedure(Sender: TObject; BarItem: TObject; Bitmap: TBitmap; var X, Y, Width: Integer) of object;\r\n\r\n TJvCustomBarItemViewerClass = class of TJvExplorerCustomBarItemViewer;\r\n\r\n TJvExplorerCustomBarItemViewer = class(TObject)\r\n private\r\n FItem: TJvExplorerBarGroupItem;\r\n FShowClientArea: Boolean;\r\n function GetExplorerBar: TJvExplorerBar; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\n protected\r\n procedure DrawCaption(Bitmap: TBitmap; var X, Y: Integer; var aRect: TRect; dwFlags: Integer); virtual;\r\n procedure DrawIcon(Bitmap: TBitmap; var X, Y, Width: Integer); virtual;\r\n\r\n procedure HandleCustomDrawBarItem(BarItem: TObject; Bitmap: TBitmap; var X, Y, Width: Integer);\r\n procedure HandleCustomMeasureBarItem(BarItem: TObject; Bitmap: TBitmap; var X, Y, Width: Integer);\r\n public\r\n constructor Create(AItem: TJvExplorerBarGroupItem); virtual;\r\n procedure Draw(Bitmap: TBitmap; var X, Y, Width: Integer); virtual;\r\n procedure Measure(Bitmap: TBitmap; var X, Y, Width: Integer); virtual;\r\n\r\n property Item: TJvExplorerBarGroupItem read FItem;\r\n property ExplorerBar: TJvExplorerBar read GetExplorerBar;\r\n property ShowClientArea: Boolean read FShowClientArea write FShowClientArea;\r\n end;\r\n\r\n TJvDefaultBarItemViewer = class(TJvExplorerCustomBarItemViewer)\r\n public\r\n procedure Draw(Bitmap: TBitmap; var X, Y, Width: Integer); override;\r\n procedure Measure(Bitmap: TBitmap; var X, Y, Width: Integer); override;\r\n end;\r\n\r\n TJvExplorerBarGroup = class;\r\n\r\n { an item - generic class for all items }\r\n TJvExplorerBarGroupItem = class(TComponent)\r\n private\r\n FHeight: Integer;\r\n FIcon: TBitmap;\r\n FIconIndex: Integer;\r\n FIdentifier: Integer;\r\n FState: TJvExplorerBarItemState;\r\n FHint: string;\r\n FWidth: Integer;\r\n FCaption: string;\r\n FEnabled: Boolean;\r\n FExplorerGroup: TJvExplorerBarGroup;\r\n FIndex: Integer;\r\n FHotTracking: Boolean;\r\n FMouseInControl: Boolean;\r\n FWordWrap: Boolean;\r\n FFontStyle: TFontStyles;\r\n FFontColor: TColor;\r\n FClientAreaRectangle: TRect;\r\n FItemViewer: TJvExplorerCustomBarItemViewer;\r\n FLoadedExplorerBar: TJvExplorerBar;\r\n FLoadedGroupIndex: Integer;\r\n procedure SetHeight(const Value: Integer);\r\n procedure SetIcon(const Value: TBitmap);\r\n procedure SetIconIndex(const Value: Integer);\r\n procedure SetState(const Value: TJvExplorerBarItemState); virtual;\r\n procedure SetCaption(const Value: string);\r\n procedure SetMouseInControl(const Value: Boolean); virtual;\r\n procedure SetFontColor(const Value: TColor);\r\n procedure SetWordWrap(const Value: Boolean);\r\n function GetItemRectangle: TRect;\r\n\r\n function GetBarItemViewer: TJvExplorerCustomBarItemViewer;\r\n procedure Draw(Bitmap: TBitmap; var X, Y, Width: Integer);\r\n procedure Measure(Bitmap: TBitmap; var X, Y, Width: Integer);\r\n procedure SetFontStyle(const Value: TFontStyles);\r\n protected\r\n procedure SetEnabled(const Value: Boolean); virtual;\r\n procedure MouseDown(Sender: TObject; X, Y: Integer); virtual;\r\n\r\n function IsEnabled: Boolean; virtual;\r\n procedure HandleItemClick;\r\n\r\n function CreateBarItemViewer: TJvExplorerCustomBarItemViewer; virtual; abstract; // ahuser: AItem parameter not needed, always Self ???\r\n procedure NotifyPaint;\r\n procedure DefineProperties(Filer: TFiler); override;\r\n procedure Loaded; override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n\r\n procedure ItemClick; virtual;\r\n property MouseInControl: Boolean read FMouseInControl write SetMouseInControl;\r\n property ExplorerGroup: TJvExplorerBarGroup read FExplorerGroup;\r\n property Height: Integer read FHeight write SetHeight;\r\n property Width: Integer read FWidth write FWidth;\r\n property Icon: TBitmap read FIcon write SetIcon;\r\n property IconIndex: Integer read FIconIndex write SetIconIndex;\r\n property Identifier: Integer read FIdentifier write FIdentifier;\r\n property State: TJvExplorerBarItemState read FState write SetState;\r\n property Hint: string read FHint write FHint;\r\n property Caption: string read FCaption write SetCaption;\r\n property Enabled: Boolean read FEnabled write SetEnabled;\r\n property Index: Integer read FIndex write FIndex;\r\n property HotTracking: Boolean read FHotTracking write FHotTracking;\r\n property WordWrap: Boolean read FWordWrap write SetWordWrap;\r\n property FontColor: TColor read FFontColor write SetFontColor;\r\n property FontStyle: TFontStyles read FFontStyle write SetFontStyle;\r\n property ItemRectangle: TRect read GetItemRectangle;\r\n\r\n property ClientAreaRectangle: TRect read FClientAreaRectangle write FClientAreaRectangle; // written by ExplorerBar.Items\r\n end;\r\n\r\n TJvExplorerBarGroupItems = class(TComponentList)\r\n private\r\n FGroup: TJvExplorerBarGroup;\r\n function GetItem(Index: Integer): TJvExplorerBarGroupItem;\r\n public\r\n constructor Create(AGroup: TJvExplorerBarGroup);\r\n function Add(AItem: TJvExplorerBarGroupItem): TJvExplorerBarGroupItem;\r\n function Remove(AItem: TJvExplorerBarGroupItem): Integer;\r\n function IndexOf(AItem: TJvExplorerBarGroupItem): Integer;\r\n\r\n property Items[Index: Integer]: TJvExplorerBarGroupItem read GetItem; default;\r\n property Group: TJvExplorerBarGroup read FGroup;\r\n end;\r\n\r\n { a group of items - clickable }\r\n TJvExplorerBarGroup = class(TCollectionItem)\r\n private\r\n FAnimStep: Integer;\r\n FNbSteps: Integer;\r\n FDestHeight: Integer;\r\n FShownHeight: Integer;\r\n FBackgroundImage: TBitmap;\r\n FGroupIconIndex: Integer;\r\n FItems: TJvExplorerBarGroupItems;\r\n FSpecialGroup: Boolean;\r\n FState: TJvExplorerGroupState;\r\n FTimer: TTimer;\r\n FTitle: string;\r\n FTitleRect: TRect;\r\n FBodyRect: TRect;\r\n FHeight: Integer;\r\n FWidth: Integer;\r\n procedure Draw(Bitmap: TBitmap; var X, Y: Integer);\r\n procedure Measure(Bitmap: TBitmap; var X, Y: Integer); overload;\r\n procedure Measure; overload;\r\n procedure SetBackgroundImage(Value: TBitmap);\r\n procedure SetGroupIconIndex(Value: Integer);\r\n procedure SetSpecialGroup(Value: Boolean);\r\n procedure SetTitle(Value: string);\r\n procedure Timer(Sender: TObject);\r\n function GetExplorerBar: TJvExplorerBar;\r\n protected\r\n procedure NotifyPaint;\r\n public\r\n constructor Create(Collection: TCollection); override;\r\n destructor Destroy; override;\r\n procedure Assign(Source: TPersistent); override;\r\n\r\n procedure OpenClose;\r\n procedure Collapse;\r\n procedure Expand;\r\n function FindItem(const ATitle, AClassName: string): TJvExplorerBarGroupItem;\r\n property Items: TJvExplorerBarGroupItems read FItems;\r\n property ExplorerBar: TJvExplorerBar read GetExplorerBar;\r\n property Width: Integer read FWidth;\r\n published\r\n property BackgroundImage: TBitmap read FBackgroundImage write SetBackgroundImage;\r\n property SpecialGroup: Boolean read FSpecialGroup write SetSpecialGroup;\r\n property State: TJvExplorerGroupState read FState write FState;\r\n property Title: string read FTitle write SetTitle;\r\n property GroupIconIndex: Integer read FGroupIconIndex write SetGroupIconIndex;\r\n end;\r\n\r\n { a list of groups }\r\n TJvExplorerBarGroups = class(TOwnedCollection)\r\n private\r\n function GetItem(Index: Integer): TJvExplorerBarGroup;\r\n function GetExplorerBar: TJvExplorerBar;\r\n protected\r\n procedure Notify(Item: TCollectionItem; Action: TCollectionNotification); override;\r\n procedure Update(Item: TCollectionItem); override;\r\n public\r\n constructor Create(AOwner: TComponent);\r\n function AddTitle(const ATitle: string; ASpecialGroup: Boolean = False): TJvExplorerBarGroup;\r\n function Add: TJvExplorerBarGroup;\r\n\r\n property ExplorerBar: TJvExplorerBar read GetExplorerBar;\r\n property Items[Index: Integer]: TJvExplorerBarGroup read GetItem; default;\r\n end;\r\n\r\n TJvExplorerBarColourSet = class(TObject)\r\n private\r\n FText: TColor;\r\n FTextHot: TColor;\r\n FBar: TJvExplorerBar;\r\n FGroupBackground: TColor;\r\n FBackground: TColor;\r\n FSpecialText: TColor;\r\n FSpecialTextHot: TColor;\r\n FBorder: TColor;\r\n public\r\n constructor Create(ABar: TJvExplorerBar);\r\n procedure SaveToFile(const AFilename: string);\r\n procedure LoadFromFile(const AFilename, AThemeName: string);\r\n\r\n property TextHot: TColor read FTextHot write FTextHot;\r\n property Text: TColor read FText write FText;\r\n property Border: TColor read FBorder write FBorder;\r\n property Background: TColor read FBackground write FBackground;\r\n property GroupBackground: TColor read FGroupBackground write FGroupBackground;\r\n property SpecialText: TColor read FSpecialText write FSpecialText;\r\n property SpecialTextHot: TColor read FSpecialTextHot write FSpecialTextHot;\r\n property Bar: TJvExplorerBar read FBar;\r\n end;\r\n\r\n TJvExplorerBarThemeElements = class(TObject)\r\n private\r\n FBar: TJvExplorerBar;\r\n FTheme: TJvExplorerTheme;\r\n\r\n FBlueElements: TBitmap;\r\n FOrangeElements: TBitmap;\r\n FOliveElements: TBitmap;\r\n FSilverElements: TBitmap;\r\n FBlueFlatElements: TBitmap;\r\n\r\n FArrowDown: TBitmap;\r\n FArrowUp: TBitmap;\r\n FCheckBoxWidth: Integer;\r\n FCheckBoxHeight: Integer;\r\n\r\n function GetHeight: Integer;\r\n function GetThemeBitmap: TBitmap;\r\n procedure SetTheme(Value: TJvExplorerTheme);\r\n procedure ThemeChanged;\r\n protected\r\n procedure UpdateCheckBoxDimensions;\r\n procedure DrawMask(Dest: TBitmap; X, Y: Integer; Src: TBitmap);\r\n function ElementRect(dwType: TJvExplorerThemeElementRectType): TRect;\r\n\r\n property BlueElements: TBitmap read FBlueElements;\r\n property SilverElements: TBitmap read FSilverElements;\r\n property OliveElements: TBitmap read FOliveElements;\r\n property OrangeElements: TBitmap read FOrangeElements;\r\n property BlueFlatElements: TBitmap read FBlueFlatElements;\r\n property ArrowUp: TBitmap read FArrowUp;\r\n property ArrowDown: TBitmap read FArrowDown;\r\n public\r\n constructor Create(ABar: TJvExplorerBar);\r\n destructor Destroy; override;\r\n\r\n procedure DrawThemedHeader(Bitmap, Skin: TBitmap; X, Y, Width: Integer;\r\n SpecialGroup, Closed, MouseOver: Boolean);\r\n procedure DrawHeader(Bitmap: TBitmap; X, Y, Width: Integer; SpecialGroup, Closed: Boolean;\r\n TextColor: TColor);\r\n procedure BlendFillRect(Dest: TBitmap; aRect: TRect; Alpha: Extended = 1);\r\n\r\n property Bar: TJvExplorerBar read FBar;\r\n property CheckBoxWidth: Integer read FCheckBoxWidth;\r\n property CheckBoxHeight: Integer read FCheckBoxHeight;\r\n property Height: Integer read GetHeight;\r\n property ThemeBitmap: TBitmap read GetThemeBitmap;\r\n property Theme: TJvExplorerTheme read FTheme write SetTheme;\r\n end;\r\n\r\n { a complete bar }\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvExplorerBar = class(TScrollingWinControl)\r\n private\r\n FAnimStep: Integer;\r\n FUpdateLock: Integer;\r\n FAnimate: Boolean;\r\n FGroups: TJvExplorerBarGroups;\r\n FGroupIcons: TCustomImageList;\r\n FGroupIconsChangeLink: TChangeLink;\r\n FHotArea: TObject;\r\n FItemIcons: TCustomImageList;\r\n FItemIconsChangeLink: TChangeLink;\r\n FNeedResize: Boolean;\r\n FOnClick: TJvExplorerMenuItemClickEvent;\r\n FPaintBox: TJvExplorerPaintBox;\r\n FTimer: TTimer;\r\n FOldWidth: Integer;\r\n FGroupsHeight: Integer;\r\n FHoverGroup: TJvExplorerBarGroup;\r\n FColourSet: TJvExplorerBarColourSet;\r\n FMousePosition: TJvExplorerMouseHotTrackPosition;\r\n FOnItemClick: TJvExplorerItemClickEvent;\r\n FThemeElements: TJvExplorerBarThemeElements;\r\n FOnBeforeGroupPaint: TNotifyEvent;\r\n FOnBeforePaint: TNotifyEvent;\r\n FOnAfterDrawGroup: TNotifyEvent;\r\n FOnAfterDraw: TNotifyEvent;\r\n FOnCustomMeasureBarItem: TJvExplorerCustomMeasureBarItem;\r\n FOnCustomDrawBarItem: TJvExplorerCustomDrawBarItem;\r\n procedure CMMouseLeave(var Msg: TMessage); message CM_MOUSELEAVE;\r\n function GetHotItem(X, Y: Integer): TObject;\r\n procedure PaintBuffer(Sender: TObject; Buffer: TBitmap);\r\n procedure PbMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);\r\n procedure PbMouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);\r\n procedure PbMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);\r\n procedure SetGroupIcons(Value: TCustomImageList);\r\n procedure Measure;\r\n procedure SetItemIcons(Value: TCustomImageList);\r\n procedure Timer(Sender: TObject);\r\n function GetThem: TJvExplorerTheme;\r\n procedure SetTheme(const Value: TJvExplorerTheme);\r\n procedure SetGroups(const Value: TJvExplorerBarGroups);\r\n protected\r\n procedure Resize; override;\r\n procedure Loaded; override;\r\n\r\n procedure DoItemClick(Item: TJvExplorerBarGroupItem; ItemIndex, GroupIndex: Integer);\r\n procedure DoCustomDrawBarItem(BarItem: TObject; Bitmap: TBitmap; var X, Y, Width: Integer);\r\n procedure DoCustomMeasureBarItem(BarItem: TObject; Bitmap: TBitmap; var X, Y, Width: Integer);\r\n\r\n procedure GroupIconsChange(Sender: TObject);\r\n procedure ItemIconsChange(Sender: TObject);\r\n procedure Notification(AComponent: TComponent; Operation: TOperation); override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n procedure BeginUpdate;\r\n procedure EndUpdate;\r\n procedure Repaint; override;\r\n procedure ShowAnimate;\r\n procedure FocusToGroup(dwIndex: Integer);\r\n procedure CloseAllGroups;\r\n function IsUpdating: Boolean;\r\n\r\n property HoverGroup: TJvExplorerBarGroup read FHoverGroup;\r\n property ColourSet: TJvExplorerBarColourSet read FColourSet;\r\n property MousePosition: TJvExplorerMouseHotTrackPosition read FMousePosition;\r\n property HotArea: TObject read FHotArea write FHotArea; // written by ExplorerBar.Items\r\n property ThemeElements: TJvExplorerBarThemeElements read FThemeElements;\r\n published\r\n property Animate: Boolean read FAnimate write FAnimate;\r\n property GroupIcons: TCustomImageList read FGroupIcons write SetGroupIcons;\r\n property ItemIcons: TCustomImageList read FItemIcons write SetItemIcons;\r\n property OnMenuItemClick: TJvExplorerMenuItemClickEvent read FOnClick write FOnClick;\r\n property OnItemClick: TJvExplorerItemClickEvent read FOnItemClick write FOnItemClick;\r\n property OnBeforeDrawGroup: TNotifyEvent read FOnBeforeGroupPaint write FOnBeforeGroupPaint;\r\n property OnBeforeDraw: TNotifyEvent read FOnBeforePaint write FOnBeforePaint;\r\n property OnAfterDraw: TNotifyEvent read FOnAfterDraw write FOnAfterDraw;\r\n property OnAfterDrawGroup: TNotifyEvent read FOnAfterDrawGroup write FOnAfterDrawGroup;\r\n property OnCustomDrawBarItem: TJvExplorerCustomDrawBarItem read FOnCustomDrawBarItem write FOnCustomDrawBarItem;\r\n property OnCustomMeasureBarItem: TJvExplorerCustomMeasureBarItem read FOnCustomMeasureBarItem write FOnCustomMeasureBarItem;\r\n property Groups: TJvExplorerBarGroups read FGroups write SetGroups;\r\n property Theme: TJvExplorerTheme read GetThem write SetTheme default etBlue;\r\n property Align;\r\n property Anchors;\r\n {$IFDEF COMPILER14_UP}\r\n property DoubleBuffered;\r\n property ParentDoubleBuffered;\r\n {$ENDIF COMPILER14_UP}\r\n property Constraints;\r\n property Enabled;\r\n property Font;\r\n property ParentFont;\r\n property PopupMenu;\r\n property ShowHint;\r\n property TabOrder;\r\n property Visible;\r\n property OnCanResize;\r\n property OnClick;\r\n property OnConstrainedResize;\r\n property OnContextPopup;\r\n property OnDblClick;\r\n property OnEnter;\r\n property OnExit;\r\n property OnGetSiteInfo;\r\n property OnMouseDown;\r\n property OnMouseMove;\r\n property OnMouseUp;\r\n property OnMouseWheel;\r\n property OnMouseWheelDown;\r\n property OnMouseWheelUp;\r\n property OnResize;\r\n property HorzScrollBar;\r\n property VertScrollBar;\r\n end;\r\n\r\ntype\r\n TJvExplorerBarRenderer = class(TObject)\r\n public\r\n class procedure DrawAlpha(Dest: TBitmap; BgColor: TColor; X, Y: Integer;\r\n SrcRect: TRect; Src: TBitmap; Alpha: Extended = 1); {$IFDEF SUPPORTS_STATIC} static; {$ENDIF}\r\n end;\r\n\r\n TJvExplorerBarText = class(TObject)\r\n public\r\n class function Parse(Canvas: TCanvas; var Line: string; MaxWidth: Integer): string; {$IFDEF SUPPORTS_STATIC} static; {$ENDIF}\r\n class function ClipLine(Canvas: TCanvas; const Line: string; MaxWidth: Integer): string; {$IFDEF SUPPORTS_STATIC} static; {$ENDIF}\r\n class function HeightOf(Canvas: TCanvas; const Line: string; MaxWidth: Integer): Integer; {$IFDEF SUPPORTS_STATIC} static; {$ENDIF}\r\n end;\r\n\r\nimplementation\r\n\r\nuses\r\n IniFiles,\r\n JvJVCLUtils;\r\n\r\n{$R JvExplorerBar.res}\r\n\r\n{ resize a bitmap }\r\n\r\nprocedure ResizeBmp(var Src, Dst: TBitmap);\r\nvar\r\n OldStreatchMode: Integer;\r\nbegin\r\n OldStreatchMode := SetStretchBltMode(Dst.Canvas.Handle, HALFTONE);\r\n Dst.Canvas.CopyRect(Dst.Canvas.ClipRect, Src.Canvas, Src.Canvas.ClipRect);\r\n SetStretchBltMode(Dst.Canvas.Handle, OldStreatchMode);\r\nend;\r\n\r\n{ nb of steps to change height from H1 to H2 }\r\n\r\nfunction CalcNbSteps(H1, H2, Incr: Integer): Integer;\r\nvar\r\n NbSteps: Integer;\r\n Buf: Integer;\r\nbegin\r\n NbSteps := 1;\r\n if H1 > H2 then\r\n begin\r\n Buf := H1;\r\n H1 := H2;\r\n H2 := Buf;\r\n end;\r\n while H1 < H2 do\r\n begin\r\n Inc(H1, NbSteps);\r\n Inc(NbSteps, Incr);\r\n end;\r\n Result := NbSteps;\r\nend;\r\n\r\n{ TJvExplorerBarRenderer }\r\n\r\nclass procedure TJvExplorerBarRenderer.DrawAlpha(Dest: TBitmap; BgColor: TColor;\r\n X, Y: Integer; SrcRect: TRect; Src: TBitmap; Alpha: Extended = 1);\r\nvar\r\n I, J: Integer;\r\n RTmp, OutRect: TRect;\r\n PSrc, PDest: PByteArray;\r\n R, G, B: Byte;\r\nbegin\r\n if Alpha >= 1 then // if no alpha blending\r\n Dest.Canvas.CopyRect(Rect(X, Y, X + SrcRect.Right - SrcRect.Left,\r\n Y + SrcRect.Bottom - SrcRect.Top), Src.Canvas, SrcRect)\r\n else\r\n begin\r\n Src.PixelFormat := pf24bit;\r\n Dest.PixelFormat := pf24bit;\r\n RTmp := Rect(Max(0, X), Max(0, Y), Min(Dest.Width - 1, X + SrcRect.Right - SrcRect.Left - 1),\r\n Min(Dest.Height - 1, Y + SrcRect.Bottom - SrcRect.Top - 1));\r\n if IntersectRect(OutRect, RTmp, Dest.Canvas.ClipRect) then\r\n begin\r\n R := GetRValue(BgColor);\r\n G := GetGValue(BgColor);\r\n B := GetBValue(BgColor);\r\n for J := OutRect.Top to OutRect.Bottom do\r\n begin\r\n PSrc := Src.ScanLine[J - Y + SrcRect.Top];\r\n PDest := Dest.ScanLine[J];\r\n for I := OutRect.Left to OutRect.Right do\r\n begin // blending\r\n PDest[I * 3] := Round(((1 - Alpha) * B + Alpha * PSrc[(I - X + SrcRect.Left) * 3]));\r\n PDest[I * 3 + 1] := Round(((1 - Alpha) * G + Alpha * PSrc[(I - X + SrcRect.Left) * 3 + 1]));\r\n PDest[I * 3 + 2] := Round(((1 - Alpha) * R + Alpha * PSrc[(I - X + SrcRect.Left) * 3 + 2]));\r\n end;\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\n{ TJvExplorerBarText }\r\n\r\nclass function TJvExplorerBarText.HeightOf(Canvas: TCanvas; const Line: string; MaxWidth: Integer): Integer;\r\nvar\r\n R: TRect;\r\nbegin\r\n SetRect(R, 0, 0, MaxWidth, MaxWidth);\r\n DrawText(Canvas.Handle, PChar(Line), Length(Line), R,\r\n DT_CALCRECT or DT_WORDBREAK or DT_EDITCONTROL or DT_TOP or DT_WORD_ELLIPSIS or DT_MODIFYSTRING);\r\n Result := R.Bottom; // + Canvas.TextHeight('A');\r\nend;\r\n\r\nclass function TJvExplorerBarText.Parse(Canvas: TCanvas; var Line: string; MaxWidth: Integer): string;\r\nvar // parse a line to fit in a specified width\r\n I, Len: Integer;\r\n Word: string;\r\n Stop: Boolean;\r\nbegin\r\n Result := '';\r\n Stop := False;\r\n while not Stop and (Line <> '') do\r\n begin\r\n I := 1;\r\n Len := Length(Line);\r\n while (I <= Len) and (Line[I] <> ' ') do\r\n Inc(I);\r\n Word := Copy(Line, 1, I);\r\n if Canvas.TextWidth(Result + Word) < MaxWidth then\r\n begin\r\n Line := Copy(Line, I + 1, Length(Line));\r\n Result := Result + Word;\r\n end\r\n else\r\n begin\r\n if Result = '' then\r\n begin\r\n Line := Copy(Line, I + 1, Length(Line));\r\n repeat\r\n Delete(Word, Length(Word), 1);\r\n until (Canvas.TextWidth(Word + '...') < MaxWidth) or (Length(Word) < 2);\r\n Result := Word + '...';\r\n end;\r\n Stop := True;\r\n end;\r\n end;\r\nend;\r\n\r\nclass function TJvExplorerBarText.ClipLine(Canvas: TCanvas; const Line: string; MaxWidth: Integer): string;\r\nbegin\r\n Result := Line;\r\n if Canvas.TextWidth(Line) > MaxWidth then\r\n begin\r\n repeat\r\n System.Delete(Result, Length(Result), 1);\r\n until (Canvas.TextWidth(Result + '...') <= MaxWidth) or\r\n (Length(Result) < 2);\r\n Result := Result + '...';\r\n end;\r\nend;\r\n\r\n{ TFlickerFreePaintBox }\r\n\r\nconstructor TJvExplorerPaintBox.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n TabStop := False;\r\n FBuffer := TBitmap.Create;\r\n FBuffer.Width := Width;\r\n FBuffer.Height := Height;\r\n FBuffer.PixelFormat := pf24bit;\r\n FBuffer.Canvas.Brush.Color := Color;\r\n FNeedRepaint := True;\r\n FDrawing := False;\r\nend;\r\n\r\nprocedure TJvExplorerPaintBox.Paint;\r\nvar\r\n Bmp: TBitmap;\r\nbegin\r\n if FNeedRepaint then\r\n Repaint\r\n else if FApplyDeform then\r\n begin\r\n FDrawing := True;\r\n Bmp := TBitmap.Create;\r\n try\r\n Bmp.PixelFormat := pf24bit;\r\n Bmp.Width := FBuffer.Width;\r\n Bmp.Height := FBuffer.Height;\r\n TJvExplorerBarRenderer.DrawAlpha(Bmp, Color, 0, 0, FBuffer.Canvas.ClipRect, FBuffer, FDeformAlpha);\r\n Canvas.CopyRect(Rect(0, 0, Round(FBuffer.Width * FDeformHorz),\r\n Round(FBuffer.Height * FDeformVert)), Bmp.Canvas, Bmp.Canvas.ClipRect);\r\n Canvas.Brush.Color := Color;\r\n Canvas.FillRect(Rect(Round(FBuffer.Width * FDeformHorz), 0, Width - 1, Height - 1));\r\n Canvas.FillRect(Rect(0, Round(FBuffer.Height * FDeformVert), Width - 1, Height - 1));\r\n finally\r\n Bmp.Free;\r\n FDrawing := False;\r\n end;\r\n end\r\n else\r\n begin\r\n FDrawing := True;\r\n try\r\n Canvas.Draw(0, 0, FBuffer);\r\n finally\r\n FDrawing := False;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvExplorerPaintBox.Resize;\r\nbegin\r\n if FDrawing then\r\n Exit;\r\n FBuffer.Free;\r\n FBuffer := TBitmap.Create;\r\n FBuffer.PixelFormat := pf24bit;\r\n FBuffer.Width := Width;\r\n FBuffer.Height := Height;\r\n FBuffer.Canvas.Brush.Color := Color;\r\n FNeedRepaint := True;\r\n inherited Resize;\r\nend;\r\n\r\nprocedure TJvExplorerPaintBox.WMEraseBkgnd(var Msg: TWMEraseBkgnd);\r\nbegin\r\n Msg.Result := 1;\r\nend;\r\n\r\nprocedure TJvExplorerPaintBox.Repaint;\r\nbegin\r\n FBuffer.Canvas.FillRect(FBuffer.Canvas.ClipRect);\r\n if Assigned(FOnFFPaint) then\r\n FOnFFPaint(Self, FBuffer);\r\n FNeedRepaint := False;\r\n Paint;\r\nend;\r\n\r\nprocedure TJvExplorerPaintBox.ApplyDeform(Horz, Vert, Alpha: Extended);\r\nbegin\r\n FApplyDeform := True;\r\n FDeformHorz := Horz;\r\n FDeformVert := Vert;\r\n FDeformAlpha := Alpha;\r\n Paint;\r\nend;\r\n\r\nprocedure TJvExplorerPaintBox.NoDeform;\r\nbegin\r\n FApplyDeform := False;\r\n Paint;\r\nend;\r\n\r\n{ TJvExplorerBarGroupItem }\r\n\r\nconstructor TJvExplorerBarGroupItem.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FIcon := nil;\r\n FIconIndex := JvExplorerConstUnknownValue;\r\n FIdentifier := JvExplorerConstUnknownValue;\r\n ClientAreaRectangle := JvExplorerConstUnknownRect;\r\n FEnabled := True;\r\n FHeight := JvExplorerConstDefaultItemHeight;\r\n FFontColor := clWindowText;\r\n FFontStyle := [];\r\nend;\r\n\r\nprocedure TJvExplorerBarGroupItem.DefineProperties(Filer: TFiler);\r\nbegin\r\n inherited DefineProperties(Filer);\r\n // ahuser: we need some information to reconstruct the explorer bar in Loaded()\r\n //Filer.DefineProperty('ExplorerBar', ReadExplorerBar, WriteExplorerbar, True);\r\n //Filer.DefineProperty('GroupIndex', ReadGroupIndex, WriteGroupIndex, True);\r\nend;\r\n\r\ndestructor TJvExplorerBarGroupItem.Destroy;\r\nbegin\r\n FIcon.Free;\r\n FItemViewer.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvExplorerBarGroupItem.MouseDown(Sender: TObject; X, Y: Integer);\r\nbegin\r\nend;\r\n\r\nprocedure TJvExplorerBarGroupItem.HandleItemClick;\r\nbegin\r\n ExplorerGroup.ExplorerBar.DoItemClick(Self, Index, ExplorerGroup.Index);\r\nend;\r\n\r\nprocedure TJvExplorerBarGroupItem.Draw(Bitmap: TBitmap; var X, Y, Width: Integer);\r\nbegin\r\n GetBarItemViewer().Draw(Bitmap, X, Y, Width);\r\nend;\r\n\r\nfunction TJvExplorerBarGroupItem.GetBarItemViewer: TJvExplorerCustomBarItemViewer;\r\nbegin\r\n if FItemViewer = nil then\r\n FItemViewer := CreateBarItemViewer();\r\n Result := FItemViewer;\r\nend;\r\n\r\nfunction TJvExplorerBarGroupItem.GetItemRectangle: TRect;\r\nbegin\r\n Result := ClientAreaRectangle;\r\nend;\r\n\r\nprocedure TJvExplorerBarGroupItem.Measure(Bitmap: TBitmap; var X, Y, Width: Integer);\r\nbegin\r\n GetBarItemViewer().Measure(Bitmap, X, Y, Width);\r\nend;\r\n\r\nprocedure TJvExplorerBarGroupItem.NotifyPaint;\r\nbegin\r\n if ExplorerGroup <> nil then\r\n ExplorerGroup.NotifyPaint;\r\nend;\r\n\r\nfunction TJvExplorerBarGroupItem.IsEnabled: Boolean;\r\nbegin\r\n Result := Enabled;\r\nend;\r\n\r\nprocedure TJvExplorerBarGroupItem.ItemClick;\r\nbegin\r\n HandleItemClick;\r\nend;\r\n\r\nprocedure TJvExplorerBarGroupItem.Loaded;\r\nbegin\r\n inherited Loaded;\r\n // ahuser: maybe I should implement them completely different with an own DFM stream\r\n if FLoadedExplorerBar <> nil then\r\n begin\r\n if (FLoadedGroupIndex >= 0) and (FLoadedGroupIndex < FLoadedExplorerBar.Groups.Count) then\r\n FLoadedExplorerBar.Groups[FLoadedGroupIndex].Items.Add(Self);\r\n FLoadedGroupIndex := -1;\r\n FLoadedExplorerBar := nil;\r\n end;\r\nend;\r\n\r\nprocedure TJvExplorerBarGroupItem.SetCaption(const Value: string);\r\nbegin\r\n if Value <> FCaption then\r\n begin\r\n FCaption := Value;\r\n NotifyPaint;\r\n end;\r\nend;\r\n\r\nprocedure TJvExplorerBarGroupItem.SetEnabled(const Value: Boolean);\r\nbegin\r\n if Value <> FEnabled then\r\n begin\r\n FEnabled := Value;\r\n NotifyPaint;\r\n end;\r\nend;\r\n\r\nprocedure TJvExplorerBarGroupItem.SetFontColor(const Value: TColor);\r\nbegin\r\n if Value <> FFontColor then\r\n begin\r\n FFontColor := Value;\r\n NotifyPaint;\r\n end;\r\nend;\r\n\r\nprocedure TJvExplorerBarGroupItem.SetFontStyle(const Value: TFontStyles);\r\nbegin\r\n if Value <> FFontStyle then\r\n begin\r\n FFontStyle := Value;\r\n NotifyPaint;\r\n end;\r\nend;\r\n\r\nprocedure TJvExplorerBarGroupItem.SetHeight(const Value: Integer);\r\nbegin\r\n if Value <> FHeight then\r\n begin\r\n FHeight := Value;\r\n NotifyPaint;\r\n end;\r\nend;\r\n\r\nprocedure TJvExplorerBarGroupItem.SetIcon(const Value: TBitmap);\r\nbegin\r\n if Value <> FIcon then\r\n begin\r\n if Value = nil then\r\n begin\r\n if FIcon <> nil then\r\n begin\r\n FIcon.Free;\r\n FIcon := nil;\r\n end;\r\n end\r\n else\r\n begin\r\n if FIcon = nil then\r\n FIcon := TBitmap.Create;\r\n FIcon.Assign(Value);\r\n end;\r\n NotifyPaint;\r\n end;\r\nend;\r\n\r\nprocedure TJvExplorerBarGroupItem.SetIconIndex(const Value: Integer);\r\nbegin\r\n if Value <> FIconIndex then\r\n begin\r\n FIconIndex := Value;\r\n if ExplorerGroup.ExplorerBar.ItemIcons <> nil then\r\n NotifyPaint;\r\n end;\r\nend;\r\n\r\nprocedure TJvExplorerBarGroupItem.SetMouseInControl(const Value: Boolean);\r\nbegin\r\n FMouseInControl := Value;\r\nend;\r\n\r\nprocedure TJvExplorerBarGroupItem.SetState(const Value: TJvExplorerBarItemState);\r\nbegin\r\n if Value <> FState then\r\n begin\r\n FState := Value;\r\n NotifyPaint;\r\n end;\r\nend;\r\n\r\nprocedure TJvExplorerBarGroupItem.SetWordWrap(const Value: Boolean);\r\nbegin\r\n if Value <> FWordWrap then\r\n begin\r\n FWordWrap := Value;\r\n NotifyPaint;\r\n end;\r\nend;\r\n\r\n{ TJvExplorerBarGroup }\r\n\r\nconstructor TJvExplorerBarGroup.Create(Collection: TCollection);\r\nbegin\r\n inherited Create(Collection);\r\n FItems := TJvExplorerBarGroupItems.Create(Self);\r\n FState := gsOpen;\r\n FTimer := TTimer.Create(nil);\r\n FTimer.Enabled := False;\r\n FTimer.Interval := JvExplorerConstAnimationSpeed;\r\n FTimer.OnTimer := Timer;\r\n FHeight := 25;\r\n FDestHeight := FHeight;\r\n FShownHeight := FHeight;\r\n FWidth := ExplorerBar.ClientWidth - 2 * JvExplorerConstXOffset;\r\n FGroupIconIndex := JvExplorerConstUnknownValue;\r\n FBackgroundImage := nil;\r\nend;\r\n\r\ndestructor TJvExplorerBarGroup.Destroy;\r\nbegin\r\n if ExplorerBar.FHotArea = Self then\r\n ExplorerBar.FHotArea := nil;\r\n FBackgroundImage.Free;\r\n FItems.Free;\r\n FTimer.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvExplorerBarGroup.Draw(Bitmap: TBitmap; var X, Y: Integer);\r\nvar\r\n I: Integer;\r\n BodyRgn: HRGN;\r\n TitleRect: TRect;\r\nbegin\r\n if ExplorerBar.IsUpdating then\r\n Exit;\r\n BodyRgn := CreateRectRgn(X, Y, X + FWidth, Y + JvExplorerConstIconSide);\r\n SelectClipRgn(Bitmap.Canvas.Handle, BodyRgn);\r\n ExplorerBar.ThemeElements.DrawThemedHeader(Bitmap, ExplorerBar.ThemeElements.ThemeBitmap, X, Y, FWidth,\r\n FSpecialGroup, FState in [gsClosed, gsClosing], Self = ExplorerBar.HotArea);\r\n // else\r\n // ExplorerBar.ThemeElements.DrawHeader(Bitmap, X, Y, FWidth, FSpecialGroup, FState in [gsClosed, gsClosing], IfThen(FSpecialGroup, IfThen(Self <> ExplorerBar.FHotArea, ExplorerBar.ColourSet.SpecialText, ExplorerBar.ColourSet.SpecialTextHot), IfThen(Self <> ExplorerBar.FHotArea, ExplorerBar.ColourSet.Text, ExplorerBar.ColourSet.TextHot)));\r\n // draw icon and write title\r\n with Bitmap.Canvas do\r\n begin\r\n Brush.Style := bsClear;\r\n Font.Style := [fsBold];\r\n Font.Color := IfThen(FSpecialGroup, IfThen(Self <> ExplorerBar.FHotArea,\r\n ExplorerBar.ColourSet.SpecialText, ExplorerBar.ColourSet.SpecialTextHot),\r\n IfThen(Self <> ExplorerBar.FHotArea, ExplorerBar.ColourSet.Text,\r\n ExplorerBar.ColourSet.TextHot));\r\n if (FGroupIconIndex <> JvExplorerConstUnknownValue) and (ExplorerBar.FGroupIcons <> nil) then\r\n begin\r\n ExplorerBar.FGroupIcons.Draw(Bitmap.Canvas, X, Y, FGroupIconIndex);\r\n TitleRect := Rect(X + 2 * JvExplorerConstIconOffset + JvExplorerConstIconSide,\r\n Y + JvExplorerConstYOffset + (JvExplorerConstIconSide - JvExplorerConstYOffset - TextHeight('A')) div 2,\r\n X + FWidth - JvExplorerConstSkinRightPartWidth, Y + JvExplorerConstIconSide);\r\n DrawText(Handle, PChar(Title), -1, TitleRect, DT_LEFT or DT_VCENTER or DT_SINGLELINE or\r\n DT_END_ELLIPSIS);\r\n // TextRect(Rect(X, Y, X + FWidth - SKIN_RIGHT_PART_WIDTH, Y + ICON_SIDE), X + 2 * ICON_OFFSET + ICON_SIDE, Y + Y_OFFSET + (ICON_SIDE - Y_OFFSET - TextHeight('A')) div 2, FTitle);\r\n end\r\n else\r\n begin\r\n TitleRect := Rect(X + 2 * JvExplorerConstIconOffset,\r\n Y + JvExplorerConstYOffset + (JvExplorerConstIconSide - JvExplorerConstYOffset - TextHeight('A')) div 2,\r\n X + FWidth - JvExplorerConstSkinRightPartWidth, Y + JvExplorerConstIconSide);\r\n DrawText(Handle, PChar(Title), -1, TitleRect, DT_LEFT or DT_VCENTER or DT_SINGLELINE or\r\n DT_END_ELLIPSIS);\r\n // TextRect(Rect(X, Y, X + FWidth - SKIN_RIGHT_PART_WIDTH, Y + ICON_SIDE), X + 2 * ICON_OFFSET, Y + Y_OFFSET + (ICON_SIDE - Y_OFFSET - TextHeight('A')) div 2, FTitle);\r\n end;\r\n\r\n end;\r\n DeleteObject(BodyRgn);\r\n FTitleRect := Rect(X, Y + JvExplorerConstIconSide - ExplorerBar.ThemeElements.Height,\r\n X + FWidth, Y + JvExplorerConstIconSide);\r\n Inc(Y, JvExplorerConstIconSide);\r\n FBodyRect.TopLeft := Point(X, Y);\r\n FBodyRect.Right := X + FWidth;\r\n if FState <> gsClosed then\r\n begin\r\n BodyRgn := CreateRectRgn(X, Y, X + FWidth, Y + FShownHeight);\r\n try\r\n SelectClipRgn(Bitmap.Canvas.Handle, BodyRgn);\r\n // draw body background\r\n with Bitmap.Canvas do\r\n begin\r\n Brush.Color := ExplorerBar.ColourSet.GroupBackground;\r\n Brush.Style := bsSolid;\r\n FillRect(Bitmap.Canvas.ClipRect);\r\n // draw BgImage\r\n if FBackgroundImage <> nil then\r\n Draw(X + FWidth - FBackgroundImage.Width, Y + FShownHeight - FBackgroundImage.Height, FBackgroundImage);\r\n Pen.Color := ExplorerBar.ColourSet.Border;\r\n Pen.Style := psSolid;\r\n MoveTo(X, Y);\r\n LineTo(X, Y + FShownHeight - 1);\r\n LineTo(X + FWidth - 1, Y + FShownHeight - 1);\r\n LineTo(X + FWidth - 1, Y);\r\n end;\r\n // draw items\r\n if FState in [gsOpening, gsClosing] then\r\n Y := Y - FHeight + FShownHeight;\r\n Inc(Y, JvExplorerConstYOffset);\r\n for I := 0 to FItems.Count - 1 do\r\n try\r\n (FItems[I] as TJvExplorerBarGroupItem).Draw(Bitmap, X, Y, FWidth);\r\n except\r\n end;\r\n Inc(Y, JvExplorerConstYOffset);\r\n\r\n if FState in [gsOpening, gsClosing] then\r\n begin\r\n Bitmap.Canvas.Brush.Color := ExplorerBar.ColourSet.Background;\r\n ExplorerBar.ThemeElements.BlendFillRect(Bitmap, Bitmap.Canvas.ClipRect,\r\n 1 - FShownHeight / FHeight);\r\n end;\r\n finally\r\n DeleteObject(BodyRgn);\r\n end;\r\n end;\r\n FBodyRect.Bottom := Y;\r\n Inc(Y, JvExplorerConstYOffset);\r\nend;\r\n\r\nprocedure TJvExplorerBarGroup.Expand;\r\nbegin\r\n State := gsClosed;\r\n OpenClose;\r\nend;\r\n\r\nfunction TJvExplorerBarGroup.FindItem(const ATitle, AClassName: string): TJvExplorerBarGroupItem;\r\nvar\r\n I: Integer;\r\n Item: TJvExplorerBarGroupItem;\r\nbegin\r\n Result := nil;\r\n for I := 0 to Items.Count - 1 do\r\n begin\r\n Item := Items.GetItem(I);\r\n if (CompareText(Item.ClassName, AClassName) = 0) and\r\n (CompareText(Item.Caption, ATitle) = 0) then\r\n begin\r\n Result := Item;\r\n Break;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJvExplorerBarGroup.GetExplorerBar: TJvExplorerBar;\r\nbegin\r\n Result := TJvExplorerBarGroups(Collection).ExplorerBar;\r\nend;\r\n\r\nprocedure TJvExplorerBarGroup.Measure(Bitmap: TBitmap; var X, Y: Integer);\r\nvar\r\n I, Bottom: Integer;\r\nbegin\r\n if ExplorerBar.IsUpdating then\r\n Exit;\r\n Inc(Y, JvExplorerConstIconSide);\r\n Bottom := Y;\r\n Inc(Bottom, JvExplorerConstYOffset);\r\n for I := 0 to Items.Count - 1 do\r\n begin\r\n Items[I].Measure(Bitmap, X, Bottom, FWidth);\r\n end;\r\n\r\n Inc(Bottom, JvExplorerConstYOffset);\r\n FHeight := Bottom - Y;\r\n if (FShownHeight > FHeight) or (FState = gsOpen) then\r\n FShownHeight := FHeight;\r\n if FState in [gsOpen, gsOpening] then\r\n Y := Bottom;\r\n Inc(Y, JvExplorerConstYOffset);\r\nend;\r\n\r\nprocedure TJvExplorerBarGroup.Measure;\r\nvar\r\n X, Y: Integer;\r\nbegin\r\n X := 0;\r\n Y := 0;\r\n Measure(ExplorerBar.FPaintBox.FBuffer, X, Y);\r\nend;\r\n\r\nprocedure TJvExplorerBarGroup.NotifyPaint;\r\nbegin\r\n if TJvExplorerBarGroups(Collection).UpdateCount = 0 then\r\n ExplorerBar.Repaint;\r\nend;\r\n\r\nprocedure TJvExplorerBarGroup.SetBackgroundImage(Value: TBitmap);\r\nbegin\r\n if Value <> nil then\r\n begin\r\n if FBackgroundImage = nil then\r\n FBackgroundImage := TBitmap.Create;\r\n FBackgroundImage.Assign(Value);\r\n end\r\n else if FBackgroundImage <> nil then\r\n begin\r\n FBackgroundImage.Free;\r\n FBackgroundImage := nil;\r\n end;\r\nend;\r\n\r\nprocedure TJvExplorerBarGroup.SetGroupIconIndex(Value: Integer);\r\nbegin\r\n FGroupIconIndex := Value;\r\n if not ExplorerBar.IsUpdating then\r\n ExplorerBar.Repaint;\r\nend;\r\n\r\nprocedure TJvExplorerBarGroup.SetSpecialGroup(Value: Boolean);\r\nbegin\r\n FSpecialGroup := Value;\r\n if not ExplorerBar.IsUpdating then\r\n ExplorerBar.Repaint;\r\nend;\r\n\r\nprocedure TJvExplorerBarGroup.SetTitle(Value: string);\r\nbegin\r\n FTitle := Value;\r\n if not ExplorerBar.IsUpdating then\r\n ExplorerBar.Repaint;\r\nend;\r\n\r\nprocedure TJvExplorerBarGroup.Timer(Sender: TObject);\r\nbegin\r\n case FState of\r\n gsOpening:\r\n begin\r\n FShownHeight := FShownHeight + FAnimStep;\r\n if FShownHeight > FHeight then\r\n FShownHeight := FHeight;\r\n Dec(FAnimStep, 1 + FHeight div 150);\r\n end;\r\n gsClosing:\r\n begin\r\n FShownHeight := FShownHeight - FAnimStep;\r\n if FShownHeight < 0 then\r\n FShownHeight := 0;\r\n Inc(FAnimStep, 1 + FHeight div 150);\r\n end;\r\n end;\r\n if (FAnimStep >= FNbSteps) or (FAnimStep < 0) then\r\n begin\r\n FShownHeight := FDestHeight;\r\n FTimer.Enabled := False;\r\n if FShownHeight = 0 then\r\n FState := gsClosed\r\n else\r\n FState := gsOpen;\r\n end;\r\n ExplorerBar.Measure;\r\n ExplorerBar.Repaint;\r\nend;\r\n\r\nprocedure TJvExplorerBarGroup.Assign(Source: TPersistent);\r\nvar\r\n Src: TJvExplorerBarGroup;\r\nbegin\r\n if Source is TJvExplorerBarGroup then\r\n begin\r\n Collection.BeginUpdate;\r\n try\r\n Src := TJvExplorerBarGroup(Source);\r\n SetBackgroundImage(Src.BackgroundImage);\r\n SpecialGroup := Src.SpecialGroup;\r\n State := Src.State;\r\n Title := Src.Title;\r\n GroupIconIndex := Src.GroupIconIndex;\r\n finally\r\n Collection.EndUpdate;\r\n end;\r\n end\r\n else\r\n inherited Assign(Source);\r\nend;\r\n\r\nprocedure TJvExplorerBarGroup.Collapse;\r\nbegin\r\n Self.State := gsOpen;\r\n Self.OpenClose;\r\nend;\r\n\r\nprocedure TJvExplorerBarGroup.OpenClose;\r\nvar\r\n DoCalc: Boolean;\r\nbegin\r\n if not ExplorerBar.Animate then\r\n begin\r\n case FState of\r\n gsOpen:\r\n FState := gsClosed;\r\n gsClosed:\r\n FState := gsOpen;\r\n end;\r\n end\r\n else\r\n begin\r\n DoCalc := False;\r\n case FState of\r\n gsOpen:\r\n begin\r\n DoCalc := True;\r\n FDestHeight := 0;\r\n FShownHeight := FHeight;\r\n FState := gsClosing;\r\n FTimer.Enabled := True;\r\n end;\r\n gsClosed:\r\n begin\r\n DoCalc := True;\r\n FDestHeight := FHeight;\r\n FShownHeight := 0;\r\n FState := gsOpening;\r\n FTimer.Enabled := True;\r\n end;\r\n gsOpening:\r\n begin\r\n FDestHeight := 0;\r\n FState := gsClosing;\r\n end;\r\n gsClosing:\r\n begin\r\n FDestHeight := FHeight;\r\n FState := gsOpening;\r\n end;\r\n end;\r\n if FShownHeight > FHeight then\r\n FShownHeight := FHeight;\r\n if DoCalc then\r\n begin\r\n FNbSteps := CalcNbSteps(0, FHeight, 1 + FHeight div 150);\r\n if FState = gsOpening then\r\n FAnimStep := FNbSteps - 1\r\n else\r\n FAnimStep := 0;\r\n end;\r\n end;\r\n ExplorerBar.Measure;\r\n ExplorerBar.Repaint;\r\nend;\r\n\r\n{ TExplorerBarGroups }\r\n\r\nconstructor TJvExplorerBarGroups.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner, TJvExplorerBarGroup);\r\nend;\r\n\r\nfunction TJvExplorerBarGroups.Add: TJvExplorerBarGroup;\r\nbegin\r\n Result := TJvExplorerBarGroup(inherited Add);\r\nend;\r\n\r\nfunction TJvExplorerBarGroups.AddTitle(const ATitle: string; ASpecialGroup: Boolean): TJvExplorerBarGroup;\r\nbegin\r\n Result := Add();\r\n Result.Title := ATitle;\r\n Result.SpecialGroup := ASpecialGroup;\r\n ExplorerBar.FNeedResize := True;\r\nend;\r\n\r\nfunction TJvExplorerBarGroups.GetItem(Index: Integer): TJvExplorerBarGroup;\r\nbegin\r\n Result := TJvExplorerBarGroup(inherited GetItem(Index));\r\nend;\r\n\r\nfunction TJvExplorerBarGroups.GetExplorerBar: TJvExplorerBar;\r\nbegin\r\n Result := TJvExplorerBar(inherited Owner);\r\nend;\r\n\r\nprocedure TJvExplorerBarGroups.Notify(Item: TCollectionItem; Action: TCollectionNotification);\r\nbegin\r\n inherited Notify(Item, Action);\r\n ExplorerBar.FNeedResize := True;\r\nend;\r\n\r\nprocedure TJvExplorerBarGroups.Update(Item: TCollectionItem);\r\nbegin\r\n inherited Update(Item);\r\n ExplorerBar.FNeedResize := True;\r\n ExplorerBar.Repaint;\r\nend;\r\n\r\n{ TJvExplorerBar }\r\n\r\nconstructor TJvExplorerBar.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FColourSet := TJvExplorerBarColourSet.Create(Self);\r\n FThemeElements := TJvExplorerBarThemeElements.Create(Self);\r\n FAnimate := True;\r\n ControlStyle := [csAcceptsControls, csCaptureMouse, csClickEvents, csSetCaption, csDoubleClicks,\r\n csActionClient];\r\n Width := JvExplorerConstDefaultWidth;\r\n FOldWidth := JvExplorerConstDefaultWidth;\r\n Height := JvExplorerConstDefaultHeight;\r\n ParentColor := False;\r\n VertScrollBar.Smooth := True;\r\n VertScrollBar.Tracking := True;\r\n VertScrollBar.ButtonSize := JvExplorerConstScollbarWidth;\r\n VertScrollBar.Visible := True;\r\n HorzScrollBar.Visible := True;\r\n HorzScrollBar.Tracking := True;\r\n HorzScrollBar.Smooth := True;\r\n AutoScroll := True;\r\n FPaintBox := TJvExplorerPaintBox.Create(Self);\r\n FGroups := TJvExplorerBarGroups.Create(Self);\r\n with FPaintBox do\r\n begin\r\n Parent := Self;\r\n SetBounds(0, 0, Self.Width, 1);\r\n Resize;\r\n OnMouseMove := PbMouseMove;\r\n OnMouseUp := PbMouseUp;\r\n OnMouseDown := PbMouseDown;\r\n OnPaint := PaintBuffer;\r\n end;\r\n FGroupIcons := nil;\r\n FItemIcons := nil;\r\n FNeedResize := True;\r\n FHotArea := nil;\r\n\r\n FGroupIconsChangeLink := TChangeLink.Create;\r\n FGroupIconsChangeLink.OnChange := GroupIconsChange;\r\n FItemIconsChangeLink := TChangeLink.Create;\r\n FItemIconsChangeLink.OnChange := ItemIconsChange;\r\n\r\n FTimer := TTimer.Create(nil);\r\n FTimer.Enabled := False;\r\n FTimer.OnTimer := Timer;\r\n FTimer.Interval := JvExplorerConstAnimationSpeed;\r\nend;\r\n\r\ndestructor TJvExplorerBar.Destroy;\r\nbegin\r\n SetGroupIcons(nil);\r\n SetItemIcons(nil);\r\n FItemIconsChangeLink.Free;\r\n FGroupIconsChangeLink.Free;\r\n\r\n FPaintBox.Free;\r\n FGroups.Free;\r\n FTimer.Free;\r\n FColourSet.Free;\r\n FThemeElements.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvExplorerBar.GroupIconsChange(Sender: TObject);\r\nbegin\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvExplorerBar.ItemIconsChange(Sender: TObject);\r\nbegin\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvExplorerBar.Loaded;\r\nbegin\r\n inherited Loaded;\r\n FNeedResize := True;\r\n Repaint;\r\nend;\r\n\r\nprocedure TJvExplorerBar.CMMouseLeave(var Msg: TMessage);\r\nvar\r\n OldHotArea: TObject;\r\n DrawX, DrawY: Integer;\r\nbegin\r\n if (HotArea <> nil) then\r\n begin\r\n OldHotArea := HotArea;\r\n FHotArea := nil;\r\n if (OldHotArea <> nil) and (OldHotArea is TJvExplorerBarGroupItem) then\r\n OldHotArea := (OldHotArea as TJvExplorerBarGroupItem).ExplorerGroup;\r\n if OldHotArea <> nil then\r\n try\r\n with OldHotArea as TJvExplorerBarGroup do\r\n begin\r\n DrawX := FTitleRect.Left;\r\n DrawY := FTitleRect.Top - JvExplorerConstIconSide + ThemeElements.Height;\r\n Draw(FPaintBox.FBuffer, DrawX, DrawY);\r\n end;\r\n except\r\n end;\r\n FPaintBox.Paint;\r\n end;\r\nend;\r\n\r\nfunction TJvExplorerBar.GetHotItem(X, Y: Integer): TObject;\r\nvar\r\n I, J: Integer;\r\n Found: Boolean;\r\nbegin\r\n Result := nil;\r\n FMousePosition := mhtNone;\r\n Found := False;\r\n I := 0;\r\n while not Found and (I < Groups.Count) do\r\n with Groups[I] do\r\n begin\r\n if PtInRect(FTitleRect, Point(X, Y)) then\r\n begin\r\n FMousePosition := mhtTitle;\r\n Result := Groups[I];\r\n Found := True;\r\n end\r\n else\r\n if PtInRect(FBodyRect, Point(X, Y)) then\r\n begin\r\n J := 0;\r\n FMousePosition := mhtBody;\r\n while not Found and (J < Items.Count) do\r\n begin\r\n if (PtInRect((Items[J]).ClientAreaRectangle, Point(X, Y))) and (Items[J].HotTracking) and\r\n (Items[J].Enabled) then\r\n begin\r\n FMousePosition := mhtItem;\r\n Result := Items[J];\r\n Items[J].State := [bisHot];\r\n Items[J].MouseInControl := True;\r\n Found := True;\r\n end;\r\n Inc(J);\r\n end;\r\n end;\r\n Inc(I);\r\n end;\r\nend;\r\n\r\nprocedure TJvExplorerBar.PbMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);\r\nvar\r\n NewHotArea: TObject;\r\n OldHotArea: TObject;\r\n DrawX, DrawY: Integer;\r\nbegin\r\n if Shift <> [] then\r\n Exit;\r\n if not ((HotArea <> nil) and\r\n ((FHotArea is TJvExplorerBarGroupItem) and PtInRect(TJvExplorerBarGroupItem(FHotArea).ClientAreaRectangle, Point(X, Y))) or\r\n ((FHotArea is TJvExplorerBarGroup) and PtInRect(TJvExplorerBarGroup(FHotArea).FTitleRect, Point(X, Y)))\r\n ) then\r\n begin\r\n NewHotArea := GetHotItem(X, Y);\r\n if NewHotArea <> HotArea then\r\n begin\r\n if (HotArea is TJvExplorerBarGroupItem) then\r\n begin\r\n TJvExplorerBarGroupItem(HotArea).State := [];\r\n TJvExplorerBarGroupItem(HotArea).MouseInControl := False;\r\n end;\r\n\r\n OldHotArea := HotArea;\r\n FHotArea := NewHotArea;\r\n if (MousePosition = mhtItem) then\r\n begin\r\n if (HotArea as TJvExplorerBarGroupItem).Hint <> '' then\r\n begin\r\n ShowHint := True;\r\n Hint := (FHotArea as TJvExplorerBarGroupItem).Hint;\r\n end;\r\n end\r\n else\r\n ShowHint := False;\r\n\r\n if (OldHotArea <> nil) and (OldHotArea is TJvExplorerBarGroupItem) then\r\n OldHotArea := (OldHotArea as TJvExplorerBarGroupItem).ExplorerGroup;\r\n if (NewHotArea <> nil) and (NewHotArea is TJvExplorerBarGroupItem) then\r\n NewHotArea := (NewHotArea as TJvExplorerBarGroupItem).ExplorerGroup;\r\n if OldHotArea <> nil then\r\n with OldHotArea as TJvExplorerBarGroup do\r\n begin\r\n DrawX := FTitleRect.Left;\r\n DrawY := FTitleRect.Top - JvExplorerConstIconSide + ThemeElements.Height;\r\n Draw(FPaintBox.FBuffer, DrawX, DrawY);\r\n end;\r\n if NewHotArea <> nil then\r\n with NewHotArea as TJvExplorerBarGroup do\r\n begin\r\n DrawX := FTitleRect.Left;\r\n DrawY := FTitleRect.Top - JvExplorerConstIconSide + ThemeElements.Height;\r\n Draw(FPaintBox.FBuffer, DrawX, DrawY);\r\n end;\r\n if FHotArea = nil then\r\n (Sender as TJvExplorerPaintBox).Cursor := crDefault\r\n else\r\n (Sender as TJvExplorerPaintBox).Cursor := crHandPoint;\r\n FPaintBox.Paint;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvExplorerBar.PbMouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState;\r\n X, Y: Integer);\r\nvar\r\n NewHotArea: TObject;\r\nbegin\r\n NewHotArea := GetHotItem(X, Y);\r\n if (NewHotArea = HotArea) and (NewHotArea <> nil) then\r\n begin\r\n // if (NewHotArea is TExplorerBarGroupItem) then\r\n // begin\r\n // (NewHotArea as TExplorerBarGroupItem).OnItemClick(Self);\r\n // if Assigned(FOnClick) then fOnClick(Self, (NewHotArea as TExplorerBarGroupItem).Identifier);\r\n\r\n if NewHotArea is TJvExplorerBarGroup then\r\n TJvExplorerBarGroup(NewHotArea).OpenClose;\r\n end;\r\n\r\n if HotArea = nil then\r\n (Sender as TJvExplorerPaintBox).Cursor := crDefault\r\n else\r\n (Sender as TJvExplorerPaintBox).Cursor := crHandPoint;\r\n Repaint;\r\nend;\r\n\r\nprocedure TJvExplorerBar.PbMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState;\r\n X, Y: Integer);\r\nvar\r\n NewHotArea: TObject;\r\nbegin\r\n NewHotArea := GetHotItem(X, Y);\r\n if (NewHotArea = HotArea) and (NewHotArea <> nil) then\r\n if (NewHotArea is TJvExplorerBarGroupItem) then\r\n begin\r\n try\r\n if TJvExplorerBarGroupItem(NewHotArea).IsEnabled then\r\n begin\r\n TJvExplorerBarGroupItem(NewHotArea).MouseDown(Sender, X, Y);\r\n TJvExplorerBarGroupItem(NewHotArea).ItemClick;\r\n if Assigned(FOnClick) then\r\n FOnClick(Self, TJvExplorerBarGroupItem(NewHotArea).Identifier);\r\n end;\r\n except\r\n end;\r\n end;\r\n\r\n if HotArea = nil then\r\n (Sender as TJvExplorerPaintBox).Cursor := crDefault\r\n else\r\n (Sender as TJvExplorerPaintBox).Cursor := crHandPoint;\r\n Repaint;\r\nend;\r\n\r\nprocedure TJvExplorerBar.PaintBuffer(Sender: TObject; Buffer: TBitmap);\r\nvar\r\n I: Integer;\r\n X, Y: Integer;\r\nbegin\r\n if IsUpdating then\r\n Exit;\r\n Buffer.Canvas.Brush.Color := ColourSet.Background;\r\n Buffer.Canvas.Font.Name := 'Tahoma';\r\n Buffer.Canvas.FillRect(Buffer.Canvas.ClipRect);\r\n X := JvExplorerConstXOffset;\r\n Y := JvExplorerConstYOffset;\r\n for I := 0 to FGroups.Count - 1 do\r\n begin\r\n if Assigned(OnBeforeDrawGroup) then\r\n OnBeforeDrawGroup(FGroups[I]);\r\n FGroups[I].Draw(Buffer, X, Y);\r\n if Assigned(OnAfterDrawGroup) then\r\n OnAfterDrawGroup(FGroups[I]);\r\n end;\r\nend;\r\n\r\nprocedure TJvExplorerBar.SetGroupIcons(Value: TCustomImageList);\r\nbegin\r\n ReplaceImageListReference(Self, Value, FGroupIcons, FGroupIconsChangeLink);\r\nend;\r\n\r\nprocedure TJvExplorerBar.SetGroups(const Value: TJvExplorerBarGroups);\r\nbegin\r\n if Value <> FGroups then\r\n FGroups.Assign(Value);\r\nend;\r\n\r\nprocedure TJvExplorerBar.SetItemIcons(Value: TCustomImageList);\r\nbegin\r\n ReplaceImageListReference(Self, Value, FItemIcons, FItemIconsChangeLink);\r\nend;\r\n\r\nfunction TJvExplorerBar.GetThem: TJvExplorerTheme;\r\nbegin\r\n Result := ThemeElements.Theme;\r\nend;\r\n\r\nprocedure TJvExplorerBar.SetTheme(const Value: TJvExplorerTheme);\r\nbegin\r\n if Value <> ThemeElements.Theme then\r\n begin\r\n ThemeElements.Theme := Value;\r\n Repaint;\r\n end;\r\nend;\r\n\r\nprocedure TJvExplorerBar.Notification(AComponent: TComponent; Operation: TOperation);\r\nbegin\r\n inherited Notification(AComponent, Operation);\r\n if Operation = opRemove then\r\n begin\r\n if AComponent = GroupIcons then\r\n GroupIcons := nil;\r\n if AComponent = ItemIcons then\r\n ItemIcons := nil;\r\n end;\r\nend;\r\n\r\nprocedure TJvExplorerBar.Measure;\r\nvar\r\n I: Integer;\r\n X, Y: Integer;\r\n Closing: Boolean;\r\n NewPbHeight: Integer;\r\nbegin\r\n // resize FpaintBox & FpaintBox.Buffer\r\n Y := JvExplorerConstYOffset;\r\n X := JvExplorerConstXOffset;\r\n Closing := False;\r\n for I := 0 to FGroups.Count - 1 do\r\n with FGroups[I] do\r\n begin\r\n Measure(FPaintBox.FBuffer, X, Y);\r\n if State = gsClosing then\r\n Closing := True;\r\n end;\r\n if Closing and (Y < ClientHeight - 1) then\r\n NewPbHeight := ClientHeight - 1\r\n else\r\n NewPbHeight := Y;\r\n if NewPbHeight <> FPaintBox.Height then\r\n begin\r\n FPaintBox.Height := NewPbHeight;\r\n FPaintBox.Resize;\r\n end;\r\n FGroupsHeight := Y;\r\n Resize;\r\nend;\r\n\r\nprocedure TJvExplorerBar.Timer(Sender: TObject);\r\nbegin\r\n Inc(FAnimStep);\r\n if FAnimStep >= JvExplorerConstAnimatinoCount then\r\n begin\r\n FTimer.Enabled := False;\r\n FPaintBox.NoDeform;\r\n end\r\n else\r\n FPaintBox.ApplyDeform(1, FAnimStep / JvExplorerConstAnimatinoCount,\r\n (FAnimStep / JvExplorerConstAnimatinoCount) * (FAnimStep / JvExplorerConstAnimatinoCount));\r\n FPaintBox.Paint;\r\nend;\r\n\r\nprocedure TJvExplorerBar.Resize;\r\nvar\r\n I: Integer;\r\n NeedRefresh: Boolean;\r\nbegin\r\n inherited Resize;\r\n NeedRefresh := False;\r\n if (ClientHeight >= FGroupsHeight) and VertScrollBar.Visible then\r\n begin\r\n VertScrollBar.Visible := False;\r\n NeedRefresh := True;\r\n end\r\n else if (ClientHeight < FGroupsHeight) and not VertScrollBar.Visible then\r\n begin\r\n VertScrollBar.Visible := True;\r\n NeedRefresh := True;\r\n end;\r\n if Width <> FOldWidth then\r\n begin\r\n FOldWidth := Width;\r\n FPaintBox.Width := Width;\r\n FPaintBox.Resize;\r\n NeedRefresh := True;\r\n end;\r\n if NeedRefresh then\r\n begin\r\n for I := 0 to FGroups.Count - 1 do\r\n begin\r\n FGroups[I].FWidth := ClientWidth - 2 * JvExplorerConstXOffset;\r\n FGroups[I].Measure;\r\n end;\r\n Measure;\r\n Repaint;\r\n end;\r\nend;\r\n\r\nprocedure TJvExplorerBar.DoCustomDrawBarItem(BarItem: TObject; Bitmap: TBitmap;\r\n var X, Y, Width: Integer);\r\nbegin\r\n if Assigned(FOnCustomDrawBarItem) then\r\n FOnCustomDrawBarItem(Self, BarItem, Bitmap, X, Y, Width);\r\nend;\r\n\r\nprocedure TJvExplorerBar.DoCustomMeasureBarItem(BarItem: TObject; Bitmap: TBitmap;\r\n var X, Y, Width: Integer);\r\nbegin\r\n if Assigned(FOnCustomMeasureBarItem) then\r\n FOnCustomMeasureBarItem(Self, BarItem, Bitmap, X, Y, Width);\r\nend;\r\n\r\nprocedure TJvExplorerBar.DoItemClick(Item: TJvExplorerBarGroupItem; ItemIndex, GroupIndex: Integer);\r\nbegin\r\n if Assigned(FOnItemClick) then\r\n FOnItemClick(Self, Item, ItemIndex, GroupIndex);\r\nend;\r\n\r\nprocedure TJvExplorerBar.BeginUpdate;\r\nbegin\r\n Inc(FUpdateLock);\r\nend;\r\n\r\nprocedure TJvExplorerBar.EndUpdate;\r\nbegin\r\n Dec(FUpdateLock);\r\n if FUpdateLock = 0 then\r\n Measure;\r\nend;\r\n\r\nfunction TJvExplorerBar.IsUpdating: Boolean;\r\nbegin\r\n Result := FUpdateLock > 0;\r\nend;\r\n\r\nprocedure TJvExplorerBar.Repaint;\r\nbegin\r\n if IsUpdating or ([csDestroying, csLoading] * ComponentState <> []) or not HandleAllocated or not Visible then\r\n Exit;\r\n inherited Repaint;\r\n if Assigned(OnBeforeDraw) then\r\n OnBeforeDraw(Self);\r\n if FNeedResize then\r\n begin\r\n Measure;\r\n FNeedResize := False;\r\n end;\r\n FPaintBox.Repaint;\r\n if Assigned(OnAfterDraw) then\r\n OnAfterDraw(Self);\r\nend;\r\n\r\nprocedure TJvExplorerBar.ShowAnimate;\r\nbegin\r\n if IsUpdating or not Animate then\r\n Exit;\r\n FAnimStep := 0;\r\n if FNeedResize then\r\n begin\r\n Measure;\r\n FNeedResize := False;\r\n end;\r\n FTimer.Enabled := True;\r\n Timer(FTimer);\r\nend;\r\n\r\nprocedure TJvExplorerBar.FocusToGroup(dwIndex: Integer);\r\nbegin\r\n CloseAllGroups;\r\n BeginUpdate;\r\n Groups[dwIndex].OpenClose;\r\n EndUpdate;\r\nend;\r\n\r\nprocedure TJvExplorerBar.CloseAllGroups;\r\nvar\r\n I: Integer;\r\nbegin\r\n BeginUpdate;\r\n for I := 0 to Groups.Count - 1 do\r\n begin\r\n if Groups[I].State = gsOpen then\r\n Groups[I].OpenClose;\r\n end;\r\n EndUpdate;\r\nend;\r\n\r\n{ TExplorerBarGroupItems }\r\n\r\nfunction TJvExplorerBarGroupItems.Add(AItem: TJvExplorerBarGroupItem): TJvExplorerBarGroupItem;\r\nvar\r\n Index: Integer;\r\nbegin\r\n Index := inherited Add(AItem);\r\n AItem.FExplorerGroup := Group;\r\n AItem.Index := Index;\r\n Result := AItem;\r\n Group.ExplorerBar.FNeedResize := True;\r\nend;\r\n\r\nconstructor TJvExplorerBarGroupItems.Create(AGroup: TJvExplorerBarGroup);\r\nbegin\r\n inherited Create(True);\r\n FGroup := AGroup;\r\nend;\r\n\r\nfunction TJvExplorerBarGroupItems.GetItem(Index: Integer): TJvExplorerBarGroupItem;\r\nbegin\r\n Result := TJvExplorerBarGroupItem(inherited Items[Index]);\r\nend;\r\n\r\nfunction TJvExplorerBarGroupItems.IndexOf(AItem: TJvExplorerBarGroupItem): Integer;\r\nbegin\r\n Result := inherited IndexOf(AItem);\r\nend;\r\n\r\nfunction TJvExplorerBarGroupItems.Remove(AItem: TJvExplorerBarGroupItem): Integer;\r\nbegin\r\n Result := inherited Remove(AItem);\r\nend;\r\n\r\n{ TDefaultBarItemView }\r\n\r\nprocedure TJvDefaultBarItemViewer.Draw(Bitmap: TBitmap; var X, Y, Width: Integer);\r\nbegin\r\nend;\r\n\r\nprocedure TJvDefaultBarItemViewer.Measure(Bitmap: TBitmap; var X, Y, Width: Integer);\r\nbegin\r\nend;\r\n\r\n{ TCustomBarItemViewer }\r\n\r\nconstructor TJvExplorerCustomBarItemViewer.Create(AItem: TJvExplorerBarGroupItem);\r\nbegin\r\n inherited Create;\r\n FItem := AItem;\r\n // FShowClientArea:= True;\r\nend;\r\n\r\nprocedure TJvExplorerCustomBarItemViewer.Draw(Bitmap: TBitmap; var X, Y, Width: Integer);\r\nbegin\r\n if ShowClientArea then\r\n begin\r\n Bitmap.Canvas.Brush.Color := Item.ExplorerGroup.ExplorerBar.ColourSet.TextHot;\r\n Bitmap.Canvas.FrameRect(Item.ClientAreaRectangle);\r\n Bitmap.Canvas.Brush.Style := bsClear;\r\n end;\r\n Inc(Y, JvExplorerConstYOffset div 2);\r\nend;\r\n\r\nprocedure TJvExplorerCustomBarItemViewer.DrawCaption(Bitmap: TBitmap; var X, Y: Integer; var aRect: TRect;\r\n dwFlags: Integer);\r\nvar\r\n DrawFlags: Integer;\r\nbegin\r\n DrawFlags := DT_LEFT;\r\n if Item.WordWrap then\r\n DrawFlags := DrawFlags or DT_WORDBREAK or DT_WORD_ELLIPSIS or DT_TOP or DT_EDITCONTROL\r\n else\r\n DrawFlags := DrawFlags or DT_SINGLELINE or DT_END_ELLIPSIS;\r\n\r\n // DrawText(Bitmap.Canvas.Handle,PChar(Item.Caption),Length(Item.Caption),aRect,DrawFlags);\r\n // DrawFlags:= DrawFlags and not DT_CALCRECT;\r\n DrawText(Bitmap.Canvas.Handle, PChar(Item.Caption), Length(Item.Caption), aRect, DrawFlags);\r\n Y := aRect.Bottom + (JvExplorerConstYOffset div 2);\r\n Item.ClientAreaRectangle := aRect;\r\nend;\r\n\r\nprocedure TJvExplorerCustomBarItemViewer.Measure(Bitmap: TBitmap; var X, Y, Width: Integer);\r\n//var\r\n// DrawFlags: Integer;\r\n// R: TRect;\r\nbegin\r\n Bitmap.Canvas.Font.Style := Item.FontStyle;\r\n //DrawFlags := DT_LEFT;\r\n if Item.WordWrap then\r\n begin\r\n // SetRect(aRect,0,0,Width,Width);\r\n // DrawFlags:= DrawFlags or DT_WORDBREAK or DT_WORD_ELLIPSIS or DT_TOP or DT_EDITCONTROL or DT_CALCRECT;\r\n // DrawText(Bitmap.Canvas.Handle,PChar(Item.Caption),Length(Item.Caption),aRect,DrawFlags);\r\n // Inc(Y,aRect.Bottom);\r\n Inc(Y, TJvExplorerBarText.HeightOf(Bitmap.Canvas, Item.Caption, Width) +\r\n JvExplorerConstIconOffset)\r\n end\r\n else\r\n Inc(Y, Bitmap.Canvas.TextHeight('Yy') + JvExplorerConstIconOffset);\r\n Inc(Y, JvExplorerConstYOffset div 2);\r\nend;\r\n\r\nprocedure TJvExplorerCustomBarItemViewer.DrawIcon(Bitmap: TBitmap; var X, Y, Width: Integer);\r\nbegin\r\n if (Item.IconIndex <> JvExplorerConstUnknownValue) and\r\n Assigned(Item.ExplorerGroup.ExplorerBar.ItemIcons) then\r\n begin\r\n Item.ExplorerGroup.ExplorerBar.ItemIcons.Draw(Bitmap.Canvas, X + JvExplorerConstXOffset, Y,\r\n Item.IconIndex);\r\n X := Item.ExplorerGroup.ExplorerBar.ItemIcons.Width + (JvExplorerConstXOffset * 2) +\r\n JvExplorerConstIconOffset;\r\n end\r\n else\r\n X := X + (JvExplorerConstXOffset);\r\nend;\r\n\r\nfunction TJvExplorerCustomBarItemViewer.GetExplorerBar: TJvExplorerBar;\r\nbegin\r\n Result := Item.ExplorerGroup.ExplorerBar;\r\nend;\r\n\r\nprocedure TJvExplorerCustomBarItemViewer.HandleCustomDrawBarItem(BarItem: TObject; Bitmap: TBitmap;\r\n var X, Y, Width: Integer);\r\nbegin\r\n Item.ExplorerGroup.ExplorerBar.DoCustomDrawBarItem(BarItem, Bitmap, X, Y, Width);\r\nend;\r\n\r\nprocedure TJvExplorerCustomBarItemViewer.HandleCustomMeasureBarItem(BarItem: TObject; Bitmap: TBitmap;\r\n var X, Y, Width: Integer);\r\nbegin\r\n Item.ExplorerGroup.ExplorerBar.DoCustomMeasureBarItem(BarItem, Bitmap, X, Y, Width);\r\nend;\r\n\r\n{ TExplorerBarColourSet }\r\n\r\nconstructor TJvExplorerBarColourSet.Create(ABar: TJvExplorerBar);\r\nbegin\r\n inherited Create;\r\n FBar := ABar;\r\nend;\r\n\r\nprocedure TJvExplorerBarColourSet.LoadFromFile(const AFilename, AThemeName: string);\r\n{\r\n[Blue]\r\nName=Blue\r\nText Hot=16748098\r\nText=12999969\r\nBorder=16777215\r\nBackground=15114362\r\nGroup Background=16773869\r\nSpecial Text=16777215\r\nSpecial Text Hot=16748098\r\n\r\n[Olive]\r\nName=Olive\r\nText Hot=1938034\r\nText=2975318\r\nBorder=16777215\r\nBackground=11262154\r\nGroup Background=15529718\r\nSpecial Text=16777215\r\nSpecial Text Hot=12117984\r\n\r\n[Silver]\r\nName=Silver\r\nText Hot=8158334\r\nText=4013375\r\nBorder=16777215\r\nBackground=13879235\r\nGroup Background=16118256\r\nSpecial Text=16777215\r\nSpecial Text Hot=15132390\r\n}\r\nvar\r\n IniFile: TMemIniFile;\r\nbegin\r\n IniFile := TMemIniFile.Create(AFilename);\r\n try\r\n if IniFile.SectionExists(AThemeName) then\r\n begin\r\n IniFile.ReadString(AThemeName, 'Name', JvExplorerThemeNames[Bar.ThemeElements.Theme]);\r\n IniFile.ReadInteger(AThemeName, 'Text Hot', TColor(TextHot));\r\n IniFile.ReadInteger(AThemeName, 'Text', TColor(Text));\r\n IniFile.ReadInteger(AThemeName, 'Border', TColor(Border));\r\n IniFile.ReadInteger(AThemeName, 'Background', TColor(Background));\r\n IniFile.ReadInteger(AThemeName, 'Group Background', TColor(GroupBackground));\r\n IniFile.ReadInteger(AThemeName, 'Special Text', TColor(SpecialText));\r\n IniFile.ReadInteger(AThemeName, 'Special Text Hot', TColor(SpecialTextHot));\r\n end;\r\n finally\r\n IniFile.Free;\r\n end;\r\nend;\r\n\r\nprocedure TJvExplorerBarColourSet.SaveToFile(const AFilename: string);\r\nvar\r\n IniFile: TMemIniFile;\r\n ThemeName: string;\r\nbegin\r\n ThemeName := JvExplorerThemeNames[Bar.ThemeElements.Theme];\r\n IniFile := TMemIniFile.Create(AFilename);\r\n try\r\n IniFile.EraseSection(ThemeName);\r\n IniFile.WriteString(ThemeName, 'Name', ThemeName);\r\n IniFile.WriteInteger(ThemeName, 'Text Hot', Integer(TextHot));\r\n IniFile.WriteInteger(ThemeName, 'Text', Integer(Text));\r\n IniFile.WriteInteger(ThemeName, 'Border', Integer(Border));\r\n IniFile.WriteInteger(ThemeName, 'Background', Integer(Background));\r\n IniFile.WriteInteger(ThemeName, 'Group Background', Integer(GroupBackground));\r\n IniFile.WriteInteger(ThemeName, 'Special Text', Integer(SpecialText));\r\n IniFile.WriteInteger(ThemeName, 'Special Text Hot', Integer(SpecialTextHot));\r\n IniFile.UpdateFile;\r\n finally\r\n IniFile.Free;\r\n end;\r\nend;\r\n\r\n{ TExplorerBarThemeElements }\r\n\r\nconstructor TJvExplorerBarThemeElements.Create(ABar: TJvExplorerBar);\r\nbegin\r\n inherited Create;\r\n FBar := ABar;\r\n\r\n FTheme := etBlue;\r\n\r\n FBlueElements := TBitmap.Create;\r\n FOliveElements := TBitmap.Create;\r\n FSilverElements := TBitmap.Create;\r\n FOrangeElements := TBitmap.Create;\r\n FBlueFlatElements := TBitmap.Create;\r\n\r\n FBlueElements.LoadFromResourceName(hInstance, 'THEME_BLUE');\r\n FOliveElements.LoadFromResourceName(hInstance, 'THEME_OLIVE');\r\n FSilverElements.LoadFromResourceName(hInstance, 'THEME_SILVER');\r\n FOrangeElements.LoadFromResourceName(hInstance, 'THEME_ORANGE');\r\n FBlueFlatElements.LoadFromResourceName(hInstance, 'THEME_BLUE_FLAT');\r\n\r\n FArrowUp := TBitmap.Create;\r\n FArrowUp.LoadFromResourceName(hInstance, 'ARROW_UP');\r\n FArrowUp.PixelFormat := pf8bit;\r\n\r\n FArrowDown := TBitmap.Create;\r\n FArrowDown.LoadFromResourceName(hInstance, 'ARROW_DOWN');\r\n FArrowDown.PixelFormat := pf8bit;\r\n\r\n ThemeChanged;\r\n UpdateCheckBoxDimensions;\r\nend;\r\n\r\ndestructor TJvExplorerBarThemeElements.Destroy;\r\nbegin\r\n BlueElements.Free;\r\n OliveElements.Free;\r\n SilverElements.Free;\r\n OrangeElements.Free;\r\n BlueFlatElements.Free;\r\n ArrowDown.Free;\r\n ArrowUp.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvExplorerBarThemeElements.BlendFillRect(Dest: TBitmap; aRect: TRect; Alpha: Extended);\r\nvar\r\n I, J: Integer;\r\n OutRect: TRect;\r\n PDest: PByteArray;\r\n R, G, B: Byte;\r\nbegin\r\n if Alpha >= 1 then\r\n Dest.Canvas.FillRect(aRect)\r\n else if Alpha > 0 then\r\n begin\r\n if Dest.PixelFormat <> pf24bit then\r\n Dest.PixelFormat := pf24bit;\r\n if IntersectRect(OutRect, aRect, Dest.Canvas.ClipRect) then\r\n begin\r\n R := GetRValue(Dest.Canvas.Brush.Color);\r\n G := GetGValue(Dest.Canvas.Brush.Color);\r\n B := GetBValue(Dest.Canvas.Brush.Color);\r\n for J := OutRect.Top to OutRect.Bottom - 1 do\r\n begin\r\n PDest := Dest.ScanLine[J];\r\n for I := OutRect.Left to OutRect.Right - 1 do\r\n begin // blending\r\n PDest[I * 3] := Round(((1 - Alpha) * PDest[I * 3] + Alpha * B));\r\n PDest[I * 3 + 1] := Round(((1 - Alpha) * PDest[I * 3 + 1] + Alpha * G));\r\n PDest[I * 3 + 2] := Round(((1 - Alpha) * PDest[I * 3 + 2] + Alpha * R));\r\n end;\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvExplorerBarThemeElements.DrawHeader(Bitmap: TBitmap; X, Y, Width: Integer;\r\n SpecialGroup, Closed: Boolean; TextColor: TColor);\r\nbegin\r\n with Bitmap.Canvas do\r\n begin\r\n Brush.Color := IfThen(SpecialGroup, clActiveCaption, clBtnFace);\r\n FillRect(Rect(X, Y + JvExplorerConstIconSide - Height, X + Width, Y + JvExplorerConstIconSide));\r\n Brush.Color := TextColor;\r\n if Closed then\r\n DrawMask(Bitmap, Width - JvExplorerConstXOffset, Y + 2 * JvExplorerConstYOffset, ArrowDown)\r\n else\r\n DrawMask(Bitmap, Width - JvExplorerConstXOffset, Y + 2 * JvExplorerConstYOffset, ArrowUp);\r\n end;\r\nend;\r\n\r\nprocedure TJvExplorerBarThemeElements.DrawMask(Dest: TBitmap; X, Y: Integer; Src: TBitmap);\r\nvar\r\n I, J: Integer;\r\n X2, Y2: Integer;\r\n PSrc: PByteArray;\r\nbegin\r\n if (Y >= Dest.Height) or (X >= Dest.Width) then\r\n Exit;\r\n Y2 := Min(Src.Height, Dest.Height - Y) - 1;\r\n X2 := Min(Src.Width, Dest.Width - X) - 1;\r\n for J := 0 to Y2 do\r\n begin\r\n PSrc := Src.ScanLine[J];\r\n for I := 0 to X2 do\r\n if PSrc[I] = 0 then\r\n Dest.Canvas.Pixels[X + I, Y + J] := Dest.Canvas.Brush.Color;\r\n end;\r\nend;\r\n\r\nprocedure TJvExplorerBarThemeElements.DrawThemedHeader(Bitmap, Skin: TBitmap; X, Y, Width: Integer;\r\n SpecialGroup, Closed, MouseOver: Boolean);\r\nbegin\r\n SetStretchBltMode(Bitmap.Canvas.Handle, COLORONCOLOR);\r\n if SpecialGroup then\r\n begin\r\n BitBlt(Bitmap.Canvas.Handle, X, Y + JvExplorerConstIconSide - Height,\r\n JvExplorerConstSkinLeftPartWidth, Height, Skin.Canvas.Handle,\r\n ElementRect(terSpecialTitleLeft).Left, ElementRect(terSpecialTitleLeft).Top, SRCCOPY);\r\n StretchBlt(Bitmap.Canvas.Handle,\r\n X + JvExplorerConstSkinLeftPartWidth,\r\n Y + JvExplorerConstIconSide - Height,\r\n Width - JvExplorerConstSkinLeftPartWidth - JvExplorerConstSkinRightPartWidth,\r\n Height,\r\n Skin.Canvas.Handle,\r\n ElementRect(terSpecialTitleCenter).Left, ElementRect(terSpecialTitleCenter).Top,\r\n ElementRect(terSpecialTitleCenter).Right - ElementRect(terSpecialTitleCenter).Left,\r\n ElementRect(terSpecialTitleCenter).Bottom - ElementRect(terSpecialTitleCenter).Top, SRCCOPY);\r\n BitBlt(Bitmap.Canvas.Handle,\r\n X + Width - JvExplorerConstSkinRightPartWidth,\r\n Y + JvExplorerConstIconSide - Height, JvExplorerConstSkinRightPartWidth, Height,\r\n Skin.Canvas.Handle, IfThen(Closed, IfThen(MouseOver, ElementRect(terSpecialTitleRightDownOn).Left,\r\n ElementRect(terSpecialTitleRightDownOff).Left),\r\n IfThen(MouseOver, ElementRect(terSpecialTitleRightUpOn).Left, ElementRect(terSpecialTitleRightUpOff).Left)),\r\n IfThen(Closed, IfThen(MouseOver, ElementRect(terSpecialTitleRightDownOn).Top, ElementRect(terSpecialTitleRightDownOff).Top),\r\n IfThen(MouseOver, ElementRect(terSpecialTitleRightUpOn).Top, ElementRect(terSpecialTitleRightUpOff).Top)),\r\n SRCCOPY);\r\n end\r\n else\r\n begin\r\n BitBlt(Bitmap.Canvas.Handle, X, Y + JvExplorerConstIconSide - Height,\r\n JvExplorerConstSkinLeftPartWidth, Height, Skin.Canvas.Handle, ElementRect(terTitleLeft).Left,\r\n ElementRect(terTitleLeft).Top, SRCCOPY);\r\n StretchBlt(Bitmap.Canvas.Handle,\r\n X + JvExplorerConstSkinLeftPartWidth,\r\n Y + JvExplorerConstIconSide - Height,\r\n Width - JvExplorerConstSkinLeftPartWidth - JvExplorerConstSkinRightPartWidth,\r\n Height,\r\n Skin.Canvas.Handle,\r\n ElementRect(terTitleCenter).Left, ElementRect(terTitleCenter).Top,\r\n ElementRect(terTitleCenter).Right - ElementRect(terTitleCenter).Left,\r\n ElementRect(terTitleCenter).Bottom - ElementRect(terTitleCenter).Top, SRCCOPY);\r\n BitBlt(Bitmap.Canvas.Handle,\r\n X + Width - JvExplorerConstSkinRightPartWidth,\r\n Y + JvExplorerConstIconSide - Height, JvExplorerConstSkinRightPartWidth, Height,\r\n Skin.Canvas.Handle,\r\n IfThen(Closed, IfThen(MouseOver, ElementRect(terTitleRightDownOn).Left, ElementRect(terTitleRightDownOff).Left),\r\n IfThen(MouseOver, ElementRect(terTitleRightUpOn).Left, ElementRect(terTitleRightUpOff).Left)),\r\n IfThen(Closed, IfThen(MouseOver, ElementRect(terTitleRightDownOn).Top, ElementRect(terTitleRightDownOff).Top),\r\n IfThen(MouseOver, ElementRect(terTitleRightUpOn).Top, ElementRect(terTitleRightUpOff).Top)),\r\n SRCCOPY);\r\n end;\r\nend;\r\n\r\nfunction TJvExplorerBarThemeElements.ElementRect(dwType: TJvExplorerThemeElementRectType): TRect;\r\nbegin\r\n case dwType of\r\n terTitleLeft:\r\n Result := Rect(7, 1, 12, 24);\r\n terTitleCenter:\r\n Result := Rect(13, 1, 163, 24);\r\n terTitleRightUpOff:\r\n Result := Rect(164, 1, 189, 24);\r\n terTitleRightUpOn:\r\n Result := Rect(190, 1, 215, 24);\r\n terTitleRightDownOff:\r\n Result := Rect(216, 1, 241, 24);\r\n terTitleRightDownOn:\r\n Result := Rect(242, 1, 267, 24);\r\n terSpecialTitleLeft:\r\n Result := Rect(7, 25, 12, 48);\r\n terSpecialTitleCenter:\r\n Result := Rect(13, 25, 163, 48);\r\n terSpecialTitleRightUpOff:\r\n Result := Rect(164, 25, 189, 48);\r\n terSpecialTitleRightUpOn:\r\n Result := Rect(190, 25, 215, 48);\r\n terSpecialTitleRightDownOff:\r\n Result := Rect(216, 25, 241, 48);\r\n terSpecialTitleRightDownOn:\r\n Result := Rect(242, 25, 267, 48);\r\n end;\r\nend;\r\n\r\nfunction TJvExplorerBarThemeElements.GetHeight: Integer;\r\nbegin\r\n Result := 23;\r\nend;\r\n\r\nfunction TJvExplorerBarThemeElements.GetThemeBitmap: TBitmap;\r\nbegin\r\n case Theme of\r\n etBlue:\r\n Result := BlueElements;\r\n etSilver:\r\n Result := SilverElements;\r\n etOlive:\r\n Result := OliveElements;\r\n etOrange:\r\n Result := OrangeElements;\r\n etBlueFlat:\r\n Result := BlueFlatElements;\r\n else\r\n Result := BlueElements;\r\n end;\r\nend;\r\n\r\nprocedure TJvExplorerBarThemeElements.SetTheme(Value: TJvExplorerTheme);\r\nbegin\r\n if Value <> FTheme then\r\n begin\r\n FTheme := Value;\r\n ThemeChanged;\r\n end;\r\nend;\r\n\r\nprocedure TJvExplorerBarThemeElements.ThemeChanged;\r\nbegin\r\n Bar.ColourSet.Background := ThemeBitmap.Canvas.Pixels[1, 1];\r\n Bar.ColourSet.GroupBackground := ThemeBitmap.Canvas.Pixels[1, 7];\r\n Bar.ColourSet.Border := ThemeBitmap.Canvas.Pixels[1, 13];\r\n Bar.ColourSet.Text := ThemeBitmap.Canvas.Pixels[1, 19];\r\n Bar.ColourSet.TextHot := ThemeBitmap.Canvas.Pixels[1, 25];\r\n Bar.ColourSet.SpecialText := ThemeBitmap.Canvas.Pixels[1, 31];\r\n Bar.ColourSet.SpecialTextHot := ThemeBitmap.Canvas.Pixels[1, 37];\r\n Bar.Color := Bar.ColourSet.Background;\r\n Bar.Repaint;\r\n // Bar.ColourSet.Background:= clWhite; //clWindow;\r\n // Bar.ColourSet.GroupBackground:= clWindow;\r\n // Bar.ColourSet.Border:= clBtnFace;\r\n // Bar.ColourSet.Text:= clBtnText;\r\n // Bar.ColourSet.TextHot:= clBtnText;\r\n // Bar.ColourSet.SpecialText:= clCaptionText;\r\n // Bar.ColourSet.SpecialTextHot:= clCaptionText;\r\n // Bar.Color := clWhite; //clWindow;\r\nend;\r\n\r\nprocedure TJvExplorerBarThemeElements.UpdateCheckBoxDimensions;\r\nbegin\r\n with TBitmap.Create do\r\n try\r\n Handle := LoadBitmap(0, PChar(32759));\r\n FCheckBoxWidth := Width div 4;\r\n FCheckBoxHeight := Height div 3;\r\n finally\r\n Free;\r\n end;\r\nend;\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvExplorerBarItems.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvExplorerBarItems.pas, released on 2010-11-28.\r\n\r\nThe Initial Developers of the Original Code is: Max Evans\r\nCopyright (c) 2009 Max Events\r\nAll Rights Reserved.\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nContributor(s):\r\n Andreas Hausladen (bugfixing, additional features)\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvExplorerBarItems.pas 13143 2011-11-02 18:23:46Z ahuser $\r\n\r\nunit JvExplorerBarItems;\r\n\r\ninterface\r\n\r\n{$I jvcl.inc}\r\n\r\nuses\r\n Windows, Types, SysUtils, Classes, Controls, StdCtrls, Graphics, ActnList,\r\n JvExplorerBar;\r\n\r\ntype\r\n { Text classes }\r\n\r\n TJvExplorerGroupMenuItemViewer = class(TJvExplorerCustomBarItemViewer)\r\n public\r\n procedure Draw(Bitmap: TBitmap; var X, Y, Width: Integer); override;\r\n end;\r\n\r\n TJvExplorerGroupMenuItem = class(TJvExplorerBarGroupItem)\r\n protected\r\n function CreateBarItemViewer: TJvExplorerCustomBarItemViewer; override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n end;\r\n\r\n TJvExplorerTextLineItemViewer = class(TJvExplorerCustomBarItemViewer)\r\n public\r\n procedure Draw(Bitmap: TBitmap; var X, Y, Width: Integer); override;\r\n procedure Measure(Bitmap: TBitmap; var X, Y, Width: Integer); override;\r\n end;\r\n\r\n TJvExplorerGroupTextLineItem = class(TJvExplorerBarGroupItem)\r\n private\r\n FFontSize: Integer;\r\n FTextAlignment: TAlignment;\r\n protected\r\n function CreateBarItemViewer: TJvExplorerCustomBarItemViewer; override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n\r\n property FontSize: Integer read FFontSize write FFontSize;\r\n property TextAlignment: TAlignment read FTextAlignment write FTextAlignment;\r\n end;\r\n\r\n TJvExplorerCategoryItemViewer = class(TJvExplorerCustomBarItemViewer)\r\n public\r\n procedure Draw(Bitmap: TBitmap; var X, Y, Width: Integer); override;\r\n procedure Measure(Bitmap: TBitmap; var X, Y, Width: Integer); override;\r\n end;\r\n\r\n TJvExplorerGroupCategoryItem = class(TJvExplorerBarGroupItem)\r\n private\r\n FUnderlined: Boolean;\r\n FPaddingAfter: Integer;\r\n FPaddingBefore: Integer;\r\n protected\r\n function CreateBarItemViewer: TJvExplorerCustomBarItemViewer; override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n\r\n property Underlined: Boolean read FUnderlined write FUnderlined;\r\n property PaddingBefore: Integer read FPaddingBefore write FPaddingBefore;\r\n property PaddingAfter: Integer read FPaddingAfter write FPaddingAfter;\r\n end;\r\n\r\n { CheckBox }\r\n\r\n TJvExplorerCheckBoxItemViewer = class(TJvExplorerCustomBarItemViewer)\r\n private\r\n procedure DrawCheck(Canvas: TCanvas; R: TRect; AState: TCheckBoxState; AEnabled: Boolean);\r\n public\r\n procedure Draw(Bitmap: TBitmap; var X, Y, Width: Integer); override;\r\n end;\r\n\r\n TJvExplorerGroupCheckBoxItem = class(TJvExplorerBarGroupItem)\r\n private\r\n FChecked: Boolean;\r\n procedure SetChecked(Value: Boolean);\r\n protected\r\n function CreateBarItemViewer: TJvExplorerCustomBarItemViewer; override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n procedure ItemClick; override;\r\n\r\n property Checked: Boolean read FChecked write SetChecked;\r\n end;\r\n\r\n { RadioButton }\r\n\r\n TJvExplorerGroupOptionButtonsItemViewer = class(TJvExplorerCustomBarItemViewer)\r\n private\r\n procedure DrawRadio(Canvas: TCanvas; R: TRect; AState: TCheckBoxState; AEnabled: Boolean);\r\n public\r\n procedure Draw(Bitmap: TBitmap; var X, Y, Width: Integer); override;\r\n procedure Measure(Bitmap: TBitmap; var X, Y, Width: Integer); override;\r\n end;\r\n\r\n TJvExplorerGroupOptionButtonsItem = class(TJvExplorerBarGroupItem)\r\n private\r\n FItemIndex: Integer;\r\n FItems: TStrings;\r\n procedure SetItemIndex(const Value: Integer);\r\n procedure SetItems(Value: TStrings);\r\n procedure ItemsChange(Sender: TObject);\r\n protected\r\n procedure MouseDown(Sender: TObject; X, Y: Integer); override;\r\n protected\r\n function CreateBarItemViewer: TJvExplorerCustomBarItemViewer; override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n\r\n property Items: TStrings read FItems write SetItems;\r\n property ItemIndex: Integer read FItemIndex write SetItemIndex;\r\n end;\r\n\r\n { Button }\r\n\r\n TJvExplorerButtonItemViewer = class(TJvExplorerCustomBarItemViewer)\r\n private\r\n procedure DrawButton(Canvas: TCanvas; R: TRect; AEnabled, aPushed, aHot: Boolean);\r\n public\r\n procedure Draw(Bitmap: TBitmap; var X, Y, Width: Integer); override;\r\n procedure Measure(Bitmap: TBitmap; var X, Y, Width: Integer); override;\r\n end;\r\n\r\n TJvExplorerGroupButtonItem = class(TJvExplorerBarGroupItem)\r\n protected\r\n function CreateBarItemViewer: TJvExplorerCustomBarItemViewer; override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n\r\n procedure ItemClick; override;\r\n end;\r\n\r\n { Picture }\r\n\r\n TJvExplorerPictureItemViewer = class(TJvExplorerCustomBarItemViewer)\r\n public\r\n procedure Draw(Bitmap: TBitmap; var X, Y, Width: Integer); override;\r\n procedure Measure(Bitmap: TBitmap; var X, Y, Width: Integer); override;\r\n end;\r\n\r\n TJvExplorerGroupPictureItem = class(TJvExplorerBarGroupItem)\r\n private\r\n FStretch: Boolean;\r\n FPicture: TPicture;\r\n procedure SetStretch(const Value: Boolean);\r\n protected\r\n procedure SetPicture(Value: TPicture);\r\n procedure PictureChange(Sender: TObject);\r\n\r\n function CreateBarItemViewer: TJvExplorerCustomBarItemViewer; override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n procedure LoadFromFile(const AFilename: string); virtual;\r\n\r\n property Picture: TPicture read FPicture write SetPicture;\r\n property Stretch: Boolean read FStretch write SetStretch;\r\n end;\r\n\r\n { Spacer classes }\r\n\r\n TJvExplorerSeparatorItemViewer = class(TJvExplorerCustomBarItemViewer)\r\n public\r\n procedure Draw(Bitmap: TBitmap; var X, Y, Width: Integer); override;\r\n procedure Measure(Bitmap: TBitmap; var X, Y, Width: Integer); override;\r\n end;\r\n\r\n TJvExplorerGroupSeparatorItem = class(TJvExplorerBarGroupItem)\r\n private\r\n FColor: TColor;\r\n procedure SetColor(const Value: TColor);\r\n protected\r\n function CreateBarItemViewer: TJvExplorerCustomBarItemViewer; override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n\r\n property Color: TColor read FColor write SetColor;\r\n end;\r\n\r\n TJvExplorerSpacerItemViewer = class(TJvExplorerCustomBarItemViewer)\r\n public\r\n procedure Draw(Bitmap: TBitmap; var X, Y, Width: Integer); override;\r\n procedure Measure(Bitmap: TBitmap; var X, Y, Width: Integer); override;\r\n end;\r\n\r\n TJvExplorerGroupSpacerItem = class(TJvExplorerBarGroupItem)\r\n protected\r\n function CreateBarItemViewer: TJvExplorerCustomBarItemViewer; override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n end;\r\n\r\n { Control classes }\r\n\r\n TJvExplorerProgressBarItemViewer = class(TJvExplorerCustomBarItemViewer)\r\n public\r\n procedure Draw(Bitmap: TBitmap; var X, Y, Width: Integer); override;\r\n procedure Measure(Bitmap: TBitmap; var X, Y, Width: Integer); override;\r\n end;\r\n\r\n TJvExplorerSimpleProgressBarItemViewer = class(TJvExplorerCustomBarItemViewer)\r\n public\r\n procedure Draw(Bitmap: TBitmap; var X, Y, Width: Integer); override;\r\n procedure Measure(Bitmap: TBitmap; var X, Y, Width: Integer); override;\r\n end;\r\n\r\n TJvExplorerCustomDrawProgressBarItemViewer = class(TJvExplorerCustomBarItemViewer)\r\n public\r\n procedure Draw(Bitmap: TBitmap; var X, Y, Width: Integer); override;\r\n procedure Measure(Bitmap: TBitmap; var X, Y, Width: Integer); override;\r\n end;\r\n\r\n { a base progress bar }\r\n\r\n TJvExplorerCustomGroupProgressBarItem = class(TJvExplorerBarGroupItem)\r\n private\r\n FMin, FMax, FPosition: Integer;\r\n FBorderColor: TColor;\r\n FFillColor: TColor;\r\n procedure SetMin(Value: Integer);\r\n procedure SetMax(Value: Integer);\r\n procedure SetPosition(Value: Integer);\r\n procedure SetBorderColor(const Value: TColor);\r\n procedure SetFillColor(const Value: TColor);\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n\r\n property Min: Integer read FMin write SetMin;\r\n property Max: Integer read FMax write SetMax;\r\n property Position: Integer read FPosition write SetPosition;\r\n property BorderColour: TColor read FBorderColor write SetBorderColor;\r\n property FillColour: TColor read FFillColor write SetFillColor;\r\n end;\r\n\r\n { a progress bar }\r\n\r\n TJvExplorerGroupProgressBarItem = class(TJvExplorerCustomGroupProgressBarItem)\r\n protected\r\n function CreateBarItemViewer: TJvExplorerCustomBarItemViewer; override;\r\n end;\r\n\r\n { a simple progress bar }\r\n\r\n TJvExplorerGroupSimpleProgressBarItem = class(TJvExplorerCustomGroupProgressBarItem)\r\n protected\r\n function CreateBarItemViewer: TJvExplorerCustomBarItemViewer; override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n end;\r\n\r\n { a custom draw progress bar }\r\n\r\n TJvExplorerGroupCustomDrawProgressBarItem = class(TJvExplorerCustomGroupProgressBarItem)\r\n protected\r\n function CreateBarItemViewer: TJvExplorerCustomBarItemViewer; override;\r\n end;\r\n\r\n { custom draw classes }\r\n\r\n TJvExplorerCustomDrawBarItemViewer = class(TJvExplorerCustomBarItemViewer)\r\n public\r\n procedure Draw(Bitmap: TBitmap; var X, Y, Width: Integer); override;\r\n procedure Measure(Bitmap: TBitmap; var X, Y, Width: Integer); override;\r\n end;\r\n\r\n { a custom draw bar }\r\n\r\n TJvExplorerGroupCustomDrawBarItem = class(TJvExplorerCustomGroupProgressBarItem)\r\n protected\r\n function CreateBarItemViewer: TJvExplorerCustomBarItemViewer; override;\r\n end;\r\n\r\n { Date and Calendars }\r\n\r\n TJvExplorerMonthCalendarItemViewer = class(TJvExplorerCustomBarItemViewer)\r\n private\r\n procedure PaintDay(Canvas: TCanvas; Day: Integer; DayRect: TRect);\r\n procedure PaintMonth(Canvas: TCanvas; MonthRect: TRect; Year, Month: Integer);\r\n function GetMonthRect(Bitmap: TBitmap; var X, Y, Width: Integer): TRect;\r\n function GetMonthName(Month: Integer): String;\r\n function GetDayInWeekChar(DayInWeek: Integer): Char;\r\n procedure SetPastMonth(var AYear, AMonth: Integer; Decrease: Boolean = True);\r\n public\r\n procedure Draw(Bitmap: TBitmap; var X, Y, Width: Integer); override;\r\n procedure Measure(Bitmap: TBitmap; var X, Y, Width: Integer); override;\r\n end;\r\n\r\n TJvExplorerGroupMonthCalendarItem = class(TJvExplorerBarGroupItem)\r\n private\r\n FCalendarDate: TDateTime;\r\n procedure SetCalendarDate(const Value: TDateTime);\r\n protected\r\n function CreateBarItemViewer: TJvExplorerCustomBarItemViewer; override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n procedure ItemClick; override;\r\n\r\n property CalendarDate: TDateTime read FCalendarDate write SetCalendarDate;\r\n end;\r\n\r\n { Action classes }\r\n\r\n TJvExplorerGroupActionItem = class;\r\n\r\n TJvExplorerGroupItemActionLink = class(TActionLink)\r\n private\r\n FActionItem: TJvExplorerGroupActionItem;\r\n public\r\n procedure AssignClient(AClient: TObject); override;\r\n procedure SetEnabled(Value: Boolean); override;\r\n function Update: Boolean; override;\r\n procedure Change; override;\r\n end;\r\n\r\n TJvExplorerActionItemViewer = class(TJvExplorerCustomBarItemViewer)\r\n public\r\n procedure Draw(Bitmap: TBitmap; var X, Y, Width: Integer); override;\r\n procedure Measure(Bitmap: TBitmap; var X, Y, Width: Integer); override;\r\n end;\r\n\r\n TJvExplorerGroupActionItem = class(TJvExplorerBarGroupItem)\r\n private\r\n FActionLink: TJvExplorerGroupItemActionLink;\r\n procedure SetAction(const Value: TAction);\r\n function GetAction: TAction;\r\n protected\r\n function IsEnabled: Boolean; override;\r\n protected\r\n function CreateBarItemViewer: TJvExplorerCustomBarItemViewer; override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n\r\n procedure ItemClick; override;\r\n property Action: TAction read GetAction write SetAction;\r\n end;\r\n\r\n TJvExplorerItemFactory = class(TObject)\r\n public\r\n class function ProgressBar(AGroup: TJvExplorerBarGroup; AMax, AMin, APosition: Integer): TJvExplorerGroupProgressBarItem; {$IFDEF SUPPORTS_STATIC} static; {$ENDIF}\r\n class function SimpleProgressBar(AGroup: TJvExplorerBarGroup; AMax, AMin, APosition: Integer): TJvExplorerGroupSimpleProgressBarItem; {$IFDEF SUPPORTS_STATIC} static; {$ENDIF}\r\n class function CustomProgressBar(AGroup: TJvExplorerBarGroup): TJvExplorerGroupCustomDrawProgressBarItem; {$IFDEF SUPPORTS_STATIC} static; {$ENDIF}\r\n class function CustomBarItem(AGroup: TJvExplorerBarGroup): TJvExplorerGroupCustomDrawBarItem; {$IFDEF SUPPORTS_STATIC} static; {$ENDIF}\r\n class function Menu(AGroup: TJvExplorerBarGroup; const ACaption: string;\r\n AIdentifier, AIconIndex: Integer; const AWrap: Boolean = False): TJvExplorerGroupMenuItem; {$IFDEF SUPPORTS_STATIC} static; {$ENDIF}\r\n class function Picture(AGroup: TJvExplorerBarGroup; AGraphic: TGraphic; AHotTrack, AStretch: Boolean;\r\n AIdentifier: Integer): TJvExplorerGroupPictureItem; {$IFDEF SUPPORTS_STATIC} static; {$ENDIF}\r\n class function Text(AGroup: TJvExplorerBarGroup; const ACaption: string; AFontColour: TColor;\r\n AFontStyle: TFontStyles; AWrap: Boolean; AIconIndex: Integer; const AFontSize: Integer = 8;\r\n AAligned: TAlignment = taLeftJustify): TJvExplorerGroupTextLineItem; {$IFDEF SUPPORTS_STATIC} static; {$ENDIF}\r\n class function Spacer(AGroup: TJvExplorerBarGroup; AHeight: Integer = -1): TJvExplorerGroupSpacerItem; {$IFDEF SUPPORTS_STATIC} static; {$ENDIF}\r\n class function Separator(AGroup: TJvExplorerBarGroup; AColor: TColor = -1): TJvExplorerGroupSeparatorItem; {$IFDEF SUPPORTS_STATIC} static; {$ENDIF}\r\n class function Action(AGroup: TJvExplorerBarGroup; AAction: TAction; AImageList: TImageList): TJvExplorerGroupActionItem; overload; {$IFDEF SUPPORTS_STATIC} static; {$ENDIF}\r\n class function Action(AGroup: TJvExplorerBarGroup; AAction: TAction; AIconIndex: Integer): TJvExplorerGroupActionItem; overload; {$IFDEF SUPPORTS_STATIC} static; {$ENDIF}\r\n class function Category(AGroup: TJvExplorerBarGroup; const ACaption: string;\r\n AFontColour: TColor; AFontStyle: TFontStyles; AUnderline: Boolean): TJvExplorerGroupCategoryItem; {$IFDEF SUPPORTS_STATIC} static; {$ENDIF}\r\n class function Checkbox(AGroup: TJvExplorerBarGroup; const ACaption: string;\r\n AChecked: Boolean = True; AEnabled: Boolean = True; AIdentifier: Integer = -1): TJvExplorerGroupCheckBoxItem; {$IFDEF SUPPORTS_STATIC} static; {$ENDIF}\r\n class function RadioButtons(AGroup: TJvExplorerBarGroup; const AItems: TStrings; AIndex: Integer): TJvExplorerGroupOptionButtonsItem; {$IFDEF SUPPORTS_STATIC} static; {$ENDIF}\r\n class function Button(AGroup: TJvExplorerBarGroup; const ACaption: string; AIdentifier: Integer): TJvExplorerGroupButtonItem; {$IFDEF SUPPORTS_STATIC} static; {$ENDIF}\r\n class function MonthCalendar(AGroup: TJvExplorerBarGroup; const ACalendarDate: TDateTime): TJvExplorerGroupMonthCalendarItem; {$IFDEF SUPPORTS_STATIC} static; {$ENDIF}\r\n end;\r\n\r\nimplementation\r\n\r\nuses\r\n {$IFDEF JVCLThemesEnabled}\r\n JvThemes,\r\n {$IFDEF RTL230_UP} // XE2+\r\n Themes,\r\n {$ENDIF RTL230_UP}\r\n {$ENDIF JVCLThemesEnabled}\r\n Math, DateUtils;\r\n\r\n{ TJvExplorerGroupMenuItem }\r\n\r\nconstructor TJvExplorerGroupMenuItem.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n HotTracking := True;\r\nend;\r\n\r\ndestructor TJvExplorerGroupMenuItem.Destroy;\r\nbegin\r\n if ExplorerGroup.ExplorerBar.HotArea = Self then\r\n ExplorerGroup.ExplorerBar.HotArea := nil;\r\nend;\r\n\r\nfunction TJvExplorerGroupMenuItem.CreateBarItemViewer: TJvExplorerCustomBarItemViewer;\r\nbegin\r\n Result := TJvExplorerGroupMenuItemViewer.Create(Self);\r\nend;\r\n\r\n{ TJvExplorerGroupMenuItemViewer }\r\n\r\nprocedure TJvExplorerGroupMenuItemViewer.Draw(Bitmap: TBitmap; var X, Y, Width: Integer);\r\nvar\r\n IconX, IconY: Integer;\r\n R: TRect;\r\nbegin\r\n if bisHot in Item.State then\r\n begin\r\n Bitmap.Canvas.Font.Style := [fsUnderline];\r\n Bitmap.Canvas.Font.Color := ExplorerBar.ColourSet.TextHot;\r\n end\r\n else\r\n begin\r\n Bitmap.Canvas.Font.Style := Item.FontStyle;\r\n Bitmap.Canvas.Font.Color := ExplorerBar.ColourSet.Text;\r\n end;\r\n IconX := X;\r\n IconY := Y;\r\n DrawIcon(Bitmap, IconX, IconY, Width);\r\n SetRect(R, IconX, Y, Width, Y + TJvExplorerBarText.HeightOf(Bitmap.Canvas, Item.Caption, Width));\r\n DrawCaption(Bitmap, X, Y, R, 0);\r\n inherited Draw(Bitmap, X, Y, Width);\r\nend;\r\n\r\n{ TJvExplorerGroupTextLineItem }\r\n\r\nconstructor TJvExplorerGroupTextLineItem.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FontSize := 8;\r\nend;\r\n\r\nfunction TJvExplorerGroupTextLineItem.CreateBarItemViewer: TJvExplorerCustomBarItemViewer;\r\nbegin\r\n Result := TJvExplorerTextLineItemViewer.Create(Self);\r\nend;\r\n\r\n{ TJvExplorerTextLineItemViewer }\r\n\r\nprocedure TJvExplorerTextLineItemViewer.Draw(Bitmap: TBitmap; var X, Y, Width: Integer);\r\nvar\r\n IconX, IconY: Integer;\r\n R: TRect;\r\n dwSize: Integer;\r\nbegin\r\n dwSize := Bitmap.Canvas.Font.Size;\r\n Bitmap.Canvas.Font.Size := TJvExplorerGroupTextLineItem(Item).FontSize;\r\n Bitmap.Canvas.Font.Style := Item.FontStyle;\r\n Bitmap.Canvas.Font.Color := Self.Item.FontColor;\r\n\r\n IconX := X;\r\n IconY := Y;\r\n DrawIcon(Bitmap, IconX, IconY, Width);\r\n if Item.WordWrap then\r\n SetRect(R, IconX, Y, Width, Y + TJvExplorerBarText.HeightOf(Bitmap.Canvas, Item.Caption, Width))\r\n else\r\n SetRect(R, IconX, Y, Width, Y + Bitmap.Canvas.TextHeight('Yy'));\r\n if TJvExplorerGroupTextLineItem(Item).TextAlignment = taCenter then\r\n SetRect(R, IconX + ((Width - Bitmap.Canvas.TextWidth(Item.Caption)) div 2) -\r\n JvExplorerConstXOffset, Y, Width, Y + Bitmap.Canvas.TextHeight('Yy'));\r\n // bitmap.Canvas.Brush.Color:= clRed;\r\n // Bitmap.Canvas.FrameRect(r);\r\n DrawCaption(Bitmap, X, Y, R, 0);\r\n\r\n inherited Draw(Bitmap, X, Y, Width);\r\n Bitmap.Canvas.Font.Size := dwSize;\r\nend;\r\n\r\nprocedure TJvExplorerTextLineItemViewer.Measure(Bitmap: TBitmap; var X, Y, Width: Integer);\r\nvar\r\n dwSize: Integer;\r\nbegin\r\n dwSize := Bitmap.Canvas.Font.Size;\r\n Bitmap.Canvas.Font.Size := TJvExplorerGroupTextLineItem(Item).FontSize;\r\n inherited Measure(Bitmap, X, Y, Width);\r\n Bitmap.Canvas.Font.Size := dwSize;\r\n // Inc(Y, JvExplorerConstYOffset div 2);\r\nend;\r\n\r\n{ TJvExplorerGroupCategoryItem }\r\n\r\nconstructor TJvExplorerGroupCategoryItem.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FontColor := clWindowText;\r\n FontStyle := [fsBold];\r\n Underlined := True;\r\n PaddingBefore := 10;\r\n PaddingAfter := 0;\r\nend;\r\n\r\nfunction TJvExplorerGroupCategoryItem.CreateBarItemViewer: TJvExplorerCustomBarItemViewer;\r\nbegin\r\n Result := TJvExplorerCategoryItemViewer.Create(Self);\r\nend;\r\n\r\n{ TJvExplorerCategoryItemViewer }\r\n\r\nprocedure TJvExplorerCategoryItemViewer.Draw(Bitmap: TBitmap; var X, Y, Width: Integer);\r\nvar\r\n IconX, IconY: Integer;\r\n R: TRect;\r\nbegin\r\n Bitmap.Canvas.Font.Style := Item.FontStyle;\r\n Bitmap.Canvas.Font.Color := Item.FontColor;\r\n IconX := X;\r\n IconY := Y;\r\n DrawIcon(Bitmap, IconX, IconY, Width);\r\n Inc(Y, TJvExplorerGroupCategoryItem(Item).PaddingBefore);\r\n SetRect(R, IconX, Y, Width, Y + TJvExplorerBarText.HeightOf(Bitmap.Canvas, Item.Caption, Width));\r\n DrawCaption(Bitmap, X, Y, R, 0);\r\n\r\n if TJvExplorerGroupCategoryItem(Item).Underlined then\r\n begin\r\n Bitmap.Canvas.Pen.Color := Item.FontColor;\r\n Bitmap.Canvas.MoveTo(X + JvExplorerConstXOffset, Y - 2);\r\n Bitmap.Canvas.LineTo(Width - 5, Y - 2);\r\n Inc(Y, JvExplorerConstYOffset div 2);\r\n end;\r\n Inc(Y, TJvExplorerGroupCategoryItem(Item).PaddingAfter);\r\n inherited Draw(Bitmap, X, Y, Width);\r\nend;\r\n\r\nprocedure TJvExplorerCategoryItemViewer.Measure(Bitmap: TBitmap; var X, Y, Width: Integer);\r\nbegin\r\n Inc(Y, TJvExplorerGroupCategoryItem(Item).PaddingBefore);\r\n inherited Measure(Bitmap, X, Y, Width);\r\n if TJvExplorerGroupCategoryItem(Item).Underlined then\r\n Inc(Y, JvExplorerConstYOffset div 2);\r\n Inc(Y, TJvExplorerGroupCategoryItem(Item).PaddingAfter);\r\nend;\r\n\r\n{ TJvExplorerGroupCheckBoxItem }\r\n\r\nconstructor TJvExplorerGroupCheckBoxItem.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FChecked := False;\r\n Height := 23;\r\n HotTracking := True;\r\nend;\r\n\r\nprocedure TJvExplorerGroupCheckBoxItem.SetChecked(Value: Boolean);\r\nbegin\r\n if Value <> FChecked then\r\n begin\r\n FChecked := Value;\r\n NotifyPaint;\r\n end;\r\nend;\r\n\r\nfunction TJvExplorerGroupCheckBoxItem.CreateBarItemViewer: TJvExplorerCustomBarItemViewer;\r\nbegin\r\n Result := TJvExplorerCheckBoxItemViewer.Create(Self);\r\nend;\r\n\r\nprocedure TJvExplorerGroupCheckBoxItem.ItemClick;\r\nbegin\r\n Checked := not Checked;\r\n inherited ItemClick;\r\nend;\r\n\r\n{ TJvExplorerCheckBoxItemViewer }\r\n\r\nprocedure TJvExplorerCheckBoxItemViewer.Draw(Bitmap: TBitmap; var X, Y, Width: Integer);\r\nvar\r\n EndStr: string;\r\n ARect: TRect;\r\nbegin\r\n with Bitmap.Canvas do\r\n begin\r\n if bisHot in Item.State then\r\n begin\r\n Font.Style := [fsUnderline];\r\n Font.Color := ExplorerBar.ColourSet.TextHot;\r\n end\r\n else\r\n begin\r\n Font.Style := [];\r\n Font.Color := ExplorerBar.ColourSet.Text;\r\n end;\r\n\r\n if not TJvExplorerGroupCheckBoxItem(Item).Enabled then\r\n begin\r\n Font.Style := Font.Style - [fsUnderline];\r\n Font.Color := ExplorerBar.ColourSet.Text;\r\n end;\r\n\r\n if (TJvExplorerGroupCheckBoxItem(Item).Checked) and (TJvExplorerGroupCheckBoxItem(Item).Enabled) then\r\n Font.Style := Font.Style + [fsbold]\r\n else\r\n Font.Style := Font.Style - [fsbold];\r\n\r\n ARect := Rect(X + JvExplorerConstXOffset, Y, X + JvExplorerConstXOffset +\r\n ExplorerBar.ThemeElements.CheckBoxWidth, Y + Item.Height);\r\n if TJvExplorerGroupCheckBoxItem(Item).Checked then\r\n DrawCheck(Bitmap.Canvas, ARect, cbChecked, TJvExplorerGroupCheckBoxItem(Item).Enabled)\r\n else\r\n DrawCheck(Bitmap.Canvas, ARect, cbUnchecked, TJvExplorerGroupCheckBoxItem(Item).Enabled);\r\n ARect := Rect(X + (JvExplorerConstXOffset * 3), Y,\r\n Item.ExplorerGroup.Width - JvExplorerConstXOffset, Y + Item.Height);\r\n\r\n EndStr := Item.Caption;\r\n Brush.Style := bsClear;\r\n {$IFDEF COMPILER9_UP}\r\n TextRect(ARect, EndStr, [tfSingleLine, tfEndEllipsis, tfVerticalCenter, tfLeft]);\r\n {$ELSE}\r\n DrawText(Handle, PChar(EndStr), -1, ARect, DT_SINGLELINE or DT_VCENTER or DT_LEFT);\r\n {$ENDIF COMPILER9_UP}\r\n Item.ClientAreaRectangle := Rect(X + JvExplorerConstXOffset, Y,\r\n Item.ExplorerGroup.Width - (JvExplorerConstXOffset), Y + Item.Height);\r\n Inc(Y, TextHeight('A') + JvExplorerConstLineYOffset);\r\n end;\r\n // Inc(Y, JvExplorerConstYOffset div 2);\r\n inherited Draw(Bitmap, X, Y, Width);\r\nend;\r\n\r\nprocedure TJvExplorerCheckBoxItemViewer.DrawCheck(Canvas: TCanvas; R: TRect; AState: TCheckBoxState;\r\n AEnabled: Boolean);\r\nvar\r\n DrawRect: TRect;\r\n DrawState: Integer;\r\n {$IFDEF JVCLThemesEnabled}\r\n Element: TThemedElementDetails;\r\n {$ENDIF JVCLThemesEnabled}\r\nbegin\r\n DrawRect.Left := R.Left + (R.Right - R.Left - ExplorerBar.ThemeElements.CheckBoxWidth) div 2;\r\n DrawRect.Top := R.Top + (R.Bottom - R.Top - ExplorerBar.ThemeElements.CheckBoxWidth) div 2;\r\n DrawRect.Right := DrawRect.Left + Item.Width;\r\n DrawRect.Bottom := DrawRect.Top + Item.Height;\r\n\r\n {$IFDEF JVCLThemesEnabled}\r\n if {$IFDEF RTL230_UP}StyleServices.Enabled{$ELSE}ThemeServices.ThemesEnabled{$ENDIF RTL230_UP} then\r\n begin\r\n case AState of\r\n cbChecked:\r\n Element := {$IFDEF RTL230_UP}StyleServices{$ELSE}ThemeServices{$ENDIF RTL230_UP}.GetElementDetails(tbCheckBoxCheckedNormal);\r\n cbUnchecked:\r\n Element := {$IFDEF RTL230_UP}StyleServices{$ELSE}ThemeServices{$ENDIF RTL230_UP}.GetElementDetails(tbCheckBoxUncheckedNormal);\r\n else\r\n Element := {$IFDEF RTL230_UP}StyleServices{$ELSE}ThemeServices{$ENDIF RTL230_UP}.GetElementDetails(tbCheckBoxUncheckedNormal);\r\n end;\r\n if not AEnabled then\r\n Element := {$IFDEF RTL230_UP}StyleServices{$ELSE}ThemeServices{$ENDIF RTL230_UP}.GetElementDetails(tbCheckBoxUncheckedDisabled);\r\n {$IFDEF RTL230_UP}StyleServices{$ELSE}ThemeServices{$ENDIF RTL230_UP}.DrawElement(Canvas.Handle, Element, R);\r\n end\r\n else\r\n {$ENDIF JVCLThemesEnabled}\r\n begin\r\n case AState of\r\n cbChecked:\r\n DrawState := DFCS_BUTTONCHECK or DFCS_CHECKED;\r\n cbUnchecked:\r\n DrawState := DFCS_BUTTONCHECK;\r\n else\r\n DrawState := DFCS_BUTTON3STATE or DFCS_CHECKED;\r\n end;\r\n if not AEnabled then\r\n DrawState := DrawState or DFCS_INACTIVE;\r\n DrawFrameControl(Canvas.Handle, DrawRect, DFC_BUTTON, DrawState);\r\n end;\r\nend;\r\n\r\n{ TJvExplorerButtonItemViewer }\r\n\r\nprocedure TJvExplorerButtonItemViewer.Draw(Bitmap: TBitmap; var X, Y, Width: Integer);\r\nvar\r\n ARect: TRect;\r\n Caption: string;\r\nbegin\r\n with Bitmap.Canvas do\r\n begin\r\n if bisHot in Item.State then\r\n Font.Color := ExplorerBar.ColourSet.TextHot\r\n else\r\n Font.Color := ExplorerBar.ColourSet.Text;\r\n\r\n if not Item.Enabled then\r\n Font.Color := ExplorerBar.ColourSet.Text;\r\n\r\n Caption := Item.Caption;\r\n ARect := Rect(X + JvExplorerConstXOffset, Y, Item.ExplorerGroup.Width - JvExplorerConstXOffset,\r\n Y + Item.Height);\r\n DrawButton(Bitmap.Canvas, ARect, Item.Enabled, bisPushed in Item.State, bisHot in Item.State);\r\n Item.ClientAreaRectangle := ARect;\r\n Brush.Style := bsClear;\r\n // Bitmap.Canvas.TextRect(ARect,sCaption,[tfSingleLine,tfCenter,tfEndEllipsis,tfVerticalCenter]);\r\n end;\r\n Inc(Y, Item.Height);\r\n Inc(Y, JvExplorerConstYOffset div 2);\r\n // inherited Draw(Bitmap, X, Y, Width);\r\nend;\r\n\r\nprocedure TJvExplorerButtonItemViewer.DrawButton(Canvas: TCanvas; R: TRect; AEnabled, aPushed, aHot: Boolean);\r\nvar\r\n DrawRect: TRect;\r\n {$IFDEF JVCLThemesEnabled}\r\n element: TThemedElementDetails;\r\n {$ENDIF JVCLThemesEnabled}\r\n DrawState: Integer;\r\nbegin\r\n DrawRect.Left := R.Left;\r\n DrawRect.Top := R.Top;\r\n DrawRect.Right := R.Right;\r\n DrawRect.Bottom := R.Bottom;\r\n\r\n {$IFDEF JVCLThemesEnabled}\r\n if {$IFDEF RTL230_UP}StyleServices.Enabled{$ELSE}ThemeServices.ThemesEnabled{$ENDIF RTL230_UP} then\r\n begin\r\n if not AEnabled then\r\n element := {$IFDEF RTL230_UP}StyleServices{$ELSE}ThemeServices{$ENDIF RTL230_UP}.GetElementDetails(tbPushButtonDisabled)\r\n else if aPushed then\r\n element := {$IFDEF RTL230_UP}StyleServices{$ELSE}ThemeServices{$ENDIF RTL230_UP}.GetElementDetails(tbPushButtonPressed)\r\n else if aHot then\r\n element := {$IFDEF RTL230_UP}StyleServices{$ELSE}ThemeServices{$ENDIF RTL230_UP}.GetElementDetails(tbPushButtonHot)\r\n else\r\n element := {$IFDEF RTL230_UP}StyleServices{$ELSE}ThemeServices{$ENDIF RTL230_UP}.GetElementDetails(tbPushButtonNormal);\r\n {$IFDEF RTL230_UP}StyleServices{$ELSE}ThemeServices{$ENDIF RTL230_UP}.DrawElement(Canvas.Handle, element, DrawRect);\r\n end\r\n else\r\n {$ENDIF JVCLThemesEnabled}\r\n begin\r\n if aPushed then\r\n DrawState := DFCS_BUTTONPUSH OR DFCS_PUSHED\r\n else\r\n DrawState := DFCS_BUTTONPUSH;\r\n if not AEnabled then\r\n DrawState := DrawState or DFCS_INACTIVE;\r\n DrawFrameControl(Canvas.Handle, DrawRect, DFC_BUTTON, DrawState);\r\n end;\r\nend;\r\n\r\nprocedure TJvExplorerButtonItemViewer.Measure(Bitmap: TBitmap; var X, Y, Width: Integer);\r\nbegin\r\n Inc(Y, Item.Height);\r\n Inc(Y, JvExplorerConstYOffset div 2);\r\n // inherited Draw(Bitmap, X, Y, Width);\r\nend;\r\n\r\n{ TJvExplorerGroupButtonItem }\r\n\r\nconstructor TJvExplorerGroupButtonItem.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n Height := 23;\r\n HotTracking := True;\r\nend;\r\n\r\nfunction TJvExplorerGroupButtonItem.CreateBarItemViewer: TJvExplorerCustomBarItemViewer;\r\nbegin\r\n Result := TJvExplorerButtonItemViewer.Create(Self);\r\nend;\r\n\r\nprocedure TJvExplorerGroupButtonItem.ItemClick;\r\nbegin\r\n Self.State := [bisPushed, bisHot];\r\n try\r\n inherited ItemClick;\r\n finally\r\n Self.State := [bisHot];\r\n end;\r\nend;\r\n\r\n{ TJvExplorerPictureItemViewer }\r\n\r\nprocedure TJvExplorerPictureItemViewer.Draw(Bitmap: TBitmap; var X, Y, Width: Integer);\r\nvar\r\n W: Integer;\r\n R: TRect;\r\n Graphic: TGraphic;\r\nbegin\r\n Graphic := TJvExplorerGroupPictureItem(Item).Picture.Graphic;\r\n if Graphic <> nil then\r\n if ExplorerBar.Width < JvExplorerConstDefaultWidth then\r\n begin\r\n W := ExplorerBar.Width - JvExplorerConstScollbarWidth - 4 * JvExplorerConstXOffset;\r\n if TJvExplorerGroupPictureItem(Item).Stretch then\r\n begin\r\n Bitmap.Canvas.StretchDraw(Rect(X + (Width - W) div 2, Y, X + Width - (Width - W) div 2,\r\n Y + Graphic.Height * W div Graphic.Width), Graphic);\r\n Item.ClientAreaRectangle := Rect(X + (Width - W) div 2, Y, X + Width - (Width - W) div 2,\r\n Y + Graphic.Height * W div Graphic.Width);\r\n Inc(Y, Graphic.Height * W div Graphic.Width + JvExplorerConstYOffset);\r\n end\r\n else\r\n begin\r\n Bitmap.Canvas.Draw(X + (Width - W) div 2, Y, Graphic);\r\n Item.ClientAreaRectangle := Rect(X + (Width - W) div 2, Y,\r\n X + (Width - W) div 2 + Graphic.Width, Y + Graphic.Height);\r\n Inc(Y, Graphic.Height + JvExplorerConstYOffset);\r\n end;\r\n end\r\n else\r\n begin\r\n Bitmap.Canvas.Draw(X + (Width - Graphic.Width) div 2, Y, Graphic);\r\n Item.ClientAreaRectangle := Rect(X + (Width - Graphic.Width)\r\n div 2, Y, X + (Width - Graphic.Width) div 2 + Graphic.Width, Y + Graphic.Height);\r\n Inc(Y, Graphic.Height + JvExplorerConstYOffset);\r\n end;\r\n\r\n if Item.MouseInControl and Item.HotTracking then\r\n begin\r\n Bitmap.Canvas.Brush.Color := ExplorerBar.ColourSet.TextHot;\r\n R := Item.ClientAreaRectangle;\r\n InflateRect(R, 2, 2);\r\n Bitmap.Canvas.FrameRect(R);\r\n Bitmap.Canvas.Brush.Style := bsClear;\r\n end;\r\n // inherited Draw(Bitmap, X, Y, Width);\r\nend;\r\n\r\nprocedure TJvExplorerPictureItemViewer.Measure(Bitmap: TBitmap; var X, Y, Width: Integer);\r\nvar\r\n W: Integer;\r\n Graphic: TGraphic;\r\nbegin\r\n Graphic := TJvExplorerGroupPictureItem(Item).Picture.Graphic;\r\n if Graphic <> nil then\r\n if ExplorerBar.Width < JvExplorerConstDefaultWidth then\r\n begin\r\n if TJvExplorerGroupPictureItem(Item).Stretch then\r\n begin\r\n W := ExplorerBar.Width - JvExplorerConstScollbarWidth - 4 *\r\n JvExplorerConstXOffset;\r\n Inc(Y, Graphic.Height * W div Graphic.Width + JvExplorerConstYOffset);\r\n end\r\n else\r\n Inc(Y, Graphic.Height + JvExplorerConstYOffset);\r\n end\r\n else\r\n Inc(Y, Graphic.Height + JvExplorerConstYOffset);\r\n\r\n // Inc(Y, JvExplorerConstYOffset);\r\n // inherited Measure(Bitmap, X, Y, Width);\r\nend;\r\n\r\n{ TJvExplorerGroupPictureItem }\r\n\r\nconstructor TJvExplorerGroupPictureItem.Create;\r\nbegin\r\n inherited Create(AOwner);\r\n FPicture := TPicture.Create;\r\n FPicture.OnChange := PictureChange;\r\n FStretch := True;\r\nend;\r\n\r\ndestructor TJvExplorerGroupPictureItem.Destroy;\r\nbegin\r\n FPicture.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJvExplorerGroupPictureItem.CreateBarItemViewer: TJvExplorerCustomBarItemViewer;\r\nbegin\r\n Result := TJvExplorerPictureItemViewer.Create(Self);\r\nend;\r\n\r\n{\r\n if Stretch then\r\n begin\r\n Graphic.Width := JvExplorerConstDefaultWidth - JvExplorerConstScollbarWidth - 4 *\r\n JvExplorerConstXOffset;\r\n Graphic.Height := Value.Height * (JvExplorerConstDefaultWidth - JvExplorerConstScollbarWidth -\r\n 4 * JvExplorerConstXOffset) div Value.Width;\r\n TBitmap(Graphic).Canvas.StretchDraw(TBitmap(Graphic).Canvas.ClipRect, Value);\r\n end\r\n}\r\nprocedure TJvExplorerGroupPictureItem.LoadFromFile(const AFilename: string);\r\nbegin\r\n if FileExists(AFilename) then\r\n FPicture.LoadFromFile(AFilename);\r\nend;\r\n\r\nprocedure TJvExplorerGroupPictureItem.PictureChange(Sender: TObject);\r\nbegin\r\n NotifyPaint;\r\nend;\r\n\r\nprocedure TJvExplorerGroupPictureItem.SetPicture(Value: TPicture);\r\nbegin\r\n FPicture.Assign(Value);\r\nend;\r\n\r\nprocedure TJvExplorerGroupPictureItem.SetStretch(const Value: Boolean);\r\nbegin\r\n if Value <> FStretch then\r\n begin\r\n FStretch := Value;\r\n if (FPicture.Graphic <> nil) and not FPicture.Graphic.Empty then\r\n NotifyPaint;\r\n end;\r\nend;\r\n\r\n{ TJvExplorerGroupSeparatorItem }\r\n\r\nconstructor TJvExplorerGroupSeparatorItem.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FColor := clNavy;\r\nend;\r\n\r\nfunction TJvExplorerGroupSeparatorItem.CreateBarItemViewer: TJvExplorerCustomBarItemViewer;\r\nbegin\r\n Result := TJvExplorerSeparatorItemViewer.Create(Self);\r\nend;\r\n\r\nprocedure TJvExplorerGroupSeparatorItem.SetColor(const Value: TColor);\r\nbegin\r\n if Value <> FColor then\r\n begin\r\n FColor := Value;\r\n NotifyPaint;\r\n end;\r\nend;\r\n\r\n{ TJvExplorerSeparatorItemViewer }\r\n\r\nprocedure TJvExplorerSeparatorItemViewer.Draw(Bitmap: TBitmap; var X, Y, Width: Integer);\r\nbegin\r\n with Bitmap.Canvas do\r\n begin\r\n Pen.Color := TJvExplorerGroupSeparatorItem(Item).Color;\r\n MoveTo(X + 5, Y + (JvExplorerConstYOffset div 2));\r\n LineTo(Width - 5, Y + (JvExplorerConstYOffset div 2));\r\n Inc(Y, JvExplorerConstYOffset);\r\n end;\r\nend;\r\n\r\nprocedure TJvExplorerSeparatorItemViewer.Measure(Bitmap: TBitmap; var X, Y, Width: Integer);\r\nbegin\r\n Inc(Y, JvExplorerConstYOffset);\r\nend;\r\n\r\n{ TJvExplorerGroupSpacerItem }\r\n\r\nconstructor TJvExplorerGroupSpacerItem.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n Height := JvExplorerConstYOffset;\r\nend;\r\n\r\nfunction TJvExplorerGroupSpacerItem.CreateBarItemViewer: TJvExplorerCustomBarItemViewer;\r\nbegin\r\n Result := TJvExplorerSpacerItemViewer.Create(Self);\r\nend;\r\n\r\n{ TJvExplorerSpacerItemViewer }\r\n\r\nprocedure TJvExplorerSpacerItemViewer.Draw(Bitmap: TBitmap; var X, Y, Width: Integer);\r\nbegin\r\n Inc(Y, Item.Height);\r\n // inherited Draw(Bitmap, X, Y, Width);\r\nend;\r\n\r\nprocedure TJvExplorerSpacerItemViewer.Measure(Bitmap: TBitmap; var X, Y, Width: Integer);\r\nbegin\r\n Inc(Y, Item.Height);\r\n // inherited Measure(Bitmap,X,Y,Width);\r\nend;\r\n\r\n{ TJvExplorerGroupProgressBarItem }\r\n\r\nfunction TJvExplorerGroupProgressBarItem.CreateBarItemViewer: TJvExplorerCustomBarItemViewer;\r\nbegin\r\n Result := TJvExplorerProgressBarItemViewer.Create(Self);\r\nend;\r\n\r\n{ TJvExplorerProgressBarItemViewer }\r\n\r\nprocedure TJvExplorerProgressBarItemViewer.Draw(Bitmap: TBitmap; var X, Y, Width: Integer);\r\nvar\r\n {$IFDEF JVCLThemesEnabled}\r\n element: TThemedElementDetails;\r\n {$ENDIF JVCLThemesEnabled}\r\n R: TRect;\r\n aItem: TJvExplorerGroupProgressBarItem;\r\nbegin\r\n aItem := TJvExplorerGroupProgressBarItem(Item);\r\n with Bitmap.Canvas do\r\n begin\r\n R := Rect(X + JvExplorerConstXOffset, Y, X + Width - JvExplorerConstXOffset, Y + Item.Height);\r\n\r\n {$IFDEF JVCLThemesEnabled}\r\n if {$IFDEF RTL230_UP}StyleServices.Enabled{$ELSE}ThemeServices.ThemesEnabled{$ENDIF RTL230_UP} then\r\n begin\r\n element := {$IFDEF RTL230_UP}StyleServices{$ELSE}ThemeServices{$ENDIF RTL230_UP}.GetElementDetails(tpBar);\r\n {$IFDEF RTL230_UP}StyleServices{$ELSE}ThemeServices{$ENDIF RTL230_UP}.DrawElement(Handle, element, R);\r\n if (aItem.Position > 0) and (aItem.Max > 0) then\r\n R := Rect(X + JvExplorerConstXOffset + 2, Y + 2, X + JvExplorerConstXOffset + 2 +\r\n Round((Width - 2 * JvExplorerConstXOffset - 4) * (aItem.Position - aItem.Min) /\r\n (aItem.Max - aItem.Min)), Y + Item.Height - 2);\r\n element := {$IFDEF RTL230_UP}StyleServices{$ELSE}ThemeServices{$ENDIF RTL230_UP}.GetElementDetails(tpChunk);\r\n {$IFDEF RTL230_UP}StyleServices{$ELSE}ThemeServices{$ENDIF RTL230_UP}.DrawElement(Handle, element, R);\r\n end\r\n else\r\n {$ENDIF JVCLThemesEnabled}\r\n begin\r\n Pen.Color := TJvExplorerGroupProgressBarItem(Item).BorderColour;\r\n Rectangle(X + JvExplorerConstXOffset, Y, X + Width - JvExplorerConstXOffset, Y + Item.Height);\r\n Brush.Color := aItem.FillColour;\r\n if (aItem.Position > 0) and (aItem.Max > 0) then\r\n FillRect(Rect(X + JvExplorerConstXOffset + 2, Y + 2, X + JvExplorerConstXOffset + 2 +\r\n Round((Width - 2 * JvExplorerConstXOffset - 4) * (aItem.Position - aItem.Min) /\r\n (aItem.Max - aItem.Min)), Y + Item.Height - 2));\r\n end;\r\n Inc(Y, Item.Height + JvExplorerConstYOffset);\r\n Item.ClientAreaRectangle := Rect(X + JvExplorerConstXOffset, Y,\r\n X + Width - JvExplorerConstXOffset, Y + Item.Height);\r\n end;\r\n // inherited Draw(Bitmap, X, Y, Width);\r\nend;\r\n\r\nprocedure TJvExplorerProgressBarItemViewer.Measure(Bitmap: TBitmap; var X, Y, Width: Integer);\r\nbegin\r\n Inc(Y, Item.Height + JvExplorerConstYOffset);\r\n // inherited Measure(Bitmap, X, Y, Width);\r\nend;\r\n\r\n{ TJvExplorerGroupItemActionLink }\r\n\r\nfunction TJvExplorerGroupItemActionLink.Update: Boolean;\r\nbegin\r\n Result := inherited Update;\r\n FActionItem.Caption := TAction(Self.Action).Caption;\r\n FActionItem.Enabled := TAction(Self.Action).Enabled;\r\nend;\r\n\r\nprocedure TJvExplorerGroupItemActionLink.AssignClient(AClient: TObject);\r\nbegin\r\n inherited AssignClient(AClient);\r\n FActionItem := TJvExplorerGroupActionItem(AClient);\r\nend;\r\n\r\nprocedure TJvExplorerGroupItemActionLink.Change;\r\nbegin\r\n inherited Change;\r\n FActionItem.Caption := TAction(Self.Action).Caption;\r\n FActionItem.Enabled := TAction(Self.Action).Enabled;\r\nend;\r\n\r\nprocedure TJvExplorerGroupItemActionLink.SetEnabled(Value: Boolean);\r\nbegin\r\n inherited SetEnabled(Value);\r\n FActionItem.Enabled := Value;\r\n FActionItem.FontStyle := [];\r\nend;\r\n\r\n{ TExActionItem }\r\n\r\nconstructor TJvExplorerGroupActionItem.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n HotTracking := True;\r\nend;\r\n\r\ndestructor TJvExplorerGroupActionItem.Destroy;\r\nbegin\r\n FActionLink.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvExplorerGroupActionItem.SetAction(const Value: TAction);\r\nbegin\r\n if FActionLink = nil then\r\n FActionLink := TJvExplorerGroupItemActionLink.Create(Self)\r\n else\r\n begin\r\n FActionLink.Free;\r\n FActionLink := TJvExplorerGroupItemActionLink.Create(Self);\r\n end;\r\n FActionLink.Action := Value;\r\n Self.Enabled := GetAction.Enabled;\r\n Self.Caption := GetAction.Caption;\r\nend;\r\n\r\nfunction TJvExplorerGroupActionItem.GetAction: TAction;\r\nbegin\r\n Result := TAction(FActionLink.Action);\r\nend;\r\n\r\nfunction TJvExplorerGroupActionItem.CreateBarItemViewer: TJvExplorerCustomBarItemViewer;\r\nbegin\r\n Result := TJvExplorerActionItemViewer.Create(Self);\r\nend;\r\n\r\nfunction TJvExplorerGroupActionItem.IsEnabled: Boolean;\r\nbegin\r\n Result := Enabled and Action.Enabled;\r\nend;\r\n\r\nprocedure TJvExplorerGroupActionItem.ItemClick;\r\nbegin\r\n if Action <> nil then\r\n Action.Execute;\r\n inherited ItemClick;\r\nend;\r\n\r\n{ TActionItemViewer }\r\n\r\nprocedure TJvExplorerActionItemViewer.Draw(Bitmap: TBitmap; var X, Y, Width: Integer);\r\nvar\r\n IconX, IconY: Integer;\r\n R: TRect;\r\nbegin\r\n if bisHot in Item.State then\r\n begin\r\n Bitmap.Canvas.Font.Style := [fsUnderline];\r\n Bitmap.Canvas.Font.Color := ExplorerBar.ColourSet.TextHot;\r\n end\r\n else\r\n begin\r\n Bitmap.Canvas.Font.Style := Item.FontStyle;\r\n Bitmap.Canvas.Font.Color := ExplorerBar.ColourSet.Text;\r\n end;\r\n if not TJvExplorerGroupActionItem(Item).Action.Enabled then\r\n Bitmap.Canvas.Font.Color := clGrayText;\r\n\r\n IconX := X;\r\n IconY := Y;\r\n DrawIcon(Bitmap, IconX, IconY, Width);\r\n SetRect(R, IconX, Y, Width, Y + TJvExplorerBarText.HeightOf(Bitmap.Canvas, Item.Caption, Width));\r\n DrawCaption(Bitmap, X, Y, R, 0);\r\n inherited Draw(Bitmap, X, Y, Width);\r\nend;\r\n\r\nprocedure TJvExplorerActionItemViewer.Measure(Bitmap: TBitmap; var X, Y, Width: Integer);\r\nbegin\r\n if TJvExplorerGroupActionItem(Item).Action <> nil then\r\n TJvExplorerGroupActionItem(Item).Action.Update;\r\n inherited Measure(Bitmap, X, Y, Width);\r\nend;\r\n\r\n{ TJvExplorerGroupSimpleProgressBarItem }\r\n\r\nconstructor TJvExplorerGroupSimpleProgressBarItem.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FMin := 0;\r\n FMax := 0;\r\n FPosition := 0;\r\n Height := 19;\r\n FBorderColor := clGreen;\r\n FFillColor := clLime;\r\nend;\r\n\r\nfunction TJvExplorerGroupSimpleProgressBarItem.CreateBarItemViewer: TJvExplorerCustomBarItemViewer;\r\nbegin\r\n Result := TJvExplorerSimpleProgressBarItemViewer.Create(Self);\r\nend;\r\n\r\n{ TJvExplorerSimpleProgressBarItemViewer }\r\n\r\nprocedure TJvExplorerSimpleProgressBarItemViewer.Draw(Bitmap: TBitmap; var X, Y, Width: Integer);\r\nvar\r\n R: TRect;\r\n ProgressItem: TJvExplorerGroupSimpleProgressBarItem;\r\nbegin\r\n ProgressItem := TJvExplorerGroupSimpleProgressBarItem(Item);\r\n with Bitmap.Canvas do\r\n begin\r\n R := Rect(X + JvExplorerConstXOffset, Y, X + Width - JvExplorerConstXOffset, Y + Item.Height);\r\n Pen.Color := TJvExplorerGroupSimpleProgressBarItem(Item).BorderColour;\r\n Rectangle(X + JvExplorerConstXOffset, Y, X + Width - JvExplorerConstXOffset, Y + Item.Height);\r\n Brush.Color := ProgressItem.FillColour;\r\n if (ProgressItem.Position > 0) and (ProgressItem.Max > 0) then\r\n FillRect(Rect(X + JvExplorerConstXOffset + 2, Y + 2, X + JvExplorerConstXOffset + 2 +\r\n Round((Width - 2 * JvExplorerConstXOffset - 4) * (ProgressItem.Position - ProgressItem.Min) /\r\n (ProgressItem.Max - ProgressItem.Min)), Y + Item.Height - 2));\r\n Inc(Y, Item.Height + JvExplorerConstYOffset);\r\n Brush.Style := bsClear;\r\n Item.ClientAreaRectangle := Rect(X + JvExplorerConstXOffset, Y,\r\n X + Width - JvExplorerConstXOffset, Y + Item.Height);\r\n end;\r\nend;\r\n\r\nprocedure TJvExplorerSimpleProgressBarItemViewer.Measure(Bitmap: TBitmap; var X, Y, Width: Integer);\r\nbegin\r\n Inc(Y, Item.Height + JvExplorerConstYOffset);\r\nend;\r\n\r\n{ TJvExplorerCustomGroupProgressBarItem }\r\n\r\nconstructor TJvExplorerCustomGroupProgressBarItem.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FMin := 0;\r\n FMax := 0;\r\n FPosition := 0;\r\n Height := 19;\r\n FBorderColor := cl3DDkShadow;\r\n FFillColor := clBtnShadow;\r\nend;\r\n\r\nprocedure TJvExplorerCustomGroupProgressBarItem.SetBorderColor(const Value: TColor);\r\nbegin\r\n if Value <> FBorderColor then\r\n begin\r\n FBorderColor := Value;\r\n NotifyPaint;\r\n end;\r\nend;\r\n\r\nprocedure TJvExplorerCustomGroupProgressBarItem.SetFillColor(const Value: TColor);\r\nbegin\r\n if Value <> FFillColor then\r\n begin\r\n FFillColor := Value;\r\n NotifyPaint;\r\n end;\r\nend;\r\n\r\nprocedure TJvExplorerCustomGroupProgressBarItem.SetMax(Value: Integer);\r\nbegin\r\n if Value <> FMax then\r\n begin\r\n FMax := Value;\r\n NotifyPaint;\r\n end;\r\nend;\r\n\r\nprocedure TJvExplorerCustomGroupProgressBarItem.SetMin(Value: Integer);\r\nbegin\r\n if Value <> FMin then\r\n begin\r\n FMin := Value;\r\n NotifyPaint;\r\n end;\r\nend;\r\n\r\nprocedure TJvExplorerCustomGroupProgressBarItem.SetPosition(Value: Integer);\r\nbegin\r\n if Value <> FPosition then\r\n begin\r\n FPosition := Value;\r\n NotifyPaint;\r\n end;\r\nend;\r\n\r\n{ TCustomDrawProgressBarItemViewer }\r\n\r\nprocedure TJvExplorerCustomDrawProgressBarItemViewer.Draw(Bitmap: TBitmap; var X, Y, Width: Integer);\r\nbegin\r\n HandleCustomDrawBarItem(Item, Bitmap, X, Y, Width);\r\nend;\r\n\r\nprocedure TJvExplorerCustomDrawProgressBarItemViewer.Measure(Bitmap: TBitmap; var X, Y, Width: Integer);\r\nbegin\r\n HandleCustomMeasureBarItem(Item, Bitmap, X, Y, Width);\r\nend;\r\n\r\n{ TGroupCustomDrawProgressBarItem }\r\n\r\nfunction TJvExplorerGroupCustomDrawProgressBarItem.CreateBarItemViewer: TJvExplorerCustomBarItemViewer;\r\nbegin\r\n Result := TJvExplorerCustomDrawProgressBarItemViewer.Create(Self);\r\nend;\r\n\r\n{ TCustomDrawBarItemViewer }\r\n\r\nprocedure TJvExplorerCustomDrawBarItemViewer.Draw(Bitmap: TBitmap; var X, Y, Width: Integer);\r\nbegin\r\n HandleCustomDrawBarItem(Item, Bitmap, X, Y, Width);\r\nend;\r\n\r\nprocedure TJvExplorerCustomDrawBarItemViewer.Measure(Bitmap: TBitmap; var X, Y, Width: Integer);\r\nbegin\r\n HandleCustomMeasureBarItem(Item, Bitmap, X, Y, Width);\r\nend;\r\n\r\n{ TGroupCustomDrawBarItem }\r\n\r\nfunction TJvExplorerGroupCustomDrawBarItem.CreateBarItemViewer: TJvExplorerCustomBarItemViewer;\r\nbegin\r\n Result := TJvExplorerCustomDrawBarItemViewer.Create(Self);\r\nend;\r\n\r\n{ TGroupOptionButtonsItemViewer }\r\n\r\nprocedure TJvExplorerGroupOptionButtonsItemViewer.Draw(Bitmap: TBitmap; var X, Y, Width: Integer);\r\nvar\r\n I: Integer;\r\n ARadioRect, ACaptionRect: TRect;\r\nbegin\r\n with Bitmap.Canvas do\r\n begin\r\n Brush.Style := bsClear;\r\n Font.Style := [];\r\n ARadioRect := Rect(X + JvExplorerConstXOffset, Y, X + JvExplorerConstXOffset +\r\n ExplorerBar.ThemeElements.CheckBoxWidth, Y + Item.Height);\r\n ACaptionRect := Rect(X + (JvExplorerConstXOffset + JvExplorerConstXGap) +\r\n ExplorerBar.ThemeElements.CheckBoxWidth, Y, Width, Y + Item.Height);\r\n\r\n for I := 0 to TJvExplorerGroupOptionButtonsItem(Item).Items.Count - 1 do\r\n begin\r\n if I = TJvExplorerGroupOptionButtonsItem(Item).ItemIndex then\r\n begin\r\n Font.Style := [fsbold];\r\n DrawRadio(Bitmap.Canvas, ARadioRect, cbChecked, True)\r\n end\r\n else\r\n begin\r\n Font.Style := [];\r\n DrawRadio(Bitmap.Canvas, ARadioRect, cbUnchecked, True);\r\n end;\r\n DrawText(Handle, PChar(TJvExplorerGroupOptionButtonsItem(Item).Items[I]), -1, ACaptionRect,\r\n DT_SINGLELINE or DT_VCENTER or DT_LEFT or DT_END_ELLIPSIS);\r\n OffsetRect(ARadioRect, 0, ExplorerBar.ThemeElements.CheckBoxHeight + 3);\r\n OffsetRect(ACaptionRect, 0, ExplorerBar.ThemeElements.CheckBoxHeight + 3);\r\n Font.Style := [];\r\n end;\r\n Item.ClientAreaRectangle := Rect(X + JvExplorerConstXOffset, Y,\r\n Width - (JvExplorerConstXOffset), Y + TJvExplorerGroupOptionButtonsItem(Item).Items.Count *\r\n (ExplorerBar.ThemeElements.CheckBoxHeight + 3) + (TextHeight('a')));\r\n Inc(Y, TextHeight('A') + JvExplorerConstLineYOffset);\r\n end;\r\n Inc(Y, TJvExplorerGroupOptionButtonsItem(Item).Items.Count *\r\n (ExplorerBar.ThemeElements.CheckBoxHeight + 3));\r\nend;\r\n\r\nprocedure TJvExplorerGroupOptionButtonsItemViewer.DrawRadio(Canvas: TCanvas; R: TRect; AState: TCheckBoxState;\r\n AEnabled: Boolean);\r\nvar\r\n DrawRect: TRect;\r\n DrawState: Integer;\r\n {$IFDEF JVCLThemesEnabled}\r\n Element: TThemedElementDetails;\r\n {$ENDIF JVCLThemesEnabled}\r\nbegin\r\n DrawRect.Left := R.Left +\r\n (R.Right - R.Left - ExplorerBar.ThemeElements.CheckBoxWidth) div 2;\r\n DrawRect.Top := R.Top + (R.Bottom - R.Top - ExplorerBar.ThemeElements.\r\n CheckBoxWidth) div 2;\r\n DrawRect.Right := DrawRect.Left + Item.Width;\r\n DrawRect.Bottom := DrawRect.Top + Item.Height;\r\n\r\n {$IFDEF JVCLThemesEnabled}\r\n if {$IFDEF RTL230_UP}StyleServices.Enabled{$ELSE}ThemeServices.ThemesEnabled{$ENDIF RTL230_UP} then\r\n begin\r\n case AState of\r\n cbChecked:\r\n Element := {$IFDEF RTL230_UP}StyleServices{$ELSE}ThemeServices{$ENDIF RTL230_UP}.GetElementDetails(tbRadioButtonCheckedNormal);\r\n cbUnchecked:\r\n Element := {$IFDEF RTL230_UP}StyleServices{$ELSE}ThemeServices{$ENDIF RTL230_UP}.GetElementDetails(tbRadioButtonUncheckedNormal);\r\n else\r\n Element := {$IFDEF RTL230_UP}StyleServices{$ELSE}ThemeServices{$ENDIF RTL230_UP}.GetElementDetails(tbRadioButtonUncheckedNormal);\r\n end;\r\n if not AEnabled then\r\n Element := {$IFDEF RTL230_UP}StyleServices{$ELSE}ThemeServices{$ENDIF RTL230_UP}.GetElementDetails(tbRadioButtonUncheckedDisabled);\r\n {$IFDEF RTL230_UP}StyleServices{$ELSE}ThemeServices{$ENDIF RTL230_UP}.DrawElement(Canvas.Handle, Element, R);\r\n end\r\n else\r\n {$ENDIF JVCLThemesEnabled}\r\n begin\r\n case AState of\r\n cbChecked:\r\n DrawState := DFCS_BUTTONCHECK or DFCS_CHECKED;\r\n cbUnchecked:\r\n DrawState := DFCS_BUTTONCHECK;\r\n else\r\n DrawState := DFCS_BUTTON3STATE or DFCS_CHECKED;\r\n end;\r\n if not AEnabled then\r\n DrawState := DrawState or DFCS_INACTIVE;\r\n DrawFrameControl(Canvas.Handle, DrawRect, DFC_BUTTON, DrawState);\r\n end;\r\nend;\r\n\r\nprocedure TJvExplorerGroupOptionButtonsItemViewer.Measure(Bitmap: TBitmap; var X, Y, Width: Integer);\r\nbegin\r\n Inc(Y, TJvExplorerGroupOptionButtonsItem(Item).Items.Count *\r\n (ExplorerBar.ThemeElements.CheckBoxHeight + 3));\r\n Inc(Y, Bitmap.Canvas.TextHeight('A') + JvExplorerConstLineYOffset);\r\nend;\r\n\r\n{ TGroupOptionButtonsItem }\r\n\r\nconstructor TJvExplorerGroupOptionButtonsItem.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FItems := TStringList.Create;\r\n TStringList(FItems).OnChange := ItemsChange;\r\n HotTracking := True;\r\nend;\r\n\r\ndestructor TJvExplorerGroupOptionButtonsItem.Destroy;\r\nbegin\r\n Items.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvExplorerGroupOptionButtonsItem.MouseDown(Sender: TObject; X, Y: Integer);\r\nvar\r\n dwClientHeight, dwItemHeight, dwItemIndex, dwOffset: Integer;\r\nbegin\r\n dwClientHeight := ClientAreaRectangle.Bottom - ClientAreaRectangle.Top;\r\n dwItemHeight := (dwClientHeight div Items.Count);\r\n dwOffset := Y - ClientAreaRectangle.Top;\r\n dwItemIndex := (dwOffset div dwItemHeight);\r\n ItemIndex := dwItemIndex;\r\nend;\r\n\r\nfunction TJvExplorerGroupOptionButtonsItem.CreateBarItemViewer: TJvExplorerCustomBarItemViewer;\r\nbegin\r\n Result := TJvExplorerGroupOptionButtonsItemViewer.Create(Self);\r\nend;\r\n\r\nprocedure TJvExplorerGroupOptionButtonsItem.ItemsChange(Sender: TObject);\r\nbegin\r\n NotifyPaint;\r\nend;\r\n\r\nprocedure TJvExplorerGroupOptionButtonsItem.SetItemIndex(const Value: Integer);\r\nbegin\r\n if Value <> FItemIndex then\r\n begin\r\n FItemIndex := Value;\r\n NotifyPaint;\r\n end;\r\nend;\r\n\r\nprocedure TJvExplorerGroupOptionButtonsItem.SetItems(Value: TStrings);\r\nbegin\r\n if Value <> FItems then\r\n FItems.Assign(Value);\r\nend;\r\n\r\n{ TMonthCalendarItemViewer }\r\n\r\nprocedure TJvExplorerMonthCalendarItemViewer.Draw(Bitmap: TBitmap; var X, Y, Width: Integer);\r\nvar\r\n i, p, c, spDateStartPos: Integer;\r\n DayChar: Char;\r\n dy, dm, dd, diw: Integer;\r\n R: TRect;\r\n sToday: string;\r\n Year: Integer;\r\n Month: Integer;\r\nbegin\r\n Month := MonthOf(TJvExplorerGroupMonthCalendarItem(Item).CalendarDate);\r\n Year := YearOf(TJvExplorerGroupMonthCalendarItem(Item).CalendarDate);\r\n spDateStartPos := X + 15;\r\n Inc(Y, JvExplorerConstYOffset);\r\n p := 0;\r\n with Bitmap.Canvas do\r\n begin\r\n Font.Color := clWindowText;\r\n // Pen.Color := clGrayText;\r\n // Rectangle(X + JvExplorerConstXOffset, Y, Width - JvExplorerConstIconOffset, Y + Item.Height);\r\n PaintMonth(Bitmap.Canvas, GetMonthRect(Bitmap, X, Y, Width), Year, Month);\r\n Inc(Y, TextHeight('A') + 5);\r\n R := Rect(X + JvExplorerConstXOffset + spDateStartPos, Y,\r\n X + JvExplorerConstXOffset + 15, Y + TextHeight('A') + 5);\r\n Font.Color := clWindowText;\r\n Brush.Style := bsClear;\r\n for i := 1 to 7 do\r\n begin\r\n DayChar := GetDayInWeekChar(i);\r\n TextOut(R.Left - (JvExplorerConstXOffset div 2), R.Top, DayChar);\r\n OffsetRect(R, 17, 0);\r\n end;\r\n\r\n c := spDateStartPos;\r\n Inc(Y, TextHeight('A'));\r\n Pen.Color := clGrayText;\r\n MoveTo(X + JvExplorerConstXOffset, Y);\r\n LineTo(Width - 17, Y);\r\n\r\n dy := Year;\r\n dm := Month;\r\n diw := 1;\r\n dd := 1;\r\n if DayOfWeek(StartOfAMonth(Year, Month)) > 1 then\r\n begin\r\n SetPastMonth(dy, dm);\r\n dd := DaysInAMonth(dy, dm) - DayOfWeek(StartOfAMonth(Year, Month)) + 2;\r\n end;\r\n while p < 42 do\r\n begin\r\n R := Rect(c + JvExplorerConstXOffset, Y, c + JvExplorerConstXOffset + 15, Y + 15);\r\n if dm = Month then\r\n Font.Color := clWindowText\r\n else\r\n Font.Color := clGrayText;\r\n if EncodeDate(dy, dm, dd) = TJvExplorerGroupMonthCalendarItem(Item).CalendarDate then\r\n begin\r\n Font.Style := [fsbold];\r\n FrameRect(Rect(c + (JvExplorerConstXOffset div 2), Y, c + JvExplorerConstXOffset + 17, Y + 15));\r\n end;\r\n if EncodeDate(dy, dm, dd) = Today then\r\n begin\r\n Brush.Color := clMaroon;\r\n FrameRect(Rect(c + (JvExplorerConstXOffset div 2), Y, c + JvExplorerConstXOffset + 17, Y + 15));\r\n end;\r\n PaintDay(Bitmap.Canvas, dd, R);\r\n Font.Style := [];\r\n Inc(p);\r\n Inc(dd);\r\n if dd > DaysInAMonth(dy, dm) then\r\n begin\r\n SetPastMonth(dy, dm, False);\r\n dd := 1;\r\n end;\r\n Inc(c, 17);\r\n Inc(diw);\r\n if diw > 7 then\r\n begin\r\n c := spDateStartPos;\r\n Inc(Y, 15);\r\n diw := 1;\r\n end;\r\n end;\r\n Inc(Y, JvExplorerConstYOffset);\r\n sToday := FormatDateTime('dddddddd', Date);\r\n R := Rect(X + JvExplorerConstXOffset, Y, Width, Y + TextHeight('A'));\r\n Font.Color := ExplorerBar.ColourSet.TextHot;\r\n DrawText(Bitmap.Canvas.Handle, PChar(sToday), -1, R, DT_SINGLELINE or DT_END_ELLIPSIS or\r\n DT_CENTER or DT_VCENTER);\r\n Inc(Y, TJvExplorerBarText.HeightOf(Bitmap.Canvas, sToday, Width));\r\n end;\r\n Inc(Y, JvExplorerConstYOffset);\r\nend;\r\n\r\nfunction TJvExplorerMonthCalendarItemViewer.GetDayInWeekChar(DayInWeek: Integer): Char;\r\nbegin\r\n Result := ' ';\r\n if InRange(DayInWeek, 1, 7) then\r\n {$IFDEF COMPILER15_UP}\r\n Result := FormatSettings. LongDayNames[DayInWeek][1];\r\n {$ELSE}\r\n Result := LongDayNames[DayInWeek][1];\r\n {$ENDIF COMPILER15_UP}\r\nend;\r\n\r\nfunction TJvExplorerMonthCalendarItemViewer.GetMonthName(Month: Integer): String;\r\nbegin\r\n if InRange(Month, 1, 12) then\r\n {$IFDEF COMPILER15_UP}\r\n Result := FormatSettings.LongMonthNames[Month];\r\n {$ELSE}\r\n Result := LongMonthNames[Month];\r\n {$ENDIF COMPILER15_UP}\r\nend;\r\n\r\nfunction TJvExplorerMonthCalendarItemViewer.GetMonthRect(Bitmap: TBitmap; var X, Y, Width: Integer): TRect;\r\nbegin\r\n Result := Rect(X + JvExplorerConstXOffset, Y, Width - JvExplorerConstIconOffset, Y + 16);\r\nend;\r\n\r\nprocedure TJvExplorerMonthCalendarItemViewer.Measure(Bitmap: TBitmap; var X, Y, Width: Integer);\r\nvar\r\n p, c, spDateStartPos: Integer;\r\n dy, dm, dd, diw: Integer;\r\n R: TRect;\r\n Year: Integer;\r\n Month: Integer;\r\nbegin\r\n Month := MonthOf(TJvExplorerGroupMonthCalendarItem(Item).CalendarDate);\r\n Year := YearOf(TJvExplorerGroupMonthCalendarItem(Item).CalendarDate);\r\n spDateStartPos := X + 15;\r\n Inc(Y, JvExplorerConstYOffset);\r\n p := 0;\r\n with Bitmap.Canvas do\r\n begin\r\n Inc(Y, TextHeight('A') + 5);\r\n R := Rect(X + JvExplorerConstXOffset + spDateStartPos, Y,\r\n X + JvExplorerConstXOffset + 15, Y + TextHeight('A') + 5);\r\n\r\n c := spDateStartPos;\r\n Inc(Y, TextHeight('A'));\r\n\r\n dy := Year;\r\n dm := Month;\r\n diw := 1;\r\n dd := 1;\r\n if DayOfWeek(StartOfAMonth(Year, Month)) > 1 then\r\n begin\r\n SetPastMonth(dy, dm);\r\n dd := DaysInAMonth(dy, dm) - DayOfWeek(StartOfAMonth(Year, Month)) + 2;\r\n end;\r\n while p < 42 do\r\n begin\r\n R := Rect(c + JvExplorerConstXOffset, Y, c + JvExplorerConstXOffset + 15, Y + 15);\r\n // if dm = TheMonth then Font.Color := clWindowText else Font.Color := clGrayText;\r\n if EncodeDate(dy, dm, dd) = TJvExplorerGroupMonthCalendarItem(Item).CalendarDate then\r\n begin\r\n Font.Style := [fsbold];\r\n // FrameRect(Rect(c + (JvExplorerConstXOffset div 2), Y, c + JvExplorerConstXOffset +17, Y + 15));\r\n end;\r\n if EncodeDate(dy, dm, dd) = Today then\r\n begin\r\n // Brush.Color := clMaroon;\r\n // FrameRect(Rect(c + (JvExplorerConstXOffset div 2), Y, c + JvExplorerConstXOffset + 17, Y + 15));\r\n end;\r\n // PaintDay(Bitmap.Canvas,dd, r);\r\n Font.Style := [];\r\n Inc(p);\r\n Inc(dd);\r\n if dd > DaysInAMonth(dy, dm) then\r\n begin\r\n SetPastMonth(dy, dm, False);\r\n dd := 1;\r\n end;\r\n Inc(c, 17);\r\n Inc(diw);\r\n if diw > 7 then\r\n begin\r\n c := spDateStartPos;\r\n Inc(Y, 15);\r\n diw := 1;\r\n end;\r\n end;\r\n Inc(Y, TextHeight('A'));\r\n end;\r\n Inc(Y, JvExplorerConstYOffset);\r\nend;\r\n\r\nprocedure TJvExplorerMonthCalendarItemViewer.PaintDay(Canvas: TCanvas; Day: Integer; DayRect: TRect);\r\nbegin\r\n with Canvas.Brush do\r\n begin\r\n Style := bsClear;\r\n Canvas.Font.Color := clWindowText;\r\n DrawText(Canvas.Handle, PChar(IntToStr(Day)), -1, DayRect,\r\n DT_VCENTER or DT_CENTER or DT_SINGLELINE or DT_END_ELLIPSIS);\r\n Style := bsSolid;\r\n end;\r\nend;\r\n\r\nprocedure TJvExplorerMonthCalendarItemViewer.PaintMonth(Canvas: TCanvas; MonthRect: TRect; Year, Month: Integer);\r\nbegin\r\n with Canvas do\r\n begin\r\n Brush.Color := ExplorerBar.ColourSet.Background;\r\n FillRect(MonthRect);\r\n Font.Color := clWindowText;\r\n DrawText(Canvas.Handle, PChar(GetMonthName(Month) + ' ' + IntToStr(Year)), -1, MonthRect,\r\n DT_VCENTER or DT_CENTER or DT_SINGLELINE or DT_END_ELLIPSIS);\r\n end;\r\nend;\r\n\r\nprocedure TJvExplorerMonthCalendarItemViewer.SetPastMonth(var AYear, AMonth: Integer; Decrease: Boolean);\r\nbegin\r\n case Decrease of\r\n True:\r\n if AMonth > 1 then\r\n AMonth := AMonth - 1\r\n else\r\n begin\r\n AYear := AYear - 1;\r\n AMonth := 12;\r\n end;\r\n False:\r\n if AMonth < 12 then\r\n AMonth := AMonth + 1\r\n else\r\n begin\r\n AYear := AYear + 1;\r\n AMonth := 1;\r\n end;\r\n end;\r\nend;\r\n\r\n{ TJvExplorerGroupMonthCalendarItem }\r\n\r\nconstructor TJvExplorerGroupMonthCalendarItem.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n // Height:= 130;\r\n FCalendarDate := SysUtils.Date;\r\nend;\r\n\r\nfunction TJvExplorerGroupMonthCalendarItem.CreateBarItemViewer: TJvExplorerCustomBarItemViewer;\r\nbegin\r\n Result := TJvExplorerMonthCalendarItemViewer.Create(Self);\r\nend;\r\n\r\nprocedure TJvExplorerGroupMonthCalendarItem.ItemClick;\r\nbegin\r\n // No click event for the month calendar\r\nend;\r\n\r\nprocedure TJvExplorerGroupMonthCalendarItem.SetCalendarDate(const Value: TDateTime);\r\nbegin\r\n if Value <> FCalendarDate then\r\n begin\r\n FCalendarDate := Value;\r\n NotifyPaint;\r\n end;\r\nend;\r\n\r\n{ TExplorerItemFactory }\r\n\r\nclass function TJvExplorerItemFactory.Action(AGroup: TJvExplorerBarGroup; AAction: TAction;\r\n AImageList: TImageList): TJvExplorerGroupActionItem;\r\nvar\r\n Bitmap: TBitmap;\r\nbegin\r\n Result := TJvExplorerGroupActionItem(AGroup.Items.Add(TJvExplorerGroupActionItem.Create(AGroup.ExplorerBar)));\r\n if AImageList <> nil then\r\n begin\r\n Bitmap := TBitmap.Create;\r\n try\r\n AImageList.GetBitmap(AAction.ImageIndex, Bitmap);\r\n Result.Icon.Width := Bitmap.Width;\r\n Result.Icon.Height := Bitmap.Height;\r\n Result.Icon.Canvas.BrushCopy(Rect(0, 0, Result.Icon.Width, Result.Icon.Height), Bitmap,\r\n Rect(0, 0, Bitmap.Width, Bitmap.Height), clWhite);\r\n Result.Icon.Assign(Bitmap);\r\n finally\r\n Bitmap.Free;\r\n end;\r\n end;\r\n Result.Action := AAction;\r\n Result.WordWrap := True;\r\n Result.Hint := AAction.Hint;\r\nend;\r\n\r\nclass function TJvExplorerItemFactory.Action(AGroup: TJvExplorerBarGroup; AAction: TAction;\r\n AIconIndex: Integer): TJvExplorerGroupActionItem;\r\nbegin\r\n Result := TJvExplorerGroupActionItem(AGroup.Items.Add(TJvExplorerGroupActionItem.Create(AGroup.ExplorerBar)));\r\n Result.IconIndex := AIconIndex;\r\n Result.Action := AAction;\r\n Result.Hint := AAction.Hint;\r\n Result.WordWrap := True;\r\nend;\r\n\r\nclass function TJvExplorerItemFactory.Picture(AGroup: TJvExplorerBarGroup; AGraphic: TGraphic;\r\n AHotTrack, AStretch: Boolean; AIdentifier: Integer): TJvExplorerGroupPictureItem;\r\nbegin\r\n Result := TJvExplorerGroupPictureItem(AGroup.Items.Add(TJvExplorerGroupPictureItem.Create(AGroup.ExplorerBar)));\r\n Result.HotTracking := AHotTrack;\r\n Result.Stretch := AStretch;\r\n Result.Picture.Graphic := AGraphic;\r\nend;\r\n\r\nclass function TJvExplorerItemFactory.Button(AGroup: TJvExplorerBarGroup; const ACaption: string;\r\n AIdentifier: Integer): TJvExplorerGroupButtonItem;\r\nbegin\r\n Result := TJvExplorerGroupButtonItem(AGroup.Items.Add(TJvExplorerGroupButtonItem.Create(AGroup.ExplorerBar)));\r\n Result.Caption := ACaption;\r\nend;\r\n\r\nclass function TJvExplorerItemFactory.Category(AGroup: TJvExplorerBarGroup; const ACaption: string;\r\n AFontColour: TColor; AFontStyle: TFontStyles; AUnderline: Boolean): TJvExplorerGroupCategoryItem;\r\nbegin\r\n Result := TJvExplorerGroupCategoryItem(AGroup.Items.Add(TJvExplorerGroupCategoryItem.Create(AGroup.ExplorerBar)));\r\n Result.Caption := ACaption;\r\n if AFontColour > 0 then\r\n Result.FontColor := AFontColour;\r\n Result.FontStyle := AFontStyle;\r\n Result.Underlined := AUnderline;\r\nend;\r\n\r\nclass function TJvExplorerItemFactory.Checkbox(AGroup: TJvExplorerBarGroup; const ACaption: string;\r\n AChecked: Boolean = True; AEnabled: Boolean = True; AIdentifier: Integer = -1): TJvExplorerGroupCheckBoxItem;\r\nbegin\r\n Result := TJvExplorerGroupCheckBoxItem(AGroup.Items.Add(TJvExplorerGroupCheckBoxItem.Create(AGroup.ExplorerBar)));\r\n Result.Caption := ACaption;\r\n Result.Checked := AChecked;\r\n Result.Enabled := AEnabled;\r\n Result.Identifier := AIdentifier;\r\nend;\r\n\r\nclass function TJvExplorerItemFactory.CustomBarItem(AGroup: TJvExplorerBarGroup): TJvExplorerGroupCustomDrawBarItem;\r\nbegin\r\n Result := TJvExplorerGroupCustomDrawBarItem(AGroup.Items.Add(TJvExplorerGroupCustomDrawBarItem.Create(AGroup.ExplorerBar)));\r\nend;\r\n\r\nclass function TJvExplorerItemFactory.CustomProgressBar(AGroup: TJvExplorerBarGroup): TJvExplorerGroupCustomDrawProgressBarItem;\r\nbegin\r\n Result := TJvExplorerGroupCustomDrawProgressBarItem\r\n (AGroup.Items.Add(TJvExplorerGroupCustomDrawProgressBarItem.Create(AGroup.ExplorerBar)));\r\nend;\r\n\r\nclass function TJvExplorerItemFactory.Menu(AGroup: TJvExplorerBarGroup; const ACaption: string;\r\n AIdentifier, AIconIndex: Integer; const AWrap: Boolean = False): TJvExplorerGroupMenuItem;\r\nbegin\r\n Result := TJvExplorerGroupMenuItem(AGroup.Items.Add(TJvExplorerGroupMenuItem.Create(AGroup.ExplorerBar)));\r\n Result.Caption := ACaption;\r\n Result.Identifier := AIdentifier;\r\n Result.IconIndex := AIconIndex;\r\n Result.WordWrap := AWrap;\r\nend;\r\n\r\nclass function TJvExplorerItemFactory.MonthCalendar(AGroup: TJvExplorerBarGroup;\r\n const ACalendarDate: TDateTime): TJvExplorerGroupMonthCalendarItem;\r\nbegin\r\n Result := TJvExplorerGroupMonthCalendarItem(AGroup.Items.Add(TJvExplorerGroupMonthCalendarItem.Create(AGroup.ExplorerBar)));\r\nend;\r\n\r\nclass function TJvExplorerItemFactory.ProgressBar(AGroup: TJvExplorerBarGroup;\r\n AMax, AMin, APosition: Integer): TJvExplorerGroupProgressBarItem;\r\nbegin\r\n Result := TJvExplorerGroupProgressBarItem(AGroup.Items.Add(TJvExplorerGroupProgressBarItem.Create(AGroup.ExplorerBar)));\r\n Result.Max := AMax;\r\n Result.Min := AMin;\r\n Result.Position := APosition;\r\nend;\r\n\r\nclass function TJvExplorerItemFactory.RadioButtons(AGroup: TJvExplorerBarGroup;\r\n const AItems: TStrings; AIndex: Integer): TJvExplorerGroupOptionButtonsItem;\r\nbegin\r\n Result := TJvExplorerGroupOptionButtonsItem(AGroup.Items.Add(TJvExplorerGroupOptionButtonsItem.Create(AGroup.ExplorerBar)));\r\n Result.ItemIndex := AIndex;\r\n Result.Items.Assign(AItems);\r\nend;\r\n\r\nclass function TJvExplorerItemFactory.Separator(AGroup: TJvExplorerBarGroup; AColor: TColor): TJvExplorerGroupSeparatorItem;\r\nbegin\r\n Result := TJvExplorerGroupSeparatorItem(AGroup.Items.Add(TJvExplorerGroupSeparatorItem.Create(AGroup.ExplorerBar)));\r\n if AColor <> -1 then\r\n Result.Color := AColor;\r\nend;\r\n\r\nclass function TJvExplorerItemFactory.SimpleProgressBar(AGroup: TJvExplorerBarGroup;\r\n AMax, AMin, APosition: Integer): TJvExplorerGroupSimpleProgressBarItem;\r\nbegin\r\n Result := TJvExplorerGroupSimpleProgressBarItem(AGroup.Items.Add(TJvExplorerGroupSimpleProgressBarItem.Create(AGroup.ExplorerBar)));\r\n Result.Max := AMax;\r\n Result.Min := AMin;\r\n Result.Position := APosition;\r\nend;\r\n\r\nclass function TJvExplorerItemFactory.Spacer(AGroup: TJvExplorerBarGroup; AHeight: Integer): TJvExplorerGroupSpacerItem;\r\nbegin\r\n Result := TJvExplorerGroupSpacerItem(AGroup.Items.Add(TJvExplorerGroupSpacerItem.Create(AGroup.ExplorerBar)));\r\n if AHeight <> -1 then\r\n Result.Height := AHeight;\r\nend;\r\n\r\nclass function TJvExplorerItemFactory.Text(AGroup: TJvExplorerBarGroup; const ACaption: string;\r\n AFontColour: TColor; AFontStyle: TFontStyles; AWrap: Boolean; AIconIndex: Integer;\r\n const AFontSize: Integer = 8; AAligned: TAlignment = taLeftJustify): TJvExplorerGroupTextLineItem;\r\nbegin\r\n Result := TJvExplorerGroupTextLineItem(AGroup.Items.Add(TJvExplorerGroupTextLineItem.Create(AGroup.ExplorerBar)));\r\n Result.Caption := ACaption;\r\n if AFontColour > 0 then\r\n Result.FontColor := AFontColour;\r\n Result.FontStyle := AFontStyle;\r\n Result.WordWrap := AWrap;\r\n Result.IconIndex := AIconIndex;\r\n Result.FontSize := AFontSize;\r\n if AAligned <> taLeftJustify then\r\n Result.TextAlignment := AAligned;\r\nend;\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvExprParser.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThis file is derived from ExprParser.pas of the MP3BookHelper project\r\nhttp://mp3bookhelper.sourceforge.net and re-licensed under MPL by permission from\r\nthe original author Vlad Skarzhevskyy.\r\n\r\nThe Original Code is: ExprParser.pas, released on 2008-10-24\r\n\r\nThe Initial Developers of the Original Code are: Vlad Skarzhevskyy, Christian Schiffler\r\nCopyright (c) 2002 Vlad Skarzhevskyy\r\nCopyright (c) 2008 Christian Schiffler\r\nAll Rights Reserved.\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n Equality Check is case insensitive due to usage of TMask class in unit Masks.\r\n\r\nThis unit is used as a helper for JvMemoryDataSet.pas.\r\n\r\n}\r\n\r\nunit JvExprParser;\r\n\r\n{$I jvcl.inc}\r\n\r\n{DEFINE TESTING_PARSER}\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n SysUtils, Contnrs;\r\n\r\ntype\r\n TOnGetVariableValue = function(Sender: TObject; const VarName: string;\r\n var Value: Variant): Boolean of object;\r\n TOnExecuteFunction = function(Sender: TObject; const FuncName: string;\r\n const Args: Variant; var ResVal: Variant): Boolean of object;\r\n\r\n TExprParser = class\r\n private\r\n FValue: Variant;\r\n FParser: TObject; // TParser\r\n FScan: TObject; // TScan\r\n FExpression: string;\r\n FOnGetVariable: TOnGetVariableValue;\r\n FOnExecuteFunction: TOnExecuteFunction;\r\n FEnableWildcardMatching: Boolean;\r\n FErrorMessage: string;\r\n FCaseInsensitive: Boolean;\r\n procedure SetExpression(const Value: string);\r\n function DoGetVariable(const VarName: string; var Value: Variant): Boolean;\r\n function DoExecuteFunction(const FuncName: string; const Args: Variant; var ResVal: Variant): Boolean;\r\n procedure SetCaseInsensitive(const Value: Boolean);\r\n public\r\n constructor Create();\r\n destructor Destroy; override;\r\n function Eval: Boolean; overload;\r\n function Eval(const AExpression: string): Boolean; overload;\r\n\r\n property ErrorMessage: string read FErrorMessage;\r\n\r\n {published} // ahuser: not a TPersistent derived class\r\n property Expression: string read FExpression write SetExpression;\r\n property OnGetVariable: TOnGetVariableValue read FOnGetVariable write FOnGetVariable;\r\n property OnExecuteFunction: TOnExecuteFunction read FOnExecuteFunction write FOnExecuteFunction;\r\n property Value: Variant read FValue;\r\n property EnableWildcardMatching: Boolean read FEnableWildcardMatching write FEnableWildcardMatching;\r\n property CaseInsensitive: Boolean read FCaseInsensitive write SetCaseInsensitive;\r\n end;\r\n\r\n EExprParserError = class(Exception);\r\n\r\n{$IFDEF TESTING_PARSER}\r\nvar\r\n DebugText: string;\r\n{$ENDIF TESTING_PARSER}\r\n\r\nimplementation\r\n\r\nuses\r\n Classes, Variants, Masks;\r\n\r\n{$IFDEF COMPILER12_UP}\r\n // Our charsets do not contain any char > 127 what makes it safe because the\r\n // compiler generates correct code.\r\n {$WARN WIDECHAR_REDUCED OFF}\r\n{$ENDIF COMPILER12_UP}\r\n\r\nconst\r\n cNumbers = ['0'..'9'];\r\n cLetters = ['a'..'z', 'A'..'Z', '_'];\r\n cLettersAndNumbers = cLetters + cNumbers;\r\n cOperators = [\r\n '+', '-',\r\n '/', '*',\r\n '=',\r\n '<',\r\n '>',\r\n '&',\r\n '|',\r\n '!',\r\n '~'];\r\n\r\ntype\r\n TToken = (tkNA, tkEOF, tkError,\r\n tkLParen, tkRParen, tkComa,\r\n tkOperator, tkIdentifier,\r\n tkNumber, tkInteger, tkString);\r\n\r\n TLex = class\r\n private\r\n FToken: TToken;\r\n FChr: Char;\r\n FStr: string;\r\n FPos: Integer;\r\n public\r\n constructor Create(AToken: TToken; APos: Integer); overload;\r\n constructor Create(AToken: TToken; const AStr: string; APos: Integer); overload;\r\n constructor Create(AToken: TToken; AChr: Char; APos: Integer); overload;\r\n function Debug(): string;\r\n\r\n property Token: TToken read FToken;\r\n property Chr: Char read FChr;\r\n property Str: string read FStr;\r\n property Pos: Integer read FPos;\r\n end;\r\n\r\n TScan = class(TObjectList)\r\n private\r\n FErrorMessage: string;\r\n function GetItem(Index: Integer): TLex;\r\n public\r\n constructor Create();\r\n property Items[Index: Integer]: TLex read GetItem; default;\r\n function Parse(const Str: string): Boolean;\r\n {$IFDEF TESTING_PARSER}\r\n procedure DebugPrint();\r\n {$ENDIF TESTING_PARSER}\r\n property ErrorMessage: string read FErrorMessage;\r\n end;\r\n\r\n TParser = class;\r\n\r\n TNode = class\r\n private\r\n FParser: TParser;\r\n public\r\n constructor Create(Parser: TParser); virtual;\r\n\r\n // Delphi 5 compiler shows hints about a not exported or used symbol\r\n // TNode.Eval. This is a compiler bug that is caused by the \"abstract\" keyword.\r\n function Eval(): Variant; virtual; abstract;\r\n end;\r\n\r\n EParserError = class(EExprParserError)\r\n public\r\n constructor Create(const Msg: string; Lex: TLex); overload;\r\n end;\r\n\r\n TNodeCValue = class(TNode)\r\n private\r\n FCValue: TLex;\r\n public\r\n constructor Create(AParser: TParser; ACValue: TLex); reintroduce;\r\n function Eval(): Variant; override;\r\n end;\r\n\r\n TNodeVariable = class(TNode)\r\n private\r\n FLex: TLex;\r\n public\r\n constructor Create(AParser: TParser; ALex: TLex); reintroduce;\r\n function Eval(): Variant; override;\r\n end;\r\n\r\n TNodeUnary = class(TNode)\r\n private\r\n FOperator: TLex;\r\n FRightNode: TNode;\r\n public\r\n constructor Create(AParser: TParser; AOperator: TLex; ARightNode: TNode); reintroduce;\r\n destructor Destroy; override;\r\n function Eval(): Variant; override;\r\n end;\r\n\r\n TNodeBin = class(TNode)\r\n private\r\n FOperator: TLex;\r\n FLeftNode, FRightNode: TNode;\r\n public\r\n constructor Create(AParser: TParser; AOperator: TLex; ALeftNode, ARightNode: TNode); reintroduce;\r\n destructor Destroy; override;\r\n function Eval(): Variant; override;\r\n end;\r\n\r\n TNodeFunction = class(TNode)\r\n private\r\n FFunc: TLex;\r\n FArgs: TObjectList;\r\n public\r\n constructor Create(AParser: TParser; AFunc: TLex); reintroduce;\r\n destructor Destroy; override;\r\n procedure AddArg(Node: TNode);\r\n function Eval(): Variant; override;\r\n end;\r\n\r\n TParser = class\r\n private\r\n FParent: TExprParser;\r\n FScan: TScan;\r\n FScanIdx: Integer;\r\n FRoot: TNode;\r\n FErrorMessage: string;\r\n FValue: Variant;\r\n public\r\n destructor Destroy; override;\r\n\r\n function Parse(): Boolean;\r\n function Execute(): Boolean;\r\n\r\n function Expr(): TNode;\r\n function Term(): TNode;\r\n function Factor(): TNode;\r\n\r\n function LexC(): TLex;\r\n function LexLook(LookAhead: Integer = 1): TLex;\r\n procedure LexAccept();\r\n\r\n property Parent: TExprParser read FParent write FParent;\r\n property Value: Variant read FValue;\r\n property ErrorMessage: string read FErrorMessage;\r\n property Scan: TScan read FScan write FScan;\r\n end;\r\n\r\nvar\r\n ELexEOF: TLex; // ahuser: what the...\r\n\r\n{$IFDEF TESTING_PARSER}\r\nprocedure DebugMessage(const msg: string);\r\nbegin\r\n DebugText := DebugText + msg + sLineBreak;\r\nend;\r\n{$ENDIF TESTING_PARSER}\r\n\r\n{ TLex }\r\n\r\nconstructor TLex.Create(AToken: TToken; APos: Integer);\r\nbegin\r\n FToken := AToken;\r\n FPos := APos;\r\nend;\r\n\r\nconstructor TLex.Create(AToken: TToken; const AStr: string; APos: Integer);\r\nbegin\r\n inherited Create;\r\n FToken := AToken;\r\n FStr := AStr;\r\n FPos := APos;\r\nend;\r\n\r\nconstructor TLex.Create(AToken: TToken; AChr: Char; APos: Integer);\r\nbegin\r\n FToken := AToken;\r\n FChr := Char(AChr);\r\n FPos := APos;\r\nend;\r\n\r\nfunction TLex.debug: string;\r\nconst\r\n TokenStr: array[TToken] of string =\r\n ('N/A', 'End of expression', 'Error',\r\n '(', ')', ',',\r\n 'Operator', 'Identifier',\r\n 'Number', 'Integer', 'String');\r\nbegin\r\n Result := TokenStr[Token];\r\n case Token of\r\n tkOperator:\r\n Result := Result + ': ' + Chr;\r\n tkIdentifier, tkNumber, tkInteger, tkString:\r\n Result := Result + ': ' + Str;\r\n end;\r\n Result := Result + ' at pos: ' + IntToStr(Pos);\r\nend;\r\n\r\n{ TScan }\r\n\r\nconstructor TScan.Create;\r\nbegin\r\n inherited Create;\r\n OwnsObjects := True;\r\n FErrorMessage := '';\r\nend;\r\n\r\nfunction TScan.GetItem(Index: Integer): TLex;\r\nbegin\r\n Result := inherited Items[Index] as TLex;\r\nend;\r\n\r\nfunction TScan.Parse(const Str: string): Boolean;\r\nvar\r\n Idx, StartIdx, Len: Integer;\r\n C: Char;\r\n S: string;\r\n CToken: TToken;\r\nbegin\r\n Len := Length(Str);\r\n Idx := 1;\r\n S := '';\r\n CToken := tkNA;\r\n\r\n while Idx <= Len do\r\n begin\r\n C := Str[Idx];\r\n StartIdx := Idx;\r\n Inc(Idx);\r\n CToken := tkNA;\r\n\r\n case C of\r\n '(': CToken := tkLParen;\r\n ')': CToken := tkRParen;\r\n ',': CToken := tkComa;\r\n ' ', #09: ;\r\n else\r\n if C in cOperators then\r\n CToken := tkOperator\r\n else\r\n if (C = '\"') or (C = '''') then\r\n begin\r\n CToken := tkString;\r\n while (Idx <= Len) and (Str[Idx] <> C) do\r\n begin\r\n S := S + Str[Idx]; // ahuser: performance suicide\r\n Inc(Idx);\r\n end;\r\n if (Idx <= Len) and (Str[Idx] = C) then\r\n Inc(Idx)\r\n else\r\n begin\r\n CToken := tkError;\r\n FErrorMessage := 'No end of string found';\r\n end\r\n end\r\n else\r\n if C in cNumbers then\r\n begin\r\n CToken := tkInteger;\r\n S := S + C;\r\n while (Idx <= Len) and (Str[Idx] in cNumbers) do\r\n begin\r\n S := S + Str[Idx]; // ahuser: performance suicide\r\n Inc(Idx);\r\n end;\r\n if ((Idx <= Len) and (Str[Idx] = '.')) then\r\n begin\r\n CToken := tkNumber;\r\n Inc(Idx);\r\n S := S + '.';\r\n while (Idx <= Len) and (Str[Idx] in cNumbers) do\r\n begin\r\n S := S + Str[Idx]; // ahuser: performance suicide\r\n Inc(Idx);\r\n end;\r\n end;\r\n end\r\n else\r\n if C = '.' then // .55\r\n begin\r\n CToken := tkNumber;\r\n S := S + C;\r\n while (Idx <= Len) and (Str[Idx] in cNumbers) do\r\n begin\r\n S := S + Str[Idx]; // ahuser: performance suicide\r\n Inc(Idx);\r\n end;\r\n end\r\n else\r\n if C in cLetters then\r\n begin\r\n CToken := tkIdentifier;\r\n S := S + C;\r\n while (Idx <= Len) and (Str[Idx] in cLettersAndNumbers) do\r\n begin\r\n S := S + Str[Idx]; // ahuser: performance suicide\r\n Inc(Idx);\r\n end;\r\n end\r\n else\r\n begin\r\n CToken := tkError;\r\n FErrorMessage := Format('Bad character ''%s''', [string(C)]);\r\n end;\r\n end;\r\n\r\n case CToken of\r\n tkError: break;\r\n tkNA: ; // continue\r\n tkOperator: Add(TLex.Create(tkOperator, C, StartIdx));\r\n tkIdentifier,\r\n tkNumber,\r\n tkInteger,\r\n tkString:\r\n begin\r\n if CompareText(S, 'and') = 0 then\r\n Add(TLex.Create(tkOperator, '&', StartIdx))\r\n else\r\n if CompareText(S, 'or') = 0 then\r\n Add(TLex.Create(tkOperator, '|', StartIdx))\r\n else\r\n begin\r\n if CompareText(S, 'like')=0 then\r\n Add(TLex.Create(tkOperator, '~', StartIdx))\r\n else\r\n Add(TLex.Create(CToken, S, StartIdx));\r\n end;\r\n S := '';\r\n end\r\n else\r\n Add(TLex.Create(CToken, StartIdx));\r\n end;\r\n end;\r\n Result := CToken <> tkError;\r\n ELexEOF := TLex.Create(tkEOF, Idx);\r\n Add(ELexEOF);\r\nend;\r\n\r\n{$IFDEF TESTING_PARSER}\r\nprocedure TScan.DebugPrint;\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := 0 to Count - 1 do\r\n DebugMessage(Items[I].Debug);\r\nend;\r\n{$ENDIF TESTING_PARSER}\r\n\r\n{ TParser }\r\n\r\ndestructor TParser.Destroy;\r\nbegin\r\n FRoot.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TParser.Parse: Boolean;\r\nbegin\r\n FreeAndNil(FRoot);\r\n try\r\n FRoot := Expr();\r\n if FScanIdx < FScan.Count - 1 then\r\n begin\r\n FreeAndNil(FRoot);\r\n raise EParserError.Create('Unexpected ', LexC());\r\n end;\r\n except\r\n on E: Exception do\r\n FErrorMessage := E.Message;\r\n end;\r\n Result := FRoot <> nil;\r\nend;\r\n\r\nfunction TParser.Execute: Boolean;\r\nbegin\r\n Result := False;\r\n if FRoot <> nil then\r\n begin\r\n try\r\n FValue := FRoot.Eval();\r\n Result := True;\r\n except\r\n on E: Exception do\r\n begin\r\n FErrorMessage := E.Message;\r\n// raise;\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TParser.LexAccept;\r\nbegin\r\n Inc(FScanIdx);\r\nend;\r\n\r\nfunction TParser.LexC: TLex;\r\nbegin\r\n Result := LexLook(0);\r\nend;\r\n\r\nfunction TParser.LexLook(LookAhead: Integer): TLex;\r\nbegin\r\n if (FScanIdx + LookAhead) < FScan.Count then\r\n Result := FScan[FScanIdx + LookAhead]\r\n else\r\n Result := ELexEOF;\r\nend;\r\n\r\nfunction TParser.Expr: TNode;\r\nvar\r\n CNode, RightNode: TNode;\r\n Lex: TLex;\r\nbegin\r\n CNode := nil;\r\n try\r\n CNode := Term();\r\n Lex := LexC();\r\n\r\n if Lex.Token = tkOperator then\r\n begin\r\n if Lex.Chr in ['+', '-'] then\r\n begin\r\n LexAccept();\r\n RightNode := Expr();\r\n if RightNode = nil then\r\n raise EParserError.Create('Expression expected after', Lex);\r\n CNode := TNodeBin.Create(Self, Lex, CNode, RightNode);\r\n end;\r\n end;\r\n except\r\n on E: Exception do\r\n begin\r\n FreeAndNil(CNode);\r\n if E is EParserError then\r\n raise\r\n else\r\n raise EParserError.Create(E.Message);\r\n end;\r\n end;\r\n Result := CNode;\r\nend;\r\n\r\nfunction TParser.Term: TNode;\r\nvar\r\n CNode, RightNode: TNode;\r\n Lex: TLex;\r\nbegin\r\n CNode := nil;\r\n try\r\n CNode := Factor();\r\n Lex := LexC();\r\n\r\n if Lex.Token = tkOperator then\r\n begin\r\n if Lex.Chr in ['*', '/', '=', '&', '|', '<', '>', '~'] then\r\n begin\r\n LexAccept();\r\n RightNode := Expr();\r\n if RightNode = nil then\r\n raise EParserError.Create('Expression expected after', Lex);\r\n CNode := TNodeBin.Create(Self, Lex, CNode, RightNode);\r\n end;\r\n end;\r\n except\r\n on E: Exception do\r\n begin\r\n FreeAndNil(CNode);\r\n if E is EParserError then\r\n raise\r\n else\r\n raise EParserError.Create(E.Message);\r\n end;\r\n end;\r\n Result := CNode;\r\nend;\r\n\r\nfunction TParser.Factor: TNode;\r\nvar\r\n CNode: TNode;\r\n fNode: TNodeFunction;\r\n Lex: TLex;\r\nbegin\r\n CNode := nil;\r\n try\r\n Lex := LexC();\r\n case Lex.token of\r\n tkLParen:\r\n begin\r\n LexAccept();\r\n CNode := Expr();\r\n if (LexC().Token = tkRParen) then\r\n LexAccept()\r\n else\r\n raise EParserError.Create('Expected closing parenthesis instead of', LexC());\r\n end;\r\n tkOperator: // unary minus\r\n begin\r\n if Lex.Chr in ['+', '-', '!'] then\r\n begin\r\n LexAccept();\r\n CNode := TNodeUnary.Create(Self, Lex, Factor());\r\n end\r\n else\r\n raise EParserError.Create('Unexpected ', Lex);\r\n end;\r\n tkNumber, tkInteger, tkString:\r\n begin\r\n CNode := TNodeCValue.Create(Self, Lex);\r\n LexAccept();\r\n end;\r\n tkIdentifier:\r\n begin\r\n if LexLook().Token = tkLParen then\r\n begin\r\n // function call\r\n LexAccept();\r\n fNode := TNodeFunction.Create(Self, Lex);\r\n LexAccept();\r\n CNode := fNode;\r\n if (LexC().token <> tkRParen) then\r\n begin\r\n fNode.AddArg(Expr());\r\n while LexC().Token = tkComa do\r\n begin\r\n LexAccept();\r\n fNode.AddArg(Expr());\r\n end;\r\n end;\r\n\r\n if (LexC().token = tkRParen) then\r\n LexAccept()\r\n else\r\n raise EParserError.Create('Expected closing parenthesis instead of', LexC());\r\n end\r\n else\r\n begin\r\n CNode := TNodeVariable.Create(Self, Lex);\r\n LexAccept();\r\n end;\r\n end;\r\n else\r\n raise EParserError.Create('Unexpected ', Lex);\r\n end;\r\n except\r\n on E: Exception do\r\n begin\r\n FreeAndNil(CNode);\r\n if E is EParserError then\r\n raise\r\n else\r\n raise EParserError.Create(E.Message);\r\n end;\r\n end;\r\n Result := CNode;\r\nend;\r\n\r\n{ TNode }\r\n\r\nconstructor TNode.Create(Parser: TParser);\r\nbegin\r\n inherited Create;\r\n FParser := Parser;\r\nend;\r\n\r\n{ TNodeBin }\r\n\r\nconstructor TNodeBin.Create(AParser: TParser; AOperator: TLex; ALeftNode, ARightNode: TNode);\r\nbegin\r\n inherited Create(AParser);\r\n FOperator := AOperator;\r\n FLeftNode := ALeftNode;\r\n FRightNode := ARightNode;\r\nend;\r\n\r\ndestructor TNodeBin.Destroy;\r\nbegin\r\n FLeftNode.Free;\r\n FRightNode.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TNodeBin.Eval: Variant;\r\nvar\r\n LeftValue, RightValue: Variant;\r\n\r\n function FixupBoolean(var AVal1: Variant; var AVal2: Variant): Boolean;\r\n begin\r\n Result := (TVarData(AVal1).VType = varBoolean) or (TVarData(AVal2).VType = varBoolean);\r\n if Result then\r\n begin\r\n if UpperCase(AVal1) = 'TRUE' then\r\n AVal1 := 1\r\n else\r\n AVal1 := 0;\r\n\r\n if UpperCase(AVal2) = 'TRUE' then\r\n AVal2 := 1\r\n else\r\n AVal1 := 0;\r\n end;\r\n end;\r\n\r\n function FixupDateTime(var AVal1: Variant; var AVal2: Variant): Boolean;\r\n begin\r\n Result := TVarData(AVal1).VType = varDate;\r\n if Result then\r\n begin\r\n if TVarData(AVal2).VType = varString then\r\n AVal2 := StrToDateTime(AVal2); //convert;\r\n end;\r\n end;\r\n\r\n function FixupString(var aVal: Variant): Boolean;\r\n begin\r\n Result:=((TVarData(aVal).VType = varString) {$IFDEF UNICODE}or (TVarData(aVal).VType = varUString){$ENDIF UNICODE}) and FParser.Parent.FCaseInsensitive;\r\n if Result then\r\n aVal := AnsiUpperCase(aVal);\r\n end;\r\n\r\n //returns 'True' if a conversion was necessary.\r\n function FixupValues(var AVal1: Variant; var AVal2: Variant): Boolean;\r\n var\r\n bChanged: Boolean;\r\n begin\r\n Result := FixupDateTime(AVal1, AVal2);\r\n if not Result then\r\n Result := FixupDateTime(AVal2, AVal1);\r\n if not Result then\r\n Result := FixupBoolean(AVal1, AVal2);\r\n if not Result then //ensure that the 'String' case is the last one\r\n begin\r\n Result := FixupString(AVal1);\r\n bChanged := FixupString(AVal2);\r\n Result := Result or bChanged; //ensure that both Fixups are executed regardless of optimisations\r\n end;\r\n end;\r\n\r\n function EvalLike: Boolean;\r\n var\r\n Wildcard1, Wildcard2: Boolean;\r\n LeftStr, RightStr: string;\r\n begin\r\n if (LeftValue = Null) or (RightValue = Null) then\r\n Result := (LeftValue = Null) and (RightValue = Null)\r\n else\r\n begin\r\n // Possiblilities:\r\n // Left hand contains wildcards -> Match right hand against left hand.\r\n // Right hand contains wildcards -> Match left hand against right hand.\r\n // Both hands contain wildcards -> Match for string equality as if no wildcards are supported.\r\n\r\n LeftStr := LeftValue;\r\n RightStr := RightValue;\r\n Wildcard1 := (Pos('*', LeftStr) > 0) or (Pos('?', LeftStr) > 0);\r\n Wildcard2 := (Pos('*', RightStr) > 0) or (Pos('?', RightStr) > 0);\r\n if Wildcard1 and not Wildcard2 then\r\n Result := MatchesMask(RightStr, LeftStr)\r\n else\r\n if Wildcard2 then\r\n Result := MatchesMask(LeftStr, RightStr)\r\n else\r\n Result := LeftValue = RightValue;\r\n end;\r\n end;\r\n\r\n function EvalEquality: Boolean;\r\n begin\r\n // Special case, at least one of both is null:\r\n if (LeftValue = Null) or (RightValue = Null) then\r\n Result := (LeftValue = Null) and (RightValue = Null)\r\n else\r\n begin\r\n if FParser.Parent.FEnableWildcardMatching and (TVarData(LeftValue).VType<>varDate) then\r\n begin\r\n Result := EvalLike;\r\n end\r\n else\r\n Result := LeftValue = RightValue;\r\n end;\r\n end;\r\n\r\n function EvalLT: Boolean;\r\n begin\r\n // Special case, at least one of both is Null:\r\n if (LeftValue = Null) or (RightValue = Null) then\r\n // Null is considered to be smaller than any value.\r\n Result := LeftValue = Null\r\n else\r\n Result := LeftValue < RightValue;\r\n end;\r\n\r\n function EvalGT: Boolean;\r\n begin\r\n // Special case, at least one of both is Null:\r\n if (LeftValue = Null) or (RightValue = Null) then\r\n // Null is considered to be smaller than any value.\r\n Result := RightValue = Null\r\n else\r\n Result := LeftValue > RightValue;\r\n end;\r\n\r\nvar\r\n LeftStr, RightStr: string;\r\nbegin\r\n // Determine values to have them handy.\r\n LeftValue := FLeftNode.Eval;\r\n RightValue := FRightNode.Eval;\r\n FixupValues(LeftValue, RightValue);\r\n\r\n case FOperator.Chr of\r\n '+':\r\n begin\r\n // force string concatenation\r\n if (TVarData(LeftValue).VType = varString) or\r\n (TVarData(LeftValue).VType = varOleStr) then\r\n begin\r\n LeftStr := LeftValue;\r\n RightStr := RightValue;\r\n LeftStr := LeftStr + RightStr;\r\n Result := LeftStr;\r\n end\r\n else\r\n Result := LeftValue + RightValue;\r\n end;\r\n '-': Result := LeftValue - RightValue;\r\n '*': Result := FLeftNode.Eval * FRightNode.Eval;\r\n '/': Result := FLeftNode.Eval / FRightNode.Eval;\r\n '=': Result := EvalEquality();\r\n '<': Result := EvalLT();\r\n '>': Result := EvalGT();\r\n '&': Result := FLeftNode.Eval and FRightNode.Eval;\r\n '|': Result := FLeftNode.Eval or FRightNode.Eval;\r\n '~': Result := EvalLike;\r\n else\r\n Result := Null;\r\n end;\r\nend;\r\n\r\n{ TNodeUnary }\r\n\r\nconstructor TNodeUnary.Create(AParser: TParser; AOperator: TLex; ARightNode: TNode);\r\nbegin\r\n inherited Create(AParser);\r\n FOperator := AOperator;\r\n FRightNode := ARightNode;\r\nend;\r\n\r\ndestructor TNodeUnary.Destroy;\r\nbegin\r\n FRightNode.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TNodeUnary.Eval: Variant;\r\nbegin\r\n Result := FRightNode.Eval();\r\n if FOperator.Chr = '-' then\r\n Result := -Result;\r\n if FOperator.Chr = '!' then\r\n Result := not Result;\r\nend;\r\n\r\n{ TNodeCValue }\r\n\r\nconstructor TNodeCValue.Create(AParser: TParser; ACValue: TLex);\r\nbegin\r\n inherited Create(AParser);\r\n FCValue := ACValue;\r\nend;\r\n\r\nfunction TNodeCValue.Eval: Variant;\r\nbegin\r\n case FCValue.Token of\r\n tkNumber:\r\n Result := StrToFloat(FCValue.Str);\r\n tkInteger:\r\n Result := StrToInt(FCValue.Str);\r\n tkString:\r\n Result := FCValue.Str;\r\n else\r\n Result := Null;\r\n end;\r\nend;\r\n\r\n{ TNodeFunction }\r\n\r\nconstructor TNodeFunction.Create(AParser: TParser; AFunc: TLex);\r\nbegin\r\n inherited Create(AParser);\r\n FArgs := TObjectList.Create(True);\r\n FFunc := AFunc;\r\nend;\r\n\r\ndestructor TNodeFunction.Destroy;\r\nbegin\r\n FArgs.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TNodeFunction.AddArg(Node: TNode);\r\nbegin\r\n FArgs.Add(Node);\r\nend;\r\n\r\nfunction TNodeFunction.Eval: Variant;\r\nvar\r\n Value: Variant;\r\n VArgs: Variant;\r\n I: Integer;\r\nbegin\r\n\r\n VArgs := VarArrayCreate([0, FArgs.Count - 1], varVariant);\r\n for I := 0 to FArgs.Count - 1 do\r\n VArgs[I] := TNode(FArgs[I]).Eval();\r\n Value := Null;\r\n if FParser.Parent.DoExecuteFunction(FFunc.Str, VArgs, Value) then\r\n Result := Value\r\n else\r\n raise EParserError.CreateFmt('Function %s could not be executed.', [FFunc.Str]);\r\nend;\r\n\r\n{ TNodeVariable }\r\n\r\nconstructor TNodeVariable.Create(AParser: TParser; ALex: TLex);\r\nbegin\r\n inherited Create(AParser);\r\n FLex := ALex;\r\nend;\r\n\r\nfunction TNodeVariable.Eval: Variant;\r\nvar\r\n Value: Variant;\r\nbegin\r\n Value := Null;\r\n if FParser.Parent.DoGetVariable(FLex.Str, Value) then\r\n Result := Value\r\n else\r\n raise EParserError.Create('Variable ' + FLex.Str + ' could not be fetched.');\r\nend;\r\n\r\n{ EParserError }\r\n\r\nconstructor EParserError.Create(const Msg: string; Lex: TLex);\r\nbegin\r\n inherited CreateFmt('%s %s', [Msg, Lex.Debug]);\r\nend;\r\n\r\n{ TExprParser }\r\n\r\nconstructor TExprParser.Create;\r\nbegin\r\n inherited Create;\r\n FErrorMessage := '';\r\nend;\r\n\r\ndestructor TExprParser.Destroy;\r\nbegin\r\n FParser.Free;\r\n FScan.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TExprParser.Eval(): Boolean;\r\nvar\r\n Parser: TParser;\r\n {$IFDEF TESTING_PARSER}\r\n Scan: TScan;\r\n {$ENDIF TESTING_PARSER}\r\nbegin\r\n FErrorMessage := '';\r\n {$IFDEF TESTING_PARSER}\r\n DebugText := '';\r\n Scan := TScan(FScan);\r\n Scan.DebugPrint();\r\n {$ENDIF TESTING_PARSER}\r\n Parser := TParser(FParser);\r\n if Parser.Execute() then\r\n begin\r\n FValue := Parser.Value;\r\n Result := True;\r\n end\r\n else\r\n begin\r\n FErrorMessage := Parser.ErrorMessage;\r\n Result := False;\r\n end\r\nend;\r\n\r\nfunction TExprParser.Eval(const AExpression: string): Boolean;\r\nbegin\r\n SetExpression(AExpression);\r\n Result := Eval();\r\nend;\r\n\r\nprocedure TExprParser.SetCaseInsensitive(const Value: Boolean);\r\nbegin\r\n FCaseInsensitive := Value;\r\nend;\r\n\r\nprocedure TExprParser.SetExpression(const Value: string);\r\nbegin\r\n if Value <> FExpression then\r\n begin\r\n FExpression := Value;\r\n FParser.Free;\r\n FScan.Free;\r\n FParser := TParser.Create;\r\n TParser(FParser).Parent := Self;\r\n FScan := TScan.Create;\r\n if not TScan(FScan).Parse(FExpression) then\r\n FErrorMessage := TScan(FScan).ErrorMessage\r\n else\r\n begin\r\n TParser(FParser).Scan := TScan(FScan);\r\n TParser(FParser).Parse();\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TExprParser.DoGetVariable(const VarName: string; var Value: Variant): Boolean;\r\nbegin\r\n Result := False;\r\n if Assigned(FOnGetVariable) then\r\n Result := FOnGetVariable(Self, VarName, Value);\r\nend;\r\n\r\nfunction TExprParser.DoExecuteFunction(const FuncName: string; const Args: Variant; var ResVal: Variant): Boolean;\r\nbegin\r\n Result := False;\r\n if Assigned(FOnExecuteFunction) then\r\n Result := FOnExecuteFunction(Self, FuncName, Args, ResVal);\r\nend;\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvExtComponent.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvExtComponent.pas, released on 2006-03-11.\r\n\r\nThe Initial Developer of the Original Code is Joe Doe .\r\nPortions created by Joe Doe are Copyright (C) 1999 Joe Doe.\r\nAll Rights Reserved.\r\n\r\nContributor(s): -\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvExtComponent.pas 13138 2011-10-26 23:17:50Z jfudickar $\r\n\r\nunit JvExtComponent;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Types,\r\n Classes, Graphics,\r\n JvExExtCtrls,\r\n JvExComCtrls;\r\n\r\ntype\r\n TJvPaintPanelContentEvent = procedure(Sender: TObject; Canvas: TCanvas; R: TRect) of object;\r\n\r\n TJvCustomPanel = class(TJvExCustomPanel)\r\n private\r\n FOnPaintContent: TJvPaintPanelContentEvent;\r\n protected\r\n function GetFlat: Boolean;\r\n procedure ReadCtl3D(Reader: TReader);\r\n procedure ReadParentCtl3D(Reader: TReader);\r\n procedure SetFlat(const Value: Boolean);\r\n function GetParentFlat: Boolean;\r\n procedure SetParentFlat(const Value: Boolean);\r\n\r\n procedure Paint; override;\r\n procedure PaintContent(const R: TRect); virtual;\r\n\r\n procedure DefineProperties(Filer: TFiler); override;\r\n\r\n property Flat: Boolean read GetFlat write SetFlat default False;\r\n property ParentFlat: Boolean read GetParentFlat write SetParentFlat default True;\r\n\r\n property OnPaintContent: TJvPaintPanelContentEvent read FOnPaintContent write FOnPaintContent;\r\n end;\r\n\r\n TJvPubCustomPanel = TJvExPubCustomPanel;\r\n TJvCustomTreeView = TJvExCustomTreeView;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvExtComponent.pas $';\r\n Revision: '$Revision: 13138 $';\r\n Date: '$Date: 2011-10-27 01:17:50 +0200 (jeu. 27 oct. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\n{ TJvCustomPanel }\r\n\r\n\r\nfunction TJvCustomPanel.GetFlat: Boolean;\r\nbegin\r\n Result := not Ctl3D;\r\nend;\r\n\r\nfunction TJvCustomPanel.GetParentFlat: Boolean;\r\nbegin\r\n Result := ParentCtl3D;\r\nend;\r\n\r\nprocedure TJvCustomPanel.SetFlat(const Value: Boolean);\r\nbegin\r\n Ctl3D := not Value;\r\nend;\r\n\r\nprocedure TJvCustomPanel.SetParentFlat(const Value: Boolean);\r\nbegin\r\n ParentCtl3D := Value;\r\nend;\r\n\r\nprocedure TJvCustomPanel.ReadCtl3D(Reader: TReader);\r\nbegin\r\n Flat := not Reader.ReadBoolean;\r\nend;\r\n\r\nprocedure TJvCustomPanel.ReadParentCtl3D(Reader: TReader);\r\nbegin\r\n ParentFlat := Reader.ReadBoolean;\r\nend;\r\n\r\n\r\nprocedure TJvCustomPanel.Paint;\r\nbegin\r\n inherited Paint;\r\n PaintContent(ClientRect);\r\nend;\r\n\r\nprocedure TJvCustomPanel.PaintContent(const R: TRect);\r\nbegin\r\n if Assigned(FOnPaintContent) then\r\n FOnPaintContent(Self, Canvas, R);\r\nend;\r\n\r\nprocedure TJvCustomPanel.DefineProperties(Filer: TFiler);\r\nbegin\r\n inherited DefineProperties(Filer);\r\n\r\n Filer.DefineProperty('Ctl3D', ReadCtl3D, nil, False);\r\n Filer.DefineProperty('ParentCtl3D', ReadParentCtl3D, nil, False);\r\nend;\r\n\r\ninitialization\r\n {$IFDEF UNITVERSIONING}\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n {$ENDIF UNITVERSIONING}\r\n\r\n{$IFDEF UNITVERSIONING}\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend." }, { "path": "External/Jedi/Jvcl/run/JvFavoritesButton.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvFavoritesButton.PAS, released on 2001-02-28.\r\n\r\nThe Initial Developer of the Original Code is Sbastien Buysse [sbuysse att buypin dott com]\r\nPortions created by Sbastien Buysse are Copyright (C) 2001 Sbastien Buysse.\r\nAll Rights Reserved.\r\n\r\nContributor(s): Michael Beck [mbeck att bigfoot dott com].\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvFavoritesButton.pas 13104 2011-09-07 06:50:43Z obones $\r\n\r\nunit JvFavoritesButton;\r\n\r\n{$I jvcl.inc}\r\n{$I windowsonly.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, SysUtils, Classes, Graphics, Controls,\r\n StdCtrls, Menus, ShellAPI, ImgList,\r\n JvTypes, JvButton, JvComputerInfoEx, JvJVCLUtils;\r\n\r\ntype\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvFavoritesButton = class(TJvCustomButton)\r\n private\r\n FPopup: TPopupMenu;\r\n FDirs: TJvSystemFolders;\r\n FImages: TImageList;\r\n FOnUrlClick: TJvLinkClickEvent;\r\n FOnPopup: TNotifyEvent;\r\n procedure UrlClick(Sender: TObject);\r\n protected\r\n procedure DeleteItem(Item: TMenuItem; LookTag: Boolean = False);\r\n procedure PopupCreate(Sender: TObject);\r\n procedure DirectoryClick(Sender: TObject);\r\n procedure DynBuild(Item: TMenuItem; Directory: string);\r\n procedure AddIconFrom(const Path: string);\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n procedure Click; override;\r\n published\r\n property OnUrlClick: TJvLinkClickEvent read FOnUrlClick write FOnUrlClick;\r\n property OnPopup: TNotifyEvent read FOnPopup write FOnPopup;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvFavoritesButton.pas $';\r\n Revision: '$Revision: 13104 $';\r\n Date: '$Date: 2011-09-07 08:50:43 +0200 (mer. 07 sept. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n JvResources;\r\n\r\nconstructor TJvFavoritesButton.Create(AOwner: TComponent);\r\nvar\r\n MenuItem: TMenuItem;\r\nbegin\r\n inherited Create(AOwner);\r\n FDirs := TJvSystemFolders.Create;\r\n\r\n //Create Popup\r\n FPopup := TPopupMenu.Create(Self);\r\n MenuItem := TMenuItem.Create(FPopup);\r\n MenuItem.Enabled := False;\r\n MenuItem.Caption := RsEmptyItem;\r\n MenuItem.Tag := 1;\r\n FPopup.Items.Add(MenuItem);\r\n FPopup.OnPopup := PopupCreate;\r\n\r\n //Create Images\r\n FImages := TImageList.Create(Self);\r\n FImages.Width := 16;\r\n FImages.Height := 16;\r\n FImages.DrawingStyle := dsTransparent;\r\n FImages.Masked := True;\r\n FPopup.Images := FImages;\r\n AddIconFrom(FDirs.Windows);\r\nend;\r\n\r\ndestructor TJvFavoritesButton.Destroy;\r\nbegin\r\n FDirs.Free;\r\n DeleteItem(FPopup.Items);\r\n FPopup.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvFavoritesButton.Click;\r\nvar\r\n P: TPoint;\r\nbegin\r\n inherited Click;\r\n P.X := 0;\r\n P.Y := Height;\r\n P := ClientToScreen(P);\r\n FPopup.Popup(P.X, P.Y);\r\n if Assigned(FOnPopup) then\r\n FOnPopup(Self);\r\nend;\r\n\r\nprocedure TJvFavoritesButton.UrlClick(Sender: TObject);\r\nbegin\r\n if Assigned(FOnUrlClick) then\r\n FOnUrlClick(Self, (Sender as TMenuItem).Hint);\r\nend;\r\n\r\nprocedure TJvFavoritesButton.DeleteItem(Item: TMenuItem; LookTag: Boolean);\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := Item.Count - 1 downto 0 do\r\n if (not LookTag) or (Item[I].Tag = 0) then\r\n begin\r\n DeleteItem(Item[I]);\r\n Item[I].Free;\r\n end;\r\nend;\r\n\r\nprocedure TJvFavoritesButton.PopupCreate(Sender: TObject);\r\nbegin\r\n DynBuild(FPopup.Items, FDirs.Favorites);\r\nend;\r\n\r\nprocedure TJvFavoritesButton.DynBuild(Item: TMenuItem; Directory: string);\r\nvar\r\n Res: Integer;\r\n SearchRec: TSearchRec;\r\n It, It2: TMenuItem;\r\n First: Boolean;\r\n FolderIndex: Integer;\r\nbegin\r\n DeleteItem(Item, True);\r\n if (Directory <> '') and (Directory[Length(Directory)] <> '\\') then\r\n Directory := Directory + '\\';\r\n Res := FindFirst(Directory + '*.*', faAnyFile, SearchRec);\r\n First := True;\r\n FolderIndex := 1;\r\n while Res = 0 do\r\n begin\r\n if SearchRec.FindData.cFilename[0] <> '.' then\r\n begin\r\n if (SearchRec.Attr and faDirectory) = faDirectory then\r\n begin\r\n if First then\r\n Item.Items[0].Visible := False;\r\n It := TMenuItem.Create(Item);\r\n It.Caption := SearchRec.Name;\r\n It.Hint := Directory + SearchRec.Name;\r\n It.OnClick := DirectoryClick;\r\n It.ImageIndex := 0;\r\n Item.Insert(FolderIndex, It);\r\n Inc(FolderIndex);\r\n It2 := TMenuItem.Create(It);\r\n with It2 do\r\n begin\r\n Caption := RsEmptyItem;\r\n Enabled := False;\r\n Tag := 1;\r\n end;\r\n It.Add(It2);\r\n end\r\n else\r\n if UpperCase(ExtractFileExt(SearchRec.Name)) = '.URL' then\r\n begin\r\n if First then\r\n Item.Items[0].Visible := False;\r\n if FImages.Count = 1 then\r\n AddIconFrom(Directory + SearchRec.Name);\r\n It := TMenuItem.Create(Item);\r\n It.Caption := ChangeFileExt(SearchRec.Name, '');\r\n It.OnClick := UrlClick;\r\n It.Hint := Directory + SearchRec.Name;\r\n It.ImageIndex := 1;\r\n Item.Add(It);\r\n end;\r\n end;\r\n Res := FindNext(SearchRec);\r\n end;\r\n FindClose(SearchRec);\r\nend;\r\n\r\nprocedure TJvFavoritesButton.DirectoryClick(Sender: TObject);\r\nbegin\r\n DynBuild((Sender as TMenuItem), (Sender as TMenuItem).Hint);\r\nend;\r\n\r\nprocedure TJvFavoritesButton.AddIconFrom(const Path: string);\r\nvar\r\n FileInfo: SHFILEINFO;\r\n Bmp: TBitmap;\r\nbegin\r\n SHGetFileInfo(PChar(Path), 0, FileInfo, SizeOf(FileInfo), SHGFI_ICON or SHGFI_SMALLICON);\r\n Bmp := IconToBitmap2(FileInfo.hIcon, 16, clMenu);\r\n FImages.AddMasked(Bmp, Bmp.TransparentColor);\r\n Bmp.Free;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvFindFiles.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvFindFiles.PAS, released on 2002-05-26.\r\n\r\nThe Initial Developer of the Original Code is Peter Thrnqvist [peter3 at sourceforge dot net]\r\nPortions created by Peter Thrnqvist are Copyright (C) 2002 Peter Thrnqvist.\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nDescription:\r\n A function and a component to wrap access to the FindFiles Dialog\r\n (accessible from the Explorer by hitting F3)\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvFindFiles.pas 13352 2012-06-14 09:21:26Z obones $\r\n\r\nunit JvFindFiles;\r\n\r\n{$I jvcl.inc}\r\n{$I windowsonly.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, SysUtils, Classes, ShlObj, ShellAPI, ActiveX,\r\n JvBaseDlg;\r\n\r\ntype\r\n TJvSpecialFolder =\r\n (sfRecycleBin, sfControlPanel, sfDesktop, sfDesktopDirectory,\r\n sfMyComputer, sfFonts, sfNetHood, sfNetwork, sfPersonal, sfPrinters,\r\n sfPrograms, sfRecent, sfSendTo, sfStartMenu, stStartUp, sfTemplates);\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvFindFilesDialog = class(TJvCommonDialog)\r\n private\r\n FUseSpecialFolder: Boolean;\r\n FDirectory: string;\r\n FSpecial: TJvSpecialFolder;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n function Execute(ParentWnd: HWND): Boolean; overload; override;\r\n published\r\n // the directory to start the search in\r\n property Directory: string read FDirectory write FDirectory;\r\n // ... or a special folder to start in\r\n property SpecialFolder: TJvSpecialFolder read FSpecial write FSpecial default sfMyComputer;\r\n // set to True to use SpecialFolder instead of Directory\r\n property UseSpecialFolder: Boolean read FUseSpecialFolder write FUseSpecialFolder;\r\n end;\r\n\r\nfunction FindFilesDlg(ParentWnd: HWND; const StartIn: string; SpecialFolder: TJvSpecialFolder; UseFolder: Boolean): Boolean;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvFindFiles.pas $';\r\n Revision: '$Revision: 13352 $';\r\n Date: '$Date: 2012-06-14 11:21:26 +0200 (jeu. 14 juin 2012) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\n\r\nconst\r\n FFolder: array [TJvSpecialFolder] of Integer =\r\n (CSIDL_BITBUCKET, CSIDL_CONTROLS, CSIDL_DESKTOP, CSIDL_DESKTOPDIRECTORY,\r\n CSIDL_DRIVES, CSIDL_FONTS, CSIDL_NETHOOD, CSIDL_NETWORK, CSIDL_PERSONAL,\r\n CSIDL_PRINTERS, CSIDL_PROGRAMS, CSIDL_RECENT, CSIDL_SENDTO, CSIDL_STARTMENU,\r\n CSIDL_STARTUP, CSIDL_TEMPLATES);\r\n\r\nconstructor TJvFindFilesDialog.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n // (rom) Create added to get a decent default for FSpecial\r\n FSpecial := sfMyComputer;\r\nend;\r\n\r\nfunction TJvFindFilesDialog.Execute(ParentWnd: HWND): Boolean;\r\nbegin\r\n Result := FindFilesDlg(ParentWnd, FDirectory, FSpecial, FUseSpecialFolder);\r\nend;\r\n\r\nfunction FindFilesDlg(ParentWnd: HWND; const StartIn: string; SpecialFolder: TJvSpecialFolder; UseFolder: Boolean): Boolean;\r\nvar\r\n Pidl: PITEMIDLIST;\r\n PMalloc: IMalloc;\r\n Sei: TShellExecuteInfo;\r\nbegin\r\n try\r\n SHGetMalloc(PMalloc);\r\n FillChar(Sei, SizeOf(TShellExecuteInfo), 0);\r\n Sei.lpVerb := 'find';\r\n Sei.cbSize := SizeOf(Sei);\r\n if UseFolder then\r\n begin\r\n SHGetSpecialFolderLocation(0, FFolder[SpecialFolder], Pidl);\r\n with Sei do\r\n begin\r\n fMask := SEE_MASK_INVOKEIDLIST;\r\n lpIDList := Pidl;\r\n end;\r\n end\r\n else\r\n Sei.lpFile := PChar(StartIn);\r\n Sei.Wnd := ParentWnd;\r\n Result := ShellExecuteEx(@Sei);\r\n finally\r\n PMalloc._Release;\r\n PMalloc := nil;\r\n end;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvFindReplace.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvFindReplace.PAS, released on 2002-05-26.\r\n\r\nThe Initial Developer of the Original Code is Peter Thrnqvist [peter3 at sourceforge dot net]\r\nPortions created by Peter Thrnqvist are Copyright (C) 2002 Peter Thrnqvist.\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\n Olivier Sannier\r\n Robert Marquardt\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nDescription:\r\n Wrapper for the TFind / TReplace dialogs and a stand-alone full\r\n text search engine with support for all available dialog options:\r\n Search up/down, whole word only, case sensitive, replace all etc.\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvFindReplace.pas 13104 2011-09-07 06:50:43Z obones $\r\n\r\nunit JvFindReplace;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n SysUtils, Classes, Windows, Messages, Controls, Dialogs, StdCtrls,\r\n JvComponentBase, JvEditor;\r\n\r\ntype\r\n TJvReplaceProgressEvent = procedure(Sender: TObject; Position: Integer;\r\n var Terminate: Boolean) of object;\r\n TJvReplaceAllEvent = procedure(Sender: TObject; ReplaceCount: Integer) of object;\r\n\r\n // for custom property editor\r\n TJvEditControlName = TWinControl;\r\n\r\n // internal type to handle different component ancestry trees\r\n TJvFindReplaceEditKind = (etEmpty, etCustomEdit, etJvCustomEditor);\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvFindReplace = class(TJvComponent)\r\n private\r\n FOnFind: TNotifyEvent;\r\n FOnReplace: TNotifyEvent;\r\n FOnReplacingAll: TNotifyEvent;\r\n FOnReplacedAll: TJvReplaceAllEvent;\r\n FOnShow: TNotifyEvent;\r\n FOnClose: TNotifyEvent;\r\n FOnNotFound: TNotifyEvent;\r\n FOnProgress: TJvReplaceProgressEvent;\r\n FOwner: TComponent;\r\n FFindDialog: TFindDialog;\r\n FReplaceDialog: TReplaceDialog;\r\n FOptions: TFindOptions;\r\n FPosition: TPoint;\r\n FFast: Boolean;\r\n FHelpContext: THelpContext;\r\n FShowDialogs: Boolean;\r\n FFindText: string;\r\n FReplaceText: string;\r\n FNumberReplaced: Integer; // only used by Replace All\r\n FEditControl: TJvEditControlName;\r\n FEditKind: TJvFindReplaceEditKind;\r\n procedure SetEditControl(Value: TJvEditControlName);\r\n procedure SetPosition(Value: TPoint);\r\n procedure SetDialogTop(Value: Integer);\r\n procedure SetDialogLeft(Value: Integer);\r\n procedure SetOptions(Value: TFindOptions);\r\n procedure SetHelpContext(Value: THelpContext);\r\n procedure SetFindText(const Value: string);\r\n procedure SetReplaceText(const Value: string);\r\n procedure SetShowDialogs(Value: Boolean);\r\n function GetTop: Integer;\r\n function GetLeft: Integer;\r\n function ReplaceOne(Sender: TObject): Boolean;\r\n procedure UpdateDialogs;\r\n procedure UpdateProperties(Sender: TObject);\r\n procedure NeedDialogs;\r\n protected\r\n procedure Notification(AComponent: TComponent; Operation: TOperation); override;\r\n function GetEditText: string; virtual;\r\n function GetEditSelText: string; virtual;\r\n function GetEditSelStart: Integer; virtual;\r\n function GetEditSelLength: Integer; virtual;\r\n function GetEditHandle: HWND; virtual;\r\n procedure TestEditAssigned; virtual;\r\n procedure SetEditText(const Text: string); virtual;\r\n procedure SetEditSelText(const Text: string); virtual;\r\n procedure SetEditSelStart(Start: Integer); virtual;\r\n procedure SetEditSelLength(Length: Integer); virtual;\r\n procedure SetEditFocus; virtual;\r\n procedure DoOnFind(Sender: TObject); virtual;\r\n procedure DoOnReplace(Sender: TObject); virtual;\r\n procedure DoOnShow(Sender: TObject); virtual;\r\n procedure DoOnClose(Sender: TObject); virtual;\r\n procedure DoFailed(Sender: TObject); virtual;\r\n procedure DoReplacingAll; virtual;\r\n procedure DoReplacedAll(Sender: TObject); virtual;\r\n procedure DoProgress(Position: Integer; var Terminate: Boolean); virtual;\r\n procedure Loaded; override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n procedure Find; virtual;\r\n procedure FindAgain; virtual;\r\n procedure Replace; virtual;\r\n procedure ReplaceAll(const SearchText, ReplaceText: string); virtual;\r\n property Position: TPoint read FPosition write SetPosition;\r\n property Top: Integer read GetTop write SetDialogTop default -1;\r\n property Left: Integer read GetLeft write SetDialogLeft default -1;\r\n published\r\n property EditControl: TJvEditControlName read FEditControl write SetEditControl;\r\n property Fast: Boolean read FFast write FFast default False;\r\n property Options: TFindOptions read FOptions write SetOptions;\r\n property FindText: string read FFindText write SetFindText;\r\n property ReplaceText: string read FReplaceText write SetReplaceText;\r\n property ShowDialogs: Boolean read FShowDialogs write SetShowDialogs default True;\r\n property HelpContext: THelpContext read FHelpContext write SetHelpContext default 0;\r\n property OnFind: TNotifyEvent read FOnFind write FOnFind;\r\n property OnReplace: TNotifyEvent read FOnReplace write FOnReplace;\r\n property OnReplacingAll: TNotifyEvent read FOnReplacingAll write FOnReplacingAll;\r\n property OnReplacedAll: TJvReplaceAllEvent read FOnReplacedAll write FOnReplacedAll;\r\n property OnNotFound: TNotifyEvent read FOnNotFound write FOnNotFound;\r\n property OnProgress: TJvReplaceProgressEvent read FOnProgress write FOnProgress;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvFindReplace.pas $';\r\n Revision: '$Revision: 13104 $';\r\n Date: '$Date: 2011-09-07 08:50:43 +0200 (mer. 07 sept. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n Math,\r\n {$IFNDEF COMPILER12_UP}\r\n JvJCLUtils,\r\n {$ENDIF ~COMPILER12_UP}\r\n JvConsts, JvResources, JvTypes;\r\n\r\n{ utility }\r\n\r\nfunction IsValidWholeWord(const S: string): Boolean;\r\nbegin\r\n Result := (Length(S) > 0) and not (CharInSet(S[1], IdentifierSymbols) or CharInSet(S[Length(S)], IdentifierSymbols));\r\nend;\r\n\r\n{ invert string }\r\n\r\nfunction StrRev(const S: string): string;\r\nvar\r\n I, Len: Integer;\r\nbegin\r\n Len := Length(S);\r\n SetLength(Result, Len);\r\n for I := 1 to Len do\r\n begin\r\n Result[I] := S[Len];\r\n Dec(Len);\r\n end;\r\nend;\r\n\r\n{ Pascal adaption of a function originally in C }\r\n\r\nfunction BoyerMoore(SubStr, S: PChar): Integer;\r\nvar\r\n CharJump, MatchJump, BackUp: array[0..255] of Integer;\r\n PatLen, TextLen, u, uA, uB, uText, uPat: Integer;\r\nbegin\r\n Result := 0;\r\n PatLen := StrLen(SubStr);\r\n TextLen := StrLen(S);\r\n\r\n FillChar(CharJump, 256 * SizeOf(Integer), 0);\r\n\r\n for u := 0 to PatLen do\r\n CharJump[Ord(SubStr[u])] := PatLen - u - 1;\r\n\r\n for u := 1 to PatLen - 1 do\r\n MatchJump[u] := 2 * PatLen - u;\r\n\r\n u := PatLen;\r\n uA := PatLen + 1;\r\n while u > 0 do\r\n begin\r\n BackUp[u] := uA;\r\n while (uA <= PatLen) and (SubStr[u - 1] <> SubStr[uA - 1]) do\r\n begin\r\n if MatchJump[uA] > PatLen - u then\r\n MatchJump[uA] := PatLen - u;\r\n uA := BackUp[uA];\r\n end;\r\n Dec(u);\r\n Dec(uA);\r\n end;\r\n\r\n for u := 1 to uA do\r\n if MatchJump[u] > PatLen + uA - u then\r\n MatchJump[u] := PatLen + uA - u;\r\n uB := BackUp[uA];\r\n\r\n while uA <= PatLen do\r\n begin\r\n while uA <= uB do\r\n begin\r\n if MatchJump[uA] > uB - uA + PatLen then\r\n MatchJump[uA] := uB - uA + PatLen;\r\n Inc(uA);\r\n end;\r\n uB := BackUp[uB];\r\n end;\r\n\r\n uPat := PatLen;\r\n uText := PatLen - 1;\r\n while (uText < TextLen) and (uPat <> 0) do\r\n begin\r\n if S[uText] = SubStr[uPat - 1] then\r\n begin\r\n Dec(uText);\r\n Dec(uPat);\r\n end\r\n else { mismatch - slide forward }\r\n begin\r\n uA := CharJump[Ord(S[uText])];\r\n uB := PatLen - uPat + 1;\r\n uText := uText + Max(uA, uB);\r\n uPat := PatLen;\r\n end;\r\n end;\r\n if uPat = 0 then\r\n Result := uText + 2;\r\nend;\r\n\r\n{ Find text, return a Longint }\r\n\r\nfunction FindInText(const Text, Search: string; FromPos, Len: Integer;\r\n Fast, WholeWord, MatchCase: Boolean): Longint;\r\nvar\r\n Found, SearchLen, TextLen: Integer;\r\n S: string;\r\nbegin\r\n Result := -1; // assume failure\r\n\r\n // first character in string is at position 1\r\n if FromPos = 0 then\r\n FromPos := 1;\r\n\r\n Found := 1;\r\n while (Result = -1) and (Found > 0) do\r\n begin\r\n if Fast then\r\n Found := BoyerMoore(PChar(AnsiUpperCase(Search)),\r\n PChar(AnsiUpperCase(Copy(Text, FromPos, Len))))\r\n else\r\n Found := Pos(AnsiUpperCase(Search), AnsiUpperCase(Copy(Text, FromPos, Len)));\r\n if Found > 0 then\r\n begin\r\n Result := Found + FromPos - 1;\r\n SearchLen := Length(Search);\r\n TextLen := Length(Text);\r\n FromPos := Result + SearchLen;\r\n // is match-case required and does it?\r\n if MatchCase and (AnsiCompareStr(Search, Copy(Text, Result, SearchLen)) <> 0) then\r\n Result := -1\r\n // is whole-word-only required and is it?\r\n else\r\n if WholeWord and (SearchLen < TextLen) then\r\n begin\r\n // check for extremes...\r\n S := Copy(Text, Result - 1, SearchLen + 2);\r\n // check for match at beginning or end of string\r\n if Result = 1 then\r\n S := Copy(' ' + S, 1, SearchLen + 2);\r\n if Result - 1 + SearchLen + 1 > TextLen then\r\n S := Copy(S + ' ', Length(S) - SearchLen-2, SearchLen + 2);\r\n if not IsValidWholeWord(S) then\r\n result := -1;\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\n{ invert and search }\r\n\r\nfunction FindInTextRev(const Text, Search: string; FromPos, Len: Integer;\r\n Fast, WholeWord, MatchCase: Boolean): Longint;\r\nbegin\r\n Result := FindInText(StrRev(Text), StrRev(Search), FromPos, Len, Fast,\r\n WholeWord, MatchCase);\r\n if Result > -1 then\r\n Result := Length(Text) - (Result - 1) - (Length(Search) - 1);\r\nend;\r\n\r\n//=== { TJvFindReplace } =====================================================\r\n\r\nconstructor TJvFindReplace.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FOwner := AOwner;\r\n FHelpContext := 0;\r\n FShowDialogs := True;\r\n FPosition := Point(-1, -1);\r\nend;\r\n\r\nprocedure TJvFindReplace.Loaded;\r\nbegin\r\n inherited Loaded;\r\n UpdateDialogs;\r\nend;\r\n\r\nprocedure TJvFindReplace.Notification(AComponent: TComponent; Operation: TOperation);\r\nbegin\r\n inherited Notification(AComponent, Operation);\r\n if (Operation = opRemove) and (AComponent = FEditControl) then\r\n FEditControl := nil;\r\nend;\r\n\r\nprocedure TJvFindReplace.Find;\r\nbegin\r\n TestEditAssigned;\r\n UpdateDialogs;\r\n if FShowDialogs then\r\n FFindDialog.Execute\r\n else\r\n DoOnFind(FFindDialog);\r\nend;\r\n\r\nprocedure TJvFindReplace.FindAgain;\r\nbegin\r\n TestEditAssigned;\r\n UpdateDialogs;\r\n DoOnFind(FFindDialog);\r\nend;\r\n\r\nprocedure TJvFindReplace.Replace;\r\nbegin\r\n TestEditAssigned;\r\n UpdateDialogs;\r\n\r\n if FShowDialogs then\r\n FReplaceDialog.Execute\r\n else\r\n DoOnReplace(FReplaceDialog);\r\nend;\r\n\r\nprocedure TJvFindReplace.ReplaceAll(const SearchText, ReplaceText: string);\r\nvar\r\n Txt: string;\r\n FoundPos: Longint;\r\n SLen, RLen, TLen: Integer;\r\n Terminate: Boolean;\r\n WholeWord, MatchCase: Boolean;\r\nbegin\r\n TestEditAssigned;\r\n Terminate := False;\r\n UpdateDialogs;\r\n WholeWord := frWholeWord in FOptions;\r\n MatchCase := frMatchCase in FOptions;\r\n Txt := GetEditText;\r\n SLen := Length(SearchText);\r\n RLen := Length(ReplaceText);\r\n TLen := Length(Txt);\r\n FoundPos := FindInText(Txt, SearchText, GetEditSelStart + GetEditSelLength,\r\n TLen, FFast, WholeWord, MatchCase);\r\n\r\n if FoundPos > -1 then\r\n begin\r\n DoReplacingAll;\r\n FNumberReplaced := 0;\r\n while FoundPos > -1 do\r\n begin\r\n Inc(FNumberReplaced);\r\n\r\n Delete(Txt, FoundPos, SLen);\r\n Insert(ReplaceText, Txt, FoundPos);\r\n FoundPos := FindInText(Txt, SearchText, FoundPos + RLen + 1, TLen + (RLen - SLen), FFast, WholeWord, MatchCase);\r\n\r\n DoProgress(FoundPos, Terminate);\r\n if Terminate then\r\n Exit;\r\n end;\r\n SetEditText(Txt);\r\n DoReplacedAll(FReplaceDialog);\r\n end\r\n else\r\n DoFailed(FReplaceDialog);\r\nend;\r\n\r\nfunction TJvFindReplace.ReplaceOne(Sender: TObject): Boolean;\r\nvar\r\n Equal: Integer;\r\n S, R: string;\r\nbegin\r\n Result := False;\r\n\r\n if FShowDialogs then\r\n begin\r\n S := TReplaceDialog(Sender).FindText;\r\n R := TReplaceDialog(Sender).ReplaceText;\r\n end\r\n else\r\n begin\r\n S := FFindText;\r\n R := FReplaceText;\r\n end;\r\n\r\n if frMatchCase in TFindDialog(Sender).Options then\r\n Equal := AnsiCompareStr(GetEditSelText, S)\r\n else\r\n Equal := AnsiCompareText(GetEditSelText, S);\r\n\r\n if Equal = 0 then\r\n begin\r\n Result := True;\r\n SetEditSelText(R);\r\n SetEditFocus;\r\n end;\r\nend;\r\n\r\nprocedure TJvFindReplace.NeedDialogs;\r\nbegin\r\n if not Assigned(FFindDialog) then\r\n begin\r\n FFindDialog := TFindDialog.Create(Self);\r\n FFindDialog.FindText := FFindText;\r\n FFindDialog.OnFind := DoOnFind;\r\n FFindDialog.Position := FPosition;\r\n end;\r\n if not Assigned(FReplaceDialog) then\r\n begin\r\n FReplaceDialog := TReplaceDialog.Create(Self);\r\n FReplaceDialog.FindText := FFindText;\r\n FReplaceDialog.ReplaceText := FReplaceText;\r\n FReplaceDialog.OnFind := DoOnFind;\r\n FReplaceDialog.OnReplace := DoOnReplace;\r\n FReplaceDialog.Position := FPosition;\r\n end;\r\nend;\r\n\r\nprocedure TJvFindReplace.UpdateDialogs;\r\nbegin\r\n if not (csDesigning in ComponentState) and not (csLoading in ComponentState) then\r\n begin\r\n NeedDialogs;\r\n\r\n FFindDialog.Position := FPosition;\r\n FFindDialog.Options := FOptions;\r\n FFindDialog.HelpContext := FHelpContext;\r\n FFindDialog.FindText := FFindText;\r\n\r\n FReplaceDialog.Position := FPosition;\r\n FReplaceDialog.Options := FOptions;\r\n FReplaceDialog.HelpContext := FHelpContext;\r\n FReplaceDialog.FindText := FFindText;\r\n FReplaceDialog.ReplaceText := FReplaceText;\r\n end;\r\nend;\r\n\r\nprocedure TJvFindReplace.UpdateProperties(Sender: TObject);\r\nbegin\r\n if Sender is TFindDialog then\r\n begin\r\n FPosition := TFindDialog(Sender).Position;\r\n FOptions := TFindDialog(Sender).Options;\r\n FHelpContext := TFindDialog(Sender).HelpContext;\r\n FFindText := TFindDialog(Sender).FindText;\r\n end;\r\n if Sender is TReplaceDialog then\r\n FReplaceText := TReplaceDialog(Sender).ReplaceText;\r\nend;\r\n\r\nprocedure TJvFindReplace.DoOnFind(Sender: TObject);\r\nvar\r\n FoundPos: Longint;\r\n Offset: Integer;\r\n WholeWord, MatchCase: Boolean;\r\nbegin\r\n /// update the local properties with the current values from the dialog\r\n /// in case the user has changed the options (or the find/replace text)\r\n UpdateProperties(Sender);\r\n WholeWord := frWholeWord in FOptions;\r\n MatchCase := frMatchCase in FOptions;\r\n\r\n if not (frDown in FOptions) then\r\n begin\r\n Offset := GetEditSelStart - 1;\r\n if Offset <= 0 then\r\n Offset := 1;\r\n FoundPos := FindInTextRev(GetEditText, FFindText,\r\n Length(GetEditText) - Offset, Length(GetEditText), FFast,\r\n WholeWord, MatchCase)\r\n end else\r\n begin\r\n Offset := GetEditSelStart + GetEditSelLength + 1;\r\n FoundPos := FindInText(GetEditText, FFindText, Offset,\r\n Length(GetEditText), FFast, WholeWord, MatchCase);\r\n end;\r\n\r\n if FoundPos > -1 then\r\n begin\r\n SetEditFocus;\r\n SetEditSelStart(FoundPos - 1);\r\n SetEditSelLength(Length(FFindText));\r\n if GetEditHandle <> 0 then\r\n SendMessage(GetEditHandle, EM_SCROLLCARET, 0, 0);\r\n if Assigned(FOnFind) then\r\n FOnFind(Self);\r\n end\r\n else\r\n DoFailed(Sender);\r\nend;\r\n\r\nprocedure TJvFindReplace.DoOnReplace(Sender: TObject);\r\nbegin\r\n UpdateProperties(Sender);\r\n\r\n if frReplaceAll in FOptions then\r\n begin\r\n ReplaceAll(FFindText, FReplaceText);\r\n if Assigned(FOnReplace) then\r\n FOnReplace(Self);\r\n end\r\n else\r\n begin\r\n if GetEditSelLength < 1 then\r\n DoOnFind(Sender);\r\n if GetEditSelLength < 1 then\r\n Exit;\r\n ReplaceOne(Sender);\r\n if Assigned(FOnReplace) then\r\n FOnReplace(Self);\r\n DoOnFind(Sender);\r\n end;\r\nend;\r\n\r\nprocedure TJvFindReplace.DoOnShow(Sender: TObject);\r\nbegin\r\n TestEditAssigned;\r\n UpdateDialogs;\r\n if Assigned(FOnShow) then\r\n FOnShow(Self);\r\nend;\r\n\r\nprocedure TJvFindReplace.DoOnClose(Sender: TObject);\r\nbegin\r\n TestEditAssigned;\r\n UpdateProperties(Sender);\r\n UpdateDialogs;\r\n if Assigned(FOnClose) then\r\n FOnClose(Self);\r\nend;\r\n\r\nprocedure TJvFindReplace.DoFailed(Sender: TObject);\r\nvar\r\n FCaption: string;\r\nbegin\r\n TestEditAssigned;\r\n UpdateProperties(Sender);\r\n if Assigned(FOnNotFound) then\r\n FOnNotFound(Self);\r\n if not FShowDialogs then\r\n Exit;\r\n\r\n if Sender = FReplaceDialog then\r\n FCaption := RsReplaceCaption\r\n else\r\n FCaption := RsFindCaption;\r\n\r\n MessageBox(\r\n TFindDialog(Sender).Handle,\r\n PChar(Format(RsNotFound, [FFindText])),\r\n PChar(FCaption), MB_OK or MB_ICONINFORMATION);\r\nend;\r\n\r\nprocedure TJvFindReplace.DoReplacingAll;\r\nbegin\r\n if Assigned(FOnReplacingAll) then\r\n FOnReplacingAll(Self);\r\nend;\r\n\r\nprocedure TJvFindReplace.DoReplacedAll(Sender: TObject);\r\nbegin\r\n UpdateProperties(Sender);\r\n if FShowDialogs then\r\n begin\r\n MessageBox(\r\n TFindDialog(Sender).Handle,\r\n PChar(Format(RsXOccurencesReplaced, [FNumberReplaced, FFindText])),\r\n PChar(RsReplaceCaption), MB_OK or MB_ICONINFORMATION);\r\n end;\r\n\r\n if Assigned(FOnReplacedAll) then\r\n FOnReplacedAll(Self, FNumberReplaced);\r\nend;\r\n\r\nprocedure TJvFindReplace.DoProgress(Position: Integer; var Terminate: Boolean);\r\nbegin\r\n if Assigned(FOnProgress) then\r\n FOnProgress(Self, Position, Terminate);\r\nend;\r\n\r\nprocedure TJvFindReplace.SetPosition(Value: TPoint);\r\nbegin\r\n FPosition := Value;\r\n UpdateDialogs;\r\nend;\r\n\r\nprocedure TJvFindReplace.SetDialogTop(Value: Integer);\r\nbegin\r\n FPosition.Y := Value;\r\n UpdateDialogs;\r\nend;\r\n\r\nprocedure TJvFindReplace.SetDialogLeft(Value: Integer);\r\nbegin\r\n FPosition.X := Value;\r\n UpdateDialogs;\r\nend;\r\n\r\nprocedure TJvFindReplace.SetOptions(Value: TFindOptions);\r\nbegin\r\n FOptions := Value;\r\n UpdateDialogs;\r\nend;\r\n\r\nprocedure TJvFindReplace.SetFindText(const Value: string);\r\nbegin\r\n FFindText := Value;\r\n UpdateDialogs;\r\nend;\r\n\r\nprocedure TJvFindReplace.SetShowDialogs(Value: Boolean);\r\nbegin\r\n if FShowDialogs <> Value then\r\n FShowDialogs := Value;\r\n if not Value then\r\n begin\r\n NeedDialogs;\r\n FFindDialog.CloseDialog;\r\n FReplaceDialog.CloseDialog;\r\n end;\r\nend;\r\n\r\nprocedure TJvFindReplace.SetReplaceText(const Value: string);\r\nbegin\r\n FReplaceText := Value;\r\n UpdateDialogs;\r\nend;\r\n\r\nprocedure TJvFindReplace.SetHelpContext(Value: THelpContext);\r\nbegin\r\n FHelpContext := Value;\r\n UpdateDialogs;\r\nend;\r\n\r\nfunction TJvFindReplace.GetTop: Integer;\r\nbegin\r\n Result := FPosition.Y;\r\nend;\r\n\r\nfunction TJvFindReplace.GetLeft: Integer;\r\nbegin\r\n Result := FPosition.X;\r\nend;\r\n\r\nprocedure TJvFindReplace.SetEditControl(Value: TJvEditControlName);\r\nbegin\r\n if FEditControl <> nil then\r\n FEditControl.RemoveFreeNotification(Self);\r\n FEditControl := Value;\r\n if Value <> nil then\r\n Value.FreeNotification(Self);\r\n if Value is TCustomEdit then\r\n FEditKind := etCustomEdit\r\n else\r\n if Value is TJvCustomEditor then\r\n FEditKind := etJvCustomEditor\r\n else\r\n FEditKind := etEmpty;\r\nend;\r\n\r\nprocedure TJvFindReplace.TestEditAssigned;\r\nbegin\r\n if not Assigned(FEditControl) then\r\n raise EJVCLException.CreateRes(@RsENoEditAssigned);\r\nend;\r\n\r\nfunction TJvFindReplace.GetEditText: string;\r\nbegin\r\n case FEditKind of\r\n etCustomEdit:\r\n Result := TCustomEdit(FEditControl).Text;\r\n etJvCustomEditor:\r\n Result := TJvCustomEditor(FEditControl).Lines.Text;\r\n else\r\n Result := '';\r\n end;\r\nend;\r\n\r\nfunction TJvFindReplace.GetEditSelText: string;\r\nbegin\r\n case FEditKind of\r\n etCustomEdit:\r\n Result := TCustomEdit(FEditControl).SelText;\r\n etJvCustomEditor:\r\n Result := TJvCustomEditor(FEditControl).SelText;\r\n else\r\n Result := '';\r\n end;\r\nend;\r\n\r\nfunction TJvFindReplace.GetEditSelStart: Integer;\r\nbegin\r\n case FEditKind of\r\n etCustomEdit:\r\n Result := TCustomEdit(FEditControl).SelStart;\r\n etJvCustomEditor:\r\n Result := TJvCustomEditor(FEditControl).SelStart;\r\n else\r\n Result := 0;\r\n end;\r\nend;\r\n\r\nfunction TJvFindReplace.GetEditSelLength: Integer;\r\nbegin\r\n case FEditKind of\r\n etCustomEdit:\r\n Result := TCustomEdit(FEditControl).SelLength;\r\n etJvCustomEditor:\r\n Result := TJvCustomEditor(FEditControl).SelLength;\r\n else\r\n Result := 0;\r\n end;\r\nend;\r\n\r\nfunction TJvFindReplace.GetEditHandle: HWND;\r\nbegin\r\n case FEditKind of\r\n etCustomEdit:\r\n Result := TCustomEdit(FEditControl).Handle;\r\n etJvCustomEditor:\r\n Result := TJvCustomEditor(FEditControl).Handle;\r\n else\r\n Result := HWND(0);\r\n end;\r\nend;\r\n\r\nprocedure TJvFindReplace.SetEditText(const Text: string);\r\nbegin\r\n case FEditKind of\r\n etCustomEdit:\r\n TCustomEdit(FEditControl).Text := Text;\r\n etJvCustomEditor:\r\n TJvCustomEditor(FEditControl).Lines.Text := Text;\r\n end;\r\nend;\r\n\r\nprocedure TJvFindReplace.SetEditSelText(const Text: string);\r\nbegin\r\n case FEditKind of\r\n etCustomEdit:\r\n TCustomEdit(FEditControl).SelText := Text;\r\n etJvCustomEditor:\r\n TJvCustomEditor(FEditControl).SelText := Text;\r\n end;\r\nend;\r\n\r\nprocedure TJvFindReplace.SetEditSelStart(Start: Integer);\r\nbegin\r\n case FEditKind of\r\n etCustomEdit:\r\n TCustomEdit(FEditControl).SelStart := Start;\r\n etJvCustomEditor:\r\n TJvCustomEditor(FEditControl).SelStart := Start;\r\n end;\r\nend;\r\n\r\nprocedure TJvFindReplace.SetEditSelLength(Length: Integer);\r\nbegin\r\n case FEditKind of\r\n etCustomEdit:\r\n TCustomEdit(FEditControl).SelLength := Length;\r\n etJvCustomEditor:\r\n TJvCustomEditor(FEditControl).SelLength := Length;\r\n end;\r\nend;\r\n\r\nprocedure TJvFindReplace.SetEditFocus;\r\nbegin\r\n case FEditKind of\r\n etCustomEdit:\r\n TCustomEdit(FEditControl).SetFocus;\r\n etJvCustomEditor:\r\n TJvCustomEditor(FEditControl).SetFocus;\r\n end;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvFixedEditPopUp.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvFixedEditPopUp.PAS, released 2003-03-01.\r\n\r\nThe Initial Developer of the Original Code is Peter Thornqvist (peter3 at sourceforge dot net)\r\nPortions created by Peter Thornqvist are Copyright (C) 2002 Peter Thornqvist .\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\nSteve Magruder\r\nRemko Bonte\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nDescription:\r\n A unit that can be used to replace the default system popup menu for edit controls. The problem with\r\n MS implementation is that the Paste command is enabled even when the edit is set to read-only\r\n\r\n By overriding TCustomEdit.GetPopupMenu (virtual), you can return an instance of this popup menu\r\n instead of the default, i.e:\r\n interface:\r\n\r\n function GetPopupMenu: TPopupMenu; override;\r\n\r\n implementation:\r\n\r\n function TMyEdit.GetPopupMenu: TPopupMenu;\r\n begin\r\n Result := inherited GetPopupMenu;\r\n if Result = nil then // user has not assigned his own popup menu, so use fixed default\r\n Result := FixedDefaultEditPopUp(Self);\r\n end;\r\n\r\n The popup is constructed as a singelton shared between all edit controls using it, so it is\r\n as resource friendly as we could make it and you should NOT free it after use. The popup is\r\n not created until first use, so if you don't use it, it doesn't take any resources.\r\n\r\n The popup automatically handles cut, copy, paste, select all, clear and undo events and it's aware\r\n of and can also handle the ClipboardCommands property in some JVCL edits. Menu items\r\n are automatically enabled / disabled according to the current state of the edit.\r\n\r\n The popup is \"self-translating\" based on Windows locale. If you want to\r\n use resourcestrings and supply your own translations, call FixedDefaultEditPopUseResourceString(True);\r\n (yes, the name is that long on purpose) *before the first call* to FixedDefaultEditPopUp.\r\n\r\n UPDATE 2003-07-14:\r\n Rewritten to handle any TWinControl descendant. To make a TWinControl\r\n component compatible it should implement the following messages and styles:\r\n * If the control is readonly, it should set ES_READONLY in GWL_STYLE\r\n (this can be done using the EM_SETREADONLY message for edit descendants)\r\n * If text can be selected, the control should implement the EM_GETSEL message\r\n * If the control has undo capability, it should implement the EM_CANUNDO message\r\n\r\n The control should also react to the following messages:\r\n * Undo: WM_UNDO\r\n * Cut: WM_CUT\r\n * Copy: WM_COPY\r\n * Paste: WM_PASTE\r\n * Clear: WM_CLEAR\r\n * Select All: EM_SETSEL with wParam=0 and lParam=-1\r\n\r\nHistory:\r\n3.0:\r\n 2003-09-19:\r\n - introduced IFixedPopupIntf\r\n - speed optimation in THiddenPopupObject.GetPopupMenu\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvFixedEditPopUp.pas 13397 2012-08-16 17:23:19Z ahuser $\r\n\r\nunit JvFixedEditPopUp;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, Messages, SysUtils, Classes, Controls, Menus, StdCtrls, TypInfo,\r\n JvTypes;\r\n\r\ntype\r\n { IFixedPopupIntf is implemented by a component that supports the\r\n FixedPopupMenu. }\r\n IFixedPopupIntf = interface\r\n ['{2ECA1438-EFA5-460A-B586-C30C04B85FF3}']\r\n function CanUndo: Boolean;\r\n function CanRedo: Boolean; // unused\r\n function CanCut: Boolean;\r\n function CanCopy: Boolean;\r\n function CanPaste: Boolean;\r\n function CanSelectAll: Boolean;\r\n function HasSelection: Boolean;\r\n procedure Undo;\r\n procedure Redo; // unused\r\n procedure Cut;\r\n procedure Copy;\r\n procedure Paste;\r\n { Delete() deletes the selected text without storing the content to the\r\n clipboard. It's enabled/disabled in the same way as Cut. }\r\n procedure Delete;\r\n procedure SelectAll;\r\n end;\r\n\r\n// Returns a popup menu with the standard actions associated with edit controls (Undo, Cut, Copy, Paste, Delete, Select All).\r\n// The actions are handled autmatically by sending messages (WM_COPY, WM_CUT etc) to the control\r\nfunction FixedDefaultEditPopup(AEdit: TWinControl; Update: Boolean = True): TPopupMenu;\r\n// Call with Value set to True to use the internal resourcestrings instead of those\r\n// provided by Windows. These strings can subsequently be translated using the ITE.\r\n// By default, the Windows provided strings are used.\r\nprocedure FixedDefaultEditPopUseResourceString(Value: Boolean);\r\n\r\n// Updates the menu items enabled property\r\nprocedure FixedDefaultEditPopupUpdate(AEdit: TWinControl);\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvFixedEditPopUp.pas $';\r\n Revision: '$Revision: 13397 $';\r\n Date: '$Date: 2012-08-16 19:23:19 +0200 (jeu. 16 août 2012) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n JvJCLUtils, JvResources, JvJVCLUtils;\r\n\r\ntype\r\n THiddenPopupObject = class(TComponent)\r\n private\r\n FEdit: TWinControl;\r\n FPopupMenu: TPopupMenu;\r\n procedure GetDefaultMenuCaptions;\r\n procedure DoSelectAll(Sender: TObject);\r\n procedure DoUndo(Sender: TObject);\r\n procedure DoDelete(Sender: TObject);\r\n procedure DoPaste(Sender: TObject);\r\n procedure DoCut(Sender: TObject);\r\n procedure DoCopy(Sender: TObject);\r\n function CanUndo: Boolean;\r\n function ReadOnly: Boolean;\r\n function GetTextLen: Integer;\r\n function SelLength: Integer;\r\n //function GetPopupMenu: TPopupMenu;\r\n function GetPopupMenuEx(Update: Boolean): TPopupMenu;\r\n procedure SetEdit(const Value: TWinControl);\r\n function GetClipboardCommands: TJvClipboardCommands;\r\n procedure UpdateItems;\r\n function GetEditHandle: THandle;\r\n property EditHandle: THandle read GetEditHandle;\r\n protected\r\n procedure Notification(AComponent: TComponent; Operation: TOperation); override;\r\n public\r\n destructor Destroy; override;\r\n property Edit: TWinControl read FEdit write SetEdit;\r\n // property PopupMenu: TPopupMenu read GetPopupMenu;\r\n end;\r\n\r\nvar\r\n GlobalHiddenPopup: THiddenPopupObject = nil;\r\n GlobalUseResourceStrings: Boolean = False;\r\n\r\nfunction FixedDefaultEditPopup(AEdit: TWinControl; Update: Boolean = True): TPopupMenu;\r\nbegin\r\n if GlobalHiddenPopup = nil then\r\n GlobalHiddenPopup := THiddenPopupObject.Create(nil);\r\n GlobalHiddenPopup.Edit := AEdit;\r\n Result := GlobalHiddenPopup.GetPopupMenuEx(Update);\r\nend;\r\n\r\nprocedure FixedDefaultEditPopUseResourceString(Value: Boolean);\r\nbegin\r\n GlobalUseResourceStrings := Value;\r\nend;\r\n\r\nprocedure FixedDefaultEditPopupUpdate(AEdit: TWinControl);\r\nbegin\r\n if (GlobalHiddenPopup <> nil) and (GlobalHiddenPopup.Edit = AEdit) then\r\n GlobalHiddenPopup.UpdateItems;\r\nend;\r\n\r\n//=== { THiddenPopupObject } =================================================\r\n\r\nfunction THiddenPopupObject.CanUndo: Boolean;\r\nbegin\r\n if Assigned(Edit) and Edit.HandleAllocated then\r\n Result := SendMessage(EditHandle, EM_CANUNDO, 0, 0) <> 0\r\n else\r\n Result := False;\r\nend;\r\n\r\nprocedure THiddenPopupObject.DoCopy(Sender: TObject);\r\nvar\r\n PopupIntf: IFixedPopupIntf;\r\nbegin\r\n if Assigned(Edit) and Edit.HandleAllocated then\r\n if Supports(Edit, IFixedPopupIntf, PopupIntf) then\r\n PopupIntf.Copy\r\n else\r\n Edit.Perform(WM_COPY, 0, 0);\r\nend;\r\n\r\nprocedure THiddenPopupObject.DoCut(Sender: TObject);\r\nvar\r\n PopupIntf: IFixedPopupIntf;\r\nbegin\r\n if Assigned(Edit) and Edit.HandleAllocated then\r\n if Supports(Edit, IFixedPopupIntf, PopupIntf) then\r\n PopupIntf.Cut\r\n else\r\n Edit.Perform(WM_CUT, 0, 0);\r\nend;\r\n\r\nprocedure THiddenPopupObject.DoDelete(Sender: TObject);\r\nvar\r\n PopupIntf: IFixedPopupIntf;\r\nbegin\r\n if Assigned(Edit) and Edit.HandleAllocated then\r\n if Supports(Edit, IFixedPopupIntf, PopupIntf) then\r\n PopupIntf.Delete\r\n else\r\n Edit.Perform(WM_CLEAR, 0, 0);\r\nend;\r\n\r\nprocedure THiddenPopupObject.DoPaste(Sender: TObject);\r\nvar\r\n PopupIntf: IFixedPopupIntf;\r\nbegin\r\n if Assigned(Edit) and Edit.HandleAllocated then\r\n if Supports(Edit, IFixedPopupIntf, PopupIntf) then\r\n PopupIntf.Paste\r\n else\r\n Edit.Perform(WM_PASTE, 0, 0);\r\nend;\r\n\r\nprocedure THiddenPopupObject.DoSelectAll(Sender: TObject);\r\nvar\r\n PopupIntf: IFixedPopupIntf;\r\nbegin\r\n if Assigned(Edit) and Edit.HandleAllocated then\r\n if Supports(Edit, IFixedPopupIntf, PopupIntf) then\r\n PopupIntf.SelectAll\r\n else\r\n Edit.Perform(EM_SETSEL, 0, -1);\r\nend;\r\n\r\nprocedure THiddenPopupObject.DoUndo(Sender: TObject);\r\nvar\r\n PopupIntf: IFixedPopupIntf;\r\nbegin\r\n if Assigned(Edit) and Edit.HandleAllocated then\r\n begin\r\n if Supports(Edit, IFixedPopupIntf, PopupIntf) then\r\n PopupIntf.Undo\r\n else\r\n begin\r\n if Edit is TCustomCombo then\r\n SendMessage(EditHandle, WM_UNDO, 0, 0)\r\n else\r\n Edit.Perform(WM_UNDO, 0, 0);\r\n end;\r\n end;\r\nend;\r\n\r\ntype\r\n TIntegerSet = set of 0..SizeOf(Integer) * 8 - 1;\r\n\r\nfunction THiddenPopupObject.GetClipboardCommands: TJvClipboardCommands;\r\nconst\r\n cClipboardCommands = 'ClipboardCommands';\r\nbegin\r\n if IsPublishedProp(Edit, cClipboardCommands) then\r\n Result := TJvClipboardCommands(Byte(GetOrdProp(Edit, cClipboardCommands)))\r\n else\r\n Result := [caCopy, caCut, caPaste, caUndo];\r\nend;\r\n\r\nprocedure THiddenPopupObject.GetDefaultMenuCaptions;\r\nconst\r\n BufLen = 255;\r\nvar\r\n H: HMODULE;\r\n hMenu, hSubMenu: THandle;\r\n Buf: array [0..BufLen] of Char;\r\nbegin\r\n // get the translated captions from Windows' own default popup:\r\n H := GetModuleHandle('user32.dll');\r\n hMenu := LoadMenu(H, MakeIntResource(1));\r\n if hMenu = 0 then\r\n Exit;\r\n try\r\n hSubMenu := GetSubMenu(hMenu, 0);\r\n if hSubMenu = 0 then\r\n Exit;\r\n\r\n if GetMenuString(hSubMenu, WM_UNDO, Buf, BufLen, MF_BYCOMMAND) <> 0 then\r\n FPopupMenu.Items[0].Caption := Buf;\r\n if GetMenuString(hSubMenu, WM_CUT, Buf, BufLen, MF_BYCOMMAND) <> 0 then\r\n FPopupMenu.Items[2].Caption := Buf;\r\n if GetMenuString(hSubMenu, WM_COPY, Buf, BufLen, MF_BYCOMMAND) <> 0 then\r\n FPopupMenu.Items[3].Caption := Buf;\r\n if GetMenuString(hSubMenu, WM_PASTE, Buf, BufLen, MF_BYCOMMAND) <> 0 then\r\n FPopupMenu.Items[4].Caption := Buf;\r\n if GetMenuString(hSubMenu, WM_CLEAR, Buf, BufLen, MF_BYCOMMAND) <> 0 then\r\n FPopupMenu.Items[5].Caption := Buf;\r\n if GetMenuString(hSubMenu, EM_SETSEL, Buf, BufLen, MF_BYCOMMAND) <> 0 then\r\n FPopupMenu.Items[7].Caption := Buf;\r\n finally\r\n DestroyMenu(hMenu);\r\n end;\r\nend;\r\n\r\n{function THiddenPopupObject.GetPopupMenu: TPopupMenu;\r\nbegin\r\n Result := GetPopupMenuEx(True);\r\nend;}\r\n\r\nfunction THiddenPopupObject.GetPopupMenuEx(Update: Boolean): TPopupMenu;\r\nvar\r\n m: TMenuItem;\r\nbegin\r\n if FPopupMenu = nil then\r\n begin\r\n FPopupMenu := TPopupMenu.Create(Self);\r\n { build menu:\r\n Undo\r\n -\r\n Cut\r\n Copy\r\n Paste\r\n Delete\r\n -\r\n Select All\r\n }\r\n\r\n // start off with resourcestrings (in case GetDefaultMenuCaptions fails)\r\n m := TMenuItem.Create(Self);\r\n m.Caption := RsUndoItem;\r\n m.OnClick := DoUndo;\r\n FPopupMenu.Items.Add(m);\r\n\r\n m := TMenuItem.Create(Self);\r\n m.Caption := '-';\r\n FPopupMenu.Items.Add(m);\r\n\r\n m := TMenuItem.Create(Self);\r\n m.Caption := RsCutItem;\r\n m.OnClick := DoCut;\r\n FPopupMenu.Items.Add(m);\r\n\r\n m := TMenuItem.Create(Self);\r\n m.Caption := RsCopyItem;\r\n m.OnClick := DoCopy;\r\n FPopupMenu.Items.Add(m);\r\n\r\n m := TMenuItem.Create(Self);\r\n m.Caption := RsPasteItem;\r\n m.OnClick := DoPaste;\r\n FPopupMenu.Items.Add(m);\r\n\r\n m := TMenuItem.Create(Self);\r\n m.Caption := RsDeleteItem;\r\n m.OnClick := DoDelete;\r\n FPopupMenu.Items.Add(m);\r\n\r\n m := TMenuItem.Create(Self);\r\n m.Caption := '-';\r\n FPopupMenu.Items.Add(m);\r\n\r\n m := TMenuItem.Create(Self);\r\n m.Caption := RsSelectAllItem;\r\n m.OnClick := DoSelectAll;\r\n FPopupMenu.Items.Add(m);\r\n\r\n if not GlobalUseResourceStrings then\r\n GetDefaultMenuCaptions;\r\n end;\r\n if Update then\r\n UpdateItems;\r\n Result := FPopupMenu;\r\nend;\r\n\r\nprocedure THiddenPopupObject.UpdateItems;\r\nvar\r\n cc: TJvClipboardCommands;\r\n ASelLength: Integer;\r\n AReadOnly: Boolean;\r\n ATextLen: Integer;\r\n PopupIntf: IFixedPopupIntf;\r\nbegin\r\n if (Edit <> nil) and Edit.HandleAllocated then\r\n begin\r\n cc := GetClipboardCommands;\r\n FPopupMenu.PopupComponent := Edit;\r\n\r\n if Supports(Edit, IFixedPopupIntf, PopupIntf) then\r\n begin\r\n // undo\r\n FPopupMenu.Items[0].Enabled := (caUndo in cc) and PopupIntf.CanUndo;\r\n // cut\r\n FPopupMenu.Items[2].Enabled := (caCut in cc) and PopupIntf.HasSelection and PopupIntf.CanCut;\r\n // copy\r\n FPopupMenu.Items[3].Enabled := (caCopy in cc) and PopupIntf.HasSelection and PopupIntf.CanCopy;\r\n // paste\r\n FPopupMenu.Items[4].Enabled := (caPaste in cc) and PopupIntf.CanPaste;\r\n // delete\r\n FPopupMenu.Items[5].Enabled := PopupIntf.HasSelection and PopupIntf.CanCut;\r\n // select all\r\n FPopupMenu.Items[7].Enabled := PopupIntf.CanSelectAll;\r\n end\r\n else\r\n begin\r\n ASelLength := SelLength;\r\n AReadOnly := ReadOnly;\r\n ATextLen := GetTextLen;\r\n\r\n // undo\r\n FPopupMenu.Items[0].Enabled := (caUndo in cc) and CanUndo;\r\n // cut\r\n FPopupMenu.Items[2].Enabled := (ASelLength > 0) and not AReadOnly and (caCut in cc);\r\n // copy\r\n FPopupMenu.Items[3].Enabled := (ASelLength > 0) and (caCopy in cc);\r\n // paste\r\n FPopupMenu.Items[4].Enabled := not AReadOnly and (caPaste in cc);\r\n // delete\r\n FPopupMenu.Items[5].Enabled := (ASelLength > 0) and not AReadOnly { and (caCut in cc)};\r\n // select all\r\n FPopupMenu.Items[7].Enabled := (ATextLen > 0) and (ASelLength <> ATextLen);\r\n end;\r\n end;\r\nend;\r\n\r\n\r\ntype\r\n TOpenCustomCombo = class(TCustomCombo);\r\n\r\nfunction THiddenPopupObject.GetEditHandle: THandle;\r\nbegin\r\n Result := Edit.Handle;\r\n if Edit is TCustomCombo then\r\n begin\r\n Result := TOpenCustomCombo(Edit).FEditHandle;\r\n end;\r\nend;\r\n\r\nfunction THiddenPopupObject.GetTextLen: Integer;\r\nbegin\r\n if (Edit <> nil) and Edit.HandleAllocated then\r\n Result := Edit.GetTextLen\r\n else\r\n Result := 0;\r\nend;\r\n\r\nfunction THiddenPopupObject.ReadOnly: Boolean;\r\nbegin\r\n if (Edit <> nil) and Edit.HandleAllocated then\r\n Result := GetWindowLong(EditHandle, GWL_STYLE) and ES_READONLY = ES_READONLY\r\n else\r\n Result := False;\r\nend;\r\n\r\nfunction THiddenPopupObject.SelLength: Integer;\r\nvar\r\n StartPos, EndPos: Longint;\r\n MsgResult: Longint;\r\nbegin\r\n Result := 0;\r\n if (Edit <> nil) and Edit.HandleAllocated then\r\n begin\r\n StartPos := 0;\r\n EndPos := 0;\r\n MsgResult := SendMessage(EditHandle, EM_GETSEL, WPARAM(@StartPos), LPARAM(@EndPos));\r\n Result := EndPos - StartPos;\r\n if (Result <= 0) and (MsgResult > 0) then\r\n Result := LongRec(MsgResult).Hi - LongRec(MsgResult).Lo;\r\n end;\r\nend;\r\n\r\nprocedure THiddenPopupObject.SetEdit(const Value: TWinControl);\r\nbegin\r\n ReplaceComponentReference(Self, Value, TComponent(FEdit));\r\nend;\r\n\r\nprocedure THiddenPopupObject.Notification(AComponent: TComponent;\r\n Operation: TOperation);\r\nbegin\r\n inherited Notification(AComponent, Operation);\r\n if (Operation = opRemove) and (AComponent = FEdit) then\r\n Edit := nil;\r\nend;\r\n\r\ndestructor THiddenPopupObject.Destroy;\r\nbegin\r\n Edit := nil;\r\n inherited Destroy;\r\nend;\r\n\r\ninitialization\r\n {$IFDEF UNITVERSIONING}\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n {$ENDIF UNITVERSIONING}\r\n\r\nfinalization\r\n FreeAndNil(GlobalHiddenPopup);\r\n {$IFDEF UNITVERSIONING}\r\n UnregisterUnitVersion(HInstance);\r\n {$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvFooter.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvFooter.PAS, released on 2002-09-02.\r\n\r\nThe Initial Developer of the Original Code is Fernando Silva [fernando dott silva att myrealbox dott com]\r\nPortions created by Fernando Silva are Copyright (C) 2002 Fernando Silva.\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvFooter.pas 13138 2011-10-26 23:17:50Z jfudickar $\r\n\r\nunit JvFooter;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n SysUtils, Classes, Messages, Graphics, Controls, StdCtrls, ExtCtrls,\r\n JvExtComponent, JvCtrls, JvTypes;\r\n\r\ntype\r\n EJvFooterError = class(EJVCLException);\r\n\r\n TJvFooterBtn = class(TJvImgBtn)\r\n private\r\n FAlignment: TAlignment;\r\n FButtonIndex: Integer;\r\n FSpaceInterval: Integer;\r\n function GetButtonIndex: Integer;\r\n procedure SetButtonIndex(const Value: Integer);\r\n procedure SetAlignment(const Value: TAlignment);\r\n procedure SetSpaceInterval(const Value: Integer);\r\n procedure WMMove(var Msg: TWMMove); message WM_MOVE;\r\n procedure WMSize(var Msg: TWMSize); message WM_SIZE;\r\n protected\r\n procedure SetParent(AParent: TWinControl); override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n published\r\n property Alignment: TAlignment read FAlignment write SetAlignment default taRightJustify;\r\n property ButtonIndex: Integer read GetButtonIndex write SetButtonIndex;\r\n property SpaceInterval: Integer read FSpaceInterval write SetSpaceInterval;\r\n end;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvFooter = class(TJvCustomPanel)\r\n private\r\n FBevelStyle: TJvBevelStyle;\r\n FBevelVisible: Boolean;\r\n FMargin: Integer;\r\n procedure SetBevelStyle(Value: TJvBevelStyle);\r\n procedure SetBevelVisible(Value: Boolean);\r\n procedure UpdatePosition;\r\n procedure GetBtnsValues(const ABtnIndex: Integer;\r\n const AAlignment: TAlignment; const ADirection: Integer;\r\n out BtnCount, BtnTotalSpc, BtnLeft: Integer);\r\n procedure SetMargin(const Value: Integer);\r\n protected\r\n procedure Paint; override;\r\n procedure Loaded; override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n // property DockManager;\r\n published\r\n property Align;\r\n property Anchors;\r\n property AutoSize;\r\n property BiDiMode;\r\n property DragCursor;\r\n property DragKind;\r\n property ParentBiDiMode;\r\n property OnCanResize;\r\n property OnEndDock;\r\n property OnStartDock;\r\n property BevelStyle: TJvBevelStyle read FBevelStyle write SetBevelStyle default bsLowered;\r\n property BevelVisible: Boolean read FBevelVisible write SetBevelVisible default False;\r\n property Color;\r\n property Constraints;\r\n //property DockSite;\r\n property DragMode;\r\n property Enabled;\r\n property Font;\r\n property Margin: Integer read FMargin write SetMargin default 8;\r\n {$IFDEF JVCLThemesEnabled}\r\n property ParentBackground;\r\n {$ENDIF JVCLThemesEnabled}\r\n property ParentColor;\r\n property ParentFont;\r\n property ParentShowHint;\r\n property PopupMenu;\r\n property ShowHint;\r\n //property TabOrder;\r\n //property TabStop;\r\n property Visible;\r\n property OnClick;\r\n property OnConstrainedResize;\r\n property OnContextPopup;\r\n //property OnDockDrop;\r\n //property OnDockOver;\r\n property OnDblClick;\r\n property OnDragDrop;\r\n property OnDragOver;\r\n property OnEndDrag;\r\n property OnEnter;\r\n property OnExit;\r\n //property OnGetSiteInfo;\r\n property OnMouseDown;\r\n property OnMouseMove;\r\n property OnMouseUp;\r\n property OnResize;\r\n property OnStartDrag;\r\n //property OnUnDock;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvFooter.pas $';\r\n Revision: '$Revision: 13138 $';\r\n Date: '$Date: 2011-10-27 01:17:50 +0200 (jeu. 27 oct. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n JvResources;\r\n\r\n//=== { TJvFooterBtn } =======================================================\r\n\r\nconst\r\n DefFootWidth = 350;\r\n DefFootHeight = 37;\r\n\r\nconstructor TJvFooterBtn.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FAlignment := taRightJustify;\r\n FSpaceInterval := 6;\r\n Width := 74;\r\n Height := 23;\r\nend;\r\n\r\nfunction TJvFooterBtn.GetButtonIndex: Integer;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := FButtonIndex;\r\n if Parent <> nil then\r\n for I := 0 to Parent.ControlCount - 1 do\r\n if Parent.Controls[I] = Self then\r\n begin\r\n Result := I;\r\n Break;\r\n end;\r\nend;\r\n\r\nprocedure TJvFooterBtn.SetButtonIndex(const Value: Integer);\r\nbegin\r\n if FButtonIndex <> Value then\r\n begin\r\n if Parent <> nil then\r\n TJvFooter(Parent).SetChildOrder(Self, Value);\r\n FButtonIndex := GetButtonIndex;\r\n if ComponentState * [csLoading, csDestroying] = [] then\r\n TJvFooter(Parent).UpdatePosition;\r\n end;\r\nend;\r\n\r\nprocedure TJvFooterBtn.SetAlignment(const Value: TAlignment);\r\nbegin\r\n if FAlignment <> Value then\r\n begin\r\n FAlignment := Value;\r\n if ComponentState * [csLoading, csDestroying] = [] then\r\n TJvFooter(Parent).UpdatePosition;\r\n end;\r\nend;\r\n\r\nprocedure TJvFooterBtn.SetSpaceInterval(const Value: Integer);\r\nbegin\r\n if FSpaceInterval <> Value then\r\n begin\r\n FSpaceInterval := Value;\r\n if ComponentState * [csLoading, csDestroying] = [] then\r\n TJvFooter(Parent).UpdatePosition;\r\n end;\r\nend;\r\n\r\n\r\nprocedure TJvFooterBtn.WMMove(var Msg: TWMMove);\r\nbegin\r\n // Avoid running at runtime\r\n // if (csDesigning in ComponentState) then\r\n TJvFooter(Parent).UpdatePosition;\r\nend;\r\n\r\n\r\n\r\n\r\nprocedure TJvFooterBtn.WMSize(var Msg: TWMSize);\r\n\r\nbegin\r\n // Does not allow SizeChange\r\n // Avoid running at runtime\r\n if csDesigning in ComponentState then\r\n SetBounds(Left, Top, Width, Height);\r\nend;\r\n\r\n\r\n\r\nprocedure TJvFooterBtn.SetParent(AParent: TWinControl);\r\n\r\nbegin\r\n if AParent is TJvFooterBtn then // (p3) D6 messing up ?\r\n AParent := TJvFooterBtn(AParent).Parent;\r\n if not ((AParent is TJvFooter) or (AParent = nil)) then\r\n raise EJvFooterError.CreateRes(@RsETJvFooterBtnCanOnlyBePlacedOnATJvFo);\r\n inherited SetParent(AParent);\r\nend;\r\n\r\n//=== { TJvFooter } ==========================================================\r\n\r\nconstructor TJvFooter.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FMargin := 8;\r\n Align := alBottom;\r\n ControlStyle := ControlStyle - [csSetCaption];\r\n Caption := '';\r\n Width := DefFootWidth;\r\n Height := DefFootHeight;\r\n\r\n BevelOuter := bvNone;\r\n BevelWidth := 1;\r\n Color := clBtnFace;\r\n //UseDockManager := False;\r\n FBevelStyle := bsLowered;\r\n FBevelVisible := False;\r\nend;\r\n\r\nprocedure TJvFooter.Loaded;\r\nbegin\r\n TJvFooter(Parent).UpdatePosition;\r\n inherited Loaded;\r\nend;\r\n\r\nprocedure TJvFooter.GetBtnsValues(const ABtnIndex: Integer;\r\n const AAlignment: TAlignment; const ADirection: Integer;\r\n out BtnCount, BtnTotalSpc, BtnLeft: Integer);\r\nvar\r\n Idx: Integer;\r\n\r\n // This function returns some total values about the buttons in use\r\n // BtnCount and BtnTotalSpc return values not considering the current index,\r\n // except when searching all values;\r\n procedure DoTheCount(Idx: Integer);\r\n begin\r\n if (Controls[Idx] is TJvFooterBtn) and\r\n (TJvFooterBtn(Controls[Idx]).Alignment = AAlignment) and\r\n (TJvFooterBtn(Controls[Idx]).Visible or (csDesigning in ComponentState)) then\r\n begin\r\n Inc(BtnCount);\r\n Inc(BtnTotalSpc, TJvFooterBtn(Controls[Idx]).SpaceInterval);\r\n Inc(BtnLeft, TJvFooterBtn(Controls[Idx]).Width);\r\n end;\r\n end;\r\n\r\nbegin\r\n BtnCount := 0;\r\n BtnTotalSpc := 0;\r\n case ADirection of\r\n 1: // Forward\r\n for Idx := ABtnIndex + 1 to ControlCount - 1 do\r\n DoTheCount(Idx);\r\n 0: // All\r\n for Idx := 0 to ControlCount - 1 do\r\n DoTheCount(Idx);\r\n -1: // Backward\r\n for Idx := ABtnIndex - 1 downto 0 do\r\n DoTheCount(Idx);\r\n end;\r\nend;\r\n\r\nprocedure TJvFooter.UpdatePosition;\r\nvar\r\n Idx: Integer;\r\n FBtnLeft, FBtnTop, FBtnWidth, FBtnHeight: Integer;\r\n FBtnCount, FBtnCount_2, FBtnSpace, FBtnSpace_2, FBtnLeft_2: Integer;\r\nbegin\r\n for Idx := 0 to ControlCount - 1 do\r\n if Controls[Idx] is TJvFooterBtn then\r\n begin\r\n FBtnTop := (Self.Height - TJvFooterBtn(Controls[Idx]).Height) div 2;\r\n FBtnWidth := TJvFooterBtn(Controls[Idx]).Width;\r\n FBtnHeight := TJvFooterBtn(Controls[Idx]).Height;\r\n\r\n case TJvFooterBtn(Controls[Idx]).Alignment of\r\n taCenter:\r\n begin\r\n // Set anchors\r\n TJvFooterBtn(Controls[Idx]).Anchors := [akBottom];\r\n // Normal return\r\n FBtnLeft_2 := 0;\r\n GetBtnsValues(TJvFooterBtn(Controls[Idx]).ButtonIndex,\r\n TJvFooterBtn(Controls[Idx]).Alignment, -1, FBtnCount_2, FBtnSpace_2, FBtnLeft_2);\r\n // Get all buttons\r\n FBtnLeft := 0;\r\n GetBtnsValues(0, TJvFooterBtn(Controls[Idx]).Alignment, 0, FBtnCount, FBtnSpace, FBtnLeft);\r\n\r\n FBtnLeft := (Width div 2) -\r\n (FBtnLeft + FBtnSpace) div 2 +\r\n (FBtnLeft_2 + FBtnSpace_2);\r\n end;\r\n taLeftJustify:\r\n begin\r\n // Set anchors\r\n TJvFooterBtn(Controls[Idx]).Anchors := [akLeft, akBottom];\r\n\r\n // get the number of backward buttons\r\n FBtnLeft := 0;\r\n GetBtnsValues(TJvFooterBtn(Controls[Idx]).ButtonIndex,\r\n TJvFooterBtn(Controls[Idx]).Alignment, -1, FBtnCount, FBtnSpace, FBtnLeft);\r\n\r\n if FBtnCount = 0 then\r\n FBtnLeft := FBtnLeft + Margin\r\n else\r\n FBtnLeft := FBtnLeft + FBtnSpace +\r\n TJvFooterBtn(Controls[Idx]).SpaceInterval;\r\n end;\r\n taRightJustify:\r\n begin\r\n // Set anchors\r\n TJvFooterBtn(Controls[Idx]).Anchors := [akRight, akBottom];\r\n // get the number of forward buttons\r\n FBtnLeft := 0;\r\n GetBtnsValues(TJvFooterBtn(Controls[Idx]).ButtonIndex,\r\n TJvFooterBtn(Controls[Idx]).Alignment, 1, FBtnCount, FBtnSpace, FBtnLeft);\r\n\r\n FBtnLeft := Width - (FBtnLeft + FBtnWidth);\r\n if FBtnCount = 0 then\r\n FBtnLeft := FBtnLeft - Margin\r\n else\r\n FBtnLeft := FBtnLeft - FBtnSpace - TJvFooterBtn(Controls[Idx]).SpaceInterval;\r\n end;\r\n else\r\n FBtnLeft := 0;\r\n end;\r\n\r\n Controls[Idx].SetBounds(FBtnLeft, FBtnTop, FBtnWidth, FBtnHeight);\r\n end;\r\nend;\r\n\r\nprocedure TJvFooter.SetBevelStyle(Value: TJvBevelStyle);\r\nbegin\r\n if Value <> FBevelStyle then\r\n begin\r\n FBevelStyle := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvFooter.SetBevelVisible(Value: Boolean);\r\nbegin\r\n if Value <> FBevelVisible then\r\n begin\r\n FBevelVisible := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvFooter.Paint;\r\nvar\r\n Color1, Color2: TColor;\r\n\r\n procedure BevelLine(C: TColor; X1, Y1, X2, Y2: Integer);\r\n begin\r\n with Canvas do\r\n begin\r\n Pen.Color := C;\r\n MoveTo(X1, Y1);\r\n LineTo(X2, Y2);\r\n end;\r\n end;\r\n\r\nbegin\r\n inherited Paint;\r\n // Draw Line in the top of the footer\r\n if FBevelVisible then\r\n with Canvas do\r\n begin\r\n if csDesigning in ComponentState then\r\n begin\r\n Pen.Style := psSolid;\r\n Pen.Mode := pmCopy;\r\n Pen.Color := clBlack;\r\n Brush.Style := bsSolid;\r\n end;\r\n\r\n Pen.Width := 1;\r\n\r\n if FBevelStyle = bsLowered then\r\n begin\r\n Color1 := clBtnShadow;\r\n Color2 := clBtnHighlight;\r\n end\r\n else\r\n begin\r\n Color1 := clBtnHighlight;\r\n Color2 := clBtnShadow;\r\n end;\r\n\r\n BevelLine(Color1, 0, 0, Width, 0);\r\n BevelLine(Color2, 0, 1, Width, 1);\r\n end;\r\nend;\r\n\r\nprocedure TJvFooter.SetMargin(const Value: Integer);\r\nbegin\r\n if FMargin <> Value then\r\n begin\r\n FMargin := Value;\r\n if ComponentState * [csLoading, csDestroying] = [] then\r\n UpdatePosition;\r\n end;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvFormAnimatedIcon.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvFormAnimatedIcon.PAS, released on 2001-02-28.\r\n\r\nThe Initial Developer of the Original Code is Sbastien Buysse [sbuysse att buypin dott com]\r\nPortions created by Sbastien Buysse are Copyright (C) 2001 Sbastien Buysse.\r\nAll Rights Reserved.\r\n\r\nContributor(s): Michael Beck [mbeck att bigfoot dott com].\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvFormAnimatedIcon.pas 13104 2011-09-07 06:50:43Z obones $\r\n\r\nunit JvFormAnimatedIcon;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n SysUtils, Classes, Controls, Forms, ExtCtrls,\r\n ImgList, Graphics, // clx required\r\n JvComponentBase;\r\n\r\ntype\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64 or pidOSX32)]\r\n {$ENDIF RTL230_UP}\r\n TJvFormAnimatedIcon = class(TJvComponent)\r\n private\r\n FForm: TCustomForm;\r\n FActive: Boolean;\r\n FDelay: Cardinal;\r\n FIcons: TImageList;\r\n FTimer: TTimer;\r\n FNumber: Integer;\r\n procedure SetActive(const Value: Boolean);\r\n procedure SetDelay(const Value: Cardinal);\r\n procedure Animate(Sender: TObject);\r\n procedure SetIcons(const Value: TImageList);\r\n protected\r\n procedure Notification(AComponent: TComponent; Operation: TOperation); override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n published\r\n property Icons: TImageList read FIcons write SetIcons;\r\n property Active: Boolean read FActive write SetActive default True;\r\n property Delay: Cardinal read FDelay write SetDelay default 100;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvFormAnimatedIcon.pas $';\r\n Revision: '$Revision: 13104 $';\r\n Date: '$Date: 2011-09-07 08:50:43 +0200 (mer. 07 sept. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n JvJVCLUtils;\r\n\r\n\r\nconstructor TJvFormAnimatedIcon.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n\r\n FForm := GetParentForm(TControl(AOwner));\r\n FActive := True;\r\n FNumber := 0;\r\n FDelay := 100;\r\n\r\n FTimer := nil;\r\n if not (csDesigning in ComponentState) then\r\n begin\r\n FTimer := TTimer.Create(Self);\r\n FTimer.OnTimer := Animate;\r\n FTimer.Interval := FDelay;\r\n FTimer.Enabled := FActive;\r\n end;\r\nend;\r\n\r\ndestructor TJvFormAnimatedIcon.Destroy;\r\nbegin\r\n FTimer.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvFormAnimatedIcon.Notification(AComponent: TComponent;\r\n Operation: TOperation);\r\nbegin\r\n inherited Notification(AComponent, Operation);\r\n \r\n if Operation = opRemove then\r\n begin\r\n if AComponent = FIcons then\r\n SetIcons(nil);\r\n end;\r\nend;\r\n\r\nprocedure TJvFormAnimatedIcon.Animate(Sender: TObject);\r\n\r\nbegin\r\n if (FIcons <> nil) and (FIcons.Count <> 0) then\r\n begin\r\n FNumber := (FNumber + 1) mod FIcons.Count;\r\n FIcons.GetIcon(FNumber, TForm(FForm).Icon);\r\n end;\r\nend;\r\n\r\nprocedure TJvFormAnimatedIcon.SetActive(const Value: Boolean);\r\nbegin\r\n FActive := Value;\r\n if not (csDesigning in ComponentState) then\r\n FTimer.Enabled := FActive;\r\nend;\r\n\r\nprocedure TJvFormAnimatedIcon.SetDelay(const Value: Cardinal);\r\nbegin\r\n FDelay := Value;\r\n if not (csDesigning in ComponentState) then\r\n FTimer.Interval := FDelay;\r\nend;\r\n\r\nprocedure TJvFormAnimatedIcon.SetIcons(const Value: TImageList);\r\nbegin\r\n ReplaceComponentReference(Self, Value, TComponent(FIcons));\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvFormAnimation.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvFormAnimation.PAS, released on 2001-02-28.\r\n\r\nThe Initial Developer of the Original Code is Sbastien Buysse [sbuysse att buypin dott com]\r\nPortions created by Sbastien Buysse are Copyright (C) 2001 Sbastien Buysse.\r\nAll Rights Reserved.\r\n\r\nContributor(s): Michael Beck [mbeck att bigfoot dott com].\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvFormAnimation.pas 13104 2011-09-07 06:50:43Z obones $\r\n\r\nunit JvFormAnimation;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n SysUtils, Classes,\r\n Windows, Controls, Forms,\r\n JvComponentBase, JvTypes;\r\n\r\ntype\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64 or pidOSX32)]\r\n {$ENDIF RTL230_UP}\r\n TJvFormAnimation = class(TJvComponent)\r\n private\r\n FForm: TCustomForm;\r\n FRegions: array of HRGN;\r\n // (rom) simplified\r\n procedure AnimateDisappear(N: Integer);\r\n procedure AnimateAppear(N: Integer);\r\n procedure DeleteRegions;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n published\r\n procedure DisappearEllipse;\r\n procedure DisappearRectangle;\r\n procedure DisappearRoundedRectangle(EllipseX, EllipseY: Integer);\r\n procedure DisappearHorizontally;\r\n procedure DisappearVertically;\r\n procedure DisappearTelevision;\r\n procedure DisappearToBottom;\r\n procedure DisappearToTop;\r\n procedure AppearEllipse;\r\n procedure AppearRectangle;\r\n procedure AppearRoundedRectangle(EllipseX, EllipseY: Integer);\r\n procedure AppearHorizontally;\r\n procedure AppearVertically;\r\n procedure AppearTelevision;\r\n procedure AppearToTop;\r\n procedure AppearToBottom;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvFormAnimation.pas $';\r\n Revision: '$Revision: 13104 $';\r\n Date: '$Date: 2011-09-07 08:50:43 +0200 (mer. 07 sept. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n Math;\r\n\r\nconstructor TJvFormAnimation.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FForm := GetParentForm(TControl(AOwner));\r\nend;\r\n\r\nprocedure TJvFormAnimation.AnimateDisappear(N: Integer);\r\nvar\r\n I: Integer;\r\nbegin\r\n FForm.Visible := True;\r\n for I := 0 to N do\r\n begin\r\n if SetWindowRgn(FForm.Handle, FRegions[I], True) <> 0 then\r\n FRegions[I] := NullHandle;\r\n FForm.Repaint;\r\n Sleep(10);\r\n end;\r\n FForm.Visible := False;\r\n SetWindowRgn(FForm.Handle, NullHandle, True);\r\n DeleteRegions;\r\nend;\r\n\r\nprocedure TJvFormAnimation.AnimateAppear(N: Integer);\r\nvar\r\n I: Integer;\r\n Rgn: HRGN;\r\nbegin\r\n FForm.Visible := False;\r\n Rgn := CreateRectRgn(0, 0, 0, 0);\r\n SetWindowRgn(FForm.Handle, Rgn, True);\r\n FForm.Visible := True;\r\n for I := N downto 0 do\r\n begin\r\n if SetWindowRgn(FForm.Handle, FRegions[I], True) <> 0 then\r\n FRegions[I] := NullHandle;\r\n FForm.Repaint;\r\n Sleep(10);\r\n end;\r\n SetWindowRgn(FForm.Handle, NullHandle, True);\r\n DeleteObject(Rgn);\r\n DeleteRegions;\r\nend;\r\n\r\nprocedure TJvFormAnimation.DeleteRegions;\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := Low(FRegions) to High(FRegions) do\r\n if FRegions[I] <> NullHandle then\r\n DeleteObject(FRegions[I]);\r\n SetLength(FRegions, 0);\r\nend;\r\n\r\nprocedure TJvFormAnimation.DisappearEllipse;\r\nvar\r\n I, J, K, L: Integer;\r\nbegin\r\n J := 0;\r\n I := 0;\r\n L := 0;\r\n\r\n SetLength(FRegions, Max(FForm.Width, FForm.Height));\r\n for K := 0 to High(FRegions) do\r\n begin\r\n if I < (FForm.Width div 2) then\r\n begin\r\n J := J + 2;\r\n if J > (FForm.Height div 2) then\r\n I := FForm.Width;\r\n FRegions[K] := CreateEllipticRgn(I, J, FForm.Width - I, FForm.Height - J);\r\n I := I + 2;\r\n end\r\n else\r\n begin\r\n L := K;\r\n Break;\r\n end;\r\n end;\r\n\r\n AnimateDisappear(L);\r\nend;\r\n\r\nprocedure TJvFormAnimation.DisappearRectangle;\r\nvar\r\n I, J, K, L: Integer;\r\nbegin\r\n J := 0;\r\n I := 0;\r\n L := 0;\r\n\r\n SetLength(FRegions, Max(FForm.Width, FForm.Height));\r\n for K := 0 to High(FRegions) do\r\n begin\r\n if I < (FForm.Width div 2) then\r\n begin\r\n J := J + 2;\r\n if J > (FForm.Height div 2) then\r\n I := FForm.Width;\r\n FRegions[K] := CreateRectRgn(I, J, FForm.Width - I, FForm.Height - J);\r\n I := I + 2;\r\n end\r\n else\r\n begin\r\n L := K;\r\n Break;\r\n end;\r\n end;\r\n\r\n AnimateDisappear(L);\r\nend;\r\n\r\nprocedure TJvFormAnimation.DisappearRoundedRectangle(EllipseX,\r\n EllipseY: Integer);\r\nvar\r\n I, J, K, L: Integer;\r\nbegin\r\n J := 0;\r\n I := 0;\r\n L := 0;\r\n\r\n SetLength(FRegions, Max(FForm.Width, FForm.Height));\r\n for K := 0 to High(FRegions) do\r\n begin\r\n if I < (FForm.Width div 2) then\r\n begin\r\n J := J + 2;\r\n if J > (FForm.Height div 2) then\r\n I := FForm.Width;\r\n FRegions[K] := CreateRoundRectRgn(I, J, FForm.Width - I, FForm.Height - J, EllipseX, EllipseY);\r\n I := I + 2;\r\n end\r\n else\r\n begin\r\n L := K;\r\n Break;\r\n end;\r\n end;\r\n\r\n AnimateDisappear(L);\r\nend;\r\n\r\nprocedure TJvFormAnimation.DisappearHorizontally;\r\nvar\r\n I, J, K, L: Integer;\r\nbegin\r\n J := 0;\r\n L := 0;\r\n I := 0;\r\n\r\n SetLength(FRegions, Max(FForm.Width, FForm.Height));\r\n for K := 0 to High(FRegions) do\r\n begin\r\n if I < (FForm.Width div 2) then\r\n begin\r\n if J > (FForm.Height div 2) then\r\n I := FForm.Width;\r\n FRegions[K] := CreateRectRgn(I, J, FForm.Width - I, FForm.Height - J);\r\n I := I + 2;\r\n end\r\n else\r\n begin\r\n L := K;\r\n Break;\r\n end;\r\n end;\r\n\r\n AnimateDisappear(L);\r\nend;\r\n\r\nprocedure TJvFormAnimation.DisappearVertically;\r\nvar\r\n I, J, K, L: Integer;\r\nbegin\r\n J := 0;\r\n I := 0;\r\n L := 0;\r\n\r\n SetLength(FRegions, Max(FForm.Width, FForm.Height));\r\n for K := 0 to High(FRegions) do\r\n begin\r\n if J < (FForm.Height div 2) then\r\n begin\r\n J := J + 2;\r\n if J > (FForm.Height div 2) then\r\n I := FForm.Width;\r\n FRegions[K] := CreateRectRgn(I, J, FForm.Width - I, FForm.Height - J);\r\n end\r\n else\r\n begin\r\n L := K;\r\n Break;\r\n end;\r\n end;\r\n\r\n AnimateDisappear(L);\r\nend;\r\n\r\nprocedure TJvFormAnimation.DisappearTelevision;\r\nvar\r\n I, J, K, L: Integer;\r\nbegin\r\n J := 0;\r\n I := 0;\r\n L := 0;\r\n\r\n SetLength(FRegions, Max(FForm.Width, FForm.Height));\r\n for K := 0 to High(FRegions) do\r\n begin\r\n if J + 2 < (FForm.Height div 2) then\r\n begin\r\n J := J + 2;\r\n if J > (FForm.Height div 2) then\r\n I := FForm.Width;\r\n FRegions[K] := CreateRectRgn(I, J, FForm.Width - I, FForm.Height - J);\r\n end\r\n else\r\n if I + 6 < (FForm.Width div 2) then\r\n begin\r\n I := I + 8;\r\n FRegions[K] := CreateRectRgn(I, J, FForm.Width - I, FForm.Height - J);\r\n end\r\n else\r\n begin\r\n L := K;\r\n Break;\r\n end;\r\n end;\r\n\r\n AnimateDisappear(L);\r\nend;\r\n\r\nprocedure TJvFormAnimation.DisappearToBottom;\r\nvar\r\n I, J, K, L: Integer;\r\nbegin\r\n J := 0;\r\n I := 0;\r\n L := 0;\r\n\r\n SetLength(FRegions, Max(FForm.Width, FForm.Height));\r\n for K := 0 to High(FRegions) do\r\n begin\r\n if J < FForm.Height then\r\n begin\r\n J := J + 2;\r\n FRegions[K] := CreateRectRgn(I, J, FForm.Width, FForm.Height);\r\n end\r\n else\r\n begin\r\n L := K;\r\n Break;\r\n end;\r\n end;\r\n\r\n AnimateDisappear(L);\r\nend;\r\n\r\nprocedure TJvFormAnimation.DisappearToTop;\r\nvar\r\n I, J, K, L: Integer;\r\nbegin\r\n J := 0;\r\n I := 0;\r\n L := 0;\r\n\r\n SetLength(FRegions, Max(FForm.Width, FForm.Height));\r\n for K := 0 to High(FRegions) do\r\n begin\r\n if J < FForm.Height then\r\n begin\r\n J := J + 2;\r\n FRegions[K] := CreateRectRgn(I, 0, FForm.Width, FForm.Height - J);\r\n end\r\n else\r\n begin\r\n L := K;\r\n Break;\r\n end;\r\n end;\r\n\r\n AnimateDisappear(L);\r\nend;\r\n\r\nprocedure TJvFormAnimation.AppearEllipse;\r\nvar\r\n I, J, K, L: Integer;\r\nbegin\r\n J := 0;\r\n I := 0;\r\n L := 0;\r\n\r\n SetLength(FRegions, Max(FForm.Width, FForm.Height));\r\n for K := 0 to High(FRegions) do\r\n begin\r\n if I < (FForm.Width div 2) then\r\n begin\r\n J := J + 2;\r\n if J > (FForm.Height div 2) then\r\n I := FForm.Width;\r\n FRegions[K] := CreateEllipticRgn(I, J, FForm.Width - I, FForm.Height - J);\r\n I := I + 2;\r\n end\r\n else\r\n begin\r\n L := K;\r\n Break;\r\n end;\r\n end;\r\n\r\n AnimateAppear(L);\r\nend;\r\n\r\nprocedure TJvFormAnimation.AppearRectangle;\r\nvar\r\n I, J, K, L: Integer;\r\nbegin\r\n J := 0;\r\n I := 0;\r\n L := 0;\r\n\r\n SetLength(FRegions, Max(FForm.Width, FForm.Height));\r\n for K := 0 to High(FRegions) do\r\n begin\r\n if I < (FForm.Width div 2) then\r\n begin\r\n J := J + 2;\r\n if J > (FForm.Height div 2) then\r\n I := FForm.Width;\r\n FRegions[K] := CreateRectRgn(I, J, FForm.Width - I, FForm.Height - J);\r\n I := I + 2;\r\n end\r\n else\r\n begin\r\n L := K;\r\n Break;\r\n end;\r\n end;\r\n\r\n AnimateAppear(L);\r\nend;\r\n\r\nprocedure TJvFormAnimation.AppearRoundedRectangle(EllipseX, EllipseY: Integer);\r\nvar\r\n I, J, K, L: Integer;\r\nbegin\r\n J := 0;\r\n I := 0;\r\n L := 0;\r\n\r\n SetLength(FRegions, Max(FForm.Width, FForm.Height));\r\n for K := 0 to High(FRegions) do\r\n begin\r\n if I < (FForm.Width div 2) then\r\n begin\r\n J := J + 2;\r\n if J > (FForm.Height div 2) then\r\n I := FForm.Width;\r\n FRegions[K] := CreateRoundRectRgn(I, J, FForm.Width - I, FForm.Height - J, EllipseX, EllipseY);\r\n I := I + 2;\r\n end\r\n else\r\n begin\r\n L := K;\r\n Break;\r\n end;\r\n end;\r\n\r\n AnimateAppear(L);\r\nend;\r\n\r\nprocedure TJvFormAnimation.AppearHorizontally;\r\nvar\r\n I, J, K, L: Integer;\r\nbegin\r\n J := 0;\r\n L := 0;\r\n I := 0;\r\n\r\n SetLength(FRegions, Max(FForm.Width, FForm.Height));\r\n for K := 0 to High(FRegions) do\r\n begin\r\n if I < (FForm.Width div 2) then\r\n begin\r\n if J > (FForm.Height div 2) then\r\n I := FForm.Width;\r\n FRegions[K] := CreateRectRgn(I, J, FForm.Width - I, FForm.Height - J);\r\n I := I + 2;\r\n end\r\n else\r\n begin\r\n L := K;\r\n Break;\r\n end;\r\n end;\r\n\r\n AnimateAppear(L);\r\nend;\r\n\r\nprocedure TJvFormAnimation.AppearVertically;\r\nvar\r\n I, J, K, L: Integer;\r\nbegin\r\n J := 0;\r\n I := 0;\r\n L := 0;\r\n\r\n SetLength(FRegions, Max(FForm.Width, FForm.Height));\r\n for K := 0 to High(FRegions) do\r\n begin\r\n if J < (FForm.Height div 2) then\r\n begin\r\n J := J + 2;\r\n if J > (FForm.Height div 2) then\r\n I := FForm.Width;\r\n FRegions[K] := CreateRectRgn(I, J, FForm.Width - I, FForm.Height - J);\r\n end\r\n else\r\n begin\r\n L := K;\r\n Break;\r\n end;\r\n end;\r\n\r\n AnimateAppear(L);\r\nend;\r\n\r\nprocedure TJvFormAnimation.AppearTelevision;\r\nvar\r\n I, J, K, L: Integer;\r\nbegin\r\n J := 0;\r\n I := 0;\r\n L := 0;\r\n\r\n SetLength(FRegions, Max(FForm.Width, FForm.Height));\r\n for K := 0 to High(FRegions) do\r\n begin\r\n if J + 2 < (FForm.Height div 2) then\r\n begin\r\n J := J + 2;\r\n if J > (FForm.Height div 2) then\r\n I := FForm.Width;\r\n FRegions[K] := CreateRectRgn(I, J, FForm.Width - I, FForm.Height - J);\r\n end\r\n else\r\n if I + 6 < (FForm.Width div 2) then\r\n begin\r\n I := I + 8;\r\n FRegions[K] := CreateRectRgn(I, J, FForm.Width - I, FForm.Height - J);\r\n end\r\n else\r\n begin\r\n L := K;\r\n Break;\r\n end;\r\n end;\r\n\r\n AnimateAppear(L);\r\nend;\r\n\r\nprocedure TJvFormAnimation.AppearToBottom;\r\nvar\r\n I, J, K, L: Integer;\r\nbegin\r\n J := 0;\r\n I := 0;\r\n L := 0;\r\n\r\n SetLength(FRegions, Max(FForm.Width, FForm.Height));\r\n for K := 0 to High(FRegions) do\r\n begin\r\n if J < FForm.Height then\r\n begin\r\n J := J + 2;\r\n FRegions[K] := CreateRectRgn(I, J, FForm.Width, FForm.Height);\r\n end\r\n else\r\n begin\r\n L := K;\r\n Break;\r\n end;\r\n end;\r\n\r\n AnimateAppear(L);\r\nend;\r\n\r\nprocedure TJvFormAnimation.AppearToTop;\r\nvar\r\n I, J, K, L: Integer;\r\nbegin\r\n J := 0;\r\n I := 0;\r\n L := 0;\r\n\r\n SetLength(FRegions, Max(FForm.Width, FForm.Height));\r\n for K := 0 to High(FRegions) do\r\n begin\r\n if J < FForm.Height then\r\n begin\r\n J := J + 2;\r\n FRegions[K] := CreateRectRgn(I, 0, FForm.Width, FForm.Height - J);\r\n end\r\n else\r\n begin\r\n L := K;\r\n Break;\r\n end;\r\n end;\r\n\r\n AnimateAppear(L);\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvFormAutoSize.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvAutoSizeCompo.PAS, released on 2001-02-28.\r\n\r\nThe Initial Developer of the Original Code is Sbastien Buysse [sbuysse att buypin dott com]\r\nPortions created by Sbastien Buysse are Copyright (C) 2001 Sbastien Buysse.\r\nAll Rights Reserved.\r\n\r\nContributor(s): Michael Beck [mbeck att bigfoot dott com].\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvFormAutoSize.pas 13104 2011-09-07 06:50:43Z obones $\r\n\r\nunit JvFormAutoSize;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n SysUtils, Classes, Windows, Messages, Graphics, Controls, Forms, StdCtrls,\r\n JvComponentBase;\r\n\r\ntype\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64 or pidOSX32)]\r\n {$ENDIF RTL230_UP}\r\n TJvFormAutoSize = class(TJvComponent)\r\n private\r\n FForm: TForm;\r\n FActive: Boolean;\r\n FResize: TNotifyEvent;\r\n FOldWidth: Integer;\r\n FOldHeight: Integer;\r\n procedure Resize(Sender: TObject);\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n published\r\n // (p3) default here should be false!!!\r\n property Active: Boolean read FActive write FActive default False;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvFormAutoSize.pas $';\r\n Revision: '$Revision: 13104 $';\r\n Date: '$Date: 2011-09-07 08:50:43 +0200 (mer. 07 sept. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\n\r\nconstructor TJvFormAutoSize.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n // (p3) dangerous: True can create problems without user being aware\r\n FActive := False;\r\n FForm := GetParentForm(TControl(AOwner)) as TForm;\r\n if FForm <> nil then\r\n begin\r\n FOldWidth := FForm.Width;\r\n FOldHeight := FForm.Height;\r\n FResize := FForm.OnResize;\r\n FForm.OnResize := Resize;\r\n end;\r\nend;\r\n\r\ndestructor TJvFormAutoSize.Destroy;\r\nbegin\r\n if FForm <> nil then\r\n FForm.OnResize := nil;\r\n FForm := nil;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvFormAutoSize.Resize(Sender: TObject);\r\nvar\r\n WidthRatio, HeightRatio: Double;\r\n CompIndex: Integer;\r\nbegin\r\n if FForm = nil then\r\n FForm := GetParentForm(Owner as TControl) as TForm;\r\n if FActive and (FForm <> nil) then\r\n begin\r\n // (p3) this code is slightly dangerous: no sanity checks -\r\n // values can become really large or really small\r\n if (FOldWidth <> 0) and (FOldHeight <> 0) then\r\n begin\r\n WidthRatio := FForm.Width / FOldWidth;\r\n HeightRatio := FForm.Height / FOldHeight;\r\n for CompIndex := 0 to FForm.ComponentCount - 1 do\r\n begin\r\n if FForm.Components[CompIndex] is TControl then\r\n begin\r\n with FForm.Components[CompIndex] as TControl do\r\n begin\r\n if not (FForm.Components[CompIndex] is TButton) then\r\n begin\r\n Width := Round(Width * WidthRatio);\r\n Height := Round(Height * HeightRatio);\r\n end;\r\n Left := Round(Left * WidthRatio);\r\n Top := Round(Top * HeightRatio);\r\n end;\r\n end;\r\n end;\r\n end;\r\n FOldWidth := FForm.Width;\r\n FOldHeight := FForm.Height;\r\n end;\r\n if Assigned(FResize) then\r\n FResize(Sender);\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend." }, { "path": "External/Jedi/Jvcl/run/JvFormMagnet.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvMagnet.PAS, released on 2001-02-28.\r\n\r\nThe Initial Developer of the Original Code is Sbastien Buysse [sbuysse att buypin dott com]\r\nPortions created by Sbastien Buysse are Copyright (C) 2001 Sbastien Buysse.\r\nAll Rights Reserved.\r\n\r\nContributor(s): Michael Beck [mbeck att bigfoot dott com].\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvFormMagnet.pas 13104 2011-09-07 06:50:43Z obones $\r\n\r\nunit JvFormMagnet;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, Messages, SysUtils, Classes, Controls, Forms,\r\n JvComponentBase, MultiMon;\r\n\r\ntype\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64 or pidOSX32)]\r\n {$ENDIF RTL230_UP}\r\n TJvFormMagnet = class(TJvComponent)\r\n private\r\n FForm: TForm;\r\n FActive: Boolean;\r\n FScreenMagnet: Boolean;\r\n FFormGlue: Boolean;\r\n FArea: Cardinal;\r\n FMainFormMagnet: Boolean;\r\n FLastRightDock: TDateTime;\r\n FLastLeftDock: TDateTime;\r\n FLastTopDock: TDateTime;\r\n FLastBottomDock: TDateTime;\r\n function NewWndProc(var Msg: TMessage): Boolean;\r\n procedure MagnetScreen(OldRect: TRect; var FormRect: TRect; ScreenRect: TRect);\r\n procedure GlueForms(var FormRect: TRect);\r\n procedure MagnetToMain(OldRect: TRect; var FormRect: TRect; MainRect: TRect);\r\n public\r\n procedure MoveTo(var SrcRect, Rect: TRect);\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n published\r\n property Active: Boolean read FActive write FActive default False;\r\n property ScreenMagnet: Boolean read FScreenMagnet write FScreenMagnet default True;\r\n property Area: Cardinal read FArea write FArea default 15;\r\n property FormGlue: Boolean read FFormGlue write FFormGlue default True;\r\n property MainFormMagnet: Boolean read FMainFormMagnet write FMainFormMagnet default False;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvFormMagnet.pas $';\r\n Revision: '$Revision: 13104 $';\r\n Date: '$Date: 2011-09-07 08:50:43 +0200 (mer. 07 sept. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n JvWndProcHook;\r\n\r\nconstructor TJvFormMagnet.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FActive := False;\r\n FScreenMagnet := True;\r\n FArea := 15;\r\n FFormGlue := True;\r\n FMainFormMagnet := False;\r\n\r\n FLastRightDock := 0.0;\r\n FLastLeftDock := 0.0;\r\n FLastTopDock := 0.0;\r\n FLastBottomDock := 0.0;\r\n\r\n FForm := TForm(GetParentForm(TControl(AOwner)));\r\n if not (csDesigning in ComponentState) and (FForm <> nil) then\r\n RegisterWndProcHook(FForm, NewWndProc, hoBeforeMsg);\r\nend;\r\n\r\ndestructor TJvFormMagnet.Destroy;\r\nbegin\r\n if not (csDesigning in ComponentState) and (FForm <> nil) then\r\n UnregisterWndProcHook(FForm, NewWndProc, hoBeforeMsg);\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvFormMagnet.MagnetScreen(OldRect: TRect; var FormRect: TRect; ScreenRect: TRect);\r\nvar\r\n FormWidth, FormHeight: Integer;\r\n\r\n function MovingToLeft: Boolean;\r\n begin\r\n Result := OldRect.Left > FormRect.Left;\r\n end;\r\n\r\n function MovingToRight: Boolean;\r\n begin\r\n Result := OldRect.Left < FormRect.Left;\r\n end;\r\n\r\n function MovingToTop: Boolean;\r\n begin\r\n Result := OldRect.Top > FormRect.Top;\r\n end;\r\n\r\n function MovingToBottom: Boolean;\r\n begin\r\n Result := OldRect.Top < FormRect.Top;\r\n end;\r\n\r\n function OkayForAll(var Value: TDateTime): Boolean;\r\n begin\r\n Result := Abs(Value - Now) > EncodeTime(0, 0, 0, 250);\r\n end;\r\n\r\n function OkayForRight: Boolean;\r\n begin\r\n Result := OkayForAll(FLastRightDock);\r\n end;\r\n\r\n function OkayForLeft: Boolean;\r\n begin\r\n Result := OkayForAll(FLastLeftDock);\r\n end;\r\n\r\n function OkayForTop: Boolean;\r\n begin\r\n Result := OkayForAll(FLastTopDock);\r\n end;\r\n\r\n function OkayForBottom: Boolean;\r\n begin\r\n Result := OkayForAll(FLastBottomDock);\r\n end;\r\n\r\n procedure DockOnLeft;\r\n begin\r\n FormRect.Left := ScreenRect.Left;\r\n FormRect.Right := FormRect.Left + FormWidth;\r\n FLastLeftDock := Now;\r\n end;\r\n\r\n procedure UndockOnLeftOutside;\r\n begin\r\n FormRect.Left := ScreenRect.Left - Integer(FArea);\r\n FormRect.Right := FormRect.Left + FormWidth;\r\n FLastLeftDock := Now;\r\n end;\r\n\r\n procedure UndockOnLeftInside;\r\n begin\r\n FormRect.Left := ScreenRect.Left + Integer(FArea);\r\n FormRect.Right := FormRect.Left + FormWidth;\r\n FLastLeftDock := Now;\r\n end;\r\n\r\n procedure DockOnRight;\r\n begin\r\n FormRect.Left := ScreenRect.Right - FormWidth;\r\n FormRect.Right := ScreenRect.Right;\r\n FLastRightDock := Now;\r\n end;\r\n\r\n procedure UndockOnRightOutside;\r\n begin\r\n FormRect.Left := ScreenRect.Right - FormWidth + Integer(FArea);\r\n FormRect.Right := ScreenRect.Right + Integer(FArea);\r\n FLastRightDock := Now;\r\n end;\r\n\r\n procedure UndockOnRightInside;\r\n begin\r\n FormRect.Left := ScreenRect.Right - FormWidth - Integer(FArea);\r\n FormRect.Right := ScreenRect.Right - Integer(FArea);\r\n FLastRightDock := Now;\r\n end;\r\n\r\n procedure DockOnTop;\r\n begin\r\n FormRect.Top := ScreenRect.Top;\r\n FormRect.Bottom := FormRect.Top + FormHeight;\r\n FLastTopDock := Now;\r\n end;\r\n\r\n procedure UndockOnTopOutside;\r\n begin\r\n FormRect.Top := ScreenRect.Top - Integer(FArea);\r\n FormRect.Bottom := FormRect.Top + FormHeight;\r\n FLastTopDock := Now;\r\n end;\r\n\r\n procedure UndockOnTopInside;\r\n begin\r\n FormRect.Top := ScreenRect.Top + Integer(FArea);\r\n FormRect.Bottom := FormRect.Top + FormHeight;\r\n FLastTopDock := Now;\r\n end;\r\n\r\n procedure DockOnBottom;\r\n begin\r\n FormRect.Top := ScreenRect.Bottom - FormHeight;\r\n FormRect.Bottom := ScreenRect.Bottom;\r\n FLastBottomDock := Now;\r\n end;\r\n\r\n procedure UndockOnBottomInside;\r\n begin\r\n FormRect.Top := ScreenRect.Bottom - FormHeight - Integer(FArea);\r\n FormRect.Bottom := ScreenRect.Bottom - Integer(FArea);\r\n FLastBottomDock := Now;\r\n end;\r\n\r\n procedure UndockOnBottomOutside;\r\n begin\r\n FormRect.Top := ScreenRect.Bottom - FormHeight + Integer(FArea);\r\n FormRect.Bottom := ScreenRect.Bottom + Integer(FArea);\r\n FLastBottomDock := Now;\r\n end;\r\n\r\nbegin\r\n FormWidth := FormRect.Right - FormRect.Left;\r\n FormHeight := FormRect.Bottom - FormRect.Top;\r\n\r\n // Magnet/UnMagnet Left, Magnet/UnMagnet Right\r\n if MovingToLeft then\r\n if OkayForLeft then\r\n begin\r\n if ((FormRect.Left - ScreenRect.Left) in [2..FArea]) or\r\n (Abs(FormRect.Left - ScreenRect.Left) = 1) then\r\n DockOnLeft\r\n else\r\n if Abs(FormRect.Left - ScreenRect.Left) in [2..FArea] then\r\n UndockOnLeftOutside\r\n else\r\n if (ScreenRect.Right - FormRect.Right) in [2..FArea] then\r\n UndockOnRightInside\r\n else\r\n if Abs(ScreenRect.Right - FormRect.Right) in [1..FArea] then\r\n DockOnRight;\r\n end\r\n else\r\n if Abs(FormRect.Left - ScreenRect.Left) < Integer(FArea) then\r\n DockOnLeft\r\n else\r\n if Abs(ScreenRect.Right - FormRect.Right) < Integer(FArea) then\r\n DockOnRight;\r\n\r\n // Magnet/UnMagnet Left, Magnet/UnMagnet Right\r\n if MovingToRight then\r\n if OkayForRight then\r\n begin\r\n if ((ScreenRect.Right - FormRect.Right) in [2..FArea]) or\r\n (Abs(ScreenRect.Right - FormRect.Right) = 1) then\r\n DockOnRight\r\n else\r\n if Abs(ScreenRect.Right - FormRect.Right) in [2..FArea] then\r\n UndockOnRightOutside\r\n else\r\n if (ScreenRect.Left - FormRect.Left) in [2..FArea] then\r\n DockOnLeft\r\n else\r\n if Abs(ScreenRect.Left - FormRect.Left) in [1..FArea] then\r\n UndockOnLeftInside;\r\n end\r\n else\r\n if Abs(ScreenRect.Right - FormRect.Right) < Integer(FArea) then\r\n DockOnRight\r\n else\r\n if Abs(ScreenRect.Left - FormRect.Left) < Integer(FArea) then\r\n DockOnLeft;\r\n\r\n // Magnet/UnMagnet Bottom, Magnet/UnMagnet Top\r\n if MovingToTop then\r\n if OkayForTop then\r\n begin\r\n if ((FormRect.Top - ScreenRect.Top) in [2..FArea]) or\r\n (Abs(FormRect.Top - ScreenRect.Top) = 1) then\r\n DockOnTop\r\n else\r\n if Abs(FormRect.Top - ScreenRect.Top) in [2..FArea] then\r\n UndockOnTopOutside\r\n else\r\n if (ScreenRect.Bottom - FormRect.Bottom) in [2..FArea] then\r\n UndockOnBottomInside\r\n else\r\n if Abs(ScreenRect.Bottom - FormRect.Bottom) in [1..FArea] then\r\n DockOnBottom;\r\n end\r\n else\r\n if Abs(FormRect.Top - ScreenRect.Top) < Integer(FArea) then\r\n DockOnTop\r\n else\r\n if Abs(ScreenRect.Bottom - FormRect.Bottom) < Integer(FArea) then\r\n DockOnBottom;\r\n\r\n // Magnet/UnMagnet Bottom, Magnet/UnMagnet Top\r\n if MovingToBottom then\r\n if OkayForBottom then\r\n begin\r\n if (FormRect.Top - ScreenRect.Top) in [2..FArea] then\r\n UndockOnTopInside\r\n else\r\n if Abs(FormRect.Top - ScreenRect.Top) < Integer(FArea) then\r\n DockOnTop\r\n else\r\n if (ScreenRect.Bottom - FormRect.Bottom) in [2..FArea] then\r\n DockOnBottom\r\n else\r\n if Abs(ScreenRect.Bottom - FormRect.Bottom) in [1..FArea] then\r\n UndockOnBottomOutside;\r\n end\r\n else\r\n if Abs(FormRect.Top - ScreenRect.Top) < Integer(FArea) then\r\n DockOnTop\r\n else\r\n if Abs(ScreenRect.Bottom - FormRect.Bottom) < Integer(FArea) then\r\n UndockOnBottomOutside;\r\nend;\r\n\r\nprocedure TJvFormMagnet.GlueForms(var FormRect: TRect);\r\nvar\r\n I: Integer;\r\nbegin\r\n if Assigned(FForm) then\r\n begin\r\n for I := 0 to Application.ComponentCount - 1 do \r\n begin\r\n if Application.Components[I] is TForm then \r\n begin\r\n with Application.Components[I] as TForm do \r\n begin\r\n if (Left = FForm.Left + FForm.Width) then \r\n begin\r\n // <--main--><--form-->\r\n\r\n if ((FForm.Top >= Top) and (FForm.Top <= (Top + Height))) or\r\n ((Top >= FForm.Top) and (Top <= (FForm.Top + FForm.Height))) then \r\n begin\r\n Left := Left + (FormRect.Left - FForm.Left);\r\n Top := Top + (FormRect.Top - FForm.Top);\r\n end;\r\n end\r\n else \r\n begin\r\n if (Left + Width = FForm.Left) then \r\n begin\r\n // <--form--><--main-->\r\n if ((FForm.Top >= Top) and (FForm.Top <= (Top + Height))) or\r\n ((Top >= FForm.Top) and (Top <= (FForm.Top + FForm.Height))) then \r\n begin\r\n Left := Left + (FormRect.Left - FForm.Left);\r\n Top := Top + (FormRect.Top - FForm.Top);\r\n end;\r\n end\r\n else \r\n begin\r\n if (Top = FForm.Top + FForm.Height) then \r\n begin\r\n // <--main-->\r\n // <--form-->\r\n\r\n if ((Left >= FForm.Left) and (Left <= (FForm.Left + FForm.Width))) or\r\n ((FForm.Left >= Left) and (FForm.Left <= (Left + Width))) then \r\n begin\r\n Left := Left + (FormRect.Left - FForm.Left);\r\n Top := Top + (FormRect.Top - FForm.Top);\r\n end;\r\n end\r\n else begin\r\n if (Top + Height = FForm.Top) then \r\n begin\r\n // <--form-->\r\n // <--main-->\r\n if ((Left >= FForm.Left) and (Left <= (FForm.Left + FForm.Width))) or\r\n ((FForm.Left >= Left) and (FForm.Left <= (Left + Width))) then \r\n begin\r\n Left := Left + (FormRect.Left - FForm.Left);\r\n Top := Top + (FormRect.Top - FForm.Top);\r\n end;\r\n end;\r\n end;\r\n end;\r\n end;\r\n end;\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvFormMagnet.MagnetToMain(OldRect: TRect; var FormRect: TRect; MainRect: TRect);\r\nvar\r\n FormWidth, FormHeight: Integer;\r\n\r\n function OkayForAll(var Value: TDateTime): Boolean;\r\n begin\r\n Result := Abs(Value - Now) > EncodeTime(0, 0, 0, 250);\r\n end;\r\n\r\n function OkayForRight: Boolean;\r\n begin\r\n Result := OkayForAll(FLastRightDock);\r\n end;\r\n\r\n function OkayForTop: Boolean;\r\n begin\r\n Result := OkayForAll(FLastTopDock);\r\n end;\r\n\r\n function MovingToLeft: Boolean;\r\n begin\r\n Result := OldRect.Left > FormRect.Left;\r\n end;\r\n\r\n function MovingToRight: Boolean;\r\n begin\r\n Result := OldRect.Left < FormRect.Left;\r\n end;\r\n\r\n function MovingToTop: Boolean;\r\n begin\r\n Result := OldRect.Top > FormRect.Top;\r\n end;\r\n\r\n function MovingToBottom: Boolean;\r\n begin\r\n Result := OldRect.Top < FormRect.Top;\r\n end;\r\n\r\n function InWidth: Boolean;\r\n begin\r\n Result := ((FormRect.Left > MainRect.Left) and (FormRect.Left < MainRect.Right)) or\r\n ((FormRect.Left < MainRect.Left) and (FormRect.Right > MainRect.Left));\r\n end;\r\n\r\n function InHeight: Boolean;\r\n begin\r\n Result := ((FormRect.Top > MainRect.Top) and (FormRect.Top < MainRect.Bottom)) or\r\n ((FormRect.Top < MainRect.Top) and (FormRect.Bottom > MainRect.Top));\r\n end;\r\n\r\n procedure DockOnBottom;\r\n begin\r\n FormRect.Top := MainRect.Bottom;\r\n FormRect.Bottom := FormRect.Top + FormHeight;\r\n FLastTopDock := Now;\r\n end;\r\n\r\n procedure UndockOnBottomInside;\r\n begin\r\n FormRect.Top := MainRect.Bottom - Integer(FArea);\r\n FormRect.Bottom := FormRect.Top + FormHeight;\r\n FLastTopDock := Now;\r\n end;\r\n\r\n procedure UndockOnBottomOutside;\r\n begin\r\n FormRect.Top := MainRect.Bottom + Integer(FArea);\r\n FormRect.Bottom := FormRect.Top + FormHeight;\r\n FLastTopDock := Now;\r\n end;\r\n\r\n procedure DockOnTop;\r\n begin\r\n FormRect.Top := MainRect.Top - FormHeight;\r\n FormRect.Bottom := MainRect.Top;\r\n FLastTopDock := Now;\r\n end;\r\n\r\n procedure UndockOnTopOutside;\r\n begin\r\n FormRect.Top := MainRect.Top - FormHeight - Integer(FArea);\r\n FormRect.Bottom := MainRect.Top - Integer(FArea);\r\n FLastTopDock := Now;\r\n end;\r\n\r\n procedure UndockOnTopInside;\r\n begin\r\n FormRect.Top := MainRect.Top - FormHeight + Integer(FArea);\r\n FormRect.Bottom := MainRect.Top + Integer(FArea);\r\n FLastTopDock := Now;\r\n end;\r\n\r\n procedure DockOnRight;\r\n begin\r\n FormRect.Left := MainRect.Right;\r\n FormRect.Right := FormRect.Left + FormWidth;\r\n FLastRightDock := Now;\r\n end;\r\n\r\n procedure UndockOnRightInside;\r\n begin\r\n FormRect.Left := MainRect.Right - Integer(FArea);\r\n FormRect.Right := FormRect.Left + FormWidth;\r\n FLastRightDock := Now;\r\n end;\r\n\r\n procedure UndockOnRightOutside;\r\n begin\r\n FormRect.Left := MainRect.Right + Integer(FArea);\r\n FormRect.Right := FormRect.Left + FormWidth;\r\n FLastRightDock := Now;\r\n end;\r\n\r\n procedure DockOnLeft;\r\n begin\r\n FormRect.Left := MainRect.Left - FormWidth;\r\n FormRect.Right := MainRect.Left;\r\n FLastRightDock := Now;\r\n end;\r\n\r\n procedure UndockOnLeftInside;\r\n begin\r\n FormRect.Left := MainRect.Left - FormWidth + Integer(FArea);\r\n FormRect.Right := MainRect.Left + Integer(FArea);\r\n FLastRightDock := Now;\r\n end;\r\n\r\n procedure UndockOnLeftOutside;\r\n begin\r\n FormRect.Left := MainRect.Left - FormWidth - Integer(FArea);\r\n FormRect.Right := MainRect.Left - Integer(FArea);\r\n FLastRightDock := Now;\r\n end;\r\n\r\nbegin\r\n FormWidth := FormRect.Right - FormRect.Left;\r\n FormHeight := FormRect.Bottom - FormRect.Top;\r\n\r\n // Magnet/UnMagnet Bottom, Magnet/UnMagnet Top\r\n if MovingToTop and InWidth then\r\n if OkayForTop then\r\n begin\r\n if (FormRect.Top - MainRect.Bottom) in [2..FArea] then\r\n DockOnBottom\r\n else\r\n if -(FormRect.Top - MainRect.Bottom) in [2..FArea] then\r\n UndockOnBottomInside\r\n else\r\n if (FormRect.Bottom - MainRect.Top) in [2..FArea] then\r\n DockOnTop\r\n else\r\n if -(FormRect.Bottom - MainRect.Top) in [2..FArea] then\r\n UndockOnTopOutside;\r\n end\r\n else\r\n if Abs(FormRect.Top - MainRect.Bottom) < Integer(FArea) then\r\n DockOnBottom\r\n else\r\n if Abs(FormRect.Bottom - MainRect.Top) < Integer(FArea) then\r\n DockOnTop;\r\n\r\n if MovingToBottom and InWidth then\r\n if OkayForTop then\r\n begin\r\n if (FormRect.Top - MainRect.Bottom) in [2..FArea] then\r\n UndockOnBottomOutside\r\n else\r\n if -(FormRect.Top - MainRect.Bottom) in [2..FArea] then\r\n DockOnBottom\r\n else\r\n if (FormRect.Bottom - MainRect.Top) in [1..FArea] then\r\n DockOnTop\r\n else\r\n if Abs(FormRect.Bottom - MainRect.Top) in [2..FArea] then\r\n UndockOnTopInside;\r\n end\r\n else\r\n if Abs(FormRect.Top - MainRect.Bottom) < Integer(FArea) then\r\n DockOnBottom\r\n else\r\n if (FormRect.Bottom - MainRect.Top) < Integer(FArea) then\r\n DockOnTop;\r\n\r\n if MovingToLeft and InHeight then\r\n if OkayForRight then\r\n begin\r\n if (FormRect.Left - MainRect.Right) in [2..FArea] then\r\n DockOnRight\r\n else\r\n if Abs(FormRect.Left - MainRect.Right) in [2..FArea] then\r\n UndockOnRightInside\r\n else\r\n if (FormRect.Right - MainRect.Left) in [2..FArea] then\r\n DockOnLeft\r\n else\r\n if Abs(FormRect.Right - MainRect.Left) in [2..FArea] then\r\n UndockOnLeftOutside;\r\n end\r\n else\r\n if Abs(FormRect.Left - MainRect.Right) < Integer(FArea) then\r\n DockOnRight\r\n else\r\n if Abs(FormRect.Right - MainRect.Left) < Integer(FArea) then\r\n DockOnLeft;\r\n\r\n if MovingToRight and InHeight then\r\n if OkayForRight then\r\n begin\r\n if (MainRect.Left - FormRect.Right) in [2..FArea] then\r\n DockOnLeft\r\n else\r\n if Abs(MainRect.Left - FormRect.Right) in [2..FArea] then\r\n UndockOnLeftInside\r\n else\r\n if (MainRect.Right - FormRect.Left) in [2..FArea] then\r\n DockOnRight\r\n else\r\n if Abs(MainRect.Right - FormRect.Left) in [2..FArea] then\r\n UndockOnRightOutside;\r\n end\r\n else\r\n if Abs(MainRect.Left - FormRect.Right) < Integer(FArea) then\r\n DockOnLeft\r\n else\r\n if Abs(MainRect.Right - FormRect.Left) < Integer(FArea) then\r\n DockOnRight\r\nend;\r\n\r\nfunction TJvFormMagnet.NewWndProc(var Msg: TMessage): Boolean;\r\nvar\r\n R, R3: TRect;\r\nbegin\r\n Result := False;\r\n with Msg do\r\n if FActive then\r\n case Msg of\r\n WM_MOVING:\r\n begin\r\n R := PRect(LParam)^;\r\n R3.Left := FForm.Left;\r\n R3.Top := FForm.Top;\r\n R3.Right := R3.Left + FForm.Width;\r\n R3.Bottom := R3.Top + FForm.Height;\r\n MoveTo(R3, R);\r\n PRect(LParam)^ := R;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvFormMagnet.MoveTo(var SrcRect, Rect: TRect);\r\nvar\r\n DesktopWorkRect, PreviousRect: TRect;\r\n Monitor: HMONITOR;\r\n MonInfo: TMonitorInfo;\r\nbegin\r\n PreviousRect := SrcRect;\r\n\r\n // Move to a side of the desktop?\r\n if FScreenMagnet then\r\n begin\r\n Monitor := MultiMon.MonitorFromRect(@PreviousRect, MONITOR_DEFAULTTONEAREST);\r\n if Monitor <> 0 then\r\n begin\r\n MonInfo.cbSize := SizeOf(MonInfo);\r\n GetMonitorInfo(Monitor, @MonInfo);\r\n DesktopWorkRect := MonInfo.rcWork;\r\n end\r\n else\r\n SystemParametersInfo(SPI_GETWORKAREA, 0, @DesktopWorkRect, 0);\r\n MagnetScreen(PreviousRect, Rect, DesktopWorkRect);\r\n end;\r\n\r\n // Move another form too?\r\n if FFormGlue then\r\n GlueForms(Rect);\r\n\r\n // Magnet to main form?\r\n if FMainFormMagnet and (Application.MainForm <> nil) then\r\n begin\r\n DesktopWorkRect.Left := Application.MainForm.Left;\r\n DesktopWorkRect.Top := Application.MainForm.Top;\r\n DesktopWorkRect.Right := Application.MainForm.Left + Application.MainForm.Width;\r\n DesktopWorkRect.Bottom := Application.MainForm.Top + Application.MainForm.Height;\r\n MagnetToMain(PreviousRect, Rect, DesktopWorkRect);\r\n end;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvFormPlacement.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvPlacemnt.PAS, released on 2002-07-04.\r\n\r\nThe Initial Developers of the Original Code are: Fedor Koshevnikov, Igor Pavluk and Serge Korolev\r\nCopyright (c) 1997, 1998 Fedor Koshevnikov, Igor Pavluk and Serge Korolev\r\nCopyright (c) 2001,2002 SGB Software\r\nAll Rights Reserved.\r\n\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvFormPlacement.pas 13404 2012-08-19 17:58:12Z ahuser $\r\n\r\nunit JvFormPlacement;\r\n \r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Variants, Types, RTLConsts,\r\n SysUtils, Classes, Windows, Messages, Controls, Forms,\r\n JvWndProcHook,\r\n JvAppStorage, JvComponentBase, JvJVCLUtils, JvTypes;\r\n\r\ntype\r\n TJvIniLink = class;\r\n\r\n TJvFormPlacement = class;\r\n\r\n TJvWinMinMaxInfo = class(TPersistent)\r\n private\r\n FOwner: TJvFormPlacement;\r\n FMinMaxInfo: TMinMaxInfo;\r\n function GetMinMaxInfo(Index: Integer): Integer;\r\n procedure SetMinMaxInfo(Index: Integer; AValue: Integer);\r\n public\r\n function DefaultMinMaxInfo: Boolean;\r\n procedure Assign(Source: TPersistent); override;\r\n published\r\n property MaxPosLeft: Integer index 0 read GetMinMaxInfo write SetMinMaxInfo default 0;\r\n property MaxPosTop: Integer index 1 read GetMinMaxInfo write SetMinMaxInfo default 0;\r\n property MaxSizeHeight: Integer index 2 read GetMinMaxInfo write SetMinMaxInfo default 0;\r\n property MaxSizeWidth: Integer index 3 read GetMinMaxInfo write SetMinMaxInfo default 0;\r\n property MaxTrackHeight: Integer index 4 read GetMinMaxInfo write SetMinMaxInfo default 0;\r\n property MaxTrackWidth: Integer index 5 read GetMinMaxInfo write SetMinMaxInfo default 0;\r\n property MinTrackHeight: Integer index 6 read GetMinMaxInfo write SetMinMaxInfo default 0;\r\n property MinTrackWidth: Integer index 7 read GetMinMaxInfo write SetMinMaxInfo default 0;\r\n end;\r\n\r\n TJvFormPlacementVersionCheck = (fpvcNocheck, fpvcCheckGreaterEqual, fpvcCheckEqual);\r\n\r\n TJvFormPlacement = class(TJvComponent)\r\n private\r\n FActive: Boolean;\r\n FAppStorage: TJvCustomAppStorage;\r\n FAppStoragePath: string;\r\n FLinks: TList;\r\n FOptions: TPlacementOptions;\r\n FVersion: Integer;\r\n FVersionCheck: TJvFormPlacementVersionCheck;\r\n FSaved: Boolean;\r\n FRestored: Boolean;\r\n FDestroying: Boolean;\r\n FPreventResize: Boolean;\r\n FWinMinMaxInfo: TJvWinMinMaxInfo;\r\n FDefMaximize: Boolean;\r\n FWinHook: TJvWindowHook;\r\n FSaveFormShow: TNotifyEvent;\r\n FSaveFormDestroy: TNotifyEvent;\r\n FSaveFormCloseQuery: TCloseQueryEvent;\r\n FOnSavePlacement: TNotifyEvent;\r\n FOnRestorePlacement: TNotifyEvent;\r\n FBeforeSavePlacement: TNotifyEvent;\r\n FAfterSavePlacement: TNotifyEvent;\r\n FBeforeRestorePlacement: TNotifyEvent;\r\n FAfterRestorePlacement: TNotifyEvent;\r\n procedure SetAppStoragePath(const AValue: string);\r\n procedure SetEvents;\r\n procedure RestoreEvents;\r\n procedure SetHook;\r\n procedure ReleaseHook;\r\n procedure CheckToggleHook;\r\n procedure WndMessage(Sender: TObject; var Msg: TMessage; var Handled: Boolean);\r\n function CheckMinMaxInfo: Boolean;\r\n procedure MinMaxInfoModified;\r\n procedure SetWinMinMaxInfo(AValue: TJvWinMinMaxInfo);\r\n procedure SetPreventResize(AValue: Boolean);\r\n procedure UpdatePreventResize;\r\n procedure UpdatePlacement;\r\n procedure AddLink(ALink: TJvIniLink);\r\n procedure NotifyLinks(Operation: TPlacementOperation);\r\n procedure RemoveLink(ALink: TJvIniLink);\r\n procedure FormShow(Sender: TObject);\r\n procedure FormCloseQuery(Sender: TObject; var CanClose: Boolean);\r\n procedure FormDestroy(Sender: TObject);\r\n function GetForm: TForm;\r\n procedure SetAppStorage(const Value: TJvCustomAppStorage);\r\n protected\r\n procedure ResolveAppStoragePath;\r\n procedure Loaded; override;\r\n procedure Save; dynamic;\r\n procedure Restore; dynamic;\r\n procedure SavePlacement; virtual;\r\n procedure RestorePlacement; virtual;\r\n property Form: TForm read GetForm;\r\n procedure Notification(AComponent: TComponent; Operation: TOperation); override;\r\n function ConcatPaths(const Paths: array of string): string;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n function IsActive: Boolean;\r\n procedure SaveFormPlacement;\r\n procedure RestoreFormPlacement;\r\n function ReadString(const Ident: string; const Default: string = ''): string;\r\n procedure WriteString(const Ident: string; const AValue: string);\r\n function ReadBoolean(const Ident: string; Default: Boolean): Boolean;\r\n procedure WriteBoolean(const Ident: string; AValue: Boolean);\r\n function ReadFloat(const Ident: string; Default: Double = 0): Double;\r\n procedure WriteFloat(const Ident: string; AValue: Double);\r\n function ReadInteger(const Ident: string; Default: Longint = 0): Longint;\r\n procedure WriteInteger(const Ident: string; AValue: Longint);\r\n function ReadDateTime(const Ident: string; Default: TDateTime = 0): TDateTime;\r\n procedure WriteDateTime(const Ident: string; AValue: TDateTime);\r\n procedure DeleteValue(const Ident: string);\r\n procedure EraseSections;\r\n published\r\n property Active: Boolean read FActive write FActive default True;\r\n property AppStorage: TJvCustomAppStorage read FAppStorage write SetAppStorage;\r\n property AppStoragePath: string read FAppStoragePath write SetAppStoragePath;\r\n property MinMaxInfo: TJvWinMinMaxInfo read FWinMinMaxInfo write SetWinMinMaxInfo;\r\n property Options: TPlacementOptions read FOptions write FOptions default [fpState, fpSize, fpLocation];\r\n property PreventResize: Boolean read FPreventResize write SetPreventResize default False;\r\n property Version: Integer read FVersion write FVersion default 0;\r\n property VersionCheck: TJvFormPlacementVersionCheck read FVersionCheck write FVersionCheck default fpvcCheckGreaterEqual;\r\n property BeforeSavePlacement: TNotifyEvent read FBeforeSavePlacement write FBeforeSavePlacement;\r\n property OnSavePlacement: TNotifyEvent read FOnSavePlacement write FOnSavePlacement;\r\n property AfterSavePlacement: TNotifyEvent read FAfterSavePlacement write FAfterSavePlacement;\r\n property BeforeRestorePlacement: TNotifyEvent read FBeforeRestorePlacement write FBeforeRestorePlacement;\r\n property OnRestorePlacement: TNotifyEvent read FOnRestorePlacement write FOnRestorePlacement;\r\n property AfterRestorePlacement: TNotifyEvent read FAfterRestorePlacement write FAfterRestorePlacement;\r\n end;\r\n\r\n TJvStoredValues = class;\r\n TJvStoredValue = class;\r\n TJvFormStorageStringList = class;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64 or pidOSX32)]\r\n {$ENDIF RTL230_UP}\r\n TJvFormStorage = class(TJvFormPlacement)\r\n private\r\n FStoredProps: TJvFormStorageStringList;\r\n FStoredValues: TJvStoredValues;\r\n FStoredPropsPath: string;\r\n function GetStoredProps: TStrings;\r\n procedure SetStoredProps(AValue: TStrings);\r\n procedure SetStoredValues(AValue: TJvStoredValues);\r\n function GetStoredValue(const Name: string): Variant;\r\n procedure SetStoredValue(const Name: string; AValue: Variant);\r\n function GetDefaultStoredValue(const Name: string; DefValue: Variant): Variant;\r\n procedure SetDefaultStoredValue(const Name: string; DefValue: Variant; const AValue: Variant);\r\n function GetStoredValuesPath: string;\r\n procedure SetStoredValuesPath(const AValue: string);\r\n protected\r\n procedure Loaded; override;\r\n procedure Notification(AComponent: TComponent; Operation: TOperation); override;\r\n procedure SavePlacement; override;\r\n procedure RestorePlacement; override;\r\n procedure SaveProperties; virtual;\r\n procedure RestoreProperties; virtual;\r\n procedure WriteState(Writer: TWriter); override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n procedure SetNotification;\r\n property StoredValue[const Name: string]: Variant read GetStoredValue write SetStoredValue;\r\n property DefaultValue[const Name: string; DefValue: Variant]: Variant\r\n read GetDefaultStoredValue write SetDefaultStoredValue;\r\n published\r\n property StoredProps: TStrings read GetStoredProps write SetStoredProps;\r\n property StoredValues: TJvStoredValues read FStoredValues write SetStoredValues;\r\n property StoredPropsPath: string read FStoredPropsPath write FStoredPropsPath;\r\n property StoredValuesPath: string read GetStoredValuesPath write SetStoredValuesPath;\r\n end;\r\n\r\n TJvFormStorageStringList = class(TStringList)\r\n private\r\n FFormStorage: TJvFormStorage;\r\n public\r\n constructor Create(AFormStorage: TJvFormStorage);\r\n procedure Assign(Source: TPersistent); override;\r\n procedure LoadFromStream(Stream: TStream); override;\r\n end;\r\n\r\n TJvIniLink = class(TPersistent)\r\n private\r\n FStorage: TJvFormPlacement;\r\n FOnSave: TNotifyEvent;\r\n FOnLoad: TNotifyEvent;\r\n procedure SetStorage(AValue: TJvFormPlacement);\r\n protected\r\n procedure SaveToIni; virtual;\r\n procedure LoadFromIni; virtual;\r\n public\r\n destructor Destroy; override;\r\n property Storage: TJvFormPlacement read FStorage write SetStorage;\r\n property OnSave: TNotifyEvent read FOnSave write FOnSave;\r\n property OnLoad: TNotifyEvent read FOnLoad write FOnLoad;\r\n end;\r\n\r\n TJvStoredValueEvent = procedure(Sender: TJvStoredValue; var AValue: Variant) of object;\r\n\r\n TJvStoredValue = class(TCollectionItem)\r\n private\r\n FName: string;\r\n FValue: Variant;\r\n FKeyString: string;\r\n FOnSave: TJvStoredValueEvent;\r\n FOnRestore: TJvStoredValueEvent;\r\n function IsValueStored: Boolean;\r\n function GetStoredValues: TJvStoredValues;\r\n protected\r\n function GetDisplayName: string; override;\r\n procedure SetDisplayName(const AValue: string); override;\r\n public\r\n constructor Create(Collection: TCollection); override;\r\n procedure Assign(Source: TPersistent); override;\r\n procedure Clear;\r\n procedure Save; virtual;\r\n procedure Restore; virtual;\r\n property StoredValues: TJvStoredValues read GetStoredValues;\r\n published\r\n property Name: string read FName write SetDisplayName;\r\n property Value: Variant read FValue write FValue stored IsValueStored;\r\n property KeyString: string read FKeyString write FKeyString;\r\n property OnSave: TJvStoredValueEvent read FOnSave write FOnSave;\r\n property OnRestore: TJvStoredValueEvent read FOnRestore write FOnRestore;\r\n end;\r\n\r\n TJvStoredValues = class(TOwnedCollection)\r\n private\r\n FStorage: TJvFormPlacement;\r\n FPath: string;\r\n function GetValue(const Name: string): TJvStoredValue;\r\n procedure SetValue(const Name: string; StoredValue: TJvStoredValue);\r\n function GetStoredValue(const Name: string): Variant;\r\n procedure SetStoredValue(const Name: string; AValue: Variant);\r\n function GetItem(Index: Integer): TJvStoredValue;\r\n procedure SetItem(Index: Integer; StoredValue: TJvStoredValue);\r\n public\r\n constructor Create(AOwner: TPersistent);\r\n function IndexOf(const Name: string): Integer;\r\n procedure SaveValues; virtual;\r\n procedure RestoreValues; virtual;\r\n\r\n property Path: string read FPath write FPath;\r\n property Storage: TJvFormPlacement read FStorage write FStorage;\r\n property Items[Index: Integer]: TJvStoredValue read GetItem write SetItem; default;\r\n property Values[const Name: string]: TJvStoredValue read GetValue write SetValue;\r\n property StoredValue[const Name: string]: Variant read GetStoredValue write SetStoredValue;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvFormPlacement.pas $';\r\n Revision: '$Revision: 13404 $';\r\n Date: '$Date: 2012-08-19 19:58:12 +0200 (dim. 19 août 2012) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n JclStrings,\r\n JvJCLUtils, JvPropertyStorage;\r\n\r\nconst\r\n siActiveCtrl = 'ActiveControl'; // do not localize\r\n siVersion = 'FormVersion'; // do not localize\r\n cFormNameMask = '%FORM_NAME%'; // do not localize\r\n\r\n//=== { TJvFormPlacement } ===================================================\r\n\r\nconstructor TJvFormPlacement.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FActive := True;\r\n if AOwner is TForm then\r\n FOptions := [fpState, fpSize, fpLocation]\r\n else\r\n FOptions := [];\r\n FWinHook := TJvWindowHook.Create(Self);\r\n FWinHook.AfterMessage := WndMessage;\r\n FWinMinMaxInfo := TJvWinMinMaxInfo.Create;\r\n FWinMinMaxInfo.FOwner := Self;\r\n FLinks := TList.Create;\r\n FVersion := 0;\r\n FVersionCheck := fpvcCheckGreaterEqual;\r\n FAppStoragePath := cFormNameMask;\r\n FSaved := False;\r\n FRestored := False;\r\n FDestroying := False;\r\nend;\r\n\r\ndestructor TJvFormPlacement.Destroy;\r\nbegin\r\n while FLinks.Count > 0 do\r\n RemoveLink(TJvIniLink(FLinks.Last));\r\n FLinks.Free;\r\n if not (csDesigning in ComponentState) then\r\n begin\r\n ReleaseHook;\r\n RestoreEvents;\r\n end;\r\n FWinMinMaxInfo.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvFormPlacement.Loaded;\r\nvar\r\n Loading: Boolean;\r\nbegin\r\n // Mantis 3190: Only resolve when we are loaded so that we get the correct\r\n // form name if it's a form inheriting from another one.\r\n Loading := csLoading in ComponentState;\r\n inherited Loaded;\r\n if not (csDesigning in ComponentState) then\r\n begin\r\n ResolveAppStoragePath;\r\n if Loading then\r\n SetEvents;\r\n CheckToggleHook;\r\n end;\r\nend;\r\n\r\nprocedure TJvFormPlacement.AddLink(ALink: TJvIniLink);\r\nbegin\r\n FLinks.Add(ALink);\r\n ALink.FStorage := Self;\r\nend;\r\n\r\nprocedure TJvFormPlacement.NotifyLinks(Operation: TPlacementOperation);\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := 0 to FLinks.Count - 1 do\r\n case Operation of\r\n poSave:\r\n TJvIniLink(FLinks[I]).SaveToIni;\r\n poRestore:\r\n TJvIniLink(FLinks[I]).LoadFromIni;\r\n end;\r\nend;\r\n\r\nprocedure TJvFormPlacement.RemoveLink(ALink: TJvIniLink);\r\nbegin\r\n ALink.FStorage := nil;\r\n FLinks.Remove(ALink);\r\nend;\r\n\r\nfunction TJvFormPlacement.GetForm: TForm;\r\nbegin\r\n if Owner is TCustomForm then\r\n Result := TForm(Owner as TCustomForm)\r\n else\r\n Result := nil;\r\nend;\r\n\r\nprocedure TJvFormPlacement.SetAppStoragePath(const AValue: string);\r\nbegin\r\n if (AValue <> '') and ({$IFDEF COMPILER12_UP}AValue[Length(AValue)]{$ELSE}AnsiLastChar(AValue){$ENDIF COMPILER12_UP} <> '\\') then\r\n FAppStoragePath := AValue + '\\'\r\n else\r\n FAppStoragePath := AValue;\r\n\r\n // Mantis 3190: Do not resolve if we are loding, this is way too early to\r\n // get a valid form name if this form is inheriting from another one.\r\n if not (csDesigning in ComponentState) and not (csLoading in ComponentState) then\r\n begin\r\n ResolveAppStoragePath;\r\n end;\r\nend;\r\n\r\nprocedure TJvFormPlacement.SetEvents;\r\nbegin\r\n if Owner is TCustomForm then\r\n begin\r\n FSaveFormShow := TForm(Form).OnShow;\r\n TForm(Form).OnShow := FormShow;\r\n FSaveFormCloseQuery := TForm(Form).OnCloseQuery;\r\n TForm(Form).OnCloseQuery := FormCloseQuery;\r\n FSaveFormDestroy := TForm(Form).OnDestroy;\r\n TForm(Form).OnDestroy := FormDestroy;\r\n FDefMaximize := (biMaximize in TForm(Form).BorderIcons);\r\n if FPreventResize then\r\n UpdatePreventResize;\r\n end;\r\nend;\r\n\r\nprocedure TJvFormPlacement.RestoreEvents;\r\nbegin\r\n if (Owner <> nil) and (Owner is TCustomForm) then\r\n begin\r\n TForm(Form).OnShow := FSaveFormShow;\r\n TForm(Form).OnCloseQuery := FSaveFormCloseQuery;\r\n TForm(Form).OnDestroy := FSaveFormDestroy;\r\n end;\r\nend;\r\n\r\n\r\n\r\nprocedure TJvFormPlacement.SetHook;\r\nbegin\r\n if not (csDesigning in ComponentState) and (Owner <> nil) and\r\n (Owner is TCustomForm) then\r\n FWinHook.Control := Form;\r\nend;\r\n\r\nprocedure TJvFormPlacement.ReleaseHook;\r\nbegin\r\n FWinHook.Control := nil;\r\nend;\r\n\r\nprocedure TJvFormPlacement.CheckToggleHook;\r\nbegin\r\n if CheckMinMaxInfo or PreventResize then\r\n SetHook\r\n else\r\n ReleaseHook;\r\nend;\r\n\r\n\r\n\r\nfunction TJvFormPlacement.CheckMinMaxInfo: Boolean;\r\nbegin\r\n Result := not FWinMinMaxInfo.DefaultMinMaxInfo;\r\nend;\r\n\r\nprocedure TJvFormPlacement.MinMaxInfoModified;\r\nbegin\r\n UpdatePlacement;\r\n if not (csLoading in ComponentState) then\r\n CheckToggleHook;\r\nend;\r\n\r\nprocedure TJvFormPlacement.SetWinMinMaxInfo(AValue: TJvWinMinMaxInfo);\r\nbegin\r\n FWinMinMaxInfo.Assign(AValue);\r\nend;\r\n\r\n\r\nprocedure TJvFormPlacement.WndMessage(Sender: TObject; var Msg: TMessage;\r\n var Handled: Boolean);\r\ntype\r\n PWMInitMenuPopup = ^TWMInitMenuPopup;\r\nvar\r\n MinMax: PMinMaxInfo;\r\n InitMenuPopup: PWMInitMenuPopup;\r\nbegin\r\n if FPreventResize and (Owner is TCustomForm) then\r\n begin\r\n case Msg.Msg of\r\n WM_GETMINMAXINFO:\r\n if Form.HandleAllocated and IsWindowVisible(Form.Handle) then\r\n begin\r\n MinMax := TWMGetMinMaxInfo(Msg).MinMaxInfo;\r\n MinMax.ptMinTrackSize := Point(Form.Width, Form.Height);\r\n MinMax.ptMaxTrackSize := Point(Form.Width, Form.Height);\r\n Msg.Result := 1;\r\n end;\r\n WM_INITMENUPOPUP:\r\n begin\r\n InitMenuPopup := PWMInitMenuPopup(@Msg);\r\n if InitMenuPopup.SystemMenu then\r\n begin\r\n if Form.Menu <> nil then\r\n Form.Menu.DispatchPopup(InitMenuPopup.MenuPopup);\r\n EnableMenuItem(InitMenuPopup.MenuPopup, SC_SIZE, MF_BYCOMMAND or MF_GRAYED);\r\n EnableMenuItem(InitMenuPopup.MenuPopup, SC_MAXIMIZE, MF_BYCOMMAND or MF_GRAYED);\r\n Msg.Result := 1;\r\n end;\r\n end;\r\n WM_NCHITTEST:\r\n begin\r\n if Integer(Msg.Result) in [HTLEFT, HTRIGHT, HTBOTTOM, HTBOTTOMRIGHT,\r\n HTBOTTOMLEFT, HTTOP, HTTOPRIGHT, HTTOPLEFT] then\r\n Msg.Result := HTNOWHERE;\r\n end;\r\n end;\r\n end\r\n else\r\n if Msg.Msg = WM_GETMINMAXINFO then\r\n begin\r\n MinMax := TWMGetMinMaxInfo(Msg).MinMaxInfo;\r\n if CheckMinMaxInfo then\r\n begin\r\n if FWinMinMaxInfo.MinTrackWidth <> 0 then\r\n MinMax^.ptMinTrackSize.X := FWinMinMaxInfo.MinTrackWidth;\r\n if FWinMinMaxInfo.MinTrackHeight <> 0 then\r\n MinMax^.ptMinTrackSize.Y := FWinMinMaxInfo.MinTrackHeight;\r\n if FWinMinMaxInfo.MaxTrackWidth <> 0 then\r\n MinMax^.ptMaxTrackSize.X := FWinMinMaxInfo.MaxTrackWidth;\r\n if FWinMinMaxInfo.MaxTrackHeight <> 0 then\r\n MinMax^.ptMaxTrackSize.Y := FWinMinMaxInfo.MaxTrackHeight;\r\n if FWinMinMaxInfo.MaxSizeWidth <> 0 then\r\n MinMax^.ptMaxSize.X := FWinMinMaxInfo.MaxSizeWidth;\r\n if FWinMinMaxInfo.MaxSizeHeight <> 0 then\r\n MinMax^.ptMaxSize.Y := FWinMinMaxInfo.MaxSizeHeight;\r\n if FWinMinMaxInfo.MaxPosLeft <> 0 then\r\n MinMax^.ptMaxPosition.X := FWinMinMaxInfo.MaxPosLeft;\r\n if FWinMinMaxInfo.MaxPosTop <> 0 then\r\n MinMax^.ptMaxPosition.Y := FWinMinMaxInfo.MaxPosTop;\r\n end\r\n else\r\n begin\r\n MinMax.ptMaxPosition.X := 0;\r\n MinMax.ptMaxPosition.Y := 0;\r\n end;\r\n Msg.Result := 1;\r\n end;\r\nend;\r\n\r\n\r\nprocedure TJvFormPlacement.FormShow(Sender: TObject);\r\nbegin\r\n if IsActive and not FRestored then\r\n try\r\n RestoreFormPlacement;\r\n except\r\n Application.HandleException(Self);\r\n end;\r\n if Assigned(FSaveFormShow) then\r\n FSaveFormShow(Sender);\r\nend;\r\n\r\nprocedure TJvFormPlacement.FormCloseQuery(Sender: TObject; var CanClose: Boolean);\r\nbegin\r\n if Assigned(FSaveFormCloseQuery) then\r\n FSaveFormCloseQuery(Sender, CanClose);\r\n if CanClose and IsActive and (Owner is TCustomForm) and (Form.Handle <> NullHandle) then\r\n try\r\n SaveFormPlacement;\r\n except\r\n Application.HandleException(Self);\r\n end;\r\nend;\r\n\r\nprocedure TJvFormPlacement.FormDestroy(Sender: TObject);\r\nbegin\r\n if IsActive and not FSaved then\r\n begin\r\n FDestroying := True;\r\n try\r\n SaveFormPlacement;\r\n except\r\n Application.HandleException(Self);\r\n end;\r\n FDestroying := False;\r\n end;\r\n if Assigned(FSaveFormDestroy) then\r\n FSaveFormDestroy(Sender);\r\nend;\r\n\r\n\r\n\r\nprocedure TJvFormPlacement.UpdatePlacement;\r\nconst\r\n Metrics: array [bsSingle..bsSizeToolWin] of Word =\r\n (SM_CXBORDER, SM_CXFRAME, SM_CXDLGFRAME, SM_CXBORDER, SM_CXFRAME);\r\nvar\r\n Placement: TWindowPlacement;\r\nbegin\r\n if (Owner <> nil) and (Owner is TCustomForm) and Form.HandleAllocated and\r\n not (csLoading in ComponentState) then\r\n if not (FPreventResize or CheckMinMaxInfo) then\r\n begin\r\n Placement.Length := SizeOf(TWindowPlacement);\r\n GetWindowPlacement(Form.Handle, @Placement);\r\n if not IsWindowVisible(Form.Handle) then\r\n Placement.ShowCmd := SW_HIDE;\r\n if Form.BorderStyle <> bsNone then\r\n begin\r\n Placement.ptMaxPosition.X := -GetSystemMetrics(Metrics[Form.BorderStyle]);\r\n Placement.ptMaxPosition.Y := -GetSystemMetrics(Succ(Metrics[Form.BorderStyle]));\r\n end\r\n else\r\n Placement.ptMaxPosition := Point(0, 0);\r\n SetWindowPlacement(Form.Handle, @Placement);\r\n end;\r\nend;\r\n\r\nprocedure TJvFormPlacement.UpdatePreventResize;\r\nvar\r\n IsActive: Boolean;\r\nbegin\r\n if not (csDesigning in ComponentState) and (Owner is TCustomForm) then\r\n begin\r\n if FPreventResize then\r\n FDefMaximize := (biMaximize in Form.BorderIcons);\r\n IsActive := Active;\r\n Active := False;\r\n try\r\n if (not FPreventResize) and FDefMaximize and\r\n (Form.BorderStyle <> bsDialog) then\r\n Form.BorderIcons := Form.BorderIcons + [biMaximize]\r\n else\r\n Form.BorderIcons := Form.BorderIcons - [biMaximize];\r\n finally\r\n Active := IsActive;\r\n end;\r\n if not (csLoading in ComponentState) then\r\n CheckToggleHook;\r\n end;\r\nend;\r\n\r\nprocedure TJvFormPlacement.SetPreventResize(AValue: Boolean);\r\nbegin\r\n if (Form <> nil) and (FPreventResize <> AValue) then\r\n begin\r\n FPreventResize := AValue;\r\n UpdatePlacement;\r\n UpdatePreventResize;\r\n end;\r\nend;\r\n\r\nprocedure TJvFormPlacement.Save;\r\nbegin\r\n if Assigned(FOnSavePlacement) then\r\n FOnSavePlacement(Self);\r\nend;\r\n\r\nprocedure TJvFormPlacement.Restore;\r\nbegin\r\n if Assigned(FOnRestorePlacement) then\r\n FOnRestorePlacement(Self);\r\nend;\r\n\r\nprocedure TJvFormPlacement.SavePlacement;\r\nbegin\r\n if Owner is TCustomForm then\r\n begin\r\n if Options <> [fpActiveControl] then\r\n begin\r\n InternalSaveFormPlacement(Form, AppStorage, AppStoragePath, Options);\r\n if (fpActiveControl in Options) and (Form.ActiveControl <> nil) then\r\n AppStorage.WriteString(AppStoragePath + siActiveCtrl, Form.ActiveControl.Name);\r\n end;\r\n end;\r\n NotifyLinks(poSave);\r\nend;\r\n\r\nprocedure TJvFormPlacement.RestorePlacement;\r\nbegin\r\n if Owner is TCustomForm then\r\n InternalRestoreFormPlacement(Form, AppStorage, AppStoragePath, Options);\r\n NotifyLinks(poRestore);\r\nend;\r\n\r\nfunction TJvFormPlacement.ConcatPaths(const Paths: array of string): string;\r\nbegin\r\n if Assigned(AppStorage) then\r\n Result := AppStorage.ConcatPaths(Paths)\r\n else\r\n Result := '';\r\nend;\r\n\r\nfunction TJvFormPlacement.ReadString(const Ident: string; const Default: string = ''): string;\r\nbegin\r\n if Assigned(AppStorage) and (Ident <> '') then\r\n Result := AppStorage.ReadString(AppStorage.ConcatPaths([AppStoragePath, AppStorage.TranslatePropertyName(Self, Ident, True)]), Default)\r\n else\r\n Result := Default;\r\nend;\r\n\r\nprocedure TJvFormPlacement.WriteString(const Ident, AValue: string);\r\nbegin\r\n if Assigned(AppStorage) and (Ident <> '') then\r\n AppStorage.WriteString(AppStorage.ConcatPaths([AppStoragePath, AppStorage.TranslatePropertyName(Self, Ident, False)]), AValue);\r\nend;\r\n\r\nfunction TJvFormPlacement.ReadBoolean(const Ident: string; Default: Boolean): Boolean;\r\nbegin\r\n if Assigned(AppStorage) and (Ident <> '') then\r\n Result := AppStorage.ReadBoolean(AppStorage.ConcatPaths([AppStoragePath, AppStorage.TranslatePropertyName(Self, Ident, True)]), Default)\r\n else\r\n Result := Default;\r\nend;\r\n\r\nprocedure TJvFormPlacement.WriteBoolean(const Ident: string; AValue: Boolean);\r\nbegin\r\n if Assigned(AppStorage) and (Ident <> '') then\r\n AppStorage.WriteBoolean(AppStorage.ConcatPaths([AppStoragePath, AppStorage.TranslatePropertyName(Self, Ident, False)]), AValue);\r\nend;\r\n\r\nfunction TJvFormPlacement.ReadFloat(const Ident: string; Default: Double = 0): Double;\r\nbegin\r\n if Assigned(AppStorage) and (Ident <> '') then\r\n Result := AppStorage.ReadFloat(AppStorage.ConcatPaths([AppStoragePath, AppStorage.TranslatePropertyName(Self, Ident, True)]), Default)\r\n else\r\n Result := Default;\r\nend;\r\n\r\nprocedure TJvFormPlacement.WriteFloat(const Ident: string; AValue: Double);\r\nbegin\r\n if Assigned(AppStorage) and (Ident <> '') then\r\n AppStorage.WriteFloat(AppStorage.ConcatPaths([AppStoragePath, AppStorage.TranslatePropertyName(Self, Ident, False)]), AValue);\r\nend;\r\n\r\nfunction TJvFormPlacement.ReadInteger(const Ident: string; Default: Longint = 0): Longint;\r\nbegin\r\n if Assigned(AppStorage) and (Ident <> '') then\r\n Result := AppStorage.ReadInteger(AppStorage.ConcatPaths([AppStoragePath, AppStorage.TranslatePropertyName(Self, Ident, True)]), Default)\r\n else\r\n Result := Default;\r\nend;\r\n\r\nprocedure TJvFormPlacement.WriteInteger(const Ident: string; AValue: Longint);\r\nbegin\r\n if Assigned(AppStorage) and (Ident <> '') then\r\n AppStorage.WriteInteger(AppStorage.ConcatPaths([AppStoragePath, AppStorage.TranslatePropertyName(Self, Ident, False)]), AValue);\r\nend;\r\n\r\nfunction TJvFormPlacement.ReadDateTime(const Ident: string; Default: TDateTime = 0): TDateTime;\r\nbegin\r\n if Assigned(AppStorage) and (Ident <> '') then\r\n Result := AppStorage.ReadDateTime(AppStorage.ConcatPaths([AppStoragePath, AppStorage.TranslatePropertyName(Self, Ident, True)]), Default)\r\n else\r\n Result := Default;\r\nend;\r\n\r\nprocedure TJvFormPlacement.WriteDateTime(const Ident: string; AValue: TDateTime);\r\nbegin\r\n if Assigned(AppStorage) and (Ident <> '') then\r\n AppStorage.WriteDateTime(AppStorage.ConcatPaths([AppStoragePath, AppStorage.TranslatePropertyName(Self, Ident, False)]), AValue);\r\nend;\r\n\r\nprocedure TJvFormPlacement.DeleteValue(const Ident: string);\r\nbegin\r\n // RH: added 2011-09-12\r\n if Assigned(AppStorage) and (Ident <> '') then\r\n AppStorage.DeleteValue(AppStorage.ConcatPaths([AppStoragePath, AppStorage.TranslatePropertyName(Self, Ident, False)]) );\r\nend;\r\n\r\nprocedure TJvFormPlacement.EraseSections;\r\nbegin\r\n AppStorage.DeleteSubTree(AppStoragePath);\r\nend;\r\n\r\nfunction TJvFormPlacement.IsActive: Boolean;\r\nbegin\r\n Result := Active and (AppStorage <> nil);\r\nend;\r\n\r\nprocedure TJvFormPlacement.SaveFormPlacement;\r\nbegin\r\n if Assigned(AppStorage) then\r\n begin\r\n AppStorage.BeginUpdate;\r\n try\r\n ResolveAppStoragePath; //need to resolve if not resolved yet (for Frames)\r\n\r\n if Assigned(FBeforeSavePlacement) then\r\n FBeforeSavePlacement(Self);\r\n if VersionCheck <> fpvcNocheck then\r\n WriteInteger(siVersion, FVersion);\r\n Save;\r\n SavePlacement;\r\n if Assigned(FAfterSavePlacement) then\r\n FAfterSavePlacement(Self);\r\n FSaved := True;\r\n finally\r\n AppStorage.EndUpdate;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvFormPlacement.RestoreFormPlacement;\r\nvar\r\n ActiveCtl: TComponent;\r\n ReadVersion: Integer;\r\n ContinueRestore: Boolean;\r\nbegin\r\n if Assigned(AppStorage) then\r\n begin\r\n ResolveAppStoragePath; //need to resolve if not resolved yet (for Frames)\r\n\r\n AppStorage.BeginUpdate;\r\n try\r\n FSaved := False;\r\n ReadVersion := ReadInteger(siVersion, 0);\r\n case VersionCheck of\r\n fpvcNocheck:\r\n ContinueRestore := True;\r\n fpvcCheckGreaterEqual:\r\n ContinueRestore := ReadVersion >= FVersion;\r\n fpvcCheckEqual:\r\n ContinueRestore := ReadVersion = FVersion;\r\n else\r\n ContinueRestore := False;\r\n end;\r\n if ContinueRestore then\r\n begin\r\n if Assigned(FBeforeRestorePlacement) then\r\n FBeforeRestorePlacement(Self);\r\n RestorePlacement;\r\n FRestored := True;\r\n Restore;\r\n if (fpActiveControl in Options) and (Owner is TCustomForm) then\r\n begin\r\n ActiveCtl := Form.FindComponent(AppStorage.ReadString(AppStorage.ConcatPaths([AppStoragePath, siActiveCtrl]), ''));\r\n if (ActiveCtl <> nil) and (ActiveCtl is TWinControl) and\r\n TWinControl(ActiveCtl).CanFocus then\r\n Form.ActiveControl := TWinControl(ActiveCtl);\r\n end;\r\n if Assigned(FAfterRestorePlacement) then\r\n FAfterRestorePlacement(Self);\r\n end;\r\n FRestored := True;\r\n finally\r\n AppStorage.EndUpdate;\r\n end;\r\n end;\r\n UpdatePlacement;\r\nend;\r\n\r\nprocedure TJvFormPlacement.Notification(AComponent: TComponent;\r\n Operation: TOperation);\r\nbegin\r\n inherited Notification(AComponent, Operation);\r\n if (Operation = opRemove) and (AComponent = AppStorage) then\r\n AppStorage := nil;\r\nend;\r\n\r\n//=== { TJvWinMinMaxInfo } ===================================================\r\n\r\nprocedure TJvWinMinMaxInfo.Assign(Source: TPersistent);\r\nbegin\r\n if Source is TJvWinMinMaxInfo then\r\n begin\r\n FMinMaxInfo := TJvWinMinMaxInfo(Source).FMinMaxInfo;\r\n if FOwner <> nil then\r\n FOwner.MinMaxInfoModified;\r\n end\r\n else\r\n inherited Assign(Source);\r\nend;\r\n\r\nfunction TJvWinMinMaxInfo.GetMinMaxInfo(Index: Integer): Integer;\r\nbegin\r\n case Index of\r\n 0:\r\n Result := FMinMaxInfo.ptMaxPosition.X;\r\n 1:\r\n Result := FMinMaxInfo.ptMaxPosition.Y;\r\n 2:\r\n Result := FMinMaxInfo.ptMaxSize.Y;\r\n 3:\r\n Result := FMinMaxInfo.ptMaxSize.X;\r\n 4:\r\n Result := FMinMaxInfo.ptMaxTrackSize.Y;\r\n 5:\r\n Result := FMinMaxInfo.ptMaxTrackSize.X;\r\n 6:\r\n Result := FMinMaxInfo.ptMinTrackSize.Y;\r\n 7:\r\n Result := FMinMaxInfo.ptMinTrackSize.X;\r\n else\r\n Result := 0;\r\n end;\r\nend;\r\n\r\nprocedure TJvWinMinMaxInfo.SetMinMaxInfo(Index: Integer; AValue: Integer);\r\nbegin\r\n if GetMinMaxInfo(Index) <> AValue then\r\n begin\r\n case Index of\r\n 0:\r\n FMinMaxInfo.ptMaxPosition.X := AValue;\r\n 1:\r\n FMinMaxInfo.ptMaxPosition.Y := AValue;\r\n 2:\r\n FMinMaxInfo.ptMaxSize.Y := AValue;\r\n 3:\r\n FMinMaxInfo.ptMaxSize.X := AValue;\r\n 4:\r\n FMinMaxInfo.ptMaxTrackSize.Y := AValue;\r\n 5:\r\n FMinMaxInfo.ptMaxTrackSize.X := AValue;\r\n 6:\r\n FMinMaxInfo.ptMinTrackSize.Y := AValue;\r\n 7:\r\n FMinMaxInfo.ptMinTrackSize.X := AValue;\r\n end;\r\n if FOwner <> nil then\r\n FOwner.MinMaxInfoModified;\r\n end;\r\nend;\r\n\r\nfunction TJvWinMinMaxInfo.DefaultMinMaxInfo: Boolean;\r\nbegin\r\n Result := not ((FMinMaxInfo.ptMinTrackSize.X <> 0) or\r\n (FMinMaxInfo.ptMinTrackSize.Y <> 0) or\r\n (FMinMaxInfo.ptMaxTrackSize.X <> 0) or\r\n (FMinMaxInfo.ptMaxTrackSize.Y <> 0) or\r\n (FMinMaxInfo.ptMaxSize.X <> 0) or\r\n (FMinMaxInfo.ptMaxSize.Y <> 0) or\r\n (FMinMaxInfo.ptMaxPosition.X <> 0) or\r\n (FMinMaxInfo.ptMaxPosition.Y <> 0));\r\nend;\r\n\r\n//=== { TJvFormStorage } =====================================================\r\n\r\nconstructor TJvFormStorage.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FStoredProps := TJvFormStorageStringList.Create(Self);\r\n FStoredValues := TJvStoredValues.Create(Self);\r\n FStoredValues.Storage := Self;\r\nend;\r\n\r\ndestructor TJvFormStorage.Destroy;\r\nbegin\r\n FStoredProps.Free;\r\n FStoredProps := nil;\r\n FStoredValues.Free;\r\n FStoredValues := nil;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvFormStorage.SetNotification;\r\nvar\r\n I: Integer;\r\n Component: TComponent;\r\nbegin\r\n for I := StoredProps.Count - 1 downto 0 do\r\n begin\r\n Component := TComponent(StoredProps.Objects[I]);\r\n if Component <> nil then\r\n Component.FreeNotification(Self);\r\n end;\r\nend;\r\n\r\nfunction TJvFormStorage.GetStoredProps: TStrings;\r\nbegin\r\n Result := FStoredProps;\r\nend;\r\n\r\nprocedure TJvFormStorage.SetStoredProps(AValue: TStrings);\r\nbegin\r\n FStoredProps.Assign(AValue);\r\n SetNotification;\r\nend;\r\n\r\nprocedure TJvFormStorage.SetStoredValues(AValue: TJvStoredValues);\r\nbegin\r\n FStoredValues.Assign(AValue);\r\nend;\r\n\r\nfunction TJvFormStorage.GetStoredValue(const Name: string): Variant;\r\nbegin\r\n Result := StoredValues.StoredValue[Name];\r\nend;\r\n\r\nprocedure TJvFormStorage.SetStoredValue(const Name: string; AValue: Variant);\r\nbegin\r\n StoredValues.StoredValue[Name] := AValue;\r\nend;\r\n\r\nprocedure TJvFormStorage.Loaded;\r\nbegin\r\n inherited Loaded;\r\n UpdateStoredList(Owner, FStoredProps, True);\r\nend;\r\n\r\nprocedure TJvFormStorage.WriteState(Writer: TWriter);\r\nbegin\r\n UpdateStoredList(Owner, FStoredProps, False);\r\n inherited WriteState(Writer);\r\nend;\r\n\r\nprocedure TJvFormStorage.Notification(AComponent: TComponent; Operation: TOperation);\r\nvar\r\n I: Integer;\r\n Component: TComponent;\r\nbegin\r\n inherited Notification(AComponent, Operation);\r\n if not (csDestroying in ComponentState) and (Operation = opRemove) and\r\n (FStoredProps <> nil) then\r\n for I := FStoredProps.Count - 1 downto 0 do\r\n begin\r\n Component := TComponent(FStoredProps.Objects[I]);\r\n if Component = AComponent then\r\n FStoredProps.Delete(I);\r\n end;\r\nend;\r\n\r\nprocedure TJvFormStorage.SaveProperties;\r\nvar\r\n PropertyStorage: TJvPropertyStorage;\r\nbegin\r\n PropertyStorage := TJvPropertyStorage.Create;\r\n try\r\n PropertyStorage.AppStoragePath := ConcatPaths ([AppStoragePath, StoredPropsPath]);\r\n PropertyStorage.AppStorage := AppStorage;\r\n PropertyStorage.StoreObjectsProps(Owner, FStoredProps);\r\n finally\r\n PropertyStorage.Free;\r\n end;\r\nend;\r\n\r\nprocedure TJvFormStorage.RestoreProperties;\r\nvar\r\n PropertyStorage: TJvPropertyStorage;\r\nbegin\r\n PropertyStorage := TJvPropertyStorage.Create;\r\n try\r\n PropertyStorage.AppStoragePath := ConcatPaths ([AppStoragePath, StoredPropsPath]);\r\n PropertyStorage.AppStorage := AppStorage;\r\n try\r\n PropertyStorage.LoadObjectsProps(Owner, FStoredProps);\r\n except\r\n { ignore any exceptions }\r\n end;\r\n finally\r\n PropertyStorage.Free;\r\n end;\r\nend;\r\n\r\nprocedure TJvFormStorage.SavePlacement;\r\nVar\r\n JvAppStorageHandler: IJvAppStorageHandler;\r\nbegin\r\n if FRestored then\r\n begin\r\n inherited SavePlacement;\r\n if Supports(Owner, IJvAppStorageHandler, JvAppStorageHandler)then\r\n JvAppStorageHandler.WriteToAppStorage(AppStorage, AppStoragePath);\r\n SaveProperties;\r\n StoredValues.SaveValues;\r\n end;\r\nend;\r\n\r\nprocedure TJvFormStorage.RestorePlacement;\r\nVar\r\n JvAppStorageHandler: IJvAppStorageHandler;\r\nbegin\r\n inherited RestorePlacement;\r\n FRestored := True;\r\n if Supports(Owner, IJvAppStorageHandler, JvAppStorageHandler)then\r\n JvAppStorageHandler.ReadFromAppStorage(AppStorage, AppStoragePath);\r\n RestoreProperties;\r\n StoredValues.RestoreValues;\r\nend;\r\n\r\n//=== { TJvIniLink } =========================================================\r\n\r\ndestructor TJvIniLink.Destroy;\r\nbegin\r\n FOnSave := nil;\r\n FOnLoad := nil;\r\n SetStorage(nil);\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvIniLink.SetStorage(AValue: TJvFormPlacement);\r\nbegin\r\n if FStorage <> AValue then\r\n begin\r\n if FStorage <> nil then\r\n FStorage.RemoveLink(Self);\r\n if AValue <> nil then\r\n AValue.AddLink(Self);\r\n end;\r\nend;\r\n\r\nprocedure TJvIniLink.SaveToIni;\r\nbegin\r\n if Assigned(FOnSave) then\r\n FOnSave(Self);\r\nend;\r\n\r\nprocedure TJvIniLink.LoadFromIni;\r\nbegin\r\n if Assigned(FOnLoad) then\r\n FOnLoad(Self);\r\nend;\r\n\r\n//=== { TJvStoredValue } =====================================================\r\n\r\nconstructor TJvStoredValue.Create(Collection: TCollection);\r\nbegin\r\n inherited Create(Collection);\r\n FValue := Unassigned;\r\nend;\r\n\r\nprocedure TJvStoredValue.Assign(Source: TPersistent);\r\nbegin\r\n if Source is TJvStoredValue then\r\n begin\r\n if VarIsEmpty(TJvStoredValue(Source).Value) then\r\n Clear\r\n else\r\n Value := TJvStoredValue(Source).Value;\r\n Name := TJvStoredValue(Source).Name;\r\n KeyString := TJvStoredValue(Source).KeyString;\r\n end\r\n else\r\n inherited Assign(Source);\r\nend;\r\n\r\nfunction TJvStoredValue.GetDisplayName: string;\r\nbegin\r\n if FName = '' then\r\n Result := inherited GetDisplayName\r\n else\r\n Result := FName;\r\nend;\r\n\r\nprocedure TJvStoredValue.SetDisplayName(const AValue: string);\r\nbegin\r\n if (AValue <> '') and (AnsiCompareText(AValue, FName) <> 0) and\r\n (Collection is TJvStoredValues) and (TJvStoredValues(Collection).IndexOf(AValue) >= 0) then\r\n raise EJVCLException.CreateRes(@SDuplicateString);\r\n FName := AValue;\r\n inherited SetDisplayName(AValue);\r\nend;\r\n\r\nfunction TJvStoredValue.GetStoredValues: TJvStoredValues;\r\nbegin\r\n if Collection is TJvStoredValues then\r\n Result := TJvStoredValues(Collection)\r\n else\r\n Result := nil;\r\nend;\r\n\r\nprocedure TJvStoredValue.Clear;\r\nbegin\r\n FValue := Unassigned;\r\nend;\r\n\r\nfunction TJvStoredValue.IsValueStored: Boolean;\r\nbegin\r\n Result := not VarIsEmpty(FValue);\r\nend;\r\n\r\nprocedure TJvStoredValue.Save;\r\nvar\r\n SaveValue: Variant;\r\n SaveStrValue: string;\r\n PathName: string;\r\nbegin\r\n PathName := StoredValues.Storage.ConcatPaths([StoredValues.Path, Name]);\r\n SaveValue := Value;\r\n if Assigned(FOnSave) then\r\n FOnSave(Self, SaveValue);\r\n if KeyString <> '' then\r\n begin\r\n SaveStrValue := VarToStr(SaveValue);\r\n SaveStrValue := XorEncodeString(KeyString, SaveStrValue);\r\n StoredValues.Storage.WriteString(PathName, SaveStrValue);\r\n end\r\n else\r\n if VarIsInt(SaveValue) then\r\n StoredValues.Storage.WriteInteger(PathName, SaveValue)\r\n else\r\n if VarType(SaveValue) in [varSingle, varDouble, varCurrency] then\r\n StoredValues.Storage.WriteFloat(PathName, SaveValue)\r\n else\r\n if VarType(SaveValue) in [varDate] then\r\n StoredValues.Storage.WriteDateTime(PathName, SaveValue)\r\n else\r\n if VarType(SaveValue) in [varBoolean] then\r\n StoredValues.Storage.WriteBoolean(PathName, SaveValue)\r\n else\r\n StoredValues.Storage.WriteString(PathName, SaveValue);\r\nend;\r\n\r\nprocedure TJvStoredValue.Restore;\r\nvar\r\n RestoreValue: Variant;\r\n RestoreStrValue, DefaultStrValue: string;\r\n PathName: string;\r\nbegin\r\n PathName := StoredValues.Storage.ConcatPaths([StoredValues.Path, Name]);\r\n if KeyString <> '' then\r\n begin\r\n DefaultStrValue := VarToStr(Value);\r\n DefaultStrValue := XorEncodeString(KeyString, DefaultStrValue);\r\n RestoreStrValue := StoredValues.Storage.ReadString(PathName, DefaultStrValue);\r\n RestoreStrValue := XorDecodeString(KeyString, RestoreStrValue);\r\n RestoreValue := RestoreStrValue;\r\n end\r\n else\r\n if VarIsInt(Value) then\r\n RestoreValue := StoredValues.Storage.ReadInteger(PathName, Value)\r\n else\r\n if VarType(Value) in [varSingle, varDouble, varCurrency] then\r\n RestoreValue := StoredValues.Storage.ReadFloat(PathName, Value)\r\n else\r\n if VarType(Value) in [varDate] then\r\n RestoreValue := StoredValues.Storage.ReadDateTime(PathName, Value)\r\n else\r\n if VarType(Value) in [varBoolean] then\r\n RestoreValue := StoredValues.Storage.ReadBoolean(PathName, Value)\r\n else\r\n RestoreValue := StoredValues.Storage.ReadString(PathName, Value);\r\n if Assigned(FOnRestore) then\r\n FOnRestore(Self, RestoreValue);\r\n Value := RestoreValue;\r\nend;\r\n\r\n//=== { TJvStoredValues } ====================================================\r\n\r\nconstructor TJvStoredValues.Create(AOwner: TPersistent);\r\nbegin\r\n inherited Create(AOwner, TJvStoredValue);\r\nend;\r\n\r\nfunction TJvStoredValues.IndexOf(const Name: string): Integer;\r\nbegin\r\n for Result := 0 to Count - 1 do\r\n if AnsiCompareText(Items[Result].Name, Name) = 0 then\r\n Exit;\r\n Result := -1;\r\nend;\r\n\r\nfunction TJvStoredValues.GetItem(Index: Integer): TJvStoredValue;\r\nbegin\r\n Result := TJvStoredValue(inherited Items[Index]);\r\nend;\r\n\r\nprocedure TJvStoredValues.SetItem(Index: Integer; StoredValue: TJvStoredValue);\r\nbegin\r\n inherited SetItem(Index, TCollectionItem(StoredValue));\r\nend;\r\n\r\nfunction TJvStoredValues.GetStoredValue(const Name: string): Variant;\r\nvar\r\n StoredValue: TJvStoredValue;\r\nbegin\r\n StoredValue := GetValue(Name);\r\n if StoredValue = nil then\r\n Result := Null\r\n else\r\n Result := StoredValue.Value;\r\nend;\r\n\r\nprocedure TJvStoredValues.SetStoredValue(const Name: string; AValue: Variant);\r\nvar\r\n StoredValue: TJvStoredValue;\r\nbegin\r\n StoredValue := GetValue(Name);\r\n if StoredValue = nil then\r\n begin\r\n StoredValue := TJvStoredValue(Add);\r\n StoredValue.Name := Name;\r\n StoredValue.Value := AValue;\r\n end\r\n else\r\n StoredValue.Value := AValue;\r\nend;\r\n\r\nfunction TJvStoredValues.GetValue(const Name: string): TJvStoredValue;\r\nvar\r\n I: Integer;\r\nbegin\r\n I := IndexOf(Name);\r\n if I < 0 then\r\n Result := nil\r\n else\r\n Result := Items[I];\r\nend;\r\n\r\nprocedure TJvStoredValues.SetValue(const Name: string; StoredValue: TJvStoredValue);\r\nvar\r\n I: Integer;\r\nbegin\r\n I := IndexOf(Name);\r\n if I >= 0 then\r\n Items[I].Assign(StoredValue);\r\nend;\r\n\r\nprocedure TJvStoredValues.SaveValues;\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := 0 to Count - 1 do\r\n Items[I].Save;\r\nend;\r\n\r\nprocedure TJvStoredValues.RestoreValues;\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := 0 to Count - 1 do\r\n Items[I].Restore;\r\nend;\r\n\r\nfunction TJvFormStorage.GetDefaultStoredValue(const Name: string; DefValue: Variant): Variant;\r\nbegin\r\n Result := StoredValue[Name];\r\n if Result = Null then\r\n Result := DefValue;\r\nend;\r\n\r\nprocedure TJvFormStorage.SetDefaultStoredValue(const Name: string;\r\n DefValue: Variant; const AValue: Variant);\r\nbegin\r\n if AValue = Null then\r\n StoredValue[Name] := DefValue\r\n else\r\n StoredValue[Name] := AValue;\r\nend;\r\n\r\nfunction TJvFormStorage.GetStoredValuesPath: string;\r\nbegin\r\n Result := FStoredValues.Path;\r\nend;\r\n\r\nprocedure TJvFormStorage.SetStoredValuesPath(const AValue: string);\r\nbegin\r\n FStoredValues.Path := AValue;\r\nend;\r\n\r\nprocedure TJvFormPlacement.ResolveAppStoragePath;\r\n \r\n function GetFullFrameName(AOwner: TComponent): String;\r\n var\r\n Own: String;\r\n begin\r\n if AOwner = nil then\r\n Result := ''\r\n else\r\n begin\r\n Own := GetFullFrameName(AOwner.Owner);\r\n if Own <> '' then\r\n Own := Own + '.';\r\n Result := Own + AOwner.Name;\r\n end;\r\n end;\r\n\r\nbegin\r\n if (StrFind(cFormNameMask, FAppStoragePath) <> 0) and Assigned(Owner) then\r\n if (Owner is TCustomForm) then\r\n StrReplace(FAppStoragePath, cFormNameMask, Owner.Name, [rfIgnoreCase])\r\n else if (Owner is TCustomFrame) then\r\n StrReplace(FAppStoragePath, cFormNameMask, GetFullFrameName(Owner), [rfIgnoreCase])\r\nend;\r\n\r\nprocedure TJvFormPlacement.SetAppStorage(const Value: TJvCustomAppStorage);\r\nbegin\r\n ReplaceComponentReference(Self, Value, TComponent(FAppStorage));\r\nend;\r\n\r\n{ TJvFormStorageStringList }\r\n\r\nprocedure TJvFormStorageStringList.Assign(Source: TPersistent);\r\nbegin\r\n inherited;\r\n if not (csLoading in FFormStorage.ComponentState) then\r\n UpdateStoredList(FFormStorage.Owner, Self, True);\r\nend;\r\n\r\nconstructor TJvFormStorageStringList.Create(AFormStorage: TJvFormStorage);\r\nbegin\r\n inherited Create;\r\n FFormStorage := AFormStorage;\r\nend;\r\n\r\nprocedure TJvFormStorageStringList.LoadFromStream(Stream: TStream);\r\nbegin\r\n inherited;\r\n if not (csLoading in FFormStorage.ComponentState) then\r\n UpdateStoredList(FFormStorage.Owner, Self, True);\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvFormPlacementSelectList.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Initial Developers of the Original Code is: Jens Fudickar\r\nAll Rights Reserved.\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvFormPlacementSelectList.pas 13171 2011-11-19 10:32:36Z jfudickar $\r\n\r\nunit JvFormPlacementSelectList;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n SysUtils, Classes,\r\n JvAppStorage, JvFormPlacement, JvAppStorageSelectList;\r\n\r\ntype\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64 or pidOSX32)]\r\n {$ENDIF RTL230_UP}\r\n TJvFormStorageSelectList = class (TJvBaseAppStorageSelectList)\r\n private\r\n FFormStorage: TJvFormStorage;\r\n protected\r\n procedure SetFormStorage(Value: TJvFormStorage); virtual;\r\n function GetAppStorage: TJvCustomAppStorage; override;\r\n procedure SetAppStorage(Value: TJvCustomAppStorage); override;\r\n function GetStoragePath: string; override;\r\n procedure Notification(AComponent: TComponent; Operation: TOperation); override;\r\n public\r\n function RestoreFormStorage(const ACaption: string = ''): Boolean;\r\n function SaveFormStorage(const ACaption: string = ''): Boolean;\r\n published\r\n property AppStorage;\r\n property CheckEntries;\r\n property FormStorage: TJvFormStorage read FFormStorage write SetFormStorage;\r\n property SelectListDialog;\r\n property SelectPath;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvFormPlacementSelectList.pas $';\r\n Revision: '$Revision: 13171 $';\r\n Date: '$Date: 2011-11-19 11:32:36 +0100 (sam. 19 nov. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n JvConsts, JvJVCLUtils;\r\n\r\nprocedure TJvFormStorageSelectList.SetFormStorage(Value: TJvFormStorage);\r\nbegin\r\n ReplaceComponentReference(Self, Value, TComponent(FFormStorage));\r\nend;\r\n\r\nfunction TJvFormStorageSelectList.GetAppStorage: TJvCustomAppStorage;\r\nbegin\r\n if Assigned(FFormStorage) then\r\n Result := FFormStorage.AppStorage\r\n else\r\n Result := nil;\r\nend;\r\n\r\nprocedure TJvFormStorageSelectList.SetAppStorage(Value: TJvCustomAppStorage);\r\nbegin\r\n if Assigned(FFormStorage) then\r\n FFormStorage.AppStorage := Value;\r\nend;\r\n\r\nfunction TJvFormStorageSelectList.GetStoragePath: string;\r\nbegin\r\n if Assigned(AppStorage) then\r\n Result := AppStorage.ConcatPaths([FormStorage.AppStoragePath, SelectPath])\r\n else\r\n Result := FormStorage.AppStoragePath + PathDelim + SelectPath;\r\nend;\r\n\r\nprocedure TJvFormStorageSelectList.Notification(AComponent: TComponent; Operation: TOperation);\r\nbegin\r\n inherited Notification(AComponent, Operation);\r\n if (Operation = opRemove) and (AComponent = FFormStorage) then\r\n FFormStorage := nil;\r\nend;\r\n\r\nfunction TJvFormStorageSelectList.RestoreFormStorage(const ACaption: string = ''): Boolean;\r\nvar\r\n OldPath: string;\r\nbegin\r\n if Assigned(FormStorage) then\r\n begin\r\n OldPath := FormStorage.AppStoragePath;\r\n try\r\n FormStorage.AppStoragePath := GetSelectListPath(sloLoad, ACaption);\r\n Result := FormStorage.AppStoragePath <> '';\r\n if Result then\r\n FormStorage.RestoreFormPlacement;\r\n finally\r\n FormStorage.AppStoragePath := OldPath;\r\n end;\r\n end\r\n else\r\n Result := False;\r\nend;\r\n\r\nfunction TJvFormStorageSelectList.SaveFormStorage(const ACaption: string = ''): Boolean;\r\nvar\r\n OldPath: string;\r\nbegin\r\n if Assigned(FormStorage) then\r\n begin\r\n OldPath := FormStorage.AppStoragePath;\r\n try\r\n FormStorage.AppStoragePath := GetSelectListPath(sloStore, ACaption);\r\n Result := FormStorage.AppStoragePath <> '';\r\n if Result then\r\n FormStorage.SaveFormPlacement;\r\n finally\r\n FormStorage.AppStoragePath := OldPath;\r\n end;\r\n end\r\n else\r\n Result := False;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend." }, { "path": "External/Jedi/Jvcl/run/JvFormToHtml.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvFormToHtml.PAS, released on 2001-02-28.\r\n\r\nThe Initial Developer of the Original Code is Sbastien Buysse [sbuysse att buypin dott com]\r\nPortions created by Sbastien Buysse are Copyright (C) 2001 Sbastien Buysse.\r\nAll Rights Reserved.\r\n\r\nContributor(s): Michael Beck [mbeck att bigfoot dott com].\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvFormToHtml.pas 13104 2011-09-07 06:50:43Z obones $\r\n\r\nunit JvFormToHtml;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n SysUtils, Classes, Graphics, Controls, Forms, StdCtrls,\r\n JvComponentBase;\r\n\r\ntype\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64 or pidOSX32)]\r\n {$ENDIF RTL230_UP}\r\n TJvFormToHtml = class(TJvComponent)\r\n public\r\n procedure FormToHtml(const Form: TCustomForm; const Filename: string);\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvFormToHtml.pas $';\r\n Revision: '$Revision: 13104 $';\r\n Date: '$Date: 2011-09-07 08:50:43 +0200 (mer. 07 sept. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\n\r\nfunction FontToCss(const Font: TFont): string;\r\nbegin\r\n Result := Format(';font-Size:%d;color:#%d;font-weight:', [Font.Size, Font.Color]);\r\n if fsBold in Font.Style then\r\n Result := Result + 'bold;'\r\n else\r\n Result := Result + 'normal;';\r\n Result := Result + 'font-family:' + Font.Name;\r\nend;\r\n\r\nprocedure TJvFormToHtml.FormToHtml(const Form: TCustomForm; const Filename: string);\r\nvar\r\n I, J: Integer;\r\n C: TComponent;\r\n S, S2, St: string;\r\n HTML: TStringList;\r\nbegin\r\n HTML := TStringList.Create;\r\n try\r\n HTML.Add('');\r\n for I := 0 to Form.ComponentCount - 1 do\r\n begin\r\n C := Form.Components[I];\r\n St := '';\r\n if C is TLabel then\r\n begin\r\n St := Format('';\r\n end\r\n else\r\n if C is TButton then\r\n begin\r\n if not TButton(C).Enabled then\r\n S := ' DISABLED'\r\n else\r\n S := '';\r\n\r\n St := Format('';\r\n end\r\n else\r\n if C is TMemo then\r\n begin\r\n S := '';\r\n if TMemo(C).ReadOnly then\r\n S := S + ' ReadOnly';\r\n if not TMemo(C).Enabled then\r\n S := S + ' DISABLED';\r\n\r\n S2 := '';\r\n if TMemo(C).WordWrap then\r\n S2 := S2 + ' WRAP=PHYSICAL'\r\n else\r\n S2 := S2 + ' WRAP=OFF';\r\n\r\n St := Format('';\r\n end\r\n else\r\n if C is TCheckBox then\r\n begin\r\n S := '';\r\n if not TCheckBox(C).Enabled then\r\n S := S + ' DISABLED';\r\n if TCheckBox(C).Checked then\r\n S := S + ' CHECKED';\r\n\r\n St := Format('';\r\n HTML.Add(St);\r\n St := Format('';\r\n end\r\n else\r\n if C is TRadioButton then\r\n begin\r\n S := '';\r\n if not TRadioButton(C).Enabled then\r\n S := S + ' DISABLED';\r\n if TRadioButton(C).Checked then\r\n S := S + ' CHECKED';\r\n\r\n St := Format('';\r\n HTML.Add(St);\r\n St := Format('';\r\n end\r\n else\r\n if C is TEdit then\r\n begin\r\n S := '';\r\n if TEdit(C).ReadOnly then\r\n S := S + ' ReadOnly';\r\n if TEdit(C).MaxLength <> 0 then\r\n S := S + ' MAXLENGTH=' + IntToStr(TEdit(C).MaxLength);\r\n if not TEdit(C).Enabled then\r\n S := S + ' DISABLED';\r\n\r\n St := Format('';\r\n end\r\n else\r\n if C is TComboBox then\r\n begin\r\n if not TComboBox(C).Enabled then\r\n S := ' DISABLED'\r\n else\r\n S := '';\r\n\r\n St := Format('';\r\n end\r\n else\r\n if C is TListBox then\r\n begin\r\n if not TListBox(C).Enabled then\r\n S := ' DISABLED'\r\n else\r\n S := '';\r\n\r\n St := Format('';\r\n end;\r\n\r\n if St <> '' then\r\n HTML.Add(St);\r\n end;\r\n HTML.Add('');\r\n\r\n HTML.SaveToFile(Filename);\r\n finally\r\n HTML.Free;\r\n end;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvFormTransparent.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvTransparentForm.PAS, released on 2001-02-28.\r\n\r\nThe Initial Developer of the Original Code is Sbastien Buysse [sbuysse att buypin dott com]\r\nPortions created by Sbastien Buysse are Copyright (C) 2001 Sbastien Buysse.\r\nAll Rights Reserved.\r\n\r\nContributor(s): Michael Beck [mbeck att bigfoot dott com].\r\n Andreas Hausladen [Andreas dott Hausladen att gmx dott net] (complete rewrite)\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvFormTransparent.pas 13104 2011-09-07 06:50:43Z obones $\r\n\r\nunit JvFormTransparent;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, StdCtrls, ExtCtrls,\r\n JvComponentBase;\r\n\r\ntype\r\n TJvTransparentFormMode = (\r\n tfmWindowRegion, // Use Mask as the window region\r\n tfmWindowRegionAlphaChannel, // Use the alpha channel of Mask (32bit with alpha channel) for the window region\r\n tfmLayeredWindow // Use Mask (32bit with alpha channel) for the layered window (Windows 2000 or newer)\r\n );\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64 or pidOSX32)]\r\n {$ENDIF RTL230_UP}\r\n TJvTransparentForm = class(TJvComponent)\r\n private\r\n FMask: TBitmap;\r\n FComponentOwner: TCustomForm;\r\n FAutoSize: Boolean;\r\n FActive: Boolean;\r\n FMode: TJvTransparentFormMode;\r\n FMovableForm: Boolean;\r\n FOrgWndProc: TWndMethod;\r\n FControlForm: TForm;\r\n FLayeredTransparentControlColor: TColor;\r\n FLayeredAlphaValue: Integer;\r\n FMaskFromImage: TImage;\r\n procedure SetActive(Value: Boolean);\r\n procedure SetMask(Value: TBitmap);\r\n procedure SetMode(const Value: TJvTransparentFormMode);\r\n procedure SetAutoSize(Value: Boolean);\r\n procedure DisableTransparency;\r\n procedure UpdateTransparency;\r\n procedure SetLayeredTransparentControlColor(const Value: TColor);\r\n procedure ReparentChildControls(OldParent, NewParent: TWinControl);\r\n procedure SetLayeredAlphaValue(Value: Integer);\r\n procedure SetMaskFromImage(const Value: TImage);\r\n procedure UpdateMaskFromImage;\r\n protected\r\n procedure Loaded; override;\r\n procedure WndProc(var Msg: TMessage);\r\n procedure Notification(AComponent: TComponent; Operation: TOperation); override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n procedure Update;\r\n published\r\n { Active enables/disables the transparent top level form }\r\n property Active: Boolean read FActive write SetActive default False;\r\n { Mask specifies (depending on Mode) the region or the 32bit alpha channel background picture }\r\n property Mask: TBitmap read FMask write SetMask;\r\n { With MaskFromImage you can automatically use the image of a TImage component for the mask.\r\n This is especially helpfull if you want to use a PNG image with tfmLayeredWindow. Setting\r\n the property automatically sets the image's Visible property to False in the IDE (design time). }\r\n property MaskFromImage: TImage read FMaskFromImage write SetMaskFromImage;\r\n { If AutoSize is True the top level window will be resized to fit the Mask }\r\n property AutoSize: Boolean read FAutoSize write SetAutoSize default False;\r\n { Mode specifies how Mask should be interpreted }\r\n property Mode: TJvTransparentFormMode read FMode write SetMode default tfmWindowRegion;\r\n { If MoveableForm is True the user can move the form by pressing anywhere on the form }\r\n property MovableForm: Boolean read FMovableForm write FMovableForm default False;\r\n { Mode=tfmLayeredWindow: LayeredTransparentControlColor controls the transparent color for\r\n child controls. You should keep the color as near as possible to the Mask bitmap. }\r\n property LayeredTransparentControlColor: TColor read FLayeredTransparentControlColor write SetLayeredTransparentControlColor default $FEFEFE;\r\n { Mode=tfmLayeredWindow: LayeredAlphaValue controls the form's general semi-transparency. }\r\n property LayeredAlphaValue: Integer read FLayeredAlphaValue write SetLayeredAlphaValue default 255;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvFormTransparent.pas $';\r\n Revision: '$Revision: 13104 $';\r\n Date: '$Date: 2011-09-07 08:50:43 +0200 (mer. 07 sept. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n JclGraphics;\r\n\r\ntype\r\n TOpenCustomForm = class(TCustomForm);\r\n\r\n { UpdateLayeredWindow doesn't allow controls to paint themself. So we use a trick here.\r\n All controls are moved into a TJvControlForm form that is placed above the form and\r\n that moves and resizes with the semi-transparent form. }\r\n TJvControlForm = class(TForm)\r\n protected\r\n procedure CreateParams(var Params: TCreateParams); override;\r\n procedure WMClose(var Message: TWMClose); message WM_CLOSE;\r\n procedure WMNCHitTest(var Message: TWMNCHitTest); message WM_NCHITTEST;\r\n procedure WMErasebkgnd(var Message: TWMEraseBkgnd); message WM_ERASEBKGND;\r\n end;\r\n\r\n{ TControlForm }\r\n\r\nprocedure TJvControlForm.CreateParams(var Params: TCreateParams);\r\nbegin\r\n inherited CreateParams(Params);\r\n Params.Style := WS_POPUP;\r\n { Stay on top of the semi-transparent form. }\r\n Params.WndParent := (Owner as TJvTransparentForm).FComponentOwner.Handle;\r\nend;\r\n\r\nprocedure TJvControlForm.WMClose(var Message: TWMClose);\r\nbegin\r\n { Redirect any close command to the semi-transparent form. }\r\n Message.Result := (Owner as TJvTransparentForm).FComponentOwner.Perform(Message.Msg, 0, 0);\r\nend;\r\n\r\nprocedure TJvControlForm.WMErasebkgnd(var Message: TWMEraseBkgnd);\r\nvar\r\n I: Integer;\r\n R: TRect;\r\n MaskDC: HDC;\r\n Control: TControl;\r\nbegin\r\n { Fill with transparent color }\r\n FillRect(Message.DC, Rect(0, 0, Width, Height), Brush.Handle);\r\n\r\n { Replace the transparent color with the actual Mask content. This lets fonts and\r\n other transparent controls that use aliasing look much better. }\r\n MaskDC := TJvTransparentForm(Owner).FMask.Canvas.Handle;\r\n for I := 0 to ControlCount - 1 do\r\n begin\r\n Control := Controls[I];\r\n if Control.Visible then\r\n begin\r\n R := Control.BoundsRect;\r\n BitBlt(Message.DC, R.Left, R.Top, R.Right - R.Left, R.Bottom - R.Top, MaskDC, R.Left, R.Top, SRCCOPY)\r\n end;\r\n end;\r\n Message.Result := 1;\r\nend;\r\n\r\nprocedure TJvControlForm.WMNCHitTest(var Message: TWMNCHitTest);\r\nbegin\r\n { It must feel like this helper form doesn't exist. }\r\n Message.Result := HTTRANSPARENT;\r\nend;\r\n\r\n{ TJvTransparentForm }\r\n\r\nconstructor TJvTransparentForm.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FComponentOwner := GetParentForm(TControl(AOwner));\r\n if (FComponentOwner <> nil) and not (csDesigning in ComponentState) then\r\n begin\r\n FOrgWndProc := FComponentOwner.WindowProc;\r\n FComponentOwner.WindowProc := WndProc;\r\n end;\r\n FLayeredTransparentControlColor := $FEFEFE;\r\n FLayeredAlphaValue := 255;\r\n FMask := TBitmap.Create;\r\n FMask.PixelFormat := pf32bit;\r\nend;\r\n\r\ndestructor TJvTransparentForm.Destroy;\r\nbegin\r\n if FComponentOwner <> nil then\r\n begin\r\n if not (csDestroying in FComponentOwner.ComponentState) then\r\n Active := False;\r\n if not (csDesigning in ComponentState) then\r\n FComponentOwner.WindowProc := FOrgWndProc;\r\n FComponentOwner := nil;\r\n end;\r\n SetMaskFromImage(nil);\r\n FControlForm.Free;\r\n FMask.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvTransparentForm.ReparentChildControls(OldParent, NewParent: TWinControl);\r\nvar\r\n I: Integer;\r\n List: TList;\r\nbegin\r\n List := TList.Create;\r\n try\r\n { Reparent the controls but keep the tab order. }\r\n for I := 0 to OldParent.ControlCount - 1 do\r\n List.Add(OldParent.Controls[I]);\r\n for I := 0 to List.Count - 1 do\r\n begin\r\n TControl(List[I]).Parent := NewParent;\r\n if (TControl(List[I]) is TCustomLabel) and not TLabel(List[I]).Transparent then\r\n TLabel(List[I]).Transparent := True;\r\n end;\r\n finally\r\n List.Free;\r\n end;\r\nend;\r\n\r\nprocedure TJvTransparentForm.Update;\r\nbegin\r\n UpdateMaskFromImage;\r\n UpdateTransparency;\r\nend;\r\n\r\nprocedure TJvTransparentForm.UpdateMaskFromImage;\r\nbegin\r\n if ([csLoading, csDesigning] * ComponentState = []) and (FMaskFromImage <> nil) and\r\n (FMaskFromImage.Picture.Graphic <> nil) then\r\n FMask.Assign(FMaskFromImage.Picture.Graphic);\r\nend;\r\n\r\nprocedure TJvTransparentForm.DisableTransparency;\r\nvar\r\n Params: TCreateParams;\r\nbegin\r\n if not Active or ([csDesigning, csLoading] * ComponentState <> []) or\r\n (FComponentOwner = nil) or not FComponentOwner.HandleAllocated then\r\n Exit;\r\n\r\n { Enable caption }\r\n FillChar(Params, SizeOf(Params), 0);\r\n TOpenCustomForm(FComponentOwner).CreateParams(Params);\r\n SetWindowLong(FComponentOwner.Handle, GWL_STYLE,\r\n GetWindowLong(FComponentOwner.Handle, GWL_STYLE)\r\n or (Integer(Params.Style) and not (WS_VISIBLE or WS_MAXIMIZE or WS_DISABLED)));\r\n case Mode of\r\n tfmWindowRegion, tfmWindowRegionAlphaChannel:\r\n begin\r\n { Remove region }\r\n SetWindowRgn(FComponentOwner.Handle, 0, True);\r\n end;\r\n\r\n tfmLayeredWindow:\r\n begin\r\n { Disable layered window }\r\n SetWindowLong(FComponentOwner.Handle, GWL_EXSTYLE,\r\n GetWindowLong(FComponentOwner.Handle, GWL_EXSTYLE) and not WS_EX_LAYERED);\r\n if FControlForm <> nil then\r\n ReparentChildControls(FControlForm, FComponentOwner);\r\n FreeAndNil(FControlForm);\r\n FComponentOwner.Refresh;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvTransparentForm.UpdateTransparency;\r\nconst\r\n BorderStyles = WS_SYSMENU or WS_MINIMIZEBOX or WS_MAXIMIZEBOX or\r\n WS_CAPTION or WS_BORDER or WS_THICKFRAME or WS_DLGFRAME;\r\nvar\r\n Region: HRGN;\r\n BlendFunc: TBlendFunction;\r\n Pt: TPoint;\r\n Sz: TSize;\r\nbegin\r\n if not Active or ([csDesigning, csLoading] * ComponentState <> []) or (FComponentOwner = nil) then\r\n Exit;\r\n\r\n { Remove caption }\r\n SetWindowLong(FComponentOwner.Handle, GWL_STYLE,\r\n GetWindowLong(FComponentOwner.Handle, GWL_STYLE) and not BorderStyles);\r\n case Mode of\r\n tfmWindowRegion, tfmWindowRegionAlphaChannel:\r\n begin\r\n Region := 0;\r\n if not FMask.Empty then\r\n begin\r\n if Mode = tfmWindowRegionAlphaChannel then\r\n Region := CreateRegionFromBitmap(FMask, 0, rmExclude, True)\r\n else\r\n Region := CreateRegionFromBitmap(FMask, FMask.Canvas.Pixels[0, 0], rmExclude, False);\r\n end;\r\n if SetWindowRgn(FComponentOwner.Handle, Region, True) = 0 then\r\n if Region <> 0 then\r\n DeleteObject(Region);\r\n { Region is now no longer valid }\r\n end;\r\n\r\n tfmLayeredWindow:\r\n begin\r\n if not FMask.Empty then\r\n begin\r\n if FControlForm = nil then\r\n begin\r\n FControlForm := TJvControlForm.CreateNew(Self);\r\n FControlForm.Position := poDesigned;\r\n FControlForm.BorderStyle := bsNone;\r\n end;\r\n FControlForm.Color := LayeredTransparentControlColor;\r\n FControlForm.TransparentColorValue := FControlForm.Color;\r\n FControlForm.TransparentColor := True;\r\n\r\n FControlForm.BoundsRect := FComponentOwner.BoundsRect;\r\n ReparentChildControls(FComponentOwner, FControlForm);\r\n\r\n SetWindowLong(FComponentOwner.Handle, GWL_EXSTYLE,\r\n GetWindowLong(FComponentOwner.Handle, GWL_EXSTYLE) or WS_EX_LAYERED);\r\n\r\n FillChar(BlendFunc, SizeOf(BlendFunc), 0);\r\n BlendFunc.BlendOp := AC_SRC_OVER;\r\n BlendFunc.BlendFlags := 0;\r\n BlendFunc.AlphaFormat := AC_SRC_ALPHA;\r\n BlendFunc.SourceConstantAlpha := LayeredAlphaValue;\r\n\r\n Pt := Point(0, 0);\r\n Sz.cx := FMask.Width;\r\n Sz.cy := FMask.Height;\r\n UpdateLayeredWindow(FComponentOwner.Handle, 0, nil, @Sz,\r\n FMask.Canvas.Handle, @Pt, 0, @BlendFunc, ULW_ALPHA);\r\n\r\n if FComponentOwner.Visible then\r\n FControlForm.Show;\r\n end;\r\n end;\r\n end;\r\n\r\n if AutoSize and not FMask.Empty then\r\n begin\r\n FComponentOwner.Width := FMask.Width;\r\n FComponentOwner.Height := FMask.Height;\r\n end;\r\nend;\r\n\r\nprocedure TJvTransparentForm.WndProc(var Msg: TMessage);\r\nbegin\r\n if Active then\r\n begin\r\n case Msg.Msg of\r\n WM_NCHITTEST:\r\n if MovableForm then\r\n begin\r\n Msg.Result := HTCAPTION;\r\n Exit;\r\n end;\r\n end;\r\n end;\r\n\r\n if Assigned(FOrgWndProc) then\r\n FOrgWndProc(Msg);\r\n\r\n if Msg.Msg = CM_RELEASE then // the form can be evil\r\n Exit;\r\n\r\n if Active then\r\n begin\r\n case Msg.Msg of\r\n WM_MOVE, WM_MOVING, WM_SIZE, WM_SIZING:\r\n if (FControlForm <> nil) and (FComponentOwner <> nil) then\r\n FControlForm.BoundsRect := FComponentOwner.BoundsRect;\r\n\r\n WM_SHOWWINDOW:\r\n begin\r\n if TWMShowWindow(Msg).Show then\r\n begin\r\n if Mode = tfmLayeredWindow then\r\n UpdateTransparency;\r\n end\r\n else\r\n if FControlForm <> nil then\r\n FControlForm.Hide;\r\n end;\r\n\r\n WM_SETFOCUS:\r\n if (FControlForm <> nil) and FControlForm.Visible then\r\n FControlForm.Perform(Msg.Msg, Msg.WParam, Msg.LParam);\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvTransparentForm.Loaded;\r\nbegin\r\n inherited Loaded;\r\n UpdateMaskFromImage;\r\n UpdateTransparency;\r\nend;\r\n\r\nprocedure TJvTransparentForm.Notification(AComponent: TComponent; Operation: TOperation);\r\nbegin\r\n inherited Notification(AComponent, Operation);\r\n if Operation = opRemove then\r\n begin\r\n if AComponent = FComponentOwner then\r\n FComponentOwner := nil\r\n else if AComponent = FMaskFromImage then\r\n MaskFromImage := nil;\r\n end;\r\nend;\r\n\r\nprocedure TJvTransparentForm.SetMask(Value: TBitmap);\r\nbegin\r\n if Value <> FMask then\r\n begin\r\n FMask.Assign(Value);\r\n UpdateTransparency;\r\n end;\r\nend;\r\n\r\nprocedure TJvTransparentForm.SetMaskFromImage(const Value: TImage);\r\nbegin\r\n if Value <> FMaskFromImage then\r\n begin\r\n if FMaskFromImage <> nil then\r\n FMaskFromImage.RemoveFreeNotification(Self);\r\n FMaskFromImage := Value;\r\n if FMaskFromImage <> nil then\r\n FMaskFromImage.FreeNotification(Self);\r\n\r\n if (csDesigning in ComponentState) and (FMaskFromImage <> nil) then\r\n FMaskFromImage.Visible := False;\r\n\r\n UpdateMaskFromImage;\r\n end;\r\nend;\r\n\r\nprocedure TJvTransparentForm.SetMode(const Value: TJvTransparentFormMode);\r\nbegin\r\n if Value <> FMode then\r\n begin\r\n if Active then\r\n DisableTransparency;\r\n FMode := Value;\r\n if Active then\r\n UpdateTransparency;\r\n end;\r\nend;\r\n\r\nprocedure TJvTransparentForm.SetActive(Value: Boolean);\r\nbegin\r\n if Value <> FActive then\r\n begin\r\n if FActive then\r\n DisableTransparency;\r\n FActive := Value;\r\n if FActive then\r\n UpdateTransparency;\r\n end;\r\nend;\r\n\r\nprocedure TJvTransparentForm.SetAutoSize(Value: Boolean);\r\nbegin\r\n FAutoSize := Value;\r\n if Value and Active and not (csLoading in ComponentState) and not FMask.Empty then\r\n begin\r\n FComponentOwner.Width := FMask.Width;\r\n FComponentOwner.Height := FMask.Height;\r\n end;\r\nend;\r\n\r\nprocedure TJvTransparentForm.SetLayeredAlphaValue(Value: Integer);\r\nbegin\r\n if Value < 0 then\r\n Value := 0;\r\n if Value > 255 then\r\n Value := 255;\r\n\r\n if Value <> FLayeredAlphaValue then\r\n begin\r\n FLayeredAlphaValue := Value;\r\n if Mode = tfmLayeredWindow then\r\n UpdateTransparency;\r\n end;\r\nend;\r\n\r\nprocedure TJvTransparentForm.SetLayeredTransparentControlColor(const Value: TColor);\r\nbegin\r\n if Value <> FLayeredTransparentControlColor then\r\n begin\r\n FLayeredTransparentControlColor := Value;\r\n if FControlForm <> nil then\r\n begin\r\n FControlForm.Color := FLayeredTransparentControlColor;\r\n FControlForm.TransparentColorValue := FControlForm.Color;\r\n end;\r\n end;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvFormWallpaper.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvFormWallpaper.PAS, released on 2001-02-28.\r\n\r\nThe Initial Developer of the Original Code is Sbastien Buysse [sbuysse att buypin dott com]\r\nPortions created by Sbastien Buysse are Copyright (C) 2001 Sbastien Buysse.\r\nAll Rights Reserved.\r\n\r\nContributor(s): Michael Beck [mbeck att bigfoot dott com].\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvFormWallpaper.pas 13222 2012-02-24 14:19:37Z obones $\r\n\r\nunit JvFormWallpaper;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n SysUtils, Classes, Graphics, Controls,\r\n JvComponent;\r\n\r\ntype\r\n TJvOffsetMode = (omRows, omColumns);\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64 or pidOSX32)]\r\n {$ENDIF RTL230_UP}\r\n TJvFormWallpaper = class(TJvGraphicControl)\r\n private\r\n FImage: TPicture;\r\n FOffset: Integer;\r\n FOffsetMode: TJvOffsetMode;\r\n procedure SetImage(Value: TPicture);\r\n procedure FormPaint(Sender: TObject);\r\n procedure SetOffset(const Value: Integer);\r\n procedure SetOffsetMode(const Value: TJvOffsetMode);\r\n procedure ValidateOffset;\r\n protected\r\n procedure Paint; override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n published\r\n property Align default alClient;\r\n property Image: TPicture read FImage write SetImage;\r\n property Offset: Integer read FOffset write SetOffset default 0;\r\n property OffsetMode: TJvOffsetMode read FOffsetMode write SetOffsetMode default omRows;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvFormWallpaper.pas $';\r\n Revision: '$Revision: 13222 $';\r\n Date: '$Date: 2012-02-24 15:19:37 +0100 (ven. 24 févr. 2012) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n Forms;\r\n\r\nconstructor TJvFormWallpaper.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FImage := TPicture.Create;\r\n FImage.OnChange := FormPaint;\r\n Align := alClient;\r\nend;\r\n\r\ndestructor TJvFormWallpaper.Destroy;\r\nbegin\r\n FImage.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvFormWallpaper.SetImage(Value: TPicture);\r\nbegin\r\n FImage.Assign(Value);\r\n ValidateOffset;\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvFormWallpaper.ValidateOffset;\r\nbegin\r\n case OffsetMode of\r\n omRows:\r\n if FOffset > FImage.Width then\r\n FOffset := FImage.Width;\r\n omColumns:\r\n if FOffset > FImage.Height then\r\n FOffset := FImage.Height;\r\n end;\r\nend;\r\n\r\nprocedure TJvFormWallpaper.SetOffset(const Value: Integer);\r\nbegin\r\n FOffset := Value;\r\n ValidateOffset;\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvFormWallpaper.SetOffsetMode(const Value: TJvOffsetMode);\r\nbegin\r\n FOffsetMode := Value;\r\n ValidateOffset;\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvFormWallpaper.Paint;\r\nvar\r\n X, Y, OX, OY: Integer;\r\n Bmp: TBitmap;\r\nbegin\r\n if (FImage <> nil) and (FImage.Width > 0) and (FImage.Height > 0) then\r\n begin\r\n Bmp := TBitmap.Create;\r\n try\r\n Bmp.Width := Width;\r\n Bmp.Height := Height;\r\n OX := 0;\r\n OY := 0;\r\n for X := 0 to (Width + Abs(FOffset - FImage.Width)) div FImage.Width do\r\n begin\r\n if OffsetMode = omColumns then\r\n if X mod 2 = 0 then\r\n OY := 0\r\n else\r\n OY := FOffset - FImage.Height;\r\n for Y := 0 to (Height + Abs(OY)) div FImage.Height do\r\n begin\r\n if OffsetMode = omRows then\r\n if Y mod 2 = 0 then\r\n OX := 0\r\n else\r\n OX := FOffset - FImage.Width;\r\n Bmp.Canvas.Draw(X * FImage.Width + OX, Y * FImage.Height + OY, FImage.Graphic);\r\n end;\r\n end;\r\n Canvas.Draw(0, 0, Bmp);\r\n finally\r\n Bmp.Free;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvFormWallpaper.FormPaint(Sender: TObject);\r\nbegin\r\n if (Parent is TForm) and (TForm(Parent).FormStyle = fsMDIForm) then\r\n RequestAlign // Invalidate DOES NOT work here (Mantis 5689)\r\n else\r\n Invalidate;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvForth.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvForth.PAS, released on 2002-06-15.\r\n\r\nThe Initial Developer of the Original Code is Jan Verhoeven [jan1 dott verhoeven att wxs dott nl]\r\nPortions created by Jan Verhoeven are Copyright (C) 2002 Jan Verhoeven.\r\nAll Rights Reserved.\r\n\r\nContributor(s): Robert Love [rlove att slcdug dott org].\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvForth.pas 13104 2011-09-07 06:50:43Z obones $\r\n\r\nunit JvForth;\r\n\r\n{$I jvcl.inc}\r\n{$I crossplatform.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n SysUtils, Classes,\r\n {$IFDEF MSWINDOWS}\r\n ShellAPI,\r\n {$ENDIF MSWINDOWS}\r\n Windows, Messages, Forms, Dialogs, FileCtrl, Variants,\r\n JvXmlTree, JvComponentBase, JvStrings, JvTypes;\r\n\r\nconst\r\n StackMax = 1000;\r\n\r\ntype\r\n EJvJanScriptError = class(EJVCLException);\r\n\r\n TToken = (dfoError, dfoNop,\r\n // flow actions\r\n dfoIf, dfoElse, dfoEndIf, dfoRepeat, dfoUntil,\r\n // sub routines\r\n dfoSub, dfoEndSub, dfoCall,\r\n // stack operations\r\n dfoDup, dfoDrop, dfoSwap,\r\n // conversion\r\n dfoCstr,\r\n // data source object, symbols starting with _\r\n dfoDSO, dfoSelDir, dfoDSOBase,\r\n // xmldso starts with ?\r\n dfoXML,\r\n // system io\r\n dfoSystem,\r\n // internal variables\r\n dfoIntVar,\r\n // external variables\r\n dfoExtVar,\r\n // direct action\r\n dfoInteger, dfoFloat, dfoSet, dfoString, dfoBoolean,\r\n dfoDate,\r\n // end direct action\r\n dfoEq, dfoNe, dfoGt, dfoLt, dfoGe, dfoLe, dfoLike, dfoUnlike,\r\n dfoNot, dfoAnd, dfoXor, dfoOr,\r\n dfoIn,\r\n dfoAdd, dfoSubtract, dfoMultiply, dfoDivide, dfoPower,\r\n dfoAbs,\r\n // some usefull constants\r\n dfoCrLf,\r\n // some gonio functions\r\n dfoSin, dfoCos, dfoPi, dfoTan,\r\n dfoArcSin, dfoArcCos, dfoArcTan, dfoArcTan2,\r\n\r\n dfoNegate, dfoSqr, dfoSqrt,\r\n dfoLeft, dfoRight,\r\n // windows api\r\n dfoShellExecute,\r\n // date and time\r\n dfoNow, dfoTime, dfoDateStr, dfoTimeStr\r\n );\r\n\r\n TProcVar = procedure of object;\r\n\r\n TOnGetVariable = procedure(Sender: TObject; Symbol: string; var Value: Variant;\r\n var Handled: Boolean; var ErrorStr: string) of object;\r\n TOnSetVariable = procedure(Sender: TObject; Symbol: string; Value: Variant;\r\n var Handled: Boolean; var ErrorStr: string) of object;\r\n TOnGetSystem = procedure(Sender: TObject; Symbol, Prompt: string; var Value: Variant;\r\n var Handled: Boolean; var ErrorStr: string) of object;\r\n TOnSetSystem = procedure(Sender: TObject; Symbol: string; Value: Variant;\r\n var Handled: Boolean; var ErrorStr: string) of object;\r\n TOnInclude = procedure(Sender: TObject; IncludeFile: string; var Value: string;\r\n var Handled: Boolean; var ErrorStr: string) of object;\r\n\r\n TJvJanDSO = class(TStringList)\r\n private\r\n function InternalGetValue(Index: Integer; const AField: string): string;\r\n procedure InternalSetValue(Index: Integer; const AField, AValue: string);\r\n public\r\n // when a key is not found it will be added\r\n procedure SetValue(AKey: Variant; const AField, AValue: string);\r\n function GetValue(AKey: Variant; const AField: string): string;\r\n end;\r\n\r\n TJvJanDSOList = class(TStringList)\r\n public\r\n destructor Destroy; override;\r\n procedure ClearTables;\r\n function Table(const AName: string): TJvJanDSO;\r\n end;\r\n\r\n TJvJanXMLList = class(TStringList)\r\n public\r\n destructor Destroy; override;\r\n procedure ClearXMLS;\r\n function Xml(const AName: string): TJvXMLTree;\r\n end;\r\n\r\n TVariantObject = class(TObject)\r\n private\r\n FValue: Variant;\r\n procedure SetValue(const Value: Variant);\r\n public\r\n property Value: Variant read FValue write SetValue;\r\n end;\r\n\r\n TVariantList = class(TStringList)\r\n public\r\n destructor Destroy; override;\r\n procedure ClearObjects;\r\n procedure SetVariable(const Symbol: string; AValue: Variant);\r\n function GetVariable(const Symbol: string): Variant;\r\n function GetObject(const Symbol: string): TVariantObject; reintroduce;\r\n end;\r\n\r\n TAtom = class(TObject)\r\n private\r\n FToken: TToken;\r\n FSymbol: string;\r\n FValue: Variant;\r\n FProc: TProcVar;\r\n FIsOperand: Boolean;\r\n procedure SetToken(const Value: TToken);\r\n procedure SetSymbol(const Value: string);\r\n procedure SetValue(const Value: Variant);\r\n procedure SetProc(const Value: TProcVar);\r\n procedure SetIsOperand(const Value: Boolean);\r\n public\r\n property Token: TToken read FToken write SetToken;\r\n property Proc: TProcVar read FProc write SetProc;\r\n property Symbol: string read FSymbol write SetSymbol;\r\n property Value: Variant read FValue write SetValue;\r\n property IsOperand: Boolean read FIsOperand write SetIsOperand;\r\n end;\r\n\r\n TAtomList = class(TList)\r\n public\r\n destructor Destroy; override;\r\n procedure ClearObjects;\r\n end;\r\n\r\n TRStack = array [0..StackMax] of Integer;\r\n TVStack = array [0..StackMax] of Variant;\r\n TPStack = array [0..StackMax] of TToken;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvForthScript = class(TJvComponent)\r\n private\r\n FScript: string;\r\n FIncludes: TStringList;\r\n FInDevice: string;\r\n FOutDevice: string;\r\n FSubsList: TStringList;\r\n FVarsList: TVariantList;\r\n FDSOList: TJvJanDSOList;\r\n FXMLList: TJvJanXMLList;\r\n FXMLSelect: TList;\r\n FXMLSelectRecord: Integer;\r\n FDSOBase: string; // root directory for DSO tables\r\n FAtoms: TAtomList;\r\n // FRStack if the return stack for loop, sub etc.\r\n FRStack: TRStack;\r\n FRSP: Integer;\r\n FVStack: TVStack;\r\n FVSP: Integer;\r\n // ostack: array[0..StackMax] of TToken;\r\n // osp: Integer;\r\n FPStack: TPStack;\r\n FPSP: Integer;\r\n FPC: Integer;\r\n FCurrentSymbol: string;\r\n FCurrentValue: Variant;\r\n FOnGetVariable: TOnGetVariable;\r\n FOnSetVariable: TOnSetVariable;\r\n FScriptTimeOut: Integer;\r\n FOnGetSystem: TOnGetSystem;\r\n FOnSetSystem: TOnSetSystem;\r\n FOnInclude: TOnInclude;\r\n // procedure ClearAtoms;\r\n procedure SetScript(const Value: string);\r\n procedure SetOnGetVariable(const Value: TOnGetVariable);\r\n procedure SetOnSetVariable(const Value: TOnSetVariable);\r\n // expresssion procedures\r\n\r\n // constants\r\n procedure ProcCrLf;\r\n // date and time\r\n procedure ProcNow;\r\n procedure ProcDateStr;\r\n procedure ProcTimeStr;\r\n // shell\r\n procedure ProcShellExecute;\r\n // xml variables\r\n procedure ProcXML;\r\n // data source variables\r\n procedure ProcDSO;\r\n procedure ProcSelDir;\r\n procedure ProcDSOBase;\r\n // external variables\r\n procedure ProcExtVar; // general dispatcher\r\n procedure ProcAssign;\r\n procedure ProcVariable;\r\n\r\n // internal variables\r\n procedure ProcIntVar; // general dispatcher\r\n procedure ProcVarGet;\r\n procedure ProcVarSet;\r\n procedure ProcVarInc;\r\n procedure ProcVarIncIndex;\r\n procedure ProcVarDec;\r\n procedure ProcVarDecTestZero;\r\n procedure ProcVarAdd;\r\n procedure ProcVarSub;\r\n procedure ProcVarMul;\r\n procedure ProcVarDiv;\r\n procedure ProcVarNeg;\r\n procedure ProcVarLoad;\r\n procedure ProcVarSave;\r\n // system io\r\n procedure ProcSystem; // general dispatcher\r\n procedure ProcSysGet;\r\n procedure ProcSysSet;\r\n // flow expressions\r\n procedure ProcIf;\r\n procedure ProcElse;\r\n procedure ProcEndif;\r\n procedure ProcUntil;\r\n procedure ProcRepeat;\r\n // end flow expressions\r\n\r\n // sub expressions\r\n procedure ProcSub;\r\n procedure ProcEndsub;\r\n procedure ProcCall;\r\n // conversion expressions\r\n procedure ProcCStr;\r\n procedure ProcNop;\r\n procedure ProcDup;\r\n procedure ProcDrop;\r\n procedure ProcSwap;\r\n procedure ProcInteger;\r\n procedure ProcFloat;\r\n procedure ProcSet;\r\n procedure ProcString;\r\n procedure ProcBoolean;\r\n procedure ProcDate;\r\n procedure ProcEq;\r\n procedure ProcNe;\r\n procedure ProcGt;\r\n procedure ProcLt;\r\n procedure ProcGe;\r\n procedure ProcLe;\r\n procedure ProcLike;\r\n procedure ProcUnlike;\r\n procedure ProcNot;\r\n procedure ProcAnd;\r\n procedure ProcXor;\r\n procedure ProcOr;\r\n procedure ProcIn;\r\n procedure ProcAdd;\r\n procedure ProcSubtract;\r\n procedure ProcMultiply;\r\n procedure ProcDivide;\r\n procedure ProcPower;\r\n procedure ProcAbs;\r\n // some gonio functions\r\n procedure Procpi;\r\n procedure ProcSin;\r\n procedure ProcCos;\r\n procedure ProcTan;\r\n procedure ProcArcSin;\r\n procedure ProcArcCos;\r\n procedure ProcArcTan;\r\n procedure ProcArcTan2;\r\n\r\n procedure ProcNegate;\r\n procedure ProcSqr;\r\n procedure ProcSqrt;\r\n procedure ProcLeft;\r\n procedure ProcRight;\r\n function VPop: Variant;\r\n procedure VPush(AValue: Variant);\r\n// function opop: TToken;\r\n// procedure opush(AValue: TToken);\r\n// function ppop: TToken;\r\n// procedure ppush(AValue: TToken);\r\n function RPop: Integer;\r\n procedure RPush(AValue: Integer);\r\n procedure DoProc;\r\n procedure DoToken(AToken: TToken);\r\n procedure SetScriptTimeOut(const Value: Integer);\r\n procedure ParseScript;\r\n procedure SetOnGetSystem(const Value: TOnGetSystem);\r\n procedure SetOnSetSystem(const Value: TOnSetSystem);\r\n procedure SetOnInclude(const Value: TOnInclude);\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n function Execute: Variant;\r\n function PopValue: Variant;\r\n function CanPopValue: Boolean;\r\n procedure PushValue(AValue: Variant);\r\n function CanPushValue: Boolean;\r\n published\r\n property Script: string read FScript write SetScript;\r\n property ScriptTimeOut: Integer read FScriptTimeOut write SetScriptTimeOut;\r\n property OnGetVariable: TOnGetVariable read FOnGetVariable write SetOnGetVariable;\r\n property OnSetVariable: TOnSetVariable read FOnSetVariable write SetOnSetVariable;\r\n property OnSetSystem: TOnSetSystem read FOnSetSystem write SetOnSetSystem;\r\n property OnGetSystem: TOnGetSystem read FOnGetSystem write SetOnGetSystem;\r\n property OnInclude: TOnInclude read FOnInclude write SetOnInclude;\r\n end;\r\n\r\n// runs an external file or progam\r\nprocedure Launch(const AFile: string);\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvForth.pas $';\r\n Revision: '$Revision: 13104 $';\r\n Date: '$Date: 2011-09-07 08:50:43 +0200 (mer. 07 sept. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n Math,\r\n JvConsts, JvResources;\r\n\r\n{ some utility functions }\r\n\r\nprocedure Launch(const AFile: string);\r\nvar\r\n Command, Params, WorkDir: string;\r\nbegin\r\n Command := AFile;\r\n Params := #0;\r\n WorkDir := #0;\r\n ShellExecute(Application.Handle, 'open', PChar(Command),\r\n PChar(Params), PChar(WorkDir), SW_SHOWNORMAL);\r\nend;\r\n\r\nprocedure GlobalSetValue(var AText: string; const AName, AValue: string);\r\nvar\r\n P, P2, L: Integer;\r\nbegin\r\n L := Length(AName) + 2;\r\n if AText = '' then\r\n begin\r\n AText := AName + '=\"' + AValue + '\"';\r\n end\r\n else\r\n begin\r\n P := PosText(AName + '=\"', AText);\r\n if P = 0 then\r\n AText := AText + ' ' + AName + '=\"' + AValue + '\"'\r\n else\r\n begin\r\n P2 := PosStr('\"', AText, P + L);\r\n if P2 = 0 then\r\n Exit;\r\n Delete(AText, P + L, P2 - (P + L));\r\n Insert(AValue, AText, P + L);\r\n end;\r\n end;\r\nend;\r\n\r\nfunction GlobalGetValue(const AText, AName: string): string;\r\nvar\r\n P, P2, L: Integer;\r\nbegin\r\n Result := '';\r\n L := Length(AName) + 2;\r\n P := PosText(AName + '=\"', AText);\r\n if P = 0 then\r\n Exit;\r\n P2 := PosStr('\"', AText, P + L);\r\n if P2 = 0 then\r\n Exit;\r\n Result := Copy(AText, P + L, P2 - (P + L));\r\n Result := StringReplace(Result, '~~', sLineBreak, [rfReplaceAll]);\r\nend;\r\n\r\n// some special expression functions\r\n\r\n// returns the Index of Integer v in aList\r\n\r\nfunction IndexOfInteger(AList: TStringList; Value: Variant): Integer;\r\nvar\r\n C, I, Index, P: Integer;\r\n S, S1, S2: string;\r\nbegin\r\n Result := -1;\r\n I := Value;\r\n C := AList.Count;\r\n if C = 0 then\r\n Exit;\r\n for Index := 0 to C - 1 do\r\n begin\r\n try\r\n S := AList[Index];\r\n P := Pos('..', S);\r\n if P = 0 then\r\n begin\r\n if StrToInt(AList[Index]) = I then\r\n begin\r\n Result := Index;\r\n Exit;\r\n end;\r\n end\r\n else\r\n begin // have range\r\n S1 := Trim(Copy(S, 1, P - 1));\r\n S2 := Trim(Copy(S, P + 2, Length(S)));\r\n if (I >= StrToInt(S1)) and (I <= StrToInt(S2)) then\r\n begin\r\n Result := Index;\r\n Exit;\r\n end;\r\n end;\r\n except\r\n Exit;\r\n end;\r\n end;\r\nend;\r\n\r\n// returns the Index of float Value (single or double) in AList\r\n\r\nfunction IndexOfFloat(AList: TStringList; Value: Variant): Integer;\r\nvar\r\n C, Index, P: Integer;\r\n F: Extended;\r\n S, S1, S2: string;\r\nbegin\r\n Result := -1;\r\n F := Value;\r\n C := AList.Count;\r\n if C = 0 then\r\n Exit;\r\n for Index := 0 to C - 1 do\r\n begin\r\n try\r\n S := AList[Index];\r\n P := Pos('..', S);\r\n if P = 0 then\r\n begin\r\n if StrToFloat(S) = F then\r\n begin\r\n Result := Index;\r\n Exit;\r\n end;\r\n end\r\n else\r\n begin // have range\r\n S1 := Trim(Copy(S, 1, P - 1));\r\n S2 := Trim(Copy(S, P + 2, Length(S)));\r\n if (F >= StrToFloat(S1)) and (F <= StrToFloat(S2)) then\r\n begin\r\n Result := Index;\r\n Exit;\r\n end;\r\n end;\r\n except\r\n raise EJvJanScriptError.CreateResFmt(@RsEInvalidNumbers, [S]);\r\n end;\r\n end;\r\nend;\r\n\r\n// returns the Index of date Value in AList\r\n\r\nfunction IndexOfDate(AList: TStringList; Value: Variant): Integer;\r\nvar\r\n C, Index, P: Integer;\r\n D: TDateTime;\r\n S, S1, S2: string;\r\nbegin\r\n Result := -1;\r\n D := Value;\r\n C := AList.Count;\r\n if C = 0 then\r\n Exit;\r\n for Index := 0 to C - 1 do\r\n begin\r\n try\r\n S := AList[Index];\r\n P := Pos('..', S);\r\n if P = 0 then\r\n begin\r\n if StrToDate(AList[Index]) = D then\r\n begin\r\n Result := Index;\r\n Exit;\r\n end;\r\n end\r\n else\r\n begin\r\n S1 := Trim(Copy(S, 1, P - 1));\r\n S2 := Trim(Copy(S, P + 2, Length(S)));\r\n if (D >= StrToDate(S1)) and (D <= StrToDate(S2)) then\r\n begin\r\n Result := Index;\r\n Exit;\r\n end;\r\n end;\r\n except\r\n Exit;\r\n end;\r\n end;\r\nend;\r\n\r\n// returns the Index of string Value in AList\r\n\r\nfunction IndexOfString(AList: TStringList; Value: Variant): Integer;\r\nvar\r\n C, Index, P: Integer;\r\n SV: string;\r\n S, S1, S2: string;\r\nbegin\r\n Result := -1;\r\n SV := Value;\r\n C := AList.Count;\r\n if C = 0 then\r\n Exit;\r\n for Index := 0 to C - 1 do\r\n begin\r\n try\r\n S := AList[Index];\r\n P := Pos('..', S);\r\n if P = 0 then\r\n begin\r\n if AList[Index] = SV then\r\n begin\r\n Result := Index;\r\n Exit;\r\n end;\r\n end\r\n else\r\n begin\r\n S1 := Trim(Copy(S, 1, P - 1));\r\n S2 := Trim(Copy(S, P + 2, Length(S)));\r\n if (SV >= S1) and (SV <= S2) then\r\n begin\r\n Result := Index;\r\n Exit;\r\n end;\r\n end;\r\n except\r\n Exit;\r\n end;\r\n end;\r\nend;\r\n\r\n// used by dfoIN\r\n// tests if AValue is in ASet\r\n\r\nfunction FuncIn(AValue: Variant; ASet: Variant): Boolean;\r\nvar\r\n List: TStringList;\r\n S: string;\r\n P: Integer;\r\n Token: string;\r\n\r\n function GetToken: Boolean;\r\n begin\r\n Result := False;\r\n S := TrimLeft(S);\r\n if S = '' then\r\n Exit;\r\n P := 1;\r\n if S[1] = '\"' then\r\n begin // get string\r\n P := PosStr('\"', S, 2);\r\n if P = 0 then\r\n raise EJvJanScriptError.CreateResFmt(@RsEUnterminatedStringNears, [S]);\r\n Token := Copy(S, 2, P - 2);\r\n Delete(S, 1, P);\r\n Result := True;\r\n end\r\n else\r\n begin\r\n P := Pos(' ', S);\r\n if P = 0 then\r\n begin\r\n Token := S;\r\n Result := True;\r\n S := '';\r\n end\r\n else\r\n begin\r\n Token := Copy(S, 1, P - 1);\r\n Delete(S, 1, P);\r\n Result := True;\r\n end;\r\n end\r\n end;\r\n\r\nbegin\r\n Result := False;\r\n S := ASet;\r\n if S = '' then\r\n Exit;\r\n List := TStringList.Create;\r\n try\r\n while GetToken do\r\n List.Append(Token);\r\n // c:=List.Count;\r\n case VarType(AValue) of\r\n varString:\r\n Result := IndexOfString(List, AValue) > -1;\r\n varInteger, varByte:\r\n Result := IndexOfInteger(List, AValue) > -1;\r\n varSingle, varDouble:\r\n Result := IndexOfFloat(List, AValue) > -1;\r\n varDate:\r\n Result := IndexOfDate(List, AValue) > -1;\r\n else\r\n raise EJvJanScriptError.CreateRes(@RsEUnrecognizedDataTypeInSetOperation);\r\n end;\r\n finally\r\n List.Free;\r\n end;\r\nend;\r\n\r\n//=== { TJvForthScript } =====================================================\r\n\r\nconstructor TJvForthScript.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FAtoms := TAtomList.Create;\r\n FIncludes := TStringList.Create;\r\n FSubsList := TStringList.Create;\r\n FVarsList := TVariantList.Create;\r\n FDSOList := TJvJanDSOList.Create;\r\n FXMLList := TJvJanXMLList.Create;\r\n FXMLSelect := TList.Create;\r\n FDSOBase := ExtractFilePath(ParamStr(0));\r\n if FDSOBase[Length(FDSOBase)] = PathDelim then\r\n Delete(FDSOBase, Length(FDSOBase), 1);\r\n FVSP := 0;\r\n // osp := 0;\r\n FRSP := 0;\r\n FInDevice := 'dialog';\r\n FOutDevice := 'dialog';\r\n FScriptTimeOut := 30; // seconds\r\nend;\r\n\r\ndestructor TJvForthScript.Destroy;\r\nbegin\r\n FAtoms.Free;\r\n FIncludes.Free;\r\n FSubsList.Free;\r\n FVarsList.Free;\r\n FDSOList.Free;\r\n FXMLList.Free;\r\n FXMLSelect.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvForthScript.VPush(AValue: Variant);\r\nbegin\r\n //FVStack.push(AValue);\r\n FVStack[FVSP] := AValue;\r\n if FVSP < StackMax then\r\n Inc(FVSP)\r\n else\r\n raise EJvJanScriptError.CreateRes(@RsEStackOverflow);\r\nend;\r\n\r\n(*\r\nprocedure TJvForthScript.opush(AValue: TToken);\r\nbegin\r\n ostack[osp] := AValue;\r\n if osp < StackMax then\r\n Inc(osp);\r\nend;\r\n*)\r\n(*\r\nfunction TJvForthScript.opop: TToken;\r\nbegin\r\n showmessage('opop');\r\n if osp <= 0 then\r\n Result := dfonop\r\n else\r\n begin\r\n Dec(osp);\r\n Result := ostack[osp];\r\n end;\r\nend;\r\n*)\r\n(*\r\nprocedure TJvForthScript.ppush(AValue: TToken);\r\nbegin\r\n FPStack[FPSP] := AValue;\r\n if FPSP < StackMax then\r\n Inc(FPSP);\r\nend;\r\n*)\r\n(*\r\nfunction TJvForthScript.ppop: TToken;\r\nbegin\r\n if FPSP = 0 then\r\n Result := dfoError\r\n else\r\n begin\r\n Dec(FPSP);\r\n Result := FPStack[FPSP];\r\n end;\r\nend;\r\n*)\r\nfunction TJvForthScript.VPop: Variant;\r\nbegin\r\n if FVSP = 0 then\r\n raise EJvJanScriptError.CreateRes(@RsEStackUnderflow)\r\n else\r\n begin\r\n Dec(FVSP);\r\n Result := FVStack[FVSP];\r\n end;\r\nend;\r\n\r\nprocedure TJvForthScript.SetScript(const Value: string);\r\nbegin\r\n if Value <> FScript then\r\n begin\r\n FScript := Value;\r\n ParseScript;\r\n end;\r\nend;\r\n\r\nprocedure TJvForthScript.ParseScript;\r\nvar\r\n S: string;\r\n I, P, P2: Integer;\r\n Atom: TAtom;\r\n // atomoperation: TToken;\r\n AtomSymbol: string;\r\n AtomValue: Variant;\r\n // atomproc: TProcVar;\r\n Token: string;\r\n VInteger: Integer;\r\n VFloat: Double;\r\n VDate: TDateTime;\r\n // handling of includes:\r\n IncFile: string;\r\n Handled: Boolean;\r\n IncScript: string;\r\n ErrStr: string;\r\n TimeOutTicks: Cardinal;\r\n DeltaTicks: Cardinal;\r\n\r\n function PushAtom(AToken: TToken): Integer;\r\n // var cc: Integer;\r\n begin\r\n Atom := TAtom.Create;\r\n Atom.Token := AToken;\r\n Atom.Symbol := AtomSymbol;\r\n Atom.Value := AtomValue;\r\n Result := FAtoms.Add(Atom);\r\n end;\r\n\r\n procedure OPush(AToken: TToken);\r\n // var cc: Integer;\r\n begin\r\n Atom := TAtom.Create;\r\n Atom.Token := AToken;\r\n Atom.Symbol := Token;\r\n Atom.Value := AtomValue;\r\n FAtoms.Add(Atom);\r\n end;\r\n\r\n procedure BrcPush(Proc: TProcVar);\r\n // var cc: Integer;\r\n begin\r\n Atom := TAtom.Create;\r\n Atom.Proc := Proc;\r\n Atom.Symbol := AtomSymbol;\r\n Atom.Value := AtomValue;\r\n Atom.IsOperand := False;\r\n FAtoms.Add(Atom);\r\n end;\r\n\r\n function GetToken: Boolean;\r\n begin\r\n Result := False;\r\n S :=TrimLeft(S);\r\n if S = '' then\r\n Exit;\r\n P := 1;\r\n if S[1] = '\"' then\r\n begin // get string\r\n P := PosStr('\"', S, 2);\r\n if P = 0 then\r\n raise EJvJanScriptError.CreateResFmt(@RsEUnterminatedStringNears, [S]);\r\n Token := Copy(S, 1, P);\r\n Delete(S, 1, P);\r\n Result := True;\r\n end\r\n else\r\n if S[1] = '[' then\r\n begin // get block\r\n P := PosStr(']', S, 2);\r\n if P = 0 then\r\n raise EJvJanScriptError.CreateResFmt(@RsEUnterminatedBlockNear, [S]);\r\n Token := Copy(S, 1, P);\r\n Delete(S, 1, P);\r\n Result := True;\r\n end\r\n else\r\n begin\r\n P := Pos(' ', S);\r\n if P = 0 then\r\n begin\r\n Token := S;\r\n Result := True;\r\n S := '';\r\n end\r\n else\r\n begin\r\n Token := Copy(S, 1, P - 1);\r\n Delete(S, 1, P);\r\n Result := True;\r\n end;\r\n end;\r\n end;\r\n\r\nbegin\r\n FAtoms.ClearObjects;\r\n FSubsList.Clear;\r\n // reset return stack; needed in resolving flow statements\r\n FRSP := 0;\r\n S := FScript;\r\n // include any include files, include files start with $$ and end with ;\r\n // when the parser detects and include file it will raise the oninclude event\r\n // include files can also include files (nested includes)\r\n DeltaTicks := FScriptTimeOut * 1000;\r\n TimeOutTicks := GetTickCount + DeltaTicks;\r\n FIncludes.Clear; // Clear the includes List\r\n repeat\r\n if GetTickCount > TimeOutTicks then\r\n raise EJvJanScriptError.CreateResFmt(@RsEParserTimedOutAfterdSecondsYouMayHa, [FScriptTimeout]);\r\n P := PosStr('$$', S);\r\n if P > 0 then\r\n begin\r\n P2 := PosStr(';', S, P);\r\n if P2 = 0 then\r\n raise EJvJanScriptError.CreateResFmt(@RsEUnterminatedIncludeNears, [Copy(S, P, Length(S))]);\r\n IncFile := Copy(S, P + 2, P2 - P - 2) + '.jan';\r\n if PosStr(' ', IncFile, 1) > 0 then\r\n raise EJvJanScriptError.CreateResFmt(@RsEIllegalSpaceCharacterInTheIncludeFi, [IncFile]);\r\n I := FIncludes.IndexOf(IncFile);\r\n if I <> -1 then\r\n Delete(S, P, P2 - P + 1)\r\n else\r\n begin\r\n ErrStr := Format(RsECanNotFindIncludeFiles, [IncFile]);\r\n Handled := False;\r\n IncScript := '';\r\n if not Assigned(OnInclude) then\r\n raise EJvJanScriptError.CreateResFmt(@RsEOnIncludeHandlerNotAssignedCanNotHa, [Copy(S, P, Length(S))]);\r\n OnInclude(Self, IncFile, IncScript, Handled, ErrStr);\r\n if not Handled then\r\n raise EJvJanScriptError.Create(ErrStr);\r\n Delete(S, P, P2 - P + 1);\r\n Insert(IncScript, S, P);\r\n FIncludes.Append(IncFile);\r\n end;\r\n end;\r\n until P = 0;\r\n S := Trim(StringReplace(S, sLineBreak, ' ', [rfReplaceAll]));\r\n // remove comments\r\n repeat\r\n P := Pos('{', S);\r\n if P > 0 then\r\n begin\r\n P2 := PosStr('}', S, P);\r\n if P2 = 0 then\r\n raise EJvJanScriptError.CreateResFmt(@RsEMissingCommentTerminatorNears, [S]);\r\n Delete(S, P, P2 - P + 1);\r\n end;\r\n until P = 0;\r\n if S = '' then\r\n Exit;\r\n while GetToken do\r\n begin\r\n if Token = 'cstr' then\r\n OPush(dfoCstr)\r\n else\r\n if Token = 'seldir' then\r\n OPush(dfoSelDir)\r\n else\r\n if Token = 'dsobase' then\r\n OPush(dfoDSOBase)\r\n else\r\n if Token = 'dup' then\r\n OPush(dfoDup)\r\n else\r\n if Token = 'drop' then\r\n OPush(dfoDrop)\r\n else\r\n if Token = 'swap' then\r\n OPush(dfoSwap)\r\n else\r\n if Token = 'if' then\r\n begin\r\n P := PushAtom(dfoIf);\r\n RPush(P);\r\n end\r\n else\r\n if Token = 'endif' then\r\n begin\r\n P := PushAtom(dfoEndIf);\r\n P2 := RPop;\r\n Atom := TAtom(FAtoms[P2]);\r\n Atom.Value := P + 1;\r\n end\r\n else\r\n if Token = 'else' then\r\n begin\r\n P := PushAtom(dfoElse);\r\n P2 := RPop;\r\n RPush(P);\r\n Atom := TAtom(FAtoms[P2]);\r\n Atom.Value := P + 1;\r\n end\r\n else\r\n if Token = 'repeat' then\r\n begin\r\n P := PushAtom(dfoRepeat);\r\n RPush(P);\r\n end\r\n else\r\n if Token = 'until' then\r\n begin\r\n AtomValue := RPop;\r\n PushAtom(dfoUntil);\r\n end\r\n else\r\n if Token = 'now' then\r\n OPush(dfoNow)\r\n else\r\n if Token = 'datestr' then\r\n OPush(dfoDateStr)\r\n else\r\n if Token = 'timestr' then\r\n OPush(dfoTimeStr)\r\n else\r\n if Token = 'shellexecute' then\r\n OPush(dfoShellExecute)\r\n else\r\n if Token = ';' then\r\n OPush(dfoEndSub)\r\n else\r\n if Token = 'crlf' then\r\n OPush(dfoCrLf)\r\n else\r\n if Token = '--' then\r\n OPush(dfoNegate)\r\n else\r\n if Token = '-' then\r\n OPush(dfoSubtract)\r\n else\r\n if Token = '+' then\r\n OPush(dfoAdd)\r\n else\r\n if Token = '*' then\r\n OPush(dfoMultiply)\r\n else\r\n if Token = '/' then\r\n OPush(dfoDivide)\r\n else\r\n if Token = '^' then\r\n OPush(dfoPower)\r\n else\r\n if Token = 'abs' then\r\n OPush(dfoAbs)\r\n else\r\n if Token = 'left' then\r\n OPush(dfoLeft)\r\n else\r\n if Token = 'right' then\r\n OPush(dfoRight)\r\n else\r\n if Token = 'sqr' then\r\n OPush(dfoSqr)\r\n else\r\n if Token = 'sqrt' then\r\n OPush(dfoSqrt)\r\n else\r\n if Token = 'sin' then\r\n OPush(dfoSin)\r\n else\r\n if Token = 'cos' then\r\n OPush(dfoCos)\r\n else\r\n if Token = 'tan' then\r\n OPush(dfoTan)\r\n else\r\n if Token = 'arcsin' then\r\n OPush(dfoArcSin)\r\n else\r\n if Token = 'arccos' then\r\n OPush(dfoArcCos)\r\n else\r\n if Token = 'arctan' then\r\n OPush(dfoArcTan)\r\n else\r\n if Token = 'arctan2' then\r\n OPush(dfoArcTan2)\r\n else\r\n if Token = 'pi' then\r\n OPush(dfoPi)\r\n else\r\n if Token = '<>' then\r\n OPush(dfoNe)\r\n else\r\n if Token = '>=' then\r\n OPush(dfoGe)\r\n else\r\n if Token = '>' then\r\n OPush(dfoGt)\r\n else\r\n if Token = '<=' then\r\n OPush(dfoLe)\r\n else\r\n if Token = '<' then\r\n OPush(dfoLt)\r\n else\r\n if Token = '=' then\r\n OPush(dfoEq)\r\n else\r\n if Token = 'or' then\r\n OPush(dfoOr)\r\n else\r\n if Token = 'and' then\r\n OPush(dfoAnd)\r\n else\r\n if Token = 'in' then\r\n OPush(dfoIn)\r\n else\r\n if Token = 'xor' then\r\n OPush(dfoXor)\r\n else\r\n if Token = 'not' then\r\n OPush(dfoNot)\r\n else\r\n if Token = 'like' then\r\n OPush(dfoLike)\r\n else\r\n if Token = 'unlike' then\r\n OPush(dfoUnlike)\r\n // check for block\r\n else\r\n if Token[1] = '[' then\r\n begin\r\n AtomSymbol := Token;\r\n AtomValue := Copy(Token, 2, Length(Token) - 2);\r\n PushAtom(dfoSet);\r\n end\r\n // check for sub\r\n else\r\n if Token[Length(Token)] = '=' then\r\n begin\r\n AtomSymbol := Copy(Token, 1, Length(Token) - 1);\r\n P := PushAtom(dfoSub);\r\n FSubsList.AddObject(AtomSymbol, TObject(P + 1));\r\n end\r\n // check for xml object\r\n else\r\n if (Token[1] = '?') and (Length(Token) > 1) then\r\n begin\r\n P := Pos('.', Token);\r\n if (P = 0) or (P < 3) or (P = Length(Token)) then\r\n raise EJvJanScriptError.CreateResFmt(@RsEMissingXmlMethodSpecifierNears, [S]);\r\n AtomSymbol := Copy(Token, 2, P - 2);\r\n AtomValue := Copy(Token, P + 1, Length(Token));\r\n PushAtom(dfoXML);\r\n end\r\n // check for data source object\r\n else\r\n if (Token[1] = '_') and (Length(Token) > 1) then\r\n begin\r\n P := Pos('.', Token);\r\n if (P = 0) or (P < 3) or (P = Length(Token)) then\r\n raise EJvJanScriptError.CreateResFmt(@RsEMissingDataSourceMethodSpecifierNea, [S]);\r\n AtomSymbol := Copy(Token, 2, P - 2);\r\n AtomValue := Copy(Token, P + 1, Length(Token));\r\n PushAtom(dfoDSO);\r\n end\r\n // system\r\n else\r\n if (Token[1] = ')') and (Length(Token) > 1) then\r\n begin\r\n P := Pos('.', Token);\r\n if (P = 0) or (P < 3) or (P = Length(Token)) then\r\n raise EJvJanScriptError.CreateResFmt(@RsEMissingSystemMethodSpecifierNears, [S]);\r\n AtomSymbol := Copy(Token, 2, P - 2);\r\n AtomValue := Copy(Token, P + 1, Length(Token));\r\n PushAtom(dfoSystem);\r\n end\r\n // external variable\r\n else\r\n if (Token[1] = '>') and (Length(Token) > 1) then\r\n begin\r\n P := Pos('.', Token);\r\n if (P = 0) or (P < 3) or (P = Length(Token)) then\r\n raise EJvJanScriptError.CreateResFmt(@RsEMissingExternalVariableMethodSpecif, [S]);\r\n AtomSymbol := Copy(Token, 2, P - 2);\r\n AtomValue := Copy(Token, P + 1, Length(Token));\r\n PushAtom(dfoExtVar);\r\n end\r\n // check for internal variable\r\n else\r\n if (Token[1] = ':') and (Length(Token) > 1) then\r\n begin\r\n P := Pos('.', Token);\r\n if (P = 0) or (P < 3) or (P = Length(Token)) then\r\n raise EJvJanScriptError.CreateResFmt(@RsEMissingInternalVariableMethodSpecif, [S]);\r\n AtomSymbol := Copy(Token, 2, P - 2);\r\n AtomValue := Copy(Token, P + 1, Length(Token));\r\n PushAtom(dfoIntVar);\r\n end\r\n // check for string\r\n else\r\n if Token[1] = '\"' then\r\n begin\r\n AtomSymbol := Token;\r\n AtomValue := Copy(Token, 2, Length(Token) - 2);\r\n PushAtom(dfoString);\r\n end\r\n // check Integer, float or date\r\n else\r\n begin\r\n try // Integer\r\n VInteger := StrToInt(Token);\r\n AtomSymbol := Token;\r\n AtomValue := VInteger;\r\n PushAtom(dfoInteger);\r\n except\r\n try // float\r\n VFloat := StrToFloat(Token);\r\n AtomSymbol := Token;\r\n AtomValue := VFloat;\r\n PushAtom(dfoFloat);\r\n except\r\n try // date\r\n VDate := StrToDate(Token);\r\n AtomSymbol := Token;\r\n AtomValue := VDate;\r\n PushAtom(dfoDate);\r\n except // must be call to sub\r\n AtomSymbol := Token;\r\n P := FSubsList.IndexOf(AtomSymbol);\r\n if P = -1 then\r\n raise EJvJanScriptError.CreateResFmt(@RsEUndefinedWordsNears, [AtomSymbol, S]);\r\n P := Integer(FsubsList.Objects[P]);\r\n AtomValue := P;\r\n PushAtom(dfoCall);\r\n end;\r\n end;\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvForthScript.DoToken(AToken: TToken);\r\nbegin\r\n case AToken of\r\n dfoNow:\r\n ProcNow;\r\n dfoDateStr:\r\n ProcDateStr;\r\n dfoTimeStr:\r\n ProcTimeStr;\r\n dfoShellExecute:\r\n ProcShellExecute;\r\n dfoCrLf:\r\n ProcCrLf;\r\n dfoCStr:\r\n ProcCStr;\r\n dfoXML:\r\n ProcXML;\r\n dfoDSO:\r\n ProcDSO;\r\n dfoSeldir:\r\n ProcSelDir;\r\n dfoDSOBase:\r\n ProcDSOBase;\r\n dfoIntVar:\r\n ProcIntVar;\r\n dfoExtVar:\r\n ProcExtVar;\r\n dfoSystem:\r\n ProcSystem;\r\n // dfoVarGet: ProcVarGet;\r\n // dfoVarset: ProcVarSet;\r\n // dfoSysGet: ProcSysGet;\r\n // dfoSysSet: ProcSysSet;\r\n dfoSub:\r\n ProcSub;\r\n dfoEndSub:\r\n ProcEndSub;\r\n dfoCall:\r\n ProcCall;\r\n dfoDrop:\r\n ProcDrop;\r\n dfoDup:\r\n ProcDup;\r\n dfoSwap:\r\n ProcSwap;\r\n dfoIf:\r\n ProcIf;\r\n dfoElse:\r\n ProcElse;\r\n dfoEndIf:\r\n ProcEndIf;\r\n dfoRepeat:\r\n ProcRepeat;\r\n dfoUntil:\r\n ProcUntil;\r\n dfoNop:\r\n ProcNop;\r\n // dfoAssign: ProcAssign;\r\n // dfoVariable: ProcVariable;\r\n dfoInteger:\r\n ProcInteger;\r\n dfoFloat:\r\n ProcFloat;\r\n dfoSet:\r\n ProcSet;\r\n dfoString:\r\n ProcString;\r\n dfoBoolean:\r\n ProcBoolean;\r\n dfoDate:\r\n ProcDate;\r\n dfoEq:\r\n ProcEq;\r\n dfoNe:\r\n ProcNe;\r\n dfoGt:\r\n ProcGt;\r\n dfoLt:\r\n ProcLt;\r\n dfoGe:\r\n ProcGe;\r\n dfoLe:\r\n ProcLe;\r\n dfoLike:\r\n ProcLike;\r\n dfoUnlike:\r\n ProcUnlike;\r\n dfoNot:\r\n ProcNot;\r\n dfoAnd:\r\n ProcAnd;\r\n dfoXor:\r\n ProcXor;\r\n dfoOr:\r\n ProcOr;\r\n dfoIn:\r\n ProcIn;\r\n dfoAdd:\r\n ProcAdd;\r\n dfoSubtract:\r\n ProcSubtract;\r\n dfoMultiply:\r\n ProcMultiply;\r\n dfoDivide:\r\n ProcDivide;\r\n dfoPower:\r\n ProcPower;\r\n dfoAbs:\r\n ProcAbs;\r\n dfoPi:\r\n ProcPi;\r\n dfoSin:\r\n ProcSin;\r\n dfoCos:\r\n ProcCos;\r\n dfoTan:\r\n ProcTan;\r\n dfoArcSin:\r\n ProcArcSin;\r\n dfoArcCos:\r\n ProcArcCos;\r\n dfoArcTan:\r\n ProcArcTan;\r\n dfoArcTan2:\r\n ProcArcTan2;\r\n dfoNegate:\r\n ProcNegate;\r\n dfoSqr:\r\n ProcSqr;\r\n dfoSqrt:\r\n ProcSqrt;\r\n dfoLeft:\r\n ProcLeft;\r\n dfoRight:\r\n ProcRight;\r\n end;\r\nend;\r\n\r\nfunction TJvForthScript.Execute: Variant;\r\nvar\r\n C: Integer;\r\n Atom: TAtom;\r\n Token: TToken;\r\n TimeOutTicks: Cardinal;\r\n DeltaTicks: Cardinal;\r\nbegin\r\n Result := Null;\r\n // osp := 0;\r\n FVSP := 0;\r\n FPSP := 0;\r\n FRSP := 0;\r\n C := FAtoms.Count;\r\n FVarsList.ClearObjects;\r\n FDSOList.ClearTables;\r\n FXMLList.ClearXMLS;\r\n FXMLSelect.Clear;\r\n FXMLSelectRecord := -1;\r\n if C = 0 then\r\n Exit;\r\n FPC := 0;\r\n DeltaTicks := FScriptTimeOut * 1000;\r\n TimeOutticks := GetTickCount + DeltaTicks;\r\n // evaluate all FAtoms\r\n while FPC < C do\r\n begin\r\n if GetTickCount > TimeOutTicks then\r\n raise EJvJanScriptError.CreateResFmt(@RsEScriptTimedOutAfterdSeconds, [FScriptTimeout]);\r\n Atom := TAtom(FAtoms[FPC]);\r\n Inc(FPC);\r\n FCurrentValue := Atom.Value;\r\n FCurrentSymbol := Atom.Symbol;\r\n Token := Atom.Token;\r\n case Token of\r\n dfoInteger..dfoDate:\r\n VPush(FCurrentValue);\r\n else\r\n DoToken(Token);\r\n end;\r\n end;\r\n if FVSP <= 0 then\r\n Result := Null\r\n else\r\n Result := VPop;\r\nend;\r\n\r\nprocedure TJvForthScript.SetOnGetVariable(const Value: TOnGetVariable);\r\nbegin\r\n FOnGetVariable := Value;\r\nend;\r\n\r\n(*)\r\nprocedure TJvForthScript.ClearAtoms;\r\nvar\r\n i, c: Integer;\r\nbegin\r\n c := FAtoms.Count;\r\n if c = 0 then\r\n Exit;\r\n for i := 0 to c - 1 do\r\n Tobject(FAtoms[i]).Free;\r\n FAtoms.Clear;\r\nend;\r\n(*)\r\n\r\nprocedure TJvForthScript.SetOnSetVariable(const Value: TOnSetVariable);\r\nbegin\r\n FOnSetVariable := Value;\r\nend;\r\n\r\nprocedure TJvForthScript.ProcAdd;\r\nvar\r\n Value: Variant;\r\nbegin\r\n Value := VPop;\r\n Value := VPop + Value;\r\n VPush(Value);\r\nend;\r\n\r\nprocedure TJvForthScript.ProcAnd;\r\nvar\r\n Value: Variant;\r\nbegin\r\n Value := VPop;\r\n VPush(VPop and Value);\r\nend;\r\n\r\nprocedure TJvForthScript.ProcAssign;\r\nvar\r\n Value: Variant;\r\n Handled: Boolean;\r\n Err: string;\r\nbegin\r\n Value := VPop;\r\n VPush(Value);\r\n Handled := False;\r\n Err := Format(RsECanNotAssignVariables, [FCurrentSymbol]);\r\n if Assigned(OnSetVariable) then\r\n begin\r\n OnSetVariable(Self, FCurrentSymbol, Value, Handled, Err);\r\n if not Handled then\r\n raise EJvJanScriptError.Create(Err);\r\n end;\r\nend;\r\n\r\nprocedure TJvForthScript.ProcBoolean;\r\nbegin\r\n VPush(FCurrentValue);\r\n DoProc;\r\nend;\r\n\r\nprocedure TJvForthScript.DoProc;\r\nvar\r\n Token: TToken;\r\nbegin\r\n if FPSP <= 0 then\r\n Exit;\r\n Dec(FPSP);\r\n Token := FPStack[FPSP];\r\n DoToken(Token);\r\nend;\r\n\r\nprocedure TJvForthScript.ProcCos;\r\nvar\r\n Value: Variant;\r\nbegin\r\n Value := VPop;\r\n VPush(Cos(Value));\r\nend;\r\n\r\nprocedure TJvForthScript.ProcDate;\r\nbegin\r\n VPush(FCurrentValue);\r\n DoProc;\r\nend;\r\n\r\nprocedure TJvForthScript.ProcDivide;\r\nvar\r\n Value: Variant;\r\nbegin\r\n Value := VPop;\r\n VPush(VPop / Value);\r\nend;\r\n\r\nprocedure TJvForthScript.ProcEq;\r\nvar\r\n Value: Variant;\r\nbegin\r\n Value := VPop;\r\n VPush(VPop = Value);\r\nend;\r\n\r\nprocedure TJvForthScript.ProcFloat;\r\nbegin\r\n VPush(FCurrentValue);\r\n DoProc;\r\nend;\r\n\r\nprocedure TJvForthScript.ProcGe;\r\nvar\r\n Value: Variant;\r\nbegin\r\n Value := VPop;\r\n VPush(VPop >= Value);\r\nend;\r\n\r\nprocedure TJvForthScript.ProcGt;\r\nvar\r\n Value: Variant;\r\nbegin\r\n Value := VPop;\r\n VPush(VPop > Value);\r\nend;\r\n\r\nprocedure TJvForthScript.ProcIn;\r\nvar\r\n Value: Variant;\r\nbegin\r\n Value := VPop;\r\n VPush(FuncIn(VPop, Value));\r\nend;\r\n\r\nprocedure TJvForthScript.ProcInteger;\r\nbegin\r\n VPush(FCurrentValue);\r\n DoProc;\r\nend;\r\n\r\nprocedure TJvForthScript.ProcLe;\r\nvar\r\n Value: Variant;\r\nbegin\r\n Value := VPop;\r\n VPush(VPop <= Value);\r\nend;\r\n\r\nprocedure TJvForthScript.ProcLeft;\r\nvar\r\n Value, V2: Variant;\r\n Vali: Integer;\r\n Vals: string;\r\nbegin\r\n Value := VPop;\r\n V2 := VPop;\r\n Vali := Value;\r\n Vals := V2;\r\n Value := Copy(Vals, 1, Vali);\r\n VPush(Value);\r\nend;\r\n\r\nprocedure TJvForthScript.ProcLike;\r\nvar\r\n Value: Variant;\r\nbegin\r\n Value := VarToStr(VPop);\r\n VPush(Pos(LowerCase(Value), LowerCase(VarToStr(VPop))) > 0);\r\nend;\r\n\r\nprocedure TJvForthScript.ProcLt;\r\nvar\r\n Value: Variant;\r\nbegin\r\n Value := VPop;\r\n VPush(VPop < Value);\r\nend;\r\n\r\nprocedure TJvForthScript.ProcMultiply;\r\nvar\r\n Value: Variant;\r\nbegin\r\n Value := VPop;\r\n Value := VPop * Value;\r\n VPush(Value);\r\nend;\r\n\r\nprocedure TJvForthScript.ProcNe;\r\nvar\r\n Value: Variant;\r\nbegin\r\n Value := VPop;\r\n VPush(VPop <> Value);\r\nend;\r\n\r\nprocedure TJvForthScript.ProcNegate;\r\nvar\r\n Value: Variant;\r\nbegin\r\n Value := VPop;\r\n VPush(0 - Value);\r\nend;\r\n\r\nprocedure TJvForthScript.ProcNop;\r\nbegin\r\n // just do nothing\r\nend;\r\n\r\nprocedure TJvForthScript.ProcNot;\r\nvar\r\n Value: Variant;\r\nbegin\r\n Value := VPop;\r\n VPush(not Value);\r\nend;\r\n\r\nprocedure TJvForthScript.ProcOr;\r\nvar\r\n Value: Variant;\r\nbegin\r\n Value := VPop;\r\n VPush(VPop or Value);\r\nend;\r\n\r\nprocedure TJvForthScript.ProcRight;\r\nvar\r\n Value, V2: Variant;\r\n Vali: Integer;\r\n Vals: string;\r\nbegin\r\n Value := VPop;\r\n V2 := VPop;\r\n Vali := Value;\r\n Vals := V2;\r\n if Vali <= Length(Vals) then\r\n Value := Copy(Vals, Length(Vals) - Vali + 1, Vali)\r\n else\r\n Value := Vals;\r\n VPush(Value);\r\nend;\r\n\r\nprocedure TJvForthScript.ProcSet;\r\nbegin\r\n VPush(FCurrentValue);\r\n DoProc;\r\nend;\r\n\r\nprocedure TJvForthScript.ProcSin;\r\nvar\r\n Value: Variant;\r\nbegin\r\n Value := VPop;\r\n VPush(Sin(Value));\r\nend;\r\n\r\nprocedure TJvForthScript.ProcSqr;\r\nvar\r\n Value: Variant;\r\nbegin\r\n Value := VPop;\r\n VPush(Sqr(Value));\r\nend;\r\n\r\nprocedure TJvForthScript.ProcSqrt;\r\nvar\r\n Value: Variant;\r\nbegin\r\n Value := VPop;\r\n VPush(Sqrt(Value));\r\nend;\r\n\r\nprocedure TJvForthScript.ProcString;\r\nbegin\r\n VPush(FCurrentValue);\r\n DoProc;\r\nend;\r\n\r\nprocedure TJvForthScript.ProcSubtract;\r\nvar\r\n Value: Variant;\r\nbegin\r\n Value := VPop;\r\n VPush(VPop - Value);\r\nend;\r\n\r\nprocedure TJvForthScript.ProcUnlike;\r\nvar\r\n Value: Variant;\r\nbegin\r\n Value := VarToStr(VPop);\r\n VPush(Pos(LowerCase(Value), LowerCase(VarToStr(VPop))) = 0);\r\nend;\r\n\r\nprocedure TJvForthScript.ProcVariable;\r\nvar\r\n Value: Variant;\r\n Handled: Boolean;\r\n Err: string;\r\nbegin\r\n Handled := False;\r\n Err := Format(RsEVariablesNotDefined, [FCurrentSymbol]);\r\n if Assigned(FOnGetVariable) then\r\n FOnGetVariable(Self, FCurrentSymbol, Value, Handled, Err);\r\n if not Handled then\r\n raise EJvJanScriptError.Create(Err)\r\n else\r\n VPush(Value);\r\nend;\r\n\r\nprocedure TJvForthScript.ProcXor;\r\nvar\r\n Value: Variant;\r\nbegin\r\n Value := VPop;\r\n VPush(VPop xor Value);\r\nend;\r\n\r\nprocedure TJvForthScript.ProcIf;\r\nvar\r\n V: Variant;\r\nbegin\r\n V := VPop;\r\n if V then\r\n Exit\r\n else\r\n FPC := FCurrentValue;\r\nend;\r\n\r\nprocedure TJvForthScript.ProcElse;\r\nbegin\r\n FPC := FCurrentValue;\r\nend;\r\n\r\nprocedure TJvForthScript.ProcDrop;\r\nbegin\r\n VPop;\r\nend;\r\n\r\nprocedure TJvForthScript.ProcDup;\r\nvar\r\n V: Variant;\r\nbegin\r\n V := VPop;\r\n VPush(V);\r\n VPush(V);\r\nend;\r\n\r\nprocedure TJvForthScript.ProcSwap;\r\nvar\r\n V1, V2: Variant;\r\nbegin\r\n V1 := VPop;\r\n V2 := VPop;\r\n VPush(V1);\r\n VPush(V2);\r\nend;\r\n\r\n// just a marker\r\n\r\nprocedure TJvForthScript.ProcEndif;\r\nbegin\r\n // do nothing\r\nend;\r\n\r\n// keep looping until vpop=True\r\n\r\nprocedure TJvForthScript.ProcUntil;\r\nbegin\r\n if not VPop then\r\n FPC := FCurrentValue;\r\nend;\r\n\r\nprocedure TJvForthScript.ProcRepeat;\r\nbegin\r\n // do nothing\r\nend;\r\n\r\nfunction TJvForthScript.RPop: Integer;\r\nbegin\r\n if FRSP <= 0 then\r\n raise EJvJanScriptError.CreateRes(@RsEReturnStackUnderflow)\r\n else\r\n begin\r\n Dec(FRSP);\r\n Result := FRStack[FRSP];\r\n end;\r\nend;\r\n\r\nprocedure TJvForthScript.RPush(AValue: Integer);\r\nbegin\r\n FRStack[FRSP] := AValue;\r\n if FRSP < StackMax then\r\n Inc(FRSP)\r\n else\r\n raise EJvJanScriptError.CreateRes(@RsEReturnStackOverflow);\r\nend;\r\n\r\nprocedure TJvForthScript.SetScriptTimeOut(const Value: Integer);\r\nbegin\r\n FScriptTimeOut := Value;\r\nend;\r\n\r\nprocedure TJvForthScript.ProcEndsub;\r\nbegin\r\n FPC := RPop;\r\nend;\r\n\r\n// just skip till endSub\r\n\r\nprocedure TJvForthScript.ProcSub;\r\nvar\r\n C: Integer;\r\n Token: TToken;\r\nbegin\r\n { TODO -oJVCL -cPOSSIBLEBUG : (p3) What should \"c\" really be here? }\r\n C := FAtoms.Count; //??\r\n while FPC < C do\r\n begin\r\n Token := TAtom(FAtoms[FPC]).Token;\r\n if Token = dfoEndSub then\r\n begin\r\n Inc(FPC);\r\n Exit;\r\n end;\r\n Inc(FPC);\r\n end;\r\nend;\r\n\r\n// call to a user sub, just look it up\r\n\r\nprocedure TJvForthScript.ProcCall;\r\nvar\r\n Index: Integer;\r\nbegin\r\n // Index:=FSubsList.IndexOf(FCurrentSymbol);\r\n Index := FCurrentValue;\r\n if Index <> -1 then\r\n begin\r\n RPush(FPC);\r\n // FPC:=Integer(FsubsList.Objects[Index]);\r\n FPC := Index;\r\n Exit;\r\n end\r\n else\r\n raise EJvJanScriptError.CreateResFmt(@RsEProceduresNotDefined, [FCurrentSymbol]);\r\nend;\r\n\r\nprocedure TJvForthScript.ProcVarGet;\r\nvar\r\n V: Variant;\r\nbegin\r\n V := FVarsList.GetVariable(FCurrentSymbol);\r\n if V <> null then\r\n VPush(V)\r\n else\r\n raise EJvJanScriptError.CreateResFmt(@RsEVariablesNotDefined_, [FCurrentSymbol]);\r\nend;\r\n\r\nprocedure TJvForthScript.ProcVarSet;\r\nvar\r\n V: Variant;\r\nbegin\r\n V := VPop;\r\n FVarsList.SetVariable(FCurrentSymbol, V);\r\nend;\r\n\r\nprocedure TJvForthScript.ProcCStr;\r\nvar\r\n S: string;\r\nbegin\r\n S := VPop;\r\n VPush(S);\r\nend;\r\n\r\nprocedure TJvForthScript.ProcSysGet;\r\nvar\r\n Value: Variant;\r\n Handled: Boolean;\r\n Err, Prompt: string;\r\nbegin\r\n Prompt := VPop;\r\n Handled := False;\r\n Err := Format(RsESystemsNotDefined, [FCurrentSymbol]);\r\n if Assigned(OnGetSystem) then\r\n OnGetSystem(Self, FCurrentSymbol, Prompt, Value, Handled, Err);\r\n if not Handled then\r\n raise EJvJanScriptError.Create(Err)\r\n else\r\n VPush(Value);\r\nend;\r\n\r\nprocedure TJvForthScript.ProcSysSet;\r\nvar\r\n Value: Variant;\r\n Handled: Boolean;\r\n Err: string;\r\nbegin\r\n Value := VPop;\r\n VPush(Value);\r\n Handled := False;\r\n Err := Format(RsECanNotAssignSystems, [FCurrentSymbol]);\r\n if Assigned(FOnSetSystem) then\r\n begin\r\n FOnSetSystem(Self, FCurrentSymbol, Value, Handled, Err);\r\n if not Handled then\r\n raise EJvJanScriptError.Create(Err);\r\n end;\r\nend;\r\n\r\nprocedure TJvForthScript.SetOnGetSystem(const Value: TOnGetSystem);\r\nbegin\r\n FOnGetSystem := Value;\r\nend;\r\n\r\nprocedure TJvForthScript.SetOnSetSystem(const Value: TOnSetSystem);\r\nbegin\r\n FOnSetSystem := Value;\r\nend;\r\n\r\nfunction TJvForthScript.PopValue: Variant;\r\nbegin\r\n Result := VPop;\r\nend;\r\n\r\nprocedure TJvForthScript.PushValue(AValue: Variant);\r\nbegin\r\n VPush(AValue);\r\nend;\r\n\r\nfunction TJvForthScript.CanPopValue: Boolean;\r\nbegin\r\n Result := FVSP > 0;\r\nend;\r\n\r\nfunction TJvForthScript.CanPushValue: Boolean;\r\nbegin\r\n Result := FVSP < StackMax;\r\nend;\r\n\r\nprocedure TJvForthScript.ProcPi;\r\nbegin\r\n VPush(Pi);\r\nend;\r\n\r\nprocedure TJvForthScript.ProcDSO;\r\nvar\r\n AName, AMethod: string;\r\n Table: TJvJanDSO;\r\n AField, AValue: string;\r\n AKey: Variant;\r\n C: Integer;\r\nbegin\r\n AName := FCurrentSymbol;\r\n AMethod := FCurrentValue;\r\n Table := FDSOList.Table(AName);\r\n if AMethod = 'set' then\r\n begin\r\n AKey := VPop;\r\n AField := VPop;\r\n AValue := VPop;\r\n Table.SetValue(AKey, AField, AValue);\r\n end\r\n else\r\n if AMethod = 'get' then\r\n begin\r\n AKey := VPop;\r\n AField := VPop;\r\n AValue := Table.GetValue(AKey, AField);\r\n VPush(AValue);\r\n end\r\n else\r\n if AMethod = 'load' then\r\n Table.LoadFromFile(FDSOBase + PathDelim + AName + '.txt')\r\n else\r\n if AMethod = 'save' then\r\n Table.SaveToFile(FDSOBase + PathDelim + AName + '.txt')\r\n else\r\n if AMethod = 'Clear' then\r\n Table.Clear\r\n else\r\n if AMethod = 'Count' then\r\n begin\r\n C := Table.Count;\r\n VPush(C);\r\n end;\r\nend;\r\n\r\nprocedure TJvForthScript.ProcDSOBase;\r\nvar\r\n S: string;\r\nbegin\r\n S := VPop;\r\n FDSOBase := S;\r\nend;\r\n\r\nprocedure TJvForthScript.ProcSelDir;\r\n\r\nvar\r\n Dir: string;\r\nbegin\r\n Dir := FDSOBase;\r\n if SelectDirectory(Dir, [sdAllowCreate, sdPerformCreate, sdPrompt], 0) then\r\n FDSOBase := Dir;\r\nend;\r\n\r\n\r\n\r\nprocedure TJvForthScript.ProcExtVar;\r\nvar\r\n AName, AMethod: string;\r\nbegin\r\n AName := FCurrentSymbol;\r\n AMethod := FCurrentValue;\r\n if AMethod = 'set' then\r\n ProcAssign\r\n else\r\n if AMethod = 'get' then\r\n ProcVariable\r\n else\r\n raise EJvJanScriptError.CreateResFmt(@RsEUnrecognizedExternalVariableMethodss, [AName, AMethod]);\r\nend;\r\n\r\nprocedure TJvForthScript.ProcIntVar;\r\nvar\r\n AName, AMethod: string;\r\nbegin\r\n AName := FCurrentSymbol;\r\n AMethod := FCurrentValue;\r\n if AMethod = 'set' then\r\n ProcVarSet\r\n else\r\n if AMethod = 'get' then\r\n ProcVarGet\r\n else\r\n if AMethod = '1+' then\r\n ProcVarInc\r\n else\r\n if AMethod = '[1+]' then\r\n ProcVarIncIndex\r\n else\r\n if AMethod = '1-' then\r\n ProcVarDec\r\n else\r\n if AMethod = '1-?0' then\r\n ProcVarDecTestZero\r\n else\r\n if AMethod = '+' then\r\n ProcVarAdd\r\n else\r\n if AMethod = '-' then\r\n ProcVarSub\r\n else\r\n if AMethod = '*' then\r\n ProcVarMul\r\n else\r\n if AMethod = '/' then\r\n ProcVarDiv\r\n else\r\n if AMethod = '--' then\r\n ProcVarNeg\r\n else\r\n if AMethod = 'load' then\r\n ProcVarLoad\r\n else\r\n if AMethod = 'save' then\r\n ProcVarSave\r\n else\r\n raise EJvJanScriptError.CreateResFmt(@RsEUnrecognizedInternalVariableMethodss, [AName, AMethod]);\r\nend;\r\n\r\nprocedure TJvForthScript.ProcSystem;\r\nvar\r\n AName, AMethod: string;\r\nbegin\r\n AName := FCurrentSymbol;\r\n AMethod := FCurrentValue;\r\n if AMethod = 'set' then\r\n ProcSysSet\r\n else\r\n if AMethod = 'get' then\r\n ProcSysGet\r\n else\r\n raise EJvJanScriptError.CreateResFmt(@RsEUnrecognizedSystemMethodss, [AName, AMethod]);\r\nend;\r\n\r\nprocedure TJvForthScript.ProcVarDec;\r\nvar\r\n VO: TVariantObject;\r\nbegin\r\n VO := FVarsList.GetObject(FCurrentSymbol);\r\n if VO <> nil then\r\n VO.Value := VO.Value - 1\r\n else\r\n raise EJvJanScriptError.CreateResFmt(@RsEVariablesNotDefined_, [FCurrentSymbol]);\r\nend;\r\n\r\nprocedure TJvForthScript.ProcVarInc;\r\nvar\r\n VO: TVariantObject;\r\nbegin\r\n VO := FVarsList.GetObject(FCurrentSymbol);\r\n if VO <> nil then\r\n VO.Value := VO.Value + 1\r\n else\r\n raise EJvJanScriptError.CreateResFmt(@RsEVariablesNotDefined_, [FCurrentSymbol]);\r\nend;\r\n\r\nprocedure TJvForthScript.ProcVarAdd;\r\nvar\r\n VO: TVariantObject;\r\nbegin\r\n VO := FVarsList.GetObject(FCurrentSymbol);\r\n if VO <> nil then\r\n VO.Value := VO.Value + VPop\r\n else\r\n raise EJvJanScriptError.CreateResFmt(@RsEVariablesNotDefined_, [FCurrentSymbol]);\r\nend;\r\n\r\nprocedure TJvForthScript.ProcVarDiv;\r\nvar\r\n VO: TVariantObject;\r\nbegin\r\n VO := FVarsList.GetObject(FCurrentSymbol);\r\n if VO <> nil then\r\n VO.Value := VO.Value / VPop\r\n else\r\n raise EJvJanScriptError.CreateResFmt(@RsEVariablesNotDefined_, [FCurrentSymbol]);\r\nend;\r\n\r\nprocedure TJvForthScript.ProcVarMul;\r\nvar\r\n VO: TVariantObject;\r\nbegin\r\n VO := FVarsList.GetObject(FCurrentSymbol);\r\n if VO <> nil then\r\n VO.Value := VO.Value * VPop\r\n else\r\n raise EJvJanScriptError.CreateResFmt(@RsEVariablesNotDefined_, [FCurrentSymbol]);\r\nend;\r\n\r\nprocedure TJvForthScript.ProcVarSub;\r\nvar\r\n VO: TVariantObject;\r\nbegin\r\n VO := FVarsList.GetObject(FCurrentSymbol);\r\n if VO <> nil then\r\n VO.Value := VO.Value - VPop\r\n else\r\n raise EJvJanScriptError.CreateResFmt(@RsEVariablesNotDefined_, [FCurrentSymbol]);\r\nend;\r\n\r\nprocedure TJvForthScript.ProcVarNeg;\r\nvar\r\n VO: TVariantObject;\r\nbegin\r\n VO := FVarsList.GetObject(FCurrentSymbol);\r\n if VO <> nil then\r\n VO.Value := 0 - VO.Value\r\n else\r\n raise EJvJanScriptError.CreateResFmt(@RsEVariablesNotDefined_, [FCurrentSymbol]);\r\nend;\r\n\r\nprocedure TJvForthScript.ProcPower;\r\nvar\r\n Value: Variant;\r\nbegin\r\n Value := VPop;\r\n VPush(Power(VPop, Value));\r\nend;\r\n\r\nprocedure TJvForthScript.ProcAbs;\r\nvar\r\n Value: Variant;\r\nbegin\r\n Value := VPop;\r\n VPush(Abs(Value));\r\nend;\r\n\r\nprocedure TJvForthScript.SetOnInclude(const Value: TOnInclude);\r\nbegin\r\n FOnInclude := Value;\r\nend;\r\n\r\nprocedure TJvForthScript.ProcTan;\r\nvar\r\n Value: Variant;\r\nbegin\r\n Value := VPop;\r\n VPush(Tan(Value));\r\nend;\r\n\r\nprocedure TJvForthScript.ProcArcCos;\r\nvar\r\n Value: Variant;\r\nbegin\r\n Value := VPop;\r\n VPush(ArcCos(Value));\r\nend;\r\n\r\nprocedure TJvForthScript.ProcArcSin;\r\nvar\r\n Value: Variant;\r\nbegin\r\n Value := VPop;\r\n VPush(ArcSin(Value));\r\nend;\r\n\r\nprocedure TJvForthScript.ProcArcTan;\r\nvar\r\n Value: Variant;\r\nbegin\r\n Value := VPop;\r\n VPush(ArcTan(Value));\r\nend;\r\n\r\nprocedure TJvForthScript.ProcArcTan2;\r\nvar\r\n Value: Variant;\r\nbegin\r\n Value := VPop;\r\n VPush(ArcTan2(VPop, Value));\r\nend;\r\n\r\nprocedure TJvForthScript.ProcVarLoad;\r\nvar\r\n VO: TVariantObject;\r\n AP, FN, S: string;\r\nbegin\r\n FN := VPop;\r\n AP := ExtractFilePath(ParamStr(0));\r\n FN := StringReplace(FN, '%', AP, []);\r\n VO := FVarsList.GetObject(FCurrentSymbol);\r\n if VO <> nil then\r\n begin\r\n S := LoadString(FN);\r\n VO.Value := S;\r\n end\r\n else\r\n raise EJvJanScriptError.CreateResFmt(@RsEVariablesNotDefined_, [FCurrentSymbol]);\r\nend;\r\n\r\nprocedure TJvForthScript.ProcVarSave;\r\nvar\r\n VO: TVariantObject;\r\n AP, FN, S: string;\r\nbegin\r\n FN := VPop;\r\n AP := ExtractFilePath(ParamStr(0));\r\n FN := StringReplace(FN, '%', AP, []);\r\n VO := FVarsList.GetObject(FCurrentSymbol);\r\n if VO <> nil then\r\n begin\r\n S := VO.Value;\r\n SaveString(FN, S);\r\n end\r\n else\r\n raise EJvJanScriptError.CreateResFmt(@RsEVariablesNotDefined_, [FCurrentSymbol]);\r\nend;\r\n\r\nprocedure TJvForthScript.ProcXML;\r\nvar\r\n AName, AMethod: string;\r\n XmlDSO: TJvXMLTree;\r\n N: TJvXMLNode;\r\n A: TJvXMLAttribute;\r\n APath, AtName: string;\r\n AValue: Variant;\r\n C, I, C2: Integer;\r\n ApplDir: string;\r\n B: Boolean;\r\nbegin\r\n N := nil;\r\n ApplDir := ExtractFilePath(ParamStr(0));\r\n AName := FCurrentSymbol;\r\n AMethod := FCurrentValue;\r\n XmlDSO := FXMLList.Xml(AName);\r\n if AMethod = 'set' then\r\n begin\r\n APath := VPop;\r\n AValue := VPop;\r\n N := XmlDSO.ForceNamePathNode(APath);\r\n N.Value := AValue;\r\n end\r\n else\r\n if AMethod = '@set' then\r\n begin\r\n APath := VPop;\r\n AtName := VPop;\r\n AValue := VPop;\r\n XmlDSO.ForceNamePathNodeAttribute(APath, AtName, AValue);\r\n end\r\n else\r\n if AMethod = 'get' then\r\n begin\r\n APath := VPop;\r\n N := XmlDSO.GetNamePathNode(APath);\r\n if N = nil then\r\n AValue := ''\r\n else\r\n AValue := N.Value;\r\n VPush(AValue);\r\n end\r\n else\r\n if AMethod = 'Count' then\r\n begin\r\n APath := VPop;\r\n N := XmlDSO.GetNamePathNode(APath);\r\n AValue := 0;\r\n C2 := 0;\r\n if N <> nil then\r\n begin\r\n // now Count named node\r\n C := N.Nodes.Count;\r\n APath := VPop;\r\n if C > 0 then\r\n begin\r\n for I := 0 to C - 1 do\r\n if TJvXMLNode(N.Nodes[I]).Name = APath then\r\n Inc(C2);\r\n end;\r\n AValue := C2;\r\n end;\r\n VPush(AValue);\r\n end\r\n else\r\n if AMethod = '@get' then\r\n begin\r\n APath := VPop;\r\n AtName := VPop;\r\n A := XmlDSO.GetNamePathNodeAttribute(APath, AtName);\r\n if N = nil then\r\n AValue := ''\r\n else\r\n AValue := A.Value;\r\n VPush(AValue);\r\n end\r\n else\r\n if AMethod = 'load' then\r\n begin\r\n APath := VPop;\r\n APath := StringReplace(APath, '%', ApplDir, []);\r\n if not FileExists(APath) then\r\n raise EJvJanScriptError.CreateResFmt(@RsEFilesDoesNotExist, [APath]);\r\n XmlDSO.LoadFromFile(APath);\r\n end\r\n else\r\n if AMethod = 'save' then\r\n begin\r\n APath := VPop;\r\n APath := StringReplace(APath, '%', ApplDir, []);\r\n try\r\n XmlDSO.SaveToFile(APath);\r\n except\r\n raise EJvJanScriptError.CreateResFmt(@RsECanNotSaveToFiles, [APath]);\r\n end\r\n end\r\n else\r\n if AMethod = 'astext' then\r\n begin\r\n AValue := XmlDSO.AsText;\r\n VPush(AValue);\r\n end\r\n else\r\n if AMethod = 'Delete' then\r\n begin\r\n APath := VPop;\r\n XmlDSO.deleteNamePathNode(APath);\r\n end\r\n else\r\n if AMethod = '@Delete' then\r\n begin\r\n APath := VPop;\r\n AtName := VPop;\r\n XmlDSO.DeleteNamePathNodeAttribute(APath, AtName);\r\n end\r\n else\r\n if AMethod = 'select' then\r\n begin\r\n APath := VPop;\r\n APath := StringReplace(APath, '''', '\"', [rfReplaceAll]);\r\n FXMLSelect.Clear;\r\n FXMLSelectRecord := -1;\r\n XmlDSO.SelectNodes(APath, FXMLSelect);\r\n VPush(FXMLSelect.Count > 0);\r\n end\r\n else\r\n if AMethod = 'selectfirst' then\r\n begin\r\n B := FXMLSelect.Count <> 0;\r\n if B then\r\n FXMLSelectRecord := 0\r\n else\r\n FXMLSelectRecord := -1;\r\n AValue := B;\r\n VPush(AValue);\r\n end\r\n else\r\n if AMethod = 'selectnext' then\r\n begin\r\n B := FXMLSelect.Count <> 0;\r\n if B then\r\n Inc(FXMLSelectRecord)\r\n else\r\n FXMLSelectRecord := -1;\r\n if FXMLSelectRecord >= FXMLSelect.Count then\r\n begin\r\n B := False;\r\n FXMLSelectRecord := -1;\r\n end;\r\n AValue := B;\r\n VPush(AValue);\r\n end\r\n else\r\n if AMethod = 'selectget' then\r\n begin\r\n if FXMLSelect.Count = 0 then\r\n raise EJvJanScriptError.CreateRes(@RsEXMLSelectionIsEmpty);\r\n if FXMLSelectRecord = -1 then\r\n raise EJvJanScriptError.CreateRes(@RsENoXMLSelectionSelected);\r\n if FXMLSelectRecord >= FXMLSelect.Count then\r\n raise EJvJanScriptError.CreateRes(@RsEXMLSelectionOutOfRange);\r\n N := TJvXMLNode(FXMLSelect[FXMLSelectRecord]);\r\n AValue := N.Value;\r\n VPush(AValue);\r\n end\r\n else\r\n if AMethod = '@selectget' then\r\n begin\r\n if FXMLSelect.Count = 0 then\r\n raise EJvJanScriptError.CreateRes(@RsEXMLSelectionIsEmpty);\r\n if FXMLSelectRecord = -1 then\r\n raise EJvJanScriptError.CreateRes(@RsENoXMLSelectionSelected);\r\n if FXMLSelectRecord >= FXMLSelect.Count then\r\n raise EJvJanScriptError.CreateRes(@RsEXMLSelectionOutOfRange);\r\n N := TJvXMLNode(FXMLSelect[FXMLSelectRecord]);\r\n AtName := VPop;\r\n AValue := N.GetAttributeValue(AtName);\r\n VPush(AValue);\r\n end\r\n else\r\n raise EJvJanScriptError.CreateResFmt(@RsEInvalidXmlMethodSpecifiers, [AMethod]);\r\nend;\r\n\r\nprocedure TJvForthScript.ProcVarDecTestZero;\r\nvar\r\n V: Variant;\r\n VO: TVariantObject;\r\nbegin\r\n VO := FVarsList.GetObject(FCurrentSymbol);\r\n if VO <> nil then\r\n begin\r\n V := VO.Value - 1;\r\n VO.Value := V;\r\n VPush(V = 0);\r\n end\r\n else\r\n raise EJvJanScriptError.CreateResFmt(@RsEVariablesNotDefined_, [FCurrentSymbol]);\r\nend;\r\n\r\nprocedure TJvForthScript.ProcVarIncIndex;\r\nvar\r\n VO: TVariantObject;\r\n S, SIdx: string;\r\n PB, PE: Integer;\r\n Index: Integer;\r\nbegin\r\n VO := FVarsList.GetObject(FCurrentSymbol);\r\n if VO <> nil then\r\n begin\r\n S := VO.Value;\r\n PB := LastPosChar('[', S);\r\n if PB = 0 then\r\n raise EJvJanScriptError.CreateResFmt(@RsEIncrementIndexExpectedIns, [S]);\r\n PE := LastPosChar(']', S);\r\n if PE = 0 then\r\n raise EJvJanScriptError.CreateResFmt(@RsEIncrementIndexExpectedIns_, [S]);\r\n SIdx := Copy(S, PB + 1, PE - PB - 1);\r\n try\r\n Index := StrToInt(SIdx);\r\n Inc(Index);\r\n S := Copy(S, 1, PB - 1) + '[' + IntToStr(Index) + ']';\r\n VO.Value := S;\r\n VPush(S);\r\n except\r\n raise EJvJanScriptError.CreateResFmt(@RsEIncrementIndexExpectedIntegerBetwee, [S]);\r\n end;\r\n end\r\n else\r\n raise EJvJanScriptError.CreateResFmt(@RsEVariablesNotDefined_, [FCurrentSymbol]);\r\nend;\r\n\r\nprocedure TJvForthScript.ProcCrLf;\r\nbegin\r\n VPush(sLineBreak);\r\nend;\r\n\r\nprocedure TJvForthScript.ProcShellExecute;\r\nvar\r\n AFile: string;\r\n ApplDir: string;\r\nbegin\r\n ApplDir := ExtractFilePath(ParamStr(0));\r\n AFile := VPop;\r\n AFile := StringReplace(AFile, '%', ApplDir, []);\r\n Launch(AFile);\r\nend;\r\n\r\nprocedure TJvForthScript.ProcDateStr;\r\nvar\r\n S: string;\r\nbegin\r\n S := FormatDateTime('dd-mmm-yyyy', Now);\r\n VPush(S);\r\nend;\r\n\r\nprocedure TJvForthScript.ProcTimeStr;\r\nvar\r\n S: string;\r\nbegin\r\n S := FormatDateTime('hh:nn:ss', Now);\r\n VPush(S);\r\nend;\r\n\r\nprocedure TJvForthScript.ProcNow;\r\nbegin\r\n VPush(Now);\r\nend;\r\n\r\n//=== { TAtom } ==============================================================\r\n\r\nprocedure TAtom.SetIsOperand(const Value: Boolean);\r\nbegin\r\n FIsOperand := Value;\r\nend;\r\n\r\nprocedure TAtom.SetToken(const Value: TToken);\r\nbegin\r\n FToken := Value;\r\nend;\r\n\r\nprocedure TAtom.SetProc(const Value: TProcVar);\r\nbegin\r\n FProc := Value;\r\nend;\r\n\r\nprocedure TAtom.SetSymbol(const Value: string);\r\nbegin\r\n FSymbol := Value;\r\nend;\r\n\r\nprocedure TAtom.SetValue(const Value: Variant);\r\nbegin\r\n FValue := Value;\r\nend;\r\n\r\n//=== { TAtomList } ==========================================================\r\n\r\nprocedure TAtomList.ClearObjects;\r\nvar\r\n I, C: Integer;\r\nbegin\r\n C := Count;\r\n if C = 0 then\r\n Exit;\r\n for I := 0 to C - 1 do\r\n TAtom(Items[I]).Free;\r\n Clear;\r\nend;\r\n\r\ndestructor TAtomList.Destroy;\r\nbegin\r\n ClearObjects;\r\n inherited Destroy;\r\nend;\r\n\r\n//=== { TVariantObject } =====================================================\r\n\r\nprocedure TVariantObject.SetValue(const Value: Variant);\r\nbegin\r\n FValue := Value;\r\nend;\r\n\r\n//=== { TVariantList } =======================================================\r\n\r\nprocedure TVariantList.ClearObjects;\r\nvar\r\n I, C: Integer;\r\nbegin\r\n C := Count;\r\n if C = 0 then\r\n Exit;\r\n for I := 0 to C - 1 do\r\n TVariantObject(Objects[I]).Free;\r\n Clear;\r\nend;\r\n\r\ndestructor TVariantList.Destroy;\r\nbegin\r\n ClearObjects;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TVariantList.GetObject(const Symbol: string): TVariantObject;\r\nvar\r\n Index: Integer;\r\nbegin\r\n Result := nil;\r\n if Count = 0 then\r\n Exit;\r\n Index := IndexOf(Symbol);\r\n if Index = -1 then\r\n Exit;\r\n Result := TVariantObject(Objects[Index]);\r\nend;\r\n\r\nfunction TVariantList.GetVariable(const Symbol: string): Variant;\r\nvar\r\n Index: Integer;\r\nbegin\r\n Result := null;\r\n if Count = 0 then\r\n Exit;\r\n Index := IndexOf(Symbol);\r\n if Index = -1 then\r\n Exit;\r\n Result := TVariantObject(Objects[Index]).Value;\r\nend;\r\n\r\nprocedure TVariantList.SetVariable(const Symbol: string; AValue: Variant);\r\nvar\r\n Index: Integer;\r\n Obj: TVariantObject;\r\nbegin\r\n Index := IndexOf(Symbol);\r\n if Index = -1 then\r\n begin\r\n Obj := TVariantObject.Create;\r\n Obj.Value := AValue;\r\n AddObject(Symbol, Obj);\r\n end\r\n else\r\n begin\r\n TVariantObject(Objects[Index]).Value := AValue;\r\n end;\r\nend;\r\n\r\n//=== { TJvJanDSOList } ======================================================\r\n\r\nprocedure TJvJanDSOList.ClearTables;\r\nvar\r\n I, C: Integer;\r\nbegin\r\n C := Count;\r\n if C <> 0 then\r\n for I := 0 to C - 1 do\r\n TJvJanDSO(Objects[I]).Free;\r\n Clear;\r\nend;\r\n\r\ndestructor TJvJanDSOList.Destroy;\r\nbegin\r\n ClearTables;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJvJanDSOList.Table(const AName: string): TJvJanDSO;\r\nvar\r\n Index: Integer;\r\n DSO: TJvJanDSO;\r\nbegin\r\n Index := IndexOf(AName);\r\n if Index = -1 then\r\n begin\r\n DSO := TJvJanDSO.Create;\r\n AddObject(AName, DSO);\r\n Result := DSO;\r\n end\r\n else\r\n Result := TJvJanDSO(Objects[Index]);\r\nend;\r\n\r\n//=== { TJvJanDSO } ==========================================================\r\n\r\nfunction TJvJanDSO.GetValue(AKey: Variant; const AField: string): string;\r\nvar\r\n Index: Integer;\r\n Key: string;\r\n StrKey: Boolean;\r\nbegin\r\n Key := AKey;\r\n StrKey := False;\r\n Index := 0;\r\n try\r\n Index := StrToInt(Key)\r\n except\r\n StrKey := True;\r\n end;\r\n if not StrKey then\r\n begin\r\n if Index >= Count then\r\n raise EJvJanScriptError.CreateResFmt(@RsEDSOIndexOutOfRanged, [Index])\r\n else\r\n Result := InternalGetValue(Index, AField);\r\n end\r\n else\r\n begin\r\n Index := IndexOfName(Key);\r\n if Index = -1 then\r\n raise EJvJanScriptError.CreateResFmt(@RsEDSOUnknownKeys, [Key]);\r\n Result := InternalGetValue(Index, AField);\r\n end\r\nend;\r\n\r\nfunction TJvJanDSO.InternalGetValue(Index: Integer; const AField: string): string;\r\nvar\r\n Key, S: string;\r\n P: Integer;\r\nbegin\r\n S := Strings[Index];\r\n P := Pos('=', S);\r\n Key := Copy(S, 1, P - 1);\r\n S := Copy(S, P + 1, Length(S));\r\n Result := GlobalGetValue(S, AField);\r\nend;\r\n\r\nprocedure TJvJanDSO.InternalSetValue(Index: Integer; const AField, AValue: string);\r\nvar\r\n Key, S: string;\r\n P: Integer;\r\nbegin\r\n S := Strings[Index];\r\n P := Pos('=', S);\r\n Key := Copy(S, 1, P - 1);\r\n S := Copy(S, P + 1, Length(S));\r\n GlobalSetValue(S, AField, AValue);\r\n Strings[Index] := Key + '=' + S;\r\nend;\r\n\r\nprocedure TJvJanDSO.SetValue(AKey: Variant; const AField, AValue: string);\r\nvar\r\n Index: Integer;\r\n Key: string;\r\n StrKey: Boolean;\r\nbegin\r\n Key := AKey;\r\n StrKey := False;\r\n Index := 0;\r\n try\r\n Index := StrToInt(Key)\r\n except\r\n StrKey := True;\r\n end;\r\n if not StrKey then\r\n begin\r\n if Index >= Count then\r\n raise EJvJanScriptError.CreateResFmt(@RsEDSOIndexOutOfRanged, [Index])\r\n else\r\n InternalSetValue(Index, AField, AValue);\r\n end\r\n else\r\n begin\r\n Index := IndexOfName(Key);\r\n if Index = -1 then\r\n Index := Add(Key + '=');\r\n InternalSetValue(Index, AField, AValue);\r\n end\r\nend;\r\n\r\n//=== { TJvJanXMLList } ======================================================\r\n\r\nprocedure TJvJanXMLList.ClearXMLS;\r\nvar\r\n I, C: Integer;\r\nbegin\r\n C := Count;\r\n if C <> 0 then\r\n for I := 0 to C - 1 do\r\n TJvXMLTree(Objects[I]).Free;\r\n Clear;\r\nend;\r\n\r\ndestructor TJvJanXMLList.Destroy;\r\nbegin\r\n ClearXMLS;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJvJanXMLList.Xml(const AName: string): TJvXMLTree;\r\nvar\r\n Index: Integer;\r\n XmlDSO: TJvXMLTree;\r\nbegin\r\n Index := IndexOf(AName);\r\n if Index = -1 then\r\n begin\r\n XmlDSO := TJvXMLTree.Create(AName, '', nil);\r\n AddObject(AName, XmlDSO);\r\n Result := XmlDSO;\r\n end\r\n else\r\n Result := TJvXMLTree(Objects[Index]);\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvFullColorCircleForm.dfm", "content": "object JvFullColorCircleFrm: TJvFullColorCircleFrm\r\n Left = 108\r\n Top = 135\r\n BorderStyle = bsDialog\r\n Caption = 'Color circle configurations'\r\n ClientHeight = 660\r\n ClientWidth = 1019\r\n Color = clBtnFace\r\n Font.Charset = DEFAULT_CHARSET\r\n Font.Color = clWindowText\r\n Font.Height = -11\r\n Font.Name = 'MS Sans Serif'\r\n Font.Style = []\r\n KeyPreview = True\r\n OldCreateOrder = False\r\n Position = poScreenCenter\r\n OnCreate = FormCreate\r\n PixelsPerInch = 96\r\n TextHeight = 13\r\n object BevelOld: TBevel\r\n Left = 47\r\n Top = 55\r\n Width = 131\r\n Height = 131\r\n end\r\n object LabelOld: TLabel\r\n Left = 48\r\n Top = 40\r\n Width = 19\r\n Height = 13\r\n Caption = 'Old:'\r\n end\r\n object LabelNew: TLabel\r\n Left = 200\r\n Top = 40\r\n Width = 25\r\n Height = 13\r\n Caption = 'New:'\r\n end\r\n object LabelColorSpace: TLabel\r\n Left = 128\r\n Top = 2\r\n Width = 61\r\n Height = 13\r\n Caption = '&Color Space:'\r\n end\r\n object ImageNew: TImage\r\n Left = 200\r\n Top = 56\r\n Width = 129\r\n Height = 129\r\n end\r\n object ImageOld: TImage\r\n Left = 48\r\n Top = 56\r\n Width = 129\r\n Height = 129\r\n end\r\n object BevelNew: TBevel\r\n Left = 199\r\n Top = 55\r\n Width = 131\r\n Height = 131\r\n end\r\n object PanelGraphics: TPanel\r\n Left = 384\r\n Top = 8\r\n Width = 629\r\n Height = 641\r\n BevelInner = bvRaised\r\n BevelOuter = bvLowered\r\n Caption = 'PanelGraphics'\r\n TabOrder = 5\r\n object LabelAxisSettings: TLabel\r\n Left = 232\r\n Top = 18\r\n Width = 63\r\n Height = 13\r\n Caption = 'A&xis Settings:'\r\n FocusControl = JvColorAxisConfigCombo\r\n end\r\n object JvColorCircle: TJvFullColorCircle\r\n Left = 96\r\n Top = 64\r\n Width = 531\r\n Height = 531\r\n FullColor = 83886079\r\n AxisConfig = acYZX\r\n TabOrder = 1\r\n OnColorChange = JvColorCircleColorChange\r\n OnColorSpaceChange = JvColorCircleColorSpaceChange\r\n CrossSize = 10\r\n CrossCenter = 3\r\n CrossStyle.Width = 3\r\n LineWidth = 0\r\n RedTrackBar = JvFullColorTrackBarRed\r\n GreenTrackBar = JvFullColorTrackBarGreen\r\n BlueTrackBar = JvFullColorTrackBarBlue\r\n CommonTrackBar = JvFullColorTrackBarCommon\r\n OnRedColorChange = JvColorCircleRedColorChange\r\n OnGreenColorChange = JvColorCircleGreenColorChange\r\n OnBlueColorChange = JvColorCircleBlueColorChange\r\n end\r\n object JvFullColorTrackBarCommon: TJvFullColorTrackBar\r\n Left = 40\r\n Top = 32\r\n Width = 21\r\n Height = 276\r\n FullColor = 83886079\r\n AxisConfig = acYZX\r\n TabOrder = 2\r\n ArrowWidth = 10\r\n ColorOrientation = coInverse\r\n Orientation = trVertical\r\n end\r\n object JvFullColorTrackBarBlue: TJvFullColorTrackBar\r\n Left = 72\r\n Top = 312\r\n Width = 21\r\n Height = 276\r\n FullColor = 83820544\r\n AxisConfig = acYZX\r\n TabOrder = 5\r\n ArrowColor = clBlue\r\n ArrowWidth = 10\r\n ColorOrientation = coInverse\r\n Orientation = trVertical\r\n end\r\n object JvFullColorTrackBarGreen: TJvFullColorTrackBar\r\n Left = 40\r\n Top = 312\r\n Width = 21\r\n Height = 276\r\n FullColor = 67174144\r\n AxisConfig = acYZX\r\n TabOrder = 4\r\n ArrowColor = clLime\r\n ArrowWidth = 10\r\n ColorOrientation = coInverse\r\n Orientation = trVertical\r\n end\r\n object JvFullColorTrackBarRed: TJvFullColorTrackBar\r\n Left = 8\r\n Top = 312\r\n Width = 21\r\n Height = 276\r\n FullColor = 67109119\r\n AxisConfig = acYZX\r\n TabOrder = 3\r\n ArrowColor = clRed\r\n ArrowWidth = 10\r\n ColorOrientation = coInverse\r\n Orientation = trVertical\r\n end\r\n object JvColorAxisConfigCombo: TJvFullColorAxisCombo\r\n Left = 232\r\n Top = 32\r\n Width = 257\r\n Height = 21\r\n Selected = acYZX\r\n ItemHeight = 13\r\n TabOrder = 0\r\n OnChange = JvColorAxisConfigComboChange\r\n end\r\n end\r\n object PanelCommonSettings: TPanel\r\n Left = 8\r\n Top = 208\r\n Width = 361\r\n Height = 113\r\n BevelInner = bvRaised\r\n BevelOuter = bvLowered\r\n TabOrder = 2\r\n object LabelComAxis0: TLabel\r\n Left = 80\r\n Top = 16\r\n Width = 72\r\n Height = 13\r\n Caption = 'LabelComAxis0'\r\n end\r\n object LabelComAxis1: TLabel\r\n Left = 176\r\n Top = 16\r\n Width = 72\r\n Height = 13\r\n Caption = 'LabelComAxis1'\r\n end\r\n object LabelComAxis2: TLabel\r\n Left = 272\r\n Top = 16\r\n Width = 72\r\n Height = 13\r\n Caption = 'LabelComAxis2'\r\n end\r\n object LabelCommon: TLabel\r\n Left = 20\r\n Top = 48\r\n Width = 44\r\n Height = 13\r\n Caption = 'C&ommon:'\r\n FocusControl = SpinEditComAxis0\r\n end\r\n object SpinEditComAxis0: TJvSpinEdit\r\n Tag = 48\r\n Left = 80\r\n Top = 48\r\n Width = 57\r\n Height = 22\r\n Enabled = False\r\n TabOrder = 0\r\n OnChange = SpinEditSettingsValueChange\r\n end\r\n object SpinEditComAxis1: TJvSpinEdit\r\n Tag = 49\r\n Left = 176\r\n Top = 48\r\n Width = 57\r\n Height = 22\r\n TabOrder = 1\r\n OnChange = SpinEditSettingsValueChange\r\n end\r\n object SpinEditComAxis2: TJvSpinEdit\r\n Tag = 50\r\n Left = 272\r\n Top = 48\r\n Width = 57\r\n Height = 22\r\n TabOrder = 2\r\n OnChange = SpinEditSettingsValueChange\r\n end\r\n object CheckBoxCom0: TCheckBox\r\n Tag = 48\r\n Left = 72\r\n Top = 80\r\n Width = 89\r\n Height = 17\r\n Caption = 'CheckBoxCom0'\r\n TabOrder = 3\r\n OnClick = CheckBoxSettingsClick\r\n end\r\n object CheckBoxCom1: TCheckBox\r\n Tag = 49\r\n Left = 168\r\n Top = 80\r\n Width = 89\r\n Height = 17\r\n Caption = 'CheckBoxCom1'\r\n TabOrder = 4\r\n OnClick = CheckBoxSettingsClick\r\n end\r\n object CheckBoxCom2: TCheckBox\r\n Tag = 50\r\n Left = 264\r\n Top = 80\r\n Width = 89\r\n Height = 17\r\n Caption = 'CheckBoxCom2'\r\n TabOrder = 5\r\n OnClick = CheckBoxSettingsClick\r\n end\r\n end\r\n object PanelAxisSettings: TPanel\r\n Left = 8\r\n Top = 344\r\n Width = 361\r\n Height = 257\r\n BevelInner = bvRaised\r\n BevelOuter = bvLowered\r\n TabOrder = 4\r\n object LabelAxis0: TLabel\r\n Left = 80\r\n Top = 16\r\n Width = 51\r\n Height = 13\r\n Caption = 'LabelAxis0'\r\n end\r\n object LabelAxis1: TLabel\r\n Left = 176\r\n Top = 16\r\n Width = 51\r\n Height = 13\r\n Caption = 'LabelAxis1'\r\n end\r\n object LabelAxis2: TLabel\r\n Left = 272\r\n Top = 16\r\n Width = 51\r\n Height = 13\r\n Caption = 'LabelAxis2'\r\n end\r\n object LabelRed: TLabel\r\n Left = 44\r\n Top = 48\r\n Width = 23\r\n Height = 13\r\n Alignment = taRightJustify\r\n BiDiMode = bdLeftToRight\r\n Caption = '&Red:'\r\n FocusControl = SpinEditRedAxis0\r\n ParentBiDiMode = False\r\n end\r\n object LabelGreen: TLabel\r\n Left = 35\r\n Top = 120\r\n Width = 32\r\n Height = 13\r\n Alignment = taRightJustify\r\n Caption = '&Green:'\r\n FocusControl = SpinEditGreenAxis0\r\n end\r\n object LabelBlue: TLabel\r\n Left = 43\r\n Top = 192\r\n Width = 24\r\n Height = 13\r\n Alignment = taRightJustify\r\n Caption = '&Blue:'\r\n FocusControl = SpinEditBlueAxis0\r\n end\r\n object SpinEditRedAxis0: TJvSpinEdit\r\n Left = 80\r\n Top = 48\r\n Width = 57\r\n Height = 22\r\n TabOrder = 0\r\n OnChange = SpinEditSettingsValueChange\r\n end\r\n object SpinEditGreenAxis0: TJvSpinEdit\r\n Tag = 16\r\n Left = 80\r\n Top = 120\r\n Width = 57\r\n Height = 22\r\n TabOrder = 6\r\n OnChange = SpinEditSettingsValueChange\r\n end\r\n object SpinEditBlueAxis0: TJvSpinEdit\r\n Tag = 32\r\n Left = 80\r\n Top = 192\r\n Width = 57\r\n Height = 22\r\n TabOrder = 12\r\n OnChange = SpinEditSettingsValueChange\r\n end\r\n object SpinEditRedAxis1: TJvSpinEdit\r\n Tag = 1\r\n Left = 176\r\n Top = 48\r\n Width = 57\r\n Height = 22\r\n TabOrder = 1\r\n OnChange = SpinEditSettingsValueChange\r\n end\r\n object SpinEditRedAxis2: TJvSpinEdit\r\n Tag = 2\r\n Left = 272\r\n Top = 48\r\n Width = 57\r\n Height = 22\r\n TabOrder = 2\r\n OnChange = SpinEditSettingsValueChange\r\n end\r\n object SpinEditGreenAxis1: TJvSpinEdit\r\n Tag = 17\r\n Left = 176\r\n Top = 120\r\n Width = 57\r\n Height = 22\r\n TabOrder = 7\r\n OnChange = SpinEditSettingsValueChange\r\n end\r\n object SpinEditGreenAxis2: TJvSpinEdit\r\n Tag = 18\r\n Left = 272\r\n Top = 120\r\n Width = 57\r\n Height = 22\r\n TabOrder = 8\r\n OnChange = SpinEditSettingsValueChange\r\n end\r\n object SpinEditBlueAxis1: TJvSpinEdit\r\n Tag = 33\r\n Left = 176\r\n Top = 192\r\n Width = 57\r\n Height = 22\r\n TabOrder = 13\r\n OnChange = SpinEditSettingsValueChange\r\n end\r\n object SpinEditBlueAxis2: TJvSpinEdit\r\n Tag = 34\r\n Left = 272\r\n Top = 192\r\n Width = 57\r\n Height = 22\r\n TabOrder = 14\r\n OnChange = SpinEditSettingsValueChange\r\n end\r\n object CheckBoxRed0: TCheckBox\r\n Left = 72\r\n Top = 80\r\n Width = 89\r\n Height = 17\r\n Caption = 'CheckBoxRed0'\r\n TabOrder = 3\r\n OnClick = CheckBoxSettingsClick\r\n end\r\n object CheckBoxRed1: TCheckBox\r\n Tag = 1\r\n Left = 168\r\n Top = 80\r\n Width = 89\r\n Height = 17\r\n Caption = 'CheckBoxRed1'\r\n TabOrder = 4\r\n OnClick = CheckBoxSettingsClick\r\n end\r\n object CheckBoxRed2: TCheckBox\r\n Tag = 2\r\n Left = 264\r\n Top = 80\r\n Width = 89\r\n Height = 17\r\n Caption = 'CheckBoxRed2'\r\n TabOrder = 5\r\n OnClick = CheckBoxSettingsClick\r\n end\r\n object CheckBoxGreen0: TCheckBox\r\n Tag = 16\r\n Left = 72\r\n Top = 152\r\n Width = 89\r\n Height = 17\r\n Caption = 'CheckBoxGreen0'\r\n TabOrder = 9\r\n OnClick = CheckBoxSettingsClick\r\n end\r\n object CheckBoxGreen1: TCheckBox\r\n Tag = 17\r\n Left = 168\r\n Top = 152\r\n Width = 89\r\n Height = 17\r\n Caption = 'CheckBoxGreen1'\r\n TabOrder = 10\r\n OnClick = CheckBoxSettingsClick\r\n end\r\n object CheckBoxGreen2: TCheckBox\r\n Tag = 18\r\n Left = 264\r\n Top = 152\r\n Width = 89\r\n Height = 17\r\n Caption = 'CheckBoxGreen2'\r\n TabOrder = 11\r\n OnClick = CheckBoxSettingsClick\r\n end\r\n object CheckBoxBlue0: TCheckBox\r\n Tag = 32\r\n Left = 72\r\n Top = 224\r\n Width = 89\r\n Height = 17\r\n Caption = 'CheckBoxBlue0'\r\n TabOrder = 15\r\n OnClick = CheckBoxSettingsClick\r\n end\r\n object CheckBoxBlue1: TCheckBox\r\n Tag = 33\r\n Left = 168\r\n Top = 224\r\n Width = 89\r\n Height = 17\r\n Caption = 'CheckBoxBlue1'\r\n TabOrder = 16\r\n OnClick = CheckBoxSettingsClick\r\n end\r\n object CheckBoxBlue2: TCheckBox\r\n Tag = 34\r\n Left = 264\r\n Top = 224\r\n Width = 89\r\n Height = 17\r\n Caption = 'CheckBoxBlue2'\r\n TabOrder = 17\r\n OnClick = CheckBoxSettingsClick\r\n end\r\n end\r\n object RadioButtonCommonSettings: TRadioButton\r\n Left = 16\r\n Top = 200\r\n Width = 113\r\n Height = 17\r\n Caption = 'Co&mmon Settings:'\r\n TabOrder = 1\r\n OnClick = RadioButtonAxisClick\r\n end\r\n object RadioButtonAxisSettings: TRadioButton\r\n Left = 16\r\n Top = 336\r\n Width = 89\r\n Height = 17\r\n Caption = '&Axis Settings:'\r\n TabOrder = 3\r\n OnClick = RadioButtonAxisClick\r\n end\r\n object ButtonGraphics: TButton\r\n Left = 296\r\n Top = 624\r\n Width = 73\r\n Height = 25\r\n TabOrder = 9\r\n OnClick = ButtonGraphicsClick\r\n end\r\n object ButtonCancel: TButton\r\n Left = 104\r\n Top = 624\r\n Width = 75\r\n Height = 25\r\n Cancel = True\r\n Caption = 'Ca&ncel'\r\n ModalResult = 2\r\n TabOrder = 7\r\n end\r\n object ButtonOK: TButton\r\n Left = 8\r\n Top = 624\r\n Width = 75\r\n Height = 25\r\n Caption = '&OK'\r\n Default = True\r\n ModalResult = 1\r\n TabOrder = 6\r\n end\r\n object ButtonApply: TButton\r\n Left = 200\r\n Top = 624\r\n Width = 75\r\n Height = 25\r\n Caption = '&Apply'\r\n TabOrder = 8\r\n OnClick = ButtonApplyClick\r\n end\r\n object JvColorSpaceCombo: TJvFullColorSpaceCombo\r\n Left = 128\r\n Top = 16\r\n Width = 153\r\n Height = 21\r\n AllowVariable = False\r\n ItemHeight = 13\r\n TabOrder = 0\r\n OnChange = JvColorSpaceComboChange\r\n end\r\nend\r\n" }, { "path": "External/Jedi/Jvcl/run/JvFullColorCircleForm.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: ColorCircleFrm.pas, released on 2004-10-11.\r\n\r\nThe Initial Developer of the Original Code is Florent Ouchet [ouchet dott florent att laposte dott net]\r\nPortions created by Florent Ouchet are Copyright (C) 2004 Florent Ouchet.\r\nAll Rights Reserved.\r\n\r\nContributor(s): -\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvFullColorCircleForm.pas 12461 2009-08-14 17:21:33Z obones $\r\n\r\nunit JvFullColorCircleForm;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,\r\n ExtCtrls, StdCtrls, Mask,\r\n JvFullColorDialogs, JvFullColorCtrls, JvFullColorSpaces, JvFullColorRotate,\r\n JvExMask, JvSpin, JvComponent;\r\n\r\ntype\r\n TJvFullColorCircleFrm = class(TJvForm)\r\n JvColorCircle: TJvFullColorCircle;\r\n RadioButtonCommonSettings: TRadioButton;\r\n RadioButtonAxisSettings: TRadioButton;\r\n PanelAxisSettings: TPanel;\r\n PanelCommonSettings: TPanel;\r\n ImageOld: TImage;\r\n ImageNew: TImage;\r\n JvFullColorTrackBarCommon: TJvFullColorTrackBar;\r\n JvFullColorTrackBarBlue: TJvFullColorTrackBar;\r\n JvFullColorTrackBarGreen: TJvFullColorTrackBar;\r\n JvFullColorTrackBarRed: TJvFullColorTrackBar;\r\n SpinEditComAxis0: TJvSpinEdit;\r\n SpinEditRedAxis0: TJvSpinEdit;\r\n SpinEditGreenAxis0: TJvSpinEdit;\r\n SpinEditBlueAxis0: TJvSpinEdit;\r\n SpinEditComAxis1: TJvSpinEdit;\r\n SpinEditComAxis2: TJvSpinEdit;\r\n SpinEditRedAxis1: TJvSpinEdit;\r\n SpinEditRedAxis2: TJvSpinEdit;\r\n SpinEditGreenAxis1: TJvSpinEdit;\r\n SpinEditGreenAxis2: TJvSpinEdit;\r\n SpinEditBlueAxis1: TJvSpinEdit;\r\n SpinEditBlueAxis2: TJvSpinEdit;\r\n LabelOld: TLabel;\r\n LabelNew: TLabel;\r\n LabelColorSpace: TLabel;\r\n LabelAxisSettings: TLabel;\r\n LabelComAxis0: TLabel;\r\n LabelComAxis1: TLabel;\r\n LabelComAxis2: TLabel;\r\n LabelAxis0: TLabel;\r\n LabelAxis1: TLabel;\r\n LabelAxis2: TLabel;\r\n LabelCommon: TLabel;\r\n LabelRed: TLabel;\r\n LabelGreen: TLabel;\r\n LabelBlue: TLabel;\r\n PanelGraphics: TPanel;\r\n ButtonGraphics: TButton;\r\n ButtonCancel: TButton;\r\n ButtonOK: TButton;\r\n ButtonApply: TButton;\r\n CheckBoxCom0: TCheckBox;\r\n CheckBoxCom1: TCheckBox;\r\n CheckBoxCom2: TCheckBox;\r\n CheckBoxRed0: TCheckBox;\r\n CheckBoxRed1: TCheckBox;\r\n CheckBoxRed2: TCheckBox;\r\n CheckBoxGreen0: TCheckBox;\r\n CheckBoxGreen1: TCheckBox;\r\n CheckBoxGreen2: TCheckBox;\r\n CheckBoxBlue0: TCheckBox;\r\n CheckBoxBlue1: TCheckBox;\r\n CheckBoxBlue2: TCheckBox;\r\n BevelOld: TBevel;\r\n BevelNew: TBevel;\r\n JvColorSpaceCombo: TJvFullColorSpaceCombo;\r\n JvColorAxisConfigCombo: TJvFullColorAxisCombo;\r\n procedure FormCreate(Sender: TObject);\r\n procedure ButtonGraphicsClick(Sender: TObject);\r\n procedure ButtonApplyClick(Sender: TObject);\r\n procedure JvColorSpaceComboChange(Sender: TObject);\r\n procedure CheckBoxSettingsClick(Sender: TObject);\r\n procedure JvColorCircleBlueColorChange(Sender: TObject);\r\n procedure JvColorCircleColorChange(Sender: TObject);\r\n procedure JvColorCircleGreenColorChange(Sender: TObject);\r\n procedure JvColorCircleRedColorChange(Sender: TObject);\r\n procedure JvColorAxisConfigComboChange(Sender: TObject);\r\n procedure JvColorCircleColorSpaceChange(Sender: TObject);\r\n procedure RadioButtonAxisClick(Sender: TObject);\r\n procedure SpinEditSettingsValueChange(Sender: TObject);\r\n private\r\n FExpanded: Boolean;\r\n FUpdating: Boolean;\r\n FExpandedWidth: Integer;\r\n FDelta: TJvColorDelta;\r\n FOnApply: TNotifyEvent;\r\n FOptions: TJvFullColorCircleDialogOptions;\r\n FRedAxis: array [TJvAxisIndex] of Byte;\r\n FGreenAxis: array [TJvAxisIndex] of Byte;\r\n FBlueAxis: array [TJvAxisIndex] of Byte;\r\n FComAxis: array [TJvAxisIndex] of Byte;\r\n FAxisMin: array [TJvAxisIndex] of Byte;\r\n FAxisMax: array [TJvAxisIndex] of Byte;\r\n FSpinEditComAxes: array [TJvAxisIndex] of TJvSpinEdit;\r\n FSpinEditRedAxes: array [TJvAxisIndex] of TJvSpinEdit;\r\n FSpinEditGreenAxes: array [TJvAxisIndex] of TJvSpinEdit;\r\n FSpinEditBlueAxes: array [TJvAxisIndex] of TJvSpinEdit;\r\n FLabelComAxes: array [TJvAxisIndex] of TLabel;\r\n FLabelAxes: array [TJvAxisIndex] of TLabel;\r\n FCheckBoxCom: array [TJvAxisIndex] of TCheckBox;\r\n FCheckBoxRed: array [TJvAxisIndex] of TCheckBox;\r\n FCheckBoxGreen: array [TJvAxisIndex] of TCheckBox;\r\n FCheckBoxBlue: array [TJvAxisIndex] of TCheckBox;\r\n FFilled: Boolean;\r\n procedure FillInternalArrays;\r\n protected\r\n procedure Loaded; override;\r\n function GetRedDelta: TJvAxisDelta;\r\n function GetGreenDelta: TJvAxisDelta;\r\n function GetBlueDelta: TJvAxisDelta;\r\n function GetColorID: TJvFullColorSpaceID;\r\n procedure SetOptions(const Value: TJvFullColorCircleDialogOptions);\r\n procedure SetRedDelta(const Value: TJvAxisDelta);\r\n procedure SetGreenDelta(const Value: TJvAxisDelta);\r\n procedure SetBlueDelta(const Value: TJvAxisDelta);\r\n procedure SetColorID(const Value: TJvFullColorSpaceID);\r\n procedure SetDelta(const Value: TJvColorDelta);\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n\r\n procedure UpdateDeltaValue;\r\n procedure CalcDeltaValue(ARotateColor: TJvRotateColor);\r\n procedure UpdateColorSpace;\r\n procedure UpdateCheckBoxStates;\r\n procedure UpdateAxisSettings;\r\n procedure Expand;\r\n procedure Collapse;\r\n\r\n property Expanded: Boolean read FExpanded;\r\n property Options: TJvFullColorCircleDialogOptions read FOptions write SetOptions;\r\n property RedDelta: TJvAxisDelta read GetRedDelta write SetRedDelta;\r\n property GreenDelta: TJvAxisDelta read GetGreenDelta write SetGreenDelta;\r\n property BlueDelta: TJvAxisDelta read GetBlueDelta write SetBlueDelta;\r\n property ColorID: TJvFullColorSpaceID read GetColorID write SetColorID;\r\n property Delta: TJvColorDelta read FDelta write SetDelta;\r\n property OnApply: TNotifyEvent read FOnApply write FOnApply;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvFullColorCircleForm.pas $';\r\n Revision: '$Revision: 12461 $';\r\n Date: '$Date: 2009-08-14 19:21:33 +0200 (ven. 14 août 2009) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n JvResources,\r\n TypInfo,\r\n JclMath, // For EnsureRange\r\n JvJCLUtils; // for TryStrToInt\r\n\r\n{$R *.dfm}\r\n\r\nvar\r\n GlobalLoop, GlobalRange: string;\r\n\r\nfunction AxisIndexFromTag(ATag: Integer): TJvAxisIndex;\r\nbegin\r\n Result := TJvAxisIndex(ATag and $03);\r\nend;\r\n\r\n//=== { TJvFullColorCircleForm } =============================================\r\n\r\nconstructor TJvFullColorCircleFrm.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FDelta := TJvColorDelta.Create;\r\nend;\r\n\r\ndestructor TJvFullColorCircleFrm.Destroy;\r\nbegin\r\n FDelta.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJvFullColorCircleFrm.GetBlueDelta: TJvAxisDelta;\r\nbegin\r\n Result := FDelta.AxisBlue;\r\nend;\r\n\r\nfunction TJvFullColorCircleFrm.GetColorID: TJvFullColorSpaceID;\r\nbegin\r\n Result := FDelta.ColorID;\r\nend;\r\n\r\nfunction TJvFullColorCircleFrm.GetGreenDelta: TJvAxisDelta;\r\nbegin\r\n Result := FDelta.AxisGreen;\r\nend;\r\n\r\nfunction TJvFullColorCircleFrm.GetRedDelta: TJvAxisDelta;\r\nbegin\r\n Result := FDelta.AxisRed;\r\nend;\r\n\r\nprocedure TJvFullColorCircleFrm.FormCreate(Sender: TObject);\r\nbegin\r\n Options := JvDefaultColorCircleDialogOptions - [coShowSaturation];\r\n JvColorAxisConfigCombo.Selected := JvColorCircle.AxisConfig;\r\nend;\r\n\r\nprocedure TJvFullColorCircleFrm.FillInternalArrays;\r\nbegin\r\n if not FFilled then\r\n begin\r\n FSpinEditComAxes[axIndex0] := SpinEditComAxis0;\r\n FSpinEditComAxes[axIndex1] := SpinEditComAxis1;\r\n FSpinEditComAxes[axIndex2] := SpinEditComAxis2;\r\n FSpinEditRedAxes[axIndex0] := SpinEditRedAxis0;\r\n FSpinEditRedAxes[axIndex1] := SpinEditRedAxis1;\r\n FSpinEditRedAxes[axIndex2] := SpinEditRedAxis2;\r\n FSpinEditGreenAxes[axIndex0] := SpinEditGreenAxis0;\r\n FSpinEditGreenAxes[axIndex1] := SpinEditGreenAxis1;\r\n FSpinEditGreenAxes[axIndex2] := SpinEditGreenAxis2;\r\n FSpinEditBlueAxes[axIndex0] := SpinEditBlueAxis0;\r\n FSpinEditBlueAxes[axIndex1] := SpinEditBlueAxis1;\r\n FSpinEditBlueAxes[axIndex2] := SpinEditBlueAxis2;\r\n FLabelComAxes[axIndex0] := LabelComAxis0;\r\n FLabelComAxes[axIndex1] := LabelComAxis1;\r\n FLabelComAxes[axIndex2] := LabelComAxis2;\r\n FLabelAxes[axIndex0] := LabelAxis0;\r\n FLabelAxes[axIndex1] := LabelAxis1;\r\n FLabelAxes[axIndex2] := LabelAxis2;\r\n FCheckBoxCom[axIndex0] := CheckBoxCom0;\r\n FCheckBoxCom[axIndex1] := CheckBoxCom1;\r\n FCheckBoxCom[axIndex2] := CheckBoxCom2;\r\n FCheckBoxRed[axIndex0] := CheckBoxRed0;\r\n FCheckBoxRed[axIndex1] := CheckBoxRed1;\r\n FCheckBoxRed[axIndex2] := CheckBoxRed2;\r\n FCheckBoxGreen[axIndex0] := CheckBoxGreen0;\r\n FCheckBoxGreen[axIndex1] := CheckBoxGreen1;\r\n FCheckBoxGreen[axIndex2] := CheckBoxGreen2;\r\n FCheckBoxBlue[axIndex0] := CheckBoxBlue0;\r\n FCheckBoxBlue[axIndex1] := CheckBoxBlue1;\r\n FCheckBoxBlue[axIndex2] := CheckBoxBlue2;\r\n FFilled := True;\r\n end;\r\nend;\r\n\r\nprocedure TJvFullColorCircleFrm.Loaded;\r\nbegin\r\n inherited Loaded;\r\n FExpandedWidth := Width;\r\nend;\r\n\r\nprocedure TJvFullColorCircleFrm.Collapse;\r\nbegin\r\n Width := PanelGraphics.Left - 1;\r\n PanelGraphics.Visible := False;\r\n ButtonGraphics.Caption := RsCollapsedCaption;\r\n FExpanded := False;\r\nend;\r\n\r\nprocedure TJvFullColorCircleFrm.Expand;\r\nbegin\r\n Width := FExpandedWidth;\r\n PanelGraphics.Visible := True;\r\n ButtonGraphics.Caption := RsExpandedCaption;\r\n FExpanded := True;\r\nend;\r\n\r\nprocedure TJvFullColorCircleFrm.SetOptions(const Value: TJvFullColorCircleDialogOptions);\r\nvar\r\n I: TJvAxisIndex;\r\n EnabledA, EnabledB: Boolean;\r\n LVisible: Boolean;\r\n\r\n procedure UpdateCheckBox(ACheckBox: TCheckBox);\r\n begin\r\n ACheckBox.Visible := EnabledA;\r\n ACheckBox.Checked := EnabledB;\r\n end;\r\n\r\nbegin\r\n FOptions := Value;\r\n FillInternalArrays;\r\n\r\n if coFullOpen in Options then\r\n Expand\r\n else\r\n Collapse;\r\n\r\n ButtonGraphics.Enabled := not (coPreventExpand in Options);\r\n\r\n ButtonApply.Visible := (coShowApply in Options);\r\n\r\n if coShowHelp in Options then\r\n BorderIcons := BorderIcons + [biHelp]\r\n else\r\n BorderIcons := BorderIcons - [biHelp];\r\n\r\n EnabledA := coAllowSpaceChange in Options;\r\n LabelColorSpace.Enabled := EnabledA;\r\n JvColorSpaceCombo.Enabled := EnabledA;\r\n\r\n LVisible := coShowOldPreview in Options;\r\n ImageOld.Visible := LVisible;\r\n LabelOld.Visible := LVisible;\r\n\r\n LVisible := coShowNewPreview in Options;\r\n ImageNew.Visible := LVisible;\r\n LabelNew.Visible := LVisible;\r\n\r\n EnabledA := coShowSaturation in Options;\r\n EnabledB := coDefaultRange in Options;\r\n\r\n for I := Low(TJvAxisIndex) to High(TJvAxisIndex) do\r\n begin\r\n UpdateCheckBox(FCheckBoxCom[I]);\r\n UpdateCheckBox(FCheckBoxRed[I]);\r\n UpdateCheckBox(FCheckBoxGreen[I]);\r\n UpdateCheckBox(FCheckBoxBlue[I]);\r\n end;\r\n\r\n if RadioButtonCommonSettings.Enabled and RadioButtonAxisSettings.Enabled then\r\n RadioButtonAxisSettings.Checked := True;\r\n\r\n UpdateAxisSettings;\r\n UpdateCheckBoxStates;\r\n UpdateColorSpace;\r\nend;\r\n\r\nprocedure TJvFullColorCircleFrm.UpdateColorSpace;\r\nvar\r\n I: TJvAxisIndex;\r\n LCaption: string;\r\n LColor: TJvFullColor;\r\nbegin\r\n if FUpdating then\r\n Exit;\r\n FillInternalArrays;\r\n\r\n FUpdating := True;\r\n\r\n with JvColorSpaceCombo.SelectedSpace do\r\n begin\r\n SetColorID(ID);\r\n JvColorAxisConfigCombo.ColorID := ID;\r\n\r\n for I := Low(TJvAxisIndex) to High(TJvAxisIndex) do\r\n begin\r\n LCaption := AxisName[I];\r\n FLabelComAxes[I].Caption := LCaption;\r\n FLabelAxes[I].Caption := LCaption;\r\n\r\n FAxisMax[I] := AxisMax[I];\r\n FAxisMin[I] := AxisMin[I];\r\n FSpinEditComAxes[I].MaxValue := FAxisMax[I];\r\n FSpinEditComAxes[I].MinValue := -FAxisMax[I];\r\n FSpinEditRedAxes[I].MaxValue := FAxisMax[I];\r\n FSpinEditRedAxes[I].MinValue := -FAxisMax[I];\r\n FSpinEditGreenAxes[I].MaxValue := FAxisMax[I];\r\n FSpinEditGreenAxes[I].MinValue := -FAxisMax[I];\r\n FSpinEditBlueAxes[I].MaxValue := FAxisMax[I];\r\n FSpinEditBlueAxes[I].MinValue := -FAxisMax[I];\r\n\r\n LColor := ConvertFromColor(clRed);\r\n FRedAxis[I] := GetAxisValue(LColor, I);\r\n\r\n LColor := ConvertFromColor(clLime);\r\n FGreenAxis[I] := GetAxisValue(LColor, I);\r\n\r\n LColor := ConvertFromColor(clBlue);\r\n FBlueAxis[I] := GetAxisValue(LColor, I);\r\n\r\n LColor := ConvertFromColor(clDkGray);\r\n FComAxis[I] := GetAxisValue(LColor, I);\r\n end;\r\n\r\n JvColorCircle.ConvertToID(ID shl 24);\r\n\r\n FUpdating := False;\r\n end;\r\n CalcDeltaValue(rcRed);\r\n CalcDeltaValue(rcGreen);\r\n CalcDeltaValue(rcBlue);\r\nend;\r\n\r\nprocedure TJvFullColorCircleFrm.UpdateDeltaValue;\r\nvar\r\n I: TJvAxisIndex;\r\n ComAxis: array [TJvAxisIndex] of Integer;\r\n LColorID: TJvFullColorSpaceID;\r\n ARedColor, AGreenColor, ABlueColor, ACommonColor: TJvFullColor;\r\n\r\n function CheckRange(Value: Integer; AMin: Byte; AMax: Byte): Byte;\r\n begin\r\n while Value < AMin do\r\n Inc(Value, AMax - AMin + 1);\r\n while Value > AMax do\r\n Dec(Value, AMax - AMin + 1);\r\n Result := Value;\r\n end;\r\n\r\nbegin\r\n if FUpdating then\r\n Exit;\r\n FillInternalArrays;\r\n\r\n FUpdating := True;\r\n\r\n for I := Low(TJvAxisIndex) to High(TJvAxisIndex) do\r\n begin\r\n ComAxis[I] := (RedDelta[I].Value + GreenDelta[I].Value + BlueDelta[I].Value) div 3;\r\n FSpinEditRedAxes[I].Value := RedDelta[I].Value;\r\n FSpinEditGreenAxes[I].Value := GreenDelta[I].Value;\r\n FSpinEditBlueAxes[I].Value := BlueDelta[I].Value;\r\n FSpinEditComAxes[I].Value := ComAxis[I];\r\n end;\r\n\r\n LColorID := JvColorSpaceCombo.ColorSpaceID;\r\n\r\n ACommonColor := LColorID shl 24;\r\n ARedColor := LColorID shl 24;\r\n AGreenColor := LColorID shl 24;\r\n ABlueColor := LColorID shl 24;\r\n for I := Low(TJvAxisIndex) to High(TJvAxisIndex) do\r\n begin\r\n ARedColor := ARedColor or\r\n (CheckRange(RedDelta[I].Value + FRedAxis[I], FAxisMin[I], FAxisMax[I]) shl (Ord(I)*8));\r\n AGreenColor := AGreenColor or\r\n (CheckRange(GreenDelta[I].Value + FGreenAxis[I], FAxisMin[I], FAxisMax[I]) shl (Ord(I)*8));\r\n ABlueColor := ABlueColor or\r\n (CheckRange(BlueDelta[I].Value + FBlueAxis[I], FAxisMin[I], FAxisMax[I]) shl (Ord(I)*8));\r\n ACommonColor := ACommonColor or\r\n (CheckRange(ComAxis[I] + FComAxis[I], FAxisMin[I], FAxisMax[I]) shl (Ord(I)*8));\r\n end;\r\n\r\n JvColorCircle.FullColor := ACommonColor;\r\n JvColorCircle.RedColor := ARedColor;\r\n JvColorCircle.GreenColor := AGreenColor;\r\n JvColorCircle.BlueColor := ABlueColor;\r\n\r\n FUpdating := False;\r\nend;\r\n\r\nprocedure TJvFullColorCircleFrm.RadioButtonAxisClick(Sender: TObject);\r\nbegin\r\n UpdateAxisSettings;\r\nend;\r\n\r\nprocedure TJvFullColorCircleFrm.UpdateAxisSettings;\r\nvar\r\n I: TJvAxisIndex;\r\n LColor: TColor;\r\n EnabledA, EnabledB: Boolean;\r\nbegin\r\n FillInternalArrays;\r\n EnabledA := coCommon in Options;\r\n\r\n if not EnabledA then\r\n RadioButtonAxisSettings.Checked := True;\r\n\r\n RadioButtonCommonSettings.Enabled := EnabledA;\r\n EnabledA := EnabledA and RadioButtonCommonSettings.Checked;\r\n PanelCommonSettings.Enabled := EnabledA;\r\n\r\n if EnabledA then\r\n LColor := clWindow\r\n else\r\n LColor := clBtnFace;\r\n for I := Low(TJvAxisIndex) to High(TJvAxisIndex) do\r\n begin\r\n FSpinEditComAxes[I].Enabled := EnabledA;\r\n FSpinEditComAxes[I].Color := LColor;\r\n FCheckBoxCom[I].Enabled := EnabledA;\r\n FLabelComAxes[I].Enabled := EnabledA;\r\n end;\r\n LabelCommon.Enabled := EnabledA;\r\n JvFullColorTrackBarCommon.Visible := EnabledA;\r\n if EnabledA then\r\n JvColorCircle.Styles := JvColorCircle.Styles + [csShowCommon]\r\n else\r\n JvColorCircle.Styles := JvColorCircle.Styles - [csShowCommon];\r\n\r\n EnabledA := (coRed in Options) or (coBlue in Options) or (coGreen in Options);\r\n\r\n if not EnabledA then\r\n RadioButtonCommonSettings.Checked := True;\r\n\r\n RadioButtonAxisSettings.Enabled := EnabledA;\r\n EnabledA := EnabledA and RadioButtonAxisSettings.Checked;\r\n PanelAxisSettings.Enabled := EnabledA;\r\n for I := Low(TJvAxisIndex) to High(TJvAxisIndex) do\r\n FLabelAxes[I].Enabled := EnabledA;\r\n\r\n EnabledB := EnabledA and (coRed in Options);\r\n if EnabledB then\r\n LColor := clWindow\r\n else\r\n LColor := clBtnFace;\r\n LabelRed.Enabled := EnabledB;\r\n for I := Low(TJvAxisIndex) to High(TJvAxisIndex) do\r\n begin\r\n FSpinEditRedAxes[I].Enabled := EnabledB;\r\n FSpinEditRedAxes[I].Color := LColor;\r\n FCheckBoxRed[I].Enabled := EnabledB;\r\n end;\r\n JvFullColorTrackBarRed.Visible := EnabledB;\r\n\r\n EnabledB := EnabledA and (coGreen in Options);\r\n if EnabledB then\r\n LColor := clWindow\r\n else\r\n LColor := clBtnFace;\r\n LabelGreen.Enabled := EnabledB;\r\n for I := Low(TJvAxisIndex) to High(TJvAxisIndex) do\r\n begin\r\n FSpinEditGreenAxes[I].Enabled := EnabledB;\r\n FSpinEditGreenAxes[I].Color := LColor;\r\n FCheckBoxGreen[I].Enabled := EnabledB;\r\n end;\r\n JvFullColorTrackBarGreen.Visible := EnabledB;\r\n\r\n EnabledB := EnabledA and (coBlue in Options);\r\n if EnabledB then\r\n LColor := clWindow\r\n else\r\n LColor := clBtnFace;\r\n LabelBlue.Enabled := EnabledB;\r\n for I := Low(TJvAxisIndex) to High(TJvAxisIndex) do\r\n begin\r\n FSpinEditBlueAxes[I].Enabled := EnabledB;\r\n FSpinEditBlueAxes[I].Color := LColor;\r\n FCheckBoxBlue[I].Enabled := EnabledB;\r\n end;\r\n JvFullColorTrackBarBlue.Visible := EnabledB;\r\nend;\r\n\r\nprocedure TJvFullColorCircleFrm.CheckBoxSettingsClick(Sender: TObject);\r\nvar\r\n Idx: TJvAxisIndex;\r\n AxisDelta: TJvAxisDelta;\r\n SaturationMethod: TJvSaturationMethod;\r\nbegin\r\n if FUpdating then\r\n Exit;\r\n\r\n FUpdating := True;\r\n\r\n with Sender as TCheckBox do\r\n begin\r\n if Checked then\r\n SaturationMethod := smLoop\r\n else\r\n SaturationMethod := smRange;\r\n\r\n Idx := AxisIndexFromTag(Tag);\r\n case Tag and $30 of\r\n $00:\r\n begin\r\n AxisDelta := RedDelta;\r\n AxisDelta[Idx].SaturationMethod := SaturationMethod;\r\n RedDelta := AxisDelta;\r\n end;\r\n $10:\r\n begin\r\n AxisDelta := GreenDelta;\r\n AxisDelta[Idx].SaturationMethod := SaturationMethod;\r\n GreenDelta := AxisDelta;\r\n end;\r\n $20:\r\n begin\r\n AxisDelta := BlueDelta;\r\n AxisDelta[Idx].SaturationMethod := SaturationMethod;\r\n BlueDelta := AxisDelta;\r\n end;\r\n $30:\r\n begin\r\n AxisDelta := RedDelta;\r\n AxisDelta[Idx].SaturationMethod := SaturationMethod;\r\n RedDelta := AxisDelta;\r\n\r\n AxisDelta := GreenDelta;\r\n AxisDelta[Idx].SaturationMethod := SaturationMethod;\r\n GreenDelta := AxisDelta;\r\n\r\n AxisDelta := BlueDelta;\r\n AxisDelta[Idx].SaturationMethod := SaturationMethod;\r\n BlueDelta := AxisDelta;\r\n end;\r\n end;\r\n end;\r\n\r\n FUpdating := False;\r\n\r\n UpdateCheckBoxStates;\r\nend;\r\n\r\nprocedure TJvFullColorCircleFrm.UpdateCheckBoxStates;\r\nvar\r\n I: TJvAxisIndex;\r\n\r\n procedure UpdateCheckBox(ACheckBox: TCheckBox);\r\n var\r\n Idx: TJvAxisIndex;\r\n SaturationMethod: TJvSaturationMethod;\r\n begin\r\n SaturationMethod := smRange;\r\n\r\n Idx := AxisIndexFromTag(ACheckBox.Tag);\r\n case ACheckBox.Tag and $30 of\r\n $00:\r\n SaturationMethod := RedDelta[Idx].SaturationMethod;\r\n $10:\r\n SaturationMethod := GreenDelta[Idx].SaturationMethod;\r\n $20:\r\n SaturationMethod := BlueDelta[Idx].SaturationMethod;\r\n $30:\r\n if (RedDelta[Idx].SaturationMethod = smLoop) and\r\n (GreenDelta[Idx].SaturationMethod = smLoop) and\r\n (BlueDelta[Idx].SaturationMethod = smLoop) then\r\n SaturationMethod := smLoop\r\n else\r\n SaturationMethod := smRange;\r\n end;\r\n\r\n if SaturationMethod = smLoop then\r\n begin\r\n ACheckBox.Caption := GlobalLoop;\r\n ACheckBox.Checked := True;\r\n end\r\n else\r\n begin\r\n ACheckBox.Caption := GlobalRange;\r\n ACheckBox.Checked := False;\r\n end;\r\n end;\r\n\r\nbegin\r\n if FUpdating then\r\n Exit;\r\n FillInternalArrays;\r\n\r\n FUpdating := True;\r\n for I := Low(TJvAxisIndex) to High(TJvAxisIndex) do\r\n begin\r\n UpdateCheckBox(FCheckBoxCom[I]);\r\n UpdateCheckBox(FCheckBoxRed[I]);\r\n UpdateCheckBox(FCheckBoxGreen[I]);\r\n UpdateCheckBox(FCheckBoxBlue[I]);\r\n end;\r\n FUpdating := False;\r\nend;\r\n\r\nprocedure TJvFullColorCircleFrm.ButtonGraphicsClick(Sender: TObject);\r\nbegin\r\n if Expanded then\r\n Collapse\r\n else\r\n Expand;\r\nend;\r\n\r\nprocedure TJvFullColorCircleFrm.ButtonApplyClick(Sender: TObject);\r\nbegin\r\n if Assigned(OnApply) then\r\n OnApply(Self);\r\nend;\r\n\r\nprocedure TJvFullColorCircleFrm.JvColorSpaceComboChange(Sender: TObject);\r\nbegin\r\n if not FUpdating then\r\n UpdateColorSpace;\r\nend;\r\n\r\nprocedure TJvFullColorCircleFrm.SetBlueDelta(const Value: TJvAxisDelta);\r\nbegin\r\n FDelta.AxisBlue.Assign(Value);\r\n if not FUpdating then\r\n begin\r\n UpdateDeltaValue;\r\n UpdateCheckBoxStates;\r\n end;\r\nend;\r\n\r\nprocedure TJvFullColorCircleFrm.SetDelta(const Value: TJvColorDelta);\r\nvar\r\n ChangeColorSpace:Boolean;\r\nbegin\r\n ChangeColorSpace := Value.ColorID <> Delta.ColorID;\r\n FDelta.Assign(Value);\r\n if not FUpdating then\r\n begin\r\n if ChangeColorSpace then\r\n begin\r\n JvColorSpaceCombo.ColorSpaceID := Value.ColorID;\r\n UpdateColorSpace;\r\n end;\r\n UpdateDeltaValue;\r\n UpdateCheckBoxStates;\r\n end;\r\nend;\r\n\r\nprocedure TJvFullColorCircleFrm.SetGreenDelta(const Value: TJvAxisDelta);\r\nbegin\r\n FDelta.AxisGreen.Assign(Value);\r\n if not FUpdating then\r\n begin\r\n UpdateDeltaValue;\r\n UpdateCheckBoxStates;\r\n end;\r\nend;\r\n\r\nprocedure TJvFullColorCircleFrm.SetColorID(\r\n const Value: TJvFullColorSpaceID);\r\nbegin\r\n FDelta.ColorID := Value;\r\n if not FUpdating then\r\n begin\r\n JvColorSpaceCombo.ColorSpaceID := Value;\r\n UpdateColorSpace;\r\n UpdateDeltaValue;\r\n UpdateCheckBoxStates;\r\n end;\r\nend;\r\n\r\nprocedure TJvFullColorCircleFrm.SetRedDelta(const Value: TJvAxisDelta);\r\nbegin\r\n FDelta.AxisRed.Assign(Value);\r\n if not FUpdating then\r\n begin\r\n UpdateDeltaValue;\r\n UpdateCheckBoxStates;\r\n end;\r\nend;\r\n\r\nprocedure TJvFullColorCircleFrm.CalcDeltaValue(ARotateColor: TJvRotateColor);\r\nvar\r\n I: TJvAxisIndex;\r\n AxisDelta: TJvAxisDelta;\r\n\r\n function GetDelta(OldValue: Integer; ColorAxisValue: Integer;\r\n InitAxisValue, AxisMin, AxisMax: Byte): Integer;\r\n var\r\n AxisLength: Integer;\r\n Offset1, Offset2, Offset3: Integer;\r\n begin\r\n AxisLength := AxisMax - AxisMin + 1;\r\n Offset1 := Abs(ColorAxisValue - AxisLength - OldValue - InitAxisValue);\r\n Offset2 := Abs(ColorAxisValue - OldValue - InitAxisValue);\r\n Offset3 := Abs(ColorAxisValue + AxisLength - OldValue - InitAxisValue);\r\n if (Offset1 < Offset2) and (Offset1 < Offset3) then\r\n Result := (ColorAxisValue - AxisLength) - InitAxisValue\r\n else\r\n if Offset2 < Offset3 then\r\n Result := ColorAxisValue - InitAxisValue\r\n else\r\n Result := (ColorAxisValue + AxisLength) - InitAxisValue;\r\n\r\n Result := EnsureRange(Result, -AxisLength, AxisLength);\r\n end;\r\n\r\nbegin\r\n if FUpdating then\r\n Exit;\r\n\r\n FUpdating := True;\r\n AxisDelta := TJvAxisDelta.Create;\r\n try\r\n if ARotateColor = rcCommon then\r\n begin\r\n for I := Low(TJvAxisIndex) to High(TJvAxisIndex) do\r\n begin\r\n AxisDelta[I].Value := GetDelta(RedDelta[I].Value, GetAxisValue(JvColorCircle.FullColor, I),\r\n FComAxis[I], FAxisMin[I], FAxisMax[I]);\r\n AxisDelta[I].SaturationMethod := RedDelta[I].SaturationMethod;\r\n end;\r\n RedDelta.Assign(AxisDelta);\r\n GreenDelta.Assign(RedDelta);\r\n BlueDelta.Assign(RedDelta);\r\n end\r\n else\r\n begin\r\n if ARotateColor = rcRed then\r\n begin\r\n //RedDelta := GetDelta(RedDelta, JvColorCircle.RedColor, FRedAxis0, FRedAxis1, FRedAxis2);\r\n for I := Low(TJvAxisIndex) to High(TJvAxisIndex) do\r\n begin\r\n AxisDelta[I].Value := GetDelta(RedDelta[I].Value, GetAxisValue(JvColorCircle.RedColor, I),\r\n FRedAxis[I], FAxisMin[I], FAxisMax[I]);\r\n AxisDelta[I].SaturationMethod := RedDelta[I].SaturationMethod;\r\n end;\r\n RedDelta.Assign(AxisDelta);\r\n end;\r\n\r\n if ARotateColor = rcGreen then\r\n begin\r\n //GreenDelta := GetDelta(GreenDelta, JvColorCircle.GreenColor, FGreenAxis0, FGreenAxis1, FGreenAxis2);\r\n for I := Low(TJvAxisIndex) to High(TJvAxisIndex) do\r\n begin\r\n AxisDelta[I].Value := GetDelta(GreenDelta[I].Value, GetAxisValue(JvColorCircle.GreenColor, I),\r\n FGreenAxis[I], FAxisMin[I], FAxisMax[I]);\r\n AxisDelta[I].SaturationMethod := GreenDelta[I].SaturationMethod;\r\n end;\r\n GreenDelta.Assign(AxisDelta);\r\n end;\r\n\r\n if ARotateColor = rcBlue then\r\n begin\r\n //BlueDelta := GetDelta(BlueDelta, JvColorCircle.BlueColor, FBlueAxis0, FBlueAxis1, FBlueAxis2);\r\n for I := Low(TJvAxisIndex) to High(TJvAxisIndex) do\r\n begin\r\n AxisDelta[I].Value := GetDelta(BlueDelta[I].Value, GetAxisValue(JvColorCircle.BlueColor, I),\r\n FBlueAxis[I], FAxisMin[I], FAxisMax[I]);\r\n AxisDelta[I].SaturationMethod := BlueDelta[I].SaturationMethod;\r\n end;\r\n BlueDelta.Assign(AxisDelta);\r\n end;\r\n end;\r\n finally\r\n FUpdating := False;\r\n AxisDelta.Free;\r\n end;\r\n\r\n UpdateDeltaValue;\r\nend;\r\n\r\nprocedure TJvFullColorCircleFrm.JvColorCircleBlueColorChange(Sender: TObject);\r\nbegin\r\n if not FUpdating then\r\n CalcDeltaValue(rcBlue);\r\nend;\r\n\r\nprocedure TJvFullColorCircleFrm.JvColorCircleColorChange(Sender: TObject);\r\nbegin\r\n if not FUpdating then\r\n CalcDeltaValue(rcCommon);\r\nend;\r\n\r\nprocedure TJvFullColorCircleFrm.JvColorCircleGreenColorChange(Sender: TObject);\r\nbegin\r\n if not FUpdating then\r\n CalcDeltaValue(rcGreen);\r\nend;\r\n\r\nprocedure TJvFullColorCircleFrm.JvColorCircleRedColorChange(Sender: TObject);\r\nbegin\r\n if not FUpdating then\r\n CalcDeltaValue(rcRed);\r\nend;\r\n\r\nprocedure TJvFullColorCircleFrm.JvColorAxisConfigComboChange(Sender: TObject);\r\nbegin\r\n if not FUpdating then\r\n begin\r\n FUpdating := True;\r\n JvColorCircle.AxisConfig := (Sender as TJvFullColorAxisCombo).Selected;\r\n FUpdating := False;\r\n end;\r\nend;\r\n\r\nprocedure TJvFullColorCircleFrm.JvColorCircleColorSpaceChange(Sender: TObject);\r\nbegin\r\n CalcDeltaValue(rcRed);\r\n CalcDeltaValue(rcGreen);\r\n CalcDeltaValue(rcBlue);\r\nend;\r\n\r\nprocedure TJvFullColorCircleFrm.SpinEditSettingsValueChange(Sender: TObject);\r\nvar\r\n Idx: TJvAxisIndex;\r\n AxisDelta: TJvAxisDelta;\r\n IntValue:Integer;\r\n TagValue:Integer;\r\nbegin\r\n if FUpdating then\r\n Exit;\r\n\r\n with Sender as TJvSpinEdit do\r\n begin\r\n if not TryStrToInt(Text,IntValue) then\r\n Exit;\r\n TagValue := Tag;\r\n Idx := AxisIndexFromTag(TagValue);\r\n end;\r\n\r\n FUpdating := True;\r\n\r\n case TagValue and $30 of\r\n $00:\r\n begin\r\n AxisDelta := RedDelta;\r\n AxisDelta[Idx].Value := IntValue;\r\n RedDelta := AxisDelta;\r\n end;\r\n $10:\r\n begin\r\n AxisDelta := GreenDelta;\r\n AxisDelta[Idx].Value := IntValue;\r\n GreenDelta := AxisDelta;\r\n end;\r\n $20:\r\n begin\r\n AxisDelta := BlueDelta;\r\n AxisDelta[Idx].Value := IntValue;\r\n BlueDelta := AxisDelta;\r\n end;\r\n $30:\r\n begin\r\n AxisDelta := RedDelta;\r\n AxisDelta[Idx].Value := IntValue;\r\n RedDelta := AxisDelta;\r\n GreenDelta := AxisDelta;\r\n BlueDelta := AxisDelta;\r\n end;\r\n end;\r\n\r\n FUpdating := False;\r\n\r\n UpdateDeltaValue;\r\nend;\r\n\r\nprocedure InitializeStrings;\r\nvar\r\n LTypInfo: PTypeInfo;\r\n LString: string;\r\nbegin\r\n LTypInfo := TypeInfo(TJvSaturationMethod);\r\n LString := GetEnumName(LTypInfo, Integer(smLoop));\r\n GlobalLoop := Copy(LString, 3, Length(LString) - 2);\r\n LString := GetEnumName(LTypInfo, Integer(smRange));\r\n GlobalRange := Copy(LString, 3, Length(LString) - 2);\r\nend;\r\n\r\ninitialization\r\n {$IFDEF UNITVERSIONING}\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n {$ENDIF UNITVERSIONING}\r\n InitializeStrings;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvFullColorCtrls.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: ColorCtrls.pas, released on 2004-09-11.\r\n\r\nThe Initial Developer of the Original Code is Florent Ouchet [ouchet dott florent att laposte dott net]\r\nPortions created by Florent Ouchet are Copyright (C) 2004 Florent Ouchet.\r\nAll Rights Reserved.\r\n\r\nContributor(s): -\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvFullColorCtrls.pas 13104 2011-09-07 06:50:43Z obones $\r\n\r\nunit JvFullColorCtrls;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, Messages, SysUtils, Classes, Controls, Graphics,\r\n ComCtrls, StdCtrls, ExtCtrls, Types,\r\n JvJCLUtils, JvTypes, JvCombobox, JvFullColorSpaces, JvFullColorRotate;\r\n\r\ntype\r\n TJvFullColorAxisConfig = (acXYZ, acXZY, acYXZ, acYZX, acZXY, acZYX);\r\n TJvFullColorOrientation = (coNormal, coInverse);\r\n TJvArrowPosition = (apNormal, apOpposite);\r\n\r\ntype\r\n TJvKeyCode = (kcLeft, kcRight, kcUp, kcDown);\r\n\r\n TJvFullColorMouseEvent = procedure(Sender: TObject; ColorX, ColorY: Byte) of object;\r\n TJvFullColorComponent = class;\r\n TJvFullColorPanel = class;\r\n TJvFullColorCircle = class;\r\n TJvFullColorTrackBar = class;\r\n\r\n EJvFullColorError = class(EJVCLException);\r\n\r\n TJvFullColorComponent = class(TCustomControl)\r\n private\r\n FAutoMouse: Boolean;\r\n FFullColor: TJvFullColor;\r\n FAxisConfig: TJvFullColorAxisConfig;\r\n FOnColorChange: TNotifyEvent;\r\n FOnAxisConfigChange: TNotifyEvent;\r\n FOnColorSpaceChange: TNotifyEvent;\r\n FOnMouseColor: TJvFullColorMouseEvent;\r\n FColorChanging: Boolean;\r\n FBuffer: TBitmap;\r\n FCreating: Boolean;\r\n FWantDrawBuffer: Boolean;\r\n FMouseDragging: Boolean;\r\n function GetColorSpace: TJvColorSpace;\r\n procedure SetAxisConfig(const Value: TJvFullColorAxisConfig);\r\n procedure WMGetDlgCode(var Msg: TWMGetDlgCode); message WM_GETDLGCODE;\r\n procedure CMColorChanged(var Msg: TMessage); message CM_COLORCHANGED;\r\n procedure CMSysColorChange(var Msg: TMessage); message CM_SYSCOLORCHANGE;\r\n procedure SetWantDrawBuffer(Value: Boolean);\r\n protected\r\n procedure Paint; override;\r\n procedure KeyDown(var Key: Word; Shift: TShiftState); override;\r\n procedure DoEnter; override;\r\n procedure DoExit; override;\r\n procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;\r\n procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;\r\n procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;\r\n procedure DrawFocus;\r\n procedure DrawFrame(X, Y: Integer);\r\n procedure SetFullColor(const Value: TJvFullColor); virtual;\r\n procedure MouseColor(Shift: TShiftState; X, Y: Integer); virtual;\r\n procedure AxisConfigChange; virtual;\r\n procedure DrawBuffer; virtual;\r\n procedure ColorSpaceChange; virtual;\r\n procedure CalcSize; virtual;\r\n procedure KeyMove(KeyCode: TJvKeyCode; MoveCount: Integer); virtual;\r\n procedure InvalidateCursor; virtual; abstract;\r\n property WantDrawBuffer: Boolean read FWantDrawBuffer write SetWantDrawBuffer;\r\n property MouseDragging: Boolean read FMouseDragging;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n procedure SetBounds(ALeft, ATop, AWidth, AHeight: Integer); override;\r\n property ColorSpace: TJvColorSpace read GetColorSpace;\r\n published\r\n property AutoMouse: Boolean read FAutoMouse write FAutoMouse default True;\r\n property FullColor: TJvFullColor read FFullColor write SetFullColor;\r\n property AxisConfig: TJvFullColorAxisConfig read FAxisConfig write SetAxisConfig default acXYZ;\r\n property OnMouseMove;\r\n property OnMouseDown;\r\n property OnMouseUp;\r\n property Color;\r\n property ParentColor;\r\n property TabOrder;\r\n property TabStop default True;\r\n property OnColorChange: TNotifyEvent read FOnColorChange write FOnColorChange;\r\n property OnAxisConfigChange: TNotifyEvent read FOnAxisConfigChange write FOnAxisConfigChange;\r\n property OnColorSpaceChange: TNotifyEvent read FOnColorSpaceChange write FOnColorSpaceChange;\r\n property OnMouseColor: TJvFullColorMouseEvent read FOnMouseColor write FOnMouseColor;\r\n end;\r\n\r\n TJvFullColorComponent2D = class(TJvFullColorComponent)\r\n private\r\n FValueZAuto: Boolean;\r\n FValueZ: Byte;\r\n FAxisConfigChanging: Boolean;\r\n procedure SetValueZ(const Value: Byte);\r\n procedure SetValueZAuto(const Value: Boolean);\r\n procedure UpdateDefaultValueZ;\r\n function IsValueZStored: Boolean;\r\n protected\r\n procedure AxisConfigChange; override;\r\n procedure ColorSpaceChange; override;\r\n procedure TrackBarColorChange(Sender: TObject); virtual;\r\n procedure TrackBarAxisConfigChange(Sender: TObject); virtual;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n published\r\n property ValueZAuto: Boolean read FValueZAuto write SetValueZAuto stored False;\r\n property ValueZ: Byte read FValueZ write SetValueZ stored IsValueZStored default 0;\r\n end;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvFullColorPanel = class(TJvFullColorComponent2D)\r\n private\r\n FReverseAxisY: Boolean;\r\n FReverseAxisX: Boolean;\r\n FCrossSize: Integer;\r\n FPen: TPen;\r\n FCrossCenter: Integer;\r\n FColorTrackBar: TJvFullColorTrackBar;\r\n FAxisConfigChanging: Boolean;\r\n procedure SetReverseAxisX(const Value: Boolean);\r\n procedure SetReverseAxisY(const Value: Boolean);\r\n procedure SetCrossSize(Value: Integer);\r\n procedure SetCrossCenter(Value: Integer);\r\n procedure SetPen(const Value: TPen);\r\n procedure SetColorTrackBar(const Value: TJvFullColorTrackBar);\r\n protected\r\n procedure PenChange(Sender: TObject);\r\n procedure MouseColor(Shift: TShiftState; X, Y: Integer); override;\r\n procedure Notification(AComponent: TComponent; Operation: TOperation); override;\r\n procedure SetFullColor(const Value: TJvFullColor); override;\r\n procedure DrawBuffer; override;\r\n procedure CalcSize; override;\r\n procedure AxisConfigChange; override;\r\n procedure KeyMove(KeyCode: TJvKeyCode; MoveCount: Integer); override;\r\n procedure InvalidateCursor; override;\r\n function GetCursorPosition: TPoint;\r\n procedure Paint; override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n published\r\n property ReverseAxisX: Boolean read FReverseAxisX write SetReverseAxisX default False;\r\n property ReverseAxisY: Boolean read FReverseAxisY write SetReverseAxisY default False;\r\n property CrossSize: Integer read FCrossSize write SetCrossSize default 5;\r\n property CrossCenter: Integer read FCrossCenter write SetCrossCenter default 1;\r\n property CrossStyle: TPen read FPen write SetPen;\r\n property ColorTrackBar: TJvFullColorTrackBar read FColorTrackBar write SetColorTrackBar;\r\n end;\r\n\r\n TJvFullColorCircleStyle = (csShowLines, csShowCommon, csShowRed, csShowGreen,\r\n csShowBlue, cs3ButtonsMouse, cs3ButtonsCommon);\r\n\r\n TJvFullColorCircleStyles = set of TJvFullColorCircleStyle;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvFullColorCircle = class(TJvFullColorComponent2D)\r\n private\r\n FStyles: TJvFullColorCircleStyles;\r\n FGreenColor: TJvFullColor;\r\n FBlueColor: TJvFullColor;\r\n FRedColor: TJvFullColor;\r\n FInvertRotation: Boolean;\r\n FInvertRadius: Boolean;\r\n FCrossCenter: Integer;\r\n FCrossSize: Integer;\r\n FCrossStyle: TPen;\r\n FLineWidth: Integer;\r\n FDraggingColor: TJvRotateColor;\r\n FOnRedColorChange: TNotifyEvent;\r\n FOnBlueColorChange: TNotifyEvent;\r\n FOnGreenColorChange: TNotifyEvent;\r\n FOnColorSpaceChange: TNotifyEvent;\r\n FBlueColorTrackBar: TJvFullColorTrackBar;\r\n FGreenColorTrackBar: TJvFullColorTrackBar;\r\n FRedColorTrackBar: TJvFullColorTrackBar;\r\n FCommonColorTrackBar: TJvFullColorTrackBar;\r\n FCrossRedColor: TColor;\r\n FCrossBlueColor: TColor;\r\n FCrossGreenColor: TColor;\r\n procedure SetBlueColor(const Value: TJvFullColor);\r\n procedure SetGreenColor(const Value: TJvFullColor);\r\n procedure SetRedColor(const Value: TJvFullColor);\r\n procedure SetStyles(const Value: TJvFullColorCircleStyles);\r\n procedure SetInvertRadius(const Value: Boolean);\r\n procedure SetInvertRotation(const Value: Boolean);\r\n procedure SetCrossCenter(Value: Integer);\r\n procedure SetCrossSize(Value: Integer);\r\n procedure SetCrossStyle(const Value: TPen);\r\n procedure SetLineWidth(Value: Integer);\r\n procedure SetBlueColorTrackBar(const Value: TJvFullColorTrackBar);\r\n procedure SetGreenColorTrackBar(const Value: TJvFullColorTrackBar);\r\n procedure SetRedColorTrackBar(const Value: TJvFullColorTrackBar);\r\n procedure SetCommonColorTrackBar(const Value: TJvFullColorTrackBar);\r\n procedure SetCrossBlueColor(const Value: TColor);\r\n procedure SetCrossGreenColor(const Value: TColor);\r\n procedure SetCrossRedColor(const Value: TColor);\r\n protected\r\n procedure AxisConfigChange; override;\r\n procedure ColorSpaceChange; override;\r\n procedure Paint; override;\r\n procedure InvalidateColors(AColor1, AColor2: TJvFullColor);\r\n procedure PenChanged(Sender: TObject);\r\n procedure DrawBuffer; override;\r\n procedure CalcSize; override;\r\n procedure SetFullColor(const Value: TJvFullColor); override;\r\n procedure MouseUp(Button: TMouseButton; Shift: TShiftState;\r\n X, Y: Integer); override;\r\n procedure MouseColor(Shift: TShiftState;\r\n X, Y: Integer); override;\r\n procedure KeyMove(KeyCode: TJvKeyCode; MoveCount: Integer); override;\r\n procedure Notification(AComponent: TComponent; Operation: TOperation); override;\r\n procedure TrackBarColorChange(Sender: TObject); override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n procedure ConvertToID(NewFullColor: TJvFullColor);\r\n function FullColorToPosition(AFullColor: TJvFullColor): TPoint;\r\n function PositionToFullColor(APoint: TPoint): TJvFullColor;\r\n published\r\n property Color;\r\n property ParentColor;\r\n property InvertRadius: Boolean read FInvertRadius write SetInvertRadius default False;\r\n property InvertRotation: Boolean read FInvertRotation write SetInvertRotation default False;\r\n property RedColor: TJvFullColor read FRedColor write SetRedColor default fclRGBRed;\r\n property GreenColor: TJvFullColor read FGreenColor write SetGreenColor default fclRGBLime;\r\n property BlueColor: TJvFullColor read FBlueColor write SetBlueColor default fclRGBBlue;\r\n property Styles: TJvFullColorCircleStyles read FStyles write SetStyles\r\n default [csShowLines, csShowRed, csShowGreen, csShowBlue];\r\n property CrossSize: Integer read FCrossSize write SetCrossSize default 5;\r\n property CrossCenter: Integer read FCrossCenter write SetCrossCenter default 1;\r\n property CrossStyle: TPen read FCrossStyle write SetCrossStyle;\r\n property CrossRedColor: TColor read FCrossRedColor write SetCrossRedColor default clMaroon;\r\n property CrossGreenColor: TColor read FCrossGreenColor write SetCrossGreenColor default clGreen;\r\n property CrossBlueColor: TColor read FCrossBlueColor write SetCrossBlueColor default clNavy;\r\n property LineWidth: Integer read FLineWidth write SetLineWidth default 1;\r\n property RedTrackBar: TJvFullColorTrackBar read FRedColorTrackBar write SetRedColorTrackBar;\r\n property GreenTrackBar: TJvFullColorTrackBar read FGreenColorTrackBar write SetGreenColorTrackBar;\r\n property BlueTrackBar: TJvFullColorTrackBar read FBlueColorTrackBar write SetBlueColorTrackBar;\r\n property CommonTrackBar: TJvFullColorTrackBar read FCommonColorTrackBar write SetCommonColorTrackBar;\r\n property OnRedColorChange: TNotifyEvent read FOnRedColorChange write FOnRedColorChange;\r\n property OnGreenColorChange: TNotifyEvent read FOnGreenColorChange write FOnGreenColorChange;\r\n property OnBlueColorChange: TNotifyEvent read FOnBlueColorChange write FOnBlueColorChange;\r\n property OnColorSpaceChange: TNotifyEvent read FOnColorSpaceChange write FOnColorSpaceChange;\r\n end;\r\n\r\n TJvCursorPoints = array [0..2] of TPoint;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvFullColorTrackBar = class(TJvFullColorComponent)\r\n private\r\n FArrowPosition: TJvArrowPosition;\r\n FColorOrientation: TJvFullColorOrientation;\r\n FOrientation: TTrackBarOrientation;\r\n FFullColorDrawing: Boolean;\r\n FArrowWidth: Integer;\r\n FArrowColor: TColor;\r\n FValueYAuto: Boolean;\r\n FValueXAuto: Boolean;\r\n FValueY: Byte;\r\n FValueX: Byte;\r\n FLink: TComponent;\r\n procedure SetArrowPosition(const Value: TJvArrowPosition);\r\n procedure SetColorOrientation(const Value: TJvFullColorOrientation);\r\n procedure SetOrientation(const Value: TTrackBarOrientation);\r\n procedure SetArrowWidth(const Value: Integer);\r\n procedure SetArrowColor(const Value: TColor);\r\n function IsValueXStored: Boolean;\r\n function IsValueYStored: Boolean;\r\n procedure SetValueX(const Value: Byte);\r\n procedure SetValueXAuto(const Value: Boolean);\r\n procedure SetValueY(const Value: Byte);\r\n procedure SetValueYAuto(const Value: Boolean);\r\n procedure UpdateDefaultValueX;\r\n procedure UpdateDefaultValueY;\r\n procedure SetFullColorDrawing(const Value: Boolean);\r\n protected\r\n procedure MouseColor(Shift: TShiftState; X, Y: Integer); override;\r\n procedure SetFullColor(const Value: TJvFullColor); override;\r\n procedure CalcSize; override;\r\n procedure DrawBuffer; override;\r\n procedure ColorSpaceChange; override;\r\n procedure AxisConfigChange; override;\r\n procedure KeyMove(KeyCode: TJvKeyCode; MoveCount: Integer); override;\r\n procedure InvalidateCursor; override;\r\n procedure Paint; override;\r\n function GetCursorPosition: TJvCursorPoints;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n function Linked: Boolean;\r\n function LinkerName: TComponentName;\r\n procedure SetLink(AComponent: TComponent);\r\n procedure FreeLink;\r\n published\r\n property ArrowColor: TColor read FArrowColor write SetArrowColor default clBlack;\r\n property ArrowWidth: Integer read FArrowWidth write SetArrowWidth default 9;\r\n property ArrowPosition: TJvArrowPosition read FArrowPosition write SetArrowPosition default apNormal;\r\n property ColorOrientation: TJvFullColorOrientation read FColorOrientation write SetColorOrientation\r\n default coNormal;\r\n property Orientation: TTrackBarOrientation read FOrientation write SetOrientation default trHorizontal;\r\n property ValueX: Byte read FValueX write SetValueX stored IsValueXStored;\r\n property ValueXAuto: Boolean read FValueXAuto write SetValueXAuto stored False;\r\n property ValueY: Byte read FValueY write SetValueY stored IsValueYStored;\r\n property ValueYAuto: Boolean read FValueYAuto write SetValueYAuto stored False;\r\n property FullColorDrawing: Boolean read FFullColorDrawing write SetFullColorDrawing default True;\r\n end;\r\n\r\n TJvShapePosition = (spLeft, spRight, spTop, spBottom);\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvFullColorLabel = class(TGraphicControl)\r\n private\r\n FBrush: TBrush;\r\n FPen: TPen;\r\n FCaption: TCaption;\r\n FShapeType: TShapeType;\r\n FShapeWidth: Integer;\r\n FShapeHeight: Integer;\r\n FShapePosition: TJvShapePosition;\r\n FSpacing: Integer;\r\n FRoundShapeWidth: Integer;\r\n FRoundShapeHeight: Integer;\r\n FLabelColor: TJvFullColor;\r\n procedure SetCaption(const Value: TCaption);\r\n procedure SetShapeType(const Value: TShapeType);\r\n procedure SetShapeHeight(const Value: Integer);\r\n procedure SetShapePosition(const Value: TJvShapePosition);\r\n procedure SetShapeWidth(const Value: Integer);\r\n procedure SetSpacing(const Value: Integer);\r\n procedure SetRoundShapeHeight(const Value: Integer);\r\n procedure SetRoundShapeWidth(const Value: Integer);\r\n procedure SetLabelColor(const Value: TJvFullColor);\r\n procedure SetBrush(const Value: TBrush);\r\n procedure SetPen(const Value: TPen);\r\n protected\r\n procedure Paint; override;\r\n procedure CalcSize;\r\n procedure SetAutoSize(Value: Boolean); override;\r\n procedure GraphicChange(Sender: TObject);\r\n procedure SetName(const Value: TComponentName); override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n published\r\n property LabelColor: TJvFullColor read FLabelColor write SetLabelColor default fclDEFWindowText;\r\n property Pen: TPen read FPen write SetPen;\r\n property Brush: TBrush read FBrush write SetBrush;\r\n property Shape: TShapeType read FShapeType write SetShapeType default stRectangle;\r\n property Caption: TCaption read FCaption write SetCaption;\r\n property ShapeWidth: Integer read FShapeWidth write SetShapeWidth default 16;\r\n property ShapeHeight: Integer read FShapeHeight write SetShapeHeight default 16;\r\n property ShapePosition: TJvShapePosition read FShapePosition write SetShapePosition default spLeft;\r\n property Spacing: Integer read FSpacing write SetSpacing default 5;\r\n property RoundShapeWidth: Integer read FRoundShapeWidth write SetRoundShapeWidth default 4;\r\n property RoundShapeHeight: Integer read FRoundShapeHeight write SetRoundShapeHeight default 4;\r\n property Align;\r\n property Anchors;\r\n property AutoSize;\r\n property BiDiMode;\r\n property Color nodefault;\r\n property Constraints;\r\n property DragCursor;\r\n property DragKind;\r\n property DragMode;\r\n property Enabled;\r\n property Font;\r\n property ParentBiDiMode;\r\n property ParentColor;\r\n property ParentFont;\r\n property ParentShowHint;\r\n property PopupMenu;\r\n property ShowHint;\r\n property Visible;\r\n property OnCanResize;\r\n property OnClick;\r\n property OnConstrainedResize;\r\n property OnContextPopup;\r\n property OnDblClick;\r\n property OnDragDrop;\r\n property OnDragOver;\r\n property OnEndDock;\r\n property OnEndDrag;\r\n property OnMouseDown;\r\n property OnMouseMove;\r\n property OnMouseUp;\r\n property OnMouseWheel;\r\n property OnMouseWheelDown;\r\n property OnMouseWheelUp;\r\n property OnResize;\r\n property OnStartDock;\r\n property OnStartDrag;\r\n end;\r\n\r\n TJvFullColorSpaceFormat = (cfName, cfShortName, cfBoth);\r\n\r\n TJvFullColorSpaceFormatEvent = procedure(Sender: TObject; AColorSpace: TJvColorSpace;\r\n out ACaption: string) of object;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvFullColorSpaceCombo = class(TJvCustomComboBox)\r\n private\r\n FAllowVariable: Boolean;\r\n FItemFormat: TJvFullColorSpaceFormat;\r\n FOnFormatItem: TJvFullColorSpaceFormatEvent;\r\n function GetColorSpace: TJvColorSpace;\r\n procedure SetAllowVariable(const Value: Boolean);\r\n procedure SetColorSpace(const Value: TJvColorSpace);\r\n procedure SetColorSpaceID(const Value: TJvFullColorSpaceID);\r\n function GetColorSpaceID: TJvFullColorSpaceID;\r\n procedure SetItemFormat(const Value: TJvFullColorSpaceFormat);\r\n protected\r\n procedure CreateWnd; override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n property SelectedSpace: TJvColorSpace read GetColorSpace write SetColorSpace;\r\n procedure MakeList; virtual;\r\n published\r\n property AllowVariable: Boolean read FAllowVariable write SetAllowVariable default True;\r\n property ColorSpaceID: TJvFullColorSpaceID read GetColorSpaceID write SetColorSpaceID default csRGB;\r\n property ItemFormat: TJvFullColorSpaceFormat read FItemFormat write SetItemFormat default cfBoth;\r\n property OnFormatItem: TJvFullColorSpaceFormatEvent read FOnFormatItem write FOnFormatItem;\r\n property AutoDropDown;\r\n property BevelEdges;\r\n property BevelInner;\r\n property BevelKind default bkNone;\r\n property BevelOuter;\r\n property Anchors;\r\n property BiDiMode;\r\n property Color;\r\n property Constraints;\r\n property DragCursor;\r\n property DragKind;\r\n property DragMode;\r\n property DropDownCount;\r\n property Enabled;\r\n property Flat;\r\n property ParentFlat;\r\n property Font;\r\n property ImeMode;\r\n property ImeName;\r\n property ItemHeight;\r\n property ParentBiDiMode;\r\n property ParentColor;\r\n property ParentFont;\r\n property ParentShowHint;\r\n property PopupMenu;\r\n property ShowHint;\r\n property Sorted;\r\n property TabOrder;\r\n property TabStop;\r\n property Visible;\r\n property OnChange;\r\n property OnClick;\r\n property OnCloseUp;\r\n property OnContextPopup;\r\n property OnDblClick;\r\n property OnDragDrop;\r\n property OnDragOver;\r\n property OnDrawItem;\r\n property OnDropDown;\r\n property OnEndDock;\r\n property OnEndDrag;\r\n property OnEnter;\r\n property OnExit;\r\n property OnKeyDown;\r\n property OnKeyPress;\r\n property OnKeyUp;\r\n property OnMeasureItem;\r\n property OnSelect;\r\n property OnStartDock;\r\n property OnStartDrag;\r\n end;\r\n\r\n TJvFullColorAxisConfigFormat = (afShort, afIndent, afComplete);\r\n\r\n TJvFullColorAxisFormatEvent = procedure(Sender: TObject; AAxisConfig: TJvFullColorAxisConfig;\r\n out ACaption: string) of object;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvFullColorAxisCombo = class(TJvCustomComboBox)\r\n private\r\n FItemFormat: TJvFullColorAxisConfigFormat;\r\n FColorID: TJvFullColorSpaceID;\r\n FOnFormatItem: TJvFullColorAxisFormatEvent;\r\n procedure SetItemFormat(const Value: TJvFullColorAxisConfigFormat);\r\n procedure SetSelected(const Value: TJvFullColorAxisConfig);\r\n procedure SetColorID(const Value: TJvFullColorSpaceID);\r\n function GetSelected: TJvFullColorAxisConfig;\r\n procedure SetOnFormatItem(const Value: TJvFullColorAxisFormatEvent);\r\n protected\r\n procedure MakeList; virtual;\r\n procedure CreateWnd; override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n published\r\n property ItemFormat: TJvFullColorAxisConfigFormat read FItemFormat write SetItemFormat default afComplete;\r\n property Selected: TJvFullColorAxisConfig read GetSelected write SetSelected;\r\n property ColorID: TJvFullColorSpaceID read FColorID write SetColorID default csRGB;\r\n property OnFormatItem: TJvFullColorAxisFormatEvent read FOnFormatItem write SetOnFormatItem;\r\n property AutoDropDown;\r\n property BevelEdges;\r\n property BevelInner;\r\n property BevelKind default bkNone;\r\n property BevelOuter;\r\n property Anchors;\r\n property BiDiMode;\r\n property Color;\r\n property Constraints;\r\n property DragCursor;\r\n property DragKind;\r\n property DragMode;\r\n property DropDownCount;\r\n property Enabled;\r\n property Flat;\r\n property ParentFlat;\r\n property Font;\r\n property ImeMode;\r\n property ImeName;\r\n property ItemHeight;\r\n property ParentBiDiMode;\r\n property ParentColor;\r\n property ParentFont;\r\n property ParentShowHint;\r\n property PopupMenu;\r\n property ShowHint;\r\n property Sorted;\r\n property TabOrder;\r\n property TabStop;\r\n property Visible;\r\n property OnChange;\r\n property OnClick;\r\n property OnCloseUp;\r\n property OnContextPopup;\r\n property OnDblClick;\r\n property OnDragDrop;\r\n property OnDragOver;\r\n property OnDrawItem;\r\n property OnDropDown;\r\n property OnEndDock;\r\n property OnEndDrag;\r\n property OnEnter;\r\n property OnExit;\r\n property OnKeyDown;\r\n property OnKeyPress;\r\n property OnKeyUp;\r\n property OnMeasureItem;\r\n property OnSelect;\r\n property OnStartDock;\r\n property OnStartDrag;\r\n end;\r\n\r\n TJvFullColorArray = array [0..{$IFDEF RTL230_UP}Maxint div 16{$ELSE}MaxListSize{$ENDIF RTL230_UP} - 1] of TJvFullColor;\r\n PJvFullColorArray = ^TJvFullColorArray;\r\n\r\n TJvFullColorListOperation = (foAllChanged, foDeleted, foAdded, foChanged);\r\n\r\n TJvFullColorListEvent = procedure(Sender: TObject; Index: Integer;\r\n Operation: TJvFullColorListOperation) of object;\r\n\r\n EJvFullColorListError = class(Exception);\r\n\r\n TJvFullColorList = class(TPersistent)\r\n private\r\n FCapacity: Integer;\r\n FCount: Integer;\r\n FList: PJvFullColorArray;\r\n FOnChange: TJvFullColorListEvent;\r\n FUpdateCount: Integer;\r\n FAllocBy: Integer;\r\n procedure SetCapacity(const Value: Integer);\r\n procedure SetCount(const Value: Integer);\r\n procedure SetAllocBy(const Value: Integer);\r\n protected\r\n procedure Grow;\r\n function GetItem(Index: Integer): TJvFullColor;\r\n procedure SetItem(Index: Integer; const Value: TJvFullColor);\r\n procedure DefineProperties(Filer: TFiler); override;\r\n procedure WriteItems(Writer: TWriter);\r\n procedure ReadItems(Reader: TReader);\r\n procedure Change(AIndex: Integer; AOperation: TJvFullColorListOperation);\r\n public\r\n constructor Create;\r\n destructor Destroy; override;\r\n function Add(AColor: TJvFullColor): Integer;\r\n procedure Assign(Source: TPersistent); override;\r\n procedure Clear;\r\n function Remove(AColor: TJvFullColor): Integer;\r\n procedure Delete(Index: Integer);\r\n procedure Exchange(Index1, Index2: Integer);\r\n procedure Insert(Index: Integer; AColor: TJvFullColor);\r\n function IndexOf(AColor: TJvFullColor): Integer;\r\n procedure DeleteRedundant;\r\n procedure BeginUpdate;\r\n procedure EndUpdate;\r\n property AllocBy: Integer read FAllocBy write SetAllocBy;\r\n property Items[Index: Integer]: TJvFullColor read GetItem write SetItem; default;\r\n property List: PJvFullColorArray read FList;\r\n property Capacity: Integer read FCapacity write SetCapacity;\r\n property Count: Integer read FCount write SetCount;\r\n property UpdateCount: Integer read FUpdateCount;\r\n property OnChange: TJvFullColorListEvent read FOnChange write FOnChange;\r\n end;\r\n\r\n TJvFullColorEdge = (feRaised, feLowered, feFlat);\r\n TJvFormatHintEvent = procedure(Sender: TObject; HintColor: TJvFullColor;\r\n var HintText: string) of object;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvFullColorGroup = class(TCustomControl)\r\n private\r\n FItems: TJvFullColorList;\r\n FColCount: Integer;\r\n FEdge: TJvFullColorEdge;\r\n FSelectedEdge: TJvFullColorEdge;\r\n FMouseEdge: TJvFullColorEdge;\r\n FSquareSize: Integer;\r\n FMouseIndex: Integer;\r\n FSelectedIndex: Integer;\r\n FBrush: TBrush;\r\n FOnChange: TNotifyEvent;\r\n FOnFormatHint: TJvFormatHintEvent;\r\n procedure SetItems(const Value: TJvFullColorList);\r\n procedure SetColCount(const Value: Integer);\r\n function GetRowCount: Integer;\r\n procedure SetEdge(const Value: TJvFullColorEdge);\r\n procedure SetMouseEdge(const Value: TJvFullColorEdge);\r\n procedure SetSelectedEdge(const Value: TJvFullColorEdge);\r\n procedure SetSquareSize(const Value: Integer);\r\n function GetSelected: TJvFullColor;\r\n procedure SetSelected(const Value: TJvFullColor);\r\n procedure SetSelectedIndex(const Value: Integer);\r\n procedure SetBrush(const Value: TBrush);\r\n procedure MouseLeave(var Msg: TWMMouse); message WM_MOUSELEAVE;\r\n procedure CMHintShow(var Msg: TMessage); message CM_HINTSHOW;\r\n protected\r\n procedure Paint; override;\r\n procedure ItemsChange(Sender: TObject; Index: Integer;\r\n Operation: TJvFullColorListOperation);\r\n procedure BrushChange(Sender: TObject);\r\n procedure MouseDown(Button: TMouseButton; Shift: TShiftState;\r\n X, Y: Integer); override;\r\n procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;\r\n procedure CalcRects(out XPos, YPos, XInc, YInc: Integer);\r\n procedure InvalidateIndex(AIndex: Integer);\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n property MouseIndex: Integer read FMouseIndex;\r\n property SelectedIndex: Integer read FSelectedIndex write SetSelectedIndex;\r\n property Selected: TJvFullColor read GetSelected write SetSelected;\r\n property RowCount: Integer read GetRowCount;\r\n published\r\n property Items: TJvFullColorList read FItems write SetItems;\r\n property ColCount: Integer read FColCount write SetColCount default 4;\r\n property Edge: TJvFullColorEdge read FEdge write SetEdge default feRaised;\r\n property SelectedEdge: TJvFullColorEdge read FSelectedEdge write SetSelectedEdge default feLowered;\r\n property MouseEdge: TJvFullColorEdge read FMouseEdge write SetMouseEdge default feRaised;\r\n property SquareSize: Integer read FSquareSize write SetSquareSize default 6;\r\n property Brush: TBrush read FBrush write SetBrush;\r\n property OnChange: TNotifyEvent read FOnChange write FOnChange;\r\n property OnFormatHint: TJvFormatHintEvent read FOnFormatHint write FOnFormatHint;\r\n property Align;\r\n property Anchors;\r\n property BevelInner;\r\n property BevelOuter;\r\n property BevelEdges;\r\n property BevelKind default bkTile;\r\n property BevelWidth;\r\n property BorderWidth;\r\n property Color;\r\n property Constraints;\r\n property Hint;\r\n property ParentShowHint;\r\n property ParentColor;\r\n property ShowHint;\r\n property Visible;\r\n end;\r\n\r\nfunction GetIndexAxis(AxisConfig: TJvFullColorAxisConfig; AxisID: TJvAxisIndex): TJvAxisIndex;\r\nfunction GetIndexAxisX(AxisConfig: TJvFullColorAxisConfig): TJvAxisIndex;\r\nfunction GetIndexAxisY(AxisConfig: TJvFullColorAxisConfig): TJvAxisIndex;\r\nfunction GetIndexAxisZ(AxisConfig: TJvFullColorAxisConfig): TJvAxisIndex;\r\nfunction ColorSpaceToString(AColorSpace: TJvColorSpace;\r\n ItemFormat: TJvFullColorSpaceFormat): string;\r\nfunction AxisConfigToString(AxisConfig: TJvFullColorAxisConfig;\r\n ItemFormat: TJvFullColorAxisConfigFormat; AColorSpace: TJvColorSpace): string;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvFullColorCtrls.pas $';\r\n Revision: '$Revision: 13104 $';\r\n Date: '$Date: 2011-09-07 08:50:43 +0200 (mer. 07 sept. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n RTLConsts, TypInfo, Forms,\r\n JclMath, JclLogic, // For EnsureRange and Min/Max\r\n JvResources, JvConsts, JvJVCLUtils;\r\n\r\ntype\r\n TJvFullColorAxisConfigs = array [TJvAxisIndex] of TJvAxisIndex;\r\n\r\nconst\r\n TabAxisConfigs: array [TJvFullColorAxisConfig] of TJvFullColorAxisConfigs =\r\n ((axIndex0, axIndex1, axIndex2),\r\n (axIndex0, axIndex2, axIndex1),\r\n (axIndex1, axIndex0, axIndex2),\r\n (axIndex2, axIndex0, axIndex1),\r\n (axIndex1, axIndex2, axIndex0),\r\n (axIndex2, axIndex1, axIndex0));\r\n\r\nfunction ColorSpaceToString(AColorSpace: TJvColorSpace; ItemFormat: TJvFullColorSpaceFormat): string;\r\nbegin\r\n case ItemFormat of\r\n cfName:\r\n Result := AColorSpace.Name;\r\n cfShortName:\r\n Result := AColorSpace.ShortName;\r\n else\r\n Result := Format('%s (%s)', [AColorSpace.Name, AColorSpace.ShortName]);\r\n end;\r\nend;\r\n\r\nfunction AxisConfigToString(AxisConfig: TJvFullColorAxisConfig;\r\n ItemFormat: TJvFullColorAxisConfigFormat; AColorSpace: TJvColorSpace): string;\r\nvar\r\n Str: string;\r\n AxisConfigs: TJvFullColorAxisConfigs;\r\nbegin\r\n Str := GetEnumName(TypeInfo(TJvFullColorAxisConfig), Ord(AxisConfig));\r\n case ItemFormat of\r\n afShort:\r\n Result := Copy(Str, 3, Length(Str) - 2);\r\n afIndent:\r\n Result := Str;\r\n else\r\n AxisConfigs := TabAxisConfigs[AxisConfig];\r\n Result := Format('[%s] = %s ; [%s] = %s ; [%s] = %s',\r\n [Str[3], AColorSpace.AxisName[axIndex0], Str[4],\r\n AColorSpace.AxisName[axIndex1], Str[5], AColorSpace.AxisName[axIndex2]]);\r\n end;\r\nend;\r\n\r\nfunction GetIndexAxis(AxisConfig: TJvFullColorAxisConfig; AxisID: TJvAxisIndex): TJvAxisIndex;\r\nbegin\r\n Result := TabAxisConfigs[AxisConfig][AxisID];\r\nend;\r\n\r\nfunction GetIndexAxisX(AxisConfig: TJvFullColorAxisConfig): TJvAxisIndex;\r\nbegin\r\n Result := TabAxisConfigs[AxisConfig][axIndex0];\r\nend;\r\n\r\nfunction GetIndexAxisY(AxisConfig: TJvFullColorAxisConfig): TJvAxisIndex;\r\nbegin\r\n Result := TabAxisConfigs[AxisConfig][axIndex1];\r\nend;\r\n\r\nfunction GetIndexAxisZ(AxisConfig: TJvFullColorAxisConfig): TJvAxisIndex;\r\nbegin\r\n Result := TabAxisConfigs[AxisConfig][axIndex2];\r\nend;\r\n\r\n//=== { TJvColorComponent } ==================================================\r\n\r\nconstructor TJvFullColorComponent.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FBuffer := TBitmap.Create;\r\n FBuffer.PixelFormat := pf32Bit;\r\n FAutoMouse := True;\r\n FAxisConfig := acXYZ;\r\n FFullColor := fclRGBWhite;\r\n\r\n TabStop := True;\r\n ControlStyle := [csSetCaption, csOpaque];\r\n Width := 100;\r\n Height := 100;\r\nend;\r\n\r\ndestructor TJvFullColorComponent.Destroy;\r\nbegin\r\n FBuffer.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvFullColorComponent.SetBounds(ALeft, ATop, AWidth,\r\n AHeight: Integer);\r\nbegin\r\n inherited SetBounds(ALeft, ATop, AWidth, AHeight);\r\n CalcSize;\r\nend;\r\n\r\nprocedure TJvFullColorComponent.CalcSize;\r\nbegin\r\n WantDrawBuffer := True;\r\nend;\r\n\r\nprocedure TJvFullColorComponent.DrawBuffer;\r\nbegin\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvFullColorComponent.Paint;\r\nbegin\r\n if WantDrawBuffer then\r\n DrawBuffer;\r\n WantDrawBuffer := False;\r\n inherited Paint;\r\nend;\r\n\r\nprocedure TJvFullColorComponent.DrawFocus;\r\nbegin\r\n if Focused and not (csDesigning in ComponentState) then\r\n with Canvas do\r\n begin\r\n Pen.Color := Color;\r\n Brush.Color := Color;\r\n DrawFocusRect(ClientRect);\r\n end;\r\nend;\r\n\r\nprocedure TJvFullColorComponent.DrawFrame(X, Y: Integer);\r\nbegin\r\n Canvas.Brush.Color := Color;\r\n Canvas.FillRect(Rect(0, 0, Width, Y));\r\n Canvas.FillRect(Rect(0, Y + FBuffer.Height, Width, Height));\r\n Canvas.FillRect(Rect(0, Y, X, Y + FBuffer.Height));\r\n Canvas.FillRect(Rect(X + FBuffer.Width, Y, Width, Y + FBuffer.Height));\r\nend;\r\n\r\nprocedure TJvFullColorComponent.SetFullColor(const Value: TJvFullColor);\r\nvar\r\n NewColorID: TJvFullColorSpaceID;\r\n OldColorID: TJvFullColorSpaceID;\r\n OldColor: TJvFullColor;\r\nbegin\r\n if Value <> FullColor then\r\n begin\r\n OldColor := FFullColor;\r\n NewColorID := ColorSpaceManager.GetColorSpaceID(Value);\r\n if NewColorID = csDEF then\r\n raise EJvFullColorError.CreateResFmt(@RsEUnsupportedColorSpace, [NewColorID]);\r\n OldColorID := ColorSpaceManager.GetColorSpaceID(OldColor);\r\n FFullColor := Value;\r\n if OldColorID <> ColorSpaceManager.GetColorSpaceID(FFullColor) then\r\n ColorSpaceChange;\r\n\r\n if Assigned(FOnColorChange) then\r\n FOnColorChange(Self);\r\n end;\r\nend;\r\n\r\nprocedure TJvFullColorComponent.MouseColor(Shift: TShiftState; X, Y: Integer);\r\nbegin\r\n if Assigned(FOnMouseColor) then\r\n FOnMouseColor(Self, X, Y);\r\nend;\r\n\r\nprocedure TJvFullColorComponent.MouseDown(Button: TMouseButton;\r\n Shift: TShiftState; X, Y: Integer);\r\nbegin\r\n SetFocus;\r\n try\r\n if AutoMouse and (Shift * [ssLeft, ssMiddle, ssRight] <> []) then\r\n begin\r\n FMouseDragging := True;\r\n MouseColor(Shift, X, Y);\r\n end;\r\n inherited MouseDown(Button, Shift, X, Y);\r\n finally\r\n SetCapture(Handle);\r\n end;\r\nend;\r\n\r\nprocedure TJvFullColorComponent.MouseMove(Shift: TShiftState; X, Y: Integer);\r\nbegin\r\n if MouseDragging and AutoMouse and (Shift * [ssLeft, ssMiddle, ssRight] <> []) then\r\n MouseColor(Shift, X, Y);\r\n inherited MouseMove(Shift, X, Y);\r\nend;\r\n\r\nprocedure TJvFullColorComponent.MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);\r\nbegin\r\n try\r\n FMouseDragging := False;\r\n inherited MouseUp(Button, Shift, X, Y);\r\n finally\r\n ReleaseCapture;\r\n end;\r\nend;\r\n\r\nprocedure TJvFullColorComponent.SetAxisConfig(const Value: TJvFullColorAxisConfig);\r\nbegin\r\n if FAxisConfig <> Value then\r\n begin\r\n FAxisConfig := Value;\r\n AxisConfigChange;\r\n end;\r\nend;\r\n\r\nprocedure TJvFullColorComponent.ColorSpaceChange;\r\nbegin\r\n CalcSize;\r\n if Assigned(FOnColorSpaceChange) then\r\n FOnColorSpaceChange(Self);\r\nend;\r\n\r\nfunction TJvFullColorComponent.GetColorSpace: TJvColorSpace;\r\nbegin\r\n with ColorSpaceManager do\r\n Result := ColorSpace[GetColorSpaceID(FullColor)];\r\nend;\r\n\r\nprocedure TJvFullColorComponent.AxisConfigChange;\r\nbegin\r\n CalcSize;\r\n if Assigned(FOnAxisConfigChange) then\r\n FOnAxisConfigChange(Self);\r\nend;\r\n\r\nprocedure TJvFullColorComponent.SetWantDrawBuffer(Value: Boolean);\r\nbegin\r\n FWantDrawBuffer := Value;\r\n if Value and (Width <> 0) and (Height <> 0) then\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvFullColorComponent.WMGetDlgCode(var Msg: TWMGetDlgCode);\r\nbegin\r\n inherited;\r\n Msg.Result := DLGC_WANTARROWS;\r\nend;\r\n\r\nprocedure TJvFullColorComponent.DoEnter;\r\nbegin\r\n inherited DoEnter;\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvFullColorComponent.DoExit;\r\nbegin\r\n inherited DoExit;\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvFullColorComponent.KeyMove(KeyCode: TJvKeyCode; MoveCount: Integer);\r\nbegin\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvFullColorComponent.KeyDown(var Key: Word; Shift: TShiftState);\r\nbegin\r\n case Key of\r\n VK_LEFT:\r\n KeyMove(kcLeft, 1);\r\n VK_RIGHT:\r\n KeyMove(kcRight, 1);\r\n VK_UP:\r\n KeyMove(kcUp, 1);\r\n VK_DOWN:\r\n KeyMove(kcDown, 1);\r\n end;\r\nend;\r\n\r\nprocedure TJvFullColorComponent.CMColorChanged(var Msg: TMessage);\r\nbegin\r\n inherited;\r\n WantDrawBuffer := True;\r\nend;\r\n\r\nprocedure TJvFullColorComponent.CMSysColorChange(var Msg: TMessage);\r\nbegin\r\n inherited;\r\n WantDrawBuffer := True;\r\nend;\r\n\r\n//=== { TColor2D } ===========================================================\r\n\r\nconstructor TJvFullColorComponent2D.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FValueZ := 0;\r\n FValueZAuto := True;\r\n ColorSpaceChange;\r\nend;\r\n\r\nprocedure TJvFullColorComponent2D.AxisConfigChange;\r\nbegin\r\n UpdateDefaultValueZ;\r\n inherited AxisConfigChange;\r\nend;\r\n\r\nprocedure TJvFullColorComponent2D.ColorSpaceChange;\r\nbegin\r\n UpdateDefaultValueZ;\r\n inherited ColorSpaceChange;\r\nend;\r\n\r\nprocedure TJvFullColorComponent2D.TrackBarAxisConfigChange(Sender: TObject);\r\nbegin\r\n if not FAxisConfigChanging then\r\n begin\r\n FAxisConfigChanging := True;\r\n AxisConfig := (Sender as TJvFullColorTrackBar).AxisConfig;\r\n FAxisConfigChanging := False;\r\n end;\r\nend;\r\n\r\nprocedure TJvFullColorComponent2D.TrackBarColorChange(Sender: TObject);\r\nbegin\r\n if FColorChanging then\r\n Exit;\r\n\r\n FColorChanging := True;\r\n FullColor := (Sender as TJvFullColorTrackBar).FullColor;\r\n FColorChanging := False;\r\n\r\n if Assigned(FOnColorChange) then\r\n FOnColorChange(Self);\r\nend;\r\n\r\nfunction TJvFullColorComponent2D.IsValueZStored: Boolean;\r\nbegin\r\n Result := not ValueZAuto;\r\nend;\r\n\r\nprocedure TJvFullColorComponent2D.SetValueZ(const Value: Byte);\r\nbegin\r\n FValueZAuto := False;\r\n FValueZ := Value;\r\n WantDrawBuffer := True;\r\nend;\r\n\r\nprocedure TJvFullColorComponent2D.SetValueZAuto(const Value: Boolean);\r\nbegin\r\n FValueZAuto := Value;\r\n if Value then\r\n UpdateDefaultValueZ;\r\n WantDrawBuffer := True;\r\nend;\r\n\r\nprocedure TJvFullColorComponent2D.UpdateDefaultValueZ;\r\nbegin\r\n if ValueZAuto then\r\n FValueZ := ColorSpace.AxisDefault[GetIndexAxisZ(AxisConfig)];\r\nend;\r\n\r\n//=== { TJvColorPanel } ======================================================\r\n\r\nconstructor TJvFullColorPanel.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FCrossSize := 5;\r\n FCrossCenter := 1;\r\n FReverseAxisX := False;\r\n FReverseAxisY := False;\r\n FPen := TPen.Create;\r\n FPen.OnChange := PenChange;\r\n FColorChanging := False;\r\nend;\r\n\r\ndestructor TJvFullColorPanel.Destroy;\r\nbegin\r\n ColorTrackBar := nil;\r\n FPen.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvFullColorPanel.CalcSize;\r\nbegin\r\n FBuffer.Width := Max(Width - 2 * FCrossSize,0);\r\n FBuffer.Height := Max(Height - 2 * FCrossSize,0);\r\n inherited CalcSize;\r\nend;\r\n\r\nprocedure TJvFullColorPanel.DrawBuffer;\r\nvar\r\n AxisX, AxisY: TJvAxisIndex;\r\n IndexX, IndexY: Integer;\r\n MinX, MaxX, MinY, MaxY: Integer;\r\n RangeX, RangeY: Integer;\r\n TempColor: TJvFullColor;\r\n Line: PJvFullColorArray;\r\nbegin\r\n if (FBuffer.Width = 0) or (FBuffer.Height = 0) or (Width = 0) or (Height = 0) then\r\n Exit;\r\n\r\n AxisX := GetIndexAxisX(AxisConfig);\r\n AxisY := GetIndexAxisY(AxisConfig);\r\n\r\n with ColorSpace do\r\n begin\r\n MinX := AxisMin[AxisX];\r\n MaxX := AxisMax[AxisX];\r\n RangeX := MaxX - MinX;\r\n MinY := AxisMin[AxisY];\r\n MaxY := AxisMax[AxisY];\r\n RangeY := MaxY - MinY;\r\n\r\n\r\n TempColor := SetAxisValue(fclRGBBlack, GetIndexAxisZ(AxisConfig), ValueZ);\r\n with FBuffer do\r\n begin\r\n Canvas.Brush.Color := Color;\r\n Canvas.FillRect(Rect(0, 0, Width-1, Height-1));\r\n for IndexY := 0 to Height-1 do\r\n begin\r\n Line := ScanLine[IndexY];\r\n if ReverseAxisY then\r\n TempColor := SetAxisValue(TempColor, AxisY, MaxY - (RangeY * IndexY) div (Height - 1))\r\n else\r\n TempColor := SetAxisValue(TempColor, AxisY, (RangeY * IndexY) div (Height - 1) + MinY);\r\n for IndexX := 0 to Width-1 do\r\n begin\r\n if ReverseAxisX then\r\n TempColor := SetAxisValue(TempColor, AxisX, MaxX - (RangeX * IndexX) div (Width - 1))\r\n else\r\n TempColor := SetAxisValue(TempColor, AxisX, (RangeX * IndexX) div (Width - 1) + MinX);\r\n // (outchy) don't remove, Bitmap colors are stocked as (MSB) 00RRGGBB (LSB)\r\n // Delphi TColor is (MSB) 00BBGGRR (LSB)\r\n Line[IndexX] := RGBToBGR(ConvertToColor(TempColor));\r\n end;\r\n end;\r\n end;\r\n end;\r\n inherited DrawBuffer;\r\nend;\r\n\r\nfunction TJvFullColorPanel.GetCursorPosition: TPoint;\r\nvar\r\n AxisX, AxisY: TJvAxisIndex;\r\n MinAxis, MaxAxis: Integer;\r\nbegin\r\n if (FBuffer.Width = 0) or (FBuffer.Height = 0) or (Width = 0) or (Height = 0) then\r\n begin\r\n Result.X := 0;\r\n Result.Y := 0;\r\n end\r\n else\r\n with ColorSpaceManager, ColorSpace[GetColorSpaceID(FullColor)] do\r\n begin\r\n AxisX := GetIndexAxisX(AxisConfig);\r\n MinAxis := AxisMin[AxisX];\r\n MaxAxis := AxisMax[AxisX];\r\n Result.X := GetAxisValue(FullColor, AxisX);\r\n if ReverseAxisX then\r\n Result.X := MaxAxis - Result.X\r\n else\r\n Result.X := Result.X - MinAxis;\r\n Result.X := ((Result.X * (FBuffer.Width - 1)) div (MaxAxis-MinAxis)) + CrossSize;\r\n\r\n AxisY := GetIndexAxisY(AxisConfig);\r\n MinAxis := AxisMin[AxisY];\r\n MaxAxis := AxisMax[AxisY];\r\n Result.Y := GetAxisValue(FullColor, AxisY);\r\n if ReverseAxisY then\r\n Result.Y := MaxAxis - Result.Y\r\n else\r\n Result.Y := Result.Y - MinAxis;\r\n Result.Y := ((Result.Y * (FBuffer.Height - 1)) div (MaxAxis-MinAxis)) + CrossSize;\r\n end;\r\nend;\r\n\r\nprocedure TJvFullColorPanel.InvalidateCursor;\r\nvar\r\n ARect: TRect;\r\n Pt: TPoint;\r\nbegin\r\n Pt := GetCursorPosition;\r\n ARect.Left := Pt.X - 1 - CrossSize - CrossStyle.Width;\r\n ARect.Right := Pt.X + 1 + CrossSize + CrossStyle.Width;\r\n ARect.Top := Pt.Y - 1 - CrossSize - CrossStyle.Width;\r\n ARect.Bottom := Pt.Y + 1 + CrossSize + CrossStyle.Width;\r\n Windows.InvalidateRect(Handle, @ARect, False);\r\nend;\r\n\r\nprocedure TJvFullColorPanel.Paint;\r\nvar\r\n Pt: TPoint;\r\nbegin\r\n inherited Paint;\r\n\r\n with Canvas do\r\n begin\r\n Brush.Color := Color;\r\n DrawFrame(CrossSize, CrossSize);\r\n Draw(CrossSize, CrossSize, FBuffer);\r\n Pen := CrossStyle;\r\n\r\n Pt := GetCursorPosition;\r\n MoveTo(Pt.X - CrossSize, Pt.Y);\r\n LineTo(Pt.X - CrossCenter, Pt.Y);\r\n MoveTo(Pt.X + CrossCenter, Pt.Y);\r\n LineTo(Pt.X + CrossSize, Pt.Y);\r\n\r\n MoveTo(Pt.X, Pt.Y - CrossSize);\r\n LineTo(Pt.X, Pt.Y - CrossCenter);\r\n MoveTo(Pt.X, Pt.Y + CrossCenter);\r\n LineTo(Pt.X, Pt.Y + CrossSize);\r\n end;\r\n DrawFocus;\r\nend;\r\n\r\nprocedure TJvFullColorPanel.PenChange(Sender: TObject);\r\nbegin\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvFullColorPanel.SetCrossCenter(Value: Integer);\r\nbegin\r\n if Value >= CrossSize then\r\n Value := CrossSize - 1;\r\n if FCrossCenter <> Value then\r\n begin\r\n FCrossCenter := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvFullColorPanel.SetCrossSize(Value: Integer);\r\nbegin\r\n if Value < 1 then\r\n Value := 1;\r\n if FCrossCenter >= Value then\r\n FCrossCenter := Value - 1;\r\n if FCrossSize <> Value then\r\n begin\r\n FCrossSize := Value;\r\n CalcSize;\r\n end;\r\nend;\r\n\r\nprocedure TJvFullColorPanel.SetReverseAxisX(const Value: Boolean);\r\nbegin\r\n if FReverseAxisX <> Value then\r\n begin\r\n FReverseAxisX := Value;\r\n WantDrawBuffer := True;\r\n end;\r\nend;\r\n\r\nprocedure TJvFullColorPanel.SetReverseAxisY(const Value: Boolean);\r\nbegin\r\n if FReverseAxisY <> Value then\r\n begin\r\n FReverseAxisY := Value;\r\n WantDrawBuffer := True;\r\n end;\r\nend;\r\n\r\nprocedure TJvFullColorPanel.SetPen(const Value: TPen);\r\nbegin\r\n FPen.Assign(Value);\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvFullColorPanel.SetColorTrackBar(const Value: TJvFullColorTrackBar);\r\nbegin\r\n if (Value <> nil) and (Value <> FColorTrackBar) and Value.Linked then\r\n raise EJvFullColorError.CreateResFmt(@RsEDuplicateTrackBar, [Value.LinkerName]);\r\n\r\n if Assigned(FColorTrackBar) then\r\n begin\r\n FColorTrackBar.OnColorChange := nil;\r\n FColorTrackBar.OnAxisConfigChange := nil;\r\n FColorTrackBar.FreeLink;\r\n end;\r\n\r\n ReplaceComponentReference(Self, Value, TComponent(FColorTrackBar));\r\n\r\n if Assigned(FColorTrackBar) then\r\n begin\r\n FColorTrackBar.OnColorChange := TrackBarColorChange;\r\n FColorTrackBar.OnAxisConfigChange := TrackBarAxisConfigChange;\r\n FColorTrackBar.FullColor := FullColor;\r\n FColorTrackBar.AxisConfig := AxisConfig;\r\n FColorTrackBar.SetLink(Self);\r\n end;\r\nend;\r\n\r\nprocedure TJvFullColorPanel.Notification(AComponent: TComponent; Operation: TOperation);\r\nbegin\r\n inherited Notification(AComponent, Operation);\r\n if (Operation = opRemove) and (AComponent = ColorTrackBar) then\r\n ColorTrackBar := nil;\r\nend;\r\n\r\nprocedure TJvFullColorPanel.SetFullColor(const Value: TJvFullColor);\r\nvar\r\n AxisX, AxisY: TJvAxisIndex;\r\nbegin\r\n if Value <> FullColor then\r\n begin\r\n if Assigned(FColorTrackBar) and (not FColorChanging) then\r\n begin\r\n FColorChanging := True;\r\n FColorTrackBar.FullColor := Value;\r\n FColorChanging := False;\r\n end;\r\n begin\r\n AxisX := GetIndexAxisX(AxisConfig);\r\n AxisY := GetIndexAxisY(AxisConfig);\r\n if (GetAxisValue(Value, AxisX) <> GetAxisValue(FullColor, AxisX)) or\r\n (GetAxisValue(Value, AxisY) <> GetAxisValue(FullColor, AxisY)) then\r\n begin\r\n InvalidateCursor;\r\n inherited SetFullColor(Value);\r\n InvalidateCursor;\r\n end\r\n else\r\n inherited SetFullColor(Value);\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvFullColorPanel.MouseColor(Shift: TShiftState; X, Y: Integer);\r\nvar\r\n MinX, MaxX, MinY, MaxY: Byte;\r\n AxisX, AxisY: TJvAxisIndex;\r\n PosX, PosY: Integer;\r\nbegin\r\n if ssLeft in Shift then\r\n begin\r\n AxisX := GetIndexAxisX(AxisConfig);\r\n AxisY := GetIndexAxisY(AxisConfig);\r\n with ColorSpace do\r\n begin\r\n MinX := AxisMin[AxisX];\r\n MaxX := AxisMax[AxisX];\r\n MinY := AxisMin[AxisY];\r\n MaxY := AxisMax[AxisY];\r\n\r\n PosX := EnsureRange(((X - CrossSize) * (MaxX - MinX)) div (FBuffer.Width - 1), 0, MaxX - MinX);\r\n if ReverseAxisX then\r\n PosX := MaxX - PosX\r\n else\r\n PosX := PosX + MinX;\r\n\r\n PosY := EnsureRange(((Y - CrossSize) * (MaxY - MinY)) div (FBuffer.Height - 1), 0, MaxY - MinY);\r\n if ReverseAxisY then\r\n PosY := MaxY - PosY\r\n else\r\n PosY := PosY + MinY;\r\n\r\n FullColor := SetAxisValue(SetAxisValue(FullColor, AxisX, Byte(PosX)), AxisY, Byte(PosY));\r\n end;\r\n end;\r\n inherited MouseColor(Shift, X, Y);\r\nend;\r\n\r\nprocedure TJvFullColorPanel.AxisConfigChange;\r\nbegin\r\n if (FColorTrackBar <> nil) and not FAxisConfigChanging then\r\n begin\r\n FAxisConfigChanging := True;\r\n FColorTrackBar.AxisConfig := AxisConfig;\r\n FAxisConfigChanging := False;\r\n end;\r\n inherited AxisConfigChange;\r\nend;\r\n\r\nprocedure TJvFullColorPanel.KeyMove(KeyCode: TJvKeyCode; MoveCount: Integer);\r\nvar\r\n IndexAxisX, IndexAxisY: TJvAxisIndex;\r\n ValueX, ValueY: Integer;\r\nbegin\r\n IndexAxisX := GetIndexAxisX(AxisConfig);\r\n IndexAxisY := GetIndexAxisY(AxisConfig);\r\n ValueX := GetAxisValue(FullColor, IndexAxisX);\r\n ValueY := GetAxisValue(FullColor, IndexAxisY);\r\n\r\n case KeyCode of\r\n kcLeft:\r\n begin\r\n if ReverseAxisX then\r\n MoveCount := -MoveCount;\r\n ValueX := ValueX - MoveCount;\r\n end;\r\n kcRight:\r\n begin\r\n if ReverseAxisX then\r\n MoveCount := -MoveCount;\r\n ValueX := ValueX + MoveCount;\r\n end;\r\n kcUp:\r\n begin\r\n if ReverseAxisY then\r\n MoveCount := -MoveCount;\r\n ValueY := ValueY - MoveCount;\r\n end;\r\n kcDown:\r\n begin\r\n if ReverseAxisY then\r\n MoveCount := -MoveCount;\r\n ValueY := ValueY + MoveCount;\r\n end;\r\n end;\r\n\r\n with ColorSpace do\r\n begin\r\n ValueX := EnsureRange(ValueX, AxisMin[IndexAxisX], AxisMax[IndexAxisX]);\r\n ValueY := EnsureRange(ValueY, AxisMin[IndexAxisY], AxisMax[IndexAxisY]);\r\n end;\r\n\r\n FullColor := SetAxisValue(SetAxisValue(FullColor, IndexAxisX, ValueX), IndexAxisY, ValueY);\r\nend;\r\n\r\n//=== { TJvColorCircle } =====================================================\r\n\r\nconstructor TJvFullColorCircle.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FCrossStyle := TPen.Create;\r\n FCrossStyle.OnChange := PenChanged;\r\n FInvertRadius := False;\r\n InvertRotation := False;\r\n FCrossSize := 5;\r\n FCrossCenter := 1;\r\n FLineWidth := 1;\r\n FRedColor := fclRGBRed;\r\n FGreenColor := fclRGBLime;\r\n FBlueColor := fclRGBBlue;\r\n FDraggingColor := rcCommon;\r\n FCrossGreenColor := clGreen;\r\n FCrossRedColor := clMaroon;\r\n FCrossBlueColor := clNavy;\r\n FStyles := [csShowLines, csShowRed, csShowGreen, csShowBlue];\r\nend;\r\n\r\ndestructor TJvFullColorCircle.Destroy;\r\nbegin\r\n FCrossStyle.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvFullColorCircle.CalcSize;\r\nbegin\r\n FBuffer.Width := Max(Width - (2 * CrossSize),0);\r\n FBuffer.Height := Max(Height - (2 * CrossSize),0);\r\n inherited CalcSize;\r\nend;\r\n\r\nprocedure TJvFullColorCircle.DrawBuffer;\r\nvar\r\n X, Y, Angle, RadiusInt, MaxRadius, MinRadius: Integer;\r\n AxisRadius, AxisAngle: TJvAxisIndex;\r\n MaxAngle, MinAngle: Integer;\r\n AngleUnit, AngleUnitPi, XCenter, YCenter, XRelative, YRelative,\r\n SqrXRelative, SqrYRelative, Radius: Extended;\r\n Magic1, Magic2, Magic3: Byte;\r\n Line: PJvFullColorArray;\r\nbegin\r\n if (FBuffer.Width = 0) or (FBuffer.Height = 0) then\r\n Exit;\r\n\r\n AxisRadius := GetIndexAxisX(AxisConfig);\r\n AxisAngle := GetIndexAxisY(AxisConfig);\r\n\r\n with ColorSpace do\r\n begin\r\n MaxRadius := AxisMax[AxisRadius];\r\n MinRadius := AxisMin[AxisRadius];\r\n MaxAngle := AxisMax[AxisAngle];\r\n MinAngle := AxisMin[AxisAngle];\r\n end;\r\n\r\n AngleUnit := (MaxAngle - MinAngle) / 2.0 / Pi;\r\n AngleUnitPi := (MaxAngle - MinAngle) / 2.0;\r\n\r\n Magic1 := ValueZ;\r\n Magic2 := Magic1;\r\n Magic3 := Magic1;\r\n\r\n with FBuffer, ColorSpace do\r\n begin\r\n Canvas.Brush.Color := Color;\r\n Canvas.FillRect(Rect(0, 0, Width, Height));\r\n XCenter := Width / 2.0;\r\n YCenter := Height / 2.0;\r\n for Y := 0 to Height - 1 do\r\n begin\r\n Line := ScanLine[Y];\r\n YRelative := Y - YCenter;\r\n SqrYRelative := Sqr(YRelative / YCenter);\r\n for X := 0 to Width - 1 do\r\n begin\r\n XRelative := X - XCenter;\r\n SqrXRelative := Sqr(XRelative / XCenter);\r\n Radius := Sqrt(SqrYRelative + SqrXRelative);\r\n\r\n if Radius <= 1.0 then\r\n begin\r\n Angle := Round(ArcTan2(YRelative, XRelative) * AngleUnit + AngleUnitPi) + MinAngle;\r\n RadiusInt := Round(Radius * (MaxRadius - MinRadius));\r\n case AxisAngle of\r\n axIndex0:\r\n if InvertRotation then\r\n Magic1 := MaxAngle - Angle\r\n else\r\n Magic1 := Angle + MinAngle;\r\n axIndex1:\r\n if InvertRotation then\r\n Magic2 := MaxAngle - Angle\r\n else\r\n Magic2 := Angle + MinAngle;\r\n axIndex2:\r\n if InvertRotation then\r\n Magic3 := MaxAngle - Angle\r\n else\r\n Magic3 := Angle + MinAngle;\r\n end;\r\n case AxisRadius of\r\n axIndex0:\r\n if InvertRadius then\r\n Magic1 := MaxRadius - RadiusInt\r\n else\r\n Magic1 := RadiusInt + MinRadius;\r\n axIndex1:\r\n if InvertRadius then\r\n Magic2 := MaxRadius - RadiusInt\r\n else\r\n Magic2 := RadiusInt + MinRadius;\r\n axIndex2:\r\n if InvertRadius then\r\n Magic3 := MaxRadius - RadiusInt\r\n else\r\n Magic3 := RadiusInt + MinRadius;\r\n end;\r\n // (outchy) don't remove, Bitmap colors are stocked as (MSB) 00RRGGBB (LSB)\r\n // Delphi TColor is (MSB) 00BBGGRR (LSB)\r\n Line[X] := RGBToBGR(ConvertToColor(Magic1 or (Magic2 shl 8) or (Magic3 shl 16)));\r\n end\r\n else\r\n if XRelative >= 0.0 then\r\n Break; // end of a line\r\n end;\r\n end;\r\n end;\r\n inherited DrawBuffer;\r\nend;\r\n\r\nprocedure TJvFullColorCircle.Paint;\r\n\r\n procedure DrawCross(AFullColor: TJvFullColor; ACrossColor: TColor);\r\n var\r\n Point: TPoint;\r\n begin\r\n Point := FullColorToPosition(AFullColor);\r\n\r\n with Canvas do\r\n begin\r\n Pen := CrossStyle;\r\n Pen.Color := ACrossColor;\r\n\r\n MoveTo(Point.X - CrossSize, Point.Y); // left\r\n LineTo(Point.X - CrossCenter, Point.Y);\r\n\r\n MoveTo(Point.X + CrossCenter, Point.Y); // right\r\n LineTo(Point.X + CrossSize, Point.Y);\r\n\r\n MoveTo(Point.X, Point.Y - CrossSize); // top\r\n LineTo(Point.X, Point.Y - CrossCenter);\r\n\r\n MoveTo(Point.X, Point.Y + CrossCenter); // bottom\r\n LineTo(Point.X, Point.Y + CrossSize);\r\n\r\n Pen.Mode := pmCopy;\r\n Pen.Style := psSolid;\r\n Pen.Width := LineWidth;\r\n MoveTo((FBuffer.Width div 2) + CrossSize + 1,(FBuffer.Height div 2 ) + CrossSize + 1);\r\n LineTo(Point.X, Point.Y);\r\n end;\r\n end;\r\n\r\nbegin\r\n inherited Paint;\r\n with Canvas do\r\n begin\r\n Brush.Color := Color;\r\n DrawFrame(CrossSize, CrossSize);\r\n Draw(CrossSize, CrossSize, FBuffer);\r\n\r\n if csShowCommon in Styles then\r\n DrawCross(FullColor, CrossStyle.Color)\r\n else\r\n begin\r\n if csShowBlue in Styles then\r\n DrawCross(BlueColor, CrossBlueColor);\r\n if csShowRed in Styles then\r\n DrawCross(RedColor, CrossRedColor);\r\n if csShowGreen in Styles then\r\n DrawCross(GreenColor, CrossGreenColor);\r\n end;\r\n end;\r\n DrawFocus;\r\nend;\r\n\r\nfunction TJvFullColorCircle.FullColorToPosition(AFullColor: TJvFullColor): TPoint;\r\nvar\r\n ColorID: TJvFullColorSpaceID;\r\n RadiusIndex, AngleIndex: TJvAxisIndex;\r\n Radius, RadiusMax, RadiusMin, Angle, AngleMax, AngleMin: Integer;\r\n Radius1: Integer;\r\n FullAngle: Extended;\r\nbegin\r\n with ColorSpaceManager do\r\n begin\r\n ColorID := GetColorSpaceID(AFullColor);\r\n if ColorID <> GetColorSpaceID(AFullColor) then\r\n AFullColor := ConvertToID(AFullColor, ColorID);\r\n end;\r\n\r\n with ColorSpace do\r\n begin\r\n RadiusIndex := GetIndexAxisX(AxisConfig);\r\n Radius := GetAxisValue(AFullColor, RadiusIndex);\r\n RadiusMax := AxisMax[RadiusIndex];\r\n RadiusMin := AxisMin[RadiusIndex];\r\n\r\n AngleIndex := GetIndexAxisY(AxisConfig);\r\n Angle := GetAxisValue(AFullColor, AngleIndex);\r\n AngleMax := AxisMax[AngleIndex];\r\n AngleMin := AxisMin[AngleIndex];\r\n end;\r\n\r\n Radius1 := RadiusMax - RadiusMin;\r\n\r\n if InvertRadius then\r\n Radius := RadiusMax - Radius\r\n else\r\n Radius := Radius - RadiusMin;\r\n if InvertRotation then\r\n Angle := AngleMax - Angle\r\n else\r\n Angle := Angle - AngleMin;\r\n\r\n FullAngle := (2 * Pi * Angle) / (AngleMax - AngleMin) - Pi;\r\n Result.X := Round(Radius * JclMath.Cos(FullAngle) * FBuffer.Width / (Radius1 * 2) + (FBuffer.Width / 2.0)) + CrossSize;\r\n Result.Y := Round(Radius * JclMath.Sin(FullAngle) * FBuffer.Height / (Radius1 * 2) + (FBuffer.Height / 2.0)) + CrossSize;\r\nend;\r\n\r\nfunction TJvFullColorCircle.PositionToFullColor(APoint: TPoint): TJvFullColor;\r\nvar\r\n RadiusIndex, AngleIndex: TJvAxisIndex;\r\n Radius, RadiusMax, RadiusMin, Angle, AngleMax, AngleMin: Integer;\r\n XPos, YPos: Extended;\r\nbegin\r\n if (FBuffer.Width = 0) or (FBuffer.Height = 0) then\r\n begin\r\n Result := fclRGBBlack;\r\n Exit;\r\n end;\r\n with ColorSpace do\r\n begin\r\n RadiusIndex := GetIndexAxisX(AxisConfig);\r\n RadiusMax := AxisMax[RadiusIndex];\r\n RadiusMin := AxisMin[RadiusIndex];\r\n\r\n AngleIndex := GetIndexAxisY(AxisConfig);\r\n AngleMax := AxisMax[AngleIndex];\r\n AngleMin := AxisMin[AngleIndex];\r\n end;\r\n\r\n XPos := FBuffer.Width / 2.0;\r\n XPos := (APoint.X - CrossSize - XPos) / XPos;\r\n YPos := FBuffer.Height / 2.0;\r\n YPos := (APoint.Y - CrossSize - YPos) / YPos;\r\n\r\n Radius := Round(Sqrt(Sqr(XPos) + Sqr(YPos))*(RadiusMax - RadiusMin));\r\n Angle := Round((ArcTan2(YPos, XPos) + Pi) * (AngleMax - AngleMin) / 2.0 / Pi);\r\n\r\n if InvertRadius then\r\n Radius := RadiusMax - Radius\r\n else\r\n Radius := Radius + RadiusMin;\r\n if InvertRotation then\r\n Angle := AngleMax - Angle\r\n else\r\n Angle := Angle + AngleMin;\r\n\r\n Radius := EnsureRange(Radius, RadiusMin, RadiusMax);\r\n Angle := EnsureRange(Angle, AngleMin, AngleMax);\r\n\r\n Result := SetAxisValue(\r\n SetAxisValue(\r\n SetAxisValue(ColorSpace.ID shl 24, GetIndexAxisZ(AxisConfig), ValueZ),\r\n AngleIndex, Angle), RadiusIndex, Radius);\r\nend;\r\n\r\nprocedure TJvFullColorCircle.MouseColor(Shift: TShiftState; X, Y: Integer);\r\nvar\r\n LFullColor: TJvFullColor;\r\n\r\n function MoveColor(var AFullColor: TJvFullColor): Boolean;\r\n var\r\n Distance: Integer;\r\n Point: TPoint;\r\n begin\r\n Point := FullColorToPosition(AFullColor);\r\n Distance := Round(Sqrt(Sqr(X - Point.X) + Sqr(Y - Point.Y)));\r\n if Distance < CrossSize then\r\n begin\r\n AFullColor := LFullColor;\r\n Result := True;\r\n Invalidate;\r\n end\r\n else\r\n Result := False;\r\n end;\r\n\r\nbegin\r\n LFullColor := PositionToFullColor(Point(X, Y));\r\n if csShowCommon in Styles then\r\n begin\r\n if (ssLeft in Shift) or\r\n ((cs3ButtonsMouse in Styles) and (cs3ButtonsCommon in Styles)) then\r\n FullColor := LFullColor;\r\n end\r\n else\r\n if cs3ButtonsMouse in Styles then\r\n begin\r\n if (ssLeft in Shift) and (csShowRed in Styles) then\r\n RedColor := LFullColor;\r\n if (ssMiddle in Shift) and (csShowGreen in Styles) then\r\n GreenColor := LFullColor;\r\n if (ssRight in Shift) and (csShowBlue in Styles) then\r\n BlueColor := LFullColor;\r\n end\r\n else\r\n begin\r\n if FDraggingColor = rcGreen then\r\n GreenColor := LFullColor\r\n else\r\n if FDraggingColor = rcRed then\r\n RedColor := LFullColor\r\n else\r\n if FDraggingColor = rcBlue then\r\n BlueColor := LFullColor\r\n else\r\n if FDraggingColor = rcCommon then\r\n begin\r\n if (csShowGreen in Styles) and MoveColor(FGreenColor) then\r\n begin\r\n FDraggingColor := rcGreen;\r\n if Assigned(FOnGreenColorChange) then\r\n FOnGreenColorChange(Self);\r\n end\r\n else\r\n if (csShowRed in Styles) and MoveColor(FRedColor) then\r\n begin\r\n FDraggingColor := rcRed;\r\n if Assigned(FOnRedColorChange) then\r\n FOnRedColorChange(Self);\r\n end\r\n else\r\n if (csShowBlue in Styles) and MoveColor(FBlueColor) then\r\n begin\r\n FDraggingColor := rcBlue;\r\n if Assigned(FOnBlueColorChange) then\r\n FOnBlueColorChange(Self);\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvFullColorCircle.MouseUp(Button: TMouseButton; Shift: TShiftState;\r\n X, Y: Integer);\r\nbegin\r\n FDraggingColor := rcCommon;\r\n inherited MouseUp(Button, Shift, X, Y);\r\nend;\r\n\r\nprocedure TJvFullColorCircle.KeyMove(KeyCode: TJvKeyCode;\r\n MoveCount: Integer);\r\nbegin\r\n // (outchy) todo implementation but how to select a cursor ???\r\nend;\r\n\r\nprocedure TJvFullColorCircle.PenChanged(Sender: TObject);\r\nbegin\r\n WantDrawBuffer := True;\r\nend;\r\n\r\nprocedure TJvFullColorCircle.ConvertToID(NewFullColor: TJvFullColor);\r\nvar\r\n ColorID: TJvFullColorSpaceID;\r\n Change: Boolean;\r\nbegin\r\n with ColorSpaceManager do\r\n begin\r\n ColorID := GetColorSpaceID(NewFullColor);\r\n Change := ColorID <> GetColorSpaceID(FullColor);\r\n\r\n if Change then\r\n begin\r\n FFullColor := ConvertToID(FullColor, ColorID);\r\n FRedColor := ConvertToID(RedColor, ColorID);\r\n FGreenColor := ConvertToID(GreenColor, ColorID);\r\n FBlueColor := ConvertToID(BlueColor, ColorID);\r\n ColorSpaceChange;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvFullColorCircle.InvalidateColors(AColor1, AColor2: TJvFullColor);\r\nvar\r\n AxisX, AxisY: TJvAxisIndex;\r\n APosition1,\r\n APosition2: TPoint;\r\n ARect: TRect;\r\n CenterX, CenterY: Integer;\r\nbegin\r\n AxisX := GetIndexAxisX(AxisConfig);\r\n AxisY := GetIndexAxisY(AxisConfig);\r\n\r\n if (GetAxisValue(AColor1, AxisX) <> GetAxisValue(AColor2, AxisX)) or\r\n (GetAxisValue(AColor1, AxisY) <> GetAxisValue(AColor2, AxisY)) then\r\n begin\r\n APosition1 := FullColorToPosition(AColor1);\r\n APosition2 := FullColorToPosition(AColor2);\r\n if APosition1.X < APosition2.X then\r\n begin\r\n ARect.Left := APosition1.X;\r\n ARect.Right := APosition2.X;\r\n end\r\n else\r\n begin\r\n ARect.Left := APosition2.X;\r\n ARect.Right := APosition1.X;\r\n end;\r\n if APosition1.Y < APosition2.Y then\r\n begin\r\n ARect.Top := APosition1.Y;\r\n ARect.Bottom := APosition2.Y;\r\n end\r\n else\r\n begin\r\n ARect.Top := APosition2.Y;\r\n ARect.Bottom := APosition1.Y;\r\n end;\r\n\r\n CenterX := Width div 2;\r\n CenterY := Height div 2;\r\n if ARect.Left > CenterX then\r\n ARect.Left := CenterX;\r\n if ARect.Top > CenterY then\r\n ARect.Top := CenterY;\r\n if ARect.Right < CenterX then\r\n ARect.Right := CenterX;\r\n if ARect.Bottom < CenterY then\r\n ARect.Bottom := CenterY;\r\n\r\n ARect.Left := ARect.Left - CrossStyle.Width - CrossSize;\r\n ARect.Top := ARect.Top - CrossStyle.Width - CrossSize;\r\n ARect.Right := ARect.Right + CrossStyle.Width + CrossSize;\r\n ARect.Bottom := ARect.Bottom + CrossStyle.Width + CrossSize;\r\n\r\n Windows.InvalidateRect(Handle, @ARect, False);\r\n end;\r\nend;\r\n\r\nprocedure TJvFullColorCircle.SetFullColor(const Value: TJvFullColor);\r\nvar\r\n OldColor: TJvFullColor;\r\nbegin\r\n ConvertToID(Value);\r\n\r\n OldColor := FullColor;\r\n inherited SetFullColor(Value);\r\n\r\n if Assigned(FCommonColorTrackBar) and not FColorChanging then\r\n begin\r\n FColorChanging := True;\r\n FCommonColorTrackBar.FullColor := Value;\r\n FColorChanging := False;\r\n end;\r\n\r\n InvalidateColors(OldColor, FullColor);\r\n\r\n if ColorSpaceManager.GetColorSpaceID(OldColor) <> ColorSpaceManager.GetColorSpaceID(FullColor) then\r\n CalcSize;\r\nend;\r\n\r\nprocedure TJvFullColorCircle.SetBlueColor(const Value: TJvFullColor);\r\nvar\r\n OldColor: TJvFullColor;\r\nbegin\r\n ConvertToID(Value);\r\n\r\n OldColor := BlueColor;\r\n FBlueColor := Value;\r\n\r\n if Assigned(FBlueColorTrackBar) and not FColorChanging then\r\n begin\r\n FColorChanging := True;\r\n FBlueColorTrackBar.FullColor := Value;\r\n FColorChanging := False;\r\n end;\r\n\r\n InvalidateColors(OldColor, BlueColor);\r\n\r\n if Assigned(FOnBlueColorChange) then\r\n FOnBlueColorChange(Self);\r\nend;\r\n\r\nprocedure TJvFullColorCircle.SetGreenColor(const Value: TJvFullColor);\r\nvar\r\n OldColor: TJvFullColor;\r\nbegin\r\n ConvertToID(Value);\r\n\r\n OldColor := GreenColor;\r\n FGreenColor := Value;\r\n\r\n if Assigned(FGreenColorTrackBar) and not FColorChanging then\r\n begin\r\n FColorChanging := True;\r\n FGreenColorTrackBar.FullColor := Value;\r\n FColorChanging := False;\r\n end;\r\n\r\n InvalidateColors(OldColor, GreenColor);\r\n\r\n if Assigned(FOnGreenColorChange) then\r\n FOnGreenColorChange(Self);\r\nend;\r\n\r\nprocedure TJvFullColorCircle.SetRedColor(const Value: TJvFullColor);\r\nvar\r\n OldColor: TJvFullColor;\r\nbegin\r\n ConvertToID(Value);\r\n\r\n OldColor := RedColor;\r\n FRedColor := Value;\r\n\r\n if Assigned(FRedColorTrackBar) and not FColorChanging then\r\n begin\r\n FColorChanging := True;\r\n FRedColorTrackBar.FullColor := Value;\r\n FColorChanging := False;\r\n end;\r\n\r\n InvalidateColors(OldColor, RedColor);\r\n\r\n if Assigned(FOnRedColorChange) then\r\n FOnRedColorChange(Self);\r\nend;\r\n\r\nprocedure TJvFullColorCircle.SetCrossCenter(Value: Integer);\r\nbegin\r\n if Value < 0 then\r\n Value := 0;\r\n if Value >= CrossSize then\r\n Value := CrossSize - 1;\r\n if FCrossCenter <> Value then\r\n begin\r\n FCrossCenter := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvFullColorCircle.SetCrossSize(Value: Integer);\r\nbegin\r\n if Value < 0 then\r\n Value := 0;\r\n if FCrossSize <> Value then\r\n begin\r\n FCrossSize := Value;\r\n CalcSize;\r\n end;\r\nend;\r\n\r\nprocedure TJvFullColorCircle.SetCrossStyle(const Value: TPen);\r\nbegin\r\n FCrossStyle.Assign(Value);\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvFullColorCircle.SetInvertRadius(const Value: Boolean);\r\nbegin\r\n if FInvertRadius <> Value then\r\n begin\r\n FInvertRadius := Value;\r\n WantDrawBuffer := True;\r\n end;\r\nend;\r\n\r\nprocedure TJvFullColorCircle.SetInvertRotation(const Value: Boolean);\r\nbegin\r\n if FInvertRotation <> Value then\r\n begin\r\n FInvertRotation := Value;\r\n WantDrawBuffer := True;\r\n end;\r\nend;\r\n\r\nprocedure TJvFullColorCircle.SetLineWidth(Value: Integer);\r\nbegin\r\n if Value < 0 then\r\n Value := 0;\r\n if FLineWidth <> Value then\r\n begin\r\n FLineWidth := Value;\r\n WantDrawBuffer := True;\r\n end;\r\nend;\r\n\r\nprocedure TJvFullColorCircle.SetStyles(const Value: TJvFullColorCircleStyles);\r\nbegin\r\n if FStyles <> Value then\r\n begin\r\n FStyles := Value;\r\n WantDrawBuffer := True;\r\n end;\r\nend;\r\n\r\nprocedure TJvFullColorCircle.Notification(AComponent: TComponent;\r\n Operation: TOperation);\r\nbegin\r\n if Operation = opRemove then\r\n if AComponent = RedTrackBar then\r\n RedTrackBar := nil\r\n else\r\n if AComponent = GreenTrackBar then\r\n GreenTrackBar := nil\r\n else\r\n if AComponent = BlueTrackBar then\r\n BlueTrackBar := nil\r\n else\r\n if AComponent = CommonTrackBar then\r\n CommonTrackBar := nil;\r\n inherited Notification(AComponent, Operation);\r\nend;\r\n\r\nprocedure TJvFullColorCircle.SetBlueColorTrackBar(const Value: TJvFullColorTrackBar);\r\nbegin\r\n if (Value <> nil) and (Value <> FBlueColorTrackBar) and Value.Linked then\r\n raise EJvFullColorError.CreateResFmt(@RsEDuplicateTrackBar, [Value.LinkerName]);\r\n\r\n if Assigned(FBlueColorTrackBar) then\r\n begin\r\n FBlueColorTrackBar.OnColorChange := nil;\r\n FBlueColorTrackBar.OnAxisConfigChange := nil;\r\n FBlueColorTrackBar.FreeLink;\r\n end;\r\n\r\n ReplaceComponentReference(Self, Value, TComponent(FBlueColorTrackBar));\r\n\r\n if Assigned(FBlueColorTrackBar) then\r\n begin\r\n FBlueColorTrackBar.OnColorChange := TrackBarColorChange;\r\n FBlueColorTrackBar.OnAxisConfigChange := TrackBarAxisConfigChange;\r\n FBlueColorTrackBar.FullColor := BlueColor;\r\n FBlueColorTrackBar.AxisConfig := AxisConfig;\r\n FBlueColorTrackBar.SetLink(Self);\r\n end;\r\nend;\r\n\r\nprocedure TJvFullColorCircle.SetGreenColorTrackBar(const Value: TJvFullColorTrackBar);\r\nbegin\r\n if (Value <> nil) and (Value <> FGreenColorTrackBar) and Value.Linked then\r\n raise EJvFullColorError.CreateResFmt(@RsEDuplicateTrackBar, [Value.LinkerName]);\r\n\r\n if Assigned(FGreenColorTrackBar) then\r\n begin\r\n FGreenColorTrackBar.OnColorChange := nil;\r\n FGreenColorTrackBar.OnAxisConfigChange := nil;\r\n FGreenColorTrackBar.FreeLink;\r\n end;\r\n\r\n ReplaceComponentReference(Self, Value, TComponent(FGreenColorTrackBar));\r\n\r\n if Assigned(FGreenColorTrackBar) then\r\n begin\r\n FGreenColorTrackBar.OnColorChange := TrackBarColorChange;\r\n FGreenColorTrackBar.OnAxisConfigChange := TrackBarAxisConfigChange;\r\n FGreenColorTrackBar.FullColor := GreenColor;\r\n FGreenColorTrackBar.AxisConfig := AxisConfig;\r\n FGreenColorTrackBar.SetLink(Self);\r\n end;\r\nend;\r\n\r\nprocedure TJvFullColorCircle.SetRedColorTrackBar(const Value: TJvFullColorTrackBar);\r\nbegin\r\n if (Value <> nil) and (Value <> FRedColorTrackBar) and Value.Linked then\r\n raise EJvFullColorError.CreateResFmt(@RsEDuplicateTrackBar, [Value.LinkerName]);\r\n\r\n if Assigned(FRedColorTrackBar) then\r\n begin\r\n FRedColorTrackBar.OnColorChange := nil;\r\n FRedColorTrackBar.OnAxisConfigChange := nil;\r\n FRedColorTrackBar.FreeLink;\r\n end;\r\n\r\n ReplaceComponentReference(Self, Value, TComponent(FRedColorTrackBar));\r\n\r\n if Assigned(FRedColorTrackBar) then\r\n begin\r\n FRedColorTrackBar.OnColorChange := TrackBarColorChange;\r\n FRedColorTrackBar.OnAxisConfigChange := TrackBarAxisConfigChange;\r\n FRedColorTrackBar.FullColor := RedColor;\r\n FRedColorTrackBar.AxisConfig := AxisConfig;\r\n FRedColorTrackBar.SetLink(Self);\r\n end;\r\nend;\r\n\r\nprocedure TJvFullColorCircle.SetCommonColorTrackBar(const Value: TJvFullColorTrackBar);\r\nbegin\r\n if (Value <> nil) and (Value <> FCommonColorTrackBar) and Value.Linked then\r\n raise EJvFullColorError.CreateResFmt(@RsEDuplicateTrackBar, [Value.LinkerName]);\r\n\r\n if Assigned(FCommonColorTrackBar) then\r\n begin\r\n FCommonColorTrackBar.OnColorChange := nil;\r\n FCommonColorTrackBar.OnAxisConfigChange := nil;\r\n FCommonColorTrackBar.FreeLink;\r\n end;\r\n\r\n ReplaceComponentReference(Self, Value, TComponent(FCommonColorTrackBar));\r\n\r\n if Assigned(FCommonColorTrackBar) then\r\n begin\r\n FCommonColorTrackBar.OnColorChange := TrackBarColorChange;\r\n FCommonColorTrackBar.OnAxisConfigChange := TrackBarAxisConfigChange;\r\n FCommonColorTrackBar.FullColor := FullColor;\r\n FCommonColorTrackBar.AxisConfig := AxisConfig;\r\n FCommonColorTrackBar.SetLink(Self);\r\n end;\r\nend;\r\n\r\nprocedure TJvFullColorCircle.SetCrossBlueColor(const Value: TColor);\r\nbegin\r\n if FCrossBlueColor <> Value then\r\n begin\r\n FCrossBlueColor := Value;\r\n WantDrawBuffer := True;\r\n end;\r\nend;\r\n\r\nprocedure TJvFullColorCircle.SetCrossGreenColor(const Value: TColor);\r\nbegin\r\n if FCrossGreenColor <> Value then\r\n begin\r\n FCrossGreenColor := Value;\r\n WantDrawBuffer := True;\r\n end;\r\nend;\r\n\r\nprocedure TJvFullColorCircle.SetCrossRedColor(const Value: TColor);\r\nbegin\r\n if FCrossRedColor <> Value then\r\n begin\r\n FCrossRedColor := Value;\r\n WantDrawBuffer := True;\r\n end;\r\nend;\r\n\r\nprocedure TJvFullColorCircle.AxisConfigChange;\r\nbegin\r\n if FAxisConfigChanging then\r\n Exit;\r\n\r\n if (FCommonColorTrackBar <> nil) and\r\n (FCommonColorTrackBar.AxisConfig <> AxisConfig) then\r\n begin\r\n FAxisConfigChanging := True;\r\n FCommonColorTrackBar.AxisConfig := AxisConfig;\r\n FAxisConfigChanging := False;\r\n end;\r\n\r\n if (FRedColorTrackBar <> nil) and\r\n (FRedColorTrackBar.AxisConfig <> AxisConfig) then\r\n begin\r\n FAxisConfigChanging := True;\r\n FRedColorTrackBar.AxisConfig := AxisConfig;\r\n FAxisConfigChanging := False;\r\n end;\r\n\r\n if (FGreenColorTrackBar <> nil) and\r\n (FGreenColorTrackBar.AxisConfig <> AxisConfig) then\r\n begin\r\n FAxisConfigChanging := True;\r\n FGreenColorTrackBar.AxisConfig := AxisConfig;\r\n FAxisConfigChanging := False;\r\n end;\r\n\r\n if (FBlueColorTrackBar <> nil) and\r\n (FBlueColorTrackBar.AxisConfig <> AxisConfig) then\r\n begin\r\n FAxisConfigChanging := True;\r\n FBlueColorTrackBar.AxisConfig := AxisConfig;\r\n FAxisConfigChanging := False;\r\n end;\r\n\r\n inherited AxisConfigChange;\r\nend;\r\n\r\nprocedure TJvFullColorCircle.TrackBarColorChange(Sender: TObject);\r\nbegin\r\n if FColorChanging then\r\n Exit;\r\n\r\n FColorChanging := True;\r\n\r\n if Sender = RedTrackBar then\r\n RedColor := (Sender as TJvFullColorTrackBar).FullColor\r\n else\r\n if Sender = GreenTrackBar then\r\n GreenColor := (Sender as TJvFullColorTrackBar).FullColor\r\n else\r\n if Sender = BlueTrackBar then\r\n BlueColor := (Sender as TJvFullColorTrackBar).FullColor\r\n else\r\n if Sender = CommonTrackBar then\r\n begin\r\n FullColor := (Sender as TJvFullColorTrackBar).FullColor;\r\n if Assigned(FOnColorChange) then\r\n FOnColorChange(Self);\r\n end;\r\n\r\n FColorChanging := False;\r\nend;\r\n\r\nprocedure TJvFullColorCircle.ColorSpaceChange;\r\nbegin\r\n if CommonTrackBar <> nil then\r\n CommonTrackBar.FullColor := FullColor;\r\n if RedTrackBar <> nil then\r\n RedTrackBar.FullColor := RedColor;\r\n if GreenTrackBar <> nil then\r\n GreenTrackBar.FullColor := GreenColor;\r\n if BlueTrackBar <> nil then\r\n BlueTrackBar.FullColor := BlueColor;\r\n\r\n inherited ColorSpaceChange;\r\nend;\r\n\r\n//=== { TJvFullColorTrackBar } ===============================================\r\n\r\nconstructor TJvFullColorTrackBar.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n\r\n FOrientation := trHorizontal;\r\n FArrowPosition := apNormal;\r\n FColorOrientation := coNormal;\r\n\r\n FArrowWidth := 9;\r\n FArrowColor := clBlack;\r\n FFullColorDrawing := True;\r\n FValueXAuto := True;\r\n FValueYAuto := True;\r\n FLink := nil;\r\n ColorSpaceChange;\r\nend;\r\n\r\nprocedure TJvFullColorTrackBar.AxisConfigChange;\r\nbegin\r\n UpdateDefaultValueX;\r\n UpdateDefaultValueY;\r\n inherited AxisConfigChange;\r\nend;\r\n\r\nprocedure TJvFullColorTrackBar.CalcSize;\r\nbegin\r\n case Orientation of\r\n trHorizontal:\r\n begin\r\n FBuffer.Width := Max(Width - (2 * ArrowWidth),0);\r\n FBuffer.Height := Max(Height - ArrowWidth,0);\r\n end;\r\n trVertical:\r\n begin\r\n FBuffer.Width := Max(Width - ArrowWidth,0);\r\n FBuffer.Height := Max(Height - (2 * ArrowWidth),0);\r\n end;\r\n end;\r\n inherited CalcSize;\r\nend;\r\n\r\nprocedure TJvFullColorTrackBar.ColorSpaceChange;\r\nbegin\r\n UpdateDefaultValueX;\r\n UpdateDefaultValueY;\r\n inherited ColorSpaceChange;\r\nend;\r\n\r\nprocedure TJvFullColorTrackBar.DrawBuffer;\r\nvar\r\n AxisX, AxisY, AxisZ: TJvAxisIndex;\r\n MinZ, MaxZ, ValueZ, IndexZ: Integer;\r\n TempColor: TJvFullColor;\r\n GraphicRange: Integer;\r\nbegin\r\n if (FCreating) or (Width = 0) or (Height = 0) or\r\n (FBuffer.Width = 0) or (FBuffer.Height = 0) then\r\n Exit;\r\n\r\n AxisX := GetIndexAxisX(AxisConfig);\r\n AxisY := GetIndexAxisY(AxisConfig);\r\n AxisZ := GetIndexAxisZ(AxisConfig);\r\n\r\n with ColorSpace do\r\n begin\r\n MinZ := AxisMin[AxisZ];\r\n MaxZ := AxisMax[AxisZ];\r\n\r\n if FullColorDrawing then\r\n TempColor := FullColor\r\n else\r\n TempColor := SetAxisValue(SetAxisValue(fclRGBBlack, AxisX, ValueX), AxisY, ValueY);\r\n\r\n with FBuffer.Canvas do\r\n begin\r\n if Orientation = trHorizontal then\r\n GraphicRange := FBuffer.Width - 1\r\n else\r\n GraphicRange := FBuffer.Height - 1;\r\n for IndexZ := 0 to GraphicRange do\r\n begin\r\n if ColorOrientation = coInverse then\r\n ValueZ := MaxZ - ((IndexZ * (MaxZ - MinZ)) div GraphicRange)\r\n else\r\n ValueZ := ((IndexZ * (MaxZ - MinZ)) div GraphicRange) + MinZ;\r\n Pen.Color := ConvertToColor(SetAxisValue(TempColor, AxisZ, ValueZ));\r\n case Orientation of\r\n trHorizontal:\r\n begin\r\n MoveTo(IndexZ, 0);\r\n LineTo(IndexZ, Height - ArrowWidth);\r\n end;\r\n trVertical:\r\n begin\r\n MoveTo(0, IndexZ);\r\n LineTo(Width - ArrowWidth, IndexZ);\r\n end;\r\n end;\r\n end;\r\n end;\r\n end;\r\n inherited DrawBuffer;\r\nend;\r\n\r\nfunction TJvFullColorTrackBar.GetCursorPosition: TJvCursorPoints;\r\nvar\r\n AxisZ: TJvAxisIndex;\r\n PosZ, MaxAxis, MinAxis: Integer;\r\n GraphicRange: Integer;\r\nbegin\r\n AxisZ := GetIndexAxisZ(AxisConfig);\r\n\r\n with ColorSpace do\r\n begin\r\n MaxAxis := AxisMax[AxisZ];\r\n MinAxis := AxisMin[AxisZ];\r\n if Orientation = trHorizontal then\r\n GraphicRange := FBuffer.Width - 1\r\n else\r\n GraphicRange := FBuffer.Height - 1;\r\n PosZ := GetAxisValue(FullColor, AxisZ);\r\n if ColorOrientation = coInverse then\r\n PosZ := ((MaxAxis - PosZ) * GraphicRange) div (MaxAxis - MinAxis)\r\n else\r\n PosZ := ((PosZ - MinAxis) * GraphicRange) div (MaxAxis - MinAxis);\r\n Inc(PosZ, ArrowWidth);\r\n end;\r\n\r\n case Orientation of\r\n trHorizontal:\r\n begin\r\n Result[0].X := PosZ - ArrowWidth;\r\n Result[1].X := PosZ;\r\n Result[2].X := PosZ + ArrowWidth;\r\n case ArrowPosition of\r\n apNormal:\r\n begin\r\n Result[0].Y := 0;\r\n Result[1].Y := ArrowWidth;\r\n Result[2].Y := 0;\r\n end;\r\n apOpposite:\r\n begin\r\n Result[0].Y := Height - 1;\r\n Result[1].Y := Height - 1 - ArrowWidth;\r\n Result[2].Y := Height - 1;\r\n end;\r\n end;\r\n end;\r\n trVertical:\r\n begin\r\n Result[0].Y := PosZ - ArrowWidth;\r\n Result[1].Y := PosZ;\r\n Result[2].Y := PosZ + ArrowWidth;\r\n case ArrowPosition of\r\n apNormal:\r\n begin\r\n Result[0].X := 0;\r\n Result[1].X := ArrowWidth;\r\n Result[2].X := 0;\r\n end;\r\n apOpposite:\r\n begin\r\n Result[0].X := Width - 1;\r\n Result[1].X := Width - 1 - ArrowWidth;\r\n Result[2].X := Width - 1;\r\n end;\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvFullColorTrackBar.InvalidateCursor;\r\nvar\r\n ARect: TRect;\r\n CursorPoints: TJvCursorPoints;\r\nbegin\r\n CursorPoints := GetCursorPosition;\r\n ARect.Left := Min(CursorPoints[0].X, Min(CursorPoints[1].X, CursorPoints[2].X));\r\n ARect.Top := Min(CursorPoints[0].Y, Min(CursorPoints[1].Y, CursorPoints[2].Y));\r\n ARect.Right := Max(CursorPoints[0].X, Max(CursorPoints[1].X, CursorPoints[2].X)) + 1;\r\n ARect.Bottom := Max(CursorPoints[0].Y, Max(CursorPoints[1].Y, CursorPoints[2].Y)) + 1;\r\n Windows.InvalidateRect(Handle, @ARect, False);\r\nend;\r\n\r\nprocedure TJvFullColorTrackBar.Paint;\r\nvar\r\n CursorPoints: TJvCursorPoints;\r\nbegin\r\n inherited Paint;\r\n\r\n with Canvas do\r\n begin\r\n case Orientation of\r\n trHorizontal:\r\n case ArrowPosition of\r\n apNormal:\r\n begin\r\n DrawFrame(ArrowWidth, ArrowWidth + 1);\r\n Draw(ArrowWidth, ArrowWidth + 1, FBuffer);\r\n end;\r\n apOpposite:\r\n begin\r\n DrawFrame(ArrowWidth, 0);\r\n Draw(ArrowWidth, 0, FBuffer);\r\n end;\r\n end;\r\n trVertical:\r\n case ArrowPosition of\r\n apNormal:\r\n begin\r\n DrawFrame(ArrowWidth + 1, ArrowWidth);\r\n Draw(ArrowWidth + 1, ArrowWidth, FBuffer);\r\n end;\r\n apOpposite:\r\n begin\r\n DrawFrame(0, ArrowWidth);\r\n Draw(0, ArrowWidth, FBuffer);\r\n end;\r\n end;\r\n end;\r\n Brush.Color := ArrowColor;\r\n Pen.Color := ArrowColor;\r\n CursorPoints := GetCursorPosition;\r\n Polygon(CursorPoints);\r\n end;\r\n DrawFocus;\r\nend;\r\n\r\nprocedure TJvFullColorTrackBar.FreeLink;\r\nbegin\r\n FLink := nil;\r\nend;\r\n\r\nfunction TJvFullColorTrackBar.IsValueXStored: Boolean;\r\nbegin\r\n Result := not ValueXAuto;\r\nend;\r\n\r\nfunction TJvFullColorTrackBar.IsValueYStored: Boolean;\r\nbegin\r\n Result := not ValueYAuto;\r\nend;\r\n\r\nprocedure TJvFullColorTrackBar.KeyMove(KeyCode: TJvKeyCode; MoveCount: Integer);\r\nvar\r\n IndexAxisZ: TJvAxisIndex;\r\n ValueZ: Integer;\r\nbegin\r\n IndexAxisZ := GetIndexAxisZ(AxisConfig);\r\n ValueZ := GetAxisValue(FullColor, IndexAxisZ);\r\n\r\n if ColorOrientation = coInverse then\r\n MoveCount := -MoveCount;\r\n\r\n case KeyCode of\r\n kcLeft:\r\n if Orientation = trHorizontal then\r\n ValueZ := ValueZ - MoveCount;\r\n kcRight:\r\n if Orientation = trHorizontal then\r\n ValueZ := ValueZ + MoveCount;\r\n kcUp:\r\n if Orientation = trVertical then\r\n ValueZ := ValueZ - MoveCount;\r\n kcDown:\r\n if Orientation = trVertical then\r\n ValueZ := ValueZ + MoveCount;\r\n end;\r\n\r\n with ColorSpace do\r\n ValueZ := EnsureRange(ValueZ, AxisMin[IndexAxisZ], AxisMax[IndexAxisZ]);\r\n\r\n FullColor := SetAxisValue(FullColor, IndexAxisZ, ValueZ);\r\nend;\r\n\r\nfunction TJvFullColorTrackBar.Linked: Boolean;\r\nbegin\r\n Result := FLink <> nil;\r\nend;\r\n\r\nfunction TJvFullColorTrackBar.LinkerName: TComponentName;\r\nbegin\r\n Result := FLink.Name;\r\nend;\r\n\r\nprocedure TJvFullColorTrackBar.MouseColor(Shift: TShiftState; X, Y: Integer);\r\nvar\r\n MinZ, MaxZ: Byte;\r\n AxisZ: TJvAxisIndex;\r\n GraphicRange: Integer;\r\n Pos: Integer;\r\nbegin\r\n if (not (ssLeft in Shift)) or (FBuffer.Width = 0) or (FBuffer.Height = 0) or\r\n (Width = 0) or (Height = 0) then\r\n Exit;\r\n if Orientation = trHorizontal then\r\n Pos := X - ArrowWidth\r\n else\r\n Pos := Y - ArrowWidth;\r\n\r\n if Orientation = trHorizontal then\r\n GraphicRange := FBuffer.Width - 1\r\n else\r\n GraphicRange := FBuffer.Height - 1;\r\n\r\n AxisZ := GetIndexAxisZ(AxisConfig);\r\n with ColorSpace do\r\n begin\r\n MinZ := AxisMin[AxisZ];\r\n MaxZ := AxisMax[AxisZ];\r\n\r\n Pos := EnsureRange((Pos * (MaxZ - MinZ)) div GraphicRange, 0, MaxZ - MinZ);\r\n if ColorOrientation = coInverse then\r\n Pos := MaxZ - Pos\r\n else\r\n Pos := Pos + MinZ;\r\n\r\n FullColor := SetAxisValue(FullColor, AxisZ, Pos);\r\n end;\r\n inherited MouseColor(Shift, X, Y);\r\nend;\r\n\r\nprocedure TJvFullColorTrackBar.SetArrowColor(const Value: TColor);\r\nbegin\r\n if FArrowColor <> Value then\r\n begin\r\n FArrowColor := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvFullColorTrackBar.SetArrowPosition(const Value: TJvArrowPosition);\r\nbegin\r\n if FArrowPosition <> Value then\r\n begin\r\n FArrowPosition := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvFullColorTrackBar.SetArrowWidth(const Value: Integer);\r\nbegin\r\n if FArrowWidth <> Value then\r\n begin\r\n FArrowWidth := Value;\r\n CalcSize;\r\n end;\r\nend;\r\n\r\nprocedure TJvFullColorTrackBar.SetOrientation(const Value: TTrackBarOrientation);\r\nbegin\r\n if FOrientation <> Value then\r\n begin\r\n FOrientation := Value;\r\n CalcSize;\r\n end;\r\nend;\r\n\r\nprocedure TJvFullColorTrackBar.SetColorOrientation(const Value: TJvFullColorOrientation);\r\nbegin\r\n if FColorOrientation <> Value then\r\n begin\r\n FColorOrientation := Value;\r\n WantDrawBuffer := True;\r\n end;\r\nend;\r\n\r\nprocedure TJvFullColorTrackBar.SetFullColor(const Value: TJvFullColor);\r\nvar\r\n AxisZ: TJvAxisIndex;\r\n OldValueX, OldValueY, OldValueZ, NewValueZ: Byte;\r\nbegin\r\n if Value <> FullColor then\r\n begin\r\n AxisZ := GetIndexAxisZ(AxisConfig);\r\n OldValueZ := GetAxisValue(FullColor, AxisZ);\r\n NewValueZ := GetAxisValue(Value, AxisZ);\r\n if NewValueZ <> OldValueZ then\r\n InvalidateCursor;\r\n if FullColorDrawing then\r\n begin\r\n OldValueX := ValueX;\r\n OldValueY := ValueY;\r\n inherited SetFullColor(Value);\r\n if ValueXAuto then\r\n UpdateDefaultValueX;\r\n if ValueYAuto then\r\n UpdateDefaultValueY;\r\n if (ValueX <> OldValueX) or (ValueY <> OldValueY) then\r\n WantDrawBuffer := True;\r\n end\r\n else\r\n inherited SetFullColor(Value);\r\n if NewValueZ <> OldValueZ then\r\n InvalidateCursor;\r\n end;\r\nend;\r\n\r\nprocedure TJvFullColorTrackBar.SetFullColorDrawing(const Value: Boolean);\r\nbegin\r\n if FFullColorDrawing <> Value then\r\n begin\r\n FFullColorDrawing := Value;\r\n WantDrawBuffer := True;\r\n end;\r\nend;\r\n\r\nprocedure TJvFullColorTrackBar.SetLink(AComponent: TComponent);\r\nbegin\r\n FLink := AComponent;\r\nend;\r\n\r\nprocedure TJvFullColorTrackBar.SetValueX(const Value: Byte);\r\nbegin\r\n FValueX := Value;\r\n FValueXAuto := False;\r\n WantDrawBuffer := True;\r\nend;\r\n\r\nprocedure TJvFullColorTrackBar.SetValueXAuto(const Value: Boolean);\r\nbegin\r\n FValueXAuto := Value;\r\n if Value then\r\n UpdateDefaultValueX;\r\n WantDrawBuffer := True;\r\nend;\r\n\r\nprocedure TJvFullColorTrackBar.SetValueY(const Value: Byte);\r\nbegin\r\n FValueY := Value;\r\n FValueYAuto := False;\r\n WantDrawBuffer := True;\r\nend;\r\n\r\nprocedure TJvFullColorTrackBar.SetValueYAuto(const Value: Boolean);\r\nbegin\r\n FValueYAuto := Value;\r\n if Value then\r\n UpdateDefaultValueY;\r\n WantDrawBuffer := True;\r\nend;\r\n\r\nprocedure TJvFullColorTrackBar.UpdateDefaultValueX;\r\nbegin\r\n if FullColorDrawing then\r\n FValueX := GetAxisValue(FullColor, GetIndexAxisX(AxisConfig))\r\n else\r\n FValueX := ColorSpace.AxisDefault[GetIndexAxisX(AxisConfig)];\r\nend;\r\n\r\nprocedure TJvFullColorTrackBar.UpdateDefaultValueY;\r\nbegin\r\n if FullColorDrawing then\r\n FValueY := GetAxisValue(FullColor, GetIndexAxisY(AxisConfig))\r\n else\r\n FValueY := ColorSpace.AxisDefault[GetIndexAxisY(AxisConfig)];\r\nend;\r\n\r\n//=== { TJvColorLabel } ======================================================\r\n\r\nconstructor TJvFullColorLabel.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n ControlStyle := ControlStyle - [csOpaque];\r\n FPen := TPen.Create;\r\n FPen.OnChange := GraphicChange;\r\n FBrush := TBrush.Create;\r\n FBrush.OnChange := GraphicChange;\r\n FShapeType := stRectangle;\r\n FShapePosition := spLeft;\r\n FSpacing := 5;\r\n FRoundShapeWidth := 4;\r\n FRoundShapeHeight := 4;\r\n FShapeWidth := 16;\r\n FShapeHeight := 16;\r\n FLabelColor := fclDEFWindowText;\r\n Width := 100;\r\n Height := 25;\r\nend;\r\n\r\ndestructor TJvFullColorLabel.Destroy;\r\nbegin\r\n FPen.Free;\r\n FBrush.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvFullColorLabel.CalcSize;\r\nbegin\r\n Canvas.Font := Font;\r\n if AutoSize then\r\n begin\r\n case ShapePosition of\r\n spLeft..spRight:\r\n begin\r\n Height := Max(ShapeHeight + Pen.Width, Canvas.TextHeight(Caption));\r\n Width := ShapeWidth + Pen.Width + Spacing + Canvas.TextWidth(FCaption);\r\n end;\r\n spTop..spBottom:\r\n begin\r\n Height := ShapeHeight + Spacing + Pen.Width + Canvas.TextHeight(Caption);\r\n Width := Max(ShapeWidth + Pen.Width, Canvas.TextWidth(Caption));\r\n end;\r\n end;\r\n AdjustSize;\r\n end\r\n else\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvFullColorLabel.GraphicChange(Sender: TObject);\r\nbegin\r\n CalcSize;\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvFullColorLabel.Paint;\r\nvar\r\n ShapeLeft, ShapeTop, TextLeft, TextTop: Integer;\r\nbegin\r\n with Canvas do\r\n begin\r\n Pen.Style := psClear;\r\n Brush.Style := bsSolid;\r\n Brush.Color := Parent.Brush.Color;\r\n Rectangle(0, 0, Width, Height);\r\n\r\n Font := Self.Font;\r\n Pen := Self.Pen;\r\n Brush := Self.Brush;\r\n Brush.Color := ColorSpaceManager.ConvertToColor(LabelColor);\r\n inherited Paint;\r\n case FShapePosition of\r\n spLeft:\r\n begin\r\n ShapeLeft := 0;\r\n ShapeTop := (Height - FShapeHeight) div 2;\r\n TextLeft := FShapeWidth + FSpacing;\r\n TextTop := (Height - TextHeight(FCaption)) div 2;\r\n end;\r\n spRight:\r\n begin\r\n ShapeLeft := TextWidth(FCaption) + FSpacing;\r\n ShapeTop := (Height - FShapeHeight) div 2;\r\n TextLeft := 0;\r\n TextTop := (Height - TextHeight(FCaption)) div 2;\r\n end;\r\n spTop:\r\n begin\r\n ShapeLeft := (Width - FShapeWidth) div 2;\r\n ShapeTop := 0;\r\n TextLeft := (Width - TextWidth(FCaption)) div 2;\r\n TextTop := FShapeHeight + FSpacing;\r\n end;\r\n spBottom:\r\n begin\r\n ShapeLeft := (Width - FShapeWidth) div 2;\r\n ShapeTop := TextHeight(FCaption) + FSpacing;\r\n TextLeft := (Width - TextWidth(FCaption)) div 2;\r\n TextTop := 0;\r\n end;\r\n else\r\n ShapeLeft := 0;\r\n ShapeTop := 0;\r\n TextLeft := 0;\r\n TextTop := 0;\r\n end;\r\n case FShapeType of\r\n stRectangle..stSquare:\r\n Rectangle(ShapeLeft, ShapeTop, ShapeLeft + FShapeWidth, ShapeTop + FShapeHeight);\r\n stRoundRect..stRoundSquare:\r\n RoundRect(ShapeLeft, ShapeTop, ShapeLeft + FShapeWidth, ShapeTop + FShapeHeight,\r\n RoundShapeWidth, RoundShapeHeight);\r\n stEllipse..stCircle:\r\n Ellipse(ShapeLeft, ShapeTop, ShapeLeft + FShapeWidth, ShapeTop + FShapeHeight);\r\n end;\r\n Brush.Style := bsClear;\r\n TextOut(TextLeft, TextTop, FCaption);\r\n end;\r\nend;\r\n\r\nprocedure TJvFullColorLabel.SetAutoSize(Value: Boolean);\r\nbegin\r\n inherited SetAutoSize(Value);\r\n CalcSize;\r\nend;\r\n\r\nprocedure TJvFullColorLabel.SetCaption(const Value: TCaption);\r\nbegin\r\n if FCaption <> Value then\r\n begin\r\n FCaption := Value;\r\n CalcSize;\r\n end;\r\nend;\r\n\r\nprocedure TJvFullColorLabel.SetName(const Value: TComponentName);\r\nvar\r\n Equal: Boolean;\r\nbegin\r\n Equal := Name = FCaption;\r\n inherited SetName(Value);\r\n if Equal then\r\n Caption := Name;\r\nend;\r\n\r\nprocedure TJvFullColorLabel.SetRoundShapeHeight(const Value: Integer);\r\nbegin\r\n if (Value <> FRoundShapeHeight) and (Value < ShapeHeight div 2) then\r\n begin\r\n FRoundShapeHeight := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvFullColorLabel.SetRoundShapeWidth(const Value: Integer);\r\nbegin\r\n if (Value <> FRoundShapeWidth) and (Value < ShapeWidth div 2) then\r\n begin\r\n FRoundShapeWidth := Value;\r\n if FRoundShapeWidth > Value div 2 then\r\n FRoundShapeWidth := Value div 2;\r\n if Shape in [stSquare, stRoundSquare, stCircle] then\r\n FShapeHeight := FShapeWidth;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvFullColorLabel.SetShapeHeight(const Value: Integer);\r\nbegin\r\n if FShapeHeight <> Value then\r\n begin\r\n FShapeHeight := Value;\r\n if FRoundShapeHeight > Value div 2 then\r\n FRoundShapeHeight := Value div 2;\r\n if Shape in [stSquare, stRoundSquare, stCircle] then\r\n FShapeWidth := FShapeHeight;\r\n CalcSize;\r\n end;\r\nend;\r\n\r\nprocedure TJvFullColorLabel.SetShapePosition(const Value: TJvShapePosition);\r\nbegin\r\n if FShapePosition <> Value then\r\n begin\r\n FShapePosition := Value;\r\n CalcSize;\r\n end;\r\nend;\r\n\r\nprocedure TJvFullColorLabel.SetShapeType(const Value: TShapeType);\r\nbegin\r\n if FShapeType <> Value then\r\n begin\r\n FShapeType := Value;\r\n if Shape in [stSquare, stRoundSquare, stCircle] then\r\n begin\r\n FShapeWidth := Min(FShapeWidth, FShapeHeight);\r\n FShapeHeight := FShapeWidth;\r\n end;\r\n CalcSize;\r\n end;\r\nend;\r\n\r\nprocedure TJvFullColorLabel.SetShapeWidth(const Value: Integer);\r\nbegin\r\n if FShapeWidth <> Value then\r\n begin\r\n FShapeWidth := Value;\r\n if Shape in [stSquare, stRoundSquare, stCircle] then\r\n FShapeHeight := FShapeWidth;\r\n CalcSize;\r\n end;\r\nend;\r\n\r\nprocedure TJvFullColorLabel.SetSpacing(const Value: Integer);\r\nbegin\r\n if FSpacing <> Value then\r\n begin\r\n FSpacing := Value;\r\n CalcSize;\r\n end;\r\nend;\r\n\r\nprocedure TJvFullColorLabel.SetLabelColor(const Value: TJvFullColor);\r\nbegin\r\n if FLabelColor <> Value then\r\n begin\r\n FLabelColor := Value;\r\n Brush.Color := ColorSpaceManager.ConvertToColor(Value);\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvFullColorLabel.SetBrush(const Value: TBrush);\r\nbegin\r\n FBrush.Assign(Value);\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvFullColorLabel.SetPen(const Value: TPen);\r\nbegin\r\n FPen.Assign(Value);\r\n CalcSize;\r\nend;\r\n\r\n//=== { TJvColorSpaceCombo } =================================================\r\n\r\nconstructor TJvFullColorSpaceCombo.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n Style := csDropDownList;\r\n FAllowVariable := True;\r\n FItemFormat := cfBoth;\r\nend;\r\n\r\nprocedure TJvFullColorSpaceCombo.CreateWnd;\r\nbegin\r\n inherited CreateWnd;\r\n MakeList;\r\nend;\r\n\r\nfunction TJvFullColorSpaceCombo.GetColorSpace: TJvColorSpace;\r\nbegin\r\n if ItemIndex > -1 then\r\n Result := TJvColorSpace(Self.Items.Objects[ItemIndex])\r\n else\r\n Result := nil;\r\nend;\r\n\r\nfunction TJvFullColorSpaceCombo.GetColorSpaceID: TJvFullColorSpaceID;\r\nvar\r\n CS: TJvColorSpace;\r\nbegin\r\n CS := SelectedSpace;\r\n if CS <> nil then\r\n Result := CS.ID\r\n else\r\n Result := csRGB;\r\nend;\r\n\r\nprocedure TJvFullColorSpaceCombo.MakeList;\r\nvar\r\n Index: Integer;\r\n LColorSpace: TJvColorSpace;\r\n OldColorID: TJvFullColorSpaceID;\r\n ACaption: string;\r\nbegin\r\n OldColorID := ColorSpaceID;\r\n with ColorSpaceManager, Items do\r\n begin\r\n Clear;\r\n for Index := 0 to ColorSpaceManager.Count - 1 do\r\n begin\r\n LColorSpace := ColorSpaceByIndex[Index];\r\n if (LColorSpace.ID <> csDEF) or AllowVariable then\r\n begin\r\n if Assigned(FOnFormatItem) then\r\n FOnFormatItem(Self, LColorSpace, ACaption)\r\n else\r\n ACaption := ColorSpaceToString(LColorSpace, ItemFormat);\r\n AddObject(ACaption, LColorSpace);\r\n end;\r\n end;\r\n end;\r\n ColorSpaceID := OldColorID;\r\nend;\r\n\r\nprocedure TJvFullColorSpaceCombo.SetAllowVariable(const Value: Boolean);\r\nbegin\r\n if FAllowVariable <> Value then\r\n begin\r\n FAllowVariable := Value;\r\n MakeList;\r\n end;\r\nend;\r\n\r\nprocedure TJvFullColorSpaceCombo.SetColorSpace(const Value: TJvColorSpace);\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := 0 to Items.Count - 1 do\r\n if Value.ID = TJvColorSpace(Items.Objects[I]).ID then\r\n begin\r\n ItemIndex := I;\r\n Exit;\r\n end;\r\nend;\r\n\r\nprocedure TJvFullColorSpaceCombo.SetColorSpaceID(const Value: TJvFullColorSpaceID);\r\nbegin\r\n SetColorSpace(ColorSpaceManager.ColorSpace[Value]);\r\nend;\r\n\r\nprocedure TJvFullColorSpaceCombo.SetItemFormat(const Value: TJvFullColorSpaceFormat);\r\nbegin\r\n if FItemFormat <> Value then\r\n begin\r\n FItemFormat := Value;\r\n MakeList;\r\n end;\r\nend;\r\n\r\n//=== { TJvColorAxisConfigCombo } ============================================\r\n\r\nconstructor TJvFullColorAxisCombo.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n Style := csDropDownList;\r\n FColorID := csRGB;\r\n FItemFormat := afComplete;\r\nend;\r\n\r\nprocedure TJvFullColorAxisCombo.CreateWnd;\r\nbegin\r\n inherited CreateWnd;\r\n MakeList;\r\nend;\r\n\r\nfunction TJvFullColorAxisCombo.GetSelected: TJvFullColorAxisConfig;\r\nbegin\r\n if ItemIndex = -1 then\r\n Result := acXYZ\r\n else\r\n Result := TJvFullColorAxisConfig(ItemIndex);\r\nend;\r\n\r\nprocedure TJvFullColorAxisCombo.MakeList;\r\nvar\r\n Index: TJvFullColorAxisConfig;\r\n LColorSpace: TJvColorSpace;\r\n OldItemIndex: Integer;\r\n FormattedItem: string;\r\nbegin\r\n OldItemIndex := ItemIndex;\r\n LColorSpace := ColorSpaceManager.ColorSpace[ColorID];\r\n with Items do\r\n begin\r\n Clear;\r\n for Index := Low(TJvFullColorAxisConfig) to High(TJvFullColorAxisConfig) do\r\n begin\r\n if Assigned(FOnFormatItem) then\r\n FOnFormatItem(Self,Index,FormattedItem)\r\n else\r\n FormattedItem := AxisConfigToString(Index, ItemFormat, LColorSpace);\r\n Add(FormattedItem);\r\n end;\r\n end;\r\n if OldItemIndex > -1 then\r\n ItemIndex := OldItemIndex\r\n else\r\n ItemIndex := 0;\r\nend;\r\n\r\nprocedure TJvFullColorAxisCombo.SetColorID(const Value: TJvFullColorSpaceID);\r\nbegin\r\n if FColorID <> Value then\r\n begin\r\n FColorID := Value;\r\n MakeList;\r\n end;\r\nend;\r\n\r\nprocedure TJvFullColorAxisCombo.SetItemFormat(const Value: TJvFullColorAxisConfigFormat);\r\nbegin\r\n if FItemFormat <> Value then\r\n begin\r\n FItemFormat := Value;\r\n MakeList;\r\n end;\r\nend;\r\n\r\nprocedure TJvFullColorAxisCombo.SetOnFormatItem(\r\n const Value: TJvFullColorAxisFormatEvent);\r\nbegin\r\n FOnFormatItem := Value;\r\n MakeList;\r\nend;\r\n\r\nprocedure TJvFullColorAxisCombo.SetSelected(const Value: TJvFullColorAxisConfig);\r\nbegin\r\n ItemIndex := Ord(Value);\r\nend;\r\n\r\n//=== { TJvFullColorList } ===================================================\r\n\r\nconstructor TJvFullColorList.Create;\r\nbegin\r\n inherited Create;\r\n FList := nil;\r\n FCount := 0;\r\n FCapacity := 0;\r\n FAllocBy := 2;\r\nend;\r\n\r\ndestructor TJvFullColorList.Destroy;\r\nbegin\r\n Clear;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJvFullColorList.Add(AColor: TJvFullColor): Integer;\r\nbegin\r\n Result := FCount;\r\n if Result = Capacity then\r\n Grow;\r\n FList^[Result] := AColor;\r\n Inc(FCount);\r\n Change(Result, foAdded);\r\nend;\r\n\r\nprocedure TJvFullColorList.Assign(Source: TPersistent);\r\nvar\r\n Index: Integer;\r\nbegin\r\n if Source is TJvFullColorList then\r\n with TJvFullColorList(Source) do\r\n begin\r\n Self.BeginUpdate;\r\n Self.Count := Count;\r\n for Index := 0 to Self.Count - 1 do\r\n Self.Items[Index] := Items[Index];\r\n Self.EndUpdate;\r\n Self.Change(-1, foAllChanged);\r\n end\r\n else\r\n inherited Assign(Source);\r\nend;\r\n\r\nprocedure TJvFullColorList.Change(AIndex: Integer;\r\n AOperation: TJvFullColorListOperation);\r\nbegin\r\n if (UpdateCount = 0) and Assigned(FOnChange) then\r\n FOnChange(Self, AIndex, AOperation);\r\nend;\r\n\r\nprocedure TJvFullColorList.Clear;\r\nbegin\r\n Capacity := 0;\r\n Change(-1, foAllChanged);\r\nend;\r\n\r\nprocedure TJvFullColorList.DefineProperties(Filer: TFiler);\r\nbegin\r\n inherited DefineProperties(Filer);\r\n Filer.DefineProperty('Items', ReadItems, WriteItems, Count > 0);\r\nend;\r\n\r\nprocedure TJvFullColorList.Delete(Index: Integer);\r\nbegin\r\n if (Index < 0) or (Index >= FCount) then\r\n EJvFullColorListError.CreateFmt(SListIndexError, [Index]);\r\n\r\n Dec(FCount);\r\n if Index < Count then\r\n Move(FList^[Index + 1], FList^[Index], (Count - Index) * SizeOf(TJvFullColor));\r\n\r\n Change(Index, foDeleted);\r\nend;\r\n\r\nprocedure TJvFullColorList.DeleteRedundant;\r\nbegin\r\nend;\r\n\r\nprocedure TJvFullColorList.Exchange(Index1, Index2: Integer);\r\nvar\r\n Tmp: TJvFullColor;\r\nbegin\r\n if (Index1 >= Count) or (Index1 < 0) then\r\n raise EJvFullColorListError.CreateResFmt(@SListIndexError, [Index1]);\r\n\r\n if (Index2 >= Count) or (Index2 < 0) then\r\n raise EJvFullColorListError.CreateResFmt(@SListIndexError, [Index2]);\r\n\r\n Tmp := FList^[Index1];\r\n FList^[Index1] := FList^[Index2];\r\n FList^[Index2] := Tmp;\r\n\r\n Change(Index1, foChanged);\r\n Change(Index2, foChanged);\r\nend;\r\n\r\nfunction TJvFullColorList.GetItem(Index: Integer): TJvFullColor;\r\nbegin\r\n if (Index >= Count) or (Index < 0) then\r\n raise EJvFullColorListError.CreateResFmt(@SListIndexError, [Index]);\r\n\r\n Result := FList^[Index];\r\nend;\r\n\r\nprocedure TJvFullColorList.Grow;\r\nbegin\r\n Capacity := Capacity + AllocBy;\r\nend;\r\n\r\nfunction TJvFullColorList.IndexOf(AColor: TJvFullColor): Integer;\r\nbegin\r\n for Result := 0 to Count - 1 do\r\n if FList^[Result] = AColor then\r\n Exit;\r\n Result := -1;\r\nend;\r\n\r\nprocedure TJvFullColorList.Insert(Index: Integer; AColor: TJvFullColor);\r\nbegin\r\n if (Index > Count) or (Index < 0) then\r\n EJvFullColorListError.CreateFmt(SListIndexError, [Index]);\r\n\r\n if Count = Capacity then\r\n Grow;\r\n\r\n if Index < Count then\r\n Move(FList^[Index], FList^[Index + 1], (FCount - Index) * SizeOf(TJvFullColor));\r\n\r\n FList^[Index] := AColor;\r\n Inc(FCount);\r\n\r\n Change(Index, foAdded);\r\nend;\r\n\r\nprocedure TJvFullColorList.BeginUpdate;\r\nbegin\r\n Inc(FUpdateCount);\r\nend;\r\n\r\nprocedure TJvFullColorList.ReadItems(Reader: TReader);\r\nbegin\r\n try\r\n Reader.ReadListBegin;\r\n BeginUpdate;\r\n Clear;\r\n while not Reader.EndOfList do\r\n Add(Reader.ReadInteger);\r\n finally\r\n EndUpdate;\r\n Reader.ReadListEnd;\r\n end;\r\nend;\r\n\r\nfunction TJvFullColorList.Remove(AColor: TJvFullColor): Integer;\r\nbegin\r\n Result := IndexOf(AColor);\r\n if Result >= 0 then\r\n Delete(Result);\r\nend;\r\n\r\nprocedure TJvFullColorList.SetAllocBy(const Value: Integer);\r\nbegin\r\n FAllocBy := Max(Value, 1);\r\nend;\r\n\r\nprocedure TJvFullColorList.SetCapacity(const Value: Integer);\r\nbegin\r\n ReallocMem(FList, Value * SizeOf(TJvFullColor));\r\n FCapacity := Value;\r\n if FCount > FCapacity then\r\n begin\r\n FCount := FCapacity;\r\n Change(-1, foAllChanged);\r\n end;\r\nend;\r\n\r\nprocedure TJvFullColorList.SetCount(const Value: Integer);\r\nbegin\r\n FCount := Value;\r\n if FCount > FCapacity then\r\n Capacity := FCount;\r\n Change(-1, foAllChanged);\r\nend;\r\n\r\nprocedure TJvFullColorList.SetItem(Index: Integer; const Value: TJvFullColor);\r\nbegin\r\n if (Index >= Count) or (Index < 0) then\r\n EJvFullColorListError.CreateFmt(SListIndexError, [Index]);\r\n\r\n FList^[Index] := Value;\r\n Change(Index, foChanged);\r\nend;\r\n\r\nprocedure TJvFullColorList.EndUpdate;\r\nbegin\r\n if FUpdateCount > 0 then\r\n Dec(FUpdateCount);\r\n if FUpdateCount = 0 then\r\n Change(-1, foAllChanged);\r\nend;\r\n\r\nprocedure TJvFullColorList.WriteItems(Writer: TWriter);\r\nvar\r\n I: Integer;\r\nbegin\r\n Writer.WriteListBegin;\r\n for I := 0 to Count - 1 do\r\n Writer.WriteInteger(FList^[I]);\r\n Writer.WriteListEnd;\r\nend;\r\n\r\n//=== { TFullColorGroup } ====================================================\r\n\r\nconstructor TJvFullColorGroup.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n ControlStyle := ControlStyle + [csOpaque];\r\n FItems := TJvFullColorList.Create;\r\n FItems.OnChange := ItemsChange;\r\n FBrush := TBrush.Create;\r\n FBrush.OnChange := BrushChange;\r\n FEdge := feRaised;\r\n FSelectedEdge := feLowered;\r\n FMouseEdge := feRaised;\r\n FColCount := 5;\r\n FSquareSize := 6;\r\n FSelectedIndex := -1;\r\n FMouseIndex := -1;\r\n BevelKind := bkTile;\r\n Width := 100;\r\n Height := 100;\r\nend;\r\n\r\ndestructor TJvFullColorGroup.Destroy;\r\nbegin\r\n FItems.Free;\r\n FBrush.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvFullColorGroup.CalcRects(out XPos, YPos, XInc, YInc: Integer);\r\nvar\r\n XOffset: Integer;\r\n YOffset: Integer;\r\nbegin\r\n XOffset := Width - (FSquareSize * ColCount) - 2;\r\n XInc := XOffset div ColCount;\r\n XPos := ((XOffset - (XInc * (ColCount - 1))) div 2) + 1;\r\n\r\n YOffset := Height - (FSquareSize * RowCount) - 2;\r\n YInc := YOffset div RowCount;\r\n YPos := ((YOffset - (YInc * (RowCount - 1))) div 2) + 1;\r\nend;\r\n\r\nprocedure TJvFullColorGroup.ItemsChange(Sender: TObject; Index: Integer;\r\n Operation: TJvFullColorListOperation);\r\nbegin\r\n case Operation of\r\n foAllChanged:\r\n begin\r\n FMouseIndex := -1;\r\n FSelectedIndex := -1;\r\n Invalidate;\r\n end;\r\n foDeleted:\r\n begin\r\n FMouseIndex := -1;\r\n FSelectedIndex := EnsureRange(FSelectedIndex, -1, Items.Count - 1);\r\n Invalidate;\r\n end;\r\n foAdded:\r\n Invalidate;\r\n foChanged:\r\n InvalidateIndex(Index);\r\n end;\r\nend;\r\n\r\nprocedure TJvFullColorGroup.BrushChange(Sender: TObject);\r\nbegin\r\n Refresh;\r\nend;\r\n\r\nprocedure TJvFullColorGroup.InvalidateIndex(AIndex: Integer);\r\nvar\r\n ARect: TRect;\r\n ColIndex, RowIndex: Integer;\r\n XPos, YPos, XInc, YInc: Integer;\r\nbegin\r\n if AIndex <> -1 then\r\n begin\r\n CalcRects(XPos, YPos, XInc, YInc);\r\n ColIndex := AIndex mod ColCount;\r\n RowIndex := AIndex div ColCount;\r\n ARect.Left := XPos + ColIndex * (XInc + FSquareSize);\r\n ARect.Top := YPos + RowIndex * (YInc + FSquareSize);\r\n ARect.Right := ARect.Left + FSquareSize + 1;\r\n ARect.Bottom := ARect.Top + FSquareSize + 1;\r\n Windows.InvalidateRect(Handle, @ARect, False);\r\n end;\r\nend;\r\n\r\nprocedure TJvFullColorGroup.MouseLeave(var Msg: TWMMouse);\r\nbegin\r\n FMouseIndex := -1;\r\n Msg.Result := 1;\r\n Refresh;\r\nend;\r\n\r\n{$IFDEF RTL200_UP}\r\n// for D2009 \"Use Controls.PHintInfo\" warning\r\ntype\r\n PHintInfo = Controls.PHintInfo;\r\n{$ENDIF RTL200_UP}\r\n\r\nprocedure TJvFullColorGroup.CMHintShow(var Msg: TMessage);\r\nvar\r\n AHintInfo: PHintInfo;\r\n Sum, XPos, YPos, XInc, YInc, Index: Integer;\r\n ColorIndex: Integer;\r\n AFullColor: TJvFullColor;\r\n AColor: TColor;\r\n AColorID: TJvFullColorSpaceID;\r\n AColorSpace: TJvColorSpace;\r\nbegin\r\n AHintInfo := PHintInfo(Msg.LParam);\r\n ColorIndex := -1;\r\n\r\n CalcRects(XPos, YPos, XInc, YInc);\r\n\r\n Sum := YPos;\r\n with AHintInfo^ do\r\n for Index := 0 to RowCount - 1 do\r\n begin\r\n if CursorPos.Y < Sum then\r\n begin\r\n CursorRect.Top := Max(0, Sum - YInc);\r\n CursorRect.Bottom := Sum;\r\n Break;\r\n end\r\n else\r\n if (CursorPos.Y >= Sum) and (CursorPos.Y < Sum + FSquareSize) then\r\n begin\r\n CursorRect.Top := Sum;\r\n CursorRect.Bottom := Sum + FSquareSize;\r\n ColorIndex := Index * ColCount;\r\n Break;\r\n end;\r\n Inc(Sum, FSquareSize + YInc);\r\n end;\r\n\r\n Sum := XPos;\r\n with AHintInfo^ do\r\n for Index := 0 to ColCount do\r\n // not -1 because of last space after the colcount - 1\r\n begin\r\n if CursorPos.X < Sum then\r\n begin\r\n CursorRect.Left := Max(0, Sum - XInc);\r\n CursorRect.Right := Sum;\r\n ColorIndex := -1;\r\n Break;\r\n end\r\n else\r\n if (CursorPos.X >= Sum) and (CursorPos.X < Sum + FSquareSize) then\r\n begin\r\n CursorRect.Left := Sum;\r\n CursorRect.Right := Sum + FSquareSize;\r\n if ColorIndex <> -1 then\r\n ColorIndex := ColorIndex + Index;\r\n Break;\r\n end;\r\n Inc(Sum, FSquareSize + XInc);\r\n end;\r\n\r\n if ColorIndex >= Items.Count then\r\n ColorIndex := -1;\r\n\r\n if ColorIndex > -1 then\r\n with ColorSpaceManager do\r\n begin\r\n AFullColor := Items.Items[ColorIndex];\r\n AColorID := GetColorSpaceID(AFullColor);\r\n AColorSpace := ColorSpace[AColorID];\r\n\r\n if AColorSpace.ID = csDEF then\r\n with TJvDEFColorSpace(AColorSpace) do\r\n begin\r\n AColor := ConvertToColor(AFullColor);\r\n for Index := 0 to ColorCount - 1 do\r\n if AColor = ColorValue[Index] then\r\n begin\r\n AHintInfo.HintStr := Format(RsColorHintFmt1, [AFullColor,\r\n AColorSpace.Name, AColorID, ColorName[Index], ColorPrettyName[Index]]);\r\n Break;\r\n end;\r\n end\r\n else\r\n AHintInfo.HintStr := Format(RsColorHintFmt2, [AFullColor, AColorSpace.Name, AColorID,\r\n AColorSpace.AxisName[axIndex0], GetAxisValue(AFullColor, axIndex0),\r\n AColorSpace.AxisName[axIndex1], GetAxisValue(AFullColor, axIndex1),\r\n AColorSpace.AxisName[axIndex2], GetAxisValue(AFullColor, axIndex2)]);\r\n\r\n if Assigned(FOnFormatHint) then\r\n FOnFormatHint(Self, AFullColor, AHintInfo.HintStr);\r\n end\r\n else\r\n AHintInfo.HintStr := Hint;\r\n\r\n Msg.Result := 0;\r\nend;\r\n\r\nprocedure TJvFullColorGroup.MouseMove(Shift: TShiftState; X, Y: Integer);\r\nvar\r\n Index: Integer;\r\n Sum: Integer;\r\n XPos, YPos, XInc, YInc: Integer;\r\n ColIndex, RowIndex: Integer;\r\nbegin\r\n inherited MouseMove(Shift, X, Y);\r\n\r\n CalcRects(XPos, YPos, XInc, YInc);\r\n\r\n Sum := XPos;\r\n if X < XPos then\r\n begin\r\n InvalidateIndex(MouseIndex);\r\n FMouseIndex := -1;\r\n Exit;\r\n end;\r\n ColIndex := -1;\r\n for Index := 0 to ColCount - 1 do\r\n begin\r\n if (X >= Sum) and (X < Sum + FSquareSize) then\r\n begin\r\n ColIndex := Index;\r\n Break;\r\n end;\r\n if (X >= Sum + FSquareSize) and (X < Sum + FSquareSize + XInc) then\r\n Break;\r\n Inc(Sum, FSquareSize + XInc);\r\n end;\r\n\r\n if ColIndex = -1 then\r\n begin\r\n InvalidateIndex(MouseIndex);\r\n FMouseIndex := -1;\r\n Exit;\r\n end;\r\n\r\n Sum := YPos;\r\n if Y < YPos then\r\n begin\r\n InvalidateIndex(MouseIndex);\r\n FMouseIndex := -1;\r\n Exit;\r\n end;\r\n RowIndex := -1;\r\n for Index := 0 to RowCount - 1 do\r\n begin\r\n if (Y >= Sum) and (Y < Sum + FSquareSize) then\r\n begin\r\n RowIndex := Index;\r\n Break;\r\n end;\r\n if (Y >= Sum + FSquareSize) and (Y < Sum + FSquareSize + YInc) then\r\n Break;\r\n Inc(Sum, FSquareSize + YInc);\r\n end;\r\n if RowIndex = -1 then\r\n begin\r\n InvalidateIndex(MouseIndex);\r\n FMouseIndex := -1;\r\n Exit;\r\n end;\r\n\r\n InvalidateIndex(MouseIndex);\r\n FMouseIndex := RowIndex * ColCount + ColIndex;\r\n if MouseIndex > Items.Count - 1 then\r\n FMouseIndex := -1;\r\n InvalidateIndex(MouseIndex);\r\nend;\r\n\r\nprocedure TJvFullColorGroup.MouseDown(Button: TMouseButton;\r\n Shift: TShiftState; X, Y: Integer);\r\nbegin\r\n inherited MouseDown(Button, Shift, X, Y);\r\n InvalidateIndex(SelectedIndex);\r\n SelectedIndex := MouseIndex;\r\n InvalidateIndex(SelectedIndex);\r\nend;\r\n\r\nprocedure TJvFullColorGroup.Paint;\r\nvar\r\n Index, IndexX, IndexY, XMaj: Integer;\r\n XOffset, YOffset, XInc, YInc: Integer;\r\n X, Y: Integer;\r\n Edge: TJvFullColorEdge;\r\n ClipRect: TRect;\r\n\r\n procedure BevelRect(const R: TRect; Style: TJvFullColorEdge;\r\n FillStyle: TBrushStyle; FillColor: TColor);\r\n var\r\n Color1, Color2: TColor;\r\n begin\r\n case Style of\r\n feLowered:\r\n begin\r\n Color1 := clBtnShadow;\r\n Color2 := clBtnHighlight;\r\n end;\r\n feRaised:\r\n begin\r\n Color1 := clBtnHighlight;\r\n Color2 := clBtnShadow;\r\n end;\r\n else\r\n Color1 := clBlack;\r\n Color2 := clBlack;\r\n end;\r\n\r\n with Canvas do\r\n begin\r\n Brush.Color := FillColor;\r\n Brush.Style := FillStyle;\r\n Pen.Color := FillColor;\r\n Pen.Style := psClear;\r\n Rectangle(R.Left + 1, R.Top + 1, R.Right + 1, R.Bottom + 1);\r\n\r\n Pen.Style := psSolid;\r\n Pen.Color := Color1;\r\n PolyLine([Point(R.Left, R.Bottom), Point(R.Left, R.Top),\r\n Point(R.Right, R.Top)]);\r\n Pen.Color := Color2;\r\n PolyLine([Point(R.Right, R.Top), Point(R.Right, R.Bottom),\r\n Point(R.Left, R.Bottom)]);\r\n end;\r\n end;\r\n\r\nbegin\r\n inherited Paint;\r\n CalcRects(XOffset, YOffset, XInc, YInc);\r\n\r\n Y := YOffset;\r\n X := XOffset;\r\n ClipRect := Canvas.ClipRect;\r\n\r\n Index := 0;\r\n while Index < Items.Count do\r\n begin\r\n if Index = SelectedIndex then\r\n Edge := SelectedEdge\r\n else\r\n if Index = MouseIndex then\r\n Edge := MouseEdge\r\n else\r\n Edge := feFlat;\r\n\r\n BevelRect(Rect(X, Y, X + FSquareSize, Y + FSquareSize), Edge, Brush.Style,\r\n ColorSpaceManager.ConvertToColor(Items[Index]));\r\n Inc(Index);\r\n if Index mod ColCount = 0 then\r\n begin\r\n X := XOffset;\r\n Inc(Y, YInc + FSquareSize);\r\n end\r\n else\r\n Inc(X, XInc + FSquareSize);\r\n end;\r\n\r\n with Canvas do\r\n begin\r\n Brush.Style := bsSolid;\r\n Brush.Color := Color;\r\n Pen.Color := Color;\r\n Y := YOffset;\r\n for IndexY := 0 to RowCount do\r\n begin\r\n Rectangle(Max(ClipRect.Left, 1), Max(Y - YInc + 1, 1),\r\n Min(ClipRect.Right, Width - 2), Min(Y, Height - 2));\r\n X := XOffset;\r\n for IndexX := 0 to ColCount do\r\n begin\r\n if IndexX + IndexY * ColCount >= Items.Count then\r\n XMaj := FSquareSize + 1\r\n else\r\n XMaj := 0;\r\n Rectangle(Max(X - XInc + 1, 1), Min(Max(Y, 1), Height - 2),\r\n Min(X + XMaj, Width - 2), Min(Y + FSquareSize + 1, Height - 2));\r\n Inc(X, XInc + FSquareSize);\r\n end;\r\n Inc(Y, YInc + FSquareSize);\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvFullColorGroup.SetEdge(const Value: TJvFullColorEdge);\r\nbegin\r\n FEdge := Value;\r\n Refresh;\r\nend;\r\n\r\nprocedure TJvFullColorGroup.SetMouseEdge(const Value: TJvFullColorEdge);\r\nbegin\r\n FMouseEdge := Value;\r\n Refresh;\r\nend;\r\n\r\nprocedure TJvFullColorGroup.SetSelectedEdge(const Value: TJvFullColorEdge);\r\nbegin\r\n FSelectedEdge := Value;\r\n Refresh;\r\nend;\r\n\r\nprocedure TJvFullColorGroup.SetColCount(const Value: Integer);\r\nbegin\r\n if Value <= 0 then\r\n FColCount := 1\r\n else\r\n FColCount := Value;\r\n Refresh;\r\nend;\r\n\r\nfunction TJvFullColorGroup.GetRowCount: Integer;\r\nbegin\r\n Result := Max((Items.Count + ColCount - 1) div ColCount, 1);\r\nend;\r\n\r\nprocedure TJvFullColorGroup.SetItems(const Value: TJvFullColorList);\r\nbegin\r\n FItems.Assign(Value);\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvFullColorGroup.SetSquareSize(const Value: Integer);\r\nvar\r\n TempValue: Integer;\r\nbegin\r\n if FSquareSize < 0 then\r\n FSquareSize := -FSquareSize;\r\n\r\n if FSquareSize = 0 then\r\n FSquareSize := 1;\r\n\r\n FSquareSize := Value;\r\n\r\n TempValue := (Width - 2) div ColCount;\r\n if TempValue < FSquareSize then\r\n FSquareSize := TempValue;\r\n\r\n TempValue := (Height - 2) div (Items.Count div ColCount + 1);\r\n if TempValue < FSquareSize then\r\n FSquareSize := TempValue;\r\n\r\n Refresh;\r\nend;\r\n\r\nfunction TJvFullColorGroup.GetSelected: TJvFullColor;\r\nbegin\r\n if SelectedIndex > -1 then\r\n Result := Items[SelectedIndex]\r\n else\r\n Result := clNone;\r\nend;\r\n\r\nprocedure TJvFullColorGroup.SetSelected(const Value: TJvFullColor);\r\nbegin\r\n SelectedIndex := Items.IndexOf(Value);\r\nend;\r\n\r\nprocedure TJvFullColorGroup.SetSelectedIndex(const Value: Integer);\r\nbegin\r\n FSelectedIndex := EnsureRange(Value, -1, Items.Count - 1);\r\n if Assigned(FOnChange) then\r\n FOnChange(Self);\r\nend;\r\n\r\nprocedure TJvFullColorGroup.SetBrush(const Value: TBrush);\r\nbegin\r\n FBrush.Assign(Value);\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvFullColorDialogs.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: ColorDialogs.pas, released on 2004-09-11.\r\n\r\nThe Initial Developer of the Original Code is Florent Ouchet [ouchet dott florent att laposte dott net]\r\nPortions created by Florent Ouchet are Copyright (C) 2004 Florent Ouchet.\r\nAll Rights Reserved.\r\n\r\nContributor(s): -\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvFullColorDialogs.pas 13104 2011-09-07 06:50:43Z obones $\r\n\r\nunit JvFullColorDialogs;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Classes, Graphics, Forms,\r\n JvFullColorSpaces, JvFullColorRotate;\r\n\r\ntype\r\n TJvFullColorDialogOption =\r\n (foFullOpen, foPreventExpand, foShowHelp,\r\n foAllowSpaceChange, foConvertToOriginalSpace,\r\n foShowNewPreview, foShowOldPreview,\r\n foShowPredefined, foAllowVariable,\r\n foNoneAndDefault, foShowApply);\r\n TJvFullColorDialogOptions = set of TJvFullColorDialogOption;\r\n\r\n TJvFullColorCircleDialogOption =\r\n (coFullOpen, coPreventExpand,\r\n coShowHelp, coAllowSpaceChange,\r\n coShowNewPreview, coShowOldPreview,\r\n coCommon, coRed, coGreen, coBlue,\r\n coShowSaturation, coDefaultRange,\r\n coShowApply);\r\n TJvFullColorCircleDialogOptions = set of TJvFullColorCircleDialogOption;\r\n\r\nconst\r\n JvDefaultFullColorDialogOptions =\r\n [foFullOpen, foAllowSpaceChange, foAllowVariable,\r\n foShowNewPreview, foShowOldPreview, foShowPredefined, foShowApply];\r\n\r\n JvDefaultColorCircleDialogOptions =\r\n [coFullOpen, coAllowSpaceChange,\r\n coShowNewPreview, coShowOldPreview,\r\n coCommon, coRed, coGreen, coBlue,\r\n coShowSaturation, coShowApply];\r\n\r\ntype\r\n TJvAxisType = (atCommon, atRed, atGreen, atBlue);\r\n\r\n TJvFullColorEvent = procedure(Sender: TObject; AFullColor: TJvFullColor) of object;\r\n\r\n TJvColorCircleEvent = procedure(Sender: TObject) of object;\r\n\r\n TJvFullColorDialog = class;\r\n TJvFullColorCircleDialog = class;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvFullColorDialog = class(TComponent)\r\n private\r\n FOptions: TJvFullColorDialogOptions;\r\n FTitle: string;\r\n FFullColor: TJvFullColor;\r\n FOnApply: TJvFullColorEvent;\r\n FForm: TForm;\r\n FOnCloseQuery: TCloseQueryEvent;\r\n FOnShow: TNotifyEvent;\r\n FHelpContext: THelpContext;\r\n FOldColorSpace: TJvFullColorSpaceID;\r\n function GetFullColor: TJvFullColor;\r\n procedure SetFullColor(const Value: TJvFullColor);\r\n procedure SetHelpContext(const Value: THelpContext);\r\n procedure SetOptions(const Value: TJvFullColorDialogOptions);\r\n procedure SetTitle(const Value: string);\r\n function GetColor: TColor;\r\n protected\r\n procedure FormApply(Sender: TObject);\r\n procedure FormShow(Sender: TObject);\r\n procedure FormClose(Sender: TObject; var Action: TCloseAction);\r\n property OldColorSpace: TJvFullColorSpaceID read FOldColorSpace;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n function Execute: Boolean;\r\n property Form: TForm read FForm;\r\n property Color: TColor read GetColor;\r\n published\r\n property FullColor: TJvFullColor read GetFullColor write SetFullColor default fclRGBBlack;\r\n property Options: TJvFullColorDialogOptions read FOptions write SetOptions default JvDefaultFullColorDialogOptions;\r\n property Title: string read FTitle write SetTitle;\r\n property HelpContext: THelpContext read FHelpContext write SetHelpContext default 0;\r\n property OnApply: TJvFullColorEvent read FOnApply write FOnApply;\r\n property OnShow: TNotifyEvent read FOnShow write FOnShow;\r\n property OnCloseQuery: TCloseQueryEvent read FOnCloseQuery write FOnCloseQuery;\r\n end;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvFullColorCircleDialog = class(TComponent)\r\n private\r\n FTitle: string;\r\n FForm: TForm;\r\n FHelpContext: THelpContext;\r\n FOnCloseQuery: TCloseQueryEvent;\r\n FOnShow: TNotifyEvent;\r\n FOptions: TJvFullColorCircleDialogOptions;\r\n FOnApply: TJvColorCircleEvent;\r\n FDelta: TJvColorDelta;\r\n procedure SetHelpContext(const Value: THelpContext);\r\n procedure SetOptions(const Value: TJvFullColorCircleDialogOptions);\r\n procedure SetTitle(const Value: string);\r\n procedure SetColorID(const Value: TJvFullColorSpaceID);\r\n procedure SetBlueDelta(const Value: TJvAxisDelta);\r\n procedure SetGreenDelta(const Value: TJvAxisDelta);\r\n procedure SetRedDelta(const Value: TJvAxisDelta);\r\n function GetRedDelta: TJvAxisDelta;\r\n function GetGreenDelta: TJvAxisDelta;\r\n function GetBlueDelta: TJvAxisDelta;\r\n function GetColorID: TJvFullColorSpaceID;\r\n protected\r\n procedure FormApply(Sender: TObject);\r\n procedure FormShow(Sender: TObject);\r\n procedure FormClose(Sender: TObject; var Action: TCloseAction);\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n\r\n function Execute: Boolean;\r\n property Form: TForm read FForm;\r\n property RedDelta: TJvAxisDelta read GetRedDelta write SetRedDelta;\r\n property GreenDelta: TJvAxisDelta read GetGreenDelta write SetGreenDelta;\r\n property BlueDelta: TJvAxisDelta read GetBlueDelta write SetBlueDelta;\r\n property ColorID: TJvFullColorSpaceID read GetColorID write SetColorID;\r\n property Delta: TJvColorDelta read FDelta;\r\n published\r\n // (rom) set default values\r\n property Options: TJvFullColorCircleDialogOptions\r\n read FOptions write SetOptions default JvDefaultColorCircleDialogOptions;\r\n property Title: string read FTitle write SetTitle;\r\n property HelpContext: THelpContext read FHelpContext write SetHelpContext;\r\n property OnApply: TJvColorCircleEvent read FOnApply write FOnApply;\r\n property OnShow: TNotifyEvent read FOnShow write FOnShow;\r\n property OnCloseQuery: TCloseQueryEvent read FOnCloseQuery write FOnCloseQuery;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvFullColorDialogs.pas $';\r\n Revision: '$Revision: 13104 $';\r\n Date: '$Date: 2011-09-07 08:50:43 +0200 (mer. 07 sept. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n JvResources,\r\n Controls, SysUtils, JvFullColorForm, JvFullColorCircleForm;\r\n\r\n//=== { TJvFullColorDialog } =================================================\r\n\r\nconstructor TJvFullColorDialog.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FOptions := JvDefaultFullColorDialogOptions;\r\n FFullColor := fclRGBBlack;\r\nend;\r\n\r\nfunction TJvFullColorDialog.Execute: Boolean;\r\nvar\r\n NewColor: TJvFullColor;\r\nbegin\r\n FOldColorSpace := ColorSpaceManager.GetColorSpaceID(FullColor);\r\n\r\n FForm := TJvFullColorFrm.Create(Application, FFullColor, FOptions);\r\n with TJvFullColorFrm(Form) do\r\n begin\r\n if Title <> '' then\r\n Caption := FTitle;\r\n OnApply := FormApply;\r\n OnClose := FormClose;\r\n OnShow := FormShow;\r\n HelpContext := Self.HelpContext;\r\n\r\n Result := (ShowModal = mrOk);\r\n\r\n NewColor := FullColor;\r\n end;\r\n FreeAndNil(FForm);\r\n\r\n with ColorSpaceManager do\r\n if foConvertToOriginalSpace in Options then\r\n NewColor := ConvertToID(NewColor, OldColorSpace);\r\n FFullColor := NewColor;\r\nend;\r\n\r\nprocedure TJvFullColorDialog.FormApply(Sender: TObject);\r\nvar\r\n Color: TJvFullColor;\r\nbegin\r\n if Assigned(FForm) then\r\n begin\r\n Color := TJvFullColorFrm(Form).FullColor;\r\n if foConvertToOriginalSpace in Options then\r\n Color := ColorSpaceManager.ConvertToID(Color, OldColorSpace);\r\n if Assigned(FOnApply) then\r\n FOnApply(Self, Color);\r\n end;\r\nend;\r\n\r\nprocedure TJvFullColorDialog.FormClose(Sender: TObject; var Action: TCloseAction);\r\nvar\r\n Allow: Boolean;\r\nbegin\r\n Allow := True;\r\n\r\n if Assigned(FOnCloseQuery) then\r\n FOnCloseQuery(Self, Allow);\r\n\r\n if Allow then\r\n Action := caFree\r\n else\r\n Action := caNone;\r\nend;\r\n\r\nprocedure TJvFullColorDialog.FormShow(Sender: TObject);\r\nbegin\r\n if Assigned(FOnShow) then\r\n FOnShow(Self);\r\nend;\r\n\r\nfunction TJvFullColorDialog.GetColor: TColor;\r\nbegin\r\n Result := ColorSpaceManager.ConvertToColor(FullColor);\r\nend;\r\n\r\nfunction TJvFullColorDialog.GetFullColor: TJvFullColor;\r\nbegin\r\n if Form <> nil then\r\n FFullColor := TJvFullColorFrm(Form).FullColor;\r\n Result := FFullColor;\r\nend;\r\n\r\nprocedure TJvFullColorDialog.SetFullColor(const Value: TJvFullColor);\r\nbegin\r\n FFullColor := Value;\r\n if Form <> nil then\r\n TJvFullColorFrm(Form).FullColor := Value;\r\nend;\r\n\r\nprocedure TJvFullColorDialog.SetHelpContext(const Value: THelpContext);\r\nbegin\r\n if FHelpContext <> Value then\r\n begin\r\n FHelpContext := Value;\r\n if Assigned(FForm) then\r\n Form.HelpContext := Value;\r\n end;\r\nend;\r\n\r\nprocedure TJvFullColorDialog.SetOptions(const Value: TJvFullColorDialogOptions);\r\nbegin\r\n if FOptions <> Value then\r\n begin\r\n FOptions := Value;\r\n if Assigned(FForm) then\r\n TJvFullColorFrm(Form).Options := Value;\r\n end;\r\nend;\r\n\r\nprocedure TJvFullColorDialog.SetTitle(const Value: string);\r\nbegin\r\n if FTitle <> Value then\r\n begin\r\n FTitle := Value;\r\n if Assigned(FForm) then\r\n Form.Caption := Value;\r\n end;\r\nend;\r\n\r\n//=== { TJvColorCircleDialog } ===============================================\r\n\r\nconstructor TJvFullColorCircleDialog.Create(AOwner: TComponent);\r\n procedure InitAxe (Value: TJvAxisDelta);\r\n var\r\n Index: TJvAxisIndex;\r\n begin\r\n for Index := Low(TJvAxisIndex) to High(TJvAxisIndex) do\r\n begin\r\n Value[Index].Value := 0;\r\n Value[Index].SaturationMethod := smLoop;\r\n end;\r\n end;\r\nbegin\r\n inherited Create(AOwner);\r\n FOptions := JvDefaultColorCircleDialogOptions;\r\n FDelta := TJvColorDelta.Create;\r\n\r\n InitAxe(FDelta.AxisRed);\r\n InitAxe(FDelta.AxisGreen);\r\n InitAxe(FDelta.AxisBlue);\r\n FDelta.ColorID := csRGB;\r\nend;\r\n\r\ndestructor TJvFullColorCircleDialog.Destroy;\r\nbegin\r\n FDelta.Free;\r\n\r\n inherited;\r\nend;\r\n\r\nfunction TJvFullColorCircleDialog.Execute: Boolean;\r\nbegin\r\n FForm := TJvFullColorCircleFrm.Create(Application);\r\n with TJvFullColorCircleFrm(Form) do\r\n begin\r\n if Title <> '' then\r\n Caption := Title;\r\n Options := Self.Options;\r\n Delta := Self.Delta;\r\n OnApply := FormApply;\r\n OnClose := FormClose;\r\n OnShow := FormShow;\r\n HelpContext := Self.HelpContext;\r\n\r\n Result := (ShowModal = mrOk);\r\n\r\n Self.FDelta.AxisRed.Assign(RedDelta);\r\n Self.FDelta.AxisGreen.Assign(GreenDelta);\r\n Self.FDelta.AxisBlue.Assign(BlueDelta);\r\n Self.FDelta.ColorID := ColorID;\r\n end;\r\n FreeAndNil(FForm);\r\nend;\r\n\r\nprocedure TJvFullColorCircleDialog.FormApply(Sender: TObject);\r\nbegin\r\n if FForm<>nil then\r\n begin\r\n FDelta.ColorID := TJvFullColorCircleFrm(FForm).ColorID;\r\n FDelta.AxisRed := TJvFullColorCircleFrm(FForm).RedDelta;\r\n FDelta.AxisGreen := TJvFullColorCircleFrm(FForm).GreenDelta;\r\n FDelta.AxisBlue := TJvFullColorCircleFrm(FForm).BlueDelta;\r\n if Assigned(FOnApply) then\r\n FOnApply(Self);\r\n end;\r\nend;\r\n\r\nprocedure TJvFullColorCircleDialog.FormClose(Sender: TObject; var Action: TCloseAction);\r\nvar\r\n Allow: Boolean;\r\nbegin\r\n if FForm<>nil then\r\n begin\r\n FDelta.ColorID := TJvFullColorCircleFrm(FForm).ColorID;\r\n FDelta.AxisRed := TJvFullColorCircleFrm(FForm).RedDelta;\r\n FDelta.AxisGreen := TJvFullColorCircleFrm(FForm).GreenDelta;\r\n FDelta.AxisBlue := TJvFullColorCircleFrm(FForm).BlueDelta;\r\n Allow := True;\r\n if Assigned(FOnCloseQuery) then\r\n FOnCloseQuery(Self, Allow);\r\n if Allow then\r\n Action := caFree\r\n else\r\n Action := caNone;\r\n end;\r\nend;\r\n\r\nprocedure TJvFullColorCircleDialog.FormShow(Sender: TObject);\r\nbegin\r\n if FForm<>nil then\r\n begin\r\n FDelta.ColorID := TJvFullColorCircleFrm(FForm).ColorID;\r\n FDelta.AxisRed := TJvFullColorCircleFrm(FForm).RedDelta;\r\n FDelta.AxisGreen := TJvFullColorCircleFrm(FForm).GreenDelta;\r\n FDelta.AxisBlue := TJvFullColorCircleFrm(FForm).BlueDelta;\r\n if Assigned(FOnShow) then\r\n FOnShow(Self);\r\n end;\r\nend;\r\n\r\nfunction TJvFullColorCircleDialog.GetBlueDelta: TJvAxisDelta;\r\nbegin\r\n Result := FDelta.AxisBlue;\r\nend;\r\n\r\nfunction TJvFullColorCircleDialog.GetColorID: TJvFullColorSpaceID;\r\nbegin\r\n Result := FDelta.ColorID;\r\nend;\r\n\r\nfunction TJvFullColorCircleDialog.GetGreenDelta: TJvAxisDelta;\r\nbegin\r\n Result := FDelta.AxisGreen;\r\nend;\r\n\r\nfunction TJvFullColorCircleDialog.GetRedDelta: TJvAxisDelta;\r\nbegin\r\n Result := FDelta.AxisRed;\r\nend;\r\n\r\nprocedure TJvFullColorCircleDialog.SetBlueDelta(const Value: TJvAxisDelta);\r\nbegin\r\n FDelta.AxisBlue.Assign(Value);\r\n if FForm <> nil then\r\n TJvFullColorCircleFrm(FForm).BlueDelta := Value;\r\nend;\r\n\r\nprocedure TJvFullColorCircleDialog.SetColorID(\r\n const Value: TJvFullColorSpaceID);\r\nbegin\r\n FDelta.ColorID := Value;\r\n if FForm <> nil then\r\n TJvFullColorCircleFrm(FForm).ColorID :=Value;\r\nend;\r\n\r\nprocedure TJvFullColorCircleDialog.SetGreenDelta(\r\n const Value: TJvAxisDelta);\r\nbegin\r\n FDelta.AxisGreen.Assign(Value);\r\n if FForm <> nil then\r\n TJvFullColorCircleFrm(FForm).GreenDelta := Value;\r\nend;\r\n\r\nprocedure TJvFullColorCircleDialog.SetHelpContext(const Value: THelpContext);\r\nbegin\r\n FHelpContext := Value;\r\n if FForm <> nil then\r\n FForm.HelpContext := Value;\r\nend;\r\n\r\nprocedure TJvFullColorCircleDialog.SetOptions(const Value: TJvFullColorCircleDialogOptions);\r\nbegin\r\n FOptions := Value;\r\n if FForm <> nil then\r\n TJvFullColorCircleFrm(FForm).Options := Value;\r\nend;\r\n\r\nprocedure TJvFullColorCircleDialog.SetRedDelta(const Value: TJvAxisDelta);\r\nbegin\r\n FDelta.AxisRed.Assign(Value);\r\n if FForm <> nil then\r\n TJvFullColorCircleFrm(FForm).RedDelta := Value;\r\nend;\r\n\r\nprocedure TJvFullColorCircleDialog.SetTitle(const Value: string);\r\nbegin\r\n FTitle := Value;\r\n if FForm <> nil then\r\n FForm.Caption := Value;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvFullColorForm.dfm", "content": "object JvFullColorFrm: TJvFullColorFrm\r\n Left = 350\r\n Top = 319\r\n ActiveControl = ColorBox\r\n BorderIcons = [biSystemMenu]\r\n BorderStyle = bsDialog\r\n Caption = 'Color Spaces Editor, Choose your color'\r\n ClientHeight = 380\r\n ClientWidth = 712\r\n Color = clBtnFace\r\n Font.Charset = DEFAULT_CHARSET\r\n Font.Color = clWindowText\r\n Font.Height = -11\r\n Font.Name = 'MS Sans Serif'\r\n Font.Style = []\r\n KeyPreview = True\r\n OldCreateOrder = False\r\n Position = poScreenCenter\r\n OnCreate = FormCreate\r\n PixelsPerInch = 96\r\n TextHeight = 13\r\n object LabelColorSpace: TLabel\r\n Left = 8\r\n Top = 10\r\n Width = 101\r\n Height = 13\r\n Caption = '&Current Color Space :'\r\n end\r\n object LabelDrawOld: TLabel\r\n Left = 240\r\n Top = 32\r\n Width = 81\r\n Height = 41\r\n AutoSize = False\r\n Color = clBlack\r\n ParentColor = False\r\n Transparent = False\r\n OnClick = LabelDrawOldClick\r\n end\r\n object LabelDrawNew: TLabel\r\n Left = 320\r\n Top = 32\r\n Width = 81\r\n Height = 41\r\n AutoSize = False\r\n Color = clWhite\r\n ParentColor = False\r\n Transparent = False\r\n end\r\n object LabelOld: TLabel\r\n Left = 240\r\n Top = 10\r\n Width = 19\r\n Height = 13\r\n Caption = 'Old:'\r\n end\r\n object LabelNew: TLabel\r\n Left = 320\r\n Top = 10\r\n Width = 25\r\n Height = 13\r\n Caption = 'New:'\r\n end\r\n object GroupBoxSettings: TGroupBox\r\n Left = 8\r\n Top = 80\r\n Width = 393\r\n Height = 249\r\n Caption = ' Settings ... '\r\n TabOrder = 1\r\n object LabelAxis0: TLabel\r\n Left = 8\r\n Top = 24\r\n Width = 51\r\n Height = 13\r\n Alignment = taRightJustify\r\n Caption = 'LabelAxis0'\r\n end\r\n object LabelAxis1: TLabel\r\n Left = 8\r\n Top = 80\r\n Width = 51\r\n Height = 13\r\n Alignment = taRightJustify\r\n Caption = 'LabelAxis1'\r\n end\r\n object LabelAxis2: TLabel\r\n Left = 8\r\n Top = 136\r\n Width = 51\r\n Height = 13\r\n Alignment = taRightJustify\r\n Caption = 'LabelAxis2'\r\n end\r\n object LabelPredefined: TLabel\r\n Left = 88\r\n Top = 184\r\n Width = 85\r\n Height = 13\r\n Alignment = taRightJustify\r\n Caption = '&Predefined colors:'\r\n FocusControl = ColorBox\r\n end\r\n object ScrollBarAxis0: TScrollBar\r\n Left = 8\r\n Top = 41\r\n Width = 281\r\n Height = 20\r\n LargeChange = 16\r\n Max = 255\r\n \r\n TabOrder = 0\r\n OnChange = ScrollBarChange\r\n end\r\n object ScrollBarAxis1: TScrollBar\r\n Tag = 1\r\n Left = 8\r\n Top = 98\r\n Width = 281\r\n Height = 20\r\n LargeChange = 16\r\n Max = 255\r\n \r\n TabOrder = 2\r\n OnChange = ScrollBarChange\r\n end\r\n object ScrollBarAxis2: TScrollBar\r\n Tag = 2\r\n Left = 8\r\n Top = 154\r\n Width = 281\r\n Height = 20\r\n LargeChange = 16\r\n Max = 255\r\n \r\n TabOrder = 4\r\n OnChange = ScrollBarChange\r\n end\r\n object SpinEditAxis0: TJvSpinEdit\r\n Left = 312\r\n Top = 40\r\n Width = 65\r\n Height = 22\r\n MaxValue = 255.000000000000000000\r\n TabOrder = 1\r\n OnChange = SpinEditChange\r\n end\r\n object SpinEditAxis1: TJvSpinEdit\r\n Tag = 1\r\n Left = 312\r\n Top = 96\r\n Width = 65\r\n Height = 22\r\n MaxValue = 255.000000000000000000\r\n TabOrder = 3\r\n OnChange = SpinEditChange\r\n end\r\n object SpinEditAxis2: TJvSpinEdit\r\n Tag = 2\r\n Left = 312\r\n Top = 152\r\n Width = 65\r\n Height = 22\r\n MaxValue = 255.000000000000000000\r\n TabOrder = 5\r\n OnChange = SpinEditChange\r\n end\r\n object ColorBox: TJvColorComboBox\r\n Left = 88\r\n Top = 200\r\n Width = 201\r\n Height = 22\r\n ColorDialogText = 'Custom...'\r\n DroppedDownWidth = 201\r\n NewColorText = 'Custom'\r\n Options = [coText, coSysColors]\r\n TabOrder = 6\r\n OnClick = ComboBoxPredefinedSelect\r\n end\r\n end\r\n object JvFullColorGroup: TJvFullColorGroup\r\n Left = 416\r\n Top = 8\r\n Width = 289\r\n Height = 361\r\n ColCount = 8\r\n SquareSize = 30\r\n OnChange = JvFullColorGroupChange\r\n ParentShowHint = False\r\n ShowHint = True\r\n end\r\n object PanelGraphic: TPanel\r\n Left = 416\r\n Top = 8\r\n Width = 289\r\n Height = 361\r\n BevelInner = bvRaised\r\n BevelOuter = bvLowered\r\n ParentColor = True\r\n TabOrder = 2\r\n Visible = False\r\n object LabelAxis: TLabel\r\n Left = 20\r\n Top = 20\r\n Width = 22\r\n Height = 13\r\n Caption = '&Axis:'\r\n end\r\n object JvColorPanel: TJvFullColorPanel\r\n Left = 8\r\n Top = 40\r\n Width = 276\r\n Height = 276\r\n FullColor = 83886079\r\n TabOrder = 1\r\n OnColorChange = JvColorPanelColorChange\r\n CrossSize = 10\r\n CrossCenter = 3\r\n CrossStyle.Width = 3\r\n ColorTrackBar = JvFullColorTrackBar\r\n end\r\n object JvFullColorTrackBar: TJvFullColorTrackBar\r\n Left = 8\r\n Top = 320\r\n Width = 276\r\n Height = 21\r\n FullColor = 83886079\r\n TabOrder = 2\r\n ArrowWidth = 10\r\n end\r\n object JvColorAxisConfigCombo: TJvFullColorAxisCombo\r\n Left = 48\r\n Top = 16\r\n Width = 225\r\n Height = 21\r\n Selected = acXYZ\r\n ItemHeight = 13\r\n TabOrder = 0\r\n OnChange = ComboBoxAxisChange\r\n end\r\n end\r\n object ButtonGraphics: TButton\r\n Left = 326\r\n Top = 344\r\n Width = 75\r\n Height = 25\r\n TabOrder = 6\r\n OnClick = ButtonGraphicsClick\r\n end\r\n object ButtonOK: TButton\r\n Left = 8\r\n Top = 344\r\n Width = 75\r\n Height = 25\r\n Caption = '&OK'\r\n Default = True\r\n ModalResult = 1\r\n TabOrder = 3\r\n end\r\n object ButtonCancel: TButton\r\n Left = 114\r\n Top = 344\r\n Width = 75\r\n Height = 25\r\n Cancel = True\r\n Caption = 'Ca&ncel'\r\n ModalResult = 2\r\n TabOrder = 4\r\n end\r\n object ButtonApply: TButton\r\n Left = 220\r\n Top = 344\r\n Width = 75\r\n Height = 25\r\n Caption = '&Apply'\r\n TabOrder = 5\r\n OnClick = ButtonApplyClick\r\n end\r\n object JvColorSpaceCombo: TJvFullColorSpaceCombo\r\n Left = 8\r\n Top = 32\r\n Width = 209\r\n Height = 21\r\n ItemHeight = 13\r\n TabOrder = 0\r\n OnClick = JvComboBoxColorSpaceSelect\r\n end\r\nend\r\n" }, { "path": "External/Jedi/Jvcl/run/JvFullColorForm.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: FullColorFrm.pas, released on 2004-09-11.\r\n\r\nThe Initial Developer of the Original Code is Florent Ouchet [ouchet dott florent att laposte dott net]\r\nPortions created by Florent Ouchet are Copyright (C) 2004 Florent Ouchet.\r\nAll Rights Reserved.\r\n\r\nContributor(s): -\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvFullColorForm.pas 12461 2009-08-14 17:21:33Z obones $\r\n\r\nunit JvFullColorForm;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, Messages, SysUtils, Classes, Controls, Forms, Graphics,\r\n Dialogs, StdCtrls, ExtCtrls, Mask,\r\n JvFullColorCtrls, JvFullColorSpaces, JvFullColorDialogs, JvExMask,\r\n JvSpin, JvExStdCtrls, JvCombobox, JvColorCombo, JvComponent;\r\n\r\ntype\r\n TJvFullColorFrm = class(TJvForm)\r\n LabelColorSpace: TLabel;\r\n GroupBoxSettings: TGroupBox;\r\n ScrollBarAxis0: TScrollBar;\r\n ScrollBarAxis1: TScrollBar;\r\n ScrollBarAxis2: TScrollBar;\r\n SpinEditAxis0: TJvSpinEdit;\r\n SpinEditAxis1: TJvSpinEdit;\r\n SpinEditAxis2: TJvSpinEdit;\r\n LabelAxis0: TLabel;\r\n LabelAxis1: TLabel;\r\n LabelAxis2: TLabel;\r\n LabelPredefined: TLabel;\r\n PanelGraphic: TPanel;\r\n JvColorPanel: TJvFullColorPanel;\r\n JvFullColorTrackBar: TJvFullColorTrackBar;\r\n ButtonGraphics: TButton;\r\n ButtonOK: TButton;\r\n ButtonCancel: TButton;\r\n LabelDrawOld: TLabel;\r\n LabelDrawNew: TLabel;\r\n LabelOld: TLabel;\r\n LabelNew: TLabel;\r\n LabelAxis: TLabel;\r\n ButtonApply: TButton;\r\n JvColorAxisConfigCombo: TJvFullColorAxisCombo;\r\n JvColorSpaceCombo: TJvFullColorSpaceCombo;\r\n ColorBox: TJvColorComboBox;\r\n JvFullColorGroup: TJvFullColorGroup;\r\n procedure ButtonGraphicsClick(Sender: TObject);\r\n procedure FormCreate(Sender: TObject);\r\n procedure JvComboBoxColorSpaceSelect(Sender: TObject);\r\n procedure SpinEditChange(Sender: TObject);\r\n procedure ScrollBarChange(Sender: TObject);\r\n procedure JvColorPanelColorChange(Sender: TObject);\r\n procedure ComboBoxAxisChange(Sender: TObject);\r\n procedure ComboBoxPredefinedSelect(Sender: TObject);\r\n procedure ButtonApplyClick(Sender: TObject);\r\n procedure LabelDrawOldClick(Sender: TObject);\r\n procedure JvFullColorGroupChange(Sender: TObject);\r\n private\r\n FUpdating: Boolean;\r\n FExpanded: Boolean;\r\n FExpandedWidth: Integer;\r\n FFullColor: TJvFullColor;\r\n FOptions: TJvFullColorDialogOptions;\r\n FOnApply: TNotifyEvent;\r\n FScrollBarAxes: array [TJvAxisIndex] of TScrollBar;\r\n FSpinEditAxes: array [TJvAxisIndex] of TJvSpinEdit;\r\n FLabelAxes: array [TJvAxisIndex] of TLabel;\r\n FFilled: Boolean;\r\n procedure FillInternalArrays;\r\n protected\r\n procedure UpdateColorValue;\r\n procedure UpdateColorSpace;\r\n procedure SetFullColor(const Value: TJvFullColor);\r\n procedure SetOptions(const Value: TJvFullColorDialogOptions);\r\n procedure Loaded; override;\r\n property Expanded: Boolean read FExpanded;\r\n public\r\n constructor Create(AOwner: TComponent; AFullColor: TJvFullColor;\r\n AOptions: TJvFullColorDialogOptions); reintroduce;\r\n procedure Expand;\r\n procedure Collapse;\r\n property Options: TJvFullColorDialogOptions read FOptions write SetOptions;\r\n property FullColor: TJvFullColor read FFullColor write SetFullColor;\r\n property OnApply: TNotifyEvent read FOnApply write FOnApply;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvFullColorForm.pas $';\r\n Revision: '$Revision: 12461 $';\r\n Date: '$Date: 2009-08-14 19:21:33 +0200 (ven. 14 août 2009) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n JvJCLUtils, // for TryStrToInt\r\n JvResources;\r\n\r\n{$R *.dfm}\r\n\r\nfunction AxisIndexFromTag(ATag: Integer): TJvAxisIndex;\r\nbegin\r\n Result := TJvAxisIndex(ATag and $03);\r\nend;\r\n\r\nconstructor TJvFullColorFrm.Create(AOwner: TComponent;\r\n AFullColor: TJvFullColor; AOptions: TJvFullColorDialogOptions);\r\nbegin\r\n inherited Create(AOwner);\r\n FOptions := AOptions;\r\n FFullColor := AFullColor;\r\nend;\r\n\r\nprocedure TJvFullColorFrm.FormCreate(Sender: TObject);\r\nvar\r\n CS: TJvDEFColorSpace;\r\n Index:Integer;\r\nbegin\r\n with ColorSpaceManager do\r\n begin\r\n CS := TJvDEFColorSpace(ColorSpace[csDEF]);\r\n for Index := 0 to CS.ColorCount - 1 do\r\n JvFullColorGroup.Items.Add(CS.ConvertFromColor(CS.ColorValue[Index]));\r\n LabelDrawOld.Color := ConvertToColor(FullColor);\r\n JvColorSpaceCombo.ColorSpaceID := GetColorSpaceID(FullColor);\r\n end;\r\n SetFullColor(FullColor);\r\n SetOptions(Options);\r\nend;\r\n\r\nprocedure TJvFullColorFrm.Loaded;\r\nbegin\r\n inherited Loaded;\r\n FExpandedWidth := Width;\r\nend;\r\n\r\nprocedure TJvFullColorFrm.FillInternalArrays;\r\nbegin\r\n if not FFilled then\r\n begin\r\n FScrollBarAxes[axIndex0] := ScrollBarAxis0;\r\n FScrollBarAxes[axIndex1] := ScrollBarAxis1;\r\n FScrollBarAxes[axIndex2] := ScrollBarAxis2;\r\n FSpinEditAxes[axIndex0] := SpinEditAxis0;\r\n FSpinEditAxes[axIndex1] := SpinEditAxis1;\r\n FSpinEditAxes[axIndex2] := SpinEditAxis2;\r\n FLabelAxes[axIndex0] := LabelAxis0;\r\n FLabelAxes[axIndex1] := LabelAxis1;\r\n FLabelAxes[axIndex2] := LabelAxis2;\r\n FFilled := True;\r\n end;\r\nend;\r\n\r\nprocedure TJvFullColorFrm.ButtonGraphicsClick(Sender: TObject);\r\nbegin\r\n if Expanded then\r\n Collapse\r\n else\r\n Expand;\r\nend;\r\n\r\nprocedure TJvFullColorFrm.Expand;\r\nbegin\r\n PanelGraphic.Visible := True;\r\n Width := FExpandedWidth;\r\n ButtonGraphics.Caption := RsExpandedCaption;\r\n FExpanded := True;\r\nend;\r\n\r\nprocedure TJvFullColorFrm.Collapse;\r\nbegin\r\n Width := PanelGraphic.Left - 1;\r\n PanelGraphic.Visible := False;\r\n ButtonGraphics.Caption := RsCollapsedCaption;\r\n FExpanded := False;\r\nend;\r\n\r\nprocedure TJvFullColorFrm.SpinEditChange(Sender: TObject);\r\nvar\r\n IntValue:Integer;\r\nbegin\r\n if FUpdating then\r\n Exit;\r\n FUpdating := True;\r\n\r\n with Sender as TJvSpinEdit do\r\n if TryStrToInt(Text,IntValue) then\r\n FullColor := SetAxisValue(FullColor, AxisIndexFromTag(Tag), IntValue);\r\n\r\n FUpdating := False;\r\n UpdateColorValue;\r\nend;\r\n\r\nprocedure TJvFullColorFrm.ScrollBarChange(Sender: TObject);\r\nbegin\r\n if FUpdating then\r\n Exit;\r\n FUpdating := True;\r\n with Sender as TScrollBar do\r\n FullColor := SetAxisValue(FullColor, AxisIndexFromTag(Tag), Position);\r\n FUpdating := False;\r\n UpdateColorValue;\r\nend;\r\n\r\nprocedure TJvFullColorFrm.JvColorPanelColorChange(Sender: TObject);\r\nbegin\r\n if FUpdating then\r\n Exit;\r\n FUpdating := True;\r\n FullColor := (Sender as TJvFullColorPanel).FullColor;\r\n FUpdating := False;\r\n UpdateColorValue;\r\nend;\r\n\r\nprocedure TJvFullColorFrm.JvFullColorGroupChange(Sender: TObject);\r\nbegin\r\n if FUpdating then\r\n Exit;\r\n\r\n FUpdating := True;\r\n with (Sender as TJvFullColorGroup), ColorSpaceManager do\r\n if (SelectedIndex>-1) then\r\n begin\r\n JvColorSpaceCombo.ColorSpaceID := GetColorSpaceID(Selected);\r\n FullColor := Selected;\r\n end;\r\n FUpdating := False;\r\n\r\n UpdateColorSpace;\r\nend;\r\n\r\nprocedure TJvFullColorFrm.JvComboBoxColorSpaceSelect(Sender: TObject);\r\nbegin\r\n if FUpdating then\r\n Exit;\r\n FUpdating := True;\r\n with Sender as TJvFullColorSpaceCombo do\r\n FullColor := ColorSpaceManager.ConvertToID(FullColor, ColorSpaceID);\r\n FUpdating := False;\r\n UpdateColorSpace;\r\nend;\r\n\r\nprocedure TJvFullColorFrm.ComboBoxPredefinedSelect(Sender: TObject);\r\nbegin\r\n if FUpdating then\r\n Exit;\r\n FUpdating := True;\r\n with Sender as TJvColorComboBox, ColorSpaceManager do\r\n FullColor := ConvertToID(ConvertFromColor(Colors[ItemIndex]),\r\n GetColorSpaceID(FullColor));\r\n FUpdating := False;\r\n UpdateColorSpace;\r\nend;\r\n\r\nprocedure TJvFullColorFrm.ComboBoxAxisChange(Sender: TObject);\r\nbegin\r\n JvColorPanel.AxisConfig := (Sender as TJvFullColorAxisCombo).Selected;\r\nend;\r\n\r\nprocedure TJvFullColorFrm.UpdateColorValue;\r\nvar\r\n I: TJvAxisIndex;\r\n C: TColor;\r\n NewIndex: Integer;\r\n ValueAxes: array [TJvAxisIndex] of Byte;\r\n J: Integer;\r\n LColorID: TJvFullColorSpaceID;\r\n DefColorSpace: TJvColorSpace;\r\nbegin\r\n if FUpdating then\r\n Exit;\r\n FillInternalArrays;\r\n\r\n FUpdating := True;\r\n\r\n LabelDrawNew.Color := ColorSpaceManager.ConvertToColor(FullColor);\r\n LabelDrawNew.Update;\r\n\r\n LColorID := ColorSpaceManager.GetColorSpaceID(FullColor);\r\n\r\n if (LColorID=csDEF) then\r\n begin\r\n JvFullColorGroup.Selected := FullColor;\r\n\r\n for I := Low(TJvAxisIndex) to High(TJvAxisIndex) do\r\n begin\r\n FScrollBarAxes[I].Enabled := False;\r\n FScrollBarAxes[I].Position := 0;\r\n FSpinEditAxes[I].Enabled := False;\r\n FSpinEditAxes[I].Value := 0;\r\n end;\r\n end\r\n else\r\n begin\r\n JvColorPanel.FullColor := FullColor;\r\n\r\n for I := Low(TJvAxisIndex) to High(TJvAxisIndex) do\r\n begin\r\n FScrollBarAxes[I].Enabled := True;\r\n FSpinEditAxes[I].Enabled := True;\r\n ValueAxes[I] := GetAxisValue(FullColor, I);\r\n FScrollBarAxes[I].Position := ValueAxes[I];\r\n FSpinEditAxes[I].Value := ValueAxes[I];\r\n end;\r\n end;\r\n\r\n JvColorSpaceCombo.ColorSpaceID := LColorID;\r\n\r\n NewIndex := -1;\r\n DefColorSpace := ColorSpaceManager.ColorSpace[csDEF];\r\n with ColorBox, Items, ColorSpaceManager do\r\n begin\r\n for J := 0 to Items.Count - 1 do\r\n begin\r\n C := DefColorSpace.ConvertFromColor(Colors[J]);\r\n if ConvertToID(C, LColorID) = FullColor then\r\n begin\r\n NewIndex := J;\r\n Break;\r\n end;\r\n end;\r\n ItemIndex := NewIndex;\r\n end;\r\n\r\n FUpdating := False;\r\nend;\r\n\r\nprocedure TJvFullColorFrm.UpdateColorSpace;\r\nvar\r\n I: TJvAxisIndex;\r\n AxisMin, AxisMax: Byte;\r\n LColorSpace: TJvColorSpace;\r\nbegin\r\n if FUpdating then\r\n Exit;\r\n FillInternalArrays;\r\n\r\n FUpdating := True;\r\n\r\n LColorSpace := JvColorSpaceCombo.SelectedSpace;\r\n\r\n if Assigned(LColorSpace) then\r\n begin\r\n if (LColorSpace.ID = csDEF) then\r\n begin\r\n PanelGraphic.Visible := False;\r\n JvFullColorGroup.Visible := Expanded;\r\n\r\n for I := Low(TJvAxisIndex) to High(TJvAxisIndex) do\r\n begin\r\n FScrollBarAxes[I].Enabled := False;\r\n FScrollBarAxes[I].Position := 0;\r\n FSpinEditAxes[I].Enabled := False;\r\n FSpinEditAxes[I].Value := 0;\r\n end;\r\n end\r\n else\r\n begin\r\n PanelGraphic.Visible := Expanded;\r\n JvFullColorGroup.Visible := False;\r\n\r\n JvColorAxisConfigCombo.ColorID := LColorSpace.ID;\r\n for I := Low(TJvAxisIndex) to High(TJvAxisIndex) do\r\n begin\r\n FLabelAxes[I].Caption := LColorSpace.AxisName[I];\r\n AxisMin := LColorSpace.AxisMin[I];\r\n AxisMax := LColorSpace.AxisMax[I];\r\n FScrollBarAxes[I].Min := AxisMin;\r\n FScrollBarAxes[I].Max := AxisMax;\r\n FSpinEditAxes[I].MinValue := AxisMin;\r\n FSpinEditAxes[I].MaxValue := AxisMax;\r\n end;\r\n\r\n JvColorPanel.FullColor := FullColor;\r\n JvFullColorTrackBar.FullColor := FullColor;\r\n end;\r\n end;\r\n\r\n FUpdating := False;\r\n\r\n UpdateColorValue;\r\nend;\r\n\r\nprocedure TJvFullColorFrm.ButtonApplyClick(Sender: TObject);\r\nbegin\r\n if Assigned(OnApply) then\r\n OnApply(Sender);\r\nend;\r\n\r\nprocedure TJvFullColorFrm.SetFullColor(const Value: TJvFullColor);\r\nbegin\r\n FFullColor := Value;\r\n if not FUpdating then\r\n begin\r\n with ColorSpaceManager do\r\n JvColorSpaceCombo.ColorSpaceID := GetColorSpaceID(Value);\r\n UpdateColorSpace;\r\n end;\r\nend;\r\n\r\nprocedure TJvFullColorFrm.SetOptions(const Value: TJvFullColorDialogOptions);\r\nvar\r\n LVisible: Boolean;\r\n LColor: TColor;\r\nbegin\r\n FOptions := Value;\r\n\r\n if foFullOpen in Options then\r\n Expand\r\n else\r\n Collapse;\r\n\r\n ButtonGraphics.Enabled := not (foPreventExpand in Options);\r\n\r\n ButtonApply.Visible := (foShowApply in Options);\r\n\r\n if foShowHelp in Options then\r\n BorderIcons := BorderIcons + [biHelp]\r\n else\r\n BorderIcons := BorderIcons - [biHelp];\r\n\r\n JvColorSpaceCombo.Enabled := foAllowSpaceChange in Options;\r\n\r\n LVisible := foShowOldPreview in Options;\r\n LabelDrawOld.Visible := LVisible;\r\n LabelOld.Visible := LVisible;\r\n\r\n LVisible := foShowNewPreview in Options;\r\n LabelDrawNew.Visible := LVisible;\r\n LabelNew.Visible := LVisible;\r\n\r\n LVisible := foShowPredefined in Options;\r\n ColorBox.Visible := LVisible;\r\n LabelPredefined.Visible := LVisible;\r\n\r\n JvColorSpaceCombo.AllowVariable := foAllowVariable in Options;\r\n if foAllowVariable in Options then\r\n ColorBox.Options := ColorBox.Options + [coSysColors]\r\n else\r\n ColorBox.Options := ColorBox.Options - [coSysColors];\r\n{ if foNoneAndDefault in Options then\r\n ColorBox.Style := ColorBox.Style + [cbIncludeNone, cbIncludeDefault]\r\n else\r\n ColorBox.Style := ColorBox.Style - [cbIncludeNone, cbIncludeDefault];}\r\n\r\n UpdateColorSpace;\r\n\r\n LColor := ColorSpaceManager.ConvertToColor(FullColor);\r\n\r\n LabelDrawNew.Color := LColor;\r\n LabelDrawOld.Color := LColor;\r\nend;\r\n\r\nprocedure TJvFullColorFrm.LabelDrawOldClick(Sender: TObject);\r\nbegin\r\n with ColorSpaceManager do\r\n FullColor := ConvertToID(ConvertFromColor(LabelDrawOld.Color),\r\n GetColorSpaceID(FullColor));\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvFullColorRotate.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: ColorRotate.pas, released on 2004-09-11.\r\n\r\nThe Initial Developer of the Original Code is Florent Ouchet [ouchet dott florent att laposte dott net]\r\nPortions created by Florent Ouchet are Copyright (C) 2004 Florent Ouchet.\r\nAll Rights Reserved.\r\n\r\nContributor(s): -\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvFullColorRotate.pas 12461 2009-08-14 17:21:33Z obones $\r\n\r\nunit JvFullColorRotate;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, Classes, Graphics,\r\n JvFullColorSpaces;\r\n\r\ntype\r\n TJvRotateColor = (rcCommon, rcRed, rcGreen, rcBlue);\r\n\r\n TJvSaturationMethod = (smRange, smLoop);\r\n\r\n TJvRotateValueType = -255..255;\r\n\r\n TJvRotateValue = class(TPersistent)\r\n private\r\n FValue: TJvRotateValueType;\r\n FSaturationMethod: TJvSaturationMethod;\r\n public\r\n constructor Create; reintroduce;\r\n property Value: TJvRotateValueType read FValue write FValue default 0;\r\n property SaturationMethod: TJvSaturationMethod read FSaturationMethod write FSaturationMethod default smRange;\r\n\r\n procedure Assign(Value: TJvRotateValue); reintroduce;\r\n end;\r\n\r\n TJvAxisDelta = class(TPersistent)\r\n private\r\n FConstituents: array [TJvAxisIndex] of TJvRotateValue;\r\n function GetConstituents(Index: TJvAxisIndex): TJvRotateValue;\r\n procedure SetConstituents(Index: TJvAxisIndex; const Value: TJvRotateValue);\r\n public\r\n constructor Create;\r\n destructor Destroy; override;\r\n procedure Assign(Value: TJvAxisDelta); reintroduce;\r\n property Constituents[Index: TJvAxisIndex]: TJvRotateValue read GetConstituents write SetConstituents; default;\r\n end;\r\n\r\n TJvColorDelta = class(TPersistent)\r\n private\r\n FColorID: TJvFullColorSpaceID;\r\n FAxisRed: TJvAxisDelta;\r\n FAxisGreen: TJvAxisDelta;\r\n FAxisBlue: TJvAxisDelta;\r\n procedure SetAxisBlue(const Value: TJvAxisDelta);\r\n procedure SetAxisGreen(const Value: TJvAxisDelta);\r\n procedure SetAxisRed(const Value: TJvAxisDelta);\r\n public\r\n constructor Create;\r\n destructor Destroy; override;\r\n procedure Assign(Value: TJvColorDelta); reintroduce;\r\n property ColorID: TJvFullColorSpaceID read FColorID write FColorID default csRGB;\r\n property AxisRed: TJvAxisDelta read FAxisRed write SetAxisRed;\r\n property AxisGreen: TJvAxisDelta read FAxisGreen write SetAxisGreen;\r\n property AxisBlue: TJvAxisDelta read FAxisBlue write SetAxisBlue;\r\n end;\r\n\r\nfunction RotateColor(AColor: TJvFullColor; AColorDelta: TJvColorDelta): TJvFullColor;\r\nprocedure RotateBitmap(SourceBitmap, DestBitmap: TBitmap; AColorDelta: TJvColorDelta);\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvFullColorRotate.pas $';\r\n Revision: '$Revision: 12461 $';\r\n Date: '$Date: 2009-08-14 19:21:33 +0200 (ven. 14 août 2009) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n JvTypes;\r\n\r\nfunction RotateColor(AColor: TJvFullColor; AColorDelta: TJvColorDelta): TJvFullColor;\r\nvar\r\n I: TJvAxisIndex;\r\n MinAxis: array [TJvAxisIndex] of Byte;\r\n MaxAxis: array [TJvAxisIndex] of Byte;\r\n ValueAxis: array [TJvAxisIndex] of SmallInt;\r\n ColorRed, ColorGreen, ColorBlue: TColor;\r\n MaxColorAxis:Integer;\r\n SourceColorSpace, DeltaColorSpace: TJvColorSpace;\r\n LColor: TColor;\r\n\r\n function DoRotate(AValue: TJvFullColor; AAxisDelta: TJvAxisDelta): TColor;\r\n var\r\n I: TJvAxisIndex;\r\n Range: Integer;\r\n begin\r\n for I := Low(TJvAxisIndex) to High(TJvAxisIndex) do\r\n begin\r\n ValueAxis[I] := Integer(GetAxisValue(AValue, I)) + AAxisDelta[I].Value;\r\n if AAxisDelta[I].SaturationMethod = smRange then\r\n begin\r\n if ValueAxis[I] > MaxAxis[I] then\r\n ValueAxis[I] := MaxAxis[I];\r\n if ValueAxis[I] < MinAxis[I] then\r\n ValueAxis[I] := MinAxis[I];\r\n end\r\n else\r\n begin\r\n Range := MaxAxis[I] - MinAxis[I] + 1;\r\n while ValueAxis[I] < MinAxis[I] do\r\n Inc(ValueAxis[I], Range);\r\n while ValueAxis[I] > MaxAxis[I] do\r\n Dec(ValueAxis[I], Range);\r\n end;\r\n end;\r\n Result :=\r\n (ValueAxis[axIndex0]) or (ValueAxis[axIndex1] shl 8) or (ValueAxis[axIndex2] shl 16);\r\n end;\r\n\r\nbegin\r\n with ColorSpaceManager do\r\n begin\r\n SourceColorSpace := ColorSpace[GetColorSpaceID(AColor)];\r\n LColor := SourceColorSpace.ConvertToColor(AColor);\r\n DeltaColorSpace := ColorSpace[AColorDelta.ColorID];\r\n\r\n with DeltaColorSpace do\r\n begin\r\n for I := Low(TJvAxisIndex) to High(TJvAxisIndex) do\r\n begin\r\n MinAxis[I] := AxisMin[I];\r\n MaxAxis[I] := AxisMax[I];\r\n end;\r\n ColorRed := ConvertToColor(DoRotate(ConvertFromColor(LColor and $000000FF), AColorDelta.AxisRed));\r\n ColorGreen := ConvertToColor(DoRotate(ConvertFromColor(LColor and $0000FF00), AColorDelta.AxisGreen));\r\n ColorBlue := ConvertToColor(DoRotate(ConvertFromColor(LColor and $00FF0000), AColorDelta.AxisBlue));\r\n\r\n MaxColorAxis := 255;\r\n for I := Low(TJvAxisIndex) to High(TJvAxisIndex) do\r\n begin\r\n ValueAxis[I] := (ColorRed and $FF) + (ColorGreen and $FF) + (ColorBlue and $FF);\r\n if ValueAxis[I] > MaxColorAxis then\r\n MaxColorAxis := ValueAxis[I];\r\n ColorRed := ColorRed shr 8;\r\n ColorGreen := ColorGreen shr 8;\r\n ColorBlue := ColorBlue shr 8;\r\n end;\r\n\r\n for I := Low(TJvAxisIndex) to High(TJvAxisIndex) do\r\n begin\r\n ValueAxis[I] := ValueAxis[I] + 255 - MaxColorAxis;\r\n if ValueAxis[I] < 0 then\r\n ValueAxis[I] := 0;\r\n end;\r\n LColor := ValueAxis[axIndex0] or (ValueAxis[axIndex1] shl 8) or (ValueAxis[axIndex2] shl 16);\r\n end;\r\n Result := SourceColorSpace.ConvertFromColor(LColor);\r\n end;\r\nend;\r\n\r\nprocedure RotateBitmap(SourceBitmap, DestBitmap: TBitmap; AColorDelta: TJvColorDelta);\r\ntype\r\n TFullColorValue = array [TJvAxisIndex] of SmallInt;\r\n PFullColorValue = ^TFullColorValue;\r\nvar\r\n OriginalPixelFormat: TPixelFormat;\r\n Colors: array [TJvAxisIndex,Byte] of TFullColorValue;\r\n ColorR, ColorB, ColorG, ColorFusion: TFullColorValue;\r\n I: TJvAxisIndex;\r\n J: Byte;\r\n X, Y: Integer;\r\n MinAxis: array [TJvAxisIndex] of SmallInt;\r\n MaxAxis: array [TJvAxisIndex] of SmallInt;\r\n MaxColorAxis: SmallInt;\r\n DeltaColorSpace: TJvColorSpace;\r\n DestLine, SourceLine: PCardinal;\r\n\r\n procedure DoRotate(Color: TColor; AAxisDelta: TJvAxisDelta; out DestColor: TFullColorValue);\r\n var\r\n I: TJvAxisIndex;\r\n Range: Integer;\r\n FullColor: TJvFullColor;\r\n ColorValue: TFullColorValue;\r\n begin\r\n FullColor := DeltaColorSpace.ConvertFromColor(Color);\r\n for I := Low(TJvAxisIndex) to High(TJvAxisIndex) do\r\n begin\r\n ColorValue[I] := Integer(GetAxisValue(FullColor, I)) + AAxisDelta[I].Value;\r\n if AAxisDelta[I].SaturationMethod = smRange then\r\n begin\r\n if ColorValue[I] > MaxAxis[I] then\r\n ColorValue[I] := MaxAxis[I];\r\n if ColorValue[I] < MinAxis[I] then\r\n ColorValue[I] := MinAxis[I];\r\n end\r\n else\r\n begin\r\n Range := MaxAxis[I] - MinAxis[I] + 1;\r\n while ColorValue[I] < MinAxis[I] do\r\n Inc(ColorValue[I], Range);\r\n while ColorValue[I] > MaxAxis[I] do\r\n Dec(ColorValue[I], Range);\r\n end;\r\n end;\r\n Color := DeltaColorSpace.ConvertToColor(ColorValue[axIndex0] or\r\n (ColorValue[axIndex1] shl 8) or (ColorValue[axIndex2] shl 16));\r\n DestColor[axIndex0] := Color and $FF;\r\n DestColor[axIndex1] := (Color shr 8) and $FF;\r\n DestColor[axIndex2] := (Color shr 16) and $FF;\r\n end;\r\n\r\nbegin\r\n DestBitmap.Width := SourceBitmap.Width;\r\n DestBitmap.Height := SourceBitmap.Height;\r\n OriginalPixelFormat := SourceBitmap.PixelFormat;\r\n SourceBitmap.PixelFormat := pf32bit;\r\n DestBitmap.PixelFormat := pf32bit;\r\n with ColorSpaceManager do\r\n begin\r\n DeltaColorSpace := ColorSpace[AColorDelta.ColorID];\r\n with DeltaColorSpace do\r\n begin\r\n for I := Low(TJvAxisIndex) to High(TJvAxisIndex) do\r\n begin\r\n MinAxis[I] := AxisMin[I];\r\n MaxAxis[I] := AxisMax[I];\r\n end;\r\n for J := Low(Byte) to High(Byte) do\r\n begin\r\n DoRotate(TColor(J),AColorDelta.AxisRed,Colors[axIndex0,J]);\r\n DoRotate(TColor(J shl 8),AColorDelta.AxisGreen,Colors[axIndex1,J]);\r\n DoRotate(TColor(J shl 16),AColorDelta.AxisBlue,Colors[axIndex2,J]);\r\n end;\r\n\r\n for Y := 0 to DestBitmap.Height-1 do\r\n begin\r\n SourceLine := SourceBitmap.ScanLine[Y];\r\n DestLine := DestBitmap.ScanLine[Y];\r\n for X := 0 to DestBitmap.Width-1 do\r\n begin\r\n ColorR := Colors[axIndex0,(SourceLine^ shr 16) and $FF]; //\r\n ColorG := Colors[axIndex1,(SourceLine^ shr 8) and $FF]; // Bitmap Color Format is\r\n ColorB := Colors[axIndex2,(SourceLine^) and $FF]; // (MSB)0RGB(LSB)\r\n ColorFusion[axIndex0] := ColorR[axIndex0] + ColorG[axIndex0] + ColorB[axIndex0];\r\n ColorFusion[axIndex1] := ColorR[axIndex1] + ColorG[axIndex1] + ColorB[axIndex1];\r\n ColorFusion[axIndex2] := ColorR[axIndex2] + ColorG[axIndex2] + ColorB[axIndex2];\r\n MaxColorAxis := 255;\r\n if ColorFusion[axIndex0] > MaxColorAxis then\r\n MaxColorAxis := ColorFusion[axIndex0];\r\n if ColorFusion[axIndex1] > MaxColorAxis then\r\n MaxColorAxis := ColorFusion[axIndex1];\r\n if ColorFusion[axIndex2] > MaxColorAxis then\r\n MaxColorAxis := ColorFusion[axIndex2];\r\n ColorFusion[axIndex0] := ColorFusion[axIndex0] + 255 - MaxColorAxis;\r\n if ColorFusion[axIndex0] < 0 then\r\n ColorFusion[axIndex0] := 0;\r\n ColorFusion[axIndex1] := ColorFusion[axIndex1] + 255 - MaxColorAxis;\r\n if ColorFusion[axIndex1] < 0 then\r\n ColorFusion[axIndex1] := 0;\r\n ColorFusion[axIndex2] := ColorFusion[axIndex2] + 255 - MaxColorAxis;\r\n if ColorFusion[axIndex2] < 0 then\r\n ColorFusion[axIndex2] := 0;\r\n DestLine^ := // Bitmap Color Format is (MSB)0RGB(LSB)\r\n (ColorFusion[axIndex0] shl 16) or (ColorFusion[axIndex1] shl 8) or (ColorFusion[axIndex2]);\r\n Inc(SourceLine);\r\n Inc(DestLine);\r\n end;\r\n end;\r\n end;\r\n end;\r\n SourceBitmap.PixelFormat := OriginalPixelFormat;\r\n DestBitmap.PixelFormat := OriginalPixelFormat;\r\nend;\r\n\r\n//=== { TJvAxisDelta } =======================================================\r\n\r\nconstructor TJvAxisDelta.Create;\r\nvar\r\n Index: TJvAxisIndex;\r\nbegin\r\n inherited Create;\r\n for Index := Low(TJvAxisIndex) to High(TJvAxisIndex) do\r\n FConstituents[Index] := TJvRotateValue.Create;\r\nend;\r\n\r\ndestructor TJvAxisDelta.Destroy;\r\nvar\r\n Index: TJvAxisIndex;\r\nbegin\r\n for Index := Low(TJvAxisIndex) to High(TJvAxisIndex) do\r\n FConstituents[Index].Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvAxisDelta.Assign(Value: TJvAxisDelta);\r\nvar\r\n Index: TJvAxisIndex;\r\nbegin\r\n for Index := Low(TJvAxisIndex) to High(TJvAxisIndex) do\r\n FConstituents[Index].Assign(Value[Index]);\r\nend;\r\n\r\nfunction TJvAxisDelta.GetConstituents(Index: TJvAxisIndex): TJvRotateValue;\r\nbegin\r\n Result := FConstituents[Index];\r\nend;\r\n\r\nprocedure TJvAxisDelta.SetConstituents(Index: TJvAxisIndex;\r\n const Value: TJvRotateValue);\r\nbegin\r\n FConstituents[Index].Assign(Value);\r\nend;\r\n\r\n//=== { TJvColorDelta } ======================================================\r\n\r\nconstructor TJvColorDelta.Create;\r\nbegin\r\n inherited Create;\r\n FColorID := csRGB;\r\n FAxisRed := TJvAxisDelta.Create;\r\n FAxisGreen := TJvAxisDelta.Create;\r\n FAxisBlue := TJvAxisDelta.Create;\r\nend;\r\n\r\ndestructor TJvColorDelta.Destroy;\r\nbegin\r\n FAxisRed.Free;\r\n FAxisGreen.Free;\r\n FAxisBlue.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvColorDelta.Assign(Value: TJvColorDelta);\r\nbegin\r\n AxisRed.Assign(Value.AxisRed);\r\n AxisGreen.Assign(Value.AxisGreen);\r\n AxisBlue.Assign(Value.AxisBlue);\r\n ColorID := Value.ColorID;\r\nend;\r\n\r\nprocedure TJvColorDelta.SetAxisBlue(const Value: TJvAxisDelta);\r\nbegin\r\n FAxisBlue.Assign(Value);\r\nend;\r\n\r\nprocedure TJvColorDelta.SetAxisGreen(const Value: TJvAxisDelta);\r\nbegin\r\n FAxisGreen.Assign(Value);\r\nend;\r\n\r\nprocedure TJvColorDelta.SetAxisRed(const Value: TJvAxisDelta);\r\nbegin\r\n FAxisRed.Assign(Value);\r\nend;\r\n\r\n//=== { TJvRotateValue } =====================================================\r\n\r\nconstructor TJvRotateValue.Create;\r\nbegin\r\n FValue := 0;\r\n FSaturationMethod := smLoop;\r\nend;\r\n\r\nprocedure TJvRotateValue.Assign(Value: TJvRotateValue);\r\nbegin\r\n FValue := Value.Value;\r\n FSaturationMethod := Value.SaturationMethod;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvFullColorSpaces.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: ColorSpaces.pas, released on 2004-09-11.\r\n\r\nThe Initial Developer of the Original Code is Florent Ouchet [ouchet dott florent att laposte dott net]\r\nPortions created by Florent Ouchet are Copyright (C) 2004 Florent Ouchet.\r\nAll Rights Reserved.\r\n\r\nContributor(s): -\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvFullColorSpaces.pas 12461 2009-08-14 17:21:33Z obones $\r\n\r\n// TColorBox is implemented in ExtCtrls in Delphi and BCB version 6 and +\r\n\r\nunit JvFullColorSpaces;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, Classes, SysUtils, Graphics,\r\n JvTypes;\r\n\r\ntype\r\n TJvAxisIndex = (axIndex0, axIndex1, axIndex2);\r\n TJvFullColorSpaceID = type Byte;\r\n TJvFullColor = type Cardinal;\r\n\r\nconst\r\n JvSystemColorMask = {$IFDEF COMPILER7_UP} clSystemColor; {$ELSE} $80000000; {$ENDIF}\r\n\r\n JvSubFullColorMask = $03000000;\r\n\r\n JvSystemFullColorMask = $01000000;\r\n JvSpecialFullColorMask = $03000000;\r\n\r\nconst\r\n csRGB = TJvFullColorSpaceID(1 shl 2);\r\n csHLS = TJvFullColorSpaceID(2 shl 2);\r\n csCMY = TJvFullColorSpaceID(3 shl 2);\r\n csYUV = TJvFullColorSpaceID(4 shl 2);\r\n csHSV = TJvFullColorSpaceID(5 shl 2);\r\n csYIQ = TJvFullColorSpaceID(6 shl 2);\r\n csYCC = TJvFullColorSpaceID(7 shl 2);\r\n csXYZ = TJvFullColorSpaceID(8 shl 2);\r\n csLAB = TJvFullColorSpaceID(9 shl 2);\r\n csDEF = TJvFullColorSpaceID(10 shl 2);\r\n\r\n csID_MASK = $FC;\r\n\r\n csMIN = $04 and csID_MASK;\r\n csMAX = $FF and csID_MASK;\r\n\r\n RGB_MIN = 0;\r\n RGB_MAX = 255;\r\n HLS_MIN = 0;\r\n HLS_MAX = 240;\r\n CMY_MIN = 0;\r\n CMY_MAX = 255;\r\n YUV_MIN = 16;\r\n YUV_MAX = 235;\r\n HSV_MIN = 0;\r\n HSV_MAX = 240;\r\n YIQ_MIN = 0;\r\n YIQ_MAX = 255;\r\n YCC_MIN = 0;\r\n YCC_MAX = 255;\r\n XYZ_MIN = 0;\r\n XYZ_MAX = 255;\r\n LAB_MIN = 0;\r\n LAB_MAX = 255;\r\n DEF_MIN = 0;\r\n DEF_MAX = 255;\r\n\r\n fclRGBBlack = TJvFullColor((Ord(csRGB) shl 24) or $000000);\r\n fclRGBWhite = TJvFullColor((Ord(csRGB) shl 24) or $FFFFFF);\r\n fclRGBRed = TJvFullColor((Ord(csRGB) shl 24) or $0000FF);\r\n fclRGBLime = TJvFullColor((Ord(csRGB) shl 24) or $00FF00);\r\n fclRGBBlue = TJvFullColor((Ord(csRGB) shl 24) or $FF0000);\r\n\r\n fclDEFWindowText = TJvFullColor((Ord(csDEF) shl 24) or JvSystemFullColorMask or COLOR_WINDOWTEXT);\r\n\r\ntype\r\n TJvColorSpace = class(TPersistent)\r\n private\r\n FID: TJvFullColorSpaceID;\r\n protected\r\n function GetAxisName(Index: TJvAxisIndex): string; virtual;\r\n function GetAxisMin(Index: TJvAxisIndex): Byte; virtual;\r\n function GetAxisMax(Index: TJvAxisIndex): Byte; virtual;\r\n function GetAxisDefault(Index: TJvAxisIndex): Byte; virtual;\r\n function GetName: string; virtual;\r\n function GetShortName: string; virtual;\r\n function GetNumberOfColors: Cardinal; virtual;\r\n public\r\n constructor Create(ColorID: TJvFullColorSpaceID); virtual;\r\n function ConvertFromColor(AColor: TColor): TJvFullColor; virtual;\r\n function ConvertToColor(AColor: TJvFullColor): TColor; virtual;\r\n property ID: TJvFullColorSpaceID read FID;\r\n property NumberOfColors: Cardinal read GetNumberOfColors;\r\n property Name: string read GetName;\r\n property ShortName: string read GetShortName;\r\n property AxisName[Index: TJvAxisIndex]: string read GetAxisName;\r\n property AxisMin[Index: TJvAxisIndex]: Byte read GetAxisMin;\r\n property AxisMax[Index: TJvAxisIndex]: Byte read GetAxisMax;\r\n property AxisDefault[Index: TJvAxisIndex]: Byte read GetAxisDefault;\r\n end;\r\n\r\n {TJvColorConversionMatrix = array[0..3,0..3] of Extended; // OpenGL and D3D style matrix\r\n PJvColorConversionMatrix = ^TJvColorConversionMatrix;\r\n TJvMatrixType = (mtFromRGB, mtToRGB);\r\n\r\n TJvMatrixColorSpace = class(TJvColorSpace)\r\n protected\r\n FToRGBMatrix,\r\n FFromRGBMatrix: TJvColorConversionMatrix;\r\n public\r\n constructor Create(ColorID: TJvFullColorSpaceID; AMatrix: PJvColorConversionMatrix;\r\n MatrixType: TJvMatrixType); reintroduce;\r\n destructor Destroy; override;\r\n function ConvertToID(AFullColor: TJvFullColor; NewID: TJvFullColorSpaceID; //\r\n RGBToNewIDMatrix: PJvColorConversionMatrix): TJvFullColor; // use a call with pointer argument\r\n function ConvertFromID(AFullColor: TJvFullColor; OldID: TJvFullColorSpaceID; // because a matrix is 160 Bytes !!!\r\n OldIDToRGBMatrix: PJvColorConversionMatrix): TJvFullColor; // /!\\ not on the stack /!\\\r\n function ConvertFromColor(AColor: TColor): TColor; override; //\r\n function ConvertToColor(AColor: TJvFullColor): TColor; override;\r\n function GetToRGBMatrix: PJvColorConversionMatrix;\r\n function GetFromRGBMatrix: PJvColorConversionMatrix;\r\n end;}\r\n\r\n TJvRGBColorSpace = class(TJvColorSpace)\r\n protected\r\n function GetAxisName(Index: TJvAxisIndex): string; override;\r\n function GetAxisMin(Index: TJvAxisIndex): Byte; override;\r\n function GetAxisMax(Index: TJvAxisIndex): Byte; override;\r\n function GetName: string; override;\r\n function GetShortName: string; override;\r\n function GetAxisDefault(Index: TJvAxisIndex): Byte; override;\r\n public\r\n function ConvertFromColor(AColor: TColor): TJvFullColor; override;\r\n function ConvertToColor(AColor: TJvFullColor): TColor; override;\r\n end;\r\n\r\n TJvHLSColorSpace = class(TJvColorSpace)\r\n protected\r\n function GetAxisName(Index: TJvAxisIndex): string; override;\r\n function GetAxisMin(Index: TJvAxisIndex): Byte; override;\r\n function GetAxisMax(Index: TJvAxisIndex): Byte; override;\r\n function GetName: string; override;\r\n function GetShortName: string; override;\r\n function GetAxisDefault(Index: TJvAxisIndex): Byte; override;\r\n public\r\n function ConvertFromColor(AColor: TColor): TJvFullColor; override;\r\n function ConvertToColor(AColor: TJvFullColor): TColor; override;\r\n end;\r\n\r\n TJvCMYColorSpace = class(TJvColorSpace)\r\n protected\r\n function GetAxisName(Index: TJvAxisIndex): string; override;\r\n function GetAxisMin(Index: TJvAxisIndex): Byte; override;\r\n function GetAxisMax(Index: TJvAxisIndex): Byte; override;\r\n function GetName: string; override;\r\n function GetShortName: string; override;\r\n function GetAxisDefault(Index: TJvAxisIndex): Byte; override;\r\n public\r\n function ConvertFromColor(AColor: TColor): TJvFullColor; override;\r\n function ConvertToColor(AColor: TJvFullColor): TColor; override;\r\n end;\r\n\r\n TJvYUVColorSpace = class(TJvColorSpace)\r\n protected\r\n function GetAxisName(Index: TJvAxisIndex): string; override;\r\n function GetAxisMin(Index: TJvAxisIndex): Byte; override;\r\n function GetAxisMax(Index: TJvAxisIndex): Byte; override;\r\n function GetName: string; override;\r\n function GetShortName: string; override;\r\n function GetAxisDefault(Index: TJvAxisIndex): Byte; override;\r\n public\r\n function ConvertFromColor(AColor: TColor): TJvFullColor; override;\r\n function ConvertToColor(AColor: TJvFullColor): TColor; override;\r\n end;\r\n\r\n TJvHSVColorSpace = class(TJvColorSpace)\r\n protected\r\n function GetAxisName(Index: TJvAxisIndex): string; override;\r\n function GetAxisMin(Index: TJvAxisIndex): Byte; override;\r\n function GetAxisMax(Index: TJvAxisIndex): Byte; override;\r\n function GetName: string; override;\r\n function GetShortName: string; override;\r\n function GetAxisDefault(Index: TJvAxisIndex): Byte; override;\r\n public\r\n function ConvertFromColor(AColor: TColor): TJvFullColor; override;\r\n function ConvertToColor(AColor: TJvFullColor): TColor; override;\r\n end;\r\n\r\n TJvYIQColorSpace = class(TJvColorSpace)\r\n protected\r\n function GetAxisName(Index: TJvAxisIndex): string; override;\r\n function GetAxisMin(Index: TJvAxisIndex): Byte; override;\r\n function GetAxisMax(Index: TJvAxisIndex): Byte; override;\r\n function GetName: string; override;\r\n function GetShortName: string; override;\r\n function GetAxisDefault(Index: TJvAxisIndex): Byte; override;\r\n public\r\n function ConvertFromColor(AColor: TColor): TJvFullColor; override;\r\n function ConvertToColor(AColor: TJvFullColor): TColor; override;\r\n end;\r\n\r\n TJvYCCColorSpace = class(TJvColorSpace)\r\n protected\r\n function GetAxisName(Index: TJvAxisIndex): string; override;\r\n function GetAxisMin(Index: TJvAxisIndex): Byte; override;\r\n function GetAxisMax(Index: TJvAxisIndex): Byte; override;\r\n function GetName: string; override;\r\n function GetShortName: string; override;\r\n function GetAxisDefault(Index: TJvAxisIndex): Byte; override;\r\n public\r\n function ConvertFromColor(AColor: TColor): TJvFullColor; override;\r\n function ConvertToColor(AColor: TJvFullColor): TColor; override;\r\n end;\r\n\r\n TJvXYZColorSpace = class(TJvColorSpace)\r\n protected\r\n function GetAxisName(Index: TJvAxisIndex): string; override;\r\n function GetAxisMin(Index: TJvAxisIndex): Byte; override;\r\n function GetAxisMax(Index: TJvAxisIndex): Byte; override;\r\n function GetName: string; override;\r\n function GetShortName: string; override;\r\n function GetAxisDefault(Index: TJvAxisIndex): Byte; override;\r\n public\r\n function ConvertFromColor(AColor: TColor): TJvFullColor; override;\r\n function ConvertToColor(AColor: TJvFullColor): TColor; override;\r\n end;\r\n\r\n TJvLABColorSpace = class(TJvColorSpace)\r\n protected\r\n function GetAxisName(Index: TJvAxisIndex): string; override;\r\n function GetAxisMin(Index: TJvAxisIndex): Byte; override;\r\n function GetAxisMax(Index: TJvAxisIndex): Byte; override;\r\n function GetName: string; override;\r\n function GetShortName: string; override;\r\n function GetAxisDefault(Index: TJvAxisIndex): Byte; override;\r\n public\r\n function ConvertFromColor(AColor: TColor): TJvFullColor; override;\r\n function ConvertToColor(AColor: TJvFullColor): TColor; override;\r\n end;\r\n\r\n TJvDEFColorSpace = class(TJvColorSpace)\r\n private\r\n FDelphiColors: TStringList;\r\n procedure GetColorValuesCallBack(const S: string);\r\n protected\r\n function GetName: string; override;\r\n function GetShortName: string; override;\r\n function GetNumberOfColors: Cardinal; override;\r\n function GetColorName(Index: Integer): string;\r\n function GetPrettyName(Index: Integer): string;\r\n function GetColorValue(Index: Integer): TColor;\r\n public\r\n constructor Create(ColorID: TJvFullColorSpaceID); override;\r\n destructor Destroy; override;\r\n function ConvertFromColor(AColor: TColor): TJvFullColor; override;\r\n function ConvertToColor(AColor: TJvFullColor): TColor; override;\r\n procedure AddCustomColor(AColor: TColor; ShortName: string; PrettyName: string);\r\n procedure AddDelphiColor(Value: TColor);\r\n property ColorCount: Cardinal read GetNumberOfColors;\r\n property ColorName[Index: Integer]: string read GetColorName;\r\n property ColorPrettyName[Index: Integer]: string read GetPrettyName;\r\n property ColorValue[Index: Integer]: TColor read GetColorValue; default;\r\n end;\r\n\r\n TJvColorSpaceManager = class(TPersistent)\r\n private\r\n FColorSpaceList: TList;\r\n function GetCount: Integer;\r\n function GetColorSpaceByIndex(Index: Integer): TJvColorSpace;\r\n protected\r\n function GetColorSpace(ID: TJvFullColorSpaceID): TJvColorSpace; virtual;\r\n public\r\n procedure RegisterColorSpace(NewColorSpace: TJvColorSpace);\r\n procedure UnRegisterColorSpace(AColorSpace: TJvColorSpace);\r\n constructor Create;\r\n destructor Destroy; override;\r\n function ConvertToID(AColor: TJvFullColor; DestID: TJvFullColorSpaceID): TJvFullColor;\r\n function ConvertToColor(AColor: TJvFullColor): TColor;\r\n function ConvertFromColor(AColor: TColor): TJvFullColor;\r\n function GetColorSpaceID(AColor: TJvFullColor): TJvFullColorSpaceID;\r\n\r\n property ColorSpace[ID: TJvFullColorSpaceID]: TJvColorSpace read GetColorSpace;\r\n property ColorSpaceByIndex[Index: Integer]: TJvColorSpace read GetColorSpaceByIndex;\r\n property Count: Integer read GetCount;\r\n end;\r\n\r\n EJvColorSpaceError = class(EJVCLException);\r\n\r\nfunction ColorSpaceManager: TJvColorSpaceManager;\r\nfunction GetAxisValue(AColor: TJvFullColor; AAxis: TJvAxisIndex): Byte;\r\nfunction SetAxisValue(AColor: TJvFullColor; AAxis: TJvAxisIndex; NewValue: Byte): TJvFullColor;\r\n\r\nprocedure SplitColorParts(AColor: TJvFullColor; var Part1, Part2, Part3: Integer);\r\nfunction JoinColorParts(const Part1, Part2, Part3: Integer): TJvFullColor;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvFullColorSpaces.pas $';\r\n Revision: '$Revision: 12461 $';\r\n Date: '$Date: 2009-08-14 19:21:33 +0200 (ven. 14 août 2009) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n Controls, StdCtrls, ExtCtrls,\r\n JvResources, TypInfo, JvJCLUtils ,JvJVCLUtils,\r\n JclMath;\r\n\r\nvar\r\n GlobalColorSpaceManager: TJvColorSpaceManager = nil;\r\n\r\nconst\r\n HLS_MAX_HALF = HLS_MAX / 2.0;\r\n HLS_MAX_ONE_THIRD = HLS_MAX / 3.0;\r\n HLS_MAX_TWO_THIRDS = (HLS_MAX * 2.0) / 3.0;\r\n HLS_MAX_SIXTH = HLS_MAX / 6.0;\r\n HLS_MAX_TWELVETH = HLS_MAX / 12.0;\r\n\r\nfunction ColorSpaceManager: TJvColorSpaceManager;\r\nbegin\r\n if GlobalColorSpaceManager = nil then\r\n begin\r\n GlobalColorSpaceManager := TJvColorSpaceManager.Create;\r\n GlobalColorSpaceManager.RegisterColorSpace(TJvRGBColorSpace.Create(csRGB));\r\n GlobalColorSpaceManager.RegisterColorSpace(TJvHLSColorSpace.Create(csHLS));\r\n GlobalColorSpaceManager.RegisterColorSpace(TJvCMYColorSpace.Create(csCMY));\r\n GlobalColorSpaceManager.RegisterColorSpace(TJvYUVColorSpace.Create(csYUV));\r\n GlobalColorSpaceManager.RegisterColorSpace(TJvHSVColorSpace.Create(csHSV));\r\n GlobalColorSpaceManager.RegisterColorSpace(TJvYIQColorSpace.Create(csYIQ));\r\n GlobalColorSpaceManager.RegisterColorSpace(TJvYCCColorSpace.Create(csYCC));\r\n GlobalColorSpaceManager.RegisterColorSpace(TJvXYZColorSpace.Create(csXYZ));\r\n GlobalColorSpaceManager.RegisterColorSpace(TJvLABColorSpace.Create(csLAB));\r\n GlobalColorSpaceManager.RegisterColorSpace(TJvDEFColorSpace.Create(csDEF));\r\n end;\r\n Result := GlobalColorSpaceManager;\r\nend;\r\n\r\nfunction SetAxisValue(AColor: TJvFullColor; AAxis: TJvAxisIndex;\r\n NewValue: Byte): TJvFullColor;\r\nbegin\r\n case AAxis of\r\n axIndex0:\r\n AColor := (AColor and $FFFFFF00) or NewValue;\r\n axIndex1:\r\n AColor := (AColor and $FFFF00FF) or (NewValue shl 8);\r\n axIndex2:\r\n AColor := (AColor and $FF00FFFF) or (NewValue shl 16);\r\n end;\r\n Result := AColor;\r\nend;\r\n\r\nfunction GetAxisValue(AColor: TJvFullColor; AAxis: TJvAxisIndex): Byte;\r\nbegin\r\n case AAxis of\r\n axIndex0:\r\n Result := (AColor and $000000FF);\r\n axIndex1:\r\n Result := (AColor and $0000FF00) shr 8;\r\n axIndex2:\r\n Result := (AColor and $00FF0000) shr 16;\r\n else\r\n Result := 0;\r\n end;\r\nend;\r\n\r\nprocedure SplitColorParts(AColor: TJvFullColor; var Part1, Part2, Part3: Integer);\r\nbegin\r\n Part1 := AColor and $000000FF;\r\n Part2 := (AColor shr 8) and $000000FF;\r\n Part3 := (AColor shr 16) and $000000FF;\r\nend;\r\n\r\nfunction JoinColorParts(const Part1, Part2, Part3: Integer): TJvFullColor;\r\nbegin\r\n Result :=\r\n (Part1 and $000000FF) or\r\n ((Part2 and $000000FF) shl 8) or\r\n ((Part3 and $000000FF) shl 16);\r\nend;\r\n\r\n\r\n//=== { TJvColorSpace } ======================================================\r\n\r\nconstructor TJvColorSpace.Create(ColorID: TJvFullColorSpaceID);\r\nbegin\r\n inherited Create;\r\n if (ColorID >= csMIN) and (ColorID <= csMAX) then\r\n FID := ColorID\r\n else\r\n raise EJvColorSpaceError.CreateResFmt(@RsEIllegalID, [Ord(ColorID)]);\r\nend;\r\n\r\nfunction TJvColorSpace.ConvertFromColor(AColor: TColor): TJvFullColor;\r\nbegin\r\n Result := (AColor and $00FFFFFF) or (ID shl 24);\r\nend;\r\n\r\nfunction TJvColorSpace.ConvertToColor(AColor: TJvFullColor): TColor;\r\nbegin\r\n Result := AColor and $00FFFFFF;\r\nend;\r\n\r\nfunction TJvColorSpace.GetNumberOfColors: Cardinal;\r\nbegin\r\n Result :=\r\n (AxisMax[axIndex0] - AxisMin[axIndex0] + 1) *\r\n (AxisMax[axIndex1] - AxisMin[axIndex1] + 1) *\r\n (AxisMax[axIndex2] - AxisMin[axIndex2] + 1);\r\nend;\r\n\r\nfunction TJvColorSpace.GetAxisDefault(Index: TJvAxisIndex): Byte;\r\nbegin\r\n Result := Low(Byte);\r\nend;\r\n\r\nfunction TJvColorSpace.GetAxisMax(Index: TJvAxisIndex): Byte;\r\nbegin\r\n Result := High(Byte);\r\nend;\r\n\r\nfunction TJvColorSpace.GetAxisMin(Index: TJvAxisIndex): Byte;\r\nbegin\r\n Result := Low(Byte);\r\nend;\r\n\r\nfunction TJvColorSpace.GetAxisName(Index: TJvAxisIndex): string;\r\nbegin\r\n Result := RsEUnnamedAxis;\r\nend;\r\n\r\nfunction TJvColorSpace.GetName: string;\r\nbegin\r\n Result := RsEUnnamedSpace;\r\nend;\r\n\r\nfunction TJvColorSpace.GetShortName: string;\r\nbegin\r\n Result := RsEUCS;\r\nend;\r\n\r\n//=== { TJvRGBColorSpace } ===================================================\r\n\r\nfunction TJvRGBColorSpace.ConvertFromColor(AColor: TColor): TJvFullColor;\r\nbegin\r\n Result := inherited ConvertFromColor(AColor);\r\nend;\r\n\r\nfunction TJvRGBColorSpace.ConvertToColor(AColor: TJvFullColor): TColor;\r\nbegin\r\n Result := inherited ConvertToColor(AColor);\r\nend;\r\n\r\nfunction TJvRGBColorSpace.GetAxisDefault(Index: TJvAxisIndex): Byte;\r\nbegin\r\n Result := 0;\r\nend;\r\n\r\nfunction TJvRGBColorSpace.GetAxisMax(Index: TJvAxisIndex): Byte;\r\nbegin\r\n Result := RGB_MAX;\r\nend;\r\n\r\nfunction TJvRGBColorSpace.GetAxisMin(Index: TJvAxisIndex): Byte;\r\nbegin\r\n Result := RGB_MIN;\r\nend;\r\n\r\nfunction TJvRGBColorSpace.GetAxisName(Index: TJvAxisIndex): string;\r\nbegin\r\n case Index of\r\n axIndex0:\r\n Result := RsRGB_Red;\r\n axIndex1:\r\n Result := RsRGB_Green;\r\n axIndex2:\r\n Result := RsRGB_Blue;\r\n else\r\n Result := inherited GetAxisName(Index);\r\n end;\r\nend;\r\n\r\nfunction TJvRGBColorSpace.GetName: string;\r\nbegin\r\n Result := RsRGB_FullName;\r\nend;\r\n\r\nfunction TJvRGBColorSpace.GetShortName: string;\r\nbegin\r\n Result := RsRGB_ShortName;\r\nend;\r\n\r\n//=== { TJvHLSColorSpace } ===================================================\r\n\r\nfunction TJvHLSColorSpace.ConvertFromColor(AColor: TColor): TJvFullColor;\r\nvar\r\n Hue, Lightness, Saturation: Double;\r\n Red, Green, Blue: Integer;\r\n ColorMax, ColorMin, ColorDiff, ColorSum: Double;\r\n RedDelta, GreenDelta, BlueDelta: Extended;\r\nbegin\r\n SplitColorParts(AColor, Red, Green, Blue);\r\n\r\n if Red > Green then\r\n ColorMax := Red\r\n else\r\n ColorMax := Green;\r\n if Blue > ColorMax then\r\n ColorMax := Blue;\r\n if Red < Green then\r\n ColorMin := Red\r\n else\r\n ColorMin := Green;\r\n if Blue < ColorMin then\r\n ColorMin := Blue;\r\n ColorDiff := ColorMax - ColorMin;\r\n ColorSum := ColorMax + ColorMin;\r\n\r\n Lightness := (ColorSum * HLS_MAX + RGB_MAX) / (2.0 * RGB_MAX);\r\n if ColorMax = ColorMin then\r\n AColor := (Round(Lightness) shl 8) or (2 * HLS_MAX div 3)\r\n else\r\n begin\r\n if Lightness <= HLS_MAX_HALF then\r\n Saturation := (ColorDiff * HLS_MAX + ColorSum / 2.0) / ColorSum\r\n else\r\n Saturation := (ColorDiff * HLS_MAX + ((2.0 * RGB_MAX - ColorMax - ColorMin) / 2.0)) /\r\n (2.0 * RGB_MAX - ColorMax - ColorMin);\r\n\r\n RedDelta := ((ColorMax - Red) * HLS_MAX_SIXTH + ColorDiff / 2.0) / ColorDiff;\r\n GreenDelta := ((ColorMax - Green) * HLS_MAX_SIXTH + ColorDiff / 2.0) / ColorDiff;\r\n BlueDelta := ((ColorMax - Blue) * HLS_MAX_SIXTH + ColorDiff / 2.0) / ColorDiff;\r\n\r\n if Red = ColorMax then\r\n Hue := BlueDelta - GreenDelta\r\n else\r\n if Green = ColorMax then\r\n Hue := HLS_MAX_ONE_THIRD + RedDelta - BlueDelta\r\n else\r\n Hue := 2.0 * HLS_MAX_ONE_THIRD + GreenDelta - RedDelta;\r\n\r\n if Hue < 0 then\r\n Hue := Hue + HLS_MAX;\r\n if Hue > HLS_MAX then\r\n Hue := Hue - HLS_MAX;\r\n\r\n AColor :=\r\n JoinColorParts(Cardinal(Round(Hue)), Cardinal(Round(Lightness)), Cardinal(Round(Saturation)));\r\n end;\r\n Result := inherited ConvertFromColor(AColor);\r\nend;\r\n\r\nfunction TJvHLSColorSpace.ConvertToColor(AColor: TJvFullColor): TColor;\r\nvar\r\n Red, Green, Blue: Double;\r\n Magic1, Magic2: Double;\r\n Hue, Lightness, Saturation: Integer;\r\n\r\n function HueToRGB(Lightness, Saturation, Hue: Double): Integer;\r\n var\r\n ResultEx: Double;\r\n begin\r\n if Hue < 0 then\r\n Hue := Hue + HLS_MAX;\r\n if Hue > HLS_MAX then\r\n Hue := Hue - HLS_MAX;\r\n\r\n if Hue < HLS_MAX_SIXTH then\r\n ResultEx := Lightness + ((Saturation - Lightness) * Hue + HLS_MAX_TWELVETH) / HLS_MAX_SIXTH\r\n else\r\n if Hue < HLS_MAX_HALF then\r\n ResultEx := Saturation\r\n else\r\n if Hue < HLS_MAX_TWO_THIRDS then\r\n ResultEx := Lightness + ((Saturation - Lightness) * (HLS_MAX_TWO_THIRDS - Hue) + HLS_MAX_TWELVETH) / HLS_MAX_SIXTH\r\n else\r\n ResultEx := Lightness;\r\n Result := Round(ResultEx);\r\n end;\r\n\r\n function RoundColor(Value: Double): Integer;\r\n begin\r\n if Value > RGB_MAX then\r\n Result := RGB_MAX\r\n else\r\n Result := Round(Value);\r\n end;\r\n\r\nbegin\r\n SplitColorParts(AColor, Hue, Lightness, Saturation);\r\n\r\n if Saturation = 0 then\r\n begin\r\n Red := (Lightness * RGB_MAX) / HLS_MAX;\r\n Green := Red;\r\n Blue := Red;\r\n end\r\n else\r\n begin\r\n if Lightness <= HLS_MAX_HALF then\r\n Magic2 := (Lightness * (HLS_MAX + Saturation) + HLS_MAX_HALF) / HLS_MAX\r\n else\r\n Magic2 := Lightness + Saturation - ((Lightness * Saturation) + HLS_MAX_HALF) / HLS_MAX;\r\n\r\n Magic1 := 2 * Lightness - Magic2;\r\n\r\n Red := (HueToRGB(Magic1, Magic2, Hue + HLS_MAX_ONE_THIRD) * RGB_MAX + HLS_MAX_HALF) / HLS_MAX;\r\n Green := (HueToRGB(Magic1, Magic2, Hue) * RGB_MAX + HLS_MAX_HALF) / HLS_MAX;\r\n Blue := (HueToRGB(Magic1, Magic2, Hue - HLS_MAX_ONE_THIRD) * RGB_MAX + HLS_MAX_HALF) / HLS_MAX;\r\n end;\r\n\r\n Result := inherited ConvertToColor(\r\n JoinColorParts(RoundColor(Red), RoundColor(Green), RoundColor(Blue)));\r\nend;\r\n\r\nfunction TJvHLSColorSpace.GetAxisDefault(Index: TJvAxisIndex): Byte;\r\nbegin\r\n Result := 120;\r\nend;\r\n\r\nfunction TJvHLSColorSpace.GetAxisMax(Index: TJvAxisIndex): Byte;\r\nbegin\r\n Result := HLS_MAX;\r\nend;\r\n\r\nfunction TJvHLSColorSpace.GetAxisMin(Index: TJvAxisIndex): Byte;\r\nbegin\r\n Result := HLS_MIN;\r\nend;\r\n\r\nfunction TJvHLSColorSpace.GetAxisName(Index: TJvAxisIndex): string;\r\nbegin\r\n case Index of\r\n axIndex0:\r\n Result := RsHLS_Hue;\r\n axIndex1:\r\n Result := RsHLS_Lightness;\r\n axIndex2:\r\n Result := RsHLS_Saturation;\r\n else\r\n Result := inherited GetAxisName(Index);\r\n end;\r\nend;\r\n\r\nfunction TJvHLSColorSpace.GetName: string;\r\nbegin\r\n Result := RsHLS_FullName;\r\nend;\r\n\r\nfunction TJvHLSColorSpace.GetShortName: string;\r\nbegin\r\n Result := RsHLS_ShortName;\r\nend;\r\n\r\n//=== { TJvCMYColorSpace } ===================================================\r\n\r\nfunction TJvCMYColorSpace.ConvertFromColor(AColor: TColor): TJvFullColor;\r\nvar\r\n Red, Green, Blue: Integer;\r\n Cyan, Magenta, Yellow: Integer;\r\nbegin\r\n SplitColorParts(AColor, Red, Green, Blue);\r\n\r\n Cyan := ((RGB_MAX - Red ) * (CMY_MAX-CMY_MIN+1) div (RGB_MAX-RGB_MIN+1)) + CMY_MIN;\r\n Magenta := ((RGB_MAX - Green) * (CMY_MAX-CMY_MIN+1) div (RGB_MAX-RGB_MIN+1)) + CMY_MIN;\r\n Yellow := ((RGB_MAX - Blue ) * (CMY_MAX-CMY_MIN+1) div (RGB_MAX-RGB_MIN+1)) + CMY_MIN;\r\n\r\n Result := inherited ConvertFromColor(JoinColorParts(Cyan, Magenta, Yellow));\r\nend;\r\n\r\nfunction TJvCMYColorSpace.ConvertToColor(AColor: TJvFullColor): TColor;\r\nvar\r\n Cyan, Magenta, Yellow: Integer;\r\n Red, Green, Blue: Integer;\r\nbegin\r\n SplitColorParts(AColor, Cyan, Magenta, Yellow);\r\n\r\n Red := ((CMY_MAX - Cyan ) * (RGB_MAX-RGB_MIN+1) div (CMY_MAX-CMY_MIN+1)) + RGB_MIN;\r\n Green := ((CMY_MAX - Magenta) * (RGB_MAX-RGB_MIN+1) div (CMY_MAX-CMY_MIN+1)) + RGB_MIN;\r\n Blue := ((CMY_MAX - Yellow ) * (RGB_MAX-RGB_MIN+1) div (CMY_MAX-CMY_MIN+1)) + RGB_MIN;\r\n\r\n Result := inherited ConvertToColor(JoinColorParts(Red, Green, Blue));\r\nend;\r\n\r\nfunction TJvCMYColorSpace.GetAxisDefault(Index: TJvAxisIndex): Byte;\r\nbegin\r\n Result := 255;\r\nend;\r\n\r\nfunction TJvCMYColorSpace.GetAxisMax(Index: TJvAxisIndex): Byte;\r\nbegin\r\n Result := CMY_MAX;\r\nend;\r\n\r\nfunction TJvCMYColorSpace.GetAxisMin(Index: TJvAxisIndex): Byte;\r\nbegin\r\n Result := CMY_MIN;\r\nend;\r\n\r\nfunction TJvCMYColorSpace.GetAxisName(Index: TJvAxisIndex): string;\r\nbegin\r\n case Index of\r\n axIndex0:\r\n Result := RsCMY_Cyan;\r\n axIndex1:\r\n Result := RsCMY_Magenta;\r\n axIndex2:\r\n Result := RsCMY_Yellow;\r\n else\r\n Result := inherited GetAxisName(Index);\r\n end;\r\nend;\r\n\r\nfunction TJvCMYColorSpace.GetName: string;\r\nbegin\r\n Result := RsCMY_FullName;\r\nend;\r\n\r\nfunction TJvCMYColorSpace.GetShortName: string;\r\nbegin\r\n Result := RsCMY_ShortName;\r\nend;\r\n\r\n//=== { TJvYUVColorSpace } ===================================================\r\n\r\nfunction TJvYUVColorSpace.ConvertFromColor(AColor: TColor): TJvFullColor;\r\nvar\r\n Y, U, V: Integer;\r\n Red, Green, Blue: Integer;\r\nbegin\r\n SplitColorParts(AColor, Red, Green, Blue);\r\n\r\n Y := Round(0.257*Red + 0.504*Green + 0.098*Blue) + 16;\r\n V := Round(0.439*Red - 0.368*Green - 0.071*Blue) + 128;\r\n U := Round(-0.148*Red - 0.291*Green + 0.439*Blue) + 128;\r\n\r\n Y := EnsureRange(Y, YUV_MIN, YUV_MAX);\r\n U := EnsureRange(U, YUV_MIN, YUV_MAX);\r\n V := EnsureRange(V, YUV_MIN, YUV_MAX);\r\n\r\n Result := inherited ConvertFromColor(JoinColorParts(Y, U, V));\r\nend;\r\n\r\nfunction TJvYUVColorSpace.ConvertToColor(AColor: TJvFullColor): TColor;\r\nvar\r\n Red, Green, Blue: Integer;\r\n Y, U, V: Integer;\r\nbegin\r\n SplitColorParts(AColor, Y, U, V);\r\n\r\n Y := Y - 16;\r\n U := U - 128;\r\n V := V - 128;\r\n\r\n Red := Round(1.164*Y - 0.002*U + 1.596*V);\r\n Green := Round(1.164*Y - 0.391*U - 0.813*V);\r\n Blue := Round(1.164*Y + 2.018*U - 0.001*V);\r\n\r\n Red := EnsureRange(Red , RGB_MIN, RGB_MAX);\r\n Green := EnsureRange(Green, RGB_MIN, RGB_MAX);\r\n Blue := EnsureRange(Blue, RGB_MIN, RGB_MAX);\r\n\r\n Result := inherited ConvertToColor(JoinColorParts(Red, Green, Blue));\r\nend;\r\n\r\nfunction TJvYUVColorSpace.GetAxisDefault(Index: TJvAxisIndex): Byte;\r\nbegin\r\n Result := 128;\r\nend;\r\n\r\nfunction TJvYUVColorSpace.GetAxisMax(Index: TJvAxisIndex): Byte;\r\nbegin\r\n Result := YUV_MAX;\r\nend;\r\n\r\nfunction TJvYUVColorSpace.GetAxisMin(Index: TJvAxisIndex): Byte;\r\nbegin\r\n Result := YUV_MIN;\r\nend;\r\n\r\nfunction TJvYUVColorSpace.GetAxisName(Index: TJvAxisIndex): string;\r\nbegin\r\n case Index of\r\n axIndex0:\r\n Result := RsYUV_Y;\r\n axIndex1:\r\n Result := RsYUV_U;\r\n axIndex2:\r\n Result := RsYUV_V;\r\n else\r\n Result := inherited GetAxisName(Index);\r\n end;\r\nend;\r\n\r\nfunction TJvYUVColorSpace.GetName: string;\r\nbegin\r\n Result := RsYUV_FullName;\r\nend;\r\n\r\nfunction TJvYUVColorSpace.GetShortName: string;\r\nbegin\r\n Result := RsYUV_ShortName;\r\nend;\r\n\r\n//=== { TJvHSVColorSpace } ===================================================\r\n\r\nfunction TJvHSVColorSpace.ConvertFromColor(AColor: TColor): TJvFullColor;\r\nvar\r\n Hue, Saturation, Value: Integer;\r\n Red, Green, Blue: Integer;\r\n ColorMax, ColorMin, ColorDelta: Integer;\r\nbegin\r\n SplitColorParts(AColor, Red, Green, Blue);\r\n\r\n if Red > Green then\r\n ColorMax := Red\r\n else\r\n ColorMax := Green;\r\n if Blue > ColorMax then\r\n ColorMax := Blue;\r\n\r\n if Red < Green then\r\n ColorMin := Red\r\n else\r\n ColorMin := Green;\r\n if Blue < ColorMin then\r\n ColorMin := Blue;\r\n\r\n ColorDelta := ColorMax - ColorMin;\r\n Value := ColorMax;\r\n\r\n if Value = 0 then\r\n Saturation := 0\r\n else\r\n Saturation := (255 * ColorDelta) div Value;\r\n\r\n if Saturation = 0 then\r\n Hue := 0\r\n else\r\n begin\r\n Hue := 0;\r\n if Value = Red then\r\n Hue := (40 * (Green - Blue) div ColorDelta);\r\n if Value = Green then\r\n Hue := (HSV_MAX div 3) + (40 * (Blue - Red) div ColorDelta);\r\n if Value = Blue then\r\n Hue := ((HSV_MAX * 2) div 3) + (40 * (Red - Green) div ColorDelta);\r\n end;\r\n\r\n if Hue < 0 then\r\n Hue := Hue + HSV_MAX;\r\n if Hue > HSV_MAX then\r\n Hue := Hue - HSV_MAX;\r\n\r\n Result := inherited ConvertFromColor(JoinColorParts(Hue, Saturation, Value));\r\nend;\r\n\r\nfunction TJvHSVColorSpace.ConvertToColor(AColor: TJvFullColor): TColor;\r\nvar\r\n Hue, Saturation, Value: Integer;\r\n Red, Green, Blue: Integer;\r\n P, Q, T, Summ, Rest: Integer;\r\nbegin\r\n SplitColorParts(AColor, Hue, Saturation, Value);\r\n\r\n if Saturation = 0 then\r\n begin\r\n Red := Value;\r\n Green := Value;\r\n Blue := Value;\r\n end\r\n else\r\n begin\r\n if Hue = HSV_MAX then\r\n Hue := 0;\r\n\r\n Rest := Hue mod (HSV_MAX div 6);\r\n Hue := Hue div (HSV_MAX div 6);\r\n\r\n Summ := Value * Saturation;\r\n\r\n P := Value - Summ div RGB_MAX;\r\n Q := Value - (Summ * Rest) div (RGB_MAX * (HSV_MAX div 6));\r\n T := Value - (Summ * ((HSV_MAX div 6) - Rest)) div (RGB_MAX * (HSV_MAX div 6));\r\n case Hue of\r\n 0:\r\n begin\r\n Red := Value;\r\n Green := T;\r\n Blue := P;\r\n end;\r\n 1:\r\n begin\r\n Red := Q;\r\n Green := Value;\r\n Blue := P;\r\n end;\r\n 2:\r\n begin\r\n Red := P;\r\n Green := Value;\r\n Blue := T;\r\n end;\r\n 3:\r\n begin\r\n Red := P;\r\n Green := Q;\r\n Blue := Value;\r\n end;\r\n 4:\r\n begin\r\n Red := T;\r\n Green := P;\r\n Blue := Value;\r\n end;\r\n else\r\n Red := Value;\r\n Green := P;\r\n Blue := Q;\r\n end;\r\n end;\r\n\r\n Result := inherited ConvertToColor(JoinColorParts(Red, Green, Blue));\r\nend;\r\n\r\nfunction TJvHSVColorSpace.GetAxisDefault(Index: TJvAxisIndex): Byte;\r\nbegin\r\n case Index of\r\n axIndex0:\r\n Result := 120;\r\n axIndex1:\r\n Result := 240;\r\n else\r\n Result := 150;\r\n end;\r\nend;\r\n\r\nfunction TJvHSVColorSpace.GetAxisMax(Index: TJvAxisIndex): Byte;\r\nbegin\r\n case Index of\r\n axIndex0:\r\n Result := HSV_MAX;\r\n else\r\n Result := RGB_MAX;\r\n end;\r\nend;\r\n\r\nfunction TJvHSVColorSpace.GetAxisMin(Index: TJvAxisIndex): Byte;\r\nbegin\r\n Result := HSV_MIN;\r\nend;\r\n\r\nfunction TJvHSVColorSpace.GetAxisName(Index: TJvAxisIndex): string;\r\nbegin\r\n case Index of\r\n axIndex0:\r\n Result := RsHSV_Hue;\r\n axIndex1:\r\n Result := RsHSV_Saturation;\r\n axIndex2:\r\n Result := RsHSV_Value;\r\n else\r\n Result := inherited GetAxisName(Index);\r\n end;\r\nend;\r\n\r\nfunction TJvHSVColorSpace.GetName: string;\r\nbegin\r\n Result := RsHSV_FullName;\r\nend;\r\n\r\nfunction TJvHSVColorSpace.GetShortName: string;\r\nbegin\r\n Result := RsHSV_ShortName;\r\nend;\r\n\r\n//=== { TJvYIQColorSpace } ===================================================\r\n\r\nfunction TJvYIQColorSpace.ConvertFromColor(AColor: TColor): TJvFullColor;\r\nvar\r\n Y, I, Q: Integer;\r\n Red, Green, Blue: Integer;\r\nbegin\r\n SplitColorParts(AColor, Red, Green, Blue);\r\n\r\n Y := Round(0.299*Red + 0.587*Green + 0.114*Blue);\r\n I := Round(0.596*Red - 0.275*Green - 0.321*Blue) + 128;\r\n Q := Round(0.212*Red - 0.523*Green + 0.311*Blue) + 128;\r\n\r\n Y := EnsureRange(Y, YIQ_MIN, YIQ_MAX);\r\n I := EnsureRange(I, YIQ_MIN, YIQ_MAX);\r\n Q := EnsureRange(Q, YIQ_MIN, YIQ_MAX);\r\n\r\n Result := inherited ConvertFromColor(JoinColorParts(Y, I, Q));\r\nend;\r\n\r\nfunction TJvYIQColorSpace.ConvertToColor(AColor: TJvFullColor): TColor;\r\nvar\r\n Red, Green, Blue: Integer;\r\n Y, I, Q: Integer;\r\nbegin\r\n SplitColorParts(AColor, Y, I, Q);\r\n\r\n //Y := Y;\r\n I := I - 128;\r\n Q := Q - 128;\r\n\r\n Red := Round(Y + 0.956*I + 0.620*Q);\r\n Green := Round(Y - 0.272*I - 0.647*Q);\r\n Blue := Round(Y - 1.108*I + 1.705*Q);\r\n\r\n Red := EnsureRange(Red , RGB_MIN, RGB_MAX);\r\n Green := EnsureRange(Green, RGB_MIN, RGB_MAX);\r\n Blue := EnsureRange(Blue, RGB_MIN, RGB_MAX);\r\n\r\n Result := inherited ConvertToColor(JoinColorParts(Red, Green, Blue));\r\nend;\r\n\r\nfunction TJvYIQColorSpace.GetAxisDefault(Index: TJvAxisIndex): Byte;\r\nbegin\r\n Result := 128;\r\nend;\r\n\r\nfunction TJvYIQColorSpace.GetAxisMax(Index: TJvAxisIndex): Byte;\r\nbegin\r\n Result := YIQ_MAX;\r\nend;\r\n\r\nfunction TJvYIQColorSpace.GetAxisMin(Index: TJvAxisIndex): Byte;\r\nbegin\r\n Result := YIQ_MIN;\r\nend;\r\n\r\nfunction TJvYIQColorSpace.GetAxisName(Index: TJvAxisIndex): string;\r\nbegin\r\n case Index of\r\n axIndex0:\r\n Result := RsYIQ_Y;\r\n axIndex1:\r\n Result := RsYIQ_I;\r\n axIndex2:\r\n Result := RsYIQ_Q;\r\n else\r\n Result := inherited GetAxisName(Index);\r\n end;\r\nend;\r\n\r\nfunction TJvYIQColorSpace.GetName: string;\r\nbegin\r\n Result := RsYIQ_FullName;\r\nend;\r\n\r\nfunction TJvYIQColorSpace.GetShortName: string;\r\nbegin\r\n Result := RsYIQ_ShortName;\r\nend;\r\n\r\n//=== { TJvYCCColorSpace } ===================================================\r\n\r\nfunction TJvYCCColorSpace.ConvertFromColor(AColor: TColor): TJvFullColor;\r\nvar\r\n Y, Cr, Cb: Integer;\r\n Red, Green, Blue: Integer;\r\nbegin\r\n SplitColorParts(AColor, Red, Green, Blue);\r\n\r\n Y := Round( 0.299*Red + 0.587*Green + 0.114*Blue);\r\n Cr := Round(-0.150*Red - 0.293*Green + 0.443*Blue) + 128;\r\n Cb := Round( 0.438*Red - 0.367*Green - 0.071*Blue) + 128;\r\n\r\n Y := EnsureRange(Y, YCC_MIN, YCC_MAX);\r\n Cr := EnsureRange(Cr, YCC_MIN, YCC_MAX);\r\n Cb := EnsureRange(Cb, YCC_MIN, YCC_MAX);\r\n\r\n Result := inherited ConvertFromColor(JoinColorParts(Y, Cr, Cb));\r\nend;\r\n\r\nfunction TJvYCCColorSpace.ConvertToColor(AColor: TJvFullColor): TColor;\r\nvar\r\n Red, Green, Blue: Integer;\r\n Y, Cr, Cb: Integer;\r\nbegin\r\n SplitColorParts(AColor, Y, Cr, Cb);\r\n\r\n Y := Y;\r\n Cr := Cr - 128;\r\n Cb := Cb - 128;\r\n\r\n Red := Round(Y - 0.001*Cr + 1.600*Cb);\r\n Green := Round(Y - 0.388*Cr - 0.816*Cb);\r\n Blue := Round(Y + 2.000*Cr + 0.002*Cb);\r\n\r\n Red := EnsureRange(Red , RGB_MIN, RGB_MAX);\r\n Green := EnsureRange(Green, RGB_MIN, RGB_MAX);\r\n Blue := EnsureRange(Blue, RGB_MIN, RGB_MAX);\r\n\r\n Result := inherited ConvertToColor(JoinColorParts(Red, Green, Blue));\r\nend;\r\n\r\nfunction TJvYCCColorSpace.GetAxisDefault(Index: TJvAxisIndex): Byte;\r\nbegin\r\n Result := 128;\r\nend;\r\n\r\nfunction TJvYCCColorSpace.GetAxisMax(Index: TJvAxisIndex): Byte;\r\nbegin\r\n Result := YCC_MAX;\r\nend;\r\n\r\nfunction TJvYCCColorSpace.GetAxisMin(Index: TJvAxisIndex): Byte;\r\nbegin\r\n Result := YCC_MIN;\r\nend;\r\n\r\nfunction TJvYCCColorSpace.GetAxisName(Index: TJvAxisIndex): string;\r\nbegin\r\n case Index of\r\n axIndex0:\r\n Result := RsYCC_Y;\r\n axIndex1:\r\n Result := RsYCC_Cr;\r\n axIndex2:\r\n Result := RsYCC_Cb;\r\n else\r\n Result := inherited GetAxisName(Index);\r\n end;\r\nend;\r\n\r\nfunction TJvYCCColorSpace.GetName: string;\r\nbegin\r\n Result := RsYCC_FullName;\r\nend;\r\n\r\nfunction TJvYCCColorSpace.GetShortName: string;\r\nbegin\r\n Result := RsYCC_ShortName;\r\nend;\r\n\r\n//=== { TJvXYZColorSpace } ===================================================\r\n\r\nfunction TJvXYZColorSpace.ConvertFromColor(AColor: TColor): TJvFullColor;\r\nvar\r\n X, Y, Z: Integer;\r\n Red, Green, Blue: Integer;\r\nbegin\r\n SplitColorParts(AColor, Red, Green, Blue);\r\n\r\n X := Round( 0.618*Red + 0.177*Green + 0.205*Blue);\r\n Y := Round( 0.299*Red + 0.587*Green + 0.114*Blue);\r\n Z := Round( 0.056*Green + 0.944*Blue);\r\n\r\n X := EnsureRange(X, XYZ_MIN, XYZ_MAX);\r\n Y := EnsureRange(Y, XYZ_MIN, XYZ_MAX);\r\n Z := EnsureRange(Z, XYZ_MIN, XYZ_MAX);\r\n\r\n Result := inherited ConvertFromColor(JoinColorParts(X, Y, Z));\r\nend;\r\n\r\nfunction TJvXYZColorSpace.ConvertToColor(AColor: TJvFullColor): TColor;\r\nvar\r\n Red, Green, Blue: Integer;\r\n X, Y, Z: Integer;\r\nbegin\r\n SplitColorParts(AColor, X, Y, Z);\r\n\r\n Red := Round( 1.876*X - 0.533*Y - 0.343*Z);\r\n Green := Round(-0.967*X + 1.998*Y - 0.031*Z);\r\n Blue := Round( 0.057*X - 0.118*Y + 1.061*Z);\r\n\r\n Red := EnsureRange(Red , RGB_MIN, RGB_MAX);\r\n Green := EnsureRange(Green, RGB_MIN, RGB_MAX);\r\n Blue := EnsureRange(Blue, RGB_MIN, RGB_MAX);\r\n\r\n Result := inherited ConvertToColor(JoinColorParts(Red, Green, Blue));\r\nend;\r\n\r\nfunction TJvXYZColorSpace.GetAxisDefault(Index: TJvAxisIndex): Byte;\r\nbegin\r\n Result := 128;\r\nend;\r\n\r\nfunction TJvXYZColorSpace.GetAxisMax(Index: TJvAxisIndex): Byte;\r\nbegin\r\n Result := XYZ_MAX;\r\nend;\r\n\r\nfunction TJvXYZColorSpace.GetAxisMin(Index: TJvAxisIndex): Byte;\r\nbegin\r\n Result := XYZ_MIN;\r\nend;\r\n\r\nfunction TJvXYZColorSpace.GetAxisName(Index: TJvAxisIndex): string;\r\nbegin\r\n case Index of\r\n axIndex0:\r\n Result := RsXYZ_X;\r\n axIndex1:\r\n Result := RsXYZ_Y;\r\n axIndex2:\r\n Result := RsXYZ_Z;\r\n else\r\n Result := inherited GetAxisName(Index);\r\n end;\r\nend;\r\n\r\nfunction TJvXYZColorSpace.GetName: string;\r\nbegin\r\n Result := RsXYZ_FullName;\r\nend;\r\n\r\nfunction TJvXYZColorSpace.GetShortName: string;\r\nbegin\r\n Result := RsXYZ_ShortName;\r\nend;\r\n\r\n//=== { TJvLABColorSpace } ===================================================\r\n\r\nfunction TJvLABColorSpace.ConvertFromColor(AColor: TColor): TJvFullColor;\r\nvar\r\n X, Y, Z: Extended;\r\n L, A, B: Integer;\r\n Red, Green, Blue: Integer;\r\n\r\n function Calc(Value: Extended): Extended;\r\n begin\r\n if Value > 0.008856 then\r\n Result := Power(Value, 1.0 / 3.0)\r\n else\r\n Result := 7.7787 * Value + (16.0 / 116.0);\r\n end;\r\n\r\nbegin\r\n SplitColorParts(AColor, Red, Green, Blue);\r\n\r\n X := (0.618*Red + 0.177*Green + 0.205*Blue) / XYZ_MAX;\r\n Y := (0.299*Red + 0.587*Green + 0.114*Blue) / XYZ_MAX;\r\n Z := ( 0.056*Green + 0.944*Blue) / XYZ_MAX;\r\n\r\n X := EnsureRange(X, 0.0, 1.0);\r\n Y := EnsureRange(Y, 0.0, 1.0);\r\n Z := EnsureRange(Z, 0.0, 1.0);\r\n\r\n if Y > 0.008856 then\r\n L := Round(116.0 * Power(Y, 1.0 / 3.0) - 16.0)\r\n else\r\n L := Round(903.3 * Y);\r\n A := Round(500.0 *(Calc(X) - Calc(Y)))+128;\r\n B := Round(200.0 *(Calc(Y) - Calc(Z)))+128;\r\n\r\n L := EnsureRange(L, LAB_MIN, LAB_MAX);\r\n A := EnsureRange(A, LAB_MIN, LAB_MAX);\r\n B := EnsureRange(B, LAB_MIN, LAB_MAX);\r\n\r\n Result := inherited ConvertFromColor(JoinColorParts(L, A, B));\r\nend;\r\n\r\nfunction TJvLABColorSpace.ConvertToColor(AColor: TJvFullColor): TColor;\r\nvar\r\n Red, Green, Blue: Integer;\r\n X, Y, Z: Extended;\r\n L, A, B: Integer;\r\n\r\n function Calc(Value: Extended): Extended;\r\n begin\r\n if Value > 0.207 then\r\n Result := Power(Value, 3.0)\r\n else\r\n Result := ((116.0 * Value) - 16.0) / 903.3;\r\n end;\r\n\r\nbegin\r\n SplitColorParts(AColor, L, A, B);\r\n\r\n if L > 8 then\r\n Y := XYZ_MAX * Power((L + 16.0) / 116.0, 3.0)\r\n else\r\n Y := (XYZ_MAX * L) / 903.3;\r\n X := XYZ_MAX * Calc(((A-128) / 500.0) + ((L + 16.0) / 116.0));\r\n Z := XYZ_MAX * Calc(((L + 16.0) / 116.0) - ((B-128) / 200.0));\r\n\r\n X := EnsureRange(X, XYZ_MIN, XYZ_MAX);\r\n Y := EnsureRange(Y, XYZ_MIN, XYZ_MAX);\r\n Z := EnsureRange(Z, XYZ_MIN, XYZ_MAX);\r\n\r\n Red := Round( 1.876*X - 0.533*Y - 0.343*Z);\r\n Green := Round(-0.967*X + 1.998*Y - 0.031*Z);\r\n Blue := Round( 0.057*X - 0.118*Y + 1.061*Z);\r\n\r\n Red := EnsureRange(Red , RGB_MIN, RGB_MAX);\r\n Green := EnsureRange(Green, RGB_MIN, RGB_MAX);\r\n Blue := EnsureRange(Blue, RGB_MIN, RGB_MAX);\r\n\r\n Result := inherited ConvertToColor(JoinColorParts(Red, Green, Blue));\r\nend;\r\n\r\nfunction TJvLABColorSpace.GetAxisDefault(Index: TJvAxisIndex): Byte;\r\nbegin\r\n Result := 50;\r\nend;\r\n\r\nfunction TJvLABColorSpace.GetAxisMax(Index: TJvAxisIndex): Byte;\r\nbegin\r\n Result := LAB_MAX;\r\nend;\r\n\r\nfunction TJvLABColorSpace.GetAxisMin(Index: TJvAxisIndex): Byte;\r\nbegin\r\n Result := LAB_MIN;\r\nend;\r\n\r\nfunction TJvLABColorSpace.GetAxisName(Index: TJvAxisIndex): string;\r\nbegin\r\n case Index of\r\n axIndex0:\r\n Result := RsLAB_L;\r\n axIndex1:\r\n Result := RsLAB_A;\r\n axIndex2:\r\n Result := RsLAB_B;\r\n else\r\n Result := inherited GetAxisName(Index);\r\n end;\r\nend;\r\n\r\nfunction TJvLABColorSpace.GetName: string;\r\nbegin\r\n Result := RsLAB_FullName;\r\nend;\r\n\r\nfunction TJvLABColorSpace.GetShortName: string;\r\nbegin\r\n Result := RsLAB_ShortName;\r\nend;\r\n\r\n//=== { TJvDEFColorSpace } ===================================================\r\n\r\nconstructor TJvDEFColorSpace.Create(ColorID: TJvFullColorSpaceID);\r\nbegin\r\n inherited Create(ColorID);\r\n FDelphiColors := TStringList.Create;\r\n // ignore duplicates\r\n FDelphiColors.Duplicates := dupIgnore;\r\n GetColorValues(GetColorValuesCallBack);\r\n AddDelphiColor(clNone);\r\nend;\r\n\r\ndestructor TJvDEFColorSpace.Destroy;\r\nbegin\r\n FDelphiColors.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvDEFColorSpace.GetColorValuesCallBack(const S: string);\r\nvar\r\n AColor: TColor;\r\nbegin\r\n AColor := StringToColor(S);\r\n AddCustomColor(AColor,Copy(S,3,Length(S)-2),ColorToPrettyName(AColor));\r\nend;\r\n\r\nprocedure TJvDEFColorSpace.AddDelphiColor(Value: TColor);\r\nbegin\r\n AddCustomColor(Value,ColorToString(Value),ColorToPrettyName(Value));\r\nend;\r\n\r\nprocedure TJvDEFColorSpace.AddCustomColor(AColor: TColor; ShortName,\r\n PrettyName: string);\r\nbegin\r\n if FDelphiColors.IndexOfObject(TObject(AColor)) = -1 then\r\n begin\r\n FDelphiColors.Values[ShortName] := PrettyName;\r\n FDelphiColors.Objects[FDelphiColors.IndexOfName(ShortName)] := TObject(AColor);\r\n end;\r\nend;\r\n\r\nfunction TJvDEFColorSpace.ConvertFromColor(AColor: TColor): TJvFullColor;\r\nvar\r\n I: Integer;\r\n NewColor: TColor;\r\nbegin\r\n NewColor := clNone;\r\n for I := 0 to FDelphiColors.Count - 1 do\r\n if AColor = TColor(FDelphiColors.Objects[I]) then\r\n begin\r\n NewColor := AColor;\r\n Break;\r\n end;\r\n\r\n Result := inherited ConvertFromColor(NewColor);\r\n\r\n if NewColor = clNone then\r\n // mark it as clNone\r\n Result := Result or JvSpecialFullColorMask\r\n else\r\n if NewColor = clDefault then\r\n // mark it as clDefault\r\n Result := Result or JvSpecialFullColorMask\r\n else\r\n if (NewColor and JvSystemColorMask) = JvSystemColorMask then\r\n // mark it as predefined color\r\n Result := Result or JvSystemFullColorMask\r\n\r\n else\r\n if (NewColor and JvSystemColorMask) = 0 then\r\n Result := ColorSpaceManager.ColorSpace[csRGB].ConvertFromColor(NewColor)\r\n // should never happend because there should be no way ...\r\n else\r\n raise EJvColorSpaceError.CreateResFmt(@RsEInconvertibleColor, [Cardinal(NewColor)]);\r\nend;\r\n\r\nfunction TJvDEFColorSpace.ConvertToColor(AColor: TJvFullColor): TColor;\r\nbegin\r\n Result := inherited ConvertToColor(AColor);\r\n case AColor and JvSubFullColorMask of\r\n JvSystemFullColorMask:\r\n Result := Cardinal(Result) or JvSystemColorMask;\r\n JvSpecialFullColorMask:\r\n begin\r\n if Result = (clNone and $FFFFFF) then\r\n Result := clNone\r\n else\r\n if Result = (clDefault and $FFFFFF) then\r\n Result := clDefault\r\n else\r\n raise EJvColorSpaceError.CreateResFmt(@RsEInconvertibleColor, [Cardinal(AColor)]);\r\n end;\r\n else\r\n raise EJvColorSpaceError.CreateResFmt(@RsEInconvertibleColor, [Cardinal(AColor)]);\r\n end;\r\nend;\r\n\r\nfunction TJvDEFColorSpace.GetColorName(Index: Integer): string;\r\nbegin\r\n if (Index >= 0) and (Index < FDelphiColors.Count) then\r\n Result := FDelphiColors.Names[Index]\r\n else\r\n Result := '';\r\nend;\r\n\r\nfunction TJvDEFColorSpace.GetPrettyName(Index: Integer): string;\r\nbegin\r\n Result := FDelphiColors.Values[FDelphiColors.Names[Index]];\r\nend;\r\n\r\nfunction TJvDEFColorSpace.GetColorValue(Index: Integer): TColor;\r\nbegin\r\n if (Index >= 0) and (Index < FDelphiColors.Count) then\r\n Result := TColor(FDelphiColors.Objects[Index])\r\n else\r\n Result := clNone;\r\nend;\r\n\r\nfunction TJvDEFColorSpace.GetName: string;\r\nbegin\r\n Result := RsDEF_FullName;\r\nend;\r\n\r\nfunction TJvDEFColorSpace.GetShortName: string;\r\nbegin\r\n Result := RsDEF_ShortName;\r\nend;\r\n\r\nfunction TJvDEFColorSpace.GetNumberOfColors: Cardinal;\r\nbegin\r\n Result := FDelphiColors.Count;\r\nend;\r\n\r\n//=== { TJvColorSpaceManager } ===============================================\r\n\r\nconstructor TJvColorSpaceManager.Create;\r\nbegin\r\n inherited Create;\r\n FColorSpaceList := TList.Create;\r\nend;\r\n\r\ndestructor TJvColorSpaceManager.Destroy;\r\nvar\r\n Index: Integer;\r\nbegin\r\n for Index := 0 to FColorSpaceList.Count - 1 do\r\n TJvColorSpace(FColorSpaceList.Items[Index]).Free;\r\n FColorSpaceList.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJvColorSpaceManager.ConvertToID(AColor: TJvFullColor;\r\n DestID: TJvFullColorSpaceID): TJvFullColor;\r\nvar\r\n SourceID: TJvFullColorSpaceID;\r\n Color: TColor;\r\nbegin\r\n SourceID := GetColorSpaceID(AColor);\r\n if SourceID = DestID then\r\n Result := AColor\r\n else\r\n begin\r\n Color := ColorToRGB(ColorSpace[SourceID].ConvertToColor(AColor));\r\n Result := ColorSpace[DestID].ConvertFromColor(Color);\r\n end;\r\nend;\r\n\r\nfunction TJvColorSpaceManager.ConvertToColor(AColor: TJvFullColor): TColor;\r\nbegin\r\n Result := ColorSpace[GetColorSpaceID(AColor)].ConvertToColor(AColor);\r\nend;\r\n\r\nfunction TJvColorSpaceManager.ConvertFromColor(AColor: TColor): TJvFullColor;\r\nvar\r\n MaskedColor:Cardinal;\r\nbegin\r\n MaskedColor := Cardinal(AColor) and JvSystemColorMask;\r\n if (AColor = clNone) or (AColor = clDefault) or\r\n (MaskedColor = JvSystemColorMask) then\r\n Result := ColorSpace[csDEF].ConvertFromColor(AColor)\r\n else\r\n if MaskedColor = 0 then\r\n Result := ColorSpace[csRGB].ConvertFromColor(AColor)\r\n else\r\n raise EJvColorSpaceError.CreateResFmt(@RsEInconvertibleColor, [Cardinal(AColor)]);\r\nend;\r\n\r\nfunction TJvColorSpaceManager.GetColorSpaceID(AColor: TJvFullColor): TJvFullColorSpaceID;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := TJvFullColorSpaceID(AColor shr 24) and csID_MASK;\r\n for I := 0 to Count - 1 do\r\n if ColorSpaceByIndex[I].ID = Result then\r\n Exit;\r\n raise EJvColorSpaceError.CreateResFmt(@RsEIllegalID, [Ord(Result)]);\r\nend;\r\n\r\nfunction TJvColorSpaceManager.GetColorSpace(ID: TJvFullColorSpaceID): TJvColorSpace;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := nil;\r\n for I := 0 to FColorSpaceList.Count - 1 do\r\n begin\r\n Result := TJvColorSpace(FColorSpaceList.Items[I]);\r\n if Result.ID = ID then\r\n Break;\r\n end;\r\n if Result = nil then\r\n raise EJvColorSpaceError.CreateResFmt(@RsECSNotFound, [Ord(ID)]);\r\nend;\r\n\r\nfunction TJvColorSpaceManager.GetCount: Integer;\r\nbegin\r\n Result := FColorSpaceList.Count;\r\nend;\r\n\r\nfunction TJvColorSpaceManager.GetColorSpaceByIndex(Index: Integer): TJvColorSpace;\r\nbegin\r\n Result := TJvColorSpace(FColorSpaceList.Items[Index]);\r\nend;\r\n\r\nprocedure TJvColorSpaceManager.RegisterColorSpace(NewColorSpace: TJvColorSpace);\r\nvar\r\n Index: Integer;\r\n CS: TJvColorSpace;\r\nbegin\r\n for Index := 0 to FColorSpaceList.Count - 1 do\r\n begin\r\n CS := TJvColorSpace(FColorSpaceList.Items[Index]);\r\n if CS.ID = NewColorSpace.ID then\r\n raise EJvColorSpaceError.CreateResFmt(@RsECSAlreadyExists, [CS.ID, CS.Name]);\r\n end;\r\n FColorSpaceList.Add(Pointer(NewColorSpace));\r\nend;\r\n\r\nprocedure TJvColorSpaceManager.UnRegisterColorSpace(AColorSpace: TJvColorSpace);\r\nbegin\r\n // maybe more than one instance of one class\r\n while FColorSpaceList.Remove(AColorSpace) >= 0 do\r\n ;\r\nend;\r\n\r\ninitialization\r\n {$IFDEF UNITVERSIONING}\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n {$ENDIF UNITVERSIONING}\r\n\r\nfinalization\r\n FreeAndNil(GlobalColorSpaceManager);\r\n {$IFDEF UNITVERSIONING}\r\n UnregisterUnitVersion(HInstance);\r\n {$ENDIF UNITVERSIONING}\r\n\r\nend." }, { "path": "External/Jedi/Jvcl/run/JvGIF.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvGIF.PAS, released on 2002-07-04.\r\n\r\nThe Initial Developers of the Original Code are: Fedor Koshevnikov, Igor Pavluk and Serge Korolev\r\nCopyright (c) 1997, 1998 Fedor Koshevnikov, Igor Pavluk and Serge Korolev\r\nCopyright (c) 2001,2002 SGB Software\r\nAll Rights Reserved.\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n GIF support is native for VisualCLX so this file is VCL only\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvGIF.pas 13164 2011-11-08 20:23:45Z ahuser $\r\n\r\nunit JvGIF;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, RTLConsts, SysUtils, Classes, Graphics, Controls;\r\n\r\nconst\r\n RT_GIF = 'GIF'; { GIF Resource Type }\r\n\r\ntype\r\n TGIFVersion = (gvUnknown, gv87a, gv89a);\r\n TGIFBits = 1..8;\r\n TDisposalMethod = (dmUndefined, dmLeave, dmRestoreBackground,\r\n dmRestorePrevious, dmReserved4, dmReserved5, dmReserved6, dmReserved7);\r\n\r\n TGIFColorItem = packed record\r\n Red: Byte;\r\n Green: Byte;\r\n Blue: Byte;\r\n end;\r\n\r\n TGIFColorTable = packed record\r\n Count: Integer;\r\n Colors: packed array [Byte] of TGIFColorItem;\r\n end;\r\n\r\n TJvGIFFrame = class;\r\n TGIFData = class;\r\n TGIFItem = class;\r\n\r\n TJvGIFImage = class(TGraphic)\r\n private\r\n FImage: TGIFData;\r\n FVersion: TGIFVersion;\r\n FItems: TList;\r\n FFrameIndex: Integer;\r\n FScreenWidth: Word;\r\n FScreenHeight: Word;\r\n FBackgroundColor: TColor;\r\n FLooping: Boolean;\r\n FCorrupted: Boolean;\r\n FRepeatCount: Word;\r\n function GetBitmap: TBitmap;\r\n function GetCount: Integer;\r\n function GetComment: TStrings;\r\n function GetScreenWidth: Integer;\r\n function GetScreenHeight: Integer;\r\n function GetGlobalColorCount: Integer;\r\n procedure UpdateScreenSize;\r\n procedure SetComment(Value: TStrings);\r\n function GetFrame(Index: Integer): TJvGIFFrame;\r\n procedure SetFrameIndex(Value: Integer);\r\n procedure SetBackgroundColor(Value: TColor);\r\n procedure SetLooping(Value: Boolean);\r\n procedure SetRepeatCount(Value: Word);\r\n procedure ReadSignature(Stream: TStream);\r\n procedure DoProgress(Stage: TProgressStage; PercentDone: Byte;\r\n const Msg: string);\r\n function GetCorrupted: Boolean;\r\n function GetTransparentColor: TColor;\r\n function GetBackgroundColor: TColor;\r\n function GetPixelFormat: TPixelFormat;\r\n procedure EncodeFrames(ReverseDecode: Boolean);\r\n procedure ReadStream(Size: Longint; Stream: TStream; ForceDecode: Boolean);\r\n procedure WriteStream(Stream: TStream; WriteSize: Boolean);\r\n protected\r\n procedure AssignTo(Dest: TPersistent); override;\r\n procedure Draw(ACanvas: TCanvas; const ARect: TRect); override;\r\n function Equals(Graphic: TGraphic): Boolean; override;\r\n function GetEmpty: Boolean; override;\r\n function GetHeight: Integer; override;\r\n function GetWidth: Integer; override;\r\n function GetPalette: HPALETTE; override;\r\n function GetTransparent: Boolean; override;\r\n procedure ClearItems;\r\n procedure NewImage;\r\n procedure UniqueImage;\r\n procedure ReadData(Stream: TStream); override;\r\n procedure SetHeight(Value: Integer); override;\r\n procedure SetWidth(Value: Integer); override;\r\n procedure WriteData(Stream: TStream); override;\r\n property Bitmap: TBitmap read GetBitmap; { volatile }\r\n public\r\n constructor Create; override;\r\n destructor Destroy; override;\r\n procedure Clear;\r\n procedure DecodeAllFrames;\r\n procedure EncodeAllFrames;\r\n procedure Assign(Source: TPersistent); override;\r\n procedure LoadFromStream(Stream: TStream); override;\r\n procedure SaveToStream(Stream: TStream); override;\r\n procedure LoadFromClipboardFormat(AFormat: Word; AData: THandle;\r\n APalette: HPALETTE); override;\r\n procedure SaveToClipboardFormat(var AFormat: Word; var AData: THandle;\r\n var APalette: HPALETTE); override;\r\n procedure LoadFromResourceName(Instance: THandle; const ResName: string;\r\n ResType: PChar);\r\n procedure LoadFromResourceID(Instance: THandle; ResID: Integer;\r\n ResType: PChar);\r\n function AddFrame(Value: TGraphic): Integer; virtual;\r\n procedure DeleteFrame(Index: Integer);\r\n procedure MoveFrame(CurIndex, NewIndex: Integer);\r\n procedure Grayscale(ForceEncoding: Boolean);\r\n property BackgroundColor: TColor read GetBackgroundColor write SetBackgroundColor;\r\n property Comment: TStrings read GetComment write SetComment;\r\n property Corrupted: Boolean read GetCorrupted;\r\n property Count: Integer read GetCount;\r\n property Frames[Index: Integer]: TJvGIFFrame read GetFrame; default;\r\n property FrameIndex: Integer read FFrameIndex write SetFrameIndex;\r\n property GlobalColorCount: Integer read GetGlobalColorCount;\r\n property Looping: Boolean read FLooping write SetLooping;\r\n property PixelFormat: TPixelFormat read GetPixelFormat;\r\n property RepeatCount: Word read FRepeatCount write SetRepeatCount;\r\n property ScreenWidth: Integer read GetScreenWidth;\r\n property ScreenHeight: Integer read GetScreenHeight;\r\n property TransparentColor: TColor read GetTransparentColor;\r\n property Version: TGIFVersion read FVersion;\r\n end;\r\n\r\n TJvGIFFrame = class(TPersistent)\r\n private\r\n FOwner: TJvGIFImage;\r\n FBitmap: TBitmap;\r\n FImage: TGIFItem;\r\n FExtensions: TList;\r\n FTopLeft: TPoint;\r\n FInterlaced: Boolean;\r\n FCorrupted: Boolean;\r\n FGrayscale: Boolean;\r\n FTransparentColor: TColor;\r\n FAnimateInterval: Word;\r\n FDisposal: TDisposalMethod;\r\n FLocalColors: Boolean;\r\n function GetBitmap: TBitmap;\r\n function GetHeight: Integer;\r\n function GetWidth: Integer;\r\n function GetColorCount: Integer;\r\n function FindComment(ForceCreate: Boolean): TStrings;\r\n function GetComment: TStrings;\r\n procedure SetComment(Value: TStrings);\r\n procedure SetTransparentColor(Value: TColor);\r\n procedure SetDisposalMethod(Value: TDisposalMethod);\r\n procedure SetAnimateInterval(Value: Word);\r\n procedure SetTopLeft(const Value: TPoint);\r\n procedure NewBitmap;\r\n procedure NewImage;\r\n procedure SaveToBitmapStream(Stream: TMemoryStream);\r\n procedure EncodeBitmapStream(Stream: TMemoryStream);\r\n procedure EncodeRasterData;\r\n procedure UpdateExtensions;\r\n procedure WriteImageDescriptor(Stream: TStream);\r\n procedure WriteLocalColorMap(Stream: TStream);\r\n procedure WriteRasterData(Stream: TStream);\r\n protected\r\n constructor Create(AOwner: TJvGIFImage); virtual;\r\n procedure LoadFromStream(Stream: TStream);\r\n procedure AssignTo(Dest: TPersistent); override;\r\n procedure GrayscaleImage(ForceEncoding: Boolean);\r\n public\r\n destructor Destroy; override;\r\n procedure Assign(Source: TPersistent); override;\r\n procedure Draw(ACanvas: TCanvas; const ARect: TRect;\r\n Transparent: Boolean);\r\n property AnimateInterval: Word read FAnimateInterval write SetAnimateInterval;\r\n property Bitmap: TBitmap read GetBitmap; { volatile }\r\n property ColorCount: Integer read GetColorCount;\r\n property Comment: TStrings read GetComment write SetComment;\r\n property DisposalMethod: TDisposalMethod read FDisposal write SetDisposalMethod;\r\n property Interlaced: Boolean read FInterlaced;\r\n property Corrupted: Boolean read FCorrupted;\r\n property TransparentColor: TColor read FTransparentColor write SetTransparentColor;\r\n property Origin: TPoint read FTopLeft write SetTopLeft;\r\n property Height: Integer read GetHeight;\r\n property Width: Integer read GetWidth;\r\n end;\r\n\r\n TGIFData = class(TSharedImage)\r\n private\r\n FComment: TStringList;\r\n FAspectRatio: Byte;\r\n FBitsPerPixel: Byte;\r\n FColorResBits: Byte;\r\n FColorMap: TGIFColorTable;\r\n protected\r\n procedure FreeHandle; override;\r\n public\r\n constructor Create;\r\n destructor Destroy; override;\r\n end;\r\n\r\n TGIFItem = class(TSharedImage)\r\n private\r\n FImageData: TMemoryStream;\r\n FSize: TPoint;\r\n FPackedFields: Byte;\r\n FBitsPerPixel: Byte;\r\n FColorMap: TGIFColorTable;\r\n protected\r\n procedure FreeHandle; override;\r\n public\r\n destructor Destroy; override;\r\n end;\r\n\r\nvar\r\n CF_JVGIF: UINT; { Clipboard format for GIF image }\r\n\r\n{ Load incomplete or corrupted images without exceptions }\r\n\r\n// (rom) changed to var to allow changes\r\nvar\r\n GIFLoadCorrupted: Boolean = True;\r\n\r\nfunction GIFVersionName(Version: TGIFVersion): string;\r\nprocedure JvGif_Dummy;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvGIF.pas $';\r\n Revision: '$Revision: 13164 $';\r\n Date: '$Date: 2011-11-08 21:23:45 +0100 (mar. 08 nov. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n Consts, Math,\r\n JvJCLUtils, JvJVCLUtils, JvAni, JvConsts, JvResources, JvTypes;\r\n\r\n{$RANGECHECKS OFF}\r\n\r\nprocedure JvGif_Dummy;\r\nbegin\r\nend;\r\n\r\nprocedure GifError(const Msg: string);\r\n\r\n procedure ThrowException(const Msg: string; ReturnAddr: Pointer);\r\n begin\r\n raise EInvalidGraphicOperation.Create(Msg) at ReturnAddr;\r\n end;\r\n\r\nasm\r\n {$IFDEF CPU32}\r\n pop edx\r\n {$ENDIF CPU32}\r\n {$IFDEF CPU64}\r\n pop rdx\r\n {$ENDIF CPU64}\r\n jmp ThrowException\r\nend;\r\n\r\n{$IFDEF RANGECHECKS_ON}\r\n{$RANGECHECKS ON}\r\n{$ENDIF RANGECHECKS_ON}\r\n\r\n//=== { TSharedImage } =======================================================\r\n\r\ntype\r\n TGifSignature = array [0..2] of AnsiChar;\r\n\r\nconst\r\n GIFSignature: TGifSignature = 'GIF';\r\n GIFVersionStr: array [TGIFVersion] of TGifSignature = (#0#0#0, '87a', '89a');\r\n\r\nfunction GIFVersionName(Version: TGIFVersion): string;\r\nbegin\r\n Result := string(GIFVersionStr[Version]);\r\nend;\r\n\r\nconst\r\n CODE_TABLE_SIZE = 4096;\r\n HASH_TABLE_SIZE = 17777;\r\n MAX_LOOP_COUNT = 30000;\r\n\r\n CHR_EXT_INTRODUCER = '!';\r\n CHR_IMAGE_SEPARATOR = ',';\r\n CHR_TRAILER = ';'; { indicates the end of the GIF Data stream }\r\n\r\n { Image descriptor bit masks }\r\n ID_LOCAL_COLOR_TABLE = $80; { set if a local color table follows }\r\n ID_INTERLACED = $40; { set if image is interlaced }\r\n ID_SORT = $20; { set if color table is sorted }\r\n ID_RESERVED = $0C; { reserved - must be set to $00 }\r\n ID_COLOR_TABLE_SIZE = $07; { Size of color table as above }\r\n\r\n { Logical screen descriptor packed field masks }\r\n LSD_GLOBAL_COLOR_TABLE = $80; { set if global color table follows L.S.D. }\r\n LSD_COLOR_RESOLUTION = $70; { Color resolution - 3 bits }\r\n LSD_SORT = $08; { set if global color table is sorted - 1 bit }\r\n LSD_COLOR_TABLE_SIZE = $07; { Size of global color table - 3 bits }\r\n { Actual Size = 2^value+1 - value is 3 bits }\r\n\r\n { Graphic control extension packed field masks }\r\n GCE_TRANSPARENT = $01; { whether a transparency Index is given }\r\n GCE_USER_INPUT = $02; { whether or not user input is expected }\r\n GCE_DISPOSAL_METHOD = $1C; { the way in which the graphic is to be treated after being displayed }\r\n GCE_RESERVED = $E0; { reserved - must be set to $00 }\r\n\r\n { Application extension }\r\n AE_LOOPING = $01; { looping Netscape extension }\r\n\r\n GIFColors: array [TGIFBits] of Word = (2, 4, 8, 16, 32, 64, 128, 256);\r\n\r\nfunction ColorsToBits(ColorCount: Word): Byte;\r\nvar\r\n I: TGIFBits;\r\nbegin\r\n Result := 0;\r\n for I := Low(TGIFBits) to High(TGIFBits) do\r\n if ColorCount = GIFColors[I] then\r\n begin\r\n Result := I;\r\n Exit;\r\n end;\r\n GifError(RsEWrongGIFColors);\r\nend;\r\n\r\nfunction ColorsToPixelFormat(Colors: Word): TPixelFormat;\r\nbegin\r\n if Colors <= 2 then\r\n Result := pf1bit\r\n else\r\n if Colors <= 16 then\r\n Result := pf4bit\r\n else\r\n if Colors <= 256 then\r\n Result := pf8bit\r\n else\r\n Result := pf24bit;\r\nend;\r\n\r\nfunction ItemToRGB(Item: TGIFColorItem): Longint;\r\nbegin\r\n with Item do\r\n Result := RGB(Red, Green, Blue);\r\nend;\r\n\r\nfunction GrayColor(Color: TColor): TColor;\r\nvar\r\n Index: Integer;\r\nbegin\r\n Index := Byte(Longint(Word(GetRValue(Color)) * 77 +\r\n Word(GetGValue(Color)) * 150 + Word(GetBValue(Color)) * 29) shr 8);\r\n Result := RGB(Index, Index, Index);\r\nend;\r\n\r\nprocedure GrayColorTable(var ColorTable: TGIFColorTable);\r\nvar\r\n I: Byte;\r\n Index: Integer;\r\nbegin\r\n for I := 0 to ColorTable.Count - 1 do\r\n begin\r\n with ColorTable.Colors[I] do\r\n begin\r\n Index := Byte(Longint(Word(Red) * 77 + Word(Green) * 150 + Word(Blue) * 29) shr 8);\r\n Red := Index;\r\n Green := Index;\r\n Blue := Index;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction FindColorIndex(const ColorTable: TGIFColorTable;\r\n Color: TColor): Integer;\r\nbegin\r\n if Color <> clNone then\r\n for Result := 0 to ColorTable.Count - 1 do\r\n if ItemToRGB(ColorTable.Colors[Result]) = ColorToRGB(Color) then\r\n Exit;\r\n Result := -1;\r\nend;\r\n\r\n{ The following types and function declarations are used to call into\r\n functions of the GIF implementation of the GIF image\r\n compression/decompression standard. }\r\n\r\ntype\r\n TGIFHeader = packed record\r\n Signature: TGifSignature; { contains 'GIF' }\r\n Version: TGifSignature; { '87a' or '89a' }\r\n end;\r\n\r\n TScreenDescriptor = packed record\r\n ScreenWidth: Word; { logical screen width }\r\n ScreenHeight: Word; { logical screen height }\r\n PackedFields: Byte;\r\n BackgroundColorIndex: Byte; { Index to global color table }\r\n AspectRatio: Byte; { actual ratio = (AspectRatio + 15) / 64 }\r\n end;\r\n\r\n TImageDescriptor = packed record\r\n ImageLeftPos: Word; { column in pixels in respect to left of logical screen }\r\n ImageTopPos: Word; { row in pixels in respect to top of logical screen }\r\n ImageWidth: Word; { width of image in pixels }\r\n ImageHeight: Word; { height of image in pixels }\r\n PackedFields: Byte;\r\n end;\r\n\r\n{ GIF Extensions support }\r\n\r\ntype\r\n TExtensionType = (etGraphic, etPlainText, etApplication, etComment);\r\n\r\nconst\r\n ExtLabels: array [TExtensionType] of Byte = ($F9, $01, $FF, $FE);\r\n LoopExtNS: string[11] = 'NETSCAPE2.0';\r\n LoopExtAN: string[11] = 'ANIMEXTS1.0';\r\n\r\ntype\r\n TGraphicControlExtension = packed record\r\n BlockSize: Byte; { should be 4 }\r\n PackedFields: Byte;\r\n DelayTime: Word; { in centiseconds }\r\n TransparentColorIndex: Byte;\r\n Terminator: Byte;\r\n end;\r\n\r\n TPlainTextExtension = packed record\r\n BlockSize: Byte; { should be 12 }\r\n Left: Word;\r\n Top: Word;\r\n Width: Word;\r\n Height: Word;\r\n CellWidth: Byte;\r\n CellHeight: Byte;\r\n FGColorIndex: Byte;\r\n BGColorIndex: Byte;\r\n end;\r\n\r\n TAppExtension = packed record\r\n BlockSize: Byte; { should be 11 }\r\n AppId: array [1..8] of Byte;\r\n Authentication: array [1..3] of Byte;\r\n end;\r\n\r\n TExtensionRecord = packed record\r\n case ExtensionType: TExtensionType of\r\n etGraphic:\r\n (GCE: TGraphicControlExtension);\r\n etPlainText:\r\n (PTE: TPlainTextExtension);\r\n etApplication:\r\n (APPE: TAppExtension);\r\n end;\r\n\r\n//=== { TExtension } =========================================================\r\n\r\ntype\r\n TExtension = class(TPersistent)\r\n private\r\n FExtType: TExtensionType;\r\n FData: TStringList;\r\n FExtRec: TExtensionRecord;\r\n public\r\n destructor Destroy; override;\r\n procedure Assign(Source: TPersistent); override;\r\n function IsLoopExtension: Boolean;\r\n end;\r\n\r\ndestructor TExtension.Destroy;\r\nbegin\r\n FData.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TExtension.Assign(Source: TPersistent);\r\nbegin\r\n if (Source <> nil) and (Source is TExtension) then\r\n begin\r\n FExtType := TExtension(Source).FExtType;\r\n FExtRec := TExtension(Source).FExtRec;\r\n if TExtension(Source).FData <> nil then\r\n begin\r\n if FData = nil then\r\n FData := TStringList.Create;\r\n FData.Assign(TExtension(Source).FData);\r\n end;\r\n end\r\n else\r\n inherited Assign(Source);\r\nend;\r\n\r\nfunction TExtension.IsLoopExtension: Boolean;\r\nbegin\r\n Result := (FExtType = etApplication) and (FData.Count > 0) and\r\n (CompareMem(@FExtRec.APPE.AppId, @LoopExtNS[1], FExtRec.APPE.BlockSize) or\r\n CompareMem(@FExtRec.APPE.AppId, @LoopExtAN[1], FExtRec.APPE.BlockSize)) and\r\n (Length(FData[0]) >= 3) and (Byte(FData[0][1]) = AE_LOOPING);\r\nend;\r\n\r\nprocedure FreeExtensions(Extensions: TList); near;\r\nbegin\r\n if Extensions <> nil then\r\n begin\r\n while Extensions.Count > 0 do\r\n begin\r\n TObject(Extensions[0]).Free;\r\n Extensions.Delete(0);\r\n end;\r\n Extensions.Free;\r\n end;\r\nend;\r\n\r\nfunction FindExtension(Extensions: TList; ExtType: TExtensionType): TExtension;\r\nvar\r\n I: Integer;\r\nbegin\r\n if Extensions <> nil then\r\n for I := Extensions.Count - 1 downto 0 do\r\n begin\r\n Result := TExtension(Extensions[I]);\r\n if (Result <> nil) and (Result.FExtType = ExtType) then\r\n Exit;\r\n end;\r\n Result := nil;\r\nend;\r\n\r\n{\r\nfunction CopyExtensions(Source: TList): TList; near;\r\nvar\r\n I: Integer;\r\n Ext: TExtension;\r\nbegin\r\n Result := TList.Create;\r\n try\r\n for I := 0 to Source.Count - 1 do\r\n if (Source[I] <> nil) and (TObject(Source[I]) is TExtension) then\r\n begin\r\n Ext := TExtension.Create;\r\n try\r\n Ext.Assign(Source[I]);\r\n Result.Add(Ext);\r\n except\r\n Ext.Free;\r\n raise;\r\n end;\r\n end;\r\n except\r\n Result.Free;\r\n raise;\r\n end;\r\nend;\r\n}\r\n\r\ntype\r\n TProgressProc = procedure(Stage: TProgressStage; PercentDone: Byte;\r\n const Msg: string) of object;\r\n\r\n{ GIF reading/writing routines\r\n\r\n Procedures to read and write GIF files, GIF-decoding and encoding\r\n based on freeware C source code of GBM package by Andy Key\r\n (nyangau att interalpha dott co dott uk). The home page of GBM author is\r\n at http://www.interalpha.net/customer/nyangau/. }\r\n\r\ntype\r\n PIntCodeTable = ^TIntCodeTable;\r\n TIntCodeTable = array [0..CODE_TABLE_SIZE - 1] of Word;\r\n\r\n PReadContext = ^TReadContext;\r\n TReadContext = record\r\n Inx: Longint;\r\n Size: Longint;\r\n Buf: array [0..255 + 4] of Byte;\r\n CodeSize: Longint;\r\n ReadMask: Longint;\r\n end;\r\n\r\n PWriteContext = ^TWriteContext;\r\n TWriteContext = record\r\n Inx: Longint;\r\n CodeSize: Longint;\r\n Buf: array [0..255 + 4] of Byte;\r\n end;\r\n\r\n TOutputContext = record\r\n W: Longint;\r\n H: Longint;\r\n X: Longint;\r\n Y: Longint;\r\n BitsPerPixel: Integer;\r\n Pass: Integer;\r\n Interlace: Boolean;\r\n LineIdent: Longint;\r\n Data: Pointer;\r\n CurrLineData: Pointer;\r\n end;\r\n\r\n PImageDict = ^TImageDict;\r\n TImageDict = record\r\n Tail: Word;\r\n Index: Word;\r\n Col: Byte;\r\n end;\r\n\r\n PDictTable = ^TDictTable;\r\n TDictTable = array [0..CODE_TABLE_SIZE - 1] of TImageDict;\r\n\r\nfunction InitHash(P: Longint): Longint;\r\nbegin\r\n Result := (P + 3) * 301;\r\nend;\r\n\r\nfunction InterlaceStep(Y, Height: Integer; var Pass: Integer): Integer;\r\nbegin\r\n Result := Y;\r\n case Pass of\r\n 0, 1:\r\n Inc(Result, 8);\r\n 2:\r\n Inc(Result, 4);\r\n 3:\r\n Inc(Result, 2);\r\n end;\r\n if Result >= Height then\r\n begin\r\n if Pass = 0 then\r\n begin\r\n Pass := 1;\r\n Result := 4;\r\n if Result < Height then\r\n Exit;\r\n end;\r\n if Pass = 1 then\r\n begin\r\n Pass := 2;\r\n Result := 2;\r\n if Result < Height then\r\n Exit;\r\n end;\r\n if Pass = 2 then\r\n begin\r\n Pass := 3;\r\n Result := 1;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure ReadImageStream(Stream, Dest: TStream; var Desc: TImageDescriptor;\r\n var Interlaced, LocalColors, Corrupted: Boolean; var BitsPerPixel: Byte;\r\n var ColorTable: TGIFColorTable);\r\nvar\r\n CodeSize, BlockSize: Byte;\r\nbegin\r\n Corrupted := False;\r\n Stream.ReadBuffer(Desc, SizeOf(TImageDescriptor));\r\n Interlaced := (Desc.PackedFields and ID_INTERLACED) <> 0;\r\n if (Desc.PackedFields and ID_LOCAL_COLOR_TABLE) <> 0 then\r\n begin\r\n { Local colors table follows }\r\n BitsPerPixel := 1 + Desc.PackedFields and ID_COLOR_TABLE_SIZE;\r\n LocalColors := True;\r\n ColorTable.Count := 1 shl BitsPerPixel;\r\n Stream.ReadBuffer(ColorTable.Colors[0],\r\n ColorTable.Count * SizeOf(TGIFColorItem));\r\n end\r\n else\r\n begin\r\n LocalColors := False;\r\n FillChar(ColorTable, SizeOf(ColorTable), 0);\r\n end;\r\n Stream.ReadBuffer(CodeSize, 1);\r\n Dest.Write(CodeSize, 1);\r\n repeat\r\n Stream.Read(BlockSize, 1);\r\n if (Stream.Position + BlockSize) > Stream.Size then\r\n begin\r\n Corrupted := True;\r\n Stream.Position := Stream.Size;\r\n Exit;\r\n end;\r\n Dest.Write(BlockSize, 1);\r\n if (Stream.Position + BlockSize) > Stream.Size then\r\n begin\r\n BlockSize := Stream.Size - Stream.Position;\r\n Corrupted := True;\r\n end;\r\n if BlockSize > 0 then\r\n Dest.CopyFrom(Stream, BlockSize);\r\n until (BlockSize = 0) or (Stream.Position >= Stream.Size);\r\nend;\r\n\r\nprocedure FillRGBPalette(const ColorTable: TGIFColorTable;\r\n var Colors: TRGBPalette);\r\nvar\r\n I: Byte;\r\nbegin\r\n FillChar(Colors, SizeOf(Colors), $80);\r\n for I := 0 to ColorTable.Count - 1 do\r\n begin\r\n Colors[I].rgbRed := ColorTable.Colors[I].Red;\r\n Colors[I].rgbGreen := ColorTable.Colors[I].Green;\r\n Colors[I].rgbBlue := ColorTable.Colors[I].Blue;\r\n Colors[I].rgbReserved := 0;\r\n end;\r\nend;\r\n\r\nfunction ReadCode(Stream: TStream; var Context: TReadContext): Longint;\r\nvar\r\n RawCode: Longint;\r\n ByteIndex: Longint;\r\n Bytes: Byte;\r\n BytesToLose: Longint;\r\nbegin\r\n while (Context.Inx + Context.CodeSize > Context.Size) and\r\n (Stream.Position < Stream.Size) do\r\n begin\r\n { not enough bits in buffer - refill it }\r\n { Not very efficient, but infrequently called }\r\n BytesToLose := Context.Inx shr 3;\r\n { Note biggest Code Size is 12 bits. And this can at worst span 3 Bytes }\r\n Move(Context.Buf[Word(BytesToLose)], Context.Buf[0], 3);\r\n Context.Inx := Context.Inx and 7;\r\n Context.Size := Context.Size - (BytesToLose shl 3);\r\n Stream.ReadBuffer(Bytes, 1);\r\n if Bytes > 0 then\r\n Stream.ReadBuffer(Context.Buf[Word(Context.Size shr 3)], Bytes);\r\n Context.Size := Context.Size + (Bytes shl 3);\r\n end;\r\n ByteIndex := Context.Inx shr 3;\r\n RawCode := Context.Buf[Word(ByteIndex)] +\r\n (Word(Context.Buf[Word(ByteIndex + 1)]) shl 8);\r\n if Context.CodeSize > 8 then\r\n RawCode := RawCode + (Longint(Context.Buf[ByteIndex + 2]) shl 16);\r\n RawCode := RawCode shr (Context.Inx and 7);\r\n Context.Inx := Context.Inx + Byte(Context.CodeSize);\r\n Result := RawCode and Context.ReadMask;\r\nend;\r\n\r\nprocedure Output(Value: Byte; var Context: TOutputContext);\r\nvar\r\n P: PByte;\r\nbegin\r\n if Context.Y >= Context.H then\r\n Exit;\r\n case Context.BitsPerPixel of\r\n 1:\r\n begin\r\n P := PByte(PAnsiChar(Context.CurrLineData) + (Context.X shr 3));\r\n if (Context.X and $07) <> 0 then\r\n P^ := P^ or Word(Value shl (7 - (Word(Context.X and 7))))\r\n else\r\n P^ := Byte(Value shl 7);\r\n end;\r\n 4:\r\n begin\r\n P := PByte(PAnsiChar(Context.CurrLineData) + (Context.X shr 1));\r\n if (Context.X and 1) <> 0 then\r\n P^ := P^ or Value\r\n else\r\n P^ := Byte(Value shl 4);\r\n end;\r\n 8:\r\n begin\r\n P := PByte(PAnsiChar(Context.CurrLineData) + Context.X);\r\n P^ := Value;\r\n end;\r\n end;\r\n Inc(Context.X);\r\n if Context.X < Context.W then\r\n Exit;\r\n Context.X := 0;\r\n if Context.Interlace then\r\n Context.Y := InterlaceStep(Context.Y, Context.H, Context.Pass)\r\n else\r\n Inc(Context.Y);\r\n Context.CurrLineData := PAnsiChar(Context.Data) + (Context.H - 1 - Context.Y) * Context.LineIdent;\r\nend;\r\n\r\nprocedure ReadGIFData(Stream: TStream; const Header: TBitmapInfoHeader;\r\n Interlaced, LoadCorrupt: Boolean; IntBitPerPixel: Byte; Data: Pointer;\r\n var Corrupted: Boolean; ProgressProc: TProgressProc);\r\nvar\r\n MinCodeSize, Temp: Byte;\r\n MaxCode, BitMask, InitCodeSize: Longint;\r\n ClearCode, EndingCode, FirstFreeCode, FreeCode: Word;\r\n I, OutCount, Code: Longint;\r\n CurCode, OldCode, InCode, FinalChar: Word;\r\n Prefix, Suffix, OutCode: PIntCodeTable;\r\n ReadCtxt: TReadContext;\r\n OutCtxt: TOutputContext;\r\n TableFull: Boolean;\r\nbegin\r\n Corrupted := False;\r\n OutCount := 0;\r\n OldCode := 0;\r\n FinalChar := 0;\r\n TableFull := False;\r\n Prefix := AllocMem(SizeOf(TIntCodeTable));\r\n try\r\n Suffix := AllocMem(SizeOf(TIntCodeTable));\r\n try\r\n OutCode := AllocMem(SizeOf(TIntCodeTable) + SizeOf(Word));\r\n try\r\n if Assigned(ProgressProc) then\r\n ProgressProc(psStarting, 0, '');\r\n try\r\n Stream.ReadBuffer(MinCodeSize, 1);\r\n if (MinCodeSize < 2) or (MinCodeSize > 9) then\r\n begin\r\n if LoadCorrupt then\r\n begin\r\n Corrupted := True;\r\n MinCodeSize := Max(2, Min(MinCodeSize, 9));\r\n end\r\n else\r\n GifError(RsEBadGIFCodeSize);\r\n end;\r\n { Initial read context }\r\n ReadCtxt.Inx := 0;\r\n ReadCtxt.Size := 0;\r\n ReadCtxt.CodeSize := MinCodeSize + 1;\r\n ReadCtxt.ReadMask := (1 shl ReadCtxt.CodeSize) - 1;\r\n { Initialise pixel-output context }\r\n OutCtxt.X := 0;\r\n OutCtxt.Y := 0;\r\n OutCtxt.Pass := 0;\r\n OutCtxt.W := Header.biWidth;\r\n OutCtxt.H := Header.biHeight;\r\n OutCtxt.BitsPerPixel := Header.biBitCount;\r\n OutCtxt.Interlace := Interlaced;\r\n OutCtxt.LineIdent := ((Header.biWidth * Header.biBitCount + 31)\r\n div 32) * 4;\r\n OutCtxt.Data := Data;\r\n OutCtxt.CurrLineData := PAnsiChar(Data) + (Header.biHeight - 1) * OutCtxt.LineIdent;\r\n BitMask := (1 shl IntBitPerPixel) - 1;\r\n { 2 ^ MinCodeSize accounts for all colours in file }\r\n ClearCode := 1 shl MinCodeSize;\r\n EndingCode := ClearCode + 1;\r\n FreeCode := ClearCode + 2;\r\n FirstFreeCode := FreeCode;\r\n { 2^ (MinCodeSize + 1) includes clear and eoi Code and space too }\r\n InitCodeSize := ReadCtxt.CodeSize;\r\n MaxCode := 1 shl ReadCtxt.CodeSize;\r\n Code := ReadCode(Stream, ReadCtxt);\r\n while (Code <> EndingCode) and (Code <> $FFFF) and\r\n (OutCtxt.Y < OutCtxt.H) do\r\n begin\r\n if Code = ClearCode then\r\n begin\r\n ReadCtxt.CodeSize := InitCodeSize;\r\n MaxCode := 1 shl ReadCtxt.CodeSize;\r\n ReadCtxt.ReadMask := MaxCode - 1;\r\n FreeCode := FirstFreeCode;\r\n Code := ReadCode(Stream, ReadCtxt);\r\n CurCode := Code;\r\n OldCode := Code;\r\n if Code = $FFFF then\r\n Break;\r\n FinalChar := (CurCode and BitMask);\r\n Output(Byte(FinalChar), OutCtxt);\r\n TableFull := False;\r\n end\r\n else\r\n begin\r\n CurCode := Code;\r\n InCode := Code;\r\n if CurCode >= FreeCode then\r\n begin\r\n CurCode := OldCode;\r\n OutCode^[OutCount] := FinalChar;\r\n Inc(OutCount);\r\n end;\r\n while CurCode > BitMask do\r\n begin\r\n if OutCount > CODE_TABLE_SIZE then\r\n begin\r\n if LoadCorrupt then\r\n begin\r\n CurCode := BitMask;\r\n OutCount := 1;\r\n Corrupted := True;\r\n Break;\r\n end\r\n else\r\n GifError(RsEGIFDecodeError);\r\n end;\r\n OutCode^[OutCount] := Suffix^[CurCode];\r\n Inc(OutCount);\r\n CurCode := Prefix^[CurCode];\r\n end;\r\n if Corrupted then\r\n Break;\r\n FinalChar := CurCode and BitMask;\r\n OutCode^[OutCount] := FinalChar;\r\n Inc(OutCount);\r\n for I := OutCount - 1 downto 0 do\r\n Output(Byte(OutCode^[I]), OutCtxt);\r\n OutCount := 0;\r\n { Update dictionary }\r\n if not TableFull then\r\n begin\r\n Prefix^[FreeCode] := OldCode;\r\n Suffix^[FreeCode] := FinalChar;\r\n { Advance to next free slot }\r\n Inc(FreeCode);\r\n if FreeCode >= MaxCode then\r\n begin\r\n if ReadCtxt.CodeSize < 12 then\r\n begin\r\n Inc(ReadCtxt.CodeSize);\r\n MaxCode := MaxCode shl 1;\r\n ReadCtxt.ReadMask := (1 shl ReadCtxt.CodeSize) - 1;\r\n end\r\n else\r\n TableFull := True;\r\n end;\r\n end;\r\n OldCode := InCode;\r\n end;\r\n Code := ReadCode(Stream, ReadCtxt);\r\n if Stream.Size > 0 then\r\n begin\r\n Temp := Trunc(100.0 * (Stream.Position / Stream.Size));\r\n if Assigned(ProgressProc) then\r\n ProgressProc(psRunning, Temp, '');\r\n end;\r\n end; { while }\r\n if Code = $FFFF then\r\n GifError(SReadError);\r\n finally\r\n if Assigned(ProgressProc) then\r\n begin\r\n if ExceptObject = nil then\r\n ProgressProc(psEnding, 100, '')\r\n else\r\n ProgressProc(psEnding, 0, Exception(ExceptObject).Message);\r\n end;\r\n end;\r\n finally\r\n FreeMem(OutCode, SizeOf(TIntCodeTable) + SizeOf(Word));\r\n end;\r\n finally\r\n FreeMem(Suffix, SizeOf(TIntCodeTable));\r\n end;\r\n finally\r\n FreeMem(Prefix, SizeOf(TIntCodeTable));\r\n end;\r\nend;\r\n\r\nprocedure WriteCode(Stream: TStream; Code: Longint;\r\n var Context: TWriteContext);\r\nvar\r\n BufIndex: Longint;\r\n Bytes: Byte;\r\nbegin\r\n BufIndex := Context.Inx shr 3;\r\n Code := Code shl (Context.Inx and 7);\r\n Context.Buf[BufIndex] := Context.Buf[BufIndex] or Code;\r\n Context.Buf[BufIndex + 1] := (Code shr 8);\r\n Context.Buf[BufIndex + 2] := (Code shr 16);\r\n Context.Inx := Context.Inx + Context.CodeSize;\r\n if Context.Inx >= 255 * 8 then\r\n begin\r\n { Flush out full buffer }\r\n Bytes := 255;\r\n Stream.WriteBuffer(Bytes, 1);\r\n Stream.WriteBuffer(Context.Buf, Bytes);\r\n Move(Context.Buf[255], Context.Buf[0], 2);\r\n FillChar(Context.Buf[2], 255, 0);\r\n Context.Inx := Context.Inx - (255 * 8);\r\n end;\r\nend;\r\n\r\nprocedure FlushCode(Stream: TStream; var Context: TWriteContext);\r\nvar\r\n Bytes: Byte;\r\nbegin\r\n Bytes := (Context.Inx + 7) shr 3;\r\n if Bytes > 0 then\r\n begin\r\n Stream.WriteBuffer(Bytes, 1);\r\n Stream.WriteBuffer(Context.Buf, Bytes);\r\n end;\r\n { Data block terminator - a block of zero Size }\r\n Bytes := 0;\r\n Stream.WriteBuffer(Bytes, 1);\r\nend;\r\n\r\nprocedure FillColorTable(var ColorTable: TGIFColorTable;\r\n const Colors: TRGBPalette; Count: Integer);\r\nvar\r\n I: Byte;\r\nbegin\r\n FillChar(ColorTable, SizeOf(ColorTable), 0);\r\n ColorTable.Count := Min(256, Count);\r\n for I := 0 to ColorTable.Count - 1 do\r\n begin\r\n ColorTable.Colors[I].Red := Colors[I].rgbRed;\r\n ColorTable.Colors[I].Green := Colors[I].rgbGreen;\r\n ColorTable.Colors[I].Blue := Colors[I].rgbBlue;\r\n end;\r\nend;\r\n\r\nprocedure WriteGIFData(Stream: TStream; var Header: TBitmapInfoHeader;\r\n Interlaced: Boolean; Data: Pointer; ProgressProc: TProgressProc);\r\n { LZW encode data }\r\nvar\r\n LineIdent: Longint;\r\n MinCodeSize, Col, Temp: Byte;\r\n InitCodeSize, X, Y: Longint;\r\n Pass: Integer;\r\n MaxCode: Longint; { 1 shl CodeSize }\r\n ClearCode, EndingCode, LastCode, Tail: Longint;\r\n I, HashValue: Longint;\r\n LenString: Word;\r\n Dict: PDictTable;\r\n HashTable: TList;\r\n PData: PByte;\r\n WriteCtxt: TWriteContext;\r\nbegin\r\n LineIdent := ((Header.biWidth * Header.biBitCount + 31) div 32) * 4;\r\n Tail := 0;\r\n HashValue := 0;\r\n Dict := AllocMem(SizeOf(TDictTable));\r\n try\r\n HashTable := TList.Create;\r\n try\r\n for I := 0 to HASH_TABLE_SIZE - 1 do\r\n HashTable.Add(nil);\r\n { Initialise encoder variables }\r\n InitCodeSize := Header.biBitCount + 1;\r\n if InitCodeSize = 2 then\r\n Inc(InitCodeSize);\r\n MinCodeSize := InitCodeSize - 1;\r\n Stream.WriteBuffer(MinCodeSize, 1);\r\n ClearCode := 1 shl MinCodeSize;\r\n EndingCode := ClearCode + 1;\r\n LastCode := EndingCode;\r\n MaxCode := 1 shl InitCodeSize;\r\n LenString := 0;\r\n { Setup write context }\r\n WriteCtxt.Inx := 0;\r\n WriteCtxt.CodeSize := InitCodeSize;\r\n FillChar(WriteCtxt.Buf, SizeOf(WriteCtxt.Buf), 0);\r\n WriteCode(Stream, ClearCode, WriteCtxt);\r\n for I := 0 to HASH_TABLE_SIZE - 1 do\r\n HashTable[I] := nil;\r\n Data := PAnsiChar(Data) + (Header.biHeight - 1) * LineIdent;\r\n Y := 0;\r\n Pass := 0;\r\n if Assigned(ProgressProc) then\r\n ProgressProc(psStarting, 0, '');\r\n try\r\n while Y < Header.biHeight do\r\n begin\r\n PData := PByte(PAnsiChar(Data) - (Y * LineIdent));\r\n for X := 0 to Header.biWidth - 1 do\r\n begin\r\n case Header.biBitCount of\r\n 8:\r\n begin\r\n Col := PData^;\r\n Inc(PData);\r\n end;\r\n 4:\r\n begin\r\n if X and 1 <> 0 then\r\n begin\r\n Col := PData^ and $0F;\r\n Inc(PData);\r\n end\r\n else\r\n Col := PData^ shr 4;\r\n end;\r\n else { must be 1 }\r\n begin\r\n if X and 7 = 7 then\r\n begin\r\n Col := PData^ and 1;\r\n Inc(PData);\r\n end\r\n else\r\n Col := (PData^ shr (7 - (X and $07))) and $01;\r\n end;\r\n end;\r\n Inc(LenString);\r\n if LenString = 1 then\r\n begin\r\n Tail := Col;\r\n HashValue := InitHash(Col);\r\n end\r\n else\r\n begin\r\n HashValue := HashValue * (Col + LenString + 4);\r\n I := HashValue mod HASH_TABLE_SIZE;\r\n HashValue := HashValue mod HASH_TABLE_SIZE;\r\n while (HashTable[I] <> nil) and\r\n ((PImageDict(HashTable[I])^.Tail <> Tail) or\r\n (PImageDict(HashTable[I])^.Col <> Col)) do\r\n begin\r\n Inc(I);\r\n if I >= HASH_TABLE_SIZE then\r\n I := 0;\r\n end;\r\n if HashTable[I] <> nil then { Found in the strings table }\r\n Tail := PImageDict(HashTable[I])^.Index\r\n else\r\n begin\r\n { Not found }\r\n WriteCode(Stream, Tail, WriteCtxt);\r\n Inc(LastCode);\r\n HashTable[I] := @Dict^[LastCode];\r\n PImageDict(HashTable[I])^.Index := LastCode;\r\n PImageDict(HashTable[I])^.Tail := Tail;\r\n PImageDict(HashTable[I])^.Col := Col;\r\n Tail := Col;\r\n HashValue := InitHash(Col);\r\n LenString := 1;\r\n if LastCode >= MaxCode then\r\n begin\r\n { Next Code will be written longer }\r\n MaxCode := MaxCode shl 1;\r\n Inc(WriteCtxt.CodeSize);\r\n end\r\n else\r\n if LastCode >= CODE_TABLE_SIZE - 2 then\r\n begin\r\n { Reset tables }\r\n WriteCode(Stream, Tail, WriteCtxt);\r\n WriteCode(Stream, ClearCode, WriteCtxt);\r\n LenString := 0;\r\n LastCode := EndingCode;\r\n WriteCtxt.CodeSize := InitCodeSize;\r\n MaxCode := 1 shl InitCodeSize;\r\n for I := 0 to HASH_TABLE_SIZE - 1 do\r\n HashTable[I] := nil;\r\n end;\r\n end;\r\n end;\r\n end; { for X loop }\r\n if Interlaced then\r\n Y := InterlaceStep(Y, Header.biHeight, Pass)\r\n else\r\n Inc(Y);\r\n Temp := Trunc(100.0 * (Y / Header.biHeight));\r\n if Assigned(ProgressProc) then\r\n ProgressProc(psRunning, Temp, '');\r\n end; { while Y loop }\r\n WriteCode(Stream, Tail, WriteCtxt);\r\n WriteCode(Stream, EndingCode, WriteCtxt);\r\n FlushCode(Stream, WriteCtxt);\r\n finally\r\n if Assigned(ProgressProc) then\r\n begin\r\n if ExceptObject = nil then\r\n ProgressProc(psEnding, 100, '')\r\n else\r\n ProgressProc(psEnding, 0, Exception(ExceptObject).Message);\r\n end;\r\n end;\r\n finally\r\n HashTable.Free;\r\n end;\r\n finally\r\n FreeMem(Dict, SizeOf(TDictTable));\r\n end;\r\nend;\r\n\r\n//=== { TGIFItem } ===========================================================\r\n\r\ndestructor TGIFItem.Destroy;\r\nbegin\r\n FImageData.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TGIFItem.FreeHandle;\r\nbegin\r\n if FImageData <> nil then\r\n FImageData.SetSize(0);\r\nend;\r\n\r\n//=== { TGIFData } ===========================================================\r\n\r\nconstructor TGIFData.Create;\r\nbegin\r\n inherited Create;\r\n FComment := TStringList.Create;\r\nend;\r\n\r\ndestructor TGIFData.Destroy;\r\nbegin\r\n FComment.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TGIFData.FreeHandle;\r\nbegin\r\n if FComment <> nil then\r\n FComment.Clear;\r\nend;\r\n\r\n//=== { TJvGIFFrame } ========================================================\r\n\r\nconstructor TJvGIFFrame.Create(AOwner: TJvGIFImage);\r\nbegin\r\n FOwner := AOwner;\r\n inherited Create;\r\n NewImage;\r\nend;\r\n\r\ndestructor TJvGIFFrame.Destroy;\r\nbegin\r\n FBitmap.Free;\r\n FreeExtensions(FExtensions);\r\n FImage.Release;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvGIFFrame.SetAnimateInterval(Value: Word);\r\nbegin\r\n if FAnimateInterval <> Value then\r\n begin\r\n FAnimateInterval := Value;\r\n if Value > 0 then\r\n FOwner.FVersion := gv89a;\r\n FOwner.Changed(FOwner);\r\n end;\r\nend;\r\n\r\nprocedure TJvGIFFrame.SetDisposalMethod(Value: TDisposalMethod);\r\nbegin\r\n if FDisposal <> Value then\r\n begin\r\n FDisposal := Value;\r\n if Value <> dmUndefined then\r\n FOwner.FVersion := gv89a;\r\n FOwner.Changed(FOwner);\r\n end;\r\nend;\r\n\r\nprocedure TJvGIFFrame.SetTopLeft(const Value: TPoint);\r\nbegin\r\n if (FTopLeft.X <> Value.X) or (FTopLeft.Y <> Value.Y) then\r\n begin\r\n FTopLeft.X := Value.X;\r\n FTopLeft.Y := Value.Y;\r\n FOwner.FScreenWidth := Max(FOwner.FScreenWidth,\r\n FImage.FSize.X + FTopLeft.X);\r\n FOwner.FScreenHeight := Max(FOwner.FScreenHeight,\r\n FImage.FSize.Y + FTopLeft.Y);\r\n FOwner.Changed(FOwner);\r\n end;\r\nend;\r\n\r\nprocedure TJvGIFFrame.SetTransparentColor(Value: TColor);\r\nbegin\r\n if FTransparentColor <> Value then\r\n begin\r\n FTransparentColor := Value;\r\n if Value <> clNone then\r\n FOwner.FVersion := gv89a;\r\n FOwner.Changed(FOwner);\r\n end;\r\nend;\r\n\r\nfunction TJvGIFFrame.GetBitmap: TBitmap;\r\nvar\r\n Mem: TMemoryStream;\r\nbegin\r\n Result := FBitmap;\r\n if (Result = nil) or Result.Empty then\r\n begin\r\n NewBitmap;\r\n Result := FBitmap;\r\n if Assigned(FImage.FImageData) then\r\n try\r\n Mem := TMemoryStream.Create;\r\n try\r\n SaveToBitmapStream(Mem);\r\n FBitmap.LoadFromStream(Mem);\r\n if not FBitmap.Monochrome then\r\n FBitmap.HandleType := bmDDB;\r\n finally\r\n Mem.Free;\r\n end;\r\n except\r\n raise;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJvGIFFrame.GetHeight: Integer;\r\nbegin\r\n if Assigned(FBitmap) or Assigned(FImage.FImageData) then\r\n Result := Bitmap.Height\r\n else\r\n Result := 0;\r\nend;\r\n\r\nfunction TJvGIFFrame.GetWidth: Integer;\r\nbegin\r\n if Assigned(FBitmap) or Assigned(FImage.FImageData) then\r\n Result := Bitmap.Width\r\n else\r\n Result := 0;\r\nend;\r\n\r\nfunction TJvGIFFrame.GetColorCount: Integer;\r\nbegin\r\n Result := FImage.FColorMap.Count;\r\n if (Result = 0) and Assigned(FBitmap) and (FBitmap.Palette <> 0) then\r\n Result := PaletteEntries(FBitmap.Palette);\r\nend;\r\n\r\nprocedure TJvGIFFrame.GrayscaleImage(ForceEncoding: Boolean);\r\nvar\r\n Mem: TMemoryStream;\r\n TransIndex: Integer;\r\nbegin\r\n if not FGrayscale and (Assigned(FBitmap) or\r\n Assigned(FImage.FImageData)) then\r\n begin\r\n if Assigned(FImage.FImageData) and (FImage.FColorMap.Count > 0) then\r\n begin\r\n FBitmap.Free;\r\n FBitmap := nil;\r\n TransIndex := FindColorIndex(FImage.FColorMap, FTransparentColor);\r\n GrayColorTable(FImage.FColorMap);\r\n if TransIndex >= 0 then\r\n FTransparentColor := ItemToRGB(FImage.FColorMap.Colors[TransIndex])\r\n else\r\n FTransparentColor := clNone;\r\n FGrayscale := True;\r\n try\r\n GetBitmap;\r\n except\r\n on EAbort do\r\n ;\r\n else\r\n raise;\r\n end;\r\n end\r\n else\r\n begin\r\n Mem := BitmapToMemoryStream(Bitmap, pf8bit, mmGrayscale);\r\n try\r\n FImage.Release;\r\n FImage := TGIFItem.Create;\r\n FImage.Reference;\r\n if ForceEncoding then\r\n EncodeBitmapStream(Mem);\r\n FGrayscale := True;\r\n if FTransparentColor <> clNone then\r\n FTransparentColor := GrayColor(FTransparentColor);\r\n FBitmap.LoadFromStream(Mem);\r\n finally\r\n Mem.Free;\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvGIFFrame.Assign(Source: TPersistent);\r\nvar\r\n AComment: TStrings;\r\nbegin\r\n if Source = nil then\r\n begin\r\n NewImage;\r\n FBitmap.Free;\r\n FBitmap := nil;\r\n end\r\n else\r\n if Source is TJvGIFFrame then\r\n begin\r\n if Source <> Self then\r\n begin\r\n FImage.Release;\r\n FImage := TJvGIFFrame(Source).FImage;\r\n if TJvGIFFrame(Source).FOwner <> FOwner then\r\n FLocalColors := True\r\n else\r\n FLocalColors := TJvGIFFrame(Source).FLocalColors;\r\n FImage.Reference;\r\n FTopLeft := TJvGIFFrame(Source).FTopLeft;\r\n FInterlaced := TJvGIFFrame(Source).FInterlaced;\r\n if TJvGIFFrame(Source).FBitmap <> nil then\r\n begin\r\n NewBitmap;\r\n FBitmap.Assign(TJvGIFFrame(Source).FBitmap);\r\n end;\r\n FTransparentColor := TJvGIFFrame(Source).FTransparentColor;\r\n FAnimateInterval := TJvGIFFrame(Source).FAnimateInterval;\r\n FDisposal := TJvGIFFrame(Source).FDisposal;\r\n FGrayscale := TJvGIFFrame(Source).FGrayscale;\r\n FCorrupted := TJvGIFFrame(Source).FCorrupted;\r\n AComment := TJvGIFFrame(Source).FindComment(False);\r\n if (AComment <> nil) and (AComment.Count > 0) then\r\n SetComment(AComment);\r\n end;\r\n end\r\n else\r\n if Source is TJvGIFImage then\r\n begin\r\n if TJvGIFImage(Source).Count > 0 then\r\n begin\r\n if TJvGIFImage(Source).FrameIndex >= 0 then\r\n Assign(TJvGIFImage(Source).Frames[TJvGIFImage(Source).FrameIndex])\r\n else\r\n Assign(TJvGIFImage(Source).Frames[0]);\r\n end\r\n else\r\n Assign(nil);\r\n end\r\n else\r\n if Source is TGraphic then\r\n begin\r\n { TBitmap, TJPEGImage... }\r\n if TGraphic(Source).Empty then\r\n begin\r\n Assign(nil);\r\n Exit;\r\n end;\r\n NewImage;\r\n NewBitmap;\r\n try\r\n FBitmap.Assign(Source);\r\n if Source is TBitmap then\r\n FBitmap.Monochrome := TBitmap(Source).Monochrome;\r\n except\r\n FBitmap.Canvas.Brush.Color := clFuchsia;\r\n FBitmap.Width := TGraphic(Source).Width;\r\n FBitmap.Height := TGraphic(Source).Height;\r\n FBitmap.Canvas.Draw(0, 0, TGraphic(Source));\r\n end;\r\n if TGraphic(Source).Transparent then\r\n begin\r\n if Source is TBitmap then\r\n FTransparentColor := TBitmap(Source).TransparentColor\r\n else\r\n FTransparentColor := GetNearestColor(FBitmap.Canvas.Handle,\r\n ColorToRGB(FBitmap.Canvas.Brush.Color));\r\n end;\r\n end\r\n else\r\n inherited Assign(Source);\r\n if FOwner <> nil then\r\n FOwner.UpdateScreenSize;\r\nend;\r\n\r\nprocedure TJvGIFFrame.AssignTo(Dest: TPersistent);\r\nbegin\r\n if (Dest is TJvGIFFrame) or (Dest is TJvGIFImage) then\r\n Dest.Assign(Self)\r\n else\r\n if Dest is TGraphic then\r\n begin\r\n Dest.Assign(Bitmap);\r\n if (Dest is TBitmap) and (FTransparentColor <> clNone) then\r\n begin\r\n TBitmap(Dest).TransparentColor := GetNearestColor(\r\n TBitmap(Dest).Canvas.Handle, ColorToRGB(FTransparentColor));\r\n TBitmap(Dest).Transparent := True;\r\n end;\r\n end\r\n else\r\n inherited AssignTo(Dest);\r\nend;\r\n\r\nprocedure TJvGIFFrame.NewBitmap;\r\nbegin\r\n FBitmap.Free;\r\n FBitmap := TBitmap.Create;\r\nend;\r\n\r\nprocedure TJvGIFFrame.NewImage;\r\nbegin\r\n if FImage <> nil then\r\n FImage.Release;\r\n FImage := TGIFItem.Create;\r\n FImage.Reference;\r\n FGrayscale := False;\r\n FCorrupted := False;\r\n FTransparentColor := clNone;\r\n FTopLeft := Point(0, 0);\r\n FInterlaced := False;\r\n FLocalColors := False;\r\n FAnimateInterval := 0;\r\n FDisposal := dmUndefined;\r\nend;\r\n\r\nfunction TJvGIFFrame.FindComment(ForceCreate: Boolean): TStrings;\r\nvar\r\n Ext: TExtension;\r\nbegin\r\n Ext := FindExtension(FExtensions, etComment);\r\n if (Ext = nil) and ForceCreate then\r\n begin\r\n Ext := TExtension.Create;\r\n try\r\n Ext.FExtType := etComment;\r\n if FExtensions = nil then\r\n FExtensions := TList.Create;\r\n FExtensions.Add(Ext);\r\n except\r\n Ext.Free;\r\n raise;\r\n end;\r\n end;\r\n if Ext <> nil then\r\n begin\r\n if (Ext.FData = nil) and ForceCreate then\r\n Ext.FData := TStringList.Create;\r\n Result := Ext.FData;\r\n end\r\n else\r\n Result := nil;\r\nend;\r\n\r\nfunction TJvGIFFrame.GetComment: TStrings;\r\nbegin\r\n Result := FindComment(True);\r\nend;\r\n\r\nprocedure TJvGIFFrame.SetComment(Value: TStrings);\r\nbegin\r\n GetComment.Assign(Value);\r\nend;\r\n\r\nprocedure TJvGIFFrame.UpdateExtensions;\r\nvar\r\n Ext: TExtension;\r\n I: Integer;\r\nbegin\r\n Ext := FindExtension(FExtensions, etGraphic);\r\n if (FAnimateInterval > 0) or (FTransparentColor <> clNone) or\r\n (FDisposal <> dmUndefined) then\r\n begin\r\n if Ext = nil then\r\n begin\r\n Ext := TExtension.Create;\r\n Ext.FExtType := etGraphic;\r\n if FExtensions = nil then\r\n FExtensions := TList.Create;\r\n FExtensions.Add(Ext);\r\n with Ext.FExtRec.GCE do\r\n begin\r\n BlockSize := 4;\r\n PackedFields := 0;\r\n Terminator := 0;\r\n end;\r\n end;\r\n end;\r\n if Ext <> nil then\r\n with Ext.FExtRec.GCE do\r\n begin\r\n DelayTime := FAnimateInterval div 10;\r\n I := FindColorIndex(FImage.FColorMap, FTransparentColor);\r\n if I >= 0 then\r\n begin\r\n TransparentColorIndex := I;\r\n PackedFields := PackedFields or GCE_TRANSPARENT;\r\n end\r\n else\r\n PackedFields := PackedFields and not GCE_TRANSPARENT;\r\n PackedFields := (PackedFields and not GCE_DISPOSAL_METHOD) or\r\n (Ord(FDisposal) shl 2);\r\n end;\r\n if FExtensions <> nil then\r\n for I := FExtensions.Count - 1 downto 0 do\r\n begin\r\n Ext := TExtension(FExtensions[I]);\r\n if (Ext <> nil) and (Ext.FExtType = etComment) and\r\n ((Ext.FData = nil) or (Ext.FData.Count = 0)) then\r\n begin\r\n Ext.Free;\r\n FExtensions.Delete(I);\r\n end;\r\n end;\r\n if (FExtensions <> nil) and (FExtensions.Count > 0) then\r\n FOwner.FVersion := gv89a;\r\nend;\r\n\r\nprocedure TJvGIFFrame.EncodeBitmapStream(Stream: TMemoryStream);\r\nvar\r\n BI: PBitmapInfoHeader;\r\n ColorCount, W, H: Integer;\r\n Bits, Pal: Pointer;\r\nbegin\r\n ColorCount := 0;\r\n Stream.Position := 0;\r\n BI := PBitmapInfoHeader(PAnsiChar(Stream.Memory) + SizeOf(TBitmapFileHeader));\r\n W := BI^.biWidth;\r\n H := BI^.biHeight;\r\n Pal := PRGBPalette(PAnsiChar(BI) + SizeOf(TBitmapInfoHeader));\r\n Bits := Pointer(PAnsiChar(Stream.Memory) + PBitmapFileHeader(Stream.Memory)^.bfOffBits);\r\n case BI^.biBitCount of\r\n 1:\r\n ColorCount := 2;\r\n 4:\r\n ColorCount := 16;\r\n 8:\r\n ColorCount := 256;\r\n else\r\n GifError(RsEGIFEncodeError);\r\n end;\r\n FInterlaced := False;\r\n FillColorTable(FImage.FColorMap, PRGBPalette(Pal)^, ColorCount);\r\n if FImage.FImageData = nil then\r\n FImage.FImageData := TMemoryStream.Create\r\n else\r\n FImage.FImageData.SetSize(0);\r\n try\r\n WriteGIFData(FImage.FImageData, BI^, FInterlaced, Bits, FOwner.DoProgress);\r\n except\r\n on EAbort do\r\n begin\r\n NewImage; { OnProgress can raise EAbort to cancel image save }\r\n raise;\r\n end\r\n else\r\n raise;\r\n end;\r\n FImage.FBitsPerPixel := 1;\r\n while FImage.FColorMap.Count > 1 shl FImage.FBitsPerPixel do\r\n Inc(FImage.FBitsPerPixel);\r\n if FOwner.FImage.FColorMap.Count = 0 then\r\n begin\r\n FOwner.FImage.FColorMap := FImage.FColorMap;\r\n FOwner.FImage.FBitsPerPixel := FImage.FBitsPerPixel;\r\n FLocalColors := False;\r\n end\r\n else\r\n FLocalColors := True;\r\n FImage.FSize.X := W;\r\n FImage.FSize.Y := H;\r\n FOwner.FScreenWidth := Max(FOwner.FScreenWidth, FImage.FSize.X + FTopLeft.X);\r\n FOwner.FScreenHeight := Max(FOwner.FScreenHeight, FImage.FSize.Y + FTopLeft.Y);\r\nend;\r\n\r\nprocedure TJvGIFFrame.EncodeRasterData;\r\nvar\r\n Method: TMappingMethod;\r\n Mem: TMemoryStream;\r\nbegin\r\n if not Assigned(FBitmap) or FBitmap.Empty then\r\n GifError(RsENoGIFData);\r\n if not (GetBitmapPixelFormat(FBitmap) in [pf1bit, pf4bit, pf8bit]) then\r\n begin\r\n if FGrayscale then\r\n Method := mmGrayscale\r\n else\r\n Method := DefaultMappingMethod;\r\n Mem := BitmapToMemoryStream(FBitmap, pf8bit, Method);\r\n if Method = mmGrayscale then\r\n FGrayscale := True;\r\n end\r\n else\r\n Mem := TMemoryStream.Create;\r\n try\r\n if Mem.Size = 0 then\r\n FBitmap.SaveToStream(Mem);\r\n EncodeBitmapStream(Mem);\r\n finally\r\n Mem.Free;\r\n end;\r\nend;\r\n\r\nprocedure TJvGIFFrame.WriteImageDescriptor(Stream: TStream);\r\nvar\r\n ImageDesc: TImageDescriptor;\r\nbegin\r\n with ImageDesc do\r\n begin\r\n PackedFields := 0;\r\n if FLocalColors then\r\n begin\r\n FImage.FBitsPerPixel := 1;\r\n while FImage.FColorMap.Count > 1 shl FImage.FBitsPerPixel do\r\n Inc(FImage.FBitsPerPixel);\r\n PackedFields := (PackedFields or ID_LOCAL_COLOR_TABLE) +\r\n (FImage.FBitsPerPixel - 1);\r\n end;\r\n if FInterlaced then\r\n PackedFields := PackedFields or ID_INTERLACED;\r\n ImageLeftPos := FTopLeft.X;\r\n ImageTopPos := FTopLeft.Y;\r\n ImageWidth := FImage.FSize.X;\r\n ImageHeight := FImage.FSize.Y;\r\n end;\r\n Stream.Write(ImageDesc, SizeOf(TImageDescriptor));\r\nend;\r\n\r\nprocedure TJvGIFFrame.WriteLocalColorMap(Stream: TStream);\r\nbegin\r\n if FLocalColors then\r\n with FImage.FColorMap do\r\n Stream.Write(Colors[0], Count * SizeOf(TGIFColorItem));\r\nend;\r\n\r\nprocedure TJvGIFFrame.WriteRasterData(Stream: TStream);\r\nbegin\r\n Stream.WriteBuffer(FImage.FImageData.Memory^, FImage.FImageData.Size);\r\nend;\r\n\r\nprocedure TJvGIFFrame.SaveToBitmapStream(Stream: TMemoryStream);\r\n\r\n function ConvertBitsPerPixel: TPixelFormat;\r\n begin\r\n Result := pfDevice;\r\n case FImage.FBitsPerPixel of\r\n 1:\r\n Result := pf1bit;\r\n 2..4:\r\n Result := pf4bit;\r\n 5..8:\r\n Result := pf8bit;\r\n else\r\n GifError(RsEWrongGIFColors);\r\n end;\r\n end;\r\n\r\nvar\r\n HeaderSize: Longword;\r\n Length: Longword;\r\n BI: TBitmapInfoHeader;\r\n BitFile: TBitmapFileHeader;\r\n Colors: TRGBPalette;\r\n Bits: Pointer;\r\n Corrupt: Boolean;\r\nbegin\r\n with BI do\r\n begin\r\n biSize := SizeOf(TBitmapInfoHeader);\r\n biWidth := FImage.FSize.X;\r\n biHeight := FImage.FSize.Y;\r\n biPlanes := 1;\r\n biBitCount := 0;\r\n case ConvertBitsPerPixel of\r\n pf1bit:\r\n biBitCount := 1;\r\n pf4bit:\r\n biBitCount := 4;\r\n pf8bit:\r\n biBitCount := 8;\r\n end;\r\n biCompression := BI_RGB;\r\n biSizeImage := (((biWidth * biBitCount + 31) div 32) * 4) * biHeight;\r\n biXPelsPerMeter := 0;\r\n biYPelsPerMeter := 0;\r\n biClrUsed := 0;\r\n biClrImportant := 0;\r\n end;\r\n HeaderSize := SizeOf(TBitmapFileHeader) + SizeOf(TBitmapInfoHeader) +\r\n SizeOf(TRGBQuad) * (1 shl BI.biBitCount);\r\n Length := HeaderSize + BI.biSizeImage;\r\n Stream.SetSize(0);\r\n Stream.Position := 0;\r\n with BitFile do\r\n begin\r\n bfType := $4D42; { BM }\r\n bfSize := Length;\r\n bfOffBits := HeaderSize;\r\n end;\r\n Stream.Write(BitFile, SizeOf(TBitmapFileHeader));\r\n Stream.Write(BI, SizeOf(TBitmapInfoHeader));\r\n FillRGBPalette(FImage.FColorMap, Colors);\r\n Stream.Write(Colors, SizeOf(TRGBQuad) * (1 shl BI.biBitCount));\r\n Bits := GlobalAllocPtr(GMEM_ZEROINIT, BI.biSizeImage);\r\n try\r\n FImage.FImageData.Position := 0;\r\n ReadGIFData(FImage.FImageData, BI, FInterlaced, GIFLoadCorrupted,\r\n FImage.FBitsPerPixel, Bits, Corrupt, FOwner.DoProgress);\r\n FCorrupted := FCorrupted or Corrupt;\r\n Stream.WriteBuffer(Bits^, BI.biSizeImage);\r\n finally\r\n GlobalFreePtr(Bits);\r\n end;\r\n Stream.Position := 0;\r\nend;\r\n\r\nfunction ColorItemTwiceInColorMap(Index: Integer; ColorMap: TGIFColorTable): Boolean;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := False;\r\n I := 0;\r\n while (I < ColorMap.Count) and not Result do\r\n begin\r\n if (I = Index) then\r\n begin\r\n Inc(I);\r\n end\r\n else\r\n begin\r\n Result := (ItemToRGB(ColorMap.Colors[Index]) = ItemToRGB(ColorMap.Colors[I]));\r\n end;\r\n Inc(I);\r\n end;\r\nend;\r\n\r\nprocedure TJvGIFFrame.LoadFromStream(Stream: TStream);\r\nvar\r\n ImageDesc: TImageDescriptor;\r\n I, Offset, TransIndex: Integer;\r\nbegin\r\n FImage.FImageData := TMemoryStream.Create;\r\n try\r\n ReadImageStream(Stream, FImage.FImageData, ImageDesc, FInterlaced,\r\n FLocalColors, FCorrupted, FImage.FBitsPerPixel, FImage.FColorMap);\r\n if FCorrupted and not GIFLoadCorrupted then\r\n GifError(SReadError);\r\n FImage.FImageData.Position := 0;\r\n with ImageDesc do\r\n begin\r\n if ImageHeight = 0 then\r\n ImageHeight := FOwner.FScreenHeight;\r\n if ImageWidth = 0 then\r\n ImageWidth := FOwner.FScreenWidth;\r\n FTopLeft := Point(ImageLeftPos, ImageTopPos);\r\n FImage.FSize := Point(ImageWidth, ImageHeight);\r\n FImage.FPackedFields := PackedFields;\r\n end;\r\n if not FLocalColors then\r\n FImage.FColorMap := FOwner.FImage.FColorMap;\r\n FAnimateInterval := 0;\r\n if FExtensions <> nil then\r\n begin\r\n for I := 0 to FExtensions.Count - 1 do\r\n with TExtension(FExtensions[I]) do\r\n if FExtType = etGraphic then\r\n begin\r\n if (FExtRec.GCE.PackedFields and GCE_TRANSPARENT) <> 0 then\r\n begin\r\n TransIndex := FExtRec.GCE.TransparentColorIndex;\r\n if FImage.FColorMap.Count > TransIndex then\r\n begin\r\n // Mantis 2135: Ensure that the transparent color does not appear\r\n // twice in the palette or the second color index would end up\r\n // being transparent as well\r\n Offset := -1;\r\n while ColorItemTwiceInColorMap(TransIndex, FImage.FColorMap) do\r\n begin\r\n if FImage.FColorMap.Colors[TransIndex].Blue = 0 then\r\n Offset := 1\r\n else\r\n if FImage.FColorMap.Colors[TransIndex].Blue = 255 then\r\n Offset := -1;\r\n Inc(FImage.FColorMap.Colors[TransIndex].Blue, Offset);\r\n end;\r\n\r\n FTransparentColor := ItemToRGB(FImage.FColorMap.Colors[TransIndex]);\r\n end;\r\n end\r\n else\r\n FTransparentColor := clNone;\r\n FAnimateInterval := Max(FExtRec.GCE.DelayTime * 10, FAnimateInterval);\r\n FDisposal := TDisposalMethod((FExtRec.GCE.PackedFields and GCE_DISPOSAL_METHOD) shr 2);\r\n end;\r\n end;\r\n except\r\n FImage.FImageData.Free;\r\n FImage.FImageData := nil;\r\n raise;\r\n end;\r\nend;\r\n\r\nprocedure TJvGIFFrame.Draw(ACanvas: TCanvas; const ARect: TRect;\r\n Transparent: Boolean);\r\nbegin\r\n if (FTransparentColor <> clNone) and Transparent then\r\n begin\r\n StretchBitmapRectTransparent(ACanvas, ARect.Left, ARect.Top, ARect.Right - ARect.Left,\r\n ARect.Bottom - ARect.Top, Bounds(0, 0, Bitmap.Width, Bitmap.Height), Bitmap,\r\n FTransparentColor);\r\n end\r\n else\r\n ACanvas.StretchDraw(ARect, Bitmap);\r\nend;\r\n\r\n//=== { TJvGIFImage } ========================================================\r\n\r\nconstructor TJvGIFImage.Create;\r\nbegin\r\n inherited Create;\r\n NewImage;\r\n inherited SetTransparent(True);\r\nend;\r\n\r\ndestructor TJvGIFImage.Destroy;\r\nbegin\r\n OnChange := nil;\r\n FImage.Release;\r\n ClearItems;\r\n FItems.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvGIFImage.Clear;\r\nbegin\r\n Assign(nil);\r\nend;\r\n\r\nprocedure TJvGIFImage.ClearItems;\r\nbegin\r\n if FItems <> nil then\r\n while FItems.Count > 0 do\r\n begin\r\n TObject(FItems[0]).Free;\r\n FItems.Delete(0);\r\n end;\r\nend;\r\n\r\nprocedure TJvGIFImage.Assign(Source: TPersistent);\r\nvar\r\n I: Integer;\r\n AFrame: TJvGIFFrame;\r\nbegin\r\n if Source = nil then\r\n begin\r\n NewImage;\r\n Changed(Self);\r\n end\r\n else\r\n if (Source is TJvGIFImage) and (Source <> Self) then\r\n begin\r\n FImage.Release;\r\n FImage := TJvGIFImage(Source).FImage;\r\n FImage.Reference;\r\n FVersion := TJvGIFImage(Source).FVersion;\r\n FBackgroundColor := TJvGIFImage(Source).FBackgroundColor;\r\n FRepeatCount := TJvGIFImage(Source).FRepeatCount;\r\n FLooping := TJvGIFImage(Source).FLooping;\r\n FCorrupted := TJvGIFImage(Source).FCorrupted;\r\n if FItems = nil then\r\n FItems := TList.Create\r\n else\r\n ClearItems;\r\n with TJvGIFImage(Source) do\r\n begin\r\n for I := 0 to FItems.Count - 1 do\r\n begin\r\n AFrame := TJvGIFFrame.Create(Self);\r\n try\r\n AFrame.FImage.FBitsPerPixel :=\r\n TJvGIFFrame(FItems[I]).FImage.FBitsPerPixel;\r\n AFrame.Assign(TJvGIFFrame(FItems[I]));\r\n AFrame.FLocalColors := TJvGIFFrame(FItems[I]).FLocalColors;\r\n Self.FItems.Add(AFrame);\r\n except\r\n AFrame.Free;\r\n raise;\r\n end;\r\n end;\r\n Self.FScreenWidth := FScreenWidth;\r\n Self.FScreenHeight := FScreenHeight;\r\n end;\r\n FFrameIndex := TJvGIFImage(Source).FFrameIndex;\r\n Changed(Self);\r\n end\r\n else\r\n if Source is TJvGIFFrame then\r\n begin\r\n NewImage;\r\n with TJvGIFFrame(Source).FOwner.FImage do\r\n begin\r\n FImage.FAspectRatio := FAspectRatio;\r\n FImage.FBitsPerPixel := FBitsPerPixel;\r\n FImage.FColorResBits := FColorResBits;\r\n Move(FColorMap, FImage.FColorMap, SizeOf(FColorMap));\r\n end;\r\n FFrameIndex := FItems.Add(TJvGIFFrame.Create(Self));\r\n TJvGIFFrame(FItems[FFrameIndex]).Assign(Source);\r\n if FVersion = gvUnknown then\r\n FVersion := gv87a;\r\n Changed(Self);\r\n end\r\n else\r\n if Source is TBitmap then\r\n begin\r\n NewImage;\r\n AddFrame(TBitmap(Source));\r\n Changed(Self);\r\n end\r\n else\r\n if Source is TJvAni then\r\n begin\r\n NewImage;\r\n FBackgroundColor := clWindow;\r\n with TJvAni(Source) do\r\n begin\r\n for I := 0 to FrameCount - 1 do\r\n begin\r\n AddFrame(TIcon(Icons[I]));\r\n Self.Frames[I].FAnimateInterval := Longint(Frames[I].Rate * 100) div 6;\r\n if Frames[I].Rate = 0 then\r\n Self.Frames[I].FAnimateInterval := 100;\r\n end;\r\n end;\r\n Changed(Self);\r\n end\r\n else\r\n inherited Assign(Source);\r\nend;\r\n\r\nprocedure TJvGIFImage.AssignTo(Dest: TPersistent);\r\nbegin\r\n if Dest is TJvGIFImage then\r\n Dest.Assign(Self)\r\n else\r\n if Dest is TGraphic then\r\n begin\r\n if Empty then\r\n Dest.Assign(nil)\r\n else\r\n if FFrameIndex >= 0 then\r\n TJvGIFFrame(FItems[FFrameIndex]).AssignTo(Dest)\r\n else\r\n Dest.Assign(Bitmap);\r\n end\r\n else\r\n inherited AssignTo(Dest);\r\nend;\r\n\r\nprocedure TJvGIFImage.Draw(ACanvas: TCanvas; const ARect: TRect);\r\nbegin\r\n if FFrameIndex >= 0 then\r\n TJvGIFFrame(FItems[FFrameIndex]).Draw(ACanvas, ARect, Self.Transparent);\r\nend;\r\n\r\nfunction TJvGIFImage.GetBackgroundColor: TColor;\r\nbegin\r\n Result := FBackgroundColor;\r\nend;\r\n\r\nprocedure TJvGIFImage.SetBackgroundColor(Value: TColor);\r\nbegin\r\n if Value <> FBackgroundColor then\r\n begin\r\n FBackgroundColor := Value;\r\n Changed(Self);\r\n end;\r\nend;\r\n\r\nprocedure TJvGIFImage.SetLooping(Value: Boolean);\r\nbegin\r\n if Value <> FLooping then\r\n begin\r\n FLooping := Value;\r\n Changed(Self);\r\n end;\r\nend;\r\n\r\nprocedure TJvGIFImage.SetRepeatCount(Value: Word);\r\nbegin\r\n if Min(Value, MAX_LOOP_COUNT) <> FRepeatCount then\r\n begin\r\n FRepeatCount := Min(Value, MAX_LOOP_COUNT);\r\n Changed(Self);\r\n end;\r\nend;\r\n\r\nfunction TJvGIFImage.GetPixelFormat: TPixelFormat;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := pfDevice;\r\n if not Empty then\r\n begin\r\n Result := ColorsToPixelFormat(FImage.FColorMap.Count);\r\n for I := 0 to FItems.Count - 1 do\r\n begin\r\n if (Frames[I].FImage.FImageData = nil) or\r\n (Frames[I].FImage.FImageData.Size = 0) then\r\n begin\r\n if Assigned(Frames[I].FBitmap) then\r\n Result := TPixelFormat(Max(Ord(Result),\r\n Ord(GetBitmapPixelFormat(Frames[I].FBitmap))))\r\n else\r\n Result := TPixelFormat(Max(Ord(Result), Ord(pfDevice)));\r\n end\r\n else\r\n if Frames[I].FLocalColors then\r\n Result := TPixelFormat(Max(Ord(Result),\r\n Ord(ColorsToPixelFormat(Frames[I].FImage.FColorMap.Count))));\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJvGIFImage.GetCorrupted: Boolean;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := FCorrupted;\r\n if not Result then\r\n for I := 0 to FItems.Count - 1 do\r\n if Frames[I].Corrupted then\r\n begin\r\n Result := True;\r\n Exit;\r\n end;\r\nend;\r\n\r\nfunction TJvGIFImage.GetTransparentColor: TColor;\r\nbegin\r\n if (FItems.Count > 0) and (FFrameIndex >= 0) then\r\n Result := TJvGIFFrame(FItems[FFrameIndex]).FTransparentColor\r\n else\r\n Result := clNone;\r\nend;\r\n\r\nfunction TJvGIFImage.GetCount: Integer;\r\nbegin\r\n Result := FItems.Count;\r\nend;\r\n\r\nfunction TJvGIFImage.GetFrame(Index: Integer): TJvGIFFrame;\r\nbegin\r\n Result := TJvGIFFrame(FItems[Index]);\r\nend;\r\n\r\nprocedure TJvGIFImage.SetFrameIndex(Value: Integer);\r\nbegin\r\n Value := Min(FItems.Count - 1, Max(-1, Value));\r\n if FFrameIndex <> Value then\r\n begin\r\n FFrameIndex := Value;\r\n PaletteModified := True;\r\n Changed(Self);\r\n end;\r\nend;\r\n\r\nfunction TJvGIFImage.Equals(Graphic: TGraphic): Boolean;\r\nbegin\r\n Result := (Graphic is TJvGIFImage) and\r\n (FImage = TJvGIFImage(Graphic).FImage);\r\nend;\r\n\r\nfunction TJvGIFImage.GetBitmap: TBitmap;\r\nvar\r\n Bmp: TBitmap;\r\nbegin\r\n if FItems.Count > 0 then\r\n begin\r\n if (FFrameIndex >= 0) and (FFrameIndex < FItems.Count) then\r\n Result := TJvGIFFrame(FItems[FFrameIndex]).Bitmap\r\n else\r\n Result := TJvGIFFrame(FItems[0]).Bitmap\r\n end\r\n else\r\n begin\r\n FFrameIndex := 0;\r\n Bmp := TBitmap.Create;\r\n try\r\n Bmp.Handle := 0;\r\n Assign(Bmp);\r\n Result := TJvGIFFrame(FItems[FFrameIndex]).Bitmap;\r\n finally\r\n Bmp.Free;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJvGIFImage.GetGlobalColorCount: Integer;\r\nbegin\r\n Result := FImage.FColorMap.Count;\r\nend;\r\n\r\nfunction TJvGIFImage.GetEmpty: Boolean;\r\nvar\r\n I: Integer;\r\nbegin\r\n I := Max(FFrameIndex, 0);\r\n Result := (FItems.Count = 0) or\r\n ((TJvGIFFrame(FItems[I]).FBitmap = nil) and\r\n ((TJvGIFFrame(FItems[I]).FImage.FImageData = nil) or\r\n (TJvGIFFrame(FItems[I]).FImage.FImageData.Size = 0)));\r\nend;\r\n\r\nfunction TJvGIFImage.GetPalette: HPALETTE;\r\nbegin\r\n if FItems.Count > 0 then\r\n Result := Bitmap.Palette\r\n else\r\n Result := 0;\r\nend;\r\n\r\nfunction TJvGIFImage.GetTransparent: Boolean;\r\nvar\r\n I: Integer;\r\nbegin\r\n if inherited GetTransparent then\r\n for I := 0 to FItems.Count - 1 do\r\n if Frames[I].TransparentColor <> clNone then\r\n begin\r\n Result := True;\r\n Exit;\r\n end;\r\n Result := False;\r\nend;\r\n\r\nfunction TJvGIFImage.GetHeight: Integer;\r\nbegin\r\n if not Empty and (FFrameIndex >= 0) and (FFrameIndex < Count) then\r\n Result := TJvGIFFrame(FItems[FFrameIndex]).Bitmap.Height\r\n else\r\n Result := 0;\r\nend;\r\n\r\nfunction TJvGIFImage.GetWidth: Integer;\r\nbegin\r\n if not Empty and (FFrameIndex >= 0) and (FFrameIndex < Count) then\r\n Result := TJvGIFFrame(FItems[FFrameIndex]).Bitmap.Width\r\n else\r\n Result := 0;\r\nend;\r\n\r\nfunction TJvGIFImage.GetScreenWidth: Integer;\r\nbegin\r\n if Empty then\r\n Result := 0\r\n else\r\n Result := FScreenWidth;\r\nend;\r\n\r\nfunction TJvGIFImage.GetScreenHeight: Integer;\r\nbegin\r\n if Empty then\r\n Result := 0\r\n else\r\n Result := FScreenHeight;\r\nend;\r\n\r\nprocedure TJvGIFImage.LoadFromClipboardFormat(AFormat: Word; AData: THandle;\r\n APalette: HPALETTE);\r\nvar\r\n Bmp: TBitmap;\r\n Stream: TMemoryStream;\r\n Size: Longint;\r\n Buffer: Pointer;\r\n Data: THandle;\r\nbegin\r\n { !! check for gif clipboard Data, mime type image/gif }\r\n Data := GetClipboardData(CF_JVGIF);\r\n if Data <> 0 then\r\n begin\r\n Buffer := GlobalLock(Data);\r\n try\r\n Stream := TMemoryStream.Create;\r\n try\r\n Stream.Write(Buffer^, GlobalSize(Data));\r\n Stream.Position := 0;\r\n Stream.Read(Size, SizeOf(Size));\r\n ReadStream(Size, Stream, False);\r\n if Count > 0 then\r\n begin\r\n FFrameIndex := 0;\r\n AData := GetClipboardData(CF_BITMAP);\r\n if AData <> 0 then\r\n begin\r\n Frames[0].NewBitmap;\r\n Frames[0].FBitmap.LoadFromClipboardFormat(CF_BITMAP, AData, APalette);\r\n end;\r\n end;\r\n finally\r\n Stream.Free;\r\n end;\r\n finally\r\n GlobalUnlock(Data);\r\n end;\r\n end\r\n else\r\n begin\r\n Bmp := TBitmap.Create;\r\n try\r\n Bmp.LoadFromClipboardFormat(AFormat, AData, APalette);\r\n Assign(Bmp);\r\n finally\r\n Bmp.Free;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvGIFImage.LoadFromStream(Stream: TStream);\r\nbegin\r\n ReadStream(Stream.Size - Stream.Position, Stream, True);\r\nend;\r\n\r\nprocedure TJvGIFImage.LoadFromResourceName(Instance: THandle; const ResName: string;\r\n ResType: PChar);\r\nvar\r\n Stream: TStream;\r\nbegin\r\n Stream := TResourceStream.Create(Instance, ResName, ResType);\r\n try\r\n ReadStream(Stream.Size - Stream.Position, Stream, True);\r\n finally\r\n Stream.Free;\r\n end;\r\nend;\r\n\r\nprocedure TJvGIFImage.LoadFromResourceID(Instance: THandle; ResID: Integer;\r\n ResType: PChar);\r\nvar\r\n Stream: TStream;\r\nbegin\r\n Stream := TResourceStream.CreateFromID(Instance, ResID, ResType);\r\n try\r\n ReadStream(Stream.Size - Stream.Position, Stream, True);\r\n finally\r\n Stream.Free;\r\n end;\r\nend;\r\n\r\nprocedure TJvGIFImage.UpdateScreenSize;\r\nvar\r\n I: Integer;\r\nbegin\r\n FScreenWidth := 0;\r\n FScreenHeight := 0;\r\n for I := 0 to FItems.Count - 1 do\r\n if Frames[I] <> nil then\r\n begin\r\n FScreenWidth := Max(FScreenWidth, Frames[I].Width +\r\n Frames[I].FTopLeft.X);\r\n FScreenHeight := Max(FScreenHeight, Frames[I].Height +\r\n Frames[I].FTopLeft.Y);\r\n end;\r\nend;\r\n\r\nfunction TJvGIFImage.AddFrame(Value: TGraphic): Integer;\r\nbegin\r\n FFrameIndex := FItems.Add(TJvGIFFrame.Create(Self));\r\n TJvGIFFrame(FItems[FFrameIndex]).Assign(Value);\r\n if FVersion = gvUnknown then\r\n FVersion := gv87a;\r\n if FItems.Count > 1 then\r\n FVersion := gv89a;\r\n Result := FFrameIndex;\r\nend;\r\n\r\nprocedure TJvGIFImage.DeleteFrame(Index: Integer);\r\nbegin\r\n Frames[Index].Free;\r\n FItems.Delete(Index);\r\n UpdateScreenSize;\r\n if FFrameIndex >= FItems.Count then\r\n Dec(FFrameIndex);\r\n Changed(Self);\r\nend;\r\n\r\nprocedure TJvGIFImage.MoveFrame(CurIndex, NewIndex: Integer);\r\nbegin\r\n FItems.Move(CurIndex, NewIndex);\r\n FFrameIndex := NewIndex;\r\n Changed(Self);\r\nend;\r\n\r\nprocedure TJvGIFImage.NewImage;\r\nbegin\r\n if FImage <> nil then\r\n FImage.Release;\r\n FImage := TGIFData.Create;\r\n FImage.Reference;\r\n if FItems = nil then\r\n FItems := TList.Create;\r\n ClearItems;\r\n FCorrupted := False;\r\n FFrameIndex := -1;\r\n FBackgroundColor := clNone;\r\n FRepeatCount := 1;\r\n FLooping := False;\r\n FVersion := gvUnknown;\r\nend;\r\n\r\nprocedure TJvGIFImage.UniqueImage;\r\nvar\r\n Temp: TGIFData;\r\nbegin\r\n if FImage = nil then\r\n NewImage\r\n else\r\n if FImage.RefCount > 1 then\r\n begin\r\n Temp := TGIFData.Create;\r\n with Temp do\r\n try\r\n FComment.Assign(FImage.FComment);\r\n FAspectRatio := FImage.FAspectRatio;\r\n FBitsPerPixel := FImage.FBitsPerPixel;\r\n FColorResBits := FImage.FColorResBits;\r\n FColorMap := FImage.FColorMap;\r\n except\r\n Temp.Free;\r\n raise;\r\n end;\r\n FImage.Release;\r\n FImage := Temp;\r\n FImage.Reference;\r\n end;\r\nend;\r\n\r\nfunction TJvGIFImage.GetComment: TStrings;\r\nbegin\r\n Result := FImage.FComment;\r\nend;\r\n\r\nprocedure TJvGIFImage.SetComment(Value: TStrings);\r\nbegin\r\n UniqueImage;\r\n FImage.FComment.Assign(Value);\r\nend;\r\n\r\nprocedure TJvGIFImage.DecodeAllFrames;\r\nvar\r\n FrameNo, I: Integer;\r\nbegin\r\n for FrameNo := 0 to FItems.Count - 1 do\r\n try\r\n TJvGIFFrame(FItems[FrameNo]).GetBitmap;\r\n except\r\n on EAbort do\r\n begin { OnProgress can raise EAbort to cancel image load }\r\n for I := FItems.Count - 1 downto FrameNo do\r\n begin\r\n TObject(FItems[I]).Free;\r\n FItems.Delete(I);\r\n end;\r\n FCorrupted := True;\r\n Break;\r\n end;\r\n else\r\n raise;\r\n end;\r\nend;\r\n\r\nprocedure TJvGIFImage.EncodeFrames(ReverseDecode: Boolean);\r\nvar\r\n FrameNo: Integer;\r\nbegin\r\n for FrameNo := 0 to FItems.Count - 1 do\r\n with TJvGIFFrame(FItems[FrameNo]) do\r\n begin\r\n if (FImage.FImageData = nil) or (FImage.FImageData.Size = 0) then\r\n begin\r\n FImage.FImageData.Free;\r\n FImage.FImageData := nil;\r\n EncodeRasterData;\r\n if ReverseDecode and (FBitmap.Palette = 0) then\r\n begin\r\n FBitmap.Free;\r\n FBitmap := nil;\r\n try\r\n GetBitmap;\r\n except\r\n on EAbort do\r\n ; { OnProgress can raise EAbort to cancel encoding }\r\n else\r\n raise;\r\n end;\r\n end;\r\n end;\r\n UpdateExtensions;\r\n end;\r\nend;\r\n\r\nprocedure TJvGIFImage.EncodeAllFrames;\r\nbegin\r\n EncodeFrames(True);\r\nend;\r\n\r\nprocedure TJvGIFImage.ReadData(Stream: TStream);\r\nvar\r\n Size: Longint;\r\nbegin\r\n Stream.Read(Size, SizeOf(Size));\r\n ReadStream(Size, Stream, True);\r\nend;\r\n\r\nprocedure TJvGIFImage.ReadSignature(Stream: TStream);\r\nvar\r\n I: TGIFVersion;\r\n S: TGifSignature;\r\nbegin\r\n FVersion := gvUnknown;\r\n Stream.Read(S[0], 3);\r\n if not CompareMem(@GIFSignature[0], @S[0], 3) then\r\n GifError(RsEGIFVersion);\r\n Stream.Read(S[0], 3);\r\n for I := Low(TGIFVersion) to High(TGIFVersion) do\r\n if CompareMem(@S[0], @GIFVersionStr[I][0], 3) then\r\n begin\r\n FVersion := I;\r\n Break;\r\n end;\r\n if FVersion = gvUnknown then\r\n GifError(RsEGIFVersion);\r\nend;\r\n\r\nprocedure TJvGIFImage.ReadStream(Size: Longint; Stream: TStream;\r\n ForceDecode: Boolean);\r\nvar\r\n SeparatorChar: AnsiChar;\r\n NewItem: TJvGIFFrame;\r\n Extensions: TList;\r\n ScreenDesc: TScreenDescriptor;\r\n Data: TMemoryStream;\r\n\r\n procedure ReadScreenDescriptor(Stream: TStream);\r\n begin\r\n Stream.Read(ScreenDesc, SizeOf(ScreenDesc));\r\n FScreenWidth := ScreenDesc.ScreenWidth;\r\n FScreenHeight := ScreenDesc.ScreenHeight;\r\n with FImage do\r\n begin\r\n FAspectRatio := ScreenDesc.AspectRatio;\r\n FBitsPerPixel := 1 + (ScreenDesc.PackedFields and\r\n LSD_COLOR_TABLE_SIZE);\r\n FColorResBits := 1 + (ScreenDesc.PackedFields and\r\n LSD_COLOR_RESOLUTION) shr 4;\r\n end;\r\n end;\r\n\r\n procedure ReadGlobalColorMap(Stream: TStream);\r\n begin\r\n if (ScreenDesc.PackedFields and LSD_GLOBAL_COLOR_TABLE) <> 0 then\r\n with FImage.FColorMap do\r\n begin\r\n Count := 1 shl FImage.FBitsPerPixel;\r\n Stream.Read(Colors[0], Count * SizeOf(TGIFColorItem));\r\n if Count > ScreenDesc.BackgroundColorIndex then\r\n FBackgroundColor := ItemToRGB(Colors[ScreenDesc.BackgroundColorIndex]);\r\n end;\r\n end;\r\n\r\n function ReadDataBlock(Stream: TStream): TStringList;\r\n var\r\n BlockSize: Byte;\r\n S: AnsiString;\r\n begin\r\n Result := TStringList.Create;\r\n try\r\n repeat\r\n Stream.Read(BlockSize, SizeOf(Byte));\r\n if BlockSize <> 0 then\r\n begin\r\n SetLength(S, BlockSize);\r\n Stream.Read(S[1], BlockSize);\r\n Result.Add(string(S));\r\n end;\r\n until (BlockSize = 0) or (Stream.Position >= Stream.Size);\r\n except\r\n Result.Free;\r\n raise;\r\n end;\r\n end;\r\n\r\n function ReadExtension(Stream: TStream): TExtension;\r\n var\r\n ExtensionLabel: Byte;\r\n begin\r\n Result := TExtension.Create;\r\n try\r\n Stream.Read(ExtensionLabel, SizeOf(Byte));\r\n with Result do\r\n begin\r\n if ExtensionLabel = ExtLabels[etGraphic] then\r\n begin\r\n { graphic control extension }\r\n FExtType := etGraphic;\r\n Stream.Read(FExtRec.GCE, SizeOf(TGraphicControlExtension));\r\n end\r\n else\r\n if ExtensionLabel = ExtLabels[etComment] then\r\n begin\r\n { comment extension }\r\n FExtType := etComment;\r\n FData := ReadDataBlock(Stream);\r\n end\r\n else\r\n if ExtensionLabel = ExtLabels[etPlainText] then\r\n begin\r\n { plain text extension }\r\n FExtType := etPlainText;\r\n Stream.Read(FExtRec.PTE, SizeOf(TPlainTextExtension));\r\n FData := ReadDataBlock(Stream);\r\n end\r\n else\r\n if ExtensionLabel = ExtLabels[etApplication] then\r\n begin\r\n { application extension }\r\n FExtType := etApplication;\r\n Stream.Read(FExtRec.APPE, SizeOf(TAppExtension));\r\n FData := ReadDataBlock(Stream);\r\n end\r\n else\r\n GifError(Format(RsEUnrecognizedGIFExt, [ExtensionLabel]));\r\n end;\r\n except\r\n Result.Free;\r\n raise;\r\n end;\r\n end;\r\n\r\n function ReadSeparator(Stream: TStream): AnsiChar;\r\n begin\r\n Result := #0;\r\n while (Stream.Size > Stream.Position) and (Result = #0) do\r\n Stream.Read(Result, SizeOf(Byte));\r\n end;\r\n\r\n function ReadExtensionBlock(Stream: TStream; var SeparatorChar: AnsiChar): TList;\r\n var\r\n NewExt: TExtension;\r\n begin\r\n Result := nil;\r\n try\r\n while SeparatorChar = CHR_EXT_INTRODUCER do\r\n begin\r\n NewExt := ReadExtension(Stream);\r\n if NewExt.FExtType = etPlainText then\r\n begin\r\n { plain text data blocks are not supported,\r\n clear all previous readed extensions }\r\n FreeExtensions(Result);\r\n Result := nil;\r\n end;\r\n if NewExt.FExtType in [etPlainText, etApplication] then\r\n begin\r\n { check for loop extension }\r\n if NewExt.IsLoopExtension then\r\n begin\r\n FLooping := True;\r\n FRepeatCount := Min(MakeWord(Byte(NewExt.FData[0][2]),\r\n Byte(NewExt.FData[0][3])), MAX_LOOP_COUNT);\r\n end;\r\n { not supported yet, must be ignored }\r\n NewExt.Free;\r\n end\r\n else\r\n begin\r\n if Result = nil then\r\n Result := TList.Create;\r\n Result.Add(NewExt);\r\n end;\r\n if Stream.Size > Stream.Position then\r\n SeparatorChar := ReadSeparator(Stream)\r\n else\r\n SeparatorChar := CHR_TRAILER;\r\n end;\r\n if (Result <> nil) and (Result.Count = 0) then\r\n begin\r\n Result.Free;\r\n Result := nil;\r\n end;\r\n except\r\n if Result <> nil then\r\n Result.Free;\r\n raise;\r\n end;\r\n end;\r\n\r\nvar\r\n I: Integer;\r\n Ext: TExtension;\r\nbegin\r\n NewImage;\r\n with FImage do\r\n begin\r\n if Size > 0 then\r\n begin\r\n Data := TMemoryStream.Create;\r\n try\r\n TMemoryStream(Data).SetSize(Size);\r\n Stream.ReadBuffer(Data.Memory^, Size);\r\n Data.Position := 0;\r\n ReadSignature(Data);\r\n ReadScreenDescriptor(Data);\r\n ReadGlobalColorMap(Data);\r\n SeparatorChar := ReadSeparator(Data);\r\n while not (SeparatorChar in [CHR_TRAILER, #0]) and not (Data.Position >= Data.Size) do\r\n begin\r\n Extensions := ReadExtensionBlock(Data, SeparatorChar);\r\n if SeparatorChar = CHR_IMAGE_SEPARATOR then\r\n try\r\n NewItem := TJvGIFFrame.Create(Self);\r\n try\r\n if FImage.FColorMap.Count > 0 then\r\n NewItem.FImage.FBitsPerPixel := ColorsToBits(FImage.FColorMap.Count);\r\n NewItem.FExtensions := Extensions;\r\n Extensions := nil;\r\n NewItem.LoadFromStream(Data);\r\n FItems.Add(NewItem);\r\n except\r\n NewItem.Free;\r\n raise;\r\n end;\r\n if not (Data.Position >= Data.Size) then\r\n SeparatorChar := ReadSeparator(Data)\r\n else\r\n SeparatorChar := CHR_TRAILER;\r\n if not (SeparatorChar in [CHR_EXT_INTRODUCER, CHR_IMAGE_SEPARATOR, CHR_TRAILER]) then\r\n begin\r\n SeparatorChar := #0;\r\n {GifError(RsEGIFDecodeError);}\r\n end;\r\n except\r\n FreeExtensions(Extensions);\r\n raise;\r\n end\r\n else\r\n if (FComment.Count = 0) and (Extensions <> nil) then\r\n begin\r\n try\r\n { trailig extensions }\r\n for I := 0 to Extensions.Count - 1 do\r\n begin\r\n Ext := TExtension(Extensions[I]);\r\n if (Ext <> nil) and (Ext.FExtType = etComment) then\r\n begin\r\n if FComment.Count > 0 then\r\n FComment.Add(CrLf + CrLf);\r\n FComment.AddStrings(Ext.FData);\r\n end;\r\n end;\r\n finally\r\n FreeExtensions(Extensions);\r\n end;\r\n end\r\n else\r\n if not (SeparatorChar in [CHR_TRAILER, #0]) then\r\n GifError(SReadError);\r\n end;\r\n finally\r\n Data.Free;\r\n end;\r\n end;\r\n end;\r\n if Count > 0 then\r\n begin\r\n FFrameIndex := 0;\r\n if ForceDecode then\r\n try\r\n GetBitmap; { force bitmap creation }\r\n except\r\n Frames[0].Free;\r\n FItems.Delete(0);\r\n raise;\r\n end;\r\n end;\r\n PaletteModified := True;\r\n Changed(Self);\r\nend;\r\n\r\nprocedure TJvGIFImage.SaveToClipboardFormat(var AFormat: Word; var AData: THandle;\r\n var APalette: HPALETTE);\r\nvar\r\n Stream: TMemoryStream;\r\n Data: THandle;\r\n Buffer: Pointer;\r\n I: Integer;\r\nbegin\r\n { !! check for gif clipboard format, mime type image/gif }\r\n if FItems.Count = 0 then\r\n Exit;\r\n Frames[0].Bitmap.SaveToClipboardFormat(AFormat, AData, APalette);\r\n for I := 0 to FItems.Count - 1 do\r\n with Frames[I] do\r\n begin\r\n if (FImage.FImageData = nil) or (FImage.FImageData.Size = 0) then\r\n Exit;\r\n end;\r\n Stream := TMemoryStream.Create;\r\n try\r\n WriteStream(Stream, True);\r\n Stream.Position := 0;\r\n Data := GlobalAlloc(GMEM_MOVEABLE, Stream.Size);\r\n try\r\n if Data <> 0 then\r\n begin\r\n Buffer := GlobalLock(Data);\r\n try\r\n Stream.Read(Buffer^, Stream.Size);\r\n SetClipboardData(CF_JVGIF, Data);\r\n finally\r\n GlobalUnlock(Data);\r\n end;\r\n end;\r\n except\r\n GlobalFree(Data);\r\n raise;\r\n end;\r\n finally\r\n Stream.Free;\r\n end;\r\nend;\r\n\r\nprocedure TJvGIFImage.WriteData(Stream: TStream);\r\nbegin\r\n WriteStream(Stream, True);\r\nend;\r\n\r\nprocedure TJvGIFImage.SetHeight(Value: Integer);\r\nbegin\r\n GifError(RsEChangeGIFSize);\r\nend;\r\n\r\nprocedure TJvGIFImage.SetWidth(Value: Integer);\r\nbegin\r\n GifError(RsEChangeGIFSize);\r\nend;\r\n\r\nprocedure TJvGIFImage.WriteStream(Stream: TStream; WriteSize: Boolean);\r\nvar\r\n Separator: Byte;\r\n Temp: Byte;\r\n FrameNo: Integer;\r\n Frame: TJvGIFFrame;\r\n Mem: TMemoryStream;\r\n Size: Longint;\r\n StrList: TStringList;\r\n\r\n procedure WriteSignature(Stream: TStream);\r\n var\r\n Header: TGIFHeader;\r\n begin\r\n Header.Signature := GIFSignature;\r\n Move(GIFVersionStr[FVersion][0], Header.Version[0], 3);\r\n Stream.Write(Header, SizeOf(TGIFHeader));\r\n end;\r\n\r\n procedure WriteScreenDescriptor(Stream: TStream);\r\n var\r\n ColorResBits: Byte;\r\n ScreenDesc: TScreenDescriptor;\r\n I: Integer;\r\n begin\r\n UpdateScreenSize;\r\n with ScreenDesc do\r\n begin\r\n ScreenWidth := Self.FScreenWidth;\r\n ScreenHeight := Self.FScreenHeight;\r\n AspectRatio := FImage.FAspectRatio;\r\n PackedFields := 0;\r\n BackgroundColorIndex := 0;\r\n if FImage.FColorMap.Count > 0 then\r\n begin\r\n PackedFields := PackedFields or LSD_GLOBAL_COLOR_TABLE;\r\n ColorResBits := ColorsToBits(FImage.FColorMap.Count);\r\n if FBackgroundColor <> clNone then\r\n for I := 0 to FImage.FColorMap.Count - 1 do\r\n if ColorToRGB(FBackgroundColor) =\r\n ItemToRGB(FImage.FColorMap.Colors[I]) then\r\n begin\r\n BackgroundColorIndex := I;\r\n Break;\r\n end;\r\n PackedFields := PackedFields + ((ColorResBits - 1) shl 4) +\r\n (FImage.FBitsPerPixel - 1);\r\n end;\r\n end;\r\n Stream.Write(ScreenDesc, SizeOf(ScreenDesc));\r\n end;\r\n\r\n procedure WriteDataBlock(Stream: TStream; Data: TStrings);\r\n var\r\n I: Integer;\r\n S: AnsiString;\r\n BlockSize: Byte;\r\n begin\r\n for I := 0 to Data.Count - 1 do\r\n begin\r\n S := AnsiString(Data[I]);\r\n BlockSize := Min(Length(S), 255);\r\n if BlockSize > 0 then\r\n begin\r\n Stream.Write(BlockSize, SizeOf(Byte));\r\n Stream.Write(S[1], BlockSize);\r\n end;\r\n end;\r\n BlockSize := 0;\r\n Stream.Write(BlockSize, SizeOf(Byte));\r\n end;\r\n\r\n procedure WriteExtensionBlock(Stream: TStream; Extensions: TList);\r\n var\r\n I: Integer;\r\n Ext: TExtension;\r\n ExtensionLabel: Byte;\r\n SeparateChar: Byte;\r\n begin\r\n SeparateChar := Byte(CHR_EXT_INTRODUCER);\r\n for I := 0 to Extensions.Count - 1 do\r\n begin\r\n Ext := TExtension(Extensions[I]);\r\n if Ext <> nil then\r\n begin\r\n Stream.Write(SeparateChar, SizeOf(Byte));\r\n ExtensionLabel := ExtLabels[Ext.FExtType];\r\n Stream.Write(ExtensionLabel, SizeOf(Byte));\r\n case Ext.FExtType of\r\n etGraphic:\r\n begin\r\n Stream.Write(Ext.FExtRec.GCE, SizeOf(TGraphicControlExtension));\r\n end;\r\n etComment:\r\n WriteDataBlock(Stream, Ext.FData);\r\n etPlainText:\r\n begin\r\n Stream.Write(Ext.FExtRec.PTE, SizeOf(TPlainTextExtension));\r\n WriteDataBlock(Stream, Ext.FData);\r\n end;\r\n etApplication:\r\n begin\r\n Stream.Write(Ext.FExtRec.APPE, SizeOf(TAppExtension));\r\n WriteDataBlock(Stream, Ext.FData);\r\n end;\r\n end;\r\n end;\r\n end;\r\n end;\r\n\r\nbegin\r\n if FItems.Count = 0 then\r\n GifError(RsENoGIFData);\r\n EncodeFrames(False);\r\n Mem := TMemoryStream.Create;\r\n try\r\n if FImage.FComment.Count > 0 then\r\n FVersion := gv89a;\r\n WriteSignature(Mem);\r\n WriteScreenDescriptor(Mem);\r\n if FImage.FColorMap.Count > 0 then\r\n with FImage.FColorMap do\r\n Mem.Write(Colors[0], Count * SizeOf(TGIFColorItem));\r\n\r\n if FLooping and (FItems.Count > 1) then\r\n begin\r\n { write looping extension }\r\n Separator := Byte(CHR_EXT_INTRODUCER);\r\n Mem.Write(Separator, SizeOf(Byte));\r\n Temp := ExtLabels[etApplication];\r\n Mem.Write(Temp, SizeOf(Byte));\r\n Temp := SizeOf(TAppExtension) - SizeOf(Byte);\r\n Mem.Write(Temp, SizeOf(Byte));\r\n Mem.Write(LoopExtNS[1], Temp);\r\n StrList := TStringList.Create;\r\n try\r\n StrList.Add(Char(AE_LOOPING) + Char(LoByte(FRepeatCount)) +\r\n Char(HiByte(FRepeatCount)));\r\n WriteDataBlock(Mem, StrList);\r\n finally\r\n StrList.Free;\r\n end;\r\n end;\r\n Separator := Byte(CHR_IMAGE_SEPARATOR);\r\n for FrameNo := 0 to FItems.Count - 1 do\r\n begin\r\n Frame := TJvGIFFrame(FItems[FrameNo]);\r\n if Frame.FExtensions <> nil then\r\n WriteExtensionBlock(Mem, Frame.FExtensions);\r\n Mem.Write(Separator, SizeOf(Byte));\r\n Frame.WriteImageDescriptor(Mem);\r\n Frame.WriteLocalColorMap(Mem);\r\n Frame.WriteRasterData(Mem);\r\n end;\r\n if FImage.FComment.Count > 0 then\r\n begin\r\n Separator := Byte(CHR_EXT_INTRODUCER);\r\n Mem.Write(Separator, SizeOf(Byte));\r\n Temp := ExtLabels[etComment];\r\n Mem.Write(Temp, SizeOf(Byte));\r\n WriteDataBlock(Mem, FImage.FComment);\r\n end;\r\n Separator := Byte(CHR_TRAILER);\r\n Mem.Write(Separator, SizeOf(Byte));\r\n Size := Mem.Size;\r\n if WriteSize then\r\n Stream.Write(Size, SizeOf(Size));\r\n Stream.Write(Mem.Memory^, Size);\r\n finally\r\n Mem.Free;\r\n end;\r\nend;\r\n\r\nprocedure TJvGIFImage.Grayscale(ForceEncoding: Boolean);\r\nvar\r\n I: Integer;\r\nbegin\r\n if FItems.Count = 0 then\r\n GifError(RsENoGIFData);\r\n for I := 0 to FItems.Count - 1 do\r\n Frames[I].GrayscaleImage(ForceEncoding);\r\n if FBackgroundColor <> clNone then\r\n begin\r\n if FImage.FColorMap.Count > 0 then\r\n begin\r\n I := FindColorIndex(FImage.FColorMap, FBackgroundColor);\r\n GrayColorTable(FImage.FColorMap);\r\n if I >= 0 then\r\n FBackgroundColor := ItemToRGB(FImage.FColorMap.Colors[I])\r\n else\r\n FBackgroundColor := GrayColor(FBackgroundColor);\r\n end\r\n else\r\n FBackgroundColor := GrayColor(FBackgroundColor);\r\n end;\r\n PaletteModified := True;\r\n Changed(Self);\r\nend;\r\n\r\nprocedure TJvGIFImage.SaveToStream(Stream: TStream);\r\nbegin\r\n WriteStream(Stream, False);\r\nend;\r\n\r\nprocedure TJvGIFImage.DoProgress(Stage: TProgressStage; PercentDone: Byte;\r\n const Msg: string);\r\nbegin\r\n Progress(Self, Stage, PercentDone, False, Rect(0, 0, 0, 0), Msg);\r\nend;\r\n\r\nprocedure Init;\r\nbegin\r\n CF_JVGIF := RegisterClipboardFormat('JvGIF Image');\r\n {$IFDEF COMPILER7_UP}\r\n GroupDescendentsWith(TJvGIFFrame, TControl);\r\n GroupDescendentsWith(TJvGIFImage, TControl);\r\n {$ENDIF COMPILER7_UP}\r\n RegisterClasses([TJvGIFFrame, TJvGIFImage]);\r\n {$IFDEF USE_JV_GIF}\r\n TPicture.RegisterFileFormat('gif', RsGIFImage, TJvGIFImage);\r\n {$ELSE}\r\n TPicture.RegisterFileFormat('', '', TJvGIFImage); // register for loading but do not show in FileDialog\r\n {$ENDIF USE_JV_GIF}\r\n TPicture.RegisterClipboardFormat(CF_JVGIF, TJvGIFImage);\r\n\r\n RegisterGraphicSignature('GIF', 0, TJvGIFImage);\r\nend;\r\n\r\ninitialization\r\n {$IFDEF UNITVERSIONING}\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n {$ENDIF UNITVERSIONING}\r\n Init;\r\n\r\nfinalization\r\n TPicture.UnRegisterGraphicClass(TJvGIFImage);\r\n {$IFDEF UNITVERSIONING}\r\n UnregisterUnitVersion(HInstance);\r\n {$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvGIFCtrl.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvGIFCtrl.PAS, released on 2002-07-04.\r\n\r\nThe Initial Developers of the Original Code are: Fedor Koshevnikov, Igor Pavluk and Serge Korolev\r\nCopyright (c) 1997, 1998 Fedor Koshevnikov, Igor Pavluk and Serge Korolev\r\nCopyright (c) 2001,2002 SGB Software\r\nAll Rights Reserved.\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvGIFCtrl.pas 13104 2011-09-07 06:50:43Z obones $\r\n\r\nunit JvGIFCtrl;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Messages, Windows, SysUtils, Classes, Graphics, Controls, Forms, Menus,\r\n JvAnimatedImage, JvGIF, JvTimer;\r\n\r\ntype\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvGIFAnimator = class(TJvImageControl)\r\n private\r\n FAnimate: Boolean;\r\n FImage: TJvGIFImage;\r\n FTimer: TJvTimer;\r\n FFrameIndex: Integer;\r\n FStretch: Boolean;\r\n FLoop: Boolean;\r\n FCenter: Boolean;\r\n FTransparent: Boolean;\r\n FTimerRepaint: Boolean;\r\n FCache: TBitmap;\r\n FCacheIndex: Integer;\r\n FTransColor: TColor;\r\n FAsyncDrawing: Boolean;\r\n FOnStart: TNotifyEvent;\r\n FOnStop: TNotifyEvent;\r\n FOnChange: TNotifyEvent;\r\n FOnFrameChanged: TNotifyEvent;\r\n procedure TimerDeactivate;\r\n function GetFrameBitmap(Index: Integer; var TransColor: TColor): TBitmap;\r\n function GetDelayTime(Index: Integer): Cardinal;\r\n procedure SetAsyncDrawing(Value: Boolean);\r\n procedure SetAnimate(Value: Boolean);\r\n procedure SetCenter(Value: Boolean);\r\n procedure SetImage(Value: TJvGIFImage);\r\n procedure SetFrameIndex(Value: Integer);\r\n procedure SetStretch(Value: Boolean);\r\n procedure SetTransparent(Value: Boolean);\r\n procedure ImageChanged(Sender: TObject);\r\n procedure TimerExpired(Sender: TObject);\r\n { Backwards compatibility; eventually remove }\r\n procedure ReadJvxAnimate(Reader: TReader);\r\n function GetThreaded: Boolean;\r\n procedure SetThreaded(const Value: Boolean);\r\n protected\r\n function CanAutoSize(var NewWidth, NewHeight: Integer): Boolean; override;\r\n function GetPalette: HPALETTE; override;\r\n procedure AdjustSize; override;\r\n procedure BufferedPaint; override;\r\n procedure DoPaintImage; override;\r\n procedure Change; dynamic;\r\n procedure FrameChanged; dynamic;\r\n procedure Start; dynamic;\r\n procedure Stop; dynamic;\r\n { Backwards compatibility; eventually remove }\r\n procedure DefineProperties(Filer: TFiler); override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n published\r\n property AsyncDrawing: Boolean read FAsyncDrawing write SetAsyncDrawing default False;\r\n property Animate: Boolean read FAnimate write SetAnimate default False;\r\n property AutoSize default True;\r\n property Center: Boolean read FCenter write SetCenter default False;\r\n property FrameIndex: Integer read FFrameIndex write SetFrameIndex default 0;\r\n property Image: TJvGIFImage read FImage write SetImage;\r\n property Loop: Boolean read FLoop write FLoop default True;\r\n property Stretch: Boolean read FStretch write SetStretch default False;\r\n property Transparent: Boolean read FTransparent write SetTransparent default True;\r\n property Threaded: Boolean read GetThreaded write SetThreaded default True;\r\n property Anchors;\r\n property Constraints;\r\n property DragKind;\r\n property Align;\r\n property Cursor;\r\n property DragCursor;\r\n property DragMode;\r\n property Enabled;\r\n property ParentShowHint;\r\n property PopupMenu;\r\n property ShowHint;\r\n property Visible;\r\n property OnChange: TNotifyEvent read FOnChange write FOnChange;\r\n property OnFrameChanged: TNotifyEvent read FOnFrameChanged write FOnFrameChanged;\r\n property OnStart: TNotifyEvent read FOnStart write FOnStart;\r\n property OnStop: TNotifyEvent read FOnStop write FOnStop;\r\n property OnClick;\r\n property OnDblClick;\r\n property OnDragOver;\r\n property OnDragDrop;\r\n property OnEndDrag;\r\n property OnMouseMove;\r\n property OnMouseDown;\r\n property OnMouseUp;\r\n property OnContextPopup;\r\n property OnStartDrag;\r\n property OnEndDock;\r\n property OnStartDock;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvGIFCtrl.pas $';\r\n Revision: '$Revision: 13104 $';\r\n Date: '$Date: 2011-09-07 08:50:43 +0200 (mer. 07 sept. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n Math,\r\n JvJCLUtils, JvJVCLUtils;\r\n\r\nconst\r\n { Maximum delay (10 sec) guarantees that a very long and slow\r\n GIF does not hang the system }\r\n MaxDelayTime = 10000;\r\n MinDelayTime = 50;\r\n\r\nprocedure TJvGIFAnimator.AdjustSize;\r\nbegin\r\n if not (csReading in ComponentState) then\r\n if AutoSize and Assigned(FImage) and not FImage.Empty then\r\n SetBounds(Left, Top, FImage.ScreenWidth, FImage.ScreenHeight);\r\nend;\r\n\r\nfunction TJvGIFAnimator.CanAutoSize(var NewWidth, NewHeight: Integer): Boolean;\r\nbegin\r\n Result := True;\r\n if not (csDesigning in ComponentState) and Assigned(FImage) and\r\n not FImage.Empty then\r\n begin\r\n if Align in [alNone, alLeft, alRight] then\r\n NewWidth := FImage.ScreenWidth;\r\n if Align in [alNone, alTop, alBottom] then\r\n NewHeight := FImage.ScreenHeight;\r\n end;\r\nend;\r\n\r\nprocedure TJvGIFAnimator.Change;\r\nbegin\r\n if Assigned(FOnChange) then\r\n FOnChange(Self);\r\nend;\r\n\r\nconstructor TJvGIFAnimator.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FTimer := TJvTimer.Create(Self);\r\n FTimer.Threaded := True;\r\n AutoSize := True;\r\n FImage := TJvGIFImage.Create;\r\n FGraphic := FImage;\r\n FImage.OnChange := ImageChanged;\r\n FCacheIndex := -1;\r\n FTransColor := clNone;\r\n FLoop := True;\r\n FTransparent := True;\r\nend;\r\n\r\nprocedure TJvGIFAnimator.DefineProperties(Filer: TFiler);\r\nbegin\r\n inherited DefineProperties(Filer);\r\n Filer.DefineProperty('JvxAnimate', ReadJvxAnimate, nil, False);\r\nend;\r\n\r\ndestructor TJvGIFAnimator.Destroy;\r\nbegin\r\n FTimer.OnTimer := nil; // terminate timer thread\r\n FTimer.Enabled := False;\r\n Destroying; // ??? ahuser: this is the job of TComponent.Destroy, why is it called here?\r\n FOnStart := nil;\r\n FOnStop := nil;\r\n FOnChange := nil;\r\n FOnFrameChanged := nil;\r\n Animate := False;\r\n FCache.Free;\r\n FImage.OnChange := nil;\r\n FImage.Free;\r\n FreeAndNil(FTimer); // Note: not really required (VCL does it for us), but cleaner\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvGIFAnimator.DoPaintImage;\r\nvar\r\n Frame: TBitmap;\r\n Dest: TRect;\r\n TransColor: TColor;\r\nbegin\r\n { copy image from parent and back-level controls }\r\n if FImage.Transparent or FImage.Empty then\r\n CopyParentImage(Self, Canvas);\r\n if (not FImage.Empty) and (FImage.ScreenWidth > 0) and\r\n (FImage.ScreenHeight > 0) then\r\n begin\r\n TransColor := clNone;\r\n Frame := GetFrameBitmap(FrameIndex, TransColor);\r\n Frame.Canvas.Lock;\r\n try\r\n if Stretch then\r\n Dest := ClientRect\r\n else\r\n if Center then\r\n Dest := Bounds((ClientWidth - Frame.Width) div 2,\r\n (ClientHeight - Frame.Height) div 2, Frame.Width, Frame.Height)\r\n else\r\n Dest := Rect(0, 0, Frame.Width, Frame.Height);\r\n if (TransColor = clNone) or not FTransparent then\r\n Canvas.StretchDraw(Dest, Frame)\r\n else\r\n begin\r\n StretchBitmapRectTransparent(Canvas, Dest.Left, Dest.Top,\r\n RectWidth(Dest), RectHeight(Dest), Bounds(0, 0, Frame.Width,\r\n Frame.Height), Frame, TransColor);\r\n end;\r\n finally\r\n Frame.Canvas.Unlock;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvGIFAnimator.FrameChanged;\r\nbegin\r\n if Assigned(FOnFrameChanged) then\r\n FOnFrameChanged(Self);\r\nend;\r\n\r\nfunction TJvGIFAnimator.GetDelayTime(Index: Integer): Cardinal;\r\nbegin\r\n if (FFrameIndex >= 0) and (FFrameIndex < FImage.Count) and\r\n (FImage.Count > 1) then\r\n begin\r\n Result := FImage.Frames[FFrameIndex].AnimateInterval;\r\n if Result < MinDelayTime then\r\n Result := MinDelayTime\r\n else\r\n if Result > MaxDelayTime then\r\n Result := MaxDelayTime;\r\n end\r\n else\r\n Result := 0;\r\nend;\r\n\r\nfunction TJvGIFAnimator.GetFrameBitmap(Index: Integer;\r\n var TransColor: TColor): TBitmap;\r\nvar\r\n I, Last, First: Integer;\r\n SavePal: HPALETTE;\r\n UseCache: Boolean;\r\nbegin\r\n Index := Min(Index, FImage.Count - 1);\r\n UseCache := (FCache <> nil) and (FCacheIndex = Index - 1) and (FCacheIndex >= 0) and\r\n (FImage.Frames[FCacheIndex].DisposalMethod <> dmRestorePrevious);\r\n if UseCache then\r\n begin\r\n Result := FCache;\r\n TransColor := FTransColor;\r\n end\r\n else\r\n begin\r\n FCache.Free;\r\n FCache := nil;\r\n Result := TJvLockedBitmap.Create;\r\n end;\r\n Result.Canvas.Lock;\r\n try\r\n with Result do\r\n begin\r\n if not UseCache then\r\n begin\r\n Width := FImage.ScreenWidth;\r\n Height := FImage.ScreenHeight;\r\n end;\r\n Last := Index;\r\n First := Max(0, Last);\r\n SavePal := 0;\r\n if FImage.Palette <> 0 then\r\n begin\r\n SavePal := SelectPalette(Canvas.Handle, FImage.Palette, False);\r\n RealizePalette(Canvas.Handle);\r\n end;\r\n if not UseCache then\r\n begin\r\n if (FImage.Frames[FImage.FrameIndex].TransparentColor <> clNone) then\r\n begin\r\n TransColor := GetNearestColor(Canvas.Handle,\r\n ColorToRGB(FImage.Frames[FImage.FrameIndex].TransparentColor));\r\n Canvas.Brush.Color := PaletteColor(TransColor);\r\n end\r\n else\r\n if (FImage.BackgroundColor <> clNone) and FImage.Transparent then\r\n Canvas.Brush.Color := PaletteColor(FImage.BackgroundColor)\r\n else\r\n Canvas.Brush.Color := PaletteColor(clWindow);\r\n Canvas.FillRect(Bounds(0, 0, Width, Height));\r\n while First > 0 do\r\n begin\r\n if (FImage.ScreenWidth = FImage.Frames[First].Width) and\r\n (FImage.ScreenHeight = FImage.Frames[First].Height) then\r\n begin\r\n if (FImage.Frames[First].TransparentColor = clNone) or\r\n ((FImage.Frames[First].DisposalMethod = dmRestoreBackground) and\r\n (First < Last)) then\r\n Break;\r\n end;\r\n Dec(First);\r\n end;\r\n for I := First to Last - 1 do\r\n begin\r\n with FImage.Frames[I] do\r\n case DisposalMethod of\r\n dmUndefined, dmLeave:\r\n Draw(Canvas, Bounds(Origin.X, Origin.Y, Width, Height), True);\r\n dmRestoreBackground:\r\n if I > First then\r\n Canvas.FillRect(Bounds(Origin.X, Origin.Y, Width, Height));\r\n dmRestorePrevious:\r\n begin { do nothing }\r\n end;\r\n end;\r\n end;\r\n end\r\n else\r\n begin\r\n with FImage.Frames[FCacheIndex] do\r\n if DisposalMethod = dmRestoreBackground then\r\n Canvas.FillRect(Bounds(Origin.X, Origin.Y, Width, Height));\r\n end;\r\n with FImage.Frames[Last] do\r\n Draw(Canvas, Bounds(Origin.X, Origin.Y, Width, Height), True);\r\n if (not UseCache) and (TransColor <> clNone) and FTransparent then\r\n begin\r\n TransparentColor := PaletteColor(TransColor);\r\n Transparent := True;\r\n end;\r\n if FImage.Palette <> 0 then\r\n SelectPalette(Canvas.Handle, SavePal, False);\r\n end;\r\n FCache := Result;\r\n FCacheIndex := Index;\r\n FTransColor := TransColor;\r\n Result.Canvas.Unlock;\r\n except\r\n Result.Canvas.Unlock;\r\n if not UseCache then\r\n Result.Free;\r\n raise;\r\n end;\r\nend;\r\n\r\nfunction TJvGIFAnimator.GetPalette: HPALETTE;\r\nbegin\r\n Result := 0;\r\n if not FImage.Empty then\r\n Result := FImage.Palette;\r\nend;\r\n\r\nfunction TJvGIFAnimator.GetThreaded: Boolean;\r\nbegin\r\n Result := FTimer.Threaded;\r\nend;\r\n\r\nprocedure TJvGIFAnimator.ImageChanged(Sender: TObject);\r\nbegin\r\n Lock;\r\n try\r\n FCacheIndex := -1;\r\n FCache.Free;\r\n FCache := nil;\r\n FTransColor := clNone;\r\n FFrameIndex := FImage.FrameIndex;\r\n if (FFrameIndex >= 0) and (FImage.Count > 0) then\r\n FTimer.Interval := GetDelayTime(FFrameIndex);\r\n finally\r\n Unlock;\r\n end;\r\n PictureChanged;\r\n Change;\r\nend;\r\n\r\nprocedure TJvGIFAnimator.BufferedPaint;\r\nbegin\r\n PaintImage;\r\n if FImage.Transparent or FImage.Empty then\r\n PaintDesignRect;\r\nend;\r\n\r\nprocedure TJvGIFAnimator.ReadJvxAnimate(Reader: TReader);\r\nbegin\r\n Animate := Reader.ReadBoolean;\r\nend;\r\n\r\nprocedure TJvGIFAnimator.SetAnimate(Value: Boolean);\r\nbegin\r\n if FAnimate <> Value then\r\n begin\r\n if Value then\r\n begin\r\n FTimer.OnTimer := TimerExpired;\r\n FTimer.Enabled := True;\r\n FAnimate := FTimer.Enabled;\r\n Start;\r\n end\r\n else\r\n begin\r\n FTimer.Enabled := False;\r\n FTimer.OnTimer := nil;\r\n FAnimate := False;\r\n Stop;\r\n PictureChanged;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvGIFAnimator.SetAsyncDrawing(Value: Boolean);\r\nbegin\r\n if FAsyncDrawing <> Value then\r\n begin\r\n Lock;\r\n try\r\n if Assigned(FTimer) then\r\n FTimer.SyncEvent := not Value;\r\n FAsyncDrawing := Value;\r\n finally\r\n Unlock;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvGIFAnimator.SetCenter(Value: Boolean);\r\nbegin\r\n if Value <> FCenter then\r\n begin\r\n Lock;\r\n try\r\n FCenter := Value;\r\n finally\r\n Unlock;\r\n end;\r\n PictureChanged;\r\n if Animate then\r\n Repaint;\r\n end;\r\nend;\r\n\r\nprocedure TJvGIFAnimator.SetFrameIndex(Value: Integer);\r\nbegin\r\n if Value <> FFrameIndex then\r\n begin\r\n if (Value < FImage.Count) and (Value >= 0) then\r\n begin\r\n Lock;\r\n try\r\n FFrameIndex := Value;\r\n if (FFrameIndex >= 0) and (FImage.Count > 0) then\r\n FTimer.Interval := GetDelayTime(FFrameIndex);\r\n finally\r\n Unlock;\r\n end;\r\n FrameChanged;\r\n PictureChanged;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvGIFAnimator.SetImage(Value: TJvGIFImage);\r\nbegin\r\n Lock;\r\n try\r\n FImage.Assign(Value);\r\n finally\r\n Unlock;\r\n end;\r\nend;\r\n\r\nprocedure TJvGIFAnimator.SetStretch(Value: Boolean);\r\nbegin\r\n if Value <> FStretch then\r\n begin\r\n Lock;\r\n try\r\n FStretch := Value;\r\n finally\r\n Unlock;\r\n end;\r\n PictureChanged;\r\n if Animate then\r\n Repaint;\r\n end;\r\nend;\r\n\r\nprocedure TJvGIFAnimator.SetThreaded(const Value: Boolean);\r\nbegin\r\n FTimer.Threaded := Value;\r\nend;\r\n\r\nprocedure TJvGIFAnimator.SetTransparent(Value: Boolean);\r\nbegin\r\n if Value <> FTransparent then\r\n begin\r\n Lock;\r\n try\r\n FTransparent := Value;\r\n finally\r\n Unlock;\r\n end;\r\n PictureChanged;\r\n if Animate then\r\n Repaint;\r\n end;\r\nend;\r\n\r\nprocedure TJvGIFAnimator.Start;\r\nbegin\r\n if Assigned(FOnStart) then\r\n FOnStart(Self);\r\nend;\r\n\r\nprocedure TJvGIFAnimator.Stop;\r\nbegin\r\n if Assigned(FOnStop) then\r\n FOnStop(Self);\r\nend;\r\n\r\nprocedure TJvGIFAnimator.TimerDeactivate;\r\nvar\r\n F: TCustomForm;\r\nbegin\r\n SetAnimate(False);\r\n if csDesigning in ComponentState then\r\n begin\r\n F := GetParentForm(Self);\r\n if (F <> nil) and (F.Designer <> nil) then\r\n F.Designer.Modified;\r\n end;\r\nend;\r\n\r\nprocedure TJvGIFAnimator.TimerExpired(Sender: TObject);\r\nbegin\r\n if (csPaintCopy in ControlState) or (csDestroying in ComponentState) then\r\n Exit;\r\n if Visible and (FImage.Count > 1) and (Parent <> nil) and\r\n Parent.HandleAllocated then\r\n begin\r\n Lock;\r\n try\r\n if FFrameIndex < FImage.Count - 1 then\r\n Inc(FFrameIndex)\r\n else\r\n FFrameIndex := 0;\r\n Canvas.Lock;\r\n try\r\n FTimerRepaint := True;\r\n if AsyncDrawing and Assigned(FOnFrameChanged) then\r\n FTimer.Synchronize(FrameChanged)\r\n else\r\n FrameChanged;\r\n DoPaintControl;\r\n finally\r\n FTimerRepaint := False;\r\n Canvas.Unlock;\r\n if (FFrameIndex >= 0) and (FFrameIndex < FImage.Count) then\r\n FTimer.Interval := GetDelayTime(FFrameIndex);\r\n end;\r\n if not FLoop and (FFrameIndex = 0) then\r\n if AsyncDrawing then\r\n FTimer.Synchronize(TimerDeactivate)\r\n else\r\n TimerDeactivate;\r\n finally\r\n Unlock;\r\n end;\r\n end;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvGammaPanel.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvGammaPanel.PAS, released on 2001-02-28.\r\n\r\nThe Initial Developer of the Original Code is Sbastien Buysse [sbuysse att buypin dott com]\r\nPortions created by Sbastien Buysse are Copyright (C) 2001 Sbastien Buysse.\r\nAll Rights Reserved.\r\n\r\nContributor(s): Michael Beck [mbeck att bigfoot dott com].\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nModifications:\r\n 2/11/2000 Added the Align and AutoSize property (Request of Brad T.)\r\n 2004/01/06 VisualCLX compatibilty\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvGammaPanel.pas 13104 2011-09-07 06:50:43Z obones $\r\n\r\nunit JvGammaPanel;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Types, SysUtils, Classes, Windows, Messages, Graphics, Controls, Dialogs,\r\n ExtCtrls, StdCtrls,\r\n JvTypes, JvComponent;\r\n\r\ntype\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvGammaPanel = class(TJvWinControl)\r\n private\r\n FForegroundColor: TColor;\r\n FBackgroundColor: TColor;\r\n LastCol: TColor;\r\n FPanel1: TPanel;\r\n FPanel2: TPanel;\r\n FPanel3: TPanel;\r\n FPanel4: TPanel;\r\n FRLabel: TLabel;\r\n FGLabel: TLabel;\r\n FBLabel: TLabel;\r\n FXLabel: TLabel;\r\n FGamma: TImage;\r\n FChoosed: TImage;\r\n FForegroundColorImg: TImage;\r\n FBackgroundColorImg: TImage;\r\n FOnChangeColor: TJvChangeColorEvent;\r\n procedure ChangeColor(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);\r\n procedure ColorSeek(Sender: TObject; Shift: TShiftState; X, Y: Integer);\r\n procedure Exchange(Sender: TObject);\r\n procedure SetForegroundColor(const Value: TColor);\r\n procedure SetBackgroundColor(const Value: TColor);\r\n procedure Color1Click(Sender: TObject);\r\n procedure Color2Click(Sender: TObject);\r\n protected\r\n procedure BoundsChanged; override;\r\n procedure DoChangeColor(AForegroundColor, ABackgroundColor: TColor); virtual;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n published\r\n property Align;\r\n property AutoSize;\r\n property Height default 250;\r\n property Width default 65;\r\n property ForegroundColor: TColor read FForegroundColor write SetForegroundColor default clBlack;\r\n property BackgroundColor: TColor read FBackgroundColor write SetBackgroundColor default clWhite;\r\n property OnChangeColor: TJvChangeColorEvent read FOnChangeColor write FOnChangeColor;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvGammaPanel.pas $';\r\n Revision: '$Revision: 13104 $';\r\n Date: '$Date: 2011-09-07 08:50:43 +0200 (mer. 07 sept. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n JvResources;\r\n\r\n{$R JvGammaPanel.res}\r\n\r\nconstructor TJvGammaPanel.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n Width := 65;\r\n Height := 250;\r\n FForegroundColor := clBlack;\r\n FBackgroundColor := clWhite;\r\n\r\n FPanel1 := TPanel.Create(Self);\r\n with FPanel1 do\r\n begin\r\n Parent := Self;\r\n Width := 65;\r\n Height := 250;\r\n Align := alClient;\r\n BevelInner := bvLowered;\r\n BevelOuter := bvRaised;\r\n Visible := True;\r\n end;\r\n\r\n FPanel2 := TPanel.Create(FPanel1);\r\n with FPanel2 do\r\n begin\r\n Parent := FPanel1;\r\n Left := 5;\r\n Top := 5;\r\n Width := 55;\r\n Height := 105;\r\n BevelInner := bvLowered;\r\n BevelOuter := bvRaised;\r\n Visible := True;\r\n end;\r\n\r\n FPanel3 := TPanel.Create(FPanel1);\r\n with FPanel3 do\r\n begin\r\n Parent := FPanel1;\r\n Left := 5;\r\n Top := 115;\r\n Width := 55;\r\n Height := 50;\r\n BevelInner := bvLowered;\r\n BevelOuter := bvRaised;\r\n Visible := True;\r\n end;\r\n\r\n FPanel4 := TPanel.Create(FPanel1);\r\n with FPanel4 do\r\n begin\r\n Parent := FPanel1;\r\n Left := 5;\r\n Top := 170;\r\n Width := 55;\r\n Height := 75;\r\n BevelInner := bvLowered;\r\n BevelOuter := bvRaised;\r\n Visible := True;\r\n end;\r\n\r\n FRLabel := TLabel.Create(FPanel4);\r\n with FRLabel do\r\n begin\r\n Top := 2;\r\n Left := 5;\r\n AutoSize := True;\r\n Font.Size := 8;\r\n Font.Name := 'Arial';\r\n Caption := RsDefaultR;\r\n Transparent := True;\r\n Parent := FPanel4;\r\n end;\r\n\r\n FGLabel := TLabel.Create(FPanel4);\r\n with FGLabel do\r\n begin\r\n Top := 14;\r\n Left := 5;\r\n AutoSize := True;\r\n Font.Name := 'Arial';\r\n Font.Size := 8;\r\n Caption := RsDefaultG;\r\n Transparent := True;\r\n Parent := FPanel4;\r\n end;\r\n\r\n FBLabel := TLabel.Create(FPanel4);\r\n with FBLabel do\r\n begin\r\n Top := 26;\r\n Left := 5;\r\n Font.Size := 8;\r\n Font.Name := 'arial';\r\n AutoSize := True;\r\n Caption := RsDefaultB;\r\n Transparent := True;\r\n Parent := FPanel4;\r\n end;\r\n\r\n FGamma := TImage.Create(FPanel2);\r\n with FGamma do\r\n begin\r\n Parent := FPanel2;\r\n Stretch := False;\r\n Center := True;\r\n AutoSize := True;\r\n Picture.Bitmap.PixelFormat := pf24bit;\r\n Width := 55;\r\n Height := 105;\r\n OnMouseDown := ChangeColor;\r\n OnMouseMove := ColorSeek;\r\n Align := alClient;\r\n Picture.Bitmap.LoadFromResourceName(HInstance, 'JvGammaPanelCOLORS');\r\n Cursor := crCross;\r\n end;\r\n\r\n FChoosed := TImage.Create(FPanel4);\r\n with FChoosed do\r\n begin\r\n Top := 40;\r\n Left := 12;\r\n Width := 30;\r\n Height := 30;\r\n Parent := FPanel4;\r\n Visible := True;\r\n Stretch := False;\r\n Align := alNone;\r\n// Picture.Bitmap := TBitmap.Create;\r\n Picture.Bitmap.Width := Width;\r\n Picture.Bitmap.Height := Height;\r\n Canvas.Brush.Color := clBlack;\r\n Canvas.Brush.Style := bsSolid;\r\n Canvas.FillRect(Rect(0, 0, Width, Height));\r\n end;\r\n\r\n FForegroundColorImg := TImage.Create(FPanel3);\r\n with FForegroundColorImg do\r\n begin\r\n Left := 5;\r\n Top := 5;\r\n Width := 25;\r\n Height := 25;\r\n// Picture.Bitmap := TBitmap.Create;\r\n Picture.Bitmap.Width := FChoosed.Width;\r\n Picture.Bitmap.Height := FChoosed.Height;\r\n Canvas.Brush.Color := clBlack;\r\n Canvas.Brush.Style := bsSolid;\r\n Canvas.FillRect(Rect(0, 0, FChoosed.Width, FChoosed.Height));\r\n Hint := RsHint2;\r\n ShowHint := True;\r\n OnClick := Color1Click;\r\n Parent := FPanel3;\r\n Visible := True;\r\n end;\r\n\r\n FBackgroundColorImg := TImage.Create(FPanel3);\r\n with FBackgroundColorImg do\r\n begin\r\n Left := 25;\r\n Top := 20;\r\n Height := 25;\r\n Width := 25;\r\n// Picture.Bitmap := TBitmap.Create;\r\n Picture.Bitmap.Width := FChoosed.Width;\r\n Picture.Bitmap.Height := FChoosed.Height;\r\n Canvas.Brush.Color := clWhite;\r\n Canvas.Brush.Style := bsSolid;\r\n Canvas.FillRect(Rect(0, 0, FChoosed.Width, FChoosed.Height));\r\n Hint := RsHint1;\r\n ShowHint := True;\r\n OnClick := Color2Click;\r\n Parent := FPanel3;\r\n Visible := True;\r\n end;\r\n\r\n FXLabel := TLabel.Create(FPanel3);\r\n with FXLabel do\r\n begin\r\n Left := 7;\r\n Top := 32;\r\n AutoSize := True;\r\n Caption := RsXCaption;\r\n Hint := RsLabelHint;\r\n OnClick := Exchange;\r\n ShowHint := True;\r\n Visible := True;\r\n Parent := FPanel3;\r\n end;\r\nend;\r\n\r\nprocedure TJvGammaPanel.ChangeColor(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);\r\nbegin\r\n if Button = mbLeft then\r\n begin\r\n FForegroundColor := LastCol;\r\n FForegroundColorImg.Canvas.Brush.Color := FForegroundColor;\r\n FForegroundColorImg.Canvas.Brush.Style := bsSolid;\r\n FForegroundColorImg.Canvas.FillRect(Rect(0, 0, FChoosed.Width, FChoosed.Height));\r\n DoChangeColor(FForegroundColor, FBackgroundColor);\r\n end\r\n else\r\n if Button = mbRight then\r\n begin\r\n FBackgroundColor := LastCol;\r\n FBackgroundColorImg.Canvas.Brush.Color := FBackgroundColor;\r\n FBackgroundColorImg.Canvas.Brush.Style := bsSolid;\r\n FBackgroundColorImg.Canvas.FillRect(Rect(0, 0, FChoosed.Width, FChoosed.Height));\r\n DoChangeColor(FForegroundColor, FBackgroundColor);\r\n end;\r\nend;\r\n\r\nprocedure TJvGammaPanel.Color1Click(Sender: TObject);\r\nbegin\r\n with TColorDialog.Create(Self) do\r\n begin\r\n if Execute then\r\n SetForegroundColor(Color);\r\n Free;\r\n end;\r\nend;\r\n\r\nprocedure TJvGammaPanel.Color2Click(Sender: TObject);\r\nbegin\r\n with TColorDialog.Create(Self) do\r\n begin\r\n if Execute then\r\n SetBackgroundColor(Color);\r\n Free;\r\n end;\r\nend;\r\n\r\nprocedure TJvGammaPanel.ColorSeek(Sender: TObject; Shift: TShiftState; X, Y: Integer);\r\nvar\r\n Col: TColor;\r\nbegin\r\n if not PtInRect(Bounds(0, 0, FGamma.Picture.Width, FGamma.Picture.Height), Point(X,Y)) then\r\n Exit; // asn for Linux/X11\r\n Col := FGamma.Picture.Bitmap.Canvas.Pixels[X, Y];\r\n LastCol := Col;\r\n FRLabel.Caption := Format(RsRedFormat, [GetRValue(Col)]);\r\n FGLabel.Caption := Format(RsGreenFormat, [GetGValue(Col)]);\r\n FBLabel.Caption := Format(RsBlueFormat, [GetBValue(Col)]);\r\n FChoosed.Canvas.Brush.Color := Col;\r\n FChoosed.Canvas.Brush.Style := bsSolid;\r\n FChoosed.Canvas.FillRect(Rect(0, 0, FChoosed.Width, FChoosed.Height));\r\nend;\r\n\r\nprocedure TJvGammaPanel.Exchange(Sender: TObject);\r\nvar\r\n Col: TColor;\r\nbegin\r\n // exchange colors\r\n Col := FForegroundColor;\r\n FForegroundColor := FBackgroundColor;\r\n FBackgroundColor := Col;\r\n\r\n FForegroundColorImg.Canvas.Brush.Color := FForegroundColor;\r\n FForegroundColorImg.Canvas.Brush.Style := bsSolid;\r\n FForegroundColorImg.Canvas.FillRect(Rect(0, 0, FChoosed.Width, FChoosed.Height));\r\n\r\n FBackgroundColorImg.Canvas.Brush.Color := FBackgroundColor;\r\n FBackgroundColorImg.Canvas.Brush.Style := bsSolid;\r\n FBackgroundColorImg.Canvas.FillRect(Rect(0, 0, FChoosed.Width, FChoosed.Height));\r\n\r\n if Assigned(FOnChangeColor) then\r\n FOnChangeColor(Self, FForegroundColor, FBackgroundColor);\r\nend;\r\n\r\nprocedure TJvGammaPanel.SetForegroundColor(const Value: TColor);\r\nbegin\r\n FForegroundColor := Value;\r\n FForegroundColorImg.Canvas.Brush.Color := FForegroundColor;\r\n FForegroundColorImg.Canvas.Brush.Style := bsSolid;\r\n FForegroundColorImg.Canvas.FillRect(Rect(0, 0, FChoosed.Width, FChoosed.Height));\r\n if Assigned(FOnChangeColor) then\r\n FOnChangeColor(Self, FForegroundColor, FBackgroundColor);\r\nend;\r\n\r\nprocedure TJvGammaPanel.SetBackgroundColor(const Value: TColor);\r\nbegin\r\n FBackgroundColor := Value;\r\n FBackgroundColorImg.Canvas.Brush.Color := FBackgroundColor;\r\n FBackgroundColorImg.Canvas.Brush.Style := bsSolid;\r\n FBackgroundColorImg.Canvas.FillRect(Rect(0, 0, FChoosed.Width, FChoosed.Height));\r\n if Assigned(FOnChangeColor) then\r\n FOnChangeColor(Self, FForegroundColor, FBackgroundColor);\r\nend;\r\n\r\nprocedure TJvGammaPanel.BoundsChanged;\r\nbegin\r\n Width := 65;\r\n Height := 250;\r\n if Assigned(FForegroundColorImg) then\r\n FForegroundColorImg.BringToFront;\r\nend;\r\n\r\nprocedure TJvGammaPanel.DoChangeColor(AForegroundColor, ABackgroundColor: TColor);\r\nbegin\r\n if Assigned(FOnChangeColor) then\r\n FOnChangeColor(Self, FForegroundColor, FBackgroundColor);\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvGenetic.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvGenetic.PAS, released on 2001-02-28.\r\n\r\nThe Initial Developer of the Original Code is Sbastien Buysse [sbuysse att buypin dott com]\r\nPortions created by Sbastien Buysse are Copyright (C) 2001 Sbastien Buysse.\r\nAll Rights Reserved.\r\n\r\nContributor(s): Michael Beck [mbeck att bigfoot dott com].\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvGenetic.pas 13104 2011-09-07 06:50:43Z obones $\r\n\r\nunit JvGenetic;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n SysUtils, Classes, Windows,\r\n JvTypes, JvComponentBase;\r\n\r\ntype\r\n TJvTestMember = function(Sender: TObject; Index: Integer; Member: PByte): Byte of object;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64 or pidOSX32)]\r\n {$ENDIF RTL230_UP}\r\n TJvGenetic = class(TJvComponent)\r\n private\r\n FMembers: TStringList;\r\n FGeneration: Integer;\r\n FSize: Integer;\r\n FCount: Integer;\r\n FOnTestMember: TJvTestMember;\r\n FCrossover: Double;\r\n FMutationProbability: Double;\r\n procedure SetCount(const Value: Integer);\r\n procedure SetSize(const Value: Integer);\r\n procedure KillThemAll(Value: TStringList);\r\n function Generate(Father, Mother: PByte; Size: Integer): PByte;\r\n function Mutate(Value: Byte): Byte;\r\n function DoCrossover: Boolean;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n procedure NewGeneration;\r\n procedure NextGeneration;\r\n function GetMember(Index: Integer): PByte;\r\n function GetAverage: Double;\r\n property Generation: Integer read FGeneration;\r\n published\r\n property MemberSize: Integer read FSize write SetSize default 4;\r\n property Count: Integer read FCount write SetCount default 10;\r\n property CrossoverProbability: Double read FCrossover write FCrossover;\r\n property MutationProbability: Double read FMutationProbability write FMutationProbability;\r\n property OnTestMember: TJvTestMember read FOnTestMember write FOnTestMember;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvGenetic.pas $';\r\n Revision: '$Revision: 13104 $';\r\n Date: '$Date: 2011-09-07 08:50:43 +0200 (mer. 07 sept. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n JvResources;\r\n\r\ntype\r\n TGeneticMember = class(TObject)\r\n public\r\n Points: Cardinal;\r\n Data: PByte;\r\n end;\r\n\r\nconstructor TJvGenetic.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FMembers := TStringList.Create;\r\n Randomize;\r\n FGeneration := 0;\r\n FCount := 10;\r\n FSize := 4;\r\n FCrossover := 0.6;\r\n FMutationProbability := 0.003;\r\nend;\r\n\r\ndestructor TJvGenetic.Destroy;\r\nbegin\r\n KillThemAll(FMembers);\r\n FMembers.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJvGenetic.DoCrossover: Boolean;\r\nbegin\r\n Result := Random < FCrossover;\r\nend;\r\n\r\nfunction TJvGenetic.Generate(Father, Mother: PByte; Size: Integer): PByte;\r\nvar\r\n I, Count: Integer;\r\n P, S: PByte;\r\nbegin\r\n if DoCrossover then\r\n Count := Random(Size - 1)\r\n else\r\n Count := Size;\r\n\r\n Result := AllocMem(Size);\r\n P := Result;\r\n S := Father;\r\n for I := 0 to Count - 1 do\r\n begin\r\n P^ := Mutate(S^);\r\n Inc(P);\r\n Inc(S);\r\n end;\r\n S := Mother;\r\n Inc(S, Count);\r\n for I := Count to Size - 1 do\r\n begin\r\n P^ := Mutate(S^);\r\n Inc(P);\r\n Inc(S);\r\n end;\r\nend;\r\n\r\nfunction TJvGenetic.GetAverage: Double;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := 0.0;\r\n if FMembers.Count <> 0 then\r\n begin\r\n for I := 0 to FMembers.Count - 1 do\r\n Result := Result + TGeneticMember(FMembers.Objects[I]).Points;\r\n Result := Result / FMembers.Count;\r\n end;\r\nend;\r\n\r\nfunction TJvGenetic.GetMember(Index: Integer): PByte;\r\nbegin\r\n Result := TGeneticMember(FMembers.Objects[Index]).Data;\r\nend;\r\n\r\nprocedure TJvGenetic.KillThemAll(Value: TStringList);\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := 0 to Value.Count-1 do\r\n begin\r\n FreeMem(TGeneticMember(Value.Objects[I]).Data);\r\n TGeneticMember(Value.Objects[I]).Free;\r\n end;\r\n Value.Clear;\r\nend;\r\n\r\nfunction TJvGenetic.Mutate(Value: Byte): Byte;\r\nvar\r\n B: Byte;\r\n I: Integer;\r\nbegin\r\n B := $80;\r\n Result := Value;\r\n for I := 0 to 7 do\r\n begin\r\n if Random < FMutationProbability then\r\n begin\r\n if (Result and B) = 0 then\r\n Result := Result or B\r\n else\r\n Result := Result and (not B);\r\n end;\r\n B := B shr 1;\r\n end;\r\nend;\r\n\r\nprocedure TJvGenetic.NewGeneration;\r\nvar\r\n I, J: Integer;\r\n Member: TGeneticMember;\r\n P: PByte;\r\nbegin\r\n if (FCount > 0) and (FSize > 0) then\r\n begin\r\n KillThemAll(FMembers);\r\n FGeneration := 0;\r\n for I := 0 to FCount - 1 do\r\n begin\r\n Member := TGeneticMember.Create;\r\n Member.Data := AllocMem(FSize);\r\n P := Member.Data;\r\n for J := 0 to FSize - 1 do\r\n begin\r\n Byte(P^) := Random(256);\r\n Inc(P);\r\n end;\r\n if not Assigned(FOnTestMember) then\r\n raise EJVCLException.CreateRes(@RsENoTest);\r\n Member.Points := FOnTestMember(Self, I, Member.Data);\r\n FMembers.AddObject('', TObject(Member));\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvGenetic.NextGeneration;\r\nvar\r\n A, B, Tot: Cardinal;\r\n I: Integer;\r\n Father, Mother: Integer;\r\n FGenerat: TStringList;\r\n Member: TGeneticMember;\r\nbegin\r\n if (FCount > 0) and (FSize > 0) then\r\n begin\r\n Inc(FGeneration);\r\n\r\n //Compute the sum of Points\r\n Tot := 0;\r\n for I := 0 to FCount - 1 do\r\n Inc(Tot, TGeneticMember(FMembers.Objects[I]).Points);\r\n\r\n //Create new Generation\r\n FGenerat := TStringList.Create;\r\n for I := 0 to FCount do\r\n begin\r\n A := Random(Tot);\r\n B := TGeneticMember(FMembers.Objects[0]).Points;\r\n Father := 0;\r\n while B < A do\r\n begin\r\n Inc(Father);\r\n Inc(B, TGeneticMember(FMembers.Objects[Father]).Points);\r\n end;\r\n\r\n A := Random(Tot);\r\n B := TGeneticMember(FMembers.Objects[0]).Points;\r\n Mother := 0;\r\n while B < A do\r\n begin\r\n Inc(Mother);\r\n Inc(B, TGeneticMember(FMembers.Objects[Mother]).Points);\r\n end;\r\n\r\n //Copy, Crossover and mutate\r\n Member := TGeneticMember.Create;\r\n Member.Data := Generate(TGeneticMember(FMembers.Objects[Mother]).Data,\r\n TGeneticMember(FMembers.Objects[Father]).Data, FSize);\r\n\r\n if Assigned(FOnTestMember) then\r\n Member.Points := FOnTestMember(Self, I, Member.Data)\r\n else\r\n raise EJVCLException.CreateRes(@RsENoTest);\r\n\r\n //Add new element to FGenerat\r\n FGenerat.AddObject('', TObject(Member));\r\n end;\r\n KillThemAll(FMembers);\r\n FMembers.Assign(FGenerat);\r\n FGenerat.Free;\r\n end;\r\nend;\r\n\r\nprocedure TJvGenetic.SetCount(const Value: Integer);\r\nbegin\r\n if FCount <> Value then\r\n begin\r\n FCount := Value;\r\n KillThemAll(FMembers);\r\n FGeneration := 0;\r\n end;\r\nend;\r\n\r\nprocedure TJvGenetic.SetSize(const Value: Integer);\r\nbegin\r\n if FSize <> Value then\r\n begin\r\n FSize := Value;\r\n KillThemAll(FMembers);\r\n FGeneration := 0;\r\n end;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvGnugettext.pas", "content": "{*------------------------------------------------------------------------------\r\n GNU gettext translation system for Delphi, Kylix, C++ Builder and others.\r\n All parts of the translation system are kept in this unit.\r\n\r\n @author Lars B. Dybdahl and others\r\n @version $LastChangedRevision: 13415 $\r\n @see http://dybdahl.dk/dxgettext/\r\n-------------------------------------------------------------------------------}\r\nunit JvGnugettext;\r\n(**************************************************************)\r\n(* *)\r\n(* (C) Copyright by Lars B. Dybdahl and others *)\r\n(* E-mail: Lars@dybdahl.dk, phone +45 70201241 *)\r\n(* *)\r\n(* Contributors: Peter Thornqvist, Troy Wolbrink, *)\r\n(* Frank Andreas de Groot, Igor Siticov, *)\r\n(* Jacques Garcia Vazquez, Igor Gitman, *)\r\n(* Arvid Winkelsdorf, Andreas Hausladen, *)\r\n(* Olivier Sannier *)\r\n(* *)\r\n(* See http://dybdahl.dk/dxgettext/ for more information *)\r\n(* *)\r\n(**************************************************************)\r\n\r\n{*------------------------------------------------------------------------------\r\n NOTE ON JVCL INTEGRATION:\r\n \r\n The original file name is \"gnugexttext.pas\" but has been renamed to \r\n JvGnugettext.pas so as to not conflict with other packages that might\r\n use the gnugettext.pas file directly\r\n In order to ease the synchronization with the public version of \r\n gnugettext.pas the style guide for the JVCL is not enforced here.\r\n------------------------------------------------------------------------------*}\r\n\r\n// Information about this file:\r\n// $--LastChangedDate: 2010-08-25 15:40:17 +0200 (mer., 25 aot 2010) $\r\n// $--LastChangedRevision: 220 $\r\n// $--HeadURL: http://svn.berlios.de/svnroot/repos/dxgettext/trunk/dxgettext/sample/gnugettext.pas $\r\n\r\n// Redistribution and use in source and binary forms, with or without\r\n// modification, are permitted provided that the following conditions are met:\r\n//\r\n// The names of any contributor may not be used to endorse or promote\r\n// products derived from this software without specific prior written permission.\r\n//\r\n// THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS \"AS IS\"\r\n// AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE\r\n// IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE\r\n// ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE\r\n// LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL\r\n// DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR\r\n// SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER\r\n// CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,\r\n// OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE\r\n// OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.\r\n\r\ninterface\r\n\r\n{$I jedi\\jedi.inc}\r\n\r\n// If the conditional define DXGETTEXTDEBUG is defined, debugging log is activated.\r\n// Use DefaultInstance.DebugLogToFile() to write the log to a file.\r\n{ $define DXGETTEXTDEBUG}\r\n\r\n{$ifdef VER140}\r\n // Delphi 6\r\n {$DEFINE DELPHI2007OROLDER}\r\n{$ifdef MSWINDOWS}\r\n {$DEFINE DELPHI6OROLDER}\r\n{$endif}\r\n{$endif}\r\n{$ifdef VER150}\r\n // Delphi 7\r\n {$DEFINE DELPHI2007OROLDER}\r\n{$endif}\r\n{$ifdef VER160}\r\n // Delphi 8\r\n {$DEFINE DELPHI2007OROLDER}\r\n{$endif}\r\n{$ifdef VER170}\r\n // Delphi 2005\r\n {$DEFINE DELPHI2007OROLDER}\r\n{$endif}\r\n{$ifdef VER180}\r\n // Delphi 2006\r\n {$DEFINE DELPHI2007OROLDER}\r\n{$endif}\r\n{$ifdef VER190}\r\n // Delphi 2007\r\n {$DEFINE DELPHI2007OROLDER}\r\n{$endif}\r\n{$ifdef VER200}\r\n // Delphi 2009 with Unicode\r\n {$DEFINE DELPHI2009OROLDER}\r\n{$endif}\r\n{$ifdef VER220}\r\n // Delphi 2011 with Unicode\r\n {$DEFINE DELPHI2011OROLDER}\r\n{$endif}\r\n{$ifdef VER230}\r\n // Delphi 2012 with Unicode\r\n {$DEFINE DELPHI2012OROLDER}\r\n{$endif}\r\n{$ifdef VER240}\r\n // Delphi 2013 with Unicode\r\n {$DEFINE DELPHI2013OROLDER}\r\n{$endif}\r\n\r\n{$ifdef DELPHI2013OROLDER}\r\n {$DEFINE DELPHI2012OROLDER}\r\n{$endif}\r\n\r\n{$ifdef DELPHI2012OROLDER}\r\n {$DEFINE DELPHI2011OROLDER}\r\n{$endif}\r\n\r\n{$ifdef DELPHI2011OROLDER}\r\n {$DEFINE DELPHI2010OROLDER}\r\n{$endif}\r\n\r\n{$ifdef DELPHI2010OROLDER}\r\n {$DEFINE DELPHI2009OROLDER}\r\n{$endif}\r\n\r\n{$ifdef DELPHI2009OROLDER}\r\n {$DEFINE DELPHI2007OROLDER}\r\n{$endif}\r\n\r\n{$ifdef DELPHI2007OROLDER}\r\n {$DEFINE DELPHI7OROLDER}\r\n{$endif}\r\n\r\n{$ifdef DELPHI7OROLDER}\r\n {$DEFINE DELPHI6OROLDER}\r\n{$endif}\r\n\r\nuses\r\n{$ifdef MSWINDOWS}\r\n Windows,\r\n{$else}\r\n Libc,\r\n{$ifdef FPC}\r\n CWString,\r\n{$endif}\r\n{$endif}\r\n Classes, StrUtils, SysUtils, TypInfo;\r\n\r\n(*****************************************************************************)\r\n(* *)\r\n(* MAIN API *)\r\n(* *)\r\n(*****************************************************************************)\r\n\r\ntype\r\n {$IFNDEF UNICODE}\r\n UnicodeString=WideString;\r\n RawUtf8String=AnsiString;\r\n RawByteString=AnsiString;\r\n {$ELSE}\r\n RawUtf8String=RawByteString;\r\n {$ENDIF}\r\n DomainString=string;\r\n LanguageString=string;\r\n ComponentNameString=string;\r\n FilenameString=string;\r\n MsgIdString=UnicodeString;\r\n TranslatedUnicodeString=UnicodeString;\r\n {$IFNDEF DELPHI2010OROLDER}\r\n NativeInt=Integer;\r\n {$ENDIF}\r\n\r\n// Main GNU gettext functions. See documentation for instructions on how to use them.\r\n//DOM-IGNORE-BEGIN\r\nfunction _(const szMsgId: MsgIdString): TranslatedUnicodeString;\r\n//DOM-IGNORE-END\r\nfunction gettext(const szMsgId: MsgIdString): TranslatedUnicodeString;\r\nfunction gettext_NoExtract(const szMsgId: MsgIdString): TranslatedUnicodeString;\r\nfunction gettext_NoOp(const szMsgId: MsgIdString): TranslatedUnicodeString;\r\nfunction dgettext(const szDomain: DomainString; const szMsgId: MsgIdString): TranslatedUnicodeString;\r\nfunction dgettext_NoExtract(const szDomain: DomainString; const szMsgId: MsgIdString): TranslatedUnicodeString;\r\nfunction dngettext(const szDomain: DomainString; const singular,plural: MsgIdString; Number:longint): TranslatedUnicodeString;\r\nfunction ngettext(const singular,plural: MsgIdString; Number:longint): TranslatedUnicodeString;\r\nfunction ngettext_NoExtract(const singular,plural: MsgIdString; Number:longint): TranslatedUnicodeString;\r\nprocedure textdomain(const szDomain: DomainString);\r\nfunction getcurrenttextdomain: DomainString;\r\nprocedure bindtextdomain(const szDomain: DomainString; const szDirectory: FilenameString);\r\n\r\n// Set language to use\r\nprocedure UseLanguage(LanguageCode: LanguageString);\r\nfunction GetCurrentLanguage:LanguageString;\r\n\r\n// Translates a component (form, frame etc.) to the currently selected language.\r\n// Put TranslateComponent(self) in the OnCreate event of all your forms.\r\n// See the manual for documentation on these functions\r\ntype\r\n TTranslator=procedure (obj:TObject) of object;\r\n\r\nprocedure TP_Ignore(AnObject:TObject; const name:ComponentNameString);\r\nprocedure TP_IgnoreClass (IgnClass:TClass);\r\nprocedure TP_IgnoreClassProperty (IgnClass:TClass;const propertyname:ComponentNameString);\r\nprocedure TP_GlobalIgnoreClass (IgnClass:TClass);\r\nprocedure TP_GlobalIgnoreClassProperty (IgnClass:TClass;const propertyname:ComponentNameString);\r\nprocedure TP_GlobalHandleClass (HClass:TClass;Handler:TTranslator);\r\nprocedure TranslateComponent(AnObject: TComponent; const TextDomain:DomainString='');\r\nprocedure RetranslateComponent(AnObject: TComponent; const TextDomain:DomainString='');\r\n\r\n// Add more domains that resourcestrings can be extracted from. If a translation\r\n// is not found in the default domain, this domain will be searched, too.\r\n// This is useful for adding mo files for certain runtime libraries and 3rd\r\n// party component libraries\r\nprocedure AddDomainForResourceString (const domain:DomainString);\r\nprocedure RemoveDomainForResourceString (const domain:DomainString);\r\n\r\n// Add more domains that component strings can be extracted from. If a translation\r\n// is not found in the default domain, this domain will be searched, too.\r\n// This is useful when an application inherits components from a 3rd\r\n// party component libraries\r\nprocedure AddDomainForComponent (const domain:DomainString);\r\nprocedure RemoveDomainForComponent (const domain:DomainString);\r\n\r\n// Unicode-enabled way to get resourcestrings, automatically translated\r\n// Use like this: ws:=LoadResStringW(@NameOfResourceString);\r\nfunction LoadResString(ResStringRec: PResStringRec): widestring;\r\nfunction LoadResStringW(ResStringRec: PResStringRec): UnicodeString;\r\n\r\n// This returns an empty string if not translated or translator name is not specified.\r\nfunction GetTranslatorNameAndEmail:TranslatedUnicodeString;\r\n\r\n\r\n(*****************************************************************************)\r\n(* *)\r\n(* ADVANCED FUNCTIONALITY *)\r\n(* *)\r\n(*****************************************************************************)\r\n\r\nconst\r\n DefaultTextDomain = 'default';\r\n\r\nvar\r\n ExecutableFilename: FilenameString; // This is set to paramstr(0) or the name of the DLL you are creating.\r\n\r\nconst\r\n PreferExternal = True; // Set to true, to prefer external *.mo over embedded translation\r\n UseMemoryMappedFiles = True; // Set to False, to use the mo-file as independent copy in memory (you can update the file while it is in use)\r\n ReReadMoFileOnSameLanguage = True; // Set to True, to reread mo-file if the current language is selected again\r\n\r\nconst\r\n // Subversion source code version control version information\r\n VCSVersion='$LastChangedRevision: 13415 $';\r\n\r\ntype\r\n EGnuGettext=class(Exception);\r\n EGGProgrammingError=class(EGnuGettext);\r\n EGGComponentError=class(EGnuGettext);\r\n EGGIOError=class(EGnuGettext);\r\n EGGAnsi2WideConvError=class(EGnuGettext);\r\n\r\n// This function will turn resourcestring hooks on or off, eventually with BPL file support.\r\n// Please do not activate BPL file support when the package is in design mode.\r\nconst AutoCreateHooks=true;\r\nprocedure HookIntoResourceStrings (enabled:boolean=true; SupportPackages:boolean=false);\r\n\r\n\r\n\r\n\r\n(*****************************************************************************)\r\n(* *)\r\n(* CLASS based implementation. *)\r\n(* Use TGnuGettextInstance to have more than one language *)\r\n(* in your application at the same time *)\r\n(* *)\r\n(*****************************************************************************)\r\n\r\n{$ifdef MSWINDOWS}\r\n{$ifndef DELPHI6OROLDER}\r\n{$WARN UNSAFE_TYPE OFF}\r\n{$WARN UNSAFE_CODE OFF}\r\n{$WARN UNSAFE_CAST OFF}\r\n{$endif}\r\n{$endif}\r\n\r\ntype\r\n TOnDebugLine = Procedure (Sender: TObject; const Line: String; var Discard: Boolean) of Object; // Set Discard to false if output should still go to ordinary debug log\r\n TGetPluralForm=function (Number:Longint):Integer;\r\n TDebugLogger=procedure (line: ansistring) of object;\r\n\r\n{*------------------------------------------------------------------------------\r\n Handles .mo files, in separate files or inside the exe file.\r\n Don't use this class. It's for internal use.\r\n-------------------------------------------------------------------------------}\r\n TMoFile=\r\n class /// Threadsafe. Only constructor and destructor are writing to memory\r\n private\r\n doswap: boolean;\r\n public\r\n Users:Integer; /// Reference count. If it reaches zero, this object should be destroyed.\r\n constructor Create (const filename: FilenameString;\r\n const Offset: int64; Size: int64;\r\n const xUseMemoryMappedFiles: Boolean);\r\n destructor Destroy; override;\r\n function gettext(const msgid: RawUtf8String;var found:boolean): RawUtf8String; // uses mo file and utf-8\r\n property isSwappedArchitecture:boolean read doswap;\r\n private\r\n N, O, T: Cardinal; /// Values defined at http://www.linuxselfhelp.com/gnu/gettext/html_chapter/gettext_6.html\r\n startindex,startstep:integer;\r\n FUseMemoryMappedFiles: Boolean;\r\n mo: THandle;\r\n momapping: THandle;\r\n momemoryHandle:PAnsiChar;\r\n momemory: PAnsiChar;\r\n function autoswap32(i: cardinal): cardinal;\r\n function CardinalInMem(baseptr: PAnsiChar; Offset: Cardinal): Cardinal;\r\n end;\r\n\r\n{*------------------------------------------------------------------------------\r\n Handles all issues regarding a specific domain.\r\n Don't use this class. It's for internal use.\r\n-------------------------------------------------------------------------------}\r\n TDomain=\r\n class\r\n private\r\n Enabled:boolean;\r\n vDirectory: FilenameString;\r\n procedure setDirectory(const dir: FilenameString);\r\n public\r\n DebugLogger:TDebugLogger;\r\n Domain: DomainString;\r\n property Directory: FilenameString read vDirectory write setDirectory;\r\n constructor Create;\r\n destructor Destroy; override;\r\n // Set parameters\r\n procedure SetLanguageCode (const langcode:LanguageString);\r\n procedure SetFilename (const filename:FilenameString); // Bind this domain to a specific file\r\n // Get information\r\n procedure GetListOfLanguages(list:TStrings);\r\n function GetTranslationProperty(Propertyname: ComponentNameString): TranslatedUnicodeString;\r\n function gettext(const msgid: RawUtf8String): RawUtf8String; // uses mo file and utf-8\r\n private\r\n mofile:TMoFile;\r\n SpecificFilename:FilenameString;\r\n curlang: LanguageString;\r\n OpenHasFailedBefore: boolean;\r\n procedure OpenMoFile;\r\n procedure CloseMoFile;\r\n end;\r\n\r\n{*------------------------------------------------------------------------------\r\n Helper class for invoking events.\r\n-------------------------------------------------------------------------------}\r\n TExecutable=\r\n class\r\n procedure Execute; virtual; abstract;\r\n end;\r\n\r\n{*------------------------------------------------------------------------------\r\n Interface to implement if you want to register as a language change listener\r\n-------------------------------------------------------------------------------}\r\n IGnuGettextInstanceWhenNewLanguageListener = interface\r\n procedure WhenNewLanguage (const LanguageID:LanguageString);\r\n end;\r\n \r\n{*------------------------------------------------------------------------------\r\n The main translation engine.\r\n-------------------------------------------------------------------------------}\r\n TGnuGettextInstance=\r\n class\r\n private\r\n fOnDebugLine:TOnDebugLine;\r\n public\r\n Enabled:Boolean; /// Set this to false to disable translations\r\n DesignTimeCodePage:Integer; /// See MultiByteToWideChar() in Win32 API for documentation\r\n constructor Create;\r\n destructor Destroy; override;\r\n procedure UseLanguage(LanguageCode: LanguageString);\r\n procedure GetListOfLanguages (const domain:DomainString; list:TStrings); // Puts list of language codes, for which there are translations in the specified domain, into list\r\n {$ifndef UNICODE}\r\n function gettext(const szMsgId: ansistring): TranslatedUnicodeString; overload; virtual;\r\n function ngettext(const singular,plural:ansistring;Number:longint):TranslatedUnicodeString; overload; virtual;\r\n {$endif}\r\n function gettext(const szMsgId: MsgIdString): TranslatedUnicodeString; overload; virtual;\r\n function gettext_NoExtract(const szMsgId: MsgIdString): TranslatedUnicodeString;\r\n function gettext_NoOp(const szMsgId: MsgIdString): TranslatedUnicodeString;\r\n function ngettext(const singular,plural:MsgIdString;Number:longint):TranslatedUnicodeString; overload; virtual;\r\n function ngettext_NoExtract(const singular,plural:MsgIdString;Number:longint):TranslatedUnicodeString;\r\n function GetCurrentLanguage:LanguageString;\r\n function GetTranslationProperty (const Propertyname:ComponentNameString):TranslatedUnicodeString;\r\n function GetTranslatorNameAndEmail:TranslatedUnicodeString;\r\n\r\n // Form translation tools, these are not threadsafe. All TP_ procs must be called just before TranslateProperites()\r\n procedure TP_Ignore(AnObject:TObject; const name:ComponentNameString);\r\n procedure TP_IgnoreClass (IgnClass:TClass);\r\n procedure TP_IgnoreClassProperty (IgnClass:TClass;propertyname:ComponentNameString);\r\n procedure TP_GlobalIgnoreClass (IgnClass:TClass);\r\n procedure TP_GlobalIgnoreClassProperty (IgnClass:TClass;propertyname:ComponentNameString);\r\n procedure TP_GlobalHandleClass (HClass:TClass;Handler:TTranslator);\r\n procedure TranslateProperties(AnObject: TObject; textdomain:DomainString='');\r\n procedure TranslateComponent(AnObject: TComponent; const TextDomain:DomainString='');\r\n procedure RetranslateComponent(AnObject: TComponent; const TextDomain:DomainString='');\r\n\r\n // Multi-domain functions\r\n {$ifndef UNICODE}\r\n function dgettext(const szDomain: DomainString; const szMsgId: ansistring): TranslatedUnicodeString; overload; virtual;\r\n function dngettext(const szDomain: DomainString; const singular,plural:ansistring;Number:longint):TranslatedUnicodeString; overload; virtual;\r\n {$endif}\r\n function dgettext(const szDomain: DomainString; const szMsgId: MsgIdString): TranslatedUnicodeString; overload; virtual;\r\n function dgettext_NoExtract(const szDomain: DomainString; const szMsgId: MsgIdString): TranslatedUnicodeString;\r\n function dngettext(const szDomain: DomainString; const singular,plural:MsgIdString;Number:longint):TranslatedUnicodeString; overload; virtual;\r\n function dngettext_NoExtract(const szDomain: DomainString; const singular,plural:MsgIdString;Number:longint):TranslatedUnicodeString;\r\n procedure textdomain(const szDomain: DomainString);\r\n function getcurrenttextdomain: DomainString;\r\n procedure bindtextdomain(const szDomain: DomainString; const szDirectory: FilenameString);\r\n procedure bindtextdomainToFile (const szDomain: DomainString; const filename: FilenameString); // Also works with files embedded in exe file\r\n\r\n // Windows API functions\r\n function LoadResString(ResStringRec: PResStringRec): UnicodeString;\r\n\r\n // Output all log info to this file. This may only be called once.\r\n procedure DebugLogToFile (const filename:FilenameString; append:boolean=false);\r\n procedure DebugLogPause (PauseEnabled:boolean);\r\n property OnDebugLine: TOnDebugLine read fOnDebugLine write fOnDebugLine; // If set, all debug output goes here\r\n {$ifndef UNICODE}\r\n // Conversion according to design-time character set\r\n function ansi2wideDTCP (const s:AnsiString):MsgIdString; // Convert using Design Time Code Page\r\n {$endif}\r\n\r\n procedure RegisterWhenNewLanguageListener(Listener: IGnuGettextInstanceWhenNewLanguageListener);\r\n procedure UnregisterWhenNewLanguageListener(Listener: IGnuGettextInstanceWhenNewLanguageListener);\r\n protected\r\n procedure TranslateStrings (sl:TStrings;const TextDomain:DomainString);\r\n\r\n // Override these three, if you want to inherited from this class\r\n // to create a new class that handles other domain and language dependent\r\n // issues\r\n procedure WhenNewLanguage (const LanguageID:LanguageString); virtual; // Override to know when language changes\r\n procedure WhenNewDomain (const TextDomain:DomainString); virtual; // Override to know when text domain changes. Directory is purely informational\r\n procedure WhenNewDomainDirectory (const TextDomain:DomainString;const Directory:FilenameString); virtual; // Override to know when any text domain's directory changes. It won't be called if a domain is fixed to a specific file.\r\n private\r\n curlang: LanguageString;\r\n curGetPluralForm:TGetPluralForm;\r\n curmsgdomain: DomainString;\r\n savefileCS: TMultiReadExclusiveWriteSynchronizer;\r\n savefile: TextFile;\r\n savememory: TStringList;\r\n DefaultDomainDirectory:FilenameString;\r\n domainlist: TStringList; /// List of domain names. Objects are TDomain.\r\n TP_IgnoreList:TStringList; /// Temporary list, reset each time TranslateProperties is called\r\n TP_ClassHandling:TList; /// Items are TClassMode. If a is derived from b, a comes first\r\n TP_GlobalClassHandling:TList; /// Items are TClassMode. If a is derived from b, a comes first\r\n TP_Retranslator:TExecutable; /// Cast this to TTP_Retranslator\r\n fWhenNewLanguageListeners: TInterfaceList; /// List of all registered WhenNewLanguage listeners\r\n {$ifdef DXGETTEXTDEBUG}\r\n DebugLogCS:TMultiReadExclusiveWriteSynchronizer;\r\n DebugLog:TStream;\r\n DebugLogOutputPaused:Boolean;\r\n {$endif}\r\n function TP_CreateRetranslator:TExecutable; // Must be freed by caller!\r\n procedure FreeTP_ClassHandlingItems;\r\n {$ifdef DXGETTEXTDEBUG}\r\n procedure DebugWriteln(line: ansistring);\r\n {$endif}\r\n procedure TranslateProperty(AnObject: TObject; PropInfo: PPropInfo;\r\n TodoList: TStrings; const TextDomain:DomainString);\r\n function Getdomain(const domain:DomainString; const DefaultDomainDirectory:FilenameString; const CurLang: LanguageString): TDomain; // Translates a single property of an object\r\n end;\r\n\r\nconst\r\n LOCALE_SISO639LANGNAME = $59; // Used by Lazarus software development tool\r\n LOCALE_SISO3166CTRYNAME = $5A; // Used by Lazarus software development tool\r\n\r\nvar\r\n DefaultInstance:TGnuGettextInstance; /// Default instance of the main API for singlethreaded applications.\r\n\r\nimplementation\r\n\r\n{$ifndef MSWINDOWS}\r\n{$ifndef LINUX}\r\n 'This version of gnugettext.pas is only meant to be compiled with Kylix 3,'\r\n 'Delphi 6, Delphi 7 and later versions. If you use other versions, please'\r\n 'get the gnugettext.pas version from the Delphi 5 directory.'\r\n{$endif}\r\n{$endif}\r\n\r\n(**************************************************************************)\r\n// Some comments on the implementation:\r\n// This unit should be independent of other units where possible.\r\n// It should have a small footprint in any way.\r\n(**************************************************************************)\r\n// TMultiReadExclusiveWriteSynchronizer is used instead of TCriticalSection\r\n// because it makes this unit independent of the SyncObjs unit\r\n(**************************************************************************)\r\n\r\n{$B-,R+,I+,Q+}\r\n\r\ntype\r\n TTP_RetranslatorItem=\r\n class\r\n obj:TObject;\r\n Propname:ComponentNameString;\r\n OldValue:TranslatedUnicodeString;\r\n end;\r\n TTP_Retranslator=\r\n class (TExecutable)\r\n TextDomain:DomainString;\r\n Instance:TGnuGettextInstance;\r\n constructor Create;\r\n destructor Destroy; override;\r\n procedure Remember (obj:TObject; PropName:ComponentNameString; OldValue:TranslatedUnicodeString);\r\n procedure Execute; override;\r\n private\r\n list:TList;\r\n end;\r\n TEmbeddedFileInfo=\r\n class\r\n offset,size:int64;\r\n end;\r\n TFileLocator=\r\n class // This class finds files even when embedded inside executable\r\n constructor Create;\r\n destructor Destroy; override;\r\n function FindSignaturePos(const signature: RawByteString; str: TFileStream): Int64;\r\n procedure Analyze; // List files embedded inside executable\r\n function FileExists (filename:FilenameString):boolean;\r\n function GetMoFile (filename:FilenameString;DebugLogger:TDebugLogger):TMoFile;\r\n procedure ReleaseMoFile (mofile:TMoFile);\r\n private\r\n basedirectory:FilenameString;\r\n filelist:TStringList; //Objects are TEmbeddedFileInfo. Filenames are relative to .exe file\r\n MoFilesCS:TMultiReadExclusiveWriteSynchronizer;\r\n MoFiles:TStringList; // Objects are filenames+offset, objects are TMoFile\r\n function ReadInt64 (str:TStream):int64;\r\n end;\r\n TGnuGettextComponentMarker=\r\n class (TComponent)\r\n public\r\n LastLanguage:LanguageString;\r\n Retranslator:TExecutable;\r\n destructor Destroy; override;\r\n end;\r\n TClassMode=\r\n class\r\n HClass:TClass;\r\n SpecialHandler:TTranslator;\r\n PropertiesToIgnore:TStringList; // This is ignored if Handler is set\r\n constructor Create;\r\n destructor Destroy; override;\r\n end;\r\n TRStrinfo = record\r\n strlength, stroffset: cardinal;\r\n end;\r\n TStrInfoArr = array[0..10000000] of TRStrinfo;\r\n PStrInfoArr = ^TStrInfoArr;\r\n TCharArray5=array[0..4] of ansichar;\r\n THook= // Replaces a runtime library procedure with a custom procedure\r\n class\r\n public\r\n constructor Create (OldProcedure, NewProcedure: pointer; FollowJump:boolean=false);\r\n destructor Destroy; override; // Restores unhooked state\r\n procedure Reset (FollowJump:boolean=false); // Disables and picks up patch points again\r\n procedure Disable;\r\n procedure Enable;\r\n private\r\n oldproc,newproc:Pointer;\r\n Patch:TCharArray5;\r\n Original:TCharArray5;\r\n PatchPosition:PAnsiChar;\r\n procedure Shutdown; // Same as destroy, except that object is not destroyed\r\n end;\r\n\r\nvar\r\n // System information\r\n Win32PlatformIsUnicode:boolean=False;\r\n \r\n // Information about files embedded inside .exe file\r\n FileLocator:TFileLocator;\r\n\r\n // Hooks into runtime library functions\r\n ResourceStringDomainListCS:TMultiReadExclusiveWriteSynchronizer;\r\n ResourceStringDomainList:TStringList;\r\n ComponentDomainListCS:TMultiReadExclusiveWriteSynchronizer;\r\n ComponentDomainList:TStringList;\r\n HookLoadResString:THook;\r\n HookLoadStr:THook;\r\n HookFmtLoadStr:THook;\r\n\r\nfunction GGGetEnvironmentVariable(const Name:widestring):widestring;\r\nvar\r\n Len: integer;\r\n W : WideString;\r\nbegin\r\n Result := '';\r\n SetLength(W,1);\r\n Len := Windows.GetEnvironmentVariableW(PWideChar(Name), PWideChar(W), 1);\r\n if Len > 0 then begin\r\n SetLength(Result, Len - 1);\r\n Windows.GetEnvironmentVariableW(PWideChar(Name), PWideChar(Result), Len);\r\n end;\r\nend;\r\n\r\nfunction StripCRRawMsgId (s:RawUtf8String):RawUtf8String;\r\nvar\r\n i:integer;\r\nbegin\r\n i:=1;\r\n while i<=length(s) do begin\r\n if s[i]=#13 then delete (s,i,1) else inc (i);\r\n end;\r\n Result:=s;\r\nend;\r\n\r\nfunction EnsureLineBreakInTranslatedString (s:RawUtf8String):RawUtf8String;\r\n{$ifdef MSWINDOWS}\r\nvar\r\n i:integer;\r\n{$endif}\r\nbegin\r\n {$ifdef MSWINDOWS}\r\n Assert (sLinebreak=ansistring(#13#10));\r\n i:=1;\r\n while i<=length(s) do begin\r\n if (s[i]=#10) and (MidStr(s,i-1,1)<>#13) then begin\r\n insert (#13,s,i);\r\n inc (i,2);\r\n end else\r\n inc (i);\r\n end;\r\n {$endif}\r\n Result:=s;\r\nend;\r\n\r\nfunction IsWriteProp(Info: PPropInfo): Boolean;\r\nbegin\r\n Result := Assigned(Info) and (Info^.SetProc <> nil);\r\nend;\r\n\r\nfunction ResourceStringGettext(MsgId: MsgIdString): TranslatedUnicodeString;\r\nvar\r\n i:integer;\r\nbegin\r\n if (MsgID='') or (ResourceStringDomainListCS=nil) then begin\r\n // This only happens during very complicated program startups that fail,\r\n // or when Msgid=''\r\n Result:=MsgId;\r\n exit;\r\n end;\r\n ResourceStringDomainListCS.BeginRead;\r\n try\r\n for i:=0 to ResourceStringDomainList.Count-1 do begin\r\n Result:=dgettext(ResourceStringDomainList.Strings[i], MsgId);\r\n if Result<>MsgId then\r\n break;\r\n end;\r\n finally\r\n ResourceStringDomainListCS.EndRead;\r\n end;\r\nend;\r\n\r\nfunction ComponentGettext(MsgId: MsgIdString; Instance: TGnuGettextInstance = nil): TranslatedUnicodeString;\r\nvar\r\n i:integer;\r\nbegin\r\n if (MsgID='') or (ComponentDomainListCS=nil) then begin\r\n // This only happens during very complicated program startups that fail,\r\n // or when Msgid=''\r\n Result:=MsgId;\r\n exit;\r\n end;\r\n ComponentDomainListCS.BeginRead;\r\n try\r\n for i:=0 to ComponentDomainList.Count-1 do begin\r\n if Assigned(Instance) then\r\n Result:=Instance.dgettext(ComponentDomainList.Strings[i], MsgId)\r\n else\r\n Result:=dgettext(ComponentDomainList.Strings[i], MsgId);\r\n if Result<>MsgId then\r\n break;\r\n end;\r\n finally\r\n ComponentDomainListCS.EndRead;\r\n end;\r\nend;\r\n\r\nfunction gettext(const szMsgId: MsgIdString): TranslatedUnicodeString;\r\nbegin\r\n Result := DefaultInstance.gettext(szMsgId);\r\nend;\r\n\r\nfunction gettext_NoExtract(const szMsgId: MsgIdString): TranslatedUnicodeString;\r\nbegin\r\n // This one is very useful for translating text in variables.\r\n // This can sometimes be necessary, and by using this function,\r\n // the source code scanner will not trigger warnings.\r\n Result := gettext(szMsgId);\r\nend;\r\n\r\nfunction gettext_NoOp(const szMsgId: MsgIdString): TranslatedUnicodeString;\r\nbegin\r\n //*** With this function Strings can be added to the po-file without beeing\r\n // ResourceStrings (dxgettext will add the string and this function will\r\n // return it without a change)\r\n // see gettext manual\r\n // 4.7 - Special Cases of Translatable Strings\r\n // http://www.gnu.org/software/hello/manual/gettext/Special-cases.html#Special-cases\r\n Result := DefaultInstance.gettext_NoOp(szMsgId);\r\nend;\r\n\r\n{*------------------------------------------------------------------------------\r\n This is the main translation procedure used in programs. It takes a parameter,\r\n looks it up in the translation dictionary, and returns the translation.\r\n If no translation is found, the parameter is returned.\r\n\r\n @param szMsgId The text, that should be displayed if no translation is found.\r\n-------------------------------------------------------------------------------}\r\nfunction _(const szMsgId: MsgIdString): TranslatedUnicodeString;\r\nbegin\r\n Result:=DefaultInstance.gettext(szMsgId);\r\nend;\r\n\r\n{*------------------------------------------------------------------------------\r\n Translates a text, using a specified translation domain.\r\n If no translation is found, the parameter is returned.\r\n\r\n @param szDomain Which translation domain that should be searched for a translation.\r\n @param szMsgId The text, that should be displayed if no translation is found.\r\n-------------------------------------------------------------------------------}\r\nfunction dgettext(const szDomain: DomainString; const szMsgId: MsgIdString): TranslatedUnicodeString;\r\nbegin\r\n Result:=DefaultInstance.dgettext(szDomain, szMsgId);\r\nend;\r\n\r\nfunction dgettext_NoExtract(const szDomain: DomainString; const szMsgId: MsgIdString): TranslatedUnicodeString;\r\nbegin\r\n // This one is very useful for translating text in variables.\r\n // This can sometimes be necessary, and by using this function,\r\n // the source code scanner will not trigger warnings.\r\n Result := dgettext(szDomain, szMsgId);\r\nend;\r\n\r\nfunction dngettext(const szDomain: DomainString; const singular,plural: MsgIdString; Number:longint): TranslatedUnicodeString;\r\nbegin\r\n Result:=DefaultInstance.dngettext(szDomain,singular,plural,Number);\r\nend;\r\n\r\nfunction ngettext(const singular,plural: MsgIdString; Number:longint): TranslatedUnicodeString;\r\nbegin\r\n Result:=DefaultInstance.ngettext(singular,plural,Number);\r\nend;\r\n\r\nfunction ngettext_NoExtract(const singular,plural: MsgIdString; Number:longint): TranslatedUnicodeString;\r\nbegin\r\n // This one is very useful for translating text in variables.\r\n // This can sometimes be necessary, and by using this function,\r\n // the source code scanner will not trigger warnings.\r\n Result := ngettext(singular, plural, Number);\r\nend;\r\n\r\nprocedure textdomain(const szDomain: Domainstring);\r\nbegin\r\n DefaultInstance.textdomain(szDomain);\r\nend;\r\n\r\nprocedure SetGettextEnabled (enabled:boolean);\r\nbegin\r\n DefaultInstance.Enabled:=enabled;\r\nend;\r\n\r\nfunction getcurrenttextdomain: DomainString;\r\nbegin\r\n Result:=DefaultInstance.getcurrenttextdomain;\r\nend;\r\n\r\nprocedure bindtextdomain(const szDomain: DomainString; const szDirectory: FilenameString);\r\nbegin\r\n DefaultInstance.bindtextdomain(szDomain, szDirectory);\r\nend;\r\n\r\nprocedure TP_Ignore(AnObject:TObject; const name:FilenameString);\r\nbegin\r\n DefaultInstance.TP_Ignore(AnObject, name);\r\nend;\r\n\r\nprocedure TP_GlobalIgnoreClass (IgnClass:TClass);\r\nbegin\r\n DefaultInstance.TP_GlobalIgnoreClass(IgnClass);\r\nend;\r\n\r\nprocedure TP_IgnoreClass (IgnClass:TClass);\r\nbegin\r\n DefaultInstance.TP_IgnoreClass(IgnClass);\r\nend;\r\n\r\nprocedure TP_IgnoreClassProperty (IgnClass:TClass;const propertyname:ComponentNameString);\r\nbegin\r\n DefaultInstance.TP_IgnoreClassProperty(IgnClass,propertyname);\r\nend;\r\n\r\nprocedure TP_GlobalIgnoreClassProperty (IgnClass:TClass;const propertyname:ComponentNameString);\r\nbegin\r\n DefaultInstance.TP_GlobalIgnoreClassProperty(IgnClass,propertyname);\r\nend;\r\n\r\nprocedure TP_GlobalHandleClass (HClass:TClass;Handler:TTranslator);\r\nbegin\r\n DefaultInstance.TP_GlobalHandleClass (HClass, Handler);\r\nend;\r\n\r\nprocedure TranslateComponent(AnObject: TComponent; const TextDomain:DomainString='');\r\nbegin\r\n DefaultInstance.TranslateComponent(AnObject, TextDomain);\r\nend;\r\n\r\nprocedure RetranslateComponent(AnObject: TComponent; const TextDomain:DomainString='');\r\nbegin\r\n DefaultInstance.RetranslateComponent(AnObject, TextDomain);\r\nend;\r\n\r\n{$ifdef MSWINDOWS}\r\n\r\n// These constants are only used in Windows 95\r\n// Thanks to Frank Andreas de Groot for this table\r\nconst\r\n IDAfrikaans = $0436; IDAlbanian = $041C;\r\n IDArabicAlgeria = $1401; IDArabicBahrain = $3C01;\r\n IDArabicEgypt = $0C01; IDArabicIraq = $0801;\r\n IDArabicJordan = $2C01; IDArabicKuwait = $3401;\r\n IDArabicLebanon = $3001; IDArabicLibya = $1001;\r\n IDArabicMorocco = $1801; IDArabicOman = $2001;\r\n IDArabicQatar = $4001; IDArabic = $0401;\r\n IDArabicSyria = $2801; IDArabicTunisia = $1C01;\r\n IDArabicUAE = $3801; IDArabicYemen = $2401;\r\n IDArmenian = $042B; IDAssamese = $044D;\r\n IDAzeriCyrillic = $082C; IDAzeriLatin = $042C;\r\n IDBasque = $042D; IDByelorussian = $0423;\r\n IDBengali = $0445; IDBulgarian = $0402;\r\n IDBurmese = $0455; IDCatalan = $0403;\r\n IDChineseHongKong = $0C04; IDChineseMacao = $1404;\r\n IDSimplifiedChinese = $0804; IDChineseSingapore = $1004;\r\n IDTraditionalChinese = $0404; IDCroatian = $041A;\r\n IDCzech = $0405; IDDanish = $0406;\r\n IDBelgianDutch = $0813; IDDutch = $0413;\r\n IDEnglishAUS = $0C09; IDEnglishBelize = $2809;\r\n IDEnglishCanadian = $1009; IDEnglishCaribbean = $2409;\r\n IDEnglishIreland = $1809; IDEnglishJamaica = $2009;\r\n IDEnglishNewZealand = $1409; IDEnglishPhilippines = $3409;\r\n IDEnglishSouthAfrica = $1C09; IDEnglishTrinidad = $2C09;\r\n IDEnglishUK = $0809; IDEnglishUS = $0409;\r\n IDEnglishZimbabwe = $3009; IDEstonian = $0425;\r\n IDFaeroese = $0438; IDFarsi = $0429;\r\n IDFinnish = $040B; IDBelgianFrench = $080C;\r\n IDFrenchCameroon = $2C0C; IDFrenchCanadian = $0C0C;\r\n IDFrenchCotedIvoire = $300C; IDFrench = $040C;\r\n IDFrenchLuxembourg = $140C; IDFrenchMali = $340C;\r\n IDFrenchMonaco = $180C; IDFrenchReunion = $200C;\r\n IDFrenchSenegal = $280C; IDSwissFrench = $100C;\r\n IDFrenchWestIndies = $1C0C; IDFrenchZaire = $240C;\r\n IDFrisianNetherlands = $0462; IDGaelicIreland = $083C;\r\n IDGaelicScotland = $043C; IDGalician = $0456;\r\n IDGeorgian = $0437; IDGermanAustria = $0C07;\r\n IDGerman = $0407; IDGermanLiechtenstein = $1407;\r\n IDGermanLuxembourg = $1007; IDSwissGerman = $0807;\r\n IDGreek = $0408; IDGujarati = $0447;\r\n IDHebrew = $040D; IDHindi = $0439;\r\n IDHungarian = $040E; IDIcelandic = $040F;\r\n IDIndonesian = $0421; IDItalian = $0410;\r\n IDSwissItalian = $0810; IDJapanese = $0411;\r\n IDKannada = $044B; IDKashmiri = $0460;\r\n IDKazakh = $043F; IDKhmer = $0453;\r\n IDKirghiz = $0440; IDKonkani = $0457;\r\n IDKorean = $0412; IDLao = $0454;\r\n IDLatvian = $0426; IDLithuanian = $0427;\r\n IDMacedonian = $042F; IDMalaysian = $043E;\r\n IDMalayBruneiDarussalam = $083E; IDMalayalam = $044C;\r\n IDMaltese = $043A; IDManipuri = $0458;\r\n IDMarathi = $044E; IDMongolian = $0450;\r\n IDNepali = $0461; IDNorwegianBokmol = $0414;\r\n IDNorwegianNynorsk = $0814; IDOriya = $0448;\r\n IDPolish = $0415; IDBrazilianPortuguese = $0416;\r\n IDPortuguese = $0816; IDPunjabi = $0446;\r\n IDRhaetoRomanic = $0417; IDRomanianMoldova = $0818;\r\n IDRomanian = $0418; IDRussianMoldova = $0819;\r\n IDRussian = $0419; IDSamiLappish = $043B;\r\n IDSanskrit = $044F; IDSerbianCyrillic = $0C1A;\r\n IDSerbianLatin = $081A; IDSesotho = $0430;\r\n IDSindhi = $0459; IDSlovak = $041B;\r\n IDSlovenian = $0424; IDSorbian = $042E;\r\n IDSpanishArgentina = $2C0A; IDSpanishBolivia = $400A;\r\n IDSpanishChile = $340A; IDSpanishColombia = $240A;\r\n IDSpanishCostaRica = $140A; IDSpanishDominicanRepublic = $1C0A;\r\n IDSpanishEcuador = $300A; IDSpanishElSalvador = $440A;\r\n IDSpanishGuatemala = $100A; IDSpanishHonduras = $480A;\r\n IDMexicanSpanish = $080A; IDSpanishNicaragua = $4C0A;\r\n IDSpanishPanama = $180A; IDSpanishParaguay = $3C0A;\r\n IDSpanishPeru = $280A; IDSpanishPuertoRico = $500A;\r\n IDSpanishModernSort = $0C0A; IDSpanish = $040A;\r\n IDSpanishUruguay = $380A; IDSpanishVenezuela = $200A;\r\n IDSutu = $0430; IDSwahili = $0441;\r\n IDSwedishFinland = $081D; IDSwedish = $041D;\r\n IDTajik = $0428; IDTamil = $0449;\r\n IDTatar = $0444; IDTelugu = $044A;\r\n IDThai = $041E; IDTibetan = $0451;\r\n IDTsonga = $0431; IDTswana = $0432;\r\n IDTurkish = $041F; IDTurkmen = $0442;\r\n IDUkrainian = $0422; IDUrdu = $0420;\r\n IDUzbekCyrillic = $0843; IDUzbekLatin = $0443;\r\n IDVenda = $0433; IDVietnamese = $042A;\r\n IDWelsh = $0452; IDXhosa = $0434;\r\n IDZulu = $0435;\r\n\r\nfunction GetWindowsLanguage: WideString;\r\nvar\r\n langid: Cardinal;\r\n langcode: WideString;\r\n CountryName: array[0..4] of widechar;\r\n LanguageName: array[0..4] of widechar;\r\n works: boolean;\r\nbegin\r\n // The return value of GetLocaleInfo is compared with 3 = 2 characters and a zero\r\n works := 3 = GetLocaleInfoW(LOCALE_USER_DEFAULT, LOCALE_SISO639LANGNAME, LanguageName, SizeOf(LanguageName));\r\n works := works and (3 = GetLocaleInfoW(LOCALE_USER_DEFAULT, LOCALE_SISO3166CTRYNAME, CountryName, SizeOf(CountryName)));\r\n if works then begin\r\n // Windows 98, Me, NT4, 2000, XP and newer\r\n LangCode := PWideChar(@(LanguageName[0]));\r\n if lowercase(LangCode)='no' then LangCode:='nb';\r\n LangCode:=LangCode + '_' + PWideChar(@CountryName[0]);\r\n end else begin\r\n // This part should only happen on Windows 95.\r\n langid := GetThreadLocale;\r\n case langid of\r\n IDBelgianDutch: langcode := 'nl_BE';\r\n IDBelgianFrench: langcode := 'fr_BE';\r\n IDBrazilianPortuguese: langcode := 'pt_BR';\r\n IDDanish: langcode := 'da_DK';\r\n IDDutch: langcode := 'nl_NL';\r\n IDEnglishUK: langcode := 'en_GB';\r\n IDEnglishUS: langcode := 'en_US';\r\n IDFinnish: langcode := 'fi_FI';\r\n IDFrench: langcode := 'fr_FR';\r\n IDFrenchCanadian: langcode := 'fr_CA';\r\n IDGerman: langcode := 'de_DE';\r\n IDGermanLuxembourg: langcode := 'de_LU';\r\n IDGreek: langcode := 'el_GR';\r\n IDIcelandic: langcode := 'is_IS';\r\n IDItalian: langcode := 'it_IT';\r\n IDKorean: langcode := 'ko_KO';\r\n IDNorwegianBokmol: langcode := 'nb_NO';\r\n IDNorwegianNynorsk: langcode := 'nn_NO';\r\n IDPolish: langcode := 'pl_PL';\r\n IDPortuguese: langcode := 'pt_PT';\r\n IDRussian: langcode := 'ru_RU';\r\n IDSpanish, IDSpanishModernSort: langcode := 'es_ES';\r\n IDSwedish: langcode := 'sv_SE';\r\n IDSwedishFinland: langcode := 'sv_FI';\r\n else\r\n langcode := 'C';\r\n end;\r\n end;\r\n Result := langcode;\r\nend;\r\n{$endif}\r\n\r\n{$ifndef UNICODE}\r\nfunction LoadResStringA(ResStringRec: PResStringRec): ansistring;\r\nbegin\r\n Result:=DefaultInstance.LoadResString(ResStringRec);\r\nend;\r\n{$endif}\r\n\r\nfunction GetTranslatorNameAndEmail:TranslatedUnicodeString;\r\nbegin\r\n Result:=DefaultInstance.GetTranslatorNameAndEmail;\r\nend;\r\n\r\nprocedure UseLanguage(LanguageCode: LanguageString);\r\nbegin\r\n DefaultInstance.UseLanguage(LanguageCode);\r\nend;\r\n\r\ntype\r\n PStrData = ^TStrData;\r\n TStrData = record\r\n Ident: Integer;\r\n Str: String;\r\n end;\r\n \r\nfunction SysUtilsEnumStringModules(Instance: {$IFDEF DELPHI2012OROLDER}NativeInt{$ELSE}Integer{$ENDIF DELPHI2012OROLDER}; Data: Pointer): Boolean;\r\n{$IFDEF MSWINDOWS}\r\nvar\r\n Buffer: array [0..1023] of Char; // WideChar in Delphi 2008, AnsiChar before that\r\nbegin\r\n with PStrData(Data)^ do begin\r\n SetString(Str, Buffer,\r\n LoadString(Instance, Ident, @Buffer[0], sizeof(Buffer)));\r\n Result := Str = '';\r\n end;\r\nend;\r\n{$ENDIF}\r\n{$IFDEF LINUX}\r\nvar\r\n rs:TResStringRec;\r\n Module:HModule;\r\nbegin\r\n Module:=Instance;\r\n rs.Module:=@Module;\r\n with PStrData(Data)^ do begin\r\n rs.Identifier:=Ident;\r\n Str:=System.LoadResString(@rs);\r\n Result:=Str='';\r\n end;\r\nend;\r\n{$ENDIF}\r\n\r\nfunction SysUtilsFindStringResource(Ident: NativeInt): string;\r\nvar\r\n StrData: TStrData;\r\nbegin\r\n StrData.Ident := Ident;\r\n StrData.Str := '';\r\n EnumResourceModules(SysUtilsEnumStringModules, @StrData);\r\n Result := StrData.Str;\r\nend;\r\n\r\nfunction SysUtilsLoadStr(Ident: Integer): string;\r\nbegin\r\n {$ifdef DXGETTEXTDEBUG}\r\n DefaultInstance.DebugWriteln ('Sysutils.LoadRes('+IntToStr(ident)+') called');\r\n {$endif}\r\n Result := ResourceStringGettext(SysUtilsFindStringResource(Ident));\r\nend;\r\n\r\nfunction SysUtilsFmtLoadStr(Ident: Integer; const Args: array of const): string;\r\nbegin\r\n {$ifdef DXGETTEXTDEBUG}\r\n DefaultInstance.DebugWriteln ('Sysutils.FmtLoadRes('+IntToStr(ident)+',Args) called');\r\n {$endif}\r\n FmtStr(Result, ResourceStringGettext(SysUtilsFindStringResource(Ident)),Args);\r\nend;\r\n\r\nfunction LoadResString(ResStringRec: PResStringRec): widestring;\r\nbegin\r\n Result:=DefaultInstance.LoadResString(ResStringRec);\r\nend;\r\n\r\nfunction LoadResStringW(ResStringRec: PResStringRec): UnicodeString;\r\nbegin\r\n Result:=DefaultInstance.LoadResString(ResStringRec);\r\nend;\r\n\r\n\r\n\r\nfunction GetCurrentLanguage:LanguageString;\r\nbegin\r\n Result:=DefaultInstance.GetCurrentLanguage;\r\nend;\r\n\r\n{ TDomain }\r\n\r\nprocedure TDomain.CloseMoFile;\r\nbegin\r\n if mofile<>nil then begin\r\n FileLocator.ReleaseMoFile(mofile);\r\n mofile:=nil;\r\n end;\r\n OpenHasFailedBefore:=False;\r\nend;\r\n\r\ndestructor TDomain.Destroy;\r\nbegin\r\n CloseMoFile;\r\n inherited;\r\nend;\r\n\r\n{$ifdef mswindows}\r\nfunction GetLastWinError:widestring;\r\nvar\r\n errcode:Cardinal;\r\nbegin\r\n SetLength (Result,2000);\r\n errcode:=GetLastError();\r\n Windows.FormatMessageW(FORMAT_MESSAGE_FROM_SYSTEM,nil,errcode,0,PWideChar(Result),2000,nil);\r\n Result:=PWideChar(Result);\r\nend;\r\n{$endif}\r\n\r\nprocedure TDomain.OpenMoFile;\r\nvar\r\n filename: FilenameString;\r\nbegin\r\n // Check if it is already open\r\n if mofile<>nil then\r\n exit;\r\n\r\n // Check if it has been attempted to open the file before\r\n if OpenHasFailedBefore then\r\n exit;\r\n\r\n if SpecificFilename<>'' then begin\r\n filename:=SpecificFilename;\r\n {$ifdef DXGETTEXTDEBUG}\r\n DebugLogger ('Domain '+domain+' is bound to specific file '+filename);\r\n {$endif}\r\n end else begin\r\n filename := Directory + curlang + PathDelim + 'LC_MESSAGES' + PathDelim + domain + '.mo';\r\n if (not FileLocator.FileExists(filename)) and (not fileexists(filename)) then begin\r\n {$ifdef DXGETTEXTDEBUG}\r\n DebugLogger ('Domain '+domain+': File does not exist, neither embedded or in file system: '+filename);\r\n {$endif}\r\n filename := Directory + MidStr(curlang, 1, 2) + PathDelim + 'LC_MESSAGES' + PathDelim + domain + '.mo';\r\n {$ifdef DXGETTEXTDEBUG}\r\n DebugLogger ('Domain '+domain+' will attempt to use this file: '+filename);\r\n {$endif}\r\n end else begin\r\n {$ifdef DXGETTEXTDEBUG}\r\n if FileLocator.FileExists(filename) then\r\n DebugLogger ('Domain '+domain+' will attempt to use this embedded file: '+filename)\r\n else\r\n DebugLogger ('Domain '+domain+' will attempt to use this file that was found on the file system: '+filename);\r\n {$endif}\r\n end;\r\n end;\r\n if (not FileLocator.FileExists(filename)) and (not fileexists(filename)) then begin\r\n {$ifdef DXGETTEXTDEBUG}\r\n DebugLogger ('Domain '+domain+' failed to locate the file: '+filename);\r\n {$endif}\r\n OpenHasFailedBefore:=True;\r\n exit;\r\n end;\r\n {$ifdef DXGETTEXTDEBUG}\r\n DebugLogger ('Domain '+domain+' now accesses the file.');\r\n {$endif}\r\n mofile:=FileLocator.GetMoFile(filename, DebugLogger);\r\n\r\n {$ifdef DXGETTEXTDEBUG}\r\n if mofile.isSwappedArchitecture then\r\n DebugLogger ('.mo file is swapped (comes from another CPU architecture)');\r\n {$endif}\r\n\r\n // Check, that the contents of the file is utf-8\r\n if pos('CHARSET=UTF-8',uppercase(GetTranslationProperty('Content-Type')))=0 then begin\r\n CloseMoFile;\r\n {$ifdef DXGETTEXTDEBUG}\r\n DebugLogger ('The translation for the language code '+curlang+' (in '+filename+') does not have charset=utf-8 in its Content-Type. Translations are turned off.');\r\n {$endif}\r\n {$ifdef MSWINDOWS}\r\n MessageBoxW(0,PWideChar(widestring('The translation for the language code '+curlang+' (in '+filename+') does not have charset=utf-8 in its Content-Type. Translations are turned off.')),'Localization problem',MB_OK);\r\n {$else}\r\n writeln (stderr,'The translation for the language code '+curlang+' (in '+filename+') does not have charset=utf-8 in its Content-Type. Translations are turned off.');\r\n {$endif}\r\n Enabled:=False;\r\n end;\r\nend;\r\n\r\n{$IFDEF UNICODE}\r\nfunction utf8decode (s:RawByteString):UnicodeString; inline;\r\nbegin\r\n Result:=UTF8ToWideString(s);\r\nend;\r\n{$endif}\r\n\r\nfunction TDomain.GetTranslationProperty(\r\n Propertyname: ComponentNameString): TranslatedUnicodeString;\r\nvar\r\n sl:TStringList;\r\n i:integer;\r\n s:string;\r\nbegin\r\n Propertyname:=uppercase(Propertyname)+': ';\r\n sl:=TStringList.Create; \r\n try\r\n sl.Text:=utf8decode(gettext(''));\r\n for i:=0 to sl.Count-1 do begin\r\n s:=sl.Strings[i];\r\n if uppercase(MidStr(s,1,length(Propertyname)))=Propertyname then begin\r\n Result:=trim(MidStr(s,length(PropertyName)+1,maxint));\r\n\r\n {$ifdef DXGETTEXTDEBUG}\r\n DebugLogger ('GetTranslationProperty('+PropertyName+') returns '''+Result+'''.');\r\n {$endif}\r\n exit;\r\n end;\r\n end;\r\n finally\r\n FreeAndNil (sl);\r\n end;\r\n Result:='';\r\n {$ifdef DXGETTEXTDEBUG}\r\n DebugLogger ('GetTranslationProperty('+PropertyName+') did not find any value. An empty string is returned.');\r\n {$endif}\r\nend;\r\n\r\nprocedure TDomain.setDirectory(const dir: FilenameString);\r\nbegin\r\n vDirectory := IncludeTrailingPathDelimiter(dir);\r\n SpecificFilename:='';\r\n CloseMoFile;\r\nend;\r\n\r\nprocedure AddDomainForResourceString (const domain:DomainString);\r\nbegin\r\n {$ifdef DXGETTEXTDEBUG}\r\n DefaultInstance.DebugWriteln ('Extra domain for resourcestring: '+domain);\r\n {$endif}\r\n ResourceStringDomainListCS.BeginWrite;\r\n try\r\n if ResourceStringDomainList.IndexOf(domain)=-1 then\r\n ResourceStringDomainList.Add (domain);\r\n finally\r\n ResourceStringDomainListCS.EndWrite;\r\n end;\r\nend;\r\n\r\nprocedure RemoveDomainForResourceString (const domain:DomainString);\r\nvar\r\n i:integer;\r\nbegin\r\n {$ifdef DXGETTEXTDEBUG}\r\n DefaultInstance.DebugWriteln ('Remove domain for resourcestring: '+domain);\r\n {$endif}\r\n ResourceStringDomainListCS.BeginWrite;\r\n try\r\n i:=ResourceStringDomainList.IndexOf(domain);\r\n if i<>-1 then\r\n ResourceStringDomainList.Delete (i);\r\n finally\r\n ResourceStringDomainListCS.EndWrite;\r\n end;\r\nend;\r\n\r\nprocedure AddDomainForComponent (const domain:DomainString);\r\nbegin\r\n {$ifdef DXGETTEXTDEBUG}\r\n DefaultInstance.DebugWriteln ('Extra domain for component: '+domain);\r\n {$endif}\r\n ComponentDomainListCS.BeginWrite;\r\n try\r\n if ComponentDomainList.IndexOf(domain)=-1 then\r\n ComponentDomainList.Add (domain);\r\n finally\r\n ComponentDomainListCS.EndWrite;\r\n end;\r\nend;\r\n\r\nprocedure RemoveDomainForComponent (const domain:DomainString);\r\nvar\r\n i:integer;\r\nbegin\r\n {$ifdef DXGETTEXTDEBUG}\r\n DefaultInstance.DebugWriteln ('Remove domain for component: '+domain);\r\n {$endif}\r\n ComponentDomainListCS.BeginWrite;\r\n try\r\n i:=ComponentDomainList.IndexOf(domain);\r\n if i<>-1 then\r\n ComponentDomainList.Delete (i);\r\n finally\r\n ComponentDomainListCS.EndWrite;\r\n end;\r\nend;\r\n\r\nprocedure TDomain.SetLanguageCode(const langcode: LanguageString);\r\nbegin\r\n CloseMoFile;\r\n curlang:=langcode;\r\nend;\r\n\r\nfunction GetPluralForm2EN(Number: Integer): Integer;\r\nbegin\r\n Number:=abs(Number);\r\n if Number=1 then Result:=0 else Result:=1;\r\nend;\r\n\r\nfunction GetPluralForm1(Number: Integer): Integer;\r\nbegin\r\n Result:=0;\r\nend;\r\n\r\nfunction GetPluralForm2FR(Number: Integer): Integer;\r\nbegin\r\n Number:=abs(Number);\r\n if (Number=1) or (Number=0) then Result:=0 else Result:=1;\r\nend;\r\n\r\nfunction GetPluralForm3LV(Number: Integer): Integer;\r\nbegin\r\n Number:=abs(Number);\r\n if (Number mod 10=1) and (Number mod 100<>11) then\r\n Result:=0\r\n else\r\n if Number<>0 then Result:=1\r\n else Result:=2;\r\nend;\r\n\r\nfunction GetPluralForm3GA(Number: Integer): Integer;\r\nbegin\r\n Number:=abs(Number);\r\n if Number=1 then Result:=0\r\n else if Number=2 then Result:=1\r\n else Result:=2;\r\nend;\r\n\r\nfunction GetPluralForm3LT(Number: Integer): Integer;\r\nvar\r\n n1,n2:byte;\r\nbegin\r\n Number:=abs(Number);\r\n n1:=Number mod 10;\r\n n2:=Number mod 100;\r\n if (n1=1) and (n2<>11) then\r\n Result:=0\r\n else\r\n if (n1>=2) and ((n2<10) or (n2>=20)) then Result:=1\r\n else Result:=2;\r\nend;\r\n\r\nfunction GetPluralForm3PL(Number: Integer): Integer;\r\nvar\r\n n1,n2:byte;\r\nbegin\r\n Number:=abs(Number);\r\n n1:=Number mod 10;\r\n n2:=Number mod 100;\r\n\r\n if Number=1 then Result:=0 \r\n else if (n1>=2) and (n1<=4) and ((n2<10) or (n2>=20)) then Result:=1\r\n else Result:=2;\r\nend;\r\n\r\nfunction GetPluralForm3RU(Number: Integer): Integer;\r\nvar\r\n n1,n2:byte;\r\nbegin\r\n Number:=abs(Number);\r\n n1:=Number mod 10;\r\n n2:=Number mod 100;\r\n if (n1=1) and (n2<>11) then\r\n Result:=0\r\n else\r\n if (n1>=2) and (n1<=4) and ((n2<10) or (n2>=20)) then Result:=1\r\n else Result:=2;\r\nend;\r\n\r\nfunction GetPluralForm3SK(Number: Integer): Integer;\r\nbegin\r\n Number:=abs(Number);\r\n if number=1 then Result:=0\r\n else if (number<5) and (number<>0) then Result:=1\r\n else Result:=2;\r\nend;\r\n\r\nfunction GetPluralForm4SL(Number: Integer): Integer;\r\nvar\r\n n2:byte;\r\nbegin\r\n Number:=abs(Number);\r\n n2:=Number mod 100;\r\n if n2=1 then Result:=0\r\n else\r\n if n2=2 then Result:=1\r\n else\r\n if (n2=3) or (n2=4) then Result:=2\r\n else\r\n Result:=3;\r\nend;\r\n\r\nprocedure TDomain.GetListOfLanguages(list: TStrings);\r\nvar\r\n sr:TSearchRec;\r\n more:boolean;\r\n filename, path:FilenameString;\r\n langcode:LanguageString;\r\n i, j:integer;\r\nbegin\r\n list.Clear;\r\n\r\n // Iterate through filesystem\r\n more:=FindFirst (Directory+'*',faAnyFile,sr)=0;\r\n try\r\n while more do begin\r\n if (sr.Attr and faDirectory<>0) and (sr.name<>'.') and (sr.name<>'..') then begin\r\n filename := Directory + sr.Name + PathDelim + 'LC_MESSAGES' + PathDelim + domain + '.mo';\r\n if fileexists(filename) then begin\r\n langcode:=lowercase(sr.name);\r\n if list.IndexOf(langcode)=-1 then\r\n list.Add(langcode);\r\n end;\r\n end;\r\n more:=FindNext (sr)=0;\r\n end;\r\n finally\r\n FindClose (sr);\r\n end;\r\n\r\n // Iterate through embedded files\r\n for i:=0 to FileLocator.filelist.Count-1 do begin\r\n filename:=FileLocator.basedirectory+FileLocator.filelist.Strings[i];\r\n path:=Directory;\r\n {$ifdef MSWINDOWS}\r\n path:=uppercase(path);\r\n filename:=uppercase(filename);\r\n {$endif}\r\n j:=length(path);\r\n if MidStr(filename,1,j)=path then begin\r\n path:=PathDelim + 'LC_MESSAGES' + PathDelim + domain + '.mo';\r\n {$ifdef MSWINDOWS}\r\n path:=uppercase(path);\r\n {$endif}\r\n if MidStr(filename,length(filename)-length(path)+1,length(path))=path then begin\r\n langcode:=lowercase(MidStr(filename,j+1,length(filename)-length(path)-j));\r\n langcode:=LeftStr(langcode,3)+uppercase(MidStr(langcode,4,maxint));\r\n if list.IndexOf(langcode)=-1 then\r\n list.Add(langcode);\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TDomain.SetFilename(const filename: FilenameString);\r\nbegin\r\n CloseMoFile;\r\n vDirectory := '';\r\n SpecificFilename:=filename;\r\nend;\r\n\r\nfunction TDomain.gettext(const msgid: RawUtf8String): RawUtf8String;\r\nvar\r\n found:boolean;\r\nbegin\r\n if not Enabled then begin\r\n Result:=msgid;\r\n exit;\r\n end;\r\n if (mofile=nil) and (not OpenHasFailedBefore) then\r\n OpenMoFile;\r\n if mofile=nil then begin\r\n {$ifdef DXGETTEXTDEBUG}\r\n DebugLogger('.mo file is not open. Not translating \"'+msgid+'\"');\r\n {$endif}\r\n Result := msgid;\r\n end else begin\r\n Result:=mofile.gettext(msgid,found);\r\n {$ifdef DXGETTEXTDEBUG}\r\n if found then\r\n DebugLogger ('Found in .mo ('+Domain+'): \"'+utf8encode(msgid)+'\"->\"'+utf8encode(Result)+'\"')\r\n else\r\n DebugLogger ('Translation not found in .mo file ('+Domain+') : \"'+utf8encode(msgid)+'\"');\r\n {$endif}\r\n end;\r\nend;\r\n\r\nconstructor TDomain.Create;\r\nbegin\r\n inherited Create;\r\n Enabled:=True;\r\nend;\r\n\r\n{ TGnuGettextInstance }\r\n\r\nprocedure TGnuGettextInstance.bindtextdomain(const szDomain:DomainString;\r\n const szDirectory: FilenameString);\r\nvar\r\n dir:FilenameString;\r\nbegin\r\n dir:=IncludeTrailingPathDelimiter(szDirectory);\r\n {$ifdef DXGETTEXTDEBUG}\r\n DebugWriteln ('Text domain \"'+szDomain+'\" is now located at \"'+dir+'\"');\r\n {$endif}\r\n getdomain(szDomain,DefaultDomainDirectory,CurLang).Directory := dir;\r\n WhenNewDomainDirectory (szDomain, szDirectory);\r\nend;\r\n\r\nconstructor TGnuGettextInstance.Create;\r\nbegin\r\n {$ifdef MSWindows}\r\n DesignTimeCodePage:=CP_ACP;\r\n {$endif}\r\n {$ifdef DXGETTEXTDEBUG}\r\n DebugLogCS:=TMultiReadExclusiveWriteSynchronizer.Create;\r\n DebugLog:=TMemoryStream.Create;\r\n DebugWriteln('Debug log started '+DateTimeToStr(Now));\r\n DebugWriteln('GNU gettext module version: '+VCSVersion);\r\n DebugWriteln('');\r\n {$endif}\r\n curGetPluralForm:=GetPluralForm2EN;\r\n Enabled:=True;\r\n curmsgdomain:=DefaultTextDomain;\r\n savefileCS := TMultiReadExclusiveWriteSynchronizer.Create;\r\n domainlist := TStringList.Create;\r\n TP_IgnoreList:=TStringList.Create;\r\n TP_IgnoreList.Sorted:=True;\r\n TP_GlobalClassHandling:=TList.Create;\r\n TP_ClassHandling:=TList.Create;\r\n fWhenNewLanguageListeners := TInterfaceList.Create;\r\n\r\n // Set some settings\r\n DefaultDomainDirectory := IncludeTrailingPathDelimiter(extractfilepath(ExecutableFilename))+'locale';\r\n\r\n UseLanguage('');\r\n\r\n bindtextdomain(DefaultTextDomain, DefaultDomainDirectory);\r\n textdomain(DefaultTextDomain);\r\n\r\n // Add default properties to ignore\r\n TP_GlobalIgnoreClassProperty(TComponent,'Name');\r\n TP_GlobalIgnoreClassProperty(TCollection,'PropName');\r\nend;\r\n\r\ndestructor TGnuGettextInstance.Destroy;\r\nbegin\r\n if savememory <> nil then begin\r\n savefileCS.BeginWrite;\r\n try\r\n CloseFile(savefile);\r\n finally\r\n savefileCS.EndWrite;\r\n end;\r\n FreeAndNil(savememory);\r\n end;\r\n FreeAndNil (savefileCS);\r\n FreeAndNil (TP_IgnoreList);\r\n while TP_GlobalClassHandling.Count<>0 do begin\r\n TObject(TP_GlobalClassHandling.Items[0]).Free;\r\n TP_GlobalClassHandling.Delete(0);\r\n end;\r\n FreeAndNil (TP_GlobalClassHandling);\r\n FreeTP_ClassHandlingItems;\r\n FreeAndNil (TP_ClassHandling);\r\n while domainlist.Count <> 0 do begin\r\n domainlist.Objects[0].Free;\r\n domainlist.Delete(0);\r\n end;\r\n FreeAndNil(domainlist);\r\n fWhenNewLanguageListeners.Free;\r\n {$ifdef DXGETTEXTDEBUG}\r\n FreeAndNil (DebugLog);\r\n FreeAndNil (DebugLogCS);\r\n {$endif}\r\n inherited;\r\nend;\r\n\r\n{$ifndef UNICODE}\r\nfunction TGnuGettextInstance.dgettext(const szDomain: DomainString; const szMsgId: ansistring): TranslatedUnicodeString;\r\nbegin\r\n Result:=dgettext(szDomain, ansi2wideDTCP(szMsgId));\r\nend;\r\n{$endif}\r\n\r\nfunction TGnuGettextInstance.dgettext(const szDomain: DomainString;\r\n const szMsgId: MsgIdString): TranslatedUnicodeString;\r\nbegin\r\n if not Enabled then begin\r\n {$ifdef DXGETTEXTDEBUG}\r\n DebugWriteln ('Translation has been disabled. Text is not being translated: '+szMsgid);\r\n {$endif}\r\n Result:=szMsgId;\r\n end else begin\r\n Result:=UTF8Decode(EnsureLineBreakInTranslatedString(getdomain(szDomain,DefaultDomainDirectory,CurLang).gettext(StripCRRawMsgId(utf8encode(szMsgId)))));\r\n\r\n {$ifdef DXGETTEXTDEBUG}\r\n if (szMsgId<>'') and (Result='') then\r\n DebugWriteln (Format('Error: Translation of %s was an empty string. This may never occur.',[szMsgId]));\r\n {$endif}\r\n end;\r\nend;\r\n\r\nfunction TGnuGettextInstance.dgettext_NoExtract(const szDomain: DomainString;\r\n const szMsgId: MsgIdString): TranslatedUnicodeString;\r\nbegin\r\n // This one is very useful for translating text in variables.\r\n // This can sometimes be necessary, and by using this function,\r\n // the source code scanner will not trigger warnings.\r\n Result:=dgettext(szDomain,szMsgId);\r\nend;\r\n\r\nfunction TGnuGettextInstance.GetCurrentLanguage: LanguageString;\r\nbegin\r\n Result:=curlang;\r\nend;\r\n\r\nfunction TGnuGettextInstance.getcurrenttextdomain: DomainString;\r\nbegin\r\n Result := curmsgdomain;\r\nend;\r\n\r\n{$ifndef UNICODE}\r\nfunction TGnuGettextInstance.gettext(\r\n const szMsgId: ansistring): TranslatedUnicodeString;\r\nbegin\r\n Result := dgettext(curmsgdomain, szMsgId);\r\nend;\r\n{$endif}\r\n\r\nfunction TGnuGettextInstance.gettext(\r\n const szMsgId: MsgIdString): TranslatedUnicodeString;\r\nbegin\r\n Result := dgettext(curmsgdomain, szMsgId);\r\nend;\r\n\r\nfunction TGnuGettextInstance.gettext_NoExtract(\r\n const szMsgId: MsgIdString): TranslatedUnicodeString;\r\nbegin\r\n // This one is very useful for translating text in variables.\r\n // This can sometimes be necessary, and by using this function,\r\n // the source code scanner will not trigger warnings.\r\n Result:=gettext (szMsgId);\r\nend;\r\n\r\nfunction TGnuGettextInstance.gettext_NoOp(const szMsgId: MsgIdString): TranslatedUnicodeString;\r\nbegin\r\n //*** With this function Strings can be added to the po-file without beeing\r\n // ResourceStrings (dxgettext will add the string and this function will\r\n // return it without a change)\r\n // see gettext manual\r\n // 4.7 - Special Cases of Translatable Strings\r\n // http://www.gnu.org/software/hello/manual/gettext/Special-cases.html#Special-cases\r\n Result := TranslatedUnicodeString(szMsgId);\r\nend;\r\n\r\nprocedure TGnuGettextInstance.textdomain(const szDomain: DomainString);\r\nbegin\r\n {$ifdef DXGETTEXTDEBUG}\r\n DebugWriteln ('Changed text domain to \"'+szDomain+'\"');\r\n {$endif}\r\n curmsgdomain := szDomain;\r\n WhenNewDomain (szDomain);\r\nend;\r\n\r\nfunction TGnuGettextInstance.TP_CreateRetranslator : TExecutable;\r\nvar\r\n ttpr:TTP_Retranslator;\r\nbegin\r\n ttpr:=TTP_Retranslator.Create;\r\n ttpr.Instance:=self;\r\n TP_Retranslator:=ttpr;\r\n Result:=ttpr;\r\n {$ifdef DXGETTEXTDEBUG}\r\n DebugWriteln ('A retranslator was created.');\r\n {$endif}\r\nend;\r\n\r\nprocedure TGnuGettextInstance.TP_GlobalHandleClass(HClass: TClass;\r\n Handler: TTranslator);\r\nvar\r\n cm:TClassMode;\r\n i:integer;\r\nbegin\r\n for i:=0 to TP_GlobalClassHandling.Count-1 do begin\r\n cm:=TObject(TP_GlobalClassHandling.Items[i]) as TClassMode;\r\n if cm.HClass=HClass then\r\n raise EGGProgrammingError.Create ('You cannot set a handler for a class that has already been assigned otherwise.');\r\n if HClass.InheritsFrom(cm.HClass) then begin\r\n // This is the place to insert this class\r\n cm:=TClassMode.Create;\r\n cm.HClass:=HClass;\r\n cm.SpecialHandler:=Handler;\r\n TP_GlobalClassHandling.Insert(i,cm);\r\n {$ifdef DXGETTEXTDEBUG}\r\n DebugWriteln ('A handler was set for class '+HClass.ClassName+'.');\r\n {$endif}\r\n exit;\r\n end;\r\n end;\r\n cm:=TClassMode.Create;\r\n cm.HClass:=HClass;\r\n cm.SpecialHandler:=Handler;\r\n TP_GlobalClassHandling.Add(cm);\r\n {$ifdef DXGETTEXTDEBUG}\r\n DebugWriteln ('A handler was set for class '+HClass.ClassName+'.');\r\n {$endif}\r\nend;\r\n\r\nprocedure TGnuGettextInstance.TP_GlobalIgnoreClass(IgnClass: TClass);\r\nvar\r\n cm:TClassMode;\r\n i:integer;\r\nbegin\r\n for i:=0 to TP_GlobalClassHandling.Count-1 do begin\r\n cm:=TObject(TP_GlobalClassHandling.Items[i]) as TClassMode;\r\n if cm.HClass=IgnClass then\r\n raise EGGProgrammingError.Create ('You cannot add a class to the ignore list that is already on that list: '+IgnClass.ClassName+'. You should keep all TP_Global functions in one place in your source code.');\r\n if IgnClass.InheritsFrom(cm.HClass) then begin\r\n // This is the place to insert this class\r\n cm:=TClassMode.Create;\r\n cm.HClass:=IgnClass;\r\n TP_GlobalClassHandling.Insert(i,cm);\r\n {$ifdef DXGETTEXTDEBUG}\r\n DebugWriteln ('Globally, class '+IgnClass.ClassName+' is being ignored.');\r\n {$endif}\r\n exit;\r\n end;\r\n end;\r\n cm:=TClassMode.Create;\r\n cm.HClass:=IgnClass;\r\n TP_GlobalClassHandling.Add(cm);\r\n {$ifdef DXGETTEXTDEBUG}\r\n DebugWriteln ('Globally, class '+IgnClass.ClassName+' is being ignored.');\r\n {$endif}\r\nend;\r\n\r\nprocedure TGnuGettextInstance.TP_GlobalIgnoreClassProperty(\r\n IgnClass: TClass; propertyname: ComponentNameString);\r\nvar\r\n cm:TClassMode;\r\n i,idx:integer;\r\nbegin\r\n propertyname:=uppercase(propertyname);\r\n for i:=0 to TP_GlobalClassHandling.Count-1 do begin\r\n cm:=TObject(TP_GlobalClassHandling.Items[i]) as TClassMode;\r\n if cm.HClass=IgnClass then begin\r\n if Assigned(cm.SpecialHandler) then\r\n raise EGGProgrammingError.Create ('You cannot ignore a class property for a class that has a handler set.');\r\n if not cm.PropertiesToIgnore.Find(propertyname,idx) then\r\n cm.PropertiesToIgnore.Add(propertyname);\r\n {$ifdef DXGETTEXTDEBUG}\r\n DebugWriteln ('Globally, the '+propertyname+' property of class '+IgnClass.ClassName+' is being ignored.');\r\n {$endif}\r\n exit;\r\n end;\r\n if IgnClass.InheritsFrom(cm.HClass) then begin\r\n // This is the place to insert this class\r\n cm:=TClassMode.Create;\r\n cm.HClass:=IgnClass;\r\n cm.PropertiesToIgnore.Add(propertyname);\r\n TP_GlobalClassHandling.Insert(i,cm);\r\n {$ifdef DXGETTEXTDEBUG}\r\n DebugWriteln ('Globally, the '+propertyname+' property of class '+IgnClass.ClassName+' is being ignored.');\r\n {$endif}\r\n exit;\r\n end;\r\n end;\r\n cm:=TClassMode.Create;\r\n cm.HClass:=IgnClass;\r\n cm.PropertiesToIgnore.Add(propertyname);\r\n TP_GlobalClassHandling.Add(cm);\r\n {$ifdef DXGETTEXTDEBUG}\r\n DebugWriteln ('Globally, the '+propertyname+' property of class '+IgnClass.ClassName+' is being ignored.');\r\n {$endif}\r\nend;\r\n\r\nprocedure TGnuGettextInstance.TP_Ignore(AnObject: TObject;\r\n const name: ComponentNameString);\r\nbegin\r\n TP_IgnoreList.Add(uppercase(name));\r\n {$ifdef DXGETTEXTDEBUG}\r\n DebugWriteln ('On object with class name '+AnObject.ClassName+', ignore is set on '+name);\r\n {$endif}\r\nend;\r\n\r\nprocedure TGnuGettextInstance.TranslateComponent(AnObject: TComponent;\r\n const TextDomain: DomainString);\r\nvar\r\n comp:TGnuGettextComponentMarker;\r\nbegin\r\n {$ifdef DXGETTEXTDEBUG}\r\n DebugWriteln ('======================================================================');\r\n DebugWriteln ('TranslateComponent() was called for a component with name '+AnObject.Name+'.');\r\n {$endif}\r\n comp:=AnObject.FindComponent('GNUgettextMarker') as TGnuGettextComponentMarker;\r\n if comp=nil then begin\r\n comp:=TGnuGettextComponentMarker.Create (nil);\r\n comp.Name:='GNUgettextMarker';\r\n comp.Retranslator:=TP_CreateRetranslator;\r\n TranslateProperties (AnObject, TextDomain);\r\n AnObject.InsertComponent(comp);\r\n {$ifdef DXGETTEXTDEBUG}\r\n DebugWriteln ('This is the first time, that this component has been translated. A retranslator component has been created for this component.');\r\n {$endif}\r\n end else begin\r\n {$ifdef DXGETTEXTDEBUG}\r\n DebugWriteln ('This is not the first time, that this component has been translated.');\r\n {$endif}\r\n if comp.LastLanguage<>curlang then begin\r\n {$ifdef DXGETTEXTDEBUG}\r\n DebugWriteln ('ERROR: TranslateComponent() was called twice with different languages. This indicates an attempt to switch language at runtime, but by using TranslateComponent every time. This API has changed - please use RetranslateComponent() instead.');\r\n {$endif}\r\n {$ifdef mswindows}\r\n MessageBox (0,'This application tried to switch the language, but in an incorrect way. The programmer needs to replace a call to TranslateComponent with a call to RetranslateComponent(). The programmer should see the changelog of gnugettext.pas for more information.','Error',MB_OK);\r\n {$else}\r\n writeln (stderr,'This application tried to switch the language, but in an incorrect way. The programmer needs to replace a call to TranslateComponent with a call to RetranslateComponent(). The programmer should see the changelog of gnugettext.pas for more information.');\r\n {$endif}\r\n end else begin\r\n {$ifdef DXGETTEXTDEBUG}\r\n DebugWriteln ('ERROR: TranslateComponent has been called twice, but with the same language chosen. This is a mistake, but in order to prevent that the application breaks, no exception is raised.');\r\n {$endif}\r\n end;\r\n end;\r\n comp.LastLanguage:=curlang;\r\n {$ifdef DXGETTEXTDEBUG}\r\n DebugWriteln ('======================================================================');\r\n {$endif}\r\nend;\r\n\r\nprocedure TGnuGettextInstance.TranslateProperty (AnObject:TObject; PropInfo:PPropInfo; TodoList:TStrings; const TextDomain:DomainString);\r\nvar\r\n ppi:PPropInfo;\r\n ws: TranslatedUnicodeString;\r\n old: TranslatedUnicodeString;\r\n compmarker:TComponent;\r\n obj:TObject;\r\n Propname:ComponentNameString;\r\nbegin\r\n PropName:=string(PropInfo^.Name);\r\n try\r\n // Translate certain types of properties\r\n case PropInfo^.PropType^.Kind of\r\n {$IFDEF UNICODE}\r\n // All dfm files returning tkUString\r\n tkString, tkLString, tkWString, tkUString:\r\n {$ELSE}\r\n tkString, tkLString, tkWString:\r\n {$ENDIF}\r\n begin\r\n {$ifdef DXGETTEXTDEBUG}\r\n DebugWriteln ('Translating '+AnObject.ClassName+'.'+PropName);\r\n {$endif}\r\n case PropInfo^.PropType^.Kind of\r\n tkString, tkLString :\r\n old := GetStrProp(AnObject, PropName);\r\n tkWString :\r\n old := {$IFDEF RTL240_UP}GetStrProp{$ELSE}GetWideStrProp{$ENDIF RTL240_UP}(AnObject, PropName);\r\n {$IFDEF UNICODE}\r\n tkUString :\r\n old := {$IFDEF RTL240_UP}GetStrProp{$ELSE}GetUnicodeStrProp{$ENDIF RTL240_UP}(AnObject, PropName);\r\n {$ENDIF}\r\n else\r\n raise Exception.Create ('Internal error: Illegal property type. This problem needs to be solved by a programmer, try to find a workaround.');\r\n end;\r\n {$ifdef DXGETTEXTDEBUG}\r\n if old='' then\r\n DebugWriteln ('(Empty, not translated)')\r\n else\r\n DebugWriteln ('Old value: \"'+old+'\"');\r\n {$endif}\r\n if (old <> '') and (IsWriteProp(PropInfo)) then begin\r\n if TP_Retranslator<>nil then\r\n (TP_Retranslator as TTP_Retranslator).Remember(AnObject, PropName, old);\r\n if textdomain = '' then\r\n ws := ComponentGettext(old)\r\n else\r\n ws := dgettext(textdomain,old);\r\n if ws <> old then begin\r\n ppi:=GetPropInfo(AnObject, Propname);\r\n if ppi<>nil then begin\r\n SetWideStrProp(AnObject, ppi, ws);\r\n end else begin\r\n {$ifdef DXGETTEXTDEBUG}\r\n DebugWriteln ('ERROR: Property disappeared: '+Propname+' for object of type '+AnObject.ClassName);\r\n {$endif}\r\n end;\r\n end;\r\n end;\r\n end { case item };\r\n tkClass:\r\n begin\r\n obj:=GetObjectProp(AnObject, PropName);\r\n if obj<>nil then begin\r\n if obj is TComponent then begin\r\n compmarker := TComponent(obj).FindComponent('GNUgettextMarker');\r\n if Assigned(compmarker) then\r\n exit;\r\n end;\r\n TodoList.AddObject ('',obj);\r\n end;\r\n end { case item };\r\n end { case };\r\n except\r\n on E:Exception do\r\n raise EGGComponentError.Create ('Property cannot be translated.'+sLineBreak+\r\n 'Add TP_GlobalIgnoreClassProperty('+AnObject.ClassName+','''+PropName+''') to your source code or use'+sLineBreak+\r\n 'TP_Ignore (self,''.'+PropName+''') to prevent this message.'+sLineBreak+\r\n 'Reason: '+e.Message);\r\n end;\r\nend;\r\n\r\nprocedure TGnuGettextInstance.TranslateProperties(AnObject: TObject; textdomain:DomainString='');\r\nvar\r\n TodoList:TStringList; // List of Name/TObject's that is to be processed\r\n DoneList:TStringList; // List of hex codes representing pointers to objects that have been done\r\n i, j, Count: integer;\r\n PropList: PPropList;\r\n UPropName: ComponentNameString;\r\n PropInfo: PPropInfo;\r\n compmarker,\r\n comp:TComponent;\r\n cm,\r\n currentcm:TClassMode; // currentcm is nil or contains special information about how to handle the current object\r\n ObjectPropertyIgnoreList:TStringList;\r\n objid:string;\r\n Name:ComponentNameString;\r\nbegin\r\n {$ifdef DXGETTEXTDEBUG}\r\n DebugWriteln ('----------------------------------------------------------------------');\r\n DebugWriteln ('TranslateProperties() was called for an object of class '+AnObject.ClassName+' with domain \"'+textdomain+'\".');\r\n {$endif}\r\n if TP_Retranslator<>nil then\r\n if textdomain = '' then\r\n (TP_Retranslator as TTP_Retranslator).TextDomain:=curmsgdomain\r\n else\r\n (TP_Retranslator as TTP_Retranslator).TextDomain:=textdomain;\r\n {$ifdef FPC}\r\n DoneList:=TCSStringList.Create;\r\n TodoList:=TCSStringList.Create;\r\n ObjectPropertyIgnoreList:=TCSStringList.Create;\r\n {$else}\r\n DoneList:=TStringList.Create;\r\n TodoList:=TStringList.Create;\r\n ObjectPropertyIgnoreList:=TStringList.Create;\r\n {$endif}\r\n try\r\n TodoList.AddObject('', AnObject);\r\n DoneList.Sorted:=True;\r\n ObjectPropertyIgnoreList.Sorted:=True;\r\n ObjectPropertyIgnoreList.Duplicates:=dupIgnore;\r\n ObjectPropertyIgnoreList.CaseSensitive:=False;\r\n DoneList.Duplicates:=dupError;\r\n DoneList.CaseSensitive:=True;\r\n\r\n while TodoList.Count<>0 do begin\r\n AnObject:=TodoList.Objects[0];\r\n Name:=TodoList.Strings[0];\r\n TodoList.Delete(0);\r\n if (AnObject<>nil) and (AnObject is TPersistent) then begin\r\n // Make sure each object is only translated once\r\n Assert (sizeof({$IFDEF CPUx64}NativeInt{$ELSE}Integer{$ENDIF CPUx64})=sizeof(TObject));\r\n objid:=IntToHex({$IFDEF CPUx64}NativeInt{$ELSE}Integer{$ENDIF CPUx64}(AnObject),8);\r\n if DoneList.Find(objid,i) then begin\r\n continue;\r\n end else begin\r\n DoneList.Add(objid);\r\n end;\r\n\r\n ObjectPropertyIgnoreList.Clear;\r\n\r\n // Find out if there is special handling of this object\r\n currentcm:=nil;\r\n // First check the local handling instructions\r\n for j:=0 to TP_ClassHandling.Count-1 do begin\r\n cm:=TObject(TP_ClassHandling.Items[j]) as TClassMode;\r\n if AnObject.InheritsFrom(cm.HClass) then begin\r\n if cm.PropertiesToIgnore.Count<>0 then begin\r\n ObjectPropertyIgnoreList.AddStrings(cm.PropertiesToIgnore);\r\n end else begin\r\n // Ignore the entire class\r\n currentcm:=cm;\r\n break;\r\n end;\r\n end;\r\n end;\r\n // Then check the global handling instructions\r\n if currentcm=nil then\r\n for j:=0 to TP_GlobalClassHandling.Count-1 do begin\r\n cm:=TObject(TP_GlobalClassHandling.Items[j]) as TClassMode;\r\n if AnObject.InheritsFrom(cm.HClass) then begin\r\n if cm.PropertiesToIgnore.Count<>0 then begin\r\n ObjectPropertyIgnoreList.AddStrings(cm.PropertiesToIgnore);\r\n end else begin\r\n // Ignore the entire class\r\n currentcm:=cm;\r\n break;\r\n end;\r\n end;\r\n end;\r\n if currentcm<>nil then begin\r\n ObjectPropertyIgnoreList.Clear;\r\n // Ignore or use special handler\r\n if Assigned(currentcm.SpecialHandler) then begin\r\n currentcm.SpecialHandler (AnObject);\r\n {$ifdef DXGETTEXTDEBUG}\r\n DebugWriteln ('Special handler activated for '+AnObject.ClassName);\r\n {$endif}\r\n end else begin\r\n {$ifdef DXGETTEXTDEBUG}\r\n DebugWriteln ('Ignoring object '+AnObject.ClassName);\r\n {$endif}\r\n end;\r\n continue;\r\n end;\r\n\r\n Count := GetPropList(AnObject, PropList);\r\n try\r\n for j := 0 to Count - 1 do begin\r\n PropInfo := PropList[j];\r\n {$IFDEF UNICODE}\r\n if not (PropInfo^.PropType^.Kind in [tkString, tkLString, tkWString, tkClass, tkUString]) then\r\n {$ELSE}\r\n if not (PropInfo^.PropType^.Kind in [tkString, tkLString, tkWString, tkClass]) then\r\n {$ENDIF}\r\n continue;\r\n UPropName:=uppercase(string(PropInfo^.Name));\r\n // Ignore properties that are meant to be ignored\r\n if ((currentcm=nil) or (not currentcm.PropertiesToIgnore.Find(UPropName,i))) and\r\n (not TP_IgnoreList.Find(Name+'.'+UPropName,i)) and\r\n (not ObjectPropertyIgnoreList.Find(UPropName,i)) then begin\r\n TranslateProperty (AnObject,PropInfo,TodoList,TextDomain);\r\n end; // if\r\n end; // for\r\n finally\r\n if Count<>0 then\r\n FreeMem (PropList);\r\n end;\r\n if AnObject is TStrings then begin\r\n if ((AnObject as TStrings).Text<>'') and (TP_Retranslator<>nil) then\r\n (TP_Retranslator as TTP_Retranslator).Remember(AnObject, 'Text', (AnObject as TStrings).Text);\r\n TranslateStrings (AnObject as TStrings,TextDomain);\r\n end;\r\n // Check for TCollection\r\n if AnObject is TCollection then begin\r\n for i := 0 to (AnObject as TCollection).Count - 1 do begin\r\n // Only add the object if it's not totally ignored already\r\n if not Assigned(currentcm) or not AnObject.InheritsFrom(currentcm.HClass) then\r\n TodoList.AddObject('',(AnObject as TCollection).Items[i]);\r\n end;\r\n end;\r\n if AnObject is TComponent then begin\r\n for i := 0 to TComponent(AnObject).ComponentCount - 1 do begin\r\n comp:=TComponent(AnObject).Components[i];\r\n if (not TP_IgnoreList.Find(uppercase(comp.Name),j)) then begin\r\n // Only add the object if it's not totally ignored or translated already\r\n if not Assigned(currentcm) or not AnObject.InheritsFrom(currentcm.HClass) then begin\r\n compmarker := comp.FindComponent('GNUgettextMarker');\r\n if not Assigned(compmarker) then\r\n TodoList.AddObject(uppercase(comp.Name),comp);\r\n end;\r\n end;\r\n end;\r\n end;\r\n end { if AnObject<>nil };\r\n end { while todolist.count<>0 };\r\n finally\r\n FreeAndNil (todolist);\r\n FreeAndNil (ObjectPropertyIgnoreList);\r\n FreeAndNil (DoneList);\r\n end;\r\n FreeTP_ClassHandlingItems;\r\n TP_IgnoreList.Clear;\r\n TP_Retranslator:=nil;\r\n {$ifdef DXGETTEXTDEBUG}\r\n DebugWriteln ('----------------------------------------------------------------------');\r\n {$endif}\r\nend;\r\n\r\nprocedure TGnuGettextInstance.UnregisterWhenNewLanguageListener(\r\n Listener: IGnuGettextInstanceWhenNewLanguageListener);\r\nbegin\r\n fWhenNewLanguageListeners.Remove(Listener);\r\nend;\r\n\r\nprocedure TGnuGettextInstance.UseLanguage(LanguageCode: LanguageString);\r\nvar\r\n i,p:integer;\r\n dom:TDomain;\r\n l2:string;\r\nbegin\r\n {$ifdef DXGETTEXTDEBUG}\r\n DebugWriteln('UseLanguage('''+LanguageCode+'''); called');\r\n {$endif}\r\n\r\n if LanguageCode='' then begin\r\n LanguageCode:=GGGetEnvironmentVariable('LANG');\r\n {$ifdef DXGETTEXTDEBUG}\r\n DebugWriteln ('LANG env variable is '''+LanguageCode+'''.');\r\n {$endif}\r\n {$ifdef MSWINDOWS}\r\n if LanguageCode='' then begin\r\n LanguageCode:=GetWindowsLanguage;\r\n {$ifdef DXGETTEXTDEBUG}\r\n DebugWriteln ('Found Windows language code to be '''+LanguageCode+'''.');\r\n {$endif}\r\n end;\r\n {$endif}\r\n p:=pos('.',LanguageCode);\r\n if p<>0 then\r\n LanguageCode:=LeftStr(LanguageCode,p-1);\r\n {$ifdef DXGETTEXTDEBUG}\r\n DebugWriteln ('Language code that will be set is '''+LanguageCode+'''.');\r\n {$endif}\r\n end;\r\n\r\n curlang := LanguageCode;\r\n for i:=0 to domainlist.Count-1 do begin\r\n dom:=domainlist.Objects[i] as TDomain;\r\n dom.SetLanguageCode (curlang);\r\n end;\r\n\r\n l2:=lowercase(LeftStr(curlang,2));\r\n if (l2='en') or (l2='de') then curGetPluralForm:=GetPluralForm2EN else\r\n if (l2='hu') or (l2='ko') or (l2='zh') or (l2='ja') or (l2='tr') then curGetPluralForm:=GetPluralForm1 else\r\n if (l2='fr') or (l2='fa') or (lowercase(curlang)='pt_br') then curGetPluralForm:=GetPluralForm2FR else\r\n if (l2='lv') then curGetPluralForm:=GetPluralForm3LV else\r\n if (l2='ga') then curGetPluralForm:=GetPluralForm3GA else\r\n if (l2='lt') then curGetPluralForm:=GetPluralForm3LT else\r\n if (l2='ru') or (l2='uk') or (l2='hr') then curGetPluralForm:=GetPluralForm3RU else\r\n if (l2='cs') or (l2='sk') then curGetPluralForm:=GetPluralForm3SK else\r\n if (l2='pl') then curGetPluralForm:=GetPluralForm3PL else\r\n if (l2='sl') then curGetPluralForm:=GetPluralForm4SL else begin\r\n curGetPluralForm:=GetPluralForm2EN;\r\n {$ifdef DXGETTEXTDEBUG}\r\n DebugWriteln ('Plural form for the language was not found. English plurality system assumed.');\r\n {$endif}\r\n end;\r\n\r\n WhenNewLanguage (curlang);\r\n\r\n {$ifdef DXGETTEXTDEBUG}\r\n DebugWriteln('');\r\n {$endif}\r\nend;\r\n\r\nprocedure TGnuGettextInstance.TranslateStrings(sl: TStrings;const TextDomain:DomainString);\r\nvar\r\n line: string;\r\n i: integer;\r\n s:TStringList;\r\n {$ifdef DELPHI2009OROLDER}\r\n slAsTStringList:TStringList;\r\n originalOwnsObjects: Boolean;\r\n {$endif}\r\nbegin\r\n if sl.Count > 0 then begin\r\n // From D2009 onward, the TStringList class has a OwnsObjects property, just like\r\n // TObjectList has. This means that when we will be calling Clear on the given\r\n // list in the sl parameter, we could destroy the objects it contains.\r\n // To avoid this we must disable OwnsObjects while we replace the strings, but\r\n // only if sl is a TStringList instance and if using Delphi 2009 or upper.\r\n {$ifdef DELPHI2009OROLDER}\r\n originalOwnsObjects := False; // avoid warning\r\n if sl is TStringList then\r\n slAsTStringList := TStringList(sl)\r\n else\r\n slAsTStringList := nil;\r\n {$endif}\r\n\r\n sl.BeginUpdate;\r\n try\r\n s:=TStringList.Create;\r\n try\r\n // don't use Assign here as it will propagate the Sorted property (among others)\r\n // in versions of Delphi from Delphi XE ownard\r\n s.AddStrings(sl);\r\n\r\n for i:=0 to s.Count-1 do begin\r\n line:=s.Strings[i];\r\n if line<>'' then\r\n if TextDomain = '' then\r\n s.Strings[i]:=ComponentGettext(line)\r\n else\r\n s.Strings[i]:=dgettext(TextDomain,line);\r\n end;\r\n\r\n {$ifdef DELPHI2009OROLDER}\r\n if Assigned(slAsTStringList) then begin\r\n originalOwnsObjects := slAsTStringList.OwnsObjects;\r\n slAsTStringList.OwnsObjects := False;\r\n end;\r\n {$endif}\r\n try\r\n // same here, we don't want to modify the properties of the orignal string list\r\n sl.Clear;\r\n sl.AddStrings(s);\r\n finally\r\n {$ifdef DELPHI2009OROLDER}\r\n if Assigned(slAsTStringList) then\r\n slAsTStringList.OwnsObjects := originalOwnsObjects;\r\n {$endif}\r\n end;\r\n finally\r\n FreeAndNil (s);\r\n end;\r\n finally\r\n sl.EndUpdate;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TGnuGettextInstance.GetTranslatorNameAndEmail: TranslatedUnicodeString;\r\nbegin\r\n Result:=GetTranslationProperty('LAST-TRANSLATOR');\r\nend;\r\n\r\nfunction TGnuGettextInstance.GetTranslationProperty(\r\n const Propertyname: ComponentNameString): TranslatedUnicodeString;\r\nbegin\r\n Result:=getdomain(curmsgdomain,DefaultDomainDirectory,CurLang).GetTranslationProperty (Propertyname);\r\nend;\r\n\r\nfunction TGnuGettextInstance.dngettext(const szDomain: DomainString; const singular, plural: MsgIdString;\r\n Number: Integer): TranslatedUnicodeString;\r\nvar\r\n org:MsgIdString;\r\n trans:TranslatedUnicodeString;\r\n idx:integer;\r\n p:integer;\r\nbegin\r\n {$ifdef DXGETTEXTDEBUG}\r\n DebugWriteln ('dngettext translation (domain '+szDomain+', number is '+IntTostr(Number)+') of '+singular+'/'+plural);\r\n {$endif}\r\n org:=singular+#0+plural;\r\n trans:=dgettext(szDomain,org);\r\n if org=trans then begin\r\n {$ifdef DXGETTEXTDEBUG}\r\n DebugWriteln ('Translation was equal to english version. English plural forms assumed.');\r\n {$endif}\r\n idx:=GetPluralForm2EN(Number)\r\n end else\r\n idx:=curGetPluralForm(Number);\r\n {$ifdef DXGETTEXTDEBUG}\r\n DebugWriteln ('Index '+IntToStr(idx)+' will be used');\r\n {$endif}\r\n while true do begin\r\n p:=pos(#0,trans);\r\n if p=0 then begin\r\n {$ifdef DXGETTEXTDEBUG}\r\n DebugWriteln ('Last translation used: '+utf8encode(trans));\r\n {$endif}\r\n Result:=trans;\r\n exit;\r\n end;\r\n if idx=0 then begin\r\n {$ifdef DXGETTEXTDEBUG}\r\n DebugWriteln ('Translation found: '+utf8encode(trans));\r\n {$endif}\r\n Result:=LeftStr(trans,p-1);\r\n exit;\r\n end;\r\n delete (trans,1,p);\r\n dec (idx);\r\n end;\r\nend;\r\n\r\nfunction TGnuGettextInstance.dngettext_NoExtract(const szDomain: DomainString;\r\n const singular, plural: MsgIdString;\r\n Number: Integer): TranslatedUnicodeString;\r\nbegin\r\n // This one is very useful for translating text in variables.\r\n // This can sometimes be necessary, and by using this function,\r\n // the source code scanner will not trigger warnings.\r\n Result:=dngettext(szDomain,singular,plural,Number);\r\nend;\r\n\r\n{$ifndef UNICODE}\r\nfunction TGnuGettextInstance.ngettext(const singular, plural: ansistring;\r\n Number: Integer): TranslatedUnicodeString;\r\nbegin\r\n Result := dngettext(curmsgdomain, singular, plural, Number);\r\nend;\r\n{$endif}\r\n\r\nfunction TGnuGettextInstance.ngettext(const singular, plural: MsgIdString;\r\n Number: Integer): TranslatedUnicodeString;\r\nbegin\r\n Result := dngettext(curmsgdomain, singular, plural, Number);\r\nend;\r\n\r\nfunction TGnuGettextInstance.ngettext_NoExtract(const singular,\r\n plural: MsgIdString; Number: Integer): TranslatedUnicodeString;\r\nbegin\r\n // This one is very useful for translating text in variables.\r\n // This can sometimes be necessary, and by using this function,\r\n // the source code scanner will not trigger warnings.\r\n Result:=ngettext(singular,plural,Number);\r\nend;\r\n\r\nprocedure TGnuGettextInstance.WhenNewDomain(const TextDomain: DomainString);\r\nbegin\r\n // This is meant to be empty.\r\nend;\r\n\r\nprocedure TGnuGettextInstance.WhenNewLanguage(const LanguageID: LanguageString);\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := 0 to fWhenNewLanguageListeners.Count - 1 do\r\n IGnuGettextInstanceWhenNewLanguageListener(fWhenNewLanguageListeners[I]).WhenNewLanguage(LanguageID);\r\nend;\r\n\r\nprocedure TGnuGettextInstance.WhenNewDomainDirectory(const TextDomain:DomainString; const Directory: FilenameString);\r\nbegin\r\n // This is meant to be empty.\r\nend;\r\n\r\nprocedure TGnuGettextInstance.GetListOfLanguages(const domain: DomainString;\r\n list: TStrings);\r\nbegin\r\n getdomain(Domain,DefaultDomainDirectory,CurLang).GetListOfLanguages(list);\r\nend;\r\n\r\nprocedure TGnuGettextInstance.bindtextdomainToFile(const szDomain:DomainString; const filename: FilenameString);\r\nbegin\r\n {$ifdef DXGETTEXTDEBUG}\r\n DebugWriteln ('Text domain \"'+szDomain+'\" is now bound to file named \"'+filename+'\"');\r\n {$endif}\r\n getdomain(szDomain,DefaultDomainDirectory,CurLang).SetFilename (filename);\r\nend;\r\n\r\nprocedure TGnuGettextInstance.DebugLogPause(PauseEnabled: boolean);\r\nbegin\r\n {$ifdef DXGETTEXTDEBUG}\r\n DebugLogOutputPaused:=PauseEnabled;\r\n {$endif}\r\nend;\r\n\r\nprocedure TGnuGettextInstance.DebugLogToFile(const filename: FilenameString; append:boolean=false);\r\n{$ifdef DXGETTEXTDEBUG}\r\nvar\r\n fs:TFileStream;\r\n marker:ansistring;\r\n{$endif}\r\nbegin\r\n {$ifdef DXGETTEXTDEBUG}\r\n // Create the file if needed\r\n if (not fileexists(filename)) or (not append) then\r\n fileclose (filecreate (filename));\r\n\r\n // Open file\r\n fs:=TFileStream.Create (filename,fmOpenWrite or fmShareDenyWrite);\r\n if append then\r\n fs.Seek(0,soFromEnd);\r\n\r\n // Write header if appending\r\n if fs.Position<>0 then begin\r\n marker:=sLineBreak+'==========================================================================='+sLineBreak;\r\n fs.WriteBuffer(marker[1],length(marker));\r\n end;\r\n\r\n // Copy the memorystream contents to the file\r\n if DebugLog <> nil then\r\n begin\r\n DebugLog.Seek(0,soFromBeginning);\r\n fs.CopyFrom(DebugLog,0);\r\n end;\r\n\r\n // Make DebugLog point to the filestream\r\n FreeAndNil (DebugLog);\r\n DebugLog:=fs;\r\n {$endif}\r\nend;\r\n\r\n{$ifdef DXGETTEXTDEBUG}\r\nprocedure TGnuGettextInstance.DebugWriteln(line: ansistring);\r\nVar\r\n Discard: Boolean;\r\nbegin\r\n Assert (DebugLogCS<>nil);\r\n Assert (DebugLog<>nil);\r\n\r\n DebugLogCS.BeginWrite;\r\n try\r\n if DebugLogOutputPaused then\r\n exit;\r\n\r\n if Assigned (fOnDebugLine) then begin\r\n Discard := True;\r\n fOnDebugLine (Self, Line, Discard);\r\n If Discard then Exit;\r\n end;\r\n\r\n line:=line+sLineBreak;\r\n\r\n // Ensure that memory usage doesn't get too big.\r\n if (DebugLog is TMemoryStream) and (DebugLog.Position>1000000) then begin\r\n line:=sLineBreak+sLineBreak+sLineBreak+sLineBreak+sLineBreak+\r\n 'Debug log halted because memory usage grew too much.'+sLineBreak+\r\n 'Specify a filename to store the debug log in or disable debug loggin in gnugettext.pas.'+\r\n sLineBreak+sLineBreak+sLineBreak+sLineBreak+sLineBreak;\r\n DebugLogOutputPaused:=True;\r\n end;\r\n DebugLog.WriteBuffer(line[1],length(line));\r\n finally\r\n DebugLogCS.EndWrite;\r\n end;\r\nend;\r\n{$endif}\r\n\r\nfunction TGnuGettextInstance.Getdomain(const domain:DomainString; const DefaultDomainDirectory:FilenameString; const CurLang: LanguageString): TDomain;\r\n// Retrieves the TDomain object for the specified domain.\r\n// Creates one, if none there, yet.\r\nvar\r\n idx: integer;\r\nbegin\r\n idx := domainlist.IndexOf(Domain);\r\n if idx = -1 then begin\r\n Result := TDomain.Create;\r\n {$ifdef DXGETTEXTDEBUG}\r\n Result.DebugLogger:=DebugWriteln;\r\n {$endif}\r\n Result.Domain := Domain;\r\n Result.Directory := DefaultDomainDirectory;\r\n Result.SetLanguageCode(curlang);\r\n domainlist.AddObject(Domain, Result);\r\n end else begin\r\n Result := domainlist.Objects[idx] as TDomain;\r\n end;\r\nend;\r\n\r\nfunction TGnuGettextInstance.LoadResString(\r\n ResStringRec: PResStringRec): UnicodeString;\r\n{$ifdef MSWINDOWS}\r\nvar\r\n Len: Integer;\r\n {$IFDEF UNICODE}\r\n Buffer: array [0..1023] of widechar;\r\n {$else}\r\n Buffer: array [0..1023] of ansichar;\r\n {$endif}\r\n{$endif}\r\n{$ifdef LINUX }\r\nconst\r\n ResStringTableLen = 16;\r\ntype\r\n ResStringTable = array [0..ResStringTableLen-1] of LongWord;\r\nvar\r\n Handle: TResourceHandle;\r\n Tab: ^ResStringTable;\r\n ResMod: HMODULE;\r\n{$endif }\r\nbegin\r\n if ResStringRec=nil then\r\n exit;\r\n if ResStringRec.Identifier>=64*1024 then begin\r\n {$ifdef DXGETTEXTDEBUG}\r\n DebugWriteln ('LoadResString was given an invalid ResStringRec.Identifier');\r\n {$endif}\r\n Result:='ERROR';\r\n exit;\r\n end else begin\r\n {$ifdef LINUX}\r\n // This works with Unicode if the Linux has utf-8 character set\r\n // Result:=System.LoadResString(ResStringRec);\r\n ResMod:=FindResourceHInstance(ResStringRec^.Module^);\r\n Handle:=FindResource(ResMod,\r\n PAnsiChar(ResStringRec^.Identifier div ResStringTableLen), PAnsiChar(6)); // RT_STRING\r\n Tab:=Pointer(LoadResource(ResMod, Handle));\r\n if Tab=nil then\r\n Result:=''\r\n else\r\n Result:=PWideChar(PAnsiChar(Tab)+Tab[ResStringRec^.Identifier mod ResStringTableLen]);\r\n {$endif}\r\n {$ifdef MSWINDOWS}\r\n if not Win32PlatformIsUnicode then begin\r\n SetString(Result, Buffer,\r\n LoadString(FindResourceHInstance(ResStringRec.Module^),\r\n ResStringRec.Identifier, Buffer, SizeOf(Buffer)))\r\n end else begin\r\n Result := '';\r\n Len := 0;\r\n While Length(Result)<=Len+1 do begin \r\n if Length(Result) = 0 then\r\n SetLength(Result, 1024)\r\n else\r\n SetLength(Result, Length(Result) * 2);\r\n Len := LoadStringW(FindResourceHInstance(ResStringRec.Module^),\r\n ResStringRec.Identifier, PWideChar(Result), Length(Result));\r\n end;\r\n SetLength(Result, Len);\r\n end;\r\n {$endif}\r\n end;\r\n {$ifdef DXGETTEXTDEBUG}\r\n DebugWriteln ('Loaded resourcestring: '+utf8encode(Result));\r\n {$endif}\r\n Result:=ResourceStringGettext(Result);\r\nend;\r\n\r\nprocedure TGnuGettextInstance.RegisterWhenNewLanguageListener(\r\n Listener: IGnuGettextInstanceWhenNewLanguageListener);\r\nbegin\r\n fWhenNewLanguageListeners.Add(Listener);\r\nend;\r\n\r\nprocedure TGnuGettextInstance.RetranslateComponent(AnObject: TComponent;\r\n const TextDomain: DomainString);\r\nvar\r\n comp:TGnuGettextComponentMarker;\r\nbegin\r\n {$ifdef DXGETTEXTDEBUG}\r\n DebugWriteln ('======================================================================');\r\n DebugWriteln ('RetranslateComponent() was called for a component with name '+AnObject.Name+'.');\r\n {$endif}\r\n comp:=AnObject.FindComponent('GNUgettextMarker') as TGnuGettextComponentMarker;\r\n if comp=nil then\r\n begin\r\n {$ifdef DXGETTEXTDEBUG}\r\n DebugWriteln ('Retranslate was called on an object that has not been translated before. An Exception is being raised.');\r\n {$endif}\r\n raise EGGProgrammingError.Create ('Retranslate was called on an object that has not been translated before. Please use TranslateComponent() before RetranslateComponent().');\r\n end\r\n else\r\n begin\r\n //*** if param ReReadMoFileOnSameLanguage is set, use the ReTranslate\r\n // function nevertheless if the current language is the same like the\r\n // new (-> reread the current .mo-file from the file system).\r\n if ReReadMoFileOnSameLanguage or\r\n (comp.LastLanguage <> curlang) then\r\n begin\r\n {$ifdef DXGETTEXTDEBUG}\r\n DebugWriteln ('The retranslator is being executed.');\r\n {$endif}\r\n comp.Retranslator.Execute;\r\n end\r\n else\r\n begin\r\n {$ifdef DXGETTEXTDEBUG}\r\n DebugWriteln ('The language has not changed. The retranslator is not executed.');\r\n {$endif}\r\n end;\r\n end;\r\n comp.LastLanguage:=curlang;\r\n\r\n {$ifdef DXGETTEXTDEBUG}\r\n DebugWriteln ('======================================================================');\r\n {$endif}\r\nend;\r\n\r\nprocedure TGnuGettextInstance.TP_IgnoreClass(IgnClass: TClass);\r\nvar\r\n cm:TClassMode;\r\n i:integer;\r\nbegin\r\n for i:=0 to TP_ClassHandling.Count-1 do begin\r\n cm:=TObject(TP_ClassHandling.Items[i]) as TClassMode;\r\n if cm.HClass=IgnClass then\r\n raise EGGProgrammingError.Create ('You cannot add a class to the ignore list that is already on that list: '+IgnClass.ClassName+'.');\r\n if IgnClass.InheritsFrom(cm.HClass) then begin\r\n // This is the place to insert this class\r\n cm:=TClassMode.Create;\r\n cm.HClass:=IgnClass;\r\n TP_ClassHandling.Insert(i,cm);\r\n {$ifdef DXGETTEXTDEBUG}\r\n DebugWriteln ('Locally, class '+IgnClass.ClassName+' is being ignored.');\r\n {$endif}\r\n exit;\r\n end;\r\n end;\r\n cm:=TClassMode.Create;\r\n cm.HClass:=IgnClass;\r\n TP_ClassHandling.Add(cm);\r\n {$ifdef DXGETTEXTDEBUG}\r\n DebugWriteln ('Locally, class '+IgnClass.ClassName+' is being ignored.');\r\n {$endif}\r\nend;\r\n\r\nprocedure TGnuGettextInstance.TP_IgnoreClassProperty(IgnClass: TClass;\r\n propertyname: ComponentNameString);\r\nvar\r\n cm:TClassMode;\r\n i:integer;\r\nbegin\r\n propertyname:=uppercase(propertyname);\r\n for i:=0 to TP_ClassHandling.Count-1 do begin\r\n cm:=TObject(TP_ClassHandling.Items[i]) as TClassMode;\r\n if cm.HClass=IgnClass then begin\r\n if Assigned(cm.SpecialHandler) then\r\n raise EGGProgrammingError.Create ('You cannot ignore a class property for a class that has a handler set.');\r\n cm.PropertiesToIgnore.Add(propertyname);\r\n {$ifdef DXGETTEXTDEBUG}\r\n DebugWriteln ('Globally, the '+propertyname+' property of class '+IgnClass.ClassName+' is being ignored.');\r\n {$endif}\r\n exit;\r\n end;\r\n if IgnClass.InheritsFrom(cm.HClass) then begin\r\n // This is the place to insert this class\r\n cm:=TClassMode.Create;\r\n cm.HClass:=IgnClass;\r\n cm.PropertiesToIgnore.Add(propertyname);\r\n TP_ClassHandling.Insert(i,cm);\r\n {$ifdef DXGETTEXTDEBUG}\r\n DebugWriteln ('Locally, the '+propertyname+' property of class '+IgnClass.ClassName+' is being ignored.');\r\n {$endif}\r\n exit;\r\n end;\r\n end;\r\n cm:=TClassMode.Create;\r\n cm.HClass:=IgnClass;\r\n cm.PropertiesToIgnore.Add(propertyname);\r\n TP_GlobalClassHandling.Add(cm);\r\n {$ifdef DXGETTEXTDEBUG}\r\n DebugWriteln ('Locally, the '+propertyname+' property of class '+IgnClass.ClassName+' is being ignored.');\r\n {$endif}\r\nend;\r\n\r\nprocedure TGnuGettextInstance.FreeTP_ClassHandlingItems;\r\nbegin\r\n while TP_ClassHandling.Count<>0 do begin\r\n TObject(TP_ClassHandling.Items[0]).Free;\r\n TP_ClassHandling.Delete(0);\r\n end;\r\nend;\r\n\r\n{$ifndef UNICODE}\r\nfunction TGnuGettextInstance.ansi2wideDTCP(const s: ansistring): MsgIdString;\r\n{$ifdef MSWindows}\r\nvar\r\n len:integer;\r\n{$endif}\r\nbegin\r\n{$ifdef MSWindows}\r\n if DesignTimeCodePage=CP_ACP then begin\r\n // No design-time codepage specified. Using runtime codepage instead.\r\n{$endif}\r\n Result:=s;\r\n{$ifdef MSWindows}\r\n end else begin\r\n len:=length(s);\r\n if len=0 then\r\n Result:=''\r\n else begin\r\n SetLength (Result,len);\r\n len:=MultiByteToWideChar(DesignTimeCodePage,0,pansichar(s),len,pwidechar(Result),len);\r\n if len=0 then\r\n raise EGGAnsi2WideConvError.Create ('Cannot convert string to widestring:'+sLineBreak+s);\r\n SetLength (Result,len);\r\n end;\r\n end;\r\n{$endif}\r\nend;\r\n{$endif}\r\n\r\n{$ifndef UNICODE}\r\nfunction TGnuGettextInstance.dngettext(const szDomain: DomainString; const singular,\r\n plural: ansistring; Number: Integer): TranslatedUnicodeString;\r\nbegin\r\n Result:=dngettext (szDomain, ansi2wideDTCP(singular), ansi2wideDTCP(plural), Number);\r\nend;\r\n{$endif}\r\n\r\n{ TClassMode }\r\n\r\nconstructor TClassMode.Create;\r\nbegin\r\n PropertiesToIgnore:=TStringList.Create;\r\n PropertiesToIgnore.Sorted:=True;\r\n PropertiesToIgnore.Duplicates:=dupError;\r\n PropertiesToIgnore.CaseSensitive:=False;\r\nend;\r\n\r\ndestructor TClassMode.Destroy;\r\nbegin\r\n FreeAndNil (PropertiesToIgnore);\r\n inherited;\r\nend;\r\n\r\n{ TFileLocator }\r\n\r\nfunction TFileLocator.FindSignaturePos(const signature: RawByteString;\r\n str: TFileStream): Int64;\r\n// Finds the position of signature in the file.\r\nconst\r\n bufsize=100000;\r\nvar\r\n a:RawByteString;\r\n b:RawByteString;\r\n offset:integer;\r\n rd,p:Integer;\r\nbegin\r\n if signature='' then\r\n begin\r\n Result := 0;\r\n Exit;\r\n end;\r\n\r\n offset:=0;\r\n str.Seek(0, soFromBeginning);\r\n\r\n SetLength (a, bufsize);\r\n SetLength (b, bufsize);\r\n str.Read(a[1],bufsize);\r\n \r\n while true do begin\r\n rd:=str.Read(b[1],bufsize);\r\n p:=pos(signature,a+b);\r\n if (p<>0) then begin // do not check p < bufsize+100 here!\r\n Result:=offset+p-1;\r\n exit;\r\n end;\r\n if rd<>bufsize then begin\r\n // Prematurely ended without finding anything\r\n Result:=0;\r\n exit;\r\n end;\r\n a:=b;\r\n offset:=offset+bufsize;\r\n end;\r\n Result:=0;\r\nend;\r\n\r\nprocedure TFileLocator.Analyze;\r\nvar\r\n HeaderSize,\r\n PrefixSize: Integer;\r\n dummysig,\r\n headerpre,\r\n headerbeg,\r\n headerend:RawByteString;\r\n i:integer;\r\n headerbeginpos,\r\n headerendpos:integer;\r\n offset,\r\n tableoffset:int64;\r\n fs:TFileStream;\r\n fi:TEmbeddedFileInfo;\r\n filename:FilenameString;\r\n filename8bit:RawByteString;\r\nconst\r\n // DetectionSignature: used solely to detect gnugettext usage by assemble\r\n DetectionSignature: array[0..35] of AnsiChar='2E23E563-31FA-4C24-B7B3-90BE720C6B1A';\r\n // Embedded Header Begin Signature (without dynamic prefix written by assemble)\r\n BeginHeaderSignature: array[0..35] of AnsiChar='BD7F1BE4-9FCF-4E3A-ABA7-3443D11AB362';\r\n // Embedded Header End Signature (without dynamic prefix written by assemble)\r\n EndHeaderSignature: array[0..35] of AnsiChar='1C58841C-D8A0-4457-BF54-D8315D4CF49D';\r\n // Assemble Prefix (do not put before the Header Signatures!)\r\n SignaturePrefix: array[0..2] of AnsiChar='DXG'; // written from assemble\r\nbegin\r\n // Attn: Ensure all Signatures have the same size!\r\n HeaderSize := High(BeginHeaderSignature) - Low(BeginHeaderSignature) + 1;\r\n PrefixSize := High(SignaturePrefix) - Low(SignaturePrefix) + 1;\r\n\r\n // dummy usage of DetectionSignature (otherwise not compiled into exe)\r\n SetLength(dummysig, HeaderSize);\r\n for i := 0 to HeaderSize-1 do\r\n dummysig[i+1] := DetectionSignature[i];\r\n\r\n // copy byte by byte (D2009+ compatible)\r\n SetLength(headerpre, PrefixSize);\r\n for i:= 0 to PrefixSize-1 do\r\n headerpre[i+1] := SignaturePrefix[i];\r\n\r\n SetLength(headerbeg, HeaderSize);\r\n for i:= 0 to HeaderSize-1 do\r\n headerbeg[i+1] := BeginHeaderSignature[i];\r\n\r\n SetLength(headerend, HeaderSize);\r\n for i:= 0 to HeaderSize-1 do\r\n headerend[i+1] := EndHeaderSignature[i];\r\n\r\n BaseDirectory:=ExtractFilePath(ExecutableFilename);\r\n try\r\n fs:=TFileStream.Create(ExecutableFilename,fmOpenRead or fmShareDenyNone);\r\n try\r\n // try to find new header begin and end signatures\r\n headerbeginpos := FindSignaturePos(headerpre+headerbeg, fs);\r\n headerendpos := FindSignaturePos(headerpre+headerend, fs);\r\n\r\n if (headerbeginpos > 0) and (headerendpos > 0) then\r\n begin\r\n // adjust positions (to the end of each signature)\r\n headerbeginpos := headerbeginpos + HeaderSize + PrefixSize;\r\n\r\n // get file table offset (8 byte, stored directly before the end header)\r\n fs.Seek(headerendpos - 8, soFromBeginning);\r\n // get relative offset and convert to absolute offset during runtime\r\n tableoffset := headerbeginpos + ReadInt64(fs);\r\n\r\n // go to beginning of embedded block\r\n fs.Seek(headerbeginpos, soFromBeginning);\r\n \r\n offset := tableoffset;\r\n Assert(sizeof(offset)=8);\r\n while (true) and (fs.Position0 do begin\r\n filelist.Objects[0].Free;\r\n filelist.Delete (0);\r\n end;\r\n FreeAndNil (filelist);\r\n FreeAndNil (MoFiles);\r\n FreeAndNil (MoFilesCS);\r\n inherited;\r\nend;\r\n\r\nfunction TFileLocator.FileExists(filename: FilenameString): boolean;\r\nvar\r\n idx:integer;\r\nbegin\r\n if LeftStr(filename,length(basedirectory))=basedirectory then begin\r\n // Cut off basedirectory if the file is located beneath that base directory\r\n filename:=MidStr(filename,length(basedirectory)+1,maxint);\r\n end;\r\n Result:=filelist.Find(filename,idx);\r\nend;\r\n\r\nfunction TFileLocator.GetMoFile(filename: FilenameString; DebugLogger:TDebugLogger): TMoFile;\r\nvar\r\n fi:TEmbeddedFileInfo;\r\n idx:integer;\r\n idxname:FilenameString;\r\n Offset, Size: Int64;\r\n realfilename:FilenameString;\r\nbegin\r\n // Find real filename\r\n offset:=0;\r\n size:=0;\r\n realfilename:=filename;\r\n if LeftStr(filename,length(basedirectory))=basedirectory then begin\r\n filename:=MidStr(filename,length(basedirectory)+1,maxint);\r\n idx:=filelist.IndexOf(filename);\r\n if idx<>-1 then begin\r\n fi:=filelist.Objects[idx] as TEmbeddedFileInfo;\r\n realfilename:=ExecutableFilename;\r\n offset:=fi.offset;\r\n size:=fi.size;\r\n {$ifdef DXGETTEXTDEBUG}\r\n DebugLogger ('Instead of '+filename+', using '+realfilename+' from offset '+IntTostr(offset)+', size '+IntToStr(size));\r\n {$endif}\r\n end;\r\n end;\r\n\r\n\r\n {$ifdef DXGETTEXTDEBUG}\r\n DebugLogger ('Reading .mo data from file '''+filename+'''');\r\n {$endif}\r\n\r\n // Find TMoFile object\r\n MoFilesCS.BeginWrite;\r\n try\r\n idxname:=realfilename+' //\\\\ '+IntToStr(offset);\r\n if MoFiles.Find(idxname, idx) then begin\r\n Result:=MoFiles.Objects[idx] as TMoFile;\r\n end else begin\r\n Result:=TMoFile.Create (realfilename, Offset, Size, UseMemoryMappedFiles);\r\n MoFiles.AddObject(idxname, Result);\r\n end;\r\n Inc (Result.Users);\r\n finally\r\n MoFilesCS.EndWrite;\r\n end;\r\nend;\r\n\r\nfunction TFileLocator.ReadInt64(str: TStream): int64;\r\nbegin\r\n Assert (sizeof(Result)=8);\r\n str.ReadBuffer(Result,8);\r\nend;\r\n\r\nprocedure TFileLocator.ReleaseMoFile(mofile: TMoFile);\r\nvar\r\n i:integer;\r\nbegin\r\n Assert (mofile<>nil);\r\n \r\n MoFilesCS.BeginWrite;\r\n try\r\n dec (mofile.Users);\r\n if mofile.Users<=0 then begin\r\n i:=MoFiles.Count-1;\r\n while i>=0 do begin\r\n if MoFiles.Objects[i]=mofile then begin\r\n MoFiles.Delete(i);\r\n FreeAndNil (mofile);\r\n break;\r\n end;\r\n dec (i);\r\n end;\r\n end;\r\n finally\r\n MoFilesCS.EndWrite;\r\n end;\r\nend;\r\n\r\n{ TTP_Retranslator }\r\n\r\nconstructor TTP_Retranslator.Create;\r\nbegin\r\n list:=TList.Create;\r\nend;\r\n\r\ndestructor TTP_Retranslator.Destroy;\r\nvar\r\n i:integer;\r\nbegin\r\n for i:=0 to list.Count-1 do\r\n TObject(list.Items[i]).Free;\r\n FreeAndNil (list);\r\n inherited;\r\nend;\r\n\r\nprocedure TTP_Retranslator.Execute;\r\nvar\r\n i:integer;\r\n sl:TStrings;\r\n item:TTP_RetranslatorItem;\r\n newvalue:TranslatedUnicodeString;\r\n comp:TGnuGettextComponentMarker;\r\n ppi:PPropInfo;\r\nbegin\r\n for i:=0 to list.Count-1 do begin\r\n item:=TObject(list.items[i]) as TTP_RetranslatorItem;\r\n if item.obj is TComponent then begin\r\n comp:=TComponent(item.obj).FindComponent('GNUgettextMarker') as TGnuGettextComponentMarker;\r\n if Assigned(comp) and (self<>comp.Retranslator) then begin\r\n comp.Retranslator.Execute; \r\n Continue;\r\n end;\r\n end;\r\n if item.obj is TStrings then begin\r\n // Since we don't know the order of items in sl, and don't have\r\n // the original .Objects[] anywhere, we cannot anticipate anything\r\n // about the current sl.Strings[] and sl.Objects[] values. We therefore\r\n // have to discard both values. We can, however, set the original .Strings[]\r\n // value into the list and retranslate that.\r\n sl:=TStringList.Create;\r\n try\r\n sl.Text:=item.OldValue;\r\n Instance.TranslateStrings(sl,textdomain);\r\n (item.obj as TStrings).BeginUpdate;\r\n try\r\n (item.obj as TStrings).Text:=sl.Text;\r\n finally\r\n (item.obj as TStrings).EndUpdate;\r\n end;\r\n finally\r\n FreeAndNil (sl);\r\n end;\r\n end else begin\r\n if (textdomain = '') or (textdomain = DefaultTextDomain) then\r\n newValue := ComponentGettext(item.OldValue, instance)\r\n else\r\n newValue := instance.dgettext(textdomain,item.OldValue);\r\n ppi:=GetPropInfo(item.obj, item.Propname);\r\n if ppi<>nil then begin\r\n SetWideStrProp(item.obj, ppi, newValue);\r\n end else begin\r\n {$ifdef DXGETTEXTDEBUG}\r\n Instance.DebugWriteln ('ERROR: On retranslation, property disappeared: '+item.Propname+' for object of type '+item.obj.ClassName);\r\n {$endif}\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TTP_Retranslator.Remember(obj: TObject; PropName: ComponentNameString;\r\n OldValue: TranslatedUnicodeString);\r\nvar\r\n item:TTP_RetranslatorItem;\r\nbegin\r\n item:=TTP_RetranslatorItem.Create;\r\n item.obj:=obj;\r\n item.Propname:=Propname;\r\n item.OldValue:=OldValue;\r\n list.Add(item);\r\nend;\r\n\r\n{ TGnuGettextComponentMarker }\r\n\r\ndestructor TGnuGettextComponentMarker.Destroy;\r\nbegin\r\n FreeAndNil (Retranslator);\r\n inherited;\r\nend;\r\n\r\n{ THook }\r\n\r\nconstructor THook.Create(OldProcedure, NewProcedure: pointer; FollowJump:boolean=false);\r\n{ Idea and original code from Igor Siticov }\r\n{ Modified by Jacques Garcia Vazquez and Lars Dybdahl }\r\nbegin\r\n {$ifndef CPU386}\r\n {$ifndef CPUx64}\r\n raise Exception.Create ('This procedure only works on Intel i386 or x64 compatible processors.');\r\n {$endif}\r\n {$endif}\r\n\r\n oldproc:=OldProcedure;\r\n newproc:=NewProcedure;\r\n\r\n Reset (FollowJump);\r\nend;\r\n\r\ndestructor THook.Destroy;\r\nbegin\r\n Shutdown;\r\n inherited;\r\nend;\r\n\r\nprocedure THook.Disable;\r\nbegin\r\n Assert (PatchPosition<>nil,'Patch position in THook was nil when Disable was called');\r\n PatchPosition[0]:=Original[0];\r\n PatchPosition[1]:=Original[1];\r\n PatchPosition[2]:=Original[2];\r\n PatchPosition[3]:=Original[3];\r\n PatchPosition[4]:=Original[4];\r\nend;\r\n\r\nprocedure THook.Enable;\r\nbegin\r\n Assert (PatchPosition<>nil,'Patch position in THook was nil when Enable was called');\r\n PatchPosition[0]:=Patch[0];\r\n PatchPosition[1]:=Patch[1];\r\n PatchPosition[2]:=Patch[2];\r\n PatchPosition[3]:=Patch[3];\r\n PatchPosition[4]:=Patch[4];\r\nend;\r\n\r\nprocedure THook.Reset(FollowJump: boolean);\r\nvar\r\n offset:integer;\r\n {$ifdef LINUX}\r\n p:pointer;\r\n pagesize:integer;\r\n {$endif}\r\n {$ifdef MSWindows}\r\n ov: cardinal;\r\n {$endif}\r\nbegin\r\n if PatchPosition<>nil then\r\n Shutdown;\r\n\r\n patchPosition := OldProc;\r\n if FollowJump and (Word(OldProc^) = $25FF) then begin\r\n // This finds the correct procedure if a virtual jump has been inserted\r\n // at the procedure address\r\n Inc(patchPosition, 2); // skip the jump\r\n patchPosition := pansiChar(Pointer(pointer(patchPosition)^)^);\r\n end;\r\n offset:=integer(NewProc)-integer(pointer(patchPosition))-5;\r\n\r\n Patch[0] := ansichar($E9);\r\n Patch[1] := ansichar(offset and 255);\r\n Patch[2] := ansichar((offset shr 8) and 255);\r\n Patch[3] := ansichar((offset shr 16) and 255);\r\n Patch[4] := ansichar((offset shr 24) and 255);\r\n\r\n Original[0]:=PatchPosition[0];\r\n Original[1]:=PatchPosition[1];\r\n Original[2]:=PatchPosition[2];\r\n Original[3]:=PatchPosition[3];\r\n Original[4]:=PatchPosition[4];\r\n\r\n {$ifdef MSWINDOWS}\r\n if not VirtualProtect(Pointer(PatchPosition), 5, PAGE_EXECUTE_READWRITE, @ov) then\r\n RaiseLastOSError;\r\n {$endif}\r\n {$ifdef LINUX}\r\n pageSize:=sysconf (_SC_PAGE_SIZE);\r\n p:=pointer(PatchPosition);\r\n p:=pointer((integer(p) + PAGESIZE-1) and not (PAGESIZE-1) - pageSize);\r\n if mprotect (p, pageSize, PROT_READ + PROT_WRITE + PROT_EXEC) <> 0 then\r\n RaiseLastOSError;\r\n {$endif}\r\nend;\r\n\r\nprocedure THook.Shutdown;\r\nbegin\r\n Disable;\r\n PatchPosition:=nil;\r\nend;\r\n\r\nprocedure HookIntoResourceStrings (enabled:boolean=true; SupportPackages:boolean=false);\r\nbegin\r\n HookLoadResString.Reset (SupportPackages);\r\n HookLoadStr.Reset (SupportPackages);\r\n HookFmtLoadStr.Reset (SupportPackages);\r\n if enabled then begin\r\n HookLoadResString.Enable;\r\n HookLoadStr.Enable;\r\n HookFmtLoadStr.Enable;\r\n end;\r\nend;\r\n\r\n{ TMoFile }\r\n\r\nfunction TMoFile.autoswap32(i: cardinal): cardinal;\r\nvar\r\n cnv1, cnv2:\r\n record\r\n case integer of\r\n 0: (arr: array[0..3] of byte);\r\n 1: (int: cardinal);\r\n end;\r\nbegin\r\n if doswap then begin\r\n cnv1.int := i;\r\n cnv2.arr[0] := cnv1.arr[3];\r\n cnv2.arr[1] := cnv1.arr[2];\r\n cnv2.arr[2] := cnv1.arr[1];\r\n cnv2.arr[3] := cnv1.arr[0];\r\n Result := cnv2.int;\r\n end else\r\n Result := i;\r\nend;\r\n\r\nfunction TMoFile.CardinalInMem(baseptr: PansiChar; Offset: Cardinal): Cardinal;\r\nvar pc:^Cardinal;\r\nbegin\r\n inc (baseptr,offset);\r\n pc:=Pointer(baseptr);\r\n Result:=pc^;\r\n if doswap then\r\n autoswap32(Result);\r\nend;\r\n\r\nconstructor TMoFile.Create(const filename: FilenameString;\r\n const Offset: int64; Size: int64;\r\n const xUseMemoryMappedFiles: Boolean);\r\nvar\r\n i:cardinal;\r\n nn:integer;\r\n mofile:TFileStream;\r\nbegin\r\n if sizeof(i) <> 4 then\r\n raise EGGProgrammingError.Create('TDomain in gnugettext is written for an architecture that has 32 bit integers.');\r\n\r\n {$ifdef mswindows}\r\n FUseMemoryMappedFiles := xUseMemoryMappedFiles;\r\n {$endif}\r\n\r\n {$ifdef linux}\r\n FUseMemoryMappedFiles := False;\r\n {$endif}\r\n\r\n if FUseMemoryMappedFiles then\r\n begin\r\n // Map the mo file into memory and let the operating system decide how to cache\r\n mo:=createfile (PChar(filename),GENERIC_READ,FILE_SHARE_READ,nil,OPEN_EXISTING,0,0);\r\n if mo=INVALID_HANDLE_VALUE then\r\n raise EGGIOError.Create ('Cannot open file '+filename);\r\n momapping:=CreateFileMapping (mo, nil, PAGE_READONLY, 0, 0, nil);\r\n if momapping=0 then\r\n raise EGGIOError.Create ('Cannot create memory map on file '+filename);\r\n momemoryHandle:=MapViewOfFile (momapping,FILE_MAP_READ,0,0,0);\r\n if momemoryHandle=nil then begin\r\n raise EGGIOError.Create ('Cannot map file '+filename+' into memory. Reason: '+GetLastWinError);\r\n end;\r\n momemory:=momemoryHandle+offset;\r\n end\r\n else\r\n begin\r\n // Read the whole file into memory\r\n mofile:=TFileStream.Create (filename, fmOpenRead or fmShareDenyNone);\r\n try\r\n if (size = 0) then\r\n size := mofile.Size;\r\n Getmem (momemoryHandle, size);\r\n momemory := momemoryHandle;\r\n mofile.Seek(offset, soFromBeginning);\r\n mofile.ReadBuffer(momemory^, size);\r\n finally\r\n FreeAndNil(mofile);\r\n end;\r\n end;\r\n\r\n // Check the magic number\r\n doswap:=False;\r\n i:=CardinalInMem(momemory,0);\r\n if (i <> $950412DE) and (i <> $DE120495) then\r\n raise EGGIOError.Create('This file is not a valid GNU gettext mo file: ' + filename);\r\n doswap := (i = $DE120495);\r\n\r\n\r\n // Find the positions in the file according to the file format spec\r\n CardinalInMem(momemory,4); // Read the version number, but don't use it for anything.\r\n N:=CardinalInMem(momemory,8); // Get string count\r\n O:=CardinalInMem(momemory,12); // Get offset of original strings\r\n T:=CardinalInMem(momemory,16); // Get offset of translated strings\r\n\r\n // Calculate start conditions for a binary search\r\n nn := N;\r\n startindex := 1;\r\n while nn <> 0 do begin\r\n nn := nn shr 1;\r\n startindex := startindex shl 1;\r\n end;\r\n startindex := startindex shr 1;\r\n startstep := startindex shr 1;\r\nend;\r\n\r\ndestructor TMoFile.Destroy;\r\nbegin\r\n if FUseMemoryMappedFiles then\r\n begin\r\n UnMapViewOfFile (momemoryHandle);\r\n CloseHandle (momapping);\r\n CloseHandle (mo);\r\n end\r\n else\r\n begin\r\n FreeMem (momemoryHandle);\r\n end;\r\n\r\n inherited;\r\nend;\r\n\r\nfunction TMoFile.gettext(const msgid: RawUtf8String;var found:boolean): RawUtf8String;\r\nvar\r\n i, step: cardinal;\r\n offset, pos: cardinal;\r\n CompareResult:integer;\r\n msgidptr,a,b:PAnsiChar;\r\n abidx:integer;\r\n size, msgidsize:integer;\r\nbegin\r\n found:=false;\r\n msgidptr:=PAnsiChar(msgid);\r\n msgidsize:=length(msgid);\r\n\r\n // Do binary search\r\n i:=startindex;\r\n step:=startstep;\r\n while true do begin\r\n // Get string for index i\r\n pos:=O+8*(i-1);\r\n offset:=CardinalInMem (momemory,pos+4);\r\n size:=CardinalInMem (momemory,pos);\r\n a:=msgidptr;\r\n b:=momemory+offset;\r\n abidx:=size;\r\n if msgidsize0 do begin\r\n CompareResult:=integer(byte(a^))-integer(byte(b^));\r\n if CompareResult<>0 then\r\n break;\r\n dec (abidx);\r\n inc (a);\r\n inc (b);\r\n end;\r\n if CompareResult=0 then \r\n CompareResult:=msgidsize-size;\r\n if CompareResult=0 then begin // msgid=s\r\n // Found the msgid\r\n pos:=T+8*(i-1);\r\n offset:=CardinalInMem (momemory,pos+4);\r\n size:=CardinalInMem (momemory,pos);\r\n SetString (Result,momemory+offset,size);\r\n found:=True;\r\n break;\r\n end;\r\n if step=0 then begin\r\n // Not found\r\n Result:=msgid;\r\n break;\r\n end;\r\n if CompareResult<0 then begin // msgids\r\n i := i + step;\r\n if i > N then\r\n i := N;\r\n step := step shr 1;\r\n end;\r\n end;\r\nend;\r\n\r\nvar\r\n param0:string;\r\n\r\ninitialization\r\n {$ifdef DXGETTEXTDEBUG}\r\n {$ifdef MSWINDOWS}\r\n MessageBox (0,'gnugettext.pas debugging is enabled. Turn it off before releasing this piece of software.','Information',MB_OK);\r\n {$endif}\r\n {$ifdef LINUX}\r\n writeln (stderr,'gnugettext.pas debugging is enabled. Turn it off before releasing this piece of software.');\r\n {$endif}\r\n {$endif}\r\n {$ifdef FPC}\r\n {$ifdef LINUX}\r\n SetLocale(LC_ALL, '');\r\n SetCWidestringManager;\r\n {$endif LINUX}\r\n {$endif FPC}\r\n // Get DLL/shared object filename\r\n SetLength(ExecutableFilename, 300); // MAX_PATH ?\r\n {$ifdef MSWINDOWS}\r\n SetLength(ExecutableFilename, GetModuleFileName(HInstance,\r\n PChar(ExecutableFilename), Length(ExecutableFilename)));\r\n {$endif}\r\n {$ifdef LINUX}\r\n if ModuleIsLib or ModuleIsPackage then\r\n begin\r\n // This line has not been tested on Linux, yet, but should work.\r\n SetLength(ExecutableFilename, GetModuleFileName(0, PChar(ExecutableFilename),\r\n Length(ExecutableFilename)));\r\n end else\r\n ExecutableFilename:=Paramstr(0);\r\n {$endif}\r\n FileLocator:=TFileLocator.Create;\r\n FileLocator.Analyze;\r\n ResourceStringDomainList:=TStringList.Create;\r\n ResourceStringDomainList.Add(DefaultTextDomain);\r\n ResourceStringDomainListCS:=TMultiReadExclusiveWriteSynchronizer.Create;\r\n ComponentDomainList:=TStringList.Create;\r\n ComponentDomainList.Add(DefaultTextDomain);\r\n ComponentDomainListCS:=TMultiReadExclusiveWriteSynchronizer.Create;\r\n DefaultInstance:=TGnuGettextInstance.Create;\r\n {$ifdef MSWINDOWS}\r\n Win32PlatformIsUnicode := (Win32Platform = VER_PLATFORM_WIN32_NT);\r\n {$endif}\r\n\r\n // replace Borlands LoadResString with gettext enabled version:\r\n {$ifdef UNICODE}\r\n HookLoadResString:=THook.Create (@system.LoadResString, @LoadResStringW);\r\n {$else}\r\n HookLoadResString:=THook.Create (@system.LoadResString, @LoadResStringA);\r\n {$endif}\r\n HookLoadStr:=THook.Create (@sysutils.LoadStr, @SysUtilsLoadStr);\r\n HookFmtLoadStr:=THook.Create (@sysutils.FmtLoadStr, @SysUtilsFmtLoadStr);\r\n param0:=lowercase(extractfilename(paramstr(0)));\r\n if (param0<>'delphi32.exe') and (param0<>'kylix') and (param0<>'bds.exe') then\r\n HookIntoResourceStrings (AutoCreateHooks,false);\r\n param0:='';\r\n\r\nfinalization\r\n FreeAndNil (DefaultInstance);\r\n FreeAndNil (ResourceStringDomainListCS);\r\n FreeAndNil (ResourceStringDomainList);\r\n FreeAndNil (ComponentDomainListCS);\r\n FreeAndNil (ComponentDomainList);\r\n FreeAndNil (HookFmtLoadStr);\r\n FreeAndNil (HookLoadStr);\r\n FreeAndNil (HookLoadResString);\r\n FreeAndNil (FileLocator);\r\n\r\nend.\r\n\r\n" }, { "path": "External/Jedi/Jvcl/run/JvGradient.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing Rights and limitations under the License.\r\n\r\nThe Original Code is: JvGradient.PAS, released on 2001-02-28.\r\n\r\nThe Initial Developer of the Original Code is Sbastien Buysse [sbuysse att buypin dott com]\r\nPortions created by Sbastien Buysse are Copyright (C) 2001 Sbastien Buysse.\r\nAll Rights Reserved.\r\n\r\nContributor(s): Michael Beck [mbeck att bigfoot dott com].\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvGradient.pas 13104 2011-09-07 06:50:43Z obones $\r\n\r\nunit JvGradient;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, Messages, Graphics, Controls,\r\n SysUtils, Classes,\r\n JvTypes, JvComponent;\r\n\r\ntype\r\n TJvGradientPaintEvent = procedure(Sender: TObject; Canvas: TCanvas) of object;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvGradient = class(TJvGraphicControl)\r\n private\r\n FStyle: TJvGradientStyle;\r\n FStartColor: TColor;\r\n FEndColor: TColor;\r\n FSteps: Word;\r\n FBuffer: TBitmap;\r\n FBufferWidth: Integer;\r\n FBufferHeight: Integer;\r\n FLoadedLeft: Integer;\r\n FLoadedTop: Integer;\r\n FLoadedWidth: Integer;\r\n FLoadedHeight: Integer;\r\n FOnPaint: TJvGradientPaintEvent;\r\n procedure SetSteps(Value: Word);\r\n procedure SetStartColor(Value: TColor);\r\n procedure SetEndColor(Value: TColor);\r\n procedure SetStyle(Value: TJvGradientStyle);\r\n function GetLeft: Integer;\r\n function GetTop: Integer;\r\n function GetWidth: Integer;\r\n procedure SetLeft(const Value: Integer);\r\n procedure SetTop(const Value: Integer);\r\n procedure SetWidth(const Value: Integer);\r\n function GetHeight: Integer;\r\n procedure SetHeight(const Value: Integer);\r\n protected\r\n procedure Paint; override;\r\n procedure Loaded; override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n published\r\n property Align default alClient;\r\n property Anchors;\r\n property Constraints;\r\n property DragCursor;\r\n property DragKind;\r\n property DragMode;\r\n property Left: Integer read GetLeft write SetLeft;\r\n property Top: Integer read GetTop write SetTop;\r\n property Width: Integer read GetWidth write SetWidth;\r\n property Height: Integer read GetHeight write SetHeight;\r\n property ShowHint;\r\n property Visible;\r\n property ParentShowHint;\r\n property Enabled;\r\n property PopupMenu;\r\n property Style: TJvGradientStyle read FStyle write SetStyle default grHorizontal;\r\n property StartColor: TColor read FStartColor write SetStartColor default clBlue;\r\n property EndColor: TColor read FEndColor write SetEndColor default clBlack;\r\n property Steps: Word read FSteps write SetSteps default 100;\r\n\r\n property OnClick;\r\n property OnContextPopup;\r\n property OnDblClick;\r\n property OnDragDrop;\r\n property OnDragOver;\r\n property OnEndDock;\r\n property OnEndDrag;\r\n property OnMouseDown;\r\n property OnMouseEnter;\r\n property OnMouseLeave;\r\n property OnMouseMove;\r\n property OnMouseUp;\r\n property OnPaint: TJvGradientPaintEvent read FOnPaint write FOnPaint;\r\n property OnStartDock;\r\n property OnStartDrag;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvGradient.pas $';\r\n Revision: '$Revision: 13104 $';\r\n Date: '$Date: 2011-09-07 08:50:43 +0200 (mer. 07 sept. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\n\r\nconstructor TJvGradient.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n ControlStyle := ControlStyle + [csOpaque];\r\n FBufferWidth := 0;\r\n FBufferHeight := 0;\r\n FSteps := 100;\r\n FBuffer := TBitmap.Create;\r\n FStyle := grHorizontal;\r\n FEndColor := clBlack;\r\n FStartColor := clBlue;\r\n Align := alClient;\r\nend;\r\n\r\ndestructor TJvGradient.Destroy;\r\nbegin\r\n FBuffer.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJvGradient.GetHeight: Integer;\r\nbegin\r\n Result := inherited Height;\r\nend;\r\n\r\nfunction TJvGradient.GetLeft: Integer;\r\nbegin\r\n Result := inherited Left;\r\nend;\r\n\r\nfunction TJvGradient.GetTop: Integer;\r\nbegin\r\n Result := inherited Top;\r\nend;\r\n\r\nfunction TJvGradient.GetWidth: Integer;\r\nbegin\r\n Result := inherited Width;\r\nend;\r\n\r\nprocedure TJvGradient.Loaded;\r\nbegin\r\n inherited Loaded;\r\n if not (Align in [alLeft, alTop, alRight, alBottom]) then\r\n begin\r\n inherited Left := FLoadedLeft;\r\n inherited Top := FLoadedTop;\r\n end;\r\n if Align <> alClient then\r\n begin\r\n inherited Width := FLoadedWidth;\r\n inherited Height := FLoadedHeight;\r\n end;\r\nend;\r\n\r\nprocedure TJvGradient.Paint;\r\nvar\r\n I: Integer;\r\n J, K: Real;\r\n Deltas: array [0..2] of Double; // R,G,B\r\n R: TRect;\r\n LStartRGB, LEndRGB: TColor;\r\n LSteps: Word;\r\nbegin\r\n if csDestroying in ComponentState then\r\n Exit;\r\n if (FBufferWidth <> Width) or (FBufferHeight <> Height) then\r\n begin\r\n LSteps := FSteps;\r\n LStartRGB := ColorToRGB(FStartColor);\r\n LEndRGB := ColorToRGB(FEndColor);\r\n\r\n FBufferWidth := Width;\r\n FBufferHeight := Height;\r\n if (FBufferWidth = 0) or (FBufferHeight = 0) then\r\n Exit;\r\n\r\n FBuffer.Width := FBufferWidth;\r\n FBuffer.Height := FBufferHeight;\r\n case FStyle of\r\n grFilled:\r\n begin\r\n FBuffer.Canvas.Brush.Color := LStartRGB;\r\n FBuffer.Canvas.Brush.Style := bsSolid;\r\n FBuffer.Canvas.FillRect(Rect(0, 0, Width, Height));\r\n end;\r\n grEllipse:\r\n begin\r\n FBuffer.Canvas.Brush.Color := LStartRGB;\r\n FBuffer.Canvas.Brush.Style := bsSolid;\r\n FBuffer.Canvas.FillRect(Rect(0, 0, Width, Height));\r\n if LSteps > (Width div 2) then\r\n LSteps := Trunc(Width / 2);\r\n if LSteps > (Height div 2) then\r\n LSteps := Trunc(Height / 2);\r\n if LSteps < 1 then\r\n LSteps := 1;\r\n Deltas[0] := (GetRValue(LEndRGB) - GetRValue(LStartRGB)) / LSteps;\r\n Deltas[1] := (GetGValue(LEndRGB) - GetGValue(LStartRGB)) / LSteps;\r\n Deltas[2] := (GetBValue(LEndRGB) - GetBValue(LStartRGB)) / LSteps;\r\n FBuffer.Canvas.Brush.Style := bsSolid;\r\n J := (Width / LSteps) / 2;\r\n K := (Height / LSteps) / 2;\r\n for I := 0 to LSteps do\r\n begin\r\n R.Top := Round(I * K);\r\n R.Bottom := Height - R.Top;\r\n R.Right := Round(I * J);\r\n R.Left := Width - R.Right;\r\n FBuffer.Canvas.Brush.Color := RGB(\r\n Round(GetRValue(LStartRGB) + I * Deltas[0]),\r\n Round(GetGValue(LStartRGB) + I * Deltas[1]),\r\n Round(GetBValue(LStartRGB) + I * Deltas[2]));\r\n FBuffer.Canvas.Pen.Color := FBuffer.Canvas.Brush.Color;\r\n FBuffer.Canvas.Ellipse(R.Right, R.Top, R.Left, R.Bottom);\r\n end;\r\n end;\r\n grHorizontal:\r\n begin\r\n if LSteps > Width then\r\n LSteps := Width;\r\n if LSteps < 1 then\r\n LSteps := 1;\r\n Deltas[0] := (GetRValue(LEndRGB) - GetRValue(LStartRGB)) / LSteps;\r\n Deltas[1] := (GetGValue(LEndRGB) - GetGValue(LStartRGB)) / LSteps;\r\n Deltas[2] := (GetBValue(LEndRGB) - GetBValue(LStartRGB)) / LSteps;\r\n FBuffer.Canvas.Brush.Style := bsSolid;\r\n J := Width / LSteps;\r\n for I := 0 to LSteps do\r\n begin\r\n R.Top := 0;\r\n R.Bottom := Height;\r\n R.Left := Round(I * J);\r\n R.Right := Round((I + 1) * J);\r\n FBuffer.Canvas.Brush.Color := RGB(\r\n Round(GetRValue(LStartRGB) + I * Deltas[0]),\r\n Round(GetGValue(LStartRGB) + I * Deltas[1]),\r\n Round(GetBValue(LStartRGB) + I * Deltas[2]));\r\n FBuffer.Canvas.FillRect(R);\r\n end;\r\n end;\r\n grVertical:\r\n begin\r\n if LSteps > Height then\r\n LSteps := Height;\r\n if LSteps < 1 then\r\n LSteps := 1;\r\n Deltas[0] := (GetRValue(LEndRGB) - GetRValue(LStartRGB)) / LSteps;\r\n Deltas[1] := (GetGValue(LEndRGB) - GetGValue(LStartRGB)) / LSteps;\r\n Deltas[2] := (GetBValue(LEndRGB) - GetBValue(LStartRGB)) / LSteps;\r\n FBuffer.Canvas.Brush.Style := bsSolid;\r\n J := Height / LSteps;\r\n for I := 0 to LSteps do\r\n begin\r\n R.Left := Width;\r\n R.Right := 0;\r\n R.Top := Round(I * J);\r\n R.Bottom := Round((I + 1) * J);\r\n FBuffer.Canvas.Brush.Color := RGB(\r\n Round(GetRValue(LStartRGB) + I * Deltas[0]),\r\n Round(GetGValue(LStartRGB) + I * Deltas[1]),\r\n Round(GetBValue(LStartRGB) + I * Deltas[2]));\r\n FBuffer.Canvas.FillRect(R);\r\n end;\r\n end;\r\n grMount:\r\n begin\r\n FBuffer.Canvas.Brush.Color := LStartRGB;\r\n FBuffer.Canvas.Brush.Style := bsSolid;\r\n FBuffer.Canvas.FillRect(Rect(0, 0, Width, Height));\r\n if LSteps > (Width div 2) then\r\n LSteps := Trunc(Width / 2);\r\n if LSteps > (Height div 2) then\r\n LSteps := Trunc(Height / 2);\r\n if LSteps < 1 then\r\n LSteps := 1;\r\n Deltas[0] := (GetRValue(LEndRGB) - GetRValue(LStartRGB)) / LSteps;\r\n Deltas[1] := (GetGValue(LEndRGB) - GetGValue(LStartRGB)) / LSteps;\r\n Deltas[2] := (GetBValue(LEndRGB) - GetBValue(LStartRGB)) / LSteps;\r\n FBuffer.Canvas.Brush.Style := bsSolid;\r\n J := (Width / LSteps) / 2;\r\n K := (Height / LSteps) / 2;\r\n for I := 0 to LSteps do\r\n begin\r\n R.Top := Round(I * K);\r\n R.Bottom := Height - R.Top;\r\n R.Right := Round(I * J);\r\n R.Left := Width - R.Right;\r\n FBuffer.Canvas.Brush.Color := RGB(\r\n Round(GetRValue(LStartRGB) + I * Deltas[0]),\r\n Round(GetGValue(LStartRGB) + I * Deltas[1]),\r\n Round(GetBValue(LStartRGB) + I * Deltas[2]));\r\n FBuffer.Canvas.Pen.Color := FBuffer.Canvas.Brush.Color;\r\n FBuffer.Canvas.RoundRect(R.Right, R.Top, R.Left, R.Bottom,\r\n ((R.Left - R.Right) div 2), ((R.Bottom - R.Top) div 2));\r\n end;\r\n end;\r\n grPyramid:\r\n begin\r\n FBuffer.Canvas.Brush.Color := LStartRGB;\r\n FBuffer.Canvas.Brush.Style := bsSolid;\r\n FBuffer.Canvas.FillRect(Rect(0, 0, Width, Height));\r\n if LSteps > (Width div 2) then\r\n LSteps := Trunc(Width / 2);\r\n if LSteps > (Height div 2) then\r\n LSteps := Trunc(Height / 2);\r\n if LSteps < 1 then\r\n LSteps := 1;\r\n Deltas[0] := (GetRValue(LEndRGB) - GetRValue(LStartRGB)) / LSteps;\r\n Deltas[1] := (GetGValue(LEndRGB) - GetGValue(LStartRGB)) / LSteps;\r\n Deltas[2] := (GetBValue(LEndRGB) - GetBValue(LStartRGB)) / LSteps;\r\n FBuffer.Canvas.Brush.Style := bsSolid;\r\n J := (Width / LSteps) / 2;\r\n K := (Height / LSteps) / 2;\r\n for I := 0 to LSteps do\r\n begin\r\n R.Top := Round(I * K);\r\n R.Bottom := Height - R.Top;\r\n R.Right := Round(I * J);\r\n R.Left := Width - R.Right;\r\n FBuffer.Canvas.Brush.Color := RGB(\r\n Round(GetRValue(LStartRGB) + I * Deltas[0]),\r\n Round(GetGValue(LStartRGB) + I * Deltas[1]),\r\n Round(GetBValue(LStartRGB) + I * Deltas[2]));\r\n FBuffer.Canvas.Pen.Color := FBuffer.Canvas.Brush.Color;\r\n FBuffer.Canvas.FillRect(Rect(R.Right, R.Top, R.Left, R.Bottom));\r\n end;\r\n end;\r\n end;\r\n if Assigned(FOnPaint) then\r\n FOnPaint(Self, FBuffer.Canvas);\r\n end;\r\n Canvas.Draw(0, 0, FBuffer);\r\nend;\r\n\r\nprocedure TJvGradient.SetStyle(Value: TJvGradientStyle);\r\nbegin\r\n if FStyle <> Value then\r\n begin\r\n FStyle := Value;\r\n FBufferWidth := 0;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvGradient.SetTop(const Value: Integer);\r\nbegin\r\n FLoadedTop := Value;\r\n inherited Top := Value;\r\nend;\r\n\r\nprocedure TJvGradient.SetWidth(const Value: Integer);\r\nbegin\r\n FLoadedWidth := Value;\r\n inherited Width := Value;\r\nend;\r\n\r\nprocedure TJvGradient.SetStartColor(Value: TColor);\r\nbegin\r\n if FStartColor <> Value then\r\n begin\r\n FStartColor := Value;\r\n FBufferWidth := 0;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvGradient.SetSteps(Value: Word);\r\nbegin\r\n if FSteps <> Value then\r\n begin\r\n FSteps := Value;\r\n FBufferWidth := 0;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvGradient.SetEndColor(Value: TColor);\r\nbegin\r\n if FEndColor <> Value then\r\n begin\r\n FEndColor := Value;\r\n FBufferWidth := 0;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvGradient.SetHeight(const Value: Integer);\r\nbegin\r\n FLoadedHeight := Value;\r\n inherited Height := Value;\r\nend;\r\n\r\nprocedure TJvGradient.SetLeft(const Value: Integer);\r\nbegin\r\n FLoadedLeft := Value;\r\n inherited Left := Value;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvGradientCaption.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvGrdCpt.PAS, released on 2002-07-04.\r\n\r\nThe Initial Developers of the Original Code are: Fedor Koshevnikov, Igor Pavluk and Serge Korolev\r\nCopyright (c) 1997, 1998 Fedor Koshevnikov, Igor Pavluk and Serge Korolev\r\nCopyright (c) 2001,2002 SGB Software\r\nAll Rights Reserved.\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvGradientCaption.pas 13104 2011-09-07 06:50:43Z obones $\r\n\r\nunit JvGradientCaption;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, Messages, Classes, Graphics, Controls, Forms, Menus,\r\n JvWndProcHook, JvJCLUtils, JvJVCLUtils;\r\n\r\ntype\r\n THideDirection = (hdLeftToRight, hdRightToLeft);\r\n\r\n TJvCaption = class;\r\n TJvCaptionList = class;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64 or pidOSX32)]\r\n {$ENDIF RTL230_UP}\r\n TJvGradientCaption = class(TComponent)\r\n private\r\n FActive: Boolean;\r\n FWindowActive: Boolean;\r\n FSaveRgn: HRGN;\r\n FRgnChanged: Boolean;\r\n FWinHook: TJvWindowHook;\r\n FStartColor: TColor;\r\n FEndColor: TColor;\r\n FFillDirection : TFillDirection;\r\n FCaptions: TJvCaptionList;\r\n FFont: TFont;\r\n FDefaultFont: Boolean;\r\n FPopupMenu: TPopupMenu;\r\n FClicked: Boolean;\r\n FHideDirection: THideDirection;\r\n FGradientInactive: Boolean;\r\n FGradientActive: Boolean;\r\n FFontInactiveColor: TColor;\r\n FFormCaption: string;\r\n FGradientSteps: Integer;\r\n FOnActivate: TNotifyEvent;\r\n FOnDeactivate: TNotifyEvent;\r\n procedure SetHook;\r\n procedure ReleaseHook;\r\n procedure CheckToggleHook;\r\n function GetActive: Boolean;\r\n procedure SetActive(Value: Boolean);\r\n procedure SetStartColor(Value: TColor);\r\n procedure DrawGradientCaption(DC: HDC);\r\n procedure CalculateGradientParams(var R: TRect; var Icons: TBorderIcons);\r\n function GetForm: TForm;\r\n function GetFormCaption: string;\r\n procedure SetFormCaption(const Value: string);\r\n procedure BeforeMessage(Sender: TObject; var Msg: TMessage; var Handled: Boolean);\r\n procedure AfterMessage(Sender: TObject; var Msg: TMessage; var Handled: Boolean);\r\n function CheckMenuPopup(X, Y: Integer): Boolean;\r\n procedure SetFont(Value: TFont);\r\n procedure FontChanged(Sender: TObject);\r\n procedure SetDefaultFont(Value: Boolean);\r\n procedure SetFontDefault;\r\n function IsFontStored: Boolean;\r\n function GetTextWidth: Integer;\r\n procedure SetCaptions(Value: TJvCaptionList);\r\n procedure SetGradientActive(Value: Boolean);\r\n procedure SetGradientInactive(Value: Boolean);\r\n procedure SetGradientSteps(Value: Integer);\r\n procedure SetFontInactiveColor(Value: TColor);\r\n procedure SetHideDirection(Value: THideDirection);\r\n procedure SetPopupMenu(Value: TPopupMenu);\r\n procedure SetEndColor(Value: TColor);\r\n procedure SetFillDirection(Value: TFillDirection);\r\n protected\r\n procedure Loaded; override;\r\n procedure Notification(AComponent: TComponent; Operation: TOperation); override;\r\n function IsRightToLeft: Boolean;\r\n property Form: TForm read GetForm;\r\n property TextWidth: Integer read GetTextWidth;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n procedure MoveCaption(FromIndex, ToIndex: Integer);\r\n procedure Update;\r\n procedure Clear;\r\n published\r\n property Active: Boolean read GetActive write SetActive default True;\r\n property Captions: TJvCaptionList read FCaptions write SetCaptions;\r\n property DefaultFont: Boolean read FDefaultFont write SetDefaultFont default True;\r\n property FormCaption: string read GetFormCaption write SetFormCaption;\r\n property FontInactiveColor: TColor read FFontInactiveColor\r\n write SetFontInactiveColor default clInactiveCaptionText;\r\n property Font: TFont read FFont write SetFont stored IsFontStored;\r\n property GradientActive: Boolean read FGradientActive\r\n write SetGradientActive default True;\r\n property GradientInactive: Boolean read FGradientInactive\r\n write SetGradientInactive default False;\r\n property GradientSteps: Integer read FGradientSteps write SetGradientSteps default 64;\r\n property HideDirection: THideDirection read FHideDirection\r\n write SetHideDirection default hdLeftToRight;\r\n property PopupMenu: TPopupMenu read FPopupMenu write SetPopupMenu;\r\n property StartColor: TColor read FStartColor write SetStartColor\r\n default clWindowText;\r\n property EndColor: TColor read FEndColor write SetEndColor\r\n default clActiveCaption;\r\n property FillDirection : TFillDirection read FFillDirection write SetFillDirection\r\n default fdLeftToRight;\r\n property OnActivate: TNotifyEvent read FOnActivate write FOnActivate;\r\n property OnDeactivate: TNotifyEvent read FOnDeactivate write FOnDeactivate;\r\n end;\r\n\r\n TJvCaptionList = class(TCollection)\r\n private\r\n FParent: TJvGradientCaption;\r\n function GetCaption(Index: Integer): TJvCaption;\r\n procedure SetCaption(Index: Integer; Value: TJvCaption);\r\n protected\r\n function GetOwner: TPersistent; override;\r\n procedure Update(Item: TCollectionItem); override;\r\n public\r\n constructor Create(AParent: TJvGradientCaption);\r\n function Add: TJvCaption;\r\n procedure RestoreDefaults;\r\n property Parent: TJvGradientCaption read FParent;\r\n property Items[Index: Integer]: TJvCaption read GetCaption write SetCaption; default;\r\n end;\r\n\r\n TJvCaption = class(TCollectionItem)\r\n private\r\n FCaption: string;\r\n FFont: TFont;\r\n FParentFont: Boolean;\r\n FVisible: Boolean;\r\n FGlueNext: Boolean;\r\n FInactiveColor: TColor;\r\n procedure SetCaption(const Value: string);\r\n procedure SetFont(Value: TFont);\r\n procedure SetParentFont(Value: Boolean);\r\n procedure FontChanged(Sender: TObject);\r\n function IsFontStored: Boolean;\r\n function GetTextWidth: Integer;\r\n procedure SetVisible(Value: Boolean);\r\n procedure SetInactiveColor(Value: TColor);\r\n procedure SetGlueNext(Value: Boolean);\r\n protected\r\n function GetParentCaption: TJvGradientCaption;\r\n property TextWidth: Integer read GetTextWidth;\r\n public\r\n constructor Create(Collection: TCollection); override;\r\n destructor Destroy; override;\r\n procedure Assign(Source: TPersistent); override;\r\n procedure RestoreDefaults; virtual;\r\n property GradientCaption: TJvGradientCaption read GetParentCaption;\r\n published\r\n property Caption: string read FCaption write SetCaption;\r\n property Font: TFont read FFont write SetFont stored IsFontStored;\r\n property ParentFont: Boolean read FParentFont write SetParentFont default True;\r\n property InactiveColor: TColor read FInactiveColor write SetInactiveColor\r\n default clInactiveCaptionText;\r\n property GlueNext: Boolean read FGlueNext write SetGlueNext default False;\r\n property Visible: Boolean read FVisible write SetVisible default True;\r\n end;\r\n\r\nfunction GradientFormCaption(AForm: TCustomForm; AStartColor, AEndColor: TColor):\r\n TJvGradientCaption;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvGradientCaption.pas $';\r\n Revision: '$Revision: 13104 $';\r\n Date: '$Date: 2011-09-07 08:50:43 +0200 (mer. 07 sept. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n SysUtils,\r\n JvConsts, JvCaptionButton;\r\n\r\nfunction GradientFormCaption(AForm: TCustomForm; AStartColor, AEndColor: TColor): TJvGradientCaption;\r\nbegin\r\n Result := TJvGradientCaption.Create(AForm);\r\n with Result do\r\n try\r\n FStartColor := AStartColor;\r\n FEndColor := AEndColor;\r\n FormCaption := AForm.Caption;\r\n Update;\r\n except\r\n Free;\r\n raise;\r\n end;\r\nend;\r\n\r\nfunction InternalGetTextWidth(Font: TFont; const Caption: string): Integer;\r\nvar\r\n Canvas: TCanvas;\r\n PS: TPaintStruct;\r\nbegin\r\n BeginPaint(Application.Handle, PS);\r\n try\r\n Canvas := TCanvas.Create;\r\n try\r\n Canvas.Handle := PS.hdc;\r\n Canvas.Font := Font;\r\n Result := Canvas.TextWidth(Caption);\r\n finally\r\n Canvas.Free;\r\n end;\r\n finally\r\n EndPaint(Application.Handle, PS);\r\n end;\r\nend;\r\n\r\n//=== { TJvCaptionList } =====================================================\r\n\r\nconstructor TJvCaptionList.Create(AParent: TJvGradientCaption);\r\nbegin\r\n inherited Create(TJvCaption);\r\n FParent := AParent;\r\nend;\r\n\r\nfunction TJvCaptionList.Add: TJvCaption;\r\nbegin\r\n Result := TJvCaption(inherited Add);\r\nend;\r\n\r\nfunction TJvCaptionList.GetCaption(Index: Integer): TJvCaption;\r\nbegin\r\n Result := TJvCaption(inherited Items[Index]);\r\nend;\r\n\r\nfunction TJvCaptionList.GetOwner: TPersistent;\r\nbegin\r\n Result := FParent;\r\nend;\r\n\r\nprocedure TJvCaptionList.RestoreDefaults;\r\nvar\r\n I: Integer;\r\nbegin\r\n BeginUpdate;\r\n try\r\n for I := 0 to Count - 1 do\r\n Items[I].RestoreDefaults;\r\n finally\r\n EndUpdate;\r\n end;\r\nend;\r\n\r\nprocedure TJvCaptionList.SetCaption(Index: Integer; Value: TJvCaption);\r\nbegin\r\n Items[Index].Assign(Value);\r\nend;\r\n\r\nprocedure TJvCaptionList.Update(Item: TCollectionItem);\r\nbegin\r\n if (FParent <> nil) and not (csLoading in FParent.ComponentState) then\r\n if FParent.Active then\r\n FParent.Update;\r\nend;\r\n\r\n//=== { TJvCaption } =========================================================\r\n\r\nconstructor TJvCaption.Create(Collection: TCollection);\r\nvar\r\n Parent: TJvGradientCaption;\r\nbegin\r\n Parent := nil;\r\n if Assigned(Collection) and (Collection is TJvCaptionList) then\r\n Parent := TJvCaptionList(Collection).Parent;\r\n try\r\n inherited Create(Collection);\r\n FFont := TFont.Create;\r\n if Assigned(Parent) then\r\n begin\r\n FFont.Assign(Parent.Font);\r\n FFont.Color := Parent.Font.Color;\r\n end\r\n else\r\n FFont.Color := clCaptionText;\r\n FFont.OnChange := FontChanged;\r\n FCaption := '';\r\n FParentFont := True;\r\n FVisible := True;\r\n FGlueNext := False;\r\n FInactiveColor := clInactiveCaptionText;\r\n finally\r\n if Assigned(Parent) then\r\n Changed(False);\r\n end;\r\nend;\r\n\r\ndestructor TJvCaption.Destroy;\r\nbegin\r\n FFont.Free;\r\n FFont := nil;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvCaption.Assign(Source: TPersistent);\r\nbegin\r\n if Source is TJvCaption then\r\n begin\r\n if Assigned(Collection) then\r\n Collection.BeginUpdate;\r\n try\r\n RestoreDefaults;\r\n Caption := TJvCaption(Source).Caption;\r\n ParentFont := TJvCaption(Source).ParentFont;\r\n if not ParentFont then\r\n Font.Assign(TJvCaption(Source).Font);\r\n InactiveColor := TJvCaption(Source).InactiveColor;\r\n GlueNext := TJvCaption(Source).GlueNext;\r\n Visible := TJvCaption(Source).Visible;\r\n finally\r\n if Assigned(Collection) then\r\n Collection.EndUpdate;\r\n end;\r\n end\r\n else\r\n inherited Assign(Source);\r\nend;\r\n\r\nprocedure TJvCaption.RestoreDefaults;\r\nbegin\r\n FInactiveColor := clInactiveCaptionText;\r\n FVisible := True;\r\n ParentFont := True;\r\nend;\r\n\r\nfunction TJvCaption.GetParentCaption: TJvGradientCaption;\r\nbegin\r\n if Assigned(Collection) and (Collection is TJvCaptionList) then\r\n Result := TJvCaptionList(Collection).Parent\r\n else\r\n Result := nil;\r\nend;\r\n\r\nprocedure TJvCaption.SetCaption(const Value: string);\r\nbegin\r\n FCaption := Value;\r\n Changed(False);\r\nend;\r\n\r\nprocedure TJvCaption.FontChanged(Sender: TObject);\r\nbegin\r\n FParentFont := False;\r\n Changed(False);\r\nend;\r\n\r\nprocedure TJvCaption.SetFont(Value: TFont);\r\nbegin\r\n FFont.Assign(Value);\r\nend;\r\n\r\nprocedure TJvCaption.SetParentFont(Value: Boolean);\r\nbegin\r\n if Value and (GradientCaption <> nil) then\r\n begin\r\n FFont.OnChange := nil;\r\n try\r\n FFont.Assign(GradientCaption.Font);\r\n finally\r\n FFont.OnChange := FontChanged;\r\n end;\r\n end;\r\n FParentFont := Value;\r\n Changed(False);\r\nend;\r\n\r\nfunction TJvCaption.IsFontStored: Boolean;\r\nbegin\r\n Result := not ParentFont;\r\nend;\r\n\r\nfunction TJvCaption.GetTextWidth: Integer;\r\nbegin\r\n Result := InternalGetTextWidth(Font, Caption);\r\nend;\r\n\r\nprocedure TJvCaption.SetVisible(Value: Boolean);\r\nbegin\r\n if FVisible <> Value then\r\n begin\r\n FVisible := Value;\r\n Changed(False);\r\n end;\r\nend;\r\n\r\nprocedure TJvCaption.SetInactiveColor(Value: TColor);\r\nbegin\r\n if FInactiveColor <> Value then\r\n begin\r\n FInactiveColor := Value;\r\n if (GradientCaption = nil) or not GradientCaption.FWindowActive then\r\n Changed(False);\r\n end;\r\nend;\r\n\r\nprocedure TJvCaption.SetGlueNext(Value: Boolean);\r\nbegin\r\n if FGlueNext <> Value then\r\n begin\r\n FGlueNext := Value;\r\n Changed(False);\r\n end;\r\nend;\r\n\r\n//=== { TJvGradientCaption } ================================================\r\n\r\nconstructor TJvGradientCaption.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FGradientSteps := 64;\r\n FGradientActive := True;\r\n FActive := True;\r\n FCaptions := TJvCaptionList.Create(Self);\r\n FWinHook := TJvWindowHook.Create(Self);\r\n FWinHook.BeforeMessage := BeforeMessage;\r\n FWinHook.AfterMessage := AfterMessage;\r\n FStartColor := clWindowText;\r\n FEndColor := clActiveCaption;// doubt: should it be clGradientActiveCaption?\r\n FFillDirection := fdLeftToRight;\r\n FFontInactiveColor := clInactiveCaptionText;\r\n FFormCaption := '';\r\n FFont := TFont.Create;\r\n SetFontDefault;\r\nend;\r\n\r\ndestructor TJvGradientCaption.Destroy;\r\nbegin\r\n FOnDeactivate := nil;\r\n FOnActivate := nil;\r\n if not (csDesigning in ComponentState) then\r\n ReleaseHook;\r\n FCaptions.Free;\r\n FCaptions := nil;\r\n FFont.Free;\r\n FFont := nil;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvGradientCaption.Loaded;\r\nvar\r\n Loading: Boolean;\r\nbegin\r\n Loading := csLoading in ComponentState;\r\n inherited Loaded;\r\n if not (csDesigning in ComponentState) then\r\n begin\r\n if Loading and (Owner is TCustomForm) then\r\n Update;\r\n end;\r\nend;\r\n\r\nprocedure TJvGradientCaption.Notification(AComponent: TComponent;\r\n Operation: TOperation);\r\nbegin\r\n inherited Notification(AComponent, Operation);\r\n if (AComponent = PopupMenu) and (Operation = opRemove) then\r\n PopupMenu := nil;\r\nend;\r\n\r\nprocedure TJvGradientCaption.SetPopupMenu(Value: TPopupMenu);\r\nbegin\r\n ReplaceComponentReference(Self, Value, TComponent(FPopupMenu));\r\nend;\r\n\r\nprocedure TJvGradientCaption.SetCaptions(Value: TJvCaptionList);\r\nbegin\r\n Captions.Assign(Value);\r\nend;\r\n\r\nprocedure TJvGradientCaption.SetDefaultFont(Value: Boolean);\r\nbegin\r\n if FDefaultFont <> Value then\r\n begin\r\n if Value then\r\n SetFontDefault;\r\n FDefaultFont := Value;\r\n if Active then\r\n Update;\r\n end;\r\nend;\r\n\r\nprocedure TJvGradientCaption.SetFontDefault;\r\nvar\r\n NCMetrics: TNonClientMetrics;\r\nbegin\r\n with FFont do\r\n begin\r\n OnChange := nil;\r\n try\r\n {$IFDEF RTL210_UP}\r\n NCMetrics.cbSize := TNonClientMetrics.SizeOf;\r\n {$ELSE}\r\n NCMetrics.cbSize := SizeOf(NCMetrics);\r\n {$ENDIF RTL210_UP}\r\n if SystemParametersInfo(SPI_GETNONCLIENTMETRICS, NCMetrics.cbSize, @NCMetrics, 0) then\r\n begin\r\n if (Owner is TForm) and\r\n ((Owner as TForm).BorderStyle in [bsToolWindow, bsSizeToolWin]) then\r\n Handle := CreateFontIndirect(NCMetrics.lfSmCaptionFont)\r\n else\r\n Handle := CreateFontIndirect(NCMetrics.lfCaptionFont);\r\n end\r\n else\r\n begin\r\n Name := 'MS Sans Serif';\r\n Size := 8;\r\n Style := [fsBold];\r\n end;\r\n Color := clCaptionText;\r\n Charset := DEFAULT_CHARSET;\r\n finally\r\n OnChange := FontChanged;\r\n end;\r\n end;\r\n FDefaultFont := True;\r\nend;\r\n\r\nfunction TJvGradientCaption.IsFontStored: Boolean;\r\nbegin\r\n Result := not DefaultFont;\r\nend;\r\n\r\nfunction TJvGradientCaption.GetForm: TForm;\r\nbegin\r\n if Owner is TCustomForm then\r\n Result := TForm(Owner as TCustomForm)\r\n else\r\n Result := nil;\r\nend;\r\n\r\nfunction TJvGradientCaption.GetFormCaption: string;\r\nbegin\r\n if (Form <> nil) and (csDesigning in ComponentState) then\r\n FFormCaption := Form.Caption;\r\n Result := FFormCaption;\r\nend;\r\n\r\nprocedure TJvGradientCaption.SetFormCaption(const Value: string);\r\nbegin\r\n if FFormCaption <> Value then\r\n begin\r\n FFormCaption := Value;\r\n if (Form <> nil) and (csDesigning in ComponentState) then\r\n Form.Caption := FFormCaption;\r\n if Active then\r\n Update;\r\n end;\r\nend;\r\n\r\nprocedure TJvGradientCaption.SetHook;\r\nbegin\r\n if not (csDesigning in ComponentState) and (Owner <> nil) and\r\n (Owner is TCustomForm) then\r\n FWinHook.Control := Form;\r\nend;\r\n\r\nprocedure TJvGradientCaption.ReleaseHook;\r\nbegin\r\n FWinHook.Control := nil;\r\nend;\r\n\r\nprocedure TJvGradientCaption.CheckToggleHook;\r\nbegin\r\n if Active then\r\n SetHook\r\n else\r\n ReleaseHook;\r\nend;\r\n\r\nfunction TJvGradientCaption.CheckMenuPopup(X, Y: Integer): Boolean;\r\nbegin\r\n Result := False;\r\n if not (csDesigning in ComponentState) and Assigned(FPopupMenu) and\r\n FPopupMenu.AutoPopup then\r\n begin\r\n FPopupMenu.PopupComponent := Self;\r\n if Form <> nil then\r\n begin\r\n Form.SendCancelMode(nil);\r\n FPopupMenu.Popup(X, Y);\r\n Result := True;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvGradientCaption.BeforeMessage(Sender: TObject; var Msg: TMessage;\r\n var Handled: Boolean);\r\nvar\r\n DrawRgn: HRGN;\r\n R: TRect;\r\n Icons: TBorderIcons;\r\nbegin\r\n if Active then\r\n begin\r\n case Msg.Msg of\r\n WM_NCACTIVATE:\r\n FWindowActive := (Msg.WParam <> 0);\r\n WM_NCRBUTTONDOWN:\r\n if Assigned(FPopupMenu) and FPopupMenu.AutoPopup then\r\n begin\r\n FClicked := True;\r\n Msg.Result := 0;\r\n Handled := True;\r\n end;\r\n WM_NCRBUTTONUP:\r\n with TWMMouse(Msg) do\r\n if FClicked then\r\n begin\r\n FClicked := False;\r\n if CheckMenuPopup(XPos, YPos) then\r\n begin\r\n Result := 0;\r\n Handled := True;\r\n end;\r\n end;\r\n WM_NCPAINT:\r\n begin\r\n FSaveRgn := Msg.WParam;\r\n FRgnChanged := False;\r\n CalculateGradientParams(R, Icons);\r\n if RectInRegion(FSaveRgn, R) then\r\n begin\r\n DrawRgn := CreateRectRgn(R.Left, R.Top, R.Right, R.Bottom);\r\n try\r\n Msg.WParam := CreateRectRgn(0, 0, 1, 1);\r\n FRgnChanged := True;\r\n CombineRgn(Msg.WParam, FSaveRgn, DrawRgn, RGN_DIFF);\r\n finally\r\n DeleteObject(DrawRgn);\r\n end;\r\n end;\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvGradientCaption.AfterMessage(Sender: TObject; var Msg: TMessage;\r\n var Handled: Boolean);\r\nvar\r\n DC: HDC;\r\n S: string;\r\nbegin\r\n if Active then\r\n begin\r\n case Msg.Msg of\r\n WM_NCACTIVATE:\r\n begin\r\n DC := GetWindowDC(Form.Handle);\r\n try\r\n DrawGradientCaption(DC);\r\n finally\r\n ReleaseDC(Form.Handle, DC);\r\n end;\r\n end;\r\n WM_NCPAINT:\r\n begin\r\n if FRgnChanged then\r\n begin\r\n DeleteObject(Msg.WParam);\r\n Msg.WParam := FSaveRgn;\r\n FRgnChanged := False;\r\n end;\r\n DC := GetWindowDC(Form.Handle);\r\n try\r\n DrawGradientCaption(DC);\r\n finally\r\n ReleaseDC(Form.Handle, DC);\r\n end;\r\n end;\r\n WM_GETTEXT:\r\n { Delphi doesn't send WM_SETTEXT to form's window procedure,\r\n so we need to handle WM_GETTEXT to redraw non-client area\r\n when form's caption changed }\r\n if csDesigning in ComponentState then\r\n begin\r\n SetString(S, PChar(Msg.LParam), Msg.Result);\r\n if AnsiCompareStr(S, FFormCaption) <> 0 then\r\n begin\r\n FormCaption := S;\r\n PostMessage(Form.Handle, WM_NCPAINT, 0, 0);\r\n end;\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvGradientCaption.SetStartColor(Value: TColor);\r\nbegin\r\n if FStartColor <> Value then\r\n begin\r\n FStartColor := Value;\r\n if Active then\r\n Update;\r\n end;\r\nend;\r\n\r\nprocedure TJvGradientCaption.SetEndColor(Value: TColor);\r\nbegin\r\n if FEndColor <> Value then\r\n begin\r\n FEndColor := Value;\r\n if Active then\r\n Update;\r\n end;\r\nend;\r\n\r\n\r\nfunction TJvGradientCaption.GetActive: Boolean;\r\nbegin\r\n Result := FActive;\r\n if not (csDesigning in ComponentState) then\r\n Result := Result and (Owner is TCustomForm);\r\nend;\r\n\r\nprocedure TJvGradientCaption.SetActive(Value: Boolean);\r\nbegin\r\n if FActive <> Value then\r\n begin\r\n FActive := Value;\r\n FClicked := False;\r\n Update;\r\n if [csDestroying, csReading] * ComponentState = [] then\r\n begin\r\n if FActive then\r\n begin\r\n if Assigned(FOnActivate) then\r\n FOnActivate(Self);\r\n end\r\n else\r\n begin\r\n if Assigned(FOnDeactivate) then\r\n FOnDeactivate(Self);\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvGradientCaption.Clear;\r\nbegin\r\n if FCaptions <> nil then\r\n FCaptions.Clear;\r\nend;\r\n\r\nprocedure TJvGradientCaption.MoveCaption(FromIndex, ToIndex: Integer);\r\nbegin\r\n Captions[FromIndex].Index := ToIndex;\r\nend;\r\n\r\nprocedure TJvGradientCaption.Update;\r\nvar\r\n Rgn: HRGN;\r\nbegin\r\n if not (csDesigning in ComponentState) and (Owner is TCustomForm) and\r\n not (csLoading in ComponentState) then\r\n begin\r\n CheckToggleHook;\r\n FWindowActive := False;\r\n if (Form <> nil) and Form.HandleAllocated and Form.Visible then\r\n begin\r\n if Active then\r\n FWindowActive := (GetActiveWindow = Form.Handle) and IsForegroundTask;\r\n with Form do\r\n Rgn := CreateRectRgn(Left, Top, Left + Width, Top + Height);\r\n try\r\n SendMessage(Form.Handle, WM_NCPAINT, Rgn, 0);\r\n finally\r\n DeleteObject(Rgn);\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvGradientCaption.CalculateGradientParams(var R: TRect;\r\n var Icons: TBorderIcons);\r\nvar\r\n I: TBorderIcon;\r\n J: Integer;\r\n BtnCount: Integer;\r\n CaptionButton: TJvCaptionButton;\r\nbegin\r\n GetWindowRect(Form.Handle, R);\r\n Icons := Form.BorderIcons;\r\n case Form.BorderStyle of\r\n bsDialog: Icons := Icons * [biSystemMenu, biHelp];\r\n bsToolWindow, bsSizeToolWin: Icons := Icons * [biSystemMenu];\r\n else\r\n begin\r\n if not (biSystemMenu in Icons) then\r\n Icons := Icons - [biMaximize, biMinimize];\r\n if Icons * [biMaximize, biMinimize] <> [] then\r\n Icons := Icons - [biHelp];\r\n end;\r\n end;\r\n BtnCount := 0;\r\n for I := Low(TBorderIcon) to High(TBorderIcon) do\r\n if I in Icons then\r\n Inc(BtnCount);\r\n if (biMinimize in Icons) and not (biMaximize in Icons) then\r\n Inc(BtnCount)\r\n else\r\n if not (biMinimize in Icons) and (biMaximize in Icons) then\r\n Inc(BtnCount);\r\n case Form.BorderStyle of\r\n bsToolWindow, bsSingle, bsDialog:\r\n InflateRect(R, -GetSystemMetrics(SM_CXFIXEDFRAME),\r\n -GetSystemMetrics(SM_CYFIXEDFRAME));\r\n bsSizeable, bsSizeToolWin:\r\n InflateRect(R, -GetSystemMetrics(SM_CXSIZEFRAME),\r\n -GetSystemMetrics(SM_CYSIZEFRAME));\r\n end;\r\n if Form.BorderStyle in [bsToolWindow, bsSizeToolWin] then\r\n begin\r\n R.Bottom := R.Top + GetSystemMetrics(SM_CYSMCAPTION) - 1;\r\n Dec(R.Right, BtnCount * GetSystemMetrics(SM_CXSMSIZE));\r\n end\r\n else\r\n begin\r\n R.Bottom := R.Top + GetSystemMetrics(SM_CYCAPTION) - 1;\r\n Dec(R.Right, BtnCount * GetSystemMetrics(SM_CXSIZE));\r\n end;\r\n\r\n // Mantis 3857: take JvCaptionButtons into account\r\n for J := 0 to Form.ComponentCount - 1 do\r\n begin\r\n if Form.Components[J] is TJvCaptionButton then\r\n begin\r\n CaptionButton := Form.Components[J] as TJvCaptionButton;\r\n if CaptionButton.Visible then\r\n begin\r\n if CaptionButton.ButtonWidth = 0 then\r\n Dec(R.Right, CaptionButton.DefaultButtonWidth)\r\n else\r\n Dec(R.Right, CaptionButton.ButtonWidth);\r\n Dec(R.Right, CaptionButton.Spacing);\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJvGradientCaption.IsRightToLeft: Boolean;\r\nvar\r\n F: TForm;\r\nbegin\r\n F := Form;\r\n if F <> nil then\r\n Result := F.IsRightToLeft\r\n else\r\n Result := Application.IsRightToLeft;\r\nend;\r\n\r\nprocedure TJvGradientCaption.DrawGradientCaption(DC: HDC);\r\nvar\r\n R, DrawRect: TRect;\r\n Icons: TBorderIcons;\r\n Ico: HIcon;\r\n Image: TBitmap;\r\n S: string;\r\n IconCreated, DrawNext: Boolean;\r\n I, J, SumWidth: Integer;\r\n\r\n procedure SetCaptionFont(Index: Integer);\r\n begin\r\n if (Index < 0) or Captions[Index].ParentFont then\r\n Image.Canvas.Font.Assign(Self.Font)\r\n else\r\n Image.Canvas.Font.Assign(Captions[Index].Font);\r\n if not FWindowActive then\r\n begin\r\n if Index < 0 then\r\n Image.Canvas.Font.Color := FFontInactiveColor\r\n else\r\n Image.Canvas.Font.Color := Captions[Index].InactiveColor;\r\n end;\r\n end;\r\n\r\n function DrawStr(GluePrev, GlueNext: Boolean; PrevIndex: Integer): Boolean;\r\n const\r\n Points = '...';\r\n var\r\n Text: string;\r\n Flags: Longint;\r\n begin\r\n if Length(S) > 0 then\r\n begin\r\n Text := MinimizeText(S, Image.Canvas, R.Right - R.Left);\r\n if GlueNext and (Text = S) then\r\n begin\r\n if Image.Canvas.TextWidth(Text + '.') >= R.Right - R.Left then\r\n begin\r\n if GluePrev then\r\n Text := Points\r\n else\r\n Text := Text + Points;\r\n end;\r\n end;\r\n if (Text <> Points) or GluePrev then\r\n begin\r\n if (Text = Points) and GluePrev then\r\n begin\r\n SetCaptionFont(-1);\r\n if PrevIndex > 0 then\r\n begin\r\n if FWindowActive then\r\n Image.Canvas.Font.Color := Captions[PrevIndex].Font.Color\r\n else\r\n Image.Canvas.Font.Color := Captions[PrevIndex].InactiveColor;\r\n end;\r\n end;\r\n Flags := DT_VCENTER or DT_SINGLELINE or DT_NOPREFIX;\r\n if IsRightToLeft then\r\n Flags := Flags or DT_RIGHT or DT_RTLREADING\r\n else\r\n Flags := Flags or DT_LEFT;\r\n DrawText(Image.Canvas, Text, -1, R, Flags);\r\n if IsRightToLeft then\r\n Dec(R.Right, Image.Canvas.TextWidth(Text))\r\n else\r\n Inc(R.Left, Image.Canvas.TextWidth(Text));\r\n end;\r\n Result := (Text = S);\r\n end\r\n else\r\n Result := True;\r\n end;\r\n\r\nbegin\r\n if Form.BorderStyle = bsNone then\r\n Exit;\r\n Image := TBitmap.Create;\r\n try\r\n CalculateGradientParams(R, Icons);\r\n GetWindowRect(Form.Handle, DrawRect);\r\n OffsetRect(R, -DrawRect.Left, -DrawRect.Top);\r\n DrawRect := R;\r\n Image.Width := RectWidth(R);\r\n Image.Height := RectHeight(R);\r\n R := Rect(-Image.Width div 4, 0, Image.Width, Image.Height);\r\n if (FWindowActive and GradientActive) or\r\n (not FWindowActive and GradientInactive) then\r\n begin\r\n GradientFillRect(Image.Canvas, R, FStartColor, FEndColor, FFillDirection, FGradientSteps);\r\n end\r\n else\r\n begin\r\n Image.Canvas.Brush.Color := FEndColor;\r\n Image.Canvas.FillRect(R);\r\n end;\r\n R.Left := 0;\r\n if (biSystemMenu in Icons) and (Form.BorderStyle in [bsSizeable, bsSingle]) then\r\n begin\r\n IconCreated := False;\r\n if Form.Icon.Handle <> 0 then\r\n Ico := Form.Icon.Handle\r\n else\r\n if Application.Icon.Handle <> 0 then\r\n begin\r\n Ico := LoadImage(HInstance, 'MAINICON', IMAGE_ICON,\r\n GetSystemMetrics(SM_CXSMICON), GetSystemMetrics(SM_CYSMICON), 0);\r\n IconCreated := Ico <> 0;\r\n if not IconCreated then\r\n Ico := Application.Icon.Handle;\r\n end\r\n else\r\n Ico := LoadIcon(0, IDI_APPLICATION);\r\n DrawIconEx(Image.Canvas.Handle, R.Left + 1 + (R.Bottom + R.Top -\r\n GetSystemMetrics(SM_CXSMICON)) div 2, (R.Bottom + R.Top -\r\n GetSystemMetrics(SM_CYSMICON)) div 2, Ico,\r\n GetSystemMetrics(SM_CXSMICON), GetSystemMetrics(SM_CYSMICON),\r\n 0, 0, DI_NORMAL);\r\n if IconCreated then\r\n DestroyIcon(Ico);\r\n Inc(R.Left, R.Bottom - R.Top);\r\n end;\r\n if (FFormCaption <> '') or ((Captions <> nil) and (Captions.Count > 0)) then\r\n begin\r\n SumWidth := 2;\r\n SetBkMode(Image.Canvas.Handle, TRANSPARENT);\r\n Inc(R.Left, 2);\r\n if FHideDirection = hdLeftToRight then\r\n begin\r\n for I := 0 to Captions.Count - 1 do\r\n if Captions[I].Visible then\r\n SumWidth := SumWidth + Captions[I].TextWidth;\r\n SumWidth := SumWidth + TextWidth;\r\n J := 0;\r\n while (SumWidth > (R.Right - R.Left)) and (J < Captions.Count) do\r\n begin\r\n SumWidth := SumWidth - Captions[J].TextWidth;\r\n while (J < Captions.Count - 1) and Captions[J].GlueNext do\r\n begin\r\n SumWidth := SumWidth - Captions[J + 1].TextWidth;\r\n Inc(J);\r\n end;\r\n Inc(J);\r\n end;\r\n for I := J to Captions.Count do\r\n begin\r\n if I < Captions.Count then\r\n begin\r\n if Captions[I].Visible then\r\n begin\r\n S := Captions[I].Caption;\r\n SetCaptionFont(I);\r\n end\r\n else\r\n S := '';\r\n end\r\n else\r\n begin\r\n S := FFormCaption;\r\n SetCaptionFont(-1);\r\n end;\r\n DrawStr(I = Captions.Count, False, -1);\r\n end;\r\n end\r\n else\r\n begin\r\n DrawNext := True;\r\n J := 0;\r\n if Captions <> nil then\r\n begin\r\n while (SumWidth < (R.Right - R.Left)) and (J < Captions.Count) do\r\n begin\r\n if Captions[J].Visible then\r\n begin\r\n SumWidth := SumWidth + Captions[J].TextWidth;\r\n while Captions[J].GlueNext and (J < Captions.Count - 1) do\r\n begin\r\n SumWidth := SumWidth + Captions[J + 1].TextWidth;\r\n Inc(J);\r\n end;\r\n end;\r\n Inc(J);\r\n end;\r\n for I := 0 to J - 1 do\r\n begin\r\n if Captions[I].Visible and DrawNext then\r\n begin\r\n S := Captions[I].Caption;\r\n if S <> '' then\r\n begin\r\n SetCaptionFont(I);\r\n DrawNext := DrawStr(((I > 0) and Captions[I - 1].GlueNext) or\r\n (I = 0), Captions[I].GlueNext, I - 1) and\r\n (Captions[I].GlueNext or (R.Right > R.Left));\r\n end;\r\n end;\r\n end;\r\n end;\r\n if (R.Right > R.Left) and DrawNext and (FFormCaption <> '') then\r\n begin\r\n S := FFormCaption;\r\n SetCaptionFont(-1);\r\n DrawStr(False, False, -1);\r\n end;\r\n end;\r\n end;\r\n BitBlt(DC, DrawRect.Left, DrawRect.Top, Image.Width, Image.Height,\r\n Image.Canvas.Handle, 0, 0, SRCCOPY);\r\n finally\r\n Image.Free;\r\n end;\r\nend;\r\n\r\nprocedure TJvGradientCaption.SetFont(Value: TFont);\r\nbegin\r\n FFont.Assign(Value);\r\nend;\r\n\r\nprocedure TJvGradientCaption.FontChanged(Sender: TObject);\r\nvar\r\n I: Integer;\r\nbegin\r\n FDefaultFont := False;\r\n if Captions <> nil then\r\n begin\r\n Captions.BeginUpdate;\r\n try\r\n for I := 0 to Captions.Count - 1 do\r\n if Captions[I].ParentFont then\r\n Captions[I].SetParentFont(True);\r\n finally\r\n Captions.EndUpdate;\r\n end;\r\n end\r\n else\r\n if Active then\r\n Update;\r\nend;\r\n\r\nfunction TJvGradientCaption.GetTextWidth: Integer;\r\nbegin\r\n Result := InternalGetTextWidth(Font, FormCaption);\r\nend;\r\n\r\nprocedure TJvGradientCaption.SetGradientSteps(Value: Integer);\r\nbegin\r\n if FGradientSteps <> Value then\r\n begin\r\n FGradientSteps := Value mod 256; // auto resets to 0 at 256\r\n if Active and ((FWindowActive and GradientActive) or\r\n (not FWindowActive and GradientInactive)) then\r\n Update;\r\n end;\r\nend;\r\n\r\nprocedure TJvGradientCaption.SetGradientActive(Value: Boolean);\r\nbegin\r\n if FGradientActive <> Value then\r\n begin\r\n FGradientActive := Value;\r\n if Active and FWindowActive then\r\n Update;\r\n end;\r\nend;\r\n\r\nprocedure TJvGradientCaption.SetGradientInactive(Value: Boolean);\r\nbegin\r\n if FGradientInactive <> Value then\r\n begin\r\n FGradientInactive := Value;\r\n if Active and not FWindowActive then\r\n Update;\r\n end;\r\nend;\r\n\r\nprocedure TJvGradientCaption.SetFontInactiveColor(Value: TColor);\r\nbegin\r\n if FFontInactiveColor <> Value then\r\n begin\r\n FFontInactiveColor := Value;\r\n if Active and not FWindowActive then\r\n Update;\r\n end;\r\nend;\r\n\r\nprocedure TJvGradientCaption.SetHideDirection(Value: THideDirection);\r\nbegin\r\n if FHideDirection <> Value then\r\n begin\r\n FHideDirection := Value;\r\n if Active then\r\n Update;\r\n end;\r\nend;\r\n\r\nprocedure TJvGradientCaption.SetFillDirection(Value: TFillDirection);\r\nbegin\r\n if FFillDirection <> Value then\r\n begin\r\n FFillDirection := Value;\r\n if Active then\r\n Update;\r\n end;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\n\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvGradientHeaderPanel.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvGradientCaption.PAS, released on 2001-02-28.\r\n\r\nThe Initial Developer of the Original Code is Sbastien Buysse [sbuysse att buypin dott com]\r\nPortions created by Sbastien Buysse are Copyright (C) 2001 Sbastien Buysse.\r\nAll Rights Reserved.\r\n\r\nContributor(s): Michael Beck [mbeck att bigfoot dott com].\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvGradientHeaderPanel.pas 13104 2011-09-07 06:50:43Z obones $\r\n\r\nunit JvGradientHeaderPanel;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n SysUtils, Classes,\r\n Windows, Messages, Graphics, Controls, StdCtrls,\r\n JvGradient, JvTypes, JvComponent;\r\n\r\ntype\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvGradientHeaderPanel = class(TJvCustomControl)\r\n private\r\n FGradient: TJvGradient;\r\n FLabel: TLabel;\r\n FLabelLeft: Integer;\r\n FHint: Boolean;\r\n FOldLabelFontChange: TNotifyEvent;\r\n function GetGradientCursor: TCursor;\r\n procedure SetGradientCursor(Value: TCursor);\r\n function GetGradientHint: string;\r\n procedure SetGradientHint(const Value: string);\r\n function GetGradientStartColor: TColor;\r\n procedure SetGradientStartColor(Value: TColor);\r\n function GetGradientEndColor: TColor;\r\n procedure SetGradientEndColor(Value: TColor);\r\n function GetGradientSteps: Integer;\r\n procedure SetGradientSteps(Value: Integer);\r\n function GetLabelLeft: Integer;\r\n procedure SetLabelLeft(Value: Integer);\r\n function GetLabelTop: Integer;\r\n procedure SetLabelTop(Value: Integer);\r\n function GetLabelCursor: TCursor;\r\n procedure SetLabelCursor(Value: TCursor);\r\n function GetLabelHint: string;\r\n procedure SetLabelHint(const Value: string);\r\n function GetLabelCaption: string;\r\n procedure SetLabelCaption(const Value: string);\r\n function GetLabelColor: TColor;\r\n procedure SetLabelColor(Value: TColor);\r\n procedure SetShowHint(const Value: Boolean);\r\n function GetLabelFont: TFont;\r\n procedure SetLabelFont(const Value: TFont);\r\n function GetGradientStyle: TJvGradientStyle;\r\n procedure SetGradientStyle(const Value: TJvGradientStyle);\r\n function GetLabelAlignment: TAlignment;\r\n procedure SetLabelAlignment(const Value: TAlignment);\r\n procedure AdjustLabelWidth;\r\n procedure WMSize(var Msg: TWMSize); message WM_SIZE;\r\n protected\r\n// function DoEraseBackground(Canvas: TCanvas; Param: LPARAM): Boolean; override;\r\n procedure DoLabelFontChange(Sender: TObject);\r\n procedure MouseDown(Button: TMouseButton; Shift: TShiftState;\r\n X, Y: Integer); override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n published\r\n property GradientCursor: TCursor read GetGradientCursor write SetGradientCursor default crDefault;\r\n property GradientHint: string read GetGradientHint write SetGradientHint;\r\n property GradientStartColor: TColor read GetGradientStartColor write SetGradientStartColor default clBlack;\r\n property GradientEndColor: TColor read GetGradientEndColor write SetGradientEndColor default clWhite;\r\n property GradientSteps: Integer read GetGradientSteps write SetGradientSteps default 100;\r\n property GradientStyle: TJvGradientStyle read GetGradientStyle write SetGradientStyle;\r\n property LabelLeft: Integer read GetLabelLeft write SetLabelLeft default 10;\r\n property LabelTop: Integer read GetLabelTop write SetLabelTop default 8;\r\n property LabelCursor: TCursor read GetLabelCursor write SetLabelCursor default crDefault;\r\n property LabelHint: string read GetLabelHint write SetLabelHint;\r\n property LabelCaption: string read GetLabelCaption write SetLabelCaption;\r\n // LabelColor sets the background Color of the label (used for text in the control).\r\n // To get a transparent text background, set LabelColor to clNone\r\n property LabelColor: TColor read GetLabelColor write SetLabelColor default clNone;\r\n property LabelFont: TFont read GetLabelFont write SetLabelFont;\r\n property ShowHint: Boolean read FHint write SetShowHint default False;\r\n property LabelAlignment: TAlignment read GetLabelAlignment write SetLabelAlignment;\r\n property Align;\r\n property Anchors;\r\n property AutoSize;\r\n property BevelEdges;\r\n property BevelInner;\r\n property BevelKind;\r\n property BevelOuter;\r\n property BevelWidth;\r\n property BorderWidth;\r\n property Constraints;\r\n property DockSite;\r\n property DoubleBuffered;\r\n property DragMode;\r\n property Enabled;\r\n property Font;\r\n property ParentShowHint;\r\n property PopupMenu;\r\n property TabOrder;\r\n property TabStop;\r\n property Visible;\r\n property OnCanResize;\r\n property OnDockDrop;\r\n property OnDockOver;\r\n property OnGetSiteInfo;\r\n property OnUnDock;\r\n property OnClick;\r\n property OnConstrainedResize;\r\n property OnContextPopup;\r\n property OnDblClick;\r\n property OnDragDrop;\r\n property OnDragOver;\r\n property OnEndDrag;\r\n property OnEnter;\r\n property OnExit;\r\n property OnKeyDown;\r\n property OnKeyPress;\r\n property OnKeyUp;\r\n property OnMouseDown;\r\n property OnMouseMove;\r\n property OnMouseUp;\r\n property OnMouseWheel;\r\n property OnMouseWheelDown;\r\n property OnMouseWheelUp;\r\n property OnResize;\r\n property OnStartDrag;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvGradientHeaderPanel.pas $';\r\n Revision: '$Revision: 13104 $';\r\n Date: '$Date: 2011-09-07 08:50:43 +0200 (mer. 07 sept. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n JvResources;\r\n\r\ntype\r\n TNoEventLabel = class(TLabel)\r\n public\r\n procedure Dispatch(var Message); override;\r\n end;\r\n\r\n TNoEventGradient = class(TJvGradient)\r\n public\r\n procedure Dispatch(var Message); override;\r\n end;\r\n\r\nconstructor TJvGradientHeaderPanel.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n ControlStyle := ControlStyle + [csOpaque, csAcceptsControls];\r\n Self.Width := 285;\r\n Self.Height := 30;\r\n FGradient := TNoEventGradient.Create(Self);\r\n FGradient.Parent := Self;\r\n FLabel := TNoEventLabel.Create(Self);\r\n FLabel.AutoSize := False;\r\n FLabel.Parent := Self;\r\n FGradient.Left := 0;\r\n FGradient.Top := 0;\r\n FGradient.StartColor := clBlack;\r\n FGradient.EndColor := clWhite;\r\n FGradient.Steps := 100;\r\n LabelLeft := 10;\r\n FLabel.Top := 8;\r\n LabelColor := clNone;\r\n FOldLabelFontChange := FLabel.Font.OnChange;\r\n FLabel.Font.OnChange := DoLabelFontChange;\r\n FLabel.Font.Color := clWhite;\r\n FLabel.Caption := RsYourTextHereCaption;\r\n FHint := False;\r\nend;\r\n\r\ndestructor TJvGradientHeaderPanel.Destroy;\r\nbegin\r\n FGradient.Free;\r\n // FLabel.OnChange := FOldLabelFontChange;\r\n FLabel.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJvGradientHeaderPanel.GetGradientCursor: TCursor;\r\nbegin\r\n Result := FGradient.Cursor;\r\nend;\r\n\r\nprocedure TJvGradientHeaderPanel.SetGradientCursor(Value: TCursor);\r\nbegin\r\n FGradient.Cursor := Value;\r\nend;\r\n\r\nfunction TJvGradientHeaderPanel.GetGradientHint: string;\r\nbegin\r\n Result := FGradient.Hint;\r\nend;\r\n\r\nprocedure TJvGradientHeaderPanel.SetGradientHint(const Value: string);\r\nbegin\r\n FGradient.Hint := Value;\r\nend;\r\n\r\nfunction TJvGradientHeaderPanel.GetGradientStartColor: TColor;\r\nbegin\r\n Result := FGradient.StartColor;\r\nend;\r\n\r\nprocedure TJvGradientHeaderPanel.SetGradientStartColor(Value: TColor);\r\nbegin\r\n FGradient.StartColor := Value;\r\nend;\r\n\r\nfunction TJvGradientHeaderPanel.GetGradientEndColor: TColor;\r\nbegin\r\n Result := FGradient.EndColor;\r\nend;\r\n\r\nprocedure TJvGradientHeaderPanel.SetGradientEndColor(Value: TColor);\r\nbegin\r\n FGradient.EndColor := Value;\r\nend;\r\n\r\nfunction TJvGradientHeaderPanel.GetGradientSteps: Integer;\r\nbegin\r\n Result := FGradient.Steps;\r\nend;\r\n\r\nprocedure TJvGradientHeaderPanel.SetGradientSteps(Value: Integer);\r\nbegin\r\n FGradient.Steps := Value;\r\nend;\r\n\r\nfunction TJvGradientHeaderPanel.GetLabelLeft: Integer;\r\nbegin\r\n Result := FLabelLeft;\r\nend;\r\n\r\nprocedure TJvGradientHeaderPanel.SetLabelLeft(Value: Integer);\r\nbegin\r\n if FLabel.Left <> Value then\r\n begin\r\n if Value < 0 then\r\n Value := 0;\r\n FLabel.Left := Value;\r\n FLabelLeft := Value;\r\n AdjustLabelWidth;\r\n end;\r\nend;\r\n\r\nfunction TJvGradientHeaderPanel.GetLabelTop: Integer;\r\nbegin\r\n Result := FLabel.Top;\r\nend;\r\n\r\nprocedure TJvGradientHeaderPanel.SetLabelTop(Value: Integer);\r\nbegin\r\n if Value < 0 then\r\n Value := 0;\r\n FLabel.Top := Value;\r\nend;\r\n\r\nfunction TJvGradientHeaderPanel.GetLabelCursor: TCursor;\r\nbegin\r\n Result := FLabel.Cursor;\r\nend;\r\n\r\nprocedure TJvGradientHeaderPanel.SetLabelCursor(Value: TCursor);\r\nbegin\r\n FLabel.Cursor := Value;\r\nend;\r\n\r\nfunction TJvGradientHeaderPanel.GetLabelHint: string;\r\nbegin\r\n Result := FLabel.Hint;\r\nend;\r\n\r\nprocedure TJvGradientHeaderPanel.SetLabelHint(const Value: string);\r\nbegin\r\n FLabel.Hint := Value;\r\nend;\r\n\r\nfunction TJvGradientHeaderPanel.GetLabelCaption: string;\r\nbegin\r\n Result := FLabel.Caption;\r\nend;\r\n\r\nprocedure TJvGradientHeaderPanel.SetLabelCaption(const Value: string);\r\nbegin\r\n FLabel.Caption := Value;\r\n AdjustLabelWidth;\r\nend;\r\n\r\nfunction TJvGradientHeaderPanel.GetLabelColor: TColor;\r\nbegin\r\n Result := FLabel.Color;\r\nend;\r\n\r\nprocedure TJvGradientHeaderPanel.SetLabelColor(Value: TColor);\r\nbegin\r\n FLabel.Color := Value;\r\n FLabel.Transparent := (Value = clNone);\r\nend;\r\n\r\nprocedure TJvGradientHeaderPanel.SetShowHint(const Value: Boolean);\r\nbegin\r\n FHint := Value;\r\n FLabel.ShowHint := Value;\r\n FGradient.ShowHint := Value;\r\nend;\r\n\r\nfunction TJvGradientHeaderPanel.GetLabelFont: TFont;\r\nbegin\r\n Result := FLabel.Font;\r\nend;\r\n\r\nprocedure TJvGradientHeaderPanel.SetLabelFont(const Value: TFont);\r\nbegin\r\n FLabel.Font := Value;\r\n AdjustLabelWidth;\r\nend;\r\n\r\nfunction TJvGradientHeaderPanel.GetGradientStyle: TJvGradientStyle;\r\nbegin\r\n Result := FGradient.Style;\r\nend;\r\n\r\nprocedure TJvGradientHeaderPanel.SetGradientStyle(const Value: TJvGradientStyle);\r\nbegin\r\n FGradient.Style := Value;\r\nend;\r\n\r\nfunction TJvGradientHeaderPanel.GetLabelAlignment: TAlignment;\r\nbegin\r\n Result := FLabel.Alignment;\r\nend;\r\n\r\nprocedure TJvGradientHeaderPanel.SetLabelAlignment(const Value: TAlignment);\r\nbegin\r\n FLabel.Alignment := Value;\r\n AdjustLabelWidth;\r\nend;\r\n\r\n\r\n\r\n\r\nprocedure TJvGradientHeaderPanel.WMSize(var Msg: TWMSize);\r\nbegin\r\n inherited;\r\n AdjustLabelWidth;\r\nend;\r\n\r\n\r\nprocedure TJvGradientHeaderPanel.AdjustLabelWidth;\r\nvar\r\n W, L: Integer;\r\nbegin\r\n L := FLabel.Left;\r\n // make as large as we need:\r\n FLabel.AutoSize := True;\r\n FLabel.AutoSize := False;\r\n FLabel.Left := L;\r\n W := FGradient.Width - FLabelLeft - FLabelLeft;\r\n // make bigger if there's room\r\n if W > FLabel.Width then\r\n begin\r\n FLabel.Width := W;\r\n FLabel.Left := FLabelLeft;\r\n end\r\n else\r\n if W < FLabel.Width then // otherwise, just center\r\n begin\r\n FLabel.Left := (Width - FLabel.Width) div 2;\r\n // if (FLabelLeft > FLabel.Left) and then\r\n // FLabelLeft := FLabel.Left;\r\n end;\r\nend;\r\n\r\nprocedure TJvGradientHeaderPanel.DoLabelFontChange(Sender: TObject);\r\nbegin\r\n if Assigned(FOldLabelFontChange) then\r\n FOldLabelFontChange(Sender);\r\n AdjustLabelWidth;\r\nend;\r\n\r\nprocedure TJvGradientHeaderPanel.MouseDown(Button: TMouseButton;\r\n Shift: TShiftState; X, Y: Integer);\r\nbegin\r\n inherited MouseDown(Button, Shift, X, Y);\r\n if CanFocus then\r\n SetFocus;\r\nend;\r\n\r\n(*\r\nfunction TJvGradientHeaderPanel.DoEraseBackground(Canvas: TCanvas; Param: LPARAM): Boolean;\r\nbegin\r\n { Reduce flickering FGradient completely fills the TJvGradientHeaderPanel }\r\n Result := True;\r\nend;\r\n*)\r\n\r\n//=== { TNoEventLabel } ======================================================\r\n\r\n\r\n\r\n\r\nprocedure TNoEventLabel.Dispatch(var Message);\r\nbegin\r\n with TMessage(Message) do\r\n if (Parent <> nil) and\r\n (((Msg >= WM_MOUSEFIRST) and (Msg <= WM_MOUSELAST)) or\r\n ((Msg >= WM_KEYFIRST) and (Msg <= WM_KEYLAST))) then\r\n Parent.Dispatch(Message)\r\n else\r\n inherited Dispatch(Message);\r\nend;\r\n\r\n\r\n//=== { TNoEventGradient } ===================================================\r\n\r\n\r\n\r\n\r\nprocedure TNoEventGradient.Dispatch(var Message);\r\nbegin\r\n with TMessage(Message) do\r\n if (Parent <> nil) and\r\n (((Msg >= WM_MOUSEFIRST) and (Msg <= WM_MOUSELAST)) or\r\n ((Msg >= WM_KEYFIRST) and (Msg <= WM_KEYLAST))) then\r\n Parent.Dispatch(Message)\r\n else\r\n inherited Dispatch(Message);\r\nend;\r\n\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvGridFilter.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvGridFilter.PAS, released on 2002-06-15.\r\n\r\nThe Initial Developer of the Original Code is Jan Verhoeven [jan1 dott verhoeven att wxs dott nl]\r\nPortions created by Jan Verhoeven are Copyright (C) 2002 Jan Verhoeven.\r\nAll Rights Reserved.\r\n\r\nContributor(s): Robert Love [rlove att slcdug dott org].\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n When Position 0 you can not click on the far left of the button to move.\r\n When Position 100 you can not click on the far right of the button to move.\r\n\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvGridFilter.pas 13104 2011-09-07 06:50:43Z obones $\r\n\r\nunit JvGridFilter;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, Messages, Graphics, Controls, Forms, Grids,\r\n SysUtils, Classes;\r\n\r\ntype\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvGridFilter = class(TComponent)\r\n private\r\n FGrid: TStringGrid;\r\n FGridRowFilter: TList;\r\n procedure ApplyFilter;\r\n function ParseFilter(const AFilter: string): Boolean;\r\n procedure SetGrid(const Value: TStringGrid);\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n procedure Filter(const AFilter: string);\r\n procedure ShowRows;\r\n published\r\n property Grid: TStringGrid read FGrid write SetGrid;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvGridFilter.pas $';\r\n Revision: '$Revision: 13104 $';\r\n Date: '$Date: 2011-09-07 08:50:43 +0200 (mer. 07 sept. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n JvConsts;\r\n\r\ntype\r\n TGridFilterFunc = function(const FieldValue, FilterValue: string): Boolean;\r\n\r\n PGridFieldFilter = ^TGridFieldFilter;\r\n TGridFieldFilter = record\r\n FilterFunc: TGridFilterFunc;\r\n FilterField: Integer;\r\n FilterValue: string;\r\n end;\r\n\r\nfunction FilterEQ(const FieldValue, FilterValue: string): Boolean;\r\nbegin\r\n Result := FieldValue = FilterValue;\r\nend;\r\n\r\nfunction FilterNE(const FieldValue, FilterValue: string): Boolean;\r\nbegin\r\n Result := FieldValue <> FilterValue;\r\nend;\r\n\r\nfunction FilterGT(const FieldValue, FilterValue: string): Boolean;\r\nbegin\r\n Result := FieldValue > FilterValue;\r\nend;\r\n\r\nfunction FilterLT(const FieldValue, FilterValue: string): Boolean;\r\nbegin\r\n Result := FieldValue < FilterValue;\r\nend;\r\n\r\nfunction FilterLIKE(const FieldValue, FilterValue: string): Boolean;\r\nbegin\r\n Result := Pos(LowerCase(FilterValue), LowerCase(FieldValue)) > 0;\r\nend;\r\n\r\nconstructor TJvGridFilter.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FGridRowFilter := TList.Create;\r\nend;\r\n\r\ndestructor TJvGridFilter.Destroy;\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := 0 to FGridRowFilter.Count-1 do\r\n Dispose(FGridRowFilter[I]);\r\n FGridRowFilter.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJvGridFilter.ParseFilter(const AFilter: string): Boolean;\r\nvar\r\n Op, S: string;\r\n Func: TGridFilterFunc;\r\n FieldNr, I, P: Integer;\r\n FieldName, FilterValue: string;\r\n Filt: PGridFieldFilter;\r\nbegin\r\n Result := False;\r\n for I := 0 to FGridRowFilter.Count-1 do\r\n Dispose(FGridRowFilter[I]);\r\n FGridRowFilter.Clear;\r\n\r\n S := Trim(AFilter);\r\n if S = '' then\r\n Exit;\r\n {$IFNDEF CPUX64}\r\n @Func := nil;\r\n {$ENDIF ~CPUX64}\r\n // parse field name\r\n repeat\r\n P := Pos('[', S);\r\n\r\n if P = 0 then\r\n Exit;\r\n S := Copy(S, P + 1, Length(S));\r\n P := Pos(']', S);\r\n if P = 0 then\r\n Exit;\r\n FieldName := Copy(S, 1, P - 1);\r\n S := Trim(Copy(S, P + 1, Length(S)));\r\n if FieldName = '' then\r\n Exit;\r\n // find fieldnumber\r\n FieldNr := 0;\r\n for I := 1 to Grid.ColCount - 1 do\r\n if Grid.Cells[I, 0] = FieldName then\r\n begin\r\n FieldNr := I;\r\n Break;\r\n end;\r\n if FieldNr = 0 then\r\n Exit;\r\n // we have the field number, now check operand\r\n P := Pos('\"', S); // \" marks the beginning of the filter value\r\n if P = 0 then\r\n Exit;\r\n Op := LowerCase(Trim(Copy(S, 1, P - 1)));\r\n S := Copy(S, P + 1, Length(S));\r\n P := Pos('\"', S); // find the end of the FilterValue\r\n if P = 0 then\r\n Exit;\r\n FilterValue := Copy(S, 1, P - 1);\r\n S := Trim(Copy(S, P + 1, Length(S)));\r\n// Func := nil;\r\n if Op = '=' then\r\n Func := FilterEQ\r\n else\r\n if Op = '<>' then\r\n Func := FilterNE\r\n else\r\n if Op = '>' then\r\n Func := FilterGT\r\n else\r\n if Op = '<' then\r\n Func := FilterLT\r\n else\r\n if Op = 'like' then\r\n Func := FilterLIKE\r\n else\r\n Exit;\r\n\r\n New(Filt);\r\n Filt^.FilterFunc := Func;\r\n Filt^.FilterField := FieldNr;\r\n Filt^.FilterValue := FilterValue;\r\n FGridRowFilter.Add(Filt);\r\n until S = '';\r\n Result := True;\r\nend;\r\n\r\nprocedure TJvGridFilter.ApplyFilter;\r\nvar\r\n Row, I: Integer;\r\n FieldValue: string;\r\n CanHide: Boolean;\r\n Filt: PGridFieldFilter;\r\nbegin\r\n if FGridRowFilter.Count = 0 then\r\n Exit;\r\n for Row := 1 to Grid.RowCount - 1 do\r\n begin\r\n CanHide := False;\r\n for I := 0 to FGridRowFilter.Count - 1 do\r\n begin\r\n Filt := FGridRowFilter[I];\r\n FieldValue := Grid.Cells[Filt^.FilterField, Row];\r\n if not Filt^.FilterFunc(FieldValue, Filt^.FilterValue) then\r\n begin\r\n CanHide := True;\r\n Break;\r\n end;\r\n end;\r\n if CanHide then\r\n Grid.RowHeights[Row] := 0;\r\n end;\r\nend;\r\n\r\nprocedure TJvGridFilter.Filter(const AFilter: string);\r\nbegin\r\n if Assigned(FGrid) then\r\n if ParseFilter(AFilter) then\r\n ApplyFilter;\r\nend;\r\n\r\nprocedure TJvGridFilter.SetGrid(const Value: TStringGrid);\r\nbegin\r\n FGrid := Value;\r\nend;\r\n\r\nprocedure TJvGridFilter.ShowRows;\r\nvar\r\n Row: Integer;\r\nbegin\r\n for Row := 0 to Grid.RowCount - 1 do\r\n Grid.RowHeights[Row] := Grid.DefaultRowHeight;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend." }, { "path": "External/Jedi/Jvcl/run/JvGridPreviewForm.dfm", "content": "object JvGridPreviewForm: TJvGridPreviewForm\r\n Left = 268\r\n Top = 202\r\n ClientWidth = 595\r\n ClientHeight = 356\r\n Caption = 'Preview'\r\n Color = clBtnFace\r\n Font.Charset = DEFAULT_CHARSET\r\n Font.Color = clWindowText\r\n Font.Height = -11\r\n Font.Name = 'MS Sans Serif'\r\n Font.Style = []\r\n OldCreateOrder = False\r\n Position = poScreenCenter\r\n OnCreate = FormCreate\r\n OnDestroy = FormDestroy\r\n OnShow = FormShow\r\n PixelsPerInch = 96\r\n TextHeight = 13\r\n object ScrollBox1: TScrollBox\r\n Left = 157\r\n Top = 0\r\n Width = 438\r\n Height = 362\r\n Align = alClient\r\n \r\n \r\n TabOrder = 0\r\n object PreviewImage: TImage\r\n Left = 0\r\n Top = 0\r\n Width = 85\r\n Height = 85\r\n AutoSize = True\r\n OnClick = PreviewImageClick\r\n end\r\n end\r\n object Panel1: TPanel\r\n Left = 0\r\n Top = 0\r\n Width = 157\r\n Height = 362\r\n Align = alLeft\r\n BevelOuter = bvNone\r\n TabOrder = 1\r\n object btnprint: TSpeedButton\r\n Left = 130\r\n Top = 237\r\n Width = 19\r\n Height = 18\r\n Flat = True\r\n Glyph.Data = {\r\n F6000000424DF600000000000000760000002800000010000000100000000100\r\n 04000000000080000000120B0000120B00001000000010000000000000000000\r\n 8000008000000080800080000000800080008080000080808000C0C0C0000000\r\n FF00C0C0C00000FFFF00FF000000C0C0C000FFFF0000FFFFFF00DADADADADADA\r\n DADAAD00000000000DADD0888888888080DA000000000000080D0888888BBB88\r\n 000A088888877788080D00000000000008800888888888808080D00000000008\r\n 0800AD0FFFFFFFF08080DAD0F00000F0000AADA0FFFFFFFF0DADDADA0F00000F\r\n 0ADAADAD0FFFFFFFF0ADDADAD000000000DAADADADADADADADAD}\r\n OnClick = btnprintClick\r\n end\r\n object btnshow: TSpeedButton\r\n Left = 65\r\n Top = 237\r\n Width = 19\r\n Height = 18\r\n Flat = True\r\n Glyph.Data = {\r\n F6000000424DF600000000000000760000002800000010000000100000000100\r\n 0400000000008000000000000000000000001000000000000000000000000000\r\n 8000008000000080800080000000800080008080000080808000C0C0C0000000\r\n FF0000FF000000FFFF00FF000000FF00FF00FFFF0000FFFFFF00888888888888\r\n 888800000000000088000FFFFFFFFFF080000FFFFFFF000070080FFFFFF07887\r\n 07880FFFFF0788E770880FFFFF08888780880FFFFF08E88780880FFFFF07EE87\r\n 70880FFFFFF0788708880FFFFFFF000088880FFFFFFFFFF088880FFFFFFF0000\r\n 88880FFFFFFF080888880FFFFFFF008888880000000008888888}\r\n OnClick = btnshowClick\r\n end\r\n object lblpages: TLabel\r\n Left = 69\r\n Top = 265\r\n Width = 39\r\n Height = 13\r\n Caption = 'lblpages'\r\n end\r\n object btnsetup: TSpeedButton\r\n Left = 111\r\n Top = 237\r\n Width = 18\r\n Height = 18\r\n Flat = True\r\n Glyph.Data = {\r\n F6000000424DF600000000000000760000002800000010000000100000000100\r\n 04000000000080000000120B0000120B00001000000010000000000000000000\r\n 80000080000000808000800000008000800080800000C0C0C000808080000000\r\n FF0000FF000000FFFF00FF000000FF00FF00FFFF0000FFFFFF00777777777777\r\n 777777000000000007777077777777707077000000000000070707777777BBB7\r\n 700707777777886EEE070000000000E607800E6EEEEEEEE070707000000000E6\r\n 0700770FFFFFFF6EEE707770F000008000077770FFFFFFFF077777770F00000F\r\n 077777770FFFFFFFF07777777000000000777777777777777777}\r\n OnClick = btnsetupClick\r\n end\r\n object btnfull: TSpeedButton\r\n Left = 85\r\n Top = 237\r\n Width = 18\r\n Height = 18\r\n Hint = 'Full View'\r\n Flat = True\r\n Glyph.Data = {\r\n F6000000424DF600000000000000760000002800000010000000100000000100\r\n 0400000000008000000000000000000000001000000000000000000000000000\r\n 8000008000000080800080000000800080008080000080808000C0C0C0000000\r\n FF0000FF000000FFFF00FF000000FF00FF00FFFF0000FFFFFF00800000000000\r\n 008880FFFFFFFFFFF08880FFFFF4FFFFF08880FFFF444FFFF08880FFFFFFFFFF\r\n F08880FFFFFFFFFFF08880FF4FFFFF4FF08880F44FFFFF44F08880FF4FFFFF4F\r\n F08880FFFFFFFFFFF08880FFFFFFFFFFF08880FFFFFFFFFFF08880FFFF444F00\r\n 008880FFFFF4FF08088880FFFFFFFF0088888000000000088888}\r\n ParentShowHint = False\r\n ShowHint = True\r\n OnClick = btnfullClick\r\n end\r\n object btnpic: TSpeedButton\r\n Left = 130\r\n Top = 7\r\n Width = 19\r\n Height = 17\r\n Flat = True\r\n Glyph.Data = {\r\n F6000000424DF600000000000000760000002800000010000000100000000100\r\n 04000000000080000000120B0000120B00001000000010000000000000000000\r\n 8000008000000080800080000000800080008080000080808000C0C0C0000000\r\n FF00C0C0C00000FFFF00FF000000C0C0C000FFFF0000FFFFFF00DADADADADADA\r\n DADAA000000000000000D077770770770880A007707707708800D0F077777708\r\n 80F0A0BF077070880FB0D0FBF0770B00FBF0A0BFBF00BFBFBFB0D0FBFBFBFBFB\r\n FBF0A0BFBFBFBF7007B0D0FBFBFBFB0330F0A0BFBFBFBF0330B0D0FBFBFBFB70\r\n 07F0A0BFBFBFBFBFBFB0D000000000000000ADADADADADADADAD}\r\n OnClick = btnpicClick\r\n end\r\n object Header: TEdit\r\n Left = 7\r\n Top = 7\r\n Width = 117\r\n Height = 21\r\n TabOrder = 0\r\n Text = 'Header'\r\n OnChange = HeaderChange\r\n end\r\n object Headers: TListBox\r\n Left = 7\r\n Top = 31\r\n Width = 104\r\n Height = 66\r\n BorderStyle = bsNone\r\n Color = 16644814\r\n \r\n ItemHeight = 13\r\n Items.Strings = (\r\n 'HeaderText'\r\n 'FooterText'\r\n 'DateFormat'\r\n 'TimeFormat'\r\n 'Logo')\r\n \r\n TabOrder = 1\r\n OnClick = HeadersClick\r\n end\r\n object Margin: TUpDown\r\n Left = 45\r\n Top = 102\r\n Width = 15\r\n Height = 21\r\n Associate = Edit1\r\n Min = 0\r\n Max = 400\r\n Position = 0\r\n TabOrder = 2\r\n Wrap = False\r\n OnClick = MarginClick\r\n end\r\n object ckborders: TCheckBox\r\n Left = 65\r\n Top = 104\r\n Width = 66\r\n Height = 14\r\n Caption = 'Borders'\r\n Checked = True\r\n State = cbChecked\r\n TabOrder = 3\r\n OnClick = ckbordersClick\r\n end\r\n object Margins: TListBox\r\n Left = 7\r\n Top = 125\r\n Width = 104\r\n Height = 105\r\n BorderStyle = bsNone\r\n Color = 13172735\r\n \r\n ItemHeight = 13\r\n Items.Strings = (\r\n 'MarginTop'\r\n 'MarginHeader'\r\n 'MarginLeft'\r\n 'MarginRight'\r\n 'MarginBottom'\r\n 'PaddingLeft'\r\n 'HeaderSize'\r\n 'FooterSize')\r\n \r\n TabOrder = 4\r\n OnClick = MarginsClick\r\n end\r\n object PreviewPage: TUpDown\r\n Left = 45\r\n Top = 262\r\n Width = 15\r\n Height = 21\r\n Associate = Edit2\r\n Min = 1\r\n Max = 1\r\n Position = 1\r\n TabOrder = 5\r\n Wrap = False\r\n OnClick = PreviewPageClick\r\n end\r\n object cklive: TCheckBox\r\n Left = 7\r\n Top = 237\r\n Width = 52\r\n Height = 14\r\n Caption = 'Live'\r\n TabOrder = 6\r\n OnClick = ckliveClick\r\n end\r\n object Edit1: TEdit\r\n Left = 10\r\n Top = 102\r\n Width = 35\r\n Height = 21\r\n TabOrder = 7\r\n Text = '0'\r\n end\r\n object Edit2: TEdit\r\n Left = 10\r\n Top = 262\r\n Width = 35\r\n Height = 21\r\n TabOrder = 8\r\n Text = '1'\r\n end\r\n end\r\n object PrinterSetupDialog1: TPrinterSetupDialog\r\n Left = 243\r\n Top = 186\r\n end\r\n object OpenPictureDialog1: TOpenPictureDialog\r\n Filter = 'Bitmap Files|*.bmp'\r\n Left = 243\r\n Top = 146\r\n end\r\nend\r\n" }, { "path": "External/Jedi/Jvcl/run/JvGridPreviewForm.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvGridPreview.PAS, released on 2002-06-15.\r\n\r\nThe Initial Developer of the Original Code is Jan Verhoeven [jan1 dott verhoeven att wxs dott nl]\r\nPortions created by Jan Verhoeven are Copyright (C) 2002 Jan Verhoeven.\r\nAll Rights Reserved.\r\n\r\nContributor(s): Robert Love [rlove att slcdug dott org].\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvGridPreviewForm.pas 12767 2010-05-14 17:39:21Z ahuser $\r\n\r\nunit JvGridPreviewForm;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n SysUtils, Classes,\r\n Windows, Messages, Graphics, Controls, Forms, Dialogs,\r\n ExtCtrls, Grids, StdCtrls, ComCtrls, Buttons, Printers, ExtDlgs,\r\n JvGridPrinter, JvComponent;\r\n\r\ntype\r\n TJvGridPreviewForm = class(TJvForm)\r\n ScrollBox1: TScrollBox;\r\n PreviewImage: TImage;\r\n Panel1: TPanel;\r\n Header: TEdit;\r\n Headers: TListBox;\r\n Margin: TUpDown;\r\n ckborders: TCheckBox;\r\n Margins: TListBox;\r\n btnprint: TSpeedButton;\r\n PreviewPage: TUpDown;\r\n btnshow: TSpeedButton;\r\n lblpages: TLabel;\r\n cklive: TCheckBox;\r\n btnsetup: TSpeedButton;\r\n btnfull: TSpeedButton;\r\n btnpic: TSpeedButton;\r\n OpenPictureDialog1: TOpenPictureDialog;\r\n PrinterSetupDialog1: TPrinterSetupDialog;\r\n Edit1: TEdit;\r\n Edit2: TEdit;\r\n procedure btnshowClick(Sender: TObject);\r\n procedure MarginsClick(Sender: TObject);\r\n procedure btnprintClick(Sender: TObject);\r\n procedure HeaderChange(Sender: TObject);\r\n procedure FormShow(Sender: TObject);\r\n procedure ckbordersClick(Sender: TObject);\r\n procedure HeadersClick(Sender: TObject);\r\n procedure ckliveClick(Sender: TObject);\r\n procedure btnsetupClick(Sender: TObject);\r\n procedure btnfullClick(Sender: TObject);\r\n procedure FormCreate(Sender: TObject);\r\n procedure FormDestroy(Sender: TObject);\r\n procedure PreviewImageClick(Sender: TObject);\r\n procedure btnpicClick(Sender: TObject);\r\n procedure MarginClick(Sender: TObject; Button: TUDBtnType);\r\n procedure PreviewPageClick(Sender: TObject; Button: TUDBtnType);\r\n private\r\n FGridPrinter: TJvGridPrinter;\r\n FPrintImage: TBitmap;\r\n FGrid: TStringGrid;\r\n FPageCount: Cardinal;\r\n procedure SetGridPrinter(const Value: TJvGridPrinter);\r\n procedure FullSize;\r\n procedure Zoom(Factor: Extended);\r\n procedure SetGrid(const Value: TStringGrid);\r\n procedure UpdateRowHeights;\r\n function PageCount: Integer;\r\n procedure UpdatePreview(ACanvas: TCanvas);\r\n public\r\n procedure DrawToCanvas(ACanvas: TCanvas; Mode: TJvPrintMode;\r\n FromRow, ToRow: Integer);\r\n procedure Print;\r\n published\r\n property GridPrinter: TJvGridPrinter read FGridPrinter write SetGridPrinter;\r\n property Grid: TStringGrid read FGrid write SetGrid;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvGridPreviewForm.pas $';\r\n Revision: '$Revision: 12767 $';\r\n Date: '$Date: 2010-05-14 19:39:21 +0200 (ven. 14 mai 2010) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n JvPaintFX, JvConsts, JvResources;\r\n\r\n{$R *.dfm}\r\n\r\nvar\r\n RowHeights: array of Integer;\r\n\r\nprocedure TJvGridPreviewForm.SetGridPrinter(const Value: TJvGridPrinter);\r\nbegin\r\n FGridPrinter := Value;\r\nend;\r\n\r\nprocedure TJvGridPreviewForm.btnshowClick(Sender: TObject);\r\nbegin\r\n if Assigned(FGridPrinter) then\r\n begin\r\n UpdatePreview(FPrintImage.Canvas);\r\n PreviewImage.Picture.Bitmap.Assign(FPrintImage);\r\n end;\r\nend;\r\n\r\nprocedure TJvGridPreviewForm.MarginsClick(Sender: TObject);\r\nbegin\r\n case Margins.ItemIndex of\r\n -1:\r\n Exit;\r\n 0:\r\n Margin.Position := GridPrinter.PrintOptions.MarginTop;\r\n 1:\r\n Margin.Position := GridPrinter.PrintOptions.PageTitleMargin;\r\n 2:\r\n Margin.Position := GridPrinter.PrintOptions.MarginLeft;\r\n 3:\r\n Margin.Position := GridPrinter.PrintOptions.MarginRight;\r\n 4:\r\n Margin.Position := GridPrinter.PrintOptions.MarginBottom;\r\n 5:\r\n Margin.Position := GridPrinter.PrintOptions.LeftPadding;\r\n 6:\r\n Margin.Position := GridPrinter.PrintOptions.HeaderSize;\r\n 7:\r\n Margin.Position := GridPrinter.PrintOptions.FooterSize;\r\n else\r\n Exit;\r\n end;\r\n if Margins.ItemIndex > 5 then\r\n begin\r\n Margin.Min := 6;\r\n Margin.Max := 72;\r\n end\r\n else\r\n begin\r\n Margin.Min := 0;\r\n Margin.Max := 400;\r\n end;\r\nend;\r\n\r\nprocedure TJvGridPreviewForm.btnprintClick(Sender: TObject);\r\nbegin\r\n Print;\r\nend;\r\n\r\nprocedure TJvGridPreviewForm.HeaderChange(Sender: TObject);\r\nbegin\r\n case Headers.ItemIndex of\r\n -1:\r\n Exit;\r\n 0:\r\n GridPrinter.PrintOptions.PageTitle := Header.Text;\r\n 1:\r\n GridPrinter.PrintOptions.PageFooter := Header.Text;\r\n 2:\r\n GridPrinter.PrintOptions.DateFormat := Header.Text;\r\n 3:\r\n GridPrinter.PrintOptions.TimeFormat := Header.Text;\r\n 4:\r\n GridPrinter.PrintOptions.Logo := Header.Text;\r\n end;\r\n if cklive.Checked then\r\n btnshow.Click;\r\nend;\r\n\r\nprocedure TJvGridPreviewForm.FormShow(Sender: TObject);\r\nbegin\r\n UpdateRowHeights;\r\n FPageCount := 0;\r\n DrawToCanvas(FPrintImage.Canvas, pmPreview, 1, Grid.RowCount - 1);\r\n PreviewImage.Picture.Bitmap.Assign(FPrintImage);\r\n Header.Text := GridPrinter.PrintOptions.PageTitle;\r\n Margin.Position := GridPrinter.PrintOptions.MarginTop;\r\n Margins.ItemIndex := 0;\r\n PreviewPage.Max := PageCount;\r\n lblpages.Caption := Format(RsOfd, [PreviewPage.Max]);\r\n GridPrinter.PrintOptions.PreviewPage := 1;\r\n PreviewPage.Position := 1;\r\n ckborders.Checked := (GridPrinter.PrintOptions.BorderStyle = bsSingle);\r\n Header.Text := GridPrinter.PrintOptions.PageTitle;\r\n Headers.ItemIndex := 0;\r\n btnshow.Click;\r\nend;\r\n\r\nprocedure TJvGridPreviewForm.ckbordersClick(Sender: TObject);\r\nbegin\r\n if ckborders.Checked then\r\n GridPrinter.PrintOptions.BorderStyle := bsSingle\r\n else\r\n GridPrinter.PrintOptions.BorderStyle := bsNone;\r\n if cklive.Checked then\r\n btnshow.Click;\r\nend;\r\n\r\nprocedure TJvGridPreviewForm.HeadersClick(Sender: TObject);\r\nbegin\r\n case Headers.ItemIndex of\r\n 0:\r\n Header.Text := GridPrinter.PrintOptions.PageTitle;\r\n 1:\r\n Header.Text := GridPrinter.PrintOptions.PageFooter;\r\n 2:\r\n Header.Text := GridPrinter.PrintOptions.DateFormat;\r\n 3:\r\n Header.Text := GridPrinter.PrintOptions.TimeFormat;\r\n 4:\r\n Header.Text := GridPrinter.PrintOptions.Logo;\r\n end;\r\nend;\r\n\r\nprocedure TJvGridPreviewForm.ckliveClick(Sender: TObject);\r\nbegin\r\n if cklive.Checked then\r\n btnshow.Click;\r\nend;\r\n\r\nprocedure TJvGridPreviewForm.btnsetupClick(Sender: TObject);\r\nbegin\r\n if PrinterSetupDialog1.Execute then\r\n begin\r\n GridPrinter.PrintOptions.Orientation := Printer.Orientation;\r\n if cklive.Checked then\r\n btnshow.Click;\r\n end;\r\nend;\r\n\r\nprocedure TJvGridPreviewForm.FullSize;\r\nvar\r\n Bmp: TBitmap;\r\n W, H: Integer;\r\nbegin\r\n W := FPrintImage.Width;\r\n H := FPrintImage.Height;\r\n Bmp := TBitmap.Create;\r\n Bmp.Width := ScrollBox1.ClientWidth;\r\n Bmp.Height := Round(H / W * Bmp.Width);\r\n FPrintImage.PixelFormat := pf24bit;\r\n Bmp.PixelFormat := pf24bit;\r\n TJvPaintFX.SmoothResize(FPrintImage, Bmp);\r\n PreviewImage.Picture.Bitmap.Assign(Bmp);\r\n Bmp.Free;\r\nend;\r\n\r\nprocedure TJvGridPreviewForm.btnfullClick(Sender: TObject);\r\nbegin\r\n FullSize;\r\nend;\r\n\r\nprocedure TJvGridPreviewForm.FormCreate(Sender: TObject);\r\nbegin\r\n FPrintImage := TBitmap.Create;\r\nend;\r\n\r\nprocedure TJvGridPreviewForm.FormDestroy(Sender: TObject);\r\nbegin\r\n FPrintImage.Free;\r\nend;\r\n\r\nprocedure TJvGridPreviewForm.PreviewImageClick(Sender: TObject);\r\nvar\r\n W, W1: Integer;\r\nbegin\r\n W1 := PreviewImage.Picture.Bitmap.Width;\r\n W := FPrintImage.Width;\r\n if Round(W * 0.8) < W1 then\r\n PreviewImage.Picture.Bitmap.Assign(FPrintImage)\r\n else\r\n Zoom(W1 / W / 0.8);\r\nend;\r\n\r\nprocedure TJvGridPreviewForm.Zoom(Factor: Extended);\r\nvar\r\n Bmp: TBitmap;\r\n W, H: Integer;\r\nbegin\r\n W := FPrintImage.Width;\r\n H := FPrintImage.Height;\r\n Bmp := TBitmap.Create;\r\n Bmp.Width := Round(Factor * W);\r\n Bmp.Height := Round(H / W * Bmp.Width);\r\n FPrintImage.PixelFormat := pf24bit;\r\n Bmp.PixelFormat := pf24bit;\r\n TJvPaintFX.SmoothResize(FPrintImage, Bmp);\r\n PreviewImage.Picture.Bitmap.Assign(Bmp);\r\n Bmp.Free;\r\nend;\r\n\r\nprocedure TJvGridPreviewForm.btnpicClick(Sender: TObject);\r\nbegin\r\n if OpenPictureDialog1.Execute then\r\n if Headers.ItemIndex = 4 then\r\n begin\r\n Header.Text := OpenPictureDialog1.FileName;\r\n GridPrinter.PrintOptions.Logo := OpenPictureDialog1.FileName;\r\n end;\r\nend;\r\n\r\nprocedure TJvGridPreviewForm.DrawToCanvas(ACanvas: TCanvas; Mode: TJvPrintMode; FromRow, ToRow: Integer);\r\nvar\r\n PageWidth, PageHeight, PageRow, PageCol, I, IRow, FromCol, ToCol, X, Y: Integer;\r\n DoPaint, HasLogo: Boolean;\r\n HHeader, HFooter: Integer;\r\n LogoPic, LogoPics: TBitmap;\r\n\r\n function ScaleX(I: Integer): Integer;\r\n begin\r\n if Mode = pmPreview then\r\n Result := I\r\n else\r\n Result := Round(I * (GetDeviceCaps(Printer.Handle, LOGPIXELSX) / Screen.PixelsPerInch));\r\n end;\r\n\r\n function ScaleY(I: Integer): Integer;\r\n begin\r\n if Mode = pmPreview then\r\n Result := I\r\n else\r\n Result := Round(I * (GetDeviceCaps(Printer.Handle, LOGPIXELSY) / Screen.PixelsPerInch));\r\n end;\r\n\r\n procedure DrawCells(IRow: Integer);\r\n var\r\n ICol, I: Integer;\r\n R: TRect;\r\n drs: string;\r\n nr: Boolean;\r\n v: Extended;\r\n begin\r\n //Alignment must be done another day\r\n for ICol := FromCol to ToCol do\r\n begin\r\n //X Offset\r\n X := ScaleX(GridPrinter.PrintOptions.MarginLeft);\r\n for I := FromCol to ICol - 1 do\r\n Inc(X, ScaleX(Grid.ColWidths[I] + 1));\r\n //Text Rect\r\n R := Rect(X, Y, X + ScaleX(Grid.ColWidths[ICol]), Y + ScaleY(RowHeights[IRow]));\r\n //Draw on the Canvas\r\n if DoPaint then\r\n begin\r\n if GridPrinter.PrintOptions.BorderStyle = bsSingle then\r\n begin\r\n ACanvas.Brush.Style := bsClear;\r\n ACanvas.Rectangle(R.Left, R.Top, R.Right + ScaleX(2), R.Bottom + ScaleY(1));\r\n end;\r\n drs := Grid.Cells[ICol, IRow];\r\n nr := False;\r\n if (IRow < Grid.FixedRows) or (ICol < Grid.FixedCols) then\r\n ACanvas.Font.Style := ACanvas.Font.Style + [fsBold]\r\n else\r\n ACanvas.Font.Style := ACanvas.Font.Style - [fsBold];\r\n R.Left := R.Left + ScaleX(GridPrinter.PrintOptions.LeftPadding);\r\n if GridPrinter.WordWrap and (ICol <> 0) and (IRow <> 0) then\r\n begin\r\n if GridPrinter.NumbersalRight and (not nr) then\r\n try\r\n v := StrToFloat(drs);\r\n nr := True;\r\n drs := Format(GridPrinter.NumberFormat, [v]);\r\n except\r\n // do nothing\r\n end;\r\n if nr then\r\n DrawText(ACanvas.Handle, PChar(drs), -1, R, DT_WORDBREAK or DT_RIGHT)\r\n else\r\n DrawText(ACanvas.Handle, PChar(drs), -1, R, DT_WORDBREAK or DT_LEFT);\r\n end\r\n else\r\n begin\r\n if GridPrinter.NumbersalRight and (not nr) then\r\n try\r\n v := StrToFloat(drs);\r\n nr := True;\r\n drs := Format(GridPrinter.NumberFormat, [v]);\r\n except\r\n // do nothing\r\n end;\r\n if nr then\r\n DrawText(ACanvas.Handle, PChar(drs), -1, R, DT_SINGLELINE or DT_RIGHT)\r\n else\r\n DrawText(ACanvas.Handle, PChar(drs), -1, R, DT_SINGLELINE or DT_LEFT);\r\n end;\r\n end;\r\n end;\r\n Inc(Y, ScaleY(RowHeights[IRow]));\r\n end;\r\n\r\n procedure DrawTitle; //draw Header and Footer\r\n var\r\n S, fstr: string;\r\n List: TStringList;\r\n I: Integer;\r\n TmpFont: TFont; //I have no idea why you can't use gettextwidth when ACanvas = printer.Canvas, it returns wrong Value\r\n begin\r\n TmpFont := nil;\r\n if DoPaint then\r\n begin\r\n ACanvas.Font.Size := GridPrinter.PrintOptions.HeaderSize;\r\n TmpFont := Grid.Font;\r\n Grid.Canvas.Font := ACanvas.Font;\r\n end;\r\n //Title\r\n Y := ScaleY(GridPrinter.PrintOptions.MarginTop);\r\n S := GridPrinter.PrintOptions.PageTitle;\r\n HHeader := Grid.Canvas.TextHeight(S);\r\n if HasLogo then\r\n if LogoPic.Height > HHeader then\r\n HHeader := LogoPic.Height;\r\n if DoPaint then\r\n begin\r\n if HasLogo then\r\n ACanvas.Draw(ScaleX(GridPrinter.PrintOptions.MarginLeft), Y, LogoPics);\r\n ACanvas.TextOut((PageWidth div 2) - (ScaleX(Grid.Canvas.TextWidth(S) div 2)), Y, S);\r\n end;\r\n Y := Y + ScaleY(HHeader);\r\n //Page nr\r\n S := Format(RsPaged, [PageRow]);\r\n if (ToCol < Grid.ColCount - 1) or (PageCol > 1) then\r\n S := S + '-' + IntToStr(PageCol);\r\n fstr := GridPrinter.PrintOptions.PageFooter;\r\n HFooter := Grid.Canvas.TextHeight(fstr);\r\n if fstr <> '' then\r\n if DoPaint then\r\n begin\r\n ACanvas.Font.Size := GridPrinter.PrintOptions.FooterSize;\r\n Grid.Canvas.Font := ACanvas.Font;\r\n HFooter := Grid.Canvas.TextHeight(fstr);\r\n List := TStringList.Create;\r\n List.Text := StringReplace(fstr, '|', cr, [rfreplaceall]);\r\n while List.Count < 3 do\r\n List.Append('');\r\n for I := 0 to 2 do\r\n begin\r\n List[I] := StringReplace(List[I], 'date', FormatDateTime(GridPrinter.PrintOptions.DateFormat, Now), []);\r\n List[I] := StringReplace(List[I], 'time', FormatDateTime(GridPrinter.PrintOptions.TimeFormat, Now), []);\r\n List[I] := StringReplace(List[I], 'page', S, []);\r\n end;\r\n //paint Left footer\r\n if List[0] <> '' then\r\n ACanvas.TextOut(ScaleX(Integer(GridPrinter.PrintOptions.MarginLeft) + Grid.Canvas.TextWidth(List[0])),\r\n PageHeight - ScaleY(Integer(GridPrinter.PrintOptions.MarginBottom) + Grid.Canvas.TextHeight(List[0])),\r\n List[0]);\r\n //paint center footer\r\n if List[1] <> '' then\r\n ACanvas.TextOut((PageWidth div 2) - (ScaleX(Grid.Canvas.TextWidth(List[1])) div 2), PageHeight -\r\n ScaleY(Integer(GridPrinter.PrintOptions.MarginBottom) + Grid.Canvas.TextHeight(List[1])), List[1]);\r\n //paint Right footer\r\n if List[2] <> '' then\r\n ACanvas.TextOut(PageWidth - ScaleX(Integer(GridPrinter.PrintOptions.MarginRight) +\r\n Grid.Canvas.TextWidth(List[2]) + 10), PageHeight - ScaleY(Integer(GridPrinter.PrintOptions.MarginBottom) +\r\n Grid.Canvas.TextHeight(List[2])), List[2]);\r\n List.Free;\r\n end;\r\n\r\n if DoPaint then\r\n begin\r\n ACanvas.Font.Size := Grid.Font.Size;\r\n Grid.Canvas.Font := TmpFont;\r\n end;\r\n Y := Y + ScaleY(GridPrinter.PrintOptions.PageTitleMargin);\r\n DrawCells(0);\r\n end;\r\n\r\nbegin\r\n // Do not set the Printer's orientation after BeginDoc because this might lead\r\n // to a blank page.\r\n if Mode = pmPreview then\r\n Printer.Orientation := GridPrinter.PrintOptions.Orientation;\r\n\r\n //page size\r\n PageWidth := Printer.PageWidth;\r\n PageHeight := Printer.PageHeight;\r\n if Mode = pmPreview then\r\n begin\r\n PageWidth := PageWidth div ((GetDeviceCaps(Printer.Handle, LOGPIXELSX) div Screen.PixelsPerInch));\r\n PageHeight := PageHeight div ((GetDeviceCaps(Printer.Handle, LOGPIXELSY) div Screen.PixelsPerInch));\r\n FPrintImage.Width := PageWidth;\r\n FPrintImage.Height := PageHeight;\r\n ACanvas.Brush.Color := clWhite;\r\n ACanvas.FillRect(Rect(0, 0, PageWidth, PageHeight));\r\n end;\r\n HasLogo := False;\r\n if GridPrinter.PrintOptions.Logo <> '' then\r\n if FileExists(GridPrinter.PrintOptions.Logo) then\r\n begin\r\n LogoPic := TBitmap.Create;\r\n LogoPic.LoadFromFile(GridPrinter.PrintOptions.Logo);\r\n HasLogo := True;\r\n LogoPics := TBitmap.Create;\r\n LogoPics.Width := ScaleX(LogoPic.Width);\r\n LogoPics.Height := ScaleY(LogoPic.Height);\r\n LogoPic.PixelFormat := pf24bit;\r\n LogoPics.PixelFormat := pf24bit;\r\n TJvPaintFX.SmoothResize(LogoPic, LogoPics);\r\n end;\r\n\r\n if Mode <> pmPageCount then\r\n begin\r\n ACanvas.Font := Grid.Font;\r\n ACanvas.Font.Color := clBlack;\r\n end;\r\n PageCol := 0;\r\n FromCol := -1;\r\n ToCol := -1;\r\n //scan cols\r\n repeat\r\n //Scan missing cols\r\n if FromCol = ToCol then\r\n Inc(FromCol)\r\n else\r\n FromCol := ToCol + 1;\r\n Inc(ToCol);\r\n //Get Cols with Width that fits page\r\n X := GridPrinter.PrintOptions.MarginLeft;\r\n for I := FromCol to Grid.ColCount - 1 do\r\n begin\r\n Inc(X, ScaleX(Grid.ColWidths[I] + 1));\r\n if X <= (PageWidth - Integer(GridPrinter.PrintOptions.MarginRight)) then\r\n ToCol := I;\r\n end;\r\n PageRow := 1;\r\n Inc(PageCol);\r\n //Mode = PageCount\r\n Inc(FPageCount);\r\n //preview mode\r\n DoPaint := (((Mode = pmPreview) and (FPageCount = GridPrinter.PrintOptions.PreviewPage)) or (Mode = pmPrint));\r\n //Header & Footer\r\n DrawTitle;\r\n //Contents\r\n IRow := FromRow;\r\n repeat\r\n // Inc(Y, ScaleY(RowHeights[IRow]));\r\n if (Y + ScaleY(RowHeights[IRow])) <= (PageHeight - ScaleY(Integer(GridPrinter.PrintOptions.MarginBottom) + 20 +\r\n HFooter)) then\r\n begin //draw contents to Canvas\r\n DrawCells(IRow);\r\n Inc(IRow);\r\n end\r\n else //New page\r\n begin\r\n if DoPaint and (Mode = pmPreview) then\r\n Exit;\r\n if Mode = pmPrint then\r\n Printer.NewPage;\r\n Inc(FPageCount); //pagecount\r\n DoPaint := (((Mode = pmPreview) and (FPageCount = GridPrinter.PrintOptions.PreviewPage)) or (Mode = pmPrint));\r\n Inc(PageRow);\r\n DrawTitle;\r\n end;\r\n if (IRow = ToRow + 1) and (ToCol < Grid.ColCount - 1) and (Y <= PageHeight - ScaleY(20)) then\r\n begin\r\n if DoPaint and (Mode = pmPreview) then\r\n Exit;\r\n if Mode = pmPrint then\r\n Printer.NewPage;\r\n DrawTitle;\r\n end;\r\n until\r\n IRow = ToRow + 1;\r\n until\r\n ToCol = Grid.ColCount - 1;\r\n if HasLogo then\r\n begin\r\n LogoPic.Free;\r\n LogoPics.Free;\r\n end;\r\nend;\r\n\r\nprocedure TJvGridPreviewForm.SetGrid(const Value: TStringGrid);\r\nbegin\r\n FGrid := Value;\r\nend;\r\n\r\nprocedure TJvGridPreviewForm.UpdateRowHeights;\r\nvar\r\n C, MaxH, H, ARow: Integer;\r\n R: TRect;\r\n S: string;\r\nbegin\r\n SetLength(RowHeights, Grid.RowCount);\r\n RowHeights[0] := Grid.RowHeights[0];\r\n MaxH := Grid.DefaultRowHeight;\r\n for ARow := 1 to Grid.RowCount - 1 do\r\n begin\r\n for C := 0 to Grid.ColCount - 1 do\r\n begin\r\n S := Grid.Cells[C, ARow];\r\n R := Grid.CellRect(C, ARow);\r\n DrawText(Grid.Canvas.Handle, PChar(S), -1, R, DT_CALCRECT or DT_WORDBREAK);\r\n H := R.Bottom - R.Top + 1;\r\n if H > MaxH then\r\n MaxH := H;\r\n end;\r\n if GridPrinter.WordWrap then\r\n RowHeights[ARow] := MaxH\r\n else\r\n RowHeights[ARow] := Grid.RowHeights[ARow];\r\n end;\r\nend;\r\n\r\nfunction TJvGridPreviewForm.PageCount: Integer;\r\nbegin\r\n Result := 0;\r\n if not Assigned(FGrid) then\r\n Exit;\r\n UpdateRowHeights;\r\n FPageCount := 0;\r\n DrawToCanvas(nil, pmPageCount, 1, Grid.RowCount - 1);\r\n Result := FPageCount;\r\nend;\r\n\r\nprocedure TJvGridPreviewForm.UpdatePreview(ACanvas: TCanvas);\r\nbegin\r\n FPageCount := 0;\r\n DrawToCanvas(ACanvas, pmPreview, 1, Grid.RowCount - 1);\r\nend;\r\n\r\nprocedure TJvGridPreviewForm.Print;\r\nbegin\r\n if not Assigned(FGrid) then\r\n Exit;\r\n UpdateRowHeights;\r\n if Printer.Printers.Count = 0 then\r\n begin\r\n MessageDlg(RsNoPrinterIsInstalled, mtError, [mbOK], 0);\r\n Exit;\r\n end;\r\n Printer.Title := GridPrinter.PrintOptions.JobTitle;\r\n Printer.Copies := GridPrinter.PrintOptions.Copies;\r\n Printer.Orientation := GridPrinter.PrintOptions.Orientation;\r\n Printer.BeginDoc;\r\n DrawToCanvas(Printer.Canvas, pmPrint, 1, Grid.RowCount - 1);\r\n Printer.EndDoc;\r\nend;\r\n\r\nprocedure TJvGridPreviewForm.MarginClick(Sender: TObject;\r\n Button: TUDBtnType);\r\nbegin\r\n case Margins.ItemIndex of\r\n -1:\r\n Exit;\r\n 0:\r\n GridPrinter.PrintOptions.MarginTop := Margin.Position;\r\n 1:\r\n GridPrinter.PrintOptions.PageTitleMargin := Margin.Position;\r\n 2:\r\n GridPrinter.PrintOptions.MarginLeft := Margin.Position;\r\n 3:\r\n GridPrinter.PrintOptions.MarginRight := Margin.Position;\r\n 4:\r\n GridPrinter.PrintOptions.MarginBottom := Margin.Position;\r\n 5:\r\n GridPrinter.PrintOptions.LeftPadding := Margin.Position;\r\n 6:\r\n GridPrinter.PrintOptions.HeaderSize := Margin.Position;\r\n 7:\r\n GridPrinter.PrintOptions.FooterSize := Margin.Position;\r\n end;\r\n if cklive.Checked then\r\n btnshow.Click;\r\nend;\r\n\r\nprocedure TJvGridPreviewForm.PreviewPageClick(Sender: TObject;\r\n Button: TUDBtnType);\r\nbegin\r\n if PreviewPage.Position < PreviewPage.Min then\r\n PreviewPage.Position := PreviewPage.Min;\r\n if PreviewPage.Position > PreviewPage.Max then\r\n PreviewPage.Position := PreviewPage.Max;\r\n GridPrinter.PrintOptions.PreviewPage := PreviewPage.Position;\r\n if cklive.Checked then\r\n btnshow.Click;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvGridPrinter.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvGridPrinter.PAS, released on 2002-06-15.\r\n\r\nThe Initial Developer of the Original Code is Jan Verhoeven [jan1 dott verhoeven att wxs dott nl]\r\nPortions created by Jan Verhoeven are Copyright (C) 2002 Jan Verhoeven.\r\nAll Rights Reserved.\r\n\r\nContributor(s): Robert Love [rlove att slcdug dott org].\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvGridPrinter.pas 13104 2011-09-07 06:50:43Z obones $\r\n\r\nunit JvGridPrinter;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, Controls, Forms, Grids, Printers, SysUtils, Classes;\r\n\r\ntype\r\n TJvPrintMode = (pmPrint, pmPreview, pmPageCount);\r\n\r\n TJvPrintOptions = class(TPersistent)\r\n private\r\n FJobTitle: string;\r\n FPageTitle: string;\r\n FPageTitleMargin: Cardinal;\r\n FCopies: Cardinal;\r\n FPreviewPage: Cardinal;\r\n FBorderStyle: TBorderStyle;\r\n FLeftPadding: Cardinal;\r\n FMarginBottom: Cardinal;\r\n FMarginLeft: Cardinal;\r\n FMarginTop: Cardinal;\r\n FMarginRight: Cardinal;\r\n FPageFooter: string;\r\n FDateFormat: string;\r\n FTimeFormat: string;\r\n FHeaderSize: Cardinal;\r\n FFooterSize: Cardinal;\r\n FOrientation: TPrinterOrientation;\r\n FLogo: string;\r\n published\r\n property Orientation: TPrinterOrientation read FOrientation write FOrientation;\r\n property JobTitle: string read FJobTitle write FJobTitle;\r\n property PageTitle: string read FPageTitle write FPageTitle;\r\n property Logo: string read FLogo write FLogo;\r\n property PageTitleMargin: Cardinal read FPageTitleMargin write FPageTitleMargin;\r\n property PageFooter: string read FPageFooter write FPageFooter;\r\n property HeaderSize: Cardinal read FHeaderSize write FHeaderSize;\r\n property FooterSize: Cardinal read FFooterSize write FFooterSize;\r\n property DateFormat: string read FDateFormat write FDateFormat;\r\n property TimeFormat: string read FTimeFormat write FTimeFormat;\r\n property Copies: Cardinal read FCopies write FCopies default 1;\r\n property PreviewPage: Cardinal read FPreviewPage write FPreviewPage;\r\n property BorderStyle: TBorderStyle read FBorderStyle write FBorderStyle;\r\n property Leftpadding: Cardinal read FLeftPadding write FLeftPadding;\r\n property MarginBottom: Cardinal read FMarginBottom write FMarginBottom;\r\n property MarginLeft: Cardinal read FMarginLeft write FMarginLeft;\r\n property MarginTop: Cardinal read FMarginTop write FMarginTop;\r\n property MarginRight: Cardinal read FMarginRight write FMarginRight;\r\n end;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvGridPrinter = class(TComponent)\r\n private\r\n FPrintOptions: TJvPrintOptions;\r\n FGrid: TStringGrid;\r\n FNumbersAlright: Boolean;\r\n FNumberFormat: string;\r\n FWordWrap: Boolean;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n function Preview: Boolean;\r\n published\r\n property PrintOptions: TJvPrintOptions read FPrintOptions write FPrintOptions;\r\n property Grid: TStringGrid read FGrid write FGrid;\r\n property WordWrap: Boolean read FWordWrap write FWordWrap default True;\r\n property NumbersAlright: Boolean read FNumbersAlright write FNumbersAlright default True;\r\n property NumberFormat: string read FNumberFormat write FNumberFormat;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvGridPrinter.pas $';\r\n Revision: '$Revision: 13104 $';\r\n Date: '$Date: 2011-09-07 08:50:43 +0200 (mer. 07 sept. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n JvGridPreviewForm, JvTypes, JvResources;\r\n\r\nconstructor TJvGridPrinter.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FPrintOptions := TJvPrintOptions.Create;\r\n FPrintOptions.PageFooter := RsPrintOptionsPageFooter;\r\n FPrintOptions.DateFormat := RsPrintOptionsDateFormat;\r\n FPrintOptions.TimeFormat := RsPrintOptionsTimeFormat;\r\n FPrintOptions.HeaderSize := 14;\r\n FPrintOptions.FooterSize := 8;\r\n FPrintOptions.PreviewPage := 1;\r\n FNumbersAlright := True;\r\n FNumberFormat := '%.2f';\r\n FWordWrap := True;\r\nend;\r\n\r\ndestructor TJvGridPrinter.Destroy;\r\nbegin\r\n FPrintOptions.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJvGridPrinter.Preview: Boolean;\r\nvar\r\n Preview: TJvGridPreviewForm;\r\nbegin\r\n if Assigned(FGrid) then\r\n begin\r\n Preview := TJvGridPreviewForm.Create(Application);\r\n Preview.GridPrinter := Self;\r\n Preview.Grid := Grid;\r\n Preview.ShowModal;\r\n Preview.Free;\r\n Result := True;\r\n end\r\n else\r\n Result := False;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend." }, { "path": "External/Jedi/Jvcl/run/JvGrids.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvGrids.PAS, released on 2002-07-04.\r\n\r\nThe Initial Developers of the Original Code are: Fedor Koshevnikov, Igor Pavluk and Serge Korolev\r\nCopyright (c) 1997, 1998 Fedor Koshevnikov, Igor Pavluk and Serge Korolev\r\nCopyright (c) 2001,2002 SGB Software\r\nAll Rights Reserved.\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvGrids.pas 13104 2011-09-07 06:50:43Z obones $\r\n\r\nunit JvGrids;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Classes, Windows, Messages, Controls, Graphics, StdCtrls, Forms, Grids,\r\n JvConsts, JvAppStorage, JvFormPlacement, JvComponent, JvExGrids;\r\n\r\ntype\r\n TAcceptKeyEvent = function(Sender: TObject; var Key: Char): Boolean of object;\r\n TEditLimitEvent = procedure(Sender: TObject; var MaxLength: Integer) of object;\r\n TEditShowEvent = procedure(Sender: TObject; ACol, ARow: Longint;\r\n var AllowEdit: Boolean) of object;\r\n TFixedCellClickEvent = procedure(Sender: TObject; ACol, ARow: Longint) of object;\r\n TFixedCellCheckEvent = procedure(Sender: TObject; ACol, ARow: Longint;\r\n var Enabled: Boolean) of object;\r\n\r\n TInplaceEditStyle = TEditStyle;\r\n\r\nconst\r\n ieSimple = esSimple;\r\n ieEllipsis = esEllipsis;\r\n iePickList = esPickList;\r\n\r\ntype\r\n TEditAlignEvent = procedure(Sender: TObject; ACol, ARow: Longint;\r\n var Alignment: TAlignment) of object;\r\n TPicklistEvent = procedure(Sender: TObject; ACol, ARow: Longint;\r\n PickList: TStrings) of object;\r\n TEditStyleEvent = procedure(Sender: TObject; ACol, ARow: Longint;\r\n var Style: TInplaceEditStyle) of object;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvDrawGrid = class(TJvExDrawGrid)\r\n private\r\n FNoUpdateData: Boolean;\r\n FFixedCellsButtons: Boolean;\r\n FPressedCell: TGridCoord;\r\n FCellDown: TGridCoord;\r\n FPressed: Boolean;\r\n FTracking: Boolean;\r\n FSwapButtons: Boolean;\r\n FDefaultDrawing: Boolean;\r\n FIniLink: TJvIniLink;\r\n FOnColumnSized: TNotifyEvent;\r\n FOnRowSized: TNotifyEvent;\r\n FOnAcceptEditKey: TAcceptKeyEvent;\r\n FOnGetEditLimit: TEditLimitEvent;\r\n FOnEditChange: TNotifyEvent;\r\n FOnShowEditor: TEditShowEvent;\r\n FOnCancelEdit: TNotifyEvent;\r\n FOnFixedCellClick: TFixedCellClickEvent;\r\n FOnCheckButton: TFixedCellCheckEvent;\r\n FOnChangeFocus: TNotifyEvent;\r\n FOnHScroll: TNotifyEvent;\r\n FOnVScroll: TNotifyEvent;\r\n FOnGetEditAlign: TEditAlignEvent;\r\n FOnEditButtonClick: TNotifyEvent;\r\n FOnGetPicklist: TPicklistEvent;\r\n FOnGetEditStyle: TEditStyleEvent;\r\n FDrawButtons: Boolean;\r\n FBeepOnError: Boolean;\r\n function GetStorage: TJvFormPlacement;\r\n procedure SetStorage(Value: TJvFormPlacement);\r\n procedure IniSave(Sender: TObject);\r\n procedure IniLoad(Sender: TObject);\r\n procedure SetFixedButtons(Value: Boolean);\r\n procedure StopTracking;\r\n procedure TrackButton(X, Y: Integer);\r\n function IsActiveControl: Boolean;\r\n procedure WMCommand(var Msg: TWMCommand); message WM_COMMAND;\r\n procedure WMCancelMode(var Msg: TMessage); message WM_CANCELMODE;\r\n procedure WMLButtonDblClk(var Msg: TWMLButtonDblClk); message WM_LBUTTONDBLCLK;\r\n procedure WMRButtonUp(var Msg: TWMMouse); message WM_RBUTTONUP;\r\n procedure WMHScroll(var Msg: TWMHScroll); message WM_HSCROLL;\r\n procedure WMVScroll(var Msg: TWMVScroll); message WM_VSCROLL;\r\n procedure SetDrawButtons(const Value: Boolean);\r\n protected\r\n function SelectCell(ACol, ARow: Longint): Boolean; override;\r\n procedure FocusKilled(NextWnd: THandle); override;\r\n procedure FocusSet(PrevWnd: THandle); override;\r\n\r\n function CanEditAcceptKey(Key: Char): Boolean; override;\r\n function CanEditShow: Boolean; override;\r\n function GetEditLimit: Integer; override;\r\n procedure TopLeftChanged; override;\r\n procedure ColWidthsChanged; override;\r\n procedure RowHeightsChanged; override;\r\n procedure CallDrawCellEvent(ACol, ARow: Longint; ARect: TRect;\r\n AState: TGridDrawState);\r\n procedure DrawCell(ACol, ARow: Longint; ARect: TRect;\r\n AState: TGridDrawState); override;\r\n procedure DoDrawCell(ACol, ARow: Longint; ARect: TRect;\r\n AState: TGridDrawState); virtual;\r\n procedure KeyDown(var Key: Word; Shift: TShiftState); override;\r\n procedure MouseDown(Button: TMouseButton; Shift: TShiftState;\r\n X, Y: Integer); override;\r\n procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;\r\n procedure MouseUp(Button: TMouseButton; Shift: TShiftState;\r\n X, Y: Integer); override;\r\n procedure SetEditText(ACol, ARow: Longint; const Value: string); override;\r\n function CreateEditor: TInplaceEdit; override;\r\n procedure Paint; override;\r\n procedure EditChanged(Sender: TObject); dynamic;\r\n procedure DoFixedCellClick(ACol, ARow: Longint); dynamic;\r\n procedure CheckFixedCellButton(ACol, ARow: Longint;\r\n var Enabled: Boolean); dynamic;\r\n procedure EditButtonClick; dynamic;\r\n function GetEditAlignment(ACol, ARow: Longint): TAlignment; dynamic;\r\n function GetEditStyle(ACol, ARow: Longint): TEditStyle; override;\r\n procedure GetPickList(ACol, ARow: Longint; PickList: TStrings); dynamic;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n procedure DrawStr(ARect: TRect; const S: string; Align: TAlignment);\r\n procedure DrawMultiline(ARect: TRect; const S: string; Align: TAlignment);\r\n procedure DrawPicture(ARect: TRect; Graphic: TGraphic);\r\n procedure DrawMasked(ARect: TRect; Graphic: TBitmap);\r\n procedure InvalidateCell(ACol, ARow: Longint);\r\n procedure InvalidateCol(ACol: Longint);\r\n procedure InvalidateRow(ARow: Longint);\r\n procedure LoadFromAppStorage(const AppStorage: TJvCustomAppStorage; const Path: string);\r\n procedure SaveToAppStorage(const AppStorage: TJvCustomAppStorage; const Path: string);\r\n procedure Load;\r\n procedure Save;\r\n property InplaceEditor;\r\n published\r\n property BeepOnError: Boolean read FBeepOnError write FBeepOnError default True;\r\n property DefaultRowHeight default 18;\r\n property DrawButtons: Boolean read FDrawButtons write SetDrawButtons;\r\n property Options default [goFixedVertLine, goFixedHorzLine, goVertLine,\r\n goHorzLine, goDrawFocusSelected, goColSizing];\r\n property IniStorage: TJvFormPlacement read GetStorage write SetStorage;\r\n property FixedButtons: Boolean read FFixedCellsButtons write SetFixedButtons\r\n default False;\r\n property OnAcceptEditKey: TAcceptKeyEvent read FOnAcceptEditKey\r\n write FOnAcceptEditKey;\r\n property OnCancelEdit: TNotifyEvent read FOnCancelEdit write FOnCancelEdit;\r\n property OnCheckButton: TFixedCellCheckEvent read FOnCheckButton\r\n write FOnCheckButton;\r\n property OnChangeFocus: TNotifyEvent read FOnChangeFocus write FOnChangeFocus;\r\n property OnFixedCellClick: TFixedCellClickEvent read FOnFixedCellClick\r\n write FOnFixedCellClick;\r\n property OnColumnSized: TNotifyEvent read FOnColumnSized\r\n write FOnColumnSized;\r\n property OnRowSized: TNotifyEvent read FOnRowSized write FOnRowSized;\r\n property OnGetEditLimit: TEditLimitEvent read FOnGetEditLimit write FOnGetEditLimit;\r\n property OnEditChange: TNotifyEvent read FOnEditChange write FOnEditChange;\r\n property OnShowEditor: TEditShowEvent read FOnShowEditor write FOnShowEditor;\r\n property OnGetEditAlign: TEditAlignEvent read FOnGetEditAlign write FOnGetEditAlign;\r\n property OnGetEditStyle: TEditStyleEvent read FOnGetEditStyle write FOnGetEditStyle;\r\n property OnGetPicklist: TPicklistEvent read FOnGetPicklist write FOnGetPicklist;\r\n property OnEditButtonClick: TNotifyEvent read FOnEditButtonClick write FOnEditButtonClick;\r\n\r\n property OnMouseEnter;\r\n property OnMouseLeave;\r\n property OnParentColorChange;\r\n property OnVerticalScroll: TNotifyEvent read FOnVScroll write FOnVScroll;\r\n property OnHorizontalScroll: TNotifyEvent read FOnHScroll write FOnHScroll;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvGrids.pas $';\r\n Revision: '$Revision: 13104 $';\r\n Date: '$Date: 2011-09-07 08:50:43 +0200 (mer. 07 sept. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n SysUtils, Math, Types,\r\n JvJCLUtils, JvJVCLUtils;\r\n\r\nconst\r\n MaxCustomExtents = {$IFDEF RTL230_UP}Maxint div 16{$ELSE}MaxListSize{$ENDIF RTL230_UP};\r\n MaxShortInt = High(ShortInt);\r\n\r\ntype\r\n PIntArray = ^TIntArray;\r\n TIntArray = array [0..MaxCustomExtents] of Integer;\r\n\r\n//=== { TJvGridPopupListBox } ================================================\r\n\r\ntype\r\n TJvGridPopupListBox = class;\r\n\r\n TJvInplaceEdit = class(TJvExInplaceEdit)\r\n private\r\n FAlignment: TAlignment;\r\n FButtonWidth: Integer;\r\n FPickList: TJvGridPopupListBox;\r\n FActiveList: TWinControl;\r\n FEditStyle: TInplaceEditStyle;\r\n FListVisible: Boolean;\r\n FTracking: Boolean;\r\n FPressed: Boolean;\r\n procedure ListMouseUp(Sender: TObject; Button: TMouseButton;\r\n Shift: TShiftState; X, Y: Integer);\r\n procedure SetEditStyle(Value: TInplaceEditStyle);\r\n procedure StopTracking;\r\n procedure TrackButton(X, Y: Integer);\r\n procedure SetAlignment(Value: TAlignment);\r\n procedure CMCancelMode(var Msg: TCMCancelMode); message CM_CANCELMODE;\r\n procedure WMCancelMode(var Msg: TMessage); message WM_CANCELMODE;\r\n procedure WMLButtonDblClk(var Msg: TWMLButtonDblClk); message WM_LBUTTONDBLCLK;\r\n procedure WMPaint(var Msg: TWMPaint); message WM_PAINT;\r\n procedure WMSetCursor(var Msg: TWMSetCursor); message WM_SETCURSOR;\r\n protected\r\n procedure FocusKilled(NextWnd: THandle); override;\r\n procedure CreateParams(var Params: TCreateParams); override;\r\n procedure BoundsChanged; override;\r\n procedure CloseUp(Accept: Boolean);\r\n procedure DoDropDownKeys(var Key: Word; Shift: TShiftState);\r\n procedure DropDown;\r\n procedure KeyDown(var Key: Word; Shift: TShiftState); override;\r\n procedure MouseDown(Button: TMouseButton; Shift: TShiftState;\r\n X, Y: Integer); override;\r\n procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;\r\n procedure MouseUp(Button: TMouseButton; Shift: TShiftState;\r\n X, Y: Integer); override;\r\n procedure PaintWindow(DC: HDC); override;\r\n procedure UpdateContents; override;\r\n procedure WndProc(var Message: TMessage); override;\r\n property ActiveList: TWinControl read FActiveList write FActiveList;\r\n property PickList: TJvGridPopupListBox read FPickList;\r\n public\r\n constructor Create(Owner: TComponent); override;\r\n property Alignment: TAlignment read FAlignment write SetAlignment;\r\n property EditStyle: TInplaceEditStyle read FEditStyle write SetEditStyle;\r\n end;\r\n\r\n TJvGridPopupListBox = class(TJvPopupListBox)\r\n protected\r\n procedure MouseUp(Button: TMouseButton; Shift: TShiftState;\r\n X, Y: Integer); override;\r\n end;\r\n\r\nprocedure TJvGridPopupListBox.MouseUp(Button: TMouseButton; Shift: TShiftState;\r\n X, Y: Integer);\r\nbegin\r\n inherited MouseUp(Button, Shift, X, Y);\r\n TJvInplaceEdit(Owner).CloseUp((X >= 0) and (Y >= 0) and (X < Width) and (Y < Height));\r\nend;\r\n\r\n//=== { TJvInplaceEdit } =====================================================\r\n\r\nconstructor TJvInplaceEdit.Create(Owner: TComponent);\r\nbegin\r\n inherited Create(Owner);\r\n FButtonWidth := GetSystemMetrics(SM_CXVSCROLL);\r\n // FEditStyle := esSimple;\r\n FEditStyle := ieSimple;\r\nend;\r\n\r\n\r\nprocedure TJvInplaceEdit.CreateParams(var Params: TCreateParams);\r\nconst\r\n Alignments: array[TAlignment] of Cardinal = (ES_LEFT, ES_RIGHT, ES_CENTER);\r\nbegin\r\n inherited CreateParams(Params);\r\n with Params do\r\n Style := Style or Alignments[FAlignment];\r\nend;\r\n\r\n\r\nprocedure TJvInplaceEdit.BoundsChanged;\r\nvar\r\n R: TRect;\r\nbegin\r\n SetRect(R, 2, 2, Width - 2, Height);\r\n if FEditStyle <> ieSimple then\r\n Dec(R.Right, FButtonWidth);\r\n SendMessage(Handle, EM_SETRECTNP, 0, LPARAM(@R));\r\n SendMessage(Handle, EM_SCROLLCARET, 0, 0);\r\n if SysLocale.FarEast then\r\n SetImeCompositionWindow(Font, R.Left, R.Top);\r\nend;\r\n\r\nprocedure TJvInplaceEdit.CloseUp(Accept: Boolean);\r\nvar\r\n ListValue: string;\r\nbegin\r\n if FListVisible then\r\n begin\r\n if GetCapture <> 0 then\r\n SendMessage(GetCapture, WM_CANCELMODE, 0, 0);\r\n if FPickList.ItemIndex > -1 then\r\n ListValue := FPickList.Items[FPickList.ItemIndex];\r\n SetWindowPos(FActiveList.Handle, 0, 0, 0, 0, 0, SWP_NOZORDER or\r\n SWP_NOMOVE or SWP_NOSIZE or SWP_NOACTIVATE or SWP_HIDEWINDOW);\r\n FListVisible := False;\r\n Invalidate;\r\n if Accept and EditCanModify then\r\n Text := ListValue;\r\n end;\r\nend;\r\n\r\nprocedure TJvInplaceEdit.DoDropDownKeys(var Key: Word; Shift: TShiftState);\r\nbegin\r\n case Key of\r\n VK_UP, VK_DOWN:\r\n if ssAlt in Shift then\r\n begin\r\n if FListVisible then\r\n CloseUp(True)\r\n else\r\n DropDown;\r\n Key := 0;\r\n end;\r\n VK_RETURN, VK_ESCAPE:\r\n if FListVisible and not (ssAlt in Shift) then\r\n begin\r\n CloseUp(Key = VK_RETURN);\r\n Key := 0;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvInplaceEdit.DropDown;\r\nconst\r\n MaxListCount = 8;\r\nvar\r\n P: TPoint;\r\n Y, J, I: Integer;\r\nbegin\r\n if not FListVisible and Assigned(FActiveList) then\r\n begin\r\n FPickList.Width := Width;\r\n FPickList.Color := Color;\r\n FPickList.Font := Font;\r\n FPickList.Items.Clear;\r\n with TJvDrawGrid(Grid) do\r\n GetPickList(Col, Row, FPickList.Items);\r\n FPickList.Height := Min(FPickList.Items.Count, MaxListCount) *\r\n FPickList.ItemHeight + 4;\r\n FPickList.ItemIndex := FPickList.Items.IndexOf(Text);\r\n J := FPickList.ClientWidth;\r\n for I := 0 to FPickList.Items.Count - 1 do\r\n begin\r\n Y := FPickList.Canvas.TextWidth(FPickList.Items[I]);\r\n if Y > J then\r\n J := Y;\r\n end;\r\n if FPickList.Items.Count > MaxListCount then\r\n Inc(J, GetSystemMetrics(SM_CXVSCROLL));\r\n FPickList.ClientWidth := J;\r\n P := Parent.ClientToScreen(Point(Left, Top));\r\n Y := P.Y + Height;\r\n if Y + FActiveList.Height > Screen.Height then\r\n Y := P.Y - FActiveList.Height;\r\n SetWindowPos(FActiveList.Handle, HWND_TOP, P.X, Y, 0, 0,\r\n SWP_NOSIZE or SWP_NOACTIVATE or SWP_SHOWWINDOW);\r\n FListVisible := True;\r\n Invalidate;\r\n Windows.SetFocus(Handle);\r\n end;\r\nend;\r\n\r\ntype\r\n THackedWinControl = class(TWinControl);\r\n\r\nprocedure TJvInplaceEdit.KeyDown(var Key: Word; Shift: TShiftState);\r\nbegin\r\n if (EditStyle = ieEllipsis) and (Key = VK_RETURN) and (Shift = [ssCtrl]) then\r\n begin\r\n TJvDrawGrid(Grid).EditButtonClick;\r\n KillMessage(Handle, WM_CHAR);\r\n end\r\n else\r\n inherited KeyDown(Key, Shift);\r\nend;\r\n\r\nprocedure TJvInplaceEdit.ListMouseUp(Sender: TObject; Button: TMouseButton;\r\n Shift: TShiftState; X, Y: Integer);\r\nbegin\r\n if Button = mbLeft then\r\n CloseUp(PtInRect(FActiveList.ClientRect, Point(X, Y)));\r\nend;\r\n\r\nprocedure TJvInplaceEdit.MouseDown(Button: TMouseButton; Shift: TShiftState;\r\n X, Y: Integer);\r\nbegin\r\n if (Button = mbLeft) and (FEditStyle <> ieSimple) and\r\n PtInRect(Rect(Width - FButtonWidth, 0, Width, Height), Point(X, Y)) then\r\n begin\r\n if FListVisible then\r\n CloseUp(False)\r\n else\r\n begin\r\n MouseCapture := True;\r\n FTracking := True;\r\n TrackButton(X, Y);\r\n if Assigned(FActiveList) then\r\n DropDown;\r\n end;\r\n end;\r\n inherited MouseDown(Button, Shift, X, Y);\r\nend;\r\n\r\nprocedure TJvInplaceEdit.MouseMove(Shift: TShiftState; X, Y: Integer);\r\nvar\r\n ListPos: TPoint;\r\n MousePos: TSmallPoint;\r\nbegin\r\n if FTracking then\r\n begin\r\n TrackButton(X, Y);\r\n if FListVisible then\r\n begin\r\n ListPos := FActiveList.ScreenToClient(ClientToScreen(Point(X, Y)));\r\n if PtInRect(FActiveList.ClientRect, ListPos) then\r\n begin\r\n StopTracking;\r\n MousePos := PointToSmallPoint(ListPos);\r\n SendMessage(FActiveList.Handle, WM_LBUTTONDOWN, 0, {$IFDEF RTL230_UP}PointToLParam{$ELSE}LPARAM{$ENDIF RTL230_UP}(MousePos));\r\n Exit;\r\n end;\r\n end;\r\n end;\r\n inherited MouseMove(Shift, X, Y);\r\nend;\r\n\r\nprocedure TJvInplaceEdit.MouseUp(Button: TMouseButton; Shift: TShiftState;\r\n X, Y: Integer);\r\nvar\r\n WasPressed: Boolean;\r\nbegin\r\n WasPressed := FPressed;\r\n StopTracking;\r\n if (Button = mbLeft) and (FEditStyle = ieEllipsis) and WasPressed then\r\n TJvDrawGrid(Grid).EditButtonClick;\r\n inherited MouseUp(Button, Shift, X, Y);\r\nend;\r\n\r\n\r\nprocedure TJvInplaceEdit.PaintWindow(DC: HDC);\r\n\r\n\r\nconst\r\n LeftOffs = 3;\r\nvar\r\n R: TRect;\r\n Flags: Integer;\r\n W, G, I: Integer;\r\nbegin\r\n\r\n if FEditStyle <> ieSimple then\r\n begin\r\n SetRect(R, Width - FButtonWidth, 0, Width, Height);\r\n Flags := 0;\r\n if FEditStyle in [iePickList] then\r\n begin\r\n if FActiveList = nil then\r\n Flags := DFCS_INACTIVE\r\n else\r\n if FPressed then\r\n Flags := DFCS_FLAT or DFCS_PUSHED;\r\n DrawFrameControl(DC, R, DFC_SCROLL, Flags or DFCS_SCROLLCOMBOBOX);\r\n end\r\n else\r\n begin { esEllipsis }\r\n if FPressed then\r\n Flags := BF_FLAT;\r\n DrawEdge(DC, R, EDGE_RAISED, BF_RECT or BF_MIDDLE or Flags);\r\n W := 2;\r\n G := (FButtonWidth - LeftOffs * 2 - 3 * W) div 2;\r\n if G <= 0 then\r\n G := 1;\r\n if G > 3 then\r\n G := 3;\r\n Flags := R.Left + (FButtonWidth - 3 * W - 2 * G) div 2 + Ord(FPressed);\r\n I := R.Top + (ClientHeight - W) div 2 {+ Ord(FPressed)};\r\n PatBlt(DC, Flags, I, W, W, BLACKNESS);\r\n PatBlt(DC, Flags + G + W, I, W, W, BLACKNESS);\r\n PatBlt(DC, Flags + 2 * G + 2 * W, I, W, W, BLACKNESS);\r\n end;\r\n ExcludeClipRect(DC, R.Left, R.Top, R.Right, R.Bottom);\r\n end;\r\n inherited {PaintWindow(DC);}\r\nend;\r\n\r\n\r\nprocedure TJvInplaceEdit.SetAlignment(Value: TAlignment);\r\nbegin\r\n if FAlignment <> Value then\r\n begin\r\n FAlignment := Value;\r\n RecreateWnd;\r\n end;\r\nend;\r\n\r\n\r\nprocedure TJvInplaceEdit.SetEditStyle(Value: TInplaceEditStyle);\r\nbegin\r\n if Value = FEditStyle then\r\n Exit;\r\n FEditStyle := Value;\r\n case Value of\r\n iePickList:\r\n begin\r\n if FPickList = nil then\r\n begin\r\n FPickList := TJvGridPopupListBox.Create(Self);\r\n FPickList.Visible := False;\r\n FPickList.Parent := Self;\r\n FPickList.OnMouseUp := ListMouseUp;\r\n FPickList.IntegralHeight := True;\r\n FPickList.ItemHeight := 11;\r\n end;\r\n FActiveList := FPickList;\r\n end;\r\n else\r\n FActiveList := nil;\r\n end;\r\n Repaint;\r\nend;\r\n\r\nprocedure TJvInplaceEdit.StopTracking;\r\nbegin\r\n if FTracking then\r\n begin\r\n TrackButton(-1, -1);\r\n FTracking := False;\r\n MouseCapture := False;\r\n end;\r\nend;\r\n\r\nprocedure TJvInplaceEdit.TrackButton(X, Y: Integer);\r\nvar\r\n NewState: Boolean;\r\n R: TRect;\r\nbegin\r\n SetRect(R, ClientWidth - FButtonWidth, 0, ClientWidth, ClientHeight);\r\n NewState := PtInRect(R, Point(X, Y));\r\n if FPressed <> NewState then\r\n begin\r\n FPressed := NewState;\r\n Windows.InvalidateRect(Handle, @R, False);\r\n end;\r\nend;\r\n\r\nprocedure TJvInplaceEdit.UpdateContents;\r\nvar\r\n SaveChanged: TNotifyEvent;\r\nbegin\r\n with TJvDrawGrid(Grid) do\r\n begin\r\n Self.Alignment := GetEditAlignment(Col, Row);\r\n EditStyle := GetEditStyle(Col, Row);\r\n end;\r\n SaveChanged := Self.OnChange;\r\n try\r\n Self.OnChange := nil;\r\n inherited UpdateContents;\r\n finally\r\n Self.OnChange := SaveChanged;\r\n end;\r\nend;\r\n\r\n\r\n\r\nprocedure TJvInplaceEdit.CMCancelMode(var Msg: TCMCancelMode);\r\nbegin\r\n if (Msg.Sender <> Self) and (Msg.Sender <> FActiveList) then\r\n CloseUp(False);\r\nend;\r\n\r\nprocedure TJvInplaceEdit.WMCancelMode(var Msg: TMessage);\r\nbegin\r\n StopTracking;\r\n inherited;\r\nend;\r\n\r\n\r\n\r\nprocedure TJvInplaceEdit.FocusKilled(NextWnd: THandle);\r\nbegin\r\n if not SysLocale.FarEast then\r\n inherited FocusKilled(NextWnd)\r\n else\r\n begin\r\n ImeName := Screen.DefaultIme;\r\n ImeMode := imDontCare;\r\n inherited FocusKilled(NextWnd);\r\n if NextWnd <> TJvDrawGrid(Grid).Handle then\r\n ActivateKeyboardLayout(Screen.DefaultKbLayout, KLF_ACTIVATE);\r\n end;\r\n CloseUp(False);\r\nend;\r\n\r\n\r\n\r\nprocedure TJvInplaceEdit.WMLButtonDblClk(var Msg: TWMLButtonDblClk);\r\nbegin\r\n with Msg do\r\n if (FEditStyle <> ieSimple) and PtInRect(Rect(Width - FButtonWidth, 0,\r\n Width, Height), Point(XPos, YPos)) then\r\n Exit;\r\n inherited;\r\nend;\r\n\r\nprocedure TJvInplaceEdit.WMPaint(var Msg: TWMPaint);\r\nbegin\r\n PaintHandler(Msg);\r\nend;\r\n\r\nprocedure TJvInplaceEdit.WMSetCursor(var Msg: TWMSetCursor);\r\nvar\r\n P: TPoint;\r\nbegin\r\n GetCursorPos(P);\r\n if (FEditStyle <> ieSimple) and\r\n PtInRect(Rect(Width - FButtonWidth, 0, Width, Height), ScreenToClient(P)) then\r\n Windows.SetCursor(LoadCursor(0, IDC_ARROW))\r\n else\r\n inherited;\r\nend;\r\n\r\nprocedure TJvInplaceEdit.WndProc(var Message: TMessage);\r\nbegin\r\n case Message.Msg of\r\n WM_KEYDOWN, WM_SYSKEYDOWN, WM_CHAR:\r\n if EditStyle in [iePickList] then\r\n with TWMKey(Message) do\r\n begin\r\n DoDropDownKeys(CharCode, KeyDataToShiftState(KeyData));\r\n if (CharCode <> 0) and FListVisible then\r\n begin\r\n with TMessage(Message) do\r\n SendMessage(FActiveList.Handle, Msg, WParam, LParam);\r\n Exit;\r\n end;\r\n end;\r\n end;\r\n inherited WndProc(Message);\r\nend;\r\n\r\n\r\n\r\n//=== { TJvDrawGrid } ========================================================\r\n\r\nconstructor TJvDrawGrid.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n DefaultRowHeight := 18;\r\n Options := [goFixedVertLine, goFixedHorzLine, goVertLine, goHorzLine,\r\n goDrawFocusSelected, goColSizing];\r\n FIniLink := TJvIniLink.Create;\r\n FIniLink.OnSave := IniSave;\r\n FIniLink.OnLoad := IniLoad;\r\n FPressedCell.X := -1;\r\n FPressedCell.Y := -1;\r\n FCellDown.X := -1;\r\n FCellDown.Y := -1;\r\n FBeepOnError := True;\r\nend;\r\n\r\ndestructor TJvDrawGrid.Destroy;\r\nbegin\r\n FOnChangeFocus := nil;\r\n FIniLink.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJvDrawGrid.GetStorage: TJvFormPlacement;\r\nbegin\r\n Result := FIniLink.Storage;\r\nend;\r\n\r\nprocedure TJvDrawGrid.SetStorage(Value: TJvFormPlacement);\r\nbegin\r\n FIniLink.Storage := Value;\r\nend;\r\n\r\nprocedure TJvDrawGrid.IniSave(Sender: TObject);\r\nbegin\r\n if (Name <> '') and Assigned(IniStorage) then\r\n SaveToAppStorage(IniStorage.AppStorage, IniStorage.AppStorage.ConcatPaths([\r\n IniStorage.AppStoragePath, GetDefaultSection(Self)]));\r\nend;\r\n\r\nprocedure TJvDrawGrid.IniLoad(Sender: TObject);\r\nbegin\r\n if (Name <> '') and Assigned(IniStorage) then\r\n LoadFromAppStorage(IniStorage.AppStorage, IniStorage.AppStorage.ConcatPaths([\r\n IniStorage.AppStoragePath, GetDefaultSection(Self)]));\r\nend;\r\n\r\nfunction TJvDrawGrid.CanEditAcceptKey(Key: Char): Boolean;\r\nbegin\r\n if Assigned(FOnAcceptEditKey) then\r\n Result := FOnAcceptEditKey(Self, Key)\r\n else\r\n Result := inherited CanEditAcceptKey(Key);\r\nend;\r\n\r\nfunction TJvDrawGrid.CanEditShow: Boolean;\r\nbegin\r\n Result := inherited CanEditShow;\r\n if Result and Assigned(FOnShowEditor) then\r\n begin\r\n FOnShowEditor(Self, Col, Row, Result);\r\n if not Result then\r\n EditorMode := False;\r\n end;\r\nend;\r\n\r\nprocedure TJvDrawGrid.DrawPicture(ARect: TRect; Graphic: TGraphic);\r\nbegin\r\n DrawCellBitmap(Self, 0, 0, Graphic, ARect);\r\nend;\r\n\r\nprocedure TJvDrawGrid.DrawMasked(ARect: TRect; Graphic: TBitmap);\r\nvar\r\n X, Y: Integer;\r\nbegin\r\n X := (ARect.Right + ARect.Left - Graphic.Width) div 2;\r\n Y := (ARect.Bottom + ARect.Top - Graphic.Height) div 2;\r\n DrawBitmapTransparent(Canvas, X, Y, Graphic, Graphic.TransparentColor and not PaletteMask);\r\nend;\r\n\r\nprocedure TJvDrawGrid.DrawStr(ARect: TRect; const S: string;\r\n Align: TAlignment);\r\nbegin\r\n DrawCellTextEx(Self, 0, 0, S, ARect, Align, vaCenterJustify, False, IsRightToLeft);\r\nend;\r\n\r\nprocedure TJvDrawGrid.DrawMultiline(ARect: TRect; const S: string;\r\n Align: TAlignment);\r\nbegin\r\n DrawCellTextEx(Self, 0, 0, S, ARect, Align, vaTopJustify, True, IsRightToLeft);\r\nend;\r\n\r\nprocedure TJvDrawGrid.InvalidateCell(ACol, ARow: Longint);\r\nbegin\r\n inherited InvalidateCell(ACol, ARow);\r\nend;\r\n\r\nprocedure TJvDrawGrid.InvalidateCol(ACol: Longint);\r\nbegin\r\n inherited InvalidateCol(ACol);\r\nend;\r\n\r\nprocedure TJvDrawGrid.InvalidateRow(ARow: Longint);\r\nvar\r\n I: Longint;\r\nbegin\r\n for I := 0 to ColCount - 1 do\r\n inherited InvalidateCell(I, ARow);\r\nend;\r\n\r\nprocedure TJvDrawGrid.LoadFromAppStorage(const AppStorage: TJvCustomAppStorage; const Path: string);\r\nbegin\r\n if (Name <> '') then\r\n InternalRestoreGridLayout(Self, IniStorage.AppStorage, Path);\r\nend;\r\n\r\nprocedure TJvDrawGrid.SaveToAppStorage(const AppStorage: TJvCustomAppStorage; const Path: string);\r\nbegin\r\n if (Name <> '') then\r\n InternalSaveGridLayout(Self, IniStorage.AppStorage, Path);\r\nend;\r\n\r\nprocedure TJvDrawGrid.Load;\r\nbegin\r\n IniLoad(nil);\r\nend;\r\n\r\nprocedure TJvDrawGrid.Save;\r\nbegin\r\n IniSave(nil);\r\nend;\r\n\r\nprocedure TJvDrawGrid.KeyDown(var Key: Word; Shift: TShiftState);\r\nbegin\r\n if not CanGridAcceptKey(Key, Shift) then\r\n Exit;\r\n if not (ssCtrl in Shift) and (Key = VK_ESCAPE) and EditorMode and\r\n (InplaceEditor <> nil) and InplaceEditor.Visible and\r\n not (goAlwaysShowEditor in Options) then\r\n begin\r\n FNoUpdateData := True;\r\n try\r\n HideEditor;\r\n if Assigned(FOnCancelEdit) then\r\n FOnCancelEdit(Self);\r\n finally\r\n FNoUpdateData := False;\r\n end;\r\n end\r\n else\r\n inherited KeyDown(Key, Shift);\r\nend;\r\n\r\n\r\nprocedure TJvDrawGrid.WMCommand(var Msg: TWMCommand);\r\nbegin\r\n if (Msg.NotifyCode = EN_CHANGE) and\r\n not (goAlwaysShowEditor in Options) then\r\n begin\r\n if (InplaceEditor <> nil) and InplaceEditor.HandleAllocated and\r\n InplaceEditor.Visible then\r\n TJvInplaceEdit(InplaceEditor).Change;\r\n Msg.NotifyCode := 0;\r\n end;\r\n inherited;\r\nend;\r\n\r\n\r\nprocedure TJvDrawGrid.EditChanged(Sender: TObject);\r\nbegin\r\n if Assigned(FOnEditChange) then\r\n FOnEditChange(Self);\r\nend;\r\n\r\nfunction TJvDrawGrid.GetEditLimit: Integer;\r\nbegin\r\n Result := inherited GetEditLimit;\r\n if Assigned(FOnGetEditLimit) then\r\n FOnGetEditLimit(Self, Result);\r\nend;\r\n\r\n\r\nprocedure TJvDrawGrid.SetEditText(ACol, ARow: Longint; const Value: string);\r\nbegin\r\n if not FNoUpdateData then\r\n inherited SetEditText(ACol, ARow, Value);\r\nend;\r\n\r\n\r\n\r\nprocedure TJvDrawGrid.SetFixedButtons(Value: Boolean);\r\nbegin\r\n if FFixedCellsButtons <> Value then\r\n begin\r\n FFixedCellsButtons := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvDrawGrid.DoFixedCellClick(ACol, ARow: Longint);\r\nbegin\r\n if Assigned(FOnFixedCellClick) then\r\n FOnFixedCellClick(Self, ACol, ARow);\r\nend;\r\n\r\nprocedure TJvDrawGrid.CheckFixedCellButton(ACol, ARow: Longint; var Enabled: Boolean);\r\nbegin\r\n if (ACol >= 0) and (ARow >= 0) and ((ACol < FixedCols) or (ARow < FixedRows)) then\r\n begin\r\n if Assigned(FOnCheckButton) then\r\n FOnCheckButton(Self, ACol, ARow, Enabled);\r\n end\r\n else\r\n Enabled := False;\r\nend;\r\n\r\nprocedure TJvDrawGrid.TopLeftChanged;\r\nbegin\r\n if (goRowSelect in Options) and DefaultDrawing then\r\n InvalidateRow(Self.Row);\r\n inherited TopLeftChanged;\r\n if FTracking then\r\n StopTracking;\r\nend;\r\n\r\nprocedure TJvDrawGrid.ColWidthsChanged;\r\nbegin\r\n inherited ColWidthsChanged;\r\n if FTracking then\r\n StopTracking;\r\n if Assigned(FOnColumnSized) then\r\n FOnColumnSized(Self);\r\nend;\r\n\r\nprocedure TJvDrawGrid.RowHeightsChanged;\r\nbegin\r\n inherited RowHeightsChanged;\r\n if FTracking then\r\n StopTracking;\r\n if Assigned(FOnRowSized) then\r\n FOnRowSized(Self);\r\nend;\r\n\r\nprocedure TJvDrawGrid.StopTracking;\r\nbegin\r\n if FTracking then\r\n begin\r\n TrackButton(-1, -1);\r\n FTracking := False;\r\n MouseCapture := False;\r\n end;\r\nend;\r\n\r\nprocedure TJvDrawGrid.TrackButton(X, Y: Integer);\r\nvar\r\n Cell: TGridCoord;\r\n NewPressed: Boolean;\r\nbegin\r\n Cell := MouseCoord(X, Y);\r\n NewPressed := PtInRect(Rect(0, 0, ClientWidth, ClientHeight), Point(X, Y)) and\r\n (FPressedCell.X = Cell.X) and (FPressedCell.Y = Cell.Y);\r\n if FPressed <> NewPressed then\r\n begin\r\n FPressed := NewPressed;\r\n InvalidateCell(Cell.X, Cell.Y);\r\n InvalidateCell(FPressedCell.X, FPressedCell.Y);\r\n end;\r\nend;\r\n\r\n\r\nfunction TJvDrawGrid.IsActiveControl: Boolean;\r\nvar\r\n Handle: THandle;\r\n ParentForm: TCustomForm;\r\nbegin\r\n ParentForm := GetParentForm(Self);\r\n if Assigned(ParentForm) then\r\n Result := ParentForm.ActiveControl = Self\r\n else\r\n begin\r\n Handle := GetFocus;\r\n Result := False;\r\n while not Result and IsWindow(Handle) do\r\n begin\r\n if Handle = WindowHandle then\r\n Result := True\r\n else\r\n Handle := GetParent(Handle);\r\n end;\r\n end;\r\nend;\r\n\r\n\r\nprocedure TJvDrawGrid.MouseDown(Button: TMouseButton; Shift: TShiftState;\r\n X, Y: Integer);\r\nvar\r\n Cell: TGridCoord;\r\n EnableClick, Fixed: Boolean;\r\nbegin\r\n if DrawButtons then\r\n begin\r\n if (Button = mbLeft) and ((Shift - [ssLeft]) = []) then\r\n begin\r\n MouseToCell(X, Y, Cell.X, Cell.Y);\r\n if (Cell.X >= FixedCols) and (Cell.Y >= FixedRows) then\r\n begin\r\n FCellDown := Cell;\r\n InvalidateCell(Cell.X, Cell.Y);\r\n end;\r\n end;\r\n inherited MouseDown(Button, Shift, X, Y);\r\n Exit;\r\n end;\r\n\r\n HideEditor;\r\n if not (csDesigning in ComponentState) and\r\n (CanFocus or (GetParentForm(Self) = nil)) then\r\n begin\r\n SetFocus;\r\n if not IsActiveControl then\r\n begin\r\n MouseCapture := False;\r\n Exit;\r\n end;\r\n end;\r\n if (Button = mbLeft) and (ssDouble in Shift) then\r\n begin\r\n if FFixedCellsButtons then\r\n begin\r\n Cell := MouseCoord(X, Y);\r\n if not ((Cell.X >= 0) and (Cell.X < FixedCols)) and\r\n not ((Cell.Y >= 0) and (Cell.Y < FixedRows)) then\r\n begin\r\n DblClick;\r\n Exit;\r\n end;\r\n end\r\n else\r\n begin\r\n DblClick;\r\n Exit;\r\n end;\r\n end;\r\n if Sizing(X, Y) then\r\n inherited MouseDown(Button, Shift, X, Y)\r\n else\r\n begin\r\n Cell := MouseCoord(X, Y);\r\n Fixed := ((Cell.X >= 0) and (Cell.X < FixedCols)) or\r\n ((Cell.Y >= 0) and (Cell.Y < FixedRows));\r\n if FFixedCellsButtons and Fixed and not (csDesigning in ComponentState) then\r\n begin\r\n if ([goRowMoving, goColMoving] * Options <> []) and\r\n (Button = mbRight) then\r\n begin\r\n Button := mbLeft;\r\n FSwapButtons := True;\r\n MouseCapture := True;\r\n end\r\n else\r\n if Button = mbLeft then\r\n begin\r\n EnableClick := True;\r\n CheckFixedCellButton(Cell.X, Cell.Y, EnableClick);\r\n if EnableClick then\r\n begin\r\n MouseCapture := True;\r\n FTracking := True;\r\n FPressedCell := Cell;\r\n TrackButton(X, Y);\r\n end\r\n else\r\n if BeepOnError then\r\n Beep;\r\n Exit;\r\n end;\r\n end;\r\n inherited MouseDown(Button, Shift, X, Y);\r\n end;\r\nend;\r\n\r\nprocedure TJvDrawGrid.MouseMove(Shift: TShiftState; X, Y: Integer);\r\nvar\r\n Cell: TGridCoord;\r\nbegin\r\n if DrawButtons then\r\n begin\r\n if Shift = [ssLeft] then\r\n begin\r\n MouseToCell(X, Y, Cell.X, Cell.Y);\r\n if not CompareMem(@Cell, @FCellDown, SizeOf(Cell)) then\r\n begin\r\n if (FCellDown.X >= 0) and (FCellDown.Y >= 0) then\r\n InvalidateCell(FCellDown.X, FCellDown.Y);\r\n FCellDown := Cell;\r\n InvalidateCell(Cell.X, Cell.Y);\r\n end;\r\n end;\r\n inherited MouseMove(Shift, X, Y);\r\n Exit;\r\n end;\r\n\r\n if FTracking then\r\n TrackButton(X, Y);\r\n inherited MouseMove(Shift, X, Y);\r\nend;\r\n\r\nprocedure TJvDrawGrid.MouseUp(Button: TMouseButton; Shift: TShiftState;\r\n X, Y: Integer);\r\nvar\r\n Cell: TGridCoord;\r\n ACol, ARow: Longint;\r\n DoClick: Boolean;\r\nbegin\r\n if DrawButtons then\r\n begin\r\n if (Button = mbLeft) and (Shift = []) then\r\n begin\r\n InvalidateCell(FCellDown.X, FCellDown.Y);\r\n FCellDown.X := -1;\r\n FCellDown.Y := -1;\r\n end;\r\n inherited MouseUp(Button, Shift, X, Y);\r\n Exit;\r\n end;\r\n\r\n if FTracking and (FPressedCell.Y >= 0) and (FPressedCell.X >= 0) then\r\n begin\r\n Cell := MouseCoord(X, Y);\r\n DoClick := PtInRect(Rect(0, 0, ClientWidth, ClientHeight), Point(X, Y)) and\r\n (Cell.Y = FPressedCell.Y) and (Cell.X = FPressedCell.X);\r\n StopTracking;\r\n if DoClick then\r\n begin\r\n ACol := Cell.X;\r\n ARow := Cell.Y;\r\n if (ARow < RowCount) and (ACol < ColCount) then\r\n DoFixedCellClick(ACol, ARow);\r\n end;\r\n end\r\n else\r\n if FSwapButtons then\r\n begin\r\n FSwapButtons := False;\r\n MouseCapture := False;\r\n if Button = mbRight then\r\n Button := mbLeft;\r\n end;\r\n inherited MouseUp(Button, Shift, X, Y);\r\nend;\r\n\r\nprocedure TJvDrawGrid.Paint;\r\nvar\r\n R: TRect;\r\nbegin\r\n FDefaultDrawing := inherited DefaultDrawing;\r\n inherited DefaultDrawing := False;\r\n try\r\n inherited Paint;\r\n finally\r\n inherited DefaultDrawing := FDefaultDrawing;\r\n end;\r\n if not (csDesigning in ComponentState) and DefaultDrawing and Focused and\r\n ([goRowSelect, goRangeSelect] * Options = [goRowSelect]) then\r\n begin\r\n Canvas.Font.Color := Font.Color;\r\n Canvas.Brush.Color := Color;\r\n if Row >= FixedRows then\r\n begin\r\n R := BoxRect(FixedCols, Row, ColCount - 1, Row);\r\n if not (goHorzLine in Options) then\r\n Inc(R.Bottom, GridLineWidth);\r\n DrawFocusRect(Canvas.Handle, R);\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvDrawGrid.CallDrawCellEvent(ACol, ARow: Longint; ARect: TRect;\r\n AState: TGridDrawState);\r\nbegin\r\n inherited DrawCell(ACol, ARow, ARect, AState);\r\nend;\r\n\r\nprocedure TJvDrawGrid.DoDrawCell(ACol, ARow: Longint; ARect: TRect;\r\n AState: TGridDrawState);\r\nbegin\r\n CallDrawCellEvent(ACol, ARow, ARect, AState);\r\nend;\r\n\r\nprocedure TJvDrawGrid.DrawCell(ACol, ARow: Longint; ARect: TRect;\r\n AState: TGridDrawState);\r\nvar\r\n Down: Boolean;\r\n TempRect: TRect;\r\n FrameFlags1, FrameFlags2: DWORD;\r\n Style: DWORD;\r\nconst\r\n EdgeFlag: array [Boolean] of UINT = (BDR_RAISEDINNER, BDR_SUNKENINNER);\r\nbegin\r\n if DrawButtons then\r\n begin\r\n TempRect := ARect;\r\n if not (gdFixed in AState) then\r\n begin\r\n Canvas.Brush.Color := clBtnFace;\r\n Canvas.Font.Color := clBtnText;\r\n Style := DFCS_BUTTONPUSH or DFCS_ADJUSTRECT;\r\n if (FCellDown.X = ACol) and (FCellDown.Y = ARow) then\r\n Style := Style or DFCS_PUSHED;\r\n DrawFrameControl(Canvas.Handle, TempRect, DFC_BUTTON, Style);\r\n end;\r\n inherited DrawCell(ACol,ARow,ARect,AState);\r\n Exit;\r\n end;\r\n\r\n if FDefaultDrawing or (csDesigning in ComponentState) then\r\n with Canvas do\r\n begin\r\n Font := Self.Font;\r\n if ([goRowSelect, goVertLine] * Options = [goRowSelect]) and\r\n not (gdFixed in AState) then\r\n Inc(ARect.Right, GridLineWidth);\r\n if ([goRowSelect, goHorzLine] * Options = [goRowSelect]) and\r\n not (gdFixed in AState) then\r\n Inc(ARect.Bottom, GridLineWidth);\r\n if (gdSelected in AState) and (not (gdFocused in AState) or\r\n ([goDrawFocusSelected, goRowSelect] * Options <> [])) then\r\n begin\r\n Brush.Color := clHighlight;\r\n Font.Color := clHighlightText;\r\n end\r\n else\r\n begin\r\n if gdFixed in AState then\r\n Brush.Color := FixedColor\r\n else\r\n Brush.Color := Color;\r\n end;\r\n FillRect(ARect);\r\n end;\r\n Down := FFixedCellsButtons and (gdFixed in AState) and\r\n Ctl3D and\r\n not (csLoading in ComponentState) and FPressed and FDefaultDrawing and\r\n (FPressedCell.X = ACol) and (FPressedCell.Y = ARow);\r\n inherited DefaultDrawing := FDefaultDrawing;\r\n if Down then\r\n begin\r\n Inc(ARect.Left, GridLineWidth);\r\n Inc(ARect.Top, GridLineWidth);\r\n end;\r\n try\r\n DoDrawCell(ACol, ARow, ARect, AState);\r\n finally\r\n inherited DefaultDrawing := False;\r\n if Down then\r\n begin\r\n Dec(ARect.Left, GridLineWidth);\r\n Dec(ARect.Top, GridLineWidth);\r\n end;\r\n end;\r\n if FDefaultDrawing and\r\n Ctl3D and\r\n (gdFixed in AState) then\r\n begin\r\n FrameFlags1 := 0;\r\n FrameFlags2 := 0;\r\n if goFixedVertLine in Options then\r\n begin\r\n FrameFlags1 := BF_RIGHT;\r\n FrameFlags2 := BF_LEFT;\r\n end;\r\n if goFixedHorzLine in Options then\r\n begin\r\n FrameFlags1 := FrameFlags1 or BF_BOTTOM;\r\n FrameFlags2 := FrameFlags2 or BF_TOP;\r\n end;\r\n if (FrameFlags1 or FrameFlags2) <> 0 then\r\n begin\r\n TempRect := ARect;\r\n if ((FrameFlags1 and BF_RIGHT) = 0) and\r\n (goFixedVertLine in Options) then\r\n Inc(TempRect.Right, GridLineWidth)\r\n else\r\n if ((FrameFlags1 and BF_BOTTOM) = 0) and\r\n (goFixedVertLine in Options) then\r\n Inc(TempRect.Bottom, GridLineWidth);\r\n DrawEdge(Canvas.Handle, TempRect, EdgeFlag[Down], FrameFlags1);\r\n DrawEdge(Canvas.Handle, TempRect, EdgeFlag[Down], FrameFlags2);\r\n end;\r\n end;\r\n if FDefaultDrawing and not (csDesigning in ComponentState) and\r\n (gdFocused in AState) and\r\n ([goEditing, goAlwaysShowEditor] * Options <> [goEditing, goAlwaysShowEditor]) and\r\n not (goRowSelect in Options) then\r\n DrawFocusRect(Canvas.Handle, ARect);\r\nend;\r\n\r\n\r\n\r\nprocedure TJvDrawGrid.WMRButtonUp(var Msg: TWMMouse);\r\nbegin\r\n if not (FGridState in [gsColMoving, gsRowMoving]) then\r\n inherited\r\n else\r\n if not (csNoStdEvents in ControlStyle) then\r\n with Msg do\r\n MouseUp(mbRight, KeysToShiftState(Keys), XPos, YPos);\r\nend;\r\n\r\nprocedure TJvDrawGrid.WMLButtonDblClk(var Msg: TWMLButtonDblClk);\r\nvar\r\n Cell: TGridCoord;\r\nbegin\r\n if FFixedCellsButtons then\r\n begin\r\n with Msg do\r\n Cell := MouseCoord(XPos, YPos);\r\n if ((Cell.X >= 0) and (Cell.X < FixedCols)) or\r\n ((Cell.Y >= 0) and (Cell.Y < FixedRows)) then\r\n begin\r\n SendCancelMode(Self);\r\n if csCaptureMouse in ControlStyle then\r\n MouseCapture := True;\r\n if not (csNoStdEvents in ControlStyle) then\r\n with Msg do\r\n MouseDown(mbLeft, KeysToShiftState(Keys) - [ssDouble], XPos, YPos);\r\n Exit;\r\n end;\r\n end;\r\n inherited;\r\nend;\r\n\r\n\r\n\r\nprocedure TJvDrawGrid.FocusKilled(NextWnd: THandle);\r\nbegin\r\n inherited FocusKilled(NextWnd);\r\n if Assigned(FOnChangeFocus) then\r\n FOnChangeFocus(Self);\r\nend;\r\n\r\nprocedure TJvDrawGrid.FocusSet(PrevWnd: THandle);\r\nbegin\r\n inherited FocusSet(PrevWnd);\r\n if Assigned(FOnChangeFocus) then\r\n FOnChangeFocus(Self);\r\nend;\r\n\r\n\r\nprocedure TJvDrawGrid.WMCancelMode(var Msg: TMessage);\r\nbegin\r\n StopTracking;\r\n inherited;\r\nend;\r\n\r\n\r\nfunction TJvDrawGrid.CreateEditor: TInplaceEdit;\r\nbegin\r\n Result := TJvInplaceEdit.Create(Self);\r\n TEdit(Result).OnChange := EditChanged;\r\nend;\r\n\r\nfunction TJvDrawGrid.GetEditAlignment(ACol, ARow: Longint): TAlignment;\r\nbegin\r\n Result := taLeftJustify;\r\n if Assigned(FOnGetEditAlign) then\r\n FOnGetEditAlign(Self, ACol, ARow, Result);\r\nend;\r\n\r\nfunction TJvDrawGrid.GetEditStyle(ACol, ARow: Longint): TInplaceEditStyle;\r\nbegin\r\n Result := ieSimple;\r\n if Assigned(FOnGetEditStyle) then\r\n FOnGetEditStyle(Self, ACol, ARow, Result);\r\nend;\r\n\r\nprocedure TJvDrawGrid.GetPickList(ACol, ARow: Longint; PickList: TStrings);\r\nbegin\r\n if Assigned(FOnGetPicklist) then\r\n FOnGetPicklist(Self, ACol, ARow, PickList);\r\nend;\r\n\r\nprocedure TJvDrawGrid.EditButtonClick;\r\nbegin\r\n if Assigned(FOnEditButtonClick) then\r\n FOnEditButtonClick(Self);\r\nend;\r\n\r\n\r\nprocedure TJvDrawGrid.WMHScroll(var Msg: TWMHScroll);\r\nbegin\r\n inherited;\r\n if Assigned(FOnHScroll) then\r\n FOnHScroll(Self);\r\nend;\r\n\r\nprocedure TJvDrawGrid.WMVScroll(var Msg: TWMVScroll);\r\nbegin\r\n inherited;\r\n if Assigned(FOnVScroll) then\r\n FOnVScroll(Self);\r\nend;\r\n\r\n\r\nprocedure TJvDrawGrid.SetDrawButtons(const Value: Boolean);\r\nbegin\r\n if FDrawButtons <> Value then\r\n begin\r\n FDrawButtons := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nfunction TJvDrawGrid.SelectCell(ACol, ARow: Integer): Boolean;\r\nbegin\r\n if DrawButtons then\r\n Result := False\r\n else\r\n Result := inherited SelectCell(ACol, ARow);\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvGroupBox.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvGroupBox.PAS, released on 2000-11-22.\r\n\r\nThe Initial Developer of the Original Code is Peter Below <100113 dott 1101 att compuserve dott com>\r\nPortions created by Peter Below are Copyright (C) 2000 Peter Below.\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\n Roman Ganz\r\n Robert Marquardt\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvGroupBox.pas 13139 2011-10-28 19:59:40Z jfudickar $\r\n\r\nunit JvGroupBox;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n SysUtils, Classes, Windows, Messages, Graphics, Controls, Forms, StdCtrls,\r\n JvThemes, JvExControls, JvExStdCtrls, JvCheckBox, JvJCLUtils;\r\n\r\ntype\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvGroupBox = class(TJvExGroupBox, IJvDenySubClassing)\r\n private\r\n FCheckBox: TJvCheckBox;\r\n FOnHotKey: TNotifyEvent;\r\n FPropagateEnable: Boolean;\r\n FCheckable: Boolean;\r\n FOnCheckBoxClick: TNotifyEvent;\r\n procedure SetPropagateEnable(const Value: Boolean);\r\n procedure SetCheckable(const Value: Boolean);\r\n function GetCaption: TCaption;\r\n procedure SetCaption(const Value: TCaption);\r\n function GetChecked: Boolean;\r\n procedure SetChecked(const Value: Boolean);\r\n function StoredCheckable: Boolean;\r\n procedure CheckBoxClick(Sender: TObject);\r\n protected\r\n function WantKey(Key: Integer; Shift: TShiftState): Boolean; override;\r\n procedure EnabledChanged; override;\r\n procedure DoHotKey; dynamic;\r\n procedure Paint; override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n property Canvas;\r\n published\r\n property HintColor;\r\n {$IFDEF JVCLThemesEnabledD6}\r\n property ParentBackground default True;\r\n {$ENDIF JVCLThemesEnabledD6}\r\n property Caption: TCaption read GetCaption write SetCaption;\r\n property Checkable: Boolean read FCheckable write SetCheckable default False;\r\n property Checked: Boolean read GetChecked write SetChecked stored StoredCheckable;\r\n property PropagateEnable: Boolean read FPropagateEnable write SetPropagateEnable default False;\r\n property OnMouseEnter;\r\n property OnMouseLeave;\r\n property OnParentColorChange;\r\n property OnHotKey: TNotifyEvent read FOnHotKey write FOnHotKey;\r\n property OnCheckBoxClick: TNotifyEvent read FOnCheckBoxClick write FOnCheckBoxClick; \r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvGroupBox.pas $';\r\n Revision: '$Revision: 13139 $';\r\n Date: '$Date: 2011-10-28 21:59:40 +0200 (ven. 28 oct. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n Math;\r\n\r\nconstructor TJvGroupBox.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FPropagateEnable := False;\r\n FCheckable := False;\r\n ControlStyle := ControlStyle + [csAcceptsControls];\r\n {$IFDEF JVCLThemesEnabledD6}\r\n IncludeThemeStyle(Self, [csParentBackground]);\r\n {$ENDIF JVCLThemesEnabledD6}\r\nend;\r\n\r\nprocedure TJvGroupBox.Paint;\r\nvar\r\n H: Integer;\r\n R: TRect;\r\n Flags: Longint;\r\n {$IFDEF JVCLThemesEnabledD6}\r\n Details: TThemedElementDetails;\r\n CaptionRect: TRect;\r\n {$ENDIF JVCLThemesEnabledD6}\r\n LastBkMode: Integer;\r\nbegin\r\n {$IFDEF JVCLThemesEnabled}\r\n if ThemeServices.{$IFDEF RTL230_UP}Enabled{$ELSE}ThemesEnabled{$ENDIF RTL230_UP} then\r\n begin\r\n {$IFDEF COMPILER7_UP}\r\n inherited Paint;\r\n {$ELSE}\r\n if Enabled then\r\n Details := ThemeServices.GetElementDetails(tbGroupBoxNormal)\r\n else\r\n Details := ThemeServices.GetElementDetails(tbGroupBoxDisabled);\r\n R := ClientRect;\r\n Inc(R.Top, Canvas.TextHeight('0') div 2);\r\n ThemeServices.DrawElement(Canvas.Handle, Details, R);\r\n\r\n CaptionRect := Rect(8, 0, Min(Canvas.TextWidth(Caption) + 8, ClientWidth - 8),\r\n Canvas.TextHeight(Caption));\r\n\r\n Canvas.Brush.Color := Self.Color;\r\n DrawThemedBackground(Self, Canvas, CaptionRect);\r\n ThemeServices.DrawText(Canvas.Handle, Details, Caption, CaptionRect, DT_LEFT, 0);\r\n {$ENDIF COMPILER7_UP}\r\n Exit;\r\n end;\r\n {$ENDIF JVCLThemesEnabled}\r\n with Canvas do\r\n begin\r\n LastBkMode := GetBkMode(Handle);\r\n try\r\n Font := Self.Font;\r\n H := TextHeight('0');\r\n R := Rect(0, H div 2 - 1, Width, Height);\r\n if Ctl3D then\r\n begin\r\n Inc(R.Left);\r\n Inc(R.Top);\r\n Brush.Color := clBtnHighlight;\r\n FrameRect( R);\r\n OffsetRect(R, -1, -1);\r\n Brush.Color := clBtnShadow;\r\n end\r\n else\r\n Brush.Color := clWindowFrame;\r\n FrameRect( R);\r\n if Text <> '' then\r\n begin\r\n if not UseRightToLeftAlignment then\r\n R := Rect(8, 0, 0, H)\r\n else\r\n R := Rect(R.Right - Canvas.TextWidth(Text) - 8, 0, 0, H);\r\n Flags := DrawTextBiDiModeFlags(DT_SINGLELINE);\r\n // calculate text rect\r\n SetBkMode(Handle, OPAQUE);\r\n DrawText(Handle, Text, Length(Text), R, Flags or DT_CALCRECT);\r\n Brush.Color := Color;\r\n if not Enabled then\r\n begin\r\n OffsetRect(R, 1, 1);\r\n Font.Color := clBtnHighlight;\r\n DrawText(Canvas, Text, Length(Text), R, Flags);\r\n OffsetRect(R, -1, -1);\r\n Font.Color := clBtnShadow;\r\n SetBkMode(Handle, TRANSPARENT);\r\n DrawText(Canvas, Text, Length(Text), R, Flags);\r\n end\r\n else\r\n DrawText(Canvas, Text, Length(Text), R, Flags);\r\n end;\r\n finally\r\n SetBkMode(Handle, LastBkMode);\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJvGroupBox.WantKey(Key: Integer; Shift: TShiftState): Boolean;\r\nbegin\r\n Result := inherited WantKey(Key, Shift);\r\n if Result then\r\n DoHotKey;\r\nend;\r\n\r\nprocedure TJvGroupBox.EnabledChanged;\r\nvar\r\n I: Integer;\r\nbegin\r\n inherited EnabledChanged;\r\n if PropagateEnable then\r\n for I := 0 to ControlCount - 1 do\r\n if Checkable then\r\n if Enabled then\r\n if Controls[I] = FCheckBox then\r\n Controls[I].Enabled := True\r\n else\r\n Controls[I].Enabled := Checked\r\n else\r\n Controls[I].Enabled := False\r\n else\r\n Controls[I].Enabled := Enabled;\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvGroupBox.DoHotKey;\r\nbegin\r\n if Assigned(FOnHotKey) then\r\n FOnHotKey(Self);\r\nend;\r\n\r\nfunction TJvGroupBox.GetCaption: TCaption;\r\nbegin\r\n if FCheckable then\r\n Result := FCheckBox.Caption\r\n else\r\n Result := inherited Caption;\r\nend;\r\n\r\nfunction TJvGroupBox.GetChecked: Boolean;\r\nbegin\r\n if FCheckable then\r\n Result := FCheckBox.Checked\r\n else\r\n Result := False;\r\nend;\r\n\r\nprocedure TJvGroupBox.SetCaption(const Value: TCaption);\r\nbegin\r\n if FCheckable then\r\n FCheckBox.Caption := Value\r\n else\r\n inherited Caption := Value;\r\nend;\r\n\r\nprocedure TJvGroupBox.SetCheckable(const Value: Boolean);\r\nbegin\r\n if FCheckable <> Value then\r\n begin\r\n if Value then\r\n begin\r\n FCheckBox := TJvCheckBox.Create(Self);\r\n FCheckBox.Parent := Self;\r\n FCheckBox.Top := 0;\r\n FCheckBox.Left := 8;\r\n FCheckBox.Caption := Caption;\r\n PropagateEnable := True;\r\n FCheckBox.OnClick := CheckBoxClick;\r\n FCheckBox.Checked := True;\r\n inherited Caption := '';\r\n end\r\n else\r\n begin\r\n inherited Caption := FCheckBox.Caption;\r\n FreeAndNil(FCheckBox);\r\n end;\r\n FCheckable := Value;\r\n end;\r\nend;\r\n\r\nprocedure TJvGroupBox.SetChecked(const Value: Boolean);\r\nbegin\r\n if Checkable then\r\n FCheckBox.Checked := Value;\r\nend;\r\n\r\nprocedure TJvGroupBox.CheckBoxClick(Sender: TObject);\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := 0 to ControlCount - 1 do\r\n if Controls[I] <> FCheckBox then\r\n Controls[I].Enabled := FCheckBox.Checked;\r\n \r\n if Assigned(FOnCheckBoxClick) then\r\n FOnCheckBoxClick(Self);\r\nend;\r\n\r\nprocedure TJvGroupBox.SetPropagateEnable(const Value: Boolean);\r\nvar\r\n I: Integer;\r\nbegin\r\n FPropagateEnable := Value;\r\n for I := 0 to ControlCount - 1 do\r\n Controls[I].Enabled := Enabled;\r\nend;\r\n\r\nfunction TJvGroupBox.StoredCheckable: Boolean;\r\nbegin\r\n { Write \"False\" to the DFM file because the checkbox is initialized with \"True\" }\r\n Result := FCheckable and not Checked;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvGroupHeader.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvGroupHeader.PAS, released on 2002-09-02.\r\n\r\nThe Initial Developer of the Original Code is Fernando Silva [fernando dott silva att myrealbox dott com]\r\nPortions created by Fernando Silva are Copyright (C) 2002 Fernando Silva.\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvGroupHeader.pas 13104 2011-09-07 06:50:43Z obones $\r\n\r\nunit JvGroupHeader;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Classes, Windows, Messages, Graphics, Controls, ExtCtrls,\r\n JvJCLUtils, JvComponent, JvTypes;\r\n\r\ntype\r\n TJvGroupHeaderOptions = class(TPersistent)\r\n private\r\n FBrush: TBrush;\r\n FHeight: Integer;\r\n FPen: TPen;\r\n FShape: TShapeType;\r\n FStyle: TJvBevelStyle;\r\n FOnChange: TNotifyEvent;\r\n procedure SetBrush(Value: TBrush);\r\n procedure SetHeight(Value: Integer);\r\n procedure SetPen(Value: TPen);\r\n procedure SetStyle(Value: TJvBevelStyle);\r\n procedure SetShape(Value: TShapeType);\r\n protected\r\n procedure DoChange(Sender: TObject);\r\n property OnChange: TNotifyEvent read FOnChange write FOnChange;\r\n public\r\n constructor Create;\r\n destructor Destroy; override;\r\n procedure Assign(Source: TPersistent); override;\r\n published\r\n property Brush: TBrush read FBrush write SetBrush;\r\n property Height: Integer read FHeight write SetHeight default 2;\r\n property Pen: TPen read FPen write SetPen;\r\n property Shape: TShapeType read FShape write SetShape default stRectangle;\r\n property Style: TJvBevelStyle read FStyle write SetStyle default bsLowered;\r\n end;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvGroupHeader = class(TJvGraphicControl)\r\n private\r\n FAlignment: TAlignment;\r\n FLayout: TJvLayout;\r\n// FLabelOptions: TJvGroupHeaderOptions;\r\n FBevelOptions: TJvGroupHeaderOptions;\r\n FBevelSpace: Integer;\r\n FPositionOffset: Integer;\r\n procedure SetPositionOffset(const Value: Integer);\r\n function GetTransparent: Boolean;\r\n procedure SetAlignment(Value: TAlignment);\r\n procedure SetTransparent(Value: Boolean);\r\n procedure SetLayout(Value: TJvLayout);\r\n procedure SetBevelOptions(Value: TJvGroupHeaderOptions);\r\n procedure SetBevelSpace(Value: Integer);\r\n// procedure SetLabelOptions(Value: TJvGroupHeaderOptions);\r\n protected\r\n procedure StyleChanged(Sender: TObject); virtual;\r\n procedure BevelLine(C: TColor; X, Y, Width: Integer); virtual;\r\n procedure DoDrawText(var Rect: TRect; Flags: Longint); virtual;\r\n function GetLabelText: string; virtual;\r\n procedure Paint; override;\r\n procedure TextChanged; override;\r\n procedure FontChanged; override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n property Canvas;\r\n published\r\n property Align;\r\n property Alignment: TAlignment read FAlignment write SetAlignment default taLeftJustify;\r\n property Anchors;\r\n property BiDiMode;\r\n property DragCursor;\r\n property DragKind;\r\n property ParentBiDiMode;\r\n property OnEndDock;\r\n property OnStartDock;\r\n property Caption;\r\n property Color;\r\n property Constraints;\r\n property DragMode;\r\n property Enabled;\r\n property Font;\r\n property ParentColor;\r\n property ParentFont;\r\n property ParentShowHint;\r\n property PopupMenu;\r\n property ShowHint;\r\n property Visible;\r\n property PositionOffset: Integer read FPositionOffset write SetPositionOffset default 0;\r\n property BevelOptions: TJvGroupHeaderOptions read FBevelOptions write SetBevelOptions;\r\n property BevelSpace: Integer read FBevelSpace write SetBevelSpace default 12;\r\n // (p3) is this used anywhere?\r\n// property LabelOptions: TJvGroupHeaderOptions read FLabelOptions write SetLabelOptions stored false;\r\n property Transparent: Boolean read GetTransparent write SetTransparent default False;\r\n property Layout: TJvLayout read FLayout write SetLayout default lTop;\r\n property OnClick;\r\n property OnContextPopup;\r\n property OnDblClick;\r\n property OnDragDrop;\r\n property OnDragOver;\r\n property OnEndDrag;\r\n property OnMouseDown;\r\n property OnMouseMove;\r\n property OnMouseUp;\r\n property OnStartDrag;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvGroupHeader.pas $';\r\n Revision: '$Revision: 13104 $';\r\n Date: '$Date: 2011-09-07 08:50:43 +0200 (mer. 07 sept. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n JvThemes;\r\n\r\n//=== { TJvGroupHeaderOptions } ==============================================\r\n\r\nconstructor TJvGroupHeaderOptions.Create;\r\nbegin\r\n inherited Create;\r\n FPen := TPen.Create;\r\n FPen.OnChange := DoChange;\r\n\r\n FBrush := TBrush.Create;\r\n FBrush.OnChange := DoChange;\r\n\r\n FShape := stRectangle;\r\n FStyle := bsLowered;\r\n FHeight := 2;\r\nend;\r\n\r\ndestructor TJvGroupHeaderOptions.Destroy;\r\nbegin\r\n FPen.Free;\r\n FBrush.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvGroupHeaderOptions.Assign(Source: TPersistent);\r\nvar\r\n FOldChange: TNotifyEvent;\r\nbegin\r\n if Source is TJvGroupHeaderOptions then\r\n begin\r\n FOldChange := FOnChange;\r\n try\r\n FOnChange := nil;\r\n Brush := TJvGroupHeaderOptions(Source).Brush;\r\n Height := TJvGroupHeaderOptions(Source).Height;\r\n Pen := TJvGroupHeaderOptions(Source).Pen;\r\n Shape := TJvGroupHeaderOptions(Source).Shape;\r\n Style := TJvGroupHeaderOptions(Source).Style;\r\n finally\r\n FOnChange := FOldChange;\r\n end;\r\n DoChange(Self);\r\n end\r\n else\r\n inherited Assign(Source);\r\nend;\r\n\r\nprocedure TJvGroupHeaderOptions.SetBrush(Value: TBrush);\r\nbegin\r\n FBrush.Assign(Value);\r\nend;\r\n\r\nprocedure TJvGroupHeaderOptions.SetHeight(Value: Integer);\r\nbegin\r\n if Value <> FHeight then\r\n begin\r\n FHeight := Value;\r\n DoChange(Self);\r\n end;\r\nend;\r\n\r\nprocedure TJvGroupHeaderOptions.SetPen(Value: TPen);\r\nbegin\r\n FPen.Assign(Value);\r\nend;\r\n\r\nprocedure TJvGroupHeaderOptions.SetStyle(Value: TJvBevelStyle);\r\nbegin\r\n if Value <> FStyle then\r\n begin\r\n FStyle := Value;\r\n DoChange(Self);\r\n end;\r\nend;\r\n\r\nprocedure TJvGroupHeaderOptions.SetShape(Value: TShapeType);\r\nbegin\r\n if Value <> FShape then\r\n begin\r\n FShape := Value;\r\n DoChange(Self);\r\n end;\r\nend;\r\n\r\nprocedure TJvGroupHeaderOptions.DoChange;\r\nbegin\r\n if Assigned(FOnChange) then\r\n FOnChange(Self);\r\nend;\r\n\r\n//=== { TJvGroupHeader } =====================================================\r\n\r\nconstructor TJvGroupHeader.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n ControlStyle := ControlStyle + [csOpaque, csReplicatable];\r\n {$IFDEF JVCLThemesEnabled}\r\n IncludeThemeStyle(Self, [csParentBackground]);\r\n {$ENDIF JVCLThemesEnabled}\r\n Width := 200;\r\n Height := 17;\r\n\r\n FBevelOptions := TJvGroupHeaderOptions.Create;\r\n FBevelOptions.OnChange := StyleChanged;\r\n FBevelSpace := 12;\r\n// FLabelOptions := TJvGroupHeaderOptions.Create;\r\n// FLabelOptions.OnChange := StyleChanged;\r\nend;\r\n\r\ndestructor TJvGroupHeader.Destroy;\r\nbegin\r\n FBevelOptions.Free;\r\n// FLabelOptions.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJvGroupHeader.GetLabelText: string;\r\nbegin\r\n Result := Caption;\r\nend;\r\n\r\nprocedure TJvGroupHeader.DoDrawText(var Rect: TRect; Flags: Longint);\r\nvar\r\n Text: string;\r\nbegin\r\n Text := GetLabelText;\r\n Flags := Flags or DT_NOPREFIX;\r\n Flags := DrawTextBiDiModeFlags(Flags);\r\n Canvas.Font := Font;\r\n if not Enabled then\r\n begin\r\n OffsetRect(Rect, 1, 1);\r\n Canvas.Font.Color := clBtnHighlight;\r\n DrawText(Canvas, Text, Length(Text), Rect, Flags);\r\n OffsetRect(Rect, -1, -1);\r\n Canvas.Font.Color := clBtnShadow;\r\n DrawText(Canvas, Text, Length(Text), Rect, Flags);\r\n end\r\n else\r\n DrawText(Canvas, Text, Length(Text), Rect, Flags);\r\nend;\r\n\r\nprocedure TJvGroupHeader.Paint;\r\nconst\r\n Alignments: array [TAlignment] of Word = (DT_LEFT, DT_RIGHT, DT_CENTER);\r\n WordWraps: array [Boolean] of Word = (0, DT_WORDBREAK);\r\nvar\r\n // Text\r\n Rect, CalcRect: TRect;\r\n DrawStyle: Longint;\r\n // Standard Bevel\r\n Color1, Color2: TColor;\r\n lbHeight, lbWidth: Integer;\r\n LX1, LX2, LX3, LX4, LY: Integer;\r\n // Shape Bevel\r\n X, Y, W, H, S: Integer;\r\nbegin\r\n // D R A W T E X T\r\n // ----------------\r\n Color1 := clBlack;\r\n Color2 := clBlack; // (p3) just to remove warnings...\r\n with Canvas do\r\n begin\r\n if not Transparent then\r\n begin\r\n Brush.Color := Self.Color;\r\n Brush.Style := bsSolid;\r\n DrawThemedBackground(Self, Canvas, ClientRect);\r\n end;\r\n Brush.Style := bsClear;\r\n Rect := ClientRect;\r\n // DoDrawText takes care of BiDi alignments\r\n DrawStyle := DT_EXPANDTABS or WordWraps[False] or Alignments[FAlignment];\r\n // Calculate vertical layout\r\n OffsetRect(Rect, FPositionOffset, 0);\r\n if FLayout <> lTop then\r\n begin\r\n CalcRect := Rect;\r\n DoDrawText(CalcRect, DrawStyle or DT_CALCRECT);\r\n if FLayout = lBottom then\r\n OffsetRect(Rect, 0, Height - CalcRect.Bottom)\r\n else\r\n OffsetRect(Rect, 0, (Height - CalcRect.Bottom) div 2);\r\n end;\r\n DoDrawText(Rect, DrawStyle);\r\n end;\r\n\r\n // C A L C U L A T E P O S I T I O N S\r\n // --------------------------------------\r\n lbHeight := Canvas.TextHeight(GetLabelText);\r\n lbWidth := Canvas.TextWidth(GetLabelText);\r\n\r\n LX1 := 0;\r\n LX2 := 0;\r\n LX3 := 0;\r\n LX4 := 0;\r\n case FAlignment of\r\n taLeftJustify:\r\n begin\r\n LX1 := 0;\r\n LX2 := PositionOffset - FBevelSpace;\r\n LX3 := PositionOffset + lbWidth + FBevelSpace;\r\n LX4 := Width - lbWidth - FBevelSpace;\r\n end;\r\n taCenter:\r\n begin\r\n LX1 := 0;\r\n LX2 := (Width - lbWidth) div 2 + PositionOffset - FBevelSpace;\r\n LX3 := LX2 + lbWidth + 2 * FBevelSpace;\r\n LX4 := Width;\r\n end;\r\n taRightJustify:\r\n begin\r\n LX1 := 0;\r\n LX2 := PositionOffset + Width - lbWidth - FBevelSpace;\r\n LX3 := LX2 + lbWidth + 2 * FBevelSpace;\r\n LX4 := Width;\r\n end;\r\n end;\r\n if LX2 < LX1 then\r\n LX2 := LX1;\r\n if LX4 < LX3 then\r\n LX4 := LX3;\r\n\r\n LY := 0;\r\n case FLayout of\r\n lTop:\r\n LY := lbHeight div 2;\r\n lCenter:\r\n LY := Height div 2;\r\n lBottom:\r\n LY := Height - (lbHeight div 2);\r\n end;\r\n\r\n // D R A W B E V E L\r\n // ------------------\r\n if BevelOptions.Style <> bsShape then\r\n begin\r\n with Canvas do\r\n begin\r\n // Assign colors\r\n case BevelOptions.Style of\r\n bsLowered:\r\n begin\r\n Color1 := clBtnShadow;\r\n Color2 := clBtnHighlight;\r\n end;\r\n bsRaised:\r\n begin\r\n Color1 := clBtnHighlight;\r\n Color2 := clBtnShadow;\r\n end;\r\n end;\r\n\r\n if csDesigning in ComponentState then\r\n begin\r\n Pen.Style := psSolid;\r\n Pen.Mode := pmCopy;\r\n Pen.Color := clBlack;\r\n Brush.Style := bsSolid;\r\n end;\r\n\r\n Pen.Width := 1;\r\n\r\n // Locate and draw the line\r\n\r\n if LX1 <> LX2 then\r\n begin\r\n BevelLine(Color1, LX1, LY, LX2);\r\n BevelLine(Color2, LX1, LY + 1, LX2);\r\n end;\r\n if (LX3 <> LX4) then // Draw right bevel\r\n begin\r\n BevelLine(Color1, LX3, LY, LX4);\r\n BevelLine(Color2, LX3, LY + 1, LX4);\r\n end;\r\n end;\r\n end\r\n else\r\n with Canvas do\r\n begin\r\n Pen := BevelOptions.Pen;\r\n Brush := BevelOptions.Brush;\r\n X := LX1 + (Pen.Width div 2);\r\n Y := LY - (BevelOptions.Height div 2) + (Pen.Width div 2);\r\n W := LX2 - Pen.Width + 1;\r\n H := BevelOptions.Height - Pen.Width + 1;\r\n if Pen.Width = 0 then\r\n begin\r\n Dec(W);\r\n Dec(H);\r\n end;\r\n if W < H then\r\n S := W\r\n else\r\n S := H;\r\n if BevelOptions.Shape in [stSquare, stRoundSquare, stCircle] then\r\n begin\r\n Inc(X, (W - S) div 2);\r\n Inc(Y, (H - S) div 2);\r\n W := S;\r\n H := S;\r\n lbWidth := Width - X * 2 - W;\r\n end\r\n else\r\n lbWidth := Width - X - W;\r\n case BevelOptions.Shape of\r\n stRectangle, stSquare:\r\n begin\r\n Rectangle(X, Y, X + W, Y + H);\r\n if FAlignment = taCenter then\r\n Rectangle(X + lbWidth, Y, X + W + lbWidth, Y + H);\r\n end;\r\n stRoundRect, stRoundSquare:\r\n begin\r\n RoundRect(X, Y, X + W, Y + H, S div 4, S div 4);\r\n if FAlignment = taCenter then\r\n RoundRect(X + lbWidth, Y, X + W + lbWidth, Y + H, S div 4, S div 4);\r\n end;\r\n stCircle, stEllipse:\r\n begin\r\n Ellipse(X, Y, X + W, Y + H);\r\n if FAlignment = taCenter then\r\n Ellipse(X + lbWidth, Y, X + W + lbWidth, Y + H);\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvGroupHeader.SetAlignment(Value: TAlignment);\r\nbegin\r\n if FAlignment <> Value then\r\n begin\r\n FAlignment := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nfunction TJvGroupHeader.GetTransparent: Boolean;\r\nbegin\r\n Result := not (csOpaque in ControlStyle);\r\nend;\r\n\r\nprocedure TJvGroupHeader.SetTransparent(Value: Boolean);\r\nbegin\r\n if Transparent <> Value then\r\n begin\r\n if Value then\r\n ControlStyle := ControlStyle - [csOpaque]\r\n else\r\n ControlStyle := ControlStyle + [csOpaque];\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvGroupHeader.SetLayout(Value: TJvLayout);\r\nbegin\r\n if FLayout <> Value then\r\n begin\r\n FLayout := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvGroupHeader.SetPositionOffset(const Value: Integer);\r\nbegin\r\n if Value <> FPositionOffset then\r\n begin\r\n FPositionOffset := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvGroupHeader.TextChanged;\r\nbegin\r\n inherited TextChanged;\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvGroupHeader.FontChanged;\r\nbegin\r\n inherited FontChanged;\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvGroupHeader.SetBevelSpace(Value: Integer);\r\nbegin\r\n if Value <> FBevelSpace then\r\n begin\r\n FBevelSpace := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvGroupHeader.StyleChanged(Sender: TObject);\r\nbegin\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvGroupHeader.BevelLine(C: TColor; X, Y, Width: Integer);\r\nbegin\r\n with Canvas do\r\n begin\r\n Pen.Color := C;\r\n MoveTo(X, Y);\r\n LineTo(X + Width, Y);\r\n end;\r\nend;\r\n\r\nprocedure TJvGroupHeader.SetBevelOptions(Value: TJvGroupHeaderOptions);\r\nbegin\r\n FBevelOptions.Assign(Value);\r\nend;\r\n\r\n{\r\nprocedure TJvGroupHeader.SetLabelOptions(Value: TJvGroupHeaderOptions);\r\nbegin\r\n FLabelOptions.Assign(Value);\r\nend;\r\n}\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvHLEditor.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvHLEditor.PAS, released on 2002-07-04.\r\n\r\nThe Initial Developers of the Original Code are: Andrei Prygounkov \r\nCopyright (c) 1999, 2002 Andrei Prygounkov\r\nAll Rights Reserved.\r\n\r\nContributor(s): Eswar Prakash R [eswar dott prakash att gmail.com]\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\ncomponent : TJvHLEditor\r\ndescription : JvEditor with built-in highlighting for:\r\n pascal, cbuilder, sql, python, jscript,\r\n vbscript, perl, ini, html, not quite c\r\n\r\nKnown Issues:\r\n (rom) source cleaning incomplete\r\n (rom) GetAttr should be broken up further\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvHLEditor.pas 13288 2012-04-27 08:32:34Z ahuser $\r\n\r\n{ history\r\n (JVCL Library versions) :\r\n 1.03:\r\n - first release;\r\n 1.11:\r\n - improvements in custom reserved words support;\r\n - comments works better in custom reserved words;\r\n 1.17:\r\n - python highlighting by Rafal Smotrzyk - rsmotrzyk att mikroplan dott com dott pl;\r\n 1.17.2:\r\n - jscript, vbscript highlighting by Rafal Smotrzyk - rsmotrzyk att mikroplan dott com dott pl;\r\n 1.17.6:\r\n - html highlighting;\r\n 1.12.2:\r\n - fixed bug with pressing End-key if CursorBeoyondEOF enabled\r\n (greetings to Andre N Belokon)\r\n 1.23:\r\n - fixed another bug in comment checking (range check error)\r\n (greetings to Willo vd Merwe)\r\n 1.23.1:\r\n - first version of perl highlighter;\r\n 1.41:\r\n - fixed another bug in comment checking;\r\n 1.51.3 (JVCL Library 1.51 with Update 3):\r\n - fixed bug: exception on comments in \"c++, java, sql\" - mode;\r\n 1.51.4 (JVCL Library 1.51 with Update 4):\r\n - ini-file highlighter;\r\n - fixed bug: custom reserved words not working;\r\n 1.61:\r\n - new: in html-highlighter unknown (not html) tag highlighted with\r\n \"statement\" color. This allows to use html-highlighter to display\r\n xml-files.\r\n 2.10.2: (changes by Andreas Hausladen)\r\n - C/C++ line continuation symbol '\\' extends the highlight colors to the\r\n next line (LongToken=True)\r\n - \"Not Quite C\" highlighter (C similar, for programming LEGO MindStorm(R) robots)\r\n - fixed bug: SetBlockColor raise an exception (AV) if iEnd becomes greater than\r\n MAX_X\r\n - in TRAHLEditor.GetAttr all IsXxxKeyWord get a CONST string, so no compiler\r\n magic LStrAddRef is needed.\r\n - some speed optimations\r\n - new property DelphiColors: Boolean\r\n - renamed all \"Identifer\" to \"Identifier\". published property \"Identifer\"\r\n still exists but uses \"FIdentifier\"\r\n - added some new DelphiKeyWord\r\n - fixed bug: RescanLong() may exceed FLongDesc[] dimension\r\n 2.10.3: (changes by Andreas Hausladen\r\n - faster RescanLong\r\n - faster KeyWord search for drawing\r\n 3.0:\r\n - added TJvEditorHighlighter component\r\n\r\n}\r\n\r\nunit JvHLEditor;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n Windows,\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n SysUtils, Classes, Graphics,\r\n JvEditor, JvEditorCommon, JvHLParser;\r\n\r\ntype\r\n TJvHLEditor = class;\r\n\r\n TOnReservedWord = procedure(Sender: TObject; Token: string;\r\n var Reserved: Boolean) of object;\r\n\r\n TJvEditorHighlighter = class(TComponent)\r\n protected\r\n procedure GetAttr(Editor: TJvHLEditor; Lines: TStrings; Line, ColBeg, ColEnd: Integer;\r\n LongToken: TLongTokenType; var LineAttrs: TLineAttrs); virtual; abstract;\r\n procedure ScanLongTokens(Editor: TJvHLEditor; Lines: TStrings; Line: Integer;\r\n var FLong: TLongTokenType); virtual; abstract;\r\n function GetRescanLongKeys(Editor: TJvHLEditor; Action: TModifiedAction;\r\n ACaretX, ACaretY: Integer; const Text: string): Boolean; virtual; abstract;\r\n end;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvHLEditor = class(TJvEditor, IJvHLEditor)\r\n private\r\n Parser: TJvIParser;\r\n FHighlighter: TJvHighlighter;\r\n FColors: TJvColors;\r\n FLine: string;\r\n FLineNum: Integer;\r\n FLong: TLongTokenType;\r\n FLongTokens: Boolean;\r\n FLongDesc: array {[0..Max_Line]} of TLongTokenType;\r\n FSyntaxHighlighting: Boolean;\r\n FSyntaxHighlighter: TJvEditorHighlighter;\r\n FOnReservedWord: TOnReservedWord;\r\n\r\n // Coco/R\r\n ProductionsLine: Integer;\r\n function RescanLong(iLine: Integer): Boolean;\r\n procedure CheckInLong;\r\n function FindLongEnd: Integer;\r\n procedure SetHighlighter(const Value: TJvHighlighter);\r\n function GetDelphiColors: Boolean;\r\n procedure SetDelphiColors(Value: Boolean);\r\n function GetColors: TJvColors;\r\n procedure SetColors(const Value: TJvColors);\r\n function GetSyntaxHighlighting: Boolean;\r\n procedure SetSyntaxHighlighting(Value: Boolean);\r\n function GetHighlighter: TJvHighlighter;\r\n protected\r\n procedure Loaded; override;\r\n procedure Notification(AComponent: TComponent; Operation: TOperation); override;\r\n procedure GetAttr(Line, ColBeg, ColEnd: Integer); override;\r\n procedure TextModified(ACaretX, ACaretY: Integer; Action: TModifiedAction;\r\n const Text: string); override;\r\n function GetReservedWord(const Token: string; var Reserved: Boolean): Boolean; virtual;\r\n function UserReservedWords: Boolean; virtual;\r\n procedure SetSyntaxHighlighter(const Value: TJvEditorHighlighter);\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n procedure Assign(Source: TPersistent); override;\r\n published\r\n property Highlighter: TJvHighlighter read GetHighlighter write SetHighlighter default hlPascal;\r\n property Colors: TJvColors read GetColors write SetColors;\r\n property DelphiColors: Boolean read GetDelphiColors write SetDelphiColors stored False;\r\n property LongTokens: Boolean read FLongTokens write FLongTokens default True;\r\n property OnReservedWord: TOnReservedWord read FOnReservedWord write FOnReservedWord;\r\n property SyntaxHighlighting: Boolean read GetSyntaxHighlighting write SetSyntaxHighlighting stored False;\r\n property SyntaxHighlighter: TJvEditorHighlighter read FSyntaxHighlighter write SetSyntaxHighlighter;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvHLEditor.pas $';\r\n Revision: '$Revision: 13288 $';\r\n Date: '$Date: 2012-04-27 10:32:34 +0200 (ven. 27 avr. 2012) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n Math,\r\n JvConsts, JvJCLUtils, JvJVCLUtils;\r\n\r\nfunction LastNonSpaceChar(const S: string): Char;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := #0;\r\n I := Length(S);\r\n while (I > 0) and (S[I] = ' ') do\r\n Dec(I);\r\n if I > 0 then\r\n Result := S[I];\r\nend;\r\n\r\nfunction GetTrimChar(const S: string; Index: Integer): Char;\r\nvar\r\n LS, L: Integer;\r\nbegin\r\n LS := Length(S);\r\n if LS <> 0 then\r\n begin\r\n L := 1;\r\n while (L <= LS) and (S[L] = ' ') do\r\n Inc(L);\r\n if L <= LS then\r\n Result := S[L - 1 + Index]\r\n else\r\n Result := S[Index];\r\n end\r\n else\r\n Result := #0;\r\nend;\r\n\r\nfunction StrScanNil(P: PChar; Ch: Char): PChar;\r\nbegin\r\n Result := P;\r\n while True do\r\n begin\r\n {$IFNDEF SUPPORTS_UNICODE}\r\n while Result[0] in LeadBytes do\r\n Inc(Result); // mbcs\r\n {$ENDIF ~SUPPORTS_UNICODE}\r\n if Result[0] = Ch then\r\n Exit\r\n else\r\n if Result[0] = #0 then\r\n begin\r\n Result := nil;\r\n Exit;\r\n end;\r\n {$IFDEF SUPPORTS_UNICODE}\r\n Result := StrNextChar(Result);\r\n {$ELSE}\r\n Inc(Result);\r\n {$ENDIF SUPPORTS_UNICODE}\r\n end;\r\nend;\r\n\r\nfunction HasStringOpenEnd(Lines: TStrings; iLine: Integer): Boolean;\r\n{ find C/C++ \"line breaker\" '\\' }\r\nvar\r\n I: Integer;\r\n IsOpen: Boolean;\r\n P, F: PChar;\r\n S: string;\r\nbegin\r\n Result := False;\r\n if (iLine < 0) or (iLine >= Lines.Count) then\r\n Exit;\r\n I := iLine - 1;\r\n IsOpen := False;\r\n if (I >= 0) and (LastNonSpaceChar(Lines[I]) = '\\') then // check prior lines\r\n IsOpen := HasStringOpenEnd(Lines, I);\r\n S := Lines[iLine];\r\n F := PChar(S);\r\n P := F;\r\n repeat\r\n P := StrScanNil(P, Char('\"'));\r\n if P <> nil then\r\n begin\r\n if (P = F) or (P[-1] <> '\\') then\r\n IsOpen := not IsOpen\r\n else\r\n begin\r\n // count the backslashes\r\n I := 1;\r\n while (P-1-I > F) and (P[-1-I] = '\\') do\r\n Inc(I);\r\n if I mod 2 = 0 then\r\n IsOpen := not IsOpen;\r\n end;\r\n Inc(P);\r\n end;\r\n until P = nil;\r\n Result := IsOpen;\r\nend;\r\n\r\n//=== { TJvHLEditor } ========================================================\r\n\r\nconstructor TJvHLEditor.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n Parser := TJvIParser.Create;\r\n Parser.ReturnComments := True;\r\n FHighlighter := hlPascal;\r\n FColors := TJvColors.Create;\r\n FLongTokens := True;\r\n FSyntaxHighlighting := True;\r\n ProductionsLine := High(Integer);\r\nend;\r\n\r\ndestructor TJvHLEditor.Destroy;\r\nbegin\r\n Parser.Free;\r\n FColors.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvHLEditor.Notification(AComponent: TComponent; Operation: TOperation);\r\nbegin\r\n inherited Notification(AComponent, Operation);\r\n if (Operation = opRemove) and (AComponent = FSyntaxHighlighter) then\r\n SyntaxHighlighter := nil;\r\nend;\r\n\r\nprocedure TJvHLEditor.Loaded;\r\nbegin\r\n inherited Loaded;\r\n RescanLong(0);\r\nend;\r\n\r\nprocedure TJvHLEditor.SetHighlighter(const Value: TJvHighlighter);\r\nbegin\r\n if FHighlighter <> Value then\r\n begin\r\n FHighlighter := Value;\r\n case FHighlighter of\r\n hlPascal:\r\n Parser.Style := psPascal;\r\n hlCBuilder, hlJava, hlJScript, hlNQC, hlCSharp:\r\n Parser.Style := psCpp;\r\n hlPython:\r\n Parser.Style := psPython;\r\n hlVB:\r\n Parser.Style := psVB;\r\n hlHtml:\r\n Parser.Style := psHtml;\r\n hlPerl:\r\n Parser.Style := psPerl;\r\n hlIni:\r\n Parser.Style := psPascal;\r\n hlCocoR:\r\n Parser.Style := psCocoR;\r\n hlPhp:\r\n Parser.Style := psPhp;\r\n hlSql:\r\n Parser.Style := psSql;\r\n end;\r\n RescanLong(0);\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvHLEditor.GetAttr(Line, ColBeg, ColEnd: Integer);\r\nconst\r\n Symbols = [',', ':', ';', '.', '[', ']', '(', ')', '=', '+',\r\n '-', '/', '<', '>', '%', '*', '~', '''', '\\', '^', '@', '{', '}',\r\n '#', '|', '&'];\r\n\r\nconst\r\n DelphiKeyWords =\r\n ' constructor destructor string record procedure with of' +\r\n ' repeat until try finally except for to downto case' +\r\n ' type interface implementation initialization finalization' +\r\n ' default private public protected published automated property' +\r\n ' program read write override object nil raise' +\r\n ' on set xor shr shl begin end args if then else' +\r\n ' endif goto while do var or and not mod div unit' +\r\n ' function uses external const class inherited' +\r\n ' register stdcall cdecl safecall pascal is as package program' +\r\n ' external overload platform deprecated implements export contains' +\r\n ' requires resourcestring message dispid assembler asm abstract absolute' +\r\n ' dispinterface file threadvar library' +\r\n // TurboPascal\r\n ' interrupt inline near far' +\r\n // Delphi 8\r\n ' operator strict final unsafe sealed static ';\r\n\r\n BuilderKeyWords =\r\n ' __asm _asm asm auto __automated break bool case catch __cdecl' +\r\n ' _cdecl cdecl char class __classid __closure const const_cast' +\r\n ' continue __declspec default delete __dispid do double dynamic_cast' +\r\n ' else enum __except explicit _export __export extern false __fastcall' +\r\n ' _fastcall __finally float for friend goto if __import _import inline' +\r\n ' int __int8 __int16 __int32 __int64 long mutable namespace new operator' +\r\n ' __pascal _pascal pascal private protected __property public __published' +\r\n ' register reinterpret_cast return __rtti short signed sizeof static static_cast' +\r\n ' __stdcall _stdcall struct switch template this __thread throw true __try' +\r\n ' try typedef typename typeid union using unsigned virtual void volatile' +\r\n ' wchar_t while ';\r\n\r\n NQCKeyWords = {Not Quite C - a C similar language for programming LEGO MindStorm(R) robots }\r\n ' __event_src __type acquire break __sensor abs asm case catch const' +\r\n ' continue default do else false for if inline' +\r\n ' int monitor repeat return signed start stop sub switch task true' +\r\n ' until void while ';\r\n\r\n // REPLACE keyword added to the list\r\n SQLKeyWords =\r\n ' active as add asc after ascending all at alter auto' +\r\n ' and autoddl any avg based between basename blob' +\r\n ' base_name blobedit before buffer begin by cache compiletime' +\r\n ' cast computed char close character conditional character_length connect' +\r\n ' char_length constraint check containing check_point_len continue check_point_length count' +\r\n ' collate create collation cstring column current commit cursor' +\r\n ' committed database descending date describe db_key descriptor debug disconnect' +\r\n ' dec display decimal distinct declare do default domain' +\r\n ' delete double desc drop echo exception edit execute' +\r\n ' else exists end exit entry_point extern escape external' +\r\n ' event extract fetch foreign file found filter from' +\r\n ' float full for function gdscode grant generator group' +\r\n ' gen_id commit_group_wait global group_commit_wait_time goto' +\r\n ' having help if input_type immediate insert in int' +\r\n ' inactive integer index into indicator is init isolation' +\r\n ' inner isql input join key' +\r\n ' lc_messages like lc_type logfile left log_buffer_size length log_buf_size' +\r\n ' lev long level manual merge max message' +\r\n ' maximum min maximum_segment minimum max_segment module_name names not' +\r\n ' national null natural numeric nchar num_log_bufs no num_log_buffers' +\r\n ' noauto octet_length or of order on outer only output' +\r\n ' open output_type option overflow page post_event pagelength precision' +\r\n ' pages prepare page_size procedure parameter protected password primary' +\r\n ' plan privileges position public quit' +\r\n ' raw_partitions retain rdb db_key return read replace returning_values real returns' +\r\n ' record_version revoke references right release rollback reserv runtime replace' +\r\n ' reserving schema sql segment sqlcode select sqlerror set sqlwarning' +\r\n ' shadow stability shared starting shell starts show statement' +\r\n ' singular static size statistics smallint sub_type snapshot sum' +\r\n ' some suspend sort table translate terminator translation then trigger to trim' +\r\n ' transaction uncommitted upper union user unique using update' +\r\n ' value varying values version varchar view variable' +\r\n ' wait while when with whenever work where write' +\r\n ' term new old ';\r\n\r\n PythonKeyWords =\r\n ' and del for is raise' +\r\n ' assert elif from lambda return' +\r\n ' break else global not try' +\r\n ' class except if or while' +\r\n ' continue exec import pass' +\r\n ' def finally in print ';\r\n\r\n JavaKeyWords =\r\n ' abstract delegate if boolean do implements break double import' +\r\n ' byte else instanceof case extends int catch false interface' +\r\n ' char final long class finally multicast continue float' +\r\n ' default for native short transient new static true' +\r\n ' null super try package switch void private synchronized volatile' +\r\n ' protected this while public throw return throws ';\r\n JScriptKeyWords =\r\n//'@cc_on @if @set'\r\n ' break delete function return typeof case do if switch var' +\r\n ' catch else in this void continue false instanceof throw while' +\r\n ' debugger finally new true with default for null try' +\r\n ' abstract double goto native static boolean enum implements package super' +\r\n ' byte export import private synchronized char extends int protected throws' +\r\n ' class final interface public transient const float long short volatile' ;\r\n\r\n VBKeyWords =\r\n ' as and base binary byref byval call case class compare const date debug declare deftype dim do each else elseif ' +\r\n ' empty end endif enum eqv erase error event execute exit explicit false for friend function get' +\r\n ' global gosub goto if imp implements input is kill len let line load lock loop lset me mid mod name new next not nothing null on open option optional' +\r\n ' or paramarray preserve print private property public raiseevent randomize redim rem' +\r\n ' resume return seek select set static step' +\r\n ' string sub then time to true unlock until wend while with withevents xor ';\r\n\r\n VBStatements =\r\n ' access alias any beep ccur cdbl chdir chdrive choose' +\r\n ' chr cint clear clng clone close cls command compare' +\r\n ' cos csng cstr curdir currency cvar cvdate ' +\r\n ' defcur defdbl defint deflng defsng defstr deftype defvar delete deletesetting' +\r\n ' doevents double dynaset edit environ eof erl err exp fix format ' +\r\n ' hex int integer isdate isempty isnull isnumeric lbound lcase' +\r\n ' lib like loc local lof long mkdir oct output pset put' +\r\n ' random read refresh reset restore rmdir rnd rset savesetting ' +\r\n ' sendkeys shared single stop system text type typeof ubound unload ' +\r\n ' using variant vartype write';\r\n\r\n HTMLTags =\r\n ' doctype a address applet area b base basefont bgsound big blink ' +\r\n ' blockquote body br caption center cite code col colgroup comment ' +\r\n ' dfn dir li div dl dt dd em embed font form frame frameset h align ' +\r\n ' h1 h2 h3 h4 h5 h6 head hr html i iframe img input isindex kbd link ' +\r\n ' listing map marquee menu meta multicol nextid nobr noframes noscript ' +\r\n ' object ol option p plaintext pre s samp script select small sound ' +\r\n ' spacer span strike strong style sub sup table tbody td textarea tfoot' +\r\n ' th thead title tr tt u ul var wbr xmp ';\r\n\r\n HTMLSpecChars =\r\n ' Aacute aacute acirc Acirc acute AElig aelig agrave Agrave alefsym ' +\r\n ' alpha Alpha AMP amp and ang Aring aring asymp atilde Atilde Auml ' +\r\n ' auml bdquo beta Beta brvbar bull cap Ccedil ccedil cedil cent chi ' +\r\n ' Chi circ clubs cong copy COPY crarr cup curren dagger Dagger dArr ' +\r\n ' darr deg Delta delta diams divide eacute Eacute ecirc Ecirc Egrave ' +\r\n ' egrave empty emsp ensp Epsilon epsilon equiv eta Eta ETH eth Euml ' +\r\n ' euml euro exist fnof forall frac12 frac14 frac34 frasl Gamma gamma ' +\r\n ' ge gt GT harr hArr hearts hellip iacute Iacute Icirc icirc iexcl Igrave ' +\r\n ' igrave image infin int Iota iota iquest isin Iuml iuml kappa Kappa Lambda ' +\r\n ' lambda lang laquo larr lArr lceil ldquo le lfloor lowast loz lrm lsaquo ' +\r\n ' lsquo lt LT macr mdash micro middot minus mu Mu nabla nbsp ndash ne ' +\r\n ' ni not notin nsub Ntilde ntilde Nu nu oacute Oacute ocirc Ocirc oelig ' +\r\n ' OElig ograve Ograve oline Omega omega omicron Omicron oplus or ordf ' +\r\n ' ordm Oslash oslash Otilde otilde otimes ouml Ouml para part permil ' +\r\n ' perp phi Phi Pi pi piv plusmn pound Prime prime prod prop psi Psi quot ' +\r\n ' QUOT radic rang raquo rArr rarr rceil rdquo real REG reg rfloor Rho ' +\r\n ' rho rlm rsaquo rsquo sbquo scaron Scaron sdot sect shy Sigma sigma ' +\r\n ' sigmaf sim spades sub sube sum sup sup1 sup2 sup3 supe szlig Tau ' +\r\n ' tau there4 Theta theta thetasym thinsp THORN thorn tilde times trade ' +\r\n ' Uacute uacute uArr uarr ucirc Ucirc ugrave Ugrave uml upsih upsilon ' +\r\n ' Upsilon uuml Uuml weierp xi Xi Yacute yacute yen yuml Yuml zeta Zeta ' +\r\n ' zwj zwnj ';\r\n\r\n PerlKeyWords =\r\n ' sub if else unless foreach next local ' +\r\n ' return defined until while do elsif eq ';\r\n\r\n PerlStatements =\r\n ' stat die open print push close defined chdir last read chop ' +\r\n ' keys sort bind unlink select length ';\r\n\r\n CocoKeyWords = DelphiKeyWords +\r\n ' compiler productions delphi end_delphi ignore case characters ' +\r\n ' tokens create destroy errors comments from nested chr any ' +\r\n ' description ';\r\n\r\n CSharpKeyWords =\r\n ' abstract as base bool break byte case catch char checked class ' +\r\n ' const continue decimal default delegate do double else enum event ' +\r\n ' explicit extern false finally fixed float for foreach goto if ' +\r\n ' implicit in int interface internal is lock long namespace new null ' +\r\n ' object operator out override params private protected public readonly ' +\r\n ' ref return sbyte sealed short sizeof stackalloc static string struct ' +\r\n ' switch this throw true try typeof uint ulong unchecked unsafe ushort ' +\r\n ' using virtual void volatile while ';\r\n\r\n function PosI(const S1, S2: string): Boolean;\r\n var\r\n F, P: PChar;\r\n Len: Integer;\r\n begin\r\n Len := Length(S1);\r\n Result := True;\r\n P := PChar(S2);\r\n while P[0] <> #0 do\r\n begin\r\n while P[0] = ' ' do\r\n Inc(P);\r\n F := P;\r\n while not (P[0] <= #32) do\r\n Inc(P);\r\n if (P - F) = Len then\r\n if StrLIComp(PChar(S1), F, Len) = 0 then\r\n Exit;\r\n end;\r\n Result := False;\r\n end;\r\n\r\n function PosNI(const S1, S2: string): Boolean;\r\n var\r\n F, P: PChar;\r\n Len: Integer;\r\n begin\r\n Len := Length(S1);\r\n Result := True;\r\n P := PChar(S2);\r\n while P[0] <> #0 do\r\n begin\r\n while P[0] = ' ' do\r\n Inc(P);\r\n F := P;\r\n while not (P[0] <= #32) do\r\n Inc(P);\r\n if (P - F) = Len then\r\n if StrLComp(PChar(S1), F, Len) = 0 then\r\n Exit;\r\n end;\r\n Result := False;\r\n end;\r\n\r\n function IsDelphiKeyWord(const St: string): Boolean;\r\n begin\r\n Result := PosI(St, DelphiKeyWords);\r\n end;\r\n\r\n function IsBuilderKeyWord(const St: string): Boolean;\r\n begin\r\n Result := PosNI(St, BuilderKeyWords);\r\n end;\r\n\r\n function IsNQCKeyWord(const St: string): Boolean;\r\n begin\r\n Result := PosNI(St, NQCKeyWords);\r\n end;\r\n\r\n function IsJavaKeyWord(const St: string): Boolean;\r\n begin\r\n Result := PosNI(St, JavaKeyWords);\r\n end;\r\n function IsJScriptKeyWord(const St: string): Boolean;\r\n begin\r\n Result := PosNI(St, JScriptKeyWords);\r\n end;\r\n\r\n function IsVBKeyWord(const St: string): Boolean;\r\n begin\r\n Result := PosI(St, VBKeyWords);\r\n end;\r\n\r\n function IsVBStatement(const St: string): Boolean;\r\n begin\r\n Result := PosI(St, VBStatements);\r\n end;\r\n\r\n function IsSQLKeyWord(const St: string): Boolean;\r\n begin\r\n Result := PosI(St, SQLKeyWords);\r\n end;\r\n\r\n function IsPythonKeyWord(const St: string): Boolean;\r\n begin\r\n Result := PosNI(St, PythonKeyWords);\r\n end;\r\n\r\n function IsHtmlTag(const St: string): Boolean;\r\n begin\r\n Result := PosI(St, HTMLTags);\r\n end;\r\n\r\n function IsHtmlSpecChar(const St: string): Boolean;\r\n begin\r\n Result := PosI(St, HTMLSpecChars);\r\n end;\r\n\r\n function IsPerlKeyWord(const St: string): Boolean;\r\n begin\r\n Result := PosNI(St, PerlKeyWords);\r\n end;\r\n\r\n function IsPerlStatement(const St: string): Boolean;\r\n begin\r\n Result := PosNI(St, PerlStatements);\r\n end;\r\n\r\n function IsCocoKeyWord(const St: string): Boolean;\r\n begin\r\n Result := PosI(St, CocoKeyWords);\r\n end;\r\n\r\n function IsPhpKeyWord(const St: string): Boolean;\r\n begin\r\n Result := PosNI(St, PerlKeyWords);\r\n end;\r\n\r\n function IsCSharpKeyWord(const St: string): Boolean;\r\n begin\r\n Result := PosNI(St, CSharpKeyWords);\r\n end;\r\n\r\n function IsComment(const St: string): Boolean;\r\n var\r\n LS: Integer;\r\n begin\r\n LS := Length(St);\r\n case Highlighter of\r\n hlPascal:\r\n Result := ((LS > 0) and (St[1] = '{')) or\r\n ((LS > 1) and (((St[1] = '(') and (St[2] = '*')) or\r\n ((St[1] = '/') and (St[2] = '/'))));\r\n hlCBuilder, hlJava, hlJScript, hlPhp, hlNQC, hlCSharp:\r\n Result := (LS > 1) and (St[1] = '/') and\r\n ((St[2] = '*') or (St[2] = '/'));\r\n // Support for SQL comment line beginning with --\r\n hlSql:\r\n Result := (LS > 1) and (((St[1] = '-') and\r\n (St[2] = '-')) or\r\n (St[1] = '/') and ((St[2] = '*'))); // support for /* */\r\n // HTML multi line comment support\r\n hlHtml:\r\n Result := (LS > 3) and (St[1] = '<') and (St[2] = '!') and\r\n (St[3] = '-') and (St[4] = '-');\r\n hlVB:\r\n Result := (LS > 0) and (St[1] = '''');\r\n hlPython, hlPerl:\r\n Result := (LS > 0) and (St[1] = '#');\r\n hlIni:\r\n Result := (LS > 0) and ((St[1] = '#') or (St[1] = ';'));\r\n hlCocoR:\r\n Result := (LS > 1) and (((St[1] = '/') and (St[2] = '/')) or\r\n ((St[1] = '(') and (St[2] = '*')) or\r\n ((St[1] = '/') and (St[2] = '*'))\r\n );\r\n else\r\n Result := False;\r\n end;\r\n end;\r\n\r\n function IsPreproc(const St: string): Boolean;\r\n var\r\n LS: Integer;\r\n begin\r\n LS := Length(St);\r\n case Highlighter of\r\n hlPascal:\r\n Result := ((LS > 0) and ((St[1] = '{') and (St[2] = '$'))) or\r\n ((LS > 1) and (((St[1] = '(') and (St[2] = '*') and (St[3] = '$'))));\r\n {hlCBuilder, hlSql, hlJava, hlJscript, hlPhp, hlNQC:\r\n hlVB:\r\n hlPython, hlPerl:\r\n hlIni:\r\n hlCocoR:}\r\n else\r\n Result := False;\r\n end;\r\n end;\r\n\r\n function IsStringConstant(const St: string): Boolean;\r\n var\r\n LS: Integer;\r\n begin\r\n LS := Length(St);\r\n case FHighlighter of\r\n hlPascal, hlCBuilder, hlSql, hlPython, hlJava, hlJScript, hlPerl, hlCocoR, hlPhp,\r\n hlNQC, hlCSharp:\r\n Result := (LS > 0) and ((St[1] = '''') or (St[1] = '\"'));\r\n hlVB:\r\n Result := (LS > 0) and (St[1] = '\"');\r\n hlHtml:\r\n Result := False;\r\n else\r\n Result := False; { unknown Highlighter ? }\r\n end;\r\n end;\r\n\r\n procedure SetBlockColor(iBeg, iEnd: Integer; Color: TJvSymbolColor);\r\n var\r\n I: Integer;\r\n begin\r\n if iEnd > Max_X then\r\n iEnd := Max_X;\r\n for I := iBeg to iEnd do\r\n with LineAttrs[I] do\r\n begin\r\n FC := Color.ForeColor;\r\n BC := Color.BackColor;\r\n Style := Color.Style;\r\n Border := clNone;\r\n end;\r\n end;\r\n\r\n procedure SetColor(Color: TJvSymbolColor);\r\n begin\r\n SetBlockColor(Parser.PosBeg[0] + 1, Parser.PosEnd[0], Color);\r\n end;\r\n\r\n function NextSymbol: string;\r\n var\r\n I: Integer;\r\n begin\r\n I := 0;\r\n while (Parser.pcPos[I] <> #0) and CharInSet(Parser.pcPos[I], [' ', Tab, Cr, Lf]) do\r\n Inc(I);\r\n Result := Parser.pcPos[I];\r\n end;\r\n\r\n procedure TestHtmlSpecChars(const Token: string);\r\n var\r\n I, J, iBeg, iEnd: Integer;\r\n S1: string;\r\n F1: Integer;\r\n begin\r\n I := 1;\r\n F1 := Parser.PosBeg[0];\r\n while I <= Length(Token) do\r\n begin\r\n if Token[I] = '&' then\r\n begin\r\n iBeg := I;\r\n iEnd := iBeg;\r\n Inc(I);\r\n while I <= Length(Token) do\r\n begin\r\n if Token[I] = ';' then\r\n begin\r\n iEnd := I;\r\n Break;\r\n end;\r\n Inc(I);\r\n end;\r\n if iEnd > iBeg + 1 then\r\n begin\r\n S1 := Copy(Token, iBeg + 1, iEnd - iBeg - 1);\r\n if IsHtmlSpecChar(S1) then\r\n for J := iBeg to iEnd do\r\n with LineAttrs[F1 + J] do\r\n begin\r\n FC := Colors.Preproc.ForeColor;\r\n BC := Colors.Preproc.BackColor;\r\n Style := Colors.Preproc.Style;\r\n Border := clNone;\r\n end;\r\n end;\r\n end;\r\n Inc(I);\r\n end;\r\n end;\r\n\r\n procedure SetIniColors(const S: string);\r\n var\r\n EquPos: Integer;\r\n LS: Integer;\r\n begin\r\n LS := Length(S);\r\n if (LS > 0) and (S[1] = '[') and (S[LS] = ']') then\r\n SetBlockColor(0, LS, Colors.Declaration)\r\n else\r\n begin\r\n EquPos := Pos('=', S);\r\n if EquPos > 0 then\r\n begin\r\n SetBlockColor(0, EquPos, Colors.Identifier);\r\n SetBlockColor(EquPos, EquPos, Colors.Symbol);\r\n SetBlockColor(EquPos + 1, LS, Colors.Strings);\r\n end;\r\n end;\r\n end;\r\n\r\n // for Coco/R\r\n\r\n procedure HighlightGrammarName(const S: string);\r\n var\r\n P: Integer;\r\n begin\r\n P := Pos('-->Grammar<--', S);\r\n if P > 0 then\r\n SetBlockColor(P, P + Length('-->Grammar<--') - 1, Colors.Preproc);\r\n end;\r\n\r\n// (rom) const, var, local function sequence not cleaned up yet\r\nvar\r\n F: Boolean;\r\n C: TJvSymbolColor;\r\n Reserved: Boolean;\r\n PrevToken: string;\r\n PrevToken2: string;\r\n NextToken: string;\r\n Ch: Char;\r\n InTag: Boolean;\r\n N: Integer;\r\n\r\nvar\r\n S: string;\r\n LS: Integer;\r\n Token: string;\r\n I: Integer;\r\n\r\nbegin\r\n if not FSyntaxHighlighting then\r\n Exit;\r\n S := Lines[Line];\r\n if (FHighlighter = hlNone) and not UserReservedWords then\r\n C := Colors.PlainText\r\n else\r\n begin\r\n FLine := S;\r\n FLineNum := Line;\r\n CheckInLong;\r\n\r\n if (FHighlighter = hlSyntaxHighlighter) and (FSyntaxHighlighter <> nil) then\r\n begin\r\n // user defined syntax highlighting\r\n FSyntaxHighlighter.GetAttr(Self, Lines, Line, ColBeg, ColEnd, FLong, LineAttrs);\r\n Exit;\r\n end;\r\n\r\n Parser.pcProgram := PChar(S);\r\n Parser.pcPos := Parser.pcProgram;\r\n\r\n LS := Length(S);\r\n Ch := GetTrimChar(S, 1);\r\n if (Highlighter in [hlCBuilder, hlNQC]) and (LS > 0) and\r\n (((Ch = '#') and (FLong = 0)) or (FLong = lgPreproc)) then\r\n C := Colors.Preproc\r\n else\r\n if ((FHighlighter in [hlPython, hlPerl]) and (LS > 0) and\r\n (Ch = '#') and (FLong = 0)) or\r\n ((Highlighter = hlIni) and (LS > 0) and ((Ch = '#') or (Ch = ';'))) then\r\n C := Colors.Comment\r\n else\r\n C := Colors.PlainText;\r\n // (rom) reenabled second part of if to handle two line DOCTYPE\r\n if (FLong <> 0) and (FHighlighter <> hlHtml) then\r\n begin\r\n Parser.pcPos := Parser.pcProgram + FindLongEnd + 1;\r\n if Parser.pcPos > Parser.pcProgram + Length(S) then\r\n Parser.pcPos := Parser.pcProgram + Length(S); // => #0\r\n case Highlighter of\r\n hlCBuilder, hlPython, hlPerl, hlNQC, hlCSharp, hlHtml:\r\n case FLong of\r\n lgString:\r\n C := Colors.Strings;\r\n lgComment1, lgComment2:\r\n C := Colors.Comment;\r\n lgPreproc:\r\n C := Colors.Preproc;\r\n end;\r\n hlPascal:\r\n case FLong of\r\n lgComment1, lgComment2:\r\n C := Colors.Comment;\r\n lgPreproc1, lgPreproc2:\r\n C := Colors.Preproc;\r\n end;\r\n else\r\n C := Colors.Comment;\r\n end;\r\n end;\r\n end;\r\n\r\n LineAttrs[1].FC := C.ForeColor;\r\n LineAttrs[1].Style := C.Style;\r\n LineAttrs[1].BC := C.BackColor;\r\n LineAttrs[1].Border := clNone;\r\n N := Min(Max_X, Length(S));\r\n for I := 2 to N do\r\n Move(LineAttrs[1], LineAttrs[I], SizeOf(LineAttrs[1]));\r\n if Length(S) < Max_X then\r\n begin\r\n LineAttrs[N + 1].FC := Font.Color;\r\n LineAttrs[N + 1].Style := Font.Style;\r\n LineAttrs[N + 1].BC := Color;\r\n LineAttrs[N + 1].Border := clNone;\r\n for I := N + 1 + 1 to Max_X do\r\n Move(LineAttrs[N + 1], LineAttrs[I], SizeOf(LineAttrs[1]));\r\n end;\r\n\r\n if (FHighlighter = hlNone) and not UserReservedWords then\r\n Exit;\r\n if (Length(S) > 0) then\r\n begin\r\n Ch := GetTrimChar(S, 1);\r\n if ((Ch = '#') and (FHighlighter in [hlCBuilder, hlPython, hlPerl, hlNQC])) or\r\n (((Ch = '#') or (Ch = ';')) and (FHighlighter = hlIni)) then\r\n Exit;\r\n end;\r\n\r\n if FHighlighter = hlIni then\r\n SetIniColors(S)\r\n else\r\n try\r\n InTag := FLong = lgTag;\r\n PrevToken := '';\r\n PrevToken2 := '';\r\n Token := Parser.Token;\r\n while Token <> '' do\r\n begin\r\n F := True;\r\n if GetReservedWord(Token, Reserved) then\r\n begin\r\n if Reserved then\r\n SetColor(Colors.Reserved)\r\n else\r\n F := False;\r\n end\r\n else\r\n case FHighlighter of\r\n hlPascal:\r\n if IsDelphiKeyWord(Token) then\r\n SetColor(Colors.Reserved)\r\n else\r\n F := False;\r\n hlCBuilder:\r\n if IsBuilderKeyWord(Token) then\r\n SetColor(Colors.Reserved)\r\n else\r\n F := False;\r\n hlNQC:\r\n if IsNQCKeyWord(Token) then\r\n SetColor(Colors.Reserved)\r\n else\r\n F := False;\r\n hlSql:\r\n if IsSQLKeyWord(Token) then\r\n SetColor(Colors.Reserved)\r\n else\r\n F := False;\r\n hlPython:\r\n if IsPythonKeyWord(Token) then\r\n SetColor(Colors.Reserved)\r\n else\r\n if Token = 'None' then\r\n SetColor(Colors.Number)\r\n else\r\n if (PrevToken = 'def') or (PrevToken = 'class') then\r\n SetColor(Colors.Declaration)\r\n else\r\n if (NextSymbol = '(') and IsIdentifier(Token) then\r\n SetColor(Colors.FunctionCall)\r\n else\r\n F := False;\r\n hlJava:\r\n if IsJavaKeyWord(Token) then\r\n SetColor(Colors.Reserved)\r\n else\r\n if PrevToken = 'function' then\r\n SetColor(Colors.Declaration)\r\n else\r\n F := False;\r\n hlJScript:\r\n if IsJScriptKeyWord(Token) then\r\n SetColor(Colors.Reserved)\r\n else\r\n if PrevToken = 'function' then\r\n SetColor(Colors.Declaration)\r\n else\r\n F := False;\r\n hlVB:\r\n if IsVBKeyWord(Token) then\r\n SetColor(Colors.Reserved)\r\n else\r\n if IsVBStatement(Token) then\r\n SetColor(Colors.Statement)\r\n else\r\n if SameText(PrevToken, 'function') or SameText(PrevToken, 'sub') or\r\n SameText(PrevToken, 'class') then\r\n SetColor(Colors.Declaration)\r\n else\r\n F := False;\r\n hlHtml:\r\n if not InTag then\r\n begin\r\n { Check for the comment starting\r\n with ' then\r\n begin\r\n InTag := False;\r\n SetColor(Colors.Reserved);\r\n F := False;\r\n end\r\n else\r\n if Token = '>' then\r\n begin\r\n InTag := False;\r\n SetColor(Colors.Reserved)\r\n end\r\n else\r\n if (Token = '/') and (PrevToken = '<') then\r\n SetColor(Colors.Reserved)\r\n else\r\n if (NextSymbol = '=') and IsIdentifier(Token) then\r\n SetColor(Colors.Identifier)\r\n else\r\n if PrevToken = '=' then\r\n SetColor(Colors.Strings)\r\n else\r\n if IsHtmlTag(Token) then\r\n SetColor(Colors.Reserved)\r\n else\r\n if (PrevToken = '<') or ((PrevToken = '/') and (PrevToken2 = '<')) then\r\n SetColor(Colors.Statement)\r\n else\r\n F := False;\r\n end;\r\n hlPerl:\r\n if IsPerlKeyWord(Token) then\r\n SetColor(Colors.Reserved)\r\n else\r\n if IsPerlStatement(Token) then\r\n SetColor(Colors.Statement)\r\n else\r\n if CharInSet(Token[1], ['$', '@', '%', '&']) then\r\n SetColor(Colors.FunctionCall)\r\n else\r\n F := False;\r\n hlCocoR:\r\n if IsCocoKeyWord(Token) then\r\n SetColor(Colors.Reserved)\r\n else\r\n if (Parser.PosBeg[0] = 0) and (Line > ProductionsLine) and\r\n IsIdentifier(Token) then\r\n begin\r\n NextToken := Parser.Token;\r\n Parser.RollBack(1);\r\n SetColor(Colors.Declaration)\r\n end\r\n else\r\n F := False;\r\n hlPhp:\r\n if IsPhpKeyWord(Token) then\r\n SetColor(Colors.Reserved)\r\n else\r\n F := False;\r\n hlCSharp:\r\n if IsCSharpKeyWord(Token) then\r\n SetColor(Colors.Reserved)\r\n else\r\n F := False;\r\n else\r\n F := False;\r\n end;\r\n if F then\r\n {Ok}\r\n else\r\n if IsPreproc(Token) then\r\n SetColor(Colors.Preproc)\r\n else\r\n if IsComment(Token) then\r\n SetColor(Colors.Comment)\r\n else\r\n if IsStringConstant(Token) then\r\n SetColor(Colors.Strings)\r\n else\r\n if (Length(Token) = 1) and CharInSet(Token[1], Symbols) then\r\n SetColor(Colors.Symbol)\r\n else\r\n if IsIntConstant(Token) or IsRealConstant(Token) then\r\n SetColor(Colors.Number)\r\n else\r\n if (FHighlighter in [hlCBuilder, hlJava, hlJScript, hlPython, hlPhp, hlNQC, hlCSharp]) and\r\n (PrevToken = '0') and ((Token[1] = 'x') or (Token[1] = 'X')) then\r\n SetColor(Colors.Number)\r\n else\r\n if FHighlighter = hlHtml then\r\n SetColor(Colors.PlainText)\r\n else\r\n SetColor(Colors.Identifier);\r\n if FHighlighter = hlHtml then\r\n { found special chars starting with '&' and ending with ';' }\r\n TestHtmlSpecChars(Token);\r\n PrevToken2 := PrevToken;\r\n PrevToken := Token;\r\n Token := Parser.Token;\r\n end;\r\n\r\n if Highlighter = hlCocoR then\r\n HighlightGrammarName(S);\r\n except\r\n end;\r\nend;\r\n\r\nprocedure TJvHLEditor.CheckInLong;\r\nbegin\r\n if not FLongTokens then\r\n begin\r\n FLong := lgNone;\r\n Exit;\r\n end;\r\n if FLineNum < Length(FLongDesc) then\r\n begin\r\n FLong := FLongDesc[FLineNum];\r\n if FLong = lgUndefined then\r\n begin\r\n RescanLong(FLineNum); // scan the line\r\n FLong := FLongDesc[FLineNum];\r\n end;\r\n end\r\n else\r\n RescanLong(-1);\r\nend;\r\n\r\nfunction TJvHLEditor.RescanLong(iLine: Integer): Boolean;\r\nconst\r\n MaxScanLinesAtOnce = 5000;\r\nvar\r\n P, F: PChar;\r\n MaxLine, MaxScanLine: Integer;\r\n S: string;\r\n I, i1, L1: Integer;\r\nbegin\r\n FLong := lgNone;\r\n Result := False; // no Invalidate\r\n\r\n if (not FSyntaxHighlighting) or\r\n (not FLongTokens or (FHighlighter in [hlNone, hlIni])) or\r\n (Lines.Count = 0) then\r\n Exit;\r\n if Lines.Count >= Length(FLongDesc) then\r\n SetLength(FLongDesc, (Lines.Count div (64*1024) + 1) * (64*1024));\r\n\r\n ProductionsLine := High(Integer);\r\n MaxLine := Lines.Count - 1;\r\n if MaxLine > High(FLongDesc) then\r\n MaxLine := High(FLongDesc);\r\n if iLine > MaxLine then\r\n Exit;\r\n\r\n MaxScanLine := MaxLine;\r\n FLong := lgNone;\r\n if iLine < 0 then\r\n begin\r\n FillChar(FLongDesc[0], SizeOf(FLongDesc[0]) * (1 + MaxLine), lgUndefined);\r\n FLongDesc[0] := lgNone;\r\n iLine := 0;\r\n end\r\n else\r\n begin\r\n FLong := FLongDesc[iLine];\r\n if FLong = lgUndefined then\r\n begin\r\n if (iLine > 0) and (FLongDesc[iLine - 1] = lgUndefined) then\r\n begin\r\n iLine := 0; // scan all\r\n FLong := lgNone;\r\n end\r\n else\r\n begin\r\n Dec(iLine);\r\n FLong := FLongDesc[iLine];\r\n MaxScanLine := Min(iLine + MaxScanLinesAtOnce, MaxLine);\r\n end;\r\n end\r\n else\r\n MaxScanLine := Min(iLine + MaxScanLinesAtOnce, MaxLine);\r\n end;\r\n\r\n while iLine < MaxScanLine do\r\n begin\r\n if (FHighlighter = hlSyntaxHighlighter) and (FSyntaxHighlighter <> nil) then\r\n FSyntaxHighlighter.ScanLongTokens(Self, Lines, iLine, FLong)\r\n else\r\n begin\r\n S := Lines[iLine];\r\n P := Pointer(S);\r\n F := P;\r\n L1 := Length(S);\r\n if (L1 = 0) then\r\n begin\r\n case Highlighter of\r\n hlPascal:\r\n if FLong in [lgString] then\r\n FLong := lgNone;\r\n hlCBuilder, hlPython, hlPerl, hlNQC:\r\n if FLong in [lgPreproc] then\r\n FLong := lgNone;\r\n else\r\n if FLong in [lgPreproc1, lgPreproc2, lgString] then\r\n FLong := lgNone;\r\n end;\r\n end;\r\n I := 1;\r\n while I <= L1 do\r\n begin\r\n case FHighlighter of\r\n hlPascal:\r\n case FLong of\r\n lgNone: // not in comment\r\n case S[I] of\r\n '/':\r\n begin\r\n if S[I + 1] = '/' then\r\n Break;\r\n end;\r\n '{':\r\n begin\r\n P := StrScanNil(F + I, Char('}'));\r\n if P = nil then\r\n begin\r\n if S[I + 1] = '$' then\r\n FLong := lgPreproc1\r\n else\r\n FLong := lgComment1;\r\n Break;\r\n end\r\n else\r\n I := P - F + 1;\r\n end;\r\n '(':\r\n if {S[I + 1]} F[I] = '*' then\r\n begin\r\n if {S[I + 2]} F[I + 1] = '$' then\r\n FLong := lgPreproc2\r\n else\r\n FLong := lgComment2;\r\n P := StrScanNil(F + I + 2, Char(')'));\r\n if P = nil then\r\n Break\r\n else\r\n begin\r\n if P[-1] = '*' then\r\n FLong := lgNone;\r\n I := P - F + 1;\r\n end;\r\n end;\r\n '''':\r\n begin\r\n P := StrScanNil(F + I + 1, Char(''''));\r\n if P <> nil then\r\n begin\r\n i1 := P - F;\r\n if P[1] <> '''' then\r\n I := i1\r\n else\r\n { ?? }\r\n end\r\n else\r\n I := L1 + 1;\r\n end;\r\n end;\r\n lgPreproc1, lgComment1:\r\n begin // {\r\n P := StrScanNil(F + I - 1, Char('}'));\r\n if P <> nil then\r\n begin\r\n FLong := lgNone;\r\n I := P - F + 1;\r\n end\r\n else\r\n I := L1 + 1;\r\n end;\r\n lgPreproc2, lgComment2:\r\n begin // (*\r\n P := StrScanNil(F + I, Char(')'));\r\n if P = nil then\r\n Break\r\n else\r\n begin\r\n if P[-1] = '*' then\r\n FLong := lgNone;\r\n I := P - F + 1;\r\n end;\r\n end;\r\n end;\r\n hlCBuilder, hlSql, hlJava, hlJScript, hlPhp, hlNQC, hlCSharp:\r\n case FLong of\r\n lgNone: // not in comment\r\n case S[I] of\r\n '/':\r\n if {S[I + 1]} F[I] = '*' then\r\n begin\r\n FLong := lgComment2;\r\n P := StrScanNil(F + I + 2, Char('/'));\r\n if P = nil then\r\n Break\r\n else\r\n begin\r\n if P[-1] = '*' then\r\n FLong := lgNone;\r\n I := P - F + 1;\r\n end;\r\n end;\r\n '\"':\r\n begin\r\n P := StrScanNil(F + I + 1, Char('\"'));\r\n if P <> nil then\r\n begin\r\n i1 := P - F;\r\n if P[1] <> '\"' then\r\n I := i1\r\n else\r\n { ?? }\r\n end\r\n else\r\n if FHighlighter in [hlCBuilder, hlJava, hlJScript, hlNQC] then\r\n begin\r\n if (LastNonSpaceChar(S) = '\\') and (HasStringOpenEnd(Lines, iLine)) then\r\n FLong := lgString;\r\n I := L1 + 1;\r\n end\r\n else\r\n I := L1 + 1;\r\n end;\r\n '#':\r\n begin\r\n if (GetTrimChar(S, 1) = '#') and (LastNonSpaceChar(S) = '\\') then\r\n begin\r\n FLong := lgPreproc;\r\n Break;\r\n end;\r\n end;\r\n end;\r\n lgComment2:\r\n begin // /*\r\n P := StrScanNil(F + I, Char('/'));\r\n if P = nil then\r\n Break\r\n else\r\n begin\r\n if P[-1] = '*' then\r\n FLong := lgNone;\r\n I := P - F + 1;\r\n end;\r\n end;\r\n lgString:\r\n begin\r\n P := StrScanNil(F + I + 1, Char('\"'));\r\n if P <> nil then\r\n begin\r\n i1 := P - F;\r\n if P[1] <> '\"' then\r\n I := i1\r\n else\r\n { ?? }\r\n end\r\n else\r\n begin\r\n if FHighlighter in [hlCBuilder, hlJava, hlJScript, hlNQC] then\r\n begin\r\n if (LastNonSpaceChar(S) <> '\\') or (not HasStringOpenEnd(Lines, iLine)) then\r\n FLong := lgNone;\r\n end;\r\n I := L1 + 1;\r\n end;\r\n end;\r\n lgPreproc:\r\n begin\r\n if LastNonSpaceChar(S) <> '\\' then\r\n FLong := lgNone;\r\n end;\r\n end;\r\n hlPython, hlPerl:\r\n case FLong of\r\n lgNone: // not in comment\r\n case S[I] of\r\n '#':\r\n I := L1;\r\n '\"':\r\n begin\r\n P := StrScanNil(F + I, Char('\"'));\r\n if P = nil then\r\n begin\r\n FLong := lgString;\r\n Break;\r\n end\r\n else\r\n I := P - F + 1;\r\n end;\r\n end;\r\n lgString: // python and perl long string\r\n begin\r\n P := StrScanNil(F + I - 1, Char('\"'));\r\n if P <> nil then\r\n begin\r\n FLong := lgNone;\r\n I := P - F + 1;\r\n end\r\n else\r\n I := L1 + 1;\r\n end;\r\n end;\r\n hlHtml:\r\n case FLong of\r\n lgNone: // not in comment\r\n case S[I] of\r\n '<':\r\n begin\r\n P := StrScanNil(F + I, Char('>'));\r\n if P = nil then\r\n begin\r\n // Multiline comments in HTML\r\n if S[2] = '!' then\r\n FLong := lgComment1\r\n else\r\n FLong := lgTag;\r\n Break;\r\n end\r\n else\r\n I := P - F + 1;\r\n end;\r\n end;\r\n // Multiline comments in HTML\r\n lgComment1:\r\n begin\r\n P := StrScanNil(F + I - 1, Char('>'));\r\n if P = nil then\r\n Break\r\n else\r\n if (P[-2] = '-') and (P[-1] = '-') then\r\n FLong := lgNone;\r\n I := P - F + 1;\r\n end;\r\n lgTag: // html tag\r\n begin\r\n P := StrScanNil(F + I - 1, Char('>'));\r\n if P <> nil then\r\n begin\r\n FLong := lgNone;\r\n I := P - F + 1;\r\n end\r\n else\r\n I := L1 + 1;\r\n end;\r\n end;\r\n hlCocoR:\r\n case FLong of\r\n lgNone: // not in comment\r\n case S[I] of\r\n '(':\r\n if {S[I + 1]} F[I] = '*' then\r\n begin\r\n FLong := lgComment2;\r\n P := StrScanNil(F + I + 2, Char(')'));\r\n if P = nil then\r\n Break\r\n else\r\n begin\r\n if P[-1] = '*' then\r\n FLong := lgNone;\r\n I := P - F + 1;\r\n end;\r\n end;\r\n '\"':\r\n begin\r\n P := StrScanNil(F + I + 1, Char('\"'));\r\n if P <> nil then\r\n begin\r\n i1 := P - F;\r\n if P[1] <> '\"' then\r\n I := i1\r\n else\r\n { ?? }\r\n end\r\n else\r\n I := L1 + 1;\r\n end;\r\n '''':\r\n begin\r\n P := StrScanNil(F + I + 1, Char(''''));\r\n if P <> nil then\r\n begin\r\n i1 := P - F;\r\n if P[1] <> '''' then\r\n I := i1\r\n else\r\n { ?? }\r\n end\r\n else\r\n I := L1 + 1;\r\n end;\r\n '/':\r\n if {S[I + 1]} F[I] = '*' then\r\n begin\r\n FLong := lgComment2;\r\n P := StrScanNil(F + I + 2, Char('/'));\r\n if P = nil then\r\n Break\r\n else\r\n begin\r\n if P[-1] = '*' then\r\n FLong := lgNone;\r\n I := P - F + 1;\r\n end;\r\n end;\r\n end;\r\n lgComment2:\r\n begin // (*\r\n P := StrScanNil(F + I, Char(')'));\r\n if P = nil then\r\n Break\r\n else\r\n begin\r\n if P[-1] = '*' then\r\n FLong := lgNone;\r\n I := P - F + 1;\r\n end;\r\n end;\r\n end;\r\n end;\r\n Inc(I);\r\n end;\r\n\r\n if (FHighlighter = hlCocoR) and\r\n (StrLIComp(PChar(S), 'productions', Length('productions')) = 0) then\r\n begin\r\n ProductionsLine := iLine;\r\n end;\r\n end;\r\n\r\n Inc(iLine);\r\n if FLongDesc[iLine] <> FLong then\r\n begin\r\n FLongDesc[iLine] := FLong;\r\n Result := True; // Invalidate\r\n end;\r\n end;\r\n // undefine following lines\r\n if MaxScanLine < MaxLine then\r\n FillChar(FLongDesc[MaxScanLine + 1], SizeOf(FLongDesc[0]) * (MaxLine - MaxScanLine), lgUndefined);\r\nend;\r\n\r\nfunction TJvHLEditor.FindLongEnd: Integer;\r\nvar\r\n P, F: PChar;\r\n I: Integer;\r\nbegin\r\n P := PChar(FLine);\r\n Result := Length(FLine);\r\n case FHighlighter of\r\n hlPascal:\r\n case FLong of\r\n lgPreproc1, lgComment1:\r\n begin\r\n P := StrScanNil(P, Char('}'));\r\n if P <> nil then\r\n Result := P - PChar(FLine);\r\n end;\r\n lgPreproc2, lgComment2:\r\n begin\r\n F := P;\r\n while True do\r\n begin\r\n F := StrScanNil(F, Char('*'));\r\n if F = nil then\r\n Exit;\r\n if F[1] = ')' then\r\n Break;\r\n Inc(F);\r\n end;\r\n P := F + 1;\r\n Result := P - PChar(FLine);\r\n end;\r\n end;\r\n hlCBuilder, hlSql, hlJava, hlJScript, hlPhp, hlNQC, hlCSharp:\r\n begin\r\n case FLong of\r\n lgComment2:\r\n begin\r\n F := P;\r\n while True do\r\n begin\r\n F := StrScanNil(F, Char('*'));\r\n if F = nil then\r\n Exit;\r\n if F[1] = '/' then\r\n Break;\r\n Inc(F);\r\n end;\r\n P := F + 1;\r\n Result := P - PChar(FLine);\r\n end;\r\n lgString:\r\n begin\r\n F := P;\r\n repeat\r\n P := StrScanNil(P, Char('\"'));\r\n if P <> nil then\r\n begin\r\n if (P = F) or (P[-1] <> '\\') then\r\n begin\r\n Result := P - F;\r\n Break;\r\n end\r\n else\r\n begin\r\n // count the backslashes\r\n I := 1;\r\n while (P - 1 - I > F) and (P[-1 - I] = '\\') do\r\n Inc(I);\r\n if I and $01 = 0 then {faster than: if I mod 2 = 0 then}\r\n begin\r\n Result := P - F;\r\n Break;\r\n end;\r\n end;\r\n Inc(P);\r\n end;\r\n until P = nil;\r\n end;\r\n end;\r\n end;\r\n hlPython, hlPerl:\r\n case FLong of\r\n lgString:\r\n begin\r\n P := StrScanNil(P, Char('\"'));\r\n if P <> nil then\r\n Result := P - PChar(FLine);\r\n end;\r\n end;\r\n hlHtml:\r\n case FLong of\r\n // HTML multiline comments\r\n lgComment1:\r\n begin\r\n P := StrScanNil(P, Char('>'));\r\n if P <> nil then\r\n // check if the previous characters are\r\n // --\r\n if (P[-1] = '-') and (P[-2] = '-') then\r\n Result := P - PChar(FLine);\r\n end;\r\n lgTag:\r\n begin\r\n P := StrScanNil(P, Char('>'));\r\n if P <> nil then\r\n Result := P - PChar(FLine);\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvHLEditor.TextModified(ACaretX, ACaretY: Integer; Action: TModifiedAction;\r\n const Text: string);\r\nvar\r\n S: string;\r\n L: Integer;\r\n{ LP, I: Integer;\r\n P: PChar;\r\n OldProductionsLine: Integer; }\r\nbegin\r\n if not FLongTokens then\r\n Exit;\r\n case FHighlighter of\r\n hlPascal:\r\n S := #13'{}*()/ ';\r\n hlCBuilder, hlJava, hlJScript, hlSql, hlPhp, hlNQC, hlCSharp:\r\n S := #13'*/\\ ';\r\n hlVB:\r\n S := #13'''';\r\n hlPython, hlPerl:\r\n S := #13'#\"';\r\n hlHtml:\r\n S := #13'<>';\r\n hlCocoR:\r\n S := #13'*()/ ';\r\n hlSyntaxHighlighter:\r\n if FSyntaxHighlighter <> nil then\r\n begin\r\n if FSyntaxHighlighter.GetRescanLongKeys(Self, Action, ACaretX, ACaretY, Text) then\r\n begin\r\n if RescanLong(ACaretY) then\r\n Invalidate;\r\n end;\r\n Exit;\r\n end\r\n else\r\n S := #13;\r\n else\r\n S := #13; { unknown Highlighter ? }\r\n end;\r\n\r\n if Action = maAll then\r\n ACaretY := -1; // rescan all lines\r\n\r\n if (Action in [maAll, maReplace]) or HasAnyChar(S, Text) then\r\n begin\r\n if RescanLong(ACaretY) then\r\n Invalidate;\r\n end\r\n else\r\n begin\r\n if (Highlighter = hlPascal) and (Cardinal(ACaretY) < Cardinal(Length(FLongDesc))) then\r\n begin\r\n // comment <-> preproc\r\n S := Lines[ACaretY];\r\n L := Length(S);\r\n // [Backspace, \"insert\"]\r\n if ((ACaretX > 1) and (ACaretX <= L + 1) and (S[ACaretX - 1] = '{')) or\r\n ((ACaretX > 2) and (ACaretX <= L + 2) and (S[ACaretX - 2] = '(') and (S[ACaretX - 1] = '*')) or\r\n // [Delete]\r\n ((ACaretX > 0) and (ACaretX <= L) and (S[ACaretX] = '{')) or\r\n ((ACaretX > 1) and (ACaretX <= L + 1) and (S[ACaretX - 1] = '(') and (S[ACaretX] = '*')) then\r\n begin\r\n if RescanLong(ACaretY) then\r\n Invalidate;\r\n end;\r\n end;\r\n end;\r\n {\r\n if (FHighlighter = hlCocoR) and (HasAnyChar('productions'#13, Text)) then\r\n begin\r\n LP := Length('productions');\r\n OldProductionsLine := ProductionsLine;\r\n ProductionsLine := High(Integer);\r\n for I := 0 to Lines.Count - 1 do\r\n begin\r\n P := PChar(Lines[I]);\r\n if (StrLIComp(P, 'productions', LP) = 0) and\r\n ((Length(P) = LP) or (P[LP] = ' ')) then\r\n begin\r\n ProductionsLine := I;\r\n Break;\r\n end;\r\n end;\r\n if ProductionsLine <> OldProductionsLine then\r\n Invalidate;\r\n end; }\r\nend;\r\n\r\nfunction TJvHLEditor.GetReservedWord(const Token: string;\r\n var Reserved: Boolean): Boolean;\r\nbegin\r\n Result := Assigned(FOnReservedWord);\r\n if Result then\r\n begin\r\n Reserved := False;\r\n FOnReservedWord(Self, Token, Reserved);\r\n end\r\nend;\r\n\r\nfunction TJvHLEditor.UserReservedWords: Boolean;\r\nbegin\r\n Result := Assigned(FOnReservedWord);\r\nend;\r\n\r\nprocedure TJvHLEditor.Assign(Source: TPersistent);\r\nbegin\r\n inherited Assign(Source);\r\n if Source is TJvHLEditor then\r\n begin\r\n FHighlighter := TJvHLEditor(Source).Highlighter;\r\n Colors.Assign(TJvHLEditor(Source).Colors);\r\n SelForeColor := TJvHLEditor(Source).SelForeColor;\r\n SelBackColor := TJvHLEditor(Source).SelBackColor;\r\n Color := TJvHLEditor(Source).Color;\r\n FSyntaxHighlighting := TJvHLEditor(Source).SyntaxHighlighting;\r\n RightMarginColor := TJvHLEditor(Source).RightMarginColor;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nfunction TJvHLEditor.GetDelphiColors: Boolean;\r\n\r\n function CompareColor(Symbol: TJvSymbolColor; const DelphiColor: TDelphiColor): Boolean;\r\n begin\r\n Result := (Symbol.ForeColor = DelphiColor.ForeColor) and\r\n (Symbol.BackColor = DelphiColor.BackColor) and\r\n (Symbol.Style = DelphiColor.Style);\r\n end;\r\n\r\nbegin\r\n Result := False;\r\n if not CompareColor(Colors.Comment, DelphiColor_Comment) then\r\n Exit;\r\n if not CompareColor(Colors.Preproc, DelphiColor_Preproc) then\r\n Exit;\r\n if not CompareColor(Colors.Number, DelphiColor_Number) then\r\n Exit;\r\n if not CompareColor(Colors.Strings, DelphiColor_Strings) then\r\n Exit;\r\n if not CompareColor(Colors.Symbol, DelphiColor_Symbol) then\r\n Exit;\r\n if not CompareColor(Colors.Reserved, DelphiColor_Reserved) then\r\n Exit;\r\n if not CompareColor(Colors.Identifier, DelphiColor_Identifier) then\r\n Exit;\r\n if not CompareColor(Colors.PlainText, DelphiColor_PlainText) then\r\n Exit;\r\n Result := True;\r\nend;\r\n\r\nprocedure TJvHLEditor.SetDelphiColors(Value: Boolean);\r\n procedure SetColor(Symbol: TJvSymbolColor; const DelphiColor: TDelphiColor);\r\n begin\r\n with DelphiColor do\r\n Symbol.SetColor(ForeColor, BackColor, Style);\r\n end;\r\nbegin\r\n if Value then\r\n begin\r\n SetColor(Colors.Comment, DelphiColor_Comment);\r\n SetColor(Colors.Preproc, DelphiColor_Preproc);\r\n SetColor(Colors.Number, DelphiColor_Number);\r\n SetColor(Colors.Strings, DelphiColor_Strings);\r\n SetColor(Colors.Symbol, DelphiColor_Symbol);\r\n SetColor(Colors.Reserved, DelphiColor_Reserved);\r\n SetColor(Colors.Identifier, DelphiColor_Identifier);\r\n SetColor(Colors.PlainText, DelphiColor_PlainText);\r\n end;\r\nend;\r\n\r\nprocedure TJvHLEditor.SetSyntaxHighlighter(const Value: TJvEditorHighlighter);\r\nbegin\r\n if Value <> FSyntaxHighlighter then\r\n begin\r\n if Value <> nil then\r\n FHighlighter := hlSyntaxHighlighter\r\n else\r\n if FHighlighter = hlSyntaxHighlighter then\r\n FHighlighter := hlNone;\r\n\r\n ReplaceComponentReference(Self, Value, TComponent(FSyntaxHighlighter));\r\n RescanLong(0);\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nfunction TJvHLEditor.GetColors: TJvColors;\r\nbegin\r\n Result := FColors;\r\nend;\r\n\r\nprocedure TJvHLEditor.SetColors(const Value: TJvColors);\r\nbegin\r\n FColors.Assign(Value);\r\nend;\r\n\r\nfunction TJvHLEditor.GetSyntaxHighlighting: Boolean;\r\nbegin\r\n Result := FSyntaxHighlighting;\r\nend;\r\n\r\nprocedure TJvHLEditor.SetSyntaxHighlighting(Value: Boolean);\r\nbegin\r\n FSyntaxHighlighting := Value;\r\n Invalidate;\r\nend;\r\n\r\nfunction TJvHLEditor.GetHighlighter: TJvHighlighter;\r\nbegin\r\n Result := FHighlighter;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvHLEditorPropertyForm.dfm", "content": "object JvHLEditorParamsForm: TJvHLEditorParamsForm\r\n Left = 333\r\n Top = 152\r\n BorderIcons = [biSystemMenu]\r\n BorderStyle = bsDialog\r\n Caption = 'Editor Properties'\r\n ClientHeight = 369\r\n ClientWidth = 435\r\n Color = clBtnFace\r\n Font.Charset = DEFAULT_CHARSET\r\n Font.Color = clWindowText\r\n Font.Height = -11\r\n Font.Name = 'MS Sans Serif'\r\n Font.Style = []\r\n OldCreateOrder = True\r\n Position = poScreenCenter\r\n OnCreate = FormCreate\r\n PixelsPerInch = 96\r\n TextHeight = 13\r\n object Pages: TPageControl\r\n Left = 8\r\n Top = 8\r\n Width = 419\r\n Height = 321\r\n ActivePage = tsColors\r\n TabOrder = 0\r\n object tsEditor: TTabSheet\r\n Caption = 'Editor'\r\n ExplicitLeft = 0\r\n ExplicitTop = 0\r\n ExplicitWidth = 0\r\n ExplicitHeight = 0\r\n object lblEditorSpeedSettings: TLabel\r\n Left = 30\r\n Top = 11\r\n Width = 99\r\n Height = 13\r\n Alignment = taRightJustify\r\n Caption = 'Editor SpeedSettings'\r\n end\r\n object lblTabStops: TLabel\r\n Left = 8\r\n Top = 194\r\n Width = 50\r\n Height = 13\r\n Alignment = taRightJustify\r\n Caption = '&Tab stops:'\r\n end\r\n object cbKeyboardLayout: TComboBox\r\n Left = 136\r\n Top = 6\r\n Width = 267\r\n Height = 21\r\n Style = csDropDownList\r\n TabOrder = 0\r\n Items.Strings = (\r\n 'Default keymapping')\r\n end\r\n object gbEditor: TGroupBox\r\n Left = 8\r\n Top = 35\r\n Width = 395\r\n Height = 150\r\n Caption = 'Editor options:'\r\n TabOrder = 1\r\n object cbUndoAfterSave: TCheckBox\r\n Left = 184\r\n Top = 16\r\n Width = 200\r\n Height = 17\r\n Caption = '&Undo after sa&ve'\r\n Checked = True\r\n State = cbChecked\r\n TabOrder = 0\r\n OnClick = NotImplemented\r\n end\r\n object cbDoubleClickLine: TCheckBox\r\n Left = 184\r\n Top = 56\r\n Width = 200\r\n Height = 17\r\n Caption = '&Double click line'\r\n TabOrder = 1\r\n end\r\n object cbKeepTrailingBlanks: TCheckBox\r\n Left = 184\r\n Top = 36\r\n Width = 200\r\n Height = 17\r\n Caption = '&Keep trailing blanks'\r\n Checked = True\r\n State = cbChecked\r\n TabOrder = 2\r\n end\r\n object cbSytaxHighlighting: TCheckBox\r\n Left = 184\r\n Top = 76\r\n Width = 200\r\n Height = 17\r\n Caption = 'Use &syntax highlight'\r\n Checked = True\r\n State = cbChecked\r\n TabOrder = 3\r\n end\r\n object cbAutoIndent: TCheckBox\r\n Left = 8\r\n Top = 16\r\n Width = 169\r\n Height = 17\r\n Caption = '&Auto indent mode'\r\n Checked = True\r\n State = cbChecked\r\n TabOrder = 4\r\n end\r\n object cbSmartTab: TCheckBox\r\n Left = 8\r\n Top = 36\r\n Width = 169\r\n Height = 17\r\n Caption = 'S&mart tab'\r\n Checked = True\r\n State = cbChecked\r\n TabOrder = 5\r\n end\r\n object cbBackspaceUnindents: TCheckBox\r\n Left = 8\r\n Top = 56\r\n Width = 169\r\n Height = 17\r\n Caption = 'Backspace &unindents'\r\n Checked = True\r\n State = cbChecked\r\n TabOrder = 6\r\n end\r\n object cbGroupUndo: TCheckBox\r\n Left = 8\r\n Top = 76\r\n Width = 169\r\n Height = 17\r\n Caption = '&Group undo'\r\n Checked = True\r\n State = cbChecked\r\n TabOrder = 7\r\n OnClick = NotImplemented\r\n end\r\n object cbCursorBeyondEOF: TCheckBox\r\n Left = 8\r\n Top = 96\r\n Width = 169\r\n Height = 17\r\n Caption = 'Cursor beyond &EOF'\r\n TabOrder = 8\r\n end\r\n object cbCursorBeyondEOL: TCheckBox\r\n Left = 8\r\n Top = 116\r\n Width = 169\r\n Height = 17\r\n Caption = 'Cursor beyond end of &line'\r\n Checked = True\r\n State = cbChecked\r\n TabOrder = 9\r\n end\r\n end\r\n object eTabStops: TEdit\r\n Left = 64\r\n Top = 191\r\n Width = 273\r\n Height = 21\r\n TabOrder = 2\r\n Text = '3 5'\r\n end\r\n end\r\n object tsColors: TTabSheet\r\n Caption = 'Colors'\r\n ExplicitLeft = 0\r\n ExplicitTop = 0\r\n ExplicitWidth = 0\r\n ExplicitHeight = 0\r\n object lblColorSpeedSettingsFor: TLabel\r\n Left = 16\r\n Top = 11\r\n Width = 111\r\n Height = 13\r\n Alignment = taRightJustify\r\n Caption = 'Color SpeedSettings for'\r\n end\r\n object lblElement: TLabel\r\n Left = 8\r\n Top = 32\r\n Width = 41\r\n Height = 13\r\n Caption = '&Element:'\r\n end\r\n object lblColor: TLabel\r\n Left = 173\r\n Top = 32\r\n Width = 27\r\n Height = 13\r\n Caption = '&Color:'\r\n end\r\n object Label6: TLabel\r\n Left = 96\r\n Top = 224\r\n Width = 236\r\n Height = 13\r\n Caption = 'JvHLEditorPreview will be created here in run-time'\r\n Visible = False\r\n end\r\n object cbColorSettings: TComboBox\r\n Left = 136\r\n Top = 6\r\n Width = 267\r\n Height = 21\r\n Style = csDropDownList\r\n TabOrder = 0\r\n OnChange = cbColorSettingsChange\r\n Items.Strings = (\r\n 'Default'\r\n 'Pascal'\r\n 'CBuilder'\r\n 'Sql'\r\n 'Python'\r\n 'Java'\r\n 'VB'\r\n 'Html'\r\n 'Perl'\r\n 'Ini'\r\n 'Coco/R'\r\n 'PHP'\r\n 'NQC'\r\n 'C#')\r\n end\r\n object lbElements: TListBox\r\n Left = 8\r\n Top = 48\r\n Width = 153\r\n Height = 121\r\n Style = lbOwnerDrawFixed\r\n ExtendedSelect = False\r\n ItemHeight = 13\r\n Items.Strings = (\r\n 'Whitespace'\r\n 'Comment'\r\n 'Reserved word'\r\n 'Identifier'\r\n 'Symbol'\r\n 'String'\r\n 'Number'\r\n 'Preprocessor'\r\n 'Declaration'\r\n 'Function call'\r\n 'Statement'\r\n 'Plain text'\r\n 'Marked block'\r\n 'Right margin')\r\n TabOrder = 1\r\n OnClick = lbElementsClick\r\n OnDrawItem = lbElementsDrawItem\r\n end\r\n object gbTextAttributes: TGroupBox\r\n Left = 300\r\n Top = 33\r\n Width = 104\r\n Height = 72\r\n Caption = 'Text attributes:'\r\n TabOrder = 2\r\n object cbBold: TCheckBox\r\n Left = 8\r\n Top = 17\r\n Width = 89\r\n Height = 17\r\n Caption = '&Bold'\r\n TabOrder = 0\r\n OnClick = ColorChange\r\n end\r\n object cbItalic: TCheckBox\r\n Left = 8\r\n Top = 34\r\n Width = 89\r\n Height = 17\r\n Caption = '&Italic'\r\n TabOrder = 1\r\n OnClick = ColorChange\r\n end\r\n object cbUnderline: TCheckBox\r\n Left = 8\r\n Top = 51\r\n Width = 89\r\n Height = 17\r\n Caption = '&Underline'\r\n TabOrder = 2\r\n OnClick = ColorChange\r\n end\r\n end\r\n object gbUseDefaultsFor: TGroupBox\r\n Left = 299\r\n Top = 113\r\n Width = 104\r\n Height = 56\r\n Caption = 'Use defaults for:'\r\n TabOrder = 3\r\n object cbDefForeground: TCheckBox\r\n Left = 8\r\n Top = 17\r\n Width = 89\r\n Height = 17\r\n Caption = '&Foreground'\r\n TabOrder = 0\r\n OnClick = DefClick\r\n end\r\n object cbDefBackground: TCheckBox\r\n Left = 8\r\n Top = 34\r\n Width = 89\r\n Height = 17\r\n Caption = '&Background'\r\n TabOrder = 1\r\n OnClick = DefClick\r\n end\r\n end\r\n object Panel1: TPanel\r\n Left = 170\r\n Top = 48\r\n Width = 120\r\n Height = 120\r\n BevelOuter = bvNone\r\n TabOrder = 4\r\n object Cell0: TPanel\r\n Left = 1\r\n Top = 1\r\n Width = 28\r\n Height = 28\r\n BevelInner = bvLowered\r\n BevelOuter = bvLowered\r\n Caption = 'FB'\r\n Color = clBlack\r\n Font.Charset = DEFAULT_CHARSET\r\n Font.Color = clWhite\r\n Font.Height = -11\r\n Font.Name = 'MS Sans Serif'\r\n Font.Style = []\r\n ParentFont = False\r\n TabOrder = 0\r\n OnMouseDown = CellMouseDown\r\n end\r\n object Cell4: TPanel\r\n Tag = 4\r\n Left = 1\r\n Top = 31\r\n Width = 28\r\n Height = 28\r\n BevelInner = bvLowered\r\n BevelOuter = bvLowered\r\n Caption = 'FB'\r\n Color = clNavy\r\n Font.Charset = DEFAULT_CHARSET\r\n Font.Color = clWhite\r\n Font.Height = -11\r\n Font.Name = 'MS Sans Serif'\r\n Font.Style = []\r\n ParentFont = False\r\n TabOrder = 1\r\n OnMouseDown = CellMouseDown\r\n end\r\n object Cell8: TPanel\r\n Tag = 8\r\n Left = 1\r\n Top = 61\r\n Width = 28\r\n Height = 28\r\n BevelInner = bvLowered\r\n BevelOuter = bvLowered\r\n Caption = 'FB'\r\n Color = clGray\r\n Font.Charset = DEFAULT_CHARSET\r\n Font.Color = clWhite\r\n Font.Height = -11\r\n Font.Name = 'MS Sans Serif'\r\n Font.Style = []\r\n ParentFont = False\r\n TabOrder = 2\r\n OnMouseDown = CellMouseDown\r\n end\r\n object Cell12: TPanel\r\n Tag = 12\r\n Left = 1\r\n Top = 91\r\n Width = 28\r\n Height = 28\r\n BevelInner = bvLowered\r\n BevelOuter = bvLowered\r\n Caption = 'FB'\r\n Color = clBlue\r\n Font.Charset = DEFAULT_CHARSET\r\n Font.Color = clWhite\r\n Font.Height = -11\r\n Font.Name = 'MS Sans Serif'\r\n Font.Style = []\r\n ParentFont = False\r\n TabOrder = 3\r\n OnMouseDown = CellMouseDown\r\n end\r\n object Cell1: TPanel\r\n Tag = 1\r\n Left = 31\r\n Top = 1\r\n Width = 28\r\n Height = 28\r\n BevelInner = bvLowered\r\n BevelOuter = bvLowered\r\n Caption = 'FB'\r\n Color = clMaroon\r\n Font.Charset = DEFAULT_CHARSET\r\n Font.Color = clWhite\r\n Font.Height = -11\r\n Font.Name = 'MS Sans Serif'\r\n Font.Style = []\r\n ParentFont = False\r\n TabOrder = 4\r\n OnMouseDown = CellMouseDown\r\n end\r\n object Cell5: TPanel\r\n Tag = 5\r\n Left = 31\r\n Top = 31\r\n Width = 28\r\n Height = 28\r\n BevelInner = bvLowered\r\n BevelOuter = bvLowered\r\n Caption = 'FB'\r\n Color = clPurple\r\n Font.Charset = DEFAULT_CHARSET\r\n Font.Color = clWhite\r\n Font.Height = -11\r\n Font.Name = 'MS Sans Serif'\r\n Font.Style = []\r\n ParentFont = False\r\n TabOrder = 5\r\n OnMouseDown = CellMouseDown\r\n end\r\n object Cell9: TPanel\r\n Tag = 9\r\n Left = 31\r\n Top = 61\r\n Width = 28\r\n Height = 28\r\n BevelInner = bvLowered\r\n BevelOuter = bvLowered\r\n Caption = 'FB'\r\n Color = clRed\r\n Font.Charset = DEFAULT_CHARSET\r\n Font.Color = clBlack\r\n Font.Height = -11\r\n Font.Name = 'MS Sans Serif'\r\n Font.Style = []\r\n ParentFont = False\r\n TabOrder = 6\r\n OnMouseDown = CellMouseDown\r\n end\r\n object Cell13: TPanel\r\n Tag = 13\r\n Left = 31\r\n Top = 91\r\n Width = 28\r\n Height = 28\r\n BevelInner = bvLowered\r\n BevelOuter = bvLowered\r\n Caption = 'FB'\r\n Color = clFuchsia\r\n Font.Charset = DEFAULT_CHARSET\r\n Font.Color = clBlack\r\n Font.Height = -11\r\n Font.Name = 'MS Sans Serif'\r\n Font.Style = []\r\n ParentFont = False\r\n TabOrder = 7\r\n OnMouseDown = CellMouseDown\r\n end\r\n object Cell2: TPanel\r\n Tag = 2\r\n Left = 61\r\n Top = 1\r\n Width = 28\r\n Height = 28\r\n BevelInner = bvLowered\r\n BevelOuter = bvLowered\r\n Caption = 'FB'\r\n Color = clGreen\r\n Font.Charset = DEFAULT_CHARSET\r\n Font.Color = clWhite\r\n Font.Height = -11\r\n Font.Name = 'MS Sans Serif'\r\n Font.Style = []\r\n ParentFont = False\r\n TabOrder = 8\r\n OnMouseDown = CellMouseDown\r\n end\r\n object Cell6: TPanel\r\n Tag = 6\r\n Left = 61\r\n Top = 31\r\n Width = 28\r\n Height = 28\r\n BevelInner = bvLowered\r\n BevelOuter = bvLowered\r\n Caption = 'FB'\r\n Color = clTeal\r\n Font.Charset = DEFAULT_CHARSET\r\n Font.Color = clWhite\r\n Font.Height = -11\r\n Font.Name = 'MS Sans Serif'\r\n Font.Style = []\r\n ParentFont = False\r\n TabOrder = 9\r\n OnMouseDown = CellMouseDown\r\n end\r\n object Cell10: TPanel\r\n Tag = 10\r\n Left = 61\r\n Top = 61\r\n Width = 28\r\n Height = 28\r\n BevelInner = bvLowered\r\n BevelOuter = bvLowered\r\n Caption = 'FB'\r\n Color = clLime\r\n Font.Charset = DEFAULT_CHARSET\r\n Font.Color = clBlack\r\n Font.Height = -11\r\n Font.Name = 'MS Sans Serif'\r\n Font.Style = []\r\n ParentFont = False\r\n TabOrder = 10\r\n OnMouseDown = CellMouseDown\r\n end\r\n object Cell14: TPanel\r\n Tag = 14\r\n Left = 61\r\n Top = 91\r\n Width = 28\r\n Height = 28\r\n BevelInner = bvLowered\r\n BevelOuter = bvLowered\r\n Caption = 'FB'\r\n Color = clAqua\r\n Font.Charset = DEFAULT_CHARSET\r\n Font.Color = clBlack\r\n Font.Height = -11\r\n Font.Name = 'MS Sans Serif'\r\n Font.Style = []\r\n ParentFont = False\r\n TabOrder = 11\r\n OnMouseDown = CellMouseDown\r\n end\r\n object Cell3: TPanel\r\n Tag = 3\r\n Left = 91\r\n Top = 1\r\n Width = 28\r\n Height = 28\r\n BevelInner = bvLowered\r\n BevelOuter = bvLowered\r\n Caption = 'FB'\r\n Color = clOlive\r\n Font.Charset = DEFAULT_CHARSET\r\n Font.Color = clWhite\r\n Font.Height = -11\r\n Font.Name = 'MS Sans Serif'\r\n Font.Style = []\r\n ParentFont = False\r\n TabOrder = 12\r\n OnMouseDown = CellMouseDown\r\n end\r\n object Cell7: TPanel\r\n Tag = 7\r\n Left = 91\r\n Top = 31\r\n Width = 28\r\n Height = 28\r\n BevelInner = bvLowered\r\n BevelOuter = bvLowered\r\n Caption = 'FB'\r\n Color = clSilver\r\n Font.Charset = DEFAULT_CHARSET\r\n Font.Color = clBlack\r\n Font.Height = -11\r\n Font.Name = 'MS Sans Serif'\r\n Font.Style = []\r\n ParentFont = False\r\n TabOrder = 13\r\n OnMouseDown = CellMouseDown\r\n end\r\n object Cell11: TPanel\r\n Tag = 11\r\n Left = 91\r\n Top = 61\r\n Width = 28\r\n Height = 28\r\n BevelInner = bvLowered\r\n BevelOuter = bvLowered\r\n Caption = 'FB'\r\n Color = clYellow\r\n Font.Charset = DEFAULT_CHARSET\r\n Font.Color = clBlack\r\n Font.Height = -11\r\n Font.Name = 'MS Sans Serif'\r\n Font.Style = []\r\n ParentFont = False\r\n TabOrder = 14\r\n OnMouseDown = CellMouseDown\r\n end\r\n object Cell15: TPanel\r\n Tag = 15\r\n Left = 91\r\n Top = 91\r\n Width = 28\r\n Height = 28\r\n BevelInner = bvLowered\r\n BevelOuter = bvLowered\r\n Caption = 'FB'\r\n Color = clWhite\r\n Font.Charset = DEFAULT_CHARSET\r\n Font.Color = clBlack\r\n Font.Height = -11\r\n Font.Name = 'MS Sans Serif'\r\n Font.Style = []\r\n ParentFont = False\r\n TabOrder = 15\r\n OnMouseDown = CellMouseDown\r\n end\r\n end\r\n end\r\n end\r\n object bCancel: TButton\r\n Left = 352\r\n Top = 339\r\n Width = 75\r\n Height = 23\r\n Cancel = True\r\n Caption = 'Cancel'\r\n ModalResult = 2\r\n TabOrder = 2\r\n end\r\n object bOK: TButton\r\n Left = 268\r\n Top = 339\r\n Width = 75\r\n Height = 23\r\n Caption = 'OK'\r\n Default = True\r\n ModalResult = 1\r\n TabOrder = 1\r\n end\r\nend\r\n" }, { "path": "External/Jedi/Jvcl/run/JvHLEditorPropertyForm.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvHLEdPropDlg.PAS, released on 2002-07-04.\r\n\r\nThe Initial Developers of the Original Code are: Andrei Prygounkov \r\nCopyright (c) 1999, 2002 Andrei Prygounkov\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\ncomponent : TJvHLEdPropDlg\r\ndescription : Properties dialog for TJvHLEditor component\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvHLEditorPropertyForm.pas 13104 2011-09-07 06:50:43Z obones $\r\n\r\nunit JvHLEditorPropertyForm;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, Messages, SysUtils, Classes, Graphics, ComCtrls, Controls,\r\n Forms, StdCtrls, ExtCtrls,\r\n JvFormPlacement, JvEditorCommon, JvComponent, JvHLEditor;\r\n\r\ntype\r\n TJvHLEdPropDlg = class;\r\n\r\n TJvHLEditorParamsForm = class(TJvForm)\r\n Pages: TPageControl;\r\n bCancel: TButton;\r\n bOK: TButton;\r\n tsEditor: TTabSheet;\r\n lblEditorSpeedSettings: TLabel;\r\n cbKeyboardLayout: TComboBox;\r\n gbEditor: TGroupBox;\r\n cbUndoAfterSave: TCheckBox;\r\n cbDoubleClickLine: TCheckBox;\r\n cbKeepTrailingBlanks: TCheckBox;\r\n cbSytaxHighlighting: TCheckBox;\r\n cbAutoIndent: TCheckBox;\r\n cbSmartTab: TCheckBox;\r\n cbBackspaceUnindents: TCheckBox;\r\n cbGroupUndo: TCheckBox;\r\n cbCursorBeyondEOF: TCheckBox;\r\n eTabStops: TEdit;\r\n lblTabStops: TLabel;\r\n tsColors: TTabSheet;\r\n lblColorSpeedSettingsFor: TLabel;\r\n cbColorSettings: TComboBox;\r\n lblElement: TLabel;\r\n lbElements: TListBox;\r\n lblColor: TLabel;\r\n gbTextAttributes: TGroupBox;\r\n cbBold: TCheckBox;\r\n cbItalic: TCheckBox;\r\n cbUnderline: TCheckBox;\r\n gbUseDefaultsFor: TGroupBox;\r\n cbDefForeground: TCheckBox;\r\n cbDefBackground: TCheckBox;\r\n Label6: TLabel;\r\n Panel1: TPanel;\r\n Cell0: TPanel;\r\n Cell4: TPanel;\r\n Cell8: TPanel;\r\n Cell12: TPanel;\r\n Cell1: TPanel;\r\n Cell5: TPanel;\r\n Cell9: TPanel;\r\n Cell13: TPanel;\r\n Cell2: TPanel;\r\n Cell6: TPanel;\r\n Cell10: TPanel;\r\n Cell14: TPanel;\r\n Cell3: TPanel;\r\n Cell7: TPanel;\r\n Cell11: TPanel;\r\n Cell15: TPanel;\r\n cbCursorBeyondEOL: TCheckBox;\r\n procedure FormCreate(Sender: TObject);\r\n procedure NotImplemented(Sender: TObject);\r\n procedure lbElementsClick(Sender: TObject);\r\n procedure lbElementsDrawItem(Control: TWinControl; Index: Integer;\r\n Rect: TRect; State: TOwnerDrawState);\r\n procedure ColorChange(Sender: TObject);\r\n procedure cbColorSettingsChange(Sender: TObject);\r\n procedure DefClick(Sender: TObject);\r\n procedure CellMouseDown(Sender: TObject; Button: TMouseButton;\r\n Shift: TShiftState; X, Y: Integer);\r\n private\r\n JvHLEditorPreview: TJvHLEditor;\r\n FHighlighter: TJvHighlighter;\r\n SC: TJvSymbolColor;\r\n InChanging: Boolean;\r\n Params: TJvHLEdPropDlg;\r\n FColorSamples: TStringList;\r\n procedure LoadLocale;\r\n function ColorToIndex(const AColor: TColor): Integer;\r\n function GetColorIndex(const ColorName: string): Integer;\r\n function GetForegroundIndex: Integer;\r\n function GetBackgroundIndex: Integer;\r\n procedure SetColorIndex(const Index: Integer;\r\n const ColorName, OtherColorName: string);\r\n procedure SetForegroundIndex(const Index: Integer);\r\n procedure SetBackgroundIndex(const Index: Integer);\r\n function GetColorColor(const ColorName: string): TColor;\r\n function GetForegroundColor: TColor;\r\n function GetBackgroundColor: TColor;\r\n function GetCell(const Index: Integer): TPanel;\r\n function GetColorSamples: TStrings;\r\n procedure SetColorSamples(Value: TStrings);\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n procedure ParamsToControls;\r\n procedure ControlsToParams;\r\n property ColorSamples: TStrings read GetColorSamples write SetColorSamples;\r\n end;\r\n\r\n TJvHLEdActivePage = 0..1;\r\n TJvHLEdReadFrom = (rfStorage, rfHLEditor);\r\n TJvHLEdPages = set of (epEditor, epColors);\r\n TOnDialogPopup = procedure(Sender: TObject; Form: TForm) of object;\r\n TOnDialogClosed = procedure(Sender: TObject; Form: TForm; Apply: Boolean) of object;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvHLEdPropDlg = class(TComponent)\r\n private\r\n FJvHLEditor: TJvCustomEditorBase;\r\n FStorage: TJvFormStorage;\r\n FColorSamples: TStringList;\r\n FHighlighterCombo: Boolean;\r\n FActivePage: TJvHLEdActivePage;\r\n FReadFrom: TJvHLEdReadFrom;\r\n FPages: TJvHLEdPages;\r\n FStorageSection: string; { ini section for FStorage }\r\n FOnDialogPopup: TOnDialogPopup;\r\n FOnDialogClosed: TOnDialogClosed;\r\n function GetColorSamples: TStrings;\r\n procedure SetColorSamples(Value: TStrings);\r\n function IsPagesStored: Boolean;\r\n procedure SetJvHLEditor(const Value: TJvCustomEditorBase);\r\n procedure SetStorage(const Value: TJvFormStorage);\r\n protected\r\n procedure Notification(AComponent: TComponent; Operation: TOperation); override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n procedure Save;\r\n procedure Restore;\r\n procedure LoadHighlighterColors(AJvHLEditor: TJvCustomEditorBase; AHighlighter: TJvHighlighter);\r\n procedure SaveHighlighterColors(AJvHLEditor: TJvCustomEditorBase; AHighlighter: TJvHighlighter);\r\n function Execute: Boolean;\r\n procedure LoadCurrentHighlighterColors;\r\n procedure SaveCurrentHighlighterColors;\r\n published\r\n property JvHLEditor: TJvCustomEditorBase read FJvHLEditor write SetJvHLEditor;\r\n property Storage: TJvFormStorage read FStorage write SetStorage;\r\n property ColorSamples: TStrings read GetColorSamples write SetColorSamples;\r\n property HighlighterCombo: Boolean read FHighlighterCombo write FHighlighterCombo default True;\r\n property ActivePage: TJvHLEdActivePage read FActivePage write FActivePage default 0;\r\n property ReadFrom: TJvHLEdReadFrom read FReadFrom write FReadFrom default rfStorage;\r\n property Pages: TJvHLEdPages read FPages write FPages stored IsPagesStored;\r\n property StorageSection: string read FStorageSection write FStorageSection;\r\n property OnDialogPopup: TOnDialogPopup read FOnDialogPopup write FOnDialogPopup;\r\n property OnDialogClosed: TOnDialogClosed read FOnDialogClosed write FOnDialogClosed;\r\n end;\r\n\r\nconst\r\n Highlighters: array [TJvHighlighter] of PChar =\r\n ('None', 'Pascal', 'CBuilder', 'Sql', 'Python', 'Java', 'JScript', 'VB', 'Html',\r\n 'Perl', 'Ini', 'CocoR', 'PHP', 'NQC', 'C#', 'User Defined');\r\n\r\n HighlighterNames: array [TJvHighlighter] of PChar =\r\n ('Default', 'Pascal', 'CBuilder', 'Sql', 'Python', 'Java', 'JScript', 'VB', 'Html',\r\n 'Perl', 'Ini', 'Coco/R', 'PHP', 'NQC', 'C#', 'Custom');\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvHLEditorPropertyForm.pas $';\r\n Revision: '$Revision: 13104 $';\r\n Date: '$Date: 2011-09-07 08:50:43 +0200 (mer. 07 sept. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n Math,\r\n JvJVCLUtils, JvJCLUtils, JvResources, JvTypes;\r\n\r\n{$R *.dfm}\r\n\r\nfunction GetHardCodedExamples: string;\r\n forward;\r\n\r\nfunction Pixels(Control: TControl; APixels: Integer): Integer;\r\nvar\r\n Form: TForm;\r\nbegin\r\n Result := APixels;\r\n if Control is TForm then\r\n Form := TForm(Control)\r\n else\r\n Form := TForm(GetParentForm(Control));\r\n if Form.Scaled then\r\n Result := Result * Form.PixelsPerInch div 96;\r\nend;\r\n\r\n//=== { TJvSampleViewer } ====================================================\r\n\r\ntype\r\n TJvSampleViewer = class(TJvHLEditor)\r\n private\r\n TmpEd: TJvHLEditor;\r\n procedure WMLButtonDown(var Msg: TWMLButtonDown); message WM_LBUTTONDOWN;\r\n protected\r\n procedure WndProc(var Msg: TMessage); override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n end;\r\n\r\nconstructor TJvSampleViewer.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n TmpEd := TJvHLEditor.Create(Self);\r\n TmpEd.Visible := False;\r\n TmpEd.Parent := Self;\r\nend;\r\n\r\nprocedure TJvSampleViewer.WndProc(var Msg: TMessage);\r\nbegin\r\n case Msg.Msg of\r\n {WM_LBUTTONDOWN,}WM_LBUTTONUP, WM_RBUTTONDOWN, WM_RBUTTONUP,\r\n WM_MOUSEMOVE, WM_LBUTTONDBLCLK, WM_RBUTTONDBLCLK:\r\n { nothing - prevent user interact };\r\n else\r\n inherited WndProc(Msg);\r\n end;\r\nend;\r\n\r\nprocedure TJvSampleViewer.WMLButtonDown(var Msg: TWMLButtonDown);\r\nvar\r\n XX, YY: Integer;\r\n F: Integer;\r\n Str: string;\r\nbegin\r\n { also prevent user interact }\r\n { detect symbol type }\r\n Mouse2Caret(Msg.XPos, Msg.YPos, XX, YY);\r\n if Cardinal(YY) > Cardinal(TmpEd.Lines.Count) then\r\n Exit;\r\n if (XX = RightMargin) or (XX - 1 = RightMargin) then\r\n F := 13\r\n else\r\n begin\r\n TmpEd.Lines := Lines;\r\n TmpEd.Highlighter := Highlighter;\r\n { color values corresponds to lbElements ListBox }\r\n TmpEd.Font.Color := 0;\r\n with TmpEd.Colors do\r\n begin\r\n Comment.ForeColor := 1;\r\n Reserved.ForeColor := 2;\r\n Identifier.ForeColor := 3;\r\n Symbol.ForeColor := 4;\r\n Strings.ForeColor := 5;\r\n Number.ForeColor := 6;\r\n Preproc.ForeColor := 7;\r\n Declaration.ForeColor := 8;\r\n FunctionCall.ForeColor := 9;\r\n Statement.ForeColor := 10;\r\n PlainText.ForeColor := 11;\r\n end;\r\n TmpEd.SelForeColor := 12;\r\n Str := TmpEd.Lines[YY];\r\n TJvSampleViewer(TmpEd).GetLineAttr(Str, YY, 0, Max_X - 1);\r\n F := TJvSampleViewer(TmpEd).LineAttrs[XX].FC;\r\n end;\r\n (Owner as TJvHLEditorParamsForm).lbElements.ItemIndex := F;\r\n (Owner as TJvHLEditorParamsForm).lbElementsClick((Owner as TJvHLEditorParamsForm).lbElements);\r\nend;\r\n\r\n//=== { TJvHLEdPropDlg } =====================================================\r\n\r\nconstructor TJvHLEdPropDlg.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FHighlighterCombo := True;\r\n FColorSamples := TStringList.Create;\r\n FColorSamples.Text := GetHardCodedExamples;\r\n FPages := [epColors];\r\nend;\r\n\r\ndestructor TJvHLEdPropDlg.Destroy;\r\nbegin\r\n FColorSamples.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvHLEdPropDlg.Save;\r\nconst\r\n cParams = 'Params';\r\nvar\r\n S: string;\r\n HLed: IJvHLEditor;\r\nbegin\r\n if Storage <> nil then\r\n begin\r\n// raise Exception.CreateRes(@RsEHLEdPropDlg_RegAutoNotAssigned);\r\n FJvHLEditor.GetInterface(IJvHLEditor, HLed);\r\n S := AddSlash(FStorageSection) + cParams;\r\n with Storage do\r\n begin\r\n StoredValue['DoubleClickLine'] := FJvHLEditor.DoubleClickLine;\r\n StoredValue['UndoAfterSave'] := FJvHLEditor.UndoAfterSave;\r\n StoredValue['KeepTrailingBlanks'] := FJvHLEditor.KeepTrailingBlanks;\r\n StoredValue['AutoIndent'] := FJvHLEditor.AutoIndent;\r\n StoredValue['SmartTab'] := FJvHLEditor.SmartTab;\r\n StoredValue['BackspaceUnindents'] := FJvHLEditor.BackSpaceUnindents;\r\n StoredValue['GroupUndo'] := FJvHLEditor.GroupUndo;\r\n StoredValue['CursorBeyondEOF'] := FJvHLEditor.CursorBeyondEOF;\r\n StoredValue['CursorBeyondEOL'] := FJvHLEditor.CursorBeyondEOL;\r\n StoredValue['SyntaxHighlighting'] := HLed.SyntaxHighlighting;\r\n StoredValue['TabStops'] := FJvHLEditor.TabStops;\r\n StoredValue['RightMargin'] := FJvHLEditor.RightMargin;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvHLEdPropDlg.Restore;\r\nconst\r\n cParams = 'Params';\r\nvar\r\n S: string;\r\n HLed: IJvHLEditor;\r\nbegin\r\n if Storage <> nil then\r\n begin\r\n// raise Exception.CreateRes(@RsEHLEdPropDlg_RegAutoNotAssigned);\r\n S := AddSlash(StorageSection) + cParams;\r\n FJvHLEditor.GetInterface(IJvHLEditor, HLed);\r\n with Storage do\r\n begin\r\n FJvHLEditor.DoubleClickLine := DefaultValue['DoubleClickLine', FJvHLEditor.DoubleClickLine];\r\n FJvHLEditor.UndoAfterSave := DefaultValue['UndoAfterSave', FJvHLEditor.UndoAfterSave];\r\n FJvHLEditor.KeepTrailingBlanks := DefaultValue['KeepTrailingBlanks', FJvHLEditor.KeepTrailingBlanks];\r\n FJvHLEditor.AutoIndent := DefaultValue['AutoIndent', FJvHLEditor.AutoIndent];\r\n FJvHLEditor.SmartTab := DefaultValue['SmartTab', FJvHLEditor.SmartTab];\r\n FJvHLEditor.BackSpaceUnindents := DefaultValue['BackspaceUnindents', FJvHLEditor.BackSpaceUnindents];\r\n FJvHLEditor.GroupUndo := DefaultValue['GroupUndo', FJvHLEditor.GroupUndo];\r\n FJvHLEditor.CursorBeyondEOF := DefaultValue['CursorBeyondEOF', FJvHLEditor.CursorBeyondEOF];\r\n FJvHLEditor.CursorBeyondEOL := DefaultValue['CursorBeyondEOL', FJvHLEditor.CursorBeyondEOL];\r\n HLed.SyntaxHighlighting := DefaultValue['SyntaxHighlighting', HLed.SyntaxHighlighting];\r\n FJvHLEditor.TabStops := DefaultValue['TabStops', FJvHLEditor.TabStops];\r\n FJvHLEditor.RightMargin := DefaultValue['RightMargin', FJvHLEditor.RightMargin];\r\n end;\r\n end;\r\nend;\r\n\r\ntype\r\n TJvCustomEditorBaseAccessProtected = class(TJvCustomEditorBase);\r\n\r\nprocedure TJvHLEdPropDlg.SaveHighlighterColors(AJvHLEditor: TJvCustomEditorBase;\r\n AHighlighter: TJvHighlighter);\r\nvar\r\n Section: string;\r\n\r\n procedure SaveColor(AColor: TJvSymbolColor; const Prefix: string);\r\n begin\r\n Storage.StoredValue[Section + Prefix] :=\r\n ColorToString(AColor.ForeColor) + ', ' + ColorToString(AColor.BackColor) +\r\n ', ' + IntToStr(byte(AColor.Style));\r\n end;\r\n\r\nvar\r\n ed: TJvCustomEditorBaseAccessProtected;\r\n HLed: IJvHLEditor;\r\nbegin\r\n if Storage <> nil then\r\n begin\r\n// raise Exception.CreateRes(@RsEHLEdPropDlg_RegAutoNotAssigned);\r\n ed := TJvCustomEditorBaseAccessProtected(AJvHLEditor);\r\n FJvHLEditor.GetInterface(IJvHLEditor, HLed);\r\n Section := AddSlash(Storage.AppStoragePath) + AddSlash(StorageSection) +\r\n Highlighters[AHighlighter];\r\n Storage.StoredValue[Section + 'BackColor'] := ColorToString(ed.Color);\r\n Storage.StoredValue[Section + 'FontName'] := ed.Font.Name;\r\n Storage.StoredValue[Section + 'Charset'] := IntToStr(ed.Font.CharSet);\r\n Storage.StoredValue[Section + 'FontSize'] := ed.Font.Size;\r\n Storage.StoredValue[Section + 'RightMarginColor'] := ColorToString(ed.RightMarginColor);\r\n SaveColor(HLed.Colors.Number, 'Number');\r\n SaveColor(HLed.Colors.Strings, 'Strings');\r\n SaveColor(HLed.Colors.Symbol, 'Symbol');\r\n SaveColor(HLed.Colors.Comment, 'Comment');\r\n SaveColor(HLed.Colors.Reserved, 'Reserved');\r\n SaveColor(HLed.Colors.Identifier, 'Identifier');\r\n SaveColor(HLed.Colors.Preproc, 'Preproc');\r\n SaveColor(HLed.Colors.FunctionCall, 'FunctionCall');\r\n SaveColor(HLed.Colors.Declaration, 'Declaration');\r\n SaveColor(HLed.Colors.Statement, 'Statement');\r\n SaveColor(HLed.Colors.PlainText, 'PlainText');\r\n end;\r\nend;\r\n\r\nprocedure TJvHLEdPropDlg.LoadHighlighterColors(AJvHLEditor: TJvCustomEditorBase;\r\n AHighlighter: TJvHighlighter);\r\nvar\r\n Section: string;\r\n\r\n procedure LoadColor(AColor: TJvSymbolColor; DefaultForeColor,\r\n DefaultBackColor: TColor; DefaultStyle: TFontStyles; const Prefix: string);\r\n var\r\n S, S1: string;\r\n begin\r\n S := Storage.DefaultValue[Section + Prefix, ColorToString(DefaultForeColor) + ', ' + ColorToString(DefaultBackColor)\r\n + ', ' + IntToStr(byte(DefaultStyle))];\r\n S1 := Trim(SubStrBySeparator(S, 0, ','));\r\n if S1 <> '' then\r\n AColor.ForeColor := StringToColor(S1)\r\n else\r\n AColor.ForeColor := DefaultForeColor;\r\n S1 := Trim(SubStrBySeparator(S, 1, ','));\r\n if S1 <> '' then\r\n AColor.BackColor := StringToColor(S1)\r\n else\r\n AColor.BackColor := DefaultBackColor;\r\n S1 := Trim(SubStrBySeparator(S, 2, ','));\r\n if S1 <> '' then\r\n AColor.Style := TFontStyles(byte(StrToInt(S1)))\r\n else\r\n AColor.Style := DefaultStyle;\r\n end;\r\n\r\nvar\r\n ed: TJvCustomEditorBaseAccessProtected;\r\n HLed: IJvHLEditor;\r\nbegin\r\n if Storage <> nil then\r\n begin\r\n// raise Exception.CreateRes(@RsEHLEdPropDlg_RegAutoNotAssigned);\r\n ed := TJvCustomEditorBaseAccessProtected(AJvHLEditor);\r\n FJvHLEditor.GetInterface(IJvHLEditor, HLed);\r\n Section := AddSlash(StorageSection) + Highlighters[AHighlighter];\r\n LoadColor(HLed.Colors.Number, clNavy, clWindow, [], 'Number');\r\n LoadColor(HLed.Colors.Strings, clMaroon, clWindow, [], 'Strings');\r\n LoadColor(HLed.Colors.Symbol, clBlue, clWindow, [], 'Symbol');\r\n LoadColor(HLed.Colors.Comment, clOlive, clWindow, [fsItalic], 'Comment');\r\n LoadColor(HLed.Colors.Reserved, clWindowText, clWindow, [fsBold], 'Reserved');\r\n LoadColor(HLed.Colors.Identifier, clWindowText, clWindow, [], 'Identifier');\r\n LoadColor(HLed.Colors.Preproc, clGreen, clWindow, [], 'Preproc');\r\n LoadColor(HLed.Colors.FunctionCall, clWindowText, clWindow, [], 'FunctionCall');\r\n LoadColor(HLed.Colors.Declaration, clWindowText, clWindow, [], 'Declaration');\r\n LoadColor(HLed.Colors.Statement, clWindowText, clWindow, [], 'Statement');\r\n LoadColor(HLed.Colors.PlainText, clWindowText, clWindow, [], 'PlainText');\r\n try\r\n AJvHLEditor.Color := StringToColor(Storage.ReadString(Section + 'BackColor', 'clWindow'));\r\n except\r\n on E: EConvertError do\r\n AJvHLEditor.RightMarginColor := clWindow;\r\n end;\r\n ed.Font.Name := Storage.ReadString(Section + 'FontName', 'Courier New');\r\n ed.Font.CharSet := Storage.ReadInteger(Section + 'Charset', DEFAULT_CHARSET);\r\n ed.Font.Size := Storage.ReadInteger(Section + 'FontSize', 10);\r\n try\r\n ed.RightMarginColor := StringToColor(Storage.ReadString(Section + 'RightMarginColor', 'clSilver'));\r\n except\r\n on E: EConvertError do\r\n AJvHLEditor.RightMarginColor := clSilver;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJvHLEdPropDlg.Execute: Boolean;\r\nvar\r\n F: Integer;\r\n Form: TJvHLEditorParamsForm;\r\n HLed: IJvHLEditor;\r\nbegin\r\n if FJvHLEditor = nil then\r\n raise EJVCLException.CreateRes(@RsEHLEdPropDlg_RAHLEditorNotAssigned);\r\n Form := TJvHLEditorParamsForm.Create(Application);\r\n Form.ColorSamples.Assign(ColorSamples);\r\n with Form do\r\n try\r\n FJvHLEditor.GetInterface(IJvHLEditor, HLed);\r\n FHighlighter := HLed.Highlighter;\r\n Params := Self;\r\n ParamsToControls;\r\n if FReadFrom = rfHLEditor then\r\n JvHLEditorPreview.Assign(FJvHLEditor);\r\n\r\n tsEditor.TabVisible := epEditor in FPages;\r\n tsColors.TabVisible := epColors in FPages;\r\n\r\n F := FActivePage;\r\n\r\n if Assigned(FOnDialogPopup) then\r\n FOnDialogPopup(Self, Form);\r\n\r\n if Storage <> nil then\r\n F := Storage.ReadInteger(AddSlash(StorageSection) + 'Params' + 'ActivePage', F);\r\n F := Max(Min(F, Pages.PageCount - 1), 0);\r\n if not Pages.Pages[F].TabVisible then\r\n Pages.ActivePage := Pages.FindNextPage(Pages.Pages[F], True, True)\r\n else\r\n Pages.ActivePage := Pages.Pages[F];\r\n\r\n Result := ShowModal = mrOK;\r\n if Result then\r\n begin\r\n ControlsToParams;\r\n FJvHLEditor.Assign(JvHLEditorPreview);\r\n end;\r\n\r\n if (Storage <> nil) and (Pages.ActivePage <> nil) then\r\n Storage.WriteInteger(AddSlash(StorageSection) + 'Params' +\r\n 'ActivePage', Pages.ActivePage.PageIndex);\r\n\r\n if Assigned(FOnDialogClosed) then\r\n FOnDialogClosed(Self, Form, Result);\r\n finally\r\n Free;\r\n end;\r\nend;\r\n\r\nprocedure TJvHLEdPropDlg.LoadCurrentHighlighterColors;\r\nvar\r\n HLed: IJvHLEditor;\r\nbegin\r\n if FJvHLEditor.GetInterface(IJvHLEditor, HLed) then\r\n LoadHighlighterColors(FJvHLEditor, HLed.Highlighter);\r\nend;\r\n\r\nprocedure TJvHLEdPropDlg.SaveCurrentHighlighterColors;\r\nvar\r\n HLed: IJvHLEditor;\r\nbegin\r\n if FJvHLEditor.GetInterface(IJvHLEditor, HLed) then\r\n SaveHighlighterColors(FJvHLEditor, HLed.Highlighter);\r\nend;\r\n\r\nfunction TJvHLEdPropDlg.GetColorSamples: TStrings;\r\nbegin\r\n Result := FColorSamples;\r\nend;\r\n\r\nprocedure TJvHLEdPropDlg.SetColorSamples(Value: TStrings);\r\nbegin\r\n FColorSamples.Assign(Value);\r\nend;\r\n\r\nfunction TJvHLEdPropDlg.IsPagesStored: Boolean;\r\nbegin\r\n Result := FPages <> [epColors];\r\nend;\r\n\r\nprocedure TJvHLEdPropDlg.Notification(AComponent: TComponent;\r\n Operation: TOperation);\r\nbegin\r\n inherited Notification(AComponent, Operation);\r\n if Operation = opRemove then\r\n begin\r\n if AComponent = JvHLEditor then\r\n FJvHLEditor := nil // do not call SetJvHLEditor\r\n else\r\n if AComponent = Storage then\r\n FStorage := nil;\r\n end;\r\nend;\r\n\r\nprocedure TJvHLEdPropDlg.SetJvHLEditor(const Value: TJvCustomEditorBase);\r\nvar\r\n HLed: IJvHLEditor;\r\nbegin\r\n if ReplaceComponentReference(Self, Value, TComponent(FJvHLEditor)) then\r\n if Value <> nil then\r\n begin\r\n if Value.GetInterface(IJvHLEditor, HLed) then\r\n FJvHLEditor := Value;\r\n end;\r\nend;\r\n\r\nprocedure TJvHLEdPropDlg.SetStorage(const Value: TJvFormStorage);\r\nbegin\r\n ReplaceComponentReference(Self, Value, TComponent(FStorage));\r\nend;\r\n\r\n//=== { TJvHLEditorParamsForm } ==============================================\r\n\r\nconstructor TJvHLEditorParamsForm.Create(AOwner: TComponent);\r\nvar\r\n HL: TJvHighlighter;\r\nbegin\r\n inherited Create(AOwner);\r\n FColorSamples := TStringList.Create;\r\n cbColorSettings.Clear;\r\n for HL := Low(TJvHighlighter) to Pred(High(TJvHighlighter)) do\r\n cbColorSettings.Items.AddObject(HighlighterNames[HL], nil);\r\nend;\r\n\r\ndestructor TJvHLEditorParamsForm.Destroy;\r\nbegin\r\n FColorSamples.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJvHLEditorParamsForm.GetColorSamples: TStrings;\r\nbegin\r\n Result := FColorSamples;\r\nend;\r\n\r\nprocedure TJvHLEditorParamsForm.SetColorSamples(Value: TStrings);\r\nbegin\r\n FColorSamples.Assign(Value);\r\nend;\r\n\r\nprocedure TJvHLEditorParamsForm.ParamsToControls;\r\nvar\r\n I: Integer;\r\n HLed: IJvHLEditor;\r\nbegin\r\n Params.FJvHLEditor.GetInterface(IJvHLEditor, HLed);\r\n\r\n cbDoubleClickLine.Checked := Params.FJvHLEditor.DoubleClickLine;\r\n cbUndoAfterSave.Checked := Params.FJvHLEditor.UndoAfterSave;\r\n cbKeepTrailingBlanks.Checked := Params.FJvHLEditor.KeepTrailingBlanks;\r\n cbAutoIndent.Checked := Params.FJvHLEditor.AutoIndent;\r\n cbSmartTab.Checked := Params.FJvHLEditor.SmartTab;\r\n cbBackspaceUnindents.Checked := Params.FJvHLEditor.BackSpaceUnindents;\r\n cbGroupUndo.Checked := Params.FJvHLEditor.GroupUndo;\r\n cbCursorBeyondEOF.Checked := Params.FJvHLEditor.CursorBeyondEOF;\r\n cbCursorBeyondEOL.Checked := Params.FJvHLEditor.CursorBeyondEOL;\r\n cbSytaxHighlighting.Checked := HLed.SyntaxHighlighting;\r\n eTabStops.Text := string(Params.FJvHLEditor.TabStops);\r\n cbColorSettings.ItemIndex := Integer(FHighlighter);\r\n cbColorSettingsChange(nil);\r\n JvHLEditorPreview.RightMargin := Params.FJvHLEditor.RightMargin;\r\n cbColorSettings.Visible := Params.FHighlighterCombo;\r\n lblColorSpeedSettingsFor.Visible := Params.FHighlighterCombo;\r\n if not Params.FHighlighterCombo then\r\n begin\r\n for I := 0 to tsColors.ControlCount - 1 do\r\n tsColors.Controls[I].Top := tsColors.Controls[I].Top - Pixels(tsColors, 24);\r\n JvHLEditorPreview.Height := JvHLEditorPreview.Height + Pixels(tsColors, 24);\r\n end;\r\nend;\r\n\r\nprocedure TJvHLEditorParamsForm.ControlsToParams;\r\nvar\r\n HLed: IJvHLEditor;\r\nbegin\r\n Params.FJvHLEditor.GetInterface(IJvHLEditor, HLed);\r\n\r\n Params.FJvHLEditor.DoubleClickLine := cbDoubleClickLine.Checked;\r\n Params.FJvHLEditor.UndoAfterSave := cbUndoAfterSave.Checked;\r\n Params.FJvHLEditor.KeepTrailingBlanks := cbKeepTrailingBlanks.Checked;\r\n Params.FJvHLEditor.AutoIndent := cbAutoIndent.Checked;\r\n Params.FJvHLEditor.SmartTab := cbSmartTab.Checked;\r\n Params.FJvHLEditor.BackSpaceUnindents := cbBackspaceUnindents.Checked;\r\n Params.FJvHLEditor.GroupUndo := cbGroupUndo.Checked;\r\n Params.FJvHLEditor.CursorBeyondEOF := cbCursorBeyondEOF.Checked;\r\n Params.FJvHLEditor.CursorBeyondEOL := cbCursorBeyondEOL.Checked;\r\n HLed.SyntaxHighlighting := cbSytaxHighlighting.Checked;\r\n Params.FJvHLEditor.TabStops := eTabStops.Text;\r\n if Params.Storage <> nil then\r\n Params.SaveHighlighterColors(JvHLEditorPreview, JvHLEditorPreview.Highlighter);\r\nend;\r\n\r\nprocedure TJvHLEditorParamsForm.FormCreate(Sender: TObject);\r\nbegin\r\n LoadLocale;\r\n JvHLEditorPreview := TJvSampleViewer.Create(Self);\r\n JvHLEditorPreview.Parent := tsColors;\r\n JvHLEditorPreview.SetBounds(8, 176, 396, 110);\r\n JvHLEditorPreview.TabStop := False;\r\n cbKeyboardLayout.ItemIndex := 0;\r\n cbColorSettings.ItemIndex := 0;\r\n lbElements.ItemIndex := 0;\r\n lbElementsClick(nil);\r\nend;\r\n\r\nprocedure TJvHLEditorParamsForm.NotImplemented(Sender: TObject);\r\nbegin\r\n //(Sender as TCheckBox).Checked := True;\r\n //raise Exception.CreateRes(@RsEHLEdPropDlg_OptionCantBeChanged);\r\nend;\r\n\r\n{ Color tab }\r\n\r\n{ Color grid }\r\n\r\nfunction TJvHLEditorParamsForm.GetCell(const Index: Integer): TPanel;\r\nbegin\r\n Result := FindComponent('Cell' + IntToStr(Index)) as TPanel;\r\n if Result = nil then\r\n raise EJVCLException.CreateRes(@RsEHLEdPropDlg_GridCellNotFound);\r\nend;\r\n\r\nfunction TJvHLEditorParamsForm.ColorToIndex(const AColor: TColor): Integer;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := -1;\r\n for I := 0 to 15 do\r\n if GetCell(I).Color = AColor then\r\n begin\r\n Result := I;\r\n Exit;\r\n end;\r\nend;\r\n\r\nfunction TJvHLEditorParamsForm.GetColorIndex(const ColorName: string): Integer;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := -1;\r\n for I := 0 to 15 do\r\n if (GetCell(I).Caption = 'FB') or (GetCell(I).Caption = ColorName) then\r\n begin\r\n Result := I;\r\n Exit;\r\n end;\r\nend;\r\n\r\nfunction TJvHLEditorParamsForm.GetForegroundIndex: Integer;\r\nbegin\r\n Result := GetColorIndex('FC');\r\nend;\r\n\r\nfunction TJvHLEditorParamsForm.GetBackgroundIndex: Integer;\r\nbegin\r\n Result := GetColorIndex('BC');\r\nend;\r\n\r\nfunction TJvHLEditorParamsForm.GetColorColor(const ColorName: string): TColor;\r\nvar\r\n Index: Integer;\r\nbegin\r\n Index := GetColorIndex(ColorName);\r\n if Index > -1 then\r\n Result := GetCell(Index).Color\r\n else\r\n Result := clBlack;\r\nend;\r\n\r\nfunction TJvHLEditorParamsForm.GetForegroundColor: TColor;\r\nbegin\r\n Result := GetColorColor('FC');\r\nend;\r\n\r\nfunction TJvHLEditorParamsForm.GetBackgroundColor: TColor;\r\nbegin\r\n Result := GetColorColor('BC');\r\nend;\r\n\r\nprocedure TJvHLEditorParamsForm.SetColorIndex(const Index: Integer;\r\n const ColorName, OtherColorName: string);\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := 0 to 15 do\r\n if (GetCell(I).Caption = 'FB') or (GetCell(I).Caption = ColorName) then\r\n GetCell(I).Caption := ColorName\r\n else\r\n GetCell(I).Caption := '';\r\n if Index > -1 then\r\n if GetCell(Index).Caption = ColorName then\r\n GetCell(Index).Caption := 'FB'\r\n else\r\n GetCell(Index).Caption := OtherColorName;\r\nend;\r\n\r\nprocedure TJvHLEditorParamsForm.SetForegroundIndex(const Index: Integer);\r\nbegin\r\n SetColorIndex(Index, 'BC', 'FC');\r\nend;\r\n\r\nprocedure TJvHLEditorParamsForm.SetBackgroundIndex(const Index: Integer);\r\nbegin\r\n SetColorIndex(Index, 'FC', 'BC');\r\nend;\r\n\r\nprocedure TJvHLEditorParamsForm.CellMouseDown(Sender: TObject;\r\n Button: TMouseButton; Shift: TShiftState; X, Y: Integer);\r\nbegin\r\n if Button = mbLeft then\r\n SetForegroundIndex((Sender as TPanel).Tag)\r\n else\r\n if Button = mbRight then\r\n SetBackgroundIndex((Sender as TPanel).Tag);\r\n ColorChange(Sender);\r\nend;\r\n\r\n{ color grid ### }\r\n\r\nprocedure TJvHLEditorParamsForm.lbElementsClick(Sender: TObject);\r\nvar\r\n FC, BC: TColor;\r\n ST: TFontStyles;\r\nbegin\r\n InChanging := True;\r\n try\r\n SC := nil;\r\n ST := [];\r\n FC := clWindowText;\r\n BC := clWindow;\r\n case lbElements.ItemIndex of\r\n 0: { Whitespace }\r\n begin\r\n FC := JvHLEditorPreview.Font.Color;\r\n BC := JvHLEditorPreview.Color;\r\n end;\r\n 1: { Comment }\r\n SC := JvHLEditorPreview.Colors.Comment;\r\n 2: { Reserved word }\r\n SC := JvHLEditorPreview.Colors.Reserved;\r\n 3: { Identifier }\r\n SC := JvHLEditorPreview.Colors.Identifier;\r\n 4: { Symbol }\r\n SC := JvHLEditorPreview.Colors.Symbol;\r\n 5: { String }\r\n SC := JvHLEditorPreview.Colors.Strings;\r\n 6: { Number }\r\n SC := JvHLEditorPreview.Colors.Number;\r\n 7: { Preprocessor }\r\n SC := JvHLEditorPreview.Colors.Preproc;\r\n 8: { Declaration }\r\n SC := JvHLEditorPreview.Colors.Declaration;\r\n 9: { Function call }\r\n SC := JvHLEditorPreview.Colors.FunctionCall;\r\n 10: { VB Statement }\r\n SC := JvHLEditorPreview.Colors.Statement;\r\n 11: { PlainText }\r\n SC := JvHLEditorPreview.Colors.PlainText;\r\n 12: { Marked block }\r\n begin\r\n FC := JvHLEditorPreview.SelForeColor;\r\n BC := JvHLEditorPreview.SelBackColor;\r\n end;\r\n 13: { Right margin }\r\n begin\r\n FC := JvHLEditorPreview.RightMarginColor;\r\n BC := -1;\r\n end;\r\n end;\r\n if SC <> nil then\r\n begin\r\n FC := SC.ForeColor;\r\n BC := SC.BackColor;\r\n ST := SC.Style;\r\n end;\r\n cbDefForeground.Checked := ((lbElements.ItemIndex < 12) and (FC = clWindowText)) or\r\n ((lbElements.ItemIndex = 12) and (FC = clHighlightText));\r\n cbDefBackground.Checked := ((lbElements.ItemIndex < 12) and (BC = clWindow)) or\r\n ((lbElements.ItemIndex = 12) and (BC = clHighlight));\r\n if not cbDefForeground.Checked then\r\n SetForegroundIndex(ColorToIndex(FC))\r\n else\r\n SetForegroundIndex(-1);\r\n if not cbDefBackground.Checked then\r\n SetBackgroundIndex(ColorToIndex(BC))\r\n else\r\n SetBackgroundIndex(-1);\r\n cbBold.Checked := fsBold in ST;\r\n cbItalic.Checked := fsItalic in ST;\r\n cbUnderline.Checked := fsUnderline in ST;\r\n finally\r\n InChanging := False;\r\n end;\r\nend;\r\n\r\nprocedure TJvHLEditorParamsForm.ColorChange(Sender: TObject);\r\nvar\r\n FC, BC: TColor;\r\n ST: TFontStyles;\r\nbegin\r\n if InChanging then\r\n Exit;\r\n InChanging := True;\r\n try\r\n ST := [];\r\n if GetForegroundIndex <> -1 then\r\n cbDefForeground.Checked := False;\r\n if GetBackgroundIndex <> -1 then\r\n cbDefBackground.Checked := False;\r\n if cbDefForeground.Checked then\r\n begin\r\n if lbElements.ItemIndex = 12 then\r\n FC := clHighlightText\r\n else\r\n FC := clWindowText;\r\n SetForegroundIndex(-1);\r\n end\r\n else\r\n FC := GetForegroundColor;\r\n if cbDefBackground.Checked then\r\n begin\r\n if lbElements.ItemIndex = 12 then { marked block }\r\n BC := clHighlight\r\n else\r\n BC := clWindow;\r\n SetBackgroundIndex(-1);\r\n end\r\n else\r\n BC := GetBackgroundColor;\r\n if cbBold.Checked then\r\n Include(ST, fsBold);\r\n if cbItalic.Checked then\r\n Include(ST, fsItalic);\r\n if cbUnderline.Checked then\r\n Include(ST, fsUnderline);\r\n if SC <> nil then\r\n begin\r\n SC.Style := ST;\r\n SC.ForeColor := FC;\r\n SC.BackColor := BC;\r\n end\r\n else\r\n if lbElements.ItemIndex = 12 then { marked block }\r\n begin\r\n JvHLEditorPreview.SelForeColor := FC;\r\n JvHLEditorPreview.SelBackColor := BC;\r\n end\r\n else\r\n if lbElements.ItemIndex = 0 then { whitespace }\r\n JvHLEditorPreview.Color := BC\r\n else\r\n if lbElements.ItemIndex = 13 then { right margin }\r\n JvHLEditorPreview.RightMarginColor := FC;\r\n JvHLEditorPreview.Invalidate;\r\n finally\r\n InChanging := False;\r\n end;\r\nend;\r\n\r\nprocedure TJvHLEditorParamsForm.DefClick(Sender: TObject);\r\nbegin\r\n if InChanging then\r\n Exit;\r\n if cbDefForeground.Checked then\r\n SetForegroundIndex(-1);\r\n if cbDefBackground.Checked then\r\n SetBackgroundIndex(-1);\r\n ColorChange(nil);\r\nend;\r\n\r\nprocedure TJvHLEditorParamsForm.lbElementsDrawItem(Control: TWinControl;\r\n Index: Integer; Rect: TRect; State: TOwnerDrawState);\r\nbegin\r\n with (Control as TListBox).Canvas do { draw on control canvas, not on the form }\r\n begin\r\n FillRect(Rect); { clear the rectangle }\r\n TextOut(Rect.Left, Rect.Top, (Control as TListBox).Items[Index]) { display the text }\r\n end;\r\nend;\r\n\r\nprocedure ReadColorSampleSection(Ini: TStrings; const Section: string; Lines: TStrings);\r\nvar\r\n I: Integer;\r\n S: string;\r\n InSection: Boolean;\r\nbegin\r\n Lines.Clear;\r\n InSection := False;\r\n for I := 0 to Ini.Count - 1 do\r\n begin\r\n S := Ini[I];\r\n if (S <> '') and (S[1] = '[') and (S[Length(S)] = ']') then\r\n begin\r\n if AnsiSameText(Copy(S, 2, Length(S) - 2), Section) then\r\n InSection := True\r\n else\r\n if InSection then\r\n Break;\r\n Continue;\r\n end;\r\n if InSection then\r\n Lines.Add(Ini[I]);\r\n end;\r\nend;\r\n\r\nprocedure TJvHLEditorParamsForm.cbColorSettingsChange(Sender: TObject);\r\nvar\r\n I: Integer;\r\nbegin\r\n if (Sender <> nil) and (Params.Storage <> nil) then\r\n Params.SaveHighlighterColors(JvHLEditorPreview, JvHLEditorPreview.Highlighter);\r\n\r\n if cbColorSettings.Visible then\r\n ReadColorSampleSection(ColorSamples, cbColorSettings.Text, JvHLEditorPreview.Lines)\r\n else\r\n ReadColorSampleSection(ColorSamples, HighlighterNames[FHighlighter], JvHLEditorPreview.Lines);\r\n\r\n JvHLEditorPreview.Highlighter := TJvHighlighter(cbColorSettings.ItemIndex);\r\n if JvHLEditorPreview.Highlighter = hlIni then\r\n for I := 0 to JvHLEditorPreview.Lines.Count - 1 do\r\n JvHLEditorPreview.Lines[I] := Copy(JvHLEditorPreview.Lines[I], 2, 10000);\r\n if Params.Storage <> nil then\r\n Params.LoadHighlighterColors(JvHLEditorPreview, JvHLEditorPreview.Highlighter);\r\n lbElementsClick(nil);\r\nend;\r\n\r\nprocedure TJvHLEditorParamsForm.LoadLocale;\r\nbegin\r\n Caption := RsHLEdPropDlg_Caption;\r\n tsEditor.Caption := RsHLEdPropDlg_tsEditor;\r\n tsColors.Caption := RsHLEdPropDlg_tsColors;\r\n lblEditorSpeedSettings.Caption := RsHLEdPropDlg_lblEditorSpeedSettings;\r\n cbKeyboardLayout.Items[0] := RsHLEdPropDlg_cbKeyboardLayoutDefault;\r\n gbEditor.Caption := RsHLEdPropDlg_gbEditor;\r\n cbAutoIndent.Caption := RsHLEdPropDlg_cbAutoIndent;\r\n cbSmartTab.Caption := RsHLEdPropDlg_cbSmartTab;\r\n cbBackspaceUnindents.Caption := RsHLEdPropDlg_cbBackspaceUnindents;\r\n cbGroupUndo.Caption := RsHLEdPropDlg_cbGroupUndo;\r\n cbCursorBeyondEOF.Caption := RsHLEdPropDlg_cbCursorBeyondEOF;\r\n cbCursorBeyondEOL.Caption := RsHLEdPropDlg_cbCursorBeyondEOL;\r\n cbUndoAfterSave.Caption := RsHLEdPropDlg_cbUndoAfterSave;\r\n cbKeepTrailingBlanks.Caption := RsHLEdPropDlg_cbKeepTrailingBlanks;\r\n cbDoubleClickLine.Caption := RsHLEdPropDlg_cbDoubleClickLine;\r\n cbSytaxHighlighting.Caption := RsHLEdPropDlg_cbSytaxHighlighting;\r\n lblTabStops.Caption := RsHLEdPropDlg_lblTabStops;\r\n lblColorSpeedSettingsFor.Caption := RsHLEdPropDlg_lblColorSpeedSettingsFor;\r\n lblElement.Caption := RsHLEdPropDlg_lblElement;\r\n lblColor.Caption := RsHLEdPropDlg_lblColor;\r\n gbTextAttributes.Caption := RsHLEdPropDlg_gbTextAttributes;\r\n gbUseDefaultsFor.Caption := RsHLEdPropDlg_gbUseDefaultsFor;\r\n cbBold.Caption := RsHLEdPropDlg_cbBold;\r\n cbItalic.Caption := RsHLEdPropDlg_cbItalic;\r\n cbUnderline.Caption := RsHLEdPropDlg_cbUnderline;\r\n cbDefForeground.Caption := RsHLEdPropDlg_cbDefForeground;\r\n cbDefBackground.Caption := RsHLEdPropDlg_cbDefBackground;\r\n bOK.Caption := RsButtonOKCaption;\r\n bCancel.Caption := RsButtonCancelCaption;\r\nend;\r\n\r\nfunction GetHardCodedExamples: string;\r\nbegin\r\n Result :=\r\n '[Default]'#10 +\r\n 'Plain text'#10 +\r\n 'Selected text'#10 +\r\n ''#10 +\r\n '[Pascal]'#10 +\r\n '{ Syntax highlighting }'#10 +\r\n '{$DEFINE DELPHI}'#10 +\r\n 'procedure TMain.JvHLEditorPreviewChangeStatus(Sender: TObject);'#10 +\r\n 'const'#10 +\r\n ' Modi: array [Boolean] of string[10] = ('#39#39', '#39'Modified'#39');'#10 +\r\n ' Modes: array [Boolean] of string[10] = ('#39'Overwrite'#39', '#39'Insert'#39');'#10 +\r\n 'begin'#10 +\r\n ' with StatusBar, JvHLEditorPreview do'#10 +\r\n ' begin'#10 +\r\n ' Panels[0].Text := IntToStr(CaretY) + '#39':'#39' + IntToStr(CaretX);'#10 +\r\n ' Panels[1].Text := Modi[Modified];'#10 +\r\n ' if ReadOnly then'#10 +\r\n ' Panels[2].Text := '#39'ReadOnly'#39 +\r\n ' else'#10 +\r\n ' if Recording then'#10 +\r\n ' Panels[2].Text := '#39'Recording'#39 +\r\n ' else'#10 +\r\n ' Panels[2].Text := Modes[InsertMode];'#10 +\r\n ' miFileSave.Enabled := Modified;'#10 +\r\n ' end;'#10 +\r\n 'end;'#10 +\r\n '[]'#10 +\r\n ''#10 +\r\n '[CBuilder]'#10 +\r\n '/* Syntax highlighting */'#10 +\r\n '#include \"zlib.h\"'#10 +\r\n ''#10 +\r\n '#define local static'#10 +\r\n ''#10 +\r\n 'local int crc_table_empty = 1;'#10 +\r\n ''#10 +\r\n 'local void make_crc_table()'#10 +\r\n '{'#10 +\r\n ' uLong c;'#10 +\r\n ' int n, k;'#10 +\r\n ' uLong poly; /* polynomial exclusive-or pattern */'#10 +\r\n ' /* terms of polynomial defining this crc (except x^32): */'#10 +\r\n ' static Byte p[] = {0,1,2,4,5,7,8,10,11,12,16,22,23,26};'#10 +\r\n ''#10 +\r\n ' /* make exclusive-or pattern from polynomial (0xedb88320L) */'#10 +\r\n ' poly = 0L;'#10 +\r\n ' for (n = 0; n < sizeof(p)/sizeof(Byte); n++)'#10 +\r\n ' poly |= 1L << (31 - p[n]);'#10 +\r\n ''#10 +\r\n ' for (n = 0; n < 256; n++)'#10 +\r\n ' {'#10 +\r\n ' c = (uLong)n;'#10 +\r\n ' for (k = 0; k < 8; k++)'#10 +\r\n ' c = c & 1 ? poly ^ (c >> 1) : c >> 1;'#10 +\r\n ' crc_table[n] = c;'#10 +\r\n ' }'#10 +\r\n ' crc_table_empty = 0;'#10 +\r\n '}'#10 +\r\n '[]'#10 +\r\n ''#10 +\r\n '[VB]'#10 +\r\n 'Rem Syntax highlighting'#10 +\r\n 'Sub Main()'#10 +\r\n ' Dim S as String'#10 +\r\n ' If S = \"\" Then'#10 +\r\n ' '#39' Do something'#10 +\r\n ' MsgBox \"Hallo World\"'#10 +\r\n ' End If'#10 +\r\n 'End Sub'#10 +\r\n '[]'#10 +\r\n ''#10 +\r\n '[Sql]'#10 +\r\n '/* Syntax highlighting */'#10 +\r\n 'declare external function Copy'#10 +\r\n ' cstring(255), integer, integer'#10 +\r\n ' returns cstring(255)'#10 +\r\n ' entry_point \"Copy\" module_name \"nbsdblib\";'#10 +\r\n '[]'#10 +\r\n ''#10 +\r\n '[Python]'#10 +\r\n '# Syntax highlighting'#10 +\r\n ''#10 +\r\n 'from Tkinter import *'#10 +\r\n 'from Tkinter import _cnfmerge'#10 +\r\n ''#10 +\r\n 'class Dialog(Widget):'#10 +\r\n ' def __init__(self, master=None, cnf={}, **kw):'#10 +\r\n ' cnf = _cnfmerge((cnf, kw))'#10 +\r\n ' self.widgetName = '#39'__dialog__'#39 +\r\n ' Widget._setup(self, master, cnf)'#10 +\r\n ' self.num = self.tk.getint('#10 +\r\n ' apply(self.tk.call,'#10 +\r\n ' ('#39'tk_dialog'#39', self._w,'#10 +\r\n ' cnf['#39'title'#39'], cnf['#39'text'#39'],'#10 +\r\n ' cnf['#39'bitmap'#39'], cnf['#39'default'#39'])'#10 +\r\n ' + cnf['#39'strings'#39']))'#10 +\r\n ' try: Widget.destroy(self)'#10 +\r\n ' except TclError: pass'#10 +\r\n ' def destroy(self): pass'#10 +\r\n '[]'#10 +\r\n ''#10 +\r\n '[Java]'#10 +\r\n '/* Syntax highlighting */'#10 +\r\n 'public class utils {'#10 +\r\n ' public static String GetPropsFromTag(String str, String props) {'#10 +\r\n ' int bi;'#10 +\r\n ' String Res = \"\";'#10 +\r\n ' bi = str.indexOf(props);'#10 +\r\n ' if (bi > -1) {'#10 +\r\n ' str = str.substring(bi);'#10 +\r\n ' bi = str.indexOf(\"\\\"\");'#10 +\r\n ' if (bi > -1) {'#10 +\r\n ' str = str.substring(bi+1);'#10 +\r\n ' Res = str.substring(0, str.indexOf(\"\\\"\"));'#10 +\r\n ' } else Res = \"true\";'#10 +\r\n ' }'#10 +\r\n ' return Res;'#10 +\r\n ' }'#10 +\r\n '[]'#10 +\r\n ''#10 +\r\n '[Html]'#10 +\r\n ''#10 +\r\n ''#10 +\r\n ''#10 +\r\n 'JVCLmp;A Library home page'#10 +\r\n ''#10 +\r\n ''#10 +\r\n ''#10 +\r\n ''#10 +\r\n '

Download last JVCLmp;A Library version now - ralib110.zip'#10 +\r\n '(575 Kb).

'#10 +\r\n ''#10 +\r\n ''#10 +\r\n ''#10 +\r\n '[]'#10 +\r\n ''#10 +\r\n '[Perl]'#10 +\r\n '#!/usr/bin/perl'#10 +\r\n '# Syntax highlighting'#10 +\r\n ''#10 +\r\n 'require \"webtester.pl\";'#10 +\r\n ''#10 +\r\n '$InFile = \"/usr/foo/scripts/index.shtml\";'#10 +\r\n '$OutFile = \"/usr/foo/scripts/sitecheck.html\";'#10 +\r\n '$MapFile = \"/usr/foo/scripts/sitemap.html\";'#10 +\r\n ''#10 +\r\n 'sub MainProg {'#10 +\r\n #9'require \"find.pl\";'#10 +\r\n #9'&Initialize;'#10 +\r\n #9'&SiteCheck;'#10 +\r\n #9'if ($MapFile) { &SiteMap; }'#10 +\r\n #9'exit;'#10 +\r\n '}'#10 +\r\n '[Ini]'#10 +\r\n ' ; Syntax highlighting'#10 +\r\n ' [drivers]'#10 +\r\n ' wave=mmdrv.dll'#10 +\r\n ' timer=timer.drv'#10 +\r\n ''#10 +\r\n ' plain text'#10 +\r\n '[Coco/R]'#10 +\r\n 'TOKENS'#10 +\r\n ' NUMBER = digit { digit } .'#10 +\r\n ' EOL = eol .'#10 +\r\n ''#10 +\r\n 'PRODUCTIONS'#10 +\r\n ''#10 +\r\n 'ExprPostfix ='#10 +\r\n ' (. Output := '#39#39'; .)'#10 +\r\n ' Expression EOL'#10 +\r\n ' (. ShowOutput(Output); .)'#10 +\r\n ' .'#10 +\r\n '[]';\r\nend;\r\n\r\n(*\r\n object raColorSamples: TJvRegAuto\r\n RegPath = 'Software\\nbs\\RANotepad'\r\n Storage = raIniStrings\r\n IniFile = '$HOME/.JvInterpreterTest'\r\n IniStrings.Strings = (\r\n '[Default]'\r\n 'Plain text'\r\n 'Selected text'\r\n ''\r\n '[Pascal]'\r\n '{ Syntax highlighting }'\r\n 'procedure TMain.JvHLEditorPreviewChangeStatus(Sender: TObject);'\r\n 'const'\r\n ' Modi: array [Boolean] of string[10] = ('#39#39', '#39'Modified'#39');'\r\n ' Modes: array [Boolean] of string[10] = ('#39'Overwrite'#39', '#39'Insert'#39');'\r\n 'begin'\r\n ' with StatusBar, JvHLEditorPreview do'\r\n ' begin'\r\n ' Panels[0].Text := IntToStr(CaretY) + '#39':'#39' + IntToStr(CaretX);'\r\n ' Panels[1].Text := Modi[Modified];'\r\n ' if ReadOnly then'\r\n ' Panels[2].Text := '#39'ReadOnly'#39\r\n ' else'\r\n ' if Recording then'\r\n ' Panels[2].Text := '#39'Recording'#39\r\n ' else'\r\n ' Panels[2].Text := Modes[InsertMode];'\r\n ' miFileSave.Enabled := Modified;'\r\n ' end;'\r\n 'end;'\r\n '[]'\r\n ''\r\n '[CBuilder]'\r\n '/* Syntax highlighting */'\r\n '#include \"zlib.h\"'\r\n ''\r\n '#define local static'\r\n ''\r\n 'local int crc_table_empty = 1;'\r\n ''\r\n 'local void make_crc_table()'\r\n '{'\r\n ' uLong c;'\r\n ' int n, k;'\r\n ' uLong poly; /* polynomial exclusive-or pattern */'\r\n ' /* terms of polynomial defining this crc (except x^32): */'\r\n ' static Byte p[] = {0,1,2,4,5,7,8,10,11,12,16,22,23,26};'\r\n ''\r\n ' /* make exclusive-or pattern from polynomial (0xedb88320L) */'\r\n ' poly = 0L;'\r\n ' for (n = 0; n < sizeof(p)/sizeof(Byte); n++)'\r\n ' poly |= 1L << (31 - p[n]);'\r\n ''\r\n ' for (n = 0; n < 256; n++)'\r\n ' {'\r\n ' c = (uLong)n;'\r\n ' for (k = 0; k < 8; k++)'\r\n ' c = c & 1 ? poly ^ (c >> 1) : c >> 1;'\r\n ' crc_table[n] = c;'\r\n ' }'\r\n ' crc_table_empty = 0;'\r\n '}'\r\n '[]'\r\n ''\r\n '[VB]'\r\n 'Rem Syntax highlighting'\r\n 'Sub Main()'\r\n ' Dim S as String'\r\n ' If S = \"\" Then'\r\n ' '#39' Do something'\r\n ' MsgBox \"Hallo\"'\r\n ' End If'\r\n 'End Sub'\r\n '[]'\r\n ''\r\n '[Sql]'\r\n '/* Syntax highlighting */'\r\n 'declare external function Copy'\r\n ' cstring(255), integer, integer'\r\n ' returns cstring(255)'\r\n ' entry_point \"Copy\" module_name \"nbsdblib\";'\r\n '[]'\r\n ''\r\n '[Python]'\r\n '# Syntax highlighting'\r\n ''\r\n 'from Tkinter import *'\r\n 'from Tkinter import _cnfmerge'\r\n ''\r\n 'class Dialog(Widget):'\r\n ' def __init__(self, master=None, cnf={}, **kw):'\r\n ' cnf = _cnfmerge((cnf, kw))'\r\n ' self.widgetName = '#39'__dialog__'#39\r\n ' Widget._setup(self, master, cnf)'\r\n ' self.num = self.tk.getint('\r\n ' apply(self.tk.call,'\r\n ' ('#39'tk_dialog'#39', self._w,'\r\n ' cnf['#39'title'#39'], cnf['#39'text'#39'],'\r\n ' cnf['#39'bitmap'#39'], cnf['#39'default'#39'])'\r\n ' + cnf['#39'strings'#39']))'\r\n ' try: Widget.destroy(self)'\r\n ' except TclError: pass'\r\n ' def destroy(self): pass'\r\n '[]'\r\n ''\r\n '[Java]'\r\n '/* Syntax highlighting */'\r\n 'public class utils {'\r\n\r\n ' public static String GetPropsFromTag(String str, String props)' +\r\n ' {'\r\n ' int bi;'\r\n ' String Res = \"\";'\r\n ' bi = str.indexOf(props);'\r\n ' if (bi > -1) {'\r\n ' str = str.substring(bi);'\r\n ' bi = str.indexOf(\"\\\"\");'\r\n ' if (bi > -1) {'\r\n ' str = str.substring(bi+1);'\r\n ' Res = str.substring(0, str.indexOf(\"\\\"\"));'\r\n ' } else Res = \"true\";'\r\n ' }'\r\n ' return Res;'\r\n ' }'\r\n '[]'\r\n ''\r\n '[Html]'\r\n ''\r\n ''\r\n ''\r\n 'JVCLmp;A Library home page'\r\n ''\r\n ''\r\n\r\n ''\r\n ''\r\n\r\n '

Download last JVCLmp;A Library version now - ralib110.zip'\r\n\r\n '(575 Kb)' +\r\n '.

'\r\n ''\r\n ''\r\n ''\r\n '[]'\r\n ''\r\n '[Perl]'\r\n '#!/usr/bin/perl'\r\n '# Syntax highlighting'\r\n ''\r\n 'require \"webtester.pl\";'\r\n ''\r\n '$InFile = \"/usr/foo/scripts/index.shtml\";'\r\n '$OutFile = \"/usr/foo/scripts/sitecheck.html\";'\r\n '$MapFile = \"/usr/foo/scripts/sitemap.html\";'\r\n ''\r\n 'sub MainProg {'\r\n #9'require \"find.pl\";'\r\n #9'&Initialize;'\r\n #9'&SiteCheck;'\r\n #9'if ($MapFile) { &SiteMap; }'\r\n #9'exit;'\r\n '}'\r\n '[Ini]'\r\n ' ; Syntax highlighting'\r\n ' [drivers]'\r\n ' wave=mmdrv.dll'\r\n ' timer=timer.drv'\r\n ''\r\n ' plain text'\r\n '[Coco/R]'\r\n 'TOKENS'\r\n ' NUMBER = digit { digit } .'\r\n ' EOL = eol .'\r\n ''\r\n 'PRODUCTIONS'\r\n ''\r\n 'ExprPostfix ='\r\n ' (. Output := '#39#39'; .)'\r\n ' Expression EOL'\r\n ' (. ShowOutput(Output); .)'\r\n ' .'\r\n '[]')\r\n*)\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvHLParser.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvHLParser.PAS, released on 2002-07-04.\r\n\r\nThe Initial Developers of the Original Code are: Andrei Prygounkov \r\nCopyright (c) 1999, 2002 Andrei Prygounkov\r\nAll Rights Reserved.\r\n\r\nContributor(s): Eswar Prakash R [eswar dott prakash att gmail.com]\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nclass : TJvIParser\r\ndescription : text parser\r\n\r\nKnown Issues:\r\n Some russian comments were translated to english; these comments are marked\r\n with [translated]\r\n\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvHLParser.pas 13138 2011-10-26 23:17:50Z jfudickar $\r\n\r\n{history:\r\n3.0:\r\n 2003-09-20: (changes by Andreas Hausladen)\r\n - added a TJvIParserW parser for unicode text\r\n - added unicode versions of the functions\r\n}\r\n\r\nunit JvHLParser;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n SysUtils, Classes, Dialogs,\r\n JclWideStrings,\r\n JvJCLUtils;\r\n\r\nconst\r\n ieBadRemark = 1;\r\n\r\ntype\r\n TIParserStyle = (psNone, psPascal, psCpp, psPython, psVB, psHtml, psPerl, psCocoR, psPhp, psSql);\r\n\r\n TJvIParser = class(TObject)\r\n protected\r\n FpcProgram: PChar;\r\n FpcPos: PChar; // Current position [translated]\r\n FHistory: TStringList;\r\n FHistorySize: Integer;\r\n FHistoryPtr: Integer;\r\n FStyle: TIParserStyle;\r\n FReturnComments: Boolean;\r\n function HistoryInd(Index: Integer): Integer;\r\n function GetHistory(Index: Integer): string;\r\n function GetPosBeg(Index: Integer): Integer;\r\n function GetPosEnd(Index: Integer): Integer;\r\n procedure SetHistorySize(Size: Integer);\r\n function GetPos: Integer;\r\n public\r\n constructor Create;\r\n destructor Destroy; override;\r\n { Returns the following token; shifts a current position [translated] }\r\n function Token: string;\r\n { Returns the following token to the left of a current position shifts\r\n a current position to the left [translated]\r\n function TokenL : string; - It is devilishly difficult to make it *;-( [translated] }\r\n { Rollback back on the indicated quantity of tokens [translated] }\r\n procedure RollBack(Index: Integer);\r\n property History[Index: Integer]: string read GetHistory;\r\n property PosBeg[Index: Integer]: Integer read GetPosBeg;\r\n property PosEnd[Index: Integer]: Integer read GetPosEnd;\r\n property HistorySize: Integer read FHistorySize write SetHistorySize;\r\n property Pos: Integer read GetPos;\r\n // (rom) name change needed\r\n property pcPos: PChar read FpcPos write FpcPos;\r\n property pcProgram: PChar read FpcProgram write FpcProgram;\r\n property Style: TIParserStyle read FStyle write FStyle;\r\n property ReturnComments: Boolean read FReturnComments write FReturnComments;\r\n end;\r\n\r\n TJvIParserW = class(TObject)\r\n protected\r\n FpcProgram: PWideChar;\r\n FpcPos: PWideChar; // Current position [translated]\r\n FHistory: TWStrings;\r\n FHistorySize: Integer;\r\n FHistoryPtr: Integer;\r\n FStyle: TIParserStyle;\r\n FReturnComments: Boolean;\r\n function HistoryInd(Index: Integer): Integer;\r\n function GetHistory(Index: Integer): WideString;\r\n function GetPosBeg(Index: Integer): Integer;\r\n function GetPosEnd(Index: Integer): Integer;\r\n procedure SetHistorySize(Size: Integer);\r\n function GetPos: Integer;\r\n public\r\n constructor Create;\r\n destructor Destroy; override;\r\n { Returns the following token; shifts a current position [translated] }\r\n function Token: WideString;\r\n { Returns the following token to the left of a current position shifts\r\n a current position to the left [translated]\r\n function TokenL : string; - It is devilishly difficult to make it *;-( [translated] }\r\n { Rollback back on the indicated quantity of tokens [translated] }\r\n procedure RollBack(Index: Integer);\r\n property History[Index: Integer]: WideString read GetHistory;\r\n property PosBeg[Index: Integer]: Integer read GetPosBeg;\r\n property PosEnd[Index: Integer]: Integer read GetPosEnd;\r\n property HistorySize: Integer read FHistorySize write SetHistorySize;\r\n property Pos: Integer read GetPos;\r\n // (rom) name change needed\r\n property pcPos: PWideChar read FpcPos write FpcPos;\r\n property pcProgram: PWideChar read FpcProgram write FpcProgram;\r\n property Style: TIParserStyle read FStyle write FStyle;\r\n property ReturnComments: Boolean read FReturnComments write FReturnComments;\r\n end;\r\n\r\n EJvIParserError = class(Exception)\r\n private\r\n FErrCode: Integer;\r\n FPosition: Cardinal;\r\n public\r\n constructor Create(AErrCode: Integer; APosition: Cardinal; Dummy: Integer = 0);\r\n property ErrCode: Integer read FErrCode;\r\n property Position: Cardinal read FPosition;\r\n end;\r\n\r\nfunction IsStringConstant(const St: string): Boolean;\r\nfunction IsIntConstant(const St: string): Boolean;\r\nfunction IsRealConstant(const St: string): Boolean;\r\nfunction IsIdentifier(const ID: string): Boolean;\r\nfunction GetStringValue(const St: string): string;\r\nprocedure ParseString(const S: string; Ss: TStrings);\r\n\r\nfunction IsStringConstantW(const St: WideString): Boolean;\r\nfunction IsIntConstantW(const St: WideString): Boolean;\r\nfunction IsRealConstantW(const St: WideString): Boolean;\r\nfunction IsIdentifierW(const ID: WideString): Boolean;\r\nfunction GetStringValueW(const St: WideString): WideString;\r\nprocedure ParseStringW(const S: WideString; Ss: TWStrings);\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvHLParser.pas $';\r\n Revision: '$Revision: 13138 $';\r\n Date: '$Date: 2011-10-27 01:17:50 +0200 (jeu. 27 oct. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n JvConsts;\r\n\r\n//=== { EJvIParserError } ====================================================\r\n\r\nconstructor EJvIParserError.Create(AErrCode: Integer; APosition: Cardinal; Dummy: Integer = 0);\r\nbegin\r\n inherited Create('');\r\n FErrCode := AErrCode;\r\n FPosition := APosition;\r\nend;\r\n\r\n//=== { TJvIParser } =========================================================\r\n\r\nconstructor TJvIParser.Create;\r\nbegin\r\n inherited Create;\r\n FHistory := TStringList.Create;\r\n HistorySize := 10;\r\n Style := psPascal;\r\nend;\r\n\r\ndestructor TJvIParser.Destroy;\r\nbegin\r\n FHistory.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJvIParser.Token: string;\r\nconst\r\n StSkip = [' ', Lf, Cr];\r\nvar\r\n P, F: PChar;\r\n F1: PChar;\r\n I: Integer;\r\n\r\n function SkipComments: Boolean;\r\n begin\r\n SkipComments := True;\r\n case P[0] of\r\n '{':\r\n if FStyle = psPascal then\r\n begin\r\n F := StrScan(P + 1, '}');\r\n if F = nil then //IParserError(ieBadRemark, P - FpcProgram);\r\n Exit;\r\n P := F + 1;\r\n end;\r\n '}':\r\n if FStyle = psPascal then //IParserError(ieBadRemark, P - FpcProgram);\r\n Exit;\r\n '(':\r\n if (FStyle in [psPascal, psCocoR]) and (P[1] = '*') then\r\n begin\r\n if P[2] = #0 then\r\n Exit; // line end\r\n F := P + 2;\r\n while True do\r\n begin\r\n F := StrScan(F, '*');\r\n if F = nil then //IParserError(ieBadRemark, P - FpcProgram);\r\n Exit;\r\n if F[1] = ')' then\r\n begin\r\n Inc(F);\r\n Break;\r\n end;\r\n Inc(F);\r\n end;\r\n P := F + 1;\r\n end;\r\n '*':\r\n if FStyle in [psPascal, psCocoR] then\r\n begin\r\n if (P[1] = ')') then\r\n //IParserError(ieBadRemark, P - FpcProgram)\r\n Exit;\r\n end\r\n else\r\n if FStyle in [psCpp, psPhp] then\r\n if P[1] = '/' then //IParserError(ieBadRemark, P - FpcProgram);\r\n Exit;\r\n '/':\r\n if (FStyle in [psPascal, psCpp, psCocoR, psPhp]) and (P[1] = '/') then\r\n begin\r\n F := StrScan(P + 1, Cr);\r\n if F = nil then\r\n F := StrEnd(P + 1);\r\n P := F;\r\n end\r\n else\r\n if (FStyle in [psCpp, psCocoR, psPhp, psSQL]) and (P[1] = '*') then\r\n begin\r\n if P[2] = #0 then\r\n Exit; // line end\r\n F := P + 2;\r\n while True do\r\n begin\r\n F := StrScan(F, '*');\r\n if F = nil then //IParserError(ieBadRemark, P - FpcProgram);\r\n Exit;\r\n if F[1] = '/' then\r\n begin\r\n Inc(F);\r\n Break;\r\n end;\r\n Inc(F);\r\n end;\r\n P := F + 1;\r\n end;\r\n '#':\r\n if (FStyle in [psPython, psPerl]) { and\r\n ((P = FpcProgram) or (P[-1] in [Lf, Cr])) }then\r\n begin\r\n F := StrScan(P + 1, Cr);\r\n if F = nil then\r\n F := StrEnd(P + 1);\r\n P := F;\r\n end;\r\n '''':\r\n if FStyle = psVB then\r\n begin\r\n F := StrScan(P + 1, Cr);\r\n if F = nil then\r\n F := StrEnd(P + 1);\r\n P := F;\r\n end;\r\n // Support for the SQL -- comments\r\n '-':\r\n if (FStyle = psSql) and (P[1] = '-') then\r\n begin\r\n F := StrScan(P + 1, Cr);\r\n if F = nil then\r\n F := StrEnd(P + 1);\r\n P := F;\r\n end;\r\n // Support for multiline comments for HTML\r\n '<':\r\n if (FStyle = psHtml) and (P[1] = '!') then\r\n begin\r\n // we need the next 2 chars to be --\r\n if (P[2] = #0) or (P[3] = #0) then\r\n Exit; // line end\r\n if (P[2] <> '-') and (P[3] <> '-') then\r\n Exit;\r\n F := P + 3;\r\n while True do\r\n begin\r\n F := StrScan(F, '-');\r\n if F = nil then //IParserError(ieBadRemark, P - FpcProgram);\r\n Exit;\r\n if (F[1] = '-') and (F[2] = '>') then\r\n begin\r\n Inc(F, 2);\r\n Break;\r\n end;\r\n Inc(F);\r\n end;\r\n P := F + 1;\r\n end;\r\n end;\r\n SkipComments := False;\r\n end;\r\n\r\n procedure Return;\r\n begin\r\n FpcPos := P;\r\n FHistory[FHistoryPtr] := Result;\r\n FHistory.Objects[FHistoryPtr] := TObject(Pos - 1);\r\n Inc(FHistoryPtr);\r\n if FHistoryPtr > FHistorySize - 1 then\r\n FHistoryPtr := 0;\r\n end;\r\n\r\nbegin\r\n { New Token - To begin reading a new token [translated] }\r\n F := FpcPos;\r\n P := FpcPos;\r\n { Firstly skip spaces and remarks }\r\n repeat\r\n while CharInSet(P[0], StSkip) do\r\n Inc(P);\r\n F1 := P;\r\n try\r\n if SkipComments then\r\n P := StrEnd(F1);\r\n except\r\n on E: EJvIParserError do\r\n if (E.ErrCode = ieBadRemark) and ReturnComments then\r\n P := StrEnd(F1)\r\n else\r\n raise;\r\n end;\r\n if ReturnComments and (P > F1) then\r\n begin\r\n SetString(Result, F1, P - F1);\r\n Return;\r\n Exit;\r\n end;\r\n while CharInSet(P[0], StSkip) do\r\n Inc(P);\r\n until F1 = P;\r\n\r\n F := P;\r\n if FStyle <> psHtml then\r\n begin\r\n if CharInSet(P[0], IdentifierFirstSymbols) then\r\n { token }\r\n begin\r\n while CharInSet(P[0], IdentifierSymbols) do\r\n Inc(P);\r\n SetString(Result, F, P - F);\r\n end\r\n else\r\n if CharInSet(P[0], DigitSymbols) then\r\n { number }\r\n begin\r\n while CharInSet(P[0], DigitSymbols) or (P[0] = '.') do\r\n Inc(P);\r\n SetString(Result, F, P - F);\r\n end\r\n else\r\n if (Style = psPascal) and (P[0] = '$') and\r\n CharInSet(P[1], HexadecimalSymbols) then\r\n { pascal hex number }\r\n begin\r\n Inc(P);\r\n while CharInSet(P[0], HexadecimalSymbols) do\r\n Inc(P);\r\n SetString(Result, F, P - F);\r\n end\r\n else\r\n if (Style = psPerl) and CharInSet(P[0], ['$', '@', '%', '&']) then\r\n { perl identifier }\r\n begin\r\n Inc(P);\r\n while CharInSet(P[0], IdentifierSymbols) do\r\n Inc(P);\r\n SetString(Result, F, P - F);\r\n end\r\n else\r\n if P[0] = '''' then\r\n { pascal string constant }\r\n begin\r\n Inc(P);\r\n while P[0] <> #0 do\r\n begin\r\n if P[0] = '''' then\r\n if P[1] = '''' then\r\n Inc(P)\r\n else\r\n Break;\r\n Inc(P);\r\n end;\r\n if P[0] <> #0 then\r\n Inc(P);\r\n SetString(Result, F, P - F);\r\n I := 2;\r\n while I < Length(Result) - 1 do\r\n begin\r\n if Result[I] = '''' then\r\n Delete(Result, I, 1);\r\n Inc(I);\r\n end;\r\n end\r\n else\r\n if (FStyle in [psCpp, psCocoR]) and (P[0] = '\"') then\r\n { C++ string constant }\r\n begin\r\n Inc(P);\r\n while P[0] <> #0 do\r\n begin\r\n if (P[0] = '\"') and (P[-1] <> '\\') then\r\n Break;\r\n if (P[0] = '\"') and (P[-1] = '\\') then\r\n begin\r\n // count the backslashes, on even backslahses it is a string end\r\n I := 1;\r\n while (P - 1 - I > F) and (P[-1 - I] = '\\') do\r\n Inc(I);\r\n if I and $01 = 0 then\r\n Break; { same but faster than: if I mod 2 = 0 then Break; }\r\n end;\r\n Inc(P);\r\n end;\r\n if P[0] <> #0 then\r\n Inc(P);\r\n SetString(Result, F, P - F);\r\n end\r\n else\r\n if ((FStyle in [psPython, psVB, psHtml]) and (P[0] = '\"')) or\r\n ((FStyle in [psPerl, psPhp]) and (P[0] = '\"') and ((P = FpcPos) or (P[-1] <> '/'))) then\r\n { Python, VB, Html, Perl string constant }\r\n begin\r\n Inc(P);\r\n while P[0] <> #0 do\r\n begin\r\n if P[0] = '\"' then\r\n Break;\r\n Inc(P);\r\n end;\r\n if P[0] <> #0 then\r\n Inc(P);\r\n SetString(Result, F, P - F);\r\n end\r\n else\r\n if P[0] = #0 then\r\n Result := ''\r\n else\r\n begin\r\n Result := P[0];\r\n Inc(P);\r\n end;\r\n end\r\n else { html }\r\n begin\r\n if CharInSet(P[0], ['=', '<', '>']) or\r\n ((P <> pcProgram) and (P[0] = '/') and (P[-1] = '<')) then\r\n begin\r\n Result := P[0];\r\n Inc(P);\r\n end\r\n else\r\n if P[0] = '\"' then\r\n { Html string constant }\r\n begin\r\n Inc(P);\r\n while P[0] <> #0 do\r\n begin\r\n if P[0] = '\"' then\r\n Break;\r\n Inc(P);\r\n end;\r\n if P[0] <> #0 then\r\n Inc(P);\r\n SetString(Result, F, P - F);\r\n end\r\n else\r\n begin\r\n while not CharInSet(P[0], [#0, ' ', '=', '<', '>']) do\r\n Inc(P);\r\n SetString(Result, F, P - F);\r\n end;\r\n end;\r\n Return;\r\nend;\r\n\r\nfunction TJvIParser.HistoryInd(Index: Integer): Integer;\r\nbegin\r\n Result := FHistoryPtr - 1 - Index;\r\n if Result < 0 then\r\n Result := Result + FHistorySize;\r\nend;\r\n\r\nfunction TJvIParser.GetHistory(Index: Integer): string;\r\nbegin\r\n Result := FHistory[HistoryInd(Index)];\r\nend;\r\n\r\nfunction TJvIParser.GetPosEnd(Index: Integer): Integer;\r\nbegin\r\n Result := Integer(FHistory.Objects[HistoryInd(Index)]) + 1;\r\nend;\r\n\r\nfunction TJvIParser.GetPosBeg(Index: Integer): Integer;\r\nvar\r\n I: Integer;\r\n S: string;\r\nbegin\r\n I := HistoryInd(Index);\r\n S := FHistory[I];\r\n Result := Integer(FHistory.Objects[I]) - Length(S) + 1;\r\n case FStyle of\r\n psPascal:\r\n if S[1] = '''' then\r\n for I := 2 to Length(S) - 1 do\r\n if S[I] = '''' then\r\n Dec(Result);\r\n end;\r\nend;\r\n\r\nprocedure TJvIParser.SetHistorySize(Size: Integer);\r\nbegin\r\n while Size > FHistorySize do\r\n begin\r\n FHistory.Add('');\r\n Inc(FHistorySize);\r\n end;\r\n while Size < FHistorySize do\r\n begin\r\n FHistory.Delete(0);\r\n Dec(FHistorySize);\r\n end;\r\n FHistoryPtr := 0;\r\nend;\r\n\r\nfunction TJvIParser.GetPos: Integer;\r\nbegin\r\n Result := pcPos - FpcProgram;\r\nend;\r\n\r\nprocedure TJvIParser.RollBack(Index: Integer);\r\nbegin\r\n FpcPos := PosEnd[Index] + FpcProgram;\r\n Dec(FHistoryPtr, Index);\r\n if FHistoryPtr < 0 then\r\n FHistoryPtr := FHistorySize + FHistoryPtr;\r\nend;\r\n\r\n//=== { TJvIParserW } ========================================================\r\n\r\nconstructor TJvIParserW.Create;\r\nbegin\r\n inherited Create;\r\n FHistory := TWStringList.Create;\r\n HistorySize := 10;\r\n Style := psPascal;\r\nend;\r\n\r\ndestructor TJvIParserW.Destroy;\r\nbegin\r\n FHistory.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJvIParserW.Token: WideString;\r\nconst\r\n StSkip = [' ', Lf, Cr];\r\nvar\r\n P, F: PWideChar;\r\n F1: PWideChar;\r\n I: Integer;\r\n\r\n function SkipComments: Boolean;\r\n begin\r\n SkipComments := True;\r\n case P[0] of\r\n '{':\r\n if FStyle = psPascal then\r\n begin\r\n F := StrScanW(P + 1, WideChar('}'));\r\n if F = nil then //IParserError(ieBadRemark, P - FpcProgram);\r\n Exit;\r\n P := F + 1;\r\n end;\r\n '}':\r\n if FStyle = psPascal then //IParserError(ieBadRemark, P - FpcProgram);\r\n Exit;\r\n '(':\r\n if (FStyle in [psPascal, psCocoR]) and (P[1] = '*') then\r\n begin\r\n if P[2] = #0 then\r\n Exit; // line end\r\n F := P + 2;\r\n while True do\r\n begin\r\n F := StrScanW(F, WideChar('*'));\r\n if F = nil then //IParserError(ieBadRemark, P - FpcProgram);\r\n Exit;\r\n if F[1] = ')' then\r\n begin\r\n Inc(F);\r\n Break;\r\n end;\r\n Inc(F);\r\n end;\r\n P := F + 1;\r\n end;\r\n '*':\r\n if FStyle in [psPascal, psCocoR] then\r\n begin\r\n if (P[1] = ')') then\r\n //IParserError(ieBadRemark, P - FpcProgram)\r\n Exit;\r\n end\r\n else\r\n if FStyle in [psCpp, psPhp] then\r\n if P[1] = '/' then //IParserError(ieBadRemark, P - FpcProgram);\r\n Exit;\r\n '/':\r\n if (FStyle in [psPascal, psCpp, psCocoR, psPhp]) and (P[1] = '/') then\r\n begin\r\n F := StrScanW(P + 1, WideChar(Cr));\r\n if F = nil then\r\n F := StrEndW(P + 1);\r\n P := F;\r\n end\r\n else\r\n if (FStyle in [psCpp, psCocoR, psPhp, psSQL]) and (P[1] = '*') then\r\n begin\r\n if P[2] = #0 then\r\n Exit; // line end\r\n F := P + 2;\r\n while True do\r\n begin\r\n F := StrScanW(F, WideChar('*'));\r\n if F = nil then //IParserError(ieBadRemark, P - FpcProgram);\r\n Exit;\r\n if F[1] = '/' then\r\n begin\r\n Inc(F);\r\n Break;\r\n end;\r\n Inc(F);\r\n end;\r\n P := F + 1;\r\n end;\r\n '#':\r\n if (FStyle in [psPython, psPerl]) { and\r\n ((P = FpcProgram) or (P[-1] in [Lf, Cr])) }then\r\n begin\r\n F := StrScanW(P + 1, WideChar(Cr));\r\n if F = nil then\r\n F := StrEndW(P + 1);\r\n P := F;\r\n end;\r\n '''':\r\n if FStyle = psVB then\r\n begin\r\n F := StrScanW(P + 1, WideChar(Cr));\r\n if F = nil then\r\n F := StrEndW(P + 1);\r\n P := F;\r\n end;\r\n // Support for the SQL -- comments\r\n '-':\r\n if (FStyle = psSql) and (P[1] = '-') then\r\n begin\r\n F := StrScanW(P + 1, WideChar(Cr));\r\n if F = nil then\r\n F := StrEndW(P + 1);\r\n P := F;\r\n end;\r\n // Support for multiline comments for HTML\r\n '<':\r\n if (FStyle = psHtml) and (P[1] = '!') then\r\n begin\r\n // we need the next 2 chars to be --\r\n if (P[2] = #0) or (P[3] = #0) then\r\n Exit; // line end\r\n if (P[2] <> '-') and (P[3] <> '-') then\r\n Exit;\r\n F := P + 3;\r\n while True do\r\n begin\r\n F := StrScanW(F, WideChar('-'));\r\n if F = nil then //IParserError(ieBadRemark, P - FpcProgram);\r\n Exit;\r\n if (F[1] = '-') and (F[2] = '>') then\r\n begin\r\n Inc(F, 2);\r\n Break;\r\n end;\r\n Inc(F);\r\n end;\r\n P := F + 1;\r\n end;\r\n end;\r\n SkipComments := False;\r\n end;\r\n\r\n procedure Return;\r\n begin\r\n FpcPos := P;\r\n {$IFDEF SUPPORTS_UNICODE}\r\n FHistory.Strings[FHistoryPtr] := Result;\r\n {$ELSE}\r\n FHistory.PStrings[FHistoryPtr]^ := Result;\r\n {$ENDIF SUPPORTS_UNICODE}\r\n FHistory.Objects[FHistoryPtr] := TObject(Pos - 1);\r\n Inc(FHistoryPtr);\r\n if FHistoryPtr > FHistorySize - 1 then\r\n FHistoryPtr := 0;\r\n end;\r\n\r\nbegin\r\n { New Token - To begin reading a new token [translated] }\r\n F := FpcPos;\r\n P := FpcPos;\r\n { Firstly skip spaces and remarks }\r\n repeat\r\n while CharInSetW(P[0], StSkip) do\r\n Inc(P);\r\n F1 := P;\r\n try\r\n if SkipComments then\r\n P := StrEndW(F1);\r\n except\r\n on E: EJvIParserError do\r\n if (E.ErrCode = ieBadRemark) and ReturnComments then\r\n P := StrEndW(F1)\r\n else\r\n raise;\r\n end;\r\n if ReturnComments and (P > F1) then\r\n begin\r\n SetString(Result, F1, P - F1);\r\n Return;\r\n Exit;\r\n end;\r\n while CharInSetW(P[0], StSkip) do\r\n Inc(P);\r\n until F1 = P;\r\n\r\n F := P;\r\n if FStyle <> psHtml then\r\n begin\r\n if CharInSetW(P[0], IdentifierFirstSymbols) then\r\n { token }\r\n begin\r\n while CharInSetW(P[0], IdentifierSymbols) do\r\n Inc(P);\r\n SetString(Result, F, P - F);\r\n end\r\n else\r\n if CharInSetW(P[0], DigitSymbols) then\r\n { number }\r\n begin\r\n while CharInSetW(P[0], DigitSymbols) or (P[0] = '.') do\r\n Inc(P);\r\n SetString(Result, F, P - F);\r\n end\r\n else\r\n if (Style = psPascal) and (P[0] = '$') and\r\n CharInSetW(P[1], HexadecimalSymbols) then\r\n { pascal hex number }\r\n begin\r\n Inc(P);\r\n while CharInSetW(P[0], HexadecimalSymbols) do\r\n Inc(P);\r\n SetString(Result, F, P - F);\r\n end\r\n else\r\n if (Style = psPerl) and CharInSetW(P[0], ['$', '@', '%', '&']) then\r\n { perl identifier }\r\n begin\r\n Inc(P);\r\n while CharInSetW(P[0], IdentifierSymbols) do\r\n Inc(P);\r\n SetString(Result, F, P - F);\r\n end\r\n else\r\n if P[0] = '''' then\r\n { pascal string constant }\r\n begin\r\n Inc(P);\r\n while P[0] <> #0 do\r\n begin\r\n if P[0] = '''' then\r\n if P[1] = '''' then\r\n Inc(P)\r\n else\r\n Break;\r\n Inc(P);\r\n end;\r\n if P[0] <> #0 then\r\n Inc(P);\r\n SetString(Result, F, P - F);\r\n I := 2;\r\n while I < Length(Result) - 1 do\r\n begin\r\n if Result[I] = '''' then\r\n Delete(Result, I, 1);\r\n Inc(I);\r\n end;\r\n end\r\n else\r\n if (FStyle in [psCpp, psCocoR]) and (P[0] = '\"') then\r\n { C++ string constant }\r\n begin\r\n Inc(P);\r\n while P[0] <> #0 do\r\n begin\r\n if (P[0] = '\"') and (P[-1] <> '\\') then\r\n Break;\r\n if (P[0] = '\"') and (P[-1] = '\\') then\r\n begin\r\n // count the backslashes, on even backslahses it is a string end\r\n I := 1;\r\n while (P - 1 - I > F) and (P[-1 - I] = '\\') do\r\n Inc(I);\r\n if I and $01 = 0 then\r\n Break; { same but faster than: if I mod 2 = 0 then Break; }\r\n end;\r\n Inc(P);\r\n end;\r\n if P[0] <> #0 then\r\n Inc(P);\r\n SetString(Result, F, P - F);\r\n end\r\n else\r\n if ((FStyle in [psPython, psVB, psHtml]) and (P[0] = '\"')) or\r\n ((FStyle in [psPerl, psPhp]) and (P[0] = '\"') and ((P = FpcPos) or (P[-1] <> '/'))) then\r\n { Python, VB, Html, Perl string constant }\r\n begin\r\n Inc(P);\r\n while P[0] <> #0 do\r\n begin\r\n if P[0] = '\"' then\r\n Break;\r\n Inc(P);\r\n end;\r\n if P[0] <> #0 then\r\n Inc(P);\r\n SetString(Result, F, P - F);\r\n end\r\n else\r\n if P[0] = #0 then\r\n Result := ''\r\n else\r\n begin\r\n Result := P[0];\r\n Inc(P);\r\n end;\r\n end\r\n else { html }\r\n begin\r\n if CharInSetW(P[0], ['=', '<', '>']) or\r\n ((P <> pcProgram) and (P[0] = '/') and (P[-1] = '<')) then\r\n begin\r\n Result := P[0];\r\n Inc(P);\r\n end\r\n else\r\n if P[0] = '\"' then\r\n { Html string constant }\r\n begin\r\n Inc(P);\r\n while P[0] <> #0 do\r\n begin\r\n if P[0] = '\"' then\r\n Break;\r\n Inc(P);\r\n end;\r\n if P[0] <> #0 then\r\n Inc(P);\r\n SetString(Result, F, P - F);\r\n end\r\n else\r\n begin\r\n while not CharInSetW(P[0], [#0, ' ', '=', '<', '>']) do\r\n Inc(P);\r\n SetString(Result, F, P - F);\r\n end;\r\n end;\r\n Return;\r\nend;\r\n\r\nfunction TJvIParserW.HistoryInd(Index: Integer): Integer;\r\nbegin\r\n Result := FHistoryPtr - 1 - Index;\r\n if Result < 0 then\r\n Result := Result + FHistorySize;\r\nend;\r\n\r\nfunction TJvIParserW.GetHistory(Index: Integer): WideString;\r\nbegin\r\n Result := FHistory[HistoryInd(Index)];\r\nend;\r\n\r\nfunction TJvIParserW.GetPosEnd(Index: Integer): Integer;\r\nbegin\r\n Result := Integer(FHistory.Objects[HistoryInd(Index)]) + 1;\r\nend;\r\n\r\nfunction TJvIParserW.GetPosBeg(Index: Integer): Integer;\r\nvar\r\n I: Integer;\r\n S: WideString;\r\nbegin\r\n I := HistoryInd(Index);\r\n S := FHistory[I];\r\n Result := Integer(FHistory.Objects[I]) - Length(S) + 1;\r\n case FStyle of\r\n psPascal:\r\n if S[1] = '''' then\r\n for I := 2 to Length(S) - 1 do\r\n if S[I] = '''' then\r\n Dec(Result);\r\n end;\r\nend;\r\n\r\nprocedure TJvIParserW.SetHistorySize(Size: Integer);\r\nbegin\r\n while Size > FHistorySize do\r\n begin\r\n FHistory.Add('');\r\n Inc(FHistorySize);\r\n end;\r\n while Size < FHistorySize do\r\n begin\r\n FHistory.Delete(0);\r\n Dec(FHistorySize);\r\n end;\r\n FHistoryPtr := 0;\r\nend;\r\n\r\nfunction TJvIParserW.GetPos: Integer;\r\nbegin\r\n Result := pcPos - FpcProgram;\r\nend;\r\n\r\nprocedure TJvIParserW.RollBack(Index: Integer);\r\nbegin\r\n FpcPos := PosEnd[Index] + FpcProgram;\r\n Dec(FHistoryPtr, Index);\r\n if FHistoryPtr < 0 then\r\n FHistoryPtr := FHistorySize + FHistoryPtr;\r\nend;\r\n\r\n//============================================================================\r\n\r\nprocedure ParseString(const S: string; Ss: TStrings);\r\nvar\r\n Parser: TJvIParser;\r\n Token: string;\r\nbegin\r\n Ss.BeginUpdate;\r\n Ss.Clear;\r\n Parser := TJvIParser.Create;\r\n try\r\n Parser.pcProgram := PChar(S);\r\n Parser.pcPos := Parser.pcProgram;\r\n Token := Parser.Token;\r\n while Token <> '' do\r\n begin\r\n Ss.Add(Token);\r\n Token := Parser.Token;\r\n end;\r\n finally\r\n Parser.Free;\r\n Ss.EndUpdate;\r\n end;\r\nend;\r\n\r\nprocedure ParseStringW(const S: WideString; Ss: TWStrings);\r\nvar\r\n Parser: TJvIParserW;\r\n Token: WideString;\r\nbegin\r\n Ss.BeginUpdate;\r\n Ss.Clear;\r\n Parser := TJvIParserW.Create;\r\n try\r\n Parser.pcProgram := PWideChar(S);\r\n Parser.pcPos := Parser.pcProgram;\r\n Token := Parser.Token;\r\n while Token <> '' do\r\n begin\r\n Ss.Add(Token);\r\n Token := Parser.Token;\r\n end;\r\n finally\r\n Parser.Free;\r\n Ss.EndUpdate;\r\n end;\r\nend;\r\n\r\nfunction IsStringConstant(const St: string): Boolean;\r\nvar\r\n LS: Integer;\r\nbegin\r\n LS := Length(St);\r\n Result := (LS >= 2) and (((St[1] = '''') and (St[LS] = '''')) or\r\n ((St[1] = '\"') and (St[LS] = '\"')));\r\nend;\r\n\r\nfunction IsStringConstantW(const St: WideString): Boolean;\r\nvar\r\n LS: Integer;\r\nbegin\r\n LS := Length(St);\r\n Result := (LS >= 2) and (((St[1] = '''') and (St[LS] = '''')) or\r\n ((St[1] = '\"') and (St[LS] = '\"')));\r\nend;\r\n\r\nfunction IsRealConstant(const St: string): Boolean;\r\nvar\r\n I, J: Integer;\r\n Point: Boolean;\r\nbegin\r\n Result := False;\r\n if (St = '.') or (St = '') then\r\n Exit;\r\n if St[1] = '-' then\r\n if Length(St) = 1 then\r\n Exit\r\n else\r\n J := 2\r\n else\r\n J := 1;\r\n Point := False;\r\n for I := J to Length(St) do\r\n if St[I] = '.' then\r\n if Point then\r\n Exit\r\n else\r\n Point := True\r\n else\r\n if not CharInSet(St[I], DigitSymbols) then\r\n Exit;\r\n Result := True;\r\nend;\r\n\r\nfunction IsRealConstantW(const St: WideString): Boolean;\r\nvar\r\n I, J: Integer;\r\n Point: Boolean;\r\nbegin\r\n Result := False;\r\n if (St = '.') or (St = '') then\r\n Exit;\r\n if St[1] = '-' then\r\n if Length(St) = 1 then\r\n Exit\r\n else\r\n J := 2\r\n else\r\n J := 1;\r\n Point := False;\r\n for I := J to Length(St) do\r\n if St[I] = '.' then\r\n if Point then\r\n Exit\r\n else\r\n Point := True\r\n else\r\n if (St[I] < WideChar('0')) or (St[I] > WideChar('9')) then\r\n Exit;\r\n Result := True;\r\nend;\r\n\r\nfunction IsIntConstant(const St: string): Boolean;\r\nvar\r\n I, J: Integer;\r\n Sym: TSysCharSet;\r\nbegin\r\n Result := False;\r\n if (Length(St) = 0) or ((Length(St) = 1) and (St[1] = '$')) then\r\n Exit;\r\n Sym := DigitSymbols;\r\n if (St[1] = '-') or (St[1] = '$') then\r\n begin\r\n if Length(St) = 1 then\r\n Exit\r\n else\r\n J := 2;\r\n if St[1] = '$' then\r\n Sym := HexadecimalSymbols;\r\n end\r\n else\r\n J := 1;\r\n for I := J to Length(St) do\r\n if not CharInSet(St[I], Sym) then\r\n Exit;\r\n Result := True;\r\nend;\r\n\r\nfunction IsIntConstantW(const St: WideString): Boolean;\r\nvar\r\n I, J: Integer;\r\n Sym: TSysCharSet;\r\nbegin\r\n Result := False;\r\n if (Length(St) = 0) or ((Length(St) = 1) and (St[1] = '$')) then\r\n Exit;\r\n Sym := DigitSymbols;\r\n if (St[1] = '-') or (St[1] = '$') then\r\n begin\r\n if Length(St) = 1 then\r\n Exit\r\n else\r\n J := 2;\r\n if St[1] = '$' then\r\n Sym := HexadecimalSymbols;\r\n end\r\n else\r\n J := 1;\r\n for I := J to Length(St) do\r\n if not CharInSetW(St[I], Sym) then\r\n Exit;\r\n Result := True;\r\nend;\r\n\r\nfunction IsIdentifier(const ID: string): Boolean;\r\nvar\r\n I, L: Integer;\r\nbegin\r\n Result := False;\r\n L := Length(ID);\r\n if L = 0 then\r\n Exit;\r\n if not CharInSet(ID[1], IdentifierFirstSymbols) then\r\n Exit;\r\n for I := 1 to L do\r\n begin\r\n if not CharInSet(ID[1], IdentifierSymbols) then\r\n Exit;\r\n end;\r\n Result := True;\r\nend;\r\n\r\nfunction IsIdentifierW(const ID: WideString): Boolean;\r\nvar\r\n I, L: Integer;\r\nbegin\r\n Result := False;\r\n L := Length(ID);\r\n if L = 0 then\r\n Exit;\r\n if not CharInSetW(ID[1], IdentifierFirstSymbols) then\r\n Exit;\r\n for I := 1 to L do\r\n begin\r\n if not CharInSetW(ID[1], IdentifierSymbols) then\r\n Exit;\r\n end;\r\n Result := True;\r\nend;\r\n\r\nfunction GetStringValue(const St: string): string;\r\nbegin\r\n if IsStringConstant(St) then\r\n Result := Copy(St, 2, Length(St) - 2)\r\n else\r\n Result := St;\r\nend;\r\n\r\nfunction GetStringValueW(const St: WideString): WideString;\r\nbegin\r\n if IsStringConstant(St) then\r\n Result := Copy(St, 2, Length(St) - 2)\r\n else\r\n Result := St;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvHeaderControl.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvHeaderControl.PAS, released on 2001-02-28.\r\n\r\nThe Initial Developer of the Original Code is Sbastien Buysse [sbuysse att buypin dott com]\r\nPortions created by Sbastien Buysse are Copyright (C) 2001 Sbastien Buysse.\r\nAll Rights Reserved.\r\n\r\nContributor(s): Michael Beck [mbeck att bigfoot dott com].\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvHeaderControl.pas 13104 2011-09-07 06:50:43Z obones $\r\n\r\nunit JvHeaderControl;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n Classes,\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n JvExComCtrls;\r\n\r\ntype\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvHeaderControl = class(TJvExHeaderControl)\r\n published\r\n property HintColor;\r\n property OnMouseEnter;\r\n property OnMouseLeave;\r\n property OnParentColorChange;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvHeaderControl.pas $';\r\n Revision: '$Revision: 13104 $';\r\n Date: '$Date: 2011-09-07 08:50:43 +0200 (mer. 07 sept. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvHidControllerClass.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvHidControllerClass.PAS, released on 2001-02-28.\r\n\r\nThe Initial Developer of the Original Code is Robert Marquardt [robert_marquardt att gmx dott de]\r\nPortions created by Robert Marquardt are Copyright (C) 1999-2003 Robert Marquardt.\r\nAll Rights Reserved.\r\n\r\nContributor(s): Michael Beck [mbeck att bigfoot dott com].\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvHidControllerClass.pas 13347 2012-06-13 13:57:11Z obones $\r\n\r\nunit JvHidControllerClass;\r\n\r\n{$DEFINE DEFAULT_JVCL_INC}\r\n\r\n{$I jvcl.inc}\r\n{$I windowsonly.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, Messages, Classes, SysUtils,\r\n JvComponentBase,\r\n DBT, JvSetupApi, Hid, JvTypes;\r\n\r\nconst\r\n // a version string for the component\r\n cHidControllerClassVersion = '1.0.35';\r\n\r\n // strings from the registry for CheckOutByClass\r\n cHidNoClass = 'HIDClass';\r\n\r\ntype\r\n // forward declarations\r\n TJvHidDeviceController = class;\r\n TJvHidDevice = class;\r\n\r\n // the Event function declarations\r\n TJvHidEnumerateEvent = function(HidDev: TJvHidDevice;\r\n const Idx: Integer): Boolean of object;\r\n TJvHidPlugEvent = procedure(HidDev: TJvHidDevice) of object;\r\n TJvHidUnplugEvent = TJvHidPlugEvent;\r\n TJvHidDataEvent = procedure(HidDev: TJvHidDevice; ReportID: Byte;\r\n const Data: Pointer; Size: Word) of object;\r\n TJvHidDataErrorEvent = procedure(HidDev: TJvHidDevice; Error: DWORD) of object;\r\n\r\n // check out test function\r\n TJvHidCheckCallback = function(HidDev: TJvHidDevice): Boolean; stdcall;\r\n\r\n // open overlapped read or write file handle\r\n TJvHidOpenExMode = (omhRead, omhWrite);\r\n\r\n // the physical descriptor\r\n TJvPhysicalDescriptor = array of WORD;\r\n\r\n // all USB relevant driver entries in the registry\r\n TJvHidPnPInfo = class(TObject)\r\n private\r\n FDeviceID: DWORD;\r\n FDevicePath: string;\r\n FCapabilities: DWORD;\r\n FClassDescr: string;\r\n FClassGUID: string;\r\n FCompatibleIDs: TStringList;\r\n FConfigFlags: DWORD;\r\n FDeviceDescr: string;\r\n FDriver: string;\r\n FFriendlyName: string;\r\n FHardwareID: TStringList;\r\n FLowerFilters: TStringList;\r\n FMfg: string;\r\n FUpperFilters: TStringList;\r\n FAddress: string;\r\n FBusNumber: DWORD;\r\n FBusType: string;\r\n FCharacteristics: string;\r\n FDevType: DWORD;\r\n FEnumeratorName: string;\r\n FExclusive: DWORD;\r\n FLegacyBusType: DWORD;\r\n FLocationInfo: string;\r\n FPhysDevObjName: string;\r\n FSecuritySDS: string;\r\n FService: string;\r\n FUINumber: DWORD;\r\n FUINumberFormat: string;\r\n function GetRegistryPropertyString(PnPHandle: HDEVINFO;\r\n const DevData: TSPDevInfoData; Prop: DWORD): string;\r\n function GetRegistryPropertyStringList(PnPHandle: HDEVINFO;\r\n const DevData: TSPDevInfoData; Prop: DWORD): TStringList;\r\n function GetRegistryPropertyDWord(PnPHandle: HDEVINFO;\r\n const DevData: TSPDevInfoData; Prop: DWORD): DWORD;\r\n function GetCompatibleIDs: TStrings;\r\n function GetHardwareID: TStrings;\r\n function GetLowerFilters: TStrings;\r\n function GetUpperFilters: TStrings;\r\n public\r\n property DeviceID: DWORD read FDeviceID;\r\n property DevicePath: string read FDevicePath;\r\n // registry values\r\n property Capabilities: DWORD read FCapabilities;\r\n property ClassDescr: string read FClassDescr;\r\n property ClassGUID: string read FClassGUID;\r\n property CompatibleIDs: TStrings read GetCompatibleIDs;\r\n property ConfigFlags: DWORD read FConfigFlags;\r\n property DeviceDescr: string read FDeviceDescr;\r\n property Driver: string read FDriver;\r\n property FriendlyName: string read FFriendlyName;\r\n property HardwareID: TStrings read GetHardwareID;\r\n property LowerFilters: TStrings read GetLowerFilters;\r\n property Mfg: string read FMfg;\r\n property UpperFilters: TStrings read GetUpperFilters;\r\n property Address: string read FAddress;\r\n property BusNumber: DWORD read FBusNumber;\r\n property BusType: string read FBusType;\r\n property Characteristics: string read FCharacteristics;\r\n property DevType: DWORD read FDevType;\r\n property EnumeratorName: string read FEnumeratorName;\r\n property Exclusive: DWORD read FExclusive;\r\n property LegacyBusType: DWORD read FLegacyBusType;\r\n property LocationInfo: string read FLocationInfo;\r\n property PhysDevObjName: string read FPhysDevObjName;\r\n property SecuritySDS: string read FSecuritySDS;\r\n property Service: string read FService;\r\n property UINumber: DWORD read FUINumber;\r\n property UINumberFormat: string read FUINumberFormat;\r\n constructor Create(APnPHandle: HDEVINFO; ADevData: TSPDevInfoData; ADevicePath: PChar);\r\n destructor Destroy; override;\r\n end;\r\n\r\n // a thread helper class to implement TJvHidDevice.OnData\r\n\r\n TJvHidDeviceReadThread = class(TJvCustomThread)\r\n private\r\n FErr: DWORD;\r\n procedure DoData;\r\n procedure DoDataError;\r\n constructor CtlCreate(const Dev: TJvHidDevice);\r\n protected\r\n procedure Execute; override;\r\n public\r\n Device: TJvHidDevice;\r\n NumBytesRead: Cardinal;\r\n Report: array of Byte;\r\n constructor Create(CreateSuspended: Boolean);\r\n end;\r\n\r\n // the representation of a HID device\r\n\r\n TJvHidDevice = class(TObject)\r\n private\r\n // internal control variables\r\n FMyController: TJvHidDeviceController;\r\n FIsPluggedIn: Boolean;\r\n FIsCheckedOut: Boolean;\r\n FIsEnumerated: Boolean;\r\n FHidFileHandle: THandle;\r\n FHidOverlappedRead: THandle;\r\n FHidOverlappedWrite: THandle;\r\n FOvlRead: TOverlapped;\r\n FOvlWrite: TOverlapped;\r\n // internal properties part\r\n FAttributes: THIDDAttributes;\r\n FPnPInfo: TJvHidPnPInfo;\r\n FVendorName: WideString;\r\n FProductName: WideString;\r\n FPhysicalDescriptor: TJvPhysicalDescriptor;\r\n FPreparsedData: PHIDPPreparsedData;\r\n FSerialNumber: WideString;\r\n FLanguageStrings: TStringList;\r\n FNumInputBuffers: Integer;\r\n FNumOverlappedBuffers: Integer;\r\n FThreadSleepTime: Integer;\r\n FLinkCollection: array of THIDPLinkCollectionNode;\r\n FMaxDataListLength: ULONG;\r\n FMaxUsageListLength: ULONG;\r\n FMaxButtonListLength: ULONG;\r\n FReportTypeParam: THIDPReportType;\r\n FUsagePageParam: TUsage;\r\n FLinkCollectionParam: WORD;\r\n FUsageParam: TUsage;\r\n FData: TJvHidDataEvent;\r\n FDataError: TJvHidDataErrorEvent;\r\n FUnplug: TJvHidUnplugEvent;\r\n FHasReadWriteAccess: Boolean;\r\n FDataThread: TJvHidDeviceReadThread;\r\n FTag: Integer;\r\n // tells if access to device is allowed\r\n function IsAccessible: Boolean;\r\n procedure GetMax;\r\n // internal property implementors\r\n function GetDeviceStringAnsi(Idx: Byte): string;\r\n function GetDeviceStringUnicode(Idx: Byte): WideString;\r\n function GetLinkCollectionNode(Idx: WORD): THIDPLinkCollectionNode;\r\n function GetConfiguration: THIDDConfiguration;\r\n function GetPreparsedData: PHIDPPreparsedData;\r\n function GetCaps: THIDPCaps;\r\n function GetVendorName: WideString;\r\n function GetProductName: WideString;\r\n function GetSerialNumber: WideString;\r\n function GetPhysicalDescriptor: TJvPhysicalDescriptor;\r\n function GetLanguageStrings: TStrings;\r\n function GetOverlappedReadResult: DWORD;\r\n function GetOverlappedWriteResult: DWORD;\r\n procedure SetConfiguration(const Config: THIDDConfiguration);\r\n procedure SetDataEvent(const DataEvent: TJvHidDataEvent);\r\n procedure SetNumInputBuffers(const Num: Integer);\r\n procedure SetNumOverlappedBuffers(const Num: Integer);\r\n procedure SetReportTypeParam(const ReportType: THIDPReportType);\r\n procedure SetThreadSleepTime(const SleepTime: Integer);\r\n procedure SetUsagePageParam(const UsagePage: TUsage);\r\n procedure StartThread;\r\n procedure StopThread;\r\n // Constructor is hidden! Only a TJvHidDeviceController can create a TJvHidDevice object.\r\n // APnPInfo becomes the property of this class, do not try to free it yourself,\r\n // even if this call raises an exception.\r\n // The destructor of this class will take care of the cleanup even when an exception\r\n // is raised (as specified by the Delphi language)\r\n constructor CtlCreate(const APnPInfo: TJvHidPnPInfo;\r\n const Controller: TJvHidDeviceController);\r\n protected\r\n // internal event implementor\r\n procedure DoUnplug;\r\n public\r\n // dummy constructor\r\n constructor Create;\r\n destructor Destroy; override;\r\n // methods\r\n function CancelIO(const Mode: TJvHidOpenExMode): Boolean;\r\n procedure CloseFile;\r\n procedure CloseFileEx(const Mode: TJvHidOpenExMode);\r\n function DeviceIoControl(IoControlCode: DWORD; InBuffer: Pointer; InSize: DWORD;\r\n OutBuffer: Pointer; OutSize: DWORD;\r\n var BytesReturned: DWORD): Boolean;\r\n function FlushQueue: Boolean;\r\n function GetButtonCaps(ButtonCaps: PHIDPButtonCaps; var Count: WORD): NTSTATUS;\r\n function GetButtons(UsageList: PUsage; var UsageLength: ULONG;\r\n var Report; ReportLength: ULONG): NTSTATUS;\r\n function GetButtonsEx(UsageList: PUsageAndPage; var UsageLength: ULONG;\r\n var Report; ReportLength: ULONG): NTSTATUS;\r\n function GetData(DataList: PHIDPData; var DataLength: ULONG;\r\n var Report; ReportLength: ULONG): NTSTATUS;\r\n function GetFeature(var Report; const Size: Integer): Boolean;\r\n function GetScaledUsageValue(var UsageValue: Integer;\r\n var Report; ReportLength: ULONG): NTSTATUS;\r\n function GetSpecificButtonCaps(ButtonCaps: PHIDPButtonCaps; var Count: WORD): NTSTATUS;\r\n function GetSpecificValueCaps(ValueCaps: PHIDPValueCaps; var Count: WORD): NTSTATUS;\r\n function GetUsages(UsageList: PUsage; var UsageLength: ULONG;\r\n var Report; ReportLength: ULONG): NTSTATUS;\r\n function GetUsagesEx(UsageList: PUsageAndPage; var UsageLength: ULONG;\r\n var Report; ReportLength: ULONG): NTSTATUS;\r\n function GetUsageValue(var UsageValue: ULONG;\r\n var Report; ReportLength: ULONG): NTSTATUS;\r\n function GetUsageValueArray(UsageValue: PAnsiChar; UsageValueByteLength: WORD;\r\n var Report; ReportLength: ULONG): NTSTATUS;\r\n function GetValueCaps(ValueCaps: PHIDPValueCaps; var Count: WORD): NTSTATUS;\r\n function OpenFile: Boolean;\r\n function OpenFileEx(Mode: TJvHidOpenExMode): Boolean;\r\n function SetButtons(UsageList: PUsage; var UsageLength: ULONG;\r\n var Report; ReportLength: ULONG): NTSTATUS;\r\n function SetData(DataList: PHIDPData; var DataLength: ULONG;\r\n var Report; ReportLength: ULONG): NTSTATUS;\r\n function SetFeature(var Report; const Size: Integer): Boolean;\r\n function SetScaledUsageValue(UsageValue: Integer;\r\n var Report; ReportLength: ULONG): NTSTATUS;\r\n function SetUsages(UsageList: PUsage; var UsageLength: ULONG;\r\n var Report; ReportLength: ULONG): NTSTATUS;\r\n function SetUsageValue(UsageValue: ULONG;\r\n var Report; ReportLength: ULONG): NTSTATUS;\r\n function SetUsageValueArray(UsageValue: PAnsiChar; UsageValueByteLength: WORD;\r\n var Report; ReportLength: ULONG): NTSTATUS;\r\n function UnsetButtons(UsageList: PUsage; var UsageLength: ULONG;\r\n var Report; ReportLength: ULONG): NTSTATUS;\r\n function UnsetUsages(UsageList: PUsage; var UsageLength: ULONG;\r\n var Report; ReportLength: ULONG): NTSTATUS;\r\n function ReadFile(var Report; ToRead: DWORD; var BytesRead: DWORD): Boolean;\r\n function ReadFileEx(var Report; ToRead: DWORD;\r\n CallBack: TPROverlappedCompletionRoutine): Boolean;\r\n function WriteFile(var Report; ToWrite: DWORD; var BytesWritten: DWORD): Boolean;\r\n function WriteFileEx(var Report; ToWrite: DWORD;\r\n CallBack: TPROverlappedCompletionRoutine): Boolean;\r\n function CheckOut: Boolean;\r\n // Windows version dependent methods\r\n // added in Win 2000\r\n function GetExtendedAttributes(ReportType: THIDPReportType; DataIndex: Word;\r\n Attributes: PHIDPExtendedAttributes; var LengthAttributes: ULONG): NTSTATUS;\r\n function InitializeReportForID(ReportType: THIDPReportType; ReportID: Byte;\r\n var Report; ReportLength: ULONG): NTSTATUS;\r\n // added in Win XP\r\n function GetInputReport(var Report; const Size: ULONG): Boolean;\r\n function SetOutputReport(var Report; const Size: ULONG): Boolean;\r\n // read only properties\r\n property Attributes: THIDDAttributes read FAttributes;\r\n property Caps: THIDPCaps read GetCaps;\r\n property HasReadWriteAccess: Boolean read FHasReadWriteAccess;\r\n property HidFileHandle: THandle read FHidFileHandle;\r\n property HidOverlappedRead: THandle read FHidOverlappedRead;\r\n property HidOverlappedWrite: THandle read FHidOverlappedWrite;\r\n property HidOverlappedReadResult: DWORD read GetOverlappedReadResult;\r\n property HidOverlappedWriteResult: DWORD read GetOverlappedWriteResult;\r\n property IsCheckedOut: Boolean read FIsCheckedOut;\r\n property IsPluggedIn: Boolean read FIsPluggedIn;\r\n property LanguageStrings: TStrings read GetLanguageStrings;\r\n property MaxButtonListLength: ULONG read FMaxButtonListLength;\r\n property MaxDataListLength: ULONG read FMaxDataListLength;\r\n property MaxUsageListLength: ULONG read FMaxUsageListLength;\r\n property PhysicalDescriptor: TJvPhysicalDescriptor read GetPhysicalDescriptor;\r\n property PnPInfo: TJvHidPnPInfo read FPnPInfo;\r\n property PreparsedData: PHIDPPreparsedData read GetPreparsedData;\r\n property ProductName: WideString read GetProductName;\r\n property SerialNumber: WideString read GetSerialNumber;\r\n property VendorName: WideString read GetVendorName;\r\n // read write properties\r\n property Configuration: THIDDConfiguration read GetConfiguration write SetConfiguration;\r\n property LinkCollectionParam: WORD read FLinkCollectionParam write FLinkCollectionParam;\r\n property NumInputBuffers: Integer read FNumInputBuffers write SetNumInputBuffers;\r\n property NumOverlappedBuffers: Integer read FNumOverlappedBuffers write SetNumOverlappedBuffers;\r\n property ReportTypeParam: THIDPReportType read FReportTypeParam write SetReportTypeParam;\r\n property Tag: Integer read FTag write FTag;\r\n property ThreadSleepTime: Integer read FThreadSleepTime write SetThreadSleepTime;\r\n property UsagePageParam: TUsage read FUsagePageParam write SetUsagePageParam;\r\n property UsageParam: TUsage read FUsageParam write FUsageParam;\r\n // indexed properties\r\n property DeviceStrings[Idx: Byte]: string read GetDeviceStringAnsi;\r\n property DeviceStringsUnicode[Idx: Byte]: WideString read GetDeviceStringUnicode;\r\n property LinkCollectionNodes[Idx: WORD]: THIDPLinkCollectionNode read GetLinkCollectionNode;\r\n // event properties\r\n property OnData: TJvHidDataEvent read FData write SetDataEvent;\r\n property OnDataError: TJvHidDataErrorEvent read FDataError write FDataError;\r\n property OnUnplug: TJvHidUnplugEvent read FUnplug write FUnplug;\r\n end;\r\n\r\n // controller class to manage all HID devices\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvHidDeviceController = class(TJvComponent)\r\n private\r\n // internal properties part\r\n FHidGuid: TGUID;\r\n FArrivalEvent: TJvHidPlugEvent;\r\n FDeviceChangeEvent: TNotifyEvent;\r\n FEnumerateEvent: TJvHidEnumerateEvent;\r\n FDevDataEvent: TJvHidDataEvent;\r\n FDevDataErrorEvent: TJvHidDataErrorEvent;\r\n FDevUnplugEvent: TJvHidUnplugEvent;\r\n FRemovalEvent: TJvHidUnplugEvent;\r\n FDevThreadSleepTime: Integer;\r\n FVersion: string;\r\n FDummy: string;\r\n // internal list of all HID device objects\r\n FList: TList;\r\n // counters for the list\r\n FNumCheckedInDevices: Integer;\r\n FNumCheckedOutDevices: Integer;\r\n FNumUnpluggedDevices: Integer;\r\n // reentrancy\r\n FInDeviceChange: Boolean;\r\n FLParam: LPARAM;\r\n // window to catch WM_DEVICECHANGE\r\n FHWnd: HWND;\r\n // internal worker functions\r\n function CheckThisOut(var HidDev: TJvHidDevice; Idx: Integer; Check: Boolean): Boolean;\r\n procedure EventPipe(var Msg: TMessage);\r\n // internal event implementors\r\n procedure SetDeviceChangeEvent(const Notifier: TNotifyEvent);\r\n procedure SetEnumerate(const Enumerator: TJvHidEnumerateEvent);\r\n procedure SetDevThreadSleepTime(const DevTime: Integer);\r\n procedure SetDevData(const DataEvent: TJvHidDataEvent);\r\n procedure SetDevDataError(const DataErrorEvent: TJvHidDataErrorEvent);\r\n procedure SetDevUnplug(const Unplugger: TJvHidUnplugEvent);\r\n protected\r\n procedure DoArrival(HidDev: TJvHidDevice);\r\n procedure DoRemoval(HidDev: TJvHidDevice);\r\n procedure DoDeviceChange;\r\n function DoEnumerate(HidDev: TJvHidDevice; Idx: Integer): Boolean;\r\n public\r\n // normal constructor/destructor\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n // methods to hand out HID device objects\r\n procedure CheckIn(var HidDev: TJvHidDevice);\r\n function CheckOut(var HidDev: TJvHidDevice): Boolean;\r\n function CheckOutByClass(var HidDev: TJvHidDevice; const ClassName: string): Boolean;\r\n function CheckOutByID(var HidDev: TJvHidDevice; const Vid, Pid: Integer): Boolean;\r\n function CheckOutByIndex(var HidDev: TJvHidDevice; const Idx: Integer): Boolean;\r\n function CheckOutByProductName(var HidDev: TJvHidDevice; const ProductName: WideString): Boolean;\r\n function CheckOutByVendorName(var HidDev: TJvHidDevice; const VendorName: WideString): Boolean;\r\n function CheckOutByCallback(var HidDev: TJvHidDevice; Check: TJvHidCheckCallback): Boolean;\r\n // methods to count HID device objects\r\n function CountByClass(const ClassName: string): Integer;\r\n function CountByID(const Vid, Pid: Integer): Integer;\r\n function CountByProductName(const ProductName: WideString): Integer;\r\n function CountByVendorName(const VendorName: WideString): Integer;\r\n function CountByCallback(Check: TJvHidCheckCallback): Integer;\r\n // iterate over the HID devices\r\n function Enumerate: Integer;\r\n class function HidVersion: string;\r\n // just to be complete the GUID\r\n property HidGuid: TGUID read FHidGuid;\r\n property NumCheckedInDevices: Integer read FNumCheckedInDevices;\r\n property NumCheckedOutDevices: Integer read FNumCheckedOutDevices;\r\n property NumUnpluggedDevices: Integer read FNumUnpluggedDevices;\r\n published\r\n property DevThreadSleepTime: Integer read FDevThreadSleepTime write SetDevThreadSleepTime default 100;\r\n property Version: string read FVersion write FDummy stored False;\r\n property OnArrival: TJvHidPlugEvent read FArrivalEvent write FArrivalEvent;\r\n // the iterator event\r\n property OnEnumerate: TJvHidEnumerateEvent read FEnumerateEvent write SetEnumerate;\r\n // the central event for HID device changes\r\n property OnDeviceChange: TNotifyEvent read FDeviceChangeEvent write SetDeviceChangeEvent;\r\n // these events are copied to TJvHidDevices on creation\r\n property OnDeviceData: TJvHidDataEvent read FDevDataEvent write SetDevData;\r\n property OnDeviceDataError: TJvHidDataErrorEvent read FDevDataErrorEvent write SetDevDataError;\r\n property OnDeviceUnplug: TJvHidUnplugEvent read FDevUnplugEvent write SetDevUnplug;\r\n property OnRemoval: TJvHidUnplugEvent read FRemovalEvent write FRemovalEvent;\r\n // to be callable at design time\r\n procedure DeviceChange;\r\n end;\r\n\r\n// helpers to check the HID function and method results\r\nfunction HidCheck(const RetVal: NTSTATUS): NTSTATUS; overload;\r\nfunction HidCheck(const RetVal: LongBool): LongBool; overload;\r\nfunction HidError(const RetVal: NTSTATUS): NTSTATUS;\r\nfunction HidErrorString(const RetVal: NTSTATUS): string;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvHidControllerClass.pas $';\r\n Revision: '$Revision: 13347 $';\r\n Date: '$Date: 2012-06-13 15:57:11 +0200 (mer. 13 juin 2012) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n JvResources;\r\n\r\ntype\r\n EControllerError = class(EJVCLException);\r\n EHidClientError = class(EJVCLException);\r\n\r\n//=== these are declared inconsistent in Windows.pas =========================\r\n\r\nfunction ReadFileEx(hFile: THandle; var Buffer; nNumberOfBytesToRead: DWORD;\r\n var Overlapped: TOverlapped; lpCompletionRoutine: TPROverlappedCompletionRoutine): BOOL; stdcall;\r\n external kernel32 name 'ReadFileEx';\r\n\r\nfunction WriteFileEx(hFile: THandle; var Buffer; nNumberOfBytesToWrite: DWORD;\r\n var Overlapped: TOverlapped; lpCompletionRoutine: TPROverlappedCompletionRoutine): BOOL; stdcall;\r\n external kernel32 name 'WriteFileEx';\r\n\r\n//=== { TJvHidDeviceReadThread } =============================================\r\n\r\nconstructor TJvHidDeviceReadThread.CtlCreate(const Dev: TJvHidDevice);\r\nbegin\r\n inherited Create(False);\r\n Device := Dev;\r\n NumBytesRead := 0;\r\n SetLength(Report, Dev.Caps.InputReportByteLength);\r\nend;\r\n\r\nconstructor TJvHidDeviceReadThread.Create(CreateSuspended: Boolean);\r\nbegin\r\n raise EControllerError.CreateRes(@RsEDirectThreadCreationNotAllowed);\r\nend;\r\n\r\nprocedure TJvHidDeviceReadThread.DoData;\r\nbegin\r\n Device.OnData(Device, Report[0], @Report[1], NumBytesRead - 1);\r\nend;\r\n\r\nprocedure TJvHidDeviceReadThread.DoDataError;\r\nbegin\r\n if Assigned(Device.FDataError) then\r\n Device.FDataError(Device, FErr);\r\nend;\r\n\r\nprocedure DummyReadCompletion(ErrorCode: DWORD; Count: DWORD; Ovl: POverlapped); stdcall;\r\nbegin\r\nend;\r\n\r\nprocedure TJvHidDeviceReadThread.Execute;\r\nvar\r\n SleepRet: DWORD;\r\nbegin\r\n NameThread(ThreadName);\r\n SleepRet := WAIT_IO_COMPLETION;\r\n try\r\n while not Terminated do\r\n begin\r\n // read data\r\n SleepRet := WAIT_IO_COMPLETION;\r\n FillChar(Report[0], Device.Caps.InputReportByteLength, #0);\r\n if Device.ReadFileEx(Report[0], Device.Caps.InputReportByteLength, @DummyReadCompletion) then\r\n begin\r\n // wait for read to complete\r\n repeat\r\n SleepRet := SleepEx(Device.ThreadSleepTime, True);\r\n until Terminated or (SleepRet = WAIT_IO_COMPLETION);\r\n // show data read\r\n if not Terminated then\r\n begin\r\n NumBytesRead := Device.HidOverlappedReadResult;\r\n if NumBytesRead > 0 then\r\n // synchronizing only works if the component is not instanciated in a DLL\r\n if IsLibrary then\r\n DoData\r\n else\r\n Synchronize(DoData);\r\n end;\r\n end\r\n else\r\n begin\r\n FErr := GetLastError;\r\n Synchronize(DoDataError);\r\n SleepEx(Device.ThreadSleepTime, True); // avoid 100% CPU usage (Mantis 5749)\r\n end;\r\n end;\r\n finally\r\n // cancel ReadFileEx call or the callback will\r\n // crash your program\r\n if SleepRet <> WAIT_IO_COMPLETION then\r\n Device.CancelIO(omhRead);\r\n end;\r\nend;\r\n\r\n//=== { TJvHidPnPInfo } ======================================================\r\n\r\nconstructor TJvHidPnPInfo.Create(APnPHandle: HDEVINFO; ADevData: TSPDevInfoData; ADevicePath: PChar);\r\nbegin\r\n inherited Create;\r\n FDeviceID := ADevData.DevInst;\r\n FDevicePath := ADevicePath;\r\n\r\n // primary information\r\n FCapabilities := GetRegistryPropertyDWord(APnPHandle, ADevData, SPDRP_CAPABILITIES);\r\n FClassDescr := GetRegistryPropertyString(APnPHandle, ADevData, SPDRP_CLASS);\r\n FClassGUID := GetRegistryPropertyString(APnPHandle, ADevData, SPDRP_CLASSGUID);\r\n FCompatibleIDs := GetRegistryPropertyStringList(APnPHandle, ADevData, SPDRP_COMPATIBLEIDS);\r\n FConfigFlags := GetRegistryPropertyDWord(APnPHandle, ADevData, SPDRP_CONFIGFLAGS);\r\n FDeviceDescr := GetRegistryPropertyString(APnPHandle, ADevData, SPDRP_DEVICEDESC);\r\n FDriver := GetRegistryPropertyString(APnPHandle, ADevData, SPDRP_DRIVER);\r\n FFriendlyName := GetRegistryPropertyString(APnPHandle, ADevData, SPDRP_FRIENDLYNAME);\r\n FHardwareID := GetRegistryPropertyStringList(APnPHandle, ADevData, SPDRP_HARDWAREID);\r\n FLowerFilters := GetRegistryPropertyStringList(APnPHandle, ADevData, SPDRP_LOWERFILTERS);\r\n FMfg := GetRegistryPropertyString(APnPHandle, ADevData, SPDRP_MFG);\r\n FUpperFilters := GetRegistryPropertyStringList(APnPHandle, ADevData, SPDRP_UPPERFILTERS);\r\n FService := GetRegistryPropertyString(APnPHandle, ADevData, SPDRP_SERVICE);\r\n\r\n // secondary information not all likely to exist for a HID device\r\n FAddress := GetRegistryPropertyString(APnPHandle, ADevData, SPDRP_ADDRESS);\r\n FBusNumber := GetRegistryPropertyDWord(APnPHandle, ADevData, SPDRP_BUSNUMBER);\r\n FBusType := GetRegistryPropertyString(APnPHandle, ADevData, SPDRP_BUSTYPEGUID);\r\n FCharacteristics := GetRegistryPropertyString(APnPHandle, ADevData, SPDRP_CHARACTERISTICS);\r\n FDevType := GetRegistryPropertyDWord(APnPHandle, ADevData, SPDRP_DEVTYPE);\r\n FEnumeratorName := GetRegistryPropertyString(APnPHandle, ADevData, SPDRP_ENUMERATOR_NAME);\r\n FExclusive := GetRegistryPropertyDWord(APnPHandle, ADevData, SPDRP_EXCLUSIVE);\r\n FLegacyBusType := GetRegistryPropertyDWord(APnPHandle, ADevData, SPDRP_LEGACYBUSTYPE);\r\n FLocationInfo := GetRegistryPropertyString(APnPHandle, ADevData, SPDRP_LOCATION_INFORMATION);\r\n FPhysDevObjName := GetRegistryPropertyString(APnPHandle, ADevData, SPDRP_PHYSICAL_DEVICE_OBJECT_NAME);\r\n FSecuritySDS := GetRegistryPropertyString(APnPHandle, ADevData, SPDRP_SECURITY_SDS);\r\n FUINumber := GetRegistryPropertyDWord(APnPHandle, ADevData, SPDRP_UI_NUMBER);\r\n FUINumberFormat := GetRegistryPropertyString(APnPHandle, ADevData, SPDRP_UI_NUMBER_DESC_FORMAT);\r\nend;\r\n\r\ndestructor TJvHidPnPInfo.Destroy;\r\nbegin\r\n FCompatibleIDs.Free;\r\n FHardwareID.Free;\r\n FLowerFilters.Free;\r\n FUpperFilters.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJvHidPnPInfo.GetCompatibleIDs: TStrings;\r\nbegin\r\n Result := FCompatibleIDs;\r\nend;\r\n\r\nfunction TJvHidPnPInfo.GetHardwareID: TStrings;\r\nbegin\r\n Result := FHardwareID;\r\nend;\r\n\r\nfunction TJvHidPnPInfo.GetLowerFilters: TStrings;\r\nbegin\r\n Result := FLowerFilters;\r\nend;\r\n\r\nfunction TJvHidPnPInfo.GetUpperFilters: TStrings;\r\nbegin\r\n Result := FUpperFilters;\r\nend;\r\n\r\n// internal helpers to read values from a devices registry area\r\n\r\nfunction TJvHidPnPInfo.GetRegistryPropertyString(PnPHandle: HDEVINFO;\r\n const DevData: TSPDevInfoData; Prop: DWORD): string;\r\nvar\r\n BytesReturned: DWORD;\r\n RegDataType: DWORD;\r\n Buffer: array [0..1023] of Char;\r\nbegin\r\n BytesReturned := 0;\r\n RegDataType := 0;\r\n Buffer[0] := #0;\r\n SetupDiGetDeviceRegistryProperty(PnPHandle, DevData, Prop,\r\n RegDataType, PByte(@Buffer[0]), SizeOf(Buffer), BytesReturned);\r\n Result := Buffer;\r\nend;\r\n\r\nfunction TJvHidPnPInfo.GetRegistryPropertyStringList(PnPHandle: HDEVINFO;\r\n const DevData: TSPDevInfoData; Prop: DWORD): TStringList;\r\nvar\r\n BytesReturned: DWORD;\r\n RegDataType: DWORD;\r\n Buffer: array [0..16383] of Char;\r\n P: PChar;\r\nbegin\r\n BytesReturned := 0;\r\n RegDataType := 0;\r\n Buffer[0] := #0;\r\n SetupDiGetDeviceRegistryProperty(PnPHandle, DevData, Prop,\r\n RegDataType, PBYTE(@Buffer[0]), SizeOf(Buffer), BytesReturned);\r\n Result := TStringList.Create;\r\n P := @Buffer[0];\r\n while P[0] <> #0 do\r\n begin\r\n Result.Add(P);\r\n P := P + StrLen(P) + 1;\r\n end;\r\nend;\r\n\r\nfunction TJvHidPnPInfo.GetRegistryPropertyDWord(PnPHandle: HDEVINFO;\r\n const DevData: TSPDevInfoData; Prop: DWORD): DWORD;\r\nvar\r\n BytesReturned: DWORD;\r\n RegDataType: DWORD;\r\nbegin\r\n BytesReturned := 0;\r\n RegDataType := 0;\r\n Result := 0;\r\n SetupDiGetDeviceRegistryProperty(PnPHandle, DevData, Prop,\r\n RegDataType, PBYTE(@Result), SizeOf(Result), BytesReturned);\r\nend;\r\n\r\n//=== { TJvHidDevice } =======================================================\r\n\r\n// dummy constructor to catch invalid Create calls\r\n\r\nconstructor TJvHidDevice.Create;\r\nbegin\r\n inherited Create;\r\n FHidFileHandle := INVALID_HANDLE_VALUE;\r\n FHidOverlappedRead := INVALID_HANDLE_VALUE;\r\n FHidOverlappedWrite := INVALID_HANDLE_VALUE;\r\n raise EControllerError.CreateRes(@RsEDirectHidDeviceCreationNotAllowed);\r\nend;\r\n\r\n// create and fill in a HidDevice object\r\n// the constructor is only accessible from TJvHidController\r\n// PnPInfo contains all info the JvHidDeviceController collected\r\n// Controller is the devices controller object to be referenced\r\n// internally\r\n\r\nconstructor TJvHidDevice.CtlCreate(const APnPInfo: TJvHidPnPInfo; const Controller: TJvHidDeviceController);\r\nbegin\r\n inherited Create;\r\n\r\n // initialize private data\r\n FPnPInfo := APnPInfo;\r\n FMyController := Controller;\r\n FIsPluggedIn := True;\r\n FIsCheckedOut := False;\r\n FIsEnumerated := False;\r\n FHidOverlappedRead := INVALID_HANDLE_VALUE;\r\n FHidOverlappedWrite := INVALID_HANDLE_VALUE;\r\n FVendorName := '';\r\n FProductName := '';\r\n FPreparsedData := nil;\r\n SetLength(FPhysicalDescriptor, 0);\r\n FSerialNumber := '';\r\n FLanguageStrings := TStringList.Create;\r\n FNumInputBuffers := 0;\r\n FNumOverlappedBuffers := 0;\r\n SetLength(FLinkCollection, 0);\r\n FMaxDataListLength := 0;\r\n FMaxUsageListLength := 0;\r\n FMaxButtonListLength := 0;\r\n FReportTypeParam := HIDP_Input;\r\n FThreadSleepTime := 100;\r\n FUsagePageParam := 0;\r\n FLinkCollectionParam := 0;\r\n FUsageParam := 0;\r\n FDataThread := nil;\r\n OnData := Controller.OnDeviceData;\r\n OnUnplug := Controller.OnDeviceUnplug;\r\n\r\n FHidFileHandle := CreateFile(PChar(PnPInfo.DevicePath), GENERIC_READ or GENERIC_WRITE,\r\n FILE_SHARE_READ or FILE_SHARE_WRITE, nil, OPEN_EXISTING, 0, 0);\r\n FHasReadWriteAccess := HidFileHandle <> INVALID_HANDLE_VALUE;\r\n // Win2000 hack\r\n if not HasReadWriteAccess then\r\n FHidFileHandle := CreateFile(PChar(PnPInfo.DevicePath), 0,\r\n FILE_SHARE_READ or FILE_SHARE_WRITE, nil, OPEN_EXISTING, 0, 0);\r\n if HidFileHandle <> INVALID_HANDLE_VALUE then\r\n begin\r\n FAttributes.Size := SizeOf(THIDDAttributes);\r\n if not HidD_GetAttributes(HidFileHandle, FAttributes) then\r\n raise EControllerError.CreateRes(@RsEDeviceCannotBeIdentified);\r\n end\r\n else\r\n raise EControllerError.CreateRes(@RsEDeviceCannotBeOpened);\r\n // the file is closed to stop using up resources\r\n CloseFile;\r\nend;\r\n\r\n// If a TJvHidDevice is destroyed the TJvHidController has to be informed.\r\n// If the device is plugged in this TJvHidDevice instance is destroyed,\r\n// but another instance is created in the controller list to replace it.\r\n\r\ndestructor TJvHidDevice.Destroy;\r\nvar\r\n I: Integer;\r\n TmpOnData: TJvHidDataEvent;\r\n TmpOnUnplug: TJvHidUnplugEvent;\r\n Dev: TJvHidDevice;\r\nbegin\r\n // if we need to clone the object\r\n TmpOnData := OnData;\r\n TmpOnUnplug := OnUnplug;\r\n // to prevent strange problems\r\n OnData := nil;\r\n OnUnplug := nil;\r\n // free the data which needs special handling\r\n CloseFile;\r\n CloseFileEx(omhRead);\r\n CloseFileEx(omhWrite);\r\n\r\n if FPreparsedData <> nil then\r\n HidD_FreePreparsedData(FPreparsedData);\r\n FLanguageStrings.Free;\r\n\r\n // if controller exists\r\n if FMyController <> nil then\r\n with FMyController do\r\n begin\r\n // delete device from controller list\r\n for I := 0 to FList.Count - 1 do\r\n if FList.Items[I] = Self then\r\n begin\r\n // if device is plugged in create a checked in copy\r\n if IsPluggedIn then\r\n begin\r\n Dev := TJvHidDevice.CtlCreate(FPnPInfo, FMyController);\r\n // make it a complete clone\r\n Dev.OnData := TmpOnData;\r\n Dev.OnUnplug := TmpOnUnplug;\r\n Dev.ThreadSleepTime := ThreadSleepTime;\r\n FList.Items[I] := Dev;\r\n // the FPnPInfo has been handed over to the new object\r\n FPnPInfo := nil;\r\n if IsCheckedOut then\r\n begin\r\n Dec(FNumCheckedOutDevices);\r\n Inc(FNumCheckedInDevices);\r\n end;\r\n end\r\n else\r\n begin\r\n FList.Delete(I);\r\n Dec(FNumUnpluggedDevices);\r\n end;\r\n Break;\r\n end;\r\n end;\r\n\r\n FPnPInfo.Free;\r\n inherited Destroy;\r\nend;\r\n\r\n// if check changes change check only here\r\n\r\nfunction TJvHidDevice.IsAccessible: Boolean;\r\nbegin\r\n Result := IsPluggedIn and (IsCheckedOut or FIsEnumerated);\r\nend;\r\n\r\n// open the device \"file\" (for the other methods)\r\n\r\nfunction TJvHidDevice.OpenFile: Boolean;\r\nbegin\r\n // check if open allowed (propagates this state)\r\n if IsAccessible then\r\n if HidFileHandle = INVALID_HANDLE_VALUE then // if not already opened\r\n begin\r\n FHidFileHandle := CreateFile(PChar(PnPInfo.DevicePath), GENERIC_READ or GENERIC_WRITE,\r\n FILE_SHARE_READ or FILE_SHARE_WRITE, nil, OPEN_EXISTING, 0, 0);\r\n FHasReadWriteAccess := HidFileHandle <> INVALID_HANDLE_VALUE;\r\n // Win2000 hack\r\n if not HasReadWriteAccess then\r\n FHidFileHandle := CreateFile(PChar(PnPInfo.DevicePath), 0,\r\n FILE_SHARE_READ or FILE_SHARE_WRITE, nil, OPEN_EXISTING, 0, 0);\r\n if HidFileHandle <> INVALID_HANDLE_VALUE then\r\n begin\r\n if NumInputBuffers <> 0 then\r\n HidD_SetNumInputBuffers(HidFileHandle, NumInputBuffers);\r\n HidD_GetNumInputBuffers(HidFileHandle, FNumInputBuffers);\r\n end;\r\n end;\r\n Result := HidFileHandle <> INVALID_HANDLE_VALUE;\r\nend;\r\n\r\n// open second device \"file\" for ReadFileEx and WriteFileEx\r\n\r\nfunction TJvHidDevice.OpenFileEx(Mode: TJvHidOpenExMode): Boolean;\r\nbegin\r\n Result := False;\r\n // check if open allowed (propagates this state)\r\n if IsAccessible then\r\n if Mode = omhRead then\r\n begin\r\n if HidOverlappedRead = INVALID_HANDLE_VALUE then // if not already opened\r\n begin\r\n FHidOverlappedRead := CreateFile(PChar(PnPInfo.DevicePath), GENERIC_READ,\r\n FILE_SHARE_READ or FILE_SHARE_WRITE, nil, OPEN_EXISTING, FILE_FLAG_OVERLAPPED, 0);\r\n if FHidOverlappedRead <> INVALID_HANDLE_VALUE then\r\n begin\r\n if NumOverlappedBuffers <> 0 then\r\n HidD_SetNumInputBuffers(FHidOverlappedRead, NumOverlappedBuffers);\r\n HidD_GetNumInputBuffers(FHidOverlappedRead, FNumOverlappedBuffers);\r\n end;\r\n end;\r\n Result := FHidOverlappedRead <> INVALID_HANDLE_VALUE;\r\n end\r\n else\r\n begin\r\n if HidOverlappedWrite = INVALID_HANDLE_VALUE then // if not already opened\r\n FHidOverlappedWrite := CreateFile(PChar(PnPInfo.DevicePath), GENERIC_WRITE,\r\n FILE_SHARE_READ or FILE_SHARE_WRITE, nil, OPEN_EXISTING, FILE_FLAG_OVERLAPPED, 0);\r\n Result := FHidOverlappedWrite <> INVALID_HANDLE_VALUE;\r\n end;\r\nend;\r\n\r\n// implement OnUnplug event\r\n\r\nprocedure TJvHidDevice.DoUnplug;\r\nbegin\r\n CloseFile;\r\n CloseFileEx(omhRead);\r\n CloseFileEx(omhWrite);\r\n FIsPluggedIn := False;\r\n // event even for checked in devices\r\n if Assigned(FUnplug) then\r\n FUnplug(Self);\r\n // guarantees that event is only called once\r\n OnUnplug := nil;\r\nend;\r\n\r\n// implementing indexed properties read\r\n\r\nfunction TJvHidDevice.GetDeviceStringAnsi(Idx: Byte): string;\r\nbegin\r\n Result := WideCharToString(PWideChar(GetDeviceStringUnicode(Idx)));\r\nend;\r\n\r\nfunction TJvHidDevice.GetDeviceStringUnicode(Idx: Byte): WideString;\r\nvar\r\n Buffer: array [0..253] of WideChar;\r\nbegin\r\n Result := '';\r\n if Idx <> 0 then\r\n if OpenFile then\r\n if HidD_GetIndexedString(HidFileHandle, Idx, Buffer, SizeOf(Buffer)) then\r\n Result := Buffer;\r\nend;\r\n\r\nfunction TJvHidDevice.GetLinkCollectionNode(Idx: WORD): THIDPLinkCollectionNode;\r\nvar\r\n Siz: ULONG;\r\nbegin\r\n if Length(FLinkCollection) = 0 then\r\n begin\r\n Siz := Caps.NumberLinkCollectionNodes;\r\n SetLength(FLinkCollection, Siz);\r\n HidP_GetLinkCollectionNodes(@FLinkCollection[0], Siz, PreparsedData);\r\n end;\r\n FillChar(Result, SizeOf(THIDPLinkCollectionNode), #0);\r\n if Idx < Length(FLinkCollection) then\r\n Result := FLinkCollection[Idx];\r\nend;\r\n\r\n// implementing properties write\r\n\r\nprocedure TJvHidDevice.SetNumInputBuffers(const Num: Integer);\r\nbegin\r\n if (Num <> FNumInputBuffers) and OpenFile then\r\n begin\r\n HidD_SetNumInputBuffers(HidFileHandle, Num);\r\n HidD_GetNumInputBuffers(HidFileHandle, FNumInputBuffers);\r\n end;\r\nend;\r\n\r\nprocedure TJvHidDevice.SetNumOverlappedBuffers(const Num: Integer);\r\nbegin\r\n if (Num <> FNumOverlappedBuffers) and OpenFileEx(omhRead) then\r\n begin\r\n HidD_SetNumInputBuffers(HidOverlappedRead, Num);\r\n HidD_GetNumInputBuffers(HidOverlappedRead, FNumOverlappedBuffers);\r\n end;\r\nend;\r\n\r\n// internal helper for the following functions\r\n\r\nprocedure TJvHidDevice.GetMax;\r\nbegin\r\n if IsAccessible then\r\n begin\r\n FMaxDataListLength := HidP_MaxDataListLength(ReportTypeParam, PreparsedData);\r\n FMaxUsageListLength := HidP_MaxUsageListLength(ReportTypeParam, UsagePageParam, PreparsedData);\r\n FMaxButtonListLength := HidP_MaxButtonListLength(ReportTypeParam, UsagePageParam, PreparsedData);\r\n end;\r\nend;\r\n\r\nprocedure TJvHidDevice.SetReportTypeParam(const ReportType: THIDPReportType);\r\nbegin\r\n FReportTypeParam := ReportType;\r\n GetMax;\r\nend;\r\n\r\nprocedure TJvHidDevice.SetThreadSleepTime(const SleepTime: Integer);\r\nbegin\r\n // limit to 10 msec .. 10 sec\r\n if (SleepTime >= 10) and (SleepTime <= 10000) then\r\n FThreadSleepTime := SleepTime;\r\nend;\r\n\r\nprocedure TJvHidDevice.SetUsagePageParam(const UsagePage: TUsage);\r\nbegin\r\n FUsagePageParam := UsagePage;\r\n GetMax;\r\nend;\r\n\r\nfunction TJvHidDevice.GetConfiguration: THIDDConfiguration;\r\nbegin\r\n Result.cookie := nil;\r\n Result.size := 0;\r\n Result.RingBufferSize := 0;\r\n if OpenFile then\r\n HidD_GetConfiguration(HidFileHandle, Result, SizeOf(THIDDConfiguration));\r\nend;\r\n\r\nfunction TJvHidDevice.GetPreparsedData: PHIDPPreparsedData;\r\nbegin\r\n if FPreparsedData = nil then\r\n if OpenFile then\r\n begin\r\n HidD_GetPreparsedData(HidFileHandle, FPreparsedData);\r\n CloseFile;\r\n end;\r\n Result := FPreparsedData;\r\nend;\r\n\r\nfunction TJvHidDevice.GetCaps: THIDPCaps;\r\nbegin\r\n FillChar(Result, SizeOf(THIDPCaps), #0);\r\n HidP_GetCaps(PreparsedData, Result);\r\nend;\r\n\r\nfunction TJvHidDevice.GetVendorName: WideString;\r\nvar\r\n Buffer: array [0..253] of WideChar;\r\nbegin\r\n if FVendorName = '' then\r\n if OpenFile then\r\n begin\r\n FillChar(Buffer, SizeOf(Buffer), #0);\r\n if HidD_GetManufacturerString(HidFileHandle, Buffer, SizeOf(Buffer)) then\r\n FVendorName := Buffer;\r\n CloseFile;\r\n end;\r\n Result := FVendorName;\r\nend;\r\n\r\nfunction TJvHidDevice.GetProductName: WideString;\r\nvar\r\n Buffer: array [0..253] of WideChar;\r\nbegin\r\n if FProductName = '' then\r\n if OpenFile then\r\n begin\r\n FillChar(Buffer, SizeOf(Buffer), #0);\r\n if HidD_GetProductString(HidFileHandle, Buffer, SizeOf(Buffer)) then\r\n FProductName := Buffer;\r\n CloseFile;\r\n end;\r\n Result := FProductName;\r\nend;\r\n\r\nfunction TJvHidDevice.GetSerialNumber: WideString;\r\nvar\r\n I: Integer;\r\n Len: Integer;\r\n IDs: array [0..253] of WORD;\r\n Buffer: array [0..253] of WideChar;\r\nbegin\r\n if FSerialNumber = '' then\r\n if OpenFile then\r\n begin\r\n FillChar(Buffer, SizeOf(Buffer), #0);\r\n if HidD_GetSerialNumberString(HidFileHandle, Buffer, SizeOf(Buffer)) then\r\n begin\r\n // calculate length of StringDescriptor 0\r\n FillChar(IDs, SizeOf(IDs), $FF);\r\n Len := 0;\r\n HidD_GetIndexedString(HidFileHandle, 0, PWideChar(@IDs), SizeOf(IDs));\r\n for I := High(IDs) downto 0 do\r\n if IDs[I] <> $FFFF then\r\n begin\r\n if IDs[I] = 0 then\r\n Len := I\r\n else\r\n Len := I + 1;\r\n Break;\r\n end;\r\n // compensate for buggy function\r\n for I := 0 to Len - 1 do\r\n if IDs[I] <> WORD(Buffer[I]) then\r\n begin\r\n FSerialNumber := Buffer;\r\n Break;\r\n end;\r\n end;\r\n CloseFile;\r\n end;\r\n Result := FSerialNumber;\r\nend;\r\n\r\nfunction TJvHidDevice.GetPhysicalDescriptor: TJvPhysicalDescriptor;\r\nvar\r\n I: Integer;\r\nbegin\r\n if Length(FPhysicalDescriptor) = 0 then\r\n if OpenFile then\r\n begin\r\n I := 0;\r\n SetLength(FPhysicalDescriptor, 2048);\r\n while not HidD_GetPhysicalDescriptor(HidFileHandle, FPhysicalDescriptor[0], I * SizeOf(WORD)) do\r\n begin\r\n Inc(I);\r\n if (I > 2048) or (GetLastError <> ERROR_INSUFFICIENT_BUFFER) then\r\n begin\r\n I := 0;\r\n Break;\r\n end;\r\n end;\r\n SetLength(FPhysicalDescriptor, I);\r\n CloseFile;\r\n end;\r\n Result := FPhysicalDescriptor;\r\nend;\r\n\r\nfunction TJvHidDevice.GetLanguageStrings: TStrings;\r\nvar\r\n I: Integer;\r\n Len: Integer;\r\n IDs: array [0..253] of WORD;\r\n Name: array [0..255] of Char;\r\nbegin\r\n if FLanguageStrings.Count = 0 then\r\n if OpenFile then\r\n begin\r\n // calculate length of StringDescriptor 0\r\n FillChar(IDs, SizeOf(IDs), $FF);\r\n Len := 0;\r\n if HidD_GetIndexedString(HidFileHandle, 0, PWideChar(@IDs), SizeOf(IDs)) then\r\n for I := High(IDs) downto 0 do\r\n if IDs[I] <> $FFFF then\r\n begin\r\n if IDs[I] = 0 then\r\n Len := I\r\n else\r\n Len := I + 1;\r\n Break;\r\n end;\r\n // transform id into localized language name\r\n for I := 0 to Len - 1 do\r\n begin\r\n Name[0] := #0;\r\n if GetLocaleInfo(WORD(IDs[I]), LOCALE_SLANGUAGE, Name, SizeOf(Name)) <> 0 then\r\n FLanguageStrings.Add(Name)\r\n else\r\n FLanguageStrings.Add(Format(RsUnknownLocaleIDFmt, [WORD(IDs[I])]));\r\n end;\r\n CloseFile;\r\n end;\r\n Result := FLanguageStrings;\r\nend;\r\n\r\nfunction TJvHidDevice.GetOverlappedReadResult: DWORD;\r\nbegin\r\n Result := 0;\r\n if HidOverlappedRead <> INVALID_HANDLE_VALUE then\r\n if not GetOverlappedResult(HidOverlappedRead, FOvlRead, Result, False) then\r\n Result := 0;\r\nend;\r\n\r\nfunction TJvHidDevice.GetOverlappedWriteResult: DWORD;\r\nbegin\r\n Result := 0;\r\n if HidOverlappedWrite <> INVALID_HANDLE_VALUE then\r\n if not GetOverlappedResult(HidOverlappedWrite, FOvlWrite, Result, False) then\r\n Result := 0;\r\nend;\r\n\r\nprocedure TJvHidDevice.SetConfiguration(const Config: THIDDConfiguration);\r\nbegin\r\n if OpenFile then\r\n HidD_SetConfiguration(HidFileHandle, Config, SizeOf(THIDDConfiguration));\r\nend;\r\n\r\nprocedure TJvHidDevice.SetDataEvent(const DataEvent: TJvHidDataEvent);\r\nbegin\r\n // this assignment is a bit tricky because a thread may be running\r\n // kill the thread with the old event still in effect\r\n if not Assigned(DataEvent) then\r\n StopThread;\r\n // assign the new event and start the thread if needed\r\n FData := DataEvent;\r\n StartThread;\r\nend;\r\n\r\nprocedure TJvHidDevice.StartThread;\r\nbegin\r\n if Assigned(FData) and IsPluggedIn and IsCheckedOut and\r\n HasReadWriteAccess and not Assigned(FDataThread) then\r\n begin\r\n FDataThread := TJvHidDeviceReadThread.CtlCreate(Self);\r\n end;\r\nend;\r\n\r\nprocedure TJvHidDevice.StopThread;\r\nbegin\r\n if Assigned(FDataThread) then\r\n begin\r\n FDataThread.Terminate;\r\n FDataThread.WaitFor;\r\n FDataThread.Free;\r\n FDataThread := nil;\r\n end;\r\nend;\r\n\r\n// TJvHidDevice methods:\r\n// generally the parameter count of the methods is reduced with the Param properties\r\n// first assign the Param properties the desired value then call a method\r\n// normally you will address the same Usage, UsagePage, ReportType or LinkCollection\r\n// with more than one method\r\n//\r\n// the methods will open the device file when needed\r\n// this file is not closed until unplug or destruction to speed up access\r\n\r\n// cancel asynchronous operations on either HidOverlappedRead or HidOverlappedWrite\r\n\r\nfunction TJvHidDevice.CancelIO(const Mode: TJvHidOpenExMode): Boolean;\r\n\r\n function CallCancelIO(Handle: THandle): Boolean;\r\n type\r\n TCancelIOFunc = function(hFile: THandle): BOOL; stdcall;\r\n var\r\n hKernel: HMODULE;\r\n CancelIOFunc: TCancelIOFunc;\r\n begin\r\n hKernel := GetModuleHandle(kernel32);\r\n Result := hKernel <> INVALID_HANDLE_VALUE;\r\n if Result then\r\n begin\r\n @CancelIOFunc := GetProcAddress(hKernel, 'CancelIO');\r\n if Assigned(CancelIOFunc) then\r\n Result := CancelIOFunc(Handle)\r\n else\r\n Result := False;\r\n end;\r\n end;\r\n\r\nbegin\r\n Result := False;\r\n if (Mode = omhRead) and (HidOverlappedRead <> INVALID_HANDLE_VALUE) then\r\n Result := CallCancelIO(HidOverlappedRead)\r\n else\r\n if (Mode = omhWrite) and (HidOverlappedWrite <> INVALID_HANDLE_VALUE) then\r\n Result := CallCancelIO(HidOverlappedWrite);\r\nend;\r\n\r\n// close the device \"file\"\r\n// if you want to open the file directly close this\r\n// to get undisturbed access\r\n\r\nprocedure TJvHidDevice.CloseFile;\r\nbegin\r\n if HidFileHandle <> INVALID_HANDLE_VALUE then\r\n CloseHandle(HidFileHandle);\r\n FNumInputBuffers := 0;\r\n FHidFileHandle := INVALID_HANDLE_VALUE;\r\nend;\r\n\r\n// same for the other device \"file\"\r\n\r\nprocedure TJvHidDevice.CloseFileEx(const Mode: TJvHidOpenExMode);\r\nbegin\r\n if Mode = omhRead then\r\n begin\r\n if HidOverlappedRead <> INVALID_HANDLE_VALUE then\r\n CloseHandle(HidOverlappedRead);\r\n FNumOverlappedBuffers := 0;\r\n FHidOverlappedRead := INVALID_HANDLE_VALUE;\r\n end\r\n else\r\n begin\r\n if HidOverlappedWrite <> INVALID_HANDLE_VALUE then\r\n CloseHandle(HidOverlappedWrite);\r\n FHidOverlappedWrite := INVALID_HANDLE_VALUE;\r\n end;\r\nend;\r\n\r\n// all the methods which directly map to a HID-function\r\n\r\nfunction TJvHidDevice.FlushQueue: Boolean;\r\nbegin\r\n Result := False;\r\n if OpenFile then\r\n Result := HidD_FlushQueue(HidFileHandle);\r\nend;\r\n\r\nfunction TJvHidDevice.GetFeature(var Report; const Size: Integer): Boolean;\r\nbegin\r\n Result := False;\r\n if OpenFile then\r\n Result := HidD_GetFeature(HidFileHandle, Report, Size);\r\nend;\r\n\r\nfunction TJvHidDevice.SetFeature(var Report; const Size: Integer): Boolean;\r\nbegin\r\n Result := False;\r\n if OpenFile then\r\n Result := HidD_SetFeature(HidFileHandle, Report, Size);\r\nend;\r\n\r\nfunction TJvHidDevice.GetSpecificButtonCaps(ButtonCaps: PHIDPButtonCaps; var Count: WORD): NTSTATUS;\r\nbegin\r\n Result := HIDP_STATUS_NULL; // for not plugged in\r\n if IsAccessible then\r\n Result := HidP_GetSpecificButtonCaps(ReportTypeParam, UsagePageParam,\r\n LinkCollectionParam, UsageParam, ButtonCaps, Count, PreparsedData);\r\nend;\r\n\r\nfunction TJvHidDevice.GetButtonCaps(ButtonCaps: PHIDPButtonCaps; var Count: WORD): NTSTATUS;\r\nbegin\r\n Result := HIDP_STATUS_NULL; // for not plugged in\r\n if IsAccessible then\r\n Result := HidP_GetButtonCaps_(ReportTypeParam, ButtonCaps, Count, PreparsedData);\r\nend;\r\n\r\nfunction TJvHidDevice.GetSpecificValueCaps(ValueCaps: PHIDPValueCaps; var Count: WORD): NTSTATUS;\r\nbegin\r\n Result := HIDP_STATUS_NULL; // for not plugged in\r\n if IsAccessible then\r\n Result := HidP_GetSpecificValueCaps(ReportTypeParam, UsagePageParam,\r\n LinkCollectionParam, UsageParam, ValueCaps, Count, PreparsedData);\r\nend;\r\n\r\nfunction TJvHidDevice.GetValueCaps(ValueCaps: PHIDPValueCaps; var Count: WORD): NTSTATUS;\r\nbegin\r\n Result := HIDP_STATUS_NULL; // for not plugged in\r\n if IsAccessible then\r\n Result := HidP_GetValueCaps_(ReportTypeParam, ValueCaps, Count, PreparsedData);\r\nend;\r\n\r\nfunction TJvHidDevice.GetData(DataList: PHIDPData; var DataLength: ULONG;\r\n var Report; ReportLength: ULONG): NTSTATUS;\r\nbegin\r\n Result := HIDP_STATUS_NULL; // for not plugged in\r\n if IsAccessible then\r\n Result := HidP_GetData(ReportTypeParam, DataList, DataLength, PreparsedData,\r\n Report, ReportLength);\r\nend;\r\n\r\nfunction TJvHidDevice.SetData(DataList: PHIDPData; var DataLength: ULONG;\r\n var Report; ReportLength: ULONG): NTSTATUS;\r\nbegin\r\n Result := HIDP_STATUS_NULL; // for not plugged in\r\n if IsAccessible then\r\n Result := HidP_SetData(ReportTypeParam, DataList, DataLength, PreparsedData,\r\n Report, ReportLength);\r\nend;\r\n\r\nfunction TJvHidDevice.GetUsages(UsageList: PUsage; var UsageLength: ULONG;\r\n var Report; ReportLength: ULONG): NTSTATUS;\r\nbegin\r\n Result := HIDP_STATUS_NULL; // for not plugged in\r\n if IsAccessible then\r\n Result := HidP_GetUsages(ReportTypeParam, UsagePageParam, LinkCollectionParam,\r\n UsageList, UsageLength, PreparsedData, Report, ReportLength);\r\nend;\r\n\r\nfunction TJvHidDevice.GetButtons(UsageList: PUsage; var UsageLength: ULONG;\r\n var Report; ReportLength: ULONG): NTSTATUS;\r\nbegin\r\n Result := HIDP_STATUS_NULL; // for not plugged in\r\n if IsAccessible then\r\n Result := HidP_GetButtons(ReportTypeParam, UsagePageParam, LinkCollectionParam,\r\n UsageList, UsageLength, PreparsedData, Report, ReportLength);\r\nend;\r\n\r\nfunction TJvHidDevice.GetUsagesEx(UsageList: PUsageAndPage; var UsageLength: ULONG;\r\n var Report; ReportLength: ULONG): NTSTATUS;\r\nbegin\r\n Result := HIDP_STATUS_NULL; // for not plugged in\r\n if IsAccessible then\r\n Result := HidP_GetUsagesEx(ReportTypeParam, LinkCollectionParam, UsageList,\r\n UsageLength, PreparsedData, Report, ReportLength);\r\nend;\r\n\r\nfunction TJvHidDevice.GetButtonsEx(UsageList: PUsageAndPage; var UsageLength: ULONG;\r\n var Report; ReportLength: ULONG): NTSTATUS;\r\nbegin\r\n Result := HIDP_STATUS_NULL; // for not plugged in\r\n if IsAccessible then\r\n Result := HidP_GetButtonsEx(ReportTypeParam, LinkCollectionParam, UsageList,\r\n UsageLength, PreparsedData, Report, ReportLength);\r\nend;\r\n\r\nfunction TJvHidDevice.SetUsages(UsageList: PUsage; var UsageLength: ULONG;\r\n var Report; ReportLength: ULONG): NTSTATUS;\r\nbegin\r\n Result := HIDP_STATUS_NULL; // for not plugged in\r\n if IsAccessible then\r\n Result := HidP_SetUsages(ReportTypeParam, UsagePageParam, LinkCollectionParam,\r\n UsageList, UsageLength, PreparsedData, Report, ReportLength);\r\nend;\r\n\r\nfunction TJvHidDevice.SetButtons(UsageList: PUsage; var UsageLength: ULONG;\r\n var Report; ReportLength: ULONG): NTSTATUS;\r\nbegin\r\n Result := HIDP_STATUS_NULL; // for not plugged in\r\n if IsAccessible then\r\n Result := HidP_SetButtons(ReportTypeParam, UsagePageParam, LinkCollectionParam,\r\n UsageList, UsageLength, PreparsedData, Report, ReportLength);\r\nend;\r\n\r\nfunction TJvHidDevice.UnsetUsages(UsageList: PUsage; var UsageLength: ULONG;\r\n var Report; ReportLength: ULONG): NTSTATUS;\r\nbegin\r\n Result := HIDP_STATUS_NULL; // for not plugged in\r\n if IsAccessible then\r\n Result := HidP_UnsetUsages(ReportTypeParam, UsagePageParam, LinkCollectionParam,\r\n UsageList, UsageLength, PreparsedData, Report, ReportLength);\r\nend;\r\n\r\nfunction TJvHidDevice.UnsetButtons(UsageList: PUsage; var UsageLength: ULONG;\r\n var Report; ReportLength: ULONG): NTSTATUS;\r\nbegin\r\n Result := HIDP_STATUS_NULL; // for not plugged in\r\n if IsAccessible then\r\n Result := HidP_UnsetButtons(ReportTypeParam, UsagePageParam, LinkCollectionParam,\r\n UsageList, UsageLength, PreparsedData, Report, ReportLength);\r\nend;\r\n\r\nfunction TJvHidDevice.GetUsageValue(var UsageValue: ULONG; var Report; ReportLength: ULONG): NTSTATUS;\r\nbegin\r\n Result := HIDP_STATUS_NULL; // for not plugged in\r\n if IsAccessible then\r\n Result := HidP_GetUsageValue(ReportTypeParam, UsagePageParam, LinkCollectionParam,\r\n UsageParam, UsageValue, PreparsedData, Report, ReportLength);\r\nend;\r\n\r\nfunction TJvHidDevice.GetScaledUsageValue(var UsageValue: Integer;\r\n var Report; ReportLength: ULONG): NTSTATUS;\r\nbegin\r\n Result := HIDP_STATUS_NULL; // for not plugged in\r\n if IsAccessible then\r\n Result := HidP_GetScaledUsageValue(ReportTypeParam, UsagePageParam, LinkCollectionParam,\r\n UsageParam, UsageValue, PreparsedData, Report, ReportLength);\r\nend;\r\n\r\nfunction TJvHidDevice.GetUsageValueArray(UsageValue: PAnsiChar;\r\n UsageValueByteLength: WORD; var Report; ReportLength: ULONG): NTSTATUS;\r\nbegin\r\n Result := HIDP_STATUS_NULL; // for not plugged in\r\n if IsAccessible then\r\n Result := HidP_GetUsageValueArray(ReportTypeParam, UsagePageParam, LinkCollectionParam,\r\n UsageParam, UsageValue, UsageValueByteLength, PreparsedData, Report, ReportLength);\r\nend;\r\n\r\nfunction TJvHidDevice.SetUsageValue(UsageValue: ULONG; var Report; ReportLength: ULONG): NTSTATUS;\r\nbegin\r\n Result := HIDP_STATUS_NULL; // for not plugged in\r\n if IsAccessible then\r\n Result := HidP_SetUsageValue(ReportTypeParam, UsagePageParam, LinkCollectionParam,\r\n UsageParam, UsageValue, PreparsedData, Report, ReportLength);\r\nend;\r\n\r\nfunction TJvHidDevice.SetScaledUsageValue(UsageValue: Integer; var Report;\r\n ReportLength: ULONG): NTSTATUS;\r\nbegin\r\n Result := HIDP_STATUS_NULL; // for not plugged in\r\n if IsAccessible then\r\n Result := HidP_SetScaledUsageValue(ReportTypeParam, UsagePageParam, LinkCollectionParam,\r\n UsageParam, UsageValue, PreparsedData, Report, ReportLength);\r\nend;\r\n\r\nfunction TJvHidDevice.SetUsageValueArray(UsageValue: PAnsiChar;\r\n UsageValueByteLength: WORD; var Report; ReportLength: ULONG): NTSTATUS;\r\nbegin\r\n Result := HIDP_STATUS_NULL; // for not plugged in\r\n if IsAccessible then\r\n Result := HidP_SetUsageValueArray(ReportTypeParam, UsagePageParam, LinkCollectionParam,\r\n UsageParam, UsageValue, UsageValueByteLength, PreparsedData, Report, ReportLength);\r\nend;\r\n\r\nfunction TJvHidDevice.DeviceIoControl(IoControlCode: DWORD; InBuffer: Pointer; InSize: DWORD;\r\n OutBuffer: Pointer; OutSize: DWORD; var BytesReturned: DWORD): Boolean;\r\nbegin\r\n Result := False;\r\n if OpenFile then\r\n Result := Windows.DeviceIoControl(HidFileHandle, IoControlCode, InBuffer, InSize,\r\n OutBuffer, OutSize, BytesReturned, nil);\r\nend;\r\n\r\nfunction TJvHidDevice.ReadFile(var Report; ToRead: DWORD; var BytesRead: DWORD): Boolean;\r\nbegin\r\n Result := False;\r\n if OpenFile then\r\n Result := Windows.ReadFile(HidFileHandle, Report, ToRead, BytesRead, nil);\r\nend;\r\n\r\nfunction TJvHidDevice.WriteFile(var Report; ToWrite: DWORD; var BytesWritten: DWORD): Boolean;\r\nbegin\r\n Result := False;\r\n if OpenFile then\r\n Result := Windows.WriteFile(HidFileHandle, Report, ToWrite, BytesWritten, nil);\r\nend;\r\n\r\n// the TOverlapped structure is not needed externally\r\n// the hEvent element is used to transport the device object\r\n// to the callback function\r\n// Better not implement a Delphi event with that\r\n\r\nfunction TJvHidDevice.ReadFileEx(var Report; ToRead: DWORD;\r\n CallBack: TPROverlappedCompletionRoutine): Boolean;\r\nbegin\r\n Result := False;\r\n if OpenFileEx(omhRead) then\r\n begin\r\n FillChar(FOvlRead, SizeOf(TOverlapped), #0);\r\n FOvlRead.hEvent := DWORD(Self);\r\n Result := JvHidControllerClass.ReadFileEx(HidOverlappedRead, Report, ToRead, FOvlRead, CallBack);\r\n end;\r\nend;\r\n\r\nfunction TJvHidDevice.WriteFileEx(var Report; ToWrite: DWORD;\r\n CallBack: TPROverlappedCompletionRoutine): Boolean;\r\nbegin\r\n Result := False;\r\n if OpenFileEx(omhWrite) then\r\n begin\r\n FillChar(FOvlWrite, SizeOf(TOverlapped), #0);\r\n FOvlWrite.hEvent := DWORD(Self);\r\n Result := JvHidControllerClass.WriteFileEx(HidOverlappedWrite, Report, ToWrite, FOvlWrite, CallBack);\r\n end;\r\nend;\r\n\r\nfunction TJvHidDevice.CheckOut: Boolean;\r\nbegin\r\n Result := Assigned(FMyController) and IsPluggedIn and not IsCheckedOut;\r\n if Result then\r\n begin\r\n FIsCheckedOut := True;\r\n Inc(FMyController.FNumCheckedOutDevices);\r\n Dec(FMyController.FNumCheckedInDevices);\r\n StartThread;\r\n end;\r\nend;\r\n\r\nfunction TJvHidDevice.GetExtendedAttributes(ReportType: THIDPReportType; DataIndex: Word;\r\n Attributes: PHIDPExtendedAttributes; var LengthAttributes: ULONG): NTSTATUS;\r\nbegin\r\n if Assigned(HidP_GetExtendedAttributes) then\r\n Result := HidP_GetExtendedAttributes(ReportType, DataIndex, FPreparsedData,\r\n Attributes, LengthAttributes)\r\n else\r\n Result := HIDP_STATUS_NOT_IMPLEMENTED;\r\nend;\r\n\r\nfunction TJvHidDevice.InitializeReportForID(ReportType: THIDPReportType; ReportID: Byte;\r\n var Report; ReportLength: ULONG): NTSTATUS;\r\nbegin\r\n if Assigned(HidP_InitializeReportForID) then\r\n Result := HidP_InitializeReportForID(ReportType, ReportID, FPreparsedData, Report, ReportLength)\r\n else\r\n Result := HIDP_STATUS_NOT_IMPLEMENTED;\r\nend;\r\n\r\nfunction TJvHidDevice.GetInputReport(var Report; const Size: ULONG): Boolean;\r\nbegin\r\n Result := False;\r\n if Assigned(HidD_GetInputReport) then\r\n if OpenFile then\r\n Result := HidD_GetInputReport(FHidFileHandle, @Report, Size);\r\nend;\r\n\r\nfunction TJvHidDevice.SetOutputReport(var Report; const Size: ULONG): Boolean;\r\nbegin\r\n Result := False;\r\n if Assigned(HidD_SetOutputReport) then\r\n if OpenFile then\r\n Result := HidD_SetOutputReport(FHidFileHandle, @Report, Size);\r\nend;\r\n\r\n//=== { TJvHidDeviceController } =============================================\r\n\r\nconstructor TJvHidDeviceController.Create(AOwner: TComponent);\r\nconst\r\n cHidGuid: TGUID = '{4d1e55b2-f16f-11cf-88cb-001111000030}';\r\nbegin\r\n inherited Create(AOwner);\r\n FDeviceChangeEvent := nil;\r\n FEnumerateEvent := nil;\r\n FDevUnplugEvent := nil;\r\n FNumCheckedInDevices := 0;\r\n FNumCheckedOutDevices := 0;\r\n FNumUnpluggedDevices := 0;\r\n FDevThreadSleepTime := 100;\r\n FVersion := cHidControllerClassVersion;\r\n FInDeviceChange := False;\r\n\r\n FList := TList.Create;\r\n\r\n if LoadSetupApi then\r\n LoadHid;\r\n if IsHidLoaded then\r\n begin\r\n HidD_GetHidGuid(FHidGuid);\r\n // only hook messages if there is a HID DLL\r\n FHWnd := AllocateHWnd(EventPipe);\r\n // this one executes after Create completed which ensures\r\n // that all global elements like Application.MainForm are initialized\r\n PostMessage(FHWnd, WM_DEVICECHANGE, DBT_DEVNODES_CHANGED, -1);\r\n end\r\n else\r\n FHidGuid := cHidGuid;\r\nend;\r\n\r\n// unplug or kill all controlled TJvHidDevices on controller destruction\r\n\r\ndestructor TJvHidDeviceController.Destroy;\r\nvar\r\n I: Integer;\r\n HidDev: TJvHidDevice;\r\nbegin\r\n // to prevent strange problems\r\n FDeviceChangeEvent := nil;\r\n FDevUnplugEvent := nil;\r\n OnEnumerate := nil;\r\n // unhook event pipe\r\n if IsHidLoaded then\r\n DeallocateHWnd(FHWnd);\r\n\r\n for I := 0 to FList.Count - 1 do\r\n begin\r\n HidDev := FList.Items[I];\r\n with HidDev do\r\n begin\r\n // set to uncontrolled\r\n FMyController := nil;\r\n if IsCheckedOut then\r\n DoUnplug // pull the plug for checked out TJvHidDevices\r\n else\r\n Free; // kill TJvHidDevices which are not checked out\r\n end;\r\n end;\r\n FList.Free;\r\n\r\n if IsHidLoaded then\r\n UnloadSetupApi;\r\n UnloadHid;\r\n\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvHidDeviceController.DoArrival(HidDev: TJvHidDevice);\r\nbegin\r\n if Assigned(FArrivalEvent) then\r\n begin\r\n HidDev.FIsEnumerated := True;\r\n FArrivalEvent(HidDev);\r\n HidDev.FIsEnumerated := False;\r\n end;\r\nend;\r\n\r\nprocedure TJvHidDeviceController.DoRemoval(HidDev: TJvHidDevice);\r\nbegin\r\n if Assigned(FRemovalEvent) then\r\n begin\r\n HidDev.FIsEnumerated := True;\r\n FRemovalEvent(HidDev);\r\n HidDev.FIsEnumerated := False;\r\n end;\r\nend;\r\n\r\n// implement OnDeviceChange event\r\n\r\nprocedure TJvHidDeviceController.DoDeviceChange;\r\nbegin\r\n if Assigned(FDeviceChangeEvent) then\r\n FDeviceChangeEvent(Self);\r\nend;\r\n\r\n// gets all the Windows events/messages directly\r\n\r\nprocedure TJvHidDeviceController.EventPipe(var Msg: TMessage);\r\nbegin\r\n // sort out WM_DEVICECHANGE : DBT_DEVNODES_CHANGED\r\n if not (csDestroying in ComponentState) and\r\n (Msg.Msg = WM_DEVICECHANGE) and (TWMDeviceChange(Msg).Event = DBT_DEVNODES_CHANGED) then\r\n if not FInDeviceChange then\r\n begin\r\n FLParam := Msg.LParam;\r\n FInDeviceChange := True;\r\n DeviceChange;\r\n FInDeviceChange := False;\r\n end;\r\n Msg.Result := DefWindowProc(FHWnd, Msg.Msg, Msg.wParam, Msg.lParam);\r\nend;\r\n\r\n// implements OnDeviceChange event\r\n// it is published to allow calling at design time\r\n\r\nprocedure TJvHidDeviceController.DeviceChange;\r\nvar\r\n I: Integer;\r\n J: Integer;\r\n HidDev: TJvHidDevice;\r\n Changed: Boolean;\r\n NewList: TList;\r\n\r\n // internal worker function to find all HID devices and create their objects\r\n\r\n procedure FillInList;\r\n var\r\n PnPHandle: HDEVINFO;\r\n DevData: TSPDevInfoData;\r\n DeviceInterfaceData: TSPDeviceInterfaceData;\r\n FunctionClassDeviceData: PSPDeviceInterfaceDetailData;\r\n Success: LongBool;\r\n Devn: Integer;\r\n BytesReturned: DWORD;\r\n HidDev: TJvHidDevice;\r\n PnPInfo: TJvHidPnPInfo;\r\n begin\r\n if not IsHidLoaded then\r\n Exit;\r\n\r\n // Get a handle for the Plug and Play node and request currently active HID devices\r\n PnPHandle := SetupDiGetClassDevs(@FHidGuid, nil, 0, DIGCF_PRESENT or DIGCF_DEVICEINTERFACE);\r\n if PnPHandle = Pointer(INVALID_HANDLE_VALUE) then\r\n Exit;\r\n Devn := 0;\r\n repeat\r\n DeviceInterfaceData.cbSize := SizeOf(TSPDeviceInterfaceData);\r\n // Is there a HID device at this table entry?\r\n Success := SetupDiEnumDeviceInterfaces(PnPHandle, nil, FHidGuid, Devn, DeviceInterfaceData);\r\n if Success then\r\n begin\r\n DevData.cbSize := SizeOf(DevData);\r\n BytesReturned := 0;\r\n SetupDiGetDeviceInterfaceDetail(PnPHandle, @DeviceInterfaceData, nil, 0, BytesReturned, @DevData);\r\n if (BytesReturned <> 0) and (GetLastError = ERROR_INSUFFICIENT_BUFFER) then\r\n begin\r\n FunctionClassDeviceData := AllocMem(BytesReturned);\r\n try\r\n FunctionClassDeviceData^.cbSize := SizeOf(TSPDeviceInterfaceDetailData);\r\n if SetupDiGetDeviceInterfaceDetail(PnPHandle, @DeviceInterfaceData,\r\n FunctionClassDeviceData, BytesReturned, BytesReturned, @DevData) then\r\n begin\r\n // fill in PnPInfo of device\r\n PnPInfo := TJvHidPnPInfo.Create(PnPHandle, DevData, PChar(@FunctionClassDeviceData.DevicePath));\r\n // create HID device object and add it to the device list\r\n HidDev := TJvHidDevice.CtlCreate(PnPInfo, Self);\r\n NewList.Add(HidDev);\r\n Inc(Devn);\r\n end;\r\n finally\r\n FreeMem(FunctionClassDeviceData);\r\n end;\r\n end;\r\n end;\r\n until not Success;\r\n SetupDiDestroyDeviceInfoList(PnPHandle);\r\n end;\r\n\r\nbegin\r\n // initial auto message always triggers OnDeviceChange event\r\n Changed := (FLParam = -1);\r\n // get new device list\r\n NewList := TList.Create;\r\n FillInList;\r\n\r\n // unplug devices in FList which are not in NewList\r\n for I := FList.Count - 1 downto 0 do\r\n begin\r\n HidDev := FList.Items[I];\r\n for J := NewList.Count - 1 downto 0 do\r\n if (TJvHidDevice(NewList.Items[J]).PnPInfo.DeviceID = HidDev.PnPInfo.DeviceID) and\r\n HidDev.IsPluggedIn then\r\n begin\r\n HidDev := nil;\r\n Break;\r\n end;\r\n if HidDev <> nil then\r\n begin\r\n HidDev.DoUnplug;\r\n DoRemoval(HidDev);\r\n // delete from list\r\n if not HidDev.IsCheckedOut then\r\n FList.Delete(I);\r\n Changed := True;\r\n end;\r\n end;\r\n\r\n // delete devices from NewList which are in FList\r\n for I := 0 to NewList.Count - 1 do\r\n for J := 0 to FList.Count - 1 do\r\n if (TJvHidDevice(NewList[I]).PnPInfo.DeviceID = TJvHidDevice(FList[J]).PnPInfo.DeviceID) and\r\n TJvHidDevice(FList[J]).IsPluggedIn then\r\n begin\r\n TJvHidDevice(NewList[I]).FMyController := nil; // prevent Free/Destroy from accessing this controller\r\n TJvHidDevice(NewList[I]).Free;\r\n NewList[I] := nil;\r\n Break;\r\n end;\r\n\r\n // add the remains in NewList to FList\r\n for I := 0 to NewList.Count - 1 do\r\n if NewList[I] <> nil then\r\n begin\r\n FList.Add(NewList[I]);\r\n Changed := True;\r\n DoArrival(TJvHidDevice(NewList[I]));\r\n end;\r\n\r\n // throw away helper list\r\n NewList.Free;\r\n\r\n // recount the devices\r\n FNumCheckedInDevices := 0;\r\n FNumCheckedOutDevices := 0;\r\n FNumUnpluggedDevices := 0;\r\n for I := 0 to FList.Count - 1 do\r\n begin\r\n HidDev := FList.Items[I];\r\n Inc(FNumCheckedInDevices, Ord(not HidDev.IsCheckedOut));\r\n Inc(FNumCheckedOutDevices, Ord(HidDev.IsCheckedOut));\r\n Inc(FNumUnpluggedDevices, Ord(not HidDev.IsPluggedIn));\r\n end;\r\n FNumCheckedOutDevices := FNumCheckedOutDevices - FNumUnpluggedDevices;\r\n\r\n if Changed then\r\n DoDeviceChange;\r\nend;\r\n\r\nclass function TJvHidDeviceController.HidVersion: string;\r\nvar\r\n Dummy: DWORD;\r\n Size: UINT;\r\n Buf: array of Byte;\r\n Value: PChar;\r\nbegin\r\n Result := '';\r\n Size := GetFileVersionInfoSize(HidModuleName, Dummy);\r\n if Size > 0 then\r\n begin\r\n SetLength(Buf, Size);\r\n GetFileVersionInfo(HidModuleName, DWORD(INVALID_HANDLE_VALUE), Size, @Buf[0]);\r\n if VerQueryValue(@Buf[0], 'StringFileInfo\\040904E4\\FileVersion', Pointer(Value), Size) then\r\n Result := Value;\r\n end;\r\nend;\r\n\r\n// assign OnDeviceChange and immediately fire it\r\n\r\nprocedure TJvHidDeviceController.SetDeviceChangeEvent(const Notifier: TNotifyEvent);\r\nbegin\r\n if @FDeviceChangeEvent <> @Notifier then\r\n begin\r\n FDeviceChangeEvent := Notifier;\r\n if not (csLoading in ComponentState) then\r\n DeviceChange;\r\n end;\r\nend;\r\n\r\n// implement OnEnumerate event\r\n\r\nfunction TJvHidDeviceController.DoEnumerate(HidDev: TJvHidDevice; Idx: Integer): Boolean;\r\nbegin\r\n Result := False;\r\n if Assigned(FEnumerateEvent) then\r\n begin\r\n HidDev.FIsEnumerated := True;\r\n Result := FEnumerateEvent(HidDev, Idx);\r\n HidDev.FIsEnumerated := False;\r\n if not HidDev.IsCheckedOut then\r\n begin\r\n HidDev.CloseFile;\r\n HidDev.CloseFileEx(omhRead);\r\n HidDev.CloseFileEx(omhWrite);\r\n end;\r\n end;\r\nend;\r\n\r\n// assign OnEnumerate event\r\n\r\nprocedure TJvHidDeviceController.SetEnumerate(const Enumerator: TJvHidEnumerateEvent);\r\nbegin\r\n FEnumerateEvent := Enumerator;\r\nend;\r\n\r\n// assign DevThreadSleepTime\r\n\r\nprocedure TJvHidDeviceController.SetDevThreadSleepTime(const DevTime: Integer);\r\nvar\r\n I: Integer;\r\n Dev: TJvHidDevice;\r\nbegin\r\n if DevTime <> FDevThreadSleepTime then\r\n begin\r\n // change all DevThreadSleepTime with the same old value\r\n for I := 0 to FList.Count - 1 do\r\n begin\r\n Dev := FList.Items[I];\r\n if Dev.ThreadSleepTime = FDevThreadSleepTime then\r\n Dev.ThreadSleepTime := DevTime;\r\n end;\r\n FDevThreadSleepTime := DevTime;\r\n end;\r\nend;\r\n\r\n// assign OnDevData event\r\n\r\nprocedure TJvHidDeviceController.SetDevData(const DataEvent: TJvHidDataEvent);\r\nvar\r\n I: Integer;\r\n Dev: TJvHidDevice;\r\nbegin\r\n if @DataEvent <> @FDevDataEvent then\r\n begin\r\n // change all OnData events with the same old value\r\n for I := 0 to FList.Count - 1 do\r\n begin\r\n Dev := FList.Items[I];\r\n if @Dev.OnData = @FDevDataEvent then\r\n Dev.OnData := DataEvent;\r\n end;\r\n FDevDataEvent := DataEvent;\r\n end;\r\nend;\r\n\r\n// assign OnDevDataError event\r\n\r\nprocedure TJvHidDeviceController.SetDevDataError(const DataErrorEvent: TJvHidDataErrorEvent);\r\nvar\r\n I: Integer;\r\n Dev: TJvHidDevice;\r\nbegin\r\n if @DataErrorEvent <> @FDevDataErrorEvent then\r\n begin\r\n // change all OnDataError events with the same old value\r\n for I := 0 to FList.Count - 1 do\r\n begin\r\n Dev := FList.Items[I];\r\n if @Dev.OnDataError = @FDevDataErrorEvent then\r\n Dev.OnDataError := DataErrorEvent;\r\n end;\r\n FDevDataErrorEvent := DataErrorEvent;\r\n end;\r\nend;\r\n\r\n// assign OnDevUnplug event\r\n\r\nprocedure TJvHidDeviceController.SetDevUnplug(const Unplugger: TJvHidUnplugEvent);\r\nvar\r\n I: Integer;\r\n Dev: TJvHidDevice;\r\nbegin\r\n if @Unplugger <> @FDevUnplugEvent then\r\n begin\r\n // change all OnUnplug events with the same old value\r\n for I := 0 to FList.Count - 1 do\r\n begin\r\n Dev := FList.Items[I];\r\n if @Dev.OnUnplug = @FDevUnplugEvent then\r\n Dev.OnUnplug := Unplugger;\r\n end;\r\n FDevUnplugEvent := Unplugger;\r\n end;\r\nend;\r\n\r\n// send an OnEnumerate event for all plugged HidDevices\r\n// it is explicitly allowed to check out any device in the event\r\n\r\nfunction TJvHidDeviceController.Enumerate: Integer;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := 0;\r\n for I := 0 to FList.Count - 1 do\r\n if TJvHidDevice(FList[I]).IsPluggedIn then\r\n begin\r\n Inc(Result);\r\n if not DoEnumerate(FList[I], I) then\r\n Break;\r\n end;\r\nend;\r\n\r\n// internal worker function to check out a TJvHidDevice\r\n\r\nfunction TJvHidDeviceController.CheckThisOut(var HidDev: TJvHidDevice; Idx: Integer; Check: Boolean): Boolean;\r\nbegin\r\n Result := Check and not TJvHidDevice(FList.Items[Idx]).IsCheckedOut;\r\n if Result then\r\n begin\r\n HidDev := FList[Idx];\r\n HidDev.FIsCheckedOut := True;\r\n Inc(FNumCheckedOutDevices);\r\n Dec(FNumCheckedInDevices);\r\n HidDev.StartThread;\r\n end;\r\nend;\r\n\r\n// method CheckOutByProductName hands out the first HidDevice with a matching ProductName\r\n\r\nfunction TJvHidDeviceController.CheckOutByProductName(var HidDev: TJvHidDevice;\r\n const ProductName: WideString): Boolean;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := False;\r\n HidDev := nil;\r\n if ProductName <> '' then\r\n for I := 0 to FList.Count - 1 do\r\n begin\r\n Result := CheckThisOut(HidDev, I, ProductName = TJvHidDevice(FList[I]).ProductName);\r\n if Result then\r\n Break;\r\n end;\r\nend;\r\n\r\n// method CheckOutByVendorName hands out the first HidDevice with a matching VendorName\r\n\r\nfunction TJvHidDeviceController.CheckOutByVendorName(var HidDev: TJvHidDevice;\r\n const VendorName: WideString): Boolean;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := False;\r\n HidDev := nil;\r\n if VendorName <> '' then\r\n for I := 0 to FList.Count - 1 do\r\n begin\r\n Result := CheckThisOut(HidDev, I, VendorName = TJvHidDevice(FList[I]).VendorName);\r\n if Result then\r\n Break;\r\n end;\r\nend;\r\n\r\n// method CheckOutByCallback hands out the first HidDevice which is accepted by the Check function\r\n// only checked in devices are presented to the Check function\r\n// the device object is usable like during Enumerate\r\n\r\nfunction TJvHidDeviceController.CheckOutByCallback(var HidDev: TJvHidDevice;\r\n Check: TJvHidCheckCallback): Boolean;\r\nvar\r\n I: Integer;\r\n Dev: TJvHidDevice;\r\nbegin\r\n Result := False;\r\n HidDev := nil;\r\n for I := 0 to FList.Count - 1 do\r\n begin\r\n Dev := FList[I];\r\n if not Dev.IsCheckedOut then\r\n begin\r\n Dev.FIsEnumerated := True;\r\n Result := CheckThisOut(HidDev, I, Check(Dev));\r\n Dev.FIsEnumerated := False;\r\n if not Result then\r\n begin\r\n Dev.CloseFile;\r\n Dev.CloseFileEx(omhRead);\r\n Dev.CloseFileEx(omhWrite);\r\n end;\r\n if Result then\r\n Break;\r\n end;\r\n end;\r\nend;\r\n\r\n// method CheckOutByClass hands out the first HidDevice with a matching Class\r\n// Class comes from the registry (examples: 'Mouse', 'Keyboard')\r\n\r\nfunction TJvHidDeviceController.CheckOutByClass(var HidDev: TJvHidDevice;\r\n const ClassName: string): Boolean;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := False;\r\n HidDev := nil;\r\n if ClassName <> '' then\r\n for I := 0 to FList.Count - 1 do\r\n begin\r\n Result := CheckThisOut(HidDev, I, ClassName = TJvHidDevice(FList[I]).PnPInfo.ClassDescr);\r\n if Result then\r\n Break;\r\n end;\r\nend;\r\n\r\n// method CheckOutByID hands out the first HidDevice with a matching VendorID and ProductID\r\n// Pid = -1 matches all ProductIDs\r\n\r\nfunction TJvHidDeviceController.CheckOutByID(var HidDev: TJvHidDevice;\r\n const Vid, Pid: Integer): Boolean;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := False;\r\n HidDev := nil;\r\n for I := 0 to FList.Count - 1 do\r\n begin\r\n Result := CheckThisOut(HidDev, I, (Vid = TJvHidDevice(FList[I]).Attributes.VendorID) and\r\n ((Pid = TJvHidDevice(FList[I]).Attributes.ProductID) or (Pid = -1)));\r\n if Result then\r\n Break;\r\n end;\r\nend;\r\n\r\n// method CheckOutByIndex hands out the HidDevice in the list with the named index\r\n// this is mainly for check out during OnEnumerate\r\n\r\nfunction TJvHidDeviceController.CheckOutByIndex(var HidDev: TJvHidDevice;\r\n const Idx: Integer): Boolean;\r\nbegin\r\n Result := False;\r\n HidDev := nil;\r\n if (Idx >= 0) and (Idx < FList.Count) then\r\n Result := CheckThisOut(HidDev, Idx, True);\r\nend;\r\n\r\n// method CheckOut simply hands out the first available HidDevice in the list\r\n\r\nfunction TJvHidDeviceController.CheckOut(var HidDev: TJvHidDevice): Boolean;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := False;\r\n HidDev := nil;\r\n for I := 0 to FList.Count - 1 do\r\n begin\r\n Result := CheckThisOut(HidDev, I, True);\r\n if Result then\r\n Break;\r\n end;\r\nend;\r\n\r\n// method CheckIn hands a checked out HidDevice back in\r\n\r\nprocedure TJvHidDeviceController.CheckIn(var HidDev: TJvHidDevice);\r\nbegin\r\n if HidDev <> nil then\r\n begin\r\n HidDev.StopThread;\r\n HidDev.CloseFile;\r\n HidDev.CloseFileEx(omhRead);\r\n HidDev.CloseFileEx(omhWrite);\r\n\r\n if HidDev.IsPluggedIn then\r\n begin\r\n HidDev.FIsCheckedOut := False;\r\n Dec(FNumCheckedOutDevices);\r\n Inc(FNumCheckedInDevices);\r\n end\r\n else\r\n HidDev.Free;\r\n HidDev := nil;\r\n end;\r\nend;\r\n\r\nfunction TJvHidDeviceController.CountByClass(const ClassName: string): Integer;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := 0;\r\n for I := 0 to FList.Count - 1 do\r\n if TJvHidDevice(FList[I]).IsPluggedIn and\r\n (ClassName = TJvHidDevice(FList[I]).PnPInfo.ClassDescr) then\r\n Inc(Result);\r\nend;\r\n\r\nfunction TJvHidDeviceController.CountByID(const Vid, Pid: Integer): Integer;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := 0;\r\n for I := 0 to FList.Count - 1 do\r\n if TJvHidDevice(FList[I]).IsPluggedIn and\r\n (Vid = TJvHidDevice(FList[I]).Attributes.VendorID) and\r\n ((Pid = TJvHidDevice(FList[I]).Attributes.ProductID) or (Pid = -1)) then\r\n Inc(Result);\r\nend;\r\n\r\nfunction TJvHidDeviceController.CountByProductName(const ProductName: WideString): Integer;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := 0;\r\n for I := 0 to FList.Count - 1 do\r\n if TJvHidDevice(FList[I]).IsPluggedIn and\r\n (ProductName = TJvHidDevice(FList[I]).ProductName) then\r\n Inc(Result);\r\nend;\r\n\r\nfunction TJvHidDeviceController.CountByVendorName(const VendorName: WideString): Integer;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := 0;\r\n for I := 0 to FList.Count - 1 do\r\n if TJvHidDevice(FList[I]).IsPluggedIn and\r\n (VendorName = TJvHidDevice(FList[I]).VendorName) then\r\n Inc(Result);\r\nend;\r\n\r\nfunction TJvHidDeviceController.CountByCallback(Check: TJvHidCheckCallback): Integer;\r\nvar\r\n I: Integer;\r\n Dev: TJvHidDevice;\r\nbegin\r\n Result := 0;\r\n for I := 0 to FList.Count - 1 do\r\n begin\r\n if TJvHidDevice(FList[I]).IsPluggedIn then\r\n begin\r\n Dev := FList[I];\r\n Dev.FIsEnumerated := True;\r\n if Check(Dev) then\r\n Inc(Result);\r\n Dev.FIsEnumerated := False;\r\n if not Dev.IsCheckedOut then\r\n begin\r\n Dev.CloseFile;\r\n Dev.CloseFileEx(omhRead);\r\n Dev.CloseFileEx(omhWrite);\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\n//============================================================================\r\n\r\n// a helper function to check the return values just\r\n// like Win32Check\r\n// the functions return the parameter to be transparent\r\n\r\nfunction HidCheck(const RetVal: NTSTATUS): NTSTATUS;\r\nbegin\r\n if RetVal <> HIDP_STATUS_SUCCESS then\r\n HidError(RetVal);\r\n Result := RetVal;\r\nend;\r\n\r\nfunction HidCheck(const RetVal: LongBool): LongBool;\r\nbegin\r\n if not RetVal then\r\n raise EHidClientError.CreateRes(@RsEHIDBooleanError);\r\n Result := RetVal;\r\nend;\r\n\r\nfunction HidError(const RetVal: NTSTATUS): NTSTATUS;\r\nvar\r\n ErrBuf: string;\r\nbegin\r\n ErrBuf := HidErrorString(RetVal);\r\n // only react to HID errors\r\n if ErrBuf <> '' then\r\n raise EHidClientError.Create(ErrBuf);\r\n Result := RetVal;\r\nend;\r\n\r\nfunction HidErrorString(const RetVal: NTSTATUS): string;\r\nbegin\r\n Result := '';\r\n // only check HID errors\r\n if ((RetVal and NTSTATUS($00FF0000)) = HIDP_STATUS_SUCCESS) and\r\n ((RetVal and NTSTATUS($C0000000)) <> 0) then\r\n begin\r\n case RetVal of\r\n HIDP_STATUS_NULL:\r\n Result := RsHIDP_STATUS_NULL;\r\n HIDP_STATUS_INVALID_PREPARSED_DATA:\r\n Result := RsHIDP_STATUS_INVALID_PREPARSED_DATA;\r\n HIDP_STATUS_INVALID_REPORT_TYPE:\r\n Result := RsHIDP_STATUS_INVALID_REPORT_TYPE;\r\n HIDP_STATUS_INVALID_REPORT_LENGTH:\r\n Result := RsHIDP_STATUS_INVALID_REPORT_LENGTH;\r\n HIDP_STATUS_USAGE_NOT_FOUND:\r\n Result := RsHIDP_STATUS_USAGE_NOT_FOUND;\r\n HIDP_STATUS_VALUE_OUT_OF_RANGE:\r\n Result := RsHIDP_STATUS_VALUE_OUT_OF_RANGE;\r\n HIDP_STATUS_BAD_LOG_PHY_VALUES:\r\n Result := RsHIDP_STATUS_BAD_LOG_PHY_VALUES;\r\n HIDP_STATUS_BUFFER_TOO_SMALL:\r\n Result := RsHIDP_STATUS_BUFFER_TOO_SMALL;\r\n HIDP_STATUS_INTERNAL_ERROR:\r\n Result := RsHIDP_STATUS_INTERNAL_ERROR;\r\n HIDP_STATUS_I8042_TRANS_UNKNOWN:\r\n Result := RsHIDP_STATUS_I8042_TRANS_UNKNOWN;\r\n HIDP_STATUS_INCOMPATIBLE_REPORT_ID:\r\n Result := RsHIDP_STATUS_INCOMPATIBLE_REPORT_ID;\r\n HIDP_STATUS_NOT_VALUE_ARRAY:\r\n Result := RsHIDP_STATUS_NOT_VALUE_ARRAY;\r\n HIDP_STATUS_IS_VALUE_ARRAY:\r\n Result := RsHIDP_STATUS_IS_VALUE_ARRAY;\r\n HIDP_STATUS_DATA_INDEX_NOT_FOUND:\r\n Result := RsHIDP_STATUS_DATA_INDEX_NOT_FOUND;\r\n HIDP_STATUS_DATA_INDEX_OUT_OF_RANGE:\r\n Result := RsHIDP_STATUS_DATA_INDEX_OUT_OF_RANGE;\r\n HIDP_STATUS_BUTTON_NOT_PRESSED:\r\n Result := RsHIDP_STATUS_BUTTON_NOT_PRESSED;\r\n HIDP_STATUS_REPORT_DOES_NOT_EXIST:\r\n Result := RsHIDP_STATUS_REPORT_DOES_NOT_EXIST;\r\n HIDP_STATUS_NOT_IMPLEMENTED:\r\n Result := RsHIDP_STATUS_NOT_IMPLEMENTED;\r\n else\r\n Result := Format(RsUnknownHIDFmt, [RetVal]);\r\n end;\r\n Result := RsHIDErrorPrefix + Result;\r\n end;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvHint.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvHint.PAS, released on 2002-07-04.\r\n\r\nThe Initial Developers of the Original Code are: Andrei Prygounkov \r\nCopyright (c) 1999, 2002 Andrei Prygounkov\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\ncomponent : TJvHint\r\ndescription : Custom activated hint\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvHint.pas 13138 2011-10-26 23:17:50Z jfudickar $\r\n\r\nunit JvHint;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n SysUtils, Classes,\r\n Windows, Controls, Forms, ExtCtrls,\r\n JvHtControls, JvTypes;\r\n\r\ntype\r\n TJvHintWindow = class(THintWindow)\r\n public\r\n property Caption;\r\n end;\r\n TJvHintWindowClass = class of TJvHintWindow;\r\n\r\n TJvHintState = (tmBeginShow, tmShowing, tmStopped);\r\n \r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvHint = class(TComponent)\r\n private\r\n FAutoHide: Boolean;\r\n protected\r\n // (rom) definitely needs cleanup here bad structuring\r\n R: TRect;\r\n Area: TRect;\r\n State: TJvHintState;\r\n Txt: THintString;\r\n HintWindow: TJvHintWindow;\r\n TimerHint: TTimer;\r\n FDelay: Integer;\r\n procedure TimerHintTimer(Sender: TObject);\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n procedure ActivateHint(AArea: TRect; ATxt: THintString);\r\n procedure ActivateHintAt(AArea: TRect; ATxt: THintString; ScreenPos: TPoint);\r\n procedure CancelHint;\r\n published\r\n property AutoHide: Boolean read FAutoHide write FAutoHide default True;\r\n end;\r\n\r\n TJvHTHintWindow = class(THintWindow)\r\n private\r\n HtLabel: TJvHTLabel;\r\n protected\r\n procedure Paint; override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n function CalcHintRect(MaxWidth: Integer;\r\n const AHint: THintString; AData: Pointer): TRect; override;\r\n end;\r\n\r\nprocedure RegisterHtHints;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvHint.pas $';\r\n Revision: '$Revision: 13138 $';\r\n Date: '$Date: 2011-10-27 01:17:50 +0200 (jeu. 27 oct. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n Math,\r\n JvResources;\r\n\r\n//=== { TJvHint } ============================================================\r\n\r\nconstructor TJvHint.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n TimerHint := TTimer.Create(Self);\r\n TimerHint.Enabled := False;\r\n TimerHint.Interval := 50;\r\n TimerHint.OnTimer := TimerHintTimer;\r\n HintWindow := TJvHintWindowClass.Create(Self);\r\n FAutoHide := True;\r\nend;\r\n\r\ndestructor TJvHint.Destroy;\r\nbegin\r\n TimerHint.Free;\r\n HintWindow.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvHint.ActivateHint(AArea: TRect; ATxt: THintString);\r\nvar\r\n P: TPoint;\r\nbegin\r\n GetCursorPos(P);\r\n Inc(P.Y, 20);\r\n ActivateHintAt(AArea, ATxt, P);\r\nend;\r\n\r\nprocedure TJvHint.ActivateHintAt(AArea: TRect; ATxt: THintString; ScreenPos: TPoint);\r\nvar\r\n P: TPoint;\r\nbegin\r\n Area := AArea;\r\n if ATxt = '' then\r\n begin\r\n CancelHint;\r\n Exit;\r\n end\r\n else\r\n Txt := ATxt;\r\n GetCursorPos(P);\r\n if not PtInRect(Area, P) then\r\n begin\r\n if IsWindowVisible(HintWindow.Handle) then\r\n ShowWindow(HintWindow.Handle, SW_HIDE);\r\n Exit;\r\n end;\r\n if HintWindow.Caption <> Txt then\r\n begin\r\n R := HintWindow.CalcHintRect(Screen.Width, Txt, nil);\r\n R.Top := ScreenPos.Y;\r\n R.Left := ScreenPos.X;\r\n Inc(R.Bottom, R.Top);\r\n Inc(R.Right, R.Left);\r\n State := tmBeginShow;\r\n TimerHint.Enabled := True;\r\n end;\r\nend;\r\n\r\nprocedure TJvHint.TimerHintTimer(Sender: TObject);\r\nvar\r\n P: TPoint;\r\n bPoint, bDelay: Boolean;\r\n Delay: Integer;\r\n HintPause: Integer;\r\nbegin\r\n HintWindow.Color := Application.HintColor;\r\n Delay := FDelay * Integer(TimerHint.Interval);\r\n case State of\r\n tmBeginShow:\r\n begin\r\n GetCursorPos(P);\r\n bPoint := not PtInRect(Area, P);\r\n if bPoint then\r\n begin\r\n State := tmStopped;\r\n Exit;\r\n end;\r\n if IsWindowVisible(HintWindow.Handle) then\r\n HintPause := Application.HintShortPause\r\n else\r\n HintPause := Application.HintPause;\r\n if Delay >= HintPause then\r\n begin\r\n HintWindow.ActivateHint(R, Txt);\r\n FDelay := 0;\r\n State := tmShowing;\r\n end\r\n else\r\n Inc(FDelay);\r\n end;\r\n tmShowing:\r\n begin\r\n GetCursorPos(P);\r\n bDelay := FAutoHide and (Delay > Application.HintHidePause);\r\n bPoint := not PtInRect(Area, P);\r\n if bPoint or bDelay then\r\n begin\r\n if IsWindowVisible(HintWindow.Handle) then\r\n ShowWindow(HintWindow.Handle, SW_HIDE);\r\n FDelay := 0;\r\n if bPoint then\r\n HintWindow.Caption := RsHintCaption;\r\n State := tmStopped;\r\n end\r\n else\r\n Inc(FDelay);\r\n end;\r\n tmStopped:\r\n begin\r\n FDelay := 0;\r\n GetCursorPos(P);\r\n bPoint := not PtInRect(Area, P);\r\n if IsWindowVisible(HintWindow.Handle) then\r\n ShowWindow(HintWindow.Handle, SW_HIDE);\r\n if bPoint then\r\n begin\r\n HintWindow.Caption := RsHintCaption;\r\n TimerHint.Enabled := False;\r\n end;\r\n end;\r\n end; \r\nend;\r\n\r\nprocedure TJvHint.CancelHint;\r\nbegin\r\n if IsWindowVisible(HintWindow.Handle) then\r\n ShowWindow(HintWindow.Handle, SW_HIDE);\r\n HintWindow.Caption := '';\r\nend;\r\n\r\n//=== { TJvHTHintWindow } ====================================================\r\n\r\nconstructor TJvHTHintWindow.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n HtLabel := TJvHTLabel.Create(Self);\r\n HtLabel.Parent := Self;\r\n HtLabel.SetBounds(2, 2, 0, 0);\r\nend;\r\n\r\nprocedure TJvHTHintWindow.Paint;\r\nbegin\r\nend;\r\n\r\nfunction TJvHTHintWindow.CalcHintRect(MaxWidth: Integer;\r\n const AHint: THintString; AData: Pointer): TRect;\r\nbegin\r\n HtLabel.Caption := AHint;\r\n Result := Bounds(0, 0, HtLabel.Width + 6, HtLabel.Height + 2);\r\n if Application.HintHidePause > 0 then\r\n Application.HintHidePause :=\r\n Max(2500, // default\r\n Length(ItemHtPlain(AHint)) *\r\n (1000 div 20)); // 20 symbols per second\r\nend;\r\n\r\nprocedure RegisterHtHints;\r\nbegin\r\n if Application.ShowHint then\r\n begin\r\n Application.ShowHint := False;\r\n HintWindowClass := TJvHTHintWindow;\r\n Application.ShowHint := True;\r\n end\r\n else\r\n HintWindowClass := TJvHTHintWindow;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvHints.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvHints.PAS, released on 2002-07-04.\r\n\r\nThe Initial Developers of the Original Code are: Fedor Koshevnikov, Igor Pavluk and Serge Korolev\r\nCopyright (c) 1997, 1998 Fedor Koshevnikov, Igor Pavluk and Serge Korolev\r\nCopyright (c) 2001,2002 SGB Software\r\nAll Rights Reserved.\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvHints.pas 12806 2010-06-12 17:27:30Z uschuster $\r\n\r\nunit JvHints;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, Messages, Graphics, Controls, Forms, Classes,\r\n JvTypes;\r\n\r\ntype\r\n THintStyle = (hsRectangle, hsRoundRect, hsEllipse);\r\n THintPos = (hpTopRight, hpTopLeft, hpBottomRight, hpBottomLeft);\r\n THintShadowSize = 0..15;\r\n\r\n TJvHintWindow = class(THintWindow)\r\n private\r\n FSrcImage: TBitmap;\r\n FImage: TBitmap;\r\n FPos: THintPos;\r\n FRect: TRect;\r\n FTextRect: TRect;\r\n FTileSize: TPoint;\r\n FRoundFactor: Integer;\r\n procedure WMEraseBkgnd(var Msg: TMessage); message WM_ERASEBKGND;\r\n procedure WMNCPaint(var Msg: TMessage); message WM_NCPAINT;\r\n function CreateRegion(Shade: Boolean): HRGN;\r\n procedure FillRegion(Rgn: HRGN; Shade: Boolean);\r\n protected\r\n procedure CreateParams(var Params: TCreateParams); override;\r\n procedure Paint; override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n procedure ActivateHint(Rect: TRect;\r\n const AHint: THintString); override;\r\n procedure ActivateHintData(Rect: TRect;\r\n const AHint: THintString; AData: Pointer); override;\r\n function CalcHintRect(MaxWidth: Integer;\r\n const AHint: THintString; AData: Pointer): TRect;override;\r\n end;\r\n\r\nprocedure SetHintStyle(Style: THintStyle; ShadowSize: THintShadowSize;\r\n Tail: Boolean; Alignment: TAlignment);\r\nprocedure SetStandardHints;\r\nprocedure RegisterHintWindow(AClass: THintWindowClass);\r\nfunction GetHintControl: TControl;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvHints.pas $';\r\n Revision: '$Revision: 12806 $';\r\n Date: '$Date: 2010-06-12 19:27:30 +0200 (sam. 12 juin 2010) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n SysUtils, Math,\r\n JvJCLUtils;\r\n\r\nvar\r\n HintStyle: THintStyle = hsRectangle;\r\n HintShadowSize: Integer = 0;\r\n HintTail: Boolean = False;\r\n HintAlignment: TAlignment = taLeftJustify;\r\n\r\nprocedure RegisterHintWindow(AClass: THintWindowClass);\r\nbegin\r\n HintWindowClass := AClass;\r\n with Application do\r\n if ShowHint then\r\n begin\r\n ShowHint := False;\r\n ShowHint := True;\r\n end;\r\nend;\r\n\r\nprocedure SetStandardHints;\r\nbegin\r\n RegisterHintWindow(THintWindow);\r\nend;\r\n\r\nprocedure SetHintStyle(Style: THintStyle; ShadowSize: THintShadowSize;\r\n Tail: Boolean; Alignment: TAlignment);\r\nbegin\r\n HintStyle := Style;\r\n HintShadowSize := ShadowSize;\r\n HintTail := Tail;\r\n HintAlignment := Alignment;\r\n RegisterHintWindow(TJvHintWindow);\r\nend;\r\n\r\nfunction GetHintControl: TControl;\r\nvar\r\n CursorPos: TPoint;\r\nbegin\r\n GetCursorPos(CursorPos);\r\n Result := FindDragTarget(CursorPos, True);\r\n while (Result <> nil) and not Result.ShowHint do\r\n Result := Result.Parent;\r\n if (Result <> nil) and (csDesigning in Result.ComponentState) then\r\n Result := nil;\r\nend;\r\n\r\n\r\nprocedure StandardHintFont(AFont: TFont);\r\nvar\r\n NonClientMetrics: TNonClientMetrics;\r\nbegin\r\n {$IFDEF RTL210_UP}\r\n NonClientMetrics.cbSize := TNonClientMetrics.SizeOf;\r\n {$ELSE}\r\n NonClientMetrics.cbSize := SizeOf(NonClientMetrics);\r\n {$ENDIF RTL210_UP}\r\n if SystemParametersInfo(SPI_GETNONCLIENTMETRICS, NonClientMetrics.cbSize, @NonClientMetrics, 0) then\r\n AFont.Handle := CreateFontIndirect(NonClientMetrics.lfStatusFont)\r\n else\r\n begin\r\n AFont.Name := 'MS Sans Serif';\r\n AFont.Size := 8;\r\n end;\r\n AFont.Color := clInfoText;\r\nend;\r\n\r\n\r\n\r\n\r\nconstructor TJvHintWindow.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n StandardHintFont(Canvas.Font);\r\n FImage := TBitmap.Create;\r\n FSrcImage := TBitmap.Create;\r\nend;\r\n\r\ndestructor TJvHintWindow.Destroy;\r\nbegin\r\n FSrcImage.Free;\r\n FImage.Free;\r\n inherited Destroy;\r\nend;\r\n\r\n\r\n\r\nprocedure TJvHintWindow.CreateParams(var Params: TCreateParams);\r\nbegin\r\n inherited CreateParams(Params);\r\n Params.Style := Params.Style and not WS_BORDER;\r\nend;\r\n\r\nprocedure TJvHintWindow.WMNCPaint(var Msg: TMessage);\r\nbegin\r\nend;\r\n\r\nprocedure TJvHintWindow.WMEraseBkgnd(var Msg: TMessage);\r\nbegin\r\n Msg.Result := 1;\r\nend;\r\n\r\n\r\n\r\nfunction TJvHintWindow.CreateRegion(Shade: Boolean): HRGN;\r\nvar\r\n R: TRect;\r\n W, TileOffs: Integer;\r\n Tail, Dest: HRGN;\r\n P: TPoint;\r\n\r\n function CreatePolyRgn(const Points: array of TPoint): HRGN;\r\n begin\r\n Result := CreatePolygonRgn(Points[0], High(Points) + 1, WINDING);\r\n end;\r\n\r\nbegin\r\n R := FRect;\r\n Result := 0;\r\n if Shade then\r\n OffsetRect(R, HintShadowSize, HintShadowSize);\r\n case HintStyle of\r\n hsRoundRect:\r\n Result := CreateRoundRectRgn(R.Left, R.Top, R.Right, R.Bottom,\r\n FRoundFactor, FRoundFactor);\r\n hsEllipse:\r\n Result := CreateEllipticRgnIndirect(R);\r\n hsRectangle:\r\n Result := CreateRectRgnIndirect(R);\r\n end;\r\n if HintTail then\r\n begin\r\n R := FTextRect;\r\n GetCursorPos(P);\r\n TileOffs := 0;\r\n if FPos in [hpTopLeft, hpBottomLeft] then\r\n TileOffs := Width;\r\n if Shade then\r\n begin\r\n OffsetRect(R, HintShadowSize, HintShadowSize);\r\n Inc(TileOffs, HintShadowSize);\r\n end;\r\n W := Min(Max(8, Min(RectWidth(R), RectHeight(R)) div 4), RectWidth(R) div 2);\r\n case FPos of\r\n hpTopRight:\r\n Tail := CreatePolyRgn([Point(TileOffs, Height - HintShadowSize),\r\n Point(R.Left + W div 4, R.Bottom), Point(R.Left + 2 * W, R.Bottom)]);\r\n hpTopLeft:\r\n Tail := CreatePolyRgn([Point(TileOffs, Height - HintShadowSize),\r\n Point(R.Right - W div 4, R.Bottom), Point(R.Right - 2 * W, R.Bottom)]);\r\n hpBottomRight:\r\n Tail := CreatePolyRgn([Point(TileOffs, 0),\r\n Point(R.Left + W div 4, R.Top), Point(R.Left + 2 * W, R.Top)]);\r\n else\r\n Tail := CreatePolyRgn([Point(TileOffs, 0),\r\n Point(R.Right - W div 4, R.Top), Point(R.Right - 2 * W, R.Top)]);\r\n end;\r\n try\r\n Dest := Result;\r\n Result := CreateRectRgnIndirect(R);\r\n try\r\n CombineRgn(Result, Dest, Tail, RGN_OR);\r\n finally\r\n if Dest <> 0 then\r\n DeleteObject(Dest);\r\n end;\r\n finally\r\n DeleteObject(Tail);\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvHintWindow.FillRegion(Rgn: HRGN; Shade: Boolean);\r\nbegin\r\n if Shade then\r\n begin\r\n FImage.Canvas.Brush.Bitmap :=\r\n AllocPatternBitmap(clBtnFace, clWindowText);\r\n FImage.Canvas.Pen.Style := psClear;\r\n end\r\n else\r\n begin\r\n FImage.Canvas.Pen.Style := psSolid;\r\n FImage.Canvas.Brush.Color := Color;\r\n end;\r\n try\r\n PaintRgn(FImage.Canvas.Handle, Rgn);\r\n if not Shade then\r\n begin\r\n FImage.Canvas.Brush.Color := Font.Color;\r\n if (HintStyle = hsRectangle) and not HintTail then\r\n DrawEdge(FImage.Canvas.Handle, FRect, BDR_RAISEDOUTER, BF_RECT)\r\n else\r\n FrameRgn(FImage.Canvas.Handle, Rgn, FImage.Canvas.Brush.Handle, 1, 1);\r\n end;\r\n finally\r\n if Shade then\r\n begin\r\n FImage.Canvas.Brush.Bitmap := nil;\r\n FImage.Canvas.Pen.Style := psSolid;\r\n end;\r\n FImage.Canvas.Brush.Color := Color;\r\n end;\r\nend;\r\n\r\nprocedure TJvHintWindow.Paint;\r\nvar\r\n R: TRect;\r\n FShadeRgn, FRgn: HRGN;\r\n\r\n procedure PaintText(R: TRect);\r\n const\r\n Flag: array [TAlignment] of Longint = (DT_LEFT, DT_RIGHT, DT_CENTER);\r\n begin\r\n DrawText(FImage.Canvas, Caption, -1, R,\r\n DT_NOPREFIX or DT_WORDBREAK or Flag[HintAlignment]);\r\n end;\r\n\r\nbegin\r\n R := ClientRect;\r\n FImage.Handle := CreateCompatibleBitmap(Canvas.Handle,\r\n RectWidth(ClientRect), RectHeight(ClientRect));\r\n FImage.Canvas.Font := Self.Canvas.Font;\r\n if (HintStyle <> hsRectangle) or (HintShadowSize > 0) or HintTail then\r\n FImage.Canvas.Draw(0, 0, FSrcImage);\r\n FRgn := CreateRegion(False);\r\n FShadeRgn := CreateRegion(True);\r\n try\r\n FillRegion(FShadeRgn, True);\r\n FillRegion(FRgn, False);\r\n finally\r\n DeleteObject(FShadeRgn);\r\n DeleteObject(FRgn);\r\n end;\r\n R := FTextRect;\r\n if HintAlignment = taLeftJustify then\r\n Inc(R.Left, 2);\r\n PaintText(R);\r\n Canvas.Draw(0, 0, FImage);\r\nend;\r\n\r\nprocedure TJvHintWindow.ActivateHint(Rect: TRect;\r\n const AHint: THintString);\r\nvar\r\n R: TRect;\r\n ScreenDC: HDC;\r\n P: TPoint;\r\nbegin\r\n Caption := AHint;\r\n GetCursorPos(P);\r\n FPos := hpBottomRight;\r\n R := CalcHintRect(Screen.Width, AHint, nil);\r\n OffsetRect(R, Rect.Left - R.Left, Rect.Top - R.Top);\r\n Rect := R;\r\n BoundsRect := Rect;\r\n\r\n if HintTail then\r\n begin\r\n Rect.Top := P.Y - Height - 3;\r\n if Rect.Top < 0 then\r\n Rect.Top := BoundsRect.Top\r\n else\r\n Rect.Bottom := Rect.Top + RectHeight(BoundsRect);\r\n\r\n Rect.Left := P.X + 1;\r\n if Rect.Left < 0 then\r\n Rect.Left := BoundsRect.Left\r\n else\r\n Rect.Right := Rect.Left + RectWidth(BoundsRect);\r\n end;\r\n\r\n if Rect.Top + Height > Screen.Height then\r\n begin\r\n Rect.Top := Screen.Height - Height;\r\n if Rect.Top <= P.Y then\r\n Rect.Top := P.Y - Height - 3;\r\n end;\r\n if Rect.Left + Width > Screen.Width then\r\n begin\r\n Rect.Left := Screen.Width - Width;\r\n if Rect.Left <= P.X then\r\n Rect.Left := P.X - Width - 3;\r\n end;\r\n if Rect.Left < 0 then\r\n begin\r\n Rect.Left := 0;\r\n if Rect.Left + Width >= P.X then\r\n Rect.Left := P.X - Width - 1;\r\n end;\r\n if Rect.Top < 0 then\r\n begin\r\n Rect.Top := 0;\r\n if Rect.Top + Height >= P.Y then\r\n Rect.Top := P.Y - Height - 1;\r\n end;\r\n\r\n if (HintStyle <> hsRectangle) or (HintShadowSize > 0) or HintTail then\r\n begin\r\n FPos := hpBottomRight;\r\n if Rect.Top + Height < P.Y then\r\n FPos := hpTopRight;\r\n if Rect.Left + Width < P.X then\r\n begin\r\n if FPos = hpBottomRight then\r\n FPos := hpBottomLeft\r\n else\r\n FPos := hpTopLeft;\r\n end;\r\n if HintTail then\r\n begin\r\n if FPos in [hpBottomRight, hpBottomLeft] then\r\n begin\r\n OffsetRect(FRect, 0, FTileSize.Y);\r\n OffsetRect(FTextRect, 0, FTileSize.Y);\r\n end;\r\n if FPos in [hpBottomRight, hpTopRight] then\r\n begin\r\n OffsetRect(FRect, FTileSize.X, 0);\r\n OffsetRect(FTextRect, FTileSize.X, 0);\r\n end;\r\n end;\r\n if HandleAllocated then\r\n begin\r\n SetWindowPos(Handle, HWND_BOTTOM, 0, 0, 0, 0,\r\n SWP_HIDEWINDOW or SWP_NOACTIVATE or SWP_NOSIZE or SWP_NOMOVE);\r\n if Screen.ActiveForm <> nil then\r\n UpdateWindow(Screen.ActiveForm.Handle);\r\n end;\r\n ScreenDC := GetDC(HWND_DESKTOP);\r\n try\r\n with FSrcImage do\r\n begin\r\n Width := RectWidth(BoundsRect);\r\n Height := RectHeight(BoundsRect);\r\n BitBlt(Canvas.Handle, 0, 0, Width, Height, ScreenDC,\r\n Rect.Left, Rect.Top, SRCCOPY);\r\n end;\r\n finally\r\n ReleaseDC(HWND_DESKTOP, ScreenDC);\r\n end;\r\n end;\r\n SetWindowPos(Handle, HWND_TOPMOST, Rect.Left, Rect.Top, 0, 0,\r\n SWP_SHOWWINDOW or SWP_NOACTIVATE or SWP_NOSIZE);\r\nend;\r\n\r\nfunction TJvHintWindow.CalcHintRect(MaxWidth: Integer;\r\n const AHint: THintString;\r\n AData: Pointer): TRect;\r\nconst\r\n Flag: array [TAlignment] of Longint = (DT_LEFT, DT_RIGHT, DT_CENTER);\r\nvar\r\n A: Integer;\r\n X, Y, Factor: Double;\r\nbegin\r\n Result := Rect(0, 0, MaxWidth, 0);\r\n DrawText(Canvas, AHint, -1, Result,\r\n DT_CALCRECT or DT_WORDBREAK or DT_NOPREFIX or Flag[HintAlignment] or DrawTextBiDiModeFlagsReadingOnly );\r\n Inc(Result.Right, 8);\r\n Inc(Result.Bottom, 4);\r\n FRect := Result;\r\n FTextRect := Result;\r\n InflateRect(FTextRect, -1, -1);\r\n case HintAlignment of\r\n taCenter:\r\n OffsetRect(FTextRect, -1, 0);\r\n taRightJustify:\r\n OffsetRect(FTextRect, -4, 0);\r\n end;\r\n FRoundFactor := Max(6, Min(RectWidth(Result), RectHeight(Result)) div 4);\r\n if HintStyle = hsRoundRect then\r\n InflateRect(FRect, FRoundFactor div 4, FRoundFactor div 4)\r\n else\r\n if HintStyle = hsEllipse then\r\n begin\r\n X := RectWidth(FRect) / 2;\r\n Y := RectHeight(FRect) / 2;\r\n if (X <> 0) and (Y <> 0) then\r\n begin\r\n Factor := Round(Y / 3);\r\n A := Round(Sqrt((Sqr(X) * Sqr(Y + Factor)) / (Sqr(Y + Factor) - Sqr(Y))));\r\n InflateRect(FRect, A - Round(X), Round(Factor));\r\n end;\r\n end;\r\n Result := FRect;\r\n OffsetRect(FRect, -Result.Left, -Result.Top);\r\n OffsetRect(FTextRect, -Result.Left, -Result.Top);\r\n Inc(Result.Right, HintShadowSize);\r\n Inc(Result.Bottom, HintShadowSize);\r\n if HintTail then\r\n begin\r\n FTileSize.Y := Max(14, Min(RectWidth(FTextRect), RectHeight(FTextRect)) div 2);\r\n FTileSize.X := FTileSize.Y - 8;\r\n Inc(Result.Right, FTileSize.X);\r\n Inc(Result.Bottom, FTileSize.Y);\r\n end;\r\nend;\r\n\r\nprocedure TJvHintWindow.ActivateHintData(Rect: TRect;\r\n const AHint: THintString; AData: Pointer);\r\nbegin\r\n ActivateHint(Rect, AHint);\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvHotKey.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvHotKey.PAS, released on 2001-02-28.\r\n\r\nThe Initial Developer of the Original Code is Sbastien Buysse [sbuysse att buypin dott com]\r\nPortions created by Sbastien Buysse are Copyright (C) 2001 Sbastien Buysse.\r\nAll Rights Reserved.\r\n\r\nContributor(s): Michael Beck [mbeck att bigfoot dott com].\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvHotKey.pas 13155 2011-11-06 12:31:20Z ahuser $\r\n\r\nunit JvHotKey;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n Controls, Classes,\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n JvExComCtrls;\r\n\r\ntype\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvHotKey = class(TJvExHotKey)\r\n published\r\n property BevelEdges;\r\n property BevelInner;\r\n property BevelKind default bkNone;\r\n property BevelOuter;\r\n property HintColor;\r\n property OnMouseEnter;\r\n property OnMouseLeave;\r\n property OnParentColorChange;\r\n property Color;\r\n property Font;\r\n property ParentFont;\r\n property ParentColor;\r\n property OnKeyDown;\r\n property OnKeyPress;\r\n property OnKeyUp;\r\n property OnClick;\r\n property OnDblClick;\r\n property OnDragDrop;\r\n property OnDragOver;\r\n property OnEndDrag;\r\n property OnStartDrag;\r\n property OnResize;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvHotKey.pas $';\r\n Revision: '$Revision: 13155 $';\r\n Date: '$Date: 2011-11-06 13:31:20 +0100 (dim. 06 nov. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvHotTrackPersistent.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvButtonPersistent.PAS, released on 2007-11-20.\r\n\r\nThe Initial Developer of the Original Code is dejoy den [dejoybbs att gmail dott com]\r\nAll Rights Reserved.\r\n\r\nContributor(s): dejoy.\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvHotTrackPersistent.pas 13138 2011-10-26 23:17:50Z jfudickar $\r\n\r\nunit JvHotTrackPersistent;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Classes, Graphics,\r\n JvTypes;\r\n\r\ntype\r\n TJvHotTrackOptionsClass = class of TJvHotTrackOptions;\r\n\r\n TJvHotTrackOptions = class(TJvPersistentProperty)\r\n private\r\n FEnabled: Boolean;\r\n FFrameVisible: Boolean;\r\n FColor: TColor;\r\n FFrameColor: TColor;\r\n procedure SetColor(Value: TColor);\r\n procedure SetEnabled(Value: Boolean);\r\n procedure SetFrameColor(Value: TColor);\r\n procedure SetFrameVisible(Value: Boolean);\r\n public\r\n constructor Create(AOwner: TPersistent); override;\r\n procedure Assign(Source: TPersistent); override;\r\n published\r\n property Enabled: Boolean read FEnabled write SetEnabled default False;\r\n property Color: TColor read FColor write SetColor default DefaultHotTrackColor;\r\n property FrameVisible: Boolean read FFrameVisible write SetFrameVisible default False;\r\n property FrameColor: TColor read FFrameColor write SetFrameColor default DefaultHotTrackFrameColor;\r\n end;\r\n\r\n { IJvHotTrack specifies whether Controls are highlighted when the mouse passes over them }\r\n IJvHotTrack = interface\r\n ['{8F1B40FB-D8E3-46FE-A7A3-21CE4B199A8F}']\r\n\r\n function GetHotTrack: Boolean;\r\n function GetHotTrackFont: TFont;\r\n function GetHotTrackFontOptions: TJvTrackFontOptions;\r\n function GetHotTrackOptions: TJvHotTrackOptions;\r\n\r\n procedure SetHotTrack(Value: Boolean);\r\n procedure SetHotTrackFont(Value: TFont);\r\n procedure SetHotTrackFontOptions(Value: TJvTrackFontOptions);\r\n procedure SetHotTrackOptions(Value: TJvHotTrackOptions);\r\n procedure Assign(Source: IJvHotTrack);\r\n\r\n property HotTrack: Boolean read GetHotTrack write SetHotTrack;\r\n property HotTrackFont: TFont read GetHotTrackFont write SetHotTrackFont;\r\n property HotTrackFontOptions: TJvTrackFontOptions read GetHotTrackFontOptions write SetHotTrackFontOptions;\r\n property HotTrackOptions: TJvHotTrackOptions read GetHotTrackOptions write SetHotTrackOptions;\r\n end;\r\n\r\n TJvCustomHotTrackPersistent = class(TJvPersistentProperty, IJvHotTrack)\r\n private\r\n FHotTrack: Boolean;\r\n FHotTrackFont: TFont;\r\n FHotTrackFontOptions: TJvTrackFontOptions;\r\n FHotTrackOptions:TJvHotTrackOptions;\r\n\r\n {IJvHotTrack}\r\n function GetHotTrack: Boolean;\r\n function GetHotTrackFont: TFont;\r\n function GetHotTrackFontOptions: TJvTrackFontOptions;\r\n function GetHotTrackOptions: TJvHotTrackOptions;\r\n procedure SetHotTrack(Value: Boolean);\r\n procedure SetHotTrackFont(Value: TFont);\r\n procedure SetHotTrackFontOptions(Value: TJvTrackFontOptions);\r\n procedure SetHotTrackOptions(Value: TJvHotTrackOptions);\r\n\r\n procedure IJvHotTrack_Assign(Source: IJvHotTrack);\r\n procedure IJvHotTrack.Assign = IJvHotTrack_Assign;\r\n protected\r\n class function GetHotTrackOptionsClass: TJvHotTrackOptionsClass; virtual;\r\n procedure AssignTo(Dest: TPersistent); override;\r\n public\r\n constructor Create(AOwner: TPersistent); override;\r\n destructor Destroy; override;\r\n\r\n procedure Assign(Source: TPersistent); override;\r\n\r\n property HotTrack: Boolean read GetHotTrack write SetHotTrack default False;\r\n property HotTrackFont: TFont read GetHotTrackFont write SetHotTrackFont;\r\n property HotTrackFontOptions: TJvTrackFontOptions read GetHotTrackFontOptions write SetHotTrackFontOptions\r\n default DefaultTrackFontOptions;\r\n property HotTrackOptions: TJvHotTrackOptions read GetHotTrackOptions write SetHotTrackOptions;\r\n end;\r\n\r\n TJvHotTrackPersistent = class(TJvCustomHotTrackPersistent)\r\n published\r\n property HotTrack;\r\n property HotTrackFont;\r\n property HotTrackFontOptions;\r\n property HotTrackOptions;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvHotTrackPersistent.pas $';\r\n Revision: '$Revision: 13138 $';\r\n Date: '$Date: 2011-10-27 01:17:50 +0200 (jeu. 27 oct. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n SysUtils;\r\n\r\n//=== { TJvHotTrackOptions } ======================================\r\n\r\nconstructor TJvHotTrackOptions.Create(AOwner: TPersistent);\r\nbegin\r\n inherited ;\r\n FEnabled := False;\r\n FFrameVisible := False;\r\n FColor := DefaultHotTrackColor;\r\n FFrameColor := DefaultHotTrackFrameColor;\r\nend;\r\n\r\nprocedure TJvHotTrackOptions.Assign(Source: TPersistent);\r\nbegin\r\n if Source is TJvHotTrackOptions then\r\n begin\r\n BeginUpdate;\r\n try\r\n Enabled := TJvHotTrackOptions(Source).Enabled;\r\n Color := TJvHotTrackOptions(Source).Color;\r\n FrameVisible := TJvHotTrackOptions(Source).FrameVisible;\r\n FrameColor := TJvHotTrackOptions(Source).FrameColor;\r\n finally\r\n EndUpdate;\r\n end;\r\n end\r\n else\r\n inherited Assign(Source);\r\nend;\r\n\r\nprocedure TJvHotTrackOptions.SetColor(Value: TColor);\r\nbegin\r\n if FColor <> Value then\r\n begin\r\n Changing;\r\n ChangingProperty('Color');\r\n FColor := Value;\r\n ChangedProperty('Color');\r\n Changed;\r\n end;\r\nend;\r\n\r\nprocedure TJvHotTrackOptions.SetEnabled(Value: Boolean);\r\nbegin\r\n if FEnabled <> Value then\r\n begin\r\n Changing;\r\n ChangingProperty('Enabled');\r\n FEnabled := Value;\r\n ChangedProperty('Enabled');\r\n Changed;\r\n end;\r\nend;\r\n\r\nprocedure TJvHotTrackOptions.SetFrameVisible(Value: Boolean);\r\nbegin\r\n if FFrameVisible <> Value then\r\n begin\r\n Changing;\r\n ChangingProperty('FrameVisible');\r\n FFrameVisible := Value;\r\n ChangedProperty('FrameVisible');\r\n Changed;\r\n end;\r\nend;\r\n\r\nprocedure TJvHotTrackOptions.SetFrameColor(Value: TColor);\r\nbegin\r\n if FFrameColor <> Value then\r\n begin\r\n Changing;\r\n ChangingProperty('FrameColor');\r\n FFrameColor := Value;\r\n ChangedProperty('FrameColor');\r\n Changed;\r\n end;\r\nend;\r\n\r\n//============================================================================\r\n\r\n{ TJvCustomHotTrackPersistent }\r\n\r\nconstructor TJvCustomHotTrackPersistent.Create(AOwner: TPersistent);\r\nbegin\r\n inherited Create(AOwner);\r\n\r\n FHotTrack := False;\r\n FHotTrackFont := TFont.Create;\r\n FHotTrackFontOptions := DefaultTrackFontOptions;\r\n FHotTrackOptions :=GetHotTrackOptionsClass.Create(Self);\r\nend;\r\n\r\ndestructor TJvCustomHotTrackPersistent.Destroy;\r\nbegin\r\n FHotTrackFont.Free;\r\n FHotTrackOptions.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nclass function TJvCustomHotTrackPersistent.GetHotTrackOptionsClass: TJvHotTrackOptionsClass;\r\nbegin\r\n Result := TJvHotTrackOptions;\r\nend;\r\n\r\nprocedure TJvCustomHotTrackPersistent.Assign(Source: TPersistent);\r\nvar\r\n Intf: IJvHotTrack;\r\nbegin\r\n if Supports(Source, IJvHotTrack, Intf) then\r\n IJvHotTrack(Self).Assign(Intf)\r\n else\r\n inherited Assign(Source);\r\nend;\r\n\r\nprocedure TJvCustomHotTrackPersistent.AssignTo(Dest: TPersistent);\r\nvar\r\n Intf: IJvHotTrack;\r\nbegin\r\n if Supports(Dest, IJvHotTrack, Intf) then\r\n Intf.Assign(Self)\r\n else\r\n inherited AssignTo(Dest);\r\nend;\r\n\r\nprocedure TJvCustomHotTrackPersistent.SetHotTrackFont(Value: TFont);\r\nbegin\r\n if (FHotTrackFont<>Value) and (Value <> nil) then\r\n begin\r\n Changing;\r\n ChangingProperty('HotTrackFont');\r\n FHotTrackFont.Assign(Value);\r\n ChangedProperty('HotTrackFont');\r\n Changed;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomHotTrackPersistent.SetHotTrack(Value: Boolean);\r\nbegin\r\n if FHotTrack <> Value then\r\n begin\r\n Changing;\r\n ChangingProperty('HotTrack');\r\n FHotTrack := Value;\r\n ChangedProperty('HotTrack');\r\n Changed;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomHotTrackPersistent.SetHotTrackFontOptions(Value: TJvTrackFontOptions);\r\nbegin\r\n if FHotTrackFontOptions <> Value then\r\n begin\r\n Changing;\r\n ChangingProperty('HotTrackFontOptions');\r\n FHotTrackFontOptions := Value;\r\n ChangedProperty('HotTrackFontOptions');\r\n Changed;\r\n end;\r\nend;\r\n\r\nfunction TJvCustomHotTrackPersistent.GetHotTrack: Boolean;\r\nbegin\r\n Result := FHotTrack;\r\nend;\r\n\r\nfunction TJvCustomHotTrackPersistent.GetHotTrackFont: TFont;\r\nbegin\r\n Result := FHotTrackFont;\r\nend;\r\n\r\nfunction TJvCustomHotTrackPersistent.GetHotTrackFontOptions: TJvTrackFontOptions;\r\nbegin\r\n Result := FHotTrackFontOptions;\r\nend;\r\n\r\nfunction TJvCustomHotTrackPersistent.GetHotTrackOptions: TJvHotTrackOptions;\r\nbegin\r\n Result := FHotTrackOptions;\r\nend;\r\n\r\nprocedure TJvCustomHotTrackPersistent.SetHotTrackOptions(Value: TJvHotTrackOptions);\r\nbegin\r\n if (FHotTrackOptions <> Value) and (Value <> nil) then\r\n begin\r\n Changing;\r\n ChangingProperty('HotTrackOptions');\r\n FHotTrackOptions.Assign(Value);\r\n ChangedProperty('HotTrackOptions');\r\n Changed;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomHotTrackPersistent.IJvHotTrack_Assign(Source: IJvHotTrack);\r\nbegin\r\n if (Source <> nil) and (IJvHotTrack(Self) <> Source) then\r\n begin\r\n BeginUpdate;\r\n try\r\n HotTrack := Source.HotTrack;\r\n HotTrackFont := Source.HotTrackFont;\r\n HotTrackFontOptions := Source.HotTrackFontOptions;\r\n HotTrackOptions := Source.HotTrackOptions;\r\n finally\r\n EndUpdate;\r\n end;\r\n end;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvHtControls.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvHTControls.PAS, released on 2002-07-04.\r\n\r\nThe Initial Developers of the Original Code are: Andrei Prygounkov \r\nCopyRight (c) 1999, 2002 Andrei Prygounkov\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\n Maciej Kaczkowski\r\n Timo Tegtmeier\r\n Andreas Hausladen\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nDescription:\r\n HT Controls\r\n\r\nKnown Issues:\r\nMaciej Kaczkowski:\r\n [X] alignment not work correctly on JvHTButtonGlyph\r\n [X] not tested on BCB & Kylix\r\n [X] hyperlink work only whet alignment is left\r\n\r\nSome information about coding:\r\n [?] If you want use few times function you must use before next function
\r\n\r\nChanges:\r\n========\r\nPeter Thornqvist:\r\n 2004-01-279\r\n + Moved implementations to TJvCustomXXX classed\r\n + Now the registered controls only publish properties and events\r\nAndr Snepvangers:\r\n 2004-01-06\r\n VisualCLX compatible version\r\nMaciej Kaczkowski:\r\n 2003-09-16\r\n [+]
- new line\r\n [+]
- horizontal line\r\n [+] and - StrikeOut\r\n [+] Multiline for JvHTListBox, JvHTComboBox, TJvHTButton\r\n [+] You can change Height of JvHTComboBox\r\n [+] Tags: & " ® © ™   < >\r\n [+] \r\n [*] was changed to ex.: \r\n \r\n [*] procedure ItemHTDrawEx - rewrited\r\n [*] function ItemHTPlain - optimized\r\n\r\n 2003-09-23\r\n [*] fixed problem with

- just use
\r\n [-] fixed problem with inserting htcombobox on form\r\n [-] variable height is not work in design time, to use this put in code ex.:\r\n htcombobox1.SetHeight(40)\r\n to read height\r\n Value := htcombobox1.GetItemHeight;\r\n [-] Removed (var PlainItem: string) from header ItemHTDrawEx;\r\n [-] Alignment from TJvHTLabel was removed\r\n [+] SelectedColor, SelectedTextColor from JvMultilineListBox was moved to\r\n JvHTListBox and JvHTComboBox as ColorHighlight and ColorHighlightText\r\n\r\n 2003-09-27\r\n [-] fixed problem transparent color on JvHTlabel\r\n [-] fixed problem with layout on JvHTlabel\r\n [*] when TJvHTlabel is not enabled has pseudo 3D color\r\n [+] ColorDisabledText (JvHTcombobox, JvHTlistbox) was moved from\r\n jvmultilinelistbox\r\n [-] fixed vertical scroll on JvHTlistbox\r\n [-] minor bugs fixed\r\n\r\n 2003-10-04\r\n [-] JVCL 3.0 compatibility\r\n\r\n 2003-10-09\r\n [-] Removed +1 pixel from each line (place for
) to save compatibility\r\n with other labels\r\n [*] reorganized function\r\n [+] Added tag € (non-standard but useful)\r\n [+] Added for hyper link where %s is linkname\r\n but work only when alignment is left\r\n [+] Added to TJvHTLabel: OnHyperLinkClick(Sender; LinkText)\r\n [+] Added where %d is indention from left\r\n\r\n 2003-10-11\r\n [*] fixed with alignment but work only when autosize=True\r\n [*] fixed probem with autosize when alignment not left\r\n [+] Added to JvHTListBox but the same problem with hyperlinks\r\n when alignement is not left (need to rebuild the ItemHTDrawEx draw\r\n function)\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvHtControls.pas 13259 2012-02-28 10:09:57Z obones $\r\n\r\nunit JvHtControls;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n SysUtils, Classes,\r\n {$IFDEF MSWINDOWS}\r\n ShellAPI,\r\n {$ENDIF MSWINDOWS}\r\n Windows, Messages, Graphics, Contnrs, Controls, StdCtrls, Dialogs,\r\n JvJVCLUtils, JvExStdCtrls, JvDataSourceIntf;\r\n\r\nconst\r\n DefaultSuperSubScriptRatio: Double = 2/3;\r\n\r\ntype\r\n TJvCustomListBoxDataConnector = class(TJvFieldDataConnector)\r\n private\r\n FListBox: TCustomListBox;\r\n FMap: TList;\r\n FRecNoMap: TBucketList;\r\n protected\r\n procedure Populate; virtual;\r\n procedure ActiveChanged; override;\r\n procedure RecordChanged; override;\r\n property ListBox: TCustomListBox read FListBox;\r\n public\r\n constructor Create(AListBox: TCustomListBox);\r\n destructor Destroy; override;\r\n\r\n procedure GotoCurrent;\r\n end;\r\n\r\n TJvHyperLinkClickEvent = procedure(Sender: TObject; LinkName: string) of object;\r\n\r\n TJvCustomHTListBox = class(TJvExCustomListBox)\r\n private\r\n FOnHyperLinkClick: TJvHyperLinkClickEvent;\r\n FHideSel: Boolean;\r\n FColorHighlight: TColor;\r\n FColorHighlightText: TColor;\r\n FColorDisabledText: TColor;\r\n FDataConnector: TJvCustomListBoxDataConnector;\r\n FSuperSubScriptRatio: Double;\r\n procedure SetHideSel(Value: Boolean);\r\n function GetPlainItems(Index: Integer): string;\r\n procedure SetDataConnector(const Value: TJvCustomListBoxDataConnector);\r\n function ISuperSuperSubScriptRatioStored: Boolean;\r\n procedure SetSuperSubScriptRation(const Value: Double);\r\n protected\r\n function CreateDataConnector: TJvCustomListBoxDataConnector; virtual;\r\n procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;\r\n procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;\r\n procedure FontChanged; override;\r\n procedure Loaded; override;\r\n procedure MeasureItem(Index: Integer; var Height: Integer); override;\r\n procedure DrawItem(Index: Integer; Rect: TRect; State: TOwnerDrawState); override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n property PlainItems[Index: Integer]: string read GetPlainItems;\r\n protected\r\n procedure CMChanged(var Message: TCMChanged); message CM_CHANGED;\r\n property HideSel: Boolean read FHideSel write SetHideSel;\r\n property SuperSubScriptRatio: Double read FSuperSubScriptRatio write SetSuperSubScriptRation stored ISuperSuperSubScriptRatioStored;\r\n\r\n property ColorHighlight: TColor read FColorHighlight write FColorHighlight;\r\n property ColorHighlightText: TColor read FColorHighlightText write FColorHighlightText;\r\n property ColorDisabledText: TColor read FColorDisabledText write FColorDisabledText;\r\n property OnHyperLinkClick: TJvHyperLinkClickEvent read FOnHyperLinkClick write FOnHyperLinkClick;\r\n\r\n property DataConnector: TJvCustomListBoxDataConnector read FDataConnector write SetDataConnector;\r\n end;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvHTListBox = class(TJvCustomHTListBox)\r\n published\r\n property HideSel;\r\n property OnHyperLinkClick;\r\n\r\n property Align;\r\n property BorderStyle;\r\n property Color;\r\n property ColorHighlight;\r\n property ColorHighlightText;\r\n property ColorDisabledText;\r\n property Columns;\r\n property DragCursor;\r\n property TabWidth;\r\n property ImeMode;\r\n property ImeName;\r\n property AutoSize;\r\n property BiDiMode;\r\n property DragKind;\r\n property ParentBiDiMode;\r\n property OnEndDock;\r\n property OnStartDock;\r\n property DragMode;\r\n property Enabled;\r\n property ExtendedSelect;\r\n property Font;\r\n //property IntegralHeight;\r\n //property ItemHeight;\r\n property Items;\r\n property MultiSelect;\r\n property ParentColor;\r\n property ParentFont;\r\n property ParentShowHint;\r\n property PopupMenu;\r\n property ShowHint;\r\n property Sorted;\r\n property SuperSubScriptRatio;\r\n //property Style;\r\n property TabOrder;\r\n property TabStop;\r\n property Visible;\r\n property OnClick;\r\n property OnDblClick;\r\n property OnDragDrop;\r\n property OnDragOver;\r\n //property OnDrawItem;\r\n property OnEndDrag;\r\n property OnEnter;\r\n property OnExit;\r\n property OnKeyDown;\r\n property OnKeyPress;\r\n property OnKeyUp;\r\n //property OnMeasureItem;\r\n property OnMouseDown;\r\n property OnMouseMove;\r\n property OnMouseUp;\r\n property OnStartDrag;\r\n property Anchors;\r\n property Constraints;\r\n\r\n property DataConnector;\r\n end;\r\n\r\n TJvCustomHTComboBox = class(TJvExCustomComboBox)\r\n private\r\n FHideSel: Boolean;\r\n FDropWidth: Integer;\r\n FColorHighlight: TColor;\r\n FColorHighlightText: TColor;\r\n FColorDisabledText: TColor;\r\n FSuperSubScriptRatio: Double;\r\n procedure SetHideSel(Value: Boolean);\r\n function GetPlainItems(Index: Integer): string;\r\n procedure SetDropWidth(ADropWidth: Integer);\r\n function ISuperSuperSubScriptRatioStored: Boolean;\r\n procedure SetSuperSubScriptRation(const Value: Double);\r\n protected\r\n procedure CreateWnd; override;\r\n procedure DrawItem(Index: Integer; Rect: TRect; State: TOwnerDrawState); override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n property PlainItems[Index: Integer]: string read GetPlainItems;\r\n procedure SetHeight(Value: Integer);\r\n function GetHeight: Integer;\r\n protected\r\n property HideSel: Boolean read FHideSel write SetHideSel;\r\n property DropWidth: Integer read FDropWidth write SetDropWidth;\r\n property ColorHighlight: TColor read FColorHighlight write FColorHighlight;\r\n property ColorHighlightText: TColor read FColorHighlightText write FColorHighlightText;\r\n property ColorDisabledText: TColor read FColorDisabledText write FColorDisabledText;\r\n property SuperSubScriptRatio: Double read FSuperSubScriptRatio write SetSuperSubScriptRation stored ISuperSuperSubScriptRatioStored;\r\n end;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvHTComboBox = class(TJvCustomHTComboBox)\r\n published\r\n property Anchors;\r\n property HideSel;\r\n property DropWidth;\r\n property ColorHighlight;\r\n property ColorHighlightText;\r\n property ColorDisabledText;\r\n property Color;\r\n // property Style;\r\n property AutoSize;\r\n property DragCursor;\r\n property ImeMode;\r\n property ImeName;\r\n property BiDiMode;\r\n property DragKind;\r\n property ParentBiDiMode;\r\n property OnEndDock;\r\n property OnStartDock;\r\n property DragMode;\r\n property DropDownCount;\r\n property Enabled;\r\n property Font;\r\n // property ItemHeight;\r\n property Items;\r\n property MaxLength;\r\n property ParentColor;\r\n property ParentFont;\r\n property ParentShowHint;\r\n property PopupMenu;\r\n property ShowHint;\r\n property Sorted;\r\n property SuperSubScriptRatio;\r\n property TabOrder;\r\n property TabStop;\r\n property Text;\r\n property Visible;\r\n property OnChange;\r\n property OnClick;\r\n property OnDblClick;\r\n property OnDragDrop;\r\n property OnDragOver;\r\n // property OnDrawItem;\r\n property OnDropDown;\r\n property OnEndDrag;\r\n property OnEnter;\r\n property OnExit;\r\n property OnKeyDown;\r\n property OnKeyPress;\r\n property OnKeyUp;\r\n // property OnMeasureItem;\r\n property OnStartDrag;\r\n property Constraints;\r\n end;\r\n\r\n TJvHTLabelMouseButtons = set of TMouseButton;\r\n\r\n TJvCustomHTLabel = class(TJvExCustomLabel)\r\n private\r\n FHyperlinkHovered: Boolean;\r\n FOnHyperLinkClick: TJvHyperLinkClickEvent;\r\n FMouseX, FMouseY: Integer;\r\n FHyperLinkMouseButtons: TJvHTLabelMouseButtons;\r\n FSuperSubScriptRatio: Double;\r\n function ISuperSuperSubScriptRatioStored: Boolean;\r\n procedure SetSuperSubScriptRation(const Value: Double);\r\n protected\r\n procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;\r\n procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;\r\n procedure MouseLeave(AControl: TControl); override;\r\n procedure FontChanged; override;\r\n procedure AdjustBounds; override;\r\n procedure PrepareCanvas;\r\n function ComputeLayoutRect: TRect;\r\n procedure SetAutoSize(Value: Boolean); override;\r\n procedure Paint; override;\r\n procedure Loaded; override;\r\n\r\n property HyperLinkMouseButtons: TJvHTLabelMouseButtons read FHyperLinkMouseButtons write FHyperLinkMouseButtons default [mbLeft];\r\n property OnHyperLinkClick: TJvHyperLinkClickEvent read FOnHyperLinkClick write FOnHyperLinkClick;\r\n property SuperSubScriptRatio: Double read FSuperSubScriptRatio write SetSuperSubScriptRation stored ISuperSuperSubScriptRatioStored;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n end;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvHTLabel = class(TJvCustomHTLabel)\r\n private\r\n procedure IgnoreWordWrap(Reader: TReader);\r\n protected\r\n procedure DefineProperties(Filer: TFiler); override; // ignore former published WordWrap\r\n published\r\n property Align;\r\n property Anchors;\r\n property AutoSize;\r\n property Caption;\r\n property Color;\r\n property DragCursor;\r\n property BiDiMode;\r\n property DragKind;\r\n property ParentBiDiMode;\r\n property OnEndDock;\r\n property OnStartDock;\r\n property DragMode;\r\n property Enabled;\r\n property FocusControl;\r\n property Font;\r\n property ParentColor;\r\n property ParentFont;\r\n property ParentShowHint;\r\n property PopupMenu;\r\n // property ShowAccelChar; not supported\r\n property ShowHint;\r\n property SuperSubScriptRatio;\r\n property Transparent;\r\n property Visible;\r\n // property WordWrap; not supported\r\n property OnClick;\r\n property OnDblClick;\r\n property OnDragDrop;\r\n property OnDragOver;\r\n property OnEndDrag;\r\n property OnMouseDown;\r\n property OnMouseMove;\r\n property OnMouseUp;\r\n property OnStartDrag;\r\n property Layout;\r\n property Constraints;\r\n property HyperLinkMouseButtons;\r\n property OnHyperLinkClick;\r\n end;\r\n\r\nprocedure ItemHTDrawEx(Canvas: TCanvas; Rect: TRect;\r\n const State: TOwnerDrawState; const Text: string; var Width: Integer;\r\n CalcType: TJvHTMLCalcType; MouseX, MouseY: Integer; var MouseOnLink: Boolean;\r\n var LinkName: string; SuperSubScriptRatio: Double; Scale: Integer = 100);\r\n { example for Text parameter : 'Item 1 bold italic ITALIC
red green blue ' }\r\nfunction ItemHTDraw(Canvas: TCanvas; Rect: TRect;\r\n const State: TOwnerDrawState; const Text: string; SuperSubScriptRatio: Double; Scale: Integer = 100): string;\r\nfunction ItemHTDrawHL(Canvas: TCanvas; Rect: TRect;\r\n const State: TOwnerDrawState; const Text: string; MouseX, MouseY: Integer; SuperSubScriptRatio: Double; Scale: Integer = 100): string;\r\nfunction ItemHTPlain(const Text: string): string;\r\nfunction ItemHTExtent(Canvas: TCanvas; Rect: TRect; const State: TOwnerDrawState;\r\n const Text: string; SuperSubScriptRatio: Double; Scale: Integer = 100): TSize;\r\nfunction ItemHTWidth(Canvas: TCanvas; Rect: TRect;\r\n const State: TOwnerDrawState; const Text: string; SuperSubScriptRatio: Double; Scale: Integer = 100): Integer;\r\nfunction ItemHTHeight(Canvas: TCanvas; const Text: string; SuperSubScriptRatio: Double; Scale: Integer = 100): Integer;\r\nfunction PrepareText(const A: string): string; deprecated;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvHtControls.pas $';\r\n Revision: '$Revision: 13259 $';\r\n Date: '$Date: 2012-02-28 11:09:57 +0100 (mar. 28 févr. 2012) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nconst\r\n cMAILTO = 'MAILTO:';\r\n cURLTYPE = '://';\r\n\r\nprocedure ExecuteHyperlink(Sender: TObject; HyperLinkClick: TJvHyperLinkClickEvent; const LinkName: string);\r\nbegin\r\n if (Pos(cURLTYPE, LinkName) > 0) or // ftp:// http://\r\n (Pos(cMAILTO, UpperCase(LinkName)) > 0) then // mailto:name@server.com\r\n ShellExecute(0, 'open', PChar(LinkName), nil, nil, SW_NORMAL);\r\n if Assigned(HyperLinkClick) then\r\n HyperLinkClick(Sender, LinkName);\r\nend;\r\n\r\nfunction PrepareText(const A: string): string;\r\nbegin\r\n Result := HTMLPrepareText(A);\r\nend;\r\n\r\nprocedure ItemHTDrawEx(Canvas: TCanvas; Rect: TRect;\r\n const State: TOwnerDrawState; const Text: string; var Width: Integer;\r\n CalcType: TJvHTMLCalcType; MouseX, MouseY: Integer; var MouseOnLink: Boolean;\r\n var LinkName: string; SuperSubScriptRatio: Double; Scale: Integer = 100);\r\nbegin\r\n HTMLDrawTextEx(Canvas, Rect, State, Text, Width, CalcType, MouseX, MouseY, MouseOnLink, LinkName, SuperSubScriptRatio, Scale);\r\nend;\r\n\r\nfunction ItemHTDraw(Canvas: TCanvas; Rect: TRect; const State: TOwnerDrawState;\r\n const Text: string; SuperSubScriptRatio: Double; Scale: Integer = 100): string;\r\nbegin\r\n HTMLDrawText(Canvas, Rect, State, Text, SuperSubScriptRatio, Scale);\r\nend;\r\n\r\nfunction ItemHTDrawHL(Canvas: TCanvas; Rect: TRect; const State: TOwnerDrawState;\r\n const Text: string; MouseX, MouseY: Integer; SuperSubScriptRatio: Double; Scale: Integer = 100): string;\r\nbegin\r\n HTMLDrawTextHL(Canvas, Rect, State, Text, MouseX, MouseY, SuperSubScriptRatio, Scale);\r\nend;\r\n\r\nfunction ItemHTPlain(const Text: string): string;\r\nbegin\r\n Result := HTMLPlainText(Text);\r\nend;\r\n\r\nfunction ItemHTExtent(Canvas: TCanvas; Rect: TRect; const State: TOwnerDrawState;\r\n const Text: string; SuperSubScriptRatio: Double; Scale: Integer = 100): TSize;\r\nbegin\r\n Result := HTMLTextExtent(Canvas, Rect, State, Text, SuperSubScriptRatio, Scale);\r\nend;\r\n\r\nfunction ItemHTWidth(Canvas: TCanvas; Rect: TRect;\r\n const State: TOwnerDrawState; const Text: string; SuperSubScriptRatio: Double; Scale: Integer = 100): Integer;\r\nbegin\r\n Result := HTMLTextWidth(Canvas, Rect, State, Text, SuperSubScriptRatio, Scale);\r\nend;\r\n\r\nfunction ItemHTHeight(Canvas: TCanvas; const Text: string; SuperSubScriptRatio: Double; Scale: Integer = 100): Integer;\r\nbegin\r\n Result := HTMLTextHeight(Canvas, Text, SuperSubScriptRatio, Scale);\r\nend;\r\n\r\nfunction IsHyperLinkPaint(Canvas: TCanvas; Rect: TRect; const State: TOwnerDrawState;\r\n const Text: string; MouseX, MouseY: Integer; var HyperLink: string): Boolean;\r\nvar\r\n W: Integer;\r\nbegin\r\n ItemHTDrawEx(Canvas, Rect, State, Text, W, htmlShow, MouseX, MouseY, Result, HyperLink, DefaultSuperSubScriptRatio);\r\nend;\r\n\r\nfunction IsHyperLink(Canvas: TCanvas; Rect: TRect; const Text: string;\r\n MouseX, MouseY: Integer; var HyperLink: string): Boolean;\r\nvar\r\n W: Integer;\r\nbegin\r\n ItemHTDrawEx(Canvas, Rect, [], Text, W, htmlHyperLink, MouseX, MouseY, Result, HyperLink, DefaultSuperSubScriptRatio);\r\nend;\r\n\r\n//=== { TJvCustomListBoxDataConnector } ======================================\r\n\r\nconstructor TJvCustomListBoxDataConnector.Create(AListBox: TCustomListBox);\r\nbegin\r\n inherited Create;\r\n FListBox := AListBox;\r\n FRecNoMap := TBucketList.Create;\r\n FMap := TList.Create;\r\nend;\r\n\r\ndestructor TJvCustomListBoxDataConnector.Destroy;\r\nbegin\r\n FMap.Free;\r\n FRecNoMap.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvCustomListBoxDataConnector.GotoCurrent;\r\nbegin\r\n if Field.IsValid and (FListBox.ItemIndex <> -1) then\r\n DataSource.RecNo := Integer(FMap[FListBox.ItemIndex]);\r\nend;\r\n\r\nprocedure TJvCustomListBoxDataConnector.ActiveChanged;\r\nbegin\r\n Populate;\r\n inherited ActiveChanged;\r\nend;\r\n\r\nprocedure TJvCustomListBoxDataConnector.Populate;\r\nvar\r\n Index: {$IFDEF RTL230_UP}NativeInt{$ELSE}Integer{$ENDIF};\r\nbegin\r\n FMap.Clear;\r\n FRecNoMap.Clear;\r\n FListBox.Items.BeginUpdate;\r\n try\r\n FListBox.Items.Clear;\r\n if Field.IsValid then\r\n begin\r\n DataSource.BeginUpdate;\r\n try\r\n DataSource.First;\r\n while not DataSource.Eof do\r\n begin\r\n Index := FListBox.Items.Add(Field.AsString);\r\n FMap.Add(TObject(DataSource.RecNo));\r\n FRecNoMap.Add(TObject(DataSource.RecNo), TObject(Index));\r\n DataSource.Next;\r\n end;\r\n finally\r\n DataSource.EndUpdate;\r\n end;\r\n if FRecNoMap.Find(TObject(DataSource.RecNo), Pointer(Index)) then\r\n FListBox.ItemIndex := Index;\r\n end;\r\n finally\r\n FListBox.Items.EndUpdate;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomListBoxDataConnector.RecordChanged;\r\nvar\r\n Index: {$IFDEF RTL230_UP}NativeInt{$ELSE}Integer{$ENDIF};\r\nbegin\r\n if Field.IsValid then\r\n begin\r\n if FListBox.Items.Count <> DataSource.RecordCount then\r\n Populate\r\n else\r\n if FRecNoMap.Find(TObject(DataSource.RecNo), Pointer(Index)) then\r\n begin\r\n FListBox.Items[Index] := Field.AsString;\r\n FListBox.ItemIndex := Index;\r\n end;\r\n end;\r\nend;\r\n\r\n//=== { TJvCustomHTListBox } =================================================\r\n\r\nconstructor TJvCustomHTListBox.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FDataConnector := CreateDataConnector;\r\n Style := lbOwnerDrawVariable;\r\n FColorHighlight := clHighlight;\r\n FColorHighlightText := clHighlightText;\r\n FColorDisabledText := clGrayText;\r\n FSuperSubScriptRatio := DefaultSuperSubScriptRatio;\r\nend;\r\n\r\ndestructor TJvCustomHTListBox.Destroy;\r\nbegin\r\n FDataConnector.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvCustomHTListBox.Loaded;\r\nbegin\r\n inherited Loaded;\r\n DataConnector.Reset;\r\nend;\r\n\r\nprocedure TJvCustomHTListBox.CMChanged(var Message: TCMChanged);\r\nbegin\r\n inherited;\r\n DataConnector.GotoCurrent;\r\nend;\r\n\r\nprocedure TJvCustomHTListBox.DrawItem(Index: Integer; Rect: TRect;\r\n State: TOwnerDrawState);\r\nbegin\r\n if odSelected in State then\r\n begin\r\n Canvas.Brush.Color := ColorHighlight;\r\n Canvas.Font.Color := ColorHighlightText;\r\n end;\r\n if not Enabled then\r\n Canvas.Font.Color := ColorDisabledText;\r\n\r\n Canvas.FillRect(Rect);\r\n Inc(Rect.Left, 2);\r\n ItemHTDraw(Canvas, Rect, State, Items[Index], SuperSubScriptRatio);\r\nend;\r\n\r\nprocedure TJvCustomHTListBox.MeasureItem(Index: Integer; var Height: Integer);\r\nbegin\r\n Height := ItemHTHeight(Canvas, Items[Index], SuperSubScriptRatio);\r\nend;\r\n\r\nfunction TJvCustomHTListBox.CreateDataConnector: TJvCustomListBoxDataConnector;\r\nbegin\r\n Result := TJvCustomListBoxDataConnector.Create(Self);\r\nend;\r\n\r\nprocedure TJvCustomHTListBox.FontChanged;\r\nbegin\r\n inherited FontChanged;\r\n if not Assigned(Canvas) then\r\n Exit; // VisualCLX needs this\r\n Canvas.Font := Font;\r\n ItemHeight := CanvasMaxTextHeight(Canvas);\r\nend;\r\n\r\nprocedure TJvCustomHTListBox.SetDataConnector(const Value: TJvCustomListBoxDataConnector);\r\nbegin\r\n if Value <> FDataConnector then\r\n FDataConnector.Assign(Value);\r\nend;\r\n\r\nprocedure TJvCustomHTListBox.SetHideSel(Value: Boolean);\r\nbegin\r\n FHideSel := Value;\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvCustomHTListBox.SetSuperSubScriptRation(const Value: Double);\r\nbegin\r\n if FSuperSubScriptRatio <> Value then\r\n begin\r\n FSuperSubScriptRatio := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nfunction TJvCustomHTListBox.GetPlainItems(Index: Integer): string;\r\nbegin\r\n Result := ItemHTPlain(Items[Index]);\r\nend;\r\n\r\nfunction TJvCustomHTListBox.ISuperSuperSubScriptRatioStored: Boolean;\r\nbegin\r\n Result := FSuperSubScriptRatio <> DefaultSuperSubScriptRatio;\r\nend;\r\n\r\nprocedure TJvCustomHTListBox.MouseMove(Shift: TShiftState; X, Y: Integer);\r\nvar\r\n R: TRect;\r\n LinkName: string;\r\n State: TOwnerDrawState;\r\n I: Integer;\r\nbegin\r\n inherited MouseMove(Shift,X,Y);\r\n I := Self.ItemAtPos(Point(X, Y), True);\r\n if I = -1 then\r\n Exit;\r\n R := Self.ItemRect(I);\r\n State := [];\r\n if Self.Selected[I] then\r\n begin\r\n State := [odSelected];\r\n Canvas.Font.Color := FColorHighlightText;\r\n Canvas.Brush.Color := FColorHighlight;\r\n end\r\n else\r\n begin\r\n Canvas.Font.Color := Font.Color;\r\n Canvas.Brush.Color := Color;\r\n end;\r\n Inc(R.Left, 2);\r\n if IsHyperLinkPaint(Canvas, R, State, Items[I], X, Y, LinkName) then\r\n Cursor := crHandPoint\r\n else\r\n Cursor := crDefault;\r\nend;\r\n\r\nprocedure TJvCustomHTListBox.MouseUp(Button: TMouseButton; Shift: TShiftState;\r\n X, Y: Integer);\r\nvar\r\n R: TRect;\r\n LinkName: string;\r\n State: TOwnerDrawState;\r\n I: Integer;\r\nbegin\r\n inherited MouseUp(Button,Shift, X, Y);\r\n I := Self.ItemAtPos(Point(X, Y), True);\r\n if I <> -1 then\r\n begin\r\n R := Self.ItemRect(I);\r\n State := [];\r\n if Self.Selected[I] then\r\n begin\r\n State := [odSelected];\r\n Canvas.Font.Color := ColorHighlightText\r\n end\r\n else\r\n Canvas.Font.Color := Font.Color;\r\n Inc(R.Left, 2);\r\n if IsHyperLinkPaint(Canvas, R, State, Items[I], X, Y, LinkName) then\r\n ExecuteHyperlink(Self, FOnHyperLinkClick, LinkName);\r\n end;\r\nend;\r\n\r\n//=== { TJvCustomHTComboBox } ================================================\r\n\r\nconstructor TJvCustomHTComboBox.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n Style := csOwnerDrawVariable;\r\n FColorHighlight := clHighlight;\r\n FColorHighlightText := clHighlightText;\r\n FColorDisabledText := clGrayText;\r\n FSuperSubScriptRatio := DefaultSuperSubScriptRatio;\r\nend;\r\n\r\nprocedure TJvCustomHTComboBox.DrawItem(Index: Integer; Rect: TRect;\r\n State: TOwnerDrawState);\r\nbegin\r\n if odSelected in State then\r\n begin\r\n Canvas.Brush.Color := ColorHighlight;\r\n Canvas.Font.Color := ColorHighlightText;\r\n end;\r\n if not Enabled then\r\n Canvas.Font.Color := ColorDisabledText;\r\n\r\n Canvas.FillRect(Rect);\r\n Inc(Rect.Left, 2);\r\n ItemHTDraw(Canvas, Rect, State, Items[Index], SuperSubScriptRatio);\r\nend;\r\n\r\nfunction TJvCustomHTComboBox.GetHeight: Integer;\r\nbegin\r\n Result := SendMessage(Self.Handle, CB_GETITEMHEIGHT, -1, 0);\r\nend;\r\n\r\nprocedure TJvCustomHTComboBox.SetHeight(Value: Integer);\r\nbegin\r\n SendMessage(Self.Handle, CB_SETITEMHEIGHT, -1, Value);\r\nend;\r\n\r\nprocedure TJvCustomHTComboBox.SetHideSel(Value: Boolean);\r\nbegin\r\n FHideSel := Value;\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvCustomHTComboBox.SetSuperSubScriptRation(const Value: Double);\r\nbegin\r\n if FSuperSubScriptRatio <> Value then\r\n begin\r\n FSuperSubScriptRatio := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nfunction TJvCustomHTComboBox.GetPlainItems(Index: Integer): string;\r\nbegin\r\n Result := ItemHTPlain(Items[Index]);\r\nend;\r\n\r\nfunction TJvCustomHTComboBox.ISuperSuperSubScriptRatioStored: Boolean;\r\nbegin\r\n Result := FSuperSubScriptRatio <> DefaultSuperSubScriptRatio;\r\nend;\r\n\r\nprocedure TJvCustomHTComboBox.CreateWnd;\r\nvar\r\n Tmp: Integer;\r\nbegin\r\n inherited CreateWnd;\r\n if DropWidth = 0 then\r\n DropWidth := Width\r\n else\r\n begin\r\n Tmp := DropWidth;\r\n DropWidth := 0;\r\n DropWidth := Tmp;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomHTComboBox.SetDropWidth(ADropWidth: Integer);\r\nbegin\r\n if FDropWidth <> ADropWidth then\r\n begin\r\n FDropWidth := ADropWidth;\r\n Perform(CB_SETDROPPEDWIDTH, FDropWidth, 0);\r\n end;\r\nend;\r\n\r\n//=== { TJvCustomHTLabel } ===================================================\r\n\r\nconstructor TJvCustomHTLabel.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FHyperLinkMouseButtons := [mbLeft];\r\n FSuperSubScriptRatio := DefaultSuperSubScriptRatio;\r\nend;\r\n\r\nprocedure TJvCustomHTLabel.FontChanged;\r\nbegin\r\n inherited FontChanged;\r\n AdjustBounds;\r\nend;\r\n\r\nfunction TJvCustomHTLabel.ISuperSuperSubScriptRatioStored: Boolean;\r\nbegin\r\n Result := FSuperSubScriptRatio <> DefaultSuperSubScriptRatio;\r\nend;\r\n\r\nprocedure TJvCustomHTLabel.Loaded;\r\nbegin\r\n inherited Loaded;\r\n AdjustBounds;\r\nend;\r\n\r\nprocedure TJvCustomHTLabel.AdjustBounds;\r\nvar\r\n DC: HDC;\r\n X: Integer;\r\n Rect: TRect;\r\n MaxWidth: Integer;\r\nbegin\r\n if not (csReading in ComponentState) and AutoSize then\r\n begin\r\n Rect := ClientRect;\r\n DC := GetDC(HWND_DESKTOP);\r\n try\r\n Canvas.Handle := DC;\r\n Canvas.Font.Assign(Font);\r\n Rect.Bottom := ItemHTHeight(Canvas, Caption, SuperSubScriptRatio);\r\n MaxWidth := ItemHTWidth(Canvas, Bounds(0, 0, 0, 0), [], Caption, SuperSubScriptRatio);\r\n finally\r\n Canvas.Handle := 0;\r\n ReleaseDC(HWND_DESKTOP, DC);\r\n end;\r\n Rect.Right := Rect.Left + MaxWidth;\r\n X := Left;\r\n if Alignment = taRightJustify then\r\n Inc(X, Width - Rect.Right);\r\n SetBounds(X, Top, Rect.Right, Rect.Bottom);\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomHTLabel.PrepareCanvas;\r\nbegin\r\n Canvas.Lock;\r\n try\r\n Canvas.Font := Font;\r\n Canvas.Brush.Color := Color;\r\n finally\r\n Canvas.Unlock;\r\n end;\r\nend;\r\n\r\nfunction TJvCustomHTLabel.ComputeLayoutRect: TRect;\r\nbegin\r\n Result := ClientRect;\r\n case Layout of\r\n tlTop:\r\n ;\r\n tlBottom:\r\n Result.Top := Result.Bottom - ItemHTHeight(Canvas, Caption, SuperSubScriptRatio);\r\n tlCenter:\r\n Result.Top := (Result.Bottom - Result.Top - ItemHTHeight(Canvas, Caption, SuperSubScriptRatio)) div 2;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomHTLabel.SetAutoSize(Value: Boolean);\r\nbegin\r\n if AutoSize <> Value then\r\n begin\r\n inherited SetAutoSize(Value);\r\n AdjustBounds;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomHTLabel.SetSuperSubScriptRation(const Value: Double);\r\nbegin\r\n if FSuperSubScriptRatio <> Value then\r\n begin\r\n FSuperSubScriptRatio := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomHTLabel.Paint;\r\nvar\r\n Rect: TRect;\r\n PaintText: String;\r\nbegin\r\n PaintText := GetLabelText;\r\n PrepareCanvas;\r\n if Transparent then\r\n Canvas.Brush.Style := bsClear\r\n else\r\n begin\r\n Canvas.Brush.Style := bsSolid;\r\n Canvas.FillRect(ClientRect);\r\n end;\r\n Rect := ComputeLayoutRect;\r\n Canvas.Font.Style := []; // only font name and font size is important\r\n if not Enabled then\r\n begin\r\n OffsetRect(Rect, 1, 1);\r\n Canvas.Font.Color := clBtnHighlight;\r\n ItemHTDrawHL(Canvas, Rect, [odDisabled], PaintText, FMouseX, FMouseY, SuperSubScriptRatio);\r\n OffsetRect(Rect, -1, -1);\r\n Canvas.Font.Color := clBtnShadow;\r\n ItemHTDrawHL(Canvas, Rect, [odDisabled], PaintText, FMouseX, FMouseY, SuperSubScriptRatio);\r\n end\r\n else\r\n ItemHTDrawHL(Canvas, Rect, [], PaintText, FMouseX, FMouseY, SuperSubScriptRatio);\r\nend;\r\n\r\nprocedure TJvCustomHTLabel.MouseMove(Shift: TShiftState; X, Y: Integer);\r\nvar\r\n R: TRect;\r\n LinkName: string;\r\n LastHovered: Boolean;\r\nbegin\r\n FMouseX := X;\r\n FMouseY := Y;\r\n inherited MouseMove(Shift, X, Y);\r\n\r\n LastHovered := FHyperlinkHovered;\r\n Canvas.Lock;\r\n try\r\n PrepareCanvas;\r\n R := ComputeLayoutRect;\r\n FHyperlinkHovered := IsHyperLink(Canvas, R, Caption, X, Y, LinkName);\r\n finally\r\n Canvas.Unlock;\r\n end;\r\n\r\n if FHyperlinkHovered then\r\n Cursor := crHandPoint\r\n else\r\n Cursor := crDefault;\r\n\r\n if FHyperlinkHovered <> LastHovered then\r\n begin\r\n if Transparent then\r\n Invalidate\r\n else\r\n Paint;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomHTLabel.MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);\r\nvar\r\n R: TRect;\r\n LinkName: string;\r\nbegin\r\n FMouseX := X;\r\n FMouseY := Y;\r\n inherited MouseUp(Button, Shift, X, Y);\r\n if Button in FHyperLinkMouseButtons then\r\n begin\r\n R := ClientRect;\r\n case Layout of\r\n tlTop:\r\n ;\r\n tlBottom:\r\n R.Top := R.Bottom - ItemHTHeight(Canvas, Caption, SuperSubScriptRatio);\r\n tlCenter:\r\n R.Top := (R.Bottom - R.Top - ItemHTHeight(Canvas, Caption, SuperSubScriptRatio)) div 2;\r\n end;\r\n if IsHyperLink(Canvas, R, Caption, X, Y, LinkName) then\r\n ExecuteHyperlink(Self, FOnHyperLinkClick, LinkName);\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomHTLabel.MouseLeave(AControl: TControl);\r\nbegin\r\n FMouseX := 0;\r\n FMouseY := 0;\r\n inherited MouseLeave(AControl);\r\n if FHyperlinkHovered then\r\n begin\r\n FHyperlinkHovered := False;\r\n if Transparent then\r\n Invalidate\r\n else\r\n Paint;\r\n end;\r\nend;\r\n\r\n{ TJvHTLabel }\r\n\r\nprocedure TJvHTLabel.DefineProperties(Filer: TFiler);\r\nbegin\r\n inherited DefineProperties(Filer);\r\n Filer.DefineProperty('WordWrap', IgnoreWordWrap, nil, False);\r\nend;\r\n\r\nprocedure TJvHTLabel.IgnoreWordWrap(Reader: TReader);\r\nbegin\r\n Reader.ReadBoolean;\r\nend;\r\n\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvHtmlParser.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvHTMLParser.PAS, released on 2001-02-28.\r\n\r\nThe Initial Developer of the Original Code is Sbastien Buysse [sbuysse att buypin dott com]\r\nPortions created by Sbastien Buysse are Copyright (C) 2001 Sbastien Buysse.\r\nAll Rights Reserved.\r\n\r\nContributor(s): Michael Beck [mbeck att bigfoot dott com].\r\n Alexander Samusenko[sandx att chat dott ru].\r\n CarlEfird.\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvHtmlParser.pas 13138 2011-10-26 23:17:50Z jfudickar $\r\n\r\nunit JvHtmlParser;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n SysUtils, Classes,\r\n JclStrings,\r\n JvComponentBase;\r\n\r\ntype\r\n PTagInfo = ^TTagInfo;\r\n\r\n TTagInfo = record\r\n BeginPos: Integer;\r\n EndPos: Integer;\r\n BeginContext: Integer;\r\n EndContext: Integer;\r\n Key: Integer;\r\n end;\r\n\r\n // (rom) definitely needs improvement\r\n TJvParserInfo = class(TObject)\r\n public\r\n StartTag: string;\r\n EndTag: string;\r\n MustBe: Integer;\r\n TakeText: Integer;\r\n end;\r\n\r\n TTagInfoList = class(TList)\r\n public\r\n procedure AddValue(const Value: TTagInfo);\r\n procedure Clear; override;\r\n end;\r\n\r\n TJvKeyFoundEvent = procedure(Sender: TObject; Key, Results, OriginalLine: string) of object;\r\n TJvKeyFoundExEvent = procedure(Sender: TObject; Key, Results, OriginalLine: string;\r\n TagInfo: TTagInfo; Attributes: TStrings) of object;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64 or pidOSX32)]\r\n {$ENDIF RTL230_UP}\r\n TJvHTMLParser = class(TJvComponent)\r\n private\r\n FParser: TStringList;\r\n FKeys: TStringList;\r\n FFileName: TFileName;\r\n FTagList: TTagInfoList;\r\n FContent: string;\r\n FOnKeyFound: TJvKeyFoundEvent;\r\n FOnKeyFoundEx: TJvKeyFoundExEvent;\r\n function GetParser: TStrings;\r\n procedure SetParser(Value: TStrings);\r\n procedure SetFileName(Value: TFileName);\r\n procedure SetTagList(const Value: TTagInfoList);\r\n function GetConditionsCount: Integer;\r\n protected\r\n procedure Loaded; override;\r\n property TagList: TTagInfoList read FTagList write SetTagList;\r\n public\r\n procedure AnalyseString(const Str: string);\r\n procedure AnalyseFile;\r\n procedure AddCondition(const Keyword: string; const StartTag: string = '<';\r\n const EndTag: string = '>'; TextSelection: Integer = 0);\r\n procedure RemoveCondition(Index: Integer);\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n property ConditionsCount: Integer read GetConditionsCount;\r\n procedure ClearConditions;\r\n procedure GetCondition(Index: Integer; var Keyword, StartTag, EndTag: string); overload;\r\n procedure GetCondition(Index: Integer; var Keyword, StartTag, EndTag: string;\r\n var TextSelection: Integer); overload;\r\n property Content: string read FContent;\r\n published\r\n property FileName: TFileName read FFileName write SetFileName;\r\n property Parser: TStrings read GetParser write SetParser;\r\n property OnKeyFound: TJvKeyFoundEvent read FOnKeyFound write FOnKeyFound;\r\n property OnKeyFoundEx: TJvKeyFoundExEvent read FOnKeyFoundEx write FOnKeyFoundEx;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvHtmlParser.pas $';\r\n Revision: '$Revision: 13138 $';\r\n Date: '$Date: 2011-10-27 01:17:50 +0200 (jeu. 27 oct. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n {$IFNDEF COMPILER12_UP}\r\n JvJCLUtils,\r\n {$ENDIF ~COMPILER12_UP}\r\n JvConsts;\r\n\r\n{Comparison function. Used internally for observance of the sequences tags}\r\nfunction CompareTags(Item1, Item2: Pointer): Integer;\r\nbegin\r\n Result := (PTagInfo(Item1).BeginPos - PTagInfo(Item2).BeginPos);\r\nend;\r\n\r\n//=== { TJvHTMLParser } ======================================================\r\n\r\nconstructor TJvHTMLParser.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FParser := TStringList.Create;\r\n FKeys := TStringList.Create;\r\n FTagList := TTagInfoList.Create;\r\nend;\r\n\r\ndestructor TJvHTMLParser.Destroy;\r\nvar\r\n Index: Integer;\r\nbegin\r\n FParser.Free;\r\n for Index := FKeys.Count - 1 downto 0 do\r\n FKeys.Objects[Index].Free;\r\n FKeys.Free;\r\n FTagList.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvHTMLParser.Loaded;\r\nbegin\r\n inherited Loaded;\r\n SetParser(FParser);\r\nend;\r\n\r\nprocedure TJvHTMLParser.SetFileName(Value: TFileName);\r\nbegin\r\n if FFileName <> Value then\r\n begin\r\n FFileName := Value;\r\n if not (csDesigning in ComponentState) then\r\n AnalyseFile;\r\n end;\r\nend;\r\n\r\nfunction TJvHTMLParser.GetParser: TStrings;\r\nbegin\r\n Result := FParser;\r\nend;\r\n\r\nprocedure TJvHTMLParser.SetParser(Value: TStrings);\r\nvar\r\n I: Integer;\r\n Obj: TJvParserInfo;\r\n Cap: string;\r\nbegin\r\n if FParser <> Value then // make sure we don't assign to ourselves (that will clear the list)\r\n FParser.Assign(Value);\r\n for I := FKeys.Count - 1 downto 0 do\r\n FKeys.Objects[I].Free;\r\n FKeys.Clear;\r\n I := 0;\r\n while I < FParser.Count do\r\n begin\r\n Obj := TJvParserInfo.Create;\r\n try\r\n Cap := FParser[I];\r\n Inc(I);\r\n Obj.StartTag := FParser[I];\r\n Inc(I);\r\n Obj.EndTag := FParser[I];\r\n Inc(I);\r\n Obj.MustBe := StrToInt(FParser[I]);\r\n Inc(I);\r\n Obj.TakeText := StrToInt(FParser[I]);\r\n Inc(I);\r\n finally\r\n FKeys.AddObject(Cap, Obj);\r\n end;\r\n end;\r\nend;\r\n\r\n// (rom) reimplemented with a TStringList\r\n\r\nprocedure TJvHTMLParser.AnalyseFile;\r\nvar\r\n List: TStringList;\r\nbegin\r\n List := TStringList.Create;\r\n try\r\n if FileExists(FileName) then\r\n begin\r\n List.LoadFromFile(FileName);\r\n AnalyseString(List.Text);\r\n end;\r\n finally\r\n List.Free;\r\n end;\r\nend;\r\n\r\nprocedure TJvHTMLParser.AnalyseString(const Str: string);\r\nvar\r\n Str2, Str3: string;\r\n StartTag1, StartTag2: string;\r\n I, J, K, Index: Integer;\r\n TagInfo: TTagInfo;\r\n AttributesList: TStringList;\r\n\r\n procedure InnerParseAttributes(Content: PChar; Strings: TStrings);\r\n var\r\n Head, Tail: PChar;\r\n EOS, InQuote, LeadQuote: Boolean;\r\n QuoteChar: Char;\r\n begin\r\n if (Content = nil) or (Content^ = #0) then\r\n Exit;\r\n Tail := Content;\r\n QuoteChar := #0;\r\n repeat\r\n while CharInSet(Tail^, [Cr, Lf, ' ']) do\r\n Inc(Tail);\r\n Head := Tail;\r\n InQuote := False;\r\n LeadQuote := False;\r\n while True do\r\n begin\r\n while (InQuote and not CharInSet(Tail^, [#0, '\"'])) or\r\n not CharInSet(Tail^, [#0, Cr, Lf, ' ', '\"']) do\r\n Inc(Tail);\r\n if Tail^ = '\"' then\r\n begin\r\n if (QuoteChar <> #0) and (QuoteChar = Tail^) then\r\n QuoteChar := #0\r\n else\r\n begin\r\n LeadQuote := Head = Tail;\r\n QuoteChar := Tail^;\r\n if LeadQuote then\r\n Inc(Head);\r\n end;\r\n InQuote := QuoteChar <> #0;\r\n if InQuote then\r\n Inc(Tail)\r\n else\r\n Break;\r\n end\r\n else\r\n Break;\r\n end;\r\n if not LeadQuote and (Tail^ <> #0) and (Tail^ = '\"') then\r\n Inc(Tail);\r\n EOS := Tail^ = #0;\r\n Tail^ := #0;\r\n if Head^ <> #0 then\r\n Strings.Add(Head);\r\n Inc(Tail);\r\n until EOS;\r\n end;\r\n\r\n procedure ParseAttributes(Strings: TStrings; const Value: string);\r\n var\r\n P: PChar;\r\n Tmp: string;\r\n begin\r\n Strings.Clear;\r\n Tmp := Value;\r\n UniqueString(Tmp);\r\n P := PChar(Tmp);\r\n// if P^ in [#0, '<', '>'] then\r\n if CharInSet(P^, [#0, '>']) then\r\n Exit;\r\n // skip first word (the tag) and any whitespace\r\n while (P^ <> #0) and (P <> nil) do\r\n begin\r\n if P^ = ' ' then\r\n begin\r\n Inc(P);\r\n Break;\r\n end;\r\n Inc(P);\r\n end;\r\n InnerParseAttributes(P, Strings);\r\n end;\r\n\r\nbegin\r\n if (FKeys.Count = 0) and (FParser.Count <> 0) then\r\n SetParser(FParser);\r\n FContent := Str;\r\n AttributesList := TStringList.Create;\r\n try\r\n if FKeys.Count > 0 then\r\n begin\r\n FTagList.Clear;\r\n for I := 0 to FKeys.Count - 1 do\r\n begin\r\n StartTag1 := TJvParserInfo(FKeys.Objects[I]).StartTag;\r\n Starttag2 := '';\r\n if (Length(StartTag1) > 2) and (StartTag1[Length(StartTag1)] = '>') then\r\n begin\r\n // split the tag so tags with attributes can be found\r\n Delete(StartTag1, Length(StartTag1), 1);\r\n StartTag2 := '>';\r\n end;\r\n J := 1;\r\n while J <> 0 do\r\n begin\r\n // changed from StrSearch(case sensitive) to StrFind (case insensitive)\r\n J := StrFind(StartTag1, Str, J);\r\n if J > 0 then\r\n begin\r\n // changed from StrSearch(case sensitive) to StrFind (case insensitive)\r\n K := StrFind(TJvParserInfo(FKeys.Objects[I]).EndTag, Str, J);\r\n TagInfo.BeginPos := J;\r\n TagInfo.EndPos := K + Length(TJvParserInfo(FKeys.Objects[I]).EndTag);\r\n TagInfo.Key := I;\r\n case TJvParserInfo(FKeys.Objects[I]).TakeText of\r\n 0: //Between limits\r\n begin\r\n if StartTag2 = '' then\r\n TagInfo.BeginContext := J + Length(TJvParserInfo(FKeys.Objects[I]).StartTag)\r\n else\r\n // changed from StrSearch(case sensitive) to StrFind (case insensitive)\r\n TagInfo.BeginContext := StrFind(StartTag2, Str, j) + 1;\r\n TagInfo.EndContext := K;\r\n end;\r\n 1: //All before start tag\r\n begin\r\n TagInfo.BeginContext := 1;\r\n TagInfo.EndContext := J;\r\n end;\r\n 2: //All after start tag\r\n begin\r\n if StartTag2 = '' then\r\n TagInfo.BeginContext := J + Length(TJvParserInfo(FKeys.Objects[I]).StartTag)\r\n else\r\n // changed from StrSearch(case sensitive) to StrFind (case insensitive)\r\n TagInfo.BeginContext := StrFind(StartTag2, Str, j) + 1;\r\n TagInfo.EndContext := Length(Str);\r\n end;\r\n 3: //The whole line if containing start tag\r\n begin\r\n TagInfo.BeginContext := J;\r\n // changed from StrSearch(case sensitive) to StrFind (case insensitive)\r\n TagInfo.EndContext := StrFind(Lf, Str, J);\r\n end;\r\n end;\r\n FTagList.AddValue(TagInfo);\r\n J := J + Length(TJvParserInfo(FKeys.Objects[I]).StartTag);\r\n end;\r\n end;\r\n end;\r\n end;\r\n FTagList.Sort(CompareTags);\r\n with FTagList do\r\n begin\r\n for Index := 0 to Count - 1 do\r\n begin\r\n // Str2 now contains eveything between the start and end tags\r\n Str2 := Copy(Str, PTagInfo(Items[Index]).BeginContext,\r\n PTagInfo(Items[Index]).EndContext - PTagInfo(Items[Index]).BeginContext);\r\n if StartTag2 = '' then\r\n Str3 := ''\r\n else\r\n //Str3 contains the start tag as found, may include attributes or other tags\r\n Str3 := Copy(Str, PTagInfo(Items[Index]).BeginPos,\r\n PTagInfo(Items[Index]).BeginContext - PTagInfo(Items[Index]).BeginPos - 1);\r\n if Assigned(FOnKeyFound) then\r\n FOnKeyFound(Self, FKeys[PTagInfo(Items[Index]).Key], Str2, Str);\r\n if Assigned(FOnKeyFoundEx) then\r\n begin\r\n if Str3 <> '' then\r\n ParseAttributes(AttributesList, Str3)\r\n else\r\n ParseAttributes(AttributesList, Str2);\r\n FOnKeyFoundEx(Self, FKeys[PTagInfo(Items[Index]).Key], Str2, Str,\r\n PTagInfo(Items[Index])^, AttributesList);\r\n end;\r\n end;\r\n end;\r\n finally\r\n AttributesList.Free;\r\n end;\r\nend;\r\n\r\nprocedure TJvHTMLParser.AddCondition(const Keyword: string;\r\n const StartTag: string; const EndTag: string; TextSelection: Integer);\r\nvar\r\n Obj: TJvParserInfo;\r\nbegin\r\n Obj := TJvParserInfo.Create;\r\n Obj.StartTag := StartTag;\r\n Obj.EndTag := EndTag;\r\n Obj.TakeText := TextSelection;\r\n FKeys.AddObject(Keyword, TObject(Obj));\r\nend;\r\n\r\nprocedure TJvHTMLParser.RemoveCondition(Index: Integer);\r\nbegin\r\n FKeys.Objects[Index].Free;\r\n FKeys.Delete(Index);\r\nend;\r\n\r\nprocedure TJvHTMLParser.ClearConditions;\r\nvar\r\n Index: Integer;\r\nbegin\r\n FParser.Clear;\r\n for Index := FKeys.Count - 1 downto 0 do\r\n FKeys.Objects[Index].Free;\r\n FKeys.Clear;\r\nend;\r\n\r\nprocedure TJvHTMLParser.GetCondition(Index: Integer; var Keyword, StartTag, EndTag: string);\r\nbegin\r\n Keyword := FKeys[Index];\r\n StartTag := TJvParserInfo(FKeys.Objects[Index]).StartTag;\r\n EndTag := TJvParserInfo(FKeys.Objects[Index]).EndTag;\r\nend;\r\n\r\nprocedure TJvHTMLParser.GetCondition(Index: Integer; var Keyword, StartTag, EndTag: string;\r\n var TextSelection: Integer);\r\nbegin\r\n GetCondition(Index, Keyword, StartTag, EndTag);\r\n TextSelection := TJvParserInfo(FKeys.Objects[Index]).TakeText;\r\nend;\r\n\r\nfunction TJvHTMLParser.GetConditionsCount: Integer;\r\nbegin\r\n Result := FKeys.Count;\r\nend;\r\n\r\nprocedure TJvHTMLParser.SetTagList(const Value: TTagInfoList);\r\nbegin\r\n FTagList := Value;\r\nend;\r\n\r\n//=== { TTagInfoList } =======================================================\r\n\r\nprocedure TTagInfoList.AddValue(const Value: TTagInfo);\r\nvar\r\n P: PTagInfo;\r\nbegin\r\n GetMem(P, SizeOf(TTagInfo));\r\n if P <> nil then\r\n begin\r\n P^ := Value;\r\n Add(P);\r\n end;\r\nend;\r\n\r\nprocedure TTagInfoList.Clear;\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := 0 to Count - 1 do\r\n FreeMem(Items[I], SizeOf(TTagInfo));\r\n inherited Clear;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvID3v2Base.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvID3v2Base.PAS, released on 2003-04-16.\r\n\r\nThe Initial Developer of the Original Code is Remko Bonte [remkobonte att myrealbox dott com]\r\nPortions created by Remko Bonte are Copyright (C) 2003 Remko Bonte.\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n * Encryption, compression not supported\r\n * Footer in v2.4 tags not supported\r\n * Some tags are not supported, see var DefaultFrameClasses. Values nil in that\r\n list indicate not supported frames.\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvID3v2Base.pas 13415 2012-09-10 09:51:54Z obones $\r\n\r\nunit JvID3v2Base;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n {$IFDEF MSWINDOWS}\r\n Windows,\r\n {$ENDIF MSWINDOWS}\r\n Classes, SysUtils,\r\n JclUnicode,\r\n JvComponentBase, JvId3v2Types, JvId3v1;\r\n\r\nconst\r\n { Only v2.2, v2.3 and v2.4 are supported }\r\n CSupportedVersions = [ive2_2, ive2_3, ive2_4];\r\n\r\ntype\r\n EJvID3Error = class(Exception);\r\n\r\n TJvID3ActivateChangeEvent = procedure(Sender: TObject; Activated: Boolean) of object;\r\n\r\n TJvID3HandleError = (heAutoCorrect, heRaise, heBoolean);\r\n\r\n TJvMPEGLayer = (mlNotDefined, mlLayerIII, mlLayerII, mlLayerI);\r\n TJvMPEGVersion = (mvVersion25, mvReserved, mvVersion2, mvVersion1);\r\n TJvMPEGChannelMode = (mcStereo, mcJointStereo, mcDualChannel, mcSingleChannel);\r\n TJvMPEGBit = (mbProtection, mbPrivate, mbCopyrighted, mbOriginal);\r\n TJvMPEGBits = set of TJvMPEGBit;\r\n TJvMPEGEmphasis = (meNone, me5015ms, meReserved, meCCITJ17);\r\n TJvMPEGModeExtension = (meModeExt0, meModeExt1, meModeExt2, meModeExt3);\r\n\r\n TJvID3ControllerOption = (coAutoCorrect, coRemoveEmptyFrames);\r\n TJvID3ControllerOptions = set of TJvID3ControllerOption;\r\n\r\n TJvID3Event = (\r\n { Fired when the content of 1 or more frames in a tag changes }\r\n ideFrameChange,\r\n { Fired when the whole tag has changed, because of reading/writing }\r\n ideID3Change,\r\n { Fired when frames are added, deleted etc. }\r\n ideFrameListChange);\r\n\r\n TJvID3Controller = class;\r\n\r\n TJvID3Stream = class(TMemoryStream)\r\n private\r\n FReadingFrame: Boolean;\r\n FWritingFrame: Boolean;\r\n FSourceEncoding: TJvID3Encoding;\r\n FDestEncoding: TJvID3Encoding;\r\n\r\n FAllowedEncodings: TJvID3Encodings;\r\n\r\n FStartPosition: Integer;\r\n FCurrentFrameSize: Integer;\r\n procedure MoveToNextFrame;\r\n function GetBytesTillEndOfTag: Longint;\r\n function GetBytesTillEndOfFrame: Longint;\r\n procedure UpdateDestEncoding;\r\n procedure SetSourceEncoding(const Value: TJvID3Encoding);\r\n protected\r\n { ISO-8859-1 }\r\n function ReadStringA(var SA: AnsiString): Longint;\r\n function ReadUserStringA(var SA1, SA2: AnsiString): Longint;\r\n function WriteStringA(const SA: AnsiString): Longint;\r\n function WriteUserStringA(const SA1, SA2: AnsiString): Longint;\r\n function WriteTerminatorA: Longint;\r\n { UTF-16 & UTF-16BE }\r\n function ReadStringW(var SW: WideString): Longint;\r\n function ReadUserStringW(var SW1, SW2: WideString): Longint;\r\n function WriteStringW(const SW: WideString): Longint;\r\n function WriteUserStringW(const SW1, SW2: WideString): Longint;\r\n function WriteTerminatorW: Longint;\r\n { UTF-8 }\r\n function ReadStringUTF8(var SW: WideString): Longint;\r\n function ReadUserStringUTF8(var SW1, SW2: WideString): Longint;\r\n function WriteStringUTF8(const SW: WideString): Longint;\r\n function WriteUserStringUTF8(const SW1, SW2: WideString): Longint;\r\n public\r\n procedure BeginReadFrame(const AFrameSize: Integer);\r\n procedure BeginWriteFrame(const AFrameSize: Integer);\r\n\r\n procedure EndReadFrame;\r\n procedure EndWriteFrame;\r\n\r\n { Inits FAllowedEncodings depending on the wanted version and encoding }\r\n procedure InitAllowedEncodings(const AVersion: TJvID3Version;\r\n const AEncoding: TJvID3ForceEncoding);\r\n\r\n { Checks whether ACount bytes can be read }\r\n function CanRead(const ACount: Cardinal): Boolean;\r\n { Checks whether we are still in the frame }\r\n function InFrame(P: Pointer): Boolean;\r\n\r\n { Read }\r\n function ReadDate(var ADate: TDateTime): Longint;\r\n function ReadLanguage(var Language: AnsiString): Longint;\r\n function ReadNumber(var AValue: Cardinal): Longint;\r\n function ReadEnc(var AEncoding: TJvID3Encoding): Longint;\r\n function ReadStringEnc(var S: WideString): Longint;\r\n function ReadUserString(var S1, S2: WideString): Longint;\r\n { Only for v2.2 }\r\n function ReadFixedNumber3(var AValue: Cardinal): Longint;\r\n { Only for v2.3 }\r\n function ReadFixedNumber(var AValue: Cardinal): Longint;\r\n { Only for v2.4 }\r\n function ReadSyncSafeInteger(var AInt: Cardinal): Longint; overload;\r\n function ReadSyncSafeInteger(var AInt: Cardinal; const ASize: Byte): Longint; overload;\r\n function ReadSyncSafeInteger(var AInt: Int64; const ASize: Byte = 4): Longint; overload;\r\n\r\n procedure ReadFromStream(AStream: TStream; const ASize: Integer);\r\n\r\n { Write }\r\n function WriteDate(const ADate: TDateTime): Longint;\r\n function WriteLanguage(const Language: AnsiString): Longint;\r\n function WriteNumber(AValue: Cardinal): Longint;\r\n function WriteEnc: Longint;\r\n function WritePadding(const Count: Longint): Longint;\r\n function WriteStringEnc(const S: WideString): Longint;\r\n function WriteUserString(const S1, S2: WideString): Longint;\r\n function WriteTerminatorEnc: Longint;\r\n { Only for v2.2 }\r\n function WriteFixedNumber3(AValue: Cardinal): Longint;\r\n { Only for v2.3 }\r\n function WriteFixedNumber(AValue: Cardinal): Longint;\r\n { Only for v2.4 }\r\n function WriteSyncSafeInteger(const AInt: Int64; const ASize: Byte = 4): Longint; overload;\r\n function WriteSyncSafeInteger(const AInt: Cardinal; const ASize: Byte): Longint; overload;\r\n function WriteSyncSafeInteger(const AInt: Cardinal): Longint; overload;\r\n\r\n property BytesTillEndOfFrame: Longint read GetBytesTillEndOfFrame;\r\n property BytesTillEndOfTag: Longint read GetBytesTillEndOfTag;\r\n\r\n { SourceEncoding =\r\n - When reading: encoding of the ID3 stream\r\n - When writing: encoding of current frame in the TJvID3Controller }\r\n property SourceEncoding: TJvID3Encoding read FSourceEncoding write SetSourceEncoding;\r\n { DestEncoding =\r\n - When reading: encoding of current frame in the TJvID3Controller\r\n - When writing: encoding of the ID3 stream }\r\n property DestEncoding: TJvID3Encoding read FDestEncoding;\r\n property AllowedEncodings: TJvID3Encodings read FAllowedEncodings;\r\n end;\r\n\r\n TJvID3Frame = class;\r\n TJvID3Frames = class;\r\n\r\n TJvID3FrameClass = class of TJvID3Frame;\r\n\r\n { Base component for TJvID3Header & TJvID3ExtendedHeader }\r\n TJvID3Base = class(TPersistent)\r\n private\r\n FController: TJvID3Controller;\r\n function GetStream: TJvID3Stream;\r\n protected\r\n procedure Read; virtual; abstract;\r\n procedure Write; virtual; abstract;\r\n procedure Reset; virtual; abstract;\r\n\r\n property Stream: TJvID3Stream read GetStream;\r\n public\r\n constructor Create(AController: TJvID3Controller); virtual;\r\n procedure AfterConstruction; override;\r\n procedure ChangeToVersion(const ANewVersion: TJvID3Version); virtual; abstract;\r\n procedure Assign(Source: TPersistent); override;\r\n property Controller: TJvID3Controller read FController;\r\n end;\r\n\r\n TJvID3Header = class(TJvID3Base)\r\n private\r\n FFlags: TJvID3HeaderFlags;\r\n FHasTag: Boolean;\r\n FMajorVersion: Byte;\r\n FRevisionNumber: Byte;\r\n FSize: Cardinal;\r\n procedure SetFlags(const Value: TJvID3HeaderFlags);\r\n protected\r\n procedure Read; override;\r\n procedure Write; override;\r\n procedure Reset; override;\r\n public\r\n procedure Assign(Source: TPersistent); override;\r\n procedure ChangeToVersion(const ANewVersion: TJvID3Version); override;\r\n published\r\n property MajorVersion: Byte read FMajorVersion;\r\n property RevisionNumber: Byte read FRevisionNumber;\r\n property HasTag: Boolean read FHasTag;\r\n property Flags: TJvID3HeaderFlags read FFlags write SetFlags;\r\n property Size: Cardinal read FSize;\r\n end;\r\n\r\n TJvID3ExtendedHeader = class(TJvID3Base)\r\n private\r\n FFlags: TJvID3HeaderExtendedFlags;\r\n FRestrictions: TJvID3Restrictions;\r\n FSizeOfPadding: Cardinal;\r\n FTotalFrameCRC: Cardinal;\r\n function GetSize: Cardinal;\r\n function GetSizeForVersion(const AVersion: TJvID3Version): Cardinal;\r\n procedure SetFlags(const Value: TJvID3HeaderExtendedFlags);\r\n protected\r\n procedure Read; override;\r\n procedure Write; override;\r\n procedure Reset; override;\r\n public\r\n procedure Assign(Source: TPersistent); override;\r\n procedure ChangeToVersion(const ANewVersion: TJvID3Version); override;\r\n property Size: Cardinal read GetSize;\r\n published\r\n property TotalFrameCRC: Cardinal read FTotalFrameCRC write FTotalFrameCRC;\r\n property SizeOfPadding: Cardinal read FSizeOfPadding;\r\n property Flags: TJvID3HeaderExtendedFlags read FFlags write SetFlags;\r\n end;\r\n\r\n { Base class for all frames }\r\n { TODO : Change to TPersistent? }\r\n TJvID3Frame = class(TComponent)\r\n private\r\n FController: TJvID3Controller;\r\n FFrames: TJvID3Frames;\r\n FFrameID: TJvID3FrameID;\r\n FFrameIDStr: AnsiString;\r\n FFrameSize: Cardinal;\r\n\r\n FDataLengthIndicator: Cardinal; { v2.4 }\r\n FDecompressedSize: Cardinal;\r\n FEncoding: TJvID3Encoding;\r\n FEncryptionID: Byte;\r\n FFlags: TJvID3FrameHeaderFlags;\r\n FGroupID: Byte;\r\n\r\n function GetFrameName: AnsiString;\r\n function GetFrameIDStrForVersion(const Version: TJvID3Version): AnsiString;\r\n function GetIndex: Integer;\r\n function GetStream: TJvID3Stream;\r\n procedure SetController(const AController: TJvID3Controller);\r\n procedure SetEncoding(const Value: TJvID3Encoding);\r\n procedure SetFlags(const Value: TJvID3FrameHeaderFlags);\r\n procedure SetFrameID(const Value: TJvID3FrameID);\r\n procedure SetFrameName(NewFrameName: AnsiString);\r\n procedure SetIndex(const Value: Integer);\r\n protected\r\n procedure Read;\r\n procedure Write;\r\n\r\n procedure ReadEncoding;\r\n procedure ReadFrame; virtual; abstract;\r\n procedure ReadFrameHeader;\r\n procedure WriteEncoding;\r\n procedure WriteFrame; virtual; abstract;\r\n procedure WriteFrameHeader(const AFrameSize: Cardinal);\r\n procedure WriteID;\r\n\r\n procedure ChangeToVersion(const ANewVersion: TJvID3Version); virtual;\r\n function SupportsVersion(const AVersion: TJvID3Version): Boolean; virtual;\r\n\r\n { Checks whether this frame is empty, thus can be removed }\r\n function GetIsEmpty: Boolean; virtual;\r\n\r\n { Checks whether there are no other frames with the same unique\r\n identifier as this frame }\r\n function CheckIsUnique: Boolean;\r\n\r\n procedure CheckFrameID(const AFrameID: TJvID3FrameID);\r\n procedure CheckFrameIDStr(const S: AnsiString);\r\n\r\n { Checks whether Frame has the same unique identifier as this frame }\r\n function SameUniqueIDAs(const Frame: TJvID3Frame): Boolean; virtual;\r\n\r\n function MustWriteAsUTF: Boolean; virtual;\r\n\r\n function GetFrameSize(const ToEncoding: TJvID3Encoding): Cardinal; virtual; abstract;\r\n procedure UpdateFrameSize;\r\n\r\n procedure DataChanged;\r\n procedure Changed; virtual;\r\n\r\n procedure Error(const Msg: string);\r\n procedure ErrorFmt(const Msg: string; const Args: array of const);\r\n\r\n property Stream: TJvID3Stream read GetStream;\r\n public\r\n constructor Create(AOwner: TComponent; const AFrameID: TJvID3FrameID;\r\n const AFrameIDStr: AnsiString = ''); reintroduce; virtual;\r\n destructor Destroy; override;\r\n\r\n class function CanAddFrame(AController: TJvID3Controller; AFrameID: TJvID3FrameID): Boolean; virtual;\r\n function CheckFrame(const HandleError: TJvID3HandleError): Boolean; virtual;\r\n\r\n procedure Assign(Source: TPersistent); override;\r\n procedure Clear; virtual;\r\n property Controller: TJvID3Controller read FController write SetController stored False;\r\n property FrameSize: Cardinal read FFrameSize;\r\n\r\n property IsEmpty: Boolean read GetIsEmpty;\r\n published\r\n property Encoding: TJvID3Encoding read FEncoding write SetEncoding;\r\n property EncryptionID: Byte read FEncryptionID write FEncryptionID;\r\n property Flags: TJvID3FrameHeaderFlags read FFlags write SetFlags;\r\n property FrameID: TJvID3FrameID read FFrameID write SetFrameID;\r\n property FrameName: AnsiString read GetFrameName write SetFrameName;\r\n property GroupID: Byte read FGroupID write FGroupID;\r\n property Index: Integer read GetIndex write SetIndex stored False;\r\n end;\r\n\r\n TJvID3Frames = class(TJvID3Base)\r\n private\r\n FList: TList;\r\n protected\r\n procedure Changed;\r\n\r\n procedure CheckCanAddFrame(FrameID: TJvID3FrameID);\r\n\r\n procedure Read; override;\r\n procedure Write; override;\r\n procedure Reset; override;\r\n\r\n function GetCount: Integer;\r\n function GetFrame(Index: Integer): TJvID3Frame;\r\n procedure SetFrame(Index: Integer; Value: TJvID3Frame);\r\n procedure SetFrameIndex(Frame: TJvID3Frame; Value: Integer);\r\n public\r\n procedure AfterConstruction; override;\r\n procedure BeforeDestruction; override;\r\n\r\n procedure Assign(Source: TPersistent); override;\r\n\r\n procedure Add(Frame: TJvID3Frame);\r\n procedure Clear;\r\n function FindFrame(const FrameName: AnsiString): TJvID3Frame; overload;\r\n function FindFrame(const FrameID: TJvID3FrameID): TJvID3Frame; overload;\r\n function FrameByName(const FrameName: AnsiString): TJvID3Frame;\r\n function FrameByID(const FrameID: TJvID3FrameID): TJvID3Frame;\r\n procedure GetFrameNames(List: TStrings);\r\n function GetFrameIDs: TJvID3FrameIDs;\r\n\r\n procedure ChangeToVersion(const ANewVersion: TJvID3Version); override;\r\n function IndexOf(Frame: TJvID3Frame): Integer;\r\n function CheckIsUnique(Frame: TJvID3Frame): Boolean;\r\n function CheckFrames(const HandleError: TJvID3HandleError): Boolean;\r\n procedure RemoveEmptyFrames;\r\n procedure Remove(Frame: TJvID3Frame);\r\n property Count: Integer read GetCount;\r\n property Frames[Index: Integer]: TJvID3Frame read GetFrame write SetFrame; default;\r\n end;\r\n\r\n { MCDI - fiCDID - Music CD identifier\r\n\r\n There may only be one 'MCDI' frame in each tag.\r\n }\r\n\r\n TJvID3BinaryFrame = class(TJvID3Frame)\r\n private\r\n FData: PByte;\r\n FDataSize: Cardinal;\r\n protected\r\n procedure ReadData(ASize: Cardinal); virtual;\r\n procedure WriteData; virtual;\r\n\r\n procedure ReadFrame; override;\r\n procedure WriteFrame; override;\r\n\r\n function GetFrameSize(const ToEncoding: TJvID3Encoding): Cardinal; override;\r\n function GetIsEmpty: Boolean; override;\r\n\r\n function SameUniqueIDAs(const Frame: TJvID3Frame): Boolean; override;\r\n public\r\n class function CanAddFrame(AController: TJvID3Controller; AFrameID: TJvID3FrameID): Boolean; override;\r\n function CheckFrame(const HandleError: TJvID3HandleError): Boolean; override;\r\n\r\n procedure Assign(Source: TPersistent); override;\r\n procedure Clear; override;\r\n\r\n class function Find(AController: TJvID3Controller; const AFrameID: TJvID3FrameID): TJvID3BinaryFrame;\r\n class function FindOrCreate(AController: TJvID3Controller; const AFrameID: TJvID3FrameID): TJvID3BinaryFrame;\r\n\r\n procedure AfterConstruction; override;\r\n procedure BeforeDestruction; override;\r\n\r\n function SetData(P: Pointer; const Size: Cardinal): Boolean;\r\n function GetData(P: Pointer; const Size: Cardinal): Boolean;\r\n\r\n procedure LoadFromFile(const FileName: string); virtual;\r\n procedure SaveToFile(const FileName: string); virtual;\r\n procedure LoadFromStream(Stream: TStream); virtual;\r\n procedure SaveToStream(Stream: TStream); virtual;\r\n\r\n property DataSize: Cardinal read FDataSize;\r\n end;\r\n\r\n TJvID3SkipFrame = class(TJvID3BinaryFrame)\r\n protected\r\n procedure ChangeToVersion(const ANewVersion: TJvID3Version); override;\r\n end;\r\n\r\n { IPLS - fiInvolvedPeople - Involved people list\r\n\r\n There may only be one \"IPLS\" frame in each tag.\r\n\r\n TIPL - fiInvolvedPeople2 - Involved people list\r\n TMCL - fiMusicianCreditList - Musician credits list\r\n\r\n There may only be one text information frame of its kind in an tag\r\n }\r\n\r\n TJvID3DoubleListFrame = class(TJvID3Frame)\r\n private\r\n FList: {$IFDEF COMPILER12_UP}TStrings{$ELSE}TWideStrings{$ENDIF COMPILER12_UP};\r\n procedure ListChanged(Sender: TObject);\r\n procedure SetList(Value: {$IFDEF COMPILER12_UP}TStrings{$ELSE}TWideStrings{$ENDIF COMPILER12_UP});\r\n function GetNames(const Index: Integer): WideString;\r\n function GetValues(const Index: Integer): WideString;\r\n protected\r\n procedure ReadFrame; override;\r\n procedure WriteFrame; override;\r\n\r\n function GetFrameSize(const ToEncoding: TJvID3Encoding): Cardinal; override;\r\n function GetIsEmpty: Boolean; override;\r\n function MustWriteAsUTF: Boolean; override;\r\n\r\n procedure ChangeToVersion(const ANewVersion: TJvID3Version); override;\r\n function SupportsVersion(const AVersion: TJvID3Version): Boolean; override;\r\n function SameUniqueIDAs(const Frame: TJvID3Frame): Boolean; override;\r\n public\r\n class function CanAddFrame(AController: TJvID3Controller; AFrameID: TJvID3FrameID): Boolean; override;\r\n function CheckFrame(const HandleError: TJvID3HandleError): Boolean; override;\r\n\r\n procedure Assign(Source: TPersistent); override;\r\n procedure Clear; override;\r\n\r\n class function Find(AController: TJvID3Controller; const AFrameID: TJvID3FrameID): TJvID3DoubleListFrame;\r\n class function FindOrCreate(AController: TJvID3Controller; const AFrameID: TJvID3FrameID): TJvID3DoubleListFrame;\r\n\r\n procedure AfterConstruction; override;\r\n procedure BeforeDestruction; override;\r\n\r\n property Names[const Index: Integer]: WideString read GetNames;\r\n property Values[const Index: Integer]: WideString read GetValues;\r\n published\r\n property List: {$IFDEF COMPILER12_UP}TStrings{$ELSE}TWideStrings{$ENDIF COMPILER12_UP} read FList write SetList;\r\n end;\r\n\r\n { COMM - fiComment - Comments\r\n\r\n There may be more than one comment frame in each tag, but only one with\r\n the same language and content descriptor.\r\n\r\n USLT - fiUnsyncedLyrics - Unsynchronized lyric/text transcription\r\n\r\n There may be more than one 'Unsynchronised lyrics/text transcription' frame\r\n in each tag, but only one with the same language and content descriptor.\r\n }\r\n\r\n TJvID3ContentFrame = class(TJvID3Frame)\r\n private\r\n FLanguage: AnsiString;\r\n FText: WideString;\r\n FDescription: WideString;\r\n procedure SetDescription(const Value: WideString);\r\n procedure SetLanguage(const Value: AnsiString);\r\n procedure SetText(const Value: WideString);\r\n protected\r\n procedure ReadFrame; override;\r\n procedure WriteFrame; override;\r\n\r\n function GetFrameSize(const ToEncoding: TJvID3Encoding): Cardinal; override;\r\n function GetIsEmpty: Boolean; override;\r\n function MustWriteAsUTF: Boolean; override;\r\n\r\n function SameUniqueIDAs(const Frame: TJvID3Frame): Boolean; override;\r\n public\r\n class function CanAddFrame(AController: TJvID3Controller; AFrameID: TJvID3FrameID): Boolean; override;\r\n function CheckFrame(const HandleError: TJvID3HandleError): Boolean; override;\r\n\r\n procedure Assign(Source: TPersistent); override;\r\n procedure Clear; override;\r\n\r\n class function Find(AController: TJvID3Controller; const AFrameID: TJvID3FrameID): TJvID3ContentFrame;\r\n class function FindOrCreate(AController: TJvID3Controller; const AFrameID: TJvID3FrameID): TJvID3ContentFrame;\r\n published\r\n property Language: AnsiString read FLanguage write SetLanguage;\r\n property Description: WideString read FDescription write SetDescription;\r\n property Text: WideString read FText write SetText;\r\n end;\r\n\r\n { GEOB - fiGeneralObject - General encapsulated object\r\n\r\n There may be more than one \"GEOB\" frame in each tag, but only one with the\r\n same content descriptor\r\n }\r\n\r\n TJvID3GeneralObjFrame = class(TJvID3BinaryFrame)\r\n private\r\n FContentDescription: WideString;\r\n FMIMEType: AnsiString;\r\n FFileName: WideString;\r\n procedure SetContentDescription(const Value: WideString);\r\n procedure SetFileName(const Value: WideString);\r\n procedure SetMIMEType(const Value: AnsiString);\r\n protected\r\n procedure ReadFrame; override;\r\n procedure WriteFrame; override;\r\n\r\n function GetFrameSize(const ToEncoding: TJvID3Encoding): Cardinal; override;\r\n function GetIsEmpty: Boolean; override;\r\n function MustWriteAsUTF: Boolean; override;\r\n\r\n function SameUniqueIDAs(const Frame: TJvID3Frame): Boolean; override;\r\n public\r\n class function CanAddFrame(AController: TJvID3Controller; AFrameID: TJvID3FrameID): Boolean; override;\r\n function CheckFrame(const HandleError: TJvID3HandleError): Boolean; override;\r\n\r\n procedure Assign(Source: TPersistent); override;\r\n procedure Clear; override;\r\n\r\n class function Find(AController: TJvID3Controller): TJvID3GeneralObjFrame; overload;\r\n class function Find(AController: TJvID3Controller; const AContentDescription: WideString): TJvID3GeneralObjFrame; overload;\r\n class function FindOrCreate(AController: TJvID3Controller): TJvID3GeneralObjFrame; overload;\r\n class function FindOrCreate(AController: TJvID3Controller; const AContentDescription: WideString): TJvID3GeneralObjFrame; overload;\r\n published\r\n property MIMEType: AnsiString read FMIMEType write SetMIMEType;\r\n property FileName: WideString read FFileName write SetFileName;\r\n property ContentDescription: WideString read FContentDescription write SetContentDescription;\r\n end;\r\n\r\n { POPM - fiPopularimeter - Popularimeter\r\n\r\n There may be more than one \"POPM\" frame in each tag, but only one with the\r\n same email address.\r\n }\r\n\r\n TJvID3PopularimeterFrame = class(TJvID3Frame)\r\n private\r\n FRating: Byte;\r\n FCounter: Cardinal;\r\n FEMailAddress: AnsiString;\r\n procedure SetCounter(const Value: Cardinal);\r\n procedure SetEMailAddress(const Value: AnsiString);\r\n procedure SetRating(const Value: Byte);\r\n protected\r\n procedure ReadFrame; override;\r\n procedure WriteFrame; override;\r\n\r\n function GetFrameSize(const ToEncoding: TJvID3Encoding): Cardinal; override;\r\n function GetIsEmpty: Boolean; override;\r\n\r\n function SameUniqueIDAs(const Frame: TJvID3Frame): Boolean; override;\r\n public\r\n class function CanAddFrame(AController: TJvID3Controller; AFrameID: TJvID3FrameID): Boolean; override;\r\n function CheckFrame(const HandleError: TJvID3HandleError): Boolean; override;\r\n\r\n procedure Assign(Source: TPersistent); override;\r\n procedure Clear; override;\r\n\r\n class function Find(AController: TJvID3Controller): TJvID3PopularimeterFrame; overload;\r\n class function Find(AController: TJvID3Controller; const AEmailAddress: AnsiString): TJvID3PopularimeterFrame; overload;\r\n class function FindOrCreate(AController: TJvID3Controller): TJvID3PopularimeterFrame; overload;\r\n class function FindOrCreate(AController: TJvID3Controller; const AEmailAddress: AnsiString): TJvID3PopularimeterFrame; overload;\r\n published\r\n property EMailAddress: AnsiString read FEMailAddress write SetEMailAddress;\r\n property Rating: Byte read FRating write SetRating;\r\n property Counter: Cardinal read FCounter write SetCounter;\r\n end;\r\n\r\n { PCNT - fiPlayCounter - Play counter\r\n\r\n There may only be one \"PCNT\" frame in each tag.\r\n }\r\n\r\n TJvID3PlayCounterFrame = class(TJvID3Frame)\r\n private\r\n FCounter: Cardinal;\r\n procedure SetCounter(const Value: Cardinal);\r\n protected\r\n procedure ReadFrame; override;\r\n procedure WriteFrame; override;\r\n\r\n function GetFrameSize(const ToEncoding: TJvID3Encoding): Cardinal; override;\r\n function GetIsEmpty: Boolean; override;\r\n\r\n function SameUniqueIDAs(const Frame: TJvID3Frame): Boolean; override;\r\n public\r\n class function CanAddFrame(AController: TJvID3Controller; AFrameID: TJvID3FrameID): Boolean; override;\r\n function CheckFrame(const HandleError: TJvID3HandleError): Boolean; override;\r\n\r\n procedure Assign(Source: TPersistent); override;\r\n procedure Clear; override;\r\n\r\n class function Find(AController: TJvID3Controller): TJvID3PlayCounterFrame;\r\n class function FindOrCreate(AController: TJvID3Controller): TJvID3PlayCounterFrame;\r\n published\r\n property Counter: Cardinal read FCounter write SetCounter;\r\n end;\r\n\r\n { AENC - fiAudioCrypto - Audio encryption\r\n\r\n There may be more than one \"AENC\" frames in a tag, but only one with\r\n the same 'Owner identifier'.\r\n }\r\n\r\n TJvID3AudioEncryptionFrame = class(TJvID3BinaryFrame)\r\n private\r\n FOwnerID: AnsiString;\r\n FPreviewStart: Word;\r\n FPreviewLength: Word;\r\n procedure SetOwnerID(const Value: AnsiString);\r\n procedure SetPreviewLength(const Value: Word);\r\n procedure SetPreviewStart(const Value: Word);\r\n protected\r\n procedure ReadFrame; override;\r\n procedure WriteFrame; override;\r\n\r\n function GetFrameSize(const ToEncoding: TJvID3Encoding): Cardinal; override;\r\n function GetIsEmpty: Boolean; override;\r\n\r\n function SameUniqueIDAs(const Frame: TJvID3Frame): Boolean; override;\r\n public\r\n class function CanAddFrame(AController: TJvID3Controller; AFrameID: TJvID3FrameID): Boolean; override;\r\n function CheckFrame(const HandleError: TJvID3HandleError): Boolean; override;\r\n\r\n procedure Assign(Source: TPersistent); override;\r\n procedure Clear; override;\r\n\r\n class function Find(AController: TJvID3Controller; const AOwnerID: AnsiString): TJvID3AudioEncryptionFrame;\r\n class function FindOrCreate(AController: TJvID3Controller; const AOwnerID: AnsiString): TJvID3AudioEncryptionFrame;\r\n published\r\n property OwnerID: AnsiString read FOwnerID write SetOwnerID;\r\n property PreviewStart: Word read FPreviewStart write SetPreviewStart;\r\n property PreviewLength: Word read FPreviewLength write SetPreviewLength;\r\n end;\r\n\r\n { USER - fiTermsOfUse - Terms of use\r\n\r\n There may only be one \"USER\" frame in a tag.\r\n }\r\n\r\n TJvID3TermsOfUseFrame = class(TJvID3Frame)\r\n private\r\n FText: WideString;\r\n FLanguage: AnsiString;\r\n procedure SetLanguage(const Value: AnsiString);\r\n procedure SetText(const Value: WideString);\r\n protected\r\n procedure ReadFrame; override;\r\n procedure WriteFrame; override;\r\n\r\n function GetFrameSize(const ToEncoding: TJvID3Encoding): Cardinal; override;\r\n function GetIsEmpty: Boolean; override;\r\n function MustWriteAsUTF: Boolean; override;\r\n\r\n function SupportsVersion(const AVersion: TJvID3Version): Boolean; override;\r\n function SameUniqueIDAs(const Frame: TJvID3Frame): Boolean; override;\r\n public\r\n class function CanAddFrame(AController: TJvID3Controller; AFrameID: TJvID3FrameID): Boolean; override;\r\n function CheckFrame(const HandleError: TJvID3HandleError): Boolean; override;\r\n\r\n procedure Assign(Source: TPersistent); override;\r\n procedure Clear; override;\r\n\r\n class function Find(AController: TJvID3Controller): TJvID3TermsOfUseFrame;\r\n class function FindOrCreate(AController: TJvID3Controller): TJvID3TermsOfUseFrame;\r\n published\r\n property Language: AnsiString read FLanguage write SetLanguage;\r\n property Text: WideString read FText write SetText;\r\n end;\r\n\r\n { OWNE - fiOwnership - Ownership frame\r\n\r\n There may only be one \"OWNE\" frame in a tag.\r\n }\r\n\r\n TJvID3OwnershipFrame = class(TJvID3Frame)\r\n private\r\n FPricePayed: AnsiString;\r\n FSeller: WideString;\r\n FDateOfPurch: TDateTime;\r\n procedure SetDateOfPurch(const Value: TDateTime);\r\n procedure SetPricePayed(const Value: AnsiString);\r\n procedure SetSeller(const Value: WideString);\r\n protected\r\n procedure ReadFrame; override;\r\n procedure WriteFrame; override;\r\n\r\n function GetFrameSize(const ToEncoding: TJvID3Encoding): Cardinal; override;\r\n function GetIsEmpty: Boolean; override;\r\n function MustWriteAsUTF: Boolean; override;\r\n\r\n function SupportsVersion(const AVersion: TJvID3Version): Boolean; override;\r\n function SameUniqueIDAs(const Frame: TJvID3Frame): Boolean; override;\r\n public\r\n class function CanAddFrame(AController: TJvID3Controller; AFrameID: TJvID3FrameID): Boolean; override;\r\n function CheckFrame(const HandleError: TJvID3HandleError): Boolean; override;\r\n\r\n procedure Assign(Source: TPersistent); override;\r\n procedure Clear; override;\r\n\r\n class function Find(AController: TJvID3Controller): TJvID3OwnershipFrame;\r\n class function FindOrCreate(AController: TJvID3Controller): TJvID3OwnershipFrame;\r\n published\r\n property PricePayed: AnsiString read FPricePayed write SetPricePayed;\r\n property DateOfPurch: TDateTime read FDateOfPurch write SetDateOfPurch;\r\n property Seller: WideString read FSeller write SetSeller;\r\n end;\r\n\r\n { APIC - fiPicture - Attached picture\r\n\r\n There may be several pictures attached to one file, each in their individual\r\n \"APIC\" frame, but only one with the same content descriptor(*). There may only\r\n be one picture with the picture type declared as picture type $01 and $02 (**)\r\n respectively.\r\n\r\n (*) content descriptor = FPictureType, FDescription\r\n (**) $01 = ptFileIcon; $02 = ptOtherFileIcon\r\n }\r\n\r\n TJvID3PictureFrame = class(TJvID3BinaryFrame)\r\n private\r\n FMIMEType: AnsiString;\r\n FPictureType: TJvID3PictureType;\r\n FDescription: WideString;\r\n FURL: AnsiString;\r\n procedure SetDescription(const Value: WideString);\r\n procedure SetMIMEType(const Value: AnsiString);\r\n procedure SetURL(const Value: AnsiString);\r\n function GetHasOnlyURL: Boolean;\r\n protected\r\n procedure ReadFrame; override;\r\n procedure WriteFrame; override;\r\n\r\n function GetFrameSize(const ToEncoding: TJvID3Encoding): Cardinal; override;\r\n function GetIsEmpty: Boolean; override;\r\n function MustWriteAsUTF: Boolean; override;\r\n\r\n function SameUniqueIDAs(const Frame: TJvID3Frame): Boolean; override;\r\n\r\n procedure AssignTo(Dest: TPersistent); override;\r\n\r\n { There is the possibility to put only a link to the image file by using the 'MIME\r\n type' \"-->\" and having a complete URL [URL] instead of picture data.\r\n The use of linked files should however be used sparingly since there\r\n is the risk of separation of files: }\r\n property HasOnlyURL: Boolean read GetHasOnlyURL;\r\n public\r\n class function CanAddFrame(AController: TJvID3Controller; AFrameID: TJvID3FrameID): Boolean; override;\r\n function CheckFrame(const HandleError: TJvID3HandleError): Boolean; override;\r\n\r\n procedure Assign(Source: TPersistent); override;\r\n procedure Clear; override;\r\n\r\n class function Find(AController: TJvID3Controller; const AType: TJvID3PictureType): TJvID3PictureFrame;\r\n class function FindOrCreate(AController: TJvID3Controller; const AType: TJvID3PictureType): TJvID3PictureFrame;\r\n published\r\n property MIMEType: AnsiString read FMIMEType write SetMIMEType;\r\n property PictureType: TJvID3PictureType read FPictureType write FPictureType;\r\n property Description: WideString read FDescription write SetDescription;\r\n { Only used when MIMEType = '-->' }\r\n property URL: AnsiString read FURL write SetURL;\r\n end;\r\n\r\n TJvID3CustomTextFrame = class(TJvID3Frame)\r\n protected\r\n function GetText: WideString; virtual; abstract;\r\n procedure SetText(const ANewText: WideString); virtual; abstract;\r\n\r\n procedure ReadFrame; override;\r\n procedure WriteFrame; override;\r\n\r\n function GetFrameSize(const ToEncoding: TJvID3Encoding): Cardinal; override;\r\n function GetIsEmpty: Boolean; override;\r\n function MustWriteAsUTF: Boolean; override;\r\n\r\n function SupportsVersion(const AVersion: TJvID3Version): Boolean; override;\r\n function SameUniqueIDAs(const Frame: TJvID3Frame): Boolean; override;\r\n public\r\n class function CanAddFrame(AController: TJvID3Controller; AFrameID: TJvID3FrameID): Boolean; override;\r\n\r\n procedure Assign(Source: TPersistent); override;\r\n procedure Clear; override;\r\n\r\n property Text: WideString read GetText write SetText;\r\n end;\r\n\r\n TJvID3SimpleListFrame = class(TJvID3CustomTextFrame)\r\n private\r\n FList: {$IFDEF COMPILER12_UP}TStrings{$ELSE}TWideStrings{$ENDIF COMPILER12_UP};\r\n procedure SetList(Value: {$IFDEF COMPILER12_UP}TStrings{$ELSE}TWideStrings{$ENDIF COMPILER12_UP});\r\n function GetSeparator: WideChar;\r\n function GetFixedStringLength: Integer;\r\n procedure ListChanged(Sender: TObject);\r\n function GetIsNullSeparator: Boolean;\r\n protected\r\n function GetText: WideString; override;\r\n procedure SetText(const ANewText: WideString); override;\r\n\r\n procedure ReadFrame; override;\r\n procedure WriteFrame; override;\r\n\r\n function GetFrameSize(const ToEncoding: TJvID3Encoding): Cardinal; override;\r\n public\r\n function CheckFrame(const HandleError: TJvID3HandleError): Boolean; override;\r\n class function Find(AController: TJvID3Controller; const AFrameID: TJvID3FrameID): TJvID3SimpleListFrame;\r\n class function FindOrCreate(AController: TJvID3Controller; const AFrameID: TJvID3FrameID): TJvID3SimpleListFrame;\r\n\r\n procedure AfterConstruction; override;\r\n procedure BeforeDestruction; override;\r\n\r\n property FixedStringLength: Integer read GetFixedStringLength;\r\n property Separator: WideChar read GetSeparator;\r\n property IsNullSeparator: Boolean read GetIsNullSeparator;\r\n published\r\n property List: {$IFDEF COMPILER12_UP}TStrings{$ELSE}TWideStrings{$ENDIF COMPILER12_UP} read FList write SetList;\r\n end;\r\n\r\n TJvID3NumberFrame = class(TJvID3CustomTextFrame)\r\n private\r\n FValue: Cardinal;\r\n procedure SetValue(const AValue: Cardinal);\r\n protected\r\n function GetText: WideString; override;\r\n procedure SetText(const ANewText: WideString); override;\r\n procedure ChangeToVersion(const ANewVersion: TJvID3Version); override;\r\n function GetIsEmpty: Boolean; override;\r\n public\r\n function CheckFrame(const HandleError: TJvID3HandleError): Boolean; override;\r\n class function Find(AController: TJvID3Controller; const AFrameID: TJvID3FrameID): TJvID3NumberFrame;\r\n class function FindOrCreate(AController: TJvID3Controller; const AFrameID: TJvID3FrameID): TJvID3NumberFrame;\r\n published\r\n property Value: Cardinal read FValue write SetValue;\r\n end;\r\n\r\n TJvID3TimestampFrame = class(TJvID3CustomTextFrame)\r\n private\r\n FValue: TDateTime;\r\n procedure SetValue(const AValue: TDateTime);\r\n protected\r\n function GetText: WideString; override;\r\n procedure SetText(const ANewText: WideString); override;\r\n procedure ChangeToVersion(const ANewVersion: TJvID3Version); override;\r\n public\r\n function CheckFrame(const HandleError: TJvID3HandleError): Boolean; override;\r\n class function Find(AController: TJvID3Controller; const AFrameID: TJvID3FrameID): TJvID3TimestampFrame;\r\n class function FindOrCreate(AController: TJvID3Controller; const AFrameID: TJvID3FrameID): TJvID3TimestampFrame;\r\n published\r\n property Value: TDateTime read FValue write SetValue;\r\n end;\r\n\r\n TJvID3TextFrame = class(TJvID3CustomTextFrame)\r\n private\r\n FText: WideString;\r\n protected\r\n function GetText: WideString; override;\r\n procedure SetText(const ANewText: WideString); override;\r\n procedure ChangeToVersion(const ANewVersion: TJvID3Version); override;\r\n public\r\n function CheckFrame(const HandleError: TJvID3HandleError): Boolean; override;\r\n class function Find(AController: TJvID3Controller; const AFrameID: TJvID3FrameID): TJvID3TextFrame;\r\n class function FindOrCreate(AController: TJvID3Controller; const AFrameID: TJvID3FrameID): TJvID3TextFrame;\r\n published\r\n property Text;\r\n end;\r\n\r\n TJvID3URLFrame = class(TJvID3Frame)\r\n private\r\n FURL: AnsiString;\r\n procedure SetURL(const Value: AnsiString);\r\n protected\r\n procedure ReadFrame; override;\r\n procedure WriteFrame; override;\r\n\r\n function GetFrameSize(const ToEncoding: TJvID3Encoding): Cardinal; override;\r\n function GetIsEmpty: Boolean; override;\r\n\r\n function SameUniqueIDAs(const Frame: TJvID3Frame): Boolean; override;\r\n public\r\n class function CanAddFrame(AController: TJvID3Controller; AFrameID: TJvID3FrameID): Boolean; override;\r\n function CheckFrame(const HandleError: TJvID3HandleError): Boolean; override;\r\n\r\n procedure Assign(Source: TPersistent); override;\r\n procedure Clear; override;\r\n\r\n class function Find(AController: TJvID3Controller; const AFrameID: TJvID3FrameID): TJvID3URLFrame;\r\n class function FindOrCreate(AController: TJvID3Controller; const AFrameID: TJvID3FrameID): TJvID3URLFrame;\r\n published\r\n property URL: AnsiString read FURL write SetURL;\r\n end;\r\n\r\n { TXXX - fiUserText - User defined text information\r\n }\r\n\r\n TJvID3UserFrame = class(TJvID3Frame)\r\n private\r\n FValue: WideString;\r\n FDescription: WideString;\r\n procedure SetDescription(const AValue: WideString);\r\n procedure SetValue(const AValue: WideString);\r\n protected\r\n procedure ReadFrame; override;\r\n procedure WriteFrame; override;\r\n\r\n function GetFrameSize(const ToEncoding: TJvID3Encoding): Cardinal; override;\r\n function GetIsEmpty: Boolean; override;\r\n function MustWriteAsUTF: Boolean; override;\r\n public\r\n class function CanAddFrame(AController: TJvID3Controller; AFrameID: TJvID3FrameID): Boolean; override;\r\n function CheckFrame(const HandleError: TJvID3HandleError): Boolean; override;\r\n\r\n procedure Assign(Source: TPersistent); override;\r\n procedure Clear; override;\r\n\r\n class function Find(AController: TJvID3Controller; const Index: Integer): TJvID3UserFrame;\r\n class function FindOrCreate(AController: TJvID3Controller; const Index: Integer): TJvID3UserFrame;\r\n published\r\n property Description: WideString read FDescription write SetDescription;\r\n property Value: WideString read FValue write SetValue;\r\n end;\r\n\r\n { WXXX - fiWWWUser - User defined URL link\r\n }\r\n\r\n TJvID3URLUserFrame = class(TJvID3Frame)\r\n private\r\n FDescription: WideString;\r\n FURL: AnsiString;\r\n procedure SetDescription(const Value: WideString);\r\n procedure SetURL(const Value: AnsiString);\r\n protected\r\n procedure ReadFrame; override;\r\n procedure WriteFrame; override;\r\n\r\n function GetFrameSize(const ToEncoding: TJvID3Encoding): Cardinal; override;\r\n function GetIsEmpty: Boolean; override;\r\n function MustWriteAsUTF: Boolean; override;\r\n public\r\n class function CanAddFrame(AController: TJvID3Controller; AFrameID: TJvID3FrameID): Boolean; override;\r\n function CheckFrame(const HandleError: TJvID3HandleError): Boolean; override;\r\n\r\n procedure Assign(Source: TPersistent); override;\r\n procedure Clear; override;\r\n\r\n class function Find(AController: TJvID3Controller; const Index: Integer): TJvID3URLUserFrame;\r\n class function FindOrCreate(AController: TJvID3Controller; const Index: Integer): TJvID3URLUserFrame;\r\n published\r\n property Description: WideString read FDescription write SetDescription;\r\n property URL: AnsiString read FURL write SetURL;\r\n end;\r\n\r\n TJvID3FileInfo = class(TPersistent)\r\n private\r\n FAudioSize: Int64;\r\n FBitrate: Integer;\r\n FBits: TJvMPEGBits;\r\n FChannelMode: TJvMPEGChannelMode;\r\n FEmphasis: TJvMPEGEmphasis;\r\n FFileSize: Int64;\r\n FFrameCount: Integer;\r\n FFrameLengthInBytes: Integer;\r\n FHasID3v1Tag: Boolean;\r\n FHeaderFoundAt: Int64;\r\n FIsVBR: Boolean;\r\n FLayer: TJvMPEGLayer;\r\n FLengthInSec: Integer;\r\n FModeExtension: TJvMPEGModeExtension;\r\n FPaddingLength: Integer;\r\n FSamplingRateFrequency: Integer;\r\n FVersion: TJvMPEGVersion;\r\n function GetIsValid: Boolean;\r\n protected\r\n procedure Calc;\r\n procedure ParseMPEGTag(AMPEGTag: PAnsiChar);\r\n procedure ParseVbrTag(AMPEGTag: PAnsiChar);\r\n procedure Reset;\r\n public\r\n procedure Read(AStream: TStream; const Offset: Int64);\r\n\r\n property Bitrate: Integer read FBitrate;\r\n property Bits: TJvMPEGBits read FBits;\r\n property ChannelMode: TJvMPEGChannelMode read FChannelMode;\r\n property Emphasis: TJvMPEGEmphasis read FEmphasis;\r\n property FileSize: Int64 read FFileSize;\r\n property FrameCount: Integer read FFrameCount;\r\n property FrameLengthInBytes: Integer read FFrameLengthInBytes;\r\n property HeaderFoundAt: Int64 read FHeaderFoundAt;\r\n property IsValid: Boolean read GetIsValid;\r\n property IsVBR: Boolean read FIsVBR;\r\n property Layer: TJvMPEGLayer read FLayer;\r\n property LengthInSec: Integer read FLengthInSec;\r\n property ModeExtension: TJvMPEGModeExtension read FModeExtension;\r\n property SamplingRateFrequency: Integer read FSamplingRateFrequency;\r\n property Version: TJvMPEGVersion read FVersion;\r\n end;\r\n\r\n TJvID3ControllerDesigner = class(TObject)\r\n private\r\n FController: TJvID3Controller;\r\n public\r\n constructor Create(Controller: TJvID3Controller);\r\n destructor Destroy; override;\r\n procedure BeginDesign;\r\n procedure ID3Event(Event: TJvID3Event; Info: Longint); virtual;\r\n procedure EndDesign;\r\n property Controller: TJvID3Controller read FController;\r\n end;\r\n\r\n TJvID3ControllerState = (icsReading, icsWriting, icsUsingTempStream);\r\n TJvID3ControllerStates = set of TJvID3ControllerState;\r\n\r\n TJvID3Controller = class(TJvComponent)\r\n private\r\n FState: TJvID3ControllerStates;\r\n FStream: TJvID3Stream;\r\n FTempStream: TJvID3Stream;\r\n FFrames: TJvID3Frames;\r\n FClients: TList;\r\n FActivateEvents: TList;\r\n\r\n FFileInfo: TJvID3FileInfo;\r\n FHeader: TJvID3Header;\r\n FExtendedHeader: TJvID3ExtendedHeader;\r\n FActive: Boolean;\r\n FStreamedActive: Boolean;\r\n FFileName: TFileName;\r\n FDesigner: TJvID3ControllerDesigner;\r\n FModified: Boolean;\r\n FOptions: TJvID3ControllerOptions;\r\n FWriteEncodingAs: TJvID3ForceEncoding;\r\n FReadEncodingAs: TJvID3ForceEncoding;\r\n FReadVersionAs: TJvID3ForceVersion;\r\n FWriteVersionAs: TJvID3ForceVersion;\r\n FUpdateCount: Integer;\r\n function GetFrameCount: Integer;\r\n function GetReadVersion: TJvID3Version;\r\n function GetTagSize: Cardinal;\r\n function GetVersion: TJvID3Version;\r\n function GetWriteVersion: TJvID3Version;\r\n procedure SetActive(const Value: Boolean);\r\n procedure SetExtendedHeader(const Value: TJvID3ExtendedHeader);\r\n procedure SetFileName(const Value: TFileName);\r\n procedure SetHeader(const Value: TJvID3Header);\r\n procedure SetReadEncodingAs(const Value: TJvID3ForceEncoding);\r\n procedure SetReadVersionAs(const Value: TJvID3ForceVersion);\r\n procedure SetVersion(NewVersion: TJvID3Version);\r\n procedure SetWriteEncodingAs(const Value: TJvID3ForceEncoding);\r\n procedure SetWriteVersionAs(const Value: TJvID3ForceVersion);\r\n protected\r\n class function GetFrameClass(const FrameID: TJvID3FrameID): TJvID3FrameClass; virtual;\r\n procedure SetModified(Value: Boolean);\r\n procedure ChangeToVersion(const ANewVersion: TJvID3Version);\r\n\r\n procedure CheckFrameClass(FrameClass: TJvID3FrameClass; const AFrameID: TJvID3FrameID);\r\n\r\n procedure RegisterClient(Client: TObject; Event: TJvID3ActivateChangeEvent = nil); virtual;\r\n procedure SendActivateEvent(Activated: Boolean);\r\n procedure UnRegisterClient(Client: TObject); virtual;\r\n\r\n procedure ID3Event(Event: TJvID3Event; Info: Longint); virtual;\r\n\r\n procedure BeginReading;\r\n procedure EndReading;\r\n procedure BeginWriting;\r\n procedure EndWriting;\r\n procedure BeginUseTempStream;\r\n procedure EndUseTempStream;\r\n\r\n procedure LoadFromStream(AStream: TStream);\r\n procedure SaveToFile(const AFileName: string);\r\n\r\n procedure DoOpen; virtual;\r\n procedure DoClose; virtual;\r\n\r\n procedure Loaded; override;\r\n\r\n procedure ApplyUnsynchronisationSchemeOnCurrentStream;\r\n\r\n { Temporary stream functions }\r\n function GetTempStreamSize: Cardinal;\r\n procedure RemoveUnsynchronisationSchemeToTempStream(const ASize: Integer);\r\n procedure WriteTempStream;\r\n\r\n property Header: TJvID3Header read FHeader write SetHeader stored False;\r\n property ExtendedHeader: TJvID3ExtendedHeader read FExtendedHeader write SetExtendedHeader stored False;\r\n property FileInfo: TJvID3FileInfo read FFileInfo;\r\n property ReadEncodingAs: TJvID3ForceEncoding read FReadEncodingAs write SetReadEncodingAs default ifeAuto;\r\n property WriteEncodingAs: TJvID3ForceEncoding read FWriteEncodingAs write SetWriteEncodingAs default ifeAuto;\r\n property ReadVersionAs: TJvID3ForceVersion read FReadVersionAs write SetReadVersionAs default ifvDontCare;\r\n property WriteVersionAs: TJvID3ForceVersion read FWriteVersionAs write SetWriteVersionAs default ifvDontCare;\r\n property Options: TJvID3ControllerOptions read FOptions write FOptions default [coAutoCorrect,\r\n coRemoveEmptyFrames];\r\n property Version: TJvID3Version read GetVersion write SetVersion stored False;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n\r\n procedure BeginUpdate;\r\n procedure EndUpdate;\r\n\r\n procedure Open;\r\n procedure Commit;\r\n procedure Erase;\r\n procedure Close;\r\n\r\n { Indicates whether a frame of type AFrameID can be added to the tag. For\r\n example there may not be more than 1 text frame with the same frame\r\n id - for example fiAlbum - in the tag. }\r\n function CanAddFrame(const AFrameID: TJvID3FrameID): Boolean;\r\n { Indicates whether tag has has a frame of type AFrameID }\r\n function HasFrame(const AFrameID: TJvID3FrameID): Boolean;\r\n { Adds a frame of type AFrameID to the tag }\r\n function AddFrame(const AFrameID: TJvID3FrameID): TJvID3Frame;\r\n function FindFirstFrame(const AFrameID: TJvID3FrameID;\r\n var Frame: TJvID3Frame): Boolean;\r\n function FindNextFrame(const AFrameID: TJvID3FrameID; var From: TJvID3Frame): Boolean;\r\n { Returns the nr. of frames of type AFrameID in the tag }\r\n function GetFrameCountFor(const AFrameID: TJvID3FrameID): Cardinal;\r\n\r\n function CopyToID3v1(const DoOverwrite: Boolean = True): Boolean;\r\n procedure CopyToID3v1Ctrl(AID3v1: TJvID3v1; const DoOverwrite: Boolean = True);\r\n function CopyFromID3v1(const DoOverwrite: Boolean = True): Boolean;\r\n procedure CopyFromID3v1Ctrl(AID3v1: TJvID3v1; const DoOverwrite: Boolean = True);\r\n\r\n procedure EnsureExists(const FrameIDs: TJvID3FrameIDs);\r\n\r\n property Designer: TJvID3ControllerDesigner read FDesigner;\r\n property TagSize: Cardinal read GetTagSize;\r\n property Modified: Boolean read FModified;\r\n property FrameCount: Integer read GetFrameCount;\r\n property Frames: TJvID3Frames read FFrames;\r\n property WriteVersion: TJvID3Version read GetWriteVersion;\r\n property ReadVersion: TJvID3Version read GetReadVersion;\r\n published\r\n property Active: Boolean read FActive write SetActive;\r\n property FileName: TFileName read FFileName write SetFileName;\r\n end;\r\n\r\nprocedure ID3Error(const Msg: string; Component: TComponent = nil);\r\nprocedure ID3ErrorFmt(const Msg: string; const Args: array of const;\r\n Component: TComponent = nil);\r\nfunction CreateUniqueName(AController: TJvID3Controller; const FrameName: AnsiString;\r\n FrameClass: TJvID3FrameClass; Component: TComponent): string;\r\nprocedure GetID3v2Version(const AFileName: string; var HasTag: Boolean;\r\n var Version: TJvID3Version);\r\nfunction ExtToMIMEType(const Ext: string): string;\r\nfunction MIMETypeToExt(const MIMEType: string): string;\r\nfunction GenreToNiceGenre(const AGenre: string): string;\r\nfunction NiceGenreToGenre(const ANiceGenre: string): string;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvID3v2Base.pas $';\r\n Revision: '$Revision: 13415 $';\r\n Date: '$Date: 2012-09-10 11:51:54 +0200 (lun. 10 sept. 2012) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n Graphics,\r\n {$IFDEF HAS_UNIT_ANSISTRINGS}\r\n AnsiStrings,\r\n {$ENDIF HAS_UNIT_ANSISTRINGS}\r\n JvJCLUtils,\r\n JclBase, JclFileUtils, JclLogic, JclDateTime,\r\n JclStringConversions, JclWideStrings,\r\n JvConsts, JvResources;\r\n\r\n{$IFDEF COMPILER12_UP}\r\ntype\r\n TJvID3StringList = class(TStringList)\r\n public\r\n function GetSeparatedText(const Separator: string): string;\r\n end;\r\n{$ENDIF COMPILER12_UP}\r\n\r\nconst\r\n CMapBitrate: array [Boolean, TJvMPEGLayer] of Byte =\r\n (\r\n { ?? - III - II - I }\r\n ( $00, $02, $01, $00), // V1\r\n ( $00, $04, $04, $03) // V2/V3\r\n );\r\n\r\n CFreeBitrate = -2;\r\n\r\n CBadBitrate = -1;\r\n\r\n CBitrate: array [$00..$04, $00..$0F] of Integer =\r\n (\r\n (CFreeBitrate, 32, 64, 96, 128, 160, 192, 224, 256, 288, 320, 352, 384, 416, 448, CBadBitrate),\r\n (CFreeBitrate, 32, 48, 56, 64, 80, 96, 112, 128, 160, 192, 224, 256, 320, 384, CBadBitrate),\r\n (CFreeBitrate, 32, 40, 48, 56, 64, 80, 96, 112, 128, 160, 192, 224, 256, 320, CBadBitrate),\r\n (CFreeBitrate, 32, 48, 56, 64, 80, 96, 112, 128, 144, 160, 176, 192, 224, 256, CBadBitrate),\r\n (CFreeBitrate, 8, 16, 24, 32, 40, 48, 56, 64, 80, 96, 112, 128, 144, 160, CBadBitrate)\r\n );\r\n\r\n CSamplingFrequency: array [TJvMPEGVersion, $00..$03] of Integer =\r\n (\r\n (11025, 12000, 8000, -1), // mvVersion25,\r\n ( 0, 0, 0, 0), // mvReserved,\r\n (22050, 24000, 16000, -1), // mvVersion2,\r\n (44100, 48000, 32000, -1) // mvVersion1\r\n );\r\n\r\n CLayerArray: array [TJvMPEGLayer] of Integer =\r\n (\r\n 1, // mlNotDefined,\r\n 144000, // mlLayerIII,\r\n 144000, // mlLayerII,\r\n 48000 // mlLayerI\r\n );\r\n\r\n cUnknownLanguage = AnsiString('XXX');\r\n cID3HeaderId = AnsiString('ID3'); // do not change case\r\n cChangeTagSizeFileNameTemplate: string = 'ChangeTagSize';\r\n cPictureFrameFileNameTemplate: string = 'TJvID3PictureFrame';\r\n cURLArrow = AnsiString('-->');\r\n\r\nvar\r\n DefaultFrameClasses: array [TJvID3FrameID] of TJvID3FrameClass =\r\n (\r\n nil, { fiErrorFrame (special frame) }\r\n nil, { fiPaddingFrame (special frame) }\r\n TJvID3SkipFrame, { fiNoFrame (special frame) }\r\n TJvID3AudioEncryptionFrame, { fiAudioCrypto }\r\n TJvID3PictureFrame, { fiPicture }\r\n nil, { fiAudioSeekPoint (new in 2.4) }\r\n TJvID3ContentFrame, { fiComment }\r\n nil, { fiCommercial (new in 2.3) }\r\n nil, { fiCryptoReg (new in 2.3) }\r\n nil, { fiEqualization2 (new in 2.4) }\r\n nil, { fiEqualization (deprecated as of 2.4) }\r\n nil, { fiEventTiming }\r\n TJvID3GeneralObjFrame, { fiGeneralObject }\r\n nil, { fiGroupingReg (new in 2.3) }\r\n TJvID3DoubleListFrame, { fiInvolvedPeople (deprecated as of 2.4) }\r\n nil, { fiLinkedInfo }\r\n TJvID3BinaryFrame, { fiCDID }\r\n nil, { fiMPEGLookup }\r\n TJvID3OwnershipFrame, { fiOwnership (new in 2.3) }\r\n nil, { fiPrivate (new in 2.3) }\r\n TJvID3PlayCounterFrame, { fiPlayCounter }\r\n TJvID3PopularimeterFrame, { fiPopularimeter }\r\n nil, { fiPositionsync (new in 2.3) }\r\n nil, { fiBufferSize }\r\n nil, { fiVolumeAdj2 (new in 2.4) }\r\n nil, { fiVolumeAdj (deprecated as of 2.4) }\r\n nil, { fiReverb }\r\n nil, { fiSeekFrame (new in 2.4) }\r\n nil, { fiSignature (new in 2.4) }\r\n nil, { fiSyncedLyrics }\r\n nil, { fiSyncedTempo }\r\n TJvID3TextFrame, { fiAlbum }\r\n TJvID3TextFrame, { fiBPM } // was NumberFrame changed 03/15/10 DW\r\n TJvID3SimpleListFrame, { fiComposer }\r\n TJvID3SimpleListFrame, { fiContentType }\r\n TJvID3TextFrame, { fiCopyright }\r\n TJvID3TextFrame, { fiDate (deprecated as of 2.4) }\r\n TJvID3TimestampFrame, { fiEncodingTime (new in 2.4) }\r\n TJvID3NumberFrame, { fiPlaylistDelay }\r\n TJvID3TimestampFrame, { fiOrigReleaseTime (new in 2.4) }\r\n TJvID3TimestampFrame, { fiRecordingTime (new in 2.4) }\r\n TJvID3TimestampFrame, { fiReleaseTime (new in 2.4) }\r\n TJvID3TimestampFrame, { fiTaggingTime (new in 2.4) }\r\n TJvID3DoubleListFrame, { fiInvolvedPeople2 (new in 2.4) }\r\n TJvID3TextFrame, { fiEncodedBy }\r\n TJvID3SimpleListFrame, { fiLyricist }\r\n TJvID3TextFrame, { fiFileType }\r\n TJvID3TextFrame, { fiTime (deprecated as of 2.4) }\r\n TJvID3TextFrame, { fiContentGroup }\r\n TJvID3TextFrame, { fiTitle }\r\n TJvID3TextFrame, { fiSubTitle }\r\n TJvID3TextFrame, { fiInitialKey }\r\n TJvID3SimpleListFrame, { fiLanguage }\r\n TJvID3NumberFrame, { fiSongLen }\r\n TJvID3DoubleListFrame, { fiMusicianCreditList (new in 2.4) }\r\n TJvID3TextFrame, { fiMediaType }\r\n TJvID3TextFrame, { fiMood (new in 2.4) }\r\n TJvID3TextFrame, { fiOrigAlbum }\r\n TJvID3TextFrame, { fiOrigFileName }\r\n TJvID3SimpleListFrame, { fiOrigLyricist }\r\n TJvID3SimpleListFrame, { fiOrigArtist }\r\n TJvID3NumberFrame, { fiOrigYear (deprecated as of 2.4) }\r\n TJvID3TextFrame, { fiFileOwner (new in 2.3) }\r\n TJvID3SimpleListFrame, { fiLeadArtist }\r\n TJvID3TextFrame, { fiBand }\r\n TJvID3TextFrame, { fiConductor }\r\n TJvID3TextFrame, { fiMixArtist }\r\n TJvID3TextFrame, { fiPartInSet }\r\n TJvID3TextFrame, { fiProducedNotice (new in 2.4) }\r\n TJvID3TextFrame, { fiPublisher }\r\n TJvID3TextFrame, { fiTrackNum }\r\n TJvID3TextFrame, { fiRecordingDates (deprecated as of 2.4) }\r\n TJvID3TextFrame, { fiNetRadioStation }\r\n TJvID3TextFrame, { fiNetRadioOwner }\r\n TJvID3NumberFrame, { fiSize (deprecated as of 2.4) }\r\n TJvID3TextFrame, { fiAlbumSortOrder (new in 2.4) }\r\n TJvID3TextFrame, { fiPerformerSortOrder (new in 2.4) }\r\n TJvID3TextFrame, { fiTitleSortOrder (new in 2.4) }\r\n TJvID3TextFrame, { fiISRC }\r\n TJvID3TextFrame, { fiEncoderSettings (new in 2.3) }\r\n TJvID3TextFrame, { fiSetSubTitle (new in 2.4) }\r\n TJvID3UserFrame, { fiUserText }\r\n TJvID3NumberFrame, { fiYear (deprecated as of 2.4) }\r\n nil, { fiUniqueFileID }\r\n TJvID3TermsOfUseFrame, { fiTermsOfUse (new in 2.3) }\r\n TJvID3ContentFrame, { fiUnsyncedLyrics }\r\n TJvID3URLFrame, { fiWWWCommercialInfo }\r\n TJvID3URLFrame, { fiWWWCopyright }\r\n TJvID3URLFrame, { fiWWWAudioFile }\r\n TJvID3URLFrame, { fiWWWArtist }\r\n TJvID3URLFrame, { fiWWWAudioSource }\r\n TJvID3URLFrame, { fiWWWRadioPage }\r\n TJvID3URLFrame, { fiWWWPayment }\r\n TJvID3URLFrame, { fiWWWPublisher }\r\n TJvID3URLUserFrame, { fiWWWUser }\r\n nil, { fiMetaCrypto (only in 2.2) }\r\n nil { fiMetaCompressio (only in 2.2) }\r\n );\r\n\r\n//=== Local procedures =======================================================\r\n\r\nfunction LengthUTF8Str(const SW: WideString): Integer;\r\nbegin\r\n Result := Length(WideStringToUTF8(SW));\r\nend;\r\n\r\nfunction CharCount(const S: WideString): Cardinal;\r\nbegin\r\n Result := Length(S);\r\nend;\r\n\r\n{$IFNDEF COMPILER12_UP}\r\nfunction SameStr(const S1, S2: WideString): Boolean;\r\nbegin\r\n Result := StrICompW(PWideChar(S1), PWideChar(S2)) = 0\r\nend;\r\n{$ENDIF !COMPILER12_UP}\r\n\r\nfunction LengthEnc(const S: WideString; const Encoding: TJvID3Encoding): Cardinal;\r\nbegin\r\n { Calculates the length in bytes needed to store a string in a stream encoded as\r\n ToEnc; the string is encoded as FromEnc in the string pair S;\r\n Very similar to GetByteCount }\r\n\r\n case Encoding of\r\n ienISO_8859_1:\r\n Result := CharCount(S);\r\n ienUTF_16:\r\n Result := 2 + 2 * CharCount(S);\r\n ienUTF_16BE:\r\n Result := 2 * CharCount(S);\r\n ienUTF_8:\r\n Result := LengthUTF8Str(S);\r\n else\r\n Result := 0;\r\n ID3Error(RsEID3UnknownEncoding);\r\n end;\r\nend;\r\n\r\nfunction LengthTerminatorEnc(const Encoding: TJvID3Encoding): Cardinal;\r\nbegin\r\n { Calculates the length in bytes needed to store a terminator in the encoding\r\n specified by Encoding }\r\n\r\n case Encoding of\r\n ienISO_8859_1, ienUTF_8:\r\n Result := 1;\r\n ienUTF_16, ienUTF_16BE:\r\n Result := 2;\r\n else\r\n Result := 0;\r\n ID3Error(RsEID3UnknownEncoding);\r\n end;\r\nend;\r\n\r\nfunction CheckIsURL(Frame: TJvID3Frame; var S: AnsiString; const HandleError: TJvID3HandleError): Boolean;\r\nbegin\r\n { Not implemented }\r\n Result := True;\r\nend;\r\n\r\nfunction CheckIsLanguageA(Frame: TJvID3Frame; var S: AnsiString; const HandleError: TJvID3HandleError): Boolean;\r\nbegin\r\n { The three byte language field, present in several frames, is used to\r\n describe the language of the frame's content, according to ISO-639-2\r\n [ISO-639-2]. The language should be represented in lower case. If the\r\n language is not known the string \"XXX\" should be used.\r\n }\r\n\r\n Result := (S = cUnknownLanguage) or ISO_639_2IsCode(S);\r\n\r\n if not Result then\r\n case HandleError of\r\n heAutoCorrect:\r\n { Note, don't set Result to True }\r\n S := cUnknownLanguage;\r\n heRaise:\r\n Frame.ErrorFmt(RsEID3InvalidLanguageValue, [S]);\r\n else\r\n Exit;\r\n end\r\n else\r\n if HandleError = heAutoCorrect then\r\n S := AnsiLowerCase(S);\r\nend;\r\n\r\nfunction CheckIsID3Time(Frame: TJvID3Frame; var S: WideString; const HandleError: TJvID3HandleError): Boolean;\r\nvar\r\n I1, I2: Integer;\r\nbegin\r\n { S must be in HHMM format (H = Hour; M = Minute), and may not be empty }\r\n Result := Length(S) = 4;\r\n\r\n if Result then\r\n begin\r\n I1 := StrToIntDef(Copy(S, 1, 2), -1);\r\n I2 := StrToIntDef(Copy(S, 3, 4), -1);\r\n Result := (I1 >= 0) and (I1 < 24) and (I2 >= 0) and (I2 < 60);\r\n end;\r\n\r\n if not Result then\r\n case HandleError of\r\n heAutoCorrect:\r\n { Note, don't set Result to True }\r\n S := '0000';\r\n heRaise:\r\n Frame.ErrorFmt(RsEID3InvalidTimeValue, [S]);\r\n end;\r\nend;\r\n\r\nfunction CheckIsID3Date(Frame: TJvID3Frame; var S: WideString; const HandleError: TJvID3HandleError): Boolean;\r\nvar\r\n I1, I2: Integer;\r\nbegin\r\n { S must be in DDMM format (D = Day; M = Month), and may not be empty }\r\n Result := Length(S) = 4;\r\n\r\n if Result then\r\n begin\r\n I1 := StrToIntDef(Copy(S, 1, 2), -1);\r\n I2 := StrToIntDef(Copy(S, 3, 4), -1);\r\n Result := (I1 >= 1) and (I1 < 32) and (I2 >= 1) and (I2 < 13);\r\n end;\r\n\r\n if not Result then\r\n case HandleError of\r\n heAutoCorrect:\r\n { Note, don't set Result to True }\r\n S := '0101';\r\n heRaise:\r\n Frame.ErrorFmt(RsEID3InvalidDateValue, [S]);\r\n end;\r\nend;\r\n\r\nfunction CheckMaxCharCount(Frame: TJvID3Frame; var S: WideString;\r\n const MaxCharCount: Cardinal;\r\n const HandleError: TJvID3HandleError): Boolean;\r\nbegin\r\n Result := CharCount(S) <= MaxCharCount;\r\n if not Result then\r\n case HandleError of\r\n heAutoCorrect:\r\n SetLength(S, MaxCharCount);\r\n heRaise:\r\n Frame.ErrorFmt(RsEID3StringTooLong, [S]);\r\n end;\r\nend;\r\n\r\nfunction GetID3Date(const S: WideString; const Encoding: TJvID3Encoding;\r\n const Year: Word = 0): TDateTime;\r\nvar\r\n Day, Month: Word;\r\nbegin\r\n { must be DDMM }\r\n if Length(S) = 4 then\r\n begin\r\n Day := StrToIntDef(Copy(S, 1, 2), 1);\r\n Month := StrToIntDef(Copy(S, 3, 4), 1);\r\n end\r\n else\r\n begin\r\n Day := 1;\r\n Month := 1;\r\n end;\r\n\r\n try\r\n Result := EncodeDate(Year, Month, Day);\r\n except\r\n on EConvertError do\r\n Result := 0;\r\n end;\r\nend;\r\n\r\nfunction CheckIsLanguageList(Frame: TJvID3Frame;\r\n Strings: {$IFDEF COMPILER12_UP}TStrings{$ELSE}JclUnicode.TWideStrings{$ENDIF COMPILER12_UP};\r\n const HandleError: TJvID3HandleError): Boolean;\r\nvar\r\n I: Integer;\r\n S: AnsiString;\r\n Ok: Boolean;\r\nbegin\r\n Result := True;\r\n for I := 0 to Strings.Count - 1 do\r\n begin\r\n S := AnsiString(Strings[I]);\r\n Ok := CheckIsLanguageA(Frame, S, HandleError);\r\n Result := Result and Ok;\r\n if not Ok then\r\n if HandleError = heAutoCorrect then\r\n Strings[I] := string(S)\r\n else\r\n Break;\r\n end;\r\nend;\r\n\r\nfunction CheckList(Frame: TJvID3Frame;\r\n Strings: {$IFDEF COMPILER12_UP}TStrings{$ELSE}JclUnicode.TWideStrings{$ENDIF COMPILER12_UP};\r\n const ASeparator: WideChar;\r\n const HandleError: TJvID3HandleError): Boolean;\r\nvar\r\n I: Integer;\r\n S: string;\r\n LPos: Integer;\r\nbegin\r\n Result := True;\r\n if ASeparator = WideNull then\r\n Exit;\r\n\r\n for I := 0 to Strings.Count - 1 do\r\n begin\r\n S := Strings[I];\r\n LPos := Pos(ASeparator, S);\r\n Result := Result and (LPos = 0);\r\n if LPos > 0 then\r\n case HandleError of\r\n heAutoCorrect:\r\n begin\r\n repeat\r\n Delete(S, LPos, 1);\r\n LPos := Pos(ASeparator, S);\r\n until LPos = 0;\r\n\r\n Strings[I] := S;\r\n end;\r\n heRaise:\r\n Frame.ErrorFmt(RsEID3InvalidCharInList, [ASeparator, S]);\r\n else\r\n Break;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction GetID3Time(const S: WideString; const Encoding: TJvID3Encoding;\r\n const Sec: Word = 0; MSec: Word = 0): TDateTime;\r\nvar\r\n Hour, Min: Word;\r\nbegin\r\n { must be HHMM }\r\n if Length(S) = 4 then\r\n begin\r\n Hour := StrToIntDef(Copy(S, 1, 2), 0);\r\n Min := StrToIntDef(Copy(S, 3, 4), 0);\r\n end\r\n else\r\n begin\r\n Hour := 0;\r\n Min := 0;\r\n end;\r\n\r\n try\r\n Result := EncodeTime(Hour, Min, Sec, MSec);\r\n except\r\n on EConvertError do\r\n Result := 0;\r\n end;\r\nend;\r\n\r\nfunction CheckIsID3PartInSet(Frame: TJvID3Frame; var S: WideString; const HandleError: TJvID3HandleError): Boolean;\r\nvar\r\n P: Integer;\r\n I1, I2: Integer;\r\nbegin\r\n { S must be in N1/N2 or N format (N, N1, N2 = some number, ie [0..9]*,\r\n but may be empty }\r\n\r\n if S = '' then\r\n begin\r\n Result := True;\r\n Exit;\r\n end;\r\n\r\n P := Pos('/', S);\r\n if P > 1 then\r\n begin\r\n I1 := StrToIntDef(Copy(S, 1, P - 1), -1);\r\n I2 := StrToIntDef(Copy(S, P + 1, MaxInt), -1);\r\n Result := (I1 > -1) and (I2 > -1);\r\n end\r\n else\r\n Result := StrToIntDef(S, -1) > -1;\r\n\r\n if not Result then\r\n case HandleError of\r\n heAutoCorrect:\r\n { Note, don't set Result to True }\r\n S := '';\r\n heRaise:\r\n Frame.ErrorFmt(RsEID3InvalidPartInSetValue, [S]);\r\n end;\r\nend;\r\n\r\n{ Copied from DSDesign.pas }\r\n\r\nfunction GenerateName(Controller: TJvID3Controller; FrameName: AnsiString;\r\n FrameClass: TJvID3FrameClass; Number: Integer): string;\r\nvar\r\n Fmt: string;\r\n\r\n procedure CrunchFrameName;\r\n var\r\n I: Integer;\r\n begin\r\n I := 1;\r\n while I <= Length(FrameName) do\r\n begin\r\n if CharInSet(FrameName[I], IdentifierSymbols) then\r\n Inc(I)\r\n else\r\n if CharInSet(FrameName[I], LeadBytes) then\r\n Delete(FrameName, I, 2)\r\n else\r\n Delete(FrameName, I, 1);\r\n end;\r\n end;\r\n\r\nbegin\r\n CrunchFrameName;\r\n if (FrameName = '') or CharInSet(FrameName[1], DigitSymbols) then\r\n begin\r\n if FrameClass <> nil then\r\n FrameName := AnsiString(FrameClass.ClassName) + FrameName\r\n else\r\n FrameName := 'Frame' + FrameName;\r\n if FrameName[1] = 'T' then\r\n Delete(FrameName, 1, 1);\r\n CrunchFrameName;\r\n end;\r\n Fmt := '%s%s%d';\r\n if Number < 2 then\r\n Fmt := '%s%s';\r\n Result := Format(Fmt, [Controller.Name, FrameName, Number]);\r\nend;\r\n\r\nprocedure SyncSafe(Source: Cardinal; var Dest; const DestSize: Integer); overload;\r\ntype\r\n TBytes = array [0..MaxInt - 1] of Byte;\r\nvar\r\n I: Byte;\r\nbegin\r\n { Test : Source = 255 -> Dest = $01 $80\r\n Source = 256 -> Dest = $02 $00\r\n Source = 257 -> Dest = $02 $01 etc.\r\n }\r\n\r\n for I := DestSize - 1 downto 0 do\r\n begin\r\n TBytes(Dest)[I] := Source and $7F; // $7F = %01111111\r\n Source := Source shr 7;\r\n end;\r\nend;\r\n\r\nprocedure SyncSafe(Source: Int64; var Dest; const DestSize: Integer); overload;\r\ntype\r\n TBytes = array [0..MaxInt - 1] of Byte;\r\nvar\r\n I: Byte;\r\nbegin\r\n { Test : Source = 255 -> Dest = $01 $80\r\n Source = 256 -> Dest = $02 $00\r\n Source = 257 -> Dest = $02 $01 etc.\r\n }\r\n for I := DestSize - 1 downto 0 do\r\n begin\r\n TBytes(Dest)[I] := Source and $7F; // $7F = %01111111\r\n Source := Source shr 7;\r\n end;\r\nend;\r\n\r\nprocedure UnSyncSafe(var Source; const SourceSize: Integer; var Dest: Cardinal); overload;\r\ntype\r\n TBytes = array [0..MaxInt - 1] of Byte;\r\nvar\r\n I: Byte;\r\nbegin\r\n { Test : Source = $01 $80 -> Dest = 255\r\n Source = $02 $00 -> Dest = 256\r\n Source = $02 $01 -> Dest = 257 etc.\r\n }\r\n\r\n Dest := 0;\r\n for I := 0 to SourceSize - 1 do\r\n begin\r\n Dest := Dest shl 7;\r\n Dest := Dest or (TBytes(Source)[I] and $7F); // $7F = %01111111\r\n end;\r\nend;\r\n\r\nprocedure UnSyncSafe(var Source; const SourceSize: Integer; var Dest: Int64); overload;\r\ntype\r\n TBytes = array [0..MaxInt - 1] of Byte;\r\nvar\r\n I: Byte;\r\nbegin\r\n { Test : Source = $01 $80 -> Dest = 255\r\n Source = $02 $00 -> Dest = 256\r\n Source = $02 $01 -> Dest = 257 etc.\r\n }\r\n\r\n Dest := 0;\r\n for I := 0 to SourceSize - 1 do\r\n begin\r\n Dest := Dest shl 7;\r\n Dest := Dest or (TBytes(Source)[I] and $7F); // $7F = %01111111\r\n end;\r\nend;\r\n\r\nprocedure ExtractFixedStrings(const Content: WideString; const ALength: Integer;\r\n Strings: {$IFDEF COMPILER12_UP}TStrings{$ELSE}JclUnicode.TWideStrings{$ENDIF COMPILER12_UP});\r\nvar\r\n P, ContentPtr: PWideChar;\r\n S: WideString;\r\nbegin\r\n ContentPtr := PWideChar(Content);\r\n\r\n if (ContentPtr = nil) or (ContentPtr^ = WideNull) or (Strings = nil) or (ALength < 1) then\r\n Exit;\r\n\r\n Strings.BeginUpdate;\r\n try\r\n SetLength(S, ALength);\r\n\r\n while True do\r\n begin\r\n P := ContentPtr;\r\n\r\n while (P^ <> WideNull) and (P - ContentPtr < ALength) do\r\n Inc(P);\r\n\r\n if P - ContentPtr = ALength then\r\n begin\r\n Move(ContentPtr[0], S[1], ALength * SizeOf(WideChar));\r\n Strings.Add(S);\r\n end;\r\n\r\n if P^ = WideNull then\r\n Break;\r\n\r\n Inc(ContentPtr, ALength);\r\n end;\r\n finally\r\n Strings.EndUpdate;\r\n end;\r\nend;\r\n\r\nprocedure ExtractStrings(Separator: WideChar; const Content: WideString;\r\n Strings: {$IFDEF COMPILER12_UP}TStrings{$ELSE}JclUnicode.TWideStrings{$ENDIF COMPILER12_UP});\r\nvar\r\n Tail: PWideChar;\r\n S: WideString;\r\n EOS: Boolean;\r\n ContentPtr: PWideChar;\r\nbegin\r\n ContentPtr := PWideChar(Content);\r\n if (ContentPtr = nil) or (ContentPtr^ = WideNull) or (Strings = nil) then\r\n Exit;\r\n\r\n Strings.BeginUpdate;\r\n try\r\n Tail := ContentPtr;\r\n\r\n repeat\r\n while (Tail^ <> Separator) and (Tail^ <> WideNull) do\r\n Inc(Tail);\r\n\r\n EOS := Tail^ = WideNull;\r\n\r\n SetLength(S, Tail - ContentPtr);\r\n Move(ContentPtr[0], S[1], (Tail - ContentPtr) * SizeOf(WideChar));\r\n Strings.Add(S);\r\n\r\n Inc(Tail);\r\n ContentPtr := Tail;\r\n until EOS;\r\n finally\r\n Strings.EndUpdate;\r\n end;\r\nend;\r\n\r\nfunction GetTagSizeInclHeader(Stream: TStream): Cardinal;\r\nvar\r\n Header: TID3v2HeaderRec;\r\nbegin\r\n if (Stream.Read(Header, SizeOf(Header)) = SizeOf(Header)) and\r\n (Header.Identifier = cID3HeaderId) then\r\n begin\r\n UnSyncSafe(Header.Size, 4, Result);\r\n Inc(Result, 10);\r\n end\r\n else\r\n Result := 0;\r\nend;\r\n\r\nprocedure ChangeTagSize(const SourceFileName: string;\r\n const DestTagSizeInclHeader: Cardinal);\r\nvar\r\n DestFileName: string;\r\n Source, Dest: TFileStream;\r\n SourceFileSize: Int64;\r\n SourceTagSizeInclHeader: Cardinal; { size of tag + header size (=10) }\r\nbegin\r\n { (rb) Maybe we should copy the file attributes of the source file to\r\n the dest file? }\r\n\r\n Source := TFileStream.Create(SourceFileName, fmOpenRead or fmShareExclusive);\r\n try\r\n SourceTagSizeInclHeader := GetTagSizeInclHeader(Source);\r\n\r\n if SourceTagSizeInclHeader = DestTagSizeInclHeader then\r\n Exit;\r\n\r\n DestFileName := JclFileUtils.FileGetTempName(cChangeTagSizeFileNameTemplate);\r\n Dest := TFileStream.Create(DestFileName, fmCreate);\r\n try\r\n SourceFileSize := Source.Size;\r\n Dest.Size := SourceFileSize + DestTagSizeInclHeader - SourceTagSizeInclHeader;\r\n\r\n Source.Seek(SourceTagSizeInclHeader, soFromBeginning);\r\n Dest.Seek(DestTagSizeInclHeader, soFromBeginning);\r\n if SourceFileSize > SourceTagSizeInclHeader then\r\n Dest.CopyFrom(Source, SourceFileSize - SourceTagSizeInclHeader);\r\n finally\r\n Dest.Free;\r\n end;\r\n finally\r\n Source.Free;\r\n end;\r\n\r\n { If all went alright, then we now try to copy the dest file to\r\n the source file }\r\n if not DeleteFile(PChar(SourceFileName)) then\r\n RaiseLastOSError;\r\n\r\n if not RenameFile(DestFileName, SourceFileName) then\r\n RaiseLastOSError;\r\nend;\r\n\r\nfunction SearchSync(AStream: TStream;\r\n const BeginOffset: Integer; var Buffer; const BufferSize: Integer): Int64;\r\nconst\r\n CBufferSize = $0F00;\r\nvar\r\n LBuffer: array[0..CBufferSize - 1] of Byte;\r\n I: Integer;\r\n LastWasFF: Boolean;\r\n BytesRead: Longint;\r\nbegin\r\n { Seek sync point 11111111 111 }\r\n LastWasFF := False;\r\n Result := AStream.Seek(BeginOffset, soFromBeginning);\r\n\r\n while True do\r\n begin\r\n BytesRead := AStream.Read(LBuffer, CBufferSize);\r\n if BytesRead = 0 then\r\n begin\r\n Result := -1;\r\n Break;\r\n end;\r\n\r\n for I := 0 to BytesRead - 1 do\r\n begin\r\n if LastWasFF and (LBuffer[I] and $E0 = $E0) then\r\n begin\r\n Inc(Result, I - 1);\r\n if (I + BufferSize - 1 >= BytesRead) or (I = 0) then\r\n begin\r\n AStream.Seek(Result, soFromBeginning);\r\n if not AStream.Read(Buffer, BufferSize) = BufferSize then\r\n Result := -1;\r\n end\r\n else\r\n Move(LBuffer[I - 1], Buffer, BufferSize);\r\n\r\n Exit;\r\n end;\r\n\r\n LastWasFF := LBuffer[I] = $FF;\r\n end;\r\n Inc(Result, BytesRead);\r\n end;\r\nend;\r\n\r\nfunction GetFrameIDLength(const Version: TJvID3Version): Byte;\r\nbegin\r\n case Version of\r\n ive2_2:\r\n Result := 3;\r\n ive2_3, ive2_4:\r\n Result := 4;\r\n else\r\n Result := 0;\r\n ID3Error(RsEID3UnknownVersion);\r\n end;\r\nend;\r\n\r\nfunction MajorVersionToVersion(const MajorVersion: Byte): TJvID3Version;\r\nbegin\r\n if MajorVersion < 2 then\r\n Result := iveLowerThan2_2\r\n else\r\n if MajorVersion = 2 then\r\n Result := ive2_2\r\n else\r\n if MajorVersion = 3 then\r\n Result := ive2_3\r\n else\r\n if MajorVersion = 4 then\r\n Result := ive2_4\r\n else\r\n Result := iveHigherThan2_4\r\nend;\r\n\r\nprocedure RemoveUnsynchronisationScheme(Source, Dest: TStream; BytesToRead: Integer);\r\nconst\r\n MaxBufSize = $F000;\r\nvar\r\n LastWasFF: Boolean;\r\n BytesRead: Integer;\r\n SourcePtr, DestPtr: Integer;\r\n SourceBuf, DestBuf: array[0..MaxBufSize - 1] of Byte;\r\nbegin\r\n { Replace $FF 00 with $FF }\r\n\r\n LastWasFF := False;\r\n while BytesToRead > 0 do\r\n begin\r\n { Read at max CBufferSize bytes from the stream }\r\n BytesRead := Source.Read(SourceBuf[0], Min(MaxBufSize, BytesToRead));\r\n if BytesRead = 0 then\r\n ID3Error(RsECouldNotReadData);\r\n\r\n Dec(BytesToRead, BytesRead);\r\n\r\n DestPtr := 0;\r\n SourcePtr := 0;\r\n\r\n while SourcePtr < BytesRead do\r\n begin\r\n { If previous was $FF and current is $00 then skip.. }\r\n if not LastWasFF or (SourceBuf[SourcePtr] <> $00) then\r\n begin\r\n { ..otherwise copy }\r\n DestBuf[DestPtr] := SourceBuf[SourcePtr];\r\n Inc(DestPtr);\r\n end;\r\n\r\n LastWasFF := SourceBuf[SourcePtr] = $FF;\r\n Inc(SourcePtr);\r\n end;\r\n Dest.Write(DestBuf[0], DestPtr);\r\n end;\r\nend;\r\n\r\nprocedure ApplyUnsynchronisationScheme(Source, Dest: TStream; BytesToRead: Integer);\r\nconst\r\n MaxBufSize = $F000;\r\nvar\r\n LastWasFF: Boolean;\r\n BytesRead: Integer;\r\n SourcePtr, DestPtr: Integer;\r\n SourceBuf, DestBuf: PAnsiChar;\r\nbegin\r\n { Replace $FF 00 with $FF 00 00\r\n Replace $FF %111xxxxx with $FF 00 %111xxxxx (%11100000 = $E0 = 224 }\r\n\r\n GetMem(SourceBuf, Min(MaxBufSize div 2, BytesToRead));\r\n GetMem(DestBuf, 2 * Min(MaxBufSize div 2, BytesToRead));\r\n try\r\n LastWasFF := False;\r\n while BytesToRead > 0 do\r\n begin\r\n { Read at max CBufferSize div 2 bytes from the stream }\r\n BytesRead := Source.Read(SourceBuf^, Min(MaxBufSize div 2, BytesToRead));\r\n if BytesRead = 0 then\r\n ID3Error(RsECouldNotReadData);\r\n\r\n Dec(BytesToRead, BytesRead);\r\n\r\n DestPtr := 0;\r\n SourcePtr := 0;\r\n\r\n while SourcePtr < BytesRead do\r\n begin\r\n { If previous was $FF and current is $00 or >=$E0 then add space.. }\r\n if LastWasFF and\r\n ((SourceBuf[SourcePtr] = #$00) or (Byte(SourceBuf[SourcePtr]) and $E0 > 0)) then\r\n begin\r\n DestBuf[DestPtr] := #$00;\r\n Inc(DestPtr);\r\n end;\r\n\r\n { Copy }\r\n DestBuf[DestPtr] := SourceBuf[SourcePtr];\r\n Inc(DestPtr);\r\n\r\n LastWasFF := SourceBuf[SourcePtr] = #$FF;\r\n Inc(SourcePtr);\r\n end;\r\n Dest.Write(DestBuf^, DestPtr);\r\n end;\r\n finally\r\n FreeMem(SourceBuf);\r\n FreeMem(DestBuf);\r\n end;\r\nend;\r\n\r\n//=== Global procedures ======================================================\r\n\r\n{ Copied from DSDesign.pas }\r\n\r\nfunction CreateUniqueName(AController: TJvID3Controller; const FrameName: AnsiString;\r\n FrameClass: TJvID3FrameClass; Component: TComponent): string;\r\nvar\r\n I: Integer;\r\n\r\n function IsUnique(const AName: string): Boolean;\r\n var\r\n I: Integer;\r\n begin\r\n Result := False;\r\n with AController do\r\n for I := 0 to ComponentCount - 1 do\r\n if (Component <> Components[I]) and AnsiSameStr(AName, Components[I].Name) then\r\n Exit;\r\n Result := True;\r\n end;\r\n\r\nbegin\r\n for I := 1 to MaxInt do\r\n begin\r\n Result := GenerateName(AController, FrameName, FrameClass, I);\r\n if IsUnique(Result) then\r\n Break;\r\n end;\r\nend;\r\n\r\nfunction ExtToMIMEType(const Ext: string): string;\r\nbegin\r\n { Not a very reliable method }\r\n if AnsiSameText(Ext, '.jpeg') or AnsiSameText(Ext, '.jpg') then\r\n Result := 'image/jpeg'\r\n else if AnsiSameText(Ext, '.tiff') or AnsiSameText(Ext, '.tif') then\r\n Result := 'image/tif'\r\n else if AnsiSameText(Ext, '.bmp') then\r\n Result := 'image/bitmap'\r\n else if Ext = '' then\r\n Result := 'image/'\r\n else\r\n { .png, .gif, .jpg etc. }\r\n Result := 'image/' + Copy(Ext, 2, MaxInt);\r\nend;\r\n\r\n{ References to the ID3v1 genres can be made by, as first byte, enter \"(\"\r\n followed by a number from the genres list (appendix A) and ended with a \")\"\r\n character. This is optionally followed by a refinement, e.g. \"(21)\" or\r\n \"(4)Eurodisco\". Several references can be made in the same frame, e.g.\r\n \"(51)(39)\". If the refinement should begin with a \"(\" character it should\r\n be replaced with \"((\", e.g. \"((I can figure out any genre)\" or\r\n \"(55)((I think...)\".\r\n\r\n The following new content types is defined in ID3v2 and is implemented in\r\n the same way as the numerig content types, e.g. \"(RX)\".\r\n\r\n RX Remix\r\n CR Cover\r\n}\r\n\r\nfunction GenreToNiceGenre(const AGenre: string): string;\r\nvar\r\n State: Integer;\r\n Start: Integer;\r\n I: Integer;\r\n\r\n procedure GoState0;\r\n begin\r\n State := 0;\r\n Start := I + 1;\r\n end;\r\n\r\n procedure AddString(const S: string);\r\n begin\r\n if Result > '' then\r\n begin\r\n if (S = '') or (S[1] = ' ') then\r\n Result := Result + S\r\n else\r\n Result := Result + ' ' + S;\r\n end\r\n else\r\n Result := S;\r\n GoState0;\r\n end;\r\n\r\n procedure AddReference(const AReference: string);\r\n var\r\n iReference: Integer;\r\n Genre: string;\r\n begin\r\n iReference := StrToIntDef(AReference, -1);\r\n if iReference < 0 then\r\n begin\r\n State := -1;\r\n Exit;\r\n end;\r\n\r\n Genre := ID3_IDToGenre(iReference);\r\n if Genre = '' then\r\n begin\r\n State := -1;\r\n Exit;\r\n end;\r\n\r\n AddString(ID3_IDToGenre(iReference));\r\n GoState0;\r\n end;\r\n\r\nvar\r\n P: PChar;\r\nbegin\r\n Result := '';\r\n State := 0;\r\n I := 1;\r\n Start := I;\r\n\r\n while (State >= 0) and (I <= Length(AGenre)) do\r\n begin\r\n case State of\r\n 0:\r\n if AGenre[I] = '(' then\r\n State := 1\r\n else\r\n State := -1;\r\n 1:\r\n case AGenre[I] of\r\n '(':\r\n begin\r\n Start := I;\r\n State := -1;\r\n end;\r\n '0'..'9':\r\n State := 2;\r\n 'R':\r\n State := 3; // expect 'RX' = 'Remix'\r\n 'C':\r\n State := 5; // expect 'CR' = 'Cover'\r\n ')':\r\n GoState0;\r\n else\r\n State := -1;\r\n end;\r\n 2:\r\n case AGenre[I] of\r\n '0'..'9':\r\n ;\r\n ')':\r\n AddReference(Copy(AGenre, Start + 1, I - Start - 1));\r\n else\r\n State := -1;\r\n end;\r\n 3:\r\n if AGenre[I] = 'X' then\r\n State := 4\r\n else\r\n State := -1;\r\n 4:\r\n if AGenre[I] = ')' then\r\n AddString('Remix')\r\n else\r\n State := -1;\r\n 5:\r\n if AGenre[I] = 'R' then\r\n State := 6\r\n else\r\n State := -1;\r\n 6:\r\n if AGenre[I] = ')' then\r\n AddString('Cover')\r\n else\r\n State := -1;\r\n end;\r\n Inc(I);\r\n end;\r\n\r\n if Start <= Length(AGenre) then\r\n begin\r\n { Workaround for a bug in some taggers }\r\n P := PChar(AGenre) + Start - 1;\r\n while P^ = ' ' do\r\n Inc(P);\r\n if StrIComp(P, PChar(Result)) <> 0 then\r\n AddString(Copy(AGenre, Start, MaxInt));\r\n end;\r\nend;\r\n\r\nprocedure GetID3v2Version(const AFileName: string; var HasTag: Boolean;\r\n var Version: TJvID3Version);\r\nvar\r\n Header: TID3v2HeaderRec;\r\nbegin\r\n with TFileStream.Create(AFileName, fmOpenRead or fmShareDenyWrite) do\r\n try\r\n HasTag := (Read(Header, SizeOf(Header)) = SizeOf(Header)) and\r\n (Header.Identifier = cID3HeaderId);\r\n if not HasTag then\r\n Exit;\r\n\r\n Version := MajorVersionToVersion(Header.MajorVersion);\r\n finally\r\n Free;\r\n end;\r\nend;\r\n\r\nprocedure ID3Error(const Msg: string; Component: TComponent = nil);\r\nbegin\r\n if Assigned(Component) and (Component.Name <> '') then\r\n raise EJvID3Error.CreateResFmt(@RsENameMsgFormat, [Component.Name, Msg])\r\n else\r\n raise EJvID3Error.Create(Msg);\r\nend;\r\n\r\nprocedure ID3ErrorFmt(const Msg: string; const Args: array of const;\r\n Component: TComponent = nil);\r\nbegin\r\n ID3Error(Format(Msg, Args), Component);\r\nend;\r\n\r\nfunction MIMETypeToExt(const MIMEType: string): string;\r\nbegin\r\n { Not a very reliable method; maybe use Indy's TIdMimeTable\r\n in IdGlobal.pas\r\n\r\n See: ftp://ftp.isi.edu/in-notes/iana/assignments/media-types/media-types\r\n\r\n image/jpeg .jpg preferred supported\r\n image/png .png preferred\r\n image/gif .gif\r\n image/tiff .tif\r\n image/x-pict .pic\r\n image/bitmap .bmp supported\r\n }\r\n Result := Copy(MIMEType, Pos('/', MIMEType) + 1, MaxInt);\r\n\r\n Result := AnsiLowerCase(Result);\r\n if Result = 'jpeg' then\r\n Result := '.jpg'\r\n else\r\n if Result = 'x-png' then\r\n Result := '.png'\r\n else\r\n if (Result = 'bitmap') or (Result = 'x-ms-bmp') then\r\n Result := '.bmp'\r\n else\r\n if Result = 'tiff' then\r\n Result := '.tif'\r\n else\r\n if Result = 'x-pict' then\r\n Result := '.pic'\r\n else\r\n Result := '.' + Result;\r\nend;\r\n\r\nfunction NiceGenreToGenre(const ANiceGenre: string): string;\r\nvar\r\n S: string;\r\n\r\n function IsPrefix(const APrefix: string): Boolean;\r\n var\r\n C: Integer;\r\n begin\r\n C := Length(APrefix);\r\n Result := ((C = Length(S)) or ((C < Length(S)) and (S[C + 1] = ' '))) and\r\n (StrLIComp(PChar(S), PChar(APrefix), C) = 0);\r\n end;\r\n\r\n procedure AddAndDelete(const Add: string; const DelCount: Integer);\r\n begin\r\n Result := Result + Add;\r\n Delete(S, 1, DelCount);\r\n while (S > '') and (S[1] = ' ') do\r\n Delete(S, 1, 1);\r\n end;\r\n\r\nvar\r\n GenreID: Integer;\r\nbegin\r\n Result := '';\r\n S := ANiceGenre;\r\n while S > '' do\r\n begin\r\n GenreID := ID3_LongGenreToID(S);\r\n if GenreID <> 255 then\r\n AddAndDelete(Format('(%d)', [GenreID]), Length(ID3_IDToGenre(GenreID)))\r\n else\r\n { Specials }\r\n if IsPrefix('remix') then\r\n AddAndDelete('(RX)', 5)\r\n else\r\n if IsPrefix('cover') then\r\n AddAndDelete('(CR)', 5)\r\n else\r\n Break;\r\n end;\r\n\r\n if S > '' then\r\n begin\r\n if S[1] = '(' then\r\n Result := Result + '(' + S\r\n else\r\n Result := Result + S;\r\n end;\r\nend;\r\n\r\n//=== { TJvID3AudioEncryptionFrame } =========================================\r\n\r\nprocedure TJvID3AudioEncryptionFrame.Assign(Source: TPersistent);\r\nbegin\r\n if Source is TJvID3AudioEncryptionFrame then\r\n begin\r\n FOwnerID := TJvID3AudioEncryptionFrame(Source).FOwnerID;\r\n FPreviewStart := TJvID3AudioEncryptionFrame(Source).FPreviewStart;\r\n FPreviewLength := TJvID3AudioEncryptionFrame(Source).FPreviewLength;\r\n end;\r\n\r\n inherited Assign(Source);\r\nend;\r\n\r\nclass function TJvID3AudioEncryptionFrame.CanAddFrame(\r\n AController: TJvID3Controller; AFrameID: TJvID3FrameID): Boolean;\r\nbegin\r\n { There may be more than one \"AENC\" frames in a tag, but only one with the\r\n same 'Owner identifier' }\r\n Result := (AFrameID = fiAudioCrypto) or\r\n inherited CanAddFrame(AController, AFrameID);\r\nend;\r\n\r\nfunction TJvID3AudioEncryptionFrame.CheckFrame(\r\n const HandleError: TJvID3HandleError): Boolean;\r\nbegin\r\n Result := CheckIsURL(Self, FOwnerID, HandleError);\r\n\r\n { If something has changed update the framesize }\r\n if not Result and (HandleError = heAutoCorrect) then\r\n begin\r\n UpdateFrameSize;\r\n Result := True;\r\n end;\r\nend;\r\n\r\nprocedure TJvID3AudioEncryptionFrame.Clear;\r\nbegin\r\n FOwnerID := '';\r\n FPreviewStart := 0;\r\n FPreviewLength := 0;\r\n inherited Clear;\r\nend;\r\n\r\nclass function TJvID3AudioEncryptionFrame.Find(AController: TJvID3Controller;\r\n const AOwnerID: AnsiString): TJvID3AudioEncryptionFrame;\r\nvar\r\n Frame: TJvID3Frame;\r\nbegin\r\n Result := nil;\r\n if not Assigned(AController) or not AController.Active then\r\n Exit;\r\n\r\n if not AController.FindFirstFrame(fiAudioCrypto, Frame) then\r\n Exit;\r\n\r\n while (Frame is TJvID3AudioEncryptionFrame) and\r\n (TJvID3AudioEncryptionFrame(Frame).OwnerID <> AOwnerID) do\r\n AController.FindNextFrame(fiAudioCrypto, Frame);\r\n\r\n if Frame is TJvID3AudioEncryptionFrame then\r\n Result := TJvID3AudioEncryptionFrame(Frame)\r\nend;\r\n\r\nclass function TJvID3AudioEncryptionFrame.FindOrCreate(AController: TJvID3Controller;\r\n const AOwnerID: AnsiString): TJvID3AudioEncryptionFrame;\r\nbegin\r\n if not Assigned(AController) then\r\n ID3Error(RsEID3NoController);\r\n\r\n Result := Find(AController, AOwnerID);\r\n if not Assigned(Result) then\r\n begin\r\n Result := TJvID3AudioEncryptionFrame(AController.AddFrame(fiAudioCrypto));\r\n Result.OwnerID := AOwnerID;\r\n end;\r\nend;\r\n\r\nfunction TJvID3AudioEncryptionFrame.GetFrameSize(const ToEncoding: TJvID3Encoding): Cardinal;\r\nbegin\r\n { Owner identifier $00\r\n Preview start $xx xx\r\n Preview length $xx xx\r\n Encryption info \r\n }\r\n Result := Cardinal(Length(FOwnerID)) + 1 + 2 + 2 + DataSize;\r\nend;\r\n\r\nfunction TJvID3AudioEncryptionFrame.GetIsEmpty: Boolean;\r\nbegin\r\n Result := inherited GetIsEmpty and (Length(FOwnerID) = 0) and\r\n (FPreviewStart = 0) and (FPreviewLength = 0);\r\nend;\r\n\r\nprocedure TJvID3AudioEncryptionFrame.ReadFrame;\r\nbegin\r\n { Owner identifier $00\r\n Preview start $xx xx\r\n Preview length $xx xx\r\n Encryption info \r\n }\r\n with Stream do\r\n begin\r\n ReadStringA(FOwnerID);\r\n\r\n if not CanRead(4) then\r\n Exit;\r\n\r\n Read(FPreviewStart, 2);\r\n FPreviewStart := ReverseBytes(FPreviewStart);\r\n\r\n Read(FPreviewLength, 2);\r\n FPreviewLength := ReverseBytes(FPreviewLength);\r\n end;\r\n ReadData(Stream.BytesTillEndOfFrame);\r\nend;\r\n\r\nfunction TJvID3AudioEncryptionFrame.SameUniqueIDAs(\r\n const Frame: TJvID3Frame): Boolean;\r\nbegin\r\n { There may be more than one \"AENC\" frames in a tag, but only one with the\r\n same 'Owner identifier' }\r\n Result := (Frame is TJvID3AudioEncryptionFrame) and\r\n (Frame.FrameID = FrameID) and (FrameID = fiAudioCrypto);\r\n\r\n if Result then\r\n Result := AnsiSameStr(TJvID3AudioEncryptionFrame(Frame).OwnerID, OwnerID)\r\n else\r\n Result := inherited SameUniqueIDAs(Frame);\r\nend;\r\n\r\nprocedure TJvID3AudioEncryptionFrame.SetOwnerID(const Value: AnsiString);\r\nbegin\r\n if FOwnerID <> Value then\r\n begin\r\n FOwnerID := Value;\r\n Changed;\r\n end;\r\nend;\r\n\r\nprocedure TJvID3AudioEncryptionFrame.SetPreviewLength(const Value: Word);\r\nbegin\r\n if FPreviewLength <> Value then\r\n begin\r\n FPreviewLength := Value;\r\n Changed;\r\n end;\r\nend;\r\n\r\nprocedure TJvID3AudioEncryptionFrame.SetPreviewStart(const Value: Word);\r\nbegin\r\n if FPreviewStart <> Value then\r\n begin\r\n FPreviewStart := Value;\r\n Changed;\r\n end;\r\nend;\r\n\r\nprocedure TJvID3AudioEncryptionFrame.WriteFrame;\r\nvar\r\n TempWord: Word;\r\nbegin\r\n { Owner identifier $00\r\n Preview start $xx xx\r\n Preview length $xx xx\r\n Encryption info \r\n }\r\n with Stream do\r\n begin\r\n WriteStringA(OwnerID);\r\n WriteTerminatorA;\r\n\r\n TempWord := ReverseBytes(PreviewStart);\r\n Write(TempWord, 2);\r\n\r\n TempWord := ReverseBytes(PreviewLength);\r\n Write(TempWord, 2);\r\n end;\r\n WriteData;\r\nend;\r\n\r\n//=== { TJvID3Base } =========================================================\r\n\r\nconstructor TJvID3Base.Create(AController: TJvID3Controller);\r\nbegin\r\n inherited Create;\r\n FController := AController;\r\nend;\r\n\r\nprocedure TJvID3Base.AfterConstruction;\r\nbegin\r\n inherited AfterConstruction;\r\n Reset;\r\nend;\r\n\r\nprocedure TJvID3Base.Assign(Source: TPersistent);\r\nbegin\r\n if not Assigned(Source) then\r\n Reset\r\n else\r\n inherited Assign(Source);\r\nend;\r\n\r\nfunction TJvID3Base.GetStream: TJvID3Stream;\r\nbegin\r\n if not Assigned(FController) then\r\n ID3Error(RsEID3NoController);\r\n\r\n if icsUsingTempStream in FController.FState then\r\n Result := FController.FTempStream\r\n else\r\n Result := FController.FStream;\r\nend;\r\n\r\n//=== { TJvID3BinaryFrame } ==================================================\r\n\r\nprocedure TJvID3BinaryFrame.AfterConstruction;\r\nbegin\r\n inherited AfterConstruction;\r\n FData := nil;\r\n FDataSize := 0;\r\nend;\r\n\r\nprocedure TJvID3BinaryFrame.Assign(Source: TPersistent);\r\nbegin\r\n if Source is TJvID3BinaryFrame then\r\n SetData(TJvID3BinaryFrame(Source).FData, TJvID3BinaryFrame(Source).DataSize);\r\n\r\n inherited Assign(Source);\r\nend;\r\n\r\nprocedure TJvID3BinaryFrame.BeforeDestruction;\r\nbegin\r\n inherited BeforeDestruction;\r\n FreeMem(FData);\r\nend;\r\n\r\nclass function TJvID3BinaryFrame.CanAddFrame(AController: TJvID3Controller;\r\n AFrameID: TJvID3FrameID): Boolean;\r\nbegin\r\n { There may only be one 'MCDI' frame in each tag. }\r\n Result := ((AFrameID = fiCDID) and not AController.HasFrame(fiCDID)) or\r\n (AFrameID <> fiCDID) or inherited CanAddFrame(AController, AFrameID);\r\nend;\r\n\r\nfunction TJvID3BinaryFrame.CheckFrame(const HandleError: TJvID3HandleError): Boolean;\r\nbegin\r\n Result := True;\r\nend;\r\n\r\nprocedure TJvID3BinaryFrame.Clear;\r\nbegin\r\n SetData(nil, 0);\r\n inherited Clear;\r\nend;\r\n\r\nclass function TJvID3BinaryFrame.Find(AController: TJvID3Controller;\r\n const AFrameID: TJvID3FrameID): TJvID3BinaryFrame;\r\nvar\r\n Frame: TJvID3Frame;\r\nbegin\r\n Result := nil;\r\n if not Assigned(AController) or not AController.Active then\r\n Exit;\r\n\r\n Frame := AController.Frames.FindFrame(AFrameID);\r\n if Frame is TJvID3BinaryFrame then\r\n Result := TJvID3BinaryFrame(Frame);\r\nend;\r\n\r\nclass function TJvID3BinaryFrame.FindOrCreate(AController: TJvID3Controller;\r\n const AFrameID: TJvID3FrameID): TJvID3BinaryFrame;\r\nbegin\r\n if not Assigned(AController) then\r\n ID3Error(RsEID3NoController);\r\n\r\n Result := Find(AController, AFrameID);\r\n if not Assigned(Result) then\r\n begin\r\n AController.CheckFrameClass(TJvID3BinaryFrame, AFrameID);\r\n Result := TJvID3BinaryFrame(AController.AddFrame(AFrameID));\r\n end;\r\nend;\r\n\r\nfunction TJvID3BinaryFrame.GetData(P: Pointer; const Size: Cardinal): Boolean;\r\nvar\r\n CopySize: Cardinal;\r\nbegin\r\n Result := Assigned(P);\r\n if not Result then\r\n Exit;\r\n\r\n CopySize := Min(Size, DataSize);\r\n if (CopySize > 0) and Assigned(FData) then\r\n Move(FData^, P^, CopySize);\r\nend;\r\n\r\nfunction TJvID3BinaryFrame.GetFrameSize(const ToEncoding: TJvID3Encoding): Cardinal;\r\nbegin\r\n Result := FDataSize;\r\nend;\r\n\r\nfunction TJvID3BinaryFrame.GetIsEmpty: Boolean;\r\nbegin\r\n Result := DataSize = 0;\r\nend;\r\n\r\nprocedure TJvID3BinaryFrame.LoadFromFile(const FileName: string);\r\nvar\r\n Stream: TStream;\r\nbegin\r\n Stream := TFileStream.Create(FileName, fmOpenRead or fmShareDenyWrite);\r\n try\r\n LoadFromStream(Stream);\r\n finally\r\n Stream.Free;\r\n end;\r\nend;\r\n\r\nprocedure TJvID3BinaryFrame.LoadFromStream(Stream: TStream);\r\nbegin\r\n Stream.Position := 0;\r\n FDataSize := Stream.Size;\r\n ReallocMem(FData, FDataSize);\r\n if Assigned(FData) then\r\n Stream.Read(FData^, FDataSize);\r\n Changed;\r\nend;\r\n\r\nprocedure TJvID3BinaryFrame.ReadData(ASize: Cardinal);\r\nbegin\r\n {if ASize < 0 then\r\n ASize := 0;}\r\n\r\n FDataSize := ASize;\r\n ReallocMem(FData, FDataSize);\r\n\r\n if Assigned(FData) and (FDataSize > 0) then\r\n with Stream do\r\n Read(FData^, FDataSize);\r\nend;\r\n\r\nprocedure TJvID3BinaryFrame.ReadFrame;\r\nbegin\r\n ReadData(FFrameSize);\r\nend;\r\n\r\nfunction TJvID3BinaryFrame.SameUniqueIDAs(const Frame: TJvID3Frame): Boolean;\r\nbegin\r\n { There may only be one 'MCDI' frame in each tag. }\r\n Result := (Assigned(Frame) and (Frame.FrameID = FrameID) and\r\n (FrameID = fiCDID)) or inherited SameUniqueIDAs(Frame);\r\nend;\r\n\r\nprocedure TJvID3BinaryFrame.SaveToFile(const FileName: string);\r\nvar\r\n Stream: TStream;\r\nbegin\r\n Stream := TFileStream.Create(FileName, fmCreate);\r\n try\r\n SaveToStream(Stream);\r\n finally\r\n Stream.Free;\r\n end;\r\nend;\r\n\r\nprocedure TJvID3BinaryFrame.SaveToStream(Stream: TStream);\r\nbegin\r\n if (DataSize > 0) and Assigned(FData) then\r\n Stream.Write(FData^, DataSize)\r\nend;\r\n\r\nfunction TJvID3BinaryFrame.SetData(P: Pointer; const Size: Cardinal): Boolean;\r\nbegin\r\n Result := Assigned(P) or (Size = 0);\r\n if not Result then\r\n Exit;\r\n\r\n ReallocMem(FData, Size);\r\n FDataSize := Size;\r\n if Assigned(FData) and Assigned(P) then\r\n Move(P^, FData^, FDataSize);\r\n Changed;\r\nend;\r\n\r\nprocedure TJvID3BinaryFrame.WriteData;\r\nbegin\r\n if Assigned(FData) then\r\n with Stream do\r\n Write(FData^, DataSize);\r\nend;\r\n\r\nprocedure TJvID3BinaryFrame.WriteFrame;\r\nbegin\r\n WriteData;\r\nend;\r\n\r\n//=== { TJvID3ContentFrame } =================================================\r\n\r\nprocedure TJvID3ContentFrame.Assign(Source: TPersistent);\r\nvar\r\n Src: TJvID3ContentFrame;\r\nbegin\r\n if Source is TJvID3ContentFrame then\r\n begin\r\n Src := TJvID3ContentFrame(Source);\r\n\r\n FLanguage := Src.Language;\r\n FText := Src.Text;\r\n FDescription := Src.Description;\r\n end;\r\n\r\n inherited Assign(Source);\r\nend;\r\n\r\nclass function TJvID3ContentFrame.CanAddFrame(AController: TJvID3Controller;\r\n AFrameID: TJvID3FrameID): Boolean;\r\nbegin\r\n { There may be more than one comment frame in each tag, but only one with\r\n the same language and content descriptor.\r\n There may be more than one 'Unsynchronised lyrics/text transcription' frame\r\n in each tag, but only one with the same language and content descriptor.\r\n }\r\n Result := (AFrameID in [fiComment, fiUnsyncedLyrics]) or\r\n inherited CanAddFrame(AController, AFrameID);\r\nend;\r\n\r\nfunction TJvID3ContentFrame.CheckFrame(const HandleError: TJvID3HandleError): Boolean;\r\nbegin\r\n Result := CheckIsLanguageA(Self, FLanguage, HandleError);\r\n\r\n { If something has changed update the framesize }\r\n if not Result and (HandleError = heAutoCorrect) then\r\n begin\r\n UpdateFrameSize;\r\n Result := True;\r\n end;\r\nend;\r\n\r\nprocedure TJvID3ContentFrame.Clear;\r\nbegin\r\n FLanguage := '';\r\n FText := '';\r\n FDescription := '';\r\n\r\n inherited Clear;\r\nend;\r\n\r\nclass function TJvID3ContentFrame.Find(AController: TJvID3Controller;\r\n const AFrameID: TJvID3FrameID): TJvID3ContentFrame;\r\nvar\r\n Frame: TJvID3Frame;\r\nbegin\r\n Result := nil;\r\n if not Assigned(AController) or not AController.Active then\r\n Exit;\r\n\r\n Frame := AController.Frames.FindFrame(AFrameID);\r\n if Frame is TJvID3ContentFrame then\r\n Result := TJvID3ContentFrame(Frame);\r\nend;\r\n\r\nclass function TJvID3ContentFrame.FindOrCreate(AController: TJvID3Controller;\r\n const AFrameID: TJvID3FrameID): TJvID3ContentFrame;\r\nbegin\r\n if not Assigned(AController) then\r\n ID3Error(RsEID3NoController);\r\n\r\n Result := Find(AController, AFrameID);\r\n if not Assigned(Result) then\r\n begin\r\n AController.CheckFrameClass(TJvID3ContentFrame, AFrameID);\r\n Result := TJvID3ContentFrame(AController.AddFrame(AFrameID));\r\n end;\r\nend;\r\n\r\nfunction TJvID3ContentFrame.GetFrameSize(const ToEncoding: TJvID3Encoding): Cardinal;\r\nbegin\r\n { Text encoding $xx\r\n Language $xx xx xx\r\n Short content descrip. $00 (00)\r\n The actual text \r\n }\r\n Result := 1 + 3 +\r\n LengthEnc(Description, ToEncoding) +\r\n LengthTerminatorEnc(ToEncoding) +\r\n LengthEnc(Text, ToEncoding);\r\nend;\r\n\r\nfunction TJvID3ContentFrame.GetIsEmpty: Boolean;\r\nbegin\r\n Result := ((Length(FLanguage) = 0) or (FLanguage = cUnknownLanguage)) and\r\n (Text = '') and (Description = '');\r\nend;\r\n\r\nfunction HasNonISO_8859_1Chars(const S: WideString): Boolean;\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := 1 to Length(S) do\r\n if Ord(S[I]) > $FF then\r\n begin\r\n Result := True;\r\n Exit;\r\n end;\r\n Result := False;\r\nend;\r\n\r\nfunction TJvID3ContentFrame.MustWriteAsUTF: Boolean;\r\nbegin\r\n Result := HasNonISO_8859_1Chars(Description) or HasNonISO_8859_1Chars(Text);\r\nend;\r\n\r\nprocedure TJvID3ContentFrame.ReadFrame;\r\nbegin\r\n { Text encoding $xx\r\n Language $xx xx xx\r\n Short content descrip. $00 (00)\r\n The actual text \r\n }\r\n\r\n with Stream do\r\n begin\r\n ReadEncoding;\r\n ReadLanguage(FLanguage);\r\n ReadStringEnc(FDescription);\r\n ReadStringEnc(FText);\r\n end;\r\nend;\r\n\r\nfunction TJvID3ContentFrame.SameUniqueIDAs(const Frame: TJvID3Frame): Boolean;\r\nbegin\r\n { There may be more than one comment frame in each tag, but only one with\r\n the same language and content descriptor.\r\n There may be more than one 'Unsynchronised lyrics/text transcription' frame\r\n in each tag, but only one with the same language and content descriptor.\r\n }\r\n Result := (Frame is TJvID3ContentFrame) and\r\n (Frame.FrameID = FrameID) and (FrameID in [fiComment, fiUnsyncedLyrics]);\r\n\r\n if Result then\r\n Result :=\r\n AnsiSameStr(TJvID3ContentFrame(Frame).Language, Self.Language) and\r\n SameStr(TJvID3ContentFrame(Frame).Description, Self.Description)\r\n else\r\n Result := inherited SameUniqueIDAs(Frame);\r\nend;\r\n\r\nprocedure TJvID3ContentFrame.SetDescription(const Value: WideString);\r\nbegin\r\n if Value <> FDescription then\r\n begin\r\n FDescription := Value;\r\n Changed;\r\n end;\r\nend;\r\n\r\nprocedure TJvID3ContentFrame.SetLanguage(const Value: AnsiString);\r\nbegin\r\n if FLanguage <> Value then\r\n begin\r\n FLanguage := Value;\r\n Changed;\r\n end;\r\nend;\r\n\r\nprocedure TJvID3ContentFrame.SetText(const Value: WideString);\r\nbegin\r\n if Value <> FText then\r\n begin\r\n FText := Value;\r\n Changed;\r\n end;\r\nend;\r\n\r\nprocedure TJvID3ContentFrame.WriteFrame;\r\nbegin\r\n { Text encoding $xx\r\n Language $xx xx xx\r\n Short content descrip. $00 (00)\r\n The actual text \r\n }\r\n\r\n with Stream do\r\n begin\r\n WriteEncoding;\r\n WriteLanguage(Language);\r\n WriteStringEnc(Description);\r\n WriteTerminatorEnc;\r\n WriteStringEnc(Text);\r\n end;\r\nend;\r\n\r\n//=== { TJvID3Controller } ===================================================\r\n\r\nconstructor TJvID3Controller.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n\r\n FFrames := TJvID3Frames.Create(Self);\r\n FHeader := TJvID3Header.Create(Self);\r\n FExtendedHeader := TJvID3ExtendedHeader.Create(Self);\r\n FFileInfo := TJvID3FileInfo.Create;\r\n\r\n FActivateEvents := TList.Create;\r\n FClients := TList.Create;\r\n FState := [];\r\n\r\n { Defaults }\r\n FReadEncodingAs := ifeAuto;\r\n FWriteEncodingAs := ifeAuto;\r\n FReadVersionAs := ifvDontCare;\r\n FWriteVersionAs := ifvDontCare;\r\n FOptions := [coAutoCorrect, coRemoveEmptyFrames];\r\nend;\r\n\r\ndestructor TJvID3Controller.Destroy;\r\nbegin\r\n SetActive(False);\r\n\r\n inherited Destroy;\r\n\r\n FreeAndNil(FActivateEvents);\r\n FreeAndNil(FClients);\r\n\r\n FDesigner.Free;\r\n FDesigner := nil;\r\n\r\n FreeAndNil(FFrames);\r\n FHeader.Free;\r\n FExtendedHeader.Free;\r\n FFileInfo.Free;\r\n FStream.Free;\r\nend;\r\n\r\nfunction TJvID3Controller.AddFrame(const AFrameID: TJvID3FrameID): TJvID3Frame;\r\nvar\r\n FrameClass: TJvID3FrameClass;\r\nbegin\r\n if not Active and not (icsReading in FState) then\r\n ID3Error(RsEID3ControllerNotActive, Self);\r\n\r\n FrameClass := GetFrameClass(AFrameID);\r\n\r\n Result := FrameClass.Create(Self, AFrameID);\r\n try\r\n Result.Name := CreateUniqueName(Self, Result.FrameName, FrameClass, Result);\r\n Result.Controller := Self;\r\n except\r\n Result.Free;\r\n { Suppress errors while reading }\r\n if not (icsReading in FState) then\r\n raise;\r\n end;\r\nend;\r\n\r\nprocedure TJvID3Controller.ApplyUnsynchronisationSchemeOnCurrentStream;\r\nvar\r\n TmpStream: TMemoryStream;\r\n LTempStreamSize: Cardinal;\r\nbegin\r\n TmpStream := TMemoryStream.Create;\r\n try\r\n if icsUsingTempStream in FState then\r\n begin\r\n if not Assigned(FTempStream) then\r\n ID3Error(RsENoTempStream, Self);\r\n\r\n LTempStreamSize := GetTempStreamSize;\r\n FTempStream.Seek(0, soFromBeginning);\r\n ApplyUnsynchronisationScheme(FTempStream, TmpStream, LTempStreamSize);\r\n TmpStream.Seek(0, soFromBeginning);\r\n FTempStream.Seek(0, soFromBeginning);\r\n FTempStream.CopyFrom(TmpStream, TmpStream.Size);\r\n end\r\n else\r\n begin\r\n { Exclude header (size=10) from the unsynchronisation }\r\n FStream.Seek(10, soFromBeginning);\r\n ApplyUnsynchronisationScheme(FStream, TmpStream, FStream.Size - 10);\r\n TmpStream.Seek(0, soFromBeginning);\r\n FStream.Seek(10, soFromBeginning);\r\n FStream.CopyFrom(TmpStream, TmpStream.Size);\r\n end;\r\n finally\r\n TmpStream.Free;\r\n end;\r\nend;\r\n\r\nprocedure TJvID3Controller.BeginReading;\r\nbegin\r\n if FState <> [] then\r\n ID3Error(RsEAlreadyReadingWriting, Self);\r\n\r\n Include(FState, icsReading);\r\n FStream := TJvID3Stream.Create;\r\n\r\n BeginUpdate;\r\nend;\r\n\r\nprocedure TJvID3Controller.BeginUpdate;\r\nbegin\r\n Inc(FUpdateCount);\r\nend;\r\n\r\nprocedure TJvID3Controller.BeginUseTempStream;\r\nbegin\r\n if icsUsingTempStream in FState then\r\n ID3Error(RsEAlreadyUsingTempStream, Self);\r\n\r\n Include(FState, icsUsingTempStream);\r\n if not Assigned(FTempStream) then\r\n FTempStream := TJvID3Stream.Create;\r\n\r\n FTempStream.Seek(0, soFromBeginning);\r\n\r\n { Init FTempStream as FStream }\r\n FTempStream.FSourceEncoding := FStream.FSourceEncoding;\r\n FTempStream.FDestEncoding := FStream.FDestEncoding;\r\n FTempStream.FAllowedEncodings := FStream.FAllowedEncodings;\r\nend;\r\n\r\nprocedure TJvID3Controller.BeginWriting;\r\nbegin\r\n if FState <> [] then\r\n ID3Error(RsEAlreadyReadingWriting, Self);\r\n\r\n Include(FState, icsWriting);\r\n FStream := TJvID3Stream.Create;\r\n\r\n BeginUpdate;\r\nend;\r\n\r\nfunction TJvID3Controller.CanAddFrame(const AFrameID: TJvID3FrameID): Boolean;\r\nvar\r\n FrameClass: TJvID3FrameClass;\r\nbegin\r\n { While reading we can always add all kinds of frames, ie we accept that the\r\n stream may contain errors }\r\n if icsReading in FState then\r\n begin\r\n Result := True;\r\n Exit;\r\n end;\r\n\r\n FrameClass := GetFrameClass(AFrameID);\r\n if Assigned(FrameClass) then\r\n Result := FrameClass.CanAddFrame(Self, AFrameID)\r\n else\r\n Result := False;\r\nend;\r\n\r\nprocedure TJvID3Controller.ChangeToVersion(const ANewVersion: TJvID3Version);\r\nbegin\r\n Frames.ChangeToVersion(ANewVersion);\r\n Header.ChangeToVersion(ANewVersion);\r\n ExtendedHeader.ChangeToVersion(ANewVersion);\r\nend;\r\n\r\nprocedure TJvID3Controller.CheckFrameClass(FrameClass: TJvID3FrameClass;\r\n const AFrameID: TJvID3FrameID);\r\nvar\r\n LFrameClass: string;\r\nbegin\r\n if FrameClass <> GetFrameClass(AFrameID) then\r\n begin\r\n if Assigned(FrameClass) then\r\n LFrameClass := FrameClass.ClassName\r\n else\r\n LFrameClass := '';\r\n ID3ErrorFmt(RsEID3InvalidFrameClass, [LFrameClass, ID3_FrameIDToString(AFrameID)], Self);\r\n end;\r\nend;\r\n\r\nprocedure TJvID3Controller.Close;\r\nbegin\r\n SetActive(False);\r\nend;\r\n\r\nprocedure TJvID3Controller.Commit;\r\nconst\r\n CHandleError: array [Boolean] of TJvID3HandleError = (heRaise, heAutoCorrect);\r\nbegin\r\n if not Active then\r\n ID3Error(RsEID3ControllerNotActive);\r\n\r\n try\r\n if coRemoveEmptyFrames in Options then\r\n FFrames.RemoveEmptyFrames;\r\n FFrames.CheckFrames(CHandleError[coAutoCorrect in Options]);\r\n\r\n SaveToFile(FFileName);\r\n SetModified(False);\r\n except\r\n if csDesigning in ComponentState then\r\n if Assigned(Classes.ApplicationHandleException) then\r\n Classes.ApplicationHandleException(ExceptObject)\r\n else\r\n ShowException(ExceptObject, ExceptAddr)\r\n else\r\n raise;\r\n end;\r\nend;\r\n\r\nfunction TJvID3Controller.CopyFromID3v1(const DoOverwrite: Boolean): Boolean;\r\nvar\r\n ID3v1Ctrl: TJvID3v1;\r\nbegin\r\n if not Active then\r\n ID3Error(RsEID3ControllerNotActive, Self);\r\n\r\n ID3v1Ctrl := TJvID3v1.Create(nil);\r\n try\r\n ID3v1Ctrl.FileName := FileName;\r\n ID3v1Ctrl.Open;\r\n Result := ID3v1Ctrl.HasTag;\r\n if Result then\r\n CopyFromID3v1Ctrl(ID3v1Ctrl, DoOverwrite);\r\n finally\r\n ID3v1Ctrl.Free;\r\n end;\r\nend;\r\n\r\nprocedure TJvID3Controller.CopyFromID3v1Ctrl(AID3v1: TJvID3v1;\r\n const DoOverwrite: Boolean);\r\nvar\r\n Frame: TJvID3Frame;\r\n Year: Word;\r\n\r\n function GetFrame(AFrameID: TJvID3FrameID): TJvID3Frame;\r\n begin\r\n Result := FFrames.FindFrame(AFrameID);\r\n if Assigned(Result) and not DoOverwrite then\r\n { If the frame already exists, and we don't want to overwrite, return nil }\r\n Result := nil\r\n else\r\n if not Assigned(Result) then\r\n { If the frame does not exists, create one }\r\n Result := AddFrame(AFrameID);\r\n end;\r\n\r\nbegin\r\n { There is a lot of extra code, because it may be possible that some frame\r\n is not encoded in ISO-8859-1 }\r\n\r\n if not Assigned(AID3v1) then\r\n Exit;\r\n\r\n // Songname\r\n Frame := GetFrame(fiTitle);\r\n if Assigned(Frame) then\r\n TJvID3TextFrame(Frame).Text := string(AID3v1.SongName);\r\n\r\n // Artist\r\n Frame := GetFrame(fiLeadArtist);\r\n if Assigned(Frame) then\r\n begin\r\n TJvID3CustomTextFrame(Frame).Text := string(AID3v1.Artist);\r\n end;\r\n\r\n // Album\r\n Frame := GetFrame(fiAlbum);\r\n if Assigned(Frame) then\r\n TJvID3TextFrame(Frame).Text := string(AID3v1.Album);\r\n\r\n // Year\r\n Year := StrToIntDef(string(AID3v1.Year), 0);\r\n if Year > 0 then\r\n begin\r\n if Version = ive2_4 then\r\n begin\r\n Frame := GetFrame(fiRecordingTime);\r\n if Assigned(Frame) then\r\n TJvID3TimestampFrame(Frame).FValue := EncodeDate(Year, 1, 1);\r\n end\r\n else\r\n begin\r\n Frame := GetFrame(fiYear);\r\n if Assigned(Frame) then\r\n TJvID3NumberFrame(Frame).FValue := Year;\r\n end;\r\n end;\r\n\r\n // Comment\r\n Frame := GetFrame(fiComment);\r\n if Assigned(Frame) then\r\n TJvID3ContentFrame(Frame).Text := string(AID3v1.Comment);\r\n\r\n // Genre\r\n Frame := GetFrame(fiContentType);\r\n if Assigned(Frame) then\r\n begin\r\n if AID3v1.Genre = 255 then\r\n TJvID3TextFrame(Frame).Text := ''\r\n else\r\n TJvID3TextFrame(Frame).Text := Format('(%d)', [AID3v1.Genre]);\r\n end;\r\n\r\n // AlbumTrack\r\n if AID3v1.AlbumTrack > 0 then\r\n begin\r\n Frame := GetFrame(fiTrackNum);\r\n if Assigned(Frame) then\r\n TJvID3TextFrame(Frame).Text := IntToStr(AID3v1.AlbumTrack);\r\n end;\r\nend;\r\n\r\nfunction TJvID3Controller.CopyToID3v1(const DoOverwrite: Boolean): Boolean;\r\nvar\r\n ID3v1Ctrl: TJvID3v1;\r\nbegin\r\n if not Active then\r\n ID3Error(RsEID3ControllerNotActive, Self);\r\n\r\n ID3v1Ctrl := TJvID3v1.Create(nil);\r\n try\r\n ID3v1Ctrl.FileName := FileName;\r\n ID3v1Ctrl.Open;\r\n CopyToID3v1Ctrl(ID3v1Ctrl, DoOverwrite);\r\n Result := ID3v1Ctrl.Commit;\r\n finally\r\n ID3v1Ctrl.Free;\r\n end;\r\nend;\r\n\r\nprocedure TJvID3Controller.CopyToID3v1Ctrl(AID3v1: TJvID3v1;\r\n const DoOverwrite: Boolean);\r\nvar\r\n S: string;\r\n Frame: TJvID3Frame;\r\n Track, P: Integer;\r\n I: Integer;\r\n YearSet, CommentSet: Boolean;\r\nbegin\r\n { There is a lot of extra code, because it may be possible that some frame\r\n is not encoded in ISO-8859-1 }\r\n\r\n if not Assigned(AID3v1) then\r\n Exit;\r\n\r\n YearSet := False;\r\n CommentSet := False;\r\n\r\n for I := 0 to FrameCount - 1 do\r\n begin\r\n Frame := FFrames[I];\r\n\r\n with AID3v1 do\r\n case Frame.FrameID of\r\n fiTitle:\r\n if DoOverwrite or (SongName = '') then\r\n SongName := AnsiString(Copy(TJvID3TextFrame(Frame).Text, 1, 30));\r\n fiLeadArtist:\r\n if DoOverwrite or (Artist = '') then\r\n begin\r\n { Note: fiLeadArtist has multiple lines }\r\n Artist := AnsiString(Copy(TJvID3CustomTextFrame(Frame).Text, 1, 30));\r\n end;\r\n fiAlbum:\r\n if DoOverwrite or (Album = '') then\r\n Album := AnsiString(Copy(TJvID3TextFrame(Frame).Text, 1, 30));\r\n fiYear:\r\n if not YearSet and (DoOverwrite or (Year = '')) then\r\n begin\r\n Year := {$IFDEF HAS_UNIT_ANSISTRINGS}AnsiStrings.{$ENDIF HAS_UNIT_ANSISTRINGS}Format('%.4d', [TJvID3NumberFrame(Frame).Value]);\r\n YearSet := True;\r\n end;\r\n fiRecordingTime:\r\n if not YearSet and (DoOverwrite or (Year = '')) then\r\n begin\r\n Year := {$IFDEF HAS_UNIT_ANSISTRINGS}AnsiStrings.{$ENDIF HAS_UNIT_ANSISTRINGS}Format('%.4d', [YearOfDate(TJvID3TimestampFrame(Frame).Value)]);\r\n YearSet := True;\r\n end;\r\n fiComment:\r\n { Note : there may be more than 1 fiComment frame in the tag, just\r\n pick the first we encounter }\r\n if not CommentSet and (DoOverwrite or (SongName = '')) then\r\n begin\r\n Comment := AnsiString(Copy(TJvID3ContentFrame(Frame).Text, 1, 30));\r\n CommentSet := True;\r\n end;\r\n fiContentType:\r\n if DoOverwrite or (Genre = 255) then\r\n Genre := ID3_LongGenreToID(TJvID3TextFrame(Frame).Text);\r\n fiTrackNum:\r\n if DoOverwrite or (AlbumTrack = 0) then\r\n begin\r\n S := TJvID3TextFrame(Frame).Text;\r\n P := Pos('/', S);\r\n if P > 0 then\r\n Track := StrToIntDef(Copy(S, 1, P - 1), 0)\r\n else\r\n Track := StrToIntDef(S, 0);\r\n if (Track < 0) or (Track > 255) then\r\n Track := 0;\r\n\r\n AlbumTrack := Byte(Track);\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvID3Controller.DoClose;\r\nbegin\r\n { Note: this will set Modified to True.. }\r\n Frames.Clear;\r\n FFileInfo.Reset;\r\n FActive := False;\r\n\r\n { ..thus we set it now back to false }\r\n SetModified(False);\r\nend;\r\n\r\nprocedure TJvID3Controller.DoOpen;\r\nvar\r\n FileStream: TFileStream;\r\nbegin\r\n FileStream := TFileStream.Create(FFileName, fmOpenRead or fmShareDenyWrite);\r\n try\r\n LoadFromStream(FileStream);\r\n FActive := True;\r\n\r\n if ReadVersionAs <> ifvDontCare then\r\n FFrames.ChangeToVersion(CForceVersionToVersion[ReadVersionAs]);\r\n finally\r\n FileStream.Free;\r\n end;\r\nend;\r\n\r\nprocedure TJvID3Controller.EndReading;\r\nbegin\r\n if not (icsReading in FState) then\r\n ID3Error(RsENotReading, Self);\r\n\r\n Exclude(FState, icsReading);\r\n FreeAndNil(FStream);\r\n FreeAndNil(FTempStream);\r\n\r\n EndUpdate;\r\nend;\r\n\r\nprocedure TJvID3Controller.EndUpdate;\r\nbegin\r\n Dec(FUpdateCount);\r\n if FUpdateCount = 0 then\r\n ID3Event(ideID3Change, 0);\r\nend;\r\n\r\nprocedure TJvID3Controller.EndUseTempStream;\r\nbegin\r\n if not (icsUsingTempStream in FState) then\r\n ID3Error(RsENotUsingTempStream, Self);\r\n\r\n Exclude(FState, icsUsingTempStream);\r\n { Do not free the temp stream }\r\nend;\r\n\r\nprocedure TJvID3Controller.EndWriting;\r\nbegin\r\n if not (icsWriting in FState) then\r\n ID3Error(RsENotWriting, Self);\r\n\r\n Exclude(FState, icsWriting);\r\n FreeAndNil(FStream);\r\n FreeAndNil(FTempStream);\r\n\r\n EndUpdate;\r\nend;\r\n\r\nprocedure TJvID3Controller.EnsureExists(const FrameIDs: TJvID3FrameIDs);\r\nvar\r\n FrameID: TJvID3FrameID;\r\n IDs: TJvID3FrameIDs;\r\nbegin\r\n if not Active then\r\n ID3Error(RsEID3ControllerNotActive, Self);\r\n\r\n IDs := FrameIDs - FFrames.GetFrameIDs;\r\n { IDs represents a set of frames we have to construct }\r\n\r\n if IDs <> [] then\r\n for FrameID := Low(TJvID3FrameID) to High(TJvID3FrameID) do\r\n if (FrameID in IDs) and not (GetFrameClass(FrameID) = TJvID3SkipFrame) then\r\n AddFrame(FrameID);\r\nend;\r\n\r\nprocedure TJvID3Controller.Erase;\r\nvar\r\n SavedActive: Boolean;\r\nbegin\r\n SavedActive := Active;\r\n Close;\r\n ChangeTagSize(FileName, 0);\r\n\r\n if SavedActive then\r\n begin\r\n Open;\r\n { Force Modified to be True }\r\n SetModified(True);\r\n end;\r\nend;\r\n\r\nfunction TJvID3Controller.FindFirstFrame(const AFrameID: TJvID3FrameID;\r\n var Frame: TJvID3Frame): Boolean;\r\nbegin\r\n Frame := nil;\r\n Result := FindNextFrame(AFrameID, Frame);\r\nend;\r\n\r\nfunction TJvID3Controller.FindNextFrame(const AFrameID: TJvID3FrameID;\r\n var From: TJvID3Frame): Boolean;\r\nvar\r\n I: Integer;\r\nbegin\r\n if From = nil then\r\n begin\r\n From := Frames.FindFrame(AFrameID);\r\n Result := Assigned(From);\r\n end\r\n else\r\n begin\r\n Result := True;\r\n I := From.Index + 1;\r\n while I < FrameCount do\r\n begin\r\n From := Frames[I];\r\n if From.FrameID = AFrameID then\r\n Exit;\r\n Inc(I);\r\n end;\r\n Result := False;\r\n From := nil;\r\n end;\r\nend;\r\n\r\nclass function TJvID3Controller.GetFrameClass(const FrameID: TJvID3FrameID): TJvID3FrameClass;\r\nbegin\r\n Result := DefaultFrameClasses[FrameID];\r\n if not Assigned(Result) then\r\n { TJvID3SkipFrame is the default frame for non-implemented frames }\r\n Result := TJvID3SkipFrame;\r\nend;\r\n\r\nfunction TJvID3Controller.GetFrameCount: Integer;\r\nbegin\r\n Result := Frames.Count;\r\nend;\r\n\r\nfunction TJvID3Controller.GetFrameCountFor(const AFrameID: TJvID3FrameID): Cardinal;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := 0;\r\n for I := 0 to FrameCount - 1 do\r\n if Frames[I].FrameID = AFrameID then\r\n Inc(Result);\r\nend;\r\n\r\nfunction TJvID3Controller.GetReadVersion: TJvID3Version;\r\nbegin\r\n { Returns the end-version (2.3 or 2.4) of a tag when reading. For example\r\n a tag can have version 2.3 (on disk) but when ReadVersionAs is set to ifv2_4\r\n it will be translated to a v2.4 tag, and ReadVersion will return ive2_4 in\r\n this case }\r\n\r\n case ReadVersionAs of\r\n ifvDontCare:\r\n begin\r\n Result := Version;\r\n if Result < ive2_2 then\r\n Result := ive2_2\r\n else\r\n if Result > ive2_4 then\r\n Result := ive2_4;\r\n end;\r\n ifv2_2:\r\n Result := ive2_2;\r\n ifv2_3:\r\n Result := ive2_3;\r\n ifv2_4:\r\n Result := ive2_4;\r\n else\r\n Result := ive2_3;\r\n ID3Error(RsEID3UnknownVersion, Self);\r\n end;\r\nend;\r\n\r\nfunction TJvID3Controller.GetTagSize: Cardinal;\r\nbegin\r\n if not Active then\r\n Result := 0\r\n else\r\n Result := Header.Size;\r\nend;\r\n\r\nfunction TJvID3Controller.GetTempStreamSize: Cardinal;\r\nbegin\r\n if not Assigned(FTempStream) then\r\n ID3Error(RsENoTempStream, Self);\r\n\r\n Result := FTempStream.Position;\r\nend;\r\n\r\nfunction TJvID3Controller.GetVersion: TJvID3Version;\r\nbegin\r\n Result := MajorVersionToVersion(FHeader.MajorVersion);\r\nend;\r\n\r\nfunction TJvID3Controller.GetWriteVersion: TJvID3Version;\r\nbegin\r\n { Returns the end-version (2.3 or 2.4) of a tag when writing. For example\r\n a tag can have version 2.3 but when WriteVersionAs is set to ifv2_4 it will\r\n be translated to a v2.4 tag, and WriteVersion will return ive2_4 in this\r\n case }\r\n\r\n case WriteVersionAs of\r\n ifvDontCare:\r\n begin\r\n Result := Version;\r\n { Default to v2.4; latest version }\r\n if (Result < ive2_2) or (Result > ive2_4) then\r\n Result := ive2_4;\r\n end;\r\n ifv2_2:\r\n Result := ive2_2;\r\n ifv2_3:\r\n Result := ive2_3;\r\n ifv2_4:\r\n Result := ive2_4;\r\n else\r\n Result := ive2_3;\r\n ID3Error(RsEID3UnknownVersion, Self);\r\n end;\r\nend;\r\n\r\nfunction TJvID3Controller.HasFrame(const AFrameID: TJvID3FrameID): Boolean;\r\nbegin\r\n Result := Assigned(Frames.FindFrame(AFrameID));\r\nend;\r\n\r\nprocedure TJvID3Controller.ID3Event(Event: TJvID3Event; Info: Integer);\r\nbegin\r\n if (Event in [ideFrameChange, ideFrameListChange]) and\r\n (FState * [icsReading, icsWriting] = []) then\r\n SetModified(True);\r\n\r\n if (FUpdateCount = 0) and Assigned(FDesigner) then\r\n FDesigner.ID3Event(Event, Info);\r\nend;\r\n\r\nprocedure TJvID3Controller.Loaded;\r\nbegin\r\n inherited Loaded;\r\n try\r\n if FStreamedActive then\r\n SetActive(True);\r\n except\r\n if csDesigning in ComponentState then\r\n if Assigned(Classes.ApplicationHandleException) then\r\n Classes.ApplicationHandleException(ExceptObject)\r\n else\r\n ShowException(ExceptObject, ExceptAddr)\r\n else\r\n raise;\r\n end;\r\nend;\r\n\r\nprocedure TJvID3Controller.LoadFromStream(AStream: TStream);\r\nbegin\r\n BeginReading;\r\n try\r\n { Clear }\r\n FHeader.Reset;\r\n FExtendedHeader.Reset;\r\n FFrames.Reset;\r\n\r\n { Read the header }\r\n if AStream.Size >= 10 then\r\n FStream.ReadFromStream(AStream, 10)\r\n else\r\n Exit;\r\n\r\n { Parse the header }\r\n FHeader.Read;\r\n\r\n if FHeader.HasTag and (Version in CSupportedVersions) then\r\n begin\r\n\r\n { Init encoding after the version is read }\r\n FStream.InitAllowedEncodings(ReadVersion, ReadEncodingAs);\r\n\r\n { Note that we will overwrite the header in FStream (first 10 bytes in FStream) }\r\n FStream.Position := 0;\r\n\r\n if hfUnsynchronisation in FHeader.Flags then\r\n { Unsynchronisation scheme is applied to the tag, we have to remove it,\r\n ie replace $FF $00 with $FF }\r\n RemoveUnsynchronisationScheme(AStream, FStream, FHeader.Size)\r\n else\r\n { If not, we just copy the stream to the memory stream }\r\n FStream.ReadFromStream(AStream, FHeader.Size);\r\n\r\n FStream.Position := 0;\r\n\r\n if hfExtendedHeader in FHeader.Flags then\r\n { Read extended header, note that it's read after the unsynchronisation\r\n scheme is removed }\r\n FExtendedHeader.Read;\r\n\r\n FFrames.Read;\r\n end;\r\n\r\n if Header.HasTag then\r\n FFileInfo.Read(AStream, 10 + Header.Size)\r\n else\r\n FFileInfo.Read(AStream, 0);\r\n finally\r\n EndReading;\r\n end;\r\nend;\r\n\r\nprocedure TJvID3Controller.Open;\r\nbegin\r\n SetActive(True);\r\nend;\r\n\r\nprocedure TJvID3Controller.RegisterClient(Client: TObject;\r\n Event: TJvID3ActivateChangeEvent);\r\nbegin\r\n { Based on TCustomConnection.RegisterClient }\r\n FClients.Add(Client);\r\n FActivateEvents.Add(TMethod(Event).Code);\r\nend;\r\n\r\nprocedure TJvID3Controller.RemoveUnsynchronisationSchemeToTempStream(const ASize: Integer);\r\nbegin\r\n if icsUsingTempStream in FState then\r\n ID3Error(RsEAlreadyUsingTempStream, Self);\r\n\r\n if not Assigned(FTempStream) then\r\n FTempStream := TJvID3Stream.Create;\r\n\r\n FTempStream.Seek(0, soFromBeginning);\r\n RemoveUnsynchronisationScheme(FStream, FTempStream, ASize);\r\nend;\r\n\r\nprocedure TJvID3Controller.SaveToFile(const AFileName: string);\r\nvar\r\n PaddingSize: Integer;\r\n OldTagSizeInclHeader: Cardinal;\r\n NewTagSizeInclHeader: Cardinal;\r\n FileStream: TFileStream;\r\n\r\n { Normally Tagsize is the size of the tag including padding excluding header, so\r\n we have vars\r\n\r\n xxxTagSizeInclHeader = normal Tagsize + 10 (if tag exists)\r\n = 0 (if tag doesn't exists)\r\n xxxTagSizeInclHeaderExclPadding = normal Tagsize + 10 - size of the padding (if tag exists)\r\n = 0 (if tag doesn't exists)\r\n }\r\n function CalcNewPadding(const AOldTagSizeInclHeader: Cardinal;\r\n const ANewTagSizeInclHeaderExclPadding: Cardinal): Cardinal;\r\n const\r\n CMinPadding = $800; // = 2048\r\n CChunk = $800;\r\n var\r\n NewTagSizeInclHeader: Cardinal;\r\n begin\r\n Assert(AOldTagSizeInclHeader <= ANewTagSizeInclHeaderExclPadding);\r\n\r\n if AOldTagSizeInclHeader = 0 then\r\n Result := CMinPadding\r\n else\r\n begin\r\n NewTagSizeInclHeader := AOldTagSizeInclHeader;\r\n { ?? }\r\n while NewTagSizeInclHeader <= ANewTagSizeInclHeaderExclPadding do\r\n Inc(NewTagSizeInclHeader, 1 + NewTagSizeInclHeader div 2);\r\n\r\n Result := NewTagSizeInclHeader - ANewTagSizeInclHeaderExclPadding;\r\n if Result < CMinPadding then\r\n Result := CMinPadding;\r\n end;\r\n\r\n NewTagSizeInclHeader := ANewTagSizeInclHeaderExclPadding + Result;\r\n { Round to multiple of CChunk }\r\n NewTagSizeInclHeader := ((NewTagSizeInclHeader + CChunk - 1) div CChunk) * CChunk;\r\n Result := NewTagSizeInclHeader - ANewTagSizeInclHeaderExclPadding;\r\n end;\r\n\r\nbegin\r\n BeginWriting;\r\n try\r\n FStream.InitAllowedEncodings(WriteVersion, WriteEncodingAs);\r\n\r\n { Maybe only write header to the filestream? }\r\n Header.Write;\r\n\r\n if hfExtendedHeader in FHeader.Flags then\r\n { Write extended header, note that it's written before the unsynchronisation\r\n scheme is applied }\r\n FExtendedHeader.Write;\r\n\r\n FFrames.Write;\r\n\r\n { Compression }\r\n\r\n { Encryption }\r\n\r\n if hfUnsynchronisation in Header.Flags then\r\n ApplyUnsynchronisationSchemeOnCurrentStream;\r\n\r\n FileStream := TFileStream.Create(FFileName, fmOpenReadWrite or fmShareExclusive);\r\n try\r\n OldTagSizeInclHeader := GetTagSizeInclHeader(FileStream);\r\n\r\n { FStream.Size = size of new tag including header excluding padding }\r\n PaddingSize := OldTagSizeInclHeader - Cardinal(FStream.Size);\r\n\r\n { We always want to have padding (because of possible\r\n unsynchronisation possibly needs padding), thus if PaddingSize = 0, then\r\n also calculate new bigger padding size }\r\n if PaddingSize <= 0 then\r\n PaddingSize := CalcNewPadding(OldTagSizeInclHeader, FStream.Size);\r\n\r\n NewTagSizeInclHeader := FStream.Size + PaddingSize;\r\n if NewTagSizeInclHeader < OldTagSizeInclHeader then\r\n Inc(PaddingSize, OldTagSizeInclHeader - NewTagSizeInclHeader)\r\n else\r\n if NewTagSizeInclHeader > OldTagSizeInclHeader then\r\n begin\r\n { (rb) This is a bit clumbsy, we have to throw away the stream before\r\n resizing, then resize the file, and afterward construct the stream\r\n again.\r\n\r\n Couldn't come up with a cleaner way\r\n }\r\n\r\n FreeAndNil(FileStream);\r\n\r\n ChangeTagSize(FileName, NewTagSizeInclHeader);\r\n\r\n FileStream := TFileStream.Create(FFileName, fmOpenReadWrite or fmShareExclusive);\r\n end;\r\n\r\n { Write the padding }\r\n FStream.Seek(0, soFromEnd);\r\n FStream.WritePadding(PaddingSize);\r\n\r\n { Update header & write it again to the stream }\r\n Header.FSize := NewTagSizeInclHeader - 10;\r\n FStream.Seek(0, soFromBeginning);\r\n Header.Write;\r\n\r\n { Write the memory stream to the file }\r\n FStream.Seek(0, soFromBeginning);\r\n FileStream.Seek(0, soFromBeginning);\r\n FileStream.CopyFrom(FStream, FStream.Size);\r\n finally\r\n FileStream.Free;\r\n end;\r\n finally\r\n EndWriting;\r\n end;\r\nend;\r\n\r\nprocedure TJvID3Controller.SendActivateEvent(Activated: Boolean);\r\nvar\r\n I: Integer;\r\n ActivateEvent: TJvID3ActivateChangeEvent;\r\nbegin\r\n { Based on TCustomConnection.SendConnectEvent }\r\n for I := 0 to FClients.Count - 1 do\r\n begin\r\n if FActivateEvents[I] <> nil then\r\n begin\r\n TMethod(ActivateEvent).Code := FActivateEvents[I];\r\n TMethod(ActivateEvent).Data := FClients[I];\r\n ActivateEvent(Self, Activated);\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvID3Controller.SetActive(const Value: Boolean);\r\nbegin\r\n { Based on TCustomConnection.SetConnected }\r\n if (csReading in ComponentState) and Value then\r\n FStreamedActive := True\r\n else\r\n begin\r\n if Value = FActive then\r\n Exit;\r\n if Value then\r\n begin\r\n //if Assigned(BeforeConnect) then BeforeConnect(Self);\r\n DoOpen;\r\n SendActivateEvent(FActive);\r\n //if Assigned(AfterConnect) then AfterConnect(Self);\r\n end\r\n else\r\n begin\r\n //if Assigned(BeforeDisconnect) then BeforeDisconnect(Self);\r\n //SendConnectEvent(False);\r\n DoClose;\r\n SendActivateEvent(FActive);\r\n //if Assigned(AfterDisconnect) then AfterDisconnect(Self);\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvID3Controller.SetExtendedHeader(const Value: TJvID3ExtendedHeader);\r\nbegin\r\n FExtendedHeader.Assign(Value);\r\nend;\r\n\r\nprocedure TJvID3Controller.SetFileName(const Value: TFileName);\r\nvar\r\n SavedActive: Boolean;\r\nbegin\r\n if Value <> FFileName then\r\n begin\r\n SavedActive := Active;\r\n\r\n Close;\r\n FFileName := Value;\r\n\r\n if SavedActive then\r\n Open;\r\n end;\r\nend;\r\n\r\nprocedure TJvID3Controller.SetHeader(const Value: TJvID3Header);\r\nbegin\r\n FHeader.Assign(Value);\r\nend;\r\n\r\nprocedure TJvID3Controller.SetModified(Value: Boolean);\r\nbegin\r\n FModified := Value;\r\nend;\r\n\r\nprocedure TJvID3Controller.SetReadEncodingAs(const Value: TJvID3ForceEncoding);\r\nbegin\r\n if (FReadVersionAs in [ifv2_2, ifv2_3]) and (Value in [ifeUTF_16BE, ifeUTF_8]) then\r\n ID3Error(RsEID3EncodingNotSupported, Self);\r\n\r\n FReadEncodingAs := Value;\r\nend;\r\n\r\nprocedure TJvID3Controller.SetReadVersionAs(const Value: TJvID3ForceVersion);\r\nbegin\r\n FReadVersionAs := Value;\r\n if (FReadVersionAs in [ifv2_2, ifv2_3]) and (FReadEncodingAs in [ifeUTF_16BE, ifeUTF_8]) then\r\n FReadEncodingAs := ifeUTF_16;\r\nend;\r\n\r\nprocedure TJvID3Controller.SetVersion(NewVersion: TJvID3Version);\r\nbegin\r\n if NewVersion = iveLowerThan2_2 then\r\n NewVersion := ive2_2\r\n else\r\n if NewVersion = iveHigherThan2_4 then\r\n NewVersion := ive2_4;\r\n\r\n if NewVersion = GetVersion then\r\n Exit;\r\n\r\n ChangeToVersion(NewVersion);\r\nend;\r\n\r\nprocedure TJvID3Controller.SetWriteEncodingAs(const Value: TJvID3ForceEncoding);\r\nbegin\r\n if (FWriteVersionAs in [ifv2_2, ifv2_3]) and (Value in [ifeUTF_16BE, ifeUTF_8]) then\r\n ID3Error(RsEID3EncodingNotSupported, Self);\r\n\r\n FWriteEncodingAs := Value;\r\nend;\r\n\r\nprocedure TJvID3Controller.SetWriteVersionAs(const Value: TJvID3ForceVersion);\r\nbegin\r\n FWriteVersionAs := Value;\r\n if (FWriteVersionAs in [ifv2_2, ifv2_3]) and (FWriteEncodingAs in [ifeUTF_16BE, ifeUTF_8]) then\r\n FWriteEncodingAs := ifeUTF_16;\r\nend;\r\n\r\nprocedure TJvID3Controller.UnRegisterClient(Client: TObject);\r\nvar\r\n Index: Integer;\r\nbegin\r\n { Based on TCustomConnection.UnRegisterClient }\r\n Index := FClients.IndexOf(Client);\r\n if Index <> -1 then\r\n begin\r\n FClients.Delete(Index);\r\n FActivateEvents.Delete(Index);\r\n end;\r\nend;\r\n\r\nprocedure TJvID3Controller.WriteTempStream;\r\nvar\r\n LTempStreamSize: Cardinal;\r\nbegin\r\n if not Assigned(FTempStream) then\r\n ID3Error(RsENoTempStream, Self);\r\n\r\n LTempStreamSize := GetTempStreamSize;\r\n FTempStream.Seek(0, soFromBeginning);\r\n FStream.CopyFrom(FTempStream, LTempStreamSize);\r\nend;\r\n\r\n//=== { TJvID3ControllerDesigner } ===========================================\r\n\r\nconstructor TJvID3ControllerDesigner.Create(Controller: TJvID3Controller);\r\nbegin\r\n inherited Create;\r\n FController := Controller;\r\n FController.FDesigner := Self;\r\nend;\r\n\r\ndestructor TJvID3ControllerDesigner.Destroy;\r\nbegin\r\n FController.FDesigner := nil;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvID3ControllerDesigner.BeginDesign;\r\nbegin\r\n Controller.BeginUpdate;\r\nend;\r\n\r\nprocedure TJvID3ControllerDesigner.EndDesign;\r\nbegin\r\n Controller.EndUpdate;\r\nend;\r\n\r\nprocedure TJvID3ControllerDesigner.ID3Event(Event: TJvID3Event; Info: Integer);\r\nbegin\r\nend;\r\n\r\n//=== { TJvID3CustomTextFrame } ==============================================\r\n\r\nprocedure TJvID3CustomTextFrame.Assign(Source: TPersistent);\r\nbegin\r\n if Source is TJvID3CustomTextFrame then\r\n begin\r\n Text := TJvID3CustomTextFrame(Source).Text;\r\n end;\r\n inherited Assign(Source);\r\nend;\r\n\r\nclass function TJvID3CustomTextFrame.CanAddFrame(AController: TJvID3Controller;\r\n AFrameID: TJvID3FrameID): Boolean;\r\nbegin\r\n { There may only be one text information frame of its kind in an tag }\r\n Result := not AController.HasFrame(AFrameID) or\r\n inherited CanAddFrame(AController, AFrameID);\r\nend;\r\n\r\nprocedure TJvID3CustomTextFrame.Clear;\r\nbegin\r\n Text := '';\r\n inherited Clear;\r\nend;\r\n\r\nfunction TJvID3CustomTextFrame.GetFrameSize(const ToEncoding: TJvID3Encoding): Cardinal;\r\nbegin\r\n Result := 1 + LengthEnc(Text, ToEncoding);\r\nend;\r\n\r\nfunction TJvID3CustomTextFrame.GetIsEmpty: Boolean;\r\nbegin\r\n { Framesize is always >=1, because we must write the Encoding byte }\r\n Result := GetFrameSize(Encoding) <= 1;\r\nend;\r\n\r\nfunction TJvID3CustomTextFrame.MustWriteAsUTF: Boolean;\r\nbegin\r\n Result := HasNonISO_8859_1Chars(Text);\r\nend;\r\n\r\nprocedure TJvID3CustomTextFrame.ReadFrame;\r\nvar\r\n S: WideString;\r\nbegin\r\n with Stream do\r\n begin\r\n ReadEncoding;\r\n ReadStringEnc(S);\r\n Text := S;\r\n end;\r\nend;\r\n\r\nfunction TJvID3CustomTextFrame.SameUniqueIDAs(const Frame: TJvID3Frame): Boolean;\r\nbegin\r\n { There may only be one text information frame of its kind in an tag }\r\n Result := (Assigned(Frame) and (Frame.FrameID = FrameID)) or inherited SameUniqueIDAs(Frame);\r\nend;\r\n\r\nfunction TJvID3CustomTextFrame.SupportsVersion(const AVersion: TJvID3Version): Boolean;\r\nbegin\r\n case FrameID of\r\n { ** Not supported in 2.2 ** }\r\n\r\n fiFileOwner, fiEncoderSettings:\r\n Result := AVersion in [ive2_3, ive2_4];\r\n\r\n { ** Deprecated in 2.4 ** }\r\n\r\n { [TDAT] Replaced by the TDRC frame, 'Recording time' }\r\n fiDate,\r\n { [TIME] Replaced by the TDRC frame, 'Recording time' }\r\n fiTime,\r\n { [TORY] Replaced by the TDOR frame, 'Original release time' }\r\n fiOrigYear,\r\n { [TRDA] Replaced by the TDRC frame, 'Recording time' }\r\n fiRecordingDates,\r\n { [TSIZ] The information contained in this frame is in the general case\r\n either trivial to calculate for the player or impossible for the\r\n tagger to calculate. There is however no good use for such\r\n information. The frame is therefore completely deprecated. }\r\n fiSize,\r\n { [TYER] This frame is replaced by the TDRC frame, 'Recording time' }\r\n fiYear:\r\n Result := AVersion in [ive2_2, ive2_3];\r\n\r\n { ** New frames in 2.4 ** }\r\n\r\n fiEncodingTime, { [TDEN] Encoding time }\r\n fiOrigReleaseTime, { [TDOR] Original release time }\r\n fiRecordingTime, { [TDRC] Recording time }\r\n fiReleaseTime, { [TDRL] Release time }\r\n fiTaggingTime, { [TDTG] Tagging time }\r\n //fiInvolvedPeople2, { [TIPL] Involved people list }\r\n //fiMusicianCreditList, { [TMCL] Musician credits list }\r\n fiMood, { [TMOO] Mood }\r\n fiProducedNotice, { [TPRO] Produced notice }\r\n fiAlbumSortOrder, { [TSOA] Album sort order }\r\n fiPerformerSortOrder, { [TSOP] Performer sort order }\r\n fiTitleSortOrder, { [TSOT] Title sort order }\r\n fiSetSubTitle: { [TSST] Set subtitle }\r\n Result := AVersion = ive2_4;\r\n else\r\n Result := True;\r\n end;\r\nend;\r\n\r\nprocedure TJvID3CustomTextFrame.WriteFrame;\r\nbegin\r\n with Stream do\r\n begin\r\n WriteEncoding;\r\n WriteStringEnc(Text);\r\n end;\r\nend;\r\n\r\n//=== { TJvID3DoubleListFrame } ==============================================\r\n\r\nprocedure TJvID3DoubleListFrame.AfterConstruction;\r\nbegin\r\n inherited AfterConstruction;\r\n\r\n {$IFDEF COMPILER12_UP}\r\n FList := TStringList.Create;\r\n TStringList(FList).OnChange := ListChanged;\r\n {$ELSE}\r\n FList := JclUnicode.TWideStringList.Create;\r\n JclUnicode.TWideStringList(FList).OnChange := ListChanged;\r\n {$ENDIF COMPILER12_UP}\r\nend;\r\n\r\nprocedure TJvID3DoubleListFrame.Assign(Source: TPersistent);\r\nbegin\r\n if Source is TJvID3DoubleListFrame then\r\n begin\r\n FList.Assign(TJvID3DoubleListFrame(Source).List);\r\n end;\r\n\r\n inherited Assign(Source);\r\nend;\r\n\r\nprocedure TJvID3DoubleListFrame.BeforeDestruction;\r\nbegin\r\n inherited BeforeDestruction;\r\n\r\n FList.Free;\r\nend;\r\n\r\nclass function TJvID3DoubleListFrame.CanAddFrame(AController: TJvID3Controller;\r\n AFrameID: TJvID3FrameID): Boolean;\r\nbegin\r\n { There may only be one \"IPLS\" frame in each tag. }\r\n Result :=\r\n ((AFrameID in [fiInvolvedPeople, fiInvolvedPeople2, fiMusicianCreditList]) and\r\n not AController.HasFrame(AFrameID)) or\r\n inherited CanAddFrame(AController, AFrameID);\r\nend;\r\n\r\nprocedure TJvID3DoubleListFrame.ChangeToVersion(const ANewVersion: TJvID3Version);\r\nvar\r\n Frame: TJvID3DoubleListFrame;\r\nbegin\r\n if IsEmpty then\r\n Exit;\r\n\r\n case ANewVersion of\r\n ive2_2, ive2_3:\r\n if FrameID in [fiInvolvedPeople2, fiMusicianCreditList] then\r\n begin\r\n { Change fiInvolvedPeople2, fiMusicianCreditList to fiInvolvedPeople }\r\n Frame := TJvID3DoubleListFrame.FindOrCreate(FController, fiInvolvedPeople);\r\n List.Assign(Frame.List);\r\n end;\r\n ive2_4:\r\n if FrameID = fiInvolvedPeople then\r\n begin\r\n { Change fiInvolvedPeople to fiInvolvedPeople2 }\r\n Frame := TJvID3DoubleListFrame.FindOrCreate(FController, fiInvolvedPeople2);\r\n List.Assign(Frame.List);\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJvID3DoubleListFrame.CheckFrame(const HandleError: TJvID3HandleError): Boolean;\r\nbegin\r\n Result := True;\r\nend;\r\n\r\nprocedure TJvID3DoubleListFrame.Clear;\r\nbegin\r\n List.Clear;\r\n inherited Clear;\r\nend;\r\n\r\nclass function TJvID3DoubleListFrame.Find(AController: TJvID3Controller;\r\n const AFrameID: TJvID3FrameID): TJvID3DoubleListFrame;\r\nvar\r\n Frame: TJvID3Frame;\r\nbegin\r\n Result := nil;\r\n if not Assigned(AController) or not AController.Active then\r\n Exit;\r\n\r\n Frame := AController.Frames.FindFrame(AFrameID);\r\n if Frame is TJvID3DoubleListFrame then\r\n Result := TJvID3DoubleListFrame(Frame)\r\nend;\r\n\r\nclass function TJvID3DoubleListFrame.FindOrCreate(AController: TJvID3Controller;\r\n const AFrameID: TJvID3FrameID): TJvID3DoubleListFrame;\r\nbegin\r\n if not Assigned(AController) then\r\n ID3Error(RsEID3NoController);\r\n\r\n Result := Find(AController, AFrameID);\r\n if not Assigned(Result) then\r\n begin\r\n AController.CheckFrameClass(TJvID3DoubleListFrame, AFrameID);\r\n Result := TJvID3DoubleListFrame(AController.AddFrame(AFrameID));\r\n end;\r\nend;\r\n\r\nfunction TJvID3DoubleListFrame.GetFrameSize(const ToEncoding: TJvID3Encoding): Cardinal;\r\nvar\r\n I: Integer;\r\nbegin\r\n { 1 byte for encoding }\r\n Result := 1;\r\n\r\n for I := 0 to List.Count - 1 do\r\n begin\r\n Inc(Result, LengthEnc(Names[I], ToEncoding));\r\n Inc(Result, LengthTerminatorEnc(ToEncoding));\r\n Inc(Result, LengthEnc(Values[I], ToEncoding));\r\n Inc(Result, LengthTerminatorEnc(ToEncoding));\r\n end;\r\nend;\r\n\r\nfunction TJvID3DoubleListFrame.GetIsEmpty: Boolean;\r\nbegin\r\n Result := (List.Count = 0) or ((List.Count = 1) and (List[0] = ''))\r\nend;\r\n\r\nfunction TJvID3DoubleListFrame.GetNames(const Index: Integer): WideString;\r\nbegin\r\n Result := List.Names[Index];\r\nend;\r\n\r\nfunction TJvID3DoubleListFrame.GetValues(const Index: Integer): WideString;\r\nbegin\r\n if Index >= 0 then\r\n Result := Copy(List[Index], Length(Names[Index]) + 2, MaxInt)\r\n else\r\n Result := '';\r\nend;\r\n\r\nprocedure TJvID3DoubleListFrame.ListChanged(Sender: TObject);\r\nbegin\r\n Changed;\r\nend;\r\n\r\nfunction TJvID3DoubleListFrame.MustWriteAsUTF: Boolean;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := False;\r\n for I := 0 to List.Count - 1 do\r\n if HasNonISO_8859_1Chars(List[i]) then\r\n begin\r\n Result := True;\r\n Exit;\r\n end;\r\nend;\r\n\r\nprocedure TJvID3DoubleListFrame.ReadFrame;\r\nconst\r\n CMinBytes: array [TJvID3Encoding] of Byte = (2, 4, 4, 2);\r\nvar\r\n S1, S2: WideString;\r\nbegin\r\n with Stream do\r\n begin\r\n ReadEncoding;\r\n\r\n while BytesTillEndOfFrame > CMinBytes[Encoding] do\r\n begin\r\n ReadStringEnc(S1);\r\n ReadStringEnc(S2);\r\n List.Add(S1 + '=' + S2);\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJvID3DoubleListFrame.SameUniqueIDAs(const Frame: TJvID3Frame): Boolean;\r\nbegin\r\n Result := (Assigned(Frame) and (Frame.FrameID = FrameID)) or inherited SameUniqueIDAs(Frame);\r\nend;\r\n\r\nprocedure TJvID3DoubleListFrame.SetList(Value: {$IFDEF COMPILER12_UP}TStrings{$ELSE}JclUnicode.TWideStrings{$ENDIF COMPILER12_UP});\r\nbegin\r\n FList.Assign(Value);\r\n Changed;\r\nend;\r\n\r\nfunction TJvID3DoubleListFrame.SupportsVersion(const AVersion: TJvID3Version): Boolean;\r\nbegin\r\n case FrameID of\r\n { Deprecated in 2.4 }\r\n\r\n { [IPLS] - Involved people list\r\n This frame is replaced by the two frames TMCL, 'Musician credits\r\n and TIPL, 'Involved people list' }\r\n\r\n fiInvolvedPeople:\r\n Result := AVersion in [ive2_2, ive2_3];\r\n\r\n { New frames in 2.4 }\r\n\r\n fiInvolvedPeople2, { [TIPL] Involved people list }\r\n fiMusicianCreditList: { [TMCL] Musician credits list }\r\n Result := AVersion = ive2_4;\r\n else\r\n Result := True;\r\n end;\r\nend;\r\n\r\nprocedure TJvID3DoubleListFrame.WriteFrame;\r\nvar\r\n I: Integer;\r\nbegin\r\n with Stream do\r\n begin\r\n WriteEncoding;\r\n for I := 0 to List.Count - 1 do\r\n begin\r\n WriteStringEnc(Names[I]);\r\n WriteTerminatorEnc;\r\n WriteStringEnc(Values[I]);\r\n WriteTerminatorEnc;\r\n end;\r\n end;\r\nend;\r\n\r\n//=== { TJvID3ExtendedHeader } ===============================================\r\n\r\nprocedure TJvID3ExtendedHeader.Assign(Source: TPersistent);\r\nbegin\r\n if Source is TJvID3ExtendedHeader then\r\n begin\r\n FTotalFrameCRC := TJvID3ExtendedHeader(Source).TotalFrameCRC;\r\n FSizeOfPadding := TJvID3ExtendedHeader(Source).SizeOfPadding;\r\n FFlags := TJvID3ExtendedHeader(Source).Flags;\r\n end\r\n else\r\n inherited Assign(Source);\r\nend;\r\n\r\nprocedure TJvID3ExtendedHeader.ChangeToVersion(const ANewVersion: TJvID3Version);\r\nbegin\r\n case ANewVersion of\r\n ive2_2:\r\n FFlags := [];\r\n ive2_3:\r\n FFlags := FFlags - [hefTagIsAnUpdate, hefTagRestrictions];\r\n ive2_4:\r\n { Nothing }\r\n else\r\n ID3Error(RsEID3VersionNotSupported, Controller);\r\n end;\r\nend;\r\n\r\nfunction TJvID3ExtendedHeader.GetSize: Cardinal;\r\nbegin\r\n Result := GetSizeForVersion(Controller.Version);\r\nend;\r\n\r\nfunction TJvID3ExtendedHeader.GetSizeForVersion(const AVersion: TJvID3Version): Cardinal;\r\nbegin\r\n case AVersion of\r\n ive2_2:\r\n Result := 0;\r\n ive2_3:\r\n begin\r\n { The 'Extended header size', currently 6 or 10 bytes, excludes itself. }\r\n Result := 6;\r\n if hefCRCDataPresent in Flags then\r\n Inc(Result, 4);\r\n end;\r\n ive2_4:\r\n begin\r\n Result := 6;\r\n if hefTagIsAnUpdate in Flags then\r\n Inc(Result, 1);\r\n if hefCRCDataPresent in Flags then\r\n Inc(Result, 6);\r\n if hefTagRestrictions in Flags then\r\n Inc(Result, 2);\r\n end;\r\n else\r\n Result := 0;\r\n ID3Error(RsEID3UnknownVersion, Controller);\r\n end;\r\nend;\r\n\r\nprocedure TJvID3ExtendedHeader.Read;\r\nvar\r\n LSize: Cardinal;\r\n LFlag: Byte;\r\n FlagDataLength: Byte;\r\nbegin\r\n Reset;\r\n\r\n { Controller.Version is the actual version of the stream; Controller.ReadVersion\r\n is the version it's transformed in _after_ reading the data from the stream }\r\n case Controller.Version of\r\n ive2_2:\r\n ; { Do nothing }\r\n ive2_3:\r\n with Stream do\r\n begin\r\n ReadFixedNumber(LSize);\r\n\r\n BeginReadFrame(LSize);\r\n try\r\n { Flags:\r\n\r\n %x0000000 00000000 x - CRC data present\r\n }\r\n Read(LFlag, 1);\r\n if LFlag and $80 > 0 then\r\n Include(FFlags, hefCRCDataPresent);\r\n\r\n { Not used: }\r\n Read(LFlag, 1);\r\n\r\n { Size of padding }\r\n ReadFixedNumber(FSizeOfPadding);\r\n\r\n if hefCRCDataPresent in FFlags then\r\n { Total frame CRC }\r\n ReadFixedNumber(FTotalFrameCRC);\r\n finally\r\n EndReadFrame;\r\n end;\r\n end;\r\n ive2_4:\r\n with Stream do\r\n begin\r\n ReadSyncSafeInteger(LSize);\r\n\r\n { LSize is the size of the whole extended header, thus including the\r\n just read 4 bytes. An extended header can never have a size of fewer\r\n than six bytes}\r\n\r\n if LSize < 6 then\r\n Exit;\r\n\r\n BeginReadFrame(LSize - 4);\r\n try\r\n { Nr of flag bytes; always 1 in v2.4 }\r\n Read(FlagDataLength, 1);\r\n\r\n { Flags:\r\n\r\n %0bcd0000 b - Tag is an update\r\n c - CRC data present\r\n d - Tag restrictions\r\n }\r\n Read(LFlag, 1);\r\n\r\n if LFlag and $40 > 0 then\r\n Include(FFlags, hefTagIsAnUpdate);\r\n if LFlag and $20 > 0 then\r\n Include(FFlags, hefCRCDataPresent);\r\n if LFlag and $10 > 0 then\r\n Include(FFlags, hefTagRestrictions);\r\n\r\n if hefTagIsAnUpdate in FFlags then\r\n begin\r\n Read(FlagDataLength, 1);\r\n { Expect FlagDataLength to be 0 }\r\n end;\r\n if hefCRCDataPresent in FFlags then\r\n begin\r\n Read(FlagDataLength, 1);\r\n { Expect FlagDataLength to be 5 }\r\n ReadSyncSafeInteger(FTotalFrameCRC, 5);\r\n end;\r\n if hefTagRestrictions in FFlags then\r\n begin\r\n Read(FlagDataLength, 1);\r\n { Expect FlagDataLength to be 1 }\r\n Read(LFlag, 1);\r\n { Flags:\r\n\r\n %ppqrrstt p - Tag size restrictions\r\n q - Text encoding restrictions\r\n r - Text fields size restrictions\r\n s - Image encoding restrictions\r\n t - Image size restrictions\r\n }\r\n with FRestrictions do\r\n begin\r\n RTagSize := TJvID3TagSizeRestriction((LFlag shr 6) and 3);\r\n RTextEncoding := TJvID3TextEncodingRestriction((LFlag shr 5) and 1);\r\n RTextFieldsSize := TJvID3TextFieldsSizeRestriction((LFlag shr 3) and 3);\r\n RImageEncoding := TJvID3ImageEncodingRestriction((LFlag shr 2) and 1);\r\n RImageSize := TJvID3ImageSizeRestriction(LFlag and 3);\r\n end;\r\n end;\r\n finally\r\n EndReadFrame;\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvID3ExtendedHeader.Reset;\r\nbegin\r\n FTotalFrameCRC := 0;\r\n FSizeOfPadding := 0;\r\n FFlags := [];\r\nend;\r\n\r\nprocedure TJvID3ExtendedHeader.SetFlags(const Value: TJvID3HeaderExtendedFlags);\r\nvar\r\n ChangedFlags: TJvID3HeaderExtendedFlags;\r\nbegin\r\n if FFlags <> Value then\r\n begin\r\n ChangedFlags := FFlags + Value - (FFlags * Value);\r\n\r\n { hefCRCDataPresent is currently not supported }\r\n if (hefCRCDataPresent in ChangedFlags) and (hefCRCDataPresent in Value) then\r\n ID3Error(RsEControllerDoesNotSupportCRC, Controller);\r\n\r\n FFlags := Value;\r\n end;\r\nend;\r\n\r\nprocedure TJvID3ExtendedHeader.Write;\r\nvar\r\n LFlag: Byte;\r\n FlagDataLength: Byte;\r\n LExtendedHeaderSize: Cardinal;\r\nbegin\r\n LExtendedHeaderSize := GetSizeForVersion(Controller.WriteVersion);\r\n\r\n case Controller.WriteVersion of\r\n ive2_2:\r\n ; { Do nothing }\r\n ive2_3:\r\n with Stream do\r\n begin\r\n WriteFixedNumber(LExtendedHeaderSize);\r\n\r\n BeginWriteFrame(LExtendedHeaderSize);\r\n try\r\n { Flags:\r\n\r\n %x0000000 00000000 x - CRC data present\r\n }\r\n LFlag := 0;\r\n if hefCRCDataPresent in Flags then\r\n Inc(LFlag, $80);\r\n Write(LFlag, 1);\r\n\r\n { Not used }\r\n LFlag := 0;\r\n Write(LFlag, 1);\r\n\r\n { Size of padding }\r\n WriteFixedNumber(FSizeOfPadding);\r\n\r\n if hefCRCDataPresent in FFlags then\r\n { Total frame CRC }\r\n WriteFixedNumber(FTotalFrameCRC);\r\n finally\r\n EndWriteFrame;\r\n end;\r\n end;\r\n ive2_4:\r\n with Stream do\r\n begin\r\n WriteSyncSafeInteger(LExtendedHeaderSize);\r\n { LExtendedHeaderSize is the size of the whole extended header, thus\r\n including the just read 4 bytes }\r\n\r\n BeginWriteFrame(LExtendedHeaderSize - 4);\r\n try\r\n { Nr of flag bytes; always 1 in v2.4 }\r\n FlagDataLength := 1;\r\n Write(FlagDataLength, 1);\r\n\r\n { Flags:\r\n\r\n %0bcd0000 b - Tag is an update\r\n c - CRC data present\r\n d - Tag restrictions\r\n }\r\n LFlag := 0;\r\n if hefTagIsAnUpdate in Flags then\r\n Inc(LFlag, $40);\r\n if hefCRCDataPresent in Flags then\r\n Inc(LFlag, $20);\r\n if hefTagRestrictions in Flags then\r\n Inc(LFlag, $10);\r\n Write(LFlag, 1);\r\n\r\n if hefTagIsAnUpdate in FFlags then\r\n begin\r\n { FlagDataLength is always 0 for hefTagIsAnUpdate }\r\n FlagDataLength := 0;\r\n Write(FlagDataLength, 1);\r\n end;\r\n if hefCRCDataPresent in FFlags then\r\n begin\r\n { FlagDataLength is always 5 for hefCRCDataPresent }\r\n FlagDataLength := 5;\r\n Write(FlagDataLength, 1);\r\n\r\n WriteSyncSafeInteger(FTotalFrameCRC, 5);\r\n end;\r\n if hefTagRestrictions in FFlags then\r\n begin\r\n { FlagDataLength is always 1 for hefTagIsAnUpdate }\r\n FlagDataLength := 1;\r\n Write(FlagDataLength, 1);\r\n\r\n { Flags:\r\n\r\n %ppqrrstt p - Tag size restrictions\r\n q - Text encoding restrictions\r\n r - Text fields size restrictions\r\n s - Image encoding restrictions\r\n t - Image size restrictions\r\n }\r\n with FRestrictions do\r\n LFlag :=\r\n ((Byte(RTagSize) and 3) shl 7) +\r\n ((Byte(RTextEncoding) and 1) shl 5) +\r\n ((Byte(RTextFieldsSize) and 3) shl 3) +\r\n ((Byte(RImageEncoding) and 1) shl 2) +\r\n (Byte(RImageSize) and 3);\r\n Write(LFlag, 1);\r\n end;\r\n finally\r\n EndWriteFrame;\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\n//=== { TJvID3FileInfo } =====================================================\r\n\r\nprocedure TJvID3FileInfo.Calc;\r\nconst\r\n CID3v1Size: array [Boolean] of Integer = (0, 128);\r\nvar\r\n Tmp: Extended;\r\nbegin\r\n if FAudioSize = 0 then\r\n { No vbr tag found, so we calculate the audio size }\r\n FAudioSize := FFileSize - FHeaderFoundAt - CID3v1Size[FHasID3v1Tag];\r\n\r\n if (FAudioSize > 0) and (FFrameCount > 0) then\r\n begin\r\n { We've found a vbr tag (with enough info) }\r\n Tmp := FAudioSize / FFrameCount;\r\n FFrameLengthInBytes := Round(Tmp);\r\n\r\n { Determine average bitrate }\r\n Tmp := FSamplingRateFrequency * Tmp / CLayerArray[Layer];\r\n if Version in [mvVersion2, mvVersion25] then\r\n Tmp := Tmp / 2;\r\n\r\n FBitrate := Round(Tmp);\r\n FLengthInSec := Trunc((FAudioSize * 8) / (1000 * Tmp));\r\n end\r\n else\r\n if FBitrate > 0 then\r\n FLengthInSec := Trunc((FAudioSize * 8) / (1000 * FBitrate));\r\n\r\n if FFrameLengthInBytes = 0 then\r\n begin\r\n { Didn't calc the FFrameLengthInBytes yet }\r\n Tmp := 0;\r\n if (FBitrate <> CFreeBitrate) and (FSamplingRateFrequency > 0) then\r\n begin\r\n Tmp := CLayerArray[Layer] * FBitrate / FSamplingRateFrequency + FPaddingLength;\r\n if Version in [mvVersion2, mvVersion25] then\r\n Tmp := Tmp / 2;\r\n end;\r\n\r\n if Tmp > 0 then\r\n begin\r\n FFrameCount := Round(FAudioSize / Tmp);\r\n FFrameLengthInBytes := Round(Tmp);\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJvID3FileInfo.GetIsValid: Boolean;\r\nbegin\r\n Result := (FHeaderFoundAt >= 0) and (FLayer <> mlNotDefined) and (FVersion <> mvReserved);\r\nend;\r\n\r\nprocedure TJvID3FileInfo.ParseMPEGTag(AMPEGTag: PAnsiChar);\r\nvar\r\n LHasPadding: Boolean;\r\n B: Byte;\r\nbegin\r\n { Most info from http://www.dv.co.yu/mpgscript/mpeghdr.htm }\r\n\r\n { AAAAAAAA AAABBCCD EEEEFFGH IIJJKLMM -> bits\r\n\r\n A 11 (31-21) Frame sync (all bits set)\r\n B 2 (20,19) MPEG Audio version ID\r\n 00 - MPEG Version 2.5 (unofficial)\r\n 01 - reserved\r\n 10 - MPEG Version 2 (ISO/IEC 13818-3)\r\n 11 - MPEG Version 1 (ISO/IEC 11172-3)\r\n C 2 (18,17) Layer description\r\n 00 - reserved\r\n 01 - Layer III\r\n 10 - Layer II\r\n 11 - Layer I\r\n D 1 (16) Protection bit\r\n 0 - Protected by CRC (16bit crc follows header)\r\n 1 - Not protected\r\n E 4 (15,12) Bitrate index\r\n\r\n bits V1,L1 V1,L2 V1,L3 V2,L1 V2, L2 & L3\r\n 0000 free free free free free\r\n 0001 32 32 32 32 8\r\n 0010 64 48 40 48 16\r\n 0011 96 56 48 56 24\r\n 0100 128 64 56 64 32\r\n 0101 160 80 64 80 40\r\n 0110 192 96 80 96 48\r\n 0111 224 112 96 112 56\r\n 1000 256 128 112 128 64\r\n 1001 288 160 128 144 80\r\n 1010 320 192 160 160 96\r\n 1011 352 224 192 176 112\r\n 1100 384 256 224 192 128\r\n 1101 416 320 256 224 144\r\n 1110 448 384 320 256 160\r\n 1111 bad bad bad bad bad\r\n\r\n NOTES: All values are in kbps\r\n V1 - MPEG Version 1\r\n V2 - MPEG Version 2 and Version 2.5\r\n L1 - Layer I\r\n L2 - Layer II\r\n L3 - Layer III\r\n \"free\" means free format.\r\n \"bad\" means that this is not an allowed value\r\n\r\n F 2 (11,10) Sampling rate frequency index (values are in Hz) bits\r\n MPEG1 MPEG2 MPEG2.5\r\n 00 44100 22050 11025\r\n 01 48000 24000 12000\r\n 10 32000 16000 8000\r\n 11 reserv. reserv. reserv.\r\n G 1 (9) Padding bit\r\n 0 - frame is not padded\r\n 1 - frame is padded with one extra slot\r\n H 1 (8) Private bit.\r\n I 2 (7,6) Channel Mode\r\n 00 - Stereo\r\n 01 - Joint stereo (Stereo)\r\n 10 - Dual channel (2 mono channels)\r\n 11 - Single channel (Mono)\r\n J 2 (5,4) Mode extension (Only if Joint stereo)\r\n Layer I and II Layer III\r\n value Intensity stereo MS stereo\r\n 00 bands 4 to 31 off off\r\n 01 bands 8 to 31 on off\r\n 10 bands 12 to 31 off on\r\n 11 bands 16 to 31 on on\r\n K 1 (3) Copyright\r\n 0 - Audio is not copyrighted\r\n 1 - Audio is copyrighted\r\n L 1 (2) Original\r\n 0 - Copy of original media\r\n 1 - Original media\r\n M 2 (1,0) Emphasis\r\n 00 - none\r\n 01 - 50/15 ms\r\n 10 - reserved\r\n 11 - CCIT J.17\r\n }\r\n\r\n { Note: we assume a Reset is done before Parse is called, so we can\r\n do quick exits }\r\n\r\n { D }\r\n B := PByte(AMPEGTag + 1)^;\r\n if B and $1 = 0 then\r\n Include(FBits, mbProtection);\r\n { C }\r\n B := B shr 1;\r\n FLayer := TJvMPEGLayer(B and $3);\r\n { B }\r\n B := B shr 2;\r\n FVersion := TJvMPEGVersion(B and $3);\r\n if (FLayer = mlNotDefined) or (FVersion = mvReserved) then\r\n Exit;\r\n\r\n B := PByte(AMPEGTag + 2)^;\r\n { H }\r\n if B and $1 > 0 then\r\n Include(FBits, mbPrivate);\r\n B := B shr 1;\r\n { G }\r\n LHasPadding := B and $1 > 0;\r\n B := B shr 1;\r\n { F }\r\n FSamplingRateFrequency := CSamplingFrequency[Version, B and $3];\r\n B := B shr 2;\r\n { E }\r\n FBitrate := CBitrate[CMapBitrate[Version in [mvVersion2, mvVersion25], Layer], B and $F];\r\n if FBitrate = CBadBitrate then\r\n Exit;\r\n\r\n B := PByte(AMPEGTag + 3)^;\r\n { M }\r\n FEmphasis := TJvMPEGEmphasis(B and $3);\r\n B := B shr 2;\r\n { L }\r\n if B and $1 > 0 then\r\n Include(FBits, mbOriginal);\r\n B := B shr 1;\r\n { K }\r\n if B and $1 > 0 then\r\n Include(FBits, mbCopyrighted);\r\n B := B shr 1;\r\n { J }\r\n FModeExtension := TJvMPEGModeExtension(B and $3);\r\n B := B shr 2;\r\n { I }\r\n FChannelMode := TJvMPEGChannelMode(B and $3);\r\n\r\n { Calculate some stuff }\r\n if LHasPadding then\r\n begin\r\n if Layer = mlLayerI then\r\n FPaddingLength := 4\r\n else\r\n FPaddingLength := 1;\r\n end\r\n else\r\n FPaddingLength := 0;\r\nend;\r\n\r\nprocedure TJvID3FileInfo.ParseVbrTag(AMPEGTag: PAnsiChar);\r\nconst\r\n VBRTag_Xing: array [0..3] of AnsiChar = AnsiString('Xing'); { Do not change case }\r\n VBRTag_Info: array [0..3] of AnsiChar = AnsiString('Info'); { Do not change case }\r\n FRAMES_FLAG = $0001;\r\n BYTES_FLAG = $0002;\r\n TOC_FLAG = $0004;\r\nvar\r\n HeadFlags: Integer;\r\nbegin\r\n { Now try to find the Xing or Info tag }\r\n\r\n { maximum bytes needed is currently: 4 + 32 + 4 + 4 + 4 + 4 = 52 }\r\n if Version = mvVersion1 then\r\n begin\r\n if ChannelMode <> mcSingleChannel then\r\n Inc(AMPEGTag, 32 + 4)\r\n else\r\n Inc(AMPEGTag, 17 + 4)\r\n end\r\n else\r\n begin\r\n if ChannelMode <> mcSingleChannel then\r\n Inc(AMPEGTag, 17 + 4)\r\n else\r\n Inc(AMPEGTag, 9 + 4);\r\n end;\r\n\r\n if (PLongint(AMPEGTag)^ <> Longint(VBRTag_Xing)) and\r\n (PLongint(AMPEGTag)^ <> Longint(VBRTag_Info)) then\r\n Exit;\r\n Inc(AMPEGTag, 4);\r\n\r\n { (rb) Now always true?? }\r\n FIsVBR := True;\r\n\r\n HeadFlags := ReverseBytes(PInteger(AMPEGTag)^);\r\n Inc(AMPEGTag, 4);\r\n\r\n if HeadFlags and FRAMES_FLAG > 0 then\r\n begin\r\n FFrameCount := ReverseBytes(PInteger(AMPEGTag)^);\r\n Inc(AMPEGTag, 4);\r\n end;\r\n\r\n if HeadFlags and BYTES_FLAG > 0 then\r\n FAudioSize := ReverseBytes(PInteger(AMPEGTag)^);\r\nend;\r\n\r\nprocedure TJvID3FileInfo.Read(AStream: TStream; const Offset: Int64);\r\nconst\r\n CID3v1Tag = AnsiString('TAG'); { do not change case }\r\n CTagSize = 128;\r\n CTagIDSize = 3;\r\n CMPEGTagSize = 52;\r\nvar\r\n TagID: array [0..CTagIDSize - 1] of AnsiChar;\r\n MPEGTag: array [0..CMPEGTagSize - 1] of AnsiChar;\r\nbegin\r\n Reset;\r\n\r\n FHeaderFoundAt := SearchSync(AStream, Offset, MPEGTag, CMPEGTagSize);\r\n if FHeaderFoundAt < 0 then\r\n Exit;\r\n\r\n ParseMPEGTag(@MPEGTag);\r\n ParseVbrTag(@MPEGTag);\r\n\r\n if FFileSize = 0 then\r\n FFileSize := AStream.Size;\r\n\r\n if (FAudioSize = 0) and (FFileSize >= 128) then\r\n begin\r\n { Need to determine if the file has an ID3v1 tag }\r\n AStream.Seek(-CTagSize, soFromEnd);\r\n FHasID3v1Tag := (AStream.Read(TagID, CTagIDSize) = CTagIDSize) and (TagID = CID3v1Tag);\r\n end;\r\n\r\n { We now know enough to calculate the rest }\r\n Calc;\r\nend;\r\n\r\nprocedure TJvID3FileInfo.Reset;\r\nbegin\r\n FAudioSize := 0;\r\n FBitrate := 0;\r\n FBits := [];\r\n FChannelMode := Low(TJvMPEGChannelMode);\r\n FEmphasis := Low(TJvMPEGEmphasis);\r\n FFileSize := 0;\r\n FFrameCount := 0;\r\n FFrameLengthInBytes := 0;\r\n FHasID3v1Tag := False;\r\n FHeaderFoundAt := -1;\r\n FIsVBR := False;\r\n FLayer := Low(TJvMPEGLayer);\r\n FLengthInSec := 0;\r\n FModeExtension := Low(TJvMPEGModeExtension);\r\n FSamplingRateFrequency := 0;\r\n FVersion := Low(TJvMPEGVersion);\r\nend;\r\n\r\n//=== { TJvID3Frame } ========================================================\r\n\r\nconstructor TJvID3Frame.Create(AOwner: TComponent; const AFrameID: TJvID3FrameID;\r\n const AFrameIDStr: AnsiString);\r\nbegin\r\n inherited Create(AOwner);\r\n\r\n CheckFrameID(AFrameID);\r\n\r\n FFrameID := AFrameID;\r\n FrameName := AFrameIDStr;\r\n\r\n FEncoding := ienISO_8859_1;\r\nend;\r\n\r\ndestructor TJvID3Frame.Destroy;\r\nbegin\r\n if (FController <> nil) and (FFrames <> nil) then\r\n FFrames.Remove(Self);\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvID3Frame.Assign(Source: TPersistent);\r\nbegin\r\n if Source = nil then\r\n Clear\r\n else\r\n if Source is TJvID3Frame then\r\n begin\r\n FFlags := TJvID3Frame(Source).Flags;\r\n FEncryptionID := TJvID3Frame(Source).EncryptionID;\r\n FGroupID := TJvID3Frame(Source).GroupID;\r\n FDecompressedSize := TJvID3Frame(Source).FDecompressedSize;\r\n FEncoding := TJvID3Frame(Source).Encoding;\r\n { v2.4 }\r\n FDataLengthIndicator := TJvID3Frame(Source).FDataLengthIndicator;\r\n\r\n Changed;\r\n end\r\n else\r\n inherited Assign(Source);\r\nend;\r\n\r\nclass function TJvID3Frame.CanAddFrame(AController: TJvID3Controller;\r\n AFrameID: TJvID3FrameID): Boolean;\r\nbegin\r\n Result := False;\r\nend;\r\n\r\nprocedure TJvID3Frame.Changed;\r\nbegin\r\n FFrameSize := GetFrameSize(Encoding);\r\n DataChanged;\r\nend;\r\n\r\nprocedure TJvID3Frame.ChangeToVersion(const ANewVersion: TJvID3Version);\r\nbegin\r\n { Do nothing }\r\nend;\r\n\r\nfunction TJvID3Frame.CheckFrame(const HandleError: TJvID3HandleError): Boolean;\r\nbegin\r\n Result := False;\r\nend;\r\n\r\nprocedure TJvID3Frame.CheckFrameID(const AFrameID: TJvID3FrameID);\r\nbegin\r\n if AFrameID in [fiErrorFrame, fiPaddingFrame] then\r\n ErrorFmt(RsEID3FrameIDNotSupported, [ID3_FrameIDToString(AFrameID)]);\r\n\r\n if TJvID3Controller.GetFrameClass(AFrameID) <> ClassType then\r\n ErrorFmt(RsEID3FrameIDNotSupported, [ID3_FrameIDToString(AFrameID)]);\r\nend;\r\n\r\nprocedure TJvID3Frame.CheckFrameIDStr(const S: AnsiString);\r\nvar\r\n LFrameID: TJvID3FrameID;\r\nbegin\r\n LFrameID := ID3_StringToFrameID(S);\r\n if LFrameID in [fiErrorFrame, fiPaddingFrame] then\r\n ErrorFmt(RsEID3FrameIDStrNotSupported, [S]);\r\n\r\n if TJvID3Controller.GetFrameClass(LFrameID) <> ClassType then\r\n ErrorFmt(RsEID3FrameIDStrNotSupported, [S]);\r\nend;\r\n\r\nfunction TJvID3Frame.CheckIsUnique: Boolean;\r\nbegin\r\n Result := FFrames.CheckIsUnique(Self);\r\nend;\r\n\r\nprocedure TJvID3Frame.Clear;\r\nbegin\r\n Changed;\r\nend;\r\n\r\nprocedure TJvID3Frame.DataChanged;\r\nbegin\r\n if Assigned(FController) then\r\n FController.ID3Event(ideFrameChange, Longint(Self));\r\nend;\r\n\r\nprocedure TJvID3Frame.Error(const Msg: string);\r\nbegin\r\n ID3ErrorFmt(RsEErrorInFrame, [FrameName, Name, Msg], Controller);\r\nend;\r\n\r\nprocedure TJvID3Frame.ErrorFmt(const Msg: string;\r\n const Args: array of const);\r\nbegin\r\n Error(Format(Msg, Args));\r\nend;\r\n\r\nfunction TJvID3Frame.GetFrameIDStrForVersion(\r\n const Version: TJvID3Version): AnsiString;\r\nbegin\r\n if FFrameIDStr = '' then\r\n case Version of\r\n ive2_2:\r\n Result := ID3_FrameIDToString(FrameID, 3);\r\n ive2_3, ive2_4:\r\n Result := ID3_FrameIDToString(FrameID, 4);\r\n else\r\n Error(RsEID3UnknownVersion);\r\n end\r\n else\r\n Result := FFrameIDStr;\r\nend;\r\n\r\nfunction TJvID3Frame.GetFrameName: AnsiString;\r\nbegin\r\n Result := GetFrameIDStrForVersion(ive2_3);\r\nend;\r\n\r\nfunction TJvID3Frame.GetIndex: Integer;\r\nbegin\r\n if FFrames <> nil then\r\n Result := FFrames.IndexOf(Self)\r\n else\r\n Result := -1;\r\nend;\r\n\r\nfunction TJvID3Frame.GetIsEmpty: Boolean;\r\nbegin\r\n Result := True;\r\nend;\r\n\r\nfunction TJvID3Frame.GetStream: TJvID3Stream;\r\nbegin\r\n if not Assigned(FController) then\r\n Error(RsEID3NoController);\r\n\r\n if icsUsingTempStream in FController.FState then\r\n Result := FController.FTempStream\r\n else\r\n Result := FController.FStream;\r\nend;\r\n\r\nfunction TJvID3Frame.MustWriteAsUTF: Boolean;\r\nbegin\r\n Result := False;\r\nend;\r\n\r\nprocedure TJvID3Frame.Read;\r\nvar\r\n LFrameSize: Integer;\r\nbegin\r\n { Note: don't use 'with Stream do' for the whole procedure, because calling\r\n BeginUseTempStream changes the value of property Stream\r\n }\r\n\r\n ReadFrameHeader;\r\n\r\n if not Stream.CanRead(FrameSize) then\r\n begin\r\n { Serious error, skip the rest of the stream }\r\n Stream.BeginReadFrame(Stream.BytesTillEndOfTag);\r\n Stream.EndReadFrame;\r\n end\r\n else\r\n if (Controller.Version = ive2_4) and (fhfUnsynchronisationApplied in FFlags) then\r\n begin\r\n { Stream is unsynchronised, remove the unsynchronisation scheme and\r\n read the frame }\r\n\r\n Stream.BeginReadFrame(FrameSize);\r\n try\r\n Controller.RemoveUnsynchronisationSchemeToTempStream(FrameSize);\r\n finally\r\n Stream.EndReadFrame;\r\n end;\r\n\r\n LFrameSize := Controller.GetTempStreamSize;\r\n\r\n Controller.BeginUseTempStream;\r\n try\r\n Stream.BeginReadFrame(LFrameSize);\r\n try\r\n //Self.Clear;\r\n ReadFrame;\r\n finally\r\n Stream.EndReadFrame;\r\n end;\r\n finally\r\n Controller.EndUseTempStream;\r\n end;\r\n end\r\n else\r\n with Stream do\r\n begin\r\n BeginReadFrame(FrameSize);\r\n try\r\n //Self.Clear;\r\n ReadFrame;\r\n finally\r\n EndReadFrame;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvID3Frame.ReadEncoding;\r\nbegin\r\n Stream.ReadEnc(FEncoding);\r\nend;\r\n\r\nprocedure TJvID3Frame.ReadFrameHeader;\r\nvar\r\n Flag0, Flag1: Byte;\r\nbegin\r\n case Controller.Version of\r\n ive2_2:\r\n with Stream do\r\n begin\r\n { Frame ID $xx xx xx (three characters) // read in TJvID3Frames.Read\r\n Size $xx xx xx\r\n }\r\n\r\n ReadFixedNumber3(FFrameSize);\r\n\r\n FFlags := [];\r\n end;\r\n ive2_3:\r\n with Stream do\r\n begin\r\n { Frame ID $xx xx xx xx (four characters) // read in TJvID3Frames.Read\r\n Size $xx xx xx xx\r\n Flags $xx xx\r\n }\r\n\r\n ReadFixedNumber(FFrameSize);\r\n\r\n { Flags:\r\n\r\n %abc00000 %ijk00000 a - Tag alter preservation i - Compression\r\n b - File alter preservation j - Encryption\r\n c - Read only k - Grouping identity\r\n }\r\n\r\n FFlags := [];\r\n\r\n Read(Flag0, 1);\r\n Read(Flag1, 1);\r\n\r\n if (Flag0 and $80) > 0 then\r\n Include(FFlags, fhfOnTagAlterDiscardFrame);\r\n if (Flag0 and $40) > 0 then\r\n Include(FFlags, fhfOnFileAlterDiscardFrame);\r\n if (Flag0 and $20) > 0 then\r\n Include(FFlags, fhfReadOnly);\r\n\r\n if (Flag1 and $80) > 0 then\r\n Include(FFlags, fhfIsCompressed);\r\n if (Flag1 and $40) > 0 then\r\n Include(FFlags, fhfIsEncrypted);\r\n if (Flag1 and $20) > 0 then\r\n Include(FFlags, fhfContainsGroupInformation);\r\n\r\n if fhfIsCompressed in Flags then\r\n ReadFixedNumber(FDecompressedSize);\r\n\r\n if fhfIsEncrypted in Flags then\r\n Read(FEncryptionID, 1);\r\n\r\n if fhfContainsGroupInformation in Flags then\r\n Read(FGroupID, 1);\r\n end;\r\n ive2_4:\r\n with Stream do\r\n begin\r\n { Frame ID $xx xx xx xx (four characters) // read in TJvID3Frames.Read\r\n Size 4 * %0xxxxxxx\r\n Flags $xx xx\r\n }\r\n ReadSyncSafeInteger(FFrameSize, 4);\r\n FFlags := [];\r\n\r\n { Flags:\r\n\r\n %0abc0000 %0h00kmnp a - Tag alter preservation k - Compression\r\n b - File alter preservation m - Encryption\r\n c - Read only n - Unsynchronisation\r\n h - Grouping identity p - Data length indicator\r\n }\r\n\r\n Read(Flag0, 1);\r\n Read(Flag1, 1);\r\n\r\n if (Flag0 and $40) > 0 then\r\n Include(FFlags, fhfOnTagAlterDiscardFrame);\r\n if (Flag0 and $20) > 0 then\r\n Include(FFlags, fhfOnFileAlterDiscardFrame);\r\n if (Flag0 and $10) > 0 then\r\n Include(FFlags, fhfReadOnly);\r\n\r\n if (Flag1 and $40) > 0 then\r\n Include(FFlags, fhfContainsGroupInformation);\r\n if (Flag1 and $08) > 0 then\r\n Include(FFlags, fhfIsCompressed);\r\n if (Flag1 and $04) > 0 then\r\n Include(FFlags, fhfIsEncrypted);\r\n if (Flag1 and $02) > 0 then\r\n Include(FFlags, fhfUnsynchronisationApplied);\r\n if (Flag1 and $01) > 0 then\r\n Include(FFlags, fhfDataLengthIndicator);\r\n\r\n if fhfContainsGroupInformation in Flags then\r\n Read(FGroupID, 1);\r\n\r\n if fhfIsEncrypted in Flags then\r\n Read(FEncryptionID, 1);\r\n\r\n if fhfDataLengthIndicator in Flags then\r\n { TODO : why , 4? }\r\n ReadSyncSafeInteger(FDataLengthIndicator, 4);\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJvID3Frame.SameUniqueIDAs(const Frame: TJvID3Frame): Boolean;\r\nbegin\r\n Result := False;\r\nend;\r\n\r\nprocedure TJvID3Frame.SetController(const AController: TJvID3Controller);\r\nbegin\r\n if AController <> FController then\r\n begin\r\n if Assigned(FController) then\r\n FController.FFrames.Remove(Self);\r\n\r\n FController := AController;\r\n\r\n if Assigned(FController) then\r\n FController.FFrames.Add(Self);\r\n end;\r\nend;\r\n\r\nprocedure TJvID3Frame.SetEncoding(const Value: TJvID3Encoding);\r\nbegin\r\n if FEncoding <> Value then\r\n begin\r\n FEncoding := Value;\r\n Changed;\r\n end;\r\nend;\r\n\r\nprocedure TJvID3Frame.SetFlags(const Value: TJvID3FrameHeaderFlags);\r\nvar\r\n ChangedFlags: TJvID3FrameHeaderFlags;\r\nbegin\r\n if FFlags <> Value then\r\n begin\r\n ChangedFlags := FFlags + Value - (FFlags * Value);\r\n\r\n { fhfIsCompressed is currently not supported }\r\n if (fhfIsCompressed in ChangedFlags) and (fhfIsCompressed in Value) then\r\n ID3Error(RsEControllerDoesNotSupportCompression, Controller);\r\n\r\n { fhfIsEncrypted is currently not supported }\r\n if (fhfIsEncrypted in ChangedFlags) and (fhfIsEncrypted in Value) then\r\n ID3Error(RsEControllerDoesNotSupportEncryption, Controller);\r\n\r\n FFlags := Value;\r\n end;\r\nend;\r\n\r\nprocedure TJvID3Frame.SetFrameID(const Value: TJvID3FrameID);\r\nbegin\r\n { TODO : Refresh designer while changing }\r\n CheckFrameID(Value);\r\n\r\n FFrameID := Value;\r\n FFrameIDStr := '';\r\nend;\r\n\r\nprocedure TJvID3Frame.SetFrameName(NewFrameName: AnsiString);\r\nbegin\r\n { TODO : Refresh designer while changing }\r\n if NewFrameName = '' then\r\n FFrameIDStr := ''\r\n else\r\n begin\r\n { Force uppercase }\r\n NewFrameName := AnsiUpperCase(NewFrameName);\r\n\r\n CheckFrameIDStr(NewFrameName);\r\n FFrameID := ID3_StringToFrameID(NewFrameName);\r\n if FFrameID = fiUnknownFrame then\r\n FFrameIDStr := NewFrameName\r\n else\r\n FFrameIDStr := '';\r\n end;\r\nend;\r\n\r\nprocedure TJvID3Frame.SetIndex(const Value: Integer);\r\nbegin\r\n if FFrames <> nil then\r\n FFrames.SetFrameIndex(Self, Value)\r\nend;\r\n\r\nfunction TJvID3Frame.SupportsVersion(const AVersion: TJvID3Version): Boolean;\r\nbegin\r\n Result := AVersion in CSupportedVersions;\r\nend;\r\n\r\nprocedure TJvID3Frame.UpdateFrameSize;\r\nbegin\r\n FFrameSize := GetFrameSize(Encoding);\r\nend;\r\n\r\nprocedure TJvID3Frame.Write;\r\nvar\r\n LFrameSize: Cardinal;\r\nbegin\r\n { Note: don't use 'with Stream do' for the whole procedure, because calling\r\n BeginUseTempStream changes the value of property Stream\r\n }\r\n\r\n if not SupportsVersion(Controller.WriteVersion) then\r\n Exit;\r\n\r\n if Controller.WriteEncodingAs = ifeAuto then\r\n begin\r\n if Self.MustWriteAsUTF then\r\n Self.Encoding := ienUTF_16\r\n else\r\n Self.Encoding := ienISO_8859_1\r\n end;\r\n\r\n Stream.SourceEncoding := Self.Encoding;\r\n\r\n WriteID;\r\n\r\n { Get the frame size, with the encoding as the stream }\r\n LFrameSize := GetFrameSize(Stream.DestEncoding);\r\n\r\n if (Controller.WriteVersion = ive2_4) and\r\n (fhfUnsynchronisationApplied in FFlags) then\r\n begin\r\n { Write the frame to the temporary stream }\r\n Controller.BeginUseTempStream;\r\n try\r\n Stream.BeginWriteFrame(LFrameSize);\r\n try\r\n WriteFrame;\r\n finally\r\n Stream.EndWriteFrame;\r\n end;\r\n\r\n { Retrieve the frame size _before_ unsynchronisation }\r\n FDataLengthIndicator := Controller.GetTempStreamSize;\r\n\r\n Controller.ApplyUnsynchronisationSchemeOnCurrentStream;\r\n finally\r\n Controller.EndUseTempStream;\r\n end;\r\n\r\n { Retrieve the frame size _after_ unsynchronisation }\r\n LFrameSize := Controller.GetTempStreamSize;\r\n\r\n WriteFrameHeader(LFrameSize);\r\n\r\n Controller.WriteTempStream;\r\n end\r\n else\r\n with Stream do\r\n begin\r\n WriteFrameHeader(LFrameSize);\r\n\r\n BeginWriteFrame(LFrameSize);\r\n try\r\n WriteFrame;\r\n finally\r\n EndWriteFrame;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvID3Frame.WriteEncoding;\r\nbegin\r\n with Stream do\r\n WriteEnc;\r\nend;\r\n\r\nprocedure TJvID3Frame.WriteFrameHeader(const AFrameSize: Cardinal);\r\nvar\r\n Flag0, Flag1: Byte;\r\nbegin\r\n { Note: A v2.3 or v2.3 frame size is written as 4 bytes, thus always fits\r\n exactly in a Cardinal. A v2.2 frame size is written as 3 bytes }\r\n case Controller.WriteVersion of\r\n ive2_2:\r\n if AFrameSize > $00FFFFFF then // = 16 MB\r\n ID3Error(RsEFrameSizeTooBig, Self)\r\n else\r\n with Stream do\r\n begin\r\n { Frame ID $xx xx xx (three characters) // Written in TJvID3Frame.Write\r\n Size $xx xx xx\r\n }\r\n\r\n WriteFixedNumber3(AFrameSize);\r\n end;\r\n ive2_3:\r\n with Stream do\r\n begin\r\n { Frame ID $xx xx xx xx (four characters) // Written in TJvID3Frame.Write\r\n Size $xx xx xx xx\r\n Flags $xx xx\r\n }\r\n\r\n WriteFixedNumber(AFrameSize);\r\n\r\n { Flags:\r\n\r\n %abc00000 %ijk00000 a - Tag alter preservation i - Compression\r\n b - File alter preservation j - Encryption\r\n c - Read only k - Grouping identity\r\n }\r\n\r\n Flag0 := 0;\r\n Flag1 := 0;\r\n\r\n if fhfOnTagAlterDiscardFrame in FFlags then\r\n Inc(Flag0, $80);\r\n if fhfOnFileAlterDiscardFrame in FFlags then\r\n Inc(Flag0, $40);\r\n if fhfReadOnly in FFlags then\r\n Inc(Flag0, $20);\r\n\r\n { Compression is not supported }\r\n //if fhfIsCompressed in FFlags then\r\n // Inc(Flag1, $80);\r\n { Encryption is not supported }\r\n //if fhfIsEncrypted in FFlags then\r\n // Inc(Flag1, $40);\r\n if fhfContainsGroupInformation in FFlags then\r\n Inc(Flag1, $20);\r\n\r\n Write(Flag0, 1);\r\n Write(Flag1, 1);\r\n\r\n { Compression is not supported }\r\n //if fhfIsCompressed in Flags then\r\n // WriteFixedNumber(FDecompressedSize);\r\n\r\n { Encryption is not supported }\r\n //if fhfIsEncrypted in Flags then\r\n // Write(FEncryptionID, 1);\r\n\r\n if fhfContainsGroupInformation in Flags then\r\n Write(FGroupID, 1);\r\n end;\r\n ive2_4:\r\n with Stream do\r\n begin\r\n { Frame ID $xx xx xx xx (four characters) // read in TJvID3Frames.Read\r\n Size 4 * %0xxxxxxx\r\n Flags $xx xx\r\n }\r\n WriteSyncSafeInteger(AFrameSize, 4);\r\n\r\n { Flags:\r\n\r\n %0abc0000 %0h00kmnp a - Tag alter preservation k - Compression\r\n b - File alter preservation m - Encryption\r\n c - Read only n - Unsynchronisation\r\n h - Grouping identity p - Data length indicator\r\n }\r\n\r\n Flag0 := 0;\r\n Flag1 := 0;\r\n\r\n if fhfOnTagAlterDiscardFrame in FFlags then\r\n Inc(Flag0, $40);\r\n if fhfOnFileAlterDiscardFrame in FFlags then\r\n Inc(Flag0, $20);\r\n if fhfReadOnly in FFlags then\r\n Inc(Flag0, $10);\r\n\r\n if fhfContainsGroupInformation in FFlags then\r\n Inc(Flag1, $40);\r\n { Compression is not supported }\r\n //if fhfIsCompressed in FFlags then\r\n // Inc(Flag1, $08);\r\n { Encryption is not supported }\r\n //if fhfIsEncrypted in FFlags then\r\n // Inc(Flag1, $04);\r\n if fhfUnsynchronisationApplied in FFlags then\r\n Inc(Flag1, $02);\r\n if fhfDataLengthIndicator in FFlags then\r\n Inc(Flag1, $01);\r\n\r\n Write(Flag0, 1);\r\n Write(Flag1, 1);\r\n\r\n if fhfContainsGroupInformation in Flags then\r\n Write(FGroupID, 1);\r\n\r\n { Encryption is not supported }\r\n //if fhfIsEncrypted in Flags then\r\n // Write(FEncryptionID, 1);\r\n\r\n if fhfDataLengthIndicator in Flags then\r\n WriteSyncSafeInteger(FDataLengthIndicator, 4);\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvID3Frame.WriteID;\r\nvar\r\n LFrameIDStr: AnsiString;\r\n FrameIDLength: Byte;\r\nbegin\r\n LFrameIDStr := GetFrameIDStrForVersion(Controller.WriteVersion);\r\n FrameIDLength := GetFrameIDLength(Controller.WriteVersion);\r\n\r\n if Length(LFrameIDStr) <> FrameIDLength then\r\n begin\r\n SetLength(LFrameIDStr, FrameIDLength);\r\n FillChar(LFrameIDStr, FrameIDLength, #0);\r\n end;\r\n\r\n Stream.Write(PAnsiChar(LFrameIDStr)^, FrameIDLength);\r\nend;\r\n\r\n//=== { TJvID3Frames } =======================================================\r\n\r\nprocedure TJvID3Frames.Add(Frame: TJvID3Frame);\r\nbegin\r\n CheckCanAddFrame(Frame.FrameID);\r\n\r\n FList.Add(Frame);\r\n Frame.FFrames := Self;\r\n Frame.Controller := Controller;\r\n Changed;\r\nend;\r\n\r\nprocedure TJvID3Frames.AfterConstruction;\r\nbegin\r\n FList := TList.Create;\r\n inherited AfterConstruction;\r\nend;\r\n\r\nprocedure TJvID3Frames.Assign(Source: TPersistent);\r\nvar\r\n I: Integer;\r\n Frame: TJvID3Frame;\r\nbegin\r\n if Source is TJvID3Frames then\r\n begin\r\n Clear;\r\n for I := 0 to TJvID3Frames(Source).FList.Count - 1 do\r\n begin\r\n Frame := Controller.AddFrame(TJvID3Frames(Source).Frames[I].FrameID);\r\n Frame.FrameName := TJvID3Frames(Source).Frames[I].FrameName;\r\n Frame.Assign(TJvID3Frames(Source).Frames[I]);\r\n end;\r\n end\r\n else\r\n inherited Assign(Source);\r\nend;\r\n\r\nprocedure TJvID3Frames.BeforeDestruction;\r\nbegin\r\n inherited BeforeDestruction;\r\n if FList <> nil then\r\n Clear;\r\n FList.Free;\r\nend;\r\n\r\nprocedure TJvID3Frames.Changed;\r\nbegin\r\n if (FController <> nil) and not (csDestroying in FController.ComponentState) then\r\n FController.ID3Event(ideFrameListChange, 0);\r\n {if Assigned(OnChange) then OnChange(Self);}\r\nend;\r\n\r\nprocedure TJvID3Frames.ChangeToVersion(const ANewVersion: TJvID3Version);\r\nvar\r\n I: Integer;\r\nbegin\r\n if not (ANewVersion in CSupportedVersions) then\r\n ID3Error(RsEID3VersionNotSupported, Controller);\r\n\r\n for I := Count - 1 downto 0 do\r\n Frames[I].ChangeToVersion(ANewVersion);\r\n\r\n for I := Count - 1 downto 0 do\r\n if not Frames[I].SupportsVersion(ANewVersion) then\r\n Frames[I].Free;\r\nend;\r\n\r\nprocedure TJvID3Frames.CheckCanAddFrame(FrameID: TJvID3FrameID);\r\nbegin\r\n if not FController.CanAddFrame(FrameID) then\r\n ID3ErrorFmt(RsEID3AlreadyContainsFrame, [ID3_FrameIDToString(FrameID)]);\r\nend;\r\n\r\nfunction TJvID3Frames.CheckFrames(const HandleError: TJvID3HandleError): Boolean;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := False;\r\n { Check whether the frames have correct parameters }\r\n for I := 0 to Count - 1 do\r\n if not Frames[I].CheckFrame(HandleError) then\r\n Exit;\r\n\r\n { Check whether the frames are unique }\r\n for I := Count - 1 downto 0 do\r\n if not Frames[I].CheckIsUnique then\r\n case HandleError of\r\n heAutoCorrect:\r\n Frames[I].Free;\r\n heRaise:\r\n Frames[I].Error(RsEID3DuplicateFrame);\r\n else\r\n Exit;\r\n end;\r\n\r\n Result := True;\r\nend;\r\n\r\nfunction TJvID3Frames.CheckIsUnique(Frame: TJvID3Frame): Boolean;\r\nvar\r\n FoundFrame: TJvID3Frame;\r\nbegin\r\n Result := True;\r\n if not Assigned(Frame) then\r\n Exit;\r\n\r\n if not Controller.FindFirstFrame(Frame.FrameID, FoundFrame) then\r\n Exit;\r\n\r\n while Assigned(FoundFrame) and (FoundFrame.Index < Frame.Index) do\r\n begin\r\n if FoundFrame.SameUniqueIDAs(Frame) then\r\n begin\r\n Result := False;\r\n Break;\r\n end;\r\n\r\n if not Controller.FindNextFrame(Frame.FrameID, FoundFrame) then\r\n Break;\r\n end;\r\nend;\r\n\r\nprocedure TJvID3Frames.Clear;\r\nvar\r\n F: TJvID3Frame;\r\nbegin\r\n if FList.Count <= 0 then\r\n Exit;\r\n\r\n while FList.Count > 0 do\r\n begin\r\n F := FList.Last;\r\n F.FController := nil;\r\n F.Free;\r\n FList.Delete(FList.Count - 1);\r\n end;\r\n Changed;\r\nend;\r\n\r\nfunction TJvID3Frames.FindFrame(const FrameID: TJvID3FrameID): TJvID3Frame;\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := 0 to FList.Count - 1 do\r\n begin\r\n Result := FList.Items[I];\r\n if Result.FrameID = FrameID then\r\n Exit\r\n end;\r\n Result := nil;\r\nend;\r\n\r\nfunction TJvID3Frames.FindFrame(const FrameName: AnsiString): TJvID3Frame;\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := 0 to FList.Count - 1 do\r\n begin\r\n Result := FList.Items[I];\r\n if SameText(Result.FrameName, FrameName) then\r\n Exit;\r\n end;\r\n Result := nil;\r\nend;\r\n\r\nfunction TJvID3Frames.FrameByID(const FrameID: TJvID3FrameID): TJvID3Frame;\r\nbegin\r\n Result := FindFrame(FrameID);\r\n if Result = nil then\r\n ID3ErrorFmt(RsEID3FrameNotFound, [ID3_FrameIDToString(FrameID)], Controller);\r\nend;\r\n\r\nfunction TJvID3Frames.FrameByName(const FrameName: AnsiString): TJvID3Frame;\r\nbegin\r\n Result := FindFrame(FrameName);\r\n if Result = nil then\r\n ID3ErrorFmt(RsEID3FrameNotFound, [FrameName], Controller);\r\nend;\r\n\r\nfunction TJvID3Frames.GetCount: Integer;\r\nbegin\r\n Result := FList.Count;\r\nend;\r\n\r\nfunction TJvID3Frames.GetFrame(Index: Integer): TJvID3Frame;\r\nbegin\r\n Result := FList[Index];\r\nend;\r\n\r\nfunction TJvID3Frames.GetFrameIDs: TJvID3FrameIDs;\r\nbegin\r\nend;\r\n\r\nprocedure TJvID3Frames.GetFrameNames(List: TStrings);\r\nvar\r\n I: Integer;\r\nbegin\r\n List.BeginUpdate;\r\n try\r\n List.Clear;\r\n for I := 0 to FList.Count - 1 do\r\n List.Add(string(TJvID3Frame(FList.Items[I]).FrameName))\r\n finally\r\n List.EndUpdate;\r\n end;\r\nend;\r\n\r\nfunction TJvID3Frames.IndexOf(Frame: TJvID3Frame): Integer;\r\nbegin\r\n Result := FList.IndexOf(Frame);\r\nend;\r\n\r\nprocedure TJvID3Frames.Read;\r\nconst\r\n { v2.2 : Frame header is 6 bytes\r\n v2.3 and up : Frame header is minimal 10 bytes }\r\n CMinimalHeaderSize: array [Boolean] of Byte = (6, 10);\r\nvar\r\n Frame: TJvID3Frame;\r\n FrameIDStr: AnsiString;\r\n FrameID: TJvID3FrameID;\r\n\r\n LFrameIDLength: Byte;\r\n LMinimalHeaderSize: Byte;\r\nbegin\r\n LFrameIDLength := GetFrameIDLength(Controller.Version);\r\n LMinimalHeaderSize := CMinimalHeaderSize[Controller.Version > ive2_2];\r\n SetLength(FrameIDStr, LFrameIDLength);\r\n\r\n with Stream do\r\n while BytesTillEndOfTag >= LMinimalHeaderSize do\r\n begin\r\n if Read(PAnsiChar(FrameIDStr)^, LFrameIDLength) <> LFrameIDLength then\r\n Exit;\r\n\r\n FrameID := ID3_StringToFrameID(FrameIDStr);\r\n\r\n if FrameID in [fiPaddingFrame, fiErrorFrame] then\r\n Exit;\r\n\r\n Frame := Controller.AddFrame(FrameID);\r\n if Assigned(Frame) then\r\n begin\r\n Frame.FrameName := FrameIDStr;\r\n Frame.Read;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvID3Frames.Remove(Frame: TJvID3Frame);\r\nbegin\r\n if Assigned(Frame) then\r\n begin\r\n FList.Remove(Frame);\r\n Frame.FFrames := nil;\r\n Changed;\r\n end;\r\nend;\r\n\r\nprocedure TJvID3Frames.RemoveEmptyFrames;\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := Count - 1 downto 0 do\r\n if Frames[I].IsEmpty then\r\n Frames[I].Free;\r\nend;\r\n\r\nprocedure TJvID3Frames.Reset;\r\nbegin\r\n Clear;\r\nend;\r\n\r\nprocedure TJvID3Frames.SetFrame(Index: Integer; Value: TJvID3Frame);\r\nbegin\r\n Frames[Index].Assign(Value);\r\nend;\r\n\r\nprocedure TJvID3Frames.SetFrameIndex(Frame: TJvID3Frame; Value: Integer);\r\nvar\r\n CurIndex, Count: Integer;\r\nbegin\r\n CurIndex := FList.IndexOf(Frame);\r\n if CurIndex >= 0 then\r\n begin\r\n Count := FList.Count;\r\n if Value < 0 then\r\n Value := 0;\r\n if Value >= Count then\r\n Value := Count - 1;\r\n if Value <> CurIndex then\r\n begin\r\n FList.Delete(CurIndex);\r\n FList.Insert(Value, Frame);\r\n Changed;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvID3Frames.Write;\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := 0 to FList.Count - 1 do\r\n Frames[I].Write;\r\nend;\r\n\r\n//=== { TJvID3GeneralObjFrame } ==============================================\r\n\r\nprocedure TJvID3GeneralObjFrame.Assign(Source: TPersistent);\r\nvar\r\n Src: TJvID3GeneralObjFrame;\r\nbegin\r\n if Source is TJvID3GeneralObjFrame then\r\n begin\r\n Src := TJvID3GeneralObjFrame(Source);\r\n\r\n FContentDescription := Src.ContentDescription;\r\n FMIMEType := Src.MIMEType;\r\n FFileName := Src.FFileName;\r\n end;\r\n inherited Assign(Source);\r\nend;\r\n\r\nclass function TJvID3GeneralObjFrame.CanAddFrame(AController: TJvID3Controller;\r\n AFrameID: TJvID3FrameID): Boolean;\r\nbegin\r\n { There may be more than one \"GEOB\" frame in each tag, but only one with the\r\n same content descriptor. }\r\n Result := (AFrameID = fiGeneralObject) or\r\n inherited CanAddFrame(AController, AFrameID);\r\nend;\r\n\r\nfunction TJvID3GeneralObjFrame.CheckFrame(const HandleError: TJvID3HandleError): Boolean;\r\nbegin\r\n Result := True;\r\nend;\r\n\r\nprocedure TJvID3GeneralObjFrame.Clear;\r\nbegin\r\n FContentDescription := '';\r\n FMIMEType := '';\r\n FFileName := '';\r\n\r\n inherited Clear;\r\nend;\r\n\r\nclass function TJvID3GeneralObjFrame.Find(AController: TJvID3Controller;\r\n const AContentDescription: WideString): TJvID3GeneralObjFrame;\r\nvar\r\n Frame: TJvID3Frame;\r\nbegin\r\n Result := nil;\r\n if not Assigned(AController) or not AController.Active then\r\n Exit;\r\n\r\n if not AController.FindFirstFrame(fiGeneralObject, Frame) then\r\n Exit;\r\n\r\n while (Frame is TJvID3GeneralObjFrame) and\r\n not SameStr(TJvID3GeneralObjFrame(Frame).ContentDescription, AContentDescription) do\r\n\r\n AController.FindNextFrame(fiGeneralObject, Frame);\r\n\r\n if Frame is TJvID3GeneralObjFrame then\r\n Result := TJvID3GeneralObjFrame(Frame);\r\nend;\r\n\r\nclass function TJvID3GeneralObjFrame.Find(AController: TJvID3Controller): TJvID3GeneralObjFrame;\r\nvar\r\n Frame: TJvID3Frame;\r\nbegin\r\n Result := nil;\r\n if not Assigned(AController) or not AController.Active then\r\n Exit;\r\n\r\n Frame := AController.Frames.FindFrame(fiGeneralObject);\r\n if Frame is TJvID3GeneralObjFrame then\r\n Result := TJvID3GeneralObjFrame(Frame);\r\nend;\r\n\r\nclass function TJvID3GeneralObjFrame.FindOrCreate(AController: TJvID3Controller;\r\n const AContentDescription: WideString): TJvID3GeneralObjFrame;\r\nbegin\r\n if not Assigned(AController) then\r\n ID3Error(RsEID3NoController);\r\n\r\n Result := Find(AController, AContentDescription);\r\n if not Assigned(Result) then\r\n begin\r\n Result := TJvID3GeneralObjFrame(AController.AddFrame(fiGeneralObject));\r\n Result.ContentDescription := AContentDescription;\r\n end;\r\nend;\r\n\r\nclass function TJvID3GeneralObjFrame.FindOrCreate(AController: TJvID3Controller): TJvID3GeneralObjFrame;\r\nbegin\r\n if not Assigned(AController) then\r\n ID3Error(RsEID3NoController);\r\n\r\n Result := Find(AController);\r\n if not Assigned(Result) then\r\n Result := TJvID3GeneralObjFrame(AController.AddFrame(fiGeneralObject));\r\nend;\r\n\r\nfunction TJvID3GeneralObjFrame.GetFrameSize(const ToEncoding: TJvID3Encoding): Cardinal;\r\nbegin\r\n { Text encoding $xx\r\n MIME type $00\r\n FileName $00 (00)\r\n Content description $00 (00)\r\n Encapsulated object \r\n }\r\n Result := 1 + Cardinal(Length(MIMEType)) + 1 +\r\n LengthEnc(FileName, ToEncoding) +\r\n LengthTerminatorEnc(ToEncoding) +\r\n LengthEnc(ContentDescription, ToEncoding) +\r\n LengthTerminatorEnc(ToEncoding) +\r\n DataSize;\r\nend;\r\n\r\nfunction TJvID3GeneralObjFrame.GetIsEmpty: Boolean;\r\nbegin\r\n Result := inherited GetIsEmpty and (Length(FMIMEType) = 0) and\r\n (ContentDescription = '') and\r\n (FileName = '');\r\nend;\r\n\r\nfunction TJvID3GeneralObjFrame.MustWriteAsUTF: Boolean;\r\nbegin\r\n Result := HasNonISO_8859_1Chars(FileName) or HasNonISO_8859_1Chars(ContentDescription);\r\nend;\r\n\r\nprocedure TJvID3GeneralObjFrame.ReadFrame;\r\nbegin\r\n { Text encoding $xx\r\n MIME type $00\r\n FileName $00 (00)\r\n Content description $00 (00)\r\n Encapsulated object \r\n }\r\n with Stream do\r\n begin\r\n ReadEncoding;\r\n ReadStringA(FMIMEType);\r\n ReadStringEnc(FFileName);\r\n ReadStringEnc(FContentDescription);\r\n end;\r\n ReadData(Stream.BytesTillEndOfFrame);\r\nend;\r\n\r\nfunction TJvID3GeneralObjFrame.SameUniqueIDAs(const Frame: TJvID3Frame): Boolean;\r\nbegin\r\n { There may be more than one \"GEOB\" frame in each tag, but only one with the\r\n same content descriptor. }\r\n Result := (Frame is TJvID3GeneralObjFrame) and\r\n (Frame.FrameID = FrameID) and (FrameID = fiGeneralObject);\r\n\r\n if Result then\r\n Result := SameStr(TJvID3GeneralObjFrame(Frame).ContentDescription, ContentDescription)\r\n else\r\n Result := inherited SameUniqueIDAs(Frame);\r\nend;\r\n\r\nprocedure TJvID3GeneralObjFrame.SetContentDescription(const Value: WideString);\r\nbegin\r\n if Value <> FContentDescription then\r\n begin\r\n FContentDescription := Value;\r\n Changed;\r\n end;\r\nend;\r\n\r\nprocedure TJvID3GeneralObjFrame.SetFileName(const Value: WideString);\r\nbegin\r\n if Value <> FFileName then\r\n begin\r\n FFileName := Value;\r\n Changed;\r\n end;\r\nend;\r\n\r\nprocedure TJvID3GeneralObjFrame.SetMIMEType(const Value: AnsiString);\r\nbegin\r\n if FMIMEType <> Value then\r\n begin\r\n FMIMEType := Value;\r\n Changed;\r\n end;\r\nend;\r\n\r\nprocedure TJvID3GeneralObjFrame.WriteFrame;\r\nbegin\r\n { Text encoding $xx\r\n MIME type $00\r\n FileName $00 (00)\r\n Content description $00 (00)\r\n Encapsulated object \r\n }\r\n with Stream do\r\n begin\r\n WriteEncoding;\r\n WriteStringA(MIMEType);\r\n WriteTerminatorA;\r\n WriteStringEnc(FileName);\r\n WriteTerminatorEnc;\r\n WriteStringEnc(ContentDescription);\r\n WriteTerminatorEnc;\r\n end;\r\n WriteData;\r\nend;\r\n\r\n//=== { TJvID3Header } =======================================================\r\n\r\nprocedure TJvID3Header.Assign(Source: TPersistent);\r\nbegin\r\n if Source is TJvID3Header then\r\n begin\r\n FHasTag := TJvID3Header(Source).HasTag;\r\n FRevisionNumber := TJvID3Header(Source).RevisionNumber;\r\n FMajorVersion := TJvID3Header(Source).MajorVersion;\r\n FSize := TJvID3Header(Source).Size;\r\n FFlags := TJvID3Header(Source).Flags;\r\n end\r\n else\r\n inherited Assign(Source);\r\nend;\r\n\r\nprocedure TJvID3Header.ChangeToVersion(const ANewVersion: TJvID3Version);\r\nbegin\r\n case ANewVersion of\r\n ive2_2:\r\n begin\r\n FRevisionNumber := 0;\r\n FMajorVersion := 2;\r\n { Only flag 'hfUnsynchronisation' is allowed }\r\n FFlags := FFlags * [hfUnsynchronisation];\r\n end;\r\n ive2_3:\r\n begin\r\n FRevisionNumber := 0;\r\n FMajorVersion := 3;\r\n Exclude(FFlags, hfFooterPresent);\r\n end;\r\n ive2_4:\r\n begin\r\n FRevisionNumber := 0;\r\n FMajorVersion := 4;\r\n end;\r\n else\r\n ID3Error(RsEID3VersionNotSupported);\r\n end;\r\nend;\r\n\r\nprocedure TJvID3Header.Read;\r\nvar\r\n Header: TID3v2HeaderRec;\r\nbegin\r\n Reset;\r\n\r\n with Stream do\r\n begin\r\n BeginReadFrame(10);\r\n try\r\n if Read(Header, 10) <> 10 then\r\n Exit;\r\n\r\n FHasTag := Header.Identifier = cID3HeaderId;\r\n if not FHasTag then\r\n Exit;\r\n\r\n { This sets Controller.Version }\r\n FMajorVersion := Header.MajorVersion;\r\n FRevisionNumber := Header.RevisionNumber;\r\n\r\n { v2.2 : %ae000000 a - Unsynchronisation d - Footer present\r\n v2.3 : %abc00000 b - Extended header e - Compression (only v2.2)\r\n v2.4 : %abcd0000 c - Experimental indicator\r\n }\r\n if Header.Flags and $80 > 0 then\r\n Include(FFlags, hfUnsynchronisation);\r\n if Header.Flags and $40 > 0 then\r\n begin\r\n { v2.2: Since no compression scheme has been decided yet, the ID3\r\n decoder (for now) should just ignore the entire tag if the\r\n compression bit is set. }\r\n if Controller.Version <> ive2_2 then\r\n Include(FFlags, hfExtendedHeader);\r\n end;\r\n if Header.Flags and $20 > 0 then\r\n Include(FFlags, hfExperimentalIndicator);\r\n if Header.Flags and $10 > 0 then\r\n Include(FFlags, hfFooterPresent);\r\n\r\n { The ID3v2 tag size is the size of the complete tag after unsychronisation,\r\n including padding, excluding the header but not excluding the extended\r\n header }\r\n UnSyncSafe(Header.Size, 4, FSize);\r\n finally\r\n EndReadFrame;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvID3Header.Reset;\r\nbegin\r\n FHasTag := False;\r\n FRevisionNumber := 0;\r\n FMajorVersion := 0;\r\n FSize := 0;\r\n FFlags := [];\r\nend;\r\n\r\nprocedure TJvID3Header.SetFlags(const Value: TJvID3HeaderFlags);\r\nvar\r\n ChangedFlags: TJvID3HeaderFlags;\r\nbegin\r\n if FFlags <> Value then\r\n begin\r\n ChangedFlags := FFlags + Value - (FFlags * Value);\r\n\r\n { hfFooterPresent is currently not supported }\r\n if (hfFooterPresent in ChangedFlags) and (hfFooterPresent in Value) then\r\n ID3Error(RsEControllerDoesNotSupportFooter, Controller);\r\n\r\n FFlags := Value;\r\n end;\r\nend;\r\n\r\nprocedure TJvID3Header.Write;\r\nconst\r\n { iveLowerThan2_2, ive2_2, ive2_3, ive2_4, iveHigherThan2_4 }\r\n CMajorVersion: array [TJvID3Version] of Byte = (2, 2, 3, 4, 4);\r\n CRevisionNumber: array [TJvID3Version] of Byte = (0, 0, 0, 0, 0);\r\nvar\r\n Header: TID3v2HeaderRec;\r\nbegin\r\n { Check max size }\r\n if Self.FSize > $0FFFFFFF then // 28 bits = 256 MB\r\n ID3Error(RsETagTooBig, Controller);\r\n\r\n FillChar(Header, SizeOf(Header), #0);\r\n\r\n with Stream do\r\n begin\r\n BeginWriteFrame(10);\r\n try\r\n Header.Identifier := cID3HeaderId;\r\n Header.MajorVersion := CMajorVersion[Controller.WriteVersion];\r\n Header.RevisionNumber := CRevisionNumber[Controller.WriteVersion];\r\n\r\n { v2.2 : %ae000000 a - Unsynchronisation d - Footer present\r\n v2.3 : %abc00000 b - Extended header e - Compression (only v2.2)\r\n v2.4 : %abcd0000 c - Experimental indicator\r\n }\r\n if hfUnsynchronisation in Flags then\r\n Inc(Header.Flags, $80);\r\n if Controller.WriteVersion > ive2_2 then\r\n begin\r\n if hfExtendedHeader in Flags then\r\n Inc(Header.Flags, $40);\r\n if hfExperimentalIndicator in Flags then\r\n Inc(Header.Flags, $20);\r\n { Only for v2.4 }\r\n if (Controller.WriteVersion = ive2_4) and (hfFooterPresent in Flags) then\r\n Inc(Header.Flags, $10);\r\n end;\r\n { The ID3v2 tag size is the size of the complete tag after unsychronisation,\r\n including padding, excluding the header but not excluding the extended\r\n header }\r\n SyncSafe(FSize, Header.Size, 4);\r\n\r\n WriteBuffer(Header, 10);\r\n finally\r\n EndWriteFrame;\r\n end;\r\n end;\r\nend;\r\n\r\n//=== { TJvID3NumberFrame } ==================================================\r\n\r\nprocedure TJvID3NumberFrame.ChangeToVersion(const ANewVersion: TJvID3Version);\r\nvar\r\n Year: Word;\r\n LDate: TDateTime;\r\n Frame: TJvID3Frame;\r\nbegin\r\n if ANewVersion <> ive2_4 then\r\n Exit;\r\n\r\n { Change\r\n\r\n * fiYear, fiDate, fiTime, fiRecordingDates frames into 1 fiRecordingTime frame\r\n * fiOrigYear frame into 1 fiOrigReleaseTime frame }\r\n\r\n if FrameID = fiYear then\r\n begin\r\n if Assigned(FFrames.FindFrame(fiRecordingTime)) then\r\n Exit;\r\n\r\n { 1. Determine the year from a fiYear frame, ie this frame }\r\n Year := Value;\r\n\r\n { 2. Determine month + day from a fiDate frame }\r\n Frame := TJvID3TextFrame.Find(FController, fiDate);\r\n if Assigned(Frame) then\r\n with TJvID3TextFrame(Frame) do\r\n LDate := GetID3Date(FText, Encoding, Year)\r\n else\r\n try\r\n { hm, no date frame , just assume it's 1 jan }\r\n LDate := EncodeDate(Year, 1, 1);\r\n except\r\n on EConvertError do\r\n LDate := 0;\r\n end;\r\n\r\n { 3. Determine hour + min from a fiTime frame}\r\n Frame := TJvID3TextFrame.Find(FController, fiTime);\r\n if Assigned(Frame) then\r\n with TJvID3TextFrame(Frame) do\r\n LDate := LDate + GetID3Time(FText, Encoding);\r\n\r\n { 4. Copy constructed date to a fiRecordingTime frame }\r\n TJvID3TimestampFrame.FindOrCreate(FController, fiRecordingTime).Value := LDate;\r\n end\r\n else\r\n if FrameID = fiOrigYear then\r\n begin\r\n if Assigned(FFrames.FindFrame(fiOrigReleaseTime)) then\r\n Exit;\r\n\r\n try\r\n LDate := EncodeDate(Value, 1, 1);\r\n except\r\n on EConvertError do\r\n LDate := 0;\r\n end;\r\n\r\n { Copy date to a fiRecordingTime frame }\r\n TJvID3TimestampFrame.FindOrCreate(FController, fiOrigReleaseTime).Value := LDate;\r\n end;\r\nend;\r\n\r\nfunction TJvID3NumberFrame.CheckFrame(const HandleError: TJvID3HandleError): Boolean;\r\nbegin\r\n if FrameID in [fiOrigYear, fiYear] then\r\n begin\r\n { Always 4 characters long }\r\n Result := FValue < 10000;\r\n\r\n if not Result then\r\n case HandleError of\r\n heAutoCorrect:\r\n begin\r\n { No need to call UpdateFrameSize, because it's always 4 chars long }\r\n Result := True;\r\n FValue := 0;\r\n end;\r\n heRaise:\r\n ErrorFmt(RsEID3ValueTooBig, [FValue]);\r\n end;\r\n end\r\n else\r\n Result := True;\r\nend;\r\n\r\nclass function TJvID3NumberFrame.Find(AController: TJvID3Controller;\r\n const AFrameID: TJvID3FrameID): TJvID3NumberFrame;\r\nvar\r\n Frame: TJvID3Frame;\r\nbegin\r\n Result := nil;\r\n if not Assigned(AController) or not AController.Active then\r\n Exit;\r\n\r\n Frame := AController.Frames.FindFrame(AFrameID);\r\n if Frame is TJvID3NumberFrame then\r\n Result := TJvID3NumberFrame(Frame)\r\nend;\r\n\r\nclass function TJvID3NumberFrame.FindOrCreate(AController: TJvID3Controller;\r\n const AFrameID: TJvID3FrameID): TJvID3NumberFrame;\r\nbegin\r\n if not Assigned(AController) then\r\n ID3Error(RsEID3NoController);\r\n\r\n Result := Find(AController, AFrameID);\r\n if not Assigned(Result) then\r\n begin\r\n AController.CheckFrameClass(TJvID3NumberFrame, AFrameID);\r\n Result := TJvID3NumberFrame(AController.AddFrame(AFrameID));\r\n end;\r\nend;\r\n\r\nfunction TJvID3NumberFrame.GetIsEmpty: Boolean;\r\nbegin\r\n if FrameID in [fiOrigYear, fiYear] then\r\n Result := Value = 0\r\n else\r\n Result := inherited GetIsEmpty;\r\nend;\r\n\r\nfunction TJvID3NumberFrame.GetText: WideString;\r\nconst\r\n CFormat: array [Boolean] of string = ('%d', '%.4d');\r\nbegin\r\n Result := Format(CFormat[FrameID in [fiOrigYear, fiYear]], [FValue]);\r\nend;\r\n\r\nprocedure TJvID3NumberFrame.SetText(const ANewText: WideString);\r\nbegin\r\n FValue := StrToIntDef(ANewText, 0);\r\n\r\n UpdateFrameSize;\r\nend;\r\n\r\nprocedure TJvID3NumberFrame.SetValue(const AValue: Cardinal);\r\nbegin\r\n if AValue <> FValue then\r\n begin\r\n FValue := AValue;\r\n Changed;\r\n end;\r\nend;\r\n\r\n//=== { TJvID3OwnershipFrame } ===============================================\r\n\r\nprocedure TJvID3OwnershipFrame.Assign(Source: TPersistent);\r\nvar\r\n Src: TJvID3OwnershipFrame;\r\nbegin\r\n if Source is TJvID3OwnershipFrame then\r\n begin\r\n Src := TJvID3OwnershipFrame(Source);\r\n\r\n FPricePayed := Src.PricePayed;\r\n FSeller := Src.Seller;\r\n FDateOfPurch := Src.DateOfPurch;\r\n end;\r\n\r\n inherited Assign(Source);\r\nend;\r\n\r\nclass function TJvID3OwnershipFrame.CanAddFrame(AController: TJvID3Controller;\r\n AFrameID: TJvID3FrameID): Boolean;\r\nbegin\r\n { There may only be one 'OWNE' frame in a tag }\r\n Result := ((AFrameID = fiOwnership) and not AController.HasFrame(fiOwnership)) or\r\n inherited CanAddFrame(AController, AFrameID);\r\nend;\r\n\r\nfunction TJvID3OwnershipFrame.CheckFrame(const HandleError: TJvID3HandleError): Boolean;\r\nbegin\r\n Result := True;\r\nend;\r\n\r\nprocedure TJvID3OwnershipFrame.Clear;\r\nbegin\r\n FPricePayed := '';\r\n FSeller := '';\r\n FDateOfPurch := 0;\r\n inherited Clear;\r\nend;\r\n\r\nclass function TJvID3OwnershipFrame.Find(AController: TJvID3Controller): TJvID3OwnershipFrame;\r\nvar\r\n Frame: TJvID3Frame;\r\nbegin\r\n Result := nil;\r\n if not Assigned(AController) or not AController.Active then\r\n Exit;\r\n\r\n Frame := AController.Frames.FindFrame(fiOwnership);\r\n if Frame is TJvID3OwnershipFrame then\r\n Result := TJvID3OwnershipFrame(Frame)\r\nend;\r\n\r\nclass function TJvID3OwnershipFrame.FindOrCreate(AController: TJvID3Controller): TJvID3OwnershipFrame;\r\nbegin\r\n if not Assigned(AController) then\r\n ID3Error(RsEID3NoController);\r\n\r\n Result := Find(AController);\r\n if not Assigned(Result) then\r\n Result := TJvID3OwnershipFrame(AController.AddFrame(fiOwnership));\r\nend;\r\n\r\nfunction TJvID3OwnershipFrame.GetFrameSize(const ToEncoding: TJvID3Encoding): Cardinal;\r\nbegin\r\n { Text encoding $xx\r\n Price payed $00\r\n Date of purch. \r\n Seller \r\n }\r\n Result := 1 + Cardinal(Length(FPricePayed)) + 1 + 8 +\r\n LengthEnc(Seller, ToEncoding);\r\nend;\r\n\r\nfunction TJvID3OwnershipFrame.GetIsEmpty: Boolean;\r\nbegin\r\n Result := (Length(FPricePayed) = 0) and (Seller = '') and\r\n (FDateOfPurch = 0);\r\nend;\r\n\r\nfunction TJvID3OwnershipFrame.MustWriteAsUTF: Boolean;\r\nbegin\r\n Result := HasNonISO_8859_1Chars(Seller);\r\nend;\r\n\r\nprocedure TJvID3OwnershipFrame.ReadFrame;\r\nbegin\r\n { Text encoding $xx\r\n Price payed $00\r\n Date of purch. \r\n Seller \r\n }\r\n with Stream do\r\n begin\r\n ReadEncoding;\r\n ReadStringA(FPricePayed);\r\n ReadDate(FDateOfPurch);\r\n ReadStringEnc(FSeller);\r\n end;\r\nend;\r\n\r\nfunction TJvID3OwnershipFrame.SameUniqueIDAs(const Frame: TJvID3Frame): Boolean;\r\nbegin\r\n { There may only be one 'OWNE' frame in a tag }\r\n Result := (Assigned(Frame) and (Frame.FrameID = FrameID) and (FrameID = fiOwnership)) or\r\n inherited SameUniqueIDAs(Frame);\r\nend;\r\n\r\nprocedure TJvID3OwnershipFrame.SetDateOfPurch(const Value: TDateTime);\r\nbegin\r\n if FDateOfPurch <> Value then\r\n begin\r\n FDateOfPurch := Value;\r\n Changed;\r\n end;\r\nend;\r\n\r\nprocedure TJvID3OwnershipFrame.SetPricePayed(const Value: AnsiString);\r\nbegin\r\n if FPricePayed <> Value then\r\n begin\r\n FPricePayed := Value;\r\n Changed;\r\n end;\r\nend;\r\n\r\nprocedure TJvID3OwnershipFrame.SetSeller(const Value: WideString);\r\nbegin\r\n if Value <> FSeller then\r\n begin\r\n FSeller := Value;\r\n Changed;\r\n end;\r\nend;\r\n\r\nfunction TJvID3OwnershipFrame.SupportsVersion(const AVersion: TJvID3Version): Boolean;\r\nbegin\r\n case FrameID of\r\n { ** Not supported in 2.2 ** }\r\n\r\n fiOwnership:\r\n Result := AVersion in [ive2_3, ive2_4];\r\n else\r\n Result := True;\r\n end;\r\nend;\r\n\r\nprocedure TJvID3OwnershipFrame.WriteFrame;\r\nbegin\r\n { Text encoding $xx\r\n Price payed $00\r\n Date of purch. \r\n Seller \r\n }\r\n with Stream do\r\n begin\r\n WriteEncoding;\r\n WriteStringA(PricePayed);\r\n WriteTerminatorA;\r\n WriteDate(DateOfPurch);\r\n WriteStringEnc(Seller);\r\n end;\r\nend;\r\n\r\n//=== { TJvID3PictureFrame } =================================================\r\n\r\nprocedure TJvID3PictureFrame.Assign(Source: TPersistent);\r\nvar\r\n Stream: TMemoryStream;\r\nbegin\r\n if Source is TPicture then\r\n Assign(TPicture(Source).Graphic)\r\n else\r\n if Source is TGraphic then\r\n begin\r\n Stream := TMemoryStream.Create;\r\n try\r\n TGraphic(Source).SaveToStream(Stream);\r\n Stream.Seek(0, soFromBeginning);\r\n LoadFromStream(Stream);\r\n finally\r\n Stream.Free;\r\n end;\r\n end\r\n else\r\n if Source is TJvID3PictureFrame then\r\n begin\r\n FMIMEType := TJvID3PictureFrame(Source).MIMEType;\r\n FPictureType := TJvID3PictureFrame(Source).PictureType;\r\n FDescription := TJvID3PictureFrame(Source).Description;\r\n FURL := TJvID3PictureFrame(Source).URL;\r\n end\r\n else\r\n inherited Assign(Source);\r\nend;\r\n\r\nprocedure TJvID3PictureFrame.AssignTo(Dest: TPersistent);\r\nvar\r\n TmpFileName: string;\r\nbegin\r\n if (Dest is TPicture) or (Dest is TGraphic) then\r\n begin\r\n if (DataSize > 0) and (MIMEType <> cURLArrow) then\r\n begin\r\n { !! We can't use FileGetTempName; it /creates/ a file with extension TMP but\r\n we need to have a specific extension }\r\n TmpFileName := SysUtils.IncludeTrailingPathDelimiter(PathGetTempPath) + cPictureFrameFileNameTemplate;\r\n TmpFileName := FindUnusedFileName(TmpFileName, MIMETypeToExt(string(MIMEType)), '');\r\n\r\n try\r\n SaveToFile(TmpFileName);\r\n try\r\n try\r\n if Dest is TPicture then\r\n TPicture(Dest).LoadFromFile(TmpFileName)\r\n else\r\n if Dest is TGraphic then\r\n TGraphic(Dest).LoadFromFile(TmpFileName);\r\n except\r\n on EInvalidGraphic do\r\n ; { Do nothing }\r\n end\r\n finally\r\n SysUtils.DeleteFile(TmpFileName);\r\n end;\r\n except\r\n { Something went wrong while saving picture to file }\r\n end;\r\n end\r\n else\r\n Dest.Assign(nil);\r\n end\r\n else\r\n inherited AssignTo(Dest);\r\nend;\r\n\r\nclass function TJvID3PictureFrame.CanAddFrame(AController: TJvID3Controller;\r\n AFrameID: TJvID3FrameID): Boolean;\r\nbegin\r\n { There may be several pictures attached to one file, each in their\r\n individual \"APIC\" frame, but only one with the same content descriptor.\r\n There may only be one picture with the picture type declared as picture\r\n type $01 and $02 respectively.\r\n }\r\n Result := (AFrameID = fiPicture) or inherited CanAddFrame(AController, AFrameID);\r\nend;\r\n\r\nfunction TJvID3PictureFrame.CheckFrame(const HandleError: TJvID3HandleError): Boolean;\r\nbegin\r\n { The description has a maximum length of 64 characters, but may be empty. }\r\n\r\n Result := CheckMaxCharCount(Self, FDescription, 64, HandleError);\r\n if not Result and (HandleError = heAutoCorrect) then\r\n begin\r\n UpdateFrameSize;\r\n Result := True;\r\n end;\r\nend;\r\n\r\nprocedure TJvID3PictureFrame.Clear;\r\nbegin\r\n FMIMEType := '';\r\n FPictureType := ptOther;\r\n FDescription := '';\r\n FURL := '';\r\n\r\n inherited Clear;\r\nend;\r\n\r\nclass function TJvID3PictureFrame.Find(AController: TJvID3Controller;\r\n const AType: TJvID3PictureType): TJvID3PictureFrame;\r\nvar\r\n Frame: TJvID3Frame;\r\nbegin\r\n Result := nil;\r\n if not Assigned(AController) or not AController.Active then\r\n Exit;\r\n\r\n if not AController.FindFirstFrame(fiPicture, Frame) then\r\n Exit;\r\n\r\n while (Frame is TJvID3PictureFrame) and\r\n (TJvID3PictureFrame(Frame).PictureType <> AType) do\r\n AController.FindNextFrame(fiPicture, Frame);\r\n\r\n if Frame is TJvID3PictureFrame then\r\n Result := TJvID3PictureFrame(Frame)\r\nend;\r\n\r\nclass function TJvID3PictureFrame.FindOrCreate(AController: TJvID3Controller;\r\n const AType: TJvID3PictureType): TJvID3PictureFrame;\r\nbegin\r\n if not Assigned(AController) then\r\n ID3Error(RsEID3NoController);\r\n\r\n Result := Find(AController, AType);\r\n if not Assigned(Result) then\r\n begin\r\n Result := TJvID3PictureFrame(AController.AddFrame(fiPicture));\r\n Result.PictureType := AType;\r\n end;\r\nend;\r\n\r\nfunction TJvID3PictureFrame.GetFrameSize(const ToEncoding: TJvID3Encoding): Cardinal;\r\nbegin\r\n { Text encoding: $xx\r\n MIME type: $00\r\n Picture type: $xx\r\n Description: $00 (00)\r\n Picture data: \r\n }\r\n if HasOnlyURL then\r\n Result := 1 + Length(cURLArrow) + 1 + 1 +\r\n LengthEnc(Description, ToEncoding) +\r\n LengthTerminatorEnc(ToEncoding) + Cardinal(Length(URL))\r\n else\r\n Result := 1 + Cardinal(Length(MIMEType)) + 1 + 1 +\r\n LengthEnc(Description, ToEncoding) +\r\n LengthTerminatorEnc(ToEncoding) + DataSize;\r\nend;\r\n\r\nfunction TJvID3PictureFrame.GetHasOnlyURL: Boolean;\r\nbegin\r\n Result := (DataSize = 0) and (URL > '');\r\nend;\r\n\r\nfunction TJvID3PictureFrame.GetIsEmpty: Boolean;\r\nbegin\r\n { Don't care about FPictureType }\r\n Result := inherited GetIsEmpty and\r\n ((Length(MIMEType) = 0) or (MIMEType = cURLArrow)) and\r\n (Length(URL) = 0) and (Description = '');\r\nend;\r\n\r\nfunction TJvID3PictureFrame.MustWriteAsUTF: Boolean;\r\nbegin\r\n Result := HasNonISO_8859_1Chars(Description);\r\nend;\r\n\r\nprocedure TJvID3PictureFrame.ReadFrame;\r\nvar\r\n LPictureType: Byte;\r\nbegin\r\n { Text encoding $xx\r\n MIME type $00\r\n Picture type $xx\r\n Description $00 (00)\r\n Picture data \r\n }\r\n with Stream do\r\n begin\r\n ReadEncoding;\r\n ReadStringA(FMIMEType);\r\n if BytesTillEndOfFrame < 1 then\r\n Exit;\r\n\r\n Read(LPictureType, 1);\r\n if LPictureType <= Integer(High(TJvID3PictureType)) then\r\n FPictureType := TJvID3PictureType(LPictureType)\r\n else\r\n FPictureType := ptOther;\r\n\r\n ReadStringEnc(FDescription);\r\n\r\n if MIMEType = cURLArrow then\r\n { There is the possibility to put only a link to the image file by using\r\n the 'MIME type' \"-->\" and having a complete URL instead of picture data.\r\n }\r\n ReadStringA(FURL)\r\n else\r\n Self.ReadData(BytesTillEndOfFrame);\r\n end;\r\nend;\r\n\r\nfunction TJvID3PictureFrame.SameUniqueIDAs(const Frame: TJvID3Frame): Boolean;\r\nbegin\r\n { There may be several pictures attached to one file, each in their\r\n individual \"APIC\" frame, but only one with the same content descriptor.\r\n There may only be one picture with the picture type declared as picture\r\n type $01 and $02 respectively.\r\n }\r\n Result := (Frame is TJvID3PictureFrame) and\r\n (Frame.FrameID = FrameID) and (FrameID = fiPicture);\r\n\r\n if Result then\r\n Result :=\r\n (TJvID3PictureFrame(Frame).PictureType = PictureType) and\r\n ((PictureType in [ptFileIcon, ptOtherFileIcon]) or\r\n SameStr(Description, TJvID3PictureFrame(Frame).Description))\r\n else\r\n Result := inherited SameUniqueIDAs(Frame);\r\nend;\r\n\r\nprocedure TJvID3PictureFrame.SetDescription(const Value: WideString);\r\nbegin\r\n if Value <> FDescription then\r\n begin\r\n FDescription := Value;\r\n Changed;\r\n end;\r\nend;\r\n\r\nprocedure TJvID3PictureFrame.SetMIMEType(const Value: AnsiString);\r\nbegin\r\n if FMIMEType <> Value then\r\n begin\r\n FMIMEType := Value;\r\n Changed;\r\n end;\r\nend;\r\n\r\nprocedure TJvID3PictureFrame.SetURL(const Value: AnsiString);\r\nbegin\r\n if FURL <> Value then\r\n begin\r\n FURL := Value;\r\n Changed;\r\n end;\r\nend;\r\n\r\nprocedure TJvID3PictureFrame.WriteFrame;\r\nbegin\r\n { Text encoding $xx\r\n MIME type $00\r\n Picture type $xx\r\n Description $00 (00)\r\n Picture data \r\n\r\n There is the possibility to put only a link to the image file by using\r\n the 'MIME type' \"-->\" and having a complete URL instead of picture data. }\r\n\r\n with Stream do\r\n begin\r\n WriteEncoding;\r\n if HasOnlyURL then\r\n WriteStringA(cURLArrow)\r\n else\r\n WriteStringA(MIMEType);\r\n WriteTerminatorA;\r\n\r\n Write(PictureType, 1);\r\n\r\n WriteStringEnc(Description);\r\n WriteTerminatorEnc;\r\n if HasOnlyURL then\r\n WriteStringA(URL)\r\n else\r\n Self.WriteData;\r\n end;\r\nend;\r\n\r\n//=== { TJvID3PlayCounterFrame } =============================================\r\n\r\nprocedure TJvID3PlayCounterFrame.Assign(Source: TPersistent);\r\nbegin\r\n if Source is TJvID3PlayCounterFrame then\r\n FCounter := TJvID3PlayCounterFrame(Source).Counter;\r\n\r\n inherited Assign(Source);\r\nend;\r\n\r\nclass function TJvID3PlayCounterFrame.CanAddFrame(AController: TJvID3Controller;\r\n AFrameID: TJvID3FrameID): Boolean;\r\nbegin\r\n { There may only be one \"PCNT\" frame in each tag. }\r\n Result := not AController.HasFrame(AFrameID) or\r\n inherited CanAddFrame(AController, AFrameID);\r\nend;\r\n\r\nfunction TJvID3PlayCounterFrame.CheckFrame(const HandleError: TJvID3HandleError): Boolean;\r\nbegin\r\n Result := True;\r\nend;\r\n\r\nprocedure TJvID3PlayCounterFrame.Clear;\r\nbegin\r\n FCounter := 0;\r\n inherited Clear;\r\nend;\r\n\r\nclass function TJvID3PlayCounterFrame.Find(AController: TJvID3Controller): TJvID3PlayCounterFrame;\r\nvar\r\n Frame: TJvID3Frame;\r\nbegin\r\n Result := nil;\r\n if not Assigned(AController) or not AController.Active then\r\n Exit;\r\n\r\n Frame := AController.Frames.FindFrame(fiPlayCounter);\r\n if Frame is TJvID3PlayCounterFrame then\r\n Result := TJvID3PlayCounterFrame(Frame)\r\nend;\r\n\r\nclass function TJvID3PlayCounterFrame.FindOrCreate(AController: TJvID3Controller): TJvID3PlayCounterFrame;\r\nbegin\r\n if not Assigned(AController) then\r\n ID3Error(RsEID3NoController);\r\n\r\n Result := Find(AController);\r\n if not Assigned(Result) then\r\n Result := TJvID3PlayCounterFrame(AController.AddFrame(fiPlayCounter));\r\nend;\r\n\r\nfunction TJvID3PlayCounterFrame.GetFrameSize(const ToEncoding: TJvID3Encoding): Cardinal;\r\nbegin\r\n Result := 4;\r\nend;\r\n\r\nfunction TJvID3PlayCounterFrame.GetIsEmpty: Boolean;\r\nbegin\r\n Result := False;\r\nend;\r\n\r\nprocedure TJvID3PlayCounterFrame.ReadFrame;\r\nbegin\r\n Stream.ReadNumber(FCounter);\r\nend;\r\n\r\nfunction TJvID3PlayCounterFrame.SameUniqueIDAs(const Frame: TJvID3Frame): Boolean;\r\nbegin\r\n { There may only be one \"PCNT\" frame in each tag. }\r\n Result := ((Frame.FrameID = FrameID) and (FrameID = fiPlayCounter)) or\r\n inherited SameUniqueIDAs(Frame);\r\nend;\r\n\r\nprocedure TJvID3PlayCounterFrame.SetCounter(const Value: Cardinal);\r\nbegin\r\n if FCounter <> Value then\r\n begin\r\n FCounter := Value;\r\n Changed;\r\n end;\r\nend;\r\n\r\nprocedure TJvID3PlayCounterFrame.WriteFrame;\r\nbegin\r\n Stream.WriteNumber(FCounter);\r\nend;\r\n\r\n//=== { TJvID3PopularimeterFrame } ===========================================\r\n\r\nprocedure TJvID3PopularimeterFrame.Assign(Source: TPersistent);\r\nbegin\r\n if Source is TJvID3PopularimeterFrame then\r\n begin\r\n FRating := TJvID3PopularimeterFrame(Source).Rating;\r\n FCounter := TJvID3PopularimeterFrame(Source).Counter;\r\n FEMailAddress := TJvID3PopularimeterFrame(Source).EMailAddress;\r\n end;\r\n\r\n inherited Assign(Source);\r\nend;\r\n\r\nclass function TJvID3PopularimeterFrame.CanAddFrame(AController: TJvID3Controller;\r\n AFrameID: TJvID3FrameID): Boolean;\r\nbegin\r\n { There may be more than one \"POPM\" frame in each tag, but only one with the\r\n same email address. }\r\n Result := (AFrameID = fiPopularimeter) or inherited CanAddFrame(AController, AFrameID);\r\nend;\r\n\r\nfunction TJvID3PopularimeterFrame.CheckFrame(const HandleError: TJvID3HandleError): Boolean;\r\nbegin\r\n Result := True;\r\nend;\r\n\r\nprocedure TJvID3PopularimeterFrame.Clear;\r\nbegin\r\n FRating := 0;\r\n FCounter := 0;\r\n FEMailAddress := '';\r\n\r\n inherited Clear;\r\nend;\r\n\r\nclass function TJvID3PopularimeterFrame.Find(AController: TJvID3Controller): TJvID3PopularimeterFrame;\r\nvar\r\n Frame: TJvID3Frame;\r\nbegin\r\n Result := nil;\r\n if not Assigned(AController) or not AController.Active then\r\n Exit;\r\n\r\n Frame := AController.Frames.FindFrame(fiPopularimeter);\r\n if Frame is TJvID3PopularimeterFrame then\r\n Result := TJvID3PopularimeterFrame(Frame);\r\nend;\r\n\r\nclass function TJvID3PopularimeterFrame.Find(AController: TJvID3Controller;\r\n const AEmailAddress: AnsiString): TJvID3PopularimeterFrame;\r\nvar\r\n Frame: TJvID3Frame;\r\nbegin\r\n Result := nil;\r\n if not Assigned(AController) or not AController.Active then\r\n Exit;\r\n\r\n if not AController.FindFirstFrame(fiPopularimeter, Frame) then\r\n Exit;\r\n\r\n while (Frame is TJvID3PopularimeterFrame) and\r\n not AnsiSameStr(AEmailAddress, TJvID3PopularimeterFrame(Frame).EMailAddress) do\r\n AController.FindNextFrame(fiPopularimeter, Frame);\r\n\r\n if Frame is TJvID3PopularimeterFrame then\r\n Result := TJvID3PopularimeterFrame(Frame);\r\nend;\r\n\r\nclass function TJvID3PopularimeterFrame.FindOrCreate(AController: TJvID3Controller): TJvID3PopularimeterFrame;\r\nbegin\r\n if not Assigned(AController) then\r\n ID3Error(RsEID3NoController);\r\n\r\n Result := Find(AController);\r\n if not Assigned(Result) then\r\n Result := TJvID3PopularimeterFrame(AController.AddFrame(fiPopularimeter));\r\nend;\r\n\r\nclass function TJvID3PopularimeterFrame.FindOrCreate(AController: TJvID3Controller;\r\n const AEmailAddress: AnsiString): TJvID3PopularimeterFrame;\r\nbegin\r\n if not Assigned(AController) then\r\n ID3Error(RsEID3NoController);\r\n\r\n Result := Find(AController, AEmailAddress);\r\n if not Assigned(Result) then\r\n begin\r\n Result := TJvID3PopularimeterFrame(AController.AddFrame(fiPopularimeter));\r\n Result.EMailAddress := AEmailAddress;\r\n end;\r\nend;\r\n\r\nfunction TJvID3PopularimeterFrame.GetFrameSize(const ToEncoding: TJvID3Encoding): Cardinal;\r\nbegin\r\n { Email to user $00\r\n Rating $xx\r\n Counter $xx xx xx xx (xx ...)\r\n }\r\n Result := Length(FEMailAddress) + 1 + 1 + 4;\r\nend;\r\n\r\nfunction TJvID3PopularimeterFrame.GetIsEmpty: Boolean;\r\nbegin\r\n Result := (FRating = 0) and (FCounter = 0) and (Length(FEMailAddress) = 0);\r\nend;\r\n\r\nprocedure TJvID3PopularimeterFrame.ReadFrame;\r\nbegin\r\n { Email to user $00\r\n Rating $xx\r\n Counter $xx xx xx xx (xx ...)\r\n }\r\n with Stream do\r\n begin\r\n ReadStringA(FEMailAddress);\r\n Read(FRating, 1);\r\n ReadNumber(FCounter);\r\n end;\r\nend;\r\n\r\nfunction TJvID3PopularimeterFrame.SameUniqueIDAs(const Frame: TJvID3Frame): Boolean;\r\nbegin\r\n { There may be more than one \"POPM\" frame in each tag, but only one with the\r\n same email address. }\r\n Result := (Frame is TJvID3PopularimeterFrame) and\r\n (Frame.FrameID = FrameID) and (FrameID = fiPopularimeter);\r\n\r\n if Result then\r\n Result := AnsiSameStr(TJvID3PopularimeterFrame(Frame).EMailAddress, EMailAddress)\r\n else\r\n Result := inherited SameUniqueIDAs(Frame);\r\nend;\r\n\r\nprocedure TJvID3PopularimeterFrame.SetCounter(const Value: Cardinal);\r\nbegin\r\n if FCounter <> Value then\r\n begin\r\n FCounter := Value;\r\n Changed;\r\n end;\r\nend;\r\n\r\nprocedure TJvID3PopularimeterFrame.SetEMailAddress(const Value: AnsiString);\r\nbegin\r\n if FEMailAddress <> Value then\r\n begin\r\n FEMailAddress := Value;\r\n Changed;\r\n end;\r\nend;\r\n\r\nprocedure TJvID3PopularimeterFrame.SetRating(const Value: Byte);\r\nbegin\r\n if FRating <> Value then\r\n begin\r\n FRating := Value;\r\n Changed;\r\n end;\r\nend;\r\n\r\nprocedure TJvID3PopularimeterFrame.WriteFrame;\r\nbegin\r\n { Email to user $00\r\n Rating $xx\r\n Counter $xx xx xx xx (xx ...)\r\n }\r\n with Stream do\r\n begin\r\n WriteStringA(EMailAddress);\r\n WriteTerminatorA;\r\n Write(Rating, 1);\r\n WriteNumber(Counter);\r\n end;\r\nend;\r\n\r\n//=== { TJvID3SimpleListFrame } ==============================================\r\n\r\nprocedure TJvID3SimpleListFrame.AfterConstruction;\r\nbegin\r\n inherited AfterConstruction;\r\n\r\n {$IFDEF COMPILER12_UP}\r\n FList := TJvID3StringList.Create;\r\n TStringList(FList).OnChange := ListChanged;\r\n {$ELSE}\r\n FList := JclUnicode.TWideStringList.Create;\r\n JclUnicode.TWideStringList(FList).OnChange := ListChanged;\r\n {$ENDIF COMPILER12_UP}\r\nend;\r\n\r\nprocedure TJvID3SimpleListFrame.BeforeDestruction;\r\nbegin\r\n inherited BeforeDestruction;\r\n FList.Free;\r\nend;\r\n\r\nfunction TJvID3SimpleListFrame.CheckFrame(const HandleError: TJvID3HandleError): Boolean;\r\nbegin\r\n Result := False;\r\n case FrameID of\r\n fiLanguage:\r\n case Encoding of\r\n ienISO_8859_1:\r\n Result := CheckIsLanguageList(Self, List, HandleError);\r\n ienUTF_16, ienUTF_16BE, ienUTF_8:\r\n Result := CheckIsLanguageList(Self, List, HandleError);\r\n else\r\n Error(RsEID3UnknownEncoding);\r\n end;\r\n else\r\n case Encoding of\r\n ienISO_8859_1:\r\n Result := CheckList(Self, List, Separator, HandleError);\r\n ienUTF_16, ienUTF_16BE, ienUTF_8:\r\n Result := CheckList(Self, List, Separator, HandleError);\r\n else\r\n Error(RsEID3UnknownEncoding);\r\n end;\r\n end;\r\n\r\n if not Result and (HandleError = heAutoCorrect) then\r\n begin\r\n UpdateFrameSize;\r\n Result := True;\r\n end;\r\nend;\r\n\r\nclass function TJvID3SimpleListFrame.Find(AController: TJvID3Controller;\r\n const AFrameID: TJvID3FrameID): TJvID3SimpleListFrame;\r\nvar\r\n Frame: TJvID3Frame;\r\nbegin\r\n Result := nil;\r\n if not Assigned(AController) or not AController.Active then\r\n Exit;\r\n\r\n Frame := AController.Frames.FindFrame(AFrameID);\r\n if Frame is TJvID3SimpleListFrame then\r\n Result := TJvID3SimpleListFrame(Frame);\r\nend;\r\n\r\nclass function TJvID3SimpleListFrame.FindOrCreate(AController: TJvID3Controller;\r\n const AFrameID: TJvID3FrameID): TJvID3SimpleListFrame;\r\nbegin\r\n if not Assigned(AController) then\r\n ID3Error(RsEID3NoController);\r\n\r\n Result := Find(AController, AFrameID);\r\n if not Assigned(Result) then\r\n begin\r\n AController.CheckFrameClass(TJvID3SimpleListFrame, AFrameID);\r\n Result := TJvID3SimpleListFrame(AController.AddFrame(AFrameID));\r\n end;\r\nend;\r\n\r\nfunction TJvID3SimpleListFrame.GetFixedStringLength: Integer;\r\nbegin\r\n case FrameID of\r\n fiLanguage:\r\n Result := 3\r\n else\r\n Result := -1;\r\n end;\r\nend;\r\n\r\nfunction TJvID3SimpleListFrame.GetFrameSize(const ToEncoding: TJvID3Encoding): Cardinal;\r\nvar\r\n I: Integer;\r\n CharLength: Integer;\r\nbegin\r\n if ToEncoding = ienUTF_8 then\r\n begin\r\n Result := 1 + Length(WideStringToUTF8(Text));\r\n Exit;\r\n end;\r\n\r\n { Encoding byte = 1 }\r\n Result := 1;\r\n CharLength := 0;\r\n\r\n if FixedStringLength > 0 then\r\n Inc(CharLength, List.Count * FixedStringLength)\r\n else\r\n begin\r\n for I := 0 to List.Count - 1 do\r\n begin\r\n Inc(CharLength, Length(List[I]));\r\n Inc(CharLength); // separator\r\n end;\r\n\r\n { Set one separator less, the last line does not have a trailing\r\n separator }\r\n if not IsNullSeparator then\r\n Dec(CharLength);\r\n end;\r\n\r\n case ToEncoding of\r\n ienISO_8859_1:\r\n Inc(Result, CharLength);\r\n ienUTF_16:\r\n { Add the BOM's }\r\n Inc(Result, List.Count * 2 + CharLength * 2);\r\n ienUTF_16BE:\r\n Inc(Result, CharLength * 2);\r\n else\r\n Error(RsEID3UnknownEncoding);\r\n end;\r\nend;\r\n\r\nfunction TJvID3SimpleListFrame.GetIsNullSeparator: Boolean;\r\nbegin\r\n Result := (FixedStringLength < 0) and (Separator = WideNull);\r\nend;\r\n\r\nfunction TJvID3SimpleListFrame.GetSeparator: WideChar;\r\nbegin\r\n case FrameID of\r\n fiLyricist, fiComposer, fiOrigLyricist, fiOrigArtist, fiLeadArtist:\r\n Result := WideChar('/');\r\n fiLanguage, fiContentType:\r\n Result := WideNull;\r\n else\r\n { ?? Unknown }\r\n Result := WideChar('/');\r\n end;\r\nend;\r\n\r\nfunction TJvID3SimpleListFrame.GetText: WideString;\r\nbegin\r\n if Separator <> WideNull then\r\n {$IFDEF COMPILER12_UP}\r\n Result := (FList as TJvID3StringList).GetSeparatedText(Separator)\r\n {$ELSE}\r\n Result := (FList as JclUnicode.TWideStringList).GetSeparatedText(Separator)\r\n {$ENDIF COMPILER12_UP}\r\n else\r\n {$IFDEF COMPILER12_UP}\r\n Result := (FList as TJvID3StringList).GetSeparatedText('');\r\n {$ELSE}\r\n Result := (FList as JclUnicode.TWideStringList).GetSeparatedText('');\r\n {$ENDIF COMPILER12_UP}\r\nend;\r\n\r\nprocedure TJvID3SimpleListFrame.ListChanged(Sender: TObject);\r\nbegin\r\n if not (icsReading in Controller.FState) then\r\n Changed;\r\nend;\r\n\r\nprocedure TJvID3SimpleListFrame.SetText(const ANewText: WideString);\r\nbegin\r\n if FixedStringLength >= 0 then\r\n ExtractFixedStrings(ANewText, FixedStringLength, List)\r\n else\r\n ExtractStrings(Separator, ANewText, List);\r\nend;\r\n\r\nprocedure TJvID3SimpleListFrame.ReadFrame;\r\nconst\r\n cMinBytes: array [TJvID3Encoding] of Byte = (2, 4, 4, 2);\r\nvar\r\n S: WideString;\r\nbegin\r\n if IsNullSeparator then\r\n begin\r\n with Stream do\r\n begin\r\n ReadEncoding;\r\n while BytesTillEndOfFrame > cMinBytes[Encoding] do\r\n begin\r\n ReadStringEnc(S);\r\n List.Add(S);\r\n end;\r\n end;\r\n end\r\n else\r\n inherited ReadFrame;\r\nend;\r\n\r\nprocedure TJvID3SimpleListFrame.SetList(Value: {$IFDEF COMPILER12_UP}TStrings{$ELSE}JclUnicode.TWideStrings{$ENDIF COMPILER12_UP});\r\nbegin\r\n FList.Assign(Value);\r\nend;\r\n\r\nprocedure TJvID3SimpleListFrame.WriteFrame;\r\nvar\r\n I: Integer;\r\nbegin\r\n if IsNullSeparator then\r\n begin\r\n with Stream do\r\n begin\r\n WriteEncoding;\r\n for I := 0 to List.Count - 1 do\r\n begin\r\n WriteStringEnc(List[I]);\r\n WriteTerminatorEnc;\r\n end;\r\n end;\r\n end\r\n else\r\n inherited WriteFrame;\r\nend;\r\n\r\n//=== { TJvID3SkipFrame } ====================================================\r\n\r\nprocedure TJvID3SkipFrame.ChangeToVersion(const ANewVersion: TJvID3Version);\r\nvar\r\n LFrameID: TJvID3FrameID;\r\nbegin\r\n case ANewVersion of\r\n ive2_2:\r\n if Length(FFrameIDStr) = 4 then\r\n begin\r\n LFrameID := ID3_StringToFrameID(FFrameIDStr);\r\n if LFrameID in [fiErrorFrame, fiPaddingFrame] then\r\n FFrameIDStr := ''\r\n else\r\n FFrameIDStr := ID3_FrameIDToString(LFrameID, 3);\r\n end;\r\n ive2_3, ive2_4:\r\n if Length(FFrameIDStr) = 3 then\r\n begin\r\n LFrameID := ID3_StringToFrameID(FFrameIDStr);\r\n if LFrameID in [fiErrorFrame, fiPaddingFrame] then\r\n FFrameIDStr := ''\r\n else\r\n FFrameIDStr := ID3_FrameIDToString(LFrameID, 3);\r\n end;\r\n end;\r\nend;\r\n\r\n//=== { TJvID3Stream } =======================================================\r\n\r\nprocedure TJvID3Stream.BeginReadFrame(const AFrameSize: Integer);\r\nbegin\r\n if FReadingFrame or FWritingFrame then\r\n ID3Error(RsEAlreadyReadingWritingFrame);\r\n\r\n FStartPosition := Position;\r\n FCurrentFrameSize := AFrameSize;\r\n FReadingFrame := True;\r\nend;\r\n\r\nprocedure TJvID3Stream.BeginWriteFrame(const AFrameSize: Integer);\r\nbegin\r\n if FReadingFrame or FWritingFrame then\r\n ID3Error(RsEAlreadyReadingWritingFrame);\r\n\r\n //if not Assigned(Memory) then\r\n // { $0A = 10, the size of the header }\r\n // Capacity := $0A;\r\n\r\n FStartPosition := Position;\r\n FCurrentFrameSize := AFrameSize;\r\n FWritingFrame := True;\r\nend;\r\n\r\nfunction TJvID3Stream.CanRead(const ACount: Cardinal): Boolean;\r\nvar\r\n LBytesToRead: Longint;\r\nbegin\r\n Assert(not FWritingFrame, RsECannotCallCanRead);\r\n\r\n if FReadingFrame then\r\n LBytesToRead := BytesTillEndOfFrame\r\n else\r\n LBytesToRead := BytesTillEndOfTag;\r\n\r\n Result := (LBytesToRead >= 0) and (ACount <= Cardinal(LBytesToRead));\r\nend;\r\n\r\nprocedure TJvID3Stream.EndReadFrame;\r\nbegin\r\n if not FReadingFrame then\r\n ID3Error(RsENotReadingFrame);\r\n MoveToNextFrame;\r\n FReadingFrame := False;\r\nend;\r\n\r\nprocedure TJvID3Stream.EndWriteFrame;\r\nbegin\r\n if not FWritingFrame then\r\n ID3Error(RsENotWritingFrame);\r\n MoveToNextFrame;\r\n FWritingFrame := False;\r\nend;\r\n\r\nfunction TJvID3Stream.GetBytesTillEndOfFrame: Longint;\r\nbegin\r\n Result := FStartPosition + FCurrentFrameSize - Position;\r\nend;\r\n\r\nfunction TJvID3Stream.GetBytesTillEndOfTag: Longint;\r\nbegin\r\n Result := Size - Position;\r\nend;\r\n\r\nfunction TJvID3Stream.InFrame(P: Pointer): Boolean;\r\nbegin\r\n { This function is used to check _when_ we're reading a frame, that we don't\r\n read beyond the end marker }\r\n\r\n Result := not FReadingFrame or (PAnsiChar(P) < PAnsiChar(Memory) + FStartPosition + FCurrentFrameSize);\r\nend;\r\n\r\nprocedure TJvID3Stream.InitAllowedEncodings(const AVersion: TJvID3Version;\r\n const AEncoding: TJvID3ForceEncoding);\r\nbegin\r\n if AEncoding in [ifeDontCare, ifeAuto] then\r\n case AVersion of\r\n ive2_2, ive2_3:\r\n FAllowedEncodings := [ienISO_8859_1, ienUTF_16];\r\n ive2_4:\r\n FAllowedEncodings := [ienISO_8859_1, ienUTF_16, ienUTF_16BE, ienUTF_8];\r\n else\r\n ID3Error(RsEID3UnknownVersion);\r\n end\r\n else\r\n begin\r\n { Convert force encoding type to encoding type }\r\n FAllowedEncodings := [CForceEncodingToEncoding[AEncoding]];\r\n if (AVersion in [ive2_2, ive2_3]) and (FAllowedEncodings * [ienUTF_16BE, ienUTF_8] <> []) then\r\n FAllowedEncodings := [ienUTF_16];\r\n end;\r\n\r\n UpdateDestEncoding;\r\nend;\r\n\r\nprocedure TJvID3Stream.MoveToNextFrame;\r\nbegin\r\n if FWritingFrame and (BytesTillEndOfFrame <> 0) then\r\n ID3Error(RsEFrameSizeDiffers);\r\n\r\n Seek(BytesTillEndOfFrame, soFromCurrent);\r\nend;\r\n\r\nfunction TJvID3Stream.ReadDate(var ADate: TDateTime): Longint;\r\nvar\r\n Year, Month, Day: Word;\r\n P: PAnsiChar;\r\nbegin\r\n P := PAnsiChar(Memory) + Position;\r\n\r\n Year := 0;\r\n Month := 0;\r\n Day := 0;\r\n Result := 0;\r\n\r\n while (Result < 8) and InFrame(P) and (P^ in DigitSymbols) do\r\n begin\r\n { Use Day as temp variable }\r\n Day := Day * 10 + Ord(P^) - Ord('0');\r\n\r\n { Format = YYYYMMDD }\r\n case Result of\r\n 3:\r\n begin\r\n Year := Day;\r\n Day := 0;\r\n end;\r\n 5:\r\n begin\r\n Month := Day;\r\n Day := 0;\r\n end;\r\n end;\r\n Inc(P);\r\n Inc(Result);\r\n end;\r\n\r\n if Result = 8 then\r\n begin\r\n Seek(Result, soFromCurrent);\r\n try\r\n ADate := EncodeDate(Year, Month, Day);\r\n except\r\n on EConvertError do\r\n ADate := 0;\r\n end;\r\n end\r\n else\r\n begin\r\n Result := 0;\r\n ADate := 0;\r\n end;\r\nend;\r\n\r\nfunction TJvID3Stream.ReadEnc(var AEncoding: TJvID3Encoding): Longint;\r\nvar\r\n B: Byte;\r\nbegin\r\n Result := Read(B, 1);\r\n if B <= Integer(High(TJvID3Encoding)) then\r\n SourceEncoding := TJvID3Encoding(B)\r\n else\r\n ID3Error(RsEID3UnknownEncoding);\r\n\r\n AEncoding := DestEncoding;\r\nend;\r\n\r\nfunction TJvID3Stream.ReadFixedNumber(var AValue: Cardinal): Longint;\r\nbegin\r\n Result := Read(AValue, 4);\r\n { Swap byte order from big endian to little endian }\r\n AValue := ReverseBytes(AValue);\r\nend;\r\n\r\nfunction TJvID3Stream.ReadFixedNumber3(var AValue: Cardinal): Longint;\r\ntype\r\n TBytes = array [0..3] of Byte;\r\nbegin\r\n AValue := 0;\r\n Result := Read(TBytes(AValue)[1], 3);\r\n { Swap byte order from big endian to little endian }\r\n AValue := ReverseBytes(AValue);\r\nend;\r\n\r\nprocedure TJvID3Stream.ReadFromStream(AStream: TStream;\r\n const ASize: Integer);\r\nbegin\r\n Position := 0;\r\n SetSize(ASize);\r\n if ASize <> 0 then\r\n AStream.ReadBuffer(Memory^, ASize);\r\nend;\r\n\r\nfunction TJvID3Stream.ReadLanguage(var Language: AnsiString): Longint;\r\nbegin\r\n if not CanRead(3) then\r\n Result := 0\r\n else\r\n begin\r\n SetLength(Language, 3);\r\n Result := Read(Language[1], 3);\r\n end;\r\n\r\n if Result < 3 then\r\n begin\r\n Language := '';\r\n Exit;\r\n end;\r\nend;\r\n\r\nfunction TJvID3Stream.ReadNumber(var AValue: Cardinal): Longint;\r\nbegin\r\n { When reading a frame, a number _always_ fills up the remaining part of\r\n the frame; a number might be bigger than 4 bytes, but that can't be read\r\n currently }\r\n if not FReadingFrame then\r\n ID3Error(RsENotReadingFrame);\r\n\r\n if BytesTillEndOfFrame = 4 then\r\n begin\r\n Result := Read(AValue, 4);\r\n { Swap byte order from big endian to little endian }\r\n AValue := ReverseBytes(AValue);\r\n end\r\n else\r\n begin\r\n { Error (if BytesTillEndOfFrame < 4) or not implemented (if BytesTillEndOfFrame > 4) }\r\n AValue := 0;\r\n Result := 0;\r\n end;\r\nend;\r\n\r\nfunction TJvID3Stream.ReadStringA(var SA: AnsiString): Longint;\r\nvar\r\n P, StartPos: PAnsiChar;\r\nbegin\r\n StartPos := PAnsiChar(Memory) + Position;\r\n P := StartPos;\r\n\r\n while (P^ <> #0) and InFrame(P) do\r\n Inc(P);\r\n Result := P - StartPos;\r\n\r\n SetString(SA, StartPos, Result);\r\n\r\n { Skip terminator }\r\n if InFrame(P) then\r\n Inc(Result);\r\n\r\n Seek(Result, soFromCurrent);\r\nend;\r\n\r\nfunction TJvID3Stream.ReadStringEnc(var S: WideString): Longint;\r\nvar\r\n SA: AnsiString;\r\nbegin\r\n case SourceEncoding of\r\n ienISO_8859_1:\r\n begin\r\n Result := ReadStringA(SA);\r\n S := AnsiStringToUTF16(SA)\r\n end;\r\n ienUTF_16, ienUTF_16BE:\r\n Result := ReadStringW(S);\r\n ienUTF_8:\r\n Result := ReadStringUTF8(S);\r\n else\r\n Result := 0;\r\n ID3Error(RsEID3UnknownEncoding);\r\n end;\r\nend;\r\n\r\nfunction TJvID3Stream.ReadStringUTF8(var SW: WideString): Longint;\r\nvar\r\n SA: AnsiString;\r\nbegin\r\n Result := ReadStringA(SA);\r\n SW := UTF8ToWideString(SA);\r\nend;\r\n\r\nfunction TJvID3Stream.ReadStringW(var SW: WideString): Longint;\r\nvar\r\n Order: WideChar;\r\n P: PWideChar;\r\n StartPos: PAnsiChar;\r\n TerminatorFound: Boolean;\r\n WideCharCount: Integer;\r\nbegin\r\n Result := 0;\r\n\r\n if SourceEncoding = ienUTF_16 then\r\n begin\r\n { Try read the BOM }\r\n if not CanRead(2) then\r\n begin\r\n SW := '';\r\n Exit;\r\n end;\r\n\r\n Result := Read(Order, 2);\r\n if (Order <> BOM_LSB_FIRST) and (Order <> BOM_MSB_FIRST) then\r\n begin\r\n SW := '';\r\n Exit;\r\n end;\r\n end;\r\n\r\n StartPos := PAnsiChar(Memory) + Position;\r\n P := PWideChar(StartPos);\r\n\r\n { Read until #0#0 found or until FEndMarker }\r\n while InFrame(P) and not (P^ = WideNull) do\r\n Inc(P);\r\n\r\n TerminatorFound := InFrame(P);\r\n WideCharCount := (PAnsiChar(Pointer(P)) - StartPos) div 2;\r\n Result := Result + WideCharCount * 2;\r\n\r\n SetLength(SW, WideCharCount);\r\n if WideCharCount > 0 then\r\n Move(StartPos[0], SW[1], WideCharCount * SizeOf(WideChar));\r\n if (SourceEncoding = ienUTF_16) and (Order = BOM_MSB_FIRST) then\r\n StrSwapByteOrder(PWideChar(SW));\r\n\r\n { Skip Terminator }\r\n if TerminatorFound then\r\n begin\r\n Inc(Result, 2);\r\n Inc(WideCharCount);\r\n end;\r\n\r\n Seek(WideCharCount * 2, soFromCurrent);\r\nend;\r\n\r\nfunction TJvID3Stream.ReadSyncSafeInteger(var AInt: Cardinal;\r\n const ASize: Byte): Longint;\r\nvar\r\n Value: PAnsiChar;\r\nbegin\r\n GetMem(Value, ASize);\r\n try\r\n Result := Read(Value^, ASize);\r\n UnSyncSafe(Value^, ASize, AInt);\r\n finally\r\n FreeMem(Value);\r\n end;\r\nend;\r\n\r\nfunction TJvID3Stream.ReadSyncSafeInteger(var AInt: Int64;\r\n const ASize: Byte): Longint;\r\nvar\r\n Value: PAnsiChar;\r\nbegin\r\n GetMem(Value, ASize);\r\n try\r\n Result := Read(Value^, ASize);\r\n UnSyncSafe(Value^, ASize, AInt);\r\n finally\r\n FreeMem(Value);\r\n end;\r\nend;\r\n\r\nfunction TJvID3Stream.ReadSyncSafeInteger(var AInt: Cardinal): Longint;\r\nvar\r\n Value: Cardinal;\r\nbegin\r\n Result := Read(Value, 4);\r\n UnSyncSafe(Value, 4, AInt);\r\nend;\r\n\r\nfunction TJvID3Stream.ReadUserString(var S1, S2: WideString): Longint;\r\nvar\r\n SA1, SA2: AnsiString;\r\nbegin\r\n case SourceEncoding of\r\n ienISO_8859_1:\r\n begin\r\n Result := ReadUserStringA(SA1, SA2);\r\n S1 := AnsiStringToUTF16(SA1);\r\n S2 := AnsiStringToUTF16(SA2);\r\n end;\r\n ienUTF_16, ienUTF_16BE:\r\n Result := ReadUserStringW(S1, S2);\r\n ienUTF_8:\r\n Result := ReadUserStringUTF8(S1, S2);\r\n else\r\n Result := 0;\r\n ID3Error(RsEID3UnknownEncoding);\r\n end;\r\nend;\r\n\r\nfunction TJvID3Stream.ReadUserStringA(var SA1, SA2: AnsiString): Longint;\r\nbegin\r\n Result := ReadStringA(SA1);\r\n\r\n if CanRead(1) then\r\n Result := Result + ReadStringA(SA2)\r\n else\r\n SA2 := '';\r\nend;\r\n\r\nfunction TJvID3Stream.ReadUserStringUTF8(var SW1, SW2: WideString): Longint;\r\nvar\r\n SA1, SA2: AnsiString;\r\nbegin\r\n Result := ReadUserStringA(SA1, SA2);\r\n SW1 := UTF8ToWideString(SA1);\r\n SW2 := UTF8ToWideString(SA2);\r\nend;\r\n\r\nfunction TJvID3Stream.ReadUserStringW(var SW1, SW2: WideString): Longint;\r\nbegin\r\n Result := ReadStringW(SW1);\r\n\r\n if CanRead(2) then\r\n Result := Result + ReadStringW(SW2)\r\n else\r\n SW2 := '';\r\nend;\r\n\r\nprocedure TJvID3Stream.SetSourceEncoding(const Value: TJvID3Encoding);\r\nbegin\r\n if FSourceEncoding <> Value then\r\n begin\r\n FSourceEncoding := Value;\r\n UpdateDestEncoding;\r\n end;\r\nend;\r\n\r\nprocedure TJvID3Stream.UpdateDestEncoding;\r\nconst\r\n CEncodingTry: array [0..3] of TJvID3Encoding =\r\n (ienUTF_16, ienUTF_16BE, ienUTF_8, ienISO_8859_1);\r\nvar\r\n I: Integer;\r\nbegin\r\n { FSourceEncoding is the encoding of a specific frame; the controller\r\n may prevent writing of some encodings (for example if the\r\n version (2.3) doesn't support it).\r\n\r\n Therefore we use FDestEncoding, that is set to the encoding actually\r\n written to the stream\r\n (when writing, symetrically for reading )\r\n }\r\n Assert(FAllowedEncodings <> [], RsEAllowedEncodingsIsEmpty);\r\n\r\n FDestEncoding := FSourceEncoding;\r\n if not (FDestEncoding in FAllowedEncodings) then\r\n begin\r\n I := 0;\r\n while (I <= High(CEncodingTry)) and not (CEncodingTry[I] in FAllowedEncodings) do\r\n Inc(I);\r\n if I > High(CEncodingTry) then\r\n // insanity, should not happen\r\n ID3Error(RsECouldNotFindAllowableEncoding);\r\n\r\n FDestEncoding := CEncodingTry[I];\r\n end;\r\nend;\r\n\r\nfunction TJvID3Stream.WriteDate(const ADate: TDateTime): Longint;\r\nvar\r\n Year, Month, Day: Word;\r\n S: AnsiString;\r\nbegin\r\n { Format = YYYYMMDD }\r\n DecodeDate(ADate, Year, Month, Day);\r\n S := {$IFDEF HAS_UNIT_ANSISTRINGS}AnsiStrings.{$ENDIF HAS_UNIT_ANSISTRINGS}Format('%.4d%.2d%.2d', [Year, Month, Day]);\r\n Result := WriteStringA(S);\r\nend;\r\n\r\nfunction TJvID3Stream.WriteEnc: Longint;\r\nbegin\r\n Result := Write(DestEncoding, 1);\r\nend;\r\n\r\nfunction TJvID3Stream.WriteFixedNumber(AValue: Cardinal): Longint;\r\nbegin\r\n { Swap byte order from little endian to big endian }\r\n AValue := ReverseBytes(AValue);\r\n Result := Write(AValue, 4);\r\nend;\r\n\r\nfunction TJvID3Stream.WriteFixedNumber3(AValue: Cardinal): Longint;\r\ntype\r\n TBytes = array [0..3] of Byte;\r\nbegin\r\n Assert(AValue <= $00FFFFFF, RsEValueTooBig);\r\n\r\n { Swap byte order from little endian to big endian }\r\n AValue := ReverseBytes(AValue);\r\n Result := Write(TBytes(AValue)[1], 3);\r\nend;\r\n\r\nfunction TJvID3Stream.WriteLanguage(const Language: AnsiString): Longint;\r\nbegin\r\n if Length(Language) <> 3 then\r\n ID3Error(RsELanguageNotOfLength3);\r\n\r\n Result := WriteStringA(Language);\r\nend;\r\n\r\nfunction TJvID3Stream.WriteNumber(AValue: Cardinal): Longint;\r\nbegin\r\n { Swap byte order from little endian to big endian }\r\n AValue := ReverseBytes(AValue);\r\n Result := Write(AValue, 4);\r\nend;\r\n\r\nfunction TJvID3Stream.WritePadding(const Count: Longint): Longint;\r\nvar\r\n Pos: Longint;\r\nbegin\r\n Pos := Position + Count;\r\n if Pos > 0 then\r\n begin\r\n if Pos > Size then\r\n begin\r\n if Pos > Capacity then\r\n Capacity := Pos;\r\n Size := Pos;\r\n end;\r\n FillChar(Pointer(PAnsiChar(Memory) + Position)^, Count, 0);\r\n //System.Move(Buffer, Pointer(PAnsiChar(FMemory) + FPosition)^, Count);\r\n Position := Pos;\r\n Result := Count;\r\n Exit;\r\n end;\r\n Result := 0;\r\nend;\r\n\r\nfunction TJvID3Stream.WriteStringA(const SA: AnsiString): Longint;\r\nbegin\r\n Result := Write(PAnsiChar(SA)^, Length(SA));\r\nend;\r\n\r\nfunction TJvID3Stream.WriteStringEnc(const S: WideString): Longint;\r\nbegin\r\n case DestEncoding of\r\n ienISO_8859_1:\r\n Result := WriteStringA(UTF16ToAnsiString(S));\r\n ienUTF_16, ienUTF_16BE:\r\n Result := WriteStringW(S);\r\n ienUTF_8:\r\n Result := WriteStringUTF8(S);\r\n else\r\n Result := 0;\r\n ID3Error(RsEID3UnknownEncoding);\r\n end;\r\nend;\r\n\r\nfunction TJvID3Stream.WriteStringUTF8(const SW: WideString): Longint;\r\nvar\r\n SA: AnsiString;\r\nbegin\r\n SA := WideStringToUTF8(SW);\r\n Result := WriteStringA(SA);\r\nend;\r\n\r\nfunction TJvID3Stream.WriteStringW(const SW: WideString): Longint;\r\nvar\r\n Order: WideChar;\r\nbegin\r\n Result := 0;\r\n\r\n if DestEncoding = ienUTF_16 then\r\n begin\r\n Order := BOM_LSB_FIRST;\r\n Result := Write(Order, 2);\r\n end;\r\n\r\n Result := Result + Write(SW[1], 2 * Length(SW));\r\nend;\r\n\r\nfunction TJvID3Stream.WriteSyncSafeInteger(const AInt: Int64;\r\n const ASize: Byte): Longint;\r\nvar\r\n Value: PAnsiChar;\r\nbegin\r\n GetMem(Value, ASize);\r\n try\r\n SyncSafe(AInt, Value^, ASize);\r\n Result := Write(Value^, ASize);\r\n finally\r\n FreeMem(Value);\r\n end;\r\nend;\r\n\r\nfunction TJvID3Stream.WriteSyncSafeInteger(const AInt: Cardinal;\r\n const ASize: Byte): Longint;\r\nvar\r\n Value: PAnsiChar;\r\nbegin\r\n GetMem(Value, ASize);\r\n try\r\n SyncSafe(AInt, Value^, ASize);\r\n Result := Write(Value^, ASize);\r\n finally\r\n FreeMem(Value);\r\n end;\r\nend;\r\n\r\nfunction TJvID3Stream.WriteSyncSafeInteger(const AInt: Cardinal): Longint;\r\nvar\r\n Value: Cardinal;\r\nbegin\r\n SyncSafe(AInt, Value, 4);\r\n Result := Write(Value, 4);\r\nend;\r\n\r\nfunction TJvID3Stream.WriteTerminatorA: Longint;\r\nvar\r\n Ch: AnsiChar;\r\nbegin\r\n Ch := #0;\r\n Result := Write(Ch, 1);\r\nend;\r\n\r\nfunction TJvID3Stream.WriteTerminatorEnc: Longint;\r\nbegin\r\n case DestEncoding of\r\n ienISO_8859_1, ienUTF_8:\r\n Result := WriteTerminatorA;\r\n ienUTF_16, ienUTF_16BE:\r\n Result := WriteTerminatorW;\r\n else\r\n Result := 0;\r\n ID3Error(RsEID3UnknownEncoding);\r\n end;\r\nend;\r\n\r\nfunction TJvID3Stream.WriteTerminatorW: Longint;\r\nvar\r\n Ch: WideChar;\r\nbegin\r\n Ch := WideNull;\r\n Result := Write(Ch, 2);\r\nend;\r\n\r\nfunction TJvID3Stream.WriteUserString(const S1, S2: WideString): Longint;\r\nbegin\r\n case DestEncoding of\r\n ienISO_8859_1:\r\n Result := WriteUserStringA(UTF16ToAnsiString(S1), UTF16ToAnsiString(S2));\r\n ienUTF_16, ienUTF_16BE:\r\n Result := WriteUserStringW(S1, S2);\r\n ienUTF_8:\r\n Result := WriteUserStringUTF8(S1, S2);\r\n else\r\n Result := 0;\r\n ID3Error(RsEID3UnknownEncoding);\r\n end;\r\nend;\r\n\r\nfunction TJvID3Stream.WriteUserStringA(const SA1, SA2: AnsiString): Longint;\r\nbegin\r\n Result := WriteStringA(SA1) + WriteTerminatorA + WriteStringA(SA2);\r\nend;\r\n\r\nfunction TJvID3Stream.WriteUserStringUTF8(const SW1, SW2: WideString): Longint;\r\nvar\r\n SA1, SA2: AnsiString;\r\nbegin\r\n SA1 := WideStringToUTF8(SW1);\r\n SA2 := WideStringToUTF8(SW2);\r\n Result := WriteUserStringA(SA1, SA2);\r\nend;\r\n\r\nfunction TJvID3Stream.WriteUserStringW(const SW1, SW2: WideString): Longint;\r\nbegin\r\n Result := WriteStringW(SW1) + WriteTerminatorW + WriteStringW(SW2);\r\nend;\r\n\r\n{$IFDEF COMPILER12_UP}\r\n//=== { TJvID3StringList } ===================================================\r\n\r\nfunction TJvID3StringList.GetSeparatedText(const Separator: string): string;\r\nvar\r\n I, L: Integer;\r\n Size: Integer;\r\n Count: Integer;\r\n SepLen: Integer;\r\n P: PChar;\r\n S: string;\r\nbegin\r\n Count := GetCount;\r\n Size := 0;\r\n SepLen := Length(Separator);\r\n for I := 0 to Count - 1 do\r\n Inc(Size, Length(Get(I)) + SepLen);\r\n\r\n // set one separator less, the last line does not need a trailing separator\r\n SetLength(Result, Size - SepLen);\r\n if Size > 0 then\r\n begin\r\n P := Pointer(Result);\r\n I := 0;\r\n while True do\r\n begin\r\n S := Get(I);\r\n L := Length(S);\r\n if L <> 0 then\r\n begin\r\n // add current string\r\n System.Move(Pointer(S)^, P^, L * SizeOf(Char));\r\n Inc(P, L);\r\n end;\r\n Inc(I);\r\n if I = Count then\r\n Break;\r\n\r\n // add separators\r\n if SepLen <> 0 then\r\n begin\r\n System.Move(Pointer(Separator)^, P^, SepLen * SizeOf(Char));\r\n Inc(P, SepLen);\r\n end;\r\n end;\r\n end;\r\nend;\r\n{$ENDIF COMPILER12_UP}\r\n\r\n//=== { TJvID3TermsOfUseFrame } ==============================================\r\n\r\nprocedure TJvID3TermsOfUseFrame.Assign(Source: TPersistent);\r\nbegin\r\n if Source is TJvID3TermsOfUseFrame then\r\n begin\r\n FText := TJvID3TermsOfUseFrame(Source).Text;\r\n FLanguage := TJvID3TermsOfUseFrame(Source).Language;\r\n end;\r\n\r\n inherited Assign(Source);\r\nend;\r\n\r\nclass function TJvID3TermsOfUseFrame.CanAddFrame(AController: TJvID3Controller;\r\n AFrameID: TJvID3FrameID): Boolean;\r\nbegin\r\n { There may only be one 'USER' frame in a tag}\r\n Result := ((AFrameID = fiTermsOfUse) and not AController.HasFrame(fiTermsOfUse)) or\r\n inherited CanAddFrame(AController, AFrameID);\r\nend;\r\n\r\nfunction TJvID3TermsOfUseFrame.CheckFrame(const HandleError: TJvID3HandleError): Boolean;\r\nbegin\r\n Result := CheckIsLanguageA(Self, FLanguage, HandleError);\r\n\r\n { If something has changed update the framesize }\r\n if not Result and (HandleError = heAutoCorrect) then\r\n begin\r\n UpdateFrameSize;\r\n Result := True;\r\n end;\r\nend;\r\n\r\nprocedure TJvID3TermsOfUseFrame.Clear;\r\nbegin\r\n FText := '';\r\n FLanguage := '';\r\n inherited Clear;\r\nend;\r\n\r\nclass function TJvID3TermsOfUseFrame.Find(AController: TJvID3Controller): TJvID3TermsOfUseFrame;\r\nvar\r\n Frame: TJvID3Frame;\r\nbegin\r\n Result := nil;\r\n if not Assigned(AController) or not AController.Active then\r\n Exit;\r\n\r\n Frame := AController.Frames.FindFrame(fiTermsOfUse);\r\n if Frame is TJvID3TermsOfUseFrame then\r\n Result := TJvID3TermsOfUseFrame(Frame);\r\nend;\r\n\r\nclass function TJvID3TermsOfUseFrame.FindOrCreate(AController: TJvID3Controller): TJvID3TermsOfUseFrame;\r\nbegin\r\n if not Assigned(AController) then\r\n ID3Error(RsEID3NoController);\r\n\r\n Result := Find(AController);\r\n if not Assigned(Result) then\r\n Result := TJvID3TermsOfUseFrame(AController.AddFrame(fiTermsOfUse));\r\nend;\r\n\r\nfunction TJvID3TermsOfUseFrame.GetFrameSize(const ToEncoding: TJvID3Encoding): Cardinal;\r\nbegin\r\n { Text encoding $xx\r\n Language $xx xx xx\r\n The actual text \r\n }\r\n Result := 1 + 3 + LengthEnc(Text, ToEncoding);\r\nend;\r\n\r\nfunction TJvID3TermsOfUseFrame.GetIsEmpty: Boolean;\r\nbegin\r\n Result := (Text = '') and (Length(FLanguage) = 0);\r\nend;\r\n\r\nfunction TJvID3TermsOfUseFrame.MustWriteAsUTF: Boolean;\r\nbegin\r\n Result := HasNonISO_8859_1Chars(Text);\r\nend;\r\n\r\nprocedure TJvID3TermsOfUseFrame.ReadFrame;\r\nbegin\r\n { Text encoding $xx\r\n Language $xx xx xx\r\n The actual text \r\n }\r\n with Stream do\r\n begin\r\n ReadEncoding;\r\n ReadLanguage(FLanguage);\r\n ReadStringEnc(FText);\r\n end;\r\nend;\r\n\r\nfunction TJvID3TermsOfUseFrame.SameUniqueIDAs(const Frame: TJvID3Frame): Boolean;\r\nbegin\r\n { There may only be one 'USER' frame in a tag}\r\n Result := (Assigned(Frame) and (Frame.FrameID = FrameID) and (FrameID = fiTermsOfUse)) or\r\n inherited SameUniqueIDAs(Frame);\r\nend;\r\n\r\nprocedure TJvID3TermsOfUseFrame.SetLanguage(const Value: AnsiString);\r\nbegin\r\n if FLanguage <> Value then\r\n begin\r\n FLanguage := Value;\r\n Changed;\r\n end;\r\nend;\r\n\r\nprocedure TJvID3TermsOfUseFrame.SetText(const Value: WideString);\r\nbegin\r\n if Value <> FText then\r\n begin\r\n FText := Value;\r\n Changed;\r\n end;\r\nend;\r\n\r\nfunction TJvID3TermsOfUseFrame.SupportsVersion(const AVersion: TJvID3Version): Boolean;\r\nbegin\r\n case FrameID of\r\n { ** Not supported in 2.2 ** }\r\n\r\n fiTermsOfUse:\r\n Result := AVersion in [ive2_3, ive2_4];\r\n else\r\n Result := True;\r\n end;\r\nend;\r\n\r\nprocedure TJvID3TermsOfUseFrame.WriteFrame;\r\nbegin\r\n { Text encoding $xx\r\n Language $xx xx xx\r\n The actual text \r\n }\r\n with Stream do\r\n begin\r\n WriteEncoding;\r\n WriteLanguage(Language);\r\n WriteStringEnc(Text);\r\n end;\r\nend;\r\n\r\n//=== { TJvID3TextFrame } ====================================================\r\n\r\nprocedure TJvID3TextFrame.ChangeToVersion(const ANewVersion: TJvID3Version);\r\nvar\r\n Year: Word;\r\n LDate: TDateTime;\r\n Frame: TJvID3Frame;\r\nbegin\r\n if ANewVersion <> ive2_4 then\r\n Exit;\r\n\r\n { Change\r\n\r\n fiYear, fiDate, fiTime, fiRecordingDates frames into 1 fiRecordingTime frame }\r\n\r\n if FrameID in [fiDate, fiTime] then\r\n begin\r\n if Assigned(FFrames.FindFrame(fiRecordingTime)) then\r\n Exit;\r\n\r\n { 1. Determine the year from a fiYear frame}\r\n Frame := TJvID3NumberFrame.Find(FController, fiYear);\r\n if Assigned(Frame) then\r\n Year := TJvID3NumberFrame(Frame).Value\r\n else\r\n { hm, no year frame , just assume it's current year }\r\n Year := YearOfDate(Date);\r\n\r\n { 2. Determine month + day from a fiDate frame }\r\n Frame := TJvID3TextFrame.Find(FController, fiDate);\r\n if Assigned(Frame) then\r\n with TJvID3TextFrame(Frame) do\r\n LDate := GetID3Date(Text, Encoding, Year)\r\n else\r\n try\r\n { hm, no date frame , just assume it's 1 jan }\r\n LDate := EncodeDate(Year, 1, 1);\r\n except\r\n on EConvertError do\r\n LDate := 0;\r\n end;\r\n\r\n { 3. Determine hour + min from a fiTime frame}\r\n Frame := TJvID3TextFrame.Find(FController, fiTime);\r\n if Assigned(Frame) then\r\n with TJvID3TextFrame(Frame) do\r\n LDate := LDate + GetID3Time(Text, Encoding);\r\n\r\n { 4. Copy constructed date to a fiRecordingTime frame }\r\n TJvID3TimestampFrame.FindOrCreate(FController, fiRecordingTime).Value := LDate;\r\n end;\r\nend;\r\n\r\nfunction TJvID3TextFrame.CheckFrame(const HandleError: TJvID3HandleError): Boolean;\r\nbegin\r\n case FrameID of\r\n fiTime:\r\n Result := CheckIsID3Time(Self, FText, HandleError);\r\n fiDate:\r\n Result := CheckIsID3Date(Self, FText, HandleError);\r\n fiPartInSet:\r\n Result := CheckIsID3PartInSet(Self, FText, HandleError);\r\n fiTrackNum:\r\n Result := CheckIsID3PartInSet(Self, FText, HandleError);\r\n else\r\n Result := True;\r\n end;\r\n\r\n { If something has changed update the framesize }\r\n if not Result and (HandleError = heAutoCorrect) then\r\n begin\r\n UpdateFrameSize;\r\n Result := True;\r\n end;\r\nend;\r\n\r\nclass function TJvID3TextFrame.Find(AController: TJvID3Controller;\r\n const AFrameID: TJvID3FrameID): TJvID3TextFrame;\r\nvar\r\n Frame: TJvID3Frame;\r\nbegin\r\n Result := nil;\r\n if not Assigned(AController) or not AController.Active then\r\n Exit;\r\n\r\n Frame := AController.Frames.FindFrame(AFrameID);\r\n if Frame is TJvID3TextFrame then\r\n Result := TJvID3TextFrame(Frame);\r\nend;\r\n\r\nclass function TJvID3TextFrame.FindOrCreate(AController: TJvID3Controller;\r\n const AFrameID: TJvID3FrameID): TJvID3TextFrame;\r\nbegin\r\n if not Assigned(AController) then\r\n ID3Error(RsEID3NoController);\r\n\r\n Result := Find(AController, AFrameID);\r\n if not Assigned(Result) then\r\n begin\r\n AController.CheckFrameClass(TJvID3TextFrame, AFrameID);\r\n Result := TJvID3TextFrame(AController.AddFrame(AFrameID));\r\n end;\r\nend;\r\n\r\nfunction TJvID3TextFrame.GetText: WideString;\r\nbegin\r\n Result := FText;\r\nend;\r\n\r\nprocedure TJvID3TextFrame.SetText(const ANewText: WideString);\r\nbegin\r\n if ANewText <> FText then\r\n begin\r\n FText := ANewText;\r\n Changed;\r\n end;\r\nend;\r\n\r\n//=== { TJvID3TimestampFrame } ===============================================\r\n\r\nprocedure TJvID3TimestampFrame.ChangeToVersion(const ANewVersion: TJvID3Version);\r\nvar\r\n Year, Month, Day: Word;\r\n Hour, Min: Word;\r\n Dummy1, Dummy2: Word;\r\nbegin\r\n { Change\r\n\r\n * fiRecordingTime into fiYear, fiDate, fiTime, fiRecordingDates\r\n * fiOrigReleaseTime into fiOrigYear }\r\n\r\n if IsEmpty or not (ANewVersion in [ive2_2, ive2_3]) then\r\n Exit;\r\n\r\n if FrameID = fiRecordingTime then\r\n begin\r\n { Check if frames don't exists already }\r\n if [fiYear, fiDate, fiTime] * FFrames.GetFrameIDs = [] then\r\n begin\r\n { 1. Determine the Year, Month, Day, Hour and Min from this frame }\r\n DecodeTime(Value, Hour, Min, Dummy1, Dummy2);\r\n DecodeDate(Value, Year, Month, Day);\r\n\r\n { 2. Create a new fiYear frame for the Year }\r\n TJvID3NumberFrame.FindOrCreate(FController, fiYear).Value := Year;\r\n\r\n { 3. Create a new fiDate frame [format = 'DDMM'] for the Day and Month }\r\n TJvID3TextFrame.FindOrCreate(FController, fiDate).Text :=\r\n Format('%.2d%.2d', [Day, Month]);\r\n\r\n { 4. Create a new fiTime frame [format = 'HHMM'] for the Hour and Min }\r\n TJvID3TextFrame.FindOrCreate(FController, fiTime).Text :=\r\n Format('%.2d%.2d', [Hour, Min]);\r\n end;\r\n end\r\n else\r\n if FrameID = fiOrigReleaseTime then\r\n begin\r\n { Check if frames don't exists already }\r\n if not (fiOrigYear in FFrames.GetFrameIDs) then\r\n begin\r\n DecodeDate(Value, Year, Dummy1, Dummy2);\r\n\r\n { We can only store the year in a fiOrigYear frame, ie no other frames\r\n are supported in v2.3 }\r\n TJvID3NumberFrame.FindOrCreate(FController, fiOrigYear).Value := Year;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJvID3TimestampFrame.CheckFrame(const HandleError: TJvID3HandleError): Boolean;\r\nbegin\r\n Result := True;\r\nend;\r\n\r\nclass function TJvID3TimestampFrame.Find(AController: TJvID3Controller;\r\n const AFrameID: TJvID3FrameID): TJvID3TimestampFrame;\r\nvar\r\n Frame: TJvID3Frame;\r\nbegin\r\n Result := nil;\r\n if not Assigned(AController) or not AController.Active then\r\n Exit;\r\n\r\n Frame := AController.Frames.FindFrame(AFrameID);\r\n if Frame is TJvID3TimestampFrame then\r\n Result := TJvID3TimestampFrame(Frame);\r\nend;\r\n\r\nclass function TJvID3TimestampFrame.FindOrCreate(AController: TJvID3Controller;\r\n const AFrameID: TJvID3FrameID): TJvID3TimestampFrame;\r\nbegin\r\n if not Assigned(AController) then\r\n ID3Error(RsEID3NoController);\r\n\r\n Result := Find(AController, AFrameID);\r\n if not Assigned(Result) then\r\n begin\r\n AController.CheckFrameClass(TJvID3TimestampFrame, AFrameID);\r\n Result := TJvID3TimestampFrame(AController.AddFrame(AFrameID));\r\n end;\r\nend;\r\n\r\nfunction TJvID3TimestampFrame.GetText: WideString;\r\nvar\r\n Year, Month, Day, Hour, Min, Sec, Dummy: Word;\r\nbegin\r\n { The timestamp fields are based on a subset of ISO 8601. When being as\r\n precise as possible the format of a time string is\r\n yyyy-MM-ddTHH:mm:ss (year, \"-\", month, \"-\", day, \"T\", hour (out of\r\n 24), \":\", minutes, \":\", seconds), but the precision may be reduced by\r\n removing as many time indicators as wanted. Hence valid timestamps\r\n are\r\n yyyy, yyyy-MM, yyyy-MM-dd, yyyy-MM-ddTHH, yyyy-MM-ddTHH:mm and\r\n yyyy-MM-ddTHH:mm:ss. All time stamps are UTC. For durations, use\r\n the slash character as described in 8601, and for multiple non-\r\n contiguous dates, use multiple strings, if allowed by the frame\r\n definition.\r\n }\r\n\r\n DecodeDate(Value, Year, Month, Day);\r\n DecodeTime(Value, Hour, Min, Sec, Dummy);\r\n if Year > 9999 then\r\n Year := 9999;\r\n if (Hour = 0) and (Min = 0) and (Sec = 0) then\r\n Result := Format('%.4d-%.2d-%.2d', [Year, Month, Day])\r\n else\r\n Result := Format('%.4d-%.2d-%.2dT%.2d:%.2d:%.2d', [Year, Month, Day, Hour, Min, Sec]);\r\nend;\r\n\r\nprocedure TJvID3TimestampFrame.SetText(const ANewText: WideString);\r\ntype\r\n TimeKind = (tkYear, tkMonth, tkDay, tkHour, tkMin, tkSec);\r\nconst\r\n { 1234567890123456789\r\n Format = yyyy-MM-ddTHH:mm:ss }\r\n SepPos: array [TimeKind] of Byte = (5, 8, 11, 14, 17, 20);\r\nvar\r\n S: AnsiString;\r\n TimeArray: array [TimeKind] of Word;\r\n BusyWith: TimeKind;\r\n I: Byte;\r\nbegin\r\n { Max. 19 chars }\r\n S := UTF16ToAnsiString(Copy(ANewText, 1, 19));\r\n\r\n FillChar(TimeArray, SizeOf(TimeArray), #0);\r\n TimeArray[tkMonth] := 1;\r\n TimeArray[tkDay] := 1;\r\n\r\n I := 1;\r\n BusyWith := tkYear;\r\n while I <= Length(S) do\r\n begin\r\n { Use Timearray [Sec] as temp variable }\r\n\r\n if I = SepPos[BusyWith] then\r\n begin\r\n TimeArray[BusyWith] := TimeArray[tkSec];\r\n TimeArray[tkSec] := 0;\r\n Inc(BusyWith);\r\n end\r\n else\r\n if CharInSet(S[I], DigitSymbols) then\r\n TimeArray[tkSec] := TimeArray[tkSec] * 10 + Ord(S[I]) - Ord('0')\r\n else\r\n Break;\r\n\r\n Inc(I);\r\n end;\r\n\r\n if I = SepPos[BusyWith] then\r\n begin\r\n TimeArray[BusyWith] := TimeArray[tkSec];\r\n TimeArray[tkSec] := 0;\r\n //Inc(BusyWith);\r\n end;\r\n\r\n try\r\n FValue := EncodeDate(TimeArray[tkYear], TimeArray[tkMonth], TimeArray[tkDay]);\r\n if I > 11 then\r\n FValue := FValue + EncodeTime(TimeArray[tkHour], TimeArray[tkMin], TimeArray[tkSec], 0)\r\n except\r\n on EConvertError do\r\n FValue := 0;\r\n end;\r\nend;\r\n\r\nprocedure TJvID3TimestampFrame.SetValue(const AValue: TDateTime);\r\nbegin\r\n if AValue <> FValue then\r\n begin\r\n FValue := AValue;\r\n Changed;\r\n end;\r\nend;\r\n\r\n//=== { TJvID3URLFrame } =====================================================\r\n\r\nprocedure TJvID3URLFrame.Assign(Source: TPersistent);\r\nbegin\r\n if Source is TJvID3URLFrame then\r\n FURL := TJvID3URLFrame(Source).URL;\r\n\r\n inherited Assign(Source);\r\nend;\r\n\r\nclass function TJvID3URLFrame.CanAddFrame(AController: TJvID3Controller;\r\n AFrameID: TJvID3FrameID): Boolean;\r\nbegin\r\n { There may only be one URL link frame of its kind in an tag, except for\r\n\r\n \"WCOM\", but not with the same content.\r\n \"WOAR\", but not with the same content.\r\n }\r\n case AFrameID of\r\n fiWWWCommercialInfo, fiWWWArtist:\r\n Result := True;\r\n fiWWWCopyright, fiWWWAudioFile, fiWWWAudioSource, fiWWWRadioPage, fiWWWPayment, fiWWWPublisher:\r\n Result := not AController.HasFrame(AFrameID);\r\n else\r\n Result := inherited CanAddFrame(AController, AFrameID);\r\n end;\r\nend;\r\n\r\nfunction TJvID3URLFrame.CheckFrame(const HandleError: TJvID3HandleError): Boolean;\r\nbegin\r\n Result := CheckIsURL(Self, FURL, HandleError);\r\n\r\n { If something has changed update the framesize }\r\n if not Result and (HandleError = heAutoCorrect) then\r\n begin\r\n UpdateFrameSize;\r\n Result := True;\r\n end;\r\nend;\r\n\r\nprocedure TJvID3URLFrame.Clear;\r\nbegin\r\n FURL := '';\r\n inherited Clear;\r\nend;\r\n\r\nclass function TJvID3URLFrame.Find(AController: TJvID3Controller;\r\n const AFrameID: TJvID3FrameID): TJvID3URLFrame;\r\nvar\r\n Frame: TJvID3Frame;\r\nbegin\r\n Result := nil;\r\n if not Assigned(AController) or not AController.Active then\r\n Exit;\r\n\r\n Frame := AController.Frames.FindFrame(AFrameID);\r\n if Frame is TJvID3URLFrame then\r\n Result := TJvID3URLFrame(Frame)\r\nend;\r\n\r\nclass function TJvID3URLFrame.FindOrCreate(AController: TJvID3Controller;\r\n const AFrameID: TJvID3FrameID): TJvID3URLFrame;\r\nbegin\r\n if not Assigned(AController) then\r\n ID3Error(RsEID3NoController);\r\n\r\n Result := Find(AController, AFrameID);\r\n if not Assigned(Result) then\r\n begin\r\n AController.CheckFrameClass(TJvID3URLFrame, AFrameID);\r\n Result := TJvID3URLFrame(AController.AddFrame(AFrameID));\r\n end;\r\nend;\r\n\r\nfunction TJvID3URLFrame.GetFrameSize(const ToEncoding: TJvID3Encoding): Cardinal;\r\nbegin\r\n Result := Length(URL);\r\nend;\r\n\r\nfunction TJvID3URLFrame.GetIsEmpty: Boolean;\r\nbegin\r\n Result := Length(URL) = 0;\r\nend;\r\n\r\nprocedure TJvID3URLFrame.ReadFrame;\r\nbegin\r\n with Stream do\r\n ReadStringA(FURL);\r\nend;\r\n\r\nfunction TJvID3URLFrame.SameUniqueIDAs(const Frame: TJvID3Frame): Boolean;\r\nbegin\r\n { There may only be one URL link frame of its kind in an tag, except for\r\n\r\n \"WCOM\", but not with the same content.\r\n \"WOAR\", but not with the same content.\r\n }\r\n Result := (Frame is TJvID3URLFrame) and (Frame.FrameID = FrameID);\r\n\r\n if Result then\r\n Result :=\r\n not (FrameID in [fiWWWCommercialInfo, fiWWWArtist]) or\r\n AnsiSameStr(URL, TJvID3URLFrame(Frame).URL)\r\n else\r\n Result := inherited SameUniqueIDAs(Frame);\r\nend;\r\n\r\nprocedure TJvID3URLFrame.SetURL(const Value: AnsiString);\r\nbegin\r\n if FURL <> Value then\r\n begin\r\n FURL := Value;\r\n Changed;\r\n end;\r\nend;\r\n\r\nprocedure TJvID3URLFrame.WriteFrame;\r\nbegin\r\n with Stream do\r\n WriteStringA(URL);\r\nend;\r\n\r\n//=== { TJvID3URLUserFrame } =================================================\r\n\r\nprocedure TJvID3URLUserFrame.Assign(Source: TPersistent);\r\nbegin\r\n if Source is TJvID3URLUserFrame then\r\n begin\r\n FDescription := TJvID3URLUserFrame(Source).Description;\r\n FURL := TJvID3URLUserFrame(Source).URL;\r\n end;\r\n\r\n inherited Assign(Source);\r\nend;\r\n\r\nclass function TJvID3URLUserFrame.CanAddFrame(AController: TJvID3Controller;\r\n AFrameID: TJvID3FrameID): Boolean;\r\nbegin\r\n { There may be more than one \"WXXX\" frame in each tag, but only one\r\n with the same description. }\r\n Result := (AFrameID = fiWWWUser) or inherited CanAddFrame(AController, AFrameID);\r\nend;\r\n\r\nfunction TJvID3URLUserFrame.CheckFrame(const HandleError: TJvID3HandleError): Boolean;\r\nbegin\r\n Result := CheckIsURL(Self, FURL, HandleError);\r\n\r\n { If something has changed update the framesize }\r\n if not Result and (HandleError = heAutoCorrect) then\r\n begin\r\n UpdateFrameSize;\r\n Result := True;\r\n end;\r\nend;\r\n\r\nprocedure TJvID3URLUserFrame.Clear;\r\nbegin\r\n FDescription := '';\r\n FURL := '';\r\n inherited Clear;\r\nend;\r\n\r\nclass function TJvID3URLUserFrame.Find(AController: TJvID3Controller;\r\n const Index: Integer): TJvID3URLUserFrame;\r\nvar\r\n FoundIndex: Integer;\r\n Frame: TJvID3Frame;\r\nbegin\r\n Result := nil;\r\n if not Assigned(AController) or not AController.Active then\r\n Exit;\r\n\r\n if not AController.FindFirstFrame(fiWWWUser, Frame) then\r\n Exit;\r\n\r\n FoundIndex := 0;\r\n\r\n while Assigned(Frame) and (FoundIndex < Index) do\r\n begin\r\n AController.FindNextFrame(fiWWWUser, Frame);\r\n Inc(FoundIndex);\r\n end;\r\n\r\n if Frame is TJvID3URLUserFrame then\r\n Result := TJvID3URLUserFrame(Frame);\r\nend;\r\n\r\nclass function TJvID3URLUserFrame.FindOrCreate(AController: TJvID3Controller;\r\n const Index: Integer): TJvID3URLUserFrame;\r\nbegin\r\n if not Assigned(AController) then\r\n ID3Error(RsEID3NoController);\r\n\r\n Result := Find(AController, Index);\r\n if not Assigned(Result) then\r\n Result := TJvID3URLUserFrame(AController.AddFrame(fiWWWUser));\r\nend;\r\n\r\nfunction TJvID3URLUserFrame.GetFrameSize(const ToEncoding: TJvID3Encoding): Cardinal;\r\nbegin\r\n { Text encoding $xx\r\n Description $00 (00)\r\n Value \r\n }\r\n Result := 1 +\r\n LengthEnc(Description, ToEncoding) +\r\n LengthTerminatorEnc(ToEncoding) +\r\n Cardinal(Length(FURL));\r\nend;\r\n\r\nfunction TJvID3URLUserFrame.GetIsEmpty: Boolean;\r\nbegin\r\n Result := (FURL = '') and (Description = '');\r\nend;\r\n\r\nfunction TJvID3URLUserFrame.MustWriteAsUTF: Boolean;\r\nbegin\r\n Result := HasNonISO_8859_1Chars(Description);\r\nend;\r\n\r\nprocedure TJvID3URLUserFrame.ReadFrame;\r\nbegin\r\n with Stream do\r\n begin\r\n ReadEncoding;\r\n ReadStringEnc(FDescription);\r\n ReadStringA(FURL);\r\n end;\r\nend;\r\n\r\nprocedure TJvID3URLUserFrame.SetDescription(const Value: WideString);\r\nbegin\r\n if Value <> FDescription then\r\n begin\r\n FDescription := Value;\r\n Changed;\r\n end;\r\nend;\r\n\r\nprocedure TJvID3URLUserFrame.SetURL(const Value: AnsiString);\r\nbegin\r\n if FURL <> Value then\r\n begin\r\n FURL := Value;\r\n Changed;\r\n end;\r\nend;\r\n\r\nprocedure TJvID3URLUserFrame.WriteFrame;\r\nbegin\r\n with Stream do\r\n begin\r\n WriteEncoding;\r\n WriteStringEnc(Description);\r\n WriteTerminatorEnc;\r\n WriteStringA(URL);\r\n end;\r\nend;\r\n\r\n//=== { TJvID3UserFrame } ====================================================\r\n\r\nprocedure TJvID3UserFrame.Assign(Source: TPersistent);\r\nbegin\r\n if Source is TJvID3CustomTextFrame then\r\n begin\r\n FValue := TJvID3UserFrame(Source).Value;\r\n FDescription := TJvID3UserFrame(Source).Description;\r\n end;\r\n\r\n inherited Assign(Source);\r\nend;\r\n\r\nclass function TJvID3UserFrame.CanAddFrame(AController: TJvID3Controller;\r\n AFrameID: TJvID3FrameID): Boolean;\r\nbegin\r\n { There may be more than one \"TXXX\" frame in each tag, but only one\r\n with the same description. }\r\n Result := (AFrameID = fiUserText) or\r\n inherited CanAddFrame(AController, AFrameID);\r\nend;\r\n\r\nfunction TJvID3UserFrame.CheckFrame(const HandleError: TJvID3HandleError): Boolean;\r\nbegin\r\n Result := True;\r\nend;\r\n\r\nprocedure TJvID3UserFrame.Clear;\r\nbegin\r\n FValue := '';\r\n FDescription := '';\r\n inherited Clear;\r\nend;\r\n\r\nclass function TJvID3UserFrame.Find(AController: TJvID3Controller;\r\n const Index: Integer): TJvID3UserFrame;\r\nvar\r\n FoundIndex: Integer;\r\n Frame: TJvID3Frame;\r\nbegin\r\n Result := nil;\r\n\r\n if not Assigned(AController) or not AController.Active then\r\n Exit;\r\n\r\n if not AController.FindFirstFrame(fiUserText, Frame) then\r\n Exit;\r\n\r\n FoundIndex := 0;\r\n\r\n while Assigned(Frame) and (FoundIndex < Index) do\r\n begin\r\n AController.FindNextFrame(fiUserText, Frame);\r\n Inc(FoundIndex);\r\n end;\r\n\r\n if Frame is TJvID3UserFrame then\r\n Result := TJvID3UserFrame(Frame);\r\nend;\r\n\r\nclass function TJvID3UserFrame.FindOrCreate(AController: TJvID3Controller;\r\n const Index: Integer): TJvID3UserFrame;\r\nbegin\r\n if not Assigned(AController) then\r\n ID3Error(RsEID3NoController);\r\n\r\n Result := Find(AController, Index);\r\n if not Assigned(Result) then\r\n Result := TJvID3UserFrame(AController.AddFrame(fiUserText));\r\nend;\r\n\r\nfunction TJvID3UserFrame.GetFrameSize(const ToEncoding: TJvID3Encoding): Cardinal;\r\nbegin\r\n { Text encoding $xx\r\n Description $00 (00)\r\n Value \r\n }\r\n Result := 1 +\r\n LengthEnc(Description, ToEncoding) +\r\n LengthTerminatorEnc(ToEncoding) +\r\n LengthEnc(Value, ToEncoding);\r\nend;\r\n\r\nfunction TJvID3UserFrame.GetIsEmpty: Boolean;\r\nbegin\r\n Result := (Value = '') and (Description = '');\r\nend;\r\n\r\nfunction TJvID3UserFrame.MustWriteAsUTF: Boolean;\r\nbegin\r\n Result := HasNonISO_8859_1Chars(Value) or HasNonISO_8859_1Chars(Description)\r\nend;\r\n\r\nprocedure TJvID3UserFrame.ReadFrame;\r\nbegin\r\n with Stream do\r\n begin\r\n ReadEncoding;\r\n ReadUserString(FDescription, FValue);\r\n end;\r\nend;\r\n\r\nprocedure TJvID3UserFrame.SetDescription(const AValue: WideString);\r\nbegin\r\n if AValue <> FDescription then\r\n begin\r\n FDescription := AValue;\r\n Changed;\r\n end;\r\nend;\r\n\r\nprocedure TJvID3UserFrame.SetValue(const AValue: WideString);\r\nbegin\r\n if AValue <> FValue then\r\n begin\r\n FValue := AValue;\r\n Changed;\r\n end;\r\nend;\r\n\r\nprocedure TJvID3UserFrame.WriteFrame;\r\nbegin\r\n with Stream do\r\n begin\r\n WriteEncoding;\r\n WriteUserString(Description, Value);\r\n end;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvIconList.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvIcoList.PAS, released on 2002-07-04.\r\n\r\nThe Initial Developers of the Original Code are: Fedor Koshevnikov, Igor Pavluk and Serge Korolev\r\nCopyright (c) 1997, 1998 Fedor Koshevnikov, Igor Pavluk and Serge Korolev\r\nCopyright (c) 2001,2002 SGB Software\r\nAll Rights Reserved.\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvIconList.pas 12461 2009-08-14 17:21:33Z obones $\r\n\r\nunit JvIconList;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, SysUtils, Graphics, Classes;\r\n\r\ntype\r\n TJvIconList = class(TPersistent)\r\n private\r\n FList: TList;\r\n FUpdateCount: Integer;\r\n FOnChange: TNotifyEvent;\r\n procedure ReadData(Stream: TStream);\r\n procedure WriteData(Stream: TStream);\r\n procedure SetUpdateState(Updating: Boolean);\r\n procedure IconChanged(Sender: TObject);\r\n function AddIcon(Icon: TIcon): Integer;\r\n protected\r\n procedure Changed; virtual;\r\n procedure DefineProperties(Filer: TFiler); override;\r\n function Get(Index: Integer): TIcon; virtual;\r\n function GetCount: Integer; virtual;\r\n procedure Put(Index: Integer; Icon: TIcon); virtual;\r\n public\r\n constructor Create;\r\n destructor Destroy; override;\r\n function Add(Icon: TIcon): Integer; virtual;\r\n function AddResource(Instance: THandle; ResId: PChar): Integer; virtual;\r\n procedure Assign(Source: TPersistent); override;\r\n procedure BeginUpdate;\r\n procedure EndUpdate;\r\n procedure Clear; virtual;\r\n procedure Delete(Index: Integer); virtual;\r\n procedure Exchange(Index1, Index2: Integer); virtual;\r\n function IndexOf(Icon: TIcon): Integer; virtual;\r\n procedure Insert(Index: Integer; Icon: TIcon); virtual;\r\n procedure InsertResource(Index: Integer; Instance: THandle; ResId: PChar); virtual;\r\n procedure LoadResource(Instance: THandle; const ResIds: array of PChar);\r\n procedure LoadFromStream(Stream: TStream); virtual;\r\n procedure Move(CurIndex, NewIndex: Integer); virtual;\r\n procedure SaveToStream(Stream: TStream); virtual;\r\n property Count: Integer read GetCount;\r\n property Icons[Index: Integer]: TIcon read Get write Put; default;\r\n property OnChange: TNotifyEvent read FOnChange write FOnChange;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvIconList.pas $';\r\n Revision: '$Revision: 12461 $';\r\n Date: '$Date: 2009-08-14 19:21:33 +0200 (ven. 14 août 2009) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\n\r\nconstructor TJvIconList.Create;\r\nbegin\r\n inherited Create;\r\n FList := TList.Create;\r\nend;\r\n\r\ndestructor TJvIconList.Destroy;\r\nbegin\r\n FOnChange := nil;\r\n Clear;\r\n FList.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvIconList.BeginUpdate;\r\nbegin\r\n if FUpdateCount = 0 then\r\n SetUpdateState(True);\r\n Inc(FUpdateCount);\r\nend;\r\n\r\nprocedure TJvIconList.Changed;\r\nbegin\r\n if (FUpdateCount = 0) and Assigned(FOnChange) then\r\n FOnChange(Self);\r\nend;\r\n\r\nprocedure TJvIconList.EndUpdate;\r\nbegin\r\n Dec(FUpdateCount);\r\n if FUpdateCount = 0 then\r\n SetUpdateState(False);\r\nend;\r\n\r\nprocedure TJvIconList.ReadData(Stream: TStream);\r\nvar\r\n Len, Cnt: Longint;\r\n I: Integer;\r\n Icon: TIcon;\r\n Mem: TMemoryStream;\r\nbegin\r\n BeginUpdate;\r\n try\r\n Clear;\r\n Mem := TMemoryStream.Create;\r\n try\r\n Stream.Read(Cnt, SizeOf(Longint));\r\n for I := 0 to Cnt - 1 do\r\n begin\r\n Stream.Read(Len, SizeOf(Longint));\r\n if Len > 0 then\r\n begin\r\n Icon := TIcon.Create;\r\n try\r\n Mem.SetSize(Len);\r\n Stream.Read(Mem.Memory^, Len);\r\n Mem.Position := 0;\r\n Icon.LoadFromStream(Mem);\r\n AddIcon(Icon);\r\n except\r\n Icon.Free;\r\n raise;\r\n end;\r\n end\r\n else\r\n AddIcon(nil);\r\n end;\r\n finally\r\n Mem.Free;\r\n end;\r\n finally\r\n EndUpdate;\r\n end;\r\nend;\r\n\r\nprocedure TJvIconList.WriteData(Stream: TStream);\r\nvar\r\n I: Integer;\r\n Len: Longint;\r\n Mem: TMemoryStream;\r\nbegin\r\n Mem := TMemoryStream.Create;\r\n try\r\n Len := FList.Count;\r\n Stream.Write(Len, SizeOf(Longint));\r\n for I := 0 to FList.Count - 1 do\r\n begin\r\n Mem.Clear;\r\n if (Icons[I] <> nil) and not Icons[I].Empty then\r\n begin\r\n Icons[I].SaveToStream(Mem);\r\n Len := Mem.Size;\r\n end\r\n else\r\n Len := 0;\r\n Stream.Write(Len, SizeOf(Longint));\r\n if Len > 0 then\r\n Stream.Write(Mem.Memory^, Mem.Size);\r\n end;\r\n finally\r\n Mem.Free;\r\n end;\r\nend;\r\n\r\nprocedure TJvIconList.DefineProperties(Filer: TFiler);\r\n\r\n function DoWrite: Boolean;\r\n var\r\n I: Integer;\r\n Ancestor: TJvIconList;\r\n begin\r\n Ancestor := TJvIconList(Filer.Ancestor);\r\n if (Ancestor <> nil) and (Ancestor.Count = Count) and (Count > 0) then\r\n begin\r\n Result := False;\r\n for I := 0 to Count - 1 do\r\n begin\r\n Result := Icons[I] <> Ancestor.Icons[I];\r\n if Result then\r\n Break;\r\n end\r\n end\r\n else\r\n Result := Count > 0;\r\n end;\r\n\r\nbegin\r\n Filer.DefineBinaryProperty('Icons', ReadData, WriteData, DoWrite);\r\nend;\r\n\r\nfunction TJvIconList.Get(Index: Integer): TIcon;\r\nbegin\r\n Result := TObject(FList[Index]) as TIcon;\r\nend;\r\n\r\nfunction TJvIconList.GetCount: Integer;\r\nbegin\r\n Result := FList.Count;\r\nend;\r\n\r\nprocedure TJvIconList.IconChanged(Sender: TObject);\r\nbegin\r\n Changed;\r\nend;\r\n\r\nprocedure TJvIconList.Put(Index: Integer; Icon: TIcon);\r\nbegin\r\n BeginUpdate;\r\n try\r\n if Index = Count then\r\n Add(nil);\r\n if Icons[Index] = nil then\r\n FList[Index] := TIcon.Create;\r\n Icons[Index].OnChange := IconChanged;\r\n Icons[Index].Assign(Icon);\r\n finally\r\n EndUpdate;\r\n end;\r\nend;\r\n\r\nfunction TJvIconList.AddIcon(Icon: TIcon): Integer;\r\nbegin\r\n Result := FList.Add(Icon);\r\n if Icon <> nil then\r\n Icon.OnChange := IconChanged;\r\n Changed;\r\nend;\r\n\r\nfunction TJvIconList.Add(Icon: TIcon): Integer;\r\nvar\r\n Ico: TIcon;\r\nbegin\r\n Ico := TIcon.Create;\r\n try\r\n Ico.Assign(Icon);\r\n Result := AddIcon(Ico);\r\n except\r\n Ico.Free;\r\n raise;\r\n end;\r\nend;\r\n\r\nfunction TJvIconList.AddResource(Instance: THandle; ResId: PChar): Integer;\r\nvar\r\n Ico: TIcon;\r\nbegin\r\n Ico := TIcon.Create;\r\n try\r\n Ico.Handle := LoadIcon(Instance, ResId);\r\n Result := AddIcon(Ico);\r\n except\r\n Ico.Free;\r\n raise;\r\n end;\r\nend;\r\n\r\nprocedure TJvIconList.Assign(Source: TPersistent);\r\nvar\r\n I: Integer;\r\nbegin\r\n if Source = nil then\r\n Clear\r\n else\r\n if Source is TJvIconList then\r\n begin\r\n BeginUpdate;\r\n try\r\n Clear;\r\n for I := 0 to TJvIconList(Source).Count - 1 do\r\n Add(TJvIconList(Source)[I]);\r\n finally\r\n EndUpdate;\r\n end;\r\n end\r\n else\r\n if Source is TIcon then\r\n begin\r\n BeginUpdate;\r\n try\r\n Clear;\r\n Add(TIcon(Source));\r\n finally\r\n EndUpdate;\r\n end;\r\n end\r\n else\r\n inherited Assign(Source);\r\nend;\r\n\r\nprocedure TJvIconList.Clear;\r\nvar\r\n I: Integer;\r\nbegin\r\n BeginUpdate;\r\n try\r\n for I := FList.Count - 1 downto 0 do\r\n Delete(I);\r\n finally\r\n EndUpdate;\r\n end;\r\nend;\r\n\r\nprocedure TJvIconList.Delete(Index: Integer);\r\nvar\r\n Icon: TIcon;\r\nbegin\r\n Icon := Icons[Index];\r\n if Icon <> nil then\r\n begin\r\n Icon.OnChange := nil;\r\n Icon.Free;\r\n end;\r\n FList.Delete(Index);\r\n Changed;\r\nend;\r\n\r\nprocedure TJvIconList.Exchange(Index1, Index2: Integer);\r\nbegin\r\n FList.Exchange(Index1, Index2);\r\n Changed;\r\nend;\r\n\r\nfunction TJvIconList.IndexOf(Icon: TIcon): Integer;\r\nbegin\r\n Result := FList.IndexOf(Icon);\r\nend;\r\n\r\nprocedure TJvIconList.InsertResource(Index: Integer; Instance: THandle; ResId: PChar);\r\nvar\r\n Ico: TIcon;\r\nbegin\r\n Ico := TIcon.Create;\r\n try\r\n Ico.Handle := LoadIcon(Instance, ResId);\r\n FList.Insert(Index, Ico);\r\n Ico.OnChange := IconChanged;\r\n except\r\n Ico.Free;\r\n raise;\r\n end;\r\n Changed;\r\nend;\r\n\r\nprocedure TJvIconList.Insert(Index: Integer; Icon: TIcon);\r\nvar\r\n Ico: TIcon;\r\nbegin\r\n Ico := TIcon.Create;\r\n try\r\n Ico.Assign(Icon);\r\n FList.Insert(Index, Ico);\r\n Ico.OnChange := IconChanged;\r\n except\r\n Ico.Free;\r\n raise;\r\n end;\r\n Changed;\r\nend;\r\n\r\nprocedure TJvIconList.LoadResource(Instance: THandle; const ResIds: array of PChar);\r\nvar\r\n I: Integer;\r\nbegin\r\n BeginUpdate;\r\n try\r\n for I := Low(ResIds) to High(ResIds) do\r\n AddResource(Instance, ResIds[I]);\r\n finally\r\n EndUpdate;\r\n end;\r\nend;\r\n\r\nprocedure TJvIconList.Move(CurIndex, NewIndex: Integer);\r\nbegin\r\n FList.Move(CurIndex, NewIndex);\r\n Changed;\r\nend;\r\n\r\nprocedure TJvIconList.SetUpdateState(Updating: Boolean);\r\nbegin\r\n if not Updating then\r\n Changed;\r\nend;\r\n\r\nprocedure TJvIconList.LoadFromStream(Stream: TStream);\r\nbegin\r\n ReadData(Stream);\r\nend;\r\n\r\nprocedure TJvIconList.SaveToStream(Stream: TStream);\r\nbegin\r\n WriteData(Stream);\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvId3v1.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvID3v1.PAS, released on 2001-02-28.\r\n\r\nThe Initial Developer of the Original Code is Sbastien Buysse [sbuysse att buypin dott com]\r\nPortions created by Sbastien Buysse are Copyright (C) 2001 Sbastien Buysse.\r\nAll Rights Reserved.\r\n\r\nContributor(s): Michael Beck [mbeck att bigfoot dott com].\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvId3v1.pas 13104 2011-09-07 06:50:43Z obones $\r\n\r\nunit JvId3v1;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n SysUtils, Classes,\r\n JvComponentBase;\r\n\r\ntype\r\n TID3v1Tag = packed record\r\n Identifier: array [0..2] of AnsiChar;\r\n SongName: array [0..29] of AnsiChar;\r\n Artist: array [0..29] of AnsiChar;\r\n Album: array [0..29] of AnsiChar;\r\n Year: array [0..3] of AnsiChar;\r\n Comment: array [0..29] of AnsiChar;\r\n Genre: Byte;\r\n end;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64 or pidOSX32)]\r\n {$ENDIF RTL230_UP}\r\n TJvID3v1 = class(TJvComponent)\r\n private\r\n FSongName: AnsiString;\r\n FArtist: AnsiString;\r\n FAlbum: AnsiString;\r\n FComment: AnsiString;\r\n FYear: AnsiString;\r\n FGenre: Byte;\r\n FFileName: TFileName;\r\n FActive: Boolean;\r\n FAlbumTrack: Byte;\r\n FStreamedActive: Boolean;\r\n FHasTag: Boolean;\r\n FNeedUpdateHasTag: Boolean;\r\n function GetGenreAsString: string;\r\n function GetHasTag: Boolean;\r\n procedure Reset;\r\n procedure SetActive(const Value: Boolean);\r\n procedure SetFileName(const Value: TFileName);\r\n procedure SetGenreAsString(const Value: string);\r\n protected\r\n procedure CheckActive;\r\n procedure DoOpen; virtual;\r\n procedure DoClose; virtual;\r\n function ReadTag: Boolean;\r\n procedure Loaded; override;\r\n public\r\n procedure Refresh;\r\n procedure Open;\r\n procedure Close;\r\n function Commit: Boolean;\r\n procedure Erase;\r\n property HasTag: Boolean read GetHasTag;\r\n published\r\n property Active: Boolean read FActive write SetActive;\r\n property FileName: TFileName read FFileName write SetFileName;\r\n { Do not store dummies }\r\n property SongName: AnsiString read FSongName write FSongName stored False;\r\n property Artist: AnsiString read FArtist write FArtist stored False;\r\n property Album: AnsiString read FAlbum write FAlbum stored False;\r\n property Year: AnsiString read FYear write FYear stored False;\r\n property Comment: AnsiString read FComment write FComment stored False;\r\n property Genre: Byte read FGenre write FGenre stored False;\r\n property GenreAsString: string read GetGenreAsString write SetGenreAsString stored False;\r\n property AlbumTrack: Byte read FAlbumTrack write FAlbumTrack stored False;\r\n end;\r\n\r\nfunction HasID3v1Tag(const AFileName: string): Boolean;\r\nfunction ReadID3v1Tag(const AFileName: string; var ATag: TID3v1Tag): Boolean;\r\nprocedure RemoveID3v1Tag(const AFileName: string);\r\nfunction WriteID3v1Tag(const AFileName: string; const ATag: TID3v1Tag): Boolean;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvId3v1.pas $';\r\n Revision: '$Revision: 13104 $';\r\n Date: '$Date: 2011-09-07 08:50:43 +0200 (mer. 07 sept. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n Math,\r\n JvId3v2Types, JvTypes, JvResources;\r\n\r\nconst\r\n CID3v1Tag: array [0..2] of AnsiChar = AnsiString('TAG'); { do not change case }\r\n\r\n CTagSize = 128;\r\n CTagIDSize = 3;\r\n\r\n//=== Global procedures ======================================================\r\n\r\nfunction HasID3v1Tag(const AFileName: string): Boolean;\r\nvar\r\n TagID: array [0..CTagIDSize - 1] of AnsiChar;\r\nbegin\r\n try\r\n with TFileStream.Create(AFileName, fmOpenRead or fmShareDenyWrite) do\r\n try\r\n Result := Size >= CTagSize;\r\n if not Result then\r\n Exit;\r\n\r\n Seek(-CTagSize, soFromEnd);\r\n Result := (Read(TagID, CTagIDSize) = CTagIDSize) and (TagID = CID3v1Tag);\r\n finally\r\n Free;\r\n end;\r\n except\r\n Result := False;\r\n end;\r\nend;\r\n\r\nfunction ReadID3v1Tag(const AFileName: string; var ATag: TID3v1Tag): Boolean;\r\nbegin\r\n try\r\n with TFileStream.Create(AFileName, fmOpenRead or fmShareDenyWrite) do\r\n try\r\n Seek(-CTagSize, soFromEnd);\r\n Result := (Read(ATag, CTagSize) = CTagSize) and (ATag.Identifier = CID3v1Tag);\r\n finally\r\n Free;\r\n end;\r\n except\r\n Result := False;\r\n end;\r\nend;\r\n\r\nprocedure RemoveID3v1Tag(const AFileName: string);\r\nvar\r\n TagID: array [0..CTagIDSize - 1] of AnsiChar;\r\nbegin\r\n with TFileStream.Create(AFileName, fmOpenReadWrite or fmShareDenyWrite) do\r\n try\r\n Seek(-CTagSize, soFromEnd);\r\n\r\n if (Read(TagID, CTagIDSize) = CTagIDSize) and (TagID = CID3v1Tag) then\r\n Size := Size - CTagSize;\r\n finally\r\n Free;\r\n end;\r\nend;\r\n\r\nfunction WriteID3v1Tag(const AFileName: string; const ATag: TID3v1Tag): Boolean;\r\nvar\r\n TagID: array [0..CTagIDSize - 1] of AnsiChar;\r\nbegin\r\n try\r\n Result := FileExists(AFileName);\r\n if not Result then\r\n Exit;\r\n\r\n with TFileStream.Create(AFileName, fmOpenReadWrite or fmShareExclusive) do\r\n try\r\n // Remove old Tag ?\r\n if Size >= CTagSize then\r\n begin\r\n Seek(-CTagSize, soFromEnd);\r\n if (Read(TagID, CTagIDSize) = CTagIDSize) and (TagID = CID3v1Tag) then\r\n Seek(-CTagIDSize, soFromCurrent)\r\n else\r\n Seek(0, soFromEnd);\r\n end\r\n else\r\n Seek(0, soFromEnd);\r\n\r\n // Write it\r\n Result := Write(ATag, CTagSize) = CTagSize;\r\n finally\r\n Free;\r\n end;\r\n except\r\n Result := False;\r\n end;\r\nend;\r\n\r\n//=== Local procedures =======================================================\r\n\r\nprocedure AnsiStringToPAnsiChar(const Source: AnsiString; Dest: PAnsiChar; const MaxLength: Integer);\r\nbegin\r\n Move(PAnsiChar(Source)^, Dest^, Min(MaxLength, Length(Source)));\r\nend;\r\n\r\nfunction PAnsiCharToAnsiString(P: PAnsiChar; MaxLength: Integer): AnsiString;\r\nvar\r\n Q: PAnsiChar;\r\nbegin\r\n Q := P;\r\n while (P - Q < MaxLength) and (P^ <> #0) do\r\n Inc(P);\r\n\r\n { [Q..P) is valid }\r\n SetString(Result, Q, P - Q);\r\nend;\r\n\r\n//=== { TJvID3v1 } ===========================================================\r\n\r\nprocedure TJvID3v1.Loaded;\r\nbegin\r\n inherited Loaded;\r\n\r\n FNeedUpdateHasTag := True;\r\n if FStreamedActive then\r\n SetActive(True);\r\nend;\r\n\r\nprocedure TJvID3v1.CheckActive;\r\nbegin\r\n if not FActive then\r\n raise EJVCLException.CreateRes(@RsENotActive);\r\nend;\r\n\r\nprocedure TJvID3v1.Close;\r\nbegin\r\n SetActive(False);\r\nend;\r\n\r\nfunction TJvID3v1.Commit: Boolean;\r\nvar\r\n Tag: TID3v1Tag;\r\nbegin\r\n CheckActive;\r\n\r\n FNeedUpdateHasTag := True;\r\n\r\n FillChar(Tag, CTagSize, #0);\r\n\r\n // Set new Tag\r\n Move(CID3v1Tag[0], Tag.Identifier[0], 3);\r\n AnsiStringToPAnsiChar(SongName, @Tag.SongName, 30);\r\n AnsiStringToPAnsiChar(Artist, @Tag.Artist, 30);\r\n AnsiStringToPAnsiChar(Album, @Tag.Album, 30);\r\n AnsiStringToPAnsiChar(Year, @Tag.Year, 4);\r\n AnsiStringToPAnsiChar(Comment, @Tag.Comment, 30);\r\n Tag.Genre := FGenre;\r\n if Tag.Comment[28] = #0 then\r\n Tag.Comment[29] := AnsiChar(FAlbumTrack);\r\n\r\n Result := WriteID3v1Tag(FileName, Tag);\r\nend;\r\n\r\nprocedure TJvID3v1.DoClose;\r\nbegin\r\n Reset;\r\nend;\r\n\r\nprocedure TJvID3v1.DoOpen;\r\nbegin\r\n ReadTag;\r\nend;\r\n\r\nprocedure TJvID3v1.Erase;\r\nvar\r\n SavedActive: Boolean;\r\nbegin\r\n FNeedUpdateHasTag := True;\r\n\r\n SavedActive := Active;\r\n Close;\r\n\r\n try\r\n RemoveID3v1Tag(FileName);\r\n finally\r\n if SavedActive then\r\n Open;\r\n end;\r\nend;\r\n\r\nfunction TJvID3v1.GetGenreAsString: string;\r\nbegin\r\n Result := ID3_IDToGenre(Genre);\r\nend;\r\n\r\nfunction TJvID3v1.GetHasTag: Boolean;\r\nbegin\r\n if FNeedUpdateHasTag then\r\n begin\r\n FNeedUpdateHasTag := False;\r\n FHasTag := HasID3v1Tag(FileName);\r\n end;\r\n\r\n Result := FHasTag;\r\nend;\r\n\r\nprocedure TJvID3v1.Open;\r\nbegin\r\n SetActive(True);\r\nend;\r\n\r\nfunction TJvID3v1.ReadTag: Boolean;\r\nvar\r\n Tag: TID3v1Tag;\r\nbegin\r\n CheckActive;\r\n\r\n Result := ReadID3v1Tag(FileName, Tag);\r\n\r\n FNeedUpdateHasTag := False;\r\n FHasTag := Result;\r\n\r\n if Result then\r\n begin\r\n FSongName := PAnsiCharToAnsiString(@Tag.SongName, 30);\r\n FArtist := PAnsiCharToAnsiString(@Tag.Artist, 30);\r\n FAlbum := PAnsiCharToAnsiString(@Tag.Album, 30);\r\n FYear := PAnsiCharToAnsiString(@Tag.Year, 4);\r\n FComment := PAnsiCharToAnsiString(@Tag.Comment, 30);\r\n // (p3) missing genre added\r\n FGenre := Tag.Genre;\r\n if Tag.Comment[28] = #0 then\r\n FAlbumTrack := Byte(Tag.Comment[29])\r\n else\r\n FAlbumTrack := 0;\r\n end\r\n else\r\n Reset;\r\nend;\r\n\r\nprocedure TJvID3v1.Refresh;\r\nbegin\r\n CheckActive;\r\n ReadTag;\r\nend;\r\n\r\nprocedure TJvID3v1.Reset;\r\nbegin\r\n FSongName := '';\r\n FArtist := '';\r\n FAlbum := '';\r\n FYear := '';\r\n FComment := '';\r\n FGenre := 255;\r\nend;\r\n\r\nprocedure TJvID3v1.SetActive(const Value: Boolean);\r\nbegin\r\n { Based on TCustomConnection.SetConnected }\r\n if (csReading in ComponentState) and Value then\r\n FStreamedActive := True\r\n else\r\n begin\r\n if Value = FActive then\r\n Exit;\r\n FActive := Value;\r\n if FActive then\r\n DoOpen\r\n else\r\n DoClose;\r\n end;\r\nend;\r\n\r\nprocedure TJvID3v1.SetFileName(const Value: TFileName);\r\nvar\r\n SavedActive: Boolean;\r\nbegin\r\n if Value <> FFileName then\r\n begin\r\n SavedActive := Active;\r\n\r\n Close;\r\n\r\n FNeedUpdateHasTag := True;\r\n FFileName := Value;\r\n\r\n if SavedActive then\r\n Open;\r\n end;\r\nend;\r\n\r\nprocedure TJvID3v1.SetGenreAsString(const Value: string);\r\nbegin\r\n Genre := ID3_GenreToID(Value);\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvId3v2.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvID3v2.PAS, released on 2001-02-28.\r\n\r\nThe Initial Developer of the Original Code is Sbastien Buysse [sbuysse att buypin dott com]\r\nPortions created by Sbastien Buysse are Copyright (C) 2001 Sbastien Buysse.\r\nAll Rights Reserved.\r\n\r\nContributor(s): Michael Beck [mbeck att bigfoot dott com].\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvId3v2.pas 13104 2011-09-07 06:50:43Z obones $\r\n\r\nunit JvId3v2;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Classes, Graphics, Controls,\r\n {$IFNDEF COMPILER12_UP}\r\n JclUnicode,\r\n {$ENDIF ~COMPILER12_UP}\r\n JvId3v2Types, JvID3v2Base;\r\n\r\ntype\r\n TJvID3Persistent = class(TPersistent)\r\n private\r\n FController: TJvID3Controller;\r\n public\r\n constructor Create(AController: TJvID3Controller);\r\n end;\r\n\r\n TJvID3Text = class(TJvID3Persistent)\r\n private\r\n FDummyList: {$IFDEF COMPILER12_UP}TStrings{$ELSE}TWideStrings{$ENDIF COMPILER12_UP};\r\n function GetDateTime(const FrameID: Integer{TJvID3FrameID}): TDateTime;\r\n function GetList(const FrameID: Integer{TJvID3FrameID}): {$IFDEF COMPILER12_UP}TStrings{$ELSE}TWideStrings{$ENDIF COMPILER12_UP};\r\n function GetNumber(const FrameID: Integer{TJvID3FrameID}): Cardinal;\r\n function GetText(const FrameID: Integer{TJvID3FrameID}): WideString;\r\n procedure SetDateTime(const FrameID: Integer{TJvID3FrameID}; const Value: TDateTime);\r\n procedure SetList(const FrameID: Integer{TJvID3FrameID}; const Value: {$IFDEF COMPILER12_UP}TStrings{$ELSE}TWideStrings{$ENDIF COMPILER12_UP});\r\n procedure SetNumber(const FrameID: Integer{TJvID3FrameID}; const Value: Cardinal);\r\n procedure SetText(const FrameID: Integer{TJvID3FrameID}; const Value: WideString);\r\n function GetBPM: Cardinal;\r\n procedure SetBPM(const Value: Cardinal);\r\n public\r\n constructor Create(AController: TJvID3Controller);\r\n destructor Destroy; override;\r\n published\r\n { Do not store dummies }\r\n property Album: WideString index fiAlbum read GetText write SetText stored False;\r\n property AlbumSortOrder: WideString index fiAlbumSortOrder read GetText write SetText stored False;\r\n property Band: WideString index fiBand read GetText write SetText stored False;\r\n property BPM: Cardinal read GetBPM write SetBPM stored False;\r\n property BPMStr: WideString index fiBPM read GetText write SetText stored False;\r\n property Composer: {$IFDEF COMPILER12_UP}TStrings{$ELSE}TWideStrings{$ENDIF COMPILER12_UP} index fiComposer read GetList write SetList stored False;\r\n property Conductor: WideString index fiConductor read GetText write SetText stored False;\r\n property ContentType: {$IFDEF COMPILER12_UP}TStrings{$ELSE}TWideStrings{$ENDIF COMPILER12_UP} index fiContentType read GetList write SetList stored False;\r\n property ContentGroup: WideString index fiContentGroup read GetText write SetText stored False;\r\n property Copyright: WideString index fiCopyright read GetText write SetText stored False;\r\n property Date: WideString index fiDate read GetText write SetText stored False;\r\n property EncodedBy: WideString index fiEncodedBy read GetText write SetText stored False;\r\n property EncoderSettings: WideString index fiEncoderSettings read GetText write SetText stored False;\r\n property EncodingTime: TDateTime index fiEncodingTime read GetDateTime write SetDateTime stored False;\r\n property FileOwner: WideString index fiFileOwner read GetText write SetText stored False;\r\n property FileType: WideString index fiFileType read GetText write SetText stored False;\r\n property InitialKey: WideString index fiInitialKey read GetText write SetText stored False;\r\n property ISRC: WideString index fiISRC read GetText write SetText stored False;\r\n property Language: {$IFDEF COMPILER12_UP}TStrings{$ELSE}TWideStrings{$ENDIF COMPILER12_UP} index fiLanguage read GetList write SetList stored False;\r\n property LeadArtist: {$IFDEF COMPILER12_UP}TStrings{$ELSE}TWideStrings{$ENDIF COMPILER12_UP} index fiLeadArtist read GetList write SetList stored False;\r\n property Lyricist: {$IFDEF COMPILER12_UP}TStrings{$ELSE}TWideStrings{$ENDIF COMPILER12_UP} index fiLyricist read GetList write SetList stored False;\r\n property MediaType: WideString index fiMediaType read GetText write SetText stored False;\r\n property MixArtist: WideString index fiMixArtist read GetText write SetText stored False;\r\n property Mood: WideString index fiMood read GetText write SetText stored False;\r\n property NetRadioOwner: WideString index fiNetRadioOwner read GetText write SetText stored False;\r\n property NetRadioStation: WideString index fiNetRadioStation read GetText write SetText stored False;\r\n property OrigAlbum: WideString index fiOrigAlbum read GetText write SetText stored False;\r\n property OrigArtist: {$IFDEF COMPILER12_UP}TStrings{$ELSE}TWideStrings{$ENDIF COMPILER12_UP} index fiOrigArtist read GetList write SetList stored False;\r\n property OrigFileName: WideString index fiOrigFileName read GetText write SetText stored False;\r\n property OrigLyricist: {$IFDEF COMPILER12_UP}TStrings{$ELSE}TWideStrings{$ENDIF COMPILER12_UP} index fiOrigLyricist read GetList write SetList stored False;\r\n property OrigReleaseTime: TDateTime index fiOrigReleaseTime read GetDateTime write SetDateTime stored False;\r\n property OrigYear: Cardinal index fiOrigYear read GetNumber write SetNumber stored False;\r\n property PartInSet: WideString index fiPartInSet read GetText write SetText stored False;\r\n property PerformerSortOrder: WideString index fiPerformerSortOrder read GetText write SetText stored False;\r\n property PlaylistDelay: Cardinal index fiPlaylistDelay read GetNumber write SetNumber stored False;\r\n property ProducedNotice: WideString index fiProducedNotice read GetText write SetText stored False;\r\n property Publisher: WideString index fiPublisher read GetText write SetText stored False;\r\n property RecordingDates: WideString index fiRecordingDates read GetText write SetText stored False;\r\n property RecordingTime: TDateTime index fiRecordingTime read GetDateTime write SetDateTime stored False;\r\n property ReleaseTime: TDateTime index fiReleaseTime read GetDateTime write SetDateTime stored False;\r\n property SetSubTitle: WideString index fiSetSubTitle read GetText write SetText stored False;\r\n property Size: Cardinal index fiSize read GetNumber write SetNumber stored False;\r\n property SongLen: Cardinal index fiSongLen read GetNumber write SetNumber stored False;\r\n property SubTitle: WideString index fiSubTitle read GetText write SetText stored False;\r\n property TaggingTime: TDateTime index fiTaggingTime read GetDateTime write SetDateTime stored False;\r\n property Time: WideString index fiTime read GetText write SetText stored False;\r\n property Title: WideString index fiTitle read GetText write SetText stored False;\r\n property TitleSortOrder: WideString index fiTitleSortOrder read GetText write SetText stored False;\r\n property TrackNum: WideString index fiTrackNum read GetText write SetText stored False;\r\n property Year: Cardinal index fiYear read GetNumber write SetNumber stored False;\r\n end;\r\n\r\n TJvID3Web = class(TJvID3Persistent)\r\n private\r\n function GetText(const FrameID: Integer{TJvID3FrameID}): AnsiString;\r\n procedure SetText(const FrameID: Integer{TJvID3FrameID}; const Value: AnsiString);\r\n published\r\n { Do not store dummies }\r\n property Artist: AnsiString index fiWWWArtist read GetText write SetText stored False;\r\n property AudioFile: AnsiString index fiWWWAudioFile read GetText write SetText stored False;\r\n property AudioSource: AnsiString index fiWWWAudioSource read GetText write SetText stored False;\r\n property CommercialInfo: AnsiString index fiWWWCommercialInfo read GetText write SetText stored False;\r\n property Copyright: AnsiString index fiWWWCopyright read GetText write SetText stored False;\r\n property Payment: AnsiString index fiWWWPayment read GetText write SetText stored False;\r\n property Publisher: AnsiString index fiWWWPublisher read GetText write SetText stored False;\r\n property RadioPage: AnsiString index fiWWWRadioPage read GetText write SetText stored False;\r\n end;\r\n\r\n TJvID3UDText = class(TJvID3Persistent)\r\n private\r\n FDummyI: Integer;\r\n FItemIndex: Integer;\r\n function GetDescription: WideString;\r\n function GetItemCount: Integer;\r\n function GetItemIndex: Integer;\r\n function GetValue: WideString;\r\n procedure SetDescription(const Value: WideString);\r\n procedure SetItemIndex(const Value: Integer);\r\n procedure SetValue(const Value: WideString);\r\n public\r\n procedure Add(const ADescription, AValue: WideString);\r\n published\r\n property ItemIndex: Integer read GetItemIndex write SetItemIndex;\r\n { Do not store dummies }\r\n property Description: WideString read GetDescription write SetDescription stored False;\r\n property Value: WideString read GetValue write SetValue stored False;\r\n property ItemCount: Integer read GetItemCount write FDummyI stored False;\r\n end;\r\n\r\n TJvID3UDUrl = class(TJvID3Persistent)\r\n private\r\n FItemIndex: Integer;\r\n FDummyI: Integer;\r\n function GetDescription: WideString;\r\n function GetItemCount: Integer;\r\n function GetItemIndex: Integer;\r\n function GetURL: AnsiString;\r\n procedure SetDescription(const Value: WideString);\r\n procedure SetItemIndex(const Value: Integer);\r\n procedure SetURL(const Value: AnsiString);\r\n public\r\n procedure Add(const ADescription: WideString; const AURL: AnsiString);\r\n published\r\n property ItemIndex: Integer read GetItemIndex write SetItemIndex;\r\n { Do not store dummies }\r\n property Description: WideString read GetDescription write SetDescription stored False;\r\n property URL: AnsiString read GetURL write SetURL stored False;\r\n property ItemCount: Integer read GetItemCount write FDummyI stored False;\r\n end;\r\n\r\n TJvID3Pictures = class(TJvID3Persistent)\r\n private\r\n FPictures: array[TJvID3PictureType] of TPicture;\r\n FUpdating: Boolean;\r\n function GetPicture(const AType: Integer{TJvID3PictureType}): TPicture;\r\n procedure SetPicture(const AType: Integer{TJvID3PictureType}; const Value: TPicture);\r\n procedure PictureChanged(Sender: TObject);\r\n procedure PictureToFrame(const AType: TJvID3PictureType);\r\n procedure RetrievePictures;\r\n procedure RemovePictures;\r\n public\r\n constructor Create(AController: TJvID3Controller); virtual;\r\n destructor Destroy; override;\r\n published\r\n property Other: TPicture index ptOther read GetPicture write SetPicture stored False;\r\n property FileIcon: TPicture index ptFileIcon read GetPicture write SetPicture stored False;\r\n property OtherFileIcon: TPicture index ptOtherFileIcon read GetPicture write SetPicture stored False;\r\n property CoverFront: TPicture index ptCoverFront read GetPicture write SetPicture stored False;\r\n property CoverBack: TPicture index ptCoverBack read GetPicture write SetPicture stored False;\r\n property LeafletPage: TPicture index ptLeafletPage read GetPicture write SetPicture stored False;\r\n property Media: TPicture index ptMedia read GetPicture write SetPicture stored False;\r\n property LeadArtist: TPicture index ptLeadArtist read GetPicture write SetPicture stored False;\r\n property Artist: TPicture index ptArtist read GetPicture write SetPicture stored False;\r\n property Conductor: TPicture index ptConductor read GetPicture write SetPicture stored False;\r\n property Band: TPicture index ptBand read GetPicture write SetPicture stored False;\r\n property Composer: TPicture index ptComposer read GetPicture write SetPicture stored False;\r\n property Lyricist: TPicture index ptLyricist read GetPicture write SetPicture stored False;\r\n property RecordingLocation: TPicture index ptRecordingLocation read GetPicture write SetPicture stored False;\r\n property DuringRecording: TPicture index ptDuringRecording read GetPicture write SetPicture stored False;\r\n property DuringPerformance: TPicture index ptDuringPerformance read GetPicture write SetPicture stored False;\r\n property MovieVideoScreenCapture: TPicture index ptMovieVideoScreenCapture read GetPicture write SetPicture stored\r\n False;\r\n property BrightColouredFish: TPicture index ptBrightColouredFish read GetPicture write SetPicture stored False;\r\n property Illustration: TPicture index ptIllustration read GetPicture write SetPicture stored False;\r\n property BandLogotype: TPicture index ptBandLogotype read GetPicture write SetPicture stored False;\r\n property PublisherLogotype: TPicture index ptPublisherLogotype read GetPicture write SetPicture stored False;\r\n end;\r\n\r\n TJvID3PicturesDesc = class(TJvID3Persistent)\r\n private\r\n function GetText(const AType: Integer{TJvID3PictureType}): WideString;\r\n procedure SetText(const AType: Integer{TJvID3PictureType}; const Value: WideString);\r\n published\r\n property Other: WideString index ptOther read GetText write SetText stored False;\r\n property FileIcon: WideString index ptFileIcon read GetText write SetText stored False;\r\n property OtherFileIcon: WideString index ptOtherFileIcon read GetText write SetText stored False;\r\n property CoverFront: WideString index ptCoverFront read GetText write SetText stored False;\r\n property CoverBack: WideString index ptCoverBack read GetText write SetText stored False;\r\n property LeafletPage: WideString index ptLeafletPage read GetText write SetText stored False;\r\n property Media: WideString index ptMedia read GetText write SetText stored False;\r\n property LeadArtist: WideString index ptLeadArtist read GetText write SetText stored False;\r\n property Artist: WideString index ptArtist read GetText write SetText stored False;\r\n property Conductor: WideString index ptConductor read GetText write SetText stored False;\r\n property Band: WideString index ptBand read GetText write SetText stored False;\r\n property Composer: WideString index ptComposer read GetText write SetText stored False;\r\n property Lyricist: WideString index ptLyricist read GetText write SetText stored False;\r\n property RecordingLocation: WideString index ptRecordingLocation read GetText write SetText stored False;\r\n property DuringRecording: WideString index ptDuringRecording read GetText write SetText stored False;\r\n property DuringPerformance: WideString index ptDuringPerformance read GetText write SetText stored False;\r\n property MovieVideoScreenCapture: WideString index ptMovieVideoScreenCapture read GetText write SetText stored False;\r\n property BrightColouredFish: WideString index ptBrightColouredFish read GetText write SetText stored False;\r\n property Illustration: WideString index ptIllustration read GetText write SetText stored False;\r\n property BandLogotype: WideString index ptBandLogotype read GetText write SetText stored False;\r\n property PublisherLogotype: WideString index ptPublisherLogotype read GetText write SetText stored False;\r\n end;\r\n\r\n TJvID3Images = class(TJvID3Persistent)\r\n private\r\n FPictures: TJvID3Pictures;\r\n FInfos: TJvID3PicturesDesc;\r\n public\r\n constructor Create(AController: TJvID3Controller);\r\n destructor Destroy; override;\r\n published\r\n property Pictures: TJvID3Pictures read FPictures;\r\n property Infos: TJvID3PicturesDesc read FInfos;\r\n end;\r\n\r\n TJvID3Ipl = class(TJvID3Persistent)\r\n private\r\n FDummyI: Integer;\r\n FItemIndex: Integer;\r\n function GetItemCount: Integer;\r\n function GetJob: WideString;\r\n function GetPerson: WideString;\r\n procedure SetItemIndex(const Value: Integer);\r\n procedure SetJob(const Value: WideString);\r\n procedure SetPerson(const Value: WideString);\r\n published\r\n property ItemIndex: Integer read FItemIndex write SetItemIndex;\r\n { Do not store dummies }\r\n property Job: WideString read GetJob write SetJob stored False;\r\n property Person: WideString read GetPerson write SetPerson stored False;\r\n property ItemCount: Integer read GetItemCount write FDummyI stored False;\r\n end;\r\n\r\n TJvID3Owner = class(TJvID3Persistent)\r\n private\r\n function GetDatePurchased: TDateTime;\r\n function GetPrice: AnsiString;\r\n function GetSeller: WideString;\r\n procedure SetDatePurchased(const Value: TDateTime);\r\n procedure SetPrice(const Value: AnsiString);\r\n procedure SetSeller(const Value: WideString);\r\n published\r\n { Do not store dummies }\r\n property Price: AnsiString read GetPrice write SetPrice stored False;\r\n property DatePurchased: TDateTime read GetDatePurchased write SetDatePurchased stored False;\r\n property Seller: WideString read GetSeller write SetSeller stored False;\r\n end;\r\n\r\n TJvID3Popularimeter = class(TJvID3Persistent)\r\n private\r\n function GetCounter: Cardinal;\r\n function GetRating: Byte;\r\n function GetEMailAddress: AnsiString;\r\n procedure SetCounter(const Value: Cardinal);\r\n procedure SetRating(const Value: Byte);\r\n procedure SetEMailAddress(const Value: AnsiString);\r\n published\r\n { Do not store dummies }\r\n property EMailAddress: AnsiString read GetEMailAddress write SetEMailAddress stored False;\r\n property Rating: Byte read GetRating write SetRating stored False;\r\n property Counter: Cardinal read GetCounter write SetCounter stored False;\r\n end;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64 or pidOSX32)]\r\n {$ENDIF RTL230_UP}\r\n TJvID3v2 = class(TJvID3Controller)\r\n private\r\n FID3Text: TJvID3Text;\r\n FWeb: TJvID3Web;\r\n FUserDefinedText: TJvID3UDText;\r\n FUserDefinedWeb: TJvID3UDUrl;\r\n FInvolvedPeople: TJvID3Ipl;\r\n FImages: TJvID3Images;\r\n FOwner: TJvID3Owner;\r\n FPopularimeter: TJvID3Popularimeter;\r\n FProcessPictures: Boolean;\r\n function GetPlayCounter: Cardinal;\r\n procedure SetPlayCounter(const Value: Cardinal);\r\n protected\r\n procedure ActiveChanged(Sender: TObject; Activated: Boolean);\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n\r\n property Header;\r\n property ExtendedHeader;\r\n published\r\n { Do not store dummies }\r\n property Texts: TJvID3Text read FID3Text;\r\n property ProcessPictures: Boolean read FProcessPictures write FProcessPictures stored True;\r\n property UserDefinedText: TJvID3UDText read FUserDefinedText;\r\n property Web: TJvID3Web read FWeb;\r\n property UserDefinedWeb: TJvID3UDUrl read FUserDefinedWeb;\r\n property InvolvedPeople: TJvID3Ipl read FInvolvedPeople;\r\n property Images: TJvID3Images read FImages;\r\n property PlayCounter: Cardinal read GetPlayCounter write SetPlayCounter stored False;\r\n property Owner: TJvID3Owner read FOwner;\r\n property Popularimeter: TJvID3Popularimeter read FPopularimeter;\r\n property Version;\r\n property FileInfo;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvId3v2.pas $';\r\n Revision: '$Revision: 13104 $';\r\n Date: '$Date: 2011-09-07 08:50:43 +0200 (mer. 07 sept. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n SysUtils, Math,\r\n JvResources, JclSysUtils;\r\n\r\n//=== Local procedures =======================================================\r\n\r\nfunction ExtractMIMETypeFromClassName(AClassName: string): AnsiString;\r\nbegin\r\n AClassName := AnsiLowerCase(AClassName);\r\n\r\n if (Pos('jpg', AClassName) > 0) or (Pos('jpeg', AClassName) > 0) then\r\n Result := 'image/jpeg'\r\n else\r\n if (Pos('bmp', AClassName) > 0) or (Pos('bitmap', AClassName) > 0) then\r\n Result := 'image/bitmap'\r\n else\r\n if (Pos('gif', AClassName) > 0) then\r\n Result := 'image/gif'\r\n else\r\n Result := 'image/';\r\nend;\r\n\r\n//=== { TJvID3Images } =======================================================\r\n\r\nconstructor TJvID3Images.Create(AController: TJvID3Controller);\r\nbegin\r\n inherited Create(AController);\r\n FPictures := TJvID3Pictures.Create(AController);\r\n FInfos := TJvID3PicturesDesc.Create(AController);\r\nend;\r\n\r\ndestructor TJvID3Images.Destroy;\r\nbegin\r\n FPictures.Free;\r\n FInfos.Free;\r\n inherited Destroy;\r\nend;\r\n\r\n//=== { TJvID3Ipl } ==========================================================\r\n\r\nfunction TJvID3Ipl.GetItemCount: Integer;\r\nvar\r\n Frame: TJvID3DoubleListFrame;\r\nbegin\r\n if not FController.Active then\r\n Result := 0\r\n else\r\n begin\r\n Frame := TJvID3DoubleListFrame.Find(FController, fiInvolvedPeople);\r\n if Assigned(Frame) then\r\n Result := Frame.List.Count\r\n else\r\n Result := 0;\r\n end;\r\nend;\r\n\r\nfunction TJvID3Ipl.GetJob: WideString;\r\nvar\r\n Frame: TJvID3DoubleListFrame;\r\nbegin\r\n if ItemIndex < 0 then\r\n Result := ''\r\n else\r\n begin\r\n Frame := TJvID3DoubleListFrame.Find(FController, fiInvolvedPeople);\r\n if Assigned(Frame) and (ItemIndex < Frame.List.Count) then\r\n Result := Frame.Values[ItemIndex]\r\n else\r\n Result := '';\r\n end;\r\nend;\r\n\r\nfunction TJvID3Ipl.GetPerson: WideString;\r\nvar\r\n Frame: TJvID3DoubleListFrame;\r\nbegin\r\n if ItemIndex < 0 then\r\n Result := ''\r\n else\r\n begin\r\n Frame := TJvID3DoubleListFrame.Find(FController, fiInvolvedPeople);\r\n if Assigned(Frame) and (ItemIndex < Frame.List.Count) then\r\n Result := Frame.List.Names[ItemIndex]\r\n else\r\n Result := '';\r\n end;\r\nend;\r\n\r\nprocedure TJvID3Ipl.SetItemIndex(const Value: Integer);\r\nbegin\r\n if Value <> FItemIndex then\r\n begin\r\n FItemIndex := Min(Value, ItemCount - 1);\r\n end;\r\nend;\r\n\r\nprocedure TJvID3Ipl.SetJob(const Value: WideString);\r\nvar\r\n LPerson: WideString;\r\n Frame: TJvID3DoubleListFrame;\r\nbegin\r\n if FController.Active and (ItemIndex >= 0) then\r\n begin\r\n Frame := TJvID3DoubleListFrame.FindOrCreate(FController, fiInvolvedPeople);\r\n if (0 <= ItemIndex) and (ItemIndex < Frame.List.Count) then\r\n begin\r\n LPerson := Frame.List.Names[ItemIndex];\r\n Frame.List[ItemIndex] := Format('%s=%s', [LPerson, Value]);\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvID3Ipl.SetPerson(const Value: WideString);\r\nvar\r\n LJob: WideString;\r\n Frame: TJvID3DoubleListFrame;\r\nbegin\r\n if FController.Active and (ItemIndex >= 0) then\r\n begin\r\n Frame := TJvID3DoubleListFrame.FindOrCreate(FController, fiInvolvedPeople);\r\n if (0 <= ItemIndex) and (ItemIndex < Frame.List.Count) then\r\n begin\r\n LJob := Frame.Values[ItemIndex];\r\n Frame.List[ItemIndex] := Format('%s=%s', [Value, LJob]);\r\n end;\r\n end;\r\nend;\r\n\r\n//=== { TJvID3Owner } ========================================================\r\n\r\nfunction TJvID3Owner.GetDatePurchased: TDateTime;\r\nvar\r\n Frame: TJvID3OwnershipFrame;\r\nbegin\r\n Frame := TJvID3OwnershipFrame.Find(FController);\r\n if Assigned(Frame) then\r\n Result := Frame.DateOfPurch\r\n else\r\n Result := 0;\r\nend;\r\n\r\nfunction TJvID3Owner.GetPrice: AnsiString;\r\nvar\r\n Frame: TJvID3OwnershipFrame;\r\nbegin\r\n Frame := TJvID3OwnershipFrame.Find(FController);\r\n if Assigned(Frame) then\r\n Result := Frame.PricePayed\r\n else\r\n Result := '';\r\nend;\r\n\r\nfunction TJvID3Owner.GetSeller: WideString;\r\nvar\r\n Frame: TJvID3OwnershipFrame;\r\nbegin\r\n Frame := TJvID3OwnershipFrame.Find(FController);\r\n if Assigned(Frame) then\r\n Result := Frame.Seller\r\n else\r\n Result := '';\r\nend;\r\n\r\nprocedure TJvID3Owner.SetDatePurchased(const Value: TDateTime);\r\nbegin\r\n if FController.Active then\r\n TJvID3OwnershipFrame.FindOrCreate(FController).DateOfPurch := Value;\r\nend;\r\n\r\nprocedure TJvID3Owner.SetPrice(const Value: AnsiString);\r\nbegin\r\n if FController.Active then\r\n TJvID3OwnershipFrame.FindOrCreate(FController).PricePayed := Value;\r\nend;\r\n\r\nprocedure TJvID3Owner.SetSeller(const Value: WideString);\r\nbegin\r\n if FController.Active then\r\n TJvID3OwnershipFrame.FindOrCreate(FController).Seller := Value;\r\nend;\r\n\r\n//=== { TJvID3Persistent } ===================================================\r\n\r\nconstructor TJvID3Persistent.Create(AController: TJvID3Controller);\r\nbegin\r\n inherited Create;\r\n FController := AController;\r\nend;\r\n\r\n//=== { TJvID3Pictures } =====================================================\r\n\r\nconstructor TJvID3Pictures.Create(AController: TJvID3Controller);\r\nvar\r\n Index: TJvID3PictureType;\r\nbegin\r\n inherited Create(AController);\r\n\r\n for Index := Low(TJvID3PictureType) to High(TJvID3PictureType) do\r\n begin\r\n FPictures[Index] := TPicture.Create;\r\n FPictures[Index].OnChange := PictureChanged;\r\n end;\r\nend;\r\n\r\ndestructor TJvID3Pictures.Destroy;\r\nvar\r\n Index: TJvID3PictureType;\r\nbegin\r\n for Index := Low(TJvID3PictureType) to High(TJvID3PictureType) do\r\n FPictures[Index].Free;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJvID3Pictures.GetPicture(const AType: Integer{TJvID3PictureType}): TPicture;\r\nbegin\r\n Result := FPictures[TJvID3PictureType(AType)];\r\nend;\r\n\r\nprocedure TJvID3Pictures.PictureChanged(Sender: TObject);\r\nvar\r\n Index: TJvID3PictureType;\r\nbegin\r\n if FUpdating then\r\n Exit;\r\n\r\n for Index := Low(TJvID3PictureType) to High(TJvID3PictureType) do\r\n if FPictures[Index] = Sender then\r\n begin\r\n PictureToFrame(Index);\r\n Exit;\r\n end;\r\nend;\r\n\r\nprocedure TJvID3Pictures.PictureToFrame(const AType: TJvID3PictureType);\r\nvar\r\n Frame: TJvID3PictureFrame;\r\nbegin\r\n if not FController.Active then\r\n Exit;\r\n\r\n Frame := TJvID3PictureFrame.FindOrCreate(FController, AType);\r\n Frame.Assign(FPictures[AType]);\r\n\r\n { Borland has made it hard for us to determine the type of picture; let's\r\n just look at the Picture.Graphic classname :) This is no way a reliable\r\n method thus I don't recommend using TJvID3v2 for pictures }\r\n\r\n Frame.MIMEType := ExtractMIMETypeFromClassName(FPictures[AType].Graphic.ClassName);\r\nend;\r\n\r\nprocedure TJvID3Pictures.RemovePictures;\r\nvar\r\n Index: TJvID3PictureType;\r\nbegin\r\n FUpdating := True;\r\n try\r\n for Index := Low(TJvID3PictureType) to High(TJvID3PictureType) do\r\n FPictures[Index].Assign(nil);\r\n finally\r\n FUpdating := False;\r\n end;\r\nend;\r\n\r\nprocedure TJvID3Pictures.RetrievePictures;\r\nvar\r\n Frame: TJvID3PictureFrame;\r\n Index: TJvID3PictureType;\r\nbegin\r\n FUpdating := True;\r\n try\r\n for Index := Low(TJvID3PictureType) to High(TJvID3PictureType) do\r\n begin\r\n Frame := TJvID3PictureFrame.Find(FController, Index);\r\n FPictures[Index].Assign(Frame);\r\n end;\r\n finally\r\n FUpdating := False;\r\n end;\r\nend;\r\n\r\nprocedure TJvID3Pictures.SetPicture(const AType: Integer{TJvID3PictureType};\r\n const Value: TPicture);\r\nbegin\r\n FPictures[TJvID3PictureType(AType)].Assign(Value);\r\n //ChangePicture(AType);\r\nend;\r\n\r\n//=== { TJvID3PicturesDesc } =================================================\r\n\r\nfunction TJvID3PicturesDesc.GetText(const AType: Integer{TJvID3PictureType}): WideString;\r\nvar\r\n Frame: TJvID3PictureFrame;\r\nbegin\r\n Frame := TJvID3PictureFrame.Find(FController, TJvID3PictureType(AType));\r\n if Assigned(Frame) then\r\n Result := Frame.Description\r\n else\r\n Result := '';\r\nend;\r\n\r\nprocedure TJvID3PicturesDesc.SetText(const AType: Integer{TJvID3PictureType};\r\n const Value: WideString);\r\nbegin\r\n if FController.Active then\r\n TJvID3PictureFrame.FindOrCreate(FController, TJvID3PictureType(AType)).Description := Value;\r\nend;\r\n\r\n//=== { TJvID3Popularimeter } ================================================\r\n\r\nfunction TJvID3Popularimeter.GetCounter: Cardinal;\r\nvar\r\n Frame: TJvID3PopularimeterFrame;\r\nbegin\r\n Frame := TJvID3PopularimeterFrame.Find(FController);\r\n if Assigned(Frame) then\r\n Result := Frame.Counter\r\n else\r\n Result := 0;\r\nend;\r\n\r\nfunction TJvID3Popularimeter.GetEMailAddress: AnsiString;\r\nvar\r\n Frame: TJvID3PopularimeterFrame;\r\nbegin\r\n Frame := TJvID3PopularimeterFrame.Find(FController);\r\n if Assigned(Frame) then\r\n Result := Frame.EMailAddress\r\n else\r\n Result := '';\r\nend;\r\n\r\nfunction TJvID3Popularimeter.GetRating: Byte;\r\nvar\r\n Frame: TJvID3PopularimeterFrame;\r\nbegin\r\n Frame := TJvID3PopularimeterFrame.Find(FController);\r\n if Assigned(Frame) then\r\n Result := Frame.Rating\r\n else\r\n Result := 0;\r\nend;\r\n\r\nprocedure TJvID3Popularimeter.SetCounter(const Value: Cardinal);\r\nbegin\r\n if FController.Active then\r\n TJvID3PopularimeterFrame.FindOrCreate(FController).Counter := Value;\r\nend;\r\n\r\nprocedure TJvID3Popularimeter.SetEMailAddress(const Value: AnsiString);\r\nbegin\r\n if FController.Active then\r\n TJvID3PopularimeterFrame.FindOrCreate(FController).EMailAddress := Value;\r\nend;\r\n\r\nprocedure TJvID3Popularimeter.SetRating(const Value: Byte);\r\nbegin\r\n if FController.Active then\r\n TJvID3PopularimeterFrame.FindOrCreate(FController).Rating := Value;\r\nend;\r\n\r\n//=== { TJvID3Text } =========================================================\r\n\r\nconstructor TJvID3Text.Create(AController: TJvID3Controller);\r\nbegin\r\n inherited Create(AController);\r\n FDummyList := {$IFDEF COMPILER12_UP}TStringList{$ELSE}TWideStringList{$ENDIF COMPILER12_UP}.Create;\r\nend;\r\n\r\ndestructor TJvID3Text.Destroy;\r\nbegin\r\n FDummyList.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJvID3Text.GetDateTime(const FrameID: Integer{TJvID3FrameID}): TDateTime;\r\nvar\r\n Frame: TJvID3TimestampFrame;\r\nbegin\r\n Frame := TJvID3TimestampFrame.Find(FController, TJvID3FrameID(FrameID));\r\n if Assigned(Frame) then\r\n Result := Frame.Value\r\n else\r\n Result := 0;\r\nend;\r\n\r\nfunction TJvID3Text.GetList(const FrameID: Integer{TJvID3FrameID}): {$IFDEF COMPILER12_UP}TStrings{$ELSE}TWideStrings{$ENDIF COMPILER12_UP};\r\nbegin\r\n if FController.Active then\r\n Result := TJvID3SimpleListFrame.FindOrCreate(FController, TJvID3FrameID(FrameID)).List\r\n else\r\n begin\r\n Result := FDummyList;\r\n Result.Clear;\r\n end;\r\nend;\r\n\r\nfunction TJvID3Text.GetNumber(const FrameID: Integer{TJvID3FrameID}): Cardinal;\r\nvar\r\n Frame: TJvID3NumberFrame;\r\nbegin\r\n Frame := TJvID3NumberFrame.Find(FController, TJvID3FrameID(FrameID));\r\n if Assigned(Frame) then\r\n Result := Frame.Value\r\n else\r\n Result := 0;\r\nend;\r\n\r\nfunction TJvID3Text.GetText(const FrameID: Integer{TJvID3FrameID}): WideString;\r\nvar\r\n Frame: TJvID3TextFrame;\r\nbegin\r\n Frame := TJvID3TextFrame.Find(FController, TJvID3FrameID(FrameID));\r\n if Assigned(Frame) then\r\n Result := Frame.Text\r\n else\r\n Result := '';\r\nend;\r\n\r\nfunction TJvID3Text.GetBPM: Cardinal;\r\nbegin\r\n Result := Trunc(StrToFloatDef(StringReplace(BPMStr, '.', JclFormatSettings.DecimalSeparator, []), 0));\r\nend;\r\n\r\nprocedure TJvID3Text.SetBPM(const Value: Cardinal);\r\nbegin\r\n BPMStr := IntToStr(Value);\r\nend;\r\n\r\nprocedure TJvID3Text.SetDateTime(const FrameID: Integer{TJvID3FrameID};\r\n const Value: TDateTime);\r\nbegin\r\n if FController.Active then\r\n TJvID3TimestampFrame.FindOrCreate(FController, TJvID3FrameID(FrameID)).Value := Value;\r\nend;\r\n\r\nprocedure TJvID3Text.SetList(const FrameID: Integer{TJvID3FrameID};\r\n const Value: {$IFDEF COMPILER12_UP}TStrings{$ELSE}TWideStrings{$ENDIF COMPILER12_UP});\r\nbegin\r\n if FController.Active then\r\n TJvID3SimpleListFrame.FindOrCreate(FController, TJvID3FrameID(FrameID)).List.Assign(Value);\r\nend;\r\n\r\nprocedure TJvID3Text.SetNumber(const FrameID: Integer{TJvID3FrameID};\r\n const Value: Cardinal);\r\nbegin\r\n if FController.Active then\r\n TJvID3NumberFrame.FindOrCreate(FController, TJvID3FrameID(FrameID)).Value := Value;\r\nend;\r\n\r\nprocedure TJvID3Text.SetText(const FrameID: Integer{TJvID3FrameID}; const Value: WideString);\r\nbegin\r\n if FController.Active then\r\n TJvID3TextFrame.FindOrCreate(FController, TJvID3FrameID(FrameID)).Text := Value;\r\nend;\r\n\r\n//=== { TJvID3UDText } =======================================================\r\n\r\nprocedure TJvID3UDText.Add(const ADescription, AValue: WideString);\r\nbegin\r\n if not Assigned(FController) then\r\n ID3Error(RsEID3NoController);\r\n\r\n with TJvID3UserFrame(FController.AddFrame(fiUserText)) do\r\n begin\r\n Description := ADescription;\r\n Value := AValue;\r\n end;\r\nend;\r\n\r\nfunction TJvID3UDText.GetDescription: WideString;\r\nvar\r\n Frame: TJvID3UserFrame;\r\nbegin\r\n if ItemIndex < 0 then\r\n Result := ''\r\n else\r\n begin\r\n Frame := TJvID3UserFrame.Find(FController, ItemIndex);\r\n if Assigned(Frame) then\r\n Result := Frame.Description\r\n else\r\n Result := '';\r\n end;\r\nend;\r\n\r\nfunction TJvID3UDText.GetItemCount: Integer;\r\nbegin\r\n if not FController.Active then\r\n Result := 0\r\n else\r\n Result := FController.GetFrameCountFor(fiUserText);\r\nend;\r\n\r\nfunction TJvID3UDText.GetItemIndex: Integer;\r\nbegin\r\n if not FController.Active then\r\n FItemIndex := -1\r\n else\r\n FItemIndex := Min(FItemIndex, ItemCount - 1);\r\n Result := FItemIndex;\r\nend;\r\n\r\nfunction TJvID3UDText.GetValue: WideString;\r\nvar\r\n Frame: TJvID3UserFrame;\r\nbegin\r\n if ItemIndex < 0 then\r\n Result := ''\r\n else\r\n begin\r\n Frame := TJvID3UserFrame.Find(FController, ItemIndex);\r\n if Assigned(Frame) then\r\n Result := Frame.Value\r\n else\r\n Result := '';\r\n end;\r\nend;\r\n\r\nprocedure TJvID3UDText.SetDescription(const Value: WideString);\r\nbegin\r\n if FController.Active and (ItemIndex >= 0) and (ItemIndex < ItemCount) then\r\n TJvID3UserFrame.Find(FController, ItemIndex).Description := Value;\r\nend;\r\n\r\nprocedure TJvID3UDText.SetItemIndex(const Value: Integer);\r\nbegin\r\n if Value <> FItemIndex then\r\n FItemIndex := Min(Value, ItemCount - 1);\r\nend;\r\n\r\nprocedure TJvID3UDText.SetValue(const Value: WideString);\r\nbegin\r\n if FController.Active and (ItemIndex >= 0) and (ItemIndex < ItemCount) then\r\n TJvID3UserFrame.Find(FController, ItemIndex).Value := Value;\r\nend;\r\n\r\n//=== { TJvID3UDUrl } ========================================================\r\n\r\nprocedure TJvID3UDUrl.Add(const ADescription: WideString; const AURL: AnsiString);\r\nbegin\r\n if not Assigned(FController) then\r\n ID3Error(RsEID3NoController);\r\n\r\n with TJvID3URLUserFrame(FController.AddFrame(fiWWWUser)) do\r\n begin\r\n Description := ADescription;\r\n URL := AURL;\r\n end;\r\nend;\r\n\r\nfunction TJvID3UDUrl.GetDescription: WideString;\r\nvar\r\n Frame: TJvID3URLUserFrame;\r\nbegin\r\n if ItemIndex < 0 then\r\n Result := ''\r\n else\r\n begin\r\n Frame := TJvID3URLUserFrame.Find(FController, ItemIndex);\r\n if Assigned(Frame) then\r\n Result := Frame.Description\r\n else\r\n Result := '';\r\n end;\r\nend;\r\n\r\nfunction TJvID3UDUrl.GetItemCount: Integer;\r\nbegin\r\n if not FController.Active then\r\n Result := 0\r\n else\r\n Result := FController.GetFrameCountFor(fiWWWUser);\r\nend;\r\n\r\nfunction TJvID3UDUrl.GetItemIndex: Integer;\r\nbegin\r\n if not FController.Active then\r\n FItemIndex := -1\r\n else\r\n FItemIndex := Min(FItemIndex, ItemCount - 1);\r\n Result := FItemIndex;\r\nend;\r\n\r\nfunction TJvID3UDUrl.GetURL: AnsiString;\r\nvar\r\n Frame: TJvID3URLUserFrame;\r\nbegin\r\n if ItemIndex < 0 then\r\n Result := ''\r\n else\r\n begin\r\n Frame := TJvID3URLUserFrame.Find(FController, ItemIndex);\r\n if Assigned(Frame) then\r\n Result := Frame.URL\r\n else\r\n Result := '';\r\n end;\r\nend;\r\n\r\nprocedure TJvID3UDUrl.SetDescription(const Value: WideString);\r\nbegin\r\n if FController.Active and (ItemIndex >= 0) then\r\n TJvID3URLUserFrame.Find(FController, ItemIndex).Description := Value;\r\nend;\r\n\r\nprocedure TJvID3UDUrl.SetItemIndex(const Value: Integer);\r\nbegin\r\n if Value <> FItemIndex then\r\n FItemIndex := Min(Value, ItemCount - 1);\r\nend;\r\n\r\nprocedure TJvID3UDUrl.SetURL(const Value: AnsiString);\r\nbegin\r\n if FController.Active and (ItemIndex >= 0) then\r\n TJvID3URLUserFrame.Find(FController, ItemIndex).URL := Value;\r\nend;\r\n\r\n//=== { TJvID3v2 } ===========================================================\r\n\r\nconstructor TJvID3v2.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n RegisterClient(Self, ActiveChanged);\r\n\r\n FProcessPictures := True;\r\n FID3Text := TJvID3Text.Create(Self);\r\n FWeb := TJvID3Web.Create(Self);\r\n FUserDefinedText := TJvID3UDText.Create(Self);\r\n FUserDefinedWeb := TJvID3UDUrl.Create(Self);\r\n FInvolvedPeople := TJvID3Ipl.Create(Self);\r\n FImages := TJvID3Images.Create(Self);\r\n FOwner := TJvID3Owner.Create(Self);\r\n FPopularimeter := TJvID3Popularimeter.Create(Self);\r\n\r\n WriteEncodingAs := ifeAuto;\r\n ReadEncodingAs := ifeAuto;\r\n\r\n Options := [coAutoCorrect, coRemoveEmptyFrames];\r\nend;\r\n\r\ndestructor TJvID3v2.Destroy;\r\nbegin\r\n UnRegisterClient(Self);\r\n\r\n FID3Text.Free;\r\n FWeb.Free;\r\n FUserDefinedText.Free;\r\n FUserDefinedWeb.Free;\r\n FInvolvedPeople.Free;\r\n FImages.Free;\r\n FOwner.Free;\r\n FPopularimeter.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvID3v2.ActiveChanged(Sender: TObject; Activated: Boolean);\r\nbegin\r\n if FProcessPictures then\r\n begin\r\n if Activated then\r\n FImages.Pictures.RetrievePictures\r\n else\r\n FImages.Pictures.RemovePictures;\r\n end;\r\nend;\r\n\r\nfunction TJvID3v2.GetPlayCounter: Cardinal;\r\nvar\r\n Frame: TJvID3PlayCounterFrame;\r\nbegin\r\n Frame := TJvID3PlayCounterFrame.Find(Self);\r\n if Assigned(Frame) then\r\n Result := Frame.Counter\r\n else\r\n Result := 0;\r\nend;\r\n\r\nprocedure TJvID3v2.SetPlayCounter(const Value: Cardinal);\r\nbegin\r\n if Active then\r\n TJvID3PlayCounterFrame.FindOrCreate(Self).Counter := Value;\r\nend;\r\n\r\n//=== { TJvID3Web } ==========================================================\r\n\r\nfunction TJvID3Web.GetText(const FrameID: Integer{TJvID3FrameID}): AnsiString;\r\nvar\r\n Frame: TJvID3URLFrame;\r\nbegin\r\n Frame := TJvID3URLFrame.Find(FController, TJvID3FrameID(FrameID));\r\n if Assigned(Frame) then\r\n Result := Frame.URL\r\n else\r\n Result := '';\r\nend;\r\n\r\nprocedure TJvID3Web.SetText(const FrameID: Integer{TJvID3FrameID}; const Value: AnsiString);\r\nbegin\r\n if FController.Active then\r\n TJvID3URLFrame.FindOrCreate(FController, TJvID3FrameID(FrameID)).URL := Value;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvId3v2Types.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvID3v2Types.PAS, released on 2001-02-28.\r\n\r\nThe Initial Developer of the Original Code is Sbastien Buysse [sbuysse att buypin dott com]\r\nPortions created by Sbastien Buysse are Copyright (C) 2001 Sbastien Buysse.\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\n Michael Beck [mbeck att bigfoot dott com].\r\n Remko Bonte [remkobonte att myrealbox dott com].\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvId3v2Types.pas 13075 2011-06-27 22:56:21Z jfudickar $\r\n\r\nunit JvId3v2Types;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Classes;\r\n\r\ntype\r\n TJvID3TagSizeRestriction = (tsrMax128Frames_1MB, tsrMax64Frames_128KB, tsrMax32Frames_40KB,\r\n tsrMax32Frames_4KB);\r\n TJvID3TextEncodingRestriction = (terNoRestrictions, terOnlyISO_8859_1orUTF8);\r\n TJvID3TextFieldsSizeRestriction = (tfszNoRestrictions, tfszMax1024Char, tfszMax128Char,\r\n tfszMax30Char);\r\n TJvID3ImageEncodingRestriction = (ierNoRestrictions, ierOnlyPNGorJPEG);\r\n TJvID3ImageSizeRestriction = (isrNoRestrictions, isrMax256x256, isrMax64x64, isr64x64UnlessRequired);\r\n\r\n TJvID3Restrictions = record\r\n RTagSize: TJvID3TagSizeRestriction;\r\n RTextEncoding: TJvID3TextEncodingRestriction;\r\n RTextFieldsSize: TJvID3TextFieldsSizeRestriction;\r\n RImageEncoding: TJvID3ImageEncodingRestriction;\r\n RImageSize: TJvID3ImageSizeRestriction;\r\n end;\r\n\r\n TJvID3HeaderExtendedFlag = (hefTagIsAnUpdate, hefCRCDataPresent, hefTagRestrictions);\r\n TJvID3HeaderExtendedFlags = set of TJvID3HeaderExtendedFlag;\r\n\r\n TJvID3HeaderFlag = (hfUnsynchronisation, hfExtendedHeader, hfExperimentalIndicator, hfFooterPresent);\r\n TJvID3HeaderFlags = set of TJvID3HeaderFlag;\r\n\r\n TJvID3FrameHeaderFlag = (fhfOnTagAlterDiscardFrame, fhfOnFileAlterDiscardFrame,\r\n fhfReadOnly, fhfIsCompressed, fhfIsEncrypted, fhfContainsGroupInformation, fhfUnsynchronisationApplied,\r\n fhfDataLengthIndicator);\r\n TJvID3FrameHeaderFlags = set of TJvID3FrameHeaderFlag;\r\n\r\n { $00 ISO-8859-1 [ISO-8859-1]. Terminated with $00.\r\n $01 UTF-16 [UTF-16] encoded Unicode [UNICODE] with BOM. All\r\n strings in the same frame SHALL have the same byteorder.\r\n Terminated with $00 00.\r\n $02 UTF-16BE [UTF-16] encoded Unicode [UNICODE] without BOM.\r\n Terminated with $00 00.\r\n $03 UTF-8 [UTF-8] encoded Unicode [UNICODE]. Terminated with $00.\r\n }\r\n\r\n TJvID3ForceEncoding = (ifeDontCare, ifeISO_8859_1, ifeUTF_16, ifeUTF_16BE, ifeUTF_8, ifeAuto);\r\n TJvID3Encoding = (ienISO_8859_1, ienUTF_16, ienUTF_16BE, ienUTF_8);\r\n TJvID3Encodings = set of TJvID3Encoding;\r\n\r\n TJvID3ForceVersion = (ifvDontCare, ifv2_2, ifv2_3, ifv2_4);\r\n TJvID3Version = (iveLowerThan2_2, ive2_2, ive2_3, ive2_4, iveHigherThan2_4);\r\n\r\nconst\r\n CForceEncodingToEncoding: array [TJvID3ForceEncoding] of TJvID3Encoding =\r\n (ienISO_8859_1, ienISO_8859_1, ienUTF_16, ienUTF_16BE, ienUTF_8, ienISO_8859_1);\r\n CForceVersionToVersion: array [TJvID3ForceVersion] of TJvID3Version =\r\n (ive2_3, ive2_2, ive2_3, ive2_4);\r\n\r\ntype\r\n TID3v2HeaderRec = packed record\r\n Identifier: array [0..2] of AnsiChar;\r\n MajorVersion: Byte;\r\n RevisionNumber: Byte;\r\n Flags: Byte;\r\n Size: Cardinal;\r\n end;\r\n\r\n TID3v2FrameRec = packed record\r\n ID: array [0..3] of AnsiChar;\r\n // (rom) changed to Cardinal sizes are usually unsigned\r\n Size: Cardinal;\r\n Flag0: Byte;\r\n Flag1: Byte;\r\n end;\r\n\r\n TJvID3PictureType = (\r\n ptOther, { Other }\r\n ptFileIcon, { 32x32 pixels 'file icon' (PNG only) }\r\n ptOtherFileIcon, { Other file icon }\r\n ptCoverFront, { Cover (front) }\r\n ptCoverBack, { Cover (back) }\r\n ptLeafletPage, { Leaflet page }\r\n ptMedia, { Media (e.g. lable side of CD) }\r\n ptLeadArtist, { Lead artist/lead performer/soloist }\r\n ptArtist, { Artist/performer }\r\n ptConductor, { Conductor }\r\n ptBand, { Band/Orchestra }\r\n ptComposer, { Composer }\r\n ptLyricist, { Lyricist/text writer }\r\n ptRecordingLocation, { Recording Location }\r\n ptDuringRecording, { During recording }\r\n ptDuringPerformance, { During performance }\r\n ptMovieVideoScreenCapture, { Movie/video screen capture }\r\n ptBrightColouredFish, { A bright coloured fish }\r\n ptIllustration, { Illustration }\r\n ptBandLogotype, { Band/artist logotype }\r\n ptPublisherLogotype { Publisher/Studio logotype }\r\n );\r\n\r\n TJvID3FrameID =\r\n (\r\n { ---- } fiErrorFrame, { Erroneous frame, ie chars not in [a..z, A..Z, 0..9] }\r\n { #0 } fiPaddingFrame, { Padding }\r\n { ???? } fiUnknownFrame, { No known frame }\r\n { AENC } fiAudioCrypto, { Audio encryption }\r\n { APIC } fiPicture, { Attached picture }\r\n { ASPI } fiAudioSeekPoint, { Audio seek point index }\r\n { COMM } fiComment, { Comments }\r\n { COMR } fiCommercial, { Commercial frame }\r\n { ENCR } fiCryptoReg, { Encryption method registration }\r\n { EQU2 } fiEqualization2, { Equalisation (2) }\r\n { EQUA } fiEqualization, { Equalization }\r\n { ETCO } fiEventTiming, { Event timing codes }\r\n { GEOB } fiGeneralObject, { General encapsulated object }\r\n { GRID } fiGroupingReg, { Group identification registration }\r\n { IPLS } fiInvolvedPeople, { Involved people list }\r\n { LINK } fiLinkedInfo, { Linked information }\r\n { MCDI } fiCDID, { Music CD identifier }\r\n { MLLT } fiMPEGLookup, { MPEG location lookup table }\r\n { OWNE } fiOwnership, { Ownership frame }\r\n { PRIV } fiPrivate, { Private frame }\r\n { PCNT } fiPlayCounter, { Play counter }\r\n { POPM } fiPopularimeter, { Popularimeter }\r\n { POSS } fiPositionsync, { Position synchronisation frame }\r\n { RBUF } fiBufferSize, { Recommended buffer size }\r\n { RVA2 } fiVolumeAdj2, { Relative volume adjustment (2) }\r\n { RVAD } fiVolumeAdj, { Relative volume adjustment }\r\n { RVRB } fiReverb, { Reverb }\r\n { SEEK } fiSeekFrame, { Seek frame }\r\n { SIGN } fiSignature, { Signature frame }\r\n { SYLT } fiSyncedLyrics, { Synchronized lyric/text }\r\n { SYTC } fiSyncedTempo, { Synchronized tempo codes }\r\n { TALB } fiAlbum, { Album/Movie/Show title }\r\n { TBPM } fiBPM, { BPM (beats per minute) }\r\n { TCOM } fiComposer, { Composer }\r\n { TCON } fiContentType, { Content type }\r\n { TCOP } fiCopyright, { Copyright message }\r\n { TDAT } fiDate, { Date }\r\n { TDEN } fiEncodingTime, { Encoding time }\r\n { TDLY } fiPlaylistDelay, { Playlist delay }\r\n { TDOR } fiOrigReleaseTime, { Original release time }\r\n { TDRC } fiRecordingTime, { Recording time }\r\n { TDRL } fiReleaseTime, { Release time }\r\n { TDTG } fiTaggingTime, { Tagging time }\r\n { TIPL } fiInvolvedPeople2, { Involved people list }\r\n { TENC } fiEncodedBy, { Encoded by }\r\n { TEXT } fiLyricist, { Lyricist/Text writer }\r\n { TFLT } fiFileType, { File type }\r\n { TIME } fiTime, { Time }\r\n { TIT1 } fiContentGroup, { Content group description }\r\n { TIT2 } fiTitle, { Title/songname/content description }\r\n { TIT3 } fiSubTitle, { Subtitle/Description refinement }\r\n { TKEY } fiInitialKey, { Initial key }\r\n { TLAN } fiLanguage, { Language(s) }\r\n { TLEN } fiSongLen, { Length }\r\n { TMCL } fiMusicianCreditList, { Musician credits list }\r\n { TMED } fiMediaType, { Media type }\r\n { TMOO } fiMood, { Mood }\r\n { TOAL } fiOrigAlbum, { Original album/movie/show title }\r\n { TOFN } fiOrigFileName, { Original filename }\r\n { TOLY } fiOrigLyricist, { Original lyricist(s)/text writer(s) }\r\n { TOPE } fiOrigArtist, { Original artist(s)/performer(s) }\r\n { TORY } fiOrigYear, { Original release year }\r\n { TOWN } fiFileOwner, { File owner/licensee }\r\n { TPE1 } fiLeadArtist, { Lead performer(s)/Soloist(s) }\r\n { TPE2 } fiBand, { Band/orchestra/accompaniment }\r\n { TPE3 } fiConductor, { Conductor/performer refinement }\r\n { TPE4 } fiMixArtist, { Interpreted, remixed, or otherwise modified by }\r\n { TPOS } fiPartInSet, { Part of a set }\r\n { TPRO } fiProducedNotice, { Produced notice }\r\n { TPUB } fiPublisher, { Publisher }\r\n { TRCK } fiTrackNum, { Track number/Position in set }\r\n { TRDA } fiRecordingDates, { Recording dates }\r\n { TRSN } fiNetRadioStation, { Internet radio station name }\r\n { TRSO } fiNetRadioOwner, { Internet radio station owner }\r\n { TSIZ } fiSize, { Size }\r\n { TSOA } fiAlbumSortOrder, { Album sort order }\r\n { TSOP } fiPerformerSortOrder, { Performer sort order }\r\n { TSOT } fiTitleSortOrder, { Title sort order }\r\n { TSRC } fiISRC, { ISRC (international standard recording code) }\r\n { TSSE } fiEncoderSettings, { Software/Hardware and settings used for encoding }\r\n { TSST } fiSetSubTitle, { Set subtitle }\r\n { TXXX } fiUserText, { User defined text information }\r\n { TYER } fiYear, { Year }\r\n { UFID } fiUniqueFileID, { Unique file identifier }\r\n { USER } fiTermsOfUse, { Terms of use }\r\n { USLT } fiUnsyncedLyrics, { Unsynchronized lyric/text transcription }\r\n { WCOM } fiWWWCommercialInfo, { Commercial information }\r\n { WCOP } fiWWWCopyright, { Copyright/Legal information }\r\n { WOAF } fiWWWAudioFile, { Official audio file webpage }\r\n { WOAR } fiWWWArtist, { Official artist/performer webpage }\r\n { WOAS } fiWWWAudioSource, { Official audio source webpage }\r\n { WORS } fiWWWRadioPage, { Official internet radio station homepage }\r\n { WPAY } fiWWWPayment, { Payment }\r\n { WPUB } fiWWWPublisher, { Official publisher webpage }\r\n { WXXX } fiWWWUser, { User defined URL link }\r\n { } fiMetaCrypto, { Encrypted meta frame (ID3v2.2.x) }\r\n { } fiMetaCompression { Compressed meta frame (ID3v2.2.1) }\r\n );\r\n TJvID3FrameIDs = set of TJvID3FrameID;\r\n\r\n{ Frame ID procedures }\r\nfunction ID3_StringToFrameID(const S: AnsiString): TJvID3FrameID;\r\nfunction ID3_FrameIDToString(const ID: TJvID3FrameID; const Size: Integer = 4): AnsiString;\r\n\r\n{ Genre procedures }\r\nfunction ID3_GenreToID(const AGenre: string; const InclWinampGenres: Boolean = True): Integer;\r\n{ searches for a genre that is a prefix for AGenreLong }\r\nfunction ID3_LongGenreToID(const ALongGenre: string; const InclWinampGenres: Boolean = True): Integer;\r\nfunction ID3_IDToGenre(const ID: Integer; const InclWinampGenres: Boolean = True): string;\r\nprocedure ID3_Genres(Strings: TStrings; const InclWinampGenres: Boolean = True);\r\n\r\n{ Language ISO 639-2 procedures }\r\nfunction ISO_639_2IsCode(const Code: AnsiString): Boolean;\r\nfunction ISO_639_2CodeToName(const Code: AnsiString): AnsiString;\r\n{ Known problem: some codes such as 'dut' and 'nld', have the same name value,\r\n thus ISO_639_2NameToCode('Dutch') = 'dut' not 'nld' }\r\nfunction ISO_639_2NameToCode(const Name: string): AnsiString;\r\nprocedure ISO_639_2Names(Strings: TStrings);\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvId3v2Types.pas $';\r\n Revision: '$Revision: 13075 $';\r\n Date: '$Date: 2011-06-28 00:56:21 +0200 (mar. 28 juin 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n Math, SysUtils,\r\n {$IFDEF SUPPORTS_INLINE}\r\n Windows,\r\n {$ENDIF SUPPORTS_INLINE}\r\n {$IFDEF HAS_UNIT_ANSISTRINGS}\r\n AnsiStrings,\r\n {$ENDIF HAS_UNIT_ANSISTRINGS}\r\n JvJCLUtils,\r\n JvConsts, JvResources, JvTypes;\r\n\r\ntype\r\n TJvListType =\r\n (ltID3LongText, ltID3ShortText, ltISO_639_2Code, ltISO_639_2Name, ltID3Genres);\r\n\r\n TJvID3FrameDef = packed record\r\n ShortTextID: array [0..2] of AnsiChar;\r\n LongTextID: array [0..3] of AnsiChar;\r\n end;\r\n\r\n { Note: When you change type of S or L to 'string' it will increase the exe size\r\n with minimal 475x8 bytes }\r\n\r\n TShortToLongName = record\r\n S: array [0..2] of AnsiChar;\r\n L: PAnsiChar;\r\n end;\r\n\r\n TJvID3TermFinder = class\r\n private\r\n FLists: array [TJvListType] of TStringList;\r\n protected\r\n procedure BuildList_ISO_639_2Name;\r\n procedure BuildList_ISO_639_2Code;\r\n procedure BuildList_ID3LongText;\r\n procedure BuildList_ID3ShortText;\r\n procedure BuildList_ID3Genres;\r\n function IsFrameOk(const S: AnsiString): Boolean;\r\n public\r\n constructor Create; virtual;\r\n destructor Destroy; override;\r\n\r\n function ID3LongTextToFrameID(const S: AnsiString): TJvID3FrameID;\r\n function ID3ShortTextToFrameID(const S: AnsiString): TJvID3FrameID;\r\n\r\n function ID3GenreToID(const AGenre: string; const InclWinampGenres: Boolean): Integer;\r\n procedure ID3Genres(AStrings: TStrings; const InclWinampGenres: Boolean);\r\n function ID3LongGenreToID(const ALongGenre: string; const InclWinampGenres: Boolean): Integer;\r\n\r\n function ISO_639_2CodeToIndex(const ACode: AnsiString): Integer;\r\n function ISO_639_2NameToIndex(const AName: string): Integer;\r\n procedure ISO_639_2Names(AStrings: TStrings);\r\n end;\r\n\r\nconst\r\n CID3FrameDefs: array [TJvID3FrameID] of TJvID3FrameDef = ( { Ver. 2 3 4 }\r\n (ShortTextID: ''; LongTextID: '' ), { fiErrorFrame - - - }\r\n (ShortTextID: ''; LongTextID: '' ), { fiPaddingFrame - - - }\r\n (ShortTextID: ''; LongTextID: '' ), { fiUnknownFrame - - - }\r\n (ShortTextID: 'CRA'; LongTextID: 'AENC'), { fiAudioCrypto X X X }\r\n (ShortTextID: 'PIC'; LongTextID: 'APIC'), { fiPicture X X X }\r\n (ShortTextID: ''; LongTextID: 'ASPI'), { fiAudioSeekPoint - - X }\r\n (ShortTextID: 'COM'; LongTextID: 'COMM'), { fiComment X X X }\r\n (ShortTextID: ''; LongTextID: 'COMR'), { fiCommercial - X X }\r\n (ShortTextID: ''; LongTextID: 'ENCR'), { fiCryptoReg - X X }\r\n (ShortTextID: ''; LongTextID: 'EQU2'), { fiEqualization2 - - X }\r\n (ShortTextID: 'EQU'; LongTextID: 'EQUA'), { fiEqualization X X d }\r\n (ShortTextID: 'ETC'; LongTextID: 'ETCO'), { fiEventTiming X X X }\r\n (ShortTextID: 'GEO'; LongTextID: 'GEOB'), { fiGeneralObject X X X }\r\n (ShortTextID: ''; LongTextID: 'GRID'), { fiGroupingReg - X X }\r\n (ShortTextID: 'IPL'; LongTextID: 'IPLS'), { fiInvolvedPeople X X d }\r\n (ShortTextID: 'LNK'; LongTextID: 'LINK'), { fiLinkedInfo X X X }\r\n (ShortTextID: 'MCI'; LongTextID: 'MCDI'), { fiCDID X X X }\r\n (ShortTextID: 'MLL'; LongTextID: 'MLLT'), { fiMPEGLookup X X X }\r\n (ShortTextID: ''; LongTextID: 'OWNE'), { fiOwnership - X X }\r\n (ShortTextID: ''; LongTextID: 'PRIV'), { fiPrivate - X X }\r\n (ShortTextID: 'CNT'; LongTextID: 'PCNT'), { fiPlayCounter X X X }\r\n (ShortTextID: 'POP'; LongTextID: 'POPM'), { fiPopularimeter X X X }\r\n (ShortTextID: ''; LongTextID: 'POSS'), { fiPositionsync - X X }\r\n (ShortTextID: 'BUF'; LongTextID: 'RBUF'), { fiBufferSize X X X }\r\n (ShortTextID: ''; LongTextID: 'RVA2'), { fiVolumeAdj2 - - X }\r\n (ShortTextID: 'RVA'; LongTextID: 'RVAD'), { fiVolumeAdj X X d }\r\n (ShortTextID: 'REV'; LongTextID: 'RVRB'), { fiReverb X X X }\r\n (ShortTextID: ''; LongTextID: 'SEEK'), { fiSeekFrame - - X }\r\n (ShortTextID: ''; LongTextID: 'SIGN'), { fiSignature - - X }\r\n (ShortTextID: 'SLT'; LongTextID: 'SYLT'), { fiSyncedLyrics X X X }\r\n (ShortTextID: 'STC'; LongTextID: 'SYTC'), { fiSyncedTempo X X X }\r\n (ShortTextID: 'TAL'; LongTextID: 'TALB'), { fiAlbum X X X }\r\n (ShortTextID: 'TBP'; LongTextID: 'TBPM'), { fiBPM X X X }\r\n (ShortTextID: 'TCM'; LongTextID: 'TCOM'), { fiComposer X X X }\r\n (ShortTextID: 'TCO'; LongTextID: 'TCON'), { fiContentType X X X }\r\n (ShortTextID: 'TCR'; LongTextID: 'TCOP'), { fiCopyright X X X }\r\n (ShortTextID: 'TDA'; LongTextID: 'TDAT'), { fiDate X X d }\r\n (ShortTextID: ''; LongTextID: 'TDEN'), { fiEncodingTime - - X }\r\n (ShortTextID: 'TDY'; LongTextID: 'TDLY'), { fiPlaylistDelay X X X }\r\n (ShortTextID: ''; LongTextID: 'TDOR'), { fiOrigReleaseTime - - X }\r\n (ShortTextID: ''; LongTextID: 'TDRC'), { fiRecordingTime - - X }\r\n (ShortTextID: ''; LongTextID: 'TDRL'), { fiReleaseTime - - X }\r\n (ShortTextID: ''; LongTextID: 'TDTG'), { fiTaggingTime - - X }\r\n (ShortTextID: ''; LongTextID: 'TIPL'), { fiInvolvedPeople2 - - X }\r\n (ShortTextID: 'TEN'; LongTextID: 'TENC'), { fiEncodedBy X X X }\r\n (ShortTextID: 'TXT'; LongTextID: 'TEXT'), { fiLyricist X X X }\r\n (ShortTextID: 'TFT'; LongTextID: 'TFLT'), { fiFileType X X X }\r\n (ShortTextID: 'TIM'; LongTextID: 'TIME'), { fiTime X X d }\r\n (ShortTextID: 'TT1'; LongTextID: 'TIT1'), { fiContentGroup X X X }\r\n (ShortTextID: 'TT2'; LongTextID: 'TIT2'), { fiTitle X X X }\r\n (ShortTextID: 'TT3'; LongTextID: 'TIT3'), { fiSubTitle X X X }\r\n (ShortTextID: 'TKE'; LongTextID: 'TKEY'), { fiInitialKey X X X }\r\n (ShortTextID: 'TLA'; LongTextID: 'TLAN'), { fiLanguage X X X }\r\n (ShortTextID: 'TLE'; LongTextID: 'TLEN'), { fiSongLen X X X }\r\n (ShortTextID: ''; LongTextID: 'TMCL'), { fiMusicianCreditList - - X }\r\n (ShortTextID: 'TMT'; LongTextID: 'TMED'), { fiMediaType X X X }\r\n (ShortTextID: ''; LongTextID: 'TMOO'), { fiMood - - X }\r\n (ShortTextID: 'TOT'; LongTextID: 'TOAL'), { fiOrigAlbum X X X }\r\n (ShortTextID: 'TOF'; LongTextID: 'TOFN'), { fiOrigFileName X X X }\r\n (ShortTextID: 'TOL'; LongTextID: 'TOLY'), { fiOrigLyricist X X X }\r\n (ShortTextID: 'TOA'; LongTextID: 'TOPE'), { fiOrigArtist X X X }\r\n (ShortTextID: 'TOR'; LongTextID: 'TORY'), { fiOrigYear X X d }\r\n (ShortTextID: ''; LongTextID: 'TOWN'), { fiFileOwner - X X }\r\n (ShortTextID: 'TP1'; LongTextID: 'TPE1'), { fiLeadArtist X X X }\r\n (ShortTextID: 'TP2'; LongTextID: 'TPE2'), { fiBand X X X }\r\n (ShortTextID: 'TP3'; LongTextID: 'TPE3'), { fiConductor X X X }\r\n (ShortTextID: 'TP4'; LongTextID: 'TPE4'), { fiMixArtist X X X }\r\n (ShortTextID: 'TPA'; LongTextID: 'TPOS'), { fiPartInSet X X X }\r\n (ShortTextID: ''; LongTextID: 'TPRO'), { fiProducedNotice - - X }\r\n (ShortTextID: 'TPB'; LongTextID: 'TPUB'), { fiPublisher X X X }\r\n (ShortTextID: 'TRK'; LongTextID: 'TRCK'), { fiTrackNum X X X }\r\n (ShortTextID: 'TRD'; LongTextID: 'TRDA'), { fiRecordingDates X X d }\r\n (ShortTextID: 'TRN'; LongTextID: 'TRSN'), { fiNetRadioStation X X X }\r\n (ShortTextID: 'TRO'; LongTextID: 'TRSO'), { fiNetRadioOwner X X X }\r\n (ShortTextID: 'TSI'; LongTextID: 'TSIZ'), { fiSize X X d }\r\n (ShortTextID: ''; LongTextID: 'TSOA'), { fiAlbumSortOrder - - X }\r\n (ShortTextID: ''; LongTextID: 'TSOP'), { fiPerformerSortOrder - - X }\r\n (ShortTextID: ''; LongTextID: 'TSOT'), { fiTitleSortOrder - - X }\r\n (ShortTextID: 'TRC'; LongTextID: 'TSRC'), { fiISRC X X X }\r\n (ShortTextID: ''; LongTextID: 'TSSE'), { fiEncoderSettings - X X }\r\n (ShortTextID: 'TSS'; LongTextID: 'TSST'), { fiSetSubTitle - - X }\r\n (ShortTextID: 'TXX'; LongTextID: 'TXXX'), { fiUserText X X X }\r\n (ShortTextID: 'TYE'; LongTextID: 'TYER'), { fiYear X X d }\r\n (ShortTextID: 'UFI'; LongTextID: 'UFID'), { fiUniqueFileID X X X }\r\n (ShortTextID: ''; LongTextID: 'USER'), { fiTermsOfUse - X X }\r\n (ShortTextID: 'ULT'; LongTextID: 'USLT'), { fiUnsyncedLyrics X X X }\r\n (ShortTextID: 'WCM'; LongTextID: 'WCOM'), { fiWWWCommercialInfo X X X }\r\n (ShortTextID: 'WCP'; LongTextID: 'WCOP'), { fiWWWCopyright X X X }\r\n (ShortTextID: 'WAF'; LongTextID: 'WOAF'), { fiWWWAudioFile X X X }\r\n (ShortTextID: 'WAR'; LongTextID: 'WOAR'), { fiWWWArtist X X X }\r\n (ShortTextID: 'WAS'; LongTextID: 'WOAS'), { fiWWWAudioSource X X X }\r\n (ShortTextID: 'WRA'; LongTextID: 'WORS'), { fiWWWRadioPage X X X }\r\n (ShortTextID: 'WPY'; LongTextID: 'WPAY'), { fiWWWPayment X X X }\r\n (ShortTextID: 'WPB'; LongTextID: 'WPUB'), { fiWWWPublisher X X X }\r\n (ShortTextID: 'WXX'; LongTextID: 'WXXX'), { fiWWWUser X X X }\r\n (ShortTextID: 'CRM'; LongTextID: '' ), { fiMetaCrypto X - - }\r\n (ShortTextID: 'CDM'; LongTextID: '' ) { fiMetaCompressio X - - }\r\n );\r\n\r\n { http://www.loc.gov/standards/iso639-2/englangn.html }\r\n\r\n CISO_639_2Data: array [0..474] of TShortToLongName =\r\n (\r\n {0}(S: 'aar'; L: 'Afar'),\r\n (S: 'abk'; L: 'Abkhazian'),\r\n (S: 'ace'; L: 'Achinese'),\r\n (S: 'ach'; L: 'Acoli'),\r\n (S: 'ada'; L: 'Adangme'),\r\n (S: 'afa'; L: 'Afro-Asiatic (Other)'),\r\n (S: 'afh'; L: 'Afrihili'),\r\n (S: 'afr'; L: 'Afrikaans'),\r\n (S: 'aka'; L: 'Akan'),\r\n (S: 'akk'; L: 'Akkadian'),\r\n {10}(S: 'alb'; L: 'Albanian'), // Also 'sqi'\r\n (S: 'ale'; L: 'Aleut'),\r\n (S: 'alg'; L: 'Algonquian languages'),\r\n (S: 'amh'; L: 'Amharic'),\r\n (S: 'ang'; L: 'English, Old (ca.450-1100)'),\r\n (S: 'apa'; L: 'Apache languages'),\r\n (S: 'ara'; L: 'Arabic'),\r\n (S: 'arc'; L: 'Aramaic'),\r\n (S: 'arg'; L: 'Aragonese'),\r\n (S: 'arm'; L: 'Armenian'), // Also 'hye'\r\n {20}(S: 'arn'; L: 'Araucanian'),\r\n (S: 'arp'; L: 'Arapaho'),\r\n (S: 'art'; L: 'Artificial (Other)'),\r\n (S: 'arw'; L: 'Arawak'),\r\n (S: 'asm'; L: 'Assamese'),\r\n (S: 'ast'; L: 'Asturian; Bable'),\r\n (S: 'ath'; L: 'Athapascan languages'),\r\n (S: 'aus'; L: 'Australian languages'),\r\n (S: 'ava'; L: 'Avaric'),\r\n (S: 'ave'; L: 'Avestan'),\r\n {30}(S: 'awa'; L: 'Awadhi'),\r\n (S: 'aym'; L: 'Aymara'),\r\n (S: 'aze'; L: 'Azerbaijani'),\r\n (S: 'bad'; L: 'Banda'),\r\n (S: 'bai'; L: 'Bamileke languages'),\r\n (S: 'bak'; L: 'Bashkir'),\r\n (S: 'bal'; L: 'Baluchi'),\r\n (S: 'bam'; L: 'Bambara'),\r\n (S: 'ban'; L: 'Balinese'),\r\n (S: 'baq'; L: 'Basque'), // Also 'eus'\r\n {40}(S: 'bas'; L: 'Basa'),\r\n (S: 'bat'; L: 'Baltic (Other)'),\r\n (S: 'bej'; L: 'Beja'),\r\n (S: 'bel'; L: 'Belarusian'),\r\n (S: 'bem'; L: 'Bemba'),\r\n (S: 'ben'; L: 'Bengali'),\r\n (S: 'ber'; L: 'Berber (Other)'),\r\n (S: 'bho'; L: 'Bhojpuri'),\r\n (S: 'bih'; L: 'Bihari'),\r\n (S: 'bik'; L: 'Bikol'),\r\n {50}(S: 'bin'; L: 'Bini'),\r\n (S: 'bis'; L: 'Bislama'),\r\n (S: 'bla'; L: 'Siksika'),\r\n (S: 'bnt'; L: 'Bantu (Other)'),\r\n (S: 'bod'; L: 'Tibetan'), // Also 'tib'\r\n (S: 'bos'; L: 'Bosnian'),\r\n (S: 'bra'; L: 'Braj'),\r\n (S: 'bre'; L: 'Breton'),\r\n (S: 'btk'; L: 'Batak (Indonesia)'),\r\n (S: 'bua'; L: 'Buriat'),\r\n {60}(S: 'bug'; L: 'Buginese'),\r\n (S: 'bul'; L: 'Bulgarian'),\r\n (S: 'bur'; L: 'Burmese'), // Also 'mya'\r\n (S: 'cad'; L: 'Caddo'),\r\n (S: 'cai'; L: 'Central American Indian (Other)'),\r\n (S: 'car'; L: 'Carib'),\r\n (S: 'cat'; L: 'Catalan'),\r\n (S: 'cau'; L: 'Caucasian (Other)'),\r\n (S: 'ceb'; L: 'Cebuano'),\r\n (S: 'cel'; L: 'Celtic (Other)'),\r\n {70}(S: 'ces'; L: 'Czech'), // Also 'cze'\r\n (S: 'cha'; L: 'Chamorro'),\r\n (S: 'chb'; L: 'Chibcha'),\r\n (S: 'che'; L: 'Chechen'),\r\n (S: 'chg'; L: 'Chagatai'),\r\n (S: 'chi'; L: 'Chinese'), // Also 'zho'\r\n (S: 'chk'; L: 'Chuukese'),\r\n (S: 'chm'; L: 'Mari'),\r\n (S: 'chn'; L: 'Chinook jargon'),\r\n (S: 'cho'; L: 'Choctaw'),\r\n {80}(S: 'chp'; L: 'Chipewyan'),\r\n (S: 'chr'; L: 'Cherokee'),\r\n (S: 'chu'; L: 'Old Bulgarian'),\r\n (S: 'chv'; L: 'Chuvash'),\r\n (S: 'chy'; L: 'Cheyenne'),\r\n (S: 'cmc'; L: 'Chamic languages'),\r\n (S: 'cop'; L: 'Coptic'),\r\n (S: 'cor'; L: 'Cornish'),\r\n (S: 'cos'; L: 'Corsican'),\r\n (S: 'cpe'; L: 'Creoles and pidgins, English-based (Other)'),\r\n {90}(S: 'cpf'; L: 'Creoles and pidgins, French-based (Other)'),\r\n (S: 'cpp'; L: 'Creoles and pidgins, Portuguese-based (Other)'),\r\n (S: 'cre'; L: 'Cree'),\r\n (S: 'crp'; L: 'Creoles and pidgins(Other)'),\r\n (S: 'cus'; L: 'Cushitic (Other)'),\r\n (S: 'cym'; L: 'Welsh'), // Also 'wel'\r\n (S: 'cze'; L: 'Czech'), // Also 'ces'\r\n (S: 'dak'; L: 'Dakota'),\r\n (S: 'dan'; L: 'Danish'),\r\n (S: 'dar'; L: 'Dargwa'),\r\n {100}(S: 'day'; L: 'Dayak'),\r\n (S: 'del'; L: 'Delaware'),\r\n (S: 'den'; L: 'Slave (Athapascan)'),\r\n (S: 'deu'; L: 'German'), // Also 'ger'\r\n (S: 'dgr'; L: 'Dogrib'),\r\n (S: 'din'; L: 'Dinka'),\r\n (S: 'div'; L: 'Divehi'),\r\n (S: 'doi'; L: 'Dogri'),\r\n (S: 'dra'; L: 'Dravidian (Other)'),\r\n (S: 'dua'; L: 'Duala'),\r\n {110}(S: 'dum'; L: 'Dutch, Middle (ca. 1050-1350)'),\r\n (S: 'dut'; L: 'Dutch'), // Also 'nld'\r\n (S: 'dyu'; L: 'Dyula'),\r\n (S: 'dzo'; L: 'Dzongkha'),\r\n (S: 'efi'; L: 'Efik'),\r\n (S: 'egy'; L: 'Egyptian (Ancient)'),\r\n (S: 'eka'; L: 'Ekajuk'),\r\n (S: 'ell'; L: 'Greek, Modern (1453-)'), // Also 'gre'\r\n (S: 'elx'; L: 'Elamite'),\r\n (S: 'eng'; L: 'English'),\r\n {120}(S: 'enm'; L: 'English, Middle (1100-1500)'),\r\n (S: 'epo'; L: 'Esperanto'),\r\n (S: 'est'; L: 'Estonian'),\r\n (S: 'eus'; L: 'Basque'), // Also 'baq'\r\n (S: 'ewe'; L: 'Ewe'),\r\n (S: 'ewo'; L: 'Ewondo'),\r\n (S: 'fan'; L: 'Fang'),\r\n (S: 'fao'; L: 'Faroese'),\r\n (S: 'fas'; L: 'Persian'), // Also 'per'\r\n (S: 'fat'; L: 'Fanti'),\r\n {130}(S: 'fij'; L: 'Fijian'),\r\n (S: 'fin'; L: 'Finnish'),\r\n (S: 'fiu'; L: 'Finno-Ugrian (Other)'),\r\n (S: 'fon'; L: 'Fon'),\r\n (S: 'fra'; L: 'French'), // Also 'fre'\r\n (S: 'fre'; L: 'French'), // Also 'fra'\r\n (S: 'frm'; L: 'French, Middle (ca.1400-1600)'),\r\n (S: 'fro'; L: 'French, Old (842-ca.1400)'),\r\n (S: 'fry'; L: 'Frisian'),\r\n (S: 'ful'; L: 'Fulah'),\r\n {140}(S: 'fur'; L: 'Friulian'),\r\n (S: 'gaa'; L: 'Ga'),\r\n (S: 'gay'; L: 'Gayo'),\r\n (S: 'gba'; L: 'Gbaya'),\r\n (S: 'gem'; L: 'Germanic (Other)'),\r\n (S: 'geo'; L: 'Georgian'), // Also 'kat'\r\n (S: 'ger'; L: 'German'), // Also 'deu'\r\n (S: 'gez'; L: 'Geez'),\r\n (S: 'gil'; L: 'Gilbertese'),\r\n (S: 'gla'; L: 'Gaelic; Scottish Gaelic'),\r\n {150}(S: 'gle'; L: 'Irish'),\r\n (S: 'glg'; L: 'Gallegan'),\r\n (S: 'glv'; L: 'Manx'),\r\n (S: 'gmh'; L: 'German, Middle High (ca.1050-1500)'),\r\n (S: 'goh'; L: 'German, Old High (ca.750-1050)'),\r\n (S: 'gon'; L: 'Gondi'),\r\n (S: 'gor'; L: 'Gorontalo'),\r\n (S: 'got'; L: 'Gothic'),\r\n (S: 'grb'; L: 'Grebo'),\r\n (S: 'grc'; L: 'Greek, Ancient (to 1453)'),\r\n {160}(S: 'gre'; L: 'Greek, Modern (1453-)'), // Also 'ell'\r\n (S: 'grn'; L: 'Guarani'),\r\n (S: 'guj'; L: 'Gujarati'),\r\n (S: 'gwi'; L: 'Gwichin'),\r\n (S: 'hai'; L: 'Haida'),\r\n (S: 'hau'; L: 'Hausa'),\r\n (S: 'haw'; L: 'Hawaiian'),\r\n (S: 'heb'; L: 'Hebrew'),\r\n (S: 'her'; L: 'Herero'),\r\n (S: 'hil'; L: 'Hiligaynon'),\r\n {170}(S: 'him'; L: 'Himachali'),\r\n (S: 'hin'; L: 'Hindi'),\r\n (S: 'hit'; L: 'Hittite'),\r\n (S: 'hmn'; L: 'Hmong'),\r\n (S: 'hmo'; L: 'Hiri Motu'),\r\n (S: 'hrv'; L: 'Croatian'), // Also 'scr'\r\n (S: 'hun'; L: 'Hungarian'),\r\n (S: 'hup'; L: 'Hupa'),\r\n (S: 'hye'; L: 'Armenian'), // Also 'arm'\r\n (S: 'iba'; L: 'Iban'),\r\n {180}(S: 'ibo'; L: 'Igbo'),\r\n (S: 'ice'; L: 'Icelandic'), // Also 'isl'\r\n (S: 'ido'; L: 'Ido'),\r\n (S: 'iii'; L: 'Sichuan Yi'),\r\n (S: 'ijo'; L: 'Ijo'),\r\n (S: 'iku'; L: 'Inuktitut'),\r\n (S: 'ile'; L: 'Interlingue'),\r\n (S: 'ilo'; L: 'Iloko'),\r\n (S: 'ina'; L: 'Interlingua (International Auxiliary Language Association)'),\r\n (S: 'inc'; L: 'Indic (Other)'),\r\n {190}(S: 'ind'; L: 'Indonesian'),\r\n (S: 'ine'; L: 'Indo-European (Other)'),\r\n (S: 'inh'; L: 'Ingush'),\r\n (S: 'ipk'; L: 'Inupiaq'),\r\n (S: 'ira'; L: 'Iranian (Other)'),\r\n (S: 'iro'; L: 'Iroquoian languages'),\r\n (S: 'isl'; L: 'Icelandic'), // Also 'ice'\r\n (S: 'ita'; L: 'Italian'),\r\n (S: 'jav'; L: 'Javanese'),\r\n (S: 'jpn'; L: 'Japanese'),\r\n {200}(S: 'jpr'; L: 'Judeo-Persian'),\r\n (S: 'jrb'; L: 'Judeo-Arabic'),\r\n (S: 'kaa'; L: 'Kara-Kalpak'),\r\n (S: 'kab'; L: 'Kabyle'),\r\n (S: 'kac'; L: 'Kachin'),\r\n (S: 'kal'; L: 'Kalaallisut'),\r\n (S: 'kam'; L: 'Kamba'),\r\n (S: 'kan'; L: 'Kannada'),\r\n (S: 'kar'; L: 'Karen'),\r\n (S: 'kas'; L: 'Kashmiri'),\r\n {210}(S: 'kat'; L: 'Georgian'), // Also 'geo'\r\n (S: 'kau'; L: 'Kanuri'),\r\n (S: 'kaw'; L: 'Kawi'),\r\n (S: 'kaz'; L: 'Kazakh'),\r\n (S: 'kbd'; L: 'Kabardian'),\r\n (S: 'kha'; L: 'Khasi'),\r\n (S: 'khi'; L: 'Khoisan (Other)'),\r\n (S: 'khm'; L: 'Khmer'),\r\n (S: 'kho'; L: 'Khotanese'),\r\n (S: 'kik'; L: 'Kikuyu; Gikuyu'),\r\n {220}(S: 'kin'; L: 'Kinyarwanda'),\r\n (S: 'kir'; L: 'Kirghiz'),\r\n (S: 'kmb'; L: 'Kimbundu'),\r\n (S: 'kok'; L: 'Konkani'),\r\n (S: 'kom'; L: 'Komi'),\r\n (S: 'kon'; L: 'Kongo'),\r\n (S: 'kor'; L: 'Korean'),\r\n (S: 'kos'; L: 'Kosraean'),\r\n (S: 'kpe'; L: 'Kpelle'),\r\n (S: 'kro'; L: 'Kru'),\r\n {230}(S: 'kru'; L: 'Kurukh'),\r\n (S: 'kua'; L: 'Kuanyama; Kwanyama'),\r\n (S: 'kum'; L: 'Kumyk'),\r\n (S: 'kur'; L: 'Kurdish'),\r\n (S: 'kut'; L: 'Kutenai'),\r\n (S: 'lad'; L: 'Ladino'),\r\n (S: 'lah'; L: 'Lahnda'),\r\n (S: 'lam'; L: 'Lamba'),\r\n (S: 'lao'; L: 'Lao'),\r\n (S: 'lat'; L: 'Latin'),\r\n {240}(S: 'lav'; L: 'Latvian'),\r\n (S: 'lez'; L: 'Lezghian'),\r\n (S: 'lim'; L: 'Limburgan'),\r\n (S: 'lin'; L: 'Lingala'),\r\n (S: 'lit'; L: 'Lithuanian'),\r\n (S: 'lol'; L: 'Mongo'),\r\n (S: 'loz'; L: 'Lozi'),\r\n (S: 'ltz'; L: 'Luxembourgish'),\r\n (S: 'lua'; L: 'Luba-Lulua'),\r\n (S: 'lub'; L: 'Luba-Katanga'),\r\n {250}(S: 'lug'; L: 'Ganda'),\r\n (S: 'lui'; L: 'Luiseno'),\r\n (S: 'lun'; L: 'Lunda'),\r\n (S: 'luo'; L: 'Luo (Kenya and Tanzania)'),\r\n (S: 'lus'; L: 'Lushai'),\r\n (S: 'mac'; L: 'Macedonian'), // Also 'mkd'\r\n (S: 'mad'; L: 'Madurese'),\r\n (S: 'mag'; L: 'Magahi'),\r\n (S: 'mah'; L: 'Marshallese'),\r\n (S: 'mai'; L: 'Maithili'),\r\n {260}(S: 'mak'; L: 'Makasar'),\r\n (S: 'mal'; L: 'Malayalam'),\r\n (S: 'man'; L: 'Mandingo'),\r\n (S: 'mao'; L: 'Maori'), // Also 'mri'\r\n (S: 'map'; L: 'Austronesian (Other)'),\r\n (S: 'mar'; L: 'Marathi'),\r\n (S: 'mas'; L: 'Masai'),\r\n (S: 'may'; L: 'Malay'), // Also 'msa'\r\n (S: 'mdr'; L: 'Mandar'),\r\n (S: 'men'; L: 'Mende'),\r\n {270}(S: 'mga'; L: 'Irish, Middle (900-1200)'),\r\n (S: 'mic'; L: 'Micmac'),\r\n (S: 'min'; L: 'Minangkabau'),\r\n (S: 'mis'; L: 'Miscellaneous languages'),\r\n (S: 'mkd'; L: 'Macedonian'), // Also 'mac'\r\n (S: 'mkh'; L: 'Mon-Khmer (Other)'),\r\n (S: 'mlg'; L: 'Malagasy'),\r\n (S: 'mlt'; L: 'Maltese'),\r\n (S: 'mnc'; L: 'Manchu'),\r\n (S: 'mni'; L: 'Manipuri'),\r\n {280}(S: 'mno'; L: 'Manobo languages'),\r\n (S: 'moh'; L: 'Mohawk'),\r\n (S: 'mol'; L: 'Moldavian'),\r\n (S: 'mon'; L: 'Mongolian'),\r\n (S: 'mos'; L: 'Mossi'),\r\n (S: 'mri'; L: 'Maori'), // Also 'mao'\r\n (S: 'msa'; L: 'Malay'), // Also 'may'\r\n (S: 'mul'; L: 'Multiple languages'),\r\n (S: 'mun'; L: 'Munda languages'),\r\n (S: 'mus'; L: 'Creek'),\r\n {290}(S: 'mwr'; L: 'Marwari'),\r\n (S: 'mya'; L: 'Burmese'), // Also 'bur'\r\n (S: 'myn'; L: 'Mayan languages'),\r\n (S: 'nah'; L: 'Nahuatl'),\r\n (S: 'nai'; L: 'North American Indian (Other)'),\r\n (S: 'nap'; L: 'Neapolitan'),\r\n (S: 'nau'; L: 'Nauru'),\r\n (S: 'nav'; L: 'Navajo; Navaho'),\r\n (S: 'nbl'; L: 'Ndebele, South'),\r\n (S: 'nde'; L: 'Ndebele, North'),\r\n {300}(S: 'ndo'; L: 'Ndonga'),\r\n (S: 'nds'; L: 'German, Low'),\r\n (S: 'nep'; L: 'Nepali'),\r\n (S: 'new'; L: 'Newari'),\r\n (S: 'nia'; L: 'Nias'),\r\n (S: 'nic'; L: 'Niger-Kordofanian (Other)'),\r\n (S: 'niu'; L: 'Niuean'),\r\n (S: 'nld'; L: 'Dutch'), // Also 'dut'\r\n (S: 'nno'; L: 'Nynorsk, Norwegian'),\r\n (S: 'nob'; L: 'Bokml, Norwegian'),\r\n {310}(S: 'non'; L: 'Norse, Old'),\r\n (S: 'nor'; L: 'Norwegian'),\r\n (S: 'nso'; L: 'Sotho, Northern'),\r\n (S: 'nub'; L: 'Nubian languages'),\r\n (S: 'nya'; L: 'Chichewa'),\r\n (S: 'nym'; L: 'Nyamwezi'),\r\n (S: 'nyn'; L: 'Nyankole'),\r\n (S: 'nyo'; L: 'Nyoro'),\r\n (S: 'nzi'; L: 'Nzima'),\r\n (S: 'oci'; L: 'Occitan (post 1500); Provenal'),\r\n {320}(S: 'oji'; L: 'Ojibwa'),\r\n (S: 'ori'; L: 'Oriya'),\r\n (S: 'orm'; L: 'Oromo'),\r\n (S: 'osa'; L: 'Osage'),\r\n (S: 'oss'; L: 'Ossetian'),\r\n (S: 'ota'; L: 'Turkish, Ottoman (1500-1928)'),\r\n (S: 'oto'; L: 'Otomian languages'),\r\n (S: 'paa'; L: 'Papuan (Other)'),\r\n (S: 'pag'; L: 'Pangasinan'),\r\n (S: 'pal'; L: 'Pahlavi'),\r\n {330}(S: 'pam'; L: 'Pampanga'),\r\n (S: 'pan'; L: 'Panjabi'),\r\n (S: 'pap'; L: 'Papiamento'),\r\n (S: 'pau'; L: 'Palauan'),\r\n (S: 'peo'; L: 'Persian, Old (ca.600-400)'),\r\n (S: 'per'; L: 'Persian'), // Also 'fas'\r\n (S: 'phi'; L: 'Philippine (Other)'),\r\n (S: 'phn'; L: 'Phoenician'),\r\n (S: 'pli'; L: 'Pali'),\r\n (S: 'pol'; L: 'Polish'),\r\n {340}(S: 'pon'; L: 'Pohnpeian'),\r\n (S: 'por'; L: 'Portuguese'),\r\n (S: 'pra'; L: 'Prakrit languages'),\r\n (S: 'pro'; L: 'Provenal, Old (to 1500)'),\r\n (S: 'pus'; L: 'Pushto'),\r\n (S: 'qtz'; L: 'Reserved for local user; qaa'),\r\n (S: 'que'; L: 'Quechua'),\r\n (S: 'raj'; L: 'Rajasthani'),\r\n (S: 'rap'; L: 'Rapanui'),\r\n (S: 'rar'; L: 'Rarotongan'),\r\n {350}(S: 'roa'; L: 'Romance (Other)'),\r\n (S: 'roh'; L: 'Raeto-Romance'),\r\n (S: 'rom'; L: 'Romany'),\r\n (S: 'ron'; L: 'Romanian'), // Also 'rum'\r\n (S: 'rum'; L: 'Romanian'), // Also 'ron'\r\n (S: 'run'; L: 'Rundi'),\r\n (S: 'rus'; L: 'Russian'),\r\n (S: 'sad'; L: 'Sandawe'),\r\n (S: 'sag'; L: 'Sango'),\r\n (S: 'sah'; L: 'Yakut'),\r\n {360}(S: 'sai'; L: 'South American Indian (Other)'),\r\n (S: 'sal'; L: 'Salishan languages'),\r\n (S: 'sam'; L: 'Samaritan Aramaic'),\r\n (S: 'san'; L: 'Sanskrit'),\r\n (S: 'sas'; L: 'Sasak'),\r\n (S: 'sat'; L: 'Santali'),\r\n (S: 'scc'; L: 'Serbian'), // Also 'srp'\r\n (S: 'sco'; L: 'Scots'),\r\n (S: 'scr'; L: 'Croatian'), // Also 'hrv'\r\n (S: 'sel'; L: 'Selkup'),\r\n {370}(S: 'sem'; L: 'Semitic (Other)'),\r\n (S: 'sga'; L: 'Irish, Old (to 900)'),\r\n (S: 'sgn'; L: 'Sign languages'),\r\n (S: 'shn'; L: 'Shan'),\r\n (S: 'sid'; L: 'Sidamo'),\r\n (S: 'sin'; L: 'Sinhalese'),\r\n (S: 'sio'; L: 'Siouan languages'),\r\n (S: 'sit'; L: 'Sino-Tibetan (Other)'),\r\n (S: 'sla'; L: 'Slavic (Other)'),\r\n (S: 'slk'; L: 'Slovak'), // Also 'slo'\r\n {380}(S: 'slo'; L: 'Slovak'), // Also 'slk'\r\n (S: 'slv'; L: 'Slovenian'),\r\n (S: 'sma'; L: 'Southern Sami'),\r\n (S: 'sme'; L: 'Northern Sami'),\r\n (S: 'smi'; L: 'Sami languages (Other)'),\r\n (S: 'smj'; L: 'Lule Sami'),\r\n (S: 'smn'; L: 'Inari Sami'),\r\n (S: 'smo'; L: 'Samoan'),\r\n (S: 'sms'; L: 'Skolt Sami'),\r\n (S: 'sna'; L: 'Shona'),\r\n {390}(S: 'snd'; L: 'Sindhi'),\r\n (S: 'snk'; L: 'Soninke'),\r\n (S: 'sog'; L: 'Sogdian'),\r\n (S: 'som'; L: 'Somali'),\r\n (S: 'son'; L: 'Songhai'),\r\n (S: 'sot'; L: 'Sotho, Southern'),\r\n (S: 'spa'; L: 'Spanish; Castilian'),\r\n (S: 'sqi'; L: 'Albanian'), // Also 'alb'\r\n (S: 'srd'; L: 'Sardinian'),\r\n (S: 'srp'; L: 'Serbian'), // Also 'scc'\r\n {400}(S: 'srr'; L: 'Serer'),\r\n (S: 'ssa'; L: 'Nilo-Saharan (Other)'),\r\n (S: 'ssw'; L: 'Swati'),\r\n (S: 'suk'; L: 'Sukuma'),\r\n (S: 'sun'; L: 'Sundanese'),\r\n (S: 'sus'; L: 'Susu'),\r\n (S: 'sux'; L: 'Sumerian'),\r\n (S: 'swa'; L: 'Swahili'),\r\n (S: 'swe'; L: 'Swedish'),\r\n (S: 'syr'; L: 'Syriac'),\r\n {410}(S: 'tah'; L: 'Tahitian'),\r\n (S: 'tai'; L: 'Tai (Other)'),\r\n (S: 'tam'; L: 'Tamil'),\r\n (S: 'tat'; L: 'Tatar'),\r\n (S: 'tel'; L: 'Telugu'),\r\n (S: 'tem'; L: 'Timne'),\r\n (S: 'ter'; L: 'Tereno'),\r\n (S: 'tet'; L: 'Tetum'),\r\n (S: 'tgk'; L: 'Tajik'),\r\n (S: 'tgl'; L: 'Tagalog'),\r\n {420}(S: 'tha'; L: 'Thai'),\r\n (S: 'tib'; L: 'Tibetan'), // Also 'bod'\r\n (S: 'tig'; L: 'Tigre'),\r\n (S: 'tir'; L: 'Tigrinya'),\r\n (S: 'tiv'; L: 'Tiv'),\r\n (S: 'tkl'; L: 'Tokelau'),\r\n (S: 'tli'; L: 'Tlingit'),\r\n (S: 'tmh'; L: 'Tamashek'),\r\n (S: 'tog'; L: 'Tonga (Nyasa)'),\r\n (S: 'ton'; L: 'Tonga (Tonga Islands)'),\r\n {430}(S: 'tpi'; L: 'Tok Pisin'),\r\n (S: 'tsi'; L: 'Tsimshian'),\r\n (S: 'tsn'; L: 'Tswana'),\r\n (S: 'tso'; L: 'Tsonga'),\r\n (S: 'tuk'; L: 'Turkmen'),\r\n (S: 'tum'; L: 'Tumbuka'),\r\n (S: 'tup'; L: 'Tupi languages'),\r\n (S: 'tur'; L: 'Turkish'),\r\n (S: 'tut'; L: 'Altaic (Other)'),\r\n (S: 'tvl'; L: 'Tuvalu'),\r\n {440}(S: 'twi'; L: 'Twi'),\r\n (S: 'tyv'; L: 'Tuvinian'),\r\n (S: 'uga'; L: 'Ugaritic'),\r\n (S: 'uig'; L: 'Uighur'),\r\n (S: 'ukr'; L: 'Ukrainian'),\r\n (S: 'umb'; L: 'Umbundu'),\r\n (S: 'und'; L: 'Undetermined'),\r\n (S: 'urd'; L: 'Urdu'),\r\n (S: 'uzb'; L: 'Uzbek'),\r\n (S: 'vai'; L: 'Vai'),\r\n {450}(S: 'ven'; L: 'Venda'),\r\n (S: 'vie'; L: 'Vietnamese'),\r\n (S: 'vol'; L: 'Volapk'),\r\n (S: 'vot'; L: 'Votic'),\r\n (S: 'wak'; L: 'Wakashan languages'),\r\n (S: 'wal'; L: 'Walamo'),\r\n (S: 'war'; L: 'Waray'),\r\n (S: 'was'; L: 'Washo'),\r\n (S: 'wel'; L: 'Welsh'), // Also 'cym'\r\n (S: 'wen'; L: 'Sorbian languages'),\r\n {460}(S: 'wln'; L: 'Walloon'),\r\n (S: 'wol'; L: 'Wolof'),\r\n (S: 'xho'; L: 'Xhosa'),\r\n (S: 'yao'; L: 'Yao'),\r\n (S: 'yap'; L: 'Yapese'),\r\n (S: 'yid'; L: 'Yiddish'),\r\n (S: 'yor'; L: 'Yoruba'),\r\n (S: 'ypk'; L: 'Yupik languages'),\r\n (S: 'zap'; L: 'Zapotec'),\r\n (S: 'zen'; L: 'Zenaga'),\r\n {470}(S: 'zha'; L: 'Zhuang; Chuang'),\r\n (S: 'zho'; L: 'Chinese'), // Also 'chi'\r\n (S: 'znd'; L: 'Zande'),\r\n (S: 'zul'; L: 'Zulu'),\r\n (S: 'zun'; L: 'Zuni')\r\n );\r\n\r\n CID3Genres: array[0..147] of PAnsiChar = (\r\n\r\n { The following genres are defined in ID3v1 }\r\n\r\n {0}'Blues',\r\n 'Classic Rock',\r\n 'Country',\r\n 'Dance',\r\n 'Disco',\r\n 'Funk',\r\n 'Grunge',\r\n 'Hip-Hop',\r\n 'Jazz',\r\n 'Metal',\r\n {10}'New Age',\r\n 'Oldies',\r\n 'Other', { <= Default }\r\n 'Pop',\r\n 'R&B',\r\n 'Rap',\r\n 'Reggae',\r\n 'Rock',\r\n 'Techno',\r\n 'Industrial',\r\n {20}'Alternative',\r\n 'Ska',\r\n 'Death Metal',\r\n 'Pranks',\r\n 'Soundtrack',\r\n 'Euro-Techno',\r\n 'Ambient',\r\n 'Trip-Hop',\r\n 'Vocal',\r\n 'Jazz+Funk',\r\n {30}'Fusion',\r\n 'Trance',\r\n 'Classical',\r\n 'Instrumental',\r\n 'Acid',\r\n 'House',\r\n 'Game',\r\n 'Sound Clip',\r\n 'Gospel',\r\n 'Noise',\r\n {40}'AlternRock',\r\n 'Bass',\r\n 'Soul',\r\n 'Punk',\r\n 'Space',\r\n 'Meditative',\r\n 'Instrumental Pop',\r\n 'Instrumental Rock',\r\n 'Ethnic',\r\n 'Gothic',\r\n {50}'Darkwave',\r\n 'Techno-Industrial',\r\n 'Electronic',\r\n 'Pop-Folk',\r\n 'Eurodance',\r\n 'Dream',\r\n 'Southern Rock',\r\n 'Comedy',\r\n 'Cult',\r\n 'Gangsta',\r\n {60}'Top 40',\r\n 'Christian Rap',\r\n 'Pop/Funk',\r\n 'Jungle',\r\n 'Native American',\r\n 'Cabaret',\r\n 'New Wave',\r\n 'Psychedelic', // = 'Psychadelic' in ID3 docs, 'Psychedelic' in winamp.\r\n 'Rave',\r\n 'Showtunes',\r\n {70}'Trailer',\r\n 'Lo-Fi',\r\n 'Tribal',\r\n 'Acid Punk',\r\n 'Acid Jazz',\r\n 'Polka',\r\n 'Retro',\r\n 'Musical',\r\n 'Rock & Roll',\r\n 'Hard Rock',\r\n\r\n { The following genres are Winamp extensions }\r\n\r\n {80}'Folk',\r\n 'Folk-Rock',\r\n 'National Folk',\r\n 'Swing',\r\n 'Fast Fusion',\r\n 'Bebob',\r\n 'Latin',\r\n 'Revival',\r\n 'Celtic',\r\n 'Bluegrass',\r\n {90}'Avantgarde',\r\n 'Gothic Rock',\r\n 'Progressive Rock',\r\n 'Psychedelic Rock',\r\n 'Symphonic Rock',\r\n 'Slow Rock',\r\n 'Big Band',\r\n 'Chorus',\r\n 'Easy Listening',\r\n 'Acoustic',\r\n {100}'Humour',\r\n 'Speech',\r\n 'Chanson',\r\n 'Opera',\r\n 'Chamber Music',\r\n 'Sonata',\r\n 'Symphony',\r\n 'Booty Bass',\r\n 'Primus',\r\n 'Porn Groove',\r\n {110}'Satire',\r\n 'Slow Jam',\r\n 'Club',\r\n 'Tango',\r\n 'Samba',\r\n 'Folklore',\r\n 'Ballad',\r\n 'Power Ballad',\r\n 'Rhythmic Soul',\r\n 'Freestyle',\r\n {120}'Duet',\r\n 'Punk Rock',\r\n 'Drum Solo',\r\n 'A capella', // A Capella\r\n 'Euro-House',\r\n 'Dance Hall',\r\n\r\n { winamp ?? genres }\r\n\r\n 'Goa',\r\n 'Drum & Bass',\r\n 'Club-House',\r\n 'Hardcore',\r\n {130}'Terror',\r\n 'Indie',\r\n 'BritPop',\r\n 'Negerpunk',\r\n 'Polsk Punk',\r\n 'Beat',\r\n 'Christian Gangsta Rap',\r\n 'Heavy Metal',\r\n 'Black Metal',\r\n 'Crossover',\r\n {140}'Contemporary Christian',\r\n 'Christian Rock',\r\n\r\n { winamp 1.91 genres }\r\n\r\n 'Merengue',\r\n 'Salsa',\r\n 'Trash Metal',\r\n\r\n { winamp 1.92 genres }\r\n\r\n 'Anime',\r\n 'JPop',\r\n 'SynthPop'\r\n );\r\n\r\n CGenre_HighV1 = 79;\r\n CGenre_DefaultID = 12;\r\n\r\n//=== Local procedures =======================================================\r\n\r\nfunction IndexOfLongString(Strings: TStrings; const ALongText: string): Integer;\r\n{ Searches for a string in Strings that is a prefix of ALongText, this is used\r\n by the ID3 genres; problem is that some strings may have the same prefix, ie\r\n\r\n Pop\r\n Pop/Funk\r\n Pop-Folk\r\n\r\n If we search for a prefix for 'Pop/Funk or something' the binary search\r\n may return 'Pop', thus we use FindFrom to search some more\r\n\r\n Note:\r\n\r\n 'Rock' => Result = 17\r\n 'Rocks' => Result = 255 (nothing found)\r\n 'Rock Rock' => Result = 17\r\n}\r\n\r\n function IsPrefix(const S: string): Boolean;\r\n begin\r\n Result := (AnsiStrLIComp(PChar(S), PChar(ALongText), Length(S)) = 0);\r\n end;\r\n\r\n function HasSpaceAfterPrefix(const Prefix: string): Boolean;\r\n { PRE: IsPrefix(Prefix) = True }\r\n var\r\n C: Integer;\r\n begin\r\n C := Length(Prefix) - Length(ALongText);\r\n Result := (C = 0) or ((C < 0) and (ALongText[Length(Prefix) + 1] = ' '));\r\n end;\r\n\r\n function FindFrom(const Index: Integer): Integer;\r\n begin\r\n { Try to find I with IsPrefix(Strings[I]) and HasSpaceAfterPrefix(Strings[i]) }\r\n\r\n if Length(Strings[Index]) < Length(ALongText) then\r\n begin\r\n { Now is valid: IsPrefix(Strings[Result]) }\r\n\r\n Result := Index + 1;\r\n\r\n { Strings is sorted thus it's only usefull to look at higher indexes than\r\n Index ie only at higher indexes are possibly longer prefixes of ALongText }\r\n while (Result < Strings.Count) and IsPrefix(Strings[Result]) do\r\n Inc(Result);\r\n\r\n { Strings[Result] is not ok, Strings[Result-1] is ok }\r\n Dec(Result);\r\n\r\n { Now is valid: IsPrefix(Strings[Result]) }\r\n end\r\n else\r\n if Length(ALongText) < Length(Strings[Index]) then\r\n begin\r\n Result := Index - 1;\r\n\r\n while (Result >= 0) and (Length(Strings[Result]) > Length(ALongText)) do\r\n if AnsiStrLIComp(PChar(Strings[Result]), PChar(ALongText), Length(ALongText)) = 0 then\r\n Dec(Result)\r\n else\r\n begin\r\n { Not found }\r\n Result := -1;\r\n Exit;\r\n end;\r\n\r\n if (Result < 0) or not IsPrefix(Strings[Result]) then\r\n begin\r\n { Not found }\r\n Result := -1;\r\n Exit;\r\n end;\r\n\r\n { Now is valid: IsPrefix(Strings[Result]) }\r\n end\r\n else\r\n begin\r\n { Found }\r\n Result := Index;\r\n Exit;\r\n end;\r\n\r\n { Now is valid: IsPrefix(Strings[Result]) }\r\n\r\n if HasSpaceAfterPrefix(Strings[Result]) then\r\n { Found }\r\n Exit;\r\n\r\n Dec(Result);\r\n\r\n { Now go down until we find a string X with X + some separator is a prefix\r\n of ALongText }\r\n while Result >= 0 do\r\n if IsPrefix(Strings[Result]) then\r\n begin\r\n if HasSpaceAfterPrefix(Strings[Result]) then\r\n { Found }\r\n Exit\r\n else\r\n Dec(Result);\r\n end\r\n else\r\n begin\r\n { Not found }\r\n Result := -1;\r\n Exit;\r\n end;\r\n end;\r\nvar\r\n Top, Mid, C: Integer;\r\nbegin\r\n Result := 0;\r\n Top := Strings.Count - 1;\r\n while Result <= Top do\r\n begin\r\n Mid := (Result + Top) shr 1;\r\n C := AnsiStrLIComp(PChar(Strings[Mid]), PChar(ALongText),\r\n Min(Length(Strings[Mid]), Length(ALongText)));\r\n if C < 0 then\r\n Result := Mid + 1\r\n else\r\n if C = 0 then\r\n begin\r\n Result := FindFrom(Mid);\r\n Exit;\r\n end\r\n else { C > 0 }\r\n Top := Mid - 1;\r\n end;\r\n\r\n { Nothing found }\r\n Result := -1;\r\nend;\r\n\r\n//=== Global procedures ======================================================\r\n\r\nfunction ID3_FrameIDToString(const ID: TJvID3FrameID; const Size: Integer): AnsiString;\r\nbegin\r\n case Size of\r\n 3:\r\n Result := CID3FrameDefs[ID].ShortTextID;\r\n 4:\r\n Result := CID3FrameDefs[ID].LongTextID;\r\n else\r\n raise EJVCLException.CreateRes(@RsEFrameIDSizeCanOnlyBe34);\r\n end;\r\nend;\r\n\r\nvar\r\n GID3TermFinder: TJvID3TermFinder = nil;\r\n\r\nfunction ID3TermFinder: TJvID3TermFinder;\r\nbegin\r\n if GID3TermFinder = nil then\r\n GID3TermFinder := TJvID3TermFinder.Create;\r\n Result := GID3TermFinder;\r\nend;\r\n\r\nprocedure ID3_Genres(Strings: TStrings; const InclWinampGenres: Boolean);\r\nbegin\r\n ID3TermFinder.ID3Genres(Strings, InclWinampGenres);\r\nend;\r\n\r\nfunction ID3_GenreToID(const AGenre: string; const InclWinampGenres: Boolean): Integer;\r\nbegin\r\n Result := ID3TermFinder.ID3GenreToID(AGenre, True);\r\nend;\r\n\r\nfunction ID3_IDToGenre(const ID: Integer; const InclWinampGenres: Boolean): string;\r\nconst\r\n HighValue: array [Boolean] of Byte = (CGenre_HighV1, High(CID3Genres));\r\nbegin\r\n { Note : In Winamp, ID = 255 then Genre = '' }\r\n if (ID >= Low(CID3Genres)) and (ID <= HighValue[InclWinampGenres]) then\r\n Result := string(CID3Genres[ID])\r\n else\r\n Result := '';\r\nend;\r\n\r\nfunction ID3_LongGenreToID(const ALongGenre: string; const InclWinampGenres: Boolean = True): Integer;\r\nbegin\r\n Result := ID3TermFinder.ID3LongGenreToID(ALongGenre, InclWinampGenres);\r\nend;\r\n\r\nfunction ID3_StringToFrameID(const S: AnsiString): TJvID3FrameID;\r\nvar\r\n L: Integer;\r\nbegin\r\n L := Length(S);\r\n case L of\r\n 0:\r\n Result := fiPaddingFrame;\r\n 3:\r\n if S = #0#0#0 then\r\n Result := fiPaddingFrame\r\n else\r\n Result := ID3TermFinder.ID3ShortTextToFrameID(S);\r\n 4:\r\n if S = #0#0#0#0 then\r\n Result := fiPaddingFrame\r\n else\r\n Result := ID3TermFinder.ID3LongTextToFrameID(S);\r\n else\r\n Result := fiErrorFrame\r\n end;\r\nend;\r\n\r\nfunction ISO_639_2CodeToName(const Code: AnsiString): AnsiString;\r\nvar\r\n Index: Integer;\r\nbegin\r\n if Length(Code) <> 3 then\r\n begin\r\n Result := '';\r\n Exit;\r\n end;\r\n\r\n Index := ID3TermFinder.ISO_639_2CodeToIndex(Code);\r\n if Index >= Low(CISO_639_2Data) then\r\n Result := CISO_639_2Data[Index].L\r\n else\r\n Result := '';\r\nend;\r\n\r\nfunction ISO_639_2IsCode(const Code: AnsiString): Boolean;\r\nbegin\r\n Result := (Length(Code) = 3) and\r\n (ID3TermFinder.ISO_639_2CodeToIndex(Code) >= Low(CISO_639_2Data));\r\nend;\r\n\r\nprocedure ISO_639_2Names(Strings: TStrings);\r\nbegin\r\n ID3TermFinder.ISO_639_2Names(Strings);\r\nend;\r\n\r\nfunction ISO_639_2NameToCode(const Name: string): AnsiString;\r\nvar\r\n Index: Integer;\r\nbegin\r\n Index := ID3TermFinder.ISO_639_2NameToIndex(Name);\r\n if (Index < Low(CISO_639_2Data)) or (Index > High(CISO_639_2Data)) then\r\n Result := ''\r\n else\r\n Result := CISO_639_2Data[Index].S;\r\nend;\r\n\r\n//=== { TJvID3TermFinder } ===================================================\r\n\r\nconstructor TJvID3TermFinder.Create;\r\nvar\r\n ListType: TJvListType;\r\nbegin\r\n inherited Create;\r\n for ListType := Low(TJvListType) to High(TJvListType) do\r\n FLists[ListType] := nil;\r\nend;\r\n\r\ndestructor TJvID3TermFinder.Destroy;\r\nvar\r\n ListType: TJvListType;\r\nbegin\r\n for ListType := Low(TJvListType) to High(TJvListType) do\r\n FLists[ListType].Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvID3TermFinder.BuildList_ID3Genres;\r\nvar\r\n I: Integer;\r\nbegin\r\n if Assigned(FLists[ltID3Genres]) then\r\n Exit;\r\n\r\n FLists[ltID3Genres] := TStringList.Create;\r\n with FLists[ltID3Genres] do\r\n begin\r\n { There are no duplicates in the list }\r\n Duplicates := dupError;\r\n Sorted := True;\r\n\r\n for I := Low(CID3Genres) to High(CID3Genres) do\r\n AddObject(string(CID3Genres[I]), TObject(I));\r\n end;\r\nend;\r\n\r\nprocedure TJvID3TermFinder.BuildList_ID3LongText;\r\nvar\r\n FrameID: TJvID3FrameID;\r\nbegin\r\n if Assigned(FLists[ltID3LongText]) then\r\n Exit;\r\n\r\n FLists[ltID3LongText] := TStringList.Create;\r\n with FLists[ltID3LongText] do\r\n begin\r\n Duplicates := dupError;\r\n Sorted := True;\r\n\r\n for FrameID := Low(TJvID3FrameID) to High(TJvID3FrameID) do\r\n with CID3FrameDefs[FrameID] do\r\n if LongTextID[0] <> #0 then\r\n AddObject(string(LongTextID), TObject(FrameID));\r\n end;\r\nend;\r\n\r\nprocedure TJvID3TermFinder.BuildList_ID3ShortText;\r\nvar\r\n FrameID: TJvID3FrameID;\r\nbegin\r\n if Assigned(FLists[ltID3ShortText]) then\r\n Exit;\r\n\r\n FLists[ltID3ShortText] := TStringList.Create;\r\n with FLists[ltID3ShortText] do\r\n begin\r\n Duplicates := dupError;\r\n Sorted := True;\r\n\r\n for FrameID := Low(TJvID3FrameID) to High(TJvID3FrameID) do\r\n with CID3FrameDefs[FrameID] do\r\n if ShortTextID[0] <> #0 then\r\n AddObject(string(ShortTextID), TObject(FrameID));\r\n end;\r\nend;\r\n\r\nprocedure TJvID3TermFinder.BuildList_ISO_639_2Code;\r\nvar\r\n I: Integer;\r\nbegin\r\n if Assigned(FLists[ltISO_639_2Code]) then\r\n Exit;\r\n\r\n FLists[ltISO_639_2Code] := TStringList.Create;\r\n with FLists[ltISO_639_2Code] do\r\n begin\r\n { There are no duplicates in the list }\r\n Duplicates := dupError;\r\n Sorted := True;\r\n\r\n for I := Low(CISO_639_2Data) to High(CISO_639_2Data) do\r\n AddObject(string(CISO_639_2Data[I].S), TObject(I));\r\n end;\r\nend;\r\n\r\nprocedure TJvID3TermFinder.BuildList_ISO_639_2Name;\r\nvar\r\n I: Integer;\r\nbegin\r\n if Assigned(FLists[ltISO_639_2Name]) then\r\n Exit;\r\n\r\n FLists[ltISO_639_2Name] := TStringList.Create;\r\n with FLists[ltISO_639_2Name] do\r\n begin\r\n { There are duplicates in the list }\r\n Duplicates := dupIgnore;\r\n Sorted := True;\r\n\r\n for I := Low(CISO_639_2Data) to High(CISO_639_2Data) do\r\n AddObject(string(CISO_639_2Data[I].L), TObject(I));\r\n end;\r\nend;\r\n\r\nprocedure TJvID3TermFinder.ID3Genres(AStrings: TStrings;\r\n const InclWinampGenres: Boolean);\r\nvar\r\n I: Integer;\r\nbegin\r\n BuildList_ID3Genres;\r\n\r\n AStrings.BeginUpdate;\r\n try\r\n AStrings.Clear;\r\n\r\n { In Winamp, ID = 255 then Genre = '' }\r\n if InclWinampGenres then\r\n AStrings.AddObject('', TObject(255));\r\n\r\n for I := 0 to FLists[ltID3Genres].Count - 1 do\r\n if InclWinampGenres or (Integer(FLists[ltID3Genres].Objects[I]) <= CGenre_HighV1) then\r\n AStrings.AddObject(FLists[ltID3Genres][I], FLists[ltID3Genres].Objects[I]);\r\n finally\r\n AStrings.EndUpdate;\r\n end;\r\nend;\r\n\r\nfunction TJvID3TermFinder.ID3GenreToID(const AGenre: string; const InclWinampGenres: Boolean): Integer;\r\nconst\r\n { In Winamp, ID = 255 then Genre = '' }\r\n CDefaultGenre: array [Boolean] of Byte = (CGenre_DefaultID, 255);\r\nbegin\r\n BuildList_ID3Genres;\r\n\r\n if AGenre = '' then\r\n Result := CDefaultGenre[InclWinampGenres]\r\n else\r\n begin\r\n Result := FLists[ltID3Genres].IndexOf(AGenre);\r\n\r\n { Special case: 'Psychadelic' }\r\n if (Result < 0) and (CompareText(AGenre, 'psychadelic') = 0) then\r\n Result := FLists[ltID3Genres].IndexOf('Psychedelic');\r\n\r\n if not InclWinampGenres and (Result > CGenre_HighV1) then\r\n Result := -1;\r\n\r\n if Result >= 0 then\r\n Result := Integer(FLists[ltID3Genres].Objects[Result])\r\n else\r\n Result := cDefaultGenre[InclWinampGenres];\r\n end;\r\nend;\r\n\r\nfunction TJvID3TermFinder.ID3LongGenreToID(const ALongGenre: string;\r\n const InclWinampGenres: Boolean): Integer;\r\nconst\r\n { In Winamp, ID = 255 then Genre = '' }\r\n CDefaultGenre: array [Boolean] of Byte = (CGenre_DefaultID, 255);\r\nbegin\r\n BuildList_ID3Genres;\r\n\r\n if ALongGenre = '' then\r\n begin\r\n Result := CDefaultGenre[InclWinampGenres];\r\n Exit;\r\n end;\r\n\r\n Result := IndexOfLongString(FLists[ltID3Genres], string(ALongGenre));\r\n\r\n { Special case: 'Psychadelic' }\r\n if (Result < 0) and (AnsiStrLIComp(PChar(string(ALongGenre)), 'psychadelic', Length(ALongGenre)) = 0) then\r\n Result := FLists[ltID3Genres].IndexOf('Psychedelic');\r\n\r\n if not InclWinampGenres and (Result > CGenre_HighV1) then\r\n Result := -1;\r\n\r\n if Result >= 0 then\r\n Result := Integer(FLists[ltID3Genres].Objects[Result])\r\n else\r\n Result := CDefaultGenre[InclWinampGenres];\r\nend;\r\n\r\nfunction TJvID3TermFinder.ID3LongTextToFrameID(\r\n const S: AnsiString): TJvID3FrameID;\r\nvar\r\n I: Integer;\r\nbegin\r\n if not IsFrameOk(S) then\r\n begin\r\n Result := fiErrorFrame;\r\n Exit;\r\n end;\r\n\r\n BuildList_ID3LongText;\r\n\r\n I := FLists[ltID3LongText].IndexOf(string(S));\r\n if I < 0 then\r\n Result := fiUnknownFrame\r\n else\r\n Result := TJvID3FrameID(FLists[ltID3LongText].Objects[I]);\r\nend;\r\n\r\nfunction TJvID3TermFinder.ID3ShortTextToFrameID(\r\n const S: AnsiString): TJvID3FrameID;\r\nvar\r\n I: Integer;\r\nbegin\r\n if not IsFrameOk(S) then\r\n begin\r\n Result := fiErrorFrame;\r\n Exit;\r\n end;\r\n\r\n BuildList_ID3ShortText;\r\n\r\n I := FLists[ltID3ShortText].IndexOf(string(S));\r\n if I < 0 then\r\n Result := fiUnknownFrame\r\n else\r\n Result := TJvID3FrameID(FLists[ltID3ShortText].Objects[I]);\r\nend;\r\n\r\nfunction TJvID3TermFinder.IsFrameOk(const S: AnsiString): Boolean;\r\nvar\r\n I: Integer;\r\nbegin\r\n { The frame ID must be made out of the characters capital A-Z and 0-9. }\r\n Result := False;\r\n\r\n for I := 1 to Length(S) do\r\n if not CharInSet(S[I], (['A'..'Z'] + DigitChars)) then\r\n Exit;\r\n\r\n Result := True;\r\nend;\r\n\r\nfunction TJvID3TermFinder.ISO_639_2CodeToIndex(\r\n const ACode: AnsiString): Integer;\r\nbegin\r\n BuildList_ISO_639_2Code;\r\n\r\n Result := FLists[ltISO_639_2Code].IndexOf(string(AnsiLowerCase(ACode)));\r\n if Result >= 0 then\r\n Result := Integer(FLists[ltISO_639_2Code].Objects[Result]);\r\nend;\r\n\r\nprocedure TJvID3TermFinder.ISO_639_2Names(AStrings: TStrings);\r\nbegin\r\n BuildList_ISO_639_2Name;\r\n\r\n AStrings.Assign(FLists[ltISO_639_2Name]);\r\nend;\r\n\r\nfunction TJvID3TermFinder.ISO_639_2NameToIndex(\r\n const AName: string): Integer;\r\nbegin\r\n BuildList_ISO_639_2Name;\r\n\r\n Result := FLists[ltISO_639_2Name].IndexOf(AName);\r\n if Result >= 0 then\r\n Result := Integer(FLists[ltISO_639_2Name].Objects[Result]);\r\nend;\r\n\r\ninitialization\r\n {$IFDEF UNITVERSIONING}\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n {$ENDIF UNITVERSIONING}\r\n\r\nfinalization\r\n FreeAndNil(GID3TermFinder);\r\n {$IFDEF UNITVERSIONING}\r\n UnregisterUnitVersion(HInstance);\r\n {$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvImage.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvImage.PAS, released on 2001-02-28.\r\n\r\nThe Initial Developer of the Original Code is Sbastien Buysse [sbuysse att buypin dott com]\r\nPortions created by Sbastien Buysse are Copyright (C) 2001 Sbastien Buysse.\r\nAll Rights Reserved.\r\n\r\nContributor(s): Michael Beck [mbeck att bigfoot dott com].\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvImage.pas 13321 2012-06-12 12:52:12Z obones $\r\n\r\nunit JvImage;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, SysUtils, Classes, Graphics, ExtCtrls, Controls, Forms,\r\n JvExExtCtrls;\r\n\r\ntype\r\n TPicState = (stDefault, stEntered, stClicked1, stClicked2, stDown, stDisabled);\r\n\r\n TJvPictures = class(TPersistent)\r\n private\r\n FOnChanged: TNotifyEvent;\r\n FPicClicked1: TPicture;\r\n FPicClicked2: TPicture;\r\n FPicDown: TPicture;\r\n FPicEnter: TPicture;\r\n FPicDisabled: TPicture;\r\n procedure SetPicClicked(const Value: TPicture);\r\n procedure SetPicClicked2(const Value: TPicture);\r\n procedure SetPicDown(const Value: TPicture);\r\n procedure SetPicEnter(const Value: TPicture);\r\n procedure SetPicDisabled(const Value: TPicture);\r\n protected\r\n property OnChanged: TNotifyEvent read FOnChanged write FOnChanged;\r\n procedure Changed;\r\n public\r\n constructor Create;\r\n destructor Destroy; override;\r\n published\r\n property PicEnter: TPicture read FPicEnter write SetPicEnter;\r\n property PicClicked1: TPicture read FPicClicked1 write SetPicClicked;\r\n property PicClicked2: TPicture read FPicClicked2 write SetPicClicked2;\r\n property PicDown: TPicture read FPicDown write SetPicDown;\r\n property PicDisabled:TPicture read FPicDisabled write SetPicDisabled;\r\n end;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvImage = class(TJvExImage)\r\n private\r\n FOnStateChanged: TNotifyEvent;\r\n FPictures: TJvPictures;\r\n FState: TPicState;\r\n FPicture: TPicture;\r\n FClickCount: Integer;\r\n FPictureChange: TNotifyEvent;\r\n FDrawing: Boolean;\r\n procedure SetState(Value: TPicState);\r\n procedure PicturesChanged(Sender: TObject);\r\n procedure DoPictureChange(Sender: TObject);\r\n procedure DoOwnPictureChange(Sender: TObject);\r\n procedure SetPicture(const Value: TPicture);\r\n procedure ApplyClick;\r\n function UsesPictures: Boolean;\r\n protected\r\n procedure Click; override;\r\n procedure Paint; override;\r\n procedure SetEnabled(Value: Boolean); override;\r\n procedure MouseEnter(Control: TControl); override;\r\n procedure MouseLeave(Control: TControl); override;\r\n function HitTest(X, Y: Integer): Boolean; override;\r\n procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;\r\n procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n procedure LoadFromStream(AStream: TStream); virtual;\r\n published\r\n property HintColor;\r\n property Pictures: TJvPictures read FPictures write FPictures;\r\n property Picture: TPicture read FPicture write SetPicture;\r\n property State: TPicState read FState write SetState default stDefault;\r\n property OnMouseEnter;\r\n property OnMouseLeave;\r\n property OnStateChanged: TNotifyEvent read FOnStateChanged write FOnStateChanged;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvImage.pas $';\r\n Revision: '$Revision: 13321 $';\r\n Date: '$Date: 2012-06-12 14:52:12 +0200 (mar. 12 juin 2012) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n JvJVCLUtils;\r\n\r\n//=== { TJvImage } ===========================================================\r\n\r\nconstructor TJvImage.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FState := stDefault;\r\n FPictures := TJvPictures.Create;\r\n FPictures.OnChanged := PicturesChanged;\r\n FPicture := TPicture.Create;\r\n FPicture.OnChange := DoOwnPictureChange;\r\n FPictureChange := inherited Picture.OnChange;\r\n inherited Picture.OnChange := DoPictureChange;\r\nend;\r\n\r\ndestructor TJvImage.Destroy;\r\nbegin\r\n inherited Picture.OnChange := FPictureChange;\r\n FPictureChange := nil;\r\n FPictures.Free;\r\n FPicture.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvImage.ApplyClick;\r\nbegin\r\n case FClickCount of\r\n 1:\r\n begin\r\n State := stClicked1;\r\n if State <> stClicked1 then\r\n begin\r\n FClickCount := 0;\r\n State := stDefault;\r\n end;\r\n end;\r\n 2:\r\n begin\r\n State := stClicked2;\r\n if State <> stClicked2 then\r\n begin\r\n FClickCount := 0;\r\n State := stDefault;\r\n end;\r\n end;\r\n 0, 3:\r\n begin\r\n State := stDefault;\r\n FClickCount := 0;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvImage.Click;\r\nbegin\r\n inherited Click;\r\n if UsesPictures then\r\n begin\r\n Inc(FClickCount);\r\n ApplyClick;\r\n end;\r\nend;\r\n\r\nprocedure TJvImage.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);\r\nbegin\r\n inherited MouseDown(Button, Shift, X, Y);\r\n if UsesPictures then\r\n State := stDown;\r\nend;\r\n\r\nprocedure TJvImage.MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);\r\nbegin\r\n inherited MouseUp(Button, Shift, X, Y);\r\n if not UsesPictures or (State = stClicked1) or (State = stClicked2) then\r\n Exit;\r\n if (X > 0) and (X < Width) and (Y > 0) and (Y < Height) then\r\n begin\r\n SetState(stEntered);\r\n if State <> stEntered then\r\n ApplyClick;\r\n end\r\n else\r\n ApplyClick;\r\nend;\r\n\r\nprocedure TJvImage.MouseEnter(Control: TControl);\r\nbegin\r\n if csDesigning in ComponentState then\r\n Exit;\r\n if not MouseOver then\r\n begin\r\n if UsesPictures and Enabled then\r\n State := stEntered;\r\n inherited MouseEnter(Control);\r\n end;\r\nend;\r\n\r\nprocedure TJvImage.MouseLeave(Control: TControl);\r\nbegin\r\n if MouseOver then\r\n begin\r\n if UsesPictures and Enabled then\r\n ApplyClick;\r\n inherited MouseLeave(Control);\r\n end;\r\nend;\r\n\r\n// (rom) improvement. now only non-transparent pixels are considered\r\n// (rom) part of the clickable area\r\n// (p3) NB!!! This only works if TGraphic is a TBitmap! For PNG and JPG images, the result is that\r\n// the FPicture is cleared when \"Assigned(Picture.Bitmap)\" is called!\r\n// A (somewhat) better solution would be to replace the test with\r\n// \"if Assigned(Picture) and (Picture.Graphic is TBitmap) and Transparent and\"...\r\n// but then the PicEnter image will be assigned as soon as the mouse enters the component as no\r\n// transparency detection is possible (TGraphic doesn't have the necessary TransparentColor and Canvas.Pixels)\r\n// (rom) improved\r\n\r\nfunction TJvImage.HitTest(X, Y: Integer): Boolean;\r\nbegin\r\n Result := inherited HitTest(X, Y);\r\n if (not UsesPictures) and Assigned(Picture) and (Picture.Graphic is TBitmap) and\r\n Transparent and (X < Picture.Bitmap.Width) and (Y < Picture.Bitmap.Height) and\r\n (Picture.Bitmap.Canvas.Pixels[X, Y] = ColorToRGB(Picture.Bitmap.TransparentColor)) then\r\n Result := False;\r\nend;\r\n\r\nprocedure TJvImage.DoOwnPictureChange(Sender: TObject);\r\nvar\r\n G: TGraphic;\r\n D: TRect;\r\nbegin\r\n // All this code is required for Transparent, Center and other inherited\r\n // properties to work fine.\r\n G := Picture.Graphic;\r\n if G <> nil then\r\n begin\r\n if not ((G is TMetaFile) or (G is TIcon)) then\r\n G.Transparent := inherited Transparent;\r\n D := DestRect;\r\n if (not G.Transparent) and (D.Left <= 0) and (D.Top <= 0) and\r\n (D.Right >= Width) and (D.Bottom >= Height) then\r\n ControlStyle := ControlStyle + [csOpaque]\r\n else // picture might not cover entire clientrect\r\n ControlStyle := ControlStyle - [csOpaque];\r\n if DoPaletteChange and FDrawing then\r\n Update;\r\n end\r\n else ControlStyle := ControlStyle - [csOpaque];\r\n if not FDrawing then\r\n Invalidate;\r\n\r\n inherited Picture.Assign(FPicture);\r\nend;\r\n\r\nprocedure TJvImage.Paint;\r\nbegin\r\n FDrawing := True;\r\n try\r\n inherited Paint;\r\n finally\r\n FDrawing := False;\r\n end;\r\nend;\r\n\r\nprocedure TJvImage.PicturesChanged(Sender: TObject);\r\nbegin\r\n if UsesPictures then\r\n SetState(State);\r\nend;\r\n\r\nprocedure TJvImage.SetEnabled(Value: Boolean);\r\nbegin\r\n if Value <> Enabled then\r\n begin\r\n if not Value then\r\n State := stDisabled\r\n else\r\n State := stDefault;\r\n end;\r\n\r\n inherited SetEnabled(Value);\r\nend;\r\n\r\nprocedure TJvImage.SetPicture(const Value: TPicture);\r\nbegin\r\n FPicture.Assign(Value);\r\nend;\r\n\r\nprocedure TJvImage.SetState(Value: TPicState);\r\n\r\n function NotEmpty(Value: TPicture): Boolean;\r\n begin\r\n Result := (Value <> nil) and (Value.Width > 0) and (Value.Height > 0);\r\n end;\r\n\r\nbegin\r\n case Value of\r\n stDefault:\r\n if NotEmpty(FPicture) then\r\n begin\r\n inherited Picture.Assign(FPicture);\r\n FState := Value;\r\n end;\r\n stEntered:\r\n if NotEmpty(Pictures.PicEnter) then\r\n begin\r\n inherited Picture.Assign(Pictures.PicEnter);\r\n FState := Value;\r\n end;\r\n stClicked1:\r\n if NotEmpty(Pictures.PicClicked1) then\r\n begin\r\n inherited Picture.Assign(Pictures.PicClicked1);\r\n FState := Value;\r\n end;\r\n stClicked2:\r\n if NotEmpty(Pictures.PicClicked2) then\r\n begin\r\n inherited Picture.Assign(Pictures.PicClicked2);\r\n FState := Value;\r\n end;\r\n stDown:\r\n if NotEmpty(Pictures.PicDown) then\r\n begin\r\n inherited Picture.Assign(Pictures.PicDown);\r\n FState := Value;\r\n end;\r\n stDisabled:\r\n if NotEmpty(Pictures.PicDisabled) then\r\n begin\r\n inherited Picture.Assign(Pictures.PicDisabled);\r\n FState := Value;\r\n end;\r\n end;\r\n if Assigned(FOnStateChanged) then\r\n FOnStateChanged(Self);\r\nend;\r\n\r\nprocedure TJvImage.DoPictureChange(Sender: TObject);\r\nbegin\r\n Invalidate;\r\nend;\r\n\r\nfunction TJvImage.UsesPictures: Boolean;\r\nbegin\r\n Result := Assigned(Pictures.PicEnter.Graphic) or\r\n Assigned(Pictures.PicClicked1.Graphic) or\r\n Assigned(Pictures.PicClicked2.Graphic) or\r\n Assigned(Pictures.PicDown.Graphic) or\r\n Assigned(Pictures.PicDisabled.Graphic);\r\nend;\r\n\r\nprocedure TJvImage.LoadFromStream(AStream: TStream);\r\nvar\r\n G: TGraphic;\r\nbegin\r\n G := GetGraphicObject(AStream);\r\n try\r\n Picture.Assign(G);\r\n finally\r\n G.Free;\r\n end;\r\nend;\r\n\r\n//=== { TJvPictures } ========================================================\r\n\r\nconstructor TJvPictures.Create;\r\nbegin\r\n inherited Create;\r\n FPicClicked1 := TPicture.Create;\r\n FPicClicked2 := TPicture.Create;\r\n FPicDown := TPicture.Create;\r\n FPicEnter := TPicture.Create;\r\n FPicDisabled := TPicture.Create;\r\nend;\r\n\r\ndestructor TJvPictures.Destroy;\r\nbegin\r\n FPicClicked1.Free;\r\n FPicClicked2.Free;\r\n FPicDown.Free;\r\n FPicEnter.Free;\r\n FPicDisabled.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvPictures.Changed;\r\nbegin\r\n if Assigned(FOnChanged) then\r\n FOnChanged(Self);\r\nend;\r\n\r\nprocedure TJvPictures.SetPicClicked(const Value: TPicture);\r\nbegin\r\n FPicClicked1.Assign(Value);\r\n Changed;\r\nend;\r\n\r\nprocedure TJvPictures.SetPicClicked2(const Value: TPicture);\r\nbegin\r\n FPicClicked2.Assign(Value);\r\n Changed;\r\nend;\r\n\r\nprocedure TJvPictures.SetPicDisabled(const Value: TPicture);\r\nbegin\r\n FPicDisabled.Assign(Value);\r\n Changed;\r\nend;\r\n\r\nprocedure TJvPictures.SetPicDown(const Value: TPicture);\r\nbegin\r\n FPicDown.Assign(Value);\r\n Changed;\r\nend;\r\n\r\nprocedure TJvPictures.SetPicEnter(const Value: TPicture);\r\nbegin\r\n FPicEnter.Assign(Value);\r\n Changed;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvImageDlg.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvImageDlg.PAS, released on 2001-02-28.\r\n\r\nThe Initial Developer of the Original Code is Sbastien Buysse [sbuysse att buypin dott com]\r\nPortions created by Sbastien Buysse are Copyright (C) 2001 Sbastien Buysse.\r\nAll Rights Reserved.\r\n\r\nContributor(s): Michael Beck [mbeck att bigfoot dott com].\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvImageDlg.pas 13413 2012-09-08 11:02:21Z ahuser $\r\n\r\nunit JvImageDlg;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, SysUtils, Classes,\r\n Graphics, Controls, Forms, ExtCtrls,\r\n JvBaseDlg, JvComponent;\r\n\r\ntype\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvImageDialog = class(TJvCommonDialog)\r\n private\r\n FPicture: TPicture;\r\n FTitle: string;\r\n function GetPicture: TPicture;\r\n procedure SetPicture(const Value: TPicture);\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n published\r\n property Picture: TPicture read GetPicture write SetPicture;\r\n property Title: string read FTitle write FTitle;\r\n function Execute(ParentWnd: HWND): Boolean; overload; override;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvImageDlg.pas $';\r\n Revision: '$Revision: 13413 $';\r\n Date: '$Date: 2012-09-08 13:02:21 +0200 (sam. 08 sept. 2012) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n JvResources;\r\n\r\ntype\r\n TJvImageDlgForm = class(TJvForm)\r\n private\r\n FParentWnd: HWND;\r\n protected\r\n procedure CreateParams(var Params: TCreateParams); override;\r\n public\r\n constructor Create(AOwner: TComponent; AParentWnd: HWND); reintroduce;\r\n end;\r\n\r\n//=== { TJvImageDlgForm } ====================================================\r\n\r\nconstructor TJvImageDlgForm.Create(AOwner: TComponent; AParentWnd: HWND);\r\nbegin\r\n FParentWnd := AParentWnd;\r\n CreateNew(AOwner, 0);\r\nend;\r\n\r\nprocedure TJvImageDlgForm.CreateParams(var Params: TCreateParams);\r\nbegin\r\n inherited CreateParams(Params);\r\n if FParentWnd <> 0 then\r\n Params.WndParent := FParentWnd;\r\nend;\r\n\r\n\r\n//=== { TJvImageDialog } ====================================================\r\n\r\nconstructor TJvImageDialog.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FPicture := nil;\r\n FTitle := RsImageTitle;\r\nend;\r\n\r\ndestructor TJvImageDialog.Destroy;\r\nbegin\r\n FPicture.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJvImageDialog.Execute(ParentWnd: HWND): Boolean;\r\nvar\r\n Form: TJvImageDlgForm;\r\n Image1: TImage;\r\nbegin\r\n Result := False;\r\n if (Picture.Height <> 0) and (Picture.Width <> 0) then\r\n begin\r\n Form := TJvImageDlgForm.Create(Self, ParentWnd);\r\n try\r\n Form.BorderStyle := bsDialog;\r\n Form.BorderIcons := [biSystemMenu];\r\n Form.Position := poScreenCenter;\r\n Image1 := TImage.Create(Form);\r\n Image1.Picture.Assign(Picture);\r\n Image1.Parent := Form;\r\n Form.ClientHeight := Picture.Height;\r\n Form.ClientWidth := Picture.Width;\r\n Form.Caption := FTitle;\r\n Image1.SetBounds(0,0,Picture.Width,Picture.Height);\r\n Image1.Anchors := [akTop, akLeft, akRight, akBottom];\r\n Result := Form.ShowModal = mrOk;\r\n finally\r\n Form.Free;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJvImageDialog.GetPicture: TPicture;\r\nbegin\r\n if FPicture = nil then\r\n FPicture := TPicture.Create;\r\n Result := FPicture;\r\nend;\r\n\r\nprocedure TJvImageDialog.SetPicture(const Value: TPicture);\r\nbegin\r\n FPicture.Assign(Value);\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvImageDrawThread.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvImageRotate.PAS, released on 2001-02-28.\r\n\r\nThe Initial Developer of the Original Code is Sbastien Buysse [sbuysse att buypin dott com]\r\nPortions created by Sbastien Buysse are Copyright (C) 2001 Sbastien Buysse.\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\nMichael Beck [mbeck att bigfoot dott com].\r\nExtracted from JvImageThread and saved to a new unit by Peter Thrnqvist\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvImageDrawThread.pas 12962 2011-01-04 23:58:03Z jfudickar $\r\n\r\nunit JvImageDrawThread;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n JvThread,\r\n Windows,\r\n Classes;\r\n\r\ntype\r\n TJvImageDrawThread = class(TJvPausableThread)\r\n private\r\n FTag: Integer;\r\n FDelay: Cardinal;\r\n FOnDraw: TNotifyEvent;\r\n protected\r\n procedure Draw;\r\n procedure Execute; override;\r\n public\r\n procedure Synchronize(AMethod: TThreadMethod); overload;\r\n {$IFDEF RTL200_UP}\r\n procedure Synchronize(AThreadProc: TThreadProcedure); overload;\r\n {$ENDIF RTL200_UP}\r\n\r\n property Tag: Integer read FTag write FTag;\r\n property Delay: Cardinal read FDelay write FDelay;\r\n property OnDraw: TNotifyEvent read FOnDraw write FOnDraw;\r\n property Terminated;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvImageDrawThread.pas $';\r\n Revision: '$Revision: 12962 $';\r\n Date: '$Date: 2011-01-05 00:58:03 +0100 (mer. 05 janv. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\n\r\nprocedure TJvImageDrawThread.Draw;\r\nbegin\r\n if not Terminated and Assigned(FOnDraw) then\r\n FOnDraw(Self);\r\nend;\r\n\r\nprocedure TJvImageDrawThread.Execute;\r\nbegin\r\n NameThread(ThreadName);\r\n try\r\n while not Terminated do\r\n begin\r\n Sleep(FDelay);\r\n EnterUnpauseableSection;\r\n try\r\n if Terminated then\r\n Exit;\r\n\r\n Synchronize(Draw);\r\n finally\r\n LeaveUnpauseableSection;\r\n end;\r\n end;\r\n except\r\n // ignore exception\r\n end;\r\nend;\r\n\r\nprocedure TJvImageDrawThread.Synchronize(AMethod: TThreadMethod);\r\nbegin\r\n inherited Synchronize(AMethod);\r\nend;\r\n\r\n{$IFDEF RTL200_UP}\r\nprocedure TJvImageDrawThread.Synchronize(AThreadProc: TThreadProcedure);\r\nbegin\r\n inherited Synchronize(AThreadProc);\r\nend;\r\n{$ENDIF RTL200_UP}\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend." }, { "path": "External/Jedi/Jvcl/run/JvImageList.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvImageList.pas, released on 2003-10-09\r\n\r\nThe Initial Developers of the Original Code are: Andreas Hausladen \r\nCopyright (c) 2003 Andreas Hausladen\r\nAll Rights Reserved.\r\nPortions created by Uwe Schuster are Copyright (C) 2003, 2004 Uwe Schuster.\r\n\r\nContributor(s):\r\nUwe Schuster [jedivcs att bitcommander dott de]\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n ImageKind ikMappedResourceBitmap is not support so far\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvImageList.pas 13173 2011-11-19 12:43:58Z ahuser $\r\n\r\nunit JvImageList;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, CommCtrl, SysUtils, Classes, Graphics, Controls, ImgList;\r\n\r\ntype\r\n TJvImageListMode = (imClassic, imPicture, imResourceIds, imItemList);\r\n TJvImageListTransparentMode = (tmNone, tmAuto, tmColor);\r\n\r\n EJvImageListError = class(Exception);\r\n\r\n TJvImageListItemKind = (ikResourceBitmap, ikMappedResourceBitmap, ikInlineBitmap);\r\n\r\n TJvImageListItem = class(TCollectionItem)\r\n private\r\n FBitmap: TBitmap;\r\n FKind: TJvImageListItemKind;\r\n FResourceName: string;\r\n FTransparentColor: TColor;\r\n procedure AddToImageList(AImageList: TImageList);\r\n procedure BitmapChanged(Sender: TObject);\r\n function GetImageList: TImageList;\r\n procedure SetBitmap(ABitmap: TBitmap);\r\n procedure SetKind(AKind: TJvImageListItemKind);\r\n procedure SetResourceName(const AResourceName: string);\r\n procedure SetTransparentColor(AColor: TColor);\r\n procedure UpdateImageListItem(AImageList: TImageList; AIndex: Integer);\r\n protected\r\n function GetDisplayName: string; override;\r\n procedure SetIndex(Value: Integer); override;\r\n procedure Loaded; virtual;\r\n public\r\n constructor Create(Collection: Classes.TCollection); override;\r\n destructor Destroy; override;\r\n procedure Assign(Source: TPersistent); override;\r\n procedure UpdateImageList;\r\n published\r\n property Kind: TJvImageListItemKind read FKind write SetKind;\r\n property TransparentColor: TColor read FTransparentColor write SetTransparentColor;\r\n property Bitmap: TBitmap read FBitmap write SetBitmap;\r\n property ResourceName: string read FResourceName write SetResourceName;\r\n end;\r\n\r\n TJvImageListItems = class(TOwnedCollection)\r\n private\r\n function GetItem(AIndex: Integer): TJvImageListItem;\r\n procedure SetItem(AIndex: Integer; Value: TJvImageListItem);\r\n protected\r\n procedure Update(Item: TCollectionItem); override;\r\n procedure Loaded; virtual;\r\n public\r\n constructor Create(AOwner: TComponent);\r\n function Add: TJvImageListItem;\r\n property Items[AIndex: Integer]: TJvImageListItem read GetItem write SetItem; default;\r\n end;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvImageList = class(TCustomImageList)\r\n private\r\n FUpdateLock: Integer;\r\n FModified: Boolean;\r\n\r\n FItems: TJvImageListItems;\r\n FTransparentMode: TJvImageListTransparentMode;\r\n FTransparentColor: TColor;\r\n FPicture: TPicture;\r\n FFileName: TFileName;\r\n {$IFNDEF COMPILER12_UP}\r\n FPixelFormat: TPixelFormat;\r\n {$ENDIF ~COMPILER12_UP}\r\n FResourceIds: TStrings;\r\n FMode: TJvImageListMode;\r\n\r\n procedure SetFileName(const Value: TFileName);\r\n procedure SetItems(AItems: TJvImageListItems);\r\n procedure SetPicture(Value: TPicture);\r\n procedure SetTransparentMode(Value: TJvImageListTransparentMode);\r\n procedure SetTransparentColor(Value: TColor);\r\n procedure SetPixelFormat(const Value: TPixelFormat);\r\n procedure SetInternalHandle(Value: THandle);\r\n procedure SetResourceIds(Value: TStrings);\r\n procedure SetMode(const Value: TJvImageListMode);\r\n function GetPixelFormat: TPixelFormat;\r\n\r\n procedure SlicePictureToImageList;\r\n procedure ResourceIdsToImageList;\r\n procedure DoLoadFromFile;\r\n protected\r\n procedure ItemListError;\r\n procedure DefineProperties(Filer: TFiler); override;\r\n procedure InitializeImageList; virtual; // called by Initialize (VCL and VCLX)\r\n procedure Initialize; override;\r\n procedure Change; override;\r\n procedure DataChanged(Sender: TObject); virtual;\r\n procedure UpdateImageList;\r\n {$IFNDEF COMPILER12_UP}\r\n procedure HandleNeeded;\r\n procedure CreateImageList;\r\n {$ENDIF ~COMPILER12_UP}\r\n procedure Loaded; override;\r\n property FHandle: THandle write SetInternalHandle;\r\n public\r\n destructor Destroy; override;\r\n procedure Assign(Source: TPersistent); override;\r\n procedure BeginUpdate;\r\n procedure EndUpdate;\r\n procedure DrawIndirect(ImageListDrawParams: TImageListDrawParams);\r\n // DrawIndirect fills the .cbSize and .himl field.\r\n function Merge(Index1: Integer; ImageList: TImageList; Index2: Integer;\r\n dx, dy: Integer): TCustomImageList;\r\n // Merge creates a new TJvImageList and returns it. It is up to the user\r\n // to release this new image list.\r\n procedure SaveToFile(const FileName: string);\r\n procedure SaveToStream(Stream: TStream); virtual;\r\n procedure LoadFromFile(const FileName: string);\r\n procedure LoadFromStream(Stream: TStream); virtual;\r\n\r\n { imItemList }\r\n // (usc) DeleteItem, ClearItem and GetItemInfoStr are obsolete because the are\r\n // directly mapped to Items\r\n procedure AddItem(ABitmap: TBitmap; ATransparentColor: TColor); overload;\r\n // AddItem adds a bitmap to the ItemList with ATransparentColor as\r\n // transparent color. If the image list mode is not imItemList the image\r\n // list is cleared and the mode is set to imItemList.\r\n procedure AddItem(const AResourceName: string; ATransparentColor: TColor); overload;\r\n // AddItem adds the resource AResourceName from the HInstance libarary to\r\n // the ItemList with ATransparentColor as transparent color. If the image\r\n // list mode is not imItemList the image list is cleared and the mode is\r\n // set to imItemList.\r\n procedure DeleteItem(AIndex: Integer);\r\n // DeleteItem deletes the ItemList item that is identified by AIndex.\r\n // When the ImageList is not in imItenList mode the method raises an\r\n // RJvImageListError.\r\n procedure ClearItems;\r\n // ClearItems clears the ItemList. When the ImageList is not in imItemList\r\n // mode the method raises an RJvImageListError.\r\n function GetItemInfoStr(AIndex: Integer): string;\r\n // GetItemInfoStr returns the info string of the ItemList item that is\r\n // identified by AIndex. When the ImageList is not in imItenList mode the\r\n // method raises an RJvImageListError.\r\n published\r\n property Mode: TJvImageListMode read FMode write SetMode default imPicture;\r\n // Mode specifies which property the component should use.\r\n // imClassic: be a normal TImageList\r\n // imPicture: split the image in Picture\r\n // imResourceIds: load the images by ResourceIds\r\n // imItemList: the AddItem, DeleteItem, ClearItems and GetItemInfoStr methods are available\r\n\r\n property PixelFormat: TPixelFormat read GetPixelFormat write SetPixelFormat default pfDevice;\r\n // PixelFormat is the color resolution of the image list. pf1bit and\r\n // pfCustom are not supported.\r\n // WARNING: pf32bit works under Windows XP only.\r\n property TransparentMode: TJvImageListTransparentMode read FTransparentMode write SetTransparentMode default\r\n tmColor;\r\n // TransparentMode is used for adding the bitmaps from Picture or\r\n // ResourceIds.\r\n // tmNone: no mask\r\n // tmAuto: use the pixel at the left bottom edge\r\n // tmColor: use TransparentColor\r\n property TransparentColor: TColor read FTransparentColor write SetTransparentColor default clFuchsia;\r\n // TransparentColor specifies the color that is used as the MaskColor\r\n // when spitting the graphic in Picture.Graphic or adding the Resource\r\n // bitmaps to the image list.\r\n\r\n property FileName: TFileName read FFileName write SetFileName;\r\n // (only for designtime)\r\n // FileName specifies a graphic file that is available on the developer's\r\n // system which contains the bitmaps which can be exported by the\r\n // ImageList. The Data is copied to Picture.Graphic. If the file does not\r\n // exists at design time the stored Picture.Graphic is used.\r\n property Picture: TPicture read FPicture write SetPicture;\r\n // Picture.Graphic is updated at design time by the graphic file specified\r\n // by FileName. The Picture property is only loaded into the image list if\r\n // the Mode is imPicture.\r\n property ResourceIds: TStrings read FResourceIds write SetResourceIds;\r\n // ResourceIds contains the resource ids of the bitmaps to load. Allowed\r\n // are RCDATA (a bitmap file) and BITMAP. ResourceIds property is only\r\n // loaded into the image list if Mode is imResourceIds.\r\n property Items: TJvImageListItems read FItems write SetItems;\r\n property BlendColor;\r\n property BkColor;\r\n property AllocBy;\r\n property DrawingStyle;\r\n property Height;\r\n property ImageType;\r\n property Masked;\r\n property OnChange;\r\n property ShareImages;\r\n property Width;\r\n end;\r\n\r\n\r\nfunction CreateImageListHandle(Width, Height: Integer; PixelFormat: TPixelFormat;\r\n Masked: Boolean; AllocBy: Integer): THandle;\r\n\r\nfunction LoadImageListFromBitmap(ImgList: TCustomImageList; const Bitmap: TBitmap;\r\n MaskColor: TColor = clFuchsia; AutoMaskColor: Boolean = False): Integer; overload;\r\nfunction LoadImageListFromBitmap(ImgList: TCustomImageList; const Bitmap: TBitmap;\r\n MaskBitmap: TBitmap): Integer; overload;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvImageList.pas $';\r\n Revision: '$Revision: 13173 $';\r\n Date: '$Date: 2011-11-19 13:43:58 +0100 (sam. 19 nov. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n Consts, TypInfo, ActiveX,\r\n JclSysUtils,\r\n JvJVCLUtils, JvResources;\r\n\r\nresourcestring\r\n // (usc) there is no real need to move this string to JvResource.pas because\r\n // hopefully ikMappedResourceBitmap will be supported soon\r\n RsENotSupportedItemKind = 'The item kind %s is not supported so far.';\r\n\r\n{$IFNDEF COMPILER12_UP} // Delphi 2009 introduced \"property ColorDepth: TColorDepth\"\r\n{------------------------------------------------------------------------------}\r\n{ Here we inject a jump to our HandleNeededHook into the static\r\n TCustomImageList.HandleNeeded method. }\r\n\r\ntype\r\n TCustomImageListAccessProtected = class(TCustomImageList);\r\n\r\n // we need direct access to the FHandle field because the Handle property\r\n // calls the Changed method that calls HandleNeeded that calls SetHandle, ...\r\n TImageListPrivate = class(TComponent)\r\n protected\r\n FHeight: Integer;\r\n FWidth: Integer;\r\n FAllocBy: Integer;\r\n FHandle: HIMAGELIST;\r\n end;\r\n\r\n TJumpCode = packed record\r\n Jump: Byte;\r\n Offset: Integer;\r\n end;\r\n PJumpCode = ^TJumpCode;\r\n\r\nvar\r\n HandleNeededHookInstalled: Boolean = False;\r\n SavedNeededHookCode: TJumpCode;\r\n\r\nprocedure HandleNeededHook(Self: TCustomImageList);\r\nbegin\r\n if Self is TJvImageList then\r\n TJvImageList(Self).HandleNeeded\r\n else\r\n begin\r\n if not Self.HandleAllocated then\r\n begin\r\n TImageListPrivate(Self).FHandle := CreateImageListHandle(Self.Width, Self.Height,\r\n pfCustom, Self.Masked, Self.AllocBy);\r\n if not Self.HandleAllocated then\r\n raise EInvalidOperation.CreateRes(@SInvalidImageList);\r\n if Self.BkColor <> clNone then\r\n Self.BkColor := Self.BkColor;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure UninstallHandleNeededHook;\r\nvar\r\n OrgProc: Pointer;\r\n WrittenBytes: Cardinal;\r\nbegin\r\n if HandleNeededHookInstalled then\r\n begin\r\n OrgProc := @TCustomImageListAccessProtected.HandleNeeded;\r\n\r\n if WriteProtectedMemory(OrgProc, @SavedNeededHookCode, SizeOf(SavedNeededHookCode), WrittenBytes) then\r\n HandleNeededHookInstalled := False;\r\n end;\r\nend;\r\n\r\nprocedure InstallHandleNeededHook;\r\nvar\r\n OrgProc: Pointer;\r\n NewProc: Pointer;\r\n Code: TJumpCode;\r\n N: Cardinal;\r\nbegin\r\n if not HandleNeededHookInstalled then\r\n begin\r\n OrgProc := @TCustomImageListAccessProtected.HandleNeeded;\r\n NewProc := @HandleNeededHook;\r\n\r\n Code.Jump := $E9;\r\n Code.Offset := PAnsiChar(NewProc) - PAnsiChar(OrgProc) - SizeOf(Code);\r\n\r\n if ReadProcessMemory(GetCurrentProcess, OrgProc, @SavedNeededHookCode, SizeOf(SavedNeededHookCode), N) and\r\n WriteProtectedMemory(OrgProc, @Code, SizeOf(Code), N) then\r\n HandleNeededHookInstalled := True;\r\n end;\r\nend;\r\n{$ENDIF ~COMPILER12_UP}\r\n{------------------------------------------------------------------------------}\r\n\r\nfunction CreateImageListHandle(Width, Height: Integer; PixelFormat: TPixelFormat;\r\n Masked: Boolean; AllocBy: Integer): THandle;\r\nvar\r\n Flags: Cardinal;\r\nbegin\r\n if PixelFormat = pfDevice then\r\n PixelFormat := ScreenPixelFormat;\r\n\r\n case PixelFormat of\r\n pf4bit:\r\n Flags := ILC_COLOR4;\r\n pf8bit:\r\n Flags := ILC_COLOR8;\r\n pf15bit, pf16bit:\r\n Flags := ILC_COLOR16;\r\n pf24bit:\r\n Flags := ILC_COLOR24;\r\n pf32bit:\r\n Flags := ILC_COLOR32;\r\n else\r\n Flags := ILC_COLORDDB;\r\n end;\r\n if Masked then\r\n Flags := Flags or ILC_MASK;\r\n\r\n Result := ImageList_Create(Width, Height, Flags, AllocBy, AllocBy);\r\nend;\r\n\r\n//=== { TJvImageListItem } ===================================================\r\n\r\nconstructor TJvImageListItem.Create(Collection: TCollection); \r\nbegin\r\n inherited Create(Collection);\r\n\r\n FBitmap := TBitmap.Create;\r\n FBitmap.OnChange := BitmapChanged;\r\n FKind := ikResourceBitmap;\r\n FResourceName := '';\r\n FTransparentColor := clFuchsia;\r\n if (GetImageList <> nil) and not (csLoading in GetImageList.ComponentState) then\r\n AddToImageList(GetImageList);\r\nend;\r\n\r\ndestructor TJvImageListItem.Destroy;\r\nvar\r\n ImageList: TImageList;\r\nbegin\r\n ImageList := GetImageList;\r\n if Assigned(ImageList) and (Index >= 0) and (ImageList.Count > Index) then\r\n ImageList.Delete(Index);\r\n FBitmap.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvImageListItem.Assign(Source: TPersistent);\r\nbegin\r\n if Source is TJvImageListItem then\r\n begin\r\n FBitmap.Assign(TJvImageListItem(Source).FBitmap);\r\n FKind := TJvImageListItem(Source).FKind;\r\n FResourceName := TJvImageListItem(Source).FResourceName;\r\n FTransparentColor := TJvImageListItem(Source).FTransparentColor;\r\n end\r\n else\r\n inherited Assign(Source);\r\nend;\r\n\r\nprocedure TJvImageListItem.AddToImageList(AImageList: TImageList);\r\nvar\r\n Bitmap: TBitmap;\r\nbegin\r\n Bitmap := TBitmap.Create;\r\n try\r\n Bitmap.Width := AImageList.Width;\r\n Bitmap.Height := AImageList.Height;\r\n AImageList.AddMasked(Bitmap, FTransparentColor);\r\n finally\r\n Bitmap.Free;\r\n end;\r\n UpdateImageListItem(AImageList, Pred(AImageList.Count));\r\nend;\r\n\r\nprocedure TJvImageListItem.BitmapChanged(Sender: TObject);\r\nbegin\r\n UpdateImageList;\r\nend;\r\n\r\nfunction TJvImageListItem.GetDisplayName: string;\r\nbegin\r\n case FKind of\r\n ikResourceBitmap:\r\n Result := Format(RsResource, [FResourceName]);\r\n ikMappedResourceBitmap:\r\n Result := Format(RsMappedResource, [FResourceName]);\r\n ikInlineBitmap:\r\n Result := Format(RsBitmap,\r\n [GetEnumName(TypeInfo(TPixelFormat), Ord(FBitmap.PixelFormat))]);\r\n else\r\n inherited GetDisplayName;\r\n end;\r\nend;\r\n\r\nfunction TJvImageListItem.GetImageList: TImageList;\r\nbegin\r\n Result := TImageList(TJvImageListItems(Collection).Owner);\r\nend;\r\n\r\nprocedure TJvImageListItem.Loaded;\r\nbegin\r\n AddToImageList(GetImageList);\r\nend;\r\n\r\nprocedure TJvImageListItem.SetBitmap(ABitmap: TBitmap);\r\nbegin\r\n if FKind = ikInlineBitmap then\r\n begin\r\n FBitmap.Assign(ABitmap);\r\n UpdateImageList;\r\n end;\r\nend;\r\n\r\nprocedure TJvImageListItem.SetIndex(Value: Integer);\r\nvar\r\n ImageList: TImageList;\r\n OldIndex: Integer;\r\nbegin\r\n OldIndex := Index;\r\n inherited SetIndex(Value);\r\n ImageList := GetImageList;\r\n if Assigned(ImageList) and (OldIndex >= 0) and (ImageList.Count > OldIndex) and\r\n (Index >= 0) and (ImageList.Count > Index) then\r\n ImageList.Move(OldIndex, Index);\r\nend;\r\n\r\nprocedure TJvImageListItem.SetKind(AKind: TJvImageListItemKind);\r\nbegin\r\n // (usc) remove when MappedResourceBitmap support is finished\r\n if AKind = ikMappedResourceBitmap then\r\n raise EJvImageListError.CreateResFmt(@RsENotSupportedItemKind, ['ikMappedResourceBitmap']);\r\n\r\n if FKind <> AKind then\r\n begin\r\n FKind := AKind;\r\n if FKind in [ikResourceBitmap, ikMappedResourceBitmap] then\r\n FBitmap.Assign(nil)\r\n else\r\n if FKind = ikInlineBitmap then\r\n FResourceName := '';\r\n end;\r\nend;\r\n\r\nprocedure TJvImageListItem.SetResourceName(const AResourceName: string);\r\nbegin\r\n if (FKind in [ikResourceBitmap, ikMappedResourceBitmap]) and\r\n (FResourceName <> AResourceName) then\r\n begin\r\n FResourceName := AResourceName;\r\n UpdateImageList;\r\n end;\r\nend;\r\n\r\nprocedure TJvImageListItem.SetTransparentColor(AColor: TColor);\r\nbegin\r\n if FTransparentColor <> AColor then\r\n begin\r\n FTransparentColor := AColor;\r\n UpdateImageList;\r\n end;\r\nend;\r\n\r\nprocedure TJvImageListItem.UpdateImageList;\r\nbegin\r\n if (GetImageList <> nil) and not (csLoading in GetImageList.ComponentState) then\r\n UpdateImageListItem(GetImageList, Index);\r\nend;\r\n\r\nprocedure TJvImageListItem.UpdateImageListItem(AImageList: TImageList; AIndex: Integer);\r\nvar\r\n Bitmap: TBitmap;\r\nbegin\r\n if (FKind in [ikResourceBitmap, ikMappedResourceBitmap]) and (FResourceName <> '') then\r\n begin\r\n Bitmap := TBitmap.Create;\r\n try\r\n try\r\n if FKind = ikResourceBitmap then\r\n Bitmap.LoadFromResourceName(HInstance, FResourceName);\r\n{// (usc) include when MappedResourceBitmap support is finished\r\n else\r\n if FKind = ikMappedResourceBitmap then\r\n GetMappedResourceBitmap(FResourceName, Bitmap);\r\n}\r\n AImageList.ReplaceMasked(AIndex, Bitmap, FTransparentColor);\r\n except\r\n end;\r\n finally\r\n Bitmap.Free;\r\n end;\r\n end\r\n else\r\n if (FKind = ikInlineBitmap) and Assigned(FBitmap) and\r\n (FBitmap.Width = AImageList.Width) and (FBitmap.Height = AImageList.Height) then\r\n AImageList.ReplaceMasked(AIndex, FBitmap, FTransparentColor);\r\nend;\r\n\r\n//=== { TJvImageListItems } ==================================================\r\n\r\nconstructor TJvImageListItems.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner, TJvImageListItem);\r\nend;\r\n\r\nfunction TJvImageListItems.Add: TJvImageListItem;\r\nbegin\r\n Result := TJvImageListItem(inherited Add);\r\nend;\r\n\r\nfunction TJvImageListItems.GetItem(AIndex: Integer): TJvImageListItem;\r\nbegin\r\n Result := TJvImageListItem(inherited GetItem(AIndex));\r\nend;\r\n\r\nprocedure TJvImageListItems.Loaded;\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := 0 to Count - 1 do\r\n Items[I].Loaded;\r\nend;\r\n\r\nprocedure TJvImageListItems.SetItem(AIndex: Integer; Value: TJvImageListItem);\r\nbegin\r\n inherited SetItem(AIndex, Value);\r\nend;\r\n\r\nprocedure TJvImageListItems.Update(Item: TCollectionItem);\r\nbegin\r\n if Assigned(Item) then\r\n TJvImageListItem(Item).UpdateImageList;\r\nend;\r\n\r\n{ Loads the bitmaps for the ImageList from the bitmap Bitmap.\r\n The return value is the number of added bitmaps. }\r\n\r\nfunction LoadImageListFromBitmap(ImgList: TCustomImageList; const Bitmap: TBitmap;\r\n MaskColor: TColor = clFuchsia; AutoMaskColor: Boolean = False): Integer; overload;\r\nvar\r\n Bmp: TBitmap;\r\n Width, Height: Integer;\r\n i: Integer;\r\n TempImageList: TCustomImageList;\r\nbegin\r\n Result := 0;\r\n if (ImgList = nil) or (ImgList.Width = 0) or (ImgList.Height = 0) or\r\n (Bitmap = nil) then\r\n Exit;\r\n\r\n Width := ImgList.Width;\r\n Height := ImgList.Height;\r\n Result := Bitmap.Width div Width; // count\r\n if (Result = 0) and (Bitmap.Width > 0) then\r\n Result := 1;\r\n TempImageList := TCustomImageList.CreateSize(Width, Height);\r\n Bmp := TBitmap.Create;\r\n try\r\n Bmp.PixelFormat := Bitmap.PixelFormat;\r\n TempImageList.Handle := CreateImageListHandle(Width, Height,\r\n Bitmap.PixelFormat, ImgList.Masked, Result);\r\n\r\n // split Bitmap and add all bitmaps to ImgList\r\n for i := 0 to Result - 1 do\r\n begin\r\n if AutoMaskColor then\r\n MaskColor := Bitmap.Canvas.Pixels[i * Width, Height - 1];\r\n\r\n Bmp.Canvas.Brush.Color := MaskColor;\r\n Bmp.Width := 0; // clear bitmap\r\n Bmp.Width := Width;\r\n Bmp.Height := Height;\r\n BitBlt(Bmp.Canvas.Handle, 0, 0, Width, Height,\r\n Bitmap.Canvas.Handle, i * Width, 0, SRCCOPY);\r\n\r\n TempImageList.AddMasked(Bmp, MaskColor);\r\n end;\r\n ImgList.AddImages(TempImageList);\r\n finally\r\n Bmp.Free;\r\n TempImageList.Free;\r\n end;\r\nend;\r\n\r\nfunction LoadImageListFromBitmap(ImgList: TCustomImageList; const Bitmap: TBitmap;\r\n MaskBitmap: TBitmap): Integer; overload;\r\nvar\r\n Bmp, MaskBmp: TBitmap;\r\n Width, Height: Integer;\r\n i: Integer;\r\n TempImageList: TCustomImageList;\r\nbegin\r\n Result := 0;\r\n if (ImgList = nil) or (ImgList.Width = 0) or (ImgList.Height = 0) or\r\n (Bitmap = nil) or (MaskBitmap = nil) then\r\n Exit;\r\n\r\n Width := ImgList.Width;\r\n Height := ImgList.Height;\r\n Result := Bitmap.Width div Width; // calc count\r\n if (Result = 0) and (Bitmap.Width > 0) then\r\n Result := 1;\r\n TempImageList := TCustomImageList.CreateSize(Width, Height);\r\n Bmp := TBitmap.Create;\r\n MaskBmp := TBitmap.Create;\r\n try\r\n Bmp.PixelFormat := Bitmap.PixelFormat;\r\n MaskBmp.PixelFormat := MaskBitmap.PixelFormat;\r\n\r\n TempImageList.Handle := CreateImageListHandle(Width, Height,\r\n Bitmap.PixelFormat, ImgList.Masked, Result);\r\n\r\n // split Bitmap and add all bitmaps to ImgList\r\n for i := 0 to Result - 1 do\r\n begin\r\n Bmp.Width := 0; // clear bitmap\r\n Bmp.Width := Width;\r\n Bmp.Height := Height;\r\n BitBlt(Bmp.Canvas.Handle, 0, 0, Width, Height,\r\n Bitmap.Canvas.Handle, i * Width, 0, SRCCOPY);\r\n\r\n MaskBmp.Width := 0; // clear bitmap\r\n MaskBmp.Width := Width;\r\n MaskBmp.Height := Height;\r\n BitBlt(MaskBmp.Canvas.Handle, 0, 0, Width, Height,\r\n MaskBitmap.Canvas.Handle, i * Width, 0, SRCCOPY);\r\n\r\n TempImageList.Add(Bmp, MaskBmp);\r\n end;\r\n ImgList.AddImages(TempImageList);\r\n finally\r\n Bmp.Free;\r\n TempImageList.Free;\r\n end;\r\nend;\r\n\r\n//=== { TJvImageList } =======================================================\r\n\r\ndestructor TJvImageList.Destroy;\r\nbegin\r\n FItems.Free;\r\n FPicture.Free;\r\n FResourceIds.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvImageList.InitializeImageList;\r\nbegin\r\n FModified := False;\r\n\r\n {$IFNDEF COMPILER12_UP}\r\n if not (csDesigning in ComponentState) and not HandleNeededHookInstalled then\r\n InstallHandleNeededHook;\r\n {$ENDIF ~COMPILER12_UP}\r\n\r\n FUpdateLock := 0;\r\n\r\n FMode := imPicture;\r\n FTransparentMode := tmColor;\r\n FTransparentColor := clFuchsia;\r\n {$IFNDEF COMPILER12_UP}\r\n FPixelFormat := pfDevice;\r\n {$ENDIF ~COMPILER12_UP}\r\n\r\n FFileName := '';\r\n FPicture := TPicture.Create;\r\n FPicture.OnChange := DataChanged;\r\n\r\n FResourceIds := TStringList.Create;\r\n TStringList(FResourceIds).OnChange := DataChanged;\r\n\r\n FItems := TJvImageListItems.Create(Self);\r\nend;\r\n\r\nprocedure TJvImageList.Assign(Source: TPersistent);\r\nvar\r\n ImageList: TJvImageList;\r\nbegin\r\n ImageList := TJvImageList(Source);\r\n\r\n BeginUpdate;\r\n try\r\n if (Source <> nil) and (Source is TJvImageList) then\r\n begin\r\n Clear;\r\n FMode := imClassic; // lock update\r\n\r\n if (ImageList.Picture.Graphic <> nil) and not ImageList.Picture.Graphic.Empty then\r\n Picture.Assign(ImageList.Picture)\r\n else\r\n Picture.Assign(nil);\r\n ResourceIds.Assign(ImageList.ResourceIds);\r\n // Do not assign FileName here.\r\n TransparentMode := ImageList.TransparentMode;\r\n TransparentColor := ImageList.TransparentColor;\r\n PixelFormat := ImageList.PixelFormat;\r\n end;\r\n\r\n inherited Assign(Source);\r\n\r\n if (Source <> nil) and (Source is TJvImageList) then\r\n Mode := ImageList.Mode; // enable update\r\n finally\r\n EndUpdate;\r\n end;\r\nend;\r\n\r\nprocedure TJvImageList.BeginUpdate;\r\nbegin\r\n if FUpdateLock = 0 then\r\n FModified := False;\r\n Inc(FUpdateLock);\r\nend;\r\n\r\nprocedure TJvImageList.EndUpdate;\r\nbegin\r\n Dec(FUpdateLock);\r\n if (FUpdateLock = 0) and FModified then\r\n Change;\r\nend;\r\n\r\nprocedure TJvImageList.Change;\r\nbegin\r\n FModified := True;\r\n if FUpdateLock = 0 then\r\n inherited Change;\r\nend;\r\n\r\nprocedure TJvImageList.DataChanged(Sender: TObject);\r\nbegin\r\n UpdateImageList;\r\nend;\r\n\r\nprocedure TJvImageList.SetPicture(Value: TPicture);\r\nbegin\r\n if (Value <> FPicture) then\r\n FPicture.Assign(Value);\r\nend;\r\n\r\nprocedure TJvImageList.SetTransparentMode(Value: TJvImageListTransparentMode);\r\nbegin\r\n if Value <> FTransparentMode then\r\n begin\r\n FTransparentMode := Value;\r\n UpdateImageList;\r\n end;\r\nend;\r\n\r\nprocedure TJvImageList.SetTransparentColor(Value: TColor);\r\nbegin\r\n if Value <> FTransparentColor then\r\n begin\r\n FTransparentColor := Value;\r\n if FTransparentMode = tmColor then\r\n UpdateImageList;\r\n end;\r\nend;\r\n\r\nprocedure TJvImageList.SetFileName(const Value: TFileName);\r\nbegin\r\n if not SameFileName(Value, FFileName) then\r\n begin\r\n FFileName := Value;\r\n DoLoadFromFile;\r\n end;\r\nend;\r\n\r\nprocedure TJvImageList.DoLoadFromFile;\r\nbegin\r\n if (not (csDesigning in ComponentState)) and (csLoading in ComponentState) then\r\n Exit;\r\n\r\n if (FFileName <> '') and FileExists(FFileName) then\r\n try\r\n FPicture.LoadFromFile(FFileName);\r\n except\r\n // ignore exception\r\n end;\r\nend;\r\n\r\nprocedure TJvImageList.SlicePictureToImageList;\r\nvar\r\n Bmp: TBitmap;\r\n OwnBitmap: Boolean;\r\n MaskColor: TColor;\r\nbegin\r\n BeginUpdate;\r\n try\r\n Clear;\r\n if FPicture.Graphic = nil then\r\n Exit;\r\n\r\n OwnBitmap := False;\r\n if FPicture.Graphic is TBitmap then\r\n Bmp := FPicture.Bitmap\r\n else\r\n begin\r\n OwnBitmap := True;\r\n Bmp := TBitmap.Create;\r\n Bmp.Canvas.Brush.Color := FTransparentColor;\r\n Bmp.Width := FPicture.Width;\r\n Bmp.Height := FPicture.Height;\r\n Bmp.Canvas.Draw(0, 0, FPicture.Graphic);\r\n end;\r\n try\r\n if TransparentMode = tmNone then\r\n MaskColor := clNone\r\n else\r\n MaskColor := TransparentColor;\r\n\r\n LoadImageListFromBitmap(Self, Bmp, MaskColor, TransparentMode = tmAuto);\r\n finally\r\n if OwnBitmap then\r\n Bmp.Free;\r\n end;\r\n finally\r\n EndUpdate;\r\n end;\r\nend;\r\n\r\nprocedure TJvImageList.ResourceIdsToImageList;\r\nvar\r\n Bmp: TBitmap;\r\n ResStream: TResourceStream;\r\n i: Integer;\r\n MaskColor: TColor;\r\nbegin\r\n BeginUpdate;\r\n try\r\n Clear;\r\n if ResourceIds.Count = 0 then\r\n Exit;\r\n\r\n Bmp := TBitmap.Create;\r\n try\r\n for i := 0 to ResourceIds.Count - 1 do\r\n begin\r\n if Trim(ResourceIds[i]) <> '' then\r\n try\r\n // load resource\r\n ResStream := nil;\r\n try\r\n if FindResource(HInstance, PChar(ResourceIds[I]), RT_BITMAP) <> 0 then\r\n try\r\n ResStream := TResourceStream.Create(HInstance, ResourceIds[i], RT_BITMAP);\r\n except\r\n ResStream := nil;\r\n end;\r\n Bmp.Assign(nil); // fixes GDI resource leak\r\n if ResStream <> nil then\r\n Bmp.LoadFromResourceName(HInstance, ResourceIds[i])\r\n else\r\n begin\r\n ResStream := TResourceStream.Create(HInstance, ResourceIds[i], RT_RCDATA);\r\n Bmp.LoadFromStream(ResStream);\r\n end;\r\n finally\r\n ResStream.Free;\r\n end;\r\n\r\n // add bitmap\r\n if not Bmp.Empty and (Bmp.Width > 0) and (Bmp.Height > 0) then\r\n begin\r\n case TransparentMode of\r\n tmNone:\r\n MaskColor := clNone;\r\n tmColor:\r\n MaskColor := TransparentColor;\r\n tmAuto:\r\n MaskColor := Bmp.Canvas.Pixels[0, Bmp.Height - 1];\r\n else\r\n MaskColor := clNone; // make the compiler happy\r\n end;\r\n AddMasked(Bmp, MaskColor);\r\n end;\r\n except\r\n // ignore exception\r\n end;\r\n end;\r\n finally\r\n Bmp.Free;\r\n end;\r\n finally\r\n EndUpdate;\r\n end;\r\nend;\r\n\r\ntype\r\n TComponentAccessProtected = class(TComponent);\r\n TDefineProperties = procedure(Self: TComponent; Filer: TFiler);\r\n\r\nprocedure TJvImageList.DefineProperties(Filer: TFiler);\r\nbegin\r\n Inc(FUpdateLock); // no BeginUpdate/EndUpdate here\r\n try\r\n if (Filer is TWriter) then\r\n DoLoadFromFile; // update Picture.Graphic if a filename is specified\r\n\r\n if (Filer is TWriter) and\r\n (((FMode = imPicture) and (FPicture.Graphic <> nil) and (not FPicture.Graphic.Empty)) or\r\n ((FMode = imResourceIds) and (FResourceIds.Count > 0)) or\r\n ((FMode = imItemList) and (FItems.Count > 0))) then\r\n TDefineProperties(@TComponentAccessProtected.DefineProperties)(Self, Filer)\r\n else\r\n inherited DefineProperties(Filer);\r\n finally\r\n Dec(FUpdateLock);\r\n end;\r\nend;\r\n\r\nprocedure TJvImageList.SetPixelFormat(const Value: TPixelFormat);\r\n{$IFDEF COMPILER12_UP}\r\nconst\r\n PixelFormatToColorDepth: array[TPixelFormat] of TColorDepth = (\r\n cdDeviceDependent, cdDeviceDependent, cd4Bit, cd8Bit, cd16Bit, cd16Bit, cd24Bit, cd32Bit, cdDeviceDependent\r\n );\r\n{$ELSE}\r\nvar\r\n ImgList: TJvImageList;\r\n{$ENDIF COMPILER12_UP}\r\nbegin\r\n {$IFDEF COMPILER12_UP}\r\n if not (Value in [pf1bit, pfCustom]) then\r\n ColorDepth := PixelFormatToColorDepth[Value];\r\n {$ELSE}\r\n if (Value <> FPixelFormat) and not (Value in [pf1bit, pfCustom]) then\r\n begin\r\n if HandleAllocated then\r\n begin\r\n BeginUpdate;\r\n try\r\n // convert image list\r\n ImgList := TJvImageList.CreateSize(Width, Height);\r\n try\r\n ImgList.Assign(Self); // copy imagelist with old pixelformat\r\n FPixelFormat := Value; // set new pixelformat\r\n CreateImageList; // create new image list handle\r\n AddImages(ImgList);\r\n finally\r\n ImgList.Free;\r\n end;\r\n finally\r\n EndUpdate;\r\n end;\r\n end\r\n else\r\n FPixelFormat := Value;\r\n end;\r\n {$ENDIF COMPILER12_UP}\r\nend;\r\n\r\nfunction TJvImageList.GetPixelFormat: TPixelFormat;\r\n{$IFDEF COMPILER12_UP}\r\nconst\r\n ColorDepthToPixelFormat: array[TColorDepth] of TPixelFormat = (\r\n pfDevice, pfDevice, pf4bit, pf8bit, pf16bit, pf24bit, pf32bit\r\n );\r\n{$ENDIF COMPILER12_UP}\r\nbegin\r\n {$IFDEF COMPILER12_UP}\r\n Result := ColorDepthToPixelFormat[ColorDepth];\r\n {$ELSE}\r\n Result := FPixelFormat;\r\n {$ENDIF COMPILER12_UP}\r\nend;\r\n\r\nprocedure TJvImageList.SetItems(AItems: TJvImageListItems);\r\nbegin\r\n Clear;\r\n FItems.Assign(AItems);\r\nend;\r\n\r\nprocedure TJvImageList.AddItem(ABitmap: TBitmap; ATransparentColor: TColor);\r\nvar\r\n BitmapItem: TJvImageListItem;\r\nbegin\r\n if Mode <> imItemList then\r\n Clear;\r\n Mode := imItemList;\r\n BitmapItem := FItems.Add;\r\n BitmapItem.Kind := ikInlineBitmap;\r\n BitmapItem.Bitmap.Assign(ABitmap);\r\n BitmapItem.TransparentColor := ATransparentColor;\r\nend;\r\n\r\nprocedure TJvImageList.AddItem(const AResourceName: string; ATransparentColor: TColor);\r\nvar\r\n ResourceItem: TJvImageListItem;\r\nbegin\r\n if Mode <> imItemList then\r\n Clear;\r\n Mode := imItemList;\r\n ResourceItem := FItems.Add;\r\n ResourceItem.Kind := ikResourceBitmap;\r\n ResourceItem.ResourceName := AResourceName;\r\n ResourceItem.TransparentColor := ATransparentColor;\r\nend;\r\n\r\nprocedure TJvImageList.DeleteItem(AIndex: Integer);\r\nbegin\r\n if Mode = imItemList then\r\n FItems.Delete(AIndex)\r\n else\r\n ItemListError;\r\nend;\r\n\r\nprocedure TJvImageList.ClearItems;\r\nbegin\r\n if Mode = imItemList then\r\n begin\r\n Clear;\r\n FItems.Clear;\r\n end\r\n else\r\n ItemListError;\r\nend;\r\n\r\nfunction TJvImageList.GetItemInfoStr(AIndex: Integer): string;\r\nbegin\r\n Result := '';\r\n if Mode = imItemList then\r\n Result := FItems[AIndex].DisplayName\r\n else\r\n ItemListError;\r\nend;\r\n\r\nprocedure TJvImageList.SetResourceIds(Value: TStrings);\r\nbegin\r\n if (Value <> nil) and (Value <> FResourceIds) then\r\n FResourceIds.Assign(Value);\r\nend;\r\n\r\nprocedure TJvImageList.SetMode(const Value: TJvImageListMode);\r\nbegin\r\n if Value <> FMode then\r\n begin\r\n FMode := Value;\r\n UpdateImageList;\r\n end;\r\nend;\r\n\r\nprocedure TJvImageList.UpdateImageList;\r\nbegin\r\n case FMode of\r\n imClassic:\r\n ; // do nothing\r\n imPicture:\r\n SlicePictureToImageList;\r\n imResourceIds:\r\n ResourceIdsToImageList;\r\n imItemList:\r\n ; // do nothing\r\n end;\r\nend;\r\n\r\nprocedure TJvImageList.SetInternalHandle(Value: THandle);\r\nbegin\r\n if not HandleAllocated or (Handle <> Value) then\r\n begin\r\n Inc(FUpdateLock); // no BeginUpdate/EndUpdate here\r\n try\r\n Handle := Value;\r\n finally\r\n Dec(FUpdateLock);\r\n end;\r\n end;\r\nend;\r\n\r\n{$IFNDEF COMPILER12_UP}\r\nprocedure TJvImageList.HandleNeeded;\r\nbegin\r\n if not HandleAllocated then\r\n CreateImageList;\r\nend;\r\n\r\nprocedure TJvImageList.CreateImageList;\r\nbegin\r\n FHandle := CreateImageListHandle(Width, Height, FPixelFormat, Masked, AllocBy);\r\n if not HandleAllocated then\r\n raise EInvalidOperation.CreateRes(@SInvalidImageList);\r\n if BkColor <> clNone then\r\n BkColor := BkColor;\r\nend;\r\n{$ENDIF ~COMPILER12_UP}\r\n\r\nprocedure TJvImageList.DrawIndirect(ImageListDrawParams: TImageListDrawParams);\r\nbegin\r\n ImageListDrawParams.cbSize := SizeOf(ImageListDrawParams);\r\n ImageListDrawParams.himl := Handle;\r\n ImageList_DrawIndirect(@ImageListDrawParams);\r\nend;\r\n\r\nfunction TJvImageList.Merge(Index1: Integer; ImageList: TImageList;\r\n Index2, dx, dy: Integer): TCustomImageList;\r\nvar\r\n h: THandle;\r\nbegin\r\n h := ImageList_Merge(Handle, Index1, ImageList.Handle, Index2, dx, dy);\r\n if h = 0 then\r\n Result := nil\r\n else\r\n begin\r\n Result := TJvImageList.Create(nil);\r\n Result.Handle := h;\r\n end;\r\nend;\r\n\r\nprocedure TJvImageList.Loaded;\r\nbegin\r\n inherited Loaded;\r\n Items.Loaded;\r\nend;\r\n\r\nprocedure TJvImageList.LoadFromFile(const FileName: string);\r\nvar\r\n Stream: TStream;\r\nbegin\r\n Stream := TFileStream.Create(FileName, fmOpenRead or fmShareDenyWrite);\r\n try\r\n LoadFromStream(Stream);\r\n finally\r\n Stream.Free;\r\n end;\r\nend;\r\n\r\nprocedure TJvImageList.SaveToFile(const FileName: string);\r\nvar\r\n Stream: TStream;\r\nbegin\r\n Stream := TFileStream.Create(FileName, fmCreate);\r\n try\r\n SaveToStream(Stream);\r\n finally\r\n Stream.Free;\r\n end;\r\nend;\r\n\r\nprocedure TJvImageList.Initialize;\r\nbegin\r\n inherited Initialize;\r\n InitializeImageList;\r\nend;\r\n\r\nprocedure TJvImageList.LoadFromStream(Stream: TStream);\r\nvar\r\n Adapter: IStream;\r\nbegin\r\n Adapter := TStreamAdapter.Create(Stream);\r\n Handle := ImageList_Read(Adapter);\r\nend;\r\n\r\nprocedure TJvImageList.SaveToStream(Stream: TStream);\r\ntype\r\n TWriteExProc = function(himl: HIMAGELIST; Flags: Cardinal; Stream: IStream): HResult; stdcall;\r\nconst\r\n ILP_NORMAL = 0;\r\n ILP_DOWNLEVEL = 1;\r\nvar\r\n Adapter: IStream;\r\n ImageList_WriteEx: TWriteExProc;\r\nbegin\r\n Adapter := TStreamAdapter.Create(Stream);\r\n if PixelFormat <> pf32bit then // 32 Bit is only supported by CommCtrls 6.0\r\n begin\r\n ImageList_WriteEx := GetProcAddress(GetModuleHandle('comctl32.dll'), 'ImageList_WriteEx');\r\n if Assigned(ImageList_WriteEx) then\r\n begin\r\n // write down\r\n ImageList_WriteEx(Handle, ILP_DOWNLEVEL, Adapter);\r\n Exit;\r\n end;\r\n end;\r\n ImageList_Write(Handle, Adapter);\r\nend;\r\n\r\nprocedure TJvImageList.ItemListError;\r\nbegin\r\n raise EJvImageListError.CreateResFmt(@RsEWrongImageListMode, ['imItemList']);\r\nend;\r\n\r\ninitialization\r\n {$IFDEF UNITVERSIONING}\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n {$ENDIF UNITVERSIONING}\r\n\r\nfinalization\r\n {$IFNDEF COMPILER12_UP}\r\n UninstallHandleNeededHook;\r\n {$ENDIF ~COMPILER12_UP}\r\n {$IFDEF UNITVERSIONING}\r\n UnregisterUnitVersion(HInstance);\r\n {$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvImageListViewer.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvImageListViewer.PAS, released on 2003-12-01.\r\n\r\nThe Initial Developer of the Original Code is: Peter Thrnqvist\r\nAll Rights Reserved.\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvImageListViewer.pas 13104 2011-09-07 06:50:43Z obones $\r\n\r\nunit JvImageListViewer;\r\n\r\ninterface\r\n\r\n{$I jvcl.inc}\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n SysUtils, Classes, Windows, Messages, Controls,\r\n Graphics, StdCtrls, ComCtrls, ImgList,\r\n JvCustomItemViewer;\r\n\r\ntype\r\n TJvImageListViewerOptions = class(TJvCustomItemViewerOptions)\r\n private\r\n FDrawingStyle: TDrawingStyle;\r\n FSelectedStyle: TDrawingStyle;\r\n FFillCaption: Boolean;\r\n FFrameSize: Word;\r\n procedure SetDrawingStyle(const Value: TDrawingStyle);\r\n procedure SetSelectedStyle(const Value: TDrawingStyle);\r\n procedure SetFillCaption(const Value: Boolean);\r\n procedure SetFrameSize(const Value: Word);\r\n public\r\n constructor Create(AOwner: TJvCustomItemViewer); override;\r\n published\r\n property AutoCenter;\r\n property BrushPattern;\r\n property DragAutoScroll;\r\n property DrawingStyle: TDrawingStyle read FDrawingStyle write SetDrawingStyle default dsTransparent;\r\n property FillCaption: Boolean read FFillCaption write SetFillCaption default True;\r\n property SelectedStyle: TDrawingStyle read FSelectedStyle write SetSelectedStyle default dsSelected;\r\n property FrameSize: Word read FFrameSize write SetFrameSize default 1;\r\n property Height;\r\n property Layout;\r\n property RightClickSelect;\r\n property ScrollBar;\r\n property ShowCaptions;\r\n property Tracking;\r\n property Width;\r\n end;\r\n\r\n TJvImageListViewerCaptionEvent = procedure(Sender: TObject;\r\n ImageIndex: Integer; var ACaption: WideString) of object;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvImageListViewer = class(TJvCustomItemViewer)\r\n private\r\n FChangeLink: TChangeLink;\r\n FImages: TCustomImageList;\r\n FOnGetCaption: TJvImageListViewerCaptionEvent;\r\n procedure SetImages(const Value: TCustomImageList);\r\n function GetOptions: TJvImageListViewerOptions;\r\n procedure SetOptions(const Value: TJvImageListViewerOptions);\r\n protected\r\n procedure Notification(AComponent: TComponent; Operation: TOperation); override;\r\n procedure DoImageChange(Sender: TObject);\r\n procedure DrawItem(Index: Integer; State: TCustomDrawState; Canvas: TCanvas;\r\n ItemRect, TextRect: TRect); override;\r\n function GetOptionsClass: TJvItemViewerOptionsClass; override;\r\n function GetCaption(ImageIndex: Integer): WideString; virtual;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n published\r\n property Images: TCustomImageList read FImages write SetImages;\r\n property Options: TJvImageListViewerOptions read GetOptions write SetOptions;\r\n property SelectedIndex;\r\n property Align;\r\n property Anchors;\r\n // property BiDiMode;\r\n property Color;\r\n property Constraints;\r\n property DockSite;\r\n property DragCursor;\r\n property DragKind;\r\n property DragMode;\r\n property Enabled;\r\n property Font;\r\n // property ParentBiDiMode;\r\n property ParentColor;\r\n property ParentFont;\r\n property ParentShowHint;\r\n property PopupMenu;\r\n property ShowHint;\r\n property TabOrder;\r\n property TabStop;\r\n property Visible;\r\n property OnClick;\r\n property OnContextPopup;\r\n property OnDblClick;\r\n property OnDragDrop;\r\n property OnDockDrop;\r\n property OnDockOver;\r\n property OnDragOver;\r\n property OnEndDock;\r\n property OnEndDrag;\r\n property OnEnter;\r\n property OnExit;\r\n property OnGetCaption: TJvImageListViewerCaptionEvent read FOnGetCaption write FOnGetCaption;\r\n property OnDrawItem;\r\n property OnOptionsChanged;\r\n property OnItemChanging;\r\n property OnItemChanged;\r\n property OnItemHint;\r\n property OnGetSiteInfo;\r\n property OnMouseDown;\r\n property OnMouseMove;\r\n property OnMouseUp;\r\n property OnKeyDown;\r\n property OnKeyUp;\r\n property OnKeyPress;\r\n property OnStartDock;\r\n property OnStartDrag;\r\n property OnUnDock;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvImageListViewer.pas $';\r\n Revision: '$Revision: 13104 $';\r\n Date: '$Date: 2011-09-07 08:50:43 +0200 (mer. 07 sept. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n CommCtrl,\r\n Math,\r\n JvJCLUtils, JvJVCLUtils;\r\n\r\n//=== { TJvImageListViewerOptions } ==========================================\r\n\r\nconstructor TJvImageListViewerOptions.Create(AOwner: TJvCustomItemViewer);\r\nbegin\r\n inherited Create(AOwner);\r\n FDrawingStyle := dsTransparent;\r\n FSelectedStyle := dsSelected;\r\n FFillCaption := True;\r\n FFrameSize := 1;\r\nend;\r\n\r\nprocedure TJvImageListViewerOptions.SetDrawingStyle(const Value: TDrawingStyle);\r\nbegin\r\n if FDrawingStyle <> Value then\r\n begin\r\n FDrawingStyle := Value;\r\n Change;\r\n end;\r\nend;\r\n\r\nprocedure TJvImageListViewerOptions.SetFillCaption(const Value: Boolean);\r\nbegin\r\n if FFillCaption <> Value then\r\n begin\r\n FFillCaption := Value;\r\n Change;\r\n end;\r\nend;\r\n\r\nprocedure TJvImageListViewerOptions.SetFrameSize(const Value: Word);\r\nbegin\r\n if FFrameSize <> Value then\r\n begin\r\n FFrameSize := Value;\r\n Change;\r\n end;\r\nend;\r\n\r\nprocedure TJvImageListViewerOptions.SetSelectedStyle(const Value: TDrawingStyle);\r\nbegin\r\n if FSelectedStyle <> Value then\r\n begin\r\n FSelectedStyle := Value;\r\n Change;\r\n end;\r\nend;\r\n\r\n//=== { TJvImageListViewer } =================================================\r\n\r\nconstructor TJvImageListViewer.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FChangeLink := TChangeLink.Create;\r\n FChangeLink.OnChange := DoImageChange;\r\n Color := clWindow;\r\nend;\r\n\r\ndestructor TJvImageListViewer.Destroy;\r\nbegin\r\n Images := nil;\r\n FChangeLink.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvImageListViewer.DoImageChange(Sender: TObject);\r\nbegin\r\n if Images <> nil then\r\n Count := Images.Count\r\n else\r\n Count := 0;\r\n Repaint;\r\nend;\r\n\r\nprocedure TJvImageListViewer.DrawItem(Index: Integer; State: TCustomDrawState;\r\n Canvas: TCanvas; ItemRect, TextRect: TRect);\r\nconst\r\n DrawingStyles: array [TDrawingStyle] of Cardinal =\r\n (ILD_FOCUS, ILD_SELECTED, ILD_NORMAL, ILD_TRANSPARENT);\r\n DrawMask: array [Boolean] of Cardinal =\r\n (ILD_MASK, ILD_NORMAL);\r\nvar\r\n X, Y: Integer;\r\n S: WideString;\r\n DrawStyle, Flags: Cardinal;\r\nbegin\r\n Canvas.Brush.Color := Color;\r\n Canvas.Font := Self.Font;\r\n if Images <> nil then\r\n begin\r\n Flags := DT_END_ELLIPSIS or DT_EDITCONTROL;\r\n S := GetCaption(Index);\r\n // determine where to draw image\r\n X := Max(ItemRect.Left, ItemRect.Left + (RectWidth(ItemRect) - Images.Width) div 2);\r\n Y := ItemRect.Top + (RectHeight(ItemRect) - Images.Height) div 2;\r\n if not Options.FillCaption then\r\n OffsetRect(TextRect,0,2);\r\n if cdsSelected in State then\r\n begin\r\n if Options.BrushPattern.Active then\r\n begin\r\n Canvas.Pen.Color := Options.BrushPattern.OddColor;\r\n Canvas.Brush.Bitmap := Options.BrushPattern.GetBitmap;\r\n end\r\n else\r\n begin\r\n Canvas.Pen.Color := Options.BrushPattern.OddColor;\r\n Canvas.Brush.Color := Options.BrushPattern.OddColor;\r\n end;\r\n if Options.FrameSize > 0 then\r\n begin\r\n Canvas.Pen.Width := Options.FrameSize;\r\n Canvas.Rectangle(ItemRect);\r\n end\r\n else\r\n Canvas.FillRect(ItemRect);\r\n end\r\n else\r\n begin\r\n Canvas.Brush.Color := Color;\r\n Canvas.FillRect(ItemRect);\r\n end;\r\n if cdsSelected in Items[Index].State then\r\n DrawStyle := DrawingStyles[Options.SelectedStyle]\r\n else\r\n DrawStyle := DrawingStyles[Options.DrawingStyle];\r\n ImageList_Draw(Images.Handle, Index, Canvas.Handle, X, Y,\r\n DrawStyle or DrawMask[Images.ImageType = itImage]);\r\n if S <> '' then\r\n begin\r\n if cdsSelected in State then\r\n begin\r\n Canvas.Brush.Color := clHighlight; // Options.BrushPattern.OddColor;\r\n Canvas.Font.Color := clHighlightText; // Options.BrushPattern.EvenColor;\r\n end\r\n else\r\n SetBkMode(Canvas.Handle, Windows.TRANSPARENT);\r\n if (Options.Layout <> tlCenter) and Options.FillCaption then\r\n Canvas.FillRect(TextRect)\r\n else\r\n S := ' ' + S + ' ';\r\n ViewerDrawText(Canvas, PWideChar(S), Length(S), TextRect, Flags, taCenter, tlCenter, True);\r\n end;\r\n// if not Options.BrushPattern.Active and (cdsSelected in State) then\r\n// begin\r\n// Canvas.DrawFocusRect(ItemRect);\r\n// end;\r\n end;\r\nend;\r\n\r\nfunction TJvImageListViewer.GetCaption(ImageIndex: Integer): WideString;\r\nbegin\r\n Result := '';\r\n if Assigned(FOnGetCaption) then\r\n FOnGetCaption(Self, ImageIndex, Result);\r\nend;\r\n\r\nfunction TJvImageListViewer.GetOptions: TJvImageListViewerOptions;\r\nbegin\r\n Result := TJvImageListViewerOptions(inherited Options);\r\nend;\r\n\r\nfunction TJvImageListViewer.GetOptionsClass: TJvItemViewerOptionsClass;\r\nbegin\r\n Result := TJvImageListViewerOptions;\r\nend;\r\n\r\nprocedure TJvImageListViewer.Notification(AComponent: TComponent;\r\n Operation: TOperation);\r\nbegin\r\n inherited Notification(AComponent, Operation);\r\n if (Operation = opRemove) and (AComponent = FImages) then\r\n Images := nil;\r\nend;\r\n\r\nprocedure TJvImageListViewer.SetImages(const Value: TCustomImageList);\r\nbegin\r\n if FImages <> Value then\r\n begin\r\n ReplaceImageListReference(Self, Value, FImages, FChangeLink);\r\n Count := 0;\r\n if FImages <> nil then\r\n begin\r\n Options.Width := Max(Options.Width, FImages.Width);\r\n Options.Height := Max(Options.Height, FImages.Height);\r\n end;\r\n DoImageChange(Value);\r\n end;\r\nend;\r\n\r\nprocedure TJvImageListViewer.SetOptions(const Value: TJvImageListViewerOptions);\r\nbegin\r\n inherited Options := Value;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n\r\n" }, { "path": "External/Jedi/Jvcl/run/JvImageRotate.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvImageRotate.PAS, released on 2001-02-28.\r\n\r\nThe Initial Developer of the Original Code is Sbastien Buysse [sbuysse att buypin dott com]\r\nPortions created by Sbastien Buysse are Copyright (C) 2001 Sbastien Buysse.\r\nAll Rights Reserved.\r\n\r\nContributor(s): Michael Beck [mbeck att bigfoot dott com].\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvImageRotate.pas 13104 2011-09-07 06:50:43Z obones $\r\n\r\nunit JvImageRotate;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n SysUtils, Classes, Windows, Graphics, Controls, ExtCtrls,\r\n JvImageDrawThread, JVCLVer, JvExExtCtrls;\r\n\r\ntype\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvImageRotate = class(TJvExImage)\r\n private\r\n FRotated: TBitmap;\r\n FOriginal: TBitmap;\r\n FTimer: TJvImageDrawThread;\r\n FPosition: Integer;\r\n FInterval: Cardinal;\r\n FColor: TColor;\r\n FRotating: Boolean;\r\n procedure SetPicture(Value: TBitmap);\r\n procedure SetRotating(Value: Boolean);\r\n procedure Rotate(Sender: TObject);\r\n procedure SetInterval(Value: Cardinal);\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n published\r\n property Rotating: Boolean read FRotating write SetRotating default False;\r\n property StartImage: TBitmap read FOriginal write SetPicture;\r\n property Interval: Cardinal read FInterval write SetInterval default 20;\r\n property FillColor: TColor read FColor write FColor;\r\n procedure SetAngle(Value: Integer);\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvImageRotate.pas $';\r\n Revision: '$Revision: 13104 $';\r\n Date: '$Date: 2011-09-07 08:50:43 +0200 (mer. 07 sept. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n JvTypes;\r\n\r\nconstructor TJvImageRotate.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FOriginal := TBitmap.Create;\r\n FRotated := TBitmap.Create;\r\n FTimer := TJvImageDrawThread.Create(True);\r\n FTimer.FreeOnTerminate := False;\r\n FTimer.Delay := 20;\r\n FTimer.OnDraw := Rotate;\r\n FPosition := 0;\r\n FInterval := 20;\r\n FRotating := False;\r\n FOriginal.Assign(Picture.Bitmap);\r\nend;\r\n\r\ndestructor TJvImageRotate.Destroy;\r\nbegin\r\n FTimer.OnDraw := nil;\r\n FTimer.Terminate;\r\n FreeAndNil(FTimer);\r\n FreeAndNil(FOriginal);\r\n FreeAndNil(FRotated);\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvImageRotate.SetPicture(Value: TBitmap);\r\nbegin\r\n Value.PixelFormat := pf24bit;\r\n FOriginal.PixelFormat := pf24bit;\r\n Picture.Bitmap.PixelFormat := pf24bit;\r\n Picture.Assign(Value);\r\n FOriginal.Assign(Value);\r\nend;\r\n\r\nprocedure TJvImageRotate.SetRotating(Value: Boolean);\r\nbegin\r\n FRotating := Value;\r\n if not (csDesigning in ComponentState) then\r\n begin\r\n FTimer.Paused := not FRotating;\r\n end;\r\nend;\r\n\r\nprocedure TJvImageRotate.Rotate(Sender: TObject);\r\nbegin\r\n // Must exit because we are \"Synchronized\" and our parent is already\r\n // partly destroyed. If we did not exit, we would get an AV.\r\n if csDestroying in ComponentState then\r\n Exit;\r\n\r\n if FTimer.Tag = 0 then //0 from Left to Right\r\n begin\r\n if FPosition = 181 then\r\n FTimer.Tag := 1\r\n else\r\n begin\r\n Dec(FPosition);\r\n if FPosition < 0 then\r\n FPosition := 359;\r\n SetAngle(FPosition);\r\n end;\r\n end\r\n else //from Right to Left\r\n begin\r\n if FPosition = 179 then\r\n Self.FTimer.Tag := 0\r\n else\r\n begin\r\n FPosition := (FPosition + 1) mod 360;\r\n SetAngle(FPosition);\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvImageRotate.SetAngle(Value: Integer);\r\nvar\r\n i, j, iRotationAxis, iOriginal, iPrime, iPrimeRotated: Integer;\r\n jRotationAxis, jOriginal, jPrime, jPrimeRotated: Integer;\r\n RowOriginal: PJvRGBArray;\r\n RowRotated: PJvRGBArray;\r\n Theta, SinTheta, CosTheta: Double;\r\n R, G, B: Byte;\r\nbegin\r\n FRotated.Width := FOriginal.Width;\r\n FRotated.Height := FOriginal.Height;\r\n FRotated.PixelFormat := pf24bit;\r\n iRotationAxis := FOriginal.Width div 2;\r\n jRotationAxis := FOriginal.Height div 2;\r\n Theta := -Value * Pi / 180;\r\n SinTheta := Sin(Theta);\r\n CosTheta := Cos(Theta);\r\n B := FColor mod 256;\r\n G := Round((FColor div 256) mod 256);\r\n R := Round((FColor div 256) div 256);\r\n for j := FRotated.Height - 1 downto 0 do\r\n begin\r\n RowRotated := FRotated.Scanline[j];\r\n jPrime := 2 * (j - jRotationAxis) + 1;\r\n for i := FRotated.Width - 1 downto 0 do\r\n begin\r\n iPrime := 2 * (i - iRotationAxis) + 1;\r\n iPrimeRotated := Round(iPrime * CosTheta - jPrime * SinTheta);\r\n jPrimeRotated := Round(iPrime * SinTheta + jPrime * CosTheta);\r\n iOriginal := (iPrimeRotated - 1) div 2 + iRotationAxis;\r\n jOriginal := (jPrimeRotated - 1) div 2 + jRotationAxis;\r\n if (iOriginal >= 0) and (iOriginal <= FOriginal.Width - 1) and\r\n (jOriginal >= 0) and (jOriginal <= FOriginal.Height - 1) then\r\n begin\r\n RowOriginal := FOriginal.Scanline[jOriginal];\r\n RowRotated[i] := RowOriginal[iOriginal]\r\n end\r\n else\r\n begin\r\n RowRotated[i].rgbBlue := B;\r\n RowRotated[i].rgbGreen := G;\r\n RowRotated[i].rgbRed := R\r\n end;\r\n end;\r\n end;\r\n Picture.Assign(FRotated);\r\nend;\r\n\r\nprocedure TJvImageRotate.SetInterval(Value: Cardinal);\r\nbegin\r\n FInterval := Value;\r\n FTimer.Delay := Value;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvImageSquare.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvImageWindow.PAS, released on 2002-05-26.\r\n\r\nThe Initial Developer of the Original Code is Peter Thrnqvist [peter3 at sourceforge dot net]\r\nPortions created by Peter Thrnqvist are Copyright (C) 2002 Peter Thrnqvist.\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvImageSquare.pas 13104 2011-09-07 06:50:43Z obones $\r\n\r\nunit JvImageSquare;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n SysUtils, Classes, Windows, Messages, Graphics, Controls, ImgList, Forms,\r\n JvComponent;\r\n\r\ntype\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvImageSquare = class(TJvGraphicControl)\r\n private\r\n FHiColor: TColor;\r\n FTmpColor: TColor;\r\n FBackColor: TColor;\r\n FBorderStyle: TBorderStyle;\r\n FImageList: TCustomImageList;\r\n FIndex: Integer;\r\n FDown: Boolean;\r\n FShowClick: Boolean;\r\n FImageChangeLink: TChangeLink;\r\n procedure SetHiColor(Value: TColor);\r\n procedure SetBorderStyle(Value: TBorderStyle);\r\n procedure SetIndex(Value: Integer);\r\n procedure SetImageList(Value: TCustomImageList);\r\n procedure ImageListChange(Sender: TObject);\r\n protected\r\n procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;\r\n procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;\r\n procedure MouseEnter(Control: TControl); override;\r\n procedure MouseLeave(Control: TControl); override;\r\n procedure ColorChanged; override;\r\n procedure PaintFrame; virtual;\r\n procedure Paint; override;\r\n procedure Notification(AComponent: TComponent; Operation: TOperation); override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n published\r\n property Color default clWindow;\r\n property BorderStyle: TBorderStyle read FBorderStyle write SetBorderStyle default bsSingle;\r\n property HiColor: TColor read FHiColor write SetHiColor default clActiveCaption;\r\n property Images: TCustomImageList read FImageList write SetImageList;\r\n property ImageIndex: Integer read FIndex write SetIndex default 0;\r\n property ShowClick: Boolean read FShowClick write FShowClick default False;\r\n property Width default 36;\r\n property Height default 36;\r\n\r\n property Align;\r\n property Anchors;\r\n property Action;\r\n property Text;\r\n property Visible;\r\n property Enabled;\r\n property DragCursor;\r\n property DragMode;\r\n property PopupMenu;\r\n property ParentShowHint;\r\n property Hint;\r\n property ShowHint;\r\n property OnMouseEnter;\r\n property OnMouseLeave;\r\n property OnClick;\r\n property OnMouseDown;\r\n property OnMouseMove;\r\n property OnMouseUp;\r\n property OnDragDrop;\r\n property OnDragOver;\r\n property OnEndDrag;\r\n property OnStartDrag;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvImageSquare.pas $';\r\n Revision: '$Revision: 13104 $';\r\n Date: '$Date: 2011-09-07 08:50:43 +0200 (mer. 07 sept. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n ExtCtrls, CommCtrl,\r\n JvThemes, JvResources, JvJVCLUtils;\r\n\r\n//=== { TJvImageSquare } =====================================================\r\n\r\nconstructor TJvImageSquare.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FHiColor := clActiveCaption;\r\n Color := clWindow;\r\n FTmpColor := clWindow;\r\n FBackColor := clWindow;\r\n FIndex := 0;\r\n FDown := False;\r\n FShowClick := False;\r\n Width := 36;\r\n Height := 36;\r\n FBorderStyle := bsSingle;\r\n FImageChangeLink := TChangeLink.Create;\r\n FImageChangeLink.OnChange := ImageListChange;\r\nend;\r\n\r\ndestructor TJvImageSquare.Destroy;\r\nbegin\r\n FImageChangeLink.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvImageSquare.ImageListChange(Sender: TObject);\r\nbegin\r\n Repaint;\r\nend;\r\n\r\nprocedure TJvImageSquare.Notification(AComponent: TComponent; Operation: TOperation);\r\nbegin\r\n inherited Notification(AComponent, Operation);\r\n if (AComponent = FImageList) and (Operation = opRemove) then\r\n FImageList := nil;\r\nend;\r\n\r\nprocedure TJvImageSquare.PaintFrame;\r\nvar\r\n R: TRect;\r\nbegin\r\n R := GetClientRect;\r\n if FDown and FShowClick then\r\n begin\r\n Frame3D(Canvas, R, cl3DDkShadow, cl3DDkShadow, 1);\r\n Frame3D(Canvas, R, clBtnHighLight, clBtnHighLight, 1);\r\n Frame3D(Canvas, R, cl3DDkShadow, cl3DDkShadow, 1);\r\n end\r\n else\r\n {$IFDEF JVCLThemesEnabled}\r\n if (FBorderStyle = bsSingle) and ThemeServices.{$IFDEF RTL230_UP}Enabled{$ELSE}ThemesEnabled{$ENDIF RTL230_UP} then\r\n DrawThemedBorder(Self)\r\n else\r\n {$ENDIF JVCLThemesEnabled}\r\n if FBorderStyle = bsSingle then\r\n begin\r\n Frame3D(Canvas, R, clBtnFace, clBtnFace, 1);\r\n Frame3D(Canvas, R, clBtnShadow, clBtnHighLight, 1);\r\n Frame3D(Canvas, R, cl3DDkShadow, clBtnFace, 1);\r\n end\r\n else\r\n Frame3D(Canvas, R, FHiColor, FHiColor, 3);\r\nend;\r\n\r\nprocedure TJvImageSquare.Paint;\r\nvar\r\n R: TRect;\r\n DX, DY: Integer;\r\nbegin\r\n R := Rect(0, 0, Width, Height);\r\n\r\n if FBorderStyle = bsSingle then\r\n begin\r\n PaintFrame;\r\n InflateRect(R, -3, -3);\r\n end;\r\n\r\n { fill in the rest }\r\n Canvas.Brush.Color := FTmpColor;\r\n Canvas.Brush.Style := bsSolid;\r\n Canvas.FillRect(R);\r\n\r\n if Assigned(FImageList) then\r\n begin\r\n { draw in middle }\r\n DX := (Width - FImageList.Width) div 2;\r\n DY := (Height - FImageList.Height) div 2;\r\n ImageList_DrawEx(FImageList.Handle, FIndex, Canvas.Handle,\r\n DX, DY, 0, 0, CLR_NONE, CLR_NONE, ILD_TRANSPARENT);\r\n end;\r\nend;\r\n\r\nprocedure TJvImageSquare.SetHiColor(Value: TColor);\r\nbegin\r\n if FHiColor <> Value then\r\n begin\r\n FHiColor := Value;\r\n Repaint;\r\n end;\r\nend;\r\n\r\nprocedure TJvImageSquare.SetBorderStyle(Value: TBorderStyle);\r\nbegin\r\n if FBorderStyle <> Value then\r\n begin\r\n FBorderStyle := Value;\r\n Repaint;\r\n end;\r\nend;\r\n\r\nprocedure TJvImageSquare.SetIndex(Value: Integer);\r\nbegin\r\n if FIndex <> Value then\r\n begin\r\n FIndex := Value;\r\n Repaint;\r\n end;\r\nend;\r\n\r\nprocedure TJvImageSquare.SetImageList(Value: TCustomImageList);\r\nbegin\r\n ReplaceImageListReference(Self, Value, FImageList, FImageChangeLink);\r\n Repaint;\r\nend;\r\n\r\nprocedure TJvImageSquare.MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);\r\nbegin\r\n inherited MouseUp(Button, Shift, X, Y);\r\n FDown := False;\r\n if FShowClick then\r\n PaintFrame;\r\nend;\r\n\r\nprocedure TJvImageSquare.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);\r\nbegin\r\n inherited MouseDown(Button, Shift, X, Y);\r\n FDown := True;\r\n if FShowClick then\r\n PaintFrame;\r\nend;\r\n\r\nprocedure TJvImageSquare.MouseEnter(Control: TControl);\r\nbegin\r\n if csDesigning in ComponentState then\r\n Exit;\r\n inherited MouseEnter(Control);\r\n if ColorToRGB(FTmpColor) <> ColorToRGB(FHiColor) then\r\n begin\r\n FTmpColor := FHiColor;\r\n Repaint;\r\n end;\r\nend;\r\n\r\nprocedure TJvImageSquare.MouseLeave(Control: TControl);\r\nbegin\r\n FDown := False;\r\n if csDesigning in ComponentState then\r\n Exit;\r\n inherited MouseLeave(Control);\r\n if ColorToRGB(FTmpColor) <> ColorToRGB(FBackColor) then\r\n begin\r\n FTmpColor := FBackColor;\r\n Repaint;\r\n end;\r\nend;\r\n\r\nprocedure TJvImageSquare.ColorChanged;\r\nbegin\r\n inherited ColorChanged;\r\n FBackColor := Color;\r\n FTmpColor := Color;\r\n Repaint;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvImageTransform.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvImageTransform.PAS, released on 2001-02-28.\r\n\r\nThe Initial Developer of the Original Code is Sbastien Buysse [sbuysse att buypin dott com]\r\nPortions created by Sbastien Buysse are Copyright (C) 2001 Sbastien Buysse.\r\nAll Rights Reserved.\r\n\r\nContributor(s): Michael Beck [mbeck att bigfoot dott com].\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvImageTransform.pas 13104 2011-09-07 06:50:43Z obones $\r\n\r\nunit JvImageTransform;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n SysUtils, Classes,\r\n Windows, Graphics, Controls, ExtCtrls,\r\n JvComponent;\r\n\r\ntype\r\n TJvTransformationKind = (ttWipeLeft, ttWipeRight, ttWipeUp, ttWipeDown,\r\n ttTurnLeft, ttTurnRight, ttTurnUp, ttTurnDown,\r\n ttWipeDownRight, ttWipeDownLeft, ttWipeUpRight, ttWipeUpLeft);\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvImageTransform = class(TJvGraphicControl)\r\n private\r\n FPicture1: TPicture;\r\n FPicture2: TPicture;\r\n FTimer: TTimer;\r\n FInterval: Integer;\r\n FImageShown: Byte;\r\n FSteps: Integer;\r\n FType: TJvTransformationKind;\r\n StepNum: Integer;\r\n FOnFinished: TNotifyEvent;\r\n procedure PictureChanged(Sender: TObject);\r\n procedure SetPicture1(Value: TPicture);\r\n procedure SetPicture2(Value: TPicture);\r\n procedure SetImageShown(Value: Byte);\r\n procedure SetInterval(Value: Integer);\r\n procedure SetType(Value: TJvTransformationKind);\r\n protected\r\n procedure SetAutoSize(Value: Boolean); override;\r\n function GetPalette: HPALETTE; override;\r\n procedure Paint; override;\r\n procedure TimerTick(Sender: TObject);\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n published\r\n property AutoSize;\r\n property DragCursor;\r\n property DragMode;\r\n property Enabled;\r\n property ImageShown: Byte read FImageShown write SetImageShown default 1;\r\n property Interval: Integer read FInterval write SetInterval default 1;\r\n property ParentShowHint;\r\n property Picture1: TPicture read FPicture1 write SetPicture1;\r\n property Picture2: TPicture read FPicture2 write SetPicture2;\r\n property PopupMenu;\r\n property ShowHint;\r\n property Steps: Integer read FSteps write FSteps default 10;\r\n property TransformType: TJvTransformationKind read FType write SetType default ttWipeLeft;\r\n property Visible;\r\n property OnClick;\r\n property OnDblClick;\r\n property OnDragDrop;\r\n property OnDragOver;\r\n property OnEndDrag;\r\n property OnMouseDown;\r\n property OnMouseMove;\r\n property OnMouseUp;\r\n property OnFinished: TNotifyEvent read FOnFinished write FOnFinished;\r\n procedure Transform;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvImageTransform.pas $';\r\n Revision: '$Revision: 13104 $';\r\n Date: '$Date: 2011-09-07 08:50:43 +0200 (mer. 07 sept. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\n\r\nconstructor TJvImageTransform.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FImageShown := 1;\r\n FPicture1 := TPicture.Create;\r\n FPicture1.OnChange := PictureChanged;\r\n FPicture2 := TPicture.Create;\r\n FPicture2.OnChange := PictureChanged;\r\n FTimer := TTimer.Create(Self);\r\n FTimer.OnTimer := TimerTick;\r\n FTimer.Enabled := False;\r\n FInterval := 1;\r\n FType := ttWipeLeft;\r\n FSteps := 10;\r\n Height := 105;\r\n Width := 105;\r\nend;\r\n\r\ndestructor TJvImageTransform.Destroy;\r\nbegin\r\n FPicture1.Free;\r\n FPicture2.Free;\r\n FTimer.Free;\r\n inherited Destroy;\r\nend;\r\n\r\n\r\nfunction TJvImageTransform.GetPalette: HPALETTE;\r\nbegin\r\n if FPicture1.Graphic is TBitmap then\r\n Result := TBitmap(FPicture1.Graphic).Palette\r\n else\r\n Result := 0;\r\nend;\r\n\r\n\r\nprocedure TJvImageTransform.SetAutoSize(Value: Boolean);\r\nbegin\r\n inherited SetAutoSize(Value);\r\n PictureChanged(Self);\r\nend;\r\n\r\nprocedure TJvImageTransform.SetPicture1(Value: TPicture);\r\nbegin\r\n FPicture1.Assign(Value);\r\nend;\r\n\r\nprocedure TJvImageTransform.SetPicture2(Value: TPicture);\r\nbegin\r\n FPicture2.Assign(Value);\r\nend;\r\n\r\nprocedure TJvImageTransform.SetImageShown(Value: Byte);\r\nbegin\r\n if Value in [1, 2] then\r\n begin\r\n FImageShown := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvImageTransform.SetInterval(Value: Integer);\r\nbegin\r\n FInterval := Value;\r\n if Value > 1000 then\r\n FInterval := 1000;\r\n if Value < 1 then\r\n FInterval := 1;\r\n {Reset the timer interval}\r\n if FTimer <> nil then\r\n FTimer.Interval := FInterval;\r\nend;\r\n\r\nprocedure TJvImageTransform.SetType(Value: TJvTransformationKind);\r\nbegin\r\n FType := Value;\r\nend;\r\n\r\nprocedure TJvImageTransform.PictureChanged(Sender: TObject);\r\nbegin\r\n if AutoSize and (Picture1.Width > 0) and (Picture1.Height > 0) then\r\n SetBounds(Left, Top, Picture1.Width, Picture1.Height);\r\n if (Picture1.Graphic is TBitmap) and (Picture1.Width = Width) and (Picture1.Height = Height) then\r\n ControlStyle := ControlStyle + [csOpaque]\r\n else\r\n ControlStyle := ControlStyle - [csOpaque];\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvImageTransform.Transform;\r\nbegin\r\n StepNum := 0;\r\n {Turn on the timer}\r\n if FTimer <> nil then\r\n begin\r\n FTimer.Interval := 1;\r\n FTimer.Enabled := True;\r\n end;\r\nend;\r\n\r\nprocedure TJvImageTransform.TimerTick;\r\nbegin\r\n if FTimer <> nil then\r\n FTimer.Interval := FInterval;\r\n Inc(StepNum);\r\n Repaint;\r\n if FTimer <> nil then\r\n if FTimer.Enabled then\r\n if StepNum >= Steps then\r\n begin\r\n FTimer.Enabled := False;\r\n if ImageShown = 1 then\r\n ImageShown := 2\r\n else\r\n ImageShown := 1;\r\n if Assigned(FOnFinished) then\r\n FOnFinished(Self);\r\n end;\r\nend;\r\n\r\nprocedure TJvImageTransform.Paint;\r\nvar\r\n PctDone: Real;\r\n PctLeft: Real;\r\n DestRect: TRect;\r\n ShowCurrentImage: Boolean;\r\n Other: TGraphic;\r\nbegin\r\n with inherited Canvas do\r\n begin\r\n if csDesigning in ComponentState then\r\n begin\r\n Pen.Style := psDash;\r\n Brush.Style := bsClear;\r\n Rectangle(0, 0, Width, Height);\r\n end;\r\n ShowCurrentImage := False;\r\n if FTimer <> nil then\r\n if not FTimer.Enabled then\r\n ShowCurrentImage := True;\r\n if StepNum < 1 then\r\n ShowCurrentImage := True;\r\n if ShowCurrentImage then\r\n begin\r\n if ImageShown = 1 then\r\n Draw(0, 0, Picture1.Graphic)\r\n else\r\n Draw(0, 0, Picture2.Graphic);\r\n Exit;\r\n end;\r\n if FSteps > 0 then\r\n PctDone := (StepNum / FSteps)\r\n else\r\n PctDone := 0.0;\r\n PctLeft := 1 - PctDone;\r\n // (rom) simplified with variable Other\r\n if ImageShown = 1 then\r\n Other := Picture2.Graphic\r\n else\r\n Other := Picture1.Graphic;\r\n if PctDone > 0.0 then\r\n case TransformType of\r\n ttWipeLeft:\r\n Draw(Round(Picture1.Width * PctLeft), 0, Other);\r\n ttWipeRight:\r\n Draw(-Round(Picture1.Width * PctLeft), 0, Other);\r\n ttWipeUp:\r\n Draw(0, Round(Picture1.Height * PctLeft), Other);\r\n ttWipeDown:\r\n Draw(0, -Round(Picture1.Height * PctLeft), Other);\r\n ttTurnLeft:\r\n begin\r\n with Picture1 do\r\n DestRect := Rect(Round(Width * PctLeft), 0,\r\n Round(Width * PctLeft) +\r\n Round(Width * PctDone), Height);\r\n StretchDraw(DestRect, Other);\r\n end;\r\n ttTurnRight:\r\n begin\r\n with Picture1 do\r\n DestRect := Rect(0, 0, Round(Width * PctDone), Height);\r\n StretchDraw(DestRect, Other);\r\n end;\r\n ttTurnUp:\r\n begin\r\n with Picture1 do\r\n DestRect := Rect(0, Round(Height * PctLeft),\r\n Width, Round(Height * PctLeft) +\r\n Round(Height * PctDone));\r\n StretchDraw(DestRect, Other);\r\n end;\r\n ttTurnDown:\r\n begin\r\n with Picture1 do\r\n DestRect := Rect(0, 0, Width, Round(Height * PctDone));\r\n StretchDraw(DestRect, Other);\r\n end;\r\n ttWipeDownRight:\r\n Draw(-Round(Picture1.Width * PctLeft), -Round(Picture1.Height * PctLeft), Other);\r\n ttWipeDownLeft:\r\n Draw(Round(Picture1.Width * PctLeft), -Round(Picture1.Height * PctLeft), Other);\r\n ttWipeUpRight:\r\n Draw(-Round(Picture1.Width * PctLeft), Round(Picture1.Height * PctLeft), Other);\r\n ttWipeUpLeft:\r\n Draw(Round(Picture1.Width * PctLeft), Round(Picture1.Height * PctLeft), Other);\r\n end;\r\n end;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvImagesViewer.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvImagesViewer.PAS, released on 2003-12-01.\r\n\r\nThe Initial Developer of the Original Code is: Peter Thrnqvist\r\nAll Rights Reserved.\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvImagesViewer.pas 13145 2011-11-02 21:15:19Z ahuser $\r\n\r\nunit JvImagesViewer;\r\n\r\ninterface\r\n\r\n{$I jvcl.inc}\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n SysUtils, Classes,\r\n {$IFDEF MSWINDOWS}\r\n Windows,\r\n {$ENDIF MSWINDOWS}\r\n Messages, Controls, Graphics, StdCtrls, ComCtrls,\r\n JvCustomItemViewer;\r\n\r\ntype\r\n TJvPictureItem = class(TJvViewerItem)\r\n private\r\n FFileName: WideString;\r\n FPicture: TPicture;\r\n FCaption: WideString;\r\n procedure SetFileName(const Value: WideString);\r\n procedure SetCaption(const Value: WideString);\r\n procedure SetPicture(const Value: TPicture);\r\n function GetPicture: TPicture;\r\n procedure CreatePicture;\r\n protected\r\n procedure DoPictureChange(Sender: TObject); virtual;\r\n procedure DoLoadProgress(Sender: TObject; Stage: TProgressStage; PercentDone: Byte;\r\n RedrawNow: Boolean; const R: TRect; const Msg: string); virtual;\r\n procedure ReduceMemoryUsage; override;\r\n public\r\n destructor Destroy; override;\r\n procedure Refresh;\r\n public\r\n property FileName: WideString read FFileName write SetFileName;\r\n property Picture: TPicture read GetPicture write SetPicture;\r\n property Caption: WideString read FCaption write SetCaption;\r\n end;\r\n\r\n TJvImageViewerOptions = class(TJvCustomItemViewerOptions)\r\n private\r\n FImagePadding: Integer;\r\n FFrameColor: TColor;\r\n FHotFrameSize: Integer;\r\n FHotColor: TColor;\r\n FTransparent: Boolean;\r\n procedure SetImagePadding(const Value: Integer);\r\n procedure SetFrameColor(const Value: TColor);\r\n procedure SetHotColor(const Value: TColor);\r\n procedure SetHotFrameSize(const Value: Integer);\r\n procedure SetTransparent(const Value: Boolean);\r\n public\r\n constructor Create(AOwner: TJvCustomItemViewer); override;\r\n published\r\n property AutoCenter;\r\n property Alignment;\r\n property BrushPattern;\r\n property DragAutoScroll;\r\n property FrameColor: TColor read FFrameColor write SetFrameColor default clGray;\r\n property Height;\r\n property HorzSpacing;\r\n property HotColor: TColor read FHotColor write SetHotColor default clHighlight;\r\n property HotFrameSize: Integer read FHotFrameSize write SetHotFrameSize default 2;\r\n property HotTrack;\r\n property ImagePadding: Integer read FImagePadding write SetImagePadding default 8;\r\n property Layout;\r\n property LazyRead;\r\n property MultiSelect;\r\n property ReduceMemoryUsage;\r\n property RightClickSelect;\r\n property Transparent: Boolean read FTransparent write SetTransparent default False;\r\n property ScrollBar;\r\n property ShowCaptions default True;\r\n property Tracking;\r\n property VertSpacing;\r\n property Width;\r\n end;\r\n\r\n TJvImageLoadEvent = procedure(Sender: TObject; Item: TJvPictureItem) of object;\r\n TJvImageLoadErrorEvent = procedure(Sender: TObject; E: Exception;\r\n const FileName: WideString; var Handled: Boolean) of object;\r\n TJvImageViewerLoadProgress = procedure(Sender: TObject; Item: TJvPictureItem; Stage: TProgressStage;\r\n PercentDone: Byte; RedrawNow: Boolean; const R: TRect; const Msg: string) of object;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvImagesViewer = class(TJvCustomItemViewer)\r\n private\r\n FFileMask: WideString;\r\n FDirectory: WideString;\r\n FOnLoadError: TJvImageLoadErrorEvent;\r\n FOnLoadProgress: TJvImageViewerLoadProgress;\r\n FOnLoadBegin: TNotifyEvent;\r\n FOnLoadEnd: TNotifyEvent;\r\n procedure SetDirectory(const Value: WideString);\r\n procedure SetFileMask(const Value: WideString);\r\n function GetItems(Index: Integer): TJvPictureItem;\r\n procedure ExpandFileMask(const Mask: WideString; Strings: TStrings);\r\n function ScaleRect(ARect, RefRect: TRect): TRect;\r\n function GetOptions: TJvImageViewerOptions;\r\n procedure SetOptions(const Value: TJvImageViewerOptions);\r\n protected\r\n function GetItemClass: TJvViewerItemClass; override;\r\n function GetOptionsClass: TJvItemViewerOptionsClass; override;\r\n function LoadErrorHandled(E: Exception; const FileName: WideString): Boolean;\r\n procedure DoLoadBegin; virtual;\r\n procedure DoLoadProgress(Item: TJvPictureItem; Stage: TProgressStage; PercentDone: Byte;\r\n RedrawNow: Boolean; const R: TRect; const Msg: WideString);\r\n procedure DoLoadEnd; virtual;\r\n procedure DrawItem(Index: Integer; State: TCustomDrawState; Canvas: TCanvas;\r\n ItemRect, TextRect: TRect); override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n function LoadImages: Boolean;virtual;\r\n procedure CustomSort(Compare: TListSortCompare); override;\r\n\r\n property Items[Index: Integer]: TJvPictureItem read GetItems;\r\n property Count;\r\n published\r\n property Directory: WideString read FDirectory write SetDirectory;\r\n property FileMask: WideString read FFileMask write SetFileMask;\r\n property Options: TJvImageViewerOptions read GetOptions write SetOptions;\r\n property SelectedIndex;\r\n property OnScroll;\r\n property OnLoadBegin: TNotifyEvent read FOnLoadBegin write FOnLoadBegin;\r\n property OnLoadEnd: TNotifyEvent read FOnLoadEnd write FOnLoadEnd;\r\n property OnLoadError: TJvImageLoadErrorEvent read FOnLoadError write FOnLoadError;\r\n property OnLoadProgress: TJvImageViewerLoadProgress read FOnLoadProgress write FOnLoadProgress;\r\n property OnDrawItem;\r\n property OnOptionsChanged;\r\n property OnItemChanging;\r\n property OnItemChanged;\r\n property OnItemHint;\r\n property OnInsertion;\r\n property OnDeletion;\r\n\r\n property Align;\r\n property Anchors;\r\n // property BiDiMode;\r\n property Color;\r\n property Constraints;\r\n property DockSite;\r\n property DragCursor;\r\n property DragKind;\r\n property DragMode;\r\n property Enabled;\r\n property Font;\r\n // property ParentBiDiMode;\r\n property ParentColor;\r\n property ParentFont;\r\n property ParentShowHint;\r\n property PopupMenu;\r\n property ShowHint;\r\n property TabOrder;\r\n property TabStop;\r\n property Visible;\r\n property OnClick;\r\n property OnContextPopup;\r\n property OnDblClick;\r\n property OnDragDrop;\r\n property OnDockDrop;\r\n property OnDockOver;\r\n property OnEndDock;\r\n property OnGetSiteInfo;\r\n property OnStartDock;\r\n property OnUnDock;\r\n property OnDragOver;\r\n property OnEndDrag;\r\n property OnEnter;\r\n property OnExit;\r\n property OnMouseDown;\r\n property OnMouseMove;\r\n property OnMouseUp;\r\n property OnKeyDown;\r\n property OnKeyUp;\r\n property OnKeyPress;\r\n property OnStartDrag;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvImagesViewer.pas $';\r\n Revision: '$Revision: 13145 $';\r\n Date: '$Date: 2011-11-02 22:15:19 +0100 (mer. 02 nov. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n JvJCLUtils;\r\n\r\n//=== { TJvImageViewerOptions } ==============================================\r\n\r\nconstructor TJvImageViewerOptions.Create(AOwner: TJvCustomItemViewer);\r\nbegin\r\n inherited Create(AOwner);\r\n FImagePadding := 20;\r\n FFrameColor := clGray;\r\n FHotColor := clHighlight;\r\n FHotFrameSize := 2;\r\n ShowCaptions := True;\r\nend;\r\n\r\nprocedure TJvImageViewerOptions.SetFrameColor(const Value: TColor);\r\nbegin\r\n if FFrameColor <> Value then\r\n begin\r\n FFrameColor := Value;\r\n Change;\r\n end;\r\nend;\r\n\r\nprocedure TJvImageViewerOptions.SetHotColor(const Value: TColor);\r\nbegin\r\n FHotColor := Value;\r\nend;\r\n\r\nprocedure TJvImageViewerOptions.SetHotFrameSize(const Value: Integer);\r\nbegin\r\n FHotFrameSize := Value;\r\nend;\r\n\r\nprocedure TJvImageViewerOptions.SetImagePadding(const Value: Integer);\r\nbegin\r\n if FImagePadding <> Value then\r\n begin\r\n FImagePadding := Value;\r\n Change;\r\n end;\r\nend;\r\n\r\nprocedure TJvImageViewerOptions.SetTransparent(const Value: Boolean);\r\nbegin\r\n if FTransparent <> Value then\r\n begin\r\n FTransparent := Value;\r\n Change;\r\n end;\r\nend;\r\n\r\n//=== { TJvPictureItem } =====================================================\r\n\r\ndestructor TJvPictureItem.Destroy;\r\nbegin\r\n FreeAndNil(FPicture);\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvPictureItem.CreatePicture;\r\nvar\r\n S: WideString;\r\nbegin\r\n if FPicture = nil then\r\n begin\r\n FPicture := TPicture.Create;\r\n FPicture.OnChange := DoPictureChange;\r\n FPicture.OnProgress := DoLoadProgress;\r\n S := ExpandUNCFileName(FileName);\r\n if (S <> '') and FileExists(S) then\r\n try\r\n FPicture.LoadFromFile(S);\r\n if FPicture.Graphic <> nil then\r\n FPicture.Graphic.Transparent := TJvImagesViewer(Owner).Options.Transparent;\r\n except\r\n on E: Exception do\r\n if not TJvImagesViewer(Owner).LoadErrorHandled(E, FileName) then\r\n raise\r\n else\r\n begin\r\n Delete;\r\n FreeAndNil(FPicture);\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvPictureItem.DoPictureChange(Sender: TObject);\r\nbegin\r\n Changed;\r\nend;\r\n\r\nprocedure TJvPictureItem.DoLoadProgress(Sender: TObject; Stage: TProgressStage;\r\n PercentDone: Byte; RedrawNow: Boolean; const R: TRect; const Msg: string);\r\nbegin\r\n if Owner is TJvImagesViewer then\r\n TJvImagesViewer(Owner).DoLoadProgress(Self, Stage, PercentDone, RedrawNow, R, Msg);\r\nend;\r\n\r\nfunction TJvPictureItem.GetPicture: TPicture;\r\nbegin\r\n CreatePicture;\r\n Result := FPicture;\r\nend;\r\n\r\nprocedure TJvPictureItem.SetFileName(const Value: WideString);\r\nbegin\r\n if (AnsiCompareFileName(FFileName, Value) <> 0) and Changing then\r\n begin\r\n FFileName := Value;\r\n // don't load image until .Picture is used\r\n FreeAndNil(FPicture);\r\n end;\r\nend;\r\n\r\nprocedure TJvPictureItem.SetPicture(const Value: TPicture);\r\nbegin\r\n if Changing then\r\n begin\r\n if Value <> nil then\r\n GetPicture.Assign(Value)\r\n else\r\n if Assigned(FPicture) then\r\n begin\r\n FreeAndNil(FPicture);\r\n Changed;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvPictureItem.SetCaption(const Value: WideString);\r\nbegin\r\n if (FCaption <> Value) and Changing then\r\n begin\r\n FCaption := Value;\r\n Changed;\r\n end;\r\nend;\r\n\r\nprocedure TJvPictureItem.ReduceMemoryUsage;\r\nbegin\r\n inherited ReduceMemoryUsage;\r\n if FileName <> '' then // release image if we can recreate it from it's filename\r\n Picture := nil;\r\nend;\r\n\r\nprocedure TJvPictureItem.Refresh;\r\nbegin\r\n FreeAndNil(FPicture);\r\nend;\r\n\r\n//=== { TJvImagesViewer } ====================================================\r\n\r\nconstructor TJvImagesViewer.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n // FDirectory := GetCurrentDir;\r\n FFileMask := Graphics.GraphicFileMask(TGraphic);\r\n Color := clWindow;\r\nend;\r\n\r\nfunction TJvImagesViewer.ScaleRect(ARect, RefRect: TRect): TRect;\r\nvar\r\n w, h, cw, ch: Integer;\r\n XYAspect: Double;\r\nbegin\r\n w := ARect.Right - ARect.Left;\r\n h := ARect.Bottom - ARect.Top;\r\n cw := RefRect.Right - RefRect.Left;\r\n ch := RefRect.Bottom - RefRect.Top;\r\n\r\n if (w > cw) or (h > ch) then\r\n begin\r\n if (w > 0) and (h > 0) then\r\n begin\r\n XYAspect := w / h;\r\n if w > h then\r\n begin\r\n w := cw;\r\n h := Trunc(cw / XYAspect);\r\n if h > ch then\r\n begin\r\n h := ch;\r\n w := Trunc(ch * XYAspect);\r\n end;\r\n end\r\n else\r\n begin\r\n h := ch;\r\n w := Trunc(ch * XYAspect);\r\n if w > cw then\r\n begin\r\n w := cw;\r\n h := Trunc(cw / XYAspect);\r\n end;\r\n end;\r\n end\r\n else\r\n begin\r\n w := cw;\r\n h := ch;\r\n end;\r\n end;\r\n\r\n with Result do\r\n begin\r\n Left := 0;\r\n Top := 0;\r\n Right := w;\r\n Bottom := h;\r\n end;\r\nend;\r\n\r\nprocedure TJvImagesViewer.DrawItem(Index: Integer; State: TCustomDrawState;\r\n Canvas: TCanvas; ItemRect, TextRect: TRect);\r\nvar\r\n ImageRect: TRect;\r\n TotalPadding, BottomRightShift: Integer;\r\n AItem: TJvPictureItem;\r\n S: WideString;\r\n\r\n procedure ModifyRect(var R: TRect; ALeft, ATop, ARight, ABottom: Integer);\r\n begin\r\n Inc(R.Left, ALeft);\r\n Inc(R.Top, ATop);\r\n Inc(R.Right, ARight);\r\n Inc(R.Bottom, ABottom);\r\n end;\r\n\r\nbegin\r\n inherited DrawItem(Index, State, Canvas, ItemRect, TextRect);\r\n {$IFDEF MSWINDOWS}\r\n if Win32Platform = VER_PLATFORM_WIN32_NT then\r\n BottomRightShift := 1\r\n else\r\n {$ENDIF MSWINDOWS}\r\n BottomRightShift := 0;\r\n AItem := Items[Index];\r\n Canvas.Font := Font;\r\n Canvas.Brush.Color := Color;\r\n Canvas.Pen.Color := Font.Color;\r\n TotalPadding := Options.ImagePadding;\r\n if Options.ShowCaptions then\r\n begin\r\n Dec(ImageRect.Bottom, 2);\r\n Inc(TextRect.Top, 2);\r\n S := AItem.Caption;\r\n if S = '' then\r\n S := ExtractFileName(AItem.FileName);\r\n end;\r\n\r\n if cdsHot in State then\r\n begin\r\n Canvas.Font.Style := Canvas.Font.Style + [fsUnderline];\r\n Canvas.Font.Color := clHighlight;\r\n Canvas.Pen.Color := Options.HotColor;\r\n Canvas.Pen.Width := Options.HotFrameSize;\r\n Canvas.Brush.Style := bsClear;\r\n ModifyRect(ItemRect,Options.HotFrameSize div 2,Options.HotFrameSize div 2,\r\n -Options.HotFrameSize div 2 + BottomRightShift,-Options.HotFrameSize div 2 + BottomRightShift);\r\n Canvas.Rectangle(ItemRect);\r\n ModifyRect(ItemRect,-Options.HotFrameSize div 2,-Options.HotFrameSize div 2,\r\n Options.HotFrameSize div 2 - BottomRightShift,Options.HotFrameSize div 2 - BottomRightShift);\r\n Canvas.Brush.Style := bsSolid;\r\n SetBkMode(Canvas.Handle, Windows.TRANSPARENT);\r\n Canvas.Pen.Width := 1;\r\n end;\r\n if cdsSelected in State then\r\n begin\r\n Canvas.Pen.Color := clBtnFace;\r\n Canvas.Brush.Color := clHighlight;\r\n if Options.BrushPattern.Active then\r\n Canvas.Brush.Bitmap := Options.BrushPattern.GetBitmap\r\n else\r\n Canvas.Brush.Color := Options.BrushPattern.OddColor;\r\n Canvas.Rectangle(ItemRect);\r\n Canvas.Brush.Bitmap := nil;\r\n Canvas.Brush.Style := bsClear;\r\n Canvas.Pen.Color := Options.HotColor;\r\n Canvas.Pen.Width := Options.HotFrameSize;\r\n ModifyRect(ItemRect,Options.HotFrameSize div 2, Options.HotFrameSize div 2,\r\n -Options.HotFrameSize div 2 + BottomRightShift, -Options.HotFrameSize div 2 + BottomRightShift);\r\n Canvas.Rectangle(ItemRect);\r\n ModifyRect(ItemRect,-Options.HotFrameSize div 2, -Options.HotFrameSize div 2,\r\n Options.HotFrameSize div 2 - BottomRightShift, Options.HotFrameSize div 2 - BottomRightShift);\r\n Canvas.Font.Color := clHighlightText;\r\n Canvas.Brush.Style := bsSolid;\r\n Canvas.Brush.Color := clHighlight;\r\n Canvas.Pen.Width := 1;\r\n end\r\n else\r\n if (Options.FrameColor <> clNone) and not (cdsHot in State) then\r\n begin\r\n Canvas.Brush.Color := Options.FrameColor;\r\n Canvas.FrameRect(ItemRect);\r\n SetBkMode(Canvas.Handle, Windows.TRANSPARENT);\r\n end;\r\n // make space around image\r\n InflateRect(ItemRect, -TotalPadding, -TotalPadding);\r\n if AItem.Picture <> nil then // access Picture to load image\r\n begin\r\n ImageRect := Rect(0, 0, AItem.Picture.Width, AItem.Picture.Height);\r\n ImageRect := CenterRect(ScaleRect(ImageRect, ItemRect), ItemRect);\r\n if (RectWidth(ImageRect) > 0) and (RectHeight(ImageRect) > 0) then\r\n if AItem.Picture.Graphic is TIcon then\r\n // and (RectWidth(ImageRect) < RectWidth(R)) and (RectHeight(ImageRect) < RectHeight(R)) then\r\n // TIcon doesn't scale it's content\r\n DrawIconEx(Canvas.Handle, ImageRect.Left, ImageRect.Top, AItem.Picture.Icon.Handle,\r\n ImageRect.Right - ImageRect.Left, ImageRect.Bottom - ImageRect.Top, 0, 0, DI_NORMAL)\r\n else\r\n Canvas.StretchDraw(ImageRect, AItem.Picture.Graphic);\r\n end;\r\n\r\n if Options.ShowCaptions and (S <> '') then\r\n begin\r\n if Options.Layout = tlCenter then\r\n S := ' ' + S + ' ';\r\n ViewerDrawText(Canvas, S, Length(S),\r\n TextRect, DT_END_ELLIPSIS or DT_EDITCONTROL, Options.Alignment, tlCenter, False);\r\n end;\r\nend;\r\n\r\nfunction TJvImagesViewer.GetItems(Index: Integer): TJvPictureItem;\r\nbegin\r\n Result := TJvPictureItem(inherited Items[Index]);\r\nend;\r\n\r\nfunction TJvImagesViewer.GetItemClass: TJvViewerItemClass;\r\nbegin\r\n Result := TJvPictureItem;\r\nend;\r\n\r\nfunction TJvImagesViewer.LoadImages: Boolean;\r\nvar\r\n I, J: Integer;\r\n F: TSearchRec;\r\n Files, FileMasks: TStringList;\r\n TmpDir: WideString;\r\nbegin\r\n BeginUpdate;\r\n try\r\n Count := 0;\r\n TmpDir := ExpandUNCFileName(Directory);\r\n FileMasks := TStringList.Create;\r\n try\r\n FileMasks.Sorted := True; // make sure no duplicates are added\r\n ExpandFileMask(FileMask, FileMasks);\r\n if TmpDir <> '' then\r\n TmpDir := IncludeTrailingPathDelimiter(TmpDir);\r\n DoLoadBegin;\r\n Files := TStringList.Create;\r\n try\r\n Files.Sorted := True;\r\n for I := 0 to FileMasks.Count - 1 do\r\n begin\r\n if SysUtils.FindFirst(TmpDir + FileMasks[I], faAnyFile, F) = 0 then\r\n try\r\n repeat\r\n if F.Attr and faDirectory = 0 then\r\n Files.Add(TmpDir + F.Name);\r\n until SysUtils.FindNext(F) <> 0;\r\n Count := Files.Count;\r\n J := 0;\r\n while J < Files.Count do\r\n begin\r\n Items[J].FileName := Files[J];\r\n Inc(J);\r\n end;\r\n finally\r\n SysUtils.FindClose(F);\r\n end;\r\n end;\r\n finally\r\n Files.Free;\r\n end;\r\n DoLoadEnd;\r\n finally\r\n FileMasks.Free;\r\n end;\r\n Result := Count > 0;\r\n finally\r\n EndUpdate;\r\n end;\r\nend;\r\n\r\nprocedure TJvImagesViewer.SetDirectory(const Value: WideString);\r\nbegin\r\n if FDirectory <> Value then\r\n begin\r\n FDirectory := Value;\r\n LoadImages;\r\n end;\r\nend;\r\n\r\nprocedure TJvImagesViewer.SetFileMask(const Value: WideString);\r\nbegin\r\n if FFileMask <> Value then\r\n begin\r\n FFileMask := Value;\r\n LoadImages;\r\n end;\r\nend;\r\n\r\nprocedure TJvImagesViewer.ExpandFileMask(const Mask: WideString;\r\n Strings: TStrings);\r\nvar\r\n Start, Current: PChar;\r\n TmpChar: Char;\r\nbegin\r\n Current := PChar(string(Mask));\r\n Start := Current;\r\n while (Current <> nil) and (Current^ <> #0) do\r\n begin\r\n if CharInSet(Current^, [',', ';']) then\r\n begin\r\n TmpChar := Current^;\r\n Current^ := #0;\r\n if Start <> '' then\r\n Strings.Add(Start);\r\n Current^ := TmpChar;\r\n Start := Current + 1;\r\n end;\r\n Inc(Current);\r\n end;\r\n if Start <> '' then\r\n Strings.Add(Start);\r\nend;\r\n\r\nfunction TJvImagesViewer.LoadErrorHandled(E: Exception; const FileName: WideString): Boolean;\r\nbegin\r\n Result := False;\r\n if Assigned(FOnLoadError) then\r\n FOnLoadError(Self, E, FileName, Result);\r\nend;\r\n\r\nprocedure TJvImagesViewer.DoLoadBegin;\r\nbegin\r\n if Assigned(FOnLoadBegin) then\r\n FOnLoadBegin(Self);\r\nend;\r\n\r\nprocedure TJvImagesViewer.DoLoadProgress(Item: TJvPictureItem;\r\n Stage: TProgressStage; PercentDone: Byte; RedrawNow: Boolean;\r\n const R: TRect; const Msg: WideString);\r\nbegin\r\n if Assigned(FOnLoadProgress) then\r\n FOnLoadProgress(Self, Item, Stage, PercentDone, RedrawNow, R, Msg);\r\nend;\r\n\r\nprocedure TJvImagesViewer.DoLoadEnd;\r\nbegin\r\n if Assigned(FOnLoadEnd) then\r\n FOnLoadEnd(Self);\r\nend;\r\n\r\nfunction TJvImagesViewer.GetOptionsClass: TJvItemViewerOptionsClass;\r\nbegin\r\n Result := TJvImageViewerOptions;\r\nend;\r\n\r\nfunction TJvImagesViewer.GetOptions: TJvImageViewerOptions;\r\nbegin\r\n Result := TJvImageViewerOptions(inherited Options);\r\nend;\r\n\r\nprocedure TJvImagesViewer.SetOptions(const Value: TJvImageViewerOptions);\r\nbegin\r\n inherited Options := Value;\r\nend;\r\n\r\nfunction SortByFilename(Item1, Item2:Pointer):integer;\r\nbegin\r\n Result := AnsiCompareFileName(TJvPictureItem(Item1).Filename, TJvPictureItem(Item2).Filename);\r\nend;\r\n\r\nprocedure TJvImagesViewer.CustomSort(Compare: TListSortCompare);\r\nbegin\r\n if Assigned(Compare) then\r\n inherited CustomSort(Compare)\r\n else\r\n inherited CustomSort(SortByFilename);\r\n Invalidate;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\n\r\n\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend." }, { "path": "External/Jedi/Jvcl/run/JvInspDB.pas", "content": "{******************************************************************************\r\n\r\n Project JEDI Visible Component Library (J-VCL)\r\n\r\n The contents of this file are subject to the Mozilla Public License Version\r\n 1.1 (the \"License\"); you may not use this file except in compliance with the\r\n License. You may obtain a copy of the License at http://www.mozilla.org/MPL/\r\n\r\n Software distributed under the License is distributed on an \"AS IS\" basis,\r\n WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for\r\n the specific language governing rights and limitations under the License.\r\n\r\n The Initial Developer of the Original Code is Marcel Bestebroer\r\n .\r\n Portions created by Marcel Bestebroer are Copyright (C) 2000 - 2002 mbeSoft.\r\n All Rights Reserved.\r\n\r\n******************************************************************************\r\n\r\n JvInspector data layer to inspect TField instances.\r\n\r\n You may retrieve the latest version of this file at the Project JEDI home\r\n page, located at http://www.delphi-jedi.org\r\n\r\n******************************************************************************}\r\n\r\nunit JvInspDB;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n SysUtils, Classes, DB, TypInfo, DBCtrls,\r\n JvInspector, Windows;\r\n\r\ntype\r\n TJvInspectorDBData = class(TJvCustomInspectorData)\r\n private\r\n FDataLink: TFieldDataLink;\r\n protected\r\n procedure ActiveChange(Sender: TObject); virtual;\r\n procedure DataChange(Sender: TObject); virtual;\r\n procedure EditingChange(Sender: TObject); virtual;\r\n function GetAsFloat: Extended; override;\r\n function GetAsInt64: Int64; override;\r\n function GetAsMethod: TMethod; override;\r\n function GetAsOrdinal: Int64; override;\r\n function GetAsString: string; override;\r\n function GetDataSource: TDataSource; virtual;\r\n function GetField: TField; virtual;\r\n function GetFieldName: string; virtual;\r\n procedure InitDB(const ADataSource: TDataSource; const AFieldName: string); virtual;\r\n function IsEqualReference(const Ref: TJvCustomInspectorData): Boolean; override;\r\n procedure SetAsFloat(const Value: Extended); override;\r\n procedure SetAsInt64(const Value: Int64); override;\r\n procedure SetAsMethod(const Value: TMethod); override;\r\n procedure SetAsOrdinal(const Value: Int64); override;\r\n procedure SetAsString(const Value: string); override;\r\n procedure SetDataSource(const Value: TDataSource); virtual;\r\n procedure SetField(const Value: TField); virtual;\r\n procedure SetFieldName(const Value: string); virtual;\r\n property DataLink: TFieldDataLink read FDataLink;\r\n public\r\n class function New(const AParent: TJvCustomInspectorItem; const ADataSource: TDataSource;\r\n const AFieldName: string): TJvCustomInspectorItem; overload;\r\n class function New(const AParent: TJvCustomInspectorItem;\r\n const ADataSource: TDataSource): TJvInspectorItemInstances; overload;\r\n class function New(const AParent: TJvCustomInspectorItem; const ADataSource: TDataSource;\r\n const AFieldNames: array of string): TJvInspectorItemInstances; overload;\r\n destructor Destroy; override;\r\n class function FieldTypeMapping: TJvInspectorRegister;\r\n procedure GetAsSet(var Buf); override;\r\n function HasValue: Boolean; override;\r\n function IsAssigned: Boolean; override;\r\n function IsInitialized: Boolean; override;\r\n class function ItemRegister: TJvInspectorRegister; override;\r\n procedure SetAsSet(const Buf); override;\r\n property DataSource: TDataSource read GetDataSource write SetDataSource;\r\n property Field: TField read GetField write SetField;\r\n property FieldName: string read GetFieldName write SetFieldName;\r\n end;\r\n\r\n TJvInspectorTFieldTypeRegItem = class(TJvCustomInspectorRegItem)\r\n private\r\n FFieldName: string;\r\n FFieldTable: string;\r\n FFieldType: TFieldType;\r\n FTypeInfo: PTypeInfo;\r\n public\r\n constructor Create(const AFieldName, AFieldTable: string; const AFieldType: TFieldType;\r\n ATypeInfo: PTypeInfo);\r\n function MatchValue(const ADataObj: TJvCustomInspectorData): Integer; override;\r\n function MatchPercent(const ADataObj: TJvCustomInspectorData): Integer; override;\r\n property FieldName: string read FFieldName;\r\n property FieldTable: string read FFieldTable;\r\n property FieldType: TFieldType read FFieldType;\r\n property TypeInfo: PTypeInfo read FTypeInfo;\r\n end;\r\n\r\nfunction GetTableName(const AField: TField): string;\r\nfunction GetFieldName(const AField: TField): string;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvInspDB.pas $';\r\n Revision: '$Revision: 12351 $';\r\n Date: '$Date: 2009-06-28 19:13:38 +0200 (dim. 28 juin 2009) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n Consts,\r\n JvConsts, JvResources;\r\n\r\nvar\r\n GlobalDBReg: TJvInspectorRegister = nil;\r\n GlobalMapReg: TJvInspectorRegister = nil;\r\n\r\nfunction GetTableName(const AField: TField): string;\r\nbegin\r\n if AField.Origin <> '' then\r\n begin\r\n Result := AField.Origin;\r\n Delete(Result, Pos('.', Result) + 1, Length(Result));\r\n end\r\n else\r\n Result := '';\r\nend;\r\n\r\nfunction GetFieldName(const AField: TField): string;\r\nbegin\r\n if AField.Origin <> '' then\r\n begin\r\n Result := AField.Origin;\r\n Delete(Result, 1, Pos('.', Result));\r\n if Result = '' then\r\n Result := AField.FieldName;\r\n end\r\n else\r\n Result := AField.FieldName;\r\nend;\r\n\r\n//=== { TJvInspectorDBData } =================================================\r\n\r\ndestructor TJvInspectorDBData.Destroy;\r\nbegin\r\n inherited Destroy;\r\n DataLink.Free;\r\n FDataLink := nil;\r\nend;\r\n\r\nprocedure TJvInspectorDBData.ActiveChange(Sender: TObject);\r\nbegin\r\n DoneEdits(True);\r\n{ if Item.Editing then\r\n Item.DoneEdit(True);}\r\n Invalidate;\r\n if (DataSource <> nil) and (DataSource.DataSet <> nil) and DataSource.DataSet.Active then\r\n InitEdits;\r\n{ if (DataSource <> nil) and (DataSource.DataSet <> nil) and DataSource.DataSet.Active and\r\n (Item.Inspector.FocusedItem <> nil) then\r\n Item.Inspector.FocusedItem.InitEdit;}\r\nend;\r\n\r\nprocedure TJvInspectorDBData.DataChange(Sender: TObject);\r\nbegin\r\n if (DataLink <> nil) and (DataLink.Field <> nil) then\r\n begin\r\n RefreshEdits;\r\n{ if Item.Editing then\r\n begin\r\n Item.DoneEdit(True);\r\n Item.InitEdit;\r\n end;}\r\n InvalidateData;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvInspectorDBData.EditingChange(Sender: TObject);\r\nbegin\r\n Invalidate;\r\nend;\r\n\r\nfunction TJvInspectorDBData.GetAsFloat: Extended;\r\nbegin\r\n CheckReadAccess;\r\n if TypeInfo.Kind = tkFloat then\r\n Result := Field.AsFloat\r\n else\r\n raise EJvInspectorData.CreateResFmt(@RsEJvInspDataNoAccessAs, [cJvInspectorFloat]);\r\nend;\r\n\r\nfunction TJvInspectorDBData.GetAsInt64: Int64;\r\nbegin\r\n CheckReadAccess;\r\n if TypeInfo.Kind = tkInt64 then\r\n Result := TLargeIntField(Field).AsLargeInt\r\n else\r\n raise EJvInspectorData.CreateResFmt(@RsEJvInspDataNoAccessAs, [cJvInspectorInt64]);\r\nend;\r\n\r\nfunction TJvInspectorDBData.GetAsMethod: TMethod;\r\nbegin\r\n CheckReadAccess;\r\n raise EJvInspectorData.CreateResFmt(@RsEJvInspDataNoAccessAs, [cJvInspectorTMethod]);\r\nend;\r\n\r\nfunction TJvInspectorDBData.GetAsOrdinal: Int64;\r\nbegin\r\n CheckReadAccess;\r\n if Field is TBooleanField then\r\n Result := Ord(TBooleanField(Field).AsBoolean)\r\n else\r\n if TypeInfo.Kind in [tkInteger, tkChar, tkEnumeration, tkSet, tkWChar, tkClass] then\r\n begin\r\n if GetTypeData(TypeInfo).OrdType = otULong then\r\n Result := Cardinal(Field.AsInteger)\r\n else\r\n Result := Field.AsInteger;\r\n end\r\n else\r\n raise EJvInspectorData.CreateResFmt(@RsEJvInspDataNoAccessAs, [cJvInspectorOrdinal]);\r\nend;\r\n\r\nfunction TJvInspectorDBData.GetAsString: string;\r\nbegin\r\n CheckReadAccess;\r\n if TypeInfo.Kind in tkStrings then\r\n Result := Field.AsString\r\n else\r\n raise EJvInspectorData.CreateResFmt(@RsEJvInspDataNoAccessAs, [cJvInspectorString]);\r\nend;\r\n\r\nfunction TJvInspectorDBData.GetDataSource: TDataSource;\r\nbegin\r\n if DataLink <> nil then\r\n Result := DataLink.DataSource\r\n else\r\n Result := nil;\r\nend;\r\n\r\nfunction TJvInspectorDBData.GetField: TField;\r\nbegin\r\n if (DataSource <> nil) and (DataSource.DataSet <> nil) and (FieldName <> '') then\r\n Result := DataSource.DataSet.FindField(FieldName)\r\n else\r\n Result := nil;\r\nend;\r\n\r\nfunction TJvInspectorDBData.GetFieldName: string;\r\nbegin\r\n if DataLink <> nil then\r\n Result := DataLink.FieldName\r\n else\r\n Result := '';\r\nend;\r\n\r\nprocedure TJvInspectorDBData.InitDB(const ADataSource: TDataSource; const AFieldName: string);\r\nvar\r\n MapItem: TJvCustomInspectorRegItem;\r\n ATypeInfo: PTypeInfo;\r\nbegin\r\n if DataLink = nil then\r\n FDataLink := TFieldDataLink.Create;\r\n DataLink.DataSource := ADataSource;\r\n DataLink.FieldName := AFieldName;\r\n DataLink.OnDataChange := DataChange;\r\n DataLink.OnActiveChange := ActiveChange;\r\n DataLink.OnEditingChange := EditingChange;\r\n MapItem := FieldTypeMapping.FindMatch(Self);\r\n if MapItem <> nil then\r\n ATypeInfo := TJvInspectorTFieldTypeRegItem(MapItem).TypeInfo\r\n else\r\n ATypeInfo := nil;\r\n if Field <> nil then\r\n begin\r\n Name := Field.DisplayName;\r\n TypeInfo := ATypeInfo;\r\n end\r\n else\r\n begin\r\n Name := AFieldName;\r\n TypeInfo := nil;\r\n end;\r\nend;\r\n\r\nfunction TJvInspectorDBData.IsEqualReference(const Ref: TJvCustomInspectorData): Boolean;\r\nbegin\r\n Result := (Ref is TJvInspectorDBData) and (TJvInspectorDBData(Ref).Field = Field);\r\nend;\r\n\r\nprocedure TJvInspectorDBData.SetAsFloat(const Value: Extended);\r\nbegin\r\n CheckWriteAccess;\r\n if TypeInfo.Kind = tkFloat then\r\n begin\r\n DataLink.Edit;\r\n Field.AsFloat := Value;\r\n end\r\n else\r\n raise EJvInspectorData.CreateResFmt(@RsEJvInspDataNoAccessAs, [cJvInspectorFloat]);\r\nend;\r\n\r\nprocedure TJvInspectorDBData.SetAsInt64(const Value: Int64);\r\nbegin\r\n CheckWriteAccess;\r\n if TypeInfo.Kind = tkInt64 then\r\n begin\r\n DataLink.Edit;\r\n TLargeIntField(Field).AsLargeInt := Value;\r\n end\r\n else\r\n raise EJvInspectorData.CreateResFmt(@RsEJvInspDataNoAccessAs, [cJvInspectorInt64]);\r\nend;\r\n\r\nprocedure TJvInspectorDBData.SetAsMethod(const Value: TMethod);\r\nbegin\r\n CheckWriteAccess;\r\n raise EJvInspectorData.CreateResFmt(@RsEJvInspDataNoAccessAs, [cJvInspectorTMethod]);\r\nend;\r\n\r\nprocedure TJvInspectorDBData.SetAsOrdinal(const Value: Int64);\r\nvar\r\n MinValue: Int64;\r\n MaxValue: Int64;\r\nbegin\r\n CheckWriteAccess;\r\n if Field is TBooleanField then\r\n begin\r\n DataLink.Edit;\r\n TBooleanField(Field).AsBoolean := Value <> 0;\r\n end\r\n else\r\n if TypeInfo.Kind in [tkInteger, tkChar, tkEnumeration, tkWChar] then\r\n begin\r\n case GetTypeData(TypeInfo).OrdType of\r\n otSByte:\r\n begin\r\n MinValue := GetTypeData(TypeInfo).MinValue;\r\n MaxValue := GetTypeData(TypeInfo).MaxValue;\r\n if (Value < MinValue) or (Value > MaxValue) then\r\n raise ERangeError.CreateResFmt(@SOutOfRange, [MinValue, MaxValue]);\r\n DataLink.Edit;\r\n Field.AsInteger := Shortint(Value)\r\n end;\r\n otUByte:\r\n begin\r\n MinValue := GetTypeData(TypeInfo).MinValue;\r\n MaxValue := GetTypeData(TypeInfo).MaxValue;\r\n if (Value < MinValue) or (Value > MaxValue) then\r\n raise ERangeError.CreateResFmt(@SOutOfRange, [MinValue, MaxValue]);\r\n DataLink.Edit;\r\n Field.AsInteger := Byte(Value)\r\n end;\r\n otSWord:\r\n begin\r\n MinValue := GetTypeData(TypeInfo).MinValue;\r\n MaxValue := GetTypeData(TypeInfo).MaxValue;\r\n if (Value < MinValue) or (Value > MaxValue) then\r\n raise ERangeError.CreateResFmt(@SOutOfRange, [MinValue, MaxValue]);\r\n DataLink.Edit;\r\n Field.AsInteger := Smallint(Value)\r\n end;\r\n otUWord:\r\n begin\r\n MinValue := GetTypeData(TypeInfo).MinValue;\r\n MaxValue := GetTypeData(TypeInfo).MaxValue;\r\n if (Value < MinValue) or (Value > MaxValue) then\r\n raise ERangeError.CreateResFmt(@SOutOfRange, [MinValue, MaxValue]);\r\n DataLink.Edit;\r\n Field.AsInteger := Word(Value)\r\n end;\r\n otSLong:\r\n begin\r\n MinValue := GetTypeData(TypeInfo).MinValue;\r\n MaxValue := GetTypeData(TypeInfo).MaxValue;\r\n if (Value < MinValue) or (Value > MaxValue) then\r\n raise ERangeError.CreateResFmt(@SOutOfRange, [MinValue, MaxValue]);\r\n DataLink.Edit;\r\n Field.AsInteger := Integer(Value)\r\n end;\r\n otULong:\r\n begin\r\n MinValue := Longword(GetTypeData(TypeInfo).MinValue);\r\n MaxValue := Longword(GetTypeData(TypeInfo).MaxValue);\r\n if (Value < MinValue) or (Value > MaxValue) then\r\n raise ERangeError.CreateResFmt(@SOutOfRange, [MinValue, MaxValue]);\r\n DataLink.Edit;\r\n Field.AsInteger := Integer(Value)\r\n end;\r\n end;\r\n end\r\n else\r\n if TypeInfo.Kind = tkClass then\r\n begin\r\n DataLink.Edit;\r\n Field.AsInteger := Integer(Value);\r\n end\r\n else\r\n raise EJvInspectorData.CreateResFmt(@RsEJvInspDataNoAccessAs, [cJvInspectorOrdinal]);\r\nend;\r\n\r\nprocedure TJvInspectorDBData.SetAsString(const Value: string);\r\nbegin\r\n CheckWriteAccess;\r\n if TypeInfo.Kind in tkStrings then\r\n begin\r\n DataLink.Edit;\r\n Field.AsString := Value;\r\n end\r\n else\r\n raise EJvInspectorData.CreateResFmt(@RsEJvInspDataNoAccessAs, [cJvInspectorString]);\r\nend;\r\n\r\nprocedure TJvInspectorDBData.SetDataSource(const Value: TDataSource);\r\nvar\r\n OrgFieldName: string;\r\nbegin\r\n if DataSource <> Value then\r\n begin\r\n OrgFieldName := FieldName;\r\n DataLink.DataSource := Value;\r\n if FieldName <> OrgFieldName then\r\n FieldName := OrgFieldName\r\n else\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvInspectorDBData.SetField(const Value: TField);\r\nbegin\r\n if Field <> Value then\r\n begin\r\n TFieldDataLink(DataLink).FieldName := Value.FieldName;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvInspectorDBData.SetFieldName(const Value: string);\r\nbegin\r\n if FieldName <> Value then\r\n begin\r\n TFieldDataLink(DataLink).FieldName := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure RegisterDBTypes; forward;\r\n\r\nclass function TJvInspectorDBData.FieldTypeMapping: TJvInspectorRegister;\r\nbegin\r\n if GlobalMapReg = nil then\r\n begin\r\n GlobalMapReg := TJvInspectorRegister.Create(TJvCustomInspectorData);\r\n RegisterDBTypes; // register\r\n end;\r\n Result := GlobalMapReg;\r\nend;\r\n\r\nprocedure TJvInspectorDBData.GetAsSet(var Buf);\r\nvar\r\n CompType: PTypeInfo;\r\n EnumMin: Integer;\r\n EnumMax: Integer;\r\n ResBytes: Integer;\r\n TmpInt: Integer;\r\nbegin\r\n CheckReadAccess;\r\n if TypeInfo.Kind <> tkSet then\r\n raise EJvInspectorData.CreateResFmt(@RsEJvInspDataNoAccessAs, [cJvInspectorSet]);\r\n CompType := GetTypeData(TypeInfo).CompType^;\r\n EnumMin := GetTypeData(CompType).MinValue;\r\n EnumMax := GetTypeData(CompType).MaxValue;\r\n ResBytes := (EnumMax div 8) - (EnumMin div 8) + 1;\r\n if ResBytes > 4 then\r\n ResBytes := 4;\r\n TmpInt := Field.AsInteger;\r\n Move(TmpInt, Buf, ResBytes);\r\nend;\r\n\r\nfunction TJvInspectorDBData.HasValue: Boolean;\r\nbegin\r\n Result := IsInitialized and (DataSource <> nil) and (DataSource.DataSet <> nil) and\r\n DataSource.DataSet.Active;\r\nend;\r\n\r\nfunction TJvInspectorDBData.IsAssigned: Boolean;\r\nbegin\r\n Result := IsInitialized and not Field.IsNull;\r\nend;\r\n\r\nfunction TJvInspectorDBData.IsInitialized: Boolean;\r\nbegin\r\n Result := (DataLink <> nil) and (DataSource <> nil) and (Field <> nil);\r\nend;\r\n\r\nclass function TJvInspectorDBData.ItemRegister: TJvInspectorRegister;\r\nbegin\r\n if GlobalDBReg = nil then\r\n GlobalDBReg := TJvInspectorRegister.Create(TJvInspectorDBData);\r\n Result := GlobalDBReg;\r\nend;\r\n\r\nclass function TJvInspectorDBData.New(const AParent: TJvCustomInspectorItem;\r\n const ADataSource: TDataSource; const AFieldName: string): TJvCustomInspectorItem;\r\nvar\r\n Data: TJvInspectorDBData;\r\nbegin\r\n Data := CreatePrim('', nil);\r\n Data.InitDB(ADataSource, AFieldName);\r\n Data := TJvInspectorDBData(RegisterInstance(Data));\r\n if Data <> nil then\r\n Result := Data.NewItem(AParent)\r\n else\r\n Result := nil;\r\nend;\r\n\r\nclass function TJvInspectorDBData.New(const AParent: TJvCustomInspectorItem;\r\n const ADataSource: TDataSource): TJvInspectorItemInstances;\r\nvar\r\n DS: TDataSet;\r\n IArr: Integer;\r\n I: Integer;\r\n TmpItem: TJvCustomInspectorItem;\r\nbegin\r\n SetLength(Result, ADataSource.DataSet.FieldCount);\r\n DS := ADataSource.DataSet;\r\n IArr := 0;\r\n for I := 0 to DS.FieldCount - 1 do\r\n begin\r\n TmpItem := New(AParent, ADataSource, DS.Fields[I].FieldName);\r\n if TmpItem <> nil then\r\n begin\r\n Result[IArr] := TmpItem;\r\n Inc(IArr);\r\n end;\r\n end;\r\n SetLength(Result, IArr);\r\nend;\r\n\r\nclass function TJvInspectorDBData.New(const AParent: TJvCustomInspectorItem;\r\n const ADataSource: TDataSource; const AFieldNames: array of string): TJvInspectorItemInstances;\r\nvar\r\n IArr: Integer;\r\n I: Integer;\r\n TmpItem: TJvCustomInspectorItem;\r\nbegin\r\n SetLength(Result, Length(AFieldNames));\r\n IArr := 0;\r\n for I := Low(AFieldNames) to High(AFieldNames) do\r\n begin\r\n TmpItem := New(AParent, ADataSource, AFieldNames[I]);\r\n if TmpItem <> nil then\r\n begin\r\n Result[IArr] := TmpItem;\r\n Inc(IArr);\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvInspectorDBData.SetAsSet(const Buf);\r\nvar\r\n CompType: PTypeInfo;\r\n EnumMin: Integer;\r\n EnumMax: Integer;\r\n ResBytes: Integer;\r\n TmpInt: Integer;\r\nbegin\r\n CheckWriteAccess;\r\n if TypeInfo.Kind <> tkSet then\r\n raise EJvInspectorData.CreateResFmt(@RsEJvInspDataNoAccessAs, [cJvInspectorSet]);\r\n CompType := GetTypeData(TypeInfo).CompType^;\r\n EnumMin := GetTypeData(CompType).MinValue;\r\n EnumMax := GetTypeData(CompType).MaxValue;\r\n ResBytes := (EnumMax div 8) - (EnumMin div 8) + 1;\r\n if ResBytes > 4 then\r\n ResBytes := 4;\r\n TmpInt := 0;\r\n Move(Buf, TmpInt, ResBytes);\r\n DataLink.Edit;\r\n Field.AsInteger := TmpInt;\r\nend;\r\n\r\n//=== { TJvInspectorTFieldTypeRegItem } ======================================\r\n\r\nconstructor TJvInspectorTFieldTypeRegItem.Create(const AFieldName, AFieldTable: string;\r\n const AFieldType: TFieldType; ATypeInfo: PTypeInfo);\r\nbegin\r\n inherited Create(nil);\r\n FFieldName := AFieldName;\r\n FFieldTable := AFieldTable;\r\n FFieldType := AFieldType;\r\n FTypeInfo := ATypeInfo;\r\nend;\r\n\r\nfunction TJvInspectorTFieldTypeRegItem.MatchValue(const ADataObj: TJvCustomInspectorData): Integer;\r\nvar\r\n ThisField: TField;\r\n GoOn: Boolean;\r\n ThisTableName: string;\r\n ThisFieldName: string;\r\nbegin\r\n { Determine value as follows:\r\n\r\n Base value = 0\r\n * FieldType specified:\r\n * no match: return 0\r\n * match: add 16\r\n * FieldName specified:\r\n * no match: return 0\r\n * matches by mask: add 4\r\n * exact match: add 8\r\n * FieldTable specified:\r\n * no match: return 0\r\n * matches by mask: add 1\r\n * exact match: add 2 }\r\n ThisField := (ADataObj as TJvInspectorDBData).Field;\r\n Result := 0;\r\n GoOn := ThisField <> nil;\r\n if GoOn then\r\n begin\r\n ThisTableName := GetTableName(ThisField);\r\n ThisFieldName := GetFieldName(ThisField);\r\n if FieldType <> ftUnknown then\r\n begin\r\n if FieldType = ThisField.DataType then\r\n Result := Result or 16\r\n else\r\n GoOn := False;\r\n end;\r\n if GoOn and (FieldName <> '') then\r\n begin\r\n if AnsiSameText(FieldName, ThisFieldName) then\r\n Result := Result or 8\r\n else\r\n GoOn := False;\r\n end;\r\n if GoOn and (FieldTable <> '') then\r\n begin\r\n if AnsiSameText(FieldTable, ThisTableName) then\r\n Result := Result or 2\r\n else\r\n GoOn := False;\r\n end;\r\n end;\r\n if not GoOn then\r\n Result := 0;\r\n if FieldType = ftUnknown then\r\n Result := 1;\r\nend;\r\n\r\nfunction TJvInspectorTFieldTypeRegItem.MatchPercent(const ADataObj: TJvCustomInspectorData): Integer;\r\nbegin\r\n if IsMatch(ADataObj) then\r\n ADataObj.TypeInfo := TypeInfo;\r\n if (FieldType = ftUnknown) and (ADataObj.TypeInfo = nil) then\r\n Result := 100 // terminate the search now\r\n else\r\n Result := 0; // Make sure the other items are searched as well\r\nend;\r\n\r\nprocedure RegisterDBTypes;\r\nbegin\r\n with TJvInspectorDBData.FieldTypeMapping do\r\n begin\r\n Add(TJvInspectorTFieldTypeRegItem.Create('', '', ftString, System.TypeInfo(string)));\r\n Add(TJvInspectorTFieldTypeRegItem.Create('', '', ftSmallint, System.TypeInfo(Smallint)));\r\n {$IFDEF COMPILER12_UP}\r\n Add(TJvInspectorTFieldTypeRegItem.Create('', '', ftShortint, System.TypeInfo(ShortInt)));\r\n {$ENDIF COMPILER12_UP}\r\n Add(TJvInspectorTFieldTypeRegItem.Create('', '', ftInteger, System.TypeInfo(Integer)));\r\n Add(TJvInspectorTFieldTypeRegItem.Create('', '', ftWord, System.TypeInfo(Word)));\r\n {$IFDEF COMPILER12_UP}\r\n Add(TJvInspectorTFieldTypeRegItem.Create('', '', ftLongWord, System.TypeInfo(LongWord)));\r\n {$ENDIF COMPILER12_UP}\r\n Add(TJvInspectorTFieldTypeRegItem.Create('', '', ftBoolean, System.TypeInfo(Boolean)));\r\n Add(TJvInspectorTFieldTypeRegItem.Create('', '', ftFloat, System.TypeInfo(Double)));\r\n {$IFDEF COMPILER12_UP}\r\n Add(TJvInspectorTFieldTypeRegItem.Create('', '', DB.ftExtended, System.TypeInfo(Extended)));\r\n {$ENDIF COMPILER12_UP}\r\n Add(TJvInspectorTFieldTypeRegItem.Create('', '', ftCurrency, System.TypeInfo(Currency)));\r\n Add(TJvInspectorTFieldTypeRegItem.Create('', '', ftBCD, System.TypeInfo(Currency)));\r\n Add(TJvInspectorTFieldTypeRegItem.Create('', '', ftDate, System.TypeInfo(TDateTime)));\r\n Add(TJvInspectorTFieldTypeRegItem.Create('', '', ftTime, System.TypeInfo(TDateTime)));\r\n Add(TJvInspectorTFieldTypeRegItem.Create('', '', ftDateTime, System.TypeInfo(TDateTime)));\r\n {$IFDEF COMPILER10_UP}\r\n Add(TJvInspectorTFieldTypeRegItem.Create('', '', ftOraTimeStamp, System.TypeInfo(TDateTime)));\r\n {$ENDIF COMPILER10_UP}\r\n Add(TJvInspectorTFieldTypeRegItem.Create('', '', ftAutoInc, System.TypeInfo(Integer)));\r\n Add(TJvInspectorTFieldTypeRegItem.Create('', '', ftMemo, System.TypeInfo(string)));\r\n {$IFDEF COMPILER10_UP}\r\n Add(TJvInspectorTFieldTypeRegItem.Create('', '', ftWideMemo, System.TypeInfo(string)));\r\n {$ENDIF COMPILER10_UP}\r\n Add(TJvInspectorTFieldTypeRegItem.Create('', '', ftFmtMemo, System.TypeInfo(string)));\r\n Add(TJvInspectorTFieldTypeRegItem.Create('', '', ftFixedChar, System.TypeInfo(string)));\r\n {$IFDEF COMPILER10_UP}\r\n Add(TJvInspectorTFieldTypeRegItem.Create('', '', ftFixedWideChar, System.TypeInfo(string)));\r\n {$ENDIF COMPILER10_UP}\r\n Add(TJvInspectorTFieldTypeRegItem.Create('', '', ftWideString, System.TypeInfo(WideString)));\r\n Add(TJvInspectorTFieldTypeRegItem.Create('', '', ftLargeint, System.TypeInfo(Int64)));\r\n Add(TJvInspectorTFieldTypeRegItem.Create('', '', ftVariant, System.TypeInfo(Variant)));\r\n Add(TJvInspectorTFieldTypeRegItem.Create('', '', ftInterface, System.TypeInfo(IUnknown)));\r\n Add(TJvInspectorTFieldTypeRegItem.Create('', '', ftIDispatch, System.TypeInfo(IDispatch)));\r\n Add(TJvInspectorTFieldTypeRegItem.Create('', '', ftGUID, System.TypeInfo(string)));\r\n Add(TJvInspectorTFieldTypeRegItem.Create('', '', ftOraClob, System.TypeInfo(string)));\r\n end;\r\nend;\r\n\r\ninitialization\r\n {$IFDEF UNITVERSIONING}\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n {$ENDIF UNITVERSIONING}\r\n\r\nfinalization\r\n FreeAndNil(GlobalDBReg);\r\n FreeAndNil(GlobalMapReg);\r\n {$IFDEF UNITVERSIONING}\r\n UnregisterUnitVersion(HInstance);\r\n {$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n\r\n" }, { "path": "External/Jedi/Jvcl/run/JvInspExtraEditors.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvInspExtraEditors.pas, released on 2001-02-28.\r\n\r\nThe Initial Developer of the Original Code is Marcel Bestebroer\r\n .\r\nPortions created by Marcel Bestebroer are Copyright (C) 2000 - 2001 mbeSoft.\r\nAll Rights Reserved.\r\n\r\nContributor(s): Michael Beck [mbeck att bigfoot dott com], Markus Spoettl.\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nDescription:\r\n Additional editors for JvInspector.\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvInspExtraEditors.pas 13415 2012-09-10 09:51:54Z obones $\r\n\r\nunit JvInspExtraEditors;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n SysUtils, Classes,\r\n Windows, Graphics, Controls, StdCtrls, ImgList,\r\n {$IFDEF HAS_UNIT_SYSTEM_UITYPES}\r\n System.UITypes,\r\n {$ENDIF HAS_UNIT_SYSTEM_UITYPES}\r\n JvInspector;\r\n\r\ntype\r\n // In the same spirit as the TJvTypeInfoHelper class in JvInspector.pas\r\n // we define here a TJvTypeInfoExtraHelper class for the types that\r\n // are used by the editors in this unit. Please refer to JvInspector.pas\r\n // for more details on this C++ Builder compatibility issue.\r\n TJvTypeInfoExtraHelper = class(TJvTypeInfoHelper)\r\n private\r\n FTAlignProp: TAlign;\r\n FTAnchorsProp: TAnchors;\r\n FTColorProp: TColor;\r\n FTImageIndexProp: TImageIndex;\r\n published\r\n property TAlignProp: TAlign read FTAlignProp;\r\n property TAnchorsProp: TAnchors read FTAnchorsProp;\r\n property TColorProp: TColor read FTColorProp;\r\n property TImageIndexProp: TImageIndex read FTImageIndexProp;\r\n end;\r\n\r\n { TAlign item editor. Descents from the enumeration item to keep DisplayValue available }\r\n TJvInspectorAlignItem = class(TJvInspectorEnumItem)\r\n private\r\n FUnassignedColor: TColor;\r\n FNormalColor: TColor;\r\n FActiveColor: TColor;\r\n protected\r\n procedure EditKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState); override;\r\n procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;\r\n procedure PaintAlignBox(const Align: TAlign; const ACanvas: TCanvas; const ARect: TRect;\r\n const UseUnassigned: Boolean);\r\n public\r\n constructor Create(const AParent: TJvCustomInspectorItem;\r\n const AData: TJvCustomInspectorData); override;\r\n procedure DoneEdit(const CancelEdits: Boolean = False); override;\r\n procedure DrawValue(const ACanvas: TCanvas); override;\r\n procedure InitEdit; override;\r\n class procedure RegisterAsDefaultItem;\r\n class procedure UnregisterAsDefaultItem;\r\n property UnassignedColor: TColor read FUnassignedColor;\r\n property NormalColor: TColor read FNormalColor;\r\n property ActiveColor: TColor read FActiveColor;\r\n end;\r\n\r\n { TAnchors item editor. Descents from the set item to keep DisplayValue available }\r\n TJvInspectorAnchorsItem = class(TJvInspectorSetItem)\r\n private\r\n FUnassignedColor: TColor;\r\n FNormalColor: TColor;\r\n FActiveColor: TColor;\r\n protected\r\n procedure EditKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState); override;\r\n procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;\r\n procedure SetFlags(const Value: TInspectorItemFlags); override;\r\n procedure SetItemSetFlags(const Value: TInspectorSetFlags); override;\r\n procedure PaintAnchorsBox(const Anchors: TAnchors; const ACanvas: TCanvas; const ARect: TRect;\r\n const UseUnassigned: Boolean);\r\n public\r\n constructor Create(const AParent: TJvCustomInspectorItem;\r\n const AData: TJvCustomInspectorData); override;\r\n procedure DoneEdit(const CancelEdits: Boolean = False); override;\r\n procedure DrawValue(const ACanvas: TCanvas); override;\r\n procedure InitEdit; override;\r\n class procedure RegisterAsDefaultItem;\r\n class procedure UnregisterAsDefaultItem;\r\n property UnassignedColor: TColor read FUnassignedColor;\r\n property NormalColor: TColor read FNormalColor;\r\n property ActiveColor: TColor read FActiveColor;\r\n end;\r\n\r\n { TColor item editor. Will render the color in a box, together with the name/value }\r\n TJvInspectorColorItem = class(TJvCustomInspectorItem)\r\n private\r\n FColors: TStringList;\r\n FStdColors: TStringList;\r\n FIncludeStdColors: Boolean;\r\n protected\r\n procedure AddStdColor(const S: string);\r\n function BorderColor(const ABackgroundColor, AInternalColor: TColor): TColor;\r\n function NameForColor(const Color: TColor): string;\r\n procedure PaintValue(const Color: TColor; const ColorName: string; const ACanvas: TCanvas;\r\n const ARect: TRect);\r\n procedure DoDrawListItem(Control: TWinControl; Index: Integer; Rect: TRect;\r\n State: TOwnerDrawState); override;\r\n\r\n procedure DoMeasureListItem(Control: TWinControl; Index: Integer; var Height: Integer); override;\r\n procedure DoMeasureListItemWidth(Control: TWinControl; Index: Integer; var Width: Integer); override;\r\n function GetDisplayValue: string; override;\r\n procedure GetValueList(const Strings: TStrings); override;\r\n procedure SetDisplayValue(const Value: string); override;\r\n procedure SetFlags(const Value: TInspectorItemFlags); override;\r\n procedure SetRects(const RectKind: TInspectorPaintRect; Value: TRect); override;\r\n public\r\n constructor Create(const AParent: TJvCustomInspectorItem;\r\n const AData: TJvCustomInspectorData); override;\r\n procedure BeforeDestruction; override;\r\n procedure DrawValue(const ACanvas: TCanvas); override;\r\n class procedure RegisterAsDefaultItem;\r\n class procedure UnregisterAsDefaultItem;\r\n property IncludeStdColors: Boolean read FIncludeStdColors write FIncludeStdColors;\r\n end;\r\n\r\n { TImageList image index editor. Will render the image next to the value }\r\n TJvInspectorTImageIndexItem = class(TJvCustomInspectorItem)\r\n private\r\n FImageList: TCustomImageList;\r\n protected\r\n procedure PaintValue(const ImgNum: Integer; const ImgName: string; const ACanvas: TCanvas;\r\n const ARect: TRect);\r\n procedure DoDrawListItem(Control: TWinControl; Index: Integer; Rect: TRect;\r\n State: TOwnerDrawState); override;\r\n\r\n procedure DoMeasureListItem(Control: TWinControl; Index: Integer; var Height: Integer); override;\r\n procedure DoMeasureListItemWidth(Control: TWinControl; Index: Integer; var Width: Integer); override;\r\n function GetDisplayValue: string; override;\r\n procedure GetValueList(const Strings: TStrings); override;\r\n procedure SetDisplayValue(const Value: string); override;\r\n procedure SetFlags(const Value: TInspectorItemFlags); override;\r\n procedure SetRects(const RectKind: TInspectorPaintRect; Value: TRect); override;\r\n public\r\n procedure DrawValue(const ACanvas: TCanvas); override;\r\n class procedure RegisterAsDefaultItem;\r\n class procedure UnregisterAsDefaultItem;\r\n property Images: TCustomImageList read FImageList write FImageList;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvInspExtraEditors.pas $';\r\n Revision: '$Revision: 13415 $';\r\n Date: '$Date: 2012-09-10 11:51:54 +0200 (lun. 10 sept. 2012) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n Types, TypInfo,\r\n JclRTTI,\r\n JvResources;\r\n\r\ntype\r\n TColorQuad = packed record\r\n Red: Byte;\r\n Green: Byte;\r\n Blue: Byte;\r\n Alpha: Byte;\r\n end;\r\n\r\n//=== { TJvInspectorAlignItem } ==============================================\r\n\r\nconstructor TJvInspectorAlignItem.Create(const AParent: TJvCustomInspectorItem;\r\n const AData: TJvCustomInspectorData);\r\nbegin\r\n inherited Create(AParent, AData);\r\n FUnassignedColor := clGrayText;\r\n FNormalColor := clWindowText;\r\n FActiveColor := clBlue;\r\nend;\r\n\r\nprocedure TJvInspectorAlignItem.EditKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);\r\nvar\r\n NewAlign: TAlign;\r\nbegin\r\n if Editing and (Shift = [ssCtrl]) then\r\n begin\r\n if Data.IsAssigned then\r\n NewAlign := TAlign(Data.AsOrdinal)\r\n else\r\n NewAlign := alNone;\r\n case Key of\r\n VK_UP, VK_NUMPAD8:\r\n begin\r\n if NewAlign = alTop then\r\n NewAlign := alNone\r\n else\r\n NewAlign := alTop;\r\n end;\r\n VK_RIGHT, VK_NUMPAD6:\r\n begin\r\n if NewAlign = alRight then\r\n NewAlign := alNone\r\n else\r\n NewAlign := alRight;\r\n end;\r\n VK_DOWN, VK_NUMPAD2:\r\n begin\r\n if NewAlign = alBottom then\r\n NewAlign := alNone\r\n else\r\n NewAlign := alBottom;\r\n end;\r\n VK_LEFT, VK_NUMPAD4:\r\n begin\r\n if NewAlign = alLeft then\r\n NewAlign := alNone\r\n else\r\n NewAlign := alLeft;\r\n end;\r\n VK_NUMPAD5, VK_HOME, VK_NUMPAD7:\r\n begin\r\n if NewAlign = alClient then\r\n NewAlign := alNone\r\n else\r\n NewAlign := alClient;\r\n end;\r\n end;\r\n case Key of\r\n VK_UP, VK_NUMPAD8, VK_RIGHT, VK_NUMPAD6, VK_DOWN, VK_NUMPAD2,\r\n VK_LEFT, VK_NUMPAD4, VK_NUMPAD5, VK_HOME, VK_NUMPAD7:\r\n begin\r\n Data.AsOrdinal := Ord(NewAlign);\r\n Key := 0;\r\n end;\r\n else\r\n inherited EditKeyDown(Sender, Key, Shift);\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvInspectorAlignItem.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);\r\nvar\r\n NewAlign: TAlign;\r\n R: TRect;\r\nbegin\r\n if Editing and (Shift = [ssLeft]) then\r\n begin\r\n if Data.IsAssigned then\r\n NewAlign := TAlign(Data.AsOrdinal)\r\n else\r\n NewAlign := alNone;\r\n R := Rects[iprValueArea];\r\n if PtInRect(Rect(R.Left + 5, R.Top, R.Right - 5, R.Top + 5), Point(X, Y)) then\r\n begin\r\n if NewAlign = alTop then\r\n NewAlign := alNone\r\n else\r\n NewAlign := alTop;\r\n end\r\n else\r\n if PtInRect(Rect(R.Right - 5, R.Top + 5, R.Right, R.Bottom - 5), Point(X, Y)) then\r\n begin\r\n if NewAlign = alRight then\r\n NewAlign := alNone\r\n else\r\n NewAlign := alRight;\r\n end\r\n else\r\n if PtInRect(Rect(R.Left + 5, R.Bottom - 5, R.Right - 5, R.Bottom), Point(X, Y)) then\r\n begin\r\n if NewAlign = alBottom then\r\n NewAlign := alNone\r\n else\r\n NewAlign := alBottom;\r\n end\r\n else\r\n if PtInRect(Rect(R.Left, R.Top + 5, R.Left + 5, R.Bottom - 5), Point(X, Y)) then\r\n begin\r\n if NewAlign = alLeft then\r\n NewAlign := alNone\r\n else\r\n NewAlign := alLeft;\r\n end\r\n else\r\n if PtInRect(R, Point(X, Y)) then\r\n begin\r\n if NewAlign = alClient then\r\n NewAlign := alNone\r\n else\r\n NewAlign := alClient;\r\n end;\r\n Data.AsOrdinal := Ord(NewAlign);\r\n end;\r\nend;\r\n\r\nprocedure TJvInspectorAlignItem.PaintAlignBox(const Align: TAlign;\r\n const ACanvas: TCanvas; const ARect: TRect; const UseUnassigned: Boolean);\r\nvar\r\n NoAlignColor: TColor;\r\n\r\n procedure RenderAlign(const Check: TAlign; const X, Y: Integer);\r\n begin\r\n if (Align = alClient) or (Align = Check) then\r\n ACanvas.Pen.Color := ActiveColor\r\n else\r\n ACanvas.Pen.Color := NoAlignColor;\r\n ACanvas.LineTo(X, Y);\r\n end;\r\n\r\nbegin\r\n if UseUnassigned then\r\n NoAlignColor := UnassignedColor\r\n else\r\n NoAlignColor := NormalColor;\r\n ACanvas.Pen.Width := 2;\r\n\r\n ACanvas.MoveTo(ARect.Left + 2, ARect.Top + 2);\r\n RenderAlign(alTop, ARect.Right - 3, ARect.Top + 2);\r\n RenderAlign(alRight, ARect.Right - 3, ARect.Bottom - 3);\r\n RenderAlign(alBottom, ARect.Left + 2, ARect.Bottom - 3);\r\n RenderAlign(alLeft, ARect.Left + 2, ARect.Top + 1);\r\nend;\r\n\r\nprocedure TJvInspectorAlignItem.DoneEdit(const CancelEdits: Boolean = False);\r\nbegin\r\n SetEditing(False);\r\nend;\r\n\r\nprocedure TJvInspectorAlignItem.DrawValue(const ACanvas: TCanvas);\r\nvar\r\n IsValid: Boolean;\r\n Align: TAlign;\r\n ARect: TRect;\r\n\r\nbegin\r\n IsValid := Data.IsInitialized and Data.IsAssigned and Data.HasValue;\r\n if IsValid then\r\n Align := TAlign(Data.AsOrdinal)\r\n else\r\n Align := alNone;\r\n\r\n if Editing and Data.IsAssigned then\r\n ACanvas.Brush.Color := clWindow;\r\n\r\n ARect := Rects[iprValueArea];\r\n ACanvas.FillRect(ARect);\r\n PaintAlignBox(Align, ACanvas, ARect, not IsValid);\r\nend;\r\n\r\nprocedure TJvInspectorAlignItem.InitEdit;\r\nbegin\r\n SetEditing(CanEdit);\r\nend;\r\n\r\nclass procedure TJvInspectorAlignItem.RegisterAsDefaultItem;\r\nbegin\r\n with TJvCustomInspectorData.ItemRegister do\r\n begin\r\n if IndexOf(Self) = -1 then\r\n Add(TJvInspectorTypeInfoRegItem.Create(Self, TypeInfo(TAlign)));\r\n end;\r\nend;\r\n\r\nclass procedure TJvInspectorAlignItem.UnregisterAsDefaultItem;\r\nbegin\r\n TJvCustomInspectorData.ItemRegister.Delete(Self);\r\nend;\r\n\r\n//=== { TJvInspectorColorItem } ==============================================\r\n\r\nconstructor TJvInspectorColorItem.Create(const AParent: TJvCustomInspectorItem;\r\n const AData: TJvCustomInspectorData);\r\nbegin\r\n inherited Create(AParent, AData);\r\n FColors := TStringList.Create;\r\n FStdColors := TStringList.Create;\r\n GetColorValues(AddStdColor);\r\n FStdColors.Sort;\r\n IncludeStdColors := True;\r\n Flags := [iifVisible, iifValueList, iifAllowNonListValues, iifOwnerDrawListVariable];\r\nend;\r\n\r\nprocedure TJvInspectorColorItem.AddStdColor(const S: string);\r\nbegin\r\n FStdColors.AddObject(S, TObject(JclStrToTypedInt(S, TypeInfo(TColor))));\r\nend;\r\n\r\nfunction TJvInspectorColorItem.BorderColor(const ABackgroundColor, AInternalColor: TColor): TColor;\r\nvar\r\n BckRGB: TColor;\r\n ColRGB: TColor;\r\n\r\n function IsLightColor(const RGB: TColor): Boolean;\r\n begin\r\n with TColorQuad(RGB) do\r\n Result := (Red > 192) or (Green > 192) or (Blue > 192);\r\n end;\r\n\r\nbegin\r\n BckRGB := ColorToRGB(ABackgroundColor);\r\n ColRGB := ColorToRGB(AInternalColor);\r\n if IsLightColor(BckRGB) and IsLightColor(ColRGB) then\r\n Result := clBlack\r\n else\r\n if not IsLightColor(BckRGB) and not IsLightColor(ColRGB) then\r\n Result := clWhite\r\n else\r\n Result := AInternalColor;\r\nend;\r\n\r\nfunction TJvInspectorColorItem.NameForColor(const Color: TColor): string;\r\nbegin\r\n Result := JclTypedIntToStr(Color, TypeInfo(TColor));\r\nend;\r\n\r\nprocedure TJvInspectorColorItem.PaintValue(const Color: TColor; const ColorName: string;\r\n const ACanvas: TCanvas; const ARect: TRect);\r\nvar\r\n TH: Integer;\r\n BoxRect: TRect;\r\n bc: TColor;\r\n pc: TColor;\r\n txtRect: TRect;\r\nbegin\r\n TH := Rects[iprValue].Bottom - Rects[iprValue].Top - 2;\r\n BoxRect.Left := ARect.Left + (ARect.Bottom - ARect.Top - TH) div 2;\r\n BoxRect.Top := ARect.Top + BoxRect.Left - ARect.Left;\r\n BoxRect.Right := BoxRect.Left + TH;\r\n BoxRect.Bottom := BoxRect.Top + TH;\r\n with ACanvas do\r\n begin\r\n if Color <> clNone then\r\n begin\r\n bc := Brush.Color;\r\n pc := Pen.Color;\r\n try\r\n Brush.Color := Color;\r\n Pen.Color := BorderColor(bc, Color);\r\n Rectangle(BoxRect);\r\n finally\r\n Pen.Color := pc;\r\n Brush.Color := bc;\r\n end;\r\n end;\r\n txtRect := ARect;\r\n txtRect.Left := txtRect.Left + (txtRect.Bottom-txtRect.Top)+ 1;\r\n TextRect(txtRect, txtRect.Left, BoxRect.Top, ColorName);\r\n end;\r\nend;\r\n\r\n\r\nprocedure TJvInspectorColorItem.DoDrawListItem(Control: TWinControl; Index: Integer; Rect: TRect;\r\n State: TOwnerDrawState);\r\n\r\n\r\nbegin\r\n with TListBox(Control) do\r\n begin\r\n if odSelected in State then\r\n Canvas.Brush.Color := clHighlight;\r\n Canvas.FillRect(Rect);\r\n Rect.Top := Rect.Top + 1;\r\n Rect.Bottom := Rect.Bottom - 1;\r\n PaintValue(TColor(Items.Objects[Index]), Items[Index], Canvas, Rect);\r\n end;\r\nend;\r\n\r\nprocedure TJvInspectorColorItem.DoMeasureListItem(Control: TWinControl; Index: Integer;\r\n var Height: Integer);\r\nvar\r\n R: TRect;\r\nbegin\r\n R := Rects[iprValueArea];\r\n Height := R.Bottom - R.Top + 2;\r\nend;\r\n\r\nprocedure TJvInspectorColorItem.DoMeasureListItemWidth(Control: TWinControl; Index: Integer;\r\n var Width: Integer);\r\nvar\r\n R: TRect;\r\nbegin\r\n R := Rects[iprValueArea];\r\n Width := Width + R.Bottom - R.Top + 2;\r\nend;\r\n\r\nfunction TJvInspectorColorItem.GetDisplayValue: string;\r\nvar\r\n TempSL: TStringList;\r\n I: Integer;\r\nbegin\r\n TempSL := TStringList.Create;\r\n try\r\n GetValueList(TempSL);\r\n I := TempSL.IndexOfObject(TObject(Data.AsOrdinal));\r\n if I = -1 then\r\n Result := JclTypedIntToStr(Data.AsOrdinal, TypeInfo(TColor))\r\n else\r\n Result := TempSL[I];\r\n finally\r\n TempSL.Free;\r\n end;\r\nend;\r\n\r\nprocedure TJvInspectorColorItem.GetValueList(const Strings: TStrings);\r\nvar\r\n TempSL: TStringList;\r\nbegin\r\n TempSL := TStringList.Create;\r\n try\r\n if IncludeStdColors then\r\n TempSL.AddStrings(FStdColors);\r\n TempSL.AddStrings(FColors);\r\n DoGetValueList(Strings);\r\n TempSL.AddStrings(Strings);\r\n TempSL.Sort;\r\n Strings.Assign(TempSL);\r\n finally\r\n TempSL.Free;\r\n end;\r\nend;\r\n\r\nprocedure TJvInspectorColorItem.SetDisplayValue(const Value: string);\r\nvar\r\n SL: TStringList;\r\n I: Integer;\r\nbegin\r\n SL := TStringList.Create;\r\n try\r\n GetValueList(SL);\r\n I := SL.IndexOf(Value);\r\n if I > -1 then\r\n I := Integer(SL.Objects[I])\r\n else\r\n I := JclStrToTypedInt(Value, TypeInfo(TColor));\r\n Data.AsOrdinal := I;\r\n finally\r\n SL.Free;\r\n end;\r\nend;\r\n\r\nprocedure TJvInspectorColorItem.SetFlags(const Value: TInspectorItemFlags);\r\nbegin\r\n inherited SetFlags(Value + [iifValueList, iifAllowNonListValues, iifOwnerDrawListFixed] -\r\n [iifOwnerDrawListVariable]);\r\nend;\r\n\r\nprocedure TJvInspectorColorItem.SetRects(const RectKind: TInspectorPaintRect; Value: TRect);\r\nbegin\r\n if RectKind = iprValue then\r\n Value.Left := Value.Left + (Value.Bottom - Value.Top) + 2;\r\n inherited SetRects(RectKind, Value);\r\nend;\r\n\r\nprocedure TJvInspectorColorItem.BeforeDestruction;\r\nbegin\r\n FStdColors.Free;\r\n FColors.Free;\r\n inherited BeforeDestruction;\r\nend;\r\n\r\nprocedure TJvInspectorColorItem.DrawValue(const ACanvas: TCanvas);\r\nvar\r\n Color: TColor;\r\n S: string;\r\n ARect: TRect;\r\n SafeColor: TColor;\r\nbegin\r\n Color := clNone;\r\n if Data = nil then\r\n S := RsJvInspItemUnInitialized\r\n else\r\n try\r\n if not Data.IsInitialized then\r\n S := RsJvInspItemUnInitialized\r\n else\r\n if not Data.HasValue then\r\n S := RsJvInspItemNoValue\r\n else\r\n if not Data.IsAssigned then\r\n S := RsJvInspItemUnassigned\r\n else\r\n begin\r\n S := DisplayValue;\r\n Color := Data.AsOrdinal;\r\n end;\r\n except\r\n S := RsJvInspItemValueException + ExceptObject.ClassName + ': ' +\r\n Exception(ExceptObject).Message;\r\n end;\r\n ARect := Rects[iprValueArea];\r\n SafeColor := ACanvas.Brush.Color;\r\n if Editing then\r\n ACanvas.Brush.Color := clWindow;\r\n try\r\n ACanvas.FillRect(ARect);\r\n PaintValue(Color, S, ACanvas, ARect);\r\n if Editing then\r\n DrawEditor(ACanvas);\r\n finally\r\n if Editing then\r\n ACanvas.Brush.Color := SafeColor;\r\n end;\r\nend;\r\n\r\nclass procedure TJvInspectorColorItem.RegisterAsDefaultItem;\r\nbegin\r\n with TJvCustomInspectorData.ItemRegister do\r\n if IndexOf(Self) = -1 then\r\n Add(TJvInspectorTypeInfoRegItem.Create(Self, TypeInfo(TColor)));\r\nend;\r\n\r\nclass procedure TJvInspectorColorItem.UnregisterAsDefaultItem;\r\nbegin\r\n TJvCustomInspectorData.ItemRegister.Delete(Self);\r\nend;\r\n\r\n//=== { TJvInspectorAnchorsItem } ============================================\r\n\r\nconstructor TJvInspectorAnchorsItem.Create(const AParent: TJvCustomInspectorItem;\r\n const AData: TJvCustomInspectorData);\r\nbegin\r\n inherited Create(AParent, AData);\r\n FUnassignedColor := clGrayText;\r\n FNormalColor := clWindowText;\r\n FActiveColor := clBlue;\r\nend;\r\n\r\nprocedure TJvInspectorAnchorsItem.EditKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);\r\nvar\r\n NewAnchors: TAnchors;\r\n\r\n procedure Toggle(const Side: TAnchorKind);\r\n begin\r\n if Side in NewAnchors then\r\n Exclude(NewAnchors, Side)\r\n else\r\n Include(NewAnchors, Side)\r\n end;\r\n\r\nbegin\r\n if Editing and (Shift = [ssCtrl]) then\r\n begin\r\n if Data.IsAssigned then\r\n Data.GetAsSet(NewAnchors)\r\n else\r\n NewAnchors := [];\r\n case Key of\r\n VK_UP, VK_NUMPAD8:\r\n Toggle(akTop);\r\n VK_RIGHT, VK_NUMPAD6:\r\n Toggle(akRight);\r\n VK_DOWN, VK_NUMPAD2:\r\n Toggle(akBottom);\r\n VK_LEFT, VK_NUMPAD4:\r\n Toggle(akLeft);\r\n VK_NUMPAD5, VK_HOME, VK_NUMPAD7:\r\n begin\r\n if NewAnchors <> [] then\r\n NewAnchors := []\r\n else\r\n NewAnchors := [akLeft, akTop, akRight, akBottom];\r\n end;\r\n end;\r\n case Key of\r\n VK_UP, VK_NUMPAD8, VK_RIGHT, VK_NUMPAD6, VK_DOWN, VK_NUMPAD2, VK_LEFT,\r\n VK_NUMPAD4, VK_NUMPAD5, VK_HOME, VK_NUMPAD7:\r\n begin\r\n Data.SetAsSet(NewAnchors);\r\n Key := 0;\r\n end;\r\n else\r\n inherited EditKeyDown(Sender, Key, Shift);\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvInspectorAnchorsItem.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);\r\nvar\r\n NewAnchors: TAnchors;\r\n OrgAnchors: TAnchors;\r\n R: TRect;\r\n\r\n procedure Toggle(const Side: TAnchorKind);\r\n begin\r\n if Side in NewAnchors then\r\n Exclude(NewAnchors, Side)\r\n else\r\n Include(NewAnchors, Side);\r\n end;\r\n\r\nbegin\r\n if Editing and (Shift = [ssLeft]) then\r\n begin\r\n if Data.IsAssigned then\r\n Data.GetAsSet(NewAnchors)\r\n else\r\n NewAnchors := [];\r\n OrgAnchors := NewAnchors;\r\n R := Rects[iprValueArea];\r\n if PtInRect(Rect(R.Left + 5, R.Top, R.Right - 5, R.Top + 5), Point(X, Y)) then\r\n Toggle(akTop)\r\n else\r\n if PtInRect(Rect(R.Right - 5, R.Top + 5, R.Right, R.Bottom - 5), Point(X, Y)) then\r\n Toggle(akRight)\r\n else\r\n if PtInRect(Rect(R.Left + 5, R.Bottom - 5, R.Right - 5, R.Bottom), Point(X, Y)) then\r\n Toggle(akBottom)\r\n else\r\n if PtInRect(Rect(R.Left, R.Top + 5, R.Left + 5, R.Bottom - 5), Point(X, Y)) then\r\n Toggle(akLeft)\r\n else\r\n if PtInRect(R, Point(X, Y)) then\r\n begin\r\n if NewAnchors <> [] then\r\n NewAnchors := []\r\n else\r\n NewAnchors := [akLeft, akTop, akRight, akBottom];\r\n end;\r\n if OrgAnchors <> NewAnchors then\r\n Data.SetAsSet(NewAnchors);\r\n end;\r\nend;\r\n\r\nprocedure TJvInspectorAnchorsItem.SetFlags(const Value: TInspectorItemFlags);\r\nbegin\r\n inherited SetFlags(Value);\r\nend;\r\n\r\nprocedure TJvInspectorAnchorsItem.SetItemSetFlags(const Value: TInspectorSetFlags);\r\nbegin\r\n inherited SetItemSetFlags(Value - [isfCreateMemberItems] + [isfEditString]);\r\nend;\r\n\r\nprocedure TJvInspectorAnchorsItem.PaintAnchorsBox(const Anchors: TAnchors;\r\n const ACanvas: TCanvas; const ARect: TRect; const UseUnassigned: Boolean);\r\nvar\r\n NoAnchorsColor: TColor;\r\n\r\n procedure RenderAnchors(const Check: TAnchorKind; const X, Y: Integer);\r\n begin\r\n if Check in Anchors then\r\n ACanvas.Pen.Color := ActiveColor\r\n else\r\n ACanvas.Pen.Color := NoAnchorsColor;\r\n ACanvas.LineTo(X, Y);\r\n end;\r\n\r\nbegin\r\n if UseUnassigned then\r\n NoAnchorsColor := UnassignedColor\r\n else\r\n NoAnchorsColor := NormalColor;\r\n ACanvas.Pen.Width := 2;\r\n\r\n ACanvas.MoveTo(ARect.Left + 2, ARect.Top + 2);\r\n RenderAnchors(akTop, ARect.Right - 3, ARect.Top + 2);\r\n RenderAnchors(akRight, ARect.Right - 3, ARect.Bottom - 3);\r\n RenderAnchors(akBottom, ARect.Left + 2, ARect.Bottom - 3);\r\n RenderAnchors(akLeft, ARect.Left + 2, ARect.Top + 1);\r\nend;\r\n\r\nprocedure TJvInspectorAnchorsItem.DoneEdit(const CancelEdits: Boolean = False);\r\nbegin\r\n SetEditing(False);\r\nend;\r\n\r\nprocedure TJvInspectorAnchorsItem.DrawValue(const ACanvas: TCanvas);\r\nvar\r\n IsValid: Boolean;\r\n Anchors: TAnchors;\r\n ARect: TRect;\r\nbegin\r\n IsValid := Data.IsInitialized and Data.IsAssigned and Data.HasValue;\r\n if IsValid then\r\n Data.GetAsSet(Anchors)\r\n else\r\n Anchors := [];\r\n\r\n if Editing and Data.IsAssigned then\r\n ACanvas.Brush.Color := clWindow;\r\n\r\n ARect := Rects[iprValueArea];\r\n ACanvas.FillRect(ARect);\r\n PaintAnchorsBox(Anchors, ACanvas, ARect, not IsValid);\r\nend;\r\n\r\nprocedure TJvInspectorAnchorsItem.InitEdit;\r\nbegin\r\n SetEditing(CanEdit);\r\nend;\r\n\r\nclass procedure TJvInspectorAnchorsItem.RegisterAsDefaultItem;\r\nbegin\r\n with TJvCustomInspectorData.ItemRegister do\r\n if IndexOf(Self) = -1 then\r\n Add(TJvInspectorTypeInfoRegItem.Create(Self, TypeInfo(TAnchors)));\r\nend;\r\n\r\nclass procedure TJvInspectorAnchorsItem.UnregisterAsDefaultItem;\r\nbegin\r\n TJvCustomInspectorData.ItemRegister.Delete(Self);\r\nend;\r\n\r\n//=== { TJvInspectorTImageIndexItem } ========================================\r\n\r\nprocedure TJvInspectorTImageIndexItem.PaintValue(const ImgNum: Integer; const ImgName: string;\r\n const ACanvas: TCanvas; const ARect: TRect);\r\nvar\r\n TH: Integer;\r\n BoxRect: TRect;\r\n Bmp: TBitmap;\r\nbegin\r\n TH := Rects[iprValue].Bottom - Rects[iprValue].Top - 2;\r\n BoxRect.Left := ARect.Left + (ARect.Bottom - ARect.Top - TH) div 2;\r\n BoxRect.Top := ARect.Top + BoxRect.Left - ARect.Left;\r\n BoxRect.Right := BoxRect.Left + TH;\r\n BoxRect.Bottom := BoxRect.Top + TH;\r\n with ACanvas do\r\n begin\r\n if (ImgNum > -1) and (Images <> nil) and (ImgNum < Images.Count) then\r\n begin\r\n Bmp := TBitmap.Create;\r\n try\r\n Images.GetBitmap(ImgNum, Bmp);\r\n StretchDraw(BoxRect, Bmp);\r\n finally\r\n Bmp.Free;\r\n end;\r\n end;\r\n TextOut(ARect.Left + (ARect.Bottom - ARect.Top) + 1, BoxRect.Top, ImgName);\r\n end;\r\nend;\r\n\r\n\r\nprocedure TJvInspectorTImageIndexItem.DoDrawListItem(Control: TWinControl; Index: Integer; Rect: TRect;\r\n State: TOwnerDrawState);\r\n\r\n\r\nbegin\r\n with TListBox(Control) do\r\n begin\r\n if odSelected in State then\r\n Canvas.Brush.Color := clHighlight;\r\n Canvas.FillRect(Rect);\r\n Rect.Top := Rect.Top + 1;\r\n Rect.Bottom := Rect.Bottom - 1;\r\n PaintValue(Integer(Items.Objects[Index]), Items[Index], Canvas, Rect);\r\n end;\r\nend;\r\n\r\nprocedure TJvInspectorTImageIndexItem.DoMeasureListItem(Control: TWinControl; Index: Integer;\r\n var Height: Integer);\r\nvar\r\n R: TRect;\r\nbegin\r\n R := Rects[iprValueArea];\r\n Height := R.Bottom - R.Top + 2;\r\nend;\r\n\r\nprocedure TJvInspectorTImageIndexItem.DoMeasureListItemWidth(Control: TWinControl; Index: Integer;\r\n var Width: Integer);\r\nvar\r\n R: TRect;\r\nbegin\r\n R := Rects[iprValueArea];\r\n Width := Width + R.Bottom - R.Top + 2;\r\nend;\r\n\r\nfunction TJvInspectorTImageIndexItem.GetDisplayValue: string;\r\nbegin\r\n Result := JclTypedIntToStr(Integer(Data.AsOrdinal), Data.TypeInfo);\r\nend;\r\n\r\nprocedure TJvInspectorTImageIndexItem.GetValueList(const Strings: TStrings);\r\nvar\r\n I: Integer;\r\nbegin\r\n Strings.BeginUpdate;\r\n try\r\n Strings.AddObject('-1', TObject(-1000));\r\n for I := 0 to FImageList.Count - 1 do\r\n Strings.AddObject(IntToStr(I), TObject(I));\r\n finally\r\n Strings.EndUpdate;\r\n end;\r\nend;\r\n\r\nprocedure TJvInspectorTImageIndexItem.SetDisplayValue(const Value: string);\r\nvar\r\n TmpOrd: Integer;\r\nbegin\r\n TmpOrd := JclStrToTypedInt(Value, Data.TypeInfo);\r\n if (JclTypeInfo(Data.TypeInfo) as IJclOrdinalRangeTypeInfo).OrdinalType = otULong then\r\n Data.AsOrdinal := Cardinal(TmpOrd)\r\n else\r\n Data.AsOrdinal := TmpOrd;\r\nend;\r\n\r\nprocedure TJvInspectorTImageIndexItem.SetFlags(const Value: TInspectorItemFlags);\r\nbegin\r\n inherited SetFlags(Value + [iifValueList, iifAllowNonListValues, iifOwnerDrawListVariable] -\r\n [iifOwnerDrawListFixed]);\r\nend;\r\n\r\nprocedure TJvInspectorTImageIndexItem.SetRects(const RectKind: TInspectorPaintRect; Value: TRect);\r\nbegin\r\n if RectKind = iprValue then\r\n Value.Left := Value.Left + (Value.Bottom -Value.Top) + 2;\r\n inherited SetRects(RectKind, Value);\r\nend;\r\n\r\nprocedure TJvInspectorTImageIndexItem.DrawValue(const ACanvas: TCanvas);\r\nvar\r\n Idx: Integer;\r\n S: string;\r\n ARect: TRect;\r\n SafeColor: TColor;\r\nbegin\r\n Idx := -1;\r\n if Data = nil then\r\n S := RsJvInspItemUnInitialized\r\n else\r\n try\r\n if not Data.IsInitialized then\r\n S := RsJvInspItemUnInitialized\r\n else\r\n if not Data.HasValue then\r\n S := RsJvInspItemNoValue\r\n else\r\n if not Data.IsAssigned then\r\n S := RsJvInspItemUnassigned\r\n else\r\n begin\r\n S := DisplayValue;\r\n Idx := Data.AsOrdinal;\r\n end;\r\n except\r\n S := RsJvInspItemValueException + ExceptObject.ClassName + ': ' +\r\n Exception(ExceptObject).Message;\r\n end;\r\n ARect := Rects[iprValueArea];\r\n SafeColor := ACanvas.Brush.Color;\r\n if Editing then\r\n ACanvas.Brush.Color := clWindow;\r\n try\r\n ACanvas.FillRect(ARect);\r\n PaintValue(Idx, S, ACanvas, ARect);\r\n if Editing then\r\n DrawEditor(ACanvas);\r\n finally\r\n if Editing then\r\n ACanvas.Brush.Color := SafeColor;\r\n end;\r\nend;\r\n\r\nclass procedure TJvInspectorTImageIndexItem.RegisterAsDefaultItem;\r\nbegin\r\n with TJvCustomInspectorData.ItemRegister do\r\n begin\r\n if IndexOf(Self) = -1 then\r\n Add(TJvInspectorTypeInfoRegItem.Create(Self, TypeInfo(TImageIndex)));\r\n end;\r\nend;\r\n\r\nclass procedure TJvInspectorTImageIndexItem.UnregisterAsDefaultItem;\r\nbegin\r\n TJvCustomInspectorData.ItemRegister.Delete(Self);\r\nend;\r\n\r\ninitialization\r\n {$IFDEF UNITVERSIONING}\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n {$ENDIF UNITVERSIONING}\r\n // Register our Extra TypeInfo helper class for BCB\r\n RegisterTypeInfoHelper(TJvTypeInfoExtraHelper);\r\n\r\n{$IFDEF UNITVERSIONING}\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend." }, { "path": "External/Jedi/Jvcl/run/JvInspXVCL.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Initial Developer of the Original Code is Marcel Bestebroer\r\n .\r\nPortions created by Marcel Bestebroer are Copyright (C) 2000 - 2001 mbeSoft.\r\nAll Rights Reserved.\r\n\r\nContributor(s): Michael Beck [mbeck att bigfoot dott com].\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nDescription:\r\n JvInspector XVCL data layer. Provides access to TJvxNode and descendants.\r\n XVCL can be obtained from the XVCL home page, located at\r\n http://xvcl.sourceforge.net\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvInspXVCL.pas 12461 2009-08-14 17:21:33Z obones $\r\n\r\nunit JvInspXVCL;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n JvInspector, JvxClasses;\r\n\r\ntype\r\n TJvInspectorxNodeData = class(TJvCustomInspectorData)\r\n private\r\n FJvxNode: TJvxNode;\r\n protected\r\n function GetAsFloat: Extended; override;\r\n function GetAsInt64: Int64; override;\r\n function GetAsMethod: TMethod; override;\r\n function GetAsOrdinal: Int64; override;\r\n function GetAsString: string; override;\r\n function GetJvxNode: TJvxNode; virtual;\r\n function IsEqualReference(const Ref: TJvCustomInspectorData): Boolean; override;\r\n procedure NodeNotifyEvent(Sender: TJvxNode; Operation: TJvxNodeOperation); virtual;\r\n procedure SetAsFloat(const Value: Extended); override;\r\n procedure SetAsInt64(const Value: Int64); override;\r\n procedure SetAsMethod(const Value: TMethod); override;\r\n procedure SetAsOrdinal(const Value: Int64); override;\r\n procedure SetAsString(const Value: string); override;\r\n procedure SetJvxNode(Value: TJvxNode); virtual;\r\n public\r\n procedure GetAsSet(var Buf); override;\r\n function HasValue: Boolean; override;\r\n function IsAssigned: Boolean; override;\r\n function IsInitialized: Boolean; override;\r\n class function New(const AParent: TJvCustomInspectorItem; const AName: string; const AJvxNode: TJvxNode): TJvCustomInspectorItem;\r\n procedure SetAsSet(const Buf); override;\r\n property JvxNode: TJvxNode read GetJvxNode write SetJvxNode;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvInspXVCL.pas $';\r\n Revision: '$Revision: 12461 $';\r\n Date: '$Date: 2009-08-14 19:21:33 +0200 (ven. 14 août 2009) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n Consts,\r\n SysUtils, TypInfo,\r\n JvConsts, JvTypes, JvResources;\r\n\r\nfunction TJvInspectorxNodeData.GetAsFloat: Extended;\r\nbegin\r\n CheckReadAccess;\r\n if JvxNode.TypeInfo^.Kind = tkFloat then\r\n Result := JvxNode.AsFloat\r\n else\r\n raise EJvInspectorData.CreateResFmt(@RsEJvInspDataNoAccessAs, [cJvInspectorFloat]);\r\nend;\r\n\r\nfunction TJvInspectorxNodeData.GetAsInt64: Int64;\r\nbegin\r\n CheckReadAccess;\r\n raise EJvInspectorData.CreateResFmt(@RsEJvInspDataNoAccessAs, [cJvInspectorInt64]);\r\nend;\r\n\r\nfunction TJvInspectorxNodeData.GetAsMethod: TMethod;\r\nbegin\r\n CheckReadAccess;\r\n raise EJvInspectorData.CreateResFmt(@RsEJvInspDataNoAccessAs, [cJvInspectorTMethod]);\r\nend;\r\n\r\nfunction TJvInspectorxNodeData.GetAsOrdinal: Int64;\r\nbegin\r\n CheckReadAccess;\r\n if JvxNode.TypeInfo^.Kind in\r\n [tkInteger, tkChar, tkEnumeration, tkSet, tkWChar, tkClass] then\r\n begin\r\n if GetTypeData(JvxNode.TypeInfo).OrdType = otULong then\r\n Result := Cardinal(JvxNode.AsInteger)\r\n else\r\n Result := JvxNode.AsInteger;\r\n end\r\n else\r\n raise EJvInspectorData.CreateResFmt(@RsEJvInspDataNoAccessAs, [cJvInspectorOrdinal]);\r\nend;\r\n\r\nfunction TJvInspectorxNodeData.GetAsString: string;\r\nbegin\r\n CheckReadAccess;\r\n if JvxNode.TypeInfo^.Kind in tkStrings then\r\n Result := JvxNode.AsString\r\n else\r\n raise EJvInspectorData.CreateResFmt(@RsEJvInspDataNoAccessAs, [cJvInspectorString]);\r\nend;\r\n\r\nfunction TJvInspectorxNodeData.GetJvxNode: TJvxNode;\r\nbegin\r\n Result := FJvxNode;\r\nend;\r\n\r\nfunction TJvInspectorxNodeData.IsEqualReference(const Ref: TJvCustomInspectorData): Boolean;\r\nbegin\r\n Result := (Ref is TJvInspectorxNodeData) and (TJvInspectorxNodeData(Ref).JvxNode = JvxNode);\r\nend;\r\n\r\nprocedure TJvInspectorxNodeData.NodeNotifyEvent(Sender: TJvxNode;\r\n Operation: TJvxNodeOperation);\r\nbegin\r\n if (Sender = JvxNode) and (Operation = noChange) then\r\n begin\r\n InvalidateData;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvInspectorxNodeData.SetAsFloat(const Value: Extended);\r\nbegin\r\n CheckWriteAccess;\r\n if JvxNode.TypeInfo^.Kind = tkFloat then\r\n JvxNode.AsFloat := Value\r\n else\r\n raise EJvInspectorData.CreateResFmt(@RsEJvInspDataNoAccessAs, [cJvInspectorFloat]);\r\nend;\r\n\r\nprocedure TJvInspectorxNodeData.SetAsInt64(const Value: Int64);\r\nbegin\r\n CheckWriteAccess;\r\n raise EJvInspectorData.CreateResFmt(@RsEJvInspDataNoAccessAs, [cJvInspectorInt64]);\r\nend;\r\n\r\nprocedure TJvInspectorxNodeData.SetAsMethod(const Value: TMethod);\r\nbegin\r\n CheckWriteAccess;\r\n raise EJvInspectorData.CreateResFmt(@RsEJvInspDataNoAccessAs, [cJvInspectorTMethod]);\r\nend;\r\n\r\nprocedure TJvInspectorxNodeData.SetAsOrdinal(const Value: Int64);\r\nvar\r\n MinValue: Int64;\r\n MaxValue: Int64;\r\nbegin\r\n CheckWriteAccess;\r\n if TypeInfo.Kind in [tkInteger, tkChar, tkEnumeration, tkWChar] then\r\n begin\r\n case GetTypeData(TypeInfo).OrdType of\r\n otSByte:\r\n begin\r\n MinValue := GetTypeData(TypeInfo).MinValue;\r\n MaxValue := GetTypeData(TypeInfo).MaxValue;\r\n if (Value < MinValue) or (Value > MaxValue) then\r\n raise ERangeError.CreateResFmt(@SOutOfRange, [MinValue, MaxValue]);\r\n JvxNode.AsInteger := Shortint(Value)\r\n end;\r\n otUByte:\r\n begin\r\n MinValue := GetTypeData(TypeInfo).MinValue;\r\n MaxValue := GetTypeData(TypeInfo).MaxValue;\r\n if (Value < MinValue) or (Value > MaxValue) then\r\n raise ERangeError.CreateResFmt(@SOutOfRange, [MinValue, MaxValue]);\r\n JvxNode.AsInteger := Byte(Value)\r\n end;\r\n otSWord:\r\n begin\r\n MinValue := GetTypeData(TypeInfo).MinValue;\r\n MaxValue := GetTypeData(TypeInfo).MaxValue;\r\n if (Value < MinValue) or (Value > MaxValue) then\r\n raise ERangeError.CreateResFmt(@SOutOfRange, [MinValue, MaxValue]);\r\n JvxNode.AsInteger := Smallint(Value)\r\n end;\r\n otUWord:\r\n begin\r\n MinValue := GetTypeData(TypeInfo).MinValue;\r\n MaxValue := GetTypeData(TypeInfo).MaxValue;\r\n if (Value < MinValue) or (Value > MaxValue) then\r\n raise ERangeError.CreateResFmt(@SOutOfRange, [MinValue, MaxValue]);\r\n JvxNode.AsInteger := Word(Value)\r\n end;\r\n otSLong:\r\n begin\r\n MinValue := GetTypeData(TypeInfo).MinValue;\r\n MaxValue := GetTypeData(TypeInfo).MaxValue;\r\n if (Value < MinValue) or (Value > MaxValue) then\r\n raise ERangeError.CreateResFmt(@SOutOfRange, [MinValue, MaxValue]);\r\n JvxNode.AsInteger := Integer(Value)\r\n end;\r\n otULong:\r\n begin\r\n MinValue := Longword(GetTypeData(TypeInfo).MinValue);\r\n MaxValue := Longword(GetTypeData(TypeInfo).MaxValue);\r\n if (Value < MinValue) or (Value > MaxValue) then\r\n raise ERangeError.CreateResFmt(@SOutOfRange, [MinValue, MaxValue]);\r\n JvxNode.AsInteger := Integer(Value)\r\n end;\r\n end;\r\n end\r\n else\r\n if TypeInfo.Kind = tkClass then\r\n JvxNode.AsInteger := Integer(Value)\r\n else\r\n raise EJvInspectorData.CreateResFmt(@RsEJvInspDataNoAccessAs, [cJvInspectorOrdinal]);\r\nend;\r\n\r\nprocedure TJvInspectorxNodeData.SetAsString(const Value: string);\r\nbegin\r\n CheckWriteAccess;\r\n if JvxNode.TypeInfo.Kind in tkStrings then\r\n JvxNode.AsString := Value\r\n else\r\n raise EJvInspectorData.CreateResFmt(@RsEJvInspDataNoAccessAs, [cJvInspectorString]);\r\nend;\r\n\r\nprocedure TJvInspectorxNodeData.SetJvxNode(Value: TJvxNode);\r\nbegin\r\n if Value <> JvxNode then\r\n begin\r\n if JvxNode <> nil then\r\n JvxNode.OnNotifyEvents.Remove(NodeNotifyEvent);\r\n FJvxNode := Value;\r\n if JvxNode <> nil then\r\n begin\r\n JvxNode.OnNotifyEvents.Add(NodeNotifyEvent);\r\n TypeInfo := Value.TypeInfo;\r\n end\r\n end;\r\nend;\r\n\r\nprocedure TJvInspectorxNodeData.GetAsSet(var Buf);\r\nvar\r\n CompType: PTypeInfo;\r\n EnumMin: Integer;\r\n EnumMax: Integer;\r\n ResBytes: Integer;\r\n TmpInt: Integer;\r\nbegin\r\n CheckReadAccess;\r\n if JvxNode.TypeInfo.Kind <> tkSet then\r\n raise EJvInspectorData.CreateResFmt(@RsEJvInspDataNoAccessAs, [cJvInspectorSet]);\r\n CompType := GetTypeData(TypeInfo).CompType^;\r\n EnumMin := GetTypeData(CompType).MinValue;\r\n EnumMax := GetTypeData(CompType).MaxValue;\r\n ResBytes := (EnumMax div 8) - (EnumMin div 8) + 1;\r\n if ResBytes > 4 then\r\n ResBytes := 4;\r\n TmpInt := JvxNode.AsInteger;\r\n Move(TmpInt, Buf, ResBytes);\r\nend;\r\n\r\nfunction TJvInspectorxNodeData.HasValue: Boolean;\r\nbegin\r\n Result := IsInitialized and (JvxNode.TypeInfo <> nil);\r\nend;\r\n\r\nfunction TJvInspectorxNodeData.IsAssigned: Boolean;\r\nbegin\r\n Result := IsInitialized and JvxNode.Assigned;\r\nend;\r\n\r\nfunction TJvInspectorxNodeData.IsInitialized: Boolean;\r\nbegin\r\n Result := (JvxNode <> nil);\r\nend;\r\n\r\nclass function TJvInspectorxNodeData.New(const AParent: TJvCustomInspectorItem;\r\n const AName: string; const AJvxNode: TJvxNode): TJvCustomInspectorItem;\r\nvar\r\n Data: TJvInspectorxNodeData;\r\nbegin\r\n if AJvxNode = nil then\r\n raise EJVCLException.CreateRes(@RsENoNodeSpecified);\r\n if AJvxNode.NodeName <> '' then\r\n Data := TJvInspectorxNodeData.CreatePrim(AJvxNode.NodeName, AJvxNode.TypeInfo))\r\n else\r\n Data := TJvInspectorxNodeData.CreatePrim(AName, AJvxNode.TypeInfo));\r\n Data.JvxNode := AJvxNode;\r\n Data := TJvInspectorxNodeData(RegisterInstance(Data));\r\n if Data <> nil then\r\n Result := Data.NewItem(AParent)\r\n else\r\n Result := nil;\r\nend;\r\n\r\nprocedure TJvInspectorxNodeData.SetAsSet(const Buf);\r\nvar\r\n CompType: PTypeInfo;\r\n EnumMin: Integer;\r\n EnumMax: Integer;\r\n ResBytes: Integer;\r\n TmpInt: Integer;\r\nbegin\r\n CheckWriteAccess;\r\n if JvxNode.TypeInfo.Kind <> tkSet then\r\n raise EJvInspectorData.CreateResFmt(@RsEJvInspDataNoAccessAs, [cJvInspectorSet]);\r\n CompType := GetTypeData(TypeInfo).CompType^;\r\n EnumMin := GetTypeData(CompType).MinValue;\r\n EnumMax := GetTypeData(CompType).MaxValue;\r\n ResBytes := (EnumMax div 8) - (EnumMin div 8) + 1;\r\n if ResBytes > 4 then\r\n ResBytes := 4;\r\n TmpInt := 0;\r\n Move(Buf, TmpInt, ResBytes);\r\n JvxNode.AsInteger := TmpInt;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend." }, { "path": "External/Jedi/Jvcl/run/JvInspector.pas", "content": "{-----------------------------------------------------------------------------\r\n\r\n Project JEDI Visible Component Library (J-VCL)\r\n\r\n The contents of this file are subject to the Mozilla Public License Version\r\n 1.1 (the \"License\"); you may not use this file except in compliance with the\r\n License. You may obtain a copy of the License at http://www.mozilla.org/MPL/\r\n\r\n Software distributed under the License is distributed on an \"AS IS\" basis,\r\n WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for\r\n the specific language governing rights and limitations under the License.\r\n\r\n The Initial Developer of the Original Code is Marcel Bestebroer\r\n .\r\n Portions created by Marcel Bestebroer are Copyright (C) 2000 - 2002 mbeSoft.\r\n All Rights Reserved.\r\n\r\n ******************************************************************************\r\n\r\n Object Inspector like control which can inspect not only published\r\n properties, but also variables, string lists (can be parsed as INI files)\r\n anything you can think of (e.g. DataSet based or event based).\r\n\r\n You may retrieve the latest version of this file at the Project JEDI home\r\n page, located at http://www.delphi-jedi.org\r\n\r\n RECENT CHANGES:\r\n May 23, 2004, Markus Spoettl:\r\n - Added DrawNameEndEllipsis property to Painter (1745)\r\n - Fixed list-deactivate bugs (1651) and list drop-down bug 1672\r\n May 3, 2004, Marcel Bestebroer:\r\n - Additional checks for value list location and size.\r\n - Correction list width calculation for non-ownerdrawn value lists.\r\n May 3, 2004, Markus Spoettl:\r\n - Right align value list instead of left align (compatible with both\r\n Borland inspector and VS.NET property grid).\r\n - Fixed width measurement for font name item (used empty font name if\r\n fonts where not displayed in the actual font).\r\n May 2, 2004, Markus Spoettl:\r\n - Added iifOwnerDrawListMaxHeight flag; using this flag will result in\r\n a fixed height owner draw list; the item height used will be that of\r\n the tallest item in the list (i.e. DoMeasureListItem is called on each\r\n item before the list is shown; the largest Height value returned will\r\n be used as the list box's ItemHeight value).\r\n - Font name item will use the new iifOwnerDrawListMaxHeight flag instead\r\n of iifOwnerDrawListVariable.\r\n Apr 30, 2004, Marcel Bestebroer:\r\n - Using the MouseWheel during drop down, will no longer result in the\r\n scrolling of the inspector. Unfortunately, it will also not scroll\r\n the drop down list.\r\n - Mantis 1617: Allow Ctrl+Enter to toggle Expanded state, Ctrl+Left to\r\n collapse and Ctrl+Right to expand.\r\n - Added UseFont property to TJvInspectorFontNameItem. When set to True\r\n the actualy font represented is used to render the font name, \\\r\n otherwise the standard font is used. Note: the property defaults to\r\n False which breaks backwards compatability. This is deliberate, since\r\n the previous mechanism was to slow on slower machines to be usable.\r\n Borland has the same default settings for the Object Inspector.\r\n Apr 28, 2004, Markus Spoettl:\r\n - Added rectangle around check mark boolean items (Mantis #1645).\r\n - Exposed DropDownCount to specify the number of rows in a drop down\r\n list (Mantis #1646).\r\n - Fixed minor issue regarding item heights (Mantis #1647).\r\n - Added default bkTile to TJvCustomInspector.BevelKind property.\r\n Apr 23, 2004, Marcel Bestebroer:\r\n - Added OnItemValueError event, which is fired when an exception occurs\r\n during the Item's Apply method. If no handler is assigned, the\r\n exception will be raised, otherwise the event handler is called.\r\n Apr 16, 2004, Marcel Bestebroer:\r\n - Fixed an issue regarding resizable items or items with non-default\r\n sizes in combination with the .Net painter.\r\n Apr 15, 2004, Marcel Bestebroer:\r\n - Type mapper also mapped all types of the same class to the first\r\n mapping of that class (as in all enums mapped to the first added\r\n enum type mapping, all sets mapped to the first added set type\r\n mapping, etc). Will be changed to allow mapping of descendants of\r\n the specified class instead (or ranges of the integer types?) at a\r\n later date.\r\n Apr 11, 2004, Marcel Bestebroer:\r\n - Index out of range errors and/or AV could show up when closing an\r\n application. This happened mostly in cases where you had a number\r\n of class items with sub items for the properties of that class.\r\n - Corrected OnEnter/OnExit behavior of the inspector (often got fired\r\n when switching from edit control back to inspector or edit control\r\n of next/previous item).\r\n - Added 'hide selection' support. The DotNET painter is currently the\r\n only painter that supports this. When focus is moved out of the\r\n inspector (and not to an inline edit control) the HideSelectColor and\r\n HideSelectTextColor properties are used instead of the SelectedColor\r\n and SelectedTextColor properties.\r\n - .Net painter issue: divider line between two categories were missing\r\n the pixels where the divider between the name and value should have\r\n been.\r\n - Various paint issues when the divider was dragged further left than\r\n where the name started (expand/collapse button drawn over the value,\r\n name selection rectangle partly visible above/below and to the left\r\n of the value and other minor visual side effects).\r\n - Class item editor can now be treated as a category.\r\n Apr 10, 2004, Marcel Bestebroer:\r\n - Double clicking a category item will now expand/collapse regardless\r\n of the position of the mouse (used to work only when clicking left of\r\n the divider bar). See mantis issue 1610.\r\n - Changed the MatchPercentage of the type mapper (changing the weights\r\n of the various parts so that a type info match will always override\r\n a class+name match).\r\n - Removed the mechanism used to save the edited value before the focus\r\n changes or the editor button is clicked; the mechanism used would\r\n change the selected item which is bad. Besides that, the saving can\r\n be accomplished by either calling Apply on the item or use SaveValues\r\n of the inspector.\r\n - Editor events exposed at the inspector are renamed to OnEditorXxxx as\r\n to not interfere (or to be confused) with the standard events\r\n supported by the inspector (the inspector key and mouse events are now\r\n also exposed by TJvInspector).\r\n - Property Name was redeclared in TJvInspectorCustomCategory. It is now\r\n properly overridden (with only a new write acces specifier specified).\r\n Apr 9, 2004, Marcel Bestebroer:\r\n - Any item can now be treated like a category item (not just\r\n TJvInspectorCustomCategoryItem and descendants), using the IsCategory\r\n virtual protected method. As a result the (Get)BaseCategory and\r\n (Get)Category properties/methods will return a TJvCustomInspectorItem\r\n instance.\r\n - Set items main class can now be displayed as a category item; when the\r\n new isfRenderAsCategory flag is specified, the set members are always\r\n created as sub items (i.e. isfCreateMembers is implied to be set).\r\n - AddComponent can now add any object instance (not only TComponent\r\n instances). If not category name is specified, properties are added to\r\n the root (Expanded parameter is ignored in this case).\r\n - Add type mapper for TJvInspectorPropData. The mapper allows to map the\r\n properties actual type to a custom type (e.g. a type generated by\r\n JclGenerateEnumType). Mappings can be based on the class of the\r\n instance, the name of the property and/or the type of the property.\r\n Apr 8, 2004, Marcel Bestebroer:\r\n - trigger the AfterDataCreate event in TJvCustomInspectorData.NewItem.\r\n\r\n Mar 16, 2004, anonymous:\r\n - do not show own class for TControl selection in property.\r\n make sure that you set ComponentIndex to DisplayIndex\r\n\r\n Feb 8, 2004, Olivier Sannier obones att altern dott org\r\n - Introduced the TJvTypeInfoHelper class to help C++ Builder\r\n users to get Type Information\r\n - Corrected heaps of C++ Builder compatibility problems, especially\r\n with parameters that are const pointers\r\n Oct 10, 2003, Andreas Hausladen Andreas dott Hausladen att gmx dott de\r\n - implemented Theming and MouseWheel\r\n Oct 1, 2003, Warren Postma warrenpstma att hotmail dott com\r\n - New Name, UserData properties in TJvInspectorCustomCategoryItem\r\n September 30, Warren Postma warrenpstma att hotmail dott com\r\n - New string property Name, in inspector and category items\r\n (TJvCustomInspectorItem, and descendants, ie TJvInspectorCustomCategoryItem )\r\n holds the variable name or property name or ini file entry name, whereas\r\n the DisplayName is a description for the end-user only. Note that this is\r\n sometimes duplicated by the Item.Data.Name, but sometimes Item.Data is nil,\r\n so this becomes important as a backup.\r\n - System Sound (Beep) on enter key removed.\r\n\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvInspector.pas 13415 2012-09-10 09:51:54Z obones $\r\n\r\nunit JvInspector;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n SysUtils, Classes, Contnrs, TypInfo, IniFiles,\r\n Windows, Messages, Graphics, Controls, StdCtrls, ExtCtrls,\r\n JvExControls, JvAutoComplete, JvJVCLUtils,\r\n JvComponentBase, JvComponent, JvTypes, JvConsts;\r\n\r\nconst\r\n { Inspector Row Size constants }\r\n irsNoReSize = $00000000;\r\n irsNameHeight = $10000000;\r\n irsValueHeight = $20000000;\r\n irsItemHeight = $40000000;\r\n irsValueMask = $0FFFFFFF;\r\n\r\n\r\n\r\ntype\r\n // early declarations\r\n TJvCustomInspector = class;\r\n TJvInspectorPainter = class;\r\n TJvInspectorItemSizing = class;\r\n TJvCustomInspectorItem = class;\r\n TJvInspectorCompoundColumn = class;\r\n TJvInspectorCustomCompoundItem = class;\r\n TJvInspectorCustomCategoryItem = class;\r\n TJvCustomInspectorData = class;\r\n TJvInspectorRegister = class;\r\n TJvCustomInspectorRegItem = class;\r\n TJvInspectorEventData = class;\r\n TJvInspectorPropData = class;\r\n\r\n // For some reason, the hpp generator won't recognize our early\r\n // declarations just yet, so we output them manually.\r\n // In the process, we are careful to enclose them in a namespace\r\n // declaration or we would create two ambiguities for those classes.\r\n // The first one being between TJvCustomInspectorItem and\r\n // Jvinspector::TJvCustomInspectorItem.\r\n // This would puzzle the users quite a bit when they use the header\r\n // and would force them to use an ugly #define to lift the ambiguity.\r\n // And even so, this would trigger other problems.\r\n // So we'd better be careful here.\r\n {$HPPEMIT 'namespace Jvinspector'}\r\n {$HPPEMIT '{'}\r\n {$HPPEMIT 'class TJvCustomInspectorItem;'}\r\n {$HPPEMIT 'class TJvCustomInspectorData;'}\r\n (*$HPPEMIT '}'*)\r\n {$HPPEMIT ''}\r\n\r\n TInspectorItemFlag = (iifReadonly, iifHidden, iifExpanded, iifVisible,\r\n iifQualifiedNames, iifAutoUpdate, iifMultiLine, iifValueList,\r\n iifAllowNonListValues, iifOwnerDrawListFixed, iifOwnerDrawListVariable,\r\n iifEditButton, iifEditFixed, iifOwnerDrawListMaxHeight);\r\n TInspectorItemFlags = set of TInspectorItemFlag;\r\n TInspectorSetFlag = (isfEditString, isfCreateMemberItems, isfRenderAsCategory);\r\n TInspectorSetFlags = set of TInspectorSetFlag;\r\n TInspectorClassFlag = (icfCreateMemberItems, icfShowClassName, icfRenderAsCategory);\r\n TInspectorClassFlags = set of TInspectorClassFlag;\r\n TInspectorComponentFlag = (icfShowOwnerNames, icfNoShowFirstOwnerName, icfSortComponents,\r\n icfSortOwners, icfKeepFirstOwnerAsFirst);\r\n TInspectorComponentFlags = set of TInspectorComponentFlag;\r\n TInspectorCompoundItemFlag = (icifSingleName, icifSingleNameUseFirstCol);\r\n TInspectorCompoundItemFlags = set of TInspectorCompoundItemFlag;\r\n TInspectorTMethodFlag = (imfShowInstanceNames, imfNoShowFirstInstanceName, imfSortMethods,\r\n imfSortInstances, imfKeepFirstInstanceAsFirst);\r\n TInspectorTMethodFlags = set of TInspectorTMethodFlag;\r\n TJvInspectorStyle = (isBorland, isDotNet, isItemPainter);\r\n\r\n TInspectorPaintRect = (iprItem, iprButtonArea, iprBtnSrcRect, iprBtnDstRect,\r\n iprNameArea, iprName, iprValueArea, iprValue, iprEditValue, iprEditButton,\r\n iprUser1, iprUser2, iprUser3, iprUser4, iprUser5, iprUser6);\r\n\r\n TItemRowSizing = type Integer;\r\n\r\n TInspectorItemSortKind = (iskNone, iskName, iskManual, iskCustom);\r\n\r\n TJvInspectorItemClass = class of TJvCustomInspectorItem;\r\n TJvInspectorDataClass = class of TJvCustomInspectorData;\r\n TJvInspectorPainterClass = class of TJvInspectorPainter;\r\n\r\n TJvInspectorItemInstances = array of TJvCustomInspectorItem;\r\n TJvInspectorDataInstances = array of TJvCustomInspectorData;\r\n\r\n // Don't use the const qualifier on events when compiling for BCB\r\n // because this would lead to the generation of a parameter that is\r\n // a non const pointer to a const object.\r\n // Then this would trigger warnings about using non const methods on\r\n // a const object when we modify the properties of the object.\r\n // We would have liked to be able to generate a const pointer to a\r\n // non const object (which is what the Delphi declaration is) but the\r\n // HPP Generator is compeletely flawed in this area\r\n TInspectorItemEvent = procedure(Sender: TObject; Item: TJvCustomInspectorItem) of object;\r\n TInspectorItemBeforeCreateEvent = procedure(Sender: TObject; Data: TJvCustomInspectorData;\r\n var ItemClass: TJvInspectorItemClass) of object;\r\n TInspectorItemBeforeSelectEvent = procedure(Sender: TObject; NewItem: TJvCustomInspectorItem;\r\n var Allow: Boolean) of object;\r\n TInspectorDataEvent = procedure(Sender: TObject; Data: TJvCustomInspectorData) of object;\r\n TInspectorItemGetValueListEvent = procedure(Item: TJvCustomInspectorItem; Values: TStrings) of object;\r\n TInspectorItemSortCompare = function(Item1, Item2: TJvCustomInspectorItem): Integer of object;\r\n TJvInspAsFloat = procedure(Sender: TJvInspectorEventData; var Value: Extended) of object;\r\n TJvInspAsInt64 = procedure(Sender: TJvInspectorEventData; var Value: Int64) of object;\r\n TJvInspAsMethod = procedure(Sender: TJvInspectorEventData; var Value: TMethod) of object;\r\n TJvInspAsString = procedure(Sender: TJvInspectorEventData; var Value: string) of object;\r\n TJvInspAsSet = procedure(Sender: TJvInspectorEventData; var Value; var BufSize: Integer) of object;\r\n TJvInspSupportsMethodPointers = procedure(Sender: TJvInspectorEventData; var SupportsTMethod: Boolean) of object;\r\n TJvInspConfSectionEvent = procedure(var SectionName: string; var Parse: Boolean) of object;\r\n TJvInspConfKeyEvent = procedure(const SectionName: string; var ItemName: string; var ATypeInfo: PTypeInfo;\r\n var Allow: Boolean) of object;\r\n TInspectorValueErrorEvent = procedure(Sender: TObject; Item: TJvCustomInspectorItem;\r\n ExceptObject: Exception) of object;\r\n TInspectorValueChangingEvent = procedure(Sender: TObject; Item: TJvCustomInspectorItem; var NewValue: string; var AllowChange: Boolean) of object;\r\n // new event types (sept 2004) -wp\r\n TInspectorBeforeEditEvent = procedure(Sender: TObject; Item: TJvCustomInspectorItem; Edit: TCustomEdit) of object;\r\n\r\n EJvInspector = class(EJVCLException);\r\n EJvInspectorItem = class(EJvInspector);\r\n EJvInspectorData = class(EJvInspector);\r\n EJvInspectorReg = class(EJvInspector);\r\n\r\n TOnJvInspectorSetItemColors = procedure(Item: TJvCustomInspectorItem; Canvas: TCanvas) of object;\r\n\r\n TOnJvInspectorMouseDown = procedure(Sender: TJvCustomInspector; Item: TJvCustomInspectorItem;\r\n Button: TMouseButton; Shift: TShiftState; X, Y: Integer) of object;\r\n\r\n TOnJvInspectorItemEdit = procedure(Sender: TJvCustomInspector;\r\n Item: TJvCustomInspectorItem; var DisplayStr: string) of object;\r\n\r\n TJvCustomInspectorBase = TJvCustomControl;\r\n\r\n TJvCustomInspector = class(TJvCustomInspectorBase)\r\n private\r\n FAfterDataCreate: TInspectorDataEvent;\r\n FAfterItemCreate: TInspectorItemEvent;\r\n FBandSizing: Boolean;\r\n FBandSizingBand: Integer;\r\n FBandStartsSB: TList;\r\n FBandStartsNoSB: TList;\r\n FBandWidth: Integer;\r\n FBeforeItemCreate: TInspectorItemBeforeCreateEvent;\r\n FBeforeSelection: TInspectorItemBeforeSelectEvent;\r\n FCollapseButton: TBitmap;\r\n FDivider: Integer;\r\n FDraggingDivider: Boolean;\r\n FDividerDragBandX: Integer;\r\n FExpandButton: TBitmap;\r\n FImageHeight: Integer;\r\n FItemHeight: Integer;\r\n FLockCount: Integer;\r\n FNeedRebuild: Boolean;\r\n FNeedRedraw: Boolean;\r\n FSortNotificationList: TList;\r\n FOnDataValueChanged: TInspectorDataEvent;\r\n FOnItemSelected: TNotifyEvent;\r\n FOnItemValueChanged: TInspectorItemEvent;\r\n FPainter: TJvInspectorPainter;\r\n FPaintGen: Integer;\r\n FReadOnly: Boolean;\r\n FRelativeDivider: Boolean;\r\n FRoot: TJvCustomInspectorItem;\r\n FRowSizing: Boolean;\r\n FRowSizingItem: TJvCustomInspectorItem;\r\n FSelectedIndex: Integer;\r\n FSelecting: Boolean;\r\n FTopIndex: Integer;\r\n FUseBands: Boolean;\r\n FVisibleList: TStringList;\r\n FWantTabs: Boolean;\r\n FAutoComplete: Boolean;\r\n FAutoDropDown: Boolean; // depends on AutoComplete\r\n FOnEditorContextPopup: TContextPopupEvent;\r\n FOnEditorKeyDown: TKeyEvent;\r\n FOnEditorKeyPress: TKeyPressEvent;\r\n FOnEditorKeyUp: TKeyEvent;\r\n FOnEditorMouseDown: TOnJvInspectorMouseDown;\r\n FOnItemDoubleClicked: TInspectorItemEvent;\r\n FOnItemEdit: TOnJvInspectorItemEdit; // User clicks Ellipsis button.\r\n FOnItemValueError: TInspectorValueErrorEvent;\r\n FOnItemValueChanging: TInspectorValueChangingEvent;\r\n FInspectObject: TObject;\r\n // BeforeEdit NOTE: - WAP\r\n //\r\n // This event fired is when creating TEdit or TMemo objects, and\r\n // allows end users to customize the properties of the editor\r\n // objects, or hook event handlers, which were\r\n // otherwise invisible. This could be used to ill effect, so beware.\r\n // We already expose some critical events in a nicer way,\r\n // so only use BeforeEdit as a last-resort. Instead consider using:\r\n // BeforeSelection if you want to prevent the editing from ocurring,\r\n // or if you need to handle mouse and keyboard events in the editor\r\n // use one of these:\r\n // OnEditorKeyDown, OnEditorKeyUp,\r\n // OnEditorKeyPress, OnEditorMouseDown,\r\n // OnEditorContextPopup.etc.\r\n // Also, If you want the event that occurs when the user clicks the ellipsis\r\n // button, you want OnItemEdit, not BeforeEdit.\r\n FBeforeEdit: TInspectorBeforeEditEvent;\r\n FStyle: TJvInspectorStyle;\r\n FStylePainter: TJvInspectorPainter;\r\n FSettingStyle: Boolean;\r\n FMouseWheelRecursion: Boolean;\r\n procedure SetInspectObject(const Value: TObject);\r\n procedure SetStyle(const Value: TJvInspectorStyle);\r\n function GetActivePainter: TJvInspectorPainter;\r\n // FOnMouseDown: TInspectorMouseDownEvent;\r\n protected\r\n function CalcImageHeight: Integer; virtual;\r\n function CalcItemIndex(X, Y: Integer; var Rect: TRect): Integer; virtual;\r\n function CalcItemRect(const Item: TJvCustomInspectorItem): TRect; virtual;\r\n procedure CMActivate(var Msg: TCMActivate); message CM_ACTIVATE;\r\n procedure CMDeactivate(var Msg: TCMActivate); message CM_DEACTIVATE;\r\n procedure DoAfterDataCreate(const Data: TJvCustomInspectorData); virtual;\r\n procedure DoAfterItemCreate(const Item: TJvCustomInspectorItem); virtual;\r\n procedure DoBeforeItemCreate(const Data: TJvCustomInspectorData;\r\n var ItemClass: TJvInspectorItemClass); virtual;\r\n function DoBeforeItemSelect(const NewItem: TJvCustomInspectorItem): Boolean; virtual;\r\n procedure DoDataValueChanged(const Data: TJvCustomInspectorData); virtual;\r\n procedure DoItemSelected; virtual;\r\n procedure DoItemValueChanged(const Item: TJvCustomInspectorItem); virtual;\r\n function DoItemValueChanging(const Item: TJvCustomInspectorItem; var NewValue: string): Boolean; virtual;\r\n function DoItemValueError(Item: TJvCustomInspectorItem): Boolean; virtual;\r\n function GetAfterDataCreate: TInspectorDataEvent; virtual;\r\n function GetAfterItemCreate: TInspectorItemEvent; virtual;\r\n function GetBandFor(const ItemIdx: Integer): Integer; virtual;\r\n function GetBandStarts: TList; virtual;\r\n function GetBandWidth: Integer; virtual;\r\n function GetBeforeItemCreate: TInspectorItemBeforeCreateEvent; virtual;\r\n function GetBeforeSelection: TInspectorItemBeforeSelectEvent; virtual;\r\n function GetButtonRect(const ItemIndex: Integer): TRect; virtual;\r\n function GetCollapseButton: TBitmap; virtual;\r\n function GetDivider: Integer; virtual;\r\n function GetDividerAbs: Integer; virtual;\r\n function GetExpandButton: TBitmap; virtual;\r\n function GetImageHeight: Integer; virtual;\r\n function GetItemHeight: Integer; virtual;\r\n function GetLastFullVisible: Integer; virtual;\r\n function GetLockCount: Integer; virtual;\r\n function GetOnItemSelected: TNotifyEvent; virtual;\r\n function GetPainter: TJvInspectorPainter; virtual;\r\n function GetReadOnly: Boolean; virtual;\r\n function GetRelativeDivider: Boolean; virtual;\r\n function GetRoot: TJvCustomInspectorItem; virtual;\r\n function GetSelected: TJvCustomInspectorItem; virtual;\r\n function GetSelectedIndex: Integer; virtual;\r\n function GetTopIndex: Integer; virtual;\r\n function GetUseBands: Boolean; virtual;\r\n function GetVisibleCount: Integer; virtual;\r\n function GetVisibleItems(const I: Integer): TJvCustomInspectorItem; virtual;\r\n function GetWantTabs: Boolean; virtual;\r\n procedure HandleBandResize(X: Integer); virtual;\r\n function IdxToY(const Index: Integer): Integer; virtual;\r\n procedure IncPaintGeneration; virtual;\r\n procedure InvalidateHeight; virtual;\r\n procedure InvalidateItem; virtual;\r\n procedure InvalidateList; virtual;\r\n procedure KeyDown(var Key: Word; Shift: TShiftState); override;\r\n procedure KeyUp(var Key: Word; Shift: TShiftState); override;\r\n procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;\r\n procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;\r\n procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;\r\n procedure Notification(AComponent: TComponent; Operation: TOperation); override;\r\n procedure NotifySort(const Item: TJvCustomInspectorItem); virtual;\r\n procedure Paint; override;\r\n procedure RebuildVisible; virtual;\r\n procedure RemoveNotifySort(const Item: TJvCustomInspectorItem); virtual;\r\n procedure RemoveVisible(const Item: TJvCustomInspectorItem); virtual;\r\n procedure BoundsChanged; override;\r\n function ScrollFactorV: Extended; virtual;\r\n procedure SetAfterDataCreate(const Value: TInspectorDataEvent); virtual;\r\n procedure SetAfterItemCreate(const Value: TInspectorItemEvent); virtual;\r\n procedure SetBandWidth(Value: Integer); virtual;\r\n procedure SetBeforeItemCreate(const Value: TInspectorItemBeforeCreateEvent); virtual;\r\n procedure SetBeforeSelection(const Value: TInspectorItemBeforeSelectEvent); virtual;\r\n procedure SetCollapseButton(const Value: TBitmap); virtual;\r\n procedure SetDivider(Value: Integer); virtual;\r\n procedure SetDividerAbs(Value: Integer); virtual;\r\n procedure SetExpandButton(const Value: TBitmap); virtual;\r\n procedure SetItemHeight(Value: Integer); virtual;\r\n procedure SetLockCount(const Value: Integer); virtual;\r\n procedure SetOnItemSelected(const Value: TNotifyEvent); virtual;\r\n procedure SetPainter(const Value: TJvInspectorPainter); virtual;\r\n procedure SetReadOnly(const Value: Boolean); virtual;\r\n procedure SetRelativeDivider(Value: Boolean); virtual;\r\n procedure SetSelected(const Value: TJvCustomInspectorItem); virtual;\r\n procedure SetSelectedIndex(Value: Integer); virtual;\r\n procedure SetTopIndex(Value: Integer); virtual;\r\n procedure SetUseBands(Value: Boolean); virtual;\r\n procedure SetWantTabs(Value: Boolean); virtual;\r\n procedure UpdateScrollBars; virtual;\r\n function ViewHeight: Integer;\r\n function ViewRect: TRect; virtual;\r\n function ViewWidth: Integer;\r\n procedure WMHScroll(var Msg: TWMScroll); message WM_HSCROLL;\r\n procedure WMVScroll(var Msg: TWMScroll); message WM_VSCROLL;\r\n procedure GetDlgCode(var Code: TDlgCodes); override;\r\n procedure FocusSet(PrevWnd: THandle); override;\r\n procedure FocusKilled(NextWnd: THandle); override;\r\n function DoMouseWheel(Shift: TShiftState; WheelDelta: Integer; MousePos: TPoint): Boolean; override;\r\n procedure ShowScrollBars(Bar: Integer; Visible: Boolean); virtual;\r\n function YToIdx(const Y: Integer): Integer; virtual;\r\n property AutoComplete: Boolean read FAutoComplete write FAutoComplete;\r\n property AutoDropDown: Boolean read FAutoDropDown write FAutoDropDown;\r\n property BandSizing: Boolean read FBandSizing write FBandSizing;\r\n property BandSizingBand: Integer read FBandSizingBand write FBandSizingBand;\r\n property BandStarts: TList read GetBandStarts;\r\n property BandWidth: Integer read GetBandWidth write SetBandWidth;\r\n property CollapseButton: TBitmap read GetCollapseButton write SetCollapseButton;\r\n property ExpandButton: TBitmap read GetExpandButton write SetExpandButton;\r\n property Divider: Integer read GetDivider write SetDivider;\r\n property DividerAbs: Integer read GetDividerAbs write SetDividerAbs;\r\n property DraggingDivider: Boolean read FDraggingDivider write FDraggingDivider;\r\n property DividerDragBandX: Integer read FDividerDragBandX write FDividerDragBandX;\r\n property ItemHeight: Integer read GetItemHeight write SetItemHeight;\r\n property ImageHeight: Integer read GetImageHeight;\r\n property LockCount: Integer read GetLockCount;\r\n property NeedRebuild: Boolean read FNeedRebuild write FNeedRebuild;\r\n property NeedRedraw: Boolean read FNeedRedraw write FNeedRedraw;\r\n property SortNotificationList: TList read FSortNotificationList;\r\n property OnDataValueChanged: TInspectorDataEvent read FOnDataValueChanged write FOnDataValueChanged;\r\n property OnItemSelected: TNotifyEvent read GetOnItemSelected write SetOnItemSelected;\r\n property OnItemValueChanged: TInspectorItemEvent read FOnItemValueChanged write FOnItemValueChanged;\r\n property OnItemValueChanging: TInspectorValueChangingEvent read FOnItemValueChanging write FOnItemValueChanging;\r\n property AfterDataCreate: TInspectorDataEvent read GetAfterDataCreate write SetAfterDataCreate;\r\n property AfterItemCreate: TInspectorItemEvent read GetAfterItemCreate write SetAfterItemCreate;\r\n property BeforeItemCreate: TInspectorItemBeforeCreateEvent read GetBeforeItemCreate write SetBeforeItemCreate;\r\n property BevelKind default bkTile;\r\n property BeforeSelection: TInspectorItemBeforeSelectEvent read GetBeforeSelection write SetBeforeSelection;\r\n property Painter: TJvInspectorPainter read GetPainter write SetPainter;\r\n property PaintGeneration: Integer read FPaintGen;\r\n property ReadOnly: Boolean read GetReadOnly write SetReadOnly;\r\n property RelativeDivider: Boolean read GetRelativeDivider write SetRelativeDivider;\r\n property Root: TJvCustomInspectorItem read GetRoot;\r\n property InspectObject: TObject read FInspectObject write SetInspectObject;\r\n property RowSizing: Boolean read FRowSizing write FRowSizing;\r\n property RowSizingItem: TJvCustomInspectorItem read FRowSizingItem write FRowSizingItem;\r\n property Selected: TJvCustomInspectorItem read GetSelected;\r\n property SelectedIndex: Integer read GetSelectedIndex write SetSelectedIndex;\r\n property Selecting: Boolean read FSelecting write FSelecting;\r\n property Style: TJvInspectorStyle read FStyle write SetStyle default isBorland;\r\n property TopIndex: Integer read GetTopIndex write SetTopIndex;\r\n property UseBands: Boolean read GetUseBands write SetUseBands;\r\n property VisibleCount: Integer read GetVisibleCount;\r\n property VisibleItems[const I: Integer]: TJvCustomInspectorItem read GetVisibleItems;\r\n property WantTabs: Boolean read GetWantTabs write SetWantTabs;\r\n property BeforeEdit: TInspectorBeforeEditEvent read FBeforeEdit write FBeforeEdit;\r\n { Standard TCustomControl events - these are really events fired by\r\n the TEdit control used when editing in a cell!}\r\n property OnEditorContextPopup: TContextPopupEvent read FOnEditorContextPopup write FOnEditorContextPopup;\r\n property OnEditorKeyDown: TKeyEvent read FOnEditorKeyDown write FOnEditorKeyDown;\r\n property OnEditorKeyPress: TKeyPressEvent read FOnEditorKeyPress write FOnEditorKeyPress;\r\n property OnEditorKeyUp: TKeyEvent read FOnEditorKeyUp write FOnEditorKeyUp;\r\n property OnEditorMouseDown: TOnJvInspectorMouseDown read FOnEditorMouseDown write FOnEditorMouseDown;\r\n property OnItemDoubleClicked: TInspectorItemEvent read FOnItemDoubleClicked write FOnItemDoubleClicked;\r\n property OnItemEdit: TOnJvInspectorItemEdit read FOnItemEdit write FOnItemEdit; // User clicks Ellipsis button.\r\n property OnItemValueError: TInspectorValueErrorEvent read FOnItemValueError write FOnItemValueError;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n procedure BeforeDestruction; override;\r\n function BeginUpdate: Integer; virtual;\r\n function EndUpdate: Integer; virtual;\r\n function Focused: Boolean; override;\r\n function FocusedItem: TJvCustomInspectorItem; virtual;\r\n function VisibleIndex(const AItem: TJvCustomInspectorItem): Integer; virtual;\r\n procedure RefreshValues;\r\n procedure SaveValues;\r\n procedure AddComponent(Instance: TObject; const CategoryName: string = ''; Expanded: Boolean = True);\r\n procedure Clear;\r\n property ActivePainter: TJvInspectorPainter read GetActivePainter;\r\n end;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvInspector = class(TJvCustomInspector)\r\n public\r\n property LockCount;\r\n property Root;\r\n property Selected;\r\n property SelectedIndex;\r\n property TopIndex;\r\n property VisibleCount;\r\n property VisibleItems;\r\n property InspectObject;\r\n published\r\n property Style; // Must be BEFORE painter to ensure everithing is read correctly\r\n property Align;\r\n property Anchors;\r\n property AutoComplete default True;\r\n property AutoDropDown default False;\r\n property BandWidth default 150;\r\n property BevelEdges;\r\n property BevelKind;\r\n property BevelInner default bvNone;\r\n property BevelOuter;\r\n property BevelWidth;\r\n property CollapseButton;\r\n // (rom) this is usually handled in an overwritten Loaded\r\n property RelativeDivider default False; // Must be defined before Divider\r\n property Divider default 75;\r\n property ExpandButton;\r\n property Font;\r\n property ItemHeight;\r\n property Painter;\r\n property PopupMenu;\r\n property ReadOnly default False;\r\n property UseBands default False;\r\n property WantTabs default False;\r\n property AfterDataCreate;\r\n property AfterItemCreate;\r\n property BeforeItemCreate;\r\n property BeforeSelection;\r\n property TabStop;\r\n property TabOrder;\r\n property OnDataValueChanged;\r\n property OnItemSelected;\r\n property OnItemValueChanged;\r\n property OnItemValueChanging;\r\n property OnItemValueError;\r\n property OnItemDoubleClicked;\r\n property OnItemEdit; // User clicks Ellipsis button.\r\n property OnContextPopup;\r\n property BeforeEdit; // Low level hook for customizing TEdit/TMemo after objects are created, just before editing.\r\n\r\n // Standard control events\r\n property OnEnter;\r\n property OnExit;\r\n property OnKeyDown;\r\n property OnKeyPress;\r\n property OnKeyUp;\r\n property OnMouseDown;\r\n property OnMouseMove;\r\n property OnMouseUp;\r\n\r\n // Redirected editor events\r\n property OnEditorContextPopup;\r\n property OnEditorKeyDown;\r\n property OnEditorKeyPress;\r\n property OnEditorKeyUp;\r\n property OnEditorMouseDown;\r\n end;\r\n\r\n TJvInspectorPainter = class(TJvComponent)\r\n private\r\n FBackgroundColor: TColor;\r\n FButtonImage: TBitmap;\r\n FCanvas: TCanvas;\r\n FCategoryColor: TColor;\r\n FDividerColor: TColor;\r\n FInitializing: Boolean;\r\n FInspector: TJvCustomInspector;\r\n FInternalCollapseButton: TBitmap;\r\n FInternalExpandButton: TBitmap;\r\n FItem: TJvCustomInspectorItem;\r\n FItemIndex: Integer;\r\n FPaintRect: TRect;\r\n FSelectedColor: TColor;\r\n FDrawNameEndEllipsis: Boolean;\r\n FCategoryFont: TFont;\r\n FValueFont: TFont;\r\n FNameFont: TFont;\r\n FSelectedFont: TFont;\r\n procedure FontChange(Sender: TObject);\r\n\r\n procedure ReadCategoryTextColor(Reader: TReader);\r\n procedure ReadNameColor(Reader: TReader);\r\n procedure ReadValueColor(Reader: TReader);\r\n procedure ReadSelectedTextColor(Reader: TReader);\r\n procedure ReadHideSelectTextColor(Reader: TReader);\r\n protected\r\n procedure ApplyNameFont; virtual;\r\n procedure ApplyValueFont; virtual;\r\n procedure CalcButtonBasedRects; virtual;\r\n procedure CalcEditBasedRects; virtual;\r\n procedure CalcNameBasedRects; virtual;\r\n procedure CalcValueBasedRects; virtual;\r\n function DividerWidth: Integer; virtual;\r\n procedure DoPaint; virtual;\r\n function GetBackgroundColor: TColor; virtual;\r\n function GetCategoryColor: TColor; virtual;\r\n function GetCategoryFont: TFont; virtual;\r\n function GetHideSelectFont: TFont; virtual;\r\n function GetNameFont: TFont; virtual;\r\n function GetSelectedFont: TFont; virtual;\r\n function GetValueFont: TFont; virtual;\r\n function GetCollapseImage: TBitmap; virtual;\r\n function GetDividerColor: TColor; virtual;\r\n function GetExpandImage: TBitmap; virtual;\r\n function GetHideSelectColor: TColor; virtual;\r\n function GetNameHeight(const AItem: TJvCustomInspectorItem): Integer; virtual;\r\n function GetRects(const Index: TInspectorPaintRect): TRect; virtual;\r\n function GetSelectedColor: TColor; virtual;\r\n function GetDrawNameEndEllipsis: Boolean; virtual;\r\n function GetValueHeight(const AItem: TJvCustomInspectorItem): Integer; virtual;\r\n procedure HideEditor; virtual;\r\n procedure InitializeColors; virtual;\r\n function Loading: Boolean;\r\n procedure Paint; virtual;\r\n procedure PaintDivider(const X, YTop, YBottom: Integer); virtual;\r\n procedure PaintItem(var ARect: TRect; const AItemIndex: Integer); overload; virtual;\r\n procedure PaintItem(const AItem: TJvCustomInspectorItem); overload; virtual;\r\n procedure SetBackgroundColor(const Value: TColor); virtual;\r\n procedure SetCategoryColor(const Value: TColor); virtual;\r\n procedure SetCategoryFont(const Value: TFont); virtual;\r\n procedure SetDividerColor(const Value: TColor); virtual;\r\n procedure SetHideSelectColor(const Value: TColor); virtual;\r\n procedure SetHideSelectFont(const Value: TFont); virtual;\r\n procedure SetNameFont(const Value: TFont); virtual;\r\n procedure SetRects(const Index: TInspectorPaintRect; const ARect: TRect); virtual;\r\n procedure SetSelectedColor(const Value: TColor); virtual;\r\n procedure SetSelectedFont(const Value: TFont); virtual;\r\n procedure Setup(const ACanvas: TCanvas); virtual;\r\n procedure SetupItem; virtual;\r\n procedure SetupRects; virtual;\r\n procedure SetValueFont(const Value: TFont); virtual;\r\n procedure SetDrawNameEndEllipsis(Value: Boolean); virtual;\r\n procedure TeardownItem; virtual;\r\n property ButtonImage: TBitmap read FButtonImage write FButtonImage;\r\n property Canvas: TCanvas read FCanvas write FCanvas;\r\n property Initializing: Boolean read FInitializing write FInitializing;\r\n property Inspector: TJvCustomInspector read FInspector;\r\n property InternalCollapseButton: TBitmap read FInternalCollapseButton;\r\n property InternalExpandButton: TBitmap read FInternalExpandButton;\r\n property Item: TJvCustomInspectorItem read FItem write FItem;\r\n property ItemIndex: Integer read FItemIndex write FItemIndex;\r\n property PaintRect: TRect read FPaintRect write FPaintRect;\r\n property Rects[const Index: TInspectorPaintRect]: TRect read GetRects write SetRects;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n procedure DefineProperties(Filer: TFiler); override;\r\n procedure SetInspector(const AInspector: TJvCustomInspector); virtual;\r\n property HideSelectColor: TColor read GetHideSelectColor write SetHideSelectColor;\r\n property HideSelectFont: TFont read GetHideSelectFont write SetHideSelectFont;\r\n property SelectedColor: TColor read GetSelectedColor write SetSelectedColor;\r\n property SelectedFont: TFont read GetSelectedFont write SetSelectedFont;\r\n published\r\n property BackgroundColor: TColor read GetBackgroundColor write SetBackgroundColor;\r\n property CategoryColor: TColor read GetCategoryColor write SetCategoryColor;\r\n property CategoryFont: TFont read GetCategoryFont write SetCategoryFont;\r\n property DividerColor: TColor read GetDividerColor write SetDividerColor;\r\n property NameFont: TFont read GetNameFont write SetNameFont;\r\n property ValueFont: TFont read GetValueFont write SetValueFont;\r\n property DrawNameEndEllipsis: Boolean read GetDrawNameEndEllipsis write SetDrawNameEndEllipsis;\r\n end;\r\n\r\n TJvInspectorBorlandNETBasePainter = class(TJvInspectorPainter)\r\n private\r\n FRealButtonAreaWidth: Integer;\r\n protected\r\n procedure ApplyNameFont; override;\r\n procedure ApplyValueFont; override;\r\n procedure CalcButtonBasedRects; override;\r\n procedure CalcEditBasedRects; override;\r\n procedure CalcNameBasedRects; override;\r\n procedure CalcValueBasedRects; override;\r\n procedure SetupRects; override;\r\n procedure InitializeColors; override;\r\n property RealButtonAreaWidth: Integer read FRealButtonAreaWidth write FRealButtonAreaWidth;\r\n published\r\n property BackgroundColor default clWindow;\r\n property CategoryColor default clBtnFace;\r\n end;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvInspectorBorlandPainter = class(TJvInspectorBorlandNETBasePainter)\r\n private\r\n FDividerLightColor: TColor;\r\n FOnSetItemColors: TOnJvInspectorSetItemColors;\r\n protected\r\n function DividerWidth: Integer; override;\r\n procedure DoPaint; override;\r\n function GetDividerLightColor: TColor; virtual;\r\n function GetSelectedColor: TColor; override;\r\n function GetSelectedFont: TFont; override;\r\n procedure InitializeColors; override;\r\n procedure PaintDivider(const X, YTop, YBottom: Integer); override;\r\n procedure SetDividerLightColor(const Value: TColor); virtual;\r\n procedure Setup(const ACanvas: TCanvas); override;\r\n published\r\n property BackgroundColor default clBtnFace;\r\n property DividerColor default clBtnShadow;\r\n property DividerLightColor: TColor read GetDividerLightColor write SetDividerLightColor default clBtnHighlight;\r\n property OnSetItemColors: TOnJvInspectorSetItemColors read FOnSetItemColors write FOnSetItemColors;\r\n end;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvInspectorDotNETPainter = class(TJvInspectorBorlandNETBasePainter)\r\n private\r\n FHideSelectColor: TColor;\r\n FHideSelectFont: TFont;\r\n FOnSetItemColors: TOnJvInspectorSetItemColors;\r\n protected\r\n procedure ApplyNameFont; override;\r\n function GetHideSelectColor: TColor; override;\r\n function GetHideSelectFont: TFont; override;\r\n procedure DoPaint; override;\r\n procedure InitializeColors; override;\r\n procedure PaintDivider(const X, YTop, YBottom: Integer); override;\r\n procedure SetHideSelectColor(const Value: TColor); override;\r\n procedure SetHideSelectFont(const Value: TFont); override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n published\r\n property DividerColor default clBtnFace;\r\n property HideSelectColor default clBtnFace;\r\n property HideSelectFont;\r\n property SelectedColor default clHighlight;\r\n property SelectedFont;\r\n property OnSetItemColors: TOnJvInspectorSetItemColors read FOnSetItemColors write FOnSetItemColors;\r\n end;\r\n\r\n TJvInspectorItemSizing = class(TPersistent)\r\n private\r\n FMinHeight: TItemRowSizing;\r\n FSizable: Boolean;\r\n FSizingFactor: TItemRowSizing;\r\n protected\r\n Item: TJvCustomInspectorItem;\r\n function GetMinHeight: TItemRowSizing;\r\n function GetSizable: Boolean;\r\n function GetSizingFactor: TItemRowSizing;\r\n procedure SetMinHeight(Value: TItemRowSizing);\r\n procedure SetSizable(Value: Boolean);\r\n procedure SetSizingFactor(Value: TItemRowSizing);\r\n public\r\n constructor Create(const AItem: TJvCustomInspectorItem);\r\n procedure Assign(Source: TPersistent); override;\r\n property MinHeight: TItemRowSizing read GetMinHeight write SetMinHeight;\r\n property Sizable: Boolean read GetSizable write SetSizable;\r\n property SizingFactor: TItemRowSizing read GetSizingFactor write SetSizingFactor;\r\n end;\r\n\r\n TJvCustomInspectorItem = class(TPersistent)\r\n private\r\n FData: TJvCustomInspectorData;\r\n FDisplayIndex: Integer;\r\n FDisplayName: string;\r\n FDroppedDown: Boolean;\r\n FEditCtrlDestroying: Boolean;\r\n FEditCtrl: TCustomEdit;\r\n FEditWndPrc: TWndMethod;\r\n FEditing: Boolean;\r\n FAutoComplete: TJvEditListBoxAutoComplete;\r\n FFlags: TInspectorItemFlags;\r\n FHeight: Integer;\r\n FInspector: TJvCustomInspector;\r\n FItems: TObjectList;\r\n FListBox: TCustomListBox;\r\n FOnCompare: TInspectorItemSortCompare;\r\n FOnGetValueList: TInspectorItemGetValueListEvent;\r\n FOnValueChanged: TNotifyEvent;\r\n FParent: TJvCustomInspectorItem;\r\n FLastPaintGen: Integer;\r\n FPressed: Boolean;\r\n FRects: array [TInspectorPaintRect] of TRect;\r\n FRowSizing: TJvInspectorItemSizing;\r\n FSortKind: TInspectorItemSortKind;\r\n FTracking: Boolean;\r\n FUserData: Pointer;\r\n FDropDownCount: Integer;\r\n FUpdateEditCtrl: Integer; // Used to prevent EditCtrl destruction while in Apply().\r\n FLastEditCtrlText: string;\r\n protected\r\n function GetName: string; virtual; // NEW: Warren added.\r\n procedure AlphaSort;\r\n procedure Apply; virtual;\r\n procedure ApplyDisplayIndices(const ItemList: TList); virtual;\r\n procedure BuildDisplayableList(const ItemList: TList); virtual;\r\n procedure ButtonClick(Sender: TObject); virtual;\r\n function CanEdit: Boolean; virtual;\r\n procedure CloseUp(Accept: Boolean); virtual;\r\n procedure DataSort;\r\n procedure Deactivate; dynamic;\r\n procedure DoAfterItemCreate; virtual;\r\n function DoCompare(const Item: TJvCustomInspectorItem): Integer; virtual;\r\n procedure DoDefaultDrawListItem(ACanvas: TCanvas; Rect: TRect; const AText: string); virtual;\r\n procedure DoDrawListItem(Control: TWinControl; Index: Integer; Rect: TRect;\r\n State: TOwnerDrawState); virtual;\r\n procedure DoDropDownKeys(var Key: Word; Shift: TShiftState); virtual;\r\n procedure DoGetValueList(const Strings: TStrings); virtual;\r\n procedure DoMeasureListItem(Control: TWinControl; Index: Integer;\r\n var Height: Integer); virtual;\r\n procedure DoMeasureListItemWidth(Control: TWinControl; Index: Integer;\r\n var Width: Integer); virtual;\r\n procedure DoValueChanged; virtual;\r\n procedure DropDown; dynamic;\r\n // Defines what to do when the property editor of this inspector item is invoked. Ie, '...' button is clicked on items with iifEdit in their flags.\r\n procedure Edit; virtual;\r\n procedure EditChange(Sender: TObject); virtual;\r\n procedure EditFocusLost(Sender: TObject); dynamic;\r\n procedure EditKillFocus(Sender: TObject);\r\n procedure EditKeyPress(Sender: TObject; var Key: Char); dynamic;\r\n procedure EditKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState); dynamic;\r\n procedure EditKeyUp(Sender: TObject; var Key: Word; Shift: TShiftState); dynamic;\r\n procedure EditMouseDown(Sender: TObject; Button: TMouseButton;\r\n Shift: TShiftState; X, Y: Integer); virtual;\r\n procedure EditMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer); virtual;\r\n procedure EditMouseUp(Sender: TObject; Button: TMouseButton;\r\n Shift: TShiftState; X, Y: Integer); virtual;\r\n procedure Edit_WndProc(var Msg: TMessage); virtual;\r\n procedure AutoCompleteStart(Sender: TObject); dynamic;\r\n function GetAutoUpdate: Boolean; virtual;\r\n function GetBaseCategory: TJvCustomInspectorItem; virtual;\r\n function GetCategory: TJvCustomInspectorItem; virtual;\r\n function GetCount: Integer; virtual;\r\n function GetData: TJvCustomInspectorData; virtual;\r\n function GetDisplayIndex: Integer; virtual;\r\n function GetDisplayName: string; virtual; // NOTE THIS USES DISPLAY NAME PROPERTIES TO BUILD ITS RESULT\r\n function GetFullName: string; // NOTE THIS USES THE INTERNAL NAME properties to build its result.\r\n function GetDisplayParent: TJvCustomInspectorItem; virtual;\r\n function GetDisplayValue: string; virtual;\r\n function GetDroppedDown: Boolean; virtual;\r\n function GetEditCtrl: TCustomEdit; virtual;\r\n function GetEditCtrlDestroying: Boolean; virtual;\r\n function GetEditing: Boolean; virtual;\r\n function GetExpanded: Boolean; virtual;\r\n function GetFlags: TInspectorItemFlags; virtual;\r\n function GetHeight: Integer; virtual;\r\n function GetHeightFactor: Integer; virtual;\r\n function GetHidden: Boolean; virtual;\r\n function GetInspector: TJvCustomInspector; virtual;\r\n function GetInspectorPaintGeneration: Integer;\r\n function GetIsCompoundColumn: Boolean; virtual;\r\n function GetItems(const I: Integer): TJvCustomInspectorItem; virtual;\r\n function GetLevel: Integer; virtual;\r\n function GetListBox: TCustomListBox; virtual;\r\n function GetMultiline: Boolean; virtual;\r\n function GetNextSibling: TJvCustomInspectorItem; virtual;\r\n function GetParent: TJvCustomInspectorItem; virtual;\r\n function GetQualifiedNames: Boolean; virtual;\r\n function GetReadOnly: Boolean; virtual;\r\n function GetRects(const RectKind: TInspectorPaintRect): TRect; virtual;\r\n function GetRowSizing: TJvInspectorItemSizing; virtual;\r\n function GetSortKind: TInspectorItemSortKind; virtual;\r\n function GetSortName: string; virtual;\r\n procedure GetValueList(const Strings: TStrings); virtual;\r\n function GetVisible: Boolean; virtual;\r\n procedure InvalidateItem; virtual;\r\n procedure InvalidateList; virtual;\r\n procedure InvalidateSort; virtual;\r\n procedure InvalidateMetaData; virtual;\r\n procedure InvalidateValue; virtual;\r\n function IsCategory: Boolean; virtual;\r\n procedure ListExit(Sender: TObject); virtual;\r\n {procedure ListMouseUp(Sender: TObject; Button: TMouseButton;\r\n Shift: TShiftState; X, Y: Integer); virtual;}\r\n procedure ListValueSelect(Sender: TObject); virtual;\r\n procedure ListDeactivate(Sender: TObject); virtual;\r\n procedure MouseDown(Button: TMouseButton; Shift: TShiftState;\r\n X, Y: Integer); virtual;\r\n procedure MouseMove(Shift: TShiftState; X, Y: Integer); virtual;\r\n procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); virtual;\r\n procedure NaturalSort;\r\n procedure SelectValue(const Delta: Integer); virtual;\r\n procedure SetAutoUpdate(const Value: Boolean); virtual;\r\n procedure SetDisplayIndex(const Value: Integer); virtual;\r\n procedure SetDisplayIndexValue(const Value: Integer); virtual;\r\n procedure SetDisplayName(Value: string); virtual;\r\n procedure SetDisplayValue(const Value: string); virtual;\r\n procedure SetEditCtrl(const Value: TCustomEdit); virtual;\r\n procedure SetEditing(const Value: Boolean); virtual;\r\n procedure SetExpanded(Value: Boolean); virtual;\r\n procedure SetFlags(const Value: TInspectorItemFlags); virtual;\r\n procedure SetFocus; virtual;\r\n procedure SetHeight(Value: Integer); virtual;\r\n procedure SetHeightFactor(Value: Integer); virtual;\r\n procedure SetHidden(Value: Boolean); virtual;\r\n procedure SetInspector(const AInspector: TJvCustomInspector); virtual;\r\n procedure SetMultiline(const Value: Boolean); virtual;\r\n procedure SetOnCompare(const Value: TInspectorItemSortCompare); virtual;\r\n procedure SetParent(const Value: TJvCustomInspectorItem); virtual;\r\n procedure SetQualifiedNames(const Value: Boolean); virtual;\r\n procedure SetReadOnly(const Value: Boolean); virtual;\r\n procedure SetRects(const RectKind: TInspectorPaintRect; Value: TRect); virtual;\r\n procedure SetRowSizing(Value: TJvInspectorItemSizing); virtual;\r\n procedure SetSortKind(Value: TInspectorItemSortKind); virtual;\r\n procedure SetVisible(Value: Boolean); virtual;\r\n procedure StopTracking; dynamic;\r\n procedure TrackButton(X, Y: Integer); dynamic;\r\n procedure Undo; virtual;\r\n procedure UpdateDisplayOrder(const Item: TJvCustomInspectorItem; const NewIndex: Integer); virtual;\r\n procedure UpdateLastPaintGeneration;\r\n property BaseCategory: TJvCustomInspectorItem read GetBaseCategory;\r\n property Category: TJvCustomInspectorItem read GetCategory;\r\n property DroppedDown: Boolean read GetDroppedDown;\r\n property EditCtrlDestroying: Boolean read GetEditCtrlDestroying;\r\n property EditCtrl: TCustomEdit read GetEditCtrl;\r\n property EditWndPrc: TWndMethod read FEditWndPrc;\r\n property IsCompoundColumn: Boolean read GetIsCompoundColumn;\r\n property LastPaintGeneration: Integer read FLastPaintGen;\r\n property ListBox: TCustomListBox read GetListBox;\r\n //promoted: property OnGetValueList: TInspectorItemGetValueListEvent read FOnGetValueList write FOnGetValueList;\r\n property Pressed: Boolean read FPressed write FPressed;\r\n property Tracking: Boolean read FTracking write FTracking;\r\n public\r\n constructor Create(const AParent: TJvCustomInspectorItem; const AData: TJvCustomInspectorData); virtual;\r\n destructor Destroy; override;\r\n function Add(const Item: TJvCustomInspectorItem): Integer;\r\n procedure BeforeDestruction; override;\r\n procedure Clear;\r\n procedure Delete(const Index: Integer); overload; virtual;\r\n procedure Delete(const Item: TJvCustomInspectorItem); overload; virtual;\r\n procedure Delete(const Data: TJvCustomInspectorData); overload; virtual;\r\n procedure DrawEditor(const ACanvas: TCanvas); virtual;\r\n procedure DrawName(const ACanvas: TCanvas); virtual;\r\n procedure DrawValue(const ACanvas: TCanvas); virtual;\r\n function EditFocused: Boolean; dynamic;\r\n procedure ExpandItems(AExpand: Boolean);\r\n function HasViewableItems: Boolean; virtual;\r\n function IndexOf(const Item: TJvCustomInspectorItem): Integer; overload; virtual;\r\n function IndexOf(const Data: TJvCustomInspectorData): Integer; overload; virtual;\r\n procedure InitEdit; dynamic;\r\n procedure DoneEdit(const CancelEdits: Boolean = False); dynamic;\r\n procedure Insert(const Index: Integer; const Item: TJvCustomInspectorItem);\r\n procedure ScrollInView;\r\n procedure Sort;\r\n function GetEditorText: string;\r\n property AutoUpdate: Boolean read GetAutoUpdate write SetAutoUpdate;\r\n property Count: Integer read GetCount;\r\n property Data: TJvCustomInspectorData read GetData;\r\n property DisplayIndex: Integer read GetDisplayIndex write SetDisplayIndex;\r\n property DisplayName: string read GetDisplayName write SetDisplayName;\r\n property FullName: string read GetFullName;\r\n property DisplayValue: string read GetDisplayValue write SetDisplayValue;\r\n property Editing: Boolean read GetEditing;\r\n property Expanded: Boolean read GetExpanded write SetExpanded;\r\n property Flags: TInspectorItemFlags read GetFlags write SetFlags;\r\n property Hidden: Boolean read GetHidden write SetHidden;\r\n property Height: Integer read GetHeight write SetHeight;\r\n property HeightFactor: Integer read GetHeightFactor write SetHeightFactor;\r\n property Inspector: TJvCustomInspector read GetInspector;\r\n property Items[const I: Integer]: TJvCustomInspectorItem read GetItems; default;\r\n property Level: Integer read GetLevel;\r\n property Multiline: Boolean read GetMultiline write SetMultiline;\r\n property Name: string read GetName;\r\n property Parent: TJvCustomInspectorItem read GetParent;\r\n property QualifiedNames: Boolean read GetQualifiedNames write SetQualifiedNames;\r\n property ReadOnly: Boolean read GetReadOnly write SetReadOnly;\r\n property Rects[const RectKind: TInspectorPaintRect]: TRect read GetRects write SetRects;\r\n property RowSizing: TJvInspectorItemSizing read GetRowSizing write SetRowSizing;\r\n property SortKind: TInspectorItemSortKind read GetSortKind write SetSortKind;\r\n property UserData: Pointer read FUserData write FUserData;\r\n property Visible: Boolean read GetVisible write SetVisible;\r\n property OnCompare: TInspectorItemSortCompare read FOnCompare write SetOnCompare;\r\n property OnValueChanged: TNotifyEvent read FOnValueChanged write FOnValueChanged;\r\n property OnGetValueList: TInspectorItemGetValueListEvent read FOnGetValueList write FOnGetValueList;\r\n property DropDownCount: Integer read FDropDownCount write FDropDownCount;\r\n end;\r\n\r\n TJvInspectorCustomCategoryItem = class(TJvCustomInspectorItem)\r\n private\r\n FName: string;\r\n protected\r\n function GetName: string; override;\r\n function IsCategory: Boolean; override;\r\n procedure SetFlags(const Value: TInspectorItemFlags); override;\r\n public\r\n property Name write FName;\r\n end;\r\n\r\n TJvInspectorCompoundColumn = class(TPersistent)\r\n private\r\n FItem: TJvCustomInspectorItem;\r\n FParent: TJvInspectorCustomCompoundItem;\r\n FWidth: Integer;\r\n FWidthSet: Integer;\r\n protected\r\n function GetItem: TJvCustomInspectorItem;\r\n function GetWidth: Integer;\r\n function GetWidthSet: Integer;\r\n procedure SetItem(Value: TJvCustomInspectorItem);\r\n procedure SetWidth(Value: Integer);\r\n procedure SetWidthExternal(Value: Integer);\r\n procedure SetWidthSet(Value: Integer);\r\n property Parent: TJvInspectorCustomCompoundItem read FParent;\r\n public\r\n constructor Create(const AParent: TJvInspectorCustomCompoundItem; const AItem: TJvCustomInspectorItem);\r\n procedure BeforeDestruction; override;\r\n property Item: TJvCustomInspectorItem read GetItem write SetItem;\r\n property Width: Integer read GetWidth write SetWidthExternal;\r\n property WidthSet: Integer read GetWidthSet;\r\n end;\r\n\r\n TJvInspectorCustomCompoundItem = class(TJvCustomInspectorItem)\r\n private\r\n FCompoundItemFlags: TInspectorCompoundItemFlags;\r\n FColumns: TObjectList;\r\n FSelectedColumnIdx: Integer;\r\n protected\r\n function AddColumnPrim(const Item: TJvCustomInspectorItem): Integer; overload; virtual;\r\n function AddColumnPrim(const ItemIndex: Integer): Integer; overload; virtual;\r\n procedure DeleteColumnPrim(const Column: TJvInspectorCompoundColumn); overload; virtual;\r\n procedure DeleteColumnPrim(const Index: Integer); overload; virtual;\r\n procedure DeleteColumnPrim(const Item: TJvCustomInspectorItem); overload; virtual;\r\n procedure DivideRect(const RectKind: TInspectorPaintRect; const Value: TRect); virtual;\r\n procedure EditKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState); override;\r\n function GetColumnCount: Integer; virtual;\r\n function GetColumns(I: Integer): TJvInspectorCompoundColumn; virtual;\r\n function GetDisplayName: string; override;\r\n function GetEditCtrl: TCustomEdit; override;\r\n function GetEditCtrlDestroying: Boolean; override;\r\n function GetEditing: Boolean; override;\r\n function GetSelectedColumn: TJvInspectorCompoundColumn; virtual;\r\n function GetSelectedColumnIndex: Integer; virtual;\r\n function GetSingleName: Boolean;\r\n function GetSingleNameUseFirstCol: Boolean;\r\n function IndexOfColumnPrim(const Col: TJvInspectorCompoundColumn): Integer; overload; virtual;\r\n function IndexOfColumnPrim(const Item: TJvCustomInspectorItem): Integer; overload; virtual;\r\n procedure InsertColumnPrim(const Index: Integer; const Item: TJvCustomInspectorItem); overload; virtual;\r\n procedure InsertColumnPrim(const Index, ItemIndex: Integer); overload; virtual;\r\n procedure MouseDown(Button: TMouseButton; Shift: TShiftState;\r\n X, Y: Integer); override;\r\n procedure RecalcColumnWidths(const SetColumn: TJvInspectorCompoundColumn = nil); virtual;\r\n procedure SetCompoundItemFlags(Value: TInspectorCompoundItemFlags);\r\n procedure SetDisplayName(Value: string); override;\r\n procedure SetEditing(const Value: Boolean); override;\r\n procedure SetFlags(const Value: TInspectorItemFlags); override;\r\n procedure SetFocus; override;\r\n procedure SetRects(const RectKind: TInspectorPaintRect; Value: TRect); override;\r\n procedure SetSelectedColumn(Value: TJvInspectorCompoundColumn); virtual;\r\n procedure SetSelectedColumnIndex(Value: Integer); virtual;\r\n procedure SetSingleName(Value: Boolean);\r\n procedure SetSingleNameUseFirstCol(Value: Boolean);\r\n property ColumnCount: Integer read GetColumnCount;\r\n property Columns[I: Integer]: TJvInspectorCompoundColumn read GetColumns;\r\n property CompoundItemFlags: TInspectorCompoundItemFlags read FCompoundItemFlags write SetCompoundItemFlags;\r\n property SelectedColumn: TJvInspectorCompoundColumn read GetSelectedColumn write SetSelectedColumn;\r\n property SelectedColumnIndex: Integer read GetSelectedColumnIndex write SetSelectedColumnIndex;\r\n property SingleName: Boolean read GetSingleName write SetSingleName;\r\n property SingleNameUseFirstCol: Boolean read GetSingleNameUseFirstCol write SetSingleNameUseFirstCol;\r\n public\r\n constructor Create(const AParent: TJvCustomInspectorItem; const AData: TJvCustomInspectorData); override;\r\n procedure BeforeDestruction; override;\r\n procedure DoneEdit(const CancelEdits: Boolean = False); override;\r\n procedure DrawEditor(const ACanvas: TCanvas); override;\r\n procedure DrawName(const ACanvas: TCanvas); override;\r\n procedure DrawValue(const ACanvas: TCanvas); override;\r\n function EditFocused: Boolean; override;\r\n procedure InitEdit; override;\r\n end;\r\n\r\n TJvInspectorCompoundItem = class(TJvInspectorCustomCompoundItem)\r\n public\r\n function AddColumn(const Item: TJvCustomInspectorItem): Integer; overload;\r\n function AddColumn(const ItemIndex: Integer): Integer; overload;\r\n procedure DeleteColumn(const Column: TJvInspectorCompoundColumn); overload;\r\n procedure DeleteColumn(const Index: Integer); overload;\r\n procedure DeleteColumn(const Item: TJvCustomInspectorItem); overload;\r\n function IndexOfColumn(const Col: TJvInspectorCompoundColumn): Integer; overload;\r\n function IndexOfColumn(const Item: TJvCustomInspectorItem): Integer; overload;\r\n procedure InsertColumn(const Index: Integer; const Item: TJvCustomInspectorItem); overload;\r\n procedure InsertColumn(const Index, ItemIndex: Integer); overload;\r\n property ColumnCount;\r\n property Columns;\r\n property CompoundItemFlags;\r\n property SelectedColumn;\r\n property SelectedColumnIndex;\r\n property SingleName;\r\n property SingleNameUseFirstCol;\r\n end;\r\n\r\n TJvInspectorIntegerItem = class(TJvCustomInspectorItem)\r\n protected\r\n function GetDisplayValue: string; override;\r\n procedure SetDisplayValue(const Value: string); override;\r\n end;\r\n\r\n TJvInspectorEnumItem = class(TJvCustomInspectorItem)\r\n protected\r\n function GetDisplayValue: string; override;\r\n procedure GetValueList(const Strings: TStrings); override;\r\n procedure SetDisplayValue(const Value: string); override;\r\n procedure SetFlags(const Value: TInspectorItemFlags); override;\r\n end;\r\n\r\n TJvInspectorFloatItem = class(TJvCustomInspectorItem)\r\n protected\r\n FFormat: string;\r\n function GetDisplayValue: string; override;\r\n procedure SetDisplayValue(const Value: string); override;\r\n public\r\n constructor Create(const AParent: TJvCustomInspectorItem;\r\n const AData: TJvCustomInspectorData); override;\r\n published\r\n property Format: string read FFormat write FFormat;\r\n end;\r\n\r\n TJvInspectorSetItem = class(TJvCustomInspectorItem)\r\n private\r\n FItemSetFlags: TInspectorSetFlags;\r\n protected\r\n function CanEdit: Boolean; override;\r\n procedure CreateMembers; virtual;\r\n procedure DeleteMembers; virtual;\r\n function GetCreateMemberItems: Boolean; virtual;\r\n function GetDisplayValue: string; override;\r\n function GetEditString: Boolean; virtual;\r\n function GetRenderAsCategory: Boolean; virtual;\r\n function GetItemSetFlags: TInspectorSetFlags; virtual;\r\n procedure InvalidateMetaData; override;\r\n function IsCategory: Boolean; override;\r\n procedure SetCreateMemberItems(const Value: Boolean); virtual;\r\n procedure SetDisplayValue(const Value: string); override;\r\n procedure SetEditString(const Value: Boolean); virtual;\r\n procedure SetRenderAsCategory(const Value: Boolean); virtual;\r\n procedure SetFlags(const Value: TInspectorItemFlags); override;\r\n procedure SetItemSetFlags(const Value: TInspectorSetFlags); virtual;\r\n public\r\n constructor Create(const AParent: TJvCustomInspectorItem;\r\n const AData: TJvCustomInspectorData); override;\r\n published\r\n property ItemSetFlags: TInspectorSetFlags read GetItemSetFlags\r\n write SetItemSetFlags;\r\n property CreateMemberItems: Boolean read GetCreateMemberItems\r\n write SetCreateMemberItems;\r\n property EditString: Boolean read GetEditString write SetEditString;\r\n property RenderAsCategory: Boolean read GetRenderAsCategory write SetRenderAsCategory;\r\n end;\r\n\r\n TJvInspectorCharItem = class(TJvCustomInspectorItem)\r\n protected\r\n function GetDisplayValue: string; override;\r\n procedure SetDisplayValue(const Value: string); override;\r\n end;\r\n\r\n TJvInspectorInt64Item = class(TJvCustomInspectorItem)\r\n protected\r\n function GetDisplayValue: string; override;\r\n procedure SetDisplayValue(const Value: string); override;\r\n end;\r\n\r\n TJvInspectorStringItem = class(TJvCustomInspectorItem)\r\n protected\r\n function GetDisplayValue: string; override;\r\n procedure SetDisplayValue(const Value: string); override;\r\n end;\r\n\r\n TJvInspectorClassItem = class(TJvCustomInspectorItem)\r\n private\r\n FItemClassFlags: TInspectorClassFlags;\r\n FLastMemberInstance: TObject;\r\n protected\r\n procedure CreateMembers; virtual;\r\n function CanEdit: Boolean; override;\r\n procedure DeleteMembers; virtual;\r\n function GetCreateMemberItems: Boolean; virtual;\r\n function GetDisplayValue: string; override;\r\n function GetItemClassFlags: TInspectorClassFlags; virtual;\r\n function GetRenderAsCategory: Boolean; virtual;\r\n function GetShowClassName: Boolean; virtual;\r\n procedure InvalidateItem; override;\r\n procedure InvalidateMetaData; override;\r\n function IsCategory: Boolean; override;\r\n procedure SetCreateMemberItems(const Value: Boolean); virtual;\r\n procedure SetDisplayValue(const Value: string); override;\r\n procedure SetItemClassFlags(Value: TInspectorClassFlags); virtual;\r\n procedure SetRenderAsCategory(const Value: Boolean); virtual;\r\n procedure SetShowClassName(const Value: Boolean); virtual;\r\n public\r\n constructor Create(const AParent: TJvCustomInspectorItem;\r\n const AData: TJvCustomInspectorData); override;\r\n property CreateMemberItems: Boolean read GetCreateMemberItems write SetCreateMemberItems;\r\n property ItemClassFlags: TInspectorClassFlags read GetItemClassFlags write SetItemClassFlags;\r\n property OnGetValueList;\r\n property RenderAsCategory: Boolean read GetRenderAsCategory write SetRenderAsCategory;\r\n property ShowClassName: Boolean read GetShowClassName write SetShowClassName;\r\n end;\r\n\r\n TJvInspectorComponentItem = class(TJvInspectorClassItem)\r\n private\r\n FItemComponentFlags: TInspectorComponentFlags;\r\n FOwners: TList;\r\n protected\r\n function GetItemComponentFlags: TInspectorComponentFlags;\r\n function GetKeepFirstOwnerAsFirst: Boolean;\r\n function GetNoShowFirstOwnerName: Boolean;\r\n function GetOwnerCount: Integer;\r\n function GetOwners(I: Integer): TComponent;\r\n function GetShowOwnerNames: Boolean;\r\n function GetSortComponents: Boolean;\r\n function GetSortOwners: Boolean;\r\n procedure GetValueList(const Strings: TStrings); override;\r\n procedure SetFlags(const Value: TInspectorItemFlags); override;\r\n procedure SetItemClassFlags(Value: TInspectorClassFlags); override;\r\n procedure SetItemComponentFlags(Value: TInspectorComponentFlags); virtual;\r\n procedure SetKeepFirstOwnerAsFirst(Value: Boolean);\r\n procedure SetNoShowFirstOwnerName(Value: Boolean);\r\n procedure SetOwners(I: Integer; Value: TComponent);\r\n procedure SetShowOwnerNames(Value: Boolean);\r\n procedure SetSortComponents(Value: Boolean);\r\n procedure SetSortOwners(Value: Boolean);\r\n public\r\n constructor Create(const AParent: TJvCustomInspectorItem;\r\n const AData: TJvCustomInspectorData); override;\r\n procedure BeforeDestruction; override;\r\n procedure AddOwner(const AOwner: TComponent);\r\n procedure DeleteOwner(const AOwner: TComponent); overload;\r\n procedure DeleteOwner(const Index: Integer); overload;\r\n property ItemComponentFlags: TInspectorComponentFlags read GetItemComponentFlags write SetItemComponentFlags;\r\n property KeepFirstOwnerAsFirst: Boolean read GetKeepFirstOwnerAsFirst write SetKeepFirstOwnerAsFirst;\r\n property NoShowFirstOwnerName: Boolean read GetNoShowFirstOwnerName write SetNoShowFirstOwnerName;\r\n property OwnerCount: Integer read GetOwnerCount;\r\n property Owners[I: Integer]: TComponent read GetOwners write SetOwners;\r\n property ShowOwnerNames: Boolean read GetShowOwnerNames write SetShowOwnerNames;\r\n property SortComponents: Boolean read GetSortComponents write SetSortComponents;\r\n property SortOwners: Boolean read GetSortOwners write SetSortOwners;\r\n end;\r\n\r\n TJvInspectorFontItem = class(TJvInspectorClassItem)\r\n protected\r\n procedure Edit; override;\r\n procedure SetFlags(const Value: TInspectorItemFlags); override;\r\n end;\r\n\r\n TJvInspectorFontNameItem = class(TJvInspectorStringItem)\r\n private\r\n FUseFont: Boolean;\r\n protected\r\n function GetUseFont: Boolean;\r\n procedure SetUseFont(Value: Boolean);\r\n procedure DoDrawListItem(Control: TWinControl; Index: Integer; Rect: TRect;\r\n State: TOwnerDrawState); override;\r\n procedure DoMeasureListItem(Control: TWinControl; Index: Integer;\r\n var Height: Integer); override;\r\n procedure DoMeasureListItemWidth(Control: TWinControl; Index: Integer;\r\n var Width: Integer); override;\r\n procedure GetValueList(const Strings: TStrings); override;\r\n procedure SetFlags(const Value: TInspectorItemFlags); override;\r\n public\r\n property UseFont: Boolean read GetUseFont write SetUseFont;\r\n end;\r\n\r\n TJvInspectorBooleanItem = class(TJvInspectorEnumItem)\r\n private\r\n FCheckRect: TRect;\r\n FShowAsCheckBox: Boolean;\r\n protected\r\n function GetShowAsCheckBox: Boolean; virtual;\r\n procedure EditKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState); override;\r\n procedure MouseDown(Button: TMouseButton; Shift: TShiftState;\r\n X, Y: Integer); override;\r\n procedure SetShowAsCheckBox(Value: Boolean); virtual;\r\n public\r\n procedure DoneEdit(const CancelEdits: Boolean = False); override;\r\n procedure DrawValue(const ACanvas: TCanvas); override;\r\n procedure InitEdit; override;\r\n property ShowAsCheckBox: Boolean read GetShowAsCheckBox write SetShowAsCheckBox;\r\n end;\r\n\r\n TJvInspectorDateItem = class(TJvInspectorFloatItem)\r\n protected\r\n function GetDisplayValue: string; override;\r\n procedure SetDisplayValue(const Value: string); override;\r\n procedure SetFormat(const Value: string);\r\n public\r\n constructor Create(const AParent: TJvCustomInspectorItem;\r\n const AData: TJvCustomInspectorData); override;\r\n published\r\n property Format: string read FFormat write SetFormat;\r\n end;\r\n\r\n TJvInspectorTimeItem = class(TJvInspectorFloatItem)\r\n private\r\n FShowAMPM: Boolean;\r\n FShowSeconds: Boolean;\r\n protected\r\n function GetDisplayValue: string; override;\r\n procedure SetDisplayValue(const Value: string); override;\r\n procedure SetFormat;\r\n procedure SetShowAMPM(Value: Boolean);\r\n procedure SetShowSeconds(Value: Boolean);\r\n property Format: string read FFormat;\r\n public\r\n constructor Create(const AParent: TJvCustomInspectorItem;\r\n const AData: TJvCustomInspectorData); override;\r\n published\r\n property ShowAMPM: Boolean read FShowAMPM write SetShowAMPM;\r\n property ShowSeconds: Boolean read FShowSeconds write SetShowSeconds;\r\n end;\r\n\r\n TJvInspectorDateTimeItem = class(TJvInspectorCustomCompoundItem)\r\n private\r\n FDate: TJvInspectorDateItem;\r\n FTime: TJvInspectorTimeItem;\r\n protected\r\n function GetDateFormat: string;\r\n function GetTimeShowAMPM: Boolean;\r\n function GetTimeShowSeconds: Boolean;\r\n procedure SetDateFormat(const Value: string);\r\n procedure SetTimeShowAMPM(Value: Boolean);\r\n procedure SetTimeShowSeconds(Value: Boolean);\r\n public\r\n constructor Create(const AParent: TJvCustomInspectorItem;\r\n const AData: TJvCustomInspectorData); override;\r\n published\r\n property DateFormat: string read GetDateFormat write SetDateFormat;\r\n property TimeShowAMPM: Boolean read GetTimeShowAMPM write SetTimeShowAMPM;\r\n property TimeShowSeconds: Boolean read GetTimeShowSeconds write SetTimeShowSeconds;\r\n end;\r\n\r\n TJvInspectorTStringsItem = class(TJvCustomInspectorItem)\r\n protected\r\n procedure ContentsChanged(Sender: TObject);\r\n function GetDisplayValue: string; override;\r\n procedure Edit; override;\r\n procedure SetDisplayValue(const Value: string); override;\r\n procedure SetFlags(const Value: TInspectorItemFlags); override;\r\n public\r\n constructor Create(const AParent: TJvCustomInspectorItem;\r\n const AData: TJvCustomInspectorData); override;\r\n end;\r\n\r\n TJvInspectorTMethodItem = class(TJvCustomInspectorItem)\r\n private\r\n FList: TStrings; // list of object instances with list of methods attached.\r\n FItemTMethodFlags: TInspectorTMethodFlags;\r\n protected\r\n function GetInstanceCount: Integer;\r\n function GetInstances(I: Integer): TObject;\r\n function GetInstanceNames(I: Integer): string;\r\n function GetItemTMethodFlags: TInspectorTMethodFlags;\r\n function GetKeepFirstInstanceAsFirst: Boolean;\r\n function GetMethodCount(Instance: TObject): Integer;\r\n function GetMethods(Instance: TObject; I: Integer): TMethod;\r\n function GetMethodNames(Instance: TObject; I: Integer): string;\r\n function GetNoShowFirstInstanceName: Boolean;\r\n function GetShowInstanceNames: Boolean;\r\n function GetSortMethods: Boolean;\r\n function GetSortInstances: Boolean;\r\n procedure SetItemTMethodFlags(Value: TInspectorTMethodFlags);\r\n procedure SetKeepFirstInstanceAsFirst(Value: Boolean);\r\n procedure SetNoShowFirstInstanceName(Value: Boolean);\r\n procedure SetShowInstanceNames(Value: Boolean);\r\n procedure SetSortMethods(Value: Boolean);\r\n procedure SetSortInstances(Value: Boolean);\r\n procedure AddInstancePrim(const Instance: TObject; const InstanceName: string); virtual;\r\n procedure AddMethodPrim(const Instance: TObject; const MethodAddr: Pointer; const MethodName: string); virtual;\r\n function MethodFromName(const Name: string): TMethod;\r\n function MethodFromAbsIndex(const Idx: Integer): TMethod;\r\n function NameFromMethod(const Method: TMethod): string;\r\n function AbsIndexFromMethod(const Method: TMethod): Integer;\r\n function GetDisplayValue: string; override;\r\n procedure GetValueList(const Strings: TStrings); override;\r\n procedure SetDisplayValue(const Value: string); override;\r\n procedure SetFlags(const Value: TInspectorItemFlags); override;\r\n public\r\n constructor Create(const AParent: TJvCustomInspectorItem;\r\n const AData: TJvCustomInspectorData); override;\r\n procedure BeforeDestruction; override;\r\n procedure AddInstance(const Instance: TObject; const InstanceName: string);\r\n procedure AddMethod(const Method: TMethod; const MethodName: string); overload;\r\n procedure AddMethod(const Instance: TObject; MethodAddr: Pointer; const MethodName: string); overload;\r\n procedure DeleteInstance(const Index: Integer); overload;\r\n procedure DeleteInstance(const Instance: TObject); overload;\r\n procedure DeleteInstance(const InstanceName: string); overload;\r\n procedure DeleteMethod(const Method: TMethod); overload;\r\n procedure DeleteMethod(const InstanceIndex: Integer; const Index: Integer); overload;\r\n procedure DeleteMethod(const Instance: TObject; const Index: Integer); overload;\r\n procedure DeleteMethod(const InstanceName: string; const Index: Integer); overload;\r\n procedure DeleteMethod(const InstanceIndex: Integer; const MethodName: string); overload;\r\n procedure DeleteMethod(const Instance: TObject; const MethodName: string); overload;\r\n procedure DeleteMethod(const InstanceName: string; const MethodName: string); overload;\r\n procedure ClearInstances;\r\n procedure ClearMethods(const InstanceIndex: Integer); overload;\r\n procedure ClearMethods(const Instance: TObject); overload;\r\n procedure ClearMethods(const InstanceName: string); overload;\r\n function IndexOfInstance(const Instance: TObject): Integer; overload;\r\n function IndexOfInstance(const InstanceName: string): Integer; overload;\r\n function IndexOfMethod(const Method: TMethod): Integer; overload;\r\n function IndexOfMethod(const InstanceIndex: Integer; const MethodName: string): Integer; overload;\r\n function IndexOfMethod(const Instance: TObject; const MethodName: string): Integer; overload;\r\n function IndexOfMethod(const InstanceName: string; const MethodName: string): Integer; overload;\r\n property InstanceCount: Integer read GetInstanceCount;\r\n property Instances[I: Integer]: TObject read GetInstances;\r\n property InstanceNames[I: Integer]: string read GetInstanceNames;\r\n property ItemTMethodFlags: TInspectorTMethodFlags read GetItemTMethodFlags write SetItemTMethodFlags;\r\n property KeepFirstInstanceAsFirst: Boolean read GetKeepFirstInstanceAsFirst write SetKeepFirstInstanceAsFirst;\r\n property MethodCount[Instance: TObject]: Integer read GetMethodCount;\r\n property Methods[Instance: TObject; I: Integer]: TMethod read GetMethods;\r\n property MethodNames[Instance: TObject; I: Integer]: string read GetMethodNames;\r\n property NoShowFirstInstanceName: Boolean read GetNoShowFirstInstanceName write SetNoShowFirstInstanceName;\r\n property ShowInstanceNames: Boolean read GetShowInstanceNames write SetShowInstanceNames;\r\n property SortInstances: Boolean read GetSortInstances write SetSortInstances;\r\n property SortMethods: Boolean read GetSortMethods write SetSortMethods;\r\n end;\r\n\r\n TJvInspectorVariantItem = class(TJvCustomInspectorItem)\r\n protected\r\n function GetDisplayValue: string; override;\r\n procedure SetDisplayValue(const Value: string); override;\r\n end;\r\n\r\n TJvCustomInspectorData = class(TPersistent)\r\n private\r\n FTypeInfo: PTypeInfo;\r\n FItems: TJvInspectorItemInstances;\r\n FName: string;\r\n FRegistered: Boolean;\r\n FOnValueChanged: TNotifyEvent;\r\n protected\r\n // Remove the const qualifier when compiling with BCB. This is quite\r\n // similar to the problem aforementioned with events but is more\r\n // serious as it prevents the program from linking:\r\n // With the const qualifier, the ATypeInfo parameter gets exported\r\n // by the linker as a constant pointer to a non constant object\r\n // (TTypeInfo const *) whereas the HPP generator declares the parameter\r\n // as a non constant pointer to a constant object (const TTypeInfo *).\r\n // This leads to the linker not finding the code for the method\r\n // because the const qualifier is misplaced.\r\n // The linker is correct in its work because it reflects exactly what\r\n // the Delphi construct means, but once again the HPP generator is\r\n // wrong and there is no way to go around this problem but to remove\r\n // the const qualifier for the parameter in the Delphi source code.\r\n // The problem arises only when the type of the parameter is a Pointer\r\n // in Delphi. For instance, a constant parameter of type TForm would\r\n // be output as 'const TForm*' by both the Linker and HPP generator,\r\n // thus not triggering any error, even if this doesn't respect the\r\n // meaning of the Delphi construct which is 'TForm const *'\r\n constructor CreatePrim(const AName: string; ATypeInfo: PTypeInfo);\r\n procedure CheckReadAccess; virtual;\r\n procedure CheckWriteAccess; virtual;\r\n procedure DoDataChanged;\r\n procedure DoneEdits(const CancelEdits: Boolean = False);\r\n function GetAsFloat: Extended; virtual; abstract;\r\n function GetAsInt64: Int64; virtual; abstract;\r\n function GetAsMethod: TMethod; virtual; abstract;\r\n function GetAsOrdinal: Int64; virtual; abstract;\r\n function GetAsString: string; virtual; abstract;\r\n function GetAsVariant: Variant; virtual; abstract;\r\n function GetItemCount: Integer;\r\n function GetItems(I: Integer): TJvCustomInspectorItem;\r\n function GetName: string; virtual;\r\n function GetTypeInfo: PTypeInfo; virtual;\r\n procedure InitEdits;\r\n procedure Invalidate; virtual;\r\n procedure InvalidateData; virtual;\r\n function IsEqualReference(const Ref: TJvCustomInspectorData): Boolean; virtual;\r\n procedure NotifyRemoveData(const Instance: TJvCustomInspectorData); virtual;\r\n procedure RefreshEdits;\r\n class function RegisterInstance(const Instance: TJvCustomInspectorData): TJvCustomInspectorData;\r\n procedure RemoveItem(const Item: TJvCustomInspectorItem);\r\n procedure SetAsFloat(const Value: Extended); virtual; abstract;\r\n procedure SetAsInt64(const Value: Int64); virtual; abstract;\r\n procedure SetAsMethod(const Value: TMethod); virtual; abstract;\r\n procedure SetAsOrdinal(const Value: Int64); virtual; abstract;\r\n procedure SetAsString(const Value: string); virtual; abstract;\r\n procedure SetAsVariant(const Value: Variant); virtual; abstract;\r\n procedure SetName(const Value: string); virtual;\r\n procedure SetTypeInfo(Value: PTypeInfo); virtual;\r\n function SupportsMethodPointers: Boolean; virtual;\r\n public\r\n constructor Create;\r\n procedure BeforeDestruction; override;\r\n procedure GetAsSet(var Buf); virtual; abstract;\r\n function HasValue: Boolean; virtual; abstract;\r\n function IsAssigned: Boolean; virtual; abstract;\r\n function IsInitialized: Boolean; virtual; abstract;\r\n function IsReadOnlyProperty: Boolean; virtual; abstract;\r\n class function ItemRegister: TJvInspectorRegister; virtual;\r\n class function New: TJvCustomInspectorData;\r\n function NewItem(const AParent: TJvCustomInspectorItem): TJvCustomInspectorItem; virtual;\r\n procedure SetAsSet(const Buf); virtual; abstract;\r\n property AsFloat: Extended read GetAsFloat write SetAsFloat;\r\n property AsInt64: Int64 read GetAsInt64 write SetAsInt64;\r\n property AsMethod: TMethod read GetAsMethod write SetAsMethod;\r\n property AsOrdinal: Int64 read GetAsOrdinal write SetAsOrdinal;\r\n property AsString: string read GetAsString write SetAsString;\r\n property AsVariant: Variant read GetAsVariant write SetAsVariant;\r\n property ItemCount: Integer read GetItemCount;\r\n property Items[I: Integer]: TJvCustomInspectorItem read GetItems;\r\n property Name: string read GetName write SetName;\r\n property OnValueChanged: TNotifyEvent read FOnValueChanged write FOnValueChanged;\r\n property TypeInfo: PTypeInfo read GetTypeInfo write SetTypeInfo;\r\n end;\r\n\r\n TJvInspectorSetMemberData = class(TJvCustomInspectorData)\r\n private\r\n FBitOffset: Integer;\r\n FDataParent: TJvCustomInspectorData;\r\n protected\r\n function GetAsFloat: Extended; override;\r\n function GetAsInt64: Int64; override;\r\n function GetAsMethod: TMethod; override;\r\n function GetAsOrdinal: Int64; override;\r\n function GetAsString: string; override;\r\n function IsEqualReference(const Ref: TJvCustomInspectorData): Boolean; override;\r\n procedure NotifyRemoveData(const Instance: TJvCustomInspectorData); override;\r\n procedure SetAsFloat(const Value: Extended); override;\r\n procedure SetAsInt64(const Value: Int64); override;\r\n procedure SetAsMethod(const Value: TMethod); override;\r\n procedure SetAsOrdinal(const Value: Int64); override;\r\n procedure SetAsString(const Value: string); override;\r\n public\r\n procedure GetAsSet(var Buf); override;\r\n function HasValue: Boolean; override;\r\n function IsAssigned: Boolean; override;\r\n function IsInitialized: Boolean; override;\r\n class function New(const AParent: TJvCustomInspectorItem; const Ordinal: Integer; const ADataParent:\r\n TJvCustomInspectorData): TJvCustomInspectorItem; reintroduce; overload;\r\n procedure SetAsSet(const Buf); override;\r\n property BitOffset: Integer read FBitOffset;\r\n property DataParent: TJvCustomInspectorData read FDataParent;\r\n end;\r\n\r\n TJvInspectorVarData = class(TJvCustomInspectorData)\r\n private\r\n FAddress: Pointer;\r\n protected\r\n function GetAddress: Pointer; virtual;\r\n function GetAsFloat: Extended; override;\r\n function GetAsInt64: Int64; override;\r\n function GetAsMethod: TMethod; override;\r\n function GetAsOrdinal: Int64; override;\r\n function GetAsString: string; override;\r\n function GetAsVariant: Variant; override;\r\n function IsEqualReference(const Ref: TJvCustomInspectorData): Boolean; override;\r\n procedure SetAddress(const Value: Pointer); virtual;\r\n procedure SetAsFloat(const Value: Extended); override;\r\n procedure SetAsInt64(const Value: Int64); override;\r\n procedure SetAsMethod(const Value: TMethod); override;\r\n procedure SetAsOrdinal(const Value: Int64); override;\r\n procedure SetAsString(const Value: string); override;\r\n procedure SetAsVariant(const Value: Variant); override;\r\n function SupportsMethodPointers: Boolean; override;\r\n public\r\n procedure GetAsSet(var Buf); override;\r\n function HasValue: Boolean; override;\r\n function IsAssigned: Boolean; override;\r\n function IsInitialized: Boolean; override;\r\n class function ItemRegister: TJvInspectorRegister; override;\r\n class function New(const AParent: TJvCustomInspectorItem; const AName: string; ATypeInfo: PTypeInfo; const\r\n AAddress: Pointer): TJvCustomInspectorItem; reintroduce; overload;\r\n // REMOVED BECAUSE OF A BCB INCOMPATIBILITY:\r\n // Untyped parameters are output as void* which is exactly the same\r\n // as the output for Pointer, thus leading to the exact same\r\n // declaration. If you used this version before, simply replace\r\n // the AVar parameter by @AVar\r\n // class function New(const AParent: TJvCustomInspectorItem; const AName: string; const ATypeInfo: PTypeInfo; const AVar): TJvCustomInspectorItem; overload;\r\n procedure SetAsSet(const Buf); override;\r\n property Address: Pointer read GetAddress write SetAddress;\r\n end;\r\n\r\n // Inspector Data Object that Enumerates the Properties of a TPersistent/TComponent/TControl, etc:\r\n TJvInspectorPropData = class(TJvCustomInspectorData)\r\n private\r\n FInstance: TObject;\r\n FProp: PPropInfo;\r\n protected\r\n function GetAsFloat: Extended; override;\r\n function GetAsInt64: Int64; override;\r\n function GetAsMethod: TMethod; override;\r\n function GetAsOrdinal: Int64; override;\r\n function GetAsString: string; override;\r\n function GetAsVariant: Variant; override;\r\n function GetInstance: TObject; virtual;\r\n function GetProp: PPropInfo; virtual;\r\n function IsEqualReference(const Ref: TJvCustomInspectorData): Boolean; override;\r\n procedure NotifyRemoveData(const Instance: TJvCustomInspectorData); override;\r\n procedure SetAsFloat(const Value: Extended); override;\r\n procedure SetAsInt64(const Value: Int64); override;\r\n procedure SetAsMethod(const Value: TMethod); override;\r\n procedure SetAsOrdinal(const Value: Int64); override;\r\n procedure SetAsString(const Value: string); override;\r\n procedure SetAsVariant(const Value: Variant); override;\r\n procedure SetInstance(const Value: TObject); virtual;\r\n procedure SetProp(Value: PPropInfo); virtual;\r\n function SupportsMethodPointers: Boolean; override;\r\n public\r\n procedure GetAsSet(var Buf); override;\r\n function HasValue: Boolean; override;\r\n function IsAssigned: Boolean; override;\r\n function IsInitialized: Boolean; override;\r\n function IsReadOnlyProperty: Boolean; override;\r\n class function ItemRegister: TJvInspectorRegister; override;\r\n class function TypeInfoMapRegister: TJvInspectorRegister;\r\n class procedure AddTypeMapping(Target, Source: PTypeInfo; ObjectClass: TClass = nil;\r\n const PropertyName: string = '');\r\n class function New(const AParent: TJvCustomInspectorItem; const AInstance: TObject;\r\n PropInfo: PPropInfo): TJvCustomInspectorItem; reintroduce; overload;\r\n class function New(const AParent: TJvCustomInspectorItem; const AInstance: TObject;\r\n const PropName: string): TJvCustomInspectorItem; reintroduce; overload;\r\n class function New(const AParent: TJvCustomInspectorItem; const AInstance: TObject;\r\n const TypeKinds: TTypeKinds = tkProperties): TJvInspectorItemInstances; reintroduce; overload;\r\n class function NewByNames(const AParent: TJvCustomInspectorItem; const AInstance: TObject;\r\n const NameList: array of string; const ExcludeList: Boolean = False;\r\n const TypeKinds: TTypeKinds = tkProperties): TJvInspectorItemInstances;\r\n class function New(const AParent: TJvCustomInspectorItem; const AInstance: TObject;\r\n PropInfos: PPropList; const PropCount: Integer): TJvInspectorItemInstances; reintroduce; overload;\r\n procedure SetAsSet(const Buf); override;\r\n property Instance: TObject read GetInstance write SetInstance;\r\n property Prop: PPropInfo read GetProp write SetProp;\r\n end;\r\n\r\n TJvInspectorEventData = class(TJvCustomInspectorData)\r\n private\r\n FOnGetAsFloat: TJvInspAsFloat;\r\n FOnGetAsInt64: TJvInspAsInt64;\r\n FOnGetAsMethod: TJvInspAsMethod;\r\n FOnGetAsOrdinal: TJvInspAsInt64;\r\n FOnGetAsString: TJvInspAsString;\r\n FOnGetAsSet: TJvInspAsSet;\r\n FOnSetAsFloat: TJvInspAsFloat;\r\n FOnSetAsInt64: TJvInspAsInt64;\r\n FOnSetAsMethod: TJvInspAsMethod;\r\n FOnSetAsOrdinal: TJvInspAsInt64;\r\n FOnSetAsString: TJvInspAsString;\r\n FOnSetAsSet: TJvInspAsSet;\r\n FOnSupportsMethodPointers: TJvInspSupportsMethodPointers;\r\n\r\n FParent: TJvCustomInspectorItem;\r\n protected\r\n function DoGetAsFloat: Extended;\r\n function DoGetAsInt64: Int64;\r\n function DoGetAsMethod: TMethod;\r\n function DoGetAsOrdinal: Int64;\r\n function DoGetAsString: string;\r\n procedure DoGetAsSet(out Buf; var BufSize: Integer);\r\n procedure DoSetAsFloat(Value: Extended);\r\n procedure DoSetAsInt64(Value: Int64);\r\n procedure DoSetAsMethod(Value: TMethod);\r\n procedure DoSetAsOrdinal(Value: Int64);\r\n procedure DoSetAsString(Value: string);\r\n procedure DoSetAsSet(const Buf; var BufSize: Integer);\r\n function DoSupportsMethodPointers: Boolean;\r\n function GetAsFloat: Extended; override;\r\n function GetAsInt64: Int64; override;\r\n function GetAsMethod: TMethod; override;\r\n function GetAsOrdinal: Int64; override;\r\n function GetAsString: string; override;\r\n function IsEqualReference(const Ref: TJvCustomInspectorData): Boolean; override;\r\n procedure SetAsFloat(const Value: Extended); override;\r\n procedure SetAsInt64(const Value: Int64); override;\r\n procedure SetAsMethod(const Value: TMethod); override;\r\n procedure SetAsOrdinal(const Value: Int64); override;\r\n procedure SetAsString(const Value: string); override;\r\n procedure SetOnGetAsFloat(Value: TJvInspAsFloat);\r\n procedure SetOnGetAsInt64(Value: TJvInspAsInt64);\r\n procedure SetOnGetAsMethod(Value: TJvInspAsMethod);\r\n procedure SetOnGetAsOrdinal(Value: TJvInspAsInt64);\r\n procedure SetOnGetAsString(Value: TJvInspAsString);\r\n procedure SetOnGetAsSet(Value: TJvInspAsSet);\r\n procedure SetOnSetAsFloat(Value: TJvInspAsFloat);\r\n procedure SetOnSetAsInt64(Value: TJvInspAsInt64);\r\n procedure SetOnSetAsMethod(Value: TJvInspAsMethod);\r\n procedure SetOnSetAsOrdinal(Value: TJvInspAsInt64);\r\n procedure SetOnSetAsString(Value: TJvInspAsString);\r\n procedure SetOnSetAsSet(Value: TJvInspAsSet);\r\n procedure SetOnSupportsMethodPointers(Value: TJvInspSupportsMethodPointers);\r\n function SupportsMethodPointers: Boolean; override;\r\n public\r\n procedure GetAsSet(var Buf); override;\r\n function HasValue: Boolean; override;\r\n function IsAssigned: Boolean; override;\r\n function IsInitialized: Boolean; override;\r\n class function New(const AParent: TJvCustomInspectorItem; const AName: string; ATypeInfo: PTypeInfo):\r\n TJvCustomInspectorItem; reintroduce; overload;\r\n procedure SetAsSet(const Buf); override;\r\n property OnGetAsFloat: TJvInspAsFloat read FOnGetAsFloat write SetOnGetAsFloat;\r\n property OnGetAsInt64: TJvInspAsInt64 read FOnGetAsInt64 write SetOnGetAsInt64;\r\n property OnGetAsMethod: TJvInspAsMethod read FOnGetAsMethod write SetOnGetAsMethod;\r\n property OnGetAsOrdinal: TJvInspAsInt64 read FOnGetAsOrdinal write SetOnGetAsOrdinal;\r\n property OnGetAsString: TJvInspAsString read FOnGetAsString write SetOnGetAsString;\r\n property OnGetAsSet: TJvInspAsSet read FOnGetAsSet write SetOnGetAsSet;\r\n property OnSetAsFloat: TJvInspAsFloat read FOnSetAsFloat write SetOnSetAsFloat;\r\n property OnSetAsInt64: TJvInspAsInt64 read FOnSetAsInt64 write SetOnSetAsInt64;\r\n property OnSetAsMethod: TJvInspAsMethod read FOnSetAsMethod write SetOnSetAsMethod;\r\n property OnSetAsOrdinal: TJvInspAsInt64 read FOnSetAsOrdinal write SetOnSetAsOrdinal;\r\n property OnSetAsString: TJvInspAsString read FOnSetAsString write SetOnSetAsString;\r\n property OnSetAsSet: TJvInspAsSet read FOnSetAsSet write SetOnSetAsSet;\r\n property OnSupportsMethodPointers: TJvInspSupportsMethodPointers read FOnSupportsMethodPointers write\r\n SetOnSupportsMethodPointers;\r\n end;\r\n\r\n // used for inspecting INI and registry file data, validation rules\r\n // are different than inspecting TComponent properties. -WAP.\r\n TJvInspectorCustomConfData = class(TJvCustomInspectorData)\r\n private\r\n FKey: string;\r\n FSection: string;\r\n protected\r\n constructor CreatePrim(const AName, ASection, AKey: string; ATypeInfo: PTypeInfo);\r\n function ExistingValue: Boolean; virtual; abstract;\r\n function GetAsFloat: Extended; override;\r\n function GetAsInt64: Int64; override;\r\n function GetAsMethod: TMethod; override;\r\n function GetAsOrdinal: Int64; override;\r\n function ForceString: string;\r\n // NEW: Display something from an INI section that isn't the type it's supposed to be without exceptions and component failures.\r\n function GetAsString: string; override;\r\n function IsEqualReference(const Ref: TJvCustomInspectorData): Boolean; override;\r\n procedure SetAsFloat(const Value: Extended); override;\r\n procedure SetAsInt64(const Value: Int64); override;\r\n procedure SetAsMethod(const Value: TMethod); override;\r\n procedure SetAsOrdinal(const Value: Int64); override;\r\n procedure SetAsString(const Value: string); override;\r\n procedure SetKey(const Value: string);\r\n procedure SetSection(const Value: string);\r\n procedure WriteValue(const Value: string); virtual; abstract;\r\n public\r\n function ReadValue: string; virtual; abstract; // made public to help fix a bug. WAP.\r\n procedure GetAsSet(var Buf); override;\r\n function HasValue: Boolean; override;\r\n function IsAssigned: Boolean; override;\r\n function IsInitialized: Boolean; override;\r\n procedure SetAsSet(const Buf); override;\r\n property Key: string read FKey write SetKey;\r\n property Section: string read FSection write SetSection;\r\n end;\r\n\r\n TJvInspectorINIFileData = class(TJvInspectorCustomConfData)\r\n private\r\n FINIFile: TCustomIniFile;\r\n protected\r\n function ExistingValue: Boolean; override;\r\n function IsEqualReference(const Ref: TJvCustomInspectorData): Boolean; override;\r\n procedure WriteValue(const Value: string); override;\r\n public\r\n function ReadValue: string; override;\r\n class function New(const AParent: TJvCustomInspectorItem;\r\n const AName, ASection, AKey: string; ATypeInfo: PTypeInfo;\r\n const AINIFile: TCustomIniFile): TJvCustomInspectorItem; reintroduce; overload;\r\n class function New(const AParent: TJvCustomInspectorItem;\r\n const ASection: string; const AINIFile: TCustomIniFile;\r\n const AOnAddKey: TJvInspConfKeyEvent): TJvInspectorItemInstances; reintroduce; overload;\r\n class function New(const AParent: TJvCustomInspectorItem;\r\n const AINIFile: TCustomIniFile; const AOnAddSection: TJvInspConfSectionEvent;\r\n const AOnAddKey: TJvInspConfKeyEvent): TJvInspectorItemInstances; reintroduce; overload;\r\n property INIFile: TCustomIniFile read FINIFile;\r\n end;\r\n\r\n TJvInspectorRegister = class(TPersistent)\r\n private\r\n FDataClass: TJvInspectorDataClass;\r\n FItems: TObjectList;\r\n protected\r\n function Compare(const ADataObj: TJvCustomInspectorData;\r\n const Item1, Item2: TJvCustomInspectorRegItem): Integer;\r\n function GetCount: Integer;\r\n function GetItems(const I: Integer): TJvCustomInspectorRegItem; virtual;\r\n public\r\n constructor Create(const ADataClass: TJvInspectorDataClass);\r\n destructor Destroy; override;\r\n procedure Add(const RegItem: TJvCustomInspectorRegItem);\r\n procedure Delete(const RegItem: TJvCustomInspectorRegItem); overload;\r\n procedure Delete(const ItemClass: TJvInspectorItemClass); overload;\r\n procedure Delete(const Index: Integer); overload;\r\n function FindMatch(const ADataObj: TJvCustomInspectorData): TJvCustomInspectorRegItem;\r\n function IndexOf(const RegItem: TJvCustomInspectorRegItem): Integer; overload;\r\n function IndexOf(const ItemClass: TJvInspectorItemClass): Integer; overload;\r\n property Count: Integer read GetCount;\r\n property DataClass: TJvInspectorDataClass read FDataClass;\r\n property Items[const I: Integer]: TJvCustomInspectorRegItem read GetItems;\r\n end;\r\n\r\n TJvCustomInspectorRegItem = class(TPersistent)\r\n private\r\n FItemClass: TJvInspectorItemClass;\r\n protected\r\n function CompareTo(const ADataObj: TJvCustomInspectorData;\r\n const Item: TJvCustomInspectorRegItem): Integer; virtual;\r\n function GetItemClass: TJvInspectorItemClass; virtual;\r\n procedure SetItemClass(const Value: TJvInspectorItemClass); virtual;\r\n public\r\n constructor Create(const AItemClass: TJvInspectorItemClass);\r\n procedure ApplyDefaults(const Item: TJvCustomInspectorItem); virtual;\r\n function Compare(const ADataObj: TJvCustomInspectorData;\r\n const Item: TJvCustomInspectorRegItem): Integer; virtual;\r\n function IsMatch(const ADataObj: TJvCustomInspectorData): Boolean; virtual;\r\n function MatchValue(const ADataObj: TJvCustomInspectorData): Integer; virtual; abstract;\r\n function MatchPercent(const ADataObj: TJvCustomInspectorData): Integer; virtual; abstract;\r\n property ItemClass: TJvInspectorItemClass read GetItemClass;\r\n end;\r\n\r\n TJvInspectorTypeInfoRegItem = class(TJvCustomInspectorRegItem)\r\n private\r\n FTypeInfo: PTypeInfo;\r\n protected\r\n function GetTypeInfo: PTypeInfo; virtual;\r\n procedure SetTypeInfo(Value: PTypeInfo); virtual;\r\n public\r\n constructor Create(const AItemClass: TJvInspectorItemClass; ATypeInfo: PTypeInfo);\r\n function MatchValue(const ADataObj: TJvCustomInspectorData): Integer; override;\r\n function MatchPercent(const ADataObj: TJvCustomInspectorData): Integer; override;\r\n property TypeInfo: PTypeInfo read GetTypeInfo;\r\n end;\r\n\r\n TJvInspectorTCaptionRegItem = class(TJvInspectorTypeInfoRegItem)\r\n public\r\n procedure ApplyDefaults(const Item: TJvCustomInspectorItem); override;\r\n end;\r\n\r\n TJvInspectorTypeKindRegItem = class(TJvCustomInspectorRegItem)\r\n private\r\n FTypeKind: TTypeKind;\r\n protected\r\n function CompareTo(const ADataObj: TJvCustomInspectorData;\r\n const Item: TJvCustomInspectorRegItem): Integer; override;\r\n function GetTypeKind: TTypeKind; virtual;\r\n procedure SetTypeKind(const Value: TTypeKind); virtual;\r\n public\r\n constructor Create(const AItemClass: TJvInspectorItemClass;\r\n const ATypeKind: TTypeKind);\r\n function Compare(const ADataObj: TJvCustomInspectorData;\r\n const Item: TJvCustomInspectorRegItem): Integer; override;\r\n function MatchValue(const ADataObj: TJvCustomInspectorData): Integer; override;\r\n function MatchPercent(const ADataObj: TJvCustomInspectorData): Integer; override;\r\n property TypeKind: TTypeKind read GetTypeKind;\r\n end;\r\n\r\n TJvInspectorPropRegItem = class(TJvCustomInspectorRegItem)\r\n private\r\n FObjectClass: TClass;\r\n FName: string;\r\n FTypeInfo: PTypeInfo;\r\n public\r\n constructor Create(const AItemClass: TJvInspectorItemClass; const AObjectClass: TClass;\r\n const AName: string; ATypeInfo: PTypeInfo);\r\n function Compare(const ADataObj: TJvCustomInspectorData;\r\n const Item: TJvCustomInspectorRegItem): Integer; override;\r\n function MatchValue(const ADataObj: TJvCustomInspectorData): Integer; override;\r\n function MatchPercent(const ADataObj: TJvCustomInspectorData): Integer; override;\r\n property Name: string read FName;\r\n property ObjectClass: TClass read FObjectClass;\r\n property TypeInfo: PTypeInfo read FTypeInfo;\r\n end;\r\n\r\n TJvInspectorTypeInfoMapperRegItem = class(TJvCustomInspectorRegItem)\r\n private\r\n FObjectClass: TClass;\r\n FPropertyName: string;\r\n FPropertyType: PTypeInfo;\r\n FNewTypeInfo: PTypeInfo;\r\n public\r\n constructor Create(AObjectClass: TClass; const APropertyName: string;\r\n APropertyType: PTypeInfo; ANewTypeInfo: PTypeInfo);\r\n function Compare(const ADataObj: TJvCustomInspectorData;\r\n const Item: TJvCustomInspectorRegItem): Integer; override;\r\n function MatchValue(const ADataObj: TJvCustomInspectorData): Integer; override;\r\n function MatchPercent(const ADataObj: TJvCustomInspectorData): Integer; override;\r\n property ObjectClass: TClass read FObjectClass;\r\n property PropertyName: string read FPropertyName;\r\n property PropertyType: PTypeInfo read FPropertyType;\r\n property NewTypeInfo: PTypeInfo read FNewTypeInfo;\r\n end;\r\n\r\n// (rom) centralized the string literals\r\nconst\r\n cJvInspectorFloat = 'Float';\r\n cJvInspectorInt64 = 'Int64';\r\n cJvInspectorTMethod = 'TMethod';\r\n cJvInspectorOrdinal = 'Ordinal';\r\n cJvInspectorString = 'string';\r\n cJvInspectorSet = 'set';\r\n cJvInspectorVariant = 'variant';\r\n\r\n// All the declarations below are to help support Type Info under C++ Builder\r\n\r\n// we add missing typedefs for some Delphi types\r\n{$HPPEMIT 'typedef __int64 Int64;'}\r\n{$HPPEMIT 'typedef double Real;'}\r\n{$HPPEMIT ''}\r\n\r\n// The TJvTypeInfoHelper class is provided here to help C++ Builder users\r\n// get type information for base types.\r\n// In Delphi, to get the Type Info for an Integer, we would have done\r\n// TypeInfo(Integer). But with C++ Builder, the TypeInfo function\r\n// doesn't exist. We will then define a macro to do it for us, but with\r\n// the drawback that it will only work with types that have been declared\r\n// in a registered TypeInfo helper class.\r\n// As recommended by the help, we get the value we need by\r\n// calling GetPropInfo on a published property of an existing object.\r\n// But we need a TTypeInfo pointer, so we access the PropType\r\n// member of the PPropInfo returned by GetPropInfo.\r\n// Please see RegisterPropertyEditor in C++ Builder help for\r\n// the example that inspired this bizarre construct.\r\n\r\ntype\r\n // The class MUST be a class derived from TPersistent\r\n // to get the RTTI information\r\n TJvTypeInfoHelper = class(TPersistent)\r\n private\r\n FAnsiCharProp: AnsiChar;\r\n FAnsiStringProp: AnsiString;\r\n FBooleanProp: Boolean;\r\n FByteProp: Byte;\r\n FByteBoolProp: ByteBool;\r\n FCardinalProp: Cardinal;\r\n FCharProp: Char;\r\n FDoubleProp: Double;\r\n FExtendedProp: Extended;\r\n FInt64Prop: Int64;\r\n FIntegerProp: Integer;\r\n FLongBoolProp: LongBool;\r\n FLongintProp: Longint;\r\n FRealProp: Real;\r\n FShortintProp: Shortint;\r\n FSingleProp: Single;\r\n FSmallintProp: Smallint;\r\n FTDateTimeProp: TDateTime;\r\n {$IFDEF UNICODE}\r\n FUnicodeString: UnicodeString;\r\n {$ENDIF}\r\n FWideCharProp: WideChar;\r\n FWordProp: Word;\r\n FWordBoolProp: WordBool;\r\n published\r\n // These are the base Delphi types\r\n property AnsiCharProp: AnsiChar read FAnsiCharProp;\r\n property AnsiStringProp: AnsiString read FAnsiStringProp;\r\n property BooleanProp: Boolean read FBooleanProp;\r\n property ByteProp: Byte read FByteProp;\r\n property ByteBoolProp: ByteBool read FByteBoolProp;\r\n property CardinalProp: Cardinal read FCardinalProp;\r\n property CharProp: Char read FCharProp;\r\n property DoubleProp: Double read FDoubleProp;\r\n property ExtendedProp: Extended read FExtendedProp;\r\n property Int64Prop: Int64 read FInt64Prop;\r\n property IntegerProp: Integer read FIntegerProp;\r\n property LongBoolProp: LongBool read FLongBoolProp;\r\n property LongintProp: Longint read FLongintProp;\r\n property RealProp: Real read FRealProp;\r\n property ShortintProp: Shortint read FShortintProp;\r\n property SingleProp: Single read FSingleProp;\r\n property SmallintProp: Smallint read FSmallintProp;\r\n property TDateTimeProp: TDateTime read FTDateTimeProp;\r\n {$IFDEF UNICODE}\r\n property UnicodeStringProp: UnicodeString read FUnicodeString;\r\n {$ENDIF}\r\n property WideCharProp: WideChar read FWideCharProp;\r\n property WordProp: Word read FWordProp;\r\n property WordBoolProp: WordBool read FWordBoolProp;\r\n // These are the C++ Builder types that don't exist in Delphi\r\n // Some C++ types are different from Delphi types only by case\r\n // and are not represented here\r\n property __int64Prop: Int64 read FInt64Prop;\r\n property boolProp: Boolean read FBooleanProp;\r\n property floatProp: Single read FSingleProp;\r\n property intProp: Integer read FIntegerProp;\r\n property longProp: Integer read FIntegerProp;\r\n property long_doubleProp: Extended read FExtendedProp;\r\n property shortProp: Smallint read FSmallintProp;\r\n property signed_charProp: Shortint read FShortintProp;\r\n property signed_intProp: Integer read FIntegerProp;\r\n property signed_longProp: Integer read FIntegerProp;\r\n property signed_shortProp: Smallint read FSmallintProp;\r\n property unsigned_charProp: Byte read FByteProp;\r\n property unsigned_intProp: Cardinal read FCardinalProp;\r\n property unsigned_longProp: Cardinal read FCardinalProp;\r\n property unsigned_shortProp: Byte read FByteProp;\r\n end;\r\n TJvTypeInfoHelperClass = class of TJvTypeInfoHelper;\r\n\r\n// This function returns the type info associated with the given type name\r\n// It will go through the collection of known TypeInfoHelpers and try\r\n// to find one that contains a property named TypeName+'Prop'\r\n// The first one it finds will be used to return the PTypeInfo pointer\r\nfunction TypeInfoFromName(TypeName: string): PTypeInfo;\r\n\r\n// Register the given class as a TypeInfo helper\r\nprocedure RegisterTypeInfoHelper(AClass: TJvTypeInfoHelperClass);\r\n\r\n//Inspector Data Register\r\ntype\r\n TJvInspDataReg = class(TPersistent)\r\n private\r\n FInstanceList: TJvInspectorDataInstances;\r\n FClearing: Boolean;\r\n protected\r\n function GetCount: Integer;\r\n function GetItems(I: Integer): TJvCustomInspectorData;\r\n public\r\n constructor Create;\r\n destructor Destroy; override;\r\n // Adds a new data instance. If an instance pointing to the same data exists the given instance is destroyed and the registered instance returned\r\n function Add(Instance: TJvCustomInspectorData): TJvCustomInspectorData;\r\n // Deletes a data instance and all items referencing it. All other data instances are notified.\r\n// procedure Delete(Instance: TJvCustomInspectorData); make Delphi 5 compiler happy // andreas\r\n // Deletes all data instances and items referencing them. No notification is issued to the data instances as they will be removed also.\r\n procedure Clear;\r\n // Locates a data instance that references the same data as the given instance. The index is returned or -1 if no instance was found.\r\n function Locate(Instance: TJvCustomInspectorData): Integer;\r\n // Removes a data instance from the list. All other data instances are notified.\r\n procedure Remove(Instance: TJvCustomInspectorData);\r\n property Count: Integer read GetCount;\r\n property Items[I: Integer]: TJvCustomInspectorData read GetItems;\r\n end;\r\n\r\n// Access to the GlobalDataRegister\r\nfunction DataRegister: TJvInspDataReg;\r\n\r\n// Canvas State functions used by TJvInspectorPainter & its descendents\r\nfunction SaveCanvasState(const Canvas: TCanvas): Integer;\r\nprocedure ApplyCanvasState(const Canvas: TCanvas; const SavedIdx: Integer);\r\nprocedure RestoreCanvasState(const Canvas: TCanvas; const SavedIdx: Integer);\r\n\r\n// We define here a set of macros to help C++ Builder programmers\r\n// gather Type Info by typing code very similar to Delphi code where\r\n// one only has to type TypeInfo(typename) to get the correct result\r\n\r\n// Those first two are required to convert a macro argument\r\n// to a string. Hence STR(hello) is equivalent to \"hello\"\r\n{$HPPEMIT '#define _STR(x) #x'}\r\n{$HPPEMIT '#define STR(x) _STR(x)'}\r\n\r\n// This macro gives an expression that gives the TypeInfo for a given\r\n// type, using the given class. It will look for a published property\r\n// named type + \"Prop\" in the given class.\r\n{$HPPEMIT '#define TypeInfoFromClass(class, type) *(GetPropInfo(__typeinfo(class), STR(type) \"Prop\" )->PropType)'}\r\n\r\n// This macro is a shortcut for all base types. If you use it for any\r\n// other type, the compilation will work, but an access violation will\r\n// occur at runtime because a property of your type couldn't be found\r\n// in the TJvTypeInfoHelper class declared above.\r\n// You should declare a class with a published property of your type\r\n// and use the TypeInfoFromClass macro.\r\n{$HPPEMIT '#define TypeInfo(type) TypeInfoFromName(STR(type))'}\r\n{$HPPEMIT ''}\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvInspector.pas $';\r\n Revision: '$Revision: 13415 $';\r\n Date: '$Date: 2012-09-10 11:51:54 +0200 (lun. 10 sept. 2012) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n {$IFDEF HAS_UNIT_SYSTEM_UITYPES}\r\n System.UITypes,\r\n {$ENDIF HAS_UNIT_SYSTEM_UITYPES}\r\n RTLConsts, Types, Variants, Consts, Dialogs, Forms, Buttons,\r\n JclRTTI, JclLogic, JclStrings,\r\n JvJCLUtils, JvThemes, JvResources, JclSysUtils;\r\n\r\n// BCB Type Info support\r\nvar\r\n GlobalTypeInfoHelpersList: TClassList;\r\n\r\nfunction CreatePainterFromStyle(Style: TJvInspectorStyle): TJvInspectorPainter;\r\nbegin\r\n case Style of\r\n isDotNet:\r\n Result := TJvInspectorDotNETPainter.Create(nil);\r\n else\r\n Result := TJvInspectorBorlandPainter.Create(nil);\r\n end;\r\nend;\r\n\r\n//============================================================================\r\n\r\nfunction TypeInfoHelpersList: TClassList;\r\nbegin\r\n if not Assigned(GlobalTypeInfoHelpersList) then\r\n begin\r\n GlobalTypeInfoHelpersList := TClassList.Create;\r\n // register\r\n RegisterTypeInfoHelper(TJvTypeInfoHelper);\r\n end;\r\n Result := GlobalTypeInfoHelpersList;\r\nend;\r\n\r\nfunction TypeInfoFromName(TypeName: string): PTypeInfo;\r\nvar\r\n I: Integer;\r\n PropInfo: PPropInfo;\r\nbegin\r\n // replace spaces by underscores\r\n StrReplace(TypeName, ' ', '_', [rfReplaceAll]);\r\n\r\n I := 0;\r\n PropInfo := nil;\r\n\r\n while (I < TypeInfoHelpersList.Count) and (PropInfo = nil) do\r\n begin\r\n PropInfo := GetPropInfo(TypeInfoHelpersList[I], TypeName + 'Prop');\r\n Inc(I);\r\n end;\r\n\r\n if PropInfo <> nil then\r\n Result := PropInfo.PropType^\r\n else\r\n Result := nil;\r\nend;\r\n\r\nprocedure RegisterTypeInfoHelper(AClass: TJvTypeInfoHelperClass);\r\nbegin\r\n TypeInfoHelpersList.Add(AClass);\r\nend;\r\n\r\ntype\r\n PMethod = ^TMethod;\r\n PComp = ^Comp;\r\n PPointer = ^Pointer;\r\n TCustomEditAccessProtected = class(TCustomEdit);\r\n\r\nvar\r\n GlobalGenItemReg: TJvInspectorRegister = nil;\r\n GlobalVarItemReg: TJvInspectorRegister = nil;\r\n GlobalPropItemReg: TJvInspectorRegister = nil;\r\n GlobalPropMapReg: TJvInspectorRegister = nil;\r\n\r\nprocedure RegisterDataTypeKinds; forward;\r\nprocedure RegisterPropDataTypeKinds; forward;\r\n\r\n//=== { TCanvasStack } =======================================================\r\n\r\ntype\r\n TCanvasStack = class(TObjectList)\r\n private\r\n FTop: Integer;\r\n procedure SetCapacity(const Value: Integer);\r\n public\r\n constructor Create(const ACapacity: Integer);\r\n function Push(const Canvas: TCanvas): Integer;\r\n procedure Pop(const Canvas: TCanvas; Index: Integer = -2);\r\n // procedure Peek(const Canvas: TCanvas; Index: Integer = -2); make Delphi 5 compiler happy // andreas\r\n property Capacity write SetCapacity;\r\n property Top: Integer read FTop write FTop;\r\n end;\r\n\r\n TCanvasState = class(TPersistent)\r\n private\r\n FBrush: TBrush;\r\n FPen: TPen;\r\n FFont: TFont;\r\n public\r\n constructor Create(const Canvas: TCanvas);\r\n destructor Destroy; override;\r\n procedure ApplyTo(const Canvas: TCanvas);\r\n procedure SetState(const Canvas: TCanvas);\r\n end;\r\n\r\nvar\r\n GlobalCanvasStack: TCanvasStack = nil;\r\n\r\nconstructor TCanvasStack.Create(const ACapacity: Integer);\r\nbegin\r\n inherited Create(True);\r\n FTop := -1;\r\n Capacity := ACapacity;\r\nend;\r\n\r\nprocedure TCanvasStack.SetCapacity(const Value: Integer);\r\nvar\r\n I: Integer;\r\nbegin\r\n if Capacity <> Value then\r\n begin\r\n if Value < Capacity then\r\n begin\r\n inherited Capacity := Value;\r\n if FTop >= Capacity then\r\n FTop := Capacity - 1;\r\n end\r\n else\r\n begin\r\n I := Capacity;\r\n inherited Capacity := Value;\r\n for I := I to Value - 1 do\r\n Add(TCanvasState.Create(nil));\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TCanvasStack.Push(const Canvas: TCanvas): Integer;\r\nbegin\r\n Inc(FTop);\r\n if FTop >= Capacity then\r\n Capacity := Capacity + 128;\r\n Result := FTop;\r\n TCanvasState(Items[Result]).SetState(Canvas);\r\nend;\r\n\r\nprocedure TCanvasStack.Pop(const Canvas: TCanvas; Index: Integer = -2);\r\nbegin\r\n if Index = -1 then\r\n Index := FTop;\r\n TCanvasState(Items[Index]).ApplyTo(Canvas);\r\n FTop := Pred(Index);\r\nend;\r\n\r\n(* make Delphi 5 compiler happy // andreas\r\nprocedure TCanvasStack.Peek(const Canvas: TCanvas; Index: Integer = -2);\r\nbegin\r\n if Index = -1 then\r\n Index := FTop;\r\n TCanvasState(Items[Index]).ApplyTo(Canvas);\r\nend;*)\r\n\r\n//=== { TCanvasState } =======================================================\r\n\r\nconstructor TCanvasState.Create(const Canvas: TCanvas);\r\nbegin\r\n inherited Create;\r\n FBrush := TBrush.Create;\r\n FPen := TPen.Create;\r\n FFont := TFont.Create;\r\n if Canvas <> nil then\r\n SetState(Canvas);\r\nend;\r\n\r\ndestructor TCanvasState.Destroy;\r\nbegin\r\n FFont.Free;\r\n FPen.Free;\r\n FBrush.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TCanvasState.ApplyTo(const Canvas: TCanvas);\r\nbegin\r\n Canvas.Brush.Assign(FBrush);\r\n Canvas.Pen.Assign(FPen);\r\n Canvas.Font.Assign(FFont);\r\nend;\r\n\r\nprocedure TCanvasState.SetState(const Canvas: TCanvas);\r\nbegin\r\n FBrush.Assign(Canvas.Brush);\r\n FPen.Assign(Canvas.Pen);\r\n FFont.Assign(Canvas.Font);\r\nend;\r\n\r\nfunction CanvasStack: TCanvasStack;\r\nbegin\r\n if GlobalCanvasStack = nil then\r\n GlobalCanvasStack := TCanvasStack.Create(512);\r\n Result := GlobalCanvasStack;\r\nend;\r\n\r\nfunction SaveCanvasState(const Canvas: TCanvas): Integer;\r\nbegin\r\n Result := CanvasStack.Push(Canvas);\r\nend;\r\n\r\nprocedure ApplyCanvasState(const Canvas: TCanvas; const SavedIdx: Integer);\r\nbegin\r\n TCanvasState(CanvasStack[SavedIdx]).ApplyTo(Canvas);\r\nend;\r\n\r\nprocedure RestoreCanvasState(const Canvas: TCanvas; const SavedIdx: Integer);\r\nbegin\r\n CanvasStack.Pop(Canvas, SavedIdx);\r\nend;\r\n\r\nprocedure SetDefaultProp(const Instance: TObject; const PropName: string); overload;\r\nvar\r\n Prop: PPropInfo;\r\nbegin\r\n Prop := GetPropInfo(Instance, PropName);\r\n if (Prop <> nil) and (Prop.Default <> Low(Integer)) then\r\n SetOrdProp(Instance, Prop, Prop.Default);\r\nend;\r\n\r\nprocedure SetDefaultProp(const Instance: TObject; const PropNames: array of string); overload;\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := Low(PropNames) to High(PropNames) do\r\n SetDefaultProp(Instance, PropNames[I]);\r\nend;\r\n\r\n//=== { TInspReg } ===========================================================\r\n\r\ntype\r\n TInspReg = class(TObject)\r\n private\r\n FInspectors: array of TJvCustomInspector;\r\n protected\r\n function ApplicationDeactivate(var Msg: TMessage): Boolean;\r\n function IndexOf(const Inspector: TJvCustomInspector): Integer;\r\n public\r\n procedure RegInspector(const Inspector: TJvCustomInspector);\r\n procedure UnRegInspector(const Inspector: TJvCustomInspector);\r\n end;\r\n\r\nvar\r\n FieldGlobalInspReg: TInspReg = nil;\r\n\r\nfunction GlobalInspReg: TInspReg;\r\nbegin\r\n if not Assigned(FieldGlobalInspReg) then\r\n FieldGlobalInspReg := TInspReg.Create;\r\n Result := FieldGlobalInspReg;\r\nend;\r\n\r\nfunction TInspReg.ApplicationDeactivate(var Msg: TMessage): Boolean;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := False;\r\n if (Msg.Msg = CM_ACTIVATE) or (Msg.Msg = CM_DEACTIVATE) then\r\n // Post the CM_(DE)ACTIVATE message to all registered inspectors\r\n for I := High(FInspectors) downto 0 do\r\n if FInspectors[I].HandleAllocated then\r\n PostMessage(FInspectors[I].Handle, Msg.Msg, 0, 0);\r\nend;\r\n\r\nfunction TInspReg.IndexOf(const Inspector: TJvCustomInspector): Integer;\r\nbegin\r\n Result := High(FInspectors);\r\n while (Result >= 0) and (FInspectors[Result] <> Inspector) do\r\n Dec(Result);\r\nend;\r\n\r\nprocedure TInspReg.RegInspector(const Inspector: TJvCustomInspector);\r\nbegin\r\n if IndexOf(Inspector) = -1 then\r\n begin\r\n SetLength(FInspectors, Length(FInspectors) + 1);\r\n FInspectors[High(FInspectors)] := Inspector;\r\n if Length(FInspectors) = 1 then\r\n Application.HookMainWindow(ApplicationDeactivate);\r\n end;\r\nend;\r\n\r\nprocedure TInspReg.UnRegInspector(const Inspector: TJvCustomInspector);\r\nvar\r\n I: Integer;\r\nbegin\r\n I := IndexOf(Inspector);\r\n if I <> -1 then\r\n begin\r\n if I < High(FInspectors) then\r\n Move(FInspectors[I + 1], FInspectors[I], (High(FInspectors) - I) * SizeOf(TJvCustomInspector));\r\n SetLength(FInspectors, High(FInspectors));\r\n if Length(FInspectors) = 0 then\r\n Application.UnhookMainWindow(ApplicationDeactivate);\r\n end;\r\nend;\r\n\r\n//=== { TJvInspDataReg } =====================================================\r\n\r\nconstructor TJvInspDataReg.Create;\r\nbegin\r\n inherited Create;\r\n SetLength(FInstanceList, 0);\r\nend;\r\n\r\ndestructor TJvInspDataReg.Destroy;\r\nbegin\r\n Clear;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJvInspDataReg.GetCount: Integer;\r\nbegin\r\n Result := Length(FInstanceList);\r\nend;\r\n\r\nfunction TJvInspDataReg.GetItems(I: Integer): TJvCustomInspectorData;\r\nbegin\r\n if (I < Low(FInstanceList)) or (I > High(FInstanceList)) then\r\n TList.Error(SListIndexError, I);\r\n Result := FInstanceList[I];\r\nend;\r\n\r\nfunction TJvInspDataReg.Add(Instance: TJvCustomInspectorData): TJvCustomInspectorData;\r\nvar\r\n I: Integer;\r\nbegin\r\n I := Locate(Instance);\r\n if I = -1 then\r\n begin\r\n SetLength(FInstanceList, Count + 1);\r\n FInstanceList[High(FInstanceList)] := Instance;\r\n Result := Instance;\r\n Result.FRegistered := True;\r\n end\r\n else\r\n begin\r\n if Items[I] <> Instance then\r\n Instance.Free;\r\n Result := Items[I];\r\n end;\r\nend;\r\n\r\n(* make Delphi 5 compiler happy // andreas\r\nprocedure TJvInspDataReg.Delete(Instance: TJvCustomInspectorData);\r\nbegin\r\n Instance.Free;\r\nend;\r\n*)\r\n\r\nprocedure TJvInspDataReg.Clear;\r\nvar\r\n I: Integer;\r\nbegin\r\n FClearing := True;\r\n try\r\n for I := High(FInstanceList) downto Low(FInstanceList) do\r\n Items[I].Free;\r\n finally\r\n FClearing := False;\r\n end;\r\nend;\r\n\r\nfunction TJvInspDataReg.Locate(Instance: TJvCustomInspectorData): Integer;\r\nbegin\r\n Result := High(FInstanceList);\r\n while Result > -1 do\r\n begin\r\n if (Instance = Items[Result]) or Instance.IsEqualReference(Items[Result]) then\r\n Break;\r\n Dec(Result);\r\n end;\r\nend;\r\n\r\nprocedure TJvInspDataReg.Remove(Instance: TJvCustomInspectorData);\r\nvar\r\n I: Integer;\r\nbegin\r\n I := Locate(Instance);\r\n if I > -1 then\r\n begin\r\n if Items[I] <> Instance then\r\n raise EJvInspectorData.CreateRes(@RsEInspectorInternalError);\r\n if I < High(FInstanceList) then\r\n Move(FInstanceList[I + 1], FInstanceList[I], (High(FInstanceList) - I) * SizeOf(TJvCustomInspectorData));\r\n SetLength(FInstanceList, High(FInstanceList));\r\n if not FClearing then\r\n begin\r\n I := High(FInstanceList);\r\n while I >= 0 do\r\n begin\r\n Items[I].NotifyRemoveData(Instance);\r\n Dec(I);\r\n { Additional safety: more than 1 instance might have been removed at this point; make sure\r\n I stays in range. }\r\n if I > High(FInstanceList) then\r\n I := High(FInstanceList);\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\n//=== { TJvCustomInspector } =================================================\r\n\r\nvar\r\n GlobalDataRegister: TJvInspDataReg = nil;\r\n\r\nfunction DataRegister: TJvInspDataReg;\r\nbegin\r\n if not Assigned(GlobalDataRegister) then\r\n GlobalDataRegister := TJvInspDataReg.Create;\r\n Result := GlobalDataRegister;\r\nend;\r\n\r\nconstructor TJvCustomInspector.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n\r\n FExpandButton := TBitmap.Create;\r\n FCollapseButton := TBitmap.Create;\r\n\r\n FBandStartsNoSB := TList.Create;\r\n FBandStartsSB := TList.Create;\r\n FSortNotificationList := TList.Create;\r\n FItemHeight := 16;\r\n DoubleBuffered := True;\r\n FVisibleList := TStringList.Create;\r\n FRoot := TJvCustomInspectorItem.Create(nil, nil);\r\n Root.SetInspector(Self);\r\n Root.Flags := [iifHidden, iifExpanded, iifReadonly, iifVisible];\r\n FSelectedIndex := -1;\r\n BevelKind := bkTile;\r\n BevelInner := bvNone;\r\n BevelOuter := bvLowered;\r\n TabStop := True;\r\n Width := 300;\r\n Height := 100;\r\n Divider := 75;\r\n BandWidth := 150;\r\n AutoComplete := True;\r\n AutoDropDown := False;\r\n\r\n // An easy and 'dirty' way to force Style to take into account its value\r\n // and have the setter do its job\r\n FStyle := isItemPainter;\r\n Style := isBorland;\r\n\r\n if not (csDesigning in ComponentState) then\r\n GlobalInspReg.RegInspector(Self);\r\n\r\n // Mantis 1717: Inspecting self at design time to show effects of painter.\r\n if (csDesigning in ComponentState) then\r\n AddComponent(Self, 'Test category for Inspector', True);\r\nend;\r\n\r\nfunction TJvCustomInspector.CalcImageHeight: Integer;\r\nvar\r\n BandHeightNoSB: Integer;\r\n BandHeightSB: Integer;\r\n ClHeightNoSB: Integer;\r\n ClHeightSB: Integer;\r\n WinStyle: Longint;\r\n I: Integer;\r\nbegin\r\n BandHeightNoSB := 0;\r\n BandHeightSB := 0;\r\n FImageHeight := 0;\r\n FBandStartsNoSB.Clear;\r\n FBandStartsNoSB.Add(Pointer(0));\r\n FBandStartsSB.Clear;\r\n FBandStartsSB.Add(Pointer(0));\r\n ClHeightNoSB := ClientHeight;\r\n WinStyle := GetWindowLong(Handle, GWL_STYLE);\r\n if (WinStyle and WS_HSCROLL) <> 0 then\r\n begin\r\n ClHeightSB := ClHeightNoSB;\r\n Inc(ClHeightNoSB, GetSystemMetrics(SM_CYHSCROLL));\r\n end\r\n else\r\n begin\r\n ClHeightSB := ClHeightNoSB;\r\n Dec(ClHeightSB, GetSystemMetrics(SM_CYHSCROLL));\r\n end;\r\n for I := 0 to Pred(VisibleCount) do\r\n begin\r\n Inc(FImageHeight, VisibleItems[I].Height);\r\n if UseBands then\r\n begin\r\n if ((BandHeightSB + VisibleItems[I].Height) > ClHeightSB) and (BandHeightSB > 0) then\r\n begin\r\n FBandStartsSB.Add(Pointer(I));\r\n BandHeightSB := 0;\r\n end;\r\n if ((BandHeightNoSB + VisibleItems[I].Height) > ClHeightNoSB) and (BandHeightNoSB > 0) then\r\n begin\r\n FBandStartsNoSB.Add(Pointer(I));\r\n BandHeightNoSB := 0;\r\n end;\r\n end;\r\n Inc(BandHeightNoSB, VisibleItems[I].Height);\r\n Inc(BandHeightSB, VisibleItems[I].Height);\r\n end;\r\n Result := FImageHeight;\r\nend;\r\n\r\nfunction TJvCustomInspector.CalcItemIndex(X, Y: Integer; var Rect: TRect): Integer;\r\nvar\r\n BandIdx: Integer;\r\n MaxIdx: Integer;\r\nbegin\r\n if UseBands then\r\n begin\r\n BandIdx := X div BandWidth + BandStarts.IndexOf(Pointer(TopIndex));\r\n if BandIdx < BandStarts.Count then\r\n Result := Integer(BandStarts[BandIdx])\r\n else\r\n Result := -1;\r\n end\r\n else\r\n Result := TopIndex;\r\n MaxIdx := VisibleCount;\r\n while (Result <> -1) and (Result < MaxIdx) and not PtInRect(VisibleItems[Result].Rects[iprItem], Point(X, Y)) do\r\n Inc(Result);\r\n if Result >= MaxIdx then\r\n Result := -1;\r\n if Result > -1 then\r\n Rect := VisibleItems[Result].Rects[iprItem];\r\nend;\r\n\r\nfunction TJvCustomInspector.CalcItemRect(const Item: TJvCustomInspectorItem): TRect;\r\nbegin\r\n Result := Item.Rects[iprItem];\r\nend;\r\n\r\nprocedure TJvCustomInspector.CMActivate(var Msg: TCMActivate);\r\nbegin\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvCustomInspector.CMDeactivate(var Msg: TCMActivate);\r\nbegin\r\n inherited;\r\n if Selected <> nil then\r\n Selected.Deactivate;\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvCustomInspector.DoAfterDataCreate(const Data: TJvCustomInspectorData);\r\nbegin\r\n if Assigned(FAfterDataCreate) then\r\n FAfterDataCreate(Self, Data);\r\nend;\r\n\r\nprocedure TJvCustomInspector.DoAfterItemCreate(const Item: TJvCustomInspectorItem);\r\nbegin\r\n if Assigned(FAfterItemCreate) then\r\n FAfterItemCreate(Self, Item);\r\nend;\r\n\r\nprocedure TJvCustomInspector.DoBeforeItemCreate(const Data: TJvCustomInspectorData;\r\n var ItemClass: TJvInspectorItemClass);\r\nbegin\r\n if Assigned(FBeforeItemCreate) then\r\n FBeforeItemCreate(Self, Data, ItemClass);\r\nend;\r\n\r\nfunction TJvCustomInspector.DoBeforeItemSelect(const NewItem: TJvCustomInspectorItem): Boolean;\r\nbegin\r\n Result := True;\r\n if Assigned(FBeforeSelection) then\r\n FBeforeSelection(Self, NewItem, Result);\r\nend;\r\n\r\nprocedure TJvCustomInspector.DoDataValueChanged(const Data: TJvCustomInspectorData);\r\nbegin\r\n if Assigned(FOnDataValueChanged) then\r\n FOnDataValueChanged(Self, Data);\r\nend;\r\n\r\nprocedure TJvCustomInspector.DoItemSelected;\r\nbegin\r\n if Assigned(FOnItemSelected) then\r\n FOnItemSelected(Self);\r\nend;\r\n\r\nprocedure TJvCustomInspector.DoItemValueChanged(const Item: TJvCustomInspectorItem);\r\nbegin\r\n if Assigned(FOnItemValueChanged) then\r\n FOnItemValueChanged(Self, Item);\r\nend;\r\n\r\nfunction TJvCustomInspector.DoItemValueChanging(const Item: TJvCustomInspectorItem; var NewValue: string): Boolean;\r\nbegin\r\n Result := True;\r\n if Assigned(FOnItemValueChanging) then\r\n FOnItemValueChanging(Self, Item, NewValue, Result);\r\nend;\r\n\r\nfunction TJvCustomInspector.DoItemValueError(Item: TJvCustomInspectorItem): Boolean;\r\nvar\r\n E: Exception;\r\nbegin\r\n Result := True;\r\n E := ExceptObject as Exception;\r\n if Assigned(FOnItemValueError) then\r\n OnItemValueError(Self, Item, E)\r\n else\r\n Result := False;\r\nend;\r\n\r\nfunction TJvCustomInspector.GetActivePainter: TJvInspectorPainter;\r\nbegin\r\n if Style = isItemPainter then\r\n Result := Painter\r\n else\r\n Result := FStylePainter;\r\nend;\r\n\r\nfunction TJvCustomInspector.GetAfterDataCreate: TInspectorDataEvent;\r\nbegin\r\n Result := FAfterDataCreate;\r\nend;\r\n\r\nfunction TJvCustomInspector.GetAfterItemCreate: TInspectorItemEvent;\r\nbegin\r\n Result := FAfterItemCreate;\r\nend;\r\n\r\nfunction TJvCustomInspector.GetBandFor(const ItemIdx: Integer): Integer;\r\nbegin\r\n Result := Pred(BandStarts.Count);\r\n while (Result > -1) and (Integer(BandStarts[Result]) > ItemIdx) do\r\n Dec(Result);\r\nend;\r\n\r\nfunction TJvCustomInspector.GetBandStarts: TList;\r\nbegin\r\n if FBandStartsNoSB.Count > (ClientWidth div BandWidth) then\r\n Result := FBandStartsSB\r\n else\r\n Result := FBandStartsNoSB;\r\nend;\r\n\r\nfunction TJvCustomInspector.GetBandWidth: Integer;\r\nbegin\r\n Result := FBandWidth;\r\nend;\r\n\r\nfunction TJvCustomInspector.GetBeforeItemCreate: TInspectorItemBeforeCreateEvent;\r\nbegin\r\n Result := FBeforeItemCreate;\r\nend;\r\n\r\nfunction TJvCustomInspector.GetBeforeSelection: TInspectorItemBeforeSelectEvent;\r\nbegin\r\n Result := FBeforeSelection;\r\nend;\r\n\r\nfunction TJvCustomInspector.GetButtonRect(const ItemIndex: Integer): TRect;\r\nvar\r\n Item: TJvCustomInspectorItem;\r\nbegin\r\n // retrieve item\r\n Item := VisibleItems[ItemIndex];\r\n\r\n // retrieve button rectangle\r\n if Item.Expanded or Item.HasViewableItems then\r\n Result := Item.Rects[iprBtnDstRect]\r\n else\r\n Result := Rect(0, 0, 0, 0);\r\nend;\r\n\r\nfunction TJvCustomInspector.GetCollapseButton: TBitmap;\r\nbegin\r\n Result := FCollapseButton;\r\nend;\r\n\r\nfunction TJvCustomInspector.GetDivider: Integer;\r\nbegin\r\n Result := FDivider;\r\nend;\r\n\r\nfunction TJvCustomInspector.GetDividerAbs: Integer;\r\nbegin\r\n if RelativeDivider then\r\n begin\r\n if UseBands then\r\n Result := (FDivider * BandWidth) div 100\r\n else\r\n if HandleAllocated then\r\n Result := (FDivider * ClientWidth) div 100\r\n else\r\n Result := (FDivider * Width) div 100;\r\n end\r\n else\r\n Result := FDivider;\r\nend;\r\n\r\nfunction TJvCustomInspector.GetExpandButton: TBitmap;\r\nbegin\r\n Result := FExpandButton;\r\nend;\r\n\r\nfunction TJvCustomInspector.GetImageHeight: Integer;\r\nbegin\r\n if FImageHeight = 0 then\r\n CalcImageHeight;\r\n Result := FImageHeight;\r\nend;\r\n\r\nfunction TJvCustomInspector.GetItemHeight: Integer;\r\nbegin\r\n Result := FItemHeight;\r\nend;\r\n\r\nfunction TJvCustomInspector.GetLastFullVisible: Integer;\r\nbegin\r\n Result := YToIdx(IdxToY(TopIndex) + Pred(ClientHeight));\r\n if Result < 0 then\r\n Result := Pred(VisibleCount)\r\n else\r\n while (IdxToY(Result) + VisibleItems[Result].Height) > ClientHeight do\r\n Dec(Result);\r\nend;\r\n\r\nfunction TJvCustomInspector.GetLockCount: Integer;\r\nbegin\r\n Result := FLockCount;\r\nend;\r\n\r\nfunction TJvCustomInspector.GetRelativeDivider: Boolean;\r\nbegin\r\n Result := FRelativeDivider;\r\nend;\r\n\r\nfunction TJvCustomInspector.GetRoot: TJvCustomInspectorItem;\r\nbegin\r\n Result := FRoot;\r\nend;\r\n\r\nfunction TJvCustomInspector.GetOnItemSelected: TNotifyEvent;\r\nbegin\r\n Result := FOnItemSelected;\r\nend;\r\n\r\nfunction TJvCustomInspector.GetPainter: TJvInspectorPainter;\r\nbegin\r\n Result := FPainter;\r\nend;\r\n\r\nfunction TJvCustomInspector.GetReadOnly: Boolean;\r\nbegin\r\n Result := FReadOnly;\r\nend;\r\n\r\nfunction TJvCustomInspector.GetSelected: TJvCustomInspectorItem;\r\nbegin\r\n if (SelectedIndex > -1) and (SelectedIndex < VisibleCount) then\r\n Result := VisibleItems[SelectedIndex]\r\n else\r\n Result := nil;\r\nend;\r\n\r\nfunction TJvCustomInspector.GetSelectedIndex: Integer;\r\nbegin\r\n Result := FSelectedIndex;\r\nend;\r\n\r\nfunction TJvCustomInspector.GetTopIndex: Integer;\r\nbegin\r\n Result := FTopIndex;\r\nend;\r\n\r\nfunction TJvCustomInspector.GetUseBands: Boolean;\r\nbegin\r\n Result := FUseBands;\r\nend;\r\n\r\nfunction TJvCustomInspector.GetVisibleCount: Integer;\r\nbegin\r\n Result := FVisibleList.Count;\r\nend;\r\n\r\nfunction TJvCustomInspector.GetVisibleItems(const I: Integer): TJvCustomInspectorItem;\r\nbegin\r\n if (I < 0) or (I >= FVisibleList.Count) then\r\n Result := nil\r\n else\r\n Result := TJvCustomInspectorItem(FVisibleList.Objects[I]);\r\nend;\r\n\r\nfunction TJvCustomInspector.GetWantTabs: Boolean;\r\nbegin\r\n Result := FWantTabs;\r\nend;\r\n\r\nprocedure TJvCustomInspector.HandleBandResize(X: Integer);\r\nvar\r\n BSize: Integer;\r\nbegin\r\n BSize := X div Succ(BandSizingBand);\r\n if BSize < 100 then\r\n BSize := 100;\r\n BandWidth := BSize;\r\nend;\r\n\r\nfunction TJvCustomInspector.IdxToY(const Index: Integer): Integer;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := 0;\r\n for I := 0 to Pred(Index) do\r\n if VisibleItems[I] <> nil then\r\n Inc(Result, VisibleItems[I].Height);\r\nend;\r\n\r\nprocedure TJvCustomInspector.IncPaintGeneration;\r\nbegin\r\n Inc(FPaintGen);\r\nend;\r\n\r\nprocedure TJvCustomInspector.InvalidateHeight;\r\nbegin\r\n FImageHeight := 0;\r\n if not BandSizing then\r\n TopIndex := TopIndex; // Adapt position\r\nend;\r\n\r\nprocedure TJvCustomInspector.InvalidateItem;\r\nbegin\r\n if (LockCount = 0) and HandleAllocated then\r\n UpdateScrollBars\r\n else\r\n if not NeedRebuild then\r\n NeedRedraw := True;\r\nend;\r\n\r\nprocedure TJvCustomInspector.InvalidateList;\r\nbegin\r\n if not (csDestroying in ComponentState) and (LockCount = 0) then\r\n begin\r\n if HandleAllocated then\r\n begin\r\n RebuildVisible;\r\n UpdateScrollBars;\r\n end\r\n else\r\n NeedRebuild := True;\r\n end\r\n else\r\n NeedRebuild := True;\r\nend;\r\n\r\nprocedure TJvCustomInspector.KeyDown(var Key: Word; Shift: TShiftState);\r\nvar\r\n Item: TJvCustomInspectorItem;\r\n IgnoreKey: Boolean;\r\n TmpH: Integer;\r\n TmpIdx: Integer;\r\nbegin\r\n Item := Selected;\r\n if Shift = [] then\r\n begin\r\n IgnoreKey := True;\r\n case Key of\r\n VK_UP:\r\n if SelectedIndex > 0 then\r\n SelectedIndex := SelectedIndex - 1;\r\n VK_DOWN:\r\n if SelectedIndex < Pred(VisibleCount) then\r\n SelectedIndex := SelectedIndex + 1;\r\n VK_LEFT:\r\n begin\r\n if Item is TJvInspectorCustomCompoundItem then\r\n with Item as TJvInspectorCustomCompoundItem do\r\n begin\r\n if SelectedColumnIndex > 0 then\r\n SelectedColumnIndex := SelectedColumnIndex - 1\r\n else\r\n if SelectedIndex > 0 then\r\n SelectedIndex := SelectedIndex - 1;\r\n end\r\n else\r\n if SelectedIndex > 0 then\r\n SelectedIndex := SelectedIndex - 1;\r\n if Item <> Selected then\r\n begin\r\n if Selected is TJvInspectorCustomCompoundItem then\r\n TJvInspectorCustomCompoundItem(Selected).SelectedColumnIndex :=\r\n TJvInspectorCustomCompoundItem(Selected).ColumnCount - 1;\r\n end;\r\n end;\r\n VK_RIGHT:\r\n begin\r\n if Item is TJvInspectorCustomCompoundItem then\r\n with Item as TJvInspectorCustomCompoundItem do\r\n begin\r\n if SelectedColumnIndex < Pred(ColumnCount) then\r\n SelectedColumnIndex := SelectedColumnIndex + 1\r\n else\r\n if SelectedIndex < Pred(VisibleCount) then\r\n SelectedIndex := SelectedIndex + 1;\r\n end\r\n else\r\n if SelectedIndex < Pred(VisibleCount) then\r\n SelectedIndex := SelectedIndex + 1;\r\n if Item <> Selected then\r\n begin\r\n if Selected is TJvInspectorCustomCompoundItem then\r\n TJvInspectorCustomCompoundItem(Selected).SelectedColumnIndex := 0;\r\n end;\r\n end;\r\n VK_PRIOR:\r\n begin\r\n if SelectedIndex > TopIndex then\r\n SelectedIndex := TopIndex\r\n else\r\n if SelectedIndex > 0 then\r\n begin\r\n TmpH := VisibleItems[Pred(SelectedIndex)].Height;\r\n TmpIdx := YToIdx(IdxToY(SelectedIndex) + TmpH - ClientHeight);\r\n if TmpIdx < 0 then\r\n TmpIdx := 0;\r\n SelectedIndex := TmpIdx;\r\n end;\r\n end;\r\n VK_NEXT:\r\n begin\r\n TmpIdx := GetLastFullVisible;\r\n if SelectedIndex < TmpIdx then\r\n SelectedIndex := TmpIdx\r\n else\r\n if SelectedIndex < Pred(VisibleCount) then\r\n begin\r\n TmpH := VisibleItems[SelectedIndex].Height;\r\n TmpIdx := YToIdx(IdxToY(SelectedIndex) + TmpH + ClientHeight);\r\n if TmpIdx < 0 then\r\n TmpIdx := Pred(VisibleCount);\r\n SelectedIndex := TmpIdx;\r\n end;\r\n end;\r\n VK_TAB:\r\n if WantTabs then\r\n begin\r\n if Item is TJvInspectorCustomCompoundItem then\r\n with Item as TJvInspectorCustomCompoundItem do\r\n begin\r\n if SelectedColumnIndex < Pred(ColumnCount) then\r\n SelectedColumnIndex := SelectedColumnIndex + 1\r\n else\r\n if SelectedIndex < Pred(VisibleCount) then\r\n SelectedIndex := SelectedIndex + 1;\r\n end\r\n else\r\n if SelectedIndex < Pred(VisibleCount) then\r\n SelectedIndex := SelectedIndex + 1;\r\n if Item <> Selected then\r\n begin\r\n if Selected is TJvInspectorCustomCompoundItem then\r\n TJvInspectorCustomCompoundItem(Selected).SelectedColumnIndex := 0;\r\n end;\r\n end;\r\n VK_ADD:\r\n if Item.HasViewableItems and not Item.Expanded then\r\n Item.Expanded := True;\r\n VK_SUBTRACT:\r\n if Item.Expanded then\r\n Item.Expanded := False;\r\n else\r\n IgnoreKey := False;\r\n end;\r\n if IgnoreKey then\r\n Key := 0;\r\n end\r\n else\r\n if Shift = [ssShift] then\r\n begin\r\n IgnoreKey := True;\r\n case Key of\r\n VK_TAB:\r\n if WantTabs then\r\n begin\r\n if Item is TJvInspectorCustomCompoundItem then\r\n with Item as TJvInspectorCustomCompoundItem do\r\n begin\r\n if SelectedColumnIndex > 0 then\r\n SelectedColumnIndex := SelectedColumnIndex - 1\r\n else\r\n if SelectedIndex > 0 then\r\n SelectedIndex := SelectedIndex - 1;\r\n end\r\n else\r\n if SelectedIndex > 0 then\r\n SelectedIndex := SelectedIndex - 1;\r\n if Item <> Selected then\r\n begin\r\n if Selected is TJvInspectorCustomCompoundItem then\r\n TJvInspectorCustomCompoundItem(Selected).SelectedColumnIndex :=\r\n TJvInspectorCustomCompoundItem(Selected).ColumnCount - 1;\r\n end;\r\n end;\r\n else\r\n IgnoreKey := False;\r\n end;\r\n if IgnoreKey then\r\n Key := 0;\r\n end\r\n else\r\n if Shift = [ssCtrl] then\r\n begin\r\n IgnoreKey := True;\r\n case Key of\r\n VK_RIGHT:\r\n if Item.HasViewableItems and not Item.Expanded then\r\n Item.Expanded := True;\r\n VK_LEFT:\r\n if Item.Expanded then\r\n Item.Expanded := False;\r\n VK_RETURN:\r\n if Item.HasViewableItems and not Item.Expanded then\r\n Item.Expanded := True\r\n else\r\n if Item.Expanded then\r\n Item.Expanded := False;\r\n else\r\n IgnoreKey := False;\r\n end;\r\n if IgnoreKey then\r\n Key := 0;\r\n end;\r\n inherited KeyDown(Key, Shift);\r\n if (SelectedIndex >= 0) and (SelectedIndex < VisibleCount) then\r\n begin\r\n Item := Selected;\r\n if (Item <> nil) and Item.Editing then\r\n begin\r\n Item.ScrollInView;\r\n Item.EditKeyDown(Self, Key, Shift);\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomInspector.KeyUp(var Key: Word; Shift: TShiftState);\r\nbegin\r\n if ((Shift = []) and ((Key = VK_DOWN) or (Key = VK_UP) or (Key = VK_ADD) or\r\n (Key = VK_SUBTRACT) or (Key = VK_PRIOR) or (Key = VK_NEXT))) or\r\n ((Key = VK_TAB) and WantTabs) then\r\n Key := 0;\r\nend;\r\n\r\nprocedure TJvCustomInspector.MouseDown(Button: TMouseButton; Shift: TShiftState;\r\n X, Y: Integer);\r\nvar\r\n BWidth: Integer;\r\n BandIdx: Integer;\r\n XB: Integer;\r\n ItemIndex: Integer;\r\n ItemRect: TRect;\r\n Item: TJvCustomInspectorItem;\r\nbegin\r\n inherited MouseDown(Button, Shift, X, Y);\r\n if UseBands then\r\n begin\r\n BWidth := BandWidth;\r\n BandIdx := X div BWidth + BandStarts.IndexOf(Pointer(TopIndex));\r\n end\r\n else\r\n begin\r\n BWidth := ClientWidth;\r\n BandIdx := -1;\r\n end;\r\n XB := X mod BWidth;\r\n ItemIndex := CalcItemIndex(X, Y, ItemRect);\r\n if (ItemIndex < VisibleCount) and (ItemIndex >= 0) then\r\n Item := VisibleItems[ItemIndex]\r\n else\r\n Item := nil;\r\n if not Focused and ((Item = nil) or (not Item.Editing)) then\r\n SetFocus\r\n else\r\n if (Item <> nil) and Item.Editing then\r\n Item.SetFocus;\r\n if Button = mbLeft then\r\n begin\r\n // Check divider dragging\r\n if (XB >= Pred(DividerAbs)) and (XB <= Succ(DividerAbs)) then\r\n begin\r\n DraggingDivider := True;\r\n DividerDragBandX := BandIdx * BWidth;\r\n end\r\n // Check row sizing\r\n else\r\n if (Item <> nil) and (Y >= Pred(ItemRect.Bottom)) and\r\n (Y <= Succ(ItemRect.Bottom)) and (Item.RowSizing.SizingFactor <> irsNoReSize) and\r\n Item.RowSizing.Sizable then\r\n begin\r\n RowSizing := True;\r\n RowSizingItem := Item;\r\n end\r\n // Check band sizing\r\n else\r\n if (UseBands and (XB >= BWidth - 3)) and (not UseBands or\r\n (BandIdx < BandStarts.Count)) then\r\n begin\r\n BandSizing := True;\r\n BandSizingBand := BandIdx - BandStarts.IndexOf(Pointer(TopIndex));\r\n end\r\n // Check selecting\r\n else\r\n if (Item <> nil) and (ItemIndex <> SelectedIndex) then\r\n begin\r\n SelectedIndex := ItemIndex;\r\n if ItemIndex >= 0 then\r\n Item := VisibleItems[ItemIndex];\r\n end;\r\n if not DraggingDivider and not RowSizing and not BandSizing then\r\n Selecting := True;\r\n end;\r\n if Button in [mbLeft, mbRight] then\r\n begin\r\n if (Item <> nil) and\r\n ((Item.HasViewableItems and not (iifExpanded in Item.Flags)) or\r\n (iifExpanded in Item.Flags)) then\r\n begin\r\n if PtInRect(Item.Rects[iprBtnDstRect], Point(X, Y)) or\r\n ((ssDouble in Shift) and (Item.IsCategory or (XB < Pred(DividerAbs)))) then\r\n begin\r\n Item.Expanded := not Item.Expanded;\r\n Selecting := False;\r\n if Button = mbRight then\r\n Item.ExpandItems(Item.Expanded);\r\n end;\r\n end;\r\n end;\r\n if Button = mbLeft then\r\n begin\r\n if (Item <> nil) and (PtInRect(Item.Rects[iprNameArea], Point(X, Y)) or\r\n PtInRect(Item.Rects[iprValueArea], Point(X, Y))) then\r\n Item.MouseDown(Button, Shift, X, Y);\r\n end;\r\n\r\n if Assigned(Item) and Assigned(FOnEditorMouseDown) then\r\n FOnEditorMouseDown(Self, Item, Button, Shift, X, Y);\r\nend;\r\n\r\nprocedure TJvCustomInspector.MouseMove(Shift: TShiftState; X, Y: Integer);\r\nvar\r\n BWidth: Integer;\r\n BandIdx: Integer;\r\n XB: Integer;\r\n ItemIndex: Integer;\r\n ItemRect: TRect;\r\n Item: TJvCustomInspectorItem;\r\nbegin\r\n inherited MouseMove(Shift, X, Y);\r\n if UseBands then\r\n begin\r\n BWidth := BandWidth;\r\n BandIdx := X div BWidth + BandStarts.IndexOf(Pointer(TopIndex));\r\n end\r\n else\r\n begin\r\n BWidth := ClientWidth;\r\n BandIdx := -1;\r\n end;\r\n if UseBands and not DraggingDivider then\r\n XB := X mod BWidth\r\n else\r\n if UseBands and DraggingDivider then\r\n XB := X - DividerDragBandX\r\n else\r\n XB := X;\r\n if DraggingDivider then\r\n DividerAbs := XB\r\n else\r\n if BandSizing then\r\n HandleBandResize(X)\r\n else\r\n if (((XB >= Pred(DividerAbs)) and (XB <= Succ(DividerAbs))) or\r\n (UseBands and (XB >= BWidth - 3))) and (not UseBands or\r\n (BandIdx < BandStarts.Count)) then\r\n Cursor := crHSplit\r\n else\r\n begin\r\n Cursor := crDefault;\r\n ItemIndex := CalcItemIndex(X, Y, ItemRect);\r\n if RowSizing then\r\n begin\r\n if RowSizingItem <> nil then\r\n begin\r\n ItemRect := CalcItemRect(RowSizingItem);\r\n RowSizingItem.Height := Y - ItemRect.Top\r\n end;\r\n end\r\n else\r\n if Selecting then\r\n begin\r\n if (ItemIndex < VisibleCount) and (ItemIndex <> SelectedIndex) then\r\n begin\r\n if ItemIndex < 0 then\r\n ItemIndex := SelectedIndex;\r\n SelectedIndex := ItemIndex;\r\n end;\r\n if ItemIndex < VisibleCount then\r\n Item := VisibleItems[ItemIndex]\r\n else\r\n Item := nil;\r\n if Item <> nil then\r\n Item.MouseMove(Shift, X, Y);\r\n end\r\n else\r\n begin\r\n if (ItemIndex < VisibleCount) and (ItemIndex > -1) then\r\n Item := VisibleItems[ItemIndex]\r\n else\r\n Item := nil;\r\n if (Item <> nil) and (Y >= Pred(ItemRect.Bottom)) and\r\n (Y <= Succ(ItemRect.Bottom)) and (Item.RowSizing.SizingFactor <> irsNoReSize) and\r\n Item.RowSizing.Sizable then\r\n Cursor := crVSplit\r\n else\r\n Cursor := crDefault;\r\n end;\r\n end\r\nend;\r\n\r\nprocedure TJvCustomInspector.MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);\r\nvar\r\n ItemIndex: Integer;\r\n ItemRect: TRect;\r\n Item: TJvCustomInspectorItem;\r\nbegin\r\n inherited MouseUp(Button, Shift, X, Y);\r\n ItemIndex := CalcItemIndex(X, Y, ItemRect);\r\n if ItemIndex < VisibleCount then\r\n Item := VisibleItems[ItemIndex]\r\n else\r\n Item := nil;\r\n if Button = mbLeft then\r\n begin\r\n if DraggingDivider then\r\n DraggingDivider := False\r\n else\r\n if RowSizing then\r\n RowSizing := False\r\n else\r\n if BandSizing then\r\n begin\r\n BandSizing := False;\r\n TopIndex := TopIndex; // resync position\r\n end\r\n else\r\n if Selecting then\r\n Selecting := False;\r\n end;\r\n if (Item <> nil) and (PtInRect(Item.Rects[iprNameArea], Point(X, Y)) or\r\n PtInRect(Item.Rects[iprValueArea], Point(X, Y))) then\r\n Item.MouseUp(Button, Shift, X, Y)\r\n else\r\n if (Selected <> nil) and Selected.Tracking and not PtInRect(ClientRect, Point(X, Y)) then\r\n Selected.StopTracking;\r\nend;\r\n\r\nprocedure TJvCustomInspector.Notification(AComponent: TComponent; Operation: TOperation);\r\nbegin\r\n // Mantis 3424: Required for the application not to hang under BDS2006\r\n // (and maybe 2005). Does not have any impact under D7 and lower.\r\n inherited Notification(AComponent, Operation);\r\n\r\n if (Operation = opRemove) then\r\n begin\r\n if (AComponent = Painter) then\r\n FPainter := nil;\r\n if AComponent = FStylePainter then\r\n FStylePainter := nil;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomInspector.NotifySort(const Item: TJvCustomInspectorItem);\r\nbegin\r\n if LockCount = 0 then\r\n Item.Sort\r\n else\r\n if (Item <> nil) and (SortNotificationList.IndexOf(Item) = -1) then\r\n SortNotificationList.Add(Item);\r\nend;\r\n\r\nprocedure TJvCustomInspector.Paint;\r\nvar\r\n PaintRect: TRect;\r\nbegin\r\n PaintRect := ClientRect;\r\n\r\n\r\n if ActivePainter <> nil then\r\n begin\r\n if NeedRebuild then\r\n InvalidateList;\r\n IncPaintGeneration;\r\n ActivePainter.Setup(Canvas);\r\n ActivePainter.Paint;\r\n end\r\n else\r\n begin\r\n Canvas.Brush.Color := Color;\r\n Canvas.FillRect(PaintRect);\r\n if csDesigning in Self.ComponentState then\r\n Canvas.TextOut(10, 10, Name + ':' + ClassName);\r\n end;\r\nend;\r\n\r\nfunction ListCompare(List: TStringList; Index1, Index2: Integer): Integer;\r\nbegin\r\n Result := AnsiCompareText(List[Index1], List[Index2]);\r\nend;\r\n\r\nprocedure TJvCustomInspector.RebuildVisible;\r\nvar\r\n OldSel: TJvCustomInspectorItem;\r\n Item: TJvCustomInspectorItem;\r\n ItemStack: TStack;\r\nbegin\r\n FImageHeight := 0;\r\n OldSel := Selected;\r\n FVisibleList.Clear;\r\n Item := Root;\r\n ItemStack := TStack.Create;\r\n try\r\n while Item <> nil do\r\n begin\r\n if not Item.Hidden then\r\n FVisibleList.AddObject(Item.GetSortName, Item);\r\n if Item.Visible and Item.Expanded and (Item.Count > 0) then\r\n begin\r\n ItemStack.Push(Item);\r\n Item := Item.Items[0];\r\n end\r\n else\r\n begin\r\n Item := Item.GetNextSibling;\r\n while (Item = nil) and (ItemStack.Count > 0) do\r\n begin\r\n Item := TJvCustomInspectorItem(ItemStack.Pop);\r\n Item := Item.GetNextSibling;\r\n end;\r\n end;\r\n end;\r\n finally\r\n ItemStack.Free;\r\n end;\r\n FVisibleList.CustomSort(ListCompare);\r\n if OldSel <> nil then\r\n SelectedIndex := FVisibleList.IndexOfObject(OldSel);\r\n CalcImageHeight;\r\n NeedRebuild := False;\r\nend;\r\n\r\nprocedure TJvCustomInspector.RemoveNotifySort(const Item: TJvCustomInspectorItem);\r\nbegin\r\n SortNotificationList.Remove(Item);\r\nend;\r\n\r\nprocedure TJvCustomInspector.RemoveVisible(const Item: TJvCustomInspectorItem);\r\nvar\r\n Idx: Integer;\r\nbegin\r\n Idx := FVisibleList.IndexOfObject(Item);\r\n if Idx > -1 then\r\n begin\r\n FVisibleList.Delete(Idx);\r\n if SelectedIndex >= Idx then\r\n SelectedIndex := SelectedIndex - 1;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomInspector.BoundsChanged;\r\nbegin\r\n inherited BoundsChanged;\r\n if csCreating in ControlState then\r\n Exit;\r\n if not BandSizing then\r\n begin\r\n FImageHeight := 0; // Force recalculation of bands\r\n if (ImageHeight <= ClientHeight) and UseBands then\r\n TopIndex := 0\r\n else\r\n TopIndex := TopIndex;\r\n end;\r\n if HandleAllocated then\r\n UpdateScrollBars;\r\nend;\r\n\r\nfunction TJvCustomInspector.ScrollFactorV: Extended;\r\nbegin\r\n if ClientHeight > 32767 then\r\n Result := ClientHeight / 32767.0\r\n else\r\n Result := 1.0;\r\nend;\r\n\r\nprocedure TJvCustomInspector.SetAfterDataCreate(const Value: TInspectorDataEvent);\r\nbegin\r\n FAfterDataCreate := Value;\r\nend;\r\n\r\nprocedure TJvCustomInspector.SetAfterItemCreate(const Value: TInspectorItemEvent);\r\nbegin\r\n FAfterItemCreate := Value;\r\nend;\r\n\r\nprocedure TJvCustomInspector.SetBandWidth(Value: Integer);\r\nbegin\r\n if Value <> BandWidth then\r\n begin\r\n FBandWidth := Value;\r\n if not RelativeDivider then\r\n DividerAbs := DividerAbs;\r\n if HandleAllocated then\r\n begin\r\n CalcImageHeight;\r\n UpdateScrollBars;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomInspector.SetBeforeItemCreate(const Value: TInspectorItemBeforeCreateEvent);\r\nbegin\r\n FBeforeItemCreate := Value;\r\nend;\r\n\r\nprocedure TJvCustomInspector.SetBeforeSelection(const Value: TInspectorItemBeforeSelectEvent);\r\nbegin\r\n FBeforeSelection := Value;\r\nend;\r\n\r\nprocedure TJvCustomInspector.SetCollapseButton(const Value: TBitmap);\r\nbegin\r\n if Value <> FCollapseButton then\r\n begin\r\n FCollapseButton.Assign(Value);\r\n if HandleAllocated then\r\n UpdateScrollBars;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomInspector.SetDivider(Value: Integer);\r\nbegin\r\n if FDivider <> Value then\r\n if RelativeDivider then\r\n begin\r\n if UseBands then\r\n DividerAbs := (Value * BandWidth) div 100\r\n else\r\n if HandleAllocated then\r\n DividerAbs := (Value * ClientWidth) div 100\r\n else\r\n DividerAbs := (Value * Width) div 100;\r\n end\r\n else\r\n DividerAbs := Value;\r\nend;\r\n\r\nprocedure TJvCustomInspector.SetDividerAbs(Value: Integer);\r\nvar\r\n W: Integer;\r\nbegin\r\n if UseBands then\r\n W := BandWidth\r\n else\r\n if HandleAllocated then\r\n W := ClientWidth\r\n else\r\n W := Width;\r\n if Value > (W - 2 * ItemHeight) then\r\n Value := W - 2 * ItemHeight;\r\n if Value < (2 * ItemHeight) then\r\n Value := 2 * ItemHeight;\r\n if RelativeDivider then\r\n begin\r\n if UseBands then\r\n FDivider := (Value * 100) div BandWidth\r\n else\r\n if HandleAllocated then\r\n FDivider := (Value * 100) div ClientWidth\r\n else\r\n FDivider := (Value * 100) div Width;\r\n end\r\n else\r\n FDivider := Value;\r\n if HandleAllocated then\r\n UpdateScrollBars;\r\nend;\r\n\r\nprocedure TJvCustomInspector.SetExpandButton(const Value: TBitmap);\r\nbegin\r\n if Value <> FExpandButton then\r\n begin\r\n FExpandButton.Assign(Value);\r\n if HandleAllocated then\r\n UpdateScrollBars;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomInspector.SetItemHeight(Value: Integer);\r\nbegin\r\n if Value <> ItemHeight then\r\n begin\r\n FItemHeight := Value;\r\n if HandleAllocated then\r\n UpdateScrollBars;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomInspector.SetLockCount(const Value: Integer);\r\nbegin\r\n if Value <> LockCount then\r\n begin\r\n FLockCount := Value;\r\n if LockCount = 0 then\r\n if NeedRebuild then\r\n InvalidateList\r\n else\r\n InvalidateItem;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomInspector.SetOnItemSelected(const Value: TNotifyEvent);\r\nbegin\r\n FOnItemSelected := Value;\r\nend;\r\n\r\nprocedure TJvCustomInspector.SetPainter(const Value: TJvInspectorPainter);\r\nbegin\r\n if Value <> Painter then\r\n begin\r\n if Value <> nil then\r\n if (Value.Inspector <> nil) and (Value.Inspector <> Self) then\r\n raise EJvInspector.CreateRes(@RsEJvInspPaintOnlyUsedOnce);\r\n\r\n if Painter <> nil then\r\n Painter.SetInspector(nil);\r\n\r\n ReplaceComponentReference(Self, Value, TComponent(FPainter));\r\n\r\n if Painter <> nil then\r\n begin\r\n Style := isItemPainter;\r\n Painter.SetInspector(Self);\r\n\r\n if HandleAllocated then\r\n UpdateScrollBars;\r\n end\r\n else\r\n begin\r\n if not FSettingStyle then\r\n Style := isBorland;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomInspector.SetReadOnly(const Value: Boolean);\r\nbegin\r\n FReadOnly := Value;\r\nend;\r\n\r\nprocedure TJvCustomInspector.SetRelativeDivider(Value: Boolean);\r\nvar\r\n OrgPos: Integer;\r\nbegin\r\n if Value <> RelativeDivider then\r\n begin\r\n OrgPos := DividerAbs;\r\n FRelativeDivider := Value;\r\n DividerAbs := OrgPos;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomInspector.SetSelected(const Value: TJvCustomInspectorItem);\r\nvar\r\n Idx: Integer;\r\nbegin\r\n Idx := FVisibleList.IndexOfObject(Value);\r\n if Idx > -1 then\r\n SelectedIndex := Idx;\r\nend;\r\n\r\nprocedure TJvCustomInspector.SetSelectedIndex(Value: Integer);\r\nvar\r\n NewItem: TJvCustomInspectorItem;\r\nbegin\r\n if Value >= VisibleCount then\r\n Value := Pred(VisibleCount);\r\n if Value < -1 then\r\n Value := -1;\r\n if Value <> SelectedIndex then\r\n begin\r\n if Value > -1 then\r\n NewItem := VisibleItems[Value]\r\n else\r\n NewItem := nil;\r\n\r\n if not (csDestroying in ComponentState) then\r\n // bugfix WAP. Why repaint the screen when the component is going away anyway.\r\n if DoBeforeItemSelect(NewItem) then\r\n begin\r\n if Selected <> nil then\r\n Selected.DoneEdit(False);\r\n FSelectedIndex := Value;\r\n if Selected <> nil then\r\n begin\r\n Selected.ScrollInView;\r\n Selected.InitEdit;\r\n end;\r\n DoItemSelected;\r\n InvalidateItem;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomInspector.SetStyle(const Value: TJvInspectorStyle);\r\nbegin\r\n if FStyle <> Value then\r\n begin\r\n FSettingStyle := True;\r\n try\r\n // Prevent changing the style if getting isItemPainter without a Painter\r\n // (Mantis 3847)\r\n if (Value <> isItemPainter) or (Painter <> nil) then\r\n FStyle := Value;\r\n\r\n // Always remove the current painter\r\n if FStylePainter <> nil then\r\n begin\r\n FStylePainter.SetInspector(nil);\r\n FStylePainter.Free;\r\n FStylePainter := nil;\r\n end;\r\n\r\n if (Style <> isItemPainter) or (Painter = nil) then\r\n begin\r\n Painter := nil;\r\n\r\n FStylePainter := CreatePainterFromStyle(Value);\r\n FStylePainter.SetInspector(Self);\r\n\r\n if HandleAllocated then\r\n UpdateScrollBars;\r\n end;\r\n finally\r\n FSettingStyle := False;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomInspector.SetTopIndex(Value: Integer);\r\nvar\r\n MaxIdx: Integer;\r\nbegin\r\n if UseBands then\r\n begin\r\n MaxIdx := BandStarts.Count - (ClientWidth div BandWidth);\r\n if MaxIdx < 0 then\r\n MaxIdx := 0;\r\n if MaxIdx >= BandStarts.Count then\r\n MaxIdx := BandStarts.Count - 1;\r\n if MaxIdx <> -1 then\r\n MaxIdx := Integer(BandStarts[MaxIdx]);\r\n end\r\n else\r\n MaxIdx := Succ(YToIdx(ImageHeight - ClientHeight));\r\n if MaxIdx < 0 then\r\n MaxIdx := 0;\r\n if Value > MaxIdx then\r\n Value := MaxIdx;\r\n if Value < 0 then\r\n Value := 0;\r\n if UseBands and (BandStarts.IndexOf(Pointer(Value)) > -1) then\r\n begin\r\n MaxIdx := Pred(BandStarts.Count);\r\n while (MaxIdx > -1) and (Integer(BandStarts[MaxIdx]) > Value) do\r\n Dec(MaxIdx);\r\n if MaxIdx <= -1 then\r\n raise EJvInspector.CreateRes(@RsEJvAssertSetTopIndex);\r\n Value := Integer(BandStarts[MaxIdx]);\r\n end;\r\n if TopIndex <> Value then\r\n begin\r\n FTopIndex := Value;\r\n if HandleAllocated then\r\n UpdateScrollBars;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomInspector.SetUseBands(Value: Boolean);\r\nbegin\r\n if UseBands <> Value then\r\n begin\r\n FUseBands := Value;\r\n if not RelativeDivider then\r\n DividerAbs := DividerAbs;\r\n FImageHeight := 0;\r\n if HandleAllocated then\r\n UpdateScrollBars;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomInspector.SetWantTabs(Value: Boolean);\r\nbegin\r\n if Value <> WantTabs then\r\n begin\r\n FWantTabs := Value;\r\n RecreateWnd;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomInspector.UpdateScrollBars;\r\nvar\r\n DrawHeight: Integer;\r\n ClHeight: Integer;\r\n ScFactor: Extended;\r\n ScrollInfo: TScrollInfo;\r\n BCount: Integer;\r\n BPerPage: Integer;\r\n ShowVertSB: Boolean;\r\n ShowHorzSB: Boolean;\r\nbegin\r\n if csDestroying in ComponentState then\r\n Exit;\r\n\r\n if not HandleAllocated then\r\n Exit;\r\n\r\n if not UseBands then\r\n begin\r\n ShowScrollBars(SB_HORZ, False);\r\n // Cache the image height, client height and scroll factor\r\n DrawHeight := ImageHeight;\r\n ClHeight := ClientHeight;\r\n ScFactor := ScrollFactorV;\r\n { Needed to redisplay the scrollbar after it's hidden in the CloseUp method\r\n of an enumerated item's combobox }\r\n ShowVertSB := Round((DrawHeight) / ScFactor) >= Round(ClHeight / ScFactor);\r\n if ShowVertSB then\r\n begin\r\n with ScrollInfo do\r\n begin\r\n cbSize := SizeOf(ScrollInfo);\r\n fMask := SIF_ALL;\r\n nMin := 0;\r\n nMax := Round((IdxToY(Succ(YToIdx(ImageHeight - ClientHeight))) + ClientHeight) / ScFactor);\r\n nPage := Round(ClHeight / ScFactor);\r\n nPos := Round(IdxToY(TopIndex) / ScFactor);\r\n nTrackPos := 0;\r\n end;\r\n SetScrollInfo(Handle, SB_VERT, ScrollInfo, True);\r\n end;\r\n ShowScrollBars(SB_VERT, ShowVertSB);\r\n end\r\n else\r\n begin\r\n ShowScrollBars(SB_VERT, False);\r\n { Needed to redisplay the scrollbar after it's hidden in the CloseUp method\r\n of an enumerated item's combobox }\r\n BCount := BandStarts.Count;\r\n BPerPage := ClientWidth div BandWidth;\r\n ShowHorzSB := BCount > BPerPage;\r\n if ShowHorzSB then\r\n begin\r\n with ScrollInfo do\r\n begin\r\n cbSize := SizeOf(ScrollInfo);\r\n fMask := SIF_ALL;\r\n nMin := 0;\r\n nMax := BCount - 1;\r\n nPage := BPerPage;\r\n nPos := GetBandFor(TopIndex);\r\n nTrackPos := 0;\r\n end;\r\n SetScrollInfo(Handle, SB_HORZ, ScrollInfo, True);\r\n end;\r\n ShowScrollBars(SB_HORZ, ShowHorzSB);\r\n end;\r\n Invalidate;\r\nend;\r\n\r\nfunction TJvCustomInspector.ViewHeight: Integer;\r\nbegin\r\n Result := RectHeight(ViewRect);\r\nend;\r\n\r\nfunction TJvCustomInspector.ViewRect: TRect;\r\nbegin\r\n Result := ClientRect;\r\nend;\r\n\r\nfunction TJvCustomInspector.ViewWidth: Integer;\r\nbegin\r\n Result := RectWidth(ViewRect);\r\nend;\r\n\r\nprocedure TJvCustomInspector.GetDlgCode(var Code: TDlgCodes);\r\nbegin\r\n Code := [dcWantArrows];\r\n if WantTabs then\r\n Include(Code, dcWantTab);\r\nend;\r\n\r\nprocedure TJvCustomInspector.FocusSet(PrevWnd: THandle);\r\nbegin\r\n inherited FocusSet(PrevWnd);\r\n if (Selected <> nil) and not Selected.EditCtrlDestroying then\r\n Selected.SetFocus;\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvCustomInspector.FocusKilled(NextWnd: THandle);\r\nbegin\r\n inherited FocusKilled(NextWnd);\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvCustomInspector.WMHScroll(var Msg: TWMScroll);\r\nvar\r\n CurBand: Integer;\r\n Delta: Integer;\r\nbegin\r\n CurBand := BandStarts.IndexOf(Pointer(TopIndex));\r\n case Msg.ScrollCode of\r\n SB_BOTTOM:\r\n Delta := BandStarts.Count - 1 - CurBand;\r\n SB_ENDSCROLL:\r\n Delta := 0;\r\n SB_LINEDOWN:\r\n Delta := 1;\r\n SB_LINEUP:\r\n Delta := -1;\r\n SB_PAGEDOWN:\r\n Delta := ClientWidth div BandWidth;\r\n SB_PAGEUP:\r\n Delta := -ClientWidth div BandWidth;\r\n SB_THUMBPOSITION:\r\n Delta := Msg.Pos - CurBand;\r\n SB_THUMBTRACK:\r\n Delta := Msg.Pos - CurBand;\r\n SB_TOP:\r\n Delta := -CurBand;\r\n else\r\n Delta := 0;\r\n end;\r\n CurBand := CurBand + Delta;\r\n if CurBand < 0 then\r\n CurBand := 0;\r\n if CurBand >= BandStarts.Count then\r\n CurBand := BandStarts.Count - 1;\r\n TopIndex := Integer(BandStarts[CurBand]);\r\nend;\r\n\r\nprocedure TJvCustomInspector.WMVScroll(var Msg: TWMScroll);\r\nvar\r\n Delta: Integer;\r\n ScFactor: Extended;\r\nbegin\r\n Delta := 0;\r\n ScFactor := ScrollFactorV;\r\n case Msg.ScrollCode of\r\n SB_BOTTOM:\r\n Delta := ImageHeight - ClientHeight - IdxToY(TopIndex);\r\n SB_ENDSCROLL:\r\n Delta := 0;\r\n SB_LINEDOWN:\r\n TopIndex := TopIndex + 1;\r\n SB_LINEUP:\r\n TopIndex := TopIndex - 1;\r\n SB_PAGEDOWN:\r\n Delta := ClientHeight;\r\n SB_PAGEUP:\r\n Delta := -ClientHeight;\r\n SB_THUMBPOSITION:\r\n Delta := Round(Msg.Pos * ScFactor) - IdxToY(TopIndex);\r\n SB_THUMBTRACK:\r\n Delta := Round(Msg.Pos * ScFactor) - IdxToY(TopIndex);\r\n SB_TOP:\r\n Delta := -IdxToY(TopIndex);\r\n else\r\n Delta := 0;\r\n end;\r\n if Delta <> 0 then\r\n TopIndex := YToIdx(IdxToY(TopIndex) + Delta);\r\nend;\r\n\r\nfunction TJvCustomInspector.YToIdx(const Y: Integer): Integer;\r\nvar\r\n CurY: Integer;\r\nbegin\r\n Result := 0;\r\n CurY := 0;\r\n while (Result < VisibleCount) and (Y > (CurY + VisibleItems[Result].Height)) do\r\n begin\r\n Inc(CurY, VisibleItems[Result].Height);\r\n Inc(Result);\r\n end;\r\n if Result >= VisibleCount then\r\n Result := -1;\r\nend;\r\n\r\nprocedure TJvCustomInspector.BeforeDestruction;\r\nbegin\r\n inherited BeforeDestruction;\r\n if not (csDesigning in ComponentState) then\r\n GlobalInspReg.UnRegInspector(Self);\r\n Painter := nil;\r\n FRoot.Free;\r\n FBandStartsSB.Free;\r\n FBandStartsNoSB.Free;\r\n FSortNotificationList.Free;\r\n FVisibleList.Free;\r\n FExpandButton.Free;\r\n FCollapseButton.Free;\r\n FStylePainter.Free;\r\nend;\r\n\r\nfunction TJvCustomInspector.BeginUpdate: Integer;\r\nbegin\r\n Inc(FLockCount);\r\n Result := FLockCount;\r\nend;\r\n\r\nfunction TJvCustomInspector.EndUpdate: Integer;\r\nvar\r\n I: Integer;\r\nbegin\r\n if LockCount > 0 then\r\n Dec(FLockCount);\r\n Result := LockCount;\r\n if Result = 0 then\r\n begin\r\n I := 0;\r\n FLockCount := -1; // Keep InvalidateSort from calling InvalidateList\r\n try\r\n while I < SortNotificationList.Count do\r\n begin\r\n TJvCustomInspectorItem(SortNotificationList[I]).InvalidateSort;\r\n Inc(I);\r\n end;\r\n finally\r\n FLockCount := 0;\r\n if SortNotificationList.Count > 0 then\r\n NeedRebuild := True;\r\n if NeedRebuild then\r\n InvalidateList\r\n else\r\n InvalidateItem;\r\n SortNotificationList.Clear;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJvCustomInspector.Focused: Boolean;\r\nbegin\r\n Result := inherited Focused or ((Selected <> nil) and Selected.EditFocused);\r\nend;\r\n\r\nfunction TJvCustomInspector.FocusedItem: TJvCustomInspectorItem;\r\nbegin\r\n Result := Selected;\r\n if (Result <> nil) and (Result is TJvInspectorCustomCompoundItem) then\r\n begin\r\n with (Result as TJvInspectorCustomCompoundItem) do\r\n if SelectedColumn <> nil then\r\n Result := SelectedColumn.Item;\r\n end;\r\nend;\r\n\r\nfunction TJvCustomInspector.VisibleIndex(\r\n const AItem: TJvCustomInspectorItem): Integer;\r\nbegin\r\n Result := FVisibleList.IndexOfObject(AItem);\r\nend;\r\n\r\nprocedure TJvCustomInspector.RefreshValues;\r\nbegin\r\n if (Selected <> nil) and Selected.Editing then\r\n begin\r\n if (Selected.EditCtrl = nil) or (Selected.DisplayValue <> Selected.EditCtrl.Text) then\r\n begin\r\n Selected.DoneEdit(True);\r\n Selected.InitEdit;\r\n end;\r\n end;\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvCustomInspector.SaveValues;\r\nbegin\r\n if (Selected <> nil) and Selected.Editing then\r\n begin\r\n Selected.DoneEdit(False);\r\n Selected.InitEdit;\r\n end;\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvCustomInspector.SetInspectObject(const Value: TObject);\r\nbegin\r\n Root.Clear;\r\n if Value <> nil then\r\n TJvInspectorPropData.New(Root, Value);\r\n FInspectObject := Value;\r\nend;\r\n\r\nprocedure TJvCustomInspector.AddComponent(Instance: TObject; const CategoryName: string;\r\n Expanded: Boolean);\r\nvar\r\n InspCat: TJvCustomInspectorItem;\r\nbegin\r\n BeginUpdate;\r\n if Instance <> nil then\r\n begin\r\n if CategoryName <> '' then\r\n begin\r\n InspCat := TJvInspectorCustomCategoryItem.Create(Self.Root, nil);\r\n InspCat.DisplayName := CategoryName;\r\n end\r\n else\r\n InspCat := Root;\r\n TJvInspectorPropData.New(InspCat, Instance);\r\n if InspCat <> Root then\r\n InspCat.Expanded := Expanded;\r\n end;\r\n EndUpdate;\r\nend;\r\n\r\nprocedure TJvCustomInspector.Clear;\r\nbegin\r\n BeginUpdate;\r\n SelectedIndex := -1;\r\n Root.Clear;\r\n EndUpdate;\r\nend;\r\n\r\nfunction TJvCustomInspector.DoMouseWheel(Shift: TShiftState; WheelDelta: Integer; MousePos: TPoint): Boolean;\r\nvar\r\n Count: Integer;\r\n Index: Integer;\r\n LbPos: TPoint;\r\n MinPos, MaxPos: Integer;\r\nbegin\r\n if (Selected <> nil) and Selected.DroppedDown then\r\n begin\r\n // If Selected.ListBox gets the WM_MOUSEWHEEL we would run into an infinite recursion\r\n if not FMouseWheelRecursion then\r\n begin\r\n FMouseWheelRecursion := True;\r\n try\r\n LbPos := Selected.ListBox.ScreenToClient(ClientToScreen(MousePos));\r\n Selected.ListBox.Perform(WM_MOUSEWHEEL, WheelDelta shl 16, MakeLong(LbPos.X, LbPos.Y));\r\n finally\r\n FMouseWheelRecursion := False;\r\n end;\r\n end;\r\n end\r\n else\r\n begin\r\n GetScrollRange(Handle, SB_VERT, MinPos, MaxPos);\r\n if MinPos <> MaxPos then // no scroll bar enabled\r\n begin\r\n Count := -WheelDelta div (120 div 5); // 5 items per scroll\r\n Index := TopIndex + Count;\r\n if Index < 0 then\r\n Index := 0;\r\n TopIndex := Index;\r\n end;\r\n end;\r\n Result := True;\r\nend;\r\n\r\nprocedure TJvCustomInspector.ShowScrollBars(Bar: Integer; Visible: Boolean);\r\nbegin\r\n ShowScrollBar(Handle, Bar, Visible);\r\nend;\r\n\r\n//=== { TJvInspectorPainter } ================================================\r\n\r\nconstructor TJvInspectorPainter.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FInspector := nil;\r\n FInternalCollapseButton := TBitmap.Create;\r\n FInternalExpandButton := TBitmap.Create;\r\n\r\n FCategoryFont := TFont.Create;\r\n FCategoryFont.OnChange := FontChange;\r\n FNameFont := TFont.Create;\r\n FNameFont.OnChange := FontChange;\r\n FValueFont := TFont.Create;\r\n FValueFont.OnChange := FontChange;\r\n FSelectedFont := TFont.Create;\r\n FSelectedFont.OnChange := FontChange;\r\n\r\n Initializing := True;\r\n try\r\n InitializeColors;\r\n finally\r\n Initializing := False;\r\n end;\r\n with FInternalCollapseButton do\r\n begin\r\n Width := 9;\r\n Height := 9;\r\n Canvas.Brush.Color := clWhite;\r\n Canvas.Pen.Color := clBlack;\r\n Canvas.Rectangle(0, 0, 9, 9);\r\n Canvas.MoveTo(2, 4);\r\n Canvas.LineTo(7, 4);\r\n end;\r\n with FInternalExpandButton do\r\n begin\r\n Width := 9;\r\n Height := 9;\r\n Canvas.Brush.Color := clWhite;\r\n Canvas.Pen.Color := clBlack;\r\n Canvas.Rectangle(0, 0, 9, 9);\r\n Canvas.MoveTo(2, 4);\r\n Canvas.LineTo(7, 4);\r\n Canvas.MoveTo(4, 2);\r\n Canvas.LineTo(4, 7);\r\n end;\r\nend;\r\n\r\nprocedure TJvInspectorPainter.DefineProperties(Filer: TFiler);\r\nbegin\r\n // Here to allow transparent reading of old DFMs following changes\r\n // introduced for Mantis 1715\r\n Filer.DefineProperty('CategoryTextColor', ReadCategoryTextColor, nil, False);\r\n Filer.DefineProperty('NameColor', ReadNameColor, nil, False);\r\n Filer.DefineProperty('ValueColor', ReadValueColor, nil, False);\r\n Filer.DefineProperty('SelectedTextColor', ReadSelectedTextColor, nil, False);\r\n Filer.DefineProperty('HideSelectTextColor', ReadHideSelectTextColor, nil, False);\r\n\r\n inherited DefineProperties(Filer);\r\nend;\r\n\r\ndestructor TJvInspectorPainter.Destroy;\r\nbegin\r\n FInternalCollapseButton.Free;\r\n FInternalExpandButton.Free;\r\n FCategoryFont.Free;\r\n FNameFont.Free;\r\n FValueFont.Free;\r\n FSelectedFont.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvInspectorPainter.ApplyNameFont;\r\nbegin\r\n if Assigned(Item) and Item.IsCategory then\r\n Canvas.Font := CategoryFont\r\n else\r\n Canvas.Font := NameFont;\r\nend;\r\n\r\nprocedure TJvInspectorPainter.ApplyValueFont;\r\nbegin\r\n Canvas.Font := ValueFont;\r\nend;\r\n\r\nprocedure TJvInspectorPainter.CalcButtonBasedRects;\r\nbegin\r\nend;\r\n\r\nprocedure TJvInspectorPainter.CalcEditBasedRects;\r\nbegin\r\nend;\r\n\r\nprocedure TJvInspectorPainter.CalcNameBasedRects;\r\nbegin\r\nend;\r\n\r\nprocedure TJvInspectorPainter.CalcValueBasedRects;\r\nbegin\r\nend;\r\n\r\nprocedure TJvInspectorPainter.FontChange(Sender: TObject);\r\nbegin\r\n if not Initializing and not Loading and Assigned(Inspector) then\r\n Inspector.Invalidate;\r\nend;\r\n\r\nfunction TJvInspectorPainter.DividerWidth: Integer;\r\nbegin\r\n Result := 1;\r\nend;\r\n\r\nprocedure TJvInspectorPainter.DoPaint;\r\nbegin\r\nend;\r\n\r\nfunction TJvInspectorPainter.GetBackgroundColor: TColor;\r\nbegin\r\n Result := FBackgroundColor;\r\nend;\r\n\r\nfunction TJvInspectorPainter.GetCategoryColor: TColor;\r\nbegin\r\n Result := FCategoryColor;\r\nend;\r\n\r\nfunction TJvInspectorPainter.GetCategoryFont: TFont;\r\nbegin\r\n Result := FCategoryFont;\r\nend;\r\n\r\nfunction TJvInspectorPainter.GetCollapseImage: TBitmap;\r\nbegin\r\n if not Inspector.CollapseButton.Empty then\r\n Result := Inspector.CollapseButton\r\n else\r\n Result := FInternalCollapseButton;\r\nend;\r\n\r\nfunction TJvInspectorPainter.GetDividerColor: TColor;\r\nbegin\r\n Result := FDividerColor;\r\nend;\r\n\r\nfunction TJvInspectorPainter.GetExpandImage: TBitmap;\r\nbegin\r\n if not Inspector.ExpandButton.Empty then\r\n Result := Inspector.ExpandButton\r\n else\r\n Result := FInternalExpandButton;\r\nend;\r\n\r\nfunction TJvInspectorPainter.GetHideSelectColor: TColor;\r\nbegin\r\n Result := SelectedColor;\r\nend;\r\n\r\nfunction TJvInspectorPainter.GetHideSelectFont: TFont;\r\nbegin\r\n Result := SelectedFont;\r\nend;\r\n\r\nfunction TJvInspectorPainter.GetNameFont: TFont;\r\nbegin\r\n Result := FNameFont;\r\nend;\r\n\r\nfunction TJvInspectorPainter.GetNameHeight(const AItem: TJvCustomInspectorItem): Integer;\r\nvar\r\n TmpCanvas: TCanvas;\r\nbegin\r\n TmpCanvas := Canvas;\r\n try\r\n Canvas := TControlCanvas.Create;\r\n TControlCanvas(Canvas).Control := Inspector;\r\n ApplyNameFont;\r\n Result := CanvasMaxTextHeight(Canvas);\r\n finally\r\n if TmpCanvas <> Canvas then\r\n Canvas.Free;\r\n Canvas := TmpCanvas;\r\n end;\r\nend;\r\n\r\nfunction TJvInspectorPainter.GetRects(const Index: TInspectorPaintRect): TRect;\r\nbegin\r\n if Item <> nil then\r\n Result := Item.Rects[Index]\r\n else\r\n Result := Rect(0, 0, 0, 0);\r\nend;\r\n\r\nfunction TJvInspectorPainter.GetSelectedColor: TColor;\r\nbegin\r\n Result := FSelectedColor;\r\nend;\r\n\r\nfunction TJvInspectorPainter.GetSelectedFont: TFont;\r\nbegin\r\n Result := FSelectedFont;\r\nend;\r\n\r\nfunction TJvInspectorPainter.GetDrawNameEndEllipsis: Boolean;\r\nbegin\r\n Result := FDrawNameEndEllipsis;\r\nend;\r\n\r\nfunction TJvInspectorPainter.GetValueFont: TFont;\r\nbegin\r\n Result := FValueFont;\r\nend;\r\n\r\nfunction TJvInspectorPainter.GetValueHeight(const AItem: TJvCustomInspectorItem): Integer;\r\nvar\r\n TmpCanvas: TCanvas;\r\nbegin\r\n TmpCanvas := Canvas;\r\n try\r\n Canvas := TControlCanvas.Create;\r\n TControlCanvas(Canvas).Control := Inspector;\r\n ApplyValueFont;\r\n Result := CanvasMaxTextHeight(Canvas);\r\n finally\r\n if TmpCanvas <> Canvas then\r\n Canvas.Free;\r\n Canvas := TmpCanvas;\r\n end;\r\nend;\r\n\r\nprocedure TJvInspectorPainter.HideEditor;\r\nbegin\r\n Inspector.Selected.Rects[iprEditValue] := Rect(0, 0, 0, 0);\r\nend;\r\n\r\nprocedure TJvInspectorPainter.InitializeColors;\r\nbegin\r\n SetDefaultProp(Self, ['BackgroundColor', 'DividerColor', 'CategoryColor', 'SelectedColor']);\r\nend;\r\n\r\nfunction TJvInspectorPainter.Loading: Boolean;\r\nbegin\r\n Result := csLoading in ComponentState;\r\nend;\r\n\r\nprocedure TJvInspectorPainter.Paint;\r\nvar\r\n SelItemVisible: Boolean;\r\n Rect: TRect;\r\n ItemIdx: Integer;\r\n MaxItemIdx: Integer;\r\n BandIdx: Integer;\r\n MaxBandItemIdx: Integer;\r\nbegin\r\n SelItemVisible := False;\r\n Rect := Inspector.ViewRect;\r\n Canvas.FillRect(Rect);\r\n ItemIdx := Inspector.TopIndex;\r\n MaxItemIdx := Inspector.VisibleCount;\r\n if not Inspector.UseBands then\r\n begin\r\n // Loop through the visible list\r\n while (Rect.Top < Rect.Bottom) and (ItemIdx < MaxItemIdx) do\r\n begin\r\n SelItemVisible := SelItemVisible or (ItemIdx = Inspector.SelectedIndex);\r\n PaintItem(Rect, ItemIdx);\r\n Inc(ItemIdx);\r\n end;\r\n end\r\n else // if UseBands\r\n begin\r\n BandIdx := Inspector.BandStarts.IndexOf(Pointer(ItemIdx));\r\n Rect.Right := Rect.Left + Inspector.BandWidth - 4;\r\n while (ItemIdx < MaxItemIdx) and (Rect.Left < Inspector.ClientWidth) do\r\n begin\r\n Inc(BandIdx);\r\n if BandIdx < Inspector.BandStarts.Count then\r\n MaxBandItemIdx := Integer(Inspector.BandStarts[BandIdx])\r\n else\r\n MaxBandItemIdx := MaxItemIdx;\r\n while (Rect.Top < Rect.Bottom) and (ItemIdx < MaxBandItemIdx) do\r\n begin\r\n SelItemVisible := SelItemVisible or (ItemIdx = Inspector.SelectedIndex);\r\n PaintItem(Rect, ItemIdx);\r\n Inc(ItemIdx);\r\n end;\r\n MaxBandItemIdx := Rect.Right + 4;\r\n Rect := Inspector.ClientRect;\r\n Rect.Left := MaxBandItemIdx;\r\n Rect.Right := Rect.Left + Inspector.BandWidth - 4;\r\n Canvas.Pen.Color := clBtnShadow;\r\n Canvas.MoveTo(Rect.Left - 3, Rect.Top);\r\n Canvas.LineTo(Rect.Left - 3, Rect.Bottom);\r\n Canvas.MoveTo(Rect.Left - 1, Rect.Top);\r\n Canvas.LineTo(Rect.Left - 1, Rect.Bottom);\r\n end;\r\n end;\r\n if not SelItemVisible and (Inspector.Selected <> nil) then\r\n HideEditor;\r\nend;\r\n\r\nprocedure TJvInspectorPainter.PaintDivider(const X, YTop, YBottom: Integer);\r\nbegin\r\nend;\r\n\r\nprocedure TJvInspectorPainter.PaintItem(var ARect: TRect;\r\n const AItemIndex: Integer);\r\nvar\r\n OrgState: Integer;\r\nbegin\r\n OrgState := SaveCanvasState(Canvas);\r\n try\r\n // Initialize painter variables\r\n PaintRect := ARect;\r\n ItemIndex := AItemIndex;\r\n SetupItem;\r\n\r\n // Do actual painting\r\n DoPaint;\r\n\r\n // Finalize painting\r\n TeardownItem;\r\n ARect := PaintRect;\r\n finally\r\n RestoreCanvasState(Canvas, OrgState);\r\n end;\r\nend;\r\n\r\nprocedure TJvInspectorPainter.PaintItem(const AItem: TJvCustomInspectorItem);\r\nvar\r\n OrgState: Integer;\r\nbegin\r\n OrgState := SaveCanvasState(Canvas);\r\n try\r\n // Initialize painter variables\r\n ItemIndex := -1;\r\n Item := AItem;\r\n SetupItem;\r\n\r\n // Do actual painting\r\n DoPaint;\r\n\r\n // Finalize painting\r\n TeardownItem;\r\n finally\r\n RestoreCanvasState(Canvas, OrgState);\r\n end;\r\nend;\r\n\r\nprocedure TJvInspectorPainter.ReadCategoryTextColor(Reader: TReader);\r\nbegin\r\n CategoryFont.Color := StringToColor(Reader.ReadIdent);\r\nend;\r\n\r\nprocedure TJvInspectorPainter.ReadHideSelectTextColor(Reader: TReader);\r\nbegin\r\n HideSelectFont.Color := StringToColor(Reader.ReadIdent);\r\nend;\r\n\r\nprocedure TJvInspectorPainter.ReadNameColor(Reader: TReader);\r\nbegin\r\n NameFont.Color := StringToColor(Reader.ReadIdent);\r\nend;\r\n\r\nprocedure TJvInspectorPainter.ReadSelectedTextColor(Reader: TReader);\r\nbegin\r\n SelectedFont.Color := StringToColor(Reader.ReadIdent);\r\nend;\r\n\r\nprocedure TJvInspectorPainter.ReadValueColor(Reader: TReader);\r\nbegin\r\n ValueFont.Color := StringToColor(Reader.ReadIdent);\r\nend;\r\n\r\nprocedure TJvInspectorPainter.SetBackgroundColor(const Value: TColor);\r\nbegin\r\n if Value <> BackgroundColor then\r\n begin\r\n FBackgroundColor := Value;\r\n if not Initializing and not Loading and Assigned(Inspector) then\r\n Inspector.Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvInspectorPainter.SetCategoryColor(const Value: TColor);\r\nbegin\r\n if Value <> CategoryColor then\r\n begin\r\n FCategoryColor := Value;\r\n if not Initializing and not Loading and Assigned(Inspector) then\r\n Inspector.Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvInspectorPainter.SetCategoryFont(const Value: TFont);\r\nbegin\r\n FCategoryFont.Assign(Value);\r\nend;\r\n\r\nprocedure TJvInspectorPainter.SetDividerColor(const Value: TColor);\r\nbegin\r\n if DividerColor <> Value then\r\n begin\r\n FDividerColor := Value;\r\n if not Initializing and not Loading and Assigned(Inspector) then\r\n Inspector.Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvInspectorPainter.SetHideSelectColor(const Value: TColor);\r\nbegin\r\nend;\r\n\r\nprocedure TJvInspectorPainter.SetHideSelectFont(const Value: TFont);\r\nbegin\r\nend;\r\n\r\nprocedure TJvInspectorPainter.SetNameFont(const Value: TFont);\r\nbegin\r\n FNameFont.Assign(Value);\r\nend;\r\n\r\nprocedure TJvInspectorPainter.SetRects(const Index: TInspectorPaintRect;\r\n const ARect: TRect);\r\nbegin\r\n if Item <> nil then\r\n Item.Rects[Index] := ARect;\r\nend;\r\n\r\nprocedure TJvInspectorPainter.SetSelectedColor(const Value: TColor);\r\nbegin\r\n if Value <> SelectedColor then\r\n begin\r\n FSelectedColor := Value;\r\n if not Initializing and not Loading and Assigned(Inspector) then\r\n Inspector.Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvInspectorPainter.SetSelectedFont(const Value: TFont);\r\nbegin\r\n FSelectedFont.Assign(Value);\r\nend;\r\n\r\nprocedure TJvInspectorPainter.Setup(const ACanvas: TCanvas);\r\nbegin\r\n Canvas := ACanvas;\r\n Canvas.Brush.Color := BackgroundColor;\r\nend;\r\n\r\nprocedure TJvInspectorPainter.SetupItem;\r\nbegin\r\n // retrieve item\r\n if ItemIndex > -1 then\r\n Item := Inspector.VisibleItems[ItemIndex];\r\n\r\n if Item <> nil then\r\n begin\r\n // retrieve button image\r\n if Item.Expanded then\r\n ButtonImage := GetCollapseImage\r\n else\r\n if Item.HasViewableItems then\r\n ButtonImage := GetExpandImage\r\n else\r\n ButtonImage := nil;\r\n end\r\n else\r\n ButtonImage := nil;\r\n\r\n // calculate rectangles\r\n if ItemIndex > -1 then\r\n SetupRects;\r\nend;\r\n\r\nprocedure TJvInspectorPainter.SetupRects;\r\nbegin\r\n Rects[iprItem] := Rect(PaintRect.Left, PaintRect.Top,\r\n PaintRect.Right, Pred(PaintRect.Top + Item.Height));\r\nend;\r\n\r\nprocedure TJvInspectorPainter.SetValueFont(const Value: TFont);\r\nbegin\r\n FValueFont.Assign(Value);\r\nend;\r\n\r\nprocedure TJvInspectorPainter.SetDrawNameEndEllipsis(Value: Boolean);\r\nbegin\r\n if Value <> DrawNameEndEllipsis then\r\n begin\r\n FDrawNameEndEllipsis := Value;\r\n if not Initializing and not Loading and Assigned(Inspector) then\r\n Inspector.Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvInspectorPainter.TeardownItem;\r\nvar\r\n TmpRect: TRect;\r\nbegin\r\n TmpRect := PaintRect;\r\n TmpRect.Top := Succ(Rects[iprItem].Bottom);\r\n PaintRect := TmpRect;\r\n Item := nil;\r\n ItemIndex := -1;\r\nend;\r\n\r\nprocedure TJvInspectorPainter.SetInspector(const AInspector: TJvCustomInspector);\r\nbegin\r\n if (AInspector <> nil) and (AInspector.ActivePainter <> Self) then\r\n raise EJvInspector.CreateRes(@RsEJvInspPaintNotActive);\r\n if AInspector <> Inspector then\r\n begin\r\n if (Inspector <> nil) and (AInspector <> nil) then\r\n raise EJvInspector.CreateRes(@RsEJvInspPaintOnlyUsedOnce);\r\n FInspector := AInspector;\r\n end;\r\nend;\r\n\r\n//=== { TJvInspectorBorlandNETBasePainter } ==================================\r\n\r\nprocedure TJvInspectorBorlandNETBasePainter.ApplyNameFont;\r\nbegin\r\n inherited ApplyNameFont;\r\n if Assigned(Item) and Item.IsCategory then\r\n Canvas.Font.Style := Canvas.Font.Style + [fsBold];\r\nend;\r\n\r\nprocedure TJvInspectorBorlandNETBasePainter.ApplyValueFont;\r\nbegin\r\n inherited ApplyValueFont;\r\n if Assigned(Item) and Item.IsCategory then\r\n Canvas.Font.Style := Canvas.Font.Style + [fsBold];\r\nend;\r\n\r\nprocedure TJvInspectorBorlandNETBasePainter.CalcButtonBasedRects;\r\nvar\r\n BtnSrcRect: TRect;\r\n BtnDstRect: TRect;\r\n Y: Integer;\r\nbegin\r\n if (ButtonImage <> nil) and (RectWidth(Rects[iprButtonArea]) > 0) then\r\n begin\r\n BtnSrcRect := Rect(0, 0, ButtonImage.Width, ButtonImage.Height);\r\n BtnDstRect := Rect(0, 0, RealButtonAreaWidth, RectHeight(Rects[iprButtonArea]));\r\n if BtnSrcRect.Right > BtnDstRect.Right then\r\n begin\r\n BtnSrcRect.Left := (BtnDstRect.Right - BtnSrcRect.Right) div 2;\r\n BtnSrcRect.Right := BtnSrcRect.Left + BtnDstRect.Right;\r\n end;\r\n if BtnSrcRect.Bottom > BtnDstRect.Bottom then\r\n begin\r\n BtnSrcRect.Top := (BtnDstRect.Bottom - BtnSrcRect.Bottom) div 2;\r\n BtnSrcRect.Bottom := BtnSrcRect.Top + BtnDstRect.Bottom;\r\n end;\r\n if BtnDstRect.Right > RectWidth(BtnSrcRect) then\r\n begin\r\n BtnDstRect.Left := (BtnDstRect.Right - RectWidth(BtnSrcRect)) div 2;\r\n BtnDstRect.Right := BtnDstRect.Left + RectWidth(BtnSrcRect);\r\n end;\r\n if BtnDstRect.Bottom > RectHeight(BtnSrcRect) then\r\n begin\r\n if (RectHeight(BtnDstRect) div Inspector.ItemHeight) < 2 then\r\n Y := (RectHeight(BtnDstRect) - RectHeight(BtnSrcRect)) div 2\r\n else\r\n Y := (Inspector.ItemHeight - RectHeight(BtnSrcRect)) div 2;\r\n BtnDstRect.Top := Y;\r\n BtnDstRect.Bottom := BtnDstRect.Top + RectHeight(BtnSrcRect);\r\n end;\r\n OffsetRect(BtnDstRect, Rects[iprButtonArea].Left, Rects[iprButtonArea].Top);\r\n IntersectRect(BtnDstRect, BtnDstRect, Rects[iprButtonArea]);\r\n end\r\n else\r\n begin\r\n BtnSrcRect := Rect(0, 0, 0, 0);\r\n BtnDstRect := Rect(0, 0, 0, 0);\r\n end;\r\n Rects[iprBtnSrcRect] := BtnSrcRect;\r\n Rects[iprBtnDstRect] := BtnDstRect;\r\nend;\r\n\r\nprocedure TJvInspectorBorlandNETBasePainter.CalcEditBasedRects;\r\nvar\r\n TmpRect: TRect;\r\nbegin\r\n if [iifValueList, iifEditButton] * Item.Flags = [] then\r\n begin // Value takes up entire edit value rect, there is no edit button:\r\n Rects[iprEditValue] := Rects[iprValue];\r\n Rects[iprEditButton] := Rect(0, 0, 0, 0);\r\n end\r\n else\r\n begin // The edit button is on the right of the edit value area:\r\n TmpRect := Rects[iprValue];\r\n Dec(TmpRect.Right, Inspector.ItemHeight);\r\n Rects[iprEditValue] := TmpRect;\r\n TmpRect := Rects[iprValueArea];\r\n TmpRect.Left := TmpRect.Right - Inspector.ItemHeight;\r\n Rects[iprEditButton] := TmpRect;\r\n end;\r\nend;\r\n\r\nprocedure TJvInspectorBorlandNETBasePainter.CalcNameBasedRects;\r\nvar\r\n CanvasState: Integer;\r\n RowHeight: Integer;\r\n TmpRect: TRect;\r\nbegin\r\n CanvasState := SaveCanvasState(Canvas);\r\n try\r\n ApplyNameFont;\r\n RowHeight := CanvasMaxTextHeight(Canvas);\r\n TmpRect := Rects[iprNameArea];\r\n if Item.Level = 0 then\r\n Inc(TmpRect.Left, 2);\r\n if RectHeight(TmpRect) div RowHeight < 2 then\r\n OffsetRect(TmpRect, 0, (RectHeight(TmpRect) - RowHeight) div 2)\r\n else\r\n begin\r\n Inc(TmpRect.Top, 1);\r\n Dec(TmpRect.Bottom, 1);\r\n end;\r\n IntersectRect(TmpRect, TmpRect, Rects[iprNameArea]);\r\n Rects[iprName] := TmpRect;\r\n finally\r\n RestoreCanvasState(Inspector.Canvas, CanvasState);\r\n end;\r\nend;\r\n\r\nprocedure TJvInspectorBorlandNETBasePainter.CalcValueBasedRects;\r\nvar\r\n CanvasState: Integer;\r\n RowHeight: Integer;\r\n TmpRect: TRect;\r\nbegin\r\n CanvasState := SaveCanvasState(Canvas);\r\n try\r\n ApplyValueFont;\r\n RowHeight := CanvasMaxTextHeight(Canvas);\r\n TmpRect := Rects[iprValueArea];\r\n if RectHeight(TmpRect) div RowHeight < 2 then\r\n begin\r\n OffsetRect(TmpRect, 0, (RectHeight(TmpRect) - RowHeight) div 2);\r\n IntersectRect(TmpRect, TmpRect, Rects[iprValueArea]);\r\n end\r\n else\r\n begin\r\n Inc(TmpRect.Top, 1);\r\n Dec(TmpRect.Bottom, 1);\r\n IntersectRect(TmpRect, TmpRect, Rects[iprValueArea]);\r\n end;\r\n Rects[iprValue] := TmpRect;\r\n finally\r\n RestoreCanvasState(Inspector.Canvas, CanvasState);\r\n end;\r\n CalcEditBasedRects;\r\nend;\r\n\r\nprocedure TJvInspectorBorlandNETBasePainter.InitializeColors;\r\nbegin\r\n inherited InitializeColors;\r\n\r\n CategoryFont.Color := clBtnText;\r\n NameFont.Color := clWindowText;\r\n ValueFont.Color := clWindowText;\r\nend;\r\n\r\nprocedure TJvInspectorBorlandNETBasePainter.SetupRects;\r\nvar\r\n ItemRect2: TRect;\r\n TmpRect: TRect;\r\nbegin\r\n inherited SetupRects;\r\n ItemRect2 := Rects[iprItem];\r\n TmpRect := Rect(ItemRect2.Left + (Item.Level * Inspector.ItemHeight), ItemRect2.Top,\r\n ItemRect2.Left + (Succ(Item.Level) * Inspector.ItemHeight), ItemRect2.Bottom);\r\n RealButtonAreaWidth := RectWidth(TmpRect);\r\n if not Item.IsCategory and (TmpRect.Left > Pred(Inspector.DividerAbs)) then\r\n begin\r\n TmpRect.Left := 0;\r\n TmpRect.Right := 0;\r\n end;\r\n if not Item.IsCategory and (TmpRect.Right > Pred(Inspector.DividerAbs)) then\r\n TmpRect.Right := Pred(Inspector.DividerAbs);\r\n Rects[iprButtonArea] := TmpRect;\r\n TmpRect := ItemRect2;\r\n TmpRect.Left := ItemRect2.Left + (Succ(Item.Level) * Inspector.ItemHeight);\r\n Rects[iprNameArea] := TmpRect;\r\n if Item.IsCategory then\r\n Rects[iprValueArea] := Rect(0, 0, 0, 0)\r\n else\r\n begin\r\n if TmpRect.Left > Pred(Inspector.DividerAbs) then\r\n TmpRect := Rect(0, 0, 0, 0)\r\n else\r\n TmpRect.Right := ItemRect2.Left + Pred(Inspector.DividerAbs);\r\n Rects[iprNameArea] := TmpRect;\r\n TmpRect := ItemRect2;\r\n TmpRect.Left := ItemRect2.Left + Inspector.DividerAbs + DividerWidth;\r\n Rects[iprValueArea] := TmpRect;\r\n end;\r\n CalcButtonBasedRects;\r\n CalcNameBasedRects;\r\n CalcValueBasedRects;\r\nend;\r\n\r\n//=== { TJvInspectorBorlandPainter } =========================================\r\n\r\nfunction TJvInspectorBorlandPainter.DividerWidth: Integer;\r\nbegin\r\n Result := 2;\r\nend;\r\n\r\nprocedure TJvInspectorBorlandPainter.DoPaint;\r\nvar\r\n TmpRect: TRect;\r\n X: Integer;\r\n MaxX: Integer;\r\nbegin\r\n TmpRect := Rects[iprItem];\r\n if Item = Inspector.Selected then\r\n begin\r\n // Selected frame\r\n InflateRect(TmpRect, 0, 1);\r\n Dec(TmpRect.Top);\r\n Inc(TmpRect.Right);\r\n Frame3D(Canvas, TmpRect, clGray, clWhite, 1);\r\n Frame3D(Canvas, TmpRect, clGray, cl3DLight, 1);\r\n end\r\n else\r\n begin\r\n // Dotted line\r\n X := TmpRect.Left;\r\n MaxX := TmpRect.Right;\r\n Canvas.Pen.Color := clGray;\r\n while X < MaxX do\r\n begin\r\n Canvas.Pixels[X, TmpRect.Bottom] := clGray;\r\n Inc(X, 2);\r\n end;\r\n end;\r\n\r\n if not Item.IsCategory then\r\n begin\r\n // Draw divider line\r\n TmpRect := Rects[iprItem];\r\n PaintDivider(TmpRect.Left + Inspector.DividerAbs, Pred(TmpRect.Top), TmpRect.Bottom);\r\n end;\r\n\r\n ApplyNameFont;\r\n Item.DrawName(Canvas);\r\n ApplyValueFont;\r\n if Assigned(FOnSetItemColors) then\r\n FOnSetItemColors(Item, Canvas); // Custom colors for canvas and font for cells depending on values.\r\n\r\n Item.DrawValue(Canvas);\r\n\r\n if ButtonImage <> nil then\r\n Canvas.CopyRect(Rects[iprBtnDstRect], ButtonImage.Canvas, Rects[iprBtnSrcRect]);\r\nend;\r\n\r\nfunction TJvInspectorBorlandPainter.GetDividerLightColor: TColor;\r\nbegin\r\n Result := FDividerLightColor;\r\nend;\r\n\r\nfunction TJvInspectorBorlandPainter.GetSelectedColor: TColor;\r\nbegin\r\n Result := BackgroundColor;\r\nend;\r\n\r\nfunction TJvInspectorBorlandPainter.GetSelectedFont: TFont;\r\nbegin\r\n Result := NameFont;\r\nend;\r\n\r\nprocedure TJvInspectorBorlandPainter.InitializeColors;\r\nbegin\r\n inherited InitializeColors;\r\n SetDefaultProp(Self, 'DividerLightColor');\r\n ValueFont.Color := clNavy;\r\nend;\r\n\r\nprocedure TJvInspectorBorlandPainter.PaintDivider(const X, YTop, YBottom: Integer);\r\nbegin\r\n with Canvas do\r\n begin\r\n Canvas.Pen.Color := DividerColor;\r\n MoveTo(X, YTop);\r\n LineTo(X, YBottom);\r\n Pen.Color := DividerLightColor;\r\n MoveTo(Succ(X), YBottom);\r\n LineTo(Succ(X), YTop);\r\n end;\r\nend;\r\n\r\nprocedure TJvInspectorBorlandPainter.SetDividerLightColor(const Value: TColor);\r\nbegin\r\n if DividerLightColor <> Value then\r\n begin\r\n FDividerLightColor := Value;\r\n if not Initializing and not Loading and Assigned(Inspector) then\r\n Inspector.Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvInspectorBorlandPainter.Setup(const ACanvas: TCanvas);\r\nbegin\r\n inherited Setup(ACanvas);\r\n Canvas.Brush.Color := clBtnFace;\r\nend;\r\n\r\n//=== { TJvInspectorDotNETPainter } ==========================================\r\n\r\nprocedure TJvInspectorDotNETPainter.ApplyNameFont;\r\nbegin\r\n inherited ApplyNameFont;\r\n if (Item = Inspector.Selected) and\r\n not (Item is TJvInspectorCustomCompoundItem) then\r\n begin\r\n if Inspector.Focused then\r\n begin\r\n Canvas.Brush.Color := SelectedColor;\r\n Canvas.Font := SelectedFont;\r\n end\r\n else\r\n begin\r\n Canvas.Brush.Color := HideSelectColor;\r\n Canvas.Font := HideSelectFont;\r\n end;\r\n end\r\n else\r\n if Item.IsCategory and (Item.Level = 0) then\r\n Canvas.Brush.Color := CategoryColor\r\n else\r\n Canvas.Brush.Color := BackgroundColor;\r\nend;\r\n\r\nfunction TJvInspectorDotNETPainter.GetHideSelectColor: TColor;\r\nbegin\r\n Result := FHideSelectColor;\r\nend;\r\n\r\nfunction TJvInspectorDotNETPainter.GetHideSelectFont: TFont;\r\nbegin\r\n Result := FHideSelectFont;\r\nend;\r\n\r\nconstructor TJvInspectorDotNETPainter.Create(AOwner: TComponent);\r\nbegin\r\n // inherited Create will call Initialize colors which will use this font.\r\n FHideSelectFont := TFont.Create;\r\n FHideSelectFont.OnChange := FontChange;\r\n\r\n inherited Create(AOwner);\r\nend;\r\n\r\ndestructor TJvInspectorDotNETPainter.Destroy;\r\nbegin\r\n FHideSelectFont.Free;\r\n\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvInspectorDotNETPainter.DoPaint;\r\nvar\r\n EndOfList: Boolean;\r\n NextItem: TJvCustomInspectorItem;\r\n EndOfCat: Boolean;\r\n PreNameRect: TRect;\r\n CatRect: TRect;\r\n SaveIdx: Integer;\r\n LeftX: Integer;\r\nbegin\r\n SaveIdx := SaveCanvasState(Canvas);\r\n\r\n // Determine item type (end of list, end of a level 0 category)\r\n EndOfList := Succ(ItemIndex) >= Inspector.VisibleCount;\r\n if not EndOfList then\r\n begin\r\n NextItem := Inspector.VisibleItems[Succ(ItemIndex)];\r\n EndOfCat := (NextItem.BaseCategory <> Item.BaseCategory) and\r\n (Item.BaseCategory <> nil);\r\n end\r\n else\r\n EndOfCat := Item.BaseCategory <> nil;\r\n\r\n PreNameRect := Rects[iprItem];\r\n PreNameRect.Left := PreNameRect.Left + (Item.Level * Inspector.ItemHeight) + RealButtonAreaWidth;\r\n if PreNameRect.Left > Pred(Inspector.DividerAbs) then\r\n PreNameRect := Rect(0, 0, 0, 0)\r\n else\r\n begin\r\n PreNameRect.Right := PreNameRect.Left + RealButtonAreaWidth;\r\n if PreNameRect.Right > Pred(Inspector.DividerAbs) then\r\n PreNameRect.Right := Pred(Inspector.DividerAbs);\r\n end;\r\n Inc(PreNameRect.Right);\r\n\r\n CatRect := Rects[iprItem];\r\n CatRect.Right := CatRect.Left + RealButtonAreaWidth;\r\n Inc(CatRect.Bottom);\r\n if Item.BaseCategory <> nil then\r\n begin\r\n Canvas.Brush.Color := CategoryColor;\r\n Canvas.FillRect(CatRect);\r\n ApplyCanvasState(Canvas, SaveIdx);\r\n end;\r\n\r\n if not (Item.IsCategory) then\r\n PaintDivider(Rects[iprItem].Left + Inspector.DividerAbs, Pred(Rects[iprItem].Top),\r\n Rects[iprItem].Bottom);\r\n\r\n if (Item.IsCategory) and (Item.Level = 0) then\r\n Canvas.Brush.Color := CategoryColor;\r\n if (Item = Inspector.Selected) and (not (Item is TJvInspectorCustomCompoundItem) or\r\n TJvInspectorCustomCompoundItem(Item).SingleName or (TJvInspectorCustomCompoundItem(Item).SelectedColumnIndex = 0)) and\r\n ((Item.Level > 0) or not (Item.IsCategory)) then\r\n begin\r\n if Inspector.Focused then\r\n Canvas.Brush.Color := SelectedColor\r\n else\r\n Canvas.Brush.Color := HideSelectColor;\r\n end;\r\n Canvas.FillRect(PreNameRect);\r\n ApplyNameFont;\r\n Canvas.FillRect(Rects[iprNameArea]);\r\n Item.DrawName(Canvas);\r\n ApplyCanvasState(Canvas, SaveIdx);\r\n ApplyValueFont;\r\n if Assigned(FOnSetItemColors) then\r\n FOnSetItemColors(Item, Canvas); // Custom colors for canvas and font for cells depending on values.\r\n Item.DrawValue(Canvas);\r\n RestoreCanvasState(Canvas, SaveIdx);\r\n\r\n if ButtonImage <> nil then\r\n Canvas.CopyRect(Rects[iprBtnDstRect], ButtonImage.Canvas, Rects[iprBtnSrcRect]);\r\n\r\n SaveIdx := SaveCanvasState(Canvas);\r\n if EndOfCat or ((Item.IsCategory) and\r\n (Item.Level = 0)) then\r\n Canvas.Pen.Color := clBtnShadow\r\n else\r\n Canvas.Pen.Color := clBtnFace;\r\n if not EndOfList and not EndOfCat then\r\n LeftX := Rects[iprItem].Left + RealButtonAreaWidth\r\n else\r\n LeftX := Rects[iprItem].Left;\r\n Canvas.MoveTo(Rects[iprItem].Right, Rects[iprItem].Bottom);\r\n Canvas.LineTo(Pred(LeftX), Rects[iprItem].Bottom);\r\n\r\n if Item <> Item.BaseCategory then\r\n begin\r\n if Item.BaseCategory <> nil then\r\n Canvas.Pen.Color := clBtnShadow\r\n else\r\n Canvas.Pen.Color := CategoryColor;\r\n Canvas.MoveTo(Rects[iprItem].Left + RealButtonAreaWidth, Rects[iprItem].Top);\r\n Canvas.LineTo(Rects[iprItem].Left + RealButtonAreaWidth, Succ(Rects[iprItem].Bottom));\r\n end;\r\n RestoreCanvasState(Canvas, SaveIdx);\r\nend;\r\n\r\nprocedure TJvInspectorDotNETPainter.InitializeColors;\r\nbegin\r\n inherited InitializeColors;\r\n\r\n SetDefaultProp(Self, ['HideSelectColor']);\r\n\r\n HideSelectFont.Color := clHighlightText;\r\n SelectedFont.Color := clHighlightText;\r\nend;\r\n\r\nprocedure TJvInspectorDotNETPainter.PaintDivider(const X, YTop, YBottom: Integer);\r\nbegin\r\n with Canvas do\r\n begin\r\n Pen.Color := DividerColor;\r\n MoveTo(X, YTop);\r\n LineTo(X, YBottom);\r\n end\r\nend;\r\n\r\nprocedure TJvInspectorDotNETPainter.SetHideSelectColor(const Value: TColor);\r\nbegin\r\n if Value <> HideSelectColor then\r\n begin\r\n FHideSelectColor := Value;\r\n if not Initializing and not Loading and Assigned(Inspector) then\r\n Inspector.Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvInspectorDotNETPainter.SetHideSelectFont(const Value: TFont);\r\nbegin\r\n FHideSelectFont.Assign(Value);\r\nend;\r\n\r\n//=== { TJvInspectorItemSizing } =============================================\r\n\r\nconstructor TJvInspectorItemSizing.Create(const AItem: TJvCustomInspectorItem);\r\nbegin\r\n inherited Create;\r\n Item := AItem;\r\nend;\r\n\r\nfunction TJvInspectorItemSizing.GetMinHeight: TItemRowSizing;\r\nbegin\r\n Result := FMinHeight;\r\nend;\r\n\r\nfunction TJvInspectorItemSizing.GetSizable: Boolean;\r\nbegin\r\n Result := FSizable;\r\nend;\r\n\r\nfunction TJvInspectorItemSizing.GetSizingFactor: TItemRowSizing;\r\nbegin\r\n Result := FSizingFactor;\r\nend;\r\n\r\nprocedure TJvInspectorItemSizing.SetMinHeight(Value: TItemRowSizing);\r\nvar\r\n CurHeight: Integer;\r\nbegin\r\n CurHeight := Item.Height;\r\n if Value = irsNoReSize then\r\n begin\r\n if SizingFactor <> Value then\r\n SizingFactor := Value\r\n else\r\n if MinHeight <> irsItemHeight then\r\n begin\r\n FMinHeight := irsItemHeight;\r\n Item.Height := CurHeight;\r\n end;\r\n end\r\n else\r\n if MinHeight <> Value then\r\n begin\r\n if SizingFactor = irsNoReSize then\r\n FSizingFactor := irsValueMask;\r\n FMinHeight := Value;\r\n Item.Height := CurHeight;\r\n end;\r\nend;\r\n\r\nprocedure TJvInspectorItemSizing.SetSizable(Value: Boolean);\r\nbegin\r\n if Sizable <> Value then\r\n FSizable := Value;\r\nend;\r\n\r\nprocedure TJvInspectorItemSizing.SetSizingFactor(Value: TItemRowSizing);\r\nvar\r\n CurHeight: Integer;\r\nbegin\r\n CurHeight := Item.Height;\r\n if SizingFactor <> Value then\r\n begin\r\n FSizingFactor := Value;\r\n if SizingFactor = irsNoReSize then\r\n FMinHeight := irsItemHeight\r\n else\r\n Item.Height := CurHeight;\r\n end;\r\nend;\r\n\r\nprocedure TJvInspectorItemSizing.Assign(Source: TPersistent);\r\nbegin\r\n if Source is TJvInspectorItemSizing then\r\n begin\r\n MinHeight := TJvInspectorItemSizing(Source).MinHeight;\r\n SizingFactor := TJvInspectorItemSizing(Source).SizingFactor;\r\n end\r\n else\r\n inherited Assign(Source);\r\nend;\r\n\r\n{ Item sorting functions }\r\n\r\nfunction AlphaSortCompare(Item1, Item2: Pointer): Integer;\r\nbegin\r\n Result := AnsiCompareText(TJvCustomInspectorItem(Item1).DisplayName,\r\n TJvCustomInspectorItem(Item2).DisplayName);\r\nend;\r\n\r\nvar // maybe a threadvar would be better? OTOH, VCL is not threadsafe anyway so why bother?\r\n DataSortCompareEvent: TInspectorItemSortCompare;\r\n\r\nfunction DataSortCompare(Item1, Item2: Pointer): Integer;\r\nbegin\r\n if Assigned(DataSortCompareEvent) then\r\n Result := DataSortCompareEvent(Item1, Item2)\r\n else\r\n Result := 0;\r\nend;\r\n\r\nfunction DisplayIndexSortCompare(Item1, Item2: Pointer): Integer;\r\nvar\r\n Idx1: Integer;\r\n Idx2: Integer;\r\nbegin\r\n Idx1 := TJvCustomInspectorItem(Item1).DisplayIndex;\r\n Idx2 := TJvCustomInspectorItem(Item2).DisplayIndex;\r\n if (Idx1 <> -1) and (Idx2 <> -1) then\r\n Result := Idx1 - Idx2\r\n else\r\n begin\r\n if Idx1 = -1 then\r\n if Idx2 = -1 then\r\n Result := 0\r\n else\r\n Result := 1\r\n else\r\n Result := -1;\r\n end;\r\nend;\r\n\r\n//=== { TJvInspectorMemo } ===================================================\r\n\r\ntype\r\n TJvInspectorMemo = class(TMemo)\r\n private\r\n FOnKillFocus: TNotifyEvent;\r\n protected\r\n procedure WMKillFocus(var Msg: TWMKillFocus); message WM_KILLFOCUS;\r\n public\r\n property OnKillFocus: TNotifyEvent read FOnKillFocus write FOnKillFocus;\r\n end;\r\n\r\nprocedure TJvInspectorMemo.WMKillFocus(var Msg: TWMKillFocus);\r\nbegin\r\n inherited;\r\n if Assigned(FOnKillFocus) then\r\n FOnKillFocus(Self);\r\nend;\r\n\r\n//=== { TJvInspectorEdit } ===================================================\r\n\r\ntype\r\n TJvInspectorEdit = class(TEdit)\r\n private\r\n FOnKillFocus: TNotifyEvent;\r\n protected\r\n procedure WMKillFocus(var Msg: TWMKillFocus); message WM_KILLFOCUS;\r\n public\r\n property OnKillFocus: TNotifyEvent read FOnKillFocus write FOnKillFocus;\r\n end;\r\n\r\nprocedure TJvInspectorEdit.WMKillFocus(var Msg: TWMKillFocus);\r\nbegin\r\n inherited;\r\n if Assigned(FOnKillFocus) then\r\n FOnKillFocus(Self);\r\nend;\r\n\r\n//=== { TJvCustomInspectorItem } =============================================\r\n\r\nconstructor TJvCustomInspectorItem.Create(const AParent: TJvCustomInspectorItem;\r\n const AData: TJvCustomInspectorData);\r\nbegin\r\n inherited Create;\r\n FData := nil;\r\n FItems := TObjectList.Create(True);\r\n Flags := [iifVisible];\r\n FRowSizing := TJvInspectorItemSizing.Create(Self);\r\n FSortKind := iskName;\r\n FDisplayIndex := -1;\r\n if AData <> nil then\r\n FDisplayName := AData.Name;\r\n if AParent <> nil then\r\n begin\r\n FInspector := AParent.Inspector;\r\n AParent.Add(Self)\r\n end;\r\n FData := AData;\r\n FDropDownCount := 8;\r\nend;\r\n\r\ndestructor TJvCustomInspectorItem.Destroy;\r\nbegin\r\n FAutoComplete.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvCustomInspectorItem.AlphaSort;\r\nvar\r\n ItemList: TList;\r\nbegin\r\n ItemList := TList.Create;\r\n try\r\n BuildDisplayableList(ItemList);\r\n ItemList.Sort(AlphaSortCompare);\r\n ApplyDisplayIndices(ItemList);\r\n finally\r\n ItemList.Free;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomInspectorItem.Apply;\r\nvar\r\n TmpOnChange: TNotifyEvent;\r\n NewValue: string;\r\nbegin\r\n try\r\n if Editing and (EditCtrl <> nil) then\r\n begin\r\n NewValue := EditCtrl.Text;\r\n if (not Data.IsAssigned or (DisplayValue <> NewValue) or\r\n (AutoUpdate and (FLastEditCtrlText <> NewValue))) and\r\n Inspector.DoItemValueChanging(Self, NewValue) then\r\n begin\r\n Inc(FUpdateEditCtrl);\r\n try\r\n try\r\n DisplayValue := NewValue;\r\n except\r\n if not Inspector.DoItemValueError(Self) then\r\n raise;\r\n end;\r\n finally\r\n Dec(FUpdateEditCtrl);\r\n end;\r\n InvalidateItem;\r\n if EditCtrl <> nil then\r\n begin\r\n TmpOnChange := TCustomEditAccessProtected(EditCtrl).OnChange;\r\n TCustomEditAccessProtected(EditCtrl).OnChange := nil;\r\n try\r\n if Data.IsAssigned then\r\n EditCtrl.Text := DisplayValue\r\n else\r\n EditCtrl.Text := '';\r\n FLastEditCtrlText := EditCtrl.Text;\r\n finally\r\n TCustomEditAccessProtected(EditCtrl).OnChange := TmpOnChange;\r\n end;\r\n end;\r\n Inspector.DoItemValueChanged(Self);\r\n end;\r\n end;\r\n finally\r\n if Editing and (EditCtrl <> nil) then\r\n begin\r\n EditCtrl.SelectAll;\r\n EditCtrl.Modified := False;\r\n EditCtrl.ClearUndo;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomInspectorItem.ApplyDisplayIndices(const ItemList: TList);\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := ItemList.Count - 1 downto 0 do\r\n TJvCustomInspectorItem(ItemList[I]).SetDisplayIndexValue(I);\r\nend;\r\n\r\nprocedure TJvCustomInspectorItem.BuildDisplayableList(const ItemList: TList);\r\nvar\r\n TempList: TList;\r\n I: Integer;\r\n Item: TJvCustomInspectorItem;\r\nbegin\r\n TempList := TList.Create;\r\n try\r\n if ItemList.Capacity < 64 then\r\n ItemList.Capacity := 64; // Avoid small growth steps\r\n I := 0;\r\n while I < Count do\r\n begin\r\n Item := Items[I];\r\n if not Item.Hidden then\r\n ItemList.Add(Item)\r\n else\r\n begin\r\n Item.BuildDisplayableList(TempList);\r\n ItemList.Assign(TempList, laOr);\r\n TempList.Clear;\r\n end;\r\n Inc(I);\r\n end;\r\n finally\r\n TempList.Free;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomInspectorItem.ButtonClick(Sender: TObject);\r\nbegin\r\n Edit;\r\n if EditCtrl <> nil then\r\n EditCtrl.Text := DisplayValue;\r\nend;\r\n\r\nfunction TJvCustomInspectorItem.CanEdit: Boolean;\r\nbegin\r\n Result := not IsCategory and not ReadOnly and not Inspector.ReadOnly and Data.IsInitialized and\r\n Data.HasValue;\r\nend;\r\n\r\nprocedure TJvCustomInspectorItem.CloseUp(Accept: Boolean);\r\nvar\r\n ListValue: string;\r\nbegin\r\n if DroppedDown then\r\n begin\r\n if GetCaptureControl = ListBox then\r\n SetCaptureControl(nil);\r\n if Inspector.HandleAllocated then\r\n Inspector.ShowScrollBars(SB_BOTH, False);\r\n if GetCapture <> 0 then\r\n SendMessage(GetCapture, WM_CANCELMODE, 0, 0);\r\n if ListBox.ItemIndex > -1 then\r\n ListValue := ListBox.Items[ListBox.ItemIndex];\r\n SetWindowPos(ListBox.Handle, 0, 0, 0, 0, 0, SWP_NOZORDER or\r\n SWP_NOMOVE or SWP_NOSIZE or SWP_NOACTIVATE or SWP_HIDEWINDOW);\r\n FDroppedDown := False;\r\n InvalidateItem;\r\n if Accept then\r\n begin\r\n if Assigned(EditCtrl) then\r\n EditCtrl.Text := ListValue;\r\n Apply;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomInspectorItem.DataSort;\r\nvar\r\n ItemList: TList;\r\nbegin\r\n ItemList := TList.Create;\r\n try\r\n BuildDisplayableList(ItemList);\r\n DataSortCompareEvent := OnCompare;\r\n ItemList.Sort(DataSortCompare);\r\n ApplyDisplayIndices(ItemList);\r\n finally\r\n ItemList.Free;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomInspectorItem.Deactivate;\r\nbegin\r\n if DroppedDown then\r\n CloseUp(False);\r\nend;\r\n\r\nprocedure TJvCustomInspectorItem.DoAfterItemCreate;\r\nbegin\r\n if Inspector <> nil then\r\n Inspector.DoAfterItemCreate(Self);\r\nend;\r\n\r\nfunction TJvCustomInspectorItem.DoCompare(const Item: TJvCustomInspectorItem): Integer;\r\nbegin\r\n if Assigned(FOnCompare) then\r\n Result := OnCompare(Self, Item)\r\n else\r\n Result := 0;\r\nend;\r\n\r\nprocedure TJvCustomInspectorItem.DoDefaultDrawListItem(ACanvas: TCanvas; Rect: TRect; const AText: string);\r\nvar\r\n h: Integer;\r\nbegin\r\n ACanvas.FillRect(Rect);\r\n h := ACanvas.TextHeight(AText);\r\n Rect.Left := Rect.Left + 2;\r\n Rect.Top := Rect.Top + (Rect.Bottom - Rect.Top - h) div 2;\r\n ACanvas.TextRect(Rect, Rect.Left, Rect.Top, AText);\r\nend;\r\n\r\nprocedure TJvCustomInspectorItem.DoDrawListItem(Control: TWinControl;\r\n Index: Integer; Rect: TRect; State: TOwnerDrawState);\r\nbegin\r\n DoDefaultDrawListItem(TListBox(Control).Canvas, Rect, TListBox(Control).Items[Index]);\r\nend;\r\n\r\nprocedure TJvCustomInspectorItem.DoDropDownKeys(var Key: Word; Shift: TShiftState);\r\nbegin\r\n case Key of\r\n VK_UP, VK_DOWN:\r\n if ssAlt in Shift then\r\n begin\r\n if DroppedDown then\r\n CloseUp(True)\r\n else\r\n DropDown;\r\n Key := 0;\r\n end;\r\n VK_RETURN, VK_ESCAPE:\r\n if DroppedDown and not (ssAlt in Shift) then\r\n begin\r\n CloseUp(Key = VK_RETURN);\r\n Key := 0;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomInspectorItem.DoGetValueList(const Strings: TStrings);\r\nbegin\r\n if Assigned(FOnGetValueList) then\r\n FOnGetValueList(Self, Strings);\r\nend;\r\n\r\nprocedure TJvCustomInspectorItem.DoMeasureListItem(Control: TWinControl;\r\n Index: Integer; var Height: Integer);\r\nbegin\r\nend;\r\n\r\nprocedure TJvCustomInspectorItem.DoMeasureListItemWidth(Control: TWinControl;\r\n Index: Integer; var Width: Integer);\r\nbegin\r\nend;\r\n\r\nprocedure TJvCustomInspectorItem.DoValueChanged;\r\nbegin\r\n if Assigned(FOnValueChanged) then\r\n FOnValueChanged(Self);\r\nend;\r\n\r\nprocedure TJvCustomInspectorItem.DropDown;\r\nvar\r\n ListCount: Integer;\r\n P: TPoint;\r\n Y: Integer;\r\n J: Integer;\r\n I: Integer;\r\n IH: Integer;\r\n MH: Integer;\r\nbegin\r\n if (not DroppedDown) and (ListBox <> nil) then\r\n begin\r\n ListBox.Width := RectWidth(Rects[iprValueArea]);\r\n TListBox(ListBox).Font := TCustomEditAccessProtected(EditCtrl).Font;\r\n ListBox.Items.Clear;\r\n GetValueList(ListBox.Items);\r\n if [iifOwnerDrawListFixed, iifOwnerDrawListVariable, iifOwnerDrawListMaxHeight] * Flags <> [] then\r\n begin\r\n ListBox.Canvas.Font := TListBox(ListBox).Font;\r\n IH := CanvasMaxTextHeight(ListBox.Canvas);\r\n if iifOwnerDrawListFixed in Flags then\r\n begin\r\n DoMeasureListItem(ListBox, -1, IH);\r\n MH := IH;\r\n end\r\n else\r\n if iifOwnerDrawListMaxHeight in Flags then\r\n begin\r\n MH := IH;\r\n for I := 0 to (ListBox.Items.Count-1) do\r\n begin\r\n DoMeasureListItem(ListBox, I, IH);\r\n if MH < IH then\r\n MH := IH;\r\n end;\r\n end\r\n else\r\n MH := IH;\r\n TListBox(ListBox).ItemHeight := MH;\r\n end;\r\n if ListBox.Items.Count < DropDownCount then\r\n ListCount := ListBox.Items.Count\r\n else\r\n ListCount := DropDownCount;\r\n if ListCount = 0 then\r\n ListCount := 1;\r\n TListBox(ListBox).Height := ListCount * TListBox(ListBox).ItemHeight + 4;\r\n if ListBox.Height > Screen.Height then\r\n begin\r\n ListCount := (Screen.Height - 4) div TListBox(ListBox).ItemHeight;\r\n TListBox(ListBox).Height := ListCount * TListBox(ListBox).ItemHeight + 4;\r\n end;\r\n ListBox.ItemIndex := ListBox.Items.IndexOf(EditCtrl.Text);\r\n J := ListBox.ClientWidth;\r\n if ListBox.Items.Count > ListCount then\r\n Dec(J, GetSystemMetrics(SM_CXVSCROLL));\r\n for I := 0 to ListBox.Items.Count - 1 do\r\n begin\r\n Y := ListBox.Canvas.TextWidth(ListBox.Items[I]) + 4;\r\n if TListBox(ListBox).Style <> lbStandard then\r\n DoMeasureListItemWidth(ListBox, I, Y);\r\n if Y > J then\r\n J := Y;\r\n end;\r\n if ListBox.Items.Count > ListCount then\r\n Inc(J, GetSystemMetrics(SM_CXVSCROLL));\r\n ListBox.ClientWidth := J;\r\n if ListBox.Width > Screen.Width then\r\n ListBox.Width := Screen.Width;\r\n P := Inspector.ClientToScreen(Point(Rects[iprValueArea].Right - ListBox.Width, EditCtrl.Top));\r\n if P.X < 0 then\r\n P := Inspector.ClientToScreen(Point(Rects[iprValueArea].Left, EditCtrl.Top));\r\n Y := P.Y + RectHeight(Rects[iprValueArea]);\r\n if Y + ListBox.Height > Screen.Height then\r\n Y := P.Y - TListBox(ListBox).Height;\r\n if P.X + ListBox.Width > Screen.Width then\r\n P.X := Screen.Width - ListBox.Width;\r\n SetWindowPos(ListBox.Handle, HWND_TOP, P.X, Y, 0, 0,\r\n SWP_NOSIZE or {SWP_NOACTIVATE or }SWP_SHOWWINDOW);\r\n InvalidateItem;\r\n EditCtrl.SetFocus;\r\n FDroppedDown := True; // must be after EditCtrl.SetFocus\r\n Inspector.Selecting := False;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomInspectorItem.Edit;\r\nvar\r\n DisplayStr: string;\r\nbegin\r\n //\r\n // Override this virtual method to define what happens when item is\r\n // Edited. If you don't, then this is the default handler.\r\n // To use it, set iifEdit in one of your item's Flags fields,\r\n // and then catch the JvInspector.OnItemEdit event.\r\n //\r\n if Assigned(FInspector) and Assigned(FInspector.FOnItemEdit) then\r\n begin\r\n if Assigned(FEditCtrl) and (FEditCtrl.Text <> FData.AsString) then\r\n Apply;\r\n DisplayStr := FData.AsString;\r\n FInspector.FOnItemEdit(FInspector, Self, DisplayStr);\r\n if DisplayStr <> Self.FData.AsString then\r\n FData.SetAsString(DisplayStr); // modified!\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomInspectorItem.EditChange(Sender: TObject);\r\nbegin\r\n if AutoUpdate then\r\n begin\r\n DisplayValue := EditCtrl.Text;\r\n InvalidateItem;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomInspectorItem.EditFocusLost(Sender: TObject);\r\nbegin\r\n if Inspector.HandleAllocated and not Inspector.Focused then\r\n begin\r\n // Mantis 3391: When the focus is lost, the editing is finished, so that\r\n // moving to another item or another control always updates the value.\r\n try\r\n Apply;\r\n except\r\n Application.HandleException(Self);\r\n if (EditCtrl <> nil) and EditCtrl.CanFocus then\r\n EditCtrl.SetFocus;\r\n end;\r\n InvalidateItem;\r\n\r\n Inspector.Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomInspectorItem.EditKillFocus(Sender: TObject);\r\nbegin\r\n if DroppedDown then\r\n CloseUp(False);\r\nend;\r\n\r\nprocedure TJvCustomInspectorItem.AutoCompleteStart(Sender: TObject);\r\nbegin\r\n if Inspector.AutoDropDown and not DroppedDown then\r\n DropDown\r\n else\r\n begin\r\n ListBox.Items.Clear;\r\n GetValueList(ListBox.Items);\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomInspectorItem.EditKeyPress(Sender: TObject; var Key: Char);\r\nbegin\r\n if Assigned(Inspector.FOnEditorKeyPress) then\r\n Inspector.FOnEditorKeyPress(Inspector, Key);\r\n if Inspector.AutoComplete and (iifValueList in Flags) and not ReadOnly then\r\n begin\r\n if not Assigned(FAutoComplete) then\r\n begin\r\n FAutoComplete := TJvEditListBoxAutoComplete.Create(TCustomEdit(EditCtrl), ListBox);\r\n end\r\n else\r\n begin\r\n // Mantis 3401: AutoComplete component is already created, but the\r\n // EditCtrl and ListBox properties may have been reset to nil, especially\r\n // by the DoneEdit call. Hence the need to reaffect them.\r\n FAutoComplete.EditCtrl := EditCtrl;\r\n FAutoComplete.ListBox := ListBox;\r\n end;\r\n FAutoComplete.OnDropDown := AutoCompleteStart;\r\n FAutoComplete.AutoComplete(Key);\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomInspectorItem.EditKeyDown(Sender: TObject; var Key: Word;\r\n Shift: TShiftState);\r\nbegin\r\n if Assigned(Inspector.FOnEditorKeyDown) then\r\n Inspector.FOnEditorKeyDown(Inspector, Key, Shift);\r\n\r\n if Shift = [] then\r\n begin\r\n case Key of\r\n VK_RETURN:\r\n Apply;\r\n VK_ESCAPE:\r\n Undo;\r\n end;\r\n if (Key = VK_RETURN) or (Key = VK_ESCAPE) then\r\n Key := VK_RIGHT;\r\n end\r\n else\r\n if Shift = [ssCtrl] then\r\n case Key of\r\n VK_UP:\r\n if iifValueList in Flags then\r\n begin\r\n SelectValue(-1);\r\n Key := 0;\r\n end;\r\n VK_DOWN:\r\n if iifValueList in Flags then\r\n begin\r\n SelectValue(1);\r\n Key := 0;\r\n end;\r\n VK_RETURN:\r\n if iifValueList in Flags then\r\n begin\r\n SelectValue(1);\r\n Key := 0;\r\n end\r\n else\r\n if iifEditButton in Flags then\r\n begin\r\n Key := 0;\r\n ButtonClick(Sender);\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomInspectorItem.EditKeyUp(Sender: TObject; var Key: Word;\r\n Shift: TShiftState);\r\nbegin\r\n if Assigned(Inspector.FOnEditorKeyUp) then\r\n Inspector.FOnEditorKeyUp(Inspector, Key, Shift);\r\nend;\r\n\r\nprocedure TJvCustomInspectorItem.EditMouseDown(Sender: TObject;\r\n Button: TMouseButton; Shift: TShiftState; X, Y: Integer);\r\nbegin\r\n if (Button = mbLeft) and (ssDouble in Shift) and (iifValueList in Flags) then\r\n SelectValue(1);\r\nend;\r\n\r\nprocedure TJvCustomInspectorItem.EditMouseMove(Sender: TObject;\r\n Shift: TShiftState; X, Y: Integer);\r\nbegin\r\nend;\r\n\r\nprocedure TJvCustomInspectorItem.EditMouseUp(Sender: TObject;\r\n Button: TMouseButton; Shift: TShiftState; X, Y: Integer);\r\nvar\r\n InspCoord: TPoint;\r\nbegin\r\n InspCoord := Inspector.ScreenToClient(EditCtrl.ClientToScreen(Point(X, Y)));\r\n Inspector.MouseUp(Button, Shift, InspCoord.X, InspCoord.Y);\r\nend;\r\n\r\nprocedure TJvCustomInspectorItem.Edit_WndProc(var Msg: TMessage);\r\nvar\r\n ExecInherited: Boolean;\r\n PostToInsp: Boolean;\r\n // Key: Word;\r\n\r\n function LeftRightCanNavigate: Boolean;\r\n begin\r\n{ Result :=\r\n ((Msg.WParam = VK_LEFT) and ((EditCtrl.SelLength = Length(EditCtrl.Text)) or (EditCtrl.SelStart < 1))) or\r\n ((Msg.WParam = VK_RIGHT) and ((EditCtrl.SelLength = Length(EditCtrl.Text)) or (EditCtrl.SelStart >= Length(EditCtrl.Text))));}\r\n Result := False;\r\n end;\r\n\r\n function TabNavigate: Boolean;\r\n begin\r\n Result := Inspector.WantTabs and (Msg.WParam = VK_TAB);\r\n end;\r\n\r\nbegin\r\n ExecInherited := True;\r\n case Msg.Msg of\r\n WM_KEYDOWN, WM_SYSKEYDOWN, WM_CHAR:\r\n begin\r\n if iifValueList in Flags then\r\n begin\r\n DoDropDownKeys(TWMKeyDown(Msg).CharCode, KeyDataToShiftState(TWMKeyDown(Msg).KeyData));\r\n if TWMKeyDown(Msg).CharCode <> 0 then\r\n begin\r\n if DroppedDown then\r\n SendMessage(ListBox.Handle, Msg.Msg, Msg.WParam, Msg.LParam);\r\n if not (iifAllowNonListValues in Flags) or\r\n ((Msg.Msg = WM_KEYDOWN) and\r\n (TWMKeyDown(Msg).CharCode in [VK_UP, VK_DOWN])) then\r\n ExecInherited := False;\r\n end;\r\n end;\r\n PostToInsp :=\r\n (Msg.Msg = WM_KEYDOWN) and ((KeyDataToShiftState(Msg.LParam) = []) and\r\n ((Msg.WParam in [VK_NEXT, VK_PRIOR]) or\r\n (not DroppedDown and (Msg.WParam in [VK_DOWN, VK_UP])) or LeftRightCanNavigate)) or TabNavigate;\r\n if PostToInsp then\r\n begin\r\n PostMessage(Inspector.Handle, Msg.Msg, Msg.WParam, Msg.LParam);\r\n Msg.Result := 1;\r\n ExecInherited := False;\r\n end;\r\n end;\r\n end;\r\n\r\n if (Msg.Msg = WM_CHAR) and (Msg.WParam = VK_RETURN) then\r\n begin\r\n ExecInherited := False;\r\n GetEditCtrl.SelectAll;\r\n// FEditChanged := True; // sets a flag that a change should be accepted whenever focus shifts away!\r\n end;\r\n if Msg.Msg = WM_MOUSEWHEEL then\r\n begin\r\n if not DroppedDown then\r\n PostMessage(Inspector.Handle, Msg.Msg, Msg.WParam, Msg.LParam);\r\n Msg.Result := 1;\r\n ExecInherited := False;\r\n end;\r\n if ExecInherited and (@EditWndPrc <> nil) then\r\n EditWndPrc(Msg);\r\n case Msg.Msg of\r\n WM_GETDLGCODE:\r\n begin\r\n if Inspector.WantTabs then\r\n Msg.Result := Msg.Result or DLGC_WANTTAB;\r\n end;\r\n WM_SETFOCUS:\r\n begin\r\n { Changing the focus to another Control in the same form via Mouse-Click, if a\r\n property-editor is active has no effect until you clicked twice on the control.\r\n Telling the VCL that this control has the focus, fixes the problem. } \r\n SetFocus;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJvCustomInspectorItem.GetAutoUpdate: Boolean;\r\nbegin\r\n Result := (iifAutoUpdate in Flags);\r\nend;\r\n\r\nfunction TJvCustomInspectorItem.GetBaseCategory: TJvCustomInspectorItem;\r\nbegin\r\n if IsCategory and (Level = 0) then\r\n Result := Self\r\n else\r\n begin\r\n Result := Category;\r\n while (Result <> nil) and (Result.Level > 0) do\r\n Result := Result.Category;\r\n end;\r\nend;\r\n\r\nfunction TJvCustomInspectorItem.GetCategory: TJvCustomInspectorItem;\r\nvar\r\n ParItem: TJvCustomInspectorItem;\r\nbegin\r\n ParItem := Parent;\r\n while (ParItem <> nil) and not ParItem.IsCategory do\r\n ParItem := ParItem.Parent;\r\n if (ParItem <> nil) and ParItem.IsCategory then\r\n Result := ParItem\r\n else\r\n Result := nil;\r\nend;\r\n\r\nfunction TJvCustomInspectorItem.GetCount: Integer;\r\nbegin\r\n Result := FItems.Count;\r\nend;\r\n\r\nfunction TJvCustomInspectorItem.GetData: TJvCustomInspectorData;\r\nbegin\r\n Result := FData;\r\nend;\r\n\r\nfunction TJvCustomInspectorItem.GetDisplayIndex: Integer;\r\nbegin\r\n Result := FDisplayIndex;\r\nend;\r\n\r\nfunction TJvCustomInspectorItem.GetDisplayName: string;\r\nbegin\r\n Result := FDisplayName;\r\n if (Parent <> nil) and (iifQualifiedNames in Parent.Flags) then\r\n Result := Parent.DisplayName + '.' + Result;\r\nend;\r\n\r\n// NEW: TJvCustomInspectorItem.GetFullName\r\n// This allows us to internally fetch the fully qualified INTERNAL\r\n// names of any item using ONLY their internal names, NOT their display\r\n// names.\r\n// NOTE THIS USES INTERNAL NAME PROPERTIES (NOT DISPLAY NAME PROPERTIES)\r\n// TO BUILD ITS RESULT, UNLIKE GetDisplayName. It would do the same thing\r\n// as GetDisplayName, if and only if (a) the parents have iifQualifiedNames\r\n// in their parent flags, and (b) if the display names and internal names\r\n// are the same.\r\n\r\nfunction TJvCustomInspectorItem.GetFullName: string;\r\nvar\r\n Tmp: string;\r\nbegin\r\n Result := GetName;\r\n if Parent <> nil then\r\n begin\r\n Tmp := Parent.GetFullName;\r\n if Tmp <> '' then\r\n Result := Tmp + '.' + Result;\r\n end;\r\nend;\r\n\r\nfunction TJvCustomInspectorItem.GetDisplayParent: TJvCustomInspectorItem;\r\nbegin\r\n Result := Parent;\r\n while (Result <> nil) and Result.Hidden do\r\n Result := Result.Parent;\r\n if Result = nil then\r\n Result := Inspector.Root;\r\nend;\r\n\r\nfunction TJvCustomInspectorItem.GetDisplayValue: string;\r\nbegin\r\n Result := '';\r\nend;\r\n\r\nfunction TJvCustomInspectorItem.GetDroppedDown: Boolean;\r\nbegin\r\n Result := FDroppedDown;\r\nend;\r\n\r\nfunction TJvCustomInspectorItem.GetEditCtrl: TCustomEdit;\r\nbegin\r\n Result := FEditCtrl;\r\nend;\r\n\r\nfunction TJvCustomInspectorItem.GetEditCtrlDestroying: Boolean;\r\nbegin\r\n Result := FEditCtrlDestroying;\r\nend;\r\n\r\nfunction TJvCustomInspectorItem.GetEditorText: string; {NEW:WAP}\r\nbegin\r\n if Assigned(FEditCtrl) then\r\n Result := FEditCtrl.Text;\r\nend;\r\n\r\nfunction TJvCustomInspectorItem.GetEditing: Boolean;\r\nbegin\r\n Result := FEditing;\r\nend;\r\n\r\nfunction TJvCustomInspectorItem.GetExpanded: Boolean;\r\nbegin\r\n Result := iifExpanded in Flags;\r\nend;\r\n\r\nfunction TJvCustomInspectorItem.GetFlags: TInspectorItemFlags;\r\nbegin\r\n Result := FFlags;\r\nend;\r\n\r\nfunction TJvCustomInspectorItem.GetHeight: Integer;\r\nbegin\r\n if RowSizing.SizingFactor = irsNoReSize then\r\n Result := Inspector.ItemHeight\r\n else\r\n begin\r\n case RowSizing.MinHeight of\r\n irsNameHeight:\r\n Result := Inspector.ActivePainter.GetNameHeight(Self);\r\n irsValueHeight:\r\n Result := Inspector.ActivePainter.GetValueHeight(Self);\r\n irsItemHeight:\r\n Result := Inspector.ItemHeight;\r\n else\r\n Result := RowSizing.MinHeight;\r\n end;\r\n case RowSizing.SizingFactor of\r\n irsNameHeight:\r\n Result := Result + HeightFactor * Inspector.ActivePainter.GetNameHeight(Self);\r\n irsValueHeight:\r\n Result := Result + HeightFactor * Inspector.ActivePainter.GetValueHeight(Self);\r\n irsItemHeight:\r\n Result := Result + HeightFactor * Inspector.ItemHeight;\r\n else\r\n Result := Result + HeightFactor * RowSizing.SizingFactor;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJvCustomInspectorItem.GetHeightFactor: Integer;\r\nbegin\r\n Result := FHeight;\r\nend;\r\n\r\nfunction TJvCustomInspectorItem.GetHidden: Boolean;\r\nbegin\r\n Result := iifHidden in Flags;\r\nend;\r\n\r\nfunction TJvCustomInspectorItem.GetInspector: TJvCustomInspector;\r\nbegin\r\n Result := FInspector;\r\nend;\r\n\r\nfunction TJvCustomInspectorItem.GetInspectorPaintGeneration: Integer;\r\nbegin\r\n Result := Inspector.PaintGeneration;\r\nend;\r\n\r\nfunction TJvCustomInspectorItem.GetIsCompoundColumn: Boolean;\r\nbegin\r\n Result := (Parent <> nil) and (Parent is TJvInspectorCustomCompoundItem) and (Parent.IndexOf(Self) < 0);\r\nend;\r\n\r\nfunction TJvCustomInspectorItem.GetItems(const I: Integer): TJvCustomInspectorItem;\r\nbegin\r\n Result := TJvCustomInspectorItem(FItems[I]);\r\nend;\r\n\r\nfunction TJvCustomInspectorItem.GetLevel: Integer;\r\nvar\r\n Item: TJvCustomInspectorItem;\r\nbegin\r\n Item := Self;\r\n Result := -1;\r\n while Item <> nil do\r\n begin\r\n if not (iifHidden in Item.Flags) then\r\n Inc(Result);\r\n Item := Item.Parent;\r\n end;\r\nend;\r\n\r\nfunction TJvCustomInspectorItem.GetListBox: TCustomListBox;\r\nbegin\r\n Result := FListBox;\r\nend;\r\n\r\nfunction TJvCustomInspectorItem.GetMultiline: Boolean;\r\nbegin\r\n Result := (iifMultiLine in Flags);\r\nend;\r\n\r\nfunction TJvCustomInspectorItem.GetNextSibling: TJvCustomInspectorItem;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := Parent;\r\n if Result <> nil then\r\n begin\r\n I := Succ(Result.IndexOf(Self));\r\n if (I = 0) or (I >= Result.Count) then\r\n Result := nil\r\n else\r\n Result := Result.Items[I];\r\n end;\r\nend;\r\n\r\nfunction TJvCustomInspectorItem.GetParent: TJvCustomInspectorItem;\r\nbegin\r\n Result := FParent;\r\nend;\r\n\r\nfunction TJvCustomInspectorItem.GetQualifiedNames: Boolean;\r\nbegin\r\n Result := (iifQualifiedNames in Flags);\r\nend;\r\n\r\nfunction TJvCustomInspectorItem.GetReadOnly: Boolean;\r\nbegin\r\n Result := (iifReadonly in Flags);\r\nend;\r\n\r\nfunction TJvCustomInspectorItem.GetRects(const RectKind: TInspectorPaintRect): TRect;\r\nbegin\r\n if LastPaintGeneration = GetInspectorPaintGeneration then\r\n Result := FRects[RectKind]\r\n else\r\n Result := Rect(0, 0, 0, 0);\r\nend;\r\n\r\nfunction TJvCustomInspectorItem.GetRowSizing: TJvInspectorItemSizing;\r\nbegin\r\n Result := FRowSizing;\r\nend;\r\n\r\nfunction TJvCustomInspectorItem.GetSortKind: TInspectorItemSortKind;\r\nbegin\r\n Result := FSortKind;\r\nend;\r\n\r\nfunction TJvCustomInspectorItem.GetSortName: string;\r\nvar\r\n DisplayParent: TJvCustomInspectorItem;\r\nbegin\r\n Result := Format('%.7d', [DisplayIndex]);\r\n DisplayParent := GetDisplayParent;\r\n if (DisplayParent <> nil) and (DisplayParent <> Inspector.Root) then\r\n Result := DisplayParent.GetSortName + #31 + Result;\r\nend;\r\n\r\nprocedure TJvCustomInspectorItem.GetValueList(const Strings: TStrings);\r\nbegin\r\n DoGetValueList(Strings);\r\nend;\r\n\r\nfunction TJvCustomInspectorItem.GetVisible: Boolean;\r\nbegin\r\n Result := iifVisible in Flags;\r\nend;\r\n\r\nprocedure TJvCustomInspectorItem.InvalidateItem;\r\nbegin\r\n if Inspector <> nil then\r\n Inspector.InvalidateItem;\r\nend;\r\n\r\nprocedure TJvCustomInspectorItem.InvalidateList;\r\nbegin\r\n if Inspector <> nil then\r\n Inspector.InvalidateList;\r\nend;\r\n\r\nprocedure TJvCustomInspectorItem.InvalidateSort;\r\nbegin\r\n if Inspector.LockCount > 0 then\r\n Inspector.NotifySort(Self)\r\n else\r\n begin\r\n if SortKind in [iskNone, iskName, iskCustom] then\r\n Sort;\r\n if Inspector.LockCount = 0 then // LockCount will be -1 if called from EndUpdate\r\n InvalidateList;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomInspectorItem.InvalidateMetaData;\r\nbegin\r\n InvalidateItem;\r\nend;\r\n\r\nprocedure TJvCustomInspectorItem.InvalidateValue;\r\nbegin\r\n DoValueChanged;\r\nend;\r\n\r\nfunction TJvCustomInspectorItem.IsCategory: Boolean;\r\nbegin\r\n Result := False;\r\nend;\r\n\r\nprocedure TJvCustomInspectorItem.ListExit(Sender: TObject);\r\nbegin\r\n if DroppedDown then\r\n CloseUp(False);\r\nend;\r\n\r\n{procedure TJvCustomInspectorItem.ListMouseUp(Sender: TObject;\r\n Button: TMouseButton; Shift: TShiftState; X, Y: Integer);\r\nbegin\r\n if Button = mbLeft then\r\n CloseUp(PtInRect(ListBox.ClientRect, Point(X, Y)));\r\nend;}\r\n\r\nprocedure TJvCustomInspectorItem.ListValueSelect(Sender: TObject);\r\nbegin\r\n CloseUp(True);\r\nend;\r\n\r\nprocedure TJvCustomInspectorItem.ListDeactivate(Sender: TObject);\r\nbegin\r\n CloseUp(False);\r\nend;\r\n\r\nprocedure TJvCustomInspectorItem.MouseDown(Button: TMouseButton;\r\n Shift: TShiftState; X, Y: Integer);\r\nbegin\r\n if (Button = mbLeft) and PtInRect(Rects[iprEditButton], Point(X, Y)) then\r\n begin\r\n if DroppedDown then\r\n CloseUp(False)\r\n else\r\n begin\r\n Tracking := True;\r\n TrackButton(X, Y);\r\n if iifValueList in Flags then\r\n DropDown\r\n else\r\n Inspector.MouseCapture := True;\r\n end;\r\n end\r\n else\r\n if (Button = mbLeft) and (ssDouble in Shift) then\r\n if (iifValueList in Flags) and\r\n (PtInRect(Rects[iprValueArea], Point(X, Y))) then\r\n SelectValue(1)\r\n else\r\n if not Editing and Self.InheritsFrom(TJvInspectorClassItem) and Assigned(Inspector.FOnItemDoubleClicked) then\r\n Inspector.FOnItemDoubleClicked(Inspector, Self);\r\nend;\r\n\r\nprocedure TJvCustomInspectorItem.MouseMove(Shift: TShiftState; X, Y: Integer);\r\nvar\r\n ListPos: TPoint;\r\n MousePos: TSmallPoint;\r\nbegin\r\n if Tracking then\r\n begin\r\n TrackButton(X, Y);\r\n if DroppedDown then\r\n begin\r\n ListPos := ListBox.ScreenToClient(Inspector.ClientToScreen(Point(X, Y)));\r\n if PtInRect(ListBox.ClientRect, ListPos) then\r\n begin\r\n StopTracking;\r\n MousePos := PointToSmallPoint(ListPos);\r\n SendMessage(ListBox.Handle, WM_LBUTTONDOWN, 0, {$IFDEF RTL230_UP}PointToLParam{$ELSE}LPARAM{$ENDIF RTL230_UP}(MousePos));\r\n Exit;\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomInspectorItem.MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);\r\nvar\r\n WasPressed: Boolean;\r\nbegin\r\n WasPressed := FPressed;\r\n StopTracking;\r\n if (Button = mbLeft) and WasPressed and (iifEditButton in Flags) then\r\n ButtonClick(Self);\r\nend;\r\n\r\nprocedure TJvCustomInspectorItem.NaturalSort;\r\nvar\r\n ItemList: TList;\r\nbegin\r\n ItemList := TList.Create;\r\n try\r\n BuildDisplayableList(ItemList);\r\n ApplyDisplayIndices(ItemList);\r\n finally\r\n ItemList.Free;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomInspectorItem.SelectValue(const Delta: Integer);\r\nvar\r\n SL: TStrings;\r\n I: Integer;\r\nbegin\r\n SL := TStringList.Create;\r\n try\r\n GetValueList(SL);\r\n if SL.Count > 0 then\r\n begin\r\n I := SL.IndexOf(DisplayValue);\r\n Inc(I, Delta);\r\n while I < 0 do\r\n I := I + SL.Count;\r\n while I >= SL.Count do\r\n I := I - SL.Count;\r\n EditCtrl.Text := SL[I];\r\n Apply;\r\n end;\r\n finally\r\n SL.Free;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomInspectorItem.SetAutoUpdate(const Value: Boolean);\r\nbegin\r\n if Value <> AutoUpdate then\r\n begin\r\n if Value then\r\n Flags := Flags + [iifAutoUpdate]\r\n else\r\n Flags := Flags - [iifAutoUpdate];\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomInspectorItem.SetDisplayIndex(const Value: Integer);\r\nvar\r\n DisplayParent: TJvCustomInspectorItem;\r\nbegin\r\n if Value <> DisplayIndex then\r\n begin\r\n DisplayParent := GetDisplayParent;\r\n if DisplayParent <> nil then\r\n DisplayParent.UpdateDisplayOrder(Self, Value);\r\n end;\r\n SortKind := iskManual;\r\nend;\r\n\r\nprocedure TJvCustomInspectorItem.SetDisplayIndexValue(const Value: Integer);\r\nbegin\r\n FDisplayIndex := Value;\r\nend;\r\n\r\nprocedure TJvCustomInspectorItem.SetDisplayName(Value: string);\r\nvar\r\n S: string;\r\nbegin\r\n if (Parent <> nil) and (iifQualifiedNames in Parent.Flags) then\r\n S := Parent.DisplayName + '.';\r\n if S <> Copy(Value, 1, Length(S)) then\r\n System.Delete(Value, 1, Length(S));\r\n if Value <> FDisplayName then\r\n begin\r\n FDisplayName := Value;\r\n InvalidateItem;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomInspectorItem.SetDisplayValue(const Value: string);\r\nbegin\r\nend;\r\n\r\nprocedure TJvCustomInspectorItem.SetEditCtrl(const Value: TCustomEdit);\r\nbegin\r\n if EditCtrl <> Value then\r\n begin\r\n if EditCtrl <> nil then\r\n begin\r\n FEditCtrlDestroying := True;\r\n try\r\n if Inspector.CanFocus and (EditCtrl.Focused or Inspector.Focused) then // Without \"Inspector.Focused\" every second click looses the focus\r\n Inspector.SetFocus;\r\n\r\n // Following Mantis 3391, setting the Focus may set EditCtrl to nil\r\n if Assigned(EditCtrl) then\r\n begin\r\n // Mantis 3994: Only restore if we actually changed it by our own.\r\n if TMethod(EditCtrl.WindowProc).Code = @EditWndPrc then\r\n EditCtrl.WindowProc := FEditWndPrc; //Edit_WndProc;\r\n EditCtrl.Free;\r\n end;\r\n finally\r\n FEditCtrlDestroying := False;\r\n end;\r\n end;\r\n FEditCtrl := Value;\r\n\r\n if EditCtrl <> nil then\r\n with TCustomEditAccessProtected(EditCtrl) do\r\n begin\r\n Ctl3D := False;\r\n BorderStyle := bsNone;\r\n Parent := TWinControl(Owner);\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomInspectorItem.SetEditing(const Value: Boolean);\r\nbegin\r\n FEditing := Value;\r\nend;\r\n\r\nprocedure TJvCustomInspectorItem.SetExpanded(Value: Boolean);\r\nbegin\r\n if Value <> Expanded then\r\n begin\r\n if Value then\r\n Flags := Flags + [iifExpanded]\r\n else\r\n Flags := Flags - [iifExpanded];\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomInspectorItem.SetFlags(const Value: TInspectorItemFlags);\r\nvar\r\n NewFlags: TInspectorItemFlags;\r\n OldFlags: TInspectorItemFlags;\r\nbegin\r\n NewFlags := Value;\r\n if (iifOwnerDrawListFixed in NewFlags) and (iifOwnerDrawListMaxHeight in NewFlags) then\r\n Exclude(NewFlags, iifOwnerDrawListFixed);\r\n if (iifOwnerDrawListFixed in NewFlags) and (iifOwnerDrawListVariable in NewFlags) then\r\n Exclude(NewFlags, iifOwnerDrawListFixed);\r\n if [iifAllowNonListValues, iifOwnerDrawListFixed, iifOwnerDrawListVariable,\r\n iifOwnerDrawListMaxHeight] * NewFlags <> [] then\r\n Include(NewFlags, iifValueList);\r\n if Flags <> NewFlags then\r\n begin\r\n OldFlags := Flags;\r\n FFlags := NewFlags;\r\n OldFlags := OldFlags * [iifExpanded, iifHidden, iifVisible];\r\n NewFlags := NewFlags * [iifExpanded, iifHidden, iifVisible];\r\n if NewFlags <> OldFlags then\r\n InvalidateList\r\n else\r\n InvalidateItem;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomInspectorItem.SetFocus;\r\nbegin\r\n if (EditCtrl <> nil) and EditCtrl.CanFocus then\r\n EditCtrl.SetFocus\r\n else\r\n Inspector.SetFocus;\r\nend;\r\n\r\nprocedure TJvCustomInspectorItem.SetHeight(Value: Integer);\r\nvar\r\n Factor: Integer;\r\nbegin\r\n case RowSizing.MinHeight of\r\n irsNameHeight:\r\n Dec(Value, Inspector.ActivePainter.GetNameHeight(Self));\r\n irsValueHeight:\r\n Dec(Value, Inspector.ActivePainter.GetValueHeight(Self));\r\n irsItemHeight:\r\n Dec(Value, Inspector.ItemHeight);\r\n else\r\n Dec(Value, RowSizing.MinHeight);\r\n end;\r\n if Value < 0 then\r\n Value := 0;\r\n case RowSizing.SizingFactor of\r\n irsNoReSize:\r\n Factor := 0;\r\n irsNameHeight:\r\n Factor := Value div Inspector.ActivePainter.GetNameHeight(Self);\r\n irsValueHeight:\r\n Factor := Value div Inspector.ActivePainter.GetValueHeight(Self);\r\n irsItemHeight:\r\n Factor := Value div Inspector.ItemHeight;\r\n else\r\n Factor := Value div RowSizing.SizingFactor;\r\n end;\r\n\r\n if Factor <> HeightFactor then\r\n begin\r\n HeightFactor := Factor;\r\n InvalidateItem;\r\n Inspector.CalcImageHeight;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomInspectorItem.SetHeightFactor(Value: Integer);\r\nbegin\r\n FHeight := Value;\r\n Inspector.InvalidateHeight;\r\n InvalidateItem;\r\nend;\r\n\r\nprocedure TJvCustomInspectorItem.SetHidden(Value: Boolean);\r\nbegin\r\n if Value <> Hidden then\r\n if Value then\r\n Flags := Flags + [iifHidden]\r\n else\r\n Flags := Flags - [iifHidden];\r\nend;\r\n\r\nprocedure TJvCustomInspectorItem.SetInspector(const AInspector: TJvCustomInspector);\r\nbegin\r\n if Parent = nil then\r\n FInspector := AInspector;\r\nend;\r\n\r\nprocedure TJvCustomInspectorItem.SetMultiline(const Value: Boolean);\r\nbegin\r\n if Value <> Multiline then\r\n if Value then\r\n Flags := Flags + [iifMultiLine]\r\n else\r\n Flags := Flags - [iifMultiLine];\r\nend;\r\n\r\nprocedure TJvCustomInspectorItem.SetOnCompare(const Value: TInspectorItemSortCompare);\r\nbegin\r\n if @Value <> @OnCompare then\r\n begin\r\n FOnCompare := Value;\r\n if @Value = nil then\r\n SortKind := iskNone;\r\n InvalidateSort;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomInspectorItem.SetParent(const Value: TJvCustomInspectorItem);\r\nbegin\r\n if Parent <> Value then\r\n if Parent = nil then\r\n FParent := Value\r\n else\r\n raise EJvInspectorItem.CreateRes(@RsEJvInspItemHasParent);\r\nend;\r\n\r\nprocedure TJvCustomInspectorItem.SetQualifiedNames(const Value: Boolean);\r\nbegin\r\n if Value <> QualifiedNames then\r\n if Value then\r\n Flags := Flags + [iifQualifiedNames]\r\n else\r\n Flags := Flags - [iifQualifiedNames];\r\nend;\r\n\r\nprocedure TJvCustomInspectorItem.SetReadOnly(const Value: Boolean);\r\nbegin\r\n if Value <> ReadOnly then\r\n if Value then\r\n Flags := Flags + [iifReadonly]\r\n else\r\n Flags := Flags - [iifReadonly];\r\nend;\r\n\r\nprocedure TJvCustomInspectorItem.SetRects(const RectKind: TInspectorPaintRect;\r\n Value: TRect);\r\nbegin\r\n UpdateLastPaintGeneration;\r\n if not EqualRect(Rects[RectKind], Value) then\r\n begin\r\n FRects[RectKind] := Value;\r\n if (RectKind = iprEditValue) and (EditCtrl <> nil) then\r\n begin\r\n EditCtrl.BoundsRect := Rects[iprEditValue];\r\n if DroppedDown then\r\n CloseUp(False);\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomInspectorItem.SetRowSizing(Value: TJvInspectorItemSizing);\r\nbegin\r\n if (Value <> nil) and (Value <> RowSizing) then\r\n RowSizing.Assign(Value);\r\nend;\r\n\r\nprocedure TJvCustomInspectorItem.SetSortKind(Value: TInspectorItemSortKind);\r\nbegin\r\n if (Value = iskCustom) and (@OnCompare = nil) then\r\n Value := iskNone;\r\n if Value <> SortKind then\r\n begin\r\n FSortKind := Value;\r\n InvalidateSort;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomInspectorItem.SetVisible(Value: Boolean);\r\nbegin\r\n if Value <> Visible then\r\n if Value then\r\n Flags := Flags + [iifVisible]\r\n else\r\n Flags := Flags - [iifVisible];\r\nend;\r\n\r\nprocedure TJvCustomInspectorItem.StopTracking;\r\nbegin\r\n if Tracking then\r\n begin\r\n TrackButton(-1, -1);\r\n Tracking := False;\r\n Inspector.MouseCapture := False;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomInspectorItem.TrackButton(X, Y: Integer);\r\nvar\r\n NewState: Boolean;\r\n R: TRect;\r\nbegin\r\n R := Rects[iprEditButton];\r\n NewState := PtInRect(R, Point(X, Y));\r\n if Pressed <> NewState then\r\n begin\r\n Pressed := NewState;\r\n Windows.InvalidateRect(Inspector.Handle, @R, False);\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomInspectorItem.Undo;\r\nbegin\r\n if Editing and Assigned(EditCtrl) then\r\n begin\r\n if Data.IsAssigned then\r\n EditCtrl.Text := DisplayValue\r\n else\r\n EditCtrl.Text := '';\r\n EditCtrl.Modified := False;\r\n EditCtrl.SelectAll;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomInspectorItem.UpdateDisplayOrder(const Item: TJvCustomInspectorItem;\r\n const NewIndex: Integer);\r\nvar\r\n L: TList;\r\nbegin\r\n L := TList.Create;\r\n try\r\n BuildDisplayableList(L);\r\n L.Sort(DisplayIndexSortCompare);\r\n L.Remove(Item);\r\n L.Insert(NewIndex, Item);\r\n ApplyDisplayIndices(L);\r\n finally\r\n L.Free;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomInspectorItem.UpdateLastPaintGeneration;\r\nbegin\r\n FLastPaintGen := GetInspectorPaintGeneration;\r\nend;\r\n\r\n//NEW: Allow us to read the Name of an attribute from the\r\n// inspector item, since sometimes the data item is nil. Also make it virtual.\r\n// We override this in Category objects.\r\n\r\nfunction TJvCustomInspectorItem.GetName: string;\r\nbegin\r\n if Assigned(FData) then\r\n Result := Self.FData.Name\r\n else\r\n Result := '';\r\nend;\r\n\r\nfunction TJvCustomInspectorItem.Add(const Item: TJvCustomInspectorItem): Integer;\r\nbegin\r\n Result := Count;\r\n Insert(Result, Item);\r\nend;\r\n\r\nprocedure TJvCustomInspectorItem.BeforeDestruction;\r\nbegin\r\n inherited BeforeDestruction;\r\n if Parent <> nil then\r\n Parent.FItems.Remove(Self);\r\n if (Inspector <> nil) and (Inspector.Root <> Self) then\r\n DoneEdit(True);\r\n if Inspector <> nil then\r\n begin\r\n Inspector.RemoveNotifySort(Self);\r\n Inspector.RemoveVisible(Self);\r\n if Inspector.RowSizingItem = Self then\r\n begin\r\n Inspector.RowSizing := False;\r\n Inspector.RowSizingItem := nil;\r\n end;\r\n end;\r\n FItems.Free;\r\n if Data <> nil then\r\n FData.RemoveItem(Self);\r\n FreeAndNil(FRowSizing);\r\n FItems := nil;\r\nend;\r\n\r\nprocedure TJvCustomInspectorItem.Clear;\r\nbegin\r\n Inspector.BeginUpdate;\r\n try\r\n while Count > 0 do\r\n Delete(Count - 1);\r\n finally\r\n Inspector.EndUpdate;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomInspectorItem.Delete(const Index: Integer);\r\nvar\r\n Disp: TJvCustomInspectorItem;\r\nbegin\r\n Disp := Items[Index].GetDisplayParent;\r\n if Inspector.Selected = Items[Index] then\r\n begin\r\n Inspector.SetSelected(Disp);\r\n if Inspector.Selected = Items[Index] then\r\n Inspector.SelectedIndex := -1;\r\n end;\r\n FItems.Delete(Index);\r\n if Disp <> nil then\r\n Disp.InvalidateSort\r\n else\r\n InvalidateSort;\r\nend;\r\n\r\nprocedure TJvCustomInspectorItem.Delete(const Item: TJvCustomInspectorItem);\r\nvar\r\n Idx: Integer;\r\nbegin\r\n Idx := IndexOf(Item);\r\n if Idx > -1 then\r\n Delete(Idx);\r\nend;\r\n\r\nprocedure TJvCustomInspectorItem.Delete(const Data: TJvCustomInspectorData);\r\nvar\r\n Idx: Integer;\r\nbegin\r\n Idx := IndexOf(Data);\r\n if Idx > -1 then\r\n Delete(Idx);\r\nend;\r\n\r\nprocedure TJvCustomInspectorItem.DrawEditor(const ACanvas: TCanvas);\r\nconst\r\n LeftOffs = 3;\r\nvar\r\n R: TRect;\r\n BFlags: Integer;\r\n W, G, I: Integer;\r\nbegin\r\n // This reduces the flickering when dragging the divider bar\r\n if EditCtrl <> nil then\r\n begin\r\n ACanvas.Lock;\r\n try\r\n EditCtrl.PaintTo(ACanvas.Handle, EditCtrl.Left, EditCtrl.Top);\r\n finally\r\n ACanvas.Unlock;\r\n end;\r\n end;\r\n R := Rects[iprEditButton];\r\n if not IsRectEmpty(R) then\r\n begin\r\n BFlags := 0;\r\n if iifValueList in Flags then\r\n begin\r\n if Assigned(EditCtrl) and (not EditCtrl.Enabled) then\r\n BFlags := DFCS_INACTIVE\r\n else\r\n if Pressed then\r\n BFlags := DFCS_FLAT or DFCS_PUSHED;\r\n DrawThemedFrameControl(ACanvas.Handle, R, DFC_SCROLL, BFlags or DFCS_SCROLLCOMBOBOX);\r\n end\r\n else\r\n if iifEditButton in Flags then\r\n begin\r\n if Pressed then\r\n BFlags := BF_FLAT;\r\n {$IFDEF JVCLThemesEnabled}\r\n if ThemeServices.{$IFDEF RTL230_UP}Enabled{$ELSE}ThemesEnabled{$ENDIF RTL230_UP} then\r\n DrawThemedButtonFace(Inspector, ACanvas, R, 0, bsNew, False, Pressed, False, False)\r\n else\r\n {$ENDIF JVCLThemesEnabled}\r\n DrawEdge(ACanvas.Handle, R, EDGE_RAISED, BF_RECT or BF_MIDDLE or BFlags);\r\n W := 2;\r\n G := (RectWidth(R) - 2 * Ord(Pressed) - (3 * W)) div 4;\r\n if G < 1 then\r\n begin\r\n W := 1;\r\n G := (RectWidth(R) - 2 * Ord(Pressed) - (3 * W)) div 4;\r\n end;\r\n if G < 1 then\r\n G := 1;\r\n if G > 3 then\r\n G := 3;\r\n\r\n BFlags := R.Left + (RectWidth(R) - 3 * W - 2 * G) div 2 + Ord(Pressed);\r\n I := R.Top + (RectHeight(R) - W) div 2;\r\n PatBlt(ACanvas.Handle, BFlags, I, W, W, BLACKNESS);\r\n PatBlt(ACanvas.Handle, BFlags + G + W, I, W, W, BLACKNESS);\r\n PatBlt(ACanvas.Handle, BFlags + 2 * G + 2 * W, I, W, W, BLACKNESS);\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomInspectorItem.DrawName(const ACanvas: TCanvas);\r\nvar\r\n ARect: TRect;\r\nbegin\r\n ARect := Rects[iprName];\r\n if (Inspector.ActivePainter <> nil) and (Inspector.ActivePainter.DrawNameEndEllipsis) then\r\n begin\r\n ARect.Right := ARect.Right - 2;\r\n DrawText(ACanvas, PChar(DisplayName), -1, ARect, DT_END_ELLIPSIS);\r\n end\r\n else\r\n begin\r\n ACanvas.TextRect(ARect, ARect.Left, ARect.Top, DisplayName);\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomInspectorItem.DrawValue(const ACanvas: TCanvas);\r\nvar\r\n S: string;\r\n ARect: TRect;\r\n SafeColor: TColor;\r\nbegin\r\n if Data = nil then\r\n S := RsJvInspItemUnInitialized\r\n else\r\n try\r\n if not Data.IsInitialized then\r\n S := RsJvInspItemUnInitialized\r\n else\r\n if not Data.HasValue then\r\n S := RsJvInspItemNoValue\r\n else\r\n if not Data.IsAssigned then\r\n S := RsJvInspItemUnassigned\r\n else\r\n S := DisplayValue;\r\n except\r\n S := RsJvInspItemValueException + ExceptObject.ClassName + ': ' +\r\n Exception(ExceptObject).Message;\r\n end;\r\n ARect := Rects[iprValue];\r\n SafeColor := ACanvas.Brush.Color;\r\n if Editing then\r\n ACanvas.Brush.Color := clWindow;\r\n try\r\n if not Editing then\r\n begin\r\n if not (iifMultiLine in Flags) then\r\n ACanvas.TextRect(ARect, ARect.Left, ARect.Top, S)\r\n else\r\n begin\r\n DrawTextEx(ACanvas, PChar(S), Length(S), ARect, DT_EDITCONTROL or DT_WORDBREAK, nil);\r\n end;\r\n end\r\n else\r\n begin\r\n ARect := Rects[iprValueArea];\r\n Inc(ARect.Top);\r\n ACanvas.FillRect(ARect);\r\n DrawEditor(ACanvas);\r\n end;\r\n finally\r\n if Editing then\r\n ACanvas.Brush.Color := SafeColor;\r\n end;\r\nend;\r\n\r\nfunction TJvCustomInspectorItem.EditFocused: Boolean;\r\nbegin\r\n Result := (EditCtrl <> nil) and EditCtrl.Focused;\r\nend;\r\n\r\nprocedure TJvCustomInspectorItem.ExpandItems(AExpand: Boolean);\r\nvar\r\n i: Integer;\r\nbegin\r\n for i := 0 to Count - 1 do\r\n if Items[i].HasViewableItems then\r\n begin\r\n Items[i].Expanded := AExpand;\r\n Items[i].ExpandItems(AExpand);\r\n end;\r\nend;\r\n\r\nfunction TJvCustomInspectorItem.HasViewableItems: Boolean;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := False;\r\n I := 0;\r\n while (I < Count) and not Result do\r\n begin\r\n Result := (iifVisible in Items[I].Flags) and (not (iifHidden in Items[I].Flags) or\r\n ((iifExpanded in Items[I].Flags) and Items[I].HasViewableItems));\r\n Inc(I);\r\n end;\r\nend;\r\n\r\nfunction TJvCustomInspectorItem.IndexOf(const Item: TJvCustomInspectorItem): Integer;\r\nbegin\r\n Result := Pred(Count);\r\n while (Result > -1) and (Items[Result] <> Item) do\r\n Dec(Result);\r\nend;\r\n\r\nfunction TJvCustomInspectorItem.IndexOf(const Data: TJvCustomInspectorData): Integer;\r\nbegin\r\n Result := Pred(Count);\r\n while (Result > -1) and (Items[Result].Data <> Data) do\r\n Dec(Result);\r\nend;\r\n\r\n//=== { TJvInspectorListBox } ================================================\r\n\r\ntype\r\n TJvInspectorListBox = class(TJvPopupListBox)\r\n private\r\n FOnValueSelect: TNotifyEvent;\r\n FOnDeactivate: TNotifyEvent;\r\n FNCClick: Boolean;\r\n FClicking: Boolean;\r\n FItem: TJvCustomInspectorItem;\r\n protected\r\n procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;\r\n procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;\r\n public\r\n property OnValueSelect: TNotifyEvent read FOnValueSelect write FOnValueSelect;\r\n property OnDeactivate: TNotifyEvent read FOnDeactivate write FOnDeactivate;\r\n property Item: TJvCustomInspectorItem read FItem write FItem;\r\n end;\r\n\r\nprocedure TJvInspectorListBox.MouseDown(Button: TMouseButton; Shift: TShiftState;\r\n X, Y: Integer);\r\nvar\r\n R: TRect;\r\n Pt: TPoint;\r\nbegin\r\n R := Rect(0, 0, Width, Height);\r\n Pt := Point(X, Y);\r\n\r\n if PtInRect(R, Pt) then\r\n begin\r\n if not PtInRect(ClientRect, Pt) then\r\n FNCClick := True;\r\n FClicking := True;\r\n inherited MouseDown(Button, Shift, X, Y);\r\n end\r\n else\r\n FOnDeactivate(Self);\r\nend;\r\n\r\nprocedure TJvInspectorListBox.MouseUp(Button: TMouseButton; Shift: TShiftState;\r\n X, Y: Integer);\r\nvar\r\n R: TRect;\r\n Pt: TPoint;\r\nbegin\r\n R := Rect(0, 0, Width, Height);\r\n Pt := Point(X, Y);\r\n\r\n if FNCClick then\r\n inherited MouseUp(Button, Shift, X, Y)\r\n else\r\n if FClicking then\r\n begin\r\n if PtInRect(ClientRect, Pt) then\r\n FOnValueSelect(Self)\r\n else\r\n FOnDeactivate(Self);\r\n end\r\n else\r\n // MouseUps where FClicking is False\r\n // have originated in the item that\r\n // opened the list, let it know that\r\n // the mouse has gone up again.\r\n FItem.MouseUp(Button, Shift, X, Y);\r\n\r\n FClicking := False;\r\n FNCClick := False;\r\nend;\r\n\r\nprocedure TJvCustomInspectorItem.InitEdit;\r\nvar\r\n Edit: TEdit;\r\n Memo: TMemo;\r\nbegin\r\n SetEditing(CanEdit);\r\n if Editing and (FUpdateEditCtrl = 0) then\r\n begin\r\n if Multiline then\r\n begin\r\n Memo := TJvInspectorMemo.Create(Inspector);\r\n Memo.OnContextPopup := Inspector.FOnEditorContextPopup;\r\n Memo.OnKeyUp := EditKeyUp;\r\n Memo.OnKeyPress := EditKeyPress;\r\n Memo.WordWrap := True;\r\n Memo.WantReturns := False;\r\n Memo.ScrollBars := ssVertical;\r\n Memo.OnExit := EditFocusLost;\r\n TJvInspectorMemo(Memo).OnKillFocus := EditKillFocus;\r\n SetEditCtrl(Memo);\r\n\r\n if Assigned(Inspector.BeforeEdit) then\r\n Inspector.BeforeEdit(Inspector as TObject, Self, TCustomEdit(Memo));\r\n end\r\n else\r\n begin\r\n Edit := TJvInspectorEdit.Create(Inspector);\r\n Edit.OnContextPopup := Inspector.FOnEditorContextPopup;\r\n Edit.OnKeyUp := EditKeyUp;\r\n Edit.OnKeyPress := EditKeyPress;\r\n Edit.OnExit := EditFocusLost;\r\n TJvInspectorEdit(Edit).OnKillFocus := EditKillFocus;\r\n SetEditCtrl(Edit);\r\n\r\n if Assigned(Inspector.BeforeEdit) then\r\n Inspector.BeforeEdit(Inspector as TObject, Self, Edit as TCustomEdit);\r\n end;\r\n if iifEditFixed in Flags then\r\n begin\r\n TCustomEditAccessProtected(EditCtrl).ReadOnly := True;\r\n TCustomEditAccessProtected(EditCtrl).TabStop := False;\r\n TCustomEditAccessProtected(EditCtrl).Color := Inspector.Canvas.Brush.Color;\r\n end\r\n else\r\n TCustomEditAccessProtected(EditCtrl).Color := clWindow;\r\n FEditWndPrc := EditCtrl.WindowProc;\r\n EditCtrl.WindowProc := Edit_WndProc;\r\n TCustomEditAccessProtected(EditCtrl).AutoSize := False;\r\n if iifValueList in Flags then\r\n begin\r\n FListBox := TJvInspectorListBox.Create(Inspector);\r\n ListBox.Parent := EditCtrl;\r\n ListBox.Visible := False;\r\n TListBox(ListBox).IntegralHeight := not (iifOwnerDrawListVariable in Flags);\r\n //TJvInspectorListBox(ListBox).OnMouseUp := ListMouseUp;\r\n TJvInspectorListBox(ListBox).OnValueSelect := ListValueSelect;\r\n TJvInspectorListBox(ListBox).OnDeactivate := ListDeactivate;\r\n TJvInspectorListBox(ListBox).Item := Self;\r\n\r\n TListBox(ListBox).ItemHeight := 11;\r\n if (iifOwnerDrawListFixed in Flags) or (iifOwnerDrawListMaxHeight in Flags) then\r\n TListBox(ListBox).Style := lbOwnerDrawFixed\r\n else\r\n if iifOwnerDrawListVariable in Flags then\r\n TListBox(ListBox).Style := lbOwnerDrawVariable;\r\n TListBox(ListBox).OnDrawItem := DoDrawListItem;\r\n TListBox(ListBox).OnMeasureItem := DoMeasureListItem;\r\n TListBox(ListBox).OnExit := ListExit;\r\n end;\r\n TCustomEditAccessProtected(EditCtrl).Font.Assign(Inspector.Font);\r\n EditCtrl.BoundsRect := Rects[iprEditValue];\r\n TCustomEditAccessProtected(EditCtrl).OnKeyDown := EditKeyDown;\r\n TCustomEditAccessProtected(EditCtrl).OnKeyPress := EditKeyPress;\r\n TCustomEditAccessProtected(EditCtrl).OnMouseDown := EditMouseDown;\r\n TCustomEditAccessProtected(EditCtrl).OnMouseMove := EditMouseMove;\r\n TCustomEditAccessProtected(EditCtrl).OnMouseUp := EditMouseUp;\r\n TCustomEditAccessProtected(EditCtrl).OnChange := EditChange;\r\n EditCtrl.Visible := True;\r\n if Data.IsAssigned then\r\n EditCtrl.Text := DisplayValue\r\n else\r\n EditCtrl.Text := '';\r\n FLastEditCtrlText := EditCtrl.Text;\r\n EditCtrl.Modified := False;\r\n EditCtrl.SelectAll;\r\n if EditCtrl.CanFocus and Inspector.Focused then\r\n EditCtrl.SetFocus;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomInspectorItem.DoneEdit(const CancelEdits: Boolean);\r\nbegin\r\n if Editing and (FUpdateEditCtrl = 0) then\r\n begin\r\n if DroppedDown then\r\n CloseUp(False);\r\n if not CancelEdits and\r\n (not Data.IsAssigned or (DisplayValue <> EditCtrl.Text) or\r\n (AutoUpdate and (FLastEditCtrlText <> EditCtrl.Text))) then\r\n begin\r\n Apply;\r\n InvalidateItem;\r\n end;\r\n FreeAndNil(FListBox);\r\n\r\n SetEditCtrl(nil);\r\n FEditWndPrc := nil;\r\n end;\r\n FEditing := False;\r\nend;\r\n\r\nprocedure TJvCustomInspectorItem.Insert(const Index: Integer; const Item: TJvCustomInspectorItem);\r\nvar\r\n Disp: TJvCustomInspectorItem;\r\nbegin\r\n Item.SetParent(Self);\r\n FItems.Insert(Index, Item);\r\n Disp := Item.GetDisplayParent;\r\n if Disp <> nil then\r\n Disp.InvalidateSort\r\n else\r\n InvalidateSort;\r\nend;\r\n\r\nprocedure TJvCustomInspectorItem.ScrollInView;\r\nvar\r\n ViewIdx: Integer;\r\n Item: TJvCustomInspectorItem;\r\n YDelta: Integer;\r\n BandIdx: Integer;\r\n FirstBand: Integer;\r\n BandsVisible: Integer;\r\nbegin\r\n if not Assigned(Inspector) then\r\n Exit;\r\n if csDestroying in Inspector.ComponentState then\r\n Exit; // bugfix attempt. WAP.Self\r\n\r\n {$IFDEF MSWINDOWS}\r\n // OutputDebugString(PChar('ScrollIntoView: FDisplayName'));\r\n {$ENDIF MSWINDOWS}\r\n ViewIdx := Inspector.VisibleIndex(Self);\r\n if ViewIdx < 0 then\r\n begin\r\n { Find visible parent }\r\n Item := Parent;\r\n while (Item <> nil) and (ViewIdx < 0) do\r\n begin\r\n ViewIdx := Inspector.VisibleIndex(Item);\r\n if ViewIdx < 0 then\r\n Item := Item.Parent;\r\n end;\r\n end;\r\n if ViewIdx > -1 then\r\n begin\r\n if not Inspector.UseBands then\r\n begin\r\n if Inspector.TopIndex > ViewIdx then\r\n Inspector.TopIndex := ViewIdx\r\n else\r\n if (Inspector.IdxToY(ViewIdx) - Inspector.IdxToY(Inspector.TopIndex) + Height) > Inspector.ClientHeight then\r\n begin\r\n YDelta := (Inspector.IdxToY(ViewIdx) + Height - Inspector.ClientHeight - Inspector.IdxToY(Inspector.TopIndex));\r\n ViewIdx := Inspector.TopIndex;\r\n while (YDelta > 0) and (ViewIdx < Inspector.VisibleCount) do\r\n begin\r\n Dec(YDelta, Inspector.VisibleItems[ViewIdx].Height);\r\n Inc(ViewIdx);\r\n end;\r\n if ViewIdx < Inspector.VisibleCount then\r\n Inspector.TopIndex := ViewIdx;\r\n end;\r\n end\r\n else\r\n begin\r\n // Find band and scroll that band into the view\r\n BandIdx := Inspector.GetBandFor(ViewIdx);\r\n FirstBand := Inspector.GetBandFor(Inspector.TopIndex);\r\n BandsVisible := Inspector.ClientWidth div Inspector.BandWidth;\r\n if (BandIdx < FirstBand) or (BandIdx >= (FirstBand + BandsVisible)) then\r\n if BandIdx < FirstBand then\r\n Inspector.TopIndex := Integer(Inspector.BandStarts[BandIdx])\r\n else\r\n begin\r\n FirstBand := BandIdx - BandsVisible + 1;\r\n if (FirstBand > -1) and (FirstBand < Inspector.BandStarts.Count) then\r\n Inspector.TopIndex := Integer(Inspector.BandStarts[FirstBand]);\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomInspectorItem.Sort;\r\nbegin\r\n case SortKind of\r\n iskNone:\r\n NaturalSort;\r\n iskName:\r\n AlphaSort;\r\n iskCustom:\r\n DataSort;\r\n end;\r\nend;\r\n\r\n//=== { TJvInspectorCustomCategoryItem } =====================================\r\n\r\nfunction TJvInspectorCustomCategoryItem.GetName: string;\r\nbegin\r\n Result := FName;\r\nend;\r\n\r\nfunction TJvInspectorCustomCategoryItem.IsCategory: Boolean;\r\nbegin\r\n Result := True;\r\nend;\r\n\r\nprocedure TJvInspectorCustomCategoryItem.SetFlags(const Value: TInspectorItemFlags);\r\nvar\r\n NewFlags: TInspectorItemFlags;\r\nbegin\r\n NewFlags := Value - [iifAutoUpdate, iifMultiLine, iifValueList,\r\n iifAllowNonListValues, iifOwnerDrawListFixed, iifOwnerDrawListVariable,\r\n iifOwnerDrawListMaxHeight, iifEditButton] + [iifReadonly, iifEditFixed];\r\n inherited SetFlags(NewFlags);\r\nend;\r\n\r\n//=== { TJvInspectorCompoundColumn } =========================================\r\n\r\nconstructor TJvInspectorCompoundColumn.Create(const AParent: TJvInspectorCustomCompoundItem;\r\n const AItem: TJvCustomInspectorItem);\r\nbegin\r\n inherited Create;\r\n FParent := AParent;\r\n Item := AItem;\r\nend;\r\n\r\nfunction TJvInspectorCompoundColumn.GetItem: TJvCustomInspectorItem;\r\nbegin\r\n Result := FItem;\r\nend;\r\n\r\nfunction TJvInspectorCompoundColumn.GetWidth: Integer;\r\nbegin\r\n Result := FWidth;\r\nend;\r\n\r\nfunction TJvInspectorCompoundColumn.GetWidthSet: Integer;\r\nbegin\r\n Result := FWidthSet;\r\nend;\r\n\r\nprocedure TJvInspectorCompoundColumn.SetItem(Value: TJvCustomInspectorItem);\r\nbegin\r\n if Item <> Value then\r\n begin\r\n if (Value <> nil) and (Value.Parent <> Parent) then\r\n raise EJvInspectorItem.CreateRes(@RsEJvInspItemNotAChild);\r\n if Item <> nil then\r\n Parent.Add(Item);\r\n FItem := Value;\r\n if Item <> nil then\r\n Parent.FItems.Extract(Item);\r\n FWidthSet := 0;\r\n FWidth := -1;\r\n Parent.InvalidateList;\r\n end;\r\nend;\r\n\r\nprocedure TJvInspectorCompoundColumn.SetWidth(Value: Integer);\r\nbegin\r\n if Value <> Width then\r\n FWidth := Value;\r\nend;\r\n\r\nprocedure TJvInspectorCompoundColumn.SetWidthExternal(Value: Integer);\r\nbegin\r\n if Value <> WidthSet then\r\n begin\r\n SetWidthSet(Value);\r\n TJvInspectorCustomCompoundItem(Item.Parent).RecalcColumnWidths(Self);\r\n end;\r\nend;\r\n\r\nprocedure TJvInspectorCompoundColumn.SetWidthSet(Value: Integer);\r\nbegin\r\n if Value <> WidthSet then\r\n begin\r\n FWidthSet := Value;\r\n FWidth := -1;\r\n end;\r\nend;\r\n\r\nprocedure TJvInspectorCompoundColumn.BeforeDestruction;\r\nbegin\r\n Item := nil;\r\n inherited BeforeDestruction;\r\nend;\r\n\r\n//=== { TJvInspectorCustomCompoundItem } =====================================\r\n\r\nconstructor TJvInspectorCustomCompoundItem.Create(const AParent: TJvCustomInspectorItem;\r\n const AData: TJvCustomInspectorData);\r\nbegin\r\n inherited Create(AParent, AData);\r\n FColumns := TObjectList.Create;\r\nend;\r\n\r\nfunction TJvInspectorCustomCompoundItem.AddColumnPrim(const Item: TJvCustomInspectorItem): Integer;\r\nbegin\r\n Result := ColumnCount;\r\n InsertColumnPrim(Result, Item);\r\nend;\r\n\r\nfunction TJvInspectorCustomCompoundItem.AddColumnPrim(const ItemIndex: Integer): Integer;\r\nbegin\r\n Result := ColumnCount;\r\n InsertColumnPrim(Result, Items[ItemIndex]);\r\nend;\r\n\r\nprocedure TJvInspectorCustomCompoundItem.DeleteColumnPrim(const Column: TJvInspectorCompoundColumn);\r\nvar\r\n Idx: Integer;\r\nbegin\r\n Idx := IndexOfColumnPrim(Column);\r\n if Idx > -1 then\r\n DeleteColumnPrim(Idx)\r\n else\r\n raise EJvInspectorItem.CreateRes(@RsEJvInspItemColNotFound);\r\nend;\r\n\r\nprocedure TJvInspectorCustomCompoundItem.DeleteColumnPrim(const Index: Integer);\r\nbegin\r\n FColumns.Delete(Index);\r\n if SelectedColumnIndex > ColumnCount then\r\n SelectedColumnIndex := ColumnCount - 1;\r\nend;\r\n\r\nprocedure TJvInspectorCustomCompoundItem.DeleteColumnPrim(const Item: TJvCustomInspectorItem);\r\nvar\r\n Idx: Integer;\r\nbegin\r\n Idx := IndexOfColumnPrim(Item);\r\n if Idx > -1 then\r\n DeleteColumnPrim(Idx)\r\n else\r\n raise EJvInspectorItem.CreateRes(@RsEJvInspItemItemIsNotCol);\r\nend;\r\n\r\nprocedure TJvInspectorCustomCompoundItem.DivideRect(const RectKind: TInspectorPaintRect; const Value: TRect);\r\nvar\r\n VisibleColCount: Integer;\r\n I: Integer;\r\n WidthAvail: Integer;\r\n CurRect: TRect;\r\n WidthUsedInt: Integer;\r\n WidthUsedDbl: Double;\r\n ColWidth: Double;\r\n SaveItem: TJvCustomInspectorItem;\r\nbegin\r\n if Inspector.ActivePainter = nil then\r\n raise EJvInspectorItem.CreateRes(@RsEJvAssertInspectorPainter);\r\n VisibleColCount := 0;\r\n for I := 0 to ColumnCount - 1 do\r\n if Columns[I].Width > 0 then\r\n Inc(VisibleColCount);\r\n WidthAvail := RectWidth(Value);\r\n if VisibleColCount > 1 then\r\n Dec(WidthAvail, Pred(VisibleColCount) * Inspector.ActivePainter.DividerWidth);\r\n CurRect := Value;\r\n WidthUsedInt := 0;\r\n WidthUsedDbl := 0;\r\n for I := 0 to ColumnCount - 1 do\r\n begin\r\n ColWidth := (Columns[I].Width / 100.0) * WidthAvail;\r\n WidthUsedDbl := WidthUsedDbl + ColWidth;\r\n Inc(WidthUsedInt, Trunc(ColWidth));\r\n if WidthUsedDbl - WidthUsedInt > 1 then\r\n begin\r\n Inc(WidthUsedInt);\r\n ColWidth := ColWidth + 1;\r\n end;\r\n CurRect.Right := CurRect.Left + Trunc(ColWidth);\r\n Columns[I].Item.SetRects(RectKind, CurRect);\r\n if RectKind = iprValue then\r\n begin\r\n SaveItem := Inspector.ActivePainter.Item;\r\n try\r\n Inspector.ActivePainter.Item := Columns[I].Item;\r\n Inspector.ActivePainter.CalcEditBasedRects;\r\n finally\r\n Inspector.ActivePainter.Item := SaveItem;\r\n end;\r\n end;\r\n CurRect.Left := CurRect.Right + Inspector.ActivePainter.DividerWidth;\r\n end;\r\nend;\r\n\r\nprocedure TJvInspectorCustomCompoundItem.EditKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);\r\nbegin\r\n if (SelectedColumn <> nil) and SelectedColumn.Item.Editing then\r\n SelectedColumn.Item.EditKeyDown(Sender, Key, Shift)\r\n else\r\n inherited EditKeyDown(Sender, Key, Shift);\r\nend;\r\n\r\nfunction TJvInspectorCustomCompoundItem.GetColumnCount: Integer;\r\nbegin\r\n if FColumns <> nil then\r\n Result := FColumns.Count\r\n else\r\n Result := 0;\r\nend;\r\n\r\nfunction TJvInspectorCustomCompoundItem.GetColumns(I: Integer): TJvInspectorCompoundColumn;\r\nbegin\r\n Result := TJvInspectorCompoundColumn(FColumns[I]);\r\nend;\r\n\r\nfunction TJvInspectorCustomCompoundItem.GetDisplayName: string;\r\nbegin\r\n if SingleName then\r\n begin\r\n if SingleNameUseFirstCol then\r\n begin\r\n if ColumnCount > 0 then\r\n Result := Columns[0].Item.DisplayName\r\n else\r\n Result := '';\r\n if (Parent <> nil) and (iifQualifiedNames in Parent.Flags) then\r\n Result := Parent.DisplayName + '.' + Result;\r\n end\r\n else\r\n Result := inherited GetDisplayName;\r\n end;\r\nend;\r\n\r\nfunction TJvInspectorCustomCompoundItem.GetEditCtrl: TCustomEdit;\r\nbegin\r\n if SelectedColumn <> nil then\r\n Result := SelectedColumn.Item.EditCtrl\r\n else\r\n Result := nil;\r\nend;\r\n\r\nfunction TJvInspectorCustomCompoundItem.GetEditCtrlDestroying: Boolean;\r\nbegin\r\n Result := (SelectedColumn <> nil) and SelectedColumn.Item.EditCtrlDestroying;\r\nend;\r\n\r\nfunction TJvInspectorCustomCompoundItem.GetEditing: Boolean;\r\nbegin\r\n Result := (SelectedColumn <> nil) and SelectedColumn.Item.Editing;\r\nend;\r\n\r\nfunction TJvInspectorCustomCompoundItem.GetSelectedColumn: TJvInspectorCompoundColumn;\r\nbegin\r\n if SelectedColumnIndex > -1 then\r\n Result := Columns[SelectedColumnIndex]\r\n else\r\n Result := nil;\r\nend;\r\n\r\nfunction TJvInspectorCustomCompoundItem.GetSelectedColumnIndex: Integer;\r\nbegin\r\n Result := FSelectedColumnIdx;\r\nend;\r\n\r\nfunction TJvInspectorCustomCompoundItem.GetSingleName: Boolean;\r\nbegin\r\n Result := icifSingleName in CompoundItemFlags;\r\nend;\r\n\r\nfunction TJvInspectorCustomCompoundItem.GetSingleNameUseFirstCol: Boolean;\r\nbegin\r\n Result := icifSingleNameUseFirstCol in CompoundItemFlags;\r\nend;\r\n\r\nfunction TJvInspectorCustomCompoundItem.IndexOfColumnPrim(const Col: TJvInspectorCompoundColumn): Integer;\r\nbegin\r\n Result := ColumnCount - 1;\r\n while (Result >= 0) and (Columns[Result] <> Col) do\r\n Dec(Result);\r\nend;\r\n\r\nfunction TJvInspectorCustomCompoundItem.IndexOfColumnPrim(const Item: TJvCustomInspectorItem): Integer;\r\nbegin\r\n Result := ColumnCount - 1;\r\n while (Result >= 0) and (Columns[Result].Item <> Item) do\r\n Dec(Result);\r\nend;\r\n\r\nprocedure TJvInspectorCustomCompoundItem.InsertColumnPrim(const Index: Integer; const Item: TJvCustomInspectorItem);\r\nvar\r\n Col: TJvInspectorCompoundColumn;\r\nbegin\r\n Col := TJvInspectorCompoundColumn.Create(Self, Item);\r\n try\r\n FColumns.Insert(Index, Col);\r\n RecalcColumnWidths(Col);\r\n except\r\n Col.Free;\r\n raise;\r\n end;\r\nend;\r\n\r\nprocedure TJvInspectorCustomCompoundItem.InsertColumnPrim(const Index, ItemIndex: Integer);\r\nbegin\r\n InsertColumnPrim(Index, Items[ItemIndex]);\r\nend;\r\n\r\nprocedure TJvInspectorCustomCompoundItem.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := ColumnCount - 1 downto 0 do\r\n if PtInRect(Columns[I].Item.Rects[iprName], Point(X, Y)) or\r\n PtInRect(Columns[I].Item.Rects[iprValue], Point(X, Y)) then\r\n begin\r\n SelectedColumnIndex := I;\r\n Columns[I].Item.MouseDown(Button, Shift, X, Y);\r\n Break;\r\n end;\r\nend;\r\n\r\nprocedure TJvInspectorCustomCompoundItem.RecalcColumnWidths(const SetColumn: TJvInspectorCompoundColumn = nil);\r\nvar\r\n Idx: Integer;\r\n PercentLeft: Integer;\r\n I: Integer;\r\n DivideOver: array of Integer;\r\n\r\n procedure AddDivide(const DivideIndex: Integer);\r\n begin\r\n SetLength(DivideOver, Length(DivideOver) + 1);\r\n DivideOver[High(DivideOver)] := DivideIndex;\r\n end;\r\n\r\nbegin\r\n if SetColumn <> nil then\r\n begin\r\n Idx := IndexOfColumnPrim(SetColumn);\r\n PercentLeft := 100 - SetColumn.WidthSet;\r\n if SetColumn.WidthSet > 0 then\r\n SetColumn.SetWidth(SetColumn.WidthSet)\r\n else\r\n AddDivide(Idx);\r\n end\r\n else\r\n begin\r\n Idx := -1;\r\n PercentLeft := 100;\r\n end;\r\n for I := 0 to ColumnCount - 1 do\r\n begin\r\n if I <> Idx then\r\n begin\r\n if Columns[I].WidthSet <> 0 then\r\n begin\r\n if Columns[I].WidthSet <= PercentLeft then\r\n begin\r\n Columns[I].SetWidth(Columns[I].WidthSet);\r\n Dec(PercentLeft, Columns[I].WidthSet);\r\n end\r\n else\r\n begin\r\n Columns[I].SetWidth(PercentLeft);\r\n PercentLeft := 0;\r\n end;\r\n end\r\n else\r\n AddDivide(I);\r\n end;\r\n end;\r\n if Length(DivideOver) > 0 then\r\n begin\r\n Idx := PercentLeft mod Length(DivideOver);\r\n PercentLeft := PercentLeft div Length(DivideOver);\r\n for I := 0 to High(DivideOver) do\r\n begin\r\n if I <> 0 then\r\n Columns[DivideOver[I]].SetWidth(PercentLeft)\r\n else\r\n Columns[DivideOver[I]].SetWidth(PercentLeft + Idx);\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvInspectorCustomCompoundItem.SetCompoundItemFlags(Value: TInspectorCompoundItemFlags);\r\nbegin\r\n // Check the difference: if icifSingleName is removed, remove icifSingleNameUseFirstCol as well\r\n if ((CompoundItemFlags - Value) * [icifSingleName]) <> [] then\r\n Exclude(Value, icifSingleNameUseFirstCol)\r\n else\r\n if Value = [icifSingleNameUseFirstCol] then\r\n Include(Value, icifSingleName);\r\n if Value <> CompoundItemFlags then\r\n begin\r\n FCompoundItemFlags := Value;\r\n InvalidateItem;\r\n end;\r\nend;\r\n\r\nprocedure TJvInspectorCustomCompoundItem.SetDisplayName(Value: string);\r\nvar\r\n S: string;\r\nbegin\r\n if SingleName then\r\n begin\r\n if SingleNameUseFirstCol then\r\n begin\r\n if (Parent <> nil) and (iifQualifiedNames in Parent.Flags) then\r\n S := Parent.DisplayName + '.';\r\n if S <> Copy(Value, 1, Length(S)) then\r\n System.Delete(Value, 1, Length(S));\r\n if (ColumnCount > 0) and (Columns[0].Item.DisplayName <> Value) then\r\n Columns[0].Item.DisplayName := Value;\r\n end\r\n else\r\n inherited SetDisplayName(Value);\r\n end;\r\nend;\r\n\r\nprocedure TJvInspectorCustomCompoundItem.SetEditing(const Value: Boolean);\r\nbegin\r\n if SelectedColumn <> nil then\r\n SelectedColumn.Item.SetEditing(Value);\r\nend;\r\n\r\nprocedure TJvInspectorCustomCompoundItem.SetFlags(const Value: TInspectorItemFlags);\r\nvar\r\n NewFlags: TInspectorItemFlags;\r\nbegin\r\n NewFlags := Value - [iifQualifiedNames, iifAutoUpdate, iifMultiLine,\r\n iifValueList, iifAllowNonListValues, iifOwnerDrawListFixed,\r\n iifOwnerDrawListVariable, iifOwnerDrawListMaxHeight, iifEditButton] + [iifReadonly,\r\n iifEditFixed];\r\n inherited SetFlags(NewFlags);\r\nend;\r\n\r\nprocedure TJvInspectorCustomCompoundItem.SetFocus;\r\nbegin\r\n if SelectedColumn <> nil then\r\n SelectedColumn.Item.SetFocus;\r\nend;\r\n\r\nprocedure TJvInspectorCustomCompoundItem.SetRects(const RectKind: TInspectorPaintRect; Value: TRect);\r\nbegin\r\n inherited SetRects(RectKind, Value);\r\n case RectKind of\r\n iprName, iprValue:\r\n DivideRect(RectKind, Value);\r\n end;\r\nend;\r\n\r\nprocedure TJvInspectorCustomCompoundItem.SetSelectedColumn(Value: TJvInspectorCompoundColumn);\r\nbegin\r\n SelectedColumnIndex := IndexOfColumnPrim(Value);\r\nend;\r\n\r\nprocedure TJvInspectorCustomCompoundItem.SetSelectedColumnIndex(Value: Integer);\r\nbegin\r\n if Value <> SelectedColumnIndex then\r\n begin\r\n DoneEdit(False);\r\n FSelectedColumnIdx := Value;\r\n InitEdit;\r\n InvalidateItem;\r\n end;\r\nend;\r\n\r\nprocedure TJvInspectorCustomCompoundItem.SetSingleName(Value: Boolean);\r\nbegin\r\n if Value <> SingleName then\r\n if Value then\r\n CompoundItemFlags := CompoundItemFlags + [icifSingleName]\r\n else\r\n CompoundItemFlags := CompoundItemFlags - [icifSingleName];\r\nend;\r\n\r\nprocedure TJvInspectorCustomCompoundItem.SetSingleNameUseFirstCol(Value: Boolean);\r\nbegin\r\n if Value <> SingleNameUseFirstCol then\r\n if Value then\r\n CompoundItemFlags := CompoundItemFlags + [icifSingleNameUseFirstCol]\r\n else\r\n CompoundItemFlags := CompoundItemFlags - [icifSingleNameUseFirstCol];\r\nend;\r\n\r\nprocedure TJvInspectorCustomCompoundItem.BeforeDestruction;\r\nbegin\r\n FreeAndNil(FColumns);\r\n FSelectedColumnIdx := -1;\r\n inherited BeforeDestruction;\r\nend;\r\n\r\nprocedure TJvInspectorCustomCompoundItem.DoneEdit(const CancelEdits: Boolean);\r\nbegin\r\n if SelectedColumn <> nil then\r\n SelectedColumn.Item.DoneEdit(CancelEdits);\r\nend;\r\n\r\nprocedure TJvInspectorCustomCompoundItem.DrawEditor(const ACanvas: TCanvas);\r\nbegin\r\nend;\r\n\r\nprocedure TJvInspectorCustomCompoundItem.DrawName(const ACanvas: TCanvas);\r\nvar\r\n RTop: Integer;\r\n RBottom: Integer;\r\n LastI: Integer;\r\n I: Integer;\r\n Col: TJvInspectorCompoundColumn;\r\nbegin\r\n if SingleName then\r\n begin\r\n if Inspector.Selected = Self then\r\n begin\r\n if Inspector.Focused then\r\n begin\r\n ACanvas.Brush.Color := Inspector.ActivePainter.SelectedColor;\r\n ACanvas.Font := Inspector.ActivePainter.SelectedFont;\r\n end\r\n else\r\n begin\r\n ACanvas.Brush.Color := Inspector.ActivePainter.HideSelectColor;\r\n ACanvas.Font := Inspector.ActivePainter.HideSelectFont;\r\n end;\r\n with Rects[iprNameArea] do\r\n ACanvas.FillRect(Rect(Left, Top, Right, Bottom));\r\n end\r\n else\r\n begin\r\n ACanvas.Brush.Color := Inspector.ActivePainter.BackgroundColor;\r\n ACanvas.Font := Inspector.ActivePainter.NameFont;\r\n end;\r\n inherited DrawName(ACanvas);\r\n end\r\n else\r\n begin\r\n with Rects[iprNameArea] do\r\n begin\r\n RTop := Top;\r\n RBottom := Bottom;\r\n end;\r\n LastI := ColumnCount - 1;\r\n while (LastI > 0) and (Columns[LastI].Width < 1) do\r\n Dec(LastI);\r\n for I := 0 to LastI do\r\n begin\r\n Col := Columns[I];\r\n if Col.Width >= 0 then\r\n begin\r\n if (Inspector.Selected = Self) and (I = SelectedColumnIndex) then\r\n begin\r\n if Inspector.Focused then\r\n begin\r\n ACanvas.Brush.Color := Inspector.ActivePainter.SelectedColor;\r\n ACanvas.Font := Inspector.ActivePainter.SelectedFont;\r\n end\r\n else\r\n begin\r\n ACanvas.Brush.Color := Inspector.ActivePainter.HideSelectColor;\r\n ACanvas.Font := Inspector.ActivePainter.HideSelectFont;\r\n end;\r\n with Col.Item.Rects[iprName] do\r\n ACanvas.FillRect(Rect(Left, RTop, Right, RBottom));\r\n end\r\n else\r\n begin\r\n ACanvas.Brush.Color := Inspector.ActivePainter.BackgroundColor;\r\n ACanvas.Font := Inspector.ActivePainter.NameFont;\r\n end;\r\n Col.Item.DrawName(ACanvas);\r\n if I <> LastI then\r\n with Col.Item.Rects[iprName] do\r\n Inspector.ActivePainter.PaintDivider(Right - 1, Top + 1, Bottom - 2);\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvInspectorCustomCompoundItem.DrawValue(const ACanvas: TCanvas);\r\nvar\r\n LastI: Integer;\r\n I: Integer;\r\n Col: TJvInspectorCompoundColumn;\r\nbegin\r\n LastI := ColumnCount - 1;\r\n while (LastI > 0) and (Columns[LastI].Width < 1) do\r\n Dec(LastI);\r\n for I := 0 to LastI do\r\n begin\r\n Col := Columns[I];\r\n if Col.Width >= 0 then\r\n begin\r\n Col.Item.DrawValue(ACanvas);\r\n if I <> LastI then\r\n with Col.Item.Rects[iprValue] do\r\n Inspector.ActivePainter.PaintDivider(Right - 1, Top + 1, Bottom - 2);\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJvInspectorCustomCompoundItem.EditFocused: Boolean;\r\nbegin\r\n Result := (SelectedColumn <> nil) and (SelectedColumn.Item.EditCtrl <> nil) and\r\n SelectedColumn.Item.EditCtrl.Focused;\r\nend;\r\n\r\nprocedure TJvInspectorCustomCompoundItem.InitEdit;\r\nbegin\r\n if SelectedColumn <> nil then\r\n SelectedColumn.Item.InitEdit;\r\nend;\r\n\r\n//=== { TJvInspectorCompoundItem } ===========================================\r\n\r\nfunction TJvInspectorCompoundItem.AddColumn(const Item: TJvCustomInspectorItem): Integer;\r\nbegin\r\n Result := AddColumnPrim(Item);\r\nend;\r\n\r\nfunction TJvInspectorCompoundItem.AddColumn(const ItemIndex: Integer): Integer;\r\nbegin\r\n Result := AddColumnPrim(ItemIndex);\r\nend;\r\n\r\nprocedure TJvInspectorCompoundItem.DeleteColumn(const Column: TJvInspectorCompoundColumn);\r\nbegin\r\n DeleteColumnPrim(Column);\r\nend;\r\n\r\nprocedure TJvInspectorCompoundItem.DeleteColumn(const Index: Integer);\r\nbegin\r\n DeleteColumnPrim(Index);\r\nend;\r\n\r\nprocedure TJvInspectorCompoundItem.DeleteColumn(const Item: TJvCustomInspectorItem);\r\nbegin\r\n DeleteColumnPrim(Item);\r\nend;\r\n\r\nfunction TJvInspectorCompoundItem.IndexOfColumn(const Col: TJvInspectorCompoundColumn): Integer;\r\nbegin\r\n Result := IndexOfColumnPrim(Col);\r\nend;\r\n\r\nfunction TJvInspectorCompoundItem.IndexOfColumn(const Item: TJvCustomInspectorItem): Integer;\r\nbegin\r\n Result := IndexOfColumnPrim(Item);\r\nend;\r\n\r\nprocedure TJvInspectorCompoundItem.InsertColumn(const Index: Integer; const Item: TJvCustomInspectorItem);\r\nbegin\r\n InsertColumnPrim(Index, Item);\r\nend;\r\n\r\nprocedure TJvInspectorCompoundItem.InsertColumn(const Index, ItemIndex: Integer);\r\nbegin\r\n InsertColumnPrim(Index, ItemIndex);\r\nend;\r\n\r\n//=== { TJvInspectorIntegerItem } ============================================\r\n\r\nfunction TJvInspectorIntegerItem.GetDisplayValue: string;\r\nbegin\r\n Result := JclTypedIntToStr(Integer(Data.AsOrdinal), Data.TypeInfo);\r\nend;\r\n\r\nprocedure TJvInspectorIntegerItem.SetDisplayValue(const Value: string);\r\nvar\r\n TmpOrd: Integer;\r\nbegin\r\n TmpOrd := JclStrToTypedInt(Value, Data.TypeInfo);\r\n if (JclTypeInfo(Data.TypeInfo) as IJclOrdinalRangeTypeInfo).OrdinalType = otULong then\r\n Data.AsOrdinal := Cardinal(TmpOrd)\r\n else\r\n Data.AsOrdinal := TmpOrd;\r\nend;\r\n\r\n//=== { TJvInspectorEnumItem } ===============================================\r\n\r\nfunction TJvInspectorEnumItem.GetDisplayValue: string;\r\nvar\r\n IntVal: Integer;\r\nbegin\r\n IntVal := Ord(Data.AsOrdinal);\r\n if IntVal < 0 then // prevent GetEnumName crash. WAP.\r\n Result := IntToStr(IntVal)\r\n else\r\n Result := GetEnumName(Data.TypeInfo, IntVal);\r\nend;\r\n\r\nprocedure TJvInspectorEnumItem.GetValueList(const Strings: TStrings);\r\nvar\r\n EnumInfo: IJclEnumerationTypeInfo;\r\n I: Integer;\r\nbegin\r\n EnumInfo := JclTypeInfo(Data.TypeInfo) as IJclEnumerationTypeInfo;\r\n for I := EnumInfo.MinValue to EnumInfo.MaxValue do\r\n if Trim(EnumInfo.Names[I]) <> '' then\r\n Strings.Add(EnumInfo.Names[I]);\r\nend;\r\n\r\nprocedure TJvInspectorEnumItem.SetDisplayValue(const Value: string);\r\nvar\r\n OrdVal: Integer;\r\nbegin\r\n OrdVal := GetEnumValue(Data.TypeInfo, Value);\r\n if OrdVal <> -1 then\r\n Data.AsOrdinal := GetEnumValue(Data.TypeInfo, Value)\r\n else\r\n begin\r\n OrdVal := StrToIntDef(Value, -1);\r\n if (OrdVal >= 0) and (Length(GetEnumName(Data.TypeInfo, OrdVal)) > 0) then\r\n Data.AsOrdinal := OrdVal\r\n else\r\n raise EJvInspectorItem.CreateResFmt(@RsEJvInspItemInvalidPropValue, [AnsiQuotedStr(Value, '''')]);\r\n end;\r\nend;\r\n\r\nprocedure TJvInspectorEnumItem.SetFlags(const Value: TInspectorItemFlags);\r\nvar\r\n TmpFlags: TInspectorItemFlags;\r\nbegin\r\n TmpFlags := Value;\r\n Include(TmpFlags, iifValueList);\r\n inherited SetFlags(TmpFlags);\r\nend;\r\n\r\n//=== { TJvInspectorFloatItem } ==============================================\r\n\r\nconstructor TJvInspectorFloatItem.Create(const AParent: TJvCustomInspectorItem;\r\n const AData: TJvCustomInspectorData);\r\nbegin\r\n inherited Create(AParent, AData);\r\n FFormat := '';\r\nend;\r\n\r\nfunction TJvInspectorFloatItem.GetDisplayValue: string;\r\nbegin\r\n // WAP: Inspector component doesn't handle exceptions well,\r\n // so we mask the error nicely here. Ini file data in a float\r\n // attribute that doesn't convert nicely to a float causes\r\n // GUI Exception hell.\r\n try\r\n Result := FormatFloat(FFormat, Data.AsFloat);\r\n except\r\n on E: EConvertError do\r\n if Data is TJvInspectorCustomConfData then\r\n Result := (Data as TJvInspectorCustomConfData).ForceString // INI Display Workaround.\r\n else\r\n Result := '0'; // Inspector component doesn't handle this exception well, so mask it. workaround. WAP\r\n end;\r\nend;\r\n\r\nprocedure TJvInspectorFloatItem.SetDisplayValue(const Value: string);\r\nbegin\r\n Data.AsFloat := StrToFloat(Value);\r\nend;\r\n\r\n//=== { TJvInspectorSetMemberData } ==========================================\r\n\r\nfunction TJvInspectorSetMemberData.GetAsFloat: Extended;\r\nbegin\r\n CheckReadAccess;\r\n raise EJvInspectorData.CreateResFmt(@RsEJvInspDataNoAccessAs, [cJvInspectorFloat]);\r\nend;\r\n\r\nfunction TJvInspectorSetMemberData.GetAsInt64: Int64;\r\nbegin\r\n CheckReadAccess;\r\n raise EJvInspectorData.CreateResFmt(@RsEJvInspDataNoAccessAs, [cJvInspectorInt64]);\r\nend;\r\n\r\nfunction TJvInspectorSetMemberData.GetAsMethod: TMethod;\r\nbegin\r\n CheckReadAccess;\r\n raise EJvInspectorData.CreateResFmt(@RsEJvInspDataNoAccessAs, [cJvInspectorTMethod]);\r\nend;\r\n\r\nfunction TJvInspectorSetMemberData.GetAsOrdinal: Int64;\r\nvar\r\n Buf: array [0..31] of Byte;\r\nbegin\r\n CheckReadAccess;\r\n DataParent.GetAsSet(Buf);\r\n Result := Ord(TestBitBuffer(Buf, BitOffset));\r\nend;\r\n\r\nfunction TJvInspectorSetMemberData.GetAsString: string;\r\nbegin\r\n CheckReadAccess;\r\n raise EJvInspectorData.CreateResFmt(@RsEJvInspDataNoAccessAs, [cJvInspectorString]);\r\nend;\r\n\r\nfunction TJvInspectorSetMemberData.IsEqualReference(const Ref: TJvCustomInspectorData): Boolean;\r\nbegin\r\n Result := (Ref is TJvInspectorSetMemberData) and\r\n (TJvInspectorSetMemberData(Ref).DataParent = DataParent) and\r\n (TJvInspectorSetMemberData(Ref).BitOffset = BitOffset);\r\nend;\r\n\r\nprocedure TJvInspectorSetMemberData.NotifyRemoveData(const Instance: TJvCustomInspectorData);\r\nbegin\r\n // if the instance to be removed is the data parent of this instance, free this instance as well.\r\n if Instance = DataParent then\r\n Free;\r\nend;\r\n\r\nprocedure TJvInspectorSetMemberData.SetAsFloat(const Value: Extended);\r\nbegin\r\n CheckWriteAccess;\r\n raise EJvInspectorData.CreateResFmt(@RsEJvInspDataNoAccessAs, [cJvInspectorFloat]);\r\nend;\r\n\r\nprocedure TJvInspectorSetMemberData.SetAsInt64(const Value: Int64);\r\nbegin\r\n CheckWriteAccess;\r\n raise EJvInspectorData.CreateResFmt(@RsEJvInspDataNoAccessAs, [cJvInspectorInt64]);\r\nend;\r\n\r\nprocedure TJvInspectorSetMemberData.SetAsMethod(const Value: TMethod);\r\nbegin\r\n CheckWriteAccess;\r\n raise EJvInspectorData.CreateResFmt(@RsEJvInspDataNoAccessAs, [cJvInspectorTMethod]);\r\nend;\r\n\r\nprocedure TJvInspectorSetMemberData.SetAsOrdinal(const Value: Int64);\r\nvar\r\n Buf: array [0..31] of Byte;\r\nbegin\r\n CheckWriteAccess;\r\n DataParent.GetAsSet(Buf);\r\n if Value <> 0 then\r\n SetBitBuffer(Buf, BitOffset)\r\n else\r\n ClearBitBuffer(Buf, BitOffset);\r\n DataParent.SetAsSet(Buf);\r\nend;\r\n\r\nprocedure TJvInspectorSetMemberData.SetAsString(const Value: string);\r\nbegin\r\n CheckWriteAccess;\r\n raise EJvInspectorData.CreateResFmt(@RsEJvInspDataNoAccessAs, [cJvInspectorString]);\r\nend;\r\n\r\nprocedure TJvInspectorSetMemberData.GetAsSet(var Buf);\r\nbegin\r\n CheckReadAccess;\r\n raise EJvInspectorData.CreateResFmt(@RsEJvInspDataNoAccessAs, [cJvInspectorSet]);\r\nend;\r\n\r\nfunction TJvInspectorSetMemberData.HasValue: Boolean;\r\nbegin\r\n Result := IsInitialized;\r\nend;\r\n\r\nfunction TJvInspectorSetMemberData.IsAssigned: Boolean;\r\nbegin\r\n Result := IsInitialized;\r\nend;\r\n\r\nfunction TJvInspectorSetMemberData.IsInitialized: Boolean;\r\nbegin\r\n Result := True;\r\nend;\r\n\r\nclass function TJvInspectorSetMemberData.New(const AParent: TJvCustomInspectorItem;\r\n const Ordinal: Integer; const ADataParent: TJvCustomInspectorData): TJvCustomInspectorItem;\r\nvar\r\n BaseInfo: IJclOrdinalRangeTypeInfo;\r\n Data: TJvInspectorSetMemberData;\r\nbegin\r\n if ADataParent = nil then\r\n raise EJvInspectorData.CreateRes(@RsEJvAssertDataParent);\r\n if AParent = nil then\r\n raise EJvInspectorData.CreateRes(@RsEJvAssertParent);\r\n BaseInfo := ((JclTypeInfo(ADataParent.TypeInfo) as IJclSetTypeInfo).\r\n BaseType as IJclOrdinalRangeTypeInfo);\r\n if BaseInfo.TypeKind = tkEnumeration then\r\n Data := CreatePrim(GetEnumName(BaseInfo.TypeInfo, Ordinal), System.TypeInfo(Boolean))\r\n else\r\n Data := CreatePrim(IntToStr(Ordinal), System.TypeInfo(Boolean));\r\n Data.FBitOffset := Ordinal mod 8 + 8 * ((Ordinal div 8) - (BaseInfo.MinValue div 8));\r\n Data.FDataParent := ADataParent;\r\n Data := TJvInspectorSetMemberData(DataRegister.Add(Data));\r\n if Data <> nil then\r\n Result := Data.NewItem(AParent)\r\n else\r\n Result := nil;\r\nend;\r\n\r\nprocedure TJvInspectorSetMemberData.SetAsSet(const Buf);\r\nbegin\r\n CheckWriteAccess;\r\n raise EJvInspectorData.CreateResFmt(@RsEJvInspDataNoAccessAs, [cJvInspectorSet]);\r\nend;\r\n\r\n//=== { TJvInspectorSetItem } ================================================\r\n\r\nconstructor TJvInspectorSetItem.Create(const AParent: TJvCustomInspectorItem;\r\n const AData: TJvCustomInspectorData);\r\nbegin\r\n inherited Create(AParent, AData);\r\n ItemSetFlags := [isfCreateMemberItems];\r\nend;\r\n\r\nfunction TJvInspectorSetItem.CanEdit: Boolean;\r\nbegin\r\n Result := inherited CanEdit and (isfEditString in ItemSetFlags);\r\nend;\r\n\r\nprocedure TJvInspectorSetItem.CreateMembers;\r\nvar\r\n SetInfo: IJclSetTypeInfo;\r\n BaseInfo: IJclOrdinalRangeTypeInfo;\r\n OrdVal: Integer;\r\nbegin\r\n Inspector.BeginUpdate;\r\n try\r\n DeleteMembers;\r\n JclTypeInfo(Data.TypeInfo).QueryInterface(IJclSetTypeInfo, SetInfo);\r\n SetInfo.BaseType.QueryInterface(IJclOrdinalRangeTypeInfo, BaseInfo);\r\n for OrdVal := Integer(BaseInfo.MinValue) to Integer(BaseInfo.MaxValue) do\r\n TJvInspectorSetMemberData.New(Self, OrdVal, Data);\r\n finally\r\n Inspector.EndUpdate;\r\n end;\r\nend;\r\n\r\nprocedure TJvInspectorSetItem.DeleteMembers;\r\nvar\r\n I: Integer;\r\nbegin\r\n Inspector.BeginUpdate;\r\n try\r\n I := Pred(Count);\r\n while (I >= 0) do\r\n begin\r\n if Items[I].Data is TJvInspectorSetMemberData then\r\n Delete(I);\r\n Dec(I);\r\n end;\r\n finally\r\n Inspector.EndUpdate;\r\n end;\r\nend;\r\n\r\nfunction TJvInspectorSetItem.GetCreateMemberItems: Boolean;\r\nbegin\r\n Result := (isfCreateMemberItems in ItemSetFlags);\r\nend;\r\n\r\nfunction TJvInspectorSetItem.GetDisplayValue: string;\r\nvar\r\n SetBuf: array [0..31] of Byte;\r\nbegin\r\n Data.GetAsSet(SetBuf);\r\n Result := JclSetToStr(Data.TypeInfo, SetBuf, True, False);\r\nend;\r\n\r\nfunction TJvInspectorSetItem.GetEditString: Boolean;\r\nbegin\r\n Result := (isfEditString in ItemSetFlags);\r\nend;\r\n\r\nfunction TJvInspectorSetItem.GetRenderAsCategory: Boolean;\r\nbegin\r\n Result := (isfRenderAsCategory in ItemSetFlags);\r\nend;\r\n\r\nfunction TJvInspectorSetItem.GetItemSetFlags: TInspectorSetFlags;\r\nbegin\r\n Result := FItemSetFlags;\r\nend;\r\n\r\nprocedure TJvInspectorSetItem.InvalidateMetaData;\r\nbegin\r\n if CreateMemberItems or RenderAsCategory then\r\n CreateMembers\r\n else\r\n DeleteMembers;\r\nend;\r\n\r\nfunction TJvInspectorSetItem.IsCategory: Boolean;\r\nbegin\r\n Result := RenderAsCategory;\r\nend;\r\n\r\nprocedure TJvInspectorSetItem.SetCreateMemberItems(const Value: Boolean);\r\nbegin\r\n if Value <> CreateMemberItems then\r\n if Value then\r\n ItemSetFlags := ItemSetFlags + [isfCreateMemberItems]\r\n else\r\n ItemSetFlags := ItemSetFlags - [isfCreateMemberItems];\r\nend;\r\n\r\nprocedure TJvInspectorSetItem.SetDisplayValue(const Value: string);\r\nvar\r\n SetBuf: array [0..31] of Byte;\r\nbegin\r\n JclStrToSet(Data.TypeInfo, SetBuf[0], Value);\r\n Data.SetAsSet(SetBuf[0]);\r\nend;\r\n\r\nprocedure TJvInspectorSetItem.SetEditString(const Value: Boolean);\r\nbegin\r\n if Value <> EditString then\r\n if Value then\r\n ItemSetFlags := ItemSetFlags + [isfEditString]\r\n else\r\n ItemSetFlags := ItemSetFlags - [isfEditString];\r\nend;\r\n\r\nprocedure TJvInspectorSetItem.SetRenderAsCategory(const Value: Boolean);\r\nbegin\r\n if Value <> RenderAsCategory then\r\n if Value then\r\n ItemSetFlags := ItemSetFlags + [isfRenderAsCategory]\r\n else\r\n ItemSetFlags := ItemSetFlags - [isfRenderAsCategory];\r\nend;\r\n\r\nprocedure TJvInspectorSetItem.SetFlags(const Value: TInspectorItemFlags);\r\nvar\r\n OldReadOnly: Boolean;\r\n I: Integer;\r\nbegin\r\n OldReadOnly := ReadOnly;\r\n inherited SetFlags(Value);\r\n if (OldReadOnly <> ReadOnly) and CreateMemberItems then\r\n for I := 0 to Pred(Count) do\r\n Items[I].ReadOnly := ReadOnly;\r\nend;\r\n\r\nprocedure TJvInspectorSetItem.SetItemSetFlags(const Value: TInspectorSetFlags);\r\nbegin\r\n if ItemSetFlags <> Value then\r\n begin\r\n FItemSetFlags := Value;\r\n InvalidateMetaData;\r\n end;\r\nend;\r\n\r\n//=== { TJvInspectorCharItem } ===============================================\r\n\r\nfunction TJvInspectorCharItem.GetDisplayValue: string;\r\nvar\r\n I: Integer;\r\nbegin\r\n I := Data.AsOrdinal;\r\n if (I <= Ord(' ')) or (I > Ord('~')) then\r\n Result := '#' + IntToStr(I)\r\n else\r\n Result := Chr(Byte(I));\r\nend;\r\n\r\nprocedure TJvInspectorCharItem.SetDisplayValue(const Value: string);\r\nvar\r\n I: Integer;\r\nbegin\r\n if Length(Value) > 1 then\r\n I := StrToInt(Copy(Value, 2, Length(Value)))\r\n else\r\n if Length(Value) = 1 then\r\n I := Ord(Value[1])\r\n else\r\n I := 0;\r\n Data.AsOrdinal := I;\r\nend;\r\n\r\n//=== { TJvInspectorInt64Item } ==============================================\r\n\r\nfunction TJvInspectorInt64Item.GetDisplayValue: string;\r\nbegin\r\n Result := IntToStr(Data.AsInt64);\r\nend;\r\n\r\nprocedure TJvInspectorInt64Item.SetDisplayValue(const Value: string);\r\nbegin\r\n // (rom) is this safe? StrToInt64 can throw exceptions.\r\n // (wpostma) definitely not safe. This is a crap implementation.\r\n Data.AsInt64 := StrToInt64Def(Value,0);\r\nend;\r\n\r\n//=== { TJvInspectorStringItem } =============================================\r\n\r\nfunction TJvInspectorStringItem.GetDisplayValue: string;\r\nbegin\r\n Result := Data.AsString;\r\nend;\r\n\r\nprocedure TJvInspectorStringItem.SetDisplayValue(const Value: string);\r\nbegin\r\n Data.AsString := Value;\r\nend;\r\n\r\n{ TJvInspectorVariantItem }\r\n\r\nfunction TJvInspectorVariantItem.GetDisplayValue: string;\r\nbegin\r\n Result := VarToStr(Data.AsVariant); // return empty string instead of triggering exception when Data is Null\r\nend;\r\n\r\nprocedure TJvInspectorVariantItem.SetDisplayValue(const Value: string);\r\nbegin\r\n if Value = '' then\r\n Data.AsVariant := Unassigned\r\n else\r\n Data.AsVariant := Value;\r\nend;\r\n\r\n//=== { TJvInspectorClassItem } ==============================================\r\n\r\nconstructor TJvInspectorClassItem.Create(const AParent: TJvCustomInspectorItem;\r\n const AData: TJvCustomInspectorData);\r\nbegin\r\n inherited Create(AParent, AData);\r\n if GetTypeData(Data.TypeInfo).ClassType.InheritsFrom(Classes.TComponent) then\r\n begin\r\n ItemClassFlags := [icfCreateMemberItems];\r\n Flags := Flags + [iifValueList];\r\n end\r\n else\r\n if GetTypeData(Data.TypeInfo).ClassType.InheritsFrom(TPersistent) then\r\n ItemClassFlags := [icfCreateMemberItems, icfShowClassName]\r\n else\r\n ItemClassFlags := [icfShowClassName];\r\nend;\r\n\r\nprocedure TJvInspectorClassItem.CreateMembers;\r\nbegin\r\n if Data.IsInitialized and (Data.AsOrdinal <> 0) then\r\n begin\r\n Inspector.BeginUpdate;\r\n try\r\n DeleteMembers;\r\n TJvInspectorPropData.New(Self, TObject(Data.AsOrdinal));\r\n FLastMemberInstance := TObject(Data.AsOrdinal);\r\n finally\r\n Inspector.EndUpdate;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJvInspectorClassItem.CanEdit: Boolean;\r\nbegin\r\n Result := inherited CanEdit and\r\n ((iifEditButton in Flags) or (iifValueList in Flags));\r\nend;\r\n\r\nprocedure TJvInspectorClassItem.DeleteMembers;\r\nvar\r\n I: Integer;\r\nbegin\r\n if Data.IsInitialized then\r\n begin\r\n Inspector.BeginUpdate;\r\n try\r\n for I := Pred(Count) downto 0 do\r\n if (Items[I].Data is TJvInspectorPropData) and (Items[I].Data.IsInitialized) and\r\n (TJvInspectorPropData(Items[I].Data).Instance = FLastMemberInstance) then\r\n Delete(I);\r\n FLastMemberInstance := nil;\r\n finally\r\n Inspector.EndUpdate;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJvInspectorClassItem.GetCreateMemberItems: Boolean;\r\nbegin\r\n Result := (icfCreateMemberItems in ItemClassFlags);\r\nend;\r\n\r\nfunction TJvInspectorClassItem.GetDisplayValue: string;\r\nvar\r\n Obj: TObject;\r\n SL: TStringList;\r\n I: Integer;\r\nbegin\r\n Obj := TObject(Data.AsOrdinal);\r\n if ShowClassName then\r\n begin\r\n if Obj <> nil then\r\n Result := Result + '(' + Obj.ClassName + ')'\r\n else\r\n Result := Result + '(' + GetTypeData(Data.TypeInfo).ClassType.ClassName + ')';\r\n end\r\n else\r\n begin\r\n if Obj <> nil then\r\n begin\r\n SL := TStringList.Create;\r\n try\r\n GetValueList(SL);\r\n I := SL.IndexOfObject(Obj);\r\n if I > -1 then\r\n Result := SL[I]\r\n else\r\n Result := '';\r\n finally\r\n SL.Free;\r\n end;\r\n end\r\n else\r\n Result := '';\r\n end;\r\nend;\r\n\r\nfunction TJvInspectorClassItem.GetItemClassFlags: TInspectorClassFlags;\r\nbegin\r\n Result := FItemClassFlags;\r\nend;\r\n\r\nfunction TJvInspectorClassItem.GetRenderAsCategory: Boolean;\r\nbegin\r\n Result := (icfRenderAsCategory in ItemClassFlags);\r\nend;\r\n\r\nfunction TJvInspectorClassItem.GetShowClassName: Boolean;\r\nbegin\r\n Result := (icfShowClassName in ItemClassFlags);\r\nend;\r\n\r\nprocedure TJvInspectorClassItem.InvalidateItem;\r\nbegin\r\n inherited InvalidateItem;\r\n if CreateMemberItems or RenderAsCategory then\r\n CreateMembers;\r\nend;\r\n\r\nprocedure TJvInspectorClassItem.InvalidateMetaData;\r\nbegin\r\n if CreateMemberItems or RenderAsCategory then\r\n CreateMembers\r\n else\r\n DeleteMembers;\r\nend;\r\n\r\nfunction TJvInspectorClassItem.IsCategory: Boolean;\r\nbegin\r\n Result := RenderAsCategory;\r\nend;\r\n\r\nprocedure TJvInspectorClassItem.SetCreateMemberItems(const Value: Boolean);\r\nbegin\r\n if Value <> CreateMemberItems then\r\n if Value then\r\n ItemClassFlags := ItemClassFlags + [icfCreateMemberItems]\r\n else\r\n ItemClassFlags := ItemClassFlags - [icfCreateMemberItems];\r\nend;\r\n\r\nprocedure TJvInspectorClassItem.SetDisplayValue(const Value: string);\r\nvar\r\n SL: TStrings;\r\n I: Integer;\r\nbegin\r\n if Value = '' then\r\n Data.AsOrdinal := 0\r\n else\r\n begin\r\n SL := TStringList.Create;\r\n try\r\n GetValueList(SL);\r\n I := SL.IndexOf(Value);\r\n if I > -1 then\r\n Data.AsOrdinal := Integer(SL.Objects[I])\r\n else\r\n raise EJvInspectorItem.CreateResFmt(@RsEJvInspItemInvalidPropValue,\r\n [AnsiQuotedStr(Value, '''')]);\r\n finally\r\n SL.Free;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvInspectorClassItem.SetItemClassFlags(Value: TInspectorClassFlags);\r\nbegin\r\n if Value <> ItemClassFlags then\r\n begin\r\n FItemClassFlags := Value;\r\n InvalidateMetaData;\r\n end;\r\nend;\r\n\r\nprocedure TJvInspectorClassItem.SetRenderAsCategory(const Value: Boolean);\r\nbegin\r\n if Value <> RenderAsCategory then\r\n if Value then\r\n ItemClassFlags := ItemClassFlags + [icfRenderAsCategory]\r\n else\r\n ItemClassFlags := ItemClassFlags - [icfRenderAsCategory];\r\nend;\r\n\r\nprocedure TJvInspectorClassItem.SetShowClassName(const Value: Boolean);\r\nbegin\r\n if Value <> ShowClassName then\r\n if Value then\r\n ItemClassFlags := ItemClassFlags + [icfShowClassName]\r\n else\r\n ItemClassFlags := ItemClassFlags - [icfShowClassName];\r\nend;\r\n\r\n//=== { TJvInspectorComponentItem } ==========================================\r\n\r\nconstructor TJvInspectorComponentItem.Create(const AParent: TJvCustomInspectorItem;\r\n const AData: TJvCustomInspectorData);\r\nbegin\r\n inherited Create(AParent, AData);\r\n FOwners := TList.Create;\r\nend;\r\n\r\nfunction TJvInspectorComponentItem.GetItemComponentFlags: TInspectorComponentFlags;\r\nbegin\r\n Result := FItemComponentFlags;\r\nend;\r\n\r\nfunction TJvInspectorComponentItem.GetKeepFirstOwnerAsFirst: Boolean;\r\nbegin\r\n Result := icfKeepFirstOwnerAsFirst in ItemComponentFlags;\r\nend;\r\n\r\nfunction TJvInspectorComponentItem.GetNoShowFirstOwnerName: Boolean;\r\nbegin\r\n Result := icfNoShowFirstOwnerName in ItemComponentFlags;\r\nend;\r\n\r\nfunction TJvInspectorComponentItem.GetOwnerCount: Integer;\r\nbegin\r\n Result := FOwners.Count;\r\nend;\r\n\r\nfunction TJvInspectorComponentItem.GetOwners(I: Integer): TComponent;\r\nbegin\r\n Result := TComponent(FOwners[I]);\r\nend;\r\n\r\nfunction TJvInspectorComponentItem.GetShowOwnerNames: Boolean;\r\nbegin\r\n Result := icfShowOwnerNames in ItemComponentFlags;\r\nend;\r\n\r\nfunction TJvInspectorComponentItem.GetSortComponents: Boolean;\r\nbegin\r\n Result := icfSortComponents in ItemComponentFlags;\r\nend;\r\n\r\nfunction TJvInspectorComponentItem.GetSortOwners: Boolean;\r\nbegin\r\n Result := icfSortOwners in ItemComponentFlags;\r\nend;\r\n\r\nprocedure TJvInspectorComponentItem.GetValueList(const Strings: TStrings);\r\nvar\r\n MinClass: TClass;\r\n SL: TStringList;\r\n OwnerList: TStringList;\r\n I, J: Integer;\r\n CurOwner: TComponent;\r\n PrefixWithOwner: string;\r\nbegin\r\n MinClass := GetTypeData(Data.TypeInfo).ClassType;\r\n SL := TStringList.Create;\r\n try\r\n OwnerList := TStringList.Create;\r\n try\r\n for I := 0 to OwnerCount - 1 do\r\n OwnerList.AddObject(Owners[I].Name, Owners[I]);\r\n if SortOwners then\r\n OwnerList.Sort;\r\n if (OwnerCount > 0) and KeepFirstOwnerAsFirst then\r\n begin\r\n I := OwnerList.IndexOfObject(Owners[0]);\r\n if I > 0 then\r\n begin\r\n OwnerList.Delete(I);\r\n OwnerList.InsertObject(0, Owners[0].Name, Owners[0]);\r\n end;\r\n end;\r\n for I := 0 to OwnerCount - 1 do\r\n begin\r\n SL.Clear;\r\n CurOwner := TComponent(OwnerList.Objects[I]);\r\n if ShowOwnerNames then\r\n begin\r\n if (I > 0) or not NoShowFirstOwnerName then\r\n PrefixWithOwner := CurOwner.Name + '.';\r\n end\r\n else\r\n PrefixWithOwner := '';\r\n for J := 0 to CurOwner.ComponentCount - 1 do\r\n // don't allow setting Self as property\r\n if (CurOwner.Components[J] is MinClass) and (not (Parent.Data is TJvInspectorPropData) or\r\n (CurOwner.Components[J] <> TJvInspectorPropData(Parent.Data).Instance)) then\r\n SL.AddObject(PrefixWithOwner + CurOwner.Components[J].Name, CurOwner.Components[J]);\r\n if SL.Count > 0 then\r\n begin\r\n if SortComponents then\r\n SL.Sort;\r\n Strings.AddStrings(SL);\r\n end;\r\n end;\r\n SL.Clear;\r\n inherited GetValueList(SL);\r\n if SortComponents then\r\n SL.Sort;\r\n if SL.Count > 0 then\r\n Strings.AddStrings(SL);\r\n finally\r\n OwnerList.Free;\r\n end;\r\n finally\r\n SL.Free;\r\n end;\r\nend;\r\n\r\nprocedure TJvInspectorComponentItem.SetFlags(const Value: TInspectorItemFlags);\r\nbegin\r\n inherited SetFlags(Value + [iifValueList]);\r\nend;\r\n\r\nprocedure TJvInspectorComponentItem.SetItemClassFlags(Value: TInspectorClassFlags);\r\nbegin\r\n inherited SetItemClassFlags(Value - [icfShowClassName]);\r\nend;\r\n\r\nprocedure TJvInspectorComponentItem.SetItemComponentFlags(Value: TInspectorComponentFlags);\r\nbegin\r\n if ItemComponentFlags <> Value then\r\n begin\r\n FItemComponentFlags := Value;\r\n InvalidateMetaData;\r\n end;\r\nend;\r\n\r\nprocedure TJvInspectorComponentItem.SetKeepFirstOwnerAsFirst(Value: Boolean);\r\nbegin\r\n if Value <> KeepFirstOwnerAsFirst then\r\n if Value then\r\n ItemComponentFlags := ItemComponentFlags + [icfKeepFirstOwnerAsFirst]\r\n else\r\n ItemComponentFlags := ItemComponentFlags - [icfKeepFirstOwnerAsFirst];\r\nend;\r\n\r\nprocedure TJvInspectorComponentItem.SetNoShowFirstOwnerName(Value: Boolean);\r\nbegin\r\n if Value <> NoShowFirstOwnerName then\r\n if Value then\r\n ItemComponentFlags := ItemComponentFlags + [icfNoShowFirstOwnerName]\r\n else\r\n ItemComponentFlags := ItemComponentFlags - [icfNoShowFirstOwnerName];\r\nend;\r\n\r\nprocedure TJvInspectorComponentItem.SetOwners(I: Integer; Value: TComponent);\r\nbegin\r\n FOwners[I] := Value;\r\nend;\r\n\r\nprocedure TJvInspectorComponentItem.SetShowOwnerNames(Value: Boolean);\r\nbegin\r\n if Value <> ShowOwnerNames then\r\n if Value then\r\n ItemComponentFlags := ItemComponentFlags + [icfShowOwnerNames]\r\n else\r\n ItemComponentFlags := ItemComponentFlags - [icfShowOwnerNames];\r\nend;\r\n\r\nprocedure TJvInspectorComponentItem.SetSortComponents(Value: Boolean);\r\nbegin\r\n if Value <> SortComponents then\r\n if Value then\r\n ItemComponentFlags := ItemComponentFlags + [icfSortComponents]\r\n else\r\n ItemComponentFlags := ItemComponentFlags - [icfSortComponents];\r\nend;\r\n\r\nprocedure TJvInspectorComponentItem.SetSortOwners(Value: Boolean);\r\nbegin\r\n if Value <> SortOwners then\r\n if Value then\r\n ItemComponentFlags := ItemComponentFlags + [icfSortOwners]\r\n else\r\n ItemComponentFlags := ItemComponentFlags - [icfSortOwners];\r\nend;\r\n\r\nprocedure TJvInspectorComponentItem.BeforeDestruction;\r\nbegin\r\n FOwners.Free;\r\n inherited BeforeDestruction;\r\nend;\r\n\r\nprocedure TJvInspectorComponentItem.AddOwner(const AOwner: TComponent);\r\nbegin\r\n if FOwners.IndexOf(AOwner) < 0 then\r\n FOwners.Add(AOwner);\r\nend;\r\n\r\nprocedure TJvInspectorComponentItem.DeleteOwner(const AOwner: TComponent);\r\nbegin\r\n FOwners.Remove(AOwner);\r\nend;\r\n\r\nprocedure TJvInspectorComponentItem.DeleteOwner(const Index: Integer);\r\nbegin\r\n FOwners.Delete(Index);\r\nend;\r\n\r\n//=== { TJvInspectorFontItem } ===============================================\r\n\r\nprocedure TJvInspectorFontItem.Edit;\r\nbegin\r\n with TFontDialog.Create(GetParentForm(Inspector)) do\r\n try\r\n Font.Assign(TFont(Data.AsOrdinal));\r\n Device := fdScreen;\r\n if Execute then\r\n begin\r\n TFont(Data.AsOrdinal).Assign(Font);\r\n Data.InvalidateData;\r\n end;\r\n finally\r\n Free;\r\n Inspector.ShowScrollBars(SB_BOTH, False);\r\n end;\r\nend;\r\n\r\nprocedure TJvInspectorFontItem.SetFlags(const Value: TInspectorItemFlags);\r\nvar\r\n NewValue: TInspectorItemFlags;\r\nbegin\r\n NewValue := Value + [iifEditButton, iifEditFixed];\r\n inherited SetFlags(NewValue);\r\nend;\r\n\r\n//=== { TJvInspectorFontNameItem } ===========================================\r\n\r\nfunction TJvInspectorFontNameItem.GetUseFont: Boolean;\r\nbegin\r\n Result := FUseFont;\r\nend;\r\n\r\nprocedure TJvInspectorFontNameItem.SetUseFont(Value: Boolean);\r\nbegin\r\n if UseFont <> Value then\r\n begin\r\n FUseFont := Value;\r\n InvalidateMetaData;\r\n end;\r\nend;\r\n\r\nprocedure TJvInspectorFontNameItem.DoDrawListItem(Control: TWinControl;\r\n Index: Integer; Rect: TRect; State: TOwnerDrawState);\r\nvar\r\n FontName: string;\r\nbegin\r\n with TListBox(Control) do\r\n begin\r\n if UseFont then\r\n begin\r\n FontName := Items[Index];\r\n Canvas.Font.Name := FontName;\r\n end;\r\n DoDefaultDrawListItem(TListBox(Control).Canvas, Rect, TListBox(Control).Items[Index]);\r\n end;\r\nend;\r\n\r\nprocedure TJvInspectorFontNameItem.DoMeasureListItem(Control: TWinControl;\r\n Index: Integer; var Height: Integer);\r\nvar\r\n FontName: string;\r\nbegin\r\n if UseFont then\r\n with TListBox(Control) do\r\n begin\r\n FontName := Items[Index];\r\n Canvas.Font.Name := FontName;\r\n end;\r\n Height := CanvasMaxTextHeight(TListBox(Control).Canvas);\r\nend;\r\n\r\nprocedure TJvInspectorFontNameItem.DoMeasureListItemWidth(Control: TWinControl;\r\n Index: Integer; var Width: Integer);\r\nvar\r\n FontName: string;\r\nbegin\r\n FontName := TListBox(Control).Items[Index];\r\n if UseFont then\r\n TListBox(Control).Canvas.Font.Name := FontName;\r\n Width := TListBox(Control).Canvas.TextWidth(FontName);\r\nend;\r\n\r\nprocedure TJvInspectorFontNameItem.GetValueList(const Strings: TStrings);\r\nbegin\r\n Strings.Assign(Screen.Fonts);\r\nend;\r\n\r\nprocedure TJvInspectorFontNameItem.SetFlags(const Value: TInspectorItemFlags);\r\nvar\r\n NewValue: TInspectorItemFlags;\r\nbegin\r\n NewValue := Value + [iifValueList, iifOwnerDrawListMaxHeight];\r\n inherited SetFlags(NewValue);\r\nend;\r\n\r\n//=== { TJvInspectorBooleanItem } ============================================\r\n\r\nfunction TJvInspectorBooleanItem.GetShowAsCheckBox: Boolean;\r\nbegin\r\n Result := FShowAsCheckBox;\r\nend;\r\n\r\nprocedure TJvInspectorBooleanItem.EditKeyDown(Sender: TObject; var Key: Word;\r\n Shift: TShiftState);\r\nvar\r\n Bool: Boolean;\r\nbegin\r\n if ShowAsCheckBox then\r\n begin\r\n Bool := not (Data.AsOrdinal <> Ord(False));\r\n if Editing and (Shift = []) and (Key = VK_SPACE) then\r\n begin\r\n Data.AsOrdinal := Ord(Bool);\r\n InvalidateItem;\r\n end;\r\n end\r\n else\r\n inherited EditKeyDown(Sender, Key, Shift)\r\nend;\r\n\r\nprocedure TJvInspectorBooleanItem.MouseDown(Button: TMouseButton;\r\n Shift: TShiftState; X, Y: Integer);\r\nvar\r\n Bool: Boolean;\r\nbegin\r\n if Data.IsAssigned then\r\n Bool := not (Data.AsOrdinal <> Ord(False))\r\n else\r\n Bool := True;\r\n if PtInRect(FCheckRect, Point(X, Y)) and (Shift = [ssLeft]) and\r\n Editing and ShowAsCheckBox then\r\n begin\r\n Data.AsOrdinal := Ord(Bool);\r\n InvalidateItem;\r\n end\r\n else\r\n begin\r\n if (ssDouble in Shift) and ShowAsCheckBox then\r\n Shift := Shift - [ssDouble];\r\n if not ShowAsCheckBox then\r\n inherited MouseDown(Button, Shift, X, Y);\r\n end;\r\nend;\r\n\r\nprocedure TJvInspectorBooleanItem.SetShowAsCheckBox(Value: Boolean);\r\nvar\r\n WasEditing: Boolean;\r\nbegin\r\n if Value <> ShowAsCheckBox then\r\n begin\r\n WasEditing := Editing;\r\n DoneEdit(False);\r\n FShowAsCheckBox := Value;\r\n InvalidateMetaData;\r\n if WasEditing then\r\n InitEdit;\r\n end;\r\nend;\r\n\r\nprocedure TJvInspectorBooleanItem.DoneEdit(const CancelEdits: Boolean = False);\r\nbegin\r\n if ShowAsCheckBox then\r\n SetEditing(False)\r\n else\r\n inherited DoneEdit(CancelEdits);\r\nend;\r\n\r\nprocedure TJvInspectorBooleanItem.DrawValue(const ACanvas: TCanvas);\r\nvar\r\n Bool: Boolean;\r\n ARect: TRect;\r\n Rgn, SaveRgn: HRGN;\r\n HasRgn: Boolean;\r\n ClipRect: TRect;\r\nbegin\r\n if not ShowAsCheckBox then\r\n inherited DrawValue(ACanvas)\r\n else\r\n begin\r\n if Data.IsInitialized and Data.IsAssigned and Data.HasValue then\r\n Bool := Data.AsOrdinal <> Ord(False)\r\n else\r\n Bool := False;\r\n\r\n if Editing and Data.IsAssigned then\r\n ACanvas.Brush.Color := clWindow;\r\n ACanvas.FillRect(Rects[iprValueArea]);\r\n ARect := Rects[iprValue];\r\n OffsetRect(ARect, 2, 0);\r\n ARect.Right := ARect.Left + 13;\r\n ARect.Bottom := ARect.Top + 13;\r\n { Remember current clipping region }\r\n SaveRgn := CreateRectRgn(0, 0, 0, 0);\r\n HasRgn := GetClipRgn(ACanvas.Handle, SaveRgn) > 0;\r\n { Clip all outside of the item rectangle }\r\n IntersectRect(ClipRect, ARect, Rects[iprValue]);\r\n FCheckRect := ClipRect;\r\n Rgn := CreateRectRgn(ClipRect.Left, ClipRect.Top, ClipRect.Right, ClipRect.Bottom);\r\n SelectClipRgn(ACanvas.Handle, Rgn);\r\n DeleteObject(Rgn);\r\n try\r\n { Paint the 3d checkbox: Frame }\r\n{ Frame3D(ACanvas, ARect, clBlack, clWhite, 1);\r\n Frame3D(ACanvas, ARect, clBlack, cl3DLight, 1);}\r\n\r\n ACanvas.Pen.Color := clActiveBorder;\r\n ACanvas.Pen.Width := 1;\r\n ACanvas.Rectangle(ARect);\r\n InflateRect(ARect, -1, -1);\r\n\r\n if Bool then\r\n with ACanvas do\r\n begin\r\n InflateRect(ARect, -1, -1);\r\n { Paint the 3d checkbox: Draw the checkmark }\r\n Pen.Color := clWindowText;\r\n Pen.Width := 1;\r\n MoveTo(ARect.Left + 1, ARect.Top + 3);\r\n LineTo(ARect.Left + 3, ARect.Top + 5);\r\n LineTo(ARect.Left + 8, ARect.Top);\r\n MoveTo(ARect.Left + 1, ARect.Top + 4);\r\n LineTo(ARect.Left + 3, ARect.Top + 6);\r\n LineTo(ARect.Left + 8, ARect.Top + 1);\r\n MoveTo(ARect.Left + 1, ARect.Top + 5);\r\n LineTo(ARect.Left + 3, ARect.Top + 7);\r\n LineTo(ARect.Left + 8, ARect.Top + 2);\r\n end;\r\n finally\r\n { restore previous clipping region }\r\n if HasRgn then\r\n SelectClipRgn(ACanvas.Handle, SaveRgn)\r\n else\r\n SelectClipRgn(ACanvas.Handle, 0);\r\n DeleteObject(SaveRgn);\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvInspectorBooleanItem.InitEdit;\r\nbegin\r\n if ShowAsCheckBox then\r\n SetEditing(CanEdit)\r\n else\r\n inherited InitEdit;\r\nend;\r\n\r\n//=== { TJvInspectorDateItem } ===============================================\r\n\r\nconstructor TJvInspectorDateItem.Create(const AParent: TJvCustomInspectorItem;\r\n const AData: TJvCustomInspectorData);\r\nbegin\r\n inherited Create(AParent, AData);\r\n FFormat := JclFormatSettings.ShortDateFormat;\r\nend;\r\n\r\nfunction TJvInspectorDateItem.GetDisplayValue: string;\r\nbegin\r\n Result := FormatDateTime(Format, Data.AsFloat);\r\nend;\r\n\r\nprocedure TJvInspectorDateItem.SetDisplayValue(const Value: string);\r\nbegin\r\n if Data.IsAssigned then\r\n Data.AsFloat := Trunc(StrToDate(Value)) + Frac(Data.AsFloat)\r\n else\r\n Data.AsFloat := Trunc(StrToDate(Value));\r\nend;\r\n\r\nprocedure TJvInspectorDateItem.SetFormat(const Value: string);\r\nvar\r\n I: Integer;\r\n MCount: Integer;\r\n DCount: Integer;\r\n YCount: Integer;\r\n SepCount: Integer;\r\n WasEditing: Boolean;\r\nbegin\r\n // Only allow d, dd, m, mm, yy, yyyy and the date separator characters to ease parsing\r\n I := 1;\r\n MCount := 0;\r\n DCount := 0;\r\n YCount := 0;\r\n SepCount := 0;\r\n while I < Length(Value) do\r\n begin\r\n case Value[I] of\r\n 'd':\r\n begin\r\n if (DCount = 0) and (I > 1) and (Value[I - 1] <> JclFormatSettings.DateSeparator) then\r\n raise EJvInspectorData.CreateRes(@RsESpecifierBeforeSeparator);\r\n if (DCount = 1) and (Value[I - 1] <> 'd') then\r\n raise EJvInspectorData.CreateRes(@RsEDOrDDOnlyOnce);\r\n if DCount = 2 then\r\n raise EJvInspectorData.CreateRes(@RsEOnlyDOrDDAllowed);\r\n Inc(DCount);\r\n end;\r\n 'm':\r\n begin\r\n if (MCount = 0) and (I > 1) and (Value[I - 1] <> JclFormatSettings.DateSeparator) then\r\n raise EJvInspectorData.CreateRes(@RsESpecifierBeforeSeparator);\r\n if (MCount = 1) and (Value[I - 1] <> 'm') then\r\n raise EJvInspectorData.CreateRes(@RsEMOrMMOnlyOnce);\r\n if MCount = 2 then\r\n raise EJvInspectorData.CreateRes(@RsEOnlyMOrMMAllowed);\r\n Inc(MCount);\r\n end;\r\n 'y':\r\n begin\r\n if (MCount = 0) and (I > 1) and (Value[I - 1] <> JclFormatSettings.DateSeparator) then\r\n raise EJvInspectorData.CreateRes(@RsESpecifierBeforeSeparator);\r\n if (YCount > 1) and (YCount < 4) and (Value[I - 1] <> 'y') then\r\n raise EJvInspectorData.CreateRes(@RsEYYOrYYYYOnlyOnce);\r\n if YCount = 4 then\r\n raise EJvInspectorData.CreateRes(@RsEOnlyYYOrYYYYAllowed);\r\n Inc(YCount);\r\n end;\r\n else\r\n if Value[I] = JclFormatSettings.DateSeparator then\r\n begin\r\n if ((SepCount = 0) and (I = 1)) or\r\n ((SepCount = 1) and ((Value[I - 1]) = JclFormatSettings.DateSeparator) or (I = Length(Value))) then\r\n raise EJvInspectorData.CreateRes(@RsESpecifierBeforeSeparator);\r\n if SepCount = 2 then\r\n raise EJvInspectorData.CreateRes(@RsEOnlyTwoSeparators);\r\n Inc(SepCount);\r\n end\r\n else\r\n raise EJvInspectorData.CreateResFmt(@RsEOnlyDMYSAllowed, [JclFormatSettings.DateSeparator]);\r\n end;\r\n Inc(I);\r\n end;\r\n if DCount = 0 then\r\n raise EJvInspectorData.CreateRes(@RsEDOrDDRequired);\r\n if MCount = 0 then\r\n raise EJvInspectorData.CreateRes(@RsEMOrMMRequired);\r\n if YCount = 0 then\r\n raise EJvInspectorData.CreateRes(@RsEYYOrYYYYRequired);\r\n if (YCount = 1) or (YCount = 3) then\r\n raise EJvInspectorData.CreateRes(@RsEOnlyYYOrYYYYAllowed);\r\n if Value <> FFormat then\r\n begin\r\n WasEditing := Editing;\r\n if Editing then\r\n DoneEdit;\r\n FFormat := Value;\r\n if WasEditing then\r\n InitEdit;\r\n end;\r\nend;\r\n\r\n//=== { TJvInspectorTimeItem } ===============================================\r\n\r\nconstructor TJvInspectorTimeItem.Create(const AParent: TJvCustomInspectorItem;\r\n const AData: TJvCustomInspectorData);\r\nbegin\r\n inherited Create(AParent, AData);\r\n FShowSeconds := True;\r\n FShowAMPM := False;\r\n SetFormat;\r\nend;\r\n\r\nfunction TJvInspectorTimeItem.GetDisplayValue: string;\r\nbegin\r\n Result := FormatDateTime(Format, Data.AsFloat);\r\nend;\r\n\r\nprocedure TJvInspectorTimeItem.SetDisplayValue(const Value: string);\r\nbegin\r\n if Data.IsAssigned then\r\n Data.AsFloat := Frac(StrToTime(Value)) + Trunc(Data.AsFloat)\r\n else\r\n Data.AsFloat := Frac(StrToTime(Value)) + Trunc(Data.AsFloat);\r\nend;\r\n\r\nprocedure TJvInspectorTimeItem.SetFormat;\r\nbegin\r\n FFormat := 'hh:nn';\r\n if ShowSeconds then\r\n FFormat := FFormat + ':ss';\r\n if ShowAMPM then\r\n FFormat := FFormat + ' ampm';\r\nend;\r\n\r\nprocedure TJvInspectorTimeItem.SetShowAMPM(Value: Boolean);\r\nvar\r\n WasEditing: Boolean;\r\nbegin\r\n if Value <> ShowAMPM then\r\n begin\r\n WasEditing := Editing;\r\n DoneEdit;\r\n FShowAMPM := Value;\r\n SetFormat;\r\n if WasEditing then\r\n InitEdit;\r\n end;\r\nend;\r\n\r\nprocedure TJvInspectorTimeItem.SetShowSeconds(Value: Boolean);\r\nvar\r\n WasEditing: Boolean;\r\nbegin\r\n if Value <> ShowSeconds then\r\n begin\r\n WasEditing := Editing;\r\n DoneEdit;\r\n FShowSeconds := Value;\r\n SetFormat;\r\n if WasEditing then\r\n InitEdit;\r\n end;\r\nend;\r\n\r\n//=== { TJvInspectorDateTimeItem } ===========================================\r\n\r\nconstructor TJvInspectorDateTimeItem.Create(const AParent: TJvCustomInspectorItem;\r\n const AData: TJvCustomInspectorData);\r\nbegin\r\n inherited Create(AParent, AData);\r\n SingleNameUseFirstCol := True;\r\n FDate := TJvInspectorDateItem.Create(Self, AData);\r\n FTime := TJvInspectorTimeItem.Create(Self, AData);\r\n AddColumnPrim(FDate);\r\n AddColumnPrim(FTime);\r\nend;\r\n\r\nfunction TJvInspectorDateTimeItem.GetDateFormat: string;\r\nbegin\r\n Result := FDate.Format;\r\nend;\r\n\r\nfunction TJvInspectorDateTimeItem.GetTimeShowAMPM: Boolean;\r\nbegin\r\n Result := FTime.ShowAMPM;\r\nend;\r\n\r\nfunction TJvInspectorDateTimeItem.GetTimeShowSeconds: Boolean;\r\nbegin\r\n Result := FTime.ShowSeconds;\r\nend;\r\n\r\nprocedure TJvInspectorDateTimeItem.SetDateFormat(const Value: string);\r\nbegin\r\n FDate.Format := Value;\r\nend;\r\n\r\nprocedure TJvInspectorDateTimeItem.SetTimeShowAMPM(Value: Boolean);\r\nbegin\r\n FTime.ShowAMPM := Value;\r\nend;\r\n\r\nprocedure TJvInspectorDateTimeItem.SetTimeShowSeconds(Value: Boolean);\r\nbegin\r\n FTime.ShowSeconds := Value;\r\nend;\r\n\r\n//=== { TSLEditorForm } ======================================================\r\n\r\ntype\r\n TSLEditorForm = class(TCustomForm)\r\n public\r\n grp: TGroupBox;\r\n lbl: TLabel;\r\n mm: TMemo;\r\n btnOK: TButton;\r\n btnCancel: TButton;\r\n OnContentsChanged: TNotifyEvent;\r\n constructor CreateNew(AOwner: TComponent); reintroduce;\r\n procedure MemoChanged(Sender: TObject);\r\n end;\r\n\r\nconstructor TSLEditorForm.CreateNew(AOwner: TComponent);\r\nbegin\r\n inherited CreateNew(AOwner);\r\n Caption := RsStringListEditorCaption;\r\n Width := 435;\r\n Height := 305;\r\n BorderIcons := [biSystemMenu];\r\n grp := TGroupBox.Create(Self);\r\n grp.Parent := Self;\r\n grp.Left := 10;\r\n grp.Top := 10;\r\n grp.Width := ClientWidth - 20;\r\n grp.Height := 230;\r\n grp.Anchors := [akTop, akLeft, akRight, akBottom];\r\n lbl := TLabel.Create(Self);\r\n lbl.Parent := grp;\r\n lbl.Caption := '';\r\n lbl.AutoSize := False;\r\n lbl.Left := 10;\r\n lbl.Top := 10;\r\n lbl.Width := grp.ClientWidth - 20;\r\n lbl.Anchors := [akTop, akLeft, akRight];\r\n mm := TMemo.Create(Self);\r\n mm.Parent := grp;\r\n mm.Left := 10;\r\n mm.Top := 30;\r\n mm.Width := grp.ClientWidth - 20;\r\n mm.Height := grp.ClientHeight - 40;\r\n mm.Anchors := [akTop, akLeft, akRight, akBottom];\r\n mm.ScrollBars := ssBoth;\r\n mm.WordWrap := False;\r\n mm.WantReturns := True;\r\n mm.WantTabs := False;\r\n mm.OnChange := MemoChanged;\r\n btnOK := TButton.Create(Self);\r\n btnOK.Parent := Self;\r\n btnOK.ModalResult := mrOK;\r\n btnOK.Default := True;\r\n btnOK.Caption := RsButtonOKCaption;\r\n btnOK.Left := ClientWidth - 15 - 2 * btnOK.Width;\r\n btnOK.Top := ClientHeight - 5 - btnOK.Height;\r\n btnOK.Anchors := [akRight, akBottom];\r\n btnCancel := TButton.Create(Self);\r\n btnCancel.Parent := Self;\r\n btnCancel.ModalResult := mrCancel;\r\n btnCancel.Cancel := True;\r\n btnCancel.Caption := RsButtonCancelCaption;\r\n btnCancel.Left := ClientWidth - 10 - btnCancel.Width;\r\n btnCancel.Top := ClientHeight - 5 - btnCancel.Height;\r\n btnCancel.Anchors := [akRight, akBottom];\r\n Constraints.MinWidth := 2 * btnOK.Width + 25 + (Width - ClientWidth);\r\n Constraints.MinHeight := (ClientHeight - mm.ClientHeight) + 43 + (Height - ClientHeight);\r\nend;\r\n\r\nprocedure TSLEditorForm.MemoChanged(Sender: TObject);\r\nvar\r\n I: Integer;\r\nbegin\r\n I := mm.Lines.Count;\r\n if I <> 1 then\r\n lbl.Caption := IntToStr(I) + RsXLinesCaption\r\n else\r\n lbl.Caption := RsOneLineCaption;\r\n if Assigned(OnContentsChanged) then\r\n OnContentsChanged(Sender);\r\nend;\r\n\r\n//=== { TJvInspectorTStringsItem } ===========================================\r\n\r\nconstructor TJvInspectorTStringsItem.Create(const AParent: TJvCustomInspectorItem;\r\n const AData: TJvCustomInspectorData);\r\nbegin\r\n inherited Create(AParent, AData);\r\n RowSizing.MinHeight := irsItemHeight;\r\n Flags := Flags + [iifEditButton];\r\nend;\r\n\r\nprocedure TJvInspectorTStringsItem.ContentsChanged(Sender: TObject);\r\nvar\r\n Obj: TStrings;\r\nbegin\r\n Obj := TStrings(Data.AsOrdinal);\r\n Obj.Text := TMemo(Sender).Lines.Text;\r\nend;\r\n\r\nfunction TJvInspectorTStringsItem.GetDisplayValue: string;\r\nvar\r\n Obj: TObject;\r\nbegin\r\n Obj := TObject(Data.AsOrdinal);\r\n if not Multiline then\r\n begin\r\n if Obj <> nil then\r\n Result := Result + '(' + Obj.ClassName + ')'\r\n else\r\n Result := Result + '(' + GetTypeData(Data.TypeInfo).ClassType.ClassName + ')';\r\n end\r\n else\r\n Result := TStrings(Obj).Text;\r\nend;\r\n\r\nprocedure TJvInspectorTStringsItem.Edit;\r\nvar\r\n SL: TStrings;\r\nbegin\r\n with TSLEditorForm.CreateNew(Inspector) do\r\n try\r\n SL := TStrings(Data.AsOrdinal);\r\n mm.Lines.Assign(SL);\r\n if AutoUpdate then\r\n OnContentsChanged := ContentsChanged;\r\n if ShowModal = mrOK then\r\n SL.Assign(mm.Lines);\r\n finally\r\n Free;\r\n end;\r\nend;\r\n\r\nprocedure TJvInspectorTStringsItem.SetDisplayValue(const Value: string);\r\nvar\r\n Obj: TObject;\r\nbegin\r\n if Multiline then\r\n begin\r\n Obj := TObject(Data.AsOrdinal);\r\n TStrings(Obj).Text := Value;\r\n end;\r\nend;\r\n\r\nprocedure TJvInspectorTStringsItem.SetFlags(const Value: TInspectorItemFlags);\r\nvar\r\n OldMask: TInspectorItemFlags;\r\n NewMask: TInspectorItemFlags;\r\nbegin\r\n { The item has either an edit button or is multiline. If one of them is set,\r\n the other one will be removed }\r\n OldMask := Flags * [iifEditButton, iifMultiLine];\r\n NewMask := Value * [iifEditButton, iifMultiLine];\r\n if OldMask <> NewMask then\r\n begin\r\n if Multiline and not (iifEditButton in OldMask) and (iifEditButton in NewMask) then\r\n inherited SetFlags(Value - [iifMultiLine]) // iifEditButton has changed\r\n else\r\n if not Multiline and (iifEditButton in OldMask) and (iifMultiLine in NewMask) then\r\n inherited SetFlags(Value - [iifEditButton]) // iifMultiLine has changed\r\n else\r\n inherited SetFlags(Value); // Neither flag has changed. Should never occur.\r\n end\r\n else // Flags have not changed\r\n inherited SetFlags(Value);\r\n if RowSizing <> nil then\r\n begin\r\n RowSizing.Sizable := Multiline; // Update sizable state\r\n if not Multiline then\r\n RowSizing.SizingFactor := irsNoReSize\r\n else\r\n RowSizing.SizingFactor := irsValueHeight;\r\n end;\r\nend;\r\n\r\n//=== { TInstanceItem } ======================================================\r\n\r\ntype\r\n TInstanceItem = class(TObject)\r\n public\r\n Instance: TObject;\r\n Methods: TStrings;\r\n MethodStartIdx: Integer;\r\n Item: TJvInspectorTMethodItem;\r\n constructor Create;\r\n destructor Destroy; override;\r\n procedure AddMethod(const Name: string; const MethodAddr: Pointer);\r\n // procedure DeleteMethod(const Name: string); overload;\r\n // procedure DeleteMethod(const MethodAddr: Pointer); overload;\r\n procedure DeleteMethod(const Index: Integer); overload;\r\n procedure Clear;\r\n function IndexOf(const Name: string): Integer; overload;\r\n function IndexOf(const MethodAddr: Pointer): Integer; overload;\r\n end;\r\n\r\nconstructor TInstanceItem.Create;\r\nbegin\r\n inherited Create;\r\n Methods := TStringList.Create;\r\nend;\r\n\r\ndestructor TInstanceItem.Destroy;\r\nbegin\r\n Methods.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TInstanceItem.AddMethod(const Name: string; const MethodAddr: Pointer);\r\nvar\r\n I: Integer;\r\nbegin\r\n I := Methods.IndexOf(Name);\r\n if I = -1 then\r\n begin\r\n I := Methods.IndexOfObject(TObject(MethodAddr));\r\n if I = -1 then\r\n begin\r\n Methods.AddObject(Name, TObject(MethodAddr));\r\n I := Item.FList.IndexOfObject(Self) + 1;\r\n while I < Item.InstanceCount do\r\n begin\r\n Inc(TInstanceItem(Item.FList.Objects[I]).MethodStartIdx);\r\n Inc(I);\r\n end;\r\n end\r\n else\r\n Methods[I] := Name;\r\n end\r\n else\r\n Methods.Objects[I] := TObject(MethodAddr);\r\nend;\r\n\r\n(* make Delphi 5 compiler happy // andreas\r\nprocedure TInstanceItem.DeleteMethod(const Name: string);\r\nvar\r\n I: Integer;\r\nbegin\r\n I := Methods.IndexOf(Name);\r\n if I <> -1 then\r\n DeleteMethod(I);\r\nend;\r\n\r\nprocedure TInstanceItem.DeleteMethod(const MethodAddr: Pointer);\r\nvar\r\n I: Integer;\r\nbegin\r\n I := Methods.IndexOfObject(TObject(MethodAddr));\r\n if I <> -1 then\r\n DeleteMethod(I);\r\nend;\r\n*)\r\n\r\nprocedure TInstanceItem.DeleteMethod(const Index: Integer);\r\nbegin\r\n Methods.Delete(Index);\r\nend;\r\n\r\nprocedure TInstanceItem.Clear;\r\nbegin\r\n Methods.Clear;\r\nend;\r\n\r\nfunction TInstanceItem.IndexOf(const Name: string): Integer;\r\nbegin\r\n Result := Methods.IndexOf(Name);\r\nend;\r\n\r\nfunction TInstanceItem.IndexOf(const MethodAddr: Pointer): Integer;\r\nbegin\r\n Result := Methods.IndexOfObject(TObject(MethodAddr));\r\nend;\r\n\r\n//=== { TJvInspectorTMethodItem } ============================================\r\n\r\nfunction TJvInspectorTMethodItem.GetInstanceCount: Integer;\r\nbegin\r\n Result := FList.Count;\r\nend;\r\n\r\nfunction TJvInspectorTMethodItem.GetInstances(I: Integer): TObject;\r\nbegin\r\n Result := TInstanceItem(FList.Objects[I]).Instance;\r\nend;\r\n\r\nfunction TJvInspectorTMethodItem.GetInstanceNames(I: Integer): string;\r\nbegin\r\n Result := FList[I];\r\nend;\r\n\r\nfunction TJvInspectorTMethodItem.GetItemTMethodFlags: TInspectorTMethodFlags;\r\nbegin\r\n Result := FItemTMethodFlags;\r\nend;\r\n\r\nfunction TJvInspectorTMethodItem.GetKeepFirstInstanceAsFirst: Boolean;\r\nbegin\r\n Result := imfKeepFirstInstanceAsFirst in FItemTMethodFlags;\r\nend;\r\n\r\nfunction TJvInspectorTMethodItem.GetMethodCount(Instance: TObject): Integer;\r\nbegin\r\n Result := IndexOfInstance(Instance);\r\n if Result > -1 then\r\n Result := TInstanceItem(FList.Objects[Result]).Methods.Count\r\n else\r\n Result := 0;\r\nend;\r\n\r\nfunction TJvInspectorTMethodItem.GetMethods(Instance: TObject; I: Integer): TMethod;\r\nvar\r\n Idx: Integer;\r\nbegin\r\n Idx := IndexOfInstance(Instance);\r\n if Idx > -1 then\r\n begin\r\n Result.Data := Instance;\r\n Result.Code := TInstanceItem(FList.Objects[Idx]).Methods.Objects[I];\r\n end;\r\nend;\r\n\r\nfunction TJvInspectorTMethodItem.GetMethodNames(Instance: TObject; I: Integer): string;\r\nvar\r\n Idx: Integer;\r\nbegin\r\n Idx := IndexOfInstance(Instance);\r\n if Idx > -1 then\r\n Result := TInstanceItem(FList.Objects[Idx]).Methods[I];\r\nend;\r\n\r\nfunction TJvInspectorTMethodItem.GetNoShowFirstInstanceName: Boolean;\r\nbegin\r\n Result := imfNoShowFirstInstanceName in FItemTMethodFlags;\r\nend;\r\n\r\nfunction TJvInspectorTMethodItem.GetShowInstanceNames: Boolean;\r\nbegin\r\n Result := imfShowInstanceNames in FItemTMethodFlags;\r\nend;\r\n\r\nfunction TJvInspectorTMethodItem.GetSortMethods: Boolean;\r\nbegin\r\n Result := imfSortMethods in FItemTMethodFlags;\r\nend;\r\n\r\nfunction TJvInspectorTMethodItem.GetSortInstances: Boolean;\r\nbegin\r\n Result := imfSortInstances in FItemTMethodFlags;\r\nend;\r\n\r\nprocedure TJvInspectorTMethodItem.SetItemTMethodFlags(Value: TInspectorTMethodFlags);\r\nbegin\r\n if ItemTMethodFlags <> Value then\r\n begin\r\n FItemTMethodFlags := Value;\r\n InvalidateMetaData;\r\n end;\r\nend;\r\n\r\nprocedure TJvInspectorTMethodItem.SetKeepFirstInstanceAsFirst(Value: Boolean);\r\nbegin\r\n if Value then\r\n ItemTMethodFlags := ItemTMethodFlags + [imfKeepFirstInstanceAsFirst]\r\n else\r\n ItemTMethodFlags := ItemTMethodFlags - [imfKeepFirstInstanceAsFirst];\r\nend;\r\n\r\nprocedure TJvInspectorTMethodItem.SetNoShowFirstInstanceName(Value: Boolean);\r\nbegin\r\n if Value then\r\n ItemTMethodFlags := ItemTMethodFlags + [imfNoShowFirstInstanceName]\r\n else\r\n ItemTMethodFlags := ItemTMethodFlags - [imfNoShowFirstInstanceName];\r\nend;\r\n\r\nprocedure TJvInspectorTMethodItem.SetShowInstanceNames(Value: Boolean);\r\nbegin\r\n if Value then\r\n ItemTMethodFlags := ItemTMethodFlags + [imfShowInstanceNames]\r\n else\r\n ItemTMethodFlags := ItemTMethodFlags - [imfShowInstanceNames];\r\nend;\r\n\r\nprocedure TJvInspectorTMethodItem.SetSortMethods(Value: Boolean);\r\nbegin\r\n if Value then\r\n ItemTMethodFlags := ItemTMethodFlags + [imfSortMethods]\r\n else\r\n ItemTMethodFlags := ItemTMethodFlags - [imfSortMethods];\r\nend;\r\n\r\nprocedure TJvInspectorTMethodItem.SetSortInstances(Value: Boolean);\r\nbegin\r\n if Value then\r\n ItemTMethodFlags := ItemTMethodFlags + [imfSortInstances]\r\n else\r\n ItemTMethodFlags := ItemTMethodFlags - [imfSortInstances];\r\nend;\r\n\r\nprocedure TJvInspectorTMethodItem.AddInstancePrim(const Instance: TObject;\r\n const InstanceName: string);\r\nvar\r\n IdxInst: Integer;\r\n IdxName: Integer;\r\nbegin\r\n IdxInst := IndexOfInstance(Instance);\r\n IdxName := IndexOfInstance(InstanceName);\r\n if (IdxInst <> -1) and (IdxInst <> IdxName) then\r\n raise EJvInspectorItem.CreateRes(@RsEInstanceAlreadyExists);\r\n if (IdxName <> -1) and (IdxInst <> IdxName) then\r\n raise EJvInspectorItem.CreateRes(@RsENameAlreadyExistsForInstance);\r\n if IdxInst = -1 then\r\n begin\r\n IdxInst := FList.AddObject(InstanceName, TInstanceItem.Create);\r\n TInstanceItem(FList.Objects[IdxInst]).Instance := Instance;\r\n TInstanceItem(FList.Objects[IdxInst]).Item := Self;\r\n end;\r\nend;\r\n\r\nprocedure TJvInspectorTMethodItem.AddMethodPrim(const Instance: TObject;\r\n const MethodAddr: Pointer; const MethodName: string);\r\nvar\r\n InstIdx: Integer;\r\n InstItem: TInstanceItem;\r\n MethodIdx: Integer;\r\n MethodNameIdx: Integer;\r\nbegin\r\n InstIdx := IndexOfInstance(Instance);\r\n if InstIdx = -1 then\r\n raise EJvInspectorItem.CreateRes(@RsEInstanceNonexistent);\r\n InstItem := TInstanceItem(FList.Objects[InstIdx]);\r\n MethodIdx := InstItem.IndexOf(MethodAddr);\r\n MethodNameIdx := InstItem.IndexOf(MethodName);\r\n if (MethodIdx <> -1) and (MethodNameIdx <> MethodIdx) then\r\n raise EJvInspectorItem.CreateRes(@RsEMethodAlreadyExists);\r\n if (MethodNameIdx <> -1) and (MethodNameIdx <> MethodIdx) then\r\n raise EJvInspectorItem.CreateRes(@RsENameAlreadyExistsForMethod);\r\n if MethodIdx = -1 then\r\n InstItem.AddMethod(MethodName, MethodAddr);\r\nend;\r\n\r\nfunction TJvInspectorTMethodItem.MethodFromName(const Name: string): TMethod;\r\nvar\r\n IPeriod: Integer;\r\n InstIdx: Integer;\r\n MethodIdx: Integer;\r\nbegin\r\n IPeriod := Pos('.', Name);\r\n if IPeriod > 0 then\r\n InstIdx := IndexOfInstance(Copy(Name, 1, IPeriod - 1))\r\n else\r\n InstIdx := 0;\r\n if InstIdx < 0 then\r\n begin\r\n Result.Data := nil;\r\n Result.Code := nil;\r\n end\r\n else\r\n begin\r\n MethodIdx := IndexOfMethod(InstIdx, Copy(Name, IPeriod + 1, Length(Name) - IPeriod));\r\n if MethodIdx < 0 then\r\n begin\r\n Result.Data := nil;\r\n Result.Code := nil;\r\n end\r\n else\r\n Result := Methods[Instances[InstIdx], MethodIdx];\r\n end;\r\nend;\r\n\r\nfunction TJvInspectorTMethodItem.MethodFromAbsIndex(const Idx: Integer): TMethod;\r\nvar\r\n InstIdx: Integer;\r\n InstItem: TInstanceItem;\r\nbegin\r\n Result.Data := nil;\r\n Result.Code := nil;\r\n InstIdx := InstanceCount - 1;\r\n repeat\r\n InstItem := TInstanceItem(FList.Objects[InstIdx]);\r\n if InstItem.MethodStartIdx <= Idx then\r\n begin\r\n Result.Data := InstItem.Instance;\r\n Result.Code := InstItem.Methods.Objects[Idx - InstItem.MethodStartIdx];\r\n Break;\r\n end;\r\n until False;\r\nend;\r\n\r\nfunction TJvInspectorTMethodItem.NameFromMethod(const Method: TMethod): string;\r\nvar\r\n Instance: TObject;\r\n InstanceIdx: Integer;\r\n MethodIdx: Integer;\r\nbegin\r\n Instance := Method.Data;\r\n InstanceIdx := IndexOfInstance(Instance);\r\n MethodIdx := IndexOfMethod(Method);\r\n Result := '';\r\n if (InstanceIdx <> -1) and (MethodIdx <> -1) then\r\n begin\r\n if ShowInstanceNames and ((InstanceIdx > 0) or not NoShowFirstInstanceName) then\r\n Result := InstanceNames[InstanceIdx] + '.';\r\n Result := Result + MethodNames[Instance, MethodIdx];\r\n end;\r\nend;\r\n\r\nfunction TJvInspectorTMethodItem.AbsIndexFromMethod(const Method: TMethod): Integer;\r\nvar\r\n InstIdx: Integer;\r\n MethodIdx: Integer;\r\nbegin\r\n InstIdx := IndexOfInstance(TObject(Method.Data));\r\n if InstIdx > -1 then\r\n begin\r\n MethodIdx := TInstanceItem(FList.Objects[InstIdx]).IndexOf(Method.Code);\r\n if MethodIdx > -1 then\r\n Result := TInstanceItem(FList.Objects[InstIdx]).MethodStartIdx + MethodIdx\r\n else\r\n Result := -1;\r\n end\r\n else\r\n Result := -1;\r\nend;\r\n\r\nfunction TJvInspectorTMethodItem.GetDisplayValue: string;\r\nbegin\r\n if Data.SupportsMethodPointers then\r\n Result := NameFromMethod(Data.AsMethod)\r\n else\r\n Result := Data.GetAsString;\r\nend;\r\n\r\nprocedure TJvInspectorTMethodItem.GetValueList(const Strings: TStrings);\r\nvar\r\n SL: TStringList;\r\n InstanceList: TStringList;\r\n I: Integer;\r\n CurInstance: TInstanceItem;\r\n PrefixWithInstance: string;\r\n J: Integer;\r\nbegin\r\n SL := TStringList.Create;\r\n try\r\n InstanceList := TStringList.Create;\r\n try\r\n for I := 0 to InstanceCount - 1 do\r\n InstanceList.AddObject(InstanceNames[I], FList.Objects[I]);\r\n if SortInstances then\r\n InstanceList.Sort;\r\n if (InstanceCount > 0) and KeepFirstInstanceAsFirst then\r\n begin\r\n I := InstanceList.IndexOfObject(FList.Objects[0]);\r\n if I > 0 then\r\n begin\r\n InstanceList.Delete(I);\r\n InstanceList.InsertObject(0, InstanceNames[0], FList.Objects[0]);\r\n end;\r\n end;\r\n for I := 0 to InstanceCount - 1 do\r\n begin\r\n SL.Clear;\r\n CurInstance := TInstanceItem(InstanceList.Objects[I]);\r\n if ShowInstanceNames and ((I > 0) or not NoShowFirstInstanceName) then\r\n PrefixWithInstance := InstanceList[I] + '.'\r\n else\r\n PrefixWithInstance := '';\r\n for J := 0 to CurInstance.Methods.Count - 1 do\r\n SL.AddObject(PrefixWithInstance + CurInstance.Methods[J], TObject(CurInstance.MethodStartIdx + J));\r\n if SL.Count > 0 then\r\n begin\r\n if SortMethods then\r\n SL.Sort;\r\n Strings.AddStrings(SL);\r\n end;\r\n end;\r\n SL.Clear;\r\n inherited GetValueList(SL);\r\n if SortMethods then\r\n SL.Sort;\r\n if SL.Count > 0 then\r\n Strings.AddStrings(SL);\r\n finally\r\n InstanceList.Free;\r\n end;\r\n finally\r\n SL.Free;\r\n end;\r\nend;\r\n\r\nprocedure TJvInspectorTMethodItem.SetDisplayValue(const Value: string);\r\nvar\r\n M: TMethod;\r\nbegin\r\n M := MethodFromName(Value);\r\n if Data.SupportsMethodPointers then\r\n Data.AsMethod := M\r\n else\r\n Data.AsString := NameFromMethod(M);\r\nend;\r\n\r\nprocedure TJvInspectorTMethodItem.SetFlags(const Value: TInspectorItemFlags);\r\nbegin\r\n inherited SetFlags(Value + [iifValueList]);\r\nend;\r\n\r\nconstructor TJvInspectorTMethodItem.Create(const AParent: TJvCustomInspectorItem;\r\n const AData: TJvCustomInspectorData);\r\nbegin\r\n inherited Create(AParent, AData);\r\n FList := TStringList.Create;\r\n ItemTMethodFlags := [imfShowInstanceNames, imfNoShowFirstInstanceName,\r\n imfKeepFirstInstanceAsFirst, imfSortInstances, imfSortMethods];\r\nend;\r\n\r\nprocedure TJvInspectorTMethodItem.BeforeDestruction;\r\nbegin\r\n ClearInstances;\r\n FreeAndNil(FList);\r\n inherited BeforeDestruction;\r\nend;\r\n\r\nprocedure TJvInspectorTMethodItem.AddInstance(const Instance: TObject; const InstanceName: string);\r\nbegin\r\n AddInstancePrim(Instance, InstanceName);\r\nend;\r\n\r\nprocedure TJvInspectorTMethodItem.AddMethod(const Method: TMethod; const MethodName: string);\r\nbegin\r\n AddMethodPrim(TObject(Method.Data), Method.Code, MethodName);\r\nend;\r\n\r\nprocedure TJvInspectorTMethodItem.AddMethod(const Instance: TObject; MethodAddr: Pointer;\r\n const MethodName: string);\r\nbegin\r\n AddMethodPrim(Instance, MethodAddr, MethodName);\r\nend;\r\n\r\nprocedure TJvInspectorTMethodItem.DeleteInstance(const Index: Integer);\r\nvar\r\n InstItem: TInstanceItem;\r\nbegin\r\n InstItem := TInstanceItem(FList.Objects[Index]);\r\n InstItem.Free;\r\n FList.Delete(Index);\r\nend;\r\n\r\nprocedure TJvInspectorTMethodItem.DeleteInstance(const Instance: TObject);\r\nvar\r\n Idx: Integer;\r\nbegin\r\n Idx := IndexOfInstance(Instance);\r\n if Idx > -1 then\r\n DeleteInstance(Idx)\r\n else\r\n raise EJvInspectorItem.CreateRes(@RsEInstanceNonexistent);\r\nend;\r\n\r\nprocedure TJvInspectorTMethodItem.DeleteInstance(const InstanceName: string);\r\nvar\r\n Idx: Integer;\r\nbegin\r\n Idx := IndexOfInstance(InstanceName);\r\n if Idx > -1 then\r\n DeleteInstance(Idx)\r\n else\r\n raise EJvInspectorItem.CreateResFmt(@RsENamedInstanceNonexistent, [InstanceName]);\r\nend;\r\n\r\nprocedure TJvInspectorTMethodItem.DeleteMethod(const Method: TMethod);\r\nvar\r\n InstIdx: Integer;\r\n InstItem: TInstanceItem;\r\n MethodIdx: Integer;\r\nbegin\r\n InstIdx := IndexOfInstance(TObject(Method.Data));\r\n if InstIdx > -1 then\r\n begin\r\n InstItem := TInstanceItem(FList.Objects[InstIdx]);\r\n MethodIdx := InstItem.IndexOf(Method.Code);\r\n if MethodIdx > -1 then\r\n InstItem.DeleteMethod(MethodIdx)\r\n else\r\n raise EJvInspectorItem.CreateRes(@RsEMethodNonexistent);\r\n end\r\n else\r\n raise EJvInspectorItem.CreateRes(@RsEInstanceNonexistent);\r\nend;\r\n\r\nprocedure TJvInspectorTMethodItem.DeleteMethod(const InstanceIndex: Integer; const Index: Integer);\r\nbegin\r\n TInstanceItem(FList.Objects[InstanceIndex]).DeleteMethod(Index);\r\nend;\r\n\r\nprocedure TJvInspectorTMethodItem.DeleteMethod(const Instance: TObject; const Index: Integer);\r\nvar\r\n InstIdx: Integer;\r\nbegin\r\n InstIdx := IndexOfInstance(Instance);\r\n if InstIdx > -1 then\r\n DeleteMethod(InstIdx, Index)\r\n else\r\n raise EJvInspectorItem.CreateRes(@RsEInstanceNonexistent);\r\nend;\r\n\r\nprocedure TJvInspectorTMethodItem.DeleteMethod(const InstanceName: string; const Index: Integer);\r\nvar\r\n InstIdx: Integer;\r\nbegin\r\n InstIdx := IndexOfInstance(InstanceName);\r\n if InstIdx > -1 then\r\n DeleteMethod(InstIdx, Index)\r\n else\r\n raise EJvInspectorItem.CreateResFmt(@RsENamedInstanceNonexistent, [InstanceName]);\r\nend;\r\n\r\nprocedure TJvInspectorTMethodItem.DeleteMethod(const InstanceIndex: Integer; const MethodName: string);\r\nvar\r\n MethodIdx: Integer;\r\nbegin\r\n MethodIdx := TInstanceItem(FList.Objects[InstanceIndex]).IndexOf(MethodName);\r\n if MethodIdx > -1 then\r\n DeleteMethod(InstanceIndex, MethodIdx)\r\n else\r\n raise EJvInspectorItem.CreateResFmt(@RsENamedMethodNonexistent, [MethodName]);\r\nend;\r\n\r\nprocedure TJvInspectorTMethodItem.DeleteMethod(const Instance: TObject; const MethodName: string);\r\nvar\r\n InstIdx: Integer;\r\nbegin\r\n InstIdx := IndexOfInstance(Instance);\r\n if InstIdx > -1 then\r\n DeleteMethod(InstIdx, MethodName)\r\n else\r\n raise EJvInspectorItem.CreateRes(@RsEInstanceNonexistent);\r\nend;\r\n\r\nprocedure TJvInspectorTMethodItem.DeleteMethod(const InstanceName: string; const MethodName: string);\r\nvar\r\n InstIdx: Integer;\r\nbegin\r\n InstIdx := IndexOfInstance(InstanceName);\r\n if InstIdx > -1 then\r\n DeleteMethod(InstIdx, MethodName)\r\n else\r\n raise EJvInspectorItem.CreateResFmt(@RsENamedInstanceNonexistent, [InstanceName]);\r\nend;\r\n\r\nprocedure TJvInspectorTMethodItem.ClearInstances;\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := InstanceCount - 1 downto 0 do\r\n DeleteInstance(I);\r\nend;\r\n\r\nprocedure TJvInspectorTMethodItem.ClearMethods(const InstanceIndex: Integer);\r\nbegin\r\n TInstanceItem(FList.Objects[InstanceIndex]).Clear;\r\nend;\r\n\r\nprocedure TJvInspectorTMethodItem.ClearMethods(const Instance: TObject);\r\nvar\r\n InstIdx: Integer;\r\nbegin\r\n InstIdx := IndexOfInstance(Instance);\r\n if InstIdx > -1 then\r\n ClearMethods(InstIdx)\r\n else\r\n raise EJvInspectorItem.CreateRes(@RsEInstanceNonexistent);\r\nend;\r\n\r\nprocedure TJvInspectorTMethodItem.ClearMethods(const InstanceName: string);\r\nvar\r\n InstIdx: Integer;\r\nbegin\r\n InstIdx := IndexOfInstance(InstanceName);\r\n if InstIdx > -1 then\r\n ClearMethods(InstIdx)\r\n else\r\n raise EJvInspectorItem.CreateResFmt(@RsENamedInstanceNonexistent, [InstanceName]);\r\nend;\r\n\r\nfunction TJvInspectorTMethodItem.IndexOfInstance(const Instance: TObject): Integer;\r\nbegin\r\n Result := InstanceCount - 1;\r\n while (Result >= 0) and (TInstanceItem(FList.Objects[Result]).Instance <> Instance) do\r\n Dec(Result);\r\nend;\r\n\r\nfunction TJvInspectorTMethodItem.IndexOfInstance(const InstanceName: string): Integer;\r\nbegin\r\n Result := InstanceCount - 1;\r\n while (Result >= 0) and not AnsiSameText(FList[Result], InstanceName) do\r\n Dec(Result);\r\nend;\r\n\r\nfunction TJvInspectorTMethodItem.IndexOfMethod(const Method: TMethod): Integer;\r\nbegin\r\n Result := IndexOfInstance(TObject(Method.Data));\r\n if Result > -1 then\r\n Result := TInstanceItem(FList.Objects[Result]).IndexOf(Method.Code);\r\nend;\r\n\r\nfunction TJvInspectorTMethodItem.IndexOfMethod(const InstanceIndex: Integer; const MethodName: string): Integer;\r\nbegin\r\n Result := TInstanceItem(FList.Objects[InstanceIndex]).IndexOf(MethodName);\r\nend;\r\n\r\nfunction TJvInspectorTMethodItem.IndexOfMethod(const Instance: TObject; const MethodName: string): Integer;\r\nbegin\r\n Result := IndexOfInstance(Instance);\r\n if Result > -1 then\r\n Result := IndexOfMethod(Result, MethodName);\r\nend;\r\n\r\nfunction TJvInspectorTMethodItem.IndexOfMethod(const InstanceName: string; const MethodName: string): Integer;\r\nbegin\r\n Result := IndexOfInstance(InstanceName);\r\n if Result > -1 then\r\n Result := IndexOfMethod(Result, MethodName);\r\nend;\r\n\r\n//=== { TJvCustomInspectorData } =============================================\r\n\r\nconstructor TJvCustomInspectorData.Create;\r\nbegin\r\n raise EJvInspectorData.CreateResFmt(@RsENotSeparately, [ClassName]);\r\nend;\r\n\r\nconstructor TJvCustomInspectorData.CreatePrim(const AName: string;\r\n ATypeInfo: PTypeInfo);\r\nbegin\r\n inherited Create;\r\n Name := AName;\r\n TypeInfo := ATypeInfo;\r\nend;\r\n\r\nprocedure TJvCustomInspectorData.CheckReadAccess;\r\nbegin\r\n if not IsInitialized then\r\n raise EJvInspectorData.CreateRes(@RsEJvInspDataNotInit);\r\n if not IsAssigned then\r\n raise EJvInspectorData.CreateRes(@RsEJvInspDataNotAssigned);\r\n if not HasValue then\r\n raise EJvInspectorData.CreateRes(@RsEJvInspDataNoValue);\r\nend;\r\n\r\nprocedure TJvCustomInspectorData.CheckWriteAccess;\r\nbegin\r\n if not IsInitialized then\r\n raise EJvInspectorData.CreateRes(@RsEJvInspDataNotInit);\r\n if not HasValue then\r\n raise EJvInspectorData.CreateRes(@RsEJvInspDataNoValue);\r\nend;\r\n\r\nprocedure TJvCustomInspectorData.DoDataChanged;\r\nbegin\r\n if Assigned(FOnValueChanged) then\r\n FOnValueChanged(Self);\r\nend;\r\n\r\nprocedure TJvCustomInspectorData.DoneEdits(const CancelEdits: Boolean = False);\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := Low(FItems) to High(FItems) do\r\n if Items[I].Editing then\r\n Items[I].DoneEdit(CancelEdits);\r\nend;\r\n\r\nfunction TJvCustomInspectorData.GetItemCount: Integer;\r\nbegin\r\n Result := Length(FItems);\r\nend;\r\n\r\nfunction TJvCustomInspectorData.GetItems(I: Integer): TJvCustomInspectorItem;\r\nbegin\r\n if (I < Low(FItems)) or (I > High(FItems)) then\r\n TList.Error(SListIndexError, I);\r\n Result := FItems[I];\r\nend;\r\n\r\nfunction TJvCustomInspectorData.GetName: string;\r\nbegin\r\n Result := FName;\r\nend;\r\n\r\nfunction TJvCustomInspectorData.GetTypeInfo: PTypeInfo;\r\nbegin\r\n Result := FTypeInfo;\r\nend;\r\n\r\nprocedure TJvCustomInspectorData.InitEdits;\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := Low(FItems) to High(FItems) do\r\n if Items[I].Inspector.FocusedItem = Items[I] then\r\n Items[I].InitEdit;\r\nend;\r\n\r\nprocedure TJvCustomInspectorData.Invalidate;\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := High(FItems) downto Low(FItems) do\r\n FItems[I].InvalidateItem;\r\nend;\r\n\r\nprocedure TJvCustomInspectorData.InvalidateData;\r\nvar\r\n InspList: TList;\r\n I: Integer;\r\nbegin\r\n InspList := TList.Create;\r\n try\r\n // Fill list with unique inspector instances for this data instance\r\n for I := Low(FItems) to High(FItems) do\r\n if (FItems[I].Inspector <> nil) and (InspList.IndexOf(FItems[I].Inspector) = -1) then\r\n InspList.Add(FItems[I].Inspector);\r\n // Generate data changed event on this data instance\r\n DoDataChanged;\r\n // Generate data changed events on the inspectors that have a link to this data instance\r\n for I := 0 to InspList.Count - 1 do\r\n TJvCustomInspector(InspList[I]).DoDataValueChanged(Self);\r\n\r\n // Generate item changed events for all items for this data instance\r\n for I := Low(FItems) to High(FItems) do\r\n FItems[I].InvalidateValue;\r\n finally\r\n InspList.Free;\r\n end;\r\nend;\r\n\r\nfunction TJvCustomInspectorData.IsEqualReference(const Ref: TJvCustomInspectorData): Boolean;\r\nbegin\r\n Result := False;\r\nend;\r\n\r\nprocedure TJvCustomInspectorData.NotifyRemoveData(const Instance: TJvCustomInspectorData);\r\nbegin\r\nend;\r\n\r\nprocedure TJvCustomInspectorData.RefreshEdits;\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := High(FItems) downto Low(FItems) do\r\n if Items[I].Editing then\r\n begin\r\n Items[I].DoneEdit(True);\r\n Items[I].InitEdit;\r\n end;\r\nend;\r\n\r\nclass function TJvCustomInspectorData.RegisterInstance(const Instance: TJvCustomInspectorData): TJvCustomInspectorData;\r\nbegin\r\n Result := DataRegister.Add(Instance);\r\nend;\r\n\r\nprocedure TJvCustomInspectorData.RemoveItem(const Item: TJvCustomInspectorItem);\r\nvar\r\n I: Integer;\r\nbegin\r\n I := High(FItems);\r\n while (I >= 0) do\r\n begin\r\n if Items[I] = Item then\r\n Break;\r\n Dec(I);\r\n end;\r\n if I >= 0 then\r\n begin\r\n if I < High(FItems) then\r\n Move(FItems[I + 1], FItems[I], (High(FItems) - I) * SizeOf(TJvCustomInspectorItem));\r\n SetLength(FItems, High(FItems));\r\n end;\r\n if Length(FItems) = 0 then\r\n Destroy;\r\nend;\r\n\r\nprocedure TJvCustomInspectorData.SetName(const Value: string);\r\nbegin\r\n if Value <> Name then\r\n begin\r\n FName := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomInspectorData.SetTypeInfo(Value: PTypeInfo);\r\nbegin\r\n if Value <> TypeInfo then\r\n begin\r\n FTypeInfo := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nfunction TJvCustomInspectorData.SupportsMethodPointers: Boolean;\r\nbegin\r\n Result := False;\r\nend;\r\n\r\nprocedure TJvCustomInspectorData.BeforeDestruction;\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := High(FItems) downto Low(FItems) do\r\n Items[I].Free;\r\n if FRegistered and (GlobalDataRegister <> nil) then\r\n DataRegister().Remove(Self);\r\n inherited BeforeDestruction;\r\nend;\r\n\r\nclass function TJvCustomInspectorData.ItemRegister: TJvInspectorRegister;\r\nbegin\r\n if GlobalGenItemReg = nil then\r\n begin\r\n GlobalGenItemReg := TJvInspectorRegister.Create(TJvCustomInspectorData);\r\n // register\r\n RegisterDataTypeKinds;\r\n end;\r\n Result := GlobalGenItemReg;\r\nend;\r\n\r\nclass function TJvCustomInspectorData.New: TJvCustomInspectorData;\r\nbegin\r\n raise EJvInspectorData.CreateResFmt(@RsENoNewInstance, [ClassName]);\r\nend;\r\n\r\nfunction TJvCustomInspectorData.NewItem(const AParent: TJvCustomInspectorItem): TJvCustomInspectorItem;\r\nvar\r\n ItemClass: TJvInspectorItemClass;\r\n RegItem: TJvCustomInspectorRegItem;\r\nbegin\r\n Result := nil;\r\n AParent.Inspector.DoAfterDataCreate(Self);\r\n RegItem := ItemRegister.FindMatch(Self);\r\n if RegItem <> nil then\r\n begin\r\n ItemClass := RegItem.ItemClass;\r\n AParent.Inspector.DoBeforeItemCreate(Self, ItemClass);\r\n if ItemClass <> nil then\r\n begin\r\n Result := ItemClass.Create(AParent, Self);\r\n if Result <> nil then\r\n begin\r\n RegItem.ApplyDefaults(Result);\r\n SetLength(FItems, Length(FItems) + 1);\r\n FItems[High(FItems)] := Result;\r\n Result.InvalidateMetaData;\r\n Result.DoAfterItemCreate;\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\n//=== { TJvInspectorVarData } ================================================\r\n\r\nfunction TJvInspectorVarData.GetAddress: Pointer;\r\nbegin\r\n Result := FAddress;\r\nend;\r\n\r\nfunction TJvInspectorVarData.GetAsFloat: Extended;\r\nbegin\r\n CheckReadAccess;\r\n if TypeInfo.Kind = tkFloat then\r\n case GetTypeData(TypeInfo).FloatType of\r\n ftSingle:\r\n Result := PSingle(Address)^;\r\n ftDouble:\r\n Result := PDouble(Address)^;\r\n ftExtended:\r\n Result := PExtended(Address)^;\r\n ftComp:\r\n Result := PComp(Address)^;\r\n ftCurr:\r\n Result := PCurrency(Address)^;\r\n else\r\n Result := 0;\r\n end\r\n else\r\n raise EJvInspectorData.CreateResFmt(@RsEJvInspDataNoAccessAs, [cJvInspectorFloat]);\r\nend;\r\n\r\nfunction TJvInspectorVarData.GetAsInt64: Int64;\r\nbegin\r\n CheckReadAccess;\r\n if TypeInfo.Kind = tkInt64 then\r\n Result := PInt64(Address)^\r\n else\r\n raise EJvInspectorData.CreateResFmt(@RsEJvInspDataNoAccessAs, [cJvInspectorInt64]);\r\nend;\r\n\r\nfunction TJvInspectorVarData.GetAsMethod: TMethod;\r\nbegin\r\n CheckReadAccess;\r\n if TypeInfo.Kind = tkMethod then\r\n Result := PMethod(Address)^\r\n else\r\n raise EJvInspectorData.CreateResFmt(@RsEJvInspDataNoAccessAs, [cJvInspectorTMethod]);\r\nend;\r\n\r\nfunction TJvInspectorVarData.GetAsOrdinal: Int64;\r\nbegin\r\n CheckReadAccess;\r\n if TypeInfo.Kind in [tkInteger, tkChar, tkEnumeration, tkSet, tkWChar] then\r\n begin\r\n case GetTypeData(TypeInfo).OrdType of\r\n otSByte:\r\n Result := PShortint(Address)^;\r\n otUByte:\r\n Result := PByte(Address)^;\r\n otSWord:\r\n Result := PSmallint(Address)^;\r\n otUWord:\r\n Result := PWord(Address)^;\r\n otSLong:\r\n Result := PLongint(Address)^;\r\n otULong:\r\n Result := PLongword(Address)^;\r\n else\r\n Result := 0;\r\n end;\r\n end\r\n else\r\n if TypeInfo.Kind = tkClass then\r\n Result := PLongword(Address)^\r\n else\r\n raise EJvInspectorData.CreateResFmt(@RsEJvInspDataNoAccessAs, [cJvInspectorOrdinal]);\r\nend;\r\n\r\nfunction TJvInspectorVarData.GetAsString: string;\r\nbegin\r\n CheckReadAccess;\r\n if TypeInfo.Kind in tkStrings then\r\n begin\r\n case TypeInfo.Kind of\r\n {$IFDEF UNICODE}\r\n tkUString:\r\n Result := PUnicodeString(Address)^;\r\n {$ENDIF UNICODE}\r\n tkLString:\r\n Result := string(PAnsiString(Address)^);\r\n tkWString:\r\n Result := PWideString(Address)^;\r\n tkString:\r\n Result := string(PShortString(Address)^);\r\n else\r\n Result := '';\r\n end;\r\n end\r\n else\r\n raise EJvInspectorData.CreateResFmt(@RsEJvInspDataNoAccessAs, [cJvInspectorString]);\r\nend;\r\n\r\nfunction TJvInspectorVarData.GetAsVariant: Variant;\r\nbegin\r\n CheckReadAccess;\r\n if TypeInfo.Kind = tkVariant then\r\n begin\r\n Result := PVariant(Address)^;\r\n end\r\n else\r\n begin\r\n raise EJvInspectorData.CreateResFmt(@RsEJvInspDataNoAccessAs, [cJvInspectorVariant]);\r\n end;\r\nend;\r\n\r\nfunction TJvInspectorVarData.IsEqualReference(const Ref: TJvCustomInspectorData): Boolean;\r\nbegin\r\n Result := (Ref is TJvInspectorVarData) and (TJvInspectorVarData(Ref).Address = Address);\r\nend;\r\n\r\nprocedure TJvInspectorVarData.SetAddress(const Value: Pointer);\r\nbegin\r\n if Value <> Address then\r\n begin\r\n FAddress := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvInspectorVarData.SetAsFloat(const Value: Extended);\r\nbegin\r\n CheckWriteAccess;\r\n if TypeInfo.Kind = tkFloat then\r\n begin\r\n case GetTypeData(TypeInfo).FloatType of\r\n ftSingle:\r\n PSingle(Address)^ := Value;\r\n ftDouble:\r\n PDouble(Address)^ := Value;\r\n ftExtended:\r\n PExtended(Address)^ := Value;\r\n ftComp:\r\n PComp(Address)^ := Value;\r\n ftCurr:\r\n PCurrency(Address)^ := Value;\r\n end;\r\n InvalidateData;\r\n Invalidate;\r\n end\r\n else\r\n raise EJvInspectorData.CreateResFmt(@RsEJvInspDataNoAccessAs, [cJvInspectorFloat]);\r\nend;\r\n\r\nprocedure TJvInspectorVarData.SetAsInt64(const Value: Int64);\r\nbegin\r\n CheckWriteAccess;\r\n if TypeInfo.Kind = tkInt64 then\r\n begin\r\n if (Value < GetTypeData(TypeInfo).MinInt64Value) or (Value > GetTypeData(TypeInfo).MaxInt64Value) then\r\n raise ERangeError.CreateResFmt(@SOutOfRange,\r\n [GetTypeData(TypeInfo).MinValue, GetTypeData(TypeInfo).MaxValue]);\r\n PInt64(Address)^ := Value;\r\n InvalidateData;\r\n Invalidate;\r\n end\r\n else\r\n raise EJvInspectorData.CreateResFmt(@RsEJvInspDataNoAccessAs, [cJvInspectorInt64]);\r\nend;\r\n\r\nprocedure TJvInspectorVarData.SetAsMethod(const Value: TMethod);\r\nbegin\r\n CheckWriteAccess;\r\n if TypeInfo.Kind = tkMethod then\r\n PMethod(Address)^ := Value\r\n else\r\n raise EJvInspectorData.CreateResFmt(@RsEJvInspDataNoAccessAs, [cJvInspectorTMethod]);\r\n InvalidateData;\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvInspectorVarData.SetAsOrdinal(const Value: Int64);\r\nvar\r\n MinValue: Int64;\r\n MaxValue: Int64;\r\nbegin\r\n CheckWriteAccess;\r\n if TypeInfo.Kind in [tkInteger, tkChar, tkEnumeration, tkWChar] then\r\n begin\r\n case GetTypeData(TypeInfo).OrdType of\r\n otSByte:\r\n begin\r\n MinValue := GetTypeData(TypeInfo).MinValue;\r\n MaxValue := GetTypeData(TypeInfo).MaxValue;\r\n if (Value < MinValue) or (Value > MaxValue) then\r\n raise ERangeError.CreateResFmt(@SOutOfRange, [MinValue, MaxValue]);\r\n PShortint(Address)^ := Value;\r\n end;\r\n otUByte:\r\n begin\r\n MinValue := GetTypeData(TypeInfo).MinValue;\r\n MaxValue := GetTypeData(TypeInfo).MaxValue;\r\n if (Value < MinValue) or (Value > MaxValue) then\r\n raise ERangeError.CreateResFmt(@SOutOfRange, [MinValue, MaxValue]);\r\n PByte(Address)^ := Value;\r\n end;\r\n otSWord:\r\n begin\r\n MinValue := GetTypeData(TypeInfo).MinValue;\r\n MaxValue := GetTypeData(TypeInfo).MaxValue;\r\n if (Value < MinValue) or (Value > MaxValue) then\r\n raise ERangeError.CreateResFmt(@SOutOfRange, [MinValue, MaxValue]);\r\n PSmallint(Address)^ := Value;\r\n end;\r\n otUWord:\r\n begin\r\n MinValue := GetTypeData(TypeInfo).MinValue;\r\n MaxValue := GetTypeData(TypeInfo).MaxValue;\r\n if (Value < MinValue) or (Value > MaxValue) then\r\n raise ERangeError.CreateResFmt(@SOutOfRange, [MinValue, MaxValue]);\r\n PWord(Address)^ := Value;\r\n end;\r\n otSLong:\r\n begin\r\n MinValue := GetTypeData(TypeInfo).MinValue;\r\n MaxValue := GetTypeData(TypeInfo).MaxValue;\r\n if (Value < MinValue) or (Value > MaxValue) then\r\n raise ERangeError.CreateResFmt(@SOutOfRange, [MinValue, MaxValue]);\r\n PLongint(Address)^ := Value;\r\n end;\r\n otULong:\r\n begin\r\n MinValue := Longword(GetTypeData(TypeInfo).MinValue);\r\n MaxValue := Longword(GetTypeData(TypeInfo).MaxValue);\r\n if (Value < MinValue) or (Value > MaxValue) then\r\n raise ERangeError.CreateResFmt(@SOutOfRange, [MinValue, MaxValue]);\r\n PLongword(Address)^ := Value;\r\n end;\r\n end;\r\n end\r\n else\r\n if TypeInfo.Kind = tkClass then\r\n PLongword(Address)^ := Value\r\n else\r\n raise EJvInspectorData.CreateResFmt(@RsEJvInspDataNoAccessAs, [cJvInspectorOrdinal]);\r\n InvalidateData;\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvInspectorVarData.SetAsString(const Value: string);\r\nbegin\r\n CheckWriteAccess;\r\n if TypeInfo.Kind in tkStrings then\r\n begin\r\n case TypeInfo.Kind of\r\n {$IFDEF UNICODE}\r\n tkUString:\r\n PUnicodeString(Address)^ := Value;\r\n {$ENDIF UNICODE}\r\n tkLString:\r\n PAnsiString(Address)^ := AnsiString(Value);\r\n tkWString:\r\n PWideString(Address)^ := Value;\r\n tkString:\r\n if Length(Value) < GetTypeData(TypeInfo).MaxLength then\r\n PShortString(Address)^ := AnsiString(Value)\r\n else\r\n raise EJvInspectorData.CreateRes(@RsEJVInspDataStrTooLong);\r\n end;\r\n InvalidateData;\r\n Invalidate;\r\n end\r\n else\r\n raise EJvInspectorData.CreateResFmt(@RsEJvInspDataNoAccessAs, [cJvInspectorString]);\r\nend;\r\n\r\nprocedure TJvInspectorVarData.SetAsVariant(const Value: Variant);\r\nbegin\r\n CheckWriteAccess;\r\n if TypeInfo.Kind = tkVariant then\r\n begin\r\n PVariant(Address)^ := Value;\r\n end\r\n else\r\n begin\r\n raise EJvInspectorData.CreateResFmt(@RsEJvInspDataNoAccessAs, [cJvInspectorVariant]);\r\n end;\r\nend;\r\n\r\nfunction TJvInspectorVarData.SupportsMethodPointers: Boolean;\r\nbegin\r\n Result := True;\r\nend;\r\n\r\nprocedure TJvInspectorVarData.GetAsSet(var Buf);\r\nvar\r\n CompType: PTypeInfo;\r\n EnumMin: Integer;\r\n EnumMax: Integer;\r\n ResBytes: Integer;\r\nbegin\r\n CheckReadAccess;\r\n if TypeInfo.Kind = tkSet then\r\n begin\r\n CompType := GetTypeData(TypeInfo).CompType^;\r\n EnumMin := GetTypeData(CompType).MinValue;\r\n EnumMax := GetTypeData(CompType).MaxValue;\r\n ResBytes := (EnumMax div 8) - (EnumMin div 8) + 1;\r\n Move(PAnsiChar(Address)[0], Buf, ResBytes);\r\n end\r\n else\r\n raise EJvInspectorData.CreateResFmt(@RsEJvInspDataNoAccessAs, [cJvInspectorSet]);\r\nend;\r\n\r\nfunction TJvInspectorVarData.HasValue: Boolean;\r\nbegin\r\n // Cannot use AsVariant, it calls HasValue\r\n Result := IsInitialized and\r\n ((TypeInfo.Kind <> tkVariant) or\r\n not VarIsNull(PVariant(Address)^));\r\nend;\r\n\r\nfunction TJvInspectorVarData.IsAssigned: Boolean;\r\nbegin\r\n // Cannot use AsVariant, it calls IsAssigned\r\n Result := IsInitialized and\r\n ((TypeInfo.Kind <> tkVariant) or\r\n not VarIsEmpty(PVariant(Address)^));\r\nend;\r\n\r\nfunction TJvInspectorVarData.IsInitialized: Boolean;\r\nbegin\r\n Result := (TypeInfo <> nil) and (Address <> nil);\r\nend;\r\n\r\nclass function TJvInspectorVarData.ItemRegister: TJvInspectorRegister;\r\nbegin\r\n if GlobalVarItemReg = nil then\r\n GlobalVarItemReg := TJvInspectorRegister.Create(TJvInspectorVarData);\r\n Result := GlobalVarItemReg;\r\nend;\r\n\r\nclass function TJvInspectorVarData.New(const AParent: TJvCustomInspectorItem;\r\n const AName: string; ATypeInfo: PTypeInfo; const AAddress: Pointer): TJvCustomInspectorItem;\r\nvar\r\n Data: TJvInspectorVarData;\r\nbegin\r\n Data := CreatePrim(AName, ATypeInfo);\r\n Data.FAddress := AAddress;\r\n Data := TJvInspectorVarData(DataRegister.Add(Data));\r\n if Data <> nil then\r\n Result := Data.NewItem(AParent)\r\n else\r\n Result := nil;\r\nend;\r\n\r\n(* **REMOVED BECAUSE IT CREATES AN OVERLOADED SITUATION THAT IS INCOMPATIBLE WITH BCB.\r\n **USE @Var instead when invoking the other method, if you get compilation errors.\r\n class function TJvInspectorVarData.New(const AParent: TJvCustomInspectorItem; const AName: string; const ATypeInfo: PTypeInfo; const AVar): TJvCustomInspectorItem;\r\nbegin\r\n Result := New(AParent, AName, ATypeInfo, Addr(AVar));\r\nend;\r\n*)\r\n\r\nprocedure TJvInspectorVarData.SetAsSet(const Buf);\r\nvar\r\n CompType: PTypeInfo;\r\n EnumMin: Integer;\r\n EnumMax: Integer;\r\n ResBytes: Integer;\r\nbegin\r\n CheckWriteAccess;\r\n if TypeInfo.Kind = tkSet then\r\n begin\r\n CompType := GetTypeData(TypeInfo).CompType^;\r\n EnumMin := GetTypeData(CompType).MinValue;\r\n EnumMax := GetTypeData(CompType).MaxValue;\r\n ResBytes := (EnumMax div 8) - (EnumMin div 8) + 1;\r\n Move(Buf, PAnsiChar(Address)[0], ResBytes);\r\n InvalidateData;\r\n Invalidate;\r\n end\r\n else\r\n raise EJvInspectorData.CreateResFmt(@RsEJvInspDataNoAccessAs, [cJvInspectorSet]);\r\nend;\r\n\r\n//=== { TJvInspectorPropData } ===============================================\r\n\r\nfunction TJvInspectorPropData.GetAsFloat: Extended;\r\nbegin\r\n CheckReadAccess;\r\n if Prop.PropType^.Kind = tkFloat then\r\n Result := GetFloatProp(Instance, Prop)\r\n else\r\n raise EJvInspectorData.CreateResFmt(@RsEJvInspDataNoAccessAs, [cJvInspectorFloat]);\r\nend;\r\n\r\nfunction TJvInspectorPropData.GetAsInt64: Int64;\r\nbegin\r\n CheckReadAccess;\r\n if Prop.PropType^.Kind = tkInt64 then\r\n Result := GetInt64Prop(Instance, Prop)\r\n else\r\n raise EJvInspectorData.CreateResFmt(@RsEJvInspDataNoAccessAs, [cJvInspectorInt64]);\r\nend;\r\n\r\nfunction TJvInspectorPropData.GetAsMethod: TMethod;\r\nbegin\r\n CheckReadAccess;\r\n if Prop.PropType^.Kind = tkMethod then\r\n Result := GetMethodProp(Instance, Prop)\r\n else\r\n raise EJvInspectorData.CreateResFmt(@RsEJvInspDataNoAccessAs, [cJvInspectorTMethod]);\r\nend;\r\n\r\nfunction TJvInspectorPropData.GetAsOrdinal: Int64;\r\nbegin\r\n CheckReadAccess;\r\n if Prop.PropType^.Kind in [tkInteger, tkChar, tkEnumeration, tkSet,\r\n tkWChar, tkClass] then\r\n begin\r\n if GetTypeData(Prop.PropType^).OrdType = otULong then\r\n Result := Cardinal(GetOrdProp(Instance, Prop))\r\n else\r\n Result := GetOrdProp(Instance, Prop);\r\n end\r\n else\r\n raise EJvInspectorData.CreateResFmt(@RsEJvInspDataNoAccessAs, [cJvInspectorOrdinal]);\r\nend;\r\n\r\nfunction TJvInspectorPropData.GetAsString: string;\r\nbegin\r\n CheckReadAccess;\r\n if Prop.PropType^.Kind in tkStrings then\r\n Result := GetStrProp(Instance, Prop)\r\n else\r\n raise EJvInspectorData.CreateResFmt(@RsEJvInspDataNoAccessAs, [cJvInspectorString]);\r\nend;\r\n\r\nfunction TJvInspectorPropData.GetAsVariant: Variant;\r\nbegin\r\n CheckReadAccess;\r\n if Prop.PropType^.Kind = tkVariant then\r\n Result := GetVariantProp(Instance, Prop)\r\n else\r\n raise EJvInspectorData.CreateResFmt(@RsEJvInspDataNoAccessAs, [cJvInspectorVariant]);\r\nend;\r\n\r\nfunction TJvInspectorPropData.GetInstance: TObject;\r\nbegin\r\n Result := FInstance;\r\nend;\r\n\r\nfunction TJvInspectorPropData.GetProp: PPropInfo;\r\nbegin\r\n Result := FProp;\r\nend;\r\n\r\nfunction TJvInspectorPropData.IsEqualReference(const Ref: TJvCustomInspectorData): Boolean;\r\nbegin\r\n Result := (Ref is TJvInspectorPropData) and (TJvInspectorPropData(Ref).Instance = Instance) and\r\n (TJvInspectorPropData(Ref).Prop = Prop);\r\nend;\r\n\r\nprocedure TJvInspectorPropData.NotifyRemoveData(const Instance: TJvCustomInspectorData);\r\nbegin\r\n// The following is commented out due to Mantis #3348:\r\n// if (Instance <> nil) and (Instance <> Self) and (Instance.TypeInfo.Kind = tkClass) and\r\n// (TObject(Instance.AsOrdinal) = Self.Instance) then\r\n// Free;\r\nend;\r\n\r\nprocedure TJvInspectorPropData.SetAsFloat(const Value: Extended);\r\nbegin\r\n CheckWriteAccess;\r\n if IsReadOnlyProperty then\r\n Abort;\r\n if Prop.PropType^.Kind = tkFloat then\r\n SetFloatProp(Instance, Prop, Value)\r\n else\r\n raise EJvInspectorData.CreateResFmt(@RsEJvInspDataNoAccessAs, [cJvInspectorFloat]);\r\n InvalidateData;\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvInspectorPropData.SetAsInt64(const Value: Int64);\r\nbegin\r\n CheckWriteAccess;\r\n if IsReadOnlyProperty then\r\n Abort;\r\n if Prop.PropType^.Kind = tkInt64 then\r\n SetInt64Prop(Instance, Prop, Value)\r\n else\r\n raise EJvInspectorData.CreateResFmt(@RsEJvInspDataNoAccessAs, [cJvInspectorInt64]);\r\n InvalidateData;\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvInspectorPropData.SetAsMethod(const Value: TMethod);\r\nbegin\r\n CheckWriteAccess;\r\n if IsReadOnlyProperty then\r\n Abort;\r\n if Prop.PropType^.Kind = tkMethod then\r\n SetMethodProp(Instance, Prop, Value)\r\n else\r\n raise EJvInspectorData.CreateResFmt(@RsEJvInspDataNoAccessAs, [cJvInspectorTMethod]);\r\n InvalidateData;\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvInspectorPropData.SetAsOrdinal(const Value: Int64);\r\nbegin\r\n CheckWriteAccess;\r\n if IsReadOnlyProperty then\r\n Abort;\r\n if Prop.PropType^.Kind in [tkInteger, tkChar, tkEnumeration, tkSet,\r\n tkWChar, tkClass] then\r\n begin\r\n if GetTypeData(Prop.PropType^).OrdType = otULong then\r\n SetOrdProp(Instance, Prop, Cardinal(Value))\r\n else\r\n SetOrdProp(Instance, Prop, Value);\r\n end\r\n else\r\n raise EJvInspectorData.CreateResFmt(@RsEJvInspDataNoAccessAs, [cJvInspectorOrdinal]);\r\n InvalidateData;\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvInspectorPropData.SetAsString(const Value: string);\r\nbegin\r\n CheckWriteAccess;\r\n if IsReadOnlyProperty then\r\n Abort;\r\n if Prop.PropType^.Kind in tkStrings then\r\n SetStrProp(Instance, Prop, Value)\r\n else\r\n raise EJvInspectorData.CreateResFmt(@RsEJvInspDataNoAccessAs, [cJvInspectorString]);\r\n InvalidateData;\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvInspectorPropData.SetAsVariant(const Value: Variant);\r\nbegin\r\n CheckWriteAccess;\r\n if IsReadOnlyProperty then\r\n Abort;\r\n if TypeInfo.Kind = tkVariant then\r\n SetVariantProp(Instance, Prop, Value)\r\n else\r\n raise EJvInspectorData.CreateResFmt(@RsEJvInspDataNoAccessAs, [cJvInspectorVariant]);\r\n InvalidateData;\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvInspectorPropData.SetInstance(const Value: TObject);\r\nbegin\r\n if Instance <> Value then\r\n begin\r\n FInstance := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvInspectorPropData.SetProp(Value: PPropInfo);\r\nbegin\r\n if Prop <> Value then\r\n begin\r\n FProp := Value;\r\n TypeInfo := Value.PropType^;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nfunction TJvInspectorPropData.SupportsMethodPointers: Boolean;\r\nbegin\r\n Result := True;\r\nend;\r\n\r\nprocedure TJvInspectorPropData.GetAsSet(var Buf);\r\nvar\r\n I: Integer;\r\n CompType: PTypeInfo;\r\n EnumMin: Integer;\r\n EnumMax: Integer;\r\n ResBytes: Integer;\r\nbegin\r\n I := AsOrdinal;\r\n CompType := GetTypeData(TypeInfo).CompType^;\r\n EnumMin := GetTypeData(CompType).MinValue;\r\n EnumMax := GetTypeData(CompType).MaxValue;\r\n ResBytes := (EnumMax div 8) - (EnumMin div 8) + 1;\r\n Move(I, Buf, ResBytes);\r\nend;\r\n\r\nfunction TJvInspectorPropData.HasValue: Boolean;\r\nbegin\r\n Result := IsInitialized;\r\nend;\r\n\r\nfunction TJvInspectorPropData.IsAssigned: Boolean;\r\nbegin\r\n Result := IsInitialized;\r\nend;\r\n\r\nfunction TJvInspectorPropData.IsInitialized: Boolean;\r\nbegin\r\n Result := (Instance <> nil) and (Prop <> nil);\r\nend;\r\n\r\nfunction TJvInspectorPropData.IsReadOnlyProperty: Boolean;\r\nbegin\r\n Result := IsInitialized and (Prop^.SetProc = nil);\r\nend;\r\n\r\nclass function TJvInspectorPropData.ItemRegister: TJvInspectorRegister;\r\nbegin\r\n if GlobalPropItemReg = nil then\r\n begin\r\n GlobalPropItemReg := TJvInspectorRegister.Create(TJvInspectorPropData);\r\n // register\r\n RegisterPropDataTypeKinds;\r\n end;\r\n Result := GlobalPropItemReg;\r\nend;\r\n\r\nclass function TJvInspectorPropData.TypeInfoMapRegister: TJvInspectorRegister;\r\nbegin\r\n if GlobalPropMapReg = nil then\r\n GlobalPropMapReg := TJvInspectorRegister.Create(TJvCustomInspectorData);\r\n Result := GlobalPropMapReg;\r\nend;\r\n\r\nclass procedure TJvInspectorPropData.AddTypeMapping(Target, Source: PTypeInfo;\r\n ObjectClass: TClass; const PropertyName: string);\r\nbegin\r\n TypeInfoMapRegister.Add(TJvInspectorTypeInfoMapperRegItem.Create(ObjectClass,\r\n PropertyName, Source, Target));\r\nend;\r\n\r\nclass function TJvInspectorPropData.New(const AParent: TJvCustomInspectorItem;\r\n const AInstance: TObject; PropInfo: PPropInfo): TJvCustomInspectorItem;\r\nvar\r\n Data: TJvInspectorPropData;\r\n RegItem: TJvCustomInspectorRegItem;\r\nbegin\r\n if PropInfo = nil then\r\n raise EJvInspectorData.CreateRes(@RsEJvAssertPropInfo);\r\n Data := CreatePrim({$IFDEF SUPPORTS_UNICODE}UTF8ToString{$ENDIF SUPPORTS_UNICODE}(PropInfo.Name), PropInfo.PropType^);\r\n Data.Instance := AInstance;\r\n Data.Prop := PropInfo;\r\n Data := TJvInspectorPropData(DataRegister.Add(Data));\r\n if Data <> nil then\r\n begin\r\n RegItem := TypeInfoMapRegister.FindMatch(Data);\r\n if (RegItem <> nil) and (RegItem is TJvInspectorTypeInfoMapperRegItem) then\r\n Data.TypeInfo := TJvInspectorTypeInfoMapperRegItem(RegItem).NewTypeInfo;\r\n Result := Data.NewItem(AParent);\r\n end\r\n else\r\n Result := nil;\r\nend;\r\n\r\nclass function TJvInspectorPropData.New(const AParent: TJvCustomInspectorItem;\r\n const AInstance: TObject; const PropName: string): TJvCustomInspectorItem;\r\nvar\r\n PI: PPropInfo;\r\nbegin\r\n PI := GetPropInfo(AInstance, PropName, tkAny);\r\n if PI <> nil then\r\n Result := New(AParent, AInstance, PI)\r\n else\r\n Result := nil;\r\nend;\r\n\r\nclass function TJvInspectorPropData.New(const AParent: TJvCustomInspectorItem;\r\n const AInstance: TObject; const TypeKinds: TTypeKinds): TJvInspectorItemInstances;\r\nvar\r\n PropCount: Integer;\r\n PropList: PPropList;\r\nbegin\r\n SetLength(Result, 0);\r\n\r\n if AInstance.ClassInfo = nil then\r\n raise EJvInspectorData.CreateRes(@RsEJvAssertClassInfo);\r\n\r\n PropCount := GetPropList(AInstance.ClassInfo, TypeKinds, nil);\r\n GetMem(PropList, PropCount * SizeOf(PPropInfo));\r\n try\r\n GetPropList(AInstance.ClassInfo, TypeKinds, PropList);\r\n Result := New(AParent, AInstance, PropList, PropCount); // Generate Items for each Property element.\r\n finally\r\n FreeMem(PropList);\r\n end;\r\nend;\r\n\r\nclass function TJvInspectorPropData.NewByNames(const AParent: TJvCustomInspectorItem;\r\n const AInstance: TObject; const NameList: array of string;\r\n const ExcludeList: Boolean; const TypeKinds: TTypeKinds): TJvInspectorItemInstances;\r\nvar\r\n PropCount: Integer;\r\n PropList: PPropList;\r\n I: Integer;\r\n PropInfo: PPropInfo;\r\n NameIdx: Integer;\r\nbegin\r\n SetLength(Result, 0);\r\n\r\n if AInstance.ClassInfo = nil then\r\n raise EJvInspectorData.CreateRes(@RsEJvAssertClassInfo);\r\n\r\n PropCount := GetPropList(AInstance.ClassInfo, TypeKinds, nil);\r\n GetMem(PropList, PropCount * SizeOf(PPropInfo));\r\n try\r\n GetPropList(AInstance.ClassInfo, TypeKinds, PropList);\r\n for I := 0 to Pred(PropCount) do\r\n begin\r\n PropInfo := PropList[I];\r\n NameIdx := High(NameList);\r\n while (NameIdx >= 0) and not AnsiSameText(NameList[NameIdx], {$IFDEF SUPPORTS_UNICODE}UTF8ToString{$ENDIF SUPPORTS_UNICODE}(PropInfo.Name)) do\r\n Dec(NameIdx);\r\n if ((NameIdx < 0) and ExcludeList) or ((NameIdx > -1) and not ExcludeList) then\r\n begin\r\n SetLength(Result, Length(Result) + 1);\r\n Result[High(Result)] := New(AParent, AInstance, PropInfo);\r\n end;\r\n end;\r\n finally\r\n FreeMem(PropList);\r\n end;\r\nend;\r\n\r\nclass function TJvInspectorPropData.New(const AParent: TJvCustomInspectorItem;\r\n const AInstance: TObject; PropInfos: PPropList;\r\n const PropCount: Integer): TJvInspectorItemInstances;\r\nvar\r\n I: Integer;\r\nbegin\r\n SetLength(Result, PropCount);\r\n for I := 0 to Pred(PropCount) do\r\n Result[I] := New(AParent, AInstance, PropInfos[I]);\r\nend;\r\n\r\nprocedure TJvInspectorPropData.SetAsSet(const Buf);\r\nbegin\r\n AsOrdinal := Integer(Buf);\r\nend;\r\n\r\n//=== { TJvInspectorEventData } ==============================================\r\n\r\nfunction TJvInspectorEventData.DoGetAsFloat: Extended;\r\nbegin\r\n if Assigned(FOnGetAsFloat) then\r\n FOnGetAsFloat(Self, Result)\r\n else\r\n raise EJvInspectorData.CreateResFmt(@RsEJvInspDataNoAccessAs, [cJvInspectorFloat]);\r\nend;\r\n\r\nfunction TJvInspectorEventData.DoGetAsInt64: Int64;\r\nbegin\r\n if Assigned(FOnGetAsInt64) then\r\n FOnGetAsInt64(Self, Result)\r\n else\r\n raise EJvInspectorData.CreateResFmt(@RsEJvInspDataNoAccessAs, [cJvInspectorInt64]);\r\nend;\r\n\r\nfunction TJvInspectorEventData.DoGetAsMethod: TMethod;\r\nbegin\r\n if Assigned(FOnGetAsMethod) then\r\n FOnGetAsMethod(Self, Result)\r\n else\r\n raise EJvInspectorData.CreateResFmt(@RsEJvInspDataNoAccessAs, [cJvInspectorTMethod]);\r\nend;\r\n\r\nfunction TJvInspectorEventData.DoGetAsOrdinal: Int64;\r\nbegin\r\n if Assigned(FOnGetAsOrdinal) then\r\n FOnGetAsOrdinal(Self, Result)\r\n else\r\n raise EJvInspectorData.CreateResFmt(@RsEJvInspDataNoAccessAs, [cJvInspectorOrdinal]);\r\nend;\r\n\r\nfunction TJvInspectorEventData.DoGetAsString: string;\r\nbegin\r\n if Assigned(FOnGetAsString) then\r\n FOnGetAsString(Self, Result)\r\n else\r\n raise EJvInspectorData.CreateResFmt(@RsEJvInspDataNoAccessAs, [cJvInspectorString]);\r\nend;\r\n\r\nprocedure TJvInspectorEventData.DoGetAsSet(out Buf; var BufSize: Integer);\r\nbegin\r\n if Assigned(FOnGetAsSet) then\r\n FOnGetAsSet(Self, Buf, BufSize)\r\n else\r\n raise EJvInspectorData.CreateResFmt(@RsEJvInspDataNoAccessAs, [cJvInspectorSet]);\r\nend;\r\n\r\nprocedure TJvInspectorEventData.DoSetAsFloat(Value: Extended);\r\nbegin\r\n if Assigned(FOnSetAsFloat) then\r\n FOnSetAsFloat(Self, Value)\r\n else\r\n raise EJvInspectorData.CreateResFmt(@RsEJvInspDataNoAccessAs, [cJvInspectorFloat]);\r\nend;\r\n\r\nprocedure TJvInspectorEventData.DoSetAsInt64(Value: Int64);\r\nbegin\r\n if Assigned(FOnSetAsInt64) then\r\n FOnSetAsInt64(Self, Value)\r\n else\r\n raise EJvInspectorData.CreateResFmt(@RsEJvInspDataNoAccessAs, [cJvInspectorInt64]);\r\nend;\r\n\r\nprocedure TJvInspectorEventData.DoSetAsMethod(Value: TMethod);\r\nbegin\r\n if Assigned(FOnSetAsMethod) then\r\n FOnSetAsMethod(Self, Value)\r\n else\r\n raise EJvInspectorData.CreateResFmt(@RsEJvInspDataNoAccessAs, [cJvInspectorTMethod]);\r\nend;\r\n\r\nprocedure TJvInspectorEventData.DoSetAsOrdinal(Value: Int64);\r\nbegin\r\n if Assigned(FOnSetAsOrdinal) then\r\n FOnSetAsOrdinal(Self, Value)\r\n else\r\n raise EJvInspectorData.CreateResFmt(@RsEJvInspDataNoAccessAs, [cJvInspectorOrdinal]);\r\nend;\r\n\r\nprocedure TJvInspectorEventData.DoSetAsString(Value: string);\r\nbegin\r\n if Assigned(FOnSetAsString) then\r\n FOnSetAsString(Self, Value)\r\n else\r\n raise EJvInspectorData.CreateResFmt(@RsEJvInspDataNoAccessAs, [cJvInspectorString]);\r\nend;\r\n\r\nfunction TJvInspectorEventData.DoSupportsMethodPointers: Boolean;\r\nbegin\r\n Result := False;\r\n if Assigned(FOnSupportsMethodPointers) then\r\n FOnSupportsMethodPointers(Self, Result);\r\nend;\r\n\r\nprocedure TJvInspectorEventData.DoSetAsSet(const Buf; var BufSize: Integer);\r\nvar\r\n TmpBuf: PChar;\r\nbegin\r\n TmpBuf := @Buf;\r\n if Assigned(FOnSetAsSet) then\r\n FOnSetAsSet(Self, TmpBuf[0], BufSize)\r\n else\r\n raise EJvInspectorData.CreateResFmt(@RsEJvInspDataNoAccessAs, [cJvInspectorSet]);\r\nend;\r\n\r\nfunction TJvInspectorEventData.GetAsFloat: Extended;\r\nbegin\r\n CheckReadAccess;\r\n if TypeInfo.Kind = tkFloat then\r\n Result := DoGetAsFloat\r\n else\r\n raise EJvInspectorData.CreateResFmt(@RsEJvInspDataNoAccessAs, [cJvInspectorFloat]);\r\nend;\r\n\r\nfunction TJvInspectorEventData.GetAsInt64: Int64;\r\nbegin\r\n CheckReadAccess;\r\n if TypeInfo.Kind = tkInt64 then\r\n Result := DoGetAsInt64\r\n else\r\n raise EJvInspectorData.CreateResFmt(@RsEJvInspDataNoAccessAs, [cJvInspectorInt64]);\r\nend;\r\n\r\nfunction TJvInspectorEventData.GetAsMethod: TMethod;\r\nbegin\r\n CheckReadAccess;\r\n if TypeInfo.Kind = tkMethod then\r\n Result := DoGetAsMethod\r\n else\r\n raise EJvInspectorData.CreateResFmt(@RsEJvInspDataNoAccessAs, [cJvInspectorTMethod]);\r\nend;\r\n\r\nfunction TJvInspectorEventData.GetAsOrdinal: Int64;\r\nbegin\r\n CheckReadAccess;\r\n if TypeInfo.Kind in [tkInteger, tkChar, tkEnumeration, tkSet, tkWChar] then\r\n begin\r\n case GetTypeData(TypeInfo).OrdType of\r\n otSByte:\r\n Result := Shortint(DoGetAsOrdinal);\r\n otUByte:\r\n Result := Byte(DoGetAsOrdinal);\r\n otSWord:\r\n Result := Smallint(DoGetAsOrdinal);\r\n otUWord:\r\n Result := Word(DoGetAsOrdinal);\r\n otSLong:\r\n Result := Longint(DoGetAsOrdinal);\r\n otULong:\r\n Result := Longword(DoGetAsOrdinal);\r\n else\r\n Result := 0;\r\n end;\r\n end\r\n else\r\n if TypeInfo.Kind = tkClass then\r\n Result := Longword(DoGetAsOrdinal)\r\n else\r\n raise EJvInspectorData.CreateResFmt(@RsEJvInspDataNoAccessAs, [cJvInspectorOrdinal]);\r\nend;\r\n\r\nfunction TJvInspectorEventData.GetAsString: string;\r\nbegin\r\n CheckReadAccess;\r\n if TypeInfo.Kind in tkStrings then\r\n Result := DoGetAsString\r\n else\r\n raise EJvInspectorData.CreateResFmt(@RsEJvInspDataNoAccessAs, [cJvInspectorString]);\r\nend;\r\n\r\nfunction TJvInspectorEventData.IsEqualReference(const Ref: TJvCustomInspectorData): Boolean;\r\nbegin\r\n Result := (Ref is TJvInspectorEventData) and (TJvInspectorEventData(Ref).Name = Name) and\r\n (TJvInspectorEventData(Ref).TypeInfo = TypeInfo) and (TJvInspectorEventData(Ref).FParent = FParent);\r\nend;\r\n\r\nprocedure TJvInspectorEventData.SetAsFloat(const Value: Extended);\r\nbegin\r\n CheckWriteAccess;\r\n if TypeInfo.Kind = tkFloat then\r\n DoSetAsFloat(Value)\r\n else\r\n raise EJvInspectorData.CreateResFmt(@RsEJvInspDataNoAccessAs, [cJvInspectorFloat]);\r\n InvalidateData;\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvInspectorEventData.SetAsInt64(const Value: Int64);\r\nbegin\r\n CheckWriteAccess;\r\n if TypeInfo.Kind = tkInt64 then\r\n begin\r\n if (Value < GetTypeData(TypeInfo).MinInt64Value) or\r\n (Value > GetTypeData(TypeInfo).MaxInt64Value) then\r\n raise ERangeError.CreateResFmt(@SOutOfRange, [GetTypeData(TypeInfo).MinValue,\r\n GetTypeData(TypeInfo).MaxValue]);\r\n DoSetAsInt64(Value);\r\n end\r\n else\r\n raise EJvInspectorData.CreateResFmt(@RsEJvInspDataNoAccessAs, [cJvInspectorInt64]);\r\n InvalidateData;\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvInspectorEventData.SetAsMethod(const Value: TMethod);\r\nbegin\r\n CheckWriteAccess;\r\n if TypeInfo.Kind = tkMethod then\r\n DoSetAsMethod(Value)\r\n else\r\n raise EJvInspectorData.CreateResFmt(@RsEJvInspDataNoAccessAs, [cJvInspectorTMethod]);\r\n InvalidateData;\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvInspectorEventData.SetAsOrdinal(const Value: Int64);\r\nvar\r\n MinValue: Int64;\r\n MaxValue: Int64;\r\nbegin\r\n CheckWriteAccess;\r\n if TypeInfo.Kind in [tkInteger, tkChar, tkEnumeration, tkWChar] then\r\n begin\r\n if GetTypeData(TypeInfo).OrdType <> otULong then\r\n begin\r\n MinValue := GetTypeData(TypeInfo).MinValue;\r\n MaxValue := GetTypeData(TypeInfo).MaxValue;\r\n end\r\n else\r\n begin\r\n MinValue := Longword(GetTypeData(TypeInfo).MinValue);\r\n MaxValue := Longword(GetTypeData(TypeInfo).MaxValue);\r\n end;\r\n if (Value < MinValue) or (Value > MaxValue) then\r\n raise ERangeError.CreateResFmt(@SOutOfRange, [MinValue, MaxValue]);\r\n case GetTypeData(TypeInfo).OrdType of\r\n otSByte:\r\n DoSetAsOrdinal(Shortint(Value));\r\n otUByte:\r\n DoSetAsOrdinal(Byte(Value));\r\n otSWord:\r\n DoSetAsOrdinal(Smallint(Value));\r\n otUWord:\r\n DoSetAsOrdinal(Word(Value));\r\n otSLong:\r\n DoSetAsOrdinal(Longint(Value));\r\n otULong:\r\n DoSetAsOrdinal(Longword(Value));\r\n end;\r\n end\r\n else\r\n if TypeInfo.Kind = tkClass then\r\n DoSetAsOrdinal(Longword(Value))\r\n else\r\n raise EJvInspectorData.CreateResFmt(@RsEJvInspDataNoAccessAs, [cJvInspectorOrdinal]);\r\n InvalidateData;\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvInspectorEventData.SetAsString(const Value: string);\r\nbegin\r\n CheckWriteAccess;\r\n if TypeInfo.Kind in tkStrings then\r\n begin\r\n case TypeInfo.Kind of\r\n {$IFDEF UNICODE}\r\n tkUString:\r\n DoSetAsString(Value);\r\n {$ENDIF UNICODE}\r\n tkLString:\r\n DoSetAsString(Value);\r\n tkWString:\r\n DoSetAsString(Value);\r\n tkString:\r\n if Length(Value) < GetTypeData(TypeInfo).MaxLength then\r\n DoSetAsString(Value)\r\n else\r\n raise EJvInspectorData.CreateRes(@RsEJVInspDataStrTooLong);\r\n end;\r\n end\r\n else\r\n raise EJvInspectorData.CreateResFmt(@RsEJvInspDataNoAccessAs, [cJvInspectorString]);\r\n InvalidateData;\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvInspectorEventData.SetOnGetAsFloat(Value: TJvInspAsFloat);\r\nbegin\r\n if @FOnGetAsFloat <> @Value then\r\n begin\r\n FOnGetAsFloat := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvInspectorEventData.SetOnGetAsInt64(Value: TJvInspAsInt64);\r\nbegin\r\n if @FOnGetAsInt64 <> @Value then\r\n begin\r\n FOnGetAsInt64 := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvInspectorEventData.SetOnGetAsMethod(Value: TJvInspAsMethod);\r\nbegin\r\n if @FOnGetAsMethod <> @Value then\r\n begin\r\n FOnGetAsMethod := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvInspectorEventData.SetOnGetAsOrdinal(Value: TJvInspAsInt64);\r\nbegin\r\n if @FOnGetAsOrdinal <> @Value then\r\n begin\r\n FOnGetAsOrdinal := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvInspectorEventData.SetOnGetAsString(Value: TJvInspAsString);\r\nbegin\r\n if @FOnGetAsString <> @Value then\r\n begin\r\n FOnGetAsString := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvInspectorEventData.SetOnGetAsSet(Value: TJvInspAsSet);\r\nbegin\r\n if @FOnGetAsSet <> @Value then\r\n begin\r\n FOnGetAsSet := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvInspectorEventData.SetOnSetAsFloat(Value: TJvInspAsFloat);\r\nbegin\r\n if @FOnSetAsFloat <> @Value then\r\n begin\r\n FOnSetAsFloat := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvInspectorEventData.SetOnSetAsInt64(Value: TJvInspAsInt64);\r\nbegin\r\n if @FOnSetAsInt64 <> @Value then\r\n begin\r\n FOnSetAsInt64 := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvInspectorEventData.SetOnSetAsMethod(Value: TJvInspAsMethod);\r\nbegin\r\n if @FOnSetAsMethod <> @Value then\r\n begin\r\n FOnSetAsMethod := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvInspectorEventData.SetOnSetAsOrdinal(Value: TJvInspAsInt64);\r\nbegin\r\n if @FOnSetAsOrdinal <> @Value then\r\n begin\r\n FOnSetAsOrdinal := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvInspectorEventData.SetOnSetAsString(Value: TJvInspAsString);\r\nbegin\r\n if @FOnSetAsString <> @Value then\r\n begin\r\n FOnSetAsString := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvInspectorEventData.SetOnSetAsSet(Value: TJvInspAsSet);\r\nbegin\r\n if @FOnSetAsSet <> @Value then\r\n begin\r\n FOnSetAsSet := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvInspectorEventData.SetOnSupportsMethodPointers(Value: TJvInspSupportsMethodPointers);\r\nbegin\r\n if @FOnSupportsMethodPointers <> @Value then\r\n begin\r\n FOnSupportsMethodPointers := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nfunction TJvInspectorEventData.SupportsMethodPointers: Boolean;\r\nbegin\r\n Result := DoSupportsMethodPointers;\r\nend;\r\n\r\nprocedure TJvInspectorEventData.GetAsSet(var Buf);\r\nvar\r\n CompType: PTypeInfo;\r\n EnumMin: Integer;\r\n EnumMax: Integer;\r\n ResBytes: Integer;\r\nbegin\r\n CheckReadAccess;\r\n if TypeInfo.Kind = tkSet then\r\n begin\r\n CompType := GetTypeData(TypeInfo).CompType^;\r\n EnumMin := GetTypeData(CompType).MinValue;\r\n EnumMax := GetTypeData(CompType).MaxValue;\r\n ResBytes := (EnumMax div 8) - (EnumMin div 8) + 1;\r\n DoGetAsSet(Buf, ResBytes);\r\n end\r\n else\r\n raise EJvInspectorData.CreateResFmt(@RsEJvInspDataNoAccessAs, [cJvInspectorSet]);\r\nend;\r\n\r\nfunction TJvInspectorEventData.HasValue: Boolean;\r\nbegin\r\n Result := IsInitialized;\r\nend;\r\n\r\nfunction TJvInspectorEventData.IsAssigned: Boolean;\r\nbegin\r\n Result := IsInitialized;\r\nend;\r\n\r\nfunction TJvInspectorEventData.IsInitialized: Boolean;\r\nbegin\r\n Result := (TypeInfo <> nil) and (Assigned(OnGetAsFloat) or Assigned(OnGetAsInt64) or\r\n Assigned(OnGetAsMethod) or Assigned(OnGetAsOrdinal) or Assigned(OnGetAsString) or\r\n Assigned(OnGetAsSet));\r\nend;\r\n\r\nclass function TJvInspectorEventData.New(const AParent: TJvCustomInspectorItem;\r\n const AName: string; ATypeInfo: PTypeInfo): TJvCustomInspectorItem;\r\nvar\r\n Data: TJvInspectorEventData;\r\nbegin\r\n Data := TJvInspectorEventData(DataRegister.Add(CreatePrim(AName, ATypeInfo)));\r\n if Data <> nil then\r\n begin\r\n Data.FParent := AParent;\r\n Result := Data.NewItem(AParent)\r\n end\r\n else\r\n begin\r\n Result := nil;\r\n end;\r\nend;\r\n\r\nprocedure TJvInspectorEventData.SetAsSet(const Buf);\r\nvar\r\n CompType: PTypeInfo;\r\n EnumMin: Integer;\r\n EnumMax: Integer;\r\n ResBytes: Integer;\r\nbegin\r\n CheckWriteAccess;\r\n if TypeInfo.Kind = tkSet then\r\n begin\r\n CompType := GetTypeData(TypeInfo).CompType^;\r\n EnumMin := GetTypeData(CompType).MinValue;\r\n EnumMax := GetTypeData(CompType).MaxValue;\r\n ResBytes := (EnumMax div 8) - (EnumMin div 8) + 1;\r\n DoSetAsSet(Buf, ResBytes);\r\n end\r\n else\r\n raise EJvInspectorData.CreateResFmt(@RsEJvInspDataNoAccessAs, [cJvInspectorSet]);\r\n InvalidateData;\r\n Invalidate;\r\nend;\r\n\r\n//=== { TJvInspectorCustomConfData } =========================================\r\n\r\nconstructor TJvInspectorCustomConfData.CreatePrim(const AName, ASection, AKey: string;\r\n ATypeInfo: PTypeInfo);\r\nbegin\r\n inherited CreatePrim(AName, ATypeInfo);\r\n FKey := AKey;\r\n FSection := ASection;\r\nend;\r\n\r\nfunction TJvInspectorCustomConfData.GetAsFloat: Extended;\r\nbegin\r\n CheckReadAccess;\r\n if TypeInfo.Kind = tkFloat then\r\n Result := StrToFloat(Trim(StringReplace(ReadValue, JclFormatSettings.ThousandSeparator, JclFormatSettings.DecimalSeparator,\r\n [rfReplaceAll, rfIgnoreCase])))\r\n else\r\n raise EJvInspectorData.CreateResFmt(@RsEJvInspDataNoAccessAs, [cJvInspectorFloat]);\r\nend;\r\n\r\nfunction TJvInspectorCustomConfData.GetAsInt64: Int64;\r\nbegin\r\n CheckReadAccess;\r\n if TypeInfo.Kind = tkInt64 then\r\n Result := StrToInt64(ReadValue)\r\n else\r\n raise EJvInspectorData.CreateResFmt(@RsEJvInspDataNoAccessAs, [cJvInspectorInt64]);\r\nend;\r\n\r\nfunction TJvInspectorCustomConfData.GetAsMethod: TMethod;\r\nbegin\r\n CheckReadAccess;\r\n raise EJvInspectorData.CreateResFmt(@RsEJvInspDataNoAccessAs, [cJvInspectorTMethod]);\r\nend;\r\n\r\nfunction TJvInspectorCustomConfData.GetAsOrdinal: Int64;\r\nvar\r\n S: string;\r\nbegin\r\n CheckReadAccess;\r\n S := ReadValue;\r\n case TypeInfo.Kind of\r\n tkInteger:\r\n begin\r\n case GetTypeData(TypeInfo).OrdType of\r\n otSByte:\r\n Result := Shortint(StrToInt(S));\r\n otUByte:\r\n Result := Byte(StrToInt(S));\r\n otSWord:\r\n Result := Smallint(StrToInt(S));\r\n otUWord:\r\n Result := Word(StrToInt(S));\r\n otSLong:\r\n Result := Longint(StrToInt(S));\r\n otULong:\r\n Result := Longword(StrToInt(S));\r\n else\r\n Result := 0;\r\n end;\r\n end;\r\n tkChar, tkWChar:\r\n begin\r\n if Length(S) > 1 then\r\n Result := StrToInt(Copy(S, 2, Length(S)))\r\n else\r\n if Length(S) = 1 then\r\n Result := Ord(S[1])\r\n else\r\n Result := 0;\r\n end;\r\n tkEnumeration:\r\n Result := GetEnumValue(TypeInfo, S);\r\n tkSet:\r\n GetAsSet(Result);\r\n else\r\n raise EJvInspectorData.CreateResFmt(@RsEJvInspDataNoAccessAs, [cJvInspectorOrdinal]);\r\n end;\r\nend;\r\n\r\nfunction TJvInspectorCustomConfData.ForceString: string;\r\nbegin\r\n CheckReadAccess;\r\n Result := ReadValue;\r\nend;\r\n\r\nfunction TJvInspectorCustomConfData.GetAsString: string;\r\nbegin\r\n CheckReadAccess;\r\n if TypeInfo.Kind in tkStrings then\r\n Result := ReadValue\r\n else\r\n raise EJvInspectorData.CreateResFmt(@RsEJvInspDataNoAccessAs, [cJvInspectorString]);\r\nend;\r\n\r\nfunction TJvInspectorCustomConfData.IsEqualReference(const Ref: TJvCustomInspectorData): Boolean;\r\nbegin\r\n Result := (Ref is TJvInspectorCustomConfData) and\r\n AnsiSameText(TJvInspectorCustomConfData(Ref).Section, Section) and\r\n AnsiSameText(TJvInspectorCustomConfData(Ref).Key, Key);\r\nend;\r\n\r\nprocedure TJvInspectorCustomConfData.SetAsFloat(const Value: Extended);\r\nbegin\r\n CheckWriteAccess;\r\n if TypeInfo.Kind = tkFloat then\r\n WriteValue(FloatToStr(Value))\r\n else\r\n raise EJvInspectorData.CreateResFmt(@RsEJvInspDataNoAccessAs, [cJvInspectorFloat]);\r\n InvalidateData;\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvInspectorCustomConfData.SetAsInt64(const Value: Int64);\r\nbegin\r\n CheckWriteAccess;\r\n if TypeInfo.Kind = tkInt64 then\r\n WriteValue(IntToStr(Value))\r\n else\r\n raise EJvInspectorData.CreateResFmt(@RsEJvInspDataNoAccessAs, [cJvInspectorInt64]);\r\n InvalidateData;\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvInspectorCustomConfData.SetAsMethod(const Value: TMethod);\r\nbegin\r\n CheckWriteAccess;\r\n raise EJvInspectorData.CreateResFmt(@RsEJvInspDataNoAccessAs, [cJvInspectorTMethod]);\r\nend;\r\n\r\nprocedure TJvInspectorCustomConfData.SetAsOrdinal(const Value: Int64);\r\nbegin\r\n CheckWriteAccess;\r\n case TypeInfo.Kind of\r\n tkInteger:\r\n WriteValue(IntToStr(Value));\r\n tkChar, tkWChar:\r\n if (Value <= Ord(' ')) or (Value > Ord('~')) then\r\n WriteValue('#' + IntToStr(Value))\r\n else\r\n WriteValue(Chr(Byte(Value)));\r\n tkEnumeration:\r\n WriteValue(GetEnumName(TypeInfo, Value));\r\n tkSet:\r\n SetAsSet(Value);\r\n else\r\n raise EJvInspectorData.CreateResFmt(@RsEJvInspDataNoAccessAs, [cJvInspectorOrdinal]);\r\n end;\r\n InvalidateData;\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvInspectorCustomConfData.SetAsString(const Value: string);\r\nbegin\r\n CheckWriteAccess;\r\n case TypeInfo.Kind of\r\n tkString:\r\n if Length(Value) < GetTypeData(TypeInfo).MaxLength then\r\n WriteValue(Value)\r\n else\r\n raise EJvInspectorData.CreateRes(@RsEJVInspDataStrTooLong);\r\n tkLString, {$IFDEF UNICODE} tkUString, {$ENDIF} tkWString:\r\n WriteValue(Value)\r\n else\r\n raise EJvInspectorData.CreateResFmt(@RsEJvInspDataNoAccessAs, [cJvInspectorString]);\r\n end;\r\n InvalidateData;\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvInspectorCustomConfData.SetKey(const Value: string);\r\nbegin\r\n if Value <> Key then\r\n begin\r\n FKey := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvInspectorCustomConfData.SetSection(const Value: string);\r\nbegin\r\n if Value <> Section then\r\n begin\r\n FSection := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvInspectorCustomConfData.GetAsSet(var Buf);\r\nbegin\r\n CheckReadAccess;\r\n if TypeInfo.Kind = tkSet then\r\n JclStrToSet(TypeInfo, Buf, ReadValue)\r\n else\r\n raise EJvInspectorData.CreateResFmt(@RsEJvInspDataNoAccessAs, [cJvInspectorSet]);\r\nend;\r\n\r\nfunction TJvInspectorCustomConfData.HasValue: Boolean;\r\nbegin\r\n Result := IsInitialized;\r\nend;\r\n\r\nfunction TJvInspectorCustomConfData.IsAssigned: Boolean;\r\nbegin\r\n Result := IsInitialized and ExistingValue;\r\nend;\r\n\r\nfunction TJvInspectorCustomConfData.IsInitialized: Boolean;\r\nbegin\r\n Result := (Key <> '') and (Section <> '');\r\nend;\r\n\r\nprocedure TJvInspectorCustomConfData.SetAsSet(const Buf);\r\nbegin\r\n CheckWriteAccess;\r\n if TypeInfo.Kind = tkSet then\r\n WriteValue(JclSetToStr(TypeInfo, Buf, True, False))\r\n else\r\n raise EJvInspectorData.CreateResFmt(@RsEJvInspDataNoAccessAs, [cJvInspectorSet]);\r\n InvalidateData;\r\n Invalidate;\r\nend;\r\n\r\n//=== { TJvInspectorINIFileData } ============================================\r\n\r\nfunction TJvInspectorINIFileData.ExistingValue: Boolean;\r\nbegin\r\n Result := IsInitialized and INIFile.SectionExists(Section) and INIFile.ValueExists(Section, Key);\r\nend;\r\n\r\nfunction TJvInspectorINIFileData.IsEqualReference(const Ref: TJvCustomInspectorData): Boolean;\r\nbegin\r\n Result := (Ref is TJvInspectorINIFileData) and\r\n (TJvInspectorINIFileData(Ref).INIFile = INIFile) and inherited IsEqualReference(Ref);\r\nend;\r\n\r\nfunction TJvInspectorINIFileData.ReadValue: string;\r\nbegin\r\n Result := INIFile.ReadString(Section, Key, '');\r\nend;\r\n\r\nprocedure TJvInspectorINIFileData.WriteValue(const Value: string);\r\nbegin\r\n INIFile.WriteString(Section, Key, Value);\r\nend;\r\n\r\nclass function TJvInspectorINIFileData.New(const AParent: TJvCustomInspectorItem;\r\n const AName, ASection, AKey: string; ATypeInfo: PTypeInfo;\r\n const AINIFile: TCustomIniFile): TJvCustomInspectorItem;\r\nvar\r\n Data: TJvInspectorINIFileData;\r\nbegin\r\n if AINIFile = nil then\r\n raise EJvInspectorData.CreateRes(@RsEJvAssertINIFile);\r\n Data := CreatePrim(AName, ASection, AKey, ATypeInfo);\r\n Data.FINIFile := AINIFile;\r\n Data := TJvInspectorINIFileData(DataRegister.Add(Data));\r\n if Data <> nil then\r\n Result := Data.NewItem(AParent)\r\n else\r\n Result := nil;\r\nend;\r\n\r\nclass function TJvInspectorINIFileData.New(const AParent: TJvCustomInspectorItem;\r\n const ASection: string; const AINIFile: TCustomIniFile;\r\n const AOnAddKey: TJvInspConfKeyEvent): TJvInspectorItemInstances;\r\nvar\r\n SL: TStringList;\r\n I: Integer;\r\n KeyName: string;\r\n KeyTypeInfo: PTypeInfo;\r\n TmpItem: TJvCustomInspectorItem;\r\n //NewFlags: TInspectorItemFlags;\r\n\r\n function AllowAddKey: Boolean;\r\n begin\r\n KeyName := SL[I];\r\n KeyTypeInfo := System.TypeInfo(string);\r\n Result := True;\r\n //NewFlags := [iifVisible];\r\n if Assigned(AOnAddKey) then\r\n AOnAddKey(ASection, KeyName, KeyTypeInfo, Result {, NewFlags} );\r\n end;\r\n\r\nbegin\r\n if AINIFile = nil then\r\n raise EJvInspectorData.CreateRes(@RsEJvAssertINIFile);\r\n SetLength(Result, 0);\r\n SL := TStringList.Create;\r\n try\r\n AINIFile.ReadSection(ASection, SL);\r\n for I := 0 to SL.Count - 1 do\r\n begin\r\n if AllowAddKey then\r\n begin\r\n TmpItem := TJvInspectorINIFileData.New(AParent, KeyName, ASection, SL[I], KeyTypeInfo,\r\n AINIFile);\r\n //TmpItem.FFlags := NewFlags;\r\n // XXX Warren's first attempt to make inspector items know their data's names:\r\n //if (TmpItem.Parent.Name <> ASection) then\r\n // TmpItem.Parent.Name := ASection;\r\n //TmpItem.Name := KeyName;\r\n if TmpItem <> nil then\r\n begin\r\n SetLength(Result, Length(Result) + 1);\r\n Result[High(Result)] := TmpItem;\r\n end;\r\n end;\r\n end;\r\n finally\r\n SL.Free;\r\n end;\r\nend;\r\n\r\nclass function TJvInspectorINIFileData.New(const AParent: TJvCustomInspectorItem;\r\n const AINIFile: TCustomIniFile; const AOnAddSection: TJvInspConfSectionEvent;\r\n const AOnAddKey: TJvInspConfKeyEvent): TJvInspectorItemInstances;\r\nvar\r\n TmpLst: TJvInspectorItemInstances;\r\n SL: TStringList;\r\n I: Integer;\r\n CatName: string;\r\n CatItem: TJvInspectorCustomCategoryItem;\r\n\r\n function AllowAddSection: Boolean;\r\n begin\r\n CatName := SL[I];\r\n Result := True;\r\n if Assigned(AOnAddSection) then\r\n AOnAddSection(CatName, Result);\r\n end;\r\n\r\nbegin\r\n SetLength(TmpLst, 0);\r\n if AINIFile = nil then\r\n raise EJvInspectorData.CreateRes(@RsEJvAssertINIFile);\r\n SL := TStringList.Create;\r\n try\r\n AINIFile.ReadSections(SL);\r\n for I := 0 to SL.Count - 1 do\r\n begin\r\n if AllowAddSection then\r\n begin\r\n CatItem := TJvInspectorCustomCategoryItem.Create(AParent, nil);\r\n CatItem.Name := SL[I]; // the internal value. \r\n CatItem.DisplayName := CatName; // The displayed value\r\n //AParent.Name := SL[I];\r\n TmpLst := TJvInspectorINIFileData.New(CatItem, SL[I], AINIFile, AOnAddKey);\r\n SetLength(Result, Length(Result) + Length(TmpLst));\r\n Move(TmpLst[0], Result[Length(Result) - Length(TmpLst)], Length(TmpLst));\r\n if CatItem.Count = 0 then\r\n CatItem.Parent.Delete(CatItem);\r\n end;\r\n end;\r\n finally\r\n SL.Free;\r\n end;\r\nend;\r\n\r\n//=== { TJvInspectorRegister } ===============================================\r\n\r\nconstructor TJvInspectorRegister.Create(const ADataClass: TJvInspectorDataClass);\r\nbegin\r\n inherited Create;\r\n FDataClass := ADataClass;\r\n FItems := TObjectList.Create(True);\r\nend;\r\n\r\ndestructor TJvInspectorRegister.Destroy;\r\nbegin\r\n FItems.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJvInspectorRegister.Compare(const ADataObj: TJvCustomInspectorData;\r\n const Item1, Item2: TJvCustomInspectorRegItem): Integer;\r\nbegin\r\n Result := Item1.Compare(ADataObj, Item2);\r\nend;\r\n\r\nfunction TJvInspectorRegister.GetCount: Integer;\r\nbegin\r\n Result := FItems.Count;\r\nend;\r\n\r\nfunction TJvInspectorRegister.GetItems(const I: Integer): TJvCustomInspectorRegItem;\r\nbegin\r\n Result := TJvCustomInspectorRegItem(FItems[I]);\r\nend;\r\n\r\nprocedure TJvInspectorRegister.Add(const RegItem: TJvCustomInspectorRegItem);\r\nbegin\r\n FItems.Add(RegItem);\r\nend;\r\n\r\nprocedure TJvInspectorRegister.Delete(const RegItem: TJvCustomInspectorRegItem);\r\nbegin\r\n FItems.Remove(RegItem);\r\nend;\r\n\r\nprocedure TJvInspectorRegister.Delete(const ItemClass: TJvInspectorItemClass);\r\nvar\r\n Idx: Integer;\r\nbegin\r\n Idx := IndexOf(ItemClass);\r\n if Idx > -1 then\r\n Delete(Idx);\r\nend;\r\n\r\nprocedure TJvInspectorRegister.Delete(const Index: Integer);\r\nbegin\r\n FItems.Delete(Index);\r\nend;\r\n\r\nfunction TJvInspectorRegister.FindMatch(const ADataObj: TJvCustomInspectorData): TJvCustomInspectorRegItem;\r\nvar\r\n I: Integer;\r\n ParDataClass: TJvInspectorDataClass;\r\n ParResult: TJvCustomInspectorRegItem;\r\nbegin\r\n Result := nil;\r\n for I := Pred(Count) downto 0 do\r\n begin\r\n if Items[I].IsMatch(ADataObj) then\r\n begin\r\n if Result = nil then\r\n Result := Items[I]\r\n else\r\n if Compare(ADataObj, Result, Items[I]) < 0 then\r\n Result := Items[I];\r\n end;\r\n end;\r\n if (Result = nil) or (Result.MatchPercent(ADataObj) <> 100) then\r\n begin\r\n ParDataClass := TJvInspectorDataClass(DataClass.ClassParent);\r\n while (ParDataClass <> nil) and\r\n ParDataClass.InheritsFrom(TJvCustomInspectorData) and\r\n (ParDataClass.ItemRegister = Self) do\r\n ParDataClass := TJvInspectorDataClass(ParDataClass.ClassParent);\r\n if (ParDataClass <> nil) and\r\n ParDataClass.InheritsFrom(TJvCustomInspectorData) and\r\n (ParDataClass.ItemRegister <> Self) then\r\n begin\r\n ParResult := ParDataClass.ItemRegister.FindMatch(ADataObj);\r\n if (ParResult <> nil) and (((Result <> nil) and\r\n (Result.Compare(ADataObj, ParResult) < 0)) or (Result = nil)) then\r\n Result := ParResult;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJvInspectorRegister.IndexOf(const RegItem: TJvCustomInspectorRegItem): Integer;\r\nbegin\r\n Result := FItems.IndexOf(RegItem);\r\nend;\r\n\r\nfunction TJvInspectorRegister.IndexOf(const ItemClass: TJvInspectorItemClass): Integer;\r\nbegin\r\n Result := FItems.Count - 1;\r\n while (Result > -1) and (Items[Result].ItemClass <> ItemClass) do\r\n Dec(Result);\r\nend;\r\n\r\n//=== { TJvCustomInspectorRegItem } ==========================================\r\n\r\nconstructor TJvCustomInspectorRegItem.Create(const AItemClass: TJvInspectorItemClass);\r\nbegin\r\n inherited Create;\r\n FItemClass := AItemClass;\r\nend;\r\n\r\nfunction TJvCustomInspectorRegItem.CompareTo(const ADataObj: TJvCustomInspectorData;\r\n const Item: TJvCustomInspectorRegItem): Integer;\r\nbegin\r\n if MatchPercent(ADataObj) > Item.MatchPercent(ADataObj) then\r\n Result := MatchPercent(ADataObj)\r\n else\r\n Result := -Item.MatchPercent(ADataObj)\r\nend;\r\n\r\nfunction TJvCustomInspectorRegItem.GetItemClass: TJvInspectorItemClass;\r\nbegin\r\n Result := FItemClass;\r\nend;\r\n\r\nprocedure TJvCustomInspectorRegItem.SetItemClass(const Value: TJvInspectorItemClass);\r\nbegin\r\n FItemClass := Value;\r\nend;\r\n\r\nprocedure TJvCustomInspectorRegItem.ApplyDefaults(const Item: TJvCustomInspectorItem);\r\nbegin\r\n { Override in descendants to apply special defaults }\r\nend;\r\n\r\nfunction TJvCustomInspectorRegItem.Compare(const ADataObj: TJvCustomInspectorData;\r\n const Item: TJvCustomInspectorRegItem): Integer;\r\nbegin\r\n if ClassType = Item.ClassType then\r\n begin\r\n if MatchValue(ADataObj) >= Item.MatchValue(ADataObj) then\r\n Result := MatchValue(ADataObj)\r\n else\r\n Result := -Item.MatchValue(ADataObj);\r\n end\r\n else\r\n Result := -Item.CompareTo(ADataObj, Self);\r\nend;\r\n\r\nfunction TJvCustomInspectorRegItem.IsMatch(const ADataObj: TJvCustomInspectorData): Boolean;\r\nbegin\r\n Result := MatchValue(ADataObj) <> 0;\r\nend;\r\n\r\n//=== { TJvInspectorTypeInfoRegItem } ========================================\r\n\r\nconstructor TJvInspectorTypeInfoRegItem.Create(const AItemClass: TJvInspectorItemClass;\r\n ATypeInfo: PTypeInfo);\r\nbegin\r\n inherited Create(AItemClass);\r\n FTypeInfo := ATypeInfo;\r\nend;\r\n\r\nfunction TJvInspectorTypeInfoRegItem.GetTypeInfo: PTypeInfo;\r\nbegin\r\n Result := FTypeInfo;\r\nend;\r\n\r\nprocedure TJvInspectorTypeInfoRegItem.SetTypeInfo(Value: PTypeInfo);\r\nbegin\r\n FTypeInfo := Value;\r\nend;\r\n\r\nfunction TJvInspectorTypeInfoRegItem.MatchValue(const ADataObj: TJvCustomInspectorData): Integer;\r\nbegin\r\n if ADataObj.TypeInfo = TypeInfo then\r\n Result := 100\r\n else\r\n if (TypeInfo.Kind = tkClass) and (ADataObj.TypeInfo.Kind = tkClass) and\r\n (GetTypeData(ADataObj.TypeInfo).ClassType.InheritsFrom(GetTypeData(TypeInfo).ClassType)) then\r\n Result := 50\r\n else\r\n Result := 0;\r\nend;\r\n\r\nfunction TJvInspectorTypeInfoRegItem.MatchPercent(const ADataObj: TJvCustomInspectorData): Integer;\r\nbegin\r\n { Matching TypeInfo is a perfect match. Since MatchValue already returns a\r\n percentage, just return that value. }\r\n Result := MatchValue(ADataObj);\r\nend;\r\n\r\n//=== { TJvInspectorTCaptionRegItem } ========================================\r\n\r\nprocedure TJvInspectorTCaptionRegItem.ApplyDefaults(const Item: TJvCustomInspectorItem);\r\nbegin\r\n if Item <> nil then\r\n with Item do\r\n begin\r\n AutoUpdate := True;\r\n Flags := Item.Flags + [iifMultiLine];\r\n RowSizing.SizingFactor := irsValueHeight;\r\n RowSizing.MinHeight := irsItemHeight;\r\n RowSizing.Sizable := True;\r\n end;\r\nend;\r\n\r\n//=== { TJvInspectorTypeKindRegItem } ========================================\r\n\r\nconstructor TJvInspectorTypeKindRegItem.Create(const AItemClass: TJvInspectorItemClass;\r\n const ATypeKind: TTypeKind);\r\nbegin\r\n inherited Create(AItemClass);\r\n FTypeKind := ATypeKind;\r\nend;\r\n\r\nfunction TJvInspectorTypeKindRegItem.CompareTo(const ADataObj: TJvCustomInspectorData;\r\n const Item: TJvCustomInspectorRegItem): Integer;\r\nbegin\r\n if Item is TJvInspectorTypeInfoRegItem then\r\n Result := -Item.MatchValue(ADataObj)\r\n else\r\n Result := inherited CompareTo(ADataObj, Item);\r\nend;\r\n\r\nfunction TJvInspectorTypeKindRegItem.GetTypeKind: TTypeKind;\r\nbegin\r\n Result := FTypeKind;\r\nend;\r\n\r\nprocedure TJvInspectorTypeKindRegItem.SetTypeKind(const Value: TTypeKind);\r\nbegin\r\n FTypeKind := Value;\r\nend;\r\n\r\nfunction TJvInspectorTypeKindRegItem.Compare(const ADataObj: TJvCustomInspectorData;\r\n const Item: TJvCustomInspectorRegItem): Integer;\r\nbegin\r\n if Item is TJvInspectorTypeInfoRegItem then\r\n begin\r\n if MatchValue(ADataObj) >= Item.MatchValue(ADataObj) then\r\n Result := MatchValue(ADataObj)\r\n else\r\n Result := -Item.MatchValue(ADataObj);\r\n end\r\n else\r\n Result := inherited Compare(ADataObj, Item);\r\nend;\r\n\r\nfunction TJvInspectorTypeKindRegItem.MatchValue(const ADataObj: TJvCustomInspectorData): Integer;\r\nbegin\r\n if ADataObj.TypeInfo.Kind = TypeKind then\r\n Result := 100\r\n else\r\n Result := 0;\r\nend;\r\n\r\nfunction TJvInspectorTypeKindRegItem.MatchPercent(const ADataObj: TJvCustomInspectorData): Integer;\r\nbegin\r\n { Matching TypeKind is 50% match. Since MatchValue returns either 0 or 100,\r\n devide it by two to get 0 or 50. }\r\n Result := MatchValue(ADataObj) div 2;\r\nend;\r\n\r\n//=== { TJvInspectorPropRegItem } ============================================\r\n\r\nconstructor TJvInspectorPropRegItem.Create(const AItemClass: TJvInspectorItemClass;\r\n const AObjectClass: TClass; const AName: string; ATypeInfo: PTypeInfo);\r\nbegin\r\n inherited Create(AItemClass);\r\n FObjectClass := AObjectClass;\r\n FName := AName;\r\n FTypeInfo := ATypeInfo;\r\nend;\r\n\r\nfunction TJvInspectorPropRegItem.Compare(const ADataObj: TJvCustomInspectorData;\r\n const Item: TJvCustomInspectorRegItem): Integer;\r\nbegin\r\n if not (Item is TJvInspectorPropRegItem) then\r\n Result := MatchValue(ADataObj)\r\n else\r\n Result := inherited Compare(ADataObj, Item);\r\nend;\r\n\r\nfunction TJvInspectorPropRegItem.MatchValue(const ADataObj: TJvCustomInspectorData): Integer;\r\nvar\r\n GoOn: Boolean;\r\n ObjParentClass: TClass;\r\nbegin\r\n { Match value will be based on the all set items according to the following\r\n table:\r\n\r\n Base value is 0\r\n * ClassType known\r\n * class type equal: add 32\r\n * class type inherits: add 16\r\n * class does not match: return 0\r\n * Name known\r\n * Name exact match: add 8\r\n * Name matches by mask: add 4\r\n * Name does not match: return 0\r\n * Type info known\r\n * Typeinfo exact match: add 2\r\n * Typeinfo typekind matches: add 1\r\n * Typeinfo does not match: return 0\r\n }\r\n Result := 0;\r\n GoOn := True;\r\n if TypeInfo <> nil then\r\n begin\r\n if TypeInfo = ADataObj.TypeInfo then\r\n Result := Result or 2\r\n else\r\n if TypeInfo.Kind = ADataObj.TypeInfo.Kind then\r\n begin\r\n if (TypeInfo.Kind <> tkClass) or\r\n (GetTypeData(ADataObj.TypeInfo).ClassType.InheritsFrom(GetTypeData(TypeInfo).ClassType)) then\r\n Result := Result or 1\r\n else\r\n GoOn := False;\r\n end\r\n else\r\n GoOn := False;\r\n end;\r\n\r\n if GoOn and (Name <> '') then\r\n begin\r\n if AnsiSameText(Name, ADataObj.Name) then\r\n Result := Result or 8\r\n { Match by mask }\r\n else\r\n GoOn := False;\r\n end;\r\n\r\n if GoOn and (ObjectClass <> nil) then\r\n begin\r\n { Class type based on the parent object }\r\n ObjParentClass := TJvInspectorPropData(ADataObj).Instance.ClassType;\r\n if ObjParentClass = ObjectClass then\r\n Result := Result or 32\r\n else\r\n if (ObjParentClass <> nil) and ObjParentClass.InheritsFrom(ObjectClass) then\r\n Result := Result or 16\r\n else\r\n GoOn := False;\r\n end;\r\n\r\n if not GoOn then\r\n Result := 0;\r\nend;\r\n\r\nfunction TJvInspectorPropRegItem.MatchPercent(const ADataObj: TJvCustomInspectorData): Integer;\r\nvar\r\n MV: Integer;\r\nbegin\r\n { A 100% score would mean that Class, Name and TypeInfo all were a perfect\r\n match. }\r\n Result := 100;\r\n MV := MatchValue(ADataObj);\r\n if MV = 0 then\r\n Result := 0\r\n else\r\n begin\r\n if ObjectClass <> nil then\r\n begin\r\n if (MV and 16) <> 0 then\r\n Result := Result div 2;\r\n end\r\n else\r\n Dec(Result, 8);\r\n\r\n if Name <> '' then\r\n begin\r\n if (MV and 4) <> 0 then\r\n Result := Result div 2;\r\n end\r\n else\r\n Dec(Result, 4);\r\n\r\n if TypeInfo <> nil then\r\n begin\r\n if (MV and 1) <> 0 then\r\n Result := Result div 2;\r\n end\r\n else\r\n Dec(Result, 8);\r\n end;\r\nend;\r\n\r\n//=== { TJvInspectorTypeInfoMapperRegItem } ==================================\r\n\r\nconstructor TJvInspectorTypeInfoMapperRegItem.Create(AObjectClass: TClass;\r\n const APropertyName: string; APropertyType: PTypeInfo; ANewTypeInfo: PTypeInfo);\r\nbegin\r\n inherited Create(nil);\r\n FObjectClass := AObjectClass;\r\n FPropertyName := APropertyName;\r\n FPropertyType := APropertyType;\r\n FNewTypeInfo := ANewTypeInfo;\r\nend;\r\n\r\nfunction TJvInspectorTypeInfoMapperRegItem.Compare(const ADataObj: TJvCustomInspectorData;\r\n const Item: TJvCustomInspectorRegItem): Integer;\r\nbegin\r\n Result := inherited CompareTo(ADataObj, Item);\r\nend;\r\n\r\nfunction TJvInspectorTypeInfoMapperRegItem.MatchValue(const ADataObj: TJvCustomInspectorData): Integer;\r\nvar\r\n RetVal: Integer;\r\nbegin\r\n { ObjectClass known\r\n Same class: add 32\r\n Inherited class: add 16\r\n no match: return 0\r\n\r\n PropertyName known\r\n Exact match: add 8\r\n Masked match: add 4\r\n no match: return 0\r\n\r\n PropertyType\r\n Exact match: add 2\r\n Same type kind: add 1\r\n No match: return 0 }\r\n Result := 0;\r\n RetVal := Result;\r\n if ObjectClass <> nil then\r\n begin\r\n if TJvInspectorPropData(ADataObj).Instance.ClassType = ObjectClass then\r\n Inc(RetVal, 32)\r\n else\r\n if TJvInspectorPropData(ADataObj).Instance.InheritsFrom(ObjectClass) then\r\n Inc(RetVal, 16)\r\n else\r\n Exit;\r\n end;\r\n\r\n if PropertyName <> '' then\r\n begin\r\n if AnsiSameText(PropertyName, ADataObj.Name) then\r\n Inc(RetVal, 8)\r\n else\r\n Exit;\r\n end;\r\n\r\n if PropertyType <> nil then\r\n begin\r\n if PropertyType = ADataObj.TypeInfo then\r\n Inc(RetVal, 2)\r\n{ else\r\n if PropertyType.Kind = ADataObj.TypeInfo.Kind then\r\n Inc(RetVal, 1)}\r\n else\r\n Exit;\r\n end;\r\n Result := RetVal;\r\nend;\r\n\r\nfunction TJvInspectorTypeInfoMapperRegItem.MatchPercent(const ADataObj: TJvCustomInspectorData): Integer;\r\nvar\r\n MV: Integer;\r\n ClassMatch: Integer;\r\n NameMatch: Integer;\r\n TypeMatch: Integer;\r\nbegin\r\n MV := MatchValue(ADataObj);\r\n if MV = 0 then\r\n Result := 0\r\n else\r\n begin\r\n if MV and 32 <> 0 then\r\n ClassMatch := 100\r\n else\r\n if MV and 16 <> 0 then\r\n ClassMatch := 50\r\n else\r\n ClassMatch := 0;\r\n\r\n if MV and 8 <> 0 then\r\n NameMatch := 100\r\n else\r\n if MV and 4 <> 0 then\r\n NameMatch := 50\r\n else\r\n NameMatch := 0;\r\n\r\n if MV and 2 <> 0 then\r\n TypeMatch := 100\r\n else\r\n if MV and 1 <> 0 then\r\n TypeMatch := 50\r\n else\r\n TypeMatch := 0;\r\n\r\n Result := ((14 * TypeMatch) + (NameMatch) + (5 * ClassMatch)) div 20;\r\n end;\r\nend;\r\n\r\nprocedure RegisterDataTypeKinds;\r\nbegin\r\n if TJvCustomInspectorData.ItemRegister = nil then\r\n raise EJvInspectorReg.CreateRes(@RsEJvInspNoGenReg);\r\n with TJvCustomInspectorData.ItemRegister do\r\n begin\r\n {$IFDEF UNICODE}\r\n Add(TJvInspectorTypeKindRegItem.Create(TJvInspectorStringItem, tkUString));\r\n {$ENDIF UNICODE}\r\n Add(TJvInspectorTypeKindRegItem.Create(TJvInspectorStringItem, tkLString));\r\n Add(TJvInspectorTypeKindRegItem.Create(TJvInspectorStringItem, tkWString));\r\n Add(TJvInspectorTypeKindRegItem.Create(TJvInspectorStringItem, tkString));\r\n Add(TJvInspectorTypeKindRegItem.Create(TJvInspectorIntegerItem, tkInteger));\r\n Add(TJvInspectorTypeKindRegItem.Create(TJvInspectorEnumItem, tkEnumeration));\r\n Add(TJvInspectorTypeKindRegItem.Create(TJvInspectorFloatItem, tkFloat));\r\n Add(TJvInspectorTypeKindRegItem.Create(TJvInspectorSetItem, tkSet));\r\n Add(TJvInspectorTypeKindRegItem.Create(TJvInspectorCharItem, tkChar));\r\n Add(TJvInspectorTypeKindRegItem.Create(TJvInspectorCharItem, tkWChar));\r\n Add(TJvInspectorTypeKindRegItem.Create(TJvInspectorInt64Item, tkInt64));\r\n Add(TJvInspectorTypeKindRegItem.Create(TJvInspectorClassItem, tkClass));\r\n Add(TJvInspectorTypeKindRegItem.Create(TJvInspectorTMethodItem, tkMethod));\r\n Add(TJvInspectorTCaptionRegItem.Create(TJvInspectorStringItem, TypeInfo(TCaption)));\r\n Add(TJvInspectorTypeInfoRegItem.Create(TJvInspectorFontItem, TypeInfo(TFont)));\r\n Add(TJvInspectorTypeInfoRegItem.Create(TJvInspectorBooleanItem, TypeInfo(Boolean)));\r\n Add(TJvInspectorTypeInfoRegItem.Create(TJvInspectorBooleanItem, TypeInfo(ByteBool)));\r\n Add(TJvInspectorTypeInfoRegItem.Create(TJvInspectorBooleanItem, TypeInfo(WordBool)));\r\n Add(TJvInspectorTypeInfoRegItem.Create(TJvInspectorBooleanItem, TypeInfo(LongBool)));\r\n Add(TJvInspectorTypeInfoRegItem.Create(TJvInspectorTStringsItem, TypeInfo(TStrings)));\r\n Add(TJvInspectorTypeInfoRegItem.Create(TJvInspectorComponentItem, TypeInfo(TComponent)));\r\n Add(TJvInspectorTypeInfoRegItem.Create(TJvInspectorDateItem, TypeInfo(TDate)));\r\n Add(TJvInspectorTypeInfoRegItem.Create(TJvInspectorTimeItem, TypeInfo(TTime)));\r\n Add(TJvInspectorTypeInfoRegItem.Create(TJvInspectorDateTimeItem, TypeInfo(TDateTime)));\r\n Add(TJvInspectorTypeInfoRegItem.Create(TJvInspectorVariantItem, TypeInfo(Variant)));\r\n end;\r\nend;\r\n\r\nprocedure RegisterPropDataTypeKinds;\r\nbegin\r\n if TJvCustomInspectorData.ItemRegister = nil then\r\n raise EJvInspectorReg.CreateRes(@RsEJvInspNoGenReg);\r\n with TJvInspectorPropData.ItemRegister do\r\n Add(TJvInspectorPropRegItem.Create(TJvInspectorFontNameItem, TFont, 'Name', nil));\r\nend;\r\n\r\nconst\r\n SizingConsts: array [0..3] of TIdentMapEntry =\r\n ((Value: irsNoReSize; Name: 'irsNoReSize'),\r\n (Value: irsNameHeight; Name: 'irsNameHeight'),\r\n (Value: irsValueHeight; Name: 'irsValueHeight'),\r\n (Value: irsItemHeight; Name: 'irsItemHeight'));\r\n\r\nfunction IrsToInt(const Ident: string; var Int: Longint): Boolean;\r\nbegin\r\n Result := IdentToInt(Ident, Int, SizingConsts);\r\nend;\r\n\r\nfunction IntToIrs(Int: Longint; var Ident: string): Boolean;\r\nbegin\r\n Result := IntToIdent(Int, Ident, SizingConsts);\r\nend;\r\n\r\nprocedure RegisterConsts;\r\nbegin\r\n RegisterIntegerConsts(TypeInfo(TItemRowSizing), IrsToInt, IntToIrs);\r\nend;\r\n\r\ninitialization\r\n {$IFDEF UNITVERSIONING}\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n {$ENDIF UNITVERSIONING}\r\n RegisterConsts;\r\n\r\nfinalization\r\n FreeAndNil(GlobalTypeInfoHelpersList);\r\n FreeAndNil(GlobalCanvasStack);\r\n FreeAndNil(FieldGlobalInspReg);\r\n FreeAndNil(GlobalDataRegister);\r\n FreeAndNil(GlobalGenItemReg);\r\n FreeAndNil(GlobalVarItemReg);\r\n FreeAndNil(GlobalPropItemReg);\r\n FreeAndNil(GlobalPropMapReg);\r\n {$IFDEF UNITVERSIONING}\r\n UnregisterUnitVersion(HInstance);\r\n {$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvInstallLabel.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvInstallLabel.PAS, released on 2002-05-26.\r\n\r\nThe Initial Developer of the Original Code is Peter Thrnqvist [peter3 at sourceforge dot net]\r\nPortions created by Peter Thrnqvist are Copyright (C) 2002 Peter Thrnqvist.\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nDescription:\r\n A component that makes it dead easy to have those nifty installation screens\r\n with a list of tasks to perform and some formatting and icons to make sure the\r\n user don't get lost when the big software company is stuffing his PC with rubbish.\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvInstallLabel.pas 13104 2011-09-07 06:50:43Z obones $\r\n\r\nunit JvInstallLabel;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n SysUtils, Classes,\r\n Windows, Graphics, Controls, ImgList,\r\n JvJCLUtils, JvComponent;\r\n\r\ntype\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvInstallLabel = class(TJvGraphicControl)\r\n private\r\n FImageList: TCustomImageList;\r\n FImageChangeLink: TChangeLink;\r\n FLines: TStringList;\r\n FStyles: TList;\r\n FTextOffset: Integer;\r\n FImageOffset: Integer;\r\n FLineSpacing: Integer;\r\n FDefaultImage: Integer;\r\n procedure SetIndex(Value: Integer);\r\n procedure SetStyles(Index: Integer; Value: TFontStyles);\r\n function GetStyles(Index: Integer): TFontStyles;\r\n procedure SetImageList(Value: TCustomImageList);\r\n function GetLines: TStrings;\r\n procedure SetLines(Value: TStrings);\r\n procedure SetImageOffset(Value: Integer);\r\n procedure SetTextOffset(Value: Integer);\r\n procedure SetLineSpacing(Value: Integer);\r\n procedure Change(Sender: TObject);\r\n procedure UpdateStyles;\r\n function CheckBounds(Index: Integer): Boolean;\r\n protected\r\n procedure Paint; override;\r\n procedure Notification(AComponent: TComponent; Operation: TOperation); override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n procedure SetStyle(LineIndex, ImageIndex: Integer; LineStyle: TFontStyles);\r\n procedure SetExclusive(LineIndex, ImageIndex: Integer; LineStyle: TFontStyles);\r\n procedure SetImage(LineIndex, ImageIndex: Integer);\r\n property Styles[Index: Integer]: TFontStyles read GetStyles write SetStyles;\r\n published\r\n property Align;\r\n property Font;\r\n property Color default clBtnFace;\r\n property DefaultImage: Integer read FDefaultImage write SetIndex default -1;\r\n property Images: TCustomImageList read FImageList write SetImageList;\r\n property Lines: TStrings read GetLines write SetLines;\r\n property LineSpacing: Integer read FLineSpacing write SetLineSpacing default 10;\r\n property ShowHint;\r\n property ParentShowHint;\r\n property ParentFont;\r\n property TextOffset: Integer read FTextOffset write SetTextOffset default 24;\r\n property ImageOffset: Integer read FImageOffset write SetImageOffset default 2;\r\n property DragCursor;\r\n property DragMode;\r\n property PopupMenu;\r\n property OnClick;\r\n property OnDragDrop;\r\n property OnDragOver;\r\n property OnEndDrag;\r\n property OnMouseDown;\r\n property OnMouseMove;\r\n property OnMouseUp;\r\n property OnStartDrag;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvInstallLabel.pas $';\r\n Revision: '$Revision: 13104 $';\r\n Date: '$Date: 2011-09-07 08:50:43 +0200 (mer. 07 sept. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n JvTypes, JvThemes, JvJVCLUtils, JvResources;\r\n\r\ntype\r\n PStyles = ^TStyles;\r\n TStyles = record\r\n Style: TFontStyles;\r\n Index: Integer;\r\n end;\r\n\r\nconstructor TJvInstallLabel.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n IncludeThemeStyle(Self, [csParentBackground]);\r\n FLines := TStringList.Create;\r\n FLines.OnChange := Change;\r\n FStyles := TList.Create;\r\n FImageChangeLink := TChangeLink.Create;\r\n FImageChangeLink.OnChange := Change;\r\n FTextOffset := 24;\r\n FImageOffset := 2;\r\n FLineSpacing := 10;\r\n FDefaultImage := -1;\r\n SetBounds(0, 0, 180, 120);\r\nend;\r\n\r\ndestructor TJvInstallLabel.Destroy;\r\nvar\r\n I: Integer;\r\nbegin\r\n FLines.Free;\r\n FImageChangeLink.Free;\r\n for I := 0 to FStyles.Count - 1 do\r\n if FStyles[I] <> nil then\r\n Dispose(PStyles(FStyles[I]));\r\n FStyles.Free;\r\n inherited Destroy;\r\nend;\r\n\r\n{ make sure Lines.Count = Styles.Count }\r\n\r\nprocedure TJvInstallLabel.UpdateStyles;\r\nvar\r\n Style: PStyles;\r\nbegin\r\n while FStyles.Count > Lines.Count do\r\n begin\r\n if FStyles.Last <> nil then\r\n Dispose(PStyles(FStyles.Last));\r\n FStyles.Delete(FStyles.Count - 1);\r\n end;\r\n\r\n while FStyles.Count < Lines.Count do\r\n begin\r\n New(Style);\r\n Style^.Style := Font.Style; { default }\r\n Style^.Index := FDefaultImage;\r\n FStyles.Add(Style);\r\n end;\r\nend;\r\n\r\nprocedure TJvInstallLabel.SetIndex(Value: Integer);\r\nvar\r\n I: Integer;\r\nbegin\r\n if FDefaultImage <> Value then\r\n begin\r\n for I := 0 to FStyles.Count - 1 do\r\n if PStyles(FStyles[I])^.Index = FDefaultImage then\r\n PStyles(FStyles[I])^.Index := Value;\r\n FDefaultImage := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvInstallLabel.SetStyles(Index: Integer; Value: TFontStyles);\r\nbegin\r\n SetStyle(Index, FDefaultImage, Value);\r\nend;\r\n\r\nfunction TJvInstallLabel.GetStyles(Index: Integer): TFontStyles;\r\nbegin\r\n if not CheckBounds(Index) then\r\n raise EJVCLException.CreateResFmt(@RsEListOutOfBounds, [Index])\r\n else\r\n Result := PStyles(FStyles[Index])^.Style;\r\nend;\r\n\r\nprocedure TJvInstallLabel.SetImageList(Value: TCustomImageList);\r\nbegin\r\n ReplaceImageListReference(Self, Value, FImageList, FImageChangeLink);\r\nend;\r\n\r\nfunction TJvInstallLabel.GetLines: TStrings;\r\nbegin\r\n Result := FLines;\r\nend;\r\n\r\nprocedure TJvInstallLabel.SetLines(Value: TStrings);\r\nbegin\r\n FLines.Assign(Value);\r\n UpdateStyles;\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvInstallLabel.SetImageOffset(Value: Integer);\r\nbegin\r\n if FImageOffset <> Value then\r\n begin\r\n FImageOffset := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\n{ offset from left edge }\r\n\r\nprocedure TJvInstallLabel.SetTextOffset(Value: Integer);\r\nbegin\r\n if FTextOffset <> Value then\r\n begin\r\n FTextOffset := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\n{ space between lines }\r\n\r\nprocedure TJvInstallLabel.SetLineSpacing(Value: Integer);\r\nbegin\r\n if FLineSpacing <> Value then\r\n begin\r\n FLineSpacing := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvInstallLabel.Notification(AComponent: TComponent; Operation:\r\n TOperation);\r\nbegin\r\n inherited Notification(AComponent, Operation);\r\n if (AComponent = FImageList) and (Operation = opRemove) then\r\n FImageList := nil;\r\nend;\r\n\r\nprocedure TJvInstallLabel.Paint;\r\nvar\r\n Tmp, H, W, I: Integer;\r\n aRect: TRect;\r\nbegin\r\n if csDestroying in ComponentState then\r\n Exit;\r\n\r\n DrawThemedBackground(Self, Canvas, ClientRect, Self.Color);\r\n\r\n if csDesigning in ComponentState then\r\n with Canvas do\r\n begin\r\n Pen.Style := psDash;\r\n Brush.Style := bsClear;\r\n Rectangle(0, 0, Width, Height);\r\n end;\r\n\r\n UpdateStyles;\r\n Canvas.Font := Font;\r\n SetBkMode(Canvas.Handle, Windows.Transparent);\r\n H := CanvasMaxTextHeight(Canvas);\r\n for I := 0 to Lines.Count - 1 do\r\n begin\r\n Canvas.Font.Style := PStyles(FStyles[I])^.Style;\r\n W := Canvas.TextWidth(Lines[I]);\r\n Tmp := I * (H + FLineSpacing) + FLineSpacing;\r\n aRect := Rect(FTextOffset, Tmp, FTextOffset + W, Tmp + H);\r\n DrawText(Canvas, Lines[I], -1, aRect, DT_CENTER or DT_VCENTER or\r\n DT_SINGLELINE or DT_NOPREFIX or DT_NOCLIP);\r\n if Assigned(FImageList) then\r\n begin\r\n aRect.Top := aRect.Top + ((aRect.Bottom - aRect.Top) div 2);\r\n FImageList.Draw(Canvas, FImageOffset, aRect.Top - FImageList.Height div 2,\r\n PStyles(FStyles[I])^.Index);\r\n end;\r\n end;\r\nend;\r\n\r\n{ set the style of this line without affecting any others }\r\n\r\nprocedure TJvInstallLabel.SetStyle(LineIndex, ImageIndex: Integer; LineStyle:\r\n TFontStyles);\r\nbegin\r\n CheckBounds(LineIndex);\r\n UpdateStyles;\r\n PStyles(FStyles[LineIndex])^.Style := LineStyle;\r\n PStyles(FStyles[LineIndex])^.Index := ImageIndex;\r\n Invalidate;\r\nend;\r\n\r\n{ reset all lines to default style except this one }\r\n\r\nprocedure TJvInstallLabel.SetExclusive(LineIndex, ImageIndex: Integer;\r\n LineStyle: TFontStyles);\r\nvar\r\n I: Integer;\r\nbegin\r\n CheckBounds(LineIndex);\r\n UpdateStyles;\r\n for I := 0 to FStyles.Count - 1 do\r\n begin\r\n PStyles(FStyles[I])^.Style := Font.Style;\r\n PStyles(FStyles[I])^.Index := FDefaultImage;\r\n end;\r\n\r\n PStyles(FStyles[LineIndex])^.Style := LineStyle;\r\n PStyles(FStyles[LineIndex])^.Index := ImageIndex;\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvInstallLabel.SetImage(LineIndex, ImageIndex: Integer);\r\nbegin\r\n CheckBounds(LineIndex);\r\n UpdateStyles;\r\n PStyles(FStyles[LineIndex])^.Index := ImageIndex;\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvInstallLabel.Change(Sender: TObject);\r\nbegin\r\n Invalidate;\r\nend;\r\n\r\nfunction TJvInstallLabel.CheckBounds(Index: Integer): Boolean;\r\nbegin\r\n Result := (Index > -1) and (Index < Lines.Count);\r\n if not Result then\r\n raise EJVCLException.CreateResFmt(@RsEListOutOfBounds, [Index]);\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvInterpreter.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvInterpreter.PAS, released on 2002-07-04.\r\n\r\nThe Initial Developers of the Original Code are: Andrei Prygounkov \r\nCopyright (c) 1999, 2002 Andrei Prygounkov\r\nAll Rights Reserved.\r\n\r\nContributor(s): Dmitry Osinovsky, Peter Thornqvist, Olga Kobzar\r\n Peter Schraut (http://www.console-de.de)\r\n Ivan Ravin (ivan_ra)\r\n\r\nPortions created by Dmitry Osinovsky and Olga Kobzar are\r\nCopyright (C) 2003 ProgramBank Ltd.\r\nAll Rights Reserved.\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\ncomponent : JvInterpreterProgram and more..\r\ndescription : JVCL Interpreter version 2\r\n\r\nKnown Issues:\r\n String fields in records binded from Delphi don't work\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvInterpreter.pas 13415 2012-09-10 09:51:54Z obones $\r\n\r\n{ history (JVCL Library versions):\r\n 1.10:\r\n - first release;\r\n 1.12:\r\n - method HandleException removed as bugged;\r\n - method UpdateExceptionPos now fill error message\r\n with error Unit name and Line pos;\r\n - fixed bug in TJvInterpreterUnit.Assignment method;\r\n - new public property BaseErrLine used in UpdateExceptionPos;\r\n 1.17.7:\r\n - local \"const\" statement for functions;\r\n - global variables and constants - scope on all units - not normal !;\r\n - OnGetValue and OnSetValue now called before call to Adapter;\r\n - fixed bug with \"Break\" statement inside \"for\" loop;\r\n 1.17.10:\r\n - fixed(?) bug with \"begin/end\" statement in \"else\" part of \"if\" statement;\r\n - fixed few bugs in ole automation support;\r\n 1.21.2 (RALib 1.21 Update 2):\r\n - fixed bug with multiple external functions defintions\r\n (greetings to Peter Fischer-Haaser)\r\n - fixed AV-bug in TJvInterpreterFunction.InFunction if errors in source occured\r\n (greetings to Andre N Belokon)\r\n 1.21.4 (RALib 1.21 Update 4):\r\n - fixed bugs in \"if\" and \"while\" with \"begin\" statements;\r\n - \"div\" and \"mod\" now working;\r\n 1.21.6 (RALib 1.21 Update 6):\r\n - fixed bug with incorrect error line and unit name if erorr\r\n occured in used unit\r\n (greetings to Dmitry Mokrushin)\r\n - add parameters check (not fully functional - only count checked)\r\n in source fucntion calls;\r\n 1.31.2 (RALib 1.31 Update 2):\r\n - fixed bug: sometimes compare-operators ('=', '>', ...)\r\n in expressions do not working.\r\n 1.31.4 (RALib 1.31 Update 4):\r\n - fixed bug: plus and minus operators after symbol ']' not working.\r\n 1.31.5 (RALib 1.31 Update 5):\r\n - function Statement1 is changed; this remove many bugs and add new ones.\r\n - fixed many bug in exception handling statements and in nested\r\n \"begin/end\" statements;\r\n - fixed error with source function with TObject (and descendants)\r\n returning values;\r\n 1.41.1:\r\n - another fix for bug with incorrect error line and unit name\r\n if erorr occurred in used unit;\r\n - fixed bug with \"Break\" statement;\r\n - \"exit\" statement;\r\n - \"repeat\" loop;\r\n 1.50:\r\n - behavior of \"UseGlobalAdapter\" property was changed; in previous versions\r\n each TJvInterpreterExpression component creates its own copy of GlobalAdapter and\r\n then manage it own copy, but now TJvInterpreterExpression manages two adapters:\r\n own and global, so GlobalJvInterpreterAdapter now is used by all TJvInterpreterExpressions;\r\n performance of \"Compile\" function increased (there is no necessity\r\n more to Assign adapters) (20 msec on my machine with JvInterpreter_all unit)\r\n and memory requirement decreased;\r\n - sorting in TJvInterpreterAdapter dramatically increase its performance speed;\r\n - fixed bug in \"except/on\" statement;\r\n 1.51:\r\n - arrays as local and global variables. supports simple types (Integer,\r\n double, string, tdatetime, object).\r\n Added by Andrej Olejnik (olej att asset dott sk);\r\n - type conversion with Integer, string, TObject,... keywords;\r\n 1.51.2:\r\n - array support was rewritten;\r\n enhanced indexes support: default indexed properties,\r\n access to chars in strings. Many changes are made to make this possible:\r\n new methods: GetElement, SetElement;\r\n - record support is simplified;\r\n - new property TJvInterpreterExpression.Error provide extended error information\r\n about non-interpreter errors.\r\n - \"case\" statement; not fully implemented - only one expression for one block.\r\n 1.52:\r\n - TJvInterpreterExpression.JvInterpreterAdapter property renamed to Adapter;\r\n - new public property TJvInterpreterExpression.SharedAdapter, setting to\r\n GlobalJvInterpreterAdapter by default. This allows to create set of global adapters,\r\n shared between TJvInterpreterExpression components;\r\n - property TJvInterpreterExpression.GlobalAdapter removed; setting SharedAdapter\r\n to nil has same effect as GlobalAdapter := False;\r\n - fixed memory bug in event handling;\r\n - new: unit name in uses list can be placed in quotes and contains any symbols;\r\n - fixed bug: selector in case-statement not working with variables (only constants)\r\n 1.53:\r\n - fixed bug: \"Type mistmatch error\" in expressions with OleAutomation objects;\r\n - fixed bug: error while assign function's result to object's published property;\r\n - call to external functions (placed in dll) in previous versions always\r\n return Integer, now it can return Boolean, if declared so;\r\n 1.54:\r\n - new: in call to external function var-parameters are supported for\r\n Integer type;\r\n - new: after call to external function (placed in dll) last win32 error\r\n is restored correctly; in previous versions it was overriden by call to\r\n FreeLibrary;\r\n - fixed bug: memory leak: global variables and constants not allways be freed;\r\n 1.60:\r\n - bug fixed in case-statement;\r\n - new: global variables and constants in different units now can have\r\n identical names;\r\n - new: constants, variables and functions can have prefix with unit name\r\n and point to determine appropriate unit;\r\n - new: class declaration for forms (needed for TJvInterpreterFm component);\r\n - bug fixed: record variables do not work;\r\n 1.61:\r\n - bug fixed: variable types are not always kept the same when\r\n assigning values to them;\r\n thanks to Ritchie Annand (RitchieA att malibugroup dott com);\r\n - bug fixed: exceptions, raised in dll calls produce AV.\r\n fix: exception of class Exception is raised.\r\n - new internal: LocalVars property in TJvInterpreterFunction (it is used in TJvInterpreterFm).\r\n 2.00:\r\n - Delphi 6 compatibility;\r\n - Kylix 1 compatibility;\r\n - exception handling was rewriten in more portable way,\r\n ChangeTopException function is not used anymore;\r\n - fixed bug: intefrace section was not processed correct\r\n (Thanks to Ivan Ravin);\r\nUpcoming JVCL 3.00\r\n - major code cleanups\r\n - introduced data type system for variables and record fields initializations\r\n - interface (IInterface, IUnknown) method call support, see AddIntfGet\r\n - record declaration support\r\n - arrays of records, arrays of arrays\r\n - dynamic arrays\r\n - variant array support\r\n - arrays as parameters to Delphi procedures (sorry, no support for arrays\r\n as procedure parameters)\r\n - fixed record bugs with Delphi 6\r\n - fixed OLE bugs\r\n - (rom) added fix for default properties from ivan_ra 26 Dec 2003\r\n\r\n - (wap) fixed bug: memory leak in local-function LeaveFunction, part of\r\n TJvInterpreterFunction.InFunction. See code marker VARLEAKFIX.\r\n (Fix suggested by ivan_ra att mail dott ru)\r\n\r\n - bug fixed: exceptions, raised in Assign nil to Method property - dejoy-2004-3-13\r\n - fixed Character '\"' error in SkipToEnd from dejoy 2004-5-25;\r\n\r\n - peter schraut added shl, shr and xor support\r\n}\r\n\r\nunit JvInterpreter;\r\n\r\n{$I jvcl.inc}\r\n\r\n{.$DEFINE JvInterpreter_DEBUG}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n SysUtils, Classes,\r\n {$IFDEF MSWINDOWS}\r\n Windows,\r\n {$ENDIF MSWINDOWS}\r\n Variants,\r\n JvInterpreterParser, JvComponentBase;\r\n\r\nconst\r\n // (rom) renamed to longer names\r\n { max arguments to functions - small values increase performance }\r\n cJvInterpreterMaxArgs = 32;\r\n\r\n { max fields allowed in records }\r\n cJvInterpreterMaxRecFields = 32;\r\n\r\n // (rom) added\r\n cJvInterpreterStackMax = 199;\r\n\r\n { Max available dimensions for arrays }\r\n JvInterpreter_MAX_ARRAY_DIMENSION = 10;\r\n\r\ntype\r\n\r\n {$IFNDEF COMPILER12_UP}\r\n NativeInt = Integer; // also redeclare for Delphi 2007 where it is declared as Int64\r\n {$ENDIF ~COMPILER12_UP}\r\n\r\n { argument definition }\r\n PValueArray = ^TValueArray;\r\n TValueArray = array [0..cJvInterpreterMaxArgs] of Variant;\r\n PTypeArray = ^TTypeArray;\r\n TTypeArray = array [0..cJvInterpreterMaxArgs] of Word;\r\n PNameArray = ^TNameArray;\r\n TNameArray = array [0..cJvInterpreterMaxArgs] of string;\r\n\r\n TJvInterpreterArgs = class;\r\n IJvInterpreterDataType = interface;\r\n\r\n TJvInterpreterGetValue = procedure(Sender: TObject; Identifier: string; var Value: Variant;\r\n Args: TJvInterpreterArgs; var Done: Boolean) of object;\r\n TJvInterpreterSetValue = procedure(Sender: TObject; Identifier: string;\r\n const Value: Variant; Args: TJvInterpreterArgs; var Done: Boolean) of object;\r\n TJvInterpreterGetUnitSource = procedure(UnitName: string; var Source: string;\r\n var Done: Boolean) of object;\r\n\r\n TJvInterpreterAdapterGetValue = procedure(var Value: Variant; Args: TJvInterpreterArgs);\r\n TJvInterpreterAdapterSetValue = procedure(const Value: Variant; Args: TJvInterpreterArgs);\r\n TJvInterpreterAdapterNewRecord = procedure(var Value: Pointer);\r\n TJvInterpreterAdapterDisposeRecord = procedure(const Value: Pointer);\r\n TJvInterpreterAdapterCopyRecord = procedure(var Dest: Pointer; const Source: Pointer);\r\n\r\n POpenArray = ^TOpenArray;\r\n TOpenArray = array [0..cJvInterpreterMaxArgs] of TVarRec;\r\n\r\n TJvInterpreterRecField = record\r\n Identifier: string;\r\n Offset: Integer;\r\n Typ: Word;\r\n DataType: IJvInterpreterDataType;\r\n end;\r\n\r\n TJvInterpreterArgs = class(TObject)\r\n private\r\n FVarNames: TNameArray;\r\n FHasVars: Boolean;\r\n { open array parameter support }\r\n { allocates memory only if necessary }\r\n FOAV: PValueArray; { open array values }\r\n public\r\n Identifier: string;\r\n Count: Integer;\r\n Types: TTypeArray;\r\n Values: TValueArray;\r\n Names: TNameArray;\r\n HasResult: Boolean; { = False, if result not needed - used by calls\r\n to OLE automation servers }\r\n Assignment: Boolean; { internal }\r\n Obj: TObject;\r\n ObjTyp: Word; { varObject, varClass, varUnknown }\r\n ObjRefHolder: Variant; { if ObjType is varDispatch or varUnknown,\r\n then we need to hold a reference to it }\r\n\r\n Indexed: Boolean; // if True then Args contain Indexes to Identifier\r\n ReturnIndexed: Boolean; // established by GetValue function, indicating\r\n // what Args used as indexed (matters only if Indexed = True)\r\n public\r\n { open array parameter support }\r\n OA: POpenArray; { open array }\r\n OAS: Integer; { open array size }\r\n destructor Destroy; override;\r\n procedure Clear;\r\n procedure OpenArray(const Index: Integer);\r\n procedure Delete(const Index: Integer);\r\n end;\r\n\r\n { function descriptor }\r\n TJvInterpreterFunctionDesc = class(TObject)\r\n private\r\n FUnitName: string;\r\n FIdentifier: string;\r\n FClassIdentifier: string; { class name, if function declared as\r\n TClassIdentifier.Identifier}\r\n FParamCount: Integer; { - 1..cJvInterpreterMaxArgs }\r\n FParamTypes: TTypeArray;\r\n FParamTypeNames: TNameArray;\r\n FParamNames: TNameArray;\r\n FResTyp: Word;\r\n FResTypName: string;\r\n FResDataType: IJvInterpreterDataType;\r\n FPosBeg: Integer; { position in source }\r\n FPosEnd: Integer;\r\n function GetParamName(Index: Integer): string;\r\n function GetParamType(Index: Integer): Word;\r\n function GetParamTypeNames(Index: Integer): string;\r\n function GetDefine: string;\r\n public\r\n {$WARNINGS OFF} // Delphi 2009+ has a class function UnitName\r\n property UnitName: string read FUnitName;\r\n {$WARNINGS ON}\r\n property Identifier: string read FIdentifier;\r\n property ClassIdentifier: string read FClassIdentifier;\r\n property Define: string read GetDefine;\r\n property ParamCount: Integer read FParamCount;\r\n property ParamTypes[Index: Integer]: Word read GetParamType;\r\n property ParamNames[Index: Integer]: string read GetParamName;\r\n property ParamTypeNames[Index: Integer]: string read GetParamTypeNames;\r\n property ResTyp: Word read FResTyp;\r\n property ResTypName: string read FResTypName;\r\n property ResDataType: IJvInterpreterDataType read FResDataType;\r\n property PosBeg: Integer read FPosBeg;\r\n property PosEnd: Integer read FPosEnd;\r\n end;\r\n\r\n TSimpleEvent = procedure of object;\r\n TJvInterpreterExpression = class;\r\n EJvInterpreterError = class;\r\n\r\n TJvInterpreterEvent = class(TObject)\r\n private\r\n FOwner: TJvInterpreterExpression;\r\n FInstance: TObject;\r\n FUnitName: string;\r\n FFunctionName: string;\r\n FPropName: string;\r\n FArgs: TJvInterpreterArgs;\r\n function GetArgs: TJvInterpreterArgs;\r\n protected\r\n constructor Create(AOwner: TJvInterpreterExpression; AInstance: TObject;\r\n const AUnitName, AFunctionName, APropName: string); virtual;\r\n function CallFunction(Args: TJvInterpreterArgs; Params: array of Variant): Variant;\r\n property Args: TJvInterpreterArgs read GetArgs;\r\n property Owner: TJvInterpreterExpression read FOwner;\r\n property Instance: TObject read FInstance;\r\n {$WARNINGS OFF} // Delphi 2009+ has a class function UnitName\r\n property UnitName: string read FUnitName;\r\n {$WARNINGS ON}\r\n property FunctionName: string read FFunctionName;\r\n property PropName: string read FPropName;\r\n public\r\n destructor Destroy; override;\r\n end;\r\n\r\n TJvInterpreterEventClass = class of TJvInterpreterEvent;\r\n\r\n { variable holder }\r\n TJvInterpreterVar = class(TObject)\r\n public\r\n UnitName: string;\r\n Identifier: string;\r\n Typ: string;\r\n VTyp: Word;\r\n Value: Variant;\r\n public\r\n destructor Destroy; override;\r\n end;\r\n\r\n { variables list }\r\n TJvInterpreterVarList = class(TList)\r\n public\r\n destructor Destroy; override;\r\n procedure Clear; override;\r\n procedure AddVar(const UnitName, Identifier, Typ: string; VTyp: Word;\r\n const Value: Variant; DataType: IJvInterpreterDataType);\r\n function FindVar(const UnitName, Identifier: string): TJvInterpreterVar;\r\n procedure DeleteVar(const UnitName, Identifier: string);\r\n function GetValue(const Identifier: string; var Value: Variant; Args: TJvInterpreterArgs): Boolean;\r\n function SetValue(const Identifier: string; const Value: Variant; Args: TJvInterpreterArgs): Boolean;\r\n procedure Assign(source: TJvInterpreterVarList);\r\n end;\r\n { notes about TJvInterpreterVarList implementation:\r\n - list must allow to contain more than one Var with same name;\r\n - FindVar must return last added Var with given name;\r\n - DeleteVar must delete last added Var with given name; }\r\n\r\n TJvInterpreterIdentifier = class(TObject)\r\n public\r\n UnitName: string;\r\n Identifier: string;\r\n Data: Pointer; // provided by user when call to adapter's addxxx methods\r\n end;\r\n\r\n TJvInterpreterIdentifierList = class(TList)\r\n private\r\n FDuplicates: TDuplicates;\r\n public\r\n function IndexOf(const UnitName, Identifier: string): TJvInterpreterIdentifier;\r\n function Find(const Identifier: string; var Index: Integer): Boolean;\r\n procedure Sort(Compare: TListSortCompare = nil); virtual;\r\n property Duplicates: TDuplicates read FDuplicates write FDuplicates;\r\n end;\r\n\r\n TJvInterpreterMethodList = class(TJvInterpreterIdentifierList)\r\n public\r\n procedure Sort(Compare: TListSortCompare = nil); override;\r\n end;\r\n\r\n IJvInterpreterDataType = interface\r\n ['{8C5E4071-65AB-11D7-B235-00A0D2043DC7}']\r\n procedure Init(var V: Variant);\r\n function GetTyp: Word;\r\n end;\r\n\r\n //move from implementation section to interface section\r\n TParamCount = -1..cJvInterpreterMaxArgs;\r\n\r\n TCallConvention = set of (ccFastCall, ccStdCall, ccCDecl, ccDynamic,\r\n ccVirtual, ccClass);\r\n\r\n { Adapter classes - translates data from JvInterpreter calls to Delphi functions }\r\n TJvInterpreterSrcUnit = class(TJvInterpreterIdentifier)\r\n private\r\n FSource: string;\r\n FUsesList: TNameArray;\r\n public\r\n function UsesList: TNameArray;\r\n property Source: string read FSource;\r\n // Removed because BCB doesn't support it\r\n //property UsesList: TNameArray read FUsesList;\r\n end;\r\n\r\n TJvInterpreterMethod = class(TJvInterpreterIdentifier)\r\n protected\r\n FClassType: TClass;\r\n ParamCount: TParamCount;\r\n ParamTypes: TTypeArray; { varInteger, varString, .. }\r\n ResTyp: Word; { varInteger, varString, .. }\r\n Func: Pointer; { TJvInterpreterAdapterGetValue or TJvInterpreterAdapterSetValue }\r\n end;\r\n\r\n TJvInterpreterIntfMethod = class(TJvInterpreterIdentifier)\r\n protected\r\n IID: TGUID;\r\n ParamCount: TParamCount;\r\n ParamTypes: TTypeArray; { varInteger, varString, .. }\r\n ResTyp: Word; { varInteger, varString, .. }\r\n Func: Pointer; { TJvInterpreterAdapterGetValue or TJvInterpreterAdapterSetValue }\r\n end;\r\n\r\n TJvInterpreterDMethod = class(TJvInterpreterMethod)\r\n protected\r\n ResTyp: Word;\r\n CallConvention: TCallConvention;\r\n end;\r\n\r\n TJvInterpreterClass = class(TJvInterpreterIdentifier)\r\n private\r\n FClassFields:TJvInterpreterVarList;\r\n protected\r\n FClassType: TClass;\r\n public\r\n property ClassFields:TJvInterpreterVarList read FClassFields;\r\n constructor Create;\r\n destructor Destroy; override;\r\n end;\r\n\r\n TJvInterpreterConst = class(TJvInterpreterIdentifier)\r\n protected\r\n Value: Variant;\r\n end;\r\n\r\n TJvInterpreterRecFields = array [0..cJvInterpreterMaxRecFields] of TJvInterpreterRecField;\r\n\r\n TJvInterpreterRecord = class(TJvInterpreterIdentifier)\r\n protected\r\n RecordSize: Integer; { SizeOf(Rec^) }\r\n FieldCount: Integer;\r\n Fields: TJvInterpreterRecFields;\r\n CreateFunc: TJvInterpreterAdapterNewRecord;\r\n DestroyFunc: TJvInterpreterAdapterDisposeRecord;\r\n CopyFunc: TJvInterpreterAdapterCopyRecord;\r\n procedure AddField(const UnitName, Identifier, Typ: string; VTyp: Word;\r\n const Value: Variant; DataType: IJvInterpreterDataType);\r\n procedure NewRecord(var Value: Variant);\r\n end;\r\n\r\n TJvInterpreterRecMethod = class(TJvInterpreterIdentifier)\r\n protected\r\n JvInterpreterRecord: TJvInterpreterRecord;\r\n ParamCount: TParamCount;\r\n ParamTypes: TTypeArray; { varInteger, varString and so one .. }\r\n ResTyp: Word; { varInteger, varString, .. }\r\n Func: Pointer; { TJvInterpreterAdapterGetValue or TJvInterpreterAdapterSetValue }\r\n end;\r\n\r\n TJvInterpreterRecHolder = class(TJvInterpreterIdentifier)\r\n protected\r\n FRecordType: string;\r\n JvInterpreterRecord: TJvInterpreterRecord;\r\n Rec: Pointer; { data }\r\n public\r\n constructor Create(const ARecordType: string; ARec: Pointer);\r\n destructor Destroy; override;\r\n property RecordType: string read FRecordType;\r\n end;\r\n\r\n TJvInterpreterArrayValues = array [0..JvInterpreter_MAX_ARRAY_DIMENSION - 1] of Integer;\r\n\r\n PJvInterpreterArrayRec = ^TJvInterpreterArrayRec;\r\n TJvInterpreterArrayRec = packed record\r\n Dimension: Integer; {number of dimensions}\r\n BeginPos: TJvInterpreterArrayValues; {starting range for all dimensions}\r\n EndPos: TJvInterpreterArrayValues; {ending range for all dimensions}\r\n ItemType: Integer; {array type}\r\n DT: IJvInterpreterDataType;\r\n ElementSize: Integer; {size of element in bytes}\r\n Size: Integer; {number of elements in array}\r\n Memory: Pointer; {pointer to memory representation of array}\r\n end;\r\n\r\n { interpreter function }\r\n TJvInterpreterSrcFunction = class(TJvInterpreterIdentifier)\r\n private\r\n FFunctionDesc: TJvInterpreterFunctionDesc;\r\n public\r\n constructor Create;\r\n destructor Destroy; override;\r\n property FunctionDesc: TJvInterpreterFunctionDesc read FFunctionDesc; //Move From Private section\r\n end;\r\n\r\n { external function }\r\n TJvInterpreterExtFunction = class(TJvInterpreterSrcFunction)\r\n protected\r\n DllInstance: HINST;\r\n DllName: string;\r\n FunctionName: string;\r\n {or}\r\n FunctionIndex: Integer;\r\n function CallDll(Args: TJvInterpreterArgs): Variant;\r\n end;\r\n\r\n TJvInterpreterEventDesc = class(TJvInterpreterIdentifier)\r\n protected\r\n EventClass: TJvInterpreterEventClass;\r\n Code: Pointer;\r\n end;\r\n\r\n TJvInterpreterRecordDataType = class(TInterfacedObject, IJvInterpreterDataType)\r\n protected\r\n FRecordDesc: TJvInterpreterRecord;\r\n public\r\n constructor Create(ARecordDesc: TJvInterpreterRecord);\r\n procedure Init(var V: Variant);\r\n function GetTyp: Word;\r\n end;\r\n\r\n TJvInterpreterArrayDataType = class(TInterfacedObject, IJvInterpreterDataType)\r\n protected\r\n FArrayBegin, FArrayEnd: TJvInterpreterArrayValues;\r\n FDimension: Integer;\r\n FArrayType: Integer;\r\n FDT: IJvInterpreterDataType;\r\n public\r\n constructor Create(AArrayBegin, AArrayEnd: TJvInterpreterArrayValues;\r\n ADimension: Integer; AArrayType: Integer; ADT: IJvInterpreterDataType);\r\n procedure Init(var V: Variant);\r\n function GetTyp: Word;\r\n end;\r\n\r\n TJvInterpreterSimpleDataType = class(TInterfacedObject, IJvInterpreterDataType)\r\n protected\r\n FTyp: TVarType;\r\n public\r\n constructor Create(ATyp: TVarType);\r\n procedure Init(var V: Variant);\r\n function GetTyp: Word;\r\n end;\r\n\r\n PMethod = ^TMethod;\r\n\r\n { function context - stack }\r\n PFunctionContext = ^TFunctionContext;\r\n TFunctionContext = record\r\n PrevFunContext: PFunctionContext;\r\n LocalVars: TJvInterpreterVarList;\r\n Fun: TJvInterpreterSrcFunction;\r\n end;\r\n\r\n { TJvInterpreterAdapter - route JvInterpreter calls to Delphi functions }\r\n TJvInterpreterAdapter = class(TObject)\r\n private\r\n FOwner: TJvInterpreterExpression;\r\n FSrcUnitList: TJvInterpreterIdentifierList; // JvInterpreter-units sources\r\n FExtUnitList: TJvInterpreterIdentifierList; // internal units; like \"system\" in delphi\r\n FGetList: TJvInterpreterIdentifierList; // methods\r\n FSetList: TJvInterpreterIdentifierList; // write properties\r\n FIGetList: TJvInterpreterIdentifierList; // read indexed properties\r\n FISetList: TJvInterpreterIdentifierList; // write indexed properties\r\n FIDGetList: TJvInterpreterIdentifierList; // read default indexed properties\r\n FIDSetList: TJvInterpreterIdentifierList; // write default indexed properties\r\n FIntfGetList: TJvInterpreterIdentifierList; // interface methods\r\n FDirectGetList: TJvInterpreterIdentifierList; // direct get list\r\n FClassList: TJvInterpreterIdentifierList; // delphi classes\r\n FConstList: TJvInterpreterIdentifierList; // delphi consts\r\n FFunctionList: TJvInterpreterIdentifierList; // functions, procedures\r\n FRecordList: TJvInterpreterIdentifierList; // records\r\n FRecordGetList: TJvInterpreterIdentifierList; // read record field\r\n FRecordSetList: TJvInterpreterIdentifierList; // write record field\r\n FOnGetList: TJvInterpreterIdentifierList; // chain\r\n FOnSetList: TJvInterpreterIdentifierList; // chain\r\n FSrcFunctionList: TJvInterpreterIdentifierList; // functions, procedures in JvInterpreter-source\r\n FExtFunctionList: TJvInterpreterIdentifierList;\r\n FEventHandlerList: TJvInterpreterIdentifierList;\r\n FEventList: TJvInterpreterIdentifierList;\r\n FSrcVarList: TJvInterpreterVarList; // variables, constants in JvInterpreter-source\r\n FSrcClassList: TJvInterpreterIdentifierList; // JvInterpreter-source classes\r\n FDisableExternalFunctions: Boolean;\r\n FSorted: Boolean;\r\n procedure CheckArgs(var Args: TJvInterpreterArgs; ParamCount: Integer;\r\n var ParamTypes: TTypeArray);\r\n function GetRec(const RecordType: string): TObject;\r\n {$IFDEF JvInterpreter_OLEAUTO}\r\n function DispatchCall(const Identifier: string; var Value: Variant;\r\n Args: TJvInterpreterArgs; Get: Boolean): Boolean; stdcall;\r\n {$ENDIF JvInterpreter_OLEAUTO}\r\n function GetValueRTTI(const Identifier: string; var Value: Variant;\r\n Args: TJvInterpreterArgs): Boolean;\r\n function SetValueRTTI(const Identifier: string; const Value: Variant;\r\n Args: TJvInterpreterArgs): Boolean;\r\n protected\r\n procedure CheckAction(Expression: TJvInterpreterExpression; Args: TJvInterpreterArgs;\r\n Data: Pointer); virtual;\r\n function GetValue(Expression: TJvInterpreterExpression; const Identifier: string;\r\n var Value: Variant; Args: TJvInterpreterArgs): Boolean; virtual;\r\n function SetValue(Expression: TJvInterpreterExpression; const Identifier: string;\r\n const Value: Variant; Args: TJvInterpreterArgs): Boolean; virtual;\r\n function GetElement(Expression: TJvInterpreterExpression; const Variable: Variant;\r\n var Value: Variant; var Args: TJvInterpreterArgs): Boolean; virtual;\r\n function SetElement(Expression: TJvInterpreterExpression; var Variable: Variant;\r\n const Value: Variant; var Args: TJvInterpreterArgs): Boolean; virtual;\r\n function NewRecord(const RecordType: string; var Value: Variant): Boolean; virtual;\r\n function FindFunDesc(const UnitName, Identifier: string;\r\n const ClassIdentifier:string=''): TJvInterpreterFunctionDesc; virtual;\r\n procedure CurUnitChanged(const NewUnitName: string; var Source: string); virtual;\r\n function UnitExists(const Identifier: string): Boolean; virtual;\r\n function IsEvent(Obj: TObject; const Identifier: string): Boolean; virtual;\r\n function NewEvent(const UnitName, FunctionName, EventType: string;\r\n AOwner: TJvInterpreterExpression; AObject: TObject;\r\n const APropName: string): TSimpleEvent; virtual;\r\n procedure ClearSource; dynamic;\r\n procedure ClearNonSource; dynamic;\r\n procedure Sort; dynamic;\r\n protected\r\n { for internal use }\r\n procedure AddSrcClass(JvInterpreterSrcClass: TJvInterpreterIdentifier); virtual;\r\n function GetSrcClass(const Identifier: string): TJvInterpreterIdentifier; virtual;\r\n public\r\n constructor Create(AOwner: TJvInterpreterExpression);\r\n destructor Destroy; override;\r\n function SetRecord(var Value: Variant): Boolean; virtual;\r\n procedure Clear; dynamic;\r\n procedure Assign(Source: TJvInterpreterAdapter); dynamic;\r\n procedure AddSrcUnit(const Identifier, Source, UsesList: string); dynamic;\r\n procedure AddSrcUnitEx(const Identifier, Source, UsesList: string;\r\n Data: Pointer); dynamic;\r\n procedure AddExtUnit(const Identifier: string); dynamic;\r\n procedure AddExtUnitEx(const Identifier: string; Data: Pointer); dynamic;\r\n procedure AddClass(const UnitName: string; AClassType: TClass; const Identifier: string); dynamic;\r\n procedure AddClassEx(const UnitName: string; AClassType: TClass; const Identifier: string;\r\n Data: Pointer); dynamic;\r\n procedure AddIntfGet(IID: TGUID; const Identifier: string;\r\n GetFunc: TJvInterpreterAdapterGetValue; ParamCount: Integer;\r\n ParamTypes: array of Word; ResTyp: Word);\r\n procedure AddIntfGetEx(IID: TGUID; const Identifier: string;\r\n GetFunc: TJvInterpreterAdapterGetValue; ParamCount: Integer;\r\n ParamTypes: array of Word; ResTyp: Word; Data: Pointer);\r\n procedure AddGet(AClassType: TClass; const Identifier: string;\r\n GetFunc: TJvInterpreterAdapterGetValue; ParamCount: Integer;\r\n ParamTypes: array of Word; ResTyp: Word); dynamic;\r\n procedure AddGetEx(AClassType: TClass; const Identifier: string;\r\n GetFunc: TJvInterpreterAdapterGetValue; ParamCount: Integer;\r\n ParamTypes: array of Word; ResTyp: Word; Data: Pointer); dynamic;\r\n procedure AddSet(AClassType: TClass; const Identifier: string;\r\n SetFunc: TJvInterpreterAdapterSetValue; ParamCount: Integer;\r\n ParamTypes: array of Word); dynamic;\r\n procedure AddSetEx(AClassType: TClass; const Identifier: string;\r\n SetFunc: TJvInterpreterAdapterSetValue; ParamCount: Integer;\r\n ParamTypes: array of Word; Data: Pointer); dynamic;\r\n procedure AddIGet(AClassType: TClass; const Identifier: string;\r\n GetFunc: TJvInterpreterAdapterGetValue; ParamCount: Integer;\r\n ParamTypes: array of Word; ResTyp: Word); dynamic;\r\n procedure AddIGetEx(AClassType: TClass; const Identifier: string;\r\n GetFunc: TJvInterpreterAdapterGetValue; ParamCount: Integer;\r\n ParamTypes: array of Word; ResTyp: Word; Data: Pointer); dynamic;\r\n procedure AddISet(AClassType: TClass; const Identifier: string;\r\n SetFunc: TJvInterpreterAdapterSetValue; ParamCount: Integer;\r\n ParamTypes: array of Word); dynamic;\r\n procedure AddISetEx(AClassType: TClass; const Identifier: string;\r\n SetFunc: TJvInterpreterAdapterSetValue; ParamCount: Integer;\r\n ParamTypes: array of Word; Data: Pointer); dynamic;\r\n procedure AddIDGet(AClassType: TClass;\r\n GetFunc: TJvInterpreterAdapterGetValue; ParamCount: Integer;\r\n ParamTypes: array of Word; ResTyp: Word); dynamic;\r\n procedure AddIDGetEx(AClassType: TClass;\r\n GetFunc: TJvInterpreterAdapterGetValue; ParamCount: Integer;\r\n ParamTypes: array of Word; ResTyp: Word; Data: Pointer); dynamic;\r\n procedure AddIDSet(AClassType: TClass;\r\n SetFunc: TJvInterpreterAdapterSetValue; ParamCount: Integer;\r\n ParamTypes: array of Word); dynamic;\r\n procedure AddIDSetEx(AClassType: TClass;\r\n SetFunc: TJvInterpreterAdapterSetValue; ParamCount: Integer;\r\n ParamTypes: array of Word; Data: Pointer); dynamic;\r\n procedure AddFunction(const UnitName, Identifier: string;\r\n GetFunc: TJvInterpreterAdapterGetValue; ParamCount: Integer;\r\n ParamTypes: array of Word; ResTyp: Word); dynamic;\r\n procedure AddFunctionEx(const UnitName, Identifier: string;\r\n GetFunc: TJvInterpreterAdapterGetValue; ParamCount: Integer;\r\n ParamTypes: array of Word; ResTyp: Word; Data: Pointer); dynamic;\r\n { function AddDGet under construction - don't use it }\r\n procedure AddDGet(AClassType: TClass; const Identifier: string;\r\n GetFunc: Pointer; ParamCount: Integer; ParamTypes: array of Word;\r\n ResTyp: Word; CallConvention: TCallConvention); dynamic;\r\n procedure AddDGetEx(AClassType: TClass; const Identifier: string;\r\n GetFunc: Pointer; ParamCount: Integer; ParamTypes: array of Word;\r\n ResTyp: Word; CallConvention: TCallConvention; Data: Pointer); dynamic;\r\n procedure AddRec(const UnitName, Identifier: string; RecordSize: Integer;\r\n Fields: array of TJvInterpreterRecField; CreateFunc: TJvInterpreterAdapterNewRecord;\r\n DestroyFunc: TJvInterpreterAdapterDisposeRecord;\r\n CopyFunc: TJvInterpreterAdapterCopyRecord); dynamic;\r\n procedure AddRecEx(const UnitName, Identifier: string; RecordSize: Integer;\r\n Fields: array of TJvInterpreterRecField; CreateFunc: TJvInterpreterAdapterNewRecord;\r\n DestroyFunc: TJvInterpreterAdapterDisposeRecord; CopyFunc: TJvInterpreterAdapterCopyRecord;\r\n Data: Pointer); dynamic;\r\n procedure AddRecGet(const UnitName, RecordType, Identifier: string;\r\n GetFunc: TJvInterpreterAdapterGetValue; ParamCount: Integer;\r\n ParamTypes: array of Word; ResTyp: Word); dynamic;\r\n procedure AddRecGetEx(const UnitName, RecordType, Identifier: string;\r\n GetFunc: TJvInterpreterAdapterGetValue; ParamCount: Integer;\r\n ParamTypes: array of Word; ResTyp: Word; Data: Pointer); dynamic;\r\n procedure AddRecSet(const UnitName, RecordType, Identifier: string;\r\n SetFunc: TJvInterpreterAdapterSetValue; ParamCount: Integer;\r\n ParamTypes: array of Word); dynamic;\r\n procedure AddRecSetEx(const UnitName, RecordType, Identifier: string;\r\n SetFunc: TJvInterpreterAdapterSetValue; ParamCount: Integer;\r\n ParamTypes: array of Word; Data: Pointer); dynamic;\r\n procedure AddConst(const UnitName, Identifier: string; Value: Variant); dynamic;\r\n procedure AddConstEx(const AUnitName, AIdentifier: string; AValue: Variant;\r\n AData: Pointer); dynamic;\r\n procedure AddExtFun(const UnitName, Identifier: string; DllInstance: HINST;\r\n const DllName, FunctionName: string; FunctionIndex: Integer; ParamCount: Integer;\r\n ParamTypes: array of Word; ResTyp: Word); dynamic;\r\n procedure AddExtFunEx(const AUnitName, AIdentifier: string; ADllInstance: HINST;\r\n const ADllName, AFunctionName: string; AFunIndex: Integer; AParamCount: Integer;\r\n AParamTypes: array of Word; AResTyp: Word; AData: Pointer); dynamic;\r\n procedure AddSrcFun(const UnitName, Identifier: string;\r\n ClassIdentifier: string;\r\n PosBeg, PosEnd: Integer; ParamCount: Integer; ParamTypes: array of Word;\r\n ParamTypeNames: array of string;\r\n ParamNames: array of string; ResTyp: Word; const AResTypName: string;\r\n AResDataType: IJvInterpreterDataType; Data: Pointer); dynamic;\r\n procedure AddSrcFunEx(const AUnitName, AIdentifier: string;\r\n AClassIdentifier: string;\r\n APosBeg, APosEnd: Integer; AParamCount: Integer; AParamTypes: array of Word;\r\n AParamTypeNames: array of string;\r\n AParamNames: array of string; AResTyp: Word; const AResTypName: string;\r\n AResDataType: IJvInterpreterDataType; AData: Pointer); dynamic;\r\n procedure AddHandler(const UnitName, Identifier: string;\r\n EventClass: TJvInterpreterEventClass; Code: Pointer); dynamic;\r\n procedure AddHandlerEx(const AUnitName, AIdentifier: string;\r\n AEventClass: TJvInterpreterEventClass; ACode: Pointer; AData: Pointer); dynamic;\r\n procedure AddEvent(const UnitName: string; AClassType: TClass;\r\n const Identifier: string); dynamic;\r\n procedure AddEventEx(const AUnitName: string; AClassType: TClass;\r\n const AIdentifier: string; AData: Pointer); dynamic;\r\n procedure AddSrcVar(const UnitName, Identifier, Typ: string; VTyp: Word;\r\n const Value: Variant; DataType: IJvInterpreterDataType); dynamic;\r\n procedure AddOnGet(Method: TJvInterpreterGetValue); dynamic;\r\n procedure AddOnSet(Method: TJvInterpreterSetValue); dynamic;\r\n public\r\n property DisableExternalFunctions: Boolean read FDisableExternalFunctions write FDisableExternalFunctions;\r\n property SrcUnitList: TJvInterpreterIdentifierList read FSrcUnitList;\r\n property ExtUnitList: TJvInterpreterIdentifierList read FExtUnitList;\r\n property GetList: TJvInterpreterIdentifierList read FGetList;\r\n property SetList: TJvInterpreterIdentifierList read FSetList;\r\n property IGetList: TJvInterpreterIdentifierList read FIGetList;\r\n property ISetList: TJvInterpreterIdentifierList read FISetList;\r\n property IDGetList: TJvInterpreterIdentifierList read FIDGetList;\r\n property IDSetList: TJvInterpreterIdentifierList read FIDSetList;\r\n property IntfGetList: TJvInterpreterIdentifierList read FIntfGetList;\r\n property DirectGetList: TJvInterpreterIdentifierList read FDirectGetList;\r\n property ClassList: TJvInterpreterIdentifierList read FClassList;\r\n property ConstList: TJvInterpreterIdentifierList read FConstList;\r\n property FunctionList: TJvInterpreterIdentifierList read FFunctionList;\r\n property RecordList: TJvInterpreterIdentifierList read FRecordList;\r\n property RecordGetList: TJvInterpreterIdentifierList read FRecordGetList;\r\n property RecordSetList: TJvInterpreterIdentifierList read FRecordSetList;\r\n property OnGetList: TJvInterpreterIdentifierList read FOnGetList;\r\n property OnSetList: TJvInterpreterIdentifierList read FOnSetList;\r\n property SrcFunctionList: TJvInterpreterIdentifierList read FSrcFunctionList;\r\n property ExtFunctionList: TJvInterpreterIdentifierList read FExtFunctionList;\r\n property EventHandlerList: TJvInterpreterIdentifierList read FEventHandlerList;\r\n property EventList: TJvInterpreterIdentifierList read FEventList;\r\n property SrcVarList: TJvInterpreterVarList read FSrcVarList;\r\n property SrcClassList: TJvInterpreterIdentifierList read FSrcClassList;\r\n end;\r\n\r\n TStackPtr = -1..cJvInterpreterStackMax;\r\n\r\n { Expression evaluator }\r\n TJvInterpreterExpression = class(TJvComponent)\r\n private\r\n FParser: TJvInterpreterParser;\r\n FVResult: Variant;\r\n FExpStack: array [0..cJvInterpreterStackMax] of Variant;\r\n FExpStackPtr: TStackPtr;\r\n FToken: Variant;\r\n FBacked: Boolean;\r\n FTTyp: TTokenKind;\r\n FTokenStr: string;\r\n FPrevTTyp: TTokenKind;\r\n FAllowAssignment: Boolean;\r\n FArgs: TJvInterpreterArgs; { data }\r\n FCurrArgs: TJvInterpreterArgs; { pointer to current }\r\n FPStream: TStream; { parsed source }\r\n FParsed: Boolean;\r\n FAdapter: TJvInterpreterAdapter;\r\n FSharedAdapter: TJvInterpreterAdapter;\r\n FCompiled: Boolean;\r\n FBaseErrLine: Integer;\r\n FOnGetValue: TJvInterpreterGetValue;\r\n FOnSetValue: TJvInterpreterSetValue;\r\n FLastError: EJvInterpreterError;\r\n FDisableExternalFunctions: Boolean;\r\n function GetSource: string;\r\n procedure SetSource(const Value: string);\r\n procedure SetCurPos(Value: Integer);\r\n function GetCurPos: Integer;\r\n function GetTokenStr: string;\r\n procedure ReadArgs;\r\n procedure InternalGetValue(Obj: Pointer; ObjTyp: Word; var Result: Variant);\r\n function CallFunction(const FunctionName: string;\r\n Args: TJvInterpreterArgs; Params: array of Variant): Variant; virtual; abstract;\r\n function CallFunctionEx(Instance: TObject; const UnitName: string;\r\n const FunctionName: string; Args: TJvInterpreterArgs; Params: array of Variant): Variant; virtual; abstract;\r\n procedure SetDisableExternalFunctions(const Value: Boolean);\r\n protected\r\n procedure UpdateExceptionPos(E: Exception; const UnitName: string);\r\n procedure Init; dynamic;\r\n procedure ErrorExpected(const Exp: string);\r\n procedure ErrorNotImplemented(const Msg: string);\r\n function PosBeg: Integer;\r\n function PosEnd: Integer;\r\n procedure Back;\r\n procedure SafeBack; {? please don't use ?}\r\n function CreateAdapter: TJvInterpreterAdapter; dynamic;\r\n procedure ParseToken;\r\n procedure ReadToken;\r\n procedure WriteToken;\r\n procedure Parse;\r\n function Expression1: Variant;\r\n function Expression2(const ExpType: Word): Variant;\r\n function SetExpression1: Variant;\r\n procedure NextToken;\r\n function GetValue(const Identifier: string; var Value: Variant;\r\n var Args: TJvInterpreterArgs): Boolean; virtual;\r\n function SetValue(const Identifier: string; const Value: Variant;\r\n var Args: TJvInterpreterArgs): Boolean; virtual;\r\n function GetElement(const Variable: Variant; var Value: Variant;\r\n var Args: TJvInterpreterArgs): Boolean; virtual;\r\n function SetElement(var Variable: Variant; const Value: Variant;\r\n var Args: TJvInterpreterArgs): Boolean; virtual;\r\n procedure SourceChanged; dynamic;\r\n procedure SetAdapter(Adapter: TJvInterpreterAdapter);\r\n property Token: Variant read FToken;\r\n property TTyp: TTokenKind read FTTyp;\r\n property PrevTTyp: TTokenKind read FPrevTTyp;\r\n property TokenStr: string read GetTokenStr;\r\n property CurPos: Integer read GetCurPos write SetCurPos;\r\n property Compiled: Boolean read FCompiled;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n procedure Run; dynamic;\r\n property Source: string read GetSource write SetSource;\r\n property VResult: Variant read FVResult;\r\n property OnGetValue: TJvInterpreterGetValue read FOnGetValue write FOnGetValue;\r\n property OnSetValue: TJvInterpreterSetValue read FOnSetValue write FOnSetValue;\r\n property Adapter: TJvInterpreterAdapter read FAdapter;\r\n property SharedAdapter: TJvInterpreterAdapter read FSharedAdapter;\r\n property BaseErrLine: Integer read FBaseErrLine write FBaseErrLine;\r\n property LastError: EJvInterpreterError read FLastError;\r\n property DisableExternalFunctions: Boolean read FDisableExternalFunctions write SetDisableExternalFunctions;\r\n end;\r\n\r\n TParserState = record\r\n CurPos: Integer;\r\n Token: Variant;\r\n TTyp: TTokenKind;\r\n PrevTTyp: TTokenKind;\r\n Backed: Boolean;\r\n AllowAssignment: Boolean;\r\n end;\r\n\r\n TJvInterpreterAddVarFunc = procedure(const UnitName,\r\n Identifier, Typ: string; VTyp: Word; const Value: Variant;\r\n ADataType: IJvInterpreterDataType) of object;\r\n\r\n { Function executor }\r\n TJvInterpreterFunction = class(TJvInterpreterExpression)\r\n private\r\n FCurUnitName: string;\r\n FCurInstance: TObject;\r\n FBreak: Boolean;\r\n FContinue: Boolean;\r\n FExit: Boolean;\r\n FFunctionStack: TList;\r\n FFunctionContext: Pointer; { PFunctionContext }\r\n FSS: TStringList;\r\n FStateStack: array [0..cJvInterpreterStackMax] of TParserState;\r\n FStateStackPtr: TStackPtr;\r\n FEventList: TList;\r\n function GetLocalVars: TJvInterpreterVarList;\r\n function GetFunStackCount: Integer;\r\n function GetDebugPointerToGlobalVars: TJvInterpreterVarList;\r\n function GetDebugPointerToFunStack: Pointer;\r\n protected\r\n procedure Init; override;\r\n procedure PushState;\r\n procedure PopState;\r\n procedure RemoveState;\r\n procedure DoOnStatement; virtual;\r\n procedure InFunction(FunctionDesc: TJvInterpreterFunctionDesc);\r\n procedure InterpretStatement;\r\n procedure SkipStatement;\r\n procedure SkipToEnd;\r\n procedure SkipToUntil;\r\n procedure SkipIdentifier;\r\n procedure FindToken(ATTyp: TTokenKind);\r\n procedure InterpretVar(AddVarFunc: TJvInterpreterAddVarFunc);\r\n procedure InterpretConst(AddVarFunc: TJvInterpreterAddVarFunc);\r\n procedure InterpretIdentifier;\r\n procedure InterpretBegin;\r\n procedure InterpretIf;\r\n procedure InterpretWhile;\r\n procedure InterpretRepeat;\r\n procedure InterpretFor;\r\n procedure InterpretCase;\r\n procedure InterpretTry;\r\n procedure InterpretRaise;\r\n function ParseDataType: IJvInterpreterDataType;\r\n function NewEvent(const UnitName, FunctionName, EventType: string;\r\n Instance: TObject; const APropName: string): TSimpleEvent;\r\n function FindEvent(const UnitName: string; Instance: TObject;\r\n const PropName: string): TJvInterpreterEvent;\r\n procedure InternalSetValue(const Identifier: string);\r\n function GetValue(const Identifier: string; var Value: Variant;\r\n var Args: TJvInterpreterArgs): Boolean; override;\r\n function SetValue(const Identifier: string; const Value: Variant;\r\n var Args: TJvInterpreterArgs): Boolean; override;\r\n property LocalVars: TJvInterpreterVarList read GetLocalVars;\r\n property EventList: TList read FEventList;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n procedure Run; override;\r\n property CurUnitName: string read FCurUnitName;\r\n property CurInstance: TObject read FCurInstance;\r\n property FunStackCount: Integer read GetFunStackCount;\r\n property DebugPointerToFunStack: Pointer read GetDebugPointerToFunStack;\r\n property DebugPointerToGlobalVars: TJvInterpreterVarList read GetDebugPointerToGlobalVars;\r\n end;\r\n\r\n TUnitSection =\r\n (usUnknown, usInterface, usImplementation, usInitialization, usFinalization);\r\n\r\n { Unit executor }\r\n TJvInterpreterUnit = class(TJvInterpreterFunction)\r\n private\r\n FClearUnits: Boolean;\r\n FEventHandlerList: TList;\r\n FOnGetUnitSource: TJvInterpreterGetUnitSource;\r\n FUnitSection: TUnitSection;\r\n protected\r\n procedure Init; override;\r\n procedure ReadFunctionHeader(FunctionDesc: TJvInterpreterFunctionDesc);\r\n procedure InterpretUses(var UsesList: string);\r\n procedure ReadUnit(const UnitName: string);\r\n procedure InterpretFunction;\r\n procedure InterpretUnit;\r\n procedure InterpretType;\r\n procedure InterpretClass(const Identifier: string);\r\n function GetValue(const Identifier: string; var Value: Variant;\r\n var Args: TJvInterpreterArgs): Boolean; override;\r\n function SetValue(const Identifier: string; const Value: Variant;\r\n var Args: TJvInterpreterArgs): Boolean; override;\r\n function GetUnitSource(const UnitName: string; var Source: string): Boolean; dynamic;\r\n procedure ExecFunction(Fun: TJvInterpreterFunctionDesc);\r\n procedure SourceChanged; override;\r\n procedure InterpretRecord(const Identifier: string);\r\n property EventHandlerList: TList read FEventHandlerList;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n procedure Run; override;\r\n procedure DeclareExternalFunction(const Declaration: string);\r\n procedure Compile;\r\n function CallFunction(const FunctionName: string; Args: TJvInterpreterArgs;\r\n Params: array of Variant): Variant; override;\r\n function CallFunctionEx(Instance: TObject; const UnitName: string;\r\n const FunctionName: string; Args: TJvInterpreterArgs;\r\n Params: array of Variant): Variant; override;\r\n function FunctionExists(const UnitName: string;\r\n const FunctionName: string): Boolean;\r\n property OnGetUnitSource: TJvInterpreterGetUnitSource read FOnGetUnitSource\r\n write FOnGetUnitSource;\r\n property UnitSection: TUnitSection read FUnitSection;\r\n end;\r\n\r\n { main JvInterpreter component }\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvInterpreterProgram = class(TJvInterpreterUnit)\r\n private\r\n FPas: TStringList;\r\n FOnStatement: TNotifyEvent;\r\n function GetPas: TStrings;\r\n procedure SetPas(Value: TStrings);\r\n protected\r\n procedure DoOnStatement; override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n procedure Run; override;\r\n published\r\n property Pas: TStrings read GetPas write SetPas;\r\n property OnGetValue;\r\n property OnSetValue;\r\n property OnGetUnitSource;\r\n property OnStatement: TNotifyEvent read FOnStatement write FOnStatement;\r\n end;\r\n\r\n TJvSimpleVariantType = class(TCustomVariantType)\r\n public\r\n procedure Clear(var V: TVarData); override;\r\n procedure Copy(var Dest: TVarData; const Source: TVarData;\r\n const Indirect: Boolean); override;\r\n procedure CastTo(var Dest: TVarData; const Source: TVarData;\r\n const AVarType: TVarType); override;\r\n end;\r\n\r\n TJvRecordVariantType = class(TJvSimpleVariantType);\r\n TJvObjectVariantType = class(TJvSimpleVariantType);\r\n TJvClassVariantType = class(TJvSimpleVariantType);\r\n TJvPointerVariantType = class(TJvSimpleVariantType);\r\n TJvSetVariantType = class(TJvSimpleVariantType);\r\n TJvArrayVariantType = class(TJvSimpleVariantType);\r\n\r\n EJvInterpreterError = class(Exception)\r\n private\r\n FExceptionPos: Boolean;\r\n FErrCode: Integer;\r\n FErrPos: Integer;\r\n FErrName1: string;\r\n FErrName2: string;\r\n FErrUnitName: string;\r\n FErrLine: Integer;\r\n FErrMessage: string;\r\n public\r\n constructor Create(const AErrCode: Integer; const AErrPos: Integer;\r\n const AErrName1, AErrName2: string);\r\n procedure Assign(E: Exception);\r\n procedure Clear;\r\n property ErrCode: Integer read FErrCode;\r\n property ErrPos: Integer read FErrPos;\r\n property ErrName1: string read FErrName1;\r\n property ErrName2: string read FErrName2;\r\n property ErrUnitName: string read FErrUnitName;\r\n property ErrLine: Integer read FErrLine;\r\n property ErrMessage: string read FErrMessage;\r\n end;\r\n\r\n{Error raising routines}\r\nprocedure JvInterpreterError(const AErrCode: Integer; const AErrPos: Integer);\r\nprocedure JvInterpreterErrorN(const AErrCode: Integer; const AErrPos: Integer;\r\n const AErrName: string);\r\nprocedure JvInterpreterErrorN2(const AErrCode: Integer; const AErrPos: Integer;\r\n const AErrName1, AErrName2: string);\r\n\r\n{Utilities functions}\r\n//function LoadStr2(const ResID: Integer): string;\r\n\r\n{ RFD - RecordFieldDefinition - return record needed for TJvInterpreterAdapter.AddRec\r\n Fields parameter }\r\nfunction RFD(const Identifier: string; Offset: Integer; Typ: Word): TJvInterpreterRecField;\r\n\r\n{ raise error ieNotImplemented }\r\nprocedure NotImplemented(const Msg: string);\r\n\r\n{ clear list of TObject }\r\nprocedure ClearList(List: TList);\r\n\r\n{ additional variant types - TVarData.VType }\r\n\r\nfunction varRecord: TVarType;\r\nfunction varObject: TVarType;\r\nfunction varClass: TVarType;\r\nfunction varPointer: TVarType;\r\nfunction varSet: TVarType;\r\nfunction varArray: TVarType;\r\n\r\ntype\r\n TJvInterpreterShiftStateCastType = {$IFDEF COMPILER14_UP}Word{$ELSE}Byte{$ENDIF};\r\n\r\n{ V2O - converts variant to object }\r\nfunction V2O(const V: Variant): TObject;\r\n\r\n{ O2V - converts object to variant }\r\nfunction O2V(O: TObject): Variant;\r\n\r\n{ V2C - converts variant to class }\r\nfunction V2C(const V: Variant): TClass;\r\n\r\n{ O2V - converts class to variant }\r\nfunction C2V(C: TClass): Variant;\r\n\r\n{ V2P - converts variant to pointer }\r\nfunction V2P(const V: Variant): Pointer;\r\n\r\n{ P2V - converts pointer to variant }\r\nfunction P2V(P: Pointer): Variant;\r\n\r\n{ R2V - create record holder and put it into variant }\r\nfunction R2V(const ARecordType: string; ARec: Pointer): Variant;\r\n\r\n{ V2R - returns pointer to record from variant, containing record holder }\r\nfunction V2R(const V: Variant): Pointer;\r\n\r\n{ P2R - returns pointer to record from record holder, typically Args.Obj }\r\nfunction P2R(const P: Pointer): Pointer;\r\n\r\n{ S2V - converts Integer to set and put it into variant }\r\nfunction S2V(const I: Integer): Variant;\r\n\r\n{ V2S - give a set from variant and converts it to Integer }\r\nfunction V2S(V: Variant): Integer;\r\n\r\nprocedure V2OA(V: Variant; var OA: TOpenArray; var OAValues: TValueArray;\r\n var Size: Integer);\r\n\r\nfunction TypeName2VarTyp(const TypeName: string): Word;\r\n\r\n{ copy variant variable with all JvInterpreter variant extension }\r\nprocedure JvInterpreterVarCopy(var Dest: Variant; const Source: Variant);\r\n\r\n{ copy variant variable for assignment }\r\nprocedure JvInterpreterVarAssignment(var Dest: Variant; const Source: Variant);\r\n\r\nfunction JvInterpreterVarAsType(const V: Variant; const VarType: Integer): Variant;\r\n\r\n{ properly free var variable and set it content to empty }\r\nprocedure JvInterpreterVarFree(var V: Variant);\r\n\r\n{ compare strings }\r\nfunction Cmp(const S1, S2: string): Boolean;\r\n\r\n{ For dynamic array support}\r\nprocedure JvInterpreterArraySetLength(AArray: Variant; ASize: Integer);\r\nfunction JvInterpreterArrayLength(const AArray: Variant): Integer;\r\nfunction JvInterpreterArrayLow(const AArray: Variant): Integer;\r\nfunction JvInterpreterArrayHigh(const AArray: Variant): Integer;\r\nprocedure JvInterpreterArrayElementDelete(AArray: Variant; AElement: Integer);\r\nprocedure JvInterpreterArrayElementInsert(AArray: Variant; AElement: Integer; Value: Variant);\r\n\r\nfunction GlobalJvInterpreterAdapter: TJvInterpreterAdapter;\r\n\r\nconst\r\n prArgsNoCheck = -1;\r\n noInstance = HINST(0);\r\n RFDNull: TJvInterpreterRecField = (Identifier: ''; Offset: 0; Typ: 0);\r\n\r\n varByConst = $8000;\r\n\r\n {JvInterpreter error codes}\r\n ieOk = 0; { Okay - no errors }\r\n ieUnknown = 1;\r\n ieInternal = 2;\r\n ieUserBreak = 3; { internal }\r\n ieRaise = 4; { internal }\r\n ieErrorPos = 5;\r\n ieExternal = 6; { non-interpreter error }\r\n ieAccessDenied = 7;\r\n ieExpressionStackOverflow = 8;\r\n\r\n { register-time errors }\r\n ieRegisterBase = 30;\r\n ieRecordNotDefined = ieRegisterBase + 1;\r\n\r\n { run-time errors }\r\n ieRuntimeBase = 50;\r\n ieStackOverFlow = ieRuntimeBase + 2;\r\n ieTypeMistmatch = ieRuntimeBase + 3;\r\n ieIntegerOverflow = ieRuntimeBase + 4;\r\n ieMainUndefined = ieRuntimeBase + 5;\r\n ieUnitNotFound = ieRuntimeBase + 6;\r\n ieEventNotRegistered = ieRuntimeBase + 7;\r\n ieDfmNotFound = ieRuntimeBase + 8;\r\n\r\n { syntax errors (now run-timed) }\r\n ieSyntaxBase = 100;\r\n ieBadRemark = ieSyntaxBase + 1; { Bad remark - detected by parser }\r\n ieIdentifierExpected = ieSyntaxBase + 2;\r\n ieExpected = ieSyntaxBase + 3;\r\n ieUnknownIdentifier = ieSyntaxBase + 4;\r\n ieBooleanRequired = ieSyntaxBase + 5;\r\n ieClassRequired = ieSyntaxBase + 6;\r\n ieNotAllowedBeforeElse = ieSyntaxBase + 7;\r\n ieIntegerRequired = ieSyntaxBase + 8;\r\n ieROCRequired = ieSyntaxBase + 9;\r\n ieMissingOperator = ieSyntaxBase + 10;\r\n ieIdentifierRedeclared = ieSyntaxBase + 11;\r\n\r\n { array indexes }\r\n ieArrayBase = 170;\r\n ieArrayIndexOutOfBounds = ieArrayBase + 1;\r\n ieArrayTooManyParams = ieArrayBase + 2;\r\n ieArrayNotEnoughParams = ieArrayBase + 3;\r\n ieArrayBadDimension = ieArrayBase + 4;\r\n ieArrayBadRange = ieArrayBase + 5;\r\n ieArrayRequired = ieArrayBase + 6;\r\n\r\n { function call errors (now run-timed) }\r\n ieFunctionBase = 180;\r\n ieTooManyParams = ieFunctionBase + 1;\r\n ieNotEnoughParams = ieFunctionBase + 2;\r\n ieIncompatibleTypes = ieFunctionBase + 3;\r\n ieDllErrorLoadLibrary = ieFunctionBase + 4;\r\n ieDllInvalidArgument = ieFunctionBase + 5;\r\n ieDllInvalidResult = ieFunctionBase + 6;\r\n ieDllFunctionNotFound = ieFunctionBase + 7;\r\n ieDirectInvalidArgument = ieFunctionBase + 8;\r\n ieDirectInvalidResult = ieFunctionBase + 9;\r\n ieDirectInvalidConvention = ieFunctionBase + 10;\r\n\r\n {$IFDEF JvInterpreter_OLEAUTO}\r\n ieOleAuto = ieFunctionBase + 21;\r\n {$ENDIF JvInterpreter_OLEAUTO}\r\n\r\n ieUserBase = $300;\r\n\r\n irExpression = 301;\r\n irIdentifier = 302;\r\n irDeclaration = 303;\r\n irEndOfFile = 304;\r\n irClass = 305;\r\n irIntegerConstant = 306;\r\n irIntegerValue = 307;\r\n irStringConstant = 308;\r\n irStatement = 309;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvInterpreter.pas $';\r\n Revision: '$Revision: 13415 $';\r\n Date: '$Date: 2012-09-10 11:51:54 +0200 (lun. 10 sept. 2012) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n Types,\r\n TypInfo,\r\n {$IFDEF CPUX64}\r\n System.Rtti,\r\n {$ENDIF CPUX64}\r\n {$IFDEF JvInterpreter_OLEAUTO}\r\n OleConst, ActiveX, ComObj,\r\n {$ENDIF JvInterpreter_OLEAUTO}\r\n JvConsts, JvInterpreterConst, JvJVCLUtils, JvJCLUtils, JvResources, JvTypes,\r\n JvInterpreterFm; // required uses for class method support\r\n\r\nvar\r\n FieldGlobalJvInterpreterAdapter: TJvInterpreterAdapter = nil;\r\n\r\nfunction GlobalJvInterpreterAdapter: TJvInterpreterAdapter;\r\nbegin\r\n if not Assigned(FieldGlobalJvInterpreterAdapter) then\r\n FieldGlobalJvInterpreterAdapter := TJvInterpreterAdapter.Create(nil);\r\n Result := FieldGlobalJvInterpreterAdapter;\r\nend;\r\n\r\n{ internal structures }\r\n\r\n\r\n\r\n{$IFDEF JvInterpreter_DEBUG}\r\nvar\r\n ObjCount: Integer = 0;\r\n{$ENDIF JvInterpreter_DEBUG}\r\n\r\nvar\r\n GlobalVariantRecordInstance: TJvRecordVariantType = nil;\r\n GlobalVariantObjectInstance: TJvObjectVariantType = nil;\r\n GlobalVariantClassInstance: TJvClassVariantType = nil;\r\n GlobalVariantPointerInstance: TJvPointerVariantType = nil;\r\n GlobalVariantSetInstance: TJvSetVariantType = nil;\r\n GlobalVariantArrayInstance: TJvArrayVariantType = nil;\r\n\r\nfunction VariantRecordInstance: TJvRecordVariantType;\r\nbegin\r\n if not Assigned(GlobalVariantRecordInstance) then\r\n GlobalVariantRecordInstance := TJvRecordVariantType.Create;\r\n Result := GlobalVariantRecordInstance;\r\nend;\r\n\r\nfunction VariantObjectInstance: TJvObjectVariantType;\r\nbegin\r\n if not Assigned(GlobalVariantObjectInstance) then\r\n GlobalVariantObjectInstance := TJvObjectVariantType.Create;\r\n Result := GlobalVariantObjectInstance;\r\nend;\r\n\r\nfunction VariantClassInstance: TJvClassVariantType;\r\nbegin\r\n if not Assigned(GlobalVariantClassInstance) then\r\n GlobalVariantClassInstance := TJvClassVariantType.Create;\r\n Result := GlobalVariantClassInstance;\r\nend;\r\n\r\nfunction VariantPointerInstance: TJvPointerVariantType;\r\nbegin\r\n if not Assigned(GlobalVariantPointerInstance) then\r\n GlobalVariantPointerInstance := TJvPointerVariantType.Create;\r\n Result := GlobalVariantPointerInstance;\r\nend;\r\n\r\nfunction VariantSetInstance: TJvSetVariantType;\r\nbegin\r\n if not Assigned(GlobalVariantSetInstance) then\r\n GlobalVariantSetInstance := TJvSetVariantType.Create;\r\n Result := GlobalVariantSetInstance;\r\nend;\r\n\r\nfunction VariantArrayInstance: TJvArrayVariantType;\r\nbegin\r\n if not Assigned(GlobalVariantArrayInstance) then\r\n GlobalVariantArrayInstance := TJvArrayVariantType.Create;\r\n Result := GlobalVariantArrayInstance;\r\nend;\r\n\r\n//=== { TJvSimpleVariantType } ===============================================\r\n\r\nprocedure TJvSimpleVariantType.CastTo(var Dest: TVarData;\r\n const Source: TVarData; const AVarType: TVarType);\r\nbegin\r\n //support only inherited classes\r\n Dest.VPointer := Source.VPointer;\r\n //inherited;\r\nend;\r\n\r\nprocedure TJvSimpleVariantType.Clear(var V: TVarData);\r\nbegin\r\n SimplisticClear(V);\r\nend;\r\n\r\nprocedure TJvSimpleVariantType.Copy(var Dest: TVarData;\r\n const Source: TVarData; const Indirect: Boolean);\r\nbegin\r\n SimplisticCopy(Dest, Source, Indirect);\r\nend;\r\n\r\nfunction varRecord: TVarType;\r\nbegin\r\n Result := VariantRecordInstance.VarType;\r\nend;\r\n\r\nfunction varObject: TVarType;\r\nbegin\r\n Result := VariantObjectInstance.VarType;\r\nend;\r\n\r\nfunction varClass: TVarType;\r\nbegin\r\n Result := VariantClassInstance.VarType;\r\nend;\r\n\r\nfunction varPointer: TVarType;\r\nbegin\r\n Result := VariantPointerInstance.VarType;\r\nend;\r\n\r\nfunction varSet: TVarType;\r\nbegin\r\n Result := VariantSetInstance.VarType;\r\nend;\r\n\r\nfunction varArray: TVarType;\r\nbegin\r\n Result := VariantArrayInstance.VarType;\r\nend;\r\n\r\n//=== EJvInterpreterError ====================================================\r\n\r\nfunction LoadStr2(const ResID: Integer): string;\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := Low(JvInterpreterErrors) to High(JvInterpreterErrors) do\r\n if JvInterpreterErrors[I].ID = ResID then\r\n begin\r\n Result := JvInterpreterErrors[I].Description;\r\n Break;\r\n end;\r\nend;\r\n\r\nprocedure JvInterpreterError(const AErrCode: Integer; const AErrPos: Integer);\r\nbegin\r\n raise EJvInterpreterError.Create(AErrCode, AErrPos, '', '');\r\nend;\r\n\r\nprocedure JvInterpreterErrorN(const AErrCode: Integer; const AErrPos: Integer;\r\n const AErrName: string);\r\nbegin\r\n raise EJvInterpreterError.Create(AErrCode, AErrPos, AErrName, '');\r\nend;\r\n\r\nprocedure JvInterpreterErrorN2(const AErrCode: Integer; const AErrPos: Integer;\r\n const AErrName1, AErrName2: string);\r\nbegin\r\n raise EJvInterpreterError.Create(AErrCode, AErrPos, AErrName1, AErrName2);\r\nend;\r\n\r\nconstructor EJvInterpreterError.Create(const AErrCode: Integer;\r\n const AErrPos: Integer; const AErrName1, AErrName2: string);\r\nbegin\r\n inherited Create('');\r\n FErrCode := AErrCode;\r\n FErrPos := AErrPos;\r\n FErrName1 := AErrName1;\r\n FErrName2 := AErrName2;\r\n { function LoadStr don't work sometimes :-( }\r\n Message := Format(LoadStr2(ErrCode), [ErrName1, ErrName2]);\r\n FErrMessage := Message;\r\nend;\r\n\r\nprocedure EJvInterpreterError.Assign(E: Exception);\r\nbegin\r\n Message := E.Message;\r\n if E is EJvInterpreterError then\r\n begin\r\n FErrCode := (E as EJvInterpreterError).ErrCode;\r\n FErrPos := (E as EJvInterpreterError).ErrPos;\r\n FErrName1 := (E as EJvInterpreterError).ErrName1;\r\n FErrName2 := (E as EJvInterpreterError).ErrName2;\r\n FErrMessage := (E as EJvInterpreterError).ErrMessage;\r\n end;\r\nend;\r\n\r\nprocedure EJvInterpreterError.Clear;\r\nbegin\r\n FExceptionPos := False;\r\n FErrName1 := '';\r\n FErrName2 := '';\r\n FErrPos := -1;\r\n FErrLine := -1;\r\n FErrUnitName := '';\r\nend;\r\n\r\nfunction V2O(const V: Variant): TObject;\r\nbegin\r\n Result := TVarData(V).VPointer;\r\nend;\r\n\r\nfunction O2V(O: TObject): Variant;\r\nbegin\r\n TVarData(Result).VType := varObject;\r\n TVarData(Result).VPointer := O;\r\nend;\r\n\r\nfunction V2C(const V: Variant): TClass;\r\nbegin\r\n Result := TVarData(V).VPointer;\r\nend;\r\n\r\nfunction C2V(C: TClass): Variant;\r\nbegin\r\n TVarData(Result).VType := varClass;\r\n TVarData(Result).VPointer := C;\r\nend;\r\n\r\nfunction V2P(const V: Variant): Pointer;\r\nbegin\r\n Result := TVarData(V).VPointer;\r\nend;\r\n\r\nfunction P2V(P: Pointer): Variant;\r\nbegin\r\n TVarData(Result).VType := varPointer;\r\n TVarData(Result).VPointer := P;\r\nend;\r\n\r\nfunction R2V(const ARecordType: string; ARec: Pointer): Variant;\r\nbegin\r\n TVarData(Result).VPointer := TJvInterpreterRecHolder.Create(ARecordType, ARec);\r\n TVarData(Result).VType := varRecord;\r\nend;\r\n\r\nfunction V2R(const V: Variant): Pointer;\r\nbegin\r\n if (TVarData(V).VType <> varRecord) or\r\n not (TObject(TVarData(V).VPointer) is TJvInterpreterRecHolder) then\r\n JvInterpreterError(ieROCRequired, -1);\r\n Result := TJvInterpreterRecHolder(TVarData(V).VPointer).Rec;\r\nend;\r\n\r\nfunction P2R(const P: Pointer): Pointer;\r\nbegin\r\n if not (TObject(P) is TJvInterpreterRecHolder) then\r\n JvInterpreterError(ieROCRequired, -1);\r\n Result := TJvInterpreterRecHolder(P).Rec;\r\nend;\r\n\r\nfunction S2V(const I: Integer): Variant;\r\nbegin\r\n Result := I;\r\n TVarData(Result).VType := varSet;\r\nend;\r\n\r\nfunction V2S(V: Variant): Integer;\r\nvar\r\n I: Integer;\r\nbegin\r\n if (TVarData(V).VType and System.varArray) = 0 then\r\n Result := TVarData(V).VInteger\r\n else\r\n begin\r\n { JvInterpreter thinks about all function parameters, started\r\n with '[' symbol that they are open arrays;\r\n but it may be set constant, so we must convert it now }\r\n Result := 0;\r\n for I := VarArrayLowBound(V, 1) to VarArrayHighBound(V, 1) do\r\n Result := Result or 1 shl Integer(V[I]);\r\n end;\r\nend;\r\n\r\nfunction RFD(const Identifier: string; Offset: Integer; Typ: Word): TJvInterpreterRecField;\r\nbegin\r\n Result.Identifier := Identifier;\r\n Result.Offset := Offset;\r\n Result.Typ := Typ;\r\nend;\r\n\r\nprocedure NotImplemented(const Msg: string);\r\nbegin\r\n JvInterpreterErrorN(ieInternal, -1, Msg + RsENotImplemented);\r\nend;\r\n\r\n//RWare: added check for \"char\", otherwise function with ref variable\r\n//of type char causes AV, like KeyPress event handler\r\n\r\nfunction Typ2Size(ATyp: Word): Integer;\r\nbegin\r\n Result := 0;\r\n case ATyp of\r\n varInteger:\r\n Result := SizeOf(Integer);\r\n varDouble:\r\n Result := SizeOf(Double);\r\n varByte:\r\n Result := SizeOf(Byte);\r\n varSmallint:\r\n Result := SizeOf(Smallint);\r\n varDate:\r\n Result := SizeOf(Double);\r\n varEmpty, varVariant, varOleStr, varDispatch, varUnknown:\r\n Result := SizeOf(TVarData);\r\n else\r\n if ATyp = varObject then\r\n Result := SizeOf(TObject);\r\n end;\r\nend;\r\n\r\nfunction TypeName2VarTyp(const TypeName: string): Word;\r\nbegin\r\n // (rom) reimplemented for speed\r\n // (rom) LongBool added (untested)\r\n Result := varEmpty;\r\n if TypeName <> '' then\r\n begin\r\n case TypeName[1] of\r\n 'A', 'a':\r\n if Cmp(TypeName, 'AnsiString') then\r\n Result := varString;\r\n 'B', 'b':\r\n if Cmp(TypeName, 'boolean') or Cmp(TypeName, 'bool') then\r\n Result := varBoolean\r\n else\r\n if Cmp(TypeName, 'byte') then\r\n Result := varByte;\r\n 'C', 'c':\r\n if Cmp(TypeName, 'char') then {+RWare}\r\n Result := varString;\r\n 'D', 'd':\r\n if Cmp(TypeName, 'dword') then\r\n Result := varInteger\r\n else\r\n if Cmp(TypeName, 'double') then\r\n Result := varDouble;\r\n 'I', 'i':\r\n if Cmp(TypeName, 'integer') then\r\n Result := varInteger;\r\n 'L', 'l':\r\n if Cmp(TypeName, 'longint') then\r\n Result := varInteger\r\n else\r\n if Cmp(TypeName, 'longbool') then\r\n Result := varBoolean;\r\n 'P', 'p':\r\n if Cmp(TypeName, 'PChar') then\r\n Result := varString;\r\n 'S', 's':\r\n if Cmp(TypeName, 'string') or Cmp(TypeName, 'ShortString') then\r\n Result := varString\r\n else\r\n if Cmp(TypeName, 'smallint') then\r\n Result := varSmallint;\r\n 'T', 't':\r\n if Cmp(TypeName, 'TObject') then\r\n Result := varObject\r\n else\r\n if Cmp(TypeName, 'tdatetime') then\r\n Result := varDate;\r\n 'W', 'w':\r\n if Cmp(TypeName, 'word') then\r\n Result := varSmallint\r\n else\r\n if Cmp(TypeName, 'wordbool') then\r\n Result := varBoolean;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure ClearList(List: TList);\r\nvar\r\n I: Integer;\r\nbegin\r\n if Assigned(List) then\r\n begin\r\n for I := 0 to List.Count - 1 do\r\n TObject(List[I]).Free;\r\n List.Clear;\r\n end;\r\nend;\r\n\r\nprocedure ClearMethodList(List: TList);\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := 0 to List.Count - 1 do\r\n Dispose(PMethod(List[I]));\r\n List.Clear;\r\nend;\r\n\r\n// (rom) JvUtil added to uses and functions deleted\r\n\r\nfunction Cmp(const S1, S2: string): Boolean;\r\nbegin\r\n // Direct call to CompareString is faster than AnsiCompareText.\r\n Result := (Length(S1) = Length(S2)) and\r\n (CompareString(LOCALE_USER_DEFAULT, NORM_IGNORECASE, PChar(S1),\r\n -1, PChar(S2), -1) = 2);\r\nend;\r\n\r\n{************* Some code from RAStream unit **************}\r\n\r\nprocedure StringSaveToStream(Stream: TStream; const S: string);\r\nvar\r\n L: Integer;\r\n UTF8Str: UTF8String;\r\nbegin\r\n UTF8Str := UTF8Encode(S);\r\n L := Length(UTF8Str);\r\n Stream.WriteBuffer(L, SizeOf(L));\r\n if L > 0 then\r\n Stream.WriteBuffer(UTF8Str[1], L);\r\nend;\r\n\r\nfunction StringLoadFromStream(Stream: TStream): string;\r\nvar\r\n L: Integer;\r\n UTF8Str: UTF8String;\r\nbegin\r\n Stream.ReadBuffer(L, SizeOf(L));\r\n SetLength(UTF8Str, L);\r\n if L > 0 then\r\n Stream.ReadBuffer(UTF8Str[1], L);\r\n Result := UTF8ToString(UTF8Str);\r\nend;\r\n\r\nprocedure IntSaveToStream(Stream: TStream; AInt: Integer);\r\nbegin\r\n Stream.WriteBuffer(AInt, SizeOf(AInt));\r\nend;\r\n\r\nfunction IntLoadFromStream(Stream: TStream): Integer;\r\nbegin\r\n Stream.ReadBuffer(Result, SizeOf(Result));\r\nend;\r\n\r\nprocedure WordSaveToStream(Stream: TStream; AWord: Word);\r\nbegin\r\n Stream.WriteBuffer(AWord, SizeOf(AWord));\r\nend;\r\n\r\nfunction WordLoadFromStream(Stream: TStream): Word;\r\nbegin\r\n Stream.ReadBuffer(Result, SizeOf(Result));\r\nend;\r\n\r\nprocedure ExtendedSaveToStream(Stream: TStream; AExt: Extended);\r\nbegin\r\n Stream.WriteBuffer(AExt, SizeOf(AExt));\r\nend;\r\n\r\nfunction ExtendedLoadFromStream(Stream: TStream): Extended;\r\nbegin\r\n Stream.ReadBuffer(Result, SizeOf(Result));\r\nend;\r\n\r\nprocedure BoolSaveToStream(Stream: TStream; ABool: Boolean);\r\nvar\r\n B: Integer;\r\nbegin\r\n B := Ord(ABool);\r\n Stream.WriteBuffer(B, SizeOf(B));\r\nend;\r\n\r\nfunction BoolLoadFromStream(Stream: TStream): Boolean;\r\nvar\r\n B: Integer;\r\nbegin\r\n Stream.ReadBuffer(B, SizeOf(B));\r\n Result := (B <> 0);\r\nend;\r\n\r\n{################## from RAStream unit ##################}\r\n\r\n{$IFDEF JvInterpreter_OLEAUTO}\r\n\r\n{************* Some code from Delphi's OleAuto unit **************}\r\n\r\nconst\r\n { Maximum number of dispatch arguments }\r\n MaxDispArgs = 64;\r\n\r\n { Special variant type codes }\r\n varStrArg = $0048;\r\n\r\n { Parameter type masks }\r\n atVarMask = $3F;\r\n atTypeMask = $7F;\r\n atByRef = $80;\r\n\r\n{ Call GetIDsOfNames method on the given IDispatch interface }\r\n\r\nprocedure GetIDsOfNames(Dispatch: IDispatch; Names: PChar;\r\n NameCount: Integer; DispIDs: PDispIDList);\r\nvar\r\n I, N: Integer;\r\n Ch: WideChar;\r\n P: PWideChar;\r\n NameRefs: array [0..MaxDispArgs - 1] of PWideChar;\r\n WideNames: array [0..1023] of WideChar;\r\n R: Integer;\r\nbegin\r\n I := 0;\r\n N := 0;\r\n repeat\r\n P := @WideNames[I];\r\n if N = 0 then\r\n NameRefs[0] := P\r\n else\r\n NameRefs[NameCount - N] := P;\r\n repeat\r\n MultiByteToWideChar(0,0,@Names[I], 1, @ch, 1);\r\n WideNames[I] := Ch;\r\n Inc(I);\r\n until Char(Ch) = #0;\r\n Inc(N);\r\n until N = NameCount;\r\n { if Dispatch.GetIDsOfNames(GUID_NULL, @NameRefs, NameCount,\r\n LOCALE_SYSTEM_DEFAULT, DispIDs) <> 0 then }\r\n R := Dispatch.GetIDsOfNames(GUID_NULL, @NameRefs, NameCount,\r\n LOCALE_SYSTEM_DEFAULT, DispIDs);\r\n if R <> 0 then\r\n raise EOleError.CreateResFmt(@SNoMethod, [Names]);\r\nend;\r\n\r\n{ Central call dispatcher }\r\n\r\nprocedure VarDispInvoke(Result: PVariant; const Dispatch: Pointer;\r\n Names: PChar; CallDesc: PCallDesc; ParamTypes: Pointer); cdecl;\r\nvar\r\n DispIDs: array [0..MaxDispArgs - 1] of Integer;\r\nbegin\r\n GetIDsOfNames(IDispatch(Dispatch), Names, CallDesc^.NamedArgCount + 1, PDispIDList(@DispIDs[0]));\r\n if Result <> nil then\r\n VarClear(Result^);\r\n DispatchInvoke(IDispatch(Dispatch), CallDesc, PDispIDList(@DispIDs[0]), ParamTypes, Result);\r\nend;\r\n\r\n{################## from OleAuto unit ##################}\r\n{$ENDIF JvInterpreter_OLEAUTO}\r\n\r\ntype\r\n TFunc = procedure;\r\n {$IFNDEF CPU64}\r\n TiFunc = function: Integer;\r\n TfFunc = function: Boolean;\r\n TwFunc = function: Word;\r\n {$ENDIF ~CPU64}\r\n\r\nfunction CallDllIns(Ins: HINST; const FuncName: string; Args: TJvInterpreterArgs;\r\n ParamDesc: TTypeArray; ResTyp: Word): Variant;\r\nvar\r\n Func: TFunc;\r\n {$IFNDEF CPU64}\r\n iFunc: TiFunc;\r\n fFunc: TfFunc;\r\n wFunc: TwFunc;\r\n {$ELSE}\r\n Params: TArray;\r\n {$ENDIF ~CPU64}\r\n I: Integer;\r\n AInt: Integer;\r\n // Abyte : Byte;\r\n AWord: Word;\r\n APointer: Pointer;\r\n Str: string;\r\nbegin\r\n Result := Null;\r\n Func := GetProcAddress(Ins, PChar(FuncName));\r\n {$IFNDEF CPU64}\r\n iFunc := @Func;\r\n fFunc := @Func;\r\n wFunc := @Func;\r\n {$ENDIF ~CPU64}\r\n if Assigned(Func) then\r\n begin\r\n try\r\n {$IFNDEF CPU64}\r\n for I := Args.Count - 1 downto 0 do { 'stdcall' call conversion }\r\n {$ELSE}\r\n SetLength(Params, Args.Count);\r\n for I := 0 to Args.Count - 1 do\r\n {$ENDIF ~CPU64}\r\n begin\r\n if (ParamDesc[I] and varByRef) = 0 then\r\n case ParamDesc[I] of\r\n varInteger, { ttByte,} varBoolean:\r\n begin\r\n AInt := Args.Values[I];\r\n {$IFNDEF CPU64}\r\n asm\r\n push AInt\r\n end;\r\n {$ELSE}\r\n Params[I] := TValue.From(AInt);\r\n {$ENDIF ~CPU64}\r\n end;\r\n varSmallint:\r\n begin\r\n AWord := Word(Args.Values[I]);\r\n {$IFNDEF CPU64}\r\n asm\r\n push AWord\r\n end;\r\n {$ELSE}\r\n Params[I] := TValue.From(AWord);\r\n {$ENDIF ~CPU64}\r\n end;\r\n varString:\r\n begin\r\n APointer := PChar(string(Args.Values[I]));\r\n {$IFNDEF CPU64}\r\n asm\r\n push APointer\r\n end;\r\n {$ELSE}\r\n Params[I] := TValue.From(APointer);\r\n {$ENDIF ~CPU64}\r\n end;\r\n else\r\n JvInterpreterErrorN(ieDllInvalidArgument, -1, FuncName);\r\n end\r\n else\r\n case ParamDesc[I] and not varByRef of\r\n varInteger, { ttByte,} varBoolean:\r\n begin\r\n APointer := @TVarData(Args.Values[I]).VInteger;\r\n {$IFNDEF CPU64}\r\n asm\r\n push APointer\r\n end;\r\n {$ELSE}\r\n Params[I] := TValue.From(APointer);\r\n {$ENDIF ~CPU64}\r\n end;\r\n varSmallint:\r\n begin\r\n APointer := @TVarData(Args.Values[I]).vSmallInt;\r\n {$IFNDEF CPU64}\r\n asm\r\n push APointer\r\n end;\r\n {$ELSE}\r\n Params[I] := TValue.From(APointer);\r\n {$ENDIF ~CPU64}\r\n end;\r\n else\r\n JvInterpreterErrorN(ieDllInvalidArgument, -1, FuncName);\r\n end\r\n end;\r\n\r\n case ResTyp of\r\n varSmallint:\r\n {$IFNDEF CPU64}\r\n Result := wFunc();\r\n {$ELSE}\r\n Result := System.Rtti.Invoke(@Func, Params, System.TypInfo.TCallConv.ccStdCall, TypeInfo(SmallInt), True).AsType();\r\n {$ENDIF ~CPU64}\r\n varInteger:\r\n {$IFNDEF CPU64}\r\n Result := iFunc();\r\n {$ELSE}\r\n Result := System.Rtti.Invoke(@Func, Params, System.TypInfo.TCallConv.ccStdCall, TypeInfo(Integer), True).AsType();\r\n {$ENDIF ~CPU64}\r\n varBoolean:\r\n {$IFNDEF CPU64}\r\n Result := Boolean(Ord(fFunc()));\r\n {$ELSE}\r\n Result := Boolean(Ord(System.Rtti.Invoke(@Func, Params, System.TypInfo.TCallConv.ccStdCall, TypeInfo(Boolean), True).AsType()));\r\n {$ENDIF ~CPU64}\r\n varEmpty:\r\n {$IFNDEF CPU64}\r\n Func();\r\n {$ELSE}\r\n System.Rtti.Invoke(@Func, Params, System.TypInfo.TCallConv.ccStdCall, nil, True);\r\n {$ENDIF ~CPU64}\r\n else\r\n JvInterpreterErrorN(ieDllInvalidResult, -1, FuncName);\r\n end;\r\n except\r\n on E: EJvInterpreterError do\r\n raise E;\r\n on E: Exception do\r\n begin\r\n Str := E.Message;\r\n UniqueString(Str);\r\n raise EJVCLException.Create(Str);\r\n end;\r\n end;\r\n end\r\n else\r\n JvInterpreterError(ieDllFunctionNotFound, -1);\r\nend;\r\n\r\nfunction CallDll(const DllName, FuncName: string; Args: TJvInterpreterArgs;\r\n ParamDesc: TTypeArray; ResTyp: Word): Variant;\r\nvar\r\n Ins: HMODULE;\r\n LastError: DWORD;\r\nbegin\r\n Result := False;\r\n Ins := SafeLoadLibrary(DllName);\r\n if Ins = 0 then\r\n JvInterpreterErrorN(ieDllErrorLoadLibrary, -1, DllName);\r\n try\r\n Result := CallDllIns(Ins, FuncName, Args, ParamDesc, ResTyp);\r\n LastError := GetLastError;\r\n finally\r\n FreeLibrary(Ins);\r\n end;\r\n SetLastError(LastError);\r\nend;\r\n\r\nprocedure ConvertParamTypes(InParams: array of Word; var OutParams: TTypeArray);\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := Low(InParams) to High(InParams) do\r\n OutParams[I] := InParams[I];\r\nend;\r\n\r\nprocedure ConvertParamNames(InParams: array of string;\r\n var OutParams: TNameArray);\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := Low(InParams) to High(InParams) do\r\n OutParams[I] := InParams[I];\r\nend;\r\n\r\n{ ************************* Array support ************************* }\r\n\r\nfunction GetArraySize(Dimension: Integer; BeginPos, EndPos: TJvInterpreterArrayValues): Integer;\r\nvar\r\n A: Integer;\r\nbegin\r\n Result := 1;\r\n for A := 0 to Dimension - 1 do\r\n begin\r\n Result := Result * ((EndPos[A] - BeginPos[A]) + 1);\r\n end;\r\nend;\r\n\r\n{ Calculate starting position of element in memory }\r\n\r\nfunction GetArrayOffset(Dimension: Integer; BeginPos, EndPos: TJvInterpreterArrayValues;\r\n Element: TJvInterpreterArrayValues): Integer;\r\nvar\r\n A: Integer;\r\n LastDim: Integer;\r\nbegin\r\n Result := 0;\r\n LastDim := 1;\r\n for A := 0 to Dimension - 1 do\r\n begin\r\n if (Element[A] < BeginPos[A]) or (Element[A] > EndPos[A]) then\r\n JvInterpreterError(ieArrayIndexOutOfBounds, -1);\r\n Result := Result + (LastDim * (Element[A] - BeginPos[A]));\r\n LastDim := LastDim * (EndPos[A] - BeginPos[A] + 1);\r\n end;\r\nend;\r\n\r\n{Allocate memory for new array}\r\n\r\nfunction JvInterpreterArrayInit(const Dimension: Integer;\r\n const BeginPos, EndPos: TJvInterpreterArrayValues;\r\n const ItemType: Integer; DataType: IJvInterpreterDataType): PJvInterpreterArrayRec;\r\nvar\r\n PP: PJvInterpreterArrayRec;\r\n SS: TStringList;\r\n AA: Integer;\r\n ArraySize: Integer;\r\n I: Integer;\r\nbegin\r\n if (Dimension < 1) or (Dimension > cJvInterpreterMaxArgs) then\r\n JvInterpreterError(ieArrayBadDimension, -1);\r\n for AA := 0 to Dimension - 1 do\r\n begin\r\n // For dynamic arrays BeginPos[AA] <= EndPos[AA]\r\n if (not (BeginPos[AA] <= EndPos[AA])) and\r\n (Dimension <> 1) and (BeginPos[AA] <> 0) and (EndPos[AA] <> -1) then\r\n JvInterpreterError(ieArrayBadRange, -1);\r\n end;\r\n\r\n New(PP);\r\n PP^.BeginPos := BeginPos;\r\n PP^.EndPos := EndPos;\r\n PP^.ItemType := ItemType;\r\n PP^.DT := DataType;\r\n ArraySize := GetArraySize(Dimension, BeginPos, EndPos);\r\n PP^.Size := ArraySize;\r\n PP^.Dimension := Dimension;\r\n\r\n if ItemType <> varString then\r\n PP^.ElementSize := Typ2Size(ItemType)\r\n else\r\n begin\r\n PP^.ElementSize := 0;\r\n SS := TStringList.Create;\r\n for AA := 1 to ArraySize do\r\n SS.Add('');\r\n PP^.Memory := SS;\r\n end;\r\n\r\n if ItemType <> varString then\r\n begin\r\n GetMem(PP^.Memory, ArraySize * PP^.ElementSize);\r\n //ZeroMemory(PP^.Memory, ArraySize * PP^.ElementSize);\r\n FillChar(PP^.Memory^, ArraySize * PP^.ElementSize, 0);\r\n if ItemType = varEmpty then\r\n for I := 0 to ArraySize - 1 do\r\n PP^.DT.Init(Variant(PVarData(PAnsiChar(PP^.Memory) + I * PP^.ElementSize)^));\r\n end;\r\n Result := PP;\r\nend;\r\n\r\n{ Free memory for array }\r\n\r\nprocedure JvInterpreterArrayFree(JvInterpreterArrayRec: PJvInterpreterArrayRec);\r\nvar\r\n I: Integer;\r\n ArraySize: Integer;\r\nbegin\r\n if not Assigned(JvInterpreterArrayRec) then\r\n Exit;\r\n ArraySize := GetArraySize(JvInterpreterArrayRec^.Dimension,\r\n JvInterpreterArrayRec^.BeginPos, JvInterpreterArrayRec^.EndPos);\r\n if JvInterpreterArrayRec^.ItemType <> varString then\r\n begin\r\n if JvInterpreterArrayRec^.ItemType = varEmpty then\r\n for I := 0 to ArraySize - 1 do\r\n JvInterpreterVarFree(Variant(PVarData(PAnsiChar(JvInterpreterArrayRec^.Memory) + I *\r\n JvInterpreterArrayRec^.ElementSize)^));\r\n FreeMem(JvInterpreterArrayRec^.Memory, (JvInterpreterArrayRec^.Size) *\r\n JvInterpreterArrayRec^.ElementSize);\r\n Dispose(JvInterpreterArrayRec);\r\n end\r\n else\r\n begin\r\n TStringList(JvInterpreterArrayRec^.Memory).Clear;\r\n TStringList(JvInterpreterArrayRec^.Memory).Free;\r\n Dispose(JvInterpreterArrayRec);\r\n end;\r\nend;\r\n\r\n{ Set element for array }\r\n\r\nprocedure JvInterpreterArraySetElement(Element: TJvInterpreterArrayValues; Value: Variant;\r\n JvInterpreterArrayRec: PJvInterpreterArrayRec);\r\nvar\r\n Offset: Integer;\r\n P: Pointer;\r\nbegin\r\n if JvInterpreterArrayRec^.Dimension > 1 then\r\n Offset := GetArrayOffset(JvInterpreterArrayRec^.Dimension, JvInterpreterArrayRec^.BeginPos,\r\n JvInterpreterArrayRec^.EndPos, Element)\r\n else\r\n Offset := Element[0] - JvInterpreterArrayRec^.BeginPos[0];\r\n P := Pointer(PAnsiChar(JvInterpreterArrayRec^.Memory) + (Offset * JvInterpreterArrayRec^.ElementSize));\r\n case JvInterpreterArrayRec^.ItemType of\r\n varInteger:\r\n PInteger(P)^ := Value;\r\n varDouble:\r\n PDouble(P)^ := Value;\r\n varByte:\r\n PByte(P)^ := Value;\r\n varSmallint:\r\n PSmallInt(P)^ := Value;\r\n varDate:\r\n PDouble(P)^ := Value;\r\n varString:\r\n begin\r\n Value := VarAsType(Value, varString);\r\n TStringList(JvInterpreterArrayRec^.Memory).Strings[Offset] := Value;\r\n end;\r\n varEmpty:\r\n JvInterpreterVarAssignment(Variant(PVarData(P)^), Value);\r\n else\r\n if JvInterpreterArrayRec^.ItemType = varObject then\r\n TObject(P^) := V2O(Value);\r\n end;\r\nend;\r\n\r\n{ Get element for array }\r\n\r\nfunction JvInterpreterArrayGetElement(Element: TJvInterpreterArrayValues;\r\n JvInterpreterArrayRec: PJvInterpreterArrayRec): Variant;\r\nvar\r\n Offset: Integer;\r\n P: Pointer;\r\nbegin\r\n if JvInterpreterArrayRec^.Dimension > 1 then\r\n Offset := GetArrayOffset(JvInterpreterArrayRec^.Dimension, JvInterpreterArrayRec^.BeginPos,\r\n JvInterpreterArrayRec^.EndPos, Element)\r\n else\r\n Offset := Element[0] - JvInterpreterArrayRec^.BeginPos[0];\r\n P := Pointer(PAnsiChar(JvInterpreterArrayRec^.Memory) + (Offset * JvInterpreterArrayRec^.ElementSize));\r\n case JvInterpreterArrayRec^.ItemType of\r\n varInteger:\r\n Result := Integer(P^);\r\n varDouble:\r\n Result := Double(P^);\r\n varByte:\r\n Result := Byte(P^);\r\n varSmallint:\r\n Result := Smallint(P^);\r\n varDate:\r\n Result := TDateTime(P^);\r\n varString:\r\n Result := TStringList(JvInterpreterArrayRec^.Memory).Strings[Offset];\r\n varEmpty:\r\n JvInterpreterVarCopy(Result, Variant(PVarData(P)^));\r\n else\r\n if JvInterpreterArrayRec^.ItemType = varObject then\r\n Result := O2V(TObject(P^));\r\n end;\r\nend;\r\n\r\n{ For dynamic array support }\r\n\r\nprocedure JvInterpreterArraySetLength(AArray: Variant; ASize: Integer);\r\nvar\r\n I: Integer;\r\n OldSize: Integer;\r\n ArrayRec: PJvInterpreterArrayRec;\r\nbegin\r\n ArrayRec := PJvInterpreterArrayRec(TVarData(AArray).VPointer);\r\n if ArrayRec^.Dimension > 1 then\r\n raise EJVCLException.CreateRes(@RsESorryDynamicArraysSupportIsMadeForO);\r\n OldSize := ArrayRec^.Size;\r\n if OldSize > ASize then\r\n begin\r\n for I := ASize to OldSize - 1 do\r\n if ArrayRec^.ItemType = varEmpty then\r\n JvInterpreterVarFree(Variant((PVarData(PAnsiChar(ArrayRec^.Memory) + I * ArrayRec^.ElementSize))^));\r\n ArrayRec^.EndPos[0] := ArrayRec^.EndPos[0] - (OldSize - ASize);\r\n ArrayRec^.Size := GetArraySize(1, ArrayRec^.BeginPos, ArrayRec^.EndPos);\r\n ReallocMem(ArrayRec^.Memory, ASize * ArrayRec^.ElementSize);\r\n end\r\n else\r\n if OldSize < ASize then\r\n begin\r\n ReallocMem(ArrayRec^.Memory, ASize * ArrayRec^.ElementSize);\r\n FillChar((PAnsiChar(ArrayRec^.Memory) + OldSize * ArrayRec^.ElementSize)^,\r\n (ASize - OldSize) * ArrayRec^.ElementSize, 0);\r\n for I := OldSize to ASize - 1 do\r\n if ArrayRec^.ItemType = varEmpty then\r\n ArrayRec^.DT.Init(Variant(Pointer(PAnsiChar(ArrayRec^.Memory) + I * ArrayRec^.ElementSize)^));\r\n ArrayRec^.EndPos[0] := ArrayRec^.EndPos[0] + (ASize - OldSize);\r\n ArrayRec^.Size := GetArraySize(ArrayRec^.Dimension, ArrayRec^.BeginPos, ArrayRec^.EndPos);\r\n end;\r\nend;\r\n\r\nfunction JvInterpreterArrayLength(const AArray: Variant): Integer;\r\nvar\r\n ArrayRec: PJvInterpreterArrayRec;\r\nbegin\r\n ArrayRec := PJvInterpreterArrayRec(TVarData(AArray).VPointer);\r\n if ArrayRec^.Dimension > 1 then\r\n raise EJVCLException.CreateRes(@RsESorryForOneDimensionalArraysOnly);\r\n Result := ArrayRec^.Size;\r\nend;\r\n\r\nfunction JvInterpreterArrayLow(const AArray: Variant): Integer;\r\nvar\r\n ArrayRec: PJvInterpreterArrayRec;\r\nbegin\r\n ArrayRec := PJvInterpreterArrayRec(TVarData(AArray).VPointer);\r\n if ArrayRec^.Dimension > 1 then\r\n raise EJVCLException.CreateRes(@RsESorryForOneDimensionalArraysOnly);\r\n Result := ArrayRec^.BeginPos[0];\r\nend;\r\n\r\nfunction JvInterpreterArrayHigh(const AArray: Variant): Integer;\r\nvar\r\n ArrayRec: PJvInterpreterArrayRec;\r\nbegin\r\n ArrayRec := PJvInterpreterArrayRec(TVarData(AArray).VPointer);\r\n if ArrayRec^.Dimension > 1 then\r\n raise EJVCLException.CreateRes(@RsESorryForOneDimensionalArraysOnly);\r\n Result := ArrayRec^.EndPos[0];\r\nend;\r\n\r\nprocedure JvInterpreterArrayElementDelete(AArray: Variant; AElement: Integer);\r\nvar\r\n ArrayRec: PJvInterpreterArrayRec;\r\nbegin\r\n ArrayRec := PJvInterpreterArrayRec(TVarData(AArray).VPointer);\r\n if ArrayRec^.Dimension > 1 then\r\n raise EJVCLException.CreateRes(@RsESorryForOneDimensionalArraysOnly);\r\n if (AElement < ArrayRec^.BeginPos[0]) or (AElement > ArrayRec^.EndPos[0]) then\r\n JvInterpreterError(ieArrayIndexOutOfBounds, -1);\r\n ArrayRec^.EndPos[0] := ArrayRec^.EndPos[0] - 1;\r\n ArrayRec^.Size := GetArraySize(ArrayRec^.Dimension, ArrayRec^.BeginPos, ArrayRec^.EndPos);\r\n if ArrayRec^.ItemType = varEmpty then\r\n JvInterpreterVarFree(Variant(PVarData(PAnsiChar(ArrayRec^.Memory) +\r\n (AElement - ArrayRec^.BeginPos[0]) * ArrayRec^.ElementSize)^));\r\n Move((PAnsiChar(ArrayRec^.Memory) + (AElement - ArrayRec^.BeginPos[0] + 1) * ArrayRec^.ElementSize)^,\r\n (PAnsiChar(ArrayRec^.Memory) + (AElement - ArrayRec^.BeginPos[0]) * ArrayRec^.ElementSize)^,\r\n (ArrayRec^.EndPos[0] - AElement + 1) * ArrayRec^.ElementSize);\r\n ReallocMem(ArrayRec^.Memory, ArrayRec^.Size * ArrayRec^.ElementSize);\r\n\r\nend;\r\n\r\nprocedure JvInterpreterArrayElementInsert(AArray: Variant; AElement: Integer; Value: Variant);\r\nvar\r\n ArrayRec: PJvInterpreterArrayRec;\r\nbegin\r\n ArrayRec := PJvInterpreterArrayRec(TVarData(AArray).VPointer);\r\n if ArrayRec^.Dimension > 1 then\r\n raise EJVCLException.CreateRes(@RsESorryForOneDimensionalArraysOnly);\r\n if (AElement < ArrayRec^.BeginPos[0]) or (AElement > ArrayRec^.EndPos[0]) then\r\n JvInterpreterError(ieArrayIndexOutOfBounds, -1);\r\n ArrayRec^.EndPos[0] := ArrayRec^.EndPos[0] + 1;\r\n ArrayRec^.Size := GetArraySize(ArrayRec^.Dimension, ArrayRec^.BeginPos, ArrayRec^.EndPos);\r\n ReallocMem(ArrayRec^.Memory, ArrayRec^.Size * ArrayRec^.ElementSize);\r\n Move((PAnsiChar(ArrayRec^.Memory) + (AElement - ArrayRec^.BeginPos[0]) * ArrayRec^.ElementSize)^,\r\n (PAnsiChar(ArrayRec^.Memory) + (AElement - ArrayRec^.BeginPos[0] + 1) * ArrayRec^.ElementSize)^,\r\n (ArrayRec^.EndPos[0] - AElement) * ArrayRec^.ElementSize);\r\n if ArrayRec^.ItemType = varEmpty then\r\n ArrayRec^.DT.Init(Variant(PVarData(PAnsiChar(ArrayRec^.Memory) +\r\n (AElement - ArrayRec^.BeginPos[0]) * ArrayRec^.ElementSize)^));\r\n JvInterpreterVarAssignment(Variant(PVarData(PAnsiChar(ArrayRec^.Memory) +\r\n (AElement - ArrayRec^.BeginPos[0]) * ArrayRec^.ElementSize)^), Value);\r\nend;\r\n\r\nprocedure V2OA(V: Variant; var OA: TOpenArray; var OAValues: TValueArray;\r\n var Size: Integer);\r\nvar\r\n I: Integer;\r\n ArrayRec: PJvInterpreterArrayRec;\r\n Element: TJvInterpreterArrayValues;\r\n ElementVariant: Variant;\r\nbegin\r\n if TVarData(V).VType = varArray then\r\n //JvInterpreterError(ieTypeMistmatch, -1);\r\n begin\r\n ArrayRec := PJvInterpreterArrayRec(TVarData(V).VPointer);\r\n if ArrayRec^.Dimension > 1 then\r\n raise EJVCLException.CreateRes(@RsESorryForOneDimensionalArraysOnly);\r\n Size := ArrayRec^.Size;\r\n for I := 0 to Size - 1 do\r\n begin\r\n Element[0] := I;\r\n ElementVariant := JvInterpreterArrayGetElement(Element, ArrayRec);\r\n case TVarData(ElementVariant).VType of\r\n varInteger, varSmallint:\r\n begin\r\n OAValues[I] := ElementVariant;\r\n OA[I].VInteger := ElementVariant;\r\n OA[I].VType := vtInteger;\r\n end;\r\n varString, varOleStr:\r\n begin\r\n // OA[I].vPChar := PChar(string(V[I]));\r\n // OA[I].VType := vtPChar;\r\n OAValues[I] := ElementVariant;\r\n OA[I].VVariant := @OAValues[I];\r\n OA[I].VType := vtVariant;\r\n end;\r\n varBoolean:\r\n begin\r\n OAValues[I] := ElementVariant;\r\n OA[I].VBoolean := ElementVariant;\r\n OA[I].VType := vtBoolean;\r\n end;\r\n varDouble, varCurrency:\r\n begin\r\n OAValues[i] := V[i];\r\n VarCast(OAValues[I], OAValues[I], varCurrency);\r\n OA[i].vCurrency := @TVarData(OAValues[i]).vCurrency;\r\n OA[i].VType := vtCurrency;\r\n end;\r\n else\r\n OAValues[I] := ElementVariant;\r\n OA[I].VVariant := @OAValues[I];\r\n OA[I].VType := vtVariant;\r\n end;\r\n end;\r\n end\r\n else\r\n begin\r\n Size := VarArrayHighBound(V, 1) - VarArrayLowBound(V, 1) + 1;\r\n for I := VarArrayLowBound(V, 1) to VarArrayHighBound(V, 1) do\r\n begin\r\n case TVarData(V[I]).VType of\r\n varInteger, varSmallint:\r\n begin\r\n OAValues[I] := V[I];\r\n OA[I].VInteger := V[I];\r\n OA[I].VType := vtInteger;\r\n end;\r\n varString, varOleStr:\r\n begin\r\n OAValues[I] := V[I];\r\n OA[I].VVariant := @OAValues[I];\r\n OA[I].VType := vtVariant;\r\n end;\r\n varBoolean:\r\n begin\r\n OAValues[I] := V[I];\r\n OA[I].VBoolean := V[I];\r\n OA[I].VType := vtBoolean;\r\n end;\r\n varDouble, varCurrency:\r\n begin\r\n OAValues[i] := V[i];\r\n VarCast(OAValues[I], OAValues[I], varCurrency);\r\n OA[i].vCurrency := @TVarData(OAValues[i]).vCurrency;\r\n OA[i].VType := vtCurrency;\r\n end;\r\n else\r\n OAValues[I] := V[I];\r\n OA[I].VVariant := @OAValues[I];\r\n OA[I].VType := vtVariant;\r\n end;\r\n end;\r\n end;\r\n\r\nend;\r\n\r\n{ ########################## Array support ########################## }\r\n\r\n{ ************************ extended variants ************************ }\r\n\r\nfunction JvInterpreterVarAsType(const V: Variant; const VarType: Integer): Variant;\r\nbegin\r\n if (TVarData(V).VType = varEmpty) or (TVarData(V).VType = varNull) then\r\n begin\r\n case VarType of\r\n varString, varOleStr:\r\n Result := '';\r\n varInteger, varSmallint, varByte:\r\n Result := 0;\r\n varBoolean:\r\n Result := False;\r\n varSingle, varDouble, varCurrency, varDate:\r\n Result := 0.0;\r\n varVariant:\r\n Result := Null;\r\n else\r\n Result := VarAsType(V, VarType);\r\n end;\r\n end\r\n else\r\n begin\r\n if TVarData(V).VType = varArray then\r\n begin\r\n TVarData(Result) := TVarData(V);\r\n TVarData(Result).VType := VarType;\r\n end\r\n else\r\n if (VarType = varEmpty) and not VarIsEmpty(V) then\r\n Result := V // because any cast to unassigned = unassigned\r\n else\r\n Result := VarAsType(V, VarType);\r\n end;\r\nend;\r\n\r\nprocedure JvInterpreterVarAssignment(var Dest: Variant; const Source: Variant);\r\nvar\r\n I: Integer;\r\n DestRecHolder: TJvInterpreterRecHolder;\r\n SourceRecHolder: TJvInterpreterRecHolder;\r\nbegin\r\n if TVarData(Source).VType = varArray then\r\n begin\r\n NotImplemented(RsArrayToArrayAssignment);\r\n // TVarData(Dest) := TVarData(Source);\r\n end\r\n else\r\n if TVarData(Source).VType = varRecord then\r\n begin\r\n DestRecHolder := TJvInterpreterRecHolder(TVarData(Dest).VPointer);\r\n SourceRecHolder := TJvInterpreterRecHolder(TVarData(Source).VPointer);\r\n for I := 0 to SourceRecHolder.JvInterpreterRecord.FieldCount - 1 do\r\n if SourceRecHolder.JvInterpreterRecord.Fields[I].Typ = varEmpty then\r\n JvInterpreterVarAssignment(Variant(PVarData(PAnsiChar(DestRecHolder.Rec) +\r\n DestRecHolder.JvInterpreterRecord.Fields[I].Offset)^),\r\n Variant(PVarData(PAnsiChar(SourceRecHolder.Rec) +\r\n SourceRecHolder.JvInterpreterRecord.Fields[I].Offset)^))\r\n else\r\n Move((PAnsiChar(SourceRecHolder.Rec) +\r\n SourceRecHolder.JvInterpreterRecord.Fields[I].Offset)^,\r\n (PAnsiChar(DestRecHolder.Rec) +\r\n DestRecHolder.JvInterpreterRecord.Fields[I].Offset)^,\r\n Typ2Size(SourceRecHolder.JvInterpreterRecord.Fields[I].Typ));\r\n end\r\n else\r\n Dest := Source;\r\nend;\r\n\r\nprocedure JvInterpreterVarCopy(var Dest: Variant; const Source: Variant);\r\nbegin\r\n if (TVarData(Source).VType = varArray) or (TVarData(Source).VType = varRecord) then\r\n TVarData(Dest) := TVarData(Source)\r\n else\r\n Dest := Source;\r\nend;\r\n\r\nprocedure JvInterpreterVarFree(var V: Variant);\r\nvar\r\n TempType: TVarType;\r\nbegin\r\n TempType := TVarData(V).VType;\r\n if TempType = varArray then\r\n JvInterpreterArrayFree(PJvInterpreterArrayRec(TVarData(V).VPointer))\r\n else\r\n if TempType = varRecord then\r\n TJvInterpreterRecHolder(TVarData(V).VPointer).Free;\r\n varclear(V);\r\nend;\r\n\r\n{\r\nfunction VarAsType2(const V: Variant; VarType: Integer): Variant;\r\nbegin\r\n if TVarData(V).VType = varNull then\r\n Result := VarAsType(Unassigned,VarType)\r\n else\r\n Result := VarAsType(V,VarType);\r\nend;\r\n}\r\n\r\nfunction Var2Type(V: Variant; const VarType: Integer): Variant;\r\nbegin\r\n if (TVarData(V).VType = varEmpty) or (TVarData(V).VType = varNull) then\r\n begin\r\n case VarType of\r\n varString, varOleStr:\r\n Result := '';\r\n varInteger, varSmallint, varByte:\r\n Result := 0;\r\n varBoolean:\r\n Result := False;\r\n varSingle, varDouble, varCurrency, varDate:\r\n Result := 0.0;\r\n varVariant:\r\n Result := Null;\r\n else\r\n Result := VarAsType(V, VarType);\r\n end;\r\n end\r\n else\r\n Result := VarAsType(V, VarType);\r\n if (VarType = varInteger) and (TVarData(V).VType = varBoolean) then\r\n Result := Ord(V = True);\r\nend;\r\n{ ######################## extended variants ######################## }\r\n\r\n//=== { TJvInterpreterVar } ==================================================\r\n\r\ndestructor TJvInterpreterVar.Destroy;\r\nbegin\r\n JvInterpreterVarFree(Value);\r\n inherited Destroy;\r\nend;\r\n\r\n//=== { TJvInterpreterVarList } ==============================================\r\n\r\ndestructor TJvInterpreterVarList.Destroy;\r\nbegin\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvInterpreterVarList.Clear;\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := 0 to Count - 1 do\r\n TJvInterpreterVar(Items[I]).Free;\r\n inherited Clear;\r\nend;\r\n\r\nprocedure TJvInterpreterVarList.AddVar(const UnitName, Identifier, Typ: string; VTyp: Word;\r\n const Value: Variant; DataType: IJvInterpreterDataType);\r\nvar\r\n VarRec: TJvInterpreterVar;\r\nbegin\r\n if FindVar(UnitName, Identifier) <> nil then\r\n JvInterpreterErrorN(ieIdentifierRedeclared, -1, Identifier);\r\n VarRec := TJvInterpreterVar.Create;\r\n VarRec.Identifier := Identifier;\r\n VarRec.UnitName := UnitName;\r\n JvInterpreterVarCopy(VarRec.Value, Value);\r\n VarRec.Typ := Typ;\r\n VarRec.VTyp := VTyp;\r\n Insert(0, VarRec);\r\nend;\r\n\r\nfunction TJvInterpreterVarList.FindVar(const UnitName, Identifier: string): TJvInterpreterVar;\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := 0 to Count - 1 do\r\n begin\r\n Result := TJvInterpreterVar(Items[I]);\r\n { if UnitName = '', any unit allowed }\r\n if Cmp(Result.Identifier, Identifier) and\r\n (Cmp(Result.UnitName, UnitName) or (UnitName = '')) then\r\n Exit;\r\n end;\r\n Result := nil;\r\nend;\r\n\r\nprocedure TJvInterpreterVarList.DeleteVar(const UnitName, Identifier: string);\r\nvar\r\n I: Integer;\r\n VarRec: TJvInterpreterVar;\r\nbegin\r\n for I := 0 to Count - 1 do\r\n begin\r\n VarRec := TJvInterpreterVar(Items[I]);\r\n if Cmp(VarRec.Identifier, Identifier) and\r\n (Cmp(VarRec.UnitName, UnitName) or (UnitName = '')) then\r\n begin\r\n JvInterpreterVarFree(VarRec.Value);\r\n VarRec.Free;\r\n Delete(I);\r\n Exit;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJvInterpreterVarList.GetValue(const Identifier: string; var Value: Variant;\r\n Args: TJvInterpreterArgs): Boolean;\r\nvar\r\n V: TJvInterpreterVar;\r\nbegin\r\n if Args.Obj = nil then\r\n V := FindVar('', Identifier)\r\n else\r\n if (Args.ObjTyp = varObject) and (Args.Obj is TJvInterpreterSrcUnit) then\r\n V := FindVar((Args.Obj as TJvInterpreterSrcUnit).Identifier, Identifier)\r\n else\r\n V := nil;\r\n Result := V <> nil;\r\n if Result then\r\n JvInterpreterVarCopy(Value, V.Value);\r\nend;\r\n\r\n(*\r\nfunction TJvInterpreterVarList.SetValue(Identifier: string; const Value: Variant;\r\n Args: TJvInterpreterArgs): Boolean;\r\nvar\r\n V: TJvInterpreterVar;\r\nbegin\r\n V := FindVar('', Identifier);\r\n Result := (V <> nil) and (Args.Obj = nil);\r\n if Result then\r\n JvInterpreterVarAssignment(V.Value, Value);\r\nend; { SetValue }\r\n*)\r\n\r\nfunction TJvInterpreterVarList.SetValue(const Identifier: string; const Value: Variant;\r\n Args: TJvInterpreterArgs): Boolean;\r\nvar\r\n V: TJvInterpreterVar;\r\nbegin\r\n V := FindVar('', Identifier);\r\n Result := (V <> nil) and (Args.Obj = nil);\r\n if Result then\r\n { If 0, then it's probably an object }\r\n { If a Variant, then we don't care about typecasting }\r\n { We only want to typecast if the types are not the same, for speed }\r\n if (V.VTyp <> 0) and\r\n (V.VTyp <> varVariant) and\r\n (TVarData(Value).VType <> V.VTyp) then\r\n begin\r\n { Is it a passed-by-reference variable? }\r\n if V.VTyp and varByRef > 0 then\r\n begin\r\n JvInterpreterVarAssignment(V.Value, JvInterpreterVarAsType(Value, V.VTyp and not varByRef));\r\n V.VTyp := V.VTyp or varByRef;\r\n end\r\n else\r\n JvInterpreterVarAssignment(V.Value, JvInterpreterVarAsType(Value, V.VTyp))\r\n end\r\n else\r\n JvInterpreterVarAssignment(V.Value, Value);\r\nend;\r\n\r\nprocedure TJvInterpreterVarList.Assign(source: TJvInterpreterVarList);\r\nvar\r\n I: Integer;\r\n SrcVar: TJvInterpreterVar;\r\nbegin\r\n Clear;\r\n for I := 0 to Source.Count-1 do\r\n begin\r\n SrcVar := TJvInterpreterVar(Source[I]);\r\n with SrcVar do\r\n AddVar(UnitName, Identifier, Typ, VTyp, Value, nil); // DataType not used\r\n //TJvInterpreterSimpleDataType.Create(varVariant);\r\n end;\r\nend;\r\n\r\n//=== { TJvInterpreterFunctionDesc } =========================================\r\n\r\nfunction TJvInterpreterFunctionDesc.GetParamType(Index: Integer): Word;\r\nbegin\r\n Result := FParamTypes[Index];\r\nend;\r\n\r\nfunction TJvInterpreterFunctionDesc.GetParamTypeNames(Index: Integer): string;\r\nbegin\r\n Result := FParamTypeNames[Index];\r\nend;\r\n\r\nfunction TJvInterpreterFunctionDesc.GetDefine: string;\r\nvar\r\n Fun, S, T: string;\r\n Param, Ret: string;\r\n I: Integer;\r\nbegin\r\n Result := '';\r\n if FIdentifier = '' then\r\n Exit;\r\n\r\n T := '%s %s(%s)%s;';\r\n\r\n if FResTyp = varEmpty then\r\n begin\r\n Fun := 'procedure';\r\n Ret := '';\r\n end\r\n else\r\n begin\r\n Fun := 'function';\r\n Ret := ': ' + ResTypName;\r\n end;\r\n\r\n for I := 0 to ParamCount - 1 do\r\n begin\r\n if (ParamTypes[I] and varByRef) = varByRef then\r\n S := 'Var ' + ParamNames[I]\r\n else\r\n if (ParamTypes[I] and varByConst) = varByConst then\r\n S := 'Const ' + ParamNames[I]\r\n else\r\n S := ParamNames[I];\r\n\r\n Param := Param + S + ': ' + ParamTypeNames[I];\r\n if I <> ParamCount - 1 then\r\n Param := Param + '; ';\r\n end;\r\n Result := Format(T, [Fun, FIdentifier, Param, Ret]);\r\nend;\r\n\r\nfunction TJvInterpreterFunctionDesc.GetParamName(Index: Integer): string;\r\nbegin\r\n Result := FParamNames[Index];\r\nend;\r\n\r\n//=== { TJvInterpreterRecHolder } ============================================\r\n\r\nconstructor TJvInterpreterRecHolder.Create(const ARecordType: string; ARec: Pointer);\r\nbegin\r\n // (rom) added inherited Create\r\n inherited Create;\r\n Assert(ARecordType <> '');\r\n FRecordType := ARecordType;\r\n Rec := ARec;\r\n {$IFDEF JvInterpreter_DEBUG}\r\n Inc(ObjCount);\r\n {$ENDIF JvInterpreter_DEBUG}\r\nend;\r\n\r\ndestructor TJvInterpreterRecHolder.Destroy;\r\nvar\r\n I: Integer;\r\nbegin\r\n if Assigned(JvInterpreterRecord) then\r\n begin\r\n if Assigned(JvInterpreterRecord.DestroyFunc) then\r\n JvInterpreterRecord.DestroyFunc(Rec)\r\n else\r\n begin\r\n for I := 0 to JvInterpreterRecord.FieldCount - 1 do\r\n begin\r\n if JvInterpreterRecord.Fields[I].Typ = varEmpty then\r\n JvInterpreterVarFree(Variant(PVarData(PAnsiChar(Rec) + JvInterpreterRecord.Fields[I].Offset)^));\r\n end;\r\n FreeMem(Rec, JvInterpreterRecord.RecordSize);\r\n end;\r\n end\r\n else\r\n JvInterpreterError(ieInternal, -1);\r\n inherited Destroy;\r\n {$IFDEF JvInterpreter_DEBUG}\r\n Dec(ObjCount);\r\n {$ENDIF JvInterpreter_DEBUG}\r\nend;\r\n\r\n//=== { TJvInterpreterSrcFunction } ==========================================\r\n\r\nconstructor TJvInterpreterSrcFunction.Create;\r\nbegin\r\n inherited Create;\r\n FFunctionDesc := TJvInterpreterFunctionDesc.Create;\r\nend;\r\n\r\ndestructor TJvInterpreterSrcFunction.Destroy;\r\nbegin\r\n FFunctionDesc.Free;\r\n inherited Destroy;\r\nend;\r\n\r\n//=== { TJvInterpreterExtFunction } ==========================================\r\n\r\nfunction TJvInterpreterExtFunction.CallDll(Args: TJvInterpreterArgs): Variant;\r\nbegin\r\n if DllInstance > 0 then\r\n Result := JvInterpreter.CallDllIns(DllInstance, FunctionName, Args, FunctionDesc.FParamTypes,\r\n FunctionDesc.ResTyp)\r\n else\r\n Result := JvInterpreter.CallDll(DllName, FunctionName, Args, FunctionDesc.FParamTypes,\r\n FunctionDesc.ResTyp)\r\nend;\r\n\r\n//=== { TJvInterpreterEvent } ================================================\r\n\r\nconstructor TJvInterpreterEvent.Create(AOwner: TJvInterpreterExpression;\r\n AInstance: TObject; const AUnitName, AFunctionName, APropName: string);\r\nbegin\r\n // (rom) added inherited Create\r\n inherited Create;\r\n FOwner := AOwner;\r\n FInstance := AInstance;\r\n FUnitName := AUnitName;\r\n FFunctionName := AFunctionName;\r\n FPropName := APropName;\r\n {$IFDEF JvInterpreter_DEBUG}\r\n Inc(ObjCount);\r\n {$ENDIF JvInterpreter_DEBUG}\r\nend;\r\n\r\ndestructor TJvInterpreterEvent.Destroy;\r\nbegin\r\n FArgs.Free;\r\n inherited Destroy;\r\n {$IFDEF JvInterpreter_DEBUG}\r\n Dec(ObjCount);\r\n {$ENDIF JvInterpreter_DEBUG}\r\nend;\r\n\r\nfunction TJvInterpreterEvent.GetArgs: TJvInterpreterArgs;\r\nbegin\r\n if FArgs = nil then\r\n FArgs := TJvInterpreterArgs.Create;\r\n Result := FArgs;\r\nend;\r\n\r\nfunction TJvInterpreterEvent.CallFunction(Args: TJvInterpreterArgs;\r\n Params: array of Variant): Variant;\r\nvar\r\n I: Integer;\r\n NV: Variant;\r\nbegin\r\n if Args = nil then\r\n Args := Self.Args;\r\n Args.Clear;\r\n for I := Low(Params) to High(Params) do\r\n begin\r\n Args.Values[Args.Count] := Params[I];\r\n Inc(Args.Count);\r\n end;\r\n NV := Null;\r\n Result := FOwner.CallFunctionEx(FInstance, FUnitName, FFunctionName, Args, NV);\r\nend;\r\n\r\n//=== { TJvInterpreterIdentifierList } =======================================\r\n\r\nfunction TJvInterpreterIdentifierList.Find(const Identifier: string;\r\n var Index: Integer): Boolean;\r\nvar\r\n L, H, I, C: Integer;\r\nbegin\r\n Result := False;\r\n L := 0;\r\n H := Count - 1;\r\n while L <= H do\r\n begin\r\n I := (L + H) shr 1;\r\n C := AnsiStrIComp(PChar(TJvInterpreterIdentifier(List[I]).Identifier), PChar(Identifier));\r\n if C < 0 then\r\n L := I + 1\r\n else\r\n begin\r\n H := I - 1;\r\n if C = 0 then\r\n begin\r\n Result := True;\r\n if Duplicates <> dupAccept then\r\n L := I;\r\n end;\r\n end;\r\n end;\r\n Index := L;\r\nend;\r\n\r\nprocedure TJvInterpreterIdentifierList.Sort(Compare: TListSortCompare = nil);\r\n\r\n function SortIdentifier(Item1, Item2: Pointer): Integer;\r\n begin\r\n { function AnsiStrIComp about 30% faster than AnsiCompareText }\r\n { Result := AnsiCompareText(TJvInterpreterIdentifier(Item1).Identifier,\r\n TJvInterpreterIdentifier(Item2).Identifier); }\r\n Result := AnsiStrIComp(PChar(TJvInterpreterIdentifier(Item1).Identifier),\r\n PChar(TJvInterpreterIdentifier(Item2).Identifier));\r\n end;\r\n\r\nbegin\r\n if Assigned(Compare) then\r\n inherited Sort(Compare)\r\n else\r\n inherited Sort(TListSortCompare(@SortIdentifier));\r\nend;\r\n\r\nfunction TJvInterpreterIdentifierList.IndexOf(const UnitName, Identifier: string): TJvInterpreterIdentifier;\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := Count - 1 downto 0 do\r\n begin\r\n Result := TJvInterpreterIdentifier(Items[I]);\r\n if Cmp(Result.Identifier, Identifier) and\r\n (Cmp(Result.UnitName, UnitName) or (UnitName = '')) then\r\n Exit;\r\n end;\r\n Result := nil;\r\nend;\r\n\r\n//=== { TJvInterpreterAdapter } ==============================================\r\n\r\nconstructor TJvInterpreterAdapter.Create(AOwner: TJvInterpreterExpression);\r\nbegin\r\n // (rom) added inherited Create\r\n inherited Create;\r\n FOwner := AOwner;\r\n FSrcUnitList := TJvInterpreterIdentifierList.Create;\r\n FExtUnitList := TJvInterpreterIdentifierList.Create;\r\n FIntfGetList := TJvInterpreterIdentifierList.Create;\r\n FGetList := TJvInterpreterMethodList.Create;\r\n FSetList := TJvInterpreterMethodList.Create;\r\n FIGetList := TJvInterpreterMethodList.Create;\r\n FISetList := TJvInterpreterMethodList.Create;\r\n FIDGetList := TJvInterpreterIdentifierList.Create;\r\n FIDSetList := TJvInterpreterIdentifierList.Create;\r\n FDirectGetList := TJvInterpreterIdentifierList.Create;\r\n FClassList := TJvInterpreterIdentifierList.Create;\r\n FConstList := TJvInterpreterIdentifierList.Create;\r\n FFunctionList := TJvInterpreterMethodList.Create;\r\n FRecordList := TJvInterpreterIdentifierList.Create;\r\n FRecordGetList := TJvInterpreterIdentifierList.Create;\r\n FRecordSetList := TJvInterpreterIdentifierList.Create;\r\n FOnGetList := TJvInterpreterIdentifierList.Create;\r\n FOnSetList := TJvInterpreterIdentifierList.Create;\r\n FExtFunctionList := TJvInterpreterIdentifierList.Create;\r\n FSrcFunctionList := TJvInterpreterIdentifierList.Create;\r\n FEventHandlerList := TJvInterpreterIdentifierList.Create;\r\n FEventList := TJvInterpreterIdentifierList.Create;\r\n FSrcVarList := TJvInterpreterVarList.Create;\r\n FSrcClassList := TJvInterpreterIdentifierList.Create;\r\n\r\n FIntfGetList.Duplicates := dupAccept;\r\n FGetList.Duplicates := dupAccept;\r\n FSetList.Duplicates := dupAccept;\r\n FIGetList.Duplicates := dupAccept;\r\n FISetList.Duplicates := dupAccept;\r\n\r\n FDisableExternalFunctions := False;\r\nend;\r\n\r\ndestructor TJvInterpreterAdapter.Destroy;\r\nbegin\r\n Clear;\r\n FSrcUnitList.Free;\r\n FExtUnitList.Free;\r\n FIntfGetList.Free;\r\n FGetList.Free;\r\n FSetList.Free;\r\n FIGetList.Free;\r\n FISetList.Free;\r\n FIDGetList.Free;\r\n FIDSetList.Free;\r\n FDirectGetList.Free;\r\n FClassList.Free;\r\n FConstList.Free;\r\n FFunctionList.Free;\r\n FRecordList.Free;\r\n FRecordGetList.Free;\r\n FRecordSetList.Free;\r\n FOnGetList.Free;\r\n FOnSetList.Free;\r\n FExtFunctionList.Free;\r\n FSrcFunctionList.Free;\r\n FEventHandlerList.Free;\r\n FEventList.Free;\r\n FSrcVarList.Free;\r\n FSrcClassList.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvInterpreterAdapter.ClearSource;\r\nvar\r\n I: Integer;\r\nbegin\r\n ClearList(FSrcUnitList);\r\n ClearList(FSrcFunctionList);\r\n FSrcVarList.Clear;\r\n for I := 0 to FSrcClassList.Count-1 do\r\n TJvInterpreterClass(FSrcClassList[I]).ClassFields.Clear;\r\n ClearList(FSrcClassList);\r\nend;\r\n\r\nprocedure TJvInterpreterAdapter.ClearNonSource;\r\nbegin\r\n ClearList(FExtUnitList);\r\n ClearList(FIntfGetList);\r\n ClearList(FGetList);\r\n ClearList(FSetList);\r\n ClearList(FIGetList);\r\n ClearList(FISetList);\r\n ClearList(FIDGetList);\r\n ClearList(FIDSetList);\r\n ClearList(FDirectGetList);\r\n ClearList(FClassList);\r\n ClearList(FConstList);\r\n ClearList(FFunctionList);\r\n ClearList(FRecordList);\r\n ClearList(FRecordGetList);\r\n ClearList(FRecordSetList);\r\n ClearList(FExtFunctionList);\r\n ClearList(FEventHandlerList);\r\n ClearList(FEventList);\r\n ClearMethodList(FOnGetList);\r\n ClearMethodList(FOnSetList);\r\nend;\r\n\r\nprocedure TJvInterpreterAdapter.Clear;\r\nbegin\r\n ClearSource;\r\n ClearNonSource;\r\nend;\r\n\r\nprocedure TJvInterpreterAdapter.Assign(Source: TJvInterpreterAdapter);\r\nvar\r\n I: Integer;\r\nbegin\r\n if Source = Self then\r\n Exit;\r\n for I := 0 to Source.FGetList.Count - 1 do\r\n with TJvInterpreterMethod(Source.FGetList[I]) do\r\n AddGetEx(FClassType, Identifier, Func, ParamCount, ParamTypes, ResTyp, Data);\r\n for I := 0 to Source.FSetList.Count - 1 do\r\n with TJvInterpreterMethod(Source.FSetList[I]) do\r\n AddSetEx(FClassType, Identifier, Func, ParamCount, ParamTypes, Data);\r\n for I := 0 to Source.FIGetList.Count - 1 do\r\n with TJvInterpreterMethod(Source.FIGetList[I]) do\r\n AddIGetEx(FClassType, Identifier, Func, ParamCount, ParamTypes, ResTyp, Data);\r\n for I := 0 to Source.FISetList.Count - 1 do\r\n with TJvInterpreterMethod(Source.FISetList[I]) do\r\n AddISetEx(FClassType, Identifier, Func, ParamCount, ParamTypes, Data);\r\n for I := 0 to Source.FIDGetList.Count - 1 do\r\n with TJvInterpreterMethod(Source.FIDGetList[I]) do\r\n AddIDGetEx(FClassType, Func, ParamCount, ParamTypes, ResTyp, Data);\r\n for I := 0 to Source.FIDSetList.Count - 1 do\r\n with TJvInterpreterMethod(Source.FIDSetList[I]) do\r\n AddIDSetEx(FClassType, Func, ParamCount, ParamTypes, Data);\r\n for I := 0 to Source.FIntfGetList.Count - 1 do\r\n with TJvInterpreterIntfMethod(Source.FIntfGetList[I]) do\r\n AddIntfGetEx(IID, Identifier, Func, ParamCount, ParamTypes, ResTyp, Data);\r\n for I := 0 to Source.FDirectGetList.Count - 1 do\r\n with TJvInterpreterDMethod(Source.FDirectGetList[I]) do\r\n AddDGetEx(FClassType, Identifier, Func, ParamCount, ParamTypes, ResTyp,\r\n CallConvention, Data);\r\n for I := 0 to Source.FFunctionList.Count - 1 do\r\n with TJvInterpreterMethod(Source.FFunctionList[I]) do\r\n AddFunctionEx(UnitName, Identifier, Func, ParamCount, ParamTypes, ResTyp, Data);\r\n for I := 0 to Source.FExtUnitList.Count - 1 do\r\n with TJvInterpreterIdentifier(Source.FExtUnitList[I]) do\r\n AddExtUnitEx(Identifier, Data);\r\n for I := 0 to Source.FClassList.Count - 1 do\r\n begin\r\n with TJvInterpreterClass(Source.FClassList[I]) do\r\n AddClassEx(UnitName, FClassType, Identifier, Data);\r\n TJvInterpreterClass(FClassList[FClassList.Count-1]).ClassFields.Assign(\r\n TJvInterpreterClass(Source.FClassList[I]).ClassFields);\r\n end;\r\n\r\n for I := 0 to Source.FSrcFunctionList.Count - 1 do\r\n with TJvInterpreterSrcFunction(Source.FSrcFunctionList[I]).FunctionDesc do\r\n AddSrcFunEx(UnitName, Identifier, ClassIdentifier, PosBeg, PosEnd, ParamCount, FParamTypes,\r\n FParamTypeNames, FParamNames, ResTyp, ResTypName, ResDataType,\r\n TJvInterpreterSrcFunction(Source.FSrcFunctionList[I]).Data);\r\n for I := 0 to Source.FSrcUnitList.Count - 1 do\r\n begin\r\n with TJvInterpreterSrcUnit(Source.FSrcUnitList[I]) do\r\n AddSrcUnitEx(Identifier, Source, '', Data);\r\n TJvInterpreterSrcUnit(FSrcUnitList[FSrcUnitList.Count - 1]).FUsesList:=\r\n TJvInterpreterSrcUnit(Source.FSrcUnitList[I]).UsesList;\r\n end;\r\n\r\n for I := 0 to Source.FConstList.Count - 1 do\r\n with TJvInterpreterConst(Source.FConstList[I]) do\r\n AddConstEx(UnitName, Identifier, Value, Data);\r\n for I := 0 to Source.FRecordList.Count - 1 do\r\n with TJvInterpreterRecord(Source.FRecordList[I]) do\r\n AddRecEx(UnitName, Identifier, RecordSize, Fields, CreateFunc,\r\n DestroyFunc, CopyFunc, Data);\r\n for I := 0 to Source.FRecordGetList.Count - 1 do\r\n with TJvInterpreterRecMethod(Source.FRecordGetList[I]) do\r\n AddRecGetEx(UnitName, JvInterpreterRecord.Identifier, Identifier, Func, ParamCount,\r\n ParamTypes, ResTyp, Data);\r\n for I := 0 to Source.FRecordSetList.Count - 1 do\r\n with TJvInterpreterRecMethod(Source.FRecordSetList[I]) do\r\n AddRecSetEx(UnitName, JvInterpreterRecord.Identifier, Identifier, Func, ParamCount,\r\n ParamTypes, Data);\r\n for I := 0 to Source.FExtFunctionList.Count - 1 do\r\n with TJvInterpreterExtFunction(Source.FExtFunctionList[I]) do\r\n AddExtFunEx(UnitName, Identifier, DllInstance, DllName, FunctionName, FunctionIndex,\r\n FunctionDesc.FParamCount, FunctionDesc.FParamTypes, FunctionDesc.FResTyp, Data);\r\n for I := 0 to Source.FEventHandlerList.Count - 1 do\r\n with TJvInterpreterEventDesc(Source.FEventHandlerList[I]) do\r\n AddHandlerEx(UnitName, Identifier, EventClass, Code, Data);\r\n for I := 0 to Source.FEventList.Count - 1 do\r\n with TJvInterpreterClass(Source.FEventList[I]) do\r\n AddEventEx(UnitName, FClassType, Identifier, Data);\r\n for I := 0 to Source.FOnGetList.Count - 1 do\r\n AddOnGet(TJvInterpreterGetValue(PMethod(Source.FOnGetList[I])^));\r\n for I := 0 to Source.FOnSetList.Count - 1 do\r\n AddOnSet(TJvInterpreterSetValue(PMethod(Source.FOnSetList[I])^));\r\nend;\r\n\r\nprocedure TJvInterpreterAdapter.AddSrcUnit(const Identifier, Source, UsesList: string);\r\nbegin\r\n AddSrcUnitEx(Identifier, Source, UsesList, nil);\r\nend;\r\n\r\n{ if unit with name 'Identifier' already exists its source will be replaced }\r\n\r\nprocedure TJvInterpreterAdapter.AddSrcUnitEx(const Identifier, Source, UsesList: string;\r\n Data: Pointer);\r\nvar\r\n JvInterpreterUnit: TJvInterpreterSrcUnit;\r\n S: string;\r\n I: Integer;\r\n JvInterpreterIdentifier: TJvInterpreterIdentifier;\r\nbegin\r\n JvInterpreterUnit := nil;\r\n for I := 0 to FSrcUnitList.Count - 1 do\r\n begin\r\n JvInterpreterIdentifier := TJvInterpreterIdentifier(FSrcUnitList.Items[I]);\r\n if Cmp(JvInterpreterIdentifier.Identifier, Identifier) then\r\n begin\r\n JvInterpreterUnit := TJvInterpreterSrcUnit(FSrcUnitList.Items[I]);\r\n Break;\r\n end;\r\n end;\r\n if JvInterpreterUnit = nil then\r\n begin\r\n JvInterpreterUnit := TJvInterpreterSrcUnit.Create;\r\n FSrcUnitList.Add(JvInterpreterUnit);\r\n end;\r\n\r\n if JvInterpreterUnit.FSource = '' then\r\n begin\r\n JvInterpreterUnit.Identifier := Identifier;\r\n JvInterpreterUnit.FSource := Source;\r\n JvInterpreterUnit.Data := Data;\r\n I := 0;\r\n S := Trim(SubStrBySeparator(UsesList, I, ','));\r\n while S <> '' do\r\n begin\r\n JvInterpreterUnit.FUsesList[I] := S;\r\n Inc(I);\r\n S := Trim(SubStrBySeparator(UsesList, I, ','));\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvInterpreterAdapter.AddExtUnit(const Identifier: string);\r\nbegin\r\n AddExtUnitEx(Identifier, nil);\r\nend;\r\n\r\nprocedure TJvInterpreterAdapter.AddExtUnitEx(const Identifier: string; Data: Pointer);\r\nvar\r\n JvInterpreterUnit: TJvInterpreterIdentifier;\r\nbegin\r\n JvInterpreterUnit := TJvInterpreterIdentifier.Create;\r\n JvInterpreterUnit.Identifier := Identifier;\r\n JvInterpreterUnit.Data := Data;\r\n FExtUnitList.Add(JvInterpreterUnit);\r\nend;\r\n\r\nprocedure TJvInterpreterAdapter.AddClass(const UnitName: string; AClassType: TClass;\r\n const Identifier: string);\r\nbegin\r\n AddClassEx(UnitName, AClassType, Identifier, nil);\r\nend;\r\n\r\nprocedure TJvInterpreterAdapter.AddClassEx(const UnitName: string; AClassType: TClass;\r\n const Identifier: string; Data: Pointer);\r\nvar\r\n JvInterpreterClass: TJvInterpreterClass;\r\nbegin\r\n JvInterpreterClass := TJvInterpreterClass.Create;\r\n JvInterpreterClass.FClassType := AClassType;\r\n JvInterpreterClass.Identifier := Identifier;\r\n JvInterpreterClass.Data := Data;\r\n JvInterpreterClass.UnitName := UnitName;\r\n FClassList.Add(JvInterpreterClass);\r\n FSorted := False;\r\nend;\r\n\r\nprocedure TJvInterpreterAdapter.AddGet(AClassType: TClass; const Identifier: string;\r\n GetFunc: TJvInterpreterAdapterGetValue; ParamCount: Integer; ParamTypes: array of Word;\r\n ResTyp: Word);\r\nbegin\r\n AddGetEx(AClassType, Identifier, GetFunc, ParamCount, ParamTypes, ResTyp, nil);\r\nend;\r\n\r\nprocedure TJvInterpreterAdapter.AddGetEx(AClassType: TClass; const Identifier: string;\r\n GetFunc: TJvInterpreterAdapterGetValue; ParamCount: Integer; ParamTypes: array of Word;\r\n ResTyp: Word; Data: Pointer);\r\nvar\r\n JvInterpreterMethod: TJvInterpreterMethod;\r\nbegin\r\n JvInterpreterMethod := TJvInterpreterMethod.Create;\r\n JvInterpreterMethod.FClassType := AClassType;\r\n JvInterpreterMethod.Identifier := Identifier;\r\n JvInterpreterMethod.Func := @GetFunc;\r\n JvInterpreterMethod.ParamCount := ParamCount;\r\n JvInterpreterMethod.ResTyp := ResTyp;\r\n JvInterpreterMethod.Data := Data;\r\n ConvertParamTypes(ParamTypes, JvInterpreterMethod.ParamTypes);\r\n FGetList.Add(JvInterpreterMethod);\r\n FSorted := False;\r\nend;\r\n\r\nprocedure TJvInterpreterAdapter.AddIGet(AClassType: TClass; const Identifier: string;\r\n GetFunc: TJvInterpreterAdapterGetValue; ParamCount: Integer; ParamTypes: array of Word;\r\n ResTyp: Word);\r\nbegin\r\n AddIGetEx(AClassType, Identifier, GetFunc, ParamCount, ParamTypes, ResTyp, nil);\r\nend;\r\n\r\nprocedure TJvInterpreterAdapter.AddIGetEx(AClassType: TClass; const Identifier: string;\r\n GetFunc: TJvInterpreterAdapterGetValue; ParamCount: Integer; ParamTypes: array of Word;\r\n ResTyp: Word; Data: Pointer);\r\nvar\r\n JvInterpreterMethod: TJvInterpreterMethod;\r\nbegin\r\n JvInterpreterMethod := TJvInterpreterMethod.Create;\r\n JvInterpreterMethod.FClassType := AClassType;\r\n JvInterpreterMethod.Identifier := Identifier;\r\n JvInterpreterMethod.Func := @GetFunc;\r\n JvInterpreterMethod.ParamCount := ParamCount;\r\n JvInterpreterMethod.ResTyp := ResTyp;\r\n JvInterpreterMethod.Data := Data;\r\n ConvertParamTypes(ParamTypes, JvInterpreterMethod.ParamTypes);\r\n FIGetList.Add(JvInterpreterMethod);\r\n FSorted := False;\r\nend;\r\n\r\nprocedure TJvInterpreterAdapter.AddIDGet(AClassType: TClass;\r\n GetFunc: TJvInterpreterAdapterGetValue; ParamCount: Integer; ParamTypes: array of Word;\r\n ResTyp: Word);\r\nbegin\r\n AddIDGetEx(AClassType, GetFunc, ParamCount, ParamTypes, ResTyp, nil);\r\nend;\r\n\r\nprocedure TJvInterpreterAdapter.AddIDGetEx(AClassType: TClass;\r\n GetFunc: TJvInterpreterAdapterGetValue; ParamCount: Integer; ParamTypes: array of Word;\r\n ResTyp: Word; Data: Pointer);\r\nvar\r\n JvInterpreterMethod: TJvInterpreterMethod;\r\nbegin\r\n JvInterpreterMethod := TJvInterpreterMethod.Create;\r\n JvInterpreterMethod.FClassType := AClassType;\r\n JvInterpreterMethod.Func := @GetFunc;\r\n JvInterpreterMethod.ParamCount := ParamCount;\r\n JvInterpreterMethod.ResTyp := ResTyp;\r\n JvInterpreterMethod.Data := Data;\r\n ConvertParamTypes(ParamTypes, JvInterpreterMethod.ParamTypes);\r\n FIDGetList.Add(JvInterpreterMethod);\r\nend;\r\n\r\nprocedure TJvInterpreterAdapter.AddIntfGet(IID: TGUID; const Identifier: string;\r\n GetFunc: TJvInterpreterAdapterGetValue; ParamCount: Integer;\r\n ParamTypes: array of Word; ResTyp: Word);\r\nbegin\r\n AddIntfGetEx(IID, Identifier, GetFunc, ParamCount, ParamTypes, ResTyp, nil);\r\nend;\r\n\r\nprocedure TJvInterpreterAdapter.AddIntfGetEx(IID: TGUID; const Identifier: string;\r\n GetFunc: TJvInterpreterAdapterGetValue; ParamCount: Integer;\r\n ParamTypes: array of Word; ResTyp: Word; Data: Pointer);\r\nvar\r\n JvInterpreterMethod: TJvInterpreterIntfMethod;\r\nbegin\r\n JvInterpreterMethod := TJvInterpreterIntfMethod.Create;\r\n JvInterpreterMethod.IID := IID;\r\n JvInterpreterMethod.Identifier := Identifier;\r\n JvInterpreterMethod.Func := @GetFunc;\r\n JvInterpreterMethod.ParamCount := ParamCount;\r\n JvInterpreterMethod.ResTyp := ResTyp;\r\n JvInterpreterMethod.Data := Data;\r\n ConvertParamTypes(ParamTypes, JvInterpreterMethod.ParamTypes);\r\n FIntfGetList.Add(JvInterpreterMethod);\r\n FSorted := False;\r\nend;\r\n\r\nprocedure TJvInterpreterAdapter.AddDGet(AClassType: TClass; const Identifier: string;\r\n GetFunc: Pointer; ParamCount: Integer; ParamTypes: array of Word;\r\n ResTyp: Word; CallConvention: TCallConvention);\r\nbegin\r\n AddDGetEx(AClassType, Identifier, GetFunc, ParamCount, ParamTypes, ResTyp,\r\n CallConvention, nil);\r\nend;\r\n\r\nprocedure TJvInterpreterAdapter.AddDGetEx(AClassType: TClass; const Identifier: string;\r\n GetFunc: Pointer; ParamCount: Integer; ParamTypes: array of Word;\r\n ResTyp: Word; CallConvention: TCallConvention; Data: Pointer);\r\nvar\r\n JvInterpreterMethod: TJvInterpreterDMethod;\r\nbegin\r\n JvInterpreterMethod := TJvInterpreterDMethod.Create;\r\n JvInterpreterMethod.FClassType := AClassType;\r\n JvInterpreterMethod.Identifier := Identifier;\r\n JvInterpreterMethod.Func := GetFunc;\r\n JvInterpreterMethod.ParamCount := ParamCount;\r\n JvInterpreterMethod.ResTyp := ResTyp;\r\n JvInterpreterMethod.Data := Data;\r\n ConvertParamTypes(ParamTypes, JvInterpreterMethod.ParamTypes);\r\n JvInterpreterMethod.CallConvention := CallConvention;\r\n FDirectGetList.Add(JvInterpreterMethod);\r\nend;\r\n\r\nprocedure TJvInterpreterAdapter.AddSet(AClassType: TClass; const Identifier: string;\r\n SetFunc: TJvInterpreterAdapterSetValue; ParamCount: Integer; ParamTypes: array of Word);\r\nbegin\r\n AddSetEx(AClassType, Identifier, SetFunc, ParamCount, ParamTypes, nil);\r\nend;\r\n\r\nprocedure TJvInterpreterAdapter.AddSetEx(AClassType: TClass; const Identifier: string;\r\n SetFunc: TJvInterpreterAdapterSetValue; ParamCount: Integer; ParamTypes: array of Word;\r\n Data: Pointer);\r\nvar\r\n JvInterpreterMethod: TJvInterpreterMethod;\r\nbegin\r\n JvInterpreterMethod := TJvInterpreterMethod.Create;\r\n JvInterpreterMethod.FClassType := AClassType;\r\n JvInterpreterMethod.Identifier := Identifier;\r\n JvInterpreterMethod.Func := @SetFunc;\r\n JvInterpreterMethod.ParamCount := ParamCount;\r\n JvInterpreterMethod.Data := Data;\r\n ConvertParamTypes(ParamTypes, JvInterpreterMethod.ParamTypes);\r\n FSetList.Add(JvInterpreterMethod);\r\n FSorted := False;\r\nend;\r\n\r\nprocedure TJvInterpreterAdapter.AddISet(AClassType: TClass; const Identifier: string;\r\n SetFunc: TJvInterpreterAdapterSetValue; ParamCount: Integer; ParamTypes: array of Word);\r\nbegin\r\n AddISetEx(AClassType, Identifier, SetFunc, ParamCount, ParamTypes, nil);\r\nend;\r\n\r\nprocedure TJvInterpreterAdapter.AddISetEx(AClassType: TClass; const Identifier: string;\r\n SetFunc: TJvInterpreterAdapterSetValue; ParamCount: Integer; ParamTypes: array of Word;\r\n Data: Pointer);\r\nvar\r\n JvInterpreterMethod: TJvInterpreterMethod;\r\nbegin\r\n JvInterpreterMethod := TJvInterpreterMethod.Create;\r\n JvInterpreterMethod.FClassType := AClassType;\r\n JvInterpreterMethod.Identifier := Identifier;\r\n JvInterpreterMethod.Func := @SetFunc;\r\n JvInterpreterMethod.ParamCount := ParamCount;\r\n JvInterpreterMethod.Data := Data;\r\n ConvertParamTypes(ParamTypes, JvInterpreterMethod.ParamTypes);\r\n FISetList.Add(JvInterpreterMethod);\r\n FSorted := False;\r\nend;\r\n\r\nprocedure TJvInterpreterAdapter.AddIDSet(AClassType: TClass;\r\n SetFunc: TJvInterpreterAdapterSetValue; ParamCount: Integer; ParamTypes: array of Word);\r\nbegin\r\n AddIDSetEx(AClassType, SetFunc, ParamCount, ParamTypes, nil);\r\nend;\r\n\r\nprocedure TJvInterpreterAdapter.AddIDSetEx(AClassType: TClass;\r\n SetFunc: TJvInterpreterAdapterSetValue; ParamCount: Integer; ParamTypes: array of Word;\r\n Data: Pointer);\r\nvar\r\n JvInterpreterMethod: TJvInterpreterMethod;\r\nbegin\r\n JvInterpreterMethod := TJvInterpreterMethod.Create;\r\n JvInterpreterMethod.FClassType := AClassType;\r\n JvInterpreterMethod.Func := @SetFunc;\r\n JvInterpreterMethod.ParamCount := ParamCount;\r\n JvInterpreterMethod.Data := Data;\r\n ConvertParamTypes(ParamTypes, JvInterpreterMethod.ParamTypes);\r\n FIDSetList.Add(JvInterpreterMethod);\r\nend;\r\n\r\nprocedure TJvInterpreterAdapter.AddFunction(const UnitName, Identifier: string;\r\n GetFunc: TJvInterpreterAdapterGetValue; ParamCount: Integer; ParamTypes: array of Word;\r\n ResTyp: Word);\r\nbegin\r\n AddFunctionEx(UnitName, Identifier, GetFunc, ParamCount, ParamTypes, ResTyp, nil);\r\nend;\r\n\r\nprocedure TJvInterpreterAdapter.AddFunctionEx(const UnitName, Identifier: string;\r\n GetFunc: TJvInterpreterAdapterGetValue; ParamCount: Integer; ParamTypes: array of Word;\r\n ResTyp: Word; Data: Pointer);\r\nvar\r\n JvInterpreterMethod: TJvInterpreterMethod;\r\nbegin\r\n JvInterpreterMethod := TJvInterpreterMethod.Create;\r\n JvInterpreterMethod.Identifier := Identifier;\r\n JvInterpreterMethod.Func := @GetFunc;\r\n JvInterpreterMethod.ParamCount := ParamCount;\r\n JvInterpreterMethod.ResTyp := ResTyp;\r\n JvInterpreterMethod.Data := Data;\r\n ConvertParamTypes(ParamTypes, JvInterpreterMethod.ParamTypes);\r\n JvInterpreterMethod.UnitName := UnitName;\r\n FFunctionList.Add(JvInterpreterMethod);\r\n FSorted := False;\r\nend;\r\n\r\nprocedure TJvInterpreterAdapter.AddRec(const UnitName, Identifier: string;\r\n RecordSize: Integer; Fields: array of TJvInterpreterRecField;\r\n CreateFunc: TJvInterpreterAdapterNewRecord;\r\n DestroyFunc: TJvInterpreterAdapterDisposeRecord;\r\n CopyFunc: TJvInterpreterAdapterCopyRecord);\r\nbegin\r\n AddRecEx(UnitName, Identifier, RecordSize, Fields, CreateFunc, DestroyFunc, CopyFunc, nil);\r\nend;\r\n\r\nprocedure TJvInterpreterAdapter.AddRecEx(const UnitName, Identifier: string;\r\n RecordSize: Integer; Fields: array of TJvInterpreterRecField;\r\n CreateFunc: TJvInterpreterAdapterNewRecord;\r\n DestroyFunc: TJvInterpreterAdapterDisposeRecord;\r\n CopyFunc: TJvInterpreterAdapterCopyRecord;\r\n Data: Pointer);\r\nvar\r\n JvInterpreterRecord: TJvInterpreterRecord;\r\n I: Integer;\r\nbegin\r\n JvInterpreterRecord := TJvInterpreterRecord.Create;\r\n JvInterpreterRecord.Identifier := Identifier;\r\n JvInterpreterRecord.RecordSize := RecordSize;\r\n JvInterpreterRecord.CreateFunc := CreateFunc;\r\n JvInterpreterRecord.DestroyFunc := DestroyFunc;\r\n JvInterpreterRecord.CopyFunc := CopyFunc;\r\n JvInterpreterRecord.Data := Data;\r\n for I := Low(Fields) to High(Fields) do\r\n begin\r\n JvInterpreterRecord.Fields[I] := Fields[I];\r\n JvInterpreterRecord.Fields[I].DataType := nil;\r\n end;\r\n JvInterpreterRecord.FieldCount := High(Fields) - Low(Fields) + 1;\r\n JvInterpreterRecord.UnitName := UnitName;\r\n FRecordList.Add(JvInterpreterRecord);\r\nend;\r\n\r\nprocedure TJvInterpreterAdapter.AddRecGet(const UnitName, RecordType, Identifier: string;\r\n GetFunc: TJvInterpreterAdapterGetValue; ParamCount: Integer;\r\n ParamTypes: array of Word; ResTyp: Word);\r\nbegin\r\n AddRecGetEx(UnitName, RecordType, Identifier, GetFunc, ParamCount,\r\n ParamTypes, ResTyp, nil);\r\nend;\r\n\r\nprocedure TJvInterpreterAdapter.AddRecGetEx(const UnitName, RecordType, Identifier: string;\r\n GetFunc: TJvInterpreterAdapterGetValue; ParamCount: Integer;\r\n ParamTypes: array of Word; ResTyp: Word; Data: Pointer);\r\nvar\r\n RecMethod: TJvInterpreterRecMethod;\r\nbegin\r\n RecMethod := TJvInterpreterRecMethod.Create;\r\n RecMethod.JvInterpreterRecord := GetRec(RecordType) as TJvInterpreterRecord;\r\n RecMethod.Identifier := Identifier;\r\n RecMethod.Func := @GetFunc;\r\n RecMethod.ParamCount := ParamCount;\r\n RecMethod.ResTyp := ResTyp;\r\n RecMethod.Data := Data;\r\n ConvertParamTypes(ParamTypes, RecMethod.ParamTypes);\r\n RecMethod.UnitName := UnitName;\r\n FRecordGetList.Add(RecMethod);\r\nend;\r\n\r\nprocedure TJvInterpreterAdapter.AddRecSet(const UnitName, RecordType, Identifier: string;\r\n SetFunc: TJvInterpreterAdapterSetValue; ParamCount: Integer; ParamTypes: array of Word);\r\nbegin\r\n AddRecSetEx(UnitName, RecordType, Identifier, SetFunc,\r\n ParamCount, ParamTypes, nil);\r\nend;\r\n\r\nprocedure TJvInterpreterAdapter.AddRecSetEx(const UnitName, RecordType, Identifier: string;\r\n SetFunc: TJvInterpreterAdapterSetValue; ParamCount: Integer;\r\n ParamTypes: array of Word; Data: Pointer);\r\nvar\r\n RecMethod: TJvInterpreterRecMethod;\r\nbegin\r\n RecMethod := TJvInterpreterRecMethod.Create;\r\n RecMethod.JvInterpreterRecord := GetRec(RecordType) as TJvInterpreterRecord;\r\n RecMethod.Identifier := Identifier;\r\n RecMethod.Func := @SetFunc;\r\n RecMethod.ParamCount := ParamCount;\r\n RecMethod.Data := Data;\r\n ConvertParamTypes(ParamTypes, RecMethod.ParamTypes);\r\n RecMethod.UnitName := UnitName;\r\n FRecordSetList.Add(RecMethod);\r\nend;\r\n\r\nprocedure TJvInterpreterAdapter.AddConst(const UnitName, Identifier: string;\r\n Value: Variant);\r\nbegin\r\n AddConstEx(UnitName, Identifier, Value, nil);\r\nend;\r\n\r\nprocedure TJvInterpreterAdapter.AddConstEx(const AUnitName, AIdentifier: string;\r\n AValue: Variant; AData: Pointer);\r\nvar\r\n JvInterpreterConst: TJvInterpreterConst;\r\nbegin\r\n JvInterpreterConst := TJvInterpreterConst.Create;\r\n JvInterpreterConst.Identifier := AIdentifier;\r\n JvInterpreterConst.Value := AValue;\r\n JvInterpreterConst.Data := AData;\r\n JvInterpreterConst.UnitName := AUnitName;\r\n FConstList.Add(JvInterpreterConst);\r\n FSorted := False;\r\nend;\r\n\r\nprocedure TJvInterpreterAdapter.AddExtFun(const UnitName, Identifier: string;\r\n DllInstance: HINST; const DllName, FunctionName: string; FunctionIndex: Integer;\r\n ParamCount: Integer; ParamTypes: array of Word; ResTyp: Word);\r\nbegin\r\n AddExtFunEx(UnitName, Identifier, DllInstance, DllName, FunctionName, FunctionIndex,\r\n ParamCount, ParamTypes, ResTyp, nil);\r\nend;\r\n\r\nprocedure TJvInterpreterAdapter.AddExtFunEx(const AUnitName, AIdentifier: string;\r\n ADllInstance: HINST; const ADllName, AFunctionName: string; AFunIndex: Integer;\r\n AParamCount: Integer; AParamTypes: array of Word; AResTyp: Word; AData: Pointer);\r\nvar\r\n JvInterpreterExtFun: TJvInterpreterExtFunction;\r\nbegin\r\n JvInterpreterExtFun := TJvInterpreterExtFunction.Create;\r\n with JvInterpreterExtFun do\r\n begin\r\n FunctionDesc.FUnitName := AUnitName;\r\n Identifier := AIdentifier;\r\n DllInstance := ADllInstance;\r\n DllName := ADllName;\r\n FunctionName := AFunctionName;\r\n FunctionIndex := AFunIndex;\r\n FunctionDesc.FParamCount := AParamCount;\r\n FunctionDesc.FResTyp := AResTyp;\r\n Data := AData;\r\n ConvertParamTypes(AParamTypes, FunctionDesc.FParamTypes);\r\n end;\r\n JvInterpreterExtFun.UnitName := AUnitName;\r\n FExtFunctionList.Add(JvInterpreterExtFun);\r\nend;\r\n\r\nprocedure TJvInterpreterAdapter.AddSrcFun(const UnitName, Identifier: string;\r\n ClassIdentifier: string;\r\n PosBeg, PosEnd: Integer; ParamCount: Integer; ParamTypes: array of Word;\r\n ParamTypeNames: array of string;\r\n ParamNames: array of string; ResTyp: Word; const AResTypName: string;\r\n AResDataType: IJvInterpreterDataType;\r\n Data: Pointer);\r\nbegin\r\n AddSrcFunEx(UnitName, Identifier, ClassIdentifier, PosBeg, PosEnd, ParamCount, ParamTypes,\r\n ParamTypeNames,\r\n ParamNames, ResTyp, AResTypName, AResDataType, nil);\r\nend;\r\n\r\nprocedure TJvInterpreterAdapter.AddSrcFunEx(const AUnitName, AIdentifier: string;\r\n AClassIdentifier: string;\r\n APosBeg, APosEnd: Integer; AParamCount: Integer; AParamTypes: array of Word;\r\n AParamTypeNames: array of string;\r\n AParamNames: array of string; AResTyp: Word; const AResTypName: string;\r\n AResDataType: IJvInterpreterDataType;\r\n AData: Pointer);\r\nvar\r\n JvInterpreterSrcFun: TJvInterpreterSrcFunction;\r\nbegin\r\n JvInterpreterSrcFun := TJvInterpreterSrcFunction.Create;\r\n with JvInterpreterSrcFun do\r\n begin\r\n FunctionDesc.FUnitName := AUnitName;\r\n FunctionDesc.FIdentifier := AIdentifier;\r\n FunctionDesc.FPosBeg := APosBeg;\r\n FunctionDesc.FPosEnd := APosEnd;\r\n FunctionDesc.FParamCount := AParamCount;\r\n FunctionDesc.FResTyp := AResTyp;\r\n FunctionDesc.FResTypName := AResTypName;\r\n FunctionDesc.FResDataType := AResDataType;\r\n FunctionDesc.FClassIdentifier := AClassIdentifier; // class method support\r\n Identifier := AIdentifier;\r\n Data := AData;\r\n ConvertParamTypes(AParamTypes, FunctionDesc.FParamTypes);\r\n ConvertParamNames(AParamNames, FunctionDesc.FParamNames);\r\n ConvertParamNames(AParamTypeNames, FunctionDesc.FParamTypeNames);\r\n FunctionDesc.FResTyp := AResTyp;\r\n end;\r\n JvInterpreterSrcFun.UnitName := AUnitName; // Code Insight\r\n FSrcFunctionList.Add(JvInterpreterSrcFun);\r\nend;\r\n\r\nprocedure TJvInterpreterAdapter.AddHandler(const UnitName, Identifier: string;\r\n EventClass: TJvInterpreterEventClass; Code: Pointer);\r\nbegin\r\n AddHandlerEx(UnitName, Identifier, EventClass, Code, nil);\r\nend;\r\n\r\nprocedure TJvInterpreterAdapter.AddHandlerEx(const AUnitName, AIdentifier: string;\r\n AEventClass: TJvInterpreterEventClass; ACode: Pointer; AData: Pointer);\r\nvar\r\n JvInterpreterEventDesc: TJvInterpreterEventDesc;\r\nbegin\r\n JvInterpreterEventDesc := TJvInterpreterEventDesc.Create;\r\n with JvInterpreterEventDesc do\r\n begin\r\n UnitName := AUnitName;\r\n Identifier := AIdentifier;\r\n EventClass := AEventClass;\r\n Code := ACode;\r\n Data := AData;\r\n end;\r\n FEventHandlerList.Add(JvInterpreterEventDesc);\r\nend;\r\n\r\nprocedure TJvInterpreterAdapter.AddEvent(const UnitName: string; AClassType: TClass;\r\n const Identifier: string);\r\nbegin\r\n AddEventEx(UnitName, AClassType, Identifier, nil);\r\nend;\r\n\r\nprocedure TJvInterpreterAdapter.AddEventEx(const AUnitName: string; AClassType: TClass;\r\n const AIdentifier: string; AData: Pointer);\r\nvar\r\n JvInterpreterEvent: TJvInterpreterClass;\r\nbegin\r\n JvInterpreterEvent := TJvInterpreterClass.Create;\r\n with JvInterpreterEvent do\r\n begin\r\n UnitName := AUnitName;\r\n Identifier := AIdentifier;\r\n FClassType := AClassType;\r\n Data := AData;\r\n end;\r\n FEventList.Add(JvInterpreterEvent);\r\nend;\r\n\r\nprocedure TJvInterpreterAdapter.AddSrcVar(const UnitName, Identifier, Typ: string;\r\n VTyp: Word; const Value: Variant; DataType: IJvInterpreterDataType);\r\nbegin\r\n FSrcVarList.AddVar(UnitName, Identifier, Typ, VTyp, Value, DataType);\r\nend;\r\n\r\nprocedure TJvInterpreterAdapter.AddSrcClass(JvInterpreterSrcClass: TJvInterpreterIdentifier);\r\nbegin\r\n FSrcClassList.Add(JvInterpreterSrcClass);\r\nend;\r\n\r\nfunction TJvInterpreterAdapter.GetSrcClass(const Identifier: string): TJvInterpreterIdentifier;\r\nbegin\r\n Result := FSrcClassList.IndexOf('', Identifier);\r\nend;\r\n\r\nprocedure TJvInterpreterAdapter.AddOnGet(Method: TJvInterpreterGetValue);\r\nvar\r\n PM: PMethod;\r\nbegin\r\n New(PM);\r\n PM^ := TMethod(Method);\r\n FOnGetList.Add(PM);\r\nend;\r\n\r\nprocedure TJvInterpreterAdapter.AddOnSet(Method: TJvInterpreterSetValue);\r\nvar\r\n PM: PMethod;\r\nbegin\r\n New(PM);\r\n PM^ := TMethod(Method);\r\n FOnSetList.Add(PM);\r\nend;\r\n\r\nfunction TJvInterpreterAdapter.GetRec(const RecordType: string): TObject;\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := 0 to FRecordList.Count - 1 do\r\n begin\r\n Result := FRecordList[I];\r\n if Cmp(TJvInterpreterRecord(Result).Identifier, RecordType) then\r\n Exit;\r\n end;\r\n Result := nil;\r\nend;\r\n\r\nprocedure TJvInterpreterAdapter.CheckArgs(var Args: TJvInterpreterArgs; ParamCount: Integer;\r\n var ParamTypes: TTypeArray);\r\nvar\r\n I: Integer;\r\nbegin\r\n if ParamCount = prArgsNoCheck then\r\n Exit;\r\n if Args.Count > ParamCount then\r\n JvInterpreterError(ieTooManyParams, -1);\r\n if Args.Count < ParamCount then\r\n JvInterpreterError(ieNotEnoughParams, -1);\r\n\r\n Args.FHasVars := False;\r\n Args.Types := ParamTypes;\r\n for I := 0 to Args.Count - 1 do\r\n if (Args.FVarNames[I] <> '') and ((ParamTypes[I] and varByRef) <> 0) then\r\n begin\r\n Args.FHasVars := True;\r\n Break;\r\n end;\r\nend;\r\n\r\nprocedure TJvInterpreterAdapter.CheckAction(Expression: TJvInterpreterExpression;\r\n Args: TJvInterpreterArgs; Data: Pointer);\r\nbegin\r\n // abstract\r\nend;\r\n\r\nfunction TJvInterpreterAdapter.FindFunDesc(const UnitName: string;\r\n const Identifier: string;\r\n const ClassIdentifier:string=''): TJvInterpreterFunctionDesc;\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := FSrcFunctionList.Count - 1 downto 0 do\r\n begin\r\n Result := TJvInterpreterSrcFunction(FSrcFunctionList.Items[I]).FunctionDesc;\r\n if Cmp(Result.Identifier, Identifier) and\r\n (Cmp(Result.ClassIdentifier, ClassIdentifier) or (ClassIdentifier='')) and // Class methods support\r\n (Cmp(Result.UnitName, UnitName) or (UnitName = '')) then\r\n Exit;\r\n end;\r\n if (UnitName <> '') and (ClassIdentifier='') then // Class methods support\r\n Result := FindFunDesc('', Identifier)\r\n else\r\n Result := nil;\r\nend;\r\n\r\nfunction TJvInterpreterAdapter.GetValue(Expression: TJvInterpreterExpression; const Identifier: string;\r\n var Value: Variant; Args: TJvInterpreterArgs): Boolean;\r\nvar\r\n I: Integer;\r\n\r\n function GetMethod: Boolean;\r\n var\r\n I: Integer;\r\n JvInterpreterMethod: TJvInterpreterMethod;\r\n begin\r\n Result := GetValueRTTI(Identifier, Value, Args);\r\n if Result then\r\n Exit;\r\n\r\n if FGetList.Find(Identifier, i) then\r\n for I := I to FGetList.Count - 1 do\r\n begin\r\n JvInterpreterMethod := TJvInterpreterMethod(FGetList[I]);\r\n if not Cmp(JvInterpreterMethod.Identifier, Identifier) then\r\n Break;\r\n if Assigned(JvInterpreterMethod.Func) and\r\n (((Args.ObjTyp = varObject) and\r\n (Args.Obj is JvInterpreterMethod.FClassType)) or\r\n ((Args.ObjTyp = varClass) and\r\n (TClass(Args.Obj) = JvInterpreterMethod.FClassType))) {?!} then\r\n begin\r\n Args.Identifier := Identifier;\r\n CheckAction(Expression, Args, JvInterpreterMethod.Data);\r\n CheckArgs(Args, JvInterpreterMethod.ParamCount, JvInterpreterMethod.ParamTypes);\r\n TJvInterpreterAdapterGetValue(JvInterpreterMethod.Func)(Value, Args);\r\n Result := True;\r\n Exit;\r\n end;\r\n end;\r\n if Cmp(Identifier, 'Free') then\r\n begin\r\n Result := True;\r\n Args.Obj.Free;\r\n Args.Obj := nil;\r\n Value := Null;\r\n Exit;\r\n end;\r\n end;\r\n\r\n function IntfGetMethod: Boolean;\r\n var\r\n I: Integer;\r\n JvInterpreterMethod: TJvInterpreterIntfMethod;\r\n Intf: IUnknown;\r\n begin\r\n Result := False;\r\n if FIntfGetList.Find(Identifier, I) then\r\n for I := I to FIntfGetList.Count - 1 do\r\n begin\r\n JvInterpreterMethod := TJvInterpreterIntfMethod(FIntfGetList[I]);\r\n if not Cmp(JvInterpreterMethod.Identifier, Identifier) then\r\n Break;\r\n if Assigned(JvInterpreterMethod.Func) and\r\n ((Args.ObjTyp = varUnknown) and\r\n (IUnknown(Pointer(Args.Obj)).QueryInterface(JvInterpreterMethod.IID, Intf) = S_OK)) then\r\n begin\r\n Args.Identifier := Identifier;\r\n CheckAction(Expression, Args, JvInterpreterMethod.Data);\r\n CheckArgs(Args, JvInterpreterMethod.ParamCount,\r\n JvInterpreterMethod.ParamTypes);\r\n TJvInterpreterAdapterGetValue(JvInterpreterMethod.Func)(Value, Args);\r\n Result := True;\r\n Exit;\r\n end;\r\n end;\r\n end;\r\n\r\n function IGetMethod: Boolean;\r\n var\r\n I: Integer;\r\n JvInterpreterMethod: TJvInterpreterMethod;\r\n begin\r\n if FIGetList.Find(Identifier, I) then\r\n for I := I to FIGetList.Count - 1 do\r\n begin\r\n JvInterpreterMethod := TJvInterpreterMethod(FIGetList[I]);\r\n if not Cmp(JvInterpreterMethod.Identifier, Identifier) then\r\n Break;\r\n if Assigned(JvInterpreterMethod.Func) and\r\n (((Args.ObjTyp = varObject) and\r\n (Args.Obj is JvInterpreterMethod.FClassType)) or\r\n ((Args.ObjTyp = varClass) and\r\n (TClass(Args.Obj) = JvInterpreterMethod.FClassType))) {?!} then\r\n begin\r\n Args.Identifier := Identifier;\r\n CheckAction(Expression, Args, JvInterpreterMethod.Data);\r\n CheckArgs(Args, JvInterpreterMethod.ParamCount, JvInterpreterMethod.ParamTypes);\r\n TJvInterpreterAdapterGetValue(JvInterpreterMethod.Func)(Value, Args);\r\n Result := True;\r\n Args.ReturnIndexed := True;\r\n Exit;\r\n end;\r\n end;\r\n Result := False;\r\n end;\r\n\r\n { function DGetMethod is under construction }\r\n\r\n function DGetMethod: Boolean;\r\n var\r\n JvInterpreterMethod: TJvInterpreterDMethod;\r\n I, J: Integer;\r\n AInt: Integer;\r\n AWord: Word;\r\n iRes: Integer;\r\n Func: Pointer;\r\n {$IFNDEF CPU64}\r\n RegEAX, RegEDX, RegECX: Integer;\r\n {$ELSE}\r\n Params: TArray;\r\n {$ENDIF ~CPU64}\r\n begin\r\n Result := False;\r\n {$IFNDEF CPU64}\r\n iRes := 0;\r\n {$ENDIF ~CPU64}\r\n for I := 0 to FDirectGetList.Count - 1 do\r\n begin\r\n JvInterpreterMethod := TJvInterpreterDMethod(FDirectGetList[I]);\r\n Func := JvInterpreterMethod.Func;\r\n if Assigned(JvInterpreterMethod.Func) and\r\n (((Args.ObjTyp = varObject) and\r\n (Args.Obj is JvInterpreterMethod.FClassType)) { or\r\n ((Args.ObjTyp = varClass) and\r\n (TClass(Args.Obj) = JvInterpreterMethod.FClassType))}) and\r\n Cmp(JvInterpreterMethod.Identifier, Identifier) then\r\n begin\r\n Args.Identifier := Identifier;\r\n CheckAction(Expression, Args, JvInterpreterMethod.Data);\r\n CheckArgs(Args, JvInterpreterMethod.ParamCount, JvInterpreterMethod.ParamTypes);\r\n {$IFNDEF CPU64}\r\n if ccFastCall in JvInterpreterMethod.CallConvention then\r\n begin\r\n { !!! Delphi fast-call !!! }\r\n { push parameters to stack }\r\n for J := 2 to JvInterpreterMethod.ParamCount - 1 do\r\n if (JvInterpreterMethod.ParamTypes[J] = varInteger) or\r\n (JvInterpreterMethod.ParamTypes[J] = varObject) or\r\n (JvInterpreterMethod.ParamTypes[J] = varPointer) or\r\n (JvInterpreterMethod.ParamTypes[J] = varBoolean) {?} then\r\n begin\r\n AInt := Args.Values[J];\r\n asm\r\n push AInt\r\n end;\r\n end\r\n else\r\n if JvInterpreterMethod.ParamTypes[J] = varSmallint then\r\n begin\r\n AWord := Word(Args.Values[J]);\r\n asm\r\n push AWord\r\n end;\r\n end\r\n else\r\n JvInterpreterErrorN(ieDirectInvalidArgument, -1, Identifier);\r\n\r\n RegEAX := Integer(Args.Obj);\r\n if JvInterpreterMethod.ParamCount > 0 then\r\n if (JvInterpreterMethod.ParamTypes[0] = varInteger) or\r\n (JvInterpreterMethod.ParamTypes[0] = varObject) or\r\n (JvInterpreterMethod.ParamTypes[0] = varPointer) or\r\n (JvInterpreterMethod.ParamTypes[0] = varBoolean) or\r\n (JvInterpreterMethod.ParamTypes[0] = varSmallint) or\r\n (JvInterpreterMethod.ParamTypes[0] = varString) then\r\n RegEDX := TVarData(Args.Values[0]).VInteger\r\n else\r\n JvInterpreterErrorN(ieDirectInvalidArgument, -1, Identifier);\r\n\r\n if JvInterpreterMethod.ParamCount > 1 then\r\n if (JvInterpreterMethod.ParamTypes[1] = varInteger) or\r\n (JvInterpreterMethod.ParamTypes[1] = varObject) or\r\n (JvInterpreterMethod.ParamTypes[1] = varPointer) or\r\n (JvInterpreterMethod.ParamTypes[1] = varBoolean) or\r\n (JvInterpreterMethod.ParamTypes[1] = varSmallint) or\r\n (JvInterpreterMethod.ParamTypes[1] = varString) then\r\n RegECX := TVarData(Args.Values[1]).VInteger\r\n else\r\n JvInterpreterErrorN(ieDirectInvalidArgument, -1, Identifier);\r\n\r\n if (JvInterpreterMethod.ResTyp = varSmallint) or\r\n (JvInterpreterMethod.ResTyp = varInteger) or\r\n (JvInterpreterMethod.ResTyp = varBoolean) or\r\n (JvInterpreterMethod.ResTyp = varEmpty) or\r\n (JvInterpreterMethod.ResTyp = varObject) or\r\n (JvInterpreterMethod.ResTyp = varPointer) then\r\n asm\r\n mov EAX, RegEAX\r\n mov EDX, RegEDX\r\n mov ECX, RegECX\r\n call Func\r\n mov iRes, EAX\r\n end\r\n else\r\n JvInterpreterErrorN(ieDirectInvalidResult, -1, Identifier);\r\n {$ELSE}\r\n SetLength(Params, 1 + JvInterpreterMethod.ParamCount);\r\n Params[0] := TValue.From(Args.Obj);\r\n for J := 0 to JvInterpreterMethod.ParamCount - 1 do\r\n begin\r\n if (JvInterpreterMethod.ParamTypes[J] = varInteger) or\r\n (JvInterpreterMethod.ParamTypes[J] = varBoolean) {?} then\r\n begin\r\n AInt := Args.Values[J];\r\n Params[1 + J] := TValue.From(AInt);\r\n end\r\n else if JvInterpreterMethod.ParamTypes[J] = varSmallint then\r\n begin\r\n AWord := Word(Args.Values[J]);\r\n Params[1 + J] := TValue.From(AWord);\r\n end\r\n else if (JvInterpreterMethod.ParamTypes[J] = varObject) or\r\n (JvInterpreterMethod.ParamTypes[J] = varString) or\r\n (JvInterpreterMethod.ParamTypes[J] = varPointer) then\r\n begin\r\n Params[1 + J] := TValue.From(TVarData(Args.Values[J]).VPointer);\r\n end\r\n else\r\n JvInterpreterErrorN(ieDirectInvalidArgument, -1, Identifier);\r\n end;\r\n iRes := System.Rtti.Invoke(Func, Params, System.TypInfo.TCallConv.ccReg, TypeInfo(Integer), False).AsType();\r\n {$ENDIF ~CPU64}\r\n\r\n { clear result }\r\n if (JvInterpreterMethod.ResTyp = varInteger) or\r\n (JvInterpreterMethod.ResTyp = varObject) then\r\n Value := iRes\r\n else\r\n if JvInterpreterMethod.ResTyp = varSmallint then\r\n Value := iRes and $0000FFFF\r\n else\r\n if JvInterpreterMethod.ResTyp = varBoolean then\r\n begin\r\n Value := iRes and $000000FF;\r\n TVarData(Value).VType := varBoolean;\r\n end\r\n else\r\n if JvInterpreterMethod.ResTyp = varEmpty then\r\n Value := Null;\r\n {$IFNDEF CPU64}\r\n end\r\n else\r\n JvInterpreterErrorN(ieDirectInvalidConvention, -1, Identifier);\r\n {$ENDIF ~CPU64}\r\n Result := True;\r\n Exit;\r\n end;\r\n end;\r\n end;\r\n\r\n function GetRecord: Boolean;\r\n var\r\n I: Integer;\r\n JvInterpreterRecord: TJvInterpreterRecord;\r\n Rec: PAnsiChar;\r\n JvInterpreterRecMethod: TJvInterpreterRecMethod;\r\n begin\r\n Result := False;\r\n JvInterpreterRecord := (Args.Obj as TJvInterpreterRecHolder).JvInterpreterRecord;\r\n for I := 0 to JvInterpreterRecord.FieldCount - 1 do\r\n if Cmp(JvInterpreterRecord.Fields[I].Identifier, Identifier) then\r\n begin\r\n Rec := P2R(Args.Obj);\r\n with JvInterpreterRecord.Fields[I] do\r\n case Typ of\r\n varSmallint:\r\n Value := Smallint(PWord(Rec + Offset)^);\r\n varInteger:\r\n Value := PInteger(Rec + Offset)^;\r\n varSingle:\r\n Value := PSingle(Rec + Offset)^;\r\n varDouble:\r\n Value := PDouble(Rec + Offset)^;\r\n varCurrency:\r\n Value := PCurrency(Rec + Offset)^;\r\n varDate:\r\n Value := PDateTime(Rec + Offset)^;\r\n varOleStr:\r\n Value := PWideString(Rec + Offset)^;\r\n varBoolean:\r\n Value := PBool(Rec + Offset)^;\r\n varVariant:\r\n Value := PVariant(Rec + Offset)^;\r\n varString:\r\n Value := PString(Rec + Offset)^;\r\n varEmpty:\r\n JvInterpreterVarCopy(Value, Variant(PVarData(Rec + Offset)^));\r\n end;\r\n Result := True;\r\n Exit;\r\n end;\r\n for I := 0 to FRecordGetList.Count - 1 do\r\n begin\r\n JvInterpreterRecMethod := TJvInterpreterRecMethod(FRecordGetList[I]);\r\n if (JvInterpreterRecMethod.JvInterpreterRecord = JvInterpreterRecord) and\r\n Cmp(JvInterpreterRecMethod.Identifier, Identifier) then\r\n begin\r\n Args.Identifier := Identifier;\r\n CheckArgs(Args, JvInterpreterRecMethod.ParamCount, JvInterpreterRecMethod.ParamTypes);\r\n TJvInterpreterAdapterGetValue(JvInterpreterRecMethod.Func)(Value, Args);\r\n Result := True;\r\n Exit;\r\n end;\r\n end\r\n end;\r\n\r\n function GetConst: Boolean;\r\n var\r\n I: Integer;\r\n JvInterpreterConst: TJvInterpreterConst;\r\n begin\r\n if Cmp(Identifier, kwNIL) then\r\n begin\r\n Value := P2V(nil);\r\n Result := True;\r\n Exit;\r\n end;\r\n if Cmp(Identifier, 'Null') then\r\n begin\r\n Value := Null;\r\n Result := True;\r\n Exit;\r\n end;\r\n Result := FConstList.Find(Identifier, I);\r\n if Result then\r\n begin\r\n JvInterpreterConst := TJvInterpreterConst(FConstList[I]);\r\n CheckAction(Expression, Args, JvInterpreterConst.Data);\r\n Value := JvInterpreterConst.Value;\r\n end;\r\n end;\r\n\r\n function GetClass: Boolean;\r\n var\r\n I: Integer;\r\n JvInterpreterClass: TJvInterpreterClass;\r\n begin\r\n Result := FClassList.Find(Identifier, I);\r\n if Result then\r\n begin\r\n JvInterpreterClass := TJvInterpreterClass(FClassList[I]);\r\n if Args.Count = 0 then\r\n Value := C2V(JvInterpreterClass.FClassType)\r\n else\r\n if Args.Count = 1 then\r\n { typecasting }\r\n begin\r\n CheckAction(Expression, Args, JvInterpreterClass.Data);\r\n Value := Args.Values[0];\r\n if TVarData(Value).VType <> varClass then\r\n TVarData(Value).VType := varObject;\r\n end\r\n else\r\n JvInterpreterError(ieTooManyParams, -1);\r\n end;\r\n end;\r\n\r\n function GetFun: Boolean;\r\n var\r\n I: Integer;\r\n JvInterpreterMethod: TJvInterpreterMethod;\r\n begin\r\n Result := FFunctionList.Find(Identifier, I);\r\n if Result then\r\n begin\r\n JvInterpreterMethod := TJvInterpreterMethod(FFunctionList[I]);\r\n if Cmp(JvInterpreterMethod.Identifier, Identifier) then\r\n begin\r\n Args.Identifier := Identifier;\r\n CheckAction(Expression, Args, JvInterpreterMethod.Data);\r\n CheckArgs(Args, JvInterpreterMethod.ParamCount, JvInterpreterMethod.ParamTypes);\r\n TJvInterpreterAdapterGetValue(JvInterpreterMethod.Func)(Value, Args);\r\n end;\r\n end;\r\n end;\r\n\r\n function GetExtFun: Boolean;\r\n var\r\n I: Integer;\r\n JvInterpreterExtFun: TJvInterpreterExtFunction;\r\n begin\r\n if DisableExternalFunctions then\r\n begin\r\n Result := False;\r\n Exit;\r\n end;\r\n for I := 0 to FExtFunctionList.Count - 1 do\r\n begin\r\n JvInterpreterExtFun := TJvInterpreterExtFunction(FExtFunctionList[I]);\r\n if Cmp(JvInterpreterExtFun.Identifier, Identifier) then\r\n begin\r\n Args.Identifier := Identifier;\r\n CheckAction(Expression, Args, JvInterpreterExtFun.Data);\r\n CheckArgs(Args, JvInterpreterExtFun.FunctionDesc.ParamCount,\r\n JvInterpreterExtFun.FunctionDesc.FParamTypes);\r\n Value := JvInterpreterExtFun.CallDll(Args);\r\n Result := True;\r\n Exit;\r\n end;\r\n end;\r\n Result := False;\r\n end;\r\n\r\n function GetSrcVar: Boolean;\r\n begin\r\n Result := FSrcVarList.GetValue(Identifier, Value, Args);\r\n end;\r\n\r\n function GetSrcUnit: Boolean;\r\n var\r\n I: Integer;\r\n JvInterpreterSrcUnit: TJvInterpreterSrcUnit;\r\n FParams: TTypeArray;\r\n begin\r\n for I := 0 to FSrcUnitList.Count - 1 do\r\n begin\r\n JvInterpreterSrcUnit := TJvInterpreterSrcUnit(FSrcUnitList[I]);\r\n if Cmp(JvInterpreterSrcUnit.Identifier, Identifier) then\r\n begin\r\n CheckArgs(Args, 0, FParams);\r\n Value := O2V(JvInterpreterSrcUnit);\r\n Result := True;\r\n Exit;\r\n end;\r\n end;\r\n Result := False;\r\n end;\r\n\r\n {$IFDEF JvInterpreter_OLEAUTO}\r\n function GetOleAutoFun: Boolean;\r\n var\r\n FParams: TTypeArray;\r\n begin\r\n Result := False;\r\n if Cmp(Identifier, 'CreateOleObject') or\r\n Cmp(Identifier, 'GetActiveOleObject') or\r\n Cmp(Identifier, 'GetOleObject') then\r\n begin\r\n FParams[0] := varString;\r\n CheckArgs(Args, 1, FParams);\r\n if Cmp(Identifier, 'CreateOleObject') then\r\n Value := CreateOleObject(Args.Values[0])\r\n else\r\n if Cmp(Identifier, 'GetActiveOleObject') then\r\n Value := GetActiveOleObject(Args.Values[0])\r\n else { GetOleObject }\r\n begin\r\n try\r\n Value := GetActiveOleObject(Args.Values[0])\r\n except\r\n on E: EOleError do\r\n Value := CreateOleObject(Args.Values[0])\r\n end;\r\n end;\r\n Result := True;\r\n Exit;\r\n end;\r\n end;\r\n {$ENDIF JvInterpreter_OLEAUTO}\r\n\r\n function TypeCast: Boolean;\r\n var\r\n VT: Word;\r\n begin\r\n VT := TypeName2VarTyp(Identifier);\r\n Result := VT <> varEmpty;\r\n if Result then\r\n begin\r\n Value := Args.Values[0];\r\n TVarData(Value).VType := VT;\r\n end;\r\n end;\r\n\r\nbegin\r\n Result := True;\r\n if not FSorted then\r\n Sort;\r\n\r\n if Args.Indexed then\r\n begin\r\n if Args.ObjTyp = varRecord then\r\n begin\r\n if (Args.Obj is TJvInterpreterRecHolder) and GetRecord then\r\n begin\r\n Args.ReturnIndexed := False;\r\n Exit;\r\n end;\r\n end\r\n else\r\n if (Args.Obj <> nil) and ((Args.ObjTyp = varObject) or (Args.ObjTyp = varClass)) then\r\n begin\r\n if IGetMethod then\r\n Exit;\r\n I := Args.Count;\r\n try // try to get indexed property\r\n Args.Count := 0;\r\n Result := GetMethod or DGetMethod;\r\n finally\r\n Args.Count := I;\r\n end;\r\n if Result then\r\n Exit;\r\n end\r\n else\r\n if Args.ObjTyp = varDispatch then\r\n { Ole automation call }\r\n begin\r\n {$IFDEF JvInterpreter_OLEAUTO}\r\n Result := DispatchCall(Identifier, Value, Args, True);\r\n if Result then\r\n begin\r\n Args.ReturnIndexed := True;\r\n Exit;\r\n end;\r\n {$ELSE}\r\n NotImplemented(RsOleAutomationCall);\r\n {$ENDIF JvInterpreter_OLEAUTO}\r\n end;\r\n end\r\n else\r\n begin\r\n if Args.Obj <> nil then\r\n begin\r\n { methods }\r\n if (Args.ObjTyp = varObject) or (Args.ObjTyp = varClass) then\r\n begin\r\n if GetMethod or DGetMethod then\r\n Exit;\r\n end\r\n else\r\n if Args.ObjTyp = varUnknown then\r\n begin\r\n if IntfGetMethod then\r\n Exit;\r\n end\r\n else\r\n if Args.ObjTyp = varRecord then\r\n begin\r\n if (Args.Obj is TJvInterpreterRecHolder) and GetRecord then\r\n Exit;\r\n end\r\n else\r\n if Args.ObjTyp = varDispatch then\r\n { Ole automation call }\r\n begin\r\n {$IFDEF JvInterpreter_OLEAUTO}\r\n Result := DispatchCall(Identifier, Value, Args, True);\r\n if Result then\r\n Exit;\r\n {$ELSE}\r\n NotImplemented(RsOleAutomationCall);\r\n {$ENDIF JvInterpreter_OLEAUTO}\r\n end;\r\n end\r\n else\r\n begin\r\n { classes }\r\n if GetClass then\r\n Exit;\r\n { constants }\r\n if GetConst then\r\n Exit;\r\n { classless functions and procedures }\r\n if GetFun then\r\n Exit;\r\n { external functions }\r\n if GetExtFun then\r\n Exit;\r\n {$IFDEF JvInterpreter_OLEAUTO}\r\n if GetOleAutoFun then\r\n Exit;\r\n {$ENDIF JvInterpreter_OLEAUTO}\r\n if TypeCast then\r\n Exit;\r\n end;\r\n end;\r\n\r\n { source variables and constants }\r\n if GetSrcVar then\r\n Exit;\r\n\r\n if not ((Args.Obj <> nil) and ((Args.ObjTyp = varObject) or (Args.ObjTyp = varClass))) then\r\n if GetSrcUnit then\r\n Exit;\r\n\r\n for I := 0 to FOnGetList.Count - 1 do { Iterate }\r\n begin\r\n TJvInterpreterGetValue(FOnGetList[I]^)(Self, Identifier, Value, Args, Result);\r\n if Result then\r\n Exit;\r\n end;\r\n Result := False;\r\nend;\r\n\r\nfunction TJvInterpreterAdapter.SetValue(Expression: TJvInterpreterExpression; const Identifier: string;\r\n const Value: Variant; Args: TJvInterpreterArgs): Boolean;\r\nvar\r\n I: Integer;\r\n {$IFDEF JvInterpreter_OLEAUTO}\r\n V: Variant;\r\n {$ENDIF JvInterpreter_OLEAUTO}\r\n\r\n function SetMethod: Boolean;\r\n var\r\n I: Integer;\r\n JvInterpreterMethod: TJvInterpreterMethod;\r\n begin\r\n Result := SetValueRTTI(Identifier, Value, Args);\r\n if Result then\r\n Exit;\r\n for I := 0 to FSetList.Count - 1 do\r\n begin\r\n JvInterpreterMethod := TJvInterpreterMethod(FSetList[I]);\r\n if Assigned(JvInterpreterMethod.Func) and\r\n (Args.Obj is JvInterpreterMethod.FClassType) and\r\n Cmp(JvInterpreterMethod.Identifier, Identifier) then\r\n begin\r\n Args.Identifier := Identifier;\r\n CheckAction(Expression, Args, JvInterpreterMethod.Data);\r\n CheckArgs(Args, JvInterpreterMethod.ParamCount, JvInterpreterMethod.ParamTypes);\r\n TJvInterpreterAdapterSetValue(JvInterpreterMethod.Func)(Value, Args);\r\n Result := True;\r\n Exit;\r\n end;\r\n end;\r\n end;\r\n\r\n function ISetMethod: Boolean;\r\n var\r\n I: Integer;\r\n JvInterpreterMethod: TJvInterpreterMethod;\r\n begin\r\n Result := False;\r\n if FISetList.Find(Identifier, I) then\r\n for I := I to FISetList.Count - 1 do\r\n begin\r\n JvInterpreterMethod := TJvInterpreterMethod(FISetList[I]);\r\n if not Cmp(JvInterpreterMethod.Identifier, Identifier) then\r\n Break;\r\n if Assigned(JvInterpreterMethod.Func) and\r\n (Args.Obj is JvInterpreterMethod.FClassType) and\r\n Cmp(JvInterpreterMethod.Identifier, Identifier) then\r\n begin\r\n Args.Identifier := Identifier;\r\n CheckAction(Expression, Args, JvInterpreterMethod.Data);\r\n CheckArgs(Args, JvInterpreterMethod.ParamCount, JvInterpreterMethod.ParamTypes);\r\n TJvInterpreterAdapterSetValue(JvInterpreterMethod.Func)(Value, Args);\r\n Result := True;\r\n Args.ReturnIndexed := True;\r\n Exit;\r\n end;\r\n end;\r\n end;\r\n\r\n function SetRecord: Boolean;\r\n var\r\n I: Integer;\r\n JvInterpreterRecord: TJvInterpreterRecord;\r\n JvInterpreterRecMethod: TJvInterpreterRecMethod;\r\n Rec: PAnsiChar;\r\n begin\r\n Result := False;\r\n JvInterpreterRecord := (Args.Obj as TJvInterpreterRecHolder).JvInterpreterRecord;\r\n for I := 0 to JvInterpreterRecord.FieldCount - 1 do\r\n if Cmp(JvInterpreterRecord.Fields[I].Identifier, Identifier) then\r\n begin\r\n Rec := P2R(Args.Obj);\r\n with JvInterpreterRecord.Fields[I] do\r\n case Typ of\r\n varSmallint:\r\n PWord(Rec + Offset)^ := Word(Value);\r\n varInteger:\r\n PInteger(Rec + Offset)^ := Value;\r\n varSingle:\r\n PSingle(Rec + Offset)^ := Value;\r\n varDouble:\r\n PDouble(Rec + Offset)^ := Value;\r\n varCurrency:\r\n PCurrency(Rec + Offset)^ := Value;\r\n varDate:\r\n PDateTime(Rec + Offset)^ := Value;\r\n varOleStr:\r\n PWideString(Rec + Offset)^ := Value;\r\n varBoolean:\r\n PBool(Rec + Offset)^ := Value;\r\n varVariant:\r\n PVariant(Rec + Offset)^ := Value;\r\n varString:\r\n PString(Rec + Offset)^ := Value;\r\n varEmpty:\r\n JvInterpreterVarAssignment(Variant(PVarData(Rec + Offset)^), Value);\r\n end;\r\n Result := True;\r\n Exit;\r\n end;\r\n for I := 0 to FRecordSetList.Count - 1 do\r\n begin\r\n JvInterpreterRecMethod := TJvInterpreterRecMethod(FRecordSetList[I]);\r\n if (JvInterpreterRecMethod.JvInterpreterRecord = JvInterpreterRecord) and\r\n Cmp(JvInterpreterRecMethod.Identifier, Identifier) then\r\n begin\r\n Args.Identifier := Identifier;\r\n CheckArgs(Args, JvInterpreterRecMethod.ParamCount, JvInterpreterRecMethod.ParamTypes);\r\n TJvInterpreterAdapterSetValue(JvInterpreterRecMethod.Func)(Value, Args);\r\n Result := True;\r\n Exit;\r\n end;\r\n end;\r\n end;\r\n\r\n function SetSrcVar: Boolean;\r\n begin\r\n Result := FSrcVarList.SetValue(Identifier, Value, Args);\r\n end;\r\n\r\nbegin\r\n Result := True;\r\n if not FSorted then\r\n Sort;\r\n\r\n if Args.Indexed then\r\n begin\r\n if (Args.Obj <> nil) and ((Args.ObjTyp = varObject) or (Args.ObjTyp = varClass)) then\r\n if ISetMethod then\r\n Exit;\r\n end\r\n else\r\n begin\r\n if Args.Obj <> nil then\r\n begin\r\n { methods }\r\n if (Args.ObjTyp = varObject) or (Args.ObjTyp = varClass) then\r\n begin\r\n if SetMethod then\r\n Exit;\r\n end\r\n else\r\n if Args.ObjTyp = varRecord then\r\n begin\r\n if (Args.Obj is TJvInterpreterRecHolder) and SetRecord then\r\n Exit;\r\n end\r\n else\r\n if Args.ObjTyp = varDispatch then\r\n { Ole automation call }\r\n begin\r\n {$IFDEF JvInterpreter_OLEAUTO}\r\n V := Value;\r\n Result := DispatchCall(Identifier, V, Args, False);\r\n if Result then\r\n Exit;\r\n {$ELSE}\r\n NotImplemented(RsOleAutomationCall);\r\n {$ENDIF JvInterpreter_OLEAUTO}\r\n end;\r\n end;\r\n end;\r\n\r\n { source variables and constants }\r\n if SetSrcVar then\r\n Exit;\r\n\r\n for I := 0 to FOnSetList.Count - 1 do { Iterate }\r\n begin\r\n TJvInterpreterSetValue(FOnSetList[I]^)(Self, Identifier, Value, Args, Result);\r\n if Result then\r\n Exit;\r\n end;\r\n Result := False;\r\nend;\r\n\r\nfunction TJvInterpreterAdapter.GetElement(Expression: TJvInterpreterExpression;\r\n const Variable: Variant; var Value: Variant; var Args: TJvInterpreterArgs): Boolean;\r\n\r\n function GetID: Boolean;\r\n var\r\n I: Integer;\r\n JvInterpreterMethod: TJvInterpreterMethod;\r\n Obj: TObject;\r\n begin\r\n Obj := V2O(Variable);\r\n for I := 0 to FIDGetList.Count - 1 do\r\n begin\r\n JvInterpreterMethod := TJvInterpreterMethod(FIDGetList[I]);\r\n if Obj is JvInterpreterMethod.FClassType then\r\n begin\r\n Args.Obj := Obj;\r\n CheckAction(Expression, Args, JvInterpreterMethod.Data);\r\n CheckArgs(Args, JvInterpreterMethod.ParamCount, JvInterpreterMethod.ParamTypes);\r\n TJvInterpreterAdapterGetValue(JvInterpreterMethod.Func)(Value, Args);\r\n Result := True;\r\n Exit;\r\n end;\r\n end;\r\n Result := False;\r\n end;\r\n\r\nbegin\r\n Result := True;\r\n { default indexed properties }\r\n if TVarData(Variable).VType = varObject then\r\n begin\r\n if GetID then\r\n Exit;\r\n Result := False;\r\n end\r\n else\r\n Result := False;\r\nend;\r\n\r\nfunction TJvInterpreterAdapter.SetElement(Expression: TJvInterpreterExpression;\r\n var Variable: Variant; const Value: Variant; var Args: TJvInterpreterArgs): Boolean;\r\n\r\n function SetID: Boolean;\r\n var\r\n I: Integer;\r\n JvInterpreterMethod: TJvInterpreterMethod;\r\n Obj: TObject;\r\n begin\r\n Obj := V2O(Variable);\r\n for I := 0 to FIDSetList.Count - 1 do\r\n begin\r\n JvInterpreterMethod := TJvInterpreterMethod(FIDSetList[I]);\r\n if Obj is JvInterpreterMethod.FClassType then\r\n begin\r\n Args.Obj := Obj;\r\n CheckAction(Expression, Args, JvInterpreterMethod.Data);\r\n CheckArgs(Args, JvInterpreterMethod.ParamCount, JvInterpreterMethod.ParamTypes);\r\n TJvInterpreterAdapterSetValue(JvInterpreterMethod.Func)(Value, Args);\r\n Result := True;\r\n Exit;\r\n end;\r\n end;\r\n Result := False;\r\n end;\r\n\r\nbegin\r\n Result := True;\r\n { default indexed properties }\r\n if TVarData(Variable).VType = varObject then\r\n begin\r\n if SetID then\r\n Exit;\r\n Result := False;\r\n end\r\n else\r\n Result := False;\r\nend;\r\n\r\nfunction TJvInterpreterAdapter.SetRecord(var Value: Variant): Boolean;\r\nvar\r\n RecHolder: TJvInterpreterRecHolder;\r\nbegin\r\n if TVarData(Value).VType = varRecord then\r\n begin\r\n RecHolder := TJvInterpreterRecHolder(TVarData(Value).VPointer);\r\n RecHolder.JvInterpreterRecord := TJvInterpreterRecord(GetRec(RecHolder.RecordType));\r\n Result := Assigned(RecHolder.JvInterpreterRecord);\r\n end\r\n else\r\n Result := False;\r\nend;\r\n\r\nfunction TJvInterpreterAdapter.NewRecord(const RecordType: string;\r\n var Value: Variant): Boolean;\r\nvar\r\n JvInterpreterRecord: TJvInterpreterRecord;\r\nbegin\r\n JvInterpreterRecord := TJvInterpreterRecord(GetRec(RecordType));\r\n if JvInterpreterRecord = nil then\r\n Result := False\r\n else\r\n begin\r\n JvInterpreterRecord.NewRecord(Value);\r\n Result := True;\r\n end;\r\nend;\r\n\r\n{$IFDEF JvInterpreter_OLEAUTO}\r\nfunction TJvInterpreterAdapter.DispatchCall(const Identifier: string; var Value: Variant;\r\n Args: TJvInterpreterArgs; Get: Boolean): Boolean; stdcall;\r\nvar\r\n CallDesc: TCallDesc;\r\n ParamTypes: array [0..MaxDispArgs * 4 - 1] of Byte;\r\n Ptr: Integer;\r\n TypePtr: Integer;\r\n PVRes: PVariant;\r\n Names: string;\r\n I: Integer;\r\n\r\n procedure AddParam(const Param: Variant);\r\n var\r\n Int: Integer;\r\n Wrd: WordBool;\r\n Poin: Pointer;\r\n Dbl: Double;\r\n TempDisp : IDispatch; //ComObj\r\n\r\n procedure AddParam1(Typ: Byte; ParamSize: Integer; const Param);\r\n begin\r\n { CallDesc.ArgTypes[Ptr] := Typ;\r\n Move(Param, ParamTypes[Ptr], ParamSize);\r\n Inc(Ptr, ParamSize); }\r\n CallDesc.ArgTypes[TypePtr] := Typ;\r\n Move(Param, ParamTypes[Ptr], ParamSize);\r\n Inc(Ptr, ParamSize);\r\n Inc(TypePtr);\r\n end;\r\n\r\n begin\r\n case TVarData(Param).VType of\r\n varInteger:\r\n begin\r\n Int := Param;\r\n AddParam1(varInteger, SizeOf(Int), Int);\r\n end;\r\n varDouble, varCurrency:\r\n begin\r\n Dbl := Param;\r\n AddParam1(varDouble, SizeOf(Dbl), Dbl);\r\n end;\r\n varString:\r\n begin\r\n Poin := V2P(Param);\r\n AddParam1(varStrArg, SizeOf(Poin), Poin);\r\n end;\r\n varBoolean:\r\n begin\r\n Wrd := WordBool(Param);\r\n AddParam1(varBoolean, SizeOf(Wrd), Wrd);\r\n end;\r\n varDispatch:\r\n begin\r\n TempDisp := Param;//VarToInterface(Param).IFace);\r\n AddParam1(varDispatch, SizeOf(TempDisp), TempDisp);\r\n end;\r\n\r\n end;\r\n end;\r\n\r\nbegin\r\n Result := True;\r\n { Call method through Ole Automation }\r\n with CallDesc do\r\n begin\r\n if Get then\r\n CallType := DISPATCH_METHOD or DISPATCH_PROPERTYGET\r\n else\r\n CallType := DISPATCH_PROPERTYPUT;\r\n ArgCount := Args.Count;\r\n NamedArgCount := 0; { named args not supported by JvInterpreter }\r\n end;\r\n Names := Identifier + #00;\r\n Ptr := 0;\r\n TypePtr := 0;\r\n if not Get then\r\n begin\r\n AddParam(Value);\r\n Inc(CallDesc.ArgCount);\r\n end;\r\n for I := 0 to Args.Count - 1 do\r\n AddParam(Args.Values[I]);\r\n Value := Null;\r\n { When calling procedures(without result) PVRes must be nil }\r\n if Args.HasResult and Get then\r\n PVRes := @Value\r\n else\r\n PVRes := nil;\r\n try\r\n { call }\r\n // (rom) absolute removed\r\n VarDispInvoke(PVRes, Args.Obj, PChar(Names), @CallDesc, @ParamTypes[0]);\r\n Ptr := 0;\r\n TypePtr := 0;\r\n except\r\n on E: EOleError do\r\n JvInterpreterErrorN2(ieOleAuto, -1, Identifier, E.Message);\r\n end;\r\n if Get and (TVarData(Value).VType = varOleStr) then\r\n Value := VarAsType(Value, varString);\r\nend;\r\n{$ENDIF JvInterpreter_OLEAUTO}\r\n\r\nfunction TJvInterpreterAdapter.GetValueRTTI(const Identifier: string; var Value: Variant;\r\n Args: TJvInterpreterArgs): Boolean;\r\nvar\r\n TypeInf: PTypeInfo;\r\n PropInf: PPropInfo;\r\n PropTyp: TypInfo.TTypeKind;\r\nbegin\r\n Result := False;\r\n if (Args.ObjTyp <> varObject) or (Args.Obj = nil) then\r\n Exit;\r\n TypeInf := Args.Obj.ClassInfo;\r\n if TypeInf = nil then\r\n Exit;\r\n PropInf := GetPropInfo(TypeInf, Identifier);\r\n if PropInf = nil then\r\n Exit;\r\n PropTyp := PropInf.PropType^.Kind;\r\n case PropTyp of\r\n tkInteger, tkEnumeration:\r\n Value := GetOrdProp(Args.Obj, PropInf);\r\n tkChar, tkWChar:\r\n Value := Char(GetOrdProp(Args.Obj, PropInf));\r\n tkFloat:\r\n Value := GetFloatProp(Args.Obj, PropInf);\r\n {$IFDEF UNICODE} tkUString, {$ENDIF}\r\n tkString, tkLString, tkWString:\r\n Value := GetStrProp(Args.Obj, PropInf);\r\n tkClass:\r\n Value := O2V(TObject(GetOrdProp(Args.Obj, PropInf)));\r\n tkSet:\r\n Value := S2V(GetOrdProp(Args.Obj, PropInf));\r\n tkInterface:\r\n Value := GetInterfaceProp(Args.Obj, PropInf)\r\n else\r\n Exit;\r\n end;\r\n if PropInf^.PropType^.Name = 'Boolean' then\r\n TVarData(Value).VType := varBoolean;\r\n Result := True;\r\nend;\r\n\r\nfunction TJvInterpreterAdapter.SetValueRTTI(const Identifier: string; const Value: Variant;\r\n Args: TJvInterpreterArgs): Boolean;\r\nvar\r\n TypeInf: PTypeInfo;\r\n PropInf: PPropInfo;\r\n PropTyp: TypInfo.TTypeKind;\r\n Obj: TObject;\r\nbegin\r\n Result := False;\r\n if (Args.ObjTyp <> varObject) or (Args.Obj = nil) then\r\n Exit;\r\n Obj := Args.Obj;\r\n TypeInf := Obj.ClassInfo;\r\n if TypeInf = nil then\r\n Exit;\r\n PropInf := GetPropInfo(TypeInf, Identifier);\r\n if PropInf = nil then\r\n Exit;\r\n PropTyp := PropInf.PropType^.Kind;\r\n case PropTyp of\r\n tkInteger, tkEnumeration:\r\n SetOrdProp(Args.Obj, PropInf, Var2Type(Value, varInteger));\r\n tkChar, tkWChar:\r\n SetOrdProp(Args.Obj, PropInf, Integer(string(Value)[1]));\r\n tkFloat:\r\n SetFloatProp(Args.Obj, PropInf, Value);\r\n {$IFDEF UNICODE} tkUString, {$ENDIF}\r\n tkString, tkLString, tkWString:\r\n SetStrProp(Args.Obj, PropInf, VarToStr(Value));\r\n tkClass:\r\n SetOrdProp(Args.Obj, PropInf, NativeInt(V2O(Value)));\r\n tkSet:\r\n SetOrdProp(Args.Obj, PropInf, V2S(Value));\r\n tkInterface:\r\n SetInterfaceProp(Args.Obj, PropInf, Value);\r\n else\r\n Exit;\r\n end;\r\n Result := True;\r\nend;\r\n\r\nprocedure TJvInterpreterAdapter.CurUnitChanged(const NewUnitName: string; var Source: string);\r\nvar\r\n I: Integer;\r\n JvInterpreterUnitSource: TJvInterpreterSrcUnit;\r\nbegin\r\n for I := 0 to FSrcUnitList.Count - 1 do\r\n begin\r\n JvInterpreterUnitSource := TJvInterpreterSrcUnit(FSrcUnitList.Items[I]);\r\n if Cmp(TJvInterpreterSrcUnit(JvInterpreterUnitSource).Identifier, NewUnitName) then\r\n begin\r\n Source := TJvInterpreterSrcUnit(JvInterpreterUnitSource).FSource;\r\n Exit;\r\n end;\r\n end;\r\n Source := '';\r\nend;\r\n\r\nfunction TJvInterpreterAdapter.UnitExists(const Identifier: string): Boolean;\r\nvar\r\n JvInterpreterIdentifier: TJvInterpreterIdentifier;\r\n I: Integer;\r\nbegin\r\n Result := True;\r\n for I := 0 to FSrcUnitList.Count - 1 do\r\n begin\r\n JvInterpreterIdentifier := TJvInterpreterIdentifier(FSrcUnitList.Items[I]);\r\n if Cmp(JvInterpreterIdentifier.Identifier, Identifier) then\r\n Exit;\r\n end;\r\n for I := 0 to FExtUnitList.Count - 1 do\r\n begin\r\n JvInterpreterIdentifier := TJvInterpreterIdentifier(FExtUnitList.Items[I]);\r\n if Cmp(JvInterpreterIdentifier.Identifier, Identifier) then\r\n Exit;\r\n end;\r\n Result := False;\r\nend;\r\n\r\nfunction TJvInterpreterAdapter.NewEvent(const UnitName: string; const FunctionName,\r\n EventType: string; AOwner: TJvInterpreterExpression; AObject: TObject;\r\n const APropName: string): TSimpleEvent;\r\nvar\r\n Event: TJvInterpreterEvent;\r\n I: Integer;\r\n JvInterpreterEventDesc: TJvInterpreterEventDesc;\r\nbegin\r\n for I := 0 to FEventHandlerList.Count - 1 do\r\n begin\r\n JvInterpreterEventDesc := TJvInterpreterEventDesc(FEventHandlerList.Items[I]);\r\n if Cmp(JvInterpreterEventDesc.Identifier, EventType) then\r\n begin\r\n Event := JvInterpreterEventDesc.EventClass.Create(AOwner, AObject, UnitName, FunctionName, APropName);\r\n TMethod(Result).Code := JvInterpreterEventDesc.Code;\r\n TMethod(Result).Data := Event;\r\n Exit;\r\n end;\r\n end;\r\n Result := nil;\r\nend;\r\n\r\nfunction TJvInterpreterAdapter.IsEvent(Obj: TObject; const Identifier: string): Boolean;\r\nvar\r\n JvInterpreterClass: TJvInterpreterClass;\r\n I: Integer;\r\nbegin\r\n for I := 0 to FEventList.Count - 1 do\r\n begin\r\n JvInterpreterClass := TJvInterpreterClass(FEventList[I]);\r\n if (Obj is JvInterpreterClass.FClassType) and\r\n Cmp(JvInterpreterClass.Identifier, Identifier) then\r\n begin\r\n Result := True;\r\n Exit;\r\n end;\r\n end;\r\n Result := False;\r\nend;\r\n\r\nprocedure TJvInterpreterAdapter.Sort;\r\nbegin\r\n FConstList.Sort;\r\n FClassList.Sort;\r\n FFunctionList.Sort;\r\n FGetList.Sort;\r\n FIntfGetList.Sort;\r\n FSetList.Sort;\r\n FIGetList.Sort;\r\n FISetList.Sort;\r\n FSorted := True;\r\nend;\r\n\r\n//=== { TJvInterpreterArgs } =================================================\r\n\r\ndestructor TJvInterpreterArgs.Destroy;\r\nbegin\r\n if OA <> nil then\r\n Dispose(OA);\r\n if FOAV <> nil then\r\n Dispose(FOAV);\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvInterpreterArgs.Clear;\r\nbegin\r\n Count := 0;\r\n Obj := nil;\r\n ObjTyp := 0;\r\n FHasVars := False;\r\n Indexed := False;\r\n ReturnIndexed := False;\r\n ObjRefHolder := Unassigned;\r\nend;\r\n\r\nprocedure TJvInterpreterArgs.OpenArray(const Index: Integer);\r\nbegin\r\n if OA = nil then\r\n New(OA);\r\n if FOAV = nil then\r\n New(FOAV);\r\n V2OA(Values[Index], OA^, FOAV^, OAS);\r\nend;\r\n\r\nprocedure TJvInterpreterArgs.Delete(const Index: Integer);\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := Index to Count - 2 do\r\n begin\r\n Types[I] := Types[I + 1];\r\n Values[I] := Values[I + 1];\r\n Names[I] := Names[I + 1];\r\n end;\r\n Dec(Count);\r\nend;\r\n\r\n//=== { TJvInterpreterExpression } ===========================================\r\n\r\nconstructor TJvInterpreterExpression.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FParser := TJvInterpreterParser.Create;\r\n FPStream := TStringStream.Create('');\r\n FArgs := TJvInterpreterArgs.Create;\r\n FAdapter := CreateAdapter;\r\n FDisableExternalFunctions := False;\r\n FAdapter.DisableExternalFunctions := False;\r\n FSharedAdapter := GlobalJvInterpreterAdapter;\r\n FLastError := EJvInterpreterError.Create(-1, -1, '', '');\r\n FAllowAssignment := True;\r\n FCompiled := False;\r\nend;\r\n\r\ndestructor TJvInterpreterExpression.Destroy;\r\nbegin\r\n JvInterpreterVarFree(FVResult);\r\n FAdapter.Free;\r\n FArgs.Free;\r\n FPStream.Free;\r\n FParser.Free;\r\n FLastError.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvInterpreterExpression.UpdateExceptionPos(E: Exception; const UnitName: string);\r\n\r\n procedure NoName(E: EJvInterpreterError);\r\n begin\r\n if not E.FExceptionPos then\r\n begin\r\n if E.FErrPos = -1 then\r\n E.FErrPos := CurPos;\r\n if E.FErrUnitName = '' then\r\n E.FErrUnitName := UnitName;\r\n if E.FErrUnitName <> '' then\r\n begin\r\n { first line has number 1 }\r\n E.FErrLine := GetLineByPos(FParser.Source, E.FErrPos) + BaseErrLine + 1;\r\n E.Message := Format(LoadStr2(ieErrorPos), [E.FErrUnitName, E.FErrLine, E.FErrMessage]);\r\n E.FExceptionPos := True;\r\n end;\r\n end;\r\n end;\r\n\r\nbegin\r\n if E is EJvInterpreterError then\r\n begin\r\n NoName(E as EJvInterpreterError);\r\n FLastError.Assign(E as EJvInterpreterError);\r\n end\r\n else\r\n if not FLastError.FExceptionPos then\r\n begin\r\n FLastError.FErrCode := ieExternal;\r\n FLastError.Message := E.Message;\r\n FLastError.FErrMessage := E.Message;\r\n NoName(FLastError);\r\n end;\r\nend;\r\n\r\nprocedure TJvInterpreterExpression.Init;\r\nbegin\r\n JvInterpreterVarFree(FVResult);\r\n FExpStackPtr := -1;\r\n // Parse;\r\n FParser.Init;\r\n FBacked := False;\r\n FCurrArgs := FArgs;\r\n FAdapter.ClearNonSource;\r\n FLastError.Clear;\r\nend;\r\n\r\nfunction TJvInterpreterExpression.GetSource: string;\r\nbegin\r\n Result := FParser.Source;\r\nend;\r\n\r\nprocedure TJvInterpreterExpression.SetSource(const Value: string);\r\nbegin\r\n FParser.Source := Value;\r\n SourceChanged;\r\nend;\r\n\r\nprocedure TJvInterpreterExpression.SourceChanged;\r\nbegin\r\nend;\r\n\r\nprocedure TJvInterpreterExpression.SetAdapter(Adapter: TJvInterpreterAdapter);\r\nbegin\r\n FAdapter := Adapter;\r\nend;\r\n\r\nprocedure TJvInterpreterExpression.SetCurPos(Value: Integer);\r\nbegin\r\n if FParsed then\r\n FPStream.Position := Value\r\n else\r\n FParser.Pos := Value;\r\n FBacked := False;\r\nend;\r\n\r\nfunction TJvInterpreterExpression.GetCurPos: Integer;\r\nbegin\r\n if FParsed then\r\n Result := FPStream.Position\r\n else\r\n Result := FParser.Pos;\r\nend;\r\n\r\nprocedure TJvInterpreterExpression.ErrorExpected(const Exp: string);\r\nbegin\r\n if TokenStr <> '' then\r\n JvInterpreterErrorN2(ieExpected, PosBeg, Exp, '''' + TokenStr + '''')\r\n else\r\n JvInterpreterErrorN2(ieExpected, PosBeg, Exp, LoadStr2(irEndOfFile));\r\nend;\r\n\r\nprocedure TJvInterpreterExpression.ErrorNotImplemented(const Msg: string);\r\nbegin\r\n JvInterpreterErrorN(ieInternal, PosBeg, Msg + RsENotImplemented);\r\nend;\r\n\r\nfunction TJvInterpreterExpression.PosBeg: Integer;\r\nbegin\r\n Result := CurPos - Length(TokenStr);\r\nend;\r\n\r\nfunction TJvInterpreterExpression.PosEnd: Integer;\r\nbegin\r\n Result := CurPos;\r\nend;\r\n\r\nfunction TJvInterpreterExpression.GetTokenStr: string;\r\nbegin\r\n if FParsed and (TTyp <> ttUnknown) then\r\n Result := TypToken(TTyp)\r\n else\r\n Result := FTokenStr;\r\nend;\r\n\r\nprocedure TJvInterpreterExpression.Parse;\r\nbegin\r\n FPStream.Size := 0;\r\n FPStream.Position := 0;\r\n FParser.Init;\r\n repeat\r\n ParseToken;\r\n WriteToken;\r\n until FTTyp = ttEmpty;\r\n FParsed := True;\r\n FPStream.Position := 0;\r\nend;\r\n\r\nprocedure TJvInterpreterExpression.WriteToken;\r\nbegin\r\n WordSaveToStream(FPStream, Word(FTTyp));\r\n case FTTyp of\r\n ttInteger:\r\n IntSaveToStream(FPStream, FToken);\r\n ttString:\r\n StringSaveToStream(FPStream, FToken);\r\n ttTrue, ttFalse:\r\n BoolSaveToStream(FPStream, FToken);\r\n ttDouble:\r\n ExtendedSaveToStream(FPStream, FToken);\r\n ttIdentifier:\r\n StringSaveToStream(FPStream, FToken);\r\n ttUnknown:\r\n StringSaveToStream(FPStream, FTokenStr);\r\n end;\r\nend;\r\n\r\nprocedure TJvInterpreterExpression.ReadToken;\r\nbegin\r\n FTTyp := Smallint(WordLoadFromStream(FPStream));\r\n case FTTyp of\r\n ttInteger:\r\n FToken := IntLoadFromStream(FPStream);\r\n ttString:\r\n FToken := StringLoadFromStream(FPStream);\r\n ttTrue, ttFalse:\r\n FToken := BoolLoadFromStream(FPStream);\r\n ttDouble:\r\n FToken := ExtendedLoadFromStream(FPStream);\r\n ttIdentifier:\r\n FToken := StringLoadFromStream(FPStream);\r\n ttUnknown:\r\n FTokenStr := StringLoadFromStream(FPStream);\r\n end;\r\nend;\r\n\r\nprocedure TJvInterpreterExpression.NextToken;\r\nbegin\r\n if FBacked then\r\n FBacked := False\r\n else\r\n begin\r\n FPrevTTyp := FTTyp;\r\n if FParsed then\r\n ReadToken\r\n else\r\n ParseToken;\r\n end;\r\nend;\r\n\r\nprocedure TJvInterpreterExpression.ParseToken;\r\nvar\r\n {$IFDEF DELPHI7_UP}\r\n FS: TFormatSettings;\r\n {$ELSE}\r\n OldDecimalSeparator: Char;\r\n {$ENDIF DELPHI7_UP}\r\n Dob: Extended;\r\n Int: Integer;\r\n Stub: Integer;\r\nbegin\r\n FTokenStr := FParser.Token;\r\n FTTyp := TokenTyp(FTokenStr);\r\n case TTyp of\r\n ttInteger:\r\n begin\r\n Val(FTokenStr, Int, Stub);\r\n FToken := Int;\r\n end;\r\n ttDouble:\r\n begin\r\n {$IFDEF DELPHI7_UP}\r\n FS.ThousandSeparator := ',';\r\n FS.DecimalSeparator := '.';\r\n if not TextToFloat(PChar(FTokenStr), Dob, fvExtended, FS) then\r\n JvInterpreterError(ieInternal, -1);\r\n {$ELSE}\r\n OldDecimalSeparator := DecimalSeparator;\r\n DecimalSeparator := '.';\r\n if not TextToFloat(PChar(FTokenStr), Dob, fvExtended) then\r\n begin\r\n DecimalSeparator := OldDecimalSeparator;\r\n JvInterpreterError(ieInternal, -1);\r\n end\r\n else\r\n DecimalSeparator := OldDecimalSeparator;\r\n {$ENDIF DELPHI7_UP}\r\n FToken := Dob;\r\n end;\r\n ttString:\r\n FToken := Copy(TokenStr, 2, Length(FTokenStr) - 2);\r\n ttFalse:\r\n FToken := False;\r\n ttTrue:\r\n FToken := True;\r\n ttIdentifier:\r\n FToken := FTokenStr;\r\n {-----olej-----}\r\n ttArray:\r\n FToken := FTokenStr;\r\n {-----olej-----}\r\n end;\r\nend;\r\n\r\nprocedure TJvInterpreterExpression.Back;\r\nbegin\r\n // JvInterpreterError(ieInternal, -2);\r\n if FBacked then\r\n JvInterpreterError(ieInternal, -1);\r\n FBacked := True;\r\nend;\r\n\r\nprocedure TJvInterpreterExpression.SafeBack;\r\nbegin\r\n if not FBacked then\r\n Back;\r\nend;\r\n\r\nfunction TJvInterpreterExpression.CreateAdapter: TJvInterpreterAdapter;\r\nbegin\r\n Result := TJvInterpreterAdapter.Create(Self);\r\nend;\r\n\r\nfunction TJvInterpreterExpression.Expression1: Variant;\r\nvar\r\n OldExpStackPtr: Integer;\r\n\r\n procedure PushExp(var Value: Variant);\r\n begin\r\n Inc(FExpStackPtr);\r\n if FExpStackPtr > High(FExpStack) then\r\n JvInterpreterError(ieExpressionStackOverflow, -1);\r\n JvInterpreterVarCopy(FExpStack[FExpStackPtr], Value);\r\n end;\r\n\r\n function PopExp: Variant;\r\n begin\r\n if FExpStackPtr = -1 then\r\n JvInterpreterError(ieInternal, -1);\r\n JvInterpreterVarCopy(Result, FExpStack[FExpStackPtr]);\r\n Dec(FExpStackPtr);\r\n end;\r\n\r\n { function Expression called recursively very often, so placing it\r\n as local function (not class method) improves performance }\r\n\r\n function Expression(const OpTyp: TTokenKind): Variant;\r\n var\r\n Tmp: Variant;\r\n PrevTTyp: Integer;\r\n begin\r\n Result := Unassigned;\r\n if OpTyp <> ttUnknown then\r\n NextToken;\r\n PrevTTyp := TTyp;\r\n while True do\r\n begin\r\n case TTyp of\r\n ttInteger, ttDouble, ttFalse, ttTrue, ttIdentifier:\r\n begin\r\n Result := Token;\r\n if TTyp = ttIdentifier then\r\n begin\r\n FCurrArgs.Clear;\r\n InternalGetValue(nil, 0, Result);\r\n end;\r\n NextToken;\r\n if TTyp in [ttInteger, ttDouble, ttString,\r\n ttFalse, ttTrue, ttIdentifier] then\r\n JvInterpreterError(ieMissingOperator, PosEnd {!!});\r\n if Prior(TTyp) < Prior(OpTyp) then\r\n Exit;\r\n end;\r\n ttString:\r\n begin\r\n Result := '';\r\n repeat\r\n Result := Result + Token;\r\n NextToken;\r\n if TTyp in [ttInteger, ttDouble, ttFalse, ttTrue, ttIdentifier] then\r\n JvInterpreterError(ieMissingOperator, PosEnd {!!});\r\n until TTyp <> ttString;\r\n if Prior(TTyp) < Prior(OpTyp) then\r\n Exit;\r\n end;\r\n\r\n // [peter schraut: added ttShl case on 2005/08/14]\r\n ttShl:\r\n if priorShl > Prior(OpTyp) then\r\n Result := PopExp shl Expression(TTyp)\r\n else\r\n Exit;\r\n\r\n // [peter schraut: added ttShr case on 2005/08/14]\r\n ttShr:\r\n if priorShr > Prior(OpTyp) then\r\n Result := PopExp shr Expression(TTyp)\r\n else\r\n Exit;\r\n\r\n // [peter schraut: added ttXor case on 2005/08/14]\r\n ttXor:\r\n if priorXor > Prior(OpTyp) then\r\n Result := PopExp xor Expression(TTyp)\r\n else\r\n Exit;\r\n\r\n ttMul:\r\n if priorMul > Prior(OpTyp) then\r\n Result := PopExp * Expression(TTyp)\r\n else\r\n Exit;\r\n ttPlus:\r\n { proceed differently depending on type }\r\n if not (FPrevTTyp in [ttInteger, ttDouble, ttString, ttFalse, ttTrue,\r\n ttIdentifier, ttRB, ttRS]) then\r\n { unary plus }\r\n Result := Expression(ttNot) { highest priority }\r\n else\r\n if priorPlus > Prior(OpTyp) then\r\n begin\r\n Tmp := PopExp;\r\n if TVarData(Tmp).VType = varSet then\r\n begin\r\n Result := TVarData(Tmp).VInteger or\r\n TVarData(Expression(TTyp)).VInteger;\r\n TVarData(Result).VType := varSet;\r\n end\r\n else\r\n Result := Tmp + Expression(TTyp)\r\n end\r\n else\r\n Exit;\r\n ttMinus:\r\n { proceed differently depending on type }\r\n if not (FPrevTTyp in [ttInteger, ttDouble, ttString, ttFalse, ttTrue,\r\n ttIdentifier, ttRB, ttRS]) then\r\n { unary minus }\r\n Result := -Expression(ttNot) { highest priority }\r\n else\r\n if priorMinus > Prior(OpTyp) then\r\n begin\r\n Tmp := PopExp;\r\n if TVarData(Tmp).VType = varSet then\r\n begin\r\n Result := TVarData(Tmp).VInteger and\r\n not TVarData(Expression(TTyp)).VInteger;\r\n TVarData(Result).VType := varSet;\r\n end\r\n else\r\n Result := Tmp - Expression(TTyp)\r\n end\r\n else\r\n Exit;\r\n ttDiv:\r\n if priorDiv > Prior(OpTyp) then\r\n Result := PopExp / Expression(TTyp)\r\n else\r\n Exit;\r\n ttIntDiv:\r\n if priorIntDiv > Prior(OpTyp) then\r\n Result := PopExp div Expression(TTyp)\r\n else\r\n Exit;\r\n ttMod:\r\n if priorMod > Prior(OpTyp) then\r\n Result := PopExp mod Expression(TTyp)\r\n else\r\n Exit;\r\n ttOr:\r\n if priorOr > Prior(OpTyp) then\r\n Result := PopExp or Expression(TTyp)\r\n else\r\n Exit;\r\n ttAnd:\r\n if priorAnd > Prior(OpTyp) then\r\n Result := PopExp and Expression(TTyp)\r\n else\r\n Exit;\r\n ttNot:\r\n { 'Not' has highest priority, so we have no need to check this }\r\n // if priorNot > Prior(OpTyp) then\r\n Result := not Expression(TTyp);\r\n // else Exit;\r\n ttEqu:\r\n { proceed differently depending on type }\r\n if priorEqu > Prior(OpTyp) then\r\n begin\r\n Tmp := PopExp;\r\n if (TVarData(Tmp).VType = varObject) or (TVarData(Tmp).VType = varClass) or\r\n (TVarData(Tmp).VType = varSet) or (TVarData(Tmp).VType = varPointer) then\r\n Result := TVarData(Tmp).VInteger = TVarData(Expression(TTyp)).VInteger\r\n else\r\n Result := Tmp = Expression(TTyp)\r\n end\r\n else\r\n Exit;\r\n ttNotEqu:\r\n { proceed differently depending on a types }\r\n if priorNotEqu > Prior(OpTyp) then\r\n begin\r\n Tmp := PopExp;\r\n if (TVarData(Tmp).VType = varObject) or (TVarData(Tmp).VType = varClass) or\r\n (TVarData(Tmp).VType = varSet) or (TVarData(Tmp).VType = varPointer) then\r\n Result := TVarData(Tmp).VInteger <>\r\n TVarData(Expression(TTyp)).VInteger\r\n else\r\n if TVarData(Tmp).VType = varUnknown then\r\n Result := TVarData(Tmp).VUnknown <> TVarData(Expression(TTyp)).VUnknown\r\n else\r\n Result := Tmp <> Expression(TTyp)\r\n end\r\n else\r\n Exit;\r\n ttGreater:\r\n if priorGreater > Prior(OpTyp) then\r\n Result := PopExp > Expression(TTyp)\r\n else\r\n Exit;\r\n ttLess:\r\n if priorLess > Prior(OpTyp) then\r\n Result := PopExp < Expression(TTyp)\r\n else\r\n Exit;\r\n ttEquLess:\r\n if priorEquLess > Prior(OpTyp) then\r\n Result := PopExp <= Expression(TTyp)\r\n else\r\n Exit;\r\n ttEquGreater:\r\n if priorEquGreater > Prior(OpTyp) then\r\n Result := PopExp >= Expression(TTyp)\r\n else\r\n Exit;\r\n ttLB:\r\n begin\r\n Result := Expression(TTyp);\r\n if FTTyp <> ttRB then\r\n ErrorExpected(''')''');\r\n NextToken;\r\n end;\r\n ttRB:\r\n if (TVarData(Result).VType = varEmpty) and (PrevTTyp <> ttIdentifier) then\r\n ErrorExpected(LoadStr2(irExpression))\r\n else\r\n Exit;\r\n ttLS:\r\n begin\r\n NextToken;\r\n Result := SetExpression1;\r\n if FTTyp <> ttRS then\r\n ErrorExpected(''']''');\r\n NextToken;\r\n end;\r\n ttRS:\r\n if (TVarData(Result).VType = varEmpty) and (PrevTTyp <> ttIdentifier) then\r\n ErrorExpected(LoadStr2(irExpression))\r\n else\r\n Exit;\r\n else\r\n if (TVarData(Result).VType = varEmpty) and (PrevTTyp <> ttIdentifier) then\r\n ErrorExpected(LoadStr2(irExpression))\r\n else\r\n Exit;\r\n end;\r\n PushExp(Result);\r\n end;\r\n end;\r\n\r\nbegin\r\n Result := Null;\r\n try\r\n OldExpStackPtr := FExpStackPtr;\r\n try\r\n Expression(ttUnknown);\r\n JvInterpreterVarCopy(Result, PopExp);\r\n finally\r\n FExpStackPtr := OldExpStackPtr;\r\n end;\r\n except\r\n on E: EVariantError do\r\n JvInterpreterError(ieTypeMistmatch, CurPos);\r\n end;\r\nend;\r\n\r\nfunction TJvInterpreterExpression.Expression2(const ExpType: Word): Variant;\r\nvar\r\n ErrPos: Integer;\r\nbegin\r\n ErrPos := PosBeg;\r\n try\r\n FAllowAssignment := False;\r\n Result := Expression1;\r\n finally\r\n FAllowAssignment := True;\r\n end;\r\n if TVarData(Result).VType <> ExpType then\r\n case ExpType of\r\n varInteger:\r\n JvInterpreterError(ieIntegerRequired, ErrPos);\r\n varBoolean:\r\n JvInterpreterError(ieBooleanRequired, ErrPos);\r\n else\r\n JvInterpreterError(ieUnknown, ErrPos);\r\n end;\r\nend;\r\n\r\n{ calulate set expressions, such as: [fsBold, fsItalic] }\r\n\r\nfunction TJvInterpreterExpression.SetExpression1: Variant;\r\nvar\r\n V1: Variant;\r\nbegin\r\n Result := 0;\r\n while True do\r\n begin\r\n case TTyp of\r\n ttIdentifier, ttInteger:\r\n begin\r\n if TTyp = ttInteger then\r\n Result := Result or Integer(Token)\r\n else\r\n begin\r\n FCurrArgs.Clear;\r\n InternalGetValue(nil, 0, V1);\r\n if not VarIsOrdinal(V1) then\r\n JvInterpreterError(ieIntegerRequired, PosBeg);\r\n Result := Result or 1 shl Integer(V1);\r\n end;\r\n NextToken; { skip ',' }\r\n if TTyp = ttCol then\r\n NextToken\r\n else\r\n if TTyp = ttRS then\r\n Break\r\n else\r\n ErrorExpected(''']''');\r\n end;\r\n ttRS:\r\n Break;\r\n else\r\n Break;\r\n end;\r\n end;\r\n TVarData(Result).VType := varSet;\r\nend;\r\n\r\nprocedure TJvInterpreterExpression.ReadArgs;\r\n\r\n function ReadOpenArray: Variant;\r\n var\r\n Values: TValueArray;\r\n I: Integer;\r\n begin\r\n { open array or set constant }\r\n NextToken;\r\n Values[0] := Expression1;\r\n I := 1;\r\n while TTyp = ttCol do\r\n begin\r\n NextToken;\r\n FCurrArgs.Clear;\r\n Values[I] := Expression1;\r\n Inc(I);\r\n end;\r\n if TTyp <> ttRS then\r\n ErrorExpected(''']''');\r\n Result := VarArrayCreate([0, I - 1], varVariant);\r\n for I := 0 to I - 1 do\r\n Result[I] := Values[I];\r\n NextToken;\r\n end;\r\n\r\nvar\r\n LocalArgs: TJvInterpreterArgs;\r\n I: Integer;\r\n SK: TTokenKind;\r\nbegin\r\n LocalArgs := FCurrArgs;\r\n FCurrArgs := TJvInterpreterArgs.Create;\r\n FCurrArgs.Indexed := LocalArgs.Indexed;\r\n try\r\n I := 0;\r\n if TTyp = ttLB then\r\n SK := ttRB\r\n else\r\n SK := ttRS;\r\n\r\n NextToken;\r\n if TTyp = ttIdentifier then\r\n LocalArgs.FVarNames[I] := Token\r\n else\r\n LocalArgs.FVarNames[I] := '';\r\n\r\n FCurrArgs.Clear;\r\n if TTyp = ttLS then\r\n LocalArgs.Values[I] := ReadOpenArray\r\n //added check to recognize C style (), like \"NextToken()\"\r\n //RWare: if token ')', skip and exit\r\n else\r\n if TTyp = ttRB then\r\n begin\r\n NextToken;\r\n Exit;\r\n end\r\n else\r\n JvInterpreterVarCopy(LocalArgs.Values[I], Expression1);\r\n\r\n while TTyp = ttCol do\r\n begin\r\n Inc(I);\r\n NextToken;\r\n if TTyp = ttIdentifier then\r\n LocalArgs.FVarNames[I] := Token\r\n else\r\n LocalArgs.FVarNames[I] := '';\r\n FCurrArgs.Clear;\r\n if TTyp = ttLS then\r\n LocalArgs.Values[I] := ReadOpenArray\r\n else\r\n JvInterpreterVarCopy(LocalArgs.Values[I], Expression1);\r\n end;\r\n if TTyp <> SK then\r\n if SK = ttRB then\r\n ErrorExpected(''')''')\r\n else\r\n ErrorExpected(''']''');\r\n NextToken;\r\n LocalArgs.Count := I + 1;\r\n finally\r\n FCurrArgs.Free;\r\n FCurrArgs := LocalArgs;\r\n end;\r\nend;\r\n\r\nprocedure TJvInterpreterExpression.InternalGetValue(Obj: Pointer; ObjTyp: Word;\r\n var Result: Variant);\r\nvar\r\n Identifier: string;\r\n V: Variant;\r\n VType: TVarType;\r\n\r\n procedure UpdateVarParams;\r\n var\r\n I, C: Integer;\r\n begin\r\n if not FCurrArgs.FHasVars then\r\n Exit;\r\n C := FCurrArgs.Count;\r\n FCurrArgs.Obj := nil;\r\n FCurrArgs.ObjTyp := 0;\r\n FCurrArgs.ObjRefHolder := Unassigned;\r\n FCurrArgs.Count := 0;\r\n for I := 0 to C - 1 do\r\n if (FCurrArgs.FVarNames[I] <> '') and ((FCurrArgs.Types[I] and varByRef) <> 0) then\r\n { if not }SetValue(FCurrArgs.FVarNames[I], FCurrArgs.Values[I], FCurrArgs); { then\r\n JvInterpreterErrorN(ieUnknownIdentifier, PosBeg, FCurrArgs.VarNames[I])};\r\n FCurrArgs.FHasVars := False;\r\n end;\r\n\r\nbegin\r\n Identifier := Token;\r\n NextToken;\r\n FCurrArgs.Indexed := TTyp = ttLS;\r\n if TTyp in [ttLB, ttLS] then\r\n ReadArgs\r\n else\r\n FCurrArgs.Count := 0;\r\n FCurrArgs.Obj := Obj;\r\n FCurrArgs.ObjTyp := ObjTyp;\r\n\r\n if (TTyp = ttColon) and FAllowAssignment then\r\n begin\r\n if ObjTyp = varDispatch then\r\n FCurrArgs.ObjRefHolder := IDispatch(Obj)\r\n else\r\n if ObjTyp = varUnknown then\r\n FCurrArgs.ObjRefHolder := IUnknown(Obj);\r\n\r\n Back;\r\n FToken := Identifier; {!!!!!!!!!!!!!!}\r\n { FCurrArgs.Obj, FCurrArgs.ObjTyp, FCurrArgs.Count needed in caller }\r\n Exit;\r\n end;\r\n\r\n { need result if object field or method or assignment }\r\n FCurrArgs.HasResult := (TTyp in [ttPoint, ttRB, ttCol, ttNot..ttEquLess]) or\r\n FCurrArgs.Assignment;\r\n FCurrArgs.ReturnIndexed := False;\r\n\r\n JvInterpreterVarFree(Result);\r\n if GetValue(Identifier, Result, FCurrArgs) then\r\n begin\r\n if TVarData(Result).VType = varRecord then\r\n if not (FAdapter.SetRecord(Result) or\r\n (FAdapter <> GlobalJvInterpreterAdapter) and\r\n GlobalJvInterpreterAdapter.SetRecord(Result)) then\r\n JvInterpreterErrorN(ieRecordNotDefined, -1, RsEUnknownRecordType);\r\n { Args.HasVars may be changed in previous call to GetValue }\r\n if FCurrArgs.FHasVars then\r\n UpdateVarParams;\r\n if FCurrArgs.Indexed and not FCurrArgs.ReturnIndexed then\r\n begin\r\n JvInterpreterVarCopy(V, Result);\r\n if not GetElement(V, Result, FCurrArgs) then\r\n { problem }\r\n JvInterpreterError(ieArrayRequired, PosBeg);\r\n end;\r\n end\r\n else\r\n JvInterpreterErrorN(ieUnknownIdentifier, PosBeg {?}, Identifier);\r\n\r\n FCurrArgs.Obj := nil;\r\n FCurrArgs.ObjTyp := 0;\r\n FCurrArgs.ObjRefHolder := Unassigned;\r\n FCurrArgs.Count := 0;\r\n { FCurrArgs.Obj, FCurrArgs.ObjTyp, FCurrArgs.Count NOT needed in caller }\r\n\r\n if TTyp = ttPoint then { object field or method }\r\n begin\r\n NextToken;\r\n if TTyp <> ttIdentifier then\r\n ErrorExpected(LoadStr2(irIdentifier));\r\n VType := TVarData(Result).VType;\r\n if (VType <> varObject) and (VType <> varClass) and\r\n (VType <> varRecord) and (VType <> varDispatch) and (VType <> varUnknown) then\r\n {if not (TVarData(Result).VType in\r\n [varObject, varClass, varRecord, varDispatch, varUnknown]) then}\r\n JvInterpreterError(ieROCRequired, PosBeg);\r\n\r\n V := Null;\r\n InternalGetValue(TVarData(Result).VPointer, TVarData(Result).VType, V);\r\n JvInterpreterVarCopy(Result, V);\r\n\r\n NextToken;\r\n end;\r\n\r\n Back;\r\nend;\r\n\r\nfunction TJvInterpreterExpression.GetElement(const Variable: Variant; var Value: Variant;\r\n var Args: TJvInterpreterArgs): Boolean;\r\nvar\r\n II2: Integer;\r\n VV: TJvInterpreterArrayValues;\r\n PP: PJvInterpreterArrayRec;\r\n Bound: Integer;\r\n AI: array of Integer;\r\nbegin\r\n Result := False;\r\n if Args.Count <> 0 then\r\n begin\r\n if TVarData(Variable).VType = varString then\r\n begin\r\n if Args.Count > 1 then\r\n JvInterpreterError(ieArrayTooManyParams, -1);\r\n if Length(Variable) = 0 then\r\n raise ERangeError.CreateRes(@RsERangeCheckError);\r\n Value := string(Variable)[Integer(Args.Values[0])];\r\n Result := True;\r\n end\r\n else\r\n if TVarData(Variable).VType = varArray then\r\n begin\r\n {Get array value}\r\n PP := PJvInterpreterArrayRec(NativeInt(JvInterpreterVarAsType(Variable, varInteger)));\r\n if Args.Count > PP.Dimension then\r\n JvInterpreterError(ieArrayTooManyParams, -1)\r\n else\r\n if Args.Count < PP.Dimension then\r\n JvInterpreterError(ieArrayNotEnoughParams, -1);\r\n for II2 := 0 to Args.Count - 1 do\r\n begin\r\n Bound := Args.Values[II2];\r\n if Bound < PP.BeginPos[II2] then\r\n JvInterpreterError(ieArrayIndexOutOfBounds, -1)\r\n else\r\n if Bound > PP.EndPos[II2] then\r\n JvInterpreterError(ieArrayIndexOutOfBounds, -1);\r\n VV[II2] := Args.Values[II2];\r\n end;\r\n Value := JvInterpreterArrayGetElement(VV, PP);\r\n Result := True;\r\n end\r\n else\r\n if (TVarData(Variable).VType = varObject) or\r\n (TVarData(Variable).VType = varClass) then\r\n begin\r\n Result := FAdapter.GetElement(Self, Variable, Value, Args);\r\n if not Result and Assigned(FSharedAdapter) then\r\n Result := FSharedAdapter.GetElement(Self, Variable, Value, Args);\r\n end\r\n { for Variant Arrays }\r\n else\r\n if VarIsArray(Variable) then\r\n begin\r\n if Args.Count > VarArrayDimCount(Variable) then\r\n JvInterpreterError(ieArrayTooManyParams, -1)\r\n else\r\n if Args.Count < VarArrayDimCount(Variable) then\r\n JvInterpreterError(ieArrayNotEnoughParams, -1);\r\n AI := nil;\r\n SetLength(AI, Args.Count);\r\n for II2 := 0 to Args.Count - 1 do\r\n begin\r\n Bound := Args.Values[II2];\r\n if Bound > VarArrayHighBound(Variable, II2 + 1) then\r\n JvInterpreterError(ieArrayIndexOutOfBounds, -1);\r\n if Bound < VarArrayLowBound(Variable, II2 + 1) then\r\n JvInterpreterError(ieArrayIndexOutOfBounds, -1);\r\n AI[II2] := Bound;\r\n end;\r\n Value := VarArrayGet(Variable, AI);\r\n Result := True;\r\n end\r\n else\r\n { problem }\r\n JvInterpreterError(ieArrayRequired, CurPos);\r\n end;\r\nend;\r\n\r\nfunction TJvInterpreterExpression.SetElement(var Variable: Variant; const Value: Variant;\r\n var Args: TJvInterpreterArgs): Boolean;\r\nvar\r\n II2: Integer;\r\n VV: TJvInterpreterArrayValues;\r\n PP: PJvInterpreterArrayRec;\r\n Bound: Integer;\r\n AI: array of Integer;\r\nbegin\r\n Result := False;\r\n if Args.Count <> 0 then\r\n begin\r\n if TVarData(Variable).VType = varString then\r\n begin\r\n if Args.Count > 1 then\r\n JvInterpreterError(ieArrayTooManyParams, -1);\r\n string(TVarData(Variable).vString)[Integer(Args.Values[0])] := string(Value)[1];\r\n Result := True;\r\n end\r\n else\r\n if TVarData(Variable).VType = varArray then\r\n begin\r\n { Get array value }\r\n PP := PJvInterpreterArrayRec(NativeInt(JvInterpreterVarAsType(Variable, varInteger)));\r\n if Args.Count > PP.Dimension then\r\n JvInterpreterError(ieArrayTooManyParams, -1)\r\n else\r\n if Args.Count < PP.Dimension then\r\n JvInterpreterError(ieArrayNotEnoughParams, -1);\r\n for II2 := 0 to Args.Count - 1 do\r\n begin\r\n Bound := Args.Values[II2];\r\n if Bound < PP.BeginPos[II2] then\r\n JvInterpreterError(ieArrayIndexOutOfBounds, -1)\r\n else\r\n if Bound > PP.EndPos[II2] then\r\n JvInterpreterError(ieArrayIndexOutOfBounds, -1);\r\n VV[II2] := Args.Values[II2];\r\n end;\r\n JvInterpreterArraySetElement(VV, Value, PP);\r\n Result := True;\r\n end\r\n else\r\n if (TVarData(Variable).VType = varObject) or\r\n (TVarData(Variable).VType = varClass) then\r\n begin\r\n Result := FAdapter.SetElement(Self, Variable, Value, Args);\r\n if not Result and Assigned(FSharedAdapter) then\r\n Result := FSharedAdapter.SetElement(Self, Variable, Value, Args);\r\n end\r\n { for Variant Array }\r\n else\r\n if VarIsArray(Variable) then\r\n begin\r\n if Args.Count > VarArrayDimCount(Variable) then\r\n JvInterpreterError(ieArrayTooManyParams, -1)\r\n else\r\n if Args.Count < VarArrayDimCount(Variable) then\r\n JvInterpreterError(ieArrayNotEnoughParams, -1);\r\n AI := nil;\r\n SetLength(AI, Args.Count);\r\n for II2 := 0 to Args.Count - 1 do\r\n begin\r\n Bound := Args.Values[II2];\r\n if Bound > VarArrayHighBound(Variable, II2 + 1) then\r\n JvInterpreterError(ieArrayIndexOutOfBounds, -1);\r\n if Bound < VarArrayLowBound(Variable, II2 + 1) then\r\n JvInterpreterError(ieArrayIndexOutOfBounds, -1);\r\n AI[II2] := Bound;\r\n end;\r\n VarArrayPut(Variable, Value, AI);\r\n Result := True;\r\n end\r\n else\r\n { problem }\r\n JvInterpreterError(ieArrayRequired, CurPos);\r\n end;\r\nend;\r\n\r\nfunction TJvInterpreterExpression.GetValue(const Identifier: string; var Value: Variant;\r\n var Args: TJvInterpreterArgs): Boolean;\r\nbegin\r\n try\r\n Result := FAdapter.GetValue(Self, Identifier, Value, Args);\r\n if not Result and Assigned(FSharedAdapter) then\r\n Result := FSharedAdapter.GetValue(Self, Identifier, Value, Args);\r\n except\r\n on E: Exception do\r\n begin\r\n UpdateExceptionPos(E, '');\r\n raise;\r\n end;\r\n end;\r\n if not Result and Assigned(FOnGetValue) then\r\n FOnGetValue(Self, Identifier, Value, Args, Result);\r\nend;\r\n\r\nfunction TJvInterpreterExpression.SetValue(const Identifier: string; const Value: Variant;\r\n var Args: TJvInterpreterArgs): Boolean;\r\nbegin\r\n try\r\n Result := FAdapter.SetValue(Self, Identifier, Value, Args);\r\n if not Result and Assigned(FSharedAdapter) then\r\n Result := FSharedAdapter.SetValue(Self, Identifier, Value, Args);\r\n except\r\n on E: EJvInterpreterError do\r\n begin\r\n E.FErrPos := PosBeg;\r\n raise;\r\n end;\r\n end;\r\n if not Result and Assigned(FOnSetValue) then\r\n FOnSetValue(Self, Identifier, Value, Args, Result);\r\nend;\r\n\r\nprocedure TJvInterpreterExpression.Run;\r\nbegin\r\n Init;\r\n NextToken;\r\n FVResult := Expression1;\r\nend;\r\n\r\nprocedure TJvInterpreterExpression.SetDisableExternalFunctions(const Value: Boolean);\r\nbegin\r\n FDisableExternalFunctions := Value;\r\n FAdapter.DisableExternalFunctions := Value;\r\nend;\r\n\r\n//=== { TJvInterpreterFunction } =============================================\r\n\r\nconstructor TJvInterpreterFunction.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FFunctionStack := TList.Create;\r\n FSS := TStringList.Create;\r\n FEventList := TList.Create;\r\nend;\r\n\r\ndestructor TJvInterpreterFunction.Destroy;\r\nbegin\r\n FSS.Free;\r\n FFunctionStack.Free;\r\n ClearList(FEventList);\r\n FEventList.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvInterpreterFunction.Init;\r\nbegin\r\n inherited Init;\r\n FBreak := False;\r\n FContinue := False;\r\n FFunctionStack.Clear;\r\n FStateStackPtr := -1;\r\n FCurUnitName := '';\r\n FCurInstance := nil;\r\nend;\r\n\r\nprocedure TJvInterpreterFunction.PushState;\r\nbegin\r\n Inc(FStateStackPtr);\r\n if FStateStackPtr > High(FStateStack) then\r\n JvInterpreterError(ieInternal, -1);\r\n FStateStack[FStateStackPtr].Token := FToken;\r\n FStateStack[FStateStackPtr].TTyp := FTTyp;\r\n FStateStack[FStateStackPtr].PrevTTyp := FPrevTTyp;\r\n FStateStack[FStateStackPtr].Backed := FBacked;\r\n FStateStack[FStateStackPtr].CurPos := CurPos;\r\n FStateStack[FStateStackPtr].AllowAssignment := FAllowAssignment;\r\nend;\r\n\r\nprocedure TJvInterpreterFunction.PopState;\r\nbegin\r\n if FStateStackPtr = -1 then\r\n JvInterpreterError(ieInternal, -1);\r\n CurPos := FStateStack[FStateStackPtr].CurPos;\r\n FToken := FStateStack[FStateStackPtr].Token;\r\n FTTyp := FStateStack[FStateStackPtr].TTyp;\r\n FPrevTTyp := FStateStack[FStateStackPtr].PrevTTyp;\r\n FBacked := FStateStack[FStateStackPtr].Backed;\r\n FAllowAssignment := FStateStack[FStateStackPtr].AllowAssignment;\r\n Dec(FStateStackPtr);\r\nend;\r\n\r\nprocedure TJvInterpreterFunction.RemoveState;\r\nbegin\r\n Dec(FStateStackPtr);\r\nend;\r\n\r\nfunction TJvInterpreterFunction.GetLocalVars: TJvInterpreterVarList;\r\nbegin\r\n if FFunctionContext <> nil then\r\n Result := PFunctionContext(FFunctionContext).LocalVars\r\n else\r\n Result := nil;\r\nend;\r\n\r\nprocedure TJvInterpreterFunction.InFunction(FunctionDesc: TJvInterpreterFunctionDesc);\r\nconst\r\n cResult = 'Result';\r\nvar\r\n FunArgs: TJvInterpreterArgs;\r\n VarNames: PNameArray;\r\n\r\n procedure EnterFunction; { TJvInterpreterFunction.InFunction local: initialization/entry of function scope }\r\n var\r\n FC: PFunctionContext;\r\n I: Integer;\r\n V: Variant;\r\n begin\r\n New(PFunctionContext(FC));\r\n FillChar(FC^, SizeOf(FC^), 0);\r\n New(VarNames);\r\n PFunctionContext(FC).PrevFunContext := FFunctionContext;\r\n FFunctionContext := FC;\r\n PFunctionContext(FFunctionContext).LocalVars := TJvInterpreterVarList.Create;\r\n FFunctionStack.Add(FFunctionContext);\r\n JvInterpreterVarFree(FVResult);\r\n if FunctionDesc <> nil then\r\n begin\r\n FCurrArgs.FHasVars := False;\r\n FCurrArgs.Types := FunctionDesc.FParamTypes;\r\n for I := 0 to FCurrArgs.Count - 1 do\r\n begin\r\n if (FunctionDesc.FParamTypes[I] and varByRef) <> 0 then\r\n JvInterpreterVarCopy(V, FCurrArgs.Values[I])\r\n else\r\n JvInterpreterVarAssignment(V, FCurrArgs.Values[I]);\r\n\r\n PFunctionContext(FFunctionContext).LocalVars.AddVar('', FunctionDesc.FParamNames[I], '',\r\n FunctionDesc.FParamTypes[I], V,\r\n TJvInterpreterSimpleDataType.Create(FunctionDesc.FParamTypes[I]));\r\n VarNames^ := FunctionDesc.FParamNames;\r\n FCurrArgs.FHasVars := FCurrArgs.FHasVars or ((FunctionDesc.FParamTypes[I] and varByRef) <> 0);\r\n end;\r\n if FunctionDesc.ResTyp > 0 then\r\n begin\r\n FunctionDesc.ResDataType.Init(V);\r\n PFunctionContext(FFunctionContext).LocalVars.AddVar('', cResult, '',\r\n FunctionDesc.ResTyp, V, FunctionDesc.ResDataType);\r\n end\r\n end\r\n else\r\n PFunctionContext(FFunctionContext).LocalVars.AddVar('', cResult, '', varVariant,\r\n Null, TJvInterpreterSimpleDataType.Create(varVariant));\r\n FunArgs := FCurrArgs;\r\n FCurrArgs := TJvInterpreterArgs.Create;\r\n end;\r\n\r\n procedure LeaveFunction(Ok: Boolean); { TJvInterpreterFunction.InFunction local: finalization of function scope }\r\n var\r\n FC: PFunctionContext;\r\n C: Integer;\r\n\r\n procedure UpdateVarParams; { TJvInterpreterFunction.InFunction.LeaveFunction local. How bizarre. }\r\n var\r\n I, C: Integer;\r\n begin\r\n if not FCurrArgs.FHasVars then\r\n Exit;\r\n C := FCurrArgs.Count;\r\n FCurrArgs.Obj := nil;\r\n FCurrArgs.ObjTyp := 0;\r\n FCurrArgs.ObjRefHolder := Unassigned;\r\n FCurrArgs.Count := 0;\r\n\r\n for I := 0 to C - 1 do\r\n if (VarNames[I] <> '') and\r\n ((FCurrArgs.Types[I] and varByRef) <> 0) then\r\n GetValue(VarNames[I], FCurrArgs.Values[I], FCurrArgs);\r\n end;\r\n\r\n begin\r\n FCurrArgs.Free;\r\n FCurrArgs := FunArgs;\r\n if Ok then\r\n begin\r\n C := FCurrArgs.Count;\r\n UpdateVarParams;\r\n FCurrArgs.Count := 0;\r\n if (FunctionDesc = nil) or (FunctionDesc.ResTyp > 0) then\r\n begin\r\n { Return the 'result' value from the local function context to the\r\n FVResult: Variant property of the component }\r\n\r\n // PFunctionContext(FFunctionContext).LocalVars.GetValue('Result', FVResult, FCurrArgs);\r\n //LEAKY: TVarData(PFunctionContext(FFunctionContext).LocalVars.FindVar('', 'Result').Value).VType := varEmpty;\r\n //LEAKY: TVarData(PFunctionContext(FFunctionContext).LocalVars.FindVar('', 'Result').Value).VPointer := nil;\r\n\r\n //VARLEAKFIX begin - Feb 2004 - Warren Postma. Fix suggested by ivan_ra att mail dott ru\r\n JvInterpreterVarCopy(FVResult, LocalVars.FindVar('', cResult).Value);\r\n //VARLEAKFIX end.\r\n end;\r\n\r\n FCurrArgs.Count := C;\r\n end;\r\n FC := PFunctionContext(FFunctionContext).PrevFunContext;\r\n LocalVars.Free;\r\n Dispose(PFunctionContext(FFunctionContext));\r\n Dispose(VarNames);\r\n FFunctionStack.Delete(FFunctionStack.Count - 1);\r\n FFunctionContext := FC;\r\n end;\r\n\r\n procedure CheckNotSupportedFunctionParameters;\r\n var\r\n I: Integer;\r\n begin\r\n for I := 0 to FCurrArgs.Count - 1 do\r\n if (TVarData(FCurrArgs.Values[I]).VType = varArray)\r\n or (TVarData(FCurrArgs.Values[I]).VType = varRecord) then\r\n NotImplemented(RsEInterpreter402);\r\n end;\r\n\r\nbegin\r\n CheckNotSupportedFunctionParameters;\r\n { allocate stack }\r\n EnterFunction;\r\n try\r\n FExit := False;\r\n while True do\r\n begin\r\n case TTyp of\r\n ttBegin:\r\n begin\r\n InterpretBegin;\r\n if (TTyp <> ttSemicolon) and not FExit then\r\n ErrorExpected(''';''');\r\n Break;\r\n end;\r\n ttVar:\r\n InterpretVar(PFunctionContext(FFunctionContext).LocalVars.AddVar);\r\n ttConst:\r\n InterpretConst(PFunctionContext(FFunctionContext).LocalVars.AddVar);\r\n else\r\n ErrorExpected('''' + kwBEGIN + '''');\r\n end;\r\n NextToken;\r\n end;\r\n LeaveFunction(True);\r\n FExit := False;\r\n except\r\n on E: Exception do\r\n begin\r\n { if (E is EJvInterpreterError) and (Fun <> nil) and\r\n ((E as EJvInterpreterError).ErrUnitName = '') then }\r\n if FunctionDesc <> nil then\r\n UpdateExceptionPos(E, FunctionDesc.UnitName)\r\n else\r\n UpdateExceptionPos(E, '');\r\n LeaveFunction(False);\r\n FExit := False;\r\n raise;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJvInterpreterFunction.GetValue(const Identifier: string; var Value: Variant;\r\n var Args: TJvInterpreterArgs): Boolean;\r\nbegin\r\n Result := False;\r\n { check in local variables }\r\n try\r\n if FFunctionContext <> nil then\r\n Result := PFunctionContext(FFunctionContext).LocalVars.GetValue(Identifier, Value, Args);\r\n except\r\n on E: Exception do\r\n begin\r\n if Assigned(PFunctionContext(FFunctionContext).Fun) then\r\n UpdateExceptionPos(E, PFunctionContext(FFunctionContext).Fun.UnitName)\r\n else\r\n UpdateExceptionPos(E, '');\r\n raise;\r\n end;\r\n end;\r\n if not Result then\r\n Result := inherited GetValue(Identifier, Value, Args);\r\nend;\r\n\r\nfunction TJvInterpreterFunction.SetValue(const Identifier: string; const Value: Variant;\r\n var Args: TJvInterpreterArgs): Boolean;\r\nbegin\r\n Result := False;\r\n { check in local variables }\r\n try\r\n if FFunctionContext <> nil then\r\n Result := PFunctionContext(FFunctionContext).LocalVars.SetValue(Identifier, Value, Args);\r\n except\r\n on E: Exception do\r\n begin\r\n if Assigned(PFunctionContext(FFunctionContext).Fun) then\r\n UpdateExceptionPos(E, PFunctionContext(FFunctionContext).Fun.UnitName)\r\n else\r\n UpdateExceptionPos(E, '');\r\n raise;\r\n end;\r\n end;\r\n if not Result then\r\n Result := inherited SetValue(Identifier, Value, Args);\r\nend;\r\n\r\nprocedure TJvInterpreterFunction.DoOnStatement;\r\nbegin\r\nend;\r\n\r\n{ exit: current position set to next token }\r\n\r\nprocedure TJvInterpreterFunction.InterpretStatement;\r\nbegin\r\n DoOnStatement;\r\n case TTyp of\r\n ttIdentifier:\r\n { assignment or function call }\r\n begin\r\n InterpretIdentifier;\r\n if not (TTyp in [ttSemicolon, ttEnd, ttElse, ttUntil, ttFinally, ttExcept]) then\r\n ErrorExpected(''';''');\r\n // Back;\r\n end;\r\n ttSemicolon:\r\n ; // Back;\r\n ttEnd:\r\n ; // Back;\r\n ttBegin:\r\n InterpretBegin;\r\n ttIf:\r\n InterpretIf;\r\n ttElse:\r\n Exit;\r\n ttWhile:\r\n InterpretWhile;\r\n ttRepeat:\r\n InterpretRepeat;\r\n ttFor:\r\n InterpretFor;\r\n ttBreak:\r\n FBreak := True;\r\n ttContinue:\r\n FContinue := True;\r\n ttTry:\r\n InterpretTry;\r\n ttRaise:\r\n InterpretRaise;\r\n ttExit:\r\n FExit := True;\r\n ttCase:\r\n InterpretCase;\r\n else\r\n ErrorExpected(''';''');\r\n end;\r\nend;\r\n\r\n{ exit: current position set to next token }\r\n{ very simple version, many syntax errors are not found }\r\n\r\nprocedure TJvInterpreterFunction.SkipStatement;\r\nbegin\r\n case TTyp of\r\n ttEmpty:\r\n ErrorExpected('''' + kwEND + '''');\r\n ttIdentifier:\r\n SkipIdentifier;\r\n ttSemicolon:\r\n NextToken;\r\n ttEnd:\r\n NextToken;\r\n ttIf:\r\n begin\r\n FindToken(ttThen);\r\n NextToken;\r\n SkipStatement;\r\n if TTyp = ttElse then\r\n begin\r\n NextToken;\r\n SkipStatement;\r\n end;\r\n Exit;\r\n end;\r\n ttElse:\r\n Exit;\r\n ttWhile, ttFor:\r\n begin\r\n FindToken(ttDo);\r\n NextToken;\r\n SkipStatement;\r\n Exit;\r\n end;\r\n ttRepeat:\r\n begin\r\n SkipToUntil;\r\n SkipIdentifier;\r\n Exit;\r\n end;\r\n ttBreak, ttContinue:\r\n NextToken;\r\n ttBegin:\r\n begin\r\n SkipToEnd;\r\n Exit;\r\n end;\r\n ttTry:\r\n begin\r\n SkipToEnd;\r\n Exit;\r\n end;\r\n ttFunction, ttProcedure:\r\n ErrorExpected('''' + kwEND + '''');\r\n ttRaise:\r\n begin\r\n NextToken;\r\n SkipIdentifier;\r\n end;\r\n ttExit:\r\n NextToken;\r\n ttCase:\r\n begin\r\n SkipToEnd;\r\n Exit;\r\n end;\r\n end;\r\nend;\r\n\r\n{ out: current position set to token after end }\r\n\r\nprocedure TJvInterpreterFunction.SkipToEnd;\r\nbegin\r\n while True do\r\n begin\r\n NextToken;\r\n if TTyp = ttEnd then\r\n begin\r\n NextToken;\r\n Break;\r\n end\r\n else\r\n if TTyp in [ttBegin, ttTry, ttCase] then\r\n SkipToEnd\r\n else\r\n if TTyp = ttEmpty then\r\n ErrorExpected('''' + kwEND + '''')\r\n else\r\n if TTyp = ttDoubleQuote then\r\n NextToken\r\n else\r\n SkipStatement;\r\n if TTyp = ttEnd then\r\n begin\r\n NextToken;\r\n Break;\r\n end;\r\n end;\r\nend;\r\n\r\n{ out: current position set to token after end }\r\n\r\nprocedure TJvInterpreterFunction.SkipToUntil;\r\nbegin\r\n while True do\r\n begin\r\n NextToken;\r\n if TTyp = ttUntil then\r\n begin\r\n NextToken;\r\n Break;\r\n end\r\n else\r\n if TTyp = ttEmpty then\r\n ErrorExpected('''' + kwUNTIL + '''')\r\n else\r\n SkipStatement;\r\n if TTyp = ttUntil then\r\n begin\r\n NextToken;\r\n Break;\r\n end;\r\n end;\r\nend;\r\n\r\n{exit: current position set to next token after assignment or function call }\r\n\r\nprocedure TJvInterpreterFunction.SkipIdentifier;\r\nbegin\r\n while True do\r\n case TTyp of\r\n ttEmpty:\r\n ErrorExpected('''' + kwEND + '''');\r\n\r\n ttIdentifier..ttBoolean, ttLB, ttRB, ttCol, ttPoint, ttLS, ttRS,\r\n ttNot..ttXor, // [peter schraut: replaced ttEquLess with ttXor on 2005/08/14]\r\n ttDoubleQuote, ttTrue, ttFalse:\r\n NextToken;\r\n\r\n ttSemicolon, ttEnd, ttElse, ttUntil, ttFinally, ttExcept, ttDo, ttOf:\r\n Break;\r\n ttColon:\r\n { 'case' or assignment }\r\n begin\r\n NextToken;\r\n if TTyp <> ttEqu then\r\n begin\r\n Back;\r\n Break;\r\n end;\r\n end;\r\n else\r\n ErrorExpected(LoadStr2(irExpression));\r\n end;\r\nend;\r\n\r\nprocedure TJvInterpreterFunction.FindToken(ATTyp: TTokenKind);\r\nbegin\r\n while not (TTyp in [ATTyp, ttEmpty]) do\r\n NextToken;\r\n if TTyp = ttEmpty then\r\n ErrorExpected('''' + kwEND + '''');\r\nend;\r\n\r\nfunction TJvInterpreterFunction.NewEvent(const UnitName: string; const FunctionName,\r\n EventType: string; Instance: TObject; const APropName: string): TSimpleEvent;\r\nbegin\r\n Result := FAdapter.NewEvent(UnitName, FunctionName, EventType, Self, Instance, APropName);\r\n if not Assigned(Result) then\r\n Result := GlobalJvInterpreterAdapter.NewEvent(UnitName, FunctionName, EventType, Self, Instance, APropName);\r\n if not Assigned(Result) then\r\n JvInterpreterErrorN(ieEventNotRegistered, -1, EventType);\r\nend;\r\n\r\nfunction TJvInterpreterFunction.FindEvent(const UnitName: string;\r\n Instance: TObject; const PropName: string): TJvInterpreterEvent;\r\nvar\r\n I: Integer;\r\n Event, Event1: TJvInterpreterEvent;\r\n Method: TMethod;\r\nbegin\r\n Result := nil;\r\n Method := GetPropMethod(Instance, PropName);\r\n Event1 := TJvInterpreterEvent(Method.Data);\r\n for I := 0 to FEventList.Count - 1 do\r\n begin\r\n Event := TJvInterpreterEvent(FEventList[I]);\r\n if (Event1 = Event) or\r\n (Cmp(Event.FUnitName, UnitName) and\r\n (Event.FInstance = Instance) and\r\n Cmp(Event.FPropName, PropName)) then\r\n begin\r\n Result := Event;\r\n Exit;\r\n end;\r\n end;\r\n\r\nend;\r\n\r\nprocedure TJvInterpreterFunction.InternalSetValue(const Identifier: string);\r\nvar\r\n FunctionDesc: TJvInterpreterFunctionDesc;\r\n PropInf: PPropInfo;\r\n FunctionName: string;\r\n PopSt: Boolean;\r\n MyArgs: TJvInterpreterArgs;\r\n Variable: Variant;\r\n Method: TMethod;\r\n T: TObject;\r\n Event: TJvInterpreterEvent;\r\nbegin\r\n { may be event assignment }\r\n if (FCurrArgs.Obj <> nil) and (FCurrArgs.ObjTyp = varObject) then\r\n begin\r\n FunctionDesc := FAdapter.FindFunDesc(FCurUnitName, Token);\r\n if (FunctionDesc <> nil) or ((FunctionDesc = nil) and Cmp(Token, kwNIL)) then\r\n begin\r\n PushState;\r\n PopSt := True;\r\n try\r\n NextToken;\r\n if not (TTyp in [ttFirstExpression..ttLastExpression] - [ttSemicolon]) then\r\n begin\r\n FunctionName := Token;\r\n PropInf := GetPropInfo(FCurrArgs.Obj.ClassInfo, Identifier);\r\n if Assigned(PropInf) and (PropInf.PropType^.Kind = tkMethod) then\r\n begin\r\n { method assignment }\r\n if not Cmp(Token, kwNIL) then\r\n begin\r\n Event := FindEvent(FCurUnitName, FCurrArgs.Obj, {$IFDEF SUPPORTS_UNICODE}UTF8ToString{$ENDIF SUPPORTS_UNICODE}(PropInf^.Name));\r\n if Event <> nil then\r\n begin\r\n FEventList.Remove(Event);\r\n Event.Free;\r\n end;\r\n Method := TMethod(NewEvent(FCurUnitName, FunctionName,\r\n {$IFDEF SUPPORTS_UNICODE}UTF8ToString{$ENDIF SUPPORTS_UNICODE}(PropInf^.PropType^.Name),\r\n FCurrArgs.Obj {FCurInstance},\r\n {$IFDEF SUPPORTS_UNICODE}UTF8ToString{$ENDIF SUPPORTS_UNICODE}(PropInf^.Name)));\r\n SetMethodProp(FCurrArgs.Obj, PropInf, Method);\r\n FEventList.Add(Method.Data);\r\n end\r\n else\r\n begin //Fixed Assign nil to Method property bugs - dejoy-2004-3-13\r\n Method := GetMethodProp(FCurrArgs.Obj, PropInf);\r\n if Method.Data <> nil then\r\n begin\r\n FEventList.Remove(Method.Data);\r\n T := Method.Data;\r\n if T is TJvInterpreterEvent then\r\n T.Free;\r\n end;\r\n\r\n Method.Code := nil;\r\n Method.Data := nil;\r\n SetMethodProp(FCurrArgs.Obj, PropInf, Method);\r\n end;\r\n\r\n PopSt := False;\r\n Exit;\r\n end\r\n else\r\n if FAdapter.IsEvent(FCurrArgs.Obj, Identifier) then { check only local adapter }\r\n begin\r\n if not SetValue(Identifier, FunctionName, FCurrArgs) then\r\n JvInterpreterErrorN(ieUnknownIdentifier, PosBeg, Identifier);\r\n PopSt := False;\r\n Exit;\r\n end;\r\n end;\r\n finally\r\n if PopSt then\r\n PopState\r\n else\r\n RemoveState;\r\n end;\r\n //Exit;\r\n end;\r\n end;\r\n { normal (not method) assignmnent }\r\n JvInterpreterVarFree(FVResult);\r\n { push args }\r\n MyArgs := FCurrArgs;\r\n FCurrArgs := TJvInterpreterArgs.Create;\r\n try\r\n FCurrArgs.Assignment := True;\r\n JvInterpreterVarCopy(FVResult, Expression1);\r\n finally\r\n { pop args }\r\n FCurrArgs.Free;\r\n FCurrArgs := MyArgs;\r\n end;\r\n if FCurrArgs.Indexed then\r\n begin\r\n MyArgs := TJvInterpreterArgs.Create;\r\n MyArgs.Obj := FCurrArgs.Obj;\r\n MyArgs.ObjTyp := FCurrArgs.ObjTyp;\r\n try\r\n if GetValue(Identifier, Variable, MyArgs) then\r\n begin\r\n if not SetElement(Variable, FVResult, FCurrArgs) then\r\n { problem }\r\n JvInterpreterError(ieArrayRequired, PosBeg);\r\n if (TVarData(Variable).VType = varString) and\r\n not SetValue(Identifier, Variable, MyArgs) then\r\n JvInterpreterErrorN(ieUnknownIdentifier, PosBeg, Identifier);\r\n if VarIsArray(Variable) and\r\n not SetValue(Identifier, Variable, MyArgs) then\r\n JvInterpreterErrorN(ieUnknownIdentifier, PosBeg, Identifier);\r\n end\r\n else\r\n if not SetValue(Identifier, FVResult, FCurrArgs) then\r\n JvInterpreterErrorN(ieUnknownIdentifier, PosBeg, Identifier);\r\n finally\r\n MyArgs.Free;\r\n end;\r\n end\r\n else\r\n if not SetValue(Identifier, FVResult, FCurrArgs) then\r\n JvInterpreterErrorN(ieUnknownIdentifier, PosBeg, Identifier);\r\nend;\r\n\r\nprocedure TJvInterpreterFunction.InterpretIdentifier;\r\nvar\r\n Identifier: string;\r\nbegin\r\n Identifier := Token;\r\n FCurrArgs.Clear;\r\n NextToken;\r\n if TTyp <> ttColon then\r\n begin\r\n Back;\r\n FCurrArgs.Assignment := False;\r\n InternalGetValue(nil, 0, FVResult);\r\n Identifier := Token; { Back! }\r\n NextToken;\r\n end;\r\n if TTyp = ttColon then { assignment }\r\n begin\r\n NextToken;\r\n if TTyp <> ttEqu then\r\n ErrorExpected('''=''');\r\n NextToken;\r\n InternalSetValue(Identifier);\r\n end;\r\nend;\r\n\r\n{exit: current position set to next token after \"end\"}\r\n\r\nprocedure TJvInterpreterFunction.InterpretBegin;\r\nbegin\r\n NextToken;\r\n while True do\r\n begin\r\n case TTyp of\r\n ttEnd:\r\n begin\r\n NextToken;\r\n Exit;\r\n end;\r\n ttElse, ttDo:\r\n ErrorExpected(LoadStr2(irStatement));\r\n ttSemicolon:\r\n begin\r\n DoOnStatement;\r\n NextToken;\r\n end;\r\n ttIdentifier, ttBegin, ttIf, ttWhile, ttFor, ttRepeat,\r\n ttBreak, ttContinue, ttTry, ttRaise, ttExit, ttCase:\r\n InterpretStatement;\r\n else\r\n ErrorExpected('''' + kwEND + '''');\r\n end;\r\n if FBreak or FContinue or FExit then\r\n Exit;\r\n end;\r\nend;\r\n\r\n{ exit: current position set to next token after if block }\r\n\r\nprocedure TJvInterpreterFunction.InterpretIf;\r\nvar\r\n Condition: Variant;\r\nbegin\r\n NextToken;\r\n Condition := Expression2(varBoolean);\r\n if TTyp <> ttThen then\r\n ErrorExpected('''' + kwTHEN + '''');\r\n NextToken;\r\n if TVarData(Condition).VBoolean then\r\n begin\r\n InterpretStatement;\r\n // NextToken; {!!!????}\r\n if TTyp = ttElse then\r\n begin\r\n NextToken;\r\n SkipStatement;\r\n // Back; {!!!????}\r\n end;\r\n end\r\n else\r\n begin\r\n SkipStatement;\r\n if TTyp = ttElse then\r\n begin\r\n NextToken;\r\n InterpretStatement;\r\n end\r\n { else\r\n if TTyp = ttSemicolon then\r\n begin\r\n NextToken;\r\n if TTyp = ttElse then\r\n JvInterpreterError(ieNotAllowedBeforeElse, PosBeg)\r\n end; }\r\n end;\r\nend;\r\n\r\n{ exit: current position set to next token after loop }\r\n\r\nprocedure TJvInterpreterFunction.InterpretWhile;\r\nvar\r\n WhileCurPos: Integer;\r\n WhilePos: Integer;\r\n Condition: Variant;\r\nbegin\r\n PushState;\r\n try\r\n WhilePos := PosEnd;\r\n WhileCurPos := CurPos;\r\n while True do\r\n begin\r\n NextToken;\r\n Condition := Expression1;\r\n if TVarData(Condition).VType <> varBoolean then\r\n JvInterpreterError(ieBooleanRequired, WhilePos);\r\n if TTyp <> ttDo then\r\n ErrorExpected('''' + kwDO + '''');\r\n NextToken;\r\n if TVarData(Condition).VBoolean then\r\n begin\r\n FContinue := False;\r\n FBreak := False;\r\n InterpretStatement;\r\n if FBreak or FExit then\r\n Break;\r\n end\r\n else\r\n Break;\r\n CurPos := WhileCurPos;\r\n end;\r\n finally\r\n PopState;\r\n end;\r\n SkipStatement;\r\n FContinue := False;\r\n FBreak := False;\r\nend;\r\n\r\n{ exit: current position set to next token after loop }\r\n\r\nprocedure TJvInterpreterFunction.InterpretRepeat;\r\nvar\r\n RepeatCurPos: Integer;\r\n Condition: Variant;\r\nbegin\r\n RepeatCurPos := CurPos;\r\n while True do\r\n begin\r\n NextToken;\r\n case TTyp of\r\n ttElse, ttDo:\r\n ErrorExpected(LoadStr2(irStatement));\r\n ttSemicolon:\r\n DoOnStatement;\r\n ttIdentifier, ttBegin, ttIf, ttWhile, ttFor, ttRepeat,\r\n ttBreak, ttContinue, ttTry, ttRaise, ttExit, ttCase:\r\n begin\r\n FContinue := False;\r\n FBreak := False;\r\n InterpretStatement;\r\n if FBreak or FExit then\r\n Break;\r\n end;\r\n ttUntil:\r\n begin\r\n NextToken;\r\n Condition := Expression1;\r\n if TVarData(Condition).VType <> varBoolean then\r\n JvInterpreterError(ieBooleanRequired, CurPos);\r\n if TVarData(Condition).VBoolean then\r\n Break\r\n else\r\n CurPos := RepeatCurPos;\r\n end;\r\n else\r\n ErrorExpected('''' + kwUNTIL + '''');\r\n end;\r\n end;\r\n if FBreak or FExit then\r\n begin\r\n SkipToUntil;\r\n SkipIdentifier;\r\n end;\r\n FContinue := False;\r\n FBreak := False;\r\nend;\r\n\r\n{ exit: current position set to next token after loop }\r\n\r\nprocedure TJvInterpreterFunction.InterpretFor;\r\nvar\r\n I: Integer;\r\n DoCurPos: Integer;\r\n iBeg, iEnd: Integer;\r\n LoopVariable: string;\r\n ForwardDirection: Boolean;\r\nbegin\r\n NextToken;\r\n if TTyp <> ttIdentifier then\r\n ErrorExpected(LoadStr2(irIdentifier));\r\n // CheckLocalIdentifier;\r\n LoopVariable := Token;\r\n NextToken;\r\n if TTyp <> ttColon then\r\n ErrorExpected(''':''');\r\n NextToken;\r\n if TTyp <> ttEqu then\r\n ErrorExpected('''=''');\r\n NextToken;\r\n iBeg := Expression2(varInteger);\r\n if (TTyp <> ttTo) and (TTyp <> ttDownTo) then\r\n ErrorExpected('''' + kwTO + RsEXOrX + kwDOWNTO + '''');\r\n ForwardDirection := TTyp = ttTo;\r\n\r\n NextToken;\r\n iEnd := Expression2(varInteger);\r\n if TTyp <> ttDo then\r\n ErrorExpected('''' + kwDO + '''');\r\n DoCurPos := CurPos;\r\n NextToken;\r\n\r\n if ForwardDirection then\r\n begin\r\n for I := iBeg to iEnd do\r\n begin\r\n FCurrArgs.Clear;\r\n if not SetValue(LoopVariable, I, FCurrArgs) then\r\n JvInterpreterErrorN(ieUnknownIdentifier, PosBeg, LoopVariable);\r\n FContinue := False;\r\n FBreak := False;\r\n InterpretStatement;\r\n if FBreak or FExit then\r\n begin\r\n CurPos := DoCurPos;\r\n NextToken;\r\n Break;\r\n end;\r\n CurPos := DoCurPos;\r\n NextToken;\r\n end;\r\n end\r\n else\r\n begin\r\n for I := iBeg downto iEnd do\r\n begin\r\n FCurrArgs.Clear;\r\n if not SetValue(LoopVariable, I, FCurrArgs) then\r\n JvInterpreterErrorN(ieUnknownIdentifier, PosBeg, LoopVariable);\r\n FContinue := False;\r\n FBreak := False;\r\n InterpretStatement;\r\n if FBreak or FExit then\r\n begin\r\n CurPos := DoCurPos;\r\n NextToken;\r\n Break;\r\n end;\r\n CurPos := DoCurPos;\r\n NextToken;\r\n end;\r\n end;\r\n\r\n SkipStatement;\r\n FContinue := False;\r\n FBreak := False;\r\nend;\r\n\r\n{ exit: current position set to next token after case }\r\n\r\nprocedure TJvInterpreterFunction.InterpretCase;\r\nvar\r\n Selector, Expression, I: Integer;\r\n ExpressionArray: array of array [0..1] of Integer;\r\n\r\n function InCase(CaseSel: Integer): Boolean;\r\n var\r\n I: Integer;\r\n begin\r\n Result := False;\r\n for I := 0 to Length(ExpressionArray) - 1 do\r\n if (CaseSel >= ExpressionArray[I][0]) and (CaseSel <= ExpressionArray[I][1]) then\r\n begin\r\n Result := True;\r\n Exit;\r\n end;\r\n end;\r\n\r\nbegin\r\n NextToken;\r\n Selector := Expression2(varInteger);\r\n if TTyp <> ttOf then\r\n ErrorExpected('''' + kwOF + '''');\r\n while True do\r\n begin\r\n NextToken;\r\n case TTyp of\r\n ttIdentifier, ttInteger:\r\n begin\r\n ExpressionArray := nil;\r\n SetLength(ExpressionArray, 1);\r\n I := 0;\r\n while True do\r\n begin\r\n Expression := Expression2(varInteger);\r\n ExpressionArray[Length(ExpressionArray) - 1][I] := Expression;\r\n if TTyp = ttDoublePoint then\r\n I := 1\r\n else\r\n if TTyp = ttCol then\r\n begin\r\n if I = 0 then\r\n ExpressionArray[Length(ExpressionArray) - 1][1] := Expression\r\n else\r\n I := 0;\r\n SetLength(ExpressionArray, Length(ExpressionArray) + 1);\r\n end\r\n else\r\n begin\r\n if I = 0 then\r\n ExpressionArray[Length(ExpressionArray) - 1][1] := Expression;\r\n Break;\r\n end;\r\n NextToken;\r\n end;\r\n if TTyp <> ttColon then\r\n ErrorExpected('''' + ':' + '''');\r\n NextToken;\r\n if InCase(Selector) then\r\n begin\r\n ExpressionArray := nil;\r\n InterpretStatement;\r\n SkipToEnd;\r\n Break;\r\n end\r\n else\r\n SkipStatement;\r\n end;\r\n ttElse:\r\n begin\r\n NextToken;\r\n InterpretStatement;\r\n SkipToEnd;\r\n Break;\r\n end;\r\n ttEnd:\r\n begin\r\n NextToken;\r\n Break;\r\n end;\r\n else\r\n ErrorExpected('''' + kwEND + '''');\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvInterpreterFunction.InterpretVar(AddVarFunc: TJvInterpreterAddVarFunc);\r\nvar\r\n I: Integer;\r\n Value: Variant;\r\n TypName: string;\r\n// Typ: Word;\r\n DT: IJvInterpreterDataType;\r\n {----olej----}\r\n {Temporary for array type}\r\n// ArrayType: Integer;\r\n// Dimension: Integer;\r\n {----olej----}\r\nbegin\r\n repeat\r\n FSS.Clear;\r\n repeat\r\n NextToken;\r\n if TTyp <> ttIdentifier then\r\n ErrorExpected(LoadStr2(irIdentifier));\r\n FSS.Add(Token);\r\n NextToken;\r\n until TTyp <> ttCol;\r\n if TTyp <> ttColon then\r\n ErrorExpected(''':''');\r\n NextToken;\r\n TypName := Token;\r\n DT := ParseDataType;\r\n for I := 0 to FSS.Count - 1 do\r\n begin\r\n DT.Init(Value);\r\n AddVarFunc(FCurUnitName, FSS[I], TypName, DT.GetTyp, Value, DT);\r\n end;\r\n FSS.Clear;\r\n NextToken;\r\n if TTyp <> ttSemicolon then\r\n ErrorExpected(''';''');\r\n NextToken;\r\n Back;\r\n until TTyp <> ttIdentifier;\r\nend;\r\n\r\nprocedure TJvInterpreterFunction.InterpretConst(AddVarFunc: TJvInterpreterAddVarFunc);\r\nvar\r\n Identifier: string;\r\n Value: Variant;\r\nbegin\r\n repeat\r\n NextToken;\r\n if TTyp <> ttIdentifier then\r\n ErrorExpected(LoadStr2(irIdentifier));\r\n Identifier := Token;\r\n NextToken;\r\n if TTyp <> ttEqu then\r\n ErrorExpected('=');\r\n NextToken;\r\n Value := Expression1;\r\n\r\n AddVarFunc(FCurUnitName, Identifier, '', varEmpty, Value,\r\n TJvInterpreterSimpleDataType.Create(VarType(Value)));\r\n if TTyp <> ttSemicolon then\r\n ErrorExpected(''';''');\r\n NextToken;\r\n Back;\r\n until TTyp <> ttIdentifier;\r\nend;\r\n\r\nprocedure TJvInterpreterFunction.InterpretTry;\r\nvar\r\n ReRaiseException: Boolean;\r\n\r\n procedure FindFinallyExcept;\r\n begin\r\n while True do\r\n begin\r\n case TTyp of\r\n ttEmpty:\r\n ErrorExpected('''' + kwEND + '''');\r\n ttSemicolon:\r\n ;\r\n ttFinally, ttExcept:\r\n Exit;\r\n else\r\n SkipStatement;\r\n end;\r\n NextToken;\r\n end;\r\n end;\r\n\r\n procedure InterpretExcept(E: Exception);\r\n var\r\n ExceptionClassName, ExceptionVarName: string;\r\n ExceptionClass: TClass;\r\n V: Variant;\r\n\r\n function On1: Boolean;\r\n begin\r\n NextToken;\r\n if TTyp <> ttIdentifier then\r\n ErrorExpected(LoadStr2(irIdentifier));\r\n ExceptionClassName := Token;\r\n NextToken;\r\n if TTyp = ttColon then\r\n begin\r\n NextToken;\r\n if TTyp <> ttIdentifier then\r\n ErrorExpected(LoadStr2(irIdentifier));\r\n ExceptionVarName := ExceptionClassName;\r\n ExceptionClassName := Token;\r\n NextToken;\r\n end;\r\n FCurrArgs.Clear;\r\n if not GetValue(ExceptionClassName, V, FCurrArgs) then\r\n JvInterpreterErrorN(ieUnknownIdentifier, PosBeg {?}, ExceptionClassName);\r\n if VarType(V) <> varClass then\r\n JvInterpreterError(ieClassRequired, PosBeg {?});\r\n ExceptionClass := V2C(V);\r\n if TTyp <> ttDo then\r\n ErrorExpected('''' + kwDO + '''');\r\n Result := E is ExceptionClass;\r\n if Result then\r\n { do this 'on' section }\r\n begin\r\n NextToken;\r\n PFunctionContext(FFunctionContext).LocalVars.AddVar('', ExceptionVarName,\r\n ExceptionClassName, varObject, O2V(E),\r\n TJvInterpreterSimpleDataType.Create(varObject));\r\n try\r\n InterpretStatement;\r\n finally\r\n PFunctionContext(FFunctionContext).LocalVars.DeleteVar('', ExceptionVarName);\r\n end;\r\n SkipToEnd;\r\n end\r\n else\r\n begin\r\n NextToken;\r\n SkipStatement;\r\n { if TTyp = ttSemicolon then\r\n NextToken; }\r\n end;\r\n end;\r\n\r\n begin\r\n NextToken;\r\n if TTyp = ttOn then\r\n begin\r\n if On1 then\r\n begin\r\n ReRaiseException := False;\r\n Exit;\r\n end;\r\n while True do\r\n begin\r\n NextToken;\r\n case TTyp of\r\n ttEmpty:\r\n ErrorExpected('''' + kwEND + '''');\r\n ttOn:\r\n if On1 then\r\n begin\r\n ReRaiseException := False;\r\n Exit;\r\n end;\r\n ttEnd:\r\n begin\r\n ReRaiseException := True;\r\n Exit;\r\n end;\r\n ttElse:\r\n begin\r\n NextToken;\r\n InterpretStatement;\r\n NextToken;\r\n if TTyp = ttSemicolon then\r\n NextToken;\r\n if TTyp <> ttEnd then\r\n ErrorExpected('''' + kwEND + '''');\r\n Exit;\r\n end;\r\n else\r\n ErrorExpected('''' + kwEND + '''');\r\n end;\r\n end;\r\n end\r\n else\r\n begin\r\n Back;\r\n InterpretBegin;\r\n end;\r\n end;\r\n\r\n procedure DoFinallyExcept(E: Exception);\r\n var\r\n OldExit: Boolean;\r\n begin\r\n OldExit := FExit;\r\n try\r\n FExit := False;\r\n case TTyp of\r\n ttFinally:\r\n { do statements up to 'end' }\r\n begin\r\n InterpretBegin;\r\n if E <> nil then\r\n ReRaiseException := True;\r\n end;\r\n ttExcept:\r\n begin\r\n if E = nil then\r\n { skip except section }\r\n SkipToEnd\r\n else\r\n { except section }\r\n begin\r\n try\r\n InterpretExcept(E);\r\n FLastError.Clear;\r\n except\r\n on E1: EJvInterpreterError do\r\n begin\r\n if E1.ErrCode = ieRaise then\r\n ReRaiseException := True;\r\n end\r\n else\r\n raise;\r\n end;\r\n end;\r\n end;\r\n end;\r\n finally\r\n FExit := FExit or OldExit;\r\n end;\r\n end;\r\n\r\nbegin\r\n NextToken;\r\n while True do\r\n begin\r\n case TTyp of\r\n ttFinally:\r\n begin\r\n DoFinallyExcept(nil);\r\n Exit;\r\n end;\r\n ttExcept:\r\n begin\r\n DoFinallyExcept(nil);\r\n Exit;\r\n end;\r\n ttSemicolon:\r\n begin\r\n DoOnStatement;\r\n NextToken;\r\n end;\r\n ttIdentifier, ttBegin, ttIf, ttWhile, ttFor, ttRepeat,\r\n ttBreak, ttContinue, ttTry, ttRaise, ttExit, ttCase:\r\n begin\r\n try\r\n InterpretStatement;\r\n if FBreak or FContinue or FExit then\r\n begin\r\n FindFinallyExcept;\r\n DoFinallyExcept(nil);\r\n Exit;\r\n end;\r\n except\r\n on E: Exception do\r\n begin\r\n FindFinallyExcept;\r\n\r\n ReRaiseException := False;\r\n DoFinallyExcept(E);\r\n\r\n if ReRaiseException then\r\n raise\r\n else\r\n Exit;\r\n end;\r\n end;\r\n end;\r\n else\r\n ErrorExpected('''' + kwFINALLY + '''');\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvInterpreterFunction.InterpretRaise;\r\nvar\r\n V: Variant;\r\nbegin\r\n NextToken;\r\n case TTyp of\r\n ttEmpty, ttSemicolon, ttEnd, ttBegin, ttElse, ttFinally, ttExcept:\r\n { re-raising exception }\r\n raise EJvInterpreterError.Create(ieRaise, PosBeg, '', '');\r\n ttIdentifier:\r\n begin\r\n InternalGetValue(nil, 0, V);\r\n if VarType(V) <> varObject then\r\n JvInterpreterError(ieClassRequired, PosBeg {?});\r\n UpdateExceptionPos(Exception(V2O(V)), '');\r\n raise V2O(V);\r\n end;\r\n else\r\n JvInterpreterError(ieClassRequired, PosBeg {?});\r\n end;\r\nend;\r\n\r\nprocedure TJvInterpreterFunction.Run;\r\nbegin\r\n Init;\r\n NextToken;\r\n InFunction(nil);\r\nend;\r\n\r\nfunction TJvInterpreterFunction.GetFunStackCount: Integer;\r\nbegin\r\n Result := FFunctionStack.Count;\r\nend;\r\n\r\nfunction TJvInterpreterFunction.ParseDataType: IJvInterpreterDataType;\r\nvar\r\n TypName: string;\r\n Typ: Word;\r\n ArrayBegin, ArrayEnd: TJvInterpreterArrayValues;\r\n TempBegin, TempEnd: Integer;\r\n ArrayType: Integer;\r\n Dimension: Integer;\r\n Minus1, Minus2: Boolean;\r\n //\r\n JvInterpreterRecord: TJvInterpreterRecord;\r\n ArrayDT: IJvInterpreterDataType;\r\nbegin\r\n //NextToken;\r\n TypName := Token;\r\n Dimension := 0;\r\n if TTyp = ttIdentifier then\r\n begin\r\n Typ := TypeName2VarTyp(TypName);\r\n JvInterpreterRecord := TJvInterpreterRecord(FAdapter.GetRec(TypName));\r\n if JvInterpreterRecord = nil then\r\n JvInterpreterRecord := TJvInterpreterRecord(GlobalJvInterpreterAdapter.GetRec(TypName));\r\n if JvInterpreterRecord <> nil then\r\n Result := TJvInterpreterRecordDataType.Create(JvInterpreterRecord)\r\n else\r\n Result := TJvInterpreterSimpleDataType.Create(Typ);\r\n end\r\n else\r\n if TTyp = ttArray then\r\n begin\r\n { Get Array variables params }\r\n { This code is not very clear }\r\n // Typ := varArray;\r\n NextToken;\r\n if (TTyp <> ttLS) and (TTyp <> ttOf) then\r\n ErrorExpected('''[' + RsEXOrX + kwOF + '''');\r\n { Parse Array Range }\r\n if TTyp = ttLS then\r\n begin\r\n Dimension := 0;\r\n repeat\r\n NextToken;\r\n Minus1 := False;\r\n if (Trim(FTokenStr) = '-') then\r\n begin\r\n Minus1 := True;\r\n NextToken;\r\n end;\r\n TempBegin := StrToInt(FTokenStr);\r\n try\r\n ArrayBegin[Dimension] := TempBegin;\r\n if Minus1 then\r\n ArrayBegin[Dimension] := ArrayBegin[Dimension] * (-1);\r\n except\r\n ErrorExpected(LoadStr2(irIntegerValue));\r\n end;\r\n\r\n NextToken;\r\n if TTyp <> ttDoublePoint then\r\n ErrorExpected('''..''');\r\n\r\n NextToken;\r\n Minus2 := False;\r\n if (Trim(FTokenStr) = '-') then\r\n begin\r\n Minus2 := True;\r\n NextToken;\r\n end;\r\n TempEnd := StrToInt(FTokenStr);\r\n try\r\n ArrayEnd[Dimension] := TempEnd;\r\n except\r\n if Minus2 then\r\n ArrayEnd[Dimension] := ArrayEnd[Dimension] * (-1);\r\n ErrorExpected(LoadStr2(irIntegerValue));\r\n end;\r\n\r\n if (Dimension < 0) or (Dimension > cJvInterpreterMaxArgs) then\r\n JvInterpreterError(ieArrayBadDimension, CurPos);\r\n if not (ArrayBegin[Dimension] <= ArrayEnd[Dimension]) then\r\n JvInterpreterError(ieArrayBadRange, CurPos);\r\n {End Array Range}\r\n NextToken;\r\n Inc(Dimension);\r\n until TTyp <> ttCol; { , }\r\n\r\n if TTyp <> ttRS then\r\n ErrorExpected(''']''');\r\n NextToken;\r\n if TTyp <> ttOf then\r\n ErrorExpected('''' + kwOF + '''');\r\n end\r\n else\r\n if TTyp = ttOf then\r\n begin\r\n Dimension := 1;\r\n ArrayBegin[0] := 0;\r\n ArrayEnd[0] := -1;\r\n end;\r\n NextToken;\r\n ArrayType := TypeName2VarTyp(Token);\r\n // recursion for arrays\r\n ArrayDT := ParseDataType;\r\n\r\n Result := TJvInterpreterArrayDataType.Create(ArrayBegin, ArrayEnd, Dimension, ArrayType, ArrayDT);\r\n { end: var A: array [1..200] of Integer, parsing }\r\n end\r\n else\r\n ErrorExpected(LoadStr2(irIdentifier));\r\nend;\r\n\r\n//=== { TJvInterpreterUnit } =================================================\r\n\r\nconstructor TJvInterpreterUnit.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FClearUnits := True;\r\n FEventHandlerList := TList.Create;\r\nend;\r\n\r\ndestructor TJvInterpreterUnit.Destroy;\r\nbegin\r\n ClearList(FEventHandlerList);\r\n FEventHandlerList.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvInterpreterUnit.Init;\r\nbegin\r\n inherited Init;\r\n if FClearUnits then\r\n begin\r\n FAdapter.ClearSource;\r\n FUnitSection := usUnknown;\r\n ClearList(FEventHandlerList);\r\n end;\r\nend;\r\n\r\nprocedure TJvInterpreterUnit.ReadFunctionHeader(FunctionDesc: TJvInterpreterFunctionDesc);\r\nvar\r\n TypName: string;\r\n Fun: Boolean;\r\n\r\n procedure ReadParams;\r\n var\r\n VarParam, VarConst: Boolean;\r\n ParamType: string;\r\n iBeg: Integer;\r\n begin\r\n while True do\r\n begin\r\n VarParam := False;\r\n VarConst := False;\r\n NextToken;\r\n FunctionDesc.FParamNames[FunctionDesc.ParamCount] := Token;\r\n if TTyp = ttRB then\r\n Break;\r\n if TTyp = ttVar then\r\n begin\r\n VarParam := True;\r\n NextToken;\r\n end;\r\n if TTyp = ttConst then\r\n begin\r\n VarConst := True;\r\n// NextToken;\r\n end;\r\n iBeg := FunctionDesc.ParamCount;\r\n while True do\r\n begin\r\n case TTyp of\r\n ttIdentifier:\r\n FunctionDesc.FParamNames[FunctionDesc.ParamCount] := Token;\r\n ttSemicolon: Break;\r\n ttRB: Exit;\r\n ttColon:\r\n begin\r\n NextToken;\r\n if TTyp <> ttIdentifier then\r\n ErrorExpected(LoadStr2(irIdentifier));\r\n ParamType := Token;\r\n while True do\r\n begin\r\n if TTyp = ttRB then\r\n Back;\r\n if TTyp in [ttRB, ttSemicolon] then\r\n Break;\r\n NextToken;\r\n end;\r\n FunctionDesc.FParamTypeNames[FunctionDesc.FParamCount] := ParamType; // for ParamTypeNames\r\n Inc(FunctionDesc.FParamCount);\r\n while iBeg < FunctionDesc.FParamCount do\r\n begin\r\n FunctionDesc.FParamTypeNames[iBeg] := ParamType; // for ParamTypeNames\r\n FunctionDesc.FParamTypes[iBeg] := TypeName2VarTyp(ParamType);\r\n if VarParam then\r\n FunctionDesc.FParamTypes[iBeg] := FunctionDesc.FParamTypes[iBeg] or\r\n varByRef;\r\n if VarConst then\r\n FunctionDesc.FParamTypes[iBeg] := FunctionDesc.FParamTypes[iBeg] or\r\n varByConst;\r\n\r\n Inc(iBeg);\r\n end;\r\n Break;\r\n end;\r\n ttCol:\r\n Inc(FunctionDesc.FParamCount);\r\n end;\r\n NextToken;\r\n end;\r\n end;\r\n end;\r\n\r\nbegin\r\n Fun := TTyp = ttFunction;\r\n NextToken;\r\n if TTyp <> ttIdentifier then\r\n ErrorExpected(LoadStr2(irIdentifier));\r\n FunctionDesc.FIdentifier := Token;\r\n NextToken;\r\n if TTyp = ttPoint then\r\n begin\r\n FunctionDesc.FClassIdentifier := FunctionDesc.FIdentifier;\r\n NextToken;\r\n if TTyp <> ttIdentifier then\r\n ErrorExpected(LoadStr2(irIdentifier));\r\n FunctionDesc.FIdentifier := Token;\r\n NextToken;\r\n end;\r\n FunctionDesc.FResTyp := varEmpty;\r\n FunctionDesc.FParamCount := 0;\r\n if TTyp = ttLB then\r\n begin\r\n // NextToken;\r\n ReadParams;\r\n NextToken;\r\n end;\r\n if Fun then\r\n if (TTyp = ttColon) then\r\n begin\r\n NextToken;\r\n if TTyp <> ttIdentifier then\r\n ErrorExpected(LoadStr2(irIdentifier));\r\n TypName := Token;\r\n FunctionDesc.FResDataType := ParseDataType;\r\n FunctionDesc.FResTyp := FunctionDesc.FResDataType.GetTyp;\r\n FunctionDesc.FResTypName := TypName;\r\n\r\n if FunctionDesc.FResTyp = 0 then\r\n FunctionDesc.FResTyp := varVariant;\r\n NextToken;\r\n end\r\n else\r\n ErrorExpected(''':''');\r\n if TTyp <> ttSemicolon then\r\n ErrorExpected(''';''');\r\nend;\r\n\r\nprocedure TJvInterpreterUnit.InterpretFunction;\r\nvar\r\n FunctionDesc: TJvInterpreterFunctionDesc;\r\n FunctionName: string;\r\n FunctionIndex: Integer;\r\n DllName: string;\r\n LastTTyp: TTokenKind;\r\nbegin\r\n FunctionDesc := TJvInterpreterFunctionDesc.Create;\r\n try\r\n ReadFunctionHeader(FunctionDesc);\r\n FunctionDesc.FPosBeg := CurPos;\r\n LastTTyp := TTyp;\r\n NextToken;\r\n if TTyp = ttExternal then\r\n begin\r\n NextToken;\r\n if TTyp = ttString then\r\n DllName := Token\r\n else\r\n if TTyp = ttIdentifier then\r\n begin\r\n FCurrArgs.Clear;\r\n if not GetValue(Token, FVResult, FCurrArgs) then\r\n JvInterpreterErrorN(ieUnknownIdentifier, PosBeg, Token);\r\n DllName := VResult;\r\n end\r\n else\r\n ErrorExpected(LoadStr2(irStringConstant)); {DEBUG!!!}\r\n NextToken;\r\n if TTyp <> ttIdentifier then\r\n ErrorExpected('''' + drNAME + RsEXOrX + drINDEX + '''');\r\n FunctionIndex := -1;\r\n FunctionName := '';\r\n if Cmp(Token, drNAME) then\r\n begin\r\n NextToken;\r\n if TTyp = ttString then\r\n FunctionName := Token\r\n else\r\n ErrorExpected(LoadStr2(irStringConstant)); {DEBUG!!!}\r\n end\r\n else\r\n if Cmp(Token, drINDEX) then\r\n begin\r\n NextToken;\r\n if TTyp = ttInteger then\r\n FunctionIndex := Token\r\n else\r\n ErrorExpected(LoadStr2(irIntegerConstant)); {DEBUG!!!}\r\n end\r\n else\r\n ErrorExpected('''' + drNAME + RsEXOrX + drINDEX + '''');\r\n with FunctionDesc do\r\n FAdapter.AddExtFun(FCurUnitName {??!!}, FIdentifier, noInstance, DllName,\r\n FunctionName, FunctionIndex, FParamCount, FParamTypes, FResTyp);\r\n NextToken;\r\n end\r\n else\r\n if FUnitSection = usInterface then\r\n begin\r\n CurPos := FunctionDesc.FPosBeg;\r\n FTTyp := LastTTyp;\r\n end\r\n else\r\n begin\r\n FindToken(ttBegin);\r\n SkipToEnd;\r\n with FunctionDesc do\r\n FAdapter.AddSrcFun(FCurUnitName {??!!}, FIdentifier, FClassIdentifier, FPosBeg, CurPos,\r\n FParamCount, FParamTypes, FParamTypeNames, FParamNames, FResTyp, FResTypName, FResDataType,\r\n nil);\r\n end;\r\n finally\r\n FunctionDesc.Free;\r\n end;\r\nend;\r\n\r\nprocedure TJvInterpreterUnit.ReadUnit(const UnitName: string);\r\nvar\r\n OldUnitName: string;\r\n OldSource: string;\r\n S: string;\r\nbegin\r\n if FAdapter.UnitExists(UnitName) then\r\n Exit;\r\n FAdapter.AddSrcUnit(FCurUnitName, '', '');\r\n OldUnitName := FCurUnitName;\r\n OldSource := Source;\r\n PushState;\r\n try\r\n try\r\n if not GetUnitSource(UnitName, S) then\r\n JvInterpreterErrorN(ieUnitNotFound, PosBeg, UnitName);\r\n FCurUnitName := UnitName;\r\n Source := S;\r\n NextToken;\r\n if TTyp <> ttUnit then\r\n ErrorExpected('''' + kwUNIT + '''');\r\n InterpretUnit;\r\n except\r\n on E: Exception do\r\n begin\r\n UpdateExceptionPos(E, FCurUnitName);\r\n raise;\r\n end;\r\n end\r\n finally\r\n FCurUnitName := OldUnitName;\r\n Source := OldSource;\r\n PopState;\r\n end;\r\nend;\r\n\r\nprocedure TJvInterpreterUnit.InterpretUses(var UsesList: string);\r\nbegin\r\n NextToken;\r\n if not (TTyp in [ttIdentifier, ttString]) then\r\n ErrorExpected(LoadStr2(irIdentifier));\r\n UsesList := Token;\r\n ReadUnit(Token);\r\n while True do\r\n begin\r\n NextToken;\r\n if TTyp = ttIn then\r\n begin\r\n { ignore }\r\n NextToken;\r\n NextToken;\r\n end;\r\n if TTyp = ttSemicolon then\r\n Exit;\r\n if TTyp <> ttCol then\r\n ErrorExpected(''',''');\r\n NextToken;\r\n if not (TTyp in [ttIdentifier, ttString]) then\r\n ErrorExpected(LoadStr2(irIdentifier));\r\n UsesList := UsesList + ',';\r\n ReadUnit(Token);\r\n end;\r\nend;\r\n\r\nprocedure TJvInterpreterUnit.InterpretUnit;\r\nvar\r\n UsesList: string;\r\nbegin\r\n NextToken;\r\n if TTyp <> ttIdentifier then\r\n ErrorExpected(LoadStr2(irIdentifier));\r\n FCurUnitName := Token;\r\n NextToken;\r\n if TTyp <> ttSemicolon then\r\n ErrorExpected(''';''');\r\n UsesList := '';\r\n NextToken;\r\n while True do\r\n begin\r\n case TTyp of\r\n ttEmpty:\r\n ErrorExpected('''' + kwEND + '''');\r\n ttFunction, ttProcedure:\r\n begin\r\n InterpretFunction;\r\n if TTyp <> ttSemicolon then\r\n ErrorExpected(''';''');\r\n end;\r\n ttEnd:\r\n Break;\r\n ttUses:\r\n InterpretUses(UsesList);\r\n ttVar:\r\n InterpretVar(FAdapter.AddSrcVar);\r\n ttConst:\r\n InterpretConst(FAdapter.AddSrcVar);\r\n ttInterface:\r\n FUnitSection := usInterface;\r\n ttImplementation:\r\n FUnitSection := usImplementation;\r\n ttType:\r\n InterpretType;\r\n else\r\n ErrorExpected(LoadStr2(irDeclaration));\r\n end;\r\n NextToken;\r\n end;\r\n if TTyp <> ttEnd then\r\n ErrorExpected('''' + kwEND + '''');\r\n NextToken;\r\n if TTyp <> ttPoint then\r\n ErrorExpected('''.''');\r\n FAdapter.AddSrcUnit(FCurUnitName, Source, UsesList);\r\nend;\r\n\r\nprocedure TJvInterpreterUnit.InterpretType;\r\nvar\r\n Identifier: string;\r\nbegin\r\n NextToken;\r\n if TTyp <> ttIdentifier then\r\n ErrorExpected(LoadStr2(irIdentifier));\r\n Identifier := Token;\r\n NextToken;\r\n if TTyp <> ttEqu then\r\n ErrorExpected('''=''');\r\n NextToken;\r\n case TTyp of\r\n ttClass:\r\n InterpretClass(Identifier);\r\n ttRecord:\r\n InterpretRecord(Identifier);\r\n else\r\n { only class declaration for form is supported }\r\n ErrorExpected(LoadStr2(irClass));\r\n end;\r\nend;\r\n\r\nprocedure TJvInterpreterUnit.InterpretClass(const Identifier: string);\r\nvar\r\n JvInterpreterSrcClass: TJvInterpreterIdentifier;\r\n FunDesc: TJvInterpreterFunctionDesc; // Class Fields support\r\nbegin\r\n NextToken;\r\n if TTyp <> ttLB then\r\n ErrorExpected('''(''');\r\n NextToken;\r\n if TTyp <> ttIdentifier then\r\n ErrorExpected(LoadStr2(irIdentifier));\r\n NextToken;\r\n if TTyp <> ttRB then\r\n ErrorExpected(''')''');\r\n\r\n JvInterpreterSrcClass := TJvInterpreterClass.Create;\r\n try\r\n JvInterpreterSrcClass.UnitName := FCurUnitName;\r\n JvInterpreterSrcClass.Identifier := Identifier;\r\n NextToken;\r\n if TTyp = ttIdentifier then\r\n begin // First fields can follow class declaration\r\n Back;\r\n InterpretVar(TJvInterpreterClass(JvInterpreterSrcClass).ClassFields.AddVar);\r\n NextToken;\r\n end;\r\n while True do\r\n begin // try to interpret other fields\r\n case TTyp of { } // property declaration not supported!!\r\n ttEmpty:\r\n ErrorExpected('''' + kwEND + '''');\r\n ttFunction, ttProcedure: // from InterpetFunction\r\n begin\r\n FunDesc := TJvInterpreterFunctionDesc.Create;\r\n try // empty reading\r\n ReadFunctionHeader(FunDesc);\r\n finally\r\n FunDesc.Free;\r\n end;\r\n end;\r\n ttEnd:\r\n Break;\r\n ttPrivate,ttProtected,ttPublic,ttPublished:\r\n begin // Add more fields\r\n NextToken;\r\n Back;\r\n if TTyp = ttIdentifier then\r\n InterpretVar(TJvInterpreterClass(JvInterpreterSrcClass).ClassFields.AddVar);\r\n end;\r\n else\r\n ErrorExpected(LoadStr2(irDeclaration));\r\n end;\r\n NextToken;\r\n end;\r\n NextToken;\r\n if TTyp <> ttSemicolon then\r\n ErrorExpected(''';''');\r\n\r\n FAdapter.AddSrcClass(JvInterpreterSrcClass);\r\n except\r\n JvInterpreterSrcClass.Free;\r\n raise;\r\n end;\r\nend;\r\n\r\nprocedure TJvInterpreterUnit.InterpretRecord(const Identifier: string);\r\nvar\r\n// JvInterpreterSrcRecord: TJvInterpreterIdentifier;\r\n// Fields: array of TJvInterpreterRecField;\r\n// TempField: TJvInterpreterRecField;\r\n// TempCount: Integer;\r\n// TempTyp: Word;\r\n JvInterpreterRecord: TJvInterpreterRecord;\r\nbegin\r\n JvInterpreterRecord := TJvInterpreterRecord.Create;\r\n JvInterpreterRecord.RecordSize := 0;\r\n JvInterpreterRecord.Identifier := Identifier;\r\n JvInterpreterRecord.FieldCount := 0;\r\n InterpretVar(JvInterpreterRecord.AddField);\r\n NextToken;\r\n if TTyp <> ttEnd then\r\n ErrorExpected('''' + kwEND + '''');\r\n NextToken;\r\n if TTyp <> ttSemicolon then\r\n ErrorExpected(''';''');\r\n // \r\n\r\n FAdapter.FRecordList.Add(JvInterpreterRecord);\r\nend;\r\n\r\nprocedure TJvInterpreterUnit.Run;\r\nvar\r\n FunctionDesc: TJvInterpreterFunctionDesc;\r\nbegin\r\n Init;\r\n NextToken;\r\n case TTyp of\r\n ttVar, ttBegin:\r\n InFunction(nil);\r\n ttFunction, ttProcedure:\r\n InterpretFunction;\r\n ttUnit:\r\n begin\r\n try\r\n InterpretUnit;\r\n except\r\n on E: Exception do\r\n begin\r\n UpdateExceptionPos(E, FCurUnitName);\r\n raise;\r\n end;\r\n end;\r\n FCompiled := True;\r\n { execute main function }\r\n FunctionDesc := FAdapter.FindFunDesc(FCurUnitName, 'main');\r\n if FunctionDesc = nil then\r\n JvInterpreterError(ieMainUndefined, -1);\r\n CurPos := FunctionDesc.PosBeg;\r\n NextToken;\r\n InFunction(FunctionDesc);\r\n end;\r\n else\r\n FVResult := Expression1;\r\n end;\r\n FCompiled := True;\r\nend;\r\n\r\nprocedure TJvInterpreterUnit.Compile;\r\nbegin\r\n Init;\r\n try\r\n NextToken;\r\n if TTyp <> ttUnit then\r\n ErrorExpected('''' + kwUNIT + '''');\r\n InterpretUnit;\r\n except\r\n on E: Exception do\r\n begin\r\n UpdateExceptionPos(E, FCurUnitName);\r\n raise;\r\n end;\r\n end;\r\n FCompiled := True;\r\nend;\r\n\r\nprocedure TJvInterpreterUnit.SourceChanged;\r\nbegin\r\n inherited SourceChanged;\r\nend;\r\n\r\ntype\r\n TJvInterpreterFormAccessProtected = class(TJvInterpreterForm);\r\n\r\nfunction TJvInterpreterUnit.GetValue(const Identifier: string; var Value: Variant;\r\n var Args: TJvInterpreterArgs): Boolean;\r\nvar\r\n FunctionDesc: TJvInterpreterFunctionDesc;\r\n OldArgs: TJvInterpreterArgs;\r\n OldInstance: TObject; // class method support\r\nbegin\r\n Result := inherited GetValue(Identifier, Value, Args);\r\n if Result then\r\n Exit;\r\n if Args.Obj = nil then\r\n FunctionDesc := FAdapter.FindFunDesc(FCurUnitName, Identifier)\r\n else\r\n if Args.Obj is TJvInterpreterSrcUnit then\r\n FunctionDesc := FAdapter.FindFunDesc((Args.Obj as TJvInterpreterSrcUnit).Identifier,\r\n Identifier)\r\n else\r\n if (Args.Obj is TJvInterpreterForm) then\r\n with TJvInterpreterFormAccessProtected(Args.Obj) do\r\n FunctionDesc := FAdapter.FindFunDesc(UnitName, Identifier, ClassIdentifier)\r\n else\r\n FunctionDesc := nil;\r\n\r\n Result := FunctionDesc <> nil;\r\n if Result then\r\n begin\r\n FAdapter.CheckArgs(Args, FunctionDesc.FParamCount, FunctionDesc.FParamTypes); {not tested !}\r\n OldArgs := FCurrArgs;\r\n OldInstance := FCurInstance;\r\n if (Args.Obj is TJvInterpreterForm) then\r\n begin\r\n FCurInstance:=Args.Obj; // class method support\r\n end; //\r\n try\r\n FCurrArgs := Args;\r\n ExecFunction(FunctionDesc);\r\n finally\r\n FCurrArgs := OldArgs;\r\n if Args.Obj is TJvInterpreterForm then\r\n FCurInstance := OldInstance; // class method support\r\n end;\r\n Value := FVResult;\r\n end;\r\nend;\r\n\r\nfunction TJvInterpreterUnit.SetValue(const Identifier: string; const Value: Variant;\r\n var Args: TJvInterpreterArgs): Boolean;\r\nbegin\r\n Result := inherited SetValue(Identifier, Value, Args);\r\nend;\r\n\r\nfunction TJvInterpreterUnit.GetUnitSource(const UnitName: string; var Source: string): Boolean;\r\nbegin\r\n Result := False;\r\n if Assigned(FOnGetUnitSource) then\r\n FOnGetUnitSource(UnitName, Source, Result);\r\nend;\r\n\r\nprocedure TJvInterpreterUnit.DeclareExternalFunction(const Declaration: string);\r\nvar\r\n OldSource: string;\r\n OldPos: Integer;\r\nbegin\r\n Source := Declaration;\r\n OldSource := Source;\r\n OldPos := FParser.Pos;\r\n try\r\n NextToken;\r\n if not (TTyp in [ttFunction, ttProcedure]) then\r\n ErrorExpected('''' + kwFUNCTION + RsEXOrX + kwPROCEDURE + '''');\r\n InterpretFunction;\r\n finally\r\n Source := OldSource;\r\n FParser.Pos := OldPos;\r\n end;\r\nend;\r\n\r\nprocedure TJvInterpreterUnit.ExecFunction(Fun: TJvInterpreterFunctionDesc);\r\nvar\r\n OldUnitName: string;\r\n S: string;\r\nbegin\r\n PushState;\r\n FAllowAssignment := True;\r\n OldUnitName := FCurUnitName;\r\n try\r\n if not Cmp(FCurUnitName, Fun.UnitName) then\r\n begin\r\n FCurUnitName := Fun.UnitName;\r\n FAdapter.CurUnitChanged(FCurUnitName, S);\r\n Source := S;\r\n end;\r\n CurPos := Fun.PosBeg;\r\n NextToken;\r\n try\r\n InFunction(Fun);\r\n except\r\n on E: Exception do\r\n begin\r\n UpdateExceptionPos(E, FCurUnitName);\r\n raise;\r\n end;\r\n end;\r\n finally\r\n if not Cmp(FCurUnitName, OldUnitName) then\r\n begin\r\n FCurUnitName := OldUnitName;\r\n FAdapter.CurUnitChanged(FCurUnitName, S);\r\n Source := S;\r\n end;\r\n PopState;\r\n end;\r\nend;\r\n\r\nfunction TJvInterpreterUnit.CallFunction(const FunctionName: string; Args: TJvInterpreterArgs;\r\n Params: array of Variant): Variant;\r\nbegin\r\n Result := CallFunctionEx(nil, '', FunctionName, Args, Params);\r\nend;\r\n\r\nfunction TJvInterpreterUnit.CallFunctionEx(Instance: TObject; const UnitName: string;\r\n const FunctionName: string; Args: TJvInterpreterArgs; Params: array of Variant): Variant;\r\nvar\r\n FunctionDesc: TJvInterpreterFunctionDesc;\r\n I: Integer;\r\n OldArgs: TJvInterpreterArgs;\r\n OldInstance: TObject;\r\nbegin\r\n if not Compiled then\r\n Compile;\r\n OldInstance := FCurInstance;\r\n try\r\n FCurInstance := Instance;\r\n FunctionDesc := FAdapter.FindFunDesc(UnitName, FunctionName);\r\n if FunctionDesc <> nil then\r\n begin\r\n OldArgs := FCurrArgs;\r\n if Args = nil then\r\n begin\r\n FCurrArgs.Clear;\r\n for I := Low(Params) to High(Params) do\r\n begin\r\n FCurrArgs.Values[FCurrArgs.Count] := Params[I];\r\n Inc(FCurrArgs.Count);\r\n end;\r\n end\r\n else\r\n FCurrArgs := Args;\r\n try\r\n { simple init }\r\n FBreak := False;\r\n FContinue := False;\r\n FLastError.Clear;\r\n\r\n ExecFunction(FunctionDesc);\r\n\r\n Result := FVResult;\r\n finally\r\n FCurrArgs := OldArgs;\r\n end;\r\n end\r\n else\r\n JvInterpreterErrorN(ieUnknownIdentifier, -1, FunctionName);\r\n finally\r\n FCurInstance := OldInstance;\r\n end;\r\nend;\r\n\r\nfunction TJvInterpreterUnit.FunctionExists(const UnitName: string;\r\n const FunctionName: string): Boolean;\r\nbegin\r\n Result := FAdapter.FindFunDesc(UnitName, FunctionName) <> nil;\r\nend;\r\n\r\n//=== { TJvInterpreterProgramStrings } =======================================\r\n\r\ntype\r\n TJvInterpreterProgramStrings = class(TStringList)\r\n private\r\n FJvInterpreterProgram: TJvInterpreterProgram;\r\n protected\r\n procedure Changed; override;\r\n end;\r\n\r\nprocedure TJvInterpreterProgramStrings.Changed;\r\nbegin\r\n FJvInterpreterProgram.Source := Text;\r\nend;\r\n\r\n//=== { TJvInterpreterProgram } ==============================================\r\n\r\nconstructor TJvInterpreterProgram.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FPas := TJvInterpreterProgramStrings.Create;\r\n (FPas as TJvInterpreterProgramStrings).FJvInterpreterProgram := Self;\r\nend;\r\n\r\ndestructor TJvInterpreterProgram.Destroy;\r\nbegin\r\n FPas.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJvInterpreterProgram.GetPas: TStrings;\r\nbegin\r\n Result := FPas;\r\nend;\r\n\r\nprocedure TJvInterpreterProgram.SetPas(Value: TStrings);\r\nbegin\r\n FPas.Assign(Value);\r\nend;\r\n\r\nprocedure TJvInterpreterProgram.DoOnStatement;\r\nbegin\r\n if Assigned(FOnStatement) then\r\n FOnStatement(Self);\r\nend;\r\n\r\nprocedure TJvInterpreterProgram.Run;\r\nvar\r\n UsesList: string;\r\nbegin\r\n // (rom) Does this always work? After \"program\" a line end or tab is allowed.\r\n if AnsiStrLIComp(PChar(FParser.Source), 'program ', Length('program ')) <> 0 then\r\n begin\r\n inherited Run;\r\n Exit;\r\n end;\r\n Init;\r\n NextToken;\r\n while True do\r\n begin\r\n case TTyp of\r\n ttEmpty:\r\n ErrorExpected('''' + kwEND + '''');\r\n ttFunction, ttProcedure:\r\n begin\r\n InterpretFunction;\r\n if TTyp <> ttSemicolon then\r\n ErrorExpected(''';''');\r\n end;\r\n ttEnd:\r\n Break;\r\n ttUses:\r\n InterpretUses(UsesList);\r\n ttVar:\r\n InterpretVar(FAdapter.AddSrcVar);\r\n ttConst:\r\n InterpretConst(FAdapter.AddSrcVar);\r\n ttInterface:\r\n FUnitSection := usInterface;\r\n ttImplementation:\r\n FUnitSection := usImplementation;\r\n ttType:\r\n InterpretType;\r\n ttProgram:\r\n begin\r\n NextToken;\r\n FCurUnitName := Token;\r\n NextToken;\r\n if TTyp <> ttSemicolon then\r\n ErrorExpected(''';''');\r\n end;\r\n ttBegin:\r\n Break;\r\n else\r\n ErrorExpected('''' + kwEND + '''');\r\n end;\r\n NextToken;\r\n end;\r\n FCompiled := True;\r\n FAdapter.AddSrcUnit(FCurUnitName, Source, UsesList);\r\n { execute program function }\r\n{ FunctionDesc := FAdapter.FindFunDesc(FCurUnitName, 'program');\r\n if FunctionDesc <> nil then\r\n begin\r\n CurPos := FunctionDesc.PosBeg;\r\n NextToken;\r\n InFunction(FunctionDesc);\r\n end; }\r\n try\r\n InterpretBegin;\r\n if (TTyp <> ttPoint) then\r\n ErrorExpected('''.''');\r\n except\r\n on E: Exception do\r\n begin\r\n UpdateExceptionPos(E, FCurUnitName);\r\n raise;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJvInterpreterFunction.GetDebugPointerToGlobalVars: TJvInterpreterVarList;\r\nbegin\r\n Result := Adapter.FSrcVarList;\r\nend;\r\n\r\nfunction TJvInterpreterFunction.GetDebugPointerToFunStack: Pointer;\r\nbegin\r\n Result := FFunctionStack;\r\nend;\r\n\r\n//=== { TJvInterpreterMethodList } ===========================================\r\n\r\nfunction SortIdentifier(Item1, Item2: Pointer): Integer;\r\nbegin\r\n { function AnsiStrIComp about 30% faster than AnsiCompareText }\r\n { Result := AnsiCompareText(TJvInterpreterIdentifier(Item1).Identifier,\r\n TJvInterpreterIdentifier(Item2).Identifier); }\r\n Result := AnsiStrIComp(PChar(TJvInterpreterIdentifier(Item1).Identifier),\r\n PChar(TJvInterpreterIdentifier(Item2).Identifier));\r\n\r\n if (Result = 0) and (Item1 <> Item2) then\r\n begin\r\n if TJvInterpreterMethod(Item1).FClassType.InheritsFrom(TJvInterpreterMethod(Item2).FClassType) then\r\n Result := -1\r\n else\r\n if TJvInterpreterMethod(Item2).FClassType.InheritsFrom(TJvInterpreterMethod(Item1).FClassType) then\r\n Result := 1;\r\n end;\r\nend;\r\n\r\nprocedure TJvInterpreterMethodList.Sort(Compare: TListSortCompare);\r\nbegin\r\n inherited Sort(SortIdentifier);\r\nend;\r\n\r\n//=== { TJvInterpreterRecord } ===============================================\r\n\r\nprocedure TJvInterpreterRecord.AddField(const UnitName, Identifier, Typ: string;\r\n VTyp: Word; const Value: Variant; DataType: IJvInterpreterDataType);\r\nbegin\r\n Fields[FieldCount].Identifier := Identifier;\r\n Fields[FieldCount].Typ := varEmpty;\r\n Fields[FieldCount].Offset := RecordSize;\r\n Fields[FieldCount].DataType := DataType;\r\n\r\n Inc(RecordSize, SizeOf(TVarData));\r\n Inc(FieldCount);\r\nend;\r\n\r\nprocedure TJvInterpreterRecord.NewRecord(var Value: Variant);\r\nconst\r\n EmptyStr: string = '';\r\nvar\r\n I: Integer;\r\n Rec: PAnsiChar;\r\n // Res: Boolean;\r\n RecHolder: TJvInterpreterRecHolder;\r\nbegin\r\n if Assigned(CreateFunc) then\r\n CreateFunc(Pointer(Rec))\r\n else\r\n begin\r\n GetMem(Rec, RecordSize);\r\n for I := 0 to FieldCount - 1 do\r\n begin\r\n if Fields[I].Typ = varString then\r\n PString(PString(Rec + Fields[I].Offset)^) := @EmptyStr\r\n else\r\n if Fields[I].Typ = varEmpty then\r\n begin\r\n PVarData(Rec + Fields[I].Offset)^.VType := varNull;\r\n if Fields[I].DataType <> nil then\r\n Fields[I].DataType.Init(Variant(PVarData(Rec + Fields[I].Offset)^));\r\n end;\r\n end;\r\n end;\r\n JvInterpreterVarCopy(Value, R2V(Identifier, Rec));\r\n RecHolder := TJvInterpreterRecHolder(TVarData(Value).VPointer);\r\n RecHolder.JvInterpreterRecord := Self;\r\nend;\r\n\r\n//=== { TJvInterpreterRecordDataType } =======================================\r\n\r\nconstructor TJvInterpreterRecordDataType.Create(ARecordDesc: TJvInterpreterRecord);\r\nbegin\r\n inherited Create;\r\n FRecordDesc := ARecordDesc;\r\nend;\r\n\r\nfunction TJvInterpreterRecordDataType.GetTyp: Word;\r\nbegin\r\n Result := varEmpty;\r\nend;\r\n\r\nprocedure TJvInterpreterRecordDataType.Init(var V: Variant);\r\nbegin\r\n FRecordDesc.NewRecord(V);\r\nend;\r\n\r\n//=== { TJvInterpreterArrayDataType } ========================================\r\n\r\nconstructor TJvInterpreterArrayDataType.Create(AArrayBegin, AArrayEnd: TJvInterpreterArrayValues;\r\n ADimension: Integer; AArrayType: Integer; ADT: IJvInterpreterDataType);\r\nbegin\r\n inherited Create;\r\n FArrayBegin := AArrayBegin;\r\n FArrayEnd := AArrayEnd;\r\n FDimension := ADimension;\r\n FArrayType := AArrayType;\r\n FDT := ADT;\r\nend;\r\n\r\nfunction TJvInterpreterArrayDataType.GetTyp: Word;\r\nbegin\r\n Result := varArray;\r\nend;\r\n\r\nprocedure TJvInterpreterArrayDataType.Init(var V: Variant);\r\nbegin\r\n V := NativeInt(JvInterpreterArrayInit(FDimension, FArrayBegin, FArrayEnd, FArrayType, FDT));\r\n TVarData(V).VType := varArray;\r\nend;\r\n\r\n//=== { TJvInterpreterSimpleDataType } =======================================\r\n\r\nconstructor TJvInterpreterSimpleDataType.Create(ATyp: TVarType);\r\nbegin\r\n inherited Create;\r\n FTyp := ATyp;\r\nend;\r\n\r\nfunction TJvInterpreterSimpleDataType.GetTyp: Word;\r\nbegin\r\n Result := FTyp;\r\nend;\r\n\r\nprocedure TJvInterpreterSimpleDataType.Init(var V: Variant);\r\nbegin\r\n V := Null;\r\n TVarData(V).VType := varEmpty;\r\n if (FTyp <> 0) and (FTyp <> varObject) then //dejoy fixed: can't define TObject up d6\r\n V := Var2Type(V, FTyp);\r\nend;\r\n\r\n//=== { TJvInterpreterSrcUnit } ==============================================\r\n\r\nfunction TJvInterpreterSrcUnit.UsesList: TNameArray;\r\nbegin\r\n Result := FUsesList;\r\nend;\r\n\r\n//=== { TJvInterpreterClass } ================================================\r\n\r\nconstructor TJvInterpreterClass.Create;\r\nbegin\r\n FClassFields:=TJvInterpreterVarList.Create;\r\nend;\r\n\r\ndestructor TJvInterpreterClass.Destroy;\r\nbegin\r\n FClassFields.Free;\r\n inherited Destroy;\r\nend;\r\n\r\n{$IFDEF JvInterpreter_OLEAUTO}\r\nvar\r\n OleInitialized: Boolean;\r\n{$ENDIF JvInterpreter_OLEAUTO}\r\n\r\nprocedure Finit;\r\nbegin\r\n FreeAndNil(FieldGlobalJvInterpreterAdapter);\r\n FreeAndNil(GlobalVariantObjectInstance);\r\n FreeAndNil(GlobalVariantRecordInstance);\r\n FreeAndNil(GlobalVariantClassInstance);\r\n FreeAndNil(GlobalVariantPointerInstance);\r\n FreeAndNil(GlobalVariantSetInstance);\r\n FreeAndNil(GlobalVariantArrayInstance);\r\n {$IFDEF JvInterpreter_OLEAUTO}\r\n if OleInitialized then\r\n OleUnInitialize;\r\n {$ENDIF JvInterpreter_OLEAUTO}\r\n {$IFDEF JvInterpreter_DEBUG}\r\n if ObjCount <> 0 then\r\n Windows.MessageBox(0, PChar('Memory leak in JvInterpreter.pas'#10 +\r\n 'ObjCount = ' + IntToStr(ObjCount)),\r\n 'JvInterpreter Internal Error', MB_ICONERROR);\r\n {$ENDIF JvInterpreter_DEBUG}\r\nend;\r\n\r\ninitialization\r\n {$IFDEF UNITVERSIONING}\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n {$ENDIF UNITVERSIONING}\r\n {$IFDEF JvInterpreter_OLEAUTO}\r\n OleInitialized := OleInitialize(nil) = S_OK;\r\n {$ENDIF JvInterpreter_OLEAUTO}\r\n\r\nfinalization\r\n Finit;\r\n {$IFDEF UNITVERSIONING}\r\n UnregisterUnitVersion(HInstance);\r\n {$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvInterpreterConst.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvInterpreterConst.PAS, released on 2002-07-04.\r\n\r\nThe Initial Developers of the Original Code are: Andrei Prygounkov \r\nCopyright (c) 1999, 2002 Andrei Prygounkov\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nDescription : Language specific constant for English\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvInterpreterConst.pas 12461 2009-08-14 17:21:33Z obones $\r\n\r\nunit JvInterpreterConst;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n JvResources;\r\n\r\nconst\r\n {JvInterpreterParser}\r\n StIdSymbols = ['_', '0'..'9', 'A'..'Z', 'a'..'z'];\r\n StIdFirstSymbols = ['_', 'A'..'Z', 'a'..'z'];\r\n StConstSymbols = ['0'..'9', 'A'..'F', 'a'..'f'];\r\n StConstSymbols10 = ['0'..'9'];\r\n StSeparators = ['(', ')', ',', '.', ';'];\r\n\r\ntype\r\n TJvInterpreterErrorsDescr = record\r\n ID: Integer;\r\n Description: string;\r\n end;\r\n\r\nconst\r\n JvInterpreterErrors: array [0..52] of TJvInterpreterErrorsDescr =\r\n ((ID: 0; Description: RsEInterpreter0),\r\n (ID: 1; Description: RsEInterpreter1),\r\n (ID: 2; Description: RsEInterpreter2),\r\n (ID: 3; Description: RsEInterpreter3),\r\n (ID: 4; Description: RsEInterpreter4),\r\n (ID: 5; Description: RsEInterpreter5),\r\n (ID: 6; Description: RsEInterpreter6),\r\n (ID: 7; Description: RsEInterpreter7),\r\n (ID: 8; Description: RsEInterpreter8),\r\n (ID: 31; Description: RsEInterpreter31),\r\n\r\n (ID: 52; Description: RsEInterpreter52),\r\n (ID: 53; Description: RsEInterpreter53),\r\n (ID: 55; Description: RsEInterpreter55),\r\n (ID: 56; Description: RsEInterpreter56),\r\n (ID: 57; Description: RsEInterpreter57),\r\n (ID: 58; Description: RsEInterpreter58),\r\n\r\n (ID: 101; Description: RsEInterpreter101),\r\n (ID: 103; Description: RsEInterpreter103),\r\n (ID: 104; Description: RsEInterpreter104),\r\n (ID: 105; Description: RsEInterpreter105),\r\n (ID: 106; Description: RsEInterpreter106),\r\n (ID: 107; Description: RsEInterpreter107),\r\n (ID: 108; Description: RsEInterpreter108),\r\n (ID: 109; Description: RsEInterpreter109),\r\n (ID: 110; Description: RsEInterpreter110),\r\n (ID: 111; Description: RsEInterpreter111),\r\n\r\n (ID: 171; Description: RsEInterpreter171),\r\n (ID: 172; Description: RsEInterpreter172),\r\n (ID: 173; Description: RsEInterpreter173),\r\n (ID: 174; Description: RsEInterpreter174),\r\n (ID: 175; Description: RsEInterpreter175),\r\n (ID: 176; Description: RsEInterpreter176),\r\n\r\n (ID: 181; Description: RsEInterpreter181),\r\n (ID: 182; Description: RsEInterpreter182),\r\n (ID: 183; Description: RsEInterpreter183),\r\n (ID: 184; Description: RsEInterpreter184),\r\n (ID: 185; Description: RsEInterpreter185),\r\n (ID: 186; Description: RsEInterpreter186),\r\n (ID: 187; Description: RsEInterpreter187),\r\n (ID: 188; Description: RsEInterpreter188),\r\n (ID: 189; Description: RsEInterpreter189),\r\n (ID: 190; Description: RsEInterpreter190),\r\n\r\n (ID: 201; Description: RsEInterpreter201),\r\n\r\n (ID: 301; Description: RsEInterpreter301),\r\n (ID: 302; Description: RsEInterpreter302),\r\n (ID: 303; Description: RsEInterpreter303),\r\n (ID: 304; Description: RsEInterpreter304),\r\n (ID: 305; Description: RsEInterpreter305),\r\n (ID: 306; Description: RsEInterpreter306),\r\n (ID: 307; Description: RsEInterpreter307),\r\n (ID: 308; Description: RsEInterpreter308),\r\n (ID: 309; Description: RsEInterpreter309),\r\n\r\n (ID: 401; Description: RsEInterpreter401));\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvInterpreterConst.pas $';\r\n Revision: '$Revision: 12461 $';\r\n Date: '$Date: 2009-08-14 19:21:33 +0200 (ven. 14 août 2009) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvInterpreterFm.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvInterpreterFm.PAS, released on 2002-07-04.\r\n\r\nThe Initial Developers of the Original Code are: Andrei Prygounkov \r\nCopyright (c) 1999, 2002 Andrei Prygounkov\r\nAll Rights Reserved.\r\n\r\nContributor(s): Ivan Ravin (ivan_ra)\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nDescription : JVCL Interpreter version 2\r\nComponent : form runner for JvInterpreter\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvInterpreterFm.pas 13104 2011-09-07 06:50:43Z obones $\r\n\r\n{ history (JVCL Library versions):\r\n 1.10:\r\n - first release;\r\n 1.12:\r\n - more smart interface-part reducementer -\r\n method MakeCompatibleUnit;\r\n 1.31.3 (JVCL Library 1.31 with update 3):\r\n - support for Delphi5 text DFM files.\r\n 1.52:\r\n - fixed memory bug;\r\n 1.52.4:\r\n - previous memory bug fix was moved to JvInterpreter.pas unit;\r\n 1.60:\r\n - forms, placed in used units, are supported;\r\n - method MakeCompatibleUnit has been removed;\r\n 1.61:\r\n - fixed bug: local variables in methods overrieded by form memebers;\r\n this bug prevented MDI forms from \"Action := caFree\" code to work\r\n (thanks to Ivan Ravin);\r\n 2.00:\r\n - loading of inherited forms added by Cerny Robert;\r\n}\r\n\r\nunit JvInterpreterFm;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n SysUtils, Classes, Controls, Forms,\r\n JvInterpreter, JvJVCLUtils, JvComponent;\r\n\r\ntype\r\n TJvInterpreterGetDfmFileName = procedure(Sender: TObject; UnitName: string;\r\n var FileName: string; var Done: Boolean) of object;\r\n TJvInterpreterCreateDfmStream = procedure(Sender: TObject; UnitName: string;\r\n var Stream: TStream; var Done: Boolean) of object;\r\n TJvInterpreterFreeDfmStream = procedure(Sender: TObject; Stream: TStream) of object;\r\n\r\n TJvInterpreterFm = class;\r\n\r\n TJvInterpreterForm = class(TJvForm)\r\n private\r\n FJvInterpreterFm: TJvInterpreterFm;\r\n FMethodList: TList;\r\n FFieldList: TJvInterpreterVarList;\r\n FFreeJvInterpreterFm: Boolean;\r\n FClassIdentifier: string;\r\n FUnitName: string;\r\n procedure FixupMethods;\r\n protected\r\n procedure ReadState(Reader: TReader); override;\r\n property MethodList: TList read FMethodList;\r\n property ClassIdentifier: string read FClassIdentifier;\r\n {$WARNINGS OFF} // Delphi 2009+ has a class function UnitName\r\n property UnitName: string read FUnitName;\r\n {$WARNINGS ON}\r\n public\r\n constructor CreateNew(AOwner: TComponent; Dummy: Integer = 0); override;\r\n destructor Destroy; override;\r\n property JvInterpreterFm: TJvInterpreterFm read FJvInterpreterFm write FJvInterpreterFm;\r\n end;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvInterpreterFm = class(TJvInterpreterProgram)\r\n private\r\n FForm: TJvInterpreterForm;\r\n FFileName: string;\r\n FInterfaceUses: Boolean;\r\n FOnGetDfmFileName: TJvInterpreterGetDfmFileName;\r\n FOnCreateDfmStream: TJvInterpreterCreateDfmStream;\r\n FOnFreeDfmStream: TJvInterpreterFreeDfmStream;\r\n procedure LoadForm(AForm: TJvInterpreterForm);\r\n protected\r\n function GetValue(const Identifier: string; var Value: Variant;\r\n var Args: TJvInterpreterArgs): Boolean; override;\r\n function SetValue(const Identifier: string; const Value: Variant;\r\n var Args: TJvInterpreterArgs): Boolean; override;\r\n function GetUnitSource(const UnitName: string; var Source: string): Boolean; override;\r\n procedure CreateDfmStream(const UnitName: string; var Stream: TStream); dynamic;\r\n procedure FreeDfmStream(Stream: TStream); dynamic;\r\n public\r\n procedure Run; override;\r\n function MakeForm(const FileName: TFileName): TForm;\r\n function MakeInheritedForm(F: TJvInterpreterForm; const FileName: TFileName): TForm;\r\n function RunForm(const FileName: TFileName): TForm;\r\n function RunFormModal(const FileName: TFileName): TModalResult;\r\n function RunUnit(const FileName: TFileName): Variant;\r\n procedure RunReportPreview(const FileName: string);\r\n property Form: TJvInterpreterForm read FForm;\r\n property FileName: string read FFileName;\r\n published\r\n property OnGetDfmFileName: TJvInterpreterGetDfmFileName read FOnGetDfmFileName write FOnGetDfmFileName;\r\n property OnCreateDfmStream: TJvInterpreterCreateDfmStream read FOnCreateDfmStream write FOnCreateDfmStream;\r\n property OnFreeDfmStream: TJvInterpreterFreeDfmStream read FOnFreeDfmStream write FOnFreeDfmStream;\r\n property InterfaceUses: Boolean read FInterfaceUses write FInterfaceUses default False;\r\n end;\r\n\r\nfunction JvInterpreterRunFormModal(const AFileName: TFileName): TModalResult;\r\nfunction JvInterpreterRunForm(const AFileName: TFileName): TForm;\r\nfunction JvInterpreterMakeForm(const AFileName: TFileName): TForm;\r\nfunction JvInterpreterRunUnit(const AFileName: TFileName): Variant;\r\nprocedure JvInterpreterRunReportPreview(const AFileName: string);\r\nprocedure JvInterpreterRunReportPreview2(const AFileName: string; JvInterpreterProgram: TJvInterpreterFm);\r\n\r\nprocedure RegisterJvInterpreterAdapter(JvInterpreterAdapter: TJvInterpreterAdapter);\r\n\r\nconst\r\n ieImplementationNotFound = 401;\r\n\r\nvar\r\n JvInterpreterRunReportPreviewProc: procedure(const FileName: string);\r\n JvInterpreterRunReportPreview2Proc: procedure(const FileName: string; JvInterpreterProgram: TJvInterpreterFm);\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvInterpreterFm.pas $';\r\n Revision: '$Revision: 13104 $';\r\n Date: '$Date: 2011-09-07 08:50:43 +0200 (mer. 07 sept. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n TypInfo,\r\n JvResources, JvTypes, JvJCLUtils;\r\n\r\n//=== { TJvInterpreterReader } ===============================================\r\n\r\ntype\r\n TJvInterpreterReader = class(TReader)\r\n protected\r\n function FindMethod(Root: TComponent; const MethodName: string): Pointer;\r\n override;\r\n end;\r\n\r\n TJvInterpreterAdapterAccessProtected = class(TJvInterpreterAdapter);\r\n\r\nfunction TJvInterpreterReader.FindMethod(Root: TComponent; const MethodName: string): Pointer;\r\nvar\r\n Len: Integer;\r\nbegin\r\n // (rom) explicit allocation instead of deprecated NewStr\r\n Len := Length(MethodName) + 1;\r\n GetMem(Result, Len * SizeOf(Char));\r\n Move(PChar(MethodName)^, Result^, Len * SizeOf(Char));\r\n TJvInterpreterForm(Root).FMethodList.Add(Result);\r\nend;\r\n\r\n//=== { TJvInterpreterForm } =================================================\r\n\r\nconstructor TJvInterpreterForm.CreateNew(AOwner: TComponent; Dummy: Integer = 0);\r\nbegin\r\n FMethodList := TList.Create;\r\n FFieldList := TJvInterpreterVarList.Create; // class fields suport\r\n {$IFDEF DELPHI}\r\n inherited CreateNew(AOwner);\r\n {$ELSE}\r\n inherited CreateNew(AOwner, Dummy);\r\n {$ENDIF DELPHI}\r\nend;\r\n\r\ndestructor TJvInterpreterForm.Destroy;\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := 0 to FMethodList.Count - 1 do\r\n FreeMem(FMethodList[I]);\r\n FMethodList.Free;\r\n FFieldList.Free; // class fields suport\r\n inherited Destroy;\r\n if FFreeJvInterpreterFm then\r\n FJvInterpreterFm.Free;\r\nend;\r\n\r\nprocedure TJvInterpreterForm.FixupMethods;\r\n\r\n procedure ReadProps(Com: TComponent);\r\n var\r\n TypeInf: PTypeInfo;\r\n TypeData: PTypeData;\r\n PropList: PPropList;\r\n NumProps: Word;\r\n I: Integer;\r\n F: Integer;\r\n Method: TMethod;\r\n begin\r\n TypeInf := Com.ClassInfo;\r\n TypeData := GetTypeData(TypeInf);\r\n NumProps := TypeData^.PropCount;\r\n GetMem(PropList, NumProps * SizeOf(Pointer));\r\n try\r\n GetPropInfos(TypeInf, PropList);\r\n for I := 0 to NumProps - 1 do\r\n if PropList^[I].PropType^.Kind = tkMethod then\r\n begin\r\n Method := GetMethodProp(Com, PropList^[I]);\r\n if Method.Data = Self then\r\n begin\r\n F := FMethodList.IndexOf(Method.Code);\r\n if F > -1 then\r\n begin\r\n SetMethodProp(Com, PropList^[I],\r\n TMethod(FJvInterpreterFm.NewEvent(FUnitName,\r\n PChar(FMethodList[F]),\r\n {$IFDEF SUPPORTS_UNICODE}UTF8ToString{$ENDIF SUPPORTS_UNICODE}(PropList^[I]^.PropType^.Name),\r\n Self,\r\n {$IFDEF SUPPORTS_UNICODE}UTF8ToString{$ENDIF SUPPORTS_UNICODE}(PropList^[I]^.Name))));\r\n end;\r\n end;\r\n end;\r\n finally\r\n FreeMem(PropList);\r\n end;\r\n end;\r\n\r\nvar\r\n I: Integer;\r\nbegin\r\n if FJvInterpreterFm = nil then\r\n Exit; {+RWare}\r\n ReadProps(Self);\r\n for I := 0 to ComponentCount - 1 do\r\n ReadProps(Components[I]);\r\nend;\r\n\r\nprocedure TJvInterpreterForm.ReadState(Reader: TReader);\r\nbegin\r\n inherited ReadState(Reader);\r\n FixupMethods;\r\nend;\r\n\r\nfunction JvInterpreterReadComponentRes(var Stream: TStream;\r\n Instance: TComponent): TComponent;\r\nvar\r\n JvInterpreterReader: TJvInterpreterReader;\r\n TmpStream: TMemoryStream;\r\nbegin\r\n if TestStreamFormat(Stream) = sofText then\r\n begin\r\n TmpStream := TMemoryStream.Create;\r\n ObjectTextToResource(Stream, TmpStream);\r\n Stream.Free;\r\n Stream := TmpStream;\r\n Stream.Position := 0;\r\n end;\r\n\r\n Stream.ReadResHeader;\r\n JvInterpreterReader := TJvInterpreterReader.Create(Stream, 4096);\r\n try\r\n Result := JvInterpreterReader.ReadRootComponent(Instance);\r\n finally\r\n JvInterpreterReader.Free;\r\n end;\r\nend;\r\n\r\n//=== { TJvInterpreterFm } ===================================================\r\n\r\nfunction TJvInterpreterFm.MakeForm(const FileName: TFileName): TForm;\r\nvar\r\n S: string;\r\n UnitName: string;\r\nbegin\r\n FFileName := FileName;\r\n UnitName := ChangeFileExt(ExtractFileName(FFileName), '');\r\n if not (GetUnitSource(FFileName, S) or GetUnitSource(UnitName, S)) then\r\n JvInterpreterErrorN(ieUnitNotFound, -1, UnitName);\r\n Source := S;\r\n Compile;\r\n FForm := TJvInterpreterForm.CreateNew(Application);\r\n FForm.FUnitName := UnitName;\r\n LoadForm(FForm);\r\n Result := FForm;\r\nend; { MakeForm }\r\n\r\nfunction TJvInterpreterFm.MakeInheritedForm(F: TJvInterpreterForm; const FileName: TFileName): TForm;\r\nvar\r\n S: string;\r\n UnitName: string;\r\nbegin\r\n FFileName := FileName;\r\n UnitName := ChangeFileExt(ExtractFileName(FFileName), '');\r\n if not (GetUnitSource(FFileName, S) or GetUnitSource(UnitName, S)) then\r\n JvInterpreterErrorN(ieUnitNotFound, -1, UnitName);\r\n Source := S;\r\n Compile;\r\n FForm := F;\r\n FForm.FUnitName := UnitName;\r\n LoadForm(FForm);\r\n Result := FForm;\r\nend;\r\n\r\nprocedure TJvInterpreterFm.CreateDfmStream(const UnitName: string; var Stream: TStream);\r\nvar\r\n Done: Boolean;\r\n DfmFile: string;\r\nbegin\r\n Done := False;\r\n if Assigned(FOnCreateDfmStream) then\r\n FOnCreateDfmStream(Self, UnitName, Stream, Done);\r\n if not Done then\r\n begin\r\n if Assigned(FOnGetDfmFileName) then\r\n FOnGetDfmFileName(Self, UnitName, DfmFile, Done);\r\n if not Done then\r\n DfmFile := FindInPath(ChangeFileExt(UnitName, '.dfm'),\r\n ExtractFilePath(FFileName));\r\n Done := FileExists(DfmFile);\r\n if Done then\r\n Stream := TFileStream.Create(DfmFile, fmOpenRead);\r\n end;\r\n\r\n if not Done then\r\n JvInterpreterErrorN(ieDfmNotFound, -1, UnitName);\r\nend;\r\n\r\nprocedure TJvInterpreterFm.FreeDfmStream(Stream: TStream);\r\nbegin\r\n if Assigned(FOnFreeDfmStream) then\r\n FOnFreeDfmStream(Self, Stream)\r\n else\r\n Stream.Free;\r\nend;\r\n\r\nprocedure TJvInterpreterFm.LoadForm(AForm: TJvInterpreterForm);\r\nvar\r\n Stream: TStream;\r\n SrcClass: TJvInterpreterIdentifier; // Class Fields support\r\n i: integer;\r\nbegin\r\n FForm := AForm;\r\n Form.FJvInterpreterFm := Self;\r\n CreateDfmStream(FForm.FUnitName, Stream);\r\n try\r\n JvInterpreterReadComponentRes(Stream, Form);\r\n finally\r\n FreeDfmStream(Stream);\r\n end;\r\n // find form class\r\n if AForm.FClassIdentifier = '' then\r\n for i:=0 to Adapter.SrcClassList.Count-1 do\r\n if cmp(TJvInterpreterIdentifier(Adapter.SrcClassList[i]).UnitName,FForm.FUnitName) then\r\n begin\r\n FForm.FClassIdentifier := TJvInterpreterIdentifier(Adapter.SrcClassList[i]).Identifier;\r\n Break;\r\n end;\r\n // Class Fields support begin\r\n // copy form fields from pattern\r\n SrcClass := TJvInterpreterAdapterAccessProtected(Adapter).GetSrcClass(\r\n AForm.FClassIdentifier);\r\n if assigned(SrcClass) then\r\n AForm.FFieldList.Assign(TJvInterpreterClass(SrcClass).ClassFields);\r\n // Class Fields support end\r\n try\r\n if Assigned(Form.OnCreate) then\r\n Form.OnCreate(Form);\r\n except\r\n Application.HandleException(Form);\r\n end;\r\n if Form.FormStyle <> fsMDIChild then\r\n Form.Visible := False;\r\nend;\r\n\r\nfunction TJvInterpreterFm.GetValue(const Identifier: string; var Value: Variant;\r\n var Args: TJvInterpreterArgs): Boolean;\r\nvar\r\n JvInterpreterSrcClass: TJvInterpreterIdentifier;\r\n JvInterpreterForm: TJvInterpreterForm;\r\n LocalArgs: TJvInterpreterArgs;\r\n\r\n function GetFromForm(Form: TJvInterpreterForm): Boolean;\r\n var\r\n Com: TComponent;\r\n begin\r\n if Cmp(Identifier, 'Self') then\r\n begin\r\n Value := O2V(Form);\r\n Result := True;\r\n Exit;\r\n end;\r\n Com := Form.FindComponent(Identifier);\r\n if Com = nil then\r\n begin\r\n if (LocalVars <> nil) and (LocalVars.FindVar('', Identifier) <> nil) then\r\n begin\r\n Result := LocalVars.GetValue(Identifier, Value, Args);\r\n Exit;\r\n end;\r\n // Class Fields support begin\r\n with Form.FFieldList do\r\n if FindVar('', Identifier) <> nil then\r\n begin\r\n Args.Obj:=nil;\r\n Result := GetValue(Identifier, Value, Args);\r\n Exit;\r\n end;\r\n // Class Fields support end\r\n { may be TForm method or published property }\r\n Args.Obj := Form;\r\n Args.ObjTyp := varObject;\r\n try\r\n Result := inherited GetValue(Identifier, Value, Args);\r\n finally\r\n Args.Obj := nil;\r\n Args.ObjTyp := 0;\r\n end;\r\n end\r\n else\r\n begin\r\n Value := O2V(Com);\r\n Result := True;\r\n end;\r\n end;\r\n\r\nbegin\r\n if (Args.Obj = nil) and (CurInstance is TJvInterpreterForm) then\r\n Result := GetFromForm(CurInstance as TJvInterpreterForm)\r\n else\r\n if (Args.Obj <> nil) and (Args.ObjTyp = varObject) and\r\n (Args.Obj is TJvInterpreterForm) then\r\n begin\r\n { run-time form creation }\r\n if Cmp(Identifier, 'Create') then\r\n begin\r\n // setting form's Owner from expression 'create(newOwner)'\r\n // when Identifier = 'Create' then Token = 'newOwner'\r\n JvInterpreterForm := Args.Obj as TJvInterpreterForm;\r\n LocalArgs := TJvInterpreterArgs.Create;\r\n try\r\n LocalArgs.Obj:=Args.Obj;\r\n LocalArgs.ObjTyp:=Args.ObjTyp;\r\n GetValue(Token, Value, LocalArgs);\r\n finally\r\n LocalArgs.Free;\r\n end;\r\n if V2O(Value)<>JvInterpreterForm.Owner then begin\r\n if JvInterpreterForm.Owner<>nil then\r\n JvInterpreterForm.Owner.RemoveComponent(JvInterpreterForm);\r\n if V2O(Value)<>nil then\r\n TComponent(V2O(Value)).InsertComponent(JvInterpreterForm);\r\n end;\r\n JvInterpreterSrcClass := TJvInterpreterAdapterAccessProtected(Adapter).GetSrcClass(\r\n JvInterpreterForm.FClassIdentifier);\r\n JvInterpreterForm.FUnitName := JvInterpreterSrcClass.UnitName;\r\n LoadForm(JvInterpreterForm);\r\n Value := O2V(Args.Obj);\r\n Result := True;\r\n Exit;\r\n end\r\n else\r\n Result := GetFromForm(Args.Obj as TJvInterpreterForm)\r\n end\r\n else\r\n Result := False;\r\n\r\n if Result then\r\n Exit;\r\n\r\n { run-time form creation }\r\n JvInterpreterSrcClass := TJvInterpreterAdapterAccessProtected(Adapter).GetSrcClass(Identifier);\r\n if JvInterpreterSrcClass <> nil then\r\n begin\r\n JvInterpreterForm := TJvInterpreterForm.CreateNew(Application);\r\n JvInterpreterForm.FClassIdentifier := Identifier;\r\n Value := O2V(JvInterpreterForm);\r\n Result := True;\r\n Exit;\r\n end;\r\n\r\n Result := Result or inherited GetValue(Identifier, Value, Args);\r\nend;\r\n\r\nfunction TJvInterpreterFm.SetValue(const Identifier: string; const Value: Variant;\r\n var Args: TJvInterpreterArgs): Boolean;\r\n // Class Fields support begin\r\nvar\r\n JvInterpreterForm: TJvInterpreterForm;\r\n\r\n function SetFormValue(Form: TJvInterpreterForm): Boolean;\r\n begin\r\n Result := False;\r\n with Form.FFieldList do\r\n if FindVar('', Identifier) <> nil then begin\r\n Args.Obj := nil;\r\n Result := SetValue(Identifier, Value, Args);\r\n end;\r\n end;\r\n // Class Fields support end\r\n\r\nbegin\r\n if (Args.Obj = nil) and (CurInstance is TJvInterpreterForm) then\r\n begin\r\n if (LocalVars <> nil) and (LocalVars.FindVar('', Identifier) <> nil) then\r\n begin\r\n Result := LocalVars.SetValue(Identifier, Value, Args);\r\n Exit;\r\n end;\r\n // Class Fields support begin\r\n { may be TForm field }\r\n Result := SetFormValue(TJvInterpreterForm(CurInstance));\r\n if not Result then\r\n begin\r\n // Class Fields support end\r\n { may be TForm method or published property }\r\n Args.Obj := CurInstance;\r\n Args.ObjTyp := varObject;\r\n try\r\n Result := inherited SetValue(Identifier, Value, Args);\r\n finally\r\n Args.Obj := nil;\r\n Args.ObjTyp := 0;\r\n end;\r\n end;\r\n end\r\n // Class Fields support begin\r\n else\r\n if (Args.Obj <> nil) and (Args.ObjTyp = varObject) and\r\n (Args.Obj is TJvInterpreterForm) then\r\n begin\r\n JvInterpreterForm := TJvInterpreterForm(Args.Obj);\r\n try\r\n Args.Obj := nil;\r\n Result := SetFormValue(JvInterpreterForm);\r\n finally\r\n Args.Obj := JvInterpreterForm;\r\n end;\r\n end\r\n // Class Fields support end\r\n else\r\n Result := False;\r\n Result := Result or inherited SetValue(Identifier, Value, Args);\r\nend;\r\n\r\nfunction TJvInterpreterFm.GetUnitSource(const UnitName: string; var Source: string): Boolean;\r\nvar\r\n FN: TFileName;\r\nbegin\r\n if not FInterfaceUses and (UnitSection = usInterface) then\r\n begin\r\n Source := 'unit ' + UnitName + '; end.';\r\n Result := True;\r\n end\r\n else\r\n begin\r\n Result := inherited GetUnitSource(UnitName, Source);\r\n if not Result then\r\n begin\r\n if ExtractFileExt(UnitName) = '' then\r\n FN := UnitName + '.pas'\r\n else\r\n FN := UnitName;\r\n Result := FileExists(FN);\r\n if not Result then\r\n begin\r\n FN := FindInPath(ExtractFileName(FN), ExtractFilePath(FFileName));\r\n Result := FileExists(FN);\r\n end;\r\n if Result then\r\n Source := LoadTextFile(FN)\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvInterpreterFm.Run;\r\nbegin\r\n inherited Run;\r\nend;\r\n\r\nfunction TJvInterpreterFm.RunForm(const FileName: TFileName): TForm;\r\nbegin\r\n Result := MakeForm(FileName);\r\n Result.Show;\r\nend;\r\n\r\nfunction TJvInterpreterFm.RunFormModal(const FileName: TFileName): TModalResult;\r\nbegin\r\n with MakeForm(FileName) do\r\n try\r\n Result := ShowModal;\r\n finally\r\n Free;\r\n end;\r\nend;\r\n\r\nfunction TJvInterpreterFm.RunUnit(const FileName: TFileName): Variant;\r\nvar\r\n UnitName: string;\r\n S: string;\r\nbegin\r\n FFileName := FileName;\r\n try\r\n UnitName := ChangeFileExt(ExtractFileName(FFileName), '');\r\n if not (GetUnitSource(FFileName, S) or GetUnitSource(UnitName, S)) then\r\n JvInterpreterErrorN(ieUnitNotFound, -1, UnitName);\r\n Source := S;\r\n except\r\n JvInterpreterErrorN(ieUnitNotFound, -1, FFileName);\r\n end;\r\n Run;\r\nend;\r\n\r\nprocedure TJvInterpreterFm.RunReportPreview(const FileName: string);\r\nbegin\r\n JvInterpreterRunReportPreview2(FileName, Self);\r\nend;\r\n\r\nfunction JvInterpreterRunFormModal(const AFileName: TFileName): TModalResult;\r\nvar\r\n TmpInterpreterFm: TJvInterpreterFm;\r\nbegin\r\n TmpInterpreterFm := TJvInterpreterFm.Create(Application);\r\n try\r\n Result := TmpInterpreterFm.RunFormModal(AFileName);\r\n finally\r\n TmpInterpreterFm.Free;\r\n end;\r\nend;\r\n\r\nfunction JvInterpreterRunForm(const AFileName: TFileName): TForm;\r\nvar\r\n TmpInterpreterFm: TJvInterpreterFm;\r\nbegin\r\n TmpInterpreterFm := TJvInterpreterFm.Create(Application);\r\n begin\r\n Result := TmpInterpreterFm.RunForm(AFileName);\r\n (Result as TJvInterpreterForm).FFreeJvInterpreterFm := True;\r\n end;\r\nend;\r\n\r\nfunction JvInterpreterMakeForm(const AFileName: TFileName): TForm;\r\nvar\r\n TmpInterpreterFm: TJvInterpreterFm;\r\nbegin\r\n TmpInterpreterFm := TJvInterpreterFm.Create(Application);\r\n begin\r\n Result := TmpInterpreterFm.MakeForm(AFileName);\r\n (Result as TJvInterpreterForm).FFreeJvInterpreterFm := True;\r\n end;\r\nend;\r\n\r\nfunction JvInterpreterRunUnit(const AFileName: TFileName): Variant;\r\nvar\r\n TmpInterpreterFm: TJvInterpreterFm;\r\nbegin\r\n TmpInterpreterFm := TJvInterpreterFm.Create(Application);\r\n try\r\n Result := TmpInterpreterFm.RunUnit(AFileName);\r\n finally\r\n TmpInterpreterFm.Free;\r\n end;\r\nend;\r\n\r\n{ adapter to self }\r\n{ function JvInterpreterRunFormModal(const FileName: TFileName): TModalResult; }\r\n\r\nprocedure JvInterpreter_JvInterpreterRunFormModal(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := JvInterpreterRunFormModal(Args.Values[0]);\r\nend;\r\n\r\n{ function JvInterpreterRunForm(const FileName: TFileName): TForm; }\r\n\r\nprocedure JvInterpreter_JvInterpreterRunForm(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(JvInterpreterRunForm(Args.Values[0]));\r\nend;\r\n\r\n{ function JvInterpreterMakeForm(const FileName: TFileName): TForm; }\r\n\r\nprocedure JvInterpreter_JvInterpreterMakeForm(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(JvInterpreterMakeForm(Args.Values[0]));\r\nend;\r\n\r\n{ function JvInterpreterRunUnit(const FileName: TFileName): Variant }\r\n\r\nprocedure JvInterpreter_JvInterpreterRunUnit(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := JvInterpreterRunUnit(Args.Values[0]);\r\nend;\r\n\r\nprocedure JvInterpreterRunReportPreview(const AFileName: string);\r\nbegin\r\n if not Assigned(JvInterpreterRunReportPreviewProc) then\r\n raise EJVCLException.CreateRes(@RsENoReportProc);\r\n JvInterpreterRunReportPreviewProc(AFileName);\r\nend;\r\n\r\nprocedure JvInterpreterRunReportPreview2(const AFileName: string; JvInterpreterProgram: TJvInterpreterFm);\r\nbegin\r\n if not Assigned(JvInterpreterRunReportPreview2Proc) then\r\n raise EJVCLException.CreateRes(@RsENoReportProc2);\r\n JvInterpreterRunReportPreview2Proc(AFileName, JvInterpreterProgram);\r\nend;\r\n\r\nprocedure RegisterJvInterpreterAdapter(JvInterpreterAdapter: TJvInterpreterAdapter);\r\nconst\r\n cJvInterpreterFm = 'JvInterpreterFm';\r\nbegin\r\n with JvInterpreterAdapter do\r\n begin\r\n AddFunction(cJvInterpreterFm, 'JvInterpreterRunFormModal', JvInterpreter_JvInterpreterRunFormModal, 1, [varString],\r\n varEmpty);\r\n AddFunction(cJvInterpreterFm, 'JvInterpreterRunForm', JvInterpreter_JvInterpreterRunForm, 1, [varString], varEmpty);\r\n AddFunction(cJvInterpreterFm, 'JvInterpreterMakeForm', JvInterpreter_JvInterpreterMakeForm, 1, [varString], varEmpty);\r\n AddFunction(cJvInterpreterFm, 'JvInterpreterRunUnit', JvInterpreter_JvInterpreterRunUnit, 1, [varString], varEmpty);\r\n end;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvInterpreterParser.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvInterpreterParser.PAS, released on 2002-07-04.\r\n\r\nThe Initial Developers of the Original Code are: Andrei Prygounkov \r\nCopyright (c) 1999, 2002 Andrei Prygounkov\r\nAll Rights Reserved.\r\n\r\nContributor(s): Peter Schraut (http://www.console-de.de)\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nDescription : Parser for JVCL Interpreter version 2\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvInterpreterParser.pas 13075 2011-06-27 22:56:21Z jfudickar $\r\n\r\n{ history (JVCL Library versions):\r\n\r\nUpcoming JVCL 3.00\r\n - peter schraut added shl, shr and xor support\r\n}\r\n\r\nunit JvInterpreterParser;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n SysUtils;\r\n\r\ntype\r\n TTokenKind = type Integer;\r\n\r\n TJvInterpreterParser = class(TObject)\r\n private\r\n FSource: string;\r\n FPCPos: PChar; { current parse position }\r\n procedure SetSource(const Value: string);\r\n function GetPos: Integer;\r\n procedure SetPos(Value: Integer);\r\n public\r\n { Token - returns next token }\r\n function Token: string;\r\n procedure Init;\r\n property Source: string read FSource write SetSource;\r\n property PCPos: PChar read FPCPos write FPCPos;\r\n property Pos: Integer read GetPos write SetPos;\r\n end;\r\n\r\n //JvInterpreterError = class(Exception)\r\n //\r\n //end;\r\n\r\n TPriorLevel = 0..8;\r\n\r\n{ tokenizer }\r\n\r\nfunction TokenTyp(const Token: string): TTokenKind;\r\n{ return operation priority }\r\nfunction Prior(const TTyp: TTokenKind): TPriorLevel;\r\nfunction TypToken(const TTyp: TTokenKind): string;\r\n\r\n{ Token types }\r\nconst\r\n ttUnknown = -1; { unknown error - internal error in most cases - for debugging }\r\n ttEmpty = 0; { end of file - eof }\r\n ttIdentifier = 10; { Identifier }\r\n ttInteger = 11; { Integer constant }\r\n ttDouble = 12; { double constant }\r\n ttString = 13; { string constant }\r\n ttBoolean = 14; { boolean - variable type }\r\n\r\n ttLB = 40; { ( }\r\n ttRB = 41; { ) }\r\n ttCol = 42; { , }\r\n ttPoint = 43; { . }\r\n ttColon = 44; { : }\r\n ttSemicolon = 45; { ; }\r\n ttLS = 46; { [ }\r\n ttRS = 47; { ] }\r\n ttDoublePoint = 48; {..}\r\n ttDoubleQuote = 49; {\"}\r\n\r\n ttFalse = 63; { false }\r\n ttTrue = 65; { true }\r\n\r\n ttBegin = 66; { begin }\r\n ttEnd = 67; { end }\r\n ttIf = 68; { if }\r\n ttThen = 69; { then }\r\n ttElse = 70; { else }\r\n ttWhile = 71; { while }\r\n ttDo = 72; { do }\r\n ttRepeat = 73; { repeat }\r\n ttUntil = 74; { until }\r\n ttProcedure = 75; { procedure }\r\n ttFunction = 76; { function }\r\n ttFor = 77; { for }\r\n ttTo = 78; { to }\r\n ttBreak = 79; { break }\r\n ttContinue = 80; { continue }\r\n ttVar = 81; { var }\r\n ttTry = 82; { try }\r\n ttFinally = 83; { finally }\r\n ttExcept = 84; { except }\r\n ttOn = 85; { on }\r\n ttRaise = 86; { raise }\r\n ttExternal = 87; { external }\r\n ttUnit = 88; { unit }\r\n ttUses = 89; { uses }\r\n ttConst = 90; { Const }\r\n ttPublic = 91; { Public }\r\n ttPrivate = 92; { Private }\r\n ttProtected = 93; { Protected }\r\n ttPublished = 94; { Published }\r\n ttProperty = 95; { Property }\r\n ttClass = 96; { Class }\r\n ttType = 97; { Type }\r\n ttInterface = 98; { Interface }\r\n ttImplementation = 99; { Implementation }\r\n ttExit = 100; { Exit }\r\n ttArray = 101; { Array }\r\n ttOf = 102; { Of }\r\n ttCase = 103; { Case }\r\n ttProgram = 104; { Program }\r\n ttIn = 105; { In }\r\n ttRecord = 106; { Record }\r\n ttDownTo = 107; { DownTo }\r\n\r\n\r\n { priority 8 - highest }\r\n ttNot = 21; { not }\r\n\r\n { priority 6 }\r\n ttMul = 22; { * }\r\n ttDiv = 23; { / }\r\n ttIntDiv = 24; { div }\r\n ttMod = 25; { mod }\r\n\r\n { priority 5 }\r\n ttAnd = 26; { and }\r\n\r\n { priority 4 }\r\n ttPlus = 27; { + }\r\n ttMinus = 28; { - }\r\n ttOr = 29; { or }\r\n\r\n { priority 3 }\r\n ttEqu = 30; { = }\r\n ttGreater = 31; { > }\r\n ttLess = 32; { < }\r\n ttNotEqu = 33; { <> }\r\n\r\n { priority 2 }\r\n ttEquGreater = 34; { >= }\r\n ttEquLess = 35; { <= }\r\n\r\n { priority 6 }\r\n ttShl = 36; { shl } // [peter schraut: added on 2005/08/14]\r\n ttShr = 37; { shr } // [peter schraut: added on 2005/08/14]\r\n\r\n { priority 3 }\r\n ttXor = 38; { xor } // [peter schraut: added on 2005/08/14]\r\n\r\n { priority 1 - lowest }\r\n { nothing }\r\n\r\n priorNot = 8;\r\n priorMul = 6;\r\n priorDiv = 6;\r\n priorIntDiv = 6;\r\n priorMod = 6;\r\n priorAnd = 5;\r\n priorPlus = 4;\r\n priorMinus = 4;\r\n priorOr = 4;\r\n priorEqu = 3;\r\n priorGreater = 3;\r\n priorLess = 3;\r\n priorNotEqu = 3;\r\n priorEquGreater = 2;\r\n priorEquLess = 2;\r\n priorShl = 6; // [peter schraut: added on 2005/08/14]\r\n priorShr = 6; // [peter schraut: added on 2005/08/14]\r\n priorXor = 3; // [peter schraut: added on 2005/08/14]\r\n\r\n ttFirstExpression = 10; { tokens for expression }\r\n ttLastExpression = 59; { }\r\n\r\n { keywords }\r\n kwTRUE = 'true';\r\n kwFALSE = 'false';\r\n kwOR = 'or';\r\n kwAND = 'and';\r\n kwNOT = 'not';\r\n kwDIV = 'div';\r\n kwMOD = 'mod';\r\n kwBEGIN = 'begin';\r\n kwEND = 'end';\r\n kwIF = 'if';\r\n kwTHEN = 'then';\r\n kwELSE = 'else';\r\n kwWHILE = 'while';\r\n kwDO = 'do';\r\n kwREPEAT = 'repeat';\r\n kwUNTIL = 'until';\r\n kwPROCEDURE = 'procedure';\r\n kwFUNCTION = 'function';\r\n kwFOR = 'for';\r\n kwTO = 'to';\r\n kwBREAK = 'break';\r\n kwCONTINUE = 'continue';\r\n kwVAR = 'var';\r\n kwTRY = 'try';\r\n kwFINALLY = 'finally';\r\n kwEXCEPT = 'except';\r\n kwON = 'on';\r\n kwRAISE = 'raise';\r\n kwEXTERNAL = 'external';\r\n kwUNIT = 'unit';\r\n kwUSES = 'uses';\r\n kwCONST = 'const';\r\n kwPUBLIC = 'public';\r\n kwPRIVATE = 'private';\r\n kwPROTECTED = 'protected';\r\n kwPUBLISHED = 'published';\r\n kwPROPERTY = 'property';\r\n kwCLASS = 'class';\r\n kwTYPE = 'type';\r\n kwINTERFACE = 'interface';\r\n kwIMPLEMENTATION = 'implementation';\r\n kwEXIT = 'exit';\r\n kwARRAY = 'array';\r\n kwOF = 'of';\r\n kwCASE = 'case';\r\n kwPROGRAM = 'program';\r\n kwIN = 'in';\r\n kwRECORD = 'record';\r\n kwDOWNTO = 'downto';\r\n kwNIL = 'nil';\r\n kwSHL = 'shl'; // [peter schraut: added on 2005/08/14]\r\n kwSHR = 'shr'; // [peter schraut: added on 2005/08/14]\r\n kwXOR = 'xor'; // [peter schraut: added on 2005/08/14]\r\n\r\n { directives }\r\n drNAME = 'name';\r\n drINDEX = 'index';\r\n\r\nimplementation\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n {$IFNDEF COMPILER12_UP}\r\n JvJCLUtils,\r\n {$ENDIF ~COMPILER12_UP}\r\n JvInterpreter, JvInterpreterConst, JvConsts, Windows;\r\n\r\nconst\r\n K = '''';\r\n\r\n{*********************** tokenizer ***********************}\r\n{ modified algorithm from mozilla source }\r\n\r\ntype\r\n TTokenTag = record\r\n // (rom) changed to PChar to get rid of hidden initialization section\r\n Token: PChar;\r\n TTyp: TTokenKind;\r\n end;\r\n\r\nconst\r\n P_UNKNOWN = -1;\r\n MIN_WORD_LENGTH = 2;\r\n MAX_WORD_LENGTH = 14; { = length('implementation') }\r\n\r\n\r\n // [peter schraut: added on 2005/08/14]\r\n // Created new HashTable to avoid collisions\r\n // with added keywords such as shl, shr and xor\r\n // Mantis 3333 (ivan_ra): optimized version\r\n AssoIndices: array [0..31] of Integer = (\r\n { 0 1 2 3 4 5 6 7 8 9 }\r\n {00} 50, 80, 25, 13, 92, 71, 87, 61, 91, 99,\r\n {10} 73, 95, 27, 7, 16, 1, 96, 41, 91, 99,\r\n {20} 19, 15, 72, 71, 50, 30, 9, 6, 45, 27,\r\n {30} 79, 61);\r\n\r\n AssoValues: array [0..255] of Integer = (\r\n { 0 1 2 3 4 5 6 7 8 9 }\r\n {00} -1, -1, -1, -1, -1, -1, 44, 10, -1, -1,\r\n {10} 37, -1, -1, -1, -1, 7, -1, -1, -1, -1,\r\n {20} -1, -1, -1, 27, -1, -1, -1, -1, -1, -1,\r\n {30} -1, -1, 26, -1, -1, 20, -1, 25, -1, -1,\r\n {40} -1, 30, 39, -1, -1, -1, -1, 13, -1, -1,\r\n {50} -1, -1, -1, -1, -1, -1, -1, 1, -1, -1,\r\n {60} -1, -1, -1, -1, -1, 12, -1, -1, -1, -1,\r\n {70} -1, -1, 6, -1, -1, -1, -1, -1, -1, -1,\r\n {80} 34, -1, -1, -1, -1, -1, 3, -1, -1, 49,\r\n {90} -1, -1, 45, -1, -1, -1, -1, -1, -1, -1,\r\n {100} 2, 41, -1, -1, -1, -1, -1, 46, -1, 28,\r\n {110}-1, -1, 17, -1, -1, -1, 36, -1, 11, -1,\r\n {120}-1, -1, 35, 48, -1, -1, -1, -1, 8, -1,\r\n {130}-1, 32, -1, 19, -1, -1, -1, 5, -1, -1,\r\n {140}40, -1, -1, -1, -1, -1, -1, -1, 21, -1,\r\n {150}22, -1, 31, -1, -1, -1, -1, -1, -1, 16,\r\n {160}43, -1, -1, -1, -1, -1, -1, -1, -1, -1,\r\n {170}-1, -1, 18, -1, -1, -1, -1, 47, -1, -1,\r\n {180}-1, -1, -1, -1, -1, -1, -1, 42, -1, -1,\r\n {190}-1, -1, -1, -1, -1, -1, -1, -1, -1, -1,\r\n {200}-1, -1, -1, -1, -1, -1, -1, -1, -1, -1,\r\n {210}-1, -1, -1, -1, -1, -1, -1, -1, -1, -1,\r\n {220}29, -1, -1, -1, 4, 15, 24, -1, -1, -1,\r\n {230}-1, -1, 33, -1, -1, 9, -1, 50, -1, 14,\r\n {240}-1, -1, -1, 23, -1, -1, 38, -1, -1, -1,\r\n {250}-1, -1, -1, -1, -1, 0);\r\n\r\n WordList: array [0..51] of TTokenTag = (\r\n (Token: kwTRUE; TTyp: ttTrue),\r\n (Token: kwFALSE; TTyp: ttFalse),\r\n (Token: kwOR; TTyp: ttOr),\r\n (Token: kwAND; TTyp: ttAnd),\r\n (Token: kwNOT; TTyp: ttNot),\r\n (Token: kwDIV; TTyp: ttIntDiv),\r\n (Token: kwMOD; TTyp: ttMod),\r\n (Token: kwBEGIN; TTyp: ttBegin),\r\n (Token: kwEND; TTyp: ttEnd),\r\n (Token: kwIF; TTyp: ttIf),\r\n (Token: kwTHEN; TTyp: ttThen),\r\n (Token: kwELSE; TTyp: ttElse),\r\n (Token: kwWHILE; TTyp: ttWhile),\r\n (Token: kwDO; TTyp: ttDo),\r\n (Token: kwREPEAT; TTyp: ttRepeat),\r\n (Token: kwUNTIL; TTyp: ttUntil),\r\n (Token: kwPROCEDURE; TTyp: ttProcedure),\r\n (Token: kwFUNCTION; TTyp: ttFunction),\r\n (Token: kwFOR; TTyp: ttFor),\r\n (Token: kwTO; TTyp: ttTo),\r\n (Token: kwBREAK; TTyp: ttBreak),\r\n (Token: kwCONTINUE; TTyp: ttContinue),\r\n (Token: kwVAR; TTyp: ttVar),\r\n (Token: kwTRY; TTyp: ttTry),\r\n (Token: kwFINALLY; TTyp: ttFinally),\r\n (Token: kwEXCEPT; TTyp: ttExcept),\r\n (Token: kwON; TTyp: ttOn),\r\n (Token: kwRAISE; TTyp: ttRaise),\r\n (Token: kwEXTERNAL; TTyp: ttExternal),\r\n (Token: kwUNIT; TTyp: ttUnit),\r\n (Token: kwUSES; TTyp: ttUses),\r\n (Token: kwCONST; TTyp: ttConst),\r\n (Token: kwPUBLIC; TTyp: ttPublic),\r\n (Token: kwPRIVATE; TTyp: ttPrivate),\r\n (Token: kwPROTECTED; TTyp: ttProtected),\r\n (Token: kwPUBLISHED; TTyp: ttPublished),\r\n (Token: kwPROPERTY; TTyp: ttProperty),\r\n (Token: kwCLASS; TTyp: ttClass),\r\n (Token: kwTYPE; TTyp: ttType),\r\n (Token: kwINTERFACE; TTyp: ttInterface),\r\n (Token: kwIMPLEMENTATION; TTyp: ttImplementation),\r\n (Token: kwEXIT; TTyp: ttExit),\r\n (Token: kwARRAY; TTyp: ttArray),\r\n (Token: kwOF; TTyp: ttOf),\r\n (Token: kwCASE; TTyp: ttCase),\r\n (Token: kwPROGRAM; TTyp: ttProgram),\r\n (Token: kwIN; TTyp: ttIn),\r\n (Token: kwRECORD; TTyp: ttRecord),\r\n (Token: kwDOWNTO; TTyp: ttDownTo),\r\n (Token: kwSHL; TTyp: ttShl), // [peter schraut: added on 2005/08/14]\r\n (Token: kwSHR; TTyp: ttShr), // [peter schraut: added on 2005/08/14]\r\n (Token: kwXOR; TTyp: ttXor) // [peter schraut: added on 2005/08/14]\r\n );\r\n\r\n{ convert string into token number using hash tables }\r\n// [peter schraut: added on 2005/08/14]\r\n// Made a few changes to PaTokenizeTag to work with new hashtable.\r\n// Mantis 3333 (ivan_ra): optimized version\r\nfunction PaTokenizeTag(const TokenStr: string): TTokenKind;\r\nvar\r\n Len, I: Integer;\r\n HVal: Integer;\r\nbegin\r\n Result := P_UNKNOWN;\r\n HVal := -1;\r\n Len := Length(TokenStr);\r\n\r\n if (MIN_WORD_LENGTH <= Len) and (Len <= MAX_WORD_LENGTH) then\r\n begin\r\n HVal := Len;\r\n for I:=1 to Len do\r\n begin\r\n HVal := HVal + AssoIndices[(Byte(TokenStr[I]) - Byte('a')) and $1F];\r\n if I = 3 then\r\n Break;\r\n end;\r\n HVal := HVal + AssoIndices[(Byte(TokenStr[Len]) - Byte('a')) and $1F];\r\n HVal := HVal and 255; {High(AssoValues)}\r\n HVal := AssoValues[HVal];\r\n end;\r\n\r\n if HVal <> -1 then\r\n if Cmp(WordList[HVal].Token, TokenStr) then\r\n Result := WordList[HVal].TTyp;\r\nend;\r\n\r\nconst\r\n { !\"#$%&'()*+,-./0123456789:;<=>? }\r\n Asso1Values: array [' '..'?'] of Integer =\r\n (-1, -1, -1, -1, -1, -1, -1, -1,\r\n ttLB, ttRB, ttMul, ttPlus, ttCol, ttMinus, ttPoint, ttDiv,\r\n ttInteger, ttInteger, ttInteger, ttInteger, ttInteger,\r\n ttInteger, ttInteger, ttInteger, ttInteger, ttInteger,\r\n ttColon, ttSemicolon, ttLess, ttEqu, ttGreater, -1);\r\n\r\n{######################## tokenizer ########################}\r\n\r\nfunction TokenTyp(const Token: string): TTokenKind;\r\nvar\r\n I: Integer;\r\n L1: Integer;\r\n T1: Char;\r\n Ci: Char;\r\n Point: Boolean;\r\nlabel { Sorry about labels and gotos - for speed-ups only }\r\n Any, NotNumber;\r\nbegin\r\n L1 := Length(Token);\r\n if L1 = 0 then\r\n begin\r\n Result := ttEmpty;\r\n Exit;\r\n end;\r\n T1 := Token[1];\r\n if L1 = 1 then\r\n begin\r\n { Result := pa_tokenize_1tag(Token[1]);\r\n if Result = -1 then goto Any; }\r\n if CharInSet(T1, ['('..'>']) then { #40..#62 }\r\n Result := Asso1Values[T1]\r\n else\r\n if T1 = '[' then\r\n Result := ttLS\r\n else\r\n if T1 = ']' then\r\n Result := ttRS\r\n else\r\n if T1 = '\"' then\r\n Result := ttDoubleQuote\r\n else\r\n goto Any;\r\n end\r\n else\r\n case T1 of\r\n '.':\r\n { may be '..' }\r\n begin\r\n if Token[2] = '.' then\r\n Result := ttDoublePoint\r\n else\r\n goto Any;\r\n end;\r\n '$':\r\n { may be hex constant }\r\n begin\r\n for I := 2 to L1 do\r\n if not CharInSet(Token[I], StConstSymbols) then\r\n goto Any;\r\n Result := ttInteger;\r\n end;\r\n '<':\r\n if L1 = 2 then\r\n case Token[2] of\r\n '=': Result := ttEquLess;\r\n '>': Result := ttNotEqu;\r\n else\r\n goto Any;\r\n end\r\n else\r\n goto Any;\r\n '>':\r\n if (L1 = 2) and (Token[2] = '=') then\r\n Result := ttEquGreater\r\n else\r\n goto Any;\r\n else\r\n begin\r\n Any: { !!LABEL!! }\r\n\r\n Point := False;\r\n for I := 1 to L1 do\r\n begin\r\n Ci := Token[I];\r\n if Ci = '.' then\r\n if Point then\r\n goto NotNumber {two Points in lexem}\r\n else\r\n Point := True\r\n else\r\n if not CharInSet(Ci, StConstSymbols10) then\r\n goto NotNumber { not number }\r\n end;\r\n if Point then\r\n Result := ttDouble\r\n else\r\n Result := ttInteger;\r\n Exit;\r\n\r\n NotNumber: { !!LABEL!! }\r\n\r\n if (L1 >= 2) and (Token[1] = '''') and (Token[L1] = '''') then\r\n Result := ttString\r\n else\r\n begin\r\n { keywords }\r\n Result := PaTokenizeTag(Token);\r\n\r\n if Result <> -1 then\r\n begin\r\n end\r\n else\r\n { may be Identifier } // National symbols for OLE automation\r\n if not (CharInSet(T1, StIdFirstSymbols) or IsCharAlpha(T1)) then\r\n Result := ttUnknown\r\n else\r\n begin\r\n for I := 2 to L1 do\r\n if not (CharInSet(Token[I], StIdSymbols) or IsCharAlpha(Token[I])) then\r\n begin\r\n Result := ttUnknown;\r\n Exit;\r\n end;\r\n Result := ttIdentifier;\r\n end;\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TypToken(const TTyp: TTokenKind): string;\r\nbegin\r\n Result := '?? not implemented !!'; { DEBUG !! }\r\nend;\r\n\r\nfunction Prior(const TTyp: TTokenKind): TPriorLevel;\r\nconst\r\n Priors: array [ttNot..ttXor] of TPriorLevel =\r\n (priorNot, priorMul, priorDiv, priorIntDiv, priorMod, priorAnd, priorPlus,\r\n priorMinus, priorOr, priorEqu, priorGreater, priorLess,\r\n priorNotEqu, priorEquGreater, priorEquLess,\r\n priorShl, priorShr, priorXor); // [peter schraut: added priorShl, priorShr, priorXor on 2005/08/14]\r\nbegin\r\n //if TTyp in [ttNot..ttEquLess] then\r\n if TTyp in [ttNot..ttXor] then // [peter schraut: expanded to ttXor on 2005/08/14]\r\n Result := Priors[TTyp]\r\n else\r\n Result := 0;\r\nend;\r\n\r\n//=== { TJvInterpreterParser } ===============================================\r\n\r\nprocedure TJvInterpreterParser.SetSource(const Value: string);\r\nbegin\r\n FSource := Value;\r\n Init;\r\nend;\r\n\r\nprocedure TJvInterpreterParser.Init;\r\nbegin\r\n FPCPos := PChar(FSource);\r\nend;\r\n\r\nfunction TJvInterpreterParser.Token: string;\r\nvar\r\n P, F: PChar;\r\n F1: PChar;\r\n I: Integer;\r\n PrevPoint:boolean;\r\n// PointCount: Integer;\r\n\r\n procedure Skip;\r\n begin\r\n case P[0] of\r\n '{':\r\n begin\r\n F := StrScan(P + 1, '}');\r\n if F = nil then\r\n JvInterpreterError(ieBadRemark, P - PChar(FSource));\r\n P := F + 1;\r\n end;\r\n '(':\r\n if P[1] = '*' then\r\n begin\r\n F := P + 2;\r\n while True do\r\n begin\r\n F := StrScan(F, '*');\r\n if F = nil then\r\n JvInterpreterError(ieBadRemark, P - PChar(FSource));\r\n if F[1] = ')' then\r\n begin\r\n Inc(F);\r\n Break;\r\n end;\r\n Inc(F);\r\n end;\r\n P := F + 1;\r\n end;\r\n '}':\r\n JvInterpreterError(ieBadRemark, P - PChar(FSource));\r\n '*':\r\n if (P[1] = ')') then\r\n JvInterpreterError(ieBadRemark, P - PChar(FSource));\r\n '/':\r\n if (P[1] = '/') then\r\n while not CharInSet(P[0], [Lf, Cr, #0]) do\r\n Inc(P);\r\n end;\r\n while CharInSet(P[0], [' ', Lf, Cr, Tab]) do\r\n Inc(P);\r\n end;\r\n\r\nbegin\r\n { New Token }\r\n F := FPCPos;\r\n P := FPCPos;\r\n PrevPoint:=false;\r\n if (P > PChar(FSource))\r\n and (P[-1] = '.')\r\n then\r\n PrevPoint := true;\r\n\r\n { Firstly skip spaces and remarks }\r\n repeat\r\n F1 := P;\r\n Skip;\r\n until F1 = P;\r\n F := P; // National symbols for OLE automation\r\n if CharInSet(P[0], StIdFirstSymbols) or PrevPoint and IsCharAlpha(P[0]) then\r\n { token }\r\n begin\r\n while CharInSet(P[0], StIdSymbols) or PrevPoint and IsCharAlpha(P[0]) do\r\n Inc(P);\r\n SetString(Result, F, P - F);\r\n end\r\n else\r\n if CharInSet(P[0], StConstSymbols10) then\r\n { number }\r\n begin\r\n while CharInSet(P[0], StConstSymbols10) or (P[0] = '.') do\r\n begin\r\n if (P[0] = '.') and (P[1] = '.') then\r\n Break;\r\n Inc(P);\r\n end;\r\n SetString(Result, F, P - F);\r\n end\r\n else\r\n if ((P[0] = '$') and\r\n CharInSet(P[1], StConstSymbols)) then\r\n { hex number }\r\n begin\r\n Inc(P);\r\n while CharInSet(P[0], StConstSymbols) do\r\n Inc(P);\r\n SetString(Result, F, P - F);\r\n end\r\n else\r\n if P[0] = '''' then\r\n { string constant }\r\n begin\r\n Inc(P);\r\n while not CharInSet(P[0], [Lf, Cr, #0]) do\r\n begin\r\n if P[0] = '''' then\r\n if P[1] = '''' then\r\n Inc(P)\r\n else\r\n Break;\r\n Inc(P);\r\n end;\r\n Inc(P);\r\n SetString(Result, F, P - F);\r\n I := 2;\r\n while I < Length(Result) - 1 do\r\n begin\r\n if Result[I] = '''' then\r\n Delete(Result, I, 1);\r\n Inc(I);\r\n end;\r\n end\r\n else\r\n if ((P[0] = '#') and\r\n CharInSet(P[1], StConstSymbols10)) then\r\n { Char constant }\r\n begin\r\n Inc(P);\r\n while CharInSet(P[0], StConstSymbols10) do\r\n Inc(P);\r\n SetString(Result, F + 1, P - F - 1);\r\n Result := '''' + Chr(StrToInt(Result)) + '''';\r\n end\r\n else\r\n if CharInSet(P[0], ['>', '=', '<', '.']) then\r\n begin\r\n if (P[0] = '.') and (P[1] = '.') then\r\n begin\r\n Result := '..';\r\n Inc(P, 2);\r\n end\r\n else\r\n if (P[0] = '>') and (P[1] = '=') then\r\n begin\r\n Result := '>=';\r\n Inc(P, 2);\r\n end\r\n else\r\n if (P[0] = '<') and (P[1] = '=') then\r\n begin\r\n Result := '<=';\r\n Inc(P, 2);\r\n end\r\n else\r\n if (P[0] = '<') and (P[1] = '>') then\r\n begin\r\n Result := '<>';\r\n Inc(P, 2);\r\n end\r\n else\r\n begin\r\n Result := P[0];\r\n Inc(P);\r\n end;\r\n end\r\n else\r\n if P[0] = #0 then\r\n Result := ''\r\n else\r\n begin\r\n Result := P[0];\r\n Inc(P);\r\n end;\r\n\r\n FPCPos := P;\r\nend;\r\n\r\nfunction TJvInterpreterParser.GetPos: Integer;\r\nbegin\r\n Result := FPCPos - PChar(FSource);\r\nend;\r\n\r\nprocedure TJvInterpreterParser.SetPos(Value: Integer);\r\nbegin\r\n FPCPos := PChar(FSource) + Value;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvInterpreter_Buttons.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvInterpreter_Buttons.pas, released on 2005-02-11.\r\n\r\nThe Initial Developers of the Original Code are: Andrei Prygounkov \r\nCopyright (c) 1999, 2002 Andrei Prygounkov\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nDescription : adapter unit - converts JvInterpreter calls to delphi calls\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvInterpreter_Buttons.pas 12461 2009-08-14 17:21:33Z obones $\r\n\r\nunit JvInterpreter_Buttons;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n JvInterpreter;\r\n\r\nprocedure RegisterJvInterpreterAdapter(JvInterpreterAdapter: TJvInterpreterAdapter);\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvInterpreter_Buttons.pas $';\r\n Revision: '$Revision: 12461 $';\r\n Date: '$Date: 2009-08-14 19:21:33 +0200 (ven. 14 août 2009) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n Windows, Classes, Graphics, Buttons;\r\n\r\n{ TSpeedButtonActionLink }\r\n\r\n{ TSpeedButton }\r\n\r\n{ constructor Create(AOwner: TComponent) }\r\n\r\nprocedure TSpeedButton_Create(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TSpeedButton.Create(V2O(Args.Values[0]) as TComponent));\r\nend;\r\n\r\n{ procedure Click; }\r\n\r\nprocedure TSpeedButton_Click(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TSpeedButton(Args.Obj).Click;\r\nend;\r\n\r\n{ property Read AllowAllUp: Boolean }\r\n\r\nprocedure TSpeedButton_Read_AllowAllUp(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TSpeedButton(Args.Obj).AllowAllUp;\r\nend;\r\n\r\n{ property Write AllowAllUp(Value: Boolean) }\r\n\r\nprocedure TSpeedButton_Write_AllowAllUp(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TSpeedButton(Args.Obj).AllowAllUp := Value;\r\nend;\r\n\r\n{ property Read GroupIndex: Integer }\r\n\r\nprocedure TSpeedButton_Read_GroupIndex(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TSpeedButton(Args.Obj).GroupIndex;\r\nend;\r\n\r\n{ property Write GroupIndex(Value: Integer) }\r\n\r\nprocedure TSpeedButton_Write_GroupIndex(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TSpeedButton(Args.Obj).GroupIndex := Value;\r\nend;\r\n\r\n{ property Read Down: Boolean }\r\n\r\nprocedure TSpeedButton_Read_Down(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TSpeedButton(Args.Obj).Down;\r\nend;\r\n\r\n{ property Write Down(Value: Boolean) }\r\n\r\nprocedure TSpeedButton_Write_Down(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TSpeedButton(Args.Obj).Down := Value;\r\nend;\r\n\r\n{ property Read Flat: Boolean }\r\n\r\nprocedure TSpeedButton_Read_Flat(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TSpeedButton(Args.Obj).Flat;\r\nend;\r\n\r\n{ property Write Flat(Value: Boolean) }\r\n\r\nprocedure TSpeedButton_Write_Flat(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TSpeedButton(Args.Obj).Flat := Value;\r\nend;\r\n\r\n{ property Read Glyph: TBitmap }\r\n\r\nprocedure TSpeedButton_Read_Glyph(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TSpeedButton(Args.Obj).Glyph);\r\nend;\r\n\r\n{ property Write Glyph(Value: TBitmap) }\r\n\r\nprocedure TSpeedButton_Write_Glyph(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TSpeedButton(Args.Obj).Glyph := V2O(Value) as TBitmap;\r\nend;\r\n\r\n{ property Read Layout: TButtonLayout }\r\n\r\nprocedure TSpeedButton_Read_Layout(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TSpeedButton(Args.Obj).Layout;\r\nend;\r\n\r\n{ property Write Layout(Value: TButtonLayout) }\r\n\r\nprocedure TSpeedButton_Write_Layout(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TSpeedButton(Args.Obj).Layout := Value;\r\nend;\r\n\r\n{ property Read Margin: Integer }\r\n\r\nprocedure TSpeedButton_Read_Margin(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TSpeedButton(Args.Obj).Margin;\r\nend;\r\n\r\n{ property Write Margin(Value: Integer) }\r\n\r\nprocedure TSpeedButton_Write_Margin(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TSpeedButton(Args.Obj).Margin := Value;\r\nend;\r\n\r\n{ property Read NumGlyphs: TNumGlyphs }\r\n\r\nprocedure TSpeedButton_Read_NumGlyphs(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TSpeedButton(Args.Obj).NumGlyphs;\r\nend;\r\n\r\n{ property Write NumGlyphs(Value: TNumGlyphs) }\r\n\r\nprocedure TSpeedButton_Write_NumGlyphs(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TSpeedButton(Args.Obj).NumGlyphs := Value;\r\nend;\r\n\r\n{ property Read Spacing: Integer }\r\n\r\nprocedure TSpeedButton_Read_Spacing(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TSpeedButton(Args.Obj).Spacing;\r\nend;\r\n\r\n{ property Write Spacing(Value: Integer) }\r\n\r\nprocedure TSpeedButton_Write_Spacing(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TSpeedButton(Args.Obj).Spacing := Value;\r\nend;\r\n\r\n{ property Read Transparent: Boolean }\r\n\r\nprocedure TSpeedButton_Read_Transparent(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TSpeedButton(Args.Obj).Transparent;\r\nend;\r\n\r\n{ property Write Transparent(Value: Boolean) }\r\n\r\nprocedure TSpeedButton_Write_Transparent(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TSpeedButton(Args.Obj).Transparent := Value;\r\nend;\r\n\r\n{ TBitBtn }\r\n\r\n{ constructor Create(AOwner: TComponent) }\r\n\r\nprocedure TBitBtn_Create(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TBitBtn.Create(V2O(Args.Values[0]) as TComponent));\r\nend;\r\n\r\n{ procedure Click; }\r\n\r\nprocedure TBitBtn_Click(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TBitBtn(Args.Obj).Click;\r\nend;\r\n\r\n{ property Read Glyph: TBitmap }\r\n\r\nprocedure TBitBtn_Read_Glyph(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TBitBtn(Args.Obj).Glyph);\r\nend;\r\n\r\n{ property Write Glyph(Value: TBitmap) }\r\n\r\nprocedure TBitBtn_Write_Glyph(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TBitBtn(Args.Obj).Glyph := V2O(Value) as TBitmap;\r\nend;\r\n\r\n{ property Read Kind: TBitBtnKind }\r\n\r\nprocedure TBitBtn_Read_Kind(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TBitBtn(Args.Obj).Kind;\r\nend;\r\n\r\n{ property Write Kind(Value: TBitBtnKind) }\r\n\r\nprocedure TBitBtn_Write_Kind(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TBitBtn(Args.Obj).Kind := Value;\r\nend;\r\n\r\n{ property Read Layout: TButtonLayout }\r\n\r\nprocedure TBitBtn_Read_Layout(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TBitBtn(Args.Obj).Layout;\r\nend;\r\n\r\n{ property Write Layout(Value: TButtonLayout) }\r\n\r\nprocedure TBitBtn_Write_Layout(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TBitBtn(Args.Obj).Layout := Value;\r\nend;\r\n\r\n{ property Read Margin: Integer }\r\n\r\nprocedure TBitBtn_Read_Margin(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TBitBtn(Args.Obj).Margin;\r\nend;\r\n\r\n{ property Write Margin(Value: Integer) }\r\n\r\nprocedure TBitBtn_Write_Margin(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TBitBtn(Args.Obj).Margin := Value;\r\nend;\r\n\r\n{ property Read NumGlyphs: TNumGlyphs }\r\n\r\nprocedure TBitBtn_Read_NumGlyphs(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TBitBtn(Args.Obj).NumGlyphs;\r\nend;\r\n\r\n{ property Write NumGlyphs(Value: TNumGlyphs) }\r\n\r\nprocedure TBitBtn_Write_NumGlyphs(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TBitBtn(Args.Obj).NumGlyphs := Value;\r\nend;\r\n\r\n{ property Read Style: TButtonStyle }\r\n\r\nprocedure TBitBtn_Read_Style(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TBitBtn(Args.Obj).Style;\r\nend;\r\n\r\n{ property Write Style(Value: TButtonStyle) }\r\n\r\nprocedure TBitBtn_Write_Style(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TBitBtn(Args.Obj).Style := Value;\r\nend;\r\n\r\n{ property Read Spacing: Integer }\r\n\r\nprocedure TBitBtn_Read_Spacing(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TBitBtn(Args.Obj).Spacing;\r\nend;\r\n\r\n{ property Write Spacing(Value: Integer) }\r\n\r\nprocedure TBitBtn_Write_Spacing(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TBitBtn(Args.Obj).Spacing := Value;\r\nend;\r\n\r\nprocedure RegisterJvInterpreterAdapter(JvInterpreterAdapter: TJvInterpreterAdapter);\r\nconst\r\n cButtons = 'Buttons';\r\nbegin\r\n with JvInterpreterAdapter do\r\n begin\r\n { TSpeedButtonActionLink }\r\n {$IFDEF COMPILER7_UP}\r\n AddClass(cButtons, TSpeedButtonActionLink, 'TSpeedButtonActionLink');\r\n {$ENDIF COMPILER7_UP}\r\n { TSpeedButton }\r\n AddClass(cButtons, TSpeedButton, 'TSpeedButton');\r\n AddGet(TSpeedButton, 'Create', TSpeedButton_Create, 1, [varEmpty], varObject);\r\n AddGet(TSpeedButton, 'Click', TSpeedButton_Click, 0, [varEmpty], varObject);\r\n AddGet(TSpeedButton, 'AllowAllUp', TSpeedButton_Read_AllowAllUp, 0, [varEmpty], varBoolean);\r\n AddSet(TSpeedButton, 'AllowAllUp', TSpeedButton_Write_AllowAllUp, 0, [varBoolean]);\r\n AddGet(TSpeedButton, 'GroupIndex', TSpeedButton_Read_GroupIndex, 0, [varEmpty], varInteger);\r\n AddSet(TSpeedButton, 'GroupIndex', TSpeedButton_Write_GroupIndex, 0, [varInteger]);\r\n AddGet(TSpeedButton, 'Down', TSpeedButton_Read_Down, 0, [varEmpty], varBoolean);\r\n AddSet(TSpeedButton, 'Down', TSpeedButton_Write_Down, 0, [varBoolean]);\r\n AddGet(TSpeedButton, 'Flat', TSpeedButton_Read_Flat, 0, [varEmpty], varBoolean);\r\n AddSet(TSpeedButton, 'Flat', TSpeedButton_Write_Flat, 0, [varBoolean]);\r\n AddGet(TSpeedButton, 'Glyph', TSpeedButton_Read_Glyph, 0, [varEmpty], varEmpty);\r\n AddSet(TSpeedButton, 'Glyph', TSpeedButton_Write_Glyph, 0, [varEmpty]);\r\n AddGet(TSpeedButton, 'Layout', TSpeedButton_Read_Layout, 0, [varEmpty], varEmpty);\r\n AddSet(TSpeedButton, 'Layout', TSpeedButton_Write_Layout, 0, [varEmpty]);\r\n AddGet(TSpeedButton, 'Margin', TSpeedButton_Read_Margin, 0, [varEmpty], varInteger);\r\n AddSet(TSpeedButton, 'Margin', TSpeedButton_Write_Margin, 0, [varInteger]);\r\n AddGet(TSpeedButton, 'NumGlyphs', TSpeedButton_Read_NumGlyphs, 0, [varEmpty], varEmpty);\r\n AddSet(TSpeedButton, 'NumGlyphs', TSpeedButton_Write_NumGlyphs, 0, [varEmpty]);\r\n AddGet(TSpeedButton, 'Spacing', TSpeedButton_Read_Spacing, 0, [varEmpty], varInteger);\r\n AddSet(TSpeedButton, 'Spacing', TSpeedButton_Write_Spacing, 0, [varInteger]);\r\n AddGet(TSpeedButton, 'Transparent', TSpeedButton_Read_Transparent, 0, [varEmpty], varBoolean);\r\n AddSet(TSpeedButton, 'Transparent', TSpeedButton_Write_Transparent, 0, [varBoolean]);\r\n { TBitBtn }\r\n AddClass(cButtons, TBitBtn, 'TBitBtn');\r\n AddGet(TBitBtn, 'Create', TBitBtn_Create, 1, [varEmpty], varBoolean);\r\n AddGet(TBitBtn, 'Click', TBitBtn_Click, 0, [varEmpty], varBoolean);\r\n AddGet(TBitBtn, 'Glyph', TBitBtn_Read_Glyph, 0, [varEmpty], varEmpty);\r\n AddSet(TBitBtn, 'Glyph', TBitBtn_Write_Glyph, 0, [varEmpty]);\r\n AddGet(TBitBtn, 'Kind', TBitBtn_Read_Kind, 0, [varEmpty], varEmpty);\r\n AddSet(TBitBtn, 'Kind', TBitBtn_Write_Kind, 0, [varEmpty]);\r\n AddGet(TBitBtn, 'Layout', TBitBtn_Read_Layout, 0, [varEmpty], varEmpty);\r\n AddSet(TBitBtn, 'Layout', TBitBtn_Write_Layout, 0, [varEmpty]);\r\n AddGet(TBitBtn, 'Margin', TBitBtn_Read_Margin, 0, [varEmpty], varInteger);\r\n AddSet(TBitBtn, 'Margin', TBitBtn_Write_Margin, 0, [varInteger]);\r\n AddGet(TBitBtn, 'NumGlyphs', TBitBtn_Read_NumGlyphs, 0, [varEmpty], varEmpty);\r\n AddSet(TBitBtn, 'NumGlyphs', TBitBtn_Write_NumGlyphs, 0, [varEmpty]);\r\n AddGet(TBitBtn, 'Style', TBitBtn_Read_Style, 0, [varEmpty], varEmpty);\r\n AddSet(TBitBtn, 'Style', TBitBtn_Write_Style, 0, [varEmpty]);\r\n AddGet(TBitBtn, 'Spacing', TBitBtn_Read_Spacing, 0, [varEmpty], varInteger);\r\n AddSet(TBitBtn, 'Spacing', TBitBtn_Write_Spacing, 0, [varInteger]);\r\n end;\r\n RegisterClasses([TSpeedButton, TBitBtn]);\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend." }, { "path": "External/Jedi/Jvcl/run/JvInterpreter_Classes.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvInterpreter_Classes.PAS, released on 2002-07-04.\r\n\r\nThe Initial Developers of the Original Code are: Andrei Prygounkov \r\nCopyright (c) 1999, 2002 Andrei Prygounkov\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nDescription : adapter unit - converts JvInterpreter calls to delphi calls\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvInterpreter_Classes.pas 12461 2009-08-14 17:21:33Z obones $\r\n\r\nunit JvInterpreter_Classes;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n JvInterpreter;\r\n\r\nprocedure RegisterJvInterpreterAdapter(JvInterpreterAdapter: TJvInterpreterAdapter);\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvInterpreter_Classes.pas $';\r\n Revision: '$Revision: 12461 $';\r\n Date: '$Date: 2009-08-14 19:21:33 +0200 (ven. 14 août 2009) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n Variants, Classes;\r\n\r\n{ TList }\r\n{ constructor }\r\n\r\nprocedure TList_Create(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TList.Create);\r\nend;\r\n\r\n{ function Add(Item: Pointer): Integer; }\r\n\r\nprocedure TList_Add(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TList(Args.Obj).Add(V2P(Args.Values[0]));\r\nend;\r\n\r\n{ procedure Clear; }\r\n\r\nprocedure TList_Clear(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TList(Args.Obj).Clear;\r\nend;\r\n\r\n{ procedure Delete(Index: Integer); }\r\n\r\nprocedure TList_Delete(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TList(Args.Obj).Delete(Args.Values[0]);\r\nend;\r\n\r\n{ procedure Exchange(Index1, Index2: Integer); }\r\n\r\nprocedure TList_Exchange(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TList(Args.Obj).Exchange(Args.Values[0], Args.Values[1]);\r\nend;\r\n\r\n{ function Expand: TList; }\r\n\r\nprocedure TList_Expand(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TList(Args.Obj).Expand);\r\nend;\r\n\r\n{ function First: Pointer; }\r\n\r\nprocedure TList_First(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := P2V(TList(Args.Obj).First);\r\nend;\r\n\r\n{ function IndexOf(Item: Pointer): Integer; }\r\n\r\nprocedure TList_IndexOf(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TList(Args.Obj).IndexOf(V2P(Args.Values[0]));\r\nend;\r\n\r\n{ procedure Insert(Index: Integer; Item: Pointer); }\r\n\r\nprocedure TList_Insert(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TList(Args.Obj).Insert(Args.Values[0], V2P(Args.Values[1]));\r\nend;\r\n\r\n{ function Last: Pointer; }\r\n\r\nprocedure TList_Last(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := P2V(TList(Args.Obj).Last);\r\nend;\r\n\r\n{ procedure Move(CurIndex, NewIndex: Integer); }\r\n\r\nprocedure TList_Move(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TList(Args.Obj).Move(Args.Values[0], Args.Values[1]);\r\nend;\r\n\r\n{ function Remove(Item: Pointer): Integer; }\r\n\r\nprocedure TList_Remove(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TList(Args.Obj).Remove(V2P(Args.Values[0]));\r\nend;\r\n\r\n{ procedure Pack; }\r\n\r\nprocedure TList_Pack(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TList(Args.Obj).Pack;\r\nend;\r\n\r\n{ procedure Sort(Compare: TListSortCompare); }\r\n\r\nprocedure TList_Sort(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n// TList(Args.Obj).Sort(Args.Values[0]);\r\n NotImplemented('TList.Sort');\r\nend;\r\n\r\n{ property Read Capacity: Integer }\r\n\r\nprocedure TList_Read_Capacity(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TList(Args.Obj).Capacity;\r\nend;\r\n\r\n{ property Write Capacity(Value: Integer) }\r\n\r\nprocedure TList_Write_Capacity(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TList(Args.Obj).Capacity := Value;\r\nend;\r\n\r\n{ property Read Count: Integer }\r\n\r\nprocedure TList_Read_Count(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TList(Args.Obj).Count;\r\nend;\r\n\r\n{ property Write Count(Value: Integer) }\r\n\r\nprocedure TList_Write_Count(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TList(Args.Obj).Count := Value;\r\nend;\r\n\r\n{ property Read Items[Integer]: Pointer }\r\n\r\nprocedure TList_Read_Items(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := P2V(TList(Args.Obj).Items[Args.Values[0]]);\r\nend;\r\n\r\n{ property Write Items[Integer]: Pointer }\r\n\r\nprocedure TList_Write_Items(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TList(Args.Obj).Items[Args.Values[0]] := V2P(Value);\r\nend;\r\n\r\n{ property Read List: PPointerList }\r\n\r\nprocedure TList_Read_List(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := P2V(TList(Args.Obj).List);\r\nend;\r\n\r\n{ TPersistent }\r\n\r\n{ procedure Assign(Source: TPersistent); }\r\n\r\nprocedure TPersistent_Assign(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TPersistent(Args.Obj).Assign(V2O(Args.Values[0]) as TPersistent);\r\nend;\r\n\r\n{ function GetNamePath: string; }\r\n\r\nprocedure TPersistent_GetNamePath(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TPersistent(Args.Obj).GetNamePath;\r\nend;\r\n\r\n{ TCollectionItem }\r\n\r\n{ constructor Create(Collection: TCollection) }\r\n\r\nprocedure TCollectionItem_Create(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TCollectionItem.Create(V2O(Args.Values[0]) as TCollection));\r\nend;\r\n\r\n{ property Read Collection: TCollection }\r\n\r\nprocedure TCollectionItem_Read_Collection(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TCollectionItem(Args.Obj).Collection);\r\nend;\r\n\r\n{ property Write Collection(Value: TCollection) }\r\n\r\nprocedure TCollectionItem_Write_Collection(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TCollectionItem(Args.Obj).Collection := V2O(Value) as TCollection;\r\nend;\r\n\r\n{ property Read ID: Integer }\r\n\r\nprocedure TCollectionItem_Read_ID(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TCollectionItem(Args.Obj).ID;\r\nend;\r\n\r\n{ property Read Index: Integer }\r\n\r\nprocedure TCollectionItem_Read_Index(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TCollectionItem(Args.Obj).Index;\r\nend;\r\n\r\n{ property Write Index(Value: Integer) }\r\n\r\nprocedure TCollectionItem_Write_Index(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TCollectionItem(Args.Obj).Index := Value;\r\nend;\r\n\r\n{ property Read DisplayName: string }\r\n\r\nprocedure TCollectionItem_Read_DisplayName(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TCollectionItem(Args.Obj).DisplayName;\r\nend;\r\n\r\n{ property Write DisplayName(Value: string) }\r\n\r\nprocedure TCollectionItem_Write_DisplayName(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TCollectionItem(Args.Obj).DisplayName := Value;\r\nend;\r\n\r\n{ TCollection }\r\n\r\n{ constructor Create(ItemClass: TCollectionItemClass) }\r\n\r\nprocedure TCollection_Create(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TCollection.Create(TCollectionItemClass(V2O(Args.Values[0]))));\r\nend;\r\n\r\n{ function Add: TCollectionItem; }\r\n\r\nprocedure TCollection_Add(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TCollection(Args.Obj).Add);\r\nend;\r\n\r\n{ procedure Assign(Source: TPersistent); }\r\n\r\nprocedure TCollection_Assign(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TCollection(Args.Obj).Assign(V2O(Args.Values[0]) as TPersistent);\r\nend;\r\n\r\n{ procedure BeginUpdate; }\r\n\r\nprocedure TCollection_BeginUpdate(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TCollection(Args.Obj).BeginUpdate;\r\nend;\r\n\r\n{ procedure Clear; }\r\n\r\nprocedure TCollection_Clear(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TCollection(Args.Obj).Clear;\r\nend;\r\n\r\n{ procedure EndUpdate; }\r\n\r\nprocedure TCollection_EndUpdate(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TCollection(Args.Obj).EndUpdate;\r\nend;\r\n\r\n{ function FindItemID(ID: Integer): TCollectionItem; }\r\n\r\nprocedure TCollection_FindItemID(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TCollection(Args.Obj).FindItemID(Args.Values[0]));\r\nend;\r\n\r\n{ property Read Count: Integer }\r\n\r\nprocedure TCollection_Read_Count(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TCollection(Args.Obj).Count;\r\nend;\r\n\r\n{ property Read ItemClass: TCollectionItemClass }\r\n\r\nprocedure TCollection_Read_ItemClass(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TObject(TCollection(Args.Obj).ItemClass));\r\nend;\r\n\r\n{ property Read Items[Integer]: TCollectionItem }\r\n\r\nprocedure TCollection_Read_Items(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TCollection(Args.Obj).Items[Args.Values[0]]);\r\nend;\r\n\r\n{ property Write Items[Integer]: TCollectionItem }\r\n\r\nprocedure TCollection_Write_Items(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TCollection(Args.Obj).Items[Args.Values[0]] := V2O(Value) as TCollectionItem;\r\nend;\r\n\r\n{ TStrings }\r\n\r\n{ function Add(const S: string): Integer; }\r\n\r\nprocedure TStrings_Add(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TStrings(Args.Obj).Add(Args.Values[0]);\r\nend;\r\n\r\n{ function AddObject(const S: string; AObject: TObject): Integer; }\r\n\r\nprocedure TStrings_AddObject(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TStrings(Args.Obj).AddObject(Args.Values[0], V2O(Args.Values[1]));\r\nend;\r\n\r\n{ procedure Append(const S: string); }\r\n\r\nprocedure TStrings_Append(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TStrings(Args.Obj).Append(Args.Values[0]);\r\nend;\r\n\r\n{ procedure AddStrings(Strings: TStrings); }\r\n\r\nprocedure TStrings_AddStrings(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TStrings(Args.Obj).AddStrings(V2O(Args.Values[0]) as TStrings);\r\nend;\r\n\r\n{ procedure Assign(Source: TPersistent); }\r\n\r\nprocedure TStrings_Assign(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TStrings(Args.Obj).Assign(V2O(Args.Values[0]) as TPersistent);\r\nend;\r\n\r\n{ procedure BeginUpdate; }\r\n\r\nprocedure TStrings_BeginUpdate(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TStrings(Args.Obj).BeginUpdate;\r\nend;\r\n\r\n{ procedure Clear; }\r\n\r\nprocedure TStrings_Clear(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TStrings(Args.Obj).Clear;\r\nend;\r\n\r\n{ procedure Delete(Index: Integer); }\r\n\r\nprocedure TStrings_Delete(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TStrings(Args.Obj).Delete(Args.Values[0]);\r\nend;\r\n\r\n{ procedure EndUpdate; }\r\n\r\nprocedure TStrings_EndUpdate(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TStrings(Args.Obj).EndUpdate;\r\nend;\r\n\r\n{ function Equals(Strings: TStrings): Boolean; }\r\n\r\nprocedure TStrings_Equals(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TStrings(Args.Obj).Equals(V2O(Args.Values[0]) as TStrings);\r\nend;\r\n\r\n{ procedure Exchange(Index1, Index2: Integer); }\r\n\r\nprocedure TStrings_Exchange(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TStrings(Args.Obj).Exchange(Args.Values[0], Args.Values[1]);\r\nend;\r\n\r\n{ function IndexOf(const S: string): Integer; }\r\n\r\nprocedure TStrings_IndexOf(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TStrings(Args.Obj).IndexOf(Args.Values[0]);\r\nend;\r\n\r\n{ function IndexOfName(const Name: string): Integer; }\r\n\r\nprocedure TStrings_IndexOfName(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TStrings(Args.Obj).IndexOfName(Args.Values[0]);\r\nend;\r\n\r\n{ function IndexOfObject(AObject: TObject): Integer; }\r\n\r\nprocedure TStrings_IndexOfObject(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TStrings(Args.Obj).IndexOfObject(V2O(Args.Values[0]));\r\nend;\r\n\r\n{ procedure Insert(Index: Integer; const S: string); }\r\n\r\nprocedure TStrings_Insert(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TStrings(Args.Obj).Insert(Args.Values[0], Args.Values[1]);\r\nend;\r\n\r\n{ procedure InsertObject(Index: Integer; const S: string; AObject: TObject); }\r\n\r\nprocedure TStrings_InsertObject(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TStrings(Args.Obj).InsertObject(Args.Values[0], Args.Values[1], V2O(Args.Values[2]));\r\nend;\r\n\r\n{ procedure LoadFromFile(const FileName: string); }\r\n\r\nprocedure TStrings_LoadFromFile(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TStrings(Args.Obj).LoadFromFile(Args.Values[0]);\r\nend;\r\n\r\n{ procedure LoadFromStream(Stream: TStream); }\r\n\r\nprocedure TStrings_LoadFromStream(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TStrings(Args.Obj).LoadFromStream(V2O(Args.Values[0]) as TStream);\r\nend;\r\n\r\n{ procedure Move(CurIndex, NewIndex: Integer); }\r\n\r\nprocedure TStrings_Move(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TStrings(Args.Obj).Move(Args.Values[0], Args.Values[1]);\r\nend;\r\n\r\n{ procedure SaveToFile(const FileName: string); }\r\n\r\nprocedure TStrings_SaveToFile(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TStrings(Args.Obj).SaveToFile(Args.Values[0]);\r\nend;\r\n\r\n{ procedure SaveToStream(Stream: TStream); }\r\n\r\nprocedure TStrings_SaveToStream(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TStrings(Args.Obj).SaveToStream(V2O(Args.Values[0]) as TStream);\r\nend;\r\n\r\n{ property Read Capacity: Integer }\r\n\r\nprocedure TStrings_Read_Capacity(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TStrings(Args.Obj).Capacity;\r\nend;\r\n\r\n{ property Write Capacity(Value: Integer) }\r\n\r\nprocedure TStrings_Write_Capacity(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TStrings(Args.Obj).Capacity := Value;\r\nend;\r\n\r\n{ property Read CommaText: string }\r\n\r\nprocedure TStrings_Read_CommaText(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TStrings(Args.Obj).CommaText;\r\nend;\r\n\r\n{ property Write CommaText(Value: string) }\r\n\r\nprocedure TStrings_Write_CommaText(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TStrings(Args.Obj).CommaText := Value;\r\nend;\r\n\r\n{ property Read Count: Integer }\r\n\r\nprocedure TStrings_Read_Count(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TStrings(Args.Obj).Count;\r\nend;\r\n\r\n{ property Read Names[Integer]: string }\r\n\r\nprocedure TStrings_Read_Names(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TStrings(Args.Obj).Names[Args.Values[0]];\r\nend;\r\n\r\n{ property Read Values[Integer]: string }\r\n\r\nprocedure TStrings_Read_Values(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TStrings(Args.Obj).Values[Args.Values[0]];\r\nend;\r\n\r\n{ property Write Values[Integer]: string }// ivan_ra\r\n\r\nprocedure TStrings_Write_Values(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TStrings(Args.Obj).Values[Args.Values[0]] := Value;\r\nend;\r\n\r\n{ property Read Objects[Integer]: TObject }\r\n\r\nprocedure TStrings_Read_Objects(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TStrings(Args.Obj).Objects[Args.Values[0]]);\r\nend;\r\n\r\n{ property Write Objects[Integer]: TObject }\r\n\r\nprocedure TStrings_Write_Objects(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TStrings(Args.Obj).Objects[Args.Values[0]] := V2O(Value);\r\nend;\r\n\r\n{ property Read Strings[Integer]: string }\r\n\r\nprocedure TStrings_Read_Strings(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TStrings(Args.Obj).Strings[Args.Values[0]];\r\nend;\r\n\r\n{ property Write Strings[Integer]: string }\r\n\r\nprocedure TStrings_Write_Strings(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TStrings(Args.Obj).Strings[Args.Values[0]] := Value;\r\nend;\r\n\r\n{ property Read Text: string }\r\n\r\nprocedure TStrings_Read_Text(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TStrings(Args.Obj).Text;\r\nend;\r\n\r\n{ property Write Text(Value: string) }\r\n\r\nprocedure TStrings_Write_Text(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TStrings(Args.Obj).Text := Value;\r\nend;\r\n\r\n{ property Read StringsAdapter: IStringsAdapter }\r\n\r\nprocedure TStrings_Read_StringsAdapter(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TStrings(Args.Obj).StringsAdapter;\r\nend;\r\n\r\n{ property Write StringsAdapter(Value: IStringsAdapter) }\r\n\r\nprocedure TStrings_Write_StringsAdapter(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n// TStrings(Args.Obj).StringsAdapter := Value;\r\n NotImplemented('TStrings.StringsAdapter');\r\nend;\r\n\r\n{ TStringList }\r\n\r\n{ constructor }\r\n\r\nprocedure TStringList_Create(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TStringList.Create);\r\nend;\r\n\r\n{ function Add(const S: string): Integer; }\r\n\r\nprocedure TStringList_Add(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TStringList(Args.Obj).Add(Args.Values[0]);\r\nend;\r\n\r\n{ procedure Clear; }\r\n\r\nprocedure TStringList_Clear(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TStringList(Args.Obj).Clear;\r\nend;\r\n\r\n{ procedure Delete(Index: Integer); }\r\n\r\nprocedure TStringList_Delete(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TStringList(Args.Obj).Delete(Args.Values[0]);\r\nend;\r\n\r\n{ procedure Exchange(Index1, Index2: Integer); }\r\n\r\nprocedure TStringList_Exchange(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TStringList(Args.Obj).Exchange(Args.Values[0], Args.Values[1]);\r\nend;\r\n\r\n{ function Find(const S: string; var Index: Integer): Boolean; }\r\n\r\nprocedure TStringList_Find(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TStringList(Args.Obj).Find(Args.Values[0], TVarData(Args.Values[1]).vInteger);\r\nend;\r\n\r\n{ function IndexOf(const S: string): Integer; }\r\n\r\nprocedure TStringList_IndexOf(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TStringList(Args.Obj).IndexOf(Args.Values[0]);\r\nend;\r\n\r\n{ procedure Insert(Index: Integer; const S: string); }\r\n\r\nprocedure TStringList_Insert(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TStringList(Args.Obj).Insert(Args.Values[0], Args.Values[1]);\r\nend;\r\n\r\n{ procedure Sort; }\r\n\r\nprocedure TStringList_Sort(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TStringList(Args.Obj).Sort;\r\nend;\r\n\r\n{ property Read Duplicates: TDuplicates }\r\n\r\nprocedure TStringList_Read_Duplicates(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TStringList(Args.Obj).Duplicates;\r\nend;\r\n\r\n{ property Write Duplicates(Value: TDuplicates) }\r\n\r\nprocedure TStringList_Write_Duplicates(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TStringList(Args.Obj).Duplicates := Value;\r\nend;\r\n\r\n{ property Read Sorted: Boolean }\r\n\r\nprocedure TStringList_Read_Sorted(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TStringList(Args.Obj).Sorted;\r\nend;\r\n\r\n{ property Write Sorted(Value: Boolean) }\r\n\r\nprocedure TStringList_Write_Sorted(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TStringList(Args.Obj).Sorted := Value;\r\nend;\r\n\r\n{ TStream }\r\n\r\n{ function Read(var Buffer; Count: Longint): Longint; }\r\n\r\nprocedure TStream_Read(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TStream(Args.Obj).Read(Args.Values[0], Args.Values[1]);\r\nend;\r\n\r\n{ function Write(const Buffer; Count: Longint): Longint; }\r\n\r\nprocedure TStream_Write(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TStream(Args.Obj).Write(Args.Values[0], Args.Values[1]);\r\nend;\r\n\r\n{ function Seek(Offset: Longint; Origin: Word): Longint; }\r\n\r\nprocedure TStream_Seek(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TStream(Args.Obj).Seek(Args.Values[0], Args.Values[1]);\r\nend;\r\n\r\n{ procedure ReadBuffer(var Buffer; Count: Longint); }\r\n\r\nprocedure TStream_ReadBuffer(var Value: Variant; Args: TJvInterpreterArgs);\r\nvar\r\n S: AnsiString;\r\nbegin\r\n // ahuser: Shouldn't this be the opposite of TStream_WriteBuffer ?\r\n SetLength(S, Integer(Args.Values[1]));\r\n if S <> '' then\r\n TStream(Args.Obj).ReadBuffer(S[1], Args.Values[1]);\r\n Args.Values[0] := S;\r\nend;\r\n\r\n{ procedure WriteBuffer(const Buffer; Count: Longint); }\r\n\r\nprocedure TStream_WriteBuffer(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TStream(Args.Obj).WriteBuffer(Args.Values[0], Args.Values[1]);\r\nend;\r\n\r\n{ function CopyFrom(Source: TStream; Count: Longint): Longint; }\r\n\r\nprocedure TStream_CopyFrom(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TStream(Args.Obj).CopyFrom(V2O(Args.Values[0]) as TStream, Args.Values[1]);\r\nend;\r\n\r\n{ function ReadComponent(Instance: TComponent): TComponent; }\r\n\r\nprocedure TStream_ReadComponent(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TStream(Args.Obj).ReadComponent(V2O(Args.Values[0]) as TComponent));\r\nend;\r\n\r\n{ function ReadComponentRes(Instance: TComponent): TComponent; }\r\n\r\nprocedure TStream_ReadComponentRes(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TStream(Args.Obj).ReadComponentRes(V2O(Args.Values[0]) as TComponent));\r\nend;\r\n\r\n{ procedure WriteComponent(Instance: TComponent); }\r\n\r\nprocedure TStream_WriteComponent(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TStream(Args.Obj).WriteComponent(V2O(Args.Values[0]) as TComponent);\r\nend;\r\n\r\n{ procedure WriteComponentRes(const ResName: string; Instance: TComponent); }\r\n\r\nprocedure TStream_WriteComponentRes(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TStream(Args.Obj).WriteComponentRes(Args.Values[0], V2O(Args.Values[1]) as TComponent);\r\nend;\r\n\r\n{ procedure WriteDescendent(Instance, Ancestor: TComponent); }\r\n\r\nprocedure TStream_WriteDescendent(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TStream(Args.Obj).WriteDescendent(V2O(Args.Values[0]) as TComponent, V2O(Args.Values[1]) as TComponent);\r\nend;\r\n\r\n{ procedure WriteDescendentRes(const ResName: string; Instance, Ancestor: TComponent); }\r\n\r\nprocedure TStream_WriteDescendentRes(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TStream(Args.Obj).WriteDescendentRes(Args.Values[0], V2O(Args.Values[1]) as TComponent, V2O(Args.Values[2]) as\r\n TComponent);\r\nend;\r\n\r\n{ procedure ReadResHeader; }\r\n\r\nprocedure TStream_ReadResHeader(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TStream(Args.Obj).ReadResHeader;\r\nend;\r\n\r\n{ property Read Position: Longint }\r\n\r\nprocedure TStream_Read_Position(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TStream(Args.Obj).Position;\r\nend;\r\n\r\n{ property Write Position(Value: Longint) }\r\n\r\nprocedure TStream_Write_Position(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TStream(Args.Obj).Position := Value;\r\nend;\r\n\r\n{ property Read Size: Longint }\r\n\r\nprocedure TStream_Read_Size(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TStream(Args.Obj).Size;\r\nend;\r\n\r\n{ property Write Size(Value: Longint) }\r\n\r\nprocedure TStream_Write_Size(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TStream(Args.Obj).Size := Value;\r\nend;\r\n\r\n{ TFileStream }\r\n\r\n{ constructor Create(FileName: string; Mode: Word) }\r\n\r\nprocedure TFileStream_Create(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n {$IFDEF MSWINDOWS}\r\n Value := O2V(TFileStream.Create(Args.Values[0], Args.Values[1]));\r\n {$ENDIF MSWINDOWS}\r\n {$IFDEF UNIX}\r\n Value := O2V(TFileStream.Create(VarToStr(Args.Values[0]), Args.Values[1]));\r\n {$ENDIF UNIX}\r\nend;\r\n\r\n{ TMemoryStream }\r\n\r\n{ constructor Create }\r\n\r\nprocedure TMemoryStream_Create(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TMemoryStream.Create);\r\nend;\r\n\r\n{ TJvStringStream }\r\n\r\n{ constructor Create(AString: string) }\r\n\r\nprocedure TStringStream_Create(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TStringStream.Create(Args.Values[0]));\r\nend;\r\n\r\n{ function Read(var Buffer; Count: Longint): Longint; }\r\n\r\nprocedure TStringStream_Read(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TStringStream(Args.Obj).Read(Args.Values[0], Args.Values[1]);\r\nend;\r\n\r\n{ function ReadString(Count: Longint): string; }\r\n\r\nprocedure TStringStream_ReadString(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TStringStream(Args.Obj).ReadString(Args.Values[0]);\r\nend;\r\n\r\n{ function Seek(Offset: Longint; Origin: Word): Longint; }\r\n\r\nprocedure TStringStream_Seek(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TStringStream(Args.Obj).Seek(Args.Values[0], Args.Values[1]);\r\nend;\r\n\r\n{ function Write(const Buffer; Count: Longint): Longint; }\r\n\r\nprocedure TStringStream_Write(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TStringStream(Args.Obj).Write(Args.Values[0], Args.Values[1]);\r\nend;\r\n\r\n{ procedure WriteString(const AString: string); }\r\n\r\nprocedure TStringStream_WriteString(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TStringStream(Args.Obj).WriteString(Args.Values[0]);\r\nend;\r\n\r\n{ property Read DataString: string }\r\n\r\nprocedure TStringStream_Read_DataString(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TStringStream(Args.Obj).DataString;\r\nend;\r\n\r\n{ TComponent }\r\n\r\n{ constructor Create(AOwner: TComponent) }\r\n\r\nprocedure TComponent_Create(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TComponent.Create(V2O(Args.Values[0]) as TComponent));\r\nend;\r\n\r\n{ procedure DestroyComponents; }\r\n\r\nprocedure TComponent_DestroyComponents(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TComponent(Args.Obj).DestroyComponents;\r\nend;\r\n\r\n{ procedure Destroying; }\r\n\r\nprocedure TComponent_Destroying(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TComponent(Args.Obj).Destroying;\r\nend;\r\n\r\n{ function FindComponent(const AName: string): TComponent; }\r\n\r\nprocedure TComponent_FindComponent(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TComponent(Args.Obj).FindComponent(Args.Values[0]));\r\nend;\r\n\r\n{ procedure FreeNotification(AComponent: TComponent); }\r\n\r\nprocedure TComponent_FreeNotification(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TComponent(Args.Obj).FreeNotification(V2O(Args.Values[0]) as TComponent);\r\nend;\r\n\r\n{ procedure FreeOnRelease; }\r\n\r\nprocedure TComponent_FreeOnRelease(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TComponent(Args.Obj).FreeOnRelease;\r\nend;\r\n\r\n{ function GetParentComponent: TComponent; }\r\n\r\nprocedure TComponent_GetParentComponent(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TComponent(Args.Obj).GetParentComponent);\r\nend;\r\n\r\n{ function HasParent: Boolean; }\r\n\r\nprocedure TComponent_HasParent(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TComponent(Args.Obj).HasParent;\r\nend;\r\n\r\n{ procedure InsertComponent(AComponent: TComponent); }\r\n\r\nprocedure TComponent_InsertComponent(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TComponent(Args.Obj).InsertComponent(V2O(Args.Values[0]) as TComponent);\r\nend;\r\n\r\n{ procedure RemoveComponent(AComponent: TComponent); }\r\n\r\nprocedure TComponent_RemoveComponent(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TComponent(Args.Obj).RemoveComponent(V2O(Args.Values[0]) as TComponent);\r\nend;\r\n\r\n{ function SafeCallException(ExceptObject: TObject; ExceptAddr: Pointer): Integer; }\r\n\r\nprocedure TComponent_SafeCallException(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TComponent(Args.Obj).SafeCallException(V2O(Args.Values[0]), V2P(Args.Values[1]));\r\nend;\r\n\r\n{ property Read ComObject: IUnknown }\r\n\r\nprocedure TComponent_Read_ComObject(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TComponent(Args.Obj).ComObject;\r\nend;\r\n\r\n{ property Read Components[Integer]: TComponent }\r\n\r\nprocedure TComponent_Read_Components(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TComponent(Args.Obj).Components[Args.Values[0]]);\r\nend;\r\n\r\n{ property Read ComponentCount: Integer }\r\n\r\nprocedure TComponent_Read_ComponentCount(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TComponent(Args.Obj).ComponentCount;\r\nend;\r\n\r\n{ property Read ComponentIndex: Integer }\r\n\r\nprocedure TComponent_Read_ComponentIndex(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TComponent(Args.Obj).ComponentIndex;\r\nend;\r\n\r\n{ property Write ComponentIndex(Value: Integer) }\r\n\r\nprocedure TComponent_Write_ComponentIndex(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TComponent(Args.Obj).ComponentIndex := Value;\r\nend;\r\n\r\n{ property Read ComponentState: TComponentState }\r\n\r\nprocedure TComponent_Read_ComponentState(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n NotImplemented('TComponent.ComponentState');\r\n // Value := TComponent(Args.Obj).ComponentState;\r\nend;\r\n\r\n{ property Read ComponentStyle: TComponentStyle }\r\n\r\nprocedure TComponent_Read_ComponentStyle(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n NotImplemented('TComponent.ComponentState');\r\n // Value := TComponent(Args.Obj).ComponentStyle;\r\nend;\r\n\r\n{ property Read DesignInfo: Longint }\r\n\r\nprocedure TComponent_Read_DesignInfo(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TComponent(Args.Obj).DesignInfo;\r\nend;\r\n\r\n{ property Write DesignInfo(Value: Longint) }\r\n\r\nprocedure TComponent_Write_DesignInfo(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TComponent(Args.Obj).DesignInfo := Value;\r\nend;\r\n\r\n{ property Read Owner: TComponent }\r\n\r\nprocedure TComponent_Read_Owner(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TComponent(Args.Obj).Owner);\r\nend;\r\n\r\n{ property Read VCLComObject: Pointer }\r\n\r\nprocedure TComponent_Read_VCLComObject(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := P2V(TComponent(Args.Obj).VCLComObject);\r\nend;\r\n\r\n{ property Write VCLComObject(Value: Pointer) }\r\n\r\nprocedure TComponent_Write_VCLComObject(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TComponent(Args.Obj).VCLComObject := V2P(Value);\r\nend;\r\n\r\n{ property Read Name: TComponentName }\r\n\r\nprocedure TComponent_Read_Name(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TComponent(Args.Obj).Name;\r\nend;\r\n\r\n{ property Write Name(Value: TComponentName) }\r\n\r\nprocedure TComponent_Write_Name(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TComponent(Args.Obj).Name := Value;\r\nend;\r\n\r\n{ property Read Tag: Longint }\r\n\r\nprocedure TComponent_Read_Tag(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TComponent(Args.Obj).Tag;\r\nend;\r\n\r\n{ property Write Tag(Value: Longint) }\r\n\r\nprocedure TComponent_Write_Tag(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TComponent(Args.Obj).Tag := Value;\r\nend;\r\n\r\ntype\r\n TJvInterpreterClassesEvent = class(TJvInterpreterEvent)\r\n private\r\n procedure NotifyEvent(Sender: TObject);\r\n function HelpEvent(Command: Word; Data: Longint; var CallHelp: Boolean): Boolean;\r\n end;\r\n\r\nprocedure TJvInterpreterClassesEvent.NotifyEvent(Sender: TObject);\r\nbegin\r\n CallFunction(nil, [O2V(Sender)]);\r\nend;\r\n\r\nfunction TJvInterpreterClassesEvent.HelpEvent(Command: Word; Data: Longint; var CallHelp: Boolean): Boolean;\r\nbegin\r\n Result := CallFunction(nil, [Command, Data, CallHelp]);\r\n CallHelp := Args.Values[2];\r\nend;\r\n\r\nprocedure RegisterJvInterpreterAdapter(JvInterpreterAdapter: TJvInterpreterAdapter);\r\nconst\r\n cClasses = 'Classes';\r\nbegin\r\n with JvInterpreterAdapter do\r\n begin\r\n { TAlignment }\r\n AddConst(cClasses, 'taLeftJustify', Ord(taLeftJustify));\r\n AddConst(cClasses, 'taRightJustify', Ord(taRightJustify));\r\n AddConst(cClasses, 'taCenter', Ord(taCenter));\r\n { TShiftState }\r\n AddConst(cClasses, 'ssShift', Ord(ssShift));\r\n AddConst(cClasses, 'ssAlt', Ord(ssAlt));\r\n AddConst(cClasses, 'ssCtrl', Ord(ssCtrl));\r\n AddConst(cClasses, 'ssLeft', Ord(ssLeft));\r\n AddConst(cClasses, 'ssRight', Ord(ssRight));\r\n AddConst(cClasses, 'ssMiddle', Ord(ssMiddle));\r\n AddConst(cClasses, 'ssDouble', Ord(ssDouble));\r\n { TList }\r\n AddClass(cClasses, TList, 'TList');\r\n AddGet(TList, 'Create', TList_Create, 0, [varEmpty], varEmpty);\r\n AddGet(TList, 'Add', TList_Add, 1, [varEmpty], varEmpty);\r\n AddGet(TList, 'Clear', TList_Clear, 0, [varEmpty], varEmpty);\r\n AddGet(TList, 'Delete', TList_Delete, 1, [varEmpty], varEmpty);\r\n AddGet(TList, 'Exchange', TList_Exchange, 2, [varEmpty, varEmpty], varEmpty);\r\n AddGet(TList, 'Expand', TList_Expand, 0, [varEmpty], varEmpty);\r\n AddGet(TList, 'First', TList_First, 0, [varEmpty], varEmpty);\r\n AddGet(TList, 'IndexOf', TList_IndexOf, 1, [varEmpty], varEmpty);\r\n AddGet(TList, 'Insert', TList_Insert, 2, [varEmpty, varEmpty], varEmpty);\r\n AddGet(TList, 'Last', TList_Last, 0, [varEmpty], varEmpty);\r\n AddGet(TList, 'Move', TList_Move, 2, [varEmpty, varEmpty], varEmpty);\r\n AddGet(TList, 'Remove', TList_Remove, 1, [varEmpty], varEmpty);\r\n AddGet(TList, 'Pack', TList_Pack, 0, [varEmpty], varEmpty);\r\n AddGet(TList, 'Sort', TList_Sort, 1, [varEmpty], varEmpty);\r\n AddGet(TList, 'Capacity', TList_Read_Capacity, 0, [varEmpty], varEmpty);\r\n AddSet(TList, 'Capacity', TList_Write_Capacity, 0, [varEmpty]);\r\n AddGet(TList, 'Count', TList_Read_Count, 0, [varEmpty], varEmpty);\r\n AddSet(TList, 'Count', TList_Write_Count, 0, [varEmpty]);\r\n AddIGet(TList, 'Items', TList_Read_Items, 1, [varEmpty], varEmpty);\r\n AddIDGet(TList, TList_Read_Items, 1, [varEmpty], varEmpty);\r\n AddISet(TList, 'Items', TList_Write_Items, 1, [varNull]);\r\n AddIDSet(TList, TList_Write_Items, 1, [varNull]);\r\n AddGet(TList, 'List', TList_Read_List, 0, [varEmpty], varEmpty);\r\n { TPersistent }\r\n AddClass(cClasses, TPersistent, 'TPersistent');\r\n AddGet(TPersistent, 'Assign', TPersistent_Assign, 1, [varEmpty], varEmpty);\r\n AddGet(TPersistent, 'GetNamePath', TPersistent_GetNamePath, 0, [varEmpty], varEmpty);\r\n { TCollectionItem }\r\n AddClass(cClasses, TCollectionItem, 'TCollectionItem');\r\n AddGet(TCollectionItem, 'Create', TCollectionItem_Create, 1, [varEmpty], varEmpty);\r\n AddGet(TCollectionItem, 'Collection', TCollectionItem_Read_Collection, 0, [varEmpty], varEmpty);\r\n AddSet(TCollectionItem, 'Collection', TCollectionItem_Write_Collection, 0, [varEmpty]);\r\n AddGet(TCollectionItem, 'ID', TCollectionItem_Read_ID, 0, [varEmpty], varEmpty);\r\n AddGet(TCollectionItem, 'Index', TCollectionItem_Read_Index, 0, [varEmpty], varEmpty);\r\n AddSet(TCollectionItem, 'Index', TCollectionItem_Write_Index, 0, [varEmpty]);\r\n AddGet(TCollectionItem, 'DisplayName', TCollectionItem_Read_DisplayName, 0, [varEmpty], varEmpty);\r\n AddSet(TCollectionItem, 'DisplayName', TCollectionItem_Write_DisplayName, 0, [varEmpty]);\r\n { TCollection }\r\n AddClass(cClasses, TCollection, 'TCollection');\r\n AddGet(TCollection, 'Create', TCollection_Create, 1, [varEmpty], varEmpty);\r\n AddGet(TCollection, 'Add', TCollection_Add, 0, [varEmpty], varEmpty);\r\n AddGet(TCollection, 'Assign', TCollection_Assign, 1, [varEmpty], varEmpty);\r\n AddGet(TCollection, 'BeginUpdate', TCollection_BeginUpdate, 0, [varEmpty], varEmpty);\r\n AddGet(TCollection, 'Clear', TCollection_Clear, 0, [varEmpty], varEmpty);\r\n AddGet(TCollection, 'EndUpdate', TCollection_EndUpdate, 0, [varEmpty], varEmpty);\r\n AddGet(TCollection, 'FindItemID', TCollection_FindItemID, 1, [varEmpty], varEmpty);\r\n AddGet(TCollection, 'Count', TCollection_Read_Count, 0, [varEmpty], varEmpty);\r\n AddGet(TCollection, 'ItemClass', TCollection_Read_ItemClass, 0, [varEmpty], varEmpty);\r\n AddIGet(TCollection, 'Items', TCollection_Read_Items, 1, [varEmpty], varEmpty);\r\n AddIDGet(TCollection, TCollection_Read_Items, 1, [varEmpty], varEmpty);\r\n AddISet(TCollection, 'Items', TCollection_Write_Items, 1, [varNull]);\r\n AddIDSet(TCollection, TCollection_Write_Items, 1, [varNull]);\r\n { TStrings }\r\n AddClass(cClasses, TStrings, 'TStrings');\r\n AddGet(TStrings, 'Add', TStrings_Add, 1, [varEmpty], varEmpty);\r\n AddGet(TStrings, 'AddObject', TStrings_AddObject, 2, [varEmpty, varEmpty], varEmpty);\r\n AddGet(TStrings, 'Append', TStrings_Append, 1, [varEmpty], varEmpty);\r\n AddGet(TStrings, 'AddStrings', TStrings_AddStrings, 1, [varEmpty], varEmpty);\r\n AddGet(TStrings, 'Assign', TStrings_Assign, 1, [varEmpty], varEmpty);\r\n AddGet(TStrings, 'BeginUpdate', TStrings_BeginUpdate, 0, [varEmpty], varEmpty);\r\n AddGet(TStrings, 'Clear', TStrings_Clear, 0, [varEmpty], varEmpty);\r\n AddGet(TStrings, 'Delete', TStrings_Delete, 1, [varEmpty], varEmpty);\r\n AddGet(TStrings, 'EndUpdate', TStrings_EndUpdate, 0, [varEmpty], varEmpty);\r\n AddGet(TStrings, 'Equals', TStrings_Equals, 1, [varEmpty], varEmpty);\r\n AddGet(TStrings, 'Exchange', TStrings_Exchange, 2, [varEmpty, varEmpty], varEmpty);\r\n AddGet(TStrings, 'IndexOf', TStrings_IndexOf, 1, [varEmpty], varEmpty);\r\n AddGet(TStrings, 'IndexOfName', TStrings_IndexOfName, 1, [varEmpty], varEmpty);\r\n AddGet(TStrings, 'IndexOfObject', TStrings_IndexOfObject, 1, [varEmpty], varEmpty);\r\n AddGet(TStrings, 'Insert', TStrings_Insert, 2, [varEmpty, varEmpty], varEmpty);\r\n AddGet(TStrings, 'InsertObject', TStrings_InsertObject, 3, [varEmpty, varEmpty, varEmpty], varEmpty);\r\n AddGet(TStrings, 'LoadFromFile', TStrings_LoadFromFile, 1, [varEmpty], varEmpty);\r\n AddGet(TStrings, 'LoadFromStream', TStrings_LoadFromStream, 1, [varEmpty], varEmpty);\r\n AddGet(TStrings, 'Move', TStrings_Move, 2, [varEmpty, varEmpty], varEmpty);\r\n AddGet(TStrings, 'SaveToFile', TStrings_SaveToFile, 1, [varEmpty], varEmpty);\r\n AddGet(TStrings, 'SaveToStream', TStrings_SaveToStream, 1, [varEmpty], varEmpty);\r\n AddGet(TStrings, 'Capacity', TStrings_Read_Capacity, 0, [varEmpty], varEmpty);\r\n AddSet(TStrings, 'Capacity', TStrings_Write_Capacity, 0, [varEmpty]);\r\n AddGet(TStrings, 'CommaText', TStrings_Read_CommaText, 0, [varEmpty], varEmpty);\r\n AddSet(TStrings, 'CommaText', TStrings_Write_CommaText, 0, [varEmpty]);\r\n AddGet(TStrings, 'Count', TStrings_Read_Count, 0, [varEmpty], varEmpty);\r\n AddIGet(TStrings, 'Names', TStrings_Read_Names, 1, [varEmpty], varEmpty);\r\n AddIGet(TStrings, 'Values', TStrings_Read_Values, 1, [varEmpty], varEmpty);\r\n AddISet(TStrings, 'Values', TStrings_Write_Values, 1, [varNull]); // ivan_ra\r\n AddIGet(TStrings, 'Objects', TStrings_Read_Objects, 1, [varEmpty], varEmpty);\r\n AddISet(TStrings, 'Objects', TStrings_Write_Objects, 1, [varNull]);\r\n AddIGet(TStrings, 'Strings', TStrings_Read_Strings, 1, [varEmpty], varEmpty);\r\n AddISet(TStrings, 'Strings', TStrings_Write_Strings, 1, [varNull]);\r\n AddIDGet(TStrings, TStrings_Read_Strings, 1, [varEmpty], varEmpty);\r\n AddIDSet(TStrings, TStrings_Write_Strings, 1, [varNull]);\r\n AddGet(TStrings, 'Text', TStrings_Read_Text, 0, [varEmpty], varEmpty);\r\n AddSet(TStrings, 'Text', TStrings_Write_Text, 0, [varEmpty]);\r\n AddGet(TStrings, 'StringsAdapter', TStrings_Read_StringsAdapter, 0, [varEmpty], varEmpty);\r\n AddSet(TStrings, 'StringsAdapter', TStrings_Write_StringsAdapter, 0, [varEmpty]);\r\n { TDuplicates }\r\n AddConst(cClasses, 'dupIgnore', Ord(dupIgnore));\r\n AddConst(cClasses, 'dupAccept', Ord(dupAccept));\r\n AddConst(cClasses, 'dupError', Ord(dupError));\r\n { TStringList }\r\n AddClass(cClasses, TStringList, 'TStringList');\r\n AddGet(TStringList, 'Create', TStringList_Create, 0, [varEmpty], varEmpty);\r\n AddGet(TStringList, 'Add', TStringList_Add, 1, [varEmpty], varEmpty);\r\n AddGet(TStringList, 'Clear', TStringList_Clear, 0, [varEmpty], varEmpty);\r\n AddGet(TStringList, 'Delete', TStringList_Delete, 1, [varEmpty], varEmpty);\r\n AddGet(TStringList, 'Exchange', TStringList_Exchange, 2, [varEmpty, varEmpty], varEmpty);\r\n AddGet(TStringList, 'Find', TStringList_Find, 2, [varEmpty, varByRef], varEmpty);\r\n AddGet(TStringList, 'IndexOf', TStringList_IndexOf, 1, [varEmpty], varEmpty);\r\n AddGet(TStringList, 'Insert', TStringList_Insert, 2, [varEmpty, varEmpty], varEmpty);\r\n AddGet(TStringList, 'Sort', TStringList_Sort, 0, [varEmpty], varEmpty);\r\n AddGet(TStringList, 'Duplicates', TStringList_Read_Duplicates, 0, [varEmpty], varEmpty);\r\n AddSet(TStringList, 'Duplicates', TStringList_Write_Duplicates, 0, [varEmpty]);\r\n AddGet(TStringList, 'Sorted', TStringList_Read_Sorted, 0, [varEmpty], varEmpty);\r\n AddSet(TStringList, 'Sorted', TStringList_Write_Sorted, 0, [varEmpty]);\r\n { TStream }\r\n AddClass(cClasses, TStream, 'TStream');\r\n AddGet(TStream, 'Read', TStream_Read, 2, [varByRef, varEmpty], varEmpty);\r\n AddGet(TStream, 'Write', TStream_Write, 2, [varEmpty, varEmpty], varEmpty);\r\n AddGet(TStream, 'Seek', TStream_Seek, 2, [varEmpty, varEmpty], varEmpty);\r\n AddGet(TStream, 'ReadBuffer', TStream_ReadBuffer, 2, [varByRef, varEmpty], varEmpty);\r\n AddGet(TStream, 'WriteBuffer', TStream_WriteBuffer, 2, [varEmpty, varEmpty], varEmpty);\r\n AddGet(TStream, 'CopyFrom', TStream_CopyFrom, 2, [varEmpty, varEmpty], varEmpty);\r\n AddGet(TStream, 'ReadComponent', TStream_ReadComponent, 1, [varEmpty], varEmpty);\r\n AddGet(TStream, 'ReadComponentRes', TStream_ReadComponentRes, 1, [varEmpty], varEmpty);\r\n AddGet(TStream, 'WriteComponent', TStream_WriteComponent, 1, [varEmpty], varEmpty);\r\n AddGet(TStream, 'WriteComponentRes', TStream_WriteComponentRes, 2, [varEmpty, varEmpty], varEmpty);\r\n AddGet(TStream, 'WriteDescendent', TStream_WriteDescendent, 2, [varEmpty, varEmpty], varEmpty);\r\n AddGet(TStream, 'WriteDescendentRes', TStream_WriteDescendentRes, 3, [varEmpty, varEmpty, varEmpty], varEmpty);\r\n AddGet(TStream, 'ReadResHeader', TStream_ReadResHeader, 0, [varEmpty], varEmpty);\r\n AddGet(TStream, 'Position', TStream_Read_Position, 0, [varEmpty], varEmpty);\r\n AddSet(TStream, 'Position', TStream_Write_Position, 0, [varEmpty]);\r\n AddGet(TStream, 'Size', TStream_Read_Size, 0, [varEmpty], varEmpty);\r\n AddSet(TStream, 'Size', TStream_Write_Size, 0, [varEmpty]);\r\n { TFileStream }\r\n AddClass(cClasses, TFileStream, 'TFileStream');\r\n AddGet(TFileStream, 'Create', TFileStream_Create, 2, [varEmpty, varEmpty], varEmpty);\r\n { TMemoryStream }\r\n AddClass(cClasses, TMemoryStream, 'TMemoryStream');\r\n AddGet(TMemoryStream, 'Create', TMemoryStream_Create, 0, [varEmpty], varEmpty);\r\n { TJvStringStream }\r\n AddClass(cClasses, TStringStream, 'TStringStream ');\r\n AddGet(TStringStream, 'Create', TStringStream_Create, 1, [varEmpty], varEmpty);\r\n AddGet(TStringStream, 'Read', TStringStream_Read, 2, [varByRef, varEmpty], varEmpty);\r\n AddGet(TStringStream, 'ReadString', TStringStream_ReadString, 1, [varEmpty], varEmpty);\r\n AddGet(TStringStream, 'Seek', TStringStream_Seek, 2, [varEmpty, varEmpty], varEmpty);\r\n AddGet(TStringStream, 'Write', TStringStream_Write, 2, [varEmpty, varEmpty], varEmpty);\r\n AddGet(TStringStream, 'WriteString', TStringStream_WriteString, 1, [varEmpty], varEmpty);\r\n AddGet(TStringStream, 'DataString', TStringStream_Read_DataString, 0, [varEmpty], varEmpty);\r\n { TComponentState }\r\n AddConst(cClasses, 'csLoading', Ord(csLoading));\r\n AddConst(cClasses, 'csReading', Ord(csReading));\r\n AddConst(cClasses, 'csWriting', Ord(csWriting));\r\n AddConst(cClasses, 'csDestroying', Ord(csDestroying));\r\n AddConst(cClasses, 'csDesigning', Ord(csDesigning));\r\n AddConst(cClasses, 'csAncestor', Ord(csAncestor));\r\n AddConst(cClasses, 'csUpdating', Ord(csUpdating));\r\n AddConst(cClasses, 'csFixups', Ord(csFixups));\r\n { TComponentStyle }\r\n AddConst(cClasses, 'csInheritable', Ord(csInheritable));\r\n AddConst(cClasses, 'csCheckPropAvail', Ord(csCheckPropAvail));\r\n { TComponent }\r\n AddClass(cClasses, TComponent, 'TComponent');\r\n AddGet(TComponent, 'Create', TComponent_Create, 1, [varEmpty], varEmpty);\r\n AddGet(TComponent, 'DestroyComponents', TComponent_DestroyComponents, 0, [varEmpty], varEmpty);\r\n AddGet(TComponent, 'Destroying', TComponent_Destroying, 0, [varEmpty], varEmpty);\r\n AddGet(TComponent, 'FindComponent', TComponent_FindComponent, 1, [varEmpty], varEmpty);\r\n AddGet(TComponent, 'FreeNotification', TComponent_FreeNotification, 1, [varEmpty], varEmpty);\r\n AddGet(TComponent, 'FreeOnRelease', TComponent_FreeOnRelease, 0, [varEmpty], varEmpty);\r\n AddGet(TComponent, 'GetParentComponent', TComponent_GetParentComponent, 0, [varEmpty], varEmpty);\r\n AddGet(TComponent, 'HasParent', TComponent_HasParent, 0, [varEmpty], varEmpty);\r\n AddGet(TComponent, 'InsertComponent', TComponent_InsertComponent, 1, [varEmpty], varEmpty);\r\n AddGet(TComponent, 'RemoveComponent', TComponent_RemoveComponent, 1, [varEmpty], varEmpty);\r\n AddGet(TComponent, 'SafeCallException', TComponent_SafeCallException, 2, [varEmpty, varEmpty], varEmpty);\r\n AddGet(TComponent, 'ComObject', TComponent_Read_ComObject, 0, [varEmpty], varEmpty);\r\n AddIGet(TComponent, 'Components', TComponent_Read_Components, 1, [varEmpty], varEmpty);\r\n AddGet(TComponent, 'ComponentCount', TComponent_Read_ComponentCount, 0, [varEmpty], varEmpty);\r\n AddGet(TComponent, 'ComponentIndex', TComponent_Read_ComponentIndex, 0, [varEmpty], varEmpty);\r\n AddSet(TComponent, 'ComponentIndex', TComponent_Write_ComponentIndex, 0, [varEmpty]);\r\n AddGet(TComponent, 'ComponentState', TComponent_Read_ComponentState, 0, [varEmpty], varEmpty);\r\n AddGet(TComponent, 'ComponentStyle', TComponent_Read_ComponentStyle, 0, [varEmpty], varEmpty);\r\n AddGet(TComponent, 'DesignInfo', TComponent_Read_DesignInfo, 0, [varEmpty], varEmpty);\r\n AddSet(TComponent, 'DesignInfo', TComponent_Write_DesignInfo, 0, [varEmpty]);\r\n AddGet(TComponent, 'Owner', TComponent_Read_Owner, 0, [varEmpty], varEmpty);\r\n AddGet(TComponent, 'VCLComObject', TComponent_Read_VCLComObject, 0, [varEmpty], varEmpty);\r\n AddSet(TComponent, 'VCLComObject', TComponent_Write_VCLComObject, 0, [varEmpty]);\r\n AddGet(TComponent, 'Name', TComponent_Read_Name, 0, [varEmpty], varEmpty);\r\n AddSet(TComponent, 'Name', TComponent_Write_Name, 0, [varEmpty]);\r\n AddGet(TComponent, 'Tag', TComponent_Read_Tag, 0, [varEmpty], varEmpty);\r\n AddSet(TComponent, 'Tag', TComponent_Write_Tag, 0, [varEmpty]);\r\n\r\n AddHandler(cClasses, 'TNotifyEvent', TJvInterpreterClassesEvent, @TJvInterpreterClassesEvent.NotifyEvent);\r\n AddHandler(cClasses, 'THelpEvent', TJvInterpreterClassesEvent, @TJvInterpreterClassesEvent.HelpEvent);\r\n end;\r\n RegisterClasses([TPersistent, TCollection, TCollectionItem, TStrings,\r\n TStringList, TComponent]);\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvInterpreter_ComCtrls.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvInterpreter_ComCtrls.PAS, released on 2002-07-04.\r\n\r\nThe Initial Developers of the Original Code are: Andrei Prygounkov \r\nCopyright (c) 1999, 2002 Andrei Prygounkov\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nDescription : adapter unit - converts JvInterpreter calls to delphi calls\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvInterpreter_ComCtrls.pas 13173 2011-11-19 12:43:58Z ahuser $\r\n\r\nunit JvInterpreter_ComCtrls;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n JvInterpreter;\r\n\r\nprocedure RegisterJvInterpreterAdapter(JvInterpreterAdapter: TJvInterpreterAdapter);\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvInterpreter_ComCtrls.pas $';\r\n Revision: '$Revision: 13173 $';\r\n Date: '$Date: 2011-11-19 13:43:58 +0100 (sam. 19 nov. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n Windows, Classes, Controls, Graphics, ComCtrls,\r\n JvInterpreter_Windows;\r\n\r\n{ TTabControl }\r\n\r\n{ constructor Create(AOwner: TComponent) }\r\n\r\nprocedure TTabControl_Create(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TTabControl.Create(V2O(Args.Values[0]) as TComponent));\r\nend;\r\n\r\n{ TTabSheet }\r\n\r\n{ constructor Create(AOwner: TComponent) }\r\n\r\nprocedure TTabSheet_Create(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TTabSheet.Create(V2O(Args.Values[0]) as TComponent));\r\nend;\r\n\r\n{ property Read PageControl: TPageControl }\r\n\r\nprocedure TTabSheet_Read_PageControl(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TTabSheet(Args.Obj).PageControl);\r\nend;\r\n\r\n{ property Write PageControl(Value: TPageControl) }\r\n\r\nprocedure TTabSheet_Write_PageControl(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TTabSheet(Args.Obj).PageControl := V2O(Value) as TPageControl;\r\nend;\r\n\r\n{ property Read TabIndex: Integer }\r\n\r\nprocedure TTabSheet_Read_TabIndex(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TTabSheet(Args.Obj).TabIndex;\r\nend;\r\n\r\n{ TPageControl }\r\n\r\n{ constructor Create(AOwner: TComponent) }\r\n\r\nprocedure TPageControl_Create(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TPageControl.Create(V2O(Args.Values[0]) as TComponent));\r\nend;\r\n\r\n{ function FindNextPage(CurPage: TTabSheet; GoForward, CheckTabVisible: Boolean): TTabSheet; }\r\n\r\nprocedure TPageControl_FindNextPage(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TPageControl(Args.Obj).FindNextPage(V2O(Args.Values[0]) as TTabSheet, Args.Values[1], Args.Values[2]));\r\nend;\r\n\r\n{ procedure SelectNextPage(GoForward: Boolean); }\r\n\r\nprocedure TPageControl_SelectNextPage(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TPageControl(Args.Obj).SelectNextPage(Args.Values[0]);\r\nend;\r\n\r\n{ property Read PageCount: Integer }\r\n\r\nprocedure TPageControl_Read_PageCount(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TPageControl(Args.Obj).PageCount;\r\nend;\r\n\r\n{ property Read Pages[Integer]: TTabSheet }\r\n\r\nprocedure TPageControl_Read_Pages(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TPageControl(Args.Obj).Pages[Args.Values[0]]);\r\nend;\r\n\r\n{ TStatusPanel }\r\n\r\n{ constructor Create(Collection: TCollection) }\r\n\r\nprocedure TStatusPanel_Create(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TStatusPanel.Create(V2O(Args.Values[0]) as TCollection));\r\nend;\r\n\r\n{ procedure Assign(Source: TPersistent); }\r\n\r\nprocedure TStatusPanel_Assign(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TStatusPanel(Args.Obj).Assign(V2O(Args.Values[0]) as TPersistent);\r\nend;\r\n\r\n{ TStatusPanels }\r\n\r\n{ constructor Create(StatusBar: TStatusBar) }\r\n\r\nprocedure TStatusPanels_Create(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TStatusPanels.Create(V2O(Args.Values[0]) as TStatusBar));\r\nend;\r\n\r\n{ function Add: TStatusPanel; }\r\n\r\nprocedure TStatusPanels_Add(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TStatusPanels(Args.Obj).Add);\r\nend;\r\n\r\n{ property Read Items[Integer]: TStatusPanel }\r\n\r\nprocedure TStatusPanels_Read_Items(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TStatusPanels(Args.Obj).Items[Args.Values[0]]);\r\nend;\r\n\r\n{ property Write Items[Integer]: TStatusPanel }\r\n\r\nprocedure TStatusPanels_Write_Items(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TStatusPanels(Args.Obj).Items[Args.Values[0]] := V2O(Value) as TStatusPanel;\r\nend;\r\n\r\n{ TStatusBar }\r\n\r\n{ constructor Create(AOwner: TComponent) }\r\n\r\nprocedure TStatusBar_Create(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TStatusBar.Create(V2O(Args.Values[0]) as TComponent));\r\nend;\r\n\r\n{ property Read Canvas: TCanvas }\r\n\r\nprocedure TStatusBar_Read_Canvas(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TStatusBar(Args.Obj).Canvas);\r\nend;\r\n\r\n{ THeaderSection }\r\n\r\n{ constructor Create(Collection: TCollection) }\r\n\r\nprocedure THeaderSection_Create(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(THeaderSection.Create(V2O(Args.Values[0]) as TCollection));\r\nend;\r\n\r\n{ procedure Assign(Source: TPersistent); }\r\n\r\nprocedure THeaderSection_Assign(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n THeaderSection(Args.Obj).Assign(V2O(Args.Values[0]) as TPersistent);\r\nend;\r\n\r\n{ property Read Left: Integer }\r\n\r\nprocedure THeaderSection_Read_Left(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := THeaderSection(Args.Obj).Left;\r\nend;\r\n\r\n{ property Read Right: Integer }\r\n\r\nprocedure THeaderSection_Read_Right(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := THeaderSection(Args.Obj).Right;\r\nend;\r\n\r\n{ THeaderSections }\r\n\r\n{ constructor Create(HeaderControl: THeaderControl) }\r\n\r\nprocedure THeaderSections_Create(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(THeaderSections.Create(V2O(Args.Values[0]) as THeaderControl));\r\nend;\r\n\r\n{ function Add: THeaderSection; }\r\n\r\nprocedure THeaderSections_Add(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(THeaderSections(Args.Obj).Add);\r\nend;\r\n\r\n{ property Read Items[Integer]: THeaderSection }\r\n\r\nprocedure THeaderSections_Read_Items(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(THeaderSections(Args.Obj).Items[Args.Values[0]]);\r\nend;\r\n\r\n{ property Write Items[Integer]: THeaderSection }\r\n\r\nprocedure THeaderSections_Write_Items(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n THeaderSections(Args.Obj).Items[Args.Values[0]] := V2O(Value) as THeaderSection;\r\nend;\r\n\r\n{ THeaderControl }\r\n\r\n{ constructor Create(AOwner: TComponent) }\r\n\r\nprocedure THeaderControl_Create(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(THeaderControl.Create(V2O(Args.Values[0]) as TComponent));\r\nend;\r\n\r\n{ property Read Canvas: TCanvas }\r\n\r\nprocedure THeaderControl_Read_Canvas(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(THeaderControl(Args.Obj).Canvas);\r\nend;\r\n\r\n{ TTreeNode }\r\n\r\n{ constructor Create(AOwner: TTreeNodes) }\r\n\r\nprocedure TTreeNode_Create(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TTreeNode.Create(V2O(Args.Values[0]) as TTreeNodes));\r\nend;\r\n\r\n{ function AlphaSort: Boolean; }\r\n\r\nprocedure TTreeNode_AlphaSort(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TTreeNode(Args.Obj).AlphaSort;\r\nend;\r\n\r\n{ procedure Assign(Source: TPersistent); }\r\n\r\nprocedure TTreeNode_Assign(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TTreeNode(Args.Obj).Assign(V2O(Args.Values[0]) as TPersistent);\r\nend;\r\n\r\n{ procedure Collapse(Recurse: Boolean); }\r\n\r\nprocedure TTreeNode_Collapse(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TTreeNode(Args.Obj).Collapse(Args.Values[0]);\r\nend;\r\n\r\n{ function CustomSort(SortProc: TTVCompare; Data: Longint): Boolean; }\r\n\r\nprocedure TTreeNode_CustomSort(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n// Value := TTreeNode(Args.Obj).CustomSort(Args.Values[0], Args.Values[1]);\r\n NotImplemented('TTreeNode.CustomSort');\r\nend;\r\n\r\n{ procedure Delete; }\r\n\r\nprocedure TTreeNode_Delete(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TTreeNode(Args.Obj).Delete;\r\nend;\r\n\r\n{ procedure DeleteChildren; }\r\n\r\nprocedure TTreeNode_DeleteChildren(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TTreeNode(Args.Obj).DeleteChildren;\r\nend;\r\n\r\n{ function DisplayRect(TextOnly: Boolean): TRect; }\r\n\r\nprocedure TTreeNode_DisplayRect(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := Rect2Var(TTreeNode(Args.Obj).DisplayRect(Args.Values[0]));\r\nend;\r\n\r\n{ function EditText: Boolean; }\r\n\r\nprocedure TTreeNode_EditText(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TTreeNode(Args.Obj).EditText;\r\nend;\r\n\r\n{ procedure EndEdit(Cancel: Boolean); }\r\n\r\nprocedure TTreeNode_EndEdit(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TTreeNode(Args.Obj).EndEdit(Args.Values[0]);\r\nend;\r\n\r\n{ procedure Expand(Recurse: Boolean); }\r\n\r\nprocedure TTreeNode_Expand(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TTreeNode(Args.Obj).Expand(Args.Values[0]);\r\nend;\r\n\r\n{ function GetFirstChild: TTreeNode; }\r\n\r\nprocedure TTreeNode_GetFirstChild(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TTreeNode(Args.Obj).GetFirstChild);\r\nend;\r\n\r\n{ function GetHandle: HWND; }\r\n\r\nprocedure TTreeNode_GetHandle(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := NativeInt(TTreeNode(Args.Obj).GetHandle);\r\nend;\r\n\r\n{ function GetLastChild: TTreeNode; }\r\n\r\nprocedure TTreeNode_GetLastChild(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TTreeNode(Args.Obj).GetLastChild);\r\nend;\r\n\r\n{ function GetNext: TTreeNode; }\r\n\r\nprocedure TTreeNode_GetNext(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TTreeNode(Args.Obj).GetNext);\r\nend;\r\n\r\n{ function GetNextChild(Value: TTreeNode): TTreeNode; }\r\n\r\nprocedure TTreeNode_GetNextChild(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TTreeNode(Args.Obj).GetNextChild(V2O(Args.Values[0]) as TTreeNode));\r\nend;\r\n\r\n{ function GetNextSibling: TTreeNode; }\r\n\r\nprocedure TTreeNode_GetNextSibling(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TTreeNode(Args.Obj).GetNextSibling);\r\nend;\r\n\r\n{ function GetNextVisible: TTreeNode; }\r\n\r\nprocedure TTreeNode_GetNextVisible(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TTreeNode(Args.Obj).GetNextVisible);\r\nend;\r\n\r\n{ function GetPrev: TTreeNode; }\r\n\r\nprocedure TTreeNode_GetPrev(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TTreeNode(Args.Obj).GetPrev);\r\nend;\r\n\r\n{ function GetPrevChild(Value: TTreeNode): TTreeNode; }\r\n\r\nprocedure TTreeNode_GetPrevChild(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TTreeNode(Args.Obj).GetPrevChild(V2O(Args.Values[0]) as TTreeNode));\r\nend;\r\n\r\n{ function GetPrevSibling: TTreeNode; }\r\n\r\nprocedure TTreeNode_GetPrevSibling(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TTreeNode(Args.Obj).GetPrevSibling);\r\nend;\r\n\r\n{ function GetPrevVisible: TTreeNode; }\r\n\r\nprocedure TTreeNode_GetPrevVisible(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TTreeNode(Args.Obj).GetPrevVisible);\r\nend;\r\n\r\n{ function HasAsParent(Value: TTreeNode): Boolean; }\r\n\r\nprocedure TTreeNode_HasAsParent(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TTreeNode(Args.Obj).HasAsParent(V2O(Args.Values[0]) as TTreeNode);\r\nend;\r\n\r\n{ function IndexOf(Value: TTreeNode): Integer; }\r\n\r\nprocedure TTreeNode_IndexOf(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TTreeNode(Args.Obj).IndexOf(V2O(Args.Values[0]) as TTreeNode);\r\nend;\r\n\r\n{ procedure MakeVisible; }\r\n\r\nprocedure TTreeNode_MakeVisible(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TTreeNode(Args.Obj).MakeVisible;\r\nend;\r\n\r\n{ procedure MoveTo(Destination: TTreeNode; Mode: TNodeAttachMode); }\r\n\r\nprocedure TTreeNode_MoveTo(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TTreeNode(Args.Obj).MoveTo(V2O(Args.Values[0]) as TTreeNode, Args.Values[1]);\r\nend;\r\n\r\n{ property Read AbsoluteIndex: Integer }\r\n\r\nprocedure TTreeNode_Read_AbsoluteIndex(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TTreeNode(Args.Obj).AbsoluteIndex;\r\nend;\r\n\r\n{ property Read Count: Integer }\r\n\r\nprocedure TTreeNode_Read_Count(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TTreeNode(Args.Obj).Count;\r\nend;\r\n\r\n{ property Read Cut: Boolean }\r\n\r\nprocedure TTreeNode_Read_Cut(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TTreeNode(Args.Obj).Cut;\r\nend;\r\n\r\n{ property Write Cut(Value: Boolean) }\r\n\r\nprocedure TTreeNode_Write_Cut(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TTreeNode(Args.Obj).Cut := Value;\r\nend;\r\n\r\n{ property Read Data: Pointer }\r\n\r\nprocedure TTreeNode_Read_Data(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := P2V(TTreeNode(Args.Obj).Data);\r\nend;\r\n\r\n{ property Write Data(Value: Pointer) }\r\n\r\nprocedure TTreeNode_Write_Data(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TTreeNode(Args.Obj).Data := V2P(Value);\r\nend;\r\n\r\n{ property Read Deleting: Boolean }\r\n\r\nprocedure TTreeNode_Read_Deleting(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TTreeNode(Args.Obj).Deleting;\r\nend;\r\n\r\n{ property Read Focused: Boolean }\r\n\r\nprocedure TTreeNode_Read_Focused(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TTreeNode(Args.Obj).Focused;\r\nend;\r\n\r\n{ property Write Focused(Value: Boolean) }\r\n\r\nprocedure TTreeNode_Write_Focused(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TTreeNode(Args.Obj).Focused := Value;\r\nend;\r\n\r\n{ property Read DropTarget: Boolean }\r\n\r\nprocedure TTreeNode_Read_DropTarget(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TTreeNode(Args.Obj).DropTarget;\r\nend;\r\n\r\n{ property Write DropTarget(Value: Boolean) }\r\n\r\nprocedure TTreeNode_Write_DropTarget(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TTreeNode(Args.Obj).DropTarget := Value;\r\nend;\r\n\r\n{ property Read Selected: Boolean }\r\n\r\nprocedure TTreeNode_Read_Selected(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TTreeNode(Args.Obj).Selected;\r\nend;\r\n\r\n{ property Write Selected(Value: Boolean) }\r\n\r\nprocedure TTreeNode_Write_Selected(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TTreeNode(Args.Obj).Selected := Value;\r\nend;\r\n\r\n{ property Read Expanded: Boolean }\r\n\r\nprocedure TTreeNode_Read_Expanded(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TTreeNode(Args.Obj).Expanded;\r\nend;\r\n\r\n{ property Write Expanded(Value: Boolean) }\r\n\r\nprocedure TTreeNode_Write_Expanded(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TTreeNode(Args.Obj).Expanded := Value;\r\nend;\r\n\r\n{ property Read Handle: HWND }\r\n\r\nprocedure TTreeNode_Read_Handle(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := NativeInt(TTreeNode(Args.Obj).Handle);\r\nend;\r\n\r\n{ property Read HasChildren: Boolean }\r\n\r\nprocedure TTreeNode_Read_HasChildren(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TTreeNode(Args.Obj).HasChildren;\r\nend;\r\n\r\n{ property Write HasChildren(Value: Boolean) }\r\n\r\nprocedure TTreeNode_Write_HasChildren(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TTreeNode(Args.Obj).HasChildren := Value;\r\nend;\r\n\r\n{ property Read ImageIndex: Integer }\r\n\r\nprocedure TTreeNode_Read_ImageIndex(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TTreeNode(Args.Obj).ImageIndex;\r\nend;\r\n\r\n{ property Write ImageIndex(Value: Integer) }\r\n\r\nprocedure TTreeNode_Write_ImageIndex(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TTreeNode(Args.Obj).ImageIndex := Value;\r\nend;\r\n\r\n{ property Read Index: Integer }\r\n\r\nprocedure TTreeNode_Read_Index(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TTreeNode(Args.Obj).Index;\r\nend;\r\n\r\n{ property Read IsVisible: Boolean }\r\n\r\nprocedure TTreeNode_Read_IsVisible(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TTreeNode(Args.Obj).IsVisible;\r\nend;\r\n\r\n{ property Read Item[Integer]: TTreeNode }\r\n\r\nprocedure TTreeNode_Read_Item(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TTreeNode(Args.Obj).Item[Args.Values[0]]);\r\nend;\r\n\r\n{ property Write Item[Integer]: TTreeNode }\r\n\r\nprocedure TTreeNode_Write_Item(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TTreeNode(Args.Obj).Item[Args.Values[0]] := V2O(Value) as TTreeNode;\r\nend;\r\n\r\n{ property Read ItemId: HTreeItem }\r\n\r\nprocedure TTreeNode_Read_ItemId(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := P2V(TTreeNode(Args.Obj).ItemId);\r\nend;\r\n\r\n{ property Read Level: Integer }\r\n\r\nprocedure TTreeNode_Read_Level(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TTreeNode(Args.Obj).Level;\r\nend;\r\n\r\n{ property Read OverlayIndex: Integer }\r\n\r\nprocedure TTreeNode_Read_OverlayIndex(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TTreeNode(Args.Obj).OverlayIndex;\r\nend;\r\n\r\n{ property Write OverlayIndex(Value: Integer) }\r\n\r\nprocedure TTreeNode_Write_OverlayIndex(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TTreeNode(Args.Obj).OverlayIndex := Value;\r\nend;\r\n\r\n{ property Read Owner: TTreeNodes }\r\n\r\nprocedure TTreeNode_Read_Owner(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TTreeNode(Args.Obj).Owner);\r\nend;\r\n\r\n{ property Read Parent: TTreeNode }\r\n\r\nprocedure TTreeNode_Read_Parent(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TTreeNode(Args.Obj).Parent);\r\nend;\r\n\r\n{ property Read SelectedIndex: Integer }\r\n\r\nprocedure TTreeNode_Read_SelectedIndex(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TTreeNode(Args.Obj).SelectedIndex;\r\nend;\r\n\r\n{ property Write SelectedIndex(Value: Integer) }\r\n\r\nprocedure TTreeNode_Write_SelectedIndex(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TTreeNode(Args.Obj).SelectedIndex := Value;\r\nend;\r\n\r\n{ property Read StateIndex: Integer }\r\n\r\nprocedure TTreeNode_Read_StateIndex(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TTreeNode(Args.Obj).StateIndex;\r\nend;\r\n\r\n{ property Write StateIndex(Value: Integer) }\r\n\r\nprocedure TTreeNode_Write_StateIndex(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TTreeNode(Args.Obj).StateIndex := Value;\r\nend;\r\n\r\n{ property Read Text: string }\r\n\r\nprocedure TTreeNode_Read_Text(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TTreeNode(Args.Obj).Text;\r\nend;\r\n\r\n{ property Write Text(Value: string) }\r\n\r\nprocedure TTreeNode_Write_Text(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TTreeNode(Args.Obj).Text := Value;\r\nend;\r\n\r\n{ property Read TreeView: TCustomTreeView }\r\n\r\nprocedure TTreeNode_Read_TreeView(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TTreeNode(Args.Obj).TreeView);\r\nend;\r\n\r\n{ TTreeNodes }\r\n\r\n{ constructor Create(AOwner: TCustomTreeView) }\r\n\r\nprocedure TTreeNodes_Create(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TTreeNodes.Create(V2O(Args.Values[0]) as TCustomTreeView));\r\nend;\r\n\r\n{ function AddChildFirst(Node: TTreeNode; const S: string): TTreeNode; }\r\n\r\nprocedure TTreeNodes_AddChildFirst(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TTreeNodes(Args.Obj).AddChildFirst(V2O(Args.Values[0]) as TTreeNode, Args.Values[1]));\r\nend;\r\n\r\n{ function AddChild(Node: TTreeNode; const S: string): TTreeNode; }\r\n\r\nprocedure TTreeNodes_AddChild(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TTreeNodes(Args.Obj).AddChild(V2O(Args.Values[0]) as TTreeNode, Args.Values[1]));\r\nend;\r\n\r\n{ function AddChildObjectFirst(Node: TTreeNode; const S: string; Ptr: Pointer): TTreeNode; }\r\n\r\nprocedure TTreeNodes_AddChildObjectFirst(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TTreeNodes(Args.Obj).AddChildObjectFirst(V2O(Args.Values[0]) as TTreeNode, Args.Values[1],\r\n V2P(Args.Values[2])));\r\nend;\r\n\r\n{ function AddChildObject(Node: TTreeNode; const S: string; Ptr: Pointer): TTreeNode; }\r\n\r\nprocedure TTreeNodes_AddChildObject(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TTreeNodes(Args.Obj).AddChildObject(V2O(Args.Values[0]) as TTreeNode, Args.Values[1],\r\n V2P(Args.Values[2])));\r\nend;\r\n\r\n{ function AddFirst(Node: TTreeNode; const S: string): TTreeNode; }\r\n\r\nprocedure TTreeNodes_AddFirst(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TTreeNodes(Args.Obj).AddFirst(V2O(Args.Values[0]) as TTreeNode, Args.Values[1]));\r\nend;\r\n\r\n{ function Add(Node: TTreeNode; const S: string): TTreeNode; }\r\n\r\nprocedure TTreeNodes_Add(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TTreeNodes(Args.Obj).Add(V2O(Args.Values[0]) as TTreeNode, Args.Values[1]));\r\nend;\r\n\r\n{ function AddObjectFirst(Node: TTreeNode; const S: string; Ptr: Pointer): TTreeNode; }\r\n\r\nprocedure TTreeNodes_AddObjectFirst(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TTreeNodes(Args.Obj).AddObjectFirst(V2O(Args.Values[0]) as TTreeNode, Args.Values[1],\r\n V2P(Args.Values[2])));\r\nend;\r\n\r\n{ function AddObject(Node: TTreeNode; const S: string; Ptr: Pointer): TTreeNode; }\r\n\r\nprocedure TTreeNodes_AddObject(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TTreeNodes(Args.Obj).AddObject(V2O(Args.Values[0]) as TTreeNode, Args.Values[1], V2P(Args.Values[2])));\r\nend;\r\n\r\n{ procedure Assign(Source: TPersistent); }\r\n\r\nprocedure TTreeNodes_Assign(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TTreeNodes(Args.Obj).Assign(V2O(Args.Values[0]) as TPersistent);\r\nend;\r\n\r\n{ procedure BeginUpdate; }\r\n\r\nprocedure TTreeNodes_BeginUpdate(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TTreeNodes(Args.Obj).BeginUpdate;\r\nend;\r\n\r\n{ procedure Clear; }\r\n\r\nprocedure TTreeNodes_Clear(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TTreeNodes(Args.Obj).Clear;\r\nend;\r\n\r\n{ procedure Delete(Node: TTreeNode); }\r\n\r\nprocedure TTreeNodes_Delete(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TTreeNodes(Args.Obj).Delete(V2O(Args.Values[0]) as TTreeNode);\r\nend;\r\n\r\n{ procedure EndUpdate; }\r\n\r\nprocedure TTreeNodes_EndUpdate(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TTreeNodes(Args.Obj).EndUpdate;\r\nend;\r\n\r\n{ function GetFirstNode: TTreeNode; }\r\n\r\nprocedure TTreeNodes_GetFirstNode(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TTreeNodes(Args.Obj).GetFirstNode);\r\nend;\r\n\r\n{ function GetNode(ItemId: HTreeItem): TTreeNode; }\r\n\r\nprocedure TTreeNodes_GetNode(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TTreeNodes(Args.Obj).GetNode(V2P(Args.Values[0])));\r\nend;\r\n\r\n{ function Insert(Node: TTreeNode; const S: string): TTreeNode; }\r\n\r\nprocedure TTreeNodes_Insert(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TTreeNodes(Args.Obj).Insert(V2O(Args.Values[0]) as TTreeNode, Args.Values[1]));\r\nend;\r\n\r\n{ function InsertObject(Node: TTreeNode; const S: string; Ptr: Pointer): TTreeNode; }\r\n\r\nprocedure TTreeNodes_InsertObject(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TTreeNodes(Args.Obj).InsertObject(V2O(Args.Values[0]) as TTreeNode, Args.Values[1],\r\n V2P(Args.Values[2])));\r\nend;\r\n\r\n{ property Read Count: Integer }\r\n\r\nprocedure TTreeNodes_Read_Count(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TTreeNodes(Args.Obj).Count;\r\nend;\r\n\r\n{ property Read Handle: HWND }\r\n\r\nprocedure TTreeNodes_Read_Handle(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := NativeInt(TTreeNodes(Args.Obj).Handle);\r\nend;\r\n\r\n{ property Read Item[Integer]: TTreeNode }\r\n\r\nprocedure TTreeNodes_Read_Item(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TTreeNodes(Args.Obj).Item[Args.Values[0]]);\r\nend;\r\n\r\n{ property Read Owner: TCustomTreeView }\r\n\r\nprocedure TTreeNodes_Read_Owner(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TTreeNodes(Args.Obj).Owner);\r\nend;\r\n\r\n{ TCustomTreeView }\r\n\r\n{ function AlphaSort: Boolean; }\r\n\r\nprocedure TCustomTreeView_AlphaSort(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TCustomTreeView(Args.Obj).AlphaSort;\r\nend;\r\n\r\n{ function CustomSort(SortProc: TTVCompare; Data: Longint): Boolean; }\r\n\r\nprocedure TCustomTreeView_CustomSort(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n// Value := TCustomTreeView(Args.Obj).CustomSort(Args.Values[0], Args.Values[1]);\r\n NotImplemented('TCustomTreeView.CustomSort');\r\nend;\r\n\r\n{ procedure FullCollapse; }\r\n\r\nprocedure TCustomTreeView_FullCollapse(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TCustomTreeView(Args.Obj).FullCollapse;\r\nend;\r\n\r\n{ procedure FullExpand; }\r\n\r\nprocedure TCustomTreeView_FullExpand(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TCustomTreeView(Args.Obj).FullExpand;\r\nend;\r\n\r\n{ function GetHitTestInfoAt(X, Y: Integer): THitTests; }\r\n\r\nprocedure TCustomTreeView_GetHitTestInfoAt(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := S2V(Word(TCustomTreeView(Args.Obj).GetHitTestInfoAt(Args.Values[0], Args.Values[1])));\r\nend;\r\n\r\n{ function GetNodeAt(X, Y: Integer): TTreeNode; }\r\n\r\nprocedure TCustomTreeView_GetNodeAt(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TCustomTreeView(Args.Obj).GetNodeAt(Args.Values[0], Args.Values[1]));\r\nend;\r\n\r\n{ function IsEditing: Boolean; }\r\n\r\nprocedure TCustomTreeView_IsEditing(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TCustomTreeView(Args.Obj).IsEditing;\r\nend;\r\n\r\n{ procedure LoadFromFile(const FileName: string); }\r\n\r\nprocedure TCustomTreeView_LoadFromFile(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TCustomTreeView(Args.Obj).LoadFromFile(Args.Values[0]);\r\nend;\r\n\r\n{ procedure LoadFromStream(Stream: TStream); }\r\n\r\nprocedure TCustomTreeView_LoadFromStream(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TCustomTreeView(Args.Obj).LoadFromStream(V2O(Args.Values[0]) as TStream);\r\nend;\r\n\r\n{ procedure SaveToFile(const FileName: string); }\r\n\r\nprocedure TCustomTreeView_SaveToFile(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TCustomTreeView(Args.Obj).SaveToFile(Args.Values[0]);\r\nend;\r\n\r\n{ procedure SaveToStream(Stream: TStream); }\r\n\r\nprocedure TCustomTreeView_SaveToStream(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TCustomTreeView(Args.Obj).SaveToStream(V2O(Args.Values[0]) as TStream);\r\nend;\r\n\r\n{ property Read DropTarget: TTreeNode }\r\n\r\nprocedure TCustomTreeView_Read_DropTarget(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TCustomTreeView(Args.Obj).DropTarget);\r\nend;\r\n\r\n{ property Write DropTarget(Value: TTreeNode) }\r\n\r\nprocedure TCustomTreeView_Write_DropTarget(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TCustomTreeView(Args.Obj).DropTarget := V2O(Value) as TTreeNode;\r\nend;\r\n\r\n{ property Read Selected: TTreeNode }\r\n\r\nprocedure TCustomTreeView_Read_Selected(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TCustomTreeView(Args.Obj).Selected);\r\nend;\r\n\r\n{ property Write Selected(Value: TTreeNode) }\r\n\r\nprocedure TCustomTreeView_Write_Selected(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TCustomTreeView(Args.Obj).Selected := V2O(Value) as TTreeNode;\r\nend;\r\n\r\n{ property Read TopItem: TTreeNode }\r\n\r\nprocedure TCustomTreeView_Read_TopItem(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TCustomTreeView(Args.Obj).TopItem);\r\nend;\r\n\r\n{ property Write TopItem(Value: TTreeNode) }\r\n\r\nprocedure TCustomTreeView_Write_TopItem(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TCustomTreeView(Args.Obj).TopItem := V2O(Value) as TTreeNode;\r\nend;\r\n\r\n{ TTreeView }\r\n\r\n{ constructor Create(AOwner: TComponent) }\r\n\r\nprocedure TTreeView_Create(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TTreeView.Create(V2O(Args.Values[0]) as TComponent));\r\nend;\r\n\r\n{ TTrackBar }\r\n\r\n{ constructor Create(AOwner: TComponent) }\r\n\r\nprocedure TTrackBar_Create(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TTrackBar.Create(V2O(Args.Values[0]) as TComponent));\r\nend;\r\n\r\n{ procedure SetTick(Value: Integer); }\r\n\r\nprocedure TTrackBar_SetTick(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TTrackBar(Args.Obj).SetTick(Args.Values[0]);\r\nend;\r\n\r\n{ TProgressBar }\r\n\r\n{ constructor Create(AOwner: TComponent) }\r\n\r\nprocedure TProgressBar_Create(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TProgressBar.Create(V2O(Args.Values[0]) as TComponent));\r\nend;\r\n\r\n{ procedure StepIt; }\r\n\r\nprocedure TProgressBar_StepIt(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TProgressBar(Args.Obj).StepIt;\r\nend;\r\n\r\n{ procedure StepBy(Delta: Integer); }\r\n\r\nprocedure TProgressBar_StepBy(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TProgressBar(Args.Obj).StepBy(Args.Values[0]);\r\nend;\r\n\r\n{ TTextAttributes }\r\n\r\n{ constructor Create(AOwner: TCustomRichEdit; AttributeType: TAttributeType) }\r\n\r\nprocedure TTextAttributes_Create(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TTextAttributes.Create(V2O(Args.Values[0]) as TCustomRichEdit, Args.Values[1]));\r\nend;\r\n\r\n{ procedure Assign(Source: TPersistent); }\r\n\r\nprocedure TTextAttributes_Assign(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TTextAttributes(Args.Obj).Assign(V2O(Args.Values[0]) as TPersistent);\r\nend;\r\n\r\n{ property Read Charset: TFontCharset }\r\n\r\nprocedure TTextAttributes_Read_Charset(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TTextAttributes(Args.Obj).Charset;\r\nend;\r\n\r\n{ property Write Charset(Value: TFontCharset) }\r\n\r\nprocedure TTextAttributes_Write_Charset(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TTextAttributes(Args.Obj).Charset := Value;\r\nend;\r\n\r\n{ property Read Color: TColor }\r\n\r\nprocedure TTextAttributes_Read_Color(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TTextAttributes(Args.Obj).Color;\r\nend;\r\n\r\n{ property Write Color(Value: TColor) }\r\n\r\nprocedure TTextAttributes_Write_Color(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TTextAttributes(Args.Obj).Color := Value;\r\nend;\r\n\r\n{ property Read ConsistentAttributes: TConsistentAttributes }\r\n\r\nprocedure TTextAttributes_Read_ConsistentAttributes(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := S2V(Byte(TTextAttributes(Args.Obj).ConsistentAttributes));\r\nend;\r\n\r\n{ property Read Name: TFontName }\r\n\r\nprocedure TTextAttributes_Read_Name(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TTextAttributes(Args.Obj).Name;\r\nend;\r\n\r\n{ property Write Name(Value: TFontName) }\r\n\r\nprocedure TTextAttributes_Write_Name(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TTextAttributes(Args.Obj).Name := Value;\r\nend;\r\n\r\n{ property Read Pitch: TFontPitch }\r\n\r\nprocedure TTextAttributes_Read_Pitch(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TTextAttributes(Args.Obj).Pitch;\r\nend;\r\n\r\n{ property Write Pitch(Value: TFontPitch) }\r\n\r\nprocedure TTextAttributes_Write_Pitch(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TTextAttributes(Args.Obj).Pitch := Value;\r\nend;\r\n\r\n{ property Read Protected: Boolean }\r\n\r\nprocedure TTextAttributes_Read_Protected(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TTextAttributes(Args.Obj).Protected;\r\nend;\r\n\r\n{ property Write Protected(Value: Boolean) }\r\n\r\nprocedure TTextAttributes_Write_Protected(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TTextAttributes(Args.Obj).Protected := Value;\r\nend;\r\n\r\n{ property Read Size: Integer }\r\n\r\nprocedure TTextAttributes_Read_Size(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TTextAttributes(Args.Obj).Size;\r\nend;\r\n\r\n{ property Write Size(Value: Integer) }\r\n\r\nprocedure TTextAttributes_Write_Size(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TTextAttributes(Args.Obj).Size := Value;\r\nend;\r\n\r\n{ property Read Style: TFontStyles }\r\n\r\nprocedure TTextAttributes_Read_Style(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := S2V(Byte(TTextAttributes(Args.Obj).Style));\r\nend;\r\n\r\n{ property Write Style(Value: TFontStyles) }\r\n\r\nprocedure TTextAttributes_Write_Style(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TTextAttributes(Args.Obj).Style := TFontStyles(Byte(V2S(Value)));\r\nend;\r\n\r\n{ property Read Height: Integer }\r\n\r\nprocedure TTextAttributes_Read_Height(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TTextAttributes(Args.Obj).Height;\r\nend;\r\n\r\n{ property Write Height(Value: Integer) }\r\n\r\nprocedure TTextAttributes_Write_Height(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TTextAttributes(Args.Obj).Height := Value;\r\nend;\r\n\r\n{ TParaAttributes }\r\n\r\n{ constructor Create(AOwner: TCustomRichEdit) }\r\n\r\nprocedure TParaAttributes_Create(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TParaAttributes.Create(V2O(Args.Values[0]) as TCustomRichEdit));\r\nend;\r\n\r\n{ procedure Assign(Source: TPersistent); }\r\n\r\nprocedure TParaAttributes_Assign(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TParaAttributes(Args.Obj).Assign(V2O(Args.Values[0]) as TPersistent);\r\nend;\r\n\r\n{ property Read Alignment: TAlignment }\r\n\r\nprocedure TParaAttributes_Read_Alignment(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TParaAttributes(Args.Obj).Alignment;\r\nend;\r\n\r\n{ property Write Alignment(Value: TAlignment) }\r\n\r\nprocedure TParaAttributes_Write_Alignment(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TParaAttributes(Args.Obj).Alignment := Value;\r\nend;\r\n\r\n{ property Read FirstIndent: Longint }\r\n\r\nprocedure TParaAttributes_Read_FirstIndent(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TParaAttributes(Args.Obj).FirstIndent;\r\nend;\r\n\r\n{ property Write FirstIndent(Value: Longint) }\r\n\r\nprocedure TParaAttributes_Write_FirstIndent(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TParaAttributes(Args.Obj).FirstIndent := Value;\r\nend;\r\n\r\n{ property Read LeftIndent: Longint }\r\n\r\nprocedure TParaAttributes_Read_LeftIndent(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TParaAttributes(Args.Obj).LeftIndent;\r\nend;\r\n\r\n{ property Write LeftIndent(Value: Longint) }\r\n\r\nprocedure TParaAttributes_Write_LeftIndent(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TParaAttributes(Args.Obj).LeftIndent := Value;\r\nend;\r\n\r\n{ property Read Numbering: TNumberingStyle }\r\n\r\nprocedure TParaAttributes_Read_Numbering(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TParaAttributes(Args.Obj).Numbering;\r\nend;\r\n\r\n{ property Write Numbering(Value: TNumberingStyle) }\r\n\r\nprocedure TParaAttributes_Write_Numbering(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TParaAttributes(Args.Obj).Numbering := Value;\r\nend;\r\n\r\n{ property Read RightIndent: Longint }\r\n\r\nprocedure TParaAttributes_Read_RightIndent(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TParaAttributes(Args.Obj).RightIndent;\r\nend;\r\n\r\n{ property Write RightIndent(Value: Longint) }\r\n\r\nprocedure TParaAttributes_Write_RightIndent(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TParaAttributes(Args.Obj).RightIndent := Value;\r\nend;\r\n\r\n{ property Read Tab[Byte]: Longint }\r\n\r\nprocedure TParaAttributes_Read_Tab(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TParaAttributes(Args.Obj).Tab[Args.Values[0]];\r\nend;\r\n\r\n{ property Write Tab[Byte]: Longint }\r\n\r\nprocedure TParaAttributes_Write_Tab(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TParaAttributes(Args.Obj).Tab[Args.Values[0]] := Value;\r\nend;\r\n\r\n{ property Read TabCount: Integer }\r\n\r\nprocedure TParaAttributes_Read_TabCount(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TParaAttributes(Args.Obj).TabCount;\r\nend;\r\n\r\n{ property Write TabCount(Value: Integer) }\r\n\r\nprocedure TParaAttributes_Write_TabCount(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TParaAttributes(Args.Obj).TabCount := Value;\r\nend;\r\n\r\n{ TCustomRichEdit }\r\n\r\n{ procedure Clear; }\r\n\r\nprocedure TCustomRichEdit_Clear(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TCustomRichEdit(Args.Obj).Clear;\r\nend;\r\n\r\n{ function FindText(const SearchStr: string; StartPos, Length: Integer; Options: TSearchTypes): Integer; }\r\n\r\nprocedure TCustomRichEdit_FindText(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TCustomRichEdit(Args.Obj).FindText(Args.Values[0], Args.Values[1], Args.Values[2],\r\n TSearchTypes(Byte(V2S(Args.Values[3]))));\r\nend;\r\n\r\n{ function GetSelTextBuf(Buffer: PChar; BufSize: Integer): Integer; }\r\n\r\nprocedure TCustomRichEdit_GetSelTextBuf(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TCustomRichEdit(Args.Obj).GetSelTextBuf(PChar(string(Args.Values[0])), Args.Values[1]);\r\nend;\r\n\r\n{ procedure Print(const Caption: string); }\r\n\r\nprocedure TCustomRichEdit_Print(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TCustomRichEdit(Args.Obj).Print(Args.Values[0]);\r\nend;\r\n\r\n{ property Read DefAttributes: TTextAttributes }\r\n\r\nprocedure TCustomRichEdit_Read_DefAttributes(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TCustomRichEdit(Args.Obj).DefAttributes);\r\nend;\r\n\r\n{ property Write DefAttributes(Value: TTextAttributes) }\r\n\r\nprocedure TCustomRichEdit_Write_DefAttributes(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TCustomRichEdit(Args.Obj).DefAttributes := V2O(Value) as TTextAttributes;\r\nend;\r\n\r\n{ property Read SelAttributes: TTextAttributes }\r\n\r\nprocedure TCustomRichEdit_Read_SelAttributes(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TCustomRichEdit(Args.Obj).SelAttributes);\r\nend;\r\n\r\n{ property Write SelAttributes(Value: TTextAttributes) }\r\n\r\nprocedure TCustomRichEdit_Write_SelAttributes(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TCustomRichEdit(Args.Obj).SelAttributes := V2O(Value) as TTextAttributes;\r\nend;\r\n\r\n{ property Read PageRect: TRect }\r\n\r\nprocedure TCustomRichEdit_Read_PageRect(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := Rect2Var(TCustomRichEdit(Args.Obj).PageRect);\r\nend;\r\n\r\n{ property Write PageRect(Value: TRect) }\r\n\r\nprocedure TCustomRichEdit_Write_PageRect(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TCustomRichEdit(Args.Obj).PageRect := Var2Rect(Value);\r\nend;\r\n\r\n{ property Read Paragraph: TParaAttributes }\r\n\r\nprocedure TCustomRichEdit_Read_Paragraph(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TCustomRichEdit(Args.Obj).Paragraph);\r\nend;\r\n\r\n{ TRichEdit }\r\n\r\n{ constructor Create(AOwner: TComponent) }\r\n\r\nprocedure TRichEdit_Create(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TRichEdit.Create(V2O(Args.Values[0]) as TComponent));\r\nend;\r\n\r\n{ TUpDown }\r\n\r\n{ constructor Create(AOwner: TComponent) }\r\n\r\nprocedure TUpDown_Create(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TUpDown.Create(V2O(Args.Values[0]) as TComponent));\r\nend;\r\n\r\n{ THotKey }\r\n\r\n{ constructor Create(AOwner: TComponent) }\r\n\r\nprocedure THotKey_Create(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(THotKey.Create(V2O(Args.Values[0]) as TComponent));\r\nend;\r\n\r\n{ TListColumn }\r\n\r\n{ constructor Create(Collection: TCollection) }\r\n\r\nprocedure TListColumn_Create(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TListColumn.Create(V2O(Args.Values[0]) as TCollection));\r\nend;\r\n\r\n{ procedure Assign(Source: TPersistent); }\r\n\r\nprocedure TListColumn_Assign(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TListColumn(Args.Obj).Assign(V2O(Args.Values[0]) as TPersistent);\r\nend;\r\n\r\n{ property Read WidthType: TWidth }\r\n\r\nprocedure TListColumn_Read_WidthType(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TListColumn(Args.Obj).WidthType;\r\nend;\r\n\r\n{ TListColumns }\r\n\r\n{ constructor Create(AOwner: TCustomListView) }\r\n\r\nprocedure TListColumns_Create(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TListColumns.Create(V2O(Args.Values[0]) as TCustomListView));\r\nend;\r\n\r\n{ function Add: TListColumn; }\r\n\r\nprocedure TListColumns_Add(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TListColumns(Args.Obj).Add);\r\nend;\r\n\r\n{ property Read Owner: TCustomListView }\r\n\r\nprocedure TListColumns_Read_Owner(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TListColumns(Args.Obj).Owner);\r\nend;\r\n\r\n{ property Read Items[Integer]: TListColumn }\r\n\r\nprocedure TListColumns_Read_Items(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TListColumns(Args.Obj).Items[Args.Values[0]]);\r\nend;\r\n\r\n{ property Write Items[Integer]: TListColumn }\r\n\r\nprocedure TListColumns_Write_Items(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TListColumns(Args.Obj).Items[Args.Values[0]] := V2O(Value) as TListColumn;\r\nend;\r\n\r\n{ TListItem }\r\n\r\n{ constructor Create(AOwner: TListItems) }\r\n\r\nprocedure TListItem_Create(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TListItem.Create(V2O(Args.Values[0]) as TListItems));\r\nend;\r\n\r\n{ procedure CancelEdit; }\r\n\r\nprocedure TListItem_CancelEdit(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TListItem(Args.Obj).CancelEdit;\r\nend;\r\n\r\n{ procedure Delete; }\r\n\r\nprocedure TListItem_Delete(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TListItem(Args.Obj).Delete;\r\nend;\r\n\r\n{ function DisplayRect(Code: TDisplayCode): TRect; }\r\n\r\nprocedure TListItem_DisplayRect(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := Rect2Var(TListItem(Args.Obj).DisplayRect(Args.Values[0]));\r\nend;\r\n\r\n{ function EditCaption: Boolean; }\r\n\r\nprocedure TListItem_EditCaption(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TListItem(Args.Obj).EditCaption;\r\nend;\r\n\r\n{ function GetPosition: TPoint; }\r\n\r\nprocedure TListItem_GetPosition(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := Point2Var(TListItem(Args.Obj).GetPosition);\r\nend;\r\n\r\n{ procedure MakeVisible(PartialOK: Boolean); }\r\n\r\nprocedure TListItem_MakeVisible(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TListItem(Args.Obj).MakeVisible(Args.Values[0]);\r\nend;\r\n\r\n{ procedure Update; }\r\n\r\nprocedure TListItem_Update(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TListItem(Args.Obj).Update;\r\nend;\r\n\r\n{ procedure SetPosition(const Value: TPoint); }\r\n\r\nprocedure TListItem_SetPosition(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TListItem(Args.Obj).SetPosition(Var2Point(Args.Values[0]));\r\nend;\r\n\r\n{ property Read Caption: string }\r\n\r\nprocedure TListItem_Read_Caption(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TListItem(Args.Obj).Caption;\r\nend;\r\n\r\n{ property Write Caption(Value: string) }\r\n\r\nprocedure TListItem_Write_Caption(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TListItem(Args.Obj).Caption := Value;\r\nend;\r\n\r\n{ property Read Checked: Boolean }\r\n\r\nprocedure TListItem_Read_Checked(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TListItem(Args.Obj).Checked;\r\nend;\r\n\r\n{ property Write Checked(Value: Boolean) }\r\n\r\nprocedure TListItem_Write_Checked(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TListItem(Args.Obj).Checked := Value;\r\nend;\r\n\r\n{ property Read Cut: Boolean }\r\n\r\nprocedure TListItem_Read_Cut(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TListItem(Args.Obj).Cut;\r\nend;\r\n\r\n{ property Write Cut(Value: Boolean) }\r\n\r\nprocedure TListItem_Write_Cut(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TListItem(Args.Obj).Cut := Value;\r\nend;\r\n\r\n{ property Read Data: Pointer }\r\n\r\nprocedure TListItem_Read_Data(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := P2V(TListItem(Args.Obj).Data);\r\nend;\r\n\r\n{ property Write Data(Value: Pointer) }\r\n\r\nprocedure TListItem_Write_Data(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TListItem(Args.Obj).Data := V2P(Value);\r\nend;\r\n\r\n{ property Read DropTarget: Boolean }\r\n\r\nprocedure TListItem_Read_DropTarget(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TListItem(Args.Obj).DropTarget;\r\nend;\r\n\r\n{ property Write DropTarget(Value: Boolean) }\r\n\r\nprocedure TListItem_Write_DropTarget(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TListItem(Args.Obj).DropTarget := Value;\r\nend;\r\n\r\n{ property Read Focused: Boolean }\r\n\r\nprocedure TListItem_Read_Focused(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TListItem(Args.Obj).Focused;\r\nend;\r\n\r\n{ property Write Focused(Value: Boolean) }\r\n\r\nprocedure TListItem_Write_Focused(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TListItem(Args.Obj).Focused := Value;\r\nend;\r\n\r\n{ property Read Handle: HWND }\r\n\r\nprocedure TListItem_Read_Handle(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := NativeInt(TListItem(Args.Obj).Handle);\r\nend;\r\n\r\n{ property Read ImageIndex: Integer }\r\n\r\nprocedure TListItem_Read_ImageIndex(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TListItem(Args.Obj).ImageIndex;\r\nend;\r\n\r\n{ property Write ImageIndex(Value: Integer) }\r\n\r\nprocedure TListItem_Write_ImageIndex(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TListItem(Args.Obj).ImageIndex := Value;\r\nend;\r\n\r\n{ property Read Index: Integer }\r\n\r\nprocedure TListItem_Read_Index(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TListItem(Args.Obj).Index;\r\nend;\r\n\r\n{ property Read Left: Integer }\r\n\r\nprocedure TListItem_Read_Left(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TListItem(Args.Obj).Left;\r\nend;\r\n\r\n{ property Write Left(Value: Integer) }\r\n\r\nprocedure TListItem_Write_Left(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TListItem(Args.Obj).Left := Value;\r\nend;\r\n\r\n{ property Read ListView: TCustomListView }\r\n\r\nprocedure TListItem_Read_ListView(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TListItem(Args.Obj).ListView);\r\nend;\r\n\r\n{ property Read Owner: TListItems }\r\n\r\nprocedure TListItem_Read_Owner(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TListItem(Args.Obj).Owner);\r\nend;\r\n\r\n{ property Read OverlayIndex: Integer }\r\n\r\nprocedure TListItem_Read_OverlayIndex(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TListItem(Args.Obj).OverlayIndex;\r\nend;\r\n\r\n{ property Write OverlayIndex(Value: Integer) }\r\n\r\nprocedure TListItem_Write_OverlayIndex(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TListItem(Args.Obj).OverlayIndex := Value;\r\nend;\r\n\r\n{ property Read Selected: Boolean }\r\n\r\nprocedure TListItem_Read_Selected(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TListItem(Args.Obj).Selected;\r\nend;\r\n\r\n{ property Write Selected(Value: Boolean) }\r\n\r\nprocedure TListItem_Write_Selected(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TListItem(Args.Obj).Selected := Value;\r\nend;\r\n\r\n{ property Read StateIndex: Integer }\r\n\r\nprocedure TListItem_Read_StateIndex(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TListItem(Args.Obj).StateIndex;\r\nend;\r\n\r\n{ property Write StateIndex(Value: Integer) }\r\n\r\nprocedure TListItem_Write_StateIndex(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TListItem(Args.Obj).StateIndex := Value;\r\nend;\r\n\r\n{ property Read SubItems: TStrings }\r\n\r\nprocedure TListItem_Read_SubItems(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TListItem(Args.Obj).SubItems);\r\nend;\r\n\r\n{ property Write SubItems(Value: TStrings) }\r\n\r\nprocedure TListItem_Write_SubItems(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TListItem(Args.Obj).SubItems := V2O(Value) as TStrings;\r\nend;\r\n\r\n{ property Read Top: Integer }\r\n\r\nprocedure TListItem_Read_Top(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TListItem(Args.Obj).Top;\r\nend;\r\n\r\n{ property Write Top(Value: Integer) }\r\n\r\nprocedure TListItem_Write_Top(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TListItem(Args.Obj).Top := Value;\r\nend;\r\n\r\n{ TListItems }\r\n\r\n{ constructor Create(AOwner: TCustomListView) }\r\n\r\nprocedure TListItems_Create(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TListItems.Create(V2O(Args.Values[0]) as TCustomListView));\r\nend;\r\n\r\n{ function Add: TListItem; }\r\n\r\nprocedure TListItems_Add(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TListItems(Args.Obj).Add);\r\nend;\r\n\r\n{ procedure Assign(Source: TPersistent); }\r\n\r\nprocedure TListItems_Assign(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TListItems(Args.Obj).Assign(V2O(Args.Values[0]) as TPersistent);\r\nend;\r\n\r\n{ procedure BeginUpdate; }\r\n\r\nprocedure TListItems_BeginUpdate(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TListItems(Args.Obj).BeginUpdate;\r\nend;\r\n\r\n{ procedure Clear; }\r\n\r\nprocedure TListItems_Clear(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TListItems(Args.Obj).Clear;\r\nend;\r\n\r\n{ procedure Delete(Index: Integer); }\r\n\r\nprocedure TListItems_Delete(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TListItems(Args.Obj).Delete(Args.Values[0]);\r\nend;\r\n\r\n{ procedure EndUpdate; }\r\n\r\nprocedure TListItems_EndUpdate(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TListItems(Args.Obj).EndUpdate;\r\nend;\r\n\r\n{ function IndexOf(Value: TListItem): Integer; }\r\n\r\nprocedure TListItems_IndexOf(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TListItems(Args.Obj).IndexOf(V2O(Args.Values[0]) as TListItem);\r\nend;\r\n\r\n{ function Insert(Index: Integer): TListItem; }\r\n\r\nprocedure TListItems_Insert(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TListItems(Args.Obj).Insert(Args.Values[0]));\r\nend;\r\n\r\n{ property Read Count: Integer }\r\n\r\nprocedure TListItems_Read_Count(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TListItems(Args.Obj).Count;\r\nend;\r\n\r\n{ property Read Handle: HWND }\r\n\r\nprocedure TListItems_Read_Handle(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := NativeInt(TListItems(Args.Obj).Handle);\r\nend;\r\n\r\n{ property Read Item[Integer]: TListItem }\r\n\r\nprocedure TListItems_Read_Item(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TListItems(Args.Obj).Item[Args.Values[0]]);\r\nend;\r\n\r\n{ property Write Item[Integer]: TListItem }\r\n\r\nprocedure TListItems_Write_Item(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TListItems(Args.Obj).Item[Args.Values[0]] := V2O(Value) as TListItem;\r\nend;\r\n\r\n{ property Read Owner: TCustomListView }\r\n\r\nprocedure TListItems_Read_Owner(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TListItems(Args.Obj).Owner);\r\nend;\r\n\r\n{ TCustomListView }\r\n\r\n{ function AlphaSort: Boolean; }\r\n\r\nprocedure TCustomListView_AlphaSort(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TCustomListView(Args.Obj).AlphaSort;\r\nend;\r\n\r\n{ procedure Arrange(Code: TListArrangement); }\r\n\r\nprocedure TCustomListView_Arrange(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TCustomListView(Args.Obj).Arrange(Args.Values[0]);\r\nend;\r\n\r\n{ function FindCaption(StartIndex: Integer; Value: string; Partial, Inclusive, Wrap: Boolean): TListItem; }\r\n\r\nprocedure TCustomListView_FindCaption(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TCustomListView(Args.Obj).FindCaption(Args.Values[0], Args.Values[1], Args.Values[2], Args.Values[3],\r\n Args.Values[4]));\r\nend;\r\n\r\n{ function FindData(StartIndex: Integer; Value: Pointer; Inclusive, Wrap: Boolean): TListItem; }\r\n\r\nprocedure TCustomListView_FindData(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TCustomListView(Args.Obj).FindData(Args.Values[0], V2P(Args.Values[1]), Args.Values[2], Args.Values[3]));\r\nend;\r\n\r\n{ function GetItemAt(X, Y: Integer): TListItem; }\r\n\r\nprocedure TCustomListView_GetItemAt(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TCustomListView(Args.Obj).GetItemAt(Args.Values[0], Args.Values[1]));\r\nend;\r\n\r\n{ function GetNearestItem(Point: TPoint; Direction: TSearchDirection): TListItem; }\r\n\r\nprocedure TCustomListView_GetNearestItem(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TCustomListView(Args.Obj).GetNearestItem(Var2Point(Args.Values[0]), Args.Values[1]));\r\nend;\r\n\r\n{ function GetNextItem(StartItem: TListItem; Direction: TSearchDirection; States: TItemStates): TListItem; }\r\n\r\nprocedure TCustomListView_GetNextItem(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TCustomListView(Args.Obj).GetNextItem(V2O(Args.Values[0]) as TListItem, Args.Values[1],\r\n TItemStates(Byte(V2S(Args.Values[2])))));\r\nend;\r\n\r\n{ function GetSearchString: string; }\r\n\r\nprocedure TCustomListView_GetSearchString(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TCustomListView(Args.Obj).GetSearchString;\r\nend;\r\n\r\n{ function IsEditing: Boolean; }\r\n\r\nprocedure TCustomListView_IsEditing(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TCustomListView(Args.Obj).IsEditing;\r\nend;\r\n\r\n{ procedure Scroll(DX, DY: Integer); }\r\n\r\nprocedure TCustomListView_Scroll(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TCustomListView(Args.Obj).Scroll(Args.Values[0], Args.Values[1]);\r\nend;\r\n\r\n{ property Read Checkboxes: Boolean }\r\n\r\nprocedure TCustomListView_Read_Checkboxes(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TCustomListView(Args.Obj).Checkboxes;\r\nend;\r\n\r\n{ property Write Checkboxes(Value: Boolean) }\r\n\r\nprocedure TCustomListView_Write_Checkboxes(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TCustomListView(Args.Obj).Checkboxes := Value;\r\nend;\r\n\r\n{ property Read Column[Integer]: TListColumn }\r\n\r\nprocedure TCustomListView_Read_Column(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TCustomListView(Args.Obj).Column[Args.Values[0]]);\r\nend;\r\n\r\n{ property Read DropTarget: TListItem }\r\n\r\nprocedure TCustomListView_Read_DropTarget(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TCustomListView(Args.Obj).DropTarget);\r\nend;\r\n\r\n{ property Write DropTarget(Value: TListItem) }\r\n\r\nprocedure TCustomListView_Write_DropTarget(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TCustomListView(Args.Obj).DropTarget := V2O(Value) as TListItem;\r\nend;\r\n\r\n{ property Read GridLines: Boolean }\r\n\r\nprocedure TCustomListView_Read_GridLines(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TCustomListView(Args.Obj).GridLines;\r\nend;\r\n\r\n{ property Write GridLines(Value: Boolean) }\r\n\r\nprocedure TCustomListView_Write_GridLines(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TCustomListView(Args.Obj).GridLines := Value;\r\nend;\r\n\r\n{ property Read HotTrack: Boolean }\r\n\r\nprocedure TCustomListView_Read_HotTrack(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TCustomListView(Args.Obj).HotTrack;\r\nend;\r\n\r\n{ property Write HotTrack(Value: Boolean) }\r\n\r\nprocedure TCustomListView_Write_HotTrack(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TCustomListView(Args.Obj).HotTrack := Value;\r\nend;\r\n\r\n{ property Read ItemFocused: TListItem }\r\n\r\nprocedure TCustomListView_Read_ItemFocused(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TCustomListView(Args.Obj).ItemFocused);\r\nend;\r\n\r\n{ property Write ItemFocused(Value: TListItem) }\r\n\r\nprocedure TCustomListView_Write_ItemFocused(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TCustomListView(Args.Obj).ItemFocused := V2O(Value) as TListItem;\r\nend;\r\n\r\n{ property Read RowSelect: Boolean }\r\n\r\nprocedure TCustomListView_Read_RowSelect(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TCustomListView(Args.Obj).RowSelect;\r\nend;\r\n\r\n{ property Write RowSelect(Value: Boolean) }\r\n\r\nprocedure TCustomListView_Write_RowSelect(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TCustomListView(Args.Obj).RowSelect := Value;\r\nend;\r\n\r\n{ property Read SelCount: Integer }\r\n\r\nprocedure TCustomListView_Read_SelCount(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TCustomListView(Args.Obj).SelCount;\r\nend;\r\n\r\n{ property Read Selected: TListItem }\r\n\r\nprocedure TCustomListView_Read_Selected(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TCustomListView(Args.Obj).Selected);\r\nend;\r\n\r\n{ property Write Selected(Value: TListItem) }\r\n\r\nprocedure TCustomListView_Write_Selected(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TCustomListView(Args.Obj).Selected := V2O(Value) as TListItem;\r\nend;\r\n\r\n{ function CustomSort(SortProc: TLVCompare; lParam: Longint): Boolean; }\r\n\r\nprocedure TCustomListView_CustomSort(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n// Value := TCustomListView(Args.Obj).CustomSort(Args.Values[0], Args.Values[1]);\r\n NotImplemented('TCustomListView.CustomSort');\r\nend;\r\n\r\n{ function StringWidth(S: string): Integer; }\r\n\r\nprocedure TCustomListView_StringWidth(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TCustomListView(Args.Obj).StringWidth(Args.Values[0]);\r\nend;\r\n\r\n{ procedure UpdateItems(FirstIndex, LastIndex: Integer); }\r\n\r\nprocedure TCustomListView_UpdateItems(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TCustomListView(Args.Obj).UpdateItems(Args.Values[0], Args.Values[1]);\r\nend;\r\n\r\n{ property Read TopItem: TListItem }\r\n\r\nprocedure TCustomListView_Read_TopItem(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TCustomListView(Args.Obj).TopItem);\r\nend;\r\n\r\n{ property Read ViewOrigin: TPoint }\r\n\r\nprocedure TCustomListView_Read_ViewOrigin(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := Point2Var(TCustomListView(Args.Obj).ViewOrigin);\r\nend;\r\n\r\n{ property Read VisibleRowCount: Integer }\r\n\r\nprocedure TCustomListView_Read_VisibleRowCount(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TCustomListView(Args.Obj).VisibleRowCount;\r\nend;\r\n\r\n{ property Read BoundingRect: TRect }\r\n\r\nprocedure TCustomListView_Read_BoundingRect(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := Rect2Var(TCustomListView(Args.Obj).BoundingRect);\r\nend;\r\n\r\n{ TListView }\r\n\r\n{ constructor Create(AOwner: TComponent) }\r\n\r\nprocedure TListView_Create(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TListView.Create(V2O(Args.Values[0]) as TComponent));\r\nend;\r\n\r\n{ TAnimate }\r\n\r\n{ constructor Create(AOwner: TComponent) }\r\n\r\nprocedure TAnimate_Create(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TAnimate.Create(V2O(Args.Values[0]) as TComponent));\r\nend;\r\n\r\n{ property Read FrameCount: Integer }\r\n\r\nprocedure TAnimate_Read_FrameCount(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TAnimate(Args.Obj).FrameCount;\r\nend;\r\n\r\n{ property Read FrameHeight: Integer }\r\n\r\nprocedure TAnimate_Read_FrameHeight(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TAnimate(Args.Obj).FrameHeight;\r\nend;\r\n\r\n{ property Read FrameWidth: Integer }\r\n\r\nprocedure TAnimate_Read_FrameWidth(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TAnimate(Args.Obj).FrameWidth;\r\nend;\r\n\r\n{ property Read Open: Boolean }\r\n\r\nprocedure TAnimate_Read_Open(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TAnimate(Args.Obj).Open;\r\nend;\r\n\r\n{ property Write Open(Value: Boolean) }\r\n\r\nprocedure TAnimate_Write_Open(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TAnimate(Args.Obj).Open := Value;\r\nend;\r\n\r\n{ procedure Play(FromFrame, ToFrame: Word; Count: Integer); }\r\n\r\nprocedure TAnimate_Play(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TAnimate(Args.Obj).Play(Args.Values[0], Args.Values[1], Args.Values[2]);\r\nend;\r\n\r\n{ procedure Reset; }\r\n\r\nprocedure TAnimate_Reset(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TAnimate(Args.Obj).Reset;\r\nend;\r\n\r\n{ procedure Seek(Frame: Smallint); }\r\n\r\nprocedure TAnimate_Seek(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TAnimate(Args.Obj).Seek(Args.Values[0]);\r\nend;\r\n\r\n{ procedure Stop; }\r\n\r\nprocedure TAnimate_Stop(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TAnimate(Args.Obj).Stop;\r\nend;\r\n\r\n{ property Read ResHandle: THandle }\r\n\r\nprocedure TAnimate_Read_ResHandle(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := NativeInt(TAnimate(Args.Obj).ResHandle);\r\nend;\r\n\r\n{ property Write ResHandle(Value: THandle) }\r\n\r\nprocedure TAnimate_Write_ResHandle(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TAnimate(Args.Obj).ResHandle := Value;\r\nend;\r\n\r\n{ property Read ResId: Integer }\r\n\r\nprocedure TAnimate_Read_ResId(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TAnimate(Args.Obj).ResId;\r\nend;\r\n\r\n{ property Write ResId(Value: Integer) }\r\n\r\nprocedure TAnimate_Write_ResId(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TAnimate(Args.Obj).ResId := Value;\r\nend;\r\n\r\n{ property Read ResName: string }\r\n\r\nprocedure TAnimate_Read_ResName(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TAnimate(Args.Obj).ResName;\r\nend;\r\n\r\n{ property Write ResName(Value: string) }\r\n\r\nprocedure TAnimate_Write_ResName(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TAnimate(Args.Obj).ResName := Value;\r\nend;\r\n\r\ntype\r\n TJvInterpreterComCtrlsEvent = class(TJvInterpreterEvent)\r\n private\r\n procedure TabChangingEvent(Sender: TObject; var AllowChange: Boolean);\r\n procedure DrawPanelEvent(StatusBar: TStatusBar; Panel: TStatusPanel; const Rect: TRect);\r\n procedure DrawSectionEvent(HeaderControl: THeaderControl; Section: THeaderSection; const Rect: TRect; Pressed:\r\n Boolean);\r\n procedure SectionNotifyEvent(HeaderControl: THeaderControl; Section: THeaderSection);\r\n procedure SectionTrackEvent(HeaderControl: THeaderControl; Section: THeaderSection; Width: Integer; State:\r\n TSectionTrackState);\r\n procedure TVChangingEvent(Sender: TObject; Node: TTreeNode; var AllowChange: Boolean);\r\n procedure TVChangedEvent(Sender: TObject; Node: TTreeNode);\r\n procedure TVEditingEvent(Sender: TObject; Node: TTreeNode; var AllowEdit: Boolean);\r\n procedure TVEditedEvent(Sender: TObject; Node: TTreeNode; var S: string);\r\n procedure TVExpandingEvent(Sender: TObject; Node: TTreeNode; var AllowExpansion: Boolean);\r\n procedure TVCollapsingEvent(Sender: TObject; Node: TTreeNode; var AllowCollapse: Boolean);\r\n procedure TVExpandedEvent(Sender: TObject; Node: TTreeNode);\r\n procedure TVCompareEvent(Sender: TObject; Node1, Node2: TTreeNode; Data: Integer; var Compare: Integer);\r\n procedure RichEditResizeEvent(Sender: TObject; Rect: TRect);\r\n procedure RichEditProtectChange(Sender: TObject; StartPos, EndPos: Integer; var AllowChange: Boolean);\r\n procedure RichEditSaveClipboard(Sender: TObject; NumObjects, NumChars: Integer; var SaveClipboard: Boolean);\r\n procedure UDClickEvent(Sender: TObject; Button: TUDBtnType);\r\n procedure UDChangingEvent(Sender: TObject; var AllowChange: Boolean);\r\n procedure LVDeletedEvent(Sender: TObject; Item: TListItem);\r\n procedure LVEditingEvent(Sender: TObject; Item: TListItem; var AllowEdit: Boolean);\r\n procedure LVEditedEvent(Sender: TObject; Item: TListItem; var S: string);\r\n procedure LVChangeEvent(Sender: TObject; Item: TListItem; Change: TItemChange);\r\n procedure LVChangingEvent(Sender: TObject; Item: TListItem; Change: TItemChange; var AllowChange: Boolean);\r\n procedure LVColumnClickEvent(Sender: TObject; Column: TListColumn);\r\n procedure LVCompareEvent(Sender: TObject; Item1, Item2: TListItem; Data: Integer; var Compare: Integer);\r\n end;\r\n\r\nprocedure TJvInterpreterComCtrlsEvent.TabChangingEvent(Sender: TObject; var AllowChange: Boolean);\r\nbegin\r\n CallFunction(nil, [O2V(Sender), AllowChange]);\r\n AllowChange := Args.Values[1];\r\nend;\r\n\r\nprocedure TJvInterpreterComCtrlsEvent.DrawPanelEvent(StatusBar: TStatusBar; Panel: TStatusPanel; const Rect: TRect);\r\nbegin\r\n CallFunction(nil, [O2V(StatusBar), O2V(Panel), Rect2Var(Rect)]);\r\nend;\r\n\r\nprocedure TJvInterpreterComCtrlsEvent.DrawSectionEvent(HeaderControl: THeaderControl; Section: THeaderSection; const\r\n Rect: TRect; Pressed: Boolean);\r\nbegin\r\n CallFunction(nil, [O2V(HeaderControl), O2V(Section), Rect2Var(Rect), Pressed]);\r\nend;\r\n\r\nprocedure TJvInterpreterComCtrlsEvent.SectionNotifyEvent(HeaderControl: THeaderControl; Section: THeaderSection);\r\nbegin\r\n CallFunction(nil, [O2V(HeaderControl), O2V(Section)]);\r\nend;\r\n\r\nprocedure TJvInterpreterComCtrlsEvent.SectionTrackEvent(HeaderControl: THeaderControl; Section: THeaderSection; Width:\r\n Integer; State: TSectionTrackState);\r\nbegin\r\n CallFunction(nil, [O2V(HeaderControl), O2V(Section), Width, V2S(Byte(State))]);\r\nend;\r\n\r\nprocedure TJvInterpreterComCtrlsEvent.TVChangingEvent(Sender: TObject; Node: TTreeNode; var AllowChange: Boolean);\r\nbegin\r\n CallFunction(nil, [O2V(Sender), O2V(Node), AllowChange]);\r\n AllowChange := Args.Values[2];\r\nend;\r\n\r\nprocedure TJvInterpreterComCtrlsEvent.TVChangedEvent(Sender: TObject; Node: TTreeNode);\r\nbegin\r\n CallFunction(nil, [O2V(Sender), O2V(Node)]);\r\nend;\r\n\r\nprocedure TJvInterpreterComCtrlsEvent.TVEditingEvent(Sender: TObject; Node: TTreeNode; var AllowEdit: Boolean);\r\nbegin\r\n CallFunction(nil, [O2V(Sender), O2V(Node), AllowEdit]);\r\n AllowEdit := Args.Values[2];\r\nend;\r\n\r\nprocedure TJvInterpreterComCtrlsEvent.TVEditedEvent(Sender: TObject; Node: TTreeNode; var S: string);\r\nbegin\r\n CallFunction(nil, [O2V(Sender), O2V(Node), S]);\r\n S := Args.Values[2];\r\nend;\r\n\r\nprocedure TJvInterpreterComCtrlsEvent.TVExpandingEvent(Sender: TObject; Node: TTreeNode; var AllowExpansion: Boolean);\r\nbegin\r\n CallFunction(nil, [O2V(Sender), O2V(Node), AllowExpansion]);\r\n AllowExpansion := Args.Values[2];\r\nend;\r\n\r\nprocedure TJvInterpreterComCtrlsEvent.TVCollapsingEvent(Sender: TObject; Node: TTreeNode; var AllowCollapse: Boolean);\r\nbegin\r\n CallFunction(nil, [O2V(Sender), O2V(Node), AllowCollapse]);\r\n AllowCollapse := Args.Values[2];\r\nend;\r\n\r\nprocedure TJvInterpreterComCtrlsEvent.TVExpandedEvent(Sender: TObject; Node: TTreeNode);\r\nbegin\r\n CallFunction(nil, [O2V(Sender), O2V(Node)]);\r\nend;\r\n\r\nprocedure TJvInterpreterComCtrlsEvent.TVCompareEvent(Sender: TObject; Node1, Node2: TTreeNode; Data: Integer;\r\n var Compare: Integer);\r\nbegin\r\n CallFunction(nil, [O2V(Sender), O2V(Node1), O2V(Node2), Data, Compare]);\r\n Compare := Args.Values[4];\r\nend;\r\n\r\nprocedure TJvInterpreterComCtrlsEvent.RichEditResizeEvent(Sender: TObject; Rect: TRect);\r\nbegin\r\n CallFunction(nil, [O2V(Sender), Rect2Var(Rect)]);\r\nend;\r\n\r\nprocedure TJvInterpreterComCtrlsEvent.RichEditProtectChange(Sender: TObject; StartPos, EndPos: Integer;\r\n var AllowChange: Boolean);\r\nbegin\r\n CallFunction(nil, [O2V(Sender), StartPos, EndPos, AllowChange]);\r\n AllowChange := Args.Values[3];\r\nend;\r\n\r\nprocedure TJvInterpreterComCtrlsEvent.RichEditSaveClipboard(Sender: TObject; NumObjects, NumChars: Integer;\r\n var SaveClipboard: Boolean);\r\nbegin\r\n CallFunction(nil, [O2V(Sender), NumObjects, NumChars, SaveClipboard]);\r\n SaveClipboard := Args.Values[3];\r\nend;\r\n\r\nprocedure TJvInterpreterComCtrlsEvent.UDClickEvent(Sender: TObject; Button: TUDBtnType);\r\nbegin\r\n CallFunction(nil, [O2V(Sender), Button]);\r\nend;\r\n\r\nprocedure TJvInterpreterComCtrlsEvent.UDChangingEvent(Sender: TObject; var AllowChange: Boolean);\r\nbegin\r\n CallFunction(nil, [O2V(Sender), AllowChange]);\r\n AllowChange := Args.Values[1];\r\nend;\r\n\r\nprocedure TJvInterpreterComCtrlsEvent.LVDeletedEvent(Sender: TObject; Item: TListItem);\r\nbegin\r\n CallFunction(nil, [O2V(Sender), O2V(Item)]);\r\nend;\r\n\r\nprocedure TJvInterpreterComCtrlsEvent.LVEditingEvent(Sender: TObject; Item: TListItem; var AllowEdit: Boolean);\r\nbegin\r\n CallFunction(nil, [O2V(Sender), O2V(Item), AllowEdit]);\r\n AllowEdit := Args.Values[2];\r\nend;\r\n\r\nprocedure TJvInterpreterComCtrlsEvent.LVEditedEvent(Sender: TObject; Item: TListItem; var S: string);\r\nbegin\r\n CallFunction(nil, [O2V(Sender), O2V(Item), S]);\r\n S := Args.Values[2];\r\nend;\r\n\r\nprocedure TJvInterpreterComCtrlsEvent.LVChangeEvent(Sender: TObject; Item: TListItem; Change: TItemChange);\r\nbegin\r\n CallFunction(nil, [O2V(Sender), O2V(Item), Change]);\r\nend;\r\n\r\nprocedure TJvInterpreterComCtrlsEvent.LVChangingEvent(Sender: TObject; Item: TListItem; Change: TItemChange;\r\n var AllowChange: Boolean);\r\nbegin\r\n CallFunction(nil, [O2V(Sender), O2V(Item), Change, AllowChange]);\r\n AllowChange := Args.Values[3];\r\nend;\r\n\r\nprocedure TJvInterpreterComCtrlsEvent.LVColumnClickEvent(Sender: TObject; Column: TListColumn);\r\nbegin\r\n CallFunction(nil, [O2V(Sender), O2V(Column)]);\r\nend;\r\n\r\nprocedure TJvInterpreterComCtrlsEvent.LVCompareEvent(Sender: TObject; Item1, Item2: TListItem; Data: Integer;\r\n var Compare: Integer);\r\nbegin\r\n CallFunction(nil, [O2V(Sender), O2V(Item1), O2V(Item2), Data, Compare]);\r\n Compare := Args.Values[4];\r\nend;\r\n\r\nprocedure RegisterJvInterpreterAdapter(JvInterpreterAdapter: TJvInterpreterAdapter);\r\nconst\r\n cComCtrls = 'ComCtrls';\r\nbegin\r\n with JvInterpreterAdapter do\r\n begin\r\n { TTabPosition }\r\n AddConst(cComCtrls, 'tpTop', Ord(tpTop));\r\n AddConst(cComCtrls, 'tpBottom', Ord(tpBottom));\r\n { TCustomTabControl }\r\n AddClass(cComCtrls, TCustomTabControl, 'TCustomTabControl');\r\n { TTabControl }\r\n AddClass(cComCtrls, TTabControl, 'TTabControl');\r\n AddGet(TTabControl, 'Create', TTabControl_Create, 1, [varEmpty], varEmpty);\r\n { TTabSheet }\r\n AddClass(cComCtrls, TTabSheet, 'TTabSheet');\r\n AddGet(TTabSheet, 'Create', TTabSheet_Create, 1, [varEmpty], varEmpty);\r\n AddGet(TTabSheet, 'PageControl', TTabSheet_Read_PageControl, 0, [varEmpty], varEmpty);\r\n AddSet(TTabSheet, 'PageControl', TTabSheet_Write_PageControl, 0, [varEmpty]);\r\n AddGet(TTabSheet, 'TabIndex', TTabSheet_Read_TabIndex, 0, [varEmpty], varEmpty);\r\n { TPageControl }\r\n AddClass(cComCtrls, TPageControl, 'TPageControl');\r\n AddGet(TPageControl, 'Create', TPageControl_Create, 1, [varEmpty], varEmpty);\r\n AddGet(TPageControl, 'FindNextPage', TPageControl_FindNextPage, 3, [varEmpty, varEmpty, varEmpty], varEmpty);\r\n AddGet(TPageControl, 'SelectNextPage', TPageControl_SelectNextPage, 1, [varEmpty], varEmpty);\r\n AddGet(TPageControl, 'PageCount', TPageControl_Read_PageCount, 0, [varEmpty], varEmpty);\r\n AddGet(TPageControl, 'Pages', TPageControl_Read_Pages, 1, [varEmpty], varEmpty);\r\n { TStatusPanelStyle }\r\n AddConst(cComCtrls, 'psText', Ord(psText));\r\n AddConst(cComCtrls, 'psOwnerDraw', Ord(psOwnerDraw));\r\n { TStatusPanelBevel }\r\n AddConst(cComCtrls, 'pbNone', Ord(pbNone));\r\n AddConst(cComCtrls, 'pbLowered', Ord(pbLowered));\r\n AddConst(cComCtrls, 'pbRaised', Ord(pbRaised));\r\n { TStatusPanel }\r\n AddClass(cComCtrls, TStatusPanel, 'TStatusPanel');\r\n AddGet(TStatusPanel, 'Create', TStatusPanel_Create, 1, [varEmpty], varEmpty);\r\n AddGet(TStatusPanel, 'Assign', TStatusPanel_Assign, 1, [varEmpty], varEmpty);\r\n { TStatusPanels }\r\n AddClass(cComCtrls, TStatusPanels, 'TStatusPanels');\r\n AddGet(TStatusPanels, 'Create', TStatusPanels_Create, 1, [varEmpty], varEmpty);\r\n AddGet(TStatusPanels, 'Add', TStatusPanels_Add, 0, [varEmpty], varEmpty);\r\n AddIGet(TStatusPanels, 'Items', TStatusPanels_Read_Items, 1, [varEmpty], varEmpty);\r\n AddISet(TStatusPanels, 'Items', TStatusPanels_Write_Items, 1, [varNull]);\r\n { TStatusBar }\r\n AddClass(cComCtrls, TStatusBar, 'TStatusBar');\r\n AddGet(TStatusBar, 'Create', TStatusBar_Create, 1, [varEmpty], varEmpty);\r\n AddGet(TStatusBar, 'Canvas', TStatusBar_Read_Canvas, 0, [varEmpty], varEmpty);\r\n { THeaderSectionStyle }\r\n AddConst(cComCtrls, 'hsText', Ord(hsText));\r\n AddConst(cComCtrls, 'hsOwnerDraw', Ord(hsOwnerDraw));\r\n { THeaderSection }\r\n AddClass(cComCtrls, THeaderSection, 'THeaderSection');\r\n AddGet(THeaderSection, 'Create', THeaderSection_Create, 1, [varEmpty], varEmpty);\r\n AddGet(THeaderSection, 'Assign', THeaderSection_Assign, 1, [varEmpty], varEmpty);\r\n AddGet(THeaderSection, 'Left', THeaderSection_Read_Left, 0, [varEmpty], varEmpty);\r\n AddGet(THeaderSection, 'Right', THeaderSection_Read_Right, 0, [varEmpty], varEmpty);\r\n { THeaderSections }\r\n AddClass(cComCtrls, THeaderSections, 'THeaderSections');\r\n AddGet(THeaderSections, 'Create', THeaderSections_Create, 1, [varEmpty], varEmpty);\r\n AddGet(THeaderSections, 'Add', THeaderSections_Add, 0, [varEmpty], varEmpty);\r\n AddIGet(THeaderSections, 'Items', THeaderSections_Read_Items, 1, [varEmpty], varEmpty);\r\n AddISet(THeaderSections, 'Items', THeaderSections_Write_Items, 1, [varNull]);\r\n { TSectionTrackState }\r\n AddConst(cComCtrls, 'tsTrackBegin', Ord(tsTrackBegin));\r\n AddConst(cComCtrls, 'tsTrackMove', Ord(tsTrackMove));\r\n AddConst(cComCtrls, 'tsTrackEnd', Ord(tsTrackEnd));\r\n { THeaderControl }\r\n AddClass(cComCtrls, THeaderControl, 'THeaderControl');\r\n AddGet(THeaderControl, 'Create', THeaderControl_Create, 1, [varEmpty], varEmpty);\r\n AddGet(THeaderControl, 'Canvas', THeaderControl_Read_Canvas, 0, [varEmpty], varEmpty);\r\n { TNodeState }\r\n AddConst(cComCtrls, 'nsCut', Ord(nsCut));\r\n AddConst(cComCtrls, 'nsDropHilited', Ord(nsDropHilited));\r\n AddConst(cComCtrls, 'nsFocused', Ord(nsFocused));\r\n AddConst(cComCtrls, 'nsSelected', Ord(nsSelected));\r\n AddConst(cComCtrls, 'nsExpanded', Ord(nsExpanded));\r\n { TNodeAttachMode }\r\n AddConst(cComCtrls, 'naAdd', Ord(naAdd));\r\n AddConst(cComCtrls, 'naAddFirst', Ord(naAddFirst));\r\n AddConst(cComCtrls, 'naAddChild', Ord(naAddChild));\r\n AddConst(cComCtrls, 'naAddChildFirst', Ord(naAddChildFirst));\r\n AddConst(cComCtrls, 'naInsert', Ord(naInsert));\r\n { TAddMode }\r\n AddConst(cComCtrls, 'taAddFirst', Ord(taAddFirst));\r\n AddConst(cComCtrls, 'taAdd', Ord(taAdd));\r\n AddConst(cComCtrls, 'taInsert', Ord(taInsert));\r\n { TTreeNode }\r\n AddClass(cComCtrls, TTreeNode, 'TTreeNode');\r\n AddGet(TTreeNode, 'Create', TTreeNode_Create, 1, [varEmpty], varEmpty);\r\n AddGet(TTreeNode, 'AlphaSort', TTreeNode_AlphaSort, 0, [varEmpty], varEmpty);\r\n AddGet(TTreeNode, 'Assign', TTreeNode_Assign, 1, [varEmpty], varEmpty);\r\n AddGet(TTreeNode, 'Collapse', TTreeNode_Collapse, 1, [varEmpty], varEmpty);\r\n AddGet(TTreeNode, 'CustomSort', TTreeNode_CustomSort, 2, [varEmpty, varEmpty], varEmpty);\r\n AddGet(TTreeNode, 'Delete', TTreeNode_Delete, 0, [varEmpty], varEmpty);\r\n AddGet(TTreeNode, 'DeleteChildren', TTreeNode_DeleteChildren, 0, [varEmpty], varEmpty);\r\n AddGet(TTreeNode, 'DisplayRect', TTreeNode_DisplayRect, 1, [varEmpty], varEmpty);\r\n AddGet(TTreeNode, 'EditText', TTreeNode_EditText, 0, [varEmpty], varEmpty);\r\n AddGet(TTreeNode, 'EndEdit', TTreeNode_EndEdit, 1, [varEmpty], varEmpty);\r\n AddGet(TTreeNode, 'Expand', TTreeNode_Expand, 1, [varEmpty], varEmpty);\r\n AddGet(TTreeNode, 'GetFirstChild', TTreeNode_GetFirstChild, 0, [varEmpty], varEmpty);\r\n AddGet(TTreeNode, 'GetHandle', TTreeNode_GetHandle, 0, [varEmpty], varEmpty);\r\n AddGet(TTreeNode, 'GetLastChild', TTreeNode_GetLastChild, 0, [varEmpty], varEmpty);\r\n AddGet(TTreeNode, 'GetNext', TTreeNode_GetNext, 0, [varEmpty], varEmpty);\r\n AddGet(TTreeNode, 'GetNextChild', TTreeNode_GetNextChild, 1, [varEmpty], varEmpty);\r\n AddGet(TTreeNode, 'GetNextSibling', TTreeNode_GetNextSibling, 0, [varEmpty], varEmpty);\r\n AddGet(TTreeNode, 'GetNextVisible', TTreeNode_GetNextVisible, 0, [varEmpty], varEmpty);\r\n AddGet(TTreeNode, 'GetPrev', TTreeNode_GetPrev, 0, [varEmpty], varEmpty);\r\n AddGet(TTreeNode, 'GetPrevChild', TTreeNode_GetPrevChild, 1, [varEmpty], varEmpty);\r\n AddGet(TTreeNode, 'GetPrevSibling', TTreeNode_GetPrevSibling, 0, [varEmpty], varEmpty);\r\n AddGet(TTreeNode, 'GetPrevVisible', TTreeNode_GetPrevVisible, 0, [varEmpty], varEmpty);\r\n AddGet(TTreeNode, 'HasAsParent', TTreeNode_HasAsParent, 1, [varEmpty], varEmpty);\r\n AddGet(TTreeNode, 'IndexOf', TTreeNode_IndexOf, 1, [varEmpty], varEmpty);\r\n AddGet(TTreeNode, 'MakeVisible', TTreeNode_MakeVisible, 0, [varEmpty], varEmpty);\r\n AddGet(TTreeNode, 'MoveTo', TTreeNode_MoveTo, 2, [varEmpty, varEmpty], varEmpty);\r\n AddGet(TTreeNode, 'AbsoluteIndex', TTreeNode_Read_AbsoluteIndex, 0, [varEmpty], varEmpty);\r\n AddGet(TTreeNode, 'Count', TTreeNode_Read_Count, 0, [varEmpty], varEmpty);\r\n AddGet(TTreeNode, 'Cut', TTreeNode_Read_Cut, 0, [varEmpty], varEmpty);\r\n AddSet(TTreeNode, 'Cut', TTreeNode_Write_Cut, 0, [varEmpty]);\r\n AddGet(TTreeNode, 'Data', TTreeNode_Read_Data, 0, [varEmpty], varEmpty);\r\n AddSet(TTreeNode, 'Data', TTreeNode_Write_Data, 0, [varEmpty]);\r\n AddGet(TTreeNode, 'Deleting', TTreeNode_Read_Deleting, 0, [varEmpty], varEmpty);\r\n AddGet(TTreeNode, 'Focused', TTreeNode_Read_Focused, 0, [varEmpty], varEmpty);\r\n AddSet(TTreeNode, 'Focused', TTreeNode_Write_Focused, 0, [varEmpty]);\r\n AddGet(TTreeNode, 'DropTarget', TTreeNode_Read_DropTarget, 0, [varEmpty], varEmpty);\r\n AddSet(TTreeNode, 'DropTarget', TTreeNode_Write_DropTarget, 0, [varEmpty]);\r\n AddGet(TTreeNode, 'Selected', TTreeNode_Read_Selected, 0, [varEmpty], varEmpty);\r\n AddSet(TTreeNode, 'Selected', TTreeNode_Write_Selected, 0, [varEmpty]);\r\n AddGet(TTreeNode, 'Expanded', TTreeNode_Read_Expanded, 0, [varEmpty], varEmpty);\r\n AddSet(TTreeNode, 'Expanded', TTreeNode_Write_Expanded, 0, [varEmpty]);\r\n AddGet(TTreeNode, 'Handle', TTreeNode_Read_Handle, 0, [varEmpty], varEmpty);\r\n AddGet(TTreeNode, 'HasChildren', TTreeNode_Read_HasChildren, 0, [varEmpty], varEmpty);\r\n AddSet(TTreeNode, 'HasChildren', TTreeNode_Write_HasChildren, 0, [varEmpty]);\r\n AddGet(TTreeNode, 'ImageIndex', TTreeNode_Read_ImageIndex, 0, [varEmpty], varEmpty);\r\n AddSet(TTreeNode, 'ImageIndex', TTreeNode_Write_ImageIndex, 0, [varEmpty]);\r\n AddGet(TTreeNode, 'Index', TTreeNode_Read_Index, 0, [varEmpty], varEmpty);\r\n AddGet(TTreeNode, 'IsVisible', TTreeNode_Read_IsVisible, 0, [varEmpty], varEmpty);\r\n AddIGet(TTreeNode, 'Item', TTreeNode_Read_Item, 1, [varEmpty], varEmpty);\r\n AddISet(TTreeNode, 'Item', TTreeNode_Write_Item, 1, [varNull]);\r\n AddGet(TTreeNode, 'ItemId', TTreeNode_Read_ItemId, 0, [varEmpty], varEmpty);\r\n AddGet(TTreeNode, 'Level', TTreeNode_Read_Level, 0, [varEmpty], varEmpty);\r\n AddGet(TTreeNode, 'OverlayIndex', TTreeNode_Read_OverlayIndex, 0, [varEmpty], varEmpty);\r\n AddSet(TTreeNode, 'OverlayIndex', TTreeNode_Write_OverlayIndex, 0, [varEmpty]);\r\n AddGet(TTreeNode, 'Owner', TTreeNode_Read_Owner, 0, [varEmpty], varEmpty);\r\n AddGet(TTreeNode, 'Parent', TTreeNode_Read_Parent, 0, [varEmpty], varEmpty);\r\n AddGet(TTreeNode, 'SelectedIndex', TTreeNode_Read_SelectedIndex, 0, [varEmpty], varEmpty);\r\n AddSet(TTreeNode, 'SelectedIndex', TTreeNode_Write_SelectedIndex, 0, [varEmpty]);\r\n AddGet(TTreeNode, 'StateIndex', TTreeNode_Read_StateIndex, 0, [varEmpty], varEmpty);\r\n AddSet(TTreeNode, 'StateIndex', TTreeNode_Write_StateIndex, 0, [varEmpty]);\r\n AddGet(TTreeNode, 'Text', TTreeNode_Read_Text, 0, [varEmpty], varEmpty);\r\n AddSet(TTreeNode, 'Text', TTreeNode_Write_Text, 0, [varEmpty]);\r\n AddGet(TTreeNode, 'TreeView', TTreeNode_Read_TreeView, 0, [varEmpty], varEmpty);\r\n { TTreeNodes }\r\n AddClass(cComCtrls, TTreeNodes, 'TTreeNodes');\r\n AddGet(TTreeNodes, 'Create', TTreeNodes_Create, 1, [varEmpty], varEmpty);\r\n AddGet(TTreeNodes, 'AddChildFirst', TTreeNodes_AddChildFirst, 2, [varEmpty, varEmpty], varEmpty);\r\n AddGet(TTreeNodes, 'AddChild', TTreeNodes_AddChild, 2, [varEmpty, varEmpty], varEmpty);\r\n AddGet(TTreeNodes, 'AddChildObjectFirst', TTreeNodes_AddChildObjectFirst, 3, [varEmpty, varEmpty, varEmpty],\r\n varEmpty);\r\n AddGet(TTreeNodes, 'AddChildObject', TTreeNodes_AddChildObject, 3, [varEmpty, varEmpty, varEmpty], varEmpty);\r\n AddGet(TTreeNodes, 'AddFirst', TTreeNodes_AddFirst, 2, [varEmpty, varEmpty], varEmpty);\r\n AddGet(TTreeNodes, 'Add', TTreeNodes_Add, 2, [varEmpty, varEmpty], varEmpty);\r\n AddGet(TTreeNodes, 'AddObjectFirst', TTreeNodes_AddObjectFirst, 3, [varEmpty, varEmpty, varEmpty], varEmpty);\r\n AddGet(TTreeNodes, 'AddObject', TTreeNodes_AddObject, 3, [varEmpty, varEmpty, varEmpty], varEmpty);\r\n AddGet(TTreeNodes, 'Assign', TTreeNodes_Assign, 1, [varEmpty], varEmpty);\r\n AddGet(TTreeNodes, 'BeginUpdate', TTreeNodes_BeginUpdate, 0, [varEmpty], varEmpty);\r\n AddGet(TTreeNodes, 'Clear', TTreeNodes_Clear, 0, [varEmpty], varEmpty);\r\n AddGet(TTreeNodes, 'Delete', TTreeNodes_Delete, 1, [varEmpty], varEmpty);\r\n AddGet(TTreeNodes, 'EndUpdate', TTreeNodes_EndUpdate, 0, [varEmpty], varEmpty);\r\n AddGet(TTreeNodes, 'GetFirstNode', TTreeNodes_GetFirstNode, 0, [varEmpty], varEmpty);\r\n AddGet(TTreeNodes, 'GetNode', TTreeNodes_GetNode, 1, [varEmpty], varEmpty);\r\n AddGet(TTreeNodes, 'Insert', TTreeNodes_Insert, 2, [varEmpty, varEmpty], varEmpty);\r\n AddGet(TTreeNodes, 'InsertObject', TTreeNodes_InsertObject, 3, [varEmpty, varEmpty, varEmpty], varEmpty);\r\n AddGet(TTreeNodes, 'Count', TTreeNodes_Read_Count, 0, [varEmpty], varEmpty);\r\n AddGet(TTreeNodes, 'Handle', TTreeNodes_Read_Handle, 0, [varEmpty], varEmpty);\r\n AddGet(TTreeNodes, 'Item', TTreeNodes_Read_Item, 1, [varEmpty], varEmpty);\r\n AddGet(TTreeNodes, 'Owner', TTreeNodes_Read_Owner, 0, [varEmpty], varEmpty);\r\n { THitTest }\r\n AddConst(cComCtrls, 'htAbove', Ord(htAbove));\r\n AddConst(cComCtrls, 'htBelow', Ord(htBelow));\r\n AddConst(cComCtrls, 'htNowhere', Ord(htNowhere));\r\n AddConst(cComCtrls, 'htOnItem', Ord(htOnItem));\r\n AddConst(cComCtrls, 'htOnButton', Ord(htOnButton));\r\n AddConst(cComCtrls, 'htOnIcon', Ord(htOnIcon));\r\n AddConst(cComCtrls, 'htOnIndent', Ord(htOnIndent));\r\n AddConst(cComCtrls, 'htOnLabel', Ord(htOnLabel));\r\n AddConst(cComCtrls, 'htOnRight', Ord(htOnRight));\r\n AddConst(cComCtrls, 'htOnStateIcon', Ord(htOnStateIcon));\r\n AddConst(cComCtrls, 'htToLeft', Ord(htToLeft));\r\n AddConst(cComCtrls, 'htToRight', Ord(htToRight));\r\n { TSortType }\r\n AddConst(cComCtrls, 'stNone', Ord(stNone));\r\n AddConst(cComCtrls, 'stData', Ord(stData));\r\n AddConst(cComCtrls, 'stText', Ord(stText));\r\n AddConst(cComCtrls, 'stBoth', Ord(stBoth));\r\n { TCustomTreeView }\r\n AddClass(cComCtrls, TCustomTreeView, 'TCustomTreeView');\r\n AddGet(TCustomTreeView, 'AlphaSort', TCustomTreeView_AlphaSort, 0, [varEmpty], varEmpty);\r\n AddGet(TCustomTreeView, 'CustomSort', TCustomTreeView_CustomSort, 2, [varEmpty, varEmpty], varEmpty);\r\n AddGet(TCustomTreeView, 'FullCollapse', TCustomTreeView_FullCollapse, 0, [varEmpty], varEmpty);\r\n AddGet(TCustomTreeView, 'FullExpand', TCustomTreeView_FullExpand, 0, [varEmpty], varEmpty);\r\n AddGet(TCustomTreeView, 'GetHitTestInfoAt', TCustomTreeView_GetHitTestInfoAt, 2, [varEmpty, varEmpty], varEmpty);\r\n AddGet(TCustomTreeView, 'GetNodeAt', TCustomTreeView_GetNodeAt, 2, [varEmpty, varEmpty], varEmpty);\r\n AddGet(TCustomTreeView, 'IsEditing', TCustomTreeView_IsEditing, 0, [varEmpty], varEmpty);\r\n AddGet(TCustomTreeView, 'LoadFromFile', TCustomTreeView_LoadFromFile, 1, [varEmpty], varEmpty);\r\n AddGet(TCustomTreeView, 'LoadFromStream', TCustomTreeView_LoadFromStream, 1, [varEmpty], varEmpty);\r\n AddGet(TCustomTreeView, 'SaveToFile', TCustomTreeView_SaveToFile, 1, [varEmpty], varEmpty);\r\n AddGet(TCustomTreeView, 'SaveToStream', TCustomTreeView_SaveToStream, 1, [varEmpty], varEmpty);\r\n AddGet(TCustomTreeView, 'DropTarget', TCustomTreeView_Read_DropTarget, 0, [varEmpty], varEmpty);\r\n AddSet(TCustomTreeView, 'DropTarget', TCustomTreeView_Write_DropTarget, 0, [varEmpty]);\r\n AddGet(TCustomTreeView, 'Selected', TCustomTreeView_Read_Selected, 0, [varEmpty], varEmpty);\r\n AddSet(TCustomTreeView, 'Selected', TCustomTreeView_Write_Selected, 0, [varEmpty]);\r\n AddGet(TCustomTreeView, 'TopItem', TCustomTreeView_Read_TopItem, 0, [varEmpty], varEmpty);\r\n AddSet(TCustomTreeView, 'TopItem', TCustomTreeView_Write_TopItem, 0, [varEmpty]);\r\n { TTreeView }\r\n AddClass(cComCtrls, TTreeView, 'TTreeView');\r\n AddGet(TTreeView, 'Create', TTreeView_Create, 1, [varEmpty], varEmpty);\r\n { TTrackBarOrientation }\r\n AddConst(cComCtrls, 'trHorizontal', Ord(trHorizontal));\r\n AddConst(cComCtrls, 'trVertical', Ord(trVertical));\r\n { TTickMark }\r\n AddConst(cComCtrls, 'tmBottomRight', Ord(tmBottomRight));\r\n AddConst(cComCtrls, 'tmTopLeft', Ord(tmTopLeft));\r\n AddConst(cComCtrls, 'tmBoth', Ord(tmBoth));\r\n { TTickStyle }\r\n AddConst(cComCtrls, 'tsNone', Ord(tsNone));\r\n AddConst(cComCtrls, 'tsAuto', Ord(tsAuto));\r\n AddConst(cComCtrls, 'tsManual', Ord(tsManual));\r\n { TTrackBar }\r\n AddClass(cComCtrls, TTrackBar, 'TTrackBar');\r\n AddGet(TTrackBar, 'Create', TTrackBar_Create, 1, [varEmpty], varEmpty);\r\n AddGet(TTrackBar, 'SetTick', TTrackBar_SetTick, 1, [varEmpty], varEmpty);\r\n { TProgressBar }\r\n AddClass(cComCtrls, TProgressBar, 'TProgressBar');\r\n AddGet(TProgressBar, 'Create', TProgressBar_Create, 1, [varEmpty], varEmpty);\r\n AddGet(TProgressBar, 'StepIt', TProgressBar_StepIt, 0, [varEmpty], varEmpty);\r\n AddGet(TProgressBar, 'StepBy', TProgressBar_StepBy, 1, [varEmpty], varEmpty);\r\n { TAttributeType }\r\n AddConst(cComCtrls, 'atSelected', Ord(atSelected));\r\n AddConst(cComCtrls, 'atDefaultText', Ord(atDefaultText));\r\n { TConsistentAttribute }\r\n AddConst(cComCtrls, 'caBold', Ord(caBold));\r\n AddConst(cComCtrls, 'caColor', Ord(caColor));\r\n AddConst(cComCtrls, 'caFace', Ord(caFace));\r\n AddConst(cComCtrls, 'caItalic', Ord(caItalic));\r\n AddConst(cComCtrls, 'caSize', Ord(caSize));\r\n AddConst(cComCtrls, 'caStrikeOut', Ord(caStrikeOut));\r\n AddConst(cComCtrls, 'caUnderline', Ord(caUnderline));\r\n AddConst(cComCtrls, 'caProtected', Ord(caProtected));\r\n { TTextAttributes }\r\n AddClass(cComCtrls, TTextAttributes, 'TTextAttributes');\r\n AddGet(TTextAttributes, 'Create', TTextAttributes_Create, 2, [varEmpty, varEmpty], varEmpty);\r\n AddGet(TTextAttributes, 'Assign', TTextAttributes_Assign, 1, [varEmpty], varEmpty);\r\n AddGet(TTextAttributes, 'Charset', TTextAttributes_Read_Charset, 0, [varEmpty], varEmpty);\r\n AddSet(TTextAttributes, 'Charset', TTextAttributes_Write_Charset, 0, [varEmpty]);\r\n AddGet(TTextAttributes, 'Color', TTextAttributes_Read_Color, 0, [varEmpty], varEmpty);\r\n AddSet(TTextAttributes, 'Color', TTextAttributes_Write_Color, 0, [varEmpty]);\r\n AddGet(TTextAttributes, 'ConsistentAttributes', TTextAttributes_Read_ConsistentAttributes, 0, [varEmpty], varEmpty);\r\n AddGet(TTextAttributes, 'Name', TTextAttributes_Read_Name, 0, [varEmpty], varEmpty);\r\n AddSet(TTextAttributes, 'Name', TTextAttributes_Write_Name, 0, [varEmpty]);\r\n AddGet(TTextAttributes, 'Pitch', TTextAttributes_Read_Pitch, 0, [varEmpty], varEmpty);\r\n AddSet(TTextAttributes, 'Pitch', TTextAttributes_Write_Pitch, 0, [varEmpty]);\r\n AddGet(TTextAttributes, 'Protected', TTextAttributes_Read_Protected, 0, [varEmpty], varEmpty);\r\n AddSet(TTextAttributes, 'Protected', TTextAttributes_Write_Protected, 0, [varEmpty]);\r\n AddGet(TTextAttributes, 'Size', TTextAttributes_Read_Size, 0, [varEmpty], varEmpty);\r\n AddSet(TTextAttributes, 'Size', TTextAttributes_Write_Size, 0, [varEmpty]);\r\n AddGet(TTextAttributes, 'Style', TTextAttributes_Read_Style, 0, [varEmpty], varEmpty);\r\n AddSet(TTextAttributes, 'Style', TTextAttributes_Write_Style, 0, [varEmpty]);\r\n AddGet(TTextAttributes, 'Height', TTextAttributes_Read_Height, 0, [varEmpty], varEmpty);\r\n AddSet(TTextAttributes, 'Height', TTextAttributes_Write_Height, 0, [varEmpty]);\r\n { TNumberingStyle }\r\n AddConst(cComCtrls, 'nsNone', Ord(nsNone));\r\n AddConst(cComCtrls, 'nsBullet', Ord(nsBullet));\r\n { TParaAttributes }\r\n AddClass(cComCtrls, TParaAttributes, 'TParaAttributes');\r\n AddGet(TParaAttributes, 'Create', TParaAttributes_Create, 1, [varEmpty], varEmpty);\r\n AddGet(TParaAttributes, 'Assign', TParaAttributes_Assign, 1, [varEmpty], varEmpty);\r\n AddGet(TParaAttributes, 'Alignment', TParaAttributes_Read_Alignment, 0, [varEmpty], varEmpty);\r\n AddSet(TParaAttributes, 'Alignment', TParaAttributes_Write_Alignment, 0, [varEmpty]);\r\n AddGet(TParaAttributes, 'FirstIndent', TParaAttributes_Read_FirstIndent, 0, [varEmpty], varEmpty);\r\n AddSet(TParaAttributes, 'FirstIndent', TParaAttributes_Write_FirstIndent, 0, [varEmpty]);\r\n AddGet(TParaAttributes, 'LeftIndent', TParaAttributes_Read_LeftIndent, 0, [varEmpty], varEmpty);\r\n AddSet(TParaAttributes, 'LeftIndent', TParaAttributes_Write_LeftIndent, 0, [varEmpty]);\r\n AddGet(TParaAttributes, 'Numbering', TParaAttributes_Read_Numbering, 0, [varEmpty], varEmpty);\r\n AddSet(TParaAttributes, 'Numbering', TParaAttributes_Write_Numbering, 0, [varEmpty]);\r\n AddGet(TParaAttributes, 'RightIndent', TParaAttributes_Read_RightIndent, 0, [varEmpty], varEmpty);\r\n AddSet(TParaAttributes, 'RightIndent', TParaAttributes_Write_RightIndent, 0, [varEmpty]);\r\n AddGet(TParaAttributes, 'Tab', TParaAttributes_Read_Tab, 1, [varEmpty], varEmpty);\r\n AddSet(TParaAttributes, 'Tab', TParaAttributes_Write_Tab, 1, [varNull]);\r\n AddGet(TParaAttributes, 'TabCount', TParaAttributes_Read_TabCount, 0, [varEmpty], varEmpty);\r\n AddSet(TParaAttributes, 'TabCount', TParaAttributes_Write_TabCount, 0, [varEmpty]);\r\n { TSearchType }\r\n AddConst(cComCtrls, 'stWholeWord', Ord(stWholeWord));\r\n AddConst(cComCtrls, 'stMatchCase', Ord(stMatchCase));\r\n { TCustomRichEdit }\r\n AddClass(cComCtrls, TCustomRichEdit, 'TCustomRichEdit');\r\n AddGet(TCustomRichEdit, 'Clear', TCustomRichEdit_Clear, 0, [varEmpty], varEmpty);\r\n AddGet(TCustomRichEdit, 'FindText', TCustomRichEdit_FindText, 4, [varEmpty, varEmpty, varEmpty, varEmpty],\r\n varEmpty);\r\n AddGet(TCustomRichEdit, 'GetSelTextBuf', TCustomRichEdit_GetSelTextBuf, 2, [varEmpty, varEmpty], varEmpty);\r\n AddGet(TCustomRichEdit, 'Print', TCustomRichEdit_Print, 1, [varEmpty], varEmpty);\r\n AddGet(TCustomRichEdit, 'DefAttributes', TCustomRichEdit_Read_DefAttributes, 0, [varEmpty], varEmpty);\r\n AddSet(TCustomRichEdit, 'DefAttributes', TCustomRichEdit_Write_DefAttributes, 0, [varEmpty]);\r\n AddGet(TCustomRichEdit, 'SelAttributes', TCustomRichEdit_Read_SelAttributes, 0, [varEmpty], varEmpty);\r\n AddSet(TCustomRichEdit, 'SelAttributes', TCustomRichEdit_Write_SelAttributes, 0, [varEmpty]);\r\n AddGet(TCustomRichEdit, 'PageRect', TCustomRichEdit_Read_PageRect, 0, [varEmpty], varEmpty);\r\n AddSet(TCustomRichEdit, 'PageRect', TCustomRichEdit_Write_PageRect, 0, [varEmpty]);\r\n AddGet(TCustomRichEdit, 'Paragraph', TCustomRichEdit_Read_Paragraph, 0, [varEmpty], varEmpty);\r\n { TRichEdit }\r\n AddClass(cComCtrls, TRichEdit, 'TRichEdit');\r\n AddGet(TRichEdit, 'Create', TRichEdit_Create, 1, [varEmpty], varEmpty);\r\n { TUDAlignButton }\r\n AddConst(cComCtrls, 'udLeft', Ord(udLeft));\r\n AddConst(cComCtrls, 'udRight', Ord(udRight));\r\n { TUDOrientation }\r\n AddConst(cComCtrls, 'udHorizontal', Ord(udHorizontal));\r\n AddConst(cComCtrls, 'udVertical', Ord(udVertical));\r\n { TUDBtnType }\r\n AddConst(cComCtrls, 'btNext', Ord(btNext));\r\n AddConst(cComCtrls, 'btPrev', Ord(btPrev));\r\n { TCustomUpDown }\r\n AddClass(cComCtrls, TCustomUpDown, 'TCustomUpDown');\r\n { TUpDown }\r\n AddClass(cComCtrls, TUpDown, 'TUpDown');\r\n AddGet(TUpDown, 'Create', TUpDown_Create, 1, [varEmpty], varEmpty);\r\n { THKModifier }\r\n AddConst(cComCtrls, 'hkShift', Ord(hkShift));\r\n AddConst(cComCtrls, 'hkCtrl', Ord(hkCtrl));\r\n AddConst(cComCtrls, 'hkAlt', Ord(hkAlt));\r\n AddConst(cComCtrls, 'hkExt', Ord(hkExt));\r\n { THKInvalidKey }\r\n AddConst(cComCtrls, 'hcNone', Ord(hcNone));\r\n AddConst(cComCtrls, 'hcShift', Ord(hcShift));\r\n AddConst(cComCtrls, 'hcCtrl', Ord(hcCtrl));\r\n AddConst(cComCtrls, 'hcAlt', Ord(hcAlt));\r\n AddConst(cComCtrls, 'hcShiftCtrl', Ord(hcShiftCtrl));\r\n AddConst(cComCtrls, 'hcShiftAlt', Ord(hcShiftAlt));\r\n AddConst(cComCtrls, 'hcCtrlAlt', Ord(hcCtrlAlt));\r\n AddConst(cComCtrls, 'hcShiftCtrlAlt', Ord(hcShiftCtrlAlt));\r\n { TCustomHotKey }\r\n AddClass(cComCtrls, TCustomHotKey, 'TCustomHotKey');\r\n { THotKey }\r\n AddClass(cComCtrls, THotKey, 'THotKey');\r\n AddGet(THotKey, 'Create', THotKey_Create, 1, [varEmpty], varEmpty);\r\n { TListColumn }\r\n AddClass(cComCtrls, TListColumn, 'TListColumn');\r\n AddGet(TListColumn, 'Create', TListColumn_Create, 1, [varEmpty], varEmpty);\r\n AddGet(TListColumn, 'Assign', TListColumn_Assign, 1, [varEmpty], varEmpty);\r\n AddGet(TListColumn, 'WidthType', TListColumn_Read_WidthType, 0, [varEmpty], varEmpty);\r\n { TListColumns }\r\n AddClass(cComCtrls, TListColumns, 'TListColumns');\r\n AddGet(TListColumns, 'Create', TListColumns_Create, 1, [varEmpty], varEmpty);\r\n AddGet(TListColumns, 'Add', TListColumns_Add, 0, [varEmpty], varEmpty);\r\n AddGet(TListColumns, 'Owner', TListColumns_Read_Owner, 0, [varEmpty], varEmpty);\r\n AddIGet(TListColumns, 'Items', TListColumns_Read_Items, 1, [varEmpty], varEmpty);\r\n AddISet(TListColumns, 'Items', TListColumns_Write_Items, 1, [varNull]);\r\n { TDisplayCode }\r\n AddConst(cComCtrls, 'drBounds', Ord(drBounds));\r\n AddConst(cComCtrls, 'drIcon', Ord(drIcon));\r\n AddConst(cComCtrls, 'drLabel', Ord(drLabel));\r\n AddConst(cComCtrls, 'drSelectBounds', Ord(drSelectBounds));\r\n { TListItem }\r\n AddClass(cComCtrls, TListItem, 'TListItem');\r\n AddGet(TListItem, 'Create', TListItem_Create, 1, [varEmpty], varEmpty);\r\n AddGet(TListItem, 'CancelEdit', TListItem_CancelEdit, 0, [varEmpty], varEmpty);\r\n AddGet(TListItem, 'Delete', TListItem_Delete, 0, [varEmpty], varEmpty);\r\n AddGet(TListItem, 'DisplayRect', TListItem_DisplayRect, 1, [varEmpty], varEmpty);\r\n AddGet(TListItem, 'EditCaption', TListItem_EditCaption, 0, [varEmpty], varEmpty);\r\n AddGet(TListItem, 'GetPosition', TListItem_GetPosition, 0, [varEmpty], varEmpty);\r\n AddGet(TListItem, 'MakeVisible', TListItem_MakeVisible, 1, [varEmpty], varEmpty);\r\n AddGet(TListItem, 'Update', TListItem_Update, 0, [varEmpty], varEmpty);\r\n AddGet(TListItem, 'SetPosition', TListItem_SetPosition, 1, [varEmpty], varEmpty);\r\n AddGet(TListItem, 'Caption', TListItem_Read_Caption, 0, [varEmpty], varEmpty);\r\n AddSet(TListItem, 'Caption', TListItem_Write_Caption, 0, [varEmpty]);\r\n AddGet(TListItem, 'Checked', TListItem_Read_Checked, 0, [varEmpty], varEmpty);\r\n AddSet(TListItem, 'Checked', TListItem_Write_Checked, 0, [varEmpty]);\r\n AddGet(TListItem, 'Cut', TListItem_Read_Cut, 0, [varEmpty], varEmpty);\r\n AddSet(TListItem, 'Cut', TListItem_Write_Cut, 0, [varEmpty]);\r\n AddGet(TListItem, 'Data', TListItem_Read_Data, 0, [varEmpty], varEmpty);\r\n AddSet(TListItem, 'Data', TListItem_Write_Data, 0, [varEmpty]);\r\n AddGet(TListItem, 'DropTarget', TListItem_Read_DropTarget, 0, [varEmpty], varEmpty);\r\n AddSet(TListItem, 'DropTarget', TListItem_Write_DropTarget, 0, [varEmpty]);\r\n AddGet(TListItem, 'Focused', TListItem_Read_Focused, 0, [varEmpty], varEmpty);\r\n AddSet(TListItem, 'Focused', TListItem_Write_Focused, 0, [varEmpty]);\r\n AddGet(TListItem, 'Handle', TListItem_Read_Handle, 0, [varEmpty], varEmpty);\r\n AddGet(TListItem, 'ImageIndex', TListItem_Read_ImageIndex, 0, [varEmpty], varEmpty);\r\n AddSet(TListItem, 'ImageIndex', TListItem_Write_ImageIndex, 0, [varEmpty]);\r\n AddGet(TListItem, 'Index', TListItem_Read_Index, 0, [varEmpty], varEmpty);\r\n AddGet(TListItem, 'Left', TListItem_Read_Left, 0, [varEmpty], varEmpty);\r\n AddSet(TListItem, 'Left', TListItem_Write_Left, 0, [varEmpty]);\r\n AddGet(TListItem, 'ListView', TListItem_Read_ListView, 0, [varEmpty], varEmpty);\r\n AddGet(TListItem, 'Owner', TListItem_Read_Owner, 0, [varEmpty], varEmpty);\r\n AddGet(TListItem, 'OverlayIndex', TListItem_Read_OverlayIndex, 0, [varEmpty], varEmpty);\r\n AddSet(TListItem, 'OverlayIndex', TListItem_Write_OverlayIndex, 0, [varEmpty]);\r\n AddGet(TListItem, 'Selected', TListItem_Read_Selected, 0, [varEmpty], varEmpty);\r\n AddSet(TListItem, 'Selected', TListItem_Write_Selected, 0, [varEmpty]);\r\n AddGet(TListItem, 'StateIndex', TListItem_Read_StateIndex, 0, [varEmpty], varEmpty);\r\n AddSet(TListItem, 'StateIndex', TListItem_Write_StateIndex, 0, [varEmpty]);\r\n AddIGet(TListItem, 'SubItems', TListItem_Read_SubItems, 0, [varEmpty], varEmpty);\r\n AddISet(TListItem, 'SubItems', TListItem_Write_SubItems, 0, [varEmpty]);\r\n AddGet(TListItem, 'Top', TListItem_Read_Top, 0, [varEmpty], varEmpty);\r\n AddSet(TListItem, 'Top', TListItem_Write_Top, 0, [varEmpty]);\r\n { TListItems }\r\n AddClass(cComCtrls, TListItems, 'TListItems');\r\n AddGet(TListItems, 'Create', TListItems_Create, 1, [varEmpty], varEmpty);\r\n AddGet(TListItems, 'Add', TListItems_Add, 0, [varEmpty], varEmpty);\r\n AddGet(TListItems, 'Assign', TListItems_Assign, 1, [varEmpty], varEmpty);\r\n AddGet(TListItems, 'BeginUpdate', TListItems_BeginUpdate, 0, [varEmpty], varEmpty);\r\n AddGet(TListItems, 'Clear', TListItems_Clear, 0, [varEmpty], varEmpty);\r\n AddGet(TListItems, 'Delete', TListItems_Delete, 1, [varEmpty], varEmpty);\r\n AddGet(TListItems, 'EndUpdate', TListItems_EndUpdate, 0, [varEmpty], varEmpty);\r\n AddGet(TListItems, 'IndexOf', TListItems_IndexOf, 1, [varEmpty], varEmpty);\r\n AddGet(TListItems, 'Insert', TListItems_Insert, 1, [varEmpty], varEmpty);\r\n AddGet(TListItems, 'Count', TListItems_Read_Count, 0, [varEmpty], varEmpty);\r\n AddGet(TListItems, 'Handle', TListItems_Read_Handle, 0, [varEmpty], varEmpty);\r\n AddIGet(TListItems, 'Item', TListItems_Read_Item, 1, [varEmpty], varEmpty);\r\n AddISet(TListItems, 'Item', TListItems_Write_Item, 1, [varNull]);\r\n AddGet(TListItems, 'Owner', TListItems_Read_Owner, 0, [varEmpty], varEmpty);\r\n { TIconArrangement }\r\n AddConst(cComCtrls, 'iaTop', Ord(iaTop));\r\n AddConst(cComCtrls, 'iaLeft', Ord(iaLeft));\r\n { TListArrangement }\r\n AddConst(cComCtrls, 'arAlignBottom', Ord(arAlignBottom));\r\n AddConst(cComCtrls, 'arAlignLeft', Ord(arAlignLeft));\r\n AddConst(cComCtrls, 'arAlignRight', Ord(arAlignRight));\r\n AddConst(cComCtrls, 'arAlignTop', Ord(arAlignTop));\r\n AddConst(cComCtrls, 'arDefault', Ord(arDefault));\r\n AddConst(cComCtrls, 'arSnapToGrid', Ord(arSnapToGrid));\r\n { TViewStyle }\r\n AddConst(cComCtrls, 'vsIcon', Ord(vsIcon));\r\n AddConst(cComCtrls, 'vsSmallIcon', Ord(vsSmallIcon));\r\n AddConst(cComCtrls, 'vsList', Ord(vsList));\r\n AddConst(cComCtrls, 'vsReport', Ord(vsReport));\r\n { TItemState }\r\n AddConst(cComCtrls, 'isNone', Ord(isNone));\r\n AddConst(cComCtrls, 'isCut', Ord(isCut));\r\n AddConst(cComCtrls, 'isDropHilited', Ord(isDropHilited));\r\n AddConst(cComCtrls, 'isFocused', Ord(isFocused));\r\n AddConst(cComCtrls, 'isSelected', Ord(isSelected));\r\n { TItemChange }\r\n AddConst(cComCtrls, 'ctText', Ord(ctText));\r\n AddConst(cComCtrls, 'ctImage', Ord(ctImage));\r\n AddConst(cComCtrls, 'ctState', Ord(ctState));\r\n { TSearchDirection }\r\n AddConst(cComCtrls, 'sdLeft', Ord(sdLeft));\r\n AddConst(cComCtrls, 'sdRight', Ord(sdRight));\r\n AddConst(cComCtrls, 'sdAbove', Ord(sdAbove));\r\n AddConst(cComCtrls, 'sdBelow', Ord(sdBelow));\r\n AddConst(cComCtrls, 'sdAll', Ord(sdAll));\r\n { TCustomListView }\r\n AddClass(cComCtrls, TCustomListView, 'TCustomListView');\r\n AddGet(TCustomListView, 'AlphaSort', TCustomListView_AlphaSort, 0, [varEmpty], varEmpty);\r\n AddGet(TCustomListView, 'Arrange', TCustomListView_Arrange, 1, [varEmpty], varEmpty);\r\n AddGet(TCustomListView, 'FindCaption', TCustomListView_FindCaption, 5, [varEmpty, varEmpty, varEmpty, varEmpty,\r\n varEmpty], varEmpty);\r\n AddGet(TCustomListView, 'FindData', TCustomListView_FindData, 4, [varEmpty, varEmpty, varEmpty, varEmpty],\r\n varEmpty);\r\n AddGet(TCustomListView, 'GetItemAt', TCustomListView_GetItemAt, 2, [varEmpty, varEmpty], varEmpty);\r\n AddGet(TCustomListView, 'GetNearestItem', TCustomListView_GetNearestItem, 2, [varEmpty, varEmpty], varEmpty);\r\n AddGet(TCustomListView, 'GetNextItem', TCustomListView_GetNextItem, 3, [varEmpty, varEmpty, varEmpty], varEmpty);\r\n AddGet(TCustomListView, 'GetSearchString', TCustomListView_GetSearchString, 0, [varEmpty], varEmpty);\r\n AddGet(TCustomListView, 'IsEditing', TCustomListView_IsEditing, 0, [varEmpty], varEmpty);\r\n AddGet(TCustomListView, 'Scroll', TCustomListView_Scroll, 2, [varEmpty, varEmpty], varEmpty);\r\n AddGet(TCustomListView, 'Checkboxes', TCustomListView_Read_Checkboxes, 0, [varEmpty], varEmpty);\r\n AddSet(TCustomListView, 'Checkboxes', TCustomListView_Write_Checkboxes, 0, [varEmpty]);\r\n AddGet(TCustomListView, 'Column', TCustomListView_Read_Column, 1, [varEmpty], varEmpty);\r\n AddGet(TCustomListView, 'DropTarget', TCustomListView_Read_DropTarget, 0, [varEmpty], varEmpty);\r\n AddSet(TCustomListView, 'DropTarget', TCustomListView_Write_DropTarget, 0, [varEmpty]);\r\n AddGet(TCustomListView, 'GridLines', TCustomListView_Read_GridLines, 0, [varEmpty], varEmpty);\r\n AddSet(TCustomListView, 'GridLines', TCustomListView_Write_GridLines, 0, [varEmpty]);\r\n AddGet(TCustomListView, 'HotTrack', TCustomListView_Read_HotTrack, 0, [varEmpty], varEmpty);\r\n AddSet(TCustomListView, 'HotTrack', TCustomListView_Write_HotTrack, 0, [varEmpty]);\r\n AddGet(TCustomListView, 'ItemFocused', TCustomListView_Read_ItemFocused, 0, [varEmpty], varEmpty);\r\n AddSet(TCustomListView, 'ItemFocused', TCustomListView_Write_ItemFocused, 0, [varEmpty]);\r\n AddGet(TCustomListView, 'RowSelect', TCustomListView_Read_RowSelect, 0, [varEmpty], varEmpty);\r\n AddSet(TCustomListView, 'RowSelect', TCustomListView_Write_RowSelect, 0, [varEmpty]);\r\n AddGet(TCustomListView, 'SelCount', TCustomListView_Read_SelCount, 0, [varEmpty], varEmpty);\r\n AddGet(TCustomListView, 'Selected', TCustomListView_Read_Selected, 0, [varEmpty], varEmpty);\r\n AddSet(TCustomListView, 'Selected', TCustomListView_Write_Selected, 0, [varEmpty]);\r\n AddGet(TCustomListView, 'CustomSort', TCustomListView_CustomSort, 2, [varEmpty, varEmpty], varEmpty);\r\n AddGet(TCustomListView, 'StringWidth', TCustomListView_StringWidth, 1, [varEmpty], varEmpty);\r\n AddGet(TCustomListView, 'UpdateItems', TCustomListView_UpdateItems, 2, [varEmpty, varEmpty], varEmpty);\r\n AddGet(TCustomListView, 'TopItem', TCustomListView_Read_TopItem, 0, [varEmpty], varEmpty);\r\n AddGet(TCustomListView, 'ViewOrigin', TCustomListView_Read_ViewOrigin, 0, [varEmpty], varEmpty);\r\n AddGet(TCustomListView, 'VisibleRowCount', TCustomListView_Read_VisibleRowCount, 0, [varEmpty], varEmpty);\r\n AddGet(TCustomListView, 'BoundingRect', TCustomListView_Read_BoundingRect, 0, [varEmpty], varEmpty);\r\n { TListView }\r\n AddClass(cComCtrls, TListView, 'TListView');\r\n AddGet(TListView, 'Create', TListView_Create, 1, [varEmpty], varEmpty);\r\n { TCommonAVI }\r\n AddConst(cComCtrls, 'aviNone', Ord(aviNone));\r\n AddConst(cComCtrls, 'aviFindFolder', Ord(aviFindFolder));\r\n AddConst(cComCtrls, 'aviFindFile', Ord(aviFindFile));\r\n AddConst(cComCtrls, 'aviFindComputer', Ord(aviFindComputer));\r\n AddConst(cComCtrls, 'aviCopyFiles', Ord(aviCopyFiles));\r\n AddConst(cComCtrls, 'aviCopyFile', Ord(aviCopyFile));\r\n AddConst(cComCtrls, 'aviRecycleFile', Ord(aviRecycleFile));\r\n AddConst(cComCtrls, 'aviEmptyRecycle', Ord(aviEmptyRecycle));\r\n AddConst(cComCtrls, 'aviDeleteFile', Ord(aviDeleteFile));\r\n { TAnimate }\r\n AddClass(cComCtrls, TAnimate, 'TAnimate');\r\n AddGet(TAnimate, 'Create', TAnimate_Create, 1, [varEmpty], varEmpty);\r\n AddGet(TAnimate, 'FrameCount', TAnimate_Read_FrameCount, 0, [varEmpty], varEmpty);\r\n AddGet(TAnimate, 'FrameHeight', TAnimate_Read_FrameHeight, 0, [varEmpty], varEmpty);\r\n AddGet(TAnimate, 'FrameWidth', TAnimate_Read_FrameWidth, 0, [varEmpty], varEmpty);\r\n AddGet(TAnimate, 'Open', TAnimate_Read_Open, 0, [varEmpty], varEmpty);\r\n AddSet(TAnimate, 'Open', TAnimate_Write_Open, 0, [varEmpty]);\r\n AddGet(TAnimate, 'Play', TAnimate_Play, 3, [varEmpty, varEmpty, varEmpty], varEmpty);\r\n AddGet(TAnimate, 'Reset', TAnimate_Reset, 0, [varEmpty], varEmpty);\r\n AddGet(TAnimate, 'Seek', TAnimate_Seek, 1, [varEmpty], varEmpty);\r\n AddGet(TAnimate, 'Stop', TAnimate_Stop, 0, [varEmpty], varEmpty);\r\n AddGet(TAnimate, 'ResHandle', TAnimate_Read_ResHandle, 0, [varEmpty], varEmpty);\r\n AddSet(TAnimate, 'ResHandle', TAnimate_Write_ResHandle, 0, [varEmpty]);\r\n AddGet(TAnimate, 'ResId', TAnimate_Read_ResId, 0, [varEmpty], varEmpty);\r\n AddSet(TAnimate, 'ResId', TAnimate_Write_ResId, 0, [varEmpty]);\r\n AddGet(TAnimate, 'ResName', TAnimate_Read_ResName, 0, [varEmpty], varEmpty);\r\n AddSet(TAnimate, 'ResName', TAnimate_Write_ResName, 0, [varEmpty]);\r\n AddHandler(cComCtrls, 'TTabChangingEvent', TJvInterpreterComCtrlsEvent,\r\n @TJvInterpreterComCtrlsEvent.TabChangingEvent);\r\n AddHandler(cComCtrls, 'TDrawPanelEvent', TJvInterpreterComCtrlsEvent, @TJvInterpreterComCtrlsEvent.DrawPanelEvent);\r\n AddHandler(cComCtrls, 'TDrawSectionEvent', TJvInterpreterComCtrlsEvent,\r\n @TJvInterpreterComCtrlsEvent.DrawSectionEvent);\r\n AddHandler(cComCtrls, 'TSectionNotifyEvent', TJvInterpreterComCtrlsEvent,\r\n @TJvInterpreterComCtrlsEvent.SectionNotifyEvent);\r\n AddHandler(cComCtrls, 'TSectionTrackEvent', TJvInterpreterComCtrlsEvent,\r\n @TJvInterpreterComCtrlsEvent.SectionTrackEvent);\r\n AddHandler(cComCtrls, 'TTVChangingEvent', TJvInterpreterComCtrlsEvent,\r\n @TJvInterpreterComCtrlsEvent.TVChangingEvent);\r\n AddHandler(cComCtrls, 'TTVChangedEvent', TJvInterpreterComCtrlsEvent, @TJvInterpreterComCtrlsEvent.TVChangedEvent);\r\n AddHandler(cComCtrls, 'TTVEditingEvent', TJvInterpreterComCtrlsEvent, @TJvInterpreterComCtrlsEvent.TVEditingEvent);\r\n AddHandler(cComCtrls, 'TTVEditedEvent', TJvInterpreterComCtrlsEvent, @TJvInterpreterComCtrlsEvent.TVEditedEvent);\r\n AddHandler(cComCtrls, 'TTVExpandingEvent', TJvInterpreterComCtrlsEvent,\r\n @TJvInterpreterComCtrlsEvent.TVExpandingEvent);\r\n AddHandler(cComCtrls, 'TTVCollapsingEvent', TJvInterpreterComCtrlsEvent,\r\n @TJvInterpreterComCtrlsEvent.TVCollapsingEvent);\r\n AddHandler(cComCtrls, 'TTVExpandedEvent', TJvInterpreterComCtrlsEvent,\r\n @TJvInterpreterComCtrlsEvent.TVExpandedEvent);\r\n AddHandler(cComCtrls, 'TTVCompareEvent', TJvInterpreterComCtrlsEvent, @TJvInterpreterComCtrlsEvent.TVCompareEvent);\r\n AddHandler(cComCtrls, 'TRichEditResizeEvent', TJvInterpreterComCtrlsEvent,\r\n @TJvInterpreterComCtrlsEvent.RichEditResizeEvent);\r\n AddHandler(cComCtrls, 'TRichEditProtectChange', TJvInterpreterComCtrlsEvent,\r\n @TJvInterpreterComCtrlsEvent.RichEditProtectChange);\r\n AddHandler(cComCtrls, 'TRichEditSaveClipboard', TJvInterpreterComCtrlsEvent,\r\n @TJvInterpreterComCtrlsEvent.RichEditSaveClipboard);\r\n AddHandler(cComCtrls, 'TUDClickEvent', TJvInterpreterComCtrlsEvent, @TJvInterpreterComCtrlsEvent.UDClickEvent);\r\n AddHandler(cComCtrls, 'TUDChangingEvent', TJvInterpreterComCtrlsEvent,\r\n @TJvInterpreterComCtrlsEvent.UDChangingEvent);\r\n AddHandler(cComCtrls, 'TLVDeletedEvent', TJvInterpreterComCtrlsEvent, @TJvInterpreterComCtrlsEvent.LVDeletedEvent);\r\n AddHandler(cComCtrls, 'TLVEditingEvent', TJvInterpreterComCtrlsEvent, @TJvInterpreterComCtrlsEvent.LVEditingEvent);\r\n AddHandler(cComCtrls, 'TLVEditedEvent', TJvInterpreterComCtrlsEvent, @TJvInterpreterComCtrlsEvent.LVEditedEvent);\r\n AddHandler(cComCtrls, 'TLVChangeEvent', TJvInterpreterComCtrlsEvent, @TJvInterpreterComCtrlsEvent.LVChangeEvent);\r\n AddHandler(cComCtrls, 'TLVChangingEvent', TJvInterpreterComCtrlsEvent,\r\n @TJvInterpreterComCtrlsEvent.LVChangingEvent);\r\n AddHandler(cComCtrls, 'TLVColumnClickEvent', TJvInterpreterComCtrlsEvent,\r\n @TJvInterpreterComCtrlsEvent.LVColumnClickEvent);\r\n AddHandler(cComCtrls, 'TLVCompareEvent', TJvInterpreterComCtrlsEvent, @TJvInterpreterComCtrlsEvent.LVCompareEvent);\r\n end;\r\n RegisterClasses([TTabSheet, TPageControl, TStatusPanel, TStatusPanels,\r\n TStatusBar, THeaderSection, THeaderSections, THeaderControl, TTreeNode,\r\n TTreeNodes, TTreeView, TTrackBar, TProgressBar, TTextAttributes,\r\n TParaAttributes, TRichEdit, TUpDown, THotKey, TListColumn, TListColumns,\r\n TListItem, TListItems, TListView , TAnimate]);\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvInterpreter_Contnrs.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvInterpreter_Contnrs.PAS, released on 2002-07-04.\r\n\r\nThe Initial Developers of the Original Code are: Andrei Prygounkov \r\nCopyright (c) 1999, 2002 Andrei Prygounkov\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nDescription : adapter unit - converts JvInterpreter calls to delphi calls\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvInterpreter_Contnrs.pas 12461 2009-08-14 17:21:33Z obones $\r\n\r\nunit JvInterpreter_Contnrs;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n JvInterpreter;\r\n\r\nprocedure RegisterJvInterpreterAdapter(JvInterpreterAdapter: TJvInterpreterAdapter);\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvInterpreter_Contnrs.pas $';\r\n Revision: '$Revision: 12461 $';\r\n Date: '$Date: 2009-08-14 19:21:33 +0200 (ven. 14 août 2009) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n Classes, Contnrs;\r\n\r\n{ TObjectList }\r\n\r\n{ constructor Create }\r\n\r\nprocedure TObjectList_Create(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TObjectList.Create);\r\nend;\r\n\r\n{ constructor Create(AOwnsObjects: Boolean) }\r\n\r\nprocedure TObjectList_CreateOwns(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TObjectList.Create(Args.Values[0]));\r\nend;\r\n\r\n{ function Add(AObject: TObject): Integer; }\r\n\r\nprocedure TObjectList_Add(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TObjectList(Args.Obj).Add(V2O(Args.Values[0]));\r\nend;\r\n\r\n{ function Remove(AObject: TObject): Integer; }\r\n\r\nprocedure TObjectList_Remove(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TObjectList(Args.Obj).Remove(V2O(Args.Values[0]));\r\nend;\r\n\r\n{ function IndexOf(AObject: TObject): Integer; }\r\n\r\nprocedure TObjectList_IndexOf(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TObjectList(Args.Obj).IndexOf(V2O(Args.Values[0]));\r\nend;\r\n\r\n{ function FindInstanceOf(AClass: TClass; AExact: Boolean = True; AStartAt: Integer = 0): Integer; }\r\n\r\nprocedure TObjectList_FindInstanceOf(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TObjectList(Args.Obj).FindInstanceOf(V2C(Args.Values[0]), Args.Values[1], Args.Values[2]);\r\nend;\r\n\r\n{ procedure Insert(Index: Integer; AObject: TObject); }\r\n\r\nprocedure TObjectList_Insert(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TObjectList(Args.Obj).Insert(Args.Values[0], V2O(Args.Values[1]));\r\nend;\r\n\r\n{ property Read OwnsObjects: Boolean }\r\n\r\nprocedure TObjectList_Read_OwnsObjects(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TObjectList(Args.Obj).OwnsObjects;\r\nend;\r\n\r\n{ property Write OwnsObjects(Value: Boolean) }\r\n\r\nprocedure TObjectList_Write_OwnsObjects(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TObjectList(Args.Obj).OwnsObjects := Value;\r\nend;\r\n\r\n{ property Read Items[Integer]: TObject }\r\n\r\nprocedure TObjectList_Read_Items(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TObjectList(Args.Obj).Items[Args.Values[0]]);\r\nend;\r\n\r\n{ property Write Items[Integer]: TObject }\r\n\r\nprocedure TObjectList_Write_Items(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TObjectList(Args.Obj).Items[Args.Values[0]] := V2O(Value);\r\nend;\r\n\r\n{ TComponentList }\r\n\r\n{ function Add(AComponent: TComponent): Integer; }\r\n\r\nprocedure TComponentList_Add(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TComponentList(Args.Obj).Add(V2O(Args.Values[0]) as TComponent);\r\nend;\r\n\r\n{ function Remove(AComponent: TComponent): Integer; }\r\n\r\nprocedure TComponentList_Remove(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TComponentList(Args.Obj).Remove(V2O(Args.Values[0]) as TComponent);\r\nend;\r\n\r\n{ function IndexOf(AComponent: TComponent): Integer; }\r\n\r\nprocedure TComponentList_IndexOf(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TComponentList(Args.Obj).IndexOf(V2O(Args.Values[0]) as TComponent);\r\nend;\r\n\r\n{ procedure Insert(Index: Integer; AComponent: TComponent); }\r\n\r\nprocedure TComponentList_Insert(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TComponentList(Args.Obj).Insert(Args.Values[0], V2O(Args.Values[1]) as TComponent);\r\nend;\r\n\r\n{ property Read Items[Integer]: TComponent }\r\n\r\nprocedure TComponentList_Read_Items(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TComponentList(Args.Obj).Items[Args.Values[0]]);\r\nend;\r\n\r\n{ property Write Items[Integer]: TComponent }\r\n\r\nprocedure TComponentList_Write_Items(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TComponentList(Args.Obj).Items[Args.Values[0]] := V2O(Value) as TComponent;\r\nend;\r\n\r\n{ TClassList }\r\n\r\n{ function Add(aClass: TClass): Integer; }\r\n\r\nprocedure TClassList_Add(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TClassList(Args.Obj).Add(V2C(Args.Values[0]));\r\nend;\r\n\r\n{ function Remove(aClass: TClass): Integer; }\r\n\r\nprocedure TClassList_Remove(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TClassList(Args.Obj).Remove(V2C(Args.Values[0]));\r\nend;\r\n\r\n{ function IndexOf(aClass: TClass): Integer; }\r\n\r\nprocedure TClassList_IndexOf(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TClassList(Args.Obj).IndexOf(V2C(Args.Values[0]));\r\nend;\r\n\r\n{ procedure Insert(Index: Integer; aClass: TClass); }\r\n\r\nprocedure TClassList_Insert(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TClassList(Args.Obj).Insert(Args.Values[0], V2C(Args.Values[1]));\r\nend;\r\n\r\n{ property Read Items[Integer]: TClass }\r\n\r\nprocedure TClassList_Read_Items(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := C2V(TClassList(Args.Obj).Items[Args.Values[0]]);\r\nend;\r\n\r\n{ property Write Items[Integer]: TClass }\r\n\r\nprocedure TClassList_Write_Items(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TClassList(Args.Obj).Items[Args.Values[0]] := V2C(Value);\r\nend;\r\n\r\n{ TOrderedList }\r\n\r\n{ function Count: Integer; }\r\n\r\nprocedure TOrderedList_Count(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TOrderedList(Args.Obj).Count;\r\nend;\r\n\r\n{ function AtLeast(ACount: Integer): Boolean; }\r\n\r\nprocedure TOrderedList_AtLeast(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TOrderedList(Args.Obj).AtLeast(Args.Values[0]);\r\nend;\r\n\r\n{ procedure Push(AItem: Pointer); }\r\n\r\nprocedure TOrderedList_Push(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TOrderedList(Args.Obj).Push(V2P(Args.Values[0]));\r\nend;\r\n\r\n{ function Pop: Pointer; }\r\n\r\nprocedure TOrderedList_Pop(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := P2V(TOrderedList(Args.Obj).Pop);\r\nend;\r\n\r\n{ function Peek: Pointer; }\r\n\r\nprocedure TOrderedList_Peek(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := P2V(TOrderedList(Args.Obj).Peek);\r\nend;\r\n\r\n{ TStack }\r\n\r\n{ TObjectStack }\r\n\r\n{ procedure Push(AObject: TObject); }\r\n\r\nprocedure TObjectStack_Push(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TObjectStack(Args.Obj).Push(V2O(Args.Values[0]));\r\nend;\r\n\r\n{ function Pop: TObject; }\r\n\r\nprocedure TObjectStack_Pop(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TObjectStack(Args.Obj).Pop);\r\nend;\r\n\r\n{ function Peek: TObject; }\r\n\r\nprocedure TObjectStack_Peek(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TObjectStack(Args.Obj).Peek);\r\nend;\r\n\r\n{ TQueue }\r\n\r\n{ TObjectQueue }\r\n\r\n{ procedure Push(AObject: TObject); }\r\n\r\nprocedure TObjectQueue_Push(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TObjectQueue(Args.Obj).Push(V2O(Args.Values[0]));\r\nend;\r\n\r\n{ function Pop: TObject; }\r\n\r\nprocedure TObjectQueue_Pop(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TObjectQueue(Args.Obj).Pop);\r\nend;\r\n\r\n{ function Peek: TObject; }\r\n\r\nprocedure TObjectQueue_Peek(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TObjectQueue(Args.Obj).Peek);\r\nend;\r\n\r\nprocedure RegisterJvInterpreterAdapter(JvInterpreterAdapter: TJvInterpreterAdapter);\r\nconst\r\n cContnrs = 'Contnrs';\r\nbegin\r\n with JvInterpreterAdapter do\r\n begin\r\n { TObjectList }\r\n AddClass(cContnrs, TObjectList, 'TObjectList');\r\n AddGet(TObjectList, 'Create', TObjectList_Create, 0, [varEmpty], varEmpty);\r\n AddGet(TObjectList, 'CreateOwns', TObjectList_CreateOwns, 1, [varBoolean], varEmpty);\r\n AddGet(TObjectList, 'Add', TObjectList_Add, 1, [varObject], varEmpty);\r\n AddGet(TObjectList, 'Remove', TObjectList_Remove, 1, [varObject], varEmpty);\r\n AddGet(TObjectList, 'IndexOf', TObjectList_IndexOf, 1, [varObject], varEmpty);\r\n AddGet(TObjectList, 'FindInstanceOf', TObjectList_FindInstanceOf, 3, [varEmpty, varBoolean, varInteger], varEmpty);\r\n AddGet(TObjectList, 'Insert', TObjectList_Insert, 2, [varInteger, varObject], varEmpty);\r\n AddGet(TObjectList, 'OwnsObjects', TObjectList_Read_OwnsObjects, 0, [varEmpty], varEmpty);\r\n AddSet(TObjectList, 'OwnsObjects', TObjectList_Write_OwnsObjects, 0, [varEmpty]);\r\n AddGet(TObjectList, 'Items', TObjectList_Read_Items, 1, [varEmpty], varEmpty);\r\n AddSet(TObjectList, 'Items', TObjectList_Write_Items, 1, [varNull]);\r\n { TComponentList }\r\n AddClass(cContnrs, TComponentList, 'TComponentList');\r\n AddGet(TComponentList, 'Add', TComponentList_Add, 1, [varObject], varEmpty);\r\n AddGet(TComponentList, 'Remove', TComponentList_Remove, 1, [varObject], varEmpty);\r\n AddGet(TComponentList, 'IndexOf', TComponentList_IndexOf, 1, [varObject], varEmpty);\r\n AddGet(TComponentList, 'Insert', TComponentList_Insert, 2, [varInteger, varObject], varEmpty);\r\n AddGet(TComponentList, 'Items', TComponentList_Read_Items, 1, [varEmpty], varEmpty);\r\n AddSet(TComponentList, 'Items', TComponentList_Write_Items, 1, [varNull]);\r\n { TClassList }\r\n AddClass(cContnrs, TClassList, 'TClassList');\r\n AddGet(TClassList, 'Add', TClassList_Add, 1, [varEmpty], varEmpty);\r\n AddGet(TClassList, 'Remove', TClassList_Remove, 1, [varEmpty], varEmpty);\r\n AddGet(TClassList, 'IndexOf', TClassList_IndexOf, 1, [varEmpty], varEmpty);\r\n AddGet(TClassList, 'Insert', TClassList_Insert, 2, [varInteger, varEmpty], varEmpty);\r\n AddGet(TClassList, 'Items', TClassList_Read_Items, 1, [varEmpty], varEmpty);\r\n AddSet(TClassList, 'Items', TClassList_Write_Items, 1, [varNull]);\r\n { TOrderedList }\r\n AddClass(cContnrs, TOrderedList, 'TOrderedList');\r\n AddGet(TOrderedList, 'Count', TOrderedList_Count, 0, [varEmpty], varEmpty);\r\n AddGet(TOrderedList, 'AtLeast', TOrderedList_AtLeast, 1, [varInteger], varEmpty);\r\n AddGet(TOrderedList, 'Push', TOrderedList_Push, 1, [varPointer], varEmpty);\r\n AddGet(TOrderedList, 'Pop', TOrderedList_Pop, 0, [varEmpty], varEmpty);\r\n AddGet(TOrderedList, 'Peek', TOrderedList_Peek, 0, [varEmpty], varEmpty);\r\n { TStack }\r\n AddClass(cContnrs, TStack, 'TStack');\r\n { TObjectStack }\r\n AddClass(cContnrs, TObjectStack, 'TObjectStack');\r\n AddGet(TObjectStack, 'Push', TObjectStack_Push, 1, [varObject], varEmpty);\r\n AddGet(TObjectStack, 'Pop', TObjectStack_Pop, 0, [varEmpty], varEmpty);\r\n AddGet(TObjectStack, 'Peek', TObjectStack_Peek, 0, [varEmpty], varEmpty);\r\n { TQueue }\r\n AddClass(cContnrs, TQueue, 'TQueue');\r\n { TObjectQueue }\r\n AddClass(cContnrs, TObjectQueue, 'TObjectQueue');\r\n AddGet(TObjectQueue, 'Push', TObjectQueue_Push, 1, [varObject], varEmpty);\r\n AddGet(TObjectQueue, 'Pop', TObjectQueue_Pop, 0, [varEmpty], varEmpty);\r\n AddGet(TObjectQueue, 'Peek', TObjectQueue_Peek, 0, [varEmpty], varEmpty);\r\n end;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvInterpreter_Controls.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvInterpreter_Controls.PAS, released on 2002-07-04.\r\n\r\nThe Initial Developers of the Original Code are: Andrei Prygounkov \r\nCopyright (c) 1999, 2002 Andrei Prygounkov\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nDescription : adapter unit - converts JvInterpreter calls to delphi calls\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvInterpreter_Controls.pas 13173 2011-11-19 12:43:58Z ahuser $\r\n\r\nunit JvInterpreter_Controls;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n JvInterpreter;\r\n\r\nprocedure RegisterJvInterpreterAdapter(JvInterpreterAdapter: TJvInterpreterAdapter);\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvInterpreter_Controls.pas $';\r\n Revision: '$Revision: 13173 $';\r\n Date: '$Date: 2011-11-19 13:43:58 +0100 (sam. 19 nov. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n Classes,\r\n Graphics, Controls, Menus, ImgList,\r\n JvInterpreter_Windows;\r\n\r\n{ TControl }\r\n\r\n{ constructor Create(AOwner: TComponent) }\r\n\r\nprocedure TControl_Create(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TControl.Create(V2O(Args.Values[0]) as TComponent));\r\nend;\r\n\r\n{ procedure BeginDrag(Immediate: Boolean); }\r\n\r\nprocedure TControl_BeginDrag(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TControl(Args.Obj).BeginDrag(Args.Values[0]);\r\nend;\r\n\r\n{ procedure BringToFront; }\r\n\r\nprocedure TControl_BringToFront(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TControl(Args.Obj).BringToFront;\r\nend;\r\n\r\n{ function ClientToScreen(const Point: TPoint): TPoint; }\r\n\r\nprocedure TControl_ClientToScreen(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n JvInterpreterVarCopy(Value, Point2Var(TControl(Args.Obj).ClientToScreen(Var2Point(Args.Values[0]))));\r\nend;\r\n\r\n{ function Dragging: Boolean; }\r\n\r\nprocedure TControl_Dragging(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TControl(Args.Obj).Dragging;\r\nend;\r\n\r\n{ procedure DragDrop(Source: TObject; X, Y: Integer); }\r\n\r\nprocedure TControl_DragDrop(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TControl(Args.Obj).DragDrop(V2O(Args.Values[0]), Args.Values[1], Args.Values[2]);\r\nend;\r\n\r\n{ procedure EndDrag(Drop: Boolean); }\r\n\r\nprocedure TControl_EndDrag(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TControl(Args.Obj).EndDrag(Args.Values[0]);\r\nend;\r\n\r\n\r\n\r\n{ function GetTextBuf(Buffer: PChar; BufSize: Integer): Integer; }\r\n\r\nprocedure TControl_GetTextBuf(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TControl(Args.Obj).GetTextBuf(PChar(string(Args.Values[0])), Args.Values[1]);\r\nend;\r\n\r\n{ function GetTextLen: Integer; }\r\n\r\nprocedure TControl_GetTextLen(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TControl(Args.Obj).GetTextLen;\r\nend;\r\n\r\n\r\n\r\n{ procedure Hide; }\r\n\r\nprocedure TControl_Hide(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TControl(Args.Obj).Hide;\r\nend;\r\n\r\n{ procedure Invalidate; }\r\n\r\nprocedure TControl_Invalidate(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TControl(Args.Obj).Invalidate;\r\nend;\r\n\r\n{ function Perform(Msg: Cardinal; WParam, LParam: Longint): Longint; }\r\n\r\n\r\nprocedure TControl_Perform(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TControl(Args.Obj).Perform(Args.Values[0], Args.Values[1], Args.Values[2]);\r\nend;\r\n\r\n\r\n{ procedure Refresh; }\r\n\r\nprocedure TControl_Refresh(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TControl(Args.Obj).Refresh;\r\nend;\r\n\r\n{ procedure Repaint; }\r\n\r\nprocedure TControl_Repaint(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TControl(Args.Obj).Repaint;\r\nend;\r\n\r\n{ function ScreenToClient(const Point: TPoint): TPoint; }\r\n\r\nprocedure TControl_ScreenToClient(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n JvInterpreterVarCopy(Value, Point2Var(TControl(Args.Obj).ScreenToClient(Var2Point(Args.Values[0]))));\r\nend;\r\n\r\n{ procedure SendToBack; }\r\n\r\nprocedure TControl_SendToBack(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TControl(Args.Obj).SendToBack;\r\nend;\r\n\r\n{ procedure SetBounds(ALeft, ATop, AWidth, AHeight: Integer); }\r\n\r\nprocedure TControl_SetBounds(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TControl(Args.Obj).SetBounds(Args.Values[0], Args.Values[1], Args.Values[2], Args.Values[3]);\r\nend;\r\n\r\n{ procedure SetTextBuf(Buffer: PChar); }\r\n\r\n\r\nprocedure TControl_SetTextBuf(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TControl(Args.Obj).SetTextBuf(PChar(string(Args.Values[0])));\r\nend;\r\n\r\n\r\n{ procedure Show; }\r\n\r\nprocedure TControl_Show(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TControl(Args.Obj).Show;\r\nend;\r\n\r\n{ procedure Update; }\r\n\r\nprocedure TControl_Update(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TControl(Args.Obj).Update;\r\nend;\r\n\r\n{ property Read Align: TAlign }\r\n\r\nprocedure TControl_Read_Align(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TControl(Args.Obj).Align;\r\nend;\r\n\r\n{ property Write Align(Value: TAlign) }\r\n\r\nprocedure TControl_Write_Align(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TControl(Args.Obj).Align := Value;\r\nend;\r\n\r\n{ property Read BoundsRect: TRect }\r\n\r\nprocedure TControl_Read_BoundsRect(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n JvInterpreterVarCopy(Value, Rect2Var(TControl(Args.Obj).BoundsRect));\r\nend;\r\n\r\n{ property Write BoundsRect(Value: TRect) }\r\n\r\nprocedure TControl_Write_BoundsRect(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TControl(Args.Obj).BoundsRect := Var2Rect(Value);\r\nend;\r\n\r\n{ property Read ClientHeight: Integer }\r\n\r\nprocedure TControl_Read_ClientHeight(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TControl(Args.Obj).ClientHeight;\r\nend;\r\n\r\n{ property Write ClientHeight(Value: Integer) }\r\n\r\nprocedure TControl_Write_ClientHeight(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TControl(Args.Obj).ClientHeight := Value;\r\nend;\r\n\r\n{ property Read ClientOrigin: TPoint }\r\n\r\nprocedure TControl_Read_ClientOrigin(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n JvInterpreterVarCopy(Value, Point2Var(TControl(Args.Obj).ClientOrigin));\r\nend;\r\n\r\n{ property Read ClientRect: TRect }\r\n\r\nprocedure TControl_Read_ClientRect(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n// Value := TControl(Args.Obj).ClientRect;\r\n NotImplemented('TControl.ClientRect');\r\nend;\r\n\r\n{ property Read ClientWidth: Integer }\r\n\r\nprocedure TControl_Read_ClientWidth(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TControl(Args.Obj).ClientWidth;\r\nend;\r\n\r\n{ property Write ClientWidth(Value: Integer) }\r\n\r\nprocedure TControl_Write_ClientWidth(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TControl(Args.Obj).ClientWidth := Value;\r\nend;\r\n\r\n{ property Read ControlState: TControlState }\r\n\r\nprocedure TControl_Read_ControlState(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n// Value := TControl(Args.Obj).ControlState;\r\n NotImplemented('TControl.ControlState');\r\nend;\r\n\r\n{ property Write ControlState(Value: TControlState) }\r\n\r\nprocedure TControl_Write_ControlState(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n// TControl(Args.Obj).ControlState := Value;\r\n NotImplemented('TControl.ControlState');\r\nend;\r\n\r\n{ property Read ControlStyle: TControlStyle }\r\n\r\nprocedure TControl_Read_ControlStyle(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n// Value := TControl(Args.Obj).ControlStyle;\r\n NotImplemented('TControl.ControlState');\r\nend;\r\n\r\n{ property Write ControlStyle(Value: TControlStyle) }\r\n\r\nprocedure TControl_Write_ControlStyle(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n// TControl(Args.Obj).ControlStyle := Value;\r\n NotImplemented('TControl.ControlStyle');\r\nend;\r\n\r\n{ property Read Parent: TWinControl }\r\n\r\nprocedure TControl_Read_Parent(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TControl(Args.Obj).Parent);\r\nend;\r\n\r\n{ property Write Parent(Value: TWinControl) }\r\n\r\nprocedure TControl_Write_Parent(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TControl(Args.Obj).Parent := V2O(Value) as TWinControl;\r\nend;\r\n\r\n{ property Read ShowHint: Boolean }\r\n\r\nprocedure TControl_Read_ShowHint(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TControl(Args.Obj).ShowHint;\r\nend;\r\n\r\n{ property Write ShowHint(Value: Boolean) }\r\n\r\nprocedure TControl_Write_ShowHint(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TControl(Args.Obj).ShowHint := Value;\r\nend;\r\n\r\n{ property Read Visible: Boolean }\r\n\r\nprocedure TControl_Read_Visible(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TControl(Args.Obj).Visible;\r\nend;\r\n\r\n{ property Write Visible(Value: Boolean) }\r\n\r\nprocedure TControl_Write_Visible(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TControl(Args.Obj).Visible := Value;\r\nend;\r\n\r\n{ property Read Enabled: Boolean }\r\n\r\nprocedure TControl_Read_Enabled(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TControl(Args.Obj).Enabled;\r\nend;\r\n\r\n{ property Write Enabled(Value: Boolean) }\r\n\r\nprocedure TControl_Write_Enabled(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TControl(Args.Obj).Enabled := Value;\r\nend;\r\n\r\n{ property Read WindowProc: TWndMethod }\r\n\r\nprocedure TControl_Read_WindowProc(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n// Value := TControl(Args.Obj).WindowProc;\r\n NotImplemented('TControl.WindowProc');\r\nend;\r\n\r\n{ property Write WindowProc(Value: TWndMethod) }\r\n\r\nprocedure TControl_Write_WindowProc(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n// TControl(Args.Obj).WindowProc := Value;\r\n NotImplemented('TControl.WindowProc');\r\nend;\r\n\r\n{ property Read Left: Integer }\r\n\r\nprocedure TControl_Read_Left(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TControl(Args.Obj).Left;\r\nend;\r\n\r\n{ property Write Left(Value: Integer) }\r\n\r\nprocedure TControl_Write_Left(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TControl(Args.Obj).Left := Value;\r\nend;\r\n\r\n{ property Read Top: Integer }\r\n\r\nprocedure TControl_Read_Top(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TControl(Args.Obj).Top;\r\nend;\r\n\r\n{ property Write Top(Value: Integer) }\r\n\r\nprocedure TControl_Write_Top(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TControl(Args.Obj).Top := Value;\r\nend;\r\n\r\n{ property Read Width: Integer }\r\n\r\nprocedure TControl_Read_Width(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TControl(Args.Obj).Width;\r\nend;\r\n\r\n{ property Write Width(Value: Integer) }\r\n\r\nprocedure TControl_Write_Width(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TControl(Args.Obj).Width := Value;\r\nend;\r\n\r\n{ property Read Height: Integer }\r\n\r\nprocedure TControl_Read_Height(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TControl(Args.Obj).Height;\r\nend;\r\n\r\n{ property Write Height(Value: Integer) }\r\n\r\nprocedure TControl_Write_Height(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TControl(Args.Obj).Height := Value;\r\nend;\r\n\r\n{ property Read Cursor: TCursor }\r\n\r\nprocedure TControl_Read_Cursor(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TControl(Args.Obj).Cursor;\r\nend;\r\n\r\n{ property Write Cursor(Value: TCursor) }\r\n\r\nprocedure TControl_Write_Cursor(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TControl(Args.Obj).Cursor := Value;\r\nend;\r\n\r\n{ property Read Hint: string }\r\n\r\nprocedure TControl_Read_Hint(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TControl(Args.Obj).Hint;\r\nend;\r\n\r\n{ property Write Hint(Value: string) }\r\n\r\nprocedure TControl_Write_Hint(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TControl(Args.Obj).Hint := Value;\r\nend;\r\n\r\n{ TWinControl }\r\n\r\n{ constructor Create(AOwner: TComponent) }\r\n\r\nprocedure TWinControl_Create(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TWinControl.Create(V2O(Args.Values[0]) as TComponent));\r\nend;\r\n\r\n{ constructor CreateParented(ParentWindow: HWnd) }\r\n\r\nprocedure TWinControl_CreateParented(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TWinControl.CreateParented(Args.Values[0]));\r\nend;\r\n\r\n{ procedure Broadcast(var Message); }\r\n\r\nprocedure TWinControl_Broadcast(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TWinControl(Args.Obj).Broadcast(Args.Values[0]);\r\nend;\r\n\r\n{ function CanFocus: Boolean; }\r\n\r\nprocedure TWinControl_CanFocus(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TWinControl(Args.Obj).CanFocus;\r\nend;\r\n\r\n{ function ContainsControl(Control: TControl): Boolean; }\r\n\r\nprocedure TWinControl_ContainsControl(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TWinControl(Args.Obj).ContainsControl(V2O(Args.Values[0]) as TControl);\r\nend;\r\n\r\n{ function ControlAtPos(const Pos: TPoint; AllowDisabled: Boolean): TControl; }\r\n\r\nprocedure TWinControl_ControlAtPos(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TWinControl(Args.Obj).ControlAtPos(Var2Point(Args.Values[0]), Args.Values[1]));\r\nend;\r\n\r\n{ procedure DisableAlign; }\r\n\r\nprocedure TWinControl_DisableAlign(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TWinControl(Args.Obj).DisableAlign;\r\nend;\r\n\r\n{ procedure EnableAlign; }\r\n\r\nprocedure TWinControl_EnableAlign(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TWinControl(Args.Obj).EnableAlign;\r\nend;\r\n\r\n{ function Focused: Boolean; }\r\n\r\nprocedure TWinControl_Focused(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TWinControl(Args.Obj).Focused;\r\nend;\r\n\r\n{ procedure GetTabOrderList(List: TList); }\r\n\r\nprocedure TWinControl_GetTabOrderList(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TWinControl(Args.Obj).GetTabOrderList(V2O(Args.Values[0]) as TList);\r\nend;\r\n\r\n{ function HandleAllocated: Boolean; }\r\n\r\nprocedure TWinControl_HandleAllocated(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TWinControl(Args.Obj).HandleAllocated;\r\nend;\r\n\r\n{ procedure HandleNeeded; }\r\n\r\nprocedure TWinControl_HandleNeeded(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TWinControl(Args.Obj).HandleNeeded;\r\nend;\r\n\r\n{ procedure InsertControl(AControl: TControl); }\r\n\r\nprocedure TWinControl_InsertControl(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TWinControl(Args.Obj).InsertControl(V2O(Args.Values[0]) as TControl);\r\nend;\r\n\r\n{ procedure Invalidate; }\r\n\r\nprocedure TWinControl_Invalidate(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TWinControl(Args.Obj).Invalidate;\r\nend;\r\n\r\n{ procedure PaintTo(DC: HDC; X, Y: Integer); }\r\n\r\n\r\nprocedure TWinControl_PaintTo(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TWinControl(Args.Obj).PaintTo(Args.Values[0], Args.Values[1], Args.Values[2]);\r\nend;\r\n\r\n\r\n{ procedure RemoveControl(AControl: TControl); }\r\n\r\nprocedure TWinControl_RemoveControl(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TWinControl(Args.Obj).RemoveControl(V2O(Args.Values[0]) as TControl);\r\nend;\r\n\r\n{ procedure Realign; }\r\n\r\nprocedure TWinControl_Realign(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TWinControl(Args.Obj).Realign;\r\nend;\r\n\r\n{ procedure Repaint; }\r\n\r\nprocedure TWinControl_Repaint(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TWinControl(Args.Obj).Repaint;\r\nend;\r\n\r\n{ procedure ScaleBy(M, D: Integer); }\r\n\r\nprocedure TWinControl_ScaleBy(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TWinControl(Args.Obj).ScaleBy(Args.Values[0], Args.Values[1]);\r\nend;\r\n\r\n{ procedure ScrollBy(DeltaX, DeltaY: Integer); }\r\n\r\nprocedure TWinControl_ScrollBy(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TWinControl(Args.Obj).ScrollBy(Args.Values[0], Args.Values[1]);\r\nend;\r\n\r\n{ procedure SetBounds(ALeft, ATop, AWidth, AHeight: Integer); }\r\n\r\nprocedure TWinControl_SetBounds(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TWinControl(Args.Obj).SetBounds(Args.Values[0], Args.Values[1], Args.Values[2], Args.Values[3]);\r\nend;\r\n\r\n{ procedure SetFocus; }\r\n\r\nprocedure TWinControl_SetFocus(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TWinControl(Args.Obj).SetFocus;\r\nend;\r\n\r\n{ procedure Update; }\r\n\r\nprocedure TWinControl_Update(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TWinControl(Args.Obj).Update;\r\nend;\r\n\r\n{ procedure UpdateControlState; }\r\n\r\nprocedure TWinControl_UpdateControlState(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TWinControl(Args.Obj).UpdateControlState;\r\nend;\r\n\r\n{ property Read Brush: TBrush }\r\n\r\nprocedure TWinControl_Read_Brush(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TWinControl(Args.Obj).Brush);\r\nend;\r\n\r\n{ property Read Controls[Integer]: TControl }\r\n\r\nprocedure TWinControl_Read_Controls(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TWinControl(Args.Obj).Controls[Args.Values[0]]);\r\nend;\r\n\r\n{ property Read ControlCount: Integer }\r\n\r\nprocedure TWinControl_Read_ControlCount(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TWinControl(Args.Obj).ControlCount;\r\nend;\r\n\r\n{ property Read Handle: HWnd }\r\n\r\nprocedure TWinControl_Read_Handle(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := NativeInt(TWinControl(Args.Obj).Handle);\r\nend;\r\n\r\n{ property Read ParentWindow: HWnd }\r\n\r\nprocedure TWinControl_Read_ParentWindow(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := NativeInt(TWinControl(Args.Obj).ParentWindow);\r\nend;\r\n\r\n{ property Write ParentWindow(Value: HWnd) }\r\n\r\nprocedure TWinControl_Write_ParentWindow(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TWinControl(Args.Obj).ParentWindow := Value;\r\nend;\r\n\r\n{ property Read Showing: Boolean }\r\n\r\nprocedure TWinControl_Read_Showing(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TWinControl(Args.Obj).Showing;\r\nend;\r\n\r\n{ property Read TabOrder: TTabOrder }\r\n\r\nprocedure TWinControl_Read_TabOrder(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TWinControl(Args.Obj).TabOrder;\r\nend;\r\n\r\n{ property Write TabOrder(Value: TTabOrder) }\r\n\r\nprocedure TWinControl_Write_TabOrder(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TWinControl(Args.Obj).TabOrder := Value;\r\nend;\r\n\r\n{ property Read TabStop: Boolean }\r\n\r\nprocedure TWinControl_Read_TabStop(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TWinControl(Args.Obj).TabStop;\r\nend;\r\n\r\n{ property Write TabStop(Value: Boolean) }\r\n\r\nprocedure TWinControl_Write_TabStop(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TWinControl(Args.Obj).TabStop := Value;\r\nend;\r\n\r\n{ property Read HelpContext: THelpContext }\r\n\r\nprocedure TWinControl_Read_HelpContext(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TWinControl(Args.Obj).HelpContext;\r\nend;\r\n\r\n{ property Write HelpContext(Value: THelpContext) }\r\n\r\nprocedure TWinControl_Write_HelpContext(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TWinControl(Args.Obj).HelpContext := Value;\r\nend;\r\n\r\n{ TGraphicControl }\r\n\r\n{ constructor Create(AOwner: TComponent) }\r\n\r\nprocedure TGraphicControl_Create(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TGraphicControl.Create(V2O(Args.Values[0]) as TComponent));\r\nend;\r\n\r\n{ TCustomControl }\r\n\r\n{ constructor Create(AOwner: TComponent) }\r\n\r\nprocedure TCustomControl_Create(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TCustomControl.Create(V2O(Args.Values[0]) as TComponent));\r\nend;\r\n\r\n{ TCustomImageList }\r\n\r\n{ constructor Create(AOwner: TComponent) }\r\n\r\nprocedure TCustomImageList_Create(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TCustomImageList.Create(V2O(Args.Values[0]) as TComponent));\r\nend;\r\n\r\n{ constructor CreateSize(AWidth: Integer; AHeight: Integer) }\r\n\r\nprocedure TCustomImageList_CreateSize(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TCustomImageList.CreateSize(Args.Values[0], Args.Values[1]));\r\nend;\r\n\r\n{ procedure Assign(Source: TPersistent); }\r\n\r\nprocedure TCustomImageList_Assign(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TCustomImageList(Args.Obj).Assign(V2O(Args.Values[0]) as TPersistent);\r\nend;\r\n\r\n{ function Add(Image, Mask: TBitmap): Integer; }\r\n\r\nprocedure TCustomImageList_Add(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TCustomImageList(Args.Obj).Add(V2O(Args.Values[0]) as TBitmap, V2O(Args.Values[1]) as TBitmap);\r\nend;\r\n\r\n{ function AddIcon(Image: TIcon): Integer; }\r\n\r\n\r\nprocedure TCustomImageList_AddIcon(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TCustomImageList(Args.Obj).AddIcon(V2O(Args.Values[0]) as TIcon);\r\nend;\r\n\r\n\r\n{ procedure AddImages(Value: TCustomImageList); }\r\n\r\nprocedure TCustomImageList_AddImages(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TCustomImageList(Args.Obj).AddImages(V2O(Args.Values[0]) as TCustomImageList);\r\nend;\r\n\r\n{ function AddMasked(Image: TBitmap; MaskColor: TColor): Integer; }\r\n\r\nprocedure TCustomImageList_AddMasked(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TCustomImageList(Args.Obj).AddMasked(V2O(Args.Values[0]) as TBitmap, Args.Values[1]);\r\nend;\r\n\r\n{ procedure Clear; }\r\n\r\nprocedure TCustomImageList_Clear(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TCustomImageList(Args.Obj).Clear;\r\nend;\r\n\r\n{ procedure Delete(Index: Integer); }\r\n\r\nprocedure TCustomImageList_Delete(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TCustomImageList(Args.Obj).Delete(Args.Values[0]);\r\nend;\r\n\r\n{ procedure Draw(Canvas: TCanvas; X, Y, Index: Integer); }\r\n\r\nprocedure TCustomImageList_Draw(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TCustomImageList(Args.Obj).Draw(V2O(Args.Values[0]) as TCanvas, Args.Values[1], Args.Values[2], Args.Values[3]);\r\nend;\r\n\r\n\r\n\r\n{ procedure DrawOverlay(Canvas: TCanvas; X, Y: Integer; ImageIndex: Integer; Overlay: TOverlay); }\r\n\r\nprocedure TCustomImageList_DrawOverlay(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TCustomImageList(Args.Obj).DrawOverlay(V2O(Args.Values[0]) as TCanvas, Args.Values[1], Args.Values[2], Args.Values[3],\r\n Args.Values[4]);\r\nend;\r\n\r\n{ function FileLoad(ResType: TResType; Name: string; MaskColor: TColor): Boolean; }\r\n\r\nprocedure TCustomImageList_FileLoad(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TCustomImageList(Args.Obj).FileLoad(Args.Values[0], Args.Values[1], Args.Values[2]);\r\nend;\r\n\r\n\r\n\r\n{ procedure GetBitmap(Index: Integer; Image: TBitmap); }\r\n\r\nprocedure TCustomImageList_GetBitmap(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TCustomImageList(Args.Obj).GetBitmap(Args.Values[0], V2O(Args.Values[1]) as TBitmap);\r\nend;\r\n\r\n\r\n\r\n{ function GetHotSpot: TPoint; }\r\n\r\nprocedure TCustomImageList_GetHotSpot(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n JvInterpreterVarCopy(Value, Point2Var(TCustomImageList(Args.Obj).GetHotSpot));\r\nend;\r\n\r\n{ procedure GetIcon(Index: Integer; Image: TIcon); }\r\n\r\nprocedure TCustomImageList_GetIcon(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TCustomImageList(Args.Obj).GetIcon(Args.Values[0], V2O(Args.Values[1]) as TIcon);\r\nend;\r\n\r\n{ function GetImageBitmap: HBITMAP; }\r\n\r\nprocedure TCustomImageList_GetImageBitmap(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := NativeInt(TCustomImageList(Args.Obj).GetImageBitmap);\r\nend;\r\n\r\n{ function GetMaskBitmap: HBITMAP; }\r\n\r\nprocedure TCustomImageList_GetMaskBitmap(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := NativeInt(TCustomImageList(Args.Obj).GetMaskBitmap);\r\nend;\r\n\r\n\r\n\r\n{ function GetResource(ResType: TResType; Name: string; Width: Integer; LoadFlags: TLoadResources; MaskColor: TColor): Boolean; }\r\n\r\nprocedure TCustomImageList_GetResource(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n// Value := TCustomImageList(Args.Obj).GetResource(Args.Values[0], Args.Values[1], Args.Values[2], Args.Values[3], Args.Values[4]);\r\nend;\r\n\r\n{ function GetInstRes(Instance: THandle; ResType: TResType; Name: string; Width: Integer; LoadFlags: TLoadResources; MaskColor: TColor): Boolean; }\r\n\r\nprocedure TCustomImageList_GetInstRes(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n// Value := TCustomImageList(Args.Obj).GetInstRes(Args.Values[0], Args.Values[1], Args.Values[2], Args.Values[3], Args.Values[4], Args.Values[5]);\r\nend;\r\n\r\n{ function HandleAllocated: Boolean; }\r\n\r\n\r\nprocedure TCustomImageList_HandleAllocated(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TCustomImageList(Args.Obj).HandleAllocated;\r\nend;\r\n\r\n\r\n{ procedure Insert(Index: Integer; Image, Mask: TBitmap); }\r\n\r\nprocedure TCustomImageList_Insert(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TCustomImageList(Args.Obj).Insert(Args.Values[0], V2O(Args.Values[1]) as TBitmap, V2O(Args.Values[2]) as TBitmap);\r\nend;\r\n\r\n{ procedure InsertIcon(Index: Integer; Image: TIcon); }\r\n\r\n\r\nprocedure TCustomImageList_InsertIcon(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TCustomImageList(Args.Obj).InsertIcon(Args.Values[0], V2O(Args.Values[1]) as TIcon);\r\nend;\r\n\r\n\r\n{ procedure InsertMasked(Index: Integer; Image: TBitmap; MaskColor: TColor); }\r\n\r\nprocedure TCustomImageList_InsertMasked(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TCustomImageList(Args.Obj).InsertMasked(Args.Values[0], V2O(Args.Values[1]) as TBitmap, Args.Values[2]);\r\nend;\r\n\r\n{ procedure Move(CurIndex, NewIndex: Integer); }\r\n\r\nprocedure TCustomImageList_Move(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TCustomImageList(Args.Obj).Move(Args.Values[0], Args.Values[1]);\r\nend;\r\n\r\n{ function Overlay(ImageIndex: Integer; Overlay: TOverlay): Boolean; }\r\n\r\n\r\nprocedure TCustomImageList_Overlay(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TCustomImageList(Args.Obj).Overlay(Args.Values[0], Args.Values[1]);\r\nend;\r\n\r\n\r\n{ procedure RegisterChanges(Value: TChangeLink); }\r\n\r\nprocedure TCustomImageList_RegisterChanges(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TCustomImageList(Args.Obj).RegisterChanges(V2O(Args.Values[0]) as TChangeLink);\r\nend;\r\n\r\n\r\n\r\n{ function ResourceLoad(ResType: TResType; Name: string; MaskColor: TColor): Boolean; }\r\n\r\nprocedure TCustomImageList_ResourceLoad(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TCustomImageList(Args.Obj).ResourceLoad(Args.Values[0], Args.Values[1], Args.Values[2]);\r\nend;\r\n\r\n{ function ResInstLoad(Instance: THandle; ResType: TResType; Name: string; MaskColor: TColor): Boolean; }\r\n\r\nprocedure TCustomImageList_ResInstLoad(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TCustomImageList(Args.Obj).ResInstLoad(Args.Values[0], Args.Values[1], Args.Values[2], Args.Values[3]);\r\nend;\r\n\r\n\r\n\r\n{ procedure Replace(Index: Integer; Image, Mask: TBitmap); }\r\n\r\nprocedure TCustomImageList_Replace(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TCustomImageList(Args.Obj).Replace(Args.Values[0], V2O(Args.Values[1]) as TBitmap, V2O(Args.Values[2]) as TBitmap);\r\nend;\r\n\r\n{ procedure ReplaceIcon(Index: Integer; Image: TIcon); }\r\n\r\n\r\nprocedure TCustomImageList_ReplaceIcon(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TCustomImageList(Args.Obj).ReplaceIcon(Args.Values[0], V2O(Args.Values[1]) as TIcon);\r\nend;\r\n\r\n\r\n{ procedure ReplaceMasked(Index: Integer; NewImage: TBitmap; MaskColor: TColor); }\r\n\r\nprocedure TCustomImageList_ReplaceMasked(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TCustomImageList(Args.Obj).ReplaceMasked(Args.Values[0], V2O(Args.Values[1]) as TBitmap, Args.Values[2]);\r\nend;\r\n\r\n{ procedure UnRegisterChanges(Value: TChangeLink); }\r\n\r\nprocedure TCustomImageList_UnRegisterChanges(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TCustomImageList(Args.Obj).UnRegisterChanges(V2O(Args.Values[0]) as TChangeLink);\r\nend;\r\n\r\n{ property Read Count: Integer }\r\n\r\nprocedure TCustomImageList_Read_Count(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TCustomImageList(Args.Obj).Count;\r\nend;\r\n\r\n\r\n\r\n{ property Read Handle: HImageList }\r\n\r\nprocedure TCustomImageList_Read_Handle(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := NativeInt(TCustomImageList(Args.Obj).Handle);\r\nend;\r\n\r\n{ property Write Handle(Value: HImageList) }\r\n\r\nprocedure TCustomImageList_Write_Handle(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TCustomImageList(Args.Obj).Handle := Value;\r\nend;\r\n\r\n\r\n\r\n\r\n\r\n{ property Read DragCursor: TCursor }\r\n\r\nprocedure TCustomImageList_Read_DragCursor(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TImageList(Args.Obj).DragCursor;\r\nend;\r\n\r\n{ property Write DragCursor(Value: TCursor) }\r\n\r\nprocedure TCustomImageList_Write_DragCursor(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TImageList(Args.Obj).DragCursor := Value;\r\nend;\r\n\r\n{ property Read Dragging: Boolean }\r\n\r\nprocedure TCustomImageList_Read_Dragging(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TImageList(Args.Obj).Dragging;\r\nend;\r\n\r\n{ function BeginDrag(Window: HWND; X, Y: Integer): Boolean; }\r\n\r\nprocedure TCustomImageList_BeginDrag(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TImageList(Args.Obj).BeginDrag(Args.Values[0], Args.Values[1], Args.Values[2]);\r\nend;\r\n\r\n{ function DragLock(Window: HWND; XPos, YPos: Integer): Boolean; }\r\n\r\nprocedure TCustomImageList_DragLock(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TImageList(Args.Obj).DragLock(Args.Values[0], Args.Values[1], Args.Values[2]);\r\nend;\r\n\r\n{ function DragMove(X, Y: Integer): Boolean; }\r\n\r\nprocedure TCustomImageList_DragMove(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TImageList(Args.Obj).DragMove(Args.Values[0], Args.Values[1]);\r\nend;\r\n\r\n{ procedure DragUnlock; }\r\n\r\nprocedure TCustomImageList_DragUnlock(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TImageList(Args.Obj).DragUnlock;\r\nend;\r\n\r\n{ function EndDrag: Boolean; }\r\n\r\nprocedure TCustomImageList_EndDrag(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TImageList(Args.Obj).EndDrag;\r\nend;\r\n\r\n{ procedure HideDragImage; }\r\n\r\nprocedure TCustomImageList_HideDragImage(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TImageList(Args.Obj).HideDragImage;\r\nend;\r\n\r\n{ function SetDragImage(Index, HotSpotX, HotSpotY: Integer): Boolean; }\r\n\r\nprocedure TCustomImageList_SetDragImage(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TImageList(Args.Obj).SetDragImage(Args.Values[0], Args.Values[1], Args.Values[2]);\r\nend;\r\n\r\n{ procedure ShowDragImage; }\r\n\r\nprocedure TCustomImageList_ShowDragImage(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TImageList(Args.Obj).ShowDragImage;\r\nend;\r\n\r\n\r\n\r\n{ hack section }\r\n\r\ntype\r\n THackControl = class(TControl);\r\n THackWinControl = class(TWinControl);\r\n THackCustomControl = class(TCustomControl);\r\n\r\n{ THackControl }\r\n\r\n{ property Read Caption: TCaption }\r\n\r\nprocedure THackControl_Read_Caption(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := THackControl(Args.Obj).Caption;\r\nend;\r\n\r\n{ property Write Caption(Value: TCaption) }\r\n\r\nprocedure THackControl_Write_Caption(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n THackControl(Args.Obj).Caption := Value;\r\nend;\r\n\r\n{ property Read Color: TColor }\r\n\r\nprocedure THackControl_Read_Color(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := THackControl(Args.Obj).Color;\r\nend;\r\n\r\n{ property Write Color(Value: TColor) }\r\n\r\nprocedure THackControl_Write_Color(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n THackControl(Args.Obj).Color := Value;\r\nend;\r\n\r\n\r\n\r\n{ property Read DesktopFont: Boolean }\r\n\r\nprocedure THackControl_Read_DesktopFont(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := THackControl(Args.Obj).DesktopFont;\r\nend;\r\n\r\n{ property Write DesktopFont(Value: Boolean) }\r\n\r\nprocedure THackControl_Write_DesktopFont(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n THackControl(Args.Obj).DesktopFont := Value;\r\nend;\r\n\r\n{ property Read DragCursor: TCursor }\r\n\r\nprocedure THackControl_Read_DragCursor(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := THackControl(Args.Obj).DragCursor;\r\nend;\r\n\r\n{ property Write DragCursor(Value: TCursor) }\r\n\r\nprocedure THackControl_Write_DragCursor(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n THackControl(Args.Obj).DragCursor := Value;\r\nend;\r\n\r\n\r\n\r\n{ property Read DragMode: TDragMode }\r\n\r\nprocedure THackControl_Read_DragMode(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := THackControl(Args.Obj).DragMode;\r\nend;\r\n\r\n{ property Write DragMode(Value: TDragMode) }\r\n\r\nprocedure THackControl_Write_DragMode(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n THackControl(Args.Obj).DragMode := Value;\r\nend;\r\n\r\n{ property Read Font: TFont }\r\n\r\nprocedure THackControl_Read_Font(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(THackControl(Args.Obj).Font);\r\nend;\r\n\r\n{ property Write Font(Value: TFont) }\r\n\r\nprocedure THackControl_Write_Font(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n THackControl(Args.Obj).Font := V2O(Value) as TFont;\r\nend;\r\n\r\n\r\n\r\n{ property Read IsControl: Boolean }\r\n\r\nprocedure THackControl_Read_IsControl(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := THackControl(Args.Obj).IsControl;\r\nend;\r\n\r\n{ property Write IsControl(Value: Boolean) }\r\n\r\nprocedure THackControl_Write_IsControl(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n THackControl(Args.Obj).IsControl := Value;\r\nend;\r\n\r\n\r\n\r\n{ property Read MouseCapture: Boolean }\r\n\r\nprocedure THackControl_Read_MouseCapture(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := THackControl(Args.Obj).MouseCapture;\r\nend;\r\n\r\n{ property Write MouseCapture(Value: Boolean) }\r\n\r\nprocedure THackControl_Write_MouseCapture(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n THackControl(Args.Obj).MouseCapture := Value;\r\nend;\r\n\r\n{ property Read ParentColor: Boolean }\r\n\r\nprocedure THackControl_Read_ParentColor(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := THackControl(Args.Obj).ParentColor;\r\nend;\r\n\r\n{ property Write ParentColor(Value: Boolean) }\r\n\r\nprocedure THackControl_Write_ParentColor(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n THackControl(Args.Obj).ParentColor := Value;\r\nend;\r\n\r\n{ property Read ParentFont: Boolean }\r\n\r\nprocedure THackControl_Read_ParentFont(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := THackControl(Args.Obj).ParentFont;\r\nend;\r\n\r\n{ property Write ParentFont(Value: Boolean) }\r\n\r\nprocedure THackControl_Write_ParentFont(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n THackControl(Args.Obj).ParentFont := Value;\r\nend;\r\n\r\n{ property Read ParentShowHint: Boolean }\r\n\r\nprocedure THackControl_Read_ParentShowHint(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := THackControl(Args.Obj).ParentShowHint;\r\nend;\r\n\r\n{ property Write ParentShowHint(Value: Boolean) }\r\n\r\nprocedure THackControl_Write_ParentShowHint(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n THackControl(Args.Obj).ParentShowHint := Value;\r\nend;\r\n\r\n{ property Read PopupMenu: TPopupMenu }\r\n\r\nprocedure THackControl_Read_PopupMenu(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(THackControl(Args.Obj).PopupMenu);\r\nend;\r\n\r\n{ property Write PopupMenu(Value: TPopupMenu) }\r\n\r\nprocedure THackControl_Write_PopupMenu(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n THackControl(Args.Obj).PopupMenu := V2O(Value) as TPopupMenu;\r\nend;\r\n\r\n{ property Read Text: TCaption }\r\n\r\nprocedure THackControl_Read_Text(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := THackControl(Args.Obj).Text;\r\nend;\r\n\r\n{ property Write Text(Value: TCaption) }\r\n\r\nprocedure THackControl_Write_Text(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n THackControl(Args.Obj).Text := Value;\r\nend;\r\n\r\n\r\n\r\n{ property Read WindowText: PChar }\r\n\r\nprocedure THackControl_Read_WindowText(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := string(THackControl(Args.Obj).WindowText);\r\nend;\r\n\r\n{ property Write WindowText(Value: PChar) }\r\n\r\nprocedure THackControl_Write_WindowText(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n THackControl(Args.Obj).WindowText := PChar(string(Value));\r\nend;\r\n\r\n\r\n\r\n{ THackWinControl }\r\n\r\n\r\n\r\n{ property Read Ctl3D: Boolean }\r\n\r\nprocedure THackWinControl_Read_Ctl3D(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := THackWinControl(Args.Obj).Ctl3D;\r\nend;\r\n\r\n{ property Write Ctl3D(Value: Boolean) }\r\n\r\nprocedure THackWinControl_Write_Ctl3D(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n THackWinControl(Args.Obj).Ctl3D := Value;\r\nend;\r\n\r\n{ property Read DefWndProc: Pointer }\r\n\r\nprocedure THackWinControl_Read_DefWndProc(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := P2V(THackWinControl(Args.Obj).DefWndProc);\r\nend;\r\n\r\n{ property Write DefWndProc(Value: Pointer) }\r\n\r\nprocedure THackWinControl_Write_DefWndProc(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n THackWinControl(Args.Obj).DefWndProc := V2P(Value);\r\nend;\r\n\r\n\r\n\r\n\r\n{ property Read ImeMode: TImeMode }\r\n\r\nprocedure THackWinControl_Read_ImeMode(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := THackWinControl(Args.Obj).ImeMode;\r\nend;\r\n\r\n{ property Write ImeMode(Value: TImeMode) }\r\n\r\nprocedure THackWinControl_Write_ImeMode(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n THackWinControl(Args.Obj).ImeMode := Value;\r\nend;\r\n\r\n{ property Read ImeName: TImeName }\r\n\r\nprocedure THackWinControl_Read_ImeName(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := THackWinControl(Args.Obj).ImeName;\r\nend;\r\n\r\n{ property Write ImeName(Value: TImeName) }\r\n\r\nprocedure THackWinControl_Write_ImeName(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n THackWinControl(Args.Obj).ImeName := Value;\r\nend;\r\n\r\n{ property Read ParentCtl3D: Boolean }\r\n\r\nprocedure THackWinControl_Read_ParentCtl3D(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := THackWinControl(Args.Obj).ParentCtl3D;\r\nend;\r\n\r\n{ property Write ParentCtl3D(Value: Boolean) }\r\n\r\nprocedure THackWinControl_Write_ParentCtl3D(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n THackWinControl(Args.Obj).ParentCtl3D := Value;\r\nend;\r\n\r\n{ property Read WindowHandle: HWnd }\r\n\r\nprocedure THackWinControl_Read_WindowHandle(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := NativeInt(THackWinControl(Args.Obj).WindowHandle);\r\nend;\r\n\r\n{ property Write WindowHandle(Value: HWnd) }\r\n\r\nprocedure THackWinControl_Write_WindowHandle(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n THackWinControl(Args.Obj).WindowHandle := Value;\r\nend;\r\n\r\n\r\n\r\n{ THackCustomControl }\r\n\r\n{ procedure Paint; }\r\n\r\nprocedure THackCustomControl_Paint(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n THackCustomControl(Args.Obj).Paint;\r\nend;\r\n\r\n{ procedure PaintWindow(DC: HDC); }\r\n\r\n\r\nprocedure THackCustomControl_PaintWindow(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n THackCustomControl(Args.Obj).PaintWindow(Args.Values[0]);\r\nend;\r\n\r\n\r\n{ property Read Canvas: TCanvas }\r\n\r\nprocedure THackCustomControl_Read_Canvas(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(THackCustomControl(Args.Obj).Canvas);\r\nend;\r\n\r\n{ functions }\r\n\r\n{ function IsDragObject(Sender: TObject): Boolean; }\r\n\r\n\r\nprocedure JvInterpreter_IsDragObject(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := IsDragObject(V2O(Args.Values[0]));\r\nend;\r\n\r\n\r\n{ function FindControl(Handle: HWnd): TWinControl; }\r\n\r\nprocedure JvInterpreter_FindControl(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(FindControl(Args.Values[0]));\r\nend;\r\n\r\n{ function FindVCLWindow(const Pos: TPoint): TWinControl; }\r\n\r\n\r\nprocedure JvInterpreter_FindVCLWindow(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(FindVCLWindow(Var2Point(Args.Values[0])));\r\nend;\r\n\r\n\r\n{ function FindDragTarget(const Pos: TPoint; AllowDisabled: Boolean): TControl; }\r\n\r\nprocedure JvInterpreter_FindDragTarget(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(FindDragTarget(Var2Point(Args.Values[0]), Args.Values[1]));\r\nend;\r\n\r\n{ function GetCaptureControl: TControl; }\r\n\r\nprocedure JvInterpreter_GetCaptureControl(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(GetCaptureControl);\r\nend;\r\n\r\n{ procedure SetCaptureControl(Control: TControl); }\r\n\r\nprocedure JvInterpreter_SetCaptureControl(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n SetCaptureControl(V2O(Args.Values[0]) as TControl);\r\nend;\r\n\r\n{ procedure CancelDrag; }\r\n\r\n\r\nprocedure JvInterpreter_CancelDrag(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n CancelDrag;\r\nend;\r\n\r\n\r\n{ function CursorToString(Cursor: TCursor): string; }\r\n\r\nprocedure JvInterpreter_CursorToString(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := CursorToString(Args.Values[0]);\r\nend;\r\n\r\n{ function StringToCursor(const S: string): TCursor; }\r\n\r\nprocedure JvInterpreter_StringToCursor(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := StringToCursor(Args.Values[0]);\r\nend;\r\n\r\n{ function CursorToIdent(Cursor: Longint; var Ident: string): Boolean; }\r\n\r\nprocedure JvInterpreter_CursorToIdent(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := CursorToIdent(Args.Values[0], string(TVarData(Args.Values[1]).vString));\r\nend;\r\n\r\n{ function IdentToCursor(const Ident: string; var Cursor: Longint): Boolean; }\r\n\r\nprocedure JvInterpreter_IdentToCursor(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := IdentToCursor(Args.Values[0], Longint(TVarData(Args.Values[1]).vInteger));\r\nend;\r\n\r\n{ function GetShortHint(const Hint: string): string; }\r\n\r\nprocedure JvInterpreter_GetShortHint(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := GetShortHint(Args.Values[0]);\r\nend;\r\n\r\n{ function GetLongHint(const Hint: string): string; }\r\n\r\nprocedure JvInterpreter_GetLongHint(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := GetLongHint(Args.Values[0]);\r\nend;\r\n\r\n\r\n\r\n{ function InitWndProc(HWindow: HWnd; Message, WParam: Longint; LParam: Longint): Longint; }\r\n\r\nprocedure JvInterpreter_InitWndProc(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := InitWndProc(Args.Values[0], Args.Values[1], Args.Values[2], Args.Values[3]);\r\nend;\r\n\r\n{ function SendAppMessage(Msg: Cardinal; WParam, LParam: Longint): Longint; }\r\n\r\nprocedure JvInterpreter_SendAppMessage(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := SendAppMessage(Args.Values[0], Args.Values[1], Args.Values[2]);\r\nend;\r\n\r\n{ procedure MoveWindowOrg(DC: HDC; DX, DY: Integer); }\r\n\r\nprocedure JvInterpreter_MoveWindowOrg(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n MoveWindowOrg(Args.Values[0], Args.Values[1], Args.Values[2]);\r\nend;\r\n\r\n\r\n\r\ntype\r\n TJvInterpreterControlsEvent = class(TJvInterpreterEvent)\r\n private\r\n procedure MouseEvent(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);\r\n procedure MouseMoveEvent(Sender: TObject; Shift: TShiftState; X, Y: Integer);\r\n procedure KeyEvent(Sender: TObject; var Key: Word; Shift: TShiftState);\r\n procedure KeyPressEvent(Sender: TObject; var Key: Char);\r\n procedure DragOverEvent(Sender, Source: TObject; X, Y: Integer; State: TDragState; var Accept: Boolean);\r\n procedure DragDropEvent(Sender, Source: TObject; X, Y: Integer);\r\n procedure StartDragEvent(Sender: TObject; var DragObject: TDragObject);\r\n procedure EndDragEvent(Sender, Target: TObject; X, Y: Integer);\r\n end;\r\n\r\nprocedure TJvInterpreterControlsEvent.MouseEvent(Sender: TObject; Button: TMouseButton; Shift: TShiftState;\r\n X, Y: Integer);\r\nbegin\r\n CallFunction(nil, [O2V(Sender), Button, S2V(TJvInterpreterShiftStateCastType(Shift)), X, Y]);\r\nend;\r\n\r\nprocedure TJvInterpreterControlsEvent.MouseMoveEvent(Sender: TObject; Shift: TShiftState; X, Y: Integer);\r\nbegin\r\n CallFunction(nil, [O2V(Sender), S2V(TJvInterpreterShiftStateCastType(Shift)), X, Y]);\r\nend;\r\n\r\nprocedure TJvInterpreterControlsEvent.KeyEvent(Sender: TObject; var Key: Word; Shift: TShiftState);\r\nbegin\r\n CallFunction(nil, [O2V(Sender), Key, S2V(TJvInterpreterShiftStateCastType(Shift))]);\r\n Key := Args.Values[1];\r\nend;\r\n\r\nprocedure TJvInterpreterControlsEvent.KeyPressEvent(Sender: TObject; var Key: Char);\r\nbegin\r\n CallFunction(nil, [O2V(Sender), Key]);\r\n Key := string(Args.Values[1])[1];\r\nend;\r\n\r\nprocedure TJvInterpreterControlsEvent.DragOverEvent(Sender, Source: TObject; X, Y: Integer;\r\n State: TDragState; var Accept: Boolean);\r\nbegin\r\n CallFunction(nil, [O2V(Sender), O2V(Source), X, Y, S2V(Byte(State)), Accept]);\r\n Accept := Args.Values[5];\r\nend;\r\n\r\nprocedure TJvInterpreterControlsEvent.DragDropEvent(Sender, Source: TObject; X, Y: Integer);\r\nbegin\r\n CallFunction(nil, [O2V(Sender), O2V(Source), X, Y]);\r\nend;\r\n\r\nprocedure TJvInterpreterControlsEvent.StartDragEvent(Sender: TObject; var DragObject: TDragObject);\r\nbegin\r\n CallFunction(nil, [O2V(Sender), O2V(DragObject)]);\r\n DragObject := V2O(Args.Values[1]) as TDragObject;\r\nend;\r\n\r\nprocedure TJvInterpreterControlsEvent.EndDragEvent(Sender, Target: TObject; X, Y: Integer);\r\nbegin\r\n CallFunction(nil, [O2V(Sender), O2V(Target), X, Y]);\r\nend;\r\n\r\nprocedure RegisterJvInterpreterAdapter(JvInterpreterAdapter: TJvInterpreterAdapter);\r\nconst\r\n cControls = 'Controls';\r\nbegin\r\n with JvInterpreterAdapter do\r\n begin\r\n { TDragMessage }\r\n AddConst(cControls, 'dmDragEnter', Ord(dmDragEnter));\r\n AddConst(cControls, 'dmDragLeave', Ord(dmDragLeave));\r\n AddConst(cControls, 'dmDragMove', Ord(dmDragMove));\r\n AddConst(cControls, 'dmDragDrop', Ord(dmDragDrop));\r\n AddConst(cControls, 'dmDragCancel', Ord(dmDragCancel));\r\n AddConst(cControls, 'dmFindTarget', Ord(dmFindTarget));\r\n { TAlign }\r\n AddConst(cControls, 'alNone', Ord(alNone));\r\n AddConst(cControls, 'alTop', Ord(alTop));\r\n AddConst(cControls, 'alBottom', Ord(alBottom));\r\n AddConst(cControls, 'alLeft', Ord(alLeft));\r\n AddConst(cControls, 'alRight', Ord(alRight));\r\n AddConst(cControls, 'alClient', Ord(alClient));\r\n { TControlState }\r\n AddConst(cControls, 'csLButtonDown', Ord(csLButtonDown));\r\n AddConst(cControls, 'csClicked', Ord(csClicked));\r\n AddConst(cControls, 'csPalette', Ord(csPalette));\r\n AddConst(cControls, 'csReadingState', Ord(csReadingState));\r\n AddConst(cControls, 'csAlignmentNeeded', Ord(csAlignmentNeeded));\r\n AddConst(cControls, 'csFocusing', Ord(csFocusing));\r\n AddConst(cControls, 'csCreating', Ord(csCreating));\r\n AddConst(cControls, 'csPaintCopy', Ord(csPaintCopy));\r\n { TControlStyle }\r\n AddConst(cControls, 'csAcceptsControls', Ord(csAcceptsControls));\r\n AddConst(cControls, 'csCaptureMouse', Ord(csCaptureMouse));\r\n AddConst(cControls, 'csDesignInteractive', Ord(csDesignInteractive));\r\n AddConst(cControls, 'csClickEvents', Ord(csClickEvents));\r\n AddConst(cControls, 'csFramed', Ord(csFramed));\r\n AddConst(cControls, 'csSetCaption', Ord(csSetCaption));\r\n AddConst(cControls, 'csOpaque', Ord(csOpaque));\r\n AddConst(cControls, 'csDoubleClicks', Ord(csDoubleClicks));\r\n AddConst(cControls, 'csFixedWidth', Ord(csFixedWidth));\r\n AddConst(cControls, 'csFixedHeight', Ord(csFixedHeight));\r\n AddConst(cControls, 'csNoDesignVisible', Ord(csNoDesignVisible));\r\n AddConst(cControls, 'csReplicatable', Ord(csReplicatable));\r\n AddConst(cControls, 'csNoStdEvents', Ord(csNoStdEvents));\r\n AddConst(cControls, 'csDisplayDragImage', Ord(csDisplayDragImage));\r\n AddConst(cControls, 'csReflector', Ord(csReflector));\r\n AddConst(cControls, 'csActionClient', Ord(csActionClient));\r\n AddConst(cControls, 'csMenuEvents', Ord(csMenuEvents));\r\n { TMouseButton }\r\n AddConst(cControls, 'mbLeft', Ord(mbLeft));\r\n AddConst(cControls, 'mbRight', Ord(mbRight));\r\n AddConst(cControls, 'mbMiddle', Ord(mbMiddle));\r\n { TDragMode }\r\n AddConst(cControls, 'dmManual', Ord(dmManual));\r\n AddConst(cControls, 'dmAutomatic', Ord(dmAutomatic));\r\n { TDragState }\r\n AddConst(cControls, 'dsDragEnter', Ord(dsDragEnter));\r\n AddConst(cControls, 'dsDragLeave', Ord(dsDragLeave));\r\n AddConst(cControls, 'dsDragMove', Ord(dsDragMove));\r\n { TScalingFlags }\r\n AddConst(cControls, 'sfLeft', Ord(sfLeft));\r\n AddConst(cControls, 'sfTop', Ord(sfTop));\r\n AddConst(cControls, 'sfWidth', Ord(sfWidth));\r\n AddConst(cControls, 'sfHeight', Ord(sfHeight));\r\n AddConst(cControls, 'sfFont', Ord(sfFont));\r\n { TControl }\r\n AddClass(cControls, TControl, 'TControl');\r\n AddGet(TControl, 'Create', TControl_Create, 1, [varEmpty], varEmpty);\r\n AddGet(TControl, 'BeginDrag', TControl_BeginDrag, 1, [varEmpty], varEmpty);\r\n AddGet(TControl, 'BringToFront', TControl_BringToFront, 0, [varEmpty], varEmpty);\r\n AddGet(TControl, 'ClientToScreen', TControl_ClientToScreen, 1, [varEmpty], varEmpty);\r\n AddGet(TControl, 'Dragging', TControl_Dragging, 0, [varEmpty], varEmpty);\r\n AddGet(TControl, 'DragDrop', TControl_DragDrop, 3, [varEmpty, varEmpty, varEmpty], varEmpty);\r\n AddGet(TControl, 'EndDrag', TControl_EndDrag, 1, [varEmpty], varEmpty);\r\n AddGet(TControl, 'GetTextBuf', TControl_GetTextBuf, 2, [varEmpty, varEmpty], varEmpty);\r\n AddGet(TControl, 'GetTextLen', TControl_GetTextLen, 0, [varEmpty], varEmpty);\r\n AddGet(TControl, 'Hide', TControl_Hide, 0, [varEmpty], varEmpty);\r\n AddGet(TControl, 'Invalidate', TControl_Invalidate, 0, [varEmpty], varEmpty);\r\n AddGet(TControl, 'Perform', TControl_Perform, 3, [varEmpty, varEmpty, varEmpty], varEmpty);\r\n AddGet(TControl, 'Refresh', TControl_Refresh, 0, [varEmpty], varEmpty);\r\n AddGet(TControl, 'Repaint', TControl_Repaint, 0, [varEmpty], varEmpty);\r\n AddGet(TControl, 'ScreenToClient', TControl_ScreenToClient, 1, [varEmpty], varEmpty);\r\n AddGet(TControl, 'SendToBack', TControl_SendToBack, 0, [varEmpty], varEmpty);\r\n AddGet(TControl, 'SetBounds', TControl_SetBounds, 4, [varEmpty, varEmpty, varEmpty, varEmpty], varEmpty);\r\n AddGet(TControl, 'SetTextBuf', TControl_SetTextBuf, 1, [varEmpty], varEmpty);\r\n AddGet(TControl, 'Show', TControl_Show, 0, [varEmpty], varEmpty);\r\n AddGet(TControl, 'Update', TControl_Update, 0, [varEmpty], varEmpty);\r\n AddGet(TControl, 'Align', TControl_Read_Align, 0, [varEmpty], varEmpty);\r\n AddSet(TControl, 'Align', TControl_Write_Align, 0, [varEmpty]);\r\n AddGet(TControl, 'BoundsRect', TControl_Read_BoundsRect, 0, [varEmpty], varEmpty);\r\n AddSet(TControl, 'BoundsRect', TControl_Write_BoundsRect, 0, [varEmpty]);\r\n AddGet(TControl, 'ClientHeight', TControl_Read_ClientHeight, 0, [varEmpty], varEmpty);\r\n AddSet(TControl, 'ClientHeight', TControl_Write_ClientHeight, 0, [varEmpty]);\r\n AddGet(TControl, 'ClientOrigin', TControl_Read_ClientOrigin, 0, [varEmpty], varEmpty);\r\n AddGet(TControl, 'ClientRect', TControl_Read_ClientRect, 0, [varEmpty], varEmpty);\r\n AddGet(TControl, 'ClientWidth', TControl_Read_ClientWidth, 0, [varEmpty], varEmpty);\r\n AddSet(TControl, 'ClientWidth', TControl_Write_ClientWidth, 0, [varEmpty]);\r\n AddGet(TControl, 'ControlState', TControl_Read_ControlState, 0, [varEmpty], varEmpty);\r\n AddSet(TControl, 'ControlState', TControl_Write_ControlState, 0, [varEmpty]);\r\n AddGet(TControl, 'ControlStyle', TControl_Read_ControlStyle, 0, [varEmpty], varEmpty);\r\n AddSet(TControl, 'ControlStyle', TControl_Write_ControlStyle, 0, [varEmpty]);\r\n AddGet(TControl, 'Parent', TControl_Read_Parent, 0, [varEmpty], varEmpty);\r\n AddSet(TControl, 'Parent', TControl_Write_Parent, 0, [varEmpty]);\r\n AddGet(TControl, 'ShowHint', TControl_Read_ShowHint, 0, [varEmpty], varEmpty);\r\n AddSet(TControl, 'ShowHint', TControl_Write_ShowHint, 0, [varEmpty]);\r\n AddGet(TControl, 'Visible', TControl_Read_Visible, 0, [varEmpty], varEmpty);\r\n AddSet(TControl, 'Visible', TControl_Write_Visible, 0, [varEmpty]);\r\n AddGet(TControl, 'Enabled', TControl_Read_Enabled, 0, [varEmpty], varEmpty);\r\n AddSet(TControl, 'Enabled', TControl_Write_Enabled, 0, [varEmpty]);\r\n AddGet(TControl, 'WindowProc', TControl_Read_WindowProc, 0, [varEmpty], varEmpty);\r\n AddSet(TControl, 'WindowProc', TControl_Write_WindowProc, 0, [varEmpty]);\r\n AddGet(TControl, 'Left', TControl_Read_Left, 0, [varEmpty], varEmpty);\r\n AddSet(TControl, 'Left', TControl_Write_Left, 0, [varEmpty]);\r\n AddGet(TControl, 'Top', TControl_Read_Top, 0, [varEmpty], varEmpty);\r\n AddSet(TControl, 'Top', TControl_Write_Top, 0, [varEmpty]);\r\n AddGet(TControl, 'Width', TControl_Read_Width, 0, [varEmpty], varEmpty);\r\n AddSet(TControl, 'Width', TControl_Write_Width, 0, [varEmpty]);\r\n AddGet(TControl, 'Height', TControl_Read_Height, 0, [varEmpty], varEmpty);\r\n AddSet(TControl, 'Height', TControl_Write_Height, 0, [varEmpty]);\r\n AddGet(TControl, 'Cursor', TControl_Read_Cursor, 0, [varEmpty], varEmpty);\r\n AddSet(TControl, 'Cursor', TControl_Write_Cursor, 0, [varEmpty]);\r\n AddGet(TControl, 'Hint', TControl_Read_Hint, 0, [varEmpty], varEmpty);\r\n AddSet(TControl, 'Hint', TControl_Write_Hint, 0, [varEmpty]);\r\n { TImeMode }\r\n AddConst(cControls, 'imDisable', Ord(imDisable));\r\n AddConst(cControls, 'imClose', Ord(imClose));\r\n AddConst(cControls, 'imOpen', Ord(imOpen));\r\n AddConst(cControls, 'imDontCare', Ord(imDontCare));\r\n AddConst(cControls, 'imSAlpha', Ord(imSAlpha));\r\n AddConst(cControls, 'imAlpha', Ord(imAlpha));\r\n AddConst(cControls, 'imHira', Ord(imHira));\r\n AddConst(cControls, 'imSKata', Ord(imSKata));\r\n AddConst(cControls, 'imKata', Ord(imKata));\r\n AddConst(cControls, 'imChinese', Ord(imChinese));\r\n AddConst(cControls, 'imSHanguel', Ord(imSHanguel));\r\n AddConst(cControls, 'imHanguel', Ord(imHanguel));\r\n { TWinControl }\r\n AddClass(cControls, TWinControl, 'TWinControl');\r\n AddGet(TWinControl, 'Create', TWinControl_Create, 1, [varEmpty], varEmpty);\r\n AddGet(TWinControl, 'CreateParented', TWinControl_CreateParented, 1, [varEmpty], varEmpty);\r\n AddGet(TWinControl, 'Broadcast', TWinControl_Broadcast, 1, [varByRef], varEmpty);\r\n AddGet(TWinControl, 'CanFocus', TWinControl_CanFocus, 0, [varEmpty], varEmpty);\r\n AddGet(TWinControl, 'ContainsControl', TWinControl_ContainsControl, 1, [varEmpty], varEmpty);\r\n AddGet(TWinControl, 'ControlAtPos', TWinControl_ControlAtPos, 2, [varEmpty, varEmpty], varEmpty);\r\n AddGet(TWinControl, 'DisableAlign', TWinControl_DisableAlign, 0, [varEmpty], varEmpty);\r\n AddGet(TWinControl, 'EnableAlign', TWinControl_EnableAlign, 0, [varEmpty], varEmpty);\r\n AddGet(TWinControl, 'Focused', TWinControl_Focused, 0, [varEmpty], varEmpty);\r\n AddGet(TWinControl, 'GetTabOrderList', TWinControl_GetTabOrderList, 1, [varEmpty], varEmpty);\r\n AddGet(TWinControl, 'HandleAllocated', TWinControl_HandleAllocated, 0, [varEmpty], varEmpty);\r\n AddGet(TWinControl, 'HandleNeeded', TWinControl_HandleNeeded, 0, [varEmpty], varEmpty);\r\n AddGet(TWinControl, 'InsertControl', TWinControl_InsertControl, 1, [varEmpty], varEmpty);\r\n AddGet(TWinControl, 'Invalidate', TWinControl_Invalidate, 0, [varEmpty], varEmpty);\r\n AddGet(TWinControl, 'PaintTo', TWinControl_PaintTo, 3, [varEmpty, varEmpty, varEmpty], varEmpty);\r\n AddGet(TWinControl, 'RemoveControl', TWinControl_RemoveControl, 1, [varEmpty], varEmpty);\r\n AddGet(TWinControl, 'Realign', TWinControl_Realign, 0, [varEmpty], varEmpty);\r\n AddGet(TWinControl, 'Repaint', TWinControl_Repaint, 0, [varEmpty], varEmpty);\r\n AddGet(TWinControl, 'ScaleBy', TWinControl_ScaleBy, 2, [varEmpty, varEmpty], varEmpty);\r\n AddGet(TWinControl, 'ScrollBy', TWinControl_ScrollBy, 2, [varEmpty, varEmpty], varEmpty);\r\n AddGet(TWinControl, 'SetBounds', TWinControl_SetBounds, 4, [varEmpty, varEmpty, varEmpty, varEmpty], varEmpty);\r\n AddGet(TWinControl, 'SetFocus', TWinControl_SetFocus, 0, [varEmpty], varEmpty);\r\n AddGet(TWinControl, 'Update', TWinControl_Update, 0, [varEmpty], varEmpty);\r\n AddGet(TWinControl, 'UpdateControlState', TWinControl_UpdateControlState, 0, [varEmpty], varEmpty);\r\n AddGet(TWinControl, 'Brush', TWinControl_Read_Brush, 0, [varEmpty], varEmpty);\r\n AddIGet(TWinControl, 'Controls', TWinControl_Read_Controls, 1, [varEmpty], varEmpty);\r\n AddGet(TWinControl, 'ControlCount', TWinControl_Read_ControlCount, 0, [varEmpty], varEmpty);\r\n AddGet(TWinControl, 'Handle', TWinControl_Read_Handle, 0, [varEmpty], varEmpty);\r\n AddGet(TWinControl, 'ParentWindow', TWinControl_Read_ParentWindow, 0, [varEmpty], varEmpty);\r\n AddSet(TWinControl, 'ParentWindow', TWinControl_Write_ParentWindow, 0, [varEmpty]);\r\n AddGet(TWinControl, 'ParentWidget', TWinControl_Read_ParentWindow, 0, [varEmpty], varEmpty);\r\n AddSet(TWinControl, 'ParentWidget', TWinControl_Write_ParentWindow, 0, [varEmpty]);\r\n AddGet(TWinControl, 'Showing', TWinControl_Read_Showing, 0, [varEmpty], varEmpty);\r\n AddGet(TWinControl, 'TabOrder', TWinControl_Read_TabOrder, 0, [varEmpty], varEmpty);\r\n AddSet(TWinControl, 'TabOrder', TWinControl_Write_TabOrder, 0, [varEmpty]);\r\n AddGet(TWinControl, 'TabStop', TWinControl_Read_TabStop, 0, [varEmpty], varEmpty);\r\n AddSet(TWinControl, 'TabStop', TWinControl_Write_TabStop, 0, [varEmpty]);\r\n AddGet(TWinControl, 'HelpContext', TWinControl_Read_HelpContext, 0, [varEmpty], varEmpty);\r\n AddSet(TWinControl, 'HelpContext', TWinControl_Write_HelpContext, 0, [varEmpty]);\r\n { TGraphicControl }\r\n AddClass(cControls, TGraphicControl, 'TGraphicControl');\r\n AddGet(TGraphicControl, 'Create', TGraphicControl_Create, 1, [varEmpty], varEmpty);\r\n { TCustomControl }\r\n AddClass(cControls, TCustomControl, 'TCustomControl');\r\n AddGet(TCustomControl, 'Create', TCustomControl_Create, 1, [varEmpty], varEmpty);\r\n\r\n AddGet(TControl, 'Caption', THackControl_Read_Caption, 0, [varEmpty], varEmpty);\r\n AddSet(TControl, 'Caption', THackControl_Write_Caption, 0, [varEmpty]);\r\n AddGet(TControl, 'Color', THackControl_Read_Color, 0, [varEmpty], varEmpty);\r\n AddSet(TControl, 'Color', THackControl_Write_Color, 0, [varEmpty]);\r\n AddGet(TControl, 'DesktopFont', THackControl_Read_DesktopFont, 0, [varEmpty], varEmpty);\r\n AddSet(TControl, 'DesktopFont', THackControl_Write_DesktopFont, 0, [varEmpty]);\r\n AddGet(TControl, 'DragCursor', THackControl_Read_DragCursor, 0, [varEmpty], varEmpty);\r\n AddSet(TControl, 'DragCursor', THackControl_Write_DragCursor, 0, [varEmpty]);\r\n AddGet(TControl, 'DragMode', THackControl_Read_DragMode, 0, [varEmpty], varEmpty);\r\n AddSet(TControl, 'DragMode', THackControl_Write_DragMode, 0, [varEmpty]);\r\n AddGet(TControl, 'Font', THackControl_Read_Font, 0, [varEmpty], varEmpty);\r\n AddSet(TControl, 'Font', THackControl_Write_Font, 0, [varEmpty]);\r\n AddGet(TControl, 'IsControl', THackControl_Read_IsControl, 0, [varEmpty], varEmpty);\r\n AddSet(TControl, 'IsControl', THackControl_Write_IsControl, 0, [varEmpty]);\r\n AddGet(TControl, 'MouseCapture', THackControl_Read_MouseCapture, 0, [varEmpty], varEmpty);\r\n AddSet(TControl, 'MouseCapture', THackControl_Write_MouseCapture, 0, [varEmpty]);\r\n AddGet(TControl, 'ParentColor', THackControl_Read_ParentColor, 0, [varEmpty], varEmpty);\r\n AddSet(TControl, 'ParentColor', THackControl_Write_ParentColor, 0, [varEmpty]);\r\n AddGet(TControl, 'ParentFont', THackControl_Read_ParentFont, 0, [varEmpty], varEmpty);\r\n AddSet(TControl, 'ParentFont', THackControl_Write_ParentFont, 0, [varEmpty]);\r\n AddGet(TControl, 'ParentShowHint', THackControl_Read_ParentShowHint, 0, [varEmpty], varEmpty);\r\n AddSet(TControl, 'ParentShowHint', THackControl_Write_ParentShowHint, 0, [varEmpty]);\r\n AddGet(TControl, 'PopupMenu', THackControl_Read_PopupMenu, 0, [varEmpty], varEmpty);\r\n AddSet(TControl, 'PopupMenu', THackControl_Write_PopupMenu, 0, [varEmpty]);\r\n AddGet(TControl, 'Text', THackControl_Read_Text, 0, [varEmpty], varEmpty);\r\n AddSet(TControl, 'Text', THackControl_Write_Text, 0, [varEmpty]);\r\n AddGet(TControl, 'WindowText', THackControl_Read_WindowText, 0, [varEmpty], varEmpty);\r\n AddSet(TControl, 'WindowText', THackControl_Write_WindowText, 0, [varEmpty]);\r\n AddGet(TWinControl, 'Ctl3D', THackWinControl_Read_Ctl3D, 0, [varEmpty], varEmpty);\r\n AddSet(TWinControl, 'Ctl3D', THackWinControl_Write_Ctl3D, 0, [varEmpty]);\r\n AddGet(TWinControl, 'DefWndProc', THackWinControl_Read_DefWndProc, 0, [varEmpty], varEmpty);\r\n AddSet(TWinControl, 'DefWndProc', THackWinControl_Write_DefWndProc, 0, [varEmpty]);\r\n AddGet(TWinControl, 'ImeMode', THackWinControl_Read_ImeMode, 0, [varEmpty], varEmpty);\r\n AddSet(TWinControl, 'ImeMode', THackWinControl_Write_ImeMode, 0, [varEmpty]);\r\n AddGet(TWinControl, 'ImeName', THackWinControl_Read_ImeName, 0, [varEmpty], varEmpty);\r\n AddSet(TWinControl, 'ImeName', THackWinControl_Write_ImeName, 0, [varEmpty]);\r\n AddGet(TWinControl, 'ParentCtl3D', THackWinControl_Read_ParentCtl3D, 0, [varEmpty], varEmpty);\r\n AddSet(TWinControl, 'ParentCtl3D', THackWinControl_Write_ParentCtl3D, 0, [varEmpty]);\r\n AddGet(TWinControl, 'WindowHandle', THackWinControl_Read_WindowHandle, 0, [varEmpty], varEmpty);\r\n AddSet(TWinControl, 'WindowHandle', THackWinControl_Write_WindowHandle, 0, [varEmpty]);\r\n { TCustomControl }\r\n AddClass('IH_Controls', THackCustomControl, 'THackCustomControl');\r\n AddGet(TCustomControl, 'Paint', THackCustomControl_Paint, 0, [varEmpty], varEmpty);\r\n AddGet(TCustomControl, 'PaintWindow', THackCustomControl_PaintWindow, 1, [varEmpty], varEmpty);\r\n AddGet(TCustomControl, 'Canvas', THackCustomControl_Read_Canvas, 0, [varEmpty], varEmpty);\r\n\r\n { TDrawingStyle }\r\n AddConst(cControls, 'dsFocus', Ord(dsFocus));\r\n AddConst(cControls, 'dsSelected', Ord(dsSelected));\r\n AddConst(cControls, 'dsNormal', Ord(dsNormal));\r\n AddConst(cControls, 'dsTransparent', Ord(dsTransparent));\r\n { TImageType }\r\n AddConst(cControls, 'itImage', Ord(itImage));\r\n AddConst(cControls, 'itMask', Ord(itMask));\r\n { TResType }\r\n AddConst(cControls, 'rtBitmap', Ord(rtBitmap));\r\n AddConst(cControls, 'rtCursor', Ord(rtCursor));\r\n AddConst(cControls, 'rtIcon', Ord(rtIcon));\r\n { TLoadResource }\r\n AddConst(cControls, 'lrDefaultColor', Ord(lrDefaultColor));\r\n AddConst(cControls, 'lrDefaultSize', Ord(lrDefaultSize));\r\n AddConst(cControls, 'lrFromFile', Ord(lrFromFile));\r\n AddConst(cControls, 'lrMap3DColors', Ord(lrMap3DColors));\r\n AddConst(cControls, 'lrTransparent', Ord(lrTransparent));\r\n AddConst(cControls, 'lrMonoChrome', Ord(lrMonoChrome));\r\n { TCustomImageList }\r\n AddClass(cControls, TCustomImageList, 'TCustomImageList');\r\n AddGet(TCustomImageList, 'Create', TCustomImageList_Create, 1, [varEmpty], varEmpty);\r\n AddGet(TCustomImageList, 'CreateSize', TCustomImageList_CreateSize, 2, [varEmpty, varEmpty], varEmpty);\r\n AddGet(TCustomImageList, 'Assign', TCustomImageList_Assign, 1, [varEmpty], varEmpty);\r\n AddGet(TCustomImageList, 'Add', TCustomImageList_Add, 2, [varEmpty, varEmpty], varEmpty);\r\n AddGet(TCustomImageList, 'AddIcon', TCustomImageList_AddIcon, 1, [varEmpty], varEmpty);\r\n AddGet(TCustomImageList, 'AddImages', TCustomImageList_AddImages, 1, [varEmpty], varEmpty);\r\n AddGet(TCustomImageList, 'AddMasked', TCustomImageList_AddMasked, 2, [varEmpty, varEmpty], varEmpty);\r\n AddGet(TCustomImageList, 'Clear', TCustomImageList_Clear, 0, [varEmpty], varEmpty);\r\n AddGet(TCustomImageList, 'Delete', TCustomImageList_Delete, 1, [varEmpty], varEmpty);\r\n AddGet(TCustomImageList, 'Draw', TCustomImageList_Draw, 4, [varEmpty, varEmpty, varEmpty, varEmpty], varEmpty);\r\n AddGet(TCustomImageList, 'DrawOverlay', TCustomImageList_DrawOverlay, 5, [varEmpty, varEmpty, varEmpty, varEmpty,\r\n varEmpty], varEmpty);\r\n AddGet(TCustomImageList, 'FileLoad', TCustomImageList_FileLoad, 3, [varEmpty, varEmpty, varEmpty], varEmpty);\r\n AddGet(TCustomImageList, 'GetBitmap', TCustomImageList_GetBitmap, 2, [varEmpty, varEmpty], varEmpty);\r\n AddGet(TCustomImageList, 'GetHotSpot', TCustomImageList_GetHotSpot, 0, [varEmpty], varEmpty);\r\n AddGet(TCustomImageList, 'GetIcon', TCustomImageList_GetIcon, 2, [varEmpty, varEmpty], varEmpty);\r\n AddGet(TCustomImageList, 'GetImageBitmap', TCustomImageList_GetImageBitmap, 0, [varEmpty], varEmpty);\r\n AddGet(TCustomImageList, 'GetMaskBitmap', TCustomImageList_GetMaskBitmap, 0, [varEmpty], varEmpty);\r\n AddGet(TCustomImageList, 'GetResource', TCustomImageList_GetResource, 5, [varEmpty, varEmpty, varEmpty, varEmpty,\r\n varEmpty], varEmpty);\r\n AddGet(TCustomImageList, 'GetInstRes', TCustomImageList_GetInstRes, 6, [varEmpty, varEmpty, varEmpty, varEmpty,\r\n varEmpty, varEmpty], varEmpty);\r\n AddGet(TCustomImageList, 'HandleAllocated', TCustomImageList_HandleAllocated, 0, [varEmpty], varEmpty);\r\n AddGet(TCustomImageList, 'Insert', TCustomImageList_Insert, 3, [varEmpty, varEmpty, varEmpty], varEmpty);\r\n AddGet(TCustomImageList, 'InsertIcon', TCustomImageList_InsertIcon, 2, [varEmpty, varEmpty], varEmpty);\r\n AddGet(TCustomImageList, 'InsertMasked', TCustomImageList_InsertMasked, 3, [varEmpty, varEmpty, varEmpty],\r\n varEmpty);\r\n AddGet(TCustomImageList, 'Move', TCustomImageList_Move, 2, [varEmpty, varEmpty], varEmpty);\r\n AddGet(TCustomImageList, 'Overlay', TCustomImageList_Overlay, 2, [varEmpty, varEmpty], varEmpty);\r\n AddGet(TCustomImageList, 'RegisterChanges', TCustomImageList_RegisterChanges, 1, [varEmpty], varEmpty);\r\n AddGet(TCustomImageList, 'ResourceLoad', TCustomImageList_ResourceLoad, 3, [varEmpty, varEmpty, varEmpty],\r\n varEmpty);\r\n AddGet(TCustomImageList, 'ResInstLoad', TCustomImageList_ResInstLoad, 4, [varEmpty, varEmpty, varEmpty, varEmpty],\r\n varEmpty);\r\n AddGet(TCustomImageList, 'Replace', TCustomImageList_Replace, 3, [varEmpty, varEmpty, varEmpty], varEmpty);\r\n AddGet(TCustomImageList, 'ReplaceIcon', TCustomImageList_ReplaceIcon, 2, [varEmpty, varEmpty], varEmpty);\r\n AddGet(TCustomImageList, 'ReplaceMasked', TCustomImageList_ReplaceMasked, 3, [varEmpty, varEmpty, varEmpty],\r\n varEmpty);\r\n AddGet(TCustomImageList, 'UnRegisterChanges', TCustomImageList_UnRegisterChanges, 1, [varEmpty], varEmpty);\r\n AddGet(TCustomImageList, 'Count', TCustomImageList_Read_Count, 0, [varEmpty], varEmpty);\r\n AddGet(TCustomImageList, 'Handle', TCustomImageList_Read_Handle, 0, [varEmpty], varEmpty);\r\n AddSet(TCustomImageList, 'Handle', TCustomImageList_Write_Handle, 0, [varEmpty]);\r\n AddGet(TCustomImageList, 'HideDragImage', TCustomImageList_HideDragImage, 0, [varEmpty], varEmpty);\r\n AddGet(TCustomImageList, 'SetDragImage', TCustomImageList_SetDragImage, 3, [varEmpty, varEmpty, varEmpty],\r\n varEmpty);\r\n AddGet(TCustomImageList, 'ShowDragImage', TCustomImageList_ShowDragImage, 0, [varEmpty], varEmpty);\r\n AddGet(TCustomImageList, 'DragCursor', TCustomImageList_Read_DragCursor, 0, [varEmpty], varEmpty);\r\n AddSet(TCustomImageList, 'DragCursor', TCustomImageList_Write_DragCursor, 0, [varEmpty]);\r\n AddGet(TCustomImageList, 'Dragging', TCustomImageList_Read_Dragging, 0, [varEmpty], varEmpty);\r\n AddGet(TCustomImageList, 'BeginDrag', TCustomImageList_BeginDrag, 3, [varEmpty, varEmpty, varEmpty], varEmpty);\r\n AddGet(TCustomImageList, 'DragLock', TCustomImageList_DragLock, 3, [varEmpty, varEmpty, varEmpty], varEmpty);\r\n AddGet(TCustomImageList, 'DragMove', TCustomImageList_DragMove, 2, [varEmpty, varEmpty], varEmpty);\r\n AddGet(TCustomImageList, 'DragUnlock', TCustomImageList_DragUnlock, 0, [varEmpty], varEmpty);\r\n AddGet(TCustomImageList, 'EndDrag', TCustomImageList_EndDrag, 0, [varEmpty], varEmpty);\r\n AddGet(TDragImageList, 'HideDragImage', TCustomImageList_HideDragImage, 0, [varEmpty], varEmpty);\r\n AddGet(TDragImageList, 'SetDragImage', TCustomImageList_SetDragImage, 3, [varEmpty, varEmpty, varEmpty], varEmpty);\r\n AddGet(TDragImageList, 'ShowDragImage', TCustomImageList_ShowDragImage, 0, [varEmpty], varEmpty);\r\n AddGet(TDragImageList, 'DragCursor', TCustomImageList_Read_DragCursor, 0, [varEmpty], varEmpty);\r\n AddSet(TDragImageList, 'DragCursor', TCustomImageList_Write_DragCursor, 0, [varEmpty]);\r\n AddGet(TDragImageList, 'Dragging', TCustomImageList_Read_Dragging, 0, [varEmpty], varEmpty);\r\n AddGet(TDragImageList, 'BeginDrag', TCustomImageList_BeginDrag, 3, [varEmpty, varEmpty, varEmpty], varEmpty);\r\n AddGet(TDragImageList, 'DragLock', TCustomImageList_DragLock, 3, [varEmpty, varEmpty, varEmpty], varEmpty);\r\n AddGet(TDragImageList, 'DragMove', TCustomImageList_DragMove, 2, [varEmpty, varEmpty], varEmpty);\r\n AddGet(TDragImageList, 'DragUnlock', TCustomImageList_DragUnlock, 0, [varEmpty], varEmpty);\r\n AddGet(TDragImageList, 'EndDrag', TCustomImageList_EndDrag, 0, [varEmpty], varEmpty);\r\n { TImageList }\r\n AddClass(cControls, TImageList, 'TImageList');\r\n AddFunction(cControls, 'IsDragObject', JvInterpreter_IsDragObject, 1, [varEmpty], varEmpty);\r\n AddFunction(cControls, 'FindControl', JvInterpreter_FindControl, 1, [varEmpty], varEmpty);\r\n AddFunction(cControls, 'FindVCLWindow', JvInterpreter_FindVCLWindow, 1, [varEmpty], varEmpty);\r\n AddFunction(cControls, 'FindDragTarget', JvInterpreter_FindDragTarget, 2, [varEmpty, varEmpty], varEmpty);\r\n AddFunction(cControls, 'GetCaptureControl', JvInterpreter_GetCaptureControl, 0, [varEmpty], varEmpty);\r\n AddFunction(cControls, 'SetCaptureControl', JvInterpreter_SetCaptureControl, 1, [varEmpty], varEmpty);\r\n AddFunction(cControls, 'CancelDrag', JvInterpreter_CancelDrag, 0, [varEmpty], varEmpty);\r\n AddFunction(cControls, 'CursorToString', JvInterpreter_CursorToString, 1, [varEmpty], varEmpty);\r\n AddFunction(cControls, 'StringToCursor', JvInterpreter_StringToCursor, 1, [varEmpty], varEmpty);\r\n AddFunction(cControls, 'CursorToIdent', JvInterpreter_CursorToIdent, 2, [varEmpty, varByRef], varEmpty);\r\n AddFunction(cControls, 'IdentToCursor', JvInterpreter_IdentToCursor, 2, [varEmpty, varByRef], varEmpty);\r\n AddFunction(cControls, 'GetShortHint', JvInterpreter_GetShortHint, 1, [varEmpty], varEmpty);\r\n AddFunction(cControls, 'GetLongHint', JvInterpreter_GetLongHint, 1, [varEmpty], varEmpty);\r\n AddFunction(cControls, 'InitWndProc', JvInterpreter_InitWndProc, 4, [varEmpty, varEmpty, varEmpty, varEmpty], varEmpty);\r\n AddFunction(cControls, 'SendAppMessage', JvInterpreter_SendAppMessage, 3, [varEmpty, varEmpty, varEmpty], varEmpty);\r\n AddFunction(cControls, 'MoveWindowOrg', JvInterpreter_MoveWindowOrg, 3, [varEmpty, varEmpty, varEmpty], varEmpty);\r\n AddHandler(cControls, 'TMouseEvent', TJvInterpreterControlsEvent, @TJvInterpreterControlsEvent.MouseEvent);\r\n AddHandler(cControls, 'TMouseMoveEvent', TJvInterpreterControlsEvent, @TJvInterpreterControlsEvent.MouseMoveEvent);\r\n AddHandler(cControls, 'TKeyEvent', TJvInterpreterControlsEvent, @TJvInterpreterControlsEvent.KeyEvent);\r\n AddHandler(cControls, 'TKeyPressEvent', TJvInterpreterControlsEvent, @TJvInterpreterControlsEvent.KeyPressEvent);\r\n AddHandler(cControls, 'TDragOverEvent', TJvInterpreterControlsEvent, @TJvInterpreterControlsEvent.DragOverEvent);\r\n AddHandler(cControls, 'TDragDropEvent', TJvInterpreterControlsEvent, @TJvInterpreterControlsEvent.DragDropEvent);\r\n AddHandler(cControls, 'TStartDragEvent', TJvInterpreterControlsEvent, @TJvInterpreterControlsEvent.StartDragEvent);\r\n AddHandler(cControls, 'TEndDragEvent', TJvInterpreterControlsEvent, @TJvInterpreterControlsEvent.EndDragEvent);\r\n end;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvInterpreter_DBTables.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvInterpreter_DBTables.PAS, released on 2002-07-04.\r\n\r\nThe Initial Developers of the Original Code are: Andrei Prygounkov \r\nCopyright (c) 1999, 2002 Andrei Prygounkov\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nDescription : adapter unit - converts JvInterpreter calls to delphi calls\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvInterpreter_DBTables.pas 13415 2012-09-10 09:51:54Z obones $\r\n\r\nunit JvInterpreter_DBTables;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n {$IFDEF COMPILER10_UP}\r\n DBCommonTypes,\r\n {$ENDIF COMPILER10_UP}\r\n JvInterpreter;\r\n\r\nprocedure RegisterJvInterpreterAdapter(JvInterpreterAdapter: TJvInterpreterAdapter);\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvInterpreter_DBTables.pas $';\r\n Revision: '$Revision: 13415 $';\r\n Date: '$Date: 2012-09-10 11:51:54 +0200 (lun. 10 sept. 2012) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n BDE, Classes, DB, DBTables;\r\n\r\ntype\r\n {$IFDEF COMPILER12_UP}\r\n TJvRecordBuffer = TRecordBuffer; // Delphi 2009\r\n {$ELSE}\r\n TJvRecordBuffer = PAnsiChar;\r\n {$ENDIF COMPILER12_UP}\r\n \r\n{ EDBEngineError }\r\n\r\n{ constructor Create(ErrorCode: DBIResult) }\r\n\r\nprocedure EDBEngineError_Create(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(EDBEngineError.Create(Args.Values[0]));\r\nend;\r\n\r\n{ property Read ErrorCount: Integer }\r\n\r\nprocedure EDBEngineError_Read_ErrorCount(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := EDBEngineError(Args.Obj).ErrorCount;\r\nend;\r\n\r\n{ property Read Errors[Integer]: TDBError }\r\n\r\nprocedure EDBEngineError_Read_Errors(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(EDBEngineError(Args.Obj).Errors[Args.Values[0]]);\r\nend;\r\n\r\n{ ENoResultSet }\r\n\r\n{ TSession }\r\n\r\n{ constructor Create(AOwner: TComponent) }\r\n\r\nprocedure TSession_Create(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TSession.Create(V2O(Args.Values[0]) as TComponent));\r\nend;\r\n\r\n{ procedure AddAlias(const Name, Driver: string; List: TStrings); }\r\n\r\nprocedure TSession_AddAlias(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TSession(Args.Obj).AddAlias(Args.Values[0], Args.Values[1], V2O(Args.Values[2]) as TStrings);\r\nend;\r\n\r\n{ procedure AddDriver(const Name: string; List: TStrings); }\r\n\r\nprocedure TSession_AddDriver(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TSession(Args.Obj).AddDriver(Args.Values[0], V2O(Args.Values[1]) as TStrings);\r\nend;\r\n\r\n{ procedure AddStandardAlias(const Name, Path, DefaultDriver: string); }\r\n\r\nprocedure TSession_AddStandardAlias(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TSession(Args.Obj).AddStandardAlias(Args.Values[0], Args.Values[1], Args.Values[2]);\r\nend;\r\n\r\n{ property Read ConfigMode: TConfigMode }\r\n\r\nprocedure TSession_Read_ConfigMode(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := S2V(Byte(TSession(Args.Obj).ConfigMode));\r\nend;\r\n\r\n{ property Write ConfigMode(Value: TConfigMode) }\r\n\r\nprocedure TSession_Write_ConfigMode(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TSession(Args.Obj).ConfigMode := TConfigMode(Byte(V2S(Value)));\r\nend;\r\n\r\n{ procedure AddPassword(const Password: string); }\r\n\r\nprocedure TSession_AddPassword(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TSession(Args.Obj).AddPassword(Args.Values[0]);\r\nend;\r\n\r\n{ procedure Close; }\r\n\r\nprocedure TSession_Close(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TSession(Args.Obj).Close;\r\nend;\r\n\r\n{ procedure CloseDatabase(Database: TDatabase); }\r\n\r\nprocedure TSession_CloseDatabase(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TSession(Args.Obj).CloseDatabase(V2O(Args.Values[0]) as TDatabase);\r\nend;\r\n\r\n{ procedure DeleteAlias(const Name: string); }\r\n\r\nprocedure TSession_DeleteAlias(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TSession(Args.Obj).DeleteAlias(Args.Values[0]);\r\nend;\r\n\r\n{ procedure DeleteDriver(const Name: string); }\r\n\r\nprocedure TSession_DeleteDriver(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TSession(Args.Obj).DeleteDriver(Args.Values[0]);\r\nend;\r\n\r\n{ procedure DropConnections; }\r\n\r\nprocedure TSession_DropConnections(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TSession(Args.Obj).DropConnections;\r\nend;\r\n\r\n{ function FindDatabase(const DatabaseName: string): TDatabase; }\r\n\r\nprocedure TSession_FindDatabase(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TSession(Args.Obj).FindDatabase(Args.Values[0]));\r\nend;\r\n\r\n{ procedure GetAliasNames(List: TStrings); }\r\n\r\nprocedure TSession_GetAliasNames(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TSession(Args.Obj).GetAliasNames(V2O(Args.Values[0]) as TStrings);\r\nend;\r\n\r\n{ procedure GetAliasParams(const AliasName: string; List: TStrings); }\r\n\r\nprocedure TSession_GetAliasParams(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TSession(Args.Obj).GetAliasParams(Args.Values[0], V2O(Args.Values[1]) as TStrings);\r\nend;\r\n\r\n{ function GetAliasDriverName(const AliasName: string): string; }\r\n\r\nprocedure TSession_GetAliasDriverName(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TSession(Args.Obj).GetAliasDriverName(Args.Values[0]);\r\nend;\r\n\r\n{ procedure GetConfigParams(const Path, Section: string; List: TStrings); }\r\n\r\nprocedure TSession_GetConfigParams(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TSession(Args.Obj).GetConfigParams(Args.Values[0], Args.Values[1], V2O(Args.Values[2]) as TStrings);\r\nend;\r\n\r\n{ procedure GetDatabaseNames(List: TStrings); }\r\n\r\nprocedure TSession_GetDatabaseNames(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TSession(Args.Obj).GetDatabaseNames(V2O(Args.Values[0]) as TStrings);\r\nend;\r\n\r\n{ procedure GetDriverNames(List: TStrings); }\r\n\r\nprocedure TSession_GetDriverNames(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TSession(Args.Obj).GetDriverNames(V2O(Args.Values[0]) as TStrings);\r\nend;\r\n\r\n{ procedure GetDriverParams(const DriverName: string; List: TStrings); }\r\n\r\nprocedure TSession_GetDriverParams(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TSession(Args.Obj).GetDriverParams(Args.Values[0], V2O(Args.Values[1]) as TStrings);\r\nend;\r\n\r\n{ function GetPassword: Boolean; }\r\n\r\nprocedure TSession_GetPassword(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TSession(Args.Obj).GetPassword;\r\nend;\r\n\r\n{ procedure GetTableNames(const DatabaseName, Pattern: string; Extensions, SystemTables: Boolean; List: TStrings); }\r\n\r\nprocedure TSession_GetTableNames(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TSession(Args.Obj).GetTableNames(Args.Values[0], Args.Values[1], Args.Values[2], Args.Values[3], V2O(Args.Values[4]) as\r\n TStrings);\r\nend;\r\n\r\n{ procedure GetStoredProcNames(const DatabaseName: string; List: TStrings); }\r\n\r\nprocedure TSession_GetStoredProcNames(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TSession(Args.Obj).GetStoredProcNames(Args.Values[0], V2O(Args.Values[1]) as TStrings);\r\nend;\r\n\r\n{ function IsAlias(const Name: string): Boolean; }\r\n\r\nprocedure TSession_IsAlias(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TSession(Args.Obj).IsAlias(Args.Values[0]);\r\nend;\r\n\r\n{ procedure ModifyAlias(Name: string; List: TStrings); }\r\n\r\nprocedure TSession_ModifyAlias(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TSession(Args.Obj).ModifyAlias(Args.Values[0], V2O(Args.Values[1]) as TStrings);\r\nend;\r\n\r\n{ procedure ModifyDriver(Name: string; List: TStrings); }\r\n\r\nprocedure TSession_ModifyDriver(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TSession(Args.Obj).ModifyDriver(Args.Values[0], V2O(Args.Values[1]) as TStrings);\r\nend;\r\n\r\n{ procedure Open; }\r\n\r\nprocedure TSession_Open(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TSession(Args.Obj).Open;\r\nend;\r\n\r\n{ function OpenDatabase(const DatabaseName: string): TDatabase; }\r\n\r\nprocedure TSession_OpenDatabase(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TSession(Args.Obj).OpenDatabase(Args.Values[0]));\r\nend;\r\n\r\n{ procedure RemoveAllPasswords; }\r\n\r\nprocedure TSession_RemoveAllPasswords(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TSession(Args.Obj).RemoveAllPasswords;\r\nend;\r\n\r\n{ procedure RemovePassword(const Password: string); }\r\n\r\nprocedure TSession_RemovePassword(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TSession(Args.Obj).RemovePassword(Args.Values[0]);\r\nend;\r\n\r\n{ procedure SaveConfigFile; }\r\n\r\nprocedure TSession_SaveConfigFile(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TSession(Args.Obj).SaveConfigFile;\r\nend;\r\n\r\n{ property Read DatabaseCount: Integer }\r\n\r\nprocedure TSession_Read_DatabaseCount(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TSession(Args.Obj).DatabaseCount;\r\nend;\r\n\r\n{ property Read Databases[Integer]: TDatabase }\r\n\r\nprocedure TSession_Read_Databases(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TSession(Args.Obj).Databases[Args.Values[0]]);\r\nend;\r\n\r\n{ property Read Handle: HDBISES }\r\n\r\nprocedure TSession_Read_Handle(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := NativeInt(TSession(Args.Obj).Handle);\r\nend;\r\n\r\n{ property Read Locale: TLocale }\r\n\r\nprocedure TSession_Read_Locale(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := P2V(TSession(Args.Obj).Locale);\r\nend;\r\n\r\n{ property Read TraceFlags: TTraceFlags }\r\n\r\nprocedure TSession_Read_TraceFlags(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := S2V(Word(TSession(Args.Obj).TraceFlags));\r\nend;\r\n\r\n{ property Write TraceFlags(Value: TTraceFlags) }\r\n\r\nprocedure TSession_Write_TraceFlags(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TSession(Args.Obj).TraceFlags := TTraceFlags(Word(V2S(Value)));\r\nend;\r\n\r\n{ property Read Active: Boolean }\r\n\r\nprocedure TSession_Read_Active(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TSession(Args.Obj).Active;\r\nend;\r\n\r\n{ property Write Active(Value: Boolean) }\r\n\r\nprocedure TSession_Write_Active(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TSession(Args.Obj).Active := Value;\r\nend;\r\n\r\n{ property Read AutoSessionName: Boolean }\r\n\r\nprocedure TSession_Read_AutoSessionName(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TSession(Args.Obj).AutoSessionName;\r\nend;\r\n\r\n{ property Write AutoSessionName(Value: Boolean) }\r\n\r\nprocedure TSession_Write_AutoSessionName(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TSession(Args.Obj).AutoSessionName := Value;\r\nend;\r\n\r\n{ property Read KeepConnections: Boolean }\r\n\r\nprocedure TSession_Read_KeepConnections(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TSession(Args.Obj).KeepConnections;\r\nend;\r\n\r\n{ property Write KeepConnections(Value: Boolean) }\r\n\r\nprocedure TSession_Write_KeepConnections(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TSession(Args.Obj).KeepConnections := Value;\r\nend;\r\n\r\n{ property Read NetFileDir: string }\r\n\r\nprocedure TSession_Read_NetFileDir(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TSession(Args.Obj).NetFileDir;\r\nend;\r\n\r\n{ property Write NetFileDir(Value: string) }\r\n\r\nprocedure TSession_Write_NetFileDir(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TSession(Args.Obj).NetFileDir := Value;\r\nend;\r\n\r\n{ property Read PrivateDir: string }\r\n\r\nprocedure TSession_Read_PrivateDir(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TSession(Args.Obj).PrivateDir;\r\nend;\r\n\r\n{ property Write PrivateDir(Value: string) }\r\n\r\nprocedure TSession_Write_PrivateDir(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TSession(Args.Obj).PrivateDir := Value;\r\nend;\r\n\r\n{ property Read SessionName: string }\r\n\r\nprocedure TSession_Read_SessionName(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TSession(Args.Obj).SessionName;\r\nend;\r\n\r\n{ property Write SessionName(Value: string) }\r\n\r\nprocedure TSession_Write_SessionName(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TSession(Args.Obj).SessionName := Value;\r\nend;\r\n\r\n{ property Read SQLHourGlass: Boolean }\r\n\r\nprocedure TSession_Read_SQLHourGlass(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TSession(Args.Obj).SQLHourGlass;\r\nend;\r\n\r\n{ property Write SQLHourGlass(Value: Boolean) }\r\n\r\nprocedure TSession_Write_SQLHourGlass(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TSession(Args.Obj).SQLHourGlass := Value;\r\nend;\r\n\r\n{ TDatabase }\r\n\r\n{ constructor Create(AOwner: TComponent) }\r\n\r\nprocedure TDatabase_Create(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TDatabase.Create(V2O(Args.Values[0]) as TComponent));\r\nend;\r\n\r\n(*\r\n{ procedure ApplyUpdates(const DataSets: array of TDBDataSet); }\r\nprocedure TDatabase_ApplyUpdates(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TDatabase(Args.Obj).ApplyUpdates(Args.Values[0]);\r\nend;\r\n*)\r\n\r\n{ procedure Close; }\r\n\r\nprocedure TDatabase_Close(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TDatabase(Args.Obj).Close;\r\nend;\r\n\r\n{ procedure CloseDataSets; }\r\n\r\nprocedure TDatabase_CloseDataSets(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TDatabase(Args.Obj).CloseDataSets;\r\nend;\r\n\r\n{ procedure Commit; }\r\n\r\nprocedure TDatabase_Commit(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TDatabase(Args.Obj).Commit;\r\nend;\r\n\r\n{ procedure FlushSchemaCache(const TableName: string); }\r\n\r\nprocedure TDatabase_FlushSchemaCache(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TDatabase(Args.Obj).FlushSchemaCache(Args.Values[0]);\r\nend;\r\n\r\n{ procedure Open; }\r\n\r\nprocedure TDatabase_Open(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TDatabase(Args.Obj).Open;\r\nend;\r\n\r\n{ procedure Rollback; }\r\n\r\nprocedure TDatabase_Rollback(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TDatabase(Args.Obj).Rollback;\r\nend;\r\n\r\n{ procedure StartTransaction; }\r\n\r\nprocedure TDatabase_StartTransaction(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TDatabase(Args.Obj).StartTransaction;\r\nend;\r\n\r\n{ procedure ValidateName(const Name: string); }\r\n\r\nprocedure TDatabase_ValidateName(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TDatabase(Args.Obj).ValidateName(Args.Values[0]);\r\nend;\r\n\r\n{ property Read DataSetCount: Integer }\r\n\r\nprocedure TDatabase_Read_DataSetCount(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TDatabase(Args.Obj).DataSetCount;\r\nend;\r\n\r\n{ property Read DataSets[Integer]: TDBDataSet }\r\n\r\nprocedure TDatabase_Read_DataSets(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TDatabase(Args.Obj).DataSets[Args.Values[0]]);\r\nend;\r\n\r\n{ property Read Directory: string }\r\n\r\nprocedure TDatabase_Read_Directory(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TDatabase(Args.Obj).Directory;\r\nend;\r\n\r\n{ property Write Directory(Value: string) }\r\n\r\nprocedure TDatabase_Write_Directory(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TDatabase(Args.Obj).Directory := Value;\r\nend;\r\n\r\n{ property Read Handle: HDBIDB }\r\n\r\nprocedure TDatabase_Read_Handle(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := NativeInt(TDatabase(Args.Obj).Handle);\r\nend;\r\n\r\n{ property Write Handle(Value: HDBIDB) }\r\n\r\nprocedure TDatabase_Write_Handle(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TDatabase(Args.Obj).Handle := HDBIDB(NativeInt(Value));\r\nend;\r\n\r\n{ property Read IsSQLBased: Boolean }\r\n\r\nprocedure TDatabase_Read_IsSQLBased(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TDatabase(Args.Obj).IsSQLBased;\r\nend;\r\n\r\n{ property Read InTransaction: Boolean }\r\n\r\nprocedure TDatabase_Read_InTransaction(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TDatabase(Args.Obj).InTransaction;\r\nend;\r\n\r\n{ property Read Locale: TLocale }\r\n\r\nprocedure TDatabase_Read_Locale(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := P2V(TDatabase(Args.Obj).Locale);\r\nend;\r\n\r\n{ property Read Session: TSession }\r\n\r\nprocedure TDatabase_Read_Session(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TDatabase(Args.Obj).Session);\r\nend;\r\n\r\n{ property Read Temporary: Boolean }\r\n\r\nprocedure TDatabase_Read_Temporary(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TDatabase(Args.Obj).Temporary;\r\nend;\r\n\r\n{ property Write Temporary(Value: Boolean) }\r\n\r\nprocedure TDatabase_Write_Temporary(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TDatabase(Args.Obj).Temporary := Value;\r\nend;\r\n\r\n{ property Read SessionAlias: Boolean }\r\n\r\nprocedure TDatabase_Read_SessionAlias(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TDatabase(Args.Obj).SessionAlias;\r\nend;\r\n\r\n{ property Read TraceFlags: TTraceFlags }\r\n\r\nprocedure TDatabase_Read_TraceFlags(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := S2V(Word(TDatabase(Args.Obj).TraceFlags));\r\nend;\r\n\r\n{ property Write TraceFlags(Value: TTraceFlags) }\r\n\r\nprocedure TDatabase_Write_TraceFlags(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TDatabase(Args.Obj).TraceFlags := TTraceFlags(Word(V2S(Value)));\r\nend;\r\n\r\n{ property Read AliasName: string }\r\n\r\nprocedure TDatabase_Read_AliasName(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TDatabase(Args.Obj).AliasName;\r\nend;\r\n\r\n{ property Write AliasName(Value: string) }\r\n\r\nprocedure TDatabase_Write_AliasName(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TDatabase(Args.Obj).AliasName := Value;\r\nend;\r\n\r\n{ property Read Connected: Boolean }\r\n\r\nprocedure TDatabase_Read_Connected(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TDatabase(Args.Obj).Connected;\r\nend;\r\n\r\n{ property Write Connected(Value: Boolean) }\r\n\r\nprocedure TDatabase_Write_Connected(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TDatabase(Args.Obj).Connected := Value;\r\nend;\r\n\r\n{ property Read DatabaseName: string }\r\n\r\nprocedure TDatabase_Read_DatabaseName(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TDatabase(Args.Obj).DatabaseName;\r\nend;\r\n\r\n{ property Write DatabaseName(Value: string) }\r\n\r\nprocedure TDatabase_Write_DatabaseName(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TDatabase(Args.Obj).DatabaseName := Value;\r\nend;\r\n\r\n{ property Read DriverName: string }\r\n\r\nprocedure TDatabase_Read_DriverName(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TDatabase(Args.Obj).DriverName;\r\nend;\r\n\r\n{ property Write DriverName(Value: string) }\r\n\r\nprocedure TDatabase_Write_DriverName(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TDatabase(Args.Obj).DriverName := Value;\r\nend;\r\n\r\n{ property Read HandleShared: Boolean }\r\n\r\nprocedure TDatabase_Read_HandleShared(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TDatabase(Args.Obj).HandleShared;\r\nend;\r\n\r\n{ property Write HandleShared(Value: Boolean) }\r\n\r\nprocedure TDatabase_Write_HandleShared(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TDatabase(Args.Obj).HandleShared := Value;\r\nend;\r\n\r\n{ property Read KeepConnection: Boolean }\r\n\r\nprocedure TDatabase_Read_KeepConnection(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TDatabase(Args.Obj).KeepConnection;\r\nend;\r\n\r\n{ property Write KeepConnection(Value: Boolean) }\r\n\r\nprocedure TDatabase_Write_KeepConnection(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TDatabase(Args.Obj).KeepConnection := Value;\r\nend;\r\n\r\n{ property Read LoginPrompt: Boolean }\r\n\r\nprocedure TDatabase_Read_LoginPrompt(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TDatabase(Args.Obj).LoginPrompt;\r\nend;\r\n\r\n{ property Write LoginPrompt(Value: Boolean) }\r\n\r\nprocedure TDatabase_Write_LoginPrompt(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TDatabase(Args.Obj).LoginPrompt := Value;\r\nend;\r\n\r\n{ property Read Params: TStrings }\r\n\r\nprocedure TDatabase_Read_Params(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TDatabase(Args.Obj).Params);\r\nend;\r\n\r\n{ property Write Params(Value: TStrings) }\r\n\r\nprocedure TDatabase_Write_Params(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TDatabase(Args.Obj).Params := V2O(Value) as TStrings;\r\nend;\r\n\r\n{ property Read SessionName: string }\r\n\r\nprocedure TDatabase_Read_SessionName(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TDatabase(Args.Obj).SessionName;\r\nend;\r\n\r\n{ property Write SessionName(Value: string) }\r\n\r\nprocedure TDatabase_Write_SessionName(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TDatabase(Args.Obj).SessionName := Value;\r\nend;\r\n\r\n{ property Read TransIsolation: TTransIsolation }\r\n\r\nprocedure TDatabase_Read_TransIsolation(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TDatabase(Args.Obj).TransIsolation;\r\nend;\r\n\r\n{ property Write TransIsolation(Value: TTransIsolation) }\r\n\r\nprocedure TDatabase_Write_TransIsolation(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TDatabase(Args.Obj).TransIsolation := Value;\r\nend;\r\n\r\n{ TBDEDataSet }\r\n\r\n{ constructor Create(AOwner: TComponent) }\r\n\r\nprocedure TBDEDataSet_Create(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TBDEDataSet.Create(V2O(Args.Values[0]) as TComponent));\r\nend;\r\n\r\n{ procedure ApplyUpdates; }\r\n\r\nprocedure TBDEDataSet_ApplyUpdates(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TBDEDataSet(Args.Obj).ApplyUpdates;\r\nend;\r\n\r\n{ function BookmarkValid(Bookmark: TBookmark): Boolean; }\r\n\r\nprocedure TBDEDataSet_BookmarkValid(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TBDEDataSet(Args.Obj).BookmarkValid(V2P(Args.Values[0]));\r\nend;\r\n\r\n{ procedure Cancel; }\r\n\r\nprocedure TBDEDataSet_Cancel(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TBDEDataSet(Args.Obj).Cancel;\r\nend;\r\n\r\n{ procedure CancelUpdates; }\r\n\r\nprocedure TBDEDataSet_CancelUpdates(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TBDEDataSet(Args.Obj).CancelUpdates;\r\nend;\r\n\r\n{ property Read CacheBlobs: Boolean }\r\n\r\nprocedure TBDEDataSet_Read_CacheBlobs(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TBDEDataSet(Args.Obj).CacheBlobs;\r\nend;\r\n\r\n{ property Write CacheBlobs(Value: Boolean) }\r\n\r\nprocedure TBDEDataSet_Write_CacheBlobs(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TBDEDataSet(Args.Obj).CacheBlobs := Value;\r\nend;\r\n\r\n{ function CompareBookmarks(Bookmark1, Bookmark2: TBookmark): Integer; }\r\n\r\nprocedure TBDEDataSet_CompareBookmarks(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TBDEDataSet(Args.Obj).CompareBookmarks(V2P(Args.Values[0]), V2P(Args.Values[1]));\r\nend;\r\n\r\n{ procedure CommitUpdates; }\r\n\r\nprocedure TBDEDataSet_CommitUpdates(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TBDEDataSet(Args.Obj).CommitUpdates;\r\nend;\r\n\r\n{ function ConstraintsDisabled: Boolean; }\r\n\r\nprocedure TBDEDataSet_ConstraintsDisabled(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TBDEDataSet(Args.Obj).ConstraintsDisabled;\r\nend;\r\n\r\n{ function CreateBlobStream(Field: TField; Mode: TBlobStreamMode): TStream; }\r\n\r\nprocedure TBDEDataSet_CreateBlobStream(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TBDEDataSet(Args.Obj).CreateBlobStream(V2O(Args.Values[0]) as TField, Args.Values[1]));\r\nend;\r\n\r\n{ procedure DisableConstraints; }\r\n\r\nprocedure TBDEDataSet_DisableConstraints(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TBDEDataSet(Args.Obj).DisableConstraints;\r\nend;\r\n\r\n{ procedure EnableConstraints; }\r\n\r\nprocedure TBDEDataSet_EnableConstraints(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TBDEDataSet(Args.Obj).EnableConstraints;\r\nend;\r\n\r\n{ procedure FetchAll; }\r\n\r\nprocedure TBDEDataSet_FetchAll(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TBDEDataSet(Args.Obj).FetchAll;\r\nend;\r\n\r\n{ procedure FlushBuffers; }\r\n\r\nprocedure TBDEDataSet_FlushBuffers(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TBDEDataSet(Args.Obj).FlushBuffers;\r\nend;\r\n\r\n{ function GetCurrentRecord(Buffer: PChar): Boolean; }\r\n\r\nprocedure TBDEDataSet_GetCurrentRecord(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TBDEDataSet(Args.Obj).GetCurrentRecord(TJvRecordBuffer(AnsiString(Args.Values[0])));\r\nend;\r\n\r\n{ procedure GetIndexInfo; }\r\n\r\nprocedure TBDEDataSet_GetIndexInfo(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TBDEDataSet(Args.Obj).GetIndexInfo;\r\nend;\r\n\r\n{ function Locate(const KeyFields: string; const KeyValues: Variant; Options: TLocateOptions): Boolean; }\r\n\r\nprocedure TBDEDataSet_Locate(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TBDEDataSet(Args.Obj).Locate(Args.Values[0], Args.Values[1], TLocateOptions(Byte(V2S(Args.Values[2]))));\r\nend;\r\n\r\n{ function Lookup(const KeyFields: string; const KeyValues: Variant; const ResultFields: string): Variant; }\r\n\r\nprocedure TBDEDataSet_Lookup(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TBDEDataSet(Args.Obj).Lookup(Args.Values[0], Args.Values[1], Args.Values[2]);\r\nend;\r\n\r\n{ function IsSequenced: Boolean; }\r\n\r\nprocedure TBDEDataSet_IsSequenced(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TBDEDataSet(Args.Obj).IsSequenced;\r\nend;\r\n\r\n{ procedure Post; }\r\n\r\nprocedure TBDEDataSet_Post(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TBDEDataSet(Args.Obj).Post;\r\nend;\r\n\r\n{ procedure RevertRecord; }\r\n\r\nprocedure TBDEDataSet_RevertRecord(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TBDEDataSet(Args.Obj).RevertRecord;\r\nend;\r\n\r\n{ function UpdateStatus: TUpdateStatus; }\r\n\r\nprocedure TBDEDataSet_UpdateStatus(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TBDEDataSet(Args.Obj).UpdateStatus;\r\nend;\r\n\r\n{ procedure Translate(Src, Dest: PChar; ToOem: Boolean); }\r\n\r\nprocedure TBDEDataSet_Translate(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TBDEDataSet(Args.Obj).Translate(PAnsiChar(AnsiString(Args.Values[0])), PAnsiChar(AnsiString(Args.Values[1])), Args.Values[2]);\r\nend;\r\n\r\n{ property Read ExpIndex: Boolean }\r\n\r\nprocedure TBDEDataSet_Read_ExpIndex(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TBDEDataSet(Args.Obj).ExpIndex;\r\nend;\r\n\r\n{ property Read Handle: HDBICur }\r\n\r\nprocedure TBDEDataSet_Read_Handle(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := NativeInt(TBDEDataSet(Args.Obj).Handle);\r\nend;\r\n\r\n{ property Read KeySize: Word }\r\n\r\nprocedure TBDEDataSet_Read_KeySize(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TBDEDataSet(Args.Obj).KeySize;\r\nend;\r\n\r\n{ property Read Locale: TLocale }\r\n\r\nprocedure TBDEDataSet_Read_Locale(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := P2V(TBDEDataSet(Args.Obj).Locale);\r\nend;\r\n\r\n{ property Read UpdateObject: TDataSetUpdateObject }\r\n\r\nprocedure TBDEDataSet_Read_UpdateObject(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TBDEDataSet(Args.Obj).UpdateObject);\r\nend;\r\n\r\n{ property Write UpdateObject(Value: TDataSetUpdateObject) }\r\n\r\nprocedure TBDEDataSet_Write_UpdateObject(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TBDEDataSet(Args.Obj).UpdateObject := V2O(Value) as TDataSetUpdateObject;\r\nend;\r\n\r\n{ property Read UpdatesPending: Boolean }\r\n\r\nprocedure TBDEDataSet_Read_UpdatesPending(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TBDEDataSet(Args.Obj).UpdatesPending;\r\nend;\r\n\r\n{ property Read UpdateRecordTypes: TUpdateRecordTypes }\r\n\r\nprocedure TBDEDataSet_Read_UpdateRecordTypes(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := S2V(Byte(TBDEDataSet(Args.Obj).UpdateRecordTypes));\r\nend;\r\n\r\n{ property Write UpdateRecordTypes(Value: TUpdateRecordTypes) }\r\n\r\nprocedure TBDEDataSet_Write_UpdateRecordTypes(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TBDEDataSet(Args.Obj).UpdateRecordTypes := TUpdateRecordTypes(Byte(V2S(Value)));\r\nend;\r\n\r\n{ property Read CachedUpdates: Boolean }\r\n\r\nprocedure TBDEDataSet_Read_CachedUpdates(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TBDEDataSet(Args.Obj).CachedUpdates;\r\nend;\r\n\r\n{ property Write CachedUpdates(Value: Boolean) }\r\n\r\nprocedure TBDEDataSet_Write_CachedUpdates(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TBDEDataSet(Args.Obj).CachedUpdates := Value;\r\nend;\r\n\r\n{ TDBDataSet }\r\n\r\n{ function CheckOpen(Status: DBIResult): Boolean; }\r\n\r\nprocedure TDBDataSet_CheckOpen(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TDBDataSet(Args.Obj).CheckOpen(Args.Values[0]);\r\nend;\r\n\r\n{ procedure CloseDatabase(Database: TDatabase); }\r\n\r\nprocedure TDBDataSet_CloseDatabase(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TDBDataSet(Args.Obj).CloseDatabase(V2O(Args.Values[0]) as TDatabase);\r\nend;\r\n\r\n{ function OpenDatabase: TDatabase; }\r\n\r\nprocedure TDBDataSet_OpenDatabase(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TDBDataSet(Args.Obj).OpenDatabase);\r\nend;\r\n\r\n{ property Read Database: TDatabase }\r\n\r\nprocedure TDBDataSet_Read_Database(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TDBDataSet(Args.Obj).Database);\r\nend;\r\n\r\n{ property Read DBHandle: HDBIDB }\r\n\r\nprocedure TDBDataSet_Read_DBHandle(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := NativeInt(TDBDataSet(Args.Obj).DBHandle);\r\nend;\r\n\r\n{ property Read DBLocale: TLocale }\r\n\r\nprocedure TDBDataSet_Read_DBLocale(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := P2V(TDBDataSet(Args.Obj).DBLocale);\r\nend;\r\n\r\n{ property Read DBSession: TSession }\r\n\r\nprocedure TDBDataSet_Read_DBSession(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TDBDataSet(Args.Obj).DBSession);\r\nend;\r\n\r\n{ property Read DatabaseName: string }\r\n\r\nprocedure TDBDataSet_Read_DatabaseName(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TDBDataSet(Args.Obj).DatabaseName;\r\nend;\r\n\r\n{ property Write DatabaseName(Value: string) }\r\n\r\nprocedure TDBDataSet_Write_DatabaseName(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TDBDataSet(Args.Obj).DatabaseName := Value;\r\nend;\r\n\r\n{ property Read SessionName: string }\r\n\r\nprocedure TDBDataSet_Read_SessionName(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TDBDataSet(Args.Obj).SessionName;\r\nend;\r\n\r\n{ property Write SessionName(Value: string) }\r\n\r\nprocedure TDBDataSet_Write_SessionName(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TDBDataSet(Args.Obj).SessionName := Value;\r\nend;\r\n\r\n{ TTable }\r\n\r\n{ constructor Create(AOwner: TComponent) }\r\n\r\nprocedure TTable_Create(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TTable.Create(V2O(Args.Values[0]) as TComponent));\r\nend;\r\n\r\n{ function BatchMove(ASource: TBDEDataSet; AMode: TBatchMode): Longint; }\r\n\r\nprocedure TTable_BatchMove(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TTable(Args.Obj).BatchMove(V2O(Args.Values[0]) as TBDEDataSet, Args.Values[1]);\r\nend;\r\n\r\n{ procedure AddIndex(const Name, Fields: string; Options: TIndexOptions); }\r\n\r\nprocedure TTable_AddIndex(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TTable(Args.Obj).AddIndex(Args.Values[0], Args.Values[1], TIndexOptions(Byte(V2S(Args.Values[2]))));\r\nend;\r\n\r\n{ procedure ApplyRange; }\r\n\r\nprocedure TTable_ApplyRange(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TTable(Args.Obj).ApplyRange;\r\nend;\r\n\r\n{ procedure CancelRange; }\r\n\r\nprocedure TTable_CancelRange(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TTable(Args.Obj).CancelRange;\r\nend;\r\n\r\n{ procedure CloseIndexFile(const IndexFileName: string); }\r\n\r\nprocedure TTable_CloseIndexFile(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TTable(Args.Obj).CloseIndexFile(Args.Values[0]);\r\nend;\r\n\r\n{ procedure CreateTable; }\r\n\r\nprocedure TTable_CreateTable(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TTable(Args.Obj).CreateTable;\r\nend;\r\n\r\n{ procedure DeleteIndex(const Name: string); }\r\n\r\nprocedure TTable_DeleteIndex(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TTable(Args.Obj).DeleteIndex(Args.Values[0]);\r\nend;\r\n\r\n{ procedure DeleteTable; }\r\n\r\nprocedure TTable_DeleteTable(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TTable(Args.Obj).DeleteTable;\r\nend;\r\n\r\n{ procedure EditKey; }\r\n\r\nprocedure TTable_EditKey(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TTable(Args.Obj).EditKey;\r\nend;\r\n\r\n{ procedure EditRangeEnd; }\r\n\r\nprocedure TTable_EditRangeEnd(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TTable(Args.Obj).EditRangeEnd;\r\nend;\r\n\r\n{ procedure EditRangeStart; }\r\n\r\nprocedure TTable_EditRangeStart(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TTable(Args.Obj).EditRangeStart;\r\nend;\r\n\r\n{ procedure EmptyTable; }\r\n\r\nprocedure TTable_EmptyTable(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TTable(Args.Obj).EmptyTable;\r\nend;\r\n\r\n{ function FindKey(const KeyValues: array of const): Boolean; }\r\n\r\nprocedure TTable_FindKey(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Args.OpenArray(0);\r\n Value := TTable(Args.Obj).FindKey(Slice(Args.OA^, Args.OAS));\r\nend;\r\n\r\n{ procedure FindNearest(const KeyValues: array of const); }\r\n\r\nprocedure TTable_FindNearest(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Args.OpenArray(0);\r\n TTable(Args.Obj).FindNearest(Slice(Args.OA^, Args.OAS));\r\nend;\r\n\r\n{ procedure GetIndexNames(List: TStrings); }\r\n\r\nprocedure TTable_GetIndexNames(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TTable(Args.Obj).GetIndexNames(V2O(Args.Values[0]) as TStrings);\r\nend;\r\n\r\n{ procedure GotoCurrent(Table: TTable); }\r\n\r\nprocedure TTable_GotoCurrent(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TTable(Args.Obj).GotoCurrent(V2O(Args.Values[0]) as TTable);\r\nend;\r\n\r\n{ function GotoKey: Boolean; }\r\n\r\nprocedure TTable_GotoKey(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TTable(Args.Obj).GotoKey;\r\nend;\r\n\r\n{ procedure GotoNearest; }\r\n\r\nprocedure TTable_GotoNearest(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TTable(Args.Obj).GotoNearest;\r\nend;\r\n\r\n{ procedure LockTable(LockType: TLockType); }\r\n\r\nprocedure TTable_LockTable(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TTable(Args.Obj).LockTable(Args.Values[0]);\r\nend;\r\n\r\n{ procedure OpenIndexFile(const IndexName: string); }\r\n\r\nprocedure TTable_OpenIndexFile(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TTable(Args.Obj).OpenIndexFile(Args.Values[0]);\r\nend;\r\n\r\n{ procedure RenameTable(const NewTableName: string); }\r\n\r\nprocedure TTable_RenameTable(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TTable(Args.Obj).RenameTable(Args.Values[0]);\r\nend;\r\n\r\n{ procedure SetKey; }\r\n\r\nprocedure TTable_SetKey(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TTable(Args.Obj).SetKey;\r\nend;\r\n\r\n{ procedure SetRange(const StartValues, EndValues: array of const); }\r\n\r\nprocedure TTable_SetRange(var Value: Variant; Args: TJvInterpreterArgs);\r\nvar\r\n OA: TOpenArray;\r\n OAV: TValueArray;\r\n OAS: Integer;\r\nbegin\r\n Args.OpenArray(0);\r\n V2OA(Args.Values[1], OA, OAV, OAS);\r\n TTable(Args.Obj).SetRange(Slice(Args.OA^, Args.OAS), OA);\r\nend;\r\n\r\n{ procedure SetRangeEnd; }\r\n\r\nprocedure TTable_SetRangeEnd(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TTable(Args.Obj).SetRangeEnd;\r\nend;\r\n\r\n{ procedure SetRangeStart; }\r\n\r\nprocedure TTable_SetRangeStart(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TTable(Args.Obj).SetRangeStart;\r\nend;\r\n\r\n{ procedure UnlockTable(LockType: TLockType); }\r\n\r\nprocedure TTable_UnlockTable(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TTable(Args.Obj).UnlockTable(Args.Values[0]);\r\nend;\r\n\r\n{ property Read IndexDefs: TIndexDefs }\r\n\r\nprocedure TTable_Read_IndexDefs(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TTable(Args.Obj).IndexDefs);\r\nend;\r\n\r\n{ property Read IndexFieldCount: Integer }\r\n\r\nprocedure TTable_Read_IndexFieldCount(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TTable(Args.Obj).IndexFieldCount;\r\nend;\r\n\r\n{ property Read IndexFields[Integer]: TField }\r\n\r\nprocedure TTable_Read_IndexFields(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TTable(Args.Obj).IndexFields[Args.Values[0]]);\r\nend;\r\n\r\n{ property Write IndexFields[Integer]: TField }\r\n\r\nprocedure TTable_Write_IndexFields(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TTable(Args.Obj).IndexFields[Args.Values[0]] := V2O(Value) as TField;\r\nend;\r\n\r\n{ property Read KeyExclusive: Boolean }\r\n\r\nprocedure TTable_Read_KeyExclusive(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TTable(Args.Obj).KeyExclusive;\r\nend;\r\n\r\n{ property Write KeyExclusive(Value: Boolean) }\r\n\r\nprocedure TTable_Write_KeyExclusive(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TTable(Args.Obj).KeyExclusive := Value;\r\nend;\r\n\r\n{ property Read KeyFieldCount: Integer }\r\n\r\nprocedure TTable_Read_KeyFieldCount(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TTable(Args.Obj).KeyFieldCount;\r\nend;\r\n\r\n{ property Write KeyFieldCount(Value: Integer) }\r\n\r\nprocedure TTable_Write_KeyFieldCount(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TTable(Args.Obj).KeyFieldCount := Value;\r\nend;\r\n\r\n{ property Read TableLevel: Integer }\r\n\r\nprocedure TTable_Read_TableLevel(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TTable(Args.Obj).TableLevel;\r\nend;\r\n\r\n{ property Write TableLevel(Value: Integer) }\r\n\r\nprocedure TTable_Write_TableLevel(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TTable(Args.Obj).TableLevel := Value;\r\nend;\r\n\r\n{ property Read Exclusive: Boolean }\r\n\r\nprocedure TTable_Read_Exclusive(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TTable(Args.Obj).Exclusive;\r\nend;\r\n\r\n{ property Write Exclusive(Value: Boolean) }\r\n\r\nprocedure TTable_Write_Exclusive(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TTable(Args.Obj).Exclusive := Value;\r\nend;\r\n\r\n{ property Read IndexFieldNames: string }\r\n\r\nprocedure TTable_Read_IndexFieldNames(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TTable(Args.Obj).IndexFieldNames;\r\nend;\r\n\r\n{ property Write IndexFieldNames(Value: string) }\r\n\r\nprocedure TTable_Write_IndexFieldNames(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TTable(Args.Obj).IndexFieldNames := Value;\r\nend;\r\n\r\n{ property Read IndexFiles: TStrings }\r\n\r\nprocedure TTable_Read_IndexFiles(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TTable(Args.Obj).IndexFiles);\r\nend;\r\n\r\n{ property Write IndexFiles(Value: TStrings) }\r\n\r\nprocedure TTable_Write_IndexFiles(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TTable(Args.Obj).IndexFiles := V2O(Value) as TStrings;\r\nend;\r\n\r\n{ property Read IndexName: string }\r\n\r\nprocedure TTable_Read_IndexName(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TTable(Args.Obj).IndexName;\r\nend;\r\n\r\n{ property Write IndexName(Value: string) }\r\n\r\nprocedure TTable_Write_IndexName(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TTable(Args.Obj).IndexName := Value;\r\nend;\r\n\r\n{ property Read MasterFields: string }\r\n\r\nprocedure TTable_Read_MasterFields(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TTable(Args.Obj).MasterFields;\r\nend;\r\n\r\n{ property Write MasterFields(Value: string) }\r\n\r\nprocedure TTable_Write_MasterFields(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TTable(Args.Obj).MasterFields := Value;\r\nend;\r\n\r\n{ property Read MasterSource: TDataSource }\r\n\r\nprocedure TTable_Read_MasterSource(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TTable(Args.Obj).MasterSource);\r\nend;\r\n\r\n{ property Write MasterSource(Value: TDataSource) }\r\n\r\nprocedure TTable_Write_MasterSource(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TTable(Args.Obj).MasterSource := V2O(Value) as TDataSource;\r\nend;\r\n\r\n{ property Read ReadOnly: Boolean }\r\n\r\nprocedure TTable_Read_ReadOnly(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TTable(Args.Obj).ReadOnly;\r\nend;\r\n\r\n{ property Write ReadOnly(Value: Boolean) }\r\n\r\nprocedure TTable_Write_ReadOnly(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TTable(Args.Obj).ReadOnly := Value;\r\nend;\r\n\r\n{ property Read TableName: TFileName }\r\n\r\nprocedure TTable_Read_TableName(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TTable(Args.Obj).TableName;\r\nend;\r\n\r\n{ property Write TableName(Value: TFileName) }\r\n\r\nprocedure TTable_Write_TableName(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TTable(Args.Obj).TableName := Value;\r\nend;\r\n\r\n{ property Read TableType: TTableType }\r\n\r\nprocedure TTable_Read_TableType(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TTable(Args.Obj).TableType;\r\nend;\r\n\r\n{ property Write TableType(Value: TTableType) }\r\n\r\nprocedure TTable_Write_TableType(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TTable(Args.Obj).TableType := Value;\r\nend;\r\n\r\n{ TBatchMove }\r\n\r\n{ constructor Create(AOwner: TComponent) }\r\n\r\nprocedure TBatchMove_Create(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TBatchMove.Create(V2O(Args.Values[0]) as TComponent));\r\nend;\r\n\r\n{ procedure Execute; }\r\n\r\nprocedure TBatchMove_Execute(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TBatchMove(Args.Obj).Execute;\r\nend;\r\n\r\n{ property Read ChangedCount: Longint }\r\n\r\nprocedure TBatchMove_Read_ChangedCount(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TBatchMove(Args.Obj).ChangedCount;\r\nend;\r\n\r\n{ property Read KeyViolCount: Longint }\r\n\r\nprocedure TBatchMove_Read_KeyViolCount(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TBatchMove(Args.Obj).KeyViolCount;\r\nend;\r\n\r\n{ property Read MovedCount: Longint }\r\n\r\nprocedure TBatchMove_Read_MovedCount(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TBatchMove(Args.Obj).MovedCount;\r\nend;\r\n\r\n{ property Read ProblemCount: Longint }\r\n\r\nprocedure TBatchMove_Read_ProblemCount(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TBatchMove(Args.Obj).ProblemCount;\r\nend;\r\n\r\n{ property Read AbortOnKeyViol: Boolean }\r\n\r\nprocedure TBatchMove_Read_AbortOnKeyViol(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TBatchMove(Args.Obj).AbortOnKeyViol;\r\nend;\r\n\r\n{ property Write AbortOnKeyViol(Value: Boolean) }\r\n\r\nprocedure TBatchMove_Write_AbortOnKeyViol(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TBatchMove(Args.Obj).AbortOnKeyViol := Value;\r\nend;\r\n\r\n{ property Read AbortOnProblem: Boolean }\r\n\r\nprocedure TBatchMove_Read_AbortOnProblem(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TBatchMove(Args.Obj).AbortOnProblem;\r\nend;\r\n\r\n{ property Write AbortOnProblem(Value: Boolean) }\r\n\r\nprocedure TBatchMove_Write_AbortOnProblem(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TBatchMove(Args.Obj).AbortOnProblem := Value;\r\nend;\r\n\r\n{ property Read CommitCount: Integer }\r\n\r\nprocedure TBatchMove_Read_CommitCount(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TBatchMove(Args.Obj).CommitCount;\r\nend;\r\n\r\n{ property Write CommitCount(Value: Integer) }\r\n\r\nprocedure TBatchMove_Write_CommitCount(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TBatchMove(Args.Obj).CommitCount := Value;\r\nend;\r\n\r\n{ property Read ChangedTableName: TFileName }\r\n\r\nprocedure TBatchMove_Read_ChangedTableName(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TBatchMove(Args.Obj).ChangedTableName;\r\nend;\r\n\r\n{ property Write ChangedTableName(Value: TFileName) }\r\n\r\nprocedure TBatchMove_Write_ChangedTableName(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TBatchMove(Args.Obj).ChangedTableName := Value;\r\nend;\r\n\r\n{ property Read Destination: TTable }\r\n\r\nprocedure TBatchMove_Read_Destination(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TBatchMove(Args.Obj).Destination);\r\nend;\r\n\r\n{ property Write Destination(Value: TTable) }\r\n\r\nprocedure TBatchMove_Write_Destination(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TBatchMove(Args.Obj).Destination := V2O(Value) as TTable;\r\nend;\r\n\r\n{ property Read KeyViolTableName: TFileName }\r\n\r\nprocedure TBatchMove_Read_KeyViolTableName(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TBatchMove(Args.Obj).KeyViolTableName;\r\nend;\r\n\r\n{ property Write KeyViolTableName(Value: TFileName) }\r\n\r\nprocedure TBatchMove_Write_KeyViolTableName(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TBatchMove(Args.Obj).KeyViolTableName := Value;\r\nend;\r\n\r\n{ property Read Mappings: TStrings }\r\n\r\nprocedure TBatchMove_Read_Mappings(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TBatchMove(Args.Obj).Mappings);\r\nend;\r\n\r\n{ property Write Mappings(Value: TStrings) }\r\n\r\nprocedure TBatchMove_Write_Mappings(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TBatchMove(Args.Obj).Mappings := V2O(Value) as TStrings;\r\nend;\r\n\r\n{ property Read Mode: TBatchMode }\r\n\r\nprocedure TBatchMove_Read_Mode(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TBatchMove(Args.Obj).Mode;\r\nend;\r\n\r\n{ property Write Mode(Value: TBatchMode) }\r\n\r\nprocedure TBatchMove_Write_Mode(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TBatchMove(Args.Obj).Mode := Value;\r\nend;\r\n\r\n{ property Read ProblemTableName: TFileName }\r\n\r\nprocedure TBatchMove_Read_ProblemTableName(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TBatchMove(Args.Obj).ProblemTableName;\r\nend;\r\n\r\n{ property Write ProblemTableName(Value: TFileName) }\r\n\r\nprocedure TBatchMove_Write_ProblemTableName(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TBatchMove(Args.Obj).ProblemTableName := Value;\r\nend;\r\n\r\n{ property Read RecordCount: Longint }\r\n\r\nprocedure TBatchMove_Read_RecordCount(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TBatchMove(Args.Obj).RecordCount;\r\nend;\r\n\r\n{ property Write RecordCount(Value: Longint) }\r\n\r\nprocedure TBatchMove_Write_RecordCount(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TBatchMove(Args.Obj).RecordCount := Value;\r\nend;\r\n\r\n{ property Read Source: TBDEDataSet }\r\n\r\nprocedure TBatchMove_Read_Source(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TBatchMove(Args.Obj).Source);\r\nend;\r\n\r\n{ property Write Source(Value: TBDEDataSet) }\r\n\r\nprocedure TBatchMove_Write_Source(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TBatchMove(Args.Obj).Source := V2O(Value) as TBDEDataSet;\r\nend;\r\n\r\n{ property Read Transliterate: Boolean }\r\n\r\nprocedure TBatchMove_Read_Transliterate(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TBatchMove(Args.Obj).Transliterate;\r\nend;\r\n\r\n{ property Write Transliterate(Value: Boolean) }\r\n\r\nprocedure TBatchMove_Write_Transliterate(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TBatchMove(Args.Obj).Transliterate := Value;\r\nend;\r\n\r\n{ TParam }\r\n\r\n{ constructor Create(AParamList: TParams; AParamType: TParamType) }\r\n\r\nprocedure TParam_Create(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TParam.Create(V2O(Args.Values[0]) as TParams, Args.Values[1]));\r\nend;\r\n\r\n{ procedure Assign(Source: TPersistent); }\r\n\r\nprocedure TParam_Assign(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TParam(Args.Obj).Assign(V2O(Args.Values[0]) as TParam);\r\nend;\r\n\r\n{ procedure AssignField(Field: TField); }\r\n\r\nprocedure TParam_AssignField(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TParam(Args.Obj).AssignField(V2O(Args.Values[0]) as TField);\r\nend;\r\n\r\n{ procedure AssignFieldValue(Field: TField; const Value: Variant); }\r\n\r\nprocedure TParam_AssignFieldValue(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TParam(Args.Obj).AssignFieldValue(V2O(Args.Values[0]) as TField, Args.Values[1]);\r\nend;\r\n\r\n{ procedure Clear; }\r\n\r\nprocedure TParam_Clear(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TParam(Args.Obj).Clear;\r\nend;\r\n\r\n{ procedure GetData(Buffer: Pointer); }\r\n\r\nprocedure TParam_GetData(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TParam(Args.Obj).GetData(V2P(Args.Values[0]));\r\nend;\r\n\r\n{ function GetDataSize: Integer; }\r\n\r\nprocedure TParam_GetDataSize(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TParam(Args.Obj).GetDataSize;\r\nend;\r\n\r\n{ procedure LoadFromFile(const FileName: string; BlobType: TBlobType); }\r\n\r\nprocedure TParam_LoadFromFile(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TParam(Args.Obj).LoadFromFile(Args.Values[0], Args.Values[1]);\r\nend;\r\n\r\n{ procedure LoadFromStream(Stream: TStream; BlobType: TBlobType); }\r\n\r\nprocedure TParam_LoadFromStream(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TParam(Args.Obj).LoadFromStream(V2O(Args.Values[0]) as TStream, Args.Values[1]);\r\nend;\r\n\r\n{ procedure SetBlobData(Buffer: Pointer; Size: Integer); }\r\n\r\nprocedure TParam_SetBlobData(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TParam(Args.Obj).SetBlobData(V2P(Args.Values[0]), Args.Values[1]);\r\nend;\r\n\r\n{ procedure SetData(Buffer: Pointer); }\r\n\r\nprocedure TParam_SetData(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TParam(Args.Obj).SetData(V2P(Args.Values[0]));\r\nend;\r\n\r\n{ property Read AsBCD: Currency }\r\n\r\nprocedure TParam_Read_AsBCD(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TParam(Args.Obj).AsBCD;\r\nend;\r\n\r\n{ property Write AsBCD(Value: Currency) }\r\n\r\nprocedure TParam_Write_AsBCD(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TParam(Args.Obj).AsBCD := Value;\r\nend;\r\n\r\n{ property Read AsBlob: TBlobData }\r\n\r\nprocedure TParam_Read_AsBlob(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TParam(Args.Obj).AsBlob;\r\nend;\r\n\r\n{ property Write AsBlob(Value: TBlobData) }\r\n\r\nprocedure TParam_Write_AsBlob(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TParam(Args.Obj).AsBlob := Value;\r\nend;\r\n\r\n{ property Read AsBoolean: Boolean }\r\n\r\nprocedure TParam_Read_AsBoolean(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TParam(Args.Obj).AsBoolean;\r\nend;\r\n\r\n{ property Write AsBoolean(Value: Boolean) }\r\n\r\nprocedure TParam_Write_AsBoolean(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TParam(Args.Obj).AsBoolean := Value;\r\nend;\r\n\r\n{ property Read AsCurrency: Double }\r\n\r\nprocedure TParam_Read_AsCurrency(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TParam(Args.Obj).AsCurrency;\r\nend;\r\n\r\n{ property Write AsCurrency(Value: Double) }\r\n\r\nprocedure TParam_Write_AsCurrency(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TParam(Args.Obj).AsCurrency := Value;\r\nend;\r\n\r\n{ property Read AsDate: TDateTime }\r\n\r\nprocedure TParam_Read_AsDate(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TParam(Args.Obj).AsDate;\r\nend;\r\n\r\n{ property Write AsDate(Value: TDateTime) }\r\n\r\nprocedure TParam_Write_AsDate(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TParam(Args.Obj).AsDate := Value;\r\nend;\r\n\r\n{ property Read AsDateTime: TDateTime }\r\n\r\nprocedure TParam_Read_AsDateTime(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TParam(Args.Obj).AsDateTime;\r\nend;\r\n\r\n{ property Write AsDateTime(Value: TDateTime) }\r\n\r\nprocedure TParam_Write_AsDateTime(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TParam(Args.Obj).AsDateTime := Value;\r\nend;\r\n\r\n{ property Read AsFloat: Double }\r\n\r\nprocedure TParam_Read_AsFloat(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TParam(Args.Obj).AsFloat;\r\nend;\r\n\r\n{ property Write AsFloat(Value: Double) }\r\n\r\nprocedure TParam_Write_AsFloat(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TParam(Args.Obj).AsFloat := Value;\r\nend;\r\n\r\n{ property Read AsInteger: Longint }\r\n\r\nprocedure TParam_Read_AsInteger(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TParam(Args.Obj).AsInteger;\r\nend;\r\n\r\n{ property Write AsInteger(Value: Longint) }\r\n\r\nprocedure TParam_Write_AsInteger(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TParam(Args.Obj).AsInteger := Value;\r\nend;\r\n\r\n{ property Read AsSmallInt: Longint }\r\n\r\nprocedure TParam_Read_AsSmallInt(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TParam(Args.Obj).AsSmallInt;\r\nend;\r\n\r\n{ property Write AsSmallInt(Value: Longint) }\r\n\r\nprocedure TParam_Write_AsSmallInt(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TParam(Args.Obj).AsSmallInt := Value;\r\nend;\r\n\r\n{ property Read AsMemo: string }\r\n\r\nprocedure TParam_Read_AsMemo(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TParam(Args.Obj).AsMemo;\r\nend;\r\n\r\n{ property Write AsMemo(Value: string) }\r\n\r\nprocedure TParam_Write_AsMemo(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TParam(Args.Obj).AsMemo := Value;\r\nend;\r\n\r\n{ property Read AsString: string }\r\n\r\nprocedure TParam_Read_AsString(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TParam(Args.Obj).AsString;\r\nend;\r\n\r\n{ property Write AsString(Value: string) }\r\n\r\nprocedure TParam_Write_AsString(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TParam(Args.Obj).AsString := Value;\r\nend;\r\n\r\n{ property Read AsTime: TDateTime }\r\n\r\nprocedure TParam_Read_AsTime(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TParam(Args.Obj).AsTime;\r\nend;\r\n\r\n{ property Write AsTime(Value: TDateTime) }\r\n\r\nprocedure TParam_Write_AsTime(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TParam(Args.Obj).AsTime := Value;\r\nend;\r\n\r\n{ property Read AsWord: Longint }\r\n\r\nprocedure TParam_Read_AsWord(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TParam(Args.Obj).AsWord;\r\nend;\r\n\r\n{ property Write AsWord(Value: Longint) }\r\n\r\nprocedure TParam_Write_AsWord(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TParam(Args.Obj).AsWord := Value;\r\nend;\r\n\r\n{ property Read Bound: Boolean }\r\n\r\nprocedure TParam_Read_Bound(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TParam(Args.Obj).Bound;\r\nend;\r\n\r\n{ property Write Bound(Value: Boolean) }\r\n\r\nprocedure TParam_Write_Bound(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TParam(Args.Obj).Bound := Value;\r\nend;\r\n\r\n{ property Read DataType: TFieldType }\r\n\r\nprocedure TParam_Read_DataType(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TParam(Args.Obj).DataType;\r\nend;\r\n\r\n{ property Write DataType(Value: TFieldType) }\r\n\r\nprocedure TParam_Write_DataType(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TParam(Args.Obj).DataType := Value;\r\nend;\r\n\r\n{ property Read IsNull: Boolean }\r\n\r\nprocedure TParam_Read_IsNull(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TParam(Args.Obj).IsNull;\r\nend;\r\n\r\n{ property Read Name: string }\r\n\r\nprocedure TParam_Read_Name(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TParam(Args.Obj).Name;\r\nend;\r\n\r\n{ property Write Name(Value: string) }\r\n\r\nprocedure TParam_Write_Name(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TParam(Args.Obj).Name := Value;\r\nend;\r\n\r\n{ property Read ParamType: TParamType }\r\n\r\nprocedure TParam_Read_ParamType(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TParam(Args.Obj).ParamType;\r\nend;\r\n\r\n{ property Write ParamType(Value: TParamType) }\r\n\r\nprocedure TParam_Write_ParamType(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TParam(Args.Obj).ParamType := Value;\r\nend;\r\n\r\n{ property Read Text: string }\r\n\r\nprocedure TParam_Read_Text(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TParam(Args.Obj).Text;\r\nend;\r\n\r\n{ property Write Text(Value: string) }\r\n\r\nprocedure TParam_Write_Text(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TParam(Args.Obj).Text := Value;\r\nend;\r\n\r\n{ property Read Value: Variant }\r\n\r\nprocedure TParam_Read_Value(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TParam(Args.Obj).Value;\r\nend;\r\n\r\n{ property Write Value(Value: Variant) }\r\n\r\nprocedure TParam_Write_Value(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TParam(Args.Obj).Value := Value;\r\nend;\r\n\r\n{ TParams }\r\n\r\n{ constructor Create }\r\n\r\nprocedure TParams_Create(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TParams.Create);\r\nend;\r\n\r\n{ procedure Assign(Source: TPersistent); }\r\n\r\nprocedure TParams_Assign(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TParams(Args.Obj).Assign(V2O(Args.Values[0]) as TPersistent);\r\nend;\r\n\r\n{ procedure AssignValues(Value: TParams); }\r\n\r\nprocedure TParams_AssignValues(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TParams(Args.Obj).AssignValues(V2O(Args.Values[0]) as TParams);\r\nend;\r\n\r\n{ procedure AddParam(Value: TParam); }\r\n\r\nprocedure TParams_AddParam(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TParams(Args.Obj).AddParam(V2O(Args.Values[0]) as TParam);\r\nend;\r\n\r\n{ procedure RemoveParam(Value: TParam); }\r\n\r\nprocedure TParams_RemoveParam(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TParams(Args.Obj).RemoveParam(V2O(Args.Values[0]) as TParam);\r\nend;\r\n\r\n{ function CreateParam(FldType: TFieldType; const ParamName: string; ParamType: TParamType): TParam; }\r\n\r\nprocedure TParams_CreateParam(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TParams(Args.Obj).CreateParam(Args.Values[0], Args.Values[1], Args.Values[2]));\r\nend;\r\n\r\n{ function Count: Integer; }\r\n\r\nprocedure TParams_Count(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TParams(Args.Obj).Count;\r\nend;\r\n\r\n{ procedure Clear; }\r\n\r\nprocedure TParams_Clear(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TParams(Args.Obj).Clear;\r\nend;\r\n\r\n{ procedure GetParamList(List: TList; const ParamNames: string); }\r\n\r\nprocedure TParams_GetParamList(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TParams(Args.Obj).GetParamList(V2O(Args.Values[0]) as TList, Args.Values[1]);\r\nend;\r\n\r\n{ function IsEqual(Value: TParams): Boolean; }\r\n\r\nprocedure TParams_IsEqual(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TParams(Args.Obj).IsEqual(V2O(Args.Values[0]) as TParams);\r\nend;\r\n\r\n{ function ParamByName(const Value: string): TParam; }\r\n\r\nprocedure TParams_ParamByName(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TParams(Args.Obj).ParamByName(Args.Values[0]));\r\nend;\r\n\r\n{ property Read Items[Word]: TParam }\r\n\r\nprocedure TParams_Read_Items(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TParams(Args.Obj).Items[Args.Values[0]]);\r\nend;\r\n\r\n{ TStoredProc }\r\n\r\n{ constructor Create(AOwner: TComponent) }\r\n\r\nprocedure TStoredProc_Create(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TStoredProc.Create(V2O(Args.Values[0]) as TComponent));\r\nend;\r\n\r\n{ procedure CopyParams(Value: TParams); }\r\n\r\nprocedure TStoredProc_CopyParams(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TStoredProc(Args.Obj).CopyParams(V2O(Args.Values[0]) as TParams);\r\nend;\r\n\r\n{ function DescriptionsAvailable: Boolean; }\r\n\r\nprocedure TStoredProc_DescriptionsAvailable(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TStoredProc(Args.Obj).DescriptionsAvailable;\r\nend;\r\n\r\n{ procedure ExecProc; }\r\n\r\nprocedure TStoredProc_ExecProc(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TStoredProc(Args.Obj).ExecProc;\r\nend;\r\n\r\n{ function ParamByName(const Value: string): TParam; }\r\n\r\nprocedure TStoredProc_ParamByName(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TStoredProc(Args.Obj).ParamByName(Args.Values[0]));\r\nend;\r\n\r\n{ procedure Prepare; }\r\n\r\nprocedure TStoredProc_Prepare(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TStoredProc(Args.Obj).Prepare;\r\nend;\r\n\r\n{ procedure GetResults; }\r\n\r\nprocedure TStoredProc_GetResults(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TStoredProc(Args.Obj).GetResults;\r\nend;\r\n\r\n{ procedure UnPrepare; }\r\n\r\nprocedure TStoredProc_UnPrepare(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TStoredProc(Args.Obj).UnPrepare;\r\nend;\r\n\r\n{ property Read ParamCount: Word }\r\n\r\nprocedure TStoredProc_Read_ParamCount(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TStoredProc(Args.Obj).ParamCount;\r\nend;\r\n\r\n{ property Read StmtHandle: HDBIStmt }\r\n\r\nprocedure TStoredProc_Read_StmtHandle(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := P2V(TStoredProc(Args.Obj).StmtHandle);\r\nend;\r\n\r\n{ property Read Prepared: Boolean }\r\n\r\nprocedure TStoredProc_Read_Prepared(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TStoredProc(Args.Obj).Prepared;\r\nend;\r\n\r\n{ property Write Prepared(Value: Boolean) }\r\n\r\nprocedure TStoredProc_Write_Prepared(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TStoredProc(Args.Obj).Prepared := Value;\r\nend;\r\n\r\n{ property Read StoredProcName: string }\r\n\r\nprocedure TStoredProc_Read_StoredProcName(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TStoredProc(Args.Obj).StoredProcName;\r\nend;\r\n\r\n{ property Write StoredProcName(Value: string) }\r\n\r\nprocedure TStoredProc_Write_StoredProcName(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TStoredProc(Args.Obj).StoredProcName := Value;\r\nend;\r\n\r\n{ property Read Overload: Word }\r\n\r\nprocedure TStoredProc_Read_Overload(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TStoredProc(Args.Obj).Overload;\r\nend;\r\n\r\n{ property Write Overload(Value: Word) }\r\n\r\nprocedure TStoredProc_Write_Overload(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TStoredProc(Args.Obj).Overload := Value;\r\nend;\r\n\r\n{ property Read Params: TParams }\r\n\r\nprocedure TStoredProc_Read_Params(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TStoredProc(Args.Obj).Params);\r\nend;\r\n\r\n{ property Write Params(Value: TParams) }\r\n\r\nprocedure TStoredProc_Write_Params(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TStoredProc(Args.Obj).Params := V2O(Value) as TParams;\r\nend;\r\n\r\n{ property Read ParamBindMode: TParamBindMode }\r\n\r\nprocedure TStoredProc_Read_ParamBindMode(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TStoredProc(Args.Obj).ParamBindMode;\r\nend;\r\n\r\n{ property Write ParamBindMode(Value: TParamBindMode) }\r\n\r\nprocedure TStoredProc_Write_ParamBindMode(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TStoredProc(Args.Obj).ParamBindMode := Value;\r\nend;\r\n\r\n{ TQuery }\r\n\r\n{ constructor Create(AOwner: TComponent) }\r\n\r\nprocedure TQuery_Create(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TQuery.Create(V2O(Args.Values[0]) as TComponent));\r\nend;\r\n\r\n{ procedure ExecSQL; }\r\n\r\nprocedure TQuery_ExecSQL(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TQuery(Args.Obj).ExecSQL;\r\nend;\r\n\r\n{ function ParamByName(const Value: string): TParam; }\r\n\r\nprocedure TQuery_ParamByName(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TQuery(Args.Obj).ParamByName(Args.Values[0]));\r\nend;\r\n\r\n{ procedure Prepare; }\r\n\r\nprocedure TQuery_Prepare(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TQuery(Args.Obj).Prepare;\r\nend;\r\n\r\n{ procedure UnPrepare; }\r\n\r\nprocedure TQuery_UnPrepare(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TQuery(Args.Obj).UnPrepare;\r\nend;\r\n\r\n{ property Read Prepared: Boolean }\r\n\r\nprocedure TQuery_Read_Prepared(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TQuery(Args.Obj).Prepared;\r\nend;\r\n\r\n{ property Write Prepared(Value: Boolean) }\r\n\r\nprocedure TQuery_Write_Prepared(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TQuery(Args.Obj).Prepared := Value;\r\nend;\r\n\r\n{ property Read ParamCount: Word }\r\n\r\nprocedure TQuery_Read_ParamCount(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TQuery(Args.Obj).ParamCount;\r\nend;\r\n\r\n{ property Read Local: Boolean }\r\n\r\nprocedure TQuery_Read_Local(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TQuery(Args.Obj).Local;\r\nend;\r\n\r\n{ property Read StmtHandle: HDBIStmt }\r\n\r\nprocedure TQuery_Read_StmtHandle(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := P2V(TQuery(Args.Obj).StmtHandle);\r\nend;\r\n\r\n{ property Read Text: string }\r\n\r\nprocedure TQuery_Read_Text(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TQuery(Args.Obj).Text;\r\nend;\r\n\r\n{ property Read RowsAffected: Integer }\r\n\r\nprocedure TQuery_Read_RowsAffected(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TQuery(Args.Obj).RowsAffected;\r\nend;\r\n\r\n{ property Read SQLBinary: PChar }\r\n\r\nprocedure TQuery_Read_SQLBinary(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := string(TQuery(Args.Obj).SQLBinary);\r\nend;\r\n\r\n{ property Write SQLBinary(Value: PChar) }\r\n\r\nprocedure TQuery_Write_SQLBinary(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TQuery(Args.Obj).SQLBinary := PAnsiChar(AnsiString(Value));\r\nend;\r\n\r\n{ property Read Constrained: Boolean }\r\n\r\nprocedure TQuery_Read_Constrained(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TQuery(Args.Obj).Constrained;\r\nend;\r\n\r\n{ property Write Constrained(Value: Boolean) }\r\n\r\nprocedure TQuery_Write_Constrained(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TQuery(Args.Obj).Constrained := Value;\r\nend;\r\n\r\n{ property Read DataSource: TDataSource }\r\n\r\nprocedure TQuery_Read_DataSource(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TQuery(Args.Obj).DataSource);\r\nend;\r\n\r\n{ property Write DataSource(Value: TDataSource) }\r\n\r\nprocedure TQuery_Write_DataSource(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TQuery(Args.Obj).DataSource := V2O(Value) as TDataSource;\r\nend;\r\n\r\n{ property Read ParamCheck: Boolean }\r\n\r\nprocedure TQuery_Read_ParamCheck(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TQuery(Args.Obj).ParamCheck;\r\nend;\r\n\r\n{ property Write ParamCheck(Value: Boolean) }\r\n\r\nprocedure TQuery_Write_ParamCheck(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TQuery(Args.Obj).ParamCheck := Value;\r\nend;\r\n\r\n{ property Read RequestLive: Boolean }\r\n\r\nprocedure TQuery_Read_RequestLive(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TQuery(Args.Obj).RequestLive;\r\nend;\r\n\r\n{ property Write RequestLive(Value: Boolean) }\r\n\r\nprocedure TQuery_Write_RequestLive(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TQuery(Args.Obj).RequestLive := Value;\r\nend;\r\n\r\n{ property Read SQL: TStrings }\r\n\r\nprocedure TQuery_Read_SQL(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TQuery(Args.Obj).SQL);\r\nend;\r\n\r\n{ property Write SQL(Value: TStrings) }\r\n\r\nprocedure TQuery_Write_SQL(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TQuery(Args.Obj).SQL := V2O(Value) as TStrings;\r\nend;\r\n\r\n{ property Read Params: TParams }\r\n\r\nprocedure TQuery_Read_Params(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TQuery(Args.Obj).Params);\r\nend;\r\n\r\n{ property Write Params(Value: TParams) }\r\n\r\nprocedure TQuery_Write_Params(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TQuery(Args.Obj).Params := V2O(Value) as TParams;\r\nend;\r\n\r\n{ property Read UniDirectional: Boolean }\r\n\r\nprocedure TQuery_Read_UniDirectional(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TQuery(Args.Obj).UniDirectional;\r\nend;\r\n\r\n{ property Write UniDirectional(Value: Boolean) }\r\n\r\nprocedure TQuery_Write_UniDirectional(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TQuery(Args.Obj).UniDirectional := Value;\r\nend;\r\n\r\n{ TUpdateSQL }\r\n\r\n{ constructor Create(AOwner: TComponent) }\r\n\r\nprocedure TUpdateSQL_Create(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TUpdateSQL.Create(V2O(Args.Values[0]) as TComponent));\r\nend;\r\n\r\n{ procedure Apply(UpdateKind: TUpdateKind); }\r\n\r\nprocedure TUpdateSQL_Apply(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TUpdateSQL(Args.Obj).Apply(Args.Values[0]);\r\nend;\r\n\r\n{ procedure ExecSQL(UpdateKind: TUpdateKind); }\r\n\r\nprocedure TUpdateSQL_ExecSQL(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TUpdateSQL(Args.Obj).ExecSQL(Args.Values[0]);\r\nend;\r\n\r\n{ procedure SetParams(UpdateKind: TUpdateKind); }\r\n\r\nprocedure TUpdateSQL_SetParams(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TUpdateSQL(Args.Obj).SetParams(Args.Values[0]);\r\nend;\r\n\r\n{ property Read Query[TUpdateKind]: TQuery }\r\n\r\nprocedure TUpdateSQL_Read_Query(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TUpdateSQL(Args.Obj).Query[Args.Values[0]]);\r\nend;\r\n\r\n{ property Read SQL[TUpdateKind]: TStrings }\r\n\r\nprocedure TUpdateSQL_Read_SQL(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TUpdateSQL(Args.Obj).SQL[Args.Values[0]]);\r\nend;\r\n\r\n{ property Write SQL[TUpdateKind]: TStrings }\r\n\r\nprocedure TUpdateSQL_Write_SQL(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TUpdateSQL(Args.Obj).SQL[Args.Values[0]] := V2O(Value) as TStrings;\r\nend;\r\n\r\n{ property Read ModifySQL: TStrings }\r\n\r\nprocedure TUpdateSQL_Read_ModifySQL(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TUpdateSQL(Args.Obj).ModifySQL);\r\nend;\r\n\r\n{ property Write ModifySQL(Value: TStrings) }\r\n\r\nprocedure TUpdateSQL_Write_ModifySQL(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TUpdateSQL(Args.Obj).ModifySQL := V2O(Value) as TStrings;\r\nend;\r\n\r\n{ property Read InsertSQL: TStrings }\r\n\r\nprocedure TUpdateSQL_Read_InsertSQL(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TUpdateSQL(Args.Obj).InsertSQL);\r\nend;\r\n\r\n{ property Write InsertSQL(Value: TStrings) }\r\n\r\nprocedure TUpdateSQL_Write_InsertSQL(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TUpdateSQL(Args.Obj).InsertSQL := V2O(Value) as TStrings;\r\nend;\r\n\r\n{ property Read DeleteSQL: TStrings }\r\n\r\nprocedure TUpdateSQL_Read_DeleteSQL(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TUpdateSQL(Args.Obj).DeleteSQL);\r\nend;\r\n\r\n{ property Write DeleteSQL(Value: TStrings) }\r\n\r\nprocedure TUpdateSQL_Write_DeleteSQL(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TUpdateSQL(Args.Obj).DeleteSQL := V2O(Value) as TStrings;\r\nend;\r\n\r\n{ TBlobStream }\r\n\r\n{ constructor Create(Field: TBlobField; Mode: TBlobStreamMode) }\r\n\r\nprocedure TBlobStream_Create(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TBlobStream.Create(V2O(Args.Values[0]) as TBlobField, Args.Values[1]));\r\nend;\r\n\r\n{ function Read(var Buffer; Count: Longint): Longint; }\r\n\r\nprocedure TBlobStream_Read(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TBlobStream(Args.Obj).Read(Args.Values[0], Args.Values[1]);\r\nend;\r\n\r\n{ function Write(const Buffer; Count: Longint): Longint; }\r\n\r\nprocedure TBlobStream_Write(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TBlobStream(Args.Obj).Write(Args.Values[0], Args.Values[1]);\r\nend;\r\n\r\n{ function Seek(Offset: Longint; Origin: Word): Longint; }\r\n\r\nprocedure TBlobStream_Seek(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TBlobStream(Args.Obj).Seek(Args.Values[0], Args.Values[1]);\r\nend;\r\n\r\n{ procedure Truncate; }\r\n\r\nprocedure TBlobStream_Truncate(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TBlobStream(Args.Obj).Truncate;\r\nend;\r\n\r\nprocedure RegisterJvInterpreterAdapter(JvInterpreterAdapter: TJvInterpreterAdapter);\r\nconst\r\n cDbTables = 'DbTables';\r\nbegin\r\n with JvInterpreterAdapter do\r\n begin\r\n { EDBEngineError }\r\n AddClass(cDbTables, EDBEngineError, 'EDBEngineError');\r\n AddGet(EDBEngineError, 'Create', EDBEngineError_Create, 1, [varEmpty], varEmpty);\r\n AddGet(EDBEngineError, 'ErrorCount', EDBEngineError_Read_ErrorCount, 0, [varEmpty], varEmpty);\r\n AddGet(EDBEngineError, 'Errors', EDBEngineError_Read_Errors, 1, [varEmpty], varEmpty);\r\n { ENoResultSet }\r\n AddClass(cDbTables, ENoResultSet, 'ENoResultSet');\r\n { TConfigModes }\r\n AddConst(cDbTables, 'cfmVirtual', Ord(cfmVirtual));\r\n AddConst(cDbTables, 'cfmPersistent', Ord(cfmPersistent));\r\n AddConst(cDbTables, 'cfmSession', Ord(cfmSession));\r\n { TDatabaseEvent }\r\n AddConst(cDbTables, 'dbOpen', Ord(dbOpen));\r\n AddConst(cDbTables, 'dbClose', Ord(dbClose));\r\n AddConst(cDbTables, 'dbAdd', Ord(dbAdd));\r\n AddConst(cDbTables, 'dbRemove', Ord(dbRemove));\r\n AddConst(cDbTables, 'dbAddAlias', Ord(dbAddAlias));\r\n AddConst(cDbTables, 'dbDeleteAlias', Ord(dbDeleteAlias));\r\n AddConst(cDbTables, 'dbAddDriver', Ord(dbAddDriver));\r\n AddConst(cDbTables, 'dbDeleteDriver', Ord(dbDeleteDriver));\r\n { TTraceFlag }\r\n AddConst(cDbTables, 'tfQPrepare', Ord(tfQPrepare));\r\n AddConst(cDbTables, 'tfQExecute', Ord(tfQExecute));\r\n AddConst(cDbTables, 'tfError', Ord(tfError));\r\n AddConst(cDbTables, 'tfStmt', Ord(tfStmt));\r\n AddConst(cDbTables, 'tfConnect', Ord(tfConnect));\r\n AddConst(cDbTables, 'tfTransact', Ord(tfTransact));\r\n AddConst(cDbTables, 'tfBlob', Ord(tfBlob));\r\n AddConst(cDbTables, 'tfMisc', Ord(tfMisc));\r\n AddConst(cDbTables, 'tfVendor', Ord(tfVendor));\r\n AddConst(cDbTables, 'tfDataIn', Ord(tfDataIn));\r\n AddConst(cDbTables, 'tfDataOut', Ord(tfDataOut));\r\n { TSession }\r\n AddClass(cDbTables, TSession, 'TSession');\r\n AddGet(TSession, 'Create', TSession_Create, 1, [varEmpty], varEmpty);\r\n AddGet(TSession, 'AddAlias', TSession_AddAlias, 3, [varEmpty, varEmpty, varEmpty], varEmpty);\r\n AddGet(TSession, 'AddDriver', TSession_AddDriver, 2, [varEmpty, varEmpty], varEmpty);\r\n AddGet(TSession, 'AddStandardAlias', TSession_AddStandardAlias, 3, [varEmpty, varEmpty, varEmpty], varEmpty);\r\n AddGet(TSession, 'ConfigMode', TSession_Read_ConfigMode, 0, [varEmpty], varEmpty);\r\n AddSet(TSession, 'ConfigMode', TSession_Write_ConfigMode, 0, [varEmpty]);\r\n AddGet(TSession, 'AddPassword', TSession_AddPassword, 1, [varEmpty], varEmpty);\r\n AddGet(TSession, 'Close', TSession_Close, 0, [varEmpty], varEmpty);\r\n AddGet(TSession, 'CloseDatabase', TSession_CloseDatabase, 1, [varEmpty], varEmpty);\r\n AddGet(TSession, 'DeleteAlias', TSession_DeleteAlias, 1, [varEmpty], varEmpty);\r\n AddGet(TSession, 'DeleteDriver', TSession_DeleteDriver, 1, [varEmpty], varEmpty);\r\n AddGet(TSession, 'DropConnections', TSession_DropConnections, 0, [varEmpty], varEmpty);\r\n AddGet(TSession, 'FindDatabase', TSession_FindDatabase, 1, [varEmpty], varEmpty);\r\n AddGet(TSession, 'GetAliasNames', TSession_GetAliasNames, 1, [varEmpty], varEmpty);\r\n AddGet(TSession, 'GetAliasParams', TSession_GetAliasParams, 2, [varEmpty, varEmpty], varEmpty);\r\n AddGet(TSession, 'GetAliasDriverName', TSession_GetAliasDriverName, 1, [varEmpty], varEmpty);\r\n AddGet(TSession, 'GetConfigParams', TSession_GetConfigParams, 3, [varEmpty, varEmpty, varEmpty], varEmpty);\r\n AddGet(TSession, 'GetDatabaseNames', TSession_GetDatabaseNames, 1, [varEmpty], varEmpty);\r\n AddGet(TSession, 'GetDriverNames', TSession_GetDriverNames, 1, [varEmpty], varEmpty);\r\n AddGet(TSession, 'GetDriverParams', TSession_GetDriverParams, 2, [varEmpty, varEmpty], varEmpty);\r\n AddGet(TSession, 'GetPassword', TSession_GetPassword, 0, [varEmpty], varEmpty);\r\n AddGet(TSession, 'GetTableNames', TSession_GetTableNames, 5, [varEmpty, varEmpty, varEmpty, varEmpty, varEmpty],\r\n varEmpty);\r\n AddGet(TSession, 'GetStoredProcNames', TSession_GetStoredProcNames, 2, [varEmpty, varEmpty], varEmpty);\r\n AddGet(TSession, 'IsAlias', TSession_IsAlias, 1, [varEmpty], varEmpty);\r\n AddGet(TSession, 'ModifyAlias', TSession_ModifyAlias, 2, [varEmpty, varEmpty], varEmpty);\r\n AddGet(TSession, 'ModifyDriver', TSession_ModifyDriver, 2, [varEmpty, varEmpty], varEmpty);\r\n AddGet(TSession, 'Open', TSession_Open, 0, [varEmpty], varEmpty);\r\n AddGet(TSession, 'OpenDatabase', TSession_OpenDatabase, 1, [varEmpty], varEmpty);\r\n AddGet(TSession, 'RemoveAllPasswords', TSession_RemoveAllPasswords, 0, [varEmpty], varEmpty);\r\n AddGet(TSession, 'RemovePassword', TSession_RemovePassword, 1, [varEmpty], varEmpty);\r\n AddGet(TSession, 'SaveConfigFile', TSession_SaveConfigFile, 0, [varEmpty], varEmpty);\r\n AddGet(TSession, 'DatabaseCount', TSession_Read_DatabaseCount, 0, [varEmpty], varEmpty);\r\n AddGet(TSession, 'Databases', TSession_Read_Databases, 1, [varEmpty], varEmpty);\r\n AddGet(TSession, 'Handle', TSession_Read_Handle, 0, [varEmpty], varEmpty);\r\n AddGet(TSession, 'Locale', TSession_Read_Locale, 0, [varEmpty], varEmpty);\r\n AddGet(TSession, 'TraceFlags', TSession_Read_TraceFlags, 0, [varEmpty], varEmpty);\r\n AddSet(TSession, 'TraceFlags', TSession_Write_TraceFlags, 0, [varEmpty]);\r\n AddGet(TSession, 'Active', TSession_Read_Active, 0, [varEmpty], varEmpty);\r\n AddSet(TSession, 'Active', TSession_Write_Active, 0, [varEmpty]);\r\n AddGet(TSession, 'AutoSessionName', TSession_Read_AutoSessionName, 0, [varEmpty], varEmpty);\r\n AddSet(TSession, 'AutoSessionName', TSession_Write_AutoSessionName, 0, [varEmpty]);\r\n AddGet(TSession, 'KeepConnections', TSession_Read_KeepConnections, 0, [varEmpty], varEmpty);\r\n AddSet(TSession, 'KeepConnections', TSession_Write_KeepConnections, 0, [varEmpty]);\r\n AddGet(TSession, 'NetFileDir', TSession_Read_NetFileDir, 0, [varEmpty], varEmpty);\r\n AddSet(TSession, 'NetFileDir', TSession_Write_NetFileDir, 0, [varEmpty]);\r\n AddGet(TSession, 'PrivateDir', TSession_Read_PrivateDir, 0, [varEmpty], varEmpty);\r\n AddSet(TSession, 'PrivateDir', TSession_Write_PrivateDir, 0, [varEmpty]);\r\n AddGet(TSession, 'SessionName', TSession_Read_SessionName, 0, [varEmpty], varEmpty);\r\n AddSet(TSession, 'SessionName', TSession_Write_SessionName, 0, [varEmpty]);\r\n AddGet(TSession, 'SQLHourGlass', TSession_Read_SQLHourGlass, 0, [varEmpty], varEmpty);\r\n AddSet(TSession, 'SQLHourGlass', TSession_Write_SQLHourGlass, 0, [varEmpty]);\r\n { TTransIsolation }\r\n AddConst(cDbTables, 'tiDirtyRead', Ord(tiDirtyRead));\r\n AddConst(cDbTables, 'tiReadCommitted', Ord(tiReadCommitted));\r\n AddConst(cDbTables, 'tiRepeatableRead', Ord(tiRepeatableRead));\r\n { TDatabase }\r\n AddClass(cDbTables, TDatabase, 'TDatabase');\r\n AddGet(TDatabase, 'Create', TDatabase_Create, 1, [varEmpty], varEmpty);\r\n // AddGet(TDatabase, 'ApplyUpdates', TDatabase_ApplyUpdates, 1, [varEmpty], nil);\r\n AddGet(TDatabase, 'Close', TDatabase_Close, 0, [varEmpty], varEmpty);\r\n AddGet(TDatabase, 'CloseDataSets', TDatabase_CloseDataSets, 0, [varEmpty], varEmpty);\r\n AddGet(TDatabase, 'Commit', TDatabase_Commit, 0, [varEmpty], varEmpty);\r\n AddGet(TDatabase, 'FlushSchemaCache', TDatabase_FlushSchemaCache, 1, [varEmpty], varEmpty);\r\n AddGet(TDatabase, 'Open', TDatabase_Open, 0, [varEmpty], varEmpty);\r\n AddGet(TDatabase, 'Rollback', TDatabase_Rollback, 0, [varEmpty], varEmpty);\r\n AddGet(TDatabase, 'StartTransaction', TDatabase_StartTransaction, 0, [varEmpty], varEmpty);\r\n AddGet(TDatabase, 'ValidateName', TDatabase_ValidateName, 1, [varEmpty], varEmpty);\r\n AddGet(TDatabase, 'DataSetCount', TDatabase_Read_DataSetCount, 0, [varEmpty], varEmpty);\r\n AddIGet(TDatabase, 'DataSets', TDatabase_Read_DataSets, 1, [varEmpty], varEmpty);\r\n AddGet(TDatabase, 'Directory', TDatabase_Read_Directory, 0, [varEmpty], varEmpty);\r\n AddSet(TDatabase, 'Directory', TDatabase_Write_Directory, 0, [varEmpty]);\r\n AddGet(TDatabase, 'Handle', TDatabase_Read_Handle, 0, [varEmpty], varEmpty);\r\n AddSet(TDatabase, 'Handle', TDatabase_Write_Handle, 0, [varEmpty]);\r\n AddGet(TDatabase, 'IsSQLBased', TDatabase_Read_IsSQLBased, 0, [varEmpty], varEmpty);\r\n AddGet(TDatabase, 'InTransaction', TDatabase_Read_InTransaction, 0, [varEmpty], varEmpty);\r\n AddGet(TDatabase, 'Locale', TDatabase_Read_Locale, 0, [varEmpty], varEmpty);\r\n AddGet(TDatabase, 'Session', TDatabase_Read_Session, 0, [varEmpty], varEmpty);\r\n AddGet(TDatabase, 'Temporary', TDatabase_Read_Temporary, 0, [varEmpty], varEmpty);\r\n AddSet(TDatabase, 'Temporary', TDatabase_Write_Temporary, 0, [varEmpty]);\r\n AddGet(TDatabase, 'SessionAlias', TDatabase_Read_SessionAlias, 0, [varEmpty], varEmpty);\r\n AddGet(TDatabase, 'TraceFlags', TDatabase_Read_TraceFlags, 0, [varEmpty], varEmpty);\r\n AddSet(TDatabase, 'TraceFlags', TDatabase_Write_TraceFlags, 0, [varEmpty]);\r\n AddGet(TDatabase, 'AliasName', TDatabase_Read_AliasName, 0, [varEmpty], varEmpty);\r\n AddSet(TDatabase, 'AliasName', TDatabase_Write_AliasName, 0, [varEmpty]);\r\n AddGet(TDatabase, 'Connected', TDatabase_Read_Connected, 0, [varEmpty], varEmpty);\r\n AddSet(TDatabase, 'Connected', TDatabase_Write_Connected, 0, [varEmpty]);\r\n AddGet(TDatabase, 'DatabaseName', TDatabase_Read_DatabaseName, 0, [varEmpty], varEmpty);\r\n AddSet(TDatabase, 'DatabaseName', TDatabase_Write_DatabaseName, 0, [varEmpty]);\r\n AddGet(TDatabase, 'DriverName', TDatabase_Read_DriverName, 0, [varEmpty], varEmpty);\r\n AddSet(TDatabase, 'DriverName', TDatabase_Write_DriverName, 0, [varEmpty]);\r\n AddGet(TDatabase, 'HandleShared', TDatabase_Read_HandleShared, 0, [varEmpty], varEmpty);\r\n AddSet(TDatabase, 'HandleShared', TDatabase_Write_HandleShared, 0, [varEmpty]);\r\n AddGet(TDatabase, 'KeepConnection', TDatabase_Read_KeepConnection, 0, [varEmpty], varEmpty);\r\n AddSet(TDatabase, 'KeepConnection', TDatabase_Write_KeepConnection, 0, [varEmpty]);\r\n AddGet(TDatabase, 'LoginPrompt', TDatabase_Read_LoginPrompt, 0, [varEmpty], varEmpty);\r\n AddSet(TDatabase, 'LoginPrompt', TDatabase_Write_LoginPrompt, 0, [varEmpty]);\r\n AddGet(TDatabase, 'Params', TDatabase_Read_Params, 0, [varEmpty], varEmpty);\r\n AddSet(TDatabase, 'Params', TDatabase_Write_Params, 0, [varEmpty]);\r\n AddGet(TDatabase, 'SessionName', TDatabase_Read_SessionName, 0, [varEmpty], varEmpty);\r\n AddSet(TDatabase, 'SessionName', TDatabase_Write_SessionName, 0, [varEmpty]);\r\n AddGet(TDatabase, 'TransIsolation', TDatabase_Read_TransIsolation, 0, [varEmpty], varEmpty);\r\n AddSet(TDatabase, 'TransIsolation', TDatabase_Write_TransIsolation, 0, [varEmpty]);\r\n { TRecNoStatus }\r\n AddConst(cDbTables, 'rnDbase', Ord(rnDbase));\r\n AddConst(cDbTables, 'rnParadox', Ord(rnParadox));\r\n AddConst(cDbTables, 'rnNotSupported', Ord(rnNotSupported));\r\n { TUpdateAction }\r\n AddConst(cDbTables, 'uaFail', Ord(uaFail));\r\n AddConst(cDbTables, 'uaAbort', Ord(uaAbort));\r\n AddConst(cDbTables, 'uaSkip', Ord(uaSkip));\r\n AddConst(cDbTables, 'uaRetry', Ord(uaRetry));\r\n AddConst(cDbTables, 'uaApplied', Ord(uaApplied));\r\n { TUpdateRecordTypes }\r\n AddConst(cDbTables, 'rtModified', Ord(rtModified));\r\n AddConst(cDbTables, 'rtInserted', Ord(rtInserted));\r\n AddConst(cDbTables, 'rtDeleted', Ord(rtDeleted));\r\n AddConst(cDbTables, 'rtUnmodified', Ord(rtUnmodified));\r\n { TDataSetUpdateObject }\r\n AddClass(cDbTables, TDataSetUpdateObject, 'TDataSetUpdateObject');\r\n { TKeyIndex }\r\n AddConst(cDbTables, 'kiLookup', Ord(kiLookup));\r\n AddConst(cDbTables, 'kiRangeStart', Ord(kiRangeStart));\r\n AddConst(cDbTables, 'kiRangeEnd', Ord(kiRangeEnd));\r\n AddConst(cDbTables, 'kiCurRangeStart', Ord(kiCurRangeStart));\r\n AddConst(cDbTables, 'kiCurRangeEnd', Ord(kiCurRangeEnd));\r\n AddConst(cDbTables, 'kiSave', Ord(kiSave));\r\n { TBDEDataSet }\r\n AddClass(cDbTables, TBDEDataSet, 'TBDEDataSet');\r\n AddGet(TBDEDataSet, 'Create', TBDEDataSet_Create, 1, [varEmpty], varEmpty);\r\n AddGet(TBDEDataSet, 'ApplyUpdates', TBDEDataSet_ApplyUpdates, 0, [varEmpty], varEmpty);\r\n AddGet(TBDEDataSet, 'BookmarkValid', TBDEDataSet_BookmarkValid, 1, [varEmpty], varEmpty);\r\n AddGet(TBDEDataSet, 'Cancel', TBDEDataSet_Cancel, 0, [varEmpty], varEmpty);\r\n AddGet(TBDEDataSet, 'CancelUpdates', TBDEDataSet_CancelUpdates, 0, [varEmpty], varEmpty);\r\n AddGet(TBDEDataSet, 'CacheBlobs', TBDEDataSet_Read_CacheBlobs, 0, [varEmpty], varEmpty);\r\n AddSet(TBDEDataSet, 'CacheBlobs', TBDEDataSet_Write_CacheBlobs, 0, [varEmpty]);\r\n AddGet(TBDEDataSet, 'CompareBookmarks', TBDEDataSet_CompareBookmarks, 2, [varEmpty, varEmpty], varEmpty);\r\n AddGet(TBDEDataSet, 'CommitUpdates', TBDEDataSet_CommitUpdates, 0, [varEmpty], varEmpty);\r\n // AddGet(TBDEDataSet, 'ConstraintCallBack', TBDEDataSet_ConstraintCallBack, 2, [varEmpty, varByRef], nil);\r\n AddGet(TBDEDataSet, 'ConstraintsDisabled', TBDEDataSet_ConstraintsDisabled, 0, [varEmpty], varEmpty);\r\n AddGet(TBDEDataSet, 'CreateBlobStream', TBDEDataSet_CreateBlobStream, 2, [varEmpty, varEmpty], varEmpty);\r\n AddGet(TBDEDataSet, 'DisableConstraints', TBDEDataSet_DisableConstraints, 0, [varEmpty], varEmpty);\r\n AddGet(TBDEDataSet, 'EnableConstraints', TBDEDataSet_EnableConstraints, 0, [varEmpty], varEmpty);\r\n AddGet(TBDEDataSet, 'FetchAll', TBDEDataSet_FetchAll, 0, [varEmpty], varEmpty);\r\n AddGet(TBDEDataSet, 'FlushBuffers', TBDEDataSet_FlushBuffers, 0, [varEmpty], varEmpty);\r\n AddGet(TBDEDataSet, 'GetCurrentRecord', TBDEDataSet_GetCurrentRecord, 1, [varEmpty], varEmpty);\r\n AddGet(TBDEDataSet, 'GetIndexInfo', TBDEDataSet_GetIndexInfo, 0, [varEmpty], varEmpty);\r\n AddGet(TBDEDataSet, 'Locate', TBDEDataSet_Locate, 3, [varEmpty, varEmpty, varEmpty], varEmpty);\r\n AddGet(TBDEDataSet, 'Lookup', TBDEDataSet_Lookup, 3, [varEmpty, varEmpty, varEmpty], varEmpty);\r\n AddGet(TBDEDataSet, 'IsSequenced', TBDEDataSet_IsSequenced, 0, [varEmpty], varEmpty);\r\n AddGet(TBDEDataSet, 'Post', TBDEDataSet_Post, 0, [varEmpty], varEmpty);\r\n AddGet(TBDEDataSet, 'RevertRecord', TBDEDataSet_RevertRecord, 0, [varEmpty], varEmpty);\r\n AddGet(TBDEDataSet, 'UpdateStatus', TBDEDataSet_UpdateStatus, 0, [varEmpty], varEmpty);\r\n AddGet(TBDEDataSet, 'Translate', TBDEDataSet_Translate, 3, [varEmpty, varEmpty, varEmpty], varEmpty);\r\n AddGet(TBDEDataSet, 'ExpIndex', TBDEDataSet_Read_ExpIndex, 0, [varEmpty], varEmpty);\r\n AddGet(TBDEDataSet, 'Handle', TBDEDataSet_Read_Handle, 0, [varEmpty], varEmpty);\r\n AddGet(TBDEDataSet, 'KeySize', TBDEDataSet_Read_KeySize, 0, [varEmpty], varEmpty);\r\n AddGet(TBDEDataSet, 'Locale', TBDEDataSet_Read_Locale, 0, [varEmpty], varEmpty);\r\n AddGet(TBDEDataSet, 'UpdateObject', TBDEDataSet_Read_UpdateObject, 0, [varEmpty], varEmpty);\r\n AddSet(TBDEDataSet, 'UpdateObject', TBDEDataSet_Write_UpdateObject, 0, [varEmpty]);\r\n AddGet(TBDEDataSet, 'UpdatesPending', TBDEDataSet_Read_UpdatesPending, 0, [varEmpty], varEmpty);\r\n AddGet(TBDEDataSet, 'UpdateRecordTypes', TBDEDataSet_Read_UpdateRecordTypes, 0, [varEmpty], varEmpty);\r\n AddSet(TBDEDataSet, 'UpdateRecordTypes', TBDEDataSet_Write_UpdateRecordTypes, 0, [varEmpty]);\r\n AddGet(TBDEDataSet, 'CachedUpdates', TBDEDataSet_Read_CachedUpdates, 0, [varEmpty], varEmpty);\r\n AddSet(TBDEDataSet, 'CachedUpdates', TBDEDataSet_Write_CachedUpdates, 0, [varEmpty]);\r\n { TUpdateMode }\r\n AddConst(cDbTables, 'upWhereAll', Ord(upWhereAll));\r\n AddConst(cDbTables, 'upWhereChanged', Ord(upWhereChanged));\r\n AddConst(cDbTables, 'upWhereKeyOnly', Ord(upWhereKeyOnly));\r\n { TDBDataSet }\r\n AddClass(cDbTables, TDBDataSet, 'TDBDataSet');\r\n AddGet(TDBDataSet, 'CheckOpen', TDBDataSet_CheckOpen, 1, [varEmpty], varEmpty);\r\n AddGet(TDBDataSet, 'CloseDatabase', TDBDataSet_CloseDatabase, 1, [varEmpty], varEmpty);\r\n AddGet(TDBDataSet, 'OpenDatabase', TDBDataSet_OpenDatabase, 0, [varEmpty], varEmpty);\r\n AddGet(TDBDataSet, 'Database', TDBDataSet_Read_Database, 0, [varEmpty], varEmpty);\r\n AddGet(TDBDataSet, 'DBHandle', TDBDataSet_Read_DBHandle, 0, [varEmpty], varEmpty);\r\n AddGet(TDBDataSet, 'DBLocale', TDBDataSet_Read_DBLocale, 0, [varEmpty], varEmpty);\r\n AddGet(TDBDataSet, 'DBSession', TDBDataSet_Read_DBSession, 0, [varEmpty], varEmpty);\r\n AddGet(TDBDataSet, 'DatabaseName', TDBDataSet_Read_DatabaseName, 0, [varEmpty], varEmpty);\r\n AddSet(TDBDataSet, 'DatabaseName', TDBDataSet_Write_DatabaseName, 0, [varEmpty]);\r\n AddGet(TDBDataSet, 'SessionName', TDBDataSet_Read_SessionName, 0, [varEmpty], varEmpty);\r\n AddSet(TDBDataSet, 'SessionName', TDBDataSet_Write_SessionName, 0, [varEmpty]);\r\n { TBatchMode }\r\n AddConst(cDbTables, 'batAppend', Ord(batAppend));\r\n AddConst(cDbTables, 'batUpdate', Ord(batUpdate));\r\n AddConst(cDbTables, 'batAppendUpdate', Ord(batAppendUpdate));\r\n AddConst(cDbTables, 'batDelete', Ord(batDelete));\r\n AddConst(cDbTables, 'batCopy', Ord(batCopy));\r\n { TTableType }\r\n AddConst(cDbTables, 'ttDefault', Ord(ttDefault));\r\n AddConst(cDbTables, 'ttParadox', Ord(ttParadox));\r\n AddConst(cDbTables, 'ttDBase', Ord(ttDBase));\r\n AddConst(cDbTables, 'ttASCII', Ord(ttASCII));\r\n { TLockType }\r\n AddConst(cDbTables, 'ltReadLock', Ord(ltReadLock));\r\n AddConst(cDbTables, 'ltWriteLock', Ord(ltWriteLock));\r\n { TTable }\r\n AddClass(cDbTables, TTable, 'TTable');\r\n AddGet(TTable, 'Create', TTable_Create, 1, [varEmpty], varEmpty);\r\n AddGet(TTable, 'BatchMove', TTable_BatchMove, 2, [varEmpty, varEmpty], varEmpty);\r\n AddGet(TTable, 'AddIndex', TTable_AddIndex, 3, [varEmpty, varEmpty, varEmpty], varEmpty);\r\n AddGet(TTable, 'ApplyRange', TTable_ApplyRange, 0, [varEmpty], varEmpty);\r\n AddGet(TTable, 'CancelRange', TTable_CancelRange, 0, [varEmpty], varEmpty);\r\n AddGet(TTable, 'CloseIndexFile', TTable_CloseIndexFile, 1, [varEmpty], varEmpty);\r\n AddGet(TTable, 'CreateTable', TTable_CreateTable, 0, [varEmpty], varEmpty);\r\n AddGet(TTable, 'DeleteIndex', TTable_DeleteIndex, 1, [varEmpty], varEmpty);\r\n AddGet(TTable, 'DeleteTable', TTable_DeleteTable, 0, [varEmpty], varEmpty);\r\n AddGet(TTable, 'EditKey', TTable_EditKey, 0, [varEmpty], varEmpty);\r\n AddGet(TTable, 'EditRangeEnd', TTable_EditRangeEnd, 0, [varEmpty], varEmpty);\r\n AddGet(TTable, 'EditRangeStart', TTable_EditRangeStart, 0, [varEmpty], varEmpty);\r\n AddGet(TTable, 'EmptyTable', TTable_EmptyTable, 0, [varEmpty], varEmpty);\r\n AddGet(TTable, 'FindKey', TTable_FindKey, 1, [varEmpty], varEmpty);\r\n AddGet(TTable, 'FindNearest', TTable_FindNearest, 1, [varEmpty], varEmpty);\r\n AddGet(TTable, 'GetIndexNames', TTable_GetIndexNames, 1, [varEmpty], varEmpty);\r\n AddGet(TTable, 'GotoCurrent', TTable_GotoCurrent, 1, [varEmpty], varEmpty);\r\n AddGet(TTable, 'GotoKey', TTable_GotoKey, 0, [varEmpty], varEmpty);\r\n AddGet(TTable, 'GotoNearest', TTable_GotoNearest, 0, [varEmpty], varEmpty);\r\n AddGet(TTable, 'LockTable', TTable_LockTable, 1, [varEmpty], varEmpty);\r\n AddGet(TTable, 'OpenIndexFile', TTable_OpenIndexFile, 1, [varEmpty], varEmpty);\r\n AddGet(TTable, 'RenameTable', TTable_RenameTable, 1, [varEmpty], varEmpty);\r\n AddGet(TTable, 'SetKey', TTable_SetKey, 0, [varEmpty], varEmpty);\r\n AddGet(TTable, 'SetRange', TTable_SetRange, 2, [varEmpty, varEmpty], varEmpty);\r\n AddGet(TTable, 'SetRangeEnd', TTable_SetRangeEnd, 0, [varEmpty], varEmpty);\r\n AddGet(TTable, 'SetRangeStart', TTable_SetRangeStart, 0, [varEmpty], varEmpty);\r\n AddGet(TTable, 'UnlockTable', TTable_UnlockTable, 1, [varEmpty], varEmpty);\r\n AddGet(TTable, 'IndexDefs', TTable_Read_IndexDefs, 0, [varEmpty], varEmpty);\r\n AddGet(TTable, 'IndexFieldCount', TTable_Read_IndexFieldCount, 0, [varEmpty], varEmpty);\r\n AddIGet(TTable, 'IndexFields', TTable_Read_IndexFields, 1, [varEmpty], varEmpty);\r\n AddISet(TTable, 'IndexFields', TTable_Write_IndexFields, 1, [varNull]);\r\n AddGet(TTable, 'KeyExclusive', TTable_Read_KeyExclusive, 0, [varEmpty], varEmpty);\r\n AddSet(TTable, 'KeyExclusive', TTable_Write_KeyExclusive, 0, [varEmpty]);\r\n AddGet(TTable, 'KeyFieldCount', TTable_Read_KeyFieldCount, 0, [varEmpty], varEmpty);\r\n AddSet(TTable, 'KeyFieldCount', TTable_Write_KeyFieldCount, 0, [varEmpty]);\r\n AddGet(TTable, 'TableLevel', TTable_Read_TableLevel, 0, [varEmpty], varEmpty);\r\n AddSet(TTable, 'TableLevel', TTable_Write_TableLevel, 0, [varEmpty]);\r\n AddGet(TTable, 'Exclusive', TTable_Read_Exclusive, 0, [varEmpty], varEmpty);\r\n AddSet(TTable, 'Exclusive', TTable_Write_Exclusive, 0, [varEmpty]);\r\n AddGet(TTable, 'IndexFieldNames', TTable_Read_IndexFieldNames, 0, [varEmpty], varEmpty);\r\n AddSet(TTable, 'IndexFieldNames', TTable_Write_IndexFieldNames, 0, [varEmpty]);\r\n AddGet(TTable, 'IndexFiles', TTable_Read_IndexFiles, 0, [varEmpty], varEmpty);\r\n AddSet(TTable, 'IndexFiles', TTable_Write_IndexFiles, 0, [varEmpty]);\r\n AddGet(TTable, 'IndexName', TTable_Read_IndexName, 0, [varEmpty], varEmpty);\r\n AddSet(TTable, 'IndexName', TTable_Write_IndexName, 0, [varEmpty]);\r\n AddGet(TTable, 'MasterFields', TTable_Read_MasterFields, 0, [varEmpty], varEmpty);\r\n AddSet(TTable, 'MasterFields', TTable_Write_MasterFields, 0, [varEmpty]);\r\n AddGet(TTable, 'MasterSource', TTable_Read_MasterSource, 0, [varEmpty], varEmpty);\r\n AddSet(TTable, 'MasterSource', TTable_Write_MasterSource, 0, [varEmpty]);\r\n AddGet(TTable, 'ReadOnly', TTable_Read_ReadOnly, 0, [varEmpty], varEmpty);\r\n AddSet(TTable, 'ReadOnly', TTable_Write_ReadOnly, 0, [varEmpty]);\r\n AddGet(TTable, 'TableName', TTable_Read_TableName, 0, [varEmpty], varEmpty);\r\n AddSet(TTable, 'TableName', TTable_Write_TableName, 0, [varEmpty]);\r\n AddGet(TTable, 'TableType', TTable_Read_TableType, 0, [varEmpty], varEmpty);\r\n AddSet(TTable, 'TableType', TTable_Write_TableType, 0, [varEmpty]);\r\n { TBatchMove }\r\n AddClass(cDbTables, TBatchMove, 'TBatchMove');\r\n AddGet(TBatchMove, 'Create', TBatchMove_Create, 1, [varEmpty], varEmpty);\r\n AddGet(TBatchMove, 'Execute', TBatchMove_Execute, 0, [varEmpty], varEmpty);\r\n AddGet(TBatchMove, 'ChangedCount', TBatchMove_Read_ChangedCount, 0, [varEmpty], varEmpty);\r\n AddGet(TBatchMove, 'KeyViolCount', TBatchMove_Read_KeyViolCount, 0, [varEmpty], varEmpty);\r\n AddGet(TBatchMove, 'MovedCount', TBatchMove_Read_MovedCount, 0, [varEmpty], varEmpty);\r\n AddGet(TBatchMove, 'ProblemCount', TBatchMove_Read_ProblemCount, 0, [varEmpty], varEmpty);\r\n AddGet(TBatchMove, 'AbortOnKeyViol', TBatchMove_Read_AbortOnKeyViol, 0, [varEmpty], varEmpty);\r\n AddSet(TBatchMove, 'AbortOnKeyViol', TBatchMove_Write_AbortOnKeyViol, 0, [varEmpty]);\r\n AddGet(TBatchMove, 'AbortOnProblem', TBatchMove_Read_AbortOnProblem, 0, [varEmpty], varEmpty);\r\n AddSet(TBatchMove, 'AbortOnProblem', TBatchMove_Write_AbortOnProblem, 0, [varEmpty]);\r\n AddGet(TBatchMove, 'CommitCount', TBatchMove_Read_CommitCount, 0, [varEmpty], varEmpty);\r\n AddSet(TBatchMove, 'CommitCount', TBatchMove_Write_CommitCount, 0, [varEmpty]);\r\n AddGet(TBatchMove, 'ChangedTableName', TBatchMove_Read_ChangedTableName, 0, [varEmpty], varEmpty);\r\n AddSet(TBatchMove, 'ChangedTableName', TBatchMove_Write_ChangedTableName, 0, [varEmpty]);\r\n AddGet(TBatchMove, 'Destination', TBatchMove_Read_Destination, 0, [varEmpty], varEmpty);\r\n AddSet(TBatchMove, 'Destination', TBatchMove_Write_Destination, 0, [varEmpty]);\r\n AddGet(TBatchMove, 'KeyViolTableName', TBatchMove_Read_KeyViolTableName, 0, [varEmpty], varEmpty);\r\n AddSet(TBatchMove, 'KeyViolTableName', TBatchMove_Write_KeyViolTableName, 0, [varEmpty]);\r\n AddGet(TBatchMove, 'Mappings', TBatchMove_Read_Mappings, 0, [varEmpty], varEmpty);\r\n AddSet(TBatchMove, 'Mappings', TBatchMove_Write_Mappings, 0, [varEmpty]);\r\n AddGet(TBatchMove, 'Mode', TBatchMove_Read_Mode, 0, [varEmpty], varEmpty);\r\n AddSet(TBatchMove, 'Mode', TBatchMove_Write_Mode, 0, [varEmpty]);\r\n AddGet(TBatchMove, 'ProblemTableName', TBatchMove_Read_ProblemTableName, 0, [varEmpty], varEmpty);\r\n AddSet(TBatchMove, 'ProblemTableName', TBatchMove_Write_ProblemTableName, 0, [varEmpty]);\r\n AddGet(TBatchMove, 'RecordCount', TBatchMove_Read_RecordCount, 0, [varEmpty], varEmpty);\r\n AddSet(TBatchMove, 'RecordCount', TBatchMove_Write_RecordCount, 0, [varEmpty]);\r\n AddGet(TBatchMove, 'Source', TBatchMove_Read_Source, 0, [varEmpty], varEmpty);\r\n AddSet(TBatchMove, 'Source', TBatchMove_Write_Source, 0, [varEmpty]);\r\n AddGet(TBatchMove, 'Transliterate', TBatchMove_Read_Transliterate, 0, [varEmpty], varEmpty);\r\n AddSet(TBatchMove, 'Transliterate', TBatchMove_Write_Transliterate, 0, [varEmpty]);\r\n { TParamType }\r\n AddConst(cDbTables, 'ptUnknown', Ord(ptUnknown));\r\n AddConst(cDbTables, 'ptInput', Ord(ptInput));\r\n AddConst(cDbTables, 'ptOutput', Ord(ptOutput));\r\n AddConst(cDbTables, 'ptInputOutput', Ord(ptInputOutput));\r\n AddConst(cDbTables, 'ptResult', Ord(ptResult));\r\n { TParam }\r\n AddClass(cDbTables, TParam, 'TParam');\r\n AddGet(TParam, 'Create', TParam_Create, 2, [varEmpty, varEmpty], varEmpty);\r\n AddGet(TParam, 'Assign', TParam_Assign, 1, [varEmpty], varEmpty);\r\n AddGet(TParam, 'AssignField', TParam_AssignField, 1, [varEmpty], varEmpty);\r\n AddGet(TParam, 'AssignFieldValue', TParam_AssignFieldValue, 2, [varEmpty, varEmpty], varEmpty);\r\n AddGet(TParam, 'Clear', TParam_Clear, 0, [varEmpty], varEmpty);\r\n AddGet(TParam, 'GetData', TParam_GetData, 1, [varEmpty], varEmpty);\r\n AddGet(TParam, 'GetDataSize', TParam_GetDataSize, 0, [varEmpty], varEmpty);\r\n AddGet(TParam, 'LoadFromFile', TParam_LoadFromFile, 2, [varEmpty, varEmpty], varEmpty);\r\n AddGet(TParam, 'LoadFromStream', TParam_LoadFromStream, 2, [varEmpty, varEmpty], varEmpty);\r\n AddGet(TParam, 'SetBlobData', TParam_SetBlobData, 2, [varEmpty, varEmpty], varEmpty);\r\n AddGet(TParam, 'SetData', TParam_SetData, 1, [varEmpty], varEmpty);\r\n AddGet(TParam, 'AsBCD', TParam_Read_AsBCD, 0, [varEmpty], varEmpty);\r\n AddSet(TParam, 'AsBCD', TParam_Write_AsBCD, 0, [varEmpty]);\r\n AddGet(TParam, 'AsBlob', TParam_Read_AsBlob, 0, [varEmpty], varEmpty);\r\n AddSet(TParam, 'AsBlob', TParam_Write_AsBlob, 0, [varEmpty]);\r\n AddGet(TParam, 'AsBoolean', TParam_Read_AsBoolean, 0, [varEmpty], varEmpty);\r\n AddSet(TParam, 'AsBoolean', TParam_Write_AsBoolean, 0, [varEmpty]);\r\n AddGet(TParam, 'AsCurrency', TParam_Read_AsCurrency, 0, [varEmpty], varEmpty);\r\n AddSet(TParam, 'AsCurrency', TParam_Write_AsCurrency, 0, [varEmpty]);\r\n AddGet(TParam, 'AsDate', TParam_Read_AsDate, 0, [varEmpty], varEmpty);\r\n AddSet(TParam, 'AsDate', TParam_Write_AsDate, 0, [varEmpty]);\r\n AddGet(TParam, 'AsDateTime', TParam_Read_AsDateTime, 0, [varEmpty], varEmpty);\r\n AddSet(TParam, 'AsDateTime', TParam_Write_AsDateTime, 0, [varEmpty]);\r\n AddGet(TParam, 'AsFloat', TParam_Read_AsFloat, 0, [varEmpty], varEmpty);\r\n AddSet(TParam, 'AsFloat', TParam_Write_AsFloat, 0, [varEmpty]);\r\n AddGet(TParam, 'AsInteger', TParam_Read_AsInteger, 0, [varEmpty], varEmpty);\r\n AddSet(TParam, 'AsInteger', TParam_Write_AsInteger, 0, [varEmpty]);\r\n AddGet(TParam, 'AsSmallInt', TParam_Read_AsSmallInt, 0, [varEmpty], varEmpty);\r\n AddSet(TParam, 'AsSmallInt', TParam_Write_AsSmallInt, 0, [varEmpty]);\r\n AddGet(TParam, 'AsMemo', TParam_Read_AsMemo, 0, [varEmpty], varEmpty);\r\n AddSet(TParam, 'AsMemo', TParam_Write_AsMemo, 0, [varEmpty]);\r\n AddGet(TParam, 'AsString', TParam_Read_AsString, 0, [varEmpty], varEmpty);\r\n AddSet(TParam, 'AsString', TParam_Write_AsString, 0, [varEmpty]);\r\n AddGet(TParam, 'AsTime', TParam_Read_AsTime, 0, [varEmpty], varEmpty);\r\n AddSet(TParam, 'AsTime', TParam_Write_AsTime, 0, [varEmpty]);\r\n AddGet(TParam, 'AsWord', TParam_Read_AsWord, 0, [varEmpty], varEmpty);\r\n AddSet(TParam, 'AsWord', TParam_Write_AsWord, 0, [varEmpty]);\r\n AddGet(TParam, 'Bound', TParam_Read_Bound, 0, [varEmpty], varEmpty);\r\n AddSet(TParam, 'Bound', TParam_Write_Bound, 0, [varEmpty]);\r\n AddGet(TParam, 'DataType', TParam_Read_DataType, 0, [varEmpty], varEmpty);\r\n AddSet(TParam, 'DataType', TParam_Write_DataType, 0, [varEmpty]);\r\n AddGet(TParam, 'IsNull', TParam_Read_IsNull, 0, [varEmpty], varEmpty);\r\n AddGet(TParam, 'Name', TParam_Read_Name, 0, [varEmpty], varEmpty);\r\n AddSet(TParam, 'Name', TParam_Write_Name, 0, [varEmpty]);\r\n AddGet(TParam, 'ParamType', TParam_Read_ParamType, 0, [varEmpty], varEmpty);\r\n AddSet(TParam, 'ParamType', TParam_Write_ParamType, 0, [varEmpty]);\r\n AddGet(TParam, 'Text', TParam_Read_Text, 0, [varEmpty], varEmpty);\r\n AddSet(TParam, 'Text', TParam_Write_Text, 0, [varEmpty]);\r\n AddGet(TParam, 'Value', TParam_Read_Value, 0, [varEmpty], varEmpty);\r\n AddSet(TParam, 'Value', TParam_Write_Value, 0, [varEmpty]);\r\n { TParams }\r\n AddClass(cDbTables, TParams, 'TParams');\r\n AddGet(TParams, 'Create', TParams_Create, 0, [varEmpty], varEmpty);\r\n AddGet(TParams, 'Assign', TParams_Assign, 1, [varEmpty], varEmpty);\r\n AddGet(TParams, 'AssignValues', TParams_AssignValues, 1, [varEmpty], varEmpty);\r\n AddGet(TParams, 'AddParam', TParams_AddParam, 1, [varEmpty], varEmpty);\r\n AddGet(TParams, 'RemoveParam', TParams_RemoveParam, 1, [varEmpty], varEmpty);\r\n AddGet(TParams, 'CreateParam', TParams_CreateParam, 3, [varEmpty, varEmpty, varEmpty], varEmpty);\r\n AddGet(TParams, 'Count', TParams_Count, 0, [varEmpty], varEmpty);\r\n AddGet(TParams, 'Clear', TParams_Clear, 0, [varEmpty], varEmpty);\r\n AddGet(TParams, 'GetParamList', TParams_GetParamList, 2, [varEmpty, varEmpty], varEmpty);\r\n AddGet(TParams, 'IsEqual', TParams_IsEqual, 1, [varEmpty], varEmpty);\r\n AddGet(TParams, 'ParamByName', TParams_ParamByName, 1, [varEmpty], varEmpty);\r\n AddGet(TParams, 'Items', TParams_Read_Items, 1, [varEmpty], varEmpty);\r\n { TParamBindMode }\r\n AddConst(cDbTables, 'pbByName', Ord(pbByName));\r\n AddConst(cDbTables, 'pbByNumber', Ord(pbByNumber));\r\n { TStoredProc }\r\n AddClass(cDbTables, TStoredProc, 'TStoredProc');\r\n AddGet(TStoredProc, 'Create', TStoredProc_Create, 1, [varEmpty], varEmpty);\r\n AddGet(TStoredProc, 'CopyParams', TStoredProc_CopyParams, 1, [varEmpty], varEmpty);\r\n AddGet(TStoredProc, 'DescriptionsAvailable', TStoredProc_DescriptionsAvailable, 0, [varEmpty], varEmpty);\r\n AddGet(TStoredProc, 'ExecProc', TStoredProc_ExecProc, 0, [varEmpty], varEmpty);\r\n AddGet(TStoredProc, 'ParamByName', TStoredProc_ParamByName, 1, [varEmpty], varEmpty);\r\n AddGet(TStoredProc, 'Prepare', TStoredProc_Prepare, 0, [varEmpty], varEmpty);\r\n AddGet(TStoredProc, 'GetResults', TStoredProc_GetResults, 0, [varEmpty], varEmpty);\r\n AddGet(TStoredProc, 'UnPrepare', TStoredProc_UnPrepare, 0, [varEmpty], varEmpty);\r\n AddGet(TStoredProc, 'ParamCount', TStoredProc_Read_ParamCount, 0, [varEmpty], varEmpty);\r\n AddGet(TStoredProc, 'StmtHandle', TStoredProc_Read_StmtHandle, 0, [varEmpty], varEmpty);\r\n AddGet(TStoredProc, 'Prepared', TStoredProc_Read_Prepared, 0, [varEmpty], varEmpty);\r\n AddSet(TStoredProc, 'Prepared', TStoredProc_Write_Prepared, 0, [varEmpty]);\r\n AddGet(TStoredProc, 'StoredProcName', TStoredProc_Read_StoredProcName, 0, [varEmpty], varEmpty);\r\n AddSet(TStoredProc, 'StoredProcName', TStoredProc_Write_StoredProcName, 0, [varEmpty]);\r\n AddGet(TStoredProc, 'Overload', TStoredProc_Read_Overload, 0, [varEmpty], varEmpty);\r\n AddSet(TStoredProc, 'Overload', TStoredProc_Write_Overload, 0, [varEmpty]);\r\n AddGet(TStoredProc, 'Params', TStoredProc_Read_Params, 0, [varEmpty], varEmpty);\r\n AddSet(TStoredProc, 'Params', TStoredProc_Write_Params, 0, [varEmpty]);\r\n AddGet(TStoredProc, 'ParamBindMode', TStoredProc_Read_ParamBindMode, 0, [varEmpty], varEmpty);\r\n AddSet(TStoredProc, 'ParamBindMode', TStoredProc_Write_ParamBindMode, 0, [varEmpty]);\r\n { TQuery }\r\n AddClass(cDbTables, TQuery, 'TQuery');\r\n AddGet(TQuery, 'Create', TQuery_Create, 1, [varEmpty], varEmpty);\r\n AddGet(TQuery, 'ExecSQL', TQuery_ExecSQL, 0, [varEmpty], varEmpty);\r\n AddGet(TQuery, 'ParamByName', TQuery_ParamByName, 1, [varEmpty], varEmpty);\r\n AddGet(TQuery, 'Prepare', TQuery_Prepare, 0, [varEmpty], varEmpty);\r\n AddGet(TQuery, 'UnPrepare', TQuery_UnPrepare, 0, [varEmpty], varEmpty);\r\n AddGet(TQuery, 'Prepared', TQuery_Read_Prepared, 0, [varEmpty], varEmpty);\r\n AddSet(TQuery, 'Prepared', TQuery_Write_Prepared, 0, [varEmpty]);\r\n AddGet(TQuery, 'ParamCount', TQuery_Read_ParamCount, 0, [varEmpty], varEmpty);\r\n AddGet(TQuery, 'Local', TQuery_Read_Local, 0, [varEmpty], varEmpty);\r\n AddGet(TQuery, 'StmtHandle', TQuery_Read_StmtHandle, 0, [varEmpty], varEmpty);\r\n AddGet(TQuery, 'Text', TQuery_Read_Text, 0, [varEmpty], varEmpty);\r\n AddGet(TQuery, 'RowsAffected', TQuery_Read_RowsAffected, 0, [varEmpty], varEmpty);\r\n AddGet(TQuery, 'SQLBinary', TQuery_Read_SQLBinary, 0, [varEmpty], varEmpty);\r\n AddSet(TQuery, 'SQLBinary', TQuery_Write_SQLBinary, 0, [varEmpty]);\r\n AddGet(TQuery, 'Constrained', TQuery_Read_Constrained, 0, [varEmpty], varEmpty);\r\n AddSet(TQuery, 'Constrained', TQuery_Write_Constrained, 0, [varEmpty]);\r\n AddGet(TQuery, 'DataSource', TQuery_Read_DataSource, 0, [varEmpty], varEmpty);\r\n AddSet(TQuery, 'DataSource', TQuery_Write_DataSource, 0, [varEmpty]);\r\n AddGet(TQuery, 'ParamCheck', TQuery_Read_ParamCheck, 0, [varEmpty], varEmpty);\r\n AddSet(TQuery, 'ParamCheck', TQuery_Write_ParamCheck, 0, [varEmpty]);\r\n AddGet(TQuery, 'RequestLive', TQuery_Read_RequestLive, 0, [varEmpty], varEmpty);\r\n AddSet(TQuery, 'RequestLive', TQuery_Write_RequestLive, 0, [varEmpty]);\r\n AddGet(TQuery, 'SQL', TQuery_Read_SQL, 0, [varEmpty], varEmpty);\r\n AddSet(TQuery, 'SQL', TQuery_Write_SQL, 0, [varEmpty]);\r\n AddGet(TQuery, 'Params', TQuery_Read_Params, 0, [varEmpty], varEmpty);\r\n AddSet(TQuery, 'Params', TQuery_Write_Params, 0, [varEmpty]);\r\n AddGet(TQuery, 'UniDirectional', TQuery_Read_UniDirectional, 0, [varEmpty], varEmpty);\r\n AddSet(TQuery, 'UniDirectional', TQuery_Write_UniDirectional, 0, [varEmpty]);\r\n { TUpdateSQL }\r\n AddClass(cDbTables, TUpdateSQL, 'TUpdateSQL');\r\n AddGet(TUpdateSQL, 'Create', TUpdateSQL_Create, 1, [varEmpty], varEmpty);\r\n AddGet(TUpdateSQL, 'Apply', TUpdateSQL_Apply, 1, [varEmpty], varEmpty);\r\n AddGet(TUpdateSQL, 'ExecSQL', TUpdateSQL_ExecSQL, 1, [varEmpty], varEmpty);\r\n AddGet(TUpdateSQL, 'SetParams', TUpdateSQL_SetParams, 1, [varEmpty], varEmpty);\r\n AddGet(TUpdateSQL, 'Query', TUpdateSQL_Read_Query, 1, [varEmpty], varEmpty);\r\n AddGet(TUpdateSQL, 'SQL', TUpdateSQL_Read_SQL, 1, [varEmpty], varEmpty);\r\n AddSet(TUpdateSQL, 'SQL', TUpdateSQL_Write_SQL, 1, [varNull]);\r\n AddGet(TUpdateSQL, 'ModifySQL', TUpdateSQL_Read_ModifySQL, 0, [varEmpty], varEmpty);\r\n AddSet(TUpdateSQL, 'ModifySQL', TUpdateSQL_Write_ModifySQL, 0, [varEmpty]);\r\n AddGet(TUpdateSQL, 'InsertSQL', TUpdateSQL_Read_InsertSQL, 0, [varEmpty], varEmpty);\r\n AddSet(TUpdateSQL, 'InsertSQL', TUpdateSQL_Write_InsertSQL, 0, [varEmpty]);\r\n AddGet(TUpdateSQL, 'DeleteSQL', TUpdateSQL_Read_DeleteSQL, 0, [varEmpty], varEmpty);\r\n AddSet(TUpdateSQL, 'DeleteSQL', TUpdateSQL_Write_DeleteSQL, 0, [varEmpty]);\r\n { TBlobStream }\r\n AddClass(cDbTables, TBlobStream, 'TBlobStream');\r\n AddGet(TBlobStream, 'Create', TBlobStream_Create, 2, [varEmpty, varEmpty], varEmpty);\r\n AddGet(TBlobStream, 'Read', TBlobStream_Read, 2, [varByRef, varEmpty], varEmpty);\r\n AddGet(TBlobStream, 'Write', TBlobStream_Write, 2, [varEmpty, varEmpty], varEmpty);\r\n AddGet(TBlobStream, 'Seek', TBlobStream_Seek, 2, [varEmpty, varEmpty], varEmpty);\r\n AddGet(TBlobStream, 'Truncate', TBlobStream_Truncate, 0, [varEmpty], varEmpty);\r\n end;\r\n RegisterClasses([TSession, TDatabase, TTable, TQuery, TStoredProc,\r\n TBatchMove, TParam, TParams, TUpdateSQL]);\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvInterpreter_Db.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvInterpreter_Db.PAS, released on 2002-07-04.\r\n\r\nThe Initial Developers of the Original Code are: Andrei Prygounkov \r\nCopyright (c) 1999, 2002 Andrei Prygounkov\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nDescription : adapter unit - converts JvInterpreter calls to delphi calls\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvInterpreter_Db.pas 13415 2012-09-10 09:51:54Z obones $\r\n\r\nunit JvInterpreter_Db;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n JvInterpreter;\r\n\r\nprocedure RegisterJvInterpreterAdapter(JvInterpreterAdapter: TJvInterpreterAdapter);\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvInterpreter_Db.pas $';\r\n Revision: '$Revision: 13415 $';\r\n Date: '$Date: 2012-09-10 11:51:54 +0200 (lun. 10 sept. 2012) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n {$IFDEF RTL240_UP}\r\n System.Generics.Collections,\r\n {$ENDIF RTL240_UP}\r\n Classes, Variants, DB;\r\n\r\ntype\r\n {$IFDEF COMPILER12_UP}\r\n TJvRecordBuffer = TRecordBuffer; // Delphi 2009\r\n {$ELSE}\r\n TJvRecordBuffer = PAnsiChar;\r\n {$ENDIF COMPILER12_UP}\r\n \r\n{ EDatabaseError }\r\n\r\n{ TFieldDef }\r\n\r\n{ constructor Create(Owner: TFieldDefs; Name: string; DataType: TFieldType; Size: Word; Required: Boolean; FieldNo: Integer) }\r\n\r\nprocedure TFieldDef_Create(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TFieldDef.Create(V2O(Args.Values[0]) as TFieldDefs, string(Args.Values[1]), Args.Values[2],\r\n Args.Values[3], Args.Values[4], Args.Values[5]));\r\nend;\r\n\r\n{ function CreateField(Owner: TComponent): TField; }\r\n\r\nprocedure TFieldDef_CreateField(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TFieldDef(Args.Obj).CreateField(V2O(Args.Values[0]) as TComponent));\r\nend;\r\n\r\n{ property Read InternalCalcField: Boolean }\r\n\r\nprocedure TFieldDef_Read_InternalCalcField(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TFieldDef(Args.Obj).InternalCalcField;\r\nend;\r\n\r\n{ property Write InternalCalcField(Value: Boolean) }\r\n\r\nprocedure TFieldDef_Write_InternalCalcField(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TFieldDef(Args.Obj).InternalCalcField := Value;\r\nend;\r\n\r\n{ property Read DataType: TFieldType }\r\n\r\nprocedure TFieldDef_Read_DataType(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TFieldDef(Args.Obj).DataType;\r\nend;\r\n\r\n{ property Read FieldClass: TFieldClass }\r\n\r\nprocedure TFieldDef_Read_FieldClass(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := C2V(TFieldDef(Args.Obj).FieldClass);\r\nend;\r\n\r\n{ property Read FieldNo: Integer }\r\n\r\nprocedure TFieldDef_Read_FieldNo(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TFieldDef(Args.Obj).FieldNo;\r\nend;\r\n\r\n{ property Read Name: string }\r\n\r\nprocedure TFieldDef_Read_Name(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TFieldDef(Args.Obj).Name;\r\nend;\r\n\r\n{ property Read Precision: Integer }\r\n\r\nprocedure TFieldDef_Read_Precision(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TFieldDef(Args.Obj).Precision;\r\nend;\r\n\r\n{ property Write Precision(Value: Integer) }\r\n\r\nprocedure TFieldDef_Write_Precision(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TFieldDef(Args.Obj).Precision := Value;\r\nend;\r\n\r\n{ property Read Required: Boolean }\r\n\r\nprocedure TFieldDef_Read_Required(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TFieldDef(Args.Obj).Required;\r\nend;\r\n\r\n{ property Read Size: Word }\r\n\r\nprocedure TFieldDef_Read_Size(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TFieldDef(Args.Obj).Size;\r\nend;\r\n\r\n{ TFieldDefs }\r\n\r\n{ constructor Create(DataSet: TDataSet) }\r\n\r\nprocedure TFieldDefs_Create(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TFieldDefs.Create(V2O(Args.Values[0]) as TDataSet));\r\nend;\r\n\r\n{ procedure Add(const Name: string; DataType: TFieldType; Size: Word; Required: Boolean); }\r\n\r\nprocedure TFieldDefs_Add(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TFieldDefs(Args.Obj).Add(Args.Values[0], Args.Values[1], Args.Values[2], Args.Values[3]);\r\nend;\r\n\r\n{ procedure Assign(FieldDefs: TFieldDefs); }\r\n\r\nprocedure TFieldDefs_Assign(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TFieldDefs(Args.Obj).Assign(V2O(Args.Values[0]) as TFieldDefs);\r\nend;\r\n\r\n{ procedure Clear; }\r\n\r\nprocedure TFieldDefs_Clear(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TFieldDefs(Args.Obj).Clear;\r\nend;\r\n\r\n{ function Find(const Name: string): TFieldDef; }\r\n\r\nprocedure TFieldDefs_Find(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TFieldDefs(Args.Obj).Find(Args.Values[0]));\r\nend;\r\n\r\n{ function IndexOf(const Name: string): Integer; }\r\n\r\nprocedure TFieldDefs_IndexOf(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TFieldDefs(Args.Obj).IndexOf(Args.Values[0]);\r\nend;\r\n\r\n{ procedure Update; }\r\n\r\nprocedure TFieldDefs_Update(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TFieldDefs(Args.Obj).Update;\r\nend;\r\n\r\n{ property Read Count: Integer }\r\n\r\nprocedure TFieldDefs_Read_Count(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TFieldDefs(Args.Obj).Count;\r\nend;\r\n\r\n{ property Read Items[Integer]: TFieldDef }\r\n\r\nprocedure TFieldDefs_Read_Items(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TFieldDefs(Args.Obj).Items[Args.Values[0]]);\r\nend;\r\n\r\n{ TField }\r\n\r\n{ constructor Create(AOwner: TComponent) }\r\n\r\nprocedure TField_Create(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TField.Create(V2O(Args.Values[0]) as TComponent));\r\nend;\r\n\r\n{ procedure Assign(Source: TPersistent); }\r\n\r\nprocedure TField_Assign(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TField(Args.Obj).Assign(V2O(Args.Values[0]) as TPersistent);\r\nend;\r\n\r\n(*\r\n{ procedure AssignValue(const Value: TVarRec); }\r\nprocedure TField_AssignValue(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TField(Args.Obj).AssignValue(Args.Values[0]);\r\nend;\r\n*)\r\n\r\n{ procedure Clear; }\r\n\r\nprocedure TField_Clear(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TField(Args.Obj).Clear;\r\nend;\r\n\r\n{ procedure FocusControl; }\r\n\r\nprocedure TField_FocusControl(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TField(Args.Obj).FocusControl;\r\nend;\r\n\r\n{ function GetData(Buffer: Pointer): Boolean; }\r\n\r\nprocedure TField_GetData(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TField(Args.Obj).GetData(V2P(Args.Values[0]));\r\nend;\r\n\r\n{ function IsBlob: Boolean; }\r\n\r\nprocedure TField_IsBlob(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TField(Args.Obj).IsBlob;\r\nend;\r\n\r\n{ function IsValidChar(InputChar: Char): Boolean; }\r\n\r\nprocedure TField_IsValidChar(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TField(Args.Obj).IsValidChar(string(Args.Values[0])[1]);\r\nend;\r\n\r\n{ procedure RefreshLookupList; }\r\n\r\nprocedure TField_RefreshLookupList(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TField(Args.Obj).RefreshLookupList;\r\nend;\r\n\r\n{ procedure SetData(Buffer: Pointer); }\r\n\r\nprocedure TField_SetData(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TField(Args.Obj).SetData(V2P(Args.Values[0]));\r\nend;\r\n\r\n{ procedure SetFieldType(Value: TFieldType); }\r\n\r\nprocedure TField_SetFieldType(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TField(Args.Obj).SetFieldType(Args.Values[0]);\r\nend;\r\n\r\n{ procedure Validate(Buffer: Pointer); }\r\n\r\nprocedure TField_Validate(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TField(Args.Obj).Validate(V2P(Args.Values[0]));\r\nend;\r\n\r\n{ property Read AsBoolean: Boolean }\r\n\r\nprocedure TField_Read_AsBoolean(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TField(Args.Obj).AsBoolean;\r\nend;\r\n\r\n{ property Write AsBoolean(Value: Boolean) }\r\n\r\nprocedure TField_Write_AsBoolean(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TField(Args.Obj).AsBoolean := Value;\r\nend;\r\n\r\n{ property Read AsCurrency: Currency }\r\n\r\nprocedure TField_Read_AsCurrency(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TField(Args.Obj).AsCurrency;\r\nend;\r\n\r\n{ property Write AsCurrency(Value: Currency) }\r\n\r\nprocedure TField_Write_AsCurrency(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TField(Args.Obj).AsCurrency := Value;\r\nend;\r\n\r\n{ property Read AsDateTime: TDateTime }\r\n\r\nprocedure TField_Read_AsDateTime(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TField(Args.Obj).AsDateTime;\r\nend;\r\n\r\n{ property Write AsDateTime(Value: TDateTime) }\r\n\r\nprocedure TField_Write_AsDateTime(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TField(Args.Obj).AsDateTime := Value;\r\nend;\r\n\r\n{ property Read AsFloat: Double }\r\n\r\nprocedure TField_Read_AsFloat(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TField(Args.Obj).AsFloat;\r\nend;\r\n\r\n{ property Write AsFloat(Value: Double) }\r\n\r\nprocedure TField_Write_AsFloat(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TField(Args.Obj).AsFloat := Value;\r\nend;\r\n\r\n{ property Read AsInteger: Longint }\r\n\r\nprocedure TField_Read_AsInteger(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TField(Args.Obj).AsInteger;\r\nend;\r\n\r\n{ property Write AsInteger(Value: Longint) }\r\n\r\nprocedure TField_Write_AsInteger(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TField(Args.Obj).AsInteger := Value;\r\nend;\r\n\r\n{ property Read AsString: string }\r\n\r\nprocedure TField_Read_AsString(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TField(Args.Obj).AsString;\r\nend;\r\n\r\n{ property Write AsString(Value: string) }\r\n\r\nprocedure TField_Write_AsString(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TField(Args.Obj).AsString := Value;\r\nend;\r\n\r\n{ property Read AsVariant: Variant }\r\n\r\nprocedure TField_Read_AsVariant(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TField(Args.Obj).AsVariant;\r\nend;\r\n\r\n{ property Write AsVariant(Value: Variant) }\r\n\r\nprocedure TField_Write_AsVariant(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TField(Args.Obj).AsVariant := Value;\r\nend;\r\n\r\n{ property Read AttributeSet: string }\r\n\r\nprocedure TField_Read_AttributeSet(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TField(Args.Obj).AttributeSet;\r\nend;\r\n\r\n{ property Write AttributeSet(Value: string) }\r\n\r\nprocedure TField_Write_AttributeSet(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TField(Args.Obj).AttributeSet := Value;\r\nend;\r\n\r\n{ property Read Calculated: Boolean }\r\n\r\nprocedure TField_Read_Calculated(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TField(Args.Obj).Calculated;\r\nend;\r\n\r\n{ property Write Calculated(Value: Boolean) }\r\n\r\nprocedure TField_Write_Calculated(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TField(Args.Obj).Calculated := Value;\r\nend;\r\n\r\n{ property Read CanModify: Boolean }\r\n\r\nprocedure TField_Read_CanModify(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TField(Args.Obj).CanModify;\r\nend;\r\n\r\n{ property Read CurValue: Variant }\r\n\r\nprocedure TField_Read_CurValue(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TField(Args.Obj).CurValue;\r\nend;\r\n\r\n{ property Read DataSet: TDataSet }\r\n\r\nprocedure TField_Read_DataSet(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TField(Args.Obj).DataSet);\r\nend;\r\n\r\n{ property Write DataSet(Value: TDataSet) }\r\n\r\nprocedure TField_Write_DataSet(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TField(Args.Obj).DataSet := V2O(Value) as TDataSet;\r\nend;\r\n\r\n{ property Read DataSize: Word }\r\n\r\nprocedure TField_Read_DataSize(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TField(Args.Obj).DataSize;\r\nend;\r\n\r\n{ property Read DataType: TFieldType }\r\n\r\nprocedure TField_Read_DataType(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TField(Args.Obj).DataType;\r\nend;\r\n\r\n{ property Read DisplayName: string }\r\n\r\nprocedure TField_Read_DisplayName(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TField(Args.Obj).DisplayName;\r\nend;\r\n\r\n{ property Read DisplayText: string }\r\n\r\nprocedure TField_Read_DisplayText(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TField(Args.Obj).DisplayText;\r\nend;\r\n\r\n{ property Read EditMask: string }\r\n\r\nprocedure TField_Read_EditMask(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TField(Args.Obj).EditMask;\r\nend;\r\n\r\n{ property Write EditMask(Value: string) }\r\n\r\nprocedure TField_Write_EditMask(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TField(Args.Obj).EditMask := Value;\r\nend;\r\n\r\n{ property Read EditMaskPtr: string }\r\n\r\nprocedure TField_Read_EditMaskPtr(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TField(Args.Obj).EditMaskPtr;\r\nend;\r\n\r\n{ property Read FieldNo: Integer }\r\n\r\nprocedure TField_Read_FieldNo(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TField(Args.Obj).FieldNo;\r\nend;\r\n\r\n{ property Read IsIndexField: Boolean }\r\n\r\nprocedure TField_Read_IsIndexField(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TField(Args.Obj).IsIndexField;\r\nend;\r\n\r\n{ property Read IsNull: Boolean }\r\n\r\nprocedure TField_Read_IsNull(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TField(Args.Obj).IsNull;\r\nend;\r\n\r\n{ property Read Lookup: Boolean }\r\n\r\nprocedure TField_Read_Lookup(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TField(Args.Obj).Lookup;\r\nend;\r\n\r\n{ property Write Lookup(Value: Boolean) }\r\n\r\nprocedure TField_Write_Lookup(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TField(Args.Obj).Lookup := Value;\r\nend;\r\n\r\n{ property Read NewValue: Variant }\r\n\r\nprocedure TField_Read_NewValue(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TField(Args.Obj).NewValue;\r\nend;\r\n\r\n{ property Write NewValue(Value: Variant) }\r\n\r\nprocedure TField_Write_NewValue(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TField(Args.Obj).NewValue := Value;\r\nend;\r\n\r\n{ property Read Offset: word }\r\n\r\nprocedure TField_Read_Offset(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TField(Args.Obj).Offset;\r\nend;\r\n\r\n{ property Read OldValue: Variant }\r\n\r\nprocedure TField_Read_OldValue(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TField(Args.Obj).OldValue;\r\nend;\r\n\r\n{ property Read Size: Word }\r\n\r\nprocedure TField_Read_Size(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TField(Args.Obj).Size;\r\nend;\r\n\r\n{ property Write Size(Value: Word) }\r\n\r\nprocedure TField_Write_Size(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TField(Args.Obj).Size := Value;\r\nend;\r\n\r\n{ property Read Text: string }\r\n\r\nprocedure TField_Read_Text(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TField(Args.Obj).Text;\r\nend;\r\n\r\n{ property Write Text(Value: string) }\r\n\r\nprocedure TField_Write_Text(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TField(Args.Obj).Text := Value;\r\nend;\r\n\r\n(*\r\n{ property Read ValidChars: TFieldChars }\r\nprocedure TField_Read_ValidChars(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TField(Args.Obj).ValidChars;\r\nend;\r\n\r\n{ property Write ValidChars(Value: TFieldChars) }\r\nprocedure TField_Write_ValidChars(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TField(Args.Obj).ValidChars := Value;\r\nend;\r\n*)\r\n\r\n{ property Read Value: Variant }\r\n\r\nprocedure TField_Read_Value(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TField(Args.Obj).Value;\r\nend;\r\n\r\n{ property Write Value(Value: Variant) }\r\n\r\nprocedure TField_Write_Value(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TField(Args.Obj).Value := Value;\r\nend;\r\n\r\n{ property Read Alignment: TAlignment }\r\n\r\nprocedure TField_Read_Alignment(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TField(Args.Obj).Alignment;\r\nend;\r\n\r\n{ property Write Alignment(Value: TAlignment) }\r\n\r\nprocedure TField_Write_Alignment(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TField(Args.Obj).Alignment := Value;\r\nend;\r\n\r\n{ property Read CustomConstraint: string }\r\n\r\nprocedure TField_Read_CustomConstraint(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TField(Args.Obj).CustomConstraint;\r\nend;\r\n\r\n{ property Write CustomConstraint(Value: string) }\r\n\r\nprocedure TField_Write_CustomConstraint(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TField(Args.Obj).CustomConstraint := Value;\r\nend;\r\n\r\n{ property Read ConstraintErrorMessage: string }\r\n\r\nprocedure TField_Read_ConstraintErrorMessage(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TField(Args.Obj).ConstraintErrorMessage;\r\nend;\r\n\r\n{ property Write ConstraintErrorMessage(Value: string) }\r\n\r\nprocedure TField_Write_ConstraintErrorMessage(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TField(Args.Obj).ConstraintErrorMessage := Value;\r\nend;\r\n\r\n{ property Read DefaultExpression: string }\r\n\r\nprocedure TField_Read_DefaultExpression(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TField(Args.Obj).DefaultExpression;\r\nend;\r\n\r\n{ property Write DefaultExpression(Value: string) }\r\n\r\nprocedure TField_Write_DefaultExpression(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TField(Args.Obj).DefaultExpression := Value;\r\nend;\r\n\r\n{ property Read DisplayLabel: string }\r\n\r\nprocedure TField_Read_DisplayLabel(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TField(Args.Obj).DisplayLabel;\r\nend;\r\n\r\n{ property Write DisplayLabel(Value: string) }\r\n\r\nprocedure TField_Write_DisplayLabel(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TField(Args.Obj).DisplayLabel := Value;\r\nend;\r\n\r\n{ property Read DisplayWidth: Integer }\r\n\r\nprocedure TField_Read_DisplayWidth(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TField(Args.Obj).DisplayWidth;\r\nend;\r\n\r\n{ property Write DisplayWidth(Value: Integer) }\r\n\r\nprocedure TField_Write_DisplayWidth(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TField(Args.Obj).DisplayWidth := Value;\r\nend;\r\n\r\n{ property Read FieldKind: TFieldKind }\r\n\r\nprocedure TField_Read_FieldKind(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TField(Args.Obj).FieldKind;\r\nend;\r\n\r\n{ property Write FieldKind(Value: TFieldKind) }\r\n\r\nprocedure TField_Write_FieldKind(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TField(Args.Obj).FieldKind := Value;\r\nend;\r\n\r\n{ property Read FieldName: string }\r\n\r\nprocedure TField_Read_FieldName(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TField(Args.Obj).FieldName;\r\nend;\r\n\r\n{ property Write FieldName(Value: string) }\r\n\r\nprocedure TField_Write_FieldName(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TField(Args.Obj).FieldName := Value;\r\nend;\r\n\r\n{ property Read HasConstraints: Boolean }\r\n\r\nprocedure TField_Read_HasConstraints(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TField(Args.Obj).HasConstraints;\r\nend;\r\n\r\n{ property Read Index: Integer }\r\n\r\nprocedure TField_Read_Index(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TField(Args.Obj).Index;\r\nend;\r\n\r\n{ property Write Index(Value: Integer) }\r\n\r\nprocedure TField_Write_Index(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TField(Args.Obj).Index := Value;\r\nend;\r\n\r\n{ property Read ImportedConstraint: string }\r\n\r\nprocedure TField_Read_ImportedConstraint(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TField(Args.Obj).ImportedConstraint;\r\nend;\r\n\r\n{ property Write ImportedConstraint(Value: string) }\r\n\r\nprocedure TField_Write_ImportedConstraint(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TField(Args.Obj).ImportedConstraint := Value;\r\nend;\r\n\r\n{ property Read LookupDataSet: TDataSet }\r\n\r\nprocedure TField_Read_LookupDataSet(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TField(Args.Obj).LookupDataSet);\r\nend;\r\n\r\n{ property Write LookupDataSet(Value: TDataSet) }\r\n\r\nprocedure TField_Write_LookupDataSet(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TField(Args.Obj).LookupDataSet := V2O(Value) as TDataSet;\r\nend;\r\n\r\n{ property Read LookupKeyFields: string }\r\n\r\nprocedure TField_Read_LookupKeyFields(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TField(Args.Obj).LookupKeyFields;\r\nend;\r\n\r\n{ property Write LookupKeyFields(Value: string) }\r\n\r\nprocedure TField_Write_LookupKeyFields(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TField(Args.Obj).LookupKeyFields := Value;\r\nend;\r\n\r\n{ property Read LookupResultField: string }\r\n\r\nprocedure TField_Read_LookupResultField(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TField(Args.Obj).LookupResultField;\r\nend;\r\n\r\n{ property Write LookupResultField(Value: string) }\r\n\r\nprocedure TField_Write_LookupResultField(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TField(Args.Obj).LookupResultField := Value;\r\nend;\r\n\r\n{ property Read KeyFields: string }\r\n\r\nprocedure TField_Read_KeyFields(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TField(Args.Obj).KeyFields;\r\nend;\r\n\r\n{ property Write KeyFields(Value: string) }\r\n\r\nprocedure TField_Write_KeyFields(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TField(Args.Obj).KeyFields := Value;\r\nend;\r\n\r\n{ property Read LookupCache: Boolean }\r\n\r\nprocedure TField_Read_LookupCache(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TField(Args.Obj).LookupCache;\r\nend;\r\n\r\n{ property Write LookupCache(Value: Boolean) }\r\n\r\nprocedure TField_Write_LookupCache(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TField(Args.Obj).LookupCache := Value;\r\nend;\r\n\r\n{ property Read Origin: string }\r\n\r\nprocedure TField_Read_Origin(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TField(Args.Obj).Origin;\r\nend;\r\n\r\n{ property Write Origin(Value: string) }\r\n\r\nprocedure TField_Write_Origin(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TField(Args.Obj).Origin := Value;\r\nend;\r\n\r\n{ property Read ReadOnly: Boolean }\r\n\r\nprocedure TField_Read_ReadOnly(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TField(Args.Obj).ReadOnly;\r\nend;\r\n\r\n{ property Write ReadOnly(Value: Boolean) }\r\n\r\nprocedure TField_Write_ReadOnly(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TField(Args.Obj).ReadOnly := Value;\r\nend;\r\n\r\n{ property Read Required: Boolean }\r\n\r\nprocedure TField_Read_Required(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TField(Args.Obj).Required;\r\nend;\r\n\r\n{ property Write Required(Value: Boolean) }\r\n\r\nprocedure TField_Write_Required(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TField(Args.Obj).Required := Value;\r\nend;\r\n\r\n{ property Read Visible: Boolean }\r\n\r\nprocedure TField_Read_Visible(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TField(Args.Obj).Visible;\r\nend;\r\n\r\n{ property Write Visible(Value: Boolean) }\r\n\r\nprocedure TField_Write_Visible(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TField(Args.Obj).Visible := Value;\r\nend;\r\n\r\n{ TStringField }\r\n\r\n{ constructor Create(AOwner: TComponent) }\r\n\r\nprocedure TStringField_Create(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TStringField.Create(V2O(Args.Values[0]) as TComponent));\r\nend;\r\n\r\n{ property Read Value: string }\r\n\r\nprocedure TStringField_Read_Value(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TStringField(Args.Obj).Value;\r\nend;\r\n\r\n{ property Write Value(Value: string) }\r\n\r\nprocedure TStringField_Write_Value(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TStringField(Args.Obj).Value := AnsiString(VarToStr(Value)); // Potential data loss in D2009 because of cast to AnsiString\r\nend;\r\n\r\n{ property Read Transliterate: Boolean }\r\n\r\nprocedure TStringField_Read_Transliterate(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TStringField(Args.Obj).Transliterate;\r\nend;\r\n\r\n{ property Write Transliterate(Value: Boolean) }\r\n\r\nprocedure TStringField_Write_Transliterate(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TStringField(Args.Obj).Transliterate := Value;\r\nend;\r\n\r\n{ TNumericField }\r\n\r\n{ constructor Create(AOwner: TComponent) }\r\n\r\nprocedure TNumericField_Create(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TNumericField.Create(V2O(Args.Values[0]) as TComponent));\r\nend;\r\n\r\n{ property Read DisplayFormat: string }\r\n\r\nprocedure TNumericField_Read_DisplayFormat(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TNumericField(Args.Obj).DisplayFormat;\r\nend;\r\n\r\n{ property Write DisplayFormat(Value: string) }\r\n\r\nprocedure TNumericField_Write_DisplayFormat(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TNumericField(Args.Obj).DisplayFormat := Value;\r\nend;\r\n\r\n{ property Read EditFormat: string }\r\n\r\nprocedure TNumericField_Read_EditFormat(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TNumericField(Args.Obj).EditFormat;\r\nend;\r\n\r\n{ property Write EditFormat(Value: string) }\r\n\r\nprocedure TNumericField_Write_EditFormat(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TNumericField(Args.Obj).EditFormat := Value;\r\nend;\r\n\r\n{ TIntegerField }\r\n\r\n{ constructor Create(AOwner: TComponent) }\r\n\r\nprocedure TIntegerField_Create(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TIntegerField.Create(V2O(Args.Values[0]) as TComponent));\r\nend;\r\n\r\n{ property Read Value: Longint }\r\n\r\nprocedure TIntegerField_Read_Value(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TIntegerField(Args.Obj).Value;\r\nend;\r\n\r\n{ property Write Value(Value: Longint) }\r\n\r\nprocedure TIntegerField_Write_Value(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TIntegerField(Args.Obj).Value := Value;\r\nend;\r\n\r\n{ property Read MaxValue: Longint }\r\n\r\nprocedure TIntegerField_Read_MaxValue(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TIntegerField(Args.Obj).MaxValue;\r\nend;\r\n\r\n{ property Write MaxValue(Value: Longint) }\r\n\r\nprocedure TIntegerField_Write_MaxValue(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TIntegerField(Args.Obj).MaxValue := Value;\r\nend;\r\n\r\n{ property Read MinValue: Longint }\r\n\r\nprocedure TIntegerField_Read_MinValue(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TIntegerField(Args.Obj).MinValue;\r\nend;\r\n\r\n{ property Write MinValue(Value: Longint) }\r\n\r\nprocedure TIntegerField_Write_MinValue(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TIntegerField(Args.Obj).MinValue := Value;\r\nend;\r\n\r\n{ TSmallintField }\r\n\r\n{ constructor Create(AOwner: TComponent) }\r\n\r\nprocedure TSmallintField_Create(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TSmallintField.Create(V2O(Args.Values[0]) as TComponent));\r\nend;\r\n\r\n{ TWordField }\r\n\r\n{ constructor Create(AOwner: TComponent) }\r\n\r\nprocedure TWordField_Create(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TWordField.Create(V2O(Args.Values[0]) as TComponent));\r\nend;\r\n\r\n{ TAutoIncField }\r\n\r\n{ constructor Create(AOwner: TComponent) }\r\n\r\nprocedure TAutoIncField_Create(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TAutoIncField.Create(V2O(Args.Values[0]) as TComponent));\r\nend;\r\n\r\n{ TFloatField }\r\n\r\n{ constructor Create(AOwner: TComponent) }\r\n\r\nprocedure TFloatField_Create(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TFloatField.Create(V2O(Args.Values[0]) as TComponent));\r\nend;\r\n\r\n{ property Read Value: Double }\r\n\r\nprocedure TFloatField_Read_Value(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TFloatField(Args.Obj).Value;\r\nend;\r\n\r\n{ property Write Value(Value: Double) }\r\n\r\nprocedure TFloatField_Write_Value(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TFloatField(Args.Obj).Value := Value;\r\nend;\r\n\r\n{ property Read Currency: Boolean }\r\n\r\nprocedure TFloatField_Read_Currency(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TFloatField(Args.Obj).Currency;\r\nend;\r\n\r\n{ property Write Currency(Value: Boolean) }\r\n\r\nprocedure TFloatField_Write_Currency(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TFloatField(Args.Obj).Currency := Value;\r\nend;\r\n\r\n{ property Read MaxValue: Double }\r\n\r\nprocedure TFloatField_Read_MaxValue(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TFloatField(Args.Obj).MaxValue;\r\nend;\r\n\r\n{ property Write MaxValue(Value: Double) }\r\n\r\nprocedure TFloatField_Write_MaxValue(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TFloatField(Args.Obj).MaxValue := Value;\r\nend;\r\n\r\n{ property Read MinValue: Double }\r\n\r\nprocedure TFloatField_Read_MinValue(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TFloatField(Args.Obj).MinValue;\r\nend;\r\n\r\n{ property Write MinValue(Value: Double) }\r\n\r\nprocedure TFloatField_Write_MinValue(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TFloatField(Args.Obj).MinValue := Value;\r\nend;\r\n\r\n{ property Read Precision: Integer }\r\n\r\nprocedure TFloatField_Read_Precision(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TFloatField(Args.Obj).Precision;\r\nend;\r\n\r\n{ property Write Precision(Value: Integer) }\r\n\r\nprocedure TFloatField_Write_Precision(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TFloatField(Args.Obj).Precision := Value;\r\nend;\r\n\r\n{ TCurrencyField }\r\n\r\n{ constructor Create(AOwner: TComponent) }\r\n\r\nprocedure TCurrencyField_Create(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TCurrencyField.Create(V2O(Args.Values[0]) as TComponent));\r\nend;\r\n\r\n{ TBooleanField }\r\n\r\n{ constructor Create(AOwner: TComponent) }\r\n\r\nprocedure TBooleanField_Create(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TBooleanField.Create(V2O(Args.Values[0]) as TComponent));\r\nend;\r\n\r\n{ property Read Value: Boolean }\r\n\r\nprocedure TBooleanField_Read_Value(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TBooleanField(Args.Obj).Value;\r\nend;\r\n\r\n{ property Write Value(Value: Boolean) }\r\n\r\nprocedure TBooleanField_Write_Value(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TBooleanField(Args.Obj).Value := Value;\r\nend;\r\n\r\n{ property Read DisplayValues: string }\r\n\r\nprocedure TBooleanField_Read_DisplayValues(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TBooleanField(Args.Obj).DisplayValues;\r\nend;\r\n\r\n{ property Write DisplayValues(Value: string) }\r\n\r\nprocedure TBooleanField_Write_DisplayValues(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TBooleanField(Args.Obj).DisplayValues := Value;\r\nend;\r\n\r\n{ TDateTimeField }\r\n\r\n{ constructor Create(AOwner: TComponent) }\r\n\r\nprocedure TDateTimeField_Create(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TDateTimeField.Create(V2O(Args.Values[0]) as TComponent));\r\nend;\r\n\r\n{ property Read Value: TDateTime }\r\n\r\nprocedure TDateTimeField_Read_Value(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TDateTimeField(Args.Obj).Value;\r\nend;\r\n\r\n{ property Write Value(Value: TDateTime) }\r\n\r\nprocedure TDateTimeField_Write_Value(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TDateTimeField(Args.Obj).Value := Value;\r\nend;\r\n\r\n{ property Read DisplayFormat: string }\r\n\r\nprocedure TDateTimeField_Read_DisplayFormat(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TDateTimeField(Args.Obj).DisplayFormat;\r\nend;\r\n\r\n{ property Write DisplayFormat(Value: string) }\r\n\r\nprocedure TDateTimeField_Write_DisplayFormat(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TDateTimeField(Args.Obj).DisplayFormat := Value;\r\nend;\r\n\r\n{ TDateField }\r\n\r\n{ constructor Create(AOwner: TComponent) }\r\n\r\nprocedure TDateField_Create(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TDateField.Create(V2O(Args.Values[0]) as TComponent));\r\nend;\r\n\r\n{ TTimeField }\r\n\r\n{ constructor Create(AOwner: TComponent) }\r\n\r\nprocedure TTimeField_Create(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TTimeField.Create(V2O(Args.Values[0]) as TComponent));\r\nend;\r\n\r\n{ TBinaryField }\r\n\r\n{ constructor Create(AOwner: TComponent) }\r\n\r\nprocedure TBinaryField_Create(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TBinaryField.Create(V2O(Args.Values[0]) as TComponent));\r\nend;\r\n\r\n{ TBytesField }\r\n\r\n{ constructor Create(AOwner: TComponent) }\r\n\r\nprocedure TBytesField_Create(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TBytesField.Create(V2O(Args.Values[0]) as TComponent));\r\nend;\r\n\r\n{ TVarBytesField }\r\n\r\n{ constructor Create(AOwner: TComponent) }\r\n\r\nprocedure TVarBytesField_Create(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TVarBytesField.Create(V2O(Args.Values[0]) as TComponent));\r\nend;\r\n\r\n{ TBCDField }\r\n\r\n{ constructor Create(AOwner: TComponent) }\r\n\r\nprocedure TBCDField_Create(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TBCDField.Create(V2O(Args.Values[0]) as TComponent));\r\nend;\r\n\r\n{ property Read Value: Currency }\r\n\r\nprocedure TBCDField_Read_Value(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TBCDField(Args.Obj).Value;\r\nend;\r\n\r\n{ property Write Value(Value: Currency) }\r\n\r\nprocedure TBCDField_Write_Value(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TBCDField(Args.Obj).Value := Value;\r\nend;\r\n\r\n{ property Read Currency: Boolean }\r\n\r\nprocedure TBCDField_Read_Currency(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TBCDField(Args.Obj).Currency;\r\nend;\r\n\r\n{ property Write Currency(Value: Boolean) }\r\n\r\nprocedure TBCDField_Write_Currency(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TBCDField(Args.Obj).Currency := Value;\r\nend;\r\n\r\n{ property Read MaxValue: Currency }\r\n\r\nprocedure TBCDField_Read_MaxValue(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TBCDField(Args.Obj).MaxValue;\r\nend;\r\n\r\n{ property Write MaxValue(Value: Currency) }\r\n\r\nprocedure TBCDField_Write_MaxValue(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TBCDField(Args.Obj).MaxValue := Value;\r\nend;\r\n\r\n{ property Read MinValue: Currency }\r\n\r\nprocedure TBCDField_Read_MinValue(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TBCDField(Args.Obj).MinValue;\r\nend;\r\n\r\n{ property Write MinValue(Value: Currency) }\r\n\r\nprocedure TBCDField_Write_MinValue(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TBCDField(Args.Obj).MinValue := Value;\r\nend;\r\n\r\n{ TBlobField }\r\n\r\n{ constructor Create(AOwner: TComponent) }\r\n\r\nprocedure TBlobField_Create(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TBlobField.Create(V2O(Args.Values[0]) as TComponent));\r\nend;\r\n\r\n{ procedure Assign(Source: TPersistent); }\r\n\r\nprocedure TBlobField_Assign(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TBlobField(Args.Obj).Assign(V2O(Args.Values[0]) as TPersistent);\r\nend;\r\n\r\n{ procedure Clear; }\r\n\r\nprocedure TBlobField_Clear(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TBlobField(Args.Obj).Clear;\r\nend;\r\n\r\n{ function IsBlob: Boolean; }\r\n\r\nprocedure TBlobField_IsBlob(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TBlobField(Args.Obj).IsBlob;\r\nend;\r\n\r\n{ procedure LoadFromFile(const FileName: string); }\r\n\r\nprocedure TBlobField_LoadFromFile(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TBlobField(Args.Obj).LoadFromFile(Args.Values[0]);\r\nend;\r\n\r\n{ procedure LoadFromStream(Stream: TStream); }\r\n\r\nprocedure TBlobField_LoadFromStream(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TBlobField(Args.Obj).LoadFromStream(V2O(Args.Values[0]) as TStream);\r\nend;\r\n\r\n{ procedure SaveToFile(const FileName: string); }\r\n\r\nprocedure TBlobField_SaveToFile(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TBlobField(Args.Obj).SaveToFile(Args.Values[0]);\r\nend;\r\n\r\n{ procedure SaveToStream(Stream: TStream); }\r\n\r\nprocedure TBlobField_SaveToStream(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TBlobField(Args.Obj).SaveToStream(V2O(Args.Values[0]) as TStream);\r\nend;\r\n\r\n{ procedure SetFieldType(Value: TFieldType); }\r\n\r\nprocedure TBlobField_SetFieldType(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TBlobField(Args.Obj).SetFieldType(Args.Values[0]);\r\nend;\r\n\r\n{ property Read BlobSize: Integer }\r\n\r\nprocedure TBlobField_Read_BlobSize(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TBlobField(Args.Obj).BlobSize;\r\nend;\r\n\r\n{ property Read Modified: Boolean }\r\n\r\nprocedure TBlobField_Read_Modified(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TBlobField(Args.Obj).Modified;\r\nend;\r\n\r\n{ property Write Modified(Value: Boolean) }\r\n\r\nprocedure TBlobField_Write_Modified(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TBlobField(Args.Obj).Modified := Value;\r\nend;\r\n\r\n{ property Read Value: string }\r\n\r\nprocedure TBlobField_Read_Value(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TBlobField(Args.Obj).Value;\r\nend;\r\n\r\n{ property Write Value(Value: string) }\r\n\r\nprocedure TBlobField_Write_Value(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TBlobField(Args.Obj).Value := Value;\r\nend;\r\n\r\n{ property Read Transliterate: Boolean }\r\n\r\nprocedure TBlobField_Read_Transliterate(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TBlobField(Args.Obj).Transliterate;\r\nend;\r\n\r\n{ property Write Transliterate(Value: Boolean) }\r\n\r\nprocedure TBlobField_Write_Transliterate(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TBlobField(Args.Obj).Transliterate := Value;\r\nend;\r\n\r\n{ property Read BlobType: TBlobType }\r\n\r\nprocedure TBlobField_Read_BlobType(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TBlobField(Args.Obj).BlobType;\r\nend;\r\n\r\n{ property Write BlobType(Value: TBlobType) }\r\n\r\nprocedure TBlobField_Write_BlobType(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TBlobField(Args.Obj).BlobType := Value;\r\nend;\r\n\r\n{ TMemoField }\r\n\r\n{ constructor Create(AOwner: TComponent) }\r\n\r\nprocedure TMemoField_Create(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TMemoField.Create(V2O(Args.Values[0]) as TComponent));\r\nend;\r\n\r\n{ TGraphicField }\r\n\r\n{ constructor Create(AOwner: TComponent) }\r\n\r\nprocedure TGraphicField_Create(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TGraphicField.Create(V2O(Args.Values[0]) as TComponent));\r\nend;\r\n\r\n{ TIndexDef }\r\n\r\n{ constructor Create(Owner: TIndexDefs; Name: string; Fields: string; Options: TIndexOptions) }\r\n\r\nprocedure TIndexDef_Create(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TIndexDef.Create(V2O(Args.Values[0]) as TIndexDefs, string(Args.Values[1]), string(Args.Values[2]),\r\n TIndexOptions(Byte(V2S(Args.Values[3])))));\r\nend;\r\n\r\n{ property Read Expression: string }\r\n\r\nprocedure TIndexDef_Read_Expression(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TIndexDef(Args.Obj).Expression;\r\nend;\r\n\r\n{ property Read Fields: string }\r\n\r\nprocedure TIndexDef_Read_Fields(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TIndexDef(Args.Obj).Fields;\r\nend;\r\n\r\n{ property Read Name: string }\r\n\r\nprocedure TIndexDef_Read_Name(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TIndexDef(Args.Obj).Name;\r\nend;\r\n\r\n{ property Read Options: TIndexOptions }\r\n\r\nprocedure TIndexDef_Read_Options(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := S2V(Byte(TIndexDef(Args.Obj).Options));\r\nend;\r\n\r\n{ property Read Source: string }\r\n\r\nprocedure TIndexDef_Read_Source(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TIndexDef(Args.Obj).Source;\r\nend;\r\n\r\n{ property Write Source(Value: string) }\r\n\r\nprocedure TIndexDef_Write_Source(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TIndexDef(Args.Obj).Source := Value;\r\nend;\r\n\r\n{ TIndexDefs }\r\n\r\n{ constructor Create(DataSet: TDataSet) }\r\n\r\nprocedure TIndexDefs_Create(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TIndexDefs.Create(V2O(Args.Values[0]) as TDataSet));\r\nend;\r\n\r\n{ procedure Add(const Name, Fields: string; Options: TIndexOptions); }\r\n\r\nprocedure TIndexDefs_Add(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TIndexDefs(Args.Obj).Add(Args.Values[0], Args.Values[1], TIndexOptions(Byte(V2S(Args.Values[2]))));\r\nend;\r\n\r\n{ procedure Assign(IndexDefs: TIndexDefs); }\r\n\r\nprocedure TIndexDefs_Assign(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TIndexDefs(Args.Obj).Assign(V2O(Args.Values[0]) as TIndexDefs);\r\nend;\r\n\r\n{ procedure Clear; }\r\n\r\nprocedure TIndexDefs_Clear(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TIndexDefs(Args.Obj).Clear;\r\nend;\r\n\r\n{ function FindIndexForFields(const Fields: string): TIndexDef; }\r\n\r\nprocedure TIndexDefs_FindIndexForFields(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TIndexDefs(Args.Obj).FindIndexForFields(Args.Values[0]));\r\nend;\r\n\r\n{ function GetIndexForFields(const Fields: string; CaseInsensitive: Boolean): TIndexDef; }\r\n\r\nprocedure TIndexDefs_GetIndexForFields(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TIndexDefs(Args.Obj).GetIndexForFields(Args.Values[0], Args.Values[1]));\r\nend;\r\n\r\n{ function IndexOf(const Name: string): Integer; }\r\n\r\nprocedure TIndexDefs_IndexOf(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TIndexDefs(Args.Obj).IndexOf(Args.Values[0]);\r\nend;\r\n\r\n{ procedure Update; }\r\n\r\nprocedure TIndexDefs_Update(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TIndexDefs(Args.Obj).Update;\r\nend;\r\n\r\n{ property Read Count: Integer }\r\n\r\nprocedure TIndexDefs_Read_Count(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TIndexDefs(Args.Obj).Count;\r\nend;\r\n\r\n{ property Read Items[Integer]: TIndexDef }\r\n\r\nprocedure TIndexDefs_Read_Items(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TIndexDefs(Args.Obj).Items[Args.Values[0]]);\r\nend;\r\n\r\n{ property Read Updated: Boolean }\r\n\r\nprocedure TIndexDefs_Read_Updated(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TIndexDefs(Args.Obj).Updated;\r\nend;\r\n\r\n{ property Write Updated(Value: Boolean) }\r\n\r\nprocedure TIndexDefs_Write_Updated(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TIndexDefs(Args.Obj).Updated := Value;\r\nend;\r\n\r\n{ TDataLink }\r\n\r\n{ constructor Create }\r\n\r\nprocedure TDataLink_Create(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TDataLink.Create);\r\nend;\r\n\r\n{ function Edit: Boolean; }\r\n\r\nprocedure TDataLink_Edit(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TDataLink(Args.Obj).Edit;\r\nend;\r\n\r\n{ procedure UpdateRecord; }\r\n\r\nprocedure TDataLink_UpdateRecord(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TDataLink(Args.Obj).UpdateRecord;\r\nend;\r\n\r\n{ property Read Active: Boolean }\r\n\r\nprocedure TDataLink_Read_Active(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TDataLink(Args.Obj).Active;\r\nend;\r\n\r\n{ property Read ActiveRecord: Integer }\r\n\r\nprocedure TDataLink_Read_ActiveRecord(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TDataLink(Args.Obj).ActiveRecord;\r\nend;\r\n\r\n{ property Write ActiveRecord(Value: Integer) }\r\n\r\nprocedure TDataLink_Write_ActiveRecord(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TDataLink(Args.Obj).ActiveRecord := Value;\r\nend;\r\n\r\n{ property Read BufferCount: Integer }\r\n\r\nprocedure TDataLink_Read_BufferCount(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TDataLink(Args.Obj).BufferCount;\r\nend;\r\n\r\n{ property Write BufferCount(Value: Integer) }\r\n\r\nprocedure TDataLink_Write_BufferCount(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TDataLink(Args.Obj).BufferCount := Value;\r\nend;\r\n\r\n{ property Read DataSet: TDataSet }\r\n\r\nprocedure TDataLink_Read_DataSet(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TDataLink(Args.Obj).DataSet);\r\nend;\r\n\r\n{ property Read DataSource: TDataSource }\r\n\r\nprocedure TDataLink_Read_DataSource(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TDataLink(Args.Obj).DataSource);\r\nend;\r\n\r\n{ property Write DataSource(Value: TDataSource) }\r\n\r\nprocedure TDataLink_Write_DataSource(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TDataLink(Args.Obj).DataSource := V2O(Value) as TDataSource;\r\nend;\r\n\r\n{ property Read DataSourceFixed: Boolean }\r\n\r\nprocedure TDataLink_Read_DataSourceFixed(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TDataLink(Args.Obj).DataSourceFixed;\r\nend;\r\n\r\n{ property Write DataSourceFixed(Value: Boolean) }\r\n\r\nprocedure TDataLink_Write_DataSourceFixed(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TDataLink(Args.Obj).DataSourceFixed := Value;\r\nend;\r\n\r\n{ property Read Editing: Boolean }\r\n\r\nprocedure TDataLink_Read_Editing(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TDataLink(Args.Obj).Editing;\r\nend;\r\n\r\n{ property Read ReadOnly: Boolean }\r\n\r\nprocedure TDataLink_Read_ReadOnly(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TDataLink(Args.Obj).ReadOnly;\r\nend;\r\n\r\n{ property Write ReadOnly(Value: Boolean) }\r\n\r\nprocedure TDataLink_Write_ReadOnly(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TDataLink(Args.Obj).ReadOnly := Value;\r\nend;\r\n\r\n{ property Read RecordCount: Integer }\r\n\r\nprocedure TDataLink_Read_RecordCount(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TDataLink(Args.Obj).RecordCount;\r\nend;\r\n\r\n{ TDataSource }\r\n\r\n{ constructor Create(AOwner: TComponent) }\r\n\r\nprocedure TDataSource_Create(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TDataSource.Create(V2O(Args.Values[0]) as TComponent));\r\nend;\r\n\r\n{ procedure Edit; }\r\n\r\nprocedure TDataSource_Edit(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TDataSource(Args.Obj).Edit;\r\nend;\r\n\r\n{ function IsLinkedTo(DataSet: TDataSet): Boolean; }\r\n\r\nprocedure TDataSource_IsLinkedTo(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TDataSource(Args.Obj).IsLinkedTo(V2O(Args.Values[0]) as TDataSet);\r\nend;\r\n\r\n{ property Read State: TDataSetState }\r\n\r\nprocedure TDataSource_Read_State(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TDataSource(Args.Obj).State;\r\nend;\r\n\r\n{ property Read AutoEdit: Boolean }\r\n\r\nprocedure TDataSource_Read_AutoEdit(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TDataSource(Args.Obj).AutoEdit;\r\nend;\r\n\r\n{ property Write AutoEdit(Value: Boolean) }\r\n\r\nprocedure TDataSource_Write_AutoEdit(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TDataSource(Args.Obj).AutoEdit := Value;\r\nend;\r\n\r\n{ property Read DataSet: TDataSet }\r\n\r\nprocedure TDataSource_Read_DataSet(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TDataSource(Args.Obj).DataSet);\r\nend;\r\n\r\n{ property Write DataSet(Value: TDataSet) }\r\n\r\nprocedure TDataSource_Write_DataSet(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TDataSource(Args.Obj).DataSet := V2O(Value) as TDataSet;\r\nend;\r\n\r\n{ property Read Enabled: Boolean }\r\n\r\nprocedure TDataSource_Read_Enabled(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TDataSource(Args.Obj).Enabled;\r\nend;\r\n\r\n{ property Write Enabled(Value: Boolean) }\r\n\r\nprocedure TDataSource_Write_Enabled(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TDataSource(Args.Obj).Enabled := Value;\r\nend;\r\n\r\n{ TCheckConstraint }\r\n\r\n{ procedure Assign(Source: TPersistent); }\r\n\r\nprocedure TCheckConstraint_Assign(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TCheckConstraint(Args.Obj).Assign(V2O(Args.Values[0]) as TPersistent);\r\nend;\r\n\r\n{ function GetDisplayName: string; }\r\n\r\nprocedure TCheckConstraint_GetDisplayName(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TCheckConstraint(Args.Obj).GetDisplayName;\r\nend;\r\n\r\n{ property Read CustomConstraint: string }\r\n\r\nprocedure TCheckConstraint_Read_CustomConstraint(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TCheckConstraint(Args.Obj).CustomConstraint;\r\nend;\r\n\r\n{ property Write CustomConstraint(Value: string) }\r\n\r\nprocedure TCheckConstraint_Write_CustomConstraint(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TCheckConstraint(Args.Obj).CustomConstraint := Value;\r\nend;\r\n\r\n{ property Read ErrorMessage: string }\r\n\r\nprocedure TCheckConstraint_Read_ErrorMessage(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TCheckConstraint(Args.Obj).ErrorMessage;\r\nend;\r\n\r\n{ property Write ErrorMessage(Value: string) }\r\n\r\nprocedure TCheckConstraint_Write_ErrorMessage(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TCheckConstraint(Args.Obj).ErrorMessage := Value;\r\nend;\r\n\r\n{ property Read FromDictionary: Boolean }\r\n\r\nprocedure TCheckConstraint_Read_FromDictionary(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TCheckConstraint(Args.Obj).FromDictionary;\r\nend;\r\n\r\n{ property Write FromDictionary(Value: Boolean) }\r\n\r\nprocedure TCheckConstraint_Write_FromDictionary(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TCheckConstraint(Args.Obj).FromDictionary := Value;\r\nend;\r\n\r\n{ property Read ImportedConstraint: string }\r\n\r\nprocedure TCheckConstraint_Read_ImportedConstraint(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TCheckConstraint(Args.Obj).ImportedConstraint;\r\nend;\r\n\r\n{ property Write ImportedConstraint(Value: string) }\r\n\r\nprocedure TCheckConstraint_Write_ImportedConstraint(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TCheckConstraint(Args.Obj).ImportedConstraint := Value;\r\nend;\r\n\r\n{ TCheckConstraints }\r\n\r\n{ constructor Create(Owner: TPersistent) }\r\n\r\nprocedure TCheckConstraints_Create(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TCheckConstraints.Create(V2O(Args.Values[0]) as TPersistent));\r\nend;\r\n\r\n{ function Add: TCheckConstraint; }\r\n\r\nprocedure TCheckConstraints_Add(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TCheckConstraints(Args.Obj).Add);\r\nend;\r\n\r\n{ property Read Items[Integer]: TCheckConstraint }\r\n\r\nprocedure TCheckConstraints_Read_Items(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TCheckConstraints(Args.Obj).Items[Args.Values[0]]);\r\nend;\r\n\r\n{ property Write Items[Integer]: TCheckConstraint }\r\n\r\nprocedure TCheckConstraints_Write_Items(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TCheckConstraints(Args.Obj).Items[Args.Values[0]] := V2O(Value) as TCheckConstraint;\r\nend;\r\n\r\n{ TDataSet }\r\n\r\n{ function ActiveBuffer: PChar; }\r\n\r\nprocedure TDataSet_ActiveBuffer(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := string(PString(TDataSet(Args.Obj).ActiveBuffer));\r\nend;\r\n\r\n{ procedure Append; }\r\n\r\nprocedure TDataSet_Append(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TDataSet(Args.Obj).Append;\r\nend;\r\n\r\n{ procedure AppendRecord(const Values: array of const); }\r\n\r\nprocedure TDataSet_AppendRecord(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Args.OpenArray(0);\r\n TDataSet(Args.Obj).AppendRecord(Slice(Args.OA^, Args.OAS));\r\nend;\r\n\r\n{ function BookmarkValid(Bookmark: TBookmark): Boolean; }\r\n\r\nprocedure TDataSet_BookmarkValid(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TDataSet(Args.Obj).BookmarkValid(V2P(Args.Values[0]));\r\nend;\r\n\r\n{ procedure Cancel; }\r\n\r\nprocedure TDataSet_Cancel(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TDataSet(Args.Obj).Cancel;\r\nend;\r\n\r\n{ procedure CheckBrowseMode; }\r\n\r\nprocedure TDataSet_CheckBrowseMode(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TDataSet(Args.Obj).CheckBrowseMode;\r\nend;\r\n\r\n{ procedure ClearFields; }\r\n\r\nprocedure TDataSet_ClearFields(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TDataSet(Args.Obj).ClearFields;\r\nend;\r\n\r\n{ procedure Close; }\r\n\r\nprocedure TDataSet_Close(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TDataSet(Args.Obj).Close;\r\nend;\r\n\r\n{ function ControlsDisabled: Boolean; }\r\n\r\nprocedure TDataSet_ControlsDisabled(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TDataSet(Args.Obj).ControlsDisabled;\r\nend;\r\n\r\n{ function CompareBookmarks(Bookmark1, Bookmark2: TBookmark): Integer; }\r\n\r\nprocedure TDataSet_CompareBookmarks(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TDataSet(Args.Obj).CompareBookmarks(V2P(Args.Values[0]), V2P(Args.Values[1]));\r\nend;\r\n\r\n{ function CreateBlobStream(Field: TField; Mode: TBlobStreamMode): TStream; }\r\n\r\nprocedure TDataSet_CreateBlobStream(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TDataSet(Args.Obj).CreateBlobStream(V2O(Args.Values[0]) as TField, Args.Values[1]));\r\nend;\r\n\r\n{ procedure CursorPosChanged; }\r\n\r\nprocedure TDataSet_CursorPosChanged(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TDataSet(Args.Obj).CursorPosChanged;\r\nend;\r\n\r\n{ procedure Delete; }\r\n\r\nprocedure TDataSet_Delete(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TDataSet(Args.Obj).Delete;\r\nend;\r\n\r\n{ procedure DisableControls; }\r\n\r\nprocedure TDataSet_DisableControls(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TDataSet(Args.Obj).DisableControls;\r\nend;\r\n\r\n{ procedure Edit; }\r\n\r\nprocedure TDataSet_Edit(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TDataSet(Args.Obj).Edit;\r\nend;\r\n\r\n{ procedure EnableControls; }\r\n\r\nprocedure TDataSet_EnableControls(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TDataSet(Args.Obj).EnableControls;\r\nend;\r\n\r\n{ function FieldByName(const FieldName: string): TField; }\r\n\r\nprocedure TDataSet_FieldByName(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TDataSet(Args.Obj).FieldByName(Args.Values[0]));\r\nend;\r\n\r\n{ function FindField(const FieldName: string): TField; }\r\n\r\nprocedure TDataSet_FindField(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TDataSet(Args.Obj).FindField(Args.Values[0]));\r\nend;\r\n\r\n{ function FindFirst: Boolean; }\r\n\r\nprocedure TDataSet_FindFirst(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TDataSet(Args.Obj).FindFirst;\r\nend;\r\n\r\n{ function FindLast: Boolean; }\r\n\r\nprocedure TDataSet_FindLast(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TDataSet(Args.Obj).FindLast;\r\nend;\r\n\r\n{ function FindNext: Boolean; }\r\n\r\nprocedure TDataSet_FindNext(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TDataSet(Args.Obj).FindNext;\r\nend;\r\n\r\n{ function FindPrior: Boolean; }\r\n\r\nprocedure TDataSet_FindPrior(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TDataSet(Args.Obj).FindPrior;\r\nend;\r\n\r\n{ procedure First; }\r\n\r\nprocedure TDataSet_First(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TDataSet(Args.Obj).First;\r\nend;\r\n\r\n{ procedure FreeBookmark(Bookmark: TBookmark); }\r\n\r\nprocedure TDataSet_FreeBookmark(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TDataSet(Args.Obj).FreeBookmark(V2P(Args.Values[0]));\r\nend;\r\n\r\n{ function GetBookmark: TBookmark; }\r\n\r\nprocedure TDataSet_GetBookmark(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := P2V(TDataSet(Args.Obj).GetBookmark);\r\nend;\r\n\r\n{ function GetCurrentRecord(Buffer: PChar): Boolean; }\r\n\r\nprocedure TDataSet_GetCurrentRecord(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TDataSet(Args.Obj).GetCurrentRecord(TJvRecordBuffer(AnsiString(Args.Values[0])));\r\nend;\r\n\r\n{ procedure GetFieldList(List: TList; const FieldNames: string); }\r\n\r\nprocedure TDataSet_GetFieldList(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TDataSet(Args.Obj).GetFieldList(V2O(Args.Values[0]) as TList{$IFDEF RTL240_UP}{$ENDIF RTL240_UP}, Args.Values[1]);\r\nend;\r\n\r\n{ procedure GetFieldNames(List: TStrings); }\r\n\r\nprocedure TDataSet_GetFieldNames(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n {$IFDEF COMPILER10_UP}\r\n {$WARN SYMBOL_DEPRECATED OFF}\r\n TDataSet(Args.Obj).GetFieldNames(V2O(Args.Values[0]) as TStrings);\r\n {$WARN SYMBOL_DEPRECATED ON}\r\n {$ELSE}\r\n TDataSet(Args.Obj).GetFieldNames(V2O(Args.Values[0]) as TStrings);\r\n {$ENDIF COMPILER10_UP}\r\nend;\r\n\r\n{ procedure GotoBookmark(Bookmark: TBookmark); }\r\n\r\nprocedure TDataSet_GotoBookmark(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TDataSet(Args.Obj).GotoBookmark(V2P(Args.Values[0]));\r\nend;\r\n\r\n{ procedure Insert; }\r\n\r\nprocedure TDataSet_Insert(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TDataSet(Args.Obj).Insert;\r\nend;\r\n\r\n{ procedure InsertRecord(const Values: array of const); }\r\n\r\nprocedure TDataSet_InsertRecord(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Args.OpenArray(0);\r\n TDataSet(Args.Obj).InsertRecord(Slice(Args.OA^, Args.OAS));\r\nend;\r\n\r\n{ function IsEmpty: Boolean; }\r\n\r\nprocedure TDataSet_IsEmpty(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TDataSet(Args.Obj).IsEmpty;\r\nend;\r\n\r\n{ function IsLinkedTo(DataSource: TDataSource): Boolean; }\r\n\r\nprocedure TDataSet_IsLinkedTo(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TDataSet(Args.Obj).IsLinkedTo(V2O(Args.Values[0]) as TDataSource);\r\nend;\r\n\r\n{ function IsSequenced: Boolean; }\r\n\r\nprocedure TDataSet_IsSequenced(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TDataSet(Args.Obj).IsSequenced;\r\nend;\r\n\r\n{ procedure Last; }\r\n\r\nprocedure TDataSet_Last(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TDataSet(Args.Obj).Last;\r\nend;\r\n\r\n{ function Locate(const KeyFields: string; const KeyValues: Variant; Options: TLocateOptions): Boolean; }\r\n\r\nprocedure TDataSet_Locate(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TDataSet(Args.Obj).Locate(Args.Values[0], Args.Values[1], TLocateOptions(Byte(V2S(Args.Values[2]))));\r\nend;\r\n\r\n{ function Lookup(const KeyFields: string; const KeyValues: Variant; const ResultFields: string): Variant; }\r\n\r\nprocedure TDataSet_Lookup(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TDataSet(Args.Obj).Lookup(Args.Values[0], Args.Values[1], Args.Values[2]);\r\nend;\r\n\r\n{ function MoveBy(Distance: Integer): Integer; }\r\n\r\nprocedure TDataSet_MoveBy(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TDataSet(Args.Obj).MoveBy(Args.Values[0]);\r\nend;\r\n\r\n{ procedure Next; }\r\n\r\nprocedure TDataSet_Next(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TDataSet(Args.Obj).Next;\r\nend;\r\n\r\n{ procedure Open; }\r\n\r\nprocedure TDataSet_Open(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TDataSet(Args.Obj).Open;\r\nend;\r\n\r\n{ procedure Post; }\r\n\r\nprocedure TDataSet_Post(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TDataSet(Args.Obj).Post;\r\nend;\r\n\r\n{ procedure Prior; }\r\n\r\nprocedure TDataSet_Prior(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TDataSet(Args.Obj).Prior;\r\nend;\r\n\r\n{ procedure Refresh; }\r\n\r\nprocedure TDataSet_Refresh(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TDataSet(Args.Obj).Refresh;\r\nend;\r\n\r\n{ procedure Resync(Mode: TResyncMode); }\r\n\r\nprocedure TDataSet_Resync(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TDataSet(Args.Obj).Resync(TResyncMode(Byte(V2S(Args.Values[0]))));\r\nend;\r\n\r\n{ procedure SetFields(const Values: array of const); }\r\n\r\nprocedure TDataSet_SetFields(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Args.OpenArray(0);\r\n TDataSet(Args.Obj).SetFields(Slice(Args.OA^, Args.OAS));\r\nend;\r\n\r\n{ procedure Translate(Src, Dest: PChar; ToOem: Boolean); }\r\n\r\nprocedure TDataSet_Translate(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TDataSet(Args.Obj).Translate(PAnsiChar(AnsiString(Args.Values[0])),\r\n PAnsiChar(AnsiString(Args.Values[1])),\r\n Args.Values[2]);\r\nend;\r\n\r\n{ procedure UpdateCursorPos; }\r\n\r\nprocedure TDataSet_UpdateCursorPos(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TDataSet(Args.Obj).UpdateCursorPos;\r\nend;\r\n\r\n{ procedure UpdateRecord; }\r\n\r\nprocedure TDataSet_UpdateRecord(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TDataSet(Args.Obj).UpdateRecord;\r\nend;\r\n\r\n{ property Read BOF: Boolean }\r\n\r\nprocedure TDataSet_Read_BOF(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TDataSet(Args.Obj).BOF;\r\nend;\r\n\r\n{ property Read Bookmark: TBookmarkStr }\r\n\r\nprocedure TDataSet_Read_Bookmark(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TDataSet(Args.Obj).Bookmark;\r\nend;\r\n\r\n{ property Write Bookmark(Value: TBookmarkStr) }\r\n\r\nprocedure TDataSet_Write_Bookmark(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TDataSet(Args.Obj).Bookmark := Value;\r\nend;\r\n\r\n{ property Read CanModify: Boolean }\r\n\r\nprocedure TDataSet_Read_CanModify(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TDataSet(Args.Obj).CanModify;\r\nend;\r\n\r\n{ property Read DataSource: TDataSource }\r\n\r\nprocedure TDataSet_Read_DataSource(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TDataSet(Args.Obj).DataSource);\r\nend;\r\n\r\n{ property Read DefaultFields: Boolean }\r\n\r\nprocedure TDataSet_Read_DefaultFields(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TDataSet(Args.Obj).DefaultFields;\r\nend;\r\n\r\n{ property Read Designer: TDataSetDesigner }\r\n\r\nprocedure TDataSet_Read_Designer(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TDataSet(Args.Obj).Designer);\r\nend;\r\n\r\n{ property Read EOF: Boolean }\r\n\r\nprocedure TDataSet_Read_EOF(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TDataSet(Args.Obj).EOF;\r\nend;\r\n\r\n{ property Read FieldCount: Integer }\r\n\r\nprocedure TDataSet_Read_FieldCount(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TDataSet(Args.Obj).FieldCount;\r\nend;\r\n\r\n{ property Read FieldDefs: TFieldDefs }\r\n\r\nprocedure TDataSet_Read_FieldDefs(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TDataSet(Args.Obj).FieldDefs);\r\nend;\r\n\r\n{ property Write FieldDefs(Value: TFieldDefs) }\r\n\r\nprocedure TDataSet_Write_FieldDefs(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TDataSet(Args.Obj).FieldDefs := V2O(Value) as TFieldDefs;\r\nend;\r\n\r\n{ property Read Fields[Integer]: TField }\r\n\r\nprocedure TDataSet_Read_Fields(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TDataSet(Args.Obj).Fields[Args.Values[0]]);\r\nend;\r\n\r\n{ property Read FieldValues[string]: Variant }\r\n\r\nprocedure TDataSet_Read_FieldValues(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TDataSet(Args.Obj).FieldValues[Args.Values[0]];\r\nend;\r\n\r\n{ property Write FieldValues[string]: Variant }\r\n\r\nprocedure TDataSet_Write_FieldValues(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TDataSet(Args.Obj).FieldValues[Args.Values[0]] := Value;\r\nend;\r\n\r\n{ property Read Found: Boolean }\r\n\r\nprocedure TDataSet_Read_Found(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TDataSet(Args.Obj).Found;\r\nend;\r\n\r\n{ property Read Modified: Boolean }\r\n\r\nprocedure TDataSet_Read_Modified(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TDataSet(Args.Obj).Modified;\r\nend;\r\n\r\n{ property Read RecordCount: Integer }\r\n\r\nprocedure TDataSet_Read_RecordCount(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TDataSet(Args.Obj).RecordCount;\r\nend;\r\n\r\n{ property Read RecNo: Integer }\r\n\r\nprocedure TDataSet_Read_RecNo(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TDataSet(Args.Obj).RecNo;\r\nend;\r\n\r\n{ property Write RecNo(Value: Integer) }\r\n\r\nprocedure TDataSet_Write_RecNo(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TDataSet(Args.Obj).RecNo := Value;\r\nend;\r\n\r\n{ property Read RecordSize: Word }\r\n\r\nprocedure TDataSet_Read_RecordSize(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TDataSet(Args.Obj).RecordSize;\r\nend;\r\n\r\n{ property Read State: TDataSetState }\r\n\r\nprocedure TDataSet_Read_State(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TDataSet(Args.Obj).State;\r\nend;\r\n\r\n{ property Read Filter: string }\r\n\r\nprocedure TDataSet_Read_Filter(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TDataSet(Args.Obj).Filter;\r\nend;\r\n\r\n{ property Write Filter(Value: string) }\r\n\r\nprocedure TDataSet_Write_Filter(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TDataSet(Args.Obj).Filter := Value;\r\nend;\r\n\r\n{ property Read Filtered: Boolean }\r\n\r\nprocedure TDataSet_Read_Filtered(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TDataSet(Args.Obj).Filtered;\r\nend;\r\n\r\n{ property Write Filtered(Value: Boolean) }\r\n\r\nprocedure TDataSet_Write_Filtered(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TDataSet(Args.Obj).Filtered := Value;\r\nend;\r\n\r\n{ property Read FilterOptions: TFilterOptions }\r\n\r\nprocedure TDataSet_Read_FilterOptions(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := S2V(Byte(TDataSet(Args.Obj).FilterOptions));\r\nend;\r\n\r\n{ property Write FilterOptions(Value: TFilterOptions) }\r\n\r\nprocedure TDataSet_Write_FilterOptions(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TDataSet(Args.Obj).FilterOptions := TFilterOptions(Byte(V2S(Value)));\r\nend;\r\n\r\n{ property Read Active: Boolean }\r\n\r\nprocedure TDataSet_Read_Active(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TDataSet(Args.Obj).Active;\r\nend;\r\n\r\n{ property Write Active(Value: Boolean) }\r\n\r\nprocedure TDataSet_Write_Active(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TDataSet(Args.Obj).Active := Value;\r\nend;\r\n\r\n{ property Read AutoCalcFields: Boolean }\r\n\r\nprocedure TDataSet_Read_AutoCalcFields(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TDataSet(Args.Obj).AutoCalcFields;\r\nend;\r\n\r\n{ property Write AutoCalcFields(Value: Boolean) }\r\n\r\nprocedure TDataSet_Write_AutoCalcFields(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TDataSet(Args.Obj).AutoCalcFields := Value;\r\nend;\r\n\r\ntype\r\n\r\n TJvInterpreterDbEvent = class(TJvInterpreterEvent)\r\n private\r\n procedure FieldNotifyEvent(Sender: TField);\r\n procedure FieldGetTextEvent(Sender: TField; var Text: string; DisplayText: Boolean);\r\n procedure FieldSetTextEvent(Sender: TField; const Text: string);\r\n procedure DataChangeEvent(Sender: TObject; Field: TField);\r\n procedure DataSetNotifyEvent(DataSet: TDataSet);\r\n procedure DataSetErrorEvent(DataSet: TDataSet; E: EDatabaseError; var Action: TDataAction);\r\n procedure FilterRecordEvent(DataSet: TDataSet; var Accept: Boolean);\r\n end;\r\n\r\nprocedure TJvInterpreterDbEvent.FieldNotifyEvent(Sender: TField);\r\nbegin\r\n CallFunction(nil, [O2V(Sender)]);\r\nend;\r\n\r\nprocedure TJvInterpreterDbEvent.FieldGetTextEvent(Sender: TField; var Text: string; DisplayText: Boolean);\r\nbegin\r\n CallFunction(nil, [O2V(Sender), Text, DisplayText]);\r\n Text := Args.Values[1];\r\nend;\r\n\r\nprocedure TJvInterpreterDbEvent.FieldSetTextEvent(Sender: TField; const Text: string);\r\nbegin\r\n CallFunction(nil, [O2V(Sender), Text]);\r\nend;\r\n\r\nprocedure TJvInterpreterDbEvent.DataChangeEvent(Sender: TObject; Field: TField);\r\nbegin\r\n CallFunction(nil, [O2V(Sender), O2V(Field)]);\r\nend;\r\n\r\nprocedure TJvInterpreterDbEvent.DataSetNotifyEvent(DataSet: TDataSet);\r\nbegin\r\n CallFunction(nil, [O2V(DataSet)]);\r\nend;\r\n\r\nprocedure TJvInterpreterDbEvent.DataSetErrorEvent(DataSet: TDataSet; E: EDatabaseError; var Action: TDataAction);\r\nbegin\r\n CallFunction(nil, [O2V(DataSet), O2V(E), Action]);\r\n Action := Args.Values[2];\r\nend;\r\n\r\nprocedure TJvInterpreterDbEvent.FilterRecordEvent(DataSet: TDataSet; var Accept: Boolean);\r\nbegin\r\n CallFunction(nil, [O2V(DataSet), Accept]);\r\n Accept := Args.Values[1];\r\nend;\r\n\r\nprocedure RegisterJvInterpreterAdapter(JvInterpreterAdapter: TJvInterpreterAdapter);\r\nconst\r\n cDb = 'Db';\r\nbegin\r\n with JvInterpreterAdapter do\r\n begin\r\n { TDataSetState }\r\n AddConst(cDb, 'dsInactive', Ord(dsInactive));\r\n AddConst(cDb, 'dsBrowse', Ord(dsBrowse));\r\n AddConst(cDb, 'dsEdit', Ord(dsEdit));\r\n AddConst(cDb, 'dsInsert', Ord(dsInsert));\r\n AddConst(cDb, 'dsSetKey', Ord(dsSetKey));\r\n AddConst(cDb, 'dsCalcFields', Ord(dsCalcFields));\r\n AddConst(cDb, 'dsFilter', Ord(dsFilter));\r\n AddConst(cDb, 'dsNewValue', Ord(dsNewValue));\r\n AddConst(cDb, 'dsOldValue', Ord(dsOldValue));\r\n AddConst(cDb, 'dsCurValue', Ord(dsCurValue));\r\n { TDataEvent }\r\n AddConst(cDb, 'deFieldChange', Ord(deFieldChange));\r\n AddConst(cDb, 'deRecordChange', Ord(deRecordChange));\r\n AddConst(cDb, 'deDataSetChange', Ord(deDataSetChange));\r\n AddConst(cDb, 'deDataSetScroll', Ord(deDataSetScroll));\r\n AddConst(cDb, 'deLayoutChange', Ord(deLayoutChange));\r\n AddConst(cDb, 'deUpdateRecord', Ord(deUpdateRecord));\r\n AddConst(cDb, 'deUpdateState', Ord(deUpdateState));\r\n AddConst(cDb, 'deCheckBrowseMode', Ord(deCheckBrowseMode));\r\n AddConst(cDb, 'dePropertyChange', Ord(dePropertyChange));\r\n AddConst(cDb, 'deFieldListChange', Ord(deFieldListChange));\r\n AddConst(cDb, 'deFocusControl', Ord(deFocusControl));\r\n { TUpdateStatus }\r\n AddConst(cDb, 'usUnmodified', Ord(usUnmodified));\r\n AddConst(cDb, 'usModified', Ord(usModified));\r\n AddConst(cDb, 'usInserted', Ord(usInserted));\r\n AddConst(cDb, 'usDeleted', Ord(usDeleted));\r\n { EDatabaseError }\r\n AddClass(cDb, EDatabaseError, 'EDatabaseError');\r\n { TFieldType }\r\n AddConst(cDb, 'ftUnknown', Ord(ftUnknown));\r\n AddConst(cDb, 'ftString', Ord(ftString));\r\n AddConst(cDb, 'ftSmallint', Ord(ftSmallint));\r\n AddConst(cDb, 'ftInteger', Ord(ftInteger));\r\n AddConst(cDb, 'ftWord', Ord(ftWord));\r\n AddConst(cDb, 'ftBoolean', Ord(ftBoolean));\r\n AddConst(cDb, 'ftFloat', Ord(ftFloat));\r\n AddConst(cDb, 'ftCurrency', Ord(ftCurrency));\r\n AddConst(cDb, 'ftBCD', Ord(ftBCD));\r\n AddConst(cDb, 'ftDate', Ord(ftDate));\r\n AddConst(cDb, 'ftTime', Ord(ftTime));\r\n AddConst(cDb, 'ftDateTime', Ord(ftDateTime));\r\n AddConst(cDb, 'ftBytes', Ord(ftBytes));\r\n AddConst(cDb, 'ftVarBytes', Ord(ftVarBytes));\r\n AddConst(cDb, 'ftAutoInc', Ord(ftAutoInc));\r\n AddConst(cDb, 'ftBlob', Ord(ftBlob));\r\n AddConst(cDb, 'ftMemo', Ord(ftMemo));\r\n AddConst(cDb, 'ftGraphic', Ord(ftGraphic));\r\n AddConst(cDb, 'ftFmtMemo', Ord(ftFmtMemo));\r\n AddConst(cDb, 'ftParadoxOle', Ord(ftParadoxOle));\r\n AddConst(cDb, 'ftDBaseOle', Ord(ftDBaseOle));\r\n AddConst(cDb, 'ftTypedBinary', Ord(ftTypedBinary));\r\n AddConst(cDb, 'ftCursor', Ord(ftCursor));\r\n AddConst(cDb, 'ftFMTBCD', Ord(ftFMTBCD));\r\n AddConst(cDb, 'ftTimestamp', Ord(ftTimestamp));\r\n {$IFDEF COMPILER10_UP}\r\n AddConst(cDb, 'ftFixedWideChar', Ord(ftFixedWideChar));\r\n AddConst(cDb, 'ftWideMemo', Ord(ftWideMemo));\r\n AddConst(cDb, 'ftOraTimeStamp', Ord(ftOraTimeStamp));\r\n AddConst(cDb, 'ftOraInterval', Ord(ftOraInterval));\r\n {$ENDIF COMPILER10_UP}\r\n {$IFDEF COMPILER12_UP}\r\n AddConst(cDb, 'ftLongWord', Ord(ftLongWord));\r\n AddConst(cDb, 'ftShortint', Ord(ftShortint));\r\n AddConst(cDb, 'ftByte', Ord(ftByte));\r\n AddConst(cDb, 'ftExtended', Ord(ftExtended));\r\n AddConst(cDb, 'ftConnection', Ord(ftConnection));\r\n AddConst(cDb, 'ftParams', Ord(ftParams));\r\n AddConst(cDb, 'ftStream', Ord(ftStream));\r\n {$ENDIF COMPILER12_UP}\r\n { TFieldDef }\r\n AddClass(cDb, TFieldDef, 'TFieldDef');\r\n AddGet(TFieldDef, 'Create', TFieldDef_Create, 6, [varEmpty, varEmpty, varEmpty, varEmpty, varEmpty, varEmpty],\r\n varEmpty);\r\n AddGet(TFieldDef, 'CreateField', TFieldDef_CreateField, 1, [varEmpty], varEmpty);\r\n AddGet(TFieldDef, 'InternalCalcField', TFieldDef_Read_InternalCalcField, 0, [varEmpty], varEmpty);\r\n AddSet(TFieldDef, 'InternalCalcField', TFieldDef_Write_InternalCalcField, 0, [varEmpty]);\r\n AddGet(TFieldDef, 'DataType', TFieldDef_Read_DataType, 0, [varEmpty], varEmpty);\r\n AddGet(TFieldDef, 'FieldClass', TFieldDef_Read_FieldClass, 0, [varEmpty], varEmpty);\r\n AddGet(TFieldDef, 'FieldNo', TFieldDef_Read_FieldNo, 0, [varEmpty], varEmpty);\r\n AddGet(TFieldDef, 'Name', TFieldDef_Read_Name, 0, [varEmpty], varEmpty);\r\n AddGet(TFieldDef, 'Precision', TFieldDef_Read_Precision, 0, [varEmpty], varEmpty);\r\n AddSet(TFieldDef, 'Precision', TFieldDef_Write_Precision, 0, [varEmpty]);\r\n AddGet(TFieldDef, 'Required', TFieldDef_Read_Required, 0, [varEmpty], varEmpty);\r\n AddGet(TFieldDef, 'Size', TFieldDef_Read_Size, 0, [varEmpty], varEmpty);\r\n { TFieldDefs }\r\n AddClass(cDb, TFieldDefs, 'TFieldDefs');\r\n AddGet(TFieldDefs, 'Create', TFieldDefs_Create, 1, [varEmpty], varEmpty);\r\n AddGet(TFieldDefs, 'Add', TFieldDefs_Add, 4, [varEmpty, varEmpty, varEmpty, varEmpty], varEmpty);\r\n AddGet(TFieldDefs, 'Assign', TFieldDefs_Assign, 1, [varEmpty], varEmpty);\r\n AddGet(TFieldDefs, 'Clear', TFieldDefs_Clear, 0, [varEmpty], varEmpty);\r\n AddGet(TFieldDefs, 'Find', TFieldDefs_Find, 1, [varEmpty], varEmpty);\r\n AddGet(TFieldDefs, 'IndexOf', TFieldDefs_IndexOf, 1, [varEmpty], varEmpty);\r\n AddGet(TFieldDefs, 'Update', TFieldDefs_Update, 0, [varEmpty], varEmpty);\r\n AddGet(TFieldDefs, 'Count', TFieldDefs_Read_Count, 0, [varEmpty], varEmpty);\r\n AddIGet(TFieldDefs, 'Items', TFieldDefs_Read_Items, 1, [varEmpty], varEmpty);\r\n { TFieldKind }\r\n AddConst(cDb, 'fkData', Ord(fkData));\r\n AddConst(cDb, 'fkCalculated', Ord(fkCalculated));\r\n AddConst(cDb, 'fkLookup', Ord(fkLookup));\r\n AddConst(cDb, 'fkInternalCalc', Ord(fkInternalCalc));\r\n { TField }\r\n AddClass(cDb, TField, 'TField');\r\n AddGet(TField, 'Create', TField_Create, 1, [varEmpty], varEmpty);\r\n AddGet(TField, 'Assign', TField_Assign, 1, [varEmpty], varEmpty);\r\n // AddGet(TField, 'AssignValue', TField_AssignValue, 1, [varEmpty], nil);\r\n AddGet(TField, 'Clear', TField_Clear, 0, [varEmpty], varEmpty);\r\n AddGet(TField, 'FocusControl', TField_FocusControl, 0, [varEmpty], varEmpty);\r\n AddGet(TField, 'GetData', TField_GetData, 1, [varEmpty], varEmpty);\r\n AddGet(TField, 'IsBlob', TField_IsBlob, 0, [varEmpty], varEmpty);\r\n AddGet(TField, 'IsValidChar', TField_IsValidChar, 1, [varEmpty], varEmpty);\r\n AddGet(TField, 'RefreshLookupList', TField_RefreshLookupList, 0, [varEmpty], varEmpty);\r\n AddGet(TField, 'SetData', TField_SetData, 1, [varEmpty], varEmpty);\r\n AddGet(TField, 'SetFieldType', TField_SetFieldType, 1, [varEmpty], varEmpty);\r\n AddGet(TField, 'Validate', TField_Validate, 1, [varEmpty], varEmpty);\r\n AddGet(TField, 'AsBoolean', TField_Read_AsBoolean, 0, [varEmpty], varEmpty);\r\n AddSet(TField, 'AsBoolean', TField_Write_AsBoolean, 0, [varEmpty]);\r\n AddGet(TField, 'AsCurrency', TField_Read_AsCurrency, 0, [varEmpty], varEmpty);\r\n AddSet(TField, 'AsCurrency', TField_Write_AsCurrency, 0, [varEmpty]);\r\n AddGet(TField, 'AsDateTime', TField_Read_AsDateTime, 0, [varEmpty], varEmpty);\r\n AddSet(TField, 'AsDateTime', TField_Write_AsDateTime, 0, [varEmpty]);\r\n AddGet(TField, 'AsFloat', TField_Read_AsFloat, 0, [varEmpty], varEmpty);\r\n AddSet(TField, 'AsFloat', TField_Write_AsFloat, 0, [varEmpty]);\r\n AddGet(TField, 'AsInteger', TField_Read_AsInteger, 0, [varEmpty], varEmpty);\r\n AddSet(TField, 'AsInteger', TField_Write_AsInteger, 0, [varEmpty]);\r\n AddGet(TField, 'AsString', TField_Read_AsString, 0, [varEmpty], varEmpty);\r\n AddSet(TField, 'AsString', TField_Write_AsString, 0, [varEmpty]);\r\n AddGet(TField, 'AsVariant', TField_Read_AsVariant, 0, [varEmpty], varEmpty);\r\n AddSet(TField, 'AsVariant', TField_Write_AsVariant, 0, [varEmpty]);\r\n AddGet(TField, 'AttributeSet', TField_Read_AttributeSet, 0, [varEmpty], varEmpty);\r\n AddSet(TField, 'AttributeSet', TField_Write_AttributeSet, 0, [varEmpty]);\r\n AddGet(TField, 'Calculated', TField_Read_Calculated, 0, [varEmpty], varEmpty);\r\n AddSet(TField, 'Calculated', TField_Write_Calculated, 0, [varEmpty]);\r\n AddGet(TField, 'CanModify', TField_Read_CanModify, 0, [varEmpty], varEmpty);\r\n AddGet(TField, 'CurValue', TField_Read_CurValue, 0, [varEmpty], varEmpty);\r\n AddGet(TField, 'DataSet', TField_Read_DataSet, 0, [varEmpty], varEmpty);\r\n AddSet(TField, 'DataSet', TField_Write_DataSet, 0, [varEmpty]);\r\n AddGet(TField, 'DataSize', TField_Read_DataSize, 0, [varEmpty], varEmpty);\r\n AddGet(TField, 'DataType', TField_Read_DataType, 0, [varEmpty], varEmpty);\r\n AddGet(TField, 'DisplayName', TField_Read_DisplayName, 0, [varEmpty], varEmpty);\r\n AddGet(TField, 'DisplayText', TField_Read_DisplayText, 0, [varEmpty], varEmpty);\r\n AddGet(TField, 'EditMask', TField_Read_EditMask, 0, [varEmpty], varEmpty);\r\n AddSet(TField, 'EditMask', TField_Write_EditMask, 0, [varEmpty]);\r\n AddGet(TField, 'EditMaskPtr', TField_Read_EditMaskPtr, 0, [varEmpty], varEmpty);\r\n AddGet(TField, 'FieldNo', TField_Read_FieldNo, 0, [varEmpty], varEmpty);\r\n AddGet(TField, 'IsIndexField', TField_Read_IsIndexField, 0, [varEmpty], varEmpty);\r\n AddGet(TField, 'IsNull', TField_Read_IsNull, 0, [varEmpty], varEmpty);\r\n AddGet(TField, 'Lookup', TField_Read_Lookup, 0, [varEmpty], varEmpty);\r\n AddSet(TField, 'Lookup', TField_Write_Lookup, 0, [varEmpty]);\r\n AddGet(TField, 'NewValue', TField_Read_NewValue, 0, [varEmpty], varEmpty);\r\n AddSet(TField, 'NewValue', TField_Write_NewValue, 0, [varEmpty]);\r\n AddGet(TField, 'Offset', TField_Read_Offset, 0, [varEmpty], varEmpty);\r\n AddGet(TField, 'OldValue', TField_Read_OldValue, 0, [varEmpty], varEmpty);\r\n AddGet(TField, 'Size', TField_Read_Size, 0, [varEmpty], varEmpty);\r\n AddSet(TField, 'Size', TField_Write_Size, 0, [varEmpty]);\r\n AddGet(TField, 'Text', TField_Read_Text, 0, [varEmpty], varEmpty);\r\n AddSet(TField, 'Text', TField_Write_Text, 0, [varEmpty]);\r\n { AddGet(TField, 'ValidChars', TField_Read_ValidChars, 0, [varEmpty], nil);\r\n AddSet(TField, 'ValidChars', TField_Write_ValidChars, 0, [varEmpty]); }\r\n AddGet(TField, 'Value', TField_Read_Value, 0, [varEmpty], varEmpty);\r\n AddSet(TField, 'Value', TField_Write_Value, 0, [varEmpty]);\r\n AddGet(TField, 'Alignment', TField_Read_Alignment, 0, [varEmpty], varEmpty);\r\n AddSet(TField, 'Alignment', TField_Write_Alignment, 0, [varEmpty]);\r\n AddGet(TField, 'CustomConstraint', TField_Read_CustomConstraint, 0, [varEmpty], varEmpty);\r\n AddSet(TField, 'CustomConstraint', TField_Write_CustomConstraint, 0, [varEmpty]);\r\n AddGet(TField, 'ConstraintErrorMessage', TField_Read_ConstraintErrorMessage, 0, [varEmpty], varEmpty);\r\n AddSet(TField, 'ConstraintErrorMessage', TField_Write_ConstraintErrorMessage, 0, [varEmpty]);\r\n AddGet(TField, 'DefaultExpression', TField_Read_DefaultExpression, 0, [varEmpty], varEmpty);\r\n AddSet(TField, 'DefaultExpression', TField_Write_DefaultExpression, 0, [varEmpty]);\r\n AddGet(TField, 'DisplayLabel', TField_Read_DisplayLabel, 0, [varEmpty], varEmpty);\r\n AddSet(TField, 'DisplayLabel', TField_Write_DisplayLabel, 0, [varEmpty]);\r\n AddGet(TField, 'DisplayWidth', TField_Read_DisplayWidth, 0, [varEmpty], varEmpty);\r\n AddSet(TField, 'DisplayWidth', TField_Write_DisplayWidth, 0, [varEmpty]);\r\n AddGet(TField, 'FieldKind', TField_Read_FieldKind, 0, [varEmpty], varEmpty);\r\n AddSet(TField, 'FieldKind', TField_Write_FieldKind, 0, [varEmpty]);\r\n AddGet(TField, 'FieldName', TField_Read_FieldName, 0, [varEmpty], varEmpty);\r\n AddSet(TField, 'FieldName', TField_Write_FieldName, 0, [varEmpty]);\r\n AddGet(TField, 'HasConstraints', TField_Read_HasConstraints, 0, [varEmpty], varEmpty);\r\n AddGet(TField, 'Index', TField_Read_Index, 0, [varEmpty], varEmpty);\r\n AddSet(TField, 'Index', TField_Write_Index, 0, [varEmpty]);\r\n AddGet(TField, 'ImportedConstraint', TField_Read_ImportedConstraint, 0, [varEmpty], varEmpty);\r\n AddSet(TField, 'ImportedConstraint', TField_Write_ImportedConstraint, 0, [varEmpty]);\r\n AddGet(TField, 'LookupDataSet', TField_Read_LookupDataSet, 0, [varEmpty], varEmpty);\r\n AddSet(TField, 'LookupDataSet', TField_Write_LookupDataSet, 0, [varEmpty]);\r\n AddGet(TField, 'LookupKeyFields', TField_Read_LookupKeyFields, 0, [varEmpty], varEmpty);\r\n AddSet(TField, 'LookupKeyFields', TField_Write_LookupKeyFields, 0, [varEmpty]);\r\n AddGet(TField, 'LookupResultField', TField_Read_LookupResultField, 0, [varEmpty], varEmpty);\r\n AddSet(TField, 'LookupResultField', TField_Write_LookupResultField, 0, [varEmpty]);\r\n AddGet(TField, 'KeyFields', TField_Read_KeyFields, 0, [varEmpty], varEmpty);\r\n AddSet(TField, 'KeyFields', TField_Write_KeyFields, 0, [varEmpty]);\r\n AddGet(TField, 'LookupCache', TField_Read_LookupCache, 0, [varEmpty], varEmpty);\r\n AddSet(TField, 'LookupCache', TField_Write_LookupCache, 0, [varEmpty]);\r\n AddGet(TField, 'Origin', TField_Read_Origin, 0, [varEmpty], varEmpty);\r\n AddSet(TField, 'Origin', TField_Write_Origin, 0, [varEmpty]);\r\n AddGet(TField, 'ReadOnly', TField_Read_ReadOnly, 0, [varEmpty], varEmpty);\r\n AddSet(TField, 'ReadOnly', TField_Write_ReadOnly, 0, [varEmpty]);\r\n AddGet(TField, 'Required', TField_Read_Required, 0, [varEmpty], varEmpty);\r\n AddSet(TField, 'Required', TField_Write_Required, 0, [varEmpty]);\r\n AddGet(TField, 'Visible', TField_Read_Visible, 0, [varEmpty], varEmpty);\r\n AddSet(TField, 'Visible', TField_Write_Visible, 0, [varEmpty]);\r\n { TStringField }\r\n AddClass(cDb, TStringField, 'TStringField');\r\n AddGet(TStringField, 'Create', TStringField_Create, 1, [varEmpty], varEmpty);\r\n AddGet(TStringField, 'Value', TStringField_Read_Value, 0, [varEmpty], varEmpty);\r\n AddSet(TStringField, 'Value', TStringField_Write_Value, 0, [varEmpty]);\r\n AddGet(TStringField, 'Transliterate', TStringField_Read_Transliterate, 0, [varEmpty], varEmpty);\r\n AddSet(TStringField, 'Transliterate', TStringField_Write_Transliterate, 0, [varEmpty]);\r\n { TNumericField }\r\n AddClass(cDb, TNumericField, 'TNumericField');\r\n AddGet(TNumericField, 'Create', TNumericField_Create, 1, [varEmpty], varEmpty);\r\n AddGet(TNumericField, 'DisplayFormat', TNumericField_Read_DisplayFormat, 0, [varEmpty], varEmpty);\r\n AddSet(TNumericField, 'DisplayFormat', TNumericField_Write_DisplayFormat, 0, [varEmpty]);\r\n AddGet(TNumericField, 'EditFormat', TNumericField_Read_EditFormat, 0, [varEmpty], varEmpty);\r\n AddSet(TNumericField, 'EditFormat', TNumericField_Write_EditFormat, 0, [varEmpty]);\r\n { TIntegerField }\r\n AddClass(cDb, TIntegerField, 'TIntegerField');\r\n AddGet(TIntegerField, 'Create', TIntegerField_Create, 1, [varEmpty], varEmpty);\r\n AddGet(TIntegerField, 'Value', TIntegerField_Read_Value, 0, [varEmpty], varEmpty);\r\n AddSet(TIntegerField, 'Value', TIntegerField_Write_Value, 0, [varEmpty]);\r\n AddGet(TIntegerField, 'MaxValue', TIntegerField_Read_MaxValue, 0, [varEmpty], varEmpty);\r\n AddSet(TIntegerField, 'MaxValue', TIntegerField_Write_MaxValue, 0, [varEmpty]);\r\n AddGet(TIntegerField, 'MinValue', TIntegerField_Read_MinValue, 0, [varEmpty], varEmpty);\r\n AddSet(TIntegerField, 'MinValue', TIntegerField_Write_MinValue, 0, [varEmpty]);\r\n { TSmallintField }\r\n AddClass(cDb, TSmallintField, 'TSmallintField');\r\n AddGet(TSmallintField, 'Create', TSmallintField_Create, 1, [varEmpty], varEmpty);\r\n { TWordField }\r\n AddClass(cDb, TWordField, 'TWordField');\r\n AddGet(TWordField, 'Create', TWordField_Create, 1, [varEmpty], varEmpty);\r\n { TAutoIncField }\r\n AddClass(cDb, TAutoIncField, 'TAutoIncField');\r\n AddGet(TAutoIncField, 'Create', TAutoIncField_Create, 1, [varEmpty], varEmpty);\r\n { TFloatField }\r\n AddClass(cDb, TFloatField, 'TFloatField');\r\n AddGet(TFloatField, 'Create', TFloatField_Create, 1, [varEmpty], varEmpty);\r\n AddGet(TFloatField, 'Value', TFloatField_Read_Value, 0, [varEmpty], varEmpty);\r\n AddSet(TFloatField, 'Value', TFloatField_Write_Value, 0, [varEmpty]);\r\n AddGet(TFloatField, 'Currency', TFloatField_Read_Currency, 0, [varEmpty], varEmpty);\r\n AddSet(TFloatField, 'Currency', TFloatField_Write_Currency, 0, [varEmpty]);\r\n AddGet(TFloatField, 'MaxValue', TFloatField_Read_MaxValue, 0, [varEmpty], varEmpty);\r\n AddSet(TFloatField, 'MaxValue', TFloatField_Write_MaxValue, 0, [varEmpty]);\r\n AddGet(TFloatField, 'MinValue', TFloatField_Read_MinValue, 0, [varEmpty], varEmpty);\r\n AddSet(TFloatField, 'MinValue', TFloatField_Write_MinValue, 0, [varEmpty]);\r\n AddGet(TFloatField, 'Precision', TFloatField_Read_Precision, 0, [varEmpty], varEmpty);\r\n AddSet(TFloatField, 'Precision', TFloatField_Write_Precision, 0, [varEmpty]);\r\n { TCurrencyField }\r\n AddClass(cDb, TCurrencyField, 'TCurrencyField');\r\n AddGet(TCurrencyField, 'Create', TCurrencyField_Create, 1, [varEmpty], varEmpty);\r\n { TBooleanField }\r\n AddClass(cDb, TBooleanField, 'TBooleanField');\r\n AddGet(TBooleanField, 'Create', TBooleanField_Create, 1, [varEmpty], varEmpty);\r\n AddGet(TBooleanField, 'Value', TBooleanField_Read_Value, 0, [varEmpty], varEmpty);\r\n AddSet(TBooleanField, 'Value', TBooleanField_Write_Value, 0, [varEmpty]);\r\n AddGet(TBooleanField, 'DisplayValues', TBooleanField_Read_DisplayValues, 0, [varEmpty], varEmpty);\r\n AddSet(TBooleanField, 'DisplayValues', TBooleanField_Write_DisplayValues, 0, [varEmpty]);\r\n { TDateTimeField }\r\n AddClass(cDb, TDateTimeField, 'TDateTimeField');\r\n AddGet(TDateTimeField, 'Create', TDateTimeField_Create, 1, [varEmpty], varEmpty);\r\n AddGet(TDateTimeField, 'Value', TDateTimeField_Read_Value, 0, [varEmpty], varEmpty);\r\n AddSet(TDateTimeField, 'Value', TDateTimeField_Write_Value, 0, [varEmpty]);\r\n AddGet(TDateTimeField, 'DisplayFormat', TDateTimeField_Read_DisplayFormat, 0, [varEmpty], varEmpty);\r\n AddSet(TDateTimeField, 'DisplayFormat', TDateTimeField_Write_DisplayFormat, 0, [varEmpty]);\r\n { TDateField }\r\n AddClass(cDb, TDateField, 'TDateField');\r\n AddGet(TDateField, 'Create', TDateField_Create, 1, [varEmpty], varEmpty);\r\n { TTimeField }\r\n AddClass(cDb, TTimeField, 'TTimeField');\r\n AddGet(TTimeField, 'Create', TTimeField_Create, 1, [varEmpty], varEmpty);\r\n { TBinaryField }\r\n AddClass(cDb, TBinaryField, 'TBinaryField');\r\n AddGet(TBinaryField, 'Create', TBinaryField_Create, 1, [varEmpty], varEmpty);\r\n { TBytesField }\r\n AddClass(cDb, TBytesField, 'TBytesField');\r\n AddGet(TBytesField, 'Create', TBytesField_Create, 1, [varEmpty], varEmpty);\r\n { TVarBytesField }\r\n AddClass(cDb, TVarBytesField, 'TVarBytesField');\r\n AddGet(TVarBytesField, 'Create', TVarBytesField_Create, 1, [varEmpty], varEmpty);\r\n { TBCDField }\r\n AddClass(cDb, TBCDField, 'TBCDField');\r\n AddGet(TBCDField, 'Create', TBCDField_Create, 1, [varEmpty], varEmpty);\r\n AddGet(TBCDField, 'Value', TBCDField_Read_Value, 0, [varEmpty], varEmpty);\r\n AddSet(TBCDField, 'Value', TBCDField_Write_Value, 0, [varEmpty]);\r\n AddGet(TBCDField, 'Currency', TBCDField_Read_Currency, 0, [varEmpty], varEmpty);\r\n AddSet(TBCDField, 'Currency', TBCDField_Write_Currency, 0, [varEmpty]);\r\n AddGet(TBCDField, 'MaxValue', TBCDField_Read_MaxValue, 0, [varEmpty], varEmpty);\r\n AddSet(TBCDField, 'MaxValue', TBCDField_Write_MaxValue, 0, [varEmpty]);\r\n AddGet(TBCDField, 'MinValue', TBCDField_Read_MinValue, 0, [varEmpty], varEmpty);\r\n AddSet(TBCDField, 'MinValue', TBCDField_Write_MinValue, 0, [varEmpty]);\r\n { TBlobField }\r\n AddClass(cDb, TBlobField, 'TBlobField');\r\n AddGet(TBlobField, 'Create', TBlobField_Create, 1, [varEmpty], varEmpty);\r\n AddGet(TBlobField, 'Assign', TBlobField_Assign, 1, [varEmpty], varEmpty);\r\n AddGet(TBlobField, 'Clear', TBlobField_Clear, 0, [varEmpty], varEmpty);\r\n AddGet(TBlobField, 'IsBlob', TBlobField_IsBlob, 0, [varEmpty], varEmpty);\r\n AddGet(TBlobField, 'LoadFromFile', TBlobField_LoadFromFile, 1, [varEmpty], varEmpty);\r\n AddGet(TBlobField, 'LoadFromStream', TBlobField_LoadFromStream, 1, [varEmpty], varEmpty);\r\n AddGet(TBlobField, 'SaveToFile', TBlobField_SaveToFile, 1, [varEmpty], varEmpty);\r\n AddGet(TBlobField, 'SaveToStream', TBlobField_SaveToStream, 1, [varEmpty], varEmpty);\r\n AddGet(TBlobField, 'SetFieldType', TBlobField_SetFieldType, 1, [varEmpty], varEmpty);\r\n AddGet(TBlobField, 'BlobSize', TBlobField_Read_BlobSize, 0, [varEmpty], varEmpty);\r\n AddGet(TBlobField, 'Modified', TBlobField_Read_Modified, 0, [varEmpty], varEmpty);\r\n AddSet(TBlobField, 'Modified', TBlobField_Write_Modified, 0, [varEmpty]);\r\n AddGet(TBlobField, 'Value', TBlobField_Read_Value, 0, [varEmpty], varEmpty);\r\n AddSet(TBlobField, 'Value', TBlobField_Write_Value, 0, [varEmpty]);\r\n AddGet(TBlobField, 'Transliterate', TBlobField_Read_Transliterate, 0, [varEmpty], varEmpty);\r\n AddSet(TBlobField, 'Transliterate', TBlobField_Write_Transliterate, 0, [varEmpty]);\r\n AddGet(TBlobField, 'BlobType', TBlobField_Read_BlobType, 0, [varEmpty], varEmpty);\r\n AddSet(TBlobField, 'BlobType', TBlobField_Write_BlobType, 0, [varEmpty]);\r\n { TMemoField }\r\n AddClass(cDb, TMemoField, 'TMemoField');\r\n AddGet(TMemoField, 'Create', TMemoField_Create, 1, [varEmpty], varEmpty);\r\n { TGraphicField }\r\n AddClass(cDb, TGraphicField, 'TGraphicField');\r\n AddGet(TGraphicField, 'Create', TGraphicField_Create, 1, [varEmpty], varEmpty);\r\n { TIndexOptions }\r\n AddConst(cDb, 'ixPrimary', Ord(ixPrimary));\r\n AddConst(cDb, 'ixUnique', Ord(ixUnique));\r\n AddConst(cDb, 'ixDescending', Ord(ixDescending));\r\n AddConst(cDb, 'ixCaseInsensitive', Ord(ixCaseInsensitive));\r\n AddConst(cDb, 'ixExpression', Ord(ixExpression));\r\n { TIndexDef }\r\n AddClass(cDb, TIndexDef, 'TIndexDef');\r\n AddGet(TIndexDef, 'Create', TIndexDef_Create, 4, [varEmpty, varEmpty, varEmpty, varEmpty], varEmpty);\r\n AddGet(TIndexDef, 'Expression', TIndexDef_Read_Expression, 0, [varEmpty], varEmpty);\r\n AddGet(TIndexDef, 'Fields', TIndexDef_Read_Fields, 0, [varEmpty], varEmpty);\r\n AddGet(TIndexDef, 'Name', TIndexDef_Read_Name, 0, [varEmpty], varEmpty);\r\n AddGet(TIndexDef, 'Options', TIndexDef_Read_Options, 0, [varEmpty], varEmpty);\r\n AddGet(TIndexDef, 'Source', TIndexDef_Read_Source, 0, [varEmpty], varEmpty);\r\n AddSet(TIndexDef, 'Source', TIndexDef_Write_Source, 0, [varEmpty]);\r\n { TIndexDefs }\r\n AddClass(cDb, TIndexDefs, 'TIndexDefs');\r\n AddGet(TIndexDefs, 'Create', TIndexDefs_Create, 1, [varEmpty], varEmpty);\r\n AddGet(TIndexDefs, 'Add', TIndexDefs_Add, 3, [varEmpty, varEmpty, varEmpty], varEmpty);\r\n AddGet(TIndexDefs, 'Assign', TIndexDefs_Assign, 1, [varEmpty], varEmpty);\r\n AddGet(TIndexDefs, 'Clear', TIndexDefs_Clear, 0, [varEmpty], varEmpty);\r\n AddGet(TIndexDefs, 'FindIndexForFields', TIndexDefs_FindIndexForFields, 1, [varEmpty], varEmpty);\r\n AddGet(TIndexDefs, 'GetIndexForFields', TIndexDefs_GetIndexForFields, 2, [varEmpty, varEmpty], varEmpty);\r\n AddGet(TIndexDefs, 'IndexOf', TIndexDefs_IndexOf, 1, [varEmpty], varEmpty);\r\n AddGet(TIndexDefs, 'Update', TIndexDefs_Update, 0, [varEmpty], varEmpty);\r\n AddGet(TIndexDefs, 'Count', TIndexDefs_Read_Count, 0, [varEmpty], varEmpty);\r\n AddIGet(TIndexDefs, 'Items', TIndexDefs_Read_Items, 1, [varEmpty], varEmpty);\r\n AddIDGet(TIndexDefs, TIndexDefs_Read_Items, 1, [varEmpty], varEmpty);\r\n AddGet(TIndexDefs, 'Updated', TIndexDefs_Read_Updated, 0, [varEmpty], varEmpty);\r\n AddSet(TIndexDefs, 'Updated', TIndexDefs_Write_Updated, 0, [varEmpty]);\r\n { TDataLink }\r\n AddClass(cDb, TDataLink, 'TDataLink');\r\n AddGet(TDataLink, 'Create', TDataLink_Create, 0, [varEmpty], varEmpty);\r\n AddGet(TDataLink, 'Edit', TDataLink_Edit, 0, [varEmpty], varEmpty);\r\n AddGet(TDataLink, 'UpdateRecord', TDataLink_UpdateRecord, 0, [varEmpty], varEmpty);\r\n AddGet(TDataLink, 'Active', TDataLink_Read_Active, 0, [varEmpty], varEmpty);\r\n AddGet(TDataLink, 'ActiveRecord', TDataLink_Read_ActiveRecord, 0, [varEmpty], varEmpty);\r\n AddSet(TDataLink, 'ActiveRecord', TDataLink_Write_ActiveRecord, 0, [varEmpty]);\r\n AddGet(TDataLink, 'BufferCount', TDataLink_Read_BufferCount, 0, [varEmpty], varEmpty);\r\n AddSet(TDataLink, 'BufferCount', TDataLink_Write_BufferCount, 0, [varEmpty]);\r\n AddGet(TDataLink, 'DataSet', TDataLink_Read_DataSet, 0, [varEmpty], varEmpty);\r\n AddGet(TDataLink, 'DataSource', TDataLink_Read_DataSource, 0, [varEmpty], varEmpty);\r\n AddSet(TDataLink, 'DataSource', TDataLink_Write_DataSource, 0, [varEmpty]);\r\n AddGet(TDataLink, 'DataSourceFixed', TDataLink_Read_DataSourceFixed, 0, [varEmpty], varEmpty);\r\n AddSet(TDataLink, 'DataSourceFixed', TDataLink_Write_DataSourceFixed, 0, [varEmpty]);\r\n AddGet(TDataLink, 'Editing', TDataLink_Read_Editing, 0, [varEmpty], varEmpty);\r\n AddGet(TDataLink, 'ReadOnly', TDataLink_Read_ReadOnly, 0, [varEmpty], varEmpty);\r\n AddSet(TDataLink, 'ReadOnly', TDataLink_Write_ReadOnly, 0, [varEmpty]);\r\n AddGet(TDataLink, 'RecordCount', TDataLink_Read_RecordCount, 0, [varEmpty], varEmpty);\r\n { TDataSource }\r\n AddClass(cDb, TDataSource, 'TDataSource');\r\n AddGet(TDataSource, 'Create', TDataSource_Create, 1, [varEmpty], varEmpty);\r\n AddGet(TDataSource, 'Edit', TDataSource_Edit, 0, [varEmpty], varEmpty);\r\n AddGet(TDataSource, 'IsLinkedTo', TDataSource_IsLinkedTo, 1, [varEmpty], varEmpty);\r\n AddGet(TDataSource, 'State', TDataSource_Read_State, 0, [varEmpty], varEmpty);\r\n AddGet(TDataSource, 'AutoEdit', TDataSource_Read_AutoEdit, 0, [varEmpty], varEmpty);\r\n AddSet(TDataSource, 'AutoEdit', TDataSource_Write_AutoEdit, 0, [varEmpty]);\r\n AddGet(TDataSource, 'DataSet', TDataSource_Read_DataSet, 0, [varEmpty], varEmpty);\r\n AddSet(TDataSource, 'DataSet', TDataSource_Write_DataSet, 0, [varEmpty]);\r\n AddGet(TDataSource, 'Enabled', TDataSource_Read_Enabled, 0, [varEmpty], varEmpty);\r\n AddSet(TDataSource, 'Enabled', TDataSource_Write_Enabled, 0, [varEmpty]);\r\n { TCheckConstraint }\r\n AddClass(cDb, TCheckConstraint, 'TCheckConstraint');\r\n AddGet(TCheckConstraint, 'Assign', TCheckConstraint_Assign, 1, [varEmpty], varEmpty);\r\n AddGet(TCheckConstraint, 'GetDisplayName', TCheckConstraint_GetDisplayName, 0, [varEmpty], varEmpty);\r\n AddGet(TCheckConstraint, 'CustomConstraint', TCheckConstraint_Read_CustomConstraint, 0, [varEmpty], varEmpty);\r\n AddSet(TCheckConstraint, 'CustomConstraint', TCheckConstraint_Write_CustomConstraint, 0, [varEmpty]);\r\n AddGet(TCheckConstraint, 'ErrorMessage', TCheckConstraint_Read_ErrorMessage, 0, [varEmpty], varEmpty);\r\n AddSet(TCheckConstraint, 'ErrorMessage', TCheckConstraint_Write_ErrorMessage, 0, [varEmpty]);\r\n AddGet(TCheckConstraint, 'FromDictionary', TCheckConstraint_Read_FromDictionary, 0, [varEmpty], varEmpty);\r\n AddSet(TCheckConstraint, 'FromDictionary', TCheckConstraint_Write_FromDictionary, 0, [varEmpty]);\r\n AddGet(TCheckConstraint, 'ImportedConstraint', TCheckConstraint_Read_ImportedConstraint, 0, [varEmpty], varEmpty);\r\n AddSet(TCheckConstraint, 'ImportedConstraint', TCheckConstraint_Write_ImportedConstraint, 0, [varEmpty]);\r\n { TCheckConstraints }\r\n AddClass(cDb, TCheckConstraints, 'TCheckConstraints');\r\n AddGet(TCheckConstraints, 'Create', TCheckConstraints_Create, 1, [varEmpty], varEmpty);\r\n AddGet(TCheckConstraints, 'Add', TCheckConstraints_Add, 0, [varEmpty], varEmpty);\r\n AddIGet(TCheckConstraints, 'Items', TCheckConstraints_Read_Items, 1, [varEmpty], varEmpty);\r\n // (rom) varEmpty replaced by varNull\r\n AddISet(TCheckConstraints, 'Items', TCheckConstraints_Write_Items, 1, [varNull]);\r\n { TBookmarkFlag }\r\n AddConst(cDb, 'bfCurrent', Ord(bfCurrent));\r\n AddConst(cDb, 'bfBOF', Ord(bfBOF));\r\n AddConst(cDb, 'bfEOF', Ord(bfEOF));\r\n AddConst(cDb, 'bfInserted', Ord(bfInserted));\r\n { TGetMode }\r\n AddConst(cDb, 'gmCurrent', Ord(gmCurrent));\r\n AddConst(cDb, 'gmNext', Ord(gmNext));\r\n AddConst(cDb, 'gmPrior', Ord(gmPrior));\r\n { TGetResult }\r\n AddConst(cDb, 'grOK', Ord(grOK));\r\n AddConst(cDb, 'grBOF', Ord(grBOF));\r\n AddConst(cDb, 'grEOF', Ord(grEOF));\r\n AddConst(cDb, 'grError', Ord(grError));\r\n { TResyncMode }\r\n AddConst(cDb, 'rmExact', Ord(rmExact));\r\n AddConst(cDb, 'rmCenter', Ord(rmCenter));\r\n { TDataAction }\r\n AddConst(cDb, 'daFail', Ord(daFail));\r\n AddConst(cDb, 'daAbort', Ord(daAbort));\r\n AddConst(cDb, 'daRetry', Ord(daRetry));\r\n { TUpdateKind }\r\n AddConst(cDb, 'ukModify', Ord(ukModify));\r\n AddConst(cDb, 'ukInsert', Ord(ukInsert));\r\n AddConst(cDb, 'ukDelete', Ord(ukDelete));\r\n { TBlobStreamMode }\r\n AddConst(cDb, 'bmRead', Ord(bmRead));\r\n AddConst(cDb, 'bmWrite', Ord(bmWrite));\r\n AddConst(cDb, 'bmReadWrite', Ord(bmReadWrite));\r\n { TLocateOption }\r\n AddConst(cDb, 'loCaseInsensitive', Ord(loCaseInsensitive));\r\n AddConst(cDb, 'loPartialKey', Ord(loPartialKey));\r\n { TFilterOption }\r\n AddConst(cDb, 'foCaseInsensitive', Ord(foCaseInsensitive));\r\n AddConst(cDb, 'foNoPartialCompare', Ord(foNoPartialCompare));\r\n { TDataSet }\r\n AddClass(cDb, TDataSet, 'TDataSet');\r\n AddGet(TDataSet, 'ActiveBuffer', TDataSet_ActiveBuffer, 0, [varEmpty], varEmpty);\r\n AddGet(TDataSet, 'Append', TDataSet_Append, 0, [varEmpty], varEmpty);\r\n AddGet(TDataSet, 'AppendRecord', TDataSet_AppendRecord, 1, [varEmpty], varEmpty);\r\n AddGet(TDataSet, 'BookmarkValid', TDataSet_BookmarkValid, 1, [varEmpty], varEmpty);\r\n AddGet(TDataSet, 'Cancel', TDataSet_Cancel, 0, [varEmpty], varEmpty);\r\n AddGet(TDataSet, 'CheckBrowseMode', TDataSet_CheckBrowseMode, 0, [varEmpty], varEmpty);\r\n AddGet(TDataSet, 'ClearFields', TDataSet_ClearFields, 0, [varEmpty], varEmpty);\r\n AddGet(TDataSet, 'Close', TDataSet_Close, 0, [varEmpty], varEmpty);\r\n AddGet(TDataSet, 'ControlsDisabled', TDataSet_ControlsDisabled, 0, [varEmpty], varEmpty);\r\n AddGet(TDataSet, 'CompareBookmarks', TDataSet_CompareBookmarks, 2, [varEmpty, varEmpty], varEmpty);\r\n AddGet(TDataSet, 'CreateBlobStream', TDataSet_CreateBlobStream, 2, [varEmpty, varEmpty], varEmpty);\r\n AddGet(TDataSet, 'CursorPosChanged', TDataSet_CursorPosChanged, 0, [varEmpty], varEmpty);\r\n AddGet(TDataSet, 'Delete', TDataSet_Delete, 0, [varEmpty], varEmpty);\r\n AddGet(TDataSet, 'DisableControls', TDataSet_DisableControls, 0, [varEmpty], varEmpty);\r\n AddGet(TDataSet, 'Edit', TDataSet_Edit, 0, [varEmpty], varEmpty);\r\n AddGet(TDataSet, 'EnableControls', TDataSet_EnableControls, 0, [varEmpty], varEmpty);\r\n AddGet(TDataSet, 'FieldByName', TDataSet_FieldByName, 1, [varEmpty], varEmpty);\r\n AddGet(TDataSet, 'FindField', TDataSet_FindField, 1, [varEmpty], varEmpty);\r\n AddGet(TDataSet, 'FindFirst', TDataSet_FindFirst, 0, [varEmpty], varEmpty);\r\n AddGet(TDataSet, 'FindLast', TDataSet_FindLast, 0, [varEmpty], varEmpty);\r\n AddGet(TDataSet, 'FindNext', TDataSet_FindNext, 0, [varEmpty], varEmpty);\r\n AddGet(TDataSet, 'FindPrior', TDataSet_FindPrior, 0, [varEmpty], varEmpty);\r\n AddGet(TDataSet, 'First', TDataSet_First, 0, [varEmpty], varEmpty);\r\n AddGet(TDataSet, 'FreeBookmark', TDataSet_FreeBookmark, 1, [varEmpty], varEmpty);\r\n AddGet(TDataSet, 'GetBookmark', TDataSet_GetBookmark, 0, [varEmpty], varEmpty);\r\n AddGet(TDataSet, 'GetCurrentRecord', TDataSet_GetCurrentRecord, 1, [varEmpty], varEmpty);\r\n AddGet(TDataSet, 'GetFieldList', TDataSet_GetFieldList, 2, [varEmpty, varEmpty], varEmpty);\r\n AddGet(TDataSet, 'GetFieldNames', TDataSet_GetFieldNames, 1, [varEmpty], varEmpty);\r\n AddGet(TDataSet, 'GotoBookmark', TDataSet_GotoBookmark, 1, [varEmpty], varEmpty);\r\n AddGet(TDataSet, 'Insert', TDataSet_Insert, 0, [varEmpty], varEmpty);\r\n AddGet(TDataSet, 'InsertRecord', TDataSet_InsertRecord, 1, [varEmpty], varEmpty);\r\n AddGet(TDataSet, 'IsEmpty', TDataSet_IsEmpty, 0, [varEmpty], varEmpty);\r\n AddGet(TDataSet, 'IsLinkedTo', TDataSet_IsLinkedTo, 1, [varEmpty], varEmpty);\r\n AddGet(TDataSet, 'IsSequenced', TDataSet_IsSequenced, 0, [varEmpty], varEmpty);\r\n AddGet(TDataSet, 'Last', TDataSet_Last, 0, [varEmpty], varEmpty);\r\n AddGet(TDataSet, 'Locate', TDataSet_Locate, 3, [varEmpty, varEmpty, varEmpty], varEmpty);\r\n AddGet(TDataSet, 'Lookup', TDataSet_Lookup, 3, [varEmpty, varEmpty, varEmpty], varEmpty);\r\n AddGet(TDataSet, 'MoveBy', TDataSet_MoveBy, 1, [varEmpty], varEmpty);\r\n AddGet(TDataSet, 'Next', TDataSet_Next, 0, [varEmpty], varEmpty);\r\n AddGet(TDataSet, 'Open', TDataSet_Open, 0, [varEmpty], varEmpty);\r\n AddGet(TDataSet, 'Post', TDataSet_Post, 0, [varEmpty], varEmpty);\r\n AddGet(TDataSet, 'Prior', TDataSet_Prior, 0, [varEmpty], varEmpty);\r\n AddGet(TDataSet, 'Refresh', TDataSet_Refresh, 0, [varEmpty], varEmpty);\r\n AddGet(TDataSet, 'Resync', TDataSet_Resync, 1, [varEmpty], varEmpty);\r\n AddGet(TDataSet, 'SetFields', TDataSet_SetFields, 1, [varEmpty], varEmpty);\r\n AddGet(TDataSet, 'Translate', TDataSet_Translate, 3, [varEmpty, varEmpty, varEmpty], varEmpty);\r\n AddGet(TDataSet, 'UpdateCursorPos', TDataSet_UpdateCursorPos, 0, [varEmpty], varEmpty);\r\n AddGet(TDataSet, 'UpdateRecord', TDataSet_UpdateRecord, 0, [varEmpty], varEmpty);\r\n AddGet(TDataSet, 'BOF', TDataSet_Read_BOF, 0, [varEmpty], varEmpty);\r\n AddGet(TDataSet, 'Bookmark', TDataSet_Read_Bookmark, 0, [varEmpty], varEmpty);\r\n AddSet(TDataSet, 'Bookmark', TDataSet_Write_Bookmark, 0, [varEmpty]);\r\n AddGet(TDataSet, 'CanModify', TDataSet_Read_CanModify, 0, [varEmpty], varEmpty);\r\n AddGet(TDataSet, 'DataSource', TDataSet_Read_DataSource, 0, [varEmpty], varEmpty);\r\n AddGet(TDataSet, 'DefaultFields', TDataSet_Read_DefaultFields, 0, [varEmpty], varEmpty);\r\n AddGet(TDataSet, 'Designer', TDataSet_Read_Designer, 0, [varEmpty], varEmpty);\r\n AddGet(TDataSet, 'EOF', TDataSet_Read_EOF, 0, [varEmpty], varEmpty);\r\n AddGet(TDataSet, 'FieldCount', TDataSet_Read_FieldCount, 0, [varEmpty], varEmpty);\r\n AddGet(TDataSet, 'FieldDefs', TDataSet_Read_FieldDefs, 0, [varEmpty], varEmpty);\r\n AddSet(TDataSet, 'FieldDefs', TDataSet_Write_FieldDefs, 0, [varEmpty]);\r\n AddIGet(TDataSet, 'Fields', TDataSet_Read_Fields, 1, [varEmpty], varEmpty);\r\n AddIGet(TDataSet, 'FieldValues', TDataSet_Read_FieldValues, 1, [varEmpty], varEmpty);\r\n // (rom) varEmpty replaced by varNull\r\n AddISet(TDataSet, 'FieldValues', TDataSet_Write_FieldValues, 1, [varNull]);\r\n AddIDGet(TDataSet, TDataSet_Read_FieldValues, 1, [varEmpty], varEmpty);\r\n // (rom) varEmpty replaced by varNull\r\n AddIDSet(TDataSet, TDataSet_Write_FieldValues, 1, [varNull]);\r\n AddGet(TDataSet, 'Found', TDataSet_Read_Found, 0, [varEmpty], varEmpty);\r\n AddGet(TDataSet, 'Modified', TDataSet_Read_Modified, 0, [varEmpty], varEmpty);\r\n AddGet(TDataSet, 'RecordCount', TDataSet_Read_RecordCount, 0, [varEmpty], varEmpty);\r\n AddGet(TDataSet, 'RecNo', TDataSet_Read_RecNo, 0, [varEmpty], varEmpty);\r\n AddSet(TDataSet, 'RecNo', TDataSet_Write_RecNo, 0, [varEmpty]);\r\n AddGet(TDataSet, 'RecordSize', TDataSet_Read_RecordSize, 0, [varEmpty], varEmpty);\r\n AddGet(TDataSet, 'State', TDataSet_Read_State, 0, [varEmpty], varEmpty);\r\n AddGet(TDataSet, 'Filter', TDataSet_Read_Filter, 0, [varEmpty], varEmpty);\r\n AddSet(TDataSet, 'Filter', TDataSet_Write_Filter, 0, [varEmpty]);\r\n AddGet(TDataSet, 'Filtered', TDataSet_Read_Filtered, 0, [varEmpty], varEmpty);\r\n AddSet(TDataSet, 'Filtered', TDataSet_Write_Filtered, 0, [varEmpty]);\r\n AddGet(TDataSet, 'FilterOptions', TDataSet_Read_FilterOptions, 0, [varEmpty], varEmpty);\r\n AddSet(TDataSet, 'FilterOptions', TDataSet_Write_FilterOptions, 0, [varEmpty]);\r\n AddGet(TDataSet, 'Active', TDataSet_Read_Active, 0, [varEmpty], varEmpty);\r\n AddSet(TDataSet, 'Active', TDataSet_Write_Active, 0, [varEmpty]);\r\n AddGet(TDataSet, 'AutoCalcFields', TDataSet_Read_AutoCalcFields, 0, [varEmpty], varEmpty);\r\n AddSet(TDataSet, 'AutoCalcFields', TDataSet_Write_AutoCalcFields, 0, [varEmpty]);\r\n\r\n AddHandler(cDb, 'TFieldNotifyEvent', TJvInterpreterDbEvent, @TJvInterpreterDbEvent.FieldNotifyEvent);\r\n AddHandler(cDb, 'TFieldGetTextEvent', TJvInterpreterDbEvent, @TJvInterpreterDbEvent.FieldGetTextEvent);\r\n AddHandler(cDb, 'TFieldSetTextEvent', TJvInterpreterDbEvent, @TJvInterpreterDbEvent.FieldSetTextEvent);\r\n AddHandler(cDb, 'TDataChangeEvent', TJvInterpreterDbEvent, @TJvInterpreterDbEvent.DataChangeEvent);\r\n AddHandler(cDb, 'TDataSetNotifyEvent', TJvInterpreterDbEvent, @TJvInterpreterDbEvent.DataSetNotifyEvent);\r\n AddHandler(cDb, 'TDataSetErrorEvent', TJvInterpreterDbEvent, @TJvInterpreterDbEvent.DataSetErrorEvent);\r\n AddHandler(cDb, 'TFilterRecordEvent', TJvInterpreterDbEvent, @TJvInterpreterDbEvent.FilterRecordEvent);\r\n end;\r\n RegisterClasses([TStringField, TNumericField, TIntegerField, TSmallintField,\r\n TWordField, TAutoIncField, TFloatField, TCurrencyField, TBooleanField,\r\n TDateTimeField, TDateField, TTimeField, TBinaryField, TBytesField,\r\n TVarBytesField, TBCDField, TBlobField, TMemoField, TGraphicField,\r\n TDataSource, TCheckConstraint, TCheckConstraints]);\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvInterpreter_DbCtrls.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvInterpreter_DbCtrls.PAS, released on 2002-07-04.\r\n\r\nThe Initial Developers of the Original Code are: Andrei Prygounkov \r\nCopyright (c) 1999, 2002 Andrei Prygounkov\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nDescription : adapter unit - converts JvInterpreter calls to delphi calls\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvInterpreter_DbCtrls.pas 13075 2011-06-27 22:56:21Z jfudickar $\r\n\r\nunit JvInterpreter_DbCtrls;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n JvInterpreter;\r\n\r\nprocedure RegisterJvInterpreterAdapter(JvInterpreterAdapter: TJvInterpreterAdapter);\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvInterpreter_DbCtrls.pas $';\r\n Revision: '$Revision: 13075 $';\r\n Date: '$Date: 2011-06-28 00:56:21 +0200 (mar. 28 juin 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n Classes, Graphics, DB, DBCtrls;\r\n\r\n{ TDBEdit }\r\n\r\n{ constructor Create(AOwner: TComponent) }\r\n\r\nprocedure TDBEdit_Create(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TDBEdit.Create(V2O(Args.Values[0]) as TComponent));\r\nend;\r\n\r\n{ property Read Field: TField }\r\n\r\nprocedure TDBEdit_Read_Field(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TDBEdit(Args.Obj).Field);\r\nend;\r\n\r\n{ property Read DataField: string }\r\n\r\nprocedure TDBEdit_Read_DataField(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TDBEdit(Args.Obj).DataField;\r\nend;\r\n\r\n{ property Write DataField(Value: string) }\r\n\r\nprocedure TDBEdit_Write_DataField(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TDBEdit(Args.Obj).DataField := Value;\r\nend;\r\n\r\n{ property Read DataSource: TDataSource }\r\n\r\nprocedure TDBEdit_Read_DataSource(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TDBEdit(Args.Obj).DataSource);\r\nend;\r\n\r\n{ property Write DataSource(Value: TDataSource) }\r\n\r\nprocedure TDBEdit_Write_DataSource(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TDBEdit(Args.Obj).DataSource := V2O(Value) as TDataSource;\r\nend;\r\n\r\n{ property Read ReadOnly: Boolean }\r\n\r\nprocedure TDBEdit_Read_ReadOnly(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TDBEdit(Args.Obj).ReadOnly;\r\nend;\r\n\r\n{ property Write ReadOnly(Value: Boolean) }\r\n\r\nprocedure TDBEdit_Write_ReadOnly(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TDBEdit(Args.Obj).ReadOnly := Value;\r\nend;\r\n\r\n{ TDBText }\r\n\r\n{ constructor Create(AOwner: TComponent) }\r\n\r\nprocedure TDBText_Create(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TDBText.Create(V2O(Args.Values[0]) as TComponent));\r\nend;\r\n\r\n{ property Read Field: TField }\r\n\r\nprocedure TDBText_Read_Field(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TDBText(Args.Obj).Field);\r\nend;\r\n\r\n{ property Read DataField: string }\r\n\r\nprocedure TDBText_Read_DataField(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TDBText(Args.Obj).DataField;\r\nend;\r\n\r\n{ property Write DataField(Value: string) }\r\n\r\nprocedure TDBText_Write_DataField(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TDBText(Args.Obj).DataField := Value;\r\nend;\r\n\r\n{ property Read DataSource: TDataSource }\r\n\r\nprocedure TDBText_Read_DataSource(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TDBText(Args.Obj).DataSource);\r\nend;\r\n\r\n{ property Write DataSource(Value: TDataSource) }\r\n\r\nprocedure TDBText_Write_DataSource(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TDBText(Args.Obj).DataSource := V2O(Value) as TDataSource;\r\nend;\r\n\r\n{ TDBCheckBox }\r\n\r\n{ constructor Create(AOwner: TComponent) }\r\n\r\nprocedure TDBCheckBox_Create(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TDBCheckBox.Create(V2O(Args.Values[0]) as TComponent));\r\nend;\r\n\r\n{ property Read Field: TField }\r\n\r\nprocedure TDBCheckBox_Read_Field(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TDBCheckBox(Args.Obj).Field);\r\nend;\r\n\r\n{ property Read DataField: string }\r\n\r\nprocedure TDBCheckBox_Read_DataField(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TDBCheckBox(Args.Obj).DataField;\r\nend;\r\n\r\n{ property Write DataField(Value: string) }\r\n\r\nprocedure TDBCheckBox_Write_DataField(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TDBCheckBox(Args.Obj).DataField := Value;\r\nend;\r\n\r\n{ property Read DataSource: TDataSource }\r\n\r\nprocedure TDBCheckBox_Read_DataSource(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TDBCheckBox(Args.Obj).DataSource);\r\nend;\r\n\r\n{ property Write DataSource(Value: TDataSource) }\r\n\r\nprocedure TDBCheckBox_Write_DataSource(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TDBCheckBox(Args.Obj).DataSource := V2O(Value) as TDataSource;\r\nend;\r\n\r\n{ property Read ReadOnly: Boolean }\r\n\r\nprocedure TDBCheckBox_Read_ReadOnly(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TDBCheckBox(Args.Obj).ReadOnly;\r\nend;\r\n\r\n{ property Write ReadOnly(Value: Boolean) }\r\n\r\nprocedure TDBCheckBox_Write_ReadOnly(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TDBCheckBox(Args.Obj).ReadOnly := Value;\r\nend;\r\n\r\n{ property Read ValueChecked: string }\r\n\r\nprocedure TDBCheckBox_Read_ValueChecked(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TDBCheckBox(Args.Obj).ValueChecked;\r\nend;\r\n\r\n{ property Write ValueChecked(Value: string) }\r\n\r\nprocedure TDBCheckBox_Write_ValueChecked(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TDBCheckBox(Args.Obj).ValueChecked := Value;\r\nend;\r\n\r\n{ property Read ValueUnchecked: string }\r\n\r\nprocedure TDBCheckBox_Read_ValueUnchecked(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TDBCheckBox(Args.Obj).ValueUnchecked;\r\nend;\r\n\r\n{ property Write ValueUnchecked(Value: string) }\r\n\r\nprocedure TDBCheckBox_Write_ValueUnchecked(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TDBCheckBox(Args.Obj).ValueUnchecked := Value;\r\nend;\r\n\r\n{ TDBComboBox }\r\n\r\n{ constructor Create(AOwner: TComponent) }\r\n\r\nprocedure TDBComboBox_Create(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TDBComboBox.Create(V2O(Args.Values[0]) as TComponent));\r\nend;\r\n\r\n{ property Read Field: TField }\r\n\r\nprocedure TDBComboBox_Read_Field(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TDBComboBox(Args.Obj).Field);\r\nend;\r\n\r\n{ property Read DataField: string }\r\n\r\nprocedure TDBComboBox_Read_DataField(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TDBComboBox(Args.Obj).DataField;\r\nend;\r\n\r\n{ property Write DataField(Value: string) }\r\n\r\nprocedure TDBComboBox_Write_DataField(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TDBComboBox(Args.Obj).DataField := Value;\r\nend;\r\n\r\n{ property Read DataSource: TDataSource }\r\n\r\nprocedure TDBComboBox_Read_DataSource(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TDBComboBox(Args.Obj).DataSource);\r\nend;\r\n\r\n{ property Write DataSource(Value: TDataSource) }\r\n\r\nprocedure TDBComboBox_Write_DataSource(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TDBComboBox(Args.Obj).DataSource := V2O(Value) as TDataSource;\r\nend;\r\n\r\n{ property Read ReadOnly: Boolean }\r\n\r\nprocedure TDBComboBox_Read_ReadOnly(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TDBComboBox(Args.Obj).ReadOnly;\r\nend;\r\n\r\n{ property Write ReadOnly(Value: Boolean) }\r\n\r\nprocedure TDBComboBox_Write_ReadOnly(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TDBComboBox(Args.Obj).ReadOnly := Value;\r\nend;\r\n\r\n{ TDBListBox }\r\n\r\n{ constructor Create(AOwner: TComponent) }\r\n\r\nprocedure TDBListBox_Create(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TDBListBox.Create(V2O(Args.Values[0]) as TComponent));\r\nend;\r\n\r\n{ property Read Field: TField }\r\n\r\nprocedure TDBListBox_Read_Field(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TDBListBox(Args.Obj).Field);\r\nend;\r\n\r\n{ property Read DataField: string }\r\n\r\nprocedure TDBListBox_Read_DataField(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TDBListBox(Args.Obj).DataField;\r\nend;\r\n\r\n{ property Write DataField(Value: string) }\r\n\r\nprocedure TDBListBox_Write_DataField(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TDBListBox(Args.Obj).DataField := Value;\r\nend;\r\n\r\n{ property Read DataSource: TDataSource }\r\n\r\nprocedure TDBListBox_Read_DataSource(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TDBListBox(Args.Obj).DataSource);\r\nend;\r\n\r\n{ property Write DataSource(Value: TDataSource) }\r\n\r\nprocedure TDBListBox_Write_DataSource(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TDBListBox(Args.Obj).DataSource := V2O(Value) as TDataSource;\r\nend;\r\n\r\n{ property Read ReadOnly: Boolean }\r\n\r\nprocedure TDBListBox_Read_ReadOnly(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TDBListBox(Args.Obj).ReadOnly;\r\nend;\r\n\r\n{ property Write ReadOnly(Value: Boolean) }\r\n\r\nprocedure TDBListBox_Write_ReadOnly(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TDBListBox(Args.Obj).ReadOnly := Value;\r\nend;\r\n\r\n{ TDBRadioGroup }\r\n\r\n{ constructor Create(AOwner: TComponent) }\r\n\r\nprocedure TDBRadioGroup_Create(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TDBRadioGroup.Create(V2O(Args.Values[0]) as TComponent));\r\nend;\r\n\r\n{ property Read Field: TField }\r\n\r\nprocedure TDBRadioGroup_Read_Field(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TDBRadioGroup(Args.Obj).Field);\r\nend;\r\n\r\n{ property Read Value: string }\r\n\r\nprocedure TDBRadioGroup_Read_Value(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TDBRadioGroup(Args.Obj).Value;\r\nend;\r\n\r\n{ property Write Value(Value: string) }\r\n\r\nprocedure TDBRadioGroup_Write_Value(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TDBRadioGroup(Args.Obj).Value := Value;\r\nend;\r\n\r\n{ property Read DataField: string }\r\n\r\nprocedure TDBRadioGroup_Read_DataField(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TDBRadioGroup(Args.Obj).DataField;\r\nend;\r\n\r\n{ property Write DataField(Value: string) }\r\n\r\nprocedure TDBRadioGroup_Write_DataField(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TDBRadioGroup(Args.Obj).DataField := Value;\r\nend;\r\n\r\n{ property Read DataSource: TDataSource }\r\n\r\nprocedure TDBRadioGroup_Read_DataSource(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TDBRadioGroup(Args.Obj).DataSource);\r\nend;\r\n\r\n{ property Write DataSource(Value: TDataSource) }\r\n\r\nprocedure TDBRadioGroup_Write_DataSource(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TDBRadioGroup(Args.Obj).DataSource := V2O(Value) as TDataSource;\r\nend;\r\n\r\n{ property Read ReadOnly: Boolean }\r\n\r\nprocedure TDBRadioGroup_Read_ReadOnly(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TDBRadioGroup(Args.Obj).ReadOnly;\r\nend;\r\n\r\n{ property Write ReadOnly(Value: Boolean) }\r\n\r\nprocedure TDBRadioGroup_Write_ReadOnly(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TDBRadioGroup(Args.Obj).ReadOnly := Value;\r\nend;\r\n\r\n{ property Read Values: TStrings }\r\n\r\nprocedure TDBRadioGroup_Read_Values(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TDBRadioGroup(Args.Obj).Values);\r\nend;\r\n\r\n{ property Write Values(Value: TStrings) }\r\n\r\nprocedure TDBRadioGroup_Write_Values(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TDBRadioGroup(Args.Obj).Values := V2O(Value) as TStrings;\r\nend;\r\n\r\n{ TDBMemo }\r\n\r\n{ constructor Create(AOwner: TComponent) }\r\n\r\nprocedure TDBMemo_Create(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TDBMemo.Create(V2O(Args.Values[0]) as TComponent));\r\nend;\r\n\r\n{ procedure LoadMemo; }\r\n\r\nprocedure TDBMemo_LoadMemo(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TDBMemo(Args.Obj).LoadMemo;\r\nend;\r\n\r\n{ property Read Field: TField }\r\n\r\nprocedure TDBMemo_Read_Field(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TDBMemo(Args.Obj).Field);\r\nend;\r\n\r\n{ property Read AutoDisplay: Boolean }\r\n\r\nprocedure TDBMemo_Read_AutoDisplay(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TDBMemo(Args.Obj).AutoDisplay;\r\nend;\r\n\r\n{ property Write AutoDisplay(Value: Boolean) }\r\n\r\nprocedure TDBMemo_Write_AutoDisplay(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TDBMemo(Args.Obj).AutoDisplay := Value;\r\nend;\r\n\r\n{ property Read DataField: string }\r\n\r\nprocedure TDBMemo_Read_DataField(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TDBMemo(Args.Obj).DataField;\r\nend;\r\n\r\n{ property Write DataField(Value: string) }\r\n\r\nprocedure TDBMemo_Write_DataField(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TDBMemo(Args.Obj).DataField := Value;\r\nend;\r\n\r\n{ property Read DataSource: TDataSource }\r\n\r\nprocedure TDBMemo_Read_DataSource(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TDBMemo(Args.Obj).DataSource);\r\nend;\r\n\r\n{ property Write DataSource(Value: TDataSource) }\r\n\r\nprocedure TDBMemo_Write_DataSource(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TDBMemo(Args.Obj).DataSource := V2O(Value) as TDataSource;\r\nend;\r\n\r\n{ property Read ReadOnly: Boolean }\r\n\r\nprocedure TDBMemo_Read_ReadOnly(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TDBMemo(Args.Obj).ReadOnly;\r\nend;\r\n\r\n{ property Write ReadOnly(Value: Boolean) }\r\n\r\nprocedure TDBMemo_Write_ReadOnly(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TDBMemo(Args.Obj).ReadOnly := Value;\r\nend;\r\n\r\n{ TDBImage }\r\n\r\n{ constructor Create(AOwner: TComponent) }\r\n\r\nprocedure TDBImage_Create(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TDBImage.Create(V2O(Args.Values[0]) as TComponent));\r\nend;\r\n\r\n{ procedure CopyToClipboard; }\r\n\r\nprocedure TDBImage_CopyToClipboard(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TDBImage(Args.Obj).CopyToClipboard;\r\nend;\r\n\r\n{ procedure CutToClipboard; }\r\n\r\nprocedure TDBImage_CutToClipboard(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TDBImage(Args.Obj).CutToClipboard;\r\nend;\r\n\r\n{ procedure LoadPicture; }\r\n\r\nprocedure TDBImage_LoadPicture(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TDBImage(Args.Obj).LoadPicture;\r\nend;\r\n\r\n{ procedure PasteFromClipboard; }\r\n\r\nprocedure TDBImage_PasteFromClipboard(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TDBImage(Args.Obj).PasteFromClipboard;\r\nend;\r\n\r\n{ property Read Field: TField }\r\n\r\nprocedure TDBImage_Read_Field(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TDBImage(Args.Obj).Field);\r\nend;\r\n\r\n{ property Read Picture: TPicture }\r\n\r\nprocedure TDBImage_Read_Picture(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TDBImage(Args.Obj).Picture);\r\nend;\r\n\r\n{ property Write Picture(Value: TPicture) }\r\n\r\nprocedure TDBImage_Write_Picture(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TDBImage(Args.Obj).Picture := V2O(Value) as TPicture;\r\nend;\r\n\r\n{ property Read AutoDisplay: Boolean }\r\n\r\nprocedure TDBImage_Read_AutoDisplay(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TDBImage(Args.Obj).AutoDisplay;\r\nend;\r\n\r\n{ property Write AutoDisplay(Value: Boolean) }\r\n\r\nprocedure TDBImage_Write_AutoDisplay(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TDBImage(Args.Obj).AutoDisplay := Value;\r\nend;\r\n\r\n{ property Read BorderStyle: TBorderStyle }\r\n\r\nprocedure TDBImage_Read_BorderStyle(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TDBImage(Args.Obj).BorderStyle;\r\nend;\r\n\r\n{ property Write BorderStyle(Value: TBorderStyle) }\r\n\r\nprocedure TDBImage_Write_BorderStyle(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TDBImage(Args.Obj).BorderStyle := Value;\r\nend;\r\n\r\n{ property Read Center: Boolean }\r\n\r\nprocedure TDBImage_Read_Center(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TDBImage(Args.Obj).Center;\r\nend;\r\n\r\n{ property Write Center(Value: Boolean) }\r\n\r\nprocedure TDBImage_Write_Center(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TDBImage(Args.Obj).Center := Value;\r\nend;\r\n\r\n{ property Read DataField: string }\r\n\r\nprocedure TDBImage_Read_DataField(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TDBImage(Args.Obj).DataField;\r\nend;\r\n\r\n{ property Write DataField(Value: string) }\r\n\r\nprocedure TDBImage_Write_DataField(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TDBImage(Args.Obj).DataField := Value;\r\nend;\r\n\r\n{ property Read DataSource: TDataSource }\r\n\r\nprocedure TDBImage_Read_DataSource(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TDBImage(Args.Obj).DataSource);\r\nend;\r\n\r\n{ property Write DataSource(Value: TDataSource) }\r\n\r\nprocedure TDBImage_Write_DataSource(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TDBImage(Args.Obj).DataSource := V2O(Value) as TDataSource;\r\nend;\r\n\r\n{ property Read ReadOnly: Boolean }\r\n\r\nprocedure TDBImage_Read_ReadOnly(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TDBImage(Args.Obj).ReadOnly;\r\nend;\r\n\r\n{ property Write ReadOnly(Value: Boolean) }\r\n\r\nprocedure TDBImage_Write_ReadOnly(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TDBImage(Args.Obj).ReadOnly := Value;\r\nend;\r\n\r\n{ property Read QuickDraw: Boolean }\r\n\r\nprocedure TDBImage_Read_QuickDraw(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TDBImage(Args.Obj).QuickDraw;\r\nend;\r\n\r\n{ property Write QuickDraw(Value: Boolean) }\r\n\r\nprocedure TDBImage_Write_QuickDraw(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TDBImage(Args.Obj).QuickDraw := Value;\r\nend;\r\n\r\n{ property Read Stretch: Boolean }\r\n\r\nprocedure TDBImage_Read_Stretch(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TDBImage(Args.Obj).Stretch;\r\nend;\r\n\r\n{ property Write Stretch(Value: Boolean) }\r\n\r\nprocedure TDBImage_Write_Stretch(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TDBImage(Args.Obj).Stretch := Value;\r\nend;\r\n\r\n{ TDBNavigator }\r\n\r\n{ constructor Create(AOwner: TComponent) }\r\n\r\nprocedure TDBNavigator_Create(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TDBNavigator.Create(V2O(Args.Values[0]) as TComponent));\r\nend;\r\n\r\n{ procedure SetBounds(ALeft, ATop, AWidth, AHeight: Integer); }\r\n\r\nprocedure TDBNavigator_SetBounds(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TDBNavigator(Args.Obj).SetBounds(Args.Values[0], Args.Values[1], Args.Values[2], Args.Values[3]);\r\nend;\r\n\r\n{ procedure BtnClick(Index: TNavigateBtn); }\r\n\r\nprocedure TDBNavigator_BtnClick(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TDBNavigator(Args.Obj).BtnClick(Args.Values[0]);\r\nend;\r\n\r\n{ property Read DataSource: TDataSource }\r\n\r\nprocedure TDBNavigator_Read_DataSource(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TDBNavigator(Args.Obj).DataSource);\r\nend;\r\n\r\n{ property Write DataSource(Value: TDataSource) }\r\n\r\nprocedure TDBNavigator_Write_DataSource(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TDBNavigator(Args.Obj).DataSource := V2O(Value) as TDataSource;\r\nend;\r\n\r\n{ property Read VisibleButtons: TButtonSet }\r\n\r\nprocedure TDBNavigator_Read_VisibleButtons(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := S2V(Word(TDBNavigator(Args.Obj).VisibleButtons));\r\nend;\r\n\r\n{ property Write VisibleButtons(Value: TButtonSet) }\r\n\r\nprocedure TDBNavigator_Write_VisibleButtons(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TDBNavigator(Args.Obj).VisibleButtons := {$IFDEF COMPILER10_UP}TNavButtonSet{$ELSE}TButtonSet{$ENDIF COMPILER10_UP}(Word(V2S(Value)))\r\nend;\r\n\r\n{ property Read Flat: Boolean }\r\n\r\nprocedure TDBNavigator_Read_Flat(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TDBNavigator(Args.Obj).Flat;\r\nend;\r\n\r\n{ property Write Flat(Value: Boolean) }\r\n\r\nprocedure TDBNavigator_Write_Flat(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TDBNavigator(Args.Obj).Flat := Value;\r\nend;\r\n\r\n{ property Read Hints: TStrings }\r\n\r\nprocedure TDBNavigator_Read_Hints(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TDBNavigator(Args.Obj).Hints);\r\nend;\r\n\r\n{ property Write Hints(Value: TStrings) }\r\n\r\nprocedure TDBNavigator_Write_Hints(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TDBNavigator(Args.Obj).Hints := V2O(Value) as TStrings;\r\nend;\r\n\r\n{ property Read ConfirmDelete: Boolean }\r\n\r\nprocedure TDBNavigator_Read_ConfirmDelete(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TDBNavigator(Args.Obj).ConfirmDelete;\r\nend;\r\n\r\n{ property Write ConfirmDelete(Value: Boolean) }\r\n\r\nprocedure TDBNavigator_Write_ConfirmDelete(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TDBNavigator(Args.Obj).ConfirmDelete := Value;\r\nend;\r\n\r\n{ TDBLookupListBox }\r\n\r\n{ constructor Create(AOwner: TComponent) }\r\n\r\nprocedure TDBLookupListBox_Create(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TDBLookupListBox.Create(V2O(Args.Values[0]) as TComponent));\r\nend;\r\n\r\n{ property Read SelectedItem: string }\r\n\r\nprocedure TDBLookupListBox_Read_SelectedItem(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TDBLookupListBox(Args.Obj).SelectedItem;\r\nend;\r\n\r\n{ property Read BorderStyle: TBorderStyle }\r\n\r\nprocedure TDBLookupListBox_Read_BorderStyle(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TDBLookupListBox(Args.Obj).BorderStyle;\r\nend;\r\n\r\n{ property Write BorderStyle(Value: TBorderStyle) }\r\n\r\nprocedure TDBLookupListBox_Write_BorderStyle(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TDBLookupListBox(Args.Obj).BorderStyle := Value;\r\nend;\r\n\r\n{ property Read RowCount: Integer }\r\n\r\nprocedure TDBLookupListBox_Read_RowCount(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TDBLookupListBox(Args.Obj).RowCount;\r\nend;\r\n\r\n{ property Write RowCount(Value: Integer) }\r\n\r\nprocedure TDBLookupListBox_Write_RowCount(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TDBLookupListBox(Args.Obj).RowCount := Value;\r\nend;\r\n\r\n{ TDBLookupComboBox }\r\n\r\n{ constructor Create(AOwner: TComponent) }\r\n\r\nprocedure TDBLookupComboBox_Create(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TDBLookupComboBox.Create(V2O(Args.Values[0]) as TComponent));\r\nend;\r\n\r\n{ procedure CloseUp(Accept: Boolean); }\r\n\r\nprocedure TDBLookupComboBox_CloseUp(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TDBLookupComboBox(Args.Obj).CloseUp(Args.Values[0]);\r\nend;\r\n\r\n{ procedure DropDown; }\r\n\r\nprocedure TDBLookupComboBox_DropDown(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TDBLookupComboBox(Args.Obj).DropDown;\r\nend;\r\n\r\n{ property Read ListVisible: Boolean }\r\n\r\nprocedure TDBLookupComboBox_Read_ListVisible(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TDBLookupComboBox(Args.Obj).ListVisible;\r\nend;\r\n\r\n{ property Read Text: string }\r\n\r\nprocedure TDBLookupComboBox_Read_Text(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TDBLookupComboBox(Args.Obj).Text;\r\nend;\r\n\r\n{ property Read DropDownAlign: TDropDownAlign }\r\n\r\nprocedure TDBLookupComboBox_Read_DropDownAlign(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TDBLookupComboBox(Args.Obj).DropDownAlign;\r\nend;\r\n\r\n{ property Write DropDownAlign(Value: TDropDownAlign) }\r\n\r\nprocedure TDBLookupComboBox_Write_DropDownAlign(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TDBLookupComboBox(Args.Obj).DropDownAlign := Value;\r\nend;\r\n\r\n{ property Read DropDownRows: Integer }\r\n\r\nprocedure TDBLookupComboBox_Read_DropDownRows(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TDBLookupComboBox(Args.Obj).DropDownRows;\r\nend;\r\n\r\n{ property Write DropDownRows(Value: Integer) }\r\n\r\nprocedure TDBLookupComboBox_Write_DropDownRows(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TDBLookupComboBox(Args.Obj).DropDownRows := Value;\r\nend;\r\n\r\n{ property Read DropDownWidth: Integer }\r\n\r\nprocedure TDBLookupComboBox_Read_DropDownWidth(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TDBLookupComboBox(Args.Obj).DropDownWidth;\r\nend;\r\n\r\n{ property Write DropDownWidth(Value: Integer) }\r\n\r\nprocedure TDBLookupComboBox_Write_DropDownWidth(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TDBLookupComboBox(Args.Obj).DropDownWidth := Value;\r\nend;\r\n\r\n{ TDBRichEdit }\r\n\r\n{ constructor Create(AOwner: TComponent) }\r\n\r\nprocedure TDBRichEdit_Create(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TDBRichEdit.Create(V2O(Args.Values[0]) as TComponent));\r\nend;\r\n\r\n{ procedure LoadMemo; }\r\n\r\nprocedure TDBRichEdit_LoadMemo(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TDBRichEdit(Args.Obj).LoadMemo;\r\nend;\r\n\r\n{ property Read Field: TField }\r\n\r\nprocedure TDBRichEdit_Read_Field(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TDBRichEdit(Args.Obj).Field);\r\nend;\r\n\r\n{ property Read AutoDisplay: Boolean }\r\n\r\nprocedure TDBRichEdit_Read_AutoDisplay(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TDBRichEdit(Args.Obj).AutoDisplay;\r\nend;\r\n\r\n{ property Write AutoDisplay(Value: Boolean) }\r\n\r\nprocedure TDBRichEdit_Write_AutoDisplay(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TDBRichEdit(Args.Obj).AutoDisplay := Value;\r\nend;\r\n\r\n{ property Read DataField: string }\r\n\r\nprocedure TDBRichEdit_Read_DataField(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TDBRichEdit(Args.Obj).DataField;\r\nend;\r\n\r\n{ property Write DataField(Value: string) }\r\n\r\nprocedure TDBRichEdit_Write_DataField(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TDBRichEdit(Args.Obj).DataField := Value;\r\nend;\r\n\r\n{ property Read DataSource: TDataSource }\r\n\r\nprocedure TDBRichEdit_Read_DataSource(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TDBRichEdit(Args.Obj).DataSource);\r\nend;\r\n\r\n{ property Write DataSource(Value: TDataSource) }\r\n\r\nprocedure TDBRichEdit_Write_DataSource(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TDBRichEdit(Args.Obj).DataSource := V2O(Value) as TDataSource;\r\nend;\r\n\r\n{ property Read ReadOnly: Boolean }\r\n\r\nprocedure TDBRichEdit_Read_ReadOnly(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TDBRichEdit(Args.Obj).ReadOnly;\r\nend;\r\n\r\n{ property Write ReadOnly(Value: Boolean) }\r\n\r\nprocedure TDBRichEdit_Write_ReadOnly(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TDBRichEdit(Args.Obj).ReadOnly := Value;\r\nend;\r\n\r\nprocedure RegisterJvInterpreterAdapter(JvInterpreterAdapter: TJvInterpreterAdapter);\r\nconst\r\n cDbCtrls = 'DbCtrls';\r\nbegin\r\n with JvInterpreterAdapter do\r\n begin\r\n { TDBEdit }\r\n AddClass(cDbCtrls, TDBEdit, 'TDBEdit');\r\n AddGet(TDBEdit, 'Create', TDBEdit_Create, 1, [varEmpty], varEmpty);\r\n AddGet(TDBEdit, 'Field', TDBEdit_Read_Field, 0, [varEmpty], varEmpty);\r\n AddGet(TDBEdit, 'DataField', TDBEdit_Read_DataField, 0, [varEmpty], varEmpty);\r\n AddSet(TDBEdit, 'DataField', TDBEdit_Write_DataField, 0, [varEmpty]);\r\n AddGet(TDBEdit, 'DataSource', TDBEdit_Read_DataSource, 0, [varEmpty], varEmpty);\r\n AddSet(TDBEdit, 'DataSource', TDBEdit_Write_DataSource, 0, [varEmpty]);\r\n AddGet(TDBEdit, 'ReadOnly', TDBEdit_Read_ReadOnly, 0, [varEmpty], varEmpty);\r\n AddSet(TDBEdit, 'ReadOnly', TDBEdit_Write_ReadOnly, 0, [varEmpty]);\r\n { TDBText }\r\n AddClass(cDbCtrls, TDBText, 'TDBText');\r\n AddGet(TDBText, 'Create', TDBText_Create, 1, [varEmpty], varEmpty);\r\n AddGet(TDBText, 'Field', TDBText_Read_Field, 0, [varEmpty], varEmpty);\r\n AddGet(TDBText, 'DataField', TDBText_Read_DataField, 0, [varEmpty], varEmpty);\r\n AddSet(TDBText, 'DataField', TDBText_Write_DataField, 0, [varEmpty]);\r\n AddGet(TDBText, 'DataSource', TDBText_Read_DataSource, 0, [varEmpty], varEmpty);\r\n AddSet(TDBText, 'DataSource', TDBText_Write_DataSource, 0, [varEmpty]);\r\n { TDBCheckBox }\r\n AddClass(cDbCtrls, TDBCheckBox, 'TDBCheckBox');\r\n AddGet(TDBCheckBox, 'Create', TDBCheckBox_Create, 1, [varEmpty], varEmpty);\r\n AddGet(TDBCheckBox, 'Field', TDBCheckBox_Read_Field, 0, [varEmpty], varEmpty);\r\n AddGet(TDBCheckBox, 'DataField', TDBCheckBox_Read_DataField, 0, [varEmpty], varEmpty);\r\n AddSet(TDBCheckBox, 'DataField', TDBCheckBox_Write_DataField, 0, [varEmpty]);\r\n AddGet(TDBCheckBox, 'DataSource', TDBCheckBox_Read_DataSource, 0, [varEmpty], varEmpty);\r\n AddSet(TDBCheckBox, 'DataSource', TDBCheckBox_Write_DataSource, 0, [varEmpty]);\r\n AddGet(TDBCheckBox, 'ReadOnly', TDBCheckBox_Read_ReadOnly, 0, [varEmpty], varEmpty);\r\n AddSet(TDBCheckBox, 'ReadOnly', TDBCheckBox_Write_ReadOnly, 0, [varEmpty]);\r\n AddGet(TDBCheckBox, 'ValueChecked', TDBCheckBox_Read_ValueChecked, 0, [varEmpty], varEmpty);\r\n AddSet(TDBCheckBox, 'ValueChecked', TDBCheckBox_Write_ValueChecked, 0, [varEmpty]);\r\n AddGet(TDBCheckBox, 'ValueUnchecked', TDBCheckBox_Read_ValueUnchecked, 0, [varEmpty], varEmpty);\r\n AddSet(TDBCheckBox, 'ValueUnchecked', TDBCheckBox_Write_ValueUnchecked, 0, [varEmpty]);\r\n { TDBComboBox }\r\n AddClass(cDbCtrls, TDBComboBox, 'TDBComboBox');\r\n AddGet(TDBComboBox, 'Create', TDBComboBox_Create, 1, [varEmpty], varEmpty);\r\n AddGet(TDBComboBox, 'Field', TDBComboBox_Read_Field, 0, [varEmpty], varEmpty);\r\n AddGet(TDBComboBox, 'DataField', TDBComboBox_Read_DataField, 0, [varEmpty], varEmpty);\r\n AddSet(TDBComboBox, 'DataField', TDBComboBox_Write_DataField, 0, [varEmpty]);\r\n AddGet(TDBComboBox, 'DataSource', TDBComboBox_Read_DataSource, 0, [varEmpty], varEmpty);\r\n AddSet(TDBComboBox, 'DataSource', TDBComboBox_Write_DataSource, 0, [varEmpty]);\r\n AddGet(TDBComboBox, 'ReadOnly', TDBComboBox_Read_ReadOnly, 0, [varEmpty], varEmpty);\r\n AddSet(TDBComboBox, 'ReadOnly', TDBComboBox_Write_ReadOnly, 0, [varEmpty]);\r\n { TDBListBox }\r\n AddClass(cDbCtrls, TDBListBox, 'TDBListBox');\r\n AddGet(TDBListBox, 'Create', TDBListBox_Create, 1, [varEmpty], varEmpty);\r\n AddGet(TDBListBox, 'Field', TDBListBox_Read_Field, 0, [varEmpty], varEmpty);\r\n AddGet(TDBListBox, 'DataField', TDBListBox_Read_DataField, 0, [varEmpty], varEmpty);\r\n AddSet(TDBListBox, 'DataField', TDBListBox_Write_DataField, 0, [varEmpty]);\r\n AddGet(TDBListBox, 'DataSource', TDBListBox_Read_DataSource, 0, [varEmpty], varEmpty);\r\n AddSet(TDBListBox, 'DataSource', TDBListBox_Write_DataSource, 0, [varEmpty]);\r\n AddGet(TDBListBox, 'ReadOnly', TDBListBox_Read_ReadOnly, 0, [varEmpty], varEmpty);\r\n AddSet(TDBListBox, 'ReadOnly', TDBListBox_Write_ReadOnly, 0, [varEmpty]);\r\n { TDBRadioGroup }\r\n AddClass(cDbCtrls, TDBRadioGroup, 'TDBRadioGroup');\r\n AddGet(TDBRadioGroup, 'Create', TDBRadioGroup_Create, 1, [varEmpty], varEmpty);\r\n AddGet(TDBRadioGroup, 'Field', TDBRadioGroup_Read_Field, 0, [varEmpty], varEmpty);\r\n AddGet(TDBRadioGroup, 'Value', TDBRadioGroup_Read_Value, 0, [varEmpty], varEmpty);\r\n AddSet(TDBRadioGroup, 'Value', TDBRadioGroup_Write_Value, 0, [varEmpty]);\r\n AddGet(TDBRadioGroup, 'DataField', TDBRadioGroup_Read_DataField, 0, [varEmpty], varEmpty);\r\n AddSet(TDBRadioGroup, 'DataField', TDBRadioGroup_Write_DataField, 0, [varEmpty]);\r\n AddGet(TDBRadioGroup, 'DataSource', TDBRadioGroup_Read_DataSource, 0, [varEmpty], varEmpty);\r\n AddSet(TDBRadioGroup, 'DataSource', TDBRadioGroup_Write_DataSource, 0, [varEmpty]);\r\n AddGet(TDBRadioGroup, 'ReadOnly', TDBRadioGroup_Read_ReadOnly, 0, [varEmpty], varEmpty);\r\n AddSet(TDBRadioGroup, 'ReadOnly', TDBRadioGroup_Write_ReadOnly, 0, [varEmpty]);\r\n AddGet(TDBRadioGroup, 'Values', TDBRadioGroup_Read_Values, 0, [varEmpty], varEmpty);\r\n AddSet(TDBRadioGroup, 'Values', TDBRadioGroup_Write_Values, 0, [varEmpty]);\r\n { TDBMemo }\r\n AddClass(cDbCtrls, TDBMemo, 'TDBMemo');\r\n AddGet(TDBMemo, 'Create', TDBMemo_Create, 1, [varEmpty], varEmpty);\r\n AddGet(TDBMemo, 'LoadMemo', TDBMemo_LoadMemo, 0, [varEmpty], varEmpty);\r\n AddGet(TDBMemo, 'Field', TDBMemo_Read_Field, 0, [varEmpty], varEmpty);\r\n AddGet(TDBMemo, 'AutoDisplay', TDBMemo_Read_AutoDisplay, 0, [varEmpty], varEmpty);\r\n AddSet(TDBMemo, 'AutoDisplay', TDBMemo_Write_AutoDisplay, 0, [varEmpty]);\r\n AddGet(TDBMemo, 'DataField', TDBMemo_Read_DataField, 0, [varEmpty], varEmpty);\r\n AddSet(TDBMemo, 'DataField', TDBMemo_Write_DataField, 0, [varEmpty]);\r\n AddGet(TDBMemo, 'DataSource', TDBMemo_Read_DataSource, 0, [varEmpty], varEmpty);\r\n AddSet(TDBMemo, 'DataSource', TDBMemo_Write_DataSource, 0, [varEmpty]);\r\n AddGet(TDBMemo, 'ReadOnly', TDBMemo_Read_ReadOnly, 0, [varEmpty], varEmpty);\r\n AddSet(TDBMemo, 'ReadOnly', TDBMemo_Write_ReadOnly, 0, [varEmpty]);\r\n { TDBImage }\r\n AddClass(cDbCtrls, TDBImage, 'TDBImage');\r\n AddGet(TDBImage, 'Create', TDBImage_Create, 1, [varEmpty], varEmpty);\r\n AddGet(TDBImage, 'CopyToClipboard', TDBImage_CopyToClipboard, 0, [varEmpty], varEmpty);\r\n AddGet(TDBImage, 'CutToClipboard', TDBImage_CutToClipboard, 0, [varEmpty], varEmpty);\r\n AddGet(TDBImage, 'LoadPicture', TDBImage_LoadPicture, 0, [varEmpty], varEmpty);\r\n AddGet(TDBImage, 'PasteFromClipboard', TDBImage_PasteFromClipboard, 0, [varEmpty], varEmpty);\r\n AddGet(TDBImage, 'Field', TDBImage_Read_Field, 0, [varEmpty], varEmpty);\r\n AddGet(TDBImage, 'Picture', TDBImage_Read_Picture, 0, [varEmpty], varEmpty);\r\n AddSet(TDBImage, 'Picture', TDBImage_Write_Picture, 0, [varEmpty]);\r\n AddGet(TDBImage, 'AutoDisplay', TDBImage_Read_AutoDisplay, 0, [varEmpty], varEmpty);\r\n AddSet(TDBImage, 'AutoDisplay', TDBImage_Write_AutoDisplay, 0, [varEmpty]);\r\n AddGet(TDBImage, 'BorderStyle', TDBImage_Read_BorderStyle, 0, [varEmpty], varEmpty);\r\n AddSet(TDBImage, 'BorderStyle', TDBImage_Write_BorderStyle, 0, [varEmpty]);\r\n AddGet(TDBImage, 'Center', TDBImage_Read_Center, 0, [varEmpty], varEmpty);\r\n AddSet(TDBImage, 'Center', TDBImage_Write_Center, 0, [varEmpty]);\r\n AddGet(TDBImage, 'DataField', TDBImage_Read_DataField, 0, [varEmpty], varEmpty);\r\n AddSet(TDBImage, 'DataField', TDBImage_Write_DataField, 0, [varEmpty]);\r\n AddGet(TDBImage, 'DataSource', TDBImage_Read_DataSource, 0, [varEmpty], varEmpty);\r\n AddSet(TDBImage, 'DataSource', TDBImage_Write_DataSource, 0, [varEmpty]);\r\n AddGet(TDBImage, 'ReadOnly', TDBImage_Read_ReadOnly, 0, [varEmpty], varEmpty);\r\n AddSet(TDBImage, 'ReadOnly', TDBImage_Write_ReadOnly, 0, [varEmpty]);\r\n AddGet(TDBImage, 'QuickDraw', TDBImage_Read_QuickDraw, 0, [varEmpty], varEmpty);\r\n AddSet(TDBImage, 'QuickDraw', TDBImage_Write_QuickDraw, 0, [varEmpty]);\r\n AddGet(TDBImage, 'Stretch', TDBImage_Read_Stretch, 0, [varEmpty], varEmpty);\r\n AddSet(TDBImage, 'Stretch', TDBImage_Write_Stretch, 0, [varEmpty]);\r\n { TDBNavigator }\r\n AddClass(cDbCtrls, TDBNavigator, 'TDBNavigator');\r\n AddGet(TDBNavigator, 'Create', TDBNavigator_Create, 1, [varEmpty], varEmpty);\r\n AddGet(TDBNavigator, 'SetBounds', TDBNavigator_SetBounds, 4, [varEmpty, varEmpty, varEmpty, varEmpty], varEmpty);\r\n AddGet(TDBNavigator, 'BtnClick', TDBNavigator_BtnClick, 1, [varEmpty], varEmpty);\r\n AddGet(TDBNavigator, 'DataSource', TDBNavigator_Read_DataSource, 0, [varEmpty], varEmpty);\r\n AddSet(TDBNavigator, 'DataSource', TDBNavigator_Write_DataSource, 0, [varEmpty]);\r\n AddGet(TDBNavigator, 'VisibleButtons', TDBNavigator_Read_VisibleButtons, 0, [varEmpty], varEmpty);\r\n AddSet(TDBNavigator, 'VisibleButtons', TDBNavigator_Write_VisibleButtons, 0, [varEmpty]);\r\n AddGet(TDBNavigator, 'Flat', TDBNavigator_Read_Flat, 0, [varEmpty], varEmpty);\r\n AddSet(TDBNavigator, 'Flat', TDBNavigator_Write_Flat, 0, [varEmpty]);\r\n AddGet(TDBNavigator, 'Hints', TDBNavigator_Read_Hints, 0, [varEmpty], varEmpty);\r\n AddSet(TDBNavigator, 'Hints', TDBNavigator_Write_Hints, 0, [varEmpty]);\r\n AddGet(TDBNavigator, 'ConfirmDelete', TDBNavigator_Read_ConfirmDelete, 0, [varEmpty], varEmpty);\r\n AddSet(TDBNavigator, 'ConfirmDelete', TDBNavigator_Write_ConfirmDelete, 0, [varEmpty]);\r\n { TDBLookupListBox }\r\n AddClass(cDbCtrls, TDBLookupListBox, 'TDBLookupListBox');\r\n AddGet(TDBLookupListBox, 'Create', TDBLookupListBox_Create, 1, [varEmpty], varEmpty);\r\n AddGet(TDBLookupListBox, 'SelectedItem', TDBLookupListBox_Read_SelectedItem, 0, [varEmpty], varEmpty);\r\n AddGet(TDBLookupListBox, 'BorderStyle', TDBLookupListBox_Read_BorderStyle, 0, [varEmpty], varEmpty);\r\n AddSet(TDBLookupListBox, 'BorderStyle', TDBLookupListBox_Write_BorderStyle, 0, [varEmpty]);\r\n AddGet(TDBLookupListBox, 'RowCount', TDBLookupListBox_Read_RowCount, 0, [varEmpty], varEmpty);\r\n AddSet(TDBLookupListBox, 'RowCount', TDBLookupListBox_Write_RowCount, 0, [varEmpty]);\r\n { TDBLookupComboBox }\r\n AddClass(cDbCtrls, TDBLookupComboBox, 'TDBLookupComboBox');\r\n AddGet(TDBLookupComboBox, 'Create', TDBLookupComboBox_Create, 1, [varEmpty], varEmpty);\r\n AddGet(TDBLookupComboBox, 'CloseUp', TDBLookupComboBox_CloseUp, 1, [varEmpty], varEmpty);\r\n AddGet(TDBLookupComboBox, 'DropDown', TDBLookupComboBox_DropDown, 0, [varEmpty], varEmpty);\r\n AddGet(TDBLookupComboBox, 'ListVisible', TDBLookupComboBox_Read_ListVisible, 0, [varEmpty], varEmpty);\r\n AddGet(TDBLookupComboBox, 'Text', TDBLookupComboBox_Read_Text, 0, [varEmpty], varEmpty);\r\n AddGet(TDBLookupComboBox, 'DropDownAlign', TDBLookupComboBox_Read_DropDownAlign, 0, [varEmpty], varEmpty);\r\n AddSet(TDBLookupComboBox, 'DropDownAlign', TDBLookupComboBox_Write_DropDownAlign, 0, [varEmpty]);\r\n AddGet(TDBLookupComboBox, 'DropDownRows', TDBLookupComboBox_Read_DropDownRows, 0, [varEmpty], varEmpty);\r\n AddSet(TDBLookupComboBox, 'DropDownRows', TDBLookupComboBox_Write_DropDownRows, 0, [varEmpty]);\r\n AddGet(TDBLookupComboBox, 'DropDownWidth', TDBLookupComboBox_Read_DropDownWidth, 0, [varEmpty], varEmpty);\r\n AddSet(TDBLookupComboBox, 'DropDownWidth', TDBLookupComboBox_Write_DropDownWidth, 0, [varEmpty]);\r\n { TDBRichEdit }\r\n AddClass(cDbCtrls, TDBRichEdit, 'TDBRichEdit');\r\n AddGet(TDBRichEdit, 'Create', TDBRichEdit_Create, 1, [varEmpty], varEmpty);\r\n AddGet(TDBRichEdit, 'LoadMemo', TDBRichEdit_LoadMemo, 0, [varEmpty], varEmpty);\r\n AddGet(TDBRichEdit, 'Field', TDBRichEdit_Read_Field, 0, [varEmpty], varEmpty);\r\n AddGet(TDBRichEdit, 'AutoDisplay', TDBRichEdit_Read_AutoDisplay, 0, [varEmpty], varEmpty);\r\n AddSet(TDBRichEdit, 'AutoDisplay', TDBRichEdit_Write_AutoDisplay, 0, [varEmpty]);\r\n AddGet(TDBRichEdit, 'DataField', TDBRichEdit_Read_DataField, 0, [varEmpty], varEmpty);\r\n AddSet(TDBRichEdit, 'DataField', TDBRichEdit_Write_DataField, 0, [varEmpty]);\r\n AddGet(TDBRichEdit, 'DataSource', TDBRichEdit_Read_DataSource, 0, [varEmpty], varEmpty);\r\n AddSet(TDBRichEdit, 'DataSource', TDBRichEdit_Write_DataSource, 0, [varEmpty]);\r\n AddGet(TDBRichEdit, 'ReadOnly', TDBRichEdit_Read_ReadOnly, 0, [varEmpty], varEmpty);\r\n AddSet(TDBRichEdit, 'ReadOnly', TDBRichEdit_Write_ReadOnly, 0, [varEmpty]);\r\n end;\r\n RegisterCLasses([TDBEdit, TDBText, TDBCheckBox, TDBComboBox, TDBListBox,\r\n TDBRadioGroup, TDBMemo, TDBImage, TDBNavigator, TDBLookupListBox,\r\n TDBLookupComboBox, TDBRichEdit]);\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvInterpreter_DbGrids.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvInterpreter_DbGrids.PAS, released on 2002-07-04.\r\n\r\nThe Initial Developers of the Original Code are: Andrei Prygounkov \r\nCopyright (c) 1999, 2002 Andrei Prygounkov\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nDescription : adapter unit - converts JvInterpreter calls to delphi calls\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvInterpreter_DbGrids.pas 13075 2011-06-27 22:56:21Z jfudickar $\r\n\r\nunit JvInterpreter_DbGrids;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n JvInterpreter;\r\n\r\nprocedure RegisterJvInterpreterAdapter(JvInterpreterAdapter: TJvInterpreterAdapter);\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvInterpreter_DbGrids.pas $';\r\n Revision: '$Revision: 13075 $';\r\n Date: '$Date: 2011-06-28 00:56:21 +0200 (mar. 28 juin 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n Classes, Graphics, Menus, Grids, DB, DBGrids,\r\n JvInterpreter_Windows;\r\n\r\n{ TColumnTitle }\r\n\r\n{ constructor Create(Column: TColumn) }\r\n\r\nprocedure TColumnTitle_Create(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TColumnTitle.Create(V2O(Args.Values[0]) as TColumn));\r\nend;\r\n\r\n{ procedure Assign(Source: TPersistent); }\r\n\r\nprocedure TColumnTitle_Assign(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TColumnTitle(Args.Obj).Assign(V2O(Args.Values[0]) as TPersistent);\r\nend;\r\n\r\n{ function DefaultAlignment: TAlignment; }\r\n\r\nprocedure TColumnTitle_DefaultAlignment(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TColumnTitle(Args.Obj).DefaultAlignment;\r\nend;\r\n\r\n{ function DefaultColor: TColor; }\r\n\r\nprocedure TColumnTitle_DefaultColor(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TColumnTitle(Args.Obj).DefaultColor;\r\nend;\r\n\r\n{ function DefaultFont: TFont; }\r\n\r\nprocedure TColumnTitle_DefaultFont(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TColumnTitle(Args.Obj).DefaultFont);\r\nend;\r\n\r\n{ function DefaultCaption: string; }\r\n\r\nprocedure TColumnTitle_DefaultCaption(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TColumnTitle(Args.Obj).DefaultCaption;\r\nend;\r\n\r\n{ procedure RestoreDefaults; }\r\n\r\nprocedure TColumnTitle_RestoreDefaults(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TColumnTitle(Args.Obj).RestoreDefaults;\r\nend;\r\n\r\n{ property Read Alignment: TAlignment }\r\n\r\nprocedure TColumnTitle_Read_Alignment(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TColumnTitle(Args.Obj).Alignment;\r\nend;\r\n\r\n{ property Write Alignment(Value: TAlignment) }\r\n\r\nprocedure TColumnTitle_Write_Alignment(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TColumnTitle(Args.Obj).Alignment := Value;\r\nend;\r\n\r\n{ property Read Caption: string }\r\n\r\nprocedure TColumnTitle_Read_Caption(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TColumnTitle(Args.Obj).Caption;\r\nend;\r\n\r\n{ property Write Caption(Value: string) }\r\n\r\nprocedure TColumnTitle_Write_Caption(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TColumnTitle(Args.Obj).Caption := Value;\r\nend;\r\n\r\n{ property Read Color: TColor }\r\n\r\nprocedure TColumnTitle_Read_Color(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TColumnTitle(Args.Obj).Color;\r\nend;\r\n\r\n{ property Write Color(Value: TColor) }\r\n\r\nprocedure TColumnTitle_Write_Color(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TColumnTitle(Args.Obj).Color := Value;\r\nend;\r\n\r\n{ property Read Font: TFont }\r\n\r\nprocedure TColumnTitle_Read_Font(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TColumnTitle(Args.Obj).Font);\r\nend;\r\n\r\n{ property Write Font(Value: TFont) }\r\n\r\nprocedure TColumnTitle_Write_Font(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TColumnTitle(Args.Obj).Font := V2O(Value) as TFont;\r\nend;\r\n\r\n{ TColumn }\r\n\r\n{ constructor Create(Collection: TCollection) }\r\n\r\nprocedure TColumn_Create(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TColumn.Create(V2O(Args.Values[0]) as TCollection));\r\nend;\r\n\r\n{ procedure Assign(Source: TPersistent); }\r\n\r\nprocedure TColumn_Assign(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TColumn(Args.Obj).Assign(V2O(Args.Values[0]) as TPersistent);\r\nend;\r\n\r\n{ function DefaultAlignment: TAlignment; }\r\n\r\nprocedure TColumn_DefaultAlignment(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TColumn(Args.Obj).DefaultAlignment;\r\nend;\r\n\r\n{ function DefaultColor: TColor; }\r\n\r\nprocedure TColumn_DefaultColor(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TColumn(Args.Obj).DefaultColor;\r\nend;\r\n\r\n{ function DefaultFont: TFont; }\r\n\r\nprocedure TColumn_DefaultFont(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TColumn(Args.Obj).DefaultFont);\r\nend;\r\n\r\n{ function DefaultImeMode: TImeMode; }\r\n\r\nprocedure TColumn_DefaultImeMode(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TColumn(Args.Obj).DefaultImeMode;\r\nend;\r\n\r\n{ function DefaultImeName: TImeName; }\r\n\r\nprocedure TColumn_DefaultImeName(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TColumn(Args.Obj).DefaultImeName;\r\nend;\r\n\r\n{ function DefaultReadOnly: Boolean; }\r\n\r\nprocedure TColumn_DefaultReadOnly(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TColumn(Args.Obj).DefaultReadOnly;\r\nend;\r\n\r\n{ function DefaultWidth: Integer; }\r\n\r\nprocedure TColumn_DefaultWidth(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TColumn(Args.Obj).DefaultWidth;\r\nend;\r\n\r\n{ procedure RestoreDefaults; }\r\n\r\nprocedure TColumn_RestoreDefaults(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TColumn(Args.Obj).RestoreDefaults;\r\nend;\r\n\r\n{ property Read Grid: TCustomDBGrid }\r\n\r\nprocedure TColumn_Read_Grid(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TColumn(Args.Obj).Grid);\r\nend;\r\n\r\n{ property Read AssignedValues: TColumnValues }\r\n\r\nprocedure TColumn_Read_AssignedValues(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := S2V(Word(TColumn(Args.Obj).AssignedValues));\r\nend;\r\n\r\n{ property Read Field: TField }\r\n\r\nprocedure TColumn_Read_Field(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TColumn(Args.Obj).Field);\r\nend;\r\n\r\n{ property Write Field(Value: TField) }\r\n\r\nprocedure TColumn_Write_Field(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TColumn(Args.Obj).Field := V2O(Value) as TField;\r\nend;\r\n\r\n{ property Read Alignment: TAlignment }\r\n\r\nprocedure TColumn_Read_Alignment(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TColumn(Args.Obj).Alignment;\r\nend;\r\n\r\n{ property Write Alignment(Value: TAlignment) }\r\n\r\nprocedure TColumn_Write_Alignment(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TColumn(Args.Obj).Alignment := Value;\r\nend;\r\n\r\n{ property Read ButtonStyle: TColumnButtonStyle }\r\n\r\nprocedure TColumn_Read_ButtonStyle(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TColumn(Args.Obj).ButtonStyle;\r\nend;\r\n\r\n{ property Write ButtonStyle(Value: TColumnButtonStyle) }\r\n\r\nprocedure TColumn_Write_ButtonStyle(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TColumn(Args.Obj).ButtonStyle := Value;\r\nend;\r\n\r\n{ property Read Color: TColor }\r\n\r\nprocedure TColumn_Read_Color(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TColumn(Args.Obj).Color;\r\nend;\r\n\r\n{ property Write Color(Value: TColor) }\r\n\r\nprocedure TColumn_Write_Color(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TColumn(Args.Obj).Color := Value;\r\nend;\r\n\r\n{ property Read DropDownRows: Cardinal }\r\n\r\nprocedure TColumn_Read_DropDownRows(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := Integer(TColumn(Args.Obj).DropDownRows);\r\nend;\r\n\r\n{ property Write DropDownRows(Value: Cardinal) }\r\n\r\nprocedure TColumn_Write_DropDownRows(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TColumn(Args.Obj).DropDownRows := Value;\r\nend;\r\n\r\n{ property Read FieldName: String }\r\n\r\nprocedure TColumn_Read_FieldName(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TColumn(Args.Obj).FieldName;\r\nend;\r\n\r\n{ property Write FieldName(Value: String) }\r\n\r\nprocedure TColumn_Write_FieldName(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TColumn(Args.Obj).FieldName := Value;\r\nend;\r\n\r\n{ property Read Font: TFont }\r\n\r\nprocedure TColumn_Read_Font(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TColumn(Args.Obj).Font);\r\nend;\r\n\r\n{ property Write Font(Value: TFont) }\r\n\r\nprocedure TColumn_Write_Font(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TColumn(Args.Obj).Font := V2O(Value) as TFont;\r\nend;\r\n\r\n{ property Read ImeMode: TImeMode }\r\n\r\nprocedure TColumn_Read_ImeMode(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TColumn(Args.Obj).ImeMode;\r\nend;\r\n\r\n{ property Write ImeMode(Value: TImeMode) }\r\n\r\nprocedure TColumn_Write_ImeMode(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TColumn(Args.Obj).ImeMode := Value;\r\nend;\r\n\r\n{ property Read ImeName: TImeName }\r\n\r\nprocedure TColumn_Read_ImeName(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TColumn(Args.Obj).ImeName;\r\nend;\r\n\r\n{ property Write ImeName(Value: TImeName) }\r\n\r\nprocedure TColumn_Write_ImeName(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TColumn(Args.Obj).ImeName := Value;\r\nend;\r\n\r\n{ property Read PickList: TStrings }\r\n\r\nprocedure TColumn_Read_PickList(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TColumn(Args.Obj).PickList);\r\nend;\r\n\r\n{ property Write PickList(Value: TStrings) }\r\n\r\nprocedure TColumn_Write_PickList(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TColumn(Args.Obj).PickList := V2O(Value) as TStrings;\r\nend;\r\n\r\n{ property Read PopupMenu: TPopupMenu }\r\n\r\nprocedure TColumn_Read_PopupMenu(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TColumn(Args.Obj).PopupMenu);\r\nend;\r\n\r\n{ property Write PopupMenu(Value: TPopupMenu) }\r\n\r\nprocedure TColumn_Write_PopupMenu(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TColumn(Args.Obj).PopupMenu := V2O(Value) as TPopupMenu;\r\nend;\r\n\r\n{ property Read ReadOnly: Boolean }\r\n\r\nprocedure TColumn_Read_ReadOnly(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TColumn(Args.Obj).ReadOnly;\r\nend;\r\n\r\n{ property Write ReadOnly(Value: Boolean) }\r\n\r\nprocedure TColumn_Write_ReadOnly(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TColumn(Args.Obj).ReadOnly := Value;\r\nend;\r\n\r\n{ property Read Title: TColumnTitle }\r\n\r\nprocedure TColumn_Read_Title(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TColumn(Args.Obj).Title);\r\nend;\r\n\r\n{ property Write Title(Value: TColumnTitle) }\r\n\r\nprocedure TColumn_Write_Title(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TColumn(Args.Obj).Title := V2O(Value) as TColumnTitle;\r\nend;\r\n\r\n{ property Read Width: Integer }\r\n\r\nprocedure TColumn_Read_Width(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TColumn(Args.Obj).Width;\r\nend;\r\n\r\n{ property Write Width(Value: Integer) }\r\n\r\nprocedure TColumn_Write_Width(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TColumn(Args.Obj).Width := Value;\r\nend;\r\n\r\n{ TDBGridColumns }\r\n\r\n{ constructor Create(Grid: TCustomDBGrid; ColumnClass: TColumnClass) }\r\n\r\nprocedure TDBGridColumns_Create(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TDBGridColumns.Create(V2O(Args.Values[0]) as TCustomDBGrid, TColumnClass(V2O(Args.Values[1]))));\r\nend;\r\n\r\n{ function Add: TColumn; }\r\n\r\nprocedure TDBGridColumns_Add(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TDBGridColumns(Args.Obj).Add);\r\nend;\r\n\r\n{ procedure LoadFromFile(const Filename: string); }\r\n\r\nprocedure TDBGridColumns_LoadFromFile(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TDBGridColumns(Args.Obj).LoadFromFile(Args.Values[0]);\r\nend;\r\n\r\n{ procedure LoadFromStream(S: TStream); }\r\n\r\nprocedure TDBGridColumns_LoadFromStream(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TDBGridColumns(Args.Obj).LoadFromStream(V2O(Args.Values[0]) as TStream);\r\nend;\r\n\r\n{ procedure RestoreDefaults; }\r\n\r\nprocedure TDBGridColumns_RestoreDefaults(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TDBGridColumns(Args.Obj).RestoreDefaults;\r\nend;\r\n\r\n{ procedure RebuildColumns; }\r\n\r\nprocedure TDBGridColumns_RebuildColumns(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TDBGridColumns(Args.Obj).RebuildColumns;\r\nend;\r\n\r\n{ procedure SaveToFile(const Filename: string); }\r\n\r\nprocedure TDBGridColumns_SaveToFile(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TDBGridColumns(Args.Obj).SaveToFile(Args.Values[0]);\r\nend;\r\n\r\n{ procedure SaveToStream(S: TStream); }\r\n\r\nprocedure TDBGridColumns_SaveToStream(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TDBGridColumns(Args.Obj).SaveToStream(V2O(Args.Values[0]) as TStream);\r\nend;\r\n\r\n{ property Read State: TDBGridColumnsState }\r\n\r\nprocedure TDBGridColumns_Read_State(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TDBGridColumns(Args.Obj).State;\r\nend;\r\n\r\n{ property Write State(Value: TDBGridColumnsState) }\r\n\r\nprocedure TDBGridColumns_Write_State(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TDBGridColumns(Args.Obj).State := Value;\r\nend;\r\n\r\n{ property Read Grid: TCustomDBGrid }\r\n\r\nprocedure TDBGridColumns_Read_Grid(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TDBGridColumns(Args.Obj).Grid);\r\nend;\r\n\r\n{ property Read Items[Integer]: TColumn }\r\n\r\nprocedure TDBGridColumns_Read_Items(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TDBGridColumns(Args.Obj).Items[Args.Values[0]]);\r\nend;\r\n\r\n{ property Write Items[Integer]: TColumn }\r\n\r\nprocedure TDBGridColumns_Write_Items(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TDBGridColumns(Args.Obj).Items[Args.Values[0]] := V2O(Value) as TColumn;\r\nend;\r\n\r\n{ TBookmarkList }\r\n\r\n{ constructor Create(AGrid: TCustomDBGrid) }\r\n\r\nprocedure TBookmarkList_Create(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TBookmarkList.Create(V2O(Args.Values[0]) as TCustomDBGrid));\r\nend;\r\n\r\n{ procedure Clear; }\r\n\r\nprocedure TBookmarkList_Clear(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TBookmarkList(Args.Obj).Clear;\r\nend;\r\n\r\n{ procedure Delete; }\r\n\r\nprocedure TBookmarkList_Delete(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TBookmarkList(Args.Obj).Delete;\r\nend;\r\n\r\n{ function Find(const Item: TBookmarkStr; var Index: Integer): Boolean; }\r\n\r\nprocedure TBookmarkList_Find(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TBookmarkList(Args.Obj).Find(Args.Values[0], TVarData(Args.Values[1]).vInteger);\r\nend;\r\n\r\n{ function IndexOf(const Item: TBookmarkStr): Integer; }\r\n\r\nprocedure TBookmarkList_IndexOf(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TBookmarkList(Args.Obj).IndexOf(Args.Values[0]);\r\nend;\r\n\r\n{ function Refresh: Boolean; }\r\n\r\nprocedure TBookmarkList_Refresh(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TBookmarkList(Args.Obj).Refresh;\r\nend;\r\n\r\n{ property Read Count: Integer }\r\n\r\nprocedure TBookmarkList_Read_Count(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TBookmarkList(Args.Obj).Count;\r\nend;\r\n\r\n{ property Read CurrentRowSelected: Boolean }\r\n\r\nprocedure TBookmarkList_Read_CurrentRowSelected(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TBookmarkList(Args.Obj).CurrentRowSelected;\r\nend;\r\n\r\n{ property Write CurrentRowSelected(Value: Boolean) }\r\n\r\nprocedure TBookmarkList_Write_CurrentRowSelected(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TBookmarkList(Args.Obj).CurrentRowSelected := Value;\r\nend;\r\n\r\n{ property Read Items[Integer]: TBookmarkStr }\r\n\r\nprocedure TBookmarkList_Read_Items(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TBookmarkList(Args.Obj).Items[Args.Values[0]];\r\nend;\r\n\r\n{ TCustomDBGrid }\r\n\r\n{ procedure DefaultDrawDataCell(const Rect: TRect; Field: TField; State: TGridDrawState); }\r\n\r\nprocedure TCustomDBGrid_DefaultDrawDataCell(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TCustomDBGrid(Args.Obj).DefaultDrawDataCell(Var2Rect(Args.Values[0]), V2O(Args.Values[1]) as TField,\r\n TGridDrawState(Byte(V2S(Args.Values[2]))));\r\nend;\r\n\r\n{ procedure DefaultDrawColumnCell(const Rect: TRect; DataCol: Integer; Column: TColumn; State: TGridDrawState); }\r\n\r\nprocedure TCustomDBGrid_DefaultDrawColumnCell(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TCustomDBGrid(Args.Obj).DefaultDrawColumnCell(Var2Rect(Args.Values[0]), Args.Values[1], V2O(Args.Values[2]) as\r\n TColumn, TGridDrawState(Byte(V2S(Args.Values[3]))));\r\nend;\r\n\r\n{ function ValidFieldIndex(FieldIndex: Integer): Boolean; }\r\n\r\nprocedure TCustomDBGrid_ValidFieldIndex(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TCustomDBGrid(Args.Obj).ValidFieldIndex(Args.Values[0]);\r\nend;\r\n\r\n{ property Read FieldCount: Integer }\r\n\r\nprocedure TCustomDBGrid_Read_FieldCount(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TCustomDBGrid(Args.Obj).FieldCount;\r\nend;\r\n\r\n{ property Read Fields[Integer]: TField }\r\n\r\nprocedure TCustomDBGrid_Read_Fields(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TCustomDBGrid(Args.Obj).Fields[Args.Values[0]]);\r\nend;\r\n\r\n{ property Read SelectedField: TField }\r\n\r\nprocedure TCustomDBGrid_Read_SelectedField(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TCustomDBGrid(Args.Obj).SelectedField);\r\nend;\r\n\r\n{ property Write SelectedField(Value: TField) }\r\n\r\nprocedure TCustomDBGrid_Write_SelectedField(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TCustomDBGrid(Args.Obj).SelectedField := V2O(Value) as TField;\r\nend;\r\n\r\n{ property Read SelectedIndex: Integer }\r\n\r\nprocedure TCustomDBGrid_Read_SelectedIndex(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TCustomDBGrid(Args.Obj).SelectedIndex;\r\nend;\r\n\r\n{ property Write SelectedIndex(Value: Integer) }\r\n\r\nprocedure TCustomDBGrid_Write_SelectedIndex(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TCustomDBGrid(Args.Obj).SelectedIndex := Value;\r\nend;\r\n\r\n{ TDBGrid }\r\n\r\n{ constructor Create(AOwner: TComponent) }\r\n\r\nprocedure TDBGrid_Create(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TDBGrid.Create(V2O(Args.Values[0]) as TComponent));\r\nend;\r\n\r\nprocedure RegisterJvInterpreterAdapter(JvInterpreterAdapter: TJvInterpreterAdapter);\r\nconst\r\n cDbGrids = 'DbGrids';\r\nbegin\r\n with JvInterpreterAdapter do\r\n begin\r\n { TColumnValue }\r\n AddConst(cDbGrids, 'cvColor', Ord(cvColor));\r\n AddConst(cDbGrids, 'cvWidth', Ord(cvWidth));\r\n AddConst(cDbGrids, 'cvFont', Ord(cvFont));\r\n AddConst(cDbGrids, 'cvAlignment', Ord(cvAlignment));\r\n AddConst(cDbGrids, 'cvReadOnly', Ord(cvReadOnly));\r\n AddConst(cDbGrids, 'cvTitleColor', Ord(cvTitleColor));\r\n AddConst(cDbGrids, 'cvTitleCaption', Ord(cvTitleCaption));\r\n AddConst(cDbGrids, 'cvTitleAlignment', Ord(cvTitleAlignment));\r\n AddConst(cDbGrids, 'cvTitleFont', Ord(cvTitleFont));\r\n AddConst(cDbGrids, 'cvImeMode', Ord(cvImeMode));\r\n AddConst(cDbGrids, 'cvImeName', Ord(cvImeName));\r\n { TColumnTitle }\r\n AddClass(cDbGrids, TColumnTitle, 'TColumnTitle');\r\n AddGet(TColumnTitle, 'Create', TColumnTitle_Create, 1, [varEmpty], varEmpty);\r\n AddGet(TColumnTitle, 'Assign', TColumnTitle_Assign, 1, [varEmpty], varEmpty);\r\n AddGet(TColumnTitle, 'DefaultAlignment', TColumnTitle_DefaultAlignment, 0, [varEmpty], varEmpty);\r\n AddGet(TColumnTitle, 'DefaultColor', TColumnTitle_DefaultColor, 0, [varEmpty], varEmpty);\r\n AddGet(TColumnTitle, 'DefaultFont', TColumnTitle_DefaultFont, 0, [varEmpty], varEmpty);\r\n AddGet(TColumnTitle, 'DefaultCaption', TColumnTitle_DefaultCaption, 0, [varEmpty], varEmpty);\r\n AddGet(TColumnTitle, 'RestoreDefaults', TColumnTitle_RestoreDefaults, 0, [varEmpty], varEmpty);\r\n AddGet(TColumnTitle, 'Alignment', TColumnTitle_Read_Alignment, 0, [varEmpty], varEmpty);\r\n AddSet(TColumnTitle, 'Alignment', TColumnTitle_Write_Alignment, 0, [varEmpty]);\r\n AddGet(TColumnTitle, 'Caption', TColumnTitle_Read_Caption, 0, [varEmpty], varEmpty);\r\n AddSet(TColumnTitle, 'Caption', TColumnTitle_Write_Caption, 0, [varEmpty]);\r\n AddGet(TColumnTitle, 'Color', TColumnTitle_Read_Color, 0, [varEmpty], varEmpty);\r\n AddSet(TColumnTitle, 'Color', TColumnTitle_Write_Color, 0, [varEmpty]);\r\n AddGet(TColumnTitle, 'Font', TColumnTitle_Read_Font, 0, [varEmpty], varEmpty);\r\n AddSet(TColumnTitle, 'Font', TColumnTitle_Write_Font, 0, [varEmpty]);\r\n { TColumnButtonStyle }\r\n AddConst(cDbGrids, 'cbsAuto', Ord(cbsAuto));\r\n AddConst(cDbGrids, 'cbsEllipsis', Ord(cbsEllipsis));\r\n AddConst(cDbGrids, 'cbsNone', Ord(cbsNone));\r\n { TColumn }\r\n AddClass(cDbGrids, TColumn, 'TColumn');\r\n AddGet(TColumn, 'Create', TColumn_Create, 1, [varEmpty], varEmpty);\r\n AddGet(TColumn, 'Assign', TColumn_Assign, 1, [varEmpty], varEmpty);\r\n AddGet(TColumn, 'DefaultAlignment', TColumn_DefaultAlignment, 0, [varEmpty], varEmpty);\r\n AddGet(TColumn, 'DefaultColor', TColumn_DefaultColor, 0, [varEmpty], varEmpty);\r\n AddGet(TColumn, 'DefaultFont', TColumn_DefaultFont, 0, [varEmpty], varEmpty);\r\n AddGet(TColumn, 'DefaultImeMode', TColumn_DefaultImeMode, 0, [varEmpty], varEmpty);\r\n AddGet(TColumn, 'DefaultImeName', TColumn_DefaultImeName, 0, [varEmpty], varEmpty);\r\n AddGet(TColumn, 'DefaultReadOnly', TColumn_DefaultReadOnly, 0, [varEmpty], varEmpty);\r\n AddGet(TColumn, 'DefaultWidth', TColumn_DefaultWidth, 0, [varEmpty], varEmpty);\r\n AddGet(TColumn, 'RestoreDefaults', TColumn_RestoreDefaults, 0, [varEmpty], varEmpty);\r\n AddGet(TColumn, 'Grid', TColumn_Read_Grid, 0, [varEmpty], varEmpty);\r\n AddGet(TColumn, 'AssignedValues', TColumn_Read_AssignedValues, 0, [varEmpty], varEmpty);\r\n AddGet(TColumn, 'Field', TColumn_Read_Field, 0, [varEmpty], varEmpty);\r\n AddSet(TColumn, 'Field', TColumn_Write_Field, 0, [varEmpty]);\r\n AddGet(TColumn, 'Alignment', TColumn_Read_Alignment, 0, [varEmpty], varEmpty);\r\n AddSet(TColumn, 'Alignment', TColumn_Write_Alignment, 0, [varEmpty]);\r\n AddGet(TColumn, 'ButtonStyle', TColumn_Read_ButtonStyle, 0, [varEmpty], varEmpty);\r\n AddSet(TColumn, 'ButtonStyle', TColumn_Write_ButtonStyle, 0, [varEmpty]);\r\n AddGet(TColumn, 'Color', TColumn_Read_Color, 0, [varEmpty], varEmpty);\r\n AddSet(TColumn, 'Color', TColumn_Write_Color, 0, [varEmpty]);\r\n AddGet(TColumn, 'DropDownRows', TColumn_Read_DropDownRows, 0, [varEmpty], varEmpty);\r\n AddSet(TColumn, 'DropDownRows', TColumn_Write_DropDownRows, 0, [varEmpty]);\r\n AddGet(TColumn, 'FieldName', TColumn_Read_FieldName, 0, [varEmpty], varEmpty);\r\n AddSet(TColumn, 'FieldName', TColumn_Write_FieldName, 0, [varEmpty]);\r\n AddGet(TColumn, 'Font', TColumn_Read_Font, 0, [varEmpty], varEmpty);\r\n AddSet(TColumn, 'Font', TColumn_Write_Font, 0, [varEmpty]);\r\n AddGet(TColumn, 'ImeMode', TColumn_Read_ImeMode, 0, [varEmpty], varEmpty);\r\n AddSet(TColumn, 'ImeMode', TColumn_Write_ImeMode, 0, [varEmpty]);\r\n AddGet(TColumn, 'ImeName', TColumn_Read_ImeName, 0, [varEmpty], varEmpty);\r\n AddSet(TColumn, 'ImeName', TColumn_Write_ImeName, 0, [varEmpty]);\r\n AddGet(TColumn, 'PickList', TColumn_Read_PickList, 0, [varEmpty], varEmpty);\r\n AddSet(TColumn, 'PickList', TColumn_Write_PickList, 0, [varEmpty]);\r\n AddGet(TColumn, 'PopupMenu', TColumn_Read_PopupMenu, 0, [varEmpty], varEmpty);\r\n AddSet(TColumn, 'PopupMenu', TColumn_Write_PopupMenu, 0, [varEmpty]);\r\n AddGet(TColumn, 'ReadOnly', TColumn_Read_ReadOnly, 0, [varEmpty], varEmpty);\r\n AddSet(TColumn, 'ReadOnly', TColumn_Write_ReadOnly, 0, [varEmpty]);\r\n AddGet(TColumn, 'Title', TColumn_Read_Title, 0, [varEmpty], varEmpty);\r\n AddSet(TColumn, 'Title', TColumn_Write_Title, 0, [varEmpty]);\r\n AddGet(TColumn, 'Width', TColumn_Read_Width, 0, [varEmpty], varEmpty);\r\n AddSet(TColumn, 'Width', TColumn_Write_Width, 0, [varEmpty]);\r\n { TDBGridColumnsState }\r\n AddConst(cDbGrids, 'csDefault', Ord(csDefault));\r\n AddConst(cDbGrids, 'csCustomized', Ord(csCustomized));\r\n { TDBGridColumns }\r\n AddClass(cDbGrids, TDBGridColumns, 'TDBGridColumns');\r\n AddGet(TDBGridColumns, 'Create', TDBGridColumns_Create, 2, [varEmpty, varEmpty], varEmpty);\r\n AddGet(TDBGridColumns, 'Add', TDBGridColumns_Add, 0, [varEmpty], varEmpty);\r\n AddGet(TDBGridColumns, 'LoadFromFile', TDBGridColumns_LoadFromFile, 1, [varEmpty], varEmpty);\r\n AddGet(TDBGridColumns, 'LoadFromStream', TDBGridColumns_LoadFromStream, 1, [varEmpty], varEmpty);\r\n AddGet(TDBGridColumns, 'RestoreDefaults', TDBGridColumns_RestoreDefaults, 0, [varEmpty], varEmpty);\r\n AddGet(TDBGridColumns, 'RebuildColumns', TDBGridColumns_RebuildColumns, 0, [varEmpty], varEmpty);\r\n AddGet(TDBGridColumns, 'SaveToFile', TDBGridColumns_SaveToFile, 1, [varEmpty], varEmpty);\r\n AddGet(TDBGridColumns, 'SaveToStream', TDBGridColumns_SaveToStream, 1, [varEmpty], varEmpty);\r\n AddGet(TDBGridColumns, 'State', TDBGridColumns_Read_State, 0, [varEmpty], varEmpty);\r\n AddSet(TDBGridColumns, 'State', TDBGridColumns_Write_State, 0, [varEmpty]);\r\n AddGet(TDBGridColumns, 'Grid', TDBGridColumns_Read_Grid, 0, [varEmpty], varEmpty);\r\n AddIGet(TDBGridColumns, 'Items', TDBGridColumns_Read_Items, 1, [varEmpty], varEmpty);\r\n AddISet(TDBGridColumns, 'Items', TDBGridColumns_Write_Items, 1, [varNull]);\r\n AddIDGet(TDBGridColumns, TDBGridColumns_Read_Items, 1, [varEmpty], varEmpty);\r\n AddIDSet(TDBGridColumns, TDBGridColumns_Write_Items, 1, [varNull]);\r\n { TBookmarkList }\r\n AddClass(cDbGrids, TBookmarkList, 'TBookmarkList');\r\n AddGet(TBookmarkList, 'Create', TBookmarkList_Create, 1, [varEmpty], varEmpty);\r\n AddGet(TBookmarkList, 'Clear', TBookmarkList_Clear, 0, [varEmpty], varEmpty);\r\n AddGet(TBookmarkList, 'Delete', TBookmarkList_Delete, 0, [varEmpty], varEmpty);\r\n AddGet(TBookmarkList, 'Find', TBookmarkList_Find, 2, [varEmpty, varByRef], varEmpty);\r\n AddGet(TBookmarkList, 'IndexOf', TBookmarkList_IndexOf, 1, [varEmpty], varEmpty);\r\n AddGet(TBookmarkList, 'Refresh', TBookmarkList_Refresh, 0, [varEmpty], varEmpty);\r\n AddGet(TBookmarkList, 'Count', TBookmarkList_Read_Count, 0, [varEmpty], varEmpty);\r\n AddGet(TBookmarkList, 'CurrentRowSelected', TBookmarkList_Read_CurrentRowSelected, 0, [varEmpty], varEmpty);\r\n AddSet(TBookmarkList, 'CurrentRowSelected', TBookmarkList_Write_CurrentRowSelected, 0, [varEmpty]);\r\n AddIGet(TBookmarkList, 'Items', TBookmarkList_Read_Items, 1, [varEmpty], varEmpty);\r\n AddIDGet(TBookmarkList, TBookmarkList_Read_Items, 1, [varEmpty], varEmpty);\r\n { TDBGridOption }\r\n AddConst(cDbGrids, 'dgEditing', Ord(dgEditing));\r\n AddConst(cDbGrids, 'dgAlwaysShowEditor', Ord(dgAlwaysShowEditor));\r\n AddConst(cDbGrids, 'dgTitles', Ord(dgTitles));\r\n AddConst(cDbGrids, 'dgIndicator', Ord(dgIndicator));\r\n AddConst(cDbGrids, 'dgColumnResize', Ord(dgColumnResize));\r\n AddConst(cDbGrids, 'dgColLines', Ord(dgColLines));\r\n AddConst(cDbGrids, 'dgRowLines', Ord(dgRowLines));\r\n AddConst(cDbGrids, 'dgTabs', Ord(dgTabs));\r\n AddConst(cDbGrids, 'dgRowSelect', Ord(dgRowSelect));\r\n AddConst(cDbGrids, 'dgAlwaysShowSelection', Ord(dgAlwaysShowSelection));\r\n AddConst(cDbGrids, 'dgConfirmDelete', Ord(dgConfirmDelete));\r\n AddConst(cDbGrids, 'dgCancelOnExit', Ord(dgCancelOnExit));\r\n AddConst(cDbGrids, 'dgMultiSelect', Ord(dgMultiSelect));\r\n { TCustomDBGrid }\r\n AddClass(cDbGrids, TCustomDBGrid, 'TCustomDBGrid');\r\n AddGet(TCustomDBGrid, 'DefaultDrawDataCell', TCustomDBGrid_DefaultDrawDataCell, 3, [varEmpty, varEmpty, varEmpty],\r\n varEmpty);\r\n AddGet(TCustomDBGrid, 'DefaultDrawColumnCell', TCustomDBGrid_DefaultDrawColumnCell, 4, [varEmpty, varEmpty,\r\n varEmpty, varEmpty], varEmpty);\r\n AddGet(TCustomDBGrid, 'ValidFieldIndex', TCustomDBGrid_ValidFieldIndex, 1, [varEmpty], varEmpty);\r\n AddGet(TCustomDBGrid, 'FieldCount', TCustomDBGrid_Read_FieldCount, 0, [varEmpty], varEmpty);\r\n AddIGet(TCustomDBGrid, 'Fields', TCustomDBGrid_Read_Fields, 1, [varEmpty], varEmpty);\r\n AddGet(TCustomDBGrid, 'SelectedField', TCustomDBGrid_Read_SelectedField, 0, [varEmpty], varEmpty);\r\n AddSet(TCustomDBGrid, 'SelectedField', TCustomDBGrid_Write_SelectedField, 0, [varEmpty]);\r\n AddGet(TCustomDBGrid, 'SelectedIndex', TCustomDBGrid_Read_SelectedIndex, 0, [varEmpty], varEmpty);\r\n AddSet(TCustomDBGrid, 'SelectedIndex', TCustomDBGrid_Write_SelectedIndex, 0, [varEmpty]);\r\n { TDBGrid }\r\n AddClass(cDbGrids, TDBGrid, 'TDBGrid');\r\n AddGet(TDBGrid, 'Create', TDBGrid_Create, 1, [varEmpty], varEmpty);\r\n end;\r\n RegisterClasses([TDBGrid]);\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvInterpreter_Dialogs.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvInterpreter_Dialogs.PAS, released on 2002-07-04.\r\n\r\nThe Initial Developers of the Original Code are: Andrei Prygounkov \r\nCopyright (c) 1999, 2002 Andrei Prygounkov\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nDescription : adapter unit - converts JvInterpreter calls to delphi calls\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvInterpreter_Dialogs.pas 13173 2011-11-19 12:43:58Z ahuser $\r\n\r\nunit JvInterpreter_Dialogs;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n JvInterpreter;\r\n\r\nprocedure RegisterJvInterpreterAdapter(JvInterpreterAdapter: TJvInterpreterAdapter);\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvInterpreter_Dialogs.pas $';\r\n Revision: '$Revision: 13173 $';\r\n Date: '$Date: 2011-11-19 13:43:58 +0100 (sam. 19 nov. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n Classes,\r\n JvInterpreter_Windows,\r\n Graphics, Controls, Dialogs;\r\n\r\n\r\n\r\n{ TCommonDialog }\r\n\r\n{ property Read Handle: HWnd }\r\n\r\nprocedure TCommonDialog_Read_Handle(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := NativeInt(TCommonDialog(Args.Obj).Handle);\r\nend;\r\n\r\n\r\n\r\n{ property Read Ctl3D: Boolean }\r\n\r\nprocedure TCommonDialog_Read_Ctl3D(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TCommonDialog(Args.Obj).Ctl3D;\r\nend;\r\n\r\n{ property Write Ctl3D(Value: Boolean) }\r\n\r\nprocedure TCommonDialog_Write_Ctl3D(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TCommonDialog(Args.Obj).Ctl3D := Value;\r\nend;\r\n\r\n\r\n\r\n{ property Read HelpContext: THelpContext }\r\n\r\nprocedure TCommonDialog_Read_HelpContext(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TCommonDialog(Args.Obj).HelpContext;\r\nend;\r\n\r\n{ property Write HelpContext(Value: THelpContext) }\r\n\r\nprocedure TCommonDialog_Write_HelpContext(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TCommonDialog(Args.Obj).HelpContext := Value;\r\nend;\r\n\r\n{ TOpenDialog }\r\n\r\n{ constructor Create(AOwner: TComponent) }\r\n\r\nprocedure TOpenDialog_Create(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TOpenDialog.Create(V2O(Args.Values[0]) as TComponent));\r\nend;\r\n\r\n{ function Execute: Boolean; }\r\n\r\nprocedure TOpenDialog_Execute(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TOpenDialog(Args.Obj).Execute;\r\nend;\r\n\r\n\r\n\r\n{ property Read FileEditStyle: TFileEditStyle }\r\n\r\nprocedure TOpenDialog_Read_FileEditStyle(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TOpenDialog(Args.Obj).FileEditStyle;\r\nend;\r\n\r\n{ property Write FileEditStyle(Value: TFileEditStyle) }\r\n\r\nprocedure TOpenDialog_Write_FileEditStyle(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TOpenDialog(Args.Obj).FileEditStyle := Value;\r\nend;\r\n\r\n\r\n\r\n{ property Read Files: TStrings }\r\n\r\nprocedure TOpenDialog_Read_Files(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TOpenDialog(Args.Obj).Files);\r\nend;\r\n\r\n{ property Read HistoryList: TStrings }\r\n\r\nprocedure TOpenDialog_Read_HistoryList(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TOpenDialog(Args.Obj).HistoryList);\r\nend;\r\n\r\n{ property Write HistoryList(Value: TStrings) }\r\n\r\nprocedure TOpenDialog_Write_HistoryList(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TOpenDialog(Args.Obj).HistoryList := V2O(Value) as TStrings;\r\nend;\r\n\r\n{ property Read DefaultExt: string }\r\n\r\nprocedure TOpenDialog_Read_DefaultExt(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TOpenDialog(Args.Obj).DefaultExt;\r\nend;\r\n\r\n{ property Write DefaultExt(Value: string) }\r\n\r\nprocedure TOpenDialog_Write_DefaultExt(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TOpenDialog(Args.Obj).DefaultExt := Value;\r\nend;\r\n\r\n{ property Read FileName: TFileName }\r\n\r\nprocedure TOpenDialog_Read_FileName(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TOpenDialog(Args.Obj).FileName;\r\nend;\r\n\r\n{ property Write FileName(Value: TFileName) }\r\n\r\nprocedure TOpenDialog_Write_FileName(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TOpenDialog(Args.Obj).FileName := Value;\r\nend;\r\n\r\n{ property Read Filter: string }\r\n\r\nprocedure TOpenDialog_Read_Filter(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TOpenDialog(Args.Obj).Filter;\r\nend;\r\n\r\n{ property Write Filter(Value: string) }\r\n\r\nprocedure TOpenDialog_Write_Filter(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TOpenDialog(Args.Obj).Filter := Value;\r\nend;\r\n\r\n{ property Read FilterIndex: Integer }\r\n\r\nprocedure TOpenDialog_Read_FilterIndex(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TOpenDialog(Args.Obj).FilterIndex;\r\nend;\r\n\r\n{ property Write FilterIndex(Value: Integer) }\r\n\r\nprocedure TOpenDialog_Write_FilterIndex(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TOpenDialog(Args.Obj).FilterIndex := Value;\r\nend;\r\n\r\n{ property Read InitialDir: string }\r\n\r\nprocedure TOpenDialog_Read_InitialDir(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TOpenDialog(Args.Obj).InitialDir;\r\nend;\r\n\r\n{ property Write InitialDir(Value: string) }\r\n\r\nprocedure TOpenDialog_Write_InitialDir(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TOpenDialog(Args.Obj).InitialDir := Value;\r\nend;\r\n\r\n{ property Read Options: TOpenOptions }\r\n\r\nprocedure TOpenDialog_Read_Options(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := S2V(Integer(TOpenDialog(Args.Obj).Options));\r\nend;\r\n\r\n{ property Write Options(Value: TOpenOptions) }\r\n\r\nprocedure TOpenDialog_Write_Options(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TOpenDialog(Args.Obj).Options := TOpenOptions(V2S(Value));\r\nend;\r\n\r\n{ property Read Title: string }\r\n\r\nprocedure TOpenDialog_Read_Title(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TOpenDialog(Args.Obj).Title;\r\nend;\r\n\r\n{ property Write Title(Value: string) }\r\n\r\nprocedure TOpenDialog_Write_Title(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TOpenDialog(Args.Obj).Title := Value;\r\nend;\r\n\r\n{ TSaveDialog }\r\n\r\n{ constructor Create(AOwner: TComponent) }\r\n\r\nprocedure TSaveDialog_Create(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TSaveDialog.Create(V2O(Args.Values[0]) as TComponent));\r\nend;\r\n\r\n{ function Execute: Boolean; }\r\n\r\nprocedure TSaveDialog_Execute(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TSaveDialog(Args.Obj).Execute;\r\nend;\r\n\r\n{ TColorDialog }\r\n\r\n{ constructor Create(AOwner: TComponent) }\r\n\r\nprocedure TColorDialog_Create(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TColorDialog.Create(V2O(Args.Values[0]) as TComponent));\r\nend;\r\n\r\n{ function Execute: Boolean; }\r\n\r\nprocedure TColorDialog_Execute(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TColorDialog(Args.Obj).Execute;\r\nend;\r\n\r\n{ property Read Color: TColor }\r\n\r\nprocedure TColorDialog_Read_Color(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TColorDialog(Args.Obj).Color;\r\nend;\r\n\r\n{ property Write Color(Value: TColor) }\r\n\r\nprocedure TColorDialog_Write_Color(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TColorDialog(Args.Obj).Color := Value;\r\nend;\r\n\r\n{ property Read CustomColors: TStrings }\r\n\r\nprocedure TColorDialog_Read_CustomColors(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TColorDialog(Args.Obj).CustomColors);\r\nend;\r\n\r\n{ property Write CustomColors(Value: TStrings) }\r\n\r\nprocedure TColorDialog_Write_CustomColors(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TColorDialog(Args.Obj).CustomColors := V2O(Value) as TStrings;\r\nend;\r\n\r\n\r\n\r\n{ property Read Options: TColorDialogOptions }\r\n\r\nprocedure TColorDialog_Read_Options(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := S2V(Byte(TColorDialog(Args.Obj).Options));\r\nend;\r\n\r\n{ property Write Options(Value: TColorDialogOptions) }\r\n\r\nprocedure TColorDialog_Write_Options(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TColorDialog(Args.Obj).Options := TColorDialogOptions(Byte(V2S(Value)));\r\nend;\r\n\r\n\r\n\r\n{ TFontDialog }\r\n\r\n{ constructor Create(AOwner: TComponent) }\r\n\r\nprocedure TFontDialog_Create(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TFontDialog.Create(V2O(Args.Values[0]) as TComponent));\r\nend;\r\n\r\n{ function Execute: Boolean; }\r\n\r\nprocedure TFontDialog_Execute(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TFontDialog(Args.Obj).Execute;\r\nend;\r\n\r\n{ property Read Font: TFont }\r\n\r\nprocedure TFontDialog_Read_Font(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TFontDialog(Args.Obj).Font);\r\nend;\r\n\r\n{ property Write Font(Value: TFont) }\r\n\r\nprocedure TFontDialog_Write_Font(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TFontDialog(Args.Obj).Font := V2O(Value) as TFont;\r\nend;\r\n\r\n\r\n\r\n{ property Read Device: TFontDialogDevice }\r\n\r\nprocedure TFontDialog_Read_Device(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TFontDialog(Args.Obj).Device;\r\nend;\r\n\r\n{ property Write Device(Value: TFontDialogDevice) }\r\n\r\nprocedure TFontDialog_Write_Device(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TFontDialog(Args.Obj).Device := Value;\r\nend;\r\n\r\n{ property Read MinFontSize: Integer }\r\n\r\nprocedure TFontDialog_Read_MinFontSize(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TFontDialog(Args.Obj).MinFontSize;\r\nend;\r\n\r\n{ property Write MinFontSize(Value: Integer) }\r\n\r\nprocedure TFontDialog_Write_MinFontSize(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TFontDialog(Args.Obj).MinFontSize := Value;\r\nend;\r\n\r\n{ property Read MaxFontSize: Integer }\r\n\r\nprocedure TFontDialog_Read_MaxFontSize(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TFontDialog(Args.Obj).MaxFontSize;\r\nend;\r\n\r\n{ property Write MaxFontSize(Value: Integer) }\r\n\r\nprocedure TFontDialog_Write_MaxFontSize(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TFontDialog(Args.Obj).MaxFontSize := Value;\r\nend;\r\n\r\n{ property Read Options: TFontDialogOptions }\r\n\r\nprocedure TFontDialog_Read_Options(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := S2V(Word(TFontDialog(Args.Obj).Options));\r\nend;\r\n\r\n{ property Write Options(Value: TFontDialogOptions) }\r\n\r\nprocedure TFontDialog_Write_Options(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TFontDialog(Args.Obj).Options := TFontDialogOptions(Word(V2S(Value)));\r\nend;\r\n\r\n\r\n\r\n\r\n\r\n{ TPrinterSetupDialog }\r\n\r\n{ constructor Create(AOwner: TComponent) }\r\n\r\nprocedure TPrinterSetupDialog_Create(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TPrinterSetupDialog.Create(V2O(Args.Values[0]) as TComponent));\r\nend;\r\n\r\n{ function Execute: Boolean; }\r\n\r\nprocedure TPrinterSetupDialog_Execute(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TPrinterSetupDialog(Args.Obj).Execute;\r\nend;\r\n\r\n{ TPrintDialog }\r\n\r\n{ constructor Create(AOwner: TComponent) }\r\n\r\nprocedure TPrintDialog_Create(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TPrintDialog.Create(V2O(Args.Values[0]) as TComponent));\r\nend;\r\n\r\n{ function Execute: Boolean; }\r\n\r\nprocedure TPrintDialog_Execute(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TPrintDialog(Args.Obj).Execute;\r\nend;\r\n\r\n{ property Read Collate: Boolean }\r\n\r\nprocedure TPrintDialog_Read_Collate(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TPrintDialog(Args.Obj).Collate;\r\nend;\r\n\r\n{ property Write Collate(Value: Boolean) }\r\n\r\nprocedure TPrintDialog_Write_Collate(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TPrintDialog(Args.Obj).Collate := Value;\r\nend;\r\n\r\n{ property Read Copies: Integer }\r\n\r\nprocedure TPrintDialog_Read_Copies(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TPrintDialog(Args.Obj).Copies;\r\nend;\r\n\r\n{ property Write Copies(Value: Integer) }\r\n\r\nprocedure TPrintDialog_Write_Copies(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TPrintDialog(Args.Obj).Copies := Value;\r\nend;\r\n\r\n{ property Read FromPage: Integer }\r\n\r\nprocedure TPrintDialog_Read_FromPage(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TPrintDialog(Args.Obj).FromPage;\r\nend;\r\n\r\n{ property Write FromPage(Value: Integer) }\r\n\r\nprocedure TPrintDialog_Write_FromPage(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TPrintDialog(Args.Obj).FromPage := Value;\r\nend;\r\n\r\n{ property Read MinPage: Integer }\r\n\r\nprocedure TPrintDialog_Read_MinPage(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TPrintDialog(Args.Obj).MinPage;\r\nend;\r\n\r\n{ property Write MinPage(Value: Integer) }\r\n\r\nprocedure TPrintDialog_Write_MinPage(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TPrintDialog(Args.Obj).MinPage := Value;\r\nend;\r\n\r\n{ property Read MaxPage: Integer }\r\n\r\nprocedure TPrintDialog_Read_MaxPage(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TPrintDialog(Args.Obj).MaxPage;\r\nend;\r\n\r\n{ property Write MaxPage(Value: Integer) }\r\n\r\nprocedure TPrintDialog_Write_MaxPage(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TPrintDialog(Args.Obj).MaxPage := Value;\r\nend;\r\n\r\n{ property Read Options: TPrintDialogOptions }\r\n\r\nprocedure TPrintDialog_Read_Options(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := S2V(Byte(TPrintDialog(Args.Obj).Options));\r\nend;\r\n\r\n{ property Write Options(Value: TPrintDialogOptions) }\r\n\r\nprocedure TPrintDialog_Write_Options(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TPrintDialog(Args.Obj).Options := TPrintDialogOptions(Byte(V2S(Value)));\r\nend;\r\n\r\n{ property Read PrintToFile: Boolean }\r\n\r\nprocedure TPrintDialog_Read_PrintToFile(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TPrintDialog(Args.Obj).PrintToFile;\r\nend;\r\n\r\n{ property Write PrintToFile(Value: Boolean) }\r\n\r\nprocedure TPrintDialog_Write_PrintToFile(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TPrintDialog(Args.Obj).PrintToFile := Value;\r\nend;\r\n\r\n{ property Read PrintRange: TPrintRange }\r\n\r\nprocedure TPrintDialog_Read_PrintRange(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TPrintDialog(Args.Obj).PrintRange;\r\nend;\r\n\r\n{ property Write PrintRange(Value: TPrintRange) }\r\n\r\nprocedure TPrintDialog_Write_PrintRange(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TPrintDialog(Args.Obj).PrintRange := Value;\r\nend;\r\n\r\n{ property Read ToPage: Integer }\r\n\r\nprocedure TPrintDialog_Read_ToPage(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TPrintDialog(Args.Obj).ToPage;\r\nend;\r\n\r\n{ property Write ToPage(Value: Integer) }\r\n\r\nprocedure TPrintDialog_Write_ToPage(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TPrintDialog(Args.Obj).ToPage := Value;\r\nend;\r\n\r\n\r\n\r\n{ TFindDialog }\r\n\r\n{ constructor Create(AOwner: TComponent) }\r\n\r\nprocedure TFindDialog_Create(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TFindDialog.Create(V2O(Args.Values[0]) as TComponent));\r\nend;\r\n\r\n{ procedure CloseDialog; }\r\n\r\n\r\nprocedure TFindDialog_CloseDialog(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TFindDialog(Args.Obj).CloseDialog;\r\nend;\r\n\r\n\r\n{ function Execute: Boolean; }\r\n\r\nprocedure TFindDialog_Execute(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TFindDialog(Args.Obj).Execute;\r\nend;\r\n\r\n\r\n\r\n{ property Read Left: Integer }\r\n\r\nprocedure TFindDialog_Read_Left(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TFindDialog(Args.Obj).Left;\r\nend;\r\n\r\n{ property Write Left(Value: Integer) }\r\n\r\nprocedure TFindDialog_Write_Left(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TFindDialog(Args.Obj).Left := Value;\r\nend;\r\n\r\n\r\n\r\n{ property Read Position: TPoint }\r\n\r\nprocedure TFindDialog_Read_Position(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := Point2Var(TFindDialog(Args.Obj).Position);\r\nend;\r\n\r\n{ property Write Position(Value: TPoint) }\r\n\r\nprocedure TFindDialog_Write_Position(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TFindDialog(Args.Obj).Position := Var2Point(Value);\r\nend;\r\n\r\n\r\n\r\n{ property Read Top: Integer }\r\n\r\nprocedure TFindDialog_Read_Top(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TFindDialog(Args.Obj).Top;\r\nend;\r\n\r\n{ property Write Top(Value: Integer) }\r\n\r\nprocedure TFindDialog_Write_Top(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TFindDialog(Args.Obj).Top := Value;\r\nend;\r\n\r\n\r\n\r\n{ property Read FindText: string }\r\n\r\nprocedure TFindDialog_Read_FindText(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TFindDialog(Args.Obj).FindText;\r\nend;\r\n\r\n{ property Write FindText(Value: string) }\r\n\r\nprocedure TFindDialog_Write_FindText(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TFindDialog(Args.Obj).FindText := Value;\r\nend;\r\n\r\n{ property Read Options: TFindOptions }\r\n\r\nprocedure TFindDialog_Read_Options(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := S2V(Word(TFindDialog(Args.Obj).Options));\r\nend;\r\n\r\n{ property Write Options(Value: TFindOptions) }\r\n\r\nprocedure TFindDialog_Write_Options(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TFindDialog(Args.Obj).Options := TFindOptions(Word(V2S(Value)));\r\nend;\r\n\r\n{ TReplaceDialog }\r\n\r\n{ constructor Create(AOwner: TComponent) }\r\n\r\nprocedure TReplaceDialog_Create(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TReplaceDialog.Create(V2O(Args.Values[0]) as TComponent));\r\nend;\r\n\r\n{ property Read ReplaceText: string }\r\n\r\nprocedure TReplaceDialog_Read_ReplaceText(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TReplaceDialog(Args.Obj).ReplaceText;\r\nend;\r\n\r\n{ property Write ReplaceText(Value: string) }\r\n\r\nprocedure TReplaceDialog_Write_ReplaceText(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TReplaceDialog(Args.Obj).ReplaceText := Value;\r\nend;\r\n\r\n{ function CreateMessageDialog(const Msg: string; DlgType: TMsgDlgType; Buttons: TMsgDlgButtons): TForm; }\r\n\r\n\r\nprocedure JvInterpreter_CreateMessageDialog(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(CreateMessageDialog(Args.Values[0], Args.Values[1], TMsgDlgButtons(Word(V2S(Args.Values[2])))));\r\nend;\r\n\r\n\r\n{ function MessageDlg(const Msg: string; DlgType: TMsgDlgType; Buttons: TMsgDlgButtons; HelpCtx: Longint): Integer; }\r\n\r\nprocedure JvInterpreter_MessageDlg(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := MessageDlg(Args.Values[0], Args.Values[1], TMsgDlgButtons(Word(V2S(Args.Values[2]))), Args.Values[3]);\r\nend;\r\n\r\n{ function MessageDlgPos(const Msg: string; DlgType: TMsgDlgType; Buttons: TMsgDlgButtons; HelpCtx: Longint; X, Y: Integer): Integer; }\r\n\r\nprocedure JvInterpreter_MessageDlgPos(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := MessageDlgPos(Args.Values[0], Args.Values[1], TMsgDlgButtons(Word(V2S(Args.Values[2]))), Args.Values[3],\r\n Args.Values[4], Args.Values[5]);\r\nend;\r\n\r\n{ function MessageDlgPosHelp(const Msg: string; DlgType: TMsgDlgType; Buttons: TMsgDlgButtons; HelpCtx: Longint; X, Y: Integer; const HelpFileName: string): Integer; }\r\n\r\n\r\nprocedure JvInterpreter_MessageDlgPosHelp(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := MessageDlgPosHelp(Args.Values[0], Args.Values[1], TMsgDlgButtons(Word(V2S(Args.Values[2]))), Args.Values[3],\r\n Args.Values[4], Args.Values[5], Args.Values[6]);\r\nend;\r\n\r\n\r\n{ procedure ShowMessage(const Msg: string); }\r\n\r\nprocedure JvInterpreter_ShowMessage(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n ShowMessage(Args.Values[0]);\r\nend;\r\n\r\n{ procedure ShowMessageFmt(const Msg: string; Params: array of const); }\r\n\r\nprocedure JvInterpreter_ShowMessageFmt(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Args.OpenArray(1);\r\n ShowMessageFmt(Args.Values[0], Slice(Args.OA^, Args.OAS));\r\nend;\r\n\r\n{ procedure ShowMessagePos(const Msg: string; X, Y: Integer); }\r\n\r\nprocedure JvInterpreter_ShowMessagePos(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n ShowMessagePos(Args.Values[0], Args.Values[1], Args.Values[2]);\r\nend;\r\n\r\n{ function InputBox(const ACaption, APrompt, ADefault: string): string; }\r\n\r\nprocedure JvInterpreter_InputBox(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := InputBox(Args.Values[0], Args.Values[1], Args.Values[2]);\r\nend;\r\n\r\n{ function InputQuery(const ACaption, APrompt: string; var Value: string): Boolean; }\r\n\r\nprocedure JvInterpreter_InputQuery(var Value: Variant; Args: TJvInterpreterArgs);\r\n\r\nbegin\r\n Value := InputQuery(Args.Values[0], Args.Values[1], string(TVarData(Args.Values[2]).vString));\r\nend;\r\n\r\nprocedure RegisterJvInterpreterAdapter(JvInterpreterAdapter: TJvInterpreterAdapter);\r\nconst\r\n cDialogs = 'Dialogs';\r\nbegin\r\n with JvInterpreterAdapter do\r\n begin\r\n { TCommonDialog }\r\n AddClass(cDialogs, TCommonDialog, 'TCommonDialog');\r\n AddGet(TCommonDialog, 'Handle', TCommonDialog_Read_Handle, 0, [varEmpty], varEmpty);\r\n AddGet(TCommonDialog, 'Ctl3D', TCommonDialog_Read_Ctl3D, 0, [varEmpty], varEmpty);\r\n AddSet(TCommonDialog, 'Ctl3D', TCommonDialog_Write_Ctl3D, 0, [varEmpty]);\r\n AddGet(TCommonDialog, 'HelpContext', TCommonDialog_Read_HelpContext, 0, [varEmpty], varEmpty);\r\n AddSet(TCommonDialog, 'HelpContext', TCommonDialog_Write_HelpContext, 0, [varEmpty]);\r\n { TOpenOption }\r\n AddConst(cDialogs, 'ofReadOnly', Ord(ofReadOnly));\r\n AddConst(cDialogs, 'ofOverwritePrompt', Ord(ofOverwritePrompt));\r\n AddConst(cDialogs, 'ofHideReadOnly', Ord(ofHideReadOnly));\r\n AddConst(cDialogs, 'ofNoChangeDir', Ord(ofNoChangeDir));\r\n AddConst(cDialogs, 'ofShowHelp', Ord(ofShowHelp));\r\n AddConst(cDialogs, 'ofNoValidate', Ord(ofNoValidate));\r\n AddConst(cDialogs, 'ofAllowMultiSelect', Ord(ofAllowMultiSelect));\r\n AddConst(cDialogs, 'ofExtensionDifferent', Ord(ofExtensionDifferent));\r\n AddConst(cDialogs, 'ofPathMustExist', Ord(ofPathMustExist));\r\n AddConst(cDialogs, 'ofFileMustExist', Ord(ofFileMustExist));\r\n AddConst(cDialogs, 'ofCreatePrompt', Ord(ofCreatePrompt));\r\n AddConst(cDialogs, 'ofShareAware', Ord(ofShareAware));\r\n AddConst(cDialogs, 'ofNoReadOnlyReturn', Ord(ofNoReadOnlyReturn));\r\n AddConst(cDialogs, 'ofNoTestFileCreate', Ord(ofNoTestFileCreate));\r\n AddConst(cDialogs, 'ofNoNetworkButton', Ord(ofNoNetworkButton));\r\n AddConst(cDialogs, 'ofNoLongNames', Ord(ofNoLongNames));\r\n AddConst(cDialogs, 'ofOldStyleDialog', Ord(ofOldStyleDialog));\r\n AddConst(cDialogs, 'ofNoDereferenceLinks', Ord(ofNoDereferenceLinks));\r\n { TFileEditStyle }\r\n AddConst(cDialogs, 'fsEdit', Ord(fsEdit));\r\n AddConst(cDialogs, 'fsComboBox', Ord(fsComboBox));\r\n { TOpenDialog }\r\n AddClass(cDialogs, TOpenDialog, 'TOpenDialog');\r\n AddGet(TOpenDialog, 'Create', TOpenDialog_Create, 1, [varEmpty], varEmpty);\r\n AddGet(TOpenDialog, 'Execute', TOpenDialog_Execute, 0, [varEmpty], varEmpty);\r\n AddGet(TOpenDialog, 'FileEditStyle', TOpenDialog_Read_FileEditStyle, 0, [varEmpty], varEmpty);\r\n AddSet(TOpenDialog, 'FileEditStyle', TOpenDialog_Write_FileEditStyle, 0, [varEmpty]);\r\n AddGet(TOpenDialog, 'Files', TOpenDialog_Read_Files, 0, [varEmpty], varEmpty);\r\n AddGet(TOpenDialog, 'HistoryList', TOpenDialog_Read_HistoryList, 0, [varEmpty], varEmpty);\r\n AddSet(TOpenDialog, 'HistoryList', TOpenDialog_Write_HistoryList, 0, [varEmpty]);\r\n AddGet(TOpenDialog, 'DefaultExt', TOpenDialog_Read_DefaultExt, 0, [varEmpty], varEmpty);\r\n AddSet(TOpenDialog, 'DefaultExt', TOpenDialog_Write_DefaultExt, 0, [varEmpty]);\r\n AddGet(TOpenDialog, 'FileName', TOpenDialog_Read_FileName, 0, [varEmpty], varEmpty);\r\n AddSet(TOpenDialog, 'FileName', TOpenDialog_Write_FileName, 0, [varEmpty]);\r\n AddGet(TOpenDialog, 'Filter', TOpenDialog_Read_Filter, 0, [varEmpty], varEmpty);\r\n AddSet(TOpenDialog, 'Filter', TOpenDialog_Write_Filter, 0, [varEmpty]);\r\n AddGet(TOpenDialog, 'FilterIndex', TOpenDialog_Read_FilterIndex, 0, [varEmpty], varEmpty);\r\n AddSet(TOpenDialog, 'FilterIndex', TOpenDialog_Write_FilterIndex, 0, [varEmpty]);\r\n AddGet(TOpenDialog, 'InitialDir', TOpenDialog_Read_InitialDir, 0, [varEmpty], varEmpty);\r\n AddSet(TOpenDialog, 'InitialDir', TOpenDialog_Write_InitialDir, 0, [varEmpty]);\r\n AddGet(TOpenDialog, 'Options', TOpenDialog_Read_Options, 0, [varEmpty], varEmpty);\r\n AddSet(TOpenDialog, 'Options', TOpenDialog_Write_Options, 0, [varEmpty]);\r\n AddGet(TOpenDialog, 'Title', TOpenDialog_Read_Title, 0, [varEmpty], varEmpty);\r\n AddSet(TOpenDialog, 'Title', TOpenDialog_Write_Title, 0, [varEmpty]);\r\n { TSaveDialog }\r\n AddClass(cDialogs, TSaveDialog, 'TSaveDialog');\r\n AddGet(TSaveDialog, 'Create', TSaveDialog_Create, 1, [varEmpty], varEmpty);\r\n AddGet(TSaveDialog, 'Execute', TSaveDialog_Execute, 0, [varEmpty], varEmpty);\r\n { TColorDialogOption }\r\n AddConst(cDialogs, 'cdFullOpen', Ord(cdFullOpen));\r\n AddConst(cDialogs, 'cdPreventFullOpen', Ord(cdPreventFullOpen));\r\n AddConst(cDialogs, 'cdShowHelp', Ord(cdShowHelp));\r\n AddConst(cDialogs, 'cdSolidColor', Ord(cdSolidColor));\r\n AddConst(cDialogs, 'cdAnyColor', Ord(cdAnyColor));\r\n { TColorDialog }\r\n AddClass(cDialogs, TColorDialog, 'TColorDialog');\r\n AddGet(TColorDialog, 'Create', TColorDialog_Create, 1, [varEmpty], varEmpty);\r\n AddGet(TColorDialog, 'Execute', TColorDialog_Execute, 0, [varEmpty], varEmpty);\r\n AddGet(TColorDialog, 'Color', TColorDialog_Read_Color, 0, [varEmpty], varEmpty);\r\n AddSet(TColorDialog, 'Color', TColorDialog_Write_Color, 0, [varEmpty]);\r\n AddGet(TColorDialog, 'CustomColors', TColorDialog_Read_CustomColors, 0, [varEmpty], varEmpty);\r\n AddSet(TColorDialog, 'CustomColors', TColorDialog_Write_CustomColors, 0, [varEmpty]);\r\n AddGet(TColorDialog, 'Options', TColorDialog_Read_Options, 0, [varEmpty], varEmpty);\r\n AddSet(TColorDialog, 'Options', TColorDialog_Write_Options, 0, [varEmpty]);\r\n { TFontDialogOption }\r\n AddConst(cDialogs, 'fdAnsiOnly', Ord(fdAnsiOnly));\r\n AddConst(cDialogs, 'fdTrueTypeOnly', Ord(fdTrueTypeOnly));\r\n AddConst(cDialogs, 'fdEffects', Ord(fdEffects));\r\n AddConst(cDialogs, 'fdFixedPitchOnly', Ord(fdFixedPitchOnly));\r\n AddConst(cDialogs, 'fdForceFontExist', Ord(fdForceFontExist));\r\n AddConst(cDialogs, 'fdNoFaceSel', Ord(fdNoFaceSel));\r\n AddConst(cDialogs, 'fdNoOEMFonts', Ord(fdNoOEMFonts));\r\n AddConst(cDialogs, 'fdNoSimulations', Ord(fdNoSimulations));\r\n AddConst(cDialogs, 'fdNoSizeSel', Ord(fdNoSizeSel));\r\n AddConst(cDialogs, 'fdNoStyleSel', Ord(fdNoStyleSel));\r\n AddConst(cDialogs, 'fdNoVectorFonts', Ord(fdNoVectorFonts));\r\n AddConst(cDialogs, 'fdShowHelp', Ord(fdShowHelp));\r\n AddConst(cDialogs, 'fdWysiwyg', Ord(fdWysiwyg));\r\n AddConst(cDialogs, 'fdLimitSize', Ord(fdLimitSize));\r\n AddConst(cDialogs, 'fdScalableOnly', Ord(fdScalableOnly));\r\n AddConst(cDialogs, 'fdApplyButton', Ord(fdApplyButton));\r\n { TFontDialogDevice }\r\n AddConst(cDialogs, 'fdScreen', Ord(fdScreen));\r\n AddConst(cDialogs, 'fdPrinter', Ord(fdPrinter));\r\n AddConst(cDialogs, 'fdBoth', Ord(fdBoth));\r\n { TFontDialog }\r\n AddClass(cDialogs, TFontDialog, 'TFontDialog');\r\n AddGet(TFontDialog, 'Create', TFontDialog_Create, 1, [varEmpty], varEmpty);\r\n AddGet(TFontDialog, 'Execute', TFontDialog_Execute, 0, [varEmpty], varEmpty);\r\n AddGet(TFontDialog, 'Font', TFontDialog_Read_Font, 0, [varEmpty], varEmpty);\r\n AddSet(TFontDialog, 'Font', TFontDialog_Write_Font, 0, [varEmpty]);\r\n AddGet(TFontDialog, 'Device', TFontDialog_Read_Device, 0, [varEmpty], varEmpty);\r\n AddSet(TFontDialog, 'Device', TFontDialog_Write_Device, 0, [varEmpty]);\r\n AddGet(TFontDialog, 'MinFontSize', TFontDialog_Read_MinFontSize, 0, [varEmpty], varEmpty);\r\n AddSet(TFontDialog, 'MinFontSize', TFontDialog_Write_MinFontSize, 0, [varEmpty]);\r\n AddGet(TFontDialog, 'MaxFontSize', TFontDialog_Read_MaxFontSize, 0, [varEmpty], varEmpty);\r\n AddSet(TFontDialog, 'MaxFontSize', TFontDialog_Write_MaxFontSize, 0, [varEmpty]);\r\n AddGet(TFontDialog, 'Options', TFontDialog_Read_Options, 0, [varEmpty], varEmpty);\r\n AddSet(TFontDialog, 'Options', TFontDialog_Write_Options, 0, [varEmpty]);\r\n { TPrinterSetupDialog }\r\n AddClass(cDialogs, TPrinterSetupDialog, 'TPrinterSetupDialog');\r\n AddGet(TPrinterSetupDialog, 'Create', TPrinterSetupDialog_Create, 1, [varEmpty], varEmpty);\r\n AddGet(TPrinterSetupDialog, 'Execute', TPrinterSetupDialog_Execute, 0, [varEmpty], varEmpty);\r\n { TPrintRange }\r\n AddConst(cDialogs, 'prAllPages', Ord(prAllPages));\r\n AddConst(cDialogs, 'prSelection', Ord(prSelection));\r\n AddConst(cDialogs, 'prPageNums', Ord(prPageNums));\r\n { TPrintDialogOption }\r\n AddConst(cDialogs, 'poPrintToFile', Ord(poPrintToFile));\r\n AddConst(cDialogs, 'poPageNums', Ord(poPageNums));\r\n AddConst(cDialogs, 'poSelection', Ord(poSelection));\r\n AddConst(cDialogs, 'poWarning', Ord(poWarning));\r\n AddConst(cDialogs, 'poHelp', Ord(poHelp));\r\n AddConst(cDialogs, 'poDisablePrintToFile', Ord(poDisablePrintToFile));\r\n { TPrintDialog }\r\n AddClass(cDialogs, TPrintDialog, 'TPrintDialog');\r\n AddGet(TPrintDialog, 'Create', TPrintDialog_Create, 1, [varEmpty], varEmpty);\r\n AddGet(TPrintDialog, 'Execute', TPrintDialog_Execute, 0, [varEmpty], varEmpty);\r\n AddGet(TPrintDialog, 'Collate', TPrintDialog_Read_Collate, 0, [varEmpty], varEmpty);\r\n AddSet(TPrintDialog, 'Collate', TPrintDialog_Write_Collate, 0, [varEmpty]);\r\n AddGet(TPrintDialog, 'Copies', TPrintDialog_Read_Copies, 0, [varEmpty], varEmpty);\r\n AddSet(TPrintDialog, 'Copies', TPrintDialog_Write_Copies, 0, [varEmpty]);\r\n AddGet(TPrintDialog, 'FromPage', TPrintDialog_Read_FromPage, 0, [varEmpty], varEmpty);\r\n AddSet(TPrintDialog, 'FromPage', TPrintDialog_Write_FromPage, 0, [varEmpty]);\r\n AddGet(TPrintDialog, 'MinPage', TPrintDialog_Read_MinPage, 0, [varEmpty], varEmpty);\r\n AddSet(TPrintDialog, 'MinPage', TPrintDialog_Write_MinPage, 0, [varEmpty]);\r\n AddGet(TPrintDialog, 'MaxPage', TPrintDialog_Read_MaxPage, 0, [varEmpty], varEmpty);\r\n AddSet(TPrintDialog, 'MaxPage', TPrintDialog_Write_MaxPage, 0, [varEmpty]);\r\n AddGet(TPrintDialog, 'Options', TPrintDialog_Read_Options, 0, [varEmpty], varEmpty);\r\n AddSet(TPrintDialog, 'Options', TPrintDialog_Write_Options, 0, [varEmpty]);\r\n AddGet(TPrintDialog, 'PrintToFile', TPrintDialog_Read_PrintToFile, 0, [varEmpty], varEmpty);\r\n AddSet(TPrintDialog, 'PrintToFile', TPrintDialog_Write_PrintToFile, 0, [varEmpty]);\r\n AddGet(TPrintDialog, 'PrintRange', TPrintDialog_Read_PrintRange, 0, [varEmpty], varEmpty);\r\n AddSet(TPrintDialog, 'PrintRange', TPrintDialog_Write_PrintRange, 0, [varEmpty]);\r\n AddGet(TPrintDialog, 'ToPage', TPrintDialog_Read_ToPage, 0, [varEmpty], varEmpty);\r\n AddSet(TPrintDialog, 'ToPage', TPrintDialog_Write_ToPage, 0, [varEmpty]);\r\n { TFindOption }\r\n AddConst(cDialogs, 'frDown', Ord(frDown));\r\n AddConst(cDialogs, 'frFindNext', Ord(frFindNext));\r\n AddConst(cDialogs, 'frHideMatchCase', Ord(frHideMatchCase));\r\n AddConst(cDialogs, 'frHideWholeWord', Ord(frHideWholeWord));\r\n AddConst(cDialogs, 'frHideUpDown', Ord(frHideUpDown));\r\n AddConst(cDialogs, 'frMatchCase', Ord(frMatchCase));\r\n AddConst(cDialogs, 'frDisableMatchCase', Ord(frDisableMatchCase));\r\n AddConst(cDialogs, 'frDisableUpDown', Ord(frDisableUpDown));\r\n AddConst(cDialogs, 'frDisableWholeWord', Ord(frDisableWholeWord));\r\n AddConst(cDialogs, 'frReplace', Ord(frReplace));\r\n AddConst(cDialogs, 'frReplaceAll', Ord(frReplaceAll));\r\n AddConst(cDialogs, 'frWholeWord', Ord(frWholeWord));\r\n AddConst(cDialogs, 'frShowHelp', Ord(frShowHelp));\r\n { TFindDialog }\r\n AddClass(cDialogs, TFindDialog, 'TFindDialog');\r\n AddGet(TFindDialog, 'Create', TFindDialog_Create, 1, [varEmpty], varEmpty);\r\n AddGet(TFindDialog, 'CloseDialog', TFindDialog_CloseDialog, 0, [varEmpty], varEmpty);\r\n AddGet(TFindDialog, 'Execute', TFindDialog_Execute, 0, [varEmpty], varEmpty);\r\n AddGet(TFindDialog, 'Left', TFindDialog_Read_Left, 0, [varEmpty], varEmpty);\r\n AddSet(TFindDialog, 'Left', TFindDialog_Write_Left, 0, [varEmpty]);\r\n AddGet(TFindDialog, 'Position', TFindDialog_Read_Position, 0, [varEmpty], varEmpty);\r\n AddSet(TFindDialog, 'Position', TFindDialog_Write_Position, 0, [varEmpty]);\r\n AddGet(TFindDialog, 'Top', TFindDialog_Read_Top, 0, [varEmpty], varEmpty);\r\n AddSet(TFindDialog, 'Top', TFindDialog_Write_Top, 0, [varEmpty]);\r\n AddGet(TFindDialog, 'FindText', TFindDialog_Read_FindText, 0, [varEmpty], varEmpty);\r\n AddSet(TFindDialog, 'FindText', TFindDialog_Write_FindText, 0, [varEmpty]);\r\n AddGet(TFindDialog, 'Options', TFindDialog_Read_Options, 0, [varEmpty], varEmpty);\r\n AddSet(TFindDialog, 'Options', TFindDialog_Write_Options, 0, [varEmpty]);\r\n { TReplaceDialog }\r\n AddClass(cDialogs, TReplaceDialog, 'TReplaceDialog');\r\n AddGet(TReplaceDialog, 'Create', TReplaceDialog_Create, 1, [varEmpty], varEmpty);\r\n AddGet(TReplaceDialog, 'ReplaceText', TReplaceDialog_Read_ReplaceText, 0, [varEmpty], varEmpty);\r\n AddSet(TReplaceDialog, 'ReplaceText', TReplaceDialog_Write_ReplaceText, 0, [varEmpty]);\r\n { TMsgDlgType }\r\n AddConst(cDialogs, 'mtWarning', Ord(mtWarning));\r\n AddConst(cDialogs, 'mtError', Ord(mtError));\r\n AddConst(cDialogs, 'mtInformation', Ord(mtInformation));\r\n AddConst(cDialogs, 'mtConfirmation', Ord(mtConfirmation));\r\n AddConst(cDialogs, 'mtCustom', Ord(mtCustom));\r\n { TMsgDlgBtn }\r\n AddConst(cDialogs, 'mbYes', Ord(mbYes));\r\n AddConst(cDialogs, 'mbNo', Ord(mbNo));\r\n AddConst(cDialogs, 'mbOK', Ord(mbOK));\r\n AddConst(cDialogs, 'mbCancel', Ord(mbCancel));\r\n AddConst(cDialogs, 'mbAbort', Ord(mbAbort));\r\n AddConst(cDialogs, 'mbRetry', Ord(mbRetry));\r\n AddConst(cDialogs, 'mbIgnore', Ord(mbIgnore));\r\n AddConst(cDialogs, 'mbAll', Ord(mbAll));\r\n AddConst(cDialogs, 'mbNoToAll', Ord(mbNoToAll));\r\n AddConst(cDialogs, 'mbYesToAll', Ord(mbYesToAll));\r\n AddConst(cDialogs, 'mbHelp', Ord(mbHelp));\r\n AddConst(cDialogs, 'mrNone', Ord(mrNone));\r\n AddConst(cDialogs, 'mrOk', Ord(mrOk));\r\n AddConst(cDialogs, 'mrCancel', Ord(mrCancel));\r\n AddConst(cDialogs, 'mrAbort', Ord(mrAbort));\r\n AddConst(cDialogs, 'mrRetry', Ord(mrRetry));\r\n AddConst(cDialogs, 'mrIgnore', Ord(mrIgnore));\r\n AddConst(cDialogs, 'mrYes', Ord(mrYes));\r\n AddConst(cDialogs, 'mrNo', Ord(mrNo));\r\n AddConst(cDialogs, 'mrAll', Ord(mrAll));\r\n AddConst(cDialogs, 'mrNoToAll', Ord(mrNoToAll));\r\n AddConst(cDialogs, 'mrYesToAll', Ord(mrYesToAll));\r\n AddFunction(cDialogs, 'CreateMessageDialog', JvInterpreter_CreateMessageDialog, 3, [varEmpty, varEmpty, varEmpty],\r\n varEmpty);\r\n AddFunction(cDialogs, 'MessageDlg', JvInterpreter_MessageDlg, 4, [varEmpty, varEmpty, varEmpty, varEmpty], varEmpty);\r\n AddFunction(cDialogs, 'MessageDlgPos', JvInterpreter_MessageDlgPos, 6, [varEmpty, varEmpty, varEmpty, varEmpty,\r\n varEmpty, varEmpty], varEmpty);\r\n AddFunction(cDialogs, 'MessageDlgPosHelp', JvInterpreter_MessageDlgPosHelp, 7, [varEmpty, varEmpty, varEmpty, varEmpty,\r\n varEmpty, varEmpty, varEmpty], varEmpty);\r\n AddFunction(cDialogs, 'ShowMessage', JvInterpreter_ShowMessage, 1, [varEmpty], varEmpty);\r\n AddFunction(cDialogs, 'ShowMessageFmt', JvInterpreter_ShowMessageFmt, 2, [varEmpty, varEmpty], varEmpty);\r\n AddFunction(cDialogs, 'ShowMessagePos', JvInterpreter_ShowMessagePos, 3, [varEmpty, varEmpty, varEmpty], varEmpty);\r\n AddFunction(cDialogs, 'InputBox', JvInterpreter_InputBox, 3, [varEmpty, varEmpty, varEmpty], varEmpty);\r\n AddFunction(cDialogs, 'InputQuery', JvInterpreter_InputQuery, 3, [varEmpty, varEmpty, varByRef], varEmpty);\r\n end;\r\n RegisterClasses([TOpenDialog, TSaveDialog, TFontDialog, TColorDialog, TPrintDialog, TPrinterSetupDialog,\r\n TFindDialog, TReplaceDialog]);\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvInterpreter_ExtCtrls.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvInterpreter_ExtCtrls.PAS, released on 2002-07-04.\r\n\r\nThe Initial Developers of the Original Code are: Andrei Prygounkov \r\nCopyright (c) 1999, 2002 Andrei Prygounkov\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nDescription : adapter unit - converts JvInterpreter calls to delphi calls\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvInterpreter_ExtCtrls.pas 12461 2009-08-14 17:21:33Z obones $\r\n\r\nunit JvInterpreter_ExtCtrls;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n JvInterpreter;\r\n\r\nprocedure RegisterJvInterpreterAdapter(JvInterpreterAdapter: TJvInterpreterAdapter);\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvInterpreter_ExtCtrls.pas $';\r\n Revision: '$Revision: 12461 $';\r\n Date: '$Date: 2009-08-14 19:21:33 +0200 (ven. 14 août 2009) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n Classes, Graphics, Controls, ExtCtrls;\r\n\r\n{ TShape }\r\n\r\n{ constructor Create(AOwner: TComponent) }\r\n\r\nprocedure TShape_Create(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TShape.Create(V2O(Args.Values[0]) as TComponent));\r\nend;\r\n\r\n{ procedure StyleChanged(Sender: TObject); }\r\n\r\nprocedure TShape_StyleChanged(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TShape(Args.Obj).StyleChanged(V2O(Args.Values[0]));\r\nend;\r\n\r\n{ property Read Brush: TBrush }\r\n\r\nprocedure TShape_Read_Brush(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TShape(Args.Obj).Brush);\r\nend;\r\n\r\n{ property Write Brush(Value: TBrush) }\r\n\r\nprocedure TShape_Write_Brush(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TShape(Args.Obj).Brush := V2O(Value) as TBrush;\r\nend;\r\n\r\n{ property Read Pen: TPen }\r\n\r\nprocedure TShape_Read_Pen(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TShape(Args.Obj).Pen);\r\nend;\r\n\r\n{ property Write Pen(Value: TPen) }\r\n\r\nprocedure TShape_Write_Pen(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TShape(Args.Obj).Pen := V2O(Value) as TPen;\r\nend;\r\n\r\n{ property Read Shape: TShapeType }\r\n\r\nprocedure TShape_Read_Shape(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TShape(Args.Obj).Shape;\r\nend;\r\n\r\n{ property Write Shape(Value: TShapeType) }\r\n\r\nprocedure TShape_Write_Shape(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TShape(Args.Obj).Shape := Value;\r\nend;\r\n\r\n{ TPaintBox }\r\n\r\n{ constructor Create(AOwner: TComponent) }\r\n\r\nprocedure TPaintBox_Create(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TPaintBox.Create(V2O(Args.Values[0]) as TComponent));\r\nend;\r\n\r\n{ TImage }\r\n\r\n{ constructor Create(AOwner: TComponent) }\r\n\r\nprocedure TImage_Create(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TImage.Create(V2O(Args.Values[0]) as TComponent));\r\nend;\r\n\r\n{ property Read Canvas: TCanvas }\r\n\r\nprocedure TImage_Read_Canvas(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TImage(Args.Obj).Canvas);\r\nend;\r\n\r\n{ property Read AutoSize: Boolean }\r\n\r\nprocedure TImage_Read_AutoSize(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TImage(Args.Obj).AutoSize;\r\nend;\r\n\r\n{ property Write AutoSize(Value: Boolean) }\r\n\r\nprocedure TImage_Write_AutoSize(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TImage(Args.Obj).AutoSize := Value;\r\nend;\r\n\r\n{ property Read Center: Boolean }\r\n\r\nprocedure TImage_Read_Center(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TImage(Args.Obj).Center;\r\nend;\r\n\r\n{ property Write Center(Value: Boolean) }\r\n\r\nprocedure TImage_Write_Center(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TImage(Args.Obj).Center := Value;\r\nend;\r\n\r\n{ property Read IncrementalDisplay: Boolean }\r\n\r\nprocedure TImage_Read_IncrementalDisplay(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TImage(Args.Obj).IncrementalDisplay;\r\nend;\r\n\r\n{ property Write IncrementalDisplay(Value: Boolean) }\r\n\r\nprocedure TImage_Write_IncrementalDisplay(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TImage(Args.Obj).IncrementalDisplay := Value;\r\nend;\r\n\r\n{ property Read Picture: TPicture }\r\n\r\nprocedure TImage_Read_Picture(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TImage(Args.Obj).Picture);\r\nend;\r\n\r\n{ property Write Picture(Value: TPicture) }\r\n\r\nprocedure TImage_Write_Picture(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TImage(Args.Obj).Picture := V2O(Value) as TPicture;\r\nend;\r\n\r\n{ property Read Stretch: Boolean }\r\n\r\nprocedure TImage_Read_Stretch(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TImage(Args.Obj).Stretch;\r\nend;\r\n\r\n{ property Write Stretch(Value: Boolean) }\r\n\r\nprocedure TImage_Write_Stretch(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TImage(Args.Obj).Stretch := Value;\r\nend;\r\n\r\n{ property Read Transparent: Boolean }\r\n\r\nprocedure TImage_Read_Transparent(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TImage(Args.Obj).Transparent;\r\nend;\r\n\r\n{ property Write Transparent(Value: Boolean) }\r\n\r\nprocedure TImage_Write_Transparent(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TImage(Args.Obj).Transparent := Value;\r\nend;\r\n\r\n{ TBevel }\r\n\r\n{ constructor Create(AOwner: TComponent) }\r\n\r\nprocedure TBevel_Create(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TBevel.Create(V2O(Args.Values[0]) as TComponent));\r\nend;\r\n\r\n{ property Read Shape: TBevelShape }\r\n\r\nprocedure TBevel_Read_Shape(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TBevel(Args.Obj).Shape;\r\nend;\r\n\r\n{ property Write Shape(Value: TBevelShape) }\r\n\r\nprocedure TBevel_Write_Shape(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TBevel(Args.Obj).Shape := Value;\r\nend;\r\n\r\n{ property Read Style: TBevelStyle }\r\n\r\nprocedure TBevel_Read_Style(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TBevel(Args.Obj).Style;\r\nend;\r\n\r\n{ property Write Style(Value: TBevelStyle) }\r\n\r\nprocedure TBevel_Write_Style(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TBevel(Args.Obj).Style := Value;\r\nend;\r\n\r\n{ TTimer }\r\n\r\n{ constructor Create(AOwner: TComponent) }\r\n\r\nprocedure TTimer_Create(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TTimer.Create(V2O(Args.Values[0]) as TComponent));\r\nend;\r\n\r\n{ property Read Enabled: Boolean }\r\n\r\nprocedure TTimer_Read_Enabled(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TTimer(Args.Obj).Enabled;\r\nend;\r\n\r\n{ property Write Enabled(Value: Boolean) }\r\n\r\nprocedure TTimer_Write_Enabled(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TTimer(Args.Obj).Enabled := Value;\r\nend;\r\n\r\n{ property Read Interval: Cardinal }\r\n\r\nprocedure TTimer_Read_Interval(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := Integer(TTimer(Args.Obj).Interval);\r\nend;\r\n\r\n{ property Write Interval(Value: Cardinal) }\r\n\r\nprocedure TTimer_Write_Interval(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TTimer(Args.Obj).Interval := Value;\r\nend;\r\n\r\n{ TCustomPanel }\r\n\r\n{ TPanel }\r\n\r\n{ constructor Create(AOwner: TComponent) }\r\n\r\nprocedure TPanel_Create(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TPanel.Create(V2O(Args.Values[0]) as TComponent));\r\nend;\r\n\r\n{ TPage }\r\n\r\n{ constructor Create(AOwner: TComponent) }\r\n\r\nprocedure TPage_Create(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TPage.Create(V2O(Args.Values[0]) as TComponent));\r\nend;\r\n\r\n{ TNotebook }\r\n\r\n{ constructor Create(AOwner: TComponent) }\r\n\r\nprocedure TNotebook_Create(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TNotebook.Create(V2O(Args.Values[0]) as TComponent));\r\nend;\r\n\r\n{ property Read ActivePage: string }\r\n\r\nprocedure TNotebook_Read_ActivePage(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TNotebook(Args.Obj).ActivePage;\r\nend;\r\n\r\n{ property Write ActivePage(Value: string) }\r\n\r\nprocedure TNotebook_Write_ActivePage(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TNotebook(Args.Obj).ActivePage := Value;\r\nend;\r\n\r\n{ property Read PageIndex: Integer }\r\n\r\nprocedure TNotebook_Read_PageIndex(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TNotebook(Args.Obj).PageIndex;\r\nend;\r\n\r\n{ property Write PageIndex(Value: Integer) }\r\n\r\nprocedure TNotebook_Write_PageIndex(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TNotebook(Args.Obj).PageIndex := Value;\r\nend;\r\n\r\n{ property Read Pages: TStrings }\r\n\r\nprocedure TNotebook_Read_Pages(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TNotebook(Args.Obj).Pages);\r\nend;\r\n\r\n{ property Write Pages(Value: TStrings) }\r\n\r\nprocedure TNotebook_Write_Pages(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TNotebook(Args.Obj).Pages := V2O(Value) as TStrings;\r\nend;\r\n\r\n{ THeader }\r\n\r\n{ constructor Create(AOwner: TComponent) }\r\n\r\nprocedure THeader_Create(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(THeader.Create(V2O(Args.Values[0]) as TComponent));\r\nend;\r\n\r\n{ property Read SectionWidth[Integer]: Integer }\r\n\r\nprocedure THeader_Read_SectionWidth(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := THeader(Args.Obj).SectionWidth[Args.Values[0]];\r\nend;\r\n\r\n{ property Write SectionWidth[Integer]: Integer }\r\n\r\nprocedure THeader_Write_SectionWidth(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n THeader(Args.Obj).SectionWidth[Args.Values[0]] := Value;\r\nend;\r\n\r\n{ property Read AllowResize: Boolean }\r\n\r\nprocedure THeader_Read_AllowResize(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := THeader(Args.Obj).AllowResize;\r\nend;\r\n\r\n{ property Write AllowResize(Value: Boolean) }\r\n\r\nprocedure THeader_Write_AllowResize(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n THeader(Args.Obj).AllowResize := Value;\r\nend;\r\n\r\n{ property Read BorderStyle: TBorderStyle }\r\n\r\nprocedure THeader_Read_BorderStyle(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := THeader(Args.Obj).BorderStyle;\r\nend;\r\n\r\n{ property Write BorderStyle(Value: TBorderStyle) }\r\n\r\nprocedure THeader_Write_BorderStyle(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n THeader(Args.Obj).BorderStyle := Value;\r\nend;\r\n\r\n{ property Read Sections: TStrings }\r\n\r\nprocedure THeader_Read_Sections(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(THeader(Args.Obj).Sections);\r\nend;\r\n\r\n{ property Write Sections(Value: TStrings) }\r\n\r\nprocedure THeader_Write_Sections(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n THeader(Args.Obj).Sections := V2O(Value) as TStrings;\r\nend;\r\n\r\n{ TCustomRadioGroup }\r\n\r\n{ TRadioGroup }\r\n\r\n{ constructor Create(AOwner: TComponent) }\r\n\r\nprocedure TRadioGroup_Create(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TRadioGroup.Create(V2O(Args.Values[0]) as TComponent));\r\nend;\r\n\r\n{ TSplitter }\r\n\r\n{ constructor Create(AOwner: TComponent) }\r\n\r\nprocedure TSplitter_Create(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TSplitter.Create(V2O(Args.Values[0]) as TComponent));\r\nend;\r\n\r\n{ property Read Beveled: Boolean }\r\n\r\nprocedure TSplitter_Read_Beveled(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TSplitter(Args.Obj).Beveled;\r\nend;\r\n\r\n{ property Write Beveled(Value: Boolean) }\r\n\r\nprocedure TSplitter_Write_Beveled(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TSplitter(Args.Obj).Beveled := Value;\r\nend;\r\n\r\n{ property Read MinSize: NaturalNumber }\r\n\r\nprocedure TSplitter_Read_MinSize(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TSplitter(Args.Obj).MinSize;\r\nend;\r\n\r\n{ property Write MinSize(Value: NaturalNumber) }\r\n\r\nprocedure TSplitter_Write_MinSize(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TSplitter(Args.Obj).MinSize := Value;\r\nend;\r\n\r\nprocedure RegisterJvInterpreterAdapter(JvInterpreterAdapter: TJvInterpreterAdapter);\r\nconst\r\n cExtCtrls = 'ExtCtrls';\r\nbegin\r\n with JvInterpreterAdapter do\r\n begin\r\n { TShapeType }\r\n AddConst(cExtCtrls, 'stRectangle', Ord(stRectangle));\r\n AddConst(cExtCtrls, 'stSquare', Ord(stSquare));\r\n AddConst(cExtCtrls, 'stRoundRect', Ord(stRoundRect));\r\n AddConst(cExtCtrls, 'stRoundSquare', Ord(stRoundSquare));\r\n AddConst(cExtCtrls, 'stEllipse', Ord(stEllipse));\r\n AddConst(cExtCtrls, 'stCircle', Ord(stCircle));\r\n { TShape }\r\n AddClass(cExtCtrls, TShape, 'TShape');\r\n AddGet(TShape, 'Create', TShape_Create, 1, [varEmpty], varEmpty);\r\n AddGet(TShape, 'StyleChanged', TShape_StyleChanged, 1, [varEmpty], varEmpty);\r\n AddGet(TShape, 'Brush', TShape_Read_Brush, 0, [varEmpty], varEmpty);\r\n AddSet(TShape, 'Brush', TShape_Write_Brush, 0, [varEmpty]);\r\n AddGet(TShape, 'Pen', TShape_Read_Pen, 0, [varEmpty], varEmpty);\r\n AddSet(TShape, 'Pen', TShape_Write_Pen, 0, [varEmpty]);\r\n AddGet(TShape, 'Shape', TShape_Read_Shape, 0, [varEmpty], varEmpty);\r\n AddSet(TShape, 'Shape', TShape_Write_Shape, 0, [varEmpty]);\r\n { TPaintBox }\r\n AddClass(cExtCtrls, TPaintBox, 'TPaintBox');\r\n AddGet(TPaintBox, 'Create', TPaintBox_Create, 1, [varEmpty], varEmpty);\r\n { TImage }\r\n AddClass(cExtCtrls, TImage, 'TImage');\r\n AddGet(TImage, 'Create', TImage_Create, 1, [varEmpty], varEmpty);\r\n AddGet(TImage, 'Canvas', TImage_Read_Canvas, 0, [varEmpty], varEmpty);\r\n AddGet(TImage, 'AutoSize', TImage_Read_AutoSize, 0, [varEmpty], varEmpty);\r\n AddSet(TImage, 'AutoSize', TImage_Write_AutoSize, 0, [varEmpty]);\r\n AddGet(TImage, 'Center', TImage_Read_Center, 0, [varEmpty], varEmpty);\r\n AddSet(TImage, 'Center', TImage_Write_Center, 0, [varEmpty]);\r\n AddGet(TImage, 'IncrementalDisplay', TImage_Read_IncrementalDisplay, 0, [varEmpty], varEmpty);\r\n AddSet(TImage, 'IncrementalDisplay', TImage_Write_IncrementalDisplay, 0, [varEmpty]);\r\n AddGet(TImage, 'Picture', TImage_Read_Picture, 0, [varEmpty], varEmpty);\r\n AddSet(TImage, 'Picture', TImage_Write_Picture, 0, [varEmpty]);\r\n AddGet(TImage, 'Stretch', TImage_Read_Stretch, 0, [varEmpty], varEmpty);\r\n AddSet(TImage, 'Stretch', TImage_Write_Stretch, 0, [varEmpty]);\r\n AddGet(TImage, 'Transparent', TImage_Read_Transparent, 0, [varEmpty], varEmpty);\r\n AddSet(TImage, 'Transparent', TImage_Write_Transparent, 0, [varEmpty]);\r\n { TBevelStyle }\r\n AddConst(cExtCtrls, 'bsLowered', Ord(bsLowered));\r\n AddConst(cExtCtrls, 'bsRaised', Ord(bsRaised));\r\n { TBevelShape }\r\n AddConst(cExtCtrls, 'bsBox', Ord(bsBox));\r\n AddConst(cExtCtrls, 'bsFrame', Ord(bsFrame));\r\n AddConst(cExtCtrls, 'bsTopLine', Ord(bsTopLine));\r\n AddConst(cExtCtrls, 'bsBottomLine', Ord(bsBottomLine));\r\n AddConst(cExtCtrls, 'bsLeftLine', Ord(bsLeftLine));\r\n AddConst(cExtCtrls, 'bsRightLine', Ord(bsRightLine));\r\n { TBevel }\r\n AddClass(cExtCtrls, TBevel, 'TBevel');\r\n AddGet(TBevel, 'Create', TBevel_Create, 1, [varEmpty], varEmpty);\r\n AddGet(TBevel, 'Shape', TBevel_Read_Shape, 0, [varEmpty], varEmpty);\r\n AddSet(TBevel, 'Shape', TBevel_Write_Shape, 0, [varEmpty]);\r\n AddGet(TBevel, 'Style', TBevel_Read_Style, 0, [varEmpty], varEmpty);\r\n AddSet(TBevel, 'Style', TBevel_Write_Style, 0, [varEmpty]);\r\n { TTimer }\r\n AddClass(cExtCtrls, TTimer, 'TTimer');\r\n AddGet(TTimer, 'Create', TTimer_Create, 1, [varEmpty], varEmpty);\r\n AddGet(TTimer, 'Enabled', TTimer_Read_Enabled, 0, [varEmpty], varEmpty);\r\n AddSet(TTimer, 'Enabled', TTimer_Write_Enabled, 0, [varEmpty]);\r\n AddGet(TTimer, 'Interval', TTimer_Read_Interval, 0, [varEmpty], varEmpty);\r\n AddSet(TTimer, 'Interval', TTimer_Write_Interval, 0, [varEmpty]);\r\n { TPanelBevel }\r\n AddConst(cExtCtrls, 'bvNone', Ord(bvNone));\r\n AddConst(cExtCtrls, 'bvLowered', Ord(bvLowered));\r\n AddConst(cExtCtrls, 'bvRaised', Ord(bvRaised));\r\n { TCustomPanel }\r\n AddClass(cExtCtrls, TCustomPanel, 'TCustomPanel');\r\n { TPanel }\r\n AddClass(cExtCtrls, TPanel, 'TPanel');\r\n AddGet(TPanel, 'Create', TPanel_Create, 1, [varEmpty], varEmpty);\r\n { TPage }\r\n AddClass(cExtCtrls, TPage, 'TPage');\r\n AddGet(TPage, 'Create', TPage_Create, 1, [varEmpty], varEmpty);\r\n { TNotebook }\r\n AddClass(cExtCtrls, TNotebook, 'TNotebook');\r\n AddGet(TNotebook, 'Create', TNotebook_Create, 1, [varEmpty], varEmpty);\r\n AddGet(TNotebook, 'ActivePage', TNotebook_Read_ActivePage, 0, [varEmpty], varEmpty);\r\n AddSet(TNotebook, 'ActivePage', TNotebook_Write_ActivePage, 0, [varEmpty]);\r\n AddGet(TNotebook, 'PageIndex', TNotebook_Read_PageIndex, 0, [varEmpty], varEmpty);\r\n AddSet(TNotebook, 'PageIndex', TNotebook_Write_PageIndex, 0, [varEmpty]);\r\n AddIGet(TNotebook, 'Pages', TNotebook_Read_Pages, 0, [varEmpty], varEmpty);\r\n AddISet(TNotebook, 'Pages', TNotebook_Write_Pages, 0, [varEmpty]);\r\n { THeader }\r\n AddClass(cExtCtrls, THeader, 'THeader');\r\n AddGet(THeader, 'Create', THeader_Create, 1, [varEmpty], varEmpty);\r\n AddGet(THeader, 'SectionWidth', THeader_Read_SectionWidth, 1, [varEmpty], varEmpty);\r\n AddSet(THeader, 'SectionWidth', THeader_Write_SectionWidth, 1, [varNull]);\r\n AddGet(THeader, 'AllowResize', THeader_Read_AllowResize, 0, [varEmpty], varEmpty);\r\n AddSet(THeader, 'AllowResize', THeader_Write_AllowResize, 0, [varEmpty]);\r\n AddGet(THeader, 'BorderStyle', THeader_Read_BorderStyle, 0, [varEmpty], varEmpty);\r\n AddSet(THeader, 'BorderStyle', THeader_Write_BorderStyle, 0, [varEmpty]);\r\n AddIGet(THeader, 'Sections', THeader_Read_Sections, 0, [varEmpty], varEmpty);\r\n AddISet(THeader, 'Sections', THeader_Write_Sections, 0, [varEmpty]);\r\n { TCustomRadioGroup }\r\n AddClass(cExtCtrls, TCustomRadioGroup, 'TCustomRadioGroup');\r\n { TRadioGroup }\r\n AddClass(cExtCtrls, TRadioGroup, 'TRadioGroup');\r\n AddGet(TRadioGroup, 'Create', TRadioGroup_Create, 1, [varEmpty], varEmpty);\r\n { TSplitter }\r\n AddClass(cExtCtrls, TSplitter, 'TSplitter');\r\n AddGet(TSplitter, 'Create', TSplitter_Create, 1, [varEmpty], varEmpty);\r\n AddGet(TSplitter, 'Beveled', TSplitter_Read_Beveled, 0, [varEmpty], varEmpty);\r\n AddSet(TSplitter, 'Beveled', TSplitter_Write_Beveled, 0, [varEmpty]);\r\n AddGet(TSplitter, 'MinSize', TSplitter_Read_MinSize, 0, [varEmpty], varEmpty);\r\n AddSet(TSplitter, 'MinSize', TSplitter_Write_MinSize, 0, [varEmpty]);\r\n end;\r\n RegisterClasses([TShape, TPaintBox, TImage, TBevel, TTimer, TPanel, TPage,\r\n TNotebook, THeader, TRadioGroup, TSplitter]);\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvInterpreter_Forms.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvInterpreter_Forms.PAS, released on 2002-07-04.\r\n\r\nThe Initial Developers of the Original Code are: Andrei Prygounkov \r\nCopyright (c) 1999, 2002 Andrei Prygounkov\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nDescription : adapter unit - converts JvInterpreter calls to delphi calls\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvInterpreter_Forms.pas 13173 2011-11-19 12:43:58Z ahuser $\r\n\r\nunit JvInterpreter_Forms;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n JvInterpreter;\r\n\r\nprocedure RegisterJvInterpreterAdapter(JvInterpreterAdapter: TJvInterpreterAdapter);\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvInterpreter_Forms.pas $';\r\n Revision: '$Revision: 13173 $';\r\n Date: '$Date: 2011-11-19 13:43:58 +0100 (sam. 19 nov. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n Classes,\r\n SysUtils, Graphics, Controls, Menus, Forms;\r\n\r\n{ TControlScrollBar }\r\n\r\n{ procedure Assign(Source: TPersistent); }\r\n\r\nprocedure TControlScrollBar_Assign(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TControlScrollBar(Args.Obj).Assign(V2O(Args.Values[0]) as TPersistent);\r\nend;\r\n\r\n{ property Read Kind: TScrollBarKind }\r\n\r\nprocedure TControlScrollBar_Read_Kind(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TControlScrollBar(Args.Obj).Kind;\r\nend;\r\n\r\n{ property Read ScrollPos: Integer }\r\n\r\nprocedure TControlScrollBar_Read_ScrollPos(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TControlScrollBar(Args.Obj).ScrollPos;\r\nend;\r\n\r\n{ property Read Margin: Word }\r\n\r\nprocedure TControlScrollBar_Read_Margin(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TControlScrollBar(Args.Obj).Margin;\r\nend;\r\n\r\n{ property Write Margin(Value: Word) }\r\n\r\nprocedure TControlScrollBar_Write_Margin(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TControlScrollBar(Args.Obj).Margin := Value;\r\nend;\r\n\r\n{ property Read Increment: TScrollBarInc }\r\n\r\nprocedure TControlScrollBar_Read_Increment(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TControlScrollBar(Args.Obj).Increment;\r\nend;\r\n\r\n{ property Write Increment(Value: TScrollBarInc) }\r\n\r\nprocedure TControlScrollBar_Write_Increment(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TControlScrollBar(Args.Obj).Increment := Value;\r\nend;\r\n\r\n{ property Read Range: Integer }\r\n\r\nprocedure TControlScrollBar_Read_Range(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TControlScrollBar(Args.Obj).Range;\r\nend;\r\n\r\n{ property Write Range(Value: Integer) }\r\n\r\nprocedure TControlScrollBar_Write_Range(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TControlScrollBar(Args.Obj).Range := Value;\r\nend;\r\n\r\n{ property Read Position: Integer }\r\n\r\nprocedure TControlScrollBar_Read_Position(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TControlScrollBar(Args.Obj).Position;\r\nend;\r\n\r\n{ property Write Position(Value: Integer) }\r\n\r\nprocedure TControlScrollBar_Write_Position(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TControlScrollBar(Args.Obj).Position := Value;\r\nend;\r\n\r\n{ property Read Tracking: Boolean }\r\n\r\nprocedure TControlScrollBar_Read_Tracking(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TControlScrollBar(Args.Obj).Tracking;\r\nend;\r\n\r\n{ property Write Tracking(Value: Boolean) }\r\n\r\nprocedure TControlScrollBar_Write_Tracking(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TControlScrollBar(Args.Obj).Tracking := Value;\r\nend;\r\n\r\n{ property Read Visible: Boolean }\r\n\r\nprocedure TControlScrollBar_Read_Visible(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TControlScrollBar(Args.Obj).Visible;\r\nend;\r\n\r\n{ property Write Visible(Value: Boolean) }\r\n\r\nprocedure TControlScrollBar_Write_Visible(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TControlScrollBar(Args.Obj).Visible := Value;\r\nend;\r\n\r\n{ TScrollingWinControl }\r\n\r\n{ constructor Create(AOwner: TComponent) }\r\n\r\nprocedure TScrollingWinControl_Create(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TScrollingWinControl.Create(V2O(Args.Values[0]) as TComponent));\r\nend;\r\n\r\n{ procedure DisableAutoRange; }\r\n\r\nprocedure TScrollingWinControl_DisableAutoRange(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TScrollingWinControl(Args.Obj).DisableAutoRange;\r\nend;\r\n\r\n{ procedure EnableAutoRange; }\r\n\r\nprocedure TScrollingWinControl_EnableAutoRange(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TScrollingWinControl(Args.Obj).EnableAutoRange;\r\nend;\r\n\r\n{ procedure ScrollInView(AControl: TControl); }\r\n\r\nprocedure TScrollingWinControl_ScrollInView(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TScrollingWinControl(Args.Obj).ScrollInView(V2O(Args.Values[0]) as TControl);\r\nend;\r\n\r\n{ property Read HorzScrollBar: TControlScrollBar }\r\n\r\nprocedure TScrollingWinControl_Read_HorzScrollBar(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TScrollingWinControl(Args.Obj).HorzScrollBar);\r\nend;\r\n\r\n{ property Write HorzScrollBar(Value: TControlScrollBar) }\r\n\r\nprocedure TScrollingWinControl_Write_HorzScrollBar(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TScrollingWinControl(Args.Obj).HorzScrollBar := V2O(Value) as TControlScrollBar;\r\nend;\r\n\r\n{ property Read VertScrollBar: TControlScrollBar }\r\n\r\nprocedure TScrollingWinControl_Read_VertScrollBar(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TScrollingWinControl(Args.Obj).VertScrollBar);\r\nend;\r\n\r\n{ property Write VertScrollBar(Value: TControlScrollBar) }\r\n\r\nprocedure TScrollingWinControl_Write_VertScrollBar(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TScrollingWinControl(Args.Obj).VertScrollBar := V2O(Value) as TControlScrollBar;\r\nend;\r\n\r\n{ TScrollBox }\r\n\r\n{ constructor Create(AOwner: TComponent) }\r\n\r\nprocedure TScrollBox_Create(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TScrollBox.Create(V2O(Args.Values[0]) as TComponent));\r\nend;\r\n\r\n{ property Read BorderStyle: TBorderStyle }\r\n\r\nprocedure TScrollBox_Read_BorderStyle(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TScrollBox(Args.Obj).BorderStyle;\r\nend;\r\n\r\n{ property Write BorderStyle(Value: TBorderStyle) }\r\n\r\nprocedure TScrollBox_Write_BorderStyle(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TScrollBox(Args.Obj).BorderStyle := Value;\r\nend;\r\n\r\n{ function CloseQuery: Boolean; }\r\n\r\nprocedure TCustomForm_CloseQuery(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TCustomForm(Args.Obj).CloseQuery;\r\nend;\r\n\r\n{ procedure Close; }\r\n\r\nprocedure TCustomForm_Close(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TCustomForm(Args.Obj).Close;\r\nend;\r\n\r\n{ procedure DefocusControl(Control: TWinControl; Removing: Boolean); }\r\n\r\nprocedure TCustomForm_DefocusControl(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TCustomForm(Args.Obj).DefocusControl(V2O(Args.Values[0]) as TWinControl, Args.Values[1]);\r\nend;\r\n\r\n{ procedure FocusControl(Control: TWinControl); }\r\n\r\nprocedure TCustomForm_FocusControl(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TCustomForm(Args.Obj).FocusControl(V2O(Args.Values[0]) as TWinControl);\r\nend;\r\n\r\n{ function GetFormImage: TBitmap; }\r\n\r\n\r\nprocedure TCustomForm_GetFormImage(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TCustomForm(Args.Obj).GetFormImage);\r\nend;\r\n\r\n\r\n{ procedure Hide; }\r\n\r\nprocedure TCustomForm_Hide(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TCustomForm(Args.Obj).Hide;\r\nend;\r\n\r\n{ procedure Print; }\r\n\r\n\r\nprocedure TCustomForm_Print(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TCustomForm(Args.Obj).Print;\r\nend;\r\n\r\n\r\n{ procedure Release; }\r\n\r\nprocedure TCustomForm_Release(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TCustomForm(Args.Obj).Release;\r\nend;\r\n\r\n{ procedure SendCancelMode(Sender: TControl); }\r\n\r\n\r\nprocedure TCustomForm_SendCancelMode(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TCustomForm(Args.Obj).SendCancelMode(V2O(Args.Values[0]) as TControl);\r\nend;\r\n\r\n\r\n{ procedure SetFocus; }\r\n\r\nprocedure TCustomForm_SetFocus(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TCustomForm(Args.Obj).SetFocus;\r\nend;\r\n\r\n{ function SetFocusedControl(Control: TWinControl): Boolean; }\r\n\r\nprocedure TCustomForm_SetFocusedControl(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TCustomForm(Args.Obj).SetFocusedControl(V2O(Args.Values[0]) as TWinControl);\r\nend;\r\n\r\n{ procedure Show; }\r\n\r\nprocedure TCustomForm_Show(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TCustomForm(Args.Obj).Show;\r\nend;\r\n\r\n{ function ShowModal: Integer; }\r\n\r\nprocedure TCustomForm_ShowModal(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TCustomForm(Args.Obj).ShowModal;\r\nend;\r\n\r\n{ property Read Active: Boolean }\r\n\r\nprocedure TCustomForm_Read_Active(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TCustomForm(Args.Obj).Active;\r\nend;\r\n\r\n{ property Read ActiveControl: TWinControl }\r\n\r\nprocedure TCustomForm_Read_ActiveControl(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TCustomForm(Args.Obj).ActiveControl);\r\nend;\r\n\r\n{ property Write ActiveControl(Value: TWinControl) }\r\n\r\nprocedure TCustomForm_Write_ActiveControl(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TCustomForm(Args.Obj).ActiveControl := V2O(Value) as TWinControl;\r\nend;\r\n\r\n\r\n\r\n{ property Read ActiveOleControl: TWinControl }\r\n\r\nprocedure TCustomForm_Read_ActiveOleControl(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TCustomForm(Args.Obj).ActiveOleControl);\r\nend;\r\n\r\n{ property Write ActiveOleControl(Value: TWinControl) }\r\n\r\nprocedure TCustomForm_Write_ActiveOleControl(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TCustomForm(Args.Obj).ActiveOleControl := V2O(Value) as TWinControl;\r\nend;\r\n\r\n\r\n\r\n{ property Read Canvas: TCanvas }\r\n\r\nprocedure TCustomForm_Read_Canvas(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TCustomForm(Args.Obj).Canvas);\r\nend;\r\n\r\n{ property Read DropTarget: Boolean }\r\n\r\nprocedure TCustomForm_Read_DropTarget(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TCustomForm(Args.Obj).DropTarget;\r\nend;\r\n\r\n{ property Write DropTarget(Value: Boolean) }\r\n\r\nprocedure TCustomForm_Write_DropTarget(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TCustomForm(Args.Obj).DropTarget := Value;\r\nend;\r\n\r\n{ property Read HelpFile: string }\r\n\r\nprocedure TCustomForm_Read_HelpFile(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TCustomForm(Args.Obj).HelpFile;\r\nend;\r\n\r\n{ property Write HelpFile(Value: string) }\r\n\r\nprocedure TCustomForm_Write_HelpFile(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TCustomForm(Args.Obj).HelpFile := Value;\r\nend;\r\n\r\n{ property Read KeyPreview: Boolean }\r\n\r\nprocedure TCustomForm_Read_KeyPreview(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TCustomForm(Args.Obj).KeyPreview;\r\nend;\r\n\r\n{ property Write KeyPreview(Value: Boolean) }\r\n\r\nprocedure TCustomForm_Write_KeyPreview(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TCustomForm(Args.Obj).KeyPreview := Value;\r\nend;\r\n\r\n{ property Read Menu: TMainMenu }\r\n\r\nprocedure TCustomForm_Read_Menu(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TCustomForm(Args.Obj).Menu);\r\nend;\r\n\r\n{ property Write Menu(Value: TMainMenu) }\r\n\r\nprocedure TCustomForm_Write_Menu(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TCustomForm(Args.Obj).Menu := V2O(Value) as TMainMenu;\r\nend;\r\n\r\n{ property Read ModalResult: TModalResult }\r\n\r\nprocedure TCustomForm_Read_ModalResult(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TCustomForm(Args.Obj).ModalResult;\r\nend;\r\n\r\n{ property Write ModalResult(Value: TModalResult) }\r\n\r\nprocedure TCustomForm_Write_ModalResult(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TCustomForm(Args.Obj).ModalResult := Value;\r\nend;\r\n\r\n{ property Read WindowState: TWindowState }\r\n\r\nprocedure TCustomForm_Read_WindowState(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TCustomForm(Args.Obj).WindowState;\r\nend;\r\n\r\n{ property Write WindowState(Value: TWindowState) }\r\n\r\nprocedure TCustomForm_Write_WindowState(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TCustomForm(Args.Obj).WindowState := Value;\r\nend;\r\n\r\n{ TForm }\r\n\r\n{ constructor Create(AOwner: TComponent) }\r\n\r\nprocedure TForm_Create(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TForm.Create(V2O(Args.Values[0]) as TComponent));\r\nend;\r\n\r\n{ constructor CreateNew(AOwner: TComponent) }\r\n\r\nprocedure TForm_CreateNew(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n {$IFDEF DELPHI}\r\n Value := O2V(TForm.CreateNew(V2O(Args.Values[0]) as TComponent));\r\n {$ELSE}\r\n Value := O2V(TForm.CreateNew(V2O(Args.Values[0]) as TComponent, 1));\r\n {$ENDIF DELPHI}\r\nend;\r\n\r\n{ procedure ArrangeIcons; }\r\n\r\n\r\nprocedure TForm_ArrangeIcons(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TForm(Args.Obj).ArrangeIcons;\r\nend;\r\n\r\n\r\n{ procedure Cascade; }\r\n\r\nprocedure TForm_Cascade(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TForm(Args.Obj).Cascade;\r\nend;\r\n\r\n{ procedure Next; }\r\n\r\nprocedure TForm_Next(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TForm(Args.Obj).Next;\r\nend;\r\n\r\n{ procedure Previous; }\r\n\r\nprocedure TForm_Previous(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TForm(Args.Obj).Previous;\r\nend;\r\n\r\n{ procedure Tile; }\r\n\r\nprocedure TForm_Tile(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TForm(Args.Obj).Tile;\r\nend;\r\n\r\n{ TDataModule }\r\n\r\n{ constructor Create(AOwner: TComponent) }\r\n\r\nprocedure TDataModule_Create(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TDataModule.Create(V2O(Args.Values[0]) as TComponent));\r\nend;\r\n\r\n{ constructor CreateNew(AOwner: TComponent) }\r\n\r\nprocedure TDataModule_CreateNew(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n {$IFDEF DELPHI}\r\n Value := O2V(TDataModule.CreateNew(V2O(Args.Values[0]) as TComponent));\r\n {$ELSE}\r\n Value := O2V(TDataModule.CreateNew(V2O(Args.Values[0]) as TComponent, 1));\r\n {$ENDIF DELPHI}\r\nend;\r\n\r\n{ TScreen }\r\n\r\n{ constructor Create(AOwner: TComponent) }\r\n\r\nprocedure TScreen_Create(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TScreen.Create(V2O(Args.Values[0]) as TComponent));\r\nend;\r\n\r\n{ property Read ActiveControl: TWinControl }\r\n\r\nprocedure TScreen_Read_ActiveControl(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TScreen(Args.Obj).ActiveControl);\r\nend;\r\n\r\n{ property Read ActiveCustomForm: TCustomForm }\r\n\r\nprocedure TScreen_Read_ActiveCustomForm(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TScreen(Args.Obj).ActiveCustomForm);\r\nend;\r\n\r\n{ property Read ActiveForm: TForm }\r\n\r\nprocedure TScreen_Read_ActiveForm(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TScreen(Args.Obj).ActiveForm);\r\nend;\r\n\r\n{ property Read CustomFormCount: Integer }\r\n\r\nprocedure TScreen_Read_CustomFormCount(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TScreen(Args.Obj).CustomFormCount;\r\nend;\r\n\r\n{ property Read CustomForms[Integer]: TCustomForm }\r\n\r\nprocedure TScreen_Read_CustomForms(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TScreen(Args.Obj).CustomForms[Args.Values[0]]);\r\nend;\r\n\r\n{ property Read Cursor: TCursor }\r\n\r\nprocedure TScreen_Read_Cursor(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TScreen(Args.Obj).Cursor;\r\nend;\r\n\r\n{ property Write Cursor(Value: TCursor) }\r\n\r\nprocedure TScreen_Write_Cursor(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TScreen(Args.Obj).Cursor := Value;\r\nend;\r\n\r\n{ property Read Cursors[Integer]: HCURSOR }\r\n\r\nprocedure TScreen_Read_Cursors(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := NativeInt(TScreen(Args.Obj).Cursors[Args.Values[0]]);\r\nend;\r\n\r\n{ property Write Cursors[Integer]: HCURSOR }\r\n\r\nprocedure TScreen_Write_Cursors(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TScreen(Args.Obj).Cursors[Args.Values[0]] := Value;\r\nend;\r\n\r\n{ property Read DataModules[Integer]: TDataModule }\r\n\r\nprocedure TScreen_Read_DataModules(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TScreen(Args.Obj).DataModules[Args.Values[0]]);\r\nend;\r\n\r\n{ property Read DataModuleCount: Integer }\r\n\r\nprocedure TScreen_Read_DataModuleCount(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TScreen(Args.Obj).DataModuleCount;\r\nend;\r\n\r\n\r\n{ property Read IconFont: TFont }\r\n\r\nprocedure TScreen_Read_IconFont(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TScreen(Args.Obj).IconFont);\r\nend;\r\n\r\n{ property Write IconFont(Value: TFont) }\r\n\r\nprocedure TScreen_Write_IconFont(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TScreen(Args.Obj).IconFont := V2O(Value) as TFont;\r\nend;\r\n\r\n\r\n\r\n{ property Read Fonts: TStrings }\r\n\r\nprocedure TScreen_Read_Fonts(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TScreen(Args.Obj).Fonts);\r\nend;\r\n\r\n{ property Read FormCount: Integer }\r\n\r\nprocedure TScreen_Read_FormCount(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TScreen(Args.Obj).FormCount;\r\nend;\r\n\r\n{ property Read Forms[Integer]: TForm }\r\n\r\nprocedure TScreen_Read_Forms(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TScreen(Args.Obj).Forms[Args.Values[0]]);\r\nend;\r\n\r\n\r\n\r\n{ property Read Imes: TStrings }\r\n\r\nprocedure TScreen_Read_Imes(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TScreen(Args.Obj).Imes);\r\nend;\r\n\r\n{ property Read DefaultIme: string }\r\n\r\nprocedure TScreen_Read_DefaultIme(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TScreen(Args.Obj).DefaultIme;\r\nend;\r\n\r\n{ property Read DefaultKbLayout: HKL }\r\n\r\nprocedure TScreen_Read_DefaultKbLayout(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := NativeInt(TScreen(Args.Obj).DefaultKbLayout);\r\nend;\r\n\r\n\r\n\r\n{ property Read Height: Integer }\r\n\r\nprocedure TScreen_Read_Height(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TScreen(Args.Obj).Height;\r\nend;\r\n\r\n{ property Read PixelsPerInch: Integer }\r\n\r\nprocedure TScreen_Read_PixelsPerInch(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TScreen(Args.Obj).PixelsPerInch;\r\nend;\r\n\r\n{ property Read Width: Integer }\r\n\r\nprocedure TScreen_Read_Width(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TScreen(Args.Obj).Width;\r\nend;\r\n\r\n{ TApplication }\r\n\r\n{ constructor Create(AOwner: TComponent) }\r\n\r\nprocedure TApplication_Create(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TApplication.Create(V2O(Args.Values[0]) as TComponent));\r\nend;\r\n\r\n{ procedure BringToFront; }\r\n\r\nprocedure TApplication_BringToFront(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TApplication(Args.Obj).BringToFront;\r\nend;\r\n\r\n{ procedure ControlDestroyed(Control: TControl); }\r\n\r\nprocedure TApplication_ControlDestroyed(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TApplication(Args.Obj).ControlDestroyed(V2O(Args.Values[0]) as TControl);\r\nend;\r\n\r\n{ procedure CancelHint; }\r\n\r\nprocedure TApplication_CancelHint(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TApplication(Args.Obj).CancelHint;\r\nend;\r\n\r\n{ procedure CreateForm(InstanceClass: TComponentClass; var Reference); }\r\n\r\nprocedure TApplication_CreateForm(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TApplication(Args.Obj).CreateForm(TComponentClass(V2C(Args.Values[0])), Args.Values[1]);\r\nend;\r\n\r\n{ procedure HandleException(Sender: TObject); }\r\n\r\nprocedure TApplication_HandleException(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TApplication(Args.Obj).HandleException(V2O(Args.Values[0]));\r\nend;\r\n\r\n{ procedure HandleMessage; }\r\n\r\nprocedure TApplication_HandleMessage(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TApplication(Args.Obj).HandleMessage;\r\nend;\r\n\r\n\r\n\r\n{ function HelpCommand(Command: Integer; Data: Longint): Boolean; }\r\n\r\nprocedure TApplication_HelpCommand(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TApplication(Args.Obj).HelpCommand(Args.Values[0], Args.Values[1]);\r\nend;\r\n\r\n{ function HelpContext(Context: THelpContext): Boolean; }\r\n\r\nprocedure TApplication_HelpContext(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TApplication(Args.Obj).HelpContext(Args.Values[0]);\r\nend;\r\n\r\n{ function HelpJump(const JumpID: string): Boolean; }\r\n\r\nprocedure TApplication_HelpJump(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TApplication(Args.Obj).HelpJump(Args.Values[0]);\r\nend;\r\n\r\n\r\n\r\n{ procedure HideHint; }\r\n\r\nprocedure TApplication_HideHint(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TApplication(Args.Obj).HideHint;\r\nend;\r\n\r\n{ procedure Initialize; }\r\n\r\nprocedure TApplication_Initialize(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TApplication(Args.Obj).Initialize;\r\nend;\r\n\r\n{ function MessageBox(Text, Caption: PChar; Flags: Longint): Integer; }\r\n\r\nprocedure TApplication_MessageBox(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TApplication(Args.Obj).MessageBox(PChar(string(Args.Values[0])), PChar(string(Args.Values[1])),\r\n Args.Values[2]);\r\nend;\r\n\r\n{ procedure Minimize; }\r\n\r\nprocedure TApplication_Minimize(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TApplication(Args.Obj).Minimize;\r\nend;\r\n\r\n{ procedure NormalizeAllTopMosts; }\r\n\r\n\r\nprocedure TApplication_NormalizeAllTopMosts(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TApplication(Args.Obj).NormalizeAllTopMosts;\r\nend;\r\n\r\n\r\n{ procedure NormalizeTopMosts; }\r\n\r\nprocedure TApplication_NormalizeTopMosts(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TApplication(Args.Obj).NormalizeTopMosts;\r\nend;\r\n\r\n{ procedure ProcessMessages; }\r\n\r\nprocedure TApplication_ProcessMessages(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TApplication(Args.Obj).ProcessMessages;\r\nend;\r\n\r\n{ procedure Restore; }\r\n\r\nprocedure TApplication_Restore(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TApplication(Args.Obj).Restore;\r\nend;\r\n\r\n{ procedure RestoreTopMosts; }\r\n\r\nprocedure TApplication_RestoreTopMosts(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TApplication(Args.Obj).RestoreTopMosts;\r\nend;\r\n\r\n{ procedure Run; }\r\n\r\nprocedure TApplication_Run(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TApplication(Args.Obj).Run;\r\nend;\r\n\r\n{ procedure ShowException(E: Exception); }\r\n\r\nprocedure TApplication_ShowException(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TApplication(Args.Obj).ShowException(V2O(Args.Values[0]) as Exception);\r\nend;\r\n\r\n{ procedure Terminate; }\r\n\r\nprocedure TApplication_Terminate(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TApplication(Args.Obj).Terminate;\r\nend;\r\n\r\n{ property Read Active: Boolean }\r\n\r\nprocedure TApplication_Read_Active(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TApplication(Args.Obj).Active;\r\nend;\r\n\r\n{ property Read CurrentHelpFile: string }\r\n\r\nprocedure TApplication_Read_CurrentHelpFile(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TApplication(Args.Obj).CurrentHelpFile;\r\nend;\r\n\r\n\r\n\r\n{ property Read DialogHandle: HWnd }\r\n\r\nprocedure TApplication_Read_DialogHandle(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := NativeInt(TApplication(Args.Obj).DialogHandle);\r\nend;\r\n\r\n{ property Write DialogHandle(Value: HWnd) }\r\n\r\nprocedure TApplication_Write_DialogHandle(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TApplication(Args.Obj).DialogHandle := Value;\r\nend;\r\n\r\n\r\n\r\n{ property Read ExeName: string }\r\n\r\nprocedure TApplication_Read_ExeName(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TApplication(Args.Obj).ExeName;\r\nend;\r\n\r\n{ property Read Handle: HWnd }\r\n\r\nprocedure TApplication_Read_Handle(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := NativeInt(TApplication(Args.Obj).Handle);\r\nend;\r\n\r\n{ property Write Handle(Value: HWnd) }\r\n\r\nprocedure TApplication_Write_Handle(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TApplication(Args.Obj).Handle := Value;\r\nend;\r\n\r\n{ property Read HelpFile: string }\r\n\r\nprocedure TApplication_Read_HelpFile(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TApplication(Args.Obj).HelpFile;\r\nend;\r\n\r\n{ property Write HelpFile(Value: string) }\r\n\r\nprocedure TApplication_Write_HelpFile(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TApplication(Args.Obj).HelpFile := Value;\r\nend;\r\n\r\n{ property Read Hint: string }\r\n\r\nprocedure TApplication_Read_Hint(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TApplication(Args.Obj).Hint;\r\nend;\r\n\r\n{ property Write Hint(Value: string) }\r\n\r\nprocedure TApplication_Write_Hint(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TApplication(Args.Obj).Hint := Value;\r\nend;\r\n\r\n{ property Read HintColor: TColor }\r\n\r\nprocedure TApplication_Read_HintColor(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TApplication(Args.Obj).HintColor;\r\nend;\r\n\r\n{ property Write HintColor(Value: TColor) }\r\n\r\nprocedure TApplication_Write_HintColor(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TApplication(Args.Obj).HintColor := Value;\r\nend;\r\n\r\n{ property Read HintPause: Integer }\r\n\r\nprocedure TApplication_Read_HintPause(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TApplication(Args.Obj).HintPause;\r\nend;\r\n\r\n{ property Write HintPause(Value: Integer) }\r\n\r\nprocedure TApplication_Write_HintPause(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TApplication(Args.Obj).HintPause := Value;\r\nend;\r\n\r\n{ property Read HintShortPause: Integer }\r\n\r\nprocedure TApplication_Read_HintShortPause(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TApplication(Args.Obj).HintShortPause;\r\nend;\r\n\r\n{ property Write HintShortPause(Value: Integer) }\r\n\r\nprocedure TApplication_Write_HintShortPause(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TApplication(Args.Obj).HintShortPause := Value;\r\nend;\r\n\r\n{ property Read HintHidePause: Integer }\r\n\r\nprocedure TApplication_Read_HintHidePause(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TApplication(Args.Obj).HintHidePause;\r\nend;\r\n\r\n{ property Write HintHidePause(Value: Integer) }\r\n\r\nprocedure TApplication_Write_HintHidePause(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TApplication(Args.Obj).HintHidePause := Value;\r\nend;\r\n\r\n{ property Read Icon: TIcon }\r\n\r\nprocedure TApplication_Read_Icon(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TApplication(Args.Obj).Icon);\r\nend;\r\n\r\n{ property Write Icon(Value: TIcon) }\r\n\r\nprocedure TApplication_Write_Icon(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TApplication(Args.Obj).Icon := V2O(Value) as TIcon;\r\nend;\r\n\r\n{ property Read MainForm: TForm }\r\n\r\nprocedure TApplication_Read_MainForm(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TApplication(Args.Obj).MainForm);\r\nend;\r\n\r\n{ property Read ShowHint: Boolean }\r\n\r\nprocedure TApplication_Read_ShowHint(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TApplication(Args.Obj).ShowHint;\r\nend;\r\n\r\n{ property Write ShowHint(Value: Boolean) }\r\n\r\nprocedure TApplication_Write_ShowHint(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TApplication(Args.Obj).ShowHint := Value;\r\nend;\r\n\r\n{ property Read ShowMainForm: Boolean }\r\n\r\nprocedure TApplication_Read_ShowMainForm(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TApplication(Args.Obj).ShowMainForm;\r\nend;\r\n\r\n{ property Write ShowMainForm(Value: Boolean) }\r\n\r\nprocedure TApplication_Write_ShowMainForm(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TApplication(Args.Obj).ShowMainForm := Value;\r\nend;\r\n\r\n{ property Read Terminated: Boolean }\r\n\r\nprocedure TApplication_Read_Terminated(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TApplication(Args.Obj).Terminated;\r\nend;\r\n\r\n{ property Read Title: string }\r\n\r\nprocedure TApplication_Read_Title(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TApplication(Args.Obj).Title;\r\nend;\r\n\r\n{ property Write Title(Value: string) }\r\n\r\nprocedure TApplication_Write_Title(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TApplication(Args.Obj).Title := Value;\r\nend;\r\n\r\n\r\n\r\n{ property Read UpdateFormatSettings: Boolean }\r\n\r\nprocedure TApplication_Read_UpdateFormatSettings(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TApplication(Args.Obj).UpdateFormatSettings;\r\nend;\r\n\r\n{ property Write UpdateFormatSettings(Value: Boolean) }\r\n\r\nprocedure TApplication_Write_UpdateFormatSettings(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TApplication(Args.Obj).UpdateFormatSettings := Value;\r\nend;\r\n\r\n{ property Read UpdateMetricSettings: Boolean }\r\n\r\nprocedure TApplication_Read_UpdateMetricSettings(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TApplication(Args.Obj).UpdateMetricSettings;\r\nend;\r\n\r\n{ property Write UpdateMetricSettings(Value: Boolean) }\r\n\r\nprocedure TApplication_Write_UpdateMetricSettings(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TApplication(Args.Obj).UpdateMetricSettings := Value;\r\nend;\r\n\r\n\r\n\r\n{ Application global variable }\r\n\r\nprocedure JvInterpreter_Application(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(Application);\r\nend;\r\n\r\n{ Screen global variable }\r\n\r\nprocedure JvInterpreter_Screen(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(Screen);\r\nend;\r\n\r\n{ functions }\r\n\r\n{ function GetParentForm(Control: TControl): TCustomForm; }\r\n\r\nprocedure JvInterpreter_GetParentForm(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(GetParentForm(V2O(Args.Values[0]) as TControl));\r\nend;\r\n\r\n{ function ValidParentForm(Control: TControl): TCustomForm; }\r\n\r\nprocedure JvInterpreter_ValidParentForm(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(ValidParentForm(V2O(Args.Values[0]) as TControl));\r\nend;\r\n\r\n\r\n\r\n{ function DisableTaskWindows(ActiveWindow: HWnd): Pointer; }\r\n\r\nprocedure JvInterpreter_DisableTaskWindows(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := P2V(DisableTaskWindows(Args.Values[0]));\r\nend;\r\n\r\n{ procedure EnableTaskWindows(WindowList: Pointer); }\r\n\r\nprocedure JvInterpreter_EnableTaskWindows(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n EnableTaskWindows(V2P(Args.Values[0]));\r\nend;\r\n\r\n\r\n\r\n{ function IsAccel(VK: Word; const Str: string): Boolean; }\r\n\r\nprocedure JvInterpreter_IsAccel(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := IsAccel(Args.Values[0], Args.Values[1]);\r\nend;\r\n\r\n\r\n\r\n{ function KeysToShiftState(Keys: Word): TShiftState; }\r\n\r\nprocedure JvInterpreter_KeysToShiftState(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := S2V(TJvInterpreterShiftStateCastType(KeysToShiftState(Args.Values[0])));\r\nend;\r\n\r\n{ function KeyDataToShiftState(KeyData: Longint): TShiftState; }\r\n\r\nprocedure JvInterpreter_KeyDataToShiftState(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := S2V(TJvInterpreterShiftStateCastType(KeyDataToShiftState(Args.Values[0])));\r\nend;\r\n\r\n{ function ForegroundTask: Boolean; }\r\n\r\nprocedure JvInterpreter_ForegroundTask(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := ForegroundTask;\r\nend;\r\n\r\n\r\n\r\ntype\r\n TJvInterpreterFormsEvent = class(TJvInterpreterEvent)\r\n private\r\n procedure CloseEvent(Sender: TObject; var Action: TCloseAction);\r\n procedure CloseQueryEvent(Sender: TObject; var CanClose: Boolean);\r\n procedure ExceptionEvent(Sender: TObject; E: Exception);\r\n procedure IdleEvent(Sender: TObject; var Done: Boolean);\r\n procedure ShowHintEvent(var HintStr: string; var CanShow: Boolean; var HintInfo: {$IFDEF RTL200_UP}Controls.{$ENDIF RTL200_UP}THintInfo);\r\n end;\r\n\r\nprocedure TJvInterpreterFormsEvent.CloseEvent(Sender: TObject; var Action: TCloseAction);\r\nbegin\r\n CallFunction(nil, [O2V(Sender), Action]);\r\n Action := Args.Values[1];\r\nend;\r\n\r\nprocedure TJvInterpreterFormsEvent.CloseQueryEvent(Sender: TObject; var CanClose: Boolean);\r\nbegin\r\n CallFunction(nil, [O2V(Sender), CanClose]);\r\n CanClose := Args.Values[1];\r\nend;\r\n\r\nprocedure TJvInterpreterFormsEvent.ExceptionEvent(Sender: TObject; E: Exception);\r\nbegin\r\n CallFunction(nil, [O2V(Sender), O2V(E)]);\r\nend;\r\n\r\nprocedure TJvInterpreterFormsEvent.IdleEvent(Sender: TObject; var Done: Boolean);\r\nbegin\r\n CallFunction(nil, [O2V(Sender), Done]);\r\n Done := Args.Values[1];\r\nend;\r\n\r\nprocedure TJvInterpreterFormsEvent.ShowHintEvent(var HintStr: string; var CanShow: Boolean; var HintInfo: {$IFDEF RTL200_UP}Controls.{$ENDIF RTL200_UP}THintInfo);\r\nbegin\r\n{ CallFunction(nil, [HintStr, CanShow, HintInfo]);\r\n HintStr := Args.Values[0];\r\n CanShow := Args.Values[1];\r\n HintInfo := Args.Values[2]; }\r\n NotImplemented('TShowHintEvent');\r\n { need define record THintInfo }\r\nend;\r\n\r\nprocedure RegisterJvInterpreterAdapter(JvInterpreterAdapter: TJvInterpreterAdapter);\r\nconst\r\n cForms = 'Forms';\r\nbegin\r\n with JvInterpreterAdapter do\r\n begin\r\n { TScrollBarKind }\r\n AddConst(cForms, 'sbHorizontal', Ord(sbHorizontal));\r\n AddConst(cForms, 'sbVertical', Ord(sbVertical));\r\n { TControlScrollBar }\r\n AddClass(cForms, TControlScrollBar, 'TControlScrollBar');\r\n AddGet(TControlScrollBar, 'Assign', TControlScrollBar_Assign, 1, [varEmpty], varEmpty);\r\n AddGet(TControlScrollBar, 'Kind', TControlScrollBar_Read_Kind, 0, [varEmpty], varEmpty);\r\n AddGet(TControlScrollBar, 'ScrollPos', TControlScrollBar_Read_ScrollPos, 0, [varEmpty], varEmpty);\r\n AddGet(TControlScrollBar, 'Margin', TControlScrollBar_Read_Margin, 0, [varEmpty], varEmpty);\r\n AddSet(TControlScrollBar, 'Margin', TControlScrollBar_Write_Margin, 0, [varEmpty]);\r\n AddGet(TControlScrollBar, 'Increment', TControlScrollBar_Read_Increment, 0, [varEmpty], varEmpty);\r\n AddSet(TControlScrollBar, 'Increment', TControlScrollBar_Write_Increment, 0, [varEmpty]);\r\n AddGet(TControlScrollBar, 'Range', TControlScrollBar_Read_Range, 0, [varEmpty], varEmpty);\r\n AddSet(TControlScrollBar, 'Range', TControlScrollBar_Write_Range, 0, [varEmpty]);\r\n AddGet(TControlScrollBar, 'Position', TControlScrollBar_Read_Position, 0, [varEmpty], varEmpty);\r\n AddSet(TControlScrollBar, 'Position', TControlScrollBar_Write_Position, 0, [varEmpty]);\r\n AddGet(TControlScrollBar, 'Tracking', TControlScrollBar_Read_Tracking, 0, [varEmpty], varEmpty);\r\n AddSet(TControlScrollBar, 'Tracking', TControlScrollBar_Write_Tracking, 0, [varEmpty]);\r\n AddGet(TControlScrollBar, 'Visible', TControlScrollBar_Read_Visible, 0, [varEmpty], varEmpty);\r\n AddSet(TControlScrollBar, 'Visible', TControlScrollBar_Write_Visible, 0, [varEmpty]);\r\n { TScrollingWinControl }\r\n AddClass(cForms, TScrollingWinControl, 'TScrollingWinControl');\r\n AddGet(TScrollingWinControl, 'Create', TScrollingWinControl_Create, 1, [varEmpty], varEmpty);\r\n AddGet(TScrollingWinControl, 'DisableAutoRange', TScrollingWinControl_DisableAutoRange, 0, [varEmpty], varEmpty);\r\n AddGet(TScrollingWinControl, 'EnableAutoRange', TScrollingWinControl_EnableAutoRange, 0, [varEmpty], varEmpty);\r\n AddGet(TScrollingWinControl, 'ScrollInView', TScrollingWinControl_ScrollInView, 1, [varEmpty], varEmpty);\r\n AddGet(TScrollingWinControl, 'HorzScrollBar', TScrollingWinControl_Read_HorzScrollBar, 0, [varEmpty], varEmpty);\r\n AddSet(TScrollingWinControl, 'HorzScrollBar', TScrollingWinControl_Write_HorzScrollBar, 0, [varEmpty]);\r\n AddGet(TScrollingWinControl, 'VertScrollBar', TScrollingWinControl_Read_VertScrollBar, 0, [varEmpty], varEmpty);\r\n AddSet(TScrollingWinControl, 'VertScrollBar', TScrollingWinControl_Write_VertScrollBar, 0, [varEmpty]);\r\n { TFormBorderStyle }\r\n AddConst(cForms, 'bsNone', Ord(bsNone));\r\n AddConst(cForms, 'bsSingle', Ord(bsSingle));\r\n AddConst(cForms, 'bsSizeable', Ord(bsSizeable));\r\n AddConst(cForms, 'bsDialog', Ord(bsDialog));\r\n AddConst(cForms, 'bsToolWindow', Ord(bsToolWindow));\r\n AddConst(cForms, 'bsSizeToolWin', Ord(bsSizeToolWin));\r\n { TScrollBox }\r\n AddClass(cForms, TScrollBox, 'TScrollBox');\r\n AddGet(TScrollBox, 'Create', TScrollBox_Create, 1, [varEmpty], varEmpty);\r\n AddGet(TScrollBox, 'BorderStyle', TScrollBox_Read_BorderStyle, 0, [varEmpty], varEmpty);\r\n AddSet(TScrollBox, 'BorderStyle', TScrollBox_Write_BorderStyle, 0, [varEmpty]);\r\n { TWindowState }\r\n AddConst(cForms, 'wsNormal', Ord(wsNormal));\r\n AddConst(cForms, 'wsMinimized', Ord(wsMinimized));\r\n AddConst(cForms, 'wsMaximized', Ord(wsMaximized));\r\n { TFormStyle }\r\n AddConst(cForms, 'fsNormal', Ord(fsNormal));\r\n AddConst(cForms, 'fsMDIChild', Ord(fsMDIChild));\r\n AddConst(cForms, 'fsMDIForm', Ord(fsMDIForm));\r\n AddConst(cForms, 'fsStayOnTop', Ord(fsStayOnTop));\r\n { TBorderIcon }\r\n AddConst(cForms, 'biSystemMenu', Ord(biSystemMenu));\r\n AddConst(cForms, 'biMinimize', Ord(biMinimize));\r\n AddConst(cForms, 'biMaximize', Ord(biMaximize));\r\n AddConst(cForms, 'biHelp', Ord(biHelp));\r\n { TPosition }\r\n AddConst(cForms, 'poDesigned', Ord(poDesigned));\r\n AddConst(cForms, 'poDefault', Ord(poDefault));\r\n AddConst(cForms, 'poDefaultPosOnly', Ord(poDefaultPosOnly));\r\n AddConst(cForms, 'poDefaultSizeOnly', Ord(poDefaultSizeOnly));\r\n AddConst(cForms, 'poScreenCenter', Ord(poScreenCenter));\r\n { TPrintScale }\r\n AddConst(cForms, 'poNone', Ord(poNone));\r\n AddConst(cForms, 'poProportional', Ord(poProportional));\r\n AddConst(cForms, 'poPrintToFit', Ord(poPrintToFit));\r\n { TShowAction }\r\n AddConst(cForms, 'saIgnore', Ord(saIgnore));\r\n AddConst(cForms, 'saRestore', Ord(saRestore));\r\n AddConst(cForms, 'saMinimize', Ord(saMinimize));\r\n AddConst(cForms, 'saMaximize', Ord(saMaximize));\r\n { TTileMode }\r\n AddConst(cForms, 'tbHorizontal', Ord(tbHorizontal));\r\n AddConst(cForms, 'tbVertical', Ord(tbVertical));\r\n { TCloseAction }\r\n AddConst(cForms, 'caNone', Ord(caNone));\r\n AddConst(cForms, 'caHide', Ord(caHide));\r\n AddConst(cForms, 'caFree', Ord(caFree));\r\n AddConst(cForms, 'caMinimize', Ord(caMinimize));\r\n { TFormState }\r\n AddConst(cForms, 'fsCreating', Ord(fsCreating));\r\n AddConst(cForms, 'fsVisible', Ord(fsVisible));\r\n AddConst(cForms, 'fsShowing', Ord(fsShowing));\r\n AddConst(cForms, 'fsModal', Ord(fsModal));\r\n AddConst(cForms, 'fsCreatedMDIChild', Ord(fsCreatedMDIChild));\r\n AddConst(cForms, 'fsActivated', Ord(fsActivated));\r\n { TCustomForm }\r\n AddClass(cForms, TCustomForm, 'TCustomForm');\r\n AddGet(TCustomForm, 'Close', TCustomForm_Close, 0, [varEmpty], varEmpty);\r\n AddGet(TCustomForm, 'CloseQuery', TCustomForm_CloseQuery, 0, [varEmpty], varEmpty);\r\n AddGet(TCustomForm, 'DefocusControl', TCustomForm_DefocusControl, 2, [varEmpty, varEmpty], varEmpty);\r\n AddGet(TCustomForm, 'FocusControl', TCustomForm_FocusControl, 1, [varEmpty], varEmpty);\r\n AddGet(TCustomForm, 'GetFormImage', TCustomForm_GetFormImage, 0, [varEmpty], varEmpty);\r\n AddGet(TCustomForm, 'Hide', TCustomForm_Hide, 0, [varEmpty], varEmpty);\r\n AddGet(TCustomForm, 'Print', TCustomForm_Print, 0, [varEmpty], varEmpty);\r\n AddGet(TCustomForm, 'Release', TCustomForm_Release, 0, [varEmpty], varEmpty);\r\n AddGet(TCustomForm, 'SendCancelMode', TCustomForm_SendCancelMode, 1, [varEmpty], varEmpty);\r\n AddGet(TCustomForm, 'SetFocus', TCustomForm_SetFocus, 0, [varEmpty], varEmpty);\r\n AddGet(TCustomForm, 'SetFocusedControl', TCustomForm_SetFocusedControl, 1, [varEmpty], varEmpty);\r\n AddGet(TCustomForm, 'Show', TCustomForm_Show, 0, [varEmpty], varEmpty);\r\n AddGet(TCustomForm, 'ShowModal', TCustomForm_ShowModal, 0, [varEmpty], varEmpty);\r\n AddGet(TCustomForm, 'Active', TCustomForm_Read_Active, 0, [varEmpty], varEmpty);\r\n AddGet(TCustomForm, 'ActiveControl', TCustomForm_Read_ActiveControl, 0, [varEmpty], varEmpty);\r\n AddSet(TCustomForm, 'ActiveControl', TCustomForm_Write_ActiveControl, 0, [varEmpty]);\r\n AddGet(TCustomForm, 'ActiveOleControl', TCustomForm_Read_ActiveOleControl, 0, [varEmpty], varEmpty);\r\n AddSet(TCustomForm, 'ActiveOleControl', TCustomForm_Write_ActiveOleControl, 0, [varEmpty]);\r\n AddGet(TCustomForm, 'Canvas', TCustomForm_Read_Canvas, 0, [varEmpty], varEmpty);\r\n AddGet(TCustomForm, 'DropTarget', TCustomForm_Read_DropTarget, 0, [varEmpty], varEmpty);\r\n AddSet(TCustomForm, 'DropTarget', TCustomForm_Write_DropTarget, 0, [varEmpty]);\r\n AddGet(TCustomForm, 'HelpFile', TCustomForm_Read_HelpFile, 0, [varEmpty], varEmpty);\r\n AddSet(TCustomForm, 'HelpFile', TCustomForm_Write_HelpFile, 0, [varEmpty]);\r\n AddGet(TCustomForm, 'KeyPreview', TCustomForm_Read_KeyPreview, 0, [varEmpty], varEmpty);\r\n AddSet(TCustomForm, 'KeyPreview', TCustomForm_Write_KeyPreview, 0, [varEmpty]);\r\n AddGet(TCustomForm, 'Menu', TCustomForm_Read_Menu, 0, [varEmpty], varEmpty);\r\n AddSet(TCustomForm, 'Menu', TCustomForm_Write_Menu, 0, [varEmpty]);\r\n AddGet(TCustomForm, 'ModalResult', TCustomForm_Read_ModalResult, 0, [varEmpty], varEmpty);\r\n AddSet(TCustomForm, 'ModalResult', TCustomForm_Write_ModalResult, 0, [varEmpty]);\r\n AddGet(TCustomForm, 'WindowState', TCustomForm_Read_WindowState, 0, [varEmpty], varEmpty);\r\n AddSet(TCustomForm, 'WindowState', TCustomForm_Write_WindowState, 0, [varEmpty]);\r\n { TForm }\r\n AddClass(cForms, TForm, 'TForm');\r\n AddGet(TForm, 'Create', TForm_Create, 1, [varEmpty], varEmpty);\r\n {$IFDEF DELPHI}\r\n AddGet(TForm, 'CreateNew', TForm_CreateNew, 1, [varEmpty], varEmpty);\r\n {$ELSE}\r\n AddGet(TForm, 'CreateNew', TForm_CreateNew, 2, [varEmpty, varEmpty], varEmpty);\r\n {$ENDIF DELPHI}\r\n AddGet(TForm, 'ArrangeIcons', TForm_ArrangeIcons, 0, [varEmpty], varEmpty);\r\n AddGet(TForm, 'Cascade', TForm_Cascade, 0, [varEmpty], varEmpty);\r\n AddGet(TForm, 'Next', TForm_Next, 0, [varEmpty], varEmpty);\r\n AddGet(TForm, 'Previous', TForm_Previous, 0, [varEmpty], varEmpty);\r\n AddGet(TForm, 'Tile', TForm_Tile, 0, [varEmpty], varEmpty);\r\n { TDataModule }\r\n AddClass(cForms, TDataModule, 'TDataModule');\r\n AddGet(TDataModule, 'Create', TDataModule_Create, 1, [varEmpty], varEmpty);\r\n {$IFDEF DELPHI}\r\n AddGet(TDataModule, 'CreateNew', TDataModule_CreateNew, 1, [varEmpty], varEmpty);\r\n {$ELSE}\r\n AddGet(TDataModule, 'CreateNew', TDataModule_CreateNew, 2, [varEmpty, varEmpty], varEmpty);\r\n {$ENDIF DELPHI}\r\n { TScreen }\r\n AddClass(cForms, TScreen, 'TScreen');\r\n AddGet(TScreen, 'Create', TScreen_Create, 1, [varEmpty], varEmpty);\r\n AddGet(TScreen, 'ActiveControl', TScreen_Read_ActiveControl, 0, [varEmpty], varEmpty);\r\n AddGet(TScreen, 'ActiveCustomForm', TScreen_Read_ActiveCustomForm, 0, [varEmpty], varEmpty);\r\n AddGet(TScreen, 'ActiveForm', TScreen_Read_ActiveForm, 0, [varEmpty], varEmpty);\r\n AddGet(TScreen, 'CustomFormCount', TScreen_Read_CustomFormCount, 0, [varEmpty], varEmpty);\r\n AddGet(TScreen, 'CustomForms', TScreen_Read_CustomForms, 1, [varEmpty], varEmpty);\r\n AddGet(TScreen, 'Cursor', TScreen_Read_Cursor, 0, [varEmpty], varEmpty);\r\n AddSet(TScreen, 'Cursor', TScreen_Write_Cursor, 0, [varEmpty]);\r\n AddGet(TScreen, 'Cursors', TScreen_Read_Cursors, 1, [varEmpty], varEmpty);\r\n AddSet(TScreen, 'Cursors', TScreen_Write_Cursors, 1, [varNull]);\r\n AddGet(TScreen, 'DataModules', TScreen_Read_DataModules, 1, [varEmpty], varEmpty);\r\n AddGet(TScreen, 'DataModuleCount', TScreen_Read_DataModuleCount, 0, [varEmpty], varEmpty);\r\n AddGet(TScreen, 'IconFont', TScreen_Read_IconFont, 0, [varEmpty], varEmpty);\r\n AddSet(TScreen, 'IconFont', TScreen_Write_IconFont, 0, [varEmpty]);\r\n AddGet(TScreen, 'Fonts', TScreen_Read_Fonts, 0, [varEmpty], varEmpty);\r\n AddGet(TScreen, 'FormCount', TScreen_Read_FormCount, 0, [varEmpty], varEmpty);\r\n AddIGet(TScreen, cForms, TScreen_Read_Forms, 1, [varEmpty], varEmpty); // ivan_ra\r\n AddGet(TScreen, 'Imes', TScreen_Read_Imes, 0, [varEmpty], varEmpty);\r\n AddGet(TScreen, 'DefaultIme', TScreen_Read_DefaultIme, 0, [varEmpty], varEmpty);\r\n AddGet(TScreen, 'DefaultKbLayout', TScreen_Read_DefaultKbLayout, 0, [varEmpty], varEmpty);\r\n AddGet(TScreen, 'Height', TScreen_Read_Height, 0, [varEmpty], varEmpty);\r\n AddGet(TScreen, 'PixelsPerInch', TScreen_Read_PixelsPerInch, 0, [varEmpty], varEmpty);\r\n AddGet(TScreen, 'Width', TScreen_Read_Width, 0, [varEmpty], varEmpty);\r\n { TTimerMode }\r\n AddConst(cForms, 'tmShow', Ord(tmShow));\r\n AddConst(cForms, 'tmHide', Ord(tmHide));\r\n { TApplication }\r\n AddClass(cForms, TApplication, 'TApplication');\r\n AddGet(TApplication, 'Create', TApplication_Create, 1, [varEmpty], varEmpty);\r\n AddGet(TApplication, 'BringToFront', TApplication_BringToFront, 0, [varEmpty], varEmpty);\r\n AddGet(TApplication, 'ControlDestroyed', TApplication_ControlDestroyed, 1, [varEmpty], varEmpty);\r\n AddGet(TApplication, 'CancelHint', TApplication_CancelHint, 0, [varEmpty], varEmpty);\r\n AddGet(TApplication, 'CreateForm', TApplication_CreateForm, 2, [varEmpty, varByRef], varEmpty);\r\n AddGet(TApplication, 'HandleException', TApplication_HandleException, 1, [varEmpty], varEmpty);\r\n AddGet(TApplication, 'HandleMessage', TApplication_HandleMessage, 0, [varEmpty], varEmpty);\r\n AddGet(TApplication, 'HelpCommand', TApplication_HelpCommand, 2, [varEmpty, varEmpty], varEmpty);\r\n AddGet(TApplication, 'HelpContext', TApplication_HelpContext, 1, [varEmpty], varEmpty);\r\n AddGet(TApplication, 'HelpJump', TApplication_HelpJump, 1, [varEmpty], varEmpty);\r\n AddGet(TApplication, 'HideHint', TApplication_HideHint, 0, [varEmpty], varEmpty);\r\n AddGet(TApplication, 'Initialize', TApplication_Initialize, 0, [varEmpty], varEmpty);\r\n AddGet(TApplication, 'MessageBox', TApplication_MessageBox, 3, [varEmpty, varEmpty, varEmpty], varEmpty);\r\n AddGet(TApplication, 'Minimize', TApplication_Minimize, 0, [varEmpty], varEmpty);\r\n AddGet(TApplication, 'NormalizeAllTopMosts', TApplication_NormalizeAllTopMosts, 0, [varEmpty], varEmpty);\r\n AddGet(TApplication, 'NormalizeTopMosts', TApplication_NormalizeTopMosts, 0, [varEmpty], varEmpty);\r\n AddGet(TApplication, 'ProcessMessages', TApplication_ProcessMessages, 0, [varEmpty], varEmpty);\r\n AddGet(TApplication, 'Restore', TApplication_Restore, 0, [varEmpty], varEmpty);\r\n AddGet(TApplication, 'RestoreTopMosts', TApplication_RestoreTopMosts, 0, [varEmpty], varEmpty);\r\n AddGet(TApplication, 'Run', TApplication_Run, 0, [varEmpty], varEmpty);\r\n AddGet(TApplication, 'ShowException', TApplication_ShowException, 1, [varEmpty], varEmpty);\r\n AddGet(TApplication, 'Terminate', TApplication_Terminate, 0, [varEmpty], varEmpty);\r\n AddGet(TApplication, 'Active', TApplication_Read_Active, 0, [varEmpty], varEmpty);\r\n AddGet(TApplication, 'CurrentHelpFile', TApplication_Read_CurrentHelpFile, 0, [varEmpty], varEmpty);\r\n AddGet(TApplication, 'DialogHandle', TApplication_Read_DialogHandle, 0, [varEmpty], varEmpty);\r\n AddSet(TApplication, 'DialogHandle', TApplication_Write_DialogHandle, 0, [varEmpty]);\r\n AddGet(TApplication, 'ExeName', TApplication_Read_ExeName, 0, [varEmpty], varEmpty);\r\n AddGet(TApplication, 'Handle', TApplication_Read_Handle, 0, [varEmpty], varEmpty);\r\n AddSet(TApplication, 'Handle', TApplication_Write_Handle, 0, [varEmpty]);\r\n AddGet(TApplication, 'HelpFile', TApplication_Read_HelpFile, 0, [varEmpty], varEmpty);\r\n AddSet(TApplication, 'HelpFile', TApplication_Write_HelpFile, 0, [varEmpty]);\r\n AddGet(TApplication, 'Hint', TApplication_Read_Hint, 0, [varEmpty], varEmpty);\r\n AddSet(TApplication, 'Hint', TApplication_Write_Hint, 0, [varEmpty]);\r\n AddGet(TApplication, 'HintColor', TApplication_Read_HintColor, 0, [varEmpty], varEmpty);\r\n AddSet(TApplication, 'HintColor', TApplication_Write_HintColor, 0, [varEmpty]);\r\n AddGet(TApplication, 'HintPause', TApplication_Read_HintPause, 0, [varEmpty], varEmpty);\r\n AddSet(TApplication, 'HintPause', TApplication_Write_HintPause, 0, [varEmpty]);\r\n AddGet(TApplication, 'HintShortPause', TApplication_Read_HintShortPause, 0, [varEmpty], varEmpty);\r\n AddSet(TApplication, 'HintShortPause', TApplication_Write_HintShortPause, 0, [varEmpty]);\r\n AddGet(TApplication, 'HintHidePause', TApplication_Read_HintHidePause, 0, [varEmpty], varEmpty);\r\n AddSet(TApplication, 'HintHidePause', TApplication_Write_HintHidePause, 0, [varEmpty]);\r\n AddGet(TApplication, 'Icon', TApplication_Read_Icon, 0, [varEmpty], varEmpty);\r\n AddSet(TApplication, 'Icon', TApplication_Write_Icon, 0, [varEmpty]);\r\n AddGet(TApplication, 'MainForm', TApplication_Read_MainForm, 0, [varEmpty], varEmpty);\r\n AddGet(TApplication, 'ShowHint', TApplication_Read_ShowHint, 0, [varEmpty], varEmpty);\r\n AddSet(TApplication, 'ShowHint', TApplication_Write_ShowHint, 0, [varEmpty]);\r\n AddGet(TApplication, 'ShowMainForm', TApplication_Read_ShowMainForm, 0, [varEmpty], varEmpty);\r\n AddSet(TApplication, 'ShowMainForm', TApplication_Write_ShowMainForm, 0, [varEmpty]);\r\n AddGet(TApplication, 'Terminated', TApplication_Read_Terminated, 0, [varEmpty], varEmpty);\r\n AddGet(TApplication, 'Title', TApplication_Read_Title, 0, [varEmpty], varEmpty);\r\n AddSet(TApplication, 'Title', TApplication_Write_Title, 0, [varEmpty]);\r\n AddGet(TApplication, 'UpdateFormatSettings', TApplication_Read_UpdateFormatSettings, 0, [varEmpty], varEmpty);\r\n AddSet(TApplication, 'UpdateFormatSettings', TApplication_Write_UpdateFormatSettings, 0, [varEmpty]);\r\n AddGet(TApplication, 'UpdateMetricSettings', TApplication_Read_UpdateMetricSettings, 0, [varEmpty], varEmpty);\r\n AddSet(TApplication, 'UpdateMetricSettings', TApplication_Write_UpdateMetricSettings, 0, [varEmpty]);\r\n\r\n AddFunction(cForms, 'Application', JvInterpreter_Application, 0, [varEmpty], varEmpty);\r\n AddFunction(cForms, 'Screen', JvInterpreter_Screen, 0, [varEmpty], varEmpty);\r\n\r\n AddFunction(cForms, 'GetParentForm', JvInterpreter_GetParentForm, 1, [varEmpty], varEmpty);\r\n AddFunction(cForms, 'ValidParentForm', JvInterpreter_ValidParentForm, 1, [varEmpty], varEmpty);\r\n AddFunction(cForms, 'DisableTaskWindows', JvInterpreter_DisableTaskWindows, 1, [varEmpty], varEmpty);\r\n AddFunction(cForms, 'EnableTaskWindows', JvInterpreter_EnableTaskWindows, 1, [varEmpty], varEmpty);\r\n AddFunction(cForms, 'IsAccel', JvInterpreter_IsAccel, 2, [varEmpty, varEmpty], varEmpty);\r\n AddFunction(cForms, 'KeysToShiftState', JvInterpreter_KeysToShiftState, 1, [varEmpty], varEmpty);\r\n AddFunction(cForms, 'KeyDataToShiftState', JvInterpreter_KeyDataToShiftState, 1, [varEmpty], varEmpty);\r\n AddFunction(cForms, 'ForegroundTask', JvInterpreter_ForegroundTask, 0, [varEmpty], varEmpty);\r\n\r\n AddHandler(cForms, 'TCloseEvent', TJvInterpreterFormsEvent, @TJvInterpreterFormsEvent.CloseEvent);\r\n AddHandler(cForms, 'TCloseQueryEvent', TJvInterpreterFormsEvent, @TJvInterpreterFormsEvent.CloseQueryEvent);\r\n AddHandler(cForms, 'TExceptionEvent', TJvInterpreterFormsEvent, @TJvInterpreterFormsEvent.ExceptionEvent);\r\n AddHandler(cForms, 'TIdleEvent', TJvInterpreterFormsEvent, @TJvInterpreterFormsEvent.IdleEvent);\r\n AddHandler(cForms, 'TShowHintEvent', TJvInterpreterFormsEvent, @TJvInterpreterFormsEvent.ShowHintEvent);\r\n end;\r\n RegisterClasses([TScrollBox]);\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvInterpreter_Graphics.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvInterpreter_Graphics.PAS, released on 2002-07-04.\r\n\r\nThe Initial Developers of the Original Code are: Andrei Prygounkov \r\nCopyright (c) 1999, 2002 Andrei Prygounkov\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nDescription : adapter unit - converts JvInterpreter calls to delphi calls\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvInterpreter_Graphics.pas 13173 2011-11-19 12:43:58Z ahuser $\r\n\r\nunit JvInterpreter_Graphics;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n JvInterpreter;\r\n\r\nprocedure RegisterJvInterpreterAdapter(JvInterpreterAdapter: TJvInterpreterAdapter);\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvInterpreter_Graphics.pas $';\r\n Revision: '$Revision: 13173 $';\r\n Date: '$Date: 2011-11-19 13:43:58 +0100 (sam. 19 nov. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n Classes,\r\n JvInterpreter_Windows,\r\n Windows, Graphics;\r\n\r\n{ TFont }\r\n\r\n{ constructor Create }\r\n\r\nprocedure TFont_Create(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TFont.Create);\r\nend;\r\n\r\n{ procedure Assign(Source: TPersistent); }\r\n\r\nprocedure TFont_Assign(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TFont(Args.Obj).Assign(V2O(Args.Values[0]) as TPersistent);\r\nend;\r\n\r\n{ property Read Handle: HFont }\r\n\r\nprocedure TFont_Read_Handle(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := NativeInt(TFont(Args.Obj).Handle);\r\nend;\r\n\r\n{ property Write Handle(Value: HFont) }\r\n\r\nprocedure TFont_Write_Handle(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TFont(Args.Obj).Handle := Value;\r\nend;\r\n\r\n{ property Read PixelsPerInch: Integer }\r\n\r\nprocedure TFont_Read_PixelsPerInch(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TFont(Args.Obj).PixelsPerInch;\r\nend;\r\n\r\n{ property Write PixelsPerInch(Value: Integer) }\r\n\r\nprocedure TFont_Write_PixelsPerInch(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TFont(Args.Obj).PixelsPerInch := Value;\r\nend;\r\n\r\n{ property Read Charset: TFontCharset }\r\n\r\nprocedure TFont_Read_Charset(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TFont(Args.Obj).Charset;\r\nend;\r\n\r\n{ property Write Charset(Value: TFontCharset) }\r\n\r\nprocedure TFont_Write_Charset(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TFont(Args.Obj).Charset := Value;\r\nend;\r\n\r\n{ property Read Color: TColor }\r\n\r\nprocedure TFont_Read_Color(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TFont(Args.Obj).Color;\r\nend;\r\n\r\n{ property Write Color(Value: TColor) }\r\n\r\nprocedure TFont_Write_Color(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TFont(Args.Obj).Color := Value;\r\nend;\r\n\r\n{ property Read Height: Integer }\r\n\r\nprocedure TFont_Read_Height(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TFont(Args.Obj).Height;\r\nend;\r\n\r\n{ property Write Height(Value: Integer) }\r\n\r\nprocedure TFont_Write_Height(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TFont(Args.Obj).Height := Value;\r\nend;\r\n\r\n{ property Read Name: TFontName }\r\n\r\nprocedure TFont_Read_Name(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TFont(Args.Obj).Name;\r\nend;\r\n\r\n{ property Write Name(Value: TFontName) }\r\n\r\nprocedure TFont_Write_Name(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TFont(Args.Obj).Name := Value;\r\nend;\r\n\r\n{ property Read Pitch: TFontPitch }\r\n\r\nprocedure TFont_Read_Pitch(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TFont(Args.Obj).Pitch;\r\nend;\r\n\r\n{ property Write Pitch(Value: TFontPitch) }\r\n\r\nprocedure TFont_Write_Pitch(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TFont(Args.Obj).Pitch := Value;\r\nend;\r\n\r\n{ property Read Size: Integer }\r\n\r\nprocedure TFont_Read_Size(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TFont(Args.Obj).Size;\r\nend;\r\n\r\n{ property Write Size(Value: Integer) }\r\n\r\nprocedure TFont_Write_Size(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TFont(Args.Obj).Size := Value;\r\nend;\r\n\r\n{ property Read Style: TFontStyles }\r\n\r\nprocedure TFont_Read_Style(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := S2V(byte(TFont(Args.Obj).Style));\r\nend;\r\n\r\n{ property Write Style(Value: TFontStyles) }\r\n\r\nprocedure TFont_Write_Style(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TFont(Args.Obj).Style := TFontStyles(byte(V2S(Value)));\r\nend;\r\n\r\n{ TPen }\r\n\r\n{ constructor Create }\r\n\r\nprocedure TPen_Create(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TPen.Create);\r\nend;\r\n\r\n{ procedure Assign(Source: TPersistent); }\r\n\r\nprocedure TPen_Assign(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TPen(Args.Obj).Assign(V2O(Args.Values[0]) as TPersistent);\r\nend;\r\n\r\n{ property Read Handle: HPen }\r\n\r\nprocedure TPen_Read_Handle(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := NativeInt(TPen(Args.Obj).Handle);\r\nend;\r\n\r\n{ property Write Handle(Value: HPen) }\r\n\r\nprocedure TPen_Write_Handle(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TPen(Args.Obj).Handle := Value;\r\nend;\r\n\r\n{ property Read Color: TColor }\r\n\r\nprocedure TPen_Read_Color(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TPen(Args.Obj).Color;\r\nend;\r\n\r\n{ property Write Color(Value: TColor) }\r\n\r\nprocedure TPen_Write_Color(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TPen(Args.Obj).Color := Value;\r\nend;\r\n\r\n{ property Read Mode: TPenMode }\r\n\r\nprocedure TPen_Read_Mode(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TPen(Args.Obj).Mode;\r\nend;\r\n\r\n{ property Write Mode(Value: TPenMode) }\r\n\r\nprocedure TPen_Write_Mode(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TPen(Args.Obj).Mode := Value;\r\nend;\r\n\r\n{ property Read Style: TPenStyle }\r\n\r\nprocedure TPen_Read_Style(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TPen(Args.Obj).Style;\r\nend;\r\n\r\n{ property Write Style(Value: TPenStyle) }\r\n\r\nprocedure TPen_Write_Style(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TPen(Args.Obj).Style := Value;\r\nend;\r\n\r\n{ property Read Width: Integer }\r\n\r\nprocedure TPen_Read_Width(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TPen(Args.Obj).Width;\r\nend;\r\n\r\n{ property Write Width(Value: Integer) }\r\n\r\nprocedure TPen_Write_Width(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TPen(Args.Obj).Width := Value;\r\nend;\r\n\r\n{ TBrush }\r\n\r\n{ constructor Create }\r\n\r\nprocedure TBrush_Create(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TBrush.Create);\r\nend;\r\n\r\n{ procedure Assign(Source: TPersistent); }\r\n\r\nprocedure TBrush_Assign(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TBrush(Args.Obj).Assign(V2O(Args.Values[0]) as TPersistent);\r\nend;\r\n\r\n{ property Read Bitmap: TBitmap }\r\n\r\nprocedure TBrush_Read_Bitmap(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TBrush(Args.Obj).Bitmap);\r\nend;\r\n\r\n{ property Write Bitmap(Value: TBitmap) }\r\n\r\nprocedure TBrush_Write_Bitmap(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TBrush(Args.Obj).Bitmap := V2O(Value) as TBitmap;\r\nend;\r\n\r\n{ property Read Handle: HBrush }\r\n\r\nprocedure TBrush_Read_Handle(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := NativeInt(TBrush(Args.Obj).Handle);\r\nend;\r\n\r\n{ property Write Handle(Value: HBrush) }\r\n\r\nprocedure TBrush_Write_Handle(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TBrush(Args.Obj).Handle := Value;\r\nend;\r\n\r\n{ property Read Color: TColor }\r\n\r\nprocedure TBrush_Read_Color(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TBrush(Args.Obj).Color;\r\nend;\r\n\r\n{ property Write Color(Value: TColor) }\r\n\r\nprocedure TBrush_Write_Color(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TBrush(Args.Obj).Color := Value;\r\nend;\r\n\r\n{ property Read Style: TBrushStyle }\r\n\r\nprocedure TBrush_Read_Style(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TBrush(Args.Obj).Style;\r\nend;\r\n\r\n{ property Write Style(Value: TBrushStyle) }\r\n\r\nprocedure TBrush_Write_Style(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TBrush(Args.Obj).Style := Value;\r\nend;\r\n\r\n{ TCanvas }\r\n\r\n{ constructor Create }\r\n\r\nprocedure TCanvas_Create(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TCanvas.Create);\r\nend;\r\n\r\n{ procedure Arc(X1, Y1, X2, Y2, X3, Y3, X4, Y4: Integer); }\r\n\r\nprocedure TCanvas_Arc(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TCanvas(Args.Obj).Arc(Args.Values[0], Args.Values[1], Args.Values[2], Args.Values[3], Args.Values[4], Args.Values[5],\r\n Args.Values[6], Args.Values[7]);\r\nend;\r\n\r\n{ procedure BrushCopy(const Dest: TRect; Bitmap: TBitmap; const Source: TRect; Color: TColor); }\r\n\r\n\r\nprocedure TCanvas_BrushCopy(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TCanvas(Args.Obj).BrushCopy(Var2Rect(Args.Values[0]), V2O(Args.Values[1]) as TBitmap, Var2Rect(Args.Values[2]),\r\n Args.Values[3]);\r\nend;\r\n\r\n\r\n{ procedure Chord(X1, Y1, X2, Y2, X3, Y3, X4, Y4: Integer); }\r\n\r\nprocedure TCanvas_Chord(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TCanvas(Args.Obj).Chord(Args.Values[0], Args.Values[1], Args.Values[2], Args.Values[3], Args.Values[4],\r\n Args.Values[5], Args.Values[6], Args.Values[7]);\r\nend;\r\n\r\n{ procedure CopyRect(const Dest: TRect; Canvas: TCanvas; const Source: TRect); }\r\n\r\nprocedure TCanvas_CopyRect(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TCanvas(Args.Obj).CopyRect(Var2Rect(Args.Values[0]), V2O(Args.Values[1]) as TCanvas, Var2Rect(Args.Values[2]));\r\nend;\r\n\r\n{ procedure Draw(X, Y: Integer; Graphic: TGraphic); }\r\n\r\nprocedure TCanvas_Draw(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TCanvas(Args.Obj).Draw(Args.Values[0], Args.Values[1], V2O(Args.Values[2]) as TGraphic);\r\nend;\r\n\r\n{ procedure DrawFocusRect(const Rect: TRect); }\r\n\r\nprocedure TCanvas_DrawFocusRect(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TCanvas(Args.Obj).DrawFocusRect(Var2Rect((Args.Values[0])));\r\nend;\r\n\r\n{ procedure Ellipse(X1, Y1, X2, Y2: Integer); }\r\n\r\nprocedure TCanvas_Ellipse(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TCanvas(Args.Obj).Ellipse(Args.Values[0], Args.Values[1], Args.Values[2], Args.Values[3]);\r\nend;\r\n\r\n{ procedure FillRect(const Rect: TRect); }\r\n\r\nprocedure TCanvas_FillRect(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TCanvas(Args.Obj).FillRect(Var2Rect(Args.Values[0]));\r\nend;\r\n\r\n\r\n\r\n{ procedure FloodFill(X, Y: Integer; Color: TColor; FillStyle: TFillStyle); }\r\n\r\nprocedure TCanvas_FloodFill(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TCanvas(Args.Obj).FloodFill(Args.Values[0], Args.Values[1], Args.Values[2], Args.Values[3]);\r\nend;\r\n\r\n{ procedure FrameRect(const Rect: TRect); }\r\n\r\nprocedure TCanvas_FrameRect(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TCanvas(Args.Obj).FrameRect(Var2Rect(Args.Values[0]));\r\nend;\r\n\r\n\r\n\r\n{ procedure LineTo(X, Y: Integer); }\r\n\r\nprocedure TCanvas_LineTo(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TCanvas(Args.Obj).LineTo(Args.Values[0], Args.Values[1]);\r\nend;\r\n\r\n{ procedure Lock; }\r\n\r\nprocedure TCanvas_Lock(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TCanvas(Args.Obj).Lock;\r\nend;\r\n\r\n\r\n{ procedure MoveTo(X, Y: Integer); }\r\n\r\nprocedure TCanvas_MoveTo(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TCanvas(Args.Obj).MoveTo(Args.Values[0], Args.Values[1]);\r\nend;\r\n\r\n{ procedure Pie(X1, Y1, X2, Y2, X3, Y3, X4, Y4: Integer); }\r\n\r\nprocedure TCanvas_Pie(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TCanvas(Args.Obj).Pie(Args.Values[0], Args.Values[1], Args.Values[2], Args.Values[3], Args.Values[4], Args.Values[5],\r\n Args.Values[6], Args.Values[7]);\r\nend;\r\n\r\n{ procedure Polygon(const Points: array of TPoint); }\r\n\r\nprocedure TCanvas_Polygon(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n// TCanvas(Args.Obj).Polygon(Args.Values[0]);\r\n NotImplemented('TCanvas.Polygon');\r\nend;\r\n\r\n{ procedure Polyline(const Points: array of TPoint); }\r\n\r\nprocedure TCanvas_Polyline(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n// TCanvas(Args.Obj).Polyline(Args.Values[0]);\r\n NotImplemented('TCanvas.Polyline');\r\nend;\r\n\r\n{ procedure Rectangle(X1, Y1, X2, Y2: Integer); }\r\n\r\nprocedure TCanvas_Rectangle(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TCanvas(Args.Obj).Rectangle(Args.Values[0], Args.Values[1], Args.Values[2], Args.Values[3]);\r\nend;\r\n\r\n{ procedure Refresh; }\r\n\r\nprocedure TCanvas_Refresh(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TCanvas(Args.Obj).Refresh;\r\nend;\r\n\r\n{ procedure RoundRect(X1, Y1, X2, Y2, X3, Y3: Integer); }\r\n\r\nprocedure TCanvas_RoundRect(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TCanvas(Args.Obj).RoundRect(Args.Values[0], Args.Values[1], Args.Values[2], Args.Values[3], Args.Values[4],\r\n Args.Values[5]);\r\nend;\r\n\r\n{ procedure StretchDraw(const Rect: TRect; Graphic: TGraphic); }\r\n\r\nprocedure TCanvas_StretchDraw(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TCanvas(Args.Obj).StretchDraw(Var2Rect(Args.Values[0]), V2O(Args.Values[1]) as TGraphic);\r\nend;\r\n\r\n{ function TextExtent(const Text: string): TSize; }\r\n\r\nprocedure TCanvas_TextExtent(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n// Value := TCanvas(Args.Obj).TextExtent(Args.Values[0]);\r\n NotImplemented('TCanvas.TextExtent');\r\nend;\r\n\r\n{ function TextHeight(const Text: string): Integer; }\r\n\r\nprocedure TCanvas_TextHeight(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TCanvas(Args.Obj).TextHeight(Args.Values[0]);\r\nend;\r\n\r\n{ procedure TextOut(X, Y: Integer; const Text: string); }\r\n\r\nprocedure TCanvas_TextOut(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TCanvas(Args.Obj).TextOut(Args.Values[0], Args.Values[1], Args.Values[2]);\r\nend;\r\n\r\n{ procedure TextRect(Rect: TRect; X, Y: Integer; const Text: string); }\r\n\r\nprocedure TCanvas_TextRect(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TCanvas(Args.Obj).TextRect(Var2Rect(Args.Values[0]), Args.Values[1], Args.Values[2], Args.Values[3]);\r\nend;\r\n\r\n{ function TextWidth(const Text: string): Integer; }\r\n\r\nprocedure TCanvas_TextWidth(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TCanvas(Args.Obj).TextWidth(Args.Values[0]);\r\nend;\r\n\r\n\r\n{ function TryLock: Boolean; }\r\n\r\nprocedure TCanvas_TryLock(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TCanvas(Args.Obj).TryLock;\r\nend;\r\n\r\n{ procedure Unlock; }\r\n\r\nprocedure TCanvas_Unlock(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TCanvas(Args.Obj).Unlock;\r\nend;\r\n\r\n\r\n\r\n{ property Read ClipRect: TRect }\r\n\r\nprocedure TCanvas_Read_ClipRect(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := Rect2Var(TCanvas(Args.Obj).ClipRect);\r\nend;\r\n\r\n{ property Read Handle: HDC }\r\n\r\nprocedure TCanvas_Read_Handle(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := NativeInt(TCanvas(Args.Obj).Handle);\r\nend;\r\n\r\n{ property Write Handle(Value: HDC) }\r\n\r\nprocedure TCanvas_Write_Handle(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TCanvas(Args.Obj).Handle := Value;\r\nend;\r\n\r\n{ property Read LockCount: Integer }\r\n\r\nprocedure TCanvas_Read_LockCount(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TCanvas(Args.Obj).LockCount;\r\nend;\r\n\r\n\r\n{ property Read PenPos: TPoint }\r\n\r\nprocedure TCanvas_Read_PenPos(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := Point2Var(TCanvas(Args.Obj).PenPos);\r\nend;\r\n\r\n{ property Write PenPos(Value: TPoint) }\r\n\r\nprocedure TCanvas_Write_PenPos(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TCanvas(Args.Obj).PenPos := Var2Point(Value);\r\nend;\r\n\r\n{ property Read Brush: TBrush }\r\n\r\nprocedure TCanvas_Read_Brush(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TCanvas(Args.Obj).Brush);\r\nend;\r\n\r\n{ property Write Brush(Value: TBrush) }\r\n\r\nprocedure TCanvas_Write_Brush(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TCanvas(Args.Obj).Brush := V2O(Value) as TBrush;\r\nend;\r\n\r\n{ property Read CopyMode: TCopyMode }\r\n\r\nprocedure TCanvas_Read_CopyMode(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TCanvas(Args.Obj).CopyMode;\r\nend;\r\n\r\n{ property Write CopyMode(Value: TCopyMode) }\r\n\r\nprocedure TCanvas_Write_CopyMode(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TCanvas(Args.Obj).CopyMode := Value;\r\nend;\r\n\r\n{ property Read Font: TFont }\r\n\r\nprocedure TCanvas_Read_Font(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TCanvas(Args.Obj).Font);\r\nend;\r\n\r\n{ property Write Font(Value: TFont) }\r\n\r\nprocedure TCanvas_Write_Font(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TCanvas(Args.Obj).Font := V2O(Value) as TFont;\r\nend;\r\n\r\n{ property Read Pen: TPen }\r\n\r\nprocedure TCanvas_Read_Pen(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TCanvas(Args.Obj).Pen);\r\nend;\r\n\r\n{ property Write Pen(Value: TPen) }\r\n\r\nprocedure TCanvas_Write_Pen(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TCanvas(Args.Obj).Pen := V2O(Value) as TPen;\r\nend;\r\n\r\n{ TGraphic }\r\n\r\n{ procedure LoadFromFile(const Filename: string); }\r\n\r\nprocedure TGraphic_LoadFromFile(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TGraphic(Args.Obj).LoadFromFile(Args.Values[0]);\r\nend;\r\n\r\n{ procedure SaveToFile(const Filename: string); }\r\n\r\nprocedure TGraphic_SaveToFile(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TGraphic(Args.Obj).SaveToFile(Args.Values[0]);\r\nend;\r\n\r\n{ procedure LoadFromStream(Stream: TStream); }\r\n\r\nprocedure TGraphic_LoadFromStream(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TGraphic(Args.Obj).LoadFromStream(V2O(Args.Values[0]) as TStream);\r\nend;\r\n\r\n{ procedure SaveToStream(Stream: TStream); }\r\n\r\nprocedure TGraphic_SaveToStream(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TGraphic(Args.Obj).SaveToStream(V2O(Args.Values[0]) as TStream);\r\nend;\r\n\r\n\r\n\r\n{ procedure LoadFromClipboardFormat(AFormat: Word; AData: THandle; APalette: HPALETTE); }\r\n\r\nprocedure TGraphic_LoadFromClipboardFormat(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TGraphic(Args.Obj).LoadFromClipboardFormat(Args.Values[0], Args.Values[1], Args.Values[2]);\r\nend;\r\n\r\n{ procedure SaveToClipboardFormat(var AFormat: Word; var AData: THandle; var APalette: HPALETTE); }\r\n\r\nprocedure TGraphic_SaveToClipboardFormat(var Value: Variant; Args: TJvInterpreterArgs);\r\nvar\r\n AFormat: Word;\r\n AData: THandle;\r\n APalette: HPALETTE;\r\nbegin\r\n AFormat := Word(TVarData(Args.Values[0]).VSmallInt);\r\n AData := THandle(TVarData(Args.Values[1]).VInteger);\r\n APalette := HPALETTE(TVarData(Args.Values[2]).VInteger);\r\n\r\n TGraphic(Args.Obj).SaveToClipboardFormat(AFormat, AData, APalette);\r\nend;\r\n\r\n\r\n\r\n{ property Read Empty: Boolean }\r\n\r\nprocedure TGraphic_Read_Empty(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TGraphic(Args.Obj).Empty;\r\nend;\r\n\r\n{ property Read Height: Integer }\r\n\r\nprocedure TGraphic_Read_Height(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TGraphic(Args.Obj).Height;\r\nend;\r\n\r\n{ property Write Height(Value: Integer) }\r\n\r\nprocedure TGraphic_Write_Height(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TGraphic(Args.Obj).Height := Value;\r\nend;\r\n\r\n{ property Read Modified: Boolean }\r\n\r\nprocedure TGraphic_Read_Modified(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TGraphic(Args.Obj).Modified;\r\nend;\r\n\r\n{ property Write Modified(Value: Boolean) }\r\n\r\nprocedure TGraphic_Write_Modified(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TGraphic(Args.Obj).Modified := Value;\r\nend;\r\n\r\n\r\n\r\n{ property Read Palette: HPALETTE }\r\n\r\nprocedure TGraphic_Read_Palette(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := Integer(TGraphic(Args.Obj).Palette);\r\nend;\r\n\r\n{ property Write Palette(Value: HPALETTE) }\r\n\r\nprocedure TGraphic_Write_Palette(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TGraphic(Args.Obj).Palette := Value;\r\nend;\r\n\r\n{ property Read PaletteModified: Boolean }\r\n\r\nprocedure TGraphic_Read_PaletteModified(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TGraphic(Args.Obj).PaletteModified;\r\nend;\r\n\r\n{ property Write PaletteModified(Value: Boolean) }\r\n\r\nprocedure TGraphic_Write_PaletteModified(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TGraphic(Args.Obj).PaletteModified := Value;\r\nend;\r\n\r\n\r\n\r\n{ property Read Transparent: Boolean }\r\n\r\nprocedure TGraphic_Read_Transparent(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TGraphic(Args.Obj).Transparent;\r\nend;\r\n\r\n{ property Write Transparent(Value: Boolean) }\r\n\r\nprocedure TGraphic_Write_Transparent(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TGraphic(Args.Obj).Transparent := Value;\r\nend;\r\n\r\n\r\n\r\n{ property Read Width: Integer }\r\n\r\nprocedure TGraphic_Read_Width(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TGraphic(Args.Obj).Width;\r\nend;\r\n\r\n{ property Write Width(Value: Integer) }\r\n\r\nprocedure TGraphic_Write_Width(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TGraphic(Args.Obj).Width := Value;\r\nend;\r\n\r\n{ TPicture }\r\n\r\n{ constructor Create }\r\n\r\nprocedure TPicture_Create(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TPicture.Create);\r\nend;\r\n\r\n{ procedure LoadFromFile(const Filename: string); }\r\n\r\nprocedure TPicture_LoadFromFile(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TPicture(Args.Obj).LoadFromFile(Args.Values[0]);\r\nend;\r\n\r\n{ procedure SaveToFile(const Filename: string); }\r\n\r\nprocedure TPicture_SaveToFile(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TPicture(Args.Obj).SaveToFile(Args.Values[0]);\r\nend;\r\n\r\n\r\n\r\n{ procedure LoadFromClipboardFormat(AFormat: Word; AData: THandle; APalette: HPALETTE); }\r\n\r\nprocedure TPicture_LoadFromClipboardFormat(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TPicture(Args.Obj).LoadFromClipboardFormat(Args.Values[0], Args.Values[1], Args.Values[2]);\r\nend;\r\n\r\n{ procedure SaveToClipboardFormat(var AFormat: Word; var AData: THandle; var APalette: HPALETTE); }\r\n\r\nprocedure TPicture_SaveToClipboardFormat(var Value: Variant; Args: TJvInterpreterArgs);\r\nvar\r\n AFormat: Word;\r\n AData: THandle;\r\n APalette: HPALETTE;\r\nbegin\r\n AFormat := Word(TVarData(Args.Values[0]).VSmallInt);\r\n AData := THandle(TVarData(Args.Values[1]).VInteger);\r\n APalette := HPALETTE(TVarData(Args.Values[2]).VInteger);\r\n\r\n TPicture(Args.Obj).SaveToClipboardFormat(AFormat, AData, APalette);\r\nend;\r\n\r\n{ function SupportsClipboardFormat(AFormat: Word): Boolean; }\r\n\r\nprocedure TPicture_SupportsClipboardFormat(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TPicture(Args.Obj).SupportsClipboardFormat(Args.Values[0]);\r\nend;\r\n\r\n\r\n\r\n{ procedure Assign(Source: TPersistent); }\r\n\r\nprocedure TPicture_Assign(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TPicture(Args.Obj).Assign(V2O(Args.Values[0]) as TPersistent);\r\nend;\r\n\r\n{ property Read Bitmap: TBitmap }\r\n\r\nprocedure TPicture_Read_Bitmap(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TPicture(Args.Obj).Bitmap);\r\nend;\r\n\r\n{ property Write Bitmap(Value: TBitmap) }\r\n\r\nprocedure TPicture_Write_Bitmap(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TPicture(Args.Obj).Bitmap := V2O(Value) as TBitmap;\r\nend;\r\n\r\n{ property Read Graphic: TGraphic }\r\n\r\nprocedure TPicture_Read_Graphic(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TPicture(Args.Obj).Graphic);\r\nend;\r\n\r\n{ property Write Graphic(Value: TGraphic) }\r\n\r\nprocedure TPicture_Write_Graphic(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TPicture(Args.Obj).Graphic := V2O(Value) as TGraphic;\r\nend;\r\n\r\n\r\n\r\n{ property Read PictureAdapter: IChangeNotifier }\r\n\r\nprocedure TPicture_Read_PictureAdapter(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TPicture(Args.Obj).PictureAdapter;\r\nend;\r\n\r\n{ property Write PictureAdapter(Value: IChangeNotifier) }\r\n\r\nprocedure TPicture_Write_PictureAdapter(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n// TPicture(Args.Obj).PictureAdapter := Value;\r\n NotImplemented('TPicture.PictureAdapter');\r\nend;\r\n\r\n\r\n\r\n\r\n{ property Read Height: Integer }\r\n\r\nprocedure TPicture_Read_Height(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TPicture(Args.Obj).Height;\r\nend;\r\n\r\n{ property Read Icon: TIcon }\r\n\r\nprocedure TPicture_Read_Icon(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TPicture(Args.Obj).Icon);\r\nend;\r\n\r\n{ property Write Icon(Value: TIcon) }\r\n\r\nprocedure TPicture_Write_Icon(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TPicture(Args.Obj).Icon := V2O(Value) as TIcon;\r\nend;\r\n\r\n\r\n\r\n{ property Read Metafile: TMetafile }\r\n\r\nprocedure TPicture_Read_Metafile(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TPicture(Args.Obj).Metafile);\r\nend;\r\n\r\n{ property Write Metafile(Value: TMetafile) }\r\n\r\nprocedure TPicture_Write_Metafile(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TPicture(Args.Obj).Metafile := V2O(Value) as TMetafile;\r\nend;\r\n\r\n\r\n\r\n{ property Read Width: Integer }\r\n\r\nprocedure TPicture_Read_Width(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TPicture(Args.Obj).Width;\r\nend;\r\n\r\n\r\n\r\n{ TMetafile }\r\n\r\n{ constructor Create }\r\n\r\nprocedure TMetafile_Create(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TMetafile.Create);\r\nend;\r\n\r\n{ procedure Clear; }\r\n\r\nprocedure TMetafile_Clear(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TMetafile(Args.Obj).Clear;\r\nend;\r\n\r\n{ procedure LoadFromStream(Stream: TStream); }\r\n\r\nprocedure TMetafile_LoadFromStream(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TMetafile(Args.Obj).LoadFromStream(V2O(Args.Values[0]) as TStream);\r\nend;\r\n\r\n{ procedure SaveToFile(const Filename: String); }\r\n\r\nprocedure TMetafile_SaveToFile(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TMetafile(Args.Obj).SaveToFile(Args.Values[0]);\r\nend;\r\n\r\n{ procedure SaveToStream(Stream: TStream); }\r\n\r\nprocedure TMetafile_SaveToStream(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TMetafile(Args.Obj).SaveToStream(V2O(Args.Values[0]) as TStream);\r\nend;\r\n\r\n{ procedure LoadFromClipboardFormat(AFormat: Word; AData: THandle; APalette: HPALETTE); }\r\n\r\nprocedure TMetafile_LoadFromClipboardFormat(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TMetafile(Args.Obj).LoadFromClipboardFormat(Args.Values[0], Args.Values[1], Args.Values[2]);\r\nend;\r\n\r\n{ procedure SaveToClipboardFormat(var AFormat: Word; var AData: THandle; var APalette: HPALETTE); }\r\n\r\nprocedure TMetafile_SaveToClipboardFormat(var Value: Variant; Args: TJvInterpreterArgs);\r\nvar\r\n AFormat: Word;\r\n AData: THandle;\r\n APalette: HPALETTE;\r\nbegin\r\n AFormat := Word(TVarData(Args.Values[0]).VSmallInt);\r\n AData := THandle(TVarData(Args.Values[1]).VInteger);\r\n APalette := HPALETTE(TVarData(Args.Values[2]).VInteger);\r\n\r\n TMetafile(Args.Obj).SaveToClipboardFormat(AFormat, AData, APalette);\r\nend;\r\n\r\n{ procedure Assign(Source: TPersistent); }\r\n\r\nprocedure TMetafile_Assign(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TMetafile(Args.Obj).Assign(V2O(Args.Values[0]) as TPersistent);\r\nend;\r\n\r\n{ function ReleaseHandle: HENHMETAFILE; }\r\n\r\nprocedure TMetafile_ReleaseHandle(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := NativeInt(TMetafile(Args.Obj).ReleaseHandle);\r\nend;\r\n\r\n\r\n{ property Read CreatedBy: String }\r\n\r\nprocedure TMetafile_Read_CreatedBy(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TMetafile(Args.Obj).CreatedBy;\r\nend;\r\n\r\n{ property Read Description: String }\r\n\r\nprocedure TMetafile_Read_Description(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TMetafile(Args.Obj).Description;\r\nend;\r\n\r\n{ property Read Enhanced: Boolean }\r\n\r\nprocedure TMetafile_Read_Enhanced(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TMetafile(Args.Obj).Enhanced;\r\nend;\r\n\r\n{ property Write Enhanced(Value: Boolean) }\r\n\r\nprocedure TMetafile_Write_Enhanced(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TMetafile(Args.Obj).Enhanced := Value;\r\nend;\r\n\r\n{ property Read Handle: HENHMETAFILE }\r\n\r\nprocedure TMetafile_Read_Handle(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := NativeInt(TMetafile(Args.Obj).Handle);\r\nend;\r\n\r\n{ property Write Handle(Value: HENHMETAFILE) }\r\n\r\nprocedure TMetafile_Write_Handle(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TMetafile(Args.Obj).Handle := Value;\r\nend;\r\n\r\n{ property Read MMWidth: Integer }\r\n\r\nprocedure TMetafile_Read_MMWidth(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TMetafile(Args.Obj).MMWidth;\r\nend;\r\n\r\n{ property Write MMWidth(Value: Integer) }\r\n\r\nprocedure TMetafile_Write_MMWidth(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TMetafile(Args.Obj).MMWidth := Value;\r\nend;\r\n\r\n{ property Read MMHeight: Integer }\r\n\r\nprocedure TMetafile_Read_MMHeight(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TMetafile(Args.Obj).MMHeight;\r\nend;\r\n\r\n{ property Write MMHeight(Value: Integer) }\r\n\r\nprocedure TMetafile_Write_MMHeight(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TMetafile(Args.Obj).MMHeight := Value;\r\nend;\r\n\r\n{ property Read Inch: Word }\r\n\r\nprocedure TMetafile_Read_Inch(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TMetafile(Args.Obj).Inch;\r\nend;\r\n\r\n{ property Write Inch(Value: Word) }\r\n\r\nprocedure TMetafile_Write_Inch(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TMetafile(Args.Obj).Inch := Value;\r\nend;\r\n\r\n\r\n\r\n{ TBitmap }\r\n\r\n{ constructor Create }\r\n\r\nprocedure TBitmap_Create(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TBitmap.Create);\r\nend;\r\n\r\n{ procedure Assign(Source: TPersistent); }\r\n\r\nprocedure TBitmap_Assign(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TBitmap(Args.Obj).Assign(V2O(Args.Values[0]) as TPersistent);\r\nend;\r\n\r\n{ procedure Dormant; }\r\n\r\nprocedure TBitmap_Dormant(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TBitmap(Args.Obj).Dormant;\r\nend;\r\n\r\n{ procedure FreeImage; }\r\n\r\nprocedure TBitmap_FreeImage(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TBitmap(Args.Obj).FreeImage;\r\nend;\r\n\r\n{ procedure LoadFromClipboardFormat(AFormat: Word; AData: THandle; APalette: HPALETTE); }\r\n\r\n\r\nprocedure TBitmap_LoadFromClipboardFormat(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TBitmap(Args.Obj).LoadFromClipboardFormat(Args.Values[0], Args.Values[1], Args.Values[2]);\r\nend;\r\n\r\n\r\n{ procedure LoadFromStream(Stream: TStream); }\r\n\r\nprocedure TBitmap_LoadFromStream(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TBitmap(Args.Obj).LoadFromStream(V2O(Args.Values[0]) as TStream);\r\nend;\r\n\r\n{ procedure LoadFromResourceName(Instance: THandle; const ResName: String); }\r\n\r\nprocedure TBitmap_LoadFromResourceName(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TBitmap(Args.Obj).Assign(nil); // fixes GDI resource leak\r\n TBitmap(Args.Obj).LoadFromResourceName(Args.Values[0], Args.Values[1]);\r\nend;\r\n\r\n{ procedure LoadFromResourceID(Instance: THandle; ResID: Integer); }\r\n\r\nprocedure TBitmap_LoadFromResourceID(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TBitmap(Args.Obj).Assign(nil); // fixes GDI resource leak\r\n TBitmap(Args.Obj).LoadFromResourceID(Args.Values[0], Args.Values[1]);\r\nend;\r\n\r\n{ procedure Mask(TransparentColor: TColor); }\r\n\r\nprocedure TBitmap_Mask(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TBitmap(Args.Obj).Mask(Args.Values[0]);\r\nend;\r\n\r\n\r\n\r\n\r\n{ function ReleaseHandle: HBITMAP; }\r\n\r\nprocedure TBitmap_ReleaseHandle(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := NativeInt(TBitmap(Args.Obj).ReleaseHandle);\r\nend;\r\n\r\n{ function ReleaseMaskHandle: HBITMAP; }\r\n\r\nprocedure TBitmap_ReleaseMaskHandle(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := NativeInt(TBitmap(Args.Obj).ReleaseMaskHandle);\r\nend;\r\n\r\n\r\n{ function ReleasePalette: HPALETTE; }\r\n\r\nprocedure TBitmap_ReleasePalette(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := NativeInt(TBitmap(Args.Obj).ReleasePalette);\r\nend;\r\n\r\n{ procedure SaveToClipboardFormat(var Format: Word; var Data: THandle; var APalette: HPALETTE); }\r\n\r\nprocedure TBitmap_SaveToClipboardFormat(var Value: Variant; Args: TJvInterpreterArgs);\r\nvar\r\n AFormat: Word;\r\n AData: THandle;\r\n APalette: HPALETTE;\r\nbegin\r\n AFormat := Word(TVarData(Args.Values[0]).VSmallInt);\r\n AData := THandle(TVarData(Args.Values[1]).VInteger);\r\n APalette := HPALETTE(TVarData(Args.Values[2]).VInteger);\r\n\r\n TBitmap(Args.Obj).SaveToClipboardFormat(AFormat, AData, APalette);\r\nend;\r\n\r\n\r\n\r\n{ procedure SaveToStream(Stream: TStream); }\r\n\r\nprocedure TBitmap_SaveToStream(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TBitmap(Args.Obj).SaveToStream(V2O(Args.Values[0]) as TStream);\r\nend;\r\n\r\n{ property Read Canvas: TCanvas }\r\n\r\nprocedure TBitmap_Read_Canvas(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TBitmap(Args.Obj).Canvas);\r\nend;\r\n\r\n{ property Read Handle: HBITMAP }\r\n\r\nprocedure TBitmap_Read_Handle(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := NativeInt(TBitmap(Args.Obj).Handle);\r\nend;\r\n\r\n{ property Write Handle(Value: HBITMAP) }\r\n\r\nprocedure TBitmap_Write_Handle(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TBitmap(Args.Obj).Handle := Value;\r\nend;\r\n\r\n\r\n\r\n{ property Read HandleType: TBitmapHandleType }\r\n\r\nprocedure TBitmap_Read_HandleType(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TBitmap(Args.Obj).HandleType;\r\nend;\r\n\r\n{ property Write HandleType(Value: TBitmapHandleType) }\r\n\r\nprocedure TBitmap_Write_HandleType(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TBitmap(Args.Obj).HandleType := Value;\r\nend;\r\n\r\n\r\n\r\n{ property Read IgnorePalette: Boolean }\r\n\r\nprocedure TBitmap_Read_IgnorePalette(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TBitmap(Args.Obj).IgnorePalette;\r\nend;\r\n\r\n{ property Write IgnorePalette(Value: Boolean) }\r\n\r\nprocedure TBitmap_Write_IgnorePalette(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TBitmap(Args.Obj).IgnorePalette := Value;\r\nend;\r\n\r\n{ property Read MaskHandle: HBITMAP }\r\n\r\n\r\nprocedure TBitmap_Read_MaskHandle(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := NativeInt(TBitmap(Args.Obj).MaskHandle);\r\nend;\r\n\r\n\r\n\r\n\r\n{ property Read Monochrome: Boolean }\r\n\r\nprocedure TBitmap_Read_Monochrome(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TBitmap(Args.Obj).Monochrome;\r\nend;\r\n\r\n{ property Write Monochrome(Value: Boolean) }\r\n\r\nprocedure TBitmap_Write_Monochrome(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TBitmap(Args.Obj).Monochrome := Value;\r\nend;\r\n\r\n\r\n\r\n{ property Read PixelFormat: TPixelFormat }\r\n\r\nprocedure TBitmap_Read_PixelFormat(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TBitmap(Args.Obj).PixelFormat;\r\nend;\r\n\r\n{ property Write PixelFormat(Value: TPixelFormat) }\r\n\r\nprocedure TBitmap_Write_PixelFormat(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TBitmap(Args.Obj).PixelFormat := Value;\r\nend;\r\n\r\n{ property Read ScanLine[Integer]: Pointer }\r\n\r\nprocedure TBitmap_Read_ScanLine(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := P2V(TBitmap(Args.Obj).ScanLine[Args.Values[0]]);\r\nend;\r\n\r\n\r\n\r\n{ property Read TransparentColor: TColor }\r\n\r\nprocedure TBitmap_Read_TransparentColor(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TBitmap(Args.Obj).TransparentColor;\r\nend;\r\n\r\n\r\n\r\n{ property Write TransparentColor(Value: TColor) }\r\n\r\nprocedure TBitmap_Write_TransparentColor(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TBitmap(Args.Obj).TransparentColor := Value;\r\nend;\r\n\r\n{ property Read TransparentMode: TTransparentMode }\r\n\r\nprocedure TBitmap_Read_TransparentMode(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TBitmap(Args.Obj).TransparentMode;\r\nend;\r\n\r\n{ property Write TransparentMode(Value: TTransparentMode) }\r\n\r\nprocedure TBitmap_Write_TransparentMode(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TBitmap(Args.Obj).TransparentMode := Value;\r\nend;\r\n\r\n\r\n\r\n{ TIcon }\r\n\r\n{ constructor Create }\r\n\r\nprocedure TIcon_Create(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TIcon.Create);\r\nend;\r\n\r\n{ procedure Assign(Source: TPersistent); }\r\n\r\nprocedure TIcon_Assign(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TIcon(Args.Obj).Assign(V2O(Args.Values[0]) as TPersistent);\r\nend;\r\n\r\n{ procedure LoadFromStream(Stream: TStream); }\r\n\r\nprocedure TIcon_LoadFromStream(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TIcon(Args.Obj).LoadFromStream(V2O(Args.Values[0]) as TStream);\r\nend;\r\n\r\n{ function ReleaseHandle: HICON; }\r\n\r\n\r\nprocedure TIcon_ReleaseHandle(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := NativeInt(TIcon(Args.Obj).ReleaseHandle);\r\nend;\r\n\r\n\r\n{ procedure SaveToStream(Stream: TStream); }\r\n\r\nprocedure TIcon_SaveToStream(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TIcon(Args.Obj).SaveToStream(V2O(Args.Values[0]) as TStream);\r\nend;\r\n\r\n{ property Read Handle: HICON }\r\n\r\nprocedure TIcon_Read_Handle(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := NativeInt(TIcon(Args.Obj).Handle);\r\nend;\r\n\r\n{ property Write Handle(Value: HICON) }\r\n\r\n\r\nprocedure TIcon_Write_Handle(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TIcon(Args.Obj).Handle := Value;\r\nend;\r\n\r\n\r\nprocedure RegisterJvInterpreterAdapter(JvInterpreterAdapter: TJvInterpreterAdapter);\r\nconst\r\n cGraphics = 'Graphics';\r\nbegin\r\n with JvInterpreterAdapter do\r\n begin\r\n { TFontStyle }\r\n AddConst(cGraphics, 'fsBold', Ord(fsBold));\r\n AddConst(cGraphics, 'fsItalic', Ord(fsItalic));\r\n AddConst(cGraphics, 'fsUnderline', Ord(fsUnderline));\r\n AddConst(cGraphics, 'fsStrikeOut', Ord(fsStrikeOut));\r\n { TFontPitch }\r\n AddConst(cGraphics, 'fpDefault', Ord(fpDefault));\r\n AddConst(cGraphics, 'fpVariable', Ord(fpVariable));\r\n AddConst(cGraphics, 'fpFixed', Ord(fpFixed));\r\n { TPenStyle }\r\n AddConst(cGraphics, 'psSolid', Ord(psSolid));\r\n AddConst(cGraphics, 'psDash', Ord(psDash));\r\n AddConst(cGraphics, 'psDot', Ord(psDot));\r\n AddConst(cGraphics, 'psDashDot', Ord(psDashDot));\r\n AddConst(cGraphics, 'psDashDotDot', Ord(psDashDotDot));\r\n AddConst(cGraphics, 'psClear', Ord(psClear));\r\n AddConst(cGraphics, 'psInsideFrame', Ord(psInsideFrame));\r\n { TPenMode }\r\n AddConst(cGraphics, 'pmBlack', Ord(pmBlack));\r\n AddConst(cGraphics, 'pmWhite', Ord(pmWhite));\r\n AddConst(cGraphics, 'pmNop', Ord(pmNop));\r\n AddConst(cGraphics, 'pmNot', Ord(pmNot));\r\n AddConst(cGraphics, 'pmCopy', Ord(pmCopy));\r\n AddConst(cGraphics, 'pmNotCopy', Ord(pmNotCopy));\r\n AddConst(cGraphics, 'pmMergePenNot', Ord(pmMergePenNot));\r\n AddConst(cGraphics, 'pmMaskPenNot', Ord(pmMaskPenNot));\r\n AddConst(cGraphics, 'pmMergeNotPen', Ord(pmMergeNotPen));\r\n AddConst(cGraphics, 'pmMaskNotPen', Ord(pmMaskNotPen));\r\n AddConst(cGraphics, 'pmMerge', Ord(pmMerge));\r\n AddConst(cGraphics, 'pmNotMerge', Ord(pmNotMerge));\r\n AddConst(cGraphics, 'pmMask', Ord(pmMask));\r\n AddConst(cGraphics, 'pmNotMask', Ord(pmNotMask));\r\n AddConst(cGraphics, 'pmXor', Ord(pmXor));\r\n AddConst(cGraphics, 'pmNotXor', Ord(pmNotXor));\r\n { TBrushStyle }\r\n AddConst(cGraphics, 'bsSolid', Ord(bsSolid));\r\n AddConst(cGraphics, 'bsClear', Ord(bsClear));\r\n AddConst(cGraphics, 'bsHorizontal', Ord(bsHorizontal));\r\n AddConst(cGraphics, 'bsVertical', Ord(bsVertical));\r\n AddConst(cGraphics, 'bsFDiagonal', Ord(bsFDiagonal));\r\n AddConst(cGraphics, 'bsBDiagonal', Ord(bsBDiagonal));\r\n AddConst(cGraphics, 'bsCross', Ord(bsCross));\r\n AddConst(cGraphics, 'bsDiagCross', Ord(bsDiagCross));\r\n { TFont }\r\n AddClass(cGraphics, TFont, 'TFont');\r\n AddGet(TFont, 'Create', TFont_Create, 0, [varEmpty], varEmpty);\r\n AddGet(TFont, 'Assign', TFont_Assign, 1, [varEmpty], varEmpty);\r\n AddGet(TFont, 'Handle', TFont_Read_Handle, 0, [varEmpty], varEmpty);\r\n AddSet(TFont, 'Handle', TFont_Write_Handle, 0, [varEmpty]);\r\n AddGet(TFont, 'PixelsPerInch', TFont_Read_PixelsPerInch, 0, [varEmpty], varEmpty);\r\n AddSet(TFont, 'PixelsPerInch', TFont_Write_PixelsPerInch, 0, [varEmpty]);\r\n\r\n AddGet(TFont, 'Charset', TFont_Read_Charset, 0, [varEmpty], varEmpty);\r\n AddSet(TFont, 'Charset', TFont_Write_Charset, 0, [varEmpty]);\r\n\r\n AddGet(TFont, 'Color', TFont_Read_Color, 0, [varEmpty], varEmpty);\r\n AddSet(TFont, 'Color', TFont_Write_Color, 0, [varEmpty]);\r\n AddGet(TFont, 'Height', TFont_Read_Height, 0, [varEmpty], varEmpty);\r\n AddSet(TFont, 'Height', TFont_Write_Height, 0, [varEmpty]);\r\n AddGet(TFont, 'Name', TFont_Read_Name, 0, [varEmpty], varEmpty);\r\n AddSet(TFont, 'Name', TFont_Write_Name, 0, [varEmpty]);\r\n AddGet(TFont, 'Pitch', TFont_Read_Pitch, 0, [varEmpty], varEmpty);\r\n AddSet(TFont, 'Pitch', TFont_Write_Pitch, 0, [varEmpty]);\r\n AddGet(TFont, 'Size', TFont_Read_Size, 0, [varEmpty], varEmpty);\r\n AddSet(TFont, 'Size', TFont_Write_Size, 0, [varEmpty]);\r\n AddGet(TFont, 'Style', TFont_Read_Style, 0, [varEmpty], varEmpty);\r\n AddSet(TFont, 'Style', TFont_Write_Style, 0, [varEmpty]);\r\n { TPen }\r\n AddClass(cGraphics, TPen, 'TPen');\r\n AddGet(TPen, 'Create', TPen_Create, 0, [varEmpty], varEmpty);\r\n AddGet(TPen, 'Assign', TPen_Assign, 1, [varEmpty], varEmpty);\r\n AddGet(TPen, 'Handle', TPen_Read_Handle, 0, [varEmpty], varEmpty);\r\n AddSet(TPen, 'Handle', TPen_Write_Handle, 0, [varEmpty]);\r\n AddGet(TPen, 'Color', TPen_Read_Color, 0, [varEmpty], varEmpty);\r\n AddSet(TPen, 'Color', TPen_Write_Color, 0, [varEmpty]);\r\n AddGet(TPen, 'Mode', TPen_Read_Mode, 0, [varEmpty], varEmpty);\r\n AddSet(TPen, 'Mode', TPen_Write_Mode, 0, [varEmpty]);\r\n AddGet(TPen, 'Style', TPen_Read_Style, 0, [varEmpty], varEmpty);\r\n AddSet(TPen, 'Style', TPen_Write_Style, 0, [varEmpty]);\r\n AddGet(TPen, 'Width', TPen_Read_Width, 0, [varEmpty], varEmpty);\r\n AddSet(TPen, 'Width', TPen_Write_Width, 0, [varEmpty]);\r\n { TBrush }\r\n AddClass(cGraphics, TBrush, 'TBrush');\r\n AddGet(TBrush, 'Create', TBrush_Create, 0, [varEmpty], varEmpty);\r\n AddGet(TBrush, 'Assign', TBrush_Assign, 1, [varEmpty], varEmpty);\r\n AddGet(TBrush, 'Bitmap', TBrush_Read_Bitmap, 0, [varEmpty], varEmpty);\r\n AddSet(TBrush, 'Bitmap', TBrush_Write_Bitmap, 0, [varEmpty]);\r\n AddGet(TBrush, 'Handle', TBrush_Read_Handle, 0, [varEmpty], varEmpty);\r\n AddSet(TBrush, 'Handle', TBrush_Write_Handle, 0, [varEmpty]);\r\n AddGet(TBrush, 'Color', TBrush_Read_Color, 0, [varEmpty], varEmpty);\r\n AddSet(TBrush, 'Color', TBrush_Write_Color, 0, [varEmpty]);\r\n AddGet(TBrush, 'Style', TBrush_Read_Style, 0, [varEmpty], varEmpty);\r\n AddSet(TBrush, 'Style', TBrush_Write_Style, 0, [varEmpty]);\r\n { TFillStyle }\r\n AddConst(cGraphics, 'fsSurface', Ord(fsSurface));\r\n AddConst(cGraphics, 'fsBorder', Ord(fsBorder));\r\n { TFillMode }\r\n AddConst(cGraphics, 'fmAlternate', Ord(fmAlternate));\r\n AddConst(cGraphics, 'fmWinding', Ord(fmWinding));\r\n { TCanvasStates }\r\n AddConst(cGraphics, 'csHandleValid', Ord(csHandleValid));\r\n AddConst(cGraphics, 'csFontValid', Ord(csFontValid));\r\n AddConst(cGraphics, 'csPenValid', Ord(csPenValid));\r\n AddConst(cGraphics, 'csBrushValid', Ord(csBrushValid));\r\n { TCanvas }\r\n AddClass(cGraphics, TCanvas, 'TCanvas');\r\n AddGet(TCanvas, 'Create', TCanvas_Create, 0, [varEmpty], varEmpty);\r\n AddGet(TCanvas, 'Arc', TCanvas_Arc, 8, [varEmpty, varEmpty, varEmpty, varEmpty, varEmpty, varEmpty, varEmpty,\r\n varEmpty], varEmpty);\r\n AddGet(TCanvas, 'BrushCopy', TCanvas_BrushCopy, 4, [varEmpty, varEmpty, varEmpty, varEmpty], varEmpty);\r\n AddGet(TCanvas, 'Chord', TCanvas_Chord, 8, [varEmpty, varEmpty, varEmpty, varEmpty, varEmpty, varEmpty, varEmpty,\r\n varEmpty], varEmpty);\r\n AddGet(TCanvas, 'CopyRect', TCanvas_CopyRect, 3, [varEmpty, varEmpty, varEmpty], varEmpty);\r\n AddGet(TCanvas, 'Draw', TCanvas_Draw, 3, [varEmpty, varEmpty, varEmpty], varEmpty);\r\n AddGet(TCanvas, 'DrawFocusRect', TCanvas_DrawFocusRect, 1, [varEmpty], varEmpty);\r\n AddGet(TCanvas, 'Ellipse', TCanvas_Ellipse, 4, [varEmpty, varEmpty, varEmpty, varEmpty], varEmpty);\r\n AddGet(TCanvas, 'FillRect', TCanvas_FillRect, 1, [varEmpty], varEmpty);\r\n AddGet(TCanvas, 'FloodFill', TCanvas_FloodFill, 4, [varEmpty, varEmpty, varEmpty, varEmpty], varEmpty);\r\n AddGet(TCanvas, 'FrameRect', TCanvas_FrameRect, 1, [varEmpty], varEmpty);\r\n AddGet(TCanvas, 'LineTo', TCanvas_LineTo, 2, [varEmpty, varEmpty], varEmpty);\r\n\r\n AddGet(TCanvas, 'Lock', TCanvas_Lock, 0, [varEmpty], varEmpty);\r\n\r\n AddGet(TCanvas, 'MoveTo', TCanvas_MoveTo, 2, [varEmpty, varEmpty], varEmpty);\r\n AddGet(TCanvas, 'Pie', TCanvas_Pie, 8, [varEmpty, varEmpty, varEmpty, varEmpty, varEmpty, varEmpty, varEmpty,\r\n varEmpty], varEmpty);\r\n AddGet(TCanvas, 'Polygon', TCanvas_Polygon, 1, [varEmpty], varEmpty);\r\n AddGet(TCanvas, 'Polyline', TCanvas_Polyline, 1, [varEmpty], varEmpty);\r\n AddGet(TCanvas, 'Rectangle', TCanvas_Rectangle, 4, [varEmpty, varEmpty, varEmpty, varEmpty], varEmpty);\r\n AddGet(TCanvas, 'Refresh', TCanvas_Refresh, 0, [varEmpty], varEmpty);\r\n AddGet(TCanvas, 'RoundRect', TCanvas_RoundRect, 6, [varEmpty, varEmpty, varEmpty, varEmpty, varEmpty, varEmpty],\r\n varEmpty);\r\n AddGet(TCanvas, 'StretchDraw', TCanvas_StretchDraw, 2, [varEmpty, varEmpty], varEmpty);\r\n AddGet(TCanvas, 'TextExtent', TCanvas_TextExtent, 1, [varEmpty], varEmpty);\r\n AddGet(TCanvas, 'TextHeight', TCanvas_TextHeight, 1, [varEmpty], varEmpty);\r\n AddGet(TCanvas, 'TextOut', TCanvas_TextOut, 3, [varEmpty, varEmpty, varEmpty], varEmpty);\r\n AddGet(TCanvas, 'TextRect', TCanvas_TextRect, 4, [varEmpty, varEmpty, varEmpty, varEmpty], varEmpty);\r\n AddGet(TCanvas, 'TextWidth', TCanvas_TextWidth, 1, [varEmpty], varEmpty);\r\n\r\n AddGet(TCanvas, 'TryLock', TCanvas_TryLock, 0, [varEmpty], varEmpty);\r\n AddGet(TCanvas, 'Unlock', TCanvas_Unlock, 0, [varEmpty], varEmpty);\r\n\r\n AddGet(TCanvas, 'ClipRect', TCanvas_Read_ClipRect, 0, [varEmpty], varEmpty);\r\n AddGet(TCanvas, 'Handle', TCanvas_Read_Handle, 0, [varEmpty], varEmpty);\r\n AddSet(TCanvas, 'Handle', TCanvas_Write_Handle, 0, [varEmpty]);\r\n\r\n AddGet(TCanvas, 'LockCount', TCanvas_Read_LockCount, 0, [varEmpty], varEmpty);\r\n\r\n AddGet(TCanvas, 'PenPos', TCanvas_Read_PenPos, 0, [varEmpty], varEmpty);\r\n AddSet(TCanvas, 'PenPos', TCanvas_Write_PenPos, 0, [varEmpty]);\r\n AddGet(TCanvas, 'Brush', TCanvas_Read_Brush, 0, [varEmpty], varEmpty);\r\n AddSet(TCanvas, 'Brush', TCanvas_Write_Brush, 0, [varEmpty]);\r\n AddGet(TCanvas, 'CopyMode', TCanvas_Read_CopyMode, 0, [varEmpty], varEmpty);\r\n AddSet(TCanvas, 'CopyMode', TCanvas_Write_CopyMode, 0, [varEmpty]);\r\n AddGet(TCanvas, 'Font', TCanvas_Read_Font, 0, [varEmpty], varEmpty);\r\n AddSet(TCanvas, 'Font', TCanvas_Write_Font, 0, [varEmpty]);\r\n AddGet(TCanvas, 'Pen', TCanvas_Read_Pen, 0, [varEmpty], varEmpty);\r\n AddSet(TCanvas, 'Pen', TCanvas_Write_Pen, 0, [varEmpty]);\r\n\r\n { TProgressStage }\r\n AddConst(cGraphics, 'psStarting', Ord(psStarting));\r\n AddConst(cGraphics, 'psRunning', Ord(psRunning));\r\n AddConst(cGraphics, 'psEnding', Ord(psEnding));\r\n\r\n { TGraphic }\r\n AddClass(cGraphics, TGraphic, 'TGraphic');\r\n AddGet(TGraphic, 'LoadFromFile', TGraphic_LoadFromFile, 1, [varEmpty], varEmpty);\r\n AddGet(TGraphic, 'SaveToFile', TGraphic_SaveToFile, 1, [varEmpty], varEmpty);\r\n AddGet(TGraphic, 'LoadFromStream', TGraphic_LoadFromStream, 1, [varEmpty], varEmpty);\r\n AddGet(TGraphic, 'SaveToStream', TGraphic_SaveToStream, 1, [varEmpty], varEmpty);\r\n AddGet(TGraphic, 'LoadFromClipboardFormat', TGraphic_LoadFromClipboardFormat, 3, [varEmpty, varEmpty, varEmpty],\r\n varEmpty);\r\n AddGet(TGraphic, 'SaveToClipboardFormat', TGraphic_SaveToClipboardFormat, 3, [varByRef, varByRef, varByRef],\r\n varEmpty);\r\n AddGet(TGraphic, 'Empty', TGraphic_Read_Empty, 0, [varEmpty], varEmpty);\r\n AddGet(TGraphic, 'Height', TGraphic_Read_Height, 0, [varEmpty], varEmpty);\r\n AddSet(TGraphic, 'Height', TGraphic_Write_Height, 0, [varEmpty]);\r\n AddGet(TGraphic, 'Modified', TGraphic_Read_Modified, 0, [varEmpty], varEmpty);\r\n AddSet(TGraphic, 'Modified', TGraphic_Write_Modified, 0, [varEmpty]);\r\n\r\n AddGet(TGraphic, 'Palette', TGraphic_Read_Palette, 0, [varEmpty], varEmpty);\r\n AddSet(TGraphic, 'Palette', TGraphic_Write_Palette, 0, [varEmpty]);\r\n AddGet(TGraphic, 'PaletteModified', TGraphic_Read_PaletteModified, 0, [varEmpty], varEmpty);\r\n AddSet(TGraphic, 'PaletteModified', TGraphic_Write_PaletteModified, 0, [varEmpty]);\r\n AddGet(TGraphic, 'Transparent', TGraphic_Read_Transparent, 0, [varEmpty], varEmpty);\r\n AddSet(TGraphic, 'Transparent', TGraphic_Write_Transparent, 0, [varEmpty]);\r\n\r\n AddGet(TGraphic, 'Width', TGraphic_Read_Width, 0, [varEmpty], varEmpty);\r\n AddSet(TGraphic, 'Width', TGraphic_Write_Width, 0, [varEmpty]);\r\n { TPicture }\r\n AddClass(cGraphics, TPicture, 'TPicture');\r\n AddGet(TPicture, 'Create', TPicture_Create, 0, [varEmpty], varEmpty);\r\n AddGet(TPicture, 'LoadFromFile', TPicture_LoadFromFile, 1, [varEmpty], varEmpty);\r\n AddGet(TPicture, 'SaveToFile', TPicture_SaveToFile, 1, [varEmpty], varEmpty);\r\n AddGet(TPicture, 'LoadFromClipboardFormat', TPicture_LoadFromClipboardFormat, 3, [varEmpty, varEmpty, varEmpty],\r\n varEmpty);\r\n AddGet(TPicture, 'SaveToClipboardFormat', TPicture_SaveToClipboardFormat, 3, [varByRef, varByRef, varByRef],\r\n varEmpty);\r\n AddGet(TPicture, 'SupportsClipboardFormat', TPicture_SupportsClipboardFormat, 1, [varEmpty], varEmpty);\r\n AddGet(TPicture, 'Assign', TPicture_Assign, 1, [varEmpty], varEmpty);\r\n AddGet(TPicture, 'Bitmap', TPicture_Read_Bitmap, 0, [varEmpty], varEmpty);\r\n AddSet(TPicture, 'Bitmap', TPicture_Write_Bitmap, 0, [varEmpty]);\r\n AddGet(TPicture, 'Graphic', TPicture_Read_Graphic, 0, [varEmpty], varEmpty);\r\n AddSet(TPicture, 'Graphic', TPicture_Write_Graphic, 0, [varEmpty]);\r\n\r\n AddGet(TPicture, 'PictureAdapter', TPicture_Read_PictureAdapter, 0, [varEmpty], varEmpty);\r\n AddSet(TPicture, 'PictureAdapter', TPicture_Write_PictureAdapter, 0, [varEmpty]);\r\n\r\n AddGet(TPicture, 'Height', TPicture_Read_Height, 0, [varEmpty], varEmpty);\r\n AddGet(TPicture, 'Icon', TPicture_Read_Icon, 0, [varEmpty], varEmpty);\r\n AddSet(TPicture, 'Icon', TPicture_Write_Icon, 0, [varEmpty]);\r\n AddGet(TPicture, 'Metafile', TPicture_Read_Metafile, 0, [varEmpty], varEmpty);\r\n AddSet(TPicture, 'Metafile', TPicture_Write_Metafile, 0, [varEmpty]);\r\n AddGet(TPicture, 'Width', TPicture_Read_Width, 0, [varEmpty], varEmpty);\r\n { TMetafile }\r\n AddClass(cGraphics, TMetafile, 'TMetafile');\r\n AddGet(TMetafile, 'Create', TMetafile_Create, 0, [varEmpty], varEmpty);\r\n AddGet(TMetafile, 'Clear', TMetafile_Clear, 0, [varEmpty], varEmpty);\r\n AddGet(TMetafile, 'LoadFromStream', TMetafile_LoadFromStream, 1, [varEmpty], varEmpty);\r\n AddGet(TMetafile, 'SaveToFile', TMetafile_SaveToFile, 1, [varEmpty], varEmpty);\r\n AddGet(TMetafile, 'SaveToStream', TMetafile_SaveToStream, 1, [varEmpty], varEmpty);\r\n AddGet(TMetafile, 'LoadFromClipboardFormat', TMetafile_LoadFromClipboardFormat, 3, [varEmpty, varEmpty, varEmpty],\r\n varEmpty);\r\n AddGet(TMetafile, 'SaveToClipboardFormat', TMetafile_SaveToClipboardFormat, 3, [varByRef, varByRef, varByRef],\r\n varEmpty);\r\n AddGet(TMetafile, 'Assign', TMetafile_Assign, 1, [varEmpty], varEmpty);\r\n\r\n AddGet(TMetafile, 'ReleaseHandle', TMetafile_ReleaseHandle, 0, [varEmpty], varEmpty);\r\n\r\n AddGet(TMetafile, 'CreatedBy', TMetafile_Read_CreatedBy, 0, [varEmpty], varEmpty);\r\n AddGet(TMetafile, 'Description', TMetafile_Read_Description, 0, [varEmpty], varEmpty);\r\n AddGet(TMetafile, 'Enhanced', TMetafile_Read_Enhanced, 0, [varEmpty], varEmpty);\r\n AddSet(TMetafile, 'Enhanced', TMetafile_Write_Enhanced, 0, [varEmpty]);\r\n AddGet(TMetafile, 'Handle', TMetafile_Read_Handle, 0, [varEmpty], varEmpty);\r\n AddSet(TMetafile, 'Handle', TMetafile_Write_Handle, 0, [varEmpty]);\r\n AddGet(TMetafile, 'MMWidth', TMetafile_Read_MMWidth, 0, [varEmpty], varEmpty);\r\n AddSet(TMetafile, 'MMWidth', TMetafile_Write_MMWidth, 0, [varEmpty]);\r\n AddGet(TMetafile, 'MMHeight', TMetafile_Read_MMHeight, 0, [varEmpty], varEmpty);\r\n AddSet(TMetafile, 'MMHeight', TMetafile_Write_MMHeight, 0, [varEmpty]);\r\n AddGet(TMetafile, 'Inch', TMetafile_Read_Inch, 0, [varEmpty], varEmpty);\r\n AddSet(TMetafile, 'Inch', TMetafile_Write_Inch, 0, [varEmpty]);\r\n\r\n { TBitmapHandleType }\r\n\r\n AddConst(cGraphics, 'bmDIB', Ord(bmDIB));\r\n AddConst(cGraphics, 'bmDDB', Ord(bmDDB));\r\n { TPixelFormat }\r\n AddConst(cGraphics, 'pfDevice', Ord(pfDevice));\r\n AddConst(cGraphics, 'pf1bit', Ord(pf1bit));\r\n AddConst(cGraphics, 'pf4bit', Ord(pf4bit));\r\n AddConst(cGraphics, 'pf8bit', Ord(pf8bit));\r\n AddConst(cGraphics, 'pf15bit', Ord(pf15bit));\r\n AddConst(cGraphics, 'pf16bit', Ord(pf16bit));\r\n AddConst(cGraphics, 'pf24bit', Ord(pf24bit));\r\n AddConst(cGraphics, 'pf32bit', Ord(pf32bit));\r\n AddConst(cGraphics, 'pfCustom', Ord(pfCustom));\r\n { TTransparentMode }\r\n AddConst(cGraphics, 'tmAuto', Ord(tmAuto));\r\n AddConst(cGraphics, 'tmFixed', Ord(tmFixed));\r\n\r\n { TBitmap }\r\n\r\n AddClass(cGraphics, TBitmap, 'TBitmap');\r\n AddGet(TBitmap, 'Create', TBitmap_Create, 0, [varEmpty], varEmpty);\r\n AddGet(TBitmap, 'Assign', TBitmap_Assign, 1, [varEmpty], varEmpty);\r\n AddGet(TBitmap, 'Dormant', TBitmap_Dormant, 0, [varEmpty], varEmpty);\r\n AddGet(TBitmap, 'FreeImage', TBitmap_FreeImage, 0, [varEmpty], varEmpty);\r\n AddGet(TBitmap, 'LoadFromClipboardFormat', TBitmap_LoadFromClipboardFormat, 3, [varEmpty, varEmpty, varEmpty],\r\n varEmpty);\r\n AddGet(TBitmap, 'LoadFromStream', TBitmap_LoadFromStream, 1, [varEmpty], varEmpty);\r\n AddGet(TBitmap, 'LoadFromResourceName', TBitmap_LoadFromResourceName, 2, [varEmpty, varEmpty], varEmpty);\r\n AddGet(TBitmap, 'LoadFromResourceID', TBitmap_LoadFromResourceID, 2, [varEmpty, varEmpty], varEmpty);\r\n\r\n AddGet(TBitmap, 'Mask', TBitmap_Mask, 1, [varEmpty], varEmpty);\r\n\r\n AddGet(TBitmap, 'ReleaseHandle', TBitmap_ReleaseHandle, 0, [varEmpty], varEmpty);\r\n\r\n AddGet(TBitmap, 'ReleaseMaskHandle', TBitmap_ReleaseMaskHandle, 0, [varEmpty], varEmpty);\r\n\r\n AddGet(TBitmap, 'ReleasePalette', TBitmap_ReleasePalette, 0, [varEmpty], varEmpty);\r\n AddGet(TBitmap, 'SaveToClipboardFormat', TBitmap_SaveToClipboardFormat, 3, [varByRef, varByRef, varByRef],\r\n varEmpty);\r\n AddGet(TBitmap, 'SaveToStream', TBitmap_SaveToStream, 1, [varEmpty], varEmpty);\r\n AddGet(TBitmap, 'Canvas', TBitmap_Read_Canvas, 0, [varEmpty], varEmpty);\r\n AddGet(TBitmap, 'Handle', TBitmap_Read_Handle, 0, [varEmpty], varEmpty);\r\n AddSet(TBitmap, 'Handle', TBitmap_Write_Handle, 0, [varEmpty]);\r\n\r\n AddGet(TBitmap, 'HandleType', TBitmap_Read_HandleType, 0, [varEmpty], varEmpty);\r\n AddSet(TBitmap, 'HandleType', TBitmap_Write_HandleType, 0, [varEmpty]);\r\n\r\n AddGet(TBitmap, 'IgnorePalette', TBitmap_Read_IgnorePalette, 0, [varEmpty], varEmpty);\r\n AddSet(TBitmap, 'IgnorePalette', TBitmap_Write_IgnorePalette, 0, [varEmpty]);\r\n\r\n AddGet(TBitmap, 'MaskHandle', TBitmap_Read_MaskHandle, 0, [varEmpty], varEmpty);\r\n\r\n AddGet(TBitmap, 'Monochrome', TBitmap_Read_Monochrome, 0, [varEmpty], varEmpty);\r\n AddSet(TBitmap, 'Monochrome', TBitmap_Write_Monochrome, 0, [varEmpty]);\r\n\r\n AddGet(TBitmap, 'PixelFormat', TBitmap_Read_PixelFormat, 0, [varEmpty], varEmpty);\r\n AddSet(TBitmap, 'PixelFormat', TBitmap_Write_PixelFormat, 0, [varEmpty]);\r\n AddGet(TBitmap, 'ScanLine', TBitmap_Read_ScanLine, 1, [varEmpty], varEmpty);\r\n\r\n AddGet(TBitmap, 'TransparentColor', TBitmap_Read_TransparentColor, 0, [varEmpty], varEmpty);\r\n\r\n AddSet(TBitmap, 'TransparentColor', TBitmap_Write_TransparentColor, 0, [varEmpty]);\r\n AddGet(TBitmap, 'TransparentMode', TBitmap_Read_TransparentMode, 0, [varEmpty], varEmpty);\r\n AddSet(TBitmap, 'TransparentMode', TBitmap_Write_TransparentMode, 0, [varEmpty]);\r\n\r\n { TIcon }\r\n AddClass(cGraphics, TIcon, 'TIcon');\r\n AddGet(TIcon, 'Create', TIcon_Create, 0, [varEmpty], varEmpty);\r\n AddGet(TIcon, 'Assign', TIcon_Assign, 1, [varEmpty], varEmpty);\r\n AddGet(TIcon, 'LoadFromStream', TIcon_LoadFromStream, 1, [varEmpty], varEmpty);\r\n AddGet(TIcon, 'ReleaseHandle', TIcon_ReleaseHandle, 0, [varEmpty], varEmpty);\r\n AddGet(TIcon, 'SaveToStream', TIcon_SaveToStream, 1, [varEmpty], varEmpty);\r\n AddGet(TIcon, 'Handle', TIcon_Read_Handle, 0, [varEmpty], varEmpty);\r\n AddSet(TIcon, 'Handle', TIcon_Write_Handle, 0, [varEmpty]);\r\n { TFontData }\r\n\r\n { Color constants }\r\n AddConst(cGraphics, 'clScrollBar', clScrollBar);\r\n AddConst(cGraphics, 'clBackground', clBackground);\r\n AddConst(cGraphics, 'clActiveCaption', clActiveCaption);\r\n AddConst(cGraphics, 'clInactiveCaption', clInactiveCaption);\r\n AddConst(cGraphics, 'clMenu', clMenu);\r\n AddConst(cGraphics, 'clWindow', clWindow);\r\n AddConst(cGraphics, 'clWindowFrame', clWindowFrame);\r\n AddConst(cGraphics, 'clMenuText', clMenuText);\r\n AddConst(cGraphics, 'clWindowText', clWindowText);\r\n AddConst(cGraphics, 'clCaptionText', clCaptionText);\r\n AddConst(cGraphics, 'clActiveBorder', clActiveBorder);\r\n AddConst(cGraphics, 'clInactiveBorder', clInactiveBorder);\r\n AddConst(cGraphics, 'clAppWorkSpace', clAppWorkSpace);\r\n AddConst(cGraphics, 'clHighlight', clHighlight);\r\n AddConst(cGraphics, 'clHighlightText', clHighlightText);\r\n AddConst(cGraphics, 'clBtnFace', clBtnFace);\r\n AddConst(cGraphics, 'clBtnShadow', clBtnShadow);\r\n AddConst(cGraphics, 'clGrayText', clGrayText);\r\n AddConst(cGraphics, 'clBtnText', clBtnText);\r\n AddConst(cGraphics, 'clInactiveCaptionText', clInactiveCaptionText);\r\n AddConst(cGraphics, 'clBtnHighlight', clBtnHighlight);\r\n AddConst(cGraphics, 'cl3DDkShadow', cl3DDkShadow);\r\n AddConst(cGraphics, 'cl3DLight', cl3DLight);\r\n AddConst(cGraphics, 'clInfoText', clInfoText);\r\n AddConst(cGraphics, 'clInfoBk', clInfoBk);\r\n AddConst(cGraphics, 'clHotLight', clHotLight);\r\n AddConst(cGraphics, 'clGradientActiveCaption', clGradientActiveCaption);\r\n AddConst(cGraphics, 'clGradientInactiveCaption', clGradientInactiveCaption);\r\n AddConst(cGraphics, 'clMenuHighlight', clMenuHighlight);\r\n AddConst(cGraphics, 'clMenuBar', clMenuBar);\r\n\r\n AddConst(cGraphics, 'clBlack', clBlack);\r\n AddConst(cGraphics, 'clMaroon', clMaroon);\r\n AddConst(cGraphics, 'clGreen', clGreen);\r\n AddConst(cGraphics, 'clOlive', clOlive);\r\n AddConst(cGraphics, 'clNavy', clNavy);\r\n AddConst(cGraphics, 'clPurple', clPurple);\r\n AddConst(cGraphics, 'clTeal', clTeal);\r\n AddConst(cGraphics, 'clGray', clGray);\r\n AddConst(cGraphics, 'clSilver', clSilver);\r\n AddConst(cGraphics, 'clRed', clRed);\r\n AddConst(cGraphics, 'clLime', clLime);\r\n AddConst(cGraphics, 'clYellow', clYellow);\r\n AddConst(cGraphics, 'clBlue', clBlue);\r\n AddConst(cGraphics, 'clFuchsia', clFuchsia);\r\n AddConst(cGraphics, 'clAqua', clAqua);\r\n AddConst(cGraphics, 'clLtGray', clLtGray);\r\n AddConst(cGraphics, 'clDkGray', clDkGray);\r\n AddConst(cGraphics, 'clWhite', clWhite);\r\n\r\n AddConst(cGraphics, 'clMoneyGreen', clMoneyGreen);\r\n AddConst(cGraphics, 'clSkyBlue', clSkyBlue);\r\n AddConst(cGraphics, 'clCream', clCream);\r\n AddConst(cGraphics, 'clMedGray', clMedGray);\r\n\r\n AddConst(cGraphics, 'clNone', clNone);\r\n AddConst(cGraphics, 'clDefault', clDefault);\r\n\r\n {$IFDEF COMPILER9_UP}\r\n AddConst(cGraphics, 'clWebSnow', clWebSnow);\r\n AddConst(cGraphics, 'clWebFloralWhite', clWebFloralWhite);\r\n AddConst(cGraphics, 'clWebLavenderBlush', clWebLavenderBlush);\r\n AddConst(cGraphics, 'clWebOldLace', clWebOldLace);\r\n AddConst(cGraphics, 'clWebIvory', clWebIvory);\r\n AddConst(cGraphics, 'clWebCornSilk', clWebCornSilk);\r\n AddConst(cGraphics, 'clWebBeige', clWebBeige);\r\n AddConst(cGraphics, 'clWebAntiqueWhite', clWebAntiqueWhite);\r\n AddConst(cGraphics, 'clWebWheat', clWebWheat);\r\n AddConst(cGraphics, 'clWebAliceBlue', clWebAliceBlue);\r\n AddConst(cGraphics, 'clWebGhostWhite', clWebGhostWhite);\r\n AddConst(cGraphics, 'clWebLavender', clWebLavender);\r\n AddConst(cGraphics, 'clWebSeashell', clWebSeashell);\r\n AddConst(cGraphics, 'clWebLightYellow', clWebLightYellow);\r\n AddConst(cGraphics, 'clWebPapayaWhip', clWebPapayaWhip);\r\n AddConst(cGraphics, 'clWebNavajoWhite', clWebNavajoWhite);\r\n AddConst(cGraphics, 'clWebMoccasin', clWebMoccasin);\r\n AddConst(cGraphics, 'clWebBurlywood', clWebBurlywood);\r\n AddConst(cGraphics, 'clWebAzure', clWebAzure);\r\n AddConst(cGraphics, 'clWebMintcream', clWebMintcream);\r\n AddConst(cGraphics, 'clWebHoneydew', clWebHoneydew);\r\n AddConst(cGraphics, 'clWebLinen', clWebLinen);\r\n AddConst(cGraphics, 'clWebLemonChiffon', clWebLemonChiffon);\r\n AddConst(cGraphics, 'clWebBlanchedAlmond', clWebBlanchedAlmond);\r\n AddConst(cGraphics, 'clWebBisque', clWebBisque);\r\n AddConst(cGraphics, 'clWebPeachPuff', clWebPeachPuff);\r\n AddConst(cGraphics, 'clWebTan', clWebTan);\r\n // yellows/reds yellow ->\r\n AddConst(cGraphics, 'clWebYellow', clWebYellow);\r\n AddConst(cGraphics, 'clWebDarkOrange', clWebDarkOrange);\r\n AddConst(cGraphics, 'clWebRed', clWebRed);\r\n AddConst(cGraphics, 'clWebDarkRed', clWebDarkRed);\r\n AddConst(cGraphics, 'clWebMaroon', clWebMaroon);\r\n AddConst(cGraphics, 'clWebIndianRed', clWebIndianRed);\r\n AddConst(cGraphics, 'clWebSalmon', clWebSalmon);\r\n AddConst(cGraphics, 'clWebCoral', clWebCoral);\r\n AddConst(cGraphics, 'clWebGold', clWebGold);\r\n AddConst(cGraphics, 'clWebTomato', clWebTomato);\r\n AddConst(cGraphics, 'clWebCrimson', clWebCrimson);\r\n AddConst(cGraphics, 'clWebBrown', clWebBrown);\r\n AddConst(cGraphics, 'clWebChocolate', clWebChocolate);\r\n AddConst(cGraphics, 'clWebSandyBrown', clWebSandyBrown);\r\n AddConst(cGraphics, 'clWebLightSalmon', clWebLightSalmon);\r\n AddConst(cGraphics, 'clWebLightCoral', clWebLightCoral);\r\n AddConst(cGraphics, 'clWebOrange', clWebOrange);\r\n AddConst(cGraphics, 'clWebOrangeRed', clWebOrangeRed);\r\n AddConst(cGraphics, 'clWebFirebrick', clWebFirebrick);\r\n AddConst(cGraphics, 'clWebSaddleBrown', clWebSaddleBrown);\r\n AddConst(cGraphics, 'clWebSienna', clWebSienna);\r\n AddConst(cGraphics, 'clWebPeru', clWebPeru);\r\n AddConst(cGraphics, 'clWebDarkSalmon', clWebDarkSalmon);\r\n AddConst(cGraphics, 'clWebRosyBrown', clWebRosyBrown);\r\n // greens palegoldenrod -\r\n AddConst(cGraphics, 'clWebPaleGoldenrod', clWebPaleGoldenrod);\r\n AddConst(cGraphics, 'clWebLightGoldenrodYellow', clWebLightGoldenrodYellow);\r\n AddConst(cGraphics, 'clWebOlive', clWebOlive);\r\n AddConst(cGraphics, 'clWebForestGreen', clWebForestGreen);\r\n AddConst(cGraphics, 'clWebGreenYellow', clWebGreenYellow);\r\n AddConst(cGraphics, 'clWebChartreuse', clWebChartreuse);\r\n AddConst(cGraphics, 'clWebLightGreen', clWebLightGreen);\r\n AddConst(cGraphics, 'clWebAquamarine', clWebAquamarine);\r\n AddConst(cGraphics, 'clWebSeaGreen', clWebSeaGreen);\r\n AddConst(cGraphics, 'clWebGoldenRod', clWebGoldenRod);\r\n AddConst(cGraphics, 'clWebKhaki', clWebKhaki);\r\n AddConst(cGraphics, 'clWebOliveDrab', clWebOliveDrab);\r\n AddConst(cGraphics, 'clWebGreen', clWebGreen);\r\n AddConst(cGraphics, 'clWebYellowGreen', clWebYellowGreen);\r\n AddConst(cGraphics, 'clWebLawnGreen', clWebLawnGreen);\r\n AddConst(cGraphics, 'clWebPaleGreen', clWebPaleGreen);\r\n AddConst(cGraphics, 'clWebMediumAquamarine', clWebMediumAquamarine);\r\n AddConst(cGraphics, 'clWebMediumSeaGreen', clWebMediumSeaGreen);\r\n AddConst(cGraphics, 'clWebDarkGoldenRod', clWebDarkGoldenRod);\r\n AddConst(cGraphics, 'clWebDarkKhaki', clWebDarkKhaki);\r\n AddConst(cGraphics, 'clWebDarkOliveGreen', clWebDarkOliveGreen);\r\n AddConst(cGraphics, 'clWebDarkgreen', clWebDarkgreen);\r\n AddConst(cGraphics, 'clWebLimeGreen', clWebLimeGreen);\r\n AddConst(cGraphics, 'clWebLime', clWebLime);\r\n AddConst(cGraphics, 'clWebSpringGreen', clWebSpringGreen);\r\n AddConst(cGraphics, 'clWebMediumSpringGreen', clWebMediumSpringGreen);\r\n AddConst(cGraphics, 'clWebDarkSeaGreen', clWebDarkSeaGreen);\r\n // greens/blues lightseag\r\n AddConst(cGraphics, 'clWebLightSeaGreen', clWebLightSeaGreen);\r\n AddConst(cGraphics, 'clWebPaleTurquoise', clWebPaleTurquoise);\r\n AddConst(cGraphics, 'clWebLightCyan', clWebLightCyan);\r\n AddConst(cGraphics, 'clWebLightBlue', clWebLightBlue);\r\n AddConst(cGraphics, 'clWebLightSkyBlue', clWebLightSkyBlue);\r\n AddConst(cGraphics, 'clWebCornFlowerBlue', clWebCornFlowerBlue);\r\n AddConst(cGraphics, 'clWebDarkBlue', clWebDarkBlue);\r\n AddConst(cGraphics, 'clWebIndigo', clWebIndigo);\r\n AddConst(cGraphics, 'clWebMediumTurquoise', clWebMediumTurquoise);\r\n AddConst(cGraphics, 'clWebTurquoise', clWebTurquoise);\r\n AddConst(cGraphics, 'clWebCyan', clWebCyan);\r\n AddConst(cGraphics, 'clWebAqua', clWebAqua);\r\n AddConst(cGraphics, 'clWebPowderBlue', clWebPowderBlue);\r\n AddConst(cGraphics, 'clWebSkyBlue', clWebSkyBlue);\r\n AddConst(cGraphics, 'clWebRoyalBlue', clWebRoyalBlue);\r\n AddConst(cGraphics, 'clWebMediumBlue', clWebMediumBlue);\r\n AddConst(cGraphics, 'clWebMidnightBlue', clWebMidnightBlue);\r\n AddConst(cGraphics, 'clWebDarkTurquoise', clWebDarkTurquoise);\r\n AddConst(cGraphics, 'clWebCadetBlue', clWebCadetBlue);\r\n AddConst(cGraphics, 'clWebDarkCyan', clWebDarkCyan);\r\n AddConst(cGraphics, 'clWebTeal', clWebTeal);\r\n AddConst(cGraphics, 'clWebDeepskyBlue', clWebDeepskyBlue);\r\n AddConst(cGraphics, 'clWebDodgerBlue', clWebDodgerBlue);\r\n AddConst(cGraphics, 'clWebBlue', clWebBlue);\r\n AddConst(cGraphics, 'clWebNavy', clWebNavy);\r\n // violets/pinks darkviol\r\n AddConst(cGraphics, 'clWebDarkViolet', clWebDarkViolet);\r\n AddConst(cGraphics, 'clWebDarkOrchid', clWebDarkOrchid);\r\n AddConst(cGraphics, 'clWebMagenta', clWebMagenta);\r\n AddConst(cGraphics, 'clWebFuchsia', clWebFuchsia);\r\n AddConst(cGraphics, 'clWebDarkMagenta', clWebDarkMagenta);\r\n AddConst(cGraphics, 'clWebMediumVioletRed', clWebMediumVioletRed);\r\n AddConst(cGraphics, 'clWebPaleVioletRed', clWebPaleVioletRed);\r\n AddConst(cGraphics, 'clWebBlueViolet', clWebBlueViolet);\r\n AddConst(cGraphics, 'clWebMediumOrchid', clWebMediumOrchid);\r\n AddConst(cGraphics, 'clWebMediumPurple', clWebMediumPurple);\r\n AddConst(cGraphics, 'clWebPurple', clWebPurple);\r\n AddConst(cGraphics, 'clWebDeepPink', clWebDeepPink);\r\n AddConst(cGraphics, 'clWebLightPink', clWebLightPink);\r\n AddConst(cGraphics, 'clWebViolet', clWebViolet);\r\n AddConst(cGraphics, 'clWebOrchid', clWebOrchid);\r\n AddConst(cGraphics, 'clWebPlum', clWebPlum);\r\n AddConst(cGraphics, 'clWebThistle', clWebThistle);\r\n AddConst(cGraphics, 'clWebHotPink', clWebHotPink);\r\n AddConst(cGraphics, 'clWebPink', clWebPink);\r\n // blue/gray/black lights\r\n AddConst(cGraphics, 'clWebLightSteelBlue', clWebLightSteelBlue);\r\n AddConst(cGraphics, 'clWebMediumSlateBlue', clWebMediumSlateBlue);\r\n AddConst(cGraphics, 'clWebLightSlateGray', clWebLightSlateGray);\r\n AddConst(cGraphics, 'clWebWhite', clWebWhite);\r\n AddConst(cGraphics, 'clWebLightgrey', clWebLightgrey);\r\n AddConst(cGraphics, 'clWebGray', clWebGray);\r\n AddConst(cGraphics, 'clWebSteelBlue', clWebSteelBlue);\r\n AddConst(cGraphics, 'clWebSlateBlue', clWebSlateBlue);\r\n AddConst(cGraphics, 'clWebSlateGray', clWebSlateGray);\r\n AddConst(cGraphics, 'clWebWhiteSmoke', clWebWhiteSmoke);\r\n AddConst(cGraphics, 'clWebSilver', clWebSilver);\r\n AddConst(cGraphics, 'clWebDimGray', clWebDimGray);\r\n AddConst(cGraphics, 'clWebMistyRose', clWebMistyRose);\r\n AddConst(cGraphics, 'clWebDarkSlateBlue', clWebDarkSlateBlue);\r\n AddConst(cGraphics, 'clWebDarkSlategray', clWebDarkSlategray);\r\n AddConst(cGraphics, 'clWebGainsboro', clWebGainsboro);\r\n AddConst(cGraphics, 'clWebDarkGray', clWebDarkGray);\r\n AddConst(cGraphics, 'clWebBlack', clWebBlack);\r\n {$ENDIF COMPILER9_UP}\r\n end;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvInterpreter_Grids.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvInterpreter_Grids.PAS, released on 2002-07-04.\r\n\r\nThe Initial Developers of the Original Code are: Andrei Prygounkov \r\nCopyright (c) 1999, 2002 Andrei Prygounkov\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nDescription : adapter unit - converts JvInterpreter calls to delphi calls\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvInterpreter_Grids.pas 12461 2009-08-14 17:21:33Z obones $\r\n\r\nunit JvInterpreter_Grids;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n JvInterpreter;\r\n\r\nprocedure RegisterJvInterpreterAdapter(JvInterpreterAdapter: TJvInterpreterAdapter);\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvInterpreter_Grids.pas $';\r\n Revision: '$Revision: 12461 $';\r\n Date: '$Date: 2009-08-14 19:21:33 +0200 (ven. 14 août 2009) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n Windows, Classes, Grids,\r\n JvInterpreter_Windows;\r\n\r\n{ EInvalidGridOperation }\r\n\r\n{ TInplaceEdit }\r\n\r\n{ constructor Create(AOwner: TComponent) }\r\n\r\nprocedure TInplaceEdit_Create(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TInplaceEdit.Create(V2O(Args.Values[0]) as TComponent));\r\nend;\r\n\r\n{ procedure Deselect; }\r\n\r\nprocedure TInplaceEdit_Deselect(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TInplaceEdit(Args.Obj).Deselect;\r\nend;\r\n\r\n{ procedure Hide; }\r\n\r\nprocedure TInplaceEdit_Hide(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TInplaceEdit(Args.Obj).Hide;\r\nend;\r\n\r\n{ procedure Invalidate; }\r\n\r\nprocedure TInplaceEdit_Invalidate(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TInplaceEdit(Args.Obj).Invalidate;\r\nend;\r\n\r\n{ procedure Move(const Loc: TRect); }\r\n\r\nprocedure TInplaceEdit_Move(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TInplaceEdit(Args.Obj).Move(Var2Rect(Args.Values[0]));\r\nend;\r\n\r\n{ function PosEqual(const Rect: TRect): Boolean; }\r\n\r\nprocedure TInplaceEdit_PosEqual(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TInplaceEdit(Args.Obj).PosEqual(Var2Rect(Args.Values[0]));\r\nend;\r\n\r\n{ procedure SetFocus; }\r\n\r\nprocedure TInplaceEdit_SetFocus(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TInplaceEdit(Args.Obj).SetFocus;\r\nend;\r\n\r\n{ procedure UpdateLoc(const Loc: TRect); }\r\n\r\nprocedure TInplaceEdit_UpdateLoc(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TInplaceEdit(Args.Obj).UpdateLoc(Var2Rect(Args.Values[0]));\r\nend;\r\n\r\n{ function Visible: Boolean; }\r\n\r\nprocedure TInplaceEdit_Visible(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TInplaceEdit(Args.Obj).Visible;\r\nend;\r\n\r\n{ TCustomGrid }\r\n\r\n{ function MouseCoord(X, Y: Integer): TGridCoord; }\r\n\r\nprocedure TCustomGrid_MouseCoord(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := Point2Var(TPoint(TCustomGrid(Args.Obj).MouseCoord(Args.Values[0], Args.Values[1])));\r\nend;\r\n\r\n{ TDrawGrid }\r\n\r\n{ constructor Create(AOwner: TComponent) }\r\n\r\nprocedure TDrawGrid_Create(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TDrawGrid.Create(V2O(Args.Values[0]) as TComponent));\r\nend;\r\n\r\n{ function CellRect(ACol, ARow: Longint): TRect; }\r\n\r\nprocedure TDrawGrid_CellRect(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := Rect2Var(TDrawGrid(Args.Obj).CellRect(Args.Values[0], Args.Values[1]));\r\nend;\r\n\r\n{ procedure MouseToCell(X, Y: Integer; var ACol, ARow: Longint); }\r\n\r\nprocedure TDrawGrid_MouseToCell(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TDrawGrid(Args.Obj).MouseToCell(Args.Values[0], Args.Values[1], Longint(TVarData(Args.Values[2]).vInteger),\r\n Longint(TVarData(Args.Values[3]).vInteger));\r\nend;\r\n\r\n{ TStringGrid }\r\n\r\n{ constructor Create(AOwner: TComponent) }\r\n\r\nprocedure TStringGrid_Create(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TStringGrid.Create(V2O(Args.Values[0]) as TComponent));\r\nend;\r\n\r\n{ property Read Cols[Integer]: TStrings }\r\n\r\nprocedure TStringGrid_Read_Cols(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TStringGrid(Args.Obj).Cols[Args.Values[0]]);\r\nend;\r\n\r\n{ property Write Cols[Integer]: TStrings }\r\n\r\nprocedure TStringGrid_Write_Cols(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TStringGrid(Args.Obj).Cols[Args.Values[0]] := V2O(Value) as TStrings;\r\nend;\r\n\r\n{ property Read Rows[Integer]: TStrings }\r\n\r\nprocedure TStringGrid_Read_Rows(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TStringGrid(Args.Obj).Rows[Args.Values[0]]);\r\nend;\r\n\r\n{ property Write Rows[Integer]: TStrings }\r\n\r\nprocedure TStringGrid_Write_Rows(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TStringGrid(Args.Obj).Rows[Args.Values[0]] := V2O(Value) as TStrings;\r\nend;\r\n\r\nprocedure RegisterJvInterpreterAdapter(JvInterpreterAdapter: TJvInterpreterAdapter);\r\nconst\r\n cGrids = 'Grids';\r\nbegin\r\n with JvInterpreterAdapter do\r\n begin\r\n { EInvalidGridOperation }\r\n AddClass(cGrids, EInvalidGridOperation, 'EInvalidGridOperation');\r\n { TGridState }\r\n AddConst(cGrids, 'gsNormal', Ord(gsNormal));\r\n AddConst(cGrids, 'gsSelecting', Ord(gsSelecting));\r\n AddConst(cGrids, 'gsRowSizing', Ord(gsRowSizing));\r\n AddConst(cGrids, 'gsColSizing', Ord(gsColSizing));\r\n AddConst(cGrids, 'gsRowMoving', Ord(gsRowMoving));\r\n AddConst(cGrids, 'gsColMoving', Ord(gsColMoving));\r\n { TInplaceEdit }\r\n AddClass(cGrids, TInplaceEdit, 'TInplaceEdit');\r\n AddGet(TInplaceEdit, 'Create', TInplaceEdit_Create, 1, [varEmpty], varEmpty);\r\n AddGet(TInplaceEdit, 'Deselect', TInplaceEdit_Deselect, 0, [varEmpty], varEmpty);\r\n AddGet(TInplaceEdit, 'Hide', TInplaceEdit_Hide, 0, [varEmpty], varEmpty);\r\n AddGet(TInplaceEdit, 'Invalidate', TInplaceEdit_Invalidate, 0, [varEmpty], varEmpty);\r\n AddGet(TInplaceEdit, 'Move', TInplaceEdit_Move, 1, [varEmpty], varEmpty);\r\n AddGet(TInplaceEdit, 'PosEqual', TInplaceEdit_PosEqual, 1, [varEmpty], varEmpty);\r\n AddGet(TInplaceEdit, 'SetFocus', TInplaceEdit_SetFocus, 0, [varEmpty], varEmpty);\r\n AddGet(TInplaceEdit, 'UpdateLoc', TInplaceEdit_UpdateLoc, 1, [varEmpty], varEmpty);\r\n AddGet(TInplaceEdit, 'Visible', TInplaceEdit_Visible, 0, [varEmpty], varEmpty);\r\n { TGridOption }\r\n AddConst(cGrids, 'goFixedVertLine', Ord(goFixedVertLine));\r\n AddConst(cGrids, 'goFixedHorzLine', Ord(goFixedHorzLine));\r\n AddConst(cGrids, 'goVertLine', Ord(goVertLine));\r\n AddConst(cGrids, 'goHorzLine', Ord(goHorzLine));\r\n AddConst(cGrids, 'goRangeSelect', Ord(goRangeSelect));\r\n AddConst(cGrids, 'goDrawFocusSelected', Ord(goDrawFocusSelected));\r\n AddConst(cGrids, 'goRowSizing', Ord(goRowSizing));\r\n AddConst(cGrids, 'goColSizing', Ord(goColSizing));\r\n AddConst(cGrids, 'goRowMoving', Ord(goRowMoving));\r\n AddConst(cGrids, 'goColMoving', Ord(goColMoving));\r\n AddConst(cGrids, 'goEditing', Ord(goEditing));\r\n AddConst(cGrids, 'goTabs', Ord(goTabs));\r\n AddConst(cGrids, 'goRowSelect', Ord(goRowSelect));\r\n AddConst(cGrids, 'goAlwaysShowEditor', Ord(goAlwaysShowEditor));\r\n AddConst(cGrids, 'goThumbTracking', Ord(goThumbTracking));\r\n { TGridDrawState }\r\n AddConst(cGrids, 'gdSelected', Ord(gdSelected));\r\n AddConst(cGrids, 'gdFocused', Ord(gdFocused));\r\n AddConst(cGrids, 'gdFixed', Ord(gdFixed));\r\n { TGridScrollDirection }\r\n AddConst(cGrids, 'sdLeft', Ord(sdLeft));\r\n AddConst(cGrids, 'sdRight', Ord(sdRight));\r\n AddConst(cGrids, 'sdUp', Ord(sdUp));\r\n AddConst(cGrids, 'sdDown', Ord(sdDown));\r\n { TCustomGrid }\r\n AddClass(cGrids, TCustomGrid, 'TCustomGrid');\r\n AddGet(TCustomGrid, 'MouseCoord', TCustomGrid_MouseCoord, 2, [varEmpty, varEmpty], varEmpty);\r\n { TDrawGrid }\r\n AddClass(cGrids, TDrawGrid, 'TDrawGrid');\r\n AddGet(TDrawGrid, 'Create', TDrawGrid_Create, 1, [varEmpty], varEmpty);\r\n AddGet(TDrawGrid, 'CellRect', TDrawGrid_CellRect, 2, [varEmpty, varEmpty], varEmpty);\r\n AddGet(TDrawGrid, 'MouseToCell', TDrawGrid_MouseToCell, 4, [varEmpty, varEmpty, varByRef, varByRef], varEmpty);\r\n { TStringGrid }\r\n AddClass(cGrids, TStringGrid, 'TStringGrid');\r\n AddGet(TStringGrid, 'Create', TStringGrid_Create, 1, [varEmpty], varEmpty);\r\n AddGet(TStringGrid, 'Cols', TStringGrid_Read_Cols, 1, [varEmpty], varEmpty);\r\n AddSet(TStringGrid, 'Cols', TStringGrid_Write_Cols, 1, [varNull]);\r\n AddGet(TStringGrid, 'Rows', TStringGrid_Read_Rows, 1, [varEmpty], varEmpty);\r\n AddSet(TStringGrid, 'Rows', TStringGrid_Write_Rows, 1, [varNull]);\r\n end;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvInterpreter_JvEditor.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvInterpreter_JvEditor.PAS, released on 2002-07-04.\r\n\r\nThe Initial Developers of the Original Code are: Andrei Prygounkov \r\nCopyright (c) 1999, 2002 Andrei Prygounkov\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nDescription : adapter unit - converts JvInterpreter calls to delphi calls\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvInterpreter_JvEditor.pas 12481 2009-08-26 08:39:55Z obones $\r\n\r\nunit JvInterpreter_JvEditor;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n JvInterpreter;\r\n\r\nprocedure RegisterJvInterpreterAdapter(JvInterpreterAdapter: TJvInterpreterAdapter);\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvInterpreter_JvEditor.pas $';\r\n Revision: '$Revision: 12481 $';\r\n Date: '$Date: 2009-08-26 10:39:55 +0200 (mer. 26 août 2009) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n Classes,\r\n JvEditor, JvEditorCommon, JvHLEditor, JvInterpreter_Windows;\r\n\r\n{ TJvKeyboard }\r\n\r\n{ constructor Create }\r\n\r\nprocedure TKeyboard_Create(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TJvKeyboard.Create);\r\nend;\r\n\r\n{ procedure Add(const ACommand: TEditCommand; const AKey1: word; const AShift1: TShiftState); }\r\n\r\nprocedure TKeyboard_Add(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TJvKeyboard(Args.Obj).Add(Args.Values[0], Args.Values[1], TShiftState(TJvInterpreterShiftStateCastType(V2S(Args.Values[2]))));\r\nend;\r\n\r\n{ procedure Add2(const ACommand: TEditCommand; const AKey1: word; const AShift1: TShiftState; const AKey2: word; const AShift2: TShiftState); }\r\n\r\nprocedure TKeyboard_Add2(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TJvKeyboard(Args.Obj).Add2(Args.Values[0], Args.Values[1], TShiftState(TJvInterpreterShiftStateCastType(V2S(Args.Values[2]))), Args.Values[3],\r\n TShiftState(TJvInterpreterShiftStateCastType(V2S(Args.Values[4]))));\r\nend;\r\n\r\n{ procedure Clear; }\r\n\r\nprocedure TKeyboard_Clear(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TJvKeyboard(Args.Obj).Clear;\r\nend;\r\n\r\n{ procedure SetDefLayout; }\r\n\r\nprocedure TKeyboard_SetDefLayout(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TJvKeyboard(Args.Obj).SetDefLayout;\r\nend;\r\n\r\n{ EJvEditorError }\r\n\r\n{ TJvCustomEditor }\r\n\r\n{ constructor Create(AOwner: TComponent) }\r\n\r\nprocedure TRACustomEditor_Create(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TJvCustomEditor.Create(V2O(Args.Values[0]) as TComponent));\r\nend;\r\n\r\n{ procedure SetLeftTop(ALeftCol, ATopRow: Integer); }\r\n\r\nprocedure TRACustomEditor_SetLeftTop(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TJvCustomEditor(Args.Obj).SetLeftTop(Args.Values[0], Args.Values[1]);\r\nend;\r\n\r\n{ procedure ClipBoardCopy; }\r\n\r\nprocedure TRACustomEditor_ClipBoardCopy(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TJvCustomEditor(Args.Obj).ClipBoardCopy;\r\nend;\r\n\r\n{ procedure ClipBoardPaste; }\r\n\r\nprocedure TRACustomEditor_ClipBoardPaste(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TJvCustomEditor(Args.Obj).ClipBoardPaste;\r\nend;\r\n\r\n{ procedure ClipBoardCut; }\r\n\r\nprocedure TRACustomEditor_ClipBoardCut(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TJvCustomEditor(Args.Obj).ClipBoardCut;\r\nend;\r\n\r\n{ procedure DeleteSelected; }\r\n\r\nprocedure TRACustomEditor_DeleteSelected(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TJvCustomEditor(Args.Obj).DeleteSelected;\r\nend;\r\n\r\n{ function CalcCellRect(const X, Y: Integer): TRect; }\r\n\r\nprocedure TRACustomEditor_CalcCellRect(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := Rect2Var(TJvCustomEditor(Args.Obj).CalcCellRect(Args.Values[0], Args.Values[1]));\r\nend;\r\n\r\n{ procedure SetCaret(X, Y: Integer); }\r\n\r\nprocedure TRACustomEditor_SetCaret(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TJvCustomEditor(Args.Obj).SetCaret(Args.Values[0], Args.Values[1]);\r\nend;\r\n\r\n{ procedure CaretFromPos(const Pos: Integer; var X, Y: Integer); }\r\n\r\nprocedure TRACustomEditor_CaretFromPos(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TJvCustomEditor(Args.Obj).CaretFromPos(Args.Values[0], TVarData(Args.Values[1]).vInteger,\r\n TVarData(Args.Values[2]).vInteger);\r\nend;\r\n\r\n{ function PosFromCaret(const X, Y: Integer): Integer; }\r\n\r\nprocedure TRACustomEditor_PosFromCaret(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TJvCustomEditor(Args.Obj).PosFromCaret(Args.Values[0], Args.Values[1]);\r\nend;\r\n\r\n{ procedure PaintCaret(const bShow: Boolean); }\r\n\r\nprocedure TRACustomEditor_PaintCaret(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TJvCustomEditor(Args.Obj).PaintCaret(Args.Values[0]);\r\nend;\r\n\r\n{ function GetTextLen: Integer; }\r\n\r\nprocedure TRACustomEditor_GetTextLen(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TJvCustomEditor(Args.Obj).GetTextLen;\r\nend;\r\n\r\n{ function GetSelText: string; }\r\n\r\nprocedure TRACustomEditor_GetSelText(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TJvCustomEditor(Args.Obj).GetSelText;\r\nend;\r\n\r\n{ procedure SetSelText(const AValue: string); }\r\n\r\nprocedure TRACustomEditor_SetSelText(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TJvCustomEditor(Args.Obj).SetSelText(Args.Values[0]);\r\nend;\r\n\r\n{ function GetWordOnCaret: string; }\r\n\r\nprocedure TRACustomEditor_GetWordOnCaret(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TJvCustomEditor(Args.Obj).GetWordOnCaret;\r\nend;\r\n\r\n{ procedure BeginUpdate; }\r\n\r\nprocedure TRACustomEditor_BeginUpdate(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TJvCustomEditor(Args.Obj).BeginUpdate;\r\nend;\r\n\r\n{ procedure EndUpdate; }\r\n\r\nprocedure TRACustomEditor_EndUpdate(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TJvCustomEditor(Args.Obj).EndUpdate;\r\nend;\r\n\r\n{ procedure MakeRowVisible(ARow: Integer); }\r\n\r\nprocedure TRACustomEditor_MakeRowVisible(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TJvCustomEditor(Args.Obj).MakeRowVisible(Args.Values[0]);\r\nend;\r\n\r\n{ procedure Command(ACommand: TEditCommand); }\r\n\r\nprocedure TRACustomEditor_Command(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TJvCustomEditor(Args.Obj).Command(Args.Values[0]);\r\nend;\r\n\r\n{ procedure PostCommand(ACommand: TEditCommand); }\r\n\r\nprocedure TRACustomEditor_PostCommand(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TJvCustomEditor(Args.Obj).PostCommand(Args.Values[0]);\r\nend;\r\n\r\n{ procedure InsertText(const Text: string); }\r\n\r\nprocedure TRACustomEditor_InsertText(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TJvCustomEditor(Args.Obj).InsertText(Args.Values[0]);\r\nend;\r\n\r\n{ procedure ReplaceWord(const NewString: string); }\r\n\r\nprocedure TRACustomEditor_ReplaceWord(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TJvCustomEditor(Args.Obj).ReplaceWord(Args.Values[0]);\r\nend;\r\n\r\n{ procedure ReplaceWord2(const NewString: string); }\r\n\r\nprocedure TRACustomEditor_ReplaceWord2(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TJvCustomEditor(Args.Obj).ReplaceWord2(Args.Values[0]);\r\nend;\r\n\r\n{ procedure BeginCompound; }\r\n\r\nprocedure TRACustomEditor_BeginCompound(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TJvCustomEditor(Args.Obj).BeginCompound;\r\nend;\r\n\r\n{ procedure EndCompound; }\r\n\r\nprocedure TRACustomEditor_EndCompound(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TJvCustomEditor(Args.Obj).EndCompound;\r\nend;\r\n\r\n{ property Read LeftCol: Integer }\r\n\r\nprocedure TRACustomEditor_Read_LeftCol(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TJvCustomEditor(Args.Obj).LeftCol;\r\nend;\r\n\r\n{ property Read TopRow: Integer }\r\n\r\nprocedure TRACustomEditor_Read_TopRow(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TJvCustomEditor(Args.Obj).TopRow;\r\nend;\r\n\r\n{ property Read VisibleColCount: Integer }\r\n\r\nprocedure TRACustomEditor_Read_VisibleColCount(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TJvCustomEditor(Args.Obj).VisibleColCount;\r\nend;\r\n\r\n{ property Read VisibleRowCount: Integer }\r\n\r\nprocedure TRACustomEditor_Read_VisibleRowCount(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TJvCustomEditor(Args.Obj).VisibleRowCount;\r\nend;\r\n\r\n{ property Read LastVisibleCol: Integer }\r\n\r\nprocedure TRACustomEditor_Read_LastVisibleCol(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TJvCustomEditor(Args.Obj).LastVisibleCol;\r\nend;\r\n\r\n{ property Read LastVisibleRow: Integer }\r\n\r\nprocedure TRACustomEditor_Read_LastVisibleRow(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TJvCustomEditor(Args.Obj).LastVisibleRow;\r\nend;\r\n\r\n{ property Read Cols: Integer }\r\n\r\nprocedure TRACustomEditor_Read_Cols(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TJvCustomEditor(Args.Obj).Cols;\r\nend;\r\n\r\n{ property Write Cols(Value: Integer) }\r\n\r\nprocedure TRACustomEditor_Write_Cols(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TJvCustomEditor(Args.Obj).Cols := Value;\r\nend;\r\n\r\n{ property Read Rows: Integer }\r\n\r\nprocedure TRACustomEditor_Read_Rows(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TJvCustomEditor(Args.Obj).Rows;\r\nend;\r\n\r\n{ property Write Rows(Value: Integer) }\r\n\r\nprocedure TRACustomEditor_Write_Rows(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TJvCustomEditor(Args.Obj).Rows := Value;\r\nend;\r\n\r\n{ property Read CaretX: Integer }\r\n\r\nprocedure TRACustomEditor_Read_CaretX(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TJvCustomEditor(Args.Obj).CaretX;\r\nend;\r\n\r\n{ property Write CaretX(Value: Integer) }\r\n\r\nprocedure TRACustomEditor_Write_CaretX(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TJvCustomEditor(Args.Obj).CaretX := Value;\r\nend;\r\n\r\n{ property Read CaretY: Integer }\r\n\r\nprocedure TRACustomEditor_Read_CaretY(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TJvCustomEditor(Args.Obj).CaretY;\r\nend;\r\n\r\n{ property Write CaretY(Value: Integer) }\r\n\r\nprocedure TRACustomEditor_Write_CaretY(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TJvCustomEditor(Args.Obj).CaretY := Value;\r\nend;\r\n\r\n{ property Read Modified: Boolean }\r\n\r\nprocedure TRACustomEditor_Read_Modified(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TJvCustomEditor(Args.Obj).Modified;\r\nend;\r\n\r\n{ property Write Modified(Value: Boolean) }\r\n\r\nprocedure TRACustomEditor_Write_Modified(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TJvCustomEditor(Args.Obj).Modified := Value;\r\nend;\r\n\r\n{ property Read SelStart: Integer }\r\n\r\nprocedure TRACustomEditor_Read_SelStart(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TJvCustomEditor(Args.Obj).SelStart;\r\nend;\r\n\r\n{ property Write SelStart(Value: Integer) }\r\n\r\nprocedure TRACustomEditor_Write_SelStart(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TJvCustomEditor(Args.Obj).SelStart := Value;\r\nend;\r\n\r\n{ property Read SelLength: Integer }\r\n\r\nprocedure TRACustomEditor_Read_SelLength(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TJvCustomEditor(Args.Obj).SelLength;\r\nend;\r\n\r\n{ property Write SelLength(Value: Integer) }\r\n\r\nprocedure TRACustomEditor_Write_SelLength(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TJvCustomEditor(Args.Obj).SelLength := Value;\r\nend;\r\n\r\n{ property Read SelText: string }\r\n\r\nprocedure TRACustomEditor_Read_SelText(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TJvCustomEditor(Args.Obj).SelText;\r\nend;\r\n\r\n{ property Write SelText(Value: string) }\r\n\r\nprocedure TRACustomEditor_Write_SelText(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TJvCustomEditor(Args.Obj).SelText := Value;\r\nend;\r\n\r\n(*\r\n{ property Read BookMarks: TBookMarks }\r\nprocedure TRACustomEditor_Read_BookMarks(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TJvCustomEditor(Args.Obj).BookMarks;\r\nend;\r\n*)\r\n\r\n{ property Read Keyboard: TJvKeyboard }\r\n\r\nprocedure TRACustomEditor_Read_Keyboard(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TJvCustomEditor(Args.Obj).Keyboard);\r\nend;\r\n\r\n(*\r\n{ property Read CellRect: TCellRect }\r\nprocedure TRACustomEditor_Read_CellRect(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TJvCustomEditor(Args.Obj).CellRect;\r\nend;\r\n*)\r\n\r\n{ property Read UndoBuffer: TUndoBuffer }\r\n\r\nprocedure TRACustomEditor_Read_UndoBuffer(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TJvCustomEditor(Args.Obj).UndoBuffer);\r\nend;\r\n\r\n{ property Read Recording: Boolean }\r\n\r\nprocedure TRACustomEditor_Read_Recording(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TJvCustomEditor(Args.Obj).Recording;\r\nend;\r\n\r\nprocedure TRACustomEditor_Read_BookMarkX(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TJvCustomEditor(Args.Obj).BookMarks[Integer(Args.Values[0])].X;\r\nend;\r\n\r\nprocedure TRACustomEditor_Read_BookMarkY(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TJvCustomEditor(Args.Obj).BookMarks[Integer(Args.Values[0])].Y;\r\nend;\r\n\r\nprocedure TRACustomEditor_Read_BookMarkValid(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TJvCustomEditor(Args.Obj).BookMarks[Integer(Args.Values[0])].Valid;\r\nend;\r\n\r\nprocedure TRACustomEditor_Write_BookMarkX(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TJvCustomEditor(Args.Obj).BookMarks[Integer(Args.Values[0])].X := Value;\r\nend;\r\n\r\nprocedure TRACustomEditor_Write_BookMarkY(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TJvCustomEditor(Args.Obj).BookMarks[Integer(Args.Values[0])].Y := Value;\r\nend;\r\n\r\nprocedure TRACustomEditor_Write_BookMarkValid(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TJvCustomEditor(Args.Obj).BookMarks[Integer(Args.Values[0])].Valid := Value;\r\nend;\r\n\r\nprocedure RegisterJvInterpreterAdapter(JvInterpreterAdapter: TJvInterpreterAdapter);\r\nconst\r\n cJvEditor = 'JvEditor';\r\nbegin\r\n with JvInterpreterAdapter do\r\n begin\r\n { TModifiedAction }\r\n AddConst(cJvEditor, 'maInsert', Ord(maInsert));\r\n AddConst(cJvEditor, 'maDelete', Ord(maDelete));\r\n { TJvKeyboard }\r\n AddClass(cJvEditor, TJvKeyboard, 'TJvKeyboard ');\r\n AddGet(TJvKeyboard, 'Create', TKeyboard_Create, 0, [varEmpty], varEmpty);\r\n AddGet(TJvKeyboard, 'Add', TKeyboard_Add, 3, [varEmpty, varEmpty, varEmpty], varEmpty);\r\n AddGet(TJvKeyboard, 'Add2', TKeyboard_Add2, 5, [varEmpty, varEmpty, varEmpty, varEmpty, varEmpty], varEmpty);\r\n AddGet(TJvKeyboard, 'Clear', TKeyboard_Clear, 0, [varEmpty], varEmpty);\r\n AddGet(TJvKeyboard, 'SetDefLayout', TKeyboard_SetDefLayout, 0, [varEmpty], varEmpty);\r\n { EJvEditorError }\r\n AddClass(cJvEditor, EJvEditorError, 'EJvEditorError ');\r\n { TTabStop }\r\n// AddConst(cJvEditor, 'tsTabStop', Ord(tsTabStop));\r\n// AddConst(cJvEditor, 'tsAutoIndent', Ord(tsAutoIndent));\r\n { TJvCustomEditor }\r\n AddClass(cJvEditor, TJvCustomEditor, 'TJvCustomEditor');\r\n AddGet(TJvCustomEditor, 'Create', TRACustomEditor_Create, 1, [varEmpty], varEmpty);\r\n AddGet(TJvCustomEditor, 'SetLeftTop', TRACustomEditor_SetLeftTop, 2, [varEmpty, varEmpty], varEmpty);\r\n AddGet(TJvCustomEditor, 'ClipBoardCopy', TRACustomEditor_ClipBoardCopy, 0, [varEmpty], varEmpty);\r\n AddGet(TJvCustomEditor, 'ClipBoardPaste', TRACustomEditor_ClipBoardPaste, 0, [varEmpty], varEmpty);\r\n AddGet(TJvCustomEditor, 'ClipBoardCut', TRACustomEditor_ClipBoardCut, 0, [varEmpty], varEmpty);\r\n AddGet(TJvCustomEditor, 'DeleteSelected', TRACustomEditor_DeleteSelected, 0, [varEmpty], varEmpty);\r\n AddGet(TJvCustomEditor, 'CalcCellRect', TRACustomEditor_CalcCellRect, 2, [varEmpty, varEmpty], varEmpty);\r\n AddGet(TJvCustomEditor, 'SetCaret', TRACustomEditor_SetCaret, 2, [varEmpty, varEmpty], varEmpty);\r\n AddGet(TJvCustomEditor, 'CaretFromPos', TRACustomEditor_CaretFromPos, 3, [varEmpty, varByRef, varByRef], varEmpty);\r\n AddGet(TJvCustomEditor, 'PosFromCaret', TRACustomEditor_PosFromCaret, 2, [varEmpty, varEmpty], varEmpty);\r\n AddGet(TJvCustomEditor, 'PaintCaret', TRACustomEditor_PaintCaret, 1, [varEmpty], varEmpty);\r\n AddGet(TJvCustomEditor, 'GetTextLen', TRACustomEditor_GetTextLen, 0, [varEmpty], varEmpty);\r\n AddGet(TJvCustomEditor, 'GetSelText', TRACustomEditor_GetSelText, 0, [varEmpty], varEmpty);\r\n AddGet(TJvCustomEditor, 'SetSelText', TRACustomEditor_SetSelText, 1, [varEmpty], varEmpty);\r\n AddGet(TJvCustomEditor, 'GetWordOnCaret', TRACustomEditor_GetWordOnCaret, 0, [varEmpty], varEmpty);\r\n AddGet(TJvCustomEditor, 'BeginUpdate', TRACustomEditor_BeginUpdate, 0, [varEmpty], varEmpty);\r\n AddGet(TJvCustomEditor, 'EndUpdate', TRACustomEditor_EndUpdate, 0, [varEmpty], varEmpty);\r\n AddGet(TJvCustomEditor, 'MakeRowVisible', TRACustomEditor_MakeRowVisible, 1, [varEmpty], varEmpty);\r\n AddGet(TJvCustomEditor, 'Command', TRACustomEditor_Command, 1, [varEmpty], varEmpty);\r\n AddGet(TJvCustomEditor, 'PostCommand', TRACustomEditor_PostCommand, 1, [varEmpty], varEmpty);\r\n AddGet(TJvCustomEditor, 'InsertText', TRACustomEditor_InsertText, 1, [varEmpty], varEmpty);\r\n AddGet(TJvCustomEditor, 'ReplaceWord', TRACustomEditor_ReplaceWord, 1, [varEmpty], varEmpty);\r\n AddGet(TJvCustomEditor, 'ReplaceWord2', TRACustomEditor_ReplaceWord2, 1, [varEmpty], varEmpty);\r\n AddGet(TJvCustomEditor, 'BeginCompound', TRACustomEditor_BeginCompound, 0, [varEmpty], varEmpty);\r\n AddGet(TJvCustomEditor, 'EndCompound', TRACustomEditor_EndCompound, 0, [varEmpty], varEmpty);\r\n AddGet(TJvCustomEditor, 'LeftCol', TRACustomEditor_Read_LeftCol, 0, [varEmpty], varEmpty);\r\n AddGet(TJvCustomEditor, 'TopRow', TRACustomEditor_Read_TopRow, 0, [varEmpty], varEmpty);\r\n AddGet(TJvCustomEditor, 'VisibleColCount', TRACustomEditor_Read_VisibleColCount, 0, [varEmpty], varEmpty);\r\n AddGet(TJvCustomEditor, 'VisibleRowCount', TRACustomEditor_Read_VisibleRowCount, 0, [varEmpty], varEmpty);\r\n AddGet(TJvCustomEditor, 'LastVisibleCol', TRACustomEditor_Read_LastVisibleCol, 0, [varEmpty], varEmpty);\r\n AddGet(TJvCustomEditor, 'LastVisibleRow', TRACustomEditor_Read_LastVisibleRow, 0, [varEmpty], varEmpty);\r\n AddGet(TJvCustomEditor, 'Cols', TRACustomEditor_Read_Cols, 0, [varEmpty], varEmpty);\r\n AddSet(TJvCustomEditor, 'Cols', TRACustomEditor_Write_Cols, 0, [varEmpty]);\r\n AddGet(TJvCustomEditor, 'Rows', TRACustomEditor_Read_Rows, 0, [varEmpty], varEmpty);\r\n AddSet(TJvCustomEditor, 'Rows', TRACustomEditor_Write_Rows, 0, [varEmpty]);\r\n AddGet(TJvCustomEditor, 'CaretX', TRACustomEditor_Read_CaretX, 0, [varEmpty], varEmpty);\r\n AddSet(TJvCustomEditor, 'CaretX', TRACustomEditor_Write_CaretX, 0, [varEmpty]);\r\n AddGet(TJvCustomEditor, 'CaretY', TRACustomEditor_Read_CaretY, 0, [varEmpty], varEmpty);\r\n AddSet(TJvCustomEditor, 'CaretY', TRACustomEditor_Write_CaretY, 0, [varEmpty]);\r\n AddGet(TJvCustomEditor, 'Modified', TRACustomEditor_Read_Modified, 0, [varEmpty], varEmpty);\r\n AddSet(TJvCustomEditor, 'Modified', TRACustomEditor_Write_Modified, 0, [varEmpty]);\r\n AddGet(TJvCustomEditor, 'SelStart', TRACustomEditor_Read_SelStart, 0, [varEmpty], varEmpty);\r\n AddSet(TJvCustomEditor, 'SelStart', TRACustomEditor_Write_SelStart, 0, [varEmpty]);\r\n AddGet(TJvCustomEditor, 'SelLength', TRACustomEditor_Read_SelLength, 0, [varEmpty], varEmpty);\r\n AddSet(TJvCustomEditor, 'SelLength', TRACustomEditor_Write_SelLength, 0, [varEmpty]);\r\n AddGet(TJvCustomEditor, 'SelText', TRACustomEditor_Read_SelText, 0, [varEmpty], varEmpty);\r\n AddSet(TJvCustomEditor, 'SelText', TRACustomEditor_Write_SelText, 0, [varEmpty]);\r\n // AddGet(TJvCustomEditor, 'BookMarks', TRACustomEditor_Read_BookMarks, 0, [varEmpty], nil);\r\n AddGet(TJvCustomEditor, 'Keyboard', TRACustomEditor_Read_Keyboard, 0, [varEmpty], varEmpty);\r\n // AddGet(TJvCustomEditor, 'CellRect', TRACustomEditor_Read_CellRect, 0, [varEmpty], nil);\r\n AddGet(TJvCustomEditor, 'UndoBuffer', TRACustomEditor_Read_UndoBuffer, 0, [varEmpty], varEmpty);\r\n AddGet(TJvCustomEditor, 'Recording', TRACustomEditor_Read_Recording, 0, [varEmpty], varEmpty);\r\n\r\n AddIGet(TJvCustomEditor, 'BookMarkX', TRACustomEditor_Read_BookMarkX, 1, [varInteger], varEmpty);\r\n AddIGet(TJvCustomEditor, 'BookMarkY', TRACustomEditor_Read_BookMarkY, 1, [varInteger], varEmpty);\r\n AddIGet(TJvCustomEditor, 'BookMarkValid', TRACustomEditor_Read_BookMarkValid, 1, [varInteger], varEmpty);\r\n AddISet(TJvCustomEditor, 'BookMarkX', TRACustomEditor_Write_BookMarkX, 1, [varInteger]);\r\n AddISet(TJvCustomEditor, 'BookMarkY', TRACustomEditor_Write_BookMarkY, 1, [varInteger]);\r\n AddISet(TJvCustomEditor, 'BookMarkValid', TRACustomEditor_Write_BookMarkValid, 1, [varInteger]);\r\n\r\n { TCompletionList }\r\n AddConst(cJvEditor, 'cmIdentifiers', Ord(cmIdentifiers));\r\n AddConst(cJvEditor, 'cmTemplates', Ord(cmTemplates));\r\n\r\n AddConst(cJvEditor, 'ecCharFirst', Ord(ecCharFirst));\r\n AddConst(cJvEditor, 'ecCharLast', Ord(ecCharLast));\r\n AddConst(cJvEditor, 'ecCommandFirst', Ord(ecCommandFirst));\r\n AddConst(cJvEditor, 'ecUser', Ord(ecUser));\r\n AddConst(cJvEditor, 'ecLeft', Ord(ecLeft));\r\n AddConst(cJvEditor, 'ecUp', Ord(ecUp));\r\n AddConst(cJvEditor, 'ecRight', Ord(ecRight));\r\n AddConst(cJvEditor, 'ecDown', Ord(ecDown));\r\n AddConst(cJvEditor, 'ecSelLeft', Ord(ecSelLeft));\r\n AddConst(cJvEditor, 'ecSelUp', Ord(ecSelUp));\r\n AddConst(cJvEditor, 'ecSelRight', Ord(ecSelRight));\r\n AddConst(cJvEditor, 'ecSelDown', Ord(ecSelDown));\r\n AddConst(cJvEditor, 'ecPrevWord', Ord(ecPrevWord));\r\n AddConst(cJvEditor, 'ecNextWord', Ord(ecNextWord));\r\n AddConst(cJvEditor, 'ecSelPrevWord', Ord(ecSelPrevWord));\r\n AddConst(cJvEditor, 'ecSelNextWord', Ord(ecSelNextWord));\r\n AddConst(cJvEditor, 'ecSelWord', Ord(ecSelWord));\r\n AddConst(cJvEditor, 'ecWindowTop', Ord(ecWindowTop));\r\n AddConst(cJvEditor, 'ecWindowBottom', Ord(ecWindowBottom));\r\n AddConst(cJvEditor, 'ecPrevPage', Ord(ecPrevPage));\r\n AddConst(cJvEditor, 'ecNextPage', Ord(ecNextPage));\r\n AddConst(cJvEditor, 'ecSelPrevPage', Ord(ecSelPrevPage));\r\n AddConst(cJvEditor, 'ecSelNextPage', Ord(ecSelNextPage));\r\n AddConst(cJvEditor, 'ecBeginLine', Ord(ecBeginLine));\r\n AddConst(cJvEditor, 'ecEndLine', Ord(ecEndLine));\r\n AddConst(cJvEditor, 'ecBeginDoc', Ord(ecBeginDoc));\r\n AddConst(cJvEditor, 'ecEndDoc', Ord(ecEndDoc));\r\n AddConst(cJvEditor, 'ecSelBeginLine', Ord(ecSelBeginLine));\r\n AddConst(cJvEditor, 'ecSelEndLine', Ord(ecSelEndLine));\r\n AddConst(cJvEditor, 'ecSelBeginDoc', Ord(ecSelBeginDoc));\r\n AddConst(cJvEditor, 'ecSelEndDoc', Ord(ecSelEndDoc));\r\n AddConst(cJvEditor, 'ecSelAll', Ord(ecSelAll));\r\n AddConst(cJvEditor, 'ecScrollLineUp', Ord(ecScrollLineUp));\r\n AddConst(cJvEditor, 'ecScrollLineDown', Ord(ecScrollLineDown));\r\n AddConst(cJvEditor, 'ecInsertPara', Ord(ecInsertPara));\r\n AddConst(cJvEditor, 'ecBackspace', Ord(ecBackspace));\r\n AddConst(cJvEditor, 'ecDelete', Ord(ecDelete));\r\n AddConst(cJvEditor, 'ecChangeInsertMode', Ord(ecChangeInsertMode));\r\n AddConst(cJvEditor, 'ecTab', Ord(ecTab));\r\n AddConst(cJvEditor, 'ecBackTab', Ord(ecBackTab));\r\n AddConst(cJvEditor, 'ecIndent', Ord(ecIndent));\r\n AddConst(cJvEditor, 'ecUnindent', Ord(ecUnindent));\r\n AddConst(cJvEditor, 'ecDeleteSelected', Ord(ecDeleteSelected));\r\n AddConst(cJvEditor, 'ecClipboardCopy', Ord(ecClipboardCopy));\r\n AddConst(cJvEditor, 'ecClipboardCut', Ord(ecClipboardCut));\r\n AddConst(cJvEditor, 'ecClipBoardPaste', Ord(ecClipBoardPaste));\r\n AddConst(cJvEditor, 'ecDeleteLine', Ord(ecDeleteLine));\r\n AddConst(cJvEditor, 'ecDeleteWord', Ord(ecDeleteWord));\r\n AddConst(cJvEditor, 'ecToUpperCase', Ord(ecToUpperCase));\r\n AddConst(cJvEditor, 'ecToLowerCase', Ord(ecToLowerCase));\r\n AddConst(cJvEditor, 'ecChangeCase', Ord(ecChangeCase));\r\n AddConst(cJvEditor, 'ecUndo', Ord(ecUndo));\r\n AddConst(cJvEditor, 'ecRedo', Ord(ecRedo));\r\n AddConst(cJvEditor, 'ecBeginCompound', Ord(ecBeginCompound));\r\n AddConst(cJvEditor, 'ecEndCompound', Ord(ecEndCompound));\r\n AddConst(cJvEditor, 'ecBeginUpdate', Ord(ecBeginUpdate));\r\n AddConst(cJvEditor, 'ecEndUpdate', Ord(ecEndUpdate));\r\n AddConst(cJvEditor, 'ecSetBookmark0', Ord(ecSetBookmark0));\r\n AddConst(cJvEditor, 'ecSetBookmark1', Ord(ecSetBookmark1));\r\n AddConst(cJvEditor, 'ecSetBookmark2', Ord(ecSetBookmark2));\r\n AddConst(cJvEditor, 'ecSetBookmark3', Ord(ecSetBookmark3));\r\n AddConst(cJvEditor, 'ecSetBookmark4', Ord(ecSetBookmark4));\r\n AddConst(cJvEditor, 'ecSetBookmark5', Ord(ecSetBookmark5));\r\n AddConst(cJvEditor, 'ecSetBookmark6', Ord(ecSetBookmark6));\r\n AddConst(cJvEditor, 'ecSetBookmark7', Ord(ecSetBookmark7));\r\n AddConst(cJvEditor, 'ecSetBookmark8', Ord(ecSetBookmark8));\r\n AddConst(cJvEditor, 'ecSetBookmark9', Ord(ecSetBookmark9));\r\n AddConst(cJvEditor, 'ecGotoBookmark0', Ord(ecGotoBookmark0));\r\n AddConst(cJvEditor, 'ecGotoBookmark1', Ord(ecGotoBookmark1));\r\n AddConst(cJvEditor, 'ecGotoBookmark2', Ord(ecGotoBookmark2));\r\n AddConst(cJvEditor, 'ecGotoBookmark3', Ord(ecGotoBookmark3));\r\n AddConst(cJvEditor, 'ecGotoBookmark4', Ord(ecGotoBookmark4));\r\n AddConst(cJvEditor, 'ecGotoBookmark5', Ord(ecGotoBookmark5));\r\n AddConst(cJvEditor, 'ecGotoBookmark6', Ord(ecGotoBookmark6));\r\n AddConst(cJvEditor, 'ecGotoBookmark7', Ord(ecGotoBookmark7));\r\n AddConst(cJvEditor, 'ecGotoBookmark8', Ord(ecGotoBookmark8));\r\n AddConst(cJvEditor, 'ecGotoBookmark9', Ord(ecGotoBookmark9));\r\n AddConst(cJvEditor, 'ecCompletionIdentifiers', Ord(ecCompletionIdentifiers));\r\n AddConst(cJvEditor, 'ecCompletionTemplates', Ord(ecCompletionTemplates));\r\n AddConst(cJvEditor, 'ecRecordMacro', Ord(ecRecordMacro));\r\n AddConst(cJvEditor, 'ecPlayMacro', Ord(ecPlayMacro));\r\n AddConst(cJvEditor, 'ecBeginRecord', Ord(ecBeginRecord));\r\n AddConst(cJvEditor, 'ecEndRecord', Ord(ecEndRecord));\r\n end;\r\n RegisterClasses([TJvEditor, TJvHLEditor]);\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvInterpreter_JvInterpreter.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvInterpreter.PAS, released on 2002-07-04.\r\n\r\nThe Initial Developers of the Original Code are: Andrei Prygounkov \r\nCopyright (c) 1999, 2002 Andrei Prygounkov\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nDescription: adapter unit - converts JvInterpreter calls to delphi calls\r\n automatically generated by Pas2JvInterpreter\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvInterpreter_JvInterpreter.pas 12461 2009-08-14 17:21:33Z obones $\r\n\r\nunit JvInterpreter_JvInterpreter;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n JvInterpreter;\r\n\r\nprocedure RegisterJvInterpreterAdapter(JvInterpreterAdapter: TJvInterpreterAdapter);\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvInterpreter_JvInterpreter.pas $';\r\n Revision: '$Revision: 12461 $';\r\n Date: '$Date: 2009-08-14 19:21:33 +0200 (ven. 14 août 2009) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n SysUtils;\r\n\r\n{ EJvInterpreterError }\r\n\r\n{ constructor Create(AErrCode: Integer; AErrPos: Integer; AErrName: string; AErrName2: string) }\r\n\r\nprocedure EJvInterpreterError_Create(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(EJvInterpreterError.Create(Args.Values[0], Args.Values[1], Args.Values[2], Args.Values[3]));\r\nend;\r\n\r\n{ procedure Assign(E: Exception); }\r\n\r\nprocedure EJvInterpreterError_Assign(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n EJvInterpreterError(Args.Obj).Assign(V2O(Args.Values[0]) as Exception);\r\nend;\r\n\r\n{ procedure Clear; }\r\n\r\nprocedure EJvInterpreterError_Clear(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n EJvInterpreterError(Args.Obj).Clear;\r\nend;\r\n\r\n{ property Read ErrCode: Integer }\r\n\r\nprocedure EJvInterpreterError_Read_ErrCode(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := EJvInterpreterError(Args.Obj).ErrCode;\r\nend;\r\n\r\n{ property Read ErrPos: Integer }\r\n\r\nprocedure EJvInterpreterError_Read_ErrPos(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := EJvInterpreterError(Args.Obj).ErrPos;\r\nend;\r\n\r\n{ property Read ErrName: string }\r\n\r\nprocedure EJvInterpreterError_Read_ErrName(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := EJvInterpreterError(Args.Obj).ErrName1;\r\nend;\r\n\r\n{ property Read ErrName2: string }\r\n\r\nprocedure EJvInterpreterError_Read_ErrName2(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := EJvInterpreterError(Args.Obj).ErrName2;\r\nend;\r\n\r\n{ property Read ErrUnitName: string }\r\n\r\nprocedure EJvInterpreterError_Read_ErrUnitName(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := EJvInterpreterError(Args.Obj).ErrUnitName;\r\nend;\r\n\r\n{ property Read ErrLine: Integer }\r\n\r\nprocedure EJvInterpreterError_Read_ErrLine(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := EJvInterpreterError(Args.Obj).ErrLine;\r\nend;\r\n\r\n{ property Read Message1: string }\r\n\r\nprocedure EJvInterpreterError_Read_ErrMessage(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := EJvInterpreterError(Args.Obj).ErrMessage;\r\nend;\r\n\r\nprocedure RegisterJvInterpreterAdapter(JvInterpreterAdapter: TJvInterpreterAdapter);\r\nconst\r\n cJvInterpreter = 'JvInterpreter';\r\nbegin\r\n with JvInterpreterAdapter do\r\n begin\r\n { EJvInterpreterError }\r\n AddClass(cJvInterpreter, EJvInterpreterError, 'EJvInterpreterError');\r\n AddGet(EJvInterpreterError, 'Create', EJvInterpreterError_Create, 4, [varInteger, varInteger, varString,\r\n varString], varEmpty);\r\n AddGet(EJvInterpreterError, 'Assign', EJvInterpreterError_Assign, 1, [varEmpty], varEmpty);\r\n AddGet(EJvInterpreterError, 'Clear', EJvInterpreterError_Clear, 0, [varEmpty], varEmpty);\r\n AddGet(EJvInterpreterError, 'ErrCode', EJvInterpreterError_Read_ErrCode, 0, [varEmpty], varEmpty);\r\n AddGet(EJvInterpreterError, 'ErrPos', EJvInterpreterError_Read_ErrPos, 0, [varEmpty], varEmpty);\r\n AddGet(EJvInterpreterError, 'ErrName', EJvInterpreterError_Read_ErrName, 0, [varEmpty], varEmpty);\r\n AddGet(EJvInterpreterError, 'ErrName2', EJvInterpreterError_Read_ErrName2, 0, [varEmpty], varEmpty);\r\n AddGet(EJvInterpreterError, 'ErrUnitName', EJvInterpreterError_Read_ErrUnitName, 0, [varEmpty], varEmpty);\r\n AddGet(EJvInterpreterError, 'ErrLine', EJvInterpreterError_Read_ErrLine, 0, [varEmpty], varEmpty);\r\n AddGet(EJvInterpreterError, 'ErrMessage', EJvInterpreterError_Read_ErrMessage, 0, [varEmpty], varEmpty);\r\n end;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvInterpreter_JvUtils.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvInterpreter_JvUtils.PAS, released on 2002-07-04.\r\n\r\nThe Initial Developers of the Original Code are: Andrei Prygounkov \r\nCopyright (c) 1999, 2002 Andrei Prygounkov\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nDescription : adapter unit - converts JvInterpreter calls to delphi calls\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvInterpreter_JvUtils.pas 13397 2012-08-16 17:23:19Z ahuser $\r\n\r\nunit JvInterpreter_JvUtils;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n JvInterpreter;\r\n\r\nprocedure RegisterJvInterpreterAdapter(JvInterpreterAdapter: TJvInterpreterAdapter);\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvInterpreter_JvUtils.pas $';\r\n Revision: '$Revision: 13397 $';\r\n Date: '$Date: 2012-08-16 19:23:19 +0200 (jeu. 16 août 2012) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n SysUtils, Classes, Graphics, Forms, Controls, StdCtrls, ExtCtrls,\r\n Dialogs, Menus, Math, ImgList, Variants,\r\n {$IFDEF SUPPORTS_INLINE}\r\n Windows,\r\n {$ENDIF SUPPORTS_INLINE}\r\n JvJVCLUtils, JvJCLUtils, JvInterpreter_Windows;\r\n\r\n{ function ReplaceAllStrings(S: string; Words, Frases: TStrings): string; }\r\n\r\nprocedure JvInterpreter_ReplaceAllStrings(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := ReplaceAllStrings(Args.Values[0], V2O(Args.Values[1]) as TStrings, V2O(Args.Values[2]) as TStrings);\r\nend;\r\n\r\n{ function ReplaceStrings(S: string; PosBeg, Len: Integer; Words, Frases: TStrings; var NewSelStart: Integer): string; }\r\n\r\nprocedure JvInterpreter_ReplaceStrings(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := ReplaceStrings(Args.Values[0], Args.Values[1], Args.Values[2], V2O(Args.Values[3]) as TStrings,\r\n V2O(Args.Values[4]) as TStrings, TVarData(Args.Values[5]).vInteger);\r\nend;\r\n\r\n{ function CountOfLines(const S: string): Integer; }\r\n\r\nprocedure JvInterpreter_CountOfLines(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := CountOfLines(Args.Values[0]);\r\nend;\r\n\r\n{ procedure DeleteEmptyLines(Ss: TStrings); }\r\n\r\nprocedure JvInterpreter_DeleteEmptyLines(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n DeleteEmptyLines(V2O(Args.Values[0]) as TStrings);\r\nend;\r\n\r\n{ procedure SQLAddWhere(SQL: TStrings; const where: string); }\r\n\r\nprocedure JvInterpreter_SQLAddWhere(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n SQLAddWhere(V2O(Args.Values[0]) as TStrings, Args.Values[1]);\r\nend;\r\n\r\n{ function ResSaveToFile(const Typ, Name: string; const Compressed: Boolean; const FileName: string): Boolean; }\r\n\r\nprocedure JvInterpreter_ResSaveToFile(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := ResSaveToFile(Args.Values[0], Args.Values[1], Args.Values[2], Args.Values[3]);\r\nend;\r\n\r\n{ function ResSaveToFileEx(Instance: HINST; Typ, Name: PChar; const Compressed: Boolean; const FileName: string): Boolean; }\r\n\r\nprocedure JvInterpreter_ResSaveToFileEx(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := ResSaveToFileEx(Args.Values[0], PChar(string(Args.Values[1])), PChar(string(Args.Values[2])),\r\n Args.Values[3], Args.Values[4]);\r\nend;\r\n\r\n{ function ResSaveToString(Instance: HINST; const Typ, Name: string; var S: string): Boolean; }\r\n\r\nprocedure JvInterpreter_ResSaveToString(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := ResSaveToString(Args.Values[0], Args.Values[1], Args.Values[2], string(TVarData(Args.Values[3]).vString));\r\nend;\r\n\r\n{ function IniReadSection(const IniFileName: TFileName; const Section: string; Ss: TStrings): Boolean; }\r\n\r\nprocedure JvInterpreter_IniReadSection(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := IniReadSection(Args.Values[0], Args.Values[1], V2O(Args.Values[2]) as TStrings);\r\nend;\r\n\r\n{ function LoadTextFile(const FileName: TFileName): string; }\r\n\r\nprocedure JvInterpreter_LoadTextFile(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := LoadTextFile(Args.Values[0]);\r\nend;\r\n\r\n{ procedure SaveTextFile(const FileName: TFileName; const Source: string); }\r\n\r\nprocedure JvInterpreter_SaveTextFile(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n SaveTextFile(Args.Values[0], Args.Values[1]);\r\nend;\r\n\r\n{ function ReadFolder(const Folder, Mask: TFileName; FileList: TStrings): Integer; }\r\n\r\nprocedure JvInterpreter_ReadFolder(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := ReadFolder(Args.Values[0], Args.Values[1], V2O(Args.Values[2]) as TStrings);\r\nend;\r\n\r\nprocedure JvInterpreter_ReadFolders(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := ReadFolders(Args.Values[0], V2O(Args.Values[1]) as TStrings);\r\nend;\r\n\r\n{ function TargetFileName(const FileName: TFileName): TFileName; }\r\n\r\nprocedure JvInterpreter_TargetFileName(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TargetFileName(Args.Values[0]);\r\nend;\r\n\r\n{ function ResolveLink(const hwnd: HWND; const LinkFile: TFileName; var FileName: TFileName): HRESULT; }\r\n\r\nprocedure JvInterpreter_ResolveLink(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := ResolveLink(Args.Values[0], Args.Values[1], TFileName(TVarData(Args.Values[2]).vString));\r\nend;\r\n\r\n{ procedure LoadIcoToImage(ALarge, ASmall: TImageList; const NameRes: string); }\r\n\r\nprocedure JvInterpreter_LoadIcoToImage(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n LoadIcoToImage(V2O(Args.Values[0]) as TCustomImageList, V2O(Args.Values[1]) as TCustomImageList, Args.Values[2]);\r\nend;\r\n\r\n{ procedure RATextOut(Canvas: TCanvas; const R, RClip: TRect; const S: string); }\r\n\r\n{ (rom) disabled because the functions drag JvClxUtils.pas into JvJCLUtils.pas\r\nprocedure JvInterpreter_RATextOut(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n RATextOut(V2O(Args.Values[0]) as TCanvas, Var2Rect(Args.Values[1]), Var2Rect(Args.Values[2]), Args.Values[3]);\r\nend;\r\n}\r\n\r\n{ function RATextOutEx(Canvas: TCanvas; const R, RClip: TRect; const S: string; const CalcHeight: Boolean): Integer; }\r\n\r\n{ (rom) disabled because the functions drag JvClxUtils.pas into JvJCLUtils.pas\r\nprocedure JvInterpreter_RATextOutEx(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := RATextOutEx(V2O(Args.Values[0]) as TCanvas, Var2Rect(Args.Values[1]), Var2Rect(Args.Values[2]),\r\n Args.Values[3], Args.Values[4]);\r\nend;\r\n}\r\n\r\n{ function RATextCalcHeight(Canvas: TCanvas; const R: TRect; const S: string): Integer; }\r\n\r\n{ (rom) disabled because the functions drag JvClxUtils.pas into JvJCLUtils.pas\r\nprocedure JvInterpreter_RATextCalcHeight(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := RATextCalcHeight(V2O(Args.Values[0]) as TCanvas, Var2Rect(Args.Values[1]), Args.Values[2]);\r\nend;\r\n}\r\n\r\n{ procedure Roughed(ACanvas: TCanvas; const ARect: TRect; const AVert: Boolean); }\r\n\r\nprocedure JvInterpreter_Roughed(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Roughed(V2O(Args.Values[0]) as TCanvas, Var2Rect(Args.Values[1]), Args.Values[2]);\r\nend;\r\n\r\n{ function BitmapFromBitmap(SrcBitmap: TBitmap; const AWidth, AHeight, index: Integer): TBitmap; }\r\n\r\nprocedure JvInterpreter_BitmapFromBitmap(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(BitmapFromBitmap(V2O(Args.Values[0]) as Graphics.TBitmap, Args.Values[1], Args.Values[2], Args.Values[3]));\r\nend;\r\n\r\n{ function TextWidth(AStr: string): Integer; }\r\n\r\nprocedure JvInterpreter_TextWidth(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TextWidth(Args.Values[0]);\r\nend;\r\n\r\n{ function DefineCursor(Identifier: PChar): TCursor; }\r\n\r\nprocedure JvInterpreter_DefineCursor(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := DefineCursor(HInstance, PChar(string(Args.Values[0])));\r\nend;\r\n\r\n{ function FindFormByClassName(FormClassName: string): TForm; }\r\n\r\nprocedure JvInterpreter_FindFormByClassName(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(FindFormByClassName(Args.Values[0]));\r\nend;\r\n\r\n{ function FindByTag(WinControl: TWinControl; ComponentClass: TComponentClass; const Tag: Integer): TComponent; }\r\n\r\nprocedure JvInterpreter_FindByTag(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(FindByTag(V2O(Args.Values[0]) as TWinControl, TComponentClass(V2C(Args.Values[1])), Args.Values[2]));\r\nend;\r\n\r\n{ function ControlAtPos2(Parent: TWinControl; X, Y: Integer): TControl; }\r\n\r\nprocedure JvInterpreter_ControlAtPos2(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(ControlAtPos2(V2O(Args.Values[0]) as TWinControl, Args.Values[1], Args.Values[2]));\r\nend;\r\n\r\n{ function RBTag(Parent: TWinControl): Integer; }\r\n\r\nprocedure JvInterpreter_RBTag(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := RBTag(V2O(Args.Values[0]) as TWinControl);\r\nend;\r\n\r\n{ function AppMinimized: Boolean; }\r\n\r\nprocedure JvInterpreter_AppMinimized(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := AppMinimized;\r\nend;\r\n\r\n{ function MsgDlg2(const Msg, ACaption: string; DlgType: TMsgDlgType; Buttons: TMsgDlgButtons; HelpContext: Integer; Control: TWinControl): Integer; }\r\n\r\nprocedure JvInterpreter_MsgDlg2(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := MsgDlg2(Args.Values[0], Args.Values[1], Args.Values[2], TMsgDlgButtons(Word(V2S(Args.Values[3]))),\r\n Args.Values[4], V2O(Args.Values[5]) as TWinControl);\r\nend;\r\n\r\n{ function MsgDlgDef(const Msg, ACaption: string; DlgType: TMsgDlgType; Buttons: TMsgDlgButtons; DefButton: TMsgDlgBtn; HelpContext: Integer; Control: TWinControl): Integer; }\r\n\r\nprocedure JvInterpreter_MsgDlgDef(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := MsgDlgDef(Args.Values[0], Args.Values[1], Args.Values[2], TMsgDlgButtons(Word(V2S(Args.Values[3]))),\r\n Args.Values[4], Args.Values[5], V2O(Args.Values[6]) as TWinControl);\r\nend;\r\n\r\n{ procedure Delay(MSec: longword); }\r\n\r\nprocedure JvInterpreter_Delay(var Value: Variant; Args: TJvInterpreterArgs);\r\nvar\r\n I: Integer;\r\nbegin\r\n I := Args.Values[0];\r\n Delay(I);\r\nend;\r\n\r\n(*\r\n{ procedure CenterHor(Parent: TControl; MinLeft: Integer; Controls: array of TControl); }\r\nprocedure JvInterpreter_CenterHor(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n CenterHor(V2O(Args.Values[0]) as TControl, Args.Values[1], Args.Values[2]);\r\nend;\r\n*)\r\n\r\n{ procedure EnableControls(Control: TWinControl; const Enable: Boolean); }\r\n\r\nprocedure JvInterpreter_EnableControls(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n EnableControls(V2O(Args.Values[0]) as TWinControl, Args.Values[1]);\r\nend;\r\n\r\n{ procedure EnableMenuItems(MenuItem: TMenuItem; const Tag: Integer; const Enable: Boolean); }\r\n\r\nprocedure JvInterpreter_EnableMenuItems(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n EnableMenuItems(V2O(Args.Values[0]) as TMenuItem, Args.Values[1], Args.Values[2]);\r\nend;\r\n\r\n(*\r\n{ procedure ExpandWidth(Parent: TControl; MinWidth: Integer; Controls: array of TControl); }\r\nprocedure JvInterpreter_ExpandWidth(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n ExpandWidth(V2O(Args.Values[0]) as TControl, Args.Values[1], Args.Values[2]);\r\nend;\r\n*)\r\n\r\n{ function PanelBorder(Panel: TCustomPanel): Integer; }\r\n\r\nprocedure JvInterpreter_PanelBorder(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := PanelBorder(V2O(Args.Values[0]) as TCustomPanel);\r\nend;\r\n\r\n{ function Pixels(Control: TControl; APixels: Integer): Integer; }\r\n\r\nprocedure JvInterpreter_Pixels(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := Pixels(V2O(Args.Values[0]) as TControl, Args.Values[1]);\r\nend;\r\n\r\n{ procedure SetChildPropOrd(Owner: TComponent; PropName: string; Value: Longint); }\r\n\r\nprocedure JvInterpreter_SetChildPropOrd(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n SetChildPropOrd(V2O(Args.Values[0]) as TComponent, Args.Values[1], Args.Values[2]);\r\nend;\r\n\r\n{ procedure Error(const Message: string); }\r\n\r\nprocedure JvInterpreter_Error(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Error(Args.Values[0]);\r\nend;\r\n\r\n{ procedure ItemHtDrawEx(Canvas: TCanvas; Rect: TRect; const State: TOwnerDrawState; const Text: string; const HideSelColor: Boolean; var PlainItem: string; var Width: Integer; CalcWidth: Boolean); }\r\n\r\nprocedure JvInterpreter_ItemHtDrawEx(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n ItemHtDrawEx(V2O(Args.Values[0]) as TCanvas, Var2Rect(Args.Values[1]), TOwnerDrawState(Word(V2S(Args.Values[2]))),\r\n Args.Values[3], Args.Values[4], string(TVarData(Args.Values[5]).vString), TVarData(Args.Values[6]).vInteger,\r\n Args.Values[7]);\r\nend;\r\n\r\n{ function ItemHtDraw(Canvas: TCanvas; Rect: TRect; const State: TOwnerDrawState; const Text: string; const HideSelColor: Boolean): string; }\r\n\r\nprocedure JvInterpreter_ItemHtDraw(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := ItemHtDraw(V2O(Args.Values[0]) as TCanvas, Var2Rect(Args.Values[1]),\r\n TOwnerDrawState(Word(V2S(Args.Values[2]))), Args.Values[3], Args.Values[4]);\r\nend;\r\n\r\n{ function ItemHtWidth(Canvas: TCanvas; Rect: TRect; const State: TOwnerDrawState; const Text: string; const HideSelColor: Boolean): Integer; }\r\n\r\nprocedure JvInterpreter_ItemHtWidth(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := ItemHtWidth(V2O(Args.Values[0]) as TCanvas, Var2Rect(Args.Values[1]),\r\n TOwnerDrawState(Word(V2S(Args.Values[2]))), Args.Values[3], Args.Values[4]);\r\nend;\r\n\r\n{ function ItemHtPlain(const Text: string): string; }\r\n\r\nprocedure JvInterpreter_ItemHtPlain(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := ItemHtPlain(Args.Values[0]);\r\nend;\r\n\r\n{ procedure ClearList(List: TList); }\r\n\r\nprocedure JvInterpreter_ClearList(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n ClearList(V2O(Args.Values[0]) as TList);\r\nend;\r\n\r\n{ procedure MemStreamToClipBoard(MemStream: TMemoryStream; const Format: word); }\r\n\r\nprocedure JvInterpreter_MemStreamToClipBoard(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n MemStreamToClipBoard(V2O(Args.Values[0]) as TMemoryStream, Args.Values[1]);\r\nend;\r\n\r\n{ procedure ClipBoardToMemStream(MemStream: TMemoryStream; const Format: word); }\r\n\r\nprocedure JvInterpreter_ClipBoardToMemStream(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n ClipBoardToMemStream(V2O(Args.Values[0]) as TMemoryStream, Args.Values[1]);\r\nend;\r\n\r\n{ function GetPropType(Obj: TObject; const PropName: string): TTypeKind; }\r\n\r\nprocedure JvInterpreter_GetPropType(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := GetPropType(V2O(Args.Values[0]), Args.Values[1]);\r\nend;\r\n\r\n{ function GetPropStr(Obj: TObject; const PropName: string): string; }\r\n\r\nprocedure JvInterpreter_GetPropStr(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := GetPropStr(V2O(Args.Values[0]), Args.Values[1]);\r\nend;\r\n\r\n{ function GetPropOrd(Obj: TObject; const PropName: string): Integer; }\r\n\r\nprocedure JvInterpreter_GetPropOrd(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := GetPropOrd(V2O(Args.Values[0]), Args.Values[1]);\r\nend;\r\n\r\n{ function CompareMem(P1, P2: Pointer; Length: Integer): Boolean; }\r\n\r\nprocedure JvInterpreter_CompareMem(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := CompareMem(V2P(Args.Values[0]), V2P(Args.Values[1]), Args.Values[2]);\r\nend;\r\n\r\n{ procedure ShowMenu(Form: TForm; MenuAni: TMenuAnimation); }\r\n\r\nprocedure JvInterpreter_ShowMenu(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n ShowMenu(V2O(Args.Values[0]) as TForm, Args.Values[1]);\r\nend;\r\n\r\n{****************************** RAUtilsW *******************************}\r\n{ function GetWordOnPos(const S: string; const P: Integer): string; }\r\n\r\nprocedure JvInterpreter_GetWordOnPos(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := GetWordOnPos(Args.Values[0], Args.Values[1]);\r\nend;\r\n\r\n{ function GetWordOnPosEx(const S: string; const P: Integer; var iBeg, iEnd: Integer): string; }\r\n\r\nprocedure JvInterpreter_GetWordOnPosEx(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := GetWordOnPosEx(Args.Values[0], Args.Values[1], TVarData(Args.Values[2]).vInteger,\r\n TVarData(Args.Values[3]).vInteger);\r\nend;\r\n\r\n{ function SubStrBySeparator(const S: string; const index: Integer; const Separator: string): string; }\r\n\r\nprocedure JvInterpreter_SubStrBySeparator(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := SubStrBySeparator(Args.Values[0], Args.Values[1], Args.Values[2]);\r\nend;\r\n\r\n(*\r\n{ function SubWord(P: PChar; var P2: PChar): string; }\r\nprocedure JvInterpreter_SubWord(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := SubWord(PChar(string(Args.Values[0])), PChar(string(Args.Values[1])));\r\nend;\r\n*)\r\n\r\n{ function GetLineByPos(const S: string; const Pos: Integer): Integer; }\r\n\r\nprocedure JvInterpreter_GetLineByPos(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := GetLineByPos(Args.Values[0], Args.Values[1]);\r\nend;\r\n\r\n{ procedure GetXYByPos(const S: string; const Pos: Integer; var X, Y: Integer); }\r\n\r\nprocedure JvInterpreter_GetXYByPos(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n GetXYByPos(Args.Values[0], Args.Values[1], TVarData(Args.Values[2]).vInteger, TVarData(Args.Values[3]).vInteger);\r\nend;\r\n\r\n{ function ReplaceString(S: string; const OldPattern, NewPattern: string): string; }\r\n\r\nprocedure JvInterpreter_ReplaceString(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := ReplaceString(Args.Values[0], Args.Values[1], Args.Values[2]);\r\nend;\r\n\r\n{ function ConcatSep(const S, S2, Separator: string): string; }\r\n\r\nprocedure JvInterpreter_ConcatSep(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := ConcatSep(Args.Values[0], Args.Values[1], Args.Values[2]);\r\nend;\r\n\r\n{ function ConcatLeftSep(const S, S2, Separator: string): string; }\r\n\r\nprocedure JvInterpreter_ConcatLeftSep(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := ConcatLeftSep(Args.Values[0], Args.Values[1], Args.Values[2]);\r\nend;\r\n\r\n{ function MinimizeString(const S: string; const MaxLen: Integer): string; }\r\n\r\nprocedure JvInterpreter_MinimizeString(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := MinimizeString(Args.Values[0], Args.Values[1]);\r\nend;\r\n\r\n{ procedure Dos2Win(var S: string); }\r\n\r\nprocedure JvInterpreter_Dos2Win(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Dos2Win(AnsiString(TVarData(Args.Values[0]).vString));\r\nend;\r\n\r\n{ procedure Win2Dos(var S: string); }\r\n\r\nprocedure JvInterpreter_Win2Dos(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Win2Dos(AnsiString(TVarData(Args.Values[0]).vString));\r\nend;\r\n\r\n{ function Dos2WinRes(const S: string): string; }\r\n\r\nprocedure JvInterpreter_Dos2WinRes(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := Dos2WinRes(AnsiString(VarToStr(Args.Values[0])));\r\nend;\r\n\r\n{ function Win2DosRes(const S: string): string; }\r\n\r\nprocedure JvInterpreter_Win2DosRes(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := Win2DosRes(AnsiString(VarToStr(Args.Values[0])));\r\nend;\r\n\r\n{ function Win2Koi(const S: string): string; }\r\n\r\nprocedure JvInterpreter_Win2Koi(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := Win2Koi(AnsiString(VarToStr(Args.Values[0])));\r\nend;\r\n\r\n{ function Spaces(const N: Integer): string; }\r\n\r\nprocedure JvInterpreter_Spaces(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := Spaces(Args.Values[0]);\r\nend;\r\n\r\n{ function AddSpaces(const S: string; const N: Integer): string; }\r\n\r\nprocedure JvInterpreter_AddSpaces(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := AddSpaces(Args.Values[0], Args.Values[1]);\r\nend;\r\n\r\n{ function LastDateRUS(const Dat: TDateTime): string; }\r\n\r\nprocedure JvInterpreter_LastDateRUS(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := LastDateRUS(Args.Values[0]);\r\nend;\r\n\r\n{ function CurrencyToStr(const Cur: currency): string; }\r\n\r\nprocedure JvInterpreter_CurrencyToStr(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := CurrencyToStr(Args.Values[0]);\r\nend;\r\n\r\n{ function Cmp(const S1, S2: string): Boolean; }\r\n\r\nprocedure JvInterpreter_Cmp(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := Cmp(Args.Values[0], Args.Values[1]);\r\nend;\r\n\r\n{ function HasChar(const Ch: Char; const S: string): Boolean; }\r\n\r\nprocedure JvInterpreter_HasChar(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := HasChar(string(Args.Values[0])[1], Args.Values[1]);\r\nend;\r\n\r\n{ function HasAnyChar(const Chars: string; const S: string): Boolean; }\r\n\r\nprocedure JvInterpreter_HasAnyChar(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := HasAnyChar(Args.Values[0], Args.Values[1]);\r\nend;\r\n\r\n(*\r\n{ function CharInSet(const Ch: Char; const SetOfChar: TSetOfChar): Boolean; }\r\nprocedure JvInterpreter_CharInSet(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := CharInSet(string(Args.Values[0])[1], Args.Values[1]);\r\nend;\r\n*)\r\n\r\n{ function CountOfChar(const Ch: Char; const S: string): Integer; }\r\n\r\nprocedure JvInterpreter_CountOfChar(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := CountOfChar(string(Args.Values[0])[1], Args.Values[1]);\r\nend;\r\n\r\n{ function DefStr(const S: string; Default: string): string; }\r\n\r\nprocedure JvInterpreter_DefStr(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := DefStr(Args.Values[0], Args.Values[1]);\r\nend;\r\n\r\n{ function GenTempFileName(FileName: string): string; }\r\n\r\nprocedure JvInterpreter_GenTempFileName(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := GenTempFileName(Args.Values[0]);\r\nend;\r\n\r\n{ function GenTempFileNameExt(FileName: string; const FileExt: string): string; }\r\n\r\nprocedure JvInterpreter_GenTempFileNameExt(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := GenTempFileNameExt(Args.Values[0], Args.Values[1]);\r\nend;\r\n\r\n{ function ClearDir(const Dir: string): Boolean; }\r\n\r\nprocedure JvInterpreter_ClearDir(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := ClearDir(Args.Values[0]);\r\nend;\r\n\r\n{ function DeleteDir(const Dir: string): Boolean; }\r\n\r\nprocedure JvInterpreter_DeleteDir(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := DeleteDir(Args.Values[0]);\r\nend;\r\n\r\n{ function FileEquMask(FileName, Mask: TFileName): Boolean; }\r\n\r\nprocedure JvInterpreter_FileEquMask(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := FileEquMask(Args.Values[0], Args.Values[1]);\r\nend;\r\n\r\n{ function FileEquMasks(FileName, Masks: TFileName): Boolean; }\r\n\r\nprocedure JvInterpreter_FileEquMasks(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := FileEquMasks(Args.Values[0], Args.Values[1]);\r\nend;\r\n\r\n{ procedure DeleteFiles(const Folder: TFileName; const Masks: string); }\r\n\r\nprocedure JvInterpreter_DeleteFiles(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n DeleteFiles(Args.Values[0], Args.Values[1]);\r\nend;\r\n\r\n{ function LZFileExpand(const FileSource, FileDest: string): Boolean; }\r\n\r\nprocedure JvInterpreter_LZFileExpand(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := LZFileExpand(Args.Values[0], Args.Values[1]);\r\nend;\r\n\r\n{ function FileGetInfo(FileName: TFileName; var SearchRec: TSearchRec): Boolean; }\r\n\r\nprocedure JvInterpreter_FileGetInfo(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := FileGetInfo(Args.Values[0], TSearchRec(V2R(Args.Values[1])^));\r\nend;\r\n\r\n{ function HasSubFolder(APath: TFileName): Boolean; }\r\n\r\nprocedure JvInterpreter_HasSubFolder(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := HasSubFolder(Args.Values[0]);\r\nend;\r\n\r\n{ function IsEmptyFolder(APath: TFileName): Boolean; }\r\n\r\nprocedure JvInterpreter_IsEmptyFolder(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := IsEmptyFolder(Args.Values[0]);\r\nend;\r\n\r\n{ function AddSlash(const Dir: TFileName): string; }\r\n\r\nprocedure JvInterpreter_AddSlash(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := AddSlash(Args.Values[0]);\r\nend;\r\n\r\n{ function AddPath(const FileName, Path: TFileName): TFileName; }\r\n\r\nprocedure JvInterpreter_AddPath(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := AddPath(Args.Values[0], Args.Values[1]);\r\nend;\r\n\r\n{ function BrowseForFolderNative(const Handle: HWnd; const Title: string; var Folder: string): Boolean; }\r\n\r\n{$IFNDEF BCB1}\r\nprocedure JvInterpreter_BrowseForFolderNative(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := BrowseForFolderNative(Args.Values[0], Args.Values[1], string(TVarData(Args.Values[2]).vString));\r\nend;\r\n{$ENDIF !BCB1}\r\n\r\n{ function DeleteReadOnlyFile(const FileName: TFileName): Boolean; }\r\n\r\nprocedure JvInterpreter_DeleteReadOnlyFile(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := DeleteReadOnlyFile(Args.Values[0]);\r\nend;\r\n\r\n{ function HasParam(const Param: string): Boolean; }\r\n\r\nprocedure JvInterpreter_HasParam(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := HasParam(Args.Values[0]);\r\nend;\r\n\r\n{ function HasSwitch(const Param: string): Boolean; }\r\n\r\nprocedure JvInterpreter_HasSwitch(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := HasSwitch(Args.Values[0]);\r\nend;\r\n\r\n{ function Switch(const Param: string): string; }\r\n\r\nprocedure JvInterpreter_Switch(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := Switch(Args.Values[0]);\r\nend;\r\n\r\n{ function ExePath: TFileName; }\r\n\r\nprocedure JvInterpreter_ExePath(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := ExePath;\r\nend;\r\n\r\n{ function CopyDir(const SourceDir, DestDir: TFileName): Boolean; }\r\n\r\nprocedure JvInterpreter_CopyDir(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := CopyDir(Args.Values[0], Args.Values[1]);\r\nend;\r\n\r\n{ function IsTTFontSelected(const DC: HDC): Boolean; }\r\n\r\nprocedure JvInterpreter_IsTTFontSelected(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := IsTTFontSelected(Args.Values[0]);\r\nend;\r\n\r\n{ function TrueInflateRect(const R: TRect; const I: Integer): TRect; }\r\n\r\nprocedure JvInterpreter_TrueInflateRect(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := Rect2Var(TrueInflateRect(Var2Rect(Args.Values[0]), Args.Values[1]));\r\nend;\r\n\r\n{ procedure SetWindowTop(const Handle: HWND; const Top: Boolean); }\r\n\r\nprocedure JvInterpreter_SetWindowTop(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n SetWindowTop(Args.Values[0], Args.Values[1]);\r\nend;\r\n\r\n{ function KeyPressed(VK: Integer): Boolean; }\r\n\r\nprocedure JvInterpreter_KeyPressed(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := KeyPressed(Args.Values[0]);\r\nend;\r\n\r\n{ function Max(x, y: Integer): Integer; }\r\n\r\nprocedure JvInterpreter_Max(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := Max(Args.Values[0], Args.Values[1]);\r\nend;\r\n\r\n{ function Min(x, y: Integer): Integer; }\r\n\r\nprocedure JvInterpreter_Min(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := Min(Args.Values[0], Args.Values[1]);\r\nend;\r\n\r\n{ procedure SwapInt(var Int1, Int2: Integer); }\r\n\r\nprocedure JvInterpreter_SwapInt(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n SwapInt(TVarData(Args.Values[0]).vInteger, TVarData(Args.Values[1]).vInteger);\r\nend;\r\n\r\n{ function IntPower(Base, Exponent: Integer): Integer; }\r\n\r\nprocedure JvInterpreter_IntPower(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := IntPower(Args.Values[0], Args.Values[1]);\r\nend;\r\n\r\n{ function MakeValidFileName(const FileName: TFileName; const ReplaceBadChar: Char): TFileName; }\r\n\r\nprocedure JvInterpreter_MakeValidFileName(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := MakeValidFileName(Args.Values[0], string(Args.Values[1])[1]);\r\nend;\r\n\r\n{ function AnsiStrLIComp(S1, S2: PChar; MaxLen: Cardinal): Integer; }\r\n\r\nprocedure JvInterpreter_AnsiStrLIComp(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := AnsiStrLIComp(PChar(string(Args.Values[0])), PChar(string(Args.Values[1])), Args.Values[2]);\r\nend;\r\n\r\n{ function Var2Type(V: Variant; const VarType: Integer): Variant; }\r\n\r\nprocedure JvInterpreter_Var2Type(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := Var2Type(Args.Values[0], Args.Values[1]);\r\nend;\r\n\r\n{ function VarToInt(V: Variant): Integer; }\r\n\r\nprocedure JvInterpreter_VarToInt(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := VarToInt(Args.Values[0]);\r\nend;\r\n\r\n{ function GetParameter: string; }\r\n\r\nprocedure JvInterpreter_GetParameter(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := GetParameter;\r\nend;\r\n\r\n{ function GetLongFileName(FileName: string): string; }\r\n\r\nprocedure JvInterpreter_GetLongFileName(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := GetLongFileName(Args.Values[0]);\r\nend;\r\n\r\n{ function DirectoryExists(const Name: string): Boolean; }\r\n\r\nprocedure JvInterpreter_DirectoryExists(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := DirectoryExists(Args.Values[0]);\r\nend;\r\n\r\n{ procedure ForceDirectories(Dir: string); }\r\n\r\nprocedure JvInterpreter_ForceDirectories(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n ForceDirectories(Args.Values[0]);\r\nend;\r\n\r\n{ function FileNewExt(const FileName, NewExt: TFileName): TFileName; }\r\n\r\nprocedure JvInterpreter_FileNewExt(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := FileNewExt(Args.Values[0], Args.Values[1]);\r\nend;\r\n\r\n{ function GetComputerID: string; }\r\n\r\nprocedure JvInterpreter_GetComputerID(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := GetComputerID;\r\nend;\r\n\r\n{ function AddPaths(const PathList, Path: string): string; }\r\n\r\nprocedure JvInterpreter_AddPaths(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := AddPaths(Args.Values[0], Args.Values[1]);\r\nend;\r\n\r\n{ function ParentPath(const Path: TFileName): TFileName; }\r\n\r\nprocedure JvInterpreter_ParentPath(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := ParentPath(Args.Values[0]);\r\nend;\r\n\r\n{ function FindInPath(const FileName, PathList: string): TFileName; }\r\n\r\nprocedure JvInterpreter_FindInPath(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := FindInPath(Args.Values[0], Args.Values[1]);\r\nend;\r\n\r\n{ procedure PrepareIniSection(SS: TStrings); }\r\n\r\nprocedure JvInterpreter_PrepareIniSection(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n PrepareIniSection(V2O(Args.Values[0]) as TStrings);\r\nend;\r\n\r\nprocedure RegisterJvInterpreterAdapter(JvInterpreterAdapter: TJvInterpreterAdapter);\r\nconst\r\n cJvUtils = 'JvUtils';\r\n cMath = 'Math';\r\n cJvStrUtil = 'JvStrUtil';\r\n cFileCtrl = 'FileCtrl';\r\nbegin\r\n with JvInterpreterAdapter do\r\n begin\r\n AddFunction(cJvUtils, 'ReplaceAllStrings', JvInterpreter_ReplaceAllStrings, 3, [varString, varObject, varObject], varEmpty);\r\n AddFunction(cJvUtils, 'ReplaceStrings', JvInterpreter_ReplaceStrings, 6, [varString, varInteger, varInteger, varObject,\r\n varObject, varInteger or varByRef], varEmpty);\r\n AddFunction(cJvUtils, 'CountOfLines', JvInterpreter_CountOfLines, 1, [varString], varEmpty);\r\n AddFunction(cJvUtils, 'DeleteEmptyLines', JvInterpreter_DeleteEmptyLines, 1, [varObject], varEmpty);\r\n AddFunction(cJvUtils, 'SQLAddWhere', JvInterpreter_SQLAddWhere, 2, [varObject, varString], varEmpty);\r\n AddFunction(cJvUtils, 'ResSaveToFile', JvInterpreter_ResSaveToFile, 4, [varString, varString, varBoolean, varString],\r\n varEmpty);\r\n AddFunction(cJvUtils, 'ResSaveToFileEx', JvInterpreter_ResSaveToFileEx, 5, [varEmpty, varEmpty, varEmpty, varBoolean,\r\n varString], varEmpty);\r\n AddFunction(cJvUtils, 'ResSaveToString', JvInterpreter_ResSaveToString, 4, [varEmpty, varString, varString, varString or\r\n varByRef], varEmpty);\r\n AddFunction(cJvUtils, 'IniReadSection', JvInterpreter_IniReadSection, 3, [varEmpty, varString, varObject], varEmpty);\r\n AddFunction(cJvUtils, 'LoadTextFile', JvInterpreter_LoadTextFile, 1, [varEmpty], varEmpty);\r\n AddFunction(cJvUtils, 'SaveTextFile', JvInterpreter_SaveTextFile, 2, [varEmpty, varString], varEmpty);\r\n AddFunction(cJvUtils, 'ReadFolder', JvInterpreter_ReadFolder, 3, [varEmpty, varEmpty, varObject], varEmpty);\r\n AddFunction(cJvUtils, 'ReadFolders', JvInterpreter_ReadFolders, 2, [varEmpty, varObject], varEmpty);\r\n AddFunction(cJvUtils, 'TargetFileName', JvInterpreter_TargetFileName, 1, [varEmpty], varEmpty);\r\n AddFunction(cJvUtils, 'ResolveLink', JvInterpreter_ResolveLink, 3, [varEmpty, varEmpty, varEmpty or varByRef],\r\n varEmpty);\r\n AddFunction(cJvUtils, 'LoadIcoToImage', JvInterpreter_LoadIcoToImage, 3, [varObject, varObject, varString], varEmpty);\r\n { (rom) disabled because the functions drag JvClxUtils.pas into JvJCLUtils.pas\r\n AddFunction(cJvUtils, 'RATextOut', JvInterpreter_RATextOut, 4, [varObject, varEmpty, varEmpty, varString], varEmpty);\r\n AddFunction(cJvUtils, 'RATextOutEx', JvInterpreter_RATextOutEx, 5, [varObject, varEmpty, varEmpty, varString,\r\n varBoolean], varEmpty);\r\n AddFunction(cJvUtils, 'RATextCalcHeight', JvInterpreter_RATextCalcHeight, 3, [varObject, varEmpty, varString],\r\n varEmpty);\r\n }\r\n AddFunction(cJvUtils, 'Roughed', JvInterpreter_Roughed, 3, [varObject, varEmpty, varBoolean], varEmpty);\r\n AddFunction(cJvUtils, 'BitmapFromBitmap', JvInterpreter_BitmapFromBitmap, 4, [varObject, varInteger, varInteger,\r\n varInteger], varEmpty);\r\n AddFunction(cJvUtils, 'TextWidth', JvInterpreter_TextWidth, 1, [varString], varEmpty);\r\n AddFunction(cJvUtils, 'DefineCursor', JvInterpreter_DefineCursor, 1, [varEmpty], varEmpty);\r\n AddFunction(cJvUtils, 'FindFormByClassName', JvInterpreter_FindFormByClassName, 1, [varString], varEmpty);\r\n AddFunction(cJvUtils, 'FindByTag', JvInterpreter_FindByTag, 3, [varObject, varEmpty, varInteger], varEmpty);\r\n AddFunction(cJvUtils, 'ControlAtPos2', JvInterpreter_ControlAtPos2, 3, [varObject, varInteger, varInteger], varEmpty);\r\n AddFunction(cJvUtils, 'RBTag', JvInterpreter_RBTag, 1, [varObject], varEmpty);\r\n AddFunction(cJvUtils, 'AppMinimized', JvInterpreter_AppMinimized, 0, [varEmpty], varEmpty);\r\n AddFunction(cJvUtils, 'MsgDlg2', JvInterpreter_MsgDlg2, 6, [varString, varString, varEmpty, varEmpty, varInteger,\r\n varObject], varEmpty);\r\n AddFunction(cJvUtils, 'MsgDlgDef', JvInterpreter_MsgDlgDef, 7, [varString, varString, varEmpty, varEmpty, varEmpty,\r\n varInteger, varObject], varEmpty);\r\n AddFunction(cJvUtils, 'Delay', JvInterpreter_Delay, 1, [varEmpty], varEmpty);\r\n //AddFunction(cJvUtils, 'CenterHor', JvInterpreter_CenterHor, 3, [varObject, varInteger, varEmpty], nil);\r\n AddFunction(cJvUtils, 'EnableControls', JvInterpreter_EnableControls, 2, [varObject, varBoolean], varEmpty);\r\n AddFunction(cJvUtils, 'EnableMenuItems', JvInterpreter_EnableMenuItems, 3, [varObject, varInteger, varBoolean],\r\n varEmpty);\r\n //AddFunction(cJvUtils, 'ExpandWidth', JvInterpreter_ExpandWidth, 3, [varObject, varInteger, varEmpty], nil);\r\n AddFunction(cJvUtils, 'PanelBorder', JvInterpreter_PanelBorder, 1, [varObject], varEmpty);\r\n AddFunction(cJvUtils, 'Pixels', JvInterpreter_Pixels, 2, [varObject, varInteger], varEmpty);\r\n AddFunction(cJvUtils, 'SetChildPropOrd', JvInterpreter_SetChildPropOrd, 3, [varObject, varString, varEmpty], varEmpty);\r\n AddFunction(cJvUtils, 'Error', JvInterpreter_Error, 1, [varString], varEmpty);\r\n AddFunction(cJvUtils, 'ItemHtDrawEx', JvInterpreter_ItemHtDrawEx, 8, [varObject, varEmpty, varEmpty, varString,\r\n varBoolean, varString or varByRef, varInteger or varByRef, varBoolean], varEmpty);\r\n AddFunction(cJvUtils, 'ItemHtDraw', JvInterpreter_ItemHtDraw, 5, [varObject, varEmpty, varEmpty, varString,\r\n varBoolean], varEmpty);\r\n AddFunction(cJvUtils, 'ItemHtWidth', JvInterpreter_ItemHtWidth, 5, [varObject, varEmpty, varEmpty, varString,\r\n varBoolean], varEmpty);\r\n AddFunction(cJvUtils, 'ItemHtPlain', JvInterpreter_ItemHtPlain, 1, [varString], varEmpty);\r\n AddFunction(cJvUtils, 'ClearList', JvInterpreter_ClearList, 1, [varObject], varEmpty);\r\n AddFunction(cJvUtils, 'MemStreamToClipBoard', JvInterpreter_MemStreamToClipBoard, 2, [varObject, varSmallint],\r\n varEmpty);\r\n AddFunction(cJvUtils, 'ClipBoardToMemStream', JvInterpreter_ClipBoardToMemStream, 2, [varObject, varSmallint],\r\n varEmpty);\r\n AddFunction(cJvUtils, 'GetPropType', JvInterpreter_GetPropType, 2, [varObject, varString], varEmpty);\r\n AddFunction(cJvUtils, 'GetPropStr', JvInterpreter_GetPropStr, 2, [varObject, varString], varEmpty);\r\n AddFunction(cJvUtils, 'GetPropOrd', JvInterpreter_GetPropOrd, 2, [varObject, varString], varEmpty);\r\n AddFunction(cJvUtils, 'CompareMem', JvInterpreter_CompareMem, 3, [varPointer, varPointer, varInteger], varEmpty);\r\n AddFunction(cJvUtils, 'ShowMenu', JvInterpreter_ShowMenu, 2, [varObject, varEmpty], varEmpty);\r\n AddFunction(cJvUtils, 'PrepareIniSection', JvInterpreter_PrepareIniSection, 1, [varObject], varEmpty);\r\n\r\n AddFunction(cJvStrUtil, 'GetWordOnPos', JvInterpreter_GetWordOnPos, 2, [varString, varInteger], varEmpty);\r\n AddFunction(cJvStrUtil, 'GetWordOnPosEx', JvInterpreter_GetWordOnPosEx, 4, [varString, varInteger, varInteger or\r\n varByRef, varInteger or varByRef], varEmpty);\r\n AddFunction(cJvStrUtil, 'SubStrBySeparator', JvInterpreter_SubStrBySeparator, 3, [varString, varInteger, varString], varEmpty);\r\n AddFunction(cJvStrUtil, 'GetLineByPos', JvInterpreter_GetLineByPos, 2, [varString, varInteger], varEmpty);\r\n AddFunction(cJvStrUtil, 'GetXYByPos', JvInterpreter_GetXYByPos, 4, [varString, varInteger, varInteger or varByRef,\r\n varInteger or varByRef], varEmpty);\r\n AddFunction(cJvStrUtil, 'ReplaceString', JvInterpreter_ReplaceString, 3, [varString, varString, varString], varEmpty);\r\n AddFunction(cJvStrUtil, 'ReplaceSokr1', JvInterpreter_ReplaceString, 3, [varString, varString, varString], varEmpty);\r\n AddFunction(cJvStrUtil, 'ConcatSep', JvInterpreter_ConcatSep, 3, [varString, varString, varString], varEmpty);\r\n AddFunction(cJvStrUtil, 'ConcatLeftSep', JvInterpreter_ConcatLeftSep, 3, [varString, varString, varString], varEmpty);\r\n AddFunction(cJvStrUtil, 'MinimizeString', JvInterpreter_MinimizeString, 2, [varString, varInteger], varEmpty);\r\n AddFunction(cJvStrUtil, 'Dos2Win', JvInterpreter_Dos2Win, 1, [varString or varByRef], varEmpty);\r\n AddFunction(cJvStrUtil, 'Win2Dos', JvInterpreter_Win2Dos, 1, [varString or varByRef], varEmpty);\r\n AddFunction(cJvStrUtil, 'Dos2WinRes', JvInterpreter_Dos2WinRes, 1, [varString], varEmpty);\r\n AddFunction(cJvStrUtil, 'Win2DosRes', JvInterpreter_Win2DosRes, 1, [varString], varEmpty);\r\n AddFunction(cJvStrUtil, 'Win2Koi', JvInterpreter_Win2Koi, 1, [varString], varString);\r\n AddFunction(cJvStrUtil, 'Spaces', JvInterpreter_Spaces, 1, [varInteger], varEmpty);\r\n AddFunction(cJvStrUtil, 'AddSpaces', JvInterpreter_AddSpaces, 2, [varString, varInteger], varEmpty);\r\n AddFunction(cJvStrUtil, 'LastDateRUS', JvInterpreter_LastDateRUS, 1, [varEmpty], varEmpty);\r\n AddFunction(cJvStrUtil, 'CurrencyToStr', JvInterpreter_CurrencyToStr, 1, [varEmpty], varEmpty);\r\n AddFunction(cJvStrUtil, 'Cmp', JvInterpreter_Cmp, 2, [varString, varString], varEmpty);\r\n //AddFunction(cJvStrUtil, 'StringCat', JvInterpreter_StringCat, 2, [varString or varByRef, varString], varEmpty);\r\n AddFunction(cJvStrUtil, 'HasChar', JvInterpreter_HasChar, 2, [varEmpty, varString], varEmpty);\r\n AddFunction(cJvStrUtil, 'HasAnyChar', JvInterpreter_HasAnyChar, 2, [varString, varString], varEmpty);\r\n AddFunction(cJvStrUtil, 'CountOfChar', JvInterpreter_CountOfChar, 2, [varEmpty, varString], varEmpty);\r\n AddFunction(cJvStrUtil, 'DefStr', JvInterpreter_DefStr, 2, [varString, varString], varEmpty);\r\n AddFunction(cJvUtils, 'GenTempFileName', JvInterpreter_GenTempFileName, 1, [varString], varEmpty);\r\n AddFunction(cJvUtils, 'GenTempFileNameExt', JvInterpreter_GenTempFileNameExt, 2, [varString, varString], varEmpty);\r\n AddFunction(cJvUtils, 'ClearDir', JvInterpreter_ClearDir, 1, [varString], varEmpty);\r\n AddFunction(cJvUtils, 'DeleteDir', JvInterpreter_DeleteDir, 1, [varString], varEmpty);\r\n AddFunction(cJvUtils, 'FileEquMask', JvInterpreter_FileEquMask, 2, [varEmpty, varEmpty], varEmpty);\r\n AddFunction(cJvUtils, 'FileEquMasks', JvInterpreter_FileEquMasks, 2, [varEmpty, varEmpty], varEmpty);\r\n AddFunction(cJvUtils, 'DeleteFiles', JvInterpreter_DeleteFiles, 2, [varEmpty, varString], varEmpty);\r\n AddFunction(cJvUtils, 'LZFileExpand', JvInterpreter_LZFileExpand, 2, [varString, varString], varEmpty);\r\n AddFunction(cJvUtils, 'FileGetInfo', JvInterpreter_FileGetInfo, 2, [varEmpty, varEmpty or varByRef], varEmpty);\r\n AddFunction(cJvUtils, 'HasSubFolder', JvInterpreter_HasSubFolder, 1, [varEmpty], varEmpty);\r\n AddFunction(cJvUtils, 'IsEmptyFolder', JvInterpreter_IsEmptyFolder, 1, [varEmpty], varEmpty);\r\n AddFunction(cJvUtils, 'AddSlash', JvInterpreter_AddSlash, 1, [varEmpty], varEmpty);\r\n AddFunction(cJvUtils, 'AddPath', JvInterpreter_AddPath, 2, [varEmpty, varEmpty], varEmpty);\r\n AddFunction(cJvUtils, 'AddPaths', JvInterpreter_AddPaths, 2, [varString, varString], varEmpty);\r\n AddFunction(cJvUtils, 'ParentPath', JvInterpreter_ParentPath, 1, [varEmpty], varEmpty);\r\n AddFunction(cJvUtils, 'FindInPath', JvInterpreter_FindInPath, 2, [varString, varString], varEmpty);\r\n {$IFNDEF BCB1}\r\n AddFunction(cJvUtils, 'BrowseForFolderNative', JvInterpreter_BrowseForFolderNative, 3, [varEmpty, varString, varString or\r\n varByRef], varEmpty);\r\n {$ENDIF !BCB1}\r\n AddFunction(cJvUtils, 'DeleteReadOnlyFile', JvInterpreter_DeleteReadOnlyFile, 1, [varEmpty], varEmpty);\r\n AddFunction(cJvUtils, 'HasParam', JvInterpreter_HasParam, 1, [varString], varEmpty);\r\n AddFunction(cJvUtils, 'HasSwitch', JvInterpreter_HasSwitch, 1, [varString], varEmpty);\r\n AddFunction(cJvUtils, 'Switch', JvInterpreter_Switch, 1, [varString], varEmpty);\r\n AddFunction(cJvUtils, 'ExePath', JvInterpreter_ExePath, 0, [varEmpty], varEmpty);\r\n AddFunction(cJvUtils, 'CopyDir', JvInterpreter_CopyDir, 2, [varEmpty, varEmpty], varEmpty);\r\n AddFunction(cJvUtils, 'IsTTFontSelected', JvInterpreter_IsTTFontSelected, 1, [varEmpty], varEmpty);\r\n AddFunction(cJvUtils, 'TrueInflateRect', JvInterpreter_TrueInflateRect, 2, [varEmpty, varInteger], varEmpty);\r\n AddFunction(cJvUtils, 'SetWindowTop', JvInterpreter_SetWindowTop, 2, [varEmpty, varBoolean], varEmpty);\r\n AddFunction(cJvUtils, 'KeyPressed', JvInterpreter_KeyPressed, 1, [varInteger], varEmpty);\r\n AddFunction(cMath, 'Max', JvInterpreter_Max, 2, [varInteger, varInteger], varEmpty);\r\n AddFunction(cMath, 'Min', JvInterpreter_Min, 2, [varInteger, varInteger], varEmpty);\r\n AddFunction(cJvUtils, 'SwapInt', JvInterpreter_SwapInt, 2, [varInteger or varByRef, varInteger or varByRef],\r\n varEmpty);\r\n AddFunction(cJvUtils, 'IntPower', JvInterpreter_IntPower, 2, [varInteger, varInteger], varEmpty);\r\n AddFunction(cJvUtils, 'MakeValidFileName', JvInterpreter_MakeValidFileName, 2, [varEmpty, varEmpty], varEmpty);\r\n AddFunction(cJvUtils, 'AnsiStrLIComp', JvInterpreter_AnsiStrLIComp, 3, [varEmpty, varEmpty, varEmpty], varEmpty);\r\n AddFunction(cJvUtils, 'Var2Type', JvInterpreter_Var2Type, 2, [varEmpty, varInteger], varEmpty);\r\n AddFunction(cJvUtils, 'VarToInt', JvInterpreter_VarToInt, 1, [varEmpty], varEmpty);\r\n AddFunction(cJvUtils, 'GetParameter', JvInterpreter_GetParameter, 0, [varEmpty], varEmpty);\r\n AddFunction(cJvUtils, 'GetLongFileName', JvInterpreter_GetLongFileName, 1, [varString], varEmpty);\r\n AddFunction(cFileCtrl, 'DirectoryExists', JvInterpreter_DirectoryExists, 1, [varString], varEmpty);\r\n AddFunction(cFileCtrl, 'ForceDirectories', JvInterpreter_ForceDirectories, 1, [varString], varEmpty);\r\n AddFunction(cJvUtils, 'FileNewExt', JvInterpreter_FileNewExt, 2, [varEmpty, varEmpty], varEmpty);\r\n AddFunction(cJvUtils, 'GetComputerID', JvInterpreter_GetComputerID, 0, [varEmpty], varEmpty);\r\n end;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvInterpreter_Math.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvInterpreter_Math.pas, released on 2005-08-15.\r\n\r\nThe Initial Developers of the Original Code are: Andrei Prygounkov \r\nCopyright (c) 1999, 2002 Andrei Prygounkov\r\nAll Rights Reserved.\r\n\r\nContributor(s): Peter Schraut (http://www.console-dev.de)\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nDescription: JvInterpreter_Math adds most functions from math.pas to\r\n to JvInterpreter. Functions in this file are\r\n sorted as they appear in the Delphi 6 helpfile, same applies\r\n to functionregistration in RegisterJvInterpreterAdapter.\r\n Missing functions are marked with a \"TODO: add xxx function\". If\r\n you add a new function, remove the comment.\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvInterpreter_Math.pas 13311 2012-06-12 08:15:50Z obones $\r\n\r\n{ history (JVCL Library versions):\r\n\r\nUpcoming JVCL 3.00\r\n - initial version\r\n}\r\n\r\nunit JvInterpreter_Math;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n Variants,\r\n JvInterpreter, SysUtils;\r\n\r\n\r\nprocedure RegisterJvInterpreterAdapter(JvInterpreterAdapter: TJvInterpreterAdapter);\r\n\r\n\r\nimplementation\r\n\r\nuses\r\n Math;\r\n\r\nprocedure JvInterpreter_ArcCos(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := Math.ArcCos(Extended(Args.Values[0]));\r\nend;\r\n\r\nprocedure JvInterpreter_ArcCosh(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := Math.ArcCosh(Extended(Args.Values[0]));\r\nend;\r\n\r\nprocedure JvInterpreter_ArcCot(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := Math.ArcCot(Extended(Args.Values[0]));\r\nend;\r\n\r\nprocedure JvInterpreter_ArcCotH(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := Math.ArcCotH(Extended(Args.Values[0]));\r\nend;\r\n\r\nprocedure JvInterpreter_ArcCsc(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := Math.ArcCsc(Extended(Args.Values[0]));\r\nend;\r\n\r\nprocedure JvInterpreter_ArcCscH(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := Math.ArcCscH(Extended(Args.Values[0]));\r\nend;\r\n\r\nprocedure JvInterpreter_ArcSec(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := Math.ArcSec(Extended(Args.Values[0]));\r\nend;\r\n\r\nprocedure JvInterpreter_ArcSecH(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := Math.ArcSecH(Extended(Args.Values[0]));\r\nend;\r\n\r\nprocedure JvInterpreter_ArcSin(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := Math.ArcSin(Extended(Args.Values[0]));\r\nend;\r\n\r\nprocedure JvInterpreter_ArcSinh(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := Math.ArcSinh(Extended(Args.Values[0]));\r\nend;\r\n\r\nprocedure JvInterpreter_ArcTan2(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := Math.ArcTan2(Extended(Args.Values[0]), Extended(Args.Values[1]));\r\nend;\r\n\r\nprocedure JvInterpreter_ArcTanh(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := Math.ArcTanh(Extended(Args.Values[0]));\r\nend;\r\n\r\nprocedure JvInterpreter_Ceil(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := Math.Ceil(Extended(Args.Values[0]));\r\nend;\r\n\r\nprocedure JvInterpreter_ClearExceptions(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Math.ClearExceptions;\r\nend;\r\n\r\nprocedure JvInterpreter_Cosecant(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := Math.Cosecant(Extended(Args.Values[0]));\r\nend;\r\n\r\nprocedure JvInterpreter_Cosh(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := Math.Cosh(Extended(Args.Values[0]));\r\nend;\r\n\r\nprocedure JvInterpreter_Cot(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := Math.Cot(Extended(Args.Values[0]));\r\nend;\r\n\r\nprocedure JvInterpreter_Cotan(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := Math.Cotan(Extended(Args.Values[0]));\r\nend;\r\n\r\nprocedure JvInterpreter_CotH(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := Math.CotH(Extended(Args.Values[0]));\r\nend;\r\n\r\nprocedure JvInterpreter_Csc(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := Math.Csc(Extended(Args.Values[0]));\r\nend;\r\n\r\nprocedure JvInterpreter_CscH(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := Math.CscH(Extended(Args.Values[0]));\r\nend;\r\n\r\nprocedure JvInterpreter_CycleToDeg(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := Math.CycleToDeg(Extended(Args.Values[0]));\r\nend;\r\n\r\nprocedure JvInterpreter_CycleToGrad(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := Math.CycleToGrad(Extended(Args.Values[0]));\r\nend;\r\n\r\nprocedure JvInterpreter_CycleToRad(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := Math.CycleToRad(Extended(Args.Values[0]));\r\nend;\r\n\r\nprocedure JvInterpreter_DegToCycle(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := Math.DegToCycle(Extended(Args.Values[0]));\r\nend;\r\n\r\nprocedure JvInterpreter_DegToGrad(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := Math.DegToGrad(Extended(Args.Values[0]));\r\nend;\r\n\r\nprocedure JvInterpreter_DegToRad(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := Math.DegToRad(Extended(Args.Values[0]));\r\nend;\r\n\r\nprocedure JvInterpreter_Floor(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := Math.Floor(Extended(Args.Values[0]));\r\nend;\r\n\r\nprocedure JvInterpreter_GradToCycle(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := Math.GradToCycle(Extended(Args.Values[0]));\r\nend;\r\n\r\nprocedure JvInterpreter_GradToDeg(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := Math.GradToDeg(Extended(Args.Values[0]));\r\nend;\r\n\r\nprocedure JvInterpreter_GradToRad(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := Math.GradToRad(Extended(Args.Values[0]));\r\nend;\r\n\r\nprocedure JvInterpreter_Hypot(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := Math.Hypot(Extended(Args.Values[0]), Extended(Args.Values[1]));\r\nend;\r\n\r\nprocedure JvInterpreter_IntPower(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := Extended(Math.IntPower(Extended(Args.Values[0]), Integer(Args.Values[1])));\r\nend;\r\n\r\nprocedure JvInterpreter_IsInfinite(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := Boolean(Math.IsInfinite(Double(Args.Values[0])));\r\nend;\r\n\r\nprocedure JvInterpreter_IsNan(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := Boolean(Math.IsNan(Double(Args.Values[0])));\r\nend;\r\n\r\nprocedure JvInterpreter_Ldexp(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := Extended(Math.Ldexp(Extended(Args.Values[0]), Integer(Args.Values[1])));\r\nend;\r\n\r\nprocedure JvInterpreter_LnXP1(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := Extended(Math.LnXP1(Extended(Args.Values[0])));\r\nend;\r\n\r\nprocedure JvInterpreter_Log10(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := Extended(Math.Log10(Extended(Args.Values[0])));\r\nend;\r\n\r\nprocedure JvInterpreter_Log2(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := Extended(Math.Log2(Extended(Args.Values[0])));\r\nend;\r\n\r\nprocedure JvInterpreter_LogN(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := Extended(Math.LogN(Extended(Args.Values[0]), Extended(Args.Values[1])));\r\nend;\r\n\r\nprocedure JvInterpreter_Max(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := Max(Integer(Args.Values[0]), Integer(Args.Values[1]));\r\nend;\r\n\r\nprocedure JvInterpreter_Min(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := Min(Integer(Args.Values[0]), Integer(Args.Values[1]));\r\nend;\r\n\r\nprocedure JvInterpreter_Power(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := Extended(Math.Power(Extended(Args.Values[0]), Extended(Args.Values[1])));\r\nend;\r\n\r\nprocedure JvInterpreter_RadToCycle(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := Extended(Math.RadToCycle(Extended(Args.Values[0])));\r\nend;\r\n\r\nprocedure JvInterpreter_RadToDeg(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := Extended(Math.RadToDeg(Extended(Args.Values[0])));\r\nend;\r\n\r\nprocedure JvInterpreter_RadToGrad(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := Extended(Math.RadToGrad(Extended(Args.Values[0])));\r\nend;\r\n\r\nprocedure JvInterpreter_RandG(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := Extended(Math.RandG(Extended(Args.Values[0]), Extended(Args.Values[1])));\r\nend;\r\n\r\nprocedure JvInterpreter_RandomRange(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := Integer(Math.RandomRange(Integer(Args.Values[0]), Integer(Args.Values[1])));\r\nend;\r\n\r\nprocedure JvInterpreter_Sec(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := Math.Sec(Extended(Args.Values[0]));\r\nend;\r\n\r\nprocedure JvInterpreter_Secant(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := Math.Secant(Extended(Args.Values[0]));\r\nend;\r\n\r\nprocedure JvInterpreter_SecH(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := Math.SecH(Extended(Args.Values[0]));\r\nend;\r\n\r\nprocedure JvInterpreter_Sinh(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := Math.Sinh(Extended(Args.Values[0]));\r\nend;\r\n\r\nprocedure JvInterpreter_SLNDepreciation(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := Math.SLNDepreciation(Extended(Args.Values[0]), Extended(Args.Values[1]), Integer(Args.Values[2]));\r\nend;\r\n\r\nprocedure JvInterpreter_SYDDepreciation(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := Math.SYDDepreciation(Extended(Args.Values[0]), Extended(Args.Values[1]), Integer(Args.Values[2]), Integer(Args.Values[3]));\r\nend;\r\n\r\nprocedure JvInterpreter_Tan(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := Math.Tan(Extended(Args.Values[0]));\r\nend;\r\n\r\nprocedure JvInterpreter_Tanh(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := Math.Tanh(Extended(Args.Values[0]));\r\nend;\r\n\r\n\r\n{ RegisterJvInterpreterAdapter }\r\nprocedure RegisterJvInterpreterAdapter(JvInterpreterAdapter: TJvInterpreterAdapter);\r\nconst\r\n cMath = 'Math';\r\nbegin\r\n with JvInterpreterAdapter do\r\n begin\r\n // add constants\r\n AddConst(cMath, 'PI', PI);\r\n AddConst(cMath, 'Infinity', Infinity);\r\n AddConst(cMath, 'MaxComp', MaxComp);\r\n AddConst(cMath, 'MaxDouble', MaxDouble);\r\n // TODO: fix MaxExtended, raises and overflow error atm\r\n //AddConst(cMath, 'MaxExtended', MaxExtended);\r\n AddConst(cMath, 'MaxSingle', MaxSingle);\r\n AddConst(cMath, 'MinComp', MinComp);\r\n AddConst(cMath, 'MinDouble', MinDouble);\r\n AddConst(cMath, 'MinExtended', MinExtended);\r\n AddConst(cMath, 'MinSingle', MinSingle);\r\n AddConst(cMath, 'NaN', NaN);\r\n AddConst(cMath, 'NegInfinity', NegInfinity);\r\n\r\n // add functions\r\n AddFunction(cMath, 'ArcCos', JvInterpreter_ArcCos, 1, [varEmpty], varEmpty);\r\n AddFunction(cMath, 'ArcCosh', JvInterpreter_ArcCosh, 1, [varEmpty], varEmpty);\r\n AddFunction(cMath, 'ArcCot', JvInterpreter_ArcCot, 1, [varEmpty], varEmpty);\r\n AddFunction(cMath, 'ArcCotH', JvInterpreter_ArcCot, 1, [varEmpty], varEmpty);\r\n AddFunction(cMath, 'ArcCsc', JvInterpreter_ArcCsc, 1, [varEmpty], varEmpty);\r\n AddFunction(cMath, 'ArcCscH', JvInterpreter_ArcCsc, 1, [varEmpty], varEmpty);\r\n AddFunction(cMath, 'ArcSec', JvInterpreter_ArcSec, 1, [varEmpty], varEmpty);\r\n AddFunction(cMath, 'ArcSecH', JvInterpreter_ArcSecH, 1, [varEmpty], varEmpty);\r\n AddFunction(cMath, 'ArcSin', JvInterpreter_ArcSin, 1, [varEmpty], varEmpty);\r\n AddFunction(cMath, 'ArcSinh', JvInterpreter_ArcSinh, 1, [varEmpty], varEmpty);\r\n AddFunction(cMath, 'ArcTan2', JvInterpreter_ArcTan2, 2, [varEmpty,varEmpty], varEmpty);\r\n AddFunction(cMath, 'ArcTanh', JvInterpreter_ArcTanh, 1, [varEmpty], varEmpty);\r\n AddFunction(cMath, 'Ceil', JvInterpreter_Ceil, 1, [varEmpty], varEmpty);\r\n AddFunction(cMath, 'ClearExceptions', JvInterpreter_ClearExceptions, 0, [], varEmpty);\r\n // TODO: add CompareValue function\r\n AddFunction(cMath, 'Cosecant', JvInterpreter_Cosecant, 1, [varEmpty], varEmpty);\r\n AddFunction(cMath, 'Cosh', JvInterpreter_Cosh, 1, [varEmpty], varEmpty);\r\n AddFunction(cMath, 'Cot', JvInterpreter_Cot, 1, [varEmpty], varEmpty);\r\n AddFunction(cMath, 'Cotan', JvInterpreter_Cotan, 1, [varEmpty], varEmpty);\r\n AddFunction(cMath, 'CotH', JvInterpreter_CotH, 1, [varEmpty], varEmpty);\r\n AddFunction(cMath, 'Csc', JvInterpreter_Csc, 1, [varEmpty], varEmpty);\r\n AddFunction(cMath, 'CscH', JvInterpreter_Csc, 1, [varEmpty], varEmpty);\r\n AddFunction(cMath, 'CycleToDeg', JvInterpreter_CycleToDeg, 1, [varEmpty], varEmpty);\r\n AddFunction(cMath, 'CycleToGrad', JvInterpreter_CycleToGrad, 1, [varEmpty], varEmpty);\r\n AddFunction(cMath, 'CycleToRad', JvInterpreter_CycleToRad, 1, [varEmpty], varEmpty);\r\n AddFunction(cMath, 'DegToCycle', JvInterpreter_DegToCycle, 1, [varEmpty], varEmpty);\r\n AddFunction(cMath, 'DegToGrad', JvInterpreter_DegToGrad, 1, [varEmpty], varEmpty);\r\n AddFunction(cMath, 'DegToRad', JvInterpreter_DegToRad, 1, [varEmpty], varEmpty);\r\n // TODO: add DivMod function\r\n // TODO: add DoubleDecliningBalance function\r\n // TODO: add EnsureRange function\r\n AddFunction(cMath, 'Floor', JvInterpreter_Floor, 1, [varEmpty], varEmpty);\r\n // TODO: add Frexp procedure\r\n // TODO: add FutureValue function\r\n // TODO: add GetExceptionMask function\r\n // TODO: add GetPrecisionMode function\r\n // TODO: add GetRoundMode function\r\n AddFunction(cMath, 'GradToCycle', JvInterpreter_GradToCycle, 1, [varEmpty], varEmpty);\r\n AddFunction(cMath, 'GradToDeg', JvInterpreter_GradToDeg, 1, [varEmpty], varEmpty);\r\n AddFunction(cMath, 'GradToRad', JvInterpreter_GradToRad, 1, [varEmpty], varEmpty);\r\n AddFunction(cMath, 'Hypot', JvInterpreter_Hypot, 2, [varEmpty,varEmpty], varEmpty);\r\n // TODO: add InRange function\r\n // TODO: add InterestPayment function\r\n // TODO: add InterestRate function\r\n // TODO: add InternalRateOfReturn function\r\n AddFunction(cMath, 'IntPower', JvInterpreter_IntPower, 2, [varEmpty,varEmpty], varEmpty);\r\n AddFunction(cMath, 'IsInfinite', JvInterpreter_IsInfinite, 1, [varEmpty], varEmpty);\r\n AddFunction(cMath, 'IsNan', JvInterpreter_IsNan, 1, [varEmpty], varEmpty);\r\n // TODO: add IsZero function\r\n AddFunction(cMath, 'Ldexp', JvInterpreter_Ldexp, 2, [varEmpty,varEmpty], varEmpty);\r\n AddFunction(cMath, 'LnXP1', JvInterpreter_LnXP1, 1, [varEmpty], varEmpty);\r\n AddFunction(cMath, 'Log10', JvInterpreter_Log10, 1, [varEmpty], varEmpty);\r\n AddFunction(cMath, 'Log2', JvInterpreter_Log2, 1, [varEmpty], varEmpty);\r\n AddFunction(cMath, 'LogN', JvInterpreter_LogN, 2, [varEmpty,varEmpty], varEmpty);\r\n AddFunction(cMath, 'Max', JvInterpreter_Max, 2, [varEmpty, varEmpty], varEmpty);\r\n // TODO: add MaxIntValue function\r\n // TODO: add MaxValue function\r\n // TODO: add Mean function\r\n AddFunction(cMath, 'Min', JvInterpreter_Min, 2, [varEmpty, varEmpty], varEmpty);\r\n // TODO: add MinIntValue function\r\n // TODO: add MinValue function\r\n // TODO: add MomentSkewKurtosis function\r\n // TODO: add NetPresentValue function\r\n // TODO: add Norm function\r\n // TODO: add NumberOfPeriods function\r\n // TODO: add Payment function\r\n // TODO: add PeriodPayment function\r\n // TODO: add Poly function\r\n // TODO: add PopnStdDev function\r\n // TODO: add PopnVariance function\r\n AddFunction(cMath, 'Power', JvInterpreter_Power, 2, [varEmpty,varEmpty], varEmpty);\r\n // TODO: add PresentValue function\r\n AddFunction(cMath, 'RadToCycle', JvInterpreter_RadToCycle, 1, [varEmpty], varEmpty);\r\n AddFunction(cMath, 'RadToDeg', JvInterpreter_RadToDeg, 1, [varEmpty], varEmpty);\r\n AddFunction(cMath, 'RadToGrad', JvInterpreter_RadToGrad, 1, [varEmpty], varEmpty);\r\n AddFunction(cMath, 'RandG', JvInterpreter_RandG, 2, [varEmpty,varEmpty], varEmpty);\r\n AddFunction(cMath, 'RandomRange', JvInterpreter_RandomRange, 2, [varEmpty,varEmpty], varEmpty);\r\n // TODO: add RoundTo function\r\n // TODO: add SameValue function\r\n AddFunction(cMath, 'Sec', JvInterpreter_Sec, 1, [varEmpty], varEmpty);\r\n AddFunction(cMath, 'Secant', JvInterpreter_Secant, 1, [varEmpty], varEmpty);\r\n AddFunction(cMath, 'SecH', JvInterpreter_SecH, 1, [varEmpty], varEmpty);\r\n // TODO: add SetExceptionMask function\r\n // TODO: add SetPrecisionMode function\r\n // TODO: add SetRoundMode function\r\n // TODO: add Sign function\r\n // TODO: add SimpleRoundTo function\r\n // TODO: add SinCos function\r\n AddFunction(cMath, 'Sinh', JvInterpreter_Sinh, 1, [varEmpty], varEmpty);\r\n AddFunction(cMath, 'SLNDepreciation', JvInterpreter_SLNDepreciation, 3, [varEmpty,varEmpty,varEmpty], varEmpty);\r\n // TODO: add StdDev function\r\n // TODO: add Sum function\r\n // TODO: add SumInt function\r\n // TODO: add SumOfSquares function\r\n // TODO: add SumsAndSquares function\r\n AddFunction(cMath, 'SYDDepreciation', JvInterpreter_SYDDepreciation, 4, [varEmpty,varEmpty,varEmpty,varEmpty], varEmpty);\r\n AddFunction(cMath, 'Tan', JvInterpreter_Tan, 1, [varEmpty], varEmpty);\r\n AddFunction(cMath, 'Tanh', JvInterpreter_Tanh, 1, [varEmpty], varEmpty);\r\n // TODO: add TotalVariance function\r\n // TODO: add Variance function\r\n end;\r\nend;\r\n\r\n\r\nend.\r\n\r\n" }, { "path": "External/Jedi/Jvcl/run/JvInterpreter_Menus.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvInterpreter_Menus.PAS, released on 2002-07-04.\r\n\r\nThe Initial Developers of the Original Code are: Andrei Prygounkov \r\nCopyright (c) 1999, 2002 Andrei Prygounkov\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nDescription : adapter unit - converts JvInterpreter calls to delphi calls\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvInterpreter_Menus.pas 13173 2011-11-19 12:43:58Z ahuser $\r\n\r\nunit JvInterpreter_Menus;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n JvInterpreter;\r\n\r\nprocedure RegisterJvInterpreterAdapter(JvInterpreterAdapter: TJvInterpreterAdapter);\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvInterpreter_Menus.pas $';\r\n Revision: '$Revision: 13173 $';\r\n Date: '$Date: 2011-11-19 13:43:58 +0100 (sam. 19 nov. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n Classes, Menus;\r\n\r\n{ EMenuError }\r\n\r\n{ TMenuItem }\r\n\r\n{ constructor Create(AOwner: TComponent) }\r\n\r\nprocedure TMenuItem_Create(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TMenuItem.Create(V2O(Args.Values[0]) as TComponent));\r\nend;\r\n\r\n{ procedure Insert(Index: Integer; Item: TMenuItem); }\r\n\r\nprocedure TMenuItem_Insert(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TMenuItem(Args.Obj).Insert(Args.Values[0], V2O(Args.Values[1]) as TMenuItem);\r\nend;\r\n\r\n{ procedure Delete(Index: Integer); }\r\n\r\nprocedure TMenuItem_Delete(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TMenuItem(Args.Obj).Delete(Args.Values[0]);\r\nend;\r\n\r\n{ procedure Click; }\r\n\r\nprocedure TMenuItem_Click(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TMenuItem(Args.Obj).Click;\r\nend;\r\n\r\n{ function IndexOf(Item: TMenuItem): Integer; }\r\n\r\nprocedure TMenuItem_IndexOf(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TMenuItem(Args.Obj).IndexOf(V2O(Args.Values[0]) as TMenuItem);\r\nend;\r\n\r\n{ procedure Add(Item: TMenuItem); }\r\n\r\nprocedure TMenuItem_Add(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TMenuItem(Args.Obj).Add(V2O(Args.Values[0]) as TMenuItem);\r\nend;\r\n\r\n{ procedure Remove(Item: TMenuItem); }\r\n\r\nprocedure TMenuItem_Remove(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TMenuItem(Args.Obj).Remove(V2O(Args.Values[0]) as TMenuItem);\r\nend;\r\n\r\n{ property Read Command: Word }\r\n\r\nprocedure TMenuItem_Read_Command(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TMenuItem(Args.Obj).Command;\r\nend;\r\n\r\n{ property Read Handle: HMENU }\r\n\r\nprocedure TMenuItem_Read_Handle(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := NativeInt(TMenuItem(Args.Obj).Handle);\r\nend;\r\n\r\n{ property Read Count: Integer }\r\n\r\nprocedure TMenuItem_Read_Count(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TMenuItem(Args.Obj).Count;\r\nend;\r\n\r\n{ property Read Items[Integer]: TMenuItem }\r\n\r\nprocedure TMenuItem_Read_Items(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TMenuItem(Args.Obj).Items[Args.Values[0]]);\r\nend;\r\n\r\n{ property Read MenuIndex: Integer }\r\n\r\nprocedure TMenuItem_Read_MenuIndex(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TMenuItem(Args.Obj).MenuIndex;\r\nend;\r\n\r\n{ property Write MenuIndex(Value: Integer) }\r\n\r\nprocedure TMenuItem_Write_MenuIndex(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TMenuItem(Args.Obj).MenuIndex := Value;\r\nend;\r\n\r\n{ property Read Parent: TMenuItem }\r\n\r\nprocedure TMenuItem_Read_Parent(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TMenuItem(Args.Obj).Parent);\r\nend;\r\n\r\n{ property Read Break: TMenuBreak }\r\n\r\nprocedure TMenuItem_Read_Break(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TMenuItem(Args.Obj).Break;\r\nend;\r\n\r\n{ property Write Break(Value: TMenuBreak) }\r\n\r\nprocedure TMenuItem_Write_Break(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TMenuItem(Args.Obj).Break := Value;\r\nend;\r\n\r\n{ property Read Caption: string }\r\n\r\nprocedure TMenuItem_Read_Caption(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TMenuItem(Args.Obj).Caption;\r\nend;\r\n\r\n{ property Write Caption(Value: string) }\r\n\r\nprocedure TMenuItem_Write_Caption(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TMenuItem(Args.Obj).Caption := Value;\r\nend;\r\n\r\n{ property Read Checked: Boolean }\r\n\r\nprocedure TMenuItem_Read_Checked(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TMenuItem(Args.Obj).Checked;\r\nend;\r\n\r\n{ property Write Checked(Value: Boolean) }\r\n\r\nprocedure TMenuItem_Write_Checked(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TMenuItem(Args.Obj).Checked := Value;\r\nend;\r\n\r\n{ property Read Default: Boolean }\r\n\r\nprocedure TMenuItem_Read_Default(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TMenuItem(Args.Obj).Default;\r\nend;\r\n\r\n{ property Write Default(Value: Boolean) }\r\n\r\nprocedure TMenuItem_Write_Default(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TMenuItem(Args.Obj).Default := Value;\r\nend;\r\n\r\n{ property Read Enabled: Boolean }\r\n\r\nprocedure TMenuItem_Read_Enabled(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TMenuItem(Args.Obj).Enabled;\r\nend;\r\n\r\n{ property Write Enabled(Value: Boolean) }\r\n\r\nprocedure TMenuItem_Write_Enabled(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TMenuItem(Args.Obj).Enabled := Value;\r\nend;\r\n\r\n{ property Read GroupIndex: Byte }\r\n\r\nprocedure TMenuItem_Read_GroupIndex(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TMenuItem(Args.Obj).GroupIndex;\r\nend;\r\n\r\n{ property Write GroupIndex(Value: Byte) }\r\n\r\nprocedure TMenuItem_Write_GroupIndex(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TMenuItem(Args.Obj).GroupIndex := Value;\r\nend;\r\n\r\n{ property Read HelpContext: THelpContext }\r\n\r\nprocedure TMenuItem_Read_HelpContext(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TMenuItem(Args.Obj).HelpContext;\r\nend;\r\n\r\n{ property Write HelpContext(Value: THelpContext) }\r\n\r\nprocedure TMenuItem_Write_HelpContext(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TMenuItem(Args.Obj).HelpContext := Value;\r\nend;\r\n\r\n{ property Read Hint: string }\r\n\r\nprocedure TMenuItem_Read_Hint(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TMenuItem(Args.Obj).Hint;\r\nend;\r\n\r\n{ property Write Hint(Value: string) }\r\n\r\nprocedure TMenuItem_Write_Hint(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TMenuItem(Args.Obj).Hint := Value;\r\nend;\r\n\r\n{ property Read RadioItem: Boolean }\r\n\r\nprocedure TMenuItem_Read_RadioItem(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TMenuItem(Args.Obj).RadioItem;\r\nend;\r\n\r\n{ property Write RadioItem(Value: Boolean) }\r\n\r\nprocedure TMenuItem_Write_RadioItem(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TMenuItem(Args.Obj).RadioItem := Value;\r\nend;\r\n\r\n{ property Read ShortCut: TShortCut }\r\n\r\nprocedure TMenuItem_Read_ShortCut(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TMenuItem(Args.Obj).ShortCut;\r\nend;\r\n\r\n{ property Write ShortCut(Value: TShortCut) }\r\n\r\nprocedure TMenuItem_Write_ShortCut(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TMenuItem(Args.Obj).ShortCut := Value;\r\nend;\r\n\r\n{ property Read Visible: Boolean }\r\n\r\nprocedure TMenuItem_Read_Visible(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TMenuItem(Args.Obj).Visible;\r\nend;\r\n\r\n{ property Write Visible(Value: Boolean) }\r\n\r\nprocedure TMenuItem_Write_Visible(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TMenuItem(Args.Obj).Visible := Value;\r\nend;\r\n\r\n{ TMenu }\r\n\r\n{ function DispatchCommand(ACommand: Word): Boolean; }\r\n\r\nprocedure TMenu_DispatchCommand(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TMenu(Args.Obj).DispatchCommand(Args.Values[0]);\r\nend;\r\n\r\n{ function DispatchPopup(AHandle: HMENU): Boolean; }\r\n\r\nprocedure TMenu_DispatchPopup(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TMenu(Args.Obj).DispatchPopup(Args.Values[0]);\r\nend;\r\n\r\n{ function FindItem(Value: Integer; Kind: TFindItemKind): TMenuItem; }\r\n\r\nprocedure TMenu_FindItem(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TMenu(Args.Obj).FindItem(Args.Values[0], Args.Values[1]));\r\nend;\r\n\r\n{ function GetHelpContext(Value: Integer; ByCommand: Boolean): THelpContext; }\r\n\r\nprocedure TMenu_GetHelpContext(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TMenu(Args.Obj).GetHelpContext(Args.Values[0], Args.Values[1]);\r\nend;\r\n\r\n(*\r\n{ function IsShortCut(var Message: TWMKey): Boolean; }\r\nprocedure TMenu_IsShortCut(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TMenu(Args.Obj).IsShortCut(Args.Values[0]);\r\nend;\r\n*)\r\n\r\n{ property Read Handle: HMENU }\r\n\r\nprocedure TMenu_Read_Handle(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := NativeInt(TMenu(Args.Obj).Handle);\r\nend;\r\n\r\n{ property Read WindowHandle: HWND }\r\n\r\nprocedure TMenu_Read_WindowHandle(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := NativeInt(TMenu(Args.Obj).WindowHandle);\r\nend;\r\n\r\n{ property Write WindowHandle(Value: HWND) }\r\n\r\nprocedure TMenu_Write_WindowHandle(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TMenu(Args.Obj).WindowHandle := Value;\r\nend;\r\n\r\n{ property Read Items: TMenuItem }\r\n\r\nprocedure TMenu_Read_Items(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TMenu(Args.Obj).Items);\r\nend;\r\n\r\n{ TMainMenu }\r\n\r\n{ constructor Create(AOwner: TComponent) }\r\n\r\nprocedure TMainMenu_Create(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TMainMenu.Create(V2O(Args.Values[0]) as TComponent));\r\nend;\r\n\r\n{ procedure Merge(Menu: TMainMenu); }\r\n\r\nprocedure TMainMenu_Merge(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TMainMenu(Args.Obj).Merge(V2O(Args.Values[0]) as TMainMenu);\r\nend;\r\n\r\n{ procedure Unmerge(Menu: TMainMenu); }\r\n\r\nprocedure TMainMenu_Unmerge(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TMainMenu(Args.Obj).Unmerge(V2O(Args.Values[0]) as TMainMenu);\r\nend;\r\n\r\n{ property Read AutoMerge: Boolean }\r\n\r\nprocedure TMainMenu_Read_AutoMerge(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TMainMenu(Args.Obj).AutoMerge;\r\nend;\r\n\r\n{ property Write AutoMerge(Value: Boolean) }\r\n\r\nprocedure TMainMenu_Write_AutoMerge(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TMainMenu(Args.Obj).AutoMerge := Value;\r\nend;\r\n\r\n{ TPopupMenu }\r\n\r\n{ constructor Create(AOwner: TComponent) }\r\n\r\nprocedure TPopupMenu_Create(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TPopupMenu.Create(V2O(Args.Values[0]) as TComponent));\r\nend;\r\n\r\n{ procedure Popup(X, Y: Integer); }\r\n\r\nprocedure TPopupMenu_Popup(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TPopupMenu(Args.Obj).Popup(Args.Values[0], Args.Values[1]);\r\nend;\r\n\r\n{ property Read PopupComponent: TComponent }\r\n\r\nprocedure TPopupMenu_Read_PopupComponent(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TPopupMenu(Args.Obj).PopupComponent);\r\nend;\r\n\r\n{ property Write PopupComponent(Value: TComponent) }\r\n\r\nprocedure TPopupMenu_Write_PopupComponent(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TPopupMenu(Args.Obj).PopupComponent := V2O(Value) as TComponent;\r\nend;\r\n\r\n{ property Read Alignment: TPopupAlignment }\r\n\r\nprocedure TPopupMenu_Read_Alignment(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TPopupMenu(Args.Obj).Alignment;\r\nend;\r\n\r\n{ property Write Alignment(Value: TPopupAlignment) }\r\n\r\nprocedure TPopupMenu_Write_Alignment(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TPopupMenu(Args.Obj).Alignment := Value;\r\nend;\r\n\r\n{ property Read AutoPopup: Boolean }\r\n\r\nprocedure TPopupMenu_Read_AutoPopup(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TPopupMenu(Args.Obj).AutoPopup;\r\nend;\r\n\r\n{ property Write AutoPopup(Value: Boolean) }\r\n\r\nprocedure TPopupMenu_Write_AutoPopup(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TPopupMenu(Args.Obj).AutoPopup := Value;\r\nend;\r\n\r\n{ property Read HelpContext: THelpContext }\r\n\r\nprocedure TPopupMenu_Read_HelpContext(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TPopupMenu(Args.Obj).HelpContext;\r\nend;\r\n\r\n{ property Write HelpContext(Value: THelpContext) }\r\n\r\nprocedure TPopupMenu_Write_HelpContext(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TPopupMenu(Args.Obj).HelpContext := Value;\r\nend;\r\n\r\n{ function ShortCut(Key: Word; Shift: TShiftState): TShortCut; }\r\n\r\nprocedure JvInterpreter_ShortCut(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := ShortCut(Args.Values[0], TShiftState(TJvInterpreterShiftStateCastType(V2S(Args.Values[1]))));\r\nend;\r\n\r\n{ procedure ShortCutToKey(ShortCut: TShortCut; var Key: Word; var Shift: TShiftState); }\r\n\r\nprocedure JvInterpreter_ShortCutToKey(var Value: Variant; Args: TJvInterpreterArgs);\r\nvar\r\n Shift: TShiftState;\r\nbegin\r\n Shift := TShiftState(TJvInterpreterShiftStateCastType(V2S(Args.Values[2])));\r\n ShortCutToKey(Args.Values[0], Word(TVarData(Args.Values[1]).vSmallint), Shift);\r\n Args.Values[2] := S2V(TJvInterpreterShiftStateCastType(Shift));\r\nend;\r\n\r\n{ function ShortCutToText(ShortCut: TShortCut): string; }\r\n\r\nprocedure JvInterpreter_ShortCutToText(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := ShortCutToText(Args.Values[0]);\r\nend;\r\n\r\n{ function TextToShortCut(Text: string): TShortCut; }\r\n\r\nprocedure JvInterpreter_TextToShortCut(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TextToShortCut(Args.Values[0]);\r\nend;\r\n\r\n(*\r\n{ function NewMenu(Owner: TComponent; const AName: string; Items: array of TMenuItem): TMainMenu; }\r\nprocedure JvInterpreter_NewMenu(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(NewMenu(V2O(Args.Values[0]) as TComponent, Args.Values[1], Args.Values[2]));\r\nend;\r\n\r\n{ function NewPopupMenu(Owner: TComponent; const AName: string; Alignment: TPopupAlignment; AutoPopup: Boolean; Items: array of TMenuitem): TPopupMenu; }\r\nprocedure JvInterpreter_NewPopupMenu(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(NewPopupMenu(V2O(Args.Values[0]) as TComponent, Args.Values[1], Args.Values[2], Args.Values[3], Args.Values[4]));\r\nend;\r\n\r\n{ function NewSubMenu(const ACaption: string; hCtx: Word; const AName: string; Items: array of TMenuItem): TMenuItem; }\r\nprocedure JvInterpreter_NewSubMenu(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(NewSubMenu(Args.Values[0], Args.Values[1], Args.Values[2], Args.Values[3]));\r\nend;\r\n*)\r\n\r\n{ function NewItem(const ACaption: string; AShortCut: TShortCut; AChecked, AEnabled: Boolean; AOnClick: TNotifyEvent; hCtx: Word; const AName: string): TMenuItem; }\r\n\r\nprocedure JvInterpreter_NewItem(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(NewItem(Args.Values[0], Args.Values[1], Args.Values[2], Args.Values[3], nil, Args.Values[5],\r\n Args.Values[6]));\r\nend;\r\n\r\n{ function NewLine: TMenuItem; }\r\n\r\nprocedure JvInterpreter_NewLine(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(NewLine);\r\nend;\r\n\r\nprocedure RegisterJvInterpreterAdapter(JvInterpreterAdapter: TJvInterpreterAdapter);\r\nconst\r\n cMenus = 'Menus';\r\nbegin\r\n with JvInterpreterAdapter do\r\n begin\r\n { EMenuError }\r\n AddClass(cMenus, EMenuError, 'EMenuError');\r\n { TMenuItem }\r\n AddClass(cMenus, TMenuItem, 'TMenuItem');\r\n AddGet(TMenuItem, 'Create', TMenuItem_Create, 1, [varEmpty], varEmpty);\r\n AddGet(TMenuItem, 'Insert', TMenuItem_Insert, 2, [varEmpty, varEmpty], varEmpty);\r\n AddGet(TMenuItem, 'Delete', TMenuItem_Delete, 1, [varEmpty], varEmpty);\r\n AddGet(TMenuItem, 'Click', TMenuItem_Click, 0, [varEmpty], varEmpty);\r\n AddGet(TMenuItem, 'IndexOf', TMenuItem_IndexOf, 1, [varEmpty], varEmpty);\r\n AddGet(TMenuItem, 'Add', TMenuItem_Add, 1, [varEmpty], varEmpty);\r\n AddGet(TMenuItem, 'Remove', TMenuItem_Remove, 1, [varEmpty], varEmpty);\r\n AddGet(TMenuItem, 'Command', TMenuItem_Read_Command, 0, [varEmpty], varEmpty);\r\n AddGet(TMenuItem, 'Handle', TMenuItem_Read_Handle, 0, [varEmpty], varEmpty);\r\n AddGet(TMenuItem, 'Count', TMenuItem_Read_Count, 0, [varEmpty], varEmpty);\r\n AddIGet(TMenuItem, 'Items', TMenuItem_Read_Items, 1, [varEmpty], varEmpty);\r\n AddGet(TMenuItem, 'MenuIndex', TMenuItem_Read_MenuIndex, 0, [varEmpty], varEmpty);\r\n AddSet(TMenuItem, 'MenuIndex', TMenuItem_Write_MenuIndex, 0, [varEmpty]);\r\n AddGet(TMenuItem, 'Parent', TMenuItem_Read_Parent, 0, [varEmpty], varEmpty);\r\n AddGet(TMenuItem, 'Break', TMenuItem_Read_Break, 0, [varEmpty], varEmpty);\r\n AddSet(TMenuItem, 'Break', TMenuItem_Write_Break, 0, [varEmpty]);\r\n AddGet(TMenuItem, 'Caption', TMenuItem_Read_Caption, 0, [varEmpty], varEmpty);\r\n AddSet(TMenuItem, 'Caption', TMenuItem_Write_Caption, 0, [varEmpty]);\r\n AddGet(TMenuItem, 'Checked', TMenuItem_Read_Checked, 0, [varEmpty], varEmpty);\r\n AddSet(TMenuItem, 'Checked', TMenuItem_Write_Checked, 0, [varEmpty]);\r\n AddGet(TMenuItem, 'Default', TMenuItem_Read_Default, 0, [varEmpty], varEmpty);\r\n AddSet(TMenuItem, 'Default', TMenuItem_Write_Default, 0, [varEmpty]);\r\n AddGet(TMenuItem, 'Enabled', TMenuItem_Read_Enabled, 0, [varEmpty], varEmpty);\r\n AddSet(TMenuItem, 'Enabled', TMenuItem_Write_Enabled, 0, [varEmpty]);\r\n AddGet(TMenuItem, 'GroupIndex', TMenuItem_Read_GroupIndex, 0, [varEmpty], varEmpty);\r\n AddSet(TMenuItem, 'GroupIndex', TMenuItem_Write_GroupIndex, 0, [varEmpty]);\r\n AddGet(TMenuItem, 'HelpContext', TMenuItem_Read_HelpContext, 0, [varEmpty], varEmpty);\r\n AddSet(TMenuItem, 'HelpContext', TMenuItem_Write_HelpContext, 0, [varEmpty]);\r\n AddGet(TMenuItem, 'Hint', TMenuItem_Read_Hint, 0, [varEmpty], varEmpty);\r\n AddSet(TMenuItem, 'Hint', TMenuItem_Write_Hint, 0, [varEmpty]);\r\n AddGet(TMenuItem, 'RadioItem', TMenuItem_Read_RadioItem, 0, [varEmpty], varEmpty);\r\n AddSet(TMenuItem, 'RadioItem', TMenuItem_Write_RadioItem, 0, [varEmpty]);\r\n AddGet(TMenuItem, 'ShortCut', TMenuItem_Read_ShortCut, 0, [varEmpty], varEmpty);\r\n AddSet(TMenuItem, 'ShortCut', TMenuItem_Write_ShortCut, 0, [varEmpty]);\r\n AddGet(TMenuItem, 'Visible', TMenuItem_Read_Visible, 0, [varEmpty], varEmpty);\r\n AddSet(TMenuItem, 'Visible', TMenuItem_Write_Visible, 0, [varEmpty]);\r\n { TMenu }\r\n AddClass(cMenus, TMenu, 'TMenu');\r\n AddGet(TMenu, 'DispatchCommand', TMenu_DispatchCommand, 1, [varEmpty], varEmpty);\r\n AddGet(TMenu, 'DispatchPopup', TMenu_DispatchPopup, 1, [varEmpty], varEmpty);\r\n AddGet(TMenu, 'FindItem', TMenu_FindItem, 2, [varEmpty, varEmpty], varEmpty);\r\n AddGet(TMenu, 'GetHelpContext', TMenu_GetHelpContext, 2, [varEmpty, varEmpty], varEmpty);\r\n // AddGet(TMenu, 'IsShortCut', TMenu_IsShortCut, 1, [varByRef], nil);\r\n AddGet(TMenu, 'Handle', TMenu_Read_Handle, 0, [varEmpty], varEmpty);\r\n AddGet(TMenu, 'WindowHandle', TMenu_Read_WindowHandle, 0, [varEmpty], varEmpty);\r\n AddSet(TMenu, 'WindowHandle', TMenu_Write_WindowHandle, 0, [varEmpty]);\r\n AddGet(TMenu, 'Items', TMenu_Read_Items, 0, [varEmpty], varEmpty);\r\n { TMainMenu }\r\n AddClass(cMenus, TMainMenu, 'TMainMenu');\r\n AddGet(TMainMenu, 'Create', TMainMenu_Create, 1, [varEmpty], varEmpty);\r\n AddGet(TMainMenu, 'Merge', TMainMenu_Merge, 1, [varEmpty], varEmpty);\r\n AddGet(TMainMenu, 'Unmerge', TMainMenu_Unmerge, 1, [varEmpty], varEmpty);\r\n AddGet(TMainMenu, 'AutoMerge', TMainMenu_Read_AutoMerge, 0, [varEmpty], varEmpty);\r\n AddSet(TMainMenu, 'AutoMerge', TMainMenu_Write_AutoMerge, 0, [varEmpty]);\r\n { TPopupMenu }\r\n AddClass(cMenus, TPopupMenu, 'TPopupMenu');\r\n AddGet(TPopupMenu, 'Create', TPopupMenu_Create, 1, [varEmpty], varEmpty);\r\n AddGet(TPopupMenu, 'Popup', TPopupMenu_Popup, 2, [varEmpty, varEmpty], varEmpty);\r\n AddGet(TPopupMenu, 'PopupComponent', TPopupMenu_Read_PopupComponent, 0, [varEmpty], varEmpty);\r\n AddSet(TPopupMenu, 'PopupComponent', TPopupMenu_Write_PopupComponent, 0, [varEmpty]);\r\n AddGet(TPopupMenu, 'Alignment', TPopupMenu_Read_Alignment, 0, [varEmpty], varEmpty);\r\n AddSet(TPopupMenu, 'Alignment', TPopupMenu_Write_Alignment, 0, [varEmpty]);\r\n AddGet(TPopupMenu, 'AutoPopup', TPopupMenu_Read_AutoPopup, 0, [varEmpty], varEmpty);\r\n AddSet(TPopupMenu, 'AutoPopup', TPopupMenu_Write_AutoPopup, 0, [varEmpty]);\r\n AddGet(TPopupMenu, 'HelpContext', TPopupMenu_Read_HelpContext, 0, [varEmpty], varEmpty);\r\n AddSet(TPopupMenu, 'HelpContext', TPopupMenu_Write_HelpContext, 0, [varEmpty]);\r\n AddFunction(cMenus, 'ShortCut', JvInterpreter_ShortCut, 2, [varEmpty, varEmpty], varEmpty);\r\n AddFunction(cMenus, 'ShortCutToKey', JvInterpreter_ShortCutToKey, 3, [varEmpty, varByRef, varByRef], varEmpty);\r\n AddFunction(cMenus, 'ShortCutToText', JvInterpreter_ShortCutToText, 1, [varEmpty], varEmpty);\r\n AddFunction(cMenus, 'TextToShortCut', JvInterpreter_TextToShortCut, 1, [varEmpty], varEmpty);\r\n { AddFunction(cMenus, 'NewMenu', JvInterpreter_NewMenu, 3, [varEmpty, varEmpty, varEmpty], nil);\r\n AddFunction(cMenus, 'NewPopupMenu', JvInterpreter_NewPopupMenu, 5, [varEmpty, varEmpty, varEmpty, varEmpty, varEmpty], varEmpty);\r\n AddFunction(cMenus, 'NewSubMenu', JvInterpreter_NewSubMenu, 4, [varEmpty, varEmpty, varEmpty, varEmpty], varEmpty); }\r\n AddFunction(cMenus, 'NewItem', JvInterpreter_NewItem, 7, [varEmpty, varEmpty, varEmpty, varEmpty, varEmpty, varEmpty,\r\n varEmpty], varEmpty);\r\n AddFunction(cMenus, 'NewLine', JvInterpreter_NewLine, 0, [varEmpty], varEmpty);\r\n end;\r\n RegisterClasses([TMainMenu, TPopupMenu, TMenuItem]);\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvInterpreter_Quickrpt.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvInterpreter_Quickrpt.PAS, released on 2002-07-04.\r\n\r\nThe Initial Developers of the Original Code are: Andrei Prygounkov \r\nCopyright (c) 1999, 2002 Andrei Prygounkov\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nDescription:\r\n adapter unit - converts JvInterpreter calls to delphi calls\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvInterpreter_Quickrpt.pas 13075 2011-06-27 22:56:21Z jfudickar $\r\n\r\nunit JvInterpreter_Quickrpt;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n JvInterpreter;\r\n\r\nprocedure RegisterJvInterpreterAdapter(JvInterpreterAdapter: TJvInterpreterAdapter);\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvInterpreter_Quickrpt.pas $';\r\n Revision: '$Revision: 13075 $';\r\n Date: '$Date: 2011-06-28 00:56:21 +0200 (mar. 28 juin 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n SysUtils, Classes, Controls, Forms, Graphics, DB,\r\n {$IFDEF JVCL_UseQuickReport}\r\n QrPrntr, Quickrpt, QrCtrls,\r\n {$ELSE}\r\n {$MESSAGE FATAL 'You must have QuickReport to compile this unit'}\r\n {$ENDIF JVCL_UseQuickReport}\r\n JvInterpreterFm, JvResources, JvTypes;\r\n\r\nconst\r\n cQuickRep1 = 'QuickRep1';\r\n\r\nprocedure JvInterpreterRunReportPreview(const FileName: string);\r\nvar\r\n Form: TForm;\r\n QuickRep1: TQuickRep;\r\n I: Integer;\r\nbegin\r\n Form := JvInterpreterMakeForm(FileName);\r\n try\r\n QuickRep1 := Form.FindComponent(cQuickRep1) as TQuickRep;\r\n if QuickRep1 = nil then\r\n for I := 0 to Form.ComponentCount - 1 do\r\n if Form.Components[I] is TQuickRep then\r\n begin\r\n QuickRep1 := Form.Components[I] as TQuickRep;\r\n Break;\r\n end;\r\n if QuickRep1 = nil then\r\n raise EJVCLException.CreateRes(@RsENoQuickReportFound);\r\n QuickRep1.Preview;\r\n finally\r\n Form.Free;\r\n end;\r\nend;\r\n\r\nprocedure JvInterpreterRunReportPreview2(const FileName: string; JvInterpreterProgram: TJvInterpreterFm);\r\nvar\r\n Form: TForm;\r\n QuickRep1: TQuickRep;\r\n I: Integer;\r\nbegin\r\n Form := JvInterpreterProgram.MakeForm(FileName);\r\n try\r\n QuickRep1 := Form.FindComponent(cQuickRep1) as TQuickRep;\r\n if QuickRep1 = nil then\r\n for I := 0 to Form.ComponentCount - 1 do\r\n if Form.Components[I] is TQuickRep then\r\n begin\r\n QuickRep1 := Form.Components[I] as TQuickRep;\r\n Break;\r\n end;\r\n if QuickRep1 = nil then\r\n raise EJVCLException.CreateRes(@RsENoQuickReportFound);\r\n QuickRep1.Preview;\r\n finally\r\n Form.Free;\r\n end;\r\nend;\r\n\r\n{ TQRController }\r\n\r\n{ constructor Create(AOwner: TComponent) }\r\n\r\nprocedure TQRController_Create(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TQRController.Create(V2O(Args.Values[0]) as TComponent));\r\nend;\r\n\r\n{ procedure AddNotifyClient(Value: TQRPrintable); }\r\n\r\nprocedure TQRController_AddNotifyClient(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TQRController(Args.Obj).AddNotifyClient(V2O(Args.Values[0]) as TQRPrintable);\r\nend;\r\n\r\n{ property Read DataSet: TDataSet }\r\n\r\nprocedure TQRController_Read_DataSet(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TQRController(Args.Obj).DataSet);\r\nend;\r\n\r\n{ property Write DataSet(Value: TDataSet) }\r\n\r\nprocedure TQRController_Write_DataSet(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TQRController(Args.Obj).DataSet := V2O(Value) as TDataSet;\r\nend;\r\n\r\n{ property Read DetailNumber: Integer }\r\n\r\nprocedure TQRController_Read_DetailNumber(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TQRController(Args.Obj).DetailNumber;\r\nend;\r\n\r\n{ property Read Detail: TQRCustomBand }\r\n\r\nprocedure TQRController_Read_Detail(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TQRController(Args.Obj).Detail);\r\nend;\r\n\r\n{ property Write Detail(Value: TQRCustomBand) }\r\n\r\nprocedure TQRController_Write_Detail(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TQRController(Args.Obj).Detail := V2O(Value) as TQRCustomBand;\r\nend;\r\n\r\n{ property Read Footer: TQRCustomBand }\r\n\r\nprocedure TQRController_Read_Footer(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TQRController(Args.Obj).Footer);\r\nend;\r\n\r\n{ property Write Footer(Value: TQRCustomBand) }\r\n\r\nprocedure TQRController_Write_Footer(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TQRController(Args.Obj).Footer := V2O(Value) as TQRCustomBand;\r\nend;\r\n\r\n{ property Read Header: TQRCustomBand }\r\n\r\nprocedure TQRController_Read_Header(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TQRController(Args.Obj).Header);\r\nend;\r\n\r\n{ property Write Header(Value: TQRCustomBand) }\r\n\r\nprocedure TQRController_Write_Header(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TQRController(Args.Obj).Header := V2O(Value) as TQRCustomBand;\r\nend;\r\n\r\n{ property Read Master: TComponent }\r\n\r\nprocedure TQRController_Read_Master(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TQRController(Args.Obj).Master);\r\nend;\r\n\r\n{ property Write Master(Value: TComponent) }\r\n\r\nprocedure TQRController_Write_Master(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TQRController(Args.Obj).Master := V2O(Value) as TComponent;\r\nend;\r\n\r\n{ property Read ParentReport: TQuickRep }\r\n\r\nprocedure TQRController_Read_ParentReport(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TQRController(Args.Obj).ParentReport);\r\nend;\r\n\r\n{ property Write ParentReport(Value: TQuickRep) }\r\n\r\nprocedure TQRController_Write_ParentReport(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TQRController(Args.Obj).ParentReport := V2O(Value) as TQuickRep;\r\nend;\r\n\r\n{ property Read PrintBefore: Boolean }\r\n\r\nprocedure TQRController_Read_PrintBefore(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TQRController(Args.Obj).PrintBefore;\r\nend;\r\n\r\n{ property Write PrintBefore(Value: Boolean) }\r\n\r\nprocedure TQRController_Write_PrintBefore(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TQRController(Args.Obj).PrintBefore := Value;\r\nend;\r\n\r\n{ property Read PrintIfEmpty: Boolean }\r\n\r\nprocedure TQRController_Read_PrintIfEmpty(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TQRController(Args.Obj).PrintIfEmpty;\r\nend;\r\n\r\n{ property Write PrintIfEmpty(Value: Boolean) }\r\n\r\nprocedure TQRController_Write_PrintIfEmpty(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TQRController(Args.Obj).PrintIfEmpty := Value;\r\nend;\r\n\r\n{ property Read SelfCheck: TComponent }\r\n\r\nprocedure TQRController_Read_SelfCheck(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TQRController(Args.Obj).SelfCheck);\r\nend;\r\n\r\n{ property Write SelfCheck(Value: TComponent) }\r\n\r\nprocedure TQRController_Write_SelfCheck(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TQRController(Args.Obj).SelfCheck := V2O(Value) as TComponent;\r\nend;\r\n\r\n{ TQRFrame }\r\n\r\n{ constructor Create }\r\n\r\nprocedure TQRFrame_Create(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TQRFrame.Create);\r\nend;\r\n\r\n{ function AnyFrame: Boolean; }\r\n\r\nprocedure TQRFrame_AnyFrame(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TQRFrame(Args.Obj).AnyFrame;\r\nend;\r\n\r\n{ property Read Parent: TControl }\r\n\r\nprocedure TQRFrame_Read_Parent(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TQRFrame(Args.Obj).Parent);\r\nend;\r\n\r\n{ property Write Parent(Value: TControl) }\r\n\r\nprocedure TQRFrame_Write_Parent(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TQRFrame(Args.Obj).Parent := V2O(Value) as TControl;\r\nend;\r\n\r\n{ property Read Color: TColor }\r\n\r\nprocedure TQRFrame_Read_Color(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TQRFrame(Args.Obj).Color;\r\nend;\r\n\r\n{ property Write Color(Value: TColor) }\r\n\r\nprocedure TQRFrame_Write_Color(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TQRFrame(Args.Obj).Color := Value;\r\nend;\r\n\r\n{ property Read DrawTop: Boolean }\r\n\r\nprocedure TQRFrame_Read_DrawTop(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TQRFrame(Args.Obj).DrawTop;\r\nend;\r\n\r\n{ property Write DrawTop(Value: Boolean) }\r\n\r\nprocedure TQRFrame_Write_DrawTop(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TQRFrame(Args.Obj).DrawTop := Value;\r\nend;\r\n\r\n{ property Read DrawBottom: Boolean }\r\n\r\nprocedure TQRFrame_Read_DrawBottom(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TQRFrame(Args.Obj).DrawBottom;\r\nend;\r\n\r\n{ property Write DrawBottom(Value: Boolean) }\r\n\r\nprocedure TQRFrame_Write_DrawBottom(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TQRFrame(Args.Obj).DrawBottom := Value;\r\nend;\r\n\r\n{ property Read DrawLeft: Boolean }\r\n\r\nprocedure TQRFrame_Read_DrawLeft(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TQRFrame(Args.Obj).DrawLeft;\r\nend;\r\n\r\n{ property Write DrawLeft(Value: Boolean) }\r\n\r\nprocedure TQRFrame_Write_DrawLeft(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TQRFrame(Args.Obj).DrawLeft := Value;\r\nend;\r\n\r\n{ property Read DrawRight: Boolean }\r\n\r\nprocedure TQRFrame_Read_DrawRight(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TQRFrame(Args.Obj).DrawRight;\r\nend;\r\n\r\n{ property Write DrawRight(Value: Boolean) }\r\n\r\nprocedure TQRFrame_Write_DrawRight(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TQRFrame(Args.Obj).DrawRight := Value;\r\nend;\r\n\r\n{ property Read Style: TPenStyle }\r\n\r\nprocedure TQRFrame_Read_Style(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TQRFrame(Args.Obj).Style;\r\nend;\r\n\r\n{ property Write Style(Value: TPenStyle) }\r\n\r\nprocedure TQRFrame_Write_Style(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TQRFrame(Args.Obj).Style := Value;\r\nend;\r\n\r\n{ property Read Width: Integer }\r\n\r\nprocedure TQRFrame_Read_Width(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TQRFrame(Args.Obj).Width;\r\nend;\r\n\r\n{ property Write Width(Value: Integer) }\r\n\r\nprocedure TQRFrame_Write_Width(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TQRFrame(Args.Obj).Width := Value;\r\nend;\r\n\r\n{ TQRUnitBase }\r\n\r\n{ constructor Create }\r\n\r\nprocedure TQRUnitBase_Create(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TQRUnitBase.Create);\r\nend;\r\n\r\n{ property Read ParentReport: TQuickRep }\r\n\r\nprocedure TQRUnitBase_Read_ParentReport(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TQRUnitBase(Args.Obj).ParentReport);\r\nend;\r\n\r\n{ property Write ParentReport(Value: TQuickRep) }\r\n\r\nprocedure TQRUnitBase_Write_ParentReport(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TQRUnitBase(Args.Obj).ParentReport := V2O(Value) as TQuickRep;\r\nend;\r\n\r\n{ property Read ParentUpdating: Boolean }\r\n\r\nprocedure TQRUnitBase_Read_ParentUpdating(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TQRUnitBase(Args.Obj).ParentUpdating;\r\nend;\r\n\r\n{ property Write ParentUpdating(Value: Boolean) }\r\n\r\nprocedure TQRUnitBase_Write_ParentUpdating(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TQRUnitBase(Args.Obj).ParentUpdating := Value;\r\nend;\r\n\r\n{ property Read Resolution: Integer }\r\n\r\nprocedure TQRUnitBase_Read_Resolution(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TQRUnitBase(Args.Obj).Resolution;\r\nend;\r\n\r\n{ property Read Units: TQRUnit }\r\n\r\nprocedure TQRUnitBase_Read_Units(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TQRUnitBase(Args.Obj).Units;\r\nend;\r\n\r\n{ property Write Units(Value: TQRUnit) }\r\n\r\nprocedure TQRUnitBase_Write_Units(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TQRUnitBase(Args.Obj).Units := Value;\r\nend;\r\n\r\n{ property Read Zoom: Integer }\r\n\r\nprocedure TQRUnitBase_Read_Zoom(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TQRUnitBase(Args.Obj).Zoom;\r\nend;\r\n\r\n{ property Write Zoom(Value: Integer) }\r\n\r\nprocedure TQRUnitBase_Write_Zoom(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TQRUnitBase(Args.Obj).Zoom := Value;\r\nend;\r\n\r\n{ TQRBandSize }\r\n\r\n{ constructor Create(AParent: TQRCustomBand) }\r\n\r\nprocedure TQRBandSize_Create(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TQRBandSize.Create(V2O(Args.Values[0]) as TQRCustomBand));\r\nend;\r\n\r\n{ property Read Length: Extended }\r\n\r\nprocedure TQRBandSize_Read_Length(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TQRBandSize(Args.Obj).Length;\r\nend;\r\n\r\n{ property Write Length(Value: Extended) }\r\n\r\nprocedure TQRBandSize_Write_Length(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TQRBandSize(Args.Obj).Length := Value;\r\nend;\r\n\r\n{ property Read Height: Extended }\r\n\r\nprocedure TQRBandSize_Read_Height(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TQRBandSize(Args.Obj).Height;\r\nend;\r\n\r\n{ property Write Height(Value: Extended) }\r\n\r\nprocedure TQRBandSize_Write_Height(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TQRBandSize(Args.Obj).Height := Value;\r\nend;\r\n\r\n{ property Read Width: Extended }\r\n\r\nprocedure TQRBandSize_Read_Width(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TQRBandSize(Args.Obj).Width;\r\nend;\r\n\r\n{ property Write Width(Value: Extended) }\r\n\r\nprocedure TQRBandSize_Write_Width(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TQRBandSize(Args.Obj).Width := Value;\r\nend;\r\n\r\n{ TQRPage }\r\n\r\n{ constructor Create(AParent: TQuickRep) }\r\n\r\nprocedure TQRPage_Create(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TQRPage.Create(V2O(Args.Values[0]) as TQuickRep));\r\nend;\r\n\r\n{ property Read BottomMargin: Extended }\r\n\r\nprocedure TQRPage_Read_BottomMargin(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TQRPage(Args.Obj).BottomMargin;\r\nend;\r\n\r\n{ property Write BottomMargin(Value: Extended) }\r\n\r\nprocedure TQRPage_Write_BottomMargin(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TQRPage(Args.Obj).BottomMargin := Value;\r\nend;\r\n\r\n{ property Read ColumnSpace: Extended }\r\n\r\nprocedure TQRPage_Read_ColumnSpace(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TQRPage(Args.Obj).ColumnSpace;\r\nend;\r\n\r\n{ property Write ColumnSpace(Value: Extended) }\r\n\r\nprocedure TQRPage_Write_ColumnSpace(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TQRPage(Args.Obj).ColumnSpace := Value;\r\nend;\r\n\r\n{ property Read Columns: Integer }\r\n\r\nprocedure TQRPage_Read_Columns(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TQRPage(Args.Obj).Columns;\r\nend;\r\n\r\n{ property Write Columns(Value: Integer) }\r\n\r\nprocedure TQRPage_Write_Columns(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TQRPage(Args.Obj).Columns := Value;\r\nend;\r\n\r\n{ property Read LeftMargin: Extended }\r\n\r\nprocedure TQRPage_Read_LeftMargin(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TQRPage(Args.Obj).LeftMargin;\r\nend;\r\n\r\n{ property Write LeftMargin(Value: Extended) }\r\n\r\nprocedure TQRPage_Write_LeftMargin(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TQRPage(Args.Obj).LeftMargin := Value;\r\nend;\r\n\r\n{ property Read Length: Extended }\r\n\r\nprocedure TQRPage_Read_Length(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TQRPage(Args.Obj).Length;\r\nend;\r\n\r\n{ property Write Length(Value: Extended) }\r\n\r\nprocedure TQRPage_Write_Length(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TQRPage(Args.Obj).Length := Value;\r\nend;\r\n\r\n{ property Read Orientation: TPrinterOrientation }\r\n\r\nprocedure TQRPage_Read_Orientation(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TQRPage(Args.Obj).Orientation;\r\nend;\r\n\r\n{ property Write Orientation(Value: TPrinterOrientation) }\r\n\r\nprocedure TQRPage_Write_Orientation(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TQRPage(Args.Obj).Orientation := Value;\r\nend;\r\n\r\n{ property Read PaperSize: TQRPaperSize }\r\n\r\nprocedure TQRPage_Read_PaperSize(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TQRPage(Args.Obj).PaperSize;\r\nend;\r\n\r\n{ property Write PaperSize(Value: TQRPaperSize) }\r\n\r\nprocedure TQRPage_Write_PaperSize(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TQRPage(Args.Obj).PaperSize := Value;\r\nend;\r\n\r\n{ property Read RightMargin: Extended }\r\n\r\nprocedure TQRPage_Read_RightMargin(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TQRPage(Args.Obj).RightMargin;\r\nend;\r\n\r\n{ property Write RightMargin(Value: Extended) }\r\n\r\nprocedure TQRPage_Write_RightMargin(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TQRPage(Args.Obj).RightMargin := Value;\r\nend;\r\n\r\n{ property Read Ruler: Boolean }\r\n\r\nprocedure TQRPage_Read_Ruler(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TQRPage(Args.Obj).Ruler;\r\nend;\r\n\r\n{ property Write Ruler(Value: Boolean) }\r\n\r\nprocedure TQRPage_Write_Ruler(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TQRPage(Args.Obj).Ruler := Value;\r\nend;\r\n\r\n{ property Read TopMargin: Extended }\r\n\r\nprocedure TQRPage_Read_TopMargin(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TQRPage(Args.Obj).TopMargin;\r\nend;\r\n\r\n{ property Write TopMargin(Value: Extended) }\r\n\r\nprocedure TQRPage_Write_TopMargin(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TQRPage(Args.Obj).TopMargin := Value;\r\nend;\r\n\r\n{ property Read Width: Extended }\r\n\r\nprocedure TQRPage_Read_Width(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TQRPage(Args.Obj).Width;\r\nend;\r\n\r\n{ property Write Width(Value: Extended) }\r\n\r\nprocedure TQRPage_Write_Width(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TQRPage(Args.Obj).Width := Value;\r\nend;\r\n\r\n{ TQRBasePanel }\r\n\r\n{ constructor Create(AOwner: TComponent) }\r\n\r\nprocedure TQRBasePanel_Create(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TQRBasePanel.Create(V2O(Args.Values[0]) as TComponent));\r\nend;\r\n\r\n{ property Read Zoom: Integer }\r\n\r\nprocedure TQRBasePanel_Read_Zoom(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TQRBasePanel(Args.Obj).Zoom;\r\nend;\r\n\r\n{ property Write Zoom(Value: Integer) }\r\n\r\nprocedure TQRBasePanel_Write_Zoom(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TQRBasePanel(Args.Obj).Zoom := Value;\r\nend;\r\n\r\n{ property Read FontSize: Integer }\r\n\r\nprocedure TQRBasePanel_Read_FontSize(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TQRBasePanel(Args.Obj).FontSize;\r\nend;\r\n\r\n{ property Write FontSize(Value: Integer) }\r\n\r\nprocedure TQRBasePanel_Write_FontSize(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TQRBasePanel(Args.Obj).FontSize := Value;\r\nend;\r\n\r\n{ property Read Frame: TQRFrame }\r\n\r\nprocedure TQRBasePanel_Read_Frame(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TQRBasePanel(Args.Obj).Frame);\r\nend;\r\n\r\n{ property Write Frame(Value: TQRFrame) }\r\n\r\nprocedure TQRBasePanel_Write_Frame(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TQRBasePanel(Args.Obj).Frame := V2O(Value) as TQRFrame;\r\nend;\r\n\r\n{ TQRCustomBand }\r\n\r\n{ constructor Create(AOwner: TComponent) }\r\n\r\nprocedure TQRCustomBand_Create(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TQRCustomBand.Create(V2O(Args.Values[0]) as TComponent));\r\nend;\r\n\r\n{ function AddPrintable(PrintableClass: TQRNewComponentClass): TQRPrintable; }\r\n\r\nprocedure TQRCustomBand_AddPrintable(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TQRCustomBand(Args.Obj).AddPrintable(TQRNewComponentClass(V2C(Args.Values[0]))));\r\nend;\r\n\r\n{ function CanExpand(Value: Extended): Boolean; }\r\n\r\nprocedure TQRCustomBand_CanExpand(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TQRCustomBand(Args.Obj).CanExpand(Args.Values[0]);\r\nend;\r\n\r\n{ function ExpandBand(Value: Extended; var NewTop, OfsX: Extended): Boolean; }\r\n\r\nprocedure TQRCustomBand_ExpandBand(var Value: Variant; Args: TJvInterpreterArgs);\r\nvar\r\n NewTop: Extended;\r\n param2: Boolean;\r\nbegin\r\n NewTop := Args.Values[1];\r\n param2 := Args.Values[2];\r\n Value := TQRCustomBand(Args.Obj).ExpandBand(Args.Values[0], NewTop, param2);\r\n Args.Values[1] := NewTop;\r\n Args.Values[2] := param2;\r\nend;\r\n\r\n{ property Read BandType: TQRBandType }\r\n\r\nprocedure TQRCustomBand_Read_BandType(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TQRCustomBand(Args.Obj).BandType;\r\nend;\r\n\r\n{ property Write BandType(Value: TQRBandType) }\r\n\r\nprocedure TQRCustomBand_Write_BandType(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TQRCustomBand(Args.Obj).BandType := Value;\r\nend;\r\n\r\n{ property Read ChildBand: TQRChildBand }\r\n\r\nprocedure TQRCustomBand_Read_ChildBand(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TQRCustomBand(Args.Obj).ChildBand);\r\nend;\r\n\r\n{ property Read ParentReport: TQuickRep }\r\n\r\nprocedure TQRCustomBand_Read_ParentReport(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TQRCustomBand(Args.Obj).ParentReport);\r\nend;\r\n\r\n{ property Write ParentReport(Value: TQuickRep) }\r\n\r\nprocedure TQRCustomBand_Write_ParentReport(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TQRCustomBand(Args.Obj).ParentReport := V2O(Value) as TQuickRep;\r\nend;\r\n\r\n{ property Read LinkBand: TQRCustomBand }\r\n\r\nprocedure TQRCustomBand_Read_LinkBand(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TQRCustomBand(Args.Obj).LinkBand);\r\nend;\r\n\r\n{ property Write LinkBand(Value: TQRCustomBand) }\r\n\r\nprocedure TQRCustomBand_Write_LinkBand(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TQRCustomBand(Args.Obj).LinkBand := V2O(Value) as TQRCustomBand;\r\nend;\r\n\r\n{ property Read AlignToBottom: Boolean }\r\n\r\nprocedure TQRCustomBand_Read_AlignToBottom(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TQRCustomBand(Args.Obj).AlignToBottom;\r\nend;\r\n\r\n{ property Write AlignToBottom(Value: Boolean) }\r\n\r\nprocedure TQRCustomBand_Write_AlignToBottom(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TQRCustomBand(Args.Obj).AlignToBottom := Value;\r\nend;\r\n\r\n{ property Read Enabled: Boolean }\r\n\r\nprocedure TQRCustomBand_Read_Enabled(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TQRCustomBand(Args.Obj).Enabled;\r\nend;\r\n\r\n{ property Write Enabled(Value: Boolean) }\r\n\r\nprocedure TQRCustomBand_Write_Enabled(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TQRCustomBand(Args.Obj).Enabled := Value;\r\nend;\r\n\r\n{ property Read ForceNewColumn: Boolean }\r\n\r\nprocedure TQRCustomBand_Read_ForceNewColumn(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TQRCustomBand(Args.Obj).ForceNewColumn;\r\nend;\r\n\r\n{ property Write ForceNewColumn(Value: Boolean) }\r\n\r\nprocedure TQRCustomBand_Write_ForceNewColumn(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TQRCustomBand(Args.Obj).ForceNewColumn := Value;\r\nend;\r\n\r\n{ property Read ForceNewPage: Boolean }\r\n\r\nprocedure TQRCustomBand_Read_ForceNewPage(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TQRCustomBand(Args.Obj).ForceNewPage;\r\nend;\r\n\r\n{ property Write ForceNewPage(Value: Boolean) }\r\n\r\nprocedure TQRCustomBand_Write_ForceNewPage(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TQRCustomBand(Args.Obj).ForceNewPage := Value;\r\nend;\r\n\r\n{ property Read HasChild: Boolean }\r\n\r\nprocedure TQRCustomBand_Read_HasChild(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TQRCustomBand(Args.Obj).HasChild;\r\nend;\r\n\r\n{ property Write HasChild(Value: Boolean) }\r\n\r\nprocedure TQRCustomBand_Write_HasChild(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TQRCustomBand(Args.Obj).HasChild := Value;\r\nend;\r\n\r\n{ property Read Size: TQRBandSize }\r\n\r\nprocedure TQRCustomBand_Read_Size(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TQRCustomBand(Args.Obj).Size);\r\nend;\r\n\r\n{ property Write Size(Value: TQRBandSize) }\r\n\r\nprocedure TQRCustomBand_Write_Size(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TQRCustomBand(Args.Obj).Size := V2O(Value) as TQRBandSize;\r\nend;\r\n\r\n{ TQRBand }\r\n\r\n{ TQRChildBand }\r\n\r\n{ constructor Create(AOwner: TComponent) }\r\n\r\nprocedure TQRChildBand_Create(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TQRChildBand.Create(V2O(Args.Values[0]) as TComponent));\r\nend;\r\n\r\n{ property Read ParentBand: TQRCustomBand }\r\n\r\nprocedure TQRChildBand_Read_ParentBand(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TQRChildBand(Args.Obj).ParentBand);\r\nend;\r\n\r\n{ property Write ParentBand(Value: TQRCustomBand) }\r\n\r\nprocedure TQRChildBand_Write_ParentBand(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TQRChildBand(Args.Obj).ParentBand := V2O(Value) as TQRCustomBand;\r\nend;\r\n\r\n{ TQRControllerBand }\r\n\r\n{ constructor Create(AOwner: TComponent) }\r\n\r\nprocedure TQRControllerBand_Create(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TQRControllerBand.Create(V2O(Args.Values[0]) as TComponent));\r\nend;\r\n\r\n{ property Read PrintIfEmpty: Boolean }\r\n\r\nprocedure TQRControllerBand_Read_PrintIfEmpty(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TQRControllerBand(Args.Obj).PrintIfEmpty;\r\nend;\r\n\r\n{ property Write PrintIfEmpty(Value: Boolean) }\r\n\r\nprocedure TQRControllerBand_Write_PrintIfEmpty(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TQRControllerBand(Args.Obj).PrintIfEmpty := Value;\r\nend;\r\n\r\n{ property Read Master: TComponent }\r\n\r\nprocedure TQRControllerBand_Read_Master(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TQRControllerBand(Args.Obj).Master);\r\nend;\r\n\r\n{ property Write Master(Value: TComponent) }\r\n\r\nprocedure TQRControllerBand_Write_Master(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TQRControllerBand(Args.Obj).Master := V2O(Value) as TComponent;\r\nend;\r\n\r\n{ TQRSubDetailGroupBands }\r\n\r\n{ constructor Create(AOwner: TQRSubDetail) }\r\n\r\nprocedure TQRSubDetailGroupBands_Create(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TQRSubDetailGroupBands.Create(V2O(Args.Values[0]) as TQRSubDetail));\r\nend;\r\n\r\n{ property Read FooterBand: TQRCustomBand }\r\n\r\nprocedure TQRSubDetailGroupBands_Read_FooterBand(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TQRSubDetailGroupBands(Args.Obj).FooterBand);\r\nend;\r\n\r\n{ property Read HeaderBand: TQRCustomBand }\r\n\r\nprocedure TQRSubDetailGroupBands_Read_HeaderBand(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TQRSubDetailGroupBands(Args.Obj).HeaderBand);\r\nend;\r\n\r\n{ property Read HasFooter: Boolean }\r\n\r\nprocedure TQRSubDetailGroupBands_Read_HasFooter(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TQRSubDetailGroupBands(Args.Obj).HasFooter;\r\nend;\r\n\r\n{ property Write HasFooter(Value: Boolean) }\r\n\r\nprocedure TQRSubDetailGroupBands_Write_HasFooter(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TQRSubDetailGroupBands(Args.Obj).HasFooter := Value;\r\nend;\r\n\r\n{ property Read HasHeader: Boolean }\r\n\r\nprocedure TQRSubDetailGroupBands_Read_HasHeader(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TQRSubDetailGroupBands(Args.Obj).HasHeader;\r\nend;\r\n\r\n{ property Write HasHeader(Value: Boolean) }\r\n\r\nprocedure TQRSubDetailGroupBands_Write_HasHeader(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TQRSubDetailGroupBands(Args.Obj).HasHeader := Value;\r\nend;\r\n\r\n{ TQRSubDetail }\r\n\r\n{ constructor Create(AOwner: TComponent) }\r\n\r\nprocedure TQRSubDetail_Create(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TQRSubDetail.Create(V2O(Args.Values[0]) as TComponent));\r\nend;\r\n\r\n{ procedure AddNotifyClient(Value: TQRPrintable); }\r\n\r\nprocedure TQRSubDetail_AddNotifyClient(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TQRSubDetail(Args.Obj).AddNotifyClient(V2O(Args.Values[0]) as TQRPrintable);\r\nend;\r\n\r\n{ property Read Bands: TQRSubDetailGroupBands }\r\n\r\nprocedure TQRSubDetail_Read_Bands(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TQRSubDetail(Args.Obj).Bands);\r\nend;\r\n\r\n{ property Write Bands(Value: TQRSubDetailGroupBands) }\r\n\r\nprocedure TQRSubDetail_Write_Bands(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TQRSubDetail(Args.Obj).Bands := V2O(Value) as TQRSubDetailGroupBands;\r\nend;\r\n\r\n{ property Read DataSet: TDataSet }\r\n\r\nprocedure TQRSubDetail_Read_DataSet(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TQRSubDetail(Args.Obj).DataSet);\r\nend;\r\n\r\n{ property Write DataSet(Value: TDataSet) }\r\n\r\nprocedure TQRSubDetail_Write_DataSet(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TQRSubDetail(Args.Obj).DataSet := V2O(Value) as TDataSet;\r\nend;\r\n\r\n{ property Read FooterBand: TQRCustomBand }\r\n\r\nprocedure TQRSubDetail_Read_FooterBand(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TQRSubDetail(Args.Obj).FooterBand);\r\nend;\r\n\r\n{ property Write FooterBand(Value: TQRCustomBand) }\r\n\r\nprocedure TQRSubDetail_Write_FooterBand(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TQRSubDetail(Args.Obj).FooterBand := V2O(Value) as TQRCustomBand;\r\nend;\r\n\r\n{ property Read HeaderBand: TQRCustomBand }\r\n\r\nprocedure TQRSubDetail_Read_HeaderBand(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TQRSubDetail(Args.Obj).HeaderBand);\r\nend;\r\n\r\n{ property Write HeaderBand(Value: TQRCustomBand) }\r\n\r\nprocedure TQRSubDetail_Write_HeaderBand(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TQRSubDetail(Args.Obj).HeaderBand := V2O(Value) as TQRCustomBand;\r\nend;\r\n\r\n{ property Read PrintBefore: Boolean }\r\n\r\nprocedure TQRSubDetail_Read_PrintBefore(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TQRSubDetail(Args.Obj).PrintBefore;\r\nend;\r\n\r\n{ property Write PrintBefore(Value: Boolean) }\r\n\r\nprocedure TQRSubDetail_Write_PrintBefore(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TQRSubDetail(Args.Obj).PrintBefore := Value;\r\nend;\r\n\r\n{ TQuickRepBands }\r\n\r\n{ constructor Create(AOwner: TQuickRep) }\r\n\r\nprocedure TQuickRepBands_Create(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TQuickRepBands.Create(V2O(Args.Values[0]) as TQuickRep));\r\nend;\r\n\r\n{ property Read TitleBand: TQRCustomBand }\r\n\r\nprocedure TQuickRepBands_Read_TitleBand(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TQuickRepBands(Args.Obj).TitleBand);\r\nend;\r\n\r\n{ property Read PageHeaderBand: TQRCustomBand }\r\n\r\nprocedure TQuickRepBands_Read_PageHeaderBand(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TQuickRepBands(Args.Obj).PageHeaderBand);\r\nend;\r\n\r\n{ property Read ColumnHeaderBand: TQRCustomBand }\r\n\r\nprocedure TQuickRepBands_Read_ColumnHeaderBand(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TQuickRepBands(Args.Obj).ColumnHeaderBand);\r\nend;\r\n\r\n{ property Read DetailBand: TQRCustomBand }\r\n\r\nprocedure TQuickRepBands_Read_DetailBand(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TQuickRepBands(Args.Obj).DetailBand);\r\nend;\r\n\r\n{ property Read ColumnFooterBand: TQRCustomBand }\r\n\r\nprocedure TQuickRepBands_Read_ColumnFooterBand(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TQuickRepBands(Args.Obj).ColumnFooterBand);\r\nend;\r\n\r\n{ property Read PageFooterBand: TQRCustomBand }\r\n\r\nprocedure TQuickRepBands_Read_PageFooterBand(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TQuickRepBands(Args.Obj).PageFooterBand);\r\nend;\r\n\r\n{ property Read SummaryBand: TQRCustomBand }\r\n\r\nprocedure TQuickRepBands_Read_SummaryBand(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TQuickRepBands(Args.Obj).SummaryBand);\r\nend;\r\n\r\n{ property Read HasTitle: Boolean }\r\n\r\nprocedure TQuickRepBands_Read_HasTitle(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TQuickRepBands(Args.Obj).HasTitle;\r\nend;\r\n\r\n{ property Write HasTitle(Value: Boolean) }\r\n\r\nprocedure TQuickRepBands_Write_HasTitle(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TQuickRepBands(Args.Obj).HasTitle := Value;\r\nend;\r\n\r\n{ property Read HasPageHeader: Boolean }\r\n\r\nprocedure TQuickRepBands_Read_HasPageHeader(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TQuickRepBands(Args.Obj).HasPageHeader;\r\nend;\r\n\r\n{ property Write HasPageHeader(Value: Boolean) }\r\n\r\nprocedure TQuickRepBands_Write_HasPageHeader(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TQuickRepBands(Args.Obj).HasPageHeader := Value;\r\nend;\r\n\r\n{ property Read HasColumnHeader: Boolean }\r\n\r\nprocedure TQuickRepBands_Read_HasColumnHeader(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TQuickRepBands(Args.Obj).HasColumnHeader;\r\nend;\r\n\r\n{ property Write HasColumnHeader(Value: Boolean) }\r\n\r\nprocedure TQuickRepBands_Write_HasColumnHeader(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TQuickRepBands(Args.Obj).HasColumnHeader := Value;\r\nend;\r\n\r\n{ property Read HasDetail: Boolean }\r\n\r\nprocedure TQuickRepBands_Read_HasDetail(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TQuickRepBands(Args.Obj).HasDetail;\r\nend;\r\n\r\n{ property Write HasDetail(Value: Boolean) }\r\n\r\nprocedure TQuickRepBands_Write_HasDetail(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TQuickRepBands(Args.Obj).HasDetail := Value;\r\nend;\r\n\r\n{ property Read HasPageFooter: Boolean }\r\n\r\nprocedure TQuickRepBands_Read_HasPageFooter(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TQuickRepBands(Args.Obj).HasPageFooter;\r\nend;\r\n\r\n{ property Write HasPageFooter(Value: Boolean) }\r\n\r\nprocedure TQuickRepBands_Write_HasPageFooter(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TQuickRepBands(Args.Obj).HasPageFooter := Value;\r\nend;\r\n\r\n{ property Read HasSummary: Boolean }\r\n\r\nprocedure TQuickRepBands_Read_HasSummary(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TQuickRepBands(Args.Obj).HasSummary;\r\nend;\r\n\r\n{ property Write HasSummary(Value: Boolean) }\r\n\r\nprocedure TQuickRepBands_Write_HasSummary(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TQuickRepBands(Args.Obj).HasSummary := Value;\r\nend;\r\n\r\n{ TQuickRepPrinterSettings }\r\n\r\n{ TQuickRep }\r\n\r\n{ constructor Create(AOwner: TComponent) }\r\n\r\nprocedure TQuickRep_Create(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TQuickRep.Create(V2O(Args.Values[0]) as TComponent));\r\nend;\r\n\r\n{ constructor CreateNew(AOwner: TComponent) }\r\n\r\nprocedure TQuickRep_CreateNew(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TQuickRep.CreateNew(V2O(Args.Values[0]) as TComponent));\r\nend;\r\n\r\n{ function CreateBand(BandType: TQRBandType): TQRBand; }\r\n\r\nprocedure TQuickRep_CreateBand(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TQuickRep(Args.Obj).CreateBand(Args.Values[0]));\r\nend;\r\n\r\n{ function TextHeight(aFont: TFont; aText: string): Integer; }\r\n\r\nprocedure TQuickRep_TextHeight(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TQuickRep(Args.Obj).TextHeight(V2O(Args.Values[0]) as TFont, Args.Values[1]);\r\nend;\r\n\r\n{ function TextWidth(aFont: TFont; aText: string): Integer; }\r\n\r\nprocedure TQuickRep_TextWidth(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TQuickRep(Args.Obj).TextWidth(V2O(Args.Values[0]) as TFont, Args.Values[1]);\r\nend;\r\n\r\n{ procedure AddBand(aBand: TQRCustomBand); }\r\n\r\nprocedure TQuickRep_AddBand(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TQuickRep(Args.Obj).AddBand(V2O(Args.Values[0]) as TQRCustomBand);\r\nend;\r\n\r\n{ procedure AddNotifyClient(Value: TQRPrintable); }\r\n\r\nprocedure TQuickRep_AddNotifyClient(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TQuickRep(Args.Obj).AddNotifyClient(V2O(Args.Values[0]) as TQRPrintable);\r\nend;\r\n\r\n(*\r\n{ procedure ExportToFilter(AFilter: TQRExportFilter); }\r\nprocedure TQuickRep_ExportToFilter(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TQuickRep(Args.Obj).ExportToFilter(Args.Values[0]);\r\nend;\r\n*)\r\n\r\n{ procedure EndPage; }\r\n\r\nprocedure TQuickRep_EndPage(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TQuickRep(Args.Obj).EndPage;\r\nend;\r\n\r\n{ procedure NewColumn; }\r\n\r\nprocedure TQuickRep_NewColumn(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TQuickRep(Args.Obj).NewColumn;\r\nend;\r\n\r\n{ procedure NewPage; }\r\n\r\nprocedure TQuickRep_NewPage(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TQuickRep(Args.Obj).NewPage;\r\nend;\r\n\r\n{ procedure Paint; }\r\n\r\nprocedure TQuickRep_Paint(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TQuickRep(Args.Obj).Paint;\r\nend;\r\n\r\n{ procedure Print; }\r\n\r\nprocedure TQuickRep_Print(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TQuickRep(Args.Obj).Print;\r\nend;\r\n\r\n{ procedure PrintBackground; }\r\n\r\nprocedure TQuickRep_PrintBackground(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TQuickRep(Args.Obj).PrintBackground;\r\nend;\r\n\r\n{ procedure PrinterSetup; }\r\n\r\nprocedure TQuickRep_PrinterSetup(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TQuickRep(Args.Obj).PrinterSetup;\r\nend;\r\n\r\n{ procedure Prepare; }\r\n\r\nprocedure TQuickRep_Prepare(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TQuickRep(Args.Obj).Prepare;\r\nend;\r\n\r\n{ procedure Preview; }\r\n\r\nprocedure TQuickRep_Preview(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TQuickRep(Args.Obj).Preview;\r\nend;\r\n\r\n{ procedure ResetPageFooterSize; }\r\n\r\nprocedure TQuickRep_ResetPageFooterSize(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TQuickRep(Args.Obj).ResetPageFooterSize;\r\nend;\r\n\r\n{ procedure RemoveBand(aBand: TQRCustomBand); }\r\n\r\nprocedure TQuickRep_RemoveBand(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TQuickRep(Args.Obj).RemoveBand(V2O(Args.Values[0]) as TQRCustomBand);\r\nend;\r\n\r\n{ procedure SetBandValues; }\r\n\r\nprocedure TQuickRep_SetBandValues(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TQuickRep(Args.Obj).SetBandValues;\r\nend;\r\n\r\n{ procedure SetBounds(ALeft, ATop, AWidth, AHeight: Integer); }\r\n\r\nprocedure TQuickRep_SetBounds(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TQuickRep(Args.Obj).SetBounds(Args.Values[0], Args.Values[1], Args.Values[2], Args.Values[3]);\r\nend;\r\n\r\n{ property Read AllDataSets: TList }\r\n\r\nprocedure TQuickRep_Read_AllDataSets(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TQuickRep(Args.Obj).AllDataSets);\r\nend;\r\n\r\n{ property Write AllDataSets(Value: TList) }\r\n\r\nprocedure TQuickRep_Write_AllDataSets(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TQuickRep(Args.Obj).AllDataSets := V2O(Value) as TList;\r\nend;\r\n\r\n{ property Read Available: Boolean }\r\n\r\nprocedure TQuickRep_Read_Available(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TQuickRep(Args.Obj).Available;\r\nend;\r\n\r\n{ property Read BandList: TList }\r\n\r\nprocedure TQuickRep_Read_BandList(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TQuickRep(Args.Obj).BandList);\r\nend;\r\n\r\n{ property Read ColumnTopPosition: Integer }\r\n\r\nprocedure TQuickRep_Read_ColumnTopPosition(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TQuickRep(Args.Obj).ColumnTopPosition;\r\nend;\r\n\r\n{ property Write ColumnTopPosition(Value: Integer) }\r\n\r\nprocedure TQuickRep_Write_ColumnTopPosition(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TQuickRep(Args.Obj).ColumnTopPosition := Value;\r\nend;\r\n\r\n{ property Read CurrentColumn: Integer }\r\n\r\nprocedure TQuickRep_Read_CurrentColumn(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TQuickRep(Args.Obj).CurrentColumn;\r\nend;\r\n\r\n{ property Read CurrentX: Integer }\r\n\r\nprocedure TQuickRep_Read_CurrentX(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TQuickRep(Args.Obj).CurrentX;\r\nend;\r\n\r\n{ property Write CurrentX(Value: Integer) }\r\n\r\nprocedure TQuickRep_Write_CurrentX(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TQuickRep(Args.Obj).CurrentX := Value;\r\nend;\r\n\r\n{ property Read CurrentY: Integer }\r\n\r\nprocedure TQuickRep_Read_CurrentY(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TQuickRep(Args.Obj).CurrentY;\r\nend;\r\n\r\n{ property Write CurrentY(Value: Integer) }\r\n\r\nprocedure TQuickRep_Write_CurrentY(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TQuickRep(Args.Obj).CurrentY := Value;\r\nend;\r\n\r\n(*\r\n{ property Read ExportFilter: TQRExportFilter }\r\nprocedure TQuickRep_Read_ExportFilter(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TQuickRep(Args.Obj).ExportFilter;\r\nend;\r\n\r\n{ property Write ExportFilter(Value: TQRExportFilter) }\r\nprocedure TQuickRep_Write_ExportFilter(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TQuickRep(Args.Obj).ExportFilter := Value;\r\nend;\r\n*)\r\n\r\n{ property Read Exporting: Boolean }\r\n\r\nprocedure TQuickRep_Read_Exporting(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TQuickRep(Args.Obj).Exporting;\r\nend;\r\n\r\n{ property Read FinalPass: Boolean }\r\n\r\nprocedure TQuickRep_Read_FinalPass(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TQuickRep(Args.Obj).FinalPass;\r\nend;\r\n\r\n{ property Read HideBands: Boolean }\r\n\r\nprocedure TQuickRep_Read_HideBands(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TQuickRep(Args.Obj).HideBands;\r\nend;\r\n\r\n{ property Write HideBands(Value: Boolean) }\r\n\r\nprocedure TQuickRep_Write_HideBands(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TQuickRep(Args.Obj).HideBands := Value;\r\nend;\r\n\r\n{ property Read PageNumber: Integer }\r\n\r\nprocedure TQuickRep_Read_PageNumber(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TQuickRep(Args.Obj).PageNumber;\r\nend;\r\n\r\n{ property Read Printer: TQRPrinter }\r\n\r\nprocedure TQuickRep_Read_Printer(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TQuickRep(Args.Obj).Printer);\r\nend;\r\n\r\n{ property Read QRPrinter: TQRPrinter }\r\n\r\nprocedure TQuickRep_Read_QRPrinter(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TQuickRep(Args.Obj).QRPrinter);\r\nend;\r\n\r\n{ property Write QRPrinter(Value: TQRPrinter) }\r\n\r\nprocedure TQuickRep_Write_QRPrinter(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TQuickRep(Args.Obj).QRPrinter := V2O(Value) as TQRPrinter;\r\nend;\r\n\r\n{ property Read RotateBands: Integer }\r\n\r\nprocedure TQuickRep_Read_RotateBands(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TQuickRep(Args.Obj).RotateBands;\r\nend;\r\n\r\n{ property Write RotateBands(Value: Integer) }\r\n\r\nprocedure TQuickRep_Write_RotateBands(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TQuickRep(Args.Obj).RotateBands := Value;\r\nend;\r\n\r\n{ property Read State: TQRState }\r\n\r\nprocedure TQuickRep_Read_State(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TQuickRep(Args.Obj).State;\r\nend;\r\n\r\n{ property Write State(Value: TQRState) }\r\n\r\nprocedure TQuickRep_Write_State(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TQuickRep(Args.Obj).State := Value;\r\nend;\r\n\r\n{ property Read Bands: TQuickRepBands }\r\n\r\nprocedure TQuickRep_Read_Bands(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TQuickRep(Args.Obj).Bands);\r\nend;\r\n\r\n{ property Write Bands(Value: TQuickRepBands) }\r\n\r\nprocedure TQuickRep_Write_Bands(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TQuickRep(Args.Obj).Bands := V2O(Value) as TQuickRepBands;\r\nend;\r\n\r\n{ property Read DataSet: TDataSet }\r\n\r\nprocedure TQuickRep_Read_DataSet(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TQuickRep(Args.Obj).DataSet);\r\nend;\r\n\r\n{ property Write DataSet(Value: TDataSet) }\r\n\r\nprocedure TQuickRep_Write_DataSet(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TQuickRep(Args.Obj).DataSet := V2O(Value) as TDataSet;\r\nend;\r\n\r\n{ property Read Description: TStrings }\r\n\r\nprocedure TQuickRep_Read_Description(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TQuickRep(Args.Obj).Description);\r\nend;\r\n\r\n{ property Write Description(Value: TStrings) }\r\n\r\nprocedure TQuickRep_Write_Description(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TQuickRep(Args.Obj).Description := V2O(Value) as TStrings;\r\nend;\r\n\r\n{ property Read Options: TQuickReportOptions }\r\n\r\nprocedure TQuickRep_Read_Options(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := S2V(Byte(TQuickRep(Args.Obj).Options));\r\nend;\r\n\r\n{ property Write Options(Value: TQuickReportOptions) }\r\n\r\nprocedure TQuickRep_Write_Options(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TQuickRep(Args.Obj).Options := TQuickReportOptions(Byte(V2S(Value)));\r\nend;\r\n\r\n{ property Read Page: TQRPage }\r\n\r\nprocedure TQuickRep_Read_Page(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TQuickRep(Args.Obj).Page);\r\nend;\r\n\r\n{ property Write Page(Value: TQRPage) }\r\n\r\nprocedure TQuickRep_Write_Page(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TQuickRep(Args.Obj).Page := V2O(Value) as TQRPage;\r\nend;\r\n\r\n{ property Read PrintIfEmpty: Boolean }\r\n\r\nprocedure TQuickRep_Read_PrintIfEmpty(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TQuickRep(Args.Obj).PrintIfEmpty;\r\nend;\r\n\r\n{ property Write PrintIfEmpty(Value: Boolean) }\r\n\r\nprocedure TQuickRep_Write_PrintIfEmpty(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TQuickRep(Args.Obj).PrintIfEmpty := Value;\r\nend;\r\n\r\n{ property Read PrinterSettings: TQuickRepPrinterSettings }\r\n\r\nprocedure TQuickRep_Read_PrinterSettings(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TQuickRep(Args.Obj).PrinterSettings);\r\nend;\r\n\r\n{ property Write PrinterSettings(Value: TQuickRepPrinterSettings) }\r\n\r\nprocedure TQuickRep_Write_PrinterSettings(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TQuickRep(Args.Obj).PrinterSettings := V2O(Value) as TQuickRepPrinterSettings;\r\nend;\r\n\r\n{ property Read ReportTitle: string }\r\n\r\nprocedure TQuickRep_Read_ReportTitle(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TQuickRep(Args.Obj).ReportTitle;\r\nend;\r\n\r\n{ property Write ReportTitle(Value: string) }\r\n\r\nprocedure TQuickRep_Write_ReportTitle(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TQuickRep(Args.Obj).ReportTitle := Value;\r\nend;\r\n\r\n{ property Read ShowProgress: Boolean }\r\n\r\nprocedure TQuickRep_Read_ShowProgress(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TQuickRep(Args.Obj).ShowProgress;\r\nend;\r\n\r\n{ property Write ShowProgress(Value: Boolean) }\r\n\r\nprocedure TQuickRep_Write_ShowProgress(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TQuickRep(Args.Obj).ShowProgress := Value;\r\nend;\r\n\r\n{ property Read SnapToGrid: Boolean }\r\n\r\nprocedure TQuickRep_Read_SnapToGrid(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TQuickRep(Args.Obj).SnapToGrid;\r\nend;\r\n\r\n{ property Write SnapToGrid(Value: Boolean) }\r\n\r\nprocedure TQuickRep_Write_SnapToGrid(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TQuickRep(Args.Obj).SnapToGrid := Value;\r\nend;\r\n\r\n{ property Read Units: TQRUnit }\r\n\r\nprocedure TQuickRep_Read_Units(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TQuickRep(Args.Obj).Units;\r\nend;\r\n\r\n{ property Write Units(Value: TQRUnit) }\r\n\r\nprocedure TQuickRep_Write_Units(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TQuickRep(Args.Obj).Units := Value;\r\nend;\r\n\r\n{ TQRGroup }\r\n\r\n{ constructor Create(AOwner: TComponent) }\r\n\r\nprocedure TQRGroup_Create(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TQRGroup.Create(V2O(Args.Values[0]) as TComponent));\r\nend;\r\n\r\n{ property Read Expression: string }\r\n\r\nprocedure TQRGroup_Read_Expression(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TQRGroup(Args.Obj).Expression;\r\nend;\r\n\r\n{ property Write Expression(Value: string) }\r\n\r\nprocedure TQRGroup_Write_Expression(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TQRGroup(Args.Obj).Expression := Value;\r\nend;\r\n\r\n{ property Read FooterBand: TQRBand }\r\n\r\nprocedure TQRGroup_Read_FooterBand(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TQRGroup(Args.Obj).FooterBand);\r\nend;\r\n\r\n{ property Write FooterBand(Value: TQRBand) }\r\n\r\nprocedure TQRGroup_Write_FooterBand(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TQRGroup(Args.Obj).FooterBand := V2O(Value) as TQRBand;\r\nend;\r\n\r\n{ property Read Master: TComponent }\r\n\r\nprocedure TQRGroup_Read_Master(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TQRGroup(Args.Obj).Master);\r\nend;\r\n\r\n{ property Write Master(Value: TComponent) }\r\n\r\nprocedure TQRGroup_Write_Master(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TQRGroup(Args.Obj).Master := V2O(Value) as TComponent;\r\nend;\r\n\r\n{ TQRPrintableSize }\r\n\r\n{ constructor Create(AParent: TQRPrintable) }\r\n\r\nprocedure TQRPrintableSize_Create(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TQRPrintableSize.Create(V2O(Args.Values[0]) as TQRPrintable));\r\nend;\r\n\r\n{ property Read Height: Extended }\r\n\r\nprocedure TQRPrintableSize_Read_Height(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TQRPrintableSize(Args.Obj).Height;\r\nend;\r\n\r\n{ property Write Height(Value: Extended) }\r\n\r\nprocedure TQRPrintableSize_Write_Height(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TQRPrintableSize(Args.Obj).Height := Value;\r\nend;\r\n\r\n{ property Read Left: Extended }\r\n\r\nprocedure TQRPrintableSize_Read_Left(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TQRPrintableSize(Args.Obj).Left;\r\nend;\r\n\r\n{ property Write Left(Value: Extended) }\r\n\r\nprocedure TQRPrintableSize_Write_Left(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TQRPrintableSize(Args.Obj).Left := Value;\r\nend;\r\n\r\n{ property Read Top: Extended }\r\n\r\nprocedure TQRPrintableSize_Read_Top(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TQRPrintableSize(Args.Obj).Top;\r\nend;\r\n\r\n{ property Write Top(Value: Extended) }\r\n\r\nprocedure TQRPrintableSize_Write_Top(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TQRPrintableSize(Args.Obj).Top := Value;\r\nend;\r\n\r\n{ property Read Width: Extended }\r\n\r\nprocedure TQRPrintableSize_Read_Width(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TQRPrintableSize(Args.Obj).Width;\r\nend;\r\n\r\n{ property Write Width(Value: Extended) }\r\n\r\nprocedure TQRPrintableSize_Write_Width(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TQRPrintableSize(Args.Obj).Width := Value;\r\nend;\r\n\r\n{ TQRPrintable }\r\n\r\n{ constructor Create(AOwner: TComponent) }\r\n\r\nprocedure TQRPrintable_Create(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TQRPrintable.Create(V2O(Args.Values[0]) as TComponent));\r\nend;\r\n\r\n{ property Read ParentReport: TQuickRep }\r\n\r\nprocedure TQRPrintable_Read_ParentReport(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TQRPrintable(Args.Obj).ParentReport);\r\nend;\r\n\r\n{ property Write ParentReport(Value: TQuickRep) }\r\n\r\nprocedure TQRPrintable_Write_ParentReport(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TQRPrintable(Args.Obj).ParentReport := V2O(Value) as TQuickRep;\r\nend;\r\n\r\n{ property Read Zoom: Integer }\r\n\r\nprocedure TQRPrintable_Read_Zoom(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TQRPrintable(Args.Obj).Zoom;\r\nend;\r\n\r\n{ property Write Zoom(Value: Integer) }\r\n\r\nprocedure TQRPrintable_Write_Zoom(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TQRPrintable(Args.Obj).Zoom := Value;\r\nend;\r\n\r\n{ property Read Frame: TQRFrame }\r\n\r\nprocedure TQRPrintable_Read_Frame(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TQRPrintable(Args.Obj).Frame);\r\nend;\r\n\r\n{ property Write Frame(Value: TQRFrame) }\r\n\r\nprocedure TQRPrintable_Write_Frame(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TQRPrintable(Args.Obj).Frame := V2O(Value) as TQRFrame;\r\nend;\r\n\r\n{ property Read Size: TQRPrintableSize }\r\n\r\nprocedure TQRPrintable_Read_Size(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TQRPrintable(Args.Obj).Size);\r\nend;\r\n\r\n{ property Write Size(Value: TQRPrintableSize) }\r\n\r\nprocedure TQRPrintable_Write_Size(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TQRPrintable(Args.Obj).Size := V2O(Value) as TQRPrintableSize;\r\nend;\r\n\r\n{ TQRCompositeReport }\r\n\r\n{ constructor Create(AOwner: TComponent) }\r\n\r\nprocedure TQRCompositeReport_Create(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TQRCompositeReport.Create(V2O(Args.Values[0]) as TComponent));\r\nend;\r\n\r\n{ procedure Prepare; }\r\n\r\nprocedure TQRCompositeReport_Prepare(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TQRCompositeReport(Args.Obj).Prepare;\r\nend;\r\n\r\n{ procedure Preview; }\r\n\r\nprocedure TQRCompositeReport_Preview(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TQRCompositeReport(Args.Obj).Preview;\r\nend;\r\n\r\n{ procedure Print; }\r\n\r\nprocedure TQRCompositeReport_Print(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TQRCompositeReport(Args.Obj).Print;\r\nend;\r\n\r\n{ property Read Reports: TList }\r\n\r\nprocedure TQRCompositeReport_Read_Reports(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TQRCompositeReport(Args.Obj).Reports);\r\nend;\r\n\r\n{ property Write Reports(Value: TList) }\r\n\r\nprocedure TQRCompositeReport_Write_Reports(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TQRCompositeReport(Args.Obj).Reports := V2O(Value) as TList;\r\nend;\r\n\r\n{ property Read Options: TQuickReportOptions }\r\n\r\nprocedure TQRCompositeReport_Read_Options(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := S2V(Byte(TQRCompositeReport(Args.Obj).Options));\r\nend;\r\n\r\n{ property Write Options(Value: TQuickReportOptions) }\r\n\r\nprocedure TQRCompositeReport_Write_Options(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TQRCompositeReport(Args.Obj).Options := TQuickReportOptions(Byte(Value));\r\nend;\r\n\r\n{ property Read PrinterSettings: TQuickRepPrinterSettings }\r\n\r\nprocedure TQRCompositeReport_Read_PrinterSettings(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TQRCompositeReport(Args.Obj).PrinterSettings);\r\nend;\r\n\r\n{ property Write PrinterSettings(Value: TQuickRepPrinterSettings) }\r\n\r\nprocedure TQRCompositeReport_Write_PrinterSettings(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TQRCompositeReport(Args.Obj).PrinterSettings := V2O(Value) as TQRCompositePrinterSettings;\r\nend;\r\n\r\n{ property Read ReportTitle: string }\r\n\r\nprocedure TQRCompositeReport_Read_ReportTitle(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TQRCompositeReport(Args.Obj).ReportTitle;\r\nend;\r\n\r\n{ property Write ReportTitle(Value: string) }\r\n\r\nprocedure TQRCompositeReport_Write_ReportTitle(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TQRCompositeReport(Args.Obj).ReportTitle := Value;\r\nend;\r\n\r\ntype\r\n { TQROnNeedDataEvent = procedure (Sender : TObject; var MoreData : Boolean) of object;\r\n TQRNotifyOperationEvent = procedure (Sender : TObject; Operation : TQRNotifyOperation) of object;\r\n TQRBandBeforePrintEvent = procedure (Sender : TQRCustomBand; var PrintBand : Boolean) of object;\r\n TQRBandAfterPrintEvent = procedure (Sender : TQRCustomBand; BandPrinted : Boolean) of object;\r\n TQRNotifyEvent = procedure (Sender : TQuickRep) of object;\r\n TQRReportBeforePrintEvent = procedure (Sender : TQuickRep; var PrintReport : Boolean) of object;\r\n TQRFilterEvent = procedure (var PrintRecord : Boolean) of object; }\r\n\r\n TJvInterpreterQuickrptEvent = class(TJvInterpreterEvent)\r\n private\r\n procedure QROnNeedDataEvent(Sender: TObject; var MoreData: Boolean);\r\n procedure QRNotifyOperationEvent(Sender: TObject; Operation: TQRNotifyOperation);\r\n procedure QRBandBeforePrintEvent(Sender: TQRCustomBand; var PrintBand: Boolean);\r\n procedure QRBandAfterPrintEvent(Sender: TQRCustomBand; BandPrinted: Boolean);\r\n procedure QRNotifyEvent(Sender: TQuickRep);\r\n procedure QRReportBeforePrintEvent(Sender: TQuickRep; var PrintReport: Boolean);\r\n procedure QRFilterEvent(var PrintRecord: Boolean);\r\n end;\r\n\r\nprocedure TJvInterpreterQuickrptEvent.QROnNeedDataEvent(Sender: TObject; var MoreData: Boolean);\r\nbegin\r\n CallFunction(nil, [O2V(Sender), MoreData]);\r\n MoreData := Args.Values[1];\r\nend;\r\n\r\nprocedure TJvInterpreterQuickrptEvent.QRNotifyOperationEvent(Sender: TObject; Operation: TQRNotifyOperation);\r\nbegin\r\n CallFunction(nil, [O2V(Sender), Operation]);\r\nend;\r\n\r\nprocedure TJvInterpreterQuickrptEvent.QRBandBeforePrintEvent(Sender: TQRCustomBand; var PrintBand: Boolean);\r\nbegin\r\n CallFunction(nil, [O2V(Sender), PrintBand]);\r\n PrintBand := Args.Values[1];\r\nend;\r\n\r\nprocedure TJvInterpreterQuickrptEvent.QRBandAfterPrintEvent(Sender: TQRCustomBand; BandPrinted: Boolean);\r\nbegin\r\n CallFunction(nil, [O2V(Sender), BandPrinted]);\r\nend;\r\n\r\nprocedure TJvInterpreterQuickrptEvent.QRNotifyEvent(Sender: TQuickRep);\r\nbegin\r\n CallFunction(nil, [O2V(Sender)]);\r\nend;\r\n\r\nprocedure TJvInterpreterQuickrptEvent.QRReportBeforePrintEvent(Sender: TQuickRep; var PrintReport: Boolean);\r\nbegin\r\n CallFunction(nil, [O2V(Sender), PrintReport]);\r\n PrintReport := Args.Values[1];\r\nend;\r\n\r\nprocedure TJvInterpreterQuickrptEvent.QRFilterEvent(var PrintRecord: Boolean);\r\nbegin\r\n CallFunction(nil, [PrintRecord]);\r\n PrintRecord := Args.Values[0];\r\nend;\r\n\r\n{ Delphi 3, 4 and CBuilder 3 }\r\n\r\nprocedure RegisterJvInterpreterAdapter(JvInterpreterAdapter: TJvInterpreterAdapter);\r\nconst\r\n cQuickrpt = 'Quickrpt';\r\nbegin\r\n with JvInterpreterAdapter do\r\n begin\r\n { TQRNotifyOperation }\r\n AddConst(cQuickrpt, 'qrMasterDataAdvance', Ord(qrMasterDataAdvance));\r\n AddConst(cQuickrpt, 'qrBandPrinted', Ord(qrBandPrinted));\r\n AddConst(cQuickrpt, 'qrBandSizeChange', Ord(qrBandSizeChange));\r\n { TQRController }\r\n AddClass(cQuickrpt, TQRController, 'TQRController');\r\n AddGet(TQRController, 'Create', TQRController_Create, 1, [varEmpty], varEmpty);\r\n AddGet(TQRController, 'AddNotifyClient', TQRController_AddNotifyClient, 1, [varEmpty], varEmpty);\r\n AddGet(TQRController, 'DataSet', TQRController_Read_DataSet, 0, [varEmpty], varEmpty);\r\n AddSet(TQRController, 'DataSet', TQRController_Write_DataSet, 0, [varEmpty]);\r\n AddGet(TQRController, 'DetailNumber', TQRController_Read_DetailNumber, 0, [varEmpty], varEmpty);\r\n AddGet(TQRController, 'Detail', TQRController_Read_Detail, 0, [varEmpty], varEmpty);\r\n AddSet(TQRController, 'Detail', TQRController_Write_Detail, 0, [varEmpty]);\r\n AddGet(TQRController, 'Footer', TQRController_Read_Footer, 0, [varEmpty], varEmpty);\r\n AddSet(TQRController, 'Footer', TQRController_Write_Footer, 0, [varEmpty]);\r\n AddGet(TQRController, 'Header', TQRController_Read_Header, 0, [varEmpty], varEmpty);\r\n AddSet(TQRController, 'Header', TQRController_Write_Header, 0, [varEmpty]);\r\n AddGet(TQRController, 'Master', TQRController_Read_Master, 0, [varEmpty], varEmpty);\r\n AddSet(TQRController, 'Master', TQRController_Write_Master, 0, [varEmpty]);\r\n AddGet(TQRController, 'ParentReport', TQRController_Read_ParentReport, 0, [varEmpty], varEmpty);\r\n AddSet(TQRController, 'ParentReport', TQRController_Write_ParentReport, 0, [varEmpty]);\r\n AddGet(TQRController, 'PrintBefore', TQRController_Read_PrintBefore, 0, [varEmpty], varEmpty);\r\n AddSet(TQRController, 'PrintBefore', TQRController_Write_PrintBefore, 0, [varEmpty]);\r\n AddGet(TQRController, 'PrintIfEmpty', TQRController_Read_PrintIfEmpty, 0, [varEmpty], varEmpty);\r\n AddSet(TQRController, 'PrintIfEmpty', TQRController_Write_PrintIfEmpty, 0, [varEmpty]);\r\n AddGet(TQRController, 'SelfCheck', TQRController_Read_SelfCheck, 0, [varEmpty], varEmpty);\r\n AddSet(TQRController, 'SelfCheck', TQRController_Write_SelfCheck, 0, [varEmpty]);\r\n { TQRFrame }\r\n AddClass(cQuickrpt, TQRFrame, 'TQRFrame');\r\n AddGet(TQRFrame, 'Create', TQRFrame_Create, 0, [varEmpty], varEmpty);\r\n AddGet(TQRFrame, 'AnyFrame', TQRFrame_AnyFrame, 0, [varEmpty], varEmpty);\r\n AddGet(TQRFrame, 'Parent', TQRFrame_Read_Parent, 0, [varEmpty], varEmpty);\r\n AddSet(TQRFrame, 'Parent', TQRFrame_Write_Parent, 0, [varEmpty]);\r\n AddGet(TQRFrame, 'Color', TQRFrame_Read_Color, 0, [varEmpty], varEmpty);\r\n AddSet(TQRFrame, 'Color', TQRFrame_Write_Color, 0, [varEmpty]);\r\n AddGet(TQRFrame, 'DrawTop', TQRFrame_Read_DrawTop, 0, [varEmpty], varEmpty);\r\n AddSet(TQRFrame, 'DrawTop', TQRFrame_Write_DrawTop, 0, [varEmpty]);\r\n AddGet(TQRFrame, 'DrawBottom', TQRFrame_Read_DrawBottom, 0, [varEmpty], varEmpty);\r\n AddSet(TQRFrame, 'DrawBottom', TQRFrame_Write_DrawBottom, 0, [varEmpty]);\r\n AddGet(TQRFrame, 'DrawLeft', TQRFrame_Read_DrawLeft, 0, [varEmpty], varEmpty);\r\n AddSet(TQRFrame, 'DrawLeft', TQRFrame_Write_DrawLeft, 0, [varEmpty]);\r\n AddGet(TQRFrame, 'DrawRight', TQRFrame_Read_DrawRight, 0, [varEmpty], varEmpty);\r\n AddSet(TQRFrame, 'DrawRight', TQRFrame_Write_DrawRight, 0, [varEmpty]);\r\n AddGet(TQRFrame, 'Style', TQRFrame_Read_Style, 0, [varEmpty], varEmpty);\r\n AddSet(TQRFrame, 'Style', TQRFrame_Write_Style, 0, [varEmpty]);\r\n AddGet(TQRFrame, 'Width', TQRFrame_Read_Width, 0, [varEmpty], varEmpty);\r\n AddSet(TQRFrame, 'Width', TQRFrame_Write_Width, 0, [varEmpty]);\r\n { TQRUnit }\r\n AddConst(cQuickrpt, 'MM', Ord(MM));\r\n AddConst(cQuickrpt, 'Inches', Ord(Inches));\r\n AddConst(cQuickrpt, 'Pixels', Ord(Pixels));\r\n AddConst(cQuickrpt, 'Characters', Ord(Characters));\r\n AddConst(cQuickrpt, 'Native', Ord(Native));\r\n { TQRUnitBase }\r\n AddClass(cQuickrpt, TQRUnitBase, 'TQRUnitBase');\r\n AddGet(TQRUnitBase, 'Create', TQRUnitBase_Create, 0, [varEmpty], varEmpty);\r\n AddGet(TQRUnitBase, 'ParentReport', TQRUnitBase_Read_ParentReport, 0, [varEmpty], varEmpty);\r\n AddSet(TQRUnitBase, 'ParentReport', TQRUnitBase_Write_ParentReport, 0, [varEmpty]);\r\n AddGet(TQRUnitBase, 'ParentUpdating', TQRUnitBase_Read_ParentUpdating, 0, [varEmpty], varEmpty);\r\n AddSet(TQRUnitBase, 'ParentUpdating', TQRUnitBase_Write_ParentUpdating, 0, [varEmpty]);\r\n AddGet(TQRUnitBase, 'Resolution', TQRUnitBase_Read_Resolution, 0, [varEmpty], varEmpty);\r\n AddGet(TQRUnitBase, 'Units', TQRUnitBase_Read_Units, 0, [varEmpty], varEmpty);\r\n AddSet(TQRUnitBase, 'Units', TQRUnitBase_Write_Units, 0, [varEmpty]);\r\n AddGet(TQRUnitBase, 'Zoom', TQRUnitBase_Read_Zoom, 0, [varEmpty], varEmpty);\r\n AddSet(TQRUnitBase, 'Zoom', TQRUnitBase_Write_Zoom, 0, [varEmpty]);\r\n { TQRBandSize }\r\n AddClass(cQuickrpt, TQRBandSize, 'TQRBandSize');\r\n AddGet(TQRBandSize, 'Create', TQRBandSize_Create, 1, [varEmpty], varEmpty);\r\n AddGet(TQRBandSize, 'Length', TQRBandSize_Read_Length, 0, [varEmpty], varEmpty);\r\n AddSet(TQRBandSize, 'Length', TQRBandSize_Write_Length, 0, [varEmpty]);\r\n AddGet(TQRBandSize, 'Height', TQRBandSize_Read_Height, 0, [varEmpty], varEmpty);\r\n AddSet(TQRBandSize, 'Height', TQRBandSize_Write_Height, 0, [varEmpty]);\r\n AddGet(TQRBandSize, 'Width', TQRBandSize_Read_Width, 0, [varEmpty], varEmpty);\r\n AddSet(TQRBandSize, 'Width', TQRBandSize_Write_Width, 0, [varEmpty]);\r\n { TQRPage }\r\n AddClass(cQuickrpt, TQRPage, 'TQRPage');\r\n AddGet(TQRPage, 'Create', TQRPage_Create, 1, [varEmpty], varEmpty);\r\n AddGet(TQRPage, 'BottomMargin', TQRPage_Read_BottomMargin, 0, [varEmpty], varEmpty);\r\n AddSet(TQRPage, 'BottomMargin', TQRPage_Write_BottomMargin, 0, [varEmpty]);\r\n AddGet(TQRPage, 'ColumnSpace', TQRPage_Read_ColumnSpace, 0, [varEmpty], varEmpty);\r\n AddSet(TQRPage, 'ColumnSpace', TQRPage_Write_ColumnSpace, 0, [varEmpty]);\r\n AddGet(TQRPage, 'Columns', TQRPage_Read_Columns, 0, [varEmpty], varEmpty);\r\n AddSet(TQRPage, 'Columns', TQRPage_Write_Columns, 0, [varEmpty]);\r\n AddGet(TQRPage, 'LeftMargin', TQRPage_Read_LeftMargin, 0, [varEmpty], varEmpty);\r\n AddSet(TQRPage, 'LeftMargin', TQRPage_Write_LeftMargin, 0, [varEmpty]);\r\n AddGet(TQRPage, 'Length', TQRPage_Read_Length, 0, [varEmpty], varEmpty);\r\n AddSet(TQRPage, 'Length', TQRPage_Write_Length, 0, [varEmpty]);\r\n AddGet(TQRPage, 'Orientation', TQRPage_Read_Orientation, 0, [varEmpty], varEmpty);\r\n AddSet(TQRPage, 'Orientation', TQRPage_Write_Orientation, 0, [varEmpty]);\r\n AddGet(TQRPage, 'PaperSize', TQRPage_Read_PaperSize, 0, [varEmpty], varEmpty);\r\n AddSet(TQRPage, 'PaperSize', TQRPage_Write_PaperSize, 0, [varEmpty]);\r\n AddGet(TQRPage, 'RightMargin', TQRPage_Read_RightMargin, 0, [varEmpty], varEmpty);\r\n AddSet(TQRPage, 'RightMargin', TQRPage_Write_RightMargin, 0, [varEmpty]);\r\n AddGet(TQRPage, 'Ruler', TQRPage_Read_Ruler, 0, [varEmpty], varEmpty);\r\n AddSet(TQRPage, 'Ruler', TQRPage_Write_Ruler, 0, [varEmpty]);\r\n AddGet(TQRPage, 'TopMargin', TQRPage_Read_TopMargin, 0, [varEmpty], varEmpty);\r\n AddSet(TQRPage, 'TopMargin', TQRPage_Write_TopMargin, 0, [varEmpty]);\r\n AddGet(TQRPage, 'Width', TQRPage_Read_Width, 0, [varEmpty], varEmpty);\r\n AddSet(TQRPage, 'Width', TQRPage_Write_Width, 0, [varEmpty]);\r\n { TQRBasePanel }\r\n AddClass(cQuickrpt, TQRBasePanel, 'TQRBasePanel');\r\n AddGet(TQRBasePanel, 'Create', TQRBasePanel_Create, 1, [varEmpty], varEmpty);\r\n AddGet(TQRBasePanel, 'Zoom', TQRBasePanel_Read_Zoom, 0, [varEmpty], varEmpty);\r\n AddSet(TQRBasePanel, 'Zoom', TQRBasePanel_Write_Zoom, 0, [varEmpty]);\r\n AddGet(TQRBasePanel, 'FontSize', TQRBasePanel_Read_FontSize, 0, [varEmpty], varEmpty);\r\n AddSet(TQRBasePanel, 'FontSize', TQRBasePanel_Write_FontSize, 0, [varEmpty]);\r\n AddGet(TQRBasePanel, 'Frame', TQRBasePanel_Read_Frame, 0, [varEmpty], varEmpty);\r\n AddSet(TQRBasePanel, 'Frame', TQRBasePanel_Write_Frame, 0, [varEmpty]);\r\n { TQRCustomBand }\r\n AddClass(cQuickrpt, TQRCustomBand, 'TQRCustomBand');\r\n AddGet(TQRCustomBand, 'Create', TQRCustomBand_Create, 1, [varEmpty], varEmpty);\r\n AddGet(TQRCustomBand, 'AddPrintable', TQRCustomBand_AddPrintable, 1, [varEmpty], varEmpty);\r\n AddGet(TQRCustomBand, 'CanExpand', TQRCustomBand_CanExpand, 1, [varEmpty], varEmpty);\r\n AddGet(TQRCustomBand, 'ExpandBand', TQRCustomBand_ExpandBand, 3, [varEmpty, varByRef, varByRef], varEmpty);\r\n AddGet(TQRCustomBand, 'BandType', TQRCustomBand_Read_BandType, 0, [varEmpty], varEmpty);\r\n AddSet(TQRCustomBand, 'BandType', TQRCustomBand_Write_BandType, 0, [varEmpty]);\r\n AddGet(TQRCustomBand, 'ChildBand', TQRCustomBand_Read_ChildBand, 0, [varEmpty], varEmpty);\r\n AddGet(TQRCustomBand, 'ParentReport', TQRCustomBand_Read_ParentReport, 0, [varEmpty], varEmpty);\r\n AddSet(TQRCustomBand, 'ParentReport', TQRCustomBand_Write_ParentReport, 0, [varEmpty]);\r\n AddGet(TQRCustomBand, 'LinkBand', TQRCustomBand_Read_LinkBand, 0, [varEmpty], varEmpty);\r\n AddSet(TQRCustomBand, 'LinkBand', TQRCustomBand_Write_LinkBand, 0, [varEmpty]);\r\n AddGet(TQRCustomBand, 'AlignToBottom', TQRCustomBand_Read_AlignToBottom, 0, [varEmpty], varEmpty);\r\n AddSet(TQRCustomBand, 'AlignToBottom', TQRCustomBand_Write_AlignToBottom, 0, [varEmpty]);\r\n AddGet(TQRCustomBand, 'Enabled', TQRCustomBand_Read_Enabled, 0, [varEmpty], varEmpty);\r\n AddSet(TQRCustomBand, 'Enabled', TQRCustomBand_Write_Enabled, 0, [varEmpty]);\r\n AddGet(TQRCustomBand, 'ForceNewColumn', TQRCustomBand_Read_ForceNewColumn, 0, [varEmpty], varEmpty);\r\n AddSet(TQRCustomBand, 'ForceNewColumn', TQRCustomBand_Write_ForceNewColumn, 0, [varEmpty]);\r\n AddGet(TQRCustomBand, 'ForceNewPage', TQRCustomBand_Read_ForceNewPage, 0, [varEmpty], varEmpty);\r\n AddSet(TQRCustomBand, 'ForceNewPage', TQRCustomBand_Write_ForceNewPage, 0, [varEmpty]);\r\n AddGet(TQRCustomBand, 'HasChild', TQRCustomBand_Read_HasChild, 0, [varEmpty], varEmpty);\r\n AddSet(TQRCustomBand, 'HasChild', TQRCustomBand_Write_HasChild, 0, [varEmpty]);\r\n AddGet(TQRCustomBand, 'Size', TQRCustomBand_Read_Size, 0, [varEmpty], varEmpty);\r\n AddSet(TQRCustomBand, 'Size', TQRCustomBand_Write_Size, 0, [varEmpty]);\r\n { TQRBand }\r\n AddClass(cQuickrpt, TQRBand, 'TQRBand');\r\n { TQRChildBand }\r\n AddClass(cQuickrpt, TQRChildBand, 'TQRChildBand');\r\n AddGet(TQRChildBand, 'Create', TQRChildBand_Create, 1, [varEmpty], varEmpty);\r\n AddGet(TQRChildBand, 'ParentBand', TQRChildBand_Read_ParentBand, 0, [varEmpty], varEmpty);\r\n AddSet(TQRChildBand, 'ParentBand', TQRChildBand_Write_ParentBand, 0, [varEmpty]);\r\n { TQRControllerBand }\r\n AddClass(cQuickrpt, TQRControllerBand, 'TQRControllerBand');\r\n AddGet(TQRControllerBand, 'Create', TQRControllerBand_Create, 1, [varEmpty], varEmpty);\r\n AddGet(TQRControllerBand, 'PrintIfEmpty', TQRControllerBand_Read_PrintIfEmpty, 0, [varEmpty], varEmpty);\r\n AddSet(TQRControllerBand, 'PrintIfEmpty', TQRControllerBand_Write_PrintIfEmpty, 0, [varEmpty]);\r\n AddGet(TQRControllerBand, 'Master', TQRControllerBand_Read_Master, 0, [varEmpty], varEmpty);\r\n AddSet(TQRControllerBand, 'Master', TQRControllerBand_Write_Master, 0, [varEmpty]);\r\n { TQRSubDetailGroupBands }\r\n AddClass(cQuickrpt, TQRSubDetailGroupBands, 'TQRSubDetailGroupBands');\r\n AddGet(TQRSubDetailGroupBands, 'Create', TQRSubDetailGroupBands_Create, 1, [varEmpty], varEmpty);\r\n AddGet(TQRSubDetailGroupBands, 'FooterBand', TQRSubDetailGroupBands_Read_FooterBand, 0, [varEmpty], varEmpty);\r\n AddGet(TQRSubDetailGroupBands, 'HeaderBand', TQRSubDetailGroupBands_Read_HeaderBand, 0, [varEmpty], varEmpty);\r\n AddGet(TQRSubDetailGroupBands, 'HasFooter', TQRSubDetailGroupBands_Read_HasFooter, 0, [varEmpty], varEmpty);\r\n AddSet(TQRSubDetailGroupBands, 'HasFooter', TQRSubDetailGroupBands_Write_HasFooter, 0, [varEmpty]);\r\n AddGet(TQRSubDetailGroupBands, 'HasHeader', TQRSubDetailGroupBands_Read_HasHeader, 0, [varEmpty], varEmpty);\r\n AddSet(TQRSubDetailGroupBands, 'HasHeader', TQRSubDetailGroupBands_Write_HasHeader, 0, [varEmpty]);\r\n { TQRSubDetail }\r\n AddClass(cQuickrpt, TQRSubDetail, 'TQRSubDetail');\r\n AddGet(TQRSubDetail, 'Create', TQRSubDetail_Create, 1, [varEmpty], varEmpty);\r\n AddGet(TQRSubDetail, 'AddNotifyClient', TQRSubDetail_AddNotifyClient, 1, [varEmpty], varEmpty);\r\n AddGet(TQRSubDetail, 'Bands', TQRSubDetail_Read_Bands, 0, [varEmpty], varEmpty);\r\n AddSet(TQRSubDetail, 'Bands', TQRSubDetail_Write_Bands, 0, [varEmpty]);\r\n AddGet(TQRSubDetail, 'DataSet', TQRSubDetail_Read_DataSet, 0, [varEmpty], varEmpty);\r\n AddSet(TQRSubDetail, 'DataSet', TQRSubDetail_Write_DataSet, 0, [varEmpty]);\r\n AddGet(TQRSubDetail, 'FooterBand', TQRSubDetail_Read_FooterBand, 0, [varEmpty], varEmpty);\r\n AddSet(TQRSubDetail, 'FooterBand', TQRSubDetail_Write_FooterBand, 0, [varEmpty]);\r\n AddGet(TQRSubDetail, 'HeaderBand', TQRSubDetail_Read_HeaderBand, 0, [varEmpty], varEmpty);\r\n AddSet(TQRSubDetail, 'HeaderBand', TQRSubDetail_Write_HeaderBand, 0, [varEmpty]);\r\n AddGet(TQRSubDetail, 'PrintBefore', TQRSubDetail_Read_PrintBefore, 0, [varEmpty], varEmpty);\r\n AddSet(TQRSubDetail, 'PrintBefore', TQRSubDetail_Write_PrintBefore, 0, [varEmpty]);\r\n { TQuickRepBands }\r\n AddClass(cQuickrpt, TQuickRepBands, 'TQuickRepBands');\r\n AddGet(TQuickRepBands, 'Create', TQuickRepBands_Create, 1, [varEmpty], varEmpty);\r\n AddGet(TQuickRepBands, 'TitleBand', TQuickRepBands_Read_TitleBand, 0, [varEmpty], varEmpty);\r\n AddGet(TQuickRepBands, 'PageHeaderBand', TQuickRepBands_Read_PageHeaderBand, 0, [varEmpty], varEmpty);\r\n AddGet(TQuickRepBands, 'ColumnHeaderBand', TQuickRepBands_Read_ColumnHeaderBand, 0, [varEmpty], varEmpty);\r\n AddGet(TQuickRepBands, 'DetailBand', TQuickRepBands_Read_DetailBand, 0, [varEmpty], varEmpty);\r\n AddGet(TQuickRepBands, 'ColumnFooterBand', TQuickRepBands_Read_ColumnFooterBand, 0, [varEmpty], varEmpty);\r\n AddGet(TQuickRepBands, 'PageFooterBand', TQuickRepBands_Read_PageFooterBand, 0, [varEmpty], varEmpty);\r\n AddGet(TQuickRepBands, 'SummaryBand', TQuickRepBands_Read_SummaryBand, 0, [varEmpty], varEmpty);\r\n AddGet(TQuickRepBands, 'HasTitle', TQuickRepBands_Read_HasTitle, 0, [varEmpty], varEmpty);\r\n AddSet(TQuickRepBands, 'HasTitle', TQuickRepBands_Write_HasTitle, 0, [varEmpty]);\r\n AddGet(TQuickRepBands, 'HasPageHeader', TQuickRepBands_Read_HasPageHeader, 0, [varEmpty], varEmpty);\r\n AddSet(TQuickRepBands, 'HasPageHeader', TQuickRepBands_Write_HasPageHeader, 0, [varEmpty]);\r\n AddGet(TQuickRepBands, 'HasColumnHeader', TQuickRepBands_Read_HasColumnHeader, 0, [varEmpty], varEmpty);\r\n AddSet(TQuickRepBands, 'HasColumnHeader', TQuickRepBands_Write_HasColumnHeader, 0, [varEmpty]);\r\n AddGet(TQuickRepBands, 'HasDetail', TQuickRepBands_Read_HasDetail, 0, [varEmpty], varEmpty);\r\n AddSet(TQuickRepBands, 'HasDetail', TQuickRepBands_Write_HasDetail, 0, [varEmpty]);\r\n AddGet(TQuickRepBands, 'HasPageFooter', TQuickRepBands_Read_HasPageFooter, 0, [varEmpty], varEmpty);\r\n AddSet(TQuickRepBands, 'HasPageFooter', TQuickRepBands_Write_HasPageFooter, 0, [varEmpty]);\r\n AddGet(TQuickRepBands, 'HasSummary', TQuickRepBands_Read_HasSummary, 0, [varEmpty], varEmpty);\r\n AddSet(TQuickRepBands, 'HasSummary', TQuickRepBands_Write_HasSummary, 0, [varEmpty]);\r\n { TQRState }\r\n AddConst(cQuickrpt, 'qrAvailable', Ord(qrAvailable));\r\n AddConst(cQuickrpt, 'qrPrepare', Ord(qrPrepare));\r\n AddConst(cQuickrpt, 'qrPreview', Ord(qrPreview));\r\n AddConst(cQuickrpt, 'qrPrint', Ord(qrPrint));\r\n AddConst(cQuickrpt, 'qrEdit', Ord(qrEdit));\r\n { TQuickRepPrinterSettings }\r\n AddClass(cQuickrpt, TQuickRepPrinterSettings, 'TQuickRepPrinterSettings');\r\n { TQuickReportOption }\r\n AddConst(cQuickrpt, 'FirstPageHeader', Ord(FirstPageHeader));\r\n AddConst(cQuickrpt, 'LastPageFooter', Ord(LastPageFooter));\r\n AddConst(cQuickrpt, 'Compression', Ord(Compression));\r\n { TQuickRep }\r\n AddClass(cQuickrpt, TQuickRep, 'TQuickRep');\r\n AddGet(TQuickRep, 'Create', TQuickRep_Create, 1, [varEmpty], varEmpty);\r\n AddGet(TQuickRep, 'CreateNew', TQuickRep_CreateNew, 1, [varEmpty], varEmpty);\r\n AddGet(TQuickRep, 'CreateBand', TQuickRep_CreateBand, 1, [varEmpty], varEmpty);\r\n AddGet(TQuickRep, 'TextHeight', TQuickRep_TextHeight, 2, [varEmpty, varEmpty], varEmpty);\r\n AddGet(TQuickRep, 'TextWidth', TQuickRep_TextWidth, 2, [varEmpty, varEmpty], varEmpty);\r\n AddGet(TQuickRep, 'AddBand', TQuickRep_AddBand, 1, [varEmpty], varEmpty);\r\n AddGet(TQuickRep, 'AddNotifyClient', TQuickRep_AddNotifyClient, 1, [varEmpty], varEmpty);\r\n // AddGet(TQuickRep, 'ExportToFilter', TQuickRep_ExportToFilter, 1, [varEmpty], nil);\r\n AddGet(TQuickRep, 'EndPage', TQuickRep_EndPage, 0, [varEmpty], varEmpty);\r\n AddGet(TQuickRep, 'NewColumn', TQuickRep_NewColumn, 0, [varEmpty], varEmpty);\r\n AddGet(TQuickRep, 'NewPage', TQuickRep_NewPage, 0, [varEmpty], varEmpty);\r\n AddGet(TQuickRep, 'Paint', TQuickRep_Paint, 0, [varEmpty], varEmpty);\r\n AddGet(TQuickRep, 'Print', TQuickRep_Print, 0, [varEmpty], varEmpty);\r\n AddGet(TQuickRep, 'PrintBackground', TQuickRep_PrintBackground, 0, [varEmpty], varEmpty);\r\n AddGet(TQuickRep, 'PrinterSetup', TQuickRep_PrinterSetup, 0, [varEmpty], varEmpty);\r\n AddGet(TQuickRep, 'Prepare', TQuickRep_Prepare, 0, [varEmpty], varEmpty);\r\n AddGet(TQuickRep, 'Preview', TQuickRep_Preview, 0, [varEmpty], varEmpty);\r\n AddGet(TQuickRep, 'ResetPageFooterSize', TQuickRep_ResetPageFooterSize, 0, [varEmpty], varEmpty);\r\n AddGet(TQuickRep, 'RemoveBand', TQuickRep_RemoveBand, 1, [varEmpty], varEmpty);\r\n AddGet(TQuickRep, 'SetBandValues', TQuickRep_SetBandValues, 0, [varEmpty], varEmpty);\r\n AddGet(TQuickRep, 'SetBounds', TQuickRep_SetBounds, 4, [varEmpty, varEmpty, varEmpty, varEmpty], varEmpty);\r\n AddGet(TQuickRep, 'AllDataSets', TQuickRep_Read_AllDataSets, 0, [varEmpty], varEmpty);\r\n AddSet(TQuickRep, 'AllDataSets', TQuickRep_Write_AllDataSets, 0, [varEmpty]);\r\n AddGet(TQuickRep, 'Available', TQuickRep_Read_Available, 0, [varEmpty], varEmpty);\r\n AddGet(TQuickRep, 'BandList', TQuickRep_Read_BandList, 0, [varEmpty], varEmpty);\r\n AddGet(TQuickRep, 'ColumnTopPosition', TQuickRep_Read_ColumnTopPosition, 0, [varEmpty], varEmpty);\r\n AddSet(TQuickRep, 'ColumnTopPosition', TQuickRep_Write_ColumnTopPosition, 0, [varEmpty]);\r\n AddGet(TQuickRep, 'CurrentColumn', TQuickRep_Read_CurrentColumn, 0, [varEmpty], varEmpty);\r\n AddGet(TQuickRep, 'CurrentX', TQuickRep_Read_CurrentX, 0, [varEmpty], varEmpty);\r\n AddSet(TQuickRep, 'CurrentX', TQuickRep_Write_CurrentX, 0, [varEmpty]);\r\n AddGet(TQuickRep, 'CurrentY', TQuickRep_Read_CurrentY, 0, [varEmpty], varEmpty);\r\n AddSet(TQuickRep, 'CurrentY', TQuickRep_Write_CurrentY, 0, [varEmpty]);\r\n { AddGet(TQuickRep, 'ExportFilter', TQuickRep_Read_ExportFilter, 0, [varEmpty], nil);\r\n AddSet(TQuickRep, 'ExportFilter', TQuickRep_Write_ExportFilter, 0, [varEmpty]); }\r\n AddGet(TQuickRep, 'Exporting', TQuickRep_Read_Exporting, 0, [varEmpty], varEmpty);\r\n AddGet(TQuickRep, 'FinalPass', TQuickRep_Read_FinalPass, 0, [varEmpty], varEmpty);\r\n AddGet(TQuickRep, 'HideBands', TQuickRep_Read_HideBands, 0, [varEmpty], varEmpty);\r\n AddSet(TQuickRep, 'HideBands', TQuickRep_Write_HideBands, 0, [varEmpty]);\r\n AddGet(TQuickRep, 'PageNumber', TQuickRep_Read_PageNumber, 0, [varEmpty], varEmpty);\r\n AddGet(TQuickRep, 'Printer', TQuickRep_Read_Printer, 0, [varEmpty], varEmpty);\r\n AddGet(TQuickRep, 'QRPrinter', TQuickRep_Read_QRPrinter, 0, [varEmpty], varEmpty);\r\n AddSet(TQuickRep, 'QRPrinter', TQuickRep_Write_QRPrinter, 0, [varEmpty]);\r\n AddGet(TQuickRep, 'RotateBands', TQuickRep_Read_RotateBands, 0, [varEmpty], varEmpty);\r\n AddSet(TQuickRep, 'RotateBands', TQuickRep_Write_RotateBands, 0, [varEmpty]);\r\n AddGet(TQuickRep, 'State', TQuickRep_Read_State, 0, [varEmpty], varEmpty);\r\n AddSet(TQuickRep, 'State', TQuickRep_Write_State, 0, [varEmpty]);\r\n AddGet(TQuickRep, 'Bands', TQuickRep_Read_Bands, 0, [varEmpty], varEmpty);\r\n AddSet(TQuickRep, 'Bands', TQuickRep_Write_Bands, 0, [varEmpty]);\r\n AddGet(TQuickRep, 'DataSet', TQuickRep_Read_DataSet, 0, [varEmpty], varEmpty);\r\n AddSet(TQuickRep, 'DataSet', TQuickRep_Write_DataSet, 0, [varEmpty]);\r\n AddGet(TQuickRep, 'Description', TQuickRep_Read_Description, 0, [varEmpty], varEmpty);\r\n AddSet(TQuickRep, 'Description', TQuickRep_Write_Description, 0, [varEmpty]);\r\n AddGet(TQuickRep, 'Options', TQuickRep_Read_Options, 0, [varEmpty], varEmpty);\r\n AddSet(TQuickRep, 'Options', TQuickRep_Write_Options, 0, [varEmpty]);\r\n AddGet(TQuickRep, 'Page', TQuickRep_Read_Page, 0, [varEmpty], varEmpty);\r\n AddSet(TQuickRep, 'Page', TQuickRep_Write_Page, 0, [varEmpty]);\r\n AddGet(TQuickRep, 'PrintIfEmpty', TQuickRep_Read_PrintIfEmpty, 0, [varEmpty], varEmpty);\r\n AddSet(TQuickRep, 'PrintIfEmpty', TQuickRep_Write_PrintIfEmpty, 0, [varEmpty]);\r\n AddGet(TQuickRep, 'PrinterSettings', TQuickRep_Read_PrinterSettings, 0, [varEmpty], varEmpty);\r\n AddSet(TQuickRep, 'PrinterSettings', TQuickRep_Write_PrinterSettings, 0, [varEmpty]);\r\n AddGet(TQuickRep, 'ReportTitle', TQuickRep_Read_ReportTitle, 0, [varEmpty], varEmpty);\r\n AddSet(TQuickRep, 'ReportTitle', TQuickRep_Write_ReportTitle, 0, [varEmpty]);\r\n AddGet(TQuickRep, 'ShowProgress', TQuickRep_Read_ShowProgress, 0, [varEmpty], varEmpty);\r\n AddSet(TQuickRep, 'ShowProgress', TQuickRep_Write_ShowProgress, 0, [varEmpty]);\r\n AddGet(TQuickRep, 'SnapToGrid', TQuickRep_Read_SnapToGrid, 0, [varEmpty], varEmpty);\r\n AddSet(TQuickRep, 'SnapToGrid', TQuickRep_Write_SnapToGrid, 0, [varEmpty]);\r\n AddGet(TQuickRep, 'Units', TQuickRep_Read_Units, 0, [varEmpty], varEmpty);\r\n AddSet(TQuickRep, 'Units', TQuickRep_Write_Units, 0, [varEmpty]);\r\n { TQRGroup }\r\n AddClass(cQuickrpt, TQRGroup, 'TQRGroup');\r\n AddGet(TQRGroup, 'Create', TQRGroup_Create, 1, [varEmpty], varEmpty);\r\n AddGet(TQRGroup, 'Expression', TQRGroup_Read_Expression, 0, [varEmpty], varEmpty);\r\n AddSet(TQRGroup, 'Expression', TQRGroup_Write_Expression, 0, [varEmpty]);\r\n AddGet(TQRGroup, 'FooterBand', TQRGroup_Read_FooterBand, 0, [varEmpty], varEmpty);\r\n AddSet(TQRGroup, 'FooterBand', TQRGroup_Write_FooterBand, 0, [varEmpty]);\r\n AddGet(TQRGroup, 'Master', TQRGroup_Read_Master, 0, [varEmpty], varEmpty);\r\n AddSet(TQRGroup, 'Master', TQRGroup_Write_Master, 0, [varEmpty]);\r\n { TQRPrintableSize }\r\n AddClass(cQuickrpt, TQRPrintableSize, 'TQRPrintableSize');\r\n AddGet(TQRPrintableSize, 'Create', TQRPrintableSize_Create, 1, [varEmpty], varEmpty);\r\n AddGet(TQRPrintableSize, 'Height', TQRPrintableSize_Read_Height, 0, [varEmpty], varEmpty);\r\n AddSet(TQRPrintableSize, 'Height', TQRPrintableSize_Write_Height, 0, [varEmpty]);\r\n AddGet(TQRPrintableSize, 'Left', TQRPrintableSize_Read_Left, 0, [varEmpty], varEmpty);\r\n AddSet(TQRPrintableSize, 'Left', TQRPrintableSize_Write_Left, 0, [varEmpty]);\r\n AddGet(TQRPrintableSize, 'Top', TQRPrintableSize_Read_Top, 0, [varEmpty], varEmpty);\r\n AddSet(TQRPrintableSize, 'Top', TQRPrintableSize_Write_Top, 0, [varEmpty]);\r\n AddGet(TQRPrintableSize, 'Width', TQRPrintableSize_Read_Width, 0, [varEmpty], varEmpty);\r\n AddSet(TQRPrintableSize, 'Width', TQRPrintableSize_Write_Width, 0, [varEmpty]);\r\n { TQRPrintable }\r\n AddClass(cQuickrpt, TQRPrintable, 'TQRPrintable');\r\n AddGet(TQRPrintable, 'Create', TQRPrintable_Create, 1, [varEmpty], varEmpty);\r\n AddGet(TQRPrintable, 'ParentReport', TQRPrintable_Read_ParentReport, 0, [varEmpty], varEmpty);\r\n AddSet(TQRPrintable, 'ParentReport', TQRPrintable_Write_ParentReport, 0, [varEmpty]);\r\n AddGet(TQRPrintable, 'Zoom', TQRPrintable_Read_Zoom, 0, [varEmpty], varEmpty);\r\n AddSet(TQRPrintable, 'Zoom', TQRPrintable_Write_Zoom, 0, [varEmpty]);\r\n AddGet(TQRPrintable, 'Frame', TQRPrintable_Read_Frame, 0, [varEmpty], varEmpty);\r\n AddSet(TQRPrintable, 'Frame', TQRPrintable_Write_Frame, 0, [varEmpty]);\r\n AddGet(TQRPrintable, 'Size', TQRPrintable_Read_Size, 0, [varEmpty], varEmpty);\r\n AddSet(TQRPrintable, 'Size', TQRPrintable_Write_Size, 0, [varEmpty]);\r\n { TQRCompositeReport }\r\n AddClass(cQuickrpt, TQRCompositeReport, 'TQRCompositeReport');\r\n AddGet(TQRCompositeReport, 'Create', TQRCompositeReport_Create, 1, [varEmpty], varEmpty);\r\n AddGet(TQRCompositeReport, 'Prepare', TQRCompositeReport_Prepare, 0, [varEmpty], varEmpty);\r\n AddGet(TQRCompositeReport, 'Preview', TQRCompositeReport_Preview, 0, [varEmpty], varEmpty);\r\n AddGet(TQRCompositeReport, 'Print', TQRCompositeReport_Print, 0, [varEmpty], varEmpty);\r\n AddGet(TQRCompositeReport, 'Reports', TQRCompositeReport_Read_Reports, 0, [varEmpty], varEmpty);\r\n AddSet(TQRCompositeReport, 'Reports', TQRCompositeReport_Write_Reports, 0, [varEmpty]);\r\n AddGet(TQRCompositeReport, 'Options', TQRCompositeReport_Read_Options, 0, [varEmpty], varEmpty);\r\n AddSet(TQRCompositeReport, 'Options', TQRCompositeReport_Write_Options, 0, [varEmpty]);\r\n AddGet(TQRCompositeReport, 'PrinterSettings', TQRCompositeReport_Read_PrinterSettings, 0, [varEmpty], varEmpty);\r\n AddSet(TQRCompositeReport, 'PrinterSettings', TQRCompositeReport_Write_PrinterSettings, 0, [varEmpty]);\r\n AddGet(TQRCompositeReport, 'ReportTitle', TQRCompositeReport_Read_ReportTitle, 0, [varEmpty], varEmpty);\r\n AddSet(TQRCompositeReport, 'ReportTitle', TQRCompositeReport_Write_ReportTitle, 0, [varEmpty]);\r\n AddHandler(cQuickrpt, 'TQROnNeedDataEvent', TJvInterpreterQuickrptEvent,\r\n @TJvInterpreterQuickrptEvent.QROnNeedDataEvent);\r\n AddHandler(cQuickrpt, 'TQRNotifyOperationEvent', TJvInterpreterQuickrptEvent,\r\n @TJvInterpreterQuickrptEvent.QRNotifyOperationEvent);\r\n AddHandler(cQuickrpt, 'TQRBandBeforePrintEvent', TJvInterpreterQuickrptEvent,\r\n @TJvInterpreterQuickrptEvent.QRBandBeforePrintEvent);\r\n AddHandler(cQuickrpt, 'TQRBandAfterPrintEvent', TJvInterpreterQuickrptEvent,\r\n @TJvInterpreterQuickrptEvent.QRBandAfterPrintEvent);\r\n AddHandler(cQuickrpt, 'TQRNotifyEvent', TJvInterpreterQuickrptEvent, @TJvInterpreterQuickrptEvent.QRNotifyEvent);\r\n AddHandler(cQuickrpt, 'TQRReportBeforePrintEvent', TJvInterpreterQuickrptEvent,\r\n @TJvInterpreterQuickrptEvent.QRReportBeforePrintEvent);\r\n AddHandler(cQuickrpt, 'TQRFilterEvent', TJvInterpreterQuickrptEvent, @TJvInterpreterQuickrptEvent.QRFilterEvent);\r\n end;\r\n\r\n RegisterClasses([TQuickRep, TQRSubDetail, TQRBand, TQRChildBand, TQRGroup,\r\n TQRLabel, TQRDBText, TQRExpr, TQRSysData, TQRMemo, TQRRichText, TQRDBRichText,\r\n TQRShape, TQRImage, TQRDBImage, TQRCompositeReport, TQRPreview]);\r\nend;\r\n\r\ninitialization\r\n {$IFDEF UNITVERSIONING}\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n {$ENDIF UNITVERSIONING}\r\n JvInterpreterRunReportPreviewProc := JvInterpreterRunReportPreview;\r\n JvInterpreterRunReportPreview2Proc := JvInterpreterRunReportPreview2;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvInterpreter_StdCtrls.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvInterpreter_StdCtrls.PAS, released on 2002-07-04.\r\n\r\nThe Initial Developers of the Original Code are: Andrei Prygounkov \r\nCopyright (c) 1999, 2002 Andrei Prygounkov\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nDescription : adapter unit - converts JvInterpreter calls to delphi calls\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvInterpreter_StdCtrls.pas 12461 2009-08-14 17:21:33Z obones $\r\n\r\nunit JvInterpreter_StdCtrls;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n JvInterpreter;\r\n\r\nprocedure RegisterJvInterpreterAdapter(JvInterpreterAdapter: TJvInterpreterAdapter);\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvInterpreter_StdCtrls.pas $';\r\n Revision: '$Revision: 12461 $';\r\n Date: '$Date: 2009-08-14 19:21:33 +0200 (ven. 14 août 2009) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n Windows, Classes, Controls, StdCtrls,\r\n JvInterpreter_Windows;\r\n\r\n{ TGroupBox }\r\n\r\n{ constructor Create(AOwner: TComponent) }\r\n\r\nprocedure TGroupBox_Create(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TGroupBox.Create(V2O(Args.Values[0]) as TComponent));\r\nend;\r\n\r\n{ TCustomLabel }\r\n\r\n{ constructor Create(AOwner: TComponent) }\r\n\r\nprocedure TCustomLabel_Create(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TCustomLabel.Create(V2O(Args.Values[0]) as TComponent));\r\nend;\r\n\r\n{ property Read Canvas: TCanvas }\r\n\r\nprocedure TCustomLabel_Read_Canvas(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TCustomLabel(Args.Obj).Canvas);\r\nend;\r\n\r\n{ TLabel }\r\n\r\n{ constructor Create(AOwner: TComponent) }\r\n\r\nprocedure TLabel_Create(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TLabel.Create(V2O(Args.Values[0]) as TComponent));\r\nend;\r\n\r\n{ TCustomEdit }\r\n\r\n{ constructor Create(AOwner: TComponent) }\r\n\r\nprocedure TCustomEdit_Create(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TCustomEdit.Create(V2O(Args.Values[0]) as TComponent));\r\nend;\r\n\r\n{ procedure Clear; }\r\n\r\nprocedure TCustomEdit_Clear(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TCustomEdit(Args.Obj).Clear;\r\nend;\r\n\r\n{ procedure ClearSelection; }\r\n\r\nprocedure TCustomEdit_ClearSelection(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TCustomEdit(Args.Obj).ClearSelection;\r\nend;\r\n\r\n{ procedure CopyToClipboard; }\r\n\r\nprocedure TCustomEdit_CopyToClipboard(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TCustomEdit(Args.Obj).CopyToClipboard;\r\nend;\r\n\r\n{ procedure CutToClipboard; }\r\n\r\nprocedure TCustomEdit_CutToClipboard(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TCustomEdit(Args.Obj).CutToClipboard;\r\nend;\r\n\r\n{ procedure PasteFromClipboard; }\r\n\r\nprocedure TCustomEdit_PasteFromClipboard(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TCustomEdit(Args.Obj).PasteFromClipboard;\r\nend;\r\n\r\n{ function GetSelTextBuf(Buffer: PChar; BufSize: Integer): Integer; }\r\n\r\nprocedure TCustomEdit_GetSelTextBuf(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TCustomEdit(Args.Obj).GetSelTextBuf(PChar(string(Args.Values[0])), Args.Values[1]);\r\nend;\r\n\r\n{ procedure SelectAll; }\r\n\r\nprocedure TCustomEdit_SelectAll(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TCustomEdit(Args.Obj).SelectAll;\r\nend;\r\n\r\n{ procedure SetSelTextBuf(Buffer: PChar); }\r\n\r\nprocedure TCustomEdit_SetSelTextBuf(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TCustomEdit(Args.Obj).SetSelTextBuf(PChar(string(Args.Values[0])));\r\nend;\r\n\r\n{ property Read Modified: Boolean }\r\n\r\nprocedure TCustomEdit_Read_Modified(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TCustomEdit(Args.Obj).Modified;\r\nend;\r\n\r\n{ property Write Modified(Value: Boolean) }\r\n\r\nprocedure TCustomEdit_Write_Modified(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TCustomEdit(Args.Obj).Modified := Value;\r\nend;\r\n\r\n{ property Read SelLength: Integer }\r\n\r\nprocedure TCustomEdit_Read_SelLength(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TCustomEdit(Args.Obj).SelLength;\r\nend;\r\n\r\n{ property Write SelLength(Value: Integer) }\r\n\r\nprocedure TCustomEdit_Write_SelLength(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TCustomEdit(Args.Obj).SelLength := Value;\r\nend;\r\n\r\n{ property Read SelStart: Integer }\r\n\r\nprocedure TCustomEdit_Read_SelStart(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TCustomEdit(Args.Obj).SelStart;\r\nend;\r\n\r\n{ property Write SelStart(Value: Integer) }\r\n\r\nprocedure TCustomEdit_Write_SelStart(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TCustomEdit(Args.Obj).SelStart := Value;\r\nend;\r\n\r\n{ property Read SelText: string }\r\n\r\nprocedure TCustomEdit_Read_SelText(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TCustomEdit(Args.Obj).SelText;\r\nend;\r\n\r\n{ property Write SelText(Value: string) }\r\n\r\nprocedure TCustomEdit_Write_SelText(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TCustomEdit(Args.Obj).SelText := Value;\r\nend;\r\n\r\n{ TEdit }\r\n\r\n{ constructor Create(AOwner: TComponent) }\r\n\r\nprocedure TEdit_Create(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TEdit.Create(V2O(Args.Values[0]) as TComponent));\r\nend;\r\n\r\n{ TCustomMemo }\r\n\r\n{ constructor Create(AOwner: TComponent) }\r\n\r\nprocedure TCustomMemo_Create(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TCustomMemo.Create(V2O(Args.Values[0]) as TComponent));\r\nend;\r\n\r\n{ property Read Lines: TStrings }\r\n\r\nprocedure TCustomMemo_Read_Lines(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TCustomMemo(Args.Obj).Lines);\r\nend;\r\n\r\n{ property Write Lines(Value: TStrings) }\r\n\r\nprocedure TCustomMemo_Write_Lines(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TCustomMemo(Args.Obj).Lines := V2O(Value) as TStrings;\r\nend;\r\n\r\n{ TMemo }\r\n\r\n{ constructor Create(AOwner: TComponent) }\r\n\r\nprocedure TMemo_Create(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TMemo.Create(V2O(Args.Values[0]) as TComponent));\r\nend;\r\n\r\n{ TCustomComboBox }\r\n\r\n{ constructor Create(AOwner: TComponent) }\r\n\r\nprocedure TCustomComboBox_Create(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TCustomComboBox.Create(V2O(Args.Values[0]) as TComponent));\r\nend;\r\n\r\n{ procedure Clear; }\r\n\r\nprocedure TCustomComboBox_Clear(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TCustomComboBox(Args.Obj).Clear;\r\nend;\r\n\r\n{ procedure SelectAll; }\r\n\r\nprocedure TCustomComboBox_SelectAll(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TCustomComboBox(Args.Obj).SelectAll;\r\nend;\r\n\r\n{ property Read Canvas: TCanvas }\r\n\r\nprocedure TCustomComboBox_Read_Canvas(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TCustomComboBox(Args.Obj).Canvas);\r\nend;\r\n\r\n{ property Read DroppedDown: Boolean }\r\n\r\nprocedure TCustomComboBox_Read_DroppedDown(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TCustomComboBox(Args.Obj).DroppedDown;\r\nend;\r\n\r\n{ property Write DroppedDown(Value: Boolean) }\r\n\r\nprocedure TCustomComboBox_Write_DroppedDown(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TCustomComboBox(Args.Obj).DroppedDown := Value;\r\nend;\r\n\r\n{ property Read Items: TStrings }\r\n\r\nprocedure TCustomComboBox_Read_Items(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TCustomComboBox(Args.Obj).Items);\r\nend;\r\n\r\n{ property Write Items(Value: TStrings) }\r\n\r\nprocedure TCustomComboBox_Write_Items(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TCustomComboBox(Args.Obj).Items := V2O(Value) as TStrings;\r\nend;\r\n\r\n{ property Read ItemIndex: Integer }\r\n\r\nprocedure TCustomComboBox_Read_ItemIndex(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TCustomComboBox(Args.Obj).ItemIndex;\r\nend;\r\n\r\n{ property Write ItemIndex(Value: Integer) }\r\n\r\nprocedure TCustomComboBox_Write_ItemIndex(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TCustomComboBox(Args.Obj).ItemIndex := Value;\r\nend;\r\n\r\n{ property Read SelLength: Integer }\r\n\r\nprocedure TCustomComboBox_Read_SelLength(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TCustomComboBox(Args.Obj).SelLength;\r\nend;\r\n\r\n{ property Write SelLength(Value: Integer) }\r\n\r\nprocedure TCustomComboBox_Write_SelLength(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TCustomComboBox(Args.Obj).SelLength := Value;\r\nend;\r\n\r\n{ property Read SelStart: Integer }\r\n\r\nprocedure TCustomComboBox_Read_SelStart(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TCustomComboBox(Args.Obj).SelStart;\r\nend;\r\n\r\n{ property Write SelStart(Value: Integer) }\r\n\r\nprocedure TCustomComboBox_Write_SelStart(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TCustomComboBox(Args.Obj).SelStart := Value;\r\nend;\r\n\r\n{ property Read SelText: string }\r\n\r\nprocedure TCustomComboBox_Read_SelText(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TCustomComboBox(Args.Obj).SelText;\r\nend;\r\n\r\n{ property Write SelText(Value: string) }\r\n\r\nprocedure TCustomComboBox_Write_SelText(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TCustomComboBox(Args.Obj).SelText := Value;\r\nend;\r\n\r\n{ TComboBox }\r\n\r\n{ constructor Create(AOwner: TComponent) }\r\n\r\nprocedure TComboBox_Create(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TComboBox.Create(V2O(Args.Values[0]) as TComponent));\r\nend;\r\n\r\n{ TButton }\r\n\r\n{ constructor Create(AOwner: TComponent) }\r\n\r\nprocedure TButton_Create(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TButton.Create(V2O(Args.Values[0]) as TComponent));\r\nend;\r\n\r\n{ procedure Click; }\r\n\r\nprocedure TButton_Click(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TButton(Args.Obj).Click;\r\nend;\r\n\r\n{ TCustomCheckBox }\r\n\r\n{ constructor Create(AOwner: TComponent) }\r\n\r\nprocedure TCustomCheckBox_Create(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TCustomCheckBox.Create(V2O(Args.Values[0]) as TComponent));\r\nend;\r\n\r\n{ TCheckBox }\r\n\r\n{ constructor Create(AOwner: TComponent) }\r\n\r\nprocedure TCheckBox_Create(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TCheckBox.Create(V2O(Args.Values[0]) as TComponent));\r\nend;\r\n\r\n{ TRadioButton }\r\n\r\n{ constructor Create(AOwner: TComponent) }\r\n\r\nprocedure TRadioButton_Create(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TRadioButton.Create(V2O(Args.Values[0]) as TComponent));\r\nend;\r\n\r\n{ TCustomListBox }\r\n\r\n{ constructor Create(AOwner: TComponent) }\r\n\r\nprocedure TCustomListBox_Create(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TCustomListBox.Create(V2O(Args.Values[0]) as TComponent));\r\nend;\r\n\r\n{ procedure Clear; }\r\n\r\nprocedure TCustomListBox_Clear(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TCustomListBox(Args.Obj).Clear;\r\nend;\r\n\r\n{ function ItemAtPos(Pos: TPoint; Existing: Boolean): Integer; }\r\n\r\nprocedure TCustomListBox_ItemAtPos(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TCustomListBox(Args.Obj).ItemAtPos(Var2Point(Args.Values[0]), Args.Values[1]);\r\nend;\r\n\r\n{ function ItemRect(Index: Integer): TRect; }\r\n\r\nprocedure TCustomListBox_ItemRect(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := Rect2Var(TCustomListBox(Args.Obj).ItemRect(Args.Values[0]));\r\nend;\r\n\r\n{ property Read Canvas: TCanvas }\r\n\r\nprocedure TCustomListBox_Read_Canvas(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TCustomListBox(Args.Obj).Canvas);\r\nend;\r\n\r\n{ property Read Items: TStrings }\r\n\r\nprocedure TCustomListBox_Read_Items(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TCustomListBox(Args.Obj).Items);\r\nend;\r\n\r\n{ property Write Items(Value: TStrings) }\r\n\r\nprocedure TCustomListBox_Write_Items(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TCustomListBox(Args.Obj).Items := V2O(Value) as TStrings;\r\nend;\r\n\r\n{ property Read ItemIndex: Integer }\r\n\r\nprocedure TCustomListBox_Read_ItemIndex(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TCustomListBox(Args.Obj).ItemIndex;\r\nend;\r\n\r\n{ property Write ItemIndex(Value: Integer) }\r\n\r\nprocedure TCustomListBox_Write_ItemIndex(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TCustomListBox(Args.Obj).ItemIndex := Value;\r\nend;\r\n\r\n{ property Read SelCount: Integer }\r\n\r\nprocedure TCustomListBox_Read_SelCount(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TCustomListBox(Args.Obj).SelCount;\r\nend;\r\n\r\n{ property Read Selected[Integer]: Boolean }\r\n\r\nprocedure TCustomListBox_Read_Selected(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TCustomListBox(Args.Obj).Selected[Args.Values[0]];\r\nend;\r\n\r\n{ property Write Selected[Integer]: Boolean }\r\n\r\nprocedure TCustomListBox_Write_Selected(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TCustomListBox(Args.Obj).Selected[Args.Values[0]] := Value;\r\nend;\r\n\r\n{ property Read TopIndex: Integer }\r\n\r\nprocedure TCustomListBox_Read_TopIndex(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TCustomListBox(Args.Obj).TopIndex;\r\nend;\r\n\r\n{ property Write TopIndex(Value: Integer) }\r\n\r\nprocedure TCustomListBox_Write_TopIndex(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TCustomListBox(Args.Obj).TopIndex := Value;\r\nend;\r\n\r\n{ TListBox }\r\n\r\n{ constructor Create(AOwner: TComponent) }\r\n\r\nprocedure TListBox_Create(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TListBox.Create(V2O(Args.Values[0]) as TComponent));\r\nend;\r\n\r\n{ TScrollBar }\r\n\r\n{ constructor Create(AOwner: TComponent) }\r\n\r\nprocedure TScrollBar_Create(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TScrollBar.Create(V2O(Args.Values[0]) as TComponent));\r\nend;\r\n\r\n{ procedure SetParams(APosition, AMin, AMax: Integer); }\r\n\r\nprocedure TScrollBar_SetParams(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TScrollBar(Args.Obj).SetParams(Args.Values[0], Args.Values[1], Args.Values[2]);\r\nend;\r\n\r\n\r\n\r\n{ TCustomStaticText }\r\n\r\n{ constructor Create(AOwner: TComponent) }\r\n\r\nprocedure TCustomStaticText_Create(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TCustomStaticText.Create(V2O(Args.Values[0]) as TComponent));\r\nend;\r\n\r\n{ TStaticText }\r\n\r\n{ constructor Create(AOwner: TComponent) }\r\n\r\nprocedure TStaticText_Create(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TStaticText.Create(V2O(Args.Values[0]) as TComponent));\r\nend;\r\n\r\n\r\n\r\ntype\r\n TJvInterpreterStdCtrlsEvent = class(TJvInterpreterEvent)\r\n private\r\n procedure DrawItemEvent(Control: TWinControl; Index: Integer; Rect: TRect; State: TOwnerDrawState);\r\n procedure MeasureItemEvent(Control: TWinControl; Index: Integer; var Height: Integer);\r\n procedure ScrollEvent(Sender: TObject; ScrollCode: TScrollCode; var ScrollPos: Integer);\r\n end;\r\n\r\nprocedure TJvInterpreterStdCtrlsEvent.DrawItemEvent(Control: TWinControl; Index: Integer; Rect: TRect; State:\r\n TOwnerDrawState);\r\nbegin\r\n CallFunction(nil, [O2V(Control), Index, Rect2Var(Rect), S2V(Word(State))]);\r\nend;\r\n\r\nprocedure TJvInterpreterStdCtrlsEvent.MeasureItemEvent(Control: TWinControl; Index: Integer; var Height: Integer);\r\nbegin\r\n CallFunction(nil, [O2V(Control), Index, Height]);\r\n Height := Args.Values[1];\r\nend;\r\n\r\nprocedure TJvInterpreterStdCtrlsEvent.ScrollEvent(Sender: TObject; ScrollCode: TScrollCode; var ScrollPos: Integer);\r\nbegin\r\n CallFunction(nil, [O2V(Sender), S2V(Byte(ScrollCode)), ScrollPos]);\r\n ScrollPos := Args.Values[2];\r\nend;\r\n\r\nprocedure RegisterJvInterpreterAdapter(JvInterpreterAdapter: TJvInterpreterAdapter);\r\nconst\r\n cStdCtrls = 'StdCtrls';\r\nbegin\r\n with JvInterpreterAdapter do\r\n begin\r\n { TGroupBox }\r\n AddClass(cStdCtrls, TGroupBox, 'TGroupBox');\r\n AddGet(TGroupBox, 'Create', TGroupBox_Create, 1, [varEmpty], varEmpty);\r\n { TTextLayout }\r\n AddConst(cStdCtrls, 'tlTop', Ord(tlTop));\r\n AddConst(cStdCtrls, 'tlCenter', Ord(tlCenter));\r\n AddConst(cStdCtrls, 'tlBottom', Ord(tlBottom));\r\n { TCustomLabel }\r\n AddClass(cStdCtrls, TCustomLabel, 'TCustomLabel');\r\n AddGet(TCustomLabel, 'Create', TCustomLabel_Create, 1, [varEmpty], varEmpty);\r\n AddGet(TCustomLabel, 'Canvas', TCustomLabel_Read_Canvas, 0, [varEmpty], varEmpty);\r\n { TLabel }\r\n AddClass(cStdCtrls, TLabel, 'TLabel');\r\n AddGet(TLabel, 'Create', TLabel_Create, 1, [varEmpty], varEmpty);\r\n { TEditCharCase }\r\n AddConst(cStdCtrls, 'ecNormal', Ord(ecNormal));\r\n AddConst(cStdCtrls, 'ecUpperCase', Ord(ecUpperCase));\r\n AddConst(cStdCtrls, 'ecLowerCase', Ord(ecLowerCase));\r\n { TCustomEdit }\r\n AddClass(cStdCtrls, TCustomEdit, 'TCustomEdit');\r\n AddGet(TCustomEdit, 'Create', TCustomEdit_Create, 1, [varEmpty], varEmpty);\r\n AddGet(TCustomEdit, 'Clear', TCustomEdit_Clear, 0, [varEmpty], varEmpty);\r\n AddGet(TCustomEdit, 'ClearSelection', TCustomEdit_ClearSelection, 0, [varEmpty], varEmpty);\r\n AddGet(TCustomEdit, 'CopyToClipboard', TCustomEdit_CopyToClipboard, 0, [varEmpty], varEmpty);\r\n AddGet(TCustomEdit, 'CutToClipboard', TCustomEdit_CutToClipboard, 0, [varEmpty], varEmpty);\r\n AddGet(TCustomEdit, 'PasteFromClipboard', TCustomEdit_PasteFromClipboard, 0, [varEmpty], varEmpty);\r\n AddGet(TCustomEdit, 'GetSelTextBuf', TCustomEdit_GetSelTextBuf, 2, [varEmpty, varEmpty], varEmpty);\r\n AddGet(TCustomEdit, 'SelectAll', TCustomEdit_SelectAll, 0, [varEmpty], varEmpty);\r\n AddGet(TCustomEdit, 'SetSelTextBuf', TCustomEdit_SetSelTextBuf, 1, [varEmpty], varEmpty);\r\n AddGet(TCustomEdit, 'Modified', TCustomEdit_Read_Modified, 0, [varEmpty], varEmpty);\r\n AddSet(TCustomEdit, 'Modified', TCustomEdit_Write_Modified, 0, [varEmpty]);\r\n AddGet(TCustomEdit, 'SelLength', TCustomEdit_Read_SelLength, 0, [varEmpty], varEmpty);\r\n AddSet(TCustomEdit, 'SelLength', TCustomEdit_Write_SelLength, 0, [varEmpty]);\r\n AddGet(TCustomEdit, 'SelStart', TCustomEdit_Read_SelStart, 0, [varEmpty], varEmpty);\r\n AddSet(TCustomEdit, 'SelStart', TCustomEdit_Write_SelStart, 0, [varEmpty]);\r\n AddGet(TCustomEdit, 'SelText', TCustomEdit_Read_SelText, 0, [varEmpty], varEmpty);\r\n AddSet(TCustomEdit, 'SelText', TCustomEdit_Write_SelText, 0, [varEmpty]);\r\n { TEdit }\r\n AddClass(cStdCtrls, TEdit, 'TEdit');\r\n AddGet(TEdit, 'Create', TEdit_Create, 1, [varEmpty], varEmpty);\r\n { TScrollStyle }\r\n AddConst(cStdCtrls, 'ssNone', Ord(ssNone));\r\n AddConst(cStdCtrls, 'ssHorizontal', Ord(ssHorizontal));\r\n AddConst(cStdCtrls, 'ssVertical', Ord(ssVertical));\r\n AddConst(cStdCtrls, 'ssBoth', Ord(ssBoth));\r\n { TCustomMemo }\r\n AddClass(cStdCtrls, TCustomMemo, 'TCustomMemo');\r\n AddGet(TCustomMemo, 'Create', TCustomMemo_Create, 1, [varEmpty], varEmpty);\r\n AddGet(TCustomMemo, 'Lines', TCustomMemo_Read_Lines, 0, [varEmpty], varEmpty);\r\n AddSet(TCustomMemo, 'Lines', TCustomMemo_Write_Lines, 0, [varEmpty]);\r\n { TMemo }\r\n AddClass(cStdCtrls, TMemo, 'TMemo');\r\n AddGet(TMemo, 'Create', TMemo_Create, 1, [varEmpty], varEmpty);\r\n { TComboBoxStyle }\r\n AddConst(cStdCtrls, 'csDropDown', Ord(csDropDown));\r\n AddConst(cStdCtrls, 'csSimple', Ord(csSimple));\r\n AddConst(cStdCtrls, 'csDropDownList', Ord(csDropDownList));\r\n AddConst(cStdCtrls, 'csOwnerDrawFixed', Ord(csOwnerDrawFixed));\r\n AddConst(cStdCtrls, 'csOwnerDrawVariable', Ord(csOwnerDrawVariable));\r\n { TOwnerDrawState }\r\n AddConst(cStdCtrls, 'odSelected', Ord(odSelected));\r\n AddConst(cStdCtrls, 'odGrayed', Ord(odGrayed));\r\n AddConst(cStdCtrls, 'odDisabled', Ord(odDisabled));\r\n AddConst(cStdCtrls, 'odChecked', Ord(odChecked));\r\n AddConst(cStdCtrls, 'odFocused', Ord(odFocused));\r\n { TCustomComboBox }\r\n AddClass(cStdCtrls, TCustomComboBox, 'TCustomComboBox');\r\n AddGet(TCustomComboBox, 'Create', TCustomComboBox_Create, 1, [varEmpty], varEmpty);\r\n AddGet(TCustomComboBox, 'Clear', TCustomComboBox_Clear, 0, [varEmpty], varEmpty);\r\n AddGet(TCustomComboBox, 'SelectAll', TCustomComboBox_SelectAll, 0, [varEmpty], varEmpty);\r\n AddGet(TCustomComboBox, 'Canvas', TCustomComboBox_Read_Canvas, 0, [varEmpty], varEmpty);\r\n AddGet(TCustomComboBox, 'DroppedDown', TCustomComboBox_Read_DroppedDown, 0, [varEmpty], varEmpty);\r\n AddSet(TCustomComboBox, 'DroppedDown', TCustomComboBox_Write_DroppedDown, 0, [varEmpty]);\r\n AddGet(TCustomComboBox, 'Items', TCustomComboBox_Read_Items, 0, [varEmpty], varEmpty);\r\n AddSet(TCustomComboBox, 'Items', TCustomComboBox_Write_Items, 0, [varEmpty]);\r\n AddGet(TCustomComboBox, 'ItemIndex', TCustomComboBox_Read_ItemIndex, 0, [varEmpty], varEmpty);\r\n AddSet(TCustomComboBox, 'ItemIndex', TCustomComboBox_Write_ItemIndex, 0, [varEmpty]);\r\n AddGet(TCustomComboBox, 'SelLength', TCustomComboBox_Read_SelLength, 0, [varEmpty], varEmpty);\r\n AddSet(TCustomComboBox, 'SelLength', TCustomComboBox_Write_SelLength, 0, [varEmpty]);\r\n AddGet(TCustomComboBox, 'SelStart', TCustomComboBox_Read_SelStart, 0, [varEmpty], varEmpty);\r\n AddSet(TCustomComboBox, 'SelStart', TCustomComboBox_Write_SelStart, 0, [varEmpty]);\r\n AddGet(TCustomComboBox, 'SelText', TCustomComboBox_Read_SelText, 0, [varEmpty], varEmpty);\r\n AddSet(TCustomComboBox, 'SelText', TCustomComboBox_Write_SelText, 0, [varEmpty]);\r\n { TComboBox }\r\n AddClass(cStdCtrls, TComboBox, 'TComboBox');\r\n AddGet(TComboBox, 'Create', TComboBox_Create, 1, [varEmpty], varEmpty);\r\n { TButton }\r\n AddClass(cStdCtrls, TButton, 'TButton');\r\n AddGet(TButton, 'Create', TButton_Create, 1, [varEmpty], varEmpty);\r\n AddGet(TButton, 'Click', TButton_Click, 0, [varEmpty], varEmpty);\r\n { TCheckBoxState }\r\n AddConst(cStdCtrls, 'cbUnchecked', Ord(cbUnchecked));\r\n AddConst(cStdCtrls, 'cbChecked', Ord(cbChecked));\r\n AddConst(cStdCtrls, 'cbGrayed', Ord(cbGrayed));\r\n { TCustomCheckBox }\r\n AddClass(cStdCtrls, TCustomCheckBox, 'TCustomCheckBox');\r\n AddGet(TCustomCheckBox, 'Create', TCustomCheckBox_Create, 1, [varEmpty], varEmpty);\r\n { TCheckBox }\r\n AddClass(cStdCtrls, TCheckBox, 'TCheckBox');\r\n AddGet(TCheckBox, 'Create', TCheckBox_Create, 1, [varEmpty], varEmpty);\r\n { TRadioButton }\r\n AddClass(cStdCtrls, TRadioButton, 'TRadioButton');\r\n AddGet(TRadioButton, 'Create', TRadioButton_Create, 1, [varEmpty], varEmpty);\r\n { TListBoxStyle }\r\n AddConst(cStdCtrls, 'lbStandard', Ord(lbStandard));\r\n AddConst(cStdCtrls, 'lbOwnerDrawFixed', Ord(lbOwnerDrawFixed));\r\n AddConst(cStdCtrls, 'lbOwnerDrawVariable', Ord(lbOwnerDrawVariable));\r\n { TCustomListBox }\r\n AddClass(cStdCtrls, TCustomListBox, 'TCustomListBox');\r\n AddGet(TCustomListBox, 'Create', TCustomListBox_Create, 1, [varEmpty], varEmpty);\r\n AddGet(TCustomListBox, 'Clear', TCustomListBox_Clear, 0, [varEmpty], varEmpty);\r\n AddGet(TCustomListBox, 'ItemAtPos', TCustomListBox_ItemAtPos, 2, [varEmpty, varEmpty], varEmpty);\r\n AddGet(TCustomListBox, 'ItemRect', TCustomListBox_ItemRect, 1, [varEmpty], varEmpty);\r\n AddGet(TCustomListBox, 'Canvas', TCustomListBox_Read_Canvas, 0, [varEmpty], varEmpty);\r\n AddGet(TCustomListBox, 'Items', TCustomListBox_Read_Items, 0, [varEmpty], varEmpty);\r\n AddSet(TCustomListBox, 'Items', TCustomListBox_Write_Items, 0, [varEmpty]);\r\n AddGet(TCustomListBox, 'ItemIndex', TCustomListBox_Read_ItemIndex, 0, [varEmpty], varEmpty);\r\n AddSet(TCustomListBox, 'ItemIndex', TCustomListBox_Write_ItemIndex, 0, [varEmpty]);\r\n AddGet(TCustomListBox, 'SelCount', TCustomListBox_Read_SelCount, 0, [varEmpty], varEmpty);\r\n AddGet(TCustomListBox, 'Selected', TCustomListBox_Read_Selected, 1, [varEmpty], varEmpty);\r\n AddSet(TCustomListBox, 'Selected', TCustomListBox_Write_Selected, 1, [varNull]);\r\n AddGet(TCustomListBox, 'TopIndex', TCustomListBox_Read_TopIndex, 0, [varEmpty], varEmpty);\r\n AddSet(TCustomListBox, 'TopIndex', TCustomListBox_Write_TopIndex, 0, [varEmpty]);\r\n { TListBox }\r\n AddClass(cStdCtrls, TListBox, 'TListBox');\r\n AddGet(TListBox, 'Create', TListBox_Create, 1, [varEmpty], varEmpty);\r\n { TScrollCode }\r\n AddConst(cStdCtrls, 'scLineUp', Ord(scLineUp));\r\n AddConst(cStdCtrls, 'scLineDown', Ord(scLineDown));\r\n AddConst(cStdCtrls, 'scPageUp', Ord(scPageUp));\r\n AddConst(cStdCtrls, 'scPageDown', Ord(scPageDown));\r\n AddConst(cStdCtrls, 'scPosition', Ord(scPosition));\r\n AddConst(cStdCtrls, 'scTrack', Ord(scTrack));\r\n AddConst(cStdCtrls, 'scTop', Ord(scTop));\r\n AddConst(cStdCtrls, 'scBottom', Ord(scBottom));\r\n AddConst(cStdCtrls, 'scEndScroll', Ord(scEndScroll));\r\n { TScrollBar }\r\n AddClass(cStdCtrls, TScrollBar, 'TScrollBar');\r\n AddGet(TScrollBar, 'Create', TScrollBar_Create, 1, [varEmpty], varEmpty);\r\n AddGet(TScrollBar, 'SetParams', TScrollBar_SetParams, 3, [varEmpty, varEmpty, varEmpty], varEmpty);\r\n { TStaticBorderStyle }\r\n AddConst(cStdCtrls, 'sbsNone', Ord(sbsNone));\r\n AddConst(cStdCtrls, 'sbsSingle', Ord(sbsSingle));\r\n AddConst(cStdCtrls, 'sbsSunken', Ord(sbsSunken));\r\n { TCustomStaticText }\r\n AddClass(cStdCtrls, TCustomStaticText, 'TCustomStaticText');\r\n AddGet(TCustomStaticText, 'Create', TCustomStaticText_Create, 1, [varEmpty], varEmpty);\r\n { TStaticText }\r\n AddClass(cStdCtrls, TStaticText, 'TStaticText');\r\n AddGet(TStaticText, 'Create', TStaticText_Create, 1, [varEmpty], varEmpty);\r\n\r\n AddHandler(cStdCtrls, 'TDrawItemEvent', TJvInterpreterStdCtrlsEvent,\r\n @TJvInterpreterStdCtrlsEvent.DrawItemEvent);\r\n AddHandler(cStdCtrls, 'TMeasureItemEvent', TJvInterpreterStdCtrlsEvent,\r\n @TJvInterpreterStdCtrlsEvent.MeasureItemEvent);\r\n AddHandler(cStdCtrls, 'TScrollEvent', TJvInterpreterStdCtrlsEvent,\r\n @TJvInterpreterStdCtrlsEvent.ScrollEvent);\r\n end;\r\n RegisterClasses([TGroupBox, TCustomLabel, TLabel, TCustomEdit, TEdit,\r\n TCustomMemo, TMemo, TCustomComboBox, TComboBox, TButton, TCustomCheckBox,\r\n TCheckBox, TRadioButton, TCustomListBox, TListBox, TScrollBar,\r\n TCustomStaticText, TStaticText]);\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvInterpreter_SysUtils.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvInterpreter_SysUtils.PAS, released on 2002-07-04.\r\n\r\nThe Initial Developers of the Original Code are: Andrei Prygounkov \r\nCopyright (c) 1999, 2002 Andrei Prygounkov\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nDescription : adapter unit - converts JvInterpreter calls to delphi calls\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvInterpreter_SysUtils.pas 12833 2010-09-05 13:25:12Z obones $\r\n\r\nunit JvInterpreter_SysUtils;\r\n\r\n{$I jvcl.inc}\r\n{$I crossplatform.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n SysUtils,\r\n JvInterpreter;\r\n\r\nprocedure RegisterJvInterpreterAdapter(JvInterpreterAdapter: TJvInterpreterAdapter);\r\n\r\nfunction SearchRec2Var(const SearchRec: TSearchRec): Variant;\r\nfunction Var2SearchRec(const SearchRec: Variant): TSearchRec;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvInterpreter_SysUtils.pas $';\r\n Revision: '$Revision: 12833 $';\r\n Date: '$Date: 2010-09-05 15:25:12 +0200 (dim. 05 sept. 2010) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n Variants,\r\n {$IFDEF SUPPORTS_INLINE}\r\n Windows,\r\n {$ENDIF SUPPORTS_INLINE}\r\n JvJCLUtils;\r\n\r\n{ TSearchRec }\r\n\r\nfunction SearchRec2Var(const SearchRec: TSearchRec): Variant;\r\nvar\r\n Rec: ^TSearchRec;\r\nbegin\r\n New(Rec);\r\n Rec^ := SearchRec;\r\n Result := R2V('TSearchRec', Rec);\r\nend;\r\n\r\nfunction Var2SearchRec(const SearchRec: Variant): TSearchRec;\r\nbegin\r\n Result := TSearchRec(V2R(SearchRec)^);\r\nend;\r\n\r\n{ Exception }\r\n\r\n{ constructor Create(Msg: string) }\r\n\r\nprocedure Exception_Create(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(Exception.Create(Args.Values[0]));\r\nend;\r\n\r\n{ constructor CreateFmt(Msg: string; Args: array) }\r\n\r\nprocedure Exception_CreateFmt(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n// Value := O2V(Exception.CreateFmt(Args.Values[0], Args.Values[1]));\r\n NotImplemented('Exception.CreateFmt');\r\nend;\r\n\r\n{ constructor CreateRes(Ident: Integer) }\r\n\r\nprocedure Exception_CreateRes(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(Exception.CreateRes(Args.Values[0]));\r\nend;\r\n\r\n{ constructor CreateResFmt(Ident: Integer; Args: array) }\r\n\r\nprocedure Exception_CreateResFmt(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n// Value := O2V(Exception.CreateResFmt(Args.Values[0], Args.Values[1]));\r\n NotImplemented('Exception.CreateResFmt');\r\nend;\r\n\r\n{ constructor CreateHelp(Msg: string; AHelpContext: Integer) }\r\n\r\nprocedure Exception_CreateHelp(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(Exception.CreateHelp(Args.Values[0], Args.Values[1]));\r\nend;\r\n\r\n{ constructor CreateFmtHelp(Msg: string; Args: array; AHelpContext: Integer) }\r\n\r\nprocedure Exception_CreateFmtHelp(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n// Value := O2V(Exception.CreateFmtHelp(Args.Values[0], Args.Values[1], Args.Values[2]));\r\n NotImplemented('Exception.CreateFmtHelp');\r\nend;\r\n\r\n{ constructor CreateResHelp(Ident: Integer; AHelpContext: Integer) }\r\n\r\nprocedure Exception_CreateResHelp(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(Exception.CreateResHelp(Args.Values[0], Args.Values[1]));\r\nend;\r\n\r\n{ constructor CreateResFmtHelp(Ident: Integer; Args: array; AHelpContext: Integer) }\r\n\r\nprocedure Exception_CreateResFmtHelp(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n// Value := O2V(Exception.CreateResFmtHelp(Args.Values[0], Args.Values[1], Args.Values[2]));\r\n NotImplemented('Exception.CreateResFmtHelp');\r\nend;\r\n\r\n{ property Read HelpContext: Integer }\r\n\r\nprocedure Exception_Read_HelpContext(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := Exception(Args.Obj).HelpContext;\r\nend;\r\n\r\n{ property Write HelpContext(Value: Integer) }\r\n\r\nprocedure Exception_Write_HelpContext(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Exception(Args.Obj).HelpContext := Value;\r\nend;\r\n\r\n{ property Read Message: string }\r\n\r\nprocedure Exception_Read_Message(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := Exception(Args.Obj).Message;\r\nend;\r\n\r\n{ property Write Message(Value: string) }\r\n\r\nprocedure Exception_Write_Message(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Exception(Args.Obj).Message := Value;\r\nend;\r\n\r\n{ EAbort }\r\n\r\n{ EOutOfMemory }\r\n\r\n{ EInOutError }\r\n\r\n{ EIntError }\r\n\r\n{ EDivByZero }\r\n\r\n{ ERangeError }\r\n\r\n{ EIntOverflow }\r\n\r\n{ EMathError }\r\n\r\n{ EInvalidOp }\r\n\r\n{ EZeroDivide }\r\n\r\n{ EOverflow }\r\n\r\n{ EUnderflow }\r\n\r\n{ EInvalidPointer }\r\n\r\n{ EInvalidCast }\r\n\r\n{ EConvertError }\r\n\r\n{ EAccessViolation }\r\n\r\n{ EPrivilege }\r\n\r\n{ EStackOverflow }\r\n\r\n{ EControlC }\r\n\r\n{ EVariantError }\r\n\r\n{ EPropReadOnly }\r\n\r\n{ EPropWriteOnly }\r\n\r\n{ EExternalException }\r\n\r\n{ EAssertionFailed }\r\n\r\n{ EAbstractError }\r\n\r\n{ EIntfCastError }\r\n\r\n{ EInvalidContainer }\r\n\r\n{ EInvalidInsert }\r\n\r\n{ EPackageError }\r\n\r\n{ EWin32Error }\r\n\r\n{ function AllocMem(Size: Cardinal): Pointer; }\r\n\r\nprocedure JvInterpreter_AllocMem(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := P2V(AllocMem(Args.Values[0]));\r\nend;\r\n\r\n{ function UpperCase(const S: string): string; }\r\n\r\nprocedure JvInterpreter_UpperCase(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := UpperCase(Args.Values[0]);\r\nend;\r\n\r\n{ function LowerCase(const S: string): string; }\r\n\r\nprocedure JvInterpreter_LowerCase(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := LowerCase(Args.Values[0]);\r\nend;\r\n\r\n{ function CompareStr(const S1, S2: string): Integer; }\r\n\r\nprocedure JvInterpreter_CompareStr(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := CompareStr(Args.Values[0], Args.Values[1]);\r\nend;\r\n\r\n{ function CompareMem(P1, P2: Pointer; Length: Integer): Boolean; }\r\n\r\nprocedure JvInterpreter_CompareMem(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := CompareMem(V2P(Args.Values[0]), V2P(Args.Values[1]), Args.Values[2]);\r\nend;\r\n\r\n{ function CompareText(const S1, S2: string): Integer; }\r\n\r\nprocedure JvInterpreter_CompareText(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := CompareText(Args.Values[0], Args.Values[1]);\r\nend;\r\n{ function ExtractQuotedString(s: string; Quote: Char): string; }\r\nprocedure JvInterpreter_ExtractQuotedString(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := ExtractQuotedString(Args.Values[0], string(Args.Values[1])[1]);\r\nend;\r\n\r\n{ function AnsiUpperCase(const S: string): string; }\r\n\r\nprocedure JvInterpreter_AnsiUpperCase(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := AnsiUpperCase(Args.Values[0]);\r\nend;\r\n\r\n{ function AnsiLowerCase(const S: string): string; }\r\n\r\nprocedure JvInterpreter_AnsiLowerCase(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := AnsiLowerCase(Args.Values[0]);\r\nend;\r\n\r\n{ function AnsiCompareStr(const S1, S2: string): Integer; }\r\n\r\nprocedure JvInterpreter_AnsiCompareStr(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := AnsiCompareStr(Args.Values[0], Args.Values[1]);\r\nend;\r\n\r\n{ function AnsiCompareText(const S1, S2: string): Integer; }\r\n\r\nprocedure JvInterpreter_AnsiCompareText(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := AnsiCompareText(Args.Values[0], Args.Values[1]);\r\nend;\r\n\r\n{ function AnsiStrComp(S1, S2: PChar): Integer; }\r\n\r\nprocedure JvInterpreter_AnsiStrComp(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := AnsiStrComp(PChar(string(Args.Values[0])), PChar(string(Args.Values[1])));\r\nend;\r\n\r\n{ function AnsiStrIComp(S1, S2: PChar): Integer; }\r\n\r\nprocedure JvInterpreter_AnsiStrIComp(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := AnsiStrIComp(PChar(string(Args.Values[0])), PChar(string(Args.Values[1])));\r\nend;\r\n\r\n{ function AnsiStrLComp(S1, S2: PChar; MaxLen: Cardinal): Integer; }\r\n\r\nprocedure JvInterpreter_AnsiStrLComp(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := AnsiStrLComp(PChar(string(Args.Values[0])), PChar(string(Args.Values[1])), Args.Values[2]);\r\nend;\r\n\r\n{ function AnsiStrLIComp(S1, S2: PChar; MaxLen: Cardinal): Integer; }\r\n\r\nprocedure JvInterpreter_AnsiStrLIComp(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := AnsiStrLIComp(PChar(string(Args.Values[0])), PChar(string(Args.Values[1])), Args.Values[2]);\r\nend;\r\n\r\n{ function AnsiStrLower(Str: PChar): PChar; }\r\n\r\nprocedure JvInterpreter_AnsiStrLower(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := string(AnsiStrLower(PChar(string(Args.Values[0]))));\r\nend;\r\n\r\n{ function AnsiStrUpper(Str: PChar): PChar; }\r\n\r\nprocedure JvInterpreter_AnsiStrUpper(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := string(AnsiStrUpper(PChar(string(Args.Values[0]))));\r\nend;\r\n\r\n{ function AnsiLastChar(const S: string): PChar; }\r\n\r\nprocedure JvInterpreter_AnsiLastChar(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := string(AnsiLastChar(Args.Values[0]));\r\nend;\r\n\r\n{ function AnsiStrLastChar(P: PChar): PChar; }\r\n\r\nprocedure JvInterpreter_AnsiStrLastChar(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := string(AnsiStrLastChar(PChar(string(Args.Values[0]))));\r\nend;\r\n\r\n{ function Trim(const S: string): string; }\r\n\r\nprocedure JvInterpreter_Trim(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := Trim(Args.Values[0]);\r\nend;\r\n\r\n{ function TrimLeft(const S: string): string; }\r\n\r\nprocedure JvInterpreter_TrimLeft(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TrimLeft(Args.Values[0]);\r\nend;\r\n\r\n{ function TrimRight(const S: string): string; }\r\n\r\nprocedure JvInterpreter_TrimRight(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TrimRight(Args.Values[0]);\r\nend;\r\n\r\n{ function QuotedStr(const S: string): string; }\r\n\r\nprocedure JvInterpreter_QuotedStr(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := QuotedStr(Args.Values[0]);\r\nend;\r\n\r\n{ function AnsiQuotedStr(const S: string; Quote: Char): string; }\r\n\r\nprocedure JvInterpreter_AnsiQuotedStr(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := AnsiQuotedStr(Args.Values[0], string(Args.Values[1])[1]);\r\nend;\r\n\r\n{ function AnsiExtractQuotedStr(var Src: PChar; Quote: Char): string; }\r\n\r\nprocedure JvInterpreter_AnsiExtractQuotedStr(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := AnsiExtractQuotedStr(PChar(TVarData(Args.Values[0]).vPointer), string(Args.Values[1])[1]);\r\nend;\r\n\r\n{ function AdjustLineBreaks(const S: string): string; }\r\n\r\nprocedure JvInterpreter_AdjustLineBreaks(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := AdjustLineBreaks(Args.Values[0]);\r\nend;\r\n\r\n{ function IsValidIdent(const Ident: string): Boolean; }\r\n\r\nprocedure JvInterpreter_IsValidIdent(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := IsValidIdent(Args.Values[0]);\r\nend;\r\n\r\n{ function IntToStr(Value: Integer): string; }\r\n\r\nprocedure JvInterpreter_IntToStr(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := IntToStr(Args.Values[0]);\r\nend;\r\n\r\n{ function IntToHex(Value: Integer; Digits: Integer): string; }\r\n\r\nprocedure JvInterpreter_IntToHex(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := IntToHex(Args.Values[0], Args.Values[1]);\r\nend;\r\n\r\n{ function StrToInt(const S: string): Integer; }\r\n\r\nprocedure JvInterpreter_StrToInt(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := StrToInt(Args.Values[0]);\r\nend;\r\n\r\n{ function StrToIntDef(const S: string; Default: Integer): Integer; }\r\n\r\nprocedure JvInterpreter_StrToIntDef(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := StrToIntDef(Args.Values[0], Args.Values[1]);\r\nend;\r\n\r\n{ function LoadStr(Ident: Integer): string; }\r\n\r\nprocedure JvInterpreter_LoadStr(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := LoadStr(Args.Values[0]);\r\nend;\r\n\r\n(*\r\n{ function FmtLoadStr(Ident: Integer; const Args: array of const): string; }\r\nprocedure JvInterpreter_FmtLoadStr(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := FmtLoadStr(Args.Values[0], Args.Values[1]);\r\nend;\r\n*)\r\n\r\n{ function FileOpen(const FileName: string; Mode: Integer): Integer; }\r\n\r\nprocedure JvInterpreter_FileOpen(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := FileOpen(Args.Values[0], Args.Values[1]);\r\nend;\r\n\r\n{ function FileCreate(const FileName: string): Integer; }\r\n\r\nprocedure JvInterpreter_FileCreate(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n {$IFDEF MSWINDOWS}\r\n Value := FileCreate(Args.Values[0]);\r\n {$ENDIF MSWINDOWS}\r\n {$IFDEF UNIX}\r\n Value := FileCreate(VarToStr(Args.Values[0]));\r\n {$ENDIF UNIX}\r\nend;\r\n\r\n{ function FileRead(Handle: Integer; var Buffer; Count: Integer): Integer; }\r\n\r\nprocedure JvInterpreter_FileRead(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := FileRead(Args.Values[0], TVarData(Args.Values[1]).vInteger, Args.Values[2]);\r\nend;\r\n\r\n{ function FileWrite(Handle: Integer; const Buffer; Count: Integer): Integer; }\r\n\r\nprocedure JvInterpreter_FileWrite(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := FileWrite(Args.Values[0], Args.Values[1], Args.Values[2]);\r\nend;\r\n\r\n{ function FileSeek(Handle, Offset, Origin: Integer): Integer; }\r\n\r\nprocedure JvInterpreter_FileSeek(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := FileSeek(Args.Values[0], Args.Values[1], Args.Values[2]);\r\nend;\r\n\r\n{ procedure FileClose(Handle: Integer); }\r\n\r\nprocedure JvInterpreter_FileClose(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n FileClose(Args.Values[0]);\r\nend;\r\n\r\n{ function FileAge(const FileName: string): Integer; }\r\n\r\nprocedure JvInterpreter_FileAge(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n {$IFDEF COMPILER10_UP}\r\n {$WARN SYMBOL_DEPRECATED OFF}\r\n Value := FileAge(Args.Values[0]);\r\n {$WARN SYMBOL_DEPRECATED ON}\r\n {$ELSE}\r\n Value := FileAge(Args.Values[0]);\r\n {$ENDIF COMPILER10_UP}\r\nend;\r\n\r\n{ function FileExists(const FileName: string): Boolean; }\r\n\r\nprocedure JvInterpreter_FileExists(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := FileExists(Args.Values[0]);\r\nend;\r\n\r\n{ function FindFirst(const Path: string; Attr: Integer; var F: TSearchRec): Integer; }\r\n\r\nprocedure JvInterpreter_FindFirst(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := FindFirst(Args.Values[0], Args.Values[1], TSearchRec(V2R(Args.Values[2])^));\r\nend;\r\n\r\n{ function FindNext(var F: TSearchRec): Integer; }\r\n\r\nprocedure JvInterpreter_FindNext(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := FindNext(TSearchRec(V2R(Args.Values[0])^));\r\nend;\r\n\r\n{ procedure FindClose(var F: TSearchRec); }\r\n\r\nprocedure JvInterpreter_FindClose(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n SysUtils.FindClose(SysUtils.TSearchRec(V2R(Args.Values[0])^));\r\nend;\r\n\r\n{ function FileGetDate(Handle: Integer): Integer; }\r\n\r\nprocedure JvInterpreter_FileGetDate(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := FileGetDate(Args.Values[0]);\r\nend;\r\n\r\n{ function FileSetDate(Handle: Integer; Age: Integer): Integer; }\r\n\r\nprocedure JvInterpreter_FileSetDate(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := FileSetDate({$IFDEF RTL200_UP}VarToStr{$ENDIF RTL200_UP}(Args.Values[0]), Args.Values[1]);\r\nend;\r\n\r\n{$IFDEF MSWINDOWS}\r\n\r\n{ function FileGetAttr(const FileName: string): Integer; }\r\n\r\nprocedure JvInterpreter_FileGetAttr(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := FileGetAttr(Args.Values[0]);\r\nend;\r\n\r\n{ function FileSetAttr(const FileName: string; Attr: Integer): Integer; }\r\n\r\nprocedure JvInterpreter_FileSetAttr(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := FileSetAttr(Args.Values[0], Args.Values[1]);\r\nend;\r\n\r\n{$ENDIF MSWINDOWS}\r\n\r\n{ function DeleteFile(const FileName: string): Boolean; }\r\n\r\nprocedure JvInterpreter_DeleteFile(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := SysUtils.DeleteFile(Args.Values[0]);\r\nend;\r\n\r\n{ function RenameFile(const OldName, NewName: string): Boolean; }\r\n\r\nprocedure JvInterpreter_RenameFile(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := RenameFile(Args.Values[0], Args.Values[1]);\r\nend;\r\n\r\n{ function ChangeFileExt(const FileName, Extension: string): string; }\r\n\r\nprocedure JvInterpreter_ChangeFileExt(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := ChangeFileExt(Args.Values[0], Args.Values[1]);\r\nend;\r\n\r\n{ function ExtractFilePath(const FileName: string): string; }\r\n\r\nprocedure JvInterpreter_ExtractFilePath(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := ExtractFilePath(Args.Values[0]);\r\nend;\r\n\r\n{ function ExtractFileDir(const FileName: string): string; }\r\n\r\nprocedure JvInterpreter_ExtractFileDir(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := ExtractFileDir(Args.Values[0]);\r\nend;\r\n\r\n{ function ExtractFileDrive(const FileName: string): string; }\r\n\r\nprocedure JvInterpreter_ExtractFileDrive(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := ExtractFileDrive(Args.Values[0]);\r\nend;\r\n\r\n{ function ExtractFileName(const FileName: string): string; }\r\n\r\nprocedure JvInterpreter_ExtractFileName(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := ExtractFileName(Args.Values[0]);\r\nend;\r\n\r\n{ function ExtractFileExt(const FileName: string): string; }\r\n\r\nprocedure JvInterpreter_ExtractFileExt(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := ExtractFileExt(Args.Values[0]);\r\nend;\r\n\r\n{ function ExpandFileName(const FileName: string): string; }\r\n\r\nprocedure JvInterpreter_ExpandFileName(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := ExpandFileName(Args.Values[0]);\r\nend;\r\n\r\n{ function ExpandUNCFileName(const FileName: string): string; }\r\n\r\nprocedure JvInterpreter_ExpandUNCFileName(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := ExpandUNCFileName(Args.Values[0]);\r\nend;\r\n\r\n{ function ExtractRelativePath(const BaseName, DestName: string): string; }\r\n\r\n\r\nprocedure JvInterpreter_ExtractRelativePath(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := ExtractRelativePath(Args.Values[0], Args.Values[1]);\r\nend;\r\n\r\n{ function FileSearch(const Name, DirList: string): string; }\r\n\r\nprocedure JvInterpreter_FileSearch(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := FileSearch(Args.Values[0], Args.Values[1]);\r\nend;\r\n\r\n{$IFDEF MSWINDOWS}\r\n\r\n{ function DiskFree(Drive: Byte): Integer; }\r\n\r\nprocedure JvInterpreter_DiskFree(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := Integer(DiskFree(Args.Values[0]));\r\nend;\r\n\r\n{ function DiskSize(Drive: Byte): Integer; }\r\n\r\nprocedure JvInterpreter_DiskSize(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := Integer(DiskSize(Args.Values[0]));\r\nend;\r\n\r\n{$ENDIF MSWINDOWS}\r\n\r\n{ function FileDateToDateTime(FileDate: Integer): TDateTime; }\r\n\r\nprocedure JvInterpreter_FileDateToDateTime(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := FileDateToDateTime(Args.Values[0]);\r\nend;\r\n\r\n{ function DateTimeToFileDate(DateTime: TDateTime): Integer; }\r\n\r\nprocedure JvInterpreter_DateTimeToFileDate(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := DateTimeToFileDate(Args.Values[0]);\r\nend;\r\n\r\n{ function GetCurrentDir: string; }\r\n\r\nprocedure JvInterpreter_GetCurrentDir(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := GetCurrentDir;\r\nend;\r\n\r\n{ function SetCurrentDir(const Dir: string): Boolean; }\r\n\r\nprocedure JvInterpreter_SetCurrentDir(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := SetCurrentDir(Args.Values[0]);\r\nend;\r\n\r\n{ function CreateDir(const Dir: string): Boolean; }\r\n\r\nprocedure JvInterpreter_CreateDir(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := CreateDir(Args.Values[0]);\r\nend;\r\n\r\n{ function RemoveDir(const Dir: string): Boolean; }\r\n\r\nprocedure JvInterpreter_RemoveDir(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := RemoveDir(Args.Values[0]);\r\nend;\r\n\r\n{ function StrLen(Str: PChar): Cardinal; }\r\n\r\nprocedure JvInterpreter_StrLen(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := Integer(StrLen(PChar(string(Args.Values[0]))));\r\nend;\r\n\r\n{ function StrEnd(Str: PChar): PChar; }\r\n\r\nprocedure JvInterpreter_StrEnd(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := string(StrEnd(PChar(string(Args.Values[0]))));\r\nend;\r\n\r\n{ function StrMove(Dest, Source: PChar; Count: Cardinal): PChar; }\r\n\r\nprocedure JvInterpreter_StrMove(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := string(StrMove(PChar(string(Args.Values[0])), PChar(string(Args.Values[1])), Args.Values[2]));\r\nend;\r\n\r\n{ function StrCopy(Dest, Source: PChar): PChar; }\r\n\r\nprocedure JvInterpreter_StrCopy(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := string(StrCopy(PChar(string(Args.Values[0])), PChar(string(Args.Values[1]))));\r\nend;\r\n\r\n{ function StrECopy(Dest, Source: PChar): PChar; }\r\n\r\nprocedure JvInterpreter_StrECopy(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := string(StrECopy(PChar(string(Args.Values[0])), PChar(string(Args.Values[1]))));\r\nend;\r\n\r\n{ function StrLCopy(Dest, Source: PChar; MaxLen: Cardinal): PChar; }\r\n\r\nprocedure JvInterpreter_StrLCopy(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := string(StrLCopy(PChar(string(Args.Values[0])), PChar(string(Args.Values[1])), Args.Values[2]));\r\nend;\r\n\r\n{ function StrPCopy(Dest: PChar; const Source: string): PChar; }\r\n\r\nprocedure JvInterpreter_StrPCopy(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := string(StrPCopy(PChar(string(Args.Values[0])), Args.Values[1]));\r\nend;\r\n\r\n{ function StrPLCopy(Dest: PChar; const Source: string; MaxLen: Cardinal): PChar; }\r\n\r\nprocedure JvInterpreter_StrPLCopy(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := string(StrPLCopy(PChar(string(Args.Values[0])), Args.Values[1], Args.Values[2]));\r\nend;\r\n\r\n{ function StrCat(Dest, Source: PChar): PChar; }\r\n\r\nprocedure JvInterpreter_StrCat(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := string(StrCat(PChar(string(Args.Values[0])), PChar(string(Args.Values[1]))));\r\nend;\r\n\r\n{ function StrLCat(Dest, Source: PChar; MaxLen: Cardinal): PChar; }\r\n\r\nprocedure JvInterpreter_StrLCat(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := string(StrLCat(PChar(string(Args.Values[0])), PChar(string(Args.Values[1])), Args.Values[2]));\r\nend;\r\n\r\n{ function StrComp(Str1, Str2: PChar): Integer; }\r\n\r\nprocedure JvInterpreter_StrComp(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := StrComp(PChar(string(Args.Values[0])), PChar(string(Args.Values[1])));\r\nend;\r\n\r\n{ function StrIComp(Str1, Str2: PChar): Integer; }\r\n\r\nprocedure JvInterpreter_StrIComp(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := StrIComp(PChar(string(Args.Values[0])), PChar(string(Args.Values[1])));\r\nend;\r\n\r\n{ function StrLComp(Str1, Str2: PChar; MaxLen: Cardinal): Integer; }\r\n\r\nprocedure JvInterpreter_StrLComp(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := StrLComp(PChar(string(Args.Values[0])), PChar(string(Args.Values[1])), Args.Values[2]);\r\nend;\r\n\r\n{ function StrLIComp(Str1, Str2: PChar; MaxLen: Cardinal): Integer; }\r\n\r\nprocedure JvInterpreter_StrLIComp(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := StrLIComp(PChar(string(Args.Values[0])), PChar(string(Args.Values[1])), Args.Values[2]);\r\nend;\r\n\r\n{ function StrScan(Str: PChar; Chr: Char): PChar; }\r\n\r\nprocedure JvInterpreter_StrScan(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := string(StrScan(PChar(string(Args.Values[0])), string(Args.Values[1])[1]));\r\nend;\r\n\r\n{ function StrRScan(Str: PChar; Chr: Char): PChar; }\r\n\r\nprocedure JvInterpreter_StrRScan(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := string(StrRScan(PChar(string(Args.Values[0])), string(Args.Values[1])[1]));\r\nend;\r\n\r\n{ function StrPos(Str1, Str2: PChar): PChar; }\r\n\r\nprocedure JvInterpreter_StrPos(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := string(StrPos(PChar(string(Args.Values[0])), PChar(string(Args.Values[1]))));\r\nend;\r\n\r\n{ function StrUpper(Str: PChar): PChar; }\r\n\r\nprocedure JvInterpreter_StrUpper(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := string(StrUpper(PChar(string(Args.Values[0]))));\r\nend;\r\n\r\n{ function StrLower(Str: PChar): PChar; }\r\n\r\nprocedure JvInterpreter_StrLower(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := string(StrLower(PChar(string(Args.Values[0]))));\r\nend;\r\n\r\n{ function StrPas(Str: PChar): string; }\r\n\r\nprocedure JvInterpreter_StrPas(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := StrPas(PChar(string(Args.Values[0])));\r\nend;\r\n\r\n{ function StrAlloc(Size: Cardinal): PChar; }\r\n\r\nprocedure JvInterpreter_StrAlloc(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := string(StrAlloc(Args.Values[0]));\r\nend;\r\n\r\n{ function StrBufSize(Str: PChar): Cardinal; }\r\n\r\nprocedure JvInterpreter_StrBufSize(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := Integer(StrBufSize(PChar(string(Args.Values[0]))));\r\nend;\r\n\r\n{ function StrNew(Str: PChar): PChar; }\r\n\r\nprocedure JvInterpreter_StrNew(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := string(StrNew(PChar(string(Args.Values[0]))));\r\nend;\r\n\r\n{ procedure StrDispose(Str: PChar); }\r\n\r\nprocedure JvInterpreter_StrDispose(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n StrDispose(PChar(string(Args.Values[0])));\r\nend;\r\n\r\n{ function Format(const Format: string; const Args: array of const): string; }\r\n\r\nprocedure JvInterpreter_Format(var Value: Variant; Args: TJvInterpreterArgs);\r\n\r\n function FormatWorkaround(const MyFormat: string; const Args: array of const): string;\r\n begin\r\n Result := Format(MyFormat, Args);\r\n end;\r\n\r\nbegin\r\n Args.OpenArray(1);\r\n Value := FormatWorkaround(Args.Values[0], Slice(Args.OA^, Args.OAS));\r\nend;\r\n\r\n{ procedure FmtStr(var Result: string; const Format: string; const Args: array of const); }\r\n\r\nprocedure JvInterpreter_FmtStr(var Value: Variant; Args: TJvInterpreterArgs);\r\n\r\n procedure FmtStrWorkaround(var Result: string; const Format: string; const Args: array of const);\r\n begin\r\n FmtStr(Result, Format, Args);\r\n end;\r\n\r\nbegin\r\n Args.OpenArray(2);\r\n FmtStrWorkaround(string(TVarData(Args.Values[0]).vString), Args.Values[1], Slice(Args.OA^, Args.OAS));\r\nend;\r\n\r\n{ function StrFmt(Buffer, Format: PChar; const Args: array of const): PChar; }\r\n\r\nprocedure JvInterpreter_StrFmt(var Value: Variant; Args: TJvInterpreterArgs);\r\n\r\n function StrFmtWorkaround(Buffer, Format: PChar; const Args: array of const): PChar;\r\n begin\r\n Result := StrFmt(Buffer, Format, Args);\r\n end;\r\n\r\nbegin\r\n Args.OpenArray(2);\r\n Value := string(StrFmtWorkaround(PChar(string(Args.Values[0])), PChar(string(Args.Values[1])), Slice(Args.OA^,\r\n Args.OAS)));\r\nend;\r\n\r\n{ function StrLFmt(Buffer: PChar; MaxLen: Cardinal; Format: PChar; const Args: array of const): PChar; }\r\n\r\nprocedure JvInterpreter_StrLFmt(var Value: Variant; Args: TJvInterpreterArgs);\r\n\r\n function StrLFmtWorkaround(Buffer: PChar; MaxLen: Cardinal; Format: PChar; const Args: array of const): PChar;\r\n begin\r\n Result := StrLFmt(Buffer, MaxLen, Format, Args);\r\n end;\r\n\r\nbegin\r\n Args.OpenArray(3);\r\n Value := string(StrLFmtWorkaround(PChar(string(Args.Values[0])), Args.Values[1], PChar(string(Args.Values[2])),\r\n Slice(Args.OA^, Args.OAS)));\r\nend;\r\n\r\n{ function FormatBuf(var Buffer; BufLen: Cardinal; const Format; FmtLen: Cardinal; const Args: array of const): Cardinal; }\r\n\r\nprocedure JvInterpreter_FormatBuf(var Value: Variant; Args: TJvInterpreterArgs);\r\n\r\n function FormatBufWorkaround(var Buffer; BufLen: Cardinal; const Format; FmtLen: Cardinal;\r\n const Args: array of const): Cardinal;\r\n begin\r\n Result := FormatBuf(Buffer, BufLen, Format, FmtLen, Args);\r\n end;\r\n\r\nbegin\r\n Args.OpenArray(4);\r\n Value := Integer(FormatBufWorkaround(Args.Values[0], Args.Values[1], Args.Values[2], Args.Values[3], Slice(Args.OA^,\r\n Args.OAS)));\r\nend;\r\n\r\n{ function FloatToStr(Value: Extended): string; }\r\n\r\nprocedure JvInterpreter_FloatToStr(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := FloatToStr(Args.Values[0]);\r\nend;\r\n\r\n{ function CurrToStr(Value: Currency): string; }\r\n\r\nprocedure JvInterpreter_CurrToStr(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := CurrToStr(Args.Values[0]);\r\nend;\r\n\r\n{ function FloatToStrF(Value: Extended; Format: TFloatFormat; Precision, Digits: Integer): string; }\r\n\r\nprocedure JvInterpreter_FloatToStrF(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := FloatToStrF(Args.Values[0], Args.Values[1], Args.Values[2], Args.Values[3]);\r\nend;\r\n\r\n{ function CurrToStrF(Value: Currency; Format: TFloatFormat; Digits: Integer): string; }\r\n\r\nprocedure JvInterpreter_CurrToStrF(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := CurrToStrF(Args.Values[0], Args.Values[1], Args.Values[2]);\r\nend;\r\n\r\n(*\r\n{ function FloatToText(Buffer: PChar; const Value; ValueType: TFloatValue; Format: TFloatFormat; Precision, Digits: Integer): Integer; }\r\nprocedure JvInterpreter_FloatToText(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := FloatToText(PChar(string(Args.Values[0])), PChar(string(Args.Values[1])), Args.Values[2], Args.Values[3], Args.Values[4], Args.Values[5]);\r\nend;\r\n*)\r\n\r\n{ function FormatFloat(const Format: string; Value: Extended): string; }\r\n\r\nprocedure JvInterpreter_FormatFloat(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := FormatFloat(Args.Values[0], Args.Values[1]);\r\nend;\r\n\r\n{ function FormatCurr(const Format: string; Value: Currency): string; }\r\n\r\nprocedure JvInterpreter_FormatCurr(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := FormatCurr(Args.Values[0], Args.Values[1]);\r\nend;\r\n\r\n(*\r\n{ function FloatToTextFmt(Buffer: PChar; const Value; ValueType: TFloatValue; Format: PChar): Integer; }\r\nprocedure JvInterpreter_FloatToTextFmt(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := FloatToTextFmt(PChar(string(Args.Values[0])), PChar(string(Args.Values[1])), Args.Values[2], PChar(string(Args.Values[3])));\r\nend;\r\n*)\r\n\r\n{ function StrToFloat(const S: string): Extended; }\r\n\r\nprocedure JvInterpreter_StrToFloat(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := StrToFloat(Args.Values[0]);\r\nend;\r\n\r\n{ function StrToCurr(const S: string): Currency; }\r\n\r\nprocedure JvInterpreter_StrToCurr(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := StrToCurr(Args.Values[0]);\r\nend;\r\n\r\n(*\r\n{ function TextToFloat(Buffer: PChar; var Value; ValueType: TFloatValue): Boolean; }\r\nprocedure JvInterpreter_TextToFloat(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TextToFloat(PChar(string(Args.Values[0])), PChar(string(Args.Values[1])), Args.Values[2]);\r\nend;\r\n*)\r\n(* need record\r\n{ procedure FloatToDecimal(var Result: TFloatRec; const Value; ValueType: TFloatValue; Precision, Decimals: Integer); }\r\nprocedure JvInterpreter_FloatToDecimal(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n FloatToDecimal(Args.Values[0], Args.Values[1], Args.Values[2], Args.Values[3], Args.Values[4]);\r\nend;\r\n*)\r\n\r\n(* need record\r\n{ function DateTimeToTimeStamp(DateTime: TDateTime): TTimeStamp; }\r\nprocedure JvInterpreter_DateTimeToTimeStamp(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := DateTimeToTimeStamp(Args.Values[0]);\r\nend;\r\n\r\n{ function TimeStampToDateTime(const TimeStamp: TTimeStamp): TDateTime; }\r\nprocedure JvInterpreter_TimeStampToDateTime(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TimeStampToDateTime(Args.Values[0]);\r\nend;\r\n\r\n{ function MSecsToTimeStamp(MSecs: Comp): TTimeStamp; }\r\nprocedure JvInterpreter_MSecsToTimeStamp(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := MSecsToTimeStamp(Args.Values[0]);\r\nend;\r\n\r\n{ function TimeStampToMSecs(const TimeStamp: TTimeStamp): Comp; }\r\nprocedure JvInterpreter_TimeStampToMSecs(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TimeStampToMSecs(Args.Values[0]);\r\nend;\r\n*)\r\n\r\n{ function EncodeDate(Year, Month, Day: Word): TDateTime; }\r\n\r\nprocedure JvInterpreter_EncodeDate(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := EncodeDate(Args.Values[0], Args.Values[1], Args.Values[2]);\r\nend;\r\n\r\n{ function EncodeTime(Hour, Min, Sec, MSec: Word): TDateTime; }\r\n\r\nprocedure JvInterpreter_EncodeTime(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := EncodeTime(Args.Values[0], Args.Values[1], Args.Values[2], Args.Values[3]);\r\nend;\r\n\r\n{ procedure DecodeDate(Date: TDateTime; var Year, Month, Day: Word); }\r\n\r\nprocedure JvInterpreter_DecodeDate(var Value: Variant; Args: TJvInterpreterArgs);\r\nvar\r\n Year, Month, Day: Word;\r\nbegin\r\n DecodeDate(Args.Values[0], Year, Month, Day);\r\n Args.Values[1] := Year;\r\n Args.Values[2] := Month;\r\n Args.Values[3] := Day;\r\nend;\r\n\r\n{ procedure DecodeTime(Time: TDateTime; var Hour, Min, Sec, MSec: Word); }\r\n\r\nprocedure JvInterpreter_DecodeTime(var Value: Variant; Args: TJvInterpreterArgs);\r\nvar\r\n Hour, Min, Sec, MSec: Word;\r\nbegin\r\n DecodeTime(Args.Values[0], Hour, Min, Sec, MSec);\r\n Args.Values[1] := Hour;\r\n Args.Values[2] := Min;\r\n Args.Values[3] := Sec;\r\n Args.Values[4] := MSec;\r\nend;\r\n\r\n(* need record\r\n{ procedure DateTimeToSystemTime(DateTime: TDateTime; var SystemTime: TSystemTime); }\r\nprocedure JvInterpreter_DateTimeToSystemTime(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n DateTimeToSystemTime(Args.Values[0], Args.Values[1]);\r\nend;\r\n\r\n{ function SystemTimeToDateTime(const SystemTime: TSystemTime): TDateTime; }\r\nprocedure JvInterpreter_SystemTimeToDateTime(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := SystemTimeToDateTime(Args.Values[0]);\r\nend;\r\n*)\r\n\r\n{ function DayOfWeek(Date: TDateTime): Integer; }\r\n\r\nprocedure JvInterpreter_DayOfWeek(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := DayOfWeek(Args.Values[0]);\r\nend;\r\n\r\n{ function Date: TDateTime; }\r\n\r\nprocedure JvInterpreter_Date(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := Date;\r\nend;\r\n\r\n{ function Time: TDateTime; }\r\n\r\nprocedure JvInterpreter_Time(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := Time;\r\nend;\r\n\r\n{ function Now: TDateTime; }\r\n\r\nprocedure JvInterpreter_Now(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := Now;\r\nend;\r\n\r\n{ function IncMonth(const Date: TDateTime; NumberOfMonths: Integer): TDateTime; }\r\n\r\nprocedure JvInterpreter_IncMonth(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := IncMonth(Args.Values[0], Args.Values[1]);\r\nend;\r\n\r\n{ function IsLeapYear(Year: Word): Boolean; }\r\n\r\nprocedure JvInterpreter_IsLeapYear(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := IsLeapYear(Args.Values[0]);\r\nend;\r\n\r\n{ function DateToStr(Date: TDateTime): string; }\r\n\r\nprocedure JvInterpreter_DateToStr(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := DateToStr(Args.Values[0]);\r\nend;\r\n\r\n{ function TimeToStr(Time: TDateTime): string; }\r\n\r\nprocedure JvInterpreter_TimeToStr(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TimeToStr(Args.Values[0]);\r\nend;\r\n\r\n{ function DateTimeToStr(DateTime: TDateTime): string; }\r\n\r\nprocedure JvInterpreter_DateTimeToStr(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := DateTimeToStr(Args.Values[0]);\r\nend;\r\n\r\n{ function StrToDate(const S: string): TDateTime; }\r\n\r\nprocedure JvInterpreter_StrToDate(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := StrToDate(Args.Values[0]);\r\nend;\r\n\r\n{ function StrToTime(const S: string): TDateTime; }\r\n\r\nprocedure JvInterpreter_StrToTime(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := StrToTime(Args.Values[0]);\r\nend;\r\n\r\n{ function StrToDateTime(const S: string): TDateTime; }\r\n\r\nprocedure JvInterpreter_StrToDateTime(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := StrToDateTime(Args.Values[0]);\r\nend;\r\n\r\n{ function FormatDateTime(const Format: string; DateTime: TDateTime): string; }\r\n\r\nprocedure JvInterpreter_FormatDateTime(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := FormatDateTime(Args.Values[0], Args.Values[1]);\r\nend;\r\n\r\n{ procedure DateTimeToString(var Result: string; const Format: string; DateTime: TDateTime); }\r\n\r\nprocedure JvInterpreter_DateTimeToString(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n DateTimeToString(string(TVarData(Args.Values[0]).vString), Args.Values[1], Args.Values[2]);\r\nend;\r\n\r\n{ function SysErrorMessage(ErrorCode: Integer): string; }\r\n\r\nprocedure JvInterpreter_SysErrorMessage(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := SysErrorMessage(Args.Values[0]);\r\nend;\r\n\r\n{ function GetLocaleStr(Locale, LocaleType: Integer; const Default: string): string; }\r\n\r\nprocedure JvInterpreter_GetLocaleStr(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := GetLocaleStr(Args.Values[0], Args.Values[1], Args.Values[2]);\r\nend;\r\n\r\n{ function GetLocaleChar(Locale, LocaleType: Integer; Default: Char): Char; }\r\n\r\nprocedure JvInterpreter_GetLocaleChar(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := GetLocaleChar(Args.Values[0], Args.Values[1], string(Args.Values[2])[1]);\r\nend;\r\n\r\n{ procedure GetFormatSettings; }\r\n\r\nprocedure JvInterpreter_GetFormatSettings(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n GetFormatSettings;\r\nend;\r\n\r\n{ function ExceptObject: TObject; }\r\n\r\nprocedure JvInterpreter_ExceptObject(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(ExceptObject);\r\nend;\r\n\r\n{ function ExceptAddr: Pointer; }\r\n\r\nprocedure JvInterpreter_ExceptAddr(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := P2V(ExceptAddr);\r\nend;\r\n\r\n{ function ExceptionErrorMessage(ExceptObject: TObject; ExceptAddr: Pointer; Buffer: PChar; Size: Integer): Integer; }\r\n\r\n\r\nprocedure JvInterpreter_ExceptionErrorMessage(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := ExceptionErrorMessage(V2O(Args.Values[0]), V2P(Args.Values[1]), PChar(string(Args.Values[2])),\r\n Args.Values[3]);\r\nend;\r\n\r\n{ procedure ShowException(ExceptObject: TObject; ExceptAddr: Pointer); }\r\n\r\nprocedure JvInterpreter_ShowException(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n ShowException(V2O(Args.Values[0]), V2P(Args.Values[1]));\r\nend;\r\n\r\n{ procedure Abort; }\r\n\r\nprocedure JvInterpreter_Abort(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Abort;\r\nend;\r\n\r\n{ procedure OutOfMemoryError; }\r\n\r\nprocedure JvInterpreter_OutOfMemoryError(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n OutOfMemoryError;\r\nend;\r\n\r\n{ procedure Beep; }\r\n\r\nprocedure JvInterpreter_Beep(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n SysUtils.Beep;\r\nend;\r\n\r\n{ function ByteType(const S: string; Index: Integer): TMbcsByteType; }\r\n\r\nprocedure JvInterpreter_ByteType(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := ByteType(Args.Values[0], Args.Values[1]);\r\nend;\r\n\r\n{ function StrByteType(Str: PChar; Index: Cardinal): TMbcsByteType; }\r\n\r\nprocedure JvInterpreter_StrByteType(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := StrByteType(PChar(string(Args.Values[0])), Args.Values[1]);\r\nend;\r\n\r\n{ function ByteToCharLen(const S: string; MaxLen: Integer): Integer; }\r\n\r\nprocedure JvInterpreter_ByteToCharLen(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := {$IFDEF RTL200_UP}ElementToCharLen{$ELSE}ByteToCharLen{$ENDIF RTL200_UP}(Args.Values[0], Args.Values[1]);\r\nend;\r\n\r\n{ function CharToByteLen(const S: string; MaxLen: Integer): Integer; }\r\n\r\nprocedure JvInterpreter_CharToByteLen(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := {$IFDEF RTL200_UP}CharToElementLen{$ELSE}CharToByteLen{$ENDIF RTL200_UP}(Args.Values[0], Args.Values[1]);\r\nend;\r\n\r\n{ function ByteToCharIndex(const S: string; Index: Integer): Integer; }\r\n\r\nprocedure JvInterpreter_ByteToCharIndex(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := {$IFDEF RTL200_UP}ElementToCharIndex{$ELSE}ByteToCharIndex{$ENDIF RTL200_UP}(Args.Values[0], Args.Values[1]);\r\nend;\r\n\r\n{ function CharToByteIndex(const S: string; Index: Integer): Integer; }\r\n\r\nprocedure JvInterpreter_CharToByteIndex(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := {$IFDEF RTL200_UP}CharToElementIndex{$ELSE}CharToByteIndex{$ENDIF RTL200_UP}(Args.Values[0], Args.Values[1]);\r\nend;\r\n\r\n{ function IsPathDelimiter(const S: string; Index: Integer): Boolean; }\r\n\r\nprocedure JvInterpreter_IsPathDelimiter(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := IsPathDelimiter(Args.Values[0], Args.Values[1]);\r\nend;\r\n\r\n{ function IsDelimiter(const Delimiters, S: string; Index: Integer): Boolean; }\r\n\r\nprocedure JvInterpreter_IsDelimiter(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := IsDelimiter(Args.Values[0], Args.Values[1], Args.Values[2]);\r\nend;\r\n\r\n{ function LastDelimiter(const Delimiters, S: string): Integer; }\r\n\r\nprocedure JvInterpreter_LastDelimiter(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := LastDelimiter(Args.Values[0], Args.Values[1]);\r\nend;\r\n\r\n{ function AnsiCompareFileName(const S1, S2: string): Integer; }\r\n\r\nprocedure JvInterpreter_AnsiCompareFileName(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := AnsiCompareFileName(Args.Values[0], Args.Values[1]);\r\nend;\r\n\r\n{ function AnsiLowerCaseFileName(const S: string): string; }\r\n\r\nprocedure JvInterpreter_AnsiLowerCaseFileName(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := AnsiLowerCase(Args.Values[0]);\r\nend;\r\n\r\n{ function AnsiUpperCaseFileName(const S: string): string; }\r\n\r\nprocedure JvInterpreter_AnsiUpperCaseFileName(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := AnsiUpperCase(Args.Values[0]);\r\nend;\r\n\r\n{ function AnsiPos(const Substr, S: string): Integer; }\r\n\r\nprocedure JvInterpreter_AnsiPos(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := AnsiPos(Args.Values[0], Args.Values[1]);\r\nend;\r\n\r\n{ function AnsiStrPos(Str, SubStr: PChar): PChar; }\r\n\r\nprocedure JvInterpreter_AnsiStrPos(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := string(AnsiStrPos(PChar(string(Args.Values[0])), PChar(string(Args.Values[1]))));\r\nend;\r\n\r\n{ function AnsiStrRScan(Str: PChar; Chr: Char): PChar; }\r\n\r\nprocedure JvInterpreter_AnsiStrRScan(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := string(AnsiStrRScan(PChar(string(Args.Values[0])), string(Args.Values[1])[1]));\r\nend;\r\n\r\n{ function AnsiStrScan(Str: PChar; Chr: Char): PChar; }\r\n\r\nprocedure JvInterpreter_AnsiStrScan(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := string(AnsiStrScan(PChar(string(Args.Values[0])), string(Args.Values[1])[1]));\r\nend;\r\n\r\n{ function LoadPackage(const Name: string): HMODULE; }\r\n\r\nprocedure JvInterpreter_LoadPackage(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := Integer(LoadPackage(Args.Values[0]));\r\nend;\r\n\r\n{ procedure UnloadPackage(Module: HMODULE); }\r\n\r\nprocedure JvInterpreter_UnloadPackage(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n UnloadPackage(Args.Values[0]);\r\nend;\r\n\r\n{$IFDEF MSWINDOWS}\r\n\r\n{ procedure RaiseLastWin32Error; }\r\n\r\nprocedure JvInterpreter_RaiseLastWin32Error(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n RaiseLastOSError;\r\nend;\r\n\r\n{ function Win32Check(RetVal: BOOL): BOOL; }\r\n\r\nprocedure JvInterpreter_Win32Check(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := Win32Check(Args.Values[0]);\r\nend;\r\n\r\n{$ENDIF MSWINDOWS}\r\n\r\n{ regional options }\r\n\r\n(*\r\n{ read CurrencyString: string }\r\nprocedure JvInterpreter_Read_CurrencyString(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := CurrencyString;\r\nend;\r\n\r\n{ write CurrencyString: string }\r\nprocedure JvInterpreter_Write_CurrencyString(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n CurrencyString := Value;\r\nend;\r\n\r\n{ read CurrencyFormat: Byte }\r\nprocedure JvInterpreter_Read_CurrencyFormat(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := CurrencyFormat;\r\nend;\r\n\r\n{ write CurrencyFormat: Byte }\r\nprocedure JvInterpreter_Write_CurrencyFormat(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n CurrencyFormat := Value;\r\nend;\r\n\r\n{ read NegCurrFormat: Byte }\r\nprocedure JvInterpreter_Read_NegCurrFormat(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := NegCurrFormat;\r\nend;\r\n\r\n{ write NegCurrFormat: Byte }\r\nprocedure JvInterpreter_Write_NegCurrFormat(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n NegCurrFormat := Value;\r\nend;\r\n\r\n{ read ThousandSeparator }\r\nprocedure JvInterpreter_Read_ThousandSeparator(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := ThousandSeparator;\r\nend;\r\n\r\n{ write ThousandSeparator }\r\nprocedure JvInterpreter_Write_ThousandSeparator(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n ThousandSeparator := string(Value)[1];\r\nend;\r\n\r\n{ read DecimalSeparator }\r\nprocedure JvInterpreter_Read_DecimalSeparator(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := DecimalSeparator;\r\nend;\r\n\r\n{ write DecimalSeparator }\r\nprocedure JvInterpreter_Write_DecimalSeparator(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n DecimalSeparator := string(Value)[1];\r\nend;\r\n\r\n{ read CurrencyDecimals }\r\nprocedure JvInterpreter_Read_CurrencyDecimals(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := CurrencyDecimals;\r\nend;\r\n\r\n{ write CurrencyDecimals }\r\nprocedure JvInterpreter_Write_CurrencyDecimals(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n CurrencyDecimals := Value;\r\nend;\r\n\r\n{ read DateSeparator }\r\nprocedure JvInterpreter_Read_DateSeparator(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := DateSeparator;\r\nend;\r\n\r\n{ write DateSeparator }\r\nprocedure JvInterpreter_Write_DateSeparator(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n DateSeparator := string(Value)[1];\r\nend;\r\n\r\n{ read ShortDateFormat }\r\nprocedure JvInterpreter_Read_ShortDateFormat(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := ShortDateFormat;\r\nend;\r\n\r\n{ write ShortDateFormat }\r\nprocedure JvInterpreter_Write_ShortDateFormat(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n ShortDateFormat := Value;\r\nend;\r\n\r\n{ read LongDateFormat }\r\nprocedure JvInterpreter_Read_LongDateFormat(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := LongDateFormat;\r\nend;\r\n\r\n{ write LongDateFormat }\r\nprocedure JvInterpreter_Write_LongDateFormat(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n LongDateFormat := Value;\r\nend;\r\n\r\n{ read TimeSeparator }\r\nprocedure JvInterpreter_Read_TimeSeparator(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TimeSeparator;\r\nend;\r\n\r\n{ write TimeSeparator }\r\nprocedure JvInterpreter_Write_TimeSeparator(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TimeSeparator := string(Value)[1];\r\nend;\r\n\r\n{ read TimeAMString }\r\nprocedure JvInterpreter_Read_TimeAMString(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TimeAMString;\r\nend;\r\n\r\n{ write TimeAMString }\r\nprocedure JvInterpreter_Write_TimeAMString(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TimeAMString := Value;\r\nend;\r\n\r\n{ read TimePMString }\r\nprocedure JvInterpreter_Read_TimePMString(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TimePMString;\r\nend;\r\n\r\n{ write TimePMString }\r\nprocedure JvInterpreter_Write_TimePMString(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TimePMString := Value;\r\nend;\r\n\r\n{ read ShortTimeFormat }\r\nprocedure JvInterpreter_Read_ShortTimeFormat(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := ShortTimeFormat;\r\nend;\r\n\r\n{ write ShortTimeFormat }\r\nprocedure JvInterpreter_Write_ShortTimeFormat(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n ShortTimeFormat := Value;\r\nend;\r\n\r\n{ read LongTimeFormat }\r\nprocedure JvInterpreter_Read_LongTimeFormat(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := LongTimeFormat;\r\nend;\r\n\r\n{ write LongTimeFormat }\r\nprocedure JvInterpreter_Write_LongTimeFormat(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n LongTimeFormat := Value;\r\nend;\r\n\r\n{ read TwoDigitYearCenturyWindow }\r\nprocedure JvInterpreter_Read_TwoDigitYearCenturyWindow(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TwoDigitYearCenturyWindow;\r\nend;\r\n\r\n{ write TwoDigitYearCenturyWindow }\r\nprocedure JvInterpreter_Write_TwoDigitYearCenturyWindow(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TwoDigitYearCenturyWindow := Value;\r\nend;\r\n\r\n{ read ListSeparator }\r\nprocedure JvInterpreter_Read_ListSeparator(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := ListSeparator;\r\nend;\r\n\r\n{ write ListSeparator }\r\nprocedure JvInterpreter_Write_ListSeparator(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n ListSeparator := string(Args.Values[0])[1];\r\nend;\r\n\r\n{ read ShortMonthNames }\r\nprocedure JvInterpreter_Read_ShortMonthNames(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := ShortMonthNames[Integer(Args.Values[0])];\r\nend;\r\n\r\n{ write ShortMonthNames }\r\nprocedure JvInterpreter_Write_ShortMonthNames(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n ShortMonthNames[Integer(Args.Values[0])] := Value;\r\nend;\r\n\r\n{ read LongMonthNames }\r\nprocedure JvInterpreter_Read_LongMonthNames(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := LongMonthNames[Integer(Args.Values[0])];\r\nend;\r\n\r\n{ write LongMonthNames }\r\nprocedure JvInterpreter_Write_LongMonthNames(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n LongMonthNames[Integer(Args.Values[0])] := Value;\r\nend;\r\n\r\n{ read ShortDayNames }\r\nprocedure JvInterpreter_Read_ShortDayNames(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := ShortDayNames[Integer(Args.Values[0])];\r\nend;\r\n\r\n{ write ShortDayNames }\r\nprocedure JvInterpreter_Write_ShortDayNames(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n ShortDayNames[Integer(Args.Values[0])] := Value;\r\nend;\r\n\r\n{ read LongDayNames }\r\nprocedure JvInterpreter_Read_LongDayNames(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := LongDayNames[Integer(Args.Values[0])];\r\nend;\r\n\r\n{ write LongDayNames }\r\nprocedure JvInterpreter_Write_LongDayNames(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n LongDayNames[Integer(Args.Values[0])] := Value;\r\nend;\r\n\r\n{ read EraNames }\r\nprocedure JvInterpreter_Read_EraNames(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := EraNames[Integer(Args.Values[0])];\r\nend;\r\n\r\n{ write EraNames }\r\nprocedure JvInterpreter_Write_EraNames(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n EraNames[Integer(Args.Values[0])] := Value;\r\nend;\r\n\r\n{ read EraYearOffsets }\r\nprocedure JvInterpreter_Read_EraYearOffsets(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := EraYearOffsets[Integer(Args.Values[0])];\r\nend;\r\n\r\n{ write EraYearOffsets }\r\nprocedure JvInterpreter_Write_EraYearOffsets(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n EraYearOffsets[Integer(Args.Values[0])] := Value;\r\nend;\r\n*)\r\n\r\ntype\r\n PSearchRec = ^TSearchRec;\r\n\r\nprocedure JvInterpreter_NewTSearchRec(var Value: Pointer);\r\nbegin\r\n New(PSearchRec(Value));\r\nend;\r\n\r\nprocedure JvInterpreter_DisposeTSearchRec(const Value: Pointer);\r\nbegin\r\n Dispose(PSearchRec(Value));\r\nend;\r\n\r\nprocedure RegisterJvInterpreterAdapter(JvInterpreterAdapter: TJvInterpreterAdapter);\r\nconst\r\n cSysUtils = 'SysUtils';\r\nbegin\r\n with JvInterpreterAdapter do\r\n begin\r\n { Exception }\r\n AddClass(cSysUtils, Exception, 'Exception');\r\n AddGet(Exception, 'Create', Exception_Create, 1, [varEmpty], varEmpty);\r\n AddGet(Exception, 'CreateFmt', Exception_CreateFmt, 2, [varEmpty, varEmpty], varEmpty);\r\n AddGet(Exception, 'CreateRes', Exception_CreateRes, 1, [varEmpty], varEmpty);\r\n AddGet(Exception, 'CreateResFmt', Exception_CreateResFmt, 2, [varEmpty, varEmpty], varEmpty);\r\n AddGet(Exception, 'CreateHelp', Exception_CreateHelp, 2, [varEmpty, varEmpty], varEmpty);\r\n AddGet(Exception, 'CreateFmtHelp', Exception_CreateFmtHelp, 3, [varEmpty, varEmpty, varEmpty], varEmpty);\r\n AddGet(Exception, 'CreateResHelp', Exception_CreateResHelp, 2, [varEmpty, varEmpty], varEmpty);\r\n AddGet(Exception, 'CreateResFmtHelp', Exception_CreateResFmtHelp, 3, [varEmpty, varEmpty, varEmpty], varEmpty);\r\n AddGet(Exception, 'HelpContext', Exception_Read_HelpContext, 0, [varEmpty], varEmpty);\r\n AddSet(Exception, 'HelpContext', Exception_Write_HelpContext, 0, [varEmpty]);\r\n AddGet(Exception, 'Message', Exception_Read_Message, 0, [varEmpty], varEmpty);\r\n AddSet(Exception, 'Message', Exception_Write_Message, 0, [varEmpty]);\r\n { EAbort }\r\n AddClass(cSysUtils, EAbort, 'EAbort');\r\n { EOutOfMemory }\r\n AddClass(cSysUtils, EOutOfMemory, 'EOutOfMemory');\r\n { EInOutError }\r\n AddClass(cSysUtils, EInOutError, 'EInOutError');\r\n { EIntError }\r\n AddClass(cSysUtils, EIntError, 'EIntError');\r\n { EDivByZero }\r\n AddClass(cSysUtils, EDivByZero, 'EDivByZero');\r\n { ERangeError }\r\n AddClass(cSysUtils, ERangeError, 'ERangeError');\r\n { EIntOverflow }\r\n AddClass(cSysUtils, EIntOverflow, 'EIntOverflow');\r\n { EMathError }\r\n AddClass(cSysUtils, EMathError, 'EMathError');\r\n { EInvalidOp }\r\n AddClass(cSysUtils, EInvalidOp, 'EInvalidOp');\r\n { EZeroDivide }\r\n AddClass(cSysUtils, EZeroDivide, 'EZeroDivide');\r\n { EOverflow }\r\n AddClass(cSysUtils, EOverflow, 'EOverflow');\r\n { EUnderflow }\r\n AddClass(cSysUtils, EUnderflow, 'EUnderflow');\r\n { EInvalidPointer }\r\n AddClass(cSysUtils, EInvalidPointer, 'EInvalidPointer');\r\n { EInvalidCast }\r\n AddClass(cSysUtils, EInvalidCast, 'EInvalidCast');\r\n { EConvertError }\r\n AddClass(cSysUtils, EConvertError, 'EConvertError');\r\n { EAccessViolation }\r\n AddClass(cSysUtils, EAccessViolation, 'EAccessViolation');\r\n { EPrivilege }\r\n AddClass(cSysUtils, EPrivilege, 'EPrivilege');\r\n { EControlC }\r\n AddClass(cSysUtils, EControlC, 'EControlC');\r\n { EVariantError }\r\n AddClass(cSysUtils, EVariantError, 'EVariantError');\r\n { EPropReadOnly }\r\n AddClass(cSysUtils, EPropReadOnly, 'EPropReadOnly');\r\n { EPropWriteOnly }\r\n AddClass(cSysUtils, EPropWriteOnly, 'EPropWriteOnly');\r\n { EExternalException }\r\n AddClass(cSysUtils, EExternalException, 'EExternalException');\r\n\r\n { EAssertionFailed }\r\n AddClass(cSysUtils, EAssertionFailed, 'EAssertionFailed');\r\n {$IFNDEF PC_MAPPED_EXCEPTIONS} // Linux define symbol\r\n { EAbstractError }\r\n AddClass(cSysUtils, EAbstractError, 'EAbstractError');\r\n {$ENDIF !PC_MAPPED_EXCEPTIONS}\r\n { EIntfCastError }\r\n AddClass(cSysUtils, EIntfCastError, 'EIntfCastError');\r\n { EInvalidContainer }\r\n AddClass(cSysUtils, EInvalidContainer, 'EInvalidContainer');\r\n { EInvalidInsert }\r\n AddClass(cSysUtils, EInvalidInsert, 'EInvalidInsert');\r\n { EPackageError }\r\n AddClass(cSysUtils, EPackageError, 'EPackageError');\r\n // (rom) changed to EOSError for Delphi 6\r\n { EOSError }\r\n AddClass(cSysUtils, EOSError, 'EOSError');\r\n\r\n AddFunction(cSysUtils, 'AllocMem', JvInterpreter_AllocMem, 1, [varEmpty], varEmpty);\r\n AddFunction(cSysUtils, 'UpperCase', JvInterpreter_UpperCase, 1, [varEmpty], varEmpty);\r\n AddFunction(cSysUtils, 'LowerCase', JvInterpreter_LowerCase, 1, [varEmpty], varEmpty);\r\n AddFunction(cSysUtils, 'CompareStr', JvInterpreter_CompareStr, 2, [varEmpty, varEmpty], varEmpty);\r\n\r\n AddFunction(cSysUtils, 'CompareMem', JvInterpreter_CompareMem, 3, [varEmpty, varEmpty, varEmpty], varEmpty);\r\n\r\n AddFunction(cSysUtils, 'CompareText', JvInterpreter_CompareText, 2, [varEmpty, varEmpty], varEmpty);\r\n AddFunction(cSysUtils, 'AnsiUpperCase', JvInterpreter_AnsiUpperCase, 1, [varEmpty], varEmpty);\r\n AddFunction(cSysUtils, 'AnsiLowerCase', JvInterpreter_AnsiLowerCase, 1, [varEmpty], varEmpty);\r\n AddFunction(cSysUtils, 'AnsiCompareStr', JvInterpreter_AnsiCompareStr, 2, [varEmpty, varEmpty], varEmpty);\r\n AddFunction(cSysUtils, 'AnsiCompareText', JvInterpreter_AnsiCompareText, 2, [varEmpty, varEmpty], varEmpty);\r\n\r\n AddFunction(cSysUtils, 'AnsiStrComp', JvInterpreter_AnsiStrComp, 2, [varEmpty, varEmpty], varEmpty);\r\n AddFunction(cSysUtils, 'AnsiStrIComp', JvInterpreter_AnsiStrIComp, 2, [varEmpty, varEmpty], varEmpty);\r\n AddFunction(cSysUtils, 'AnsiStrLComp', JvInterpreter_AnsiStrLComp, 3, [varEmpty, varEmpty, varEmpty], varEmpty);\r\n AddFunction(cSysUtils, 'AnsiStrLIComp', JvInterpreter_AnsiStrLIComp, 3, [varEmpty, varEmpty, varEmpty], varEmpty);\r\n AddFunction(cSysUtils, 'AnsiStrLower', JvInterpreter_AnsiStrLower, 1, [varEmpty], varEmpty);\r\n AddFunction(cSysUtils, 'AnsiStrUpper', JvInterpreter_AnsiStrUpper, 1, [varEmpty], varEmpty);\r\n AddFunction(cSysUtils, 'AnsiLastChar', JvInterpreter_AnsiLastChar, 1, [varEmpty], varEmpty);\r\n AddFunction(cSysUtils, 'AnsiStrLastChar', JvInterpreter_AnsiStrLastChar, 1, [varEmpty], varEmpty);\r\n\r\n AddFunction(cSysUtils, 'Trim', JvInterpreter_Trim, 1, [varEmpty], varEmpty);\r\n AddFunction(cSysUtils, 'TrimLeft', JvInterpreter_TrimLeft, 1, [varEmpty], varEmpty);\r\n AddFunction(cSysUtils, 'TrimRight', JvInterpreter_TrimRight, 1, [varEmpty], varEmpty);\r\n AddFunction(cSysUtils, 'QuotedStr', JvInterpreter_QuotedStr, 1, [varEmpty], varEmpty);\r\n\r\n AddFunction(cSysUtils, 'AnsiQuotedStr', JvInterpreter_AnsiQuotedStr, 2, [varEmpty, varEmpty], varEmpty);\r\n AddFunction(cSysUtils, 'AnsiExtractQuotedStr', JvInterpreter_AnsiExtractQuotedStr, 2, [varByRef, varEmpty], varEmpty);\r\n AddFunction(cSysUtils, 'ExtractQuotedString', JvInterpreter_ExtractQuotedString, 2, [varEmpty, varEmpty], varEmpty);\r\n\r\n AddFunction(cSysUtils, 'AdjustLineBreaks', JvInterpreter_AdjustLineBreaks, 1, [varEmpty], varEmpty);\r\n AddFunction(cSysUtils, 'IsValidIdent', JvInterpreter_IsValidIdent, 1, [varEmpty], varEmpty);\r\n AddFunction(cSysUtils, 'IntToStr', JvInterpreter_IntToStr, 1, [varEmpty], varEmpty);\r\n AddFunction(cSysUtils, 'IntToHex', JvInterpreter_IntToHex, 2, [varEmpty, varEmpty], varEmpty);\r\n AddFunction(cSysUtils, 'StrToInt', JvInterpreter_StrToInt, 1, [varEmpty], varEmpty);\r\n AddFunction(cSysUtils, 'StrToIntDef', JvInterpreter_StrToIntDef, 2, [varEmpty, varEmpty], varEmpty);\r\n AddFunction(cSysUtils, 'LoadStr', JvInterpreter_LoadStr, 1, [varEmpty], varEmpty);\r\n // AddFunction(cSysUtils, 'FmtLoadStr', JvInterpreter_FmtLoadStr, 2, [varEmpty, varEmpty], varEmpty);\r\n AddFunction(cSysUtils, 'FileOpen', JvInterpreter_FileOpen, 2, [varEmpty, varEmpty], varEmpty);\r\n AddFunction(cSysUtils, 'FileCreate', JvInterpreter_FileCreate, 1, [varEmpty], varEmpty);\r\n AddFunction(cSysUtils, 'FileRead', JvInterpreter_FileRead, 3, [varEmpty, varByRef, varEmpty], varEmpty);\r\n AddFunction(cSysUtils, 'FileWrite', JvInterpreter_FileWrite, 3, [varEmpty, varEmpty, varEmpty], varEmpty);\r\n AddFunction(cSysUtils, 'FileSeek', JvInterpreter_FileSeek, 3, [varEmpty, varEmpty, varEmpty], varEmpty);\r\n AddFunction(cSysUtils, 'FileClose', JvInterpreter_FileClose, 1, [varEmpty], varEmpty);\r\n AddFunction(cSysUtils, 'FileAge', JvInterpreter_FileAge, 1, [varEmpty], varEmpty);\r\n AddFunction(cSysUtils, 'FileExists', JvInterpreter_FileExists, 1, [varEmpty], varEmpty);\r\n AddFunction(cSysUtils, 'FindFirst', JvInterpreter_FindFirst, 3, [varEmpty, varEmpty, varByRef], varEmpty);\r\n AddFunction(cSysUtils, 'FindNext', JvInterpreter_FindNext, 1, [varByRef], varEmpty);\r\n AddFunction(cSysUtils, 'FindClose', JvInterpreter_FindClose, 1, [varByRef], varEmpty);\r\n AddFunction(cSysUtils, 'FileGetDate', JvInterpreter_FileGetDate, 1, [varEmpty], varEmpty);\r\n AddFunction(cSysUtils, 'FileSetDate', JvInterpreter_FileSetDate, 2, [varEmpty, varEmpty], varEmpty);\r\n {$IFDEF MSWINDOWS}\r\n AddFunction(cSysUtils, 'FileGetAttr', JvInterpreter_FileGetAttr, 1, [varEmpty], varEmpty);\r\n AddFunction(cSysUtils, 'FileSetAttr', JvInterpreter_FileSetAttr, 2, [varEmpty, varEmpty], varEmpty);\r\n {$ENDIF MSWINDOWS}\r\n AddFunction(cSysUtils, 'DeleteFile', JvInterpreter_DeleteFile, 1, [varEmpty], varEmpty);\r\n AddFunction(cSysUtils, 'RenameFile', JvInterpreter_RenameFile, 2, [varEmpty, varEmpty], varEmpty);\r\n AddFunction(cSysUtils, 'ChangeFileExt', JvInterpreter_ChangeFileExt, 2, [varEmpty, varEmpty], varEmpty);\r\n AddFunction(cSysUtils, 'ExtractFilePath', JvInterpreter_ExtractFilePath, 1, [varEmpty], varEmpty);\r\n AddFunction(cSysUtils, 'ExtractFileDir', JvInterpreter_ExtractFileDir, 1, [varEmpty], varEmpty);\r\n AddFunction(cSysUtils, 'ExtractFileDrive', JvInterpreter_ExtractFileDrive, 1, [varEmpty], varEmpty);\r\n AddFunction(cSysUtils, 'ExtractFileName', JvInterpreter_ExtractFileName, 1, [varEmpty], varEmpty);\r\n AddFunction(cSysUtils, 'ExtractFileExt', JvInterpreter_ExtractFileExt, 1, [varEmpty], varEmpty);\r\n AddFunction(cSysUtils, 'ExpandFileName', JvInterpreter_ExpandFileName, 1, [varEmpty], varEmpty);\r\n AddFunction(cSysUtils, 'ExpandUNCFileName', JvInterpreter_ExpandUNCFileName, 1, [varEmpty], varEmpty);\r\n\r\n AddFunction(cSysUtils, 'ExtractRelativePath', JvInterpreter_ExtractRelativePath, 2, [varEmpty, varEmpty], varEmpty);\r\n\r\n AddFunction(cSysUtils, 'FileSearch', JvInterpreter_FileSearch, 2, [varEmpty, varEmpty], varEmpty);\r\n {$IFDEF MSWINDOWS}\r\n AddFunction(cSysUtils, 'DiskFree', JvInterpreter_DiskFree, 1, [varEmpty], varEmpty);\r\n AddFunction(cSysUtils, 'DiskSize', JvInterpreter_DiskSize, 1, [varEmpty], varEmpty);\r\n {$ENDIF MSWINDOWS}\r\n AddFunction(cSysUtils, 'FileDateToDateTime', JvInterpreter_FileDateToDateTime, 1, [varEmpty], varEmpty);\r\n AddFunction(cSysUtils, 'DateTimeToFileDate', JvInterpreter_DateTimeToFileDate, 1, [varEmpty], varEmpty);\r\n AddFunction(cSysUtils, 'GetCurrentDir', JvInterpreter_GetCurrentDir, 0, [varEmpty], varEmpty);\r\n AddFunction(cSysUtils, 'SetCurrentDir', JvInterpreter_SetCurrentDir, 1, [varEmpty], varEmpty);\r\n AddFunction(cSysUtils, 'CreateDir', JvInterpreter_CreateDir, 1, [varEmpty], varEmpty);\r\n AddFunction(cSysUtils, 'RemoveDir', JvInterpreter_RemoveDir, 1, [varEmpty], varEmpty);\r\n AddFunction(cSysUtils, 'StrLen', JvInterpreter_StrLen, 1, [varEmpty], varEmpty);\r\n AddFunction(cSysUtils, 'StrEnd', JvInterpreter_StrEnd, 1, [varEmpty], varEmpty);\r\n AddFunction(cSysUtils, 'StrMove', JvInterpreter_StrMove, 3, [varEmpty, varEmpty, varEmpty], varEmpty);\r\n AddFunction(cSysUtils, 'StrCopy', JvInterpreter_StrCopy, 2, [varEmpty, varEmpty], varEmpty);\r\n AddFunction(cSysUtils, 'StrECopy', JvInterpreter_StrECopy, 2, [varEmpty, varEmpty], varEmpty);\r\n AddFunction(cSysUtils, 'StrLCopy', JvInterpreter_StrLCopy, 3, [varEmpty, varEmpty, varEmpty], varEmpty);\r\n AddFunction(cSysUtils, 'StrPCopy', JvInterpreter_StrPCopy, 2, [varEmpty, varEmpty], varEmpty);\r\n AddFunction(cSysUtils, 'StrPLCopy', JvInterpreter_StrPLCopy, 3, [varEmpty, varEmpty, varEmpty], varEmpty);\r\n AddFunction(cSysUtils, 'StrCat', JvInterpreter_StrCat, 2, [varEmpty, varEmpty], varEmpty);\r\n AddFunction(cSysUtils, 'StrLCat', JvInterpreter_StrLCat, 3, [varEmpty, varEmpty, varEmpty], varEmpty);\r\n AddFunction(cSysUtils, 'StrComp', JvInterpreter_StrComp, 2, [varEmpty, varEmpty], varEmpty);\r\n AddFunction(cSysUtils, 'StrIComp', JvInterpreter_StrIComp, 2, [varEmpty, varEmpty], varEmpty);\r\n AddFunction(cSysUtils, 'StrLComp', JvInterpreter_StrLComp, 3, [varEmpty, varEmpty, varEmpty], varEmpty);\r\n AddFunction(cSysUtils, 'StrLIComp', JvInterpreter_StrLIComp, 3, [varEmpty, varEmpty, varEmpty], varEmpty);\r\n AddFunction(cSysUtils, 'StrScan', JvInterpreter_StrScan, 2, [varEmpty, varEmpty], varEmpty);\r\n AddFunction(cSysUtils, 'StrRScan', JvInterpreter_StrRScan, 2, [varEmpty, varEmpty], varEmpty);\r\n AddFunction(cSysUtils, 'StrPos', JvInterpreter_StrPos, 2, [varEmpty, varEmpty], varEmpty);\r\n AddFunction(cSysUtils, 'StrUpper', JvInterpreter_StrUpper, 1, [varEmpty], varEmpty);\r\n AddFunction(cSysUtils, 'StrLower', JvInterpreter_StrLower, 1, [varEmpty], varEmpty);\r\n AddFunction(cSysUtils, 'StrPas', JvInterpreter_StrPas, 1, [varEmpty], varEmpty);\r\n AddFunction(cSysUtils, 'StrAlloc', JvInterpreter_StrAlloc, 1, [varEmpty], varEmpty);\r\n AddFunction(cSysUtils, 'StrBufSize', JvInterpreter_StrBufSize, 1, [varEmpty], varEmpty);\r\n AddFunction(cSysUtils, 'StrNew', JvInterpreter_StrNew, 1, [varEmpty], varEmpty);\r\n AddFunction(cSysUtils, 'StrDispose', JvInterpreter_StrDispose, 1, [varEmpty], varEmpty);\r\n AddFunction(cSysUtils, 'Format', JvInterpreter_Format, 2, [varEmpty, varEmpty], varEmpty);\r\n AddFunction(cSysUtils, 'FmtStr', JvInterpreter_FmtStr, 3, [varByRef, varEmpty, varEmpty], varEmpty);\r\n AddFunction(cSysUtils, 'StrFmt', JvInterpreter_StrFmt, 3, [varEmpty, varEmpty, varEmpty], varEmpty);\r\n AddFunction(cSysUtils, 'StrLFmt', JvInterpreter_StrLFmt, 4, [varEmpty, varEmpty, varEmpty, varEmpty], varEmpty);\r\n AddFunction(cSysUtils, 'FormatBuf', JvInterpreter_FormatBuf, 5, [varByRef, varEmpty, varEmpty, varEmpty, varEmpty],\r\n varEmpty);\r\n AddFunction(cSysUtils, 'FloatToStr', JvInterpreter_FloatToStr, 1, [varEmpty], varEmpty);\r\n AddFunction(cSysUtils, 'CurrToStr', JvInterpreter_CurrToStr, 1, [varEmpty], varEmpty);\r\n AddFunction(cSysUtils, 'FloatToStrF', JvInterpreter_FloatToStrF, 4, [varEmpty, varEmpty, varEmpty, varEmpty], varEmpty);\r\n AddFunction(cSysUtils, 'CurrToStrF', JvInterpreter_CurrToStrF, 3, [varEmpty, varEmpty, varEmpty], varEmpty);\r\n // AddFunction(cSysUtils, 'FloatToText', JvInterpreter_FloatToText, 6, [varEmpty, varEmpty, varEmpty, varEmpty, varEmpty, varEmpty], varEmpty);\r\n AddFunction(cSysUtils, 'FormatFloat', JvInterpreter_FormatFloat, 2, [varEmpty, varEmpty], varEmpty);\r\n AddFunction(cSysUtils, 'FormatCurr', JvInterpreter_FormatCurr, 2, [varEmpty, varEmpty], varEmpty);\r\n // AddFunction(cSysUtils, 'FloatToTextFmt', JvInterpreter_FloatToTextFmt, 4, [varEmpty, varEmpty, varEmpty, varEmpty], varEmpty);\r\n AddFunction(cSysUtils, 'StrToFloat', JvInterpreter_StrToFloat, 1, [varEmpty], varEmpty);\r\n AddFunction(cSysUtils, 'StrToCurr', JvInterpreter_StrToCurr, 1, [varEmpty], varEmpty);\r\n // AddFunction(cSysUtils, 'TextToFloat', JvInterpreter_TextToFloat, 3, [varEmpty, varByRef, varEmpty], varEmpty);\r\n // AddFunction(cSysUtils, 'FloatToDecimal', JvInterpreter_FloatToDecimal, 5, [varByRef, varEmpty, varEmpty, varEmpty, varEmpty], varEmpty);\r\n { AddFunction(cSysUtils, 'DateTimeToTimeStamp', JvInterpreter_DateTimeToTimeStamp, 1, [varEmpty], varEmpty);\r\n AddFunction(cSysUtils, 'TimeStampToDateTime', JvInterpreter_TimeStampToDateTime, 1, [varEmpty], varEmpty);\r\n AddFunction(cSysUtils, 'MSecsToTimeStamp', JvInterpreter_MSecsToTimeStamp, 1, [varEmpty], varEmpty);\r\n AddFunction(cSysUtils, 'TimeStampToMSecs', JvInterpreter_TimeStampToMSecs, 1, [varEmpty], varEmpty); }\r\n AddFunction(cSysUtils, 'EncodeDate', JvInterpreter_EncodeDate, 3, [varEmpty, varEmpty, varEmpty], varEmpty);\r\n AddFunction(cSysUtils, 'EncodeTime', JvInterpreter_EncodeTime, 4, [varEmpty, varEmpty, varEmpty, varEmpty], varEmpty);\r\n AddFunction(cSysUtils, 'DecodeDate', JvInterpreter_DecodeDate, 4, [varEmpty, varByRef, varByRef, varByRef], varEmpty);\r\n AddFunction(cSysUtils, 'DecodeTime', JvInterpreter_DecodeTime, 5, [varEmpty, varByRef, varByRef, varByRef, varByRef],\r\n varEmpty);\r\n { AddFunction(cSysUtils, 'DateTimeToSystemTime', JvInterpreter_DateTimeToSystemTime, 2, [varEmpty, varByRef], varEmpty);\r\n AddFunction(cSysUtils, 'SystemTimeToDateTime', JvInterpreter_SystemTimeToDateTime, 1, [varEmpty], varEmpty); }\r\n AddFunction(cSysUtils, 'DayOfWeek', JvInterpreter_DayOfWeek, 1, [varEmpty], varEmpty);\r\n AddFunction(cSysUtils, 'Date', JvInterpreter_Date, 0, [varEmpty], varEmpty);\r\n AddFunction(cSysUtils, 'Time', JvInterpreter_Time, 0, [varEmpty], varEmpty);\r\n AddFunction(cSysUtils, 'Now', JvInterpreter_Now, 0, [varEmpty], varEmpty);\r\n\r\n AddFunction(cSysUtils, 'IncMonth', JvInterpreter_IncMonth, 2, [varEmpty, varEmpty], varEmpty);\r\n AddFunction(cSysUtils, 'IsLeapYear', JvInterpreter_IsLeapYear, 1, [varEmpty], varEmpty);\r\n\r\n AddFunction(cSysUtils, 'DateToStr', JvInterpreter_DateToStr, 1, [varEmpty], varEmpty);\r\n AddFunction(cSysUtils, 'TimeToStr', JvInterpreter_TimeToStr, 1, [varEmpty], varEmpty);\r\n AddFunction(cSysUtils, 'DateTimeToStr', JvInterpreter_DateTimeToStr, 1, [varEmpty], varEmpty);\r\n AddFunction(cSysUtils, 'StrToDate', JvInterpreter_StrToDate, 1, [varEmpty], varEmpty);\r\n AddFunction(cSysUtils, 'StrToTime', JvInterpreter_StrToTime, 1, [varEmpty], varEmpty);\r\n AddFunction(cSysUtils, 'StrToDateTime', JvInterpreter_StrToDateTime, 1, [varEmpty], varEmpty);\r\n AddFunction(cSysUtils, 'FormatDateTime', JvInterpreter_FormatDateTime, 2, [varEmpty, varEmpty], varEmpty);\r\n AddFunction(cSysUtils, 'DateTimeToString', JvInterpreter_DateTimeToString, 3, [varByRef, varEmpty, varEmpty], varEmpty);\r\n AddFunction(cSysUtils, 'SysErrorMessage', JvInterpreter_SysErrorMessage, 1, [varEmpty], varEmpty);\r\n AddFunction(cSysUtils, 'GetLocaleStr', JvInterpreter_GetLocaleStr, 3, [varEmpty, varEmpty, varEmpty], varEmpty);\r\n AddFunction(cSysUtils, 'GetLocaleChar', JvInterpreter_GetLocaleChar, 3, [varEmpty, varEmpty, varEmpty], varEmpty);\r\n AddFunction(cSysUtils, 'GetFormatSettings', JvInterpreter_GetFormatSettings, 0, [varEmpty], varEmpty);\r\n AddFunction(cSysUtils, 'ExceptObject', JvInterpreter_ExceptObject, 0, [varEmpty], varEmpty);\r\n AddFunction(cSysUtils, 'ExceptAddr', JvInterpreter_ExceptAddr, 0, [varEmpty], varEmpty);\r\n\r\n AddFunction(cSysUtils, 'ExceptionErrorMessage', JvInterpreter_ExceptionErrorMessage, 4, [varEmpty, varEmpty, varEmpty,\r\n varEmpty], varEmpty);\r\n\r\n AddFunction(cSysUtils, 'ShowException', JvInterpreter_ShowException, 2, [varEmpty, varEmpty], varEmpty);\r\n AddFunction(cSysUtils, 'Abort', JvInterpreter_Abort, 0, [varEmpty], varEmpty);\r\n AddFunction(cSysUtils, 'OutOfMemoryError', JvInterpreter_OutOfMemoryError, 0, [varEmpty], varEmpty);\r\n AddFunction(cSysUtils, 'Beep', JvInterpreter_Beep, 0, [varEmpty], varEmpty);\r\n\r\n AddFunction(cSysUtils, 'ByteType', JvInterpreter_ByteType, 2, [varEmpty, varEmpty], varEmpty);\r\n AddFunction(cSysUtils, 'StrByteType', JvInterpreter_StrByteType, 2, [varEmpty, varEmpty], varEmpty);\r\n AddFunction(cSysUtils, 'ByteToCharLen', JvInterpreter_ByteToCharLen, 2, [varEmpty, varEmpty], varEmpty);\r\n AddFunction(cSysUtils, 'CharToByteLen', JvInterpreter_CharToByteLen, 2, [varEmpty, varEmpty], varEmpty);\r\n AddFunction(cSysUtils, 'ByteToCharIndex', JvInterpreter_ByteToCharIndex, 2, [varEmpty, varEmpty], varEmpty);\r\n AddFunction(cSysUtils, 'CharToByteIndex', JvInterpreter_CharToByteIndex, 2, [varEmpty, varEmpty], varEmpty);\r\n AddFunction(cSysUtils, 'IsPathDelimiter', JvInterpreter_IsPathDelimiter, 2, [varEmpty, varEmpty], varEmpty);\r\n AddFunction(cSysUtils, 'IsDelimiter', JvInterpreter_IsDelimiter, 3, [varEmpty, varEmpty, varEmpty], varEmpty);\r\n AddFunction(cSysUtils, 'LastDelimiter', JvInterpreter_LastDelimiter, 2, [varEmpty, varEmpty], varEmpty);\r\n AddFunction(cSysUtils, 'AnsiCompareFileName', JvInterpreter_AnsiCompareFileName, 2, [varEmpty, varEmpty], varEmpty);\r\n AddFunction(cSysUtils, 'AnsiLowerCaseFileName', JvInterpreter_AnsiLowerCaseFileName, 1, [varEmpty], varEmpty);\r\n AddFunction(cSysUtils, 'AnsiUpperCaseFileName', JvInterpreter_AnsiUpperCaseFileName, 1, [varEmpty], varEmpty);\r\n AddFunction(cSysUtils, 'AnsiPos', JvInterpreter_AnsiPos, 2, [varEmpty, varEmpty], varEmpty);\r\n AddFunction(cSysUtils, 'AnsiStrPos', JvInterpreter_AnsiStrPos, 2, [varEmpty, varEmpty], varEmpty);\r\n AddFunction(cSysUtils, 'AnsiStrRScan', JvInterpreter_AnsiStrRScan, 2, [varEmpty, varEmpty], varEmpty);\r\n AddFunction(cSysUtils, 'AnsiStrScan', JvInterpreter_AnsiStrScan, 2, [varEmpty, varEmpty], varEmpty);\r\n AddFunction(cSysUtils, 'LoadPackage', JvInterpreter_LoadPackage, 1, [varEmpty], varEmpty);\r\n AddFunction(cSysUtils, 'UnloadPackage', JvInterpreter_UnloadPackage, 1, [varEmpty], varEmpty);\r\n {$IFDEF MSWINDOWS}\r\n AddFunction(cSysUtils, 'RaiseLastWin32Error', JvInterpreter_RaiseLastWin32Error, 0, [varEmpty], varEmpty);\r\n AddFunction(cSysUtils, 'Win32Check', JvInterpreter_Win32Check, 1, [varEmpty], varEmpty);\r\n {$ENDIF MSWINDOWS}\r\n\r\n { File open modes }\r\n AddConst(cSysUtils, 'fmOpenRead', Ord(fmOpenRead));\r\n AddConst(cSysUtils, 'fmOpenWrite', Ord(fmOpenWrite));\r\n AddConst(cSysUtils, 'fmOpenReadWrite', Ord(fmOpenReadWrite));\r\n {$IFDEF MSWINDOWS}\r\n AddConst(cSysUtils, 'fmShareCompat', Ord(fmShareCompat));\r\n {$ENDIF MSWINDOWS}\r\n AddConst(cSysUtils, 'fmShareExclusive', Ord(fmShareExclusive));\r\n AddConst(cSysUtils, 'fmShareDenyWrite', Ord(fmShareDenyWrite));\r\n {$IFDEF MSWINDOWS}\r\n AddConst(cSysUtils, 'fmShareDenyRead', Ord(fmShareDenyRead));\r\n {$ENDIF MSWINDOWS}\r\n AddConst(cSysUtils, 'fmShareDenyNone', Ord(fmShareDenyNone));\r\n { File attribute constants }\r\n AddConst(cSysUtils, 'faReadOnly', Ord(faReadOnly));\r\n AddConst(cSysUtils, 'faHidden', Ord(faHidden));\r\n AddConst(cSysUtils, 'faSysFile', Ord(faSysFile));\r\n {$IFNDEF COMPILER8_UP}\r\n AddConst(cSysUtils, 'faVolumeID', Ord(faVolumeID)); // deprecated\r\n {$ENDIF !COMPILER8_UP}\r\n AddConst(cSysUtils, 'faDirectory', Ord(faDirectory));\r\n AddConst(cSysUtils, 'faArchive', Ord(faArchive));\r\n AddConst(cSysUtils, 'faAnyFile', Ord(faAnyFile));\r\n\r\n AddRec(cSysUtils, 'TSearchRec', SizeOf(TSearchRec), [\r\n RFD('Time', 0, varInteger),\r\n RFD('Size', 4, varInteger), // Supports only integer size\r\n {$IFDEF DELPHI10_UP}\r\n RFD('Attr', 16, varInteger),\r\n RFD('Name', 20, varString),\r\n RFD('ExcludeAttr', 24, varInteger),\r\n RFD('FindHandle', 28, varInteger)\r\n {$ELSE}\r\n RFD('Attr', 8, varInteger),\r\n RFD('Name', 12, varString),\r\n RFD('ExcludeAttr', 16, varInteger),\r\n RFD('FindHandle', 20, varInteger)\r\n {$ENDIF}\r\n ],\r\n JvInterpreter_NewTSearchRec, JvInterpreter_DisposeTSearchRec, nil);\r\n { regional options }\r\n { global variables are not supported by JvInterpreter :( }\r\n end;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvInterpreter_System.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvInterpreter_System.PAS, released on 2002-07-04.\r\n\r\nThe Initial Developers of the Original Code are: Andrei Prygounkov \r\nCopyright (c) 1999, 2002 Andrei Prygounkov\r\nAll Rights Reserved.\r\n\r\nContributor(s): Peter Fischer-Haase commented as \"pfh\"\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nDescription : JVCL Interpreter version 2\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvInterpreter_System.pas 12461 2009-08-14 17:21:33Z obones $\r\n\r\nunit JvInterpreter_System;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Variants,\r\n JvInterpreter, SysUtils;\r\n\r\nprocedure RegisterJvInterpreterAdapter(JvInterpreterAdapter: TJvInterpreterAdapter);\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvInterpreter_System.pas $';\r\n Revision: '$Revision: 12461 $';\r\n Date: '$Date: 2009-08-14 19:21:33 +0200 (ven. 14 août 2009) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n JvTypes, JvResources;\r\n\r\n{ TObject }\r\n\r\n{ function ClassType: TClass; }\r\n\r\nprocedure TObject_ClassType(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := C2V(TObject(Args.Obj).ClassType);\r\nend;\r\n\r\n{ function ClassName: ShortString; }\r\n\r\nprocedure TObject_ClassName(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TObject(Args.Obj).ClassName;\r\nend;\r\n\r\n{ function ClassNameIs(const Name: string): Boolean; }\r\n\r\nprocedure TObject_ClassNameIs(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TObject(Args.Obj).ClassNameIs(Args.Values[0]);\r\nend;\r\n\r\n{ function ClassParent: TClass; }\r\n\r\nprocedure TObject_ClassParent(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := C2V(TObject(Args.Obj).ClassParent);\r\nend;\r\n\r\n{ function ClassInfo: Pointer; }\r\n\r\nprocedure TObject_ClassInfo(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := P2V(TObject(Args.Obj).ClassInfo);\r\nend;\r\n\r\n{ function InstanceSize: Longint; }\r\n\r\nprocedure TObject_InstanceSize(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TObject(Args.Obj).InstanceSize;\r\nend;\r\n\r\n{ function InheritsFrom(AClass: TClass): Boolean; }\r\n\r\nprocedure TObject_InheritsFrom(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TObject(Args.Obj).InheritsFrom(V2C(Args.Values[0]));\r\nend;\r\n\r\n(*\r\n{ function GetInterface(const IID: TGUID; out Obj): Boolean; }\r\nprocedure TObject_GetInterface(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TObject(Args.Obj).GetInterface(Args.Values[0], Args.Values[1], Args.Values[2]);\r\nend;\r\n*)\r\n\r\n{ TInterfacedObject }\r\n\r\n{ property Read RefCount: Integer }\r\n\r\nprocedure TInterfacedObject_Read_RefCount(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TInterfacedObject(Args.Obj).RefCount;\r\nend;\r\n\r\n{ procedure Move(const Source; var Dest; Count: Integer); }\r\n\r\nprocedure JvInterpreter_Move(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Move(Args.Values[0], Args.Values[1], Args.Values[2]);\r\nend;\r\n\r\n{ function ParamCount: Integer; }\r\n\r\nprocedure JvInterpreter_ParamCount(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := ParamCount;\r\nend;\r\n\r\n{ function ParamStr(Index: Integer): string; }\r\n\r\nprocedure JvInterpreter_ParamStr(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := ParamStr(Args.Values[0]);\r\nend;\r\n\r\n{ procedure Randomize; }\r\n\r\nprocedure JvInterpreter_Randomize(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Randomize;\r\nend;\r\n\r\nprocedure JvInterpreter_Random(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := Random(Integer(Args.Values[0]));\r\nend;\r\n\r\n{ function UpCase(Ch: Char): Char; }\r\n\r\nprocedure JvInterpreter_UpCase(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := UpCase(string(Args.Values[0])[1]);\r\nend;\r\n\r\n(*\r\n{ function WideCharToString(Source: PWideChar): string; }\r\nprocedure JvInterpreter_WideCharToString(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := WideCharToString(Args.Values[0]);\r\nend;\r\n\r\n{ function WideCharLenToString(Source: PWideChar; SourceLen: Integer): string; }\r\nprocedure JvInterpreter_WideCharLenToString(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := WideCharLenToString(Args.Values[0], Args.Values[1]);\r\nend;\r\n\r\n{ procedure WideCharToStrVar(Source: PWideChar; var Dest: string); }\r\nprocedure JvInterpreter_WideCharToStrVar(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n WideCharToStrVar(Args.Values[0], string(TVarData(Args.Values[1]).vString));\r\nend;\r\n\r\n{ procedure WideCharLenToStrVar(Source: PWideChar; SourceLen: Integer; var Dest: string); }\r\nprocedure JvInterpreter_WideCharLenToStrVar(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n WideCharLenToStrVar(Args.Values[0], Args.Values[1], string(TVarData(Args.Values[2]).vString));\r\nend;\r\n\r\n{ function StringToWideChar(const Source: string; Dest: PWideChar; DestSize: Integer): PWideChar; }\r\nprocedure JvInterpreter_StringToWideChar(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := StringToWideChar(Args.Values[0], Args.Values[1], Args.Values[2]);\r\nend;\r\n\r\n{ function OleStrToString(Source: PWideChar): string; }\r\nprocedure JvInterpreter_OleStrToString(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := OleStrToString(Args.Values[0]);\r\nend;\r\n\r\n{ procedure OleStrToStrVar(Source: PWideChar; var Dest: string); }\r\nprocedure JvInterpreter_OleStrToStrVar(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n OleStrToStrVar(Args.Values[0], string(TVarData(Args.Values[1]).vString));\r\nend;\r\n\r\n{ function StringToOleStr(const Source: string): PWideChar; }\r\nprocedure JvInterpreter_StringToOleStr(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := StringToOleStr(Args.Values[0]);\r\nend;\r\n*)\r\n\r\n{ function VarType(const V: Variant): Integer; }\r\n\r\nprocedure JvInterpreter_VarType(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := VarType(Args.Values[0]);\r\nend;\r\n\r\n{ function VarAsType(const V: Variant; VarType: Integer): Variant; }\r\n\r\nprocedure JvInterpreter_VarAsType(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := VarAsType(Args.Values[0], Args.Values[1]);\r\nend;\r\n\r\n{ function VarIsEmpty(const V: Variant): Boolean; }\r\n\r\nprocedure JvInterpreter_VarIsEmpty(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := VarIsEmpty(Args.Values[0]);\r\nend;\r\n\r\n{ function VarIsNull(const V: Variant): Boolean; }\r\n\r\nprocedure JvInterpreter_VarIsNull(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := VarIsNull(Args.Values[0]);\r\nend;\r\n\r\n{ function VarToStr(const V: Variant): string; }\r\n\r\nprocedure JvInterpreter_VarToStr(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := VarToStr(Args.Values[0]);\r\nend;\r\n\r\n{ function VarFromDateTime(DateTime: TDateTime): Variant; }\r\n\r\nprocedure JvInterpreter_VarFromDateTime(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := VarFromDateTime(Args.Values[0]);\r\nend;\r\n\r\n{ function VarToDateTime(const V: Variant): TDateTime; }\r\n\r\nprocedure JvInterpreter_VarToDateTime(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := VarToDateTime(Args.Values[0]);\r\nend;\r\n\r\n{ function VarArrayCreate(const Bounds: array of Integer; VarType: Integer): Variant; }\r\n\r\nprocedure JvInterpreter_VarArrayCreate(var Value: Variant; Args: TJvInterpreterArgs);\r\nvar\r\n OA: TOpenArray;\r\n OAV: TValueArray;\r\n OAS: Integer;\r\n I: Integer;\r\n AI: array of Integer;\r\nbegin\r\n V2OA(Args.Values[0], OA, OAV, OAS);\r\n if Odd(OAS) then\r\n raise EJVCLException.CreateRes(@RsESizeMustBeEven);\r\n SetLength(AI, OAS);\r\n for I := 0 to OAS -1 do\r\n AI[I] := OAV[I];\r\n Value := VarArrayCreate(AI, Args.Values[1]);\r\nend;\r\n\r\n{function VarArrayOf(const Values: array of Variant): Variant; }\r\nprocedure JvInterpreter_VarArrayOf(var Value: Variant; Args: TJvInterpreterArgs);\r\nvar\r\n OA: TOpenArray;\r\n OAV: TValueArray;\r\n OAS: Integer;\r\n I: Integer;\r\n AV: array of Variant;\r\nbegin\r\n V2OA(Args.Values[0], OA, OAV, OAS);\r\n SetLength(AV, OAS);\r\n for I := 0 to OAS -1 do\r\n AV[I] := OAV[I];\r\n Value := VarArrayOf(AV);\r\nend;\r\n\r\n{ function VarArrayDimCount(const A: Variant): Integer; }\r\nprocedure JvInterpreter_VarArrayDimCount(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := VarArrayDimCount(Args.Values[0]);\r\nend;\r\n\r\n{ function VarArrayLowBound(const A: Variant; Dim: Integer): Integer; }\r\nprocedure JvInterpreter_VarArrayLowBound(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := VarArrayLowBound(Args.Values[0], Args.Values[1]);\r\nend;\r\n\r\n{ function VarArrayHighBound(const A: Variant; Dim: Integer): Integer; }\r\nprocedure JvInterpreter_VarArrayHighBound(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := VarArrayHighBound(Args.Values[0], Args.Values[1]);\r\nend;\r\n\r\n(*{ function VarArrayLock(const A: Variant): Pointer; }\r\nprocedure JvInterpreter_VarArrayLock(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := P2V(VarArrayLock(Args.Values[0]));\r\nend;\r\n\r\n{ procedure VarArrayUnlock(const A: Variant); }\r\nprocedure JvInterpreter_VarArrayUnlock(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n VarArrayUnlock(Args.Values[0]);\r\nend;\r\n\r\n{ function VarArrayRef(const A: Variant): Variant; }\r\nprocedure JvInterpreter_VarArrayRef(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := VarArrayRef(Args.Values[0]);\r\nend;*)\r\n\r\n{ function VarIsArray(const A: Variant): Boolean; }\r\nprocedure JvInterpreter_VarIsArray(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := VarIsArray(Args.Values[0]);\r\nend;\r\n\r\n{ function Ord(const A: Variant): Integer; }\r\n\r\nprocedure JvInterpreter_Ord(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n if VarType(Args.Values[0]) = varString then\r\n Value := Ord(VarToStr(Args.Values[0])[1])\r\n else\r\n Value := Integer(Args.Values[0]);\r\nend;\r\n\r\n{ function Chr(X: Byte): Char }\r\n\r\nprocedure JvInterpreter_Chr(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := Chr(Byte(Args.Values[0]));\r\nend;\r\n\r\n{ function Abs(X); }\r\n\r\nprocedure JvInterpreter_Abs(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n if VarType(Args.Values[0]) = varInteger then\r\n Value := Abs(Integer(Args.Values[0]))\r\n else\r\n Value := Abs(Extended(Args.Values[0]));\r\nend;\r\n\r\n{ function Length(S): Integer; }\r\n\r\nprocedure JvInterpreter_Length(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n if VarIsArray(Args.Values[0]) then\r\n begin\r\n if VarArrayDimCount(Args.Values[0]) > 1 then\r\n raise EJVCLException.CreateRes(@RsESorryForOneDimensionalArraysOnly);\r\n Value := VarArrayHighBound(Args.Values[0], 1) - VarArrayLowBound(Args.Values[0], 1) + 1;\r\n end\r\n else\r\n if TVarData(Args.Values[0]).vType = varArray then\r\n Value := JvInterpreterArrayLength(Args.Values[0])\r\n else\r\n Value := Length(Args.Values[0]);\r\nend;\r\n\r\n{ function Copy(S; Index, Count: Integer): String; }\r\n\r\nprocedure JvInterpreter_Copy(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := Copy(Args.Values[0], Integer(Args.Values[1]), Integer(Args.Values[2]));\r\nend;\r\n\r\n{ function Round(Value: Extended): Int64; }\r\n\r\nprocedure JvInterpreter_Round(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := Integer(Round(Args.Values[0]));\r\nend;\r\n\r\n{ function Trunc(Value: Extended): Int64; }\r\n\r\nprocedure JvInterpreter_Trunc(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := Integer(Trunc(Args.Values[0]));\r\nend;\r\n\r\n{ function Pos(Substr: string; S: string): Integer; }\r\n\r\nprocedure JvInterpreter_Pos(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := Pos(string(Args.Values[0]), string(Args.Values[1]));\r\nend;\r\n\r\n//+++pfh\r\n{procedure Delete(var S: string; Index, Count: Integer);}\r\n\r\nprocedure JvInterpreter_Delete(var Value: Variant; Args: TJvInterpreterArgs);\r\nvar\r\n S: string;\r\nbegin\r\n S := Args.Values[0];\r\n Delete(S, Integer(Args.Values[1]), Integer(Args.Values[2]));\r\n Args.Values[0] := S;\r\n Value := S;\r\nend;\r\n\r\n{procedure Insert(Source: string; var S: string; Index: Integer);}\r\n\r\nprocedure JvInterpreter_Insert(var Value: Variant; Args: TJvInterpreterArgs);\r\nvar\r\n S: string;\r\nbegin\r\n S := Args.Values[1];\r\n Insert(string(Args.Values[0]), S, Integer(Args.Values[2]));\r\n Args.Values[1] := S;\r\n Value := S;\r\nend;\r\n\r\n{ function Sqr(X: Extended): Extended; }\r\n\r\nprocedure JvInterpreter_Sqr(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := Sqr(Args.Values[0]);\r\nend;\r\n\r\n{ function Sqrt(X: Extended): Extended; }\r\n\r\nprocedure JvInterpreter_Sqrt(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := Sqrt(Args.Values[0]);\r\nend;\r\n\r\n{ function Exp(X: Extended): Extended; }\r\n\r\nprocedure JvInterpreter_Exp(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := Exp(Args.Values[0]);\r\nend;\r\n\r\n{ function Ln(X: Extended): Extended; }\r\n\r\nprocedure JvInterpreter_Ln(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := Ln(Args.Values[0]);\r\nend;\r\n\r\n{ function Sin(X: Extended): Extended; }\r\n\r\nprocedure JvInterpreter_Sin(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := Sin(Args.Values[0]);\r\nend;\r\n\r\n{ function Cos(X: Extended): Extended; }\r\n\r\nprocedure JvInterpreter_Cos(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := Cos(Args.Values[0]);\r\nend;\r\n\r\n{ function Tan(X: Extended): Extended; }\r\n\r\nprocedure JvInterpreter_Tan(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n//(p3) Tan() is defined in Math.pas which isn't available in all Delphi SKU's\r\n// Tan(X) = Sin(X)/ Cos(X)\r\n Value := Sin(Args.Values[0]) / Cos(Args.Values[0]);\r\nend;\r\n\r\n{ function ArcTan(X: Extended): Extended; }\r\n\r\nprocedure JvInterpreter_ArcTan(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := ArcTan(Args.Values[0]);\r\nend;\r\n//---pfh\r\n\r\n{ procedure SetLength(var s: ShortString; newLength: Integer); }\r\n\r\nprocedure JvInterpreter_SetLength(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n if TVarData(Args.Values[0]).vType <> varArray then\r\n SetLength(string(TVarData(Args.Values[0]).vString), Integer(Args.Values[1]))\r\n else\r\n JvInterpreterArraySetLength(Args.Values[0], Integer(Args.Values[1]));\r\nend;\r\n\r\n{procedure High(var Value: Variant; Args: TJvInterpreterArgs);}\r\n\r\nprocedure JvInterpreter_High(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n if VarIsArray(Args.Values[0]) then\r\n begin\r\n if VarArrayDimCount(Args.Values[0]) > 1 then\r\n raise EJVCLException.CreateRes(@RsESorryForOneDimensionalArraysOnly);\r\n Value := VarArrayLowBound(Args.Values[0], 1);\r\n end\r\n else\r\n Value := JvInterpreterArrayHigh(Args.Values[0]);\r\nend;\r\n\r\n{procedure Low(var Value: Variant; Args: TJvInterpreterArgs);}\r\n\r\nprocedure JvInterpreter_Low(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n if VarIsArray(Args.Values[0]) then\r\n begin\r\n if VarArrayDimCount(Args.Values[0]) > 1 then\r\n raise EJVCLException.CreateRes(@RsESorryForOneDimensionalArraysOnly);\r\n Value := VarArrayLowBound(Args.Values[0], 1);\r\n end\r\n else\r\n Value := JvInterpreterArrayLow(Args.Values[0]);\r\nend;\r\n\r\n{procedure DeleteFromArray(var Value: Variant; Args: TJvInterpreterArgs);}\r\n\r\nprocedure JvInterpreter_DeleteFromArray(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n JvInterpreterArrayElementDelete(Args.Values[0], Integer(Args.Values[1]));\r\nend;\r\n\r\n{procedure InsertIntoArray(var Value: Variant; Args: TJvInterpreterArgs);}\r\n\r\nprocedure JvInterpreter_InsertIntoArray(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n JvInterpreterArrayElementInsert(Args.Values[0], Integer(Args.Values[1]), Args.Values[2]);\r\nend;\r\n\r\nprocedure RegisterJvInterpreterAdapter(JvInterpreterAdapter: TJvInterpreterAdapter);\r\nconst\r\n cSystem = 'System';\r\nbegin\r\n with JvInterpreterAdapter do\r\n begin\r\n { TObject }\r\n AddClass(cSystem, TObject, 'TObject');\r\n AddGet(TObject, 'ClassType', TObject_ClassType, 0, [varEmpty], varEmpty);\r\n AddGet(TObject, 'ClassName', TObject_ClassName, 0, [varEmpty], varEmpty);\r\n AddGet(TObject, 'ClassNameIs', TObject_ClassNameIs, 1, [varEmpty], varEmpty);\r\n AddGet(TObject, 'ClassParent', TObject_ClassParent, 0, [varEmpty], varEmpty);\r\n AddGet(TObject, 'ClassInfo', TObject_ClassInfo, 0, [varEmpty], varEmpty);\r\n AddGet(TObject, 'InstanceSize', TObject_InstanceSize, 0, [varEmpty], varEmpty);\r\n AddGet(TObject, 'InheritsFrom', TObject_InheritsFrom, 1, [varEmpty], varEmpty);\r\n // AddGet(TObject, 'GetInterface', TObject_GetInterface, 3, [varEmpty, varEmpty, varEmpty], varEmpty);\r\n { TInterfacedObject }\r\n AddClass(cSystem, TInterfacedObject, 'TInterfacedObject');\r\n AddGet(TInterfacedObject, 'RefCount', TInterfacedObject_Read_RefCount, 0, [varEmpty], varEmpty);\r\n AddFunction(cSystem, 'Move', JvInterpreter_Move, 3, [varEmpty, varByRef, varEmpty], varEmpty);\r\n AddFunction(cSystem, 'ParamCount', JvInterpreter_ParamCount, 0, [varEmpty], varEmpty);\r\n AddFunction(cSystem, 'ParamStr', JvInterpreter_ParamStr, 1, [varEmpty], varEmpty);\r\n AddFunction(cSystem, 'Randomize', JvInterpreter_Randomize, 0, [varEmpty], varEmpty);\r\n AddFunction(cSystem, 'Random', JvInterpreter_Random, 1, [varInteger], varEmpty);\r\n AddFunction(cSystem, 'UpCase', JvInterpreter_UpCase, 1, [varEmpty], varEmpty);\r\n { AddFunction(cSystem, 'WideCharToString', JvInterpreter_WideCharToString, 1, [varEmpty], varEmpty);\r\n AddFunction(cSystem, 'WideCharLenToString', JvInterpreter_WideCharLenToString, 2, [varEmpty, varEmpty], varEmpty);\r\n AddFunction(cSystem, 'WideCharToStrVar', JvInterpreter_WideCharToStrVar, 2, [varEmpty, varByRef], varEmpty);\r\n AddFunction(cSystem, 'WideCharLenToStrVar', JvInterpreter_WideCharLenToStrVar, 3, [varEmpty, varEmpty, varByRef], varEmpty);\r\n AddFunction(cSystem, 'StringToWideChar', JvInterpreter_StringToWideChar, 3, [varEmpty, varEmpty, varEmpty], varEmpty);\r\n AddFunction(cSystem, 'OleStrToString', JvInterpreter_OleStrToString, 1, [varEmpty], varEmpty);\r\n AddFunction(cSystem, 'OleStrToStrVar', JvInterpreter_OleStrToStrVar, 2, [varEmpty, varByRef], varEmpty);\r\n AddFunction(cSystem, 'StringToOleStr', JvInterpreter_StringToOleStr, 1, [varEmpty], varEmpty); }\r\n AddFunction(cSystem, 'VarType', JvInterpreter_VarType, 1, [varEmpty], varEmpty);\r\n AddFunction(cSystem, 'VarAsType', JvInterpreter_VarAsType, 2, [varEmpty, varEmpty], varEmpty);\r\n AddFunction(cSystem, 'VarIsEmpty', JvInterpreter_VarIsEmpty, 1, [varEmpty], varEmpty);\r\n AddFunction(cSystem, 'VarIsNull', JvInterpreter_VarIsNull, 1, [varEmpty], varEmpty);\r\n AddFunction(cSystem, 'VarToStr', JvInterpreter_VarToStr, 1, [varEmpty], varEmpty);\r\n AddFunction(cSystem, 'VarFromDateTime', JvInterpreter_VarFromDateTime, 1, [varEmpty], varEmpty);\r\n AddFunction(cSystem, 'VarToDateTime', JvInterpreter_VarToDateTime, 1, [varEmpty], varEmpty);\r\n AddFunction(cSystem, 'VarArrayCreate', JvInterpreter_VarArrayCreate, 2, [varEmpty, varEmpty], varEmpty);\r\n AddFunction(cSystem, 'VarArrayOf', JvInterpreter_VarArrayOf, 1, [varEmpty], varEmpty);\r\n AddFunction(cSystem, 'VarArrayDimCount', JvInterpreter_VarArrayDimCount, 1, [varEmpty], varEmpty);\r\n AddFunction(cSystem, 'VarArrayLowBound', JvInterpreter_VarArrayLowBound, 2, [varEmpty, varEmpty], varEmpty);\r\n AddFunction(cSystem, 'VarArrayHighBound', JvInterpreter_VarArrayHighBound, 2, [varEmpty, varEmpty], varEmpty);\r\n {AddFunction(cSystem, 'VarArrayLock', JvInterpreter_VarArrayLock, 1, [varEmpty], varEmpty);\r\n AddFunction(cSystem, 'VarArrayUnlock', JvInterpreter_VarArrayUnlock, 1, [varEmpty], varEmpty);\r\n AddFunction(cSystem, 'VarArrayRef', JvInterpreter_VarArrayRef, 1, [varEmpty], varEmpty);}\r\n AddFunction(cSystem, 'VarIsArray', JvInterpreter_VarIsArray, 1, [varEmpty], varEmpty);\r\n AddFunction(cSystem, 'ord', JvInterpreter_Ord, 1, [varEmpty], varEmpty);\r\n\r\n AddFunction(cSystem, 'Chr', JvInterpreter_Chr, 1, [varEmpty], varEmpty);\r\n AddFunction(cSystem, 'Abs', JvInterpreter_Abs, 1, [varEmpty], varEmpty);\r\n AddFunction(cSystem, 'Length', JvInterpreter_Length, 1, [varEmpty], varEmpty);\r\n AddFunction(cSystem, 'Copy', JvInterpreter_Copy, 3, [varEmpty, varEmpty, varEmpty], varEmpty);\r\n AddFunction(cSystem, 'Round', JvInterpreter_Round, 1, [varEmpty], varEmpty);\r\n AddFunction(cSystem, 'Trunc', JvInterpreter_Trunc, 1, [varEmpty], varEmpty);\r\n AddFunction(cSystem, 'Pos', JvInterpreter_Pos, 2, [varEmpty, varEmpty], varEmpty);\r\n\r\n //+++pfh\r\n // some string functions\r\n AddFunction(cSystem, 'Delete', JvInterpreter_Delete, 3, [varByRef, varEmpty, varEmpty], varEmpty);\r\n AddFunction(cSystem, 'Insert', JvInterpreter_Insert, 3, [varEmpty, varByRef, varEmpty], varEmpty);\r\n // some math functions\r\n AddFunction(cSystem, 'Sqr', JvInterpreter_Sqr, 1, [varEmpty], varEmpty);\r\n AddFunction(cSystem, 'Sqrt', JvInterpreter_Sqrt, 1, [varEmpty], varEmpty);\r\n AddFunction(cSystem, 'Exp', JvInterpreter_Exp, 1, [varEmpty], varEmpty);\r\n AddFunction(cSystem, 'Ln', JvInterpreter_Ln, 1, [varEmpty], varEmpty);\r\n AddFunction(cSystem, 'Sin', JvInterpreter_Sin, 1, [varEmpty], varEmpty);\r\n AddFunction(cSystem, 'Cos', JvInterpreter_Cos, 1, [varEmpty], varEmpty);\r\n AddFunction(cSystem, 'Tan', JvInterpreter_Tan, 1, [varEmpty], varEmpty);\r\n AddFunction(cSystem, 'ArcTan', JvInterpreter_ArcTan, 1, [varEmpty], varEmpty);\r\n //---pfh\r\n AddFunction(cSystem, 'SetLength', JvInterpreter_SetLength, 2, [varByRef or varString or varArray, varInteger], varEmpty);\r\n AddFunction(cSystem, 'High', JvInterpreter_High, 1, [varEmpty], varEmpty);\r\n AddFunction(cSystem, 'Low', JvInterpreter_Low, 1, [varEmpty], varEmpty);\r\n AddFunction(cSystem, 'DeleteFromArray', JvInterpreter_DeleteFromArray, 2, [varEmpty, varEmpty], varEmpty);\r\n AddFunction(cSystem, 'InsertIntoArray', JvInterpreter_InsertIntoArray, 3, [varEmpty, varEmpty, varEmpty], varEmpty);\r\n //\r\n AddConst(cSystem, 'varEmpty', Ord(varEmpty));\r\n AddConst(cSystem, 'varSmallint', Ord(varSmallint));\r\n AddConst(cSystem, 'varInteger', Ord(varInteger));\r\n AddConst(cSystem, 'varSingle', Ord(varSingle));\r\n AddConst(cSystem, 'varCurrency', Ord(varCurrency));\r\n AddConst(cSystem, 'varDouble', Ord(varDouble));\r\n AddConst(cSystem, 'varDate', Ord(varDate));\r\n AddConst(cSystem, 'varOleStr', Ord(varOleStr));\r\n AddConst(cSystem, 'varDispatch', Ord(varDispatch));\r\n AddConst(cSystem, 'varError', Ord(varError));\r\n AddConst(cSystem, 'varBoolean', Ord(varBoolean));\r\n AddConst(cSystem, 'varVariant', Ord(varVariant));\r\n AddConst(cSystem, 'varUnknown', Ord(varUnknown));\r\n AddConst(cSystem, 'varByte', Ord(varByte));\r\n AddConst(cSystem, 'varStrArg', Ord(varStrArg));\r\n AddConst(cSystem, 'varSrting', Ord(varString));\r\n AddConst(cSystem, 'varAny', Ord(varAny));\r\n AddConst(cSystem, 'varTypeMask', Ord(varTypeMask));\r\n AddConst(cSystem, 'varArray', Ord(varArray));\r\n AddConst(cSystem, 'varByRef', Ord(varByRef));\r\n AddConst(cSystem, 'varShortInt', Ord(varShortInt));\r\n AddConst(cSystem, 'varWord', Ord(varWord));\r\n AddConst(cSystem, 'varLongWord', Ord(varLongWord));\r\n AddConst(cSystem, 'varInt64', Ord(varInt64));\r\n end;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvInterpreter_Types.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvInterpreter_Types.PAS, released on 2002-07-04.\r\n\r\nThe Initial Developers of the Original Code are: Andrei Prygounkov \r\nCopyright (c) 1999, 2002 Andrei Prygounkov\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nDescription : adapter unit - converts JvInterpreter calls to delphi calls\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvInterpreter_Types.pas 12461 2009-08-14 17:21:33Z obones $\r\n\r\nunit JvInterpreter_Types;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Types, Variants,\r\n JvInterpreter;\r\n\r\nfunction Point2Var(const Point: TPoint): Variant;\r\nfunction Var2Point(const Point: Variant): TPoint;\r\nfunction Rect2Var(const Rect: TRect): Variant;\r\nfunction Var2Rect(const Rect: Variant): TRect;\r\n\r\nprocedure RegisterJvInterpreterAdapter(JvInterpreterAdapter: TJvInterpreterAdapter);\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvInterpreter_Types.pas $';\r\n Revision: '$Revision: 12461 $';\r\n Date: '$Date: 2009-08-14 19:21:33 +0200 (ven. 14 août 2009) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\n\r\nconst\r\n cTRect = 'TRect';\r\n cTPoint = 'TPoint';\r\n\r\n{ TPoint }\r\n\r\nfunction Point2Var(const Point: TPoint): Variant;\r\nvar\r\n Rec: ^TPoint;\r\nbegin\r\n New(Rec);\r\n Rec^ := Point;\r\n Result := R2V(cTPoint, Rec);\r\nend;\r\n\r\nfunction Var2Point(const Point: Variant): TPoint;\r\nbegin\r\n Result := TPoint(V2R(Point)^);\r\nend;\r\n\r\nprocedure JvInterpreter_Point(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := Point2Var(Point(Args.Values[0], Args.Values[1]));\r\nend;\r\n\r\n{ TRect }\r\n\r\nfunction Rect2Var(const Rect: TRect): Variant;\r\nvar\r\n Rec: ^TRect;\r\nbegin\r\n New(Rec);\r\n Rec^ := Rect;\r\n Result := R2V(cTRect, Rec);\r\nend;\r\n\r\nfunction Var2Rect(const Rect: Variant): TRect;\r\nbegin\r\n Result := TRect(V2R(Rect)^);\r\nend;\r\n\r\nprocedure JvInterpreter_Rect(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := Rect2Var(Rect(Args.Values[0], Args.Values[1], Args.Values[2], Args.Values[3]));\r\nend;\r\n\r\nprocedure JvInterpreter_Bounds(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := Rect2Var(Bounds(Args.Values[0], Args.Values[1], Args.Values[2], Args.Values[3]));\r\nend;\r\n\r\n{ Read Field TopLeft: Integer; }\r\n\r\nprocedure TRect_Read_TopLeft(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := Point2Var(TRect(P2R(Args.Obj)^).TopLeft);\r\nend;\r\n\r\n{ Write Field TopLeft: Integer; }\r\n\r\nprocedure TRect_Write_TopLeft(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TRect(P2R(Args.Obj)^).TopLeft := Var2Point(Value);\r\nend;\r\n\r\n{ Read Field BottomRight: Integer; }\r\n\r\nprocedure TRect_Read_BottomRight(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := Point2Var(TRect(P2R(Args.Obj)^).BottomRight);\r\nend;\r\n\r\n{ Write Field Right: Integer; }\r\n\r\nprocedure TRect_Write_BottomRight(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TRect(P2R(Args.Obj)^).BottomRight := Var2Point(Value);\r\nend;\r\n\r\nprocedure RegisterJvInterpreterAdapter(JvInterpreterAdapter: TJvInterpreterAdapter);\r\nconst\r\n cTypes = 'Types';\r\nbegin\r\n with JvInterpreterAdapter do\r\n begin\r\n AddExtUnit(cTypes);\r\n { TPoint }\r\n AddRec(cTypes, cTPoint, SizeOf(TPoint), [RFD('X', 0, varInteger), RFD('Y', 4, varInteger)], nil, nil, nil);\r\n AddFunction(cTypes, 'Point', JvInterpreter_Point, 2, [varInteger, varInteger], varRecord);\r\n { TRect }\r\n AddRec(cTypes, cTRect, SizeOf(TRect), [RFD('Left', 0, varInteger), RFD('Top', 4, varInteger),\r\n RFD('Right', 8, varInteger), RFD('Bottom', 12, varInteger)], nil, nil, nil);\r\n AddFunction(cTypes, 'Rect', JvInterpreter_Rect, 4, [varInteger, varInteger, varInteger, varInteger], varRecord);\r\n AddFunction(cTypes, 'Bounds', JvInterpreter_Bounds, 4, [varInteger, varInteger, varInteger, varInteger], varRecord);\r\n AddRecGet(cTypes, cTRect, 'TopLeft', TRect_Read_TopLeft, 0, [varEmpty], varRecord);\r\n AddRecSet(cTypes, cTRect, 'TopLeft', TRect_Write_TopLeft, 0, [varEmpty]);\r\n AddRecGet(cTypes, cTRect, 'BottomRight', TRect_Read_BottomRight, 0, [varEmpty], varRecord);\r\n AddRecSet(cTypes, cTRect, 'BottomRight', TRect_Write_BottomRight, 0, [varEmpty]);\r\n end;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvInterpreter_Windows.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvInterpreter_Windows.PAS, released on 2002-07-04.\r\n\r\nThe Initial Developers of the Original Code are: Andrei Prygounkov \r\nCopyright (c) 1999, 2002 Andrei Prygounkov\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nDescription : adapter unit - converts JvInterpreter calls to delphi calls\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvInterpreter_Windows.pas 13104 2011-09-07 06:50:43Z obones $\r\n\r\nunit JvInterpreter_Windows;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, Types,\r\n JvInterpreter;\r\n\r\nfunction Point2Var(const Point: TPoint): Variant;\r\nfunction Var2Point(const Point: Variant): TPoint;\r\nfunction Rect2Var(const Rect: TRect): Variant;\r\nfunction Var2Rect(const Rect: Variant): TRect;\r\n\r\nprocedure RegisterJvInterpreterAdapter(JvInterpreterAdapter: TJvInterpreterAdapter);\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvInterpreter_Windows.pas $';\r\n Revision: '$Revision: 13104 $';\r\n Date: '$Date: 2011-09-07 08:50:43 +0200 (mer. 07 sept. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n Classes;\r\n\r\n{ TPoint }\r\n\r\nfunction Point2Var(const Point: TPoint): Variant;\r\nvar\r\n Rec: ^TPoint;\r\nbegin\r\n New(Rec);\r\n Rec^ := Point;\r\n Result := R2V('TPoint', Rec);\r\nend;\r\n\r\nfunction Var2Point(const Point: Variant): TPoint;\r\nbegin\r\n Result := TPoint(V2R(Point)^);\r\nend;\r\n\r\nprocedure JvInterpreter_Point(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n JvInterpreterVarCopy(Value, Point2Var(Point(Args.Values[0], Args.Values[1])));\r\nend;\r\n\r\n{ TRect }\r\n\r\nfunction Rect2Var(const Rect: TRect): Variant;\r\nvar\r\n Rec: ^TRect;\r\nbegin\r\n New(Rec);\r\n Rec^ := Rect;\r\n Result := R2V('TRect', Rec);\r\nend;\r\n\r\nfunction Var2Rect(const Rect: Variant): TRect;\r\nbegin\r\n Result := TRect(V2R(Rect)^);\r\nend;\r\n\r\nprocedure JvInterpreter_Rect(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n JvInterpreterVarCopy(Value, Rect2Var(Rect(Args.Values[0], Args.Values[1], Args.Values[2], Args.Values[3])));\r\nend;\r\n\r\nprocedure JvInterpreter_Bounds(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n JvInterpreterVarCopy(Value, Rect2Var(Bounds(Args.Values[0], Args.Values[1], Args.Values[2], Args.Values[3])));\r\nend;\r\n\r\n{ Read Field TopLeft: Integer; }\r\n\r\nprocedure TRect_Read_TopLeft(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := Point2Var(TRect(P2R(Args.Obj)^).TopLeft);\r\nend;\r\n\r\n{ Write Field TopLeft: Integer; }\r\n\r\nprocedure TRect_Write_TopLeft(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TRect(P2R(Args.Obj)^).TopLeft := Var2Point(Value);\r\nend;\r\n\r\n{ Read Field BottomRight: Integer; }\r\n\r\nprocedure TRect_Read_BottomRight(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := Point2Var(TRect(P2R(Args.Obj)^).BottomRight);\r\nend;\r\n\r\n{ Write Field Right: Integer; }\r\n\r\nprocedure TRect_Write_BottomRight(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TRect(P2R(Args.Obj)^).BottomRight := Var2Point(Value);\r\nend;\r\n\r\nprocedure RegisterJvInterpreterAdapter(JvInterpreterAdapter: TJvInterpreterAdapter);\r\nconst\r\n cWindows = 'Windows';\r\nbegin\r\n with JvInterpreterAdapter do\r\n begin\r\n AddExtUnit(cWindows);\r\n { TPoint }\r\n AddRec(cWindows, 'TPoint', SizeOf(TPoint), [RFD('X', 0, varInteger), RFD('Y', 4, varInteger)], nil, nil, nil);\r\n AddFunction(cWindows, 'Point', JvInterpreter_Point, 2, [varInteger, varInteger], varRecord);\r\n { TRect }\r\n AddRec(cWindows, 'TRect', SizeOf(TRect), [RFD('Left', 0, varInteger), RFD('Top', 4, varInteger), RFD('Right', 8,\r\n varInteger), RFD('Bottom', 12, varInteger)], nil, nil, nil);\r\n AddFunction(cWindows, 'Rect', JvInterpreter_Rect, 4, [varInteger, varInteger, varInteger, varInteger], varRecord);\r\n AddFunction(cWindows, 'Bounds', JvInterpreter_Bounds, 4, [varInteger, varInteger, varInteger, varInteger], varRecord);\r\n AddRecGet(cWindows, 'TRect', 'TopLeft', TRect_Read_TopLeft, 0, [varEmpty], varRecord);\r\n AddRecSet(cWindows, 'TRect', 'TopLeft', TRect_Write_TopLeft, 0, [varEmpty]);\r\n AddRecGet(cWindows, 'TRect', 'BottomRight', TRect_Read_BottomRight, 0, [varEmpty], varRecord);\r\n AddRecSet(cWindows, 'TRect', 'BottomRight', TRect_Write_BottomRight, 0, [varEmpty]);\r\n\r\n AddExtFun(cWindows, 'MessageBox', 0, user32, 'MessageBoxA', -1, 4, [varInteger, varString, varString, varInteger],\r\n varInteger);\r\n { MessageBox(, nil) Flags }\r\n AddConst(cWindows, 'MB_OK', MB_OK);\r\n AddConst(cWindows, 'MB_OKCANCEL', MB_OKCANCEL);\r\n AddConst(cWindows, 'MB_ABORTRETRYIGNORE', MB_ABORTRETRYIGNORE);\r\n AddConst(cWindows, 'MB_YESNOCANCEL', MB_YESNOCANCEL);\r\n AddConst(cWindows, 'MB_YESNO', MB_YESNO);\r\n AddConst(cWindows, 'MB_RETRYCANCEL', MB_RETRYCANCEL);\r\n AddConst(cWindows, 'MB_ICONHAND', MB_ICONHAND);\r\n AddConst(cWindows, 'MB_ICONQUESTION', MB_ICONQUESTION);\r\n AddConst(cWindows, 'MB_ICONEXCLAMATION', MB_ICONEXCLAMATION);\r\n AddConst(cWindows, 'MB_ICONASTERISK', MB_ICONASTERISK);\r\n AddConst(cWindows, 'MB_USERICON', MB_USERICON);\r\n AddConst(cWindows, 'MB_ICONWARNING', MB_ICONWARNING);\r\n AddConst(cWindows, 'MB_ICONERROR', MB_ICONERROR);\r\n AddConst(cWindows, 'MB_ICONINFORMATION', MB_ICONINFORMATION);\r\n AddConst(cWindows, 'MB_ICONSTOP', MB_ICONSTOP);\r\n AddConst(cWindows, 'MB_DEFBUTTON1', MB_DEFBUTTON1);\r\n AddConst(cWindows, 'MB_DEFBUTTON2', MB_DEFBUTTON2);\r\n AddConst(cWindows, 'MB_DEFBUTTON3', MB_DEFBUTTON3);\r\n AddConst(cWindows, 'MB_DEFBUTTON4', MB_DEFBUTTON4);\r\n AddConst(cWindows, 'MB_APPLMODAL', MB_APPLMODAL);\r\n AddConst(cWindows, 'MB_SYSTEMMODAL', MB_SYSTEMMODAL);\r\n AddConst(cWindows, 'MB_TASKMODAL', MB_TASKMODAL);\r\n AddConst(cWindows, 'MB_HELP', MB_HELP);\r\n AddConst(cWindows, 'MB_NOFOCUS', MB_NOFOCUS);\r\n AddConst(cWindows, 'MB_SETFOREGROUND', MB_SETFOREGROUND);\r\n AddConst(cWindows, 'MB_DEFAULT_DESKTOP_ONLY', MB_DEFAULT_DESKTOP_ONLY);\r\n AddConst(cWindows, 'MB_TOPMOST', MB_TOPMOST);\r\n AddConst(cWindows, 'MB_RIGHT', MB_RIGHT);\r\n AddConst(cWindows, 'MB_RTLREADING', MB_RTLREADING);\r\n AddConst(cWindows, 'MB_SERVICE_NOTIFICATION', MB_SERVICE_NOTIFICATION);\r\n AddConst(cWindows, 'MB_SERVICE_NOTIFICATION_NT3X', MB_SERVICE_NOTIFICATION_NT3X);\r\n AddConst(cWindows, 'MB_TYPEMASK', MB_TYPEMASK);\r\n AddConst(cWindows, 'MB_ICONMASK', MB_ICONMASK);\r\n AddConst(cWindows, 'MB_DEFMASK', MB_DEFMASK);\r\n AddConst(cWindows, 'MB_MODEMASK', MB_MODEMASK);\r\n AddConst(cWindows, 'MB_MISCMASK', MB_MISCMASK);\r\n\r\n { Virtual Keys, Standard Set }\r\n AddConst(cWindows, 'VK_LBUTTON', VK_LBUTTON);\r\n AddConst(cWindows, 'VK_RBUTTON', VK_RBUTTON);\r\n AddConst(cWindows, 'VK_CANCEL', VK_CANCEL);\r\n AddConst(cWindows, 'VK_MBUTTON', VK_MBUTTON);\r\n AddConst(cWindows, 'VK_BACK', VK_BACK);\r\n AddConst(cWindows, 'VK_TAB', VK_TAB);\r\n AddConst(cWindows, 'VK_CLEAR', VK_CLEAR);\r\n AddConst(cWindows, 'VK_RETURN', VK_RETURN);\r\n AddConst(cWindows, 'VK_SHIFT', VK_SHIFT);\r\n AddConst(cWindows, 'VK_CONTROL', VK_CONTROL);\r\n AddConst(cWindows, 'VK_MENU', VK_MENU);\r\n AddConst(cWindows, 'VK_PAUSE', VK_PAUSE);\r\n AddConst(cWindows, 'VK_CAPITAL', VK_CAPITAL);\r\n AddConst(cWindows, 'VK_KANA', VK_KANA);\r\n AddConst(cWindows, 'VK_HANGUL', VK_HANGUL);\r\n AddConst(cWindows, 'VK_JUNJA', VK_JUNJA);\r\n AddConst(cWindows, 'VK_FINAL', VK_FINAL);\r\n AddConst(cWindows, 'VK_HANJA', VK_HANJA);\r\n AddConst(cWindows, 'VK_KANJI', VK_KANJI);\r\n AddConst(cWindows, 'VK_CONVERT', VK_CONVERT);\r\n AddConst(cWindows, 'VK_NONCONVERT', VK_NONCONVERT);\r\n AddConst(cWindows, 'VK_ACCEPT', VK_ACCEPT);\r\n AddConst(cWindows, 'VK_MODECHANGE', VK_MODECHANGE);\r\n AddConst(cWindows, 'VK_ESCAPE', VK_ESCAPE);\r\n AddConst(cWindows, 'VK_SPACE', VK_SPACE);\r\n AddConst(cWindows, 'VK_PRIOR', VK_PRIOR);\r\n AddConst(cWindows, 'VK_NEXT', VK_NEXT);\r\n AddConst(cWindows, 'VK_END', VK_END);\r\n AddConst(cWindows, 'VK_HOME', VK_HOME);\r\n AddConst(cWindows, 'VK_LEFT', VK_LEFT);\r\n AddConst(cWindows, 'VK_UP', VK_UP);\r\n AddConst(cWindows, 'VK_RIGHT', VK_RIGHT);\r\n AddConst(cWindows, 'VK_DOWN', VK_DOWN);\r\n AddConst(cWindows, 'VK_SELECT', VK_SELECT);\r\n AddConst(cWindows, 'VK_PRINT', VK_PRINT);\r\n AddConst(cWindows, 'VK_EXECUTE', VK_EXECUTE);\r\n AddConst(cWindows, 'VK_SNAPSHOT', VK_SNAPSHOT);\r\n AddConst(cWindows, 'VK_INSERT', VK_INSERT);\r\n AddConst(cWindows, 'VK_DELETE', VK_DELETE);\r\n AddConst(cWindows, 'VK_HELP', VK_HELP);\r\n AddConst(cWindows, 'VK_LWIN', VK_LWIN);\r\n AddConst(cWindows, 'VK_RWIN', VK_RWIN);\r\n AddConst(cWindows, 'VK_APPS', VK_APPS);\r\n AddConst(cWindows, 'VK_NUMPAD0', VK_NUMPAD0);\r\n AddConst(cWindows, 'VK_NUMPAD1', VK_NUMPAD1);\r\n AddConst(cWindows, 'VK_NUMPAD2', VK_NUMPAD2);\r\n AddConst(cWindows, 'VK_NUMPAD3', VK_NUMPAD3);\r\n AddConst(cWindows, 'VK_NUMPAD4', VK_NUMPAD4);\r\n AddConst(cWindows, 'VK_NUMPAD5', VK_NUMPAD5);\r\n AddConst(cWindows, 'VK_NUMPAD6', VK_NUMPAD6);\r\n AddConst(cWindows, 'VK_NUMPAD7', VK_NUMPAD7);\r\n AddConst(cWindows, 'VK_NUMPAD8', VK_NUMPAD8);\r\n AddConst(cWindows, 'VK_NUMPAD9', VK_NUMPAD9);\r\n AddConst(cWindows, 'VK_MULTIPLY', VK_MULTIPLY);\r\n AddConst(cWindows, 'VK_ADD', VK_ADD);\r\n AddConst(cWindows, 'VK_SEPARATOR', VK_SEPARATOR);\r\n AddConst(cWindows, 'VK_SUBTRACT', VK_SUBTRACT);\r\n AddConst(cWindows, 'VK_DECIMAL', VK_DECIMAL);\r\n AddConst(cWindows, 'VK_DIVIDE', VK_DIVIDE);\r\n AddConst(cWindows, 'VK_F1', VK_F1);\r\n AddConst(cWindows, 'VK_F2', VK_F2);\r\n AddConst(cWindows, 'VK_F3', VK_F3);\r\n AddConst(cWindows, 'VK_F4', VK_F4);\r\n AddConst(cWindows, 'VK_F5', VK_F5);\r\n AddConst(cWindows, 'VK_F6', VK_F6);\r\n AddConst(cWindows, 'VK_F7', VK_F7);\r\n AddConst(cWindows, 'VK_F8', VK_F8);\r\n AddConst(cWindows, 'VK_F9', VK_F9);\r\n AddConst(cWindows, 'VK_F10', VK_F10);\r\n AddConst(cWindows, 'VK_F11', VK_F11);\r\n AddConst(cWindows, 'VK_F12', VK_F12);\r\n AddConst(cWindows, 'VK_F13', VK_F13);\r\n AddConst(cWindows, 'VK_F14', VK_F14);\r\n AddConst(cWindows, 'VK_F15', VK_F15);\r\n AddConst(cWindows, 'VK_F16', VK_F16);\r\n AddConst(cWindows, 'VK_F17', VK_F17);\r\n AddConst(cWindows, 'VK_F18', VK_F18);\r\n AddConst(cWindows, 'VK_F19', VK_F19);\r\n AddConst(cWindows, 'VK_F20', VK_F20);\r\n AddConst(cWindows, 'VK_F21', VK_F21);\r\n AddConst(cWindows, 'VK_F22', VK_F22);\r\n AddConst(cWindows, 'VK_F23', VK_F23);\r\n AddConst(cWindows, 'VK_F24', VK_F24);\r\n AddConst(cWindows, 'VK_NUMLOCK', VK_NUMLOCK);\r\n AddConst(cWindows, 'VK_SCROLL', VK_SCROLL);\r\n AddConst(cWindows, 'VK_LSHIFT', VK_LSHIFT);\r\n AddConst(cWindows, 'VK_RSHIFT', VK_RSHIFT);\r\n AddConst(cWindows, 'VK_LCONTROL', VK_LCONTROL);\r\n AddConst(cWindows, 'VK_RCONTROL', VK_RCONTROL);\r\n AddConst(cWindows, 'VK_LMENU', VK_LMENU);\r\n AddConst(cWindows, 'VK_RMENU', VK_RMENU);\r\n AddConst(cWindows, 'VK_PROCESSKEY', VK_PROCESSKEY);\r\n AddConst(cWindows, 'VK_ATTN', VK_ATTN);\r\n AddConst(cWindows, 'VK_CRSEL', VK_CRSEL);\r\n AddConst(cWindows, 'VK_EXSEL', VK_EXSEL);\r\n AddConst(cWindows, 'VK_EREOF', VK_EREOF);\r\n AddConst(cWindows, 'VK_PLAY', VK_PLAY);\r\n AddConst(cWindows, 'VK_ZOOM', VK_ZOOM);\r\n AddConst(cWindows, 'VK_NONAME', VK_NONAME);\r\n AddConst(cWindows, 'VK_PA1', VK_PA1);\r\n AddConst(cWindows, 'VK_OEM_CLEAR', VK_OEM_CLEAR);\r\n end;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvInterpreter_all.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvInterpreter_all.PAS, released on 2002-07-04.\r\n\r\nThe Initial Developers of the Original Code are: Andrei Prygounkov \r\nCopyright (c) 1999, 2002 Andrei Prygounkov\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nDescription : adapter unit - converts JvInterpreter calls to delphi calls\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvInterpreter_all.pas 13104 2011-09-07 06:50:43Z obones $\r\n\r\nunit JvInterpreter_all;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\n{$IFDEF UNITVERSIONING}\r\nuses\r\n JclUnitVersioning;\r\n{$ENDIF UNITVERSIONING}\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvInterpreter_all.pas $';\r\n Revision: '$Revision: 13104 $';\r\n Date: '$Date: 2011-09-07 08:50:43 +0200 (mer. 07 sept. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n JvInterpreter_System, JvInterpreter_SysUtils, JvInterpreter_Classes,\r\n JvInterpreter_Graphics, JvInterpreter_Controls, JvInterpreter_Dialogs,\r\n JvInterpreter_Windows, JvInterpreter_Buttons,\r\n JvInterpreter_StdCtrls, JvInterpreter_ComCtrls, JvInterpreter_ExtCtrls,\r\n JvInterpreter_Forms, JvInterpreter_Menus, JvInterpreter_Grids,\r\n {$IFNDEF DelphiPersonalEdition}\r\n JvInterpreter_Db,\r\n {$IFNDEF CPU64}\r\n JvInterpreter_DBTables,\r\n {$ENDIF ~CPU64}\r\n JvInterpreter_DbCtrls,\r\n JvInterpreter_DbGrids,\r\n {$IFDEF JVCL_UseQuickReport}\r\n JvInterpreter_Quickrpt,\r\n {$ENDIF JVCL_UseQuickReport}\r\n {$ENDIF !DelphiPersonalEdition}\r\n JvInterpreter_JvEditor, JvInterpreterFm,\r\n JvInterpreter;\r\n\r\nprocedure Init;\r\nbegin\r\n JvInterpreter_System.RegisterJvInterpreterAdapter(GlobalJvInterpreterAdapter);\r\n JvInterpreter_SysUtils.RegisterJvInterpreterAdapter(GlobalJvInterpreterAdapter);\r\n JvInterpreter_Classes.RegisterJvInterpreterAdapter(GlobalJvInterpreterAdapter);\r\n// JvInterpreter_JvRegAuto.RegisterJvInterpreterAdapter(GlobalJvInterpreterAdapter);\r\n\r\n JvInterpreter_Windows.RegisterJvInterpreterAdapter(GlobalJvInterpreterAdapter);\r\n JvInterpreter_Graphics.RegisterJvInterpreterAdapter(GlobalJvInterpreterAdapter);\r\n JvInterpreter_Controls.RegisterJvInterpreterAdapter(GlobalJvInterpreterAdapter);\r\n\r\n JvInterpreter_Buttons.RegisterJvInterpreterAdapter(GlobalJvInterpreterAdapter);\r\n JvInterpreter_StdCtrls.RegisterJvInterpreterAdapter(GlobalJvInterpreterAdapter);\r\n JvInterpreter_ComCtrls.RegisterJvInterpreterAdapter(GlobalJvInterpreterAdapter);\r\n JvInterpreter_ExtCtrls.RegisterJvInterpreterAdapter(GlobalJvInterpreterAdapter);\r\n JvInterpreter_Forms.RegisterJvInterpreterAdapter(GlobalJvInterpreterAdapter);\r\n JvInterpreter_Dialogs.RegisterJvInterpreterAdapter(GlobalJvInterpreterAdapter);\r\n JvInterpreter_Menus.RegisterJvInterpreterAdapter(GlobalJvInterpreterAdapter);\r\n JvInterpreter_Grids.RegisterJvInterpreterAdapter(GlobalJvInterpreterAdapter);\r\n\r\n {$IFNDEF DelphiPersonalEdition}\r\n JvInterpreter_Db.RegisterJvInterpreterAdapter(GlobalJvInterpreterAdapter);\r\n {$IFNDEF CPU64}\r\n JvInterpreter_DBTables.RegisterJvInterpreterAdapter(GlobalJvInterpreterAdapter);\r\n {$ENDIF ~CPU64}\r\n JvInterpreter_DbCtrls.RegisterJvInterpreterAdapter(GlobalJvInterpreterAdapter);\r\n JvInterpreter_DbGrids.RegisterJvInterpreterAdapter(GlobalJvInterpreterAdapter);\r\n {$IFDEF JVCL_UseQuickReport}\r\n JvInterpreter_Quickrpt.RegisterJvInterpreterAdapter(GlobalJvInterpreterAdapter);\r\n {$ENDIF JVCL_UseQuickReport}\r\n {$ENDIF !DelphiPersonalEdition}\r\n\r\n JvInterpreter_JvEditor.RegisterJvInterpreterAdapter(GlobalJvInterpreterAdapter);\r\n\r\n JvInterpreterFm.RegisterJvInterpreterAdapter(GlobalJvInterpreterAdapter);\r\nend;\r\n\r\ninitialization\r\n {$IFDEF UNITVERSIONING}\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n {$ENDIF UNITVERSIONING}\r\n Init;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvInterpreter_httpapp.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvInterpreter_httpapp.PAS, released on 2002-07-04.\r\n\r\nThe Initial Developers of the Original Code are: Andrei Prygounkov \r\nCopyright (c) 1999, 2002 Andrei Prygounkov\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nDescription : adapter unit - converts JvInterpreter calls to delphi calls\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvInterpreter_httpapp.pas 13401 2012-08-19 08:35:09Z ahuser $\r\n\r\nunit JvInterpreter_httpapp;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n JvInterpreter;\r\n\r\nprocedure RegisterJvInterpreterAdapter(JvInterpreterAdapter: TJvInterpreterAdapter);\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvInterpreter_httpapp.pas $';\r\n Revision: '$Revision: 13401 $';\r\n Date: '$Date: 2012-08-19 10:35:09 +0200 (dim. 19 août 2012) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n {$IFDEF HAS_UNITSCOPE}\r\n Web.HTTPApp,\r\n {$ELSE}\r\n HTTPApp,\r\n {$ENDIF HAS_UNITSCOPE}\r\n SysUtils, Classes;\r\n\r\n{ function ReadClient(var Buffer; Count: Integer): Integer; }\r\n\r\nprocedure TWebRequest_ReadClient(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TWebRequest(Args.Obj).ReadClient(Args.Values[0], Args.Values[1]);\r\nend;\r\n\r\n{ function ReadString(Count: Integer): string; }\r\n\r\nprocedure TWebRequest_ReadString(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TWebRequest(Args.Obj).ReadString(Args.Values[0]);\r\nend;\r\n\r\n{ function TranslateURI(const URI: string): string; }\r\n\r\nprocedure TWebRequest_TranslateURI(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TWebRequest(Args.Obj).TranslateURI(Args.Values[0]);\r\nend;\r\n\r\n{ function WriteClient(var Buffer; Count: Integer): Integer; }\r\n\r\nprocedure TWebRequest_WriteClient(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TWebRequest(Args.Obj).WriteClient(Args.Values[0], Args.Values[1]);\r\nend;\r\n\r\n{ function WriteString(const AString: string): Boolean; }\r\n\r\nprocedure TWebRequest_WriteString(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TWebRequest(Args.Obj).WriteString(AnsiString(string(Args.Values[0])));\r\nend;\r\n\r\n{ procedure ExtractContentFields(Strings: TStrings); }\r\n\r\nprocedure TWebRequest_ExtractContentFields(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TWebRequest(Args.Obj).ExtractContentFields(V2O(Args.Values[0]) as TStrings);\r\nend;\r\n\r\n{ procedure ExtractCookieFields(Strings: TStrings); }\r\n\r\nprocedure TWebRequest_ExtractCookieFields(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TWebRequest(Args.Obj).ExtractCookieFields(V2O(Args.Values[0]) as TStrings);\r\nend;\r\n\r\n{ procedure ExtractQueryFields(Strings: TStrings); }\r\n\r\nprocedure TWebRequest_ExtractQueryFields(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TWebRequest(Args.Obj).ExtractQueryFields(V2O(Args.Values[0]) as TStrings);\r\nend;\r\n\r\n{ function GetFieldByName(const Name: string): string; }\r\n\r\nprocedure TWebRequest_GetFieldByName(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TWebRequest(Args.Obj).GetFieldByName(AnsiString(string(Args.Values[0])));\r\nend;\r\n\r\n{ property Read MethodType: TMethodType }\r\n\r\nprocedure TWebRequest_Read_MethodType(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TWebRequest(Args.Obj).MethodType;\r\nend;\r\n\r\n{ property Read ContentFields: TStrings }\r\n\r\nprocedure TWebRequest_Read_ContentFields(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TWebRequest(Args.Obj).ContentFields);\r\nend;\r\n\r\n{ property Read CookieFields: TStrings }\r\n\r\nprocedure TWebRequest_Read_CookieFields(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TWebRequest(Args.Obj).CookieFields);\r\nend;\r\n\r\n{ property Read QueryFields: TStrings }\r\n\r\nprocedure TWebRequest_Read_QueryFields(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TWebRequest(Args.Obj).QueryFields);\r\nend;\r\n\r\n{ property Read Method: string }\r\n\r\nprocedure TWebRequest_Read_Method(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TWebRequest(Args.Obj).Method;\r\nend;\r\n\r\n{ property Read ProtocolVersion: string }\r\n\r\nprocedure TWebRequest_Read_ProtocolVersion(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TWebRequest(Args.Obj).ProtocolVersion;\r\nend;\r\n\r\n{ property Read URL: string }\r\n\r\nprocedure TWebRequest_Read_URL(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TWebRequest(Args.Obj).URL;\r\nend;\r\n\r\n{ property Read Query: string }\r\n\r\nprocedure TWebRequest_Read_Query(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TWebRequest(Args.Obj).Query;\r\nend;\r\n\r\n{ property Read PathInfo: string }\r\n\r\nprocedure TWebRequest_Read_PathInfo(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TWebRequest(Args.Obj).PathInfo;\r\nend;\r\n\r\n{ property Read PathTranslated: string }\r\n\r\nprocedure TWebRequest_Read_PathTranslated(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TWebRequest(Args.Obj).PathTranslated;\r\nend;\r\n\r\n{ property Read Authorization: string }\r\n\r\nprocedure TWebRequest_Read_Authorization(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TWebRequest(Args.Obj).Authorization;\r\nend;\r\n\r\n{ property Read CacheControl: string }\r\n\r\nprocedure TWebRequest_Read_CacheControl(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TWebRequest(Args.Obj).CacheControl;\r\nend;\r\n\r\n{ property Read Cookie: string }\r\n\r\nprocedure TWebRequest_Read_Cookie(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TWebRequest(Args.Obj).Cookie;\r\nend;\r\n\r\n{ property Read Date: TDateTime }\r\n\r\nprocedure TWebRequest_Read_Date(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TWebRequest(Args.Obj).Date;\r\nend;\r\n\r\n{ property Read Accept: string }\r\n\r\nprocedure TWebRequest_Read_Accept(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TWebRequest(Args.Obj).Accept;\r\nend;\r\n\r\n{ property Read From: string }\r\n\r\nprocedure TWebRequest_Read_From(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TWebRequest(Args.Obj).From;\r\nend;\r\n\r\n{ property Read Host: string }\r\n\r\nprocedure TWebRequest_Read_Host(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TWebRequest(Args.Obj).Host;\r\nend;\r\n\r\n{ property Read IfModifiedSince: TDateTime }\r\n\r\nprocedure TWebRequest_Read_IfModifiedSince(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TWebRequest(Args.Obj).IfModifiedSince;\r\nend;\r\n\r\n{ property Read Referer: string }\r\n\r\nprocedure TWebRequest_Read_Referer(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TWebRequest(Args.Obj).Referer;\r\nend;\r\n\r\n{ property Read UserAgent: string }\r\n\r\nprocedure TWebRequest_Read_UserAgent(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TWebRequest(Args.Obj).UserAgent;\r\nend;\r\n\r\n{ property Read ContentEncoding: string }\r\n\r\nprocedure TWebRequest_Read_ContentEncoding(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TWebRequest(Args.Obj).ContentEncoding;\r\nend;\r\n\r\n{ property Read ContentType: string }\r\n\r\nprocedure TWebRequest_Read_ContentType(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TWebRequest(Args.Obj).ContentType;\r\nend;\r\n\r\n{ property Read ContentLength: Integer }\r\n\r\nprocedure TWebRequest_Read_ContentLength(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TWebRequest(Args.Obj).ContentLength;\r\nend;\r\n\r\n{ property Read ContentVersion: string }\r\n\r\nprocedure TWebRequest_Read_ContentVersion(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TWebRequest(Args.Obj).ContentVersion;\r\nend;\r\n\r\n{ property Read Content: string }\r\n\r\nprocedure TWebRequest_Read_Content(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TWebRequest(Args.Obj).Content;\r\nend;\r\n\r\n{ property Read Connection: string }\r\n\r\nprocedure TWebRequest_Read_Connection(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TWebRequest(Args.Obj).Connection;\r\nend;\r\n\r\n{ property Read DerivedFrom: string }\r\n\r\nprocedure TWebRequest_Read_DerivedFrom(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TWebRequest(Args.Obj).DerivedFrom;\r\nend;\r\n\r\n{ property Read Expires: TDateTime }\r\n\r\nprocedure TWebRequest_Read_Expires(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TWebRequest(Args.Obj).Expires;\r\nend;\r\n\r\n{ property Read Title: string }\r\n\r\nprocedure TWebRequest_Read_Title(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TWebRequest(Args.Obj).Title;\r\nend;\r\n\r\n{ property Read RemoteAddr: string }\r\n\r\nprocedure TWebRequest_Read_RemoteAddr(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TWebRequest(Args.Obj).RemoteAddr;\r\nend;\r\n\r\n{ property Read RemoteHost: string }\r\n\r\nprocedure TWebRequest_Read_RemoteHost(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TWebRequest(Args.Obj).RemoteHost;\r\nend;\r\n\r\n{ property Read ScriptName: string }\r\n\r\nprocedure TWebRequest_Read_ScriptName(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TWebRequest(Args.Obj).ScriptName;\r\nend;\r\n\r\n{ property Read ServerPort: Integer }\r\n\r\nprocedure TWebRequest_Read_ServerPort(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TWebRequest(Args.Obj).ServerPort;\r\nend;\r\n\r\n{ TCookie }\r\n\r\n{ constructor Create(Collection: TCollection) }\r\n\r\nprocedure TCookie_Create(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TCookie.Create(V2O(Args.Values[0]) as TCollection));\r\nend;\r\n\r\n{ procedure AssignTo(Dest: TPersistent); }\r\n\r\nprocedure TCookie_AssignTo(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TCookie(Args.Obj).AssignTo(V2O(Args.Values[0]) as TPersistent);\r\nend;\r\n\r\n{ property Read Name: string }\r\n\r\nprocedure TCookie_Read_Name(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TCookie(Args.Obj).Name;\r\nend;\r\n\r\n{ property Write Name(Value: string) }\r\n\r\nprocedure TCookie_Write_Name(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TCookie(Args.Obj).Name := AnsiString(string(Value));\r\nend;\r\n\r\n{ property Read Value: string }\r\n\r\nprocedure TCookie_Read_Value(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TCookie(Args.Obj).Value;\r\nend;\r\n\r\n{ property Write Value(Value: string) }\r\n\r\nprocedure TCookie_Write_Value(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TCookie(Args.Obj).Value := AnsiString(string(Value));\r\nend;\r\n\r\n{ property Read Domain: string }\r\n\r\nprocedure TCookie_Read_Domain(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TCookie(Args.Obj).Domain;\r\nend;\r\n\r\n{ property Write Domain(Value: string) }\r\n\r\nprocedure TCookie_Write_Domain(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TCookie(Args.Obj).Domain := AnsiString(string(Value));\r\nend;\r\n\r\n{ property Read Path: string }\r\n\r\nprocedure TCookie_Read_Path(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TCookie(Args.Obj).Path;\r\nend;\r\n\r\n{ property Write Path(Value: string) }\r\n\r\nprocedure TCookie_Write_Path(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TCookie(Args.Obj).Path := AnsiString(string(Value));\r\nend;\r\n\r\n{ property Read Expires: TDateTime }\r\n\r\nprocedure TCookie_Read_Expires(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TCookie(Args.Obj).Expires;\r\nend;\r\n\r\n{ property Write Expires(Value: TDateTime) }\r\n\r\nprocedure TCookie_Write_Expires(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TCookie(Args.Obj).Expires := Value;\r\nend;\r\n\r\n{ property Read Secure: Boolean }\r\n\r\nprocedure TCookie_Read_Secure(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TCookie(Args.Obj).Secure;\r\nend;\r\n\r\n{ property Write Secure(Value: Boolean) }\r\n\r\nprocedure TCookie_Write_Secure(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TCookie(Args.Obj).Secure := Value;\r\nend;\r\n\r\n{ property Read HeaderValue: string }\r\n\r\nprocedure TCookie_Read_HeaderValue(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TCookie(Args.Obj).HeaderValue;\r\nend;\r\n\r\n{ TWebResponse }\r\n\r\n{ function GetCustomHeader(const Name: string): String; }\r\n\r\nprocedure TWebResponse_GetCustomHeader(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TWebResponse(Args.Obj).GetCustomHeader(Args.Values[0]);\r\nend;\r\n\r\n{ procedure SendResponse; }\r\n\r\nprocedure TWebResponse_SendResponse(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TWebResponse(Args.Obj).SendResponse;\r\nend;\r\n\r\n{ procedure SendRedirect(const URI: string); }\r\n\r\nprocedure TWebResponse_SendRedirect(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TWebResponse(Args.Obj).SendRedirect(AnsiString(string(Args.Values[0])));\r\nend;\r\n\r\n{ procedure SendStream(AStream: TStream); }\r\n\r\nprocedure TWebResponse_SendStream(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TWebResponse(Args.Obj).SendStream(V2O(Args.Values[0]) as TStream);\r\nend;\r\n\r\n{ function Sent: Boolean; }\r\n\r\nprocedure TWebResponse_Sent(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TWebResponse(Args.Obj).Sent;\r\nend;\r\n\r\n{ procedure SetCookieField(Values: TStrings; const ADomain, APath: string; AExpires: TDateTime; ASecure: Boolean); }\r\n\r\nprocedure TWebResponse_SetCookieField(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TWebResponse(Args.Obj).SetCookieField(V2O(Args.Values[0]) as TStrings, AnsiString(string(Args.Values[1])), AnsiString(string(Args.Values[2])),\r\n Args.Values[3], Args.Values[4]);\r\nend;\r\n\r\n{ procedure SetCustomHeader(const Name, Value: string); }\r\n\r\nprocedure TWebResponse_SetCustomHeader(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TWebResponse(Args.Obj).SetCustomHeader(Args.Values[0], Args.Values[1]);\r\nend;\r\n\r\n{ property Read Cookies: TCookieCollection }\r\n\r\nprocedure TWebResponse_Read_Cookies(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TWebResponse(Args.Obj).Cookies);\r\nend;\r\n\r\n{ property Read HTTPRequest: TWebRequest }\r\n\r\nprocedure TWebResponse_Read_HTTPRequest(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TWebResponse(Args.Obj).HTTPRequest);\r\nend;\r\n\r\n{ property Read Version: string }\r\n\r\nprocedure TWebResponse_Read_Version(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TWebResponse(Args.Obj).Version;\r\nend;\r\n\r\n{ property Write Version(Value: string) }\r\n\r\nprocedure TWebResponse_Write_Version(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TWebResponse(Args.Obj).Version := AnsiString(string(Value));\r\nend;\r\n\r\n{ property Read ReasonString: string }\r\n\r\nprocedure TWebResponse_Read_ReasonString(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TWebResponse(Args.Obj).ReasonString;\r\nend;\r\n\r\n{ property Write ReasonString(Value: string) }\r\n\r\nprocedure TWebResponse_Write_ReasonString(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TWebResponse(Args.Obj).ReasonString := AnsiString(string(Value));\r\nend;\r\n\r\n{ property Read Server: string }\r\n\r\nprocedure TWebResponse_Read_Server(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TWebResponse(Args.Obj).Server;\r\nend;\r\n\r\n{ property Write Server(Value: string) }\r\n\r\nprocedure TWebResponse_Write_Server(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TWebResponse(Args.Obj).Server := AnsiString(string(Value));\r\nend;\r\n\r\n{ property Read WWWAuthenticate: string }\r\n\r\nprocedure TWebResponse_Read_WWWAuthenticate(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TWebResponse(Args.Obj).WWWAuthenticate;\r\nend;\r\n\r\n{ property Write WWWAuthenticate(Value: string) }\r\n\r\nprocedure TWebResponse_Write_WWWAuthenticate(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TWebResponse(Args.Obj).WWWAuthenticate := AnsiString(string(Value));\r\nend;\r\n\r\n{ property Read Realm: string }\r\n\r\nprocedure TWebResponse_Read_Realm(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TWebResponse(Args.Obj).Realm;\r\nend;\r\n\r\n{ property Write Realm(Value: string) }\r\n\r\nprocedure TWebResponse_Write_Realm(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TWebResponse(Args.Obj).Realm := AnsiString(string(Value));\r\nend;\r\n\r\n{ property Read Allow: string }\r\n\r\nprocedure TWebResponse_Read_Allow(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TWebResponse(Args.Obj).Allow;\r\nend;\r\n\r\n{ property Write Allow(Value: string) }\r\n\r\nprocedure TWebResponse_Write_Allow(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TWebResponse(Args.Obj).Allow := AnsiString(string(Value));\r\nend;\r\n\r\n{ property Read Location: string }\r\n\r\nprocedure TWebResponse_Read_Location(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TWebResponse(Args.Obj).Location;\r\nend;\r\n\r\n{ property Write Location(Value: string) }\r\n\r\nprocedure TWebResponse_Write_Location(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TWebResponse(Args.Obj).Location := AnsiString(string(Value));\r\nend;\r\n\r\n{ property Read ContentEncoding: string }\r\n\r\nprocedure TWebResponse_Read_ContentEncoding(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TWebResponse(Args.Obj).ContentEncoding;\r\nend;\r\n\r\n{ property Write ContentEncoding(Value: string) }\r\n\r\nprocedure TWebResponse_Write_ContentEncoding(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TWebResponse(Args.Obj).ContentEncoding := AnsiString(string(Value));\r\nend;\r\n\r\n{ property Read ContentType: string }\r\n\r\nprocedure TWebResponse_Read_ContentType(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TWebResponse(Args.Obj).ContentType;\r\nend;\r\n\r\n{ property Write ContentType(Value: string) }\r\n\r\nprocedure TWebResponse_Write_ContentType(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TWebResponse(Args.Obj).ContentType := AnsiString(string(Value));\r\nend;\r\n\r\n{ property Read ContentVersion: string }\r\n\r\nprocedure TWebResponse_Read_ContentVersion(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TWebResponse(Args.Obj).ContentVersion;\r\nend;\r\n\r\n{ property Write ContentVersion(Value: string) }\r\n\r\nprocedure TWebResponse_Write_ContentVersion(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TWebResponse(Args.Obj).ContentVersion := AnsiString(string(Value));\r\nend;\r\n\r\n{ property Read DerivedFrom: string }\r\n\r\nprocedure TWebResponse_Read_DerivedFrom(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TWebResponse(Args.Obj).DerivedFrom;\r\nend;\r\n\r\n{ property Write DerivedFrom(Value: string) }\r\n\r\nprocedure TWebResponse_Write_DerivedFrom(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TWebResponse(Args.Obj).DerivedFrom := AnsiString(string(Value));\r\nend;\r\n\r\n{ property Read Title: string }\r\n\r\nprocedure TWebResponse_Read_Title(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TWebResponse(Args.Obj).Title;\r\nend;\r\n\r\n{ property Write Title(Value: string) }\r\n\r\nprocedure TWebResponse_Write_Title(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TWebResponse(Args.Obj).Title := AnsiString(string(Value));\r\nend;\r\n\r\n{ property Read StatusCode: Integer }\r\n\r\nprocedure TWebResponse_Read_StatusCode(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TWebResponse(Args.Obj).StatusCode;\r\nend;\r\n\r\n{ property Write StatusCode(Value: Integer) }\r\n\r\nprocedure TWebResponse_Write_StatusCode(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TWebResponse(Args.Obj).StatusCode := Value;\r\nend;\r\n\r\n{ property Read ContentLength: Integer }\r\n\r\nprocedure TWebResponse_Read_ContentLength(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TWebResponse(Args.Obj).ContentLength;\r\nend;\r\n\r\n{ property Write ContentLength(Value: Integer) }\r\n\r\nprocedure TWebResponse_Write_ContentLength(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TWebResponse(Args.Obj).ContentLength := Value;\r\nend;\r\n\r\n{ property Read Date: TDateTime }\r\n\r\nprocedure TWebResponse_Read_Date(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TWebResponse(Args.Obj).Date;\r\nend;\r\n\r\n{ property Write Date(Value: TDateTime) }\r\n\r\nprocedure TWebResponse_Write_Date(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TWebResponse(Args.Obj).Date := Value;\r\nend;\r\n\r\n{ property Read Expires: TDateTime }\r\n\r\nprocedure TWebResponse_Read_Expires(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TWebResponse(Args.Obj).Expires;\r\nend;\r\n\r\n{ property Write Expires(Value: TDateTime) }\r\n\r\nprocedure TWebResponse_Write_Expires(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TWebResponse(Args.Obj).Expires := Value;\r\nend;\r\n\r\n{ property Read LastModified: TDateTime }\r\n\r\nprocedure TWebResponse_Read_LastModified(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TWebResponse(Args.Obj).LastModified;\r\nend;\r\n\r\n{ property Write LastModified(Value: TDateTime) }\r\n\r\nprocedure TWebResponse_Write_LastModified(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TWebResponse(Args.Obj).LastModified := Value;\r\nend;\r\n\r\n{ property Read Content: string }\r\n\r\nprocedure TWebResponse_Read_Content(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TWebResponse(Args.Obj).Content;\r\nend;\r\n\r\n{ property Write Content(Value: string) }\r\n\r\nprocedure TWebResponse_Write_Content(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TWebResponse(Args.Obj).Content := Value;\r\nend;\r\n\r\n{ property Read ContentStream: TStream }\r\n\r\nprocedure TWebResponse_Read_ContentStream(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TWebResponse(Args.Obj).ContentStream);\r\nend;\r\n\r\n{ property Write ContentStream(Value: TStream) }\r\n\r\nprocedure TWebResponse_Write_ContentStream(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TWebResponse(Args.Obj).ContentStream := V2O(Value) as TStream;\r\nend;\r\n\r\n{ property Read LogMessage: string }\r\n\r\nprocedure TWebResponse_Read_LogMessage(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TWebResponse(Args.Obj).LogMessage;\r\nend;\r\n\r\n{ property Write LogMessage(Value: string) }\r\n\r\nprocedure TWebResponse_Write_LogMessage(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TWebResponse(Args.Obj).LogMessage := Value;\r\nend;\r\n\r\n{ property Read CustomHeaders: TStrings }\r\n\r\nprocedure TWebResponse_Read_CustomHeaders(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TWebResponse(Args.Obj).CustomHeaders);\r\nend;\r\n\r\n{ property Write CustomHeaders(Value: TStrings) }\r\n\r\nprocedure TWebResponse_Write_CustomHeaders(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TWebResponse(Args.Obj).CustomHeaders := V2O(Value) as TStrings;\r\nend;\r\n\r\n{ TWebActionItem }\r\n\r\n{ constructor Create(Collection: TCollection) }\r\n\r\nprocedure TWebActionItem_Create(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TWebActionItem.Create(V2O(Args.Values[0]) as TCollection));\r\nend;\r\n\r\n{ procedure AssignTo(Dest: TPersistent); }\r\n\r\nprocedure TWebActionItem_AssignTo(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TWebActionItem(Args.Obj).AssignTo(V2O(Args.Values[0]) as TPersistent);\r\nend;\r\n\r\n{ property Read Default: Boolean }\r\n\r\nprocedure TWebActionItem_Read_Default(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TWebActionItem(Args.Obj).Default;\r\nend;\r\n\r\n{ property Write Default(Value: Boolean) }\r\n\r\nprocedure TWebActionItem_Write_Default(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TWebActionItem(Args.Obj).Default := Value;\r\nend;\r\n\r\n{ property Read Enabled: Boolean }\r\n\r\nprocedure TWebActionItem_Read_Enabled(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TWebActionItem(Args.Obj).Enabled;\r\nend;\r\n\r\n{ property Write Enabled(Value: Boolean) }\r\n\r\nprocedure TWebActionItem_Write_Enabled(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TWebActionItem(Args.Obj).Enabled := Value;\r\nend;\r\n\r\n{ property Read MethodType: TMethodType }\r\n\r\nprocedure TWebActionItem_Read_MethodType(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TWebActionItem(Args.Obj).MethodType;\r\nend;\r\n\r\n{ property Write MethodType(Value: TMethodType) }\r\n\r\nprocedure TWebActionItem_Write_MethodType(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TWebActionItem(Args.Obj).MethodType := Value;\r\nend;\r\n\r\n{ property Read Name: string }\r\n\r\nprocedure TWebActionItem_Read_Name(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TWebActionItem(Args.Obj).Name;\r\nend;\r\n\r\n{ property Write Name(Value: string) }\r\n\r\nprocedure TWebActionItem_Write_Name(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TWebActionItem(Args.Obj).Name := Value;\r\nend;\r\n\r\n{ property Read PathInfo: string }\r\n\r\nprocedure TWebActionItem_Read_PathInfo(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := TWebActionItem(Args.Obj).PathInfo;\r\nend;\r\n\r\n{ property Write PathInfo(Value: string) }\r\n\r\nprocedure TWebActionItem_Write_PathInfo(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TWebActionItem(Args.Obj).PathInfo := Value;\r\nend;\r\n\r\n{ property Read Producer: TCustomContentProducer }\r\n\r\nprocedure TWebActionItem_Read_Producer(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := O2V(TWebActionItem(Args.Obj).Producer);\r\nend;\r\n\r\n{ property Write Producer(Value: TCustomContentProducer) }\r\n\r\nprocedure TWebActionItem_Write_Producer(const Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n TWebActionItem(Args.Obj).Producer := V2O(Value) as TCustomContentProducer;\r\nend;\r\n\r\n{ TWebDispatcher }\r\n\r\n{ function DosPathToUnixPath(const Path: string): string; }\r\n\r\nprocedure JvInterpreter_DosPathToUnixPath(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := DosPathToUnixPath(Args.Values[0]);\r\nend;\r\n\r\n{ function HTTPDecode(const AStr: String): string; }\r\n\r\nprocedure JvInterpreter_HTTPDecode(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := HTTPDecode(AnsiString(string(Args.Values[0])));\r\nend;\r\n\r\n{ function HTTPEncode(const AStr: String): string; }\r\n\r\nprocedure JvInterpreter_HTTPEncode(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := HTTPEncode(AnsiString(string(Args.Values[0])));\r\nend;\r\n\r\n{ function ParseDate(const DateStr: string): TDateTime; }\r\n\r\nprocedure JvInterpreter_ParseDate(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := ParseDate(Args.Values[0]);\r\nend;\r\n\r\n{ function StatusString(StatusCode: Integer): string; }\r\n\r\nprocedure JvInterpreter_StatusString(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := StatusString(Args.Values[0]);\r\nend;\r\n\r\n{ function UnixPathToDosPath(const Path: string): string; }\r\n\r\nprocedure JvInterpreter_UnixPathToDosPath(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := UnixPathToDosPath(Args.Values[0]);\r\nend;\r\n\r\n{ function MonthStr(DateTime: TDateTime): string; }\r\n\r\nprocedure JvInterpreter_MonthStr(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := MonthStr(Args.Values[0]);\r\nend;\r\n\r\n{ function DayOfWeekStr(DateTime: TDateTime): string; }\r\n\r\nprocedure JvInterpreter_DayOfWeekStr(var Value: Variant; Args: TJvInterpreterArgs);\r\nbegin\r\n Value := DayOfWeekStr(Args.Values[0]);\r\nend;\r\n\r\nprocedure RegisterJvInterpreterAdapter(JvInterpreterAdapter: TJvInterpreterAdapter);\r\nconst\r\n cHTTPApp = 'HTTPApp';\r\nbegin\r\n with JvInterpreterAdapter do\r\n begin\r\n { TWebRequest }\r\n AddClass(cHTTPApp, TWebRequest, 'TWebRequest');\r\n AddGet(TWebRequest, 'ReadClient', TWebRequest_ReadClient, 2, [varEmpty or varByRef, varInteger], varEmpty);\r\n AddGet(TWebRequest, 'ReadString', TWebRequest_ReadString, 1, [varInteger], varEmpty);\r\n AddGet(TWebRequest, 'TranslateURI', TWebRequest_TranslateURI, 1, [varString], varEmpty);\r\n AddGet(TWebRequest, 'WriteClient', TWebRequest_WriteClient, 2, [varEmpty or varByRef, varInteger], varEmpty);\r\n AddGet(TWebRequest, 'WriteString', TWebRequest_WriteString, 1, [varString], varEmpty);\r\n AddGet(TWebRequest, 'ExtractContentFields', TWebRequest_ExtractContentFields, 1, [varObject], varEmpty);\r\n AddGet(TWebRequest, 'ExtractCookieFields', TWebRequest_ExtractCookieFields, 1, [varObject], varEmpty);\r\n AddGet(TWebRequest, 'ExtractQueryFields', TWebRequest_ExtractQueryFields, 1, [varObject], varEmpty);\r\n AddGet(TWebRequest, 'GetFieldByName', TWebRequest_GetFieldByName, 1, [varString], varEmpty);\r\n AddGet(TWebRequest, 'MethodType', TWebRequest_Read_MethodType, 0, [varEmpty], varEmpty);\r\n AddGet(TWebRequest, 'ContentFields', TWebRequest_Read_ContentFields, 0, [varEmpty], varEmpty);\r\n AddGet(TWebRequest, 'CookieFields', TWebRequest_Read_CookieFields, 0, [varEmpty], varEmpty);\r\n AddGet(TWebRequest, 'QueryFields', TWebRequest_Read_QueryFields, 0, [varEmpty], varEmpty);\r\n AddGet(TWebRequest, 'Method', TWebRequest_Read_Method, 0, [varEmpty], varEmpty);\r\n AddGet(TWebRequest, 'ProtocolVersion', TWebRequest_Read_ProtocolVersion, 0, [varEmpty], varEmpty);\r\n AddGet(TWebRequest, 'URL', TWebRequest_Read_URL, 0, [varEmpty], varEmpty);\r\n AddGet(TWebRequest, 'Query', TWebRequest_Read_Query, 0, [varEmpty], varEmpty);\r\n AddGet(TWebRequest, 'PathInfo', TWebRequest_Read_PathInfo, 0, [varEmpty], varEmpty);\r\n AddGet(TWebRequest, 'PathTranslated', TWebRequest_Read_PathTranslated, 0, [varEmpty], varEmpty);\r\n AddGet(TWebRequest, 'Authorization', TWebRequest_Read_Authorization, 0, [varEmpty], varEmpty);\r\n AddGet(TWebRequest, 'CacheControl', TWebRequest_Read_CacheControl, 0, [varEmpty], varEmpty);\r\n AddGet(TWebRequest, 'Cookie', TWebRequest_Read_Cookie, 0, [varEmpty], varEmpty);\r\n AddGet(TWebRequest, 'Date', TWebRequest_Read_Date, 0, [varEmpty], varEmpty);\r\n AddGet(TWebRequest, 'Accept', TWebRequest_Read_Accept, 0, [varEmpty], varEmpty);\r\n AddGet(TWebRequest, 'From', TWebRequest_Read_From, 0, [varEmpty], varEmpty);\r\n AddGet(TWebRequest, 'Host', TWebRequest_Read_Host, 0, [varEmpty], varEmpty);\r\n AddGet(TWebRequest, 'IfModifiedSince', TWebRequest_Read_IfModifiedSince, 0, [varEmpty], varEmpty);\r\n AddGet(TWebRequest, 'Referer', TWebRequest_Read_Referer, 0, [varEmpty], varEmpty);\r\n AddGet(TWebRequest, 'UserAgent', TWebRequest_Read_UserAgent, 0, [varEmpty], varEmpty);\r\n AddGet(TWebRequest, 'ContentEncoding', TWebRequest_Read_ContentEncoding, 0, [varEmpty], varEmpty);\r\n AddGet(TWebRequest, 'ContentType', TWebRequest_Read_ContentType, 0, [varEmpty], varEmpty);\r\n AddGet(TWebRequest, 'ContentLength', TWebRequest_Read_ContentLength, 0, [varEmpty], varEmpty);\r\n AddGet(TWebRequest, 'ContentVersion', TWebRequest_Read_ContentVersion, 0, [varEmpty], varEmpty);\r\n AddGet(TWebRequest, 'Content', TWebRequest_Read_Content, 0, [varEmpty], varEmpty);\r\n AddGet(TWebRequest, 'Connection', TWebRequest_Read_Connection, 0, [varEmpty], varEmpty);\r\n AddGet(TWebRequest, 'DerivedFrom', TWebRequest_Read_DerivedFrom, 0, [varEmpty], varEmpty);\r\n AddGet(TWebRequest, 'Expires', TWebRequest_Read_Expires, 0, [varEmpty], varEmpty);\r\n AddGet(TWebRequest, 'Title', TWebRequest_Read_Title, 0, [varEmpty], varEmpty);\r\n AddGet(TWebRequest, 'RemoteAddr', TWebRequest_Read_RemoteAddr, 0, [varEmpty], varEmpty);\r\n AddGet(TWebRequest, 'RemoteHost', TWebRequest_Read_RemoteHost, 0, [varEmpty], varEmpty);\r\n AddGet(TWebRequest, 'ScriptName', TWebRequest_Read_ScriptName, 0, [varEmpty], varEmpty);\r\n AddGet(TWebRequest, 'ServerPort', TWebRequest_Read_ServerPort, 0, [varEmpty], varEmpty);\r\n { TCookie }\r\n AddClass(cHTTPApp, TCookie, 'TCookie');\r\n AddGet(TCookie, 'Create', TCookie_Create, 1, [varObject], varEmpty);\r\n AddGet(TCookie, 'AssignTo', TCookie_AssignTo, 1, [varObject], varEmpty);\r\n AddGet(TCookie, 'Name', TCookie_Read_Name, 0, [varEmpty], varEmpty);\r\n AddSet(TCookie, 'Name', TCookie_Write_Name, 0, [varEmpty]);\r\n AddGet(TCookie, 'Value', TCookie_Read_Value, 0, [varEmpty], varEmpty);\r\n AddSet(TCookie, 'Value', TCookie_Write_Value, 0, [varEmpty]);\r\n AddGet(TCookie, 'Domain', TCookie_Read_Domain, 0, [varEmpty], varEmpty);\r\n AddSet(TCookie, 'Domain', TCookie_Write_Domain, 0, [varEmpty]);\r\n AddGet(TCookie, 'Path', TCookie_Read_Path, 0, [varEmpty], varEmpty);\r\n AddSet(TCookie, 'Path', TCookie_Write_Path, 0, [varEmpty]);\r\n AddGet(TCookie, 'Expires', TCookie_Read_Expires, 0, [varEmpty], varEmpty);\r\n AddSet(TCookie, 'Expires', TCookie_Write_Expires, 0, [varEmpty]);\r\n AddGet(TCookie, 'Secure', TCookie_Read_Secure, 0, [varEmpty], varEmpty);\r\n AddSet(TCookie, 'Secure', TCookie_Write_Secure, 0, [varEmpty]);\r\n AddGet(TCookie, 'HeaderValue', TCookie_Read_HeaderValue, 0, [varEmpty], varEmpty);\r\n { TWebResponse }\r\n AddClass(cHTTPApp, TWebResponse, 'TWebResponse');\r\n AddGet(TWebResponse, 'GetCustomHeader', TWebResponse_GetCustomHeader, 1, [varString], varEmpty);\r\n AddGet(TWebResponse, 'SendResponse', TWebResponse_SendResponse, 0, [varEmpty], varEmpty);\r\n AddGet(TWebResponse, 'SendRedirect', TWebResponse_SendRedirect, 1, [varString], varEmpty);\r\n AddGet(TWebResponse, 'SendStream', TWebResponse_SendStream, 1, [varObject], varEmpty);\r\n AddGet(TWebResponse, 'Sent', TWebResponse_Sent, 0, [varEmpty], varEmpty);\r\n AddGet(TWebResponse, 'SetCookieField', TWebResponse_SetCookieField, 5, [varObject, varString, varString, varEmpty,\r\n varBoolean], varEmpty);\r\n AddGet(TWebResponse, 'SetCustomHeader', TWebResponse_SetCustomHeader, 2, [varString, varString], varEmpty);\r\n AddGet(TWebResponse, 'Cookies', TWebResponse_Read_Cookies, 0, [varEmpty], varEmpty);\r\n AddGet(TWebResponse, 'HTTPRequest', TWebResponse_Read_HTTPRequest, 0, [varEmpty], varEmpty);\r\n AddGet(TWebResponse, 'Version', TWebResponse_Read_Version, 0, [varEmpty], varEmpty);\r\n AddSet(TWebResponse, 'Version', TWebResponse_Write_Version, 0, [varEmpty]);\r\n AddGet(TWebResponse, 'ReasonString', TWebResponse_Read_ReasonString, 0, [varEmpty], varEmpty);\r\n AddSet(TWebResponse, 'ReasonString', TWebResponse_Write_ReasonString, 0, [varEmpty]);\r\n AddGet(TWebResponse, 'Server', TWebResponse_Read_Server, 0, [varEmpty], varEmpty);\r\n AddSet(TWebResponse, 'Server', TWebResponse_Write_Server, 0, [varEmpty]);\r\n AddGet(TWebResponse, 'WWWAuthenticate', TWebResponse_Read_WWWAuthenticate, 0, [varEmpty], varEmpty);\r\n AddSet(TWebResponse, 'WWWAuthenticate', TWebResponse_Write_WWWAuthenticate, 0, [varEmpty]);\r\n AddGet(TWebResponse, 'Realm', TWebResponse_Read_Realm, 0, [varEmpty], varEmpty);\r\n AddSet(TWebResponse, 'Realm', TWebResponse_Write_Realm, 0, [varEmpty]);\r\n AddGet(TWebResponse, 'Allow', TWebResponse_Read_Allow, 0, [varEmpty], varEmpty);\r\n AddSet(TWebResponse, 'Allow', TWebResponse_Write_Allow, 0, [varEmpty]);\r\n AddGet(TWebResponse, 'Location', TWebResponse_Read_Location, 0, [varEmpty], varEmpty);\r\n AddSet(TWebResponse, 'Location', TWebResponse_Write_Location, 0, [varEmpty]);\r\n AddGet(TWebResponse, 'ContentEncoding', TWebResponse_Read_ContentEncoding, 0, [varEmpty], varEmpty);\r\n AddSet(TWebResponse, 'ContentEncoding', TWebResponse_Write_ContentEncoding, 0, [varEmpty]);\r\n AddGet(TWebResponse, 'ContentType', TWebResponse_Read_ContentType, 0, [varEmpty], varEmpty);\r\n AddSet(TWebResponse, 'ContentType', TWebResponse_Write_ContentType, 0, [varEmpty]);\r\n AddGet(TWebResponse, 'ContentVersion', TWebResponse_Read_ContentVersion, 0, [varEmpty], varEmpty);\r\n AddSet(TWebResponse, 'ContentVersion', TWebResponse_Write_ContentVersion, 0, [varEmpty]);\r\n AddGet(TWebResponse, 'DerivedFrom', TWebResponse_Read_DerivedFrom, 0, [varEmpty], varEmpty);\r\n AddSet(TWebResponse, 'DerivedFrom', TWebResponse_Write_DerivedFrom, 0, [varEmpty]);\r\n AddGet(TWebResponse, 'Title', TWebResponse_Read_Title, 0, [varEmpty], varEmpty);\r\n AddSet(TWebResponse, 'Title', TWebResponse_Write_Title, 0, [varEmpty]);\r\n AddGet(TWebResponse, 'StatusCode', TWebResponse_Read_StatusCode, 0, [varEmpty], varEmpty);\r\n AddSet(TWebResponse, 'StatusCode', TWebResponse_Write_StatusCode, 0, [varEmpty]);\r\n AddGet(TWebResponse, 'ContentLength', TWebResponse_Read_ContentLength, 0, [varEmpty], varEmpty);\r\n AddSet(TWebResponse, 'ContentLength', TWebResponse_Write_ContentLength, 0, [varEmpty]);\r\n AddGet(TWebResponse, 'Date', TWebResponse_Read_Date, 0, [varEmpty], varEmpty);\r\n AddSet(TWebResponse, 'Date', TWebResponse_Write_Date, 0, [varEmpty]);\r\n AddGet(TWebResponse, 'Expires', TWebResponse_Read_Expires, 0, [varEmpty], varEmpty);\r\n AddSet(TWebResponse, 'Expires', TWebResponse_Write_Expires, 0, [varEmpty]);\r\n AddGet(TWebResponse, 'LastModified', TWebResponse_Read_LastModified, 0, [varEmpty], varEmpty);\r\n AddSet(TWebResponse, 'LastModified', TWebResponse_Write_LastModified, 0, [varEmpty]);\r\n AddGet(TWebResponse, 'Content', TWebResponse_Read_Content, 0, [varEmpty], varEmpty);\r\n AddSet(TWebResponse, 'Content', TWebResponse_Write_Content, 0, [varEmpty]);\r\n AddGet(TWebResponse, 'ContentStream', TWebResponse_Read_ContentStream, 0, [varEmpty], varEmpty);\r\n AddSet(TWebResponse, 'ContentStream', TWebResponse_Write_ContentStream, 0, [varEmpty]);\r\n AddGet(TWebResponse, 'LogMessage', TWebResponse_Read_LogMessage, 0, [varEmpty], varEmpty);\r\n AddSet(TWebResponse, 'LogMessage', TWebResponse_Write_LogMessage, 0, [varEmpty]);\r\n AddGet(TWebResponse, 'CustomHeaders', TWebResponse_Read_CustomHeaders, 0, [varEmpty], varEmpty);\r\n AddSet(TWebResponse, 'CustomHeaders', TWebResponse_Write_CustomHeaders, 0, [varEmpty]);\r\n { TWebActionItem }\r\n AddClass(cHTTPApp, TWebActionItem, 'TWebActionItem');\r\n AddGet(TWebActionItem, 'Create', TWebActionItem_Create, 1, [varObject], varEmpty);\r\n AddGet(TWebActionItem, 'AssignTo', TWebActionItem_AssignTo, 1, [varObject], varEmpty);\r\n AddGet(TWebActionItem, 'Default', TWebActionItem_Read_Default, 0, [varEmpty], varEmpty);\r\n AddSet(TWebActionItem, 'Default', TWebActionItem_Write_Default, 0, [varEmpty]);\r\n AddGet(TWebActionItem, 'Enabled', TWebActionItem_Read_Enabled, 0, [varEmpty], varEmpty);\r\n AddSet(TWebActionItem, 'Enabled', TWebActionItem_Write_Enabled, 0, [varEmpty]);\r\n AddGet(TWebActionItem, 'MethodType', TWebActionItem_Read_MethodType, 0, [varEmpty], varEmpty);\r\n AddSet(TWebActionItem, 'MethodType', TWebActionItem_Write_MethodType, 0, [varEmpty]);\r\n AddGet(TWebActionItem, 'Name', TWebActionItem_Read_Name, 0, [varEmpty], varEmpty);\r\n AddSet(TWebActionItem, 'Name', TWebActionItem_Write_Name, 0, [varEmpty]);\r\n AddGet(TWebActionItem, 'PathInfo', TWebActionItem_Read_PathInfo, 0, [varEmpty], varEmpty);\r\n AddSet(TWebActionItem, 'PathInfo', TWebActionItem_Write_PathInfo, 0, [varEmpty]);\r\n AddGet(TWebActionItem, 'Producer', TWebActionItem_Read_Producer, 0, [varEmpty], varEmpty);\r\n AddSet(TWebActionItem, 'Producer', TWebActionItem_Write_Producer, 0, [varEmpty]);\r\n { TWebDispatcher }\r\n AddClass(cHTTPApp, TWebDispatcher, 'TWebDispatcher');\r\n AddFunction(cHTTPApp, 'DosPathToUnixPath', JvInterpreter_DosPathToUnixPath, 1, [varString], varEmpty);\r\n AddFunction(cHTTPApp, 'HTTPDecode', JvInterpreter_HTTPDecode, 1, [varString], varEmpty);\r\n AddFunction(cHTTPApp, 'HTTPEncode', JvInterpreter_HTTPEncode, 1, [varString], varEmpty);\r\n AddFunction(cHTTPApp, 'ParseDate', JvInterpreter_ParseDate, 1, [varString], varEmpty);\r\n AddFunction(cHTTPApp, 'StatusString', JvInterpreter_StatusString, 1, [varInteger], varEmpty);\r\n AddFunction(cHTTPApp, 'UnixPathToDosPath', JvInterpreter_UnixPathToDosPath, 1, [varString], varEmpty);\r\n AddFunction(cHTTPApp, 'MonthStr', JvInterpreter_MonthStr, 1, [varEmpty], varEmpty);\r\n AddFunction(cHTTPApp, 'DayOfWeekStr', JvInterpreter_DayOfWeekStr, 1, [varEmpty], varEmpty);\r\n end;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvItemsPanel.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvItemsPanel.PAS, released on 2002-05-26.\r\n\r\nThe Initial Developer of the Original Code is Peter Thrnqvist [peter3 at sourceforge dot net]\r\nPortions created by Peter Thrnqvist are Copyright (C) 2002 Peter Thrnqvist.\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nDescription:\r\n A Panel that is divided into items defined by the Items property\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvItemsPanel.pas 13104 2011-09-07 06:50:43Z obones $\r\n\r\nunit JvItemsPanel;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n SysUtils, Classes,\r\n Windows, Messages, Graphics, Controls, ExtCtrls,\r\n JvExtComponent, JvThemes, JvJCLUtils, JvExControls;\r\n\r\ntype\r\n TJvPanelItemClickEvent = procedure(Sender: TObject; ItemIndex: Integer) of object;\r\n TJvPanelOrientation = (poHorizontal, poVertical);\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvItemsPanel = class(TJvCustomPanel, IJvDenySubClassing)\r\n private\r\n FItems: TStringList;\r\n FItemHeight: Integer;\r\n FAutoSize: Boolean;\r\n FAutoGrow: Boolean;\r\n FDown: Boolean;\r\n FClickable: Boolean;\r\n FDownRect: TRect;\r\n FHotTrack: Boolean;\r\n FHotTrackColor: TColor;\r\n FOnItemClick: TJvPanelItemClickEvent;\r\n FOrientation: TJvPanelOrientation;\r\n function GetCaption: TCaption;\r\n function GetItems: TStrings;\r\n procedure SetItems(const Value: TStrings);\r\n procedure SetItemHeight(const Value: Integer);\r\n procedure SetAutoGrow(const Value: Boolean);\r\n procedure SetHotTrack(const Value: Boolean);\r\n procedure SetHotTrackColor(const Value: TColor);\r\n procedure SetClickable(const Value: Boolean);\r\n procedure SetOrientation(const Value: TJvPanelOrientation);\r\n procedure WMSize(var Msg: TWMSize); message WM_SIZE;\r\n protected\r\n procedure SetAutoSize(Value: Boolean); override;\r\n procedure Grow;\r\n procedure PaintDown;\r\n procedure PaintUp;\r\n procedure PaintHi;\r\n procedure DrawItemText(Index: Integer; R: TRect; HighLight: Boolean);\r\n procedure Paint; override;\r\n procedure DoItemClick(ItemIndex: Integer); dynamic;\r\n procedure MouseDown(Button: TMouseButton; Shift: TShiftState;\r\n X, Y: Integer); override;\r\n procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;\r\n procedure MouseUp(Button: TMouseButton; Shift: TShiftState;\r\n X, Y: Integer); override;\r\n procedure MouseLeave(Control: TControl); override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n function GetItemAt(X, Y: Integer): Integer;\r\n function GetItemRect(Index: Integer): TRect;\r\n property Canvas;\r\n published\r\n property AutoGrow: Boolean read FAutoGrow write SetAutoGrow;\r\n property AutoSize: Boolean read FAutoSize write SetAutoSize;\r\n property Items: TStrings read GetItems write SetItems;\r\n property ItemHeight: Integer read FItemHeight write SetItemHeight default 16;\r\n property HotTrack: Boolean read FHotTrack write SetHotTrack;\r\n property HotTrackColor: TColor read FHotTrackColor write SetHotTrackColor default clHighLight;\r\n property Caption: TCaption read GetCaption; // hide\r\n property Clickable: Boolean read FClickable write SetClickable default True;\r\n property Orientation: TJvPanelOrientation read FOrientation write SetOrientation default poVertical;\r\n // property Images: TImageList;\r\n // property ImageIndex[ItemIndex: Integer]: Integer;\r\n property OnItemClick: TJvPanelItemClickEvent read FOnItemClick write FOnItemClick;\r\n property Align;\r\n property Alignment;\r\n property Anchors;\r\n property BiDiMode;\r\n property UseDockManager default True;\r\n property DockSite;\r\n property DragCursor;\r\n property DragKind;\r\n property ParentBiDiMode;\r\n property BorderWidth;\r\n property Color;\r\n property Constraints;\r\n property DragMode;\r\n property Enabled;\r\n // property FullRepaint;\r\n property Font;\r\n // property Locked;\r\n property ParentColor;\r\n property ParentFont;\r\n property ParentShowHint;\r\n property PopupMenu;\r\n property ShowHint;\r\n property TabOrder;\r\n property TabStop;\r\n property Visible;\r\n property OnClick;\r\n property OnConstrainedResize;\r\n property OnContextPopup;\r\n property OnCanResize;\r\n property OnDockDrop;\r\n property OnDockOver;\r\n property OnEndDock;\r\n property OnGetSiteInfo;\r\n property OnStartDock;\r\n property OnUnDock;\r\n property OnDblClick;\r\n property OnDragDrop;\r\n property OnDragOver;\r\n property OnEndDrag;\r\n property OnEnter;\r\n property OnExit;\r\n property OnMouseDown;\r\n property OnMouseMove;\r\n property OnMouseUp;\r\n property OnResize;\r\n property OnStartDrag;\r\n {$IFDEF JVCLThemesEnabled}\r\n property ParentBackground default True;\r\n {$ENDIF JVCLThemesEnabled}\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvItemsPanel.pas $';\r\n Revision: '$Revision: 13104 $';\r\n Date: '$Date: 2011-09-07 08:50:43 +0200 (mer. 07 sept. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\n\r\nconstructor TJvItemsPanel.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n ControlStyle := ControlStyle - [csSetCaption];\r\n IncludeThemeStyle(Self, [csNeedsBorderPaint, csParentBackground]);\r\n BevelInner := bvNone;\r\n BevelOuter := bvNone;\r\n FItemHeight := 16;\r\n FItems := TStringList.Create;\r\n FHotTrackColor := clHighLight;\r\n FClickable := True;\r\n FOrientation := poVertical;\r\n inherited Caption := '';\r\nend;\r\n\r\ndestructor TJvItemsPanel.Destroy;\r\nbegin\r\n FItems.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJvItemsPanel.GetCaption: TCaption;\r\nbegin\r\n Result := '';\r\n inherited Caption := '';\r\nend;\r\n\r\nprocedure TJvItemsPanel.Paint;\r\nvar\r\n I, Rest: Integer;\r\n R: TRect;\r\nbegin\r\n// inherited Paint;\r\n Canvas.Brush.Color := Self.Color;\r\n DrawThemedBackground(Self, Canvas, ClientRect);\r\n if Items.Count = 0 then\r\n Exit;\r\n Rest := 0;\r\n if AutoSize then\r\n begin\r\n if Orientation = poVertical then\r\n begin\r\n ItemHeight := Height div Items.Count;\r\n Rest := Height - ItemHeight * Items.Count\r\n end\r\n else\r\n begin\r\n ItemHeight := Width div Items.Count;\r\n Rest := Width - ItemHeight * Items.Count\r\n end;\r\n end;\r\n\r\n for I := 0 to Items.Count - 1 do\r\n begin\r\n R := GetItemRect(I);\r\n if I = Items.Count - 1 then\r\n begin\r\n if Orientation = poVertical then\r\n R.Bottom := R.Bottom + Rest\r\n else\r\n R.Right := R.Right + Rest;\r\n end;\r\n Frame3D(Canvas, R, clBtnHighLight, clBtnShadow, 1);\r\n InflateRect(R, 1, 1);\r\n DrawItemText(I, R, False);\r\n end;\r\nend;\r\n\r\nprocedure TJvItemsPanel.DrawItemText(Index: Integer; R: TRect; HighLight: Boolean);\r\nvar\r\n Flags: Integer;\r\nbegin\r\n if (Index < 0) or (Index >= Items.Count) then\r\n Exit;\r\n Flags := DT_VCENTER or DT_SINGLELINE or DT_NOPREFIX or DT_END_ELLIPSIS or DT_EDITCONTROL;\r\n case Alignment of\r\n taLeftJustify:\r\n Flags := Flags or DT_LEFT;\r\n taCenter:\r\n Flags := Flags or DT_CENTER;\r\n taRightJustify:\r\n Flags := Flags or DT_RIGHT;\r\n end;\r\n R.Left := R.Left + Canvas.TextWidth(' ');\r\n R.Right := R.Right - Canvas.TextWidth(' ');\r\n Canvas.Font := Font;\r\n if FHotTrack and HighLight then\r\n Canvas.Font.Color := FHotTrackColor;\r\n {$IFDEF JVCLThemesEnabled}\r\n if ThemeServices.{$IFDEF RTL230_UP}Enabled{$ELSE}ThemesEnabled{$ENDIF RTL230_UP} then\r\n SetBkMode(Canvas.Handle, TRANSPARENT);\r\n {$ENDIF JVCLThemesEnabled}\r\n DrawText(Canvas, Items[Index], -1, R, Flags);\r\nend;\r\n\r\nprocedure TJvItemsPanel.SetAutoGrow(const Value: Boolean);\r\nbegin\r\n if FAutoGrow <> Value then\r\n begin\r\n FAutoGrow := Value;\r\n if FAutoGrow then\r\n begin\r\n AutoSize := False;\r\n Align := alNone;\r\n end;\r\n Grow;\r\n end;\r\nend;\r\n\r\nprocedure TJvItemsPanel.SetAutoSize(Value: Boolean);\r\nbegin\r\n if FAutoSize <> Value then\r\n begin\r\n FAutoSize := Value;\r\n if AutoSize then\r\n begin\r\n if Orientation = poVertical then\r\n ItemHeight := Height div (Items.Count + 1)\r\n else\r\n ItemHeight := Width div (Items.Count + 1);\r\n end;\r\n Grow;\r\n end;\r\nend;\r\n\r\nprocedure TJvItemsPanel.SetItemHeight(const Value: Integer);\r\nbegin\r\n if FItemHeight <> Value then\r\n begin\r\n FItemHeight := Value;\r\n Grow;\r\n end;\r\nend;\r\n\r\nfunction TJvItemsPanel.GetItems: TStrings;\r\nbegin\r\n Result := FItems;\r\nend;\r\n\r\nprocedure TJvItemsPanel.SetItems(const Value: TStrings);\r\nbegin\r\n FItems.Assign(Value);\r\n Grow;\r\nend;\r\n\r\n\r\nprocedure TJvItemsPanel.WMSize(var Msg: TWMSize);\r\nbegin\r\n inherited;\r\n Grow;\r\nend;\r\n\r\n\r\n\r\n\r\nprocedure TJvItemsPanel.Grow;\r\nbegin\r\n if AutoGrow and (Items.Count > 0) then\r\n begin\r\n if Orientation = poVertical then\r\n Height := Items.Count * ItemHeight\r\n else\r\n Width := Items.Count * ItemHeight;\r\n end\r\n else\r\n Invalidate;\r\nend;\r\n\r\nfunction TJvItemsPanel.GetItemAt(X, Y: Integer): Integer;\r\nbegin\r\n if Orientation = poVertical then\r\n begin\r\n if (Y < 0) or (Y > Items.Count * ItemHeight) or (X < 0) or (X > Width) then\r\n Result := -1\r\n else\r\n Result := Y div ItemHeight;\r\n end\r\n else\r\n begin\r\n if (X < 0) or (X > Items.Count * ItemHeight) or (Y < 0) or (Y > Height) then\r\n Result := -1\r\n else\r\n Result := X div ItemHeight;\r\n end;\r\nend;\r\n\r\nfunction TJvItemsPanel.GetItemRect(Index: Integer): TRect;\r\nbegin\r\n Result := Rect(0, 0, 0, 0);\r\n if (Index < 0) or (Index >= Items.Count) then\r\n Exit;\r\n if Orientation = poVertical then\r\n Result := Rect(0, Index * ItemHeight, Width, Index * ItemHeight + ItemHeight)\r\n else\r\n Result := Rect(Index * ItemHeight, 0, Index * ItemHeight + ItemHeight, Height);\r\nend;\r\n\r\nprocedure TJvItemsPanel.MouseDown(Button: TMouseButton; Shift: TShiftState;\r\n X, Y: Integer);\r\nbegin\r\n inherited MouseDown(Button, Shift, X, Y);\r\n if Button <> mbLeft then\r\n Exit;\r\n FDown := True;\r\n FDownRect := GetItemRect(GetItemAt(X, Y));\r\n PaintDown;\r\nend;\r\n\r\nprocedure TJvItemsPanel.MouseMove(Shift: TShiftState; X, Y: Integer);\r\nbegin\r\n inherited MouseMove(Shift, X, Y);\r\n if FDown then\r\n begin\r\n PaintUp;\r\n FDownRect := GetItemRect(GetItemAt(X, Y));\r\n PaintDown;\r\n end\r\n else\r\n if FHotTrack then\r\n begin\r\n PaintUp;\r\n FDownRect := GetItemRect(GetItemAt(X, Y));\r\n PaintHi;\r\n end;\r\nend;\r\n\r\nprocedure TJvItemsPanel.MouseUp(Button: TMouseButton; Shift: TShiftState;\r\n X, Y: Integer);\r\nvar\r\n I: Integer;\r\nbegin\r\n inherited MouseUp(Button, Shift, X, Y);\r\n PaintUp;\r\n I := GetItemAt(X, Y);\r\n if (I <> -1) and FDown then\r\n DoItemClick(I);\r\n FDown := False;\r\n FDownRect := Rect(0, 0, 0, 0);\r\nend;\r\n\r\nprocedure TJvItemsPanel.PaintDown;\r\nbegin\r\n if not FClickable then\r\n Exit;\r\n Frame3D(Canvas, FDownRect, clBtnShadow, clBtnHighLight, 1);\r\n InflateRect(FDownRect, 1, 1);\r\n if Orientation = poVertical then\r\n DrawItemText(GetItemAt(1, FDownRect.Top + 1), FDownRect, True)\r\n else\r\n DrawItemText(GetItemAt(FDownRect.Left + 1, 1), FDownRect, True);\r\nend;\r\n\r\nprocedure TJvItemsPanel.PaintUp;\r\nbegin\r\n Frame3D(Canvas, FDownRect, clBtnHighLight, clBtnShadow, 1);\r\n InflateRect(FDownRect, 1, 1);\r\n if Orientation = poVertical then\r\n DrawItemText(GetItemAt(1, FDownRect.Top + 1), FDownRect, False)\r\n else\r\n DrawItemText(GetItemAt(FDownRect.Left + 1, 1), FDownRect, False);\r\nend;\r\n\r\nprocedure TJvItemsPanel.PaintHi;\r\nbegin\r\n Frame3D(Canvas, FDownRect, HotTrackColor, HotTrackColor, 1);\r\n InflateRect(FDownRect, 1, 1);\r\n if Orientation = poVertical then\r\n DrawItemText(GetItemAt(1, FDownRect.Top + 1), FDownRect, True)\r\n else\r\n DrawItemText(GetItemAt(FDownRect.Left + 1, 1), FDownRect, True);\r\nend;\r\n\r\nprocedure TJvItemsPanel.MouseLeave(Control: TControl);\r\nbegin\r\n if csDesigning in ComponentState then\r\n Exit;\r\n inherited MouseLeave(Control);\r\n PaintUp;\r\nend;\r\n\r\nprocedure TJvItemsPanel.SetHotTrack(const Value: Boolean);\r\nbegin\r\n if FHotTrack <> Value then\r\n begin\r\n FHotTrack := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvItemsPanel.SetHotTrackColor(const Value: TColor);\r\nbegin\r\n if FHotTrackColor <> Value then\r\n begin\r\n FHotTrackColor := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvItemsPanel.SetClickable(const Value: Boolean);\r\nbegin\r\n if FClickable <> Value then\r\n begin\r\n FClickable := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvItemsPanel.DoItemClick(ItemIndex: Integer);\r\nbegin\r\n if Assigned(FOnItemClick) then\r\n FOnItemClick(Self, ItemIndex);\r\nend;\r\n\r\nprocedure TJvItemsPanel.SetOrientation(const Value: TJvPanelOrientation);\r\nbegin\r\n if FOrientation <> Value then\r\n begin\r\n FOrientation := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvItemsSearchs.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvItemsSearchs.PAS, released on 2001-02-28.\r\n\r\nThe Initial Developer of the Original Code is Sbastien Buysse [sbuysse att buypin dott com]\r\nPortions created by Sbastien Buysse are Copyright (C) 2001 Sbastien Buysse.\r\nAll Rights Reserved.\r\n\r\nContributor(s): Michael Beck [mbeck att bigfoot dott com].\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvItemsSearchs.pas 12461 2009-08-14 17:21:33Z obones $\r\n\r\nunit JvItemsSearchs;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n {$IFDEF COMPILER9_UP}\r\n Windows,\r\n {$ENDIF COMPILER9_UP}\r\n SysUtils, Classes;\r\n\r\ntype\r\n // (rom) made them all class functions\r\n TJvItemsSearchs = class(TObject)\r\n public\r\n class function SearchExactString(Items: TStrings; const Value: string;\r\n CaseSensitive: Boolean = True; StartIndex: Integer = -1): Integer;\r\n class function SearchPrefix(Items: TStrings; Value: string;\r\n CaseSensitive: Boolean = True; StartIndex: Integer = -1): Integer;\r\n class function SearchSubString(Items: TStrings; Value: string;\r\n CaseSensitive: Boolean = True; StartIndex: Integer = -1): Integer;\r\n class function DeleteExactString(Items: TStrings; const Value: string; All: Boolean;\r\n CaseSensitive: Boolean = True): Integer;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvItemsSearchs.pas $';\r\n Revision: '$Revision: 12461 $';\r\n Date: '$Date: 2009-08-14 19:21:33 +0200 (ven. 14 août 2009) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\n\r\nclass function TJvItemsSearchs.DeleteExactString(Items: TStrings; const Value: string;\r\n All: Boolean; CaseSensitive: Boolean): Integer;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := 0;\r\n Items.BeginUpdate;\r\n try\r\n I := SearchExactString(Items, Value, CaseSensitive);\r\n while I <> -1 do\r\n begin\r\n Inc(Result);\r\n Items.Delete(I);\r\n if All then\r\n I := SearchExactString(Items, Value, CaseSensitive)\r\n else\r\n Exit;\r\n end;\r\n finally\r\n Items.EndUpdate;\r\n end;\r\nend;\r\n\r\nclass function TJvItemsSearchs.SearchExactString(Items: TStrings; const Value: string;\r\n CaseSensitive: Boolean; StartIndex: Integer): Integer;\r\nvar\r\n I: Integer;\r\n HasLooped: Boolean;\r\nbegin\r\n Result := -1;\r\n I := StartIndex + 1;\r\n HasLooped := False;\r\n if CaseSensitive then\r\n begin\r\n while not HasLooped or (I <= StartIndex) do\r\n if I >= Items.Count then\r\n begin\r\n I := 0;\r\n HasLooped := True;\r\n end\r\n else\r\n if AnsiCompareStr(Value, Items[I]) = 0 then\r\n begin\r\n Result := I;\r\n Exit;\r\n end\r\n else\r\n Inc(I);\r\n end\r\n else\r\n begin\r\n while not HasLooped or (I <= StartIndex) do\r\n if I >= Items.Count then\r\n begin\r\n I := 0;\r\n HasLooped := True;\r\n end\r\n else\r\n if AnsiSameText(Value, Items[I]) then\r\n begin\r\n Result := I;\r\n Exit;\r\n end\r\n else\r\n Inc(I);\r\n end;\r\nend;\r\n\r\nclass function TJvItemsSearchs.SearchPrefix(Items: TStrings; Value: string;\r\n CaseSensitive: Boolean; StartIndex: Integer): Integer;\r\nvar\r\n I: Integer;\r\n HasLooped: Boolean;\r\nbegin\r\n Result := -1;\r\n I := StartIndex + 1;\r\n HasLooped := False;\r\n if CaseSensitive then\r\n begin\r\n while not HasLooped or (I <= StartIndex) do\r\n if I >= Items.Count then\r\n begin\r\n I := 0;\r\n HasLooped := True;\r\n end\r\n else\r\n if Pos(Value, Items[I]) = 1 then\r\n begin\r\n Result := I;\r\n Exit;\r\n end\r\n else\r\n Inc(I);\r\n end\r\n else\r\n begin\r\n Value := AnsiUpperCase(Value);\r\n while not HasLooped or (I <= StartIndex) do\r\n if I >= Items.Count then\r\n begin\r\n I := 0;\r\n HasLooped := True;\r\n end\r\n else\r\n if Pos(Value, AnsiUpperCase(Items[I])) = 1 then\r\n begin\r\n Result := I;\r\n Exit;\r\n end\r\n else\r\n Inc(I);\r\n end;\r\nend;\r\n\r\nclass function TJvItemsSearchs.SearchSubString(Items: TStrings; Value: string;\r\n CaseSensitive: Boolean; StartIndex: Integer): Integer;\r\nvar\r\n I: Integer;\r\n HasLooped: Boolean;\r\nbegin\r\n Result := -1;\r\n I := StartIndex + 1;\r\n HasLooped := False;\r\n if CaseSensitive then\r\n begin\r\n while not HasLooped or (I <= StartIndex) do\r\n if I >= Items.Count then\r\n begin\r\n I := 0;\r\n HasLooped := True;\r\n end\r\n else\r\n if Pos(Value, Items[I]) <> 0 then\r\n begin\r\n Result := I;\r\n Exit;\r\n end\r\n else\r\n Inc(I);\r\n end\r\n else\r\n begin\r\n Value := AnsiUpperCase(Value);\r\n while not HasLooped or (I <= StartIndex) do\r\n if I >= Items.Count then\r\n begin\r\n I := 0;\r\n HasLooped := True;\r\n end\r\n else\r\n if Pos(Value, AnsiUpperCase(Items[I])) <> 0 then\r\n begin\r\n Result := I;\r\n Exit;\r\n end\r\n else\r\n Inc(I);\r\n end;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvJCLUtils.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvJCLUtils.pas, released on 2002-07-04.\r\n\r\nThe Initial Developers of the Original Code are: Andrei Prygounkov \r\nCopyright (c) 1999, 2002 Andrei Prygounkov\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\n Andreas Hausladen\r\n Ralf Kaiser\r\n Vladimir Gaitanoff\r\n Dejoy den\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvJCLUtils.pas 13415 2012-09-10 09:51:54Z obones $\r\n\r\nunit JvJCLUtils;\r\n\r\n{$I jvcl.inc}\r\n{$I crossplatform.inc}\r\n\r\ninterface\r\n\r\n// (p3) note: this unit should only contain JCL compatible routines (no Forms etc)\r\n// and no JVCL units!\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n {$IFDEF MSWINDOWS}\r\n Windows, Messages, ShlObj, ActiveX,\r\n {$ENDIF MSWINDOWS}\r\n Types,\r\n {$IFDEF HAS_UNIT_SYSTEM_UITYPES}\r\n System.UITypes,\r\n {$ENDIF}\r\n Variants, SysUtils, Classes, Contnrs, Graphics, Clipbrd, Controls,\r\n StrUtils, TypInfo,\r\n JclBase,\r\n JvTypes;\r\n\r\nconst\r\n {$IFDEF MSWINDOWS}\r\n PathDelim = '\\';\r\n DriveDelim = ':';\r\n PathSep = ';';\r\n AllFilesMask = '*.*';\r\n {$ENDIF MSWINDOWS}\r\n {$IFDEF UNIX}\r\n PathDelim = '/';\r\n AllFilesMask = '*';\r\n {$ENDIF UNIX}\r\n // Note: the else is on purpose, VCL is not defined for a console application\r\n NullHandle = 0;\r\n USDecimalSeparator = '.';\r\n\r\n{$IFNDEF COMPILER12_UP} // Delphi 2009 introduced it and fixed the NativeInt of Delphi 2007\r\ntype\r\n // Compatibility for older Delphi versions, so the JVCL doesn't need to IFDEFs every call to\r\n // SetWindowLongPtr/GetWindowLongPtr.\r\n NativeInt = Integer;\r\n\r\n {$EXTERNALSYM INT_PTR}\r\n INT_PTR = Integer;\r\n {$EXTERNALSYM LONG_PTR}\r\n LONG_PTR = Longint;\r\n {$EXTERNALSYM UINT_PTR}\r\n UINT_PTR = Cardinal;\r\n {$EXTERNALSYM ULONG_PTR}\r\n ULONG_PTR = LongWord;\r\n {$EXTERNALSYM DWORD_PTR}\r\n DWORD_PTR = ULONG_PTR;\r\n\r\n{$EXTERNALSYM GetWindowLongPtr}\r\nfunction GetWindowLongPtr(hWnd: HWND; nIndex: Integer): LONG_PTR; stdcall;\r\n{$EXTERNALSYM SetWindowLongPtr}\r\nfunction SetWindowLongPtr(hWnd: HWND; nIndex: Integer; dwNewLong: LONG_PTR): LONG_PTR; stdcall;\r\n{$ENDIF ~COMPILER12_UP}\r\n\r\ntype\r\n EJvConvertError = Class(EConvertError); { subclass EConvertError raised by some non-Def versions of floating point conversion routine }\r\n {$IFDEF UNIX}\r\n TFileTime = Integer;\r\n {$ENDIF UNIX}\r\n\r\n {$IFNDEF RTL150_UP}\r\n TFormatSettings = record\r\n DecimalSeparator: Char;\r\n end;\r\n {$ENDIF RTL150_UP}\r\n\r\nfunction SendRectMessage(Handle: THandle; Msg: Integer; wParam: WPARAM; var R: TRect): Integer;\r\nfunction SendStructMessage(Handle: THandle; Msg: Integer; wParam: WPARAM; var Data): Integer;\r\nfunction ReadCharsFromStream(Stream: TStream; var Buf: array of AnsiChar; BufSize: Integer): Integer; // ANSI-Stream\r\nfunction WriteStringToStream(Stream: TStream; const Buf: AnsiString; BufSize: Integer): Integer; // ANSI-Stream\r\n\r\n{$IFNDEF COMPILER12_UP}\r\nfunction UTF8ToString(const S: UTF8String): string; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\n{$ENDIF ~COMPILER12_UP}\r\n\r\nconst\r\n DefaultDateOrder = doDMY;\r\n CenturyOffset: Byte = 60;\r\n NullDate: TDateTime = {-693594} 0;\r\n\r\n\r\n//------------------------------------------------------------------------------------\r\n// This 'USA' hack functionality is made useless by the JvSafeStrToFloatDef routine:\r\n//------------------------------------------------------------------------------------\r\n //function USToLocalFloatStr(const Text: string): string; // deprecated.\r\n //function StrToFloatUS(const Text: string): Extended;\r\n // StrToFloatUS uses US '.' as decimal seperator and ',' as thousand separator\r\n //function StrToFloatUSDef(const Text: string; Default: Extended): Extended;\r\n\r\n\r\nfunction VarIsInt(Value: Variant): Boolean;\r\n // VarIsInt returns VarIsOrdinal-[varBoolean]\r\n\r\n{ PosIdx returns the index of the first appearance of SubStr in Str. The search\r\n starts at index \"Index\". }\r\nfunction PosIdx(const SubStr, S: string; Index: Integer = 0): Integer;\r\nfunction PosIdxW(const SubStr, S: WideString; Index: Integer = 0): Integer;\r\nfunction PosLastCharIdx(Ch: Char; const S: string; Index: Integer = 0): Integer;\r\n\r\n{ GetWordOnPos returns Word from string, S, on the cursor position, P}\r\nfunction GetWordOnPos(const S: string; const P: Integer): string;\r\nfunction GetWordOnPosW(const S: WideString; const P: Integer): WideString;\r\nfunction GetWordOnPos2(const S: string; P: Integer; var iBeg, iEnd: Integer): string;\r\nfunction GetWordOnPos2W(const S: WideString; P: Integer; var iBeg, iEnd: Integer): WideString;\r\n{ GetWordOnPosEx working like GetWordOnPos function, but\r\n also returns Word position in iBeg, iEnd variables }\r\nfunction GetWordOnPosEx(const S: string; const P: Integer; var iBeg, iEnd: Integer): string;\r\nfunction GetWordOnPosExW(const S: WideString; const P: Integer; var iBeg, iEnd: Integer): WideString;\r\nfunction GetNextWordPosEx(const Text: string; StartIndex: Integer;\r\n var iBeg, iEnd: Integer): string;\r\nfunction GetNextWordPosExW(const Text: WideString; StartIndex: Integer;\r\n var iBeg, iEnd: Integer): WideString;\r\nprocedure GetEndPosCaret(const Text: string; CaretX, CaretY: Integer;\r\n var X, Y: Integer);\r\n{ GetEndPosCaret returns the caret position of the last char. For the position\r\n after the last char of Text you must add 1 to the returned X value. }\r\nprocedure GetEndPosCaretW(const Text: WideString; CaretX, CaretY: Integer;\r\n var X, Y: Integer);\r\n{ GetEndPosCaret returns the caret position of the last char. For the position\r\n after the last char of Text you must add 1 to the returned X value. }\r\n\r\n{ SubStrBySeparator returns substring from string, S, separated with Separator string}\r\nfunction SubStrBySeparator(const S: string; const Index: Integer; const Separator: string; StartIndex: Integer = 1): string;\r\nfunction SubStrBySeparatorW(const S: WideString; const Index: Integer; const Separator: WideString; StartIndex: Integer = 1): WideString;\r\n{ SubStrEnd same to previous function but Index numerated from the end of string }\r\n//function SubStrEnd(const S: string; const Index: Integer; const Separator: string): string;\r\n{ SubWord returns next Word from string, P, and offsets Pointer to the end of Word, P2 }\r\nfunction SubWord(P: PChar; var P2: PChar): string;\r\n// function CurrencyByWord(Value: Currency): string;\r\n{ GetLineByPos returns the Line number, there\r\n the symbol Pos is pointed. Lines separated with #13 symbol }\r\nfunction GetLineByPos(const S: string; const Pos: Integer): Integer;\r\n{ GetXYByPos is same as GetLineByPos, but returns X position in line as well}\r\nprocedure GetXYByPos(const S: string; const Pos: Integer; var X, Y: Integer);\r\nprocedure GetXYByPosW(const S: WideString; const Pos: Integer; var X, Y: Integer);\r\n{ ReplaceString searches for all substrings, OldPattern,\r\n in a string, S, and replaces them with NewPattern }\r\nfunction ReplaceString(S: string; const OldPattern, NewPattern: string; StartIndex: Integer = 1): string;\r\nfunction ReplaceStringW(S: WideString; const OldPattern, NewPattern: WideString; StartIndex: Integer = 1): WideString;\r\n{ ConcatSep concatenate S1 and S2 strings with Separator.\r\n if S = '' then separator not included }\r\nfunction ConcatSep(const S1, S2, Separator: string): string; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF SUPPORTS_INLINE}\r\n{ ConcatLeftSep is same to previous function, but\r\n strings concatenate right to left }\r\nfunction ConcatLeftSep(const S1, S2, Separator: string): string; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF SUPPORTS_INLINE}\r\n\r\n{ Next 4 function for russian chars transliterating.\r\n This functions are needed because Oem2Ansi and Ansi2Oem functions\r\n sometimes suck }\r\nprocedure Dos2Win(var S: AnsiString);\r\nprocedure Win2Dos(var S: AnsiString);\r\nfunction Dos2WinRes(const S: AnsiString): AnsiString; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF SUPPORTS_INLINE}\r\nfunction Win2DosRes(const S: AnsiString): AnsiString; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF SUPPORTS_INLINE}\r\nfunction Win2Koi(const S: AnsiString): AnsiString;\r\n\r\n{ FillString fills the string Buffer with Count Chars }\r\nprocedure FillString(var Buffer: string; Count: Integer; const Value: Char); overload;\r\nprocedure FillString(var Buffer: string; StartIndex, Count: Integer; const Value: Char); overload;\r\n{ MoveString copies Count Chars from Source to Dest }\r\nprocedure MoveString(const Source: string; var Dest: string; Count: Integer); {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF SUPPORTS_INLINE} overload;\r\nprocedure MoveString(const Source: string; SrcStartIdx: Integer; var Dest: string;\r\n DstStartIdx: Integer; Count: Integer); {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF SUPPORTS_INLINE} overload;\r\n{ FillWideChar fills Buffer with Count WideChars (2 Bytes) }\r\nprocedure FillWideChar(var Buffer; Count: Integer; const Value: WideChar);\r\n{ MoveWideChar copies Count WideChars from Source to Dest }\r\nprocedure MoveWideChar(const Source; var Dest; Count: Integer); {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF SUPPORTS_INLINE}\r\n{ FillNativeChar fills Buffer with Count NativeChars }\r\nprocedure FillNativeChar(var Buffer; Count: Integer; const Value: Char); // D2009 internal error {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF SUPPORTS_INLINE}\r\n{ MoveWideChar copies Count WideChars from Source to Dest }\r\nprocedure MoveNativeChar(const Source; var Dest; Count: Integer); // D2009 internal error {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF SUPPORTS_INLINE}\r\n{ IsSubString() compares the sub string to the string. Indices are 1th based. }\r\nfunction IsSubString(const S: string; StartIndex: Integer; const SubStr: string): Boolean;\r\n\r\n{ Spaces returns string consists on N space chars }\r\nfunction Spaces(const N: Integer): string;\r\n{ AddSpaces adds spaces to string S, if its Length is smaller than N }\r\nfunction AddSpaces(const S: string; const N: Integer): string;\r\nfunction SpacesW(const N: Integer): WideString;\r\nfunction AddSpacesW(const S: WideString; const N: Integer): WideString;\r\n{ function LastDateRUS for russian users only }\r\n{ returns date relative to current date: ' ' }\r\nfunction LastDateRUS(const Dat: TDateTime): string;\r\n{ CurrencyToStr format Currency, Cur, using ffCurrency float format}\r\nfunction CurrencyToStr(const Cur: Currency): string;\r\n{ HasChar returns True, if Char, Ch, contains in string, S }\r\nfunction HasChar(const Ch: Char; const S: string): Boolean;\r\nfunction HasCharW(const Ch: WideChar; const S: WideString): Boolean; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF SUPPORTS_INLINE}\r\nfunction HasAnyChar(const Chars: string; const S: string): Boolean;\r\n{$IFNDEF COMPILER12_UP}\r\nfunction ToUpper(C: Char): Char; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF SUPPORTS_INLINE}\r\n{$ENDIF ~COMPILER12_UP}\r\n{$IFNDEF COMPILER12_UP}\r\nfunction CharInSet(const Ch: AnsiChar; const SetOfChar: TSysCharSet): Boolean; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF SUPPORTS_INLINE}\r\n{$ENDIF ~COMPILER12_UP}\r\nfunction CharInSetW(const Ch: WideChar; const SetOfChar: TSysCharSet): Boolean; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF SUPPORTS_INLINE}\r\nfunction CountOfChar(const Ch: Char; const S: string): Integer;\r\nfunction DefStr(const S: string; Default: string): string; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF SUPPORTS_INLINE}\r\n\r\n{ StrLICompW2 is a faster replacement for JclUnicode.StrLICompW }\r\nfunction StrLICompW2(S1, S2: PWideChar; MaxLen: Integer): Integer;\r\nfunction StrPosW(S, SubStr: PWideChar): PWideChar;\r\nfunction StrLenW(S: PWideChar): Integer;\r\nfunction TrimW(const S: WideString): WideString; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF SUPPORTS_INLINE}\r\nfunction TrimLeftW(const S: WideString): WideString; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF SUPPORTS_INLINE}\r\nfunction TrimRightW(const S: WideString): WideString; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF SUPPORTS_INLINE}\r\n{**** files routines}\r\nprocedure SetDelimitedText(List: TStrings; const Text: string; Delimiter: Char);\r\n\r\nconst\r\n {$IFDEF MSWINDOWS}\r\n DefaultCaseSensitivity = False;\r\n {$ENDIF MSWINDOWS}\r\n {$IFDEF UNIX}\r\n DefaultCaseSensitivity = True;\r\n {$ENDIF UNIX}\r\n\r\n{ GenTempFileName returns temporary file name on\r\n drive, there FileName is placed }\r\nfunction GenTempFileName(FileName: string): string;\r\n{ GenTempFileNameExt same to previous function, but\r\n returning filename has given extension, FileExt }\r\nfunction GenTempFileNameExt(FileName: string; const FileExt: string): string;\r\n{ ClearDir clears folder Dir }\r\nfunction ClearDir(const Dir: string): Boolean;\r\n{ DeleteDir clears and than delete folder Dir }\r\nfunction DeleteDir(const Dir: string): Boolean;\r\n{ FileEquMask returns True if file, FileName,\r\n is compatible with given dos file mask, Mask }\r\nfunction FileEquMask(FileName, Mask: TFileName;\r\n CaseSensitive: Boolean = DefaultCaseSensitivity): Boolean;\r\n{ FileEquMasks returns True if file, FileName,\r\n is compatible with given Masks.\r\n Masks must be separated with SepPath (MSW: ';' / UNIX: ':') }\r\nfunction FileEquMasks(FileName, Masks: TFileName;\r\n CaseSensitive: Boolean = DefaultCaseSensitivity): Boolean;\r\nfunction DeleteFiles(const Folder: TFileName; const Masks: string): Boolean;\r\n\r\n{$IFDEF MSWINDOWS}\r\n{ LZFileExpand expand file, FileSource,\r\n into FileDest. Given file must be compressed, using MS Compress program }\r\nfunction LZFileExpand(const FileSource, FileDest: string): Boolean;\r\n{$ENDIF MSWINDOWS}\r\n\r\n{ FileGetInfo fills SearchRec record for specified file attributes}\r\nfunction FileGetInfo(FileName: TFileName; var SearchRec: TSearchRec): Boolean;\r\n{ HasSubFolder returns True, if folder APath contains other folders }\r\nfunction HasSubFolder(APath: TFileName): Boolean;\r\n{ IsEmptyFolder returns True, if there are no files or\r\n folders in given folder, APath}\r\nfunction IsEmptyFolder(APath: TFileName): Boolean;\r\n{ AddSlash returns string with added slash Char to Dir parameter, if needed }\r\nfunction AddSlash(const Dir: TFileName): string; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF SUPPORTS_INLINE}\r\n{ AddPath returns FileName with Path, if FileName not contain any path }\r\nfunction AddPath(const FileName, Path: TFileName): TFileName;\r\nfunction AddPaths(const PathList, Path: string): string;\r\nfunction ParentPath(const Path: TFileName): TFileName;\r\nfunction FindInPath(const FileName, PathList: string): TFileName;\r\n{ DeleteReadOnlyFile clears R/O file attribute and delete file }\r\nfunction DeleteReadOnlyFile(const FileName: TFileName): Boolean;\r\n{ HasParam returns True, if program running with specified parameter, Param }\r\nfunction HasParam(const Param: string): Boolean;\r\nfunction HasSwitch(const Param: string): Boolean;\r\nfunction Switch(const Param: string): string;\r\n{ ExePath returns ExtractFilePath(ParamStr(0)) }\r\nfunction ExePath: TFileName; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF SUPPORTS_INLINE}\r\nfunction CopyDir(const SourceDir, DestDir: TFileName): Boolean;\r\n//function FileTimeToDateTime(const FT: TFileTime): TDateTime;\r\nprocedure FileTimeToDosDateTimeDWord(const FT: TFileTime; out Dft: DWORD);\r\nfunction MakeValidFileName(const FileName: TFileName; ReplaceBadChar: Char): TFileName;\r\n\r\n{**** Graphic routines }\r\n\r\n\r\n{ IsTTFontSelected returns True, if True Type font\r\n is selected in specified device context }\r\nfunction IsTTFontSelected(const DC: HDC): Boolean;\r\nfunction KeyPressed(VK: Integer): Boolean;\r\n\r\n\r\n\r\n\r\n{ TrueInflateRect inflates rect in other method, than InflateRect API function }\r\nfunction TrueInflateRect(const R: TRect; const I: Integer): TRect;\r\n{**** Color routines }\r\nprocedure RGBToHSV(R, G, B: Integer; var H, S, V: Integer);\r\nfunction RGBToBGR(Value: Cardinal): Cardinal;\r\nfunction ColorToPrettyName(Value: TColor): string;\r\nfunction PrettyNameToColor(const Value: string): TColor;\r\n\r\n{**** other routines }\r\nprocedure SwapInt(var Int1, Int2: Integer); {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF SUPPORTS_INLINE}\r\nfunction IntPower(Base, Exponent: Integer): Integer;\r\nfunction StrToBool(const S: string): Boolean;\r\n\r\nfunction Var2Type(V: Variant; const DestVarType: Integer): Variant;\r\nfunction VarToInt(V: Variant): Integer;\r\nfunction VarToFloat(V: Variant): Double;\r\n\r\n{ following functions are not documented\r\n because they do not work properly sometimes, so do not use them }\r\n// (rom) ReplaceStrings1, GetSubStr removed\r\n\r\nfunction GetLongFileName(const FileName: string): string;\r\nfunction FileNewExt(const FileName, NewExt: TFileName): TFileName;\r\nfunction GetParameter: string;\r\nfunction GetComputerID: string;\r\nfunction GetComputerName: string;\r\n\r\n{**** string routines }\r\n\r\n{ ReplaceAllStrings searches for all substrings, Words,\r\n in a string, S, and replaces them with Frases with the same Index. }\r\nfunction ReplaceAllStrings(const S: string; Words, Frases: TStrings): string;\r\n{ ReplaceStrings searches the Word in a string, S, on PosBeg position,\r\n in the list, Words, and if founds, replaces this Word\r\n with string from another list, Frases, with the same Index,\r\n and then update NewSelStart variable }\r\nfunction ReplaceStrings(const S: string; PosBeg, Len: Integer; Words, Frases: TStrings; var NewSelStart: Integer): string;\r\n{ CountOfLines calculates the lines count in a string, S,\r\n each line must be separated from another with CrLf sequence }\r\nfunction CountOfLines(const S: string): Integer;\r\n{ DeleteLines deletes all lines from strings which in the words, words.\r\n The word of will be deleted from strings. }\r\nprocedure DeleteOfLines(Ss: TStrings; const Words: array of string);\r\n{ DeleteEmptyLines deletes all empty lines from strings, Ss.\r\n Lines contained only spaces also deletes. }\r\nprocedure DeleteEmptyLines(Ss: TStrings);\r\n{ SQLAddWhere addes or modifies existing where-statement, where,\r\n to the strings, SQL.\r\n Note: If strings SQL allready contains where-statement,\r\n it must be started on the begining of any line }\r\nprocedure SQLAddWhere(SQL: TStrings; const Where: string);\r\n\r\n{**** files routines - }\r\n\r\n{$IFDEF MSWINDOWS}\r\n{ ResSaveToFile save resource named as Name with Typ type into file FileName.\r\n Resource can be compressed using MS Compress program}\r\nfunction ResSaveToFile(const Typ, Name: string; const Compressed: Boolean; const FileName: string): Boolean;\r\nfunction ResSaveToFileEx(Instance: HINST; Typ, Name: PChar;\r\n const Compressed: Boolean; const FileName: string): Boolean;\r\nfunction ResSaveToString(Instance: HINST; const Typ, Name: string;\r\n var S: string): Boolean;\r\n{$ENDIF MSWINDOWS}\r\n{ IniReadSection read section, Section, from ini-file,\r\n IniFileName, into strings, Ss.\r\n This function reads ALL strings from specified section.\r\n Note: TIninFile.ReadSection function reads only strings with '=' symbol.}\r\nfunction IniReadSection(const IniFileName: TFileName; const Section: string; Ss: TStrings): Boolean;\r\n{ LoadTextFile load text file, FileName, into string }\r\nfunction LoadTextFile(const FileName: TFileName): string;\r\nprocedure SaveTextFile(const FileName: TFileName; const Source: string);\r\n{ ReadFolder reads files list from disk folder, Folder,\r\n that are equal to mask, Mask, into strings, FileList}\r\nfunction ReadFolder(const Folder, Mask: TFileName; FileList: TStrings): Integer;\r\nfunction ReadFolders(const Folder: TFileName; FolderList: TStrings): Integer;\r\n\r\n{ RATextOut same with TCanvas.TextOut procedure, but\r\n can clipping drawing with rectangle, RClip. }\r\nprocedure RATextOut(Canvas: TCanvas; const R, RClip: TRect; const S: string);\r\n{ RATextOutEx same with RATextOut function, but\r\n can calculate needed height for correct output }\r\nfunction RATextOutEx(Canvas: TCanvas; const R, RClip: TRect; const S: string; const CalcHeight: Boolean): Integer;\r\n{ RATextCalcHeight calculate needed height for\r\n correct output, using RATextOut or RATextOutEx functions }\r\nfunction RATextCalcHeight(Canvas: TCanvas; const R: TRect; const S: string): Integer;\r\n{ Cinema draws some visual effect }\r\nprocedure Cinema(Canvas: TCanvas; rS {Source}, rD {Dest}: TRect);\r\n{ Roughed fills rect with special 3D pattern }\r\nprocedure Roughed(ACanvas: TCanvas; const ARect: TRect; const AVert: Boolean);\r\n{ BitmapFromBitmap creates new small bitmap from part\r\n of source bitmap, SrcBitmap, with specified width and height,\r\n AWidth, AHeight and placed on a specified Index, Index in the\r\n source bitmap }\r\nfunction BitmapFromBitmap(SrcBitmap: TBitmap; const AWidth, AHeight, Index: Integer): TBitmap;\r\n{ TextWidth calculate text with for writing using standard desktop font }\r\nfunction TextWidth(const AStr: string): Integer;\r\n{ TextHeight calculate text height for writing using standard desktop font }\r\nfunction TextHeight(const AStr: string): Integer;\r\n\r\nprocedure SetChildPropOrd(Owner: TComponent; const PropName: string; Value: Longint);\r\nprocedure Error(const Msg: string);\r\nprocedure ItemHtDrawEx(Canvas: TCanvas; Rect: TRect;\r\n const State: TOwnerDrawState; const Text: string;\r\n const HideSelColor: Boolean; var PlainItem: string;\r\n var Width: Integer; CalcWidth: Boolean);\r\n{ example for Text parameter :\r\n 'Item 1 bold italic ITALIC red green blue ' }\r\nfunction ItemHtDraw(Canvas: TCanvas; Rect: TRect;\r\n const State: TOwnerDrawState; const Text: string;\r\n const HideSelColor: Boolean): string;\r\nfunction ItemHtWidth(Canvas: TCanvas; Rect: TRect;\r\n const State: TOwnerDrawState; const Text: string;\r\n const HideSelColor: Boolean): Integer;\r\nfunction ItemHtPlain(const Text: string): string;\r\n{ ClearList - clears list of TObject }\r\nprocedure ClearList(List: TList);\r\n\r\nprocedure MemStreamToClipBoard(MemStream: TMemoryStream; const Format: Word);\r\nprocedure ClipBoardToMemStream(MemStream: TMemoryStream; const Format: Word);\r\n\r\n{ RTTI support }\r\nfunction GetPropType(Obj: TObject; const PropName: string): TTypeKind;\r\nfunction GetPropStr(Obj: TObject; const PropName: string): string;\r\nfunction GetPropOrd(Obj: TObject; const PropName: string): Integer;\r\nfunction GetPropMethod(Obj: TObject; const PropName: string): TMethod;\r\n\r\nprocedure PrepareIniSection(Ss: TStrings);\r\n{ following functions are not documented because\r\n they are don't work properly, so don't use them }\r\n\r\n// (rom) from JvBandWindows to make it obsolete\r\nfunction PointL(const X, Y: Longint): TPointL; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF SUPPORTS_INLINE}\r\n// (rom) from JvBandUtils to make it obsolete\r\nfunction iif(const Test: Boolean; const ATrue, AFalse: Variant): Variant; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF SUPPORTS_INLINE}\r\n\r\n\r\nprocedure CopyIconToClipboard(Icon: TIcon; BackColor: TColor);\r\nfunction CreateIconFromClipboard: TIcon;\r\n{ begin JvIconClipboardUtils }\r\n{ Icon clipboard routines }\r\nfunction CF_ICON: Word;\r\n\r\nprocedure AssignClipboardIcon(Icon: TIcon);\r\n\r\n{ Real-size icons support routines (32-bit only) }\r\nprocedure GetIconSize(Icon: HICON; var W, H: Integer);\r\nfunction CreateRealSizeIcon(Icon: TIcon): HICON;\r\nprocedure DrawRealSizeIcon(Canvas: TCanvas; Icon: TIcon; X, Y: Integer);\r\n{end JvIconClipboardUtils }\r\n\r\nfunction CreateScreenCompatibleDC: HDC;\r\n\r\nfunction InvalidateRect(hWnd: HWND; const lpRect: TRect; bErase: BOOL): BOOL; overload; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\nfunction InvalidateRect(hWnd: HWND; lpRect: PRect; bErase: BOOL): BOOL; overload; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\n\r\n{ begin JvRLE }\r\n\r\n// (rom) changed API for inclusion in JCL\r\n\r\nprocedure RleCompressTo(InStream, OutStream: TStream);\r\nprocedure RleDecompressTo(InStream, OutStream: TStream);\r\nprocedure RleCompress(Stream: TStream);\r\nprocedure RleDecompress(Stream: TStream);\r\n{ end JvRLE }\r\n\r\n{ begin JvDateUtil }\r\nfunction CurrentYear: Word; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF SUPPORTS_INLINE}\r\nfunction IsLeapYear(AYear: Integer): Boolean;\r\nfunction DaysInAMonth(const AYear, AMonth: Word): Word;\r\nfunction DaysPerMonth(AYear, AMonth: Integer): Integer;\r\nfunction FirstDayOfPrevMonth: TDateTime;\r\nfunction LastDayOfPrevMonth: TDateTime;\r\nfunction FirstDayOfNextMonth: TDateTime;\r\nfunction ExtractDay(ADate: TDateTime): Word;\r\nfunction ExtractMonth(ADate: TDateTime): Word;\r\nfunction ExtractYear(ADate: TDateTime): Word;\r\nfunction IncDate(ADate: TDateTime; Days, Months, Years: Integer): TDateTime;\r\nfunction IncDay(ADate: TDateTime; Delta: Integer = 1): TDateTime; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF SUPPORTS_INLINE}\r\nfunction IncMonth(ADate: TDateTime; Delta: Integer = 1): TDateTime;\r\nfunction IncYear(ADate: TDateTime; Delta: Integer = 1): TDateTime;\r\nfunction ValidDate(ADate: TDateTime): Boolean;\r\nprocedure DateDiff(Date1, Date2: TDateTime; var Days, Months, Years: Word);\r\nfunction MonthsBetween(Date1, Date2: TDateTime): Double;\r\nfunction DaysInPeriod(Date1, Date2: TDateTime): Longint;\r\n{ Count days between Date1 and Date2 + 1, so if Date1 = Date2 result = 1 }\r\nfunction DaysBetween(Date1, Date2: TDateTime): Longint;\r\n{ The same as previous but if Date2 < Date1 result = 0 }\r\nfunction IncTime(ATime: TDateTime; Hours, Minutes, Seconds, MSecs: Integer): TDateTime;\r\nfunction IncHour(ATime: TDateTime; Delta: Integer): TDateTime;\r\nfunction IncMinute(ATime: TDateTime; Delta: Integer): TDateTime;\r\nfunction IncSecond(ATime: TDateTime; Delta: Integer): TDateTime;\r\nfunction IncMSec(ATime: TDateTime; Delta: Integer): TDateTime;\r\nfunction CutTime(ADate: TDateTime): TDateTime; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF SUPPORTS_INLINE} { Set time to 00:00:00:00 }\r\n\r\n{ String to date conversions }\r\nfunction GetDateOrder(const DateFormat: string): TDateOrder;\r\nfunction MonthFromName(const S: string; MaxLen: Byte): Byte;\r\nfunction StrToDateDef(const S: string; Default: TDateTime): TDateTime;\r\nfunction StrToDateFmt(const DateFormat, S: string): TDateTime;\r\nfunction StrToDateFmtDef(const DateFormat, S: string; Default: TDateTime): TDateTime;\r\nfunction DefDateFormat(AFourDigitYear: Boolean): string;\r\nfunction DefDateMask(BlanksChar: Char; AFourDigitYear: Boolean): string;\r\n\r\nfunction FormatLongDate(Value: TDateTime): string;\r\nfunction FormatLongDateTime(Value: TDateTime): string;\r\n{ end JvDateUtil }\r\nfunction BufToBinStr(Buf: Pointer; BufSize: Integer): string;\r\nfunction BinStrToBuf(Value: string; Buf: Pointer; BufSize: Integer): Integer;\r\n\r\n\r\n{ begin JvStrUtils }\r\n\r\n { ** Common string handling routines ** }\r\n\r\n{$IFDEF UNIX}\r\nfunction iconversion(InP: PAnsiChar; OutP: Pointer; InBytes, OutBytes: Cardinal;\r\n const ToCode, FromCode: AnsiString): Boolean;\r\nfunction iconvString(const S, ToCode, FromCode: AnsiString): string;\r\nfunction iconvWideString(const S: WideString; const ToCode, FromCode: AnsiString): WideString;\r\nfunction OemStrToAnsi(const S: AnsiString): AnsiString;\r\nfunction AnsiStrToOem(const S: AnsiString): AnsiString;\r\n{$ENDIF UNIX}\r\n\r\nfunction StrToOem(const AnsiStr: AnsiString): AnsiString;\r\n{ StrToOem translates a string from the Windows character set into the\r\n OEM character set. }\r\nfunction OemToAnsiStr(const OemStr: AnsiString): AnsiString;\r\n{ OemToAnsiStr translates a string from the OEM character set into the\r\n Windows character set. }\r\nfunction IsEmptyStr(const S: string; const EmptyChars: TSysCharSet): Boolean;\r\n{ EmptyStr returns True if the given string contains only character\r\n from the EmptyChars. }\r\nfunction ReplaceStr(const S, Srch, Replace: string): string;\r\n{ Returns string with every occurrence of Srch string replaced with\r\n Replace string. }\r\nfunction DelSpace(const S: string): string;\r\n{ DelSpace return a string with all white spaces removed. }\r\nfunction DelChars(const S: string; Chr: Char): string;\r\n{ DelChars return a string with all Chr characters removed. }\r\nfunction DelBSpace(const S: string): string;\r\n{ DelBSpace trims leading spaces from the given string. }\r\nfunction DelESpace(const S: string): string;\r\n{ DelESpace trims trailing spaces from the given string. }\r\nfunction DelRSpace(const S: string): string;\r\n{ DelRSpace trims leading and trailing spaces from the given string. }\r\nfunction DelSpace1(const S: string): string;\r\n{ DelSpace1 return a string with all non-single white spaces removed. }\r\nfunction Tab2Space(const S: string; Numb: Byte): string;\r\n{ Tab2Space converts any tabulation character in the given string to the\r\n Numb spaces characters. }\r\nfunction NPos(const C: string; S: string; N: Integer): Integer;\r\n{ NPos searches for a N-th position of substring C in a given string. }\r\nfunction MakeStr(C: Char; N: Integer): string; overload;\r\n{$IFNDEF COMPILER12_UP}\r\nfunction MakeStr(C: WideChar; N: Integer): WideString; overload;\r\n{$ENDIF !COMPILER12_UP}\r\nfunction MS(C: Char; N: Integer): string; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF SUPPORTS_INLINE}\r\n{ MakeStr return a string of length N filled with character C. }\r\nfunction AddChar(C: Char; const S: string; N: Integer): string;\r\n{ AddChar return a string left-padded to length N with characters C. }\r\nfunction AddCharR(C: Char; const S: string; N: Integer): string;\r\n{ AddCharR return a string right-padded to length N with characters C. }\r\nfunction LeftStr(const S: string; N: Integer): string;\r\n{ LeftStr return a string right-padded to length N with blanks. }\r\nfunction RightStr(const S: string; N: Integer): string;\r\n{ RightStr return a string left-padded to length N with blanks. }\r\nfunction CenterStr(const S: string; Len: Integer): string;\r\n{ CenterStr centers the characters in the string based upon the\r\n Len specified. }\r\nfunction CompStr(const S1, S2: string): Integer; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF SUPPORTS_INLINE}\r\n{ CompStr compares S1 to S2, with case-sensitivity. The return value is\r\n -1 if S1 < S2, 0 if S1 = S2, or 1 if S1 > S2. }\r\nfunction CompText(const S1, S2: string): Integer; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF SUPPORTS_INLINE}\r\n{ CompText compares S1 to S2, without case-sensitivity. The return value\r\n is the same as for CompStr. }\r\nfunction Copy2Symb(const S: string; Symb: Char): string;\r\n{ Copy2Symb returns a substring of a string S from begining to first\r\n character Symb. }\r\nfunction Copy2SymbDel(var S: string; Symb: Char): string;\r\n{ Copy2SymbDel returns a substring of a string S from begining to first\r\n character Symb and removes this substring from S. }\r\nfunction Copy2Space(const S: string): string;\r\n{ Copy2Symb returns a substring of a string S from begining to first\r\n white space. }\r\nfunction Copy2SpaceDel(var S: string): string;\r\n{ Copy2SpaceDel returns a substring of a string S from begining to first\r\n white space and removes this substring from S. }\r\nfunction AnsiProperCase(const S: string; const WordDelims: TSysCharSet): string;\r\n{ Returns string, with the first letter of each word in uppercase,\r\n all other letters in lowercase. Words are delimited by WordDelims. }\r\nfunction WordCount(const S: string; const WordDelims: TSysCharSet): Integer;\r\n{ WordCount given a set of word delimiters, returns number of words in S. }\r\nfunction WordPosition(const N: Integer; const S: string;\r\n const WordDelims: TSysCharSet): Integer;\r\n{ Given a set of word delimiters, returns start position of N'th word in S. }\r\nfunction ExtractWord(N: Integer; const S: string;\r\n const WordDelims: TSysCharSet): string;\r\nfunction ExtractWordPos(N: Integer; const S: string;\r\n const WordDelims: TSysCharSet; var Pos: Integer): string;\r\nfunction ExtractDelimited(N: Integer; const S: string;\r\n const Delims: TSysCharSet): string;\r\n{ ExtractWord, ExtractWordPos and ExtractDelimited given a set of word\r\n delimiters, return the N'th word in S. }\r\nfunction ExtractSubstr(const S: string; var Pos: Integer;\r\n const Delims: TSysCharSet): string;\r\n{ ExtractSubstr given a set of word delimiters, returns the substring from S,\r\n that started from position Pos. }\r\nfunction IsWordPresent(const W, S: string; const WordDelims: TSysCharSet): Boolean;\r\n{ IsWordPresent given a set of word delimiters, returns True if word W is\r\n present in string S. }\r\nfunction QuotedString(const S: string; Quote: Char): string;\r\n{ QuotedString returns the given string as a quoted string, using the\r\n provided Quote character. }\r\nfunction ExtractQuotedString(const S: string; Quote: Char): string;\r\n{ ExtractQuotedString removes the Quote characters from the beginning and\r\n end of a quoted string, and reduces pairs of Quote characters within\r\n the quoted string to a single character. }\r\nfunction FindPart(const HelpWilds, InputStr: string): Integer;\r\n{ FindPart compares a string with '?' and another, returns the position of\r\n HelpWilds in InputStr. }\r\nfunction IsWild(InputStr, Wilds: string; IgnoreCase: Boolean): Boolean;\r\n{ IsWild compares InputString with WildCard string and returns True\r\n if corresponds. }\r\nfunction XorString(const Key, Src: ShortString): ShortString;\r\nfunction XorEncode(const Key, Source: string): string;\r\n {$IFDEF SUPPORTS_DEPRECATED}deprecated{$IFDEF SUPPORTS_DEPRECATED_DETAILS} 'use XorEncodeString that has support for non-ASCII chars'{$ENDIF};{$ENDIF}\r\nfunction XorDecode(const Key, Source: string): string;\r\n {$IFDEF SUPPORTS_DEPRECATED}deprecated{$IFDEF SUPPORTS_DEPRECATED_DETAILS} 'use XorEncodeString that has support for non-ASCII chars'{$ENDIF};{$ENDIF}\r\nfunction XorEncodeString(const Key, Source: string): string;\r\nfunction XorDecodeString(const Key, Source: string): string;\r\n\r\n{ ** Command line routines ** }\r\n\r\nfunction GetCmdLineArg(const Switch: string; ASwitchChars: TSysCharSet): string;\r\n\r\n{ ** Numeric string handling routines ** }\r\n\r\nfunction Numb2USA(const S: string): string;\r\n{ Numb2USA converts numeric string S to USA-format. }\r\nfunction Dec2Hex(N: Longint; A: Byte): string; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF SUPPORTS_INLINE}\r\n{ Dec2Hex converts the given value to a hexadecimal string representation\r\n with the minimum number of digits (A) specified. }\r\nfunction Hex2Dec(const S: string): Longint;\r\n{ Hex2Dec converts the given hexadecimal string to the corresponding integer\r\n value. }\r\nfunction Dec2Numb(N: Int64; A, B: Byte): string;\r\n{ Dec2Numb converts the given value to a string representation with the\r\n base equal to B and with the minimum number of digits (A) specified. }\r\nfunction Numb2Dec(S: string; B: Byte): Int64;\r\n{ Numb2Dec converts the given B-based numeric string to the corresponding\r\n integer value. }\r\nfunction IntToBin(Value: Longint; Digits, Spaces: Integer): string;\r\n{ IntToBin converts the given value to a binary string representation\r\n with the minimum number of digits specified. }\r\nfunction IntToRoman(Value: Longint): string;\r\n{ IntToRoman converts the given value to a roman numeric string\r\n representation. }\r\nfunction RomanToInt(const S: string): Longint;\r\n{ RomanToInt converts the given string to an integer value. If the string\r\n doesn't contain a valid roman numeric value, the 0 value is returned. }\r\n\r\nfunction FindNotBlankCharPos(const S: string): Integer;\r\nfunction FindNotBlankCharPosW(const S: WideString): Integer;\r\nfunction AnsiChangeCase(const S: string): string;\r\nfunction WideChangeCase(const S: string): string;\r\n\r\nfunction StartsText(const SubStr, S: string): Boolean;\r\nfunction EndsText(const SubStr, S: string): Boolean;\r\n\r\nfunction DequotedStr(const S: string; QuoteChar: Char = ''''): string;\r\nfunction AnsiDequotedStr(const S: string; AQuote: Char): string; // follow Delphi 2009's \"Ansi\" prefix\r\n\r\n{end JvStrUtils}\r\n\r\n{$IFDEF UNIX}\r\nfunction GetTempFileName(const Prefix: AnsiString): AnsiString;\r\n{$ENDIF UNIX}\r\n\r\nfunction HasAttr(const FileName: string; Attr: Integer): Boolean;\r\nfunction DeleteFilesEx(const FileMasks: array of string): Boolean;\r\nfunction NormalDir(const DirName: string): string;\r\nfunction RemoveBackSlash(const DirName: string): string; // only for Windows/DOS Paths\r\nfunction ValidFileName(const FileName: string): Boolean;\r\n\r\n{$IFDEF MSWINDOWS}\r\nfunction FileLock(Handle: Integer; Offset, LockSize: Longint): Integer; overload;\r\nfunction FileLock(Handle: Integer; Offset, LockSize: Int64): Integer; overload;\r\nfunction FileUnlock(Handle: Integer; Offset, LockSize: Longint): Integer; overload;\r\nfunction FileUnlock(Handle: Integer; Offset, LockSize: Int64): Integer; overload;\r\n{$ENDIF MSWINDOWS}\r\nfunction GetWindowsDir: string;\r\nfunction GetSystemDir: string;\r\n\r\nfunction ShortToLongFileName(const ShortName: string): string;\r\nfunction LongToShortFileName(const LongName: string): string;\r\nfunction ShortToLongPath(const ShortName: string): string;\r\nfunction LongToShortPath(const LongName: string): string;\r\n{$IFDEF MSWINDOWS}\r\nprocedure CreateFileLink(const FileName, DisplayName: string; Folder: Integer);\r\nprocedure DeleteFileLink(const DisplayName: string; Folder: Integer);\r\n{$ENDIF MSWINDOWS}\r\n\r\n{ end JvFileUtil }\r\n\r\n// Works like PtInRect but includes all edges in comparision\r\nfunction PtInRectInclusive(R: TRect; Pt: TPoint): Boolean;\r\n// Works like PtInRect but excludes all edges from comparision\r\nfunction PtInRectExclusive(R: TRect; Pt: TPoint): Boolean;\r\n\r\nfunction FourDigitYear: Boolean; {$IFDEF SUPPORTS_DEPRECATED} deprecated; {$ENDIF}\r\nfunction IsFourDigitYear: Boolean;\r\n\r\n{ moved from JvJVCLUTils }\r\n\r\n//Open an object with the shell (url or something like that)\r\nfunction OpenObject(const Value: string): Boolean; overload;\r\nfunction OpenObject(Value: PChar): Boolean; overload;\r\n\r\n{$IFDEF MSWINDOWS}\r\n//Raise the last Exception\r\nprocedure RaiseLastWin32; overload;\r\nprocedure RaiseLastWin32(const Text: string); overload;\r\n//Raise the last Exception with a small comment from your part\r\n\r\n{ GetFileVersion returns the most significant 32 bits of a file's binary\r\n version number. Typically, this includes the major and minor version placed\r\n together in one 32-bit Integer. It generally does not include the release\r\n or build numbers. It returns 0 if it failed. }\r\nfunction GetFileVersion(const AFileName: string): Cardinal;\r\n{$EXTERNALSYM GetFileVersion}\r\n\r\n//Get version of Shell.dll\r\nfunction GetShellVersion: Cardinal;\r\n{$EXTERNALSYM GetShellVersion}\r\n\r\n// CD functions\r\nprocedure OpenCdDrive;\r\nprocedure CloseCdDrive;\r\n\r\n// returns True if Drive is accessible\r\nfunction DiskInDrive(Drive: Char): Boolean;\r\n{$ENDIF MSWINDOWS}\r\n\r\n//Same as linux function ;)\r\nprocedure PError(const Text: string);\r\n\r\n// execute a program without waiting\r\nprocedure Exec(const FileName, Parameters, Directory: string);\r\n// execute a program and wait for it to finish\r\nfunction ExecuteAndWait(CommandLine: string; const WorkingDirectory: string; Visibility: Integer = SW_SHOW): Integer;\r\n\r\n\r\n// returns True if this is the first instance of the program that is running\r\nfunction FirstInstance(const ATitle: string): Boolean;\r\n// restores a window based on it's classname and Caption. Either can be left empty\r\n// to widen the search\r\nprocedure RestoreOtherInstance(const MainFormClassName, MainFormCaption: string);\r\n\r\n// manipulate the traybar and start button\r\nprocedure HideTraybar;\r\nprocedure ShowTraybar;\r\nprocedure ShowStartButton(Visible: Boolean = True);\r\n\r\n// (rom) SC_MONITORPOWER is documented as Windows 95 only\r\n// (rom) better do some testing\r\n// set monitor functions\r\nprocedure MonitorOn;\r\nprocedure MonitorOff;\r\nprocedure LowPower;\r\n\r\n// send a key to the window named AppName\r\nfunction SendKey(const AppName: string; Key: Char): Boolean;\r\n\r\n{$IFDEF MSWINDOWS}\r\n\r\n// returns a list of all windows currently visible, the Objects property is filled with their window handle\r\nprocedure GetVisibleWindows(List: TStrings);\r\n// associates an extension to a specific program\r\nprocedure AssociateExtension(const IconPath, ProgramName, Path, Extension: string);\r\n\r\nprocedure AddToRecentDocs(const FileName: string);\r\nfunction GetRecentDocs: TStringList;\r\n{$ENDIF MSWINDOWS}\r\n\r\n// JvComponentFunctions\r\n{-----------------------------------------------------------------------------\r\nComments:\r\n Functions pulled out of MemoEx, used in MemoEx.pas and TypedEdit.pas\r\n\r\n This unit has low internal cohesion (ie it contains routines that do all kinds of stuff)\r\n Some are very good candidates for wider reuse\r\n some are quite specific to the controls\r\n and in a larger library this unit would be broken up\r\n\r\n I have tried to group related functions together\r\n}\r\n\r\nfunction CharIsMoney(const Ch: Char): Boolean;\r\n\r\n{ there is a STrToIntDef provided by Delphi, but no \"safe\" versions of\r\n StrToFloat or StrToCurr }\r\n// Note: before using JvSafeStrToFloatDef, please be aware that it will ignore\r\n// any character that is not a valid character for a float, which is different\r\n// from what StrToFloatDef in Delphi 6 up is doing. This has been documented in Mantis\r\n// issue# 2935: http://issuetracker.delphi-jedi.org/view.php?id=2935\r\n// and in Mantis 4466: http://issuetracker.delphi-jedi.org/view.php?id=4466\r\n\r\nfunction JvSafeStrToFloatDef(const Str: string; Def: Extended; aDecimalSeparator: Char = ' '): Extended; {NOTE: default value of Space is a magic wildcard}\r\n\r\nfunction JvSafeStrToFloat(const Str: string; aDecimalSeparator: Char = ' '): Extended; {NOTE: default value of Space is a magic wildcard}\r\n\r\n\r\nfunction StrToCurrDef(const Str: string; Def: Currency): Currency;\r\nfunction IntToExtended(I: Integer): Extended;\r\n\r\n{ GetChangedText works out the new text given the current cursor pos & the key pressed\r\n It is not very useful in other contexts,\r\n but it is in this unit as it is needed in both MemoEx and TypedEdit }\r\nfunction GetChangedText(const Text: string; SelStart, SelLength: Integer; Key: Char): string;\r\n\r\nfunction MakeYear4Digit(Year, Pivot: Integer): Integer;\r\n\r\nfunction StrIsInteger(const S: string): Boolean;\r\nfunction StrIsFloatMoney(const Ps: string): Boolean;\r\nfunction StrIsDateTime(const Ps: string): Boolean;\r\n\r\nfunction PreformatDateString(Ps: string): string;\r\n\r\nfunction BooleanToInteger(const B: Boolean): Integer;\r\nfunction StringToBoolean(const Ps: string): Boolean;\r\n\r\nfunction SafeStrToDateTime(const Ps: string): TDateTime;\r\nfunction SafeStrToDate(const Ps: string): TDateTime;\r\nfunction SafeStrToTime(const Ps: string): TDateTime;\r\n\r\nfunction StrDelete(const psSub, psMain: string): string;\r\n\r\n { returns the fractional value of pcValue}\r\nfunction TimeOnly(pcValue: TDateTime): TTime;\r\n{ returns the integral value of pcValue }\r\nfunction DateOnly(pcValue: TDateTime): TDate;\r\n\r\ntype\r\n TdtKind = (dtkDateOnly, dtkTimeOnly, dtkDateTime);\r\n\r\nconst\r\n { TDateTime value used to signify Null value}\r\n NullEquivalentDate: TDateTime = 0.0;\r\n\r\nfunction DateIsNull(const pdtValue: TDateTime; const pdtKind: TdtKind): Boolean;\r\n// Replacement for Win32Check to avoid platform specific warnings in D6\r\nfunction OSCheck(RetVal: Boolean): Boolean;\r\n\r\n{ Shortens a fully qualified Path name so that it can be drawn with a specified length limit.\r\n Same as FileCtrl.MinimizeName in functionality (but not implementation). Included here to\r\n not be forced to use FileCtrl unnecessarily }\r\nfunction MinimizeFileName(const FileName: string; Canvas: TCanvas; MaxLen: Integer): string;\r\nfunction MinimizeText(const Text: string; Canvas: TCanvas; MaxWidth: Integer): string;\r\n{ MinimizeString trunactes long string, S, and appends\r\n '...' symbols, if Length of S is more than MaxLen }\r\nfunction MinimizeString(const S: string; const MaxLen: Integer): string;\r\n\r\n{$IFDEF MSWINDOWS}\r\n{ RunDLL32 runs a function in a DLL using the utility rundll32.exe (on NT) or rundll.exe (on Win95/98)\r\n ModuleName is the name of the DLL to load, FuncName is the function to call and CmdLine is\r\n the command-line parameters (if any) to send to the function. Set WaitForCompletion to False to\r\n return immediately after the call.\r\n CmdShow should be one of the SW_SHOWXXXX constants and defaults SW_SHOWDEFAULT\r\n Return value:\r\n if WaitForCompletion is True, returns True if the wait didn't return WAIT_FAILED\r\n if WaitForCompletion is False, returns True if the process could be created\r\n To get information on why RunDLL32 might have failed, call GetLastError\r\n To get more info on what can actually be called using rundll32.exe, take a look at\r\n http://www.dx21.com/SCRIPTING/RUNDLL32/REFGUIDE.ASP?NTI=4&SI=6\r\n}\r\ntype\r\n // the signature of procedures in DLL's that can be called using rundll32.exe\r\n TRunDLL32Proc = procedure(Handle: THandle; HInstance: HMODULE; CmdLine: PChar; CmdShow: Integer); stdcall;\r\n\r\nfunction RunDLL32(const ModuleName, FuncName, CmdLine: string; WaitForCompletion: Boolean; CmdShow: Integer =\r\n SW_SHOWDEFAULT): Boolean;\r\n{ RunDll32Internal does the same as RunDLL32 but does not use the RunDLL32.exe application to do it.\r\n Rather it loads the DLL, gets a pointer to the function in FuncName and calls it with the given parameters.\r\n Because of this behaviour, RunDll32Internal works slightly different from RunDLL32:\r\n * It doesn't return any value indicating success/failure\r\n * There is no WaitForCompletion parameter (but see comment below on how to circumvent this)\r\n * You must pass in a valid windows handle in Wnd. Note that if you pass 0, the call might fail, with no indication of why.\r\n * To simulate WaitForCompletion = False, pass the return value of GetDesktopWindow as the Wnd parameter,\r\n * To simulate WaitForCompletion = True, pass the handle of the calling window (f ex the form you are calling the procedure from)\r\n * If you try to call a function in a DLL that doesn't use the TRunDLL32Proc signature, your program\r\n might crash. Using the RunDLL32 function protects you from any problems with calling the wrong functions\r\n (a dialog is displayed if do something wrong)\r\n * RunDll32Internal is slightly faster but RunDLL32 is safer\r\n}\r\nprocedure RunDll32Internal(Wnd: THandle; const DLLName, FuncName, CmdLine: string; CmdShow: Integer = SW_SHOWDEFAULT);\r\n{ GetDLLVersion loads DLLName, gets a pointer to the DLLVersion function and calls it, returning the major and minor version values\r\nfrom the function. Returns False if the DLL couldn't be loaded or if GetDLLVersion couldn't be found. }\r\nfunction GetDLLVersion(const DLLName: string; var pdwMajor, pdwMinor: Integer): Boolean;\r\n{$ENDIF MSWINDOWS}\r\n\r\nprocedure ResourceNotFound(ResID: PChar);\r\nfunction EmptyRect: TRect;\r\nfunction RectWidth(R: TRect): Integer;\r\nfunction RectHeight(R: TRect): Integer;\r\nfunction CompareRect(const R1, R2: TRect): Boolean;\r\nprocedure RectNormalize(var R: TRect);\r\nfunction RectIsSquare(const R: TRect): Boolean;\r\nfunction RectSquare(var ARect: TRect; AMaxSize: Integer = -1): Boolean;\r\n//If AMaxSize = -1 ,then auto calc Square's max size\r\n\r\n{$IFDEF MSWINDOWS}\r\nprocedure FreeUnusedOle;\r\nfunction GetWindowsVersionString: string;\r\nfunction LoadDLL(const LibName: string): THandle;\r\nfunction RegisterServer(const ModuleName: string): Boolean;\r\nfunction UnregisterServer(const ModuleName: string): Boolean;\r\n{$ENDIF MSWINDOWS}\r\n\r\n{ String routines }\r\nfunction GetEnvVar(const VarName: string): string;\r\nfunction AnsiUpperFirstChar(const S: string): string; // follow Delphi 2009's example with the \"Ansi\" prefix\r\nfunction StringToPChar(var S: string): PChar;\r\nfunction StrPAlloc(const S: string): PChar;\r\nprocedure SplitCommandLine(const CmdLine: string; var ExeName, Params: string);\r\nfunction DropT(const S: string): string;\r\n\r\nfunction WindowClassName(Wnd: THandle): string;\r\n\r\nprocedure SwitchToWindow(Wnd: THandle; Restore: Boolean);\r\nprocedure ActivateWindow(Wnd: THandle);\r\nprocedure ShowWinNoAnimate(Handle: THandle; CmdShow: Integer);\r\nprocedure KillMessage(Wnd: THandle; Msg: Cardinal);\r\n\r\n{ SetWindowTop put window to top without recreating window }\r\nprocedure SetWindowTop(const Handle: THandle; const Top: Boolean);\r\nprocedure CenterWindow(Wnd: THandle);\r\nfunction MakeVariant(const Values: array of Variant): Variant;\r\n\r\n{ Convert dialog units to pixels and backwards }\r\n\r\n{$IFDEF MSWINDOWS}\r\nfunction DialogUnitsToPixelsX(DlgUnits: Word): Word;\r\nfunction DialogUnitsToPixelsY(DlgUnits: Word): Word;\r\nfunction PixelsToDialogUnitsX(PixUnits: Word): Word;\r\nfunction PixelsToDialogUnitsY(PixUnits: Word): Word;\r\n{$ENDIF MSWINDOWS}\r\n\r\nfunction GetUniqueFileNameInDir(const Path, FileNameMask: string): string;\r\n\r\n{$IFDEF BCB}\r\nfunction FindPrevInstance(const MainFormClass: ShortString;\r\n const ATitle: string): THandle;\r\nfunction ActivatePrevInstance(const MainFormClass: ShortString;\r\n const ATitle: string): Boolean;\r\n{$ELSE}\r\nfunction FindPrevInstance(const MainFormClass, ATitle: string): THandle;\r\nfunction ActivatePrevInstance(const MainFormClass, ATitle: string): Boolean;\r\n{$ENDIF BCB}\r\n\r\n\r\n{$IFDEF MSWINDOWS}\r\n{ BrowseForFolderNative displays Browse For Folder dialog }\r\nfunction BrowseForFolderNative(const Handle: THandle; const Title: string; var Folder: string): Boolean;\r\n{$ENDIF MSWINDOWS}\r\n\r\n\r\nprocedure AntiAlias(Clip: TBitmap);\r\nprocedure AntiAliasRect(Clip: TBitmap; XOrigin, YOrigin,\r\n XFinal, YFinal: Integer);\r\n\r\nprocedure CopyRectDIBits(ACanvas: TCanvas; const DestRect: TRect;\r\n ABitmap: TBitmap; const SourceRect: TRect);\r\nfunction IsTrueType(const FontName: string): Boolean;\r\n\r\n\r\n// Removes all non-numeric characters from AValue and returns\r\n// the resulting string\r\nfunction TextToValText(const AValue: string): string;\r\n\r\n\r\n// VisualCLX compatibility functions\r\nfunction DrawText(DC: HDC; const Text: TCaption; Len: Integer; var R: TRect; WinFlags: Integer): Integer; overload;\r\nfunction DrawText(Canvas: TCanvas; const Text: string; Len: Integer; var R: TRect; WinFlags: Integer): Integer; overload;\r\nfunction DrawText(Canvas: TCanvas; Text: PAnsiChar; Len: Integer; var R: TRect; WinFlags: Integer): Integer; overload;\r\nfunction DrawTextEx(Canvas: TCanvas; lpchText: PChar; cchText: Integer; var p4: TRect; dwDTFormat: UINT; DTParams: PDrawTextParams): Integer; overload;\r\nfunction DrawTextEx(Canvas: TCanvas; const Text: string; cchText: Integer; var p4: TRect; dwDTFormat: UINT; DTParams: PDrawTextParams): Integer; overload;\r\nfunction DrawText(Canvas: TCanvas; const Text: WideString; Len: Integer; var R: TRect; WinFlags: Integer): Integer; overload;\r\nfunction DrawTextEx(Canvas: TCanvas; const Text: WideString; cchText: Integer; var p4: TRect; dwDTFormat: UINT; DTParams: PDrawTextParams): Integer; overload;\r\n\r\nfunction DrawTextW(Canvas: TCanvas; const Text: WideString; Len: Integer; var R: TRect; WinFlags: Integer): Integer; overload;\r\nfunction DrawTextW(Canvas: TCanvas; Text: PWideChar; Len: Integer; var R: TRect; WinFlags: Integer): Integer; overload;\r\nfunction DrawTextExW(Canvas: TCanvas; lpchText: PWideChar; cchText: Integer; var p4: TRect; dwDTFormat: UINT; DTParams: PDrawTextParams): Integer; overload;\r\nfunction DrawTextExW(Canvas: TCanvas; const Text: WideString; cchText: Integer; var p4: TRect; dwDTFormat: UINT; DTParams: PDrawTextParams): Integer; overload;\r\n\r\ntype\r\n RasterOp = (\r\n RasterOp_CopyROP,\r\n RasterOp_OrROP,\r\n RasterOp_XorROP,\r\n RasterOp_NotAndROP,\r\n RasterOp_EraseROP = 3,\r\n RasterOp_NotCopyROP,\r\n RasterOp_NotOrROP,\r\n RasterOp_NotXorROP,\r\n RasterOp_AndROP,\r\n RasterOp_NotEraseROP = 7,\r\n RasterOp_NotROP,\r\n RasterOp_ClearROP,\r\n RasterOp_SetROP,\r\n RasterOp_NopROP,\r\n RasterOp_AndNotROP,\r\n RasterOp_OrNotROP,\r\n RasterOp_NandROP,\r\n RasterOp_NorROP,\r\n RasterOp_LastROP = 15);\r\n\r\nfunction BitBlt(DestCanvas: TCanvas; X, Y, Width, Height: Integer; SrcCanvas: TCanvas;\r\n XSrc, YSrc: Integer; WinRop: Cardinal; IgnoreMask: Boolean = True): LongBool;overload;\r\nfunction BitBlt(DestDC: HDC; X, Y, Width, Height: Integer; SrcDC: HDC;\r\n XSrc, YSrc: Integer; Rop: RasterOp; IgnoreMask: Boolean): LongBool; overload;\r\nfunction BitBlt(DestDC: HDC; X, Y, Width, Height: Integer; SrcDC: HDC;\r\n XSrc, YSrc: Integer; WinRop: Cardinal; IgnoreMask: Boolean): LongBool; overload;\r\nfunction BitBlt(DestDC: HDC; X, Y, Width, Height: Integer; SrcDC: HDC;\r\n XSrc, YSrc: Integer; WinRop: Cardinal): LongBool; overload;\r\n\r\n\r\n\r\nfunction IsEqualGUID(const IID1, IID2: TGUID): Boolean;\r\n{$EXTERNALSYM IsEqualGUID}\r\n\r\n\r\n// Containers\r\ntype\r\n TIntegerListChange = procedure(Sender: TObject; Item: Integer; Action: TListNotification) of object;\r\n\r\n TIntegerList = class(TList)\r\n private\r\n FOnChange: TIntegerListChange;\r\n FLoading: Boolean;\r\n\r\n function GetItem(Index: Integer): Integer;\r\n procedure SetItem(Index: Integer; const Value: Integer);\r\n protected\r\n procedure Notify(Ptr: Pointer; Action: TListNotification); override;\r\n procedure DoChange(Item: Integer; Action: TListNotification);\r\n public\r\n // To be used with DefineProperties in client classes.\r\n procedure ReadData(Reader: TReader);\r\n procedure WriteData(Writer: TWriter);\r\n property Loading: Boolean read FLoading;\r\n\r\n // Overloaded to accept/return Integer instead of Pointer.\r\n function Add(Value: Integer): Integer;\r\n function Extract(Item: Integer): Integer;\r\n function First: Integer;\r\n function IndexOf(Item: Integer): Integer;\r\n procedure Insert(Index: Integer; Item: Integer);\r\n function Last: Integer;\r\n function Remove(Item: Integer): Integer;\r\n property Items[Index: Integer]: Integer read GetItem write SetItem; default;\r\n\r\n property OnChange: TIntegerListChange read FOnChange write FOnChange;\r\n end;\r\n\r\ntype\r\n TCollectionSortProc = function(Item1, Item2: TCollectionItem): Integer;\r\n\r\nprocedure CollectionSort(Collection: Classes.TCollection; SortProc: TCollectionSortProc);\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvJCLUtils.pas $';\r\n Revision: '$Revision: 13415 $';\r\n Date: '$Date: 2012-09-10 11:51:54 +0200 (lun. 10 sept. 2012) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n RTLConsts, SysConst,\r\n {$IFDEF MSWINDOWS}\r\n ComObj, ShellAPI, MMSystem, Registry,\r\n {$ENDIF MSWINDOWS}\r\n {$IFDEF HAS_UNIT_CHARACTER}\r\n Character, // needed for JclStrings inlined functions\r\n {$ENDIF HAS_UNIT_CHARACTER}\r\n Consts,\r\n JclStrings, JclSysInfo, JclFileUtils,\r\n Math, JclSysUtils;\r\n\r\nconst\r\n Separators: TSysCharSet = [#00, ' ', '-', #13, #10, '.', ',', '/', '\\', '#', '\"', '''',\r\n ':', '+', '%', '*', '(', ')', ';', '=', '{', '}', '[', ']', '{', '}', '<', '>'];\r\n {$IFDEF MSWINDOWS}\r\n RC_OpenCDDrive = 'set cdaudio door open wait';\r\n RC_CloseCDDrive = 'set cdaudio door closed wait';\r\n RC_ShellName = 'Shell_TrayWnd';\r\n RC_DefaultIcon = 'DefaultIcon';\r\n {$ENDIF MSWINDOWS}\r\n tkStrings: set of TTypeKind = [tkString, tkLString, {$IFDEF UNICODE} tkUString, {$ENDIF} tkWString];\r\n\r\nresourcestring\r\n // (p3) duplicated from JvConsts since this unit should not rely on JVCL at all\r\n RsEPropertyNotExists = 'Property \"%s\" does not exist';\r\n RsEInvalidPropertyType = 'Property \"%s\" has invalid type';\r\n RsEPivotLessThanZero = 'JvJCLUtils.MakeYear4Digit: Pivot < 0';\r\n\r\n{$IFNDEF COMPILER12_UP} // Delphi 2009 introduced it and fixed the NativeInt of Delphi 2007\r\nfunction GetWindowLongPtr(hWnd: HWND; nIndex: Integer): LONG_PTR; stdcall;\r\nasm\r\n pop ebp\r\n jmp GetWindowLong\r\nend;\r\n\r\nfunction SetWindowLongPtr(hWnd: HWND; nIndex: Integer; dwNewLong: LONG_PTR): LONG_PTR; stdcall;\r\nasm\r\n pop ebp\r\n jmp SetWindowLong\r\nend;\r\n{$ENDIF ~COMPILER12_UP}\r\n\r\nfunction SendRectMessage(Handle: THandle; Msg: Integer; wParam: WPARAM; var R: TRect): Integer;\r\nbegin\r\n Result := SendMessage(Handle, Msg, wParam, LPARAM(@R));\r\nend;\r\n\r\nfunction SendStructMessage(Handle: THandle; Msg: Integer; wParam: WPARAM; var Data): Integer;\r\nbegin\r\n Result := SendMessage(Handle, Msg, wParam, LPARAM(@Data));\r\nend;\r\n\r\n\r\nfunction ReadCharsFromStream(Stream: TStream; var Buf: array of AnsiChar; BufSize: Integer): Integer;\r\nbegin\r\n Result := Stream.Read(Buf[0], BufSize);\r\nend;\r\n\r\nfunction WriteStringToStream(Stream: TStream; const Buf: AnsiString; BufSize: Integer): Integer;\r\nbegin\r\n Result := Stream.Write(Buf[1], BufSize);\r\nend;\r\n\r\n{$IFNDEF COMPILER12_UP}\r\nfunction UTF8ToString(const S: UTF8String): string;\r\nbegin\r\n Result := UTF8Decode(S);\r\nend;\r\n{$ENDIF ~COMPILER12_UP}\r\n\r\n// DEPRECATED:\r\n// StrToFloatUS uses US '.' as decimal separator and ',' as thousand separator\r\n// [the right way to do this would have been to set up a TFormatSettings record]\r\n(*\r\nfunction USToLocalFloatStr(const Text: string): string;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := Text;\r\n if (DecimalSeparator <> '.') or (ThousandSeparator <> ',') then\r\n begin\r\n for I := 0 to Length(Result) do\r\n case Result[I] of\r\n '.':\r\n Result[I] := DecimalSeparator;\r\n ',':\r\n Result[I] := ThousandSeparator;\r\n end;\r\n end;\r\nend;*)\r\n\r\n\r\n// DEPRECATED:\r\n(*\r\nfunction StrToFloatUS(const Text: string): Extended;\r\nbegin\r\n try\r\n Result := StrToFloat(USToLocalFloatStr(Text));\r\n except\r\n Result := StrToFloat(Text); // try it with local settings\r\n end;\r\nend;\r\n*)\r\n\r\n// DEPRECATED:\r\n(*\r\nfunction StrToFloatUSDef(const Text: string; Default: Extended): Extended;\r\nbegin\r\n Result := JvSafeStrToFloatDef(USToLocalFloatStr(Text), Default);\r\nend;\r\n*)\r\n\r\nfunction VarIsInt(Value: Variant): Boolean;\r\nbegin\r\n Result := VarType(Value) in [varByte,\r\n varShortInt, varWord, varLongWord, {varInt64,}\r\n varSmallint, varInteger];\r\nend;\r\n\r\nfunction PosIdx(const SubStr, S: string; Index: Integer = 0): Integer;\r\n // use best register allocation\r\n function Find(Index, EndPos: Integer; StartChar: Char; const S: string): Integer;\r\n begin\r\n for Result := Index to EndPos do\r\n if S[Result] = StartChar then\r\n Exit;\r\n Result := 0;\r\n end;\r\n\r\n // use best register allocation\r\n function FindNext(Index, EndPos: Integer; const S, SubStr: string): Integer;\r\n begin\r\n for Result := Index + 1 to EndPos do\r\n if S[Result] <> SubStr[Result - Index + 1] then\r\n Exit;\r\n Result := 0;\r\n end;\r\n\r\nvar\r\n StartChar: Char;\r\n LenSubStr, LenStr: Integer;\r\n EndPos: Cardinal;\r\nbegin\r\n if Index <= 0 then\r\n Index := 1;\r\n Result := 0;\r\n LenSubStr := Length(SubStr);\r\n LenStr := Length(S);\r\n if (LenSubStr = 0) or (S = '') or (LenSubStr > LenStr - (Index - 1)) then\r\n Exit;\r\n\r\n StartChar := SubStr[1];\r\n EndPos := LenStr - LenSubStr + 1;\r\n if LenSubStr = 1 then\r\n Result := Find(Index, EndPos, StartChar, S)\r\n else\r\n begin\r\n repeat\r\n Result := Find(Index, EndPos, StartChar, S);\r\n if Result = 0 then\r\n Break;\r\n Index := Result;\r\n Result := FindNext(Result, Index + LenSubStr - 1, S, SubStr);\r\n if Result = 0 then\r\n begin\r\n Result := Index;\r\n Exit;\r\n end\r\n else\r\n Inc(Index);\r\n until False;\r\n end;\r\nend;\r\n\r\nfunction PosIdxW(const SubStr, S: WideString; Index: Integer = 0): Integer;\r\n\r\n // use best register allocation\r\n function Find(Index, EndPos: Integer; StartChar: WideChar; const S: WideString): Integer;\r\n begin\r\n for Result := Index to EndPos do\r\n if S[Result] = StartChar then\r\n Exit;\r\n Result := 0;\r\n end;\r\n\r\n // use best register allocation\r\n function FindNext(Index, EndPos: Integer; const S, SubStr: WideString): Integer;\r\n begin\r\n for Result := Index + 1 to EndPos do\r\n if S[Result] <> SubStr[Result - Index + 1] then\r\n Exit;\r\n Result := 0;\r\n end;\r\n\r\nvar\r\n StartChar: WideChar;\r\n LenSubStr, LenStr: Integer;\r\n EndPos: Cardinal;\r\nbegin\r\n if Index <= 0 then\r\n Index := 1;\r\n Result := 0;\r\n LenSubStr := Length(SubStr);\r\n LenStr := Length(S);\r\n if (LenSubStr = 0) or (S = '') or (LenSubStr > LenStr - (Index - 1)) then\r\n Exit;\r\n\r\n StartChar := SubStr[1];\r\n EndPos := LenStr - LenSubStr + 1;\r\n if LenSubStr = 1 then\r\n Result := Find(Index, EndPos, StartChar, S)\r\n else\r\n begin\r\n repeat\r\n Result := Find(Index, EndPos, StartChar, S);\r\n if Result = 0 then\r\n Break;\r\n Index := Result;\r\n Result := FindNext(Result, Index + LenSubStr - 1, S, SubStr);\r\n if Result = 0 then\r\n begin\r\n Result := Index;\r\n Exit;\r\n end\r\n else\r\n Inc(Index);\r\n until False;\r\n end;\r\nend;\r\n\r\nfunction PosLastCharIdx(Ch: Char; const S: string; Index: Integer = 0): Integer;\r\nbegin\r\n if (Index = 0) or (Index > Length(S)) then\r\n Index := Length(S);\r\n for Result := Index downto 1 do\r\n if S[Result] = Ch then\r\n Exit;\r\n Result := 0;\r\nend;\r\n\r\nfunction GetLineByPos(const S: string; const Pos: Integer): Integer;\r\nvar\r\n I: Integer;\r\nbegin\r\n if Length(S) < Pos then\r\n Result := -1\r\n else\r\n begin\r\n I := 1;\r\n Result := 0;\r\n while I <= Pos do\r\n begin\r\n if S[I] = #13 then\r\n Inc(Result);\r\n Inc(I);\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure GetXYByPos(const S: string; const Pos: Integer; var X, Y: Integer);\r\nvar\r\n I, IB: Integer;\r\nbegin\r\n X := -1;\r\n Y := -1;\r\n IB := 0;\r\n if (Length(S) >= Pos) and (Pos >= 0) then\r\n begin\r\n I := 1;\r\n Y := 0;\r\n while I <= Pos do\r\n begin\r\n if S[I] = #10 then\r\n begin\r\n Inc(Y);\r\n IB := I + 1;\r\n end;\r\n Inc(I);\r\n end;\r\n X := Pos - IB;\r\n end;\r\nend;\r\n\r\nprocedure GetXYByPosW(const S: WideString; const Pos: Integer; var X, Y: Integer);\r\nvar\r\n I, IB: Integer;\r\nbegin\r\n X := -1;\r\n Y := -1;\r\n IB := 0;\r\n if (Length(S) >= Pos) and (Pos >= 0) then\r\n begin\r\n I := 1;\r\n Y := 0;\r\n while I <= Pos do\r\n begin\r\n if S[I] = #10 then\r\n begin\r\n Inc(Y);\r\n IB := I + 1;\r\n end;\r\n Inc(I);\r\n end;\r\n X := Pos - IB;\r\n end;\r\nend;\r\n\r\nfunction GetWordOnPos(const S: string; const P: Integer): string;\r\nvar\r\n I, Beg: Integer;\r\nbegin\r\n Result := '';\r\n if (P > Length(S)) or (P < 1) then\r\n Exit;\r\n for I := P downto 1 do\r\n if CharInSet(S[I], Separators) then\r\n Break;\r\n Beg := I + 1;\r\n for I := P to Length(S) do\r\n if CharInSet(S[I], Separators) then\r\n Break;\r\n if I > Beg then\r\n Result := Copy(S, Beg, I - Beg)\r\n else\r\n Result := S[P];\r\nend;\r\n\r\nfunction GetWordOnPosW(const S: WideString; const P: Integer): WideString;\r\nvar\r\n I, Beg: Integer;\r\nbegin\r\n Result := '';\r\n if (P > Length(S)) or (P < 1) then\r\n Exit;\r\n for I := P downto 1 do\r\n if CharInSetW(S[I], Separators) then\r\n Break;\r\n Beg := I + 1;\r\n for I := P to Length(S) do\r\n if CharInSetW(S[I], Separators) then\r\n Break;\r\n if I > Beg then\r\n Result := Copy(S, Beg, I - Beg)\r\n else\r\n Result := S[P];\r\nend;\r\n\r\nfunction GetWordOnPos2(const S: string; P: Integer; var iBeg, iEnd: Integer): string;\r\nbegin\r\n Result := '';\r\n if P < 1 then\r\n Exit;\r\n if CharInSet(S[P], Separators) and ((P < 1) or CharInSet(S[P - 1], Separators)) then\r\n Inc(P);\r\n iBeg := P;\r\n while iBeg >= 1 do\r\n if CharInSet(S[iBeg], Separators) then\r\n Break\r\n else\r\n Dec(iBeg);\r\n Inc(iBeg);\r\n iEnd := P;\r\n while iEnd <= Length(S) do\r\n if CharInSet(S[iEnd], Separators) then\r\n Break\r\n else\r\n Inc(iEnd);\r\n if iEnd > iBeg then\r\n Result := Copy(S, iBeg, iEnd - iBeg)\r\n else\r\n Result := S[P];\r\nend;\r\n\r\nfunction GetWordOnPos2W(const S: WideString; P: Integer; var iBeg, iEnd: Integer): WideString;\r\nbegin\r\n Result := '';\r\n if P < 1 then\r\n Exit;\r\n if CharInSetW(S[P], Separators) and\r\n ((P < 1) or (CharInSetW(S[P - 1], Separators))) then\r\n Inc(P);\r\n iBeg := P;\r\n while iBeg >= 1 do\r\n if CharInSetW(S[iBeg], Separators) then\r\n Break\r\n else\r\n Dec(iBeg);\r\n Inc(iBeg);\r\n iEnd := P;\r\n while iEnd <= Length(S) do\r\n if CharInSetW(S[iEnd], Separators) then\r\n Break\r\n else\r\n Inc(iEnd);\r\n if iEnd > iBeg then\r\n Result := Copy(S, iBeg, iEnd - iBeg)\r\n else\r\n Result := S[P];\r\nend;\r\n\r\nfunction GetWordOnPosEx(const S: string; const P: Integer; var iBeg, iEnd: Integer): string;\r\nbegin\r\n Result := '';\r\n if (P > Length(S)) or (P < 1) then\r\n Exit;\r\n iBeg := P;\r\n if P > 1 then\r\n if CharInSet(S[P], Separators) then\r\n if (P < 1) or ((P - 1 > 0) and CharInSet(S[P - 1], Separators)) then\r\n Inc(iBeg)\r\n else\r\n if not ((P - 1 > 0) and CharInSet(S[P - 1], Separators)) then\r\n Dec(iBeg);\r\n while iBeg >= 1 do\r\n if CharInSet(S[iBeg], Separators) then\r\n Break\r\n else\r\n Dec(iBeg);\r\n Inc(iBeg);\r\n iEnd := P;\r\n while iEnd <= Length(S) do\r\n if CharInSet(S[iEnd], Separators) then\r\n Break\r\n else\r\n Inc(iEnd);\r\n if iEnd > iBeg then\r\n Result := Copy(S, iBeg, iEnd - iBeg)\r\n else\r\n Result := S[P];\r\nend;\r\n\r\nfunction GetWordOnPosExW(const S: WideString; const P: Integer; var iBeg, iEnd: Integer): WideString;\r\nbegin\r\n Result := '';\r\n if (P > Length(S)) or (P < 1) then\r\n Exit;\r\n iBeg := P;\r\n if P > 1 then\r\n if CharInSetW(S[P], Separators) then\r\n if (P < 1) or ((P - 1 > 0) and CharInSetW(S[P - 1], Separators)) then\r\n Inc(iBeg)\r\n else\r\n if not ((P - 1 > 0) and CharInSetW(S[P - 1], Separators)) then\r\n Dec(iBeg);\r\n while iBeg >= 1 do\r\n if CharInSetW(S[iBeg], Separators) then\r\n Break\r\n else\r\n Dec(iBeg);\r\n Inc(iBeg);\r\n iEnd := P;\r\n while iEnd <= Length(S) do\r\n if CharInSetW(S[iEnd], Separators) then\r\n Break\r\n else\r\n Inc(iEnd);\r\n if iEnd > iBeg then\r\n Result := Copy(S, iBeg, iEnd - iBeg)\r\n else\r\n Result := S[P];\r\nend;\r\n\r\nfunction GetNextWordPosEx(const Text: string; StartIndex: Integer;\r\n var iBeg, iEnd: Integer): string;\r\nvar\r\n Len: Integer;\r\nbegin\r\n Len := Length(Text);\r\n Result := '';\r\n if (StartIndex < 1) or (StartIndex > Len) then\r\n Exit;\r\n if CharInSet(Text[StartIndex], Separators) and\r\n ((StartIndex < 1) or CharInSet(Text[StartIndex - 1], Separators)) then\r\n Inc(StartIndex);\r\n iBeg := StartIndex;\r\n while iBeg >= 1 do\r\n if CharInSet(Text[iBeg], Separators) then\r\n Break\r\n else\r\n Dec(iBeg);\r\n Inc(iBeg);\r\n iEnd := StartIndex;\r\n while iEnd <= Len do\r\n if CharInSet(Text[iEnd], Separators) then\r\n Break\r\n else\r\n Inc(iEnd);\r\n Dec(iEnd);\r\n if iEnd >= iBeg then\r\n Result := Copy(Text, iBeg, iEnd - iBeg)\r\n else\r\n Result := Text[StartIndex];\r\n\r\n // go right\r\n iEnd := iBeg;\r\n while (iEnd <= Len) and not CharInSet(Text[iEnd], Separators) do\r\n Inc(iEnd);\r\n if iEnd > Len then\r\n iEnd := Len\r\n else\r\n Dec(iEnd);\r\n Result := Copy(Text, iBeg, iEnd - iBeg + 1);\r\nend;\r\n\r\nfunction GetNextWordPosExW(const Text: WideString; StartIndex: Integer;\r\n var iBeg, iEnd: Integer): WideString;\r\nvar\r\n Len: Integer;\r\nbegin\r\n Len := Length(Text);\r\n Result := '';\r\n if (StartIndex < 1) or (StartIndex > Len) then\r\n Exit;\r\n if CharInSetW(Text[StartIndex], Separators) and\r\n ((StartIndex < 1) or CharInSetW(Text[StartIndex - 1], Separators)) then\r\n Inc(StartIndex);\r\n iBeg := StartIndex;\r\n while iBeg >= 1 do\r\n if CharInSetW(Text[iBeg], Separators) then\r\n Break\r\n else\r\n Dec(iBeg);\r\n Inc(iBeg);\r\n iEnd := StartIndex;\r\n while iEnd <= Len do\r\n if CharInSetW(Text[iEnd], Separators) then\r\n Break\r\n else\r\n Inc(iEnd);\r\n Dec(iEnd);\r\n if iEnd >= iBeg then\r\n Result := Copy(Text, iBeg, iEnd - iBeg)\r\n else\r\n Result := Text[StartIndex];\r\n\r\n // go right\r\n iEnd := iBeg;\r\n while (iEnd <= Len) and not CharInSetW(Text[iEnd], Separators) do\r\n Inc(iEnd);\r\n if iEnd > Len then\r\n iEnd := Len\r\n else\r\n Dec(iEnd);\r\n Result := Copy(Text, iBeg, iEnd - iBeg + 1);\r\nend;\r\n\r\nprocedure GetEndPosCaret(const Text: string; CaretX, CaretY: Integer;\r\n var X, Y: Integer);\r\nbegin\r\n GetXYByPos(Text, Length(Text), X, Y);\r\n if Y = 0 then\r\n Inc(X, CaretX)\r\n else\r\n Inc(X);\r\n Dec(X);\r\n Inc(Y, CaretY);\r\nend;\r\n\r\nprocedure GetEndPosCaretW(const Text: WideString; CaretX, CaretY: Integer;\r\n var X, Y: Integer);\r\nbegin\r\n GetXYByPosW(Text, Length(Text), X, Y);\r\n if Y = 0 then\r\n Inc(X, CaretX)\r\n else\r\n Inc(X);\r\n Dec(X);\r\n Inc(Y, CaretY);\r\nend;\r\n\r\nfunction SubStrBySeparator(const S: string; const Index: Integer; const Separator: string; StartIndex: Integer): string;\r\n{ Returns a substring. Substrings are divided by a separator character }\r\nvar\r\n I, LenS, LenSeparator: Integer;\r\nbegin\r\n Result := '';\r\n LenSeparator := Length(Separator);\r\n LenS := Length(S);\r\n\r\n if StartIndex <= 0 then\r\n StartIndex := 1;\r\n if (LenS = 0) or (LenSeparator = 0) or (StartIndex > LenS) or\r\n ((Index < 0) or ((Index = 0) and (LenS > 0) and (S[StartIndex] = Separator[1]))) then\r\n Exit;\r\n\r\n for I := 1 to Index do\r\n begin\r\n StartIndex := PosIdx(Separator, S, StartIndex);\r\n if StartIndex = 0 then\r\n Exit;\r\n Inc(StartIndex, LenSeparator);\r\n if StartIndex > LenS then\r\n Exit;\r\n end;\r\n I := PosIdx(Separator, S, StartIndex);\r\n if I = 0 then\r\n I := LenS + 1;\r\n Result := Copy(S, StartIndex, I - StartIndex);\r\n //if CompareText(Result, Separator) = 0 then\r\n // Result := '';\r\nend;\r\n\r\nfunction SubStrBySeparatorW(const S: WideString; const Index: Integer; const Separator: WideString; StartIndex: Integer): WideString;\r\n{ Returns a substring. Substrings are divided by a separator character }\r\nvar\r\n I, LenS, LenSeparator: Integer;\r\nbegin\r\n Result := '';\r\n LenSeparator := Length(Separator);\r\n LenS := Length(S);\r\n\r\n if StartIndex <= 0 then\r\n StartIndex := 1;\r\n if (LenS = 0) or (LenSeparator = 0) or (StartIndex > LenS) or\r\n ((Index < 0) or ((Index = 0) and (LenS > 0) and (S[StartIndex] = Separator[1]))) then\r\n Exit;\r\n\r\n for I := 1 to Index do\r\n begin\r\n StartIndex := PosIdx(Separator, S, StartIndex);\r\n if StartIndex = 0 then\r\n Exit;\r\n Inc(StartIndex, LenSeparator);\r\n if StartIndex > LenS then\r\n Exit;\r\n end;\r\n I := PosIdx(Separator, S, StartIndex);\r\n if I = 0 then\r\n I := LenS + 1;\r\n Result := Copy(S, StartIndex, I - StartIndex);\r\n //if WideCompareText(Result, Separator) = 0 then\r\n // Result := '';\r\nend;\r\n\r\nfunction SubWord(P: PChar; var P2: PChar): string;\r\nvar\r\n I: Integer;\r\nbegin\r\n I := 0;\r\n while not CharInSet(P[I], Separators) do\r\n Inc(I);\r\n SetString(Result, P, I);\r\n P2 := P + I;\r\nend;\r\n\r\nfunction ReplaceString(S: string; const OldPattern, NewPattern: string; StartIndex: Integer): string;\r\nvar\r\n I, LenOldPattern: Integer;\r\nbegin\r\n if OldPattern <> '' then\r\n begin\r\n if StartIndex <= 0 then\r\n StartIndex := 1;\r\n LenOldPattern := Length(OldPattern);\r\n I := PosIdx(OldPattern, S, StartIndex);\r\n while I > 0 do\r\n begin\r\n StartIndex := I + LenOldPattern;\r\n S := Copy(S, 1, I - 1) + NewPattern + Copy(S, StartIndex, MaxInt);\r\n I := PosIdx(OldPattern, S, StartIndex);\r\n end;\r\n end;\r\n Result := S;\r\nend;\r\n\r\nfunction ReplaceStringW(S: WideString; const OldPattern, NewPattern: WideString; StartIndex: Integer): WideString;\r\nvar\r\n I, LenOldPattern: Integer;\r\nbegin\r\n if OldPattern <> '' then\r\n begin\r\n if StartIndex <= 0 then\r\n StartIndex := 1;\r\n LenOldPattern := Length(OldPattern);\r\n I := PosIdxW(OldPattern, S, StartIndex);\r\n while I > 0 do\r\n begin\r\n StartIndex := I + LenOldPattern;\r\n S := Copy(S, 1, I - 1) + NewPattern + Copy(S, StartIndex, MaxInt);\r\n I := PosIdxW(OldPattern, S, StartIndex);\r\n end;\r\n end;\r\n Result := S;\r\nend;\r\n\r\nfunction ConcatSep(const S1, S2, Separator: string): string;\r\nbegin\r\n Result := S1;\r\n if Result <> '' then\r\n Result := Result + Separator;\r\n Result := Result + S2;\r\nend;\r\n\r\nfunction ConcatLeftSep(const S1, S2, Separator: string): string;\r\nbegin\r\n Result := S1;\r\n if Result <> '' then\r\n Result := Separator + Result;\r\n Result := S2 + Result;\r\nend;\r\n\r\nfunction MinimizeString(const S: string; const MaxLen: Integer): string;\r\nbegin\r\n if Length(S) > MaxLen then\r\n if MaxLen < 3 then\r\n Result := Copy(S, 1, MaxLen)\r\n else\r\n Result := Copy(S, 1, MaxLen - 3) + '...'\r\n else\r\n Result := S;\r\nend;\r\n\r\nfunction TrueInflateRect(const R: TRect; const I: Integer): TRect;\r\nbegin\r\n SetRect(Result, R.Left - I, R.Top - I, R.Right + I, R.Bottom + I);\r\nend;\r\n\r\nfunction FileGetInfo(FileName: TFileName; var SearchRec: TSearchRec): Boolean;\r\nvar\r\n DosError: Integer;\r\n Path: TFileName;\r\nbegin\r\n Result := False;\r\n Path := ExtractFilePath(ExpandFileName(FileName)) + AllFilesMask;\r\n {$IFDEF MSWINDOWS}\r\n FileName := AnsiUpperCase(ExtractFileName(FileName));\r\n {$ENDIF MSWINDOWS}\r\n {$IFDEF UNIX}\r\n FileName := ExtractFileName(FileName);\r\n {$ENDIF UNIX}\r\n DosError := FindFirst(Path, faAnyFile, SearchRec);\r\n while DosError = 0 do\r\n begin\r\n {$IFDEF MSWINDOWS}\r\n if SameFileName(SearchRec.FindData.cFileName, FileName) or\r\n SameFileName(SearchRec.FindData.cAlternateFileName, FileName) then\r\n {$ENDIF MSWINDOWS}\r\n {$IFDEF UNIX}\r\n if AnsiSameStr(SearchRec.Name, FileName) then\r\n {$ENDIF UNIX}\r\n begin\r\n Result := True;\r\n Break;\r\n end;\r\n DosError := FindNext(SearchRec);\r\n end;\r\n FindClose(SearchRec);\r\nend;\r\n\r\nfunction HasSubFolder(APath: TFileName): Boolean;\r\nvar\r\n SearchRec: TSearchRec;\r\n DosError: Integer;\r\nbegin\r\n Result := False;\r\n APath := Concat(AddSlash(APath), AllFilesMask);\r\n DosError := FindFirst(APath, faDirectory, SearchRec);\r\n while DosError = 0 do\r\n begin\r\n if (SearchRec.Attr and faDirectory = faDirectory) and\r\n (SearchRec.Name <> '.') and (SearchRec.Name <> '..') then\r\n begin\r\n Result := True;\r\n Break;\r\n end;\r\n DosError := FindNext(SearchRec);\r\n end;\r\n FindClose(SearchRec);\r\nend;\r\n\r\nfunction IsEmptyFolder(APath: TFileName): Boolean;\r\nvar\r\n SearchRec: TSearchRec;\r\n DosError: Integer;\r\nbegin\r\n Result := True;\r\n APath := Concat(AddSlash(APath), AllFilesMask);\r\n DosError := FindFirst(APath, faDirectory, SearchRec);\r\n while DosError = 0 do\r\n begin\r\n if (SearchRec.Name <> '.') and (SearchRec.Name <> '..') then\r\n begin\r\n Result := False;\r\n Break;\r\n end;\r\n DosError := FindNext(SearchRec);\r\n end;\r\n FindClose(SearchRec);\r\nend;\r\n\r\n{$IFDEF MSWINDOWS}\r\nfunction LZFileExpand(const FileSource, FileDest: string): Boolean;\r\ntype\r\n TLZCopy = function(Source, Dest: Integer): Longint; stdcall;\r\n TLZOpenFile = function(FileName: PChar; var ReOpenBuff: TOFStruct; Style: Word): Integer; stdcall;\r\n TLZClose = procedure(hFile: Integer); stdcall;\r\nvar\r\n Source, Dest: Integer;\r\n OSSource, OSDest: TOFStruct;\r\n Res: Integer;\r\n Inst: THandle;\r\n LZCopy: TLZCopy;\r\n LZOpenFile: TLZOpenFile;\r\n LZClose: TLZClose;\r\nbegin\r\n Result := False;\r\n Inst := SafeLoadLibrary('LZ32.dll');\r\n try\r\n if Inst = 0 then\r\n RaiseLastOSError;\r\n LZCopy := GetProcAddress(Inst, 'LZCopy');\r\n {$IFDEF SUPPORTS_UNICODE}\r\n LZOpenFile := GetProcAddress(Inst, 'LZOpenFileW');\r\n {$ELSE}\r\n LZOpenFile := GetProcAddress(Inst, 'LZOpenFileA');\r\n {$ENDIF SUPPORTS_UNICODE}\r\n LZClose := GetProcAddress(Inst, 'LZClose');\r\n if not Assigned(LZCopy) or not Assigned(LZOpenFile) or not Assigned(LZClose) then\r\n begin\r\n SetLastError(ERROR_NOT_SUPPORTED);\r\n RaiseLastOSError;\r\n end;\r\n OSSource.cBytes := SizeOf(TOFStruct);\r\n OSDest.cBytes := SizeOf(TOFStruct);\r\n Source := LZOpenFile(\r\n PChar(FileSource), // address of name of file to be opened\r\n OSSource, // address of open file structure\r\n OF_READ or OF_SHARE_DENY_NONE); // action to take\r\n if Source < 0 then\r\n begin\r\n DeleteFile(FileDest);\r\n Dest := LZOpenFile(\r\n PChar(FileDest), // address of name of file to be opened\r\n OSDest, // address of open file structure\r\n OF_CREATE or OF_WRITE or OF_SHARE_EXCLUSIVE); // action to take\r\n if Dest >= 0 then\r\n begin\r\n Res := LZCopy(Source, Dest);\r\n if Res >= 0 then\r\n Result := True;\r\n end;\r\n LZClose(Source);\r\n LZClose(Dest);\r\n end;\r\n finally\r\n FreeLibrary(Inst);\r\n end;\r\nend;\r\n{$ENDIF MSWINDOWS}\r\n\r\nprocedure Dos2Win(var S: AnsiString);\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := 1 to Length(S) do\r\n case S[I] of\r\n #$80..#$AF:\r\n S[I] := AnsiChar(Byte(S[I]) + (192 - $80));\r\n #$E0..#$EF:\r\n S[I] := AnsiChar(Byte(S[I]) + (240 - $E0));\r\n end;\r\nend;\r\n\r\nprocedure Win2Dos(var S: AnsiString);\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := 1 to Length(S) do\r\n case S[I] of\r\n #$C0..#$EF:\r\n S[I] := AnsiChar(Byte(S[I]) - (192 - $80));\r\n #$F0..#$FF:\r\n S[I] := AnsiChar(Byte(S[I]) - (240 - $E0));\r\n end;\r\nend;\r\n\r\nfunction Dos2WinRes(const S: AnsiString): AnsiString;\r\nbegin\r\n Result := S;\r\n Dos2Win(Result);\r\nend;\r\n\r\nfunction Win2DosRes(const S: AnsiString): AnsiString;\r\nbegin\r\n Result := S;\r\n Win2Dos(Result);\r\nend;\r\n\r\nfunction Win2Koi(const S: AnsiString): AnsiString;\r\nconst\r\n W: AnsiString = '=+--+-+++---+i+_+';\r\n K: AnsiString = '---+++---+i+++_+=';\r\nvar\r\n I, J: Integer;\r\nbegin\r\n Result := S;\r\n for I := 1 to Length(Result) do\r\n begin\r\n J := Pos(Result[I], W);\r\n if J > 0 then\r\n Result[I] := K[J];\r\n end;\r\nend;\r\n\r\nprocedure FillString(var Buffer: string; Count: Integer; const Value: Char);\r\nbegin\r\n {$IFDEF COMPILER12_UP}\r\n Buffer := StringOfChar(Value, Count);\r\n {$ELSE}\r\n FillChar(Buffer[1], Count * SizeOf(Char), Value);\r\n {$ENDIF COMPILER12_UP}\r\nend;\r\n\r\nprocedure FillString(var Buffer: string; StartIndex, Count: Integer; const Value: Char);\r\nbegin\r\n if StartIndex <= 0 then\r\n StartIndex := 1;\r\n {$IFDEF COMPILER12_UP}\r\n Buffer := Copy(Buffer, 1, StartIndex - 1) + StringOfChar(Value, Count);\r\n {$ELSE}\r\n FillChar(Buffer[StartIndex], Count * SizeOf(Char), Value);\r\n {$ENDIF COMPILER12_UP}\r\nend;\r\n\r\nprocedure MoveString(const Source: string; var Dest: string; Count: Integer);\r\nbegin\r\n Move(Source[1], Dest[1], Count * SizeOf(Char));\r\nend;\r\n\r\nprocedure MoveString(const Source: string; SrcStartIdx: Integer; var Dest: string;\r\n DstStartIdx: Integer; Count: Integer);\r\nbegin\r\n if DstStartIdx <= 0 then\r\n DstStartIdx := 1;\r\n if SrcStartIdx <= 0 then\r\n SrcStartIdx := 1;\r\n\r\n Move(Source[SrcStartIdx], Dest[DstStartIdx], Count * SizeOf(Char));\r\nend;\r\n\r\nprocedure FillWideChar(var Buffer; Count: Integer; const Value: WideChar);\r\nvar\r\n P: PLongint;\r\n Value2: Cardinal;\r\n CopyWord: Boolean;\r\nbegin\r\n Value2 := (Cardinal(Value) shl 16) or Cardinal(Value);\r\n CopyWord := Count and $1 <> 0;\r\n Count := Count div 2;\r\n P := @Buffer;\r\n while Count > 0 do\r\n begin\r\n P^ := Value2;\r\n Inc(P);\r\n Dec(Count);\r\n end;\r\n if CopyWord then\r\n PWideChar(P)^ := Value;\r\nend;\r\n\r\nprocedure MoveWideChar(const Source; var Dest; Count: Integer);\r\nbegin\r\n Move(Source, Dest, Count * SizeOf(WideChar));\r\nend;\r\n\r\nprocedure FillNativeChar(var Buffer; Count: Integer; const Value: Char);\r\nbegin\r\n {$IFDEF COMPILER12_UP}\r\n FillWideChar(Buffer, Count, Value);\r\n {$ELSE}\r\n FillChar(Buffer, Count, Value);\r\n {$ENDIF COMPILER12_UP}\r\nend;\r\n\r\nprocedure MoveNativeChar(const Source; var Dest; Count: Integer);\r\nbegin\r\n {$IFDEF COMPILER12_UP}\r\n MoveWideChar(Source, Dest, Count);\r\n {$ELSE}\r\n Move(Source, Dest, Count);\r\n {$ENDIF COMPILER12_UP}\r\nend;\r\n\r\nfunction IsSubString(const S: string; StartIndex: Integer; const SubStr: string): Boolean;\r\nbegin\r\n if StartIndex < 1 then\r\n StartIndex := 1;\r\n if StartIndex > Length(S) then\r\n StartIndex := Length(S);\r\n Result := StrLComp(PChar(S) + StartIndex - 1, PChar(SubStr), Length(SubStr)) = 0;\r\nend;\r\n\r\nfunction Spaces(const N: Integer): string;\r\nbegin\r\n if N > 0 then\r\n begin\r\n SetLength(Result, N);\r\n FillString(Result, N, ' ');\r\n end\r\n else\r\n Result := '';\r\nend;\r\n\r\nfunction AddSpaces(const S: string; const N: Integer): string;\r\nvar\r\n Len: Integer;\r\nbegin\r\n Len := Length(S);\r\n if (Len < N) and (N > 0) then\r\n begin\r\n SetLength(Result, N);\r\n MoveString(S, Result, Len);\r\n FillString(Result, Len + 1, N - Len, ' ');\r\n end\r\n else\r\n Result := S;\r\nend;\r\n\r\nfunction SpacesW(const N: Integer): WideString;\r\nbegin\r\n if N > 0 then\r\n begin\r\n SetLength(Result, N);\r\n FillWideChar(Result[1], N, ' ');\r\n end\r\n else\r\n Result := '';\r\nend;\r\n\r\nfunction AddSpacesW(const S: WideString; const N: Integer): WideString;\r\nvar\r\n Len: Integer;\r\nbegin\r\n Len := Length(S);\r\n if (Len < N) and (N > 0) then\r\n begin\r\n SetLength(Result, N);\r\n MoveWideChar(S[1], Result[1], Len);\r\n FillWideChar(Result[Len + 1], N - Len, ' ');\r\n end\r\n else\r\n Result := S;\r\nend;\r\n\r\n{ (rb) maybe construct an english variant? }\r\n\r\nfunction LastDateRUS(const Dat: TDateTime): string;\r\nconst\r\n D2D: array [0..9] of Byte =\r\n (3, 1, 2, 2, 2, 3, 3, 3, 3, 3);\r\n Day: array [1..3] of string =\r\n ('', '', ''); // Day, Days, Days\r\n Month: array [1..3] of string =\r\n ('', '', ''); // Month, Months, Months\r\n Year: array [1..3] of string =\r\n ('', '', '='); // Year, Years, Years\r\n Week: array [1..4] of string =\r\n ('', '2 ', '3 ', ''); // Week, 2 Weeks, 3 Weeks, Month\r\nvar\r\n Y, M, D: Integer;\r\nbegin\r\n if Date = Dat then\r\n Result := '' // Today\r\n else\r\n if Dat = Date - 1 then\r\n Result := '' // Yesterday\r\n else\r\n if Dat = Date - 2 then\r\n Result := '' // Day before yesterday\r\n else\r\n if Dat > Date then\r\n Result := ' ' // In the future\r\n else\r\n begin\r\n D := Trunc(Date - Dat);\r\n Y := Round(D / 365);\r\n M := Round(D / 30);\r\n if Y > 0 then\r\n Result := IntToStr(Y) + ' ' + Year[D2D[StrToInt(IntToStr(Y)[Length(IntToStr(Y))])]] + ' ' // ago\r\n else\r\n if M > 0 then\r\n Result := IntToStr(M) + ' ' + Month[D2D[StrToInt(IntToStr(M)[Length(IntToStr(M))])]] + ' ' // ago\r\n else\r\n if D > 6 then\r\n Result := Week[D div 7] + ' ' // ago\r\n else\r\n if D > 0 then\r\n Result := IntToStr(D) + ' ' + Day[D2D[StrToInt(IntToStr(D)[Length(IntToStr(D))])]] + ' ' // ago\r\n end;\r\nend;\r\n\r\nfunction AddSlash(const Dir: TFileName): string;\r\nbegin\r\n Result := Dir;\r\n if (Length(Dir) > 0) and (Dir[Length(Dir)] <> PathDelim) then\r\n Result := Dir + PathDelim;\r\nend;\r\n\r\nfunction AddPath(const FileName, Path: TFileName): TFileName;\r\nbegin\r\n if ExtractFileDrive(FileName) = '' then\r\n Result := AddSlash(Path) + FileName\r\n else\r\n Result := FileName;\r\nend;\r\n\r\nfunction AddPaths(const PathList, Path: string): string;\r\nvar\r\n I: Integer;\r\n S: string;\r\nbegin\r\n Result := '';\r\n I := 0;\r\n S := SubStrBySeparator(PathList, I, PathSep);\r\n while S <> '' do\r\n begin\r\n Result := ConcatSep(Result, AddPath(S, Path), PathSep);\r\n Inc(I);\r\n S := SubStrBySeparator(PathList, I, PathSep);\r\n end;\r\nend;\r\n\r\nfunction ParentPath(const Path: TFileName): TFileName;\r\nbegin\r\n Result := Path;\r\n if (Length(Result) > 0) and (Result[Length(Result)] = PathDelim) then\r\n Delete(Result, Length(Result), 1);\r\n Result := ExtractFilePath(Result);\r\nend;\r\n\r\nfunction FindInPath(const FileName, PathList: string): TFileName;\r\nvar\r\n I: Integer;\r\n S: string;\r\nbegin\r\n I := 0;\r\n S := SubStrBySeparator(PathList, I, PathSep);\r\n while S <> '' do\r\n begin\r\n Result := AddSlash(S) + FileName;\r\n if FileExists(Result) then\r\n Exit;\r\n Inc(I);\r\n S := SubStrBySeparator(PathList, I, PathSep);\r\n end;\r\n Result := '';\r\nend;\r\n\r\n{$IFDEF MSWINDOWS}\r\nfunction GetComputerID: string;\r\nvar\r\n SN: DWORD;\r\n Nul: DWORD;\r\n WinDir: array [0..MAX_PATH] of Char;\r\nbegin\r\n GetWindowsDirectory(WinDir, MAX_PATH);\r\n WinDir[3] := #0;\r\n if GetVolumeInformation(\r\n WinDir, // address of root directory of the file system\r\n nil, // address of name of the volume\r\n 0, // Length of lpVolumeNameBuffer\r\n @SN, // address of volume serial number\r\n Nul, // address of system's maximum filename Length\r\n Nul, // address of file system flags\r\n nil, // address of name of file system\r\n 0) {// Length of lpFileSystemNameBuffer} then\r\n Result := IntToHex(SN, 8)\r\n else\r\n Result := 'None';\r\nend;\r\n{$ENDIF MSWINDOWS}\r\n{$IFDEF UNIX}\r\nfunction GetComputerID: string;\r\nbegin\r\n Result := 'None';\r\nend;\r\n{$ENDIF UNIX}\r\n\r\nfunction GetComputerName: string;\r\nvar\r\n nSize: Cardinal;\r\nbegin\r\n nSize := MAX_COMPUTERNAME_LENGTH + 1;\r\n SetLength(Result, nSize);\r\n if Windows.GetComputerName(PChar(Result), nSize) then\r\n SetLength(Result, nSize)\r\n else\r\n Result := '';\r\nend;\r\n\r\nfunction CurrencyToStr(const Cur: Currency): string;\r\nbegin\r\n Result := CurrToStrF(Cur, ffCurrency, JclFormatSettings.CurrencyDecimals)\r\nend;\r\n\r\nfunction HasChar(const Ch: Char; const S: string): Boolean;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := True;\r\n for I := 1 to Length(S) do\r\n if S[I] = Ch then\r\n Exit;\r\n Result := False;\r\nend;\r\n\r\nfunction HasCharW(const Ch: WideChar; const S: WideString): Boolean;\r\nbegin\r\n Result := Pos(Ch, S) > 0;\r\nend;\r\n\r\nfunction HasAnyChar(const Chars: string; const S: string): Boolean;\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := 1 to Length(Chars) do\r\n if HasChar(Chars[I], S) then\r\n begin\r\n Result := True;\r\n Exit;\r\n end;\r\n Result := False;\r\nend;\r\n\r\nfunction CountOfChar(const Ch: Char; const S: string): Integer;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := 0;\r\n for I := 1 to Length(S) do\r\n if S[I] = Ch then\r\n Inc(Result);\r\nend;\r\n\r\nprocedure SwapInt(var Int1, Int2: Integer);\r\nvar\r\n Tmp: Integer;\r\nbegin\r\n Tmp := Int1;\r\n Int1 := Int2;\r\n Int2 := Tmp;\r\nend;\r\n\r\nfunction DeleteReadOnlyFile(const FileName: TFileName): Boolean;\r\nbegin\r\n {$IFDEF MSWINDOWS}\r\n FileSetAttr(FileName, 0); {clear Read Only Flag}\r\n {$ENDIF MSWINDOWS}\r\n {$IFDEF UNIX}\r\n FileSetReadOnly(FileName, False);\r\n {$ENDIF UNIX}\r\n Result := DeleteFile(FileName);\r\nend;\r\n\r\nfunction HasParam(const Param: string): Boolean;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := False;\r\n for I := 1 to ParamCount do\r\n begin\r\n Result := SameText(ParamStr(I), Param);\r\n if Result then\r\n Exit;\r\n end;\r\nend;\r\n\r\nfunction HasSwitch(const Param: string): Boolean;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := False;\r\n for I := 1 to ParamCount do\r\n if HasChar(ParamStr(I)[1], '-/') then\r\n begin\r\n Result := SameText(Copy(ParamStr(I), 2, Length(Param)), Param);\r\n if Result then\r\n Exit;\r\n end;\r\nend;\r\n\r\nfunction Switch(const Param: string): string;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := '';\r\n for I := 1 to ParamCount do\r\n if HasChar(ParamStr(I)[1], '-/\\') and\r\n SameText(Copy(ParamStr(I), 2, Length(Param)), Param) then\r\n begin\r\n Result := Copy(ParamStr(I), 2 + Length(Param), 260);\r\n Exit;\r\n end;\r\nend;\r\n\r\nfunction ExePath: TFileName;\r\nbegin\r\n Result := ExtractFilePath(ParamStr(0));\r\nend;\r\n\r\nfunction FileNewExt(const FileName, NewExt: TFileName): TFileName;\r\nbegin\r\n Result := Copy(FileName, 1, Length(FileName) - Length(ExtractFileExt(FileName))) + NewExt;\r\nend;\r\n\r\n{$IFNDEF COMPILER12_UP}\r\nfunction ToUpper(C: Char): Char;\r\nvar s : string;\r\nbegin\r\n s := UpperCase(c);\r\n Result := s[1];\r\nend;\r\n{$ENDIF ~COMPILER12_UP}\r\n\r\n{$IFNDEF COMPILER12_UP}\r\nfunction CharInSet(const Ch: AnsiChar; const SetOfChar: TSysCharSet): Boolean;\r\nbegin\r\n Result := Ch in SetOfChar;\r\nend;\r\n{$ENDIF ~COMPILER12_UP}\r\n\r\nfunction CharInSetW(const Ch: WideChar; const SetOfChar: TSysCharSet): Boolean;\r\nbegin\r\n if Word(Ch) > 255 then\r\n Result := False\r\n else\r\n Result := AnsiChar(Ch) in SetOfChar;\r\nend;\r\n\r\nfunction IntPower(Base, Exponent: Integer): Integer;\r\nbegin\r\n if Exponent > 0 then\r\n begin\r\n Result := Base;\r\n Dec(Exponent);\r\n while Exponent > 0 do\r\n begin\r\n Result := Result * Base;\r\n Dec(Exponent);\r\n end;\r\n end\r\n else\r\n if Exponent < 0 then\r\n Result := 0\r\n else\r\n Result := 1;\r\nend;\r\n\r\nfunction KeyPressed(VK: Integer): Boolean;\r\nbegin\r\n Result := Windows.GetKeyState(VK) and $8000 = $8000;\r\nend;\r\n\r\n\r\nfunction Var2Type(V: Variant; const DestVarType: Integer): Variant;\r\nvar\r\n VType: TVarType;\r\nbegin\r\n VType := TVarData(V).VType;\r\n if VType in [varEmpty, varNull] then\r\n begin\r\n case DestVarType of\r\n varOleStr,\r\n varString:\r\n Result := '';\r\n varInteger, varSmallint, varByte:\r\n Result := 0;\r\n varBoolean:\r\n Result := False;\r\n varSingle, varDouble, varCurrency, varDate:\r\n Result := 0.0;\r\n varVariant:\r\n Result := Null;\r\n else\r\n Result := VarAsType(V, DestVarType);\r\n end;\r\n end\r\n else\r\n Result := VarAsType(V, DestVarType);\r\n if (DestVarType = varInteger) and (VType = varBoolean) then\r\n Result := Integer(V = True);\r\nend;\r\n\r\nfunction VarToInt(V: Variant): Integer;\r\nbegin\r\n Result := Var2Type(V, varInteger);\r\nend;\r\n\r\nfunction VarToFloat(V: Variant): Double;\r\nbegin\r\n Result := Var2Type(V, varDouble);\r\nend;\r\n\r\nfunction CopyDir(const SourceDir, DestDir: TFileName): Boolean;\r\nvar\r\n SearchRec: TSearchRec;\r\n DosError: Integer;\r\n Path, DestPath: TFileName;\r\nbegin\r\n Result := False;\r\n if not CreateDir(DestDir) then\r\n Exit;\r\n Path := SourceDir;\r\n DestPath := AddSlash(DestDir);\r\n Path := AddSlash(Path);\r\n DosError := FindFirst(Path + AllFilesMask, faAnyFile, SearchRec);\r\n while DosError = 0 do\r\n begin\r\n if (SearchRec.Name <> '.') and (SearchRec.Name <> '..') then\r\n begin\r\n if (SearchRec.Attr and faDirectory) = faDirectory then\r\n Result := CopyDir(Path + SearchRec.Name, AddSlash(DestDir) + SearchRec.Name)\r\n else\r\n Result := CopyFile(PChar(Path + SearchRec.Name), PChar(DestPath + SearchRec.Name), True);\r\n if not Result then\r\n Exit;\r\n end;\r\n DosError := FindNext(SearchRec);\r\n end;\r\n FindClose(SearchRec);\r\n Result := True;\r\nend;\r\n\r\n//////////////////////////////////////////////////////////////////////////////\r\n{ Note: FileTimeToDateTime has been commented out, it is not used anywhere\r\n in the JVCL code. Further, the old version is not to be returned\r\n as it does not behave like the JCL version it is supposed to mimick.\r\n See Mantis 2452 for details.\r\n}\r\n{const\r\n FileTimeBase = -109205.0;\r\n FileTimeStep: Extended = 24.0 * 60.0 * 60.0 * 1000.0 * 1000.0 * 10.0; // 100 nSek per Day\r\nfunction FileTimeToDateTime(const FT: TFileTime): TDateTime;\r\nbegin\r\n Result := Int64(FileTime) / FileTimeStep;\r\n Result := Result + FileTimeBase;\r\nend;}\r\n// ---------------------------- old version ---------------------------\r\n//{$IFDEF MSWINDOWS}\r\n{var\r\n LocalFileTime: TFileTime;\r\n FileDate: Integer;\r\nbegin\r\n FileTimeToLocalFileTime(FT, LocalFileTime);\r\n FileTimeToDosDateTime(LocalFileTime, LongRec(FileDate).Hi, LongRec(FileDate).Lo);\r\n Result := FileDateToDateTime(FileDate);\r\nend;}\r\n//{$ENDIF MSWINDOWS}\r\n//{$IFDEF UNIX}\r\n{begin\r\n Result := FileDateToDateTime(FT);\r\nend;}\r\n//{$ENDIF UNIX}\r\n// ------------------------- old version --------------------------------\r\n\r\nprocedure FileTimeToDosDateTimeDWord(const FT: TFileTime; out Dft: DWORD);\r\nbegin\r\n FileTimeToDosDateTime(FT, LongRec(Dft).Hi, LongRec(Dft).Lo);\r\nend;\r\n\r\nfunction MakeValidFileName(const FileName: TFileName;\r\n ReplaceBadChar: Char): TFileName;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := FileName;\r\n for I := 1 to Length(Result) do\r\n if HasChar(Result[I], '''\":?*\\/') then\r\n Result[I] := ReplaceBadChar;\r\nend;\r\n\r\nfunction DefStr(const S: string; Default: string): string;\r\nbegin\r\n if S <> '' then\r\n Result := S\r\n else\r\n Result := Default;\r\nend;\r\n\r\nfunction StrLICompW2(S1, S2: PWideChar; MaxLen: Integer): Integer;\r\n// faster than the JclUnicode.StrLICompW function\r\nvar\r\n P1, P2: WideString;\r\nbegin\r\n SetString(P1, S1, Min(MaxLen, StrLenW(S1)));\r\n SetString(P2, S2, Min(MaxLen, StrLenW(S2)));\r\n Result := SysUtils.WideCompareText(P1, P2);\r\nend;\r\n\r\nfunction StrPosW(S, SubStr: PWideChar): PWideChar;\r\nvar\r\n P: PWideChar;\r\n I: Integer;\r\nbegin\r\n Result := nil;\r\n if (S = nil) or (SubStr = nil) or\r\n (S[0] = #0) or (SubStr[0] = #0) then\r\n Exit;\r\n Result := S;\r\n while Result[0] <> #0 do\r\n begin\r\n if Result[0] <> SubStr[0] then\r\n Inc(Result)\r\n else\r\n begin\r\n P := Result + 1;\r\n I := 0;\r\n while (P[0] <> #0) and (P[0] = SubStr[I]) do\r\n begin\r\n Inc(I);\r\n Inc(P);\r\n end;\r\n if SubStr[I] = #0 then\r\n Exit\r\n else\r\n Inc(Result);\r\n end;\r\n end;\r\n Result := nil;\r\nend;\r\n\r\nfunction StrLenW(S: PWideChar): Integer;\r\nbegin\r\n Result := 0;\r\n if S <> nil then\r\n while S[Result] <> #0 do\r\n Inc(Result);\r\nend;\r\n\r\nfunction TrimW(const S: WideString): WideString;\r\nbegin\r\n Result := Trim(S);\r\nend;\r\n\r\nfunction TrimLeftW(const S: WideString): WideString;\r\nbegin\r\n Result := TrimLeft(S);\r\nend;\r\n\r\nfunction TrimRightW(const S: WideString): WideString;\r\nbegin\r\n Result := TrimRight(S);\r\nend;\r\n\r\nprocedure SetDelimitedText(List: TStrings; const Text: string; Delimiter: Char);\r\nvar\r\n Ch: Char;\r\nbegin\r\n Ch := List.Delimiter;\r\n try\r\n List.Delimiter := Delimiter;\r\n List.DelimitedText := Text;\r\n finally\r\n List.Delimiter := Ch;\r\n end;\r\nend;\r\n\r\nfunction StrToBool(const S: string): Boolean;\r\nbegin\r\n Result := (S = '1') or SameText(S, 'True') or SameText(S, 'yes');\r\nend;\r\n\r\nfunction RATextOutEx(Canvas: TCanvas; const R, RClip: TRect; const S: string;\r\n const CalcHeight: Boolean): Integer;\r\nvar\r\n Ss: TStrings;\r\n I: Integer;\r\n H: Integer;\r\nbegin\r\n Ss := TStringList.Create;\r\n try\r\n Ss.Text := S;\r\n H := Canvas.TextHeight('A');\r\n Result := H * Ss.Count;\r\n if not CalcHeight then\r\n for I := 0 to Ss.Count - 1 do\r\n ExtTextOut(\r\n Canvas.Handle, // handle of device context\r\n R.Left, // X-coordinate of reference point\r\n R.Top + H * I, // Y-coordinate of reference point\r\n ETO_CLIPPED, // text-output options\r\n @RClip, // optional clipping and/or opaquing rectangle\r\n PChar(Ss[I]),\r\n Length(Ss[I]), // number of characters in string\r\n nil); // address of array of intercharacter spacing values\r\n finally\r\n Ss.Free;\r\n end;\r\nend;\r\n\r\nprocedure RATextOut(Canvas: TCanvas; const R, RClip: TRect; const S: string);\r\nbegin\r\n RATextOutEx(Canvas, R, RClip, S, False);\r\nend;\r\n\r\nfunction RATextCalcHeight(Canvas: TCanvas; const R: TRect; const S: string): Integer;\r\nbegin\r\n Result := RATextOutEx(Canvas, R, R, S, True);\r\nend;\r\n\r\nprocedure Cinema(Canvas: TCanvas; rS, rD: TRect);\r\nconst\r\n Pause = 30; {milliseconds}\r\n Steps = 7;\r\n Width = 1;\r\nvar\r\n R: TRect;\r\n I: Integer;\r\n PenOld: TPen;\r\n\r\n procedure FrameR(R: TRect);\r\n begin\r\n with Canvas do\r\n begin\r\n MoveTo(R.Left, R.Top);\r\n LineTo(R.Left, R.Bottom);\r\n LineTo(R.Right, R.Bottom);\r\n LineTo(R.Right, R.Top);\r\n LineTo(R.Left, R.Top);\r\n end;\r\n end;\r\n\r\n procedure Frame;\r\n begin\r\n FrameR(R);\r\n with Canvas do\r\n begin\r\n MoveTo(rS.Left, rS.Top);\r\n LineTo(R.Left, R.Top);\r\n if R.Top <> rS.Top then\r\n begin\r\n MoveTo(rS.Right, rS.Top);\r\n LineTo(R.Right, R.Top);\r\n end;\r\n if R.Left <> rS.Left then\r\n begin\r\n MoveTo(rS.Left, rS.Bottom);\r\n LineTo(R.Left, R.Bottom);\r\n end;\r\n if (R.Bottom <> rS.Bottom) and (R.Right <> rS.Right) then\r\n begin\r\n MoveTo(rS.Right, rS.Bottom);\r\n LineTo(R.Right, R.Bottom);\r\n end;\r\n end;\r\n end;\r\n\r\nbegin\r\n PenOld := TPen.Create;\r\n PenOld.Assign(Canvas.Pen);\r\n Canvas.Pen.Mode := pmNot;\r\n Canvas.Pen.Width := Width;\r\n Canvas.Pen.Style := psDot;\r\n FrameR(rS);\r\n R := rS;\r\n for I := 1 to Steps do\r\n begin\r\n R.Left := rS.Left + (rD.Left - rS.Left) div Steps * I;\r\n R.Top := rS.Top + (rD.Top - rS.Top) div Steps * I;\r\n R.Bottom := rS.Bottom + (rD.Bottom - rS.Bottom) div Steps * I;\r\n R.Right := rS.Right + (rD.Right - rS.Right) div Steps * I;\r\n Frame;\r\n Sleep(Pause);\r\n Frame;\r\n end;\r\n FrameR(rS);\r\n Canvas.Pen.Assign(PenOld);\r\nend;\r\n\r\nfunction IniReadSection(const IniFileName: TFileName; const Section: string; Ss: TStrings): Boolean;\r\nvar\r\n F: Integer;\r\n S: string;\r\nbegin\r\n with TStringList.Create do\r\n try\r\n LoadFromFile(IniFileName);\r\n F := IndexOf('[' + Section + ']');\r\n Result := F > -1;\r\n if Result then\r\n begin\r\n Ss.BeginUpdate;\r\n try\r\n Ss.Clear;\r\n Inc(F);\r\n while F < Count do\r\n begin\r\n S := Strings[F];\r\n if (Length(S) > 0) and (Trim(S[1]) = '[') then\r\n Break;\r\n Ss.Add(S);\r\n Inc(F);\r\n end;\r\n finally\r\n Ss.EndUpdate;\r\n end;\r\n end;\r\n finally\r\n Free;\r\n end;\r\nend;\r\n\r\nprocedure SaveTextFile(const FileName: TFileName; const Source: string);\r\nbegin\r\n with TStringList.Create do\r\n try\r\n Text := Source;\r\n SaveToFile(FileName);\r\n finally\r\n Free;\r\n end;\r\nend;\r\n\r\nfunction LoadTextFile(const FileName: TFileName): string;\r\nbegin\r\n with TStringList.Create do\r\n try\r\n LoadFromFile(FileName);\r\n Result := Text;\r\n finally\r\n Free;\r\n end;\r\nend;\r\n\r\nfunction ReadFolder(const Folder, Mask: TFileName; FileList: TStrings): Integer;\r\nvar\r\n SearchRec: TSearchRec;\r\n DosError: Integer;\r\nbegin\r\n FileList.BeginUpdate;\r\n try\r\n FileList.Clear;\r\n Result := FindFirst(AddSlash(Folder) + Mask, faAnyFile, SearchRec);\r\n DosError := Result;\r\n while DosError = 0 do\r\n begin\r\n if not ((SearchRec.Attr and faDirectory) = faDirectory) then\r\n FileList.Add(SearchRec.Name);\r\n DosError := FindNext(SearchRec);\r\n end;\r\n FindClose(SearchRec);\r\n finally\r\n FileList.EndUpdate;\r\n end;\r\nend;\r\n\r\nfunction ReadFolders(const Folder: TFileName; FolderList: TStrings): Integer;\r\nvar\r\n SearchRec: TSearchRec;\r\n DosError: Integer;\r\nbegin\r\n FolderList.BeginUpdate;\r\n try\r\n FolderList.Clear;\r\n Result := FindFirst(AddSlash(Folder) + AllFilesMask, faAnyFile, SearchRec);\r\n DosError := Result;\r\n while DosError = 0 do\r\n begin\r\n if ((SearchRec.Attr and faDirectory) = faDirectory) and\r\n (SearchRec.Name <> '.') and (SearchRec.Name <> '..') then\r\n FolderList.Add(SearchRec.Name);\r\n DosError := FindNext(SearchRec);\r\n end;\r\n FindClose(SearchRec);\r\n finally\r\n FolderList.EndUpdate;\r\n end;\r\nend;\r\n\r\n{ example for ReplaceStrings:\r\n with memEdit do\r\n begin\r\n Text := ReplaceStrings(Text, SelStart+1, SelLength, memWords.Lines, memFrases.Lines, NewSelStart);\r\n SelStart := NewSelStart-1;\r\n end; }\r\n\r\nfunction ReplaceStrings(const S: string; PosBeg, Len: Integer; Words, Frases: TStrings;\r\n var NewSelStart: Integer): string;\r\nvar\r\n I, Beg, Ent, LS, F: Integer;\r\n Word: string;\r\nbegin\r\n NewSelStart := PosBeg;\r\n Result := S;\r\n LS := Length(S);\r\n if Len = 0 then\r\n begin\r\n if PosBeg < 1 then\r\n Exit;\r\n if PosBeg = 1 then\r\n PosBeg := 2;\r\n for I := PosBeg - 1 downto 1 do\r\n if CharInSet(S[I], Separators) then\r\n Break;\r\n Beg := I + 1;\r\n for Ent := PosBeg to LS do\r\n if CharInSet(S[Ent], Separators) then\r\n Break;\r\n if Ent > Beg then\r\n Word := Copy(S, Beg, Ent - Beg)\r\n else\r\n Word := S[PosBeg];\r\n end\r\n else\r\n begin\r\n Word := Copy(S, PosBeg, Len);\r\n Beg := PosBeg;\r\n Ent := PosBeg + Len;\r\n end;\r\n if Word = '' then\r\n Exit;\r\n F := Words.IndexOf(Word);\r\n if (F > -1) and (F < Frases.Count) then\r\n begin\r\n Result := Copy(S, 1, Beg - 1) + Frases[F] + Copy(S, Ent, LS);\r\n NewSelStart := Beg + Length(Frases[F]);\r\n end;\r\nend;\r\n\r\n{ example for ReplaceAllStrings:\r\n\r\n with memEdit do\r\n Text := ReplaceAllStrings(Text, memWords.Lines, memFrases.Lines);\r\n}\r\n\r\nfunction ReplaceAllStrings(const S: string; Words, Frases: TStrings): string;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := S;\r\n for I := 0 to Words.Count - 1 do\r\n Result := ReplaceString(Result, Words[I], Frases[I]);\r\nend;\r\n\r\nfunction CountOfLines(const S: string): Integer;\r\nbegin\r\n with TStringList.Create do\r\n try\r\n Text := S;\r\n Result := Count;\r\n finally\r\n Free;\r\n end;\r\nend;\r\n\r\nprocedure DeleteOfLines(Ss: TStrings; const Words: array of string);\r\nvar\r\n I, J: Integer;\r\nbegin\r\n Ss.BeginUpdate;\r\n try\r\n for J:= Low(Words) to High(Words) do\r\n for I := Ss.Count - 1 downto 0 do\r\n if Trim(Ss[I]) = Trim(Words[J]) then\r\n Ss.Delete(I);\r\n finally\r\n Ss.EndUpdate;\r\n end;\r\nend;\r\n\r\nprocedure DeleteEmptyLines(Ss: TStrings);\r\nbegin\r\n DeleteOfLines(Ss,['']);\r\nend;\r\n\r\nprocedure SQLAddWhere(SQL: TStrings; const Where: string);\r\nvar\r\n I, J: Integer;\r\nbegin\r\n J := SQL.Count - 1;\r\n for I := 0 to SQL.Count - 1 do\r\n // (rom) does this always work? Think of a fieldname \"grouporder\"\r\n if StrLIComp(PChar(SQL[I]), 'where ', 6) = 0 then\r\n begin\r\n J := I + 1;\r\n while J < SQL.Count do\r\n begin\r\n if (StrLIComp(PChar(SQL[J]), 'order ', 6) = 0) or\r\n (StrLIComp(PChar(SQL[J]), 'group ', 6) = 0) then\r\n Break;\r\n Inc(J);\r\n end;\r\n end;\r\n SQL.Insert(J, 'and ' + Where);\r\nend;\r\n\r\nprocedure InternalFrame3D(Canvas: TCanvas; var Rect: TRect; TopColor, BottomColor: TColor;\r\n Width: Integer);\r\n\r\n procedure DoRect;\r\n var\r\n TopRight, BottomLeft: TPoint;\r\n begin\r\n TopRight.X := Rect.Right;\r\n TopRight.Y := Rect.Top;\r\n BottomLeft.X := Rect.Left;\r\n BottomLeft.Y := Rect.Bottom;\r\n Canvas.Pen.Color := TopColor;\r\n Canvas.PolyLine([BottomLeft, Rect.TopLeft, TopRight]);\r\n Canvas.Pen.Color := BottomColor;\r\n Dec(BottomLeft.X);\r\n Canvas.PolyLine([TopRight, Rect.BottomRight, BottomLeft]);\r\n end;\r\n\r\nbegin\r\n Canvas.Pen.Width := 1;\r\n Dec(Rect.Bottom);\r\n Dec(Rect.Right);\r\n while Width > 0 do\r\n begin\r\n Dec(Width);\r\n DoRect;\r\n InflateRect(Rect, -1, -1);\r\n end;\r\n Inc(Rect.Bottom);\r\n Inc(Rect.Right);\r\nend;\r\n\r\nprocedure Roughed(ACanvas: TCanvas; const ARect: TRect; const AVert: Boolean);\r\nvar\r\n I: Integer;\r\n J: Integer;\r\n R: TRect;\r\n V: Boolean;\r\n H: Boolean;\r\nbegin\r\n H := True;\r\n V := True;\r\n for I := 0 to (ARect.Right - ARect.Left) div 4 do\r\n begin\r\n for J := 0 to (ARect.Bottom - ARect.Top) div 4 do\r\n begin\r\n if AVert then\r\n begin\r\n if V then\r\n R := Bounds(ARect.Left + I * 4 + 2, ARect.Top + J * 4, 2, 2)\r\n else\r\n R := Bounds(ARect.Left + I * 4, ARect.Top + J * 4, 2, 2);\r\n end\r\n else\r\n begin\r\n if H then\r\n R := Bounds(ARect.Left + I * 4, ARect.Top + J * 4 + 2, 2, 2)\r\n else\r\n R := Bounds(ARect.Left + I * 4, ARect.Top + J * 4, 2, 2);\r\n end;\r\n\r\n InternalFrame3D(ACanvas, R, clBtnHighlight, clBtnShadow, 1);\r\n V := not V;\r\n end;\r\n H := not H;\r\n end;\r\nend;\r\n\r\nfunction BitmapFromBitmap(SrcBitmap: TBitmap; const AWidth, AHeight, Index: Integer): TBitmap;\r\nbegin\r\n Result := TBitmap.Create;\r\n Result.Width := AWidth;\r\n Result.Height := AHeight;\r\n Result.Canvas.CopyRect(Rect(0, 0, AWidth, AHeight), SrcBitmap.Canvas, Bounds(AWidth * Index, 0, AWidth, AHeight));\r\nend;\r\n\r\n{$IFDEF MSWINDOWS}\r\n\r\nfunction ResSaveToFileEx(Instance: HINST; Typ, Name: PChar;\r\n const Compressed: Boolean; const FileName: string): Boolean;\r\nvar\r\n RhRsrc: HRSRC;\r\n RhGlobal: HGLOBAL;\r\n RAddr: Pointer;\r\n RLen: DWORD;\r\n Stream: TFileStream;\r\n FileDest: string;\r\nbegin\r\n Result := False;\r\n RhRsrc := FindResource(\r\n Instance, // resource-module handle\r\n Name, // address of resource name\r\n Typ); // address of resource type\r\n if RhRsrc = 0 then\r\n Exit;\r\n RhGlobal := LoadResource(\r\n Instance, // resource-module handle\r\n RhRsrc); // resource handle\r\n if RhGlobal = 0 then\r\n Exit;\r\n RAddr := LockResource(\r\n RhGlobal); // handle to resource to lock\r\n FreeResource(RhGlobal);\r\n if RAddr = nil then\r\n Exit;\r\n RLen := SizeofResource(\r\n Instance, // resource-module handle\r\n RhRsrc); // resource handle\r\n if RLen = 0 then\r\n Exit;\r\n { And now it is possible to duplicate [translated] }\r\n Stream := nil; { for Free [translated] }\r\n if Compressed then\r\n FileDest := GenTempFileName(FileName)\r\n else\r\n FileDest := FileName;\r\n try\r\n try\r\n Stream := TFileStream.Create(FileDest, fmCreate or fmOpenWrite or fmShareExclusive);\r\n Stream.WriteBuffer(RAddr^, RLen);\r\n finally\r\n Stream.Free;\r\n end;\r\n if Compressed then\r\n begin\r\n Result := LZFileExpand(FileDest, FileName);\r\n DeleteFile(FileDest);\r\n end\r\n else\r\n Result := True;\r\n except\r\n end;\r\nend;\r\n\r\nfunction ResSaveToFile(const Typ, Name: string; const Compressed: Boolean;\r\n const FileName: string): Boolean;\r\nbegin\r\n Result := ResSaveToFileEx(HInstance, PChar(Typ), PChar(Name), Compressed, FileName);\r\nend;\r\n\r\nfunction ResSaveToString(Instance: HINST; const Typ, Name: string;\r\n var S: string): Boolean;\r\nvar\r\n RhRsrc: HRSRC;\r\n RhGlobal: HGLOBAL;\r\n RAddr: Pointer;\r\n RLen: DWORD;\r\nbegin\r\n Result := False;\r\n RhRsrc := FindResource(\r\n Instance, // resource-module handle\r\n PChar(Name), // address of resource name\r\n PChar(Typ)); // address of resource type\r\n if RhRsrc = 0 then\r\n Exit;\r\n RhGlobal := LoadResource(\r\n Instance, // resource-module handle\r\n RhRsrc); // resource handle\r\n if RhGlobal = 0 then\r\n Exit;\r\n RAddr := LockResource(RhGlobal); // handle to resource to lock\r\n FreeResource(RhGlobal);\r\n if RAddr = nil then\r\n Exit;\r\n RLen := SizeofResource(\r\n Instance, // resource-module handle\r\n RhRsrc); // resource handle\r\n if RLen = 0 then\r\n Exit;\r\n { And now it is possible to duplicate [translated] }\r\n SetString(S, PChar(RAddr), RLen);\r\nend;\r\n\r\n{$ENDIF MSWINDOWS}\r\n\r\nfunction TextHeight(const AStr: string): Integer;\r\nvar\r\n Canvas: TCanvas;\r\n DC: HDC;\r\nbegin\r\n DC := GetDC(HWND_DESKTOP);\r\n Canvas := TCanvas.Create;\r\n try\r\n Canvas.Handle := DC;\r\n Result := Canvas.TextHeight(AStr);\r\n Canvas.Handle := NullHandle;\r\n finally\r\n ReleaseDC(HWND_DESKTOP, DC);\r\n Canvas.Free;\r\n end;\r\nend;\r\n\r\nfunction TextWidth(const AStr: string): Integer;\r\nvar\r\n Canvas: TCanvas;\r\n DC: HDC;\r\nbegin\r\n DC := GetDC(HWND_DESKTOP);\r\n Canvas := TCanvas.Create;\r\n try\r\n Canvas.Handle := DC;\r\n Result := Canvas.TextWidth(AStr);\r\n Canvas.Handle := NullHandle;\r\n finally\r\n ReleaseDC(HWND_DESKTOP, DC);\r\n Canvas.Free;\r\n end;\r\nend;\r\n\r\nprocedure SetChildPropOrd(Owner: TComponent; const PropName: string; Value: Longint);\r\nvar\r\n I: Integer;\r\n PropInfo: PPropInfo;\r\nbegin\r\n for I := 0 to Owner.ComponentCount - 1 do\r\n begin\r\n PropInfo := GetPropInfo(Owner.Components[I].ClassInfo, PropName);\r\n if PropInfo <> nil then\r\n SetOrdProp(Owner.Components[I], PropInfo, Value);\r\n end;\r\nend;\r\n\r\nprocedure Error(const Msg: string);\r\nbegin\r\n raise Exception.Create(Msg);\r\nend;\r\n\r\nprocedure ItemHtDrawEx(Canvas: TCanvas; Rect: TRect;\r\n const State: TOwnerDrawState; const Text: string;\r\n const HideSelColor: Boolean; var PlainItem: string;\r\n var Width: Integer; CalcWidth: Boolean);\r\nvar\r\n CL: string;\r\n I: Integer;\r\n M1: string;\r\n OriRect: TRect; // it's added\r\n LastFontStyle: TFontStyles;\r\n LastFontColor: TColor;\r\n\r\n function Cmp(const M1: string): Boolean;\r\n begin\r\n Result := AnsiStrLIComp(PChar(Text) + I, PChar(M1), Length(M1)) = 0;\r\n end;\r\n\r\n function Cmp1(const M1: string): Boolean;\r\n begin\r\n Result := Cmp(M1);\r\n if Result then\r\n Inc(I, Length(M1));\r\n end;\r\n\r\n function CmpL(const M1: string): Boolean;\r\n begin\r\n Result := Cmp(M1 + '>');\r\n end;\r\n\r\n function CmpL1(const M1: string): Boolean;\r\n begin\r\n Result := Cmp1(M1 + '>');\r\n end;\r\n\r\n procedure Draw(const M: string);\r\n begin\r\n if not Assigned(Canvas) then\r\n Exit;\r\n if not CalcWidth then\r\n Canvas.TextOut(Rect.Left, Rect.Top, M);\r\n Rect.Left := Rect.Left + Canvas.TextWidth(M);\r\n end;\r\n\r\n procedure Style(const Style: TFontStyle; const Include: Boolean);\r\n begin\r\n if not Assigned(Canvas) then\r\n Exit;\r\n if Include then\r\n Canvas.Font.Style := Canvas.Font.Style + [Style]\r\n else\r\n Canvas.Font.Style := Canvas.Font.Style - [Style];\r\n end;\r\n\r\nbegin\r\n PlainItem := '';\r\n LastFontColor := 0; { satisfy compiler }\r\n if Canvas <> nil then\r\n begin\r\n LastFontStyle := Canvas.Font.Style;\r\n LastFontColor := Canvas.Font.Color;\r\n end;\r\n try\r\n if HideSelColor and Assigned(Canvas) then\r\n begin\r\n Canvas.Brush.Color := clWindow;\r\n Canvas.Font.Color := clWindowText;\r\n end;\r\n if Assigned(Canvas) then\r\n Canvas.FillRect(Rect);\r\n\r\n Width := Rect.Left;\r\n Rect.Left := Rect.Left + 2;\r\n\r\n OriRect := Rect; //save origin rectangle\r\n\r\n M1 := '';\r\n I := 1;\r\n while I <= Length(Text) do\r\n begin\r\n if (Text[I] = '<') and\r\n (CmpL('b') or CmpL('/b') or\r\n CmpL('i') or CmpL('/i') or\r\n CmpL('u') or CmpL('/u') or\r\n Cmp('c:')) then\r\n begin\r\n Draw(M1);\r\n PlainItem := PlainItem + M1;\r\n\r\n if CmpL1('b') then\r\n Style(fsBold, True)\r\n else\r\n if CmpL1('/b') then\r\n Style(fsBold, False)\r\n else\r\n if CmpL1('i') then\r\n Style(fsItalic, True)\r\n else\r\n if CmpL1('/i') then\r\n Style(fsItalic, False)\r\n else\r\n if CmpL1('u') then\r\n Style(fsUnderline, True)\r\n else\r\n if CmpL1('/u') then\r\n Style(fsUnderline, False)\r\n else\r\n if Cmp1('c:') then\r\n begin\r\n CL := SubStrBySeparator(Text, 0, '>', I);\r\n if (HideSelColor or not (odSelected in State)) and Assigned(Canvas) then\r\n try\r\n if (Length(CL) > 0) and (CL[1] <> '$') then\r\n Canvas.Font.Color := StringToColor('cl' + CL)\r\n else\r\n Canvas.Font.Color := StringToColor(CL);\r\n except\r\n end;\r\n Inc(I, Length(CL) + 1 {'>'});\r\n end;\r\n Inc(I);\r\n if (Text[I] = Chr(13)) and Cmp1(string(Chr(10))) then\r\n begin\r\n Rect.Left := OriRect.Left;\r\n Rect.Top := Rect.Top + Canvas.TextHeight(M1 + 'W');\r\n Inc(I);\r\n end;\r\n Dec(I);\r\n M1 := '';\r\n end\r\n else\r\n if (Text[I] = Chr(13)) and Cmp1(string(Chr(10))) then\r\n begin\r\n // new line\r\n Draw(M1);\r\n PlainItem := PlainItem + M1;\r\n Rect.Left := OriRect.Left;\r\n Rect.Top := Rect.Top + Canvas.TextHeight(M1 + 'W');\r\n M1 := '';\r\n end\r\n else\r\n M1 := M1 + Text[I]; // add text\r\n Inc(I);\r\n end; { for }\r\n Draw(M1);\r\n PlainItem := PlainItem + M1;\r\n finally\r\n if Canvas <> nil then\r\n begin\r\n Canvas.Font.Style := LastFontStyle;\r\n Canvas.Font.Color := LastFontColor;\r\n end;\r\n end;\r\n Width := Rect.Left - Width + 2;\r\nend;\r\n\r\nfunction ItemHtDraw(Canvas: TCanvas; Rect: TRect;\r\n const State: TOwnerDrawState; const Text: string;\r\n const HideSelColor: Boolean): string;\r\nvar\r\n S: string;\r\n W: Integer;\r\nbegin\r\n ItemHtDrawEx(Canvas, Rect, State, Text, HideSelColor, S, W, False);\r\nend;\r\n\r\nfunction ItemHtPlain(const Text: string): string;\r\nvar\r\n S: string;\r\n W: Integer;\r\nbegin\r\n ItemHtDrawEx(nil, Rect(0, 0, -1, -1), [], Text, False, S, W, False);\r\n Result := S;\r\nend;\r\n\r\nfunction ItemHtWidth(Canvas: TCanvas; Rect: TRect;\r\n const State: TOwnerDrawState; const Text: string;\r\n const HideSelColor: Boolean): Integer;\r\nvar\r\n S: string;\r\n W: Integer;\r\nbegin\r\n ItemHtDrawEx(Canvas, Rect, State, Text, HideSelColor, S, W, True);\r\n Result := W;\r\nend;\r\n\r\nprocedure ClearList(List: TList);\r\nvar\r\n I: Integer;\r\nbegin\r\n if Assigned(List) then\r\n begin\r\n if not (List is TObjectList) then\r\n for I := 0 to List.Count - 1 do\r\n TObject(List[I]).Free;\r\n List.Clear;\r\n end;\r\nend;\r\n\r\nprocedure MemStreamToClipBoard(MemStream: TMemoryStream; const Format: Word);\r\nvar\r\n Data: THandle;\r\n DataPtr: Pointer;\r\nbegin\r\n Clipboard.Open;\r\n try\r\n Data := GlobalAlloc(GMEM_MOVEABLE, MemStream.Size);\r\n try\r\n DataPtr := GlobalLock(Data);\r\n try\r\n Move(MemStream.Memory^, DataPtr^, MemStream.Size);\r\n Clipboard.Clear;\r\n SetClipboardData(Format, Data);\r\n finally\r\n GlobalUnlock(Data);\r\n end;\r\n except\r\n GlobalFree(Data);\r\n raise;\r\n end;\r\n finally\r\n Clipboard.Close;\r\n end;\r\nend;\r\n\r\nprocedure ClipBoardToMemStream(MemStream: TMemoryStream; const Format: Word);\r\nvar\r\n Data: THandle;\r\n DataPtr: Pointer;\r\nbegin\r\n Clipboard.Open;\r\n try\r\n Data := GetClipboardData(Format);\r\n if Data = 0 then\r\n Exit;\r\n DataPtr := GlobalLock(Data);\r\n if DataPtr = nil then\r\n Exit;\r\n try\r\n MemStream.WriteBuffer(DataPtr^, GlobalSize(Data));\r\n MemStream.Position := 0;\r\n finally\r\n GlobalUnlock(Data);\r\n end;\r\n finally\r\n Clipboard.Close;\r\n end;\r\nend;\r\n\r\nfunction GetPropTypeKind(PropInf: PPropInfo): TTypeKind;\r\nbegin\r\n Result := PropInf.PropType^.Kind;\r\nend;\r\n\r\nfunction GetPropType(Obj: TObject; const PropName: string): TTypeKind;\r\nvar\r\n PropInf: PPropInfo;\r\nbegin\r\n PropInf := GetPropInfo(Obj.ClassInfo, PropName);\r\n if PropInf = nil then\r\n Result := tkUnknown\r\n else\r\n Result := GetPropTypeKind(PropInf);\r\nend;\r\n\r\nfunction GetPropStr(Obj: TObject; const PropName: string): string;\r\nvar\r\n PropInf: PPropInfo;\r\nbegin\r\n PropInf := GetPropInfo(Obj.ClassInfo, PropName);\r\n if PropInf = nil then\r\n raise Exception.CreateResFmt(@RsEPropertyNotExists, [PropName]);\r\n if not (GetPropTypeKind(PropInf) in tkStrings) then\r\n raise Exception.CreateResFmt(@RsEInvalidPropertyType, [PropName]);\r\n Result := GetStrProp(Obj, PropInf);\r\nend;\r\n\r\nfunction GetPropOrd(Obj: TObject; const PropName: string): Integer;\r\nvar\r\n PropInf: PPropInfo;\r\nbegin\r\n PropInf := GetPropInfo(Obj.ClassInfo, PropName);\r\n if PropInf = nil then\r\n raise Exception.CreateResFmt(@RsEPropertyNotExists, [PropName]);\r\n if not (GetPropTypeKind(PropInf) in [tkInteger, tkChar, tkWChar, tkEnumeration, tkClass]) then\r\n raise Exception.CreateResFmt(@RsEInvalidPropertyType, [PropName]);\r\n Result := GetOrdProp(Obj, PropInf);\r\nend;\r\n\r\nfunction GetPropMethod(Obj: TObject; const PropName: string): TMethod;\r\nvar\r\n PropInf: PPropInfo;\r\nbegin\r\n PropInf := GetPropInfo(Obj.ClassInfo, PropName);\r\n if PropInf = nil then\r\n raise Exception.CreateResFmt(@RsEPropertyNotExists, [PropName]);\r\n if not (GetPropTypeKind(PropInf) = tkMethod) then\r\n raise Exception.CreateResFmt(@RsEInvalidPropertyType, [PropName]);\r\n Result := GetMethodProp(Obj, PropInf);\r\nend;\r\n\r\nprocedure PrepareIniSection(Ss: TStrings);\r\nvar\r\n I: Integer;\r\n S: string;\r\nbegin\r\n Ss.BeginUpdate;\r\n try\r\n for I := Ss.Count - 1 downto 0 do\r\n begin\r\n S := Trim(Ss[I]);\r\n if (S = '') or (S[1] = ';') or (S[1] = '#') then\r\n Ss.Delete(I);\r\n end;\r\n finally\r\n Ss.EndUpdate;\r\n end;\r\nend;\r\n\r\n{:Creates a TPointL structure from a pair of coordinates.\r\nCall PointL to create a TPointL structure that represents the specified\r\ncoordinates. Use PointL to construct parameters for functions\r\nthat require a TPointL, rather than setting up local variables\r\nfor each parameter.\r\n@param X The X coordinate.\r\n@param Y The Y coordinate.\r\n@return A TPointL structure for coordinates X and Y.\r\n@example \r\nvar\r\n p: TPointL;\r\nbegin\r\n p := PointL(100, 100);\r\nend;\r\n\r\n}\r\n\r\nfunction PointL(const X, Y: Longint): TPointL;\r\nbegin\r\n Result.X := X;\r\n Result.Y := Y;\r\nend;\r\n\r\n{:Conditional assignment.\r\nReturns the value in True or False depending on the condition Test.\r\n@param Test The test condition.\r\n@param True Returns this value if Test is True.\r\n@param False Returns this value if Test is False.\r\n@return Value in True or False depending on Test.\r\n@example \r\nbar := iif(foo, 1, 0);\r\n\r\n
has the same effects as:
\r\n\r\nif foo then\r\n bar := 1\r\nelse\r\n bar := 0;\r\n\r\n}\r\n\r\nfunction iif(const Test: Boolean; const ATrue, AFalse: Variant): Variant;\r\nbegin\r\n if Test then\r\n Result := ATrue\r\n else\r\n Result := AFalse;\r\nend;\r\n\r\n\r\n{ begin JvIconClipboardUtils}\r\n{ Icon clipboard routines }\r\n\r\nvar\r\n Private_CF_ICON: Word;\r\n\r\nfunction CF_ICON: Word;\r\nbegin\r\n if Private_CF_ICON = 0 then\r\n begin\r\n { The following string should not be localized }\r\n Private_CF_ICON := RegisterClipboardFormat('Delphi Icon');\r\n TPicture.RegisterClipboardFormat(Private_CF_ICON, TIcon);\r\n end;\r\n Result := Private_CF_ICON;\r\nend;\r\n\r\nfunction CreateBitmapFromIcon(Icon: TIcon; BackColor: TColor): TBitmap;\r\nvar\r\n Ico: HICON;\r\n W, H: Integer;\r\nbegin\r\n Ico := CreateRealSizeIcon(Icon);\r\n try\r\n GetIconSize(Ico, W, H);\r\n Result := TBitmap.Create;\r\n try\r\n Result.Width := W;\r\n Result.Height := H;\r\n Result.Canvas.Brush.Color := BackColor;\r\n Result.Canvas.FillRect(Rect(0, 0, W, H));\r\n DrawIconEx(Result.Canvas.Handle, 0, 0, Ico, W, H, 0, 0, DI_NORMAL);\r\n except\r\n Result.Free;\r\n raise;\r\n end;\r\n finally\r\n DestroyIcon(Ico);\r\n end;\r\nend;\r\n\r\nprocedure CopyIconToClipboard(Icon: TIcon; BackColor: TColor);\r\nvar\r\n Bmp: TBitmap;\r\n Stream: TStream;\r\n Data: THandle;\r\n Format: Word;\r\n Palette: HPalette;\r\n Buffer: Pointer;\r\nbegin\r\n Bmp := CreateBitmapFromIcon(Icon, BackColor);\r\n try\r\n Stream := TMemoryStream.Create;\r\n try\r\n Icon.SaveToStream(Stream);\r\n Palette := 0;\r\n with Clipboard do\r\n begin\r\n Open;\r\n try\r\n Clear;\r\n Bmp.SaveToClipboardFormat(Format, Data, Palette);\r\n SetClipboardData(Format, Data);\r\n if Palette <> 0 then\r\n SetClipboardData(CF_PALETTE, Palette);\r\n Data := GlobalAlloc(HeapAllocFlags, Stream.Size);\r\n try\r\n if Data <> 0 then\r\n begin\r\n Buffer := GlobalLock(Data);\r\n try\r\n Stream.Seek(0, 0);\r\n Stream.Read(Buffer^, Stream.Size);\r\n SetClipboardData(CF_ICON, Data);\r\n finally\r\n GlobalUnlock(Data);\r\n end;\r\n end;\r\n except\r\n GlobalFree(Data);\r\n raise;\r\n end;\r\n finally\r\n Close;\r\n end;\r\n end;\r\n finally\r\n Stream.Free;\r\n end;\r\n finally\r\n Bmp.Free;\r\n end;\r\nend;\r\n\r\nprocedure AssignClipboardIcon(Icon: TIcon);\r\nvar\r\n Stream: TStream;\r\n Data: THandle;\r\n Buffer: Pointer;\r\nbegin\r\n if not Clipboard.HasFormat(CF_ICON) then\r\n Exit;\r\n with Clipboard do\r\n begin\r\n Open;\r\n try\r\n Data := GetClipboardData(CF_ICON);\r\n Buffer := GlobalLock(Data);\r\n try\r\n Stream := TMemoryStream.Create;\r\n try\r\n Stream.Write(Buffer^, GlobalSize(Data));\r\n Stream.Seek(0, 0);\r\n Icon.LoadFromStream(Stream);\r\n finally\r\n Stream.Free;\r\n end;\r\n finally\r\n GlobalUnlock(Data);\r\n end;\r\n finally\r\n Close;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction CreateIconFromClipboard: TIcon;\r\nbegin\r\n Result := nil;\r\n if not Clipboard.HasFormat(CF_ICON) then\r\n Exit;\r\n Result := TIcon.Create;\r\n try\r\n AssignClipboardIcon(Result);\r\n except\r\n Result.Free;\r\n raise;\r\n end;\r\nend;\r\n\r\n{ Real-size icons support routines }\r\nconst\r\n RC3_STOCKICON = 0;\r\n RC3_ICON = 1;\r\n RC3_CURSOR = 2;\r\n\r\ntype\r\n PCursorOrIcon = ^TCursorOrIcon;\r\n TCursorOrIcon = packed record\r\n Reserved: Word;\r\n wType: Word;\r\n Count: Word;\r\n end;\r\n\r\n PIconRec = ^TIconRec;\r\n TIconRec = packed record\r\n Width: Byte;\r\n Height: Byte;\r\n Colors: Word;\r\n Reserved1: Word;\r\n Reserved2: Word;\r\n DIBSize: Longint;\r\n DIBOffset: Longint;\r\n end;\r\n\r\nfunction WidthBytes(I: Longint): Longint;\r\nbegin\r\n Result := ((I + 31) div 32) * 4;\r\nend;\r\n\r\nfunction GetDInColors(BitCount: Word): Integer;\r\nbegin\r\n case BitCount of\r\n 1, 4, 8:\r\n Result := 1 shl BitCount;\r\n else\r\n Result := 0;\r\n end;\r\nend;\r\n\r\nprocedure OutOfResources;\r\nbegin\r\n raise EOutOfResources.Create(SOutOfResources);\r\nend;\r\n\r\nfunction DupBits(Src: HBITMAP; Size: TPoint; Mono: Boolean): HBITMAP;\r\nvar\r\n DC, Mem1, Mem2: HDC;\r\n Old1, Old2: HBITMAP;\r\n Bitmap: tagBITMAP;\r\nbegin\r\n Mem1 := CreateCompatibleDC(NullHandle);\r\n Mem2 := CreateCompatibleDC(NullHandle);\r\n GetObject(Src, SizeOf(Bitmap), @Bitmap);\r\n if Mono then\r\n Result := CreateBitmap(Size.X, Size.Y, 1, 1, nil)\r\n else\r\n begin\r\n DC := GetDC(HWND_DESKTOP);\r\n if DC = NullHandle then\r\n OutOfResources;\r\n try\r\n Result := CreateCompatibleBitmap(DC, Size.X, Size.Y);\r\n if Result = NullHandle then\r\n OutOfResources;\r\n finally\r\n ReleaseDC(HWND_DESKTOP, DC);\r\n end;\r\n end;\r\n if Result <> NullHandle then\r\n begin\r\n Old1 := SelectObject(Mem1, Src);\r\n Old2 := SelectObject(Mem2, Result);\r\n StretchBlt(Mem2, 0, 0, Size.X, Size.Y, Mem1, 0, 0, Bitmap.bmWidth,\r\n Bitmap.bmHeight, SRCCOPY);\r\n if Old1 <> NullHandle then\r\n SelectObject(Mem1, Old1);\r\n if Old2 <> NullHandle then\r\n SelectObject(Mem2, Old2);\r\n end;\r\n DeleteDC(Mem1);\r\n DeleteDC(Mem2);\r\nend;\r\n\r\nprocedure TwoBitsFromDIB(var BI: TBitmapInfoHeader; var XorBits, AndBits: HBITMAP);\r\ntype\r\n PLongArray = ^TLongArray;\r\n TLongArray = array [0..1] of Longint;\r\nvar\r\n Temp: HBITMAP;\r\n NumColors: Integer;\r\n DC: HDC;\r\n Bits: Pointer;\r\n Colors: PLongArray;\r\n IconSize: TPoint;\r\n BM: tagBITMAP;\r\nbegin\r\n IconSize.X := GetSystemMetrics(SM_CXICON);\r\n IconSize.Y := GetSystemMetrics(SM_CYICON);\r\n with BI do\r\n begin\r\n biHeight := biHeight shr 1; { Size in record is doubled }\r\n biSizeImage := WidthBytes(Longint(biWidth) * biBitCount) * biHeight;\r\n NumColors := GetDInColors(biBitCount);\r\n end;\r\n DC := GetDC(HWND_DESKTOP);\r\n if DC = NullHandle then\r\n OutOfResources;\r\n try\r\n Bits := Pointer(PAnsiChar(@BI) + SizeOf(BI) + NumColors * SizeOf(TRGBQuad));\r\n Temp := CreateDIBitmap(DC, BI, CBM_INIT, Bits, PBitmapInfo(@BI)^, DIB_RGB_COLORS);\r\n if Temp = NullHandle then\r\n OutOfResources;\r\n try\r\n GetObject(Temp, SizeOf(BM), @BM);\r\n IconSize.X := BM.bmWidth;\r\n IconSize.Y := BM.bmHeight;\r\n XorBits := DupBits(Temp, IconSize, False);\r\n finally\r\n DeleteObject(Temp);\r\n end;\r\n with BI do\r\n begin\r\n Inc(INT_PTR(Bits), biSizeImage);\r\n biBitCount := 1;\r\n biSizeImage := WidthBytes(Longint(biWidth) * biBitCount) * biHeight;\r\n biClrUsed := 2;\r\n biClrImportant := 2;\r\n end;\r\n Colors := Pointer(PAnsiChar(@BI) + SizeOf(BI));\r\n Colors^[0] := 0;\r\n Colors^[1] := $FFFFFF;\r\n Temp := CreateDIBitmap(DC, BI, CBM_INIT, Bits, PBitmapInfo(@BI)^, DIB_RGB_COLORS);\r\n if Temp = NullHandle then\r\n OutOfResources;\r\n try\r\n AndBits := DupBits(Temp, IconSize, True);\r\n finally\r\n DeleteObject(Temp);\r\n end;\r\n finally\r\n ReleaseDC(HWND_DESKTOP, DC);\r\n end;\r\nend;\r\n\r\nprocedure ReadIcon(Stream: TStream; var Icon: HICON; ImageCount: Integer;\r\n StartOffset: Integer);\r\ntype\r\n PIconRecArray = ^TIconRecArray;\r\n TIconRecArray = array [0..300] of TIconRec;\r\nvar\r\n List: PIconRecArray;\r\n HeaderLen, Length: Integer;\r\n Colors, BitsPerPixel: Word;\r\n C1, C2, N, Index: Integer;\r\n IconSize: TPoint;\r\n DC: HDC;\r\n BI: PBitmapInfoHeader;\r\n ResData: Pointer;\r\n XorBits, AndBits: HBITMAP;\r\n XorInfo, AndInfo: Windows.TBitmap;\r\n XorMem, AndMem: Pointer;\r\n XorLen, AndLen: Integer;\r\nbegin\r\n HeaderLen := SizeOf(TIconRec) * ImageCount;\r\n List := AllocMem(HeaderLen);\r\n try\r\n Stream.Read(List^, HeaderLen);\r\n IconSize.X := GetSystemMetrics(SM_CXICON);\r\n IconSize.Y := GetSystemMetrics(SM_CYICON);\r\n DC := GetDC(HWND_DESKTOP);\r\n if DC = NullHandle then\r\n OutOfResources;\r\n try\r\n BitsPerPixel := GetDeviceCaps(DC, PLANES) * GetDeviceCaps(DC, BITSPIXEL);\r\n if BitsPerPixel = 24 then\r\n Colors := 0\r\n else\r\n Colors := 1 shl BitsPerPixel;\r\n finally\r\n ReleaseDC(HWND_DESKTOP, DC);\r\n end;\r\n Index := -1;\r\n { the following code determines which image most closely matches the\r\n current device. It is not meant to absolutely match Windows\r\n (known broken) algorithm }\r\n C2 := 0;\r\n for N := 0 to ImageCount - 1 do\r\n begin\r\n C1 := List^[N].Colors;\r\n if C1 = Colors then\r\n begin\r\n Index := N;\r\n Break;\r\n end\r\n else\r\n if Index = -1 then\r\n begin\r\n if C1 <= Colors then\r\n begin\r\n Index := N;\r\n C2 := List^[N].Colors;\r\n end;\r\n end\r\n else\r\n if C1 > C2 then\r\n Index := N;\r\n end;\r\n if Index = -1 then\r\n Index := 0;\r\n with List^[Index] do\r\n begin\r\n BI := AllocMem(DIBSize);\r\n try\r\n Stream.Seek(DIBOffset - (HeaderLen + StartOffset), 1);\r\n Stream.Read(BI^, DIBSize);\r\n TwoBitsFromDIB(BI^, XorBits, AndBits);\r\n GetObject(AndBits, SizeOf(Windows.TBitmap), @AndInfo);\r\n GetObject(XorBits, SizeOf(Windows.TBitmap), @XorInfo);\r\n IconSize.X := AndInfo.bmWidth;\r\n IconSize.Y := AndInfo.bmHeight;\r\n with AndInfo do\r\n AndLen := bmWidthBytes * bmHeight * bmPlanes;\r\n with XorInfo do\r\n XorLen := bmWidthBytes * bmHeight * bmPlanes;\r\n Length := AndLen + XorLen;\r\n ResData := AllocMem(Length);\r\n try\r\n AndMem := ResData;\r\n with AndInfo do\r\n XorMem := Pointer(PAnsiChar(ResData) + AndLen);\r\n GetBitmapBits(AndBits, AndLen, AndMem);\r\n GetBitmapBits(XorBits, XorLen, XorMem);\r\n DeleteObject(XorBits);\r\n DeleteObject(AndBits);\r\n Icon := CreateIcon(HInstance, IconSize.X, IconSize.Y,\r\n XorInfo.bmPlanes, XorInfo.bmBitsPixel, AndMem, XorMem);\r\n if Icon = 0 then\r\n OutOfResources;\r\n finally\r\n FreeMem(ResData, Length);\r\n end;\r\n finally\r\n FreeMem(BI, DIBSize);\r\n end;\r\n end;\r\n finally\r\n FreeMem(List, HeaderLen);\r\n end;\r\nend;\r\n\r\nprocedure GetIconSize(Icon: HICON; var W, H: Integer);\r\nvar\r\n IconInfo: TIconInfo;\r\n BM: Windows.TBitmap;\r\nbegin\r\n if GetIconInfo(Icon, IconInfo) then\r\n begin\r\n try\r\n if IconInfo.hbmColor <> 0 then\r\n begin\r\n GetObject(IconInfo.hbmColor, SizeOf(BM), @BM);\r\n W := BM.bmWidth;\r\n H := BM.bmHeight;\r\n end\r\n else\r\n if IconInfo.hbmMask <> 0 then\r\n begin { Monochrome icon }\r\n GetObject(IconInfo.hbmMask, SizeOf(BM), @BM);\r\n W := BM.bmWidth;\r\n H := BM.bmHeight shr 1; { Size in record is doubled }\r\n end\r\n else\r\n begin\r\n W := GetSystemMetrics(SM_CXICON);\r\n H := GetSystemMetrics(SM_CYICON);\r\n end;\r\n finally\r\n if IconInfo.hbmColor <> 0 then\r\n DeleteObject(IconInfo.hbmColor);\r\n if IconInfo.hbmMask <> 0 then\r\n DeleteObject(IconInfo.hbmMask);\r\n end;\r\n end\r\n else\r\n begin\r\n W := GetSystemMetrics(SM_CXICON);\r\n H := GetSystemMetrics(SM_CYICON);\r\n end;\r\nend;\r\n\r\nfunction CreateRealSizeIcon(Icon: TIcon): HICON;\r\nvar\r\n Mem: TMemoryStream;\r\n CI: TCursorOrIcon;\r\nbegin\r\n Result := 0;\r\n Mem := TMemoryStream.Create;\r\n try\r\n Icon.SaveToStream(Mem);\r\n Mem.Position := 0;\r\n Mem.ReadBuffer(CI, SizeOf(CI));\r\n case CI.wType of\r\n RC3_STOCKICON:\r\n Result := LoadIcon(0, IDI_APPLICATION);\r\n RC3_ICON:\r\n ReadIcon(Mem, Result, CI.Count, SizeOf(CI));\r\n else\r\n Result := CopyIcon(Icon.Handle);\r\n end;\r\n finally\r\n Mem.Free;\r\n end;\r\nend;\r\n\r\nprocedure DrawRealSizeIcon(Canvas: TCanvas; Icon: TIcon; X, Y: Integer);\r\nvar\r\n Ico: HICON;\r\n W, H: Integer;\r\nbegin\r\n Ico := CreateRealSizeIcon(Icon);\r\n try\r\n GetIconSize(Ico, W, H);\r\n DrawIconEx(Canvas.Handle, X, Y, Ico, W, H, 0, 0, DI_NORMAL);\r\n finally\r\n DestroyIcon(Ico);\r\n end;\r\nend;\r\n\r\n{ end JvIconClipboardUtils }\r\n\r\nfunction CreateScreenCompatibleDC: HDC;\r\nconst\r\n HDC_DESKTOP = HDC(0);\r\nbegin\r\n Result := CreateCompatibleDC(HDC_DESKTOP);\r\nend;\r\n\r\nfunction InvalidateRect(hWnd: HWND; const lpRect: TRect; bErase: BOOL): BOOL;\r\nbegin\r\n Result := Windows.InvalidateRect(hWnd, @lpRect, bErase);\r\nend;\r\n\r\nfunction InvalidateRect(hWnd: HWND; lpRect: PRect; bErase: BOOL): BOOL;\r\nbegin\r\n Result := Windows.InvalidateRect(hWnd, lpRect, bErase);\r\nend;\r\n\r\n{ begin JvRLE }\r\n\r\nprocedure RleCompressTo(InStream, OutStream: TStream);\r\nvar\r\n Count, Count2, Count3, I: Integer;\r\n Buf1: array [0..1024] of Byte;\r\n Buf2: array [0..60000] of Byte;\r\n B: Byte;\r\nbegin\r\n InStream.Position := 0;\r\n repeat\r\n Count := InStream.Read(Buf1, 1024);\r\n Count2 := 0;\r\n I := 0;\r\n while I < Count do\r\n begin\r\n B := Buf1[I];\r\n Count3 := 0;\r\n while (Buf1[I] = B) and (I < Count) and (Count3 < $30) do\r\n begin\r\n Inc(I);\r\n Inc(Count3);\r\n end;\r\n if (I = Count) and (Count3 in [2..$2F]) and (Count = 1024) then\r\n InStream.Position := InStream.Position - Count3\r\n else\r\n begin\r\n if Count3 = 1 then\r\n begin\r\n if (B and $C0) = $C0 then\r\n begin\r\n Buf2[Count2] := $C1;\r\n Buf2[Count2 + 1] := B;\r\n Inc(Count2, 2);\r\n end\r\n else\r\n begin\r\n Buf2[Count2] := B;\r\n Inc(Count2);\r\n end;\r\n end\r\n else\r\n begin\r\n Buf2[Count2] := Count3 or $C0;\r\n Buf2[Count2 + 1] := B;\r\n Inc(Count2, 2);\r\n end;\r\n end;\r\n end;\r\n OutStream.Write(Buf2, Count2);\r\n until Count <> 1024;\r\nend;\r\n\r\nprocedure RleDecompressTo(InStream, OutStream: TStream);\r\nvar\r\n Count, Count2, Count3, I: Integer;\r\n Buf1: array [0..1024] of Byte;\r\n Buf2: array [0..60000] of Byte;\r\n B: Byte;\r\nbegin\r\n InStream.Position := 0;\r\n repeat\r\n Count := InStream.Read(Buf1, 1024);\r\n Count2 := 0;\r\n I := 0;\r\n while I < Count do\r\n begin\r\n if (Buf1[I] and $C0) = $C0 then\r\n begin\r\n if I = Count - 1 then\r\n InStream.Position := InStream.Position - 1\r\n else\r\n begin\r\n B := Buf1[I] and $3F;\r\n Inc(I);\r\n for Count3 := Count2 to Count2 + B - 1 do\r\n Buf2[Count3] := Buf1[I];\r\n Count2 := Count2 + B;\r\n end;\r\n end\r\n else\r\n begin\r\n Buf2[Count2] := Buf1[I];\r\n Inc(Count2);\r\n end;\r\n Inc(I);\r\n end;\r\n OutStream.Write(Buf2, Count2);\r\n until Count <> 1024;\r\nend;\r\n\r\nprocedure RleCompress(Stream: TStream);\r\nvar\r\n Tmp: TMemoryStream;\r\nbegin\r\n Tmp := TMemoryStream.Create;\r\n try\r\n RleCompressTo(Stream, Tmp);\r\n Tmp.Position := 0;\r\n Stream.Size := 0;\r\n Stream.CopyFrom(Tmp, 0);\r\n finally\r\n Tmp.Free;\r\n end;\r\nend;\r\n\r\nprocedure RleDecompress(Stream: TStream);\r\nvar\r\n Tmp: TMemoryStream;\r\nbegin\r\n Tmp := TMemoryStream.Create;\r\n try\r\n RleDecompressTo(Stream, Tmp);\r\n Tmp.Position := 0;\r\n Stream.Size := 0;\r\n Stream.CopyFrom(Tmp, 0);\r\n finally\r\n Tmp.Free;\r\n end;\r\nend;\r\n{ end JvRLE }\r\n\r\n{ begin JvDateUtil }\r\n\r\nfunction IsLeapYear(AYear: Integer): Boolean;\r\nbegin\r\n Result := (AYear mod 4 = 0) and ((AYear mod 100 <> 0) or (AYear mod 400 = 0));\r\nend;\r\n\r\nfunction DaysInAMonth(const AYear, AMonth: Word): Word;\r\nbegin\r\n Result := MonthDays[(AMonth = 2) and IsLeapYear(AYear), AMonth];\r\nend;\r\n\r\nfunction DaysPerMonth(AYear, AMonth: Integer): Integer;\r\nbegin\r\n Result := DaysInAMonth(AYear, AMonth);\r\nend;\r\n\r\nfunction FirstDayOfNextMonth: TDateTime;\r\nvar\r\n Year, Month, Day: Word;\r\nbegin\r\n DecodeDate(Date, Year, Month, Day);\r\n Day := 1;\r\n if Month < 12 then\r\n Inc(Month)\r\n else\r\n begin\r\n Inc(Year);\r\n Month := 1;\r\n end;\r\n Result := EncodeDate(Year, Month, Day);\r\nend;\r\n\r\nfunction FirstDayOfPrevMonth: TDateTime;\r\nvar\r\n Year, Month, Day: Word;\r\nbegin\r\n DecodeDate(Date, Year, Month, Day);\r\n Day := 1;\r\n if Month > 1 then\r\n Dec(Month)\r\n else\r\n begin\r\n Dec(Year);\r\n Month := 12;\r\n end;\r\n Result := EncodeDate(Year, Month, Day);\r\nend;\r\n\r\nfunction LastDayOfPrevMonth: TDateTime;\r\nvar\r\n D: TDateTime;\r\n Year, Month, Day: Word;\r\nbegin\r\n D := FirstDayOfPrevMonth;\r\n DecodeDate(D, Year, Month, Day);\r\n Day := DaysPerMonth(Year, Month);\r\n Result := EncodeDate(Year, Month, Day);\r\nend;\r\n\r\nfunction ExtractDay(ADate: TDateTime): Word;\r\nvar\r\n M, Y: Word;\r\nbegin\r\n DecodeDate(ADate, Y, M, Result);\r\nend;\r\n\r\nfunction ExtractMonth(ADate: TDateTime): Word;\r\nvar\r\n D, Y: Word;\r\nbegin\r\n DecodeDate(ADate, Y, Result, D);\r\nend;\r\n\r\nfunction ExtractYear(ADate: TDateTime): Word;\r\nvar\r\n D, M: Word;\r\nbegin\r\n DecodeDate(ADate, Result, M, D);\r\nend;\r\n\r\nfunction IncDate(ADate: TDateTime; Days, Months, Years: Integer): TDateTime;\r\nvar\r\n D, M, Y: Word;\r\n Day, Month, Year: Longint;\r\nbegin\r\n DecodeDate(ADate, Y, M, D);\r\n Year := Y;\r\n Month := M;\r\n Day := D;\r\n Inc(Year, Years);\r\n Inc(Year, Months div 12);\r\n Inc(Month, Months mod 12);\r\n if Month < 1 then\r\n begin\r\n Inc(Month, 12);\r\n Dec(Year);\r\n end\r\n else\r\n if Month > 12 then\r\n begin\r\n Dec(Month, 12);\r\n Inc(Year);\r\n end;\r\n if Day > DaysPerMonth(Year, Month) then\r\n Day := DaysPerMonth(Year, Month);\r\n Result := EncodeDate(Year, Month, Day) + Days + Frac(ADate);\r\nend;\r\n\r\nprocedure DateDiff(Date1, Date2: TDateTime; var Days, Months, Years: Word);\r\n{ Corrected by Anatoly A. Sanko (2:450/73) }\r\nvar\r\n DtSwap: TDateTime;\r\n Day1, Day2, Month1, Month2, Year1, Year2: Word;\r\nbegin\r\n if Date1 > Date2 then\r\n begin\r\n DtSwap := Date1;\r\n Date1 := Date2;\r\n Date2 := DtSwap;\r\n end;\r\n DecodeDate(Date1, Year1, Month1, Day1);\r\n DecodeDate(Date2, Year2, Month2, Day2);\r\n Years := Year2 - Year1;\r\n Months := 0;\r\n Days := 0;\r\n if Month2 < Month1 then\r\n begin\r\n Inc(Months, 12);\r\n Dec(Years);\r\n end;\r\n Inc(Months, Month2 - Month1);\r\n if Day2 < Day1 then\r\n begin\r\n Inc(Days, DaysPerMonth(Year1, Month1));\r\n if Months = 0 then\r\n begin\r\n Dec(Years);\r\n Months := 11;\r\n end\r\n else\r\n Dec(Months);\r\n end;\r\n Inc(Days, Day2 - Day1);\r\nend;\r\n\r\nfunction IncDay(ADate: TDateTime; Delta: Integer): TDateTime;\r\nbegin\r\n Result := ADate + Delta;\r\nend;\r\n\r\nfunction IncMonth(ADate: TDateTime; Delta: Integer): TDateTime;\r\nbegin\r\n Result := IncDate(ADate, 0, Delta, 0);\r\nend;\r\n\r\nfunction IncYear(ADate: TDateTime; Delta: Integer): TDateTime;\r\nbegin\r\n Result := IncDate(ADate, 0, 0, Delta);\r\nend;\r\n\r\nfunction MonthsBetween(Date1, Date2: TDateTime): Double;\r\nvar\r\n D, M, Y: Word;\r\nbegin\r\n DateDiff(Date1, Date2, D, M, Y);\r\n Result := 12 * Y + M;\r\n if (D > 1) and (D < 7) then\r\n Result := Result + 0.25\r\n else\r\n if (D >= 7) and (D < 15) then\r\n Result := Result + 0.5\r\n else\r\n if (D >= 15) and (D < 21) then\r\n Result := Result + 0.75\r\n else\r\n if D >= 21 then\r\n Result := Result + 1;\r\nend;\r\n\r\nfunction IsValidDate(Y, M, D: Word): Boolean;\r\nbegin\r\n Result := (Y >= 1) and (Y <= 9999) and (M >= 1) and (M <= 12) and\r\n (D >= 1) and (D <= DaysPerMonth(Y, M));\r\nend;\r\n\r\nfunction ValidDate(ADate: TDateTime): Boolean;\r\nvar\r\n Year, Month, Day: Word;\r\nbegin\r\n try\r\n DecodeDate(ADate, Year, Month, Day);\r\n Result := IsValidDate(Year, Month, Day);\r\n except\r\n Result := False;\r\n end;\r\nend;\r\n\r\nfunction DaysInPeriod(Date1, Date2: TDateTime): Longint;\r\nbegin\r\n if ValidDate(Date1) and ValidDate(Date2) then\r\n Result := Abs(Trunc(Date2) - Trunc(Date1)) + 1\r\n else\r\n Result := 0;\r\nend;\r\n\r\n{ // (ahuser) wrong implementation\r\nfunction DaysBetween(Date1, Date2: TDateTime): Longint;\r\nbegin\r\n Result := Trunc(Date2) - Trunc(Date1) + 1;\r\n if Result < 0 then\r\n Result := 0;\r\nend;}\r\n\r\nfunction DaysBetween(Date1, Date2: TDateTime): Longint;\r\nbegin\r\n if Date1 < Date2 then\r\n Result := Trunc(Date2 - Date1)\r\n else\r\n Result := Trunc(Date1 - Date2);\r\nend;\r\n\r\nfunction IncTime(ATime: TDateTime; Hours, Minutes, Seconds,\r\n MSecs: Integer): TDateTime;\r\nbegin\r\n Result := ATime + (Hours div 24) + (((Hours mod 24) * 3600000 +\r\n Minutes * 60000 + Seconds * 1000 + MSecs) / MSecsPerDay);\r\n if Result < 0 then\r\n Result := Result + 1;\r\nend;\r\n\r\nfunction IncHour(ATime: TDateTime; Delta: Integer): TDateTime;\r\nbegin\r\n Result := IncTime(ATime, Delta, 0, 0, 0);\r\nend;\r\n\r\nfunction IncMinute(ATime: TDateTime; Delta: Integer): TDateTime;\r\nbegin\r\n Result := IncTime(ATime, 0, Delta, 0, 0);\r\nend;\r\n\r\nfunction IncSecond(ATime: TDateTime; Delta: Integer): TDateTime;\r\nbegin\r\n Result := IncTime(ATime, 0, 0, Delta, 0);\r\nend;\r\n\r\nfunction IncMSec(ATime: TDateTime; Delta: Integer): TDateTime;\r\nbegin\r\n Result := IncTime(ATime, 0, 0, 0, Delta);\r\nend;\r\n\r\nfunction CutTime(ADate: TDateTime): TDateTime;\r\nbegin\r\n Result := Trunc(ADate);\r\nend;\r\n\r\nfunction CurrentYear: Word;\r\nbegin\r\n Result := ExtractYear(Date);\r\nend;\r\n\r\n{ String to date conversions. Copied from SYSUTILS.PAS unit. }\r\n\r\nprocedure ScanBlanks(const S: string; var Pos: Integer);\r\nvar\r\n I: Integer;\r\nbegin\r\n I := Pos;\r\n while (I <= Length(S)) and (S[I] = ' ') do\r\n Inc(I);\r\n Pos := I;\r\nend;\r\n\r\nfunction ScanNumber(const S: string; MaxLength: Integer; var Pos: Integer;\r\n var Number: Longint): Boolean;\r\nvar\r\n I: Integer;\r\n N: Word;\r\nbegin\r\n Result := False;\r\n ScanBlanks(S, Pos);\r\n I := Pos;\r\n N := 0;\r\n while (I <= Length(S)) and (Longint(I - Pos) < MaxLength) and\r\n CharInSet(S[I], ['0'..'9']) and (N < 1000) do\r\n begin\r\n N := N * 10 + (Ord(S[I]) - Ord('0'));\r\n Inc(I);\r\n end;\r\n if I > Pos then\r\n begin\r\n Pos := I;\r\n Number := N;\r\n Result := True;\r\n end;\r\nend;\r\n\r\nfunction ScanChar(const S: string; var Pos: Integer; Ch: Char): Boolean;\r\nbegin\r\n Result := False;\r\n ScanBlanks(S, Pos);\r\n if (Pos <= Length(S)) and (S[Pos] = Ch) then\r\n begin\r\n Inc(Pos);\r\n Result := True;\r\n end;\r\nend;\r\n\r\nprocedure ScanToNumber(const S: string; var Pos: Integer);\r\nbegin\r\n while (Pos <= Length(S)) and not CharInSet(S[Pos], ['0'..'9']) do\r\n begin\r\n {$IFNDEF UNICODE} // Utf16: '0'..'9' are in the BMP => no lead byte handling necessary\r\n if S[Pos] in LeadBytes then\r\n Inc(Pos);\r\n {$ENDIF ~UNICODE}\r\n Inc(Pos);\r\n end;\r\nend;\r\n\r\nfunction GetDateOrder(const DateFormat: string): TDateOrder;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := DefaultDateOrder;\r\n I := 1;\r\n while I <= Length(DateFormat) do\r\n begin\r\n case Chr(Ord(DateFormat[I]) and $DF) of\r\n 'E':\r\n Result := doYMD;\r\n 'Y':\r\n Result := doYMD;\r\n 'M':\r\n Result := doMDY;\r\n 'D':\r\n Result := doDMY;\r\n else\r\n Inc(I);\r\n Continue;\r\n end;\r\n Exit;\r\n end;\r\nend;\r\n\r\nfunction CurrentMonth: Word;\r\nbegin\r\n Result := ExtractMonth(Date);\r\nend;\r\n\r\n{Modified}\r\n\r\nfunction ExpandYear(Year: Integer): Integer;\r\nvar\r\n N: Longint;\r\nbegin\r\n if Year = -1 then\r\n Result := CurrentYear\r\n else\r\n begin\r\n Result := Year;\r\n if Result < 100 then\r\n begin\r\n N := CurrentYear - CenturyOffset;\r\n Inc(Result, N div 100 * 100);\r\n if (CenturyOffset > 0) and (Result < N) then\r\n Inc(Result, 100);\r\n end;\r\n end;\r\nend;\r\n\r\nfunction ScanDate(const S, DateFormat: string; var Position: Integer;\r\n var Y, M, D: Integer): Boolean;\r\nvar\r\n DateOrder: TDateOrder;\r\n N1, N2, N3: Longint;\r\nbegin\r\n Result := False;\r\n Y := 0;\r\n M := 0;\r\n D := 0;\r\n DateOrder := GetDateOrder(DateFormat);\r\n if JclFormatSettings.ShortDateFormat[1] = 'g' then { skip over prefix text }\r\n ScanToNumber(S, Position);\r\n if not (ScanNumber(S, MaxInt, Position, N1) and ScanChar(S, Position, JclFormatSettings.DateSeparator) and\r\n ScanNumber(S, MaxInt, Position, N2)) then\r\n Exit;\r\n if ScanChar(S, Position, JclFormatSettings.DateSeparator) then\r\n begin\r\n if not ScanNumber(S, MaxInt, Position, N3) then\r\n Exit;\r\n case DateOrder of\r\n doMDY:\r\n begin\r\n Y := N3;\r\n M := N1;\r\n D := N2;\r\n end;\r\n doDMY:\r\n begin\r\n Y := N3;\r\n M := N2;\r\n D := N1;\r\n end;\r\n doYMD:\r\n begin\r\n Y := N1;\r\n M := N2;\r\n D := N3;\r\n end;\r\n end;\r\n Y := ExpandYear(Y);\r\n end\r\n else\r\n begin\r\n Y := CurrentYear;\r\n if DateOrder = doDMY then\r\n begin\r\n D := N1;\r\n M := N2;\r\n end\r\n else\r\n begin\r\n M := N1;\r\n D := N2;\r\n end;\r\n end;\r\n ScanChar(S, Position, JclFormatSettings.DateSeparator);\r\n ScanBlanks(S, Position);\r\n if SysLocale.FarEast and (Pos('ddd', JclFormatSettings.ShortDateFormat) <> 0) then\r\n begin { ignore trailing text }\r\n if CharInSet(JclFormatSettings.ShortTimeFormat[1], ['0'..'9']) then { stop at time digit }\r\n ScanToNumber(S, Position)\r\n else { stop at time prefix }\r\n repeat\r\n while (Position <= Length(S)) and (S[Position] <> ' ') do\r\n Inc(Position);\r\n ScanBlanks(S, Position);\r\n until (Position > Length(S)) or\r\n AnsiSameText(JclFormatSettings.TimeAMString, Copy(S, Position, Length(JclFormatSettings.TimeAMString))) or\r\n AnsiSameText(JclFormatSettings.TimePMString, Copy(S, Position, Length(JclFormatSettings.TimePMString)));\r\n end;\r\n Result := IsValidDate(Y, M, D) and (Position > Length(S));\r\nend;\r\n\r\nfunction MonthFromName(const S: string; MaxLen: Byte): Byte;\r\nbegin\r\n if Length(S) > 0 then\r\n for Result := 1 to 12 do\r\n begin\r\n if (Length(JclFormatSettings.LongMonthNames[Result]) > 0) and\r\n AnsiSameText(Copy(S, 1, MaxLen), Copy(JclFormatSettings.LongMonthNames[Result], 1, MaxLen)) then\r\n Exit;\r\n end;\r\n Result := 0;\r\nend;\r\n\r\nprocedure ExtractMask(const Format, S: string; Ch: Char; Cnt: Integer;\r\n var I: Integer; Blank, Default: Integer);\r\nvar\r\n Tmp: string;\r\n J, L: Integer;\r\nbegin\r\n I := Default;\r\n Ch := UpCase(Ch);\r\n L := Length(Format);\r\n if Length(S) < L then\r\n L := Length(S)\r\n else\r\n if Length(S) > L then\r\n Exit;\r\n J := Pos(MakeStr(Ch, Cnt), AnsiUpperCase(Format));\r\n if J <= 0 then\r\n Exit;\r\n Tmp := '';\r\n while (UpCase(Format[J]) = Ch) and (J <= L) do\r\n begin\r\n if S[J] <> ' ' then\r\n Tmp := Tmp + S[J];\r\n Inc(J);\r\n end;\r\n if Tmp = '' then\r\n I := Blank\r\n else\r\n if Cnt > 1 then\r\n begin\r\n I := MonthFromName(Tmp, Length(Tmp));\r\n if I = 0 then\r\n I := -1;\r\n end\r\n else\r\n I := StrToIntDef(Tmp, -1);\r\nend;\r\n\r\nfunction ScanDateStr(const Format, S: string; var D, M, Y: Integer): Boolean;\r\nvar\r\n Pos: Integer;\r\nbegin\r\n ExtractMask(Format, S, 'm', 3, M, -1, 0); { short month name? }\r\n if M = 0 then\r\n ExtractMask(Format, S, 'm', 1, M, -1, 0);\r\n ExtractMask(Format, S, 'd', 1, D, -1, 1);\r\n ExtractMask(Format, S, 'y', 1, Y, -1, CurrentYear);\r\n if M = -1 then\r\n M := CurrentMonth;\r\n Y := ExpandYear(Y);\r\n Result := IsValidDate(Y, M, D);\r\n if not Result then\r\n begin\r\n Pos := 1;\r\n Result := ScanDate(S, Format, Pos, Y, M, D);\r\n end;\r\nend;\r\n\r\nfunction InternalStrToDate(const DateFormat, S: string;\r\n var Date: TDateTime): Boolean;\r\nvar\r\n D, M, Y: Integer;\r\nbegin\r\n if S = '' then\r\n begin\r\n Date := NullDate;\r\n Result := True;\r\n end\r\n else\r\n begin\r\n Result := ScanDateStr(DateFormat, S, D, M, Y);\r\n if Result then\r\n try\r\n Date := EncodeDate(Y, M, D);\r\n except\r\n Result := False;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction StrToDateFmt(const DateFormat, S: string): TDateTime;\r\nbegin\r\n if not InternalStrToDate(DateFormat, S, Result) then\r\n raise EConvertError.CreateResFmt(@SInvalidDate, [S]);\r\nend;\r\n\r\nfunction StrToDateDef(const S: string; Default: TDateTime): TDateTime;\r\nbegin\r\n if not InternalStrToDate(JclFormatSettings.ShortDateFormat, S, Result) then\r\n Result := Trunc(Default);\r\nend;\r\n\r\nfunction StrToDateFmtDef(const DateFormat, S: string; Default: TDateTime): TDateTime;\r\nbegin\r\n if not InternalStrToDate(DateFormat, S, Result) then\r\n Result := Trunc(Default);\r\nend;\r\n\r\nfunction DefDateFormat(AFourDigitYear: Boolean): string;\r\nbegin\r\n if AFourDigitYear then\r\n begin\r\n case GetDateOrder(JclFormatSettings.ShortDateFormat) of\r\n doMDY:\r\n Result := 'MM/DD/YYYY';\r\n doDMY:\r\n Result := 'DD/MM/YYYY';\r\n doYMD:\r\n Result := 'YYYY/MM/DD';\r\n end;\r\n end\r\n else\r\n begin\r\n case GetDateOrder(JclFormatSettings.ShortDateFormat) of\r\n doMDY:\r\n Result := 'MM/DD/YY';\r\n doDMY:\r\n Result := 'DD/MM/YY';\r\n doYMD:\r\n Result := 'YY/MM/DD';\r\n end;\r\n end;\r\nend;\r\n\r\nfunction DefDateMask(BlanksChar: Char; AFourDigitYear: Boolean): string;\r\nbegin\r\n if AFourDigitYear then\r\n begin\r\n case GetDateOrder(JclFormatSettings.ShortDateFormat) of\r\n doMDY, doDMY:\r\n Result := '!99/99/9999;1;';\r\n doYMD:\r\n Result := '!9999/99/99;1;';\r\n end;\r\n end\r\n else\r\n begin\r\n case GetDateOrder(JclFormatSettings.ShortDateFormat) of\r\n doMDY, doDMY:\r\n Result := '!99/99/99;1;';\r\n doYMD:\r\n Result := '!99/99/99;1;';\r\n end;\r\n end;\r\n if Result <> '' then\r\n Result := Result + BlanksChar;\r\nend;\r\n\r\nfunction FormatLongDate(Value: TDateTime): string;\r\n{$IFDEF MSWINDOWS}\r\nvar\r\n Buffer: array [0..1023] of Char;\r\n SystemTime: TSystemTime;\r\nbegin\r\n DateTimeToSystemTime(Value, SystemTime);\r\n SetString(Result, Buffer, GetDateFormat(GetThreadLocale, DATE_LONGDATE,\r\n @SystemTime, nil, Buffer, SizeOf(Buffer) - 1));\r\n Result := TrimRight(Result);\r\nend;\r\n{$ENDIF MSWINDOWS}\r\n{$IFDEF UNIX}\r\nbegin\r\n Result := TrimRight(FormatDateTime(LongDateFormat, Value));\r\nend;\r\n{$ENDIF UNIX}\r\n\r\nfunction FormatLongDateTime(Value: TDateTime): string;\r\nbegin\r\n if Value <> NullDate then\r\n Result := FormatLongDate(Value) + FormatDateTime(' tt', Value)\r\n else\r\n Result := '';\r\nend;\r\n\r\nfunction FourDigitYear: Boolean; // deprecated\r\nbegin\r\n Result := IsFourDigitYear;\r\nend;\r\n\r\nfunction IsFourDigitYear: Boolean;\r\nbegin\r\n Result := Pos('YYYY', AnsiUpperCase(JclFormatSettings.ShortDateFormat)) > 0;\r\nend;\r\n{ end JvDateUtil }\r\n\r\nfunction BufToBinStr(Buf: Pointer; BufSize: Integer): string;\r\nvar\r\n I: Integer;\r\n P: PByteArray;\r\nbegin\r\n P := Buf;\r\n for I := 0 to Pred(BufSize) do\r\n Result := Result + IntToHex(P[I] , 2);\r\nend;\r\n\r\nfunction BinStrToBuf(Value: string; Buf: Pointer; BufSize: Integer): Integer;\r\nvar\r\n I: Integer;\r\n P: PByteArray;\r\nbegin\r\n if Odd(Length(Value)) then\r\n Value := '0' + Value; // should not occur, might indicate corrupted Value\r\n if (Length(Value) div 2) < BufSize then\r\n BufSize := Length(Value) div 2;\r\n P := Buf;\r\n for I := 0 to Pred(BufSize) do\r\n P[I] := StrToInt('$' + Value[2 * I + 1] + Value[2 * I + 2]);\r\n Result := BufSize;\r\nend;\r\n\r\n{ begin JvStrUtils }\r\n{$IFDEF UNIX}\r\n\r\nfunction iconversion(InP: PAnsiChar; OutP: Pointer; InBytes, OutBytes: Cardinal;\r\n const ToCode, FromCode: AnsiString): Boolean;\r\nvar\r\n conv: iconv_t;\r\nbegin\r\n Result := False;\r\n if (InBytes > 0) and (OutBytes > 0) and (InP <> nil) and (OutP <> nil) then\r\n begin\r\n conv := iconv_open(PAnsiChar(ToCode), PAnsiChar(FromCode));\r\n if Integer(conv) <> -1 then\r\n begin\r\n if Integer(iconv(conv, InP, InBytes, OutP, OutBytes)) <> -1 then\r\n Result := True;\r\n iconv_close(conv);\r\n end;\r\n end;\r\nend;\r\n\r\nfunction iconvString(const S, ToCode, FromCode: AnsiString): AnsiString;\r\nbegin\r\n SetLength(Result, Length(S));\r\n if not iconversion(PAnsiChar(S), Pointer(Result),\r\n Length(S), Length(Result),\r\n ToCode, FromCode) then\r\n Result := S;\r\nend;\r\n\r\nfunction iconvWideString(const S: WideString; const ToCode, FromCode: AnsiString): WideString;\r\nbegin\r\n SetLength(Result, Length(S));\r\n if not iconversion(Pointer(S), Pointer(Result),\r\n Length(S) * SizeOf(WideChar), Length(Result) * SizeOf(WideChar),\r\n ToCode, FromCode) then\r\n Result := S;\r\nend;\r\n\r\nfunction OemStrToAnsi(const S: AnsiString): AnsiString;\r\nbegin\r\n Result := iconvString(S, 'WINDOWS-1252', 'CP850');\r\nend;\r\n\r\nfunction AnsiStrToOem(const S: AnsiString): AnsiString;\r\nbegin\r\n Result := iconvString(S, 'CP850', 'WINDOWS-1250');\r\nend;\r\n\r\n{$ENDIF UNIX}\r\n\r\nfunction StrToOem(const AnsiStr: AnsiString): AnsiString;\r\nbegin\r\n {$IFDEF MSWINDOWS}\r\n SetLength(Result, Length(AnsiStr));\r\n if Result <> '' then\r\n CharToOemBuffA(PAnsiChar(AnsiStr), PAnsiChar(Result), Length(Result));\r\n {$ENDIF MSWINDOWS}\r\n {$IFDEF UNIX}\r\n Result := AnsiStrToOem(AnsiStr);\r\n {$ENDIF UNIX}\r\nend;\r\n\r\nfunction OemToAnsiStr(const OemStr: AnsiString): AnsiString;\r\nbegin\r\n {$IFDEF MSWINDOWS}\r\n SetLength(Result, Length(OemStr));\r\n if Length(Result) > 0 then\r\n OemToCharBuffA(PAnsiChar(OemStr), PAnsiChar(Result), Length(Result));\r\n {$ENDIF MSWINDOWS}\r\n {$IFDEF UNIX}\r\n Result := OemStrToAnsi(OemStr);\r\n {$ENDIF UNIX}\r\nend;\r\n\r\nfunction IsEmptyStr(const S: string; const EmptyChars: TSysCharSet): Boolean;\r\nvar\r\n I, SLen: Integer;\r\nbegin\r\n SLen := Length(S);\r\n I := 1;\r\n while I <= SLen do\r\n begin\r\n if not CharInSet(S[I], EmptyChars) then\r\n begin\r\n Result := False;\r\n Exit;\r\n end\r\n else\r\n Inc(I);\r\n end;\r\n Result := True;\r\nend;\r\n\r\nfunction ReplaceStr(const S, Srch, Replace: string): string;\r\nvar\r\n I: Integer;\r\n Source: string;\r\nbegin\r\n Source := S;\r\n Result := '';\r\n repeat\r\n I := Pos(Srch, Source);\r\n if I > 0 then\r\n begin\r\n Result := Result + Copy(Source, 1, I - 1) + Replace;\r\n Source := Copy(Source, I + Length(Srch), MaxInt);\r\n end\r\n else\r\n Result := Result + Source;\r\n until I <= 0;\r\nend;\r\n\r\nfunction DelSpace(const S: string): string;\r\nbegin\r\n Result := DelChars(S, ' ');\r\nend;\r\n\r\nfunction DelChars(const S: string; Chr: Char): string;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := S;\r\n for I := Length(Result) downto 1 do\r\n begin\r\n if Result[I] = Chr then\r\n Delete(Result, I, 1);\r\n end;\r\nend;\r\n\r\nfunction DelBSpace(const S: string): string;\r\nvar\r\n I, L: Integer;\r\nbegin\r\n L := Length(S);\r\n I := 1;\r\n while (I <= L) and (S[I] = ' ') do\r\n Inc(I);\r\n Result := Copy(S, I, MaxInt);\r\nend;\r\n\r\nfunction DelESpace(const S: string): string;\r\nvar\r\n I: Integer;\r\nbegin\r\n I := Length(S);\r\n while (I > 0) and (S[I] = ' ') do\r\n Dec(I);\r\n Result := Copy(S, 1, I);\r\nend;\r\n\r\nfunction DelRSpace(const S: string): string;\r\nbegin\r\n Result := DelBSpace(DelESpace(S));\r\nend;\r\n\r\nfunction DelSpace1(const S: string): string;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := S;\r\n for I := Length(Result) downto 2 do\r\n begin\r\n if (Result[I] = ' ') and (Result[I - 1] = ' ') then\r\n Delete(Result, I, 1);\r\n end;\r\nend;\r\n\r\nfunction Tab2Space(const S: string; Numb: Byte): string;\r\nvar\r\n I: Integer;\r\nbegin\r\n I := 1;\r\n Result := S;\r\n while I <= Length(Result) do\r\n begin\r\n if Result[I] = Chr(9) then\r\n begin\r\n Delete(Result, I, 1);\r\n Insert(MakeStr(' ', Numb), Result, I);\r\n Inc(I, Numb);\r\n end\r\n else\r\n Inc(I);\r\n end;\r\nend;\r\n\r\nfunction MakeStr(C: Char; N: Integer): string; overload;\r\nbegin\r\n if N < 1 then\r\n Result := ''\r\n else\r\n begin\r\n SetLength(Result, N);\r\n FillString(Result, Length(Result), C);\r\n end;\r\nend;\r\n\r\n{$IFNDEF COMPILER12_UP}\r\nfunction MakeStr(C: WideChar; N: Integer): WideString; overload;\r\nbegin\r\n if N < 1 then\r\n Result := ''\r\n else\r\n begin\r\n SetLength(Result, N);\r\n FillWideChar(Result[1], Length(Result), C);\r\n end;\r\nend;\r\n{$ENDIF !COMPILER12_UP}\r\n\r\nfunction MS(C: Char; N: Integer): string;\r\nbegin\r\n Result := MakeStr(C, N);\r\nend;\r\n\r\nfunction NPos(const C: string; S: string; N: Integer): Integer;\r\nvar\r\n I, P, K: Integer;\r\nbegin\r\n Result := 0;\r\n K := 0;\r\n for I := 1 to N do\r\n begin\r\n P := Pos(C, S);\r\n Inc(K, P);\r\n if (I = N) and (P > 0) then\r\n begin\r\n Result := K;\r\n Exit;\r\n end;\r\n if P > 0 then\r\n Delete(S, 1, P)\r\n else\r\n Exit;\r\n end;\r\nend;\r\n\r\nfunction AddChar(C: Char; const S: string; N: Integer): string;\r\nbegin\r\n if Length(S) < N then\r\n Result := MakeStr(C, N - Length(S)) + S\r\n else\r\n Result := S;\r\nend;\r\n\r\nfunction AddCharR(C: Char; const S: string; N: Integer): string;\r\nbegin\r\n if Length(S) < N then\r\n Result := S + MakeStr(C, N - Length(S))\r\n else\r\n Result := S;\r\nend;\r\n\r\nfunction LeftStr(const S: string; N: Integer): string;\r\nbegin\r\n Result := AddCharR(' ', S, N);\r\nend;\r\n\r\nfunction RightStr(const S: string; N: Integer): string;\r\nbegin\r\n Result := AddChar(' ', S, N);\r\nend;\r\n\r\n{$IFDEF MSWINDOWS}\r\n\r\nfunction CompStr(const S1, S2: string): Integer;\r\nbegin\r\n Result := CompareString(GetThreadLocale, SORT_STRINGSORT, PChar(S1),\r\n Length(S1), PChar(S2), Length(S2)) - 2;\r\nend;\r\n\r\nfunction CompText(const S1, S2: string): Integer;\r\nbegin\r\n Result := CompareString(GetThreadLocale, SORT_STRINGSORT or NORM_IGNORECASE,\r\n PChar(S1), Length(S1), PChar(S2), Length(S2)) - 2;\r\nend;\r\n\r\n{$ENDIF MSWINDOWS}\r\n\r\n{$IFDEF UNIX}\r\n\r\nfunction CompStr(const S1, S2: string): Integer;\r\nbegin\r\n Result := AnsiCompareStr(S1, S2);\r\nend;\r\n\r\nfunction CompText(const S1, S2: string): Integer;\r\nbegin\r\n Result := AnsiCompareText(S1, S2);\r\nend;\r\n\r\n{$ENDIF UNIX}\r\n\r\nfunction Copy2Symb(const S: string; Symb: Char): string;\r\nvar\r\n P: Integer;\r\nbegin\r\n P := Pos(Symb, S);\r\n if P = 0 then\r\n P := Length(S) + 1;\r\n Result := Copy(S, 1, P - 1);\r\nend;\r\n\r\nfunction Copy2SymbDel(var S: string; Symb: Char): string;\r\nbegin\r\n Result := Copy2Symb(S, Symb);\r\n S := DelBSpace(Copy(S, Length(Result) + 1, Length(S)));\r\nend;\r\n\r\nfunction Copy2Space(const S: string): string;\r\nbegin\r\n Result := Copy2Symb(S, ' ');\r\nend;\r\n\r\nfunction Copy2SpaceDel(var S: string): string;\r\nbegin\r\n Result := Copy2SymbDel(S, ' ');\r\nend;\r\n\r\nfunction AnsiProperCase(const S: string; const WordDelims: TSysCharSet): string;\r\nvar\r\n SLen, I: Cardinal;\r\nbegin\r\n Result := AnsiLowerCase(S);\r\n I := 1;\r\n SLen := Length(Result);\r\n while I <= SLen do\r\n begin\r\n while (I <= SLen) and CharInSet(Result[I], WordDelims) do\r\n Inc(I);\r\n if I <= SLen then\r\n Result[I] := AnsiUpperCase(Result[I])[1];\r\n while (I <= SLen) and not CharInSet(Result[I], WordDelims) do\r\n Inc(I);\r\n end;\r\nend;\r\n\r\nfunction WordCount(const S: string; const WordDelims: TSysCharSet): Integer;\r\nvar\r\n SLen, I: Cardinal;\r\nbegin\r\n Result := 0;\r\n I := 1;\r\n SLen := Length(S);\r\n while I <= SLen do\r\n begin\r\n while (I <= SLen) and CharInSet(S[I], WordDelims) do\r\n Inc(I);\r\n if I <= SLen then\r\n Inc(Result);\r\n while (I <= SLen) and not CharInSet(S[I], WordDelims) do\r\n Inc(I);\r\n end;\r\nend;\r\n\r\nfunction WordPosition(const N: Integer; const S: string;\r\n const WordDelims: TSysCharSet): Integer;\r\nvar\r\n Count, I: Integer;\r\nbegin\r\n Count := 0;\r\n I := 1;\r\n Result := 0;\r\n while (I <= Length(S)) and (Count <> N) do\r\n begin\r\n { skip over delimiters }\r\n while (I <= Length(S)) and CharInSet(S[I], WordDelims) do\r\n Inc(I);\r\n { if we're not beyond end of S, we're at the start of a word }\r\n if I <= Length(S) then\r\n Inc(Count);\r\n { if not finished, find the end of the current word }\r\n if Count <> N then\r\n while (I <= Length(S)) and not CharInSet(S[I], WordDelims) do\r\n Inc(I)\r\n else\r\n Result := I;\r\n end;\r\nend;\r\n\r\nfunction ExtractWord(N: Integer; const S: string;\r\n const WordDelims: TSysCharSet): string;\r\nvar\r\n I: Integer;\r\n Len: Integer;\r\nbegin\r\n Len := 0;\r\n I := WordPosition(N, S, WordDelims);\r\n if I <> 0 then\r\n { find the end of the current word }\r\n while (I <= Length(S)) and not CharInSet(S[I], WordDelims) do\r\n begin\r\n { add the I'th character to result }\r\n Inc(Len);\r\n SetLength(Result, Len);\r\n Result[Len] := S[I];\r\n Inc(I);\r\n end;\r\n SetLength(Result, Len);\r\nend;\r\n\r\nfunction ExtractWordPos(N: Integer; const S: string;\r\n const WordDelims: TSysCharSet; var Pos: Integer): string;\r\nvar\r\n I, Len: Integer;\r\nbegin\r\n Len := 0;\r\n I := WordPosition(N, S, WordDelims);\r\n Pos := I;\r\n if I <> 0 then\r\n { find the end of the current word }\r\n while (I <= Length(S)) and not CharInSet(S[I], WordDelims) do\r\n begin\r\n { add the I'th character to result }\r\n Inc(Len);\r\n SetLength(Result, Len);\r\n Result[Len] := S[I];\r\n Inc(I);\r\n end;\r\n SetLength(Result, Len);\r\nend;\r\n\r\nfunction ExtractDelimited(N: Integer; const S: string;\r\n const Delims: TSysCharSet): string;\r\nvar\r\n CurWord: Integer;\r\n I, Len, SLen: Integer;\r\nbegin\r\n CurWord := 0;\r\n I := 1;\r\n Len := 0;\r\n SLen := Length(S);\r\n SetLength(Result, 0);\r\n while (I <= SLen) and (CurWord <> N) do\r\n begin\r\n if CharInSet(S[I], Delims) then\r\n Inc(CurWord)\r\n else\r\n begin\r\n if CurWord = N - 1 then\r\n begin\r\n Inc(Len);\r\n SetLength(Result, Len);\r\n Result[Len] := S[I];\r\n end;\r\n end;\r\n Inc(I);\r\n end;\r\nend;\r\n\r\nfunction ExtractSubstr(const S: string; var Pos: Integer;\r\n const Delims: TSysCharSet): string;\r\nvar\r\n I: Integer;\r\nbegin\r\n I := Pos;\r\n while (I <= Length(S)) and not CharInSet(S[I], Delims) do\r\n Inc(I);\r\n Result := Copy(S, Pos, I - Pos);\r\n if (I <= Length(S)) and CharInSet(S[I], Delims) then\r\n Inc(I);\r\n Pos := I;\r\nend;\r\n\r\nfunction IsWordPresent(const W, S: string; const WordDelims: TSysCharSet): Boolean;\r\nvar\r\n Count, I: Integer;\r\nbegin\r\n Result := False;\r\n Count := WordCount(S, WordDelims);\r\n for I := 1 to Count do\r\n if ExtractWord(I, S, WordDelims) = W then\r\n begin\r\n Result := True;\r\n Exit;\r\n end;\r\nend;\r\n\r\nfunction QuotedString(const S: string; Quote: Char): string;\r\nbegin\r\n Result := AnsiQuotedStr(S, Quote);\r\nend;\r\n\r\nfunction ExtractQuotedString(const S: string; Quote: Char): string;\r\nbegin\r\n Result := DequotedStr(S, Quote);\r\nend;\r\n\r\nfunction Numb2USA(const S: string): string;\r\nvar\r\n I, NA: Integer;\r\nbegin\r\n I := Length(S);\r\n Result := S;\r\n NA := 0;\r\n while (I > 0) do\r\n begin\r\n if ((Length(Result) - I + 1 - NA) mod 3 = 0) and (I <> 1) then\r\n begin\r\n Insert(',', Result, I);\r\n Inc(NA);\r\n end;\r\n Dec(I);\r\n end;\r\nend;\r\n\r\nfunction CenterStr(const S: string; Len: Integer): string;\r\nbegin\r\n if Length(S) < Len then\r\n begin\r\n Result := MakeStr(' ', (Len div 2) - (Length(S) div 2)) + S;\r\n Result := Result + MakeStr(' ', Len - Length(Result));\r\n end\r\n else\r\n Result := S;\r\nend;\r\n\r\nfunction Dec2Hex(N: Longint; A: Byte): string;\r\nbegin\r\n Result := IntToHex(N, A);\r\nend;\r\n\r\nfunction Hex2Dec(const S: string): Longint;\r\nvar\r\n HexStr: string;\r\nbegin\r\n if Pos('$', S) = 0 then\r\n HexStr := '$' + S\r\n else\r\n HexStr := S;\r\n Result := StrToIntDef(HexStr, 0);\r\nend;\r\n\r\nfunction Dec2Numb(N: Int64; A, B: Byte): string;\r\nvar\r\n C: Integer;\r\n Number: Cardinal;\r\nbegin\r\n if N = 0 then\r\n Result := '0'\r\n else\r\n begin\r\n Number := Cardinal(N);\r\n Result := '';\r\n while Number > 0 do\r\n begin\r\n C := Number mod B;\r\n if C > 9 then\r\n C := C + 55\r\n else\r\n C := C + 48;\r\n Result := Chr(C) + Result;\r\n Number := Number div B;\r\n end;\r\n end;\r\n if Result <> '' then\r\n Result := AddChar('0', Result, A);\r\nend;\r\n\r\nfunction Numb2Dec(S: string; B: Byte): Int64;\r\nvar\r\n I, P: Int64;\r\nbegin\r\n I := Length(S);\r\n Result := 0;\r\n S := UpperCase(S);\r\n P := 1;\r\n while (I >= 1) do\r\n begin\r\n if S[I] > '@' then\r\n Result := Result + (Ord(S[I]) - 55) * P\r\n else\r\n Result := Result + (Ord(S[I]) - 48) * P;\r\n Dec(I);\r\n P := P * B;\r\n end;\r\nend;\r\n\r\nfunction RomanToInt(const S: string): Longint;\r\nconst\r\n RomanChars = ['C', 'D', 'I', 'L', 'M', 'V', 'X'];\r\n RomanValues: array ['C'..'X'] of Word =\r\n (100, 500, 0, 0, 0, 0, 1, 0, 0, 50, 1000, 0, 0, 0, 0, 0, 0, 0, 0, 5, 0, 10);\r\nvar\r\n Index, Next: Char;\r\n I: Integer;\r\n Negative: Boolean;\r\nbegin\r\n Result := 0;\r\n I := 0;\r\n Negative := (Length(S) > 0) and (S[1] = '-');\r\n if Negative then\r\n Inc(I);\r\n while (I < Length(S)) do\r\n begin\r\n Inc(I);\r\n Index := UpCase(S[I]);\r\n if CharInSet(Index, RomanChars) then\r\n begin\r\n if Succ(I) <= Length(S) then\r\n Next := UpCase(S[I + 1])\r\n else\r\n Next := #0;\r\n if CharInSet(Next, RomanChars) and (RomanValues[Index] < RomanValues[Next]) then\r\n begin\r\n Inc(Result, RomanValues[Next]);\r\n Dec(Result, RomanValues[Index]);\r\n Inc(I);\r\n end\r\n else\r\n Inc(Result, RomanValues[Index]);\r\n end\r\n else\r\n begin\r\n Result := 0;\r\n Exit;\r\n end;\r\n end;\r\n if Negative then\r\n Result := -Result;\r\nend;\r\n\r\nfunction IntToRoman(Value: Longint): string;\r\nlabel\r\n A500, A400, A100, A90, A50, A40, A10, A9, A5, A4, A1;\r\nbegin\r\n Result := '';\r\n while Value >= 1000 do\r\n begin\r\n Dec(Value, 1000);\r\n Result := Result + 'M';\r\n end;\r\n if Value < 900 then\r\n goto A500\r\n else\r\n begin\r\n Dec(Value, 900);\r\n Result := Result + 'CM';\r\n end;\r\n goto A90;\r\n A400:\r\n if Value < 400 then\r\n goto A100\r\n else\r\n begin\r\n Dec(Value, 400);\r\n Result := Result + 'CD';\r\n end;\r\n goto A90;\r\n A500:\r\n if Value < 500 then\r\n goto A400\r\n else\r\n begin\r\n Dec(Value, 500);\r\n Result := Result + 'D';\r\n end;\r\n A100:\r\n while Value >= 100 do\r\n begin\r\n Dec(Value, 100);\r\n Result := Result + 'C';\r\n end;\r\n A90:\r\n if Value < 90 then\r\n goto A50\r\n else\r\n begin\r\n Dec(Value, 90);\r\n Result := Result + 'XC';\r\n end;\r\n goto A9;\r\n A40:\r\n if Value < 40 then\r\n goto A10\r\n else\r\n begin\r\n Dec(Value, 40);\r\n Result := Result + 'XL';\r\n end;\r\n goto A9;\r\n A50:\r\n if Value < 50 then\r\n goto A40\r\n else\r\n begin\r\n Dec(Value, 50);\r\n Result := Result + 'L';\r\n end;\r\n A10:\r\n while Value >= 10 do\r\n begin\r\n Dec(Value, 10);\r\n Result := Result + 'X';\r\n end;\r\n A9:\r\n if Value < 9 then\r\n goto A5\r\n else\r\n Result := Result + 'IX';\r\n Exit;\r\n A4:\r\n if Value < 4 then\r\n goto A1\r\n else\r\n Result := Result + 'IV';\r\n Exit;\r\n A5:\r\n if Value < 5 then\r\n goto A4\r\n else\r\n begin\r\n Dec(Value, 5);\r\n Result := Result + 'V';\r\n end;\r\n goto A1;\r\n A1:\r\n while Value >= 1 do\r\n begin\r\n Dec(Value);\r\n Result := Result + 'I';\r\n end;\r\nend;\r\n\r\nfunction IntToBin(Value: Longint; Digits, Spaces: Integer): string;\r\nbegin\r\n Result := '';\r\n if Digits > 32 then\r\n Digits := 32;\r\n while Digits > 0 do\r\n begin\r\n if (Digits mod Spaces) = 0 then\r\n Result := Result + ' ';\r\n Dec(Digits);\r\n Result := Result + IntToStr((Value shr Digits) and 1);\r\n end;\r\nend;\r\n\r\nfunction FindPart(const HelpWilds, InputStr: string): Integer;\r\nvar\r\n I, J: Integer;\r\n Diff: Integer;\r\nbegin\r\n I := Pos('?', HelpWilds);\r\n if I = 0 then\r\n begin\r\n { if no '?' in HelpWilds }\r\n Result := Pos(HelpWilds, InputStr);\r\n Exit;\r\n end;\r\n { '?' in HelpWilds }\r\n Diff := Length(InputStr) - Length(HelpWilds);\r\n if Diff < 0 then\r\n begin\r\n Result := 0;\r\n Exit;\r\n end;\r\n { now move HelpWilds over InputStr }\r\n for I := 0 to Diff do\r\n begin\r\n for J := 1 to Length(HelpWilds) do\r\n begin\r\n if (InputStr[I + J] = HelpWilds[J]) or (HelpWilds[J] = '?') then\r\n begin\r\n if J = Length(HelpWilds) then\r\n begin\r\n Result := I + 1;\r\n Exit;\r\n end;\r\n end\r\n else\r\n Break;\r\n end;\r\n end;\r\n Result := 0;\r\nend;\r\n\r\nfunction IsWild(InputStr, Wilds: string; IgnoreCase: Boolean): Boolean;\r\n\r\n function SearchNext(var Wilds: string): Integer;\r\n { looking for next *, returns position and string until position }\r\n begin\r\n Result := Pos('*', Wilds);\r\n if Result > 0 then\r\n Wilds := Copy(Wilds, 1, Result - 1);\r\n end;\r\n\r\nvar\r\n CWild, CInputWord: Integer; { counter for positions }\r\n I, LenHelpWilds: Integer;\r\n MaxInputWord, MaxWilds: Integer; { Length of InputStr and Wilds }\r\n HelpWilds: string;\r\nbegin\r\n if Wilds = InputStr then\r\n begin\r\n Result := True;\r\n Exit;\r\n end;\r\n repeat { delete '**', because '**' = '*' }\r\n I := Pos('**', Wilds);\r\n if I > 0 then\r\n Wilds := Copy(Wilds, 1, I - 1) + '*' + Copy(Wilds, I + 2, MaxInt);\r\n until I = 0;\r\n if Wilds = '*' then\r\n begin { for fast end, if Wilds only '*' }\r\n Result := True;\r\n Exit;\r\n end;\r\n MaxInputWord := Length(InputStr);\r\n MaxWilds := Length(Wilds);\r\n if IgnoreCase then\r\n begin { upcase all letters }\r\n InputStr := AnsiUpperCase(InputStr);\r\n Wilds := AnsiUpperCase(Wilds);\r\n end;\r\n if (MaxWilds = 0) or (MaxInputWord = 0) then\r\n begin\r\n Result := False;\r\n Exit;\r\n end;\r\n CInputWord := 1;\r\n CWild := 1;\r\n Result := True;\r\n repeat\r\n if InputStr[CInputWord] = Wilds[CWild] then\r\n begin { equal letters }\r\n { goto next letter }\r\n Inc(CWild);\r\n Inc(CInputWord);\r\n Continue;\r\n end;\r\n if Wilds[CWild] = '?' then\r\n begin { equal to '?' }\r\n { goto next letter }\r\n Inc(CWild);\r\n Inc(CInputWord);\r\n Continue;\r\n end;\r\n if Wilds[CWild] = '*' then\r\n begin { handling of '*' }\r\n HelpWilds := Copy(Wilds, CWild + 1, MaxWilds);\r\n I := SearchNext(HelpWilds);\r\n LenHelpWilds := Length(HelpWilds);\r\n if I = 0 then\r\n begin\r\n { no '*' in the rest, compare the ends }\r\n if HelpWilds = '' then\r\n Exit; { '*' is the last letter }\r\n { check the rest for equal Length and no '?' }\r\n for I := 0 to LenHelpWilds - 1 do\r\n begin\r\n if (HelpWilds[LenHelpWilds - I] <> InputStr[MaxInputWord - I]) and\r\n (HelpWilds[LenHelpWilds - I] <> '?') then\r\n begin\r\n Result := False;\r\n Exit;\r\n end;\r\n end;\r\n Exit;\r\n end;\r\n { handle all to the next '*' }\r\n Inc(CWild, 1 + LenHelpWilds);\r\n I := FindPart(HelpWilds, Copy(InputStr, CInputWord, MaxInt));\r\n if I = 0 then\r\n begin\r\n Result := False;\r\n Exit;\r\n end;\r\n CInputWord := I + LenHelpWilds;\r\n Continue;\r\n end;\r\n Result := False;\r\n Exit;\r\n until (CInputWord > MaxInputWord) or (CWild > MaxWilds);\r\n { no completed evaluation }\r\n if CInputWord <= MaxInputWord then\r\n Result := False;\r\n if (CWild <= MaxWilds) and (Wilds[MaxWilds] <> '*') then\r\n Result := False;\r\nend;\r\n\r\nfunction XorString(const Key, Src: ShortString): ShortString;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := Src;\r\n if Length(Key) > 0 then\r\n for I := 1 to Length(Src) do\r\n Result[I] := AnsiChar(Chr(Byte(Key[1 + ((I - 1) mod Length(Key))]) xor Ord(Src[I])));\r\nend;\r\n\r\nfunction XorEncode(const Key, Source: string): string;\r\nvar\r\n I, KeyLen: Integer;\r\n C: Byte;\r\nbegin\r\n Result := '';\r\n KeyLen := Length(Key);\r\n for I := 1 to Length(Source) do\r\n begin\r\n if KeyLen > 0 then\r\n C := Byte(Key[1 + ((I - 1) mod KeyLen)]) xor Byte(Source[I])\r\n else\r\n C := Byte(Source[I]);\r\n Result := Result + AnsiLowerCase(IntToHex(C, 2));\r\n end;\r\nend;\r\n\r\nfunction XorDecode(const Key, Source: string): string;\r\nvar\r\n I, KeyLen: Integer;\r\n C: Char;\r\nbegin\r\n Result := '';\r\n KeyLen := Length(Key);\r\n for I := 0 to Length(Source) div 2 - 1 do\r\n begin\r\n C := Char(StrToIntDef('$' + string(Source[I * 2 + 1] + Source[I * 2 + 2]), Ord(' ')));\r\n if KeyLen > 0 then\r\n C := Char(Byte(Key[1 + (I mod KeyLen)]) xor Byte(C));\r\n Result := Result + C;\r\n end;\r\nend;\r\n\r\nfunction XorEncodeString(const Key, Source: string): string;\r\nconst\r\n HexChars: array[0..15] of Char =\r\n ('0', '1', '2', '3', '4', '5', '6', '7', '8', '9', 'a', 'b', 'c', 'd', 'e', 'f');\r\nvar\r\n I, KeyLen: Integer;\r\n C: Byte;\r\n Utf8Src, Utf8Key: UTF8String;\r\nbegin\r\n Result := '';\r\n Utf8Src := UTF8Encode(Source);\r\n Utf8Key := UTF8Encode(Key);\r\n KeyLen := Length(Utf8Key);\r\n SetLength(Result, Length(Utf8Src) * 2);\r\n for I := 1 to Length(Utf8Src) do\r\n begin\r\n if KeyLen > 0 then\r\n C := Byte(Utf8Src[I]) xor Byte(Utf8Key[1 + ((I - 1) mod KeyLen)])\r\n else\r\n C := Byte(Utf8Src[I]);\r\n Result[1 + (I - 1) * 2] := HexChars[C shr 4];\r\n Result[1 + (I - 1) * 2 + 1] := HexChars[C and $0F];\r\n end;\r\nend;\r\n\r\nfunction XorDecodeString(const Key, Source: string): string;\r\nvar\r\n I, KeyLen: Integer;\r\n C: Char;\r\n B: Byte;\r\n Utf8Result, Utf8Key: UTF8String;\r\nbegin\r\n Result := '';\r\n Utf8Key := UTF8Encode(Key);\r\n KeyLen := Length(Utf8Key);\r\n SetLength(Utf8Result, Length(Source) div 2);\r\n for I := 0 to Length(Source) div 2 - 1 do\r\n begin\r\n // HexToInt\r\n C := Source[1 + I * 2];\r\n case C of\r\n '0'..'9': B := Ord(C) - Ord('0');\r\n 'A'..'F': B := Ord(C) - 55;\r\n 'a'..'f': B := Ord(C) - 87;\r\n else\r\n B := Ord(' ');\r\n end;\r\n B := B shl 4;\r\n C := Source[1 + I * 2 + 1];\r\n case C of\r\n '0'..'9': B := B or (Ord(C) - Ord('0'));\r\n 'A'..'F': B := B or (Ord(C) - 55);\r\n 'a'..'f': B := B or (Ord(C) - 87);\r\n else\r\n B := Ord(' ');\r\n end;\r\n if KeyLen > 0 then\r\n B := B xor Byte(Utf8Key[1 + (I mod KeyLen)]);\r\n Utf8Result[1 + I] := AnsiChar(B);\r\n end;\r\n Result := UTF8ToString(Utf8Result);\r\nend;\r\n\r\nfunction GetCmdLineArg(const Switch: string; ASwitchChars: TSysCharSet): string;\r\nvar\r\n I: Integer;\r\n S: string;\r\nbegin\r\n I := 1;\r\n while I <= ParamCount do\r\n begin\r\n S := ParamStr(I);\r\n if (ASwitchChars = []) or ((Length(S) > 1) and CharInSet(S[1], ASwitchChars)) then\r\n begin\r\n if AnsiSameText(Copy(S, 2, MaxInt), Switch) then\r\n begin\r\n Inc(I);\r\n if I <= ParamCount then\r\n begin\r\n Result := ParamStr(I);\r\n Exit;\r\n end;\r\n end;\r\n end;\r\n Inc(I);\r\n end;\r\n Result := '';\r\nend;\r\n\r\n{ begin JvStrUtil }\r\n\r\nfunction FindNotBlankCharPos(const S: string): Integer;\r\nbegin\r\n for Result := 1 to Length(S) do\r\n if S[Result] <> ' ' then\r\n Exit;\r\n Result := Length(S) + 1;\r\nend;\r\n\r\nfunction FindNotBlankCharPosW(const S: WideString): Integer;\r\nbegin\r\n for Result := 1 to Length(S) do\r\n if S[Result] <> ' ' then\r\n Exit;\r\n Result := Length(S) + 1;\r\nend;\r\n\r\n// (rom) reimplemented\r\n\r\nfunction AnsiChangeCase(const S: string): string;\r\nvar\r\n I: Integer;\r\n Up: string;\r\n Down: string;\r\nbegin\r\n Result := S;\r\n Up := AnsiUpperCase(S);\r\n Down := AnsiLowerCase(S);\r\n for I := 1 to Length(Result) do\r\n if Result[I] = Up[I] then\r\n Result[I] := Down[I]\r\n else\r\n Result[I] := Up[I];\r\nend;\r\n\r\nfunction WideChangeCase(const S: string): string;\r\nvar\r\n I: Integer;\r\n Up: string;\r\n Down: string;\r\nbegin\r\n Result := S;\r\n Up := WideUpperCase(S);\r\n Down := WideLowerCase(S);\r\n for I := 1 to Length(Result) do\r\n if Result[I] = Up[I] then\r\n Result[I] := Down[I]\r\n else\r\n Result[I] := Up[I];\r\nend;\r\n\r\n{ end JvStrUtil }\r\n{ end JvStrUtils }\r\n\r\n{ begin JvFileUtil }\r\n\r\nfunction NormalDir(const DirName: string): string;\r\nbegin\r\n Result := DirName;\r\n {$IFDEF MSWINDOWS}\r\n if (Result <> '') and\r\n not CharInSet(AnsiLastChar(Result)^, [':', '\\'])\r\n then\r\n if (Length(Result) = 1) and CharInSet(Result[1], ['A'..'Z', 'a'..'z']) then\r\n Result := Result + ':\\'\r\n else\r\n Result := Result + '\\';\r\n {$ENDIF MSWINDOWS}\r\nend;\r\n\r\nfunction RemoveBackSlash(const DirName: string): string;\r\nbegin\r\n Result := DirName;\r\n if (Length(Result) > 1) and\r\n (AnsiLastChar(Result)^ = '\\')\r\n then\r\n if not ((Length(Result) = 3) and CharInSet(Result[1], ['A'..'Z', 'a'..'z']) and\r\n (Result[2] = ':')) then\r\n Delete(Result, Length(Result), 1);\r\nend;\r\n\r\nfunction HasAttr(const FileName: string; Attr: Integer): Boolean;\r\nvar\r\n FileAttr: Integer;\r\nbegin\r\n FileAttr := FileGetAttr(FileName);\r\n Result := (FileAttr >= 0) and (FileAttr and Attr = Attr);\r\nend;\r\n\r\nfunction DeleteFilesEx(const FileMasks: array of string): Boolean;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := True;\r\n for I := Low(FileMasks) to High(FileMasks) do\r\n Result := Result and DeleteFiles(ExtractFilePath(FileMasks[I]), ExtractFileName(FileMasks[I]));\r\nend;\r\n\r\n{$IFDEF MSWINDOWS}\r\n\r\nfunction GetWindowsDir: string;\r\nvar\r\n Buffer: array [0..MAX_PATH] of Char;\r\nbegin\r\n SetString(Result, Buffer, GetWindowsDirectory(Buffer, SizeOf(Buffer)));\r\nend;\r\n\r\nfunction GetSystemDir: string;\r\nvar\r\n Buffer: array [0..MAX_PATH] of Char;\r\nbegin\r\n SetString(Result, Buffer, GetSystemDirectory(Buffer, SizeOf(Buffer)));\r\nend;\r\n\r\n{$ENDIF MSWINDOWS}\r\n\r\n{$IFDEF UNIX}\r\nfunction GetTempFileName(const Prefix: AnsiString): AnsiString;\r\nvar\r\n P: PAnsiChar;\r\nbegin\r\n P := tempnam(nil, Pointer(Prefix));\r\n Result := P;\r\n if P <> nil then\r\n Libc.free(P);\r\nend;\r\n{$ENDIF UNIX}\r\n\r\nfunction GenTempFileName(FileName: string): string;\r\nvar\r\n TempDir: string;\r\n {$IFDEF MSWINDOWS}\r\n TempFile: array [0..MAX_PATH] of Char;\r\n {$ENDIF MSWINDOWS}\r\n {$IFDEF UNIX}\r\n TempFile: string;\r\n {$ENDIF UNIX}\r\n STempDir: TFileName;\r\n Res: Integer;\r\nbegin\r\n TempDir := PathGetTempPath;\r\n if FileName <> '' then\r\n begin\r\n if Length(FileName) < 4 then\r\n FileName := ExpandFileName(FileName);\r\n if (Length(FileName) > 4) and (FileName[2] = ':') and\r\n (Length(TempDir) > 4) and\r\n (AnsiCompareFileName(TempDir, FileName) <> 0) then\r\n begin\r\n STempDir := ExtractFilePath(FileName);\r\n MoveString(STempDir, TempDir, Length(STempDir) + 1);\r\n end;\r\n end;\r\n {$IFDEF MSWINDOWS}\r\n Res := GetTempFileName(\r\n PChar(TempDir), { address of directory name for temporary file}\r\n '~JV', { address of filename prefix}\r\n 0, { number used to create temporary filename}\r\n TempFile); { address of buffer that receives the new filename}\r\n {$ENDIF MSWINDOWS}\r\n {$IFDEF UNIX}\r\n TempFile := GetTempFileName('~JV');\r\n Res := 1;\r\n {$ENDIF UNIX}\r\n if Res <> 0 then\r\n Result := TempFile\r\n else\r\n Result := '~JVCLTemp.tmp';\r\n DeleteFile(Result);\r\nend;\r\n\r\nfunction GenTempFileNameExt(FileName: string; const FileExt: string): string;\r\nbegin\r\n Result := ChangeFileExt(GenTempFileName(FileName), FileExt);\r\nend;\r\n\r\nfunction ClearDir(const Dir: string): Boolean;\r\nvar\r\n SearchRec: TSearchRec;\r\n DosError: Integer;\r\n Path: TFileName;\r\nbegin\r\n Result := True;\r\n Path := AddSlash(Dir);\r\n DosError := FindFirst(Path + AllFilesMask, faAnyFile, SearchRec);\r\n while DosError = 0 do\r\n begin\r\n if (SearchRec.Name <> '.') and (SearchRec.Name <> '..') then\r\n begin\r\n if (SearchRec.Attr and faDirectory) = faDirectory then\r\n Result := Result and DeleteDir(Path + SearchRec.Name)\r\n else\r\n Result := Result and DeleteFile(Path + SearchRec.Name);\r\n // if not Result then Exit;\r\n end;\r\n DosError := FindNext(SearchRec);\r\n end;\r\n FindClose(SearchRec);\r\nend;\r\n\r\nfunction DeleteDir(const Dir: string): Boolean;\r\nbegin\r\n ClearDir(Dir);\r\n Result := RemoveDir(Dir);\r\nend;\r\n\r\nfunction DeleteFiles(const Folder: TFileName; const Masks: string): Boolean;\r\nvar\r\n SearchRec: TSearchRec;\r\n DosError: Integer;\r\n Path: TFileName;\r\nbegin\r\n Result := False;\r\n Path := AddSlash(Folder);\r\n DosError := FindFirst(Path + AllFilesMask, faAnyFile and not faDirectory, SearchRec);\r\n while DosError = 0 do\r\n begin\r\n if FileEquMasks(Path + SearchRec.Name, Masks) then\r\n Result := DeleteFile(Path + SearchRec.Name);\r\n DosError := FindNext(SearchRec);\r\n end;\r\n FindClose(SearchRec);\r\nend;\r\n\r\nfunction GetParameter: string;\r\nvar\r\n FN, FN1: PChar;\r\nbegin\r\n if ParamCount = 0 then\r\n begin\r\n Result := '';\r\n Exit\r\n end;\r\n FN := CmdLine;\r\n if FN[0] = '\"' then\r\n begin\r\n FN := StrScan(FN + 1, '\"');\r\n if (FN[0] = #0) or (FN[1] = #0) then\r\n Result := ''\r\n else\r\n begin\r\n Inc(FN, 2);\r\n if FN[0] = '\"' then\r\n begin\r\n Inc(FN, 1);\r\n FN1 := StrScan(FN + 1, '\"');\r\n if FN1[0] <> #0 then\r\n FN1[0] := #0;\r\n end;\r\n Result := FN;\r\n end;\r\n end\r\n else\r\n Result := Copy(CmdLine, Length(ParamStr(0)) + 1, 260);\r\n while (Length(Result) > 0) and (Result[1] = ' ') do\r\n Delete(Result, 1, 1);\r\n Result := ReplaceString(Result, '\"', '');\r\n if FileExists(Result) then\r\n Result := GetLongFileName(Result);\r\nend;\r\n\r\nfunction GetLongFileName(const FileName: string): string;\r\n{$IFDEF MSWINDOWS}\r\nvar\r\n SearchRec: TSearchRec;\r\n{$ENDIF MSWINDOWS}\r\nbegin\r\n {$IFDEF MSWINDOWS}\r\n if FileGetInfo(FileName, SearchRec) then\r\n Result := ExtractFilePath(ExpandFileName(FileName)) + SearchRec.FindData.cFileName\r\n else\r\n Result := FileName;\r\n {$ENDIF MSWINDOWS}\r\n {$IFDEF UNIX}\r\n Result := ExpandFileName(FileName);\r\n {$ENDIF UNIX}\r\nend;\r\n\r\nfunction FileEquMask(FileName, Mask: TFileName; CaseSensitive: Boolean): Boolean;\r\nvar\r\n I: Integer;\r\n C: Char;\r\n Index: Integer;\r\n LenFileName: Integer;\r\nbegin\r\n if not CaseSensitive then\r\n begin\r\n FileName := AnsiUpperCase(ExtractFileName(FileName));\r\n Mask := AnsiUpperCase(Mask);\r\n end;\r\n Result := False;\r\n {$IFDEF MSWINDOWS}\r\n if Pos('.', FileName) = 0 then\r\n FileName := FileName + '.';\r\n {$ENDIF MSWINDOWS}\r\n LenFileName := Length(FileName);\r\n I := 1;\r\n Index := 1;\r\n while I <= Length(Mask) do\r\n begin\r\n C := Mask[I];\r\n if (Index > LenFileName) and (C <> '*') then\r\n Exit;\r\n case C of\r\n '*':\r\n if I = Length(Mask) then\r\n begin\r\n Result := True;\r\n Exit;\r\n end\r\n else\r\n begin\r\n Index := PosIdx(Mask[I + 1], FileName, Index);\r\n if Index = 0 then\r\n Exit;\r\n end;\r\n '?':\r\n Inc(Index);\r\n else\r\n if C = FileName[Index] then\r\n Inc(Index)\r\n else\r\n Exit;\r\n end;\r\n Inc(I);\r\n end;\r\n if Index > LenFileName then\r\n Result := True;\r\nend;\r\n\r\nfunction FileEquMasks(FileName, Masks: TFileName; CaseSensitive: Boolean): Boolean;\r\nvar\r\n I: Integer;\r\n Mask: string;\r\nbegin\r\n Result := False;\r\n I := 0;\r\n Mask := Trim(SubStrBySeparator(Masks, I, PathSep));\r\n while Length(Mask) <> 0 do\r\n if FileEquMask(FileName, Mask, CaseSensitive) then\r\n begin\r\n Result := True;\r\n Break;\r\n end\r\n else\r\n begin\r\n Inc(I);\r\n Mask := Trim(SubStrBySeparator(Masks, I, PathSep));\r\n end;\r\nend;\r\n\r\nfunction ValidFileName(const FileName: string): Boolean;\r\n\r\n function HasAny(const Str, SubStr: string): Boolean;\r\n var\r\n I: Integer;\r\n begin\r\n Result := False;\r\n for I := 1 to Length(SubStr) do\r\n begin\r\n if Pos(SubStr[I], Str) > 0 then\r\n begin\r\n Result := True;\r\n Break;\r\n end;\r\n end;\r\n end;\r\n\r\nbegin\r\n Result := (FileName <> '') and\r\n {$IFDEF MSWINDOWS}\r\n (not HasAny(FileName, '/<>\"?*|'));\r\n {$ENDIF MSWINDOWS}\r\n {$IFDEF UNIX}\r\n (not HasAny(FileName, '<>\"?*|'));\r\n {$ENDIF UNIX}\r\n if Result then\r\n Result := Pos(PathDelim, ExtractFileName(FileName)) = 0;\r\nend;\r\n\r\n{$IFDEF MSWINDOWS}\r\n\r\nfunction FileLock(Handle: Integer; Offset, LockSize: Longint): Integer; overload;\r\nbegin\r\n if LockFile(Handle, Offset, 0, LockSize, 0) then\r\n Result := 0\r\n else\r\n Result := GetLastError;\r\nend;\r\n\r\nfunction FileUnlock(Handle: Integer; Offset, LockSize: Longint): Integer; overload;\r\nbegin\r\n if UnlockFile(Handle, Offset, 0, LockSize, 0) then\r\n Result := 0\r\n else\r\n Result := GetLastError;\r\nend;\r\n\r\nfunction FileLock(Handle: Integer; Offset, LockSize: Int64): Integer; overload;\r\nbegin\r\n if LockFile(Handle, Int64Rec(Offset).Lo, Int64Rec(Offset).Hi,\r\n Int64Rec(LockSize).Lo, Int64Rec(LockSize).Hi) then\r\n Result := 0\r\n else\r\n Result := GetLastError;\r\nend;\r\n\r\nfunction FileUnlock(Handle: Integer; Offset, LockSize: Int64): Integer; overload;\r\nbegin\r\n if UnlockFile(Handle, Int64Rec(Offset).Lo, Int64Rec(Offset).Hi,\r\n Int64Rec(LockSize).Lo, Int64Rec(LockSize).Hi) then\r\n Result := 0\r\n else\r\n Result := GetLastError;\r\nend;\r\n\r\n{$ENDIF MSWINDOWS}\r\n\r\nfunction ShortToLongFileName(const ShortName: string): string;\r\n{$IFDEF MSWINDOWS}\r\nvar\r\n Temp: TWin32FindData;\r\n SearchHandle: THandle;\r\nbegin\r\n SearchHandle := FindFirstFile(PChar(ShortName), Temp);\r\n if SearchHandle <> INVALID_HANDLE_VALUE then\r\n begin\r\n Result := Temp.cFileName;\r\n if Result = '' then\r\n Result := Temp.cAlternateFileName;\r\n end\r\n else\r\n Result := '';\r\n Windows.FindClose(SearchHandle);\r\nend;\r\n{$ENDIF MSWINDOWS}\r\n{$IFDEF UNIX}\r\nbegin\r\n if FileExists(ShortName) then\r\n Result := ShortName\r\n else\r\n Result := '';\r\nend;\r\n{$ENDIF UNIX}\r\n\r\nfunction LongToShortFileName(const LongName: string): string;\r\n{$IFDEF MSWINDOWS}\r\nvar\r\n Temp: TWin32FindData;\r\n SearchHandle: THandle;\r\nbegin\r\n SearchHandle := FindFirstFile(PChar(LongName), Temp);\r\n if SearchHandle <> INVALID_HANDLE_VALUE then\r\n begin\r\n Result := Temp.cAlternateFileName;\r\n if Result = '' then\r\n Result := Temp.cFileName;\r\n end\r\n else\r\n Result := '';\r\n Windows.FindClose(SearchHandle);\r\nend;\r\n{$ENDIF MSWINDOWS}\r\n{$IFDEF UNIX}\r\nbegin\r\n if FileExists(LongName) then\r\n Result := LongName\r\n else\r\n Result := '';\r\nend;\r\n{$ENDIF UNIX}\r\n\r\nfunction ShortToLongPath(const ShortName: string): string;\r\nvar\r\n LastSlash: PChar;\r\n TempPathPtr: PChar;\r\nbegin\r\n Result := '';\r\n TempPathPtr := StrNew(PChar(ShortName));\r\n try\r\n LastSlash := StrRScan(TempPathPtr, PathDelim);\r\n while LastSlash <> nil do\r\n begin\r\n Result := PathDelim + ShortToLongFileName(TempPathPtr) + Result;\r\n if LastSlash <> nil then\r\n begin\r\n LastSlash^ := #0;\r\n LastSlash := StrRScan(TempPathPtr, PathDelim);\r\n end;\r\n end;\r\n Result := TempPathPtr + Result;\r\n finally\r\n StrDispose(TempPathPtr);\r\n end;\r\nend;\r\n\r\nfunction LongToShortPath(const LongName: string): string;\r\nvar\r\n LastSlash: PChar;\r\n TempPathPtr: PChar;\r\nbegin\r\n Result := '';\r\n TempPathPtr := StrNew(PChar(LongName));\r\n try\r\n LastSlash := StrRScan(TempPathPtr, PathDelim);\r\n while LastSlash <> nil do\r\n begin\r\n Result := PathDelim + LongToShortFileName(TempPathPtr) + Result;\r\n if LastSlash <> nil then\r\n begin\r\n LastSlash^ := #0;\r\n LastSlash := StrRScan(TempPathPtr, PathDelim);\r\n end;\r\n end;\r\n Result := TempPathPtr + Result;\r\n finally\r\n StrDispose(TempPathPtr);\r\n end;\r\nend;\r\n\r\n{$IFDEF MSWINDOWS}\r\n\r\nconst\r\n IID_IPersistFile: TGUID =\r\n (D1: $0000010B; D2: $0000; D3: $0000; D4: ($C0, $00, $00, $00, $00, $00, $00, $46));\r\n\r\nconst\r\n LinkExt = '.lnk';\r\n\r\nprocedure CreateFileLink(const FileName, DisplayName: string; Folder: Integer);\r\nvar\r\n ShellLink: IShellLink;\r\n PersistFile: IPersistFile;\r\n ItemIDList: PItemIDList;\r\n FileDestPath: array [0..MAX_PATH] of Char;\r\n {$IFNDEF UNICODE}\r\n FileNameW: array [0..MAX_PATH] of WideChar;\r\n {$ENDIF ~UNICODE}\r\nbegin\r\n CoInitialize(nil);\r\n try\r\n OleCheck(CoCreateInstance(CLSID_ShellLink, nil, CLSCTX_SERVER,\r\n IID_IShellLinkA, ShellLink));\r\n try\r\n OleCheck(ShellLink.QueryInterface(IID_IPersistFile, PersistFile));\r\n try\r\n OleCheck(SHGetSpecialFolderLocation(0, Folder, ItemIDList));\r\n SHGetPathFromIDList(ItemIDList, FileDestPath);\r\n StrCat(FileDestPath, PChar('\\' + DisplayName + LinkExt));\r\n ShellLink.SetPath(PChar(FileName));\r\n ShellLink.SetIconLocation(PChar(FileName), 0);\r\n {$IFDEF UNICODE}\r\n OleCheck(PersistFile.Save(FileDestPath, True));\r\n {$ELSE}\r\n MultiByteToWideChar(CP_ACP, 0, FileDestPath, -1, FileNameW, MAX_PATH);\r\n OleCheck(PersistFile.Save(FileNameW, True));\r\n {$ENDIF UNICODE}\r\n finally\r\n PersistFile := nil;\r\n end;\r\n finally\r\n ShellLink := nil;\r\n end;\r\n finally\r\n CoUninitialize;\r\n end;\r\nend;\r\n\r\nprocedure DeleteFileLink(const DisplayName: string; Folder: Integer);\r\nvar\r\n ShellLink: IShellLink;\r\n ItemIDList: PItemIDList;\r\n FileDestPath: array [0..MAX_PATH] of Char;\r\nbegin\r\n CoInitialize(nil);\r\n try\r\n OleCheck(CoCreateInstance(CLSID_ShellLink, nil, CLSCTX_SERVER,\r\n IID_IShellLinkA, ShellLink));\r\n try\r\n OleCheck(SHGetSpecialFolderLocation(0, Folder, ItemIDList));\r\n SHGetPathFromIDList(ItemIDList, FileDestPath);\r\n StrCat(FileDestPath, PChar('\\' + DisplayName + LinkExt));\r\n DeleteFile(FileDestPath);\r\n finally\r\n ShellLink := nil;\r\n end;\r\n finally\r\n CoUninitialize;\r\n end;\r\nend;\r\n\r\n{$ENDIF MSWINDOWS}\r\n\r\n{ end JvFileUtil }\r\n\r\nfunction PtInRectInclusive(R: TRect; Pt: TPoint): Boolean;\r\nbegin\r\n R.Right := R.Right + 1;\r\n R.Bottom := R.Bottom + 1;\r\n Result := PtInRect(R, Pt);\r\nend;\r\n\r\nfunction PtInRectExclusive(R: TRect; Pt: TPoint): Boolean;\r\nbegin\r\n R.Left := R.Left + 1;\r\n R.Top := R.Top + 1;\r\n Result := PtInRect(R, Pt);\r\nend;\r\n\r\nfunction OpenObject(const Value: string): Boolean; overload;\r\nbegin\r\n Result := OpenObject(PChar(Value));\r\nend;\r\n\r\n{ (rb) Duplicate of JvFunctions.Exec }\r\nfunction OpenObject(Value: PChar): Boolean; overload;\r\nbegin\r\n Result := ShellExecute(0, 'open', Value, nil, nil, SW_SHOWNORMAL) > HINSTANCE_ERROR;\r\nend;\r\n\r\n{$IFDEF MSWINDOWS}\r\n\r\nprocedure RaiseLastWin32; overload;\r\nbegin\r\n PError('');\r\nend;\r\n\r\nprocedure RaiseLastWin32(const Text: string); overload;\r\nbegin\r\n PError(Text);\r\nend;\r\n\r\nfunction GetFileVersion(const AFileName: string): Cardinal;\r\nvar\r\n FileName: string;\r\n InfoSize, Wnd: DWORD;\r\n VerBuf: Pointer;\r\n FI: PVSFixedFileInfo;\r\n VerSize: DWORD;\r\nbegin\r\n Result := 0;\r\n // GetFileVersionInfo modifies the filename parameter data while parsing.\r\n // Copy the string const into a local variable to create a writeable copy.\r\n FileName := AFileName;\r\n UniqueString(FileName);\r\n InfoSize := GetFileVersionInfoSize(PChar(FileName), Wnd);\r\n if InfoSize <> 0 then\r\n begin\r\n GetMem(VerBuf, InfoSize);\r\n try\r\n if GetFileVersionInfo(PChar(FileName), Wnd, InfoSize, VerBuf) then\r\n if VerQueryValue(VerBuf, '\\', Pointer(FI), VerSize) then\r\n Result := FI.dwFileVersionMS;\r\n finally\r\n FreeMem(VerBuf);\r\n end;\r\n end;\r\nend;\r\n\r\nvar\r\n ShellVersion: Integer;\r\n\r\nfunction GetShellVersion: Cardinal;\r\nbegin\r\n if ShellVersion = 0 then\r\n ShellVersion := GetFileVersion('shell32.dll');\r\n Result := ShellVersion;\r\nend;\r\n\r\nprocedure OpenCdDrive;\r\nbegin\r\n mciSendString(PChar(RC_OpenCDDrive), nil, 0, Windows.GetForegroundWindow);\r\nend;\r\n\r\nprocedure CloseCdDrive;\r\nbegin\r\n mciSendString(PChar(RC_CloseCDDrive), nil, 0, Windows.GetForegroundWindow);\r\nend;\r\n\r\n{ (rb) Duplicate of JclFileUtils.DiskInDrive }\r\n\r\nfunction DiskInDrive(Drive: Char): Boolean;\r\nvar\r\n DrvNum: Byte;\r\n EMode: Word;\r\nbegin\r\n DrvNum := Ord(Drive);\r\n if DrvNum >= Ord('a') then\r\n Dec(DrvNum, $20);\r\n EMode := SetErrorMode(SEM_FAILCRITICALERRORS);\r\n try\r\n Result := DiskSize(DrvNum - $40) <> -1;\r\n finally\r\n SetErrorMode(EMode);\r\n end;\r\nend;\r\n\r\n{$ENDIF MSWINDOWS}\r\n\r\nprocedure PError(const Text: string);\r\nvar\r\n LastError: Integer;\r\n St: string;\r\nbegin\r\n LastError := GetLastError;\r\n if LastError <> 0 then\r\n begin\r\n St := SysUtils.Format(SOSError, [LastError, SysErrorMessage(LastError)]);\r\n if Text <> '' then\r\n St := Text + ':' + St;\r\n raise EOSError.Create(St);\r\n end;\r\nend;\r\n\r\nprocedure Exec(const FileName, Parameters, Directory: string);\r\nbegin\r\n {$IFDEF MSWINDOWS}\r\n ShellExecute(Windows.GetForegroundWindow, 'open', PChar(FileName), PChar(Parameters), PChar(Directory),\r\n SW_SHOWNORMAL);\r\n {$ENDIF MSWINDOWS}\r\n {$IFDEF UNIX}\r\n ShellExecute(GetForegroundWindow, 'open', PChar(FileName), PChar(Parameters), PChar(Directory),\r\n SW_SHOWNORMAL);\r\n {$ENDIF UNIX}\r\nend;\r\n{$IFDEF UNIX}\r\n// begin\r\n// if Directory = '' then Directory := GetCurrentDir;\r\n// Libc.system(PChar(Format('cd \"%s\" ; \"%s\" %s &', [Directory, FileName, Parameters])));\r\n// end;\r\n{$ENDIF UNIX}\r\n\r\n{ (rb) Duplicate of JclMiscel.WinExec32AndWait }\r\n\r\nfunction ExecuteAndWait(CommandLine: string; const WorkingDirectory: string; Visibility: Integer): Integer;\r\n{$IFDEF MSWINDOWS}\r\nvar\r\n StartupInfo: TStartupInfo;\r\n ProcessInfo: TProcessInformation;\r\nbegin\r\n Result := 0;\r\n FillChar(StartupInfo, SizeOf(StartupInfo), 0);\r\n StartupInfo.cb := SizeOf(StartupInfo);\r\n StartupInfo.dwFlags := STARTF_USESHOWWINDOW;\r\n StartupInfo.wShowWindow := Visibility;\r\n UniqueString(CommandLine);//in the Unicode version the parameter lpCommandLine needs to be writable\r\n if not CreateProcess(nil, PChar(CommandLine), nil, nil, False, CREATE_NEW_CONSOLE or NORMAL_PRIORITY_CLASS,\r\n nil, Pointer(WorkingDirectory), StartupInfo, ProcessInfo) then\r\n begin\r\n WaitForSingleObject(ProcessInfo.hProcess, INFINITE);\r\n\r\n // required to avoid running resource leak.\r\n CloseHandle(ProcessInfo.hProcess);\r\n CloseHandle(ProcessInfo.hThread);\r\n end\r\n else\r\n begin\r\n Result := GetLastError;\r\n end;\r\nend;\r\n{$ENDIF MSWINDOWS}\r\n{$IFDEF UNIX}\r\nbegin\r\n // ignores Visibility\r\n { TODO : Untested }\r\n if Libc.system(PChar(Format('kfmclient exec \"%s\"', [CommandLine]))) = -1 then\r\n begin\r\n if WorkingDirectory = '' then\r\n Result := Libc.system(PChar(Format('cd \"%s\" ; %s',\r\n [GetCurrentDir, CommandLine])))\r\n else\r\n Result := Libc.system(PChar(Format('cd \"%s\" ; %s',\r\n [WorkingDirectory, CommandLine])));\r\n end;\r\nend;\r\n{$ENDIF UNIX}\r\n\r\n\r\nfunction FirstInstance(const ATitle: string): Boolean;\r\nvar\r\n Mutex: THandle;\r\nbegin\r\n Mutex := CreateMutex(nil, False, PChar(ATitle));\r\n try\r\n Result := (Mutex <> 0) and (GetLastError <> ERROR_ALREADY_EXISTS);\r\n finally\r\n ReleaseMutex(Mutex);\r\n end;\r\nend;\r\n\r\nprocedure RestoreOtherInstance(const MainFormClassName, MainFormCaption: string);\r\nvar\r\n OtherWnd, OwnerWnd: HWND;\r\nbegin\r\n OtherWnd := FindWindow(PChar(MainFormClassName), PChar(MainFormCaption));\r\n ShowWindow(OtherWnd, SW_SHOW); //in case the window was not visible before\r\n\r\n OwnerWnd := 0;\r\n if OtherWnd <> 0 then\r\n OwnerWnd := GetWindow(OtherWnd, GW_OWNER);\r\n\r\n if OwnerWnd <> 0 then\r\n OtherWnd := OwnerWnd;\r\n\r\n if OtherWnd <> 0 then\r\n begin\r\n { (rb) Use JvVCLUtils.SwitchToWindow }\r\n if IsIconic(OtherWnd) then\r\n ShowWindow(OtherWnd, SW_RESTORE);\r\n\r\n SetForegroundWindow(OtherWnd);\r\n end;\r\nend;\r\n\r\nprocedure HideTraybar;\r\nbegin\r\n ShowWindow(FindWindow(PChar(RC_ShellName), nil), SW_HIDE);\r\nend;\r\n\r\nprocedure ShowTraybar;\r\nbegin\r\n ShowWindow(FindWindow(PChar(RC_ShellName), nil), SW_SHOW);\r\nend;\r\n\r\nprocedure ShowStartButton(Visible: Boolean);\r\nvar\r\n Tray, Child: HWND;\r\n C: array [0..127] of Char;\r\n S: string;\r\nbegin\r\n Tray := FindWindow(PChar(RC_ShellName), nil);\r\n Child := GetWindow(Tray, GW_CHILD);\r\n while Child <> 0 do\r\n begin\r\n if GetClassName(Child, C, SizeOf(C)) > 0 then\r\n begin\r\n S := StrPas(C);\r\n if UpperCase(S) = 'BUTTON' then\r\n if Visible then\r\n ShowWindow(Child, SW_SHOWNORMAL)\r\n else\r\n ShowWindow(Child, SW_HIDE);\r\n end;\r\n Child := GetWindow(Child, GW_HWNDNEXT);\r\n end;\r\nend;\r\n\r\nprocedure MonitorOn;\r\nbegin\r\n SendMessage(GetForegroundWindow, WM_SYSCOMMAND, SC_MONITORPOWER, -1);\r\nend;\r\n\r\nprocedure MonitorOff;\r\nbegin\r\n SendMessage(GetForegroundWindow, WM_SYSCOMMAND, SC_MONITORPOWER, 2);\r\nend;\r\n\r\nprocedure LowPower;\r\nbegin\r\n SendMessage(GetForegroundWindow, WM_SYSCOMMAND, SC_MONITORPOWER, 1);\r\nend;\r\n\r\nprocedure SendShift(H: THandle; Down: Boolean);\r\nvar\r\n VKey: Word;\r\n ScanCode: DWORD;\r\nbegin\r\n VKey := VK_SHIFT;\r\n ScanCode := Longint(MapVirtualKey(VKey, 0)) shl 16 or 1;\r\n if not Down then\r\n ScanCode := ScanCode or $C0000000;\r\n SendMessage(H, WM_KEYDOWN, VKey, LPARAM(ScanCode));\r\nend;\r\n\r\nprocedure SendCtrl(H: THandle; Down: Boolean);\r\nvar\r\n VKey: Word;\r\n ScanCode: DWORD;\r\nbegin\r\n VKey := VK_CONTROL;\r\n ScanCode := Longint(MapVirtualKey(VKey, 0)) shl 16 or 1;\r\n if not Down then\r\n ScanCode := ScanCode or $C0000000;\r\n SendMessage(H, WM_KEYDOWN, VKey, LPARAM(ScanCode));\r\nend;\r\n\r\nfunction SendKey(const AppName: string; Key: Char): Boolean;\r\nvar\r\n VKey: Word;\r\n ConvKey: Longint;\r\n ScanCode: DWORD;\r\n Shift, Ctrl: Boolean;\r\n H: Windows.HWND;\r\nbegin\r\n H := FindWindow(PChar(AppName), nil);\r\n if H <> 0 then\r\n begin\r\n ConvKey := OemKeyScan(Ord(Key));\r\n Shift := (ConvKey and $00020000) <> 0;\r\n Ctrl := (ConvKey and $00040000) <> 0;\r\n ScanCode := ConvKey and $000000FF or $FF00;\r\n VKey := Ord(Key);\r\n ScanCode := (ScanCode shl 16) or 1;\r\n if Shift then\r\n SendShift(H, True);\r\n if Ctrl then\r\n SendCtrl(H, True);\r\n SendMessage(H, WM_KEYDOWN, VKey, LPARAM(ScanCode));\r\n SendMessage(H, WM_CHAR, VKey, LPARAM(ScanCode));\r\n ScanCode := ScanCode or $C0000000;\r\n SendMessage(H, WM_KEYUP, VKey, LPARAM(ScanCode));\r\n if Shift then\r\n SendShift(H, False);\r\n if Ctrl then\r\n SendCtrl(H, False);\r\n Result := True;\r\n end\r\n else\r\n Result := False;\r\nend;\r\n\r\n\r\n\r\n{$IFDEF MSWINDOWS}\r\n\r\nprocedure RebuildIconCache;\r\nvar\r\n Dummy: DWORD;\r\nbegin\r\n SendMessageTimeout(HWND_BROADCAST, WM_SETTINGCHANGE, SPI_SETNONCLIENTMETRICS,\r\n LPARAM(PChar('WindowMetrics')), SMTO_NORMAL or SMTO_ABORTIFHUNG, 10000, {$IFDEF RTL230_UP}@{$ENDIF}Dummy);\r\nend;\r\n\r\nprocedure AssociateFileExtension(const IconPath, ProgramName, Path, Extension: string);\r\nbegin\r\n with TRegistry.Create do\r\n begin\r\n RootKey := HKEY_CLASSES_ROOT;\r\n OpenKey(ProgramName, True);\r\n WriteString('', ProgramName);\r\n if IconPath <> '' then\r\n begin\r\n OpenKey(RC_DefaultIcon, True);\r\n WriteString('', IconPath);\r\n end;\r\n CloseKey;\r\n OpenKey(ProgramName, True);\r\n OpenKey('shell', True);\r\n OpenKey('open', True);\r\n OpenKey('command', True);\r\n WriteString('', '\"' + Path + '\" \"%1\"');\r\n Free;\r\n end;\r\n with TRegistry.Create do\r\n begin\r\n RootKey := HKEY_CLASSES_ROOT;\r\n OpenKey('.' + Extension, True);\r\n WriteString('', ProgramName);\r\n Free;\r\n end;\r\n RebuildIconCache;\r\nend;\r\n\r\nprocedure AssociateExtension(const IconPath, ProgramName, Path, Extension: string);\r\nbegin\r\n AssociateFileExtension(IconPath, ProgramName, Path, Extension);\r\nend;\r\n\r\nfunction GetRecentDocs: TStringList;\r\n\r\nvar\r\n Path: string;\r\n T: TSearchRec;\r\n Res: Integer;\r\n\r\nbegin\r\n Result := TStringList.Create;\r\n Path := IncludeTrailingPathDelimiter(GetRecentFolder);\r\n //search for all files\r\n Res := FindFirst(Path + '*.*', faAnyFile, T);\r\n try\r\n while Res = 0 do\r\n begin\r\n if (T.Name <> '.') and (T.Name <> '..') then\r\n Result.Add(Path + T.Name);\r\n Res := FindNext(T);\r\n end;\r\n finally\r\n FindClose(T);\r\n end;\r\nend;\r\n\r\n{ (rb) Duplicate of JvWinDialogs.AddToRecentDocs }\r\n\r\nprocedure AddToRecentDocs(const FileName: string);\r\nbegin\r\n SHAddToRecentDocs(SHARD_PATH, PChar(FileName));\r\nend;\r\n\r\nfunction EnumWindowsProc(Handle: THandle; LParam: TStrings): Boolean; stdcall;\r\nvar\r\n St: array [0..256] of Char;\r\n St2: string;\r\nbegin\r\n if Windows.IsWindowVisible(Handle) then\r\n begin\r\n GetWindowText(Handle, St, SizeOf(St));\r\n St2 := St;\r\n if St2 <> '' then\r\n with TStrings(LParam) do\r\n AddObject(St2, TObject(Handle));\r\n end;\r\n Result := True;\r\nend;\r\n\r\nprocedure GetVisibleWindows(List: TStrings);\r\nbegin\r\n List.BeginUpdate;\r\n try\r\n List.Clear;\r\n EnumWindows(@EnumWindowsProc, LPARAM(List));\r\n finally\r\n List.EndUpdate;\r\n end;\r\nend;\r\n\r\n{$ENDIF MSWINDOWS}\r\n// from JvComponentFunctions\r\n\r\nfunction StrPosNoCase(const psSub, psMain: string): Integer;\r\nbegin\r\n Result := Pos(AnsiUpperCase(psSub), AnsiUpperCase(psMain));\r\nend;\r\n\r\nfunction StrRestOf(const Ps: string; const N: Integer): string;\r\nbegin\r\n Result := Copy(Ps, N, {(Length(Ps) - N + 1)} MaxInt);\r\nend;\r\n\r\n{!!!!!!!! use these because the JCL one is badly broken }\r\n\r\n{ I am using this one purely as an internal for StrReplace\r\n\r\n Replaces parts of a string with new text. iUpdatePos is the last update position\r\n i.e. the position where substr was found + the length of the replacement string + 1.\r\n Use 0 first time in }\r\n\r\nfunction StrReplaceInstance(const psSource, psSearch, psReplace: string;\r\n var piUpdatePos: Integer; const pbCaseSens: Boolean): string;\r\nvar\r\n liIndex: Integer;\r\n lsCopy: string;\r\nbegin\r\n Result := psSource;\r\n if piUpdatePos >= Length(psSource) then\r\n Exit;\r\n if psSearch = '' then\r\n Exit;\r\n\r\n Result := Copy(psSource, 1, piUpdatePos - 1);\r\n lsCopy := StrRestOf(psSource, piUpdatePos);\r\n\r\n if pbCaseSens then\r\n liIndex := Pos(psSearch, lsCopy)\r\n else\r\n liIndex := StrPosNoCase(psSearch, lsCopy);\r\n if liIndex = 0 then\r\n begin\r\n Result := psSource;\r\n piUpdatePos := Length(psSource) + 1;\r\n Exit;\r\n end;\r\n\r\n Result := Result + Copy(lsCopy, 1, liIndex - 1);\r\n Result := Result + psReplace;\r\n piUpdatePos := Length(Result) + 1;\r\n Result := Result + StrRestOf(lsCopy, liIndex + Length(psSearch));\r\nend;\r\n\r\nfunction LStrReplace(const psSource, psSearch, psReplace: string;\r\n const pbCaseSens: Boolean): string;\r\nvar\r\n liUpdatePos: Integer;\r\nbegin\r\n liUpdatePos := 0;\r\n Result := psSource;\r\n while liUpdatePos < Length(Result) do\r\n Result := StrReplaceInstance(Result, psSearch, psReplace, liUpdatePos, pbCaseSens);\r\nend;\r\n\r\n{ if it's not a decimal point then it must be a digit, space or Currency symbol\r\n also always use $ for money }\r\n\r\nfunction CharIsMoney(const Ch: Char): Boolean;\r\nbegin\r\n Result := CharIsDigit(Ch) or (Ch = NativeSpace) or (Ch = '$') or (Ch = '-') or\r\n (Pos(Ch, JclFormatSettings.CurrencyString) > 0);\r\nend;\r\n\r\nfunction StrToCurrDef(const Str: string; Def: Currency): Currency;\r\nvar\r\n LStr: TJclStringBuilder;\r\n I: Integer;\r\n CharSet: TSysCharSet;\r\nbegin\r\n if Str = '' then\r\n Result := Def\r\n else\r\n begin\r\n LStr := TJclStringBuilder.Create(Length(Str));\r\n try\r\n CharSet := ['0'..'9', '-', '+', AnsiChar(JclFormatSettings.DecimalSeparator)];\r\n for I := 1 to Length(Str) do\r\n if CharInSet(Str[I], CharSet) then\r\n LStr.Append(Str[I]);\r\n try\r\n if not TextToFloat(PChar(LStr.ToString), Result, fvCurrency) then\r\n Result := Def;\r\n except\r\n Result := Def;\r\n end;\r\n finally\r\n LStr.Free;\r\n end;\r\n end;\r\nend;\r\n\r\n{ JvStrConvertErrorFmt used from JvSafeStrToFloat }\r\nprocedure JvStrConvertErrorFmt(ResString: PResStringRec; const Args: array of const);\r\nbegin\r\n raise EJvConvertError.CreateResFmt(ResString, Args); { will be also caught if you catch E:EConvertERror }\r\nend;\r\n\r\n{$IFNDEF RTL150_UP}\r\nfunction TextToFloatD5D6(Buffer: PAnsiChar; var Value; ValueType: TFloatValue;\r\n const FormatSettings: TFormatSettings): Boolean;\r\nvar\r\n DecimalSep: Char;\r\nbegin\r\n { not threadsafe }\r\n DecimalSep := DecimalSeparator;\r\n try\r\n DecimalSeparator := FormatSettings.DecimalSeparator;\r\n Result := TextToFloat(Buffer, Value, ValueType);\r\n finally\r\n DecimalSeparator := DecimalSep;\r\n end;\r\nend;\r\n{$ENDIF ~RTL150_UP}\r\n\r\n\r\n{ _JvSafeStrToFloat: [PRIVATE INTERNAL FUNCTION]\r\n\r\n [ not to be called outside this unit, see below for public api ]\r\n\r\n This is a refactored version of the internal guts of the former routine\r\n StrToFloatDefIgnoreInvalidCharacters with some improvements made to decimal\r\n separator handling.\r\n}\r\nfunction _JvSafeStrToFloat(const Str: string; aDecimalSeparator: Char; var OutValue: Extended): Boolean;\r\nvar\r\n LStr: TJclStringBuilder;\r\n I: Integer;\r\n CharSet: TSysCharSet;\r\n LocalFormatSettings: TFormatSettings;\r\nbegin\r\n Result := false;\r\n if Str = '' then\r\n Exit; { hows this for a nice optimization? WPostma. }\r\n\r\n { Locale Handling logic October 2008 supercedes former StrToFloatUS functionality. }\r\n {$IFDEF RTL150_UP}\r\n LocalFormatSettings.ThousandSeparator := GetLocaleChar(LOCALE_USER_DEFAULT, LOCALE_STHOUSAND, '.');\r\n LocalFormatSettings.DecimalSeparator := GetLocaleChar(LOCALE_USER_DEFAULT, LOCALE_SDECIMAL, '.');\r\n {$ELSE}\r\n LocalFormatSettings.DecimalSeparator := DecimalSeparator;\r\n {$ENDIF RTL150_UP}\r\n if aDecimalSeparator = ' ' then {magic mode}\r\n aDecimalSeparator := LocalFormatSettings.DecimalSeparator { default case! use system defaults! }\r\n else\r\n LocalFormatSettings.DecimalSeparator := aDecimalSeparator; { custom format specified! }\r\n\r\n { Cross-codepage safety feature: Handed '1.2', a string without a comma,\r\n but which is obviously a floating point number, convert it properly also.\r\n This functionality is important for JvCsvDataSet and may be important in other\r\n places. }\r\n if (Pos(USDecimalSeparator, Str) > 0) and (Pos(aDecimalSeparator, Str) = 0) then\r\n begin\r\n aDecimalSeparator := USDecimalSeparator; { automatically works when US decimal values are encountered }\r\n LocalFormatSettings.DecimalSeparator := aDecimalSeparator; { custom format specified! }\r\n end;\r\n\r\n LStr := TJclStringBuilder.Create(Length(Str));\r\n try\r\n CharSet := ['0'..'9', '-', '+', 'e', 'E', AnsiChar(aDecimalSeparator)];\r\n //if (aDecimalSeparator<>USDecimalSeparator) then\r\n // CharSet := CharSet + [USDecimalSeparator]; { we allow US Decimal separators, even when it's not the regional setting, we just grandfather it in as valid }\r\n\r\n for I := 1 to Length(Str) do\r\n if CharInSet(Str[I], CharSet) then\r\n LStr.Append(Str[I]);\r\n\r\n\r\n if LStr.Length > 0 then\r\n try\r\n { the string '-' fails StrToFloat, but it can be interpreted as 0 }\r\n if LStr[LStr.Length - 1] = '-' then\r\n LStr.Append('0');\r\n\r\n { a string that ends in a '.' such as '12.' fails StrToFloat,\r\n but as far as I am concerned, it may as well be interpreted as 12.0 }\r\n if LStr[LStr.Length - 1] = aDecimalSeparator then\r\n LStr.Append('0');\r\n\r\n {$IFDEF RTL150_UP}\r\n if not TextToFloat(PChar(LStr.ToString), OutValue, fvExtended, LocalFormatSettings) then\r\n {$ELSE}\r\n if not TextToFloatD5D6(PChar(LStr.ToString), OutValue, fvExtended, LocalFormatSettings) then\r\n {$ENDIF RTL150_UP}\r\n Result := False\r\n else\r\n Result := True; { success! }\r\n\r\n except\r\n Result := False;\r\n end;\r\n finally\r\n LStr.Free;\r\n end;\r\nend;\r\n\r\n// JvSafeStrToFloatDef:\r\n//\r\n// Note: before using StrToFloatDef, please be aware that it will ignore\r\n// any character that is not a valid character for a float, which is different\r\n// from what the one in Delphi 6 up is doing. This has been documented in Mantis\r\n// issue# 2935: http://homepages.borland.com/jedi/issuetracker/view.php?id=2935\r\n//\r\n// This function was extended by WPostma, to allow specification of custom decimal\r\n// separators. This was required by JvCsvDataSet and may be required elsewhere in the\r\n// VCL wherever custom (fixed) non-current-region-settings floating point value\r\n// encoding must be supported. We renamed this from StrToFloatDefIgnoreInvalidCharacters\r\n// to JvSafeStrToFloatDef because it has multiple \"floating point runtime exception safety\"\r\n// enhancements.\r\nfunction JvSafeStrToFloatDef(const Str: string; Def: Extended; aDecimalSeparator: Char): Extended;\r\nbegin\r\n { one handy dandy api expects a Default value returned instead }\r\n if not _JvSafeStrToFloat(Str, aDecimalSeparator, Result) then\r\n Result := Def; { failed, use default }\r\nend;\r\n\r\n// New routine, same as JvSafeStrToFloatDef but it will raise a conversion exception,\r\n// for cases when you actually want to handle an EConvertError yourself and where\r\n// there is no convenient or possible float value for your case.\r\nfunction JvSafeStrToFloat(const Str: string; aDecimalSeparator: Char): Extended;\r\nbegin\r\n { the other handy dandy api style expects us to raise an EConvertError. }\r\n if not _JvSafeStrToFloat(Str, aDecimalSeparator, Result) then\r\n JvStrConvertErrorFmt(@SInvalidFloat, [Str]); {failed, raise exception }\r\nend;\r\n\r\nfunction IntToExtended(I: Integer): Extended;\r\nbegin\r\n Result := I;\r\nend;\r\n\r\nfunction GetChangedText(const Text: string; SelStart, SelLength: Integer; Key: Char): string;\r\nbegin\r\n { take the original text, replace what will be overwritten with new value }\r\n Result := Text;\r\n\r\n if SelLength > 0 then\r\n Delete(Result, SelStart + 1, SelLength);\r\n if Key <> #0 then\r\n Insert(Key, Result, SelStart + 1);\r\nend;\r\n\r\n{ \"window\" technique for years to translate 2 digits to 4 digits.\r\n The window is 100 years wide\r\n The pivot year is the lower edge of the window\r\n A pivot year of 1900 is equivalent to putting 1900 before every 2-digit year\r\n if pivot is 1940, then 40 is interpreted as 1940, 00 as 2000 and 39 as 2039\r\n The system default is 1950\r\n\r\n Why the reimplementation?\r\n JclDatetime.Make4DigitYear will fail after 2100, this won't\r\n note that in this implementation pivot is a 4-digit year\r\n I have made it accept JclDatetime.Make4DigitYear's 2 digit pivot years.\r\n They are expanded by adding 1900.\r\n\r\n It is also better in that a valid 4-digit year will pass through unchanged,\r\n not fail an assertion.\r\n}\r\n\r\nfunction MakeYear4Digit(Year, Pivot: Integer): Integer;\r\nvar\r\n Century: Integer;\r\nbegin\r\n if Pivot < 0 then\r\n raise Exception.CreateRes(@RsEPivotLessThanZero);\r\n\r\n { map 100 to zero }\r\n if Year = 100 then\r\n Year := 0;\r\n if Pivot = 100 then\r\n Pivot := 0;\r\n\r\n // turn 2 digit pivot to 4 digit\r\n if Pivot < 100 then\r\n Pivot := Pivot + 1900;\r\n\r\n { turn 2 digit years to 4 digits }\r\n if (Year >= 0) and (Year < 100) then\r\n begin\r\n Century := (Pivot div 100) * 100;\r\n\r\n Result := Year + Century; // give the result the same century as the pivot\r\n if Result < Pivot then\r\n // cannot be lower than the Pivot\r\n Result := Result + 100;\r\n end\r\n else\r\n Result := Year;\r\nend;\r\n\r\nfunction StrIsInteger(const S: string): Boolean;\r\nvar\r\n I: Integer;\r\n Ch: Char;\r\nbegin\r\n Result := S <> '';\r\n for I := 1 to Length(S) do\r\n begin\r\n Ch := Char(S[I]);\r\n if not CharIsNumberChar(Ch) or (Ch = JclFormatSettings.DecimalSeparator) then //Az\r\n begin\r\n Result := False;\r\n Exit;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction StrIsFloatMoney(const Ps: string): Boolean;\r\nvar\r\n I, liDots: Integer;\r\n Ch: Char;\r\nbegin\r\n Result := True;\r\n liDots := 0;\r\n\r\n for I := 1 to Length(Ps) do\r\n begin\r\n { allow digits, space, Currency symbol and one decimal dot }\r\n Ch := Ps[I];\r\n\r\n if Ch = JclFormatSettings.DecimalSeparator then\r\n begin\r\n Inc(liDots);\r\n if liDots > 1 then\r\n begin\r\n Result := False;\r\n Break;\r\n end;\r\n end\r\n else\r\n if not CharIsMoney(Ch) then\r\n begin\r\n Result := False;\r\n Break;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction StrIsDateTime(const Ps: string): Boolean;\r\nconst\r\n MIN_DATE_TIME_LEN = 6; {2Jan02 }\r\n MAX_DATE_TIME_LEN = 30; { 30 chars or so in '12 December 1999 12:23:23:00' }\r\nvar\r\n I: Integer;\r\n Ch: Char;\r\n liColons, liSlashes, liSpaces, liDigits, liAlpha: Integer;\r\n lbDisqualify: Boolean;\r\nbegin\r\n if Length(Ps) < MIN_DATE_TIME_LEN then\r\n begin\r\n Result := False;\r\n Exit;\r\n end;\r\n\r\n if Length(Ps) > MAX_DATE_TIME_LEN then\r\n begin\r\n Result := False;\r\n Exit;\r\n end;\r\n\r\n lbDisqualify := False;\r\n liColons := 0;\r\n liSlashes := 0;\r\n liSpaces := 0;\r\n liDigits := 0;\r\n liAlpha := 0;\r\n\r\n for I := 1 to Length(Ps) do\r\n begin\r\n Ch := Ps[I];\r\n\r\n if Ch = ':' then\r\n Inc(liColons)\r\n else\r\n if Ch = NativeForwardSlash then\r\n Inc(liSlashes)\r\n else\r\n if CharIsSpace(Ch) then\r\n Inc(liSpaces)\r\n else\r\n if CharIsDigit(Ch) then\r\n Inc(liDigits)\r\n else\r\n if CharIsAlpha(Ch) then\r\n Inc(liAlpha)\r\n else\r\n begin\r\n // no wierd punctuation in dates!\r\n lbDisqualify := True;\r\n Break;\r\n end;\r\n end;\r\n\r\n Result := False;\r\n if not lbDisqualify then\r\n { a date must have colons and slashes and spaces, but not to many of each }\r\n if (liColons > 0) or (liSlashes > 0) or (liSpaces > 0) then\r\n { only 2 slashes in \"dd/mm/yy\" or 3 colons in \"hh:mm:ss:ms\" or 6 spaces \"yy mm dd hh mm ss ms\" }\r\n if (liSlashes <= 2) and (liColons <= 3) and (liSpaces <= 6) then\r\n { must have some digits (min 3 digits, eg in \"2 jan 02\", max 16 dgits in \"01/10/2000 10:10:10:10\"\r\n longest month name is 8 chars }\r\n if (liDigits >= 3) and (liDigits <= 16) and (liAlpha <= 10) then\r\n Result := True;\r\n\r\n { define in terms of results - if I can interpret it as a date, then I can }\r\n if Result then\r\n Result := (SafeStrToDateTime(PreformatDateString(Ps)) <> 0);\r\nend;\r\n\r\nfunction PreformatDateString(Ps: string): string;\r\nvar\r\n I: Integer;\r\nbegin\r\n { turn any month names to numbers }\r\n\r\n { use the StrReplace in stringfunctions -\r\n the one in JclStrings is badly broken and brings down the app }\r\n\r\n for I := JclFormatSettings.MonthNamesLowIndex to JclFormatSettings.MonthNamesHighIndex do\r\n Ps := LStrReplace(Ps, JclFormatSettings.LongMonthNames[I], IntToStr(I), False);\r\n\r\n { now that 'January' is gone, catch 'Jan' }\r\n for I := JclFormatSettings.MonthNamesLowIndex to JclFormatSettings.MonthNamesHighIndex do\r\n Ps := LStrReplace(Ps, JclFormatSettings.ShortMonthNames[I], IntToStr(I), False);\r\n\r\n { remove redundant spaces }\r\n Ps := LStrReplace(Ps, NativeSpace + NativeSpace, NativeSpace, False);\r\n\r\n Result := Ps;\r\nend;\r\n\r\nfunction BooleanToInteger(const B: Boolean): Integer;\r\nbegin\r\n Result := Ord(B);\r\nend;\r\n\r\n{ from my ConvertFunctions unit }\r\n\r\nfunction StringToBoolean(const Ps: string): Boolean;\r\nconst\r\n TRUE_STRINGS: array [1..5] of string = ('True', 't', 'y', 'yes', '1');\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := False;\r\n\r\n for I := Low(TRUE_STRINGS) to High(TRUE_STRINGS) do\r\n if AnsiSameText(Ps, TRUE_STRINGS[I]) then\r\n begin\r\n Result := True;\r\n Break;\r\n end;\r\nend;\r\n\r\nfunction SafeStrToDateTime(const Ps: string): TDateTime;\r\nbegin\r\n try\r\n Result := StrToDateTime(PreformatDateString(Ps));\r\n except\r\n on E: EConvertError do\r\n Result := 0.0\r\n else\r\n raise;\r\n end;\r\nend;\r\n\r\nfunction SafeStrToDate(const Ps: string): TDateTime;\r\nbegin\r\n try\r\n Result := StrToDate(PreformatDateString(Ps));\r\n except\r\n on E: EConvertError do\r\n Result := 0.0\r\n else\r\n raise;\r\n end;\r\nend;\r\n\r\nfunction SafeStrToTime(const Ps: string): TDateTime;\r\nbegin\r\n try\r\n Result := StrToTime(Ps)\r\n except\r\n on E: EConvertError do\r\n Result := 0.0\r\n else\r\n raise;\r\n end;\r\nend;\r\n\r\n{!! from strFunctions }\r\n\r\nfunction StrDeleteChars(const Ps: string; const piPos: Integer; const piCount: Integer): string;\r\nbegin\r\n Result := Copy(Ps, 1, piPos - 1) + StrRestOf(Ps, piPos + piCount);\r\nend;\r\n\r\nfunction StrDelete(const psSub, psMain: string): string;\r\nvar\r\n liPos: Integer;\r\nbegin\r\n Result := psMain;\r\n if psSub = '' then\r\n Exit;\r\n\r\n liPos := StrIPos(psSub, psMain);\r\n\r\n while liPos > 0 do\r\n begin\r\n Result := StrDeleteChars(Result, liPos, Length(psSub));\r\n liPos := StrIPos(psSub, Result);\r\n end;\r\nend;\r\n\r\nfunction TimeOnly(pcValue: TDateTime): TTime;\r\nbegin\r\n Result := Frac(pcValue);\r\nend;\r\n\r\nfunction DateOnly(pcValue: TDateTime): TDate;\r\nbegin\r\n Result := Trunc(pcValue);\r\nend;\r\n\r\n{ have to do this as it depends what the datekind of the control is}\r\n\r\nfunction DateIsNull(const pdtValue: TDateTime; const pdtKind: TdtKind): Boolean;\r\nbegin\r\n Result := False;\r\n case pdtKind of\r\n dtkDateOnly:\r\n Result := pdtValue < 1; //if date only then anything less than 1 is considered null\r\n dtkTimeOnly:\r\n Result := Frac(pdtValue) = NullEquivalentDate; //if time only then anything without a remainder is null\r\n dtkDateTime:\r\n Result := pdtValue = NullEquivalentDate;\r\n end;\r\nend;\r\n\r\nfunction OSCheck(RetVal: Boolean): Boolean;\r\nbegin\r\n if not RetVal then\r\n RaiseLastOSError;\r\n Result := RetVal;\r\nend;\r\n\r\nfunction MinimizeFileName(const FileName: string; Canvas: TCanvas; MaxLen: Integer): string;\r\nvar\r\n R: TRect;\r\nbegin\r\n Result := FileName;\r\n R := Rect(0, 0, MaxLen, Canvas.TextHeight('Wq'));\r\n UniqueString(Result);\r\n if DrawText(Canvas.Handle, PChar(Result), Length(Result), R,\r\n DT_SINGLELINE or DT_MODIFYSTRING or DT_PATH_ELLIPSIS or DT_CALCRECT or\r\n DT_NOPREFIX) <= 0 then\r\n Result := FileName;\r\nend;\r\n\r\nfunction MinimizeText(const Text: string; Canvas: TCanvas;\r\n MaxWidth: Integer): string;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := Text;\r\n I := 1;\r\n while (I <= Length(Text)) and (Canvas.TextWidth(Result) > MaxWidth) do\r\n begin\r\n Inc(I);\r\n Result := Copy(Text, 1, Max(0, Length(Text) - I)) + '...';\r\n end;\r\nend;\r\n\r\n{$IFDEF MSWINDOWS}\r\n\r\nfunction RunDLL32(const ModuleName, FuncName, CmdLine: string; WaitForCompletion: Boolean; CmdShow: Integer =\r\n SW_SHOWDEFAULT): Boolean;\r\nvar\r\n SI: TStartupInfo;\r\n PI: TProcessInformation;\r\n S: string;\r\nbegin\r\n SI.cb := SizeOf(SI);\r\n GetStartupInfo(SI);\r\n SI.wShowWindow := CmdShow;\r\n S := SysUtils.Format('rundll32.exe %s,%s %s', [ModuleName, FuncName, CmdLine]);\r\n Result := CreateProcess(nil, PChar(S), nil, nil, False, 0, nil, nil, SI, PI);\r\n try\r\n if WaitForCompletion then\r\n Result := WaitForSingleObject(PI.hProcess, INFINITE) <> WAIT_FAILED;\r\n finally\r\n CloseHandle(PI.hThread);\r\n CloseHandle(PI.hProcess);\r\n end;\r\nend;\r\n\r\nprocedure RunDll32Internal(Wnd: THandle; const DLLName, FuncName, CmdLine: string; CmdShow: Integer = SW_SHOWDEFAULT);\r\nvar\r\n H: THandle;\r\n P: TRunDLL32Proc;\r\nbegin\r\n H := SafeLoadLibrary(DLLName, SEM_FAILCRITICALERRORS or SEM_NOOPENFILEERRORBOX);\r\n if H <> 0 then\r\n begin\r\n try\r\n P := GetProcAddress(H, PChar(FuncName));\r\n if Assigned(P) then\r\n P(Wnd, H, PChar(CmdLine), CmdShow);\r\n finally\r\n FreeLibrary(H);\r\n end;\r\n end;\r\nend;\r\n\r\ntype\r\n // (p3) from ShLwAPI\r\n TDLLVersionInfo = packed record\r\n cbSize: DWORD;\r\n dwMajorVersion: DWORD;\r\n dwMinorVersion: DWORD;\r\n dwBuildNumber: DWORD;\r\n dwPlatformId: DWORD;\r\n end;\r\n\r\nfunction GetDLLVersion(const DLLName: string; var pdwMajor, pdwMinor: Integer): Boolean;\r\nvar\r\n hDLL, hr: THandle;\r\n pDllGetVersion: function(var Dvi: TDLLVersionInfo): Integer; stdcall;\r\n Dvi: TDLLVersionInfo;\r\nbegin\r\n hDLL := SafeLoadLibrary(DLLName);\r\n if hDLL <> 0 then\r\n begin\r\n Result := True;\r\n (* You must get this function explicitly\r\n because earlier versions of the DLL's\r\n don't implement this function.\r\n That makes the lack of implementation\r\n of the function a version marker in itself. *)\r\n @pDllGetVersion := GetProcAddress(hDLL, PChar('DllGetVersion'));\r\n if Assigned(pDllGetVersion) then\r\n begin\r\n FillChar(Dvi, SizeOf(Dvi), 0);\r\n Dvi.cbSize := SizeOf(Dvi);\r\n hr := pDllGetVersion(Dvi);\r\n if hr = 0 then\r\n begin\r\n pdwMajor := Dvi.dwMajorVersion;\r\n pdwMinor := Dvi.dwMinorVersion;\r\n end;\r\n end\r\n else (* If GetProcAddress failed, the DLL is a version previous to the one shipped with IE 3.x. *)\r\n begin\r\n pdwMajor := 4;\r\n pdwMinor := 0;\r\n end;\r\n FreeLibrary(hDLL);\r\n Exit;\r\n end;\r\n Result := False;\r\nend;\r\n\r\n{$ENDIF MSWINDOWS}\r\n{from JvVCLUtils }\r\n\r\n{ Exceptions }\r\n\r\nprocedure ResourceNotFound(ResID: PChar);\r\nvar\r\n S: string;\r\nbegin\r\n if DWORD_PTR(ResID) <= $FFFF then\r\n S := IntToStr(INT_PTR(ResID))\r\n else\r\n S := ResID;\r\n raise EResNotFound.CreateResFmt(@SResNotFound, [S]);\r\nend;\r\n\r\nfunction EmptyRect: TRect;\r\nbegin\r\n Result := Rect(0, 0, 0, 0);\r\nend;\r\n\r\nfunction RectWidth(R: TRect): Integer;\r\nbegin\r\n Result := Abs(R.Right - R.Left);\r\nend;\r\n\r\nfunction RectHeight(R: TRect): Integer;\r\nbegin\r\n Result := Abs(R.Bottom - R.Top);\r\nend;\r\n\r\nprocedure RectNormalize(var R: TRect);\r\nvar\r\n Temp: Integer;\r\nbegin\r\n if R.Left > R.Right then\r\n begin\r\n Temp := R.Left;\r\n R.Left := R.Right;\r\n R.Right := Temp;\r\n end;\r\n if R.Top > R.Bottom then\r\n begin\r\n Temp := R.Top;\r\n R.Top := R.Bottom;\r\n R.Bottom := Temp;\r\n end;\r\nend;\r\n\r\nfunction CompareRect(const R1, R2: TRect): Boolean;\r\nbegin\r\n Result := (R1.Left = R2.Left) and (R1.Top = R2.Top) and\r\n (R1.Right = R2.Right) and (R1.Bottom = R2.Bottom);\r\nend;\r\n\r\nfunction RectIsSquare(const R: TRect): Boolean;\r\nbegin\r\n Result := RectHeight(R) = RectWidth(R);\r\nend;\r\n\r\nfunction RectSquare(var ARect: TRect; AMaxSize: Integer): Boolean;\r\nconst\r\n cSquareMinSize = 4; // Min size is 4 pixel\r\nvar\r\n iMinSize, iW, iH :Integer;\r\n pTopLeft, pRightBottom: TPoint;\r\nbegin\r\n Result := False;\r\n if IsRectEmpty(ARect) or ((AMaxSize <> -1) and (AMaxSize < cSquareMinSize)) then\r\n Exit\r\n else if RectIsSquare(ARect) then\r\n begin\r\n Result := True;\r\n Exit;\r\n end;\r\n\r\n iW := RectWidth(ARect);\r\n iH := RectHeight(ARect);\r\n iMinSize := Min(iW, iH);\r\n if AMaxSize = -1 then\r\n AMaxSize := iMinSize\r\n else\r\n AMaxSize := Min(iMinSize, AMaxSize);\r\n\r\n pTopLeft.Y :=ARect.Top + (iH - AMaxSize) div 2;\r\n pTopLeft.X :=ARect.Left + (iW - AMaxSize) div 2;\r\n\r\n pRightBottom.Y := pTopLeft.Y + AMaxSize;\r\n pRightBottom.X := pTopLeft.X + AMaxSize;\r\n\r\n ARect := Rect(pTopLeft, pRightBottom);\r\n Result := True;\r\nend;\r\n\r\n{$IFDEF MSWINDOWS}\r\n{ Service routines }\r\n\r\nfunction LoadDLL(const LibName: string): THandle;\r\nbegin\r\n Result := SafeLoadLibrary(LibName);\r\n if Result = 0 then\r\n OSCheck(False);\r\nend;\r\n\r\nfunction GetWindowsVersionString: string;\r\nconst\r\n sWindowsVersion = 'Windows %s %d.%.2d.%.3d %s';\r\nvar\r\n Ver: TOSVersionInfo;\r\n Platfrm: string[4];\r\nbegin\r\n Ver.dwOSVersionInfoSize := SizeOf(Ver);\r\n GetVersionEx(Ver);\r\n with Ver do\r\n begin\r\n case dwPlatformId of\r\n VER_PLATFORM_WIN32s:\r\n Platfrm := '32s';\r\n VER_PLATFORM_WIN32_WINDOWS:\r\n begin\r\n dwBuildNumber := dwBuildNumber and $0000FFFF;\r\n if (dwMajorVersion > 4) or ((dwMajorVersion = 4) and\r\n (dwMinorVersion >= 10)) then\r\n Platfrm := '98'\r\n else\r\n Platfrm := '95';\r\n end;\r\n VER_PLATFORM_WIN32_NT: Platfrm := 'NT';\r\n end;\r\n Result := Trim(SysUtils.Format(sWindowsVersion, [Platfrm, dwMajorVersion,\r\n dwMinorVersion, dwBuildNumber, szCSDVersion]));\r\n end;\r\nend;\r\n\r\n{ RegisterServer procedure written by Vladimir Gaitanoff, 2:50/430.2 }\r\n\r\nfunction RegisterServer(const ModuleName: string): Boolean;\r\ntype\r\n TCOMFunc = function: HRESULT;\r\nconst\r\n S_OK = $00000000;\r\nvar\r\n Handle: THandle;\r\n DllRegServ: TCOMFunc;\r\nbegin\r\n Handle := LoadDLL(ModuleName);\r\n try\r\n DllRegServ := GetProcAddress(Handle, 'DllRegisterServer');\r\n Result := Assigned(DllRegServ) and (DllRegServ() = S_OK);\r\n finally\r\n FreeLibrary(Handle);\r\n end;\r\nend;\r\n\r\n// UnregisterServer by Ralf Kaiser patterned on RegisterServer\r\nfunction UnregisterServer(const ModuleName: string): Boolean;\r\ntype\r\n TCOMFunc = function: HRESULT;\r\nconst\r\n S_OK = $00000000;\r\nvar\r\n Handle: THandle;\r\n DllUnRegServ: TCOMFunc;\r\n DllCanUnloadNow: TCOMFunc;\r\nbegin\r\n Handle := LoadDLL(ModuleName);\r\n try\r\n DllUnRegServ := GetProcAddress(Handle, 'DllUnregisterServer');\r\n DllCanUnloadNow := GetProcAddress(Handle, 'DllCanUnloadNow');\r\n Result := Assigned(DllCanUnloadNow) and (DllCanUnloadNow() = S_OK) and\r\n Assigned(DllUnRegServ) and (DllUnRegServ() = S_OK);\r\n finally\r\n FreeLibrary(Handle);\r\n end;\r\nend;\r\n\r\nprocedure FreeUnusedOle;\r\nbegin\r\n FreeLibrary(GetModuleHandle('OleAut32'));\r\nend;\r\n\r\nfunction GetEnvVar(const VarName: string): string;\r\nbegin\r\n Result := GetEnvironmentVariable(VarName);\r\nend;\r\n\r\n{$ENDIF MSWINDOWS}\r\n\r\n{$IFDEF UNIX}\r\nfunction GetEnvVar(const VarName: string): string;\r\nbegin\r\n Result := getenv(PChar(VarName));\r\nend;\r\n{$ENDIF UNIX}\r\n\r\n{ String routines }\r\n\r\nprocedure SplitCommandLine(const CmdLine: string; var ExeName, Params: string);\r\n\r\n function SkipString(P: PChar): PChar;\r\n begin\r\n if P^ = '\"' then\r\n begin\r\n Inc(P);\r\n while (P^ <> #0) and (P^ <> '\"') do\r\n Inc(P);\r\n if P^ <> #0 then\r\n Inc(P);\r\n end\r\n else\r\n while P^ > ' ' do\r\n begin\r\n if P^ = '\"' then\r\n begin\r\n Inc(P);\r\n while (P^ <> #0) and (P^ <> '\"') do\r\n Inc(P);\r\n if P^ = #0 then\r\n Break;\r\n end;\r\n Inc(P);\r\n end;\r\n Result := P;\r\n end;\r\n\r\n function SkipWhiteChars(P: PChar): PChar;\r\n begin\r\n Result := P;\r\n while (Result^ <> #0) and (Result^ <= ' ') do\r\n Inc(Result);\r\n end;\r\n\r\nvar\r\n F, P: PChar;\r\nbegin\r\n ExeName := '';\r\n Params := '';\r\n if CmdLine <> '' then\r\n begin\r\n F := PChar(CmdLine);\r\n P := SkipString(F);\r\n if F^ = '\"' then\r\n SetString(ExeName, F + 1, P - F - 2)\r\n else\r\n SetString(ExeName, F, P - F);\r\n P := SkipWhiteChars(P);\r\n SetString(Params, P, StrLen(P));\r\n end;\r\nend;\r\n\r\nfunction AnsiUpperFirstChar(const S: string): string;\r\nvar\r\n Temp: string;\r\nbegin\r\n Result := AnsiLowerCase(S);\r\n if S <> '' then\r\n begin\r\n Temp := Result[1];\r\n Temp := AnsiUpperCase(Temp);\r\n Result[1] := Temp[1];\r\n end;\r\nend;\r\n\r\nfunction StrPAlloc(const S: string): PChar;\r\nbegin\r\n Result := StrPCopy(StrAlloc(Length(S) + 1), S);\r\nend;\r\n\r\nfunction StringToPChar(var S: string): PChar;\r\nbegin\r\n Result := PChar(S);\r\nend;\r\n\r\nfunction DropT(const S: string): string;\r\nbegin\r\n if (UpCase(S[1]) = 'T') and (Length(S) > 1) then\r\n Result := Copy(S, 2, MaxInt)\r\n else\r\n Result := S;\r\nend;\r\n\r\nfunction WindowClassName(Wnd: THandle): string;\r\nvar\r\n Buffer: array [0..255] of Char;\r\nbegin\r\n SetString(Result, Buffer, GetClassName(Wnd, Buffer, SizeOf(Buffer) - 1));\r\nend;\r\n\r\n\r\n\r\nfunction GetAnimation: Boolean;\r\nvar\r\n Info: TAnimationInfo;\r\nbegin\r\n Info.cbSize := SizeOf(Info);\r\n if SystemParametersInfo(SPI_GETANIMATION, Info.cbSize, @Info, 0) then\r\n Result := Info.iMinAnimate <> 0\r\n else\r\n Result := False;\r\nend;\r\n\r\nprocedure SetAnimation(Value: Boolean);\r\nvar\r\n Info: TAnimationInfo;\r\nbegin\r\n Info.cbSize := SizeOf(Info);\r\n Info.iMinAnimate := Ord(Value);\r\n SystemParametersInfo(SPI_SETANIMATION, Info.cbSize, @Info, 0);\r\nend;\r\n\r\nprocedure ShowWinNoAnimate(Handle: THandle; CmdShow: Integer);\r\nvar\r\n Animation: Boolean;\r\nbegin\r\n Animation := GetAnimation;\r\n if Animation then\r\n SetAnimation(False);\r\n ShowWindow(Handle, CmdShow);\r\n if Animation then\r\n SetAnimation(True);\r\nend;\r\n\r\nprocedure SwitchToWindow(Wnd: THandle; Restore: Boolean);\r\nbegin\r\n if Windows.IsWindowEnabled(Wnd) then\r\n begin\r\n SetForegroundWindow(Wnd);\r\n if Restore and Windows.IsWindowVisible(Wnd) then\r\n begin\r\n if not IsZoomed(Wnd) then\r\n SendMessage(Wnd, WM_SYSCOMMAND, SC_RESTORE, 0);\r\n Windows.SetFocus(Wnd);\r\n end;\r\n end;\r\nend;\r\n\r\nfunction GetWindowParent(Wnd: THandle): THandle;\r\nbegin\r\n Result := THandle(GetWindowLongPtr(Wnd, GWL_HWNDPARENT));\r\nend;\r\n\r\nprocedure ActivateWindow(Wnd: THandle);\r\nbegin\r\n if Wnd <> 0 then\r\n begin\r\n ShowWinNoAnimate(Wnd, SW_SHOW);\r\n SetForegroundWindow(Wnd);\r\n end;\r\nend;\r\n\r\n{$IFDEF BCB}\r\nfunction FindPrevInstance(const MainFormClass: ShortString; const ATitle: string): THandle;\r\n{$ELSE}\r\nfunction FindPrevInstance(const MainFormClass, ATitle: string): THandle;\r\n{$ENDIF BCB}\r\nvar\r\n BufClass, BufTitle: PChar;\r\nbegin\r\n Result := 0;\r\n if (MainFormClass = '') and (ATitle = '') then\r\n Exit;\r\n BufClass := nil;\r\n BufTitle := nil;\r\n if MainFormClass <> '' then\r\n BufClass := StrPAlloc(MainFormClass);\r\n if ATitle <> '' then\r\n BufTitle := StrPAlloc(ATitle);\r\n try\r\n Result := FindWindow(BufClass, BufTitle);\r\n finally\r\n StrDispose(BufTitle);\r\n StrDispose(BufClass);\r\n end;\r\nend;\r\n\r\nfunction WindowsEnum(Handle: HWND; var IsDelphi: Boolean): BOOL; stdcall;\r\nbegin\r\n if WindowClassName(Handle) = 'TAppBuilder' then\r\n begin\r\n IsDelphi := True;\r\n Result := False;\r\n end\r\n else\r\n Result := True;\r\nend;\r\n\r\n{$IFDEF BCB}\r\nfunction ActivatePrevInstance(const MainFormClass: ShortString; const ATitle: string): Boolean;\r\n{$ELSE}\r\nfunction ActivatePrevInstance(const MainFormClass, ATitle: string): Boolean;\r\n{$ENDIF BCB}\r\nvar\r\n PrevWnd, PopupWnd, ParentWnd: HWND;\r\n IsDelphi: Boolean;\r\nbegin\r\n Result := False;\r\n PrevWnd := FindPrevInstance(MainFormClass, ATitle);\r\n if PrevWnd <> 0 then\r\n begin\r\n ParentWnd := GetWindowParent(PrevWnd);\r\n while (ParentWnd <> GetDesktopWindow) and (ParentWnd <> 0) do\r\n begin\r\n PrevWnd := ParentWnd;\r\n ParentWnd := GetWindowParent(PrevWnd);\r\n end;\r\n if WindowClassName(PrevWnd) = 'TApplication' then\r\n begin\r\n IsDelphi := False;\r\n EnumThreadWindows(GetWindowTask(PrevWnd), @WindowsEnum, LPARAM(@IsDelphi));\r\n if IsDelphi then\r\n Exit;\r\n if IsIconic(PrevWnd) then\r\n begin { application is minimized }\r\n SendMessage(PrevWnd, WM_SYSCOMMAND, SC_RESTORE, 0);\r\n Result := True;\r\n Exit;\r\n end\r\n else\r\n ShowWinNoAnimate(PrevWnd, SW_SHOWNOACTIVATE);\r\n end\r\n else\r\n ActivateWindow(PrevWnd);\r\n PopupWnd := GetLastActivePopup(PrevWnd);\r\n if (PrevWnd <> PopupWnd) and Windows.IsWindowVisible(PopupWnd) and\r\n Windows.IsWindowEnabled(PopupWnd) then\r\n begin\r\n SetForegroundWindow(PopupWnd);\r\n end\r\n else\r\n ActivateWindow(PopupWnd);\r\n Result := True;\r\n end;\r\nend;\r\n\r\n{$IFDEF MSWINDOWS}\r\nfunction BrowseForFolderNative(const Handle: THandle; const Title: string; var Folder: string): Boolean;\r\nvar\r\n BrowseInfo: TBrowseInfo;\r\n Id: PItemIDList;\r\n FN: array [0..MAX_PATH] of Char;\r\nbegin\r\n with BrowseInfo do\r\n begin\r\n hwndOwner := Handle;\r\n pidlRoot := nil;\r\n pszDisplayName := FN;\r\n lpszTitle := PChar(Title);\r\n ulFlags := 0;\r\n lpfn := nil;\r\n end;\r\n Id := SHBrowseForFolder(BrowseInfo);\r\n Result := Id <> nil;\r\n if Result then\r\n begin\r\n SHGetPathFromIDList(Id, FN);\r\n Folder := FN;\r\n end;\r\nend;\r\n{$ENDIF MSWINDOWS}\r\n\r\nprocedure FitRectToScreen(var Rect: TRect);\r\nvar\r\n X, Y, Delta: Integer;\r\nbegin\r\n X := GetSystemMetrics(SM_CXSCREEN);\r\n Y := GetSystemMetrics(SM_CYSCREEN);\r\n if Rect.Right > X then\r\n begin\r\n Delta := Rect.Right - Rect.Left;\r\n Rect.Right := X;\r\n Rect.Left := Rect.Right - Delta;\r\n end;\r\n if Rect.Left < 0 then\r\n begin\r\n Delta := Rect.Right - Rect.Left;\r\n Rect.Left := 0;\r\n Rect.Right := Rect.Left + Delta;\r\n end;\r\n if Rect.Bottom > Y then\r\n begin\r\n Delta := Rect.Bottom - Rect.Top;\r\n Rect.Bottom := Y;\r\n Rect.Top := Rect.Bottom - Delta;\r\n end;\r\n if Rect.Top < 0 then\r\n begin\r\n Delta := Rect.Bottom - Rect.Top;\r\n Rect.Top := 0;\r\n Rect.Bottom := Rect.Top + Delta;\r\n end;\r\nend;\r\n\r\nprocedure CenterWindow(Wnd: THandle);\r\nvar\r\n R: TRect;\r\nbegin\r\n GetWindowRect(Wnd, R);\r\n R := Rect((GetSystemMetrics(SM_CXSCREEN) - R.Right + R.Left) div 2,\r\n (GetSystemMetrics(SM_CYSCREEN) - R.Bottom + R.Top) div 2,\r\n R.Right - R.Left, R.Bottom - R.Top);\r\n FitRectToScreen(R);\r\n SetWindowPos(Wnd, 0, R.Left, R.Top, 0, 0, SWP_NOACTIVATE or\r\n SWP_NOSIZE or SWP_NOZORDER);\r\nend;\r\n\r\n{ Delete the requested message from the queue, but throw back }\r\n{ any WM_QUIT msgs that PeekMessage may also return. }\r\n{ Copied from DbGrid.pas }\r\nprocedure KillMessage(Wnd: THandle; Msg: Cardinal);\r\nvar\r\n M: TMsg;\r\nbegin\r\n M.Message := 0;\r\n if PeekMessage(M, Wnd, Msg, Msg, PM_REMOVE) and (M.Message = WM_QUIT) then\r\n PostQuitMessage(M.WParam);\r\nend;\r\n\r\nprocedure SetWindowTop(const Handle: THandle; const Top: Boolean);\r\nconst\r\n TopFlag: array [Boolean] of THandle = (HWND_NOTOPMOST, HWND_TOPMOST);\r\nbegin\r\n SetWindowPos(Handle, TopFlag[Top], 0, 0, 0, 0, SWP_NOMOVE or\r\n SWP_NOSIZE or SWP_NOACTIVATE);\r\nend;\r\n\r\nfunction MakeVariant(const Values: array of Variant): Variant;\r\nbegin\r\n if High(Values) - Low(Values) > 1 then\r\n Result := VarArrayOf(Values)\r\n else\r\n if High(Values) - Low(Values) = 1 then\r\n Result := Values[Low(Values)]\r\n else\r\n Result := Null;\r\nend;\r\n\r\n{$IFDEF MSWINDOWS}\r\n{ Dialog units }\r\n\r\nfunction DialogUnitsToPixelsX(DlgUnits: Word): Word;\r\nbegin\r\n Result := (DlgUnits * LoWord(GetDialogBaseUnits)) div 4;\r\nend;\r\n\r\nfunction DialogUnitsToPixelsY(DlgUnits: Word): Word;\r\nbegin\r\n Result := (DlgUnits * HiWord(GetDialogBaseUnits)) div 8;\r\nend;\r\n\r\nfunction PixelsToDialogUnitsX(PixUnits: Word): Word;\r\nbegin\r\n Result := PixUnits * 4 div LoWord(GetDialogBaseUnits);\r\nend;\r\n\r\nfunction PixelsToDialogUnitsY(PixUnits: Word): Word;\r\nbegin\r\n Result := PixUnits * 8 div HiWord(GetDialogBaseUnits);\r\nend;\r\n\r\n{$ENDIF MSWINDOWS}\r\n\r\nfunction GetUniqueFileNameInDir(const Path, FileNameMask: string): string;\r\nvar\r\n CurrentName: string;\r\n I: Integer;\r\nbegin\r\n Result := '';\r\n for I := 0 to MaxInt do\r\n begin\r\n CurrentName := SysUtils.Format(FileNameMask, [I]);\r\n if not FileExists(NormalDir(Path) + CurrentName) then\r\n begin\r\n Result := CurrentName;\r\n Exit;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure AntiAlias(Clip: TBitmap);\r\nbegin\r\n AntiAliasRect(Clip, 0, 0, Clip.Width, Clip.Height);\r\nend;\r\n\r\n\r\n // (p3) duplicated from JvTypes to avoid JVCL dependencies\r\ntype\r\n TJvRGBTriple = packed record\r\n rgbBlue: Byte;\r\n rgbGreen: Byte;\r\n rgbRed: Byte;\r\n end;\r\n\r\ntype\r\n PJvRGBArray = ^TJvRGBArray;\r\n TJvRGBArray = array [0..32766] of TJvRGBTriple;\r\n\r\n\r\nprocedure AntiAliasRect(Clip: TBitmap;\r\n XOrigin, YOrigin, XFinal, YFinal: Integer);\r\nvar\r\n Tmp, X, Y: Integer;\r\n Line0, Line1, Line2: PJvRGBArray;\r\n OPF: TPixelFormat;\r\nbegin\r\n // swap values\r\n if XFinal < XOrigin then\r\n begin\r\n Tmp := XOrigin;\r\n XOrigin := XFinal;\r\n XFinal := Tmp;\r\n end;\r\n if YFinal < YOrigin then\r\n begin\r\n Tmp := YOrigin;\r\n YOrigin := YFinal;\r\n YFinal := Tmp;\r\n end;\r\n XOrigin := Max(1, XOrigin);\r\n YOrigin := Max(1, YOrigin);\r\n XFinal := Min(Clip.Width - 2, XFinal);\r\n YFinal := Min(Clip.Height - 2, YFinal);\r\n OPF := Clip.PixelFormat;\r\n Clip.PixelFormat := pf24bit;\r\n for Y := YOrigin to YFinal do\r\n begin\r\n Line0 := Clip.ScanLine[Y - 1];\r\n Line1 := Clip.ScanLine[Y];\r\n Line2 := Clip.ScanLine[Y + 1];\r\n for X := XOrigin to XFinal do\r\n begin\r\n Line1[X].rgbRed := (Line0[X].rgbRed + Line2[X].rgbRed + Line1[X - 1].rgbRed + Line1[X + 1].rgbRed) div 4;\r\n Line1[X].rgbGreen := (Line0[X].rgbGreen + Line2[X].rgbGreen + Line1[X - 1].rgbGreen + Line1[X + 1].rgbGreen) div\r\n 4;\r\n Line1[X].rgbBlue := (Line0[X].rgbBlue + Line2[X].rgbBlue + Line1[X - 1].rgbBlue + Line1[X + 1].rgbBlue) div 4;\r\n end;\r\n end;\r\n Clip.PixelFormat := OPF;\r\nend;\r\n\r\nprocedure CopyRectDIBits(ACanvas: TCanvas; const DestRect: TRect; ABitmap: TBitmap;\r\n const SourceRect: TRect);\r\nvar\r\n Header, Bits: Pointer;\r\n HeaderSize, BitsSize: Cardinal;\r\n Bmp: TBitmap;\r\nbegin\r\n if ABitmap.PixelFormat < pf15bit then\r\n begin\r\n Bmp := ABitmap;\r\n // this function does not support palettes\r\n ABitmap := TBitmap.Create;\r\n ABitmap.Assign(Bmp);\r\n ABitmap.PixelFormat := pf24bit;\r\n end\r\n else\r\n Bmp := nil;\r\n try\r\n GetDIBSizes(ABitmap.Handle, HeaderSize, BitsSize);\r\n { Do not use Delphi's memory manager. }\r\n Header := VirtualAlloc(nil, HeaderSize, MEM_COMMIT, PAGE_READWRITE);\r\n Bits := VirtualAlloc(nil, BitsSize, MEM_COMMIT, PAGE_READWRITE);\r\n try\r\n GetDIB(ABitmap.Handle, ABitmap.Palette, Header^, Bits^);\r\n StretchDIBits(ACanvas.Handle,\r\n DestRect.Left, DestRect.Top,\r\n DestRect.Right - DestRect.Left, DestRect.Bottom - DestRect.Top,\r\n SourceRect.Left, SourceRect.Top,\r\n SourceRect.Right - SourceRect.Left, SourceRect.Bottom - SourceRect.Top,\r\n Bits, TBitmapInfo(Header^),\r\n DIB_RGB_COLORS, ACanvas.CopyMode);\r\n finally\r\n VirtualFree(Bits, 0, MEM_RELEASE);\r\n VirtualFree(Header, 0, MEM_RELEASE);\r\n end;\r\n finally\r\n if Bmp <> nil then\r\n ABitmap.Free;\r\n end;\r\nend;\r\n\r\nfunction IsTTFontSelected(const DC: HDC): Boolean;\r\nvar\r\n Metrics: TTextMetric;\r\nbegin\r\n GetTextMetrics(DC, Metrics);\r\n Result := (Metrics.tmPitchAndFamily and TMPF_TRUETYPE) <> 0;\r\nend;\r\n\r\n// http://msdn.microsoft.com/library/default.asp?url=/library/en-us/gdi/fontext_6rlf.asp\r\n\r\nfunction IsTrueType(const FontName: string): Boolean;\r\nvar\r\n Canvas: TCanvas;\r\nbegin\r\n Canvas := TCanvas.Create;\r\n try\r\n Canvas.Handle := GetDC(HWND_DESKTOP);\r\n Canvas.Font.Name := FontName;\r\n Result := IsTTFontSelected(Canvas.Handle);\r\n ReleaseDC(HWND_DESKTOP, Canvas.Handle);\r\n Canvas.Handle := NullHandle;\r\n finally\r\n Canvas.Free;\r\n end;\r\nend;\r\n\r\n{$IFDEF DELPHI2007}\r\n{$WARNINGS OFF} // D2007 gives a bogus W1035 on the first line that assigns Result.\r\n{$ENDIF DELPHI2007}\r\nfunction TextToValText(const AValue: string): string;\r\nvar\r\n I, J: Integer;\r\n CharSet: TSysCharSet;\r\nbegin\r\n Result := DelRSpace(AValue);\r\n if JclFormatSettings.DecimalSeparator <> JclFormatSettings.ThousandSeparator then\r\n Result := DelChars(Result, JclFormatSettings.ThousandSeparator);\r\n\r\n if (JclFormatSettings.DecimalSeparator <> '.') and (JclFormatSettings.ThousandSeparator <> '.') then\r\n Result := ReplaceStr(Result, '.', JclFormatSettings.DecimalSeparator);\r\n if (JclFormatSettings.DecimalSeparator <> ',') and (JclFormatSettings.ThousandSeparator <> ',') then\r\n Result := ReplaceStr(Result, ',', JclFormatSettings.DecimalSeparator);\r\n\r\n J := 1;\r\n CharSet := ['0'..'9', '-', '+',\r\n AnsiChar(JclFormatSettings.DecimalSeparator),\r\n AnsiChar(JclFormatSettings.ThousandSeparator)];\r\n for I := 1 to Length(Result) do\r\n if CharInSet(Result[I], CharSet) then\r\n begin\r\n Result[J] := Result[I];\r\n Inc(J);\r\n end;\r\n SetLength(Result, J - 1);\r\n\r\n if Result = '' then\r\n Result := '0'\r\n else\r\n if Result = '-' then\r\n Result := '-0';\r\nend;\r\n{$WARNINGS ON}\r\n\r\nfunction DrawText(Canvas: TCanvas; const Text: string; Len: Integer; var R: TRect; WinFlags: Integer): Integer; overload;\r\nbegin\r\n {$IFDEF UNICODE}\r\n Result := Windows.DrawText(Canvas.Handle, PChar(Text), Len, R, WinFlags and not DT_MODIFYSTRING); // make sure the string cannot be modified\r\n {$ELSE}\r\n Result := DrawText(Canvas, PAnsiChar(Text), Len, R, WinFlags and not DT_MODIFYSTRING); // make sure the string cannot be modified\r\n {$ENDIF UNICODE}\r\nend;\r\n\r\nfunction DrawText(DC: HDC; const Text: TCaption; Len: Integer; var R: TRect; WinFlags: Integer): Integer; overload;\r\nbegin\r\n Result := Windows.DrawText(DC, PChar(Text), Len, R, WinFlags and not DT_MODIFYSTRING); // make sure the string cannot be modified\r\nend;\r\n\r\nfunction DrawTextEx(Canvas: TCanvas; const Text: string; cchText: Integer; var p4: TRect; dwDTFormat: UINT; DTParams: PDrawTextParams): Integer;\r\nbegin\r\n Result := Windows.DrawTextEx(Canvas.Handle, PChar(Text), cchText, p4, dwDTFormat and not DT_MODIFYSTRING, DTParams);\r\nend;\r\n\r\nfunction DrawText(Canvas: TCanvas; Text: PAnsiChar; Len: Integer; var R: TRect; WinFlags: Integer): Integer;\r\nbegin\r\n Result := Windows.DrawTextA(Canvas.Handle, Text, Len, R, WinFlags);\r\nend;\r\n\r\nfunction DrawTextEx(Canvas: TCanvas; lpchText: PChar; cchText: Integer; var p4: TRect; dwDTFormat: UINT; DTParams: PDrawTextParams): Integer;\r\nbegin\r\n Result := Windows.DrawTextEx(Canvas.Handle, lpchText, cchText, p4, dwDTFormat, DTParams);\r\nend;\r\n\r\nfunction DrawText(Canvas: TCanvas; const Text: WideString; Len: Integer; var R: TRect; WinFlags: Integer): Integer; overload;\r\nbegin\r\n Result := DrawTextW(Canvas, Text, Len, R, WinFlags and not DT_MODIFYSTRING);\r\nend;\r\n\r\nfunction DrawTextEx(Canvas: TCanvas; const Text: WideString; cchText: Integer; var p4: TRect; dwDTFormat: UINT; DTParams: PDrawTextParams): Integer; overload;\r\nbegin\r\n Result := DrawTextExW(Canvas, Text, cchText, p4, dwDTFormat and not DT_MODIFYSTRING, DTParams);\r\nend;\r\n\r\nfunction DrawTextW(Canvas: TCanvas; const Text: WideString; Len: Integer; var R: TRect; WinFlags: Integer): Integer; overload;\r\nbegin\r\n Result := DrawTextW(Canvas, PWideChar(Text), Len, R, WinFlags and not DT_MODIFYSTRING);\r\nend;\r\n\r\nfunction DrawTextW(Canvas: TCanvas; Text: PWideChar; Len: Integer; var R: TRect; WinFlags: Integer): Integer;\r\nbegin\r\n Result := Windows.DrawTextW(Canvas.Handle, Text, Len, R, WinFlags);\r\nend;\r\n\r\nfunction DrawTextExW(Canvas: TCanvas; lpchText: PWideChar; cchText: Integer; var p4: TRect; dwDTFormat: UINT; DTParams: PDrawTextParams): Integer;\r\nbegin\r\n Result := Windows.DrawTextExW(Canvas.Handle, lpchText, cchText, p4, dwDTFormat, DTParams);\r\nend;\r\n\r\nfunction DrawTextExW(Canvas: TCanvas; const Text: WideString; cchText: Integer; var p4: TRect; dwDTFormat: UINT; DTParams: PDrawTextParams): Integer;\r\nbegin\r\n Result := Windows.DrawTextExW(Canvas.Handle, PWideChar(Text), cchText, p4, dwDTFormat and not DT_MODIFYSTRING, DTParams);\r\nend;\r\n\r\nconst\r\n // (p3) move to interface?\r\n ROP_DSna = $00220326; // RasterOp_NotAndROP\r\n {$EXTERNALSYM ROP_DSna}\r\n ROP_DSno = MERGEPAINT;\r\n {$EXTERNALSYM ROP_DSno}\r\n ROP_DPSnoo = PATPAINT;\r\n {$EXTERNALSYM ROP_DPSnoo}\r\n ROP_D = $00AA0029; // RasterOp_NopROP\r\n {$EXTERNALSYM ROP_D}\r\n ROP_Dn = DSTINVERT; // DSTINVERT\r\n {$EXTERNALSYM ROP_Dn}\r\n ROP_SDna = SRCERASE; // SRCERASE\r\n {$EXTERNALSYM ROP_SDna}\r\n ROP_SDno = $00DD0228; // RasterOp_OrNotROP\r\n {$EXTERNALSYM ROP_SDno}\r\n ROP_DSan = $007700E6; // RasterOp_NandROP\r\n {$EXTERNALSYM ROP_DSan}\r\n ROP_DSon = $001100A6; // NOTSRCERASE\r\n {$EXTERNALSYM ROP_DSon}\r\n\r\nfunction RasterOpToWinRop(Rop: RasterOp): Cardinal;\r\nbegin\r\n case Rop of\r\n RasterOp_ClearROP:\r\n Result := BLACKNESS;\r\n RasterOp_NotROP:\r\n Result := DSTINVERT;\r\n RasterOp_NotOrROP:\r\n Result := MERGEPAINT;\r\n RasterOp_NotCopyROP:\r\n Result := NOTSRCCOPY;\r\n RasterOp_NorROP:\r\n Result := NOTSRCERASE;\r\n RasterOp_AndROP:\r\n Result := SRCAND;\r\n RasterOp_CopyROP:\r\n Result := SRCCOPY;\r\n RasterOp_AndNotROP:\r\n Result := SRCERASE;\r\n RasterOp_XorROP:\r\n Result := SRCINVERT;\r\n RasterOp_OrROP:\r\n Result := SRCPAINT;\r\n RasterOp_SetROP:\r\n Result := WHITENESS;\r\n RasterOp_NotAndROP:\r\n Result := ROP_DSna;\r\n RasterOp_NopROP:\r\n Result := ROP_D;\r\n RasterOp_OrNotROP:\r\n Result := ROP_SDno;\r\n RasterOp_NandROP:\r\n Result := ROP_DSan;\r\n else\r\n Result := 0;\r\n end;\r\nend;\r\n\r\nfunction BitBlt(DestCanvas: TCanvas; X, Y, Width, Height: Integer; SrcCanvas: TCanvas;\r\n XSrc, YSrc: Integer; WinRop: Cardinal; IgnoreMask: Boolean = True): LongBool;\r\nbegin\r\n // NB! IgnoreMask is not supported in VCL!\r\n Result := Windows.BitBlt(DestCanvas.Handle, X, Y, Width, Height, SrcCanvas.Handle,\r\n XSrc, YSrc, WinRop);\r\nend;\r\n\r\nfunction BitBlt(DestDC: HDC; X, Y, Width, Height: Integer; SrcDC: HDC;\r\n XSrc, YSrc: Integer; Rop: RasterOp; IgnoreMask: Boolean): LongBool;\r\nbegin\r\n Result := Windows.BitBlt(DestDC, X, Y, Width, Height, SrcDC, XSrc, YSrc, RasterOpToWinRop(Rop));\r\nend;\r\n\r\nfunction BitBlt(DestDC: HDC; X, Y, Width, Height: Integer; SrcDC: HDC;\r\n XSrc, YSrc: Integer; WinRop: Cardinal; IgnoreMask: Boolean): LongBool;\r\nbegin\r\n Result := Windows.BitBlt(DestDC, X, Y, Width, Height, SrcDC, XSrc, YSrc, WinRop);\r\nend;\r\n\r\nfunction BitBlt(DestDC: HDC; X, Y, Width, Height: Integer; SrcDC: HDC; XSrc, YSrc: Integer; WinRop: Cardinal): LongBool;\r\nbegin\r\n Result := Windows.BitBlt(DestDC, X, Y, Width, Height, SrcDC, XSrc, YSrc, WinRop);\r\nend;\r\n\r\n\r\n\r\n\r\n\r\nfunction IsEqualGUID(const IID1, IID2: TGUID): Boolean;\r\nbegin\r\n Result := SysUtils.IsEqualGUID(IID1, IID2);\r\nend;\r\n\r\n{Color functions}\r\nprocedure RGBToHSV(R, G, B: Integer; var H, S, V: Integer);\r\n\r\nvar\r\n Delta: Integer;\r\n Min, Max: Integer;\r\n\r\n function GetMax(I, J, K: Integer): Integer;\r\n begin\r\n if J > I then\r\n I := J;\r\n if K > I then\r\n I := K;\r\n Result := I;\r\n end;\r\n\r\n function GetMin(I, J, K: Integer): Integer;\r\n begin\r\n if J < I then\r\n I := J;\r\n if K < I then\r\n I := K;\r\n Result := I;\r\n end;\r\n\r\n\r\nbegin\r\n Min := GetMin(R, G, B);\r\n Max := GetMax(R, G, B);\r\n V := Max;\r\n Delta := Max - Min;\r\n if Max = 0 then\r\n S := 0\r\n else\r\n S := (255 * Delta) div Max;\r\n if S = 0 then\r\n H := 0\r\n else\r\n begin\r\n if R = Max then\r\n H := (60 * (G - B)) div Delta\r\n else\r\n if G = Max then\r\n H := 120 + (60 * (B - R)) div Delta\r\n else\r\n H := 240 + (60 * (R - G)) div Delta;\r\n if H < 0 then\r\n H := H + 360;\r\n end;\r\nend;\r\n\r\nfunction RGBToBGR(Value: Cardinal): Cardinal;\r\nbegin\r\n Result :=\r\n ((Value and $00FF0000) shr 16) or\r\n (Value and $0000FF00) or\r\n ((Value and $000000FF) shl 16);\r\nend;\r\n\r\nfunction ColorToPrettyName(Value: TColor): string;\r\nvar\r\n Index: Integer;\r\nbegin\r\n for Index := Low(ColorValues) to High(ColorValues) do\r\n if Value = ColorValues[Index].Value then\r\n begin\r\n Result := ColorValues[Index].Description;\r\n Exit;\r\n end;\r\n for Index := Low(StandardColorValues) to High(StandardColorValues) do\r\n if Value = StandardColorValues[Index].Value then\r\n begin\r\n Result := StandardColorValues[Index].Description;\r\n Exit;\r\n end;\r\n for Index := Low(SysColorValues) to High(SysColorValues) do\r\n if Value = SysColorValues[Index].Value then\r\n begin\r\n Result := SysColorValues[Index].Description;\r\n Exit;\r\n end;\r\n Result := ColorToString(Value);\r\nend;\r\n\r\nfunction PrettyNameToColor(const Value: string): TColor;\r\nvar\r\n Index: Integer;\r\n ColorResult: Integer;\r\nbegin\r\n for Index := Low(ColorValues) to High(ColorValues) do\r\n begin\r\n if CompareText(Value, ColorValues[Index].Description) = 0 then\r\n begin\r\n Result := ColorValues[Index].Value;\r\n Exit;\r\n end;\r\n end;\r\n for Index := Low(StandardColorValues) to High(StandardColorValues) do\r\n begin\r\n if CompareText(Value, StandardColorValues[Index].Description) = 0 then\r\n begin\r\n Result := StandardColorValues[Index].Value;\r\n Exit;\r\n end;\r\n end;\r\n for Index := Low(SysColorValues) to High(SysColorValues) do\r\n begin\r\n if CompareText(Value, SysColorValues[Index].Description) = 0 then\r\n begin\r\n Result := SysColorValues[Index].Value;\r\n Exit;\r\n end;\r\n end;\r\n if IdentToColor(Value, ColorResult) then\r\n Result := ColorResult\r\n else\r\n Result := clNone;\r\nend;\r\n\r\nfunction StartsText(const SubStr, S: string): Boolean;\r\nbegin\r\n Result := AnsiStartsText(SubStr, S);\r\nend;\r\n\r\nfunction EndsText(const SubStr, S: string): Boolean;\r\nbegin\r\n Result := AnsiEndsText(SubStr, S);\r\nend;\r\n\r\nfunction DequotedStr(const S: string; QuoteChar: Char = ''''): string;\r\nbegin\r\n Result := AnsiDequotedStr(S, Char(QuoteChar));\r\nend;\r\n\r\nfunction AnsiDequotedStr(const S: string; AQuote: Char): string;\r\nvar\r\n P: PChar;\r\nbegin\r\n P := PChar(S);\r\n Result := AnsiExtractQuotedStr(P, AQuote);\r\nend;\r\n\r\nprocedure CollectionQuickSort(List: Classes.TCollection; L, R: Integer; SortProc: TCollectionSortProc);\r\nvar\r\n I, J, pix: Integer;\r\n P, t1, t2: TCollectionItem;\r\nbegin\r\n List.BeginUpdate;\r\n repeat\r\n I := L;\r\n J := R;\r\n pix := (L+R) shr 1;\r\n if pix > List.Count - 1 then\r\n pix := List.Count - 1;\r\n P := List.Items[pix];\r\n\r\n repeat\r\n while SortProc(List.Items[I], P) < 0 do\r\n Inc(I);\r\n while SortProc(List.Items[J], P) > 0 do\r\n Dec(J);\r\n\r\n if I <= J then\r\n begin\r\n t1 := List.Items[I];\r\n t2 := List.Items[J];\r\n t1.Index := J;\r\n t2.Index := I;\r\n\r\n if pix = I then\r\n pix := J\r\n else\r\n if pix = J then\r\n pix := I;\r\n\r\n P := List.Items[pix];\r\n Inc(I);\r\n Dec(J);\r\n end;\r\n until I > J;\r\n if L < J then\r\n CollectionQuickSort(List, L, J, SortProc);\r\n L := I;\r\n until I >= R;\r\n List.EndUpdate;\r\nend;\r\n\r\nprocedure CollectionSort(Collection: Classes.TCollection; SortProc: TCollectionSortProc);\r\nbegin\r\n if Assigned(Collection) and Assigned(SortProc) and (Collection.Count >= 2) then\r\n CollectionQuickSort(Collection, 0, Collection.Count - 1, SortProc);\r\nend;\r\n\r\n{ TIntegerList }\r\n\r\nfunction TIntegerList.Add(Value: Integer): Integer;\r\nbegin\r\n Result := inherited Add(TObject(Value));\r\nend;\r\n\r\nprocedure TIntegerList.DoChange(Item: Integer; Action: TListNotification);\r\nbegin\r\n if Assigned(OnChange) then\r\n OnChange(Self, Item, Action);\r\nend;\r\n\r\nfunction TIntegerList.Extract(Item: Integer): Integer;\r\nbegin\r\n Result := Integer(inherited Extract(TObject(Item)));\r\nend;\r\n\r\nfunction TIntegerList.First: Integer;\r\nbegin\r\n Result := Integer(inherited First);\r\nend;\r\n\r\nfunction TIntegerList.GetItem(Index: Integer): Integer;\r\nbegin\r\n Result := Integer(inherited Items[Index]);\r\nend;\r\n\r\nfunction TIntegerList.IndexOf(Item: Integer): Integer;\r\nbegin\r\n Result := inherited IndexOf(TObject(Item));\r\nend;\r\n\r\nprocedure TIntegerList.Insert(Index, Item: Integer);\r\nbegin\r\n inherited Insert(Index, TObject(Item));\r\nend;\r\n\r\nfunction TIntegerList.Last: Integer;\r\nbegin\r\n Result := Integer(inherited Last);\r\nend;\r\n\r\nprocedure TIntegerList.Notify(Ptr: Pointer; Action: TListNotification);\r\nbegin\r\n DoChange(Integer(Ptr), Action);\r\nend;\r\n\r\nprocedure TIntegerList.ReadData(Reader: TReader);\r\nbegin\r\n FLoading := True;\r\n try\r\n Clear;\r\n Reader.ReadListBegin;\r\n while not Reader.EndOfList do\r\n Add(Reader.ReadInteger);\r\n Reader.ReadListEnd;\r\n finally\r\n FLoading := False;\r\n end;\r\nend;\r\n\r\nfunction TIntegerList.Remove(Item: Integer): Integer;\r\nbegin\r\n Result := Integer(inherited Remove(TObject(Item)));\r\nend;\r\n\r\nprocedure TIntegerList.SetItem(Index: Integer; const Value: Integer);\r\nbegin\r\n inherited Items[Index] := TObject(Value);\r\nend;\r\n\r\nprocedure TIntegerList.WriteData(Writer: TWriter);\r\nvar\r\n I: Integer;\r\nbegin\r\n Writer.WriteListBegin;\r\n for I := 0 to Count - 1 do\r\n Writer.WriteInteger(Items[I]);\r\n Writer.WriteListEnd;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n\r\n" }, { "path": "External/Jedi/Jvcl/run/JvJVCLAboutForm.dfm", "content": "object JvJVCLAboutForm: TJvJVCLAboutForm\r\n Left = 300\r\n Top = 156\r\n Anchors = [akLeft, akTop, akRight, akBottom]\r\n BorderIcons = [biSystemMenu]\r\n BorderStyle = bsSingle\r\n Caption = 'About JEDI-VCL'\r\n ClientHeight = 317\r\n ClientWidth = 438\r\n Color = clBtnFace\r\n Font.Charset = DEFAULT_CHARSET\r\n Font.Color = clWindowText\r\n Font.Height = -11\r\n Font.Name = 'MS Sans Serif'\r\n Font.Style = []\r\n Icon.Data = {\r\n 0000010001001010100001001000280100001600000028000000100000002000\r\n 00000100040000000000C0000000000000000000000000000000000000000000\r\n 0000000080000080000000808000800000008000800080800000C0C0C0008080\r\n 80000000FF0000FF000000FFFF00FF000000FF00FF00FFFF0000FFFFFF000000\r\n 00000000000000000BBBB0000000000BB000BB000000000BB0000B000000000B\r\n BB000BB00000000BBB000BB00000000000000BB00000000000000BB000000000\r\n 00000BB00000000000000BB00000000000000BB00000000000000BB000000000\r\n 00000BB0000000000000BBBB00000000000BBBBBB0000000000000000000FFFF\r\n 0000F87F0000E73F0000E7BF0000E39F0000E39F0000FF9F0000FF9F0000FF9F\r\n 0000FF9F0000FF9F0000FF9F0000FF9F0000FF0F0000FE070000FFFF0000}\r\n OldCreateOrder = False\r\n Position = poScreenCenter\r\n OnShow = FormShow\r\n PixelsPerInch = 96\r\n TextHeight = 13\r\n object MainPanel: TPanel\r\n Left = 0\r\n Top = 0\r\n Width = 438\r\n Height = 317\r\n Align = alClient\r\n BevelOuter = bvNone\r\n Font.Charset = DEFAULT_CHARSET\r\n Font.Color = clWindowText\r\n Font.Height = -11\r\n Font.Name = 'MS Shell Dlg 2'\r\n Font.Style = []\r\n ParentFont = False\r\n TabOrder = 0\r\n OnMouseDown = Panel1MouseDown\r\n object Bevel1: TBevel\r\n Left = 160\r\n Top = 114\r\n Width = 265\r\n Height = 4\r\n Shape = bsTopLine\r\n end\r\n object lblVersion: TLabel\r\n Left = 162\r\n Top = 37\r\n Width = 76\r\n Height = 13\r\n Caption = 'Version: 1.00'\r\n Font.Charset = DEFAULT_CHARSET\r\n Font.Color = clWindowText\r\n Font.Height = -11\r\n Font.Name = 'MS Sans Serif'\r\n Font.Style = [fsBold]\r\n ParentFont = False\r\n end\r\n object Bevel2: TBevel\r\n Left = 6\r\n Top = 266\r\n Width = 419\r\n Height = 6\r\n Shape = bsTopLine\r\n end\r\n object lblVisitJedi: TLabel\r\n Left = 161\r\n Top = 67\r\n Width = 157\r\n Height = 13\r\n Caption = 'Visit JEDI-VCL on the Web:'\r\n Font.Charset = DEFAULT_CHARSET\r\n Font.Color = clWindowText\r\n Font.Height = -11\r\n Font.Name = 'MS Sans Serif'\r\n Font.Style = [fsBold]\r\n ParentFont = False\r\n end\r\n object lblMailingList: TLabel\r\n Left = 168\r\n Top = 120\r\n Width = 143\r\n Height = 13\r\n Caption = 'JEDI-VCL Support Mailing List:'\r\n end\r\n object lblNewsgroup: TLabel\r\n Left = 168\r\n Top = 155\r\n Width = 146\r\n Height = 13\r\n Caption = 'JEDI-VCL Support Newsgroup:'\r\n end\r\n object JvHotLink1: TLabel\r\n Left = 181\r\n Top = 85\r\n Width = 133\r\n Height = 13\r\n Cursor = crHandPoint\r\n Caption = 'http://jvcl.sourceforge.net '\r\n Font.Charset = DEFAULT_CHARSET\r\n Font.Color = clBlue\r\n Font.Height = -11\r\n Font.Name = 'MS Shell Dlg 2'\r\n Font.Style = [fsUnderline]\r\n ParentFont = False\r\n OnClick = OpenURLClick\r\n end\r\n object JvHotLink4: TLabel\r\n Left = 185\r\n Top = 135\r\n Width = 202\r\n Height = 13\r\n Cursor = crHandPoint\r\n Caption = 'http://groups.yahoo.com/group/JEDI-VCL'\r\n Font.Charset = DEFAULT_CHARSET\r\n Font.Color = clBlue\r\n Font.Height = -11\r\n Font.Name = 'MS Shell Dlg 2'\r\n Font.Style = [fsUnderline]\r\n ParentFont = False\r\n OnClick = OpenURLClick\r\n end\r\n object lblNews: TLabel\r\n Left = 183\r\n Top = 171\r\n Width = 159\r\n Height = 13\r\n Cursor = crHandPoint\r\n Caption = 'news://forums.talkto.net/jedi.vcl'\r\n Font.Charset = DEFAULT_CHARSET\r\n Font.Color = clBlue\r\n Font.Height = -11\r\n Font.Name = 'MS Shell Dlg 2'\r\n Font.Style = [fsUnderline]\r\n ParentFont = False\r\n OnClick = OpenURLClick\r\n end\r\n object Label1: TLabel\r\n Left = 162\r\n Top = 5\r\n Width = 127\r\n Height = 33\r\n Caption = 'JEDI-VCL'\r\n Font.Charset = DEFAULT_CHARSET\r\n Font.Color = clBtnShadow\r\n Font.Height = -27\r\n Font.Name = 'Tahoma'\r\n Font.Style = [fsBold]\r\n ParentFont = False\r\n end\r\n object Label2: TLabel\r\n Left = 160\r\n Top = 3\r\n Width = 127\r\n Height = 33\r\n Caption = 'JEDI-VCL'\r\n Font.Charset = DEFAULT_CHARSET\r\n Font.Color = clBlue\r\n Font.Height = -27\r\n Font.Name = 'MS Shell Dlg 2'\r\n Font.Style = [fsBold]\r\n ParentFont = False\r\n Transparent = True\r\n end\r\n object lblCopyRight: TLabel\r\n Left = 7\r\n Top = 278\r\n Width = 125\r\n Height = 13\r\n Caption = 'Copyright (c) Project JEDI'\r\n end\r\n object lblRights: TLabel\r\n Left = 7\r\n Top = 294\r\n Width = 91\r\n Height = 13\r\n Caption = 'All rights reserved.'\r\n end\r\n object lblBugs: TLabel\r\n Left = 170\r\n Top = 189\r\n Width = 111\r\n Height = 13\r\n Caption = 'Reporting a Bug/Issue:'\r\n end\r\n object lblBugsURL: TLabel\r\n Left = 185\r\n Top = 206\r\n Width = 133\r\n Height = 13\r\n Cursor = crHandPoint\r\n Caption = 'http://jvcl.sourceforge.net '\r\n Font.Charset = DEFAULT_CHARSET\r\n Font.Color = clBlue\r\n Font.Height = -11\r\n Font.Name = 'MS Shell Dlg 2'\r\n Font.Style = [fsUnderline]\r\n ParentFont = False\r\n OnClick = OpenURLClick\r\n end\r\n object btnHelp: TSpeedButton\r\n Left = 304\r\n Top = 280\r\n Width = 25\r\n Height = 25\r\n Hint = 'JVCL Help'\r\n Glyph.Data = {\r\n 36040000424D3604000000000000360000002800000010000000100000000100\r\n 2000000000000004000000000000000000000000000000000000FF00FF00FF00\r\n FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00\r\n FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00\r\n FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF0000000000000000000000\r\n 0000FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00\r\n FF00FF00FF00FF00FF00FF00FF00000000000000000084008400840084008484\r\n 840000000000FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00\r\n FF00FF00FF0000000000000000008400840084008400FFFFFF00FFFFFF00C6C6\r\n C6008484840000000000FF00FF00FF00FF00FF00FF00FF00FF00FF00FF000000\r\n 0000000000008400840084008400FFFFFF00FFFFFF000000000000000000C6C6\r\n C600C6C6C6008484840000000000FF00FF00FF00FF00FF00FF00848484008400\r\n 840084008400FFFFFF00FFFFFF00000000000000000084008400840084000000\r\n 0000C6C6C600C6C6C6008484840000000000FF00FF00FF00FF00848484008400\r\n 8400FFFFFF000000000000000000840084008400840084008400840084008400\r\n 840000000000C6C6C600C6C6C6008484840000000000FF00FF00848484000000\r\n 0000000000008400840084008400840084000084840000FFFF00840084008400\r\n 84008400840000000000C6C6C600C6C6C6008484840000000000848484008400\r\n 8400840084008400840084008400840084008400840000848400840084008400\r\n 8400840084008400840000000000C6C6C60000000000FF00FF00FF00FF008400\r\n 8400FFFFFF00840084008400840084008400840084008400840000FFFF0000FF\r\n FF008400840084008400840084000000000000000000FF00FF00FF00FF00FF00\r\n FF0084008400FFFFFF0084008400840084008400840084008400840084000084\r\n 840000FFFF0000FFFF00840084008400840000000000FF00FF00FF00FF00FF00\r\n FF00FF00FF0084008400FFFFFF00840084008400840084008400008484008400\r\n 840000FFFF0000FFFF0084008400840084008400840000000000FF00FF00FF00\r\n FF00FF00FF00FF00FF0084008400FFFFFF00840084008400840000FFFF0000FF\r\n FF0000FFFF008400840084008400840084000000000000000000FF00FF00FF00\r\n FF00FF00FF00FF00FF00FF00FF0084008400FFFFFF0084008400840084008400\r\n 840084008400840084000000000000000000FF00FF00FF00FF00FF00FF00FF00\r\n FF00FF00FF00FF00FF00FF00FF00FF00FF0084008400FFFFFF00840084008400\r\n 84000000000000000000FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00\r\n FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF0084008400840084000000\r\n 0000FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00}\r\n ParentShowHint = False\r\n ShowHint = True\r\n Visible = False\r\n OnClick = btnHelpClick\r\n end\r\n object btnOptions: TSpeedButton\r\n Left = 272\r\n Top = 280\r\n Width = 25\r\n Height = 25\r\n Hint = 'Set JVCL Help'\r\n Glyph.Data = {\r\n 36040000424D3604000000000000360000002800000010000000100000000100\r\n 2000000000000004000000000000000000000000000000000000FF00FF00FF00\r\n FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00\r\n FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 00000000000000000000000000000000000000000000FF00FF00FF00FF000000\r\n 000000FFFF00FFFFFF0000FFFF00FFFFFF0000FFFF00FFFFFF0000000000FFFF\r\n FF0000FFFF00FFFFFF0000FFFF00FFFFFF0000000000FF00FF00FF00FF000000\r\n 0000FFFFFF0000FFFF00FFFFFF0000FFFF00FFFFFF0000000000000000000000\r\n 0000FFFFFF0000FFFF00FFFFFF0000FFFF0000000000FF00FF00FF00FF000000\r\n 000000FFFF00FFFFFF0000FFFF00FFFFFF00000000000000000000FFFF000000\r\n 000000000000FFFFFF0000FFFF00FFFFFF0000000000FF00FF00FF00FF000000\r\n 0000FFFFFF0000FFFF00FFFFFF0000FFFF00FFFFFF0000FFFF00FFFFFF0000FF\r\n FF000000000000000000FFFFFF0000FFFF0000000000FF00FF00FF00FF000000\r\n 000000FFFF00FFFFFF0000FFFF000000000000FFFF00FFFFFF0000FFFF00FFFF\r\n FF0000FFFF000000000000000000FFFFFF0000000000FF00FF00FF00FF000000\r\n 0000FFFFFF0000FFFF0000000000000000000000000000FFFF00FFFFFF0000FF\r\n FF00FFFFFF0000FFFF00FFFFFF0000FFFF0000000000FF00FF00FF00FF000000\r\n 000000FFFF000000000000000000FFFFFF00000000000000000000FFFF00FFFF\r\n FF0000FFFF00FFFFFF0000FFFF00FFFFFF0000000000FF00FF00FF00FF000000\r\n 0000FFFFFF0000FFFF00FFFFFF0000FFFF00FFFFFF00000000000000000000FF\r\n FF00FFFFFF0000FFFF00FFFFFF0000FFFF0000000000FF00FF00FF00FF000000\r\n 000000FFFF00FFFFFF0000FFFF00FFFFFF0000FFFF00FFFFFF00000000000000\r\n 000000FFFF00FFFFFF0000FFFF00FFFFFF0000000000FF00FF00FF00FF000000\r\n 0000FFFFFF0000FFFF00FFFFFF0000FFFF00FFFFFF0000FFFF00FFFFFF0000FF\r\n FF00FFFFFF0000FFFF00FFFFFF0000FFFF0000000000FF00FF00FF00FF000000\r\n 000000000000000000000000000000000000000000000000000000FFFF00FFFF\r\n FF0000FFFF00FFFFFF0000FFFF00FFFFFF0000000000FF00FF00FF00FF000000\r\n 0000FFFFFF0000FFFF00FFFFFF0000FFFF00FFFFFF0000FFFF00000000000000\r\n 00000000000000000000000000000000000000000000FF00FF00FF00FF00FF00\r\n FF00000000000000000000000000000000000000000000000000FF00FF00FF00\r\n FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00\r\n FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00\r\n FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00}\r\n ParentShowHint = False\r\n ShowHint = True\r\n Visible = False\r\n OnClick = btnOptionsClick\r\n end\r\n object Bevel3: TBevel\r\n Left = 160\r\n Top = 226\r\n Width = 265\r\n Height = 4\r\n Shape = bsTopLine\r\n end\r\n object lblWindowsVersion: TLabel\r\n Left = 168\r\n Top = 232\r\n Width = 73\r\n Height = 13\r\n Caption = 'Windows 2000 '\r\n end\r\n object Label4: TLabel\r\n Left = 168\r\n Top = 248\r\n Width = 147\r\n Height = 13\r\n Caption = 'Memory Available to Windows:'\r\n end\r\n object lblMemory: TLabel\r\n Left = 320\r\n Top = 248\r\n Width = 104\r\n Height = 13\r\n Alignment = taRightJustify\r\n AutoSize = False\r\n Caption = '100.000 KB'\r\n end\r\n object pnlImage: TPanel\r\n Left = 6\r\n Top = 10\r\n Width = 139\r\n Height = 251\r\n BevelOuter = bvLowered\r\n TabOrder = 0\r\n object imgStarfield: TImage\r\n Left = 1\r\n Top = 1\r\n Width = 139\r\n Height = 249\r\n Align = alClient\r\n AutoSize = True\r\n Center = True\r\n Picture.Data = {\r\n 0A544A504547496D6167652D240000FFD8FFE000104A46494600010100000100\r\n 010000FFDB0043000302020302020303030304030304050805050404050A0707\r\n 06080C0A0C0C0B0A0B0B0D0E12100D0E110E0B0B1016101113141515150C0F17\r\n 1816141812141514FFDB00430103040405040509050509140D0B0D1414141414\r\n 1414141414141414141414141414141414141414141414141414141414141414\r\n 14141414141414141414141414FFC000110800F9008B03012200021101031101\r\n FFC4001F0000010501010101010100000000000000000102030405060708090A\r\n 0BFFC400B5100002010303020403050504040000017D01020300041105122131\r\n 410613516107227114328191A1082342B1C11552D1F02433627282090A161718\r\n 191A25262728292A3435363738393A434445464748494A535455565758595A63\r\n 6465666768696A737475767778797A838485868788898A92939495969798999A\r\n A2A3A4A5A6A7A8A9AAB2B3B4B5B6B7B8B9BAC2C3C4C5C6C7C8C9CAD2D3D4D5D6\r\n D7D8D9DAE1E2E3E4E5E6E7E8E9EAF1F2F3F4F5F6F7F8F9FAFFC4001F01000301\r\n 01010101010101010000000000000102030405060708090A0BFFC400B5110002\r\n 0102040403040705040400010277000102031104052131061241510761711322\r\n 328108144291A1B1C109233352F0156272D10A162434E125F11718191A262728\r\n 292A35363738393A434445464748494A535455565758595A636465666768696A\r\n 737475767778797A82838485868788898A92939495969798999AA2A3A4A5A6A7\r\n A8A9AAB2B3B4B5B6B7B8B9BAC2C3C4C5C6C7C8C9CAD2D3D4D5D6D7D8D9DAE2E3\r\n E4E5E6E7E8E9EAF2F3F4F5F6F7F8F9FAFFDA000C03010002110311003F00FCBC\r\n FED0BAFF009F99BFEFB347F685D7FCFCCDFF007D9AAF4633581DF645CB59AFEF\r\n 6E62B7B792E279E53B5238D892C7D0531EF2F6191E39269E39118AB233904107\r\n 041A8ED6EA6B1BA8AE2DA59209E360C92C4C5590FA822BA0BED02CDFC170F88D\r\n FC456973AB5D5FB5BCBA3726E5060B79EC73F74918E9D48AB4AFA12F47A988D7\r\n 57A91AC865B811B9215CB36091D7069BFDA175FF003F337FDF66926BFBA96CA0\r\n B369DDAD617674849F950B7DE23EB505431AF32C7F685D7FCFCCDFF7D9A3FB42\r\n EBFE7E66FF00BECD57AD58BC33A84DE199F5F4841D320B85B5925DC387232062\r\n 85760ECB7297F685D7FCFCCDFF007D9A3FB42EBFE7E66FFBECD57A290EC8B1FD\r\n A175FF003F337FDF668FED0BAFF9F99BFEFB355E8A02C8B1FDA175FF003F337F\r\n DF668FED0BAFF9F99BFEFB355E8A02C8B1FDA175FF003F337FDF668FED0BAFF9\r\n F99BFEFB3502A976000C93DAB42CF4FDC46E1963DBD29AD44DA4575BDBB63813\r\n CC4FA0734EFB4DF7FCF5B8FF00BE9ABB2D17C38D7B20040E7B138AEEED7E1899\r\n 6DE370D6FF0030079714AE887248F07A2BD2EF7C25E11B6F8597B7D3EAB716FE\r\n 3AB7D496D9B483180A20E7737D41EB5E694DAB1A27702707AF148E4E0EDC6696\r\n 8A13681AB828200CF5A28A290C2A537730B76B7F39C40EC18C3BC84661C676F4\r\n CFBD455BDE1FF155FE8DA4EAFA45A476F241AC4690CE25855E4C03C796C4654F\r\n 3D475AB8EE4CB63099B71CF1F80A4A96EA17B6B8786589E19233B591D4A91F50\r\n 7A54552D598D3B85145148614F8A3323AA8EE715359D8BDE1F94E074AD58F437\r\n B51BD81623BD0F402EA7836FED349B2D5DED258F4DBD2D1DBDCB0F92565386C1\r\n EF83FCABA8F0AF82AEB56B6BCBC8225682C955A66670A406381807AF4ED5474B\r\n F122C16D05A5D5B1BDB680931C3348DB109EB8008033DEBD3FC17AA59EB57F6D\r\n 636DE1AB492E24C0086690281DC93BB803AD44E4CCA45DF877E091AD6B1696DF\r\n 609EF8313BADAD19565914024ED27807BFE06BBB3E1058951445B46C5382C38C\r\n A8349E13F15E95A76AB1B7F63D8DA35ACBCDC43712E54A9FE021F926BE8C4F8B\r\n BE0E9A0B790FC3ED36632411BEF6DB9394079F97DF1554A0A6B5661267E4F969\r\n AEE676F9DA57E5CBB6598F7273DC9E6A292378C95756461D98608FC2B47C35AE\r\n BF86B5CB2D4D2DE1BB92D64122C338CA311EA3BD69FC46F1EDFF00C4BF16DE6B\r\n FA943696D7370157CAB1844512AA8C001477C753DEB4D1A3AAEEE733413819F4\r\n A29C88D2385452EC4F0A0124FB6054A57298D560C323A5156B519567BB764B55\r\n B35C01E48CF040009E7D4F3F8D56C645572F6127A0952DB4AF05CC52C4ED1C88\r\n EACAE9F794839047B8A62A16380324F6157E0D1EE9A149CC5247131C24A50ED6\r\n 3EC7A1FCE8E569EA3D093C47A845AA6B771771CF777514A43196F48F399B6804\r\n B1048CE7F402B336E4D6E5CD95A7D86DB6C32A5E8663705F88CAFF0008519CE7\r\n D6B38D96D624B61073EF5B251EA6774B41F7DA0DFE9D61677D716B2C3677809B\r\n 69D9484980EA54F7C55051935B171A85E6A7696B6935DCF3585A82B6F04B2129\r\n 0E4F3B173819AD2D03C0B79E26B2D5EE2CFC948B4AB717370F34A14ECCE3E51D\r\n CF078F6A89453638CBB92784ADE07B84127CA830DC726BE92F88BE13F84B67F0\r\n 96CB50D07C417577E2A758CC9612281B491F3EE18E003D0E4E7DABE5AB7B86B4\r\n 4428DD80DC3BD5F935A9E58C23484803BD067D771D39093FCA08527835D669BE\r\n 24D3B48D06D66B1BBD4ADFC48267595942AC22023E5DAC0E771E720D7313F8BA\r\n F67F0DC5E1E66B71A7C572D76A1620253230C1CBF5238E955F49D534DB7B2D52\r\n 0BEB37BDBA9E155B29E19760B670D92CC3F8B2303159F25CD1D8EF740F883FD8\r\n F33C8D141745E378CA5C26F5C30C6EC7F787635E91A77C57B45D36C95A40192D\r\n E34233DC201FD2BE646D4421272E09FE123914C3AA393FC78FF7AAA34FB10927\r\n D0CE3C8A5C71494542360AB9A66A13E917F05EDAB88EE6060F1B95070DEB8AAA\r\n 06052D75421CAB525EA686AD7B6FAADC473C703457720CDCC8CE584D296259F1\r\n DB391C0F4A84E9B3A4304CC81639B71462C086C633C0391D7BE29B671091C920\r\n 103B1ABCB16D01429C0390314376D119B7CBA22BDB5B1858B1209231815D23F8\r\n 9B51BFD2AC34AB9B967D3AC0B35AC2A00F2C9EBF5CFBD626C39E952202A07B56\r\n 52BB08B6CF4CF1DFC55B0F187C3FF0DF8793C3765A6DDE94487D46D940799704\r\n 61BD79E73ED5E63247F371C8A98E4819CE3DE9AAC18641047A8A690357238A1C\r\n 901703D856BD8E8573A8831DBC734A48CB4708662C3DC0ED59D16038AF50F83F\r\n F18EEFE11EA377796B636BA82DCC060786ED4E307B82391498D2B1E617D66D6B\r\n 2156468D81C15618354A59044B920919C71DABA7F1A789E6F176BB75A94F1451\r\n 3CE73B215C2803DBFAD73A4669A466CD8BCF149BEF08E9BE1F1A659431D9CF25\r\n C0D4123C5CCA5FF85DBA903B5663D948B16F00ED03248ED5081B581ED5EA9F0B\r\n BE358F863A078934F4F0FE99AC36B36FE419B50877B5BF046E4F7A4CA5A9E377\r\n E9B640718C8AAC1B02AE6A53FDA2E18E73C9E7DEA9EDAA6A49DE2691D84A728A\r\n 00CD2F5A29C3ED329B00335760B30A017193E9D85259DBE7E76C63B0FEB57429\r\n C74AD64FA1949DB44315028C0E00EC2BA9F08F89C7865F50B81A4D8EAED7166F\r\n 6AABA8465D6DD9863CD403F8C76AE655771AD2D1CA25D224B910C8704D4A44C5\r\n 5CA080AA004EE3DCFA9F5A9157032467DAB4B51D1E5D36FDED5D32F91B78FBC0\r\n F4C542D6AF1C851C1470705586083E949C6C39686D784F5BD3346D3F561A9683\r\n 0EB171710F956B35C48556D98FF16D1F78D736206C005CB606327A9AD15320B1\r\n 7B7D8BB5A40E5FAB74C63E9510B563FF00D7AA51B0AE55F2012319CD4F7703C3\r\n 1C7D41619C1EB5B5E1AF0D49AE6B105AA93B4FCEED8E8A3AD41E22027D567688\r\n 7EE95B62FD0714DC6E527A184E8768EF8A88A0357C40475207D6B77C2DE07BBF\r\n 135DFEED3CBB65E649DBEEA8FAD546042673769A54D78199171127DE76E00FC6\r\n B375291918AA02101FBE3BD773E2DBFB3B48FF00B2F4BF96D213F3CC383291EB\r\n ED9AE3A519FAD66D5B52D34918A4E4E4F24F7A693CD59B9B731B161F74FE955F\r\n 02892735A171698AA322AD5ADB0906E2323D3D6ACE9FA31D45D52DE64790FF00\r\n CB362158FD335A4744B9B091219E096004E373A1C51295958A7E4538936FE1DA\r\n A4ADE9BC2E21D2EEAED6FE095A2B910082304B48A413BC13DB8C5651B5C01904\r\n 7BD4C35DCCED6238E0663C8200AE9E13E1F3E0F5805ADD8F149BA07ED3E61FB3\r\n 8B7FEEECCFDEF7ACFD3E0490857E15BAB7A56ACBA14B68E8CD1931B8F9645E84\r\n 575463711D57F63B78B3C151EA76CB9D434C3B64DBD593FBDF8571925ACB3CAD\r\n 24BBA476392EDD4D7A8FC23BA4D175E892750F6375FBA9D1BA60F19AB7E3FF00\r\n 86F2784FC49736650880E2485B1F791B906BB961DC95D183A893B33CB6DB4B69\r\n 2D666DBF7714B0E96CF8057AF4E2BD2346F0B19B4FBD3B09C62B5BC33F0E65D6\r\n B51D32CED08B8BDBB9BC916EA87721270324F073D78A71C3B6B6225552466787\r\n 3C30DE17F8797FAE4C856EAF0FD9ED89EBEE45799BE912B37A9EF9AFAA7E3E78\r\n 7E2D2356B3F0A5900D068B02C0E50E434C402E7EBDAB9DF859F00F53F893AF25\r\n A5A405204F9EE2E5F88E141D4B1FE95BFD51CA4910EB24AE794FC3DF8477DE37\r\n BFD89114B48FE696761F2AA8EA49AD7F89DE20D3FC2D603C37E1FDAB0A0DB34E\r\n 9F7A423D7DABDBFE35F8BB43F869A11F0878436B246BB6EAF47DE9DF1C9FA7B5\r\n 7C85ABDD3DC5CC8F29DCC49F98D4E229C692E54694E6EA3E6673F39DECC5B1CD\r\n 5195707E9C574D058D9695AED81D6E39AE74B7DB2DC456322895919490158E40\r\n 3923AFA1AC2BE589AE253086588BB18C39CB05CFCA0FBE315E335737BDF433E6\r\n 8C3A907A1ACC7528C54F515B0462AB496E8CE495C9F5CD4A7CBB92A5CA334F8F\r\n 7B3F247CB8C8EB5DCF873C697BA6158662B7D69901A0B91BD71ED9E6B8CB08CA\r\n 2648E5B9FC2B4ED20679140192C401ED9A6F5366F53E90D2FC41F0D3C59F0DE4\r\n D025D1468FE249EED66FED969B7222018DA13F3AE5752FD9E7C4715A9BCD3123\r\n D7EC17913D81DE40F75EA2BCF756D27FE119D624D3DAF60BF9210A5A6B472503\r\n 150C573EA338AED7C01F10F5DF085EC7369B7F3DB9041F91BFCE6BA294149EA8\r\n CE726B639F1E16B8B498C7342F13A1F991C608FA8AEE3C2B6E9081657D119AD1\r\n F823F8947A83DABE83F097C73F0B78DED92CBE21F846CF551B760D46CD043729\r\n EF91C1AEEADFF65FF0878F6DFEDBF0F3C5B0CCE467FB2F55F9251EC1ABD48E1D\r\n 3B58E3755ADCF9D1BE1E4BA4086F20533D8487E59D07193D8FA57B64BE101F13\r\n 7E10C77C9187D6FC37F24C1465A7B63D0FBE2B7743F861E27F863A8BDAEBDA14\r\n B3E952E52781977C722FFB2C3815EC5E00F8710F84B58875AD198DE7876F90C3\r\n 716F20F9A246E36B0F63D0D7BF469428D372933CEAD56EF43E4FF0E7828CF65A\r\n 9048CE0420F03DEBDAFF00670F86D0E82FAB78D750841B7D1E0616E1C7DF988E\r\n 3F2AF5283E0947A36ABAE416E80DACC9FB8039F949C8E7DABD293E1E25B784EC\r\n 3C336CA2384FEF6E58776EBCD3C4E270B4E118C3E6651A9395D247C87E17F82D\r\n ABFC58F184F26C2A934C67B9B993EEC618E4E7F95763F19FC77A3FC20F084DE0\r\n 7F04F9693AA6DD42F830DE49EA3DFF00A57B0FC4AF14C7E03F0F9F0DF846D89B\r\n D9176C93451977071EDD6BE5DD7BE0AEB578926A9AFDCDBE8166F96371A94BFB\r\n D6CFA27534F95E263ED17BABA21C64AF693B9F2978B4CD7934924ACD23B1CEE3\r\n C935C4DCF866FF005076305ABBA0EAE46147E35F44F89D3C27E1B12269F6F26B\r\n 9749C7DA2E06D889F50B5E35E31F116A5ABB32BB0861CF10C236A815E26229B4\r\n F53D6A524D6879E6A3A7C76129134C8EE3AA21C807EB5873AE243C1C76ADBBCB\r\n 567739E0D67CB0320E7F3AF1671B33AEE67483BD32AC4F1103A71506C35CF213\r\n 573AFB0F84BE2DB90A1341BE6F6D9C9AE8F4FF00819E39B9FF0057E17D45F3D8\r\n 4439FD6B99B1F89DE26B6DAA9ACDD8E71C486BA2B1F8D3E2D808035DBD18EDE7\r\n 1AEAA4A97DA64B72E874761FB38FC429CE17C21AA1CF385B76AEB747FD98FE23\r\n 961FF1476AC07BDB915C7D97ED01E3287006BF7E3DC5CB7F8D755A47ED17E340\r\n 540F11EA23E972DFE35E9C7D87D9673CFDAF447A1689FB337C468B04F8435550\r\n 7D6103FAD7A57863E057C45D2EE22923F0EEA56D229043AE148FD6BCB344FDA2\r\n 3C65211FF1536A7C76FB4B63F9D7A4784BE3778DB569E386DF5AD4EEA673858D\r\n 246663F857B1845D216F99C351CDEE8FAA7E1CDDFC47D36D96D359D327BEB3E0\r\n 6CBA2AC40F4CD7AAE93A35B00665B03A6BB8F9E24E15BF0AF1CF87F6DE346862\r\n B8F126B0DA542D8212EA7CCADF45073F9D7B4E8F3C654AA4B2CA100CCB2F01BE\r\n 9CD79B9929425EEA497918D0D5EA68AD8C6154607CA31D29D7516E81D06FF986\r\n 088FA9A25BC8E08833B0507D6AADD6A50287463BD9464A03F311EA3D6BE7D46A\r\n 4A499E83E548E17C4FA77886DE074F0E68F15A487FE5BB00D21F7C9AF9E3C71F\r\n 017E2378A6F249AE2CE5BE958E77CB7084FEA6BE93D5A15F11C3247A2EBEB1DD\r\n 9C816F33ED607D2BE76F8A73FC43F05BB9BD97518ADF9DB7114CE6323EA3FAD7\r\n DAE5D52A2872DD27E7B9E4B56A9A2B9E51AC7EC8FF00112E49FF00890B11EBE7\r\n C7CFEB5C4EAFFB177C4994965F0F363D4DC463FF0066AB3E20F8B5E2452E4EB3\r\n 7FF5170FFE35E67AFF00C5CF103163FDB17C7EB72FFE359E21C53F7EC77D3E7E\r\n 869EA5FB177C4989998E88AA3B837517FF00155CAEA5FB26F8F2D49F374E8531\r\n FDEBA8FF00C693C2FE2BBDF18F8A6C34DD4FC572E8967733AC52EA1732B94841\r\n EE403583F10FFB4341BFD57EC5E2B1AC69D67766D52EA1B96569F8C8654273B7\r\n 1DEBC59D5C3ADD6A75C5545F106AFF00B35F8C34C48DA482C9BCC4DF88EED5B6\r\n 8F46F43ED5CDC9F037C508E47916A31DBED2B5CD5DF88EFEE325AFAE79E72666\r\n FF001ACB7D5EECB13F6B9CFBF987FC6BCF9CE9B7A23A126BA9474578A7BB805D\r\n 48EB0798A247519645CF247A9C5747E25B2D3B49F11EA167A4EA0357D3639716\r\n F78A36F988403923B11920FB835C6D9CDE5C9B73C1FE75A904BB08C9C81EB5C8\r\n F7356ECCEB7C47A6699A35E5AC3A4EB70EBD04B6D1CCF342A57CB9083BA220F3\r\n 9523F5AD6F0D787351D524568A310C27ACD31DAA2B91B2D4BEC6434488CE3A17\r\n 19C5698D7EF6F80135C3B01D141C01F856D4DD89763DC740B3F0BF8702B6A77D\r\n 2EAB70396B6B4F957E9BABD5BC39F1AF50B2B636DE1AB3B6F0F40C00F32D6306\r\n 73F590F3F957CBBE1A325DCAB1A2EE248E9D6BEC8FD9D7E0DDB5C5BBF893C533\r\n 4763E1EB25F3649263857239DBCF53ED5EE60EA3BF91C15F45A9ED1F027C01AA\r\n 78B09F13789AF264D36305CCB77212D211DF24F03DEBD5B4AF8A36BE38F1741E\r\n 1CF0FF00FC822D72D3DD28C060BD71EDC753D6BE56F8D1FB4E9F16B0F0F78777\r\n 69BE1AB71E5844F95AE00FEF63F87D05749E12F169F849F01AFBC45230875EF1\r\n 3136F61BBEF2423AB8AF46A38D64DCFE471285B63D7BC5FF001A60B9D5BC4315\r\n ACA1AD6CA12B1B03C120E09AC197E2B5EF897E1C9D6B4BBA68F5BF0FB8338439\r\n 2F093D48EE2BE60D43E22E97796F7F269169716282C912E16E26DFE64D9F9987\r\n B1AA7F0B3E2CA786FC5917DA1F7E9F7CA6D2EE227E5647E33F875AD612C32494\r\n 56A4BA1249CAE7B6EB1E3BB7F89B60D7FA3B8D3BC57002F35923155BB03F8A3F\r\n F6BB915CBE8BFB5CF8B7C1CCD637F245AE5829DB2596A6BBBA751BBA8AF0DF88\r\n 57773E02F17DCDAC133A8865F36DAE1588CA139520D66EB1E29B5F88B6CCEF22\r\n 5B78813EF11C2DC8C75FF7AB9F11898FC16D8E9A54795687D01AC78CFE0AFC62\r\n 42B7714FF0FB5B947FAD03CCB3673EB8FBB5E23F143F675D7742B76D434992DB\r\n C45A491B96F74C944AA47B81C8AF14D4B5A9AD2E648640524524107A8A7E85F1\r\n 53C41E1294C9A3EAB7368C4E5911C957FAAF435E3CF109EE75C69D8C1D522B8D\r\n 36774991A220E30C31590B6F36AB7D0DB4285E791C4680F1927A726BD4750F8C\r\n 3A4F8D22D9E2BD0A3331207DBEC4057F724571FACF84EC6EF75CE83AA47A8C58\r\n 24DB4984940EBC83D4D79B52573A51C5DE2B452346E0ABA12A41EC7D2AAD6BF8\r\n 834B934A162268ADD649ADA37668242C7919C38FE1619E40CD61EE279E9ED5CD\r\n 7149D8CC425181F4E6B56263226E45665EE554903B73E959D6A034C80F6AE934\r\n 1D6350F0CDADFA58C8638753B76B5B81246195E2279192383E8472286D5958D6\r\n 4AECAD13796704F5E6B534D85EE6611C60966EC2B2618F73019273DEBD6FE1FF\r\n 00872CB47B01AF6BC45BD9261A38F77CF2FD056907A9163D4FE0C7C3BB0D22C4\r\n EBFE219D6D34C806F666FBD263F853D49FD29FF173F68DBAF1A88B48D31BFB3F\r\n C3B6B9586D223807FDA6C7535E5FE30F883AAF8DEE56DAD83DBE9F18022B54F9\r\n 401D3271D49AE3F52B6BBD327F2AE627865C03891769C7D2BD18E29538F244CA\r\n 54549F348F57F8729378C3C57A7E9684625906F7FEEA0E589FC2BB5FDA0BE2E4\r\n 7E24F13C7A6E9EFB346D2215B1B4894FCA02FDE61F535E71E05D5C7813C11A8E\r\n BAEF8BFBE06D6CC13C807EF30AF37B9D624B895D998E49392DC9343C4351B0BD\r\n 8DD9E8161E29C699A902F824281CD6137885965C8936E3DEB978B52658275078\r\n 6C66AABDD313D78AC7DBBD197C8AC7B878B3C41FF09C7C3EB1D514EFBFD3145B\r\n CF9E4B27626BC7E5D6644B90E85A3653B8153820D687823C56349BE96CEE18FD\r\n 8EF2331383D013D0D737AC23595FCF01C128C4640EA3B5152B3A9A9318D8D6D4\r\n F5E5D7E2DF718178831E70FF009683DFDEB9C965624F2467F87D2A091F6AE4E4\r\n 7D2992CC1471C935C8E468D8F79020C93503CDE5C81E37607AE41C546EFB8E4D\r\n 44ED9A86C96EC5A9B549E75DB230907AB0C91598ED6EEE4B727D466A49A51126\r\n 78C9E82A8538AB9504E5A9A10DA790E48C9CF1D2BA4BDF17DEEA5E14D33C3D3A\r\n 5BB58E9D7125CDBC82102656718652F9E57BE08EBDEBACF8BFE02D1FC11E259E\r\n C344D760F1258AC69245A85BA9457DC33B71D88E86B89D274E92F6ED63442CC7\r\n A00339AE6E7BAB9AB5ADCBFA0C36B638BEBD469C27CD1DBA8CEF23D6A5D6BC4B\r\n 7BAF5C896E9DB6A7DC8870A83D87D2BD274EF863E26F0941E1DF12C567E5FDAE\r\n 52D677332AB46CCA40C15CF6CF435C278BB409F48D76FE0B9D8D3899DA478882\r\n ACC5896231DB26A5556F428EFBE0F78C7C2BE1DD7F4FBAF11688FAB5844D992D\r\n D27F2CBFA1CD54F8A7E3AB4F897E309EF058C8925C482289DE61948413B14800\r\n 03B477EF5E601A688F05863D29B1DFB405E4C9F30E4293DAAE314FA8AD66747E\r\n 31F118D46E21B48322CEC97CA8C03C123A9FCEB9B370C4F5FC2AA3CECE339E49\r\n E6904C40E49ADAE4365A1332E79EB4D32B1FE23F855633EEE01E6986620F534E\r\n E4968484386CF23A1CD4DA95CFDA312E497C0049ACE32EE3CD3FCC25707907B5\r\n 34EC0911C92990738005465B143F0D8A616A96FB10DD8B9A56937BAF6A305869\r\n D6CF777B392B14119019C804903240E809FC2B3EEA4FB24EF148A43A12AC0738\r\n 20E08FCC52497B2D9491C913BC6C33868D8AB03D382391D4FE754A699A62493C\r\n 649E953B22A30E6D7A04D379AFBBA7A0A8C9CD25159CA6E474256D8F59FEC8D4\r\n FC672DFDCD8E9F35D790925D5C7D9E3CAC318E4B1ECAA2B9DD3DCDADCEE19047\r\n 423AD6FF00DAB57F094D776F0CF71633CA860B88D59A32EA7AA38E38F6355B50\r\n BAFED7D5CDD496F6F6265DA7C9B587CA8D4000642FBE327D4927BD72A6C4CED9\r\n FC6F04DE17D22C7CBBB5BDB69A469E592E0BC2F19C6D558FA29183923AE6A2F8\r\n C3F17AEFE265F69F2DC59595843A7DAADAC30D9C22350A0724F7249E726BABF0\r\n 9FC2FF000DF8ABC2D7F7C7C5365A4DD585835C4B16A071F68901F95200064F1D\r\n 73CD78A789ECE2B093F737F6D760F685CE47E040AA8C6E47358F45F872DF0F25\r\n D13C44DE2D93515BD164DFD9A2C76ED339E9BB3DABC83509104EC2324AF627AF\r\n E3559AE9C03F36077AAC2ED1DF1BB93EB5D118D89736F62C6F3EA694C848A6C5\r\n 1991C01D4D696B3E1AD4FC3C611A958CF64674F32213C6537AFA8CF515772136\r\n D19C18A9CD3DA195123768A448E4198DD908571EAA7A1FC2A07904609270077A\r\n 7CD793CC90ACB2C8F1DBA6C850B922353D428E83F0AA5726E213CD6868EB6D35\r\n FDAA5DCAD0DB34C8B348A325232C0391EE067159A3AD6BE8B7FA4DA58EB316A5\r\n A75C5E5D4F6BB74F9A09822DBCF93F338FE218C7152C7166B7C4FB2F0C69BE2B\r\n B983C1B7F73AA6888A9E4DCDE2EC91988F9B207BF4AE419F62163D8738A63C8C\r\n D0821846C7FBDC0CD3D490A327793DFD692692B8A5AEA549A5FB4FDD4242F7A8\r\n E585E35F99719ADDB2D325BB3F229AD9D33C11A8EB3A8DAD8D9DBBDC5DDCB88A\r\n 28531B9D8F400557B456B33452B1C332326370233EB551C10E73D6BA9D73449F\r\n 4ABDB8B2BB8CC53C2E51D4E0ED60704573D35B8595812722B34EC12BD456EA7B\r\n F78E3C41AA7C5EF1A6B7AF3A2BDC5C79B7D2AAAAA08E31CE3031920607BD666A\r\n 716BBAF6876524B133D868F17D9A268EDC2EC5662D82C07249CF2DCF6AE62D1A\r\n 67D4A0851D63964708ACEDB40278C93E95E8ABF11FC4DE12B0D6BC1EFA844D04\r\n 932A5C2C05258DD93A157C72013C1AE54D9A3479B5D6A92DAC6D182EA08C11EB\r\n 5CEDD4ED712162735E93F10FC26FA2EAD6D6B2EAF69ABCD3DBA5CB4B62DB9230\r\n C33B18FF007877AE67C4BE00D63C39A75B6A17BA6DDDAD95D0060B89A22B1CDC\r\n 7F09C60D6D068CE499C4DEB1DC0678C671556ACDEA012F1DC66AB56D3BE86B05\r\n 6897ECB5010C91B301BA321813C8241C8CD767F10FE29F88FE285D69D71E23BE\r\n 5BD96C2DFECB6AAB18458E31FC200FA0FCABCF69E256007CCDC74E6A60975138\r\n F62C4978EAE46D518EDD6A7865F35338C738C567139393D4D286C1F43EB5A464\r\n 9E8C99534D685AB895E3942AB1C1F606B67C32F6116BB00D56C2F355B160CA6D\r\n 2D24D92C8E47C9B48E7AF38EF8AE7A13334A5FCC19519C367045757E28D7342B\r\n 3F1245A8F82A3BED36CE2489A35BB93CC9A39C0F998139E33D2A65B90D35A247\r\n 317EAE97322BA3441598047EAA013C1F71D0D5ED222FB46C423183DFBD66DCDC\r\n 4977712CF339926958BC8C7F898F53F535B3A45C20991B85038C7A1A8B68DA2E\r\n 4B449A3D8FC05E0AFED1781513CC795951557B927007E75EE7E28FD967C5FE13\r\n D11B557D3C18A15F31DED27CBC43D4E39C735E61F0FBC4369A3DFDA4D67234D1\r\n 5B4B14A0CA36962A41208FA8AFAD7E21FED57E1ED6BE1BDF5958C5749AB5F41E\r\n 434528C24408F98EEEFC7F3A29D38CA2DC9EA6725A9F9E5E38D1BECB712301D4\r\n F5F53F5AE124B647724AE49F735E8BF1075413CD2202383FC3D2BCD67BB68E56\r\n 550A40A882BAD4766F637EEAE099327391C67D6B53C376173AD6A10D9DA2996E\r\n 256091A2F5627800554F125BD9C370DF65BA330F4688A1FD6B36C75B6D227595\r\n 5CABA904153820FA8A3974B9A2958F49F1878035FF00879E2F4F0DEABA6BD96B\r\n 6FB365AB91B98BAEE5EF8C9FAF6A3E21FC6AF16789FC2965E0AD6AFDE4D3B469\r\n 5962B475198644254AE47A7CC2BCF7C49E34D435DBE6BABFBBB9BBBB6550269E\r\n 5676C0FBBC939E2AAE91A55FF8C353B5D334E8DAF353BD7D9144A7976EA464D5\r\n 4636149DD1937CD997AF6AAD5AAFE18BD8DB5613F976C74B668EE125902B7981\r\n 8AEC033C9CF1C564EEC8E013573772A2D2D05A01249E38A8F73EFE9806B43508\r\n 6CEDA2B46B6B96B891E159260F1141149DD39FBDF51EB52A23E629D142B6E19C\r\n E7E945496222ECCF2493DE94B051927149236D426AB1249E493F5AB4B9B53294\r\n D4344588E4DE4FB559B6B836F203CE3BE2A8A82A4153927B0A58DCA139E4679F\r\n 6AAB5B6254F4B48EE74AF13CD6254AB37D41AD6D43C6F72D1A063B830E00607F\r\n FD55E7B6B388DB924A9F4348F70CCD9CED27AEDE334BD9C65A8ED2BD8D6D5B54\r\n 7B8CC849249E33CD6313B8E7AE7BD31E46249CE7D734D6258E623B530301B935\r\n AC1A8EC3DB43BCD77C21E20B2919EE348BB503B8407F91AE2EEA19609D966464\r\n 7EBB5860D6B5D6BD78E483A8DE9ED817321C7FE3D58B2CED2B969242EFDD9DB2\r\n 6B269A4850EE365CBAF04834FB7BB920955E09648A48DB72BC6C54A9F50477AA\r\n F24A0AE17BF7A8D18A364552BCB7265349E85A790CB2333B6F91896666392493\r\n 9273EB49554F35345180031EB5128DBA9509F33B244948E4BB804640EE6968A9\r\n 4DA356AE008CE3D3B52160A4027AD1B06ECE39F5A7038A340D464D6F3795E615\r\n FDD6786E3E955EA49931F367AF6A8C004F3C0F5AD95BA1C734F9B525B664593E\r\n 7CE3DBBFB5761E2BD13C39A7F85340BCD2B567D4353BC84C9A95A15DBF637CE0\r\n 274E7EBDFAD71E8523E73926A404051D854B958D631BADCAE188E8481F5A532B\r\n 1503278EF4F9191BEBED51535A993BC744C01C54EAEA8A149C11DA990CDE4B64\r\n 2827B1ABAA8D3A893ED463DC06573D0F7EF4DAB8E2F9754453585DB3FF00C7AC\r\n DC7FD333FE148BA55D9EB6F28FF801AFEA768A6EEC9BA6EECFE591B49B90BC5B\r\n CD91FF004CCF3FA545FD9B77FF003EB37FDFB3FE15FD5051492B049A7B23F95F\r\n FECDBBFF009F59BFEFD9FF000A912C6F49C7D9A6FF0081467FC2BFA9CA286AE0\r\n 9D8FE5E66F0A5DDB68167AA19A0985CCAF17D9237637316DFE274C70A7B1C9AC\r\n EFECFB9CE7ECD2E7D7CB35FD4BD152E3734551AE87F2CED6772A71F659CFD233\r\n 4C369798E2D26FC633FE15FD4DD14D4509D4933F9616B1BC6EB6D3E3D3CB3FE1\r\n 4DFECDBBFF009F59BFEFD9FF000AFEA828AAD8CDB6F73F9628F4CB960736D303\r\n DB319AD1B2D2A2FECFBC1776F7DF6C0AA6D444A3CB2727707CF3D318C63BD7F5\r\n 19452B0D4AC7F2F7278035B93C31278921B076D1D2E7ECAD202372498040299D\r\n C383C1C62B2174AB86419B6981FF0070D7F537450D5C14ACF547F2C0DA65DAB6\r\n 3ECD31F7119A5FECDBAFF9F59BFEFD9AFEA7A8AB8CB97A12F53FFFD9}\r\n OnMouseDown = Panel1MouseDown\r\n ExplicitWidth = 137\r\n end\r\n object imgProjectJEDI: TImage\r\n Left = 13\r\n Top = 194\r\n Width = 116\r\n Height = 31\r\n AutoSize = True\r\n Center = True\r\n Picture.Data = {\r\n 0A544A504547496D616765650B0000FFD8FFE000104A46494600010100000100\r\n 010000FFDB0043000302020302020303030304030304050805050404050A0707\r\n 06080C0A0C0C0B0A0B0B0D0E12100D0E110E0B0B1016101113141515150C0F17\r\n 1816141812141514FFDB00430103040405040509050509140D0B0D1414141414\r\n 1414141414141414141414141414141414141414141414141414141414141414\r\n 14141414141414141414141414FFC0001108001F007403012200021101031101\r\n FFC4001F0000010501010101010100000000000000000102030405060708090A\r\n 0BFFC400B5100002010303020403050504040000017D01020300041105122131\r\n 410613516107227114328191A1082342B1C11552D1F02433627282090A161718\r\n 191A25262728292A3435363738393A434445464748494A535455565758595A63\r\n 6465666768696A737475767778797A838485868788898A92939495969798999A\r\n A2A3A4A5A6A7A8A9AAB2B3B4B5B6B7B8B9BAC2C3C4C5C6C7C8C9CAD2D3D4D5D6\r\n D7D8D9DAE1E2E3E4E5E6E7E8E9EAF1F2F3F4F5F6F7F8F9FAFFC4001F01000301\r\n 01010101010101010000000000000102030405060708090A0BFFC400B5110002\r\n 0102040403040705040400010277000102031104052131061241510761711322\r\n 328108144291A1B1C109233352F0156272D10A162434E125F11718191A262728\r\n 292A35363738393A434445464748494A535455565758595A636465666768696A\r\n 737475767778797A82838485868788898A92939495969798999AA2A3A4A5A6A7\r\n A8A9AAB2B3B4B5B6B7B8B9BAC2C3C4C5C6C7C8C9CAD2D3D4D5D6D7D8D9DAE2E3\r\n E4E5E6E7E8E9EAF2F3F4F5F6F7F8F9FAFFDA000C03010002110311003F00FA77\r\n E3CFC64D2FE0B6B6F73E2DF1CEA9E1FB3D4AFAE16C9524BB914846C9555895B6\r\n 80197AE073C571BE03FDA7FC1DF12B5FB6D0FC3DF156FAF356B96D90DACD7377\r\n 6ED2B609DABE6AAEE6C06E073C575DFB757ECF5A17C6C1E10B5D5757D43487B7\r\n 7BD9E096C228A4DD2308461D5D97231FDD39CD78D7887F613F07697E3AF859AC\r\n F877C449A05DE8DA56912DC5BC36689F6FBB864DED7121F306C964C2E40C9C80\r\n 4649A4F1118BB12A8392B9F491D3BC5249FF008A875903D46A12FF00F15EF48F\r\n 63E274049F11EB0A39EBA84A07FE85F5AF83AE3F601F885A9687F11358835D3A\r\n D6B568D6B79E1DB5D17535297A25B9613A4E24DAD1491C65580CED24E159F15B\r\n 3F1C3E1B7C69F887F0FBF67ED03C49A7F8AAF6E624BA83C457362925E1808BE3\r\n 0473DCBC45D0C82DD01F31C93CC849CB355AAD16AE4FB168FB6058789DD72BE2\r\n 3D61811C11A84BCFFE3D4A74EF1460E3C43ACFB7FA7CBEFF00ED7D2BE69FD863\r\n E1678DFE127ED61F11BC17A85AF8A53E1F476D7D169F7DACD94B1DADEBC1771A\r\n 5BCA923208D9CC4D29FDDE0302C70428C72BE277BEB5FF0082927C45B1FB55C2\r\n D926877EF1C5E6B08F8D177021738FBC3B77155ED09F647D81FD9DE28CFF00C8\r\n C5ACE39FF97F97DFFDAA69B2F1316DBFF0926AFBCF45FED097D3FDEFAFE55F9E\r\n BFB0A687E15D6F59FF00849757F893A969DF10F489EEA6D17C2FE6174D4923B2\r\n 79096C83E920C6402171C93CF1FF0003FF00678F1DFED25F0F7C63E2FF000C6A\r\n DACEAFE3BD2B57B44480EA2B11992612BCD33CD2306F3032A904367E63D7390F\r\n 9FC83D9799FA7874EF1413FF002316B207B5FCBEFF00ED5034EF147FD0C5ACFF\r\n 00E07CBEBFEF7D2BF3AFF69AFD9F359F85FF00117E175BEB5E27D67FE123F886\r\n 63BEF10C2D3205B1BE9E68FED29088FE5DAB24B263A8E00C91D7F563E10FC11B\r\n 2F849F0E345F0945AB5E6B71E991BC6B7F7D8F3A50D233FCD8E38DD8FA014738\r\n 9D3F33E76F07FC74D1FC7BE3DD53C17A0FC43D5EFF00C4DA599C5DD8092F13CA\r\n F264114BF3BA843B5C81C31CF51919AF45FECEF14E3FE462D6738E9F6F97FF00\r\n 8AAFC9CF194D3587C54FDA267B69E48278AE750C340C430FF89F5A83C8E79C9E\r\n FEB5ED5FB2EF84BC11A87C0CF885E293F132FAE3E24C7E09F11F9FE10926CA24\r\n 2B0CAAB3292324EDF2DF827AE7A03839C7ECD773EF93A778A3903C43ACFB6750\r\n 97FF008AA0E9FE27DDFF002316B3F4FB7CBFFC557E393C3AF782FE11F85BE276\r\n 93E2DD6EC75E9FC4B7FA5AAC576C1625B7B7B49124420E771FB4BAB0390401C7\r\n 273F465D7C62D4FC29FF000503BEF181D3B54D611F47B7BC4D0F4E0F2896E2E3\r\n 4389A38C460F4F32404F700120122AA327276483D9F99C37FC14E7C55E2DF0AF\r\n C7CD0AD62F14EB91093C356F31035198649BABA5CFDEFF0066BE44FF0085A1E3\r\n 2FFA1B75DFFC194DFF00C557ACFEDB4DE37BCF8C169AAF8EF51B7D5F50D5B47B\r\n 7D42CAFAC67596D25B47793CBF20AF011583AE0018657CE4E49F00A8A91E5934\r\n 6915647F447FB4E5D5B5E5DF87B7C8635B6FB52B30708324C3DC823F84FF0091\r\n 527C3DF853A5598D2759D4358D42E1B6C77634D4C431AB9018090E37B6D3C632\r\n A08C8652381F3E78FF00FE0A0BF0634FF186B9A75EF8A959ED6FA68CA49A4DDB\r\n 804391C7EE48E95909FF000521F8311A2AAF8C595546028D26F4003D3FD4D64A\r\n 8C79F9DB13A92B5923DBB45B4BB9FC3DA85F36B1716CF6290A0B79465652ED8C\r\n 13B32A071B76F3C9CE7E523A0FEDB92E7C3DE1E8634F2D8DBCC922D933E1B13B\r\n 0672173BCB64162D9DC5989C939AF9987FC1427E04AA5CA0F11C012E7FD7A8D1\r\n 2EC097FDEFDC7CDD4F5F5351DDFF00C1403E025FE9CB6173AFDADC582FDDB597\r\n 42BA688739E14C18EB59AC3D9594BFAB95ED9F667D5575F115B4EF125E5CC16A\r\n 2D5D659678DA689C3B42CFB77608CFDE9173C606473C9AB6BAD45AE7892DAE2E\r\n A354BB95660D14B9567536B2A950A7EF72C338E99FAD7C91A6FEDFBF00B45B69\r\n 2DB4FD7AD2CADE4003C36DA15D468E06700810007A9FCE8D2BF6FEF805A0A4AB\r\n A66BB69A7ACB9F305A68375107CF5CED8067F1AA5476BC85ED5F667D25E15F84\r\n 1F092D3C5E9E256F04E8B67ABDB8F26D6EF4DB116843CA258E4DDE56D5766590\r\n AE58124679E38E83E10781FC05F066DB5983C0DA52786ACEF648A5BB28CCEA4A\r\n 07196DECDB40CE327D3BD7C9B6FF00B7F7C02B39925835DB4865439478F42BA5\r\n 653EA08838A86EFF006EFF00D9E6FEF8DEDD6ABA75CDE16DC6E26F0F5CBC99F5\r\n DC6DF39F7AA54AC97BC1ED5DF667D15F1FFE06784FE3F4FE0FF1EEAFA96AFA76\r\n B9E18B35BFB3B785A382390A959F6CD1C913383B900C06520161D45753F1DFC3\r\n 1E2EF1CF88FC337BE0FF0089FA8F8185938F3F4DB5B5F3E2D40798A4EFC10C30\r\n 3E5E011F373E87E5BBBFF82887C0DBF78DEEBC4F15CBC7F71A6D16EDCAF7E098\r\n 78E40FCA9F7BFF000516F823A8DBBC177E2B5BA81F868A6D1EF1D5BEA0C38AB7\r\n 0DF517B47A68707E27FD827C6BAC7C41F8A93D978AFC1D2378C16F2F2CA037B7\r\n 41A08DF54B6BA067616C563F917681924B1E32158AFA17C2DFD996DBE0E7ECD3\r\n E31B0D4FE1F5CDC7C58D47C31E21D362D774A9C5E4575E6C13982DD16394B33B\r\n 26C555F28312B8EB8CD2B3FF0082847C09D3ED24B3B5F11C16B692643C30E897\r\n 691BE460E54418391ED589E25FF8289FC1AF0F6877577E1CB9B7D57570A56DED\r\n 63D267B70598632CED10017079C724700734D41DD6A839EFF64F27F15683F0EB\r\n C43F08F4DF83363E00F883E1EF1DDB5D477DA645ADDA182F2F355B958E394B5B\r\n BBED10491DBC60107F779042B6097FA3FE03FC233A1F8DA693C5C9617DF13B55\r\n B546D38BDC24490A5B0090B693791B32C81115629410644280B2C885B7FCF5F0\r\n 93F680F807A825C78BFC73E3DBBD37C7FABCF27DAFCBD12E146906370D6B71A7\r\n 4D046C6274DABF7B707C147500EFA93E26FEDA3F0E3C7F6EBE0C6D6EDECA0FED\r\n 58F51BEF1C69F67791C7249167FD2AC2D3C9125A5C4E180987DCCAB119DC49F4\r\n 23C91F7535E6FF00AFE9892B1F3E7FC1426FBC1BA8FC7B8EE3C186E6181F4B8C\r\n EA9A7CF1794B63A97DA27FB4C31A0255577FCE4464A6F91F69208AF99ABDE7F6\r\n C6F1C7803C6FE3DF0C9F86D324DE1CD2BC3D0E9DB96DA5849996E2E2462DE62A\r\n B33112AB16C724F5AF06AE0A8D39368B5AA3FFD9}\r\n OnMouseDown = Panel1MouseDown\r\n end\r\n object lblJvHotLink2: TLabel\r\n Left = 20\r\n Top = 228\r\n Width = 102\r\n Height = 13\r\n Cursor = crHandPoint\r\n Caption = ' http://delphi-jedi.org '\r\n Color = clBlack\r\n Font.Charset = DEFAULT_CHARSET\r\n Font.Color = clWhite\r\n Font.Height = -11\r\n Font.Name = 'MS Sans Serif'\r\n Font.Style = []\r\n ParentColor = False\r\n ParentFont = False\r\n end\r\n end\r\n object btnOK: TButton\r\n Left = 338\r\n Top = 280\r\n Width = 88\r\n Height = 25\r\n Cancel = True\r\n Caption = 'OK'\r\n ModalResult = 2\r\n TabOrder = 1\r\n OnClick = btnOKClick\r\n end\r\n end\r\n object OpenDialog1: TOpenDialog\r\n Filter = 'Help files|*.chm; *.hlp'\r\n Left = 184\r\n Top = 272\r\n end\r\nend\r\n" }, { "path": "External/Jedi/Jvcl/run/JvJVCLAboutForm.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvJVCLAboutForm.PAS, released on 2001-02-28.\r\n\r\nThe Initial Developer of the Original Code is Michael Beck [mbeck att bigfoot dott com]\r\nPortions created by Michael Beck are Copyright (C) 2002 Michael Beck\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvJVCLAboutForm.pas 13412 2012-09-08 10:19:55Z ahuser $\r\n\r\nunit JvJVCLAboutForm;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n {$IFDEF MSWINDOWS}\r\n Windows,\r\n JclWin32,\r\n {$ENDIF MSWINDOWS}\r\n SysUtils, Classes, IniFiles, Messages, Controls, Forms, StdCtrls, ExtCtrls,\r\n Dialogs, Buttons,\r\n jpeg, // this is required because the Picture contains a JPEG image\r\n JclSysInfo,\r\n JVCLVer, JvBaseDlg, JvComponent;\r\n\r\ntype\r\n TJvJVCLAboutForm = class(TJvForm)\r\n Bevel1: TBevel;\r\n lblVersion: TLabel;\r\n pnlImage: TPanel;\r\n imgStarfield: TImage;\r\n btnOK: TButton;\r\n JvHotLink1: TLabel;\r\n JvHotLink4: TLabel;\r\n lblNews: TLabel;\r\n Label1: TLabel;\r\n Label2: TLabel;\r\n lblCopyRight: TLabel;\r\n lblRights: TLabel;\r\n imgProjectJEDI: TImage;\r\n MainPanel: TPanel;\r\n Bevel2: TBevel;\r\n lblVisitJedi: TLabel;\r\n lblMailingList: TLabel;\r\n lblNewsgroup: TLabel;\r\n lblJvHotLink2: TLabel;\r\n lblBugs: TLabel;\r\n lblBugsURL: TLabel;\r\n btnHelp: TSpeedButton;\r\n btnOptions: TSpeedButton;\r\n OpenDialog1: TOpenDialog;\r\n Bevel3: TBevel;\r\n lblWindowsVersion: TLabel;\r\n Label4: TLabel;\r\n lblMemory: TLabel;\r\n procedure btnOKClick(Sender: TObject);\r\n procedure FormShow(Sender: TObject);\r\n procedure Panel1MouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);\r\n procedure btnHelpClick(Sender: TObject);\r\n procedure btnOptionsClick(Sender: TObject);\r\n procedure OpenURLClick(Sender: TObject);\r\n private\r\n FHelpFile: string;\r\n FHelpDirectory: string;\r\n FParentWnd: HWND;\r\n protected\r\n procedure CreateParams(var Params: TCreateParams); override;\r\n public\r\n constructor Create(AOwner: TComponent; AParentWnd: HWND); reintroduce; overload;\r\n procedure LoadOptions;\r\n procedure SaveOptions;\r\n class function Execute(AParentWnd: HWND; AStoreSettings: Boolean): Boolean;\r\n end;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64 or pidOSX32)]\r\n {$ENDIF RTL230_UP}\r\n TJvJVCLAboutComponent = class(TJvCommonDialog)\r\n private\r\n FStoreSettings: Boolean;\r\n public\r\n function Execute(AParentWnd: HWND): Boolean; overload; override;\r\n published\r\n property StoreSettings: Boolean read FStoreSettings write FStoreSettings default False;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvJVCLAboutForm.pas $';\r\n Revision: '$Revision: 13412 $';\r\n Date: '$Date: 2012-09-08 12:19:55 +0200 (sam. 08 sept. 2012) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n JvJCLUtils;\r\n\r\n{$R *.dfm}\r\n\r\nconst\r\n cOptions = 'Options';\r\n cBoundsLeft = 'Bounds.Left';\r\n cBoundsTop = 'Bounds.Top';\r\n cHelpFile = 'Help.File';\r\n cHelpDirectory = 'Help.Directory';\r\n {$IFDEF MSWINDOWS}\r\n cJVCLIni = '\\JVCL.ini';\r\n {$ENDIF MSWINDOWS}\r\n {$IFDEF UNIX}\r\n cJVCLIni = '/.JVCL';\r\n {$ENDIF UNIX}\r\n\r\nprocedure TJvJVCLAboutForm.FormShow(Sender: TObject);\r\n{$IFDEF MSWINDOWS}\r\nvar\r\n VersionInfo: TOSVersionInfoEx;\r\n{$ENDIF MSWINDOWS}\r\nbegin\r\n lblVersion.Caption := 'Version: ' + JVCL_VERSIONSTRING;\r\n {$IFDEF MSWINDOWS}\r\n FillChar(VersionInfo, SizeOf(TOSVersionInfoEx), 0);\r\n VersionInfo.dwOSVersionInfoSize := SizeOf(TOSVersionInfoEx);\r\n JclWin32.GetVersionEx(VersionInfo);\r\n if VersionInfo.wServicePackMajor = 0 then\r\n lblWindowsVersion.Caption := Format('%s (Build %u)',\r\n [GetWindowsVersionString, VersionInfo.dwBuildNumber])\r\n else\r\n lblWindowsVersion.Caption := Format('%s (Build %u: %s)',\r\n [GetWindowsVersionString, VersionInfo.dwBuildNumber, GetWindowsServicePackVersionString]);\r\n {$ENDIF MSWINDOWS}\r\n {$IFDEF UNIX}\r\n lblWindowsVersion.Caption := GetOSVersionString;\r\n Label4.Caption := 'Memory Available to OS:';\r\n {$ENDIF UNIX}\r\n lblMemory.Caption := Format('%u KB', [GetTotalPhysicalMemory div 1024]);\r\n lblCopyRight.Caption := 'Copyright Project JEDI, 1999 - ' + FormatDateTime('yyyy', Now);\r\n// LoadOptions;\r\n btnHelp.Enabled := FHelpFile <> '';\r\nend;\r\n\r\nprocedure TJvJVCLAboutForm.Panel1MouseDown(Sender: TObject;\r\n Button: TMouseButton; Shift: TShiftState; X, Y: Integer);\r\nbegin\r\n ReleaseCapture;\r\n Perform(WM_SYSCOMMAND, SC_MOVE + 2, 0);\r\nend;\r\n\r\nprocedure TJvJVCLAboutForm.btnHelpClick(Sender: TObject);\r\nbegin\r\n Exec(FHelpFile, '', FHelpDirectory);\r\n Close;\r\nend;\r\n\r\nprocedure TJvJVCLAboutForm.btnOptionsClick(Sender: TObject);\r\nbegin\r\n if OpenDialog1.Execute then\r\n begin\r\n FHelpFile := ExtractFileName(OpenDialog1.FileName);\r\n FHelpDirectory := ExtractFileDir(OpenDialog1.FileName);\r\n// SaveOptions;\r\n btnHelp.Enabled := FHelpFile <> '';\r\n end;\r\nend;\r\n\r\nconstructor TJvJVCLAboutForm.Create(AOwner: TComponent; AParentWnd: HWND);\r\nbegin\r\n FParentWnd := AParentWnd;\r\n Create(AOwner);\r\nend;\r\n\r\nprocedure TJvJVCLAboutForm.CreateParams(var Params: TCreateParams);\r\nbegin\r\n inherited CreateParams(Params);\r\n if FParentWnd <> 0 then\r\n Params.WndParent := FParentWnd;\r\nend;\r\n\r\nprocedure TJvJVCLAboutForm.LoadOptions;\r\nvar\r\n L, T: Integer;\r\nbegin\r\n {$IFDEF MSWINDOWS}\r\n with TIniFile.Create(ExtractFileDir(Application.ExeName) + cJVCLIni) do\r\n {$ENDIF MSWINDOWS}\r\n {$IFDEF UNIX}\r\n with TIniFile.Create(GetEnvironmentVariable('HOME') + cJVCLIni) do\r\n {$ENDIF UNIX}\r\n try\r\n L := ReadInteger(cOptions, cBoundsLeft, -1);\r\n T := ReadInteger(cOptions, cBoundsTop, -1);\r\n\r\n FHelpFile := ReadString(cOptions, cHelpFile, '');\r\n FHelpDirectory := ReadString(cOptions, cHelpDirectory, '');\r\n finally\r\n Free;\r\n end;\r\n\r\n //make sure the form is positioned on screen ...\r\n //(ie make sure nobody's fiddled with the INI file!)\r\n if (L >= 0) and (T >= 0) and (L < Screen.Width) and (T < Screen.Height) then\r\n begin\r\n Left := L;\r\n Top := T;\r\n end;\r\nend;\r\n\r\nprocedure TJvJVCLAboutForm.SaveOptions;\r\nbegin\r\n {$IFDEF MSWINDOWS}\r\n with TIniFile.Create(ExtractFileDir(Application.ExeName) + cJVCLIni) do\r\n {$ENDIF MSWINDOWS}\r\n {$IFDEF UNIX}\r\n with TIniFile.Create(GetEnvironmentVariable('HOME') + cJVCLIni) do\r\n {$ENDIF UNIX}\r\n try\r\n if WindowState = wsNormal then\r\n begin\r\n WriteInteger(cOptions, cBoundsLeft, Left);\r\n WriteInteger(cOptions, cBoundsTop, Top);\r\n end;\r\n WriteString(cOptions, cHelpFile, FHelpFile);\r\n WriteString(cOptions, cHelpDirectory, FHelpDirectory);\r\n finally\r\n Free;\r\n end;\r\nend;\r\n\r\nprocedure TJvJVCLAboutForm.btnOKClick(Sender: TObject);\r\nbegin\r\n Close;\r\nend;\r\n\r\nfunction TJvJVCLAboutComponent.Execute(AParentWnd: HWND): Boolean;\r\nbegin\r\n Result := TJvJVCLAboutForm.Execute(AParentWnd, StoreSettings);\r\nend;\r\n\r\nclass function TJvJVCLAboutForm.Execute(AParentWnd: HWND; AStoreSettings: Boolean): Boolean;\r\nbegin\r\n with Self.Create(nil, AParentWnd) do\r\n try\r\n if AStoreSettings then\r\n LoadOptions;\r\n // (rom) used as component outside the IDE the buttons are not useful\r\n btnHelp.Visible := AStoreSettings;\r\n btnOptions.Visible := AStoreSettings;\r\n Result := ShowModal = mrOk;\r\n if AStoreSettings then\r\n SaveOptions;\r\n finally\r\n Free;\r\n end;\r\nend;\r\n\r\nprocedure TJvJVCLAboutForm.OpenURLClick(Sender: TObject);\r\nbegin\r\n OpenObject((Sender as TLabel).Caption);\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvJVCLUtils.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvJVCLUtils.PAS, released on 2002-09-24.\r\n\r\nThe Initial Developers of the Original Code are: Fedor Koshevnikov, Igor Pavluk and Serge Korolev\r\nCopyright (c) 1997, 1998 Fedor Koshevnikov, Igor Pavluk and Serge Korolev\r\nCopyright (c) 2001,2002 SGB Software\r\nAll Rights Reserved.\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvJVCLUtils.pas 13415 2012-09-10 09:51:54Z obones $\r\n\r\nunit JvJVCLUtils;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Variants,\r\n {$IFDEF MSWINDOWS}\r\n Windows, Messages, ShellAPI, Registry,\r\n {$ENDIF MSWINDOWS}\r\n Types,\r\n {$IFDEF HAS_UNIT_SYSTEM_UITYPES}\r\n System.UITypes,\r\n {$ENDIF}\r\n SysUtils,\r\n Forms, Graphics, Controls, StdCtrls, ExtCtrls, Menus,\r\n Dialogs, ComCtrls, ImgList, Grids, MultiMon,\r\n Classes, // must be after \"Forms\"\r\n JclBase,\r\n JvJCLUtils, JvAppStorage, JvTypes;\r\n\r\n// Transform an icon to a bitmap\r\nfunction IconToBitmap(Ico: HICON): TBitmap;\r\n// Transform an icon to a bitmap using an image list\r\nfunction IconToBitmap2(Ico: HICON; Size: Integer = 32;\r\n TransparentColor: TColor = clNone): TBitmap;\r\nfunction IconToBitmap3(Ico: HICON; Size: Integer = 32;\r\n TransparentColor: TColor = clNone): TBitmap;\r\n\r\n// bitmap manipulation functions\r\n// NOTE: Dest bitmap must be freed by caller!\r\n// get red channel bitmap\r\nprocedure GetRBitmap(var Dest: TBitmap; const Source: TBitmap);\r\n// get green channel bitmap\r\nprocedure GetGBitmap(var Dest: TBitmap; const Source: TBitmap);\r\n// get blue channel bitmap\r\nprocedure GetBBitmap(var Dest: TBitmap; const Source: TBitmap);\r\n// get monochrome bitmap\r\nprocedure GetMonochromeBitmap(var Dest: TBitmap; const Source: TBitmap);\r\n// get hue bitmap (h part of hsv)\r\nprocedure GetHueBitmap(var Dest: TBitmap; const Source: TBitmap);\r\n// get saturation bitmap (s part of hsv)\r\nprocedure GetSaturationBitmap(var Dest: TBitmap; const Source: TBitmap);\r\n// get value bitmap (V part of HSV)\r\nprocedure GetValueBitmap(var Dest: TBitmap; const Source: TBitmap);\r\n\r\n\r\n// hides / shows the a forms caption area\r\nprocedure HideFormCaption(FormHandle: THandle; Hide: Boolean);\r\n\r\n{$IFDEF MSWINDOWS}\r\ntype\r\n TJvWallpaperStyle = (wpTile, wpCenter, wpStretch);\r\n\r\n// set the background wallpaper (two versions)\r\nprocedure SetWallpaper(const Path: string); overload;\r\nprocedure SetWallpaper(const Path: string; Style: TJvWallpaperStyle); overload;\r\n{$ENDIF MSWINDOWS}\r\n\r\nprocedure RGBToHSV(R, G, B: Integer; var H, S, V: Integer);\r\n\r\n{ from JvVCLUtils }\r\n\r\nprocedure CopyParentImage(Control: TControl; Dest: TCanvas);\r\n{ Windows resources (bitmaps and icons) VCL-oriented routines }\r\nprocedure DrawBitmapTransparent(Dest: TCanvas; DstX, DstY: Integer;\r\n Bitmap: TBitmap; TransparentColor: TColor);\r\nprocedure DrawBitmapRectTransparent(Dest: TCanvas; DstX, DstY: Integer;\r\n SrcRect: TRect; Bitmap: TBitmap; TransparentColor: TColor);\r\nprocedure StretchBitmapRectTransparent(Dest: TCanvas; DstX, DstY, DstW,\r\n DstH: Integer; SrcRect: TRect; Bitmap: TBitmap; TransparentColor: TColor);\r\nfunction MakeBitmap(ResID: PChar): TBitmap;\r\nfunction MakeBitmapID(ResID: Word): TBitmap;\r\nfunction MakeModuleBitmap(Module: THandle; ResID: PChar): TBitmap;\r\nfunction CreateTwoColorsBrushPattern(Color1, Color2: TColor): TBitmap;\r\nfunction CreateDisabledBitmap_NewStyle(FOriginal: TBitmap; BackColor: TColor):\r\n TBitmap;\r\nfunction CreateDisabledBitmapEx(FOriginal: TBitmap; OutlineColor, BackColor,\r\n HighLightColor, ShadowColor: TColor; DrawHighlight: Boolean): TBitmap;\r\nfunction CreateDisabledBitmap(FOriginal: TBitmap; OutlineColor: TColor):\r\n TBitmap;\r\nprocedure AssignBitmapCell(Source: TGraphic; Dest: TBitmap; Cols, Rows,\r\n Index: Integer);\r\nfunction ChangeBitmapColor(Bitmap: TBitmap; Color, NewColor: TColor): TBitmap;\r\nprocedure ImageListDrawDisabled(Images: TCustomImageList; Canvas: TCanvas;\r\n X, Y, Index: Integer; HighLightColor, GrayColor: TColor;\r\n DrawHighlight: Boolean);\r\n\r\nfunction MakeIcon(ResID: PChar): TIcon;\r\nfunction MakeIconID(ResID: Word): TIcon;\r\nfunction MakeModuleIcon(Module: THandle; ResID: PChar): TIcon;\r\nfunction CreateBitmapFromIcon(Icon: TIcon; BackColor: TColor): TBitmap;\r\nfunction CreateIconFromBitmap(Bitmap: TBitmap; TransparentColor: TColor): TIcon;\r\n\r\nfunction CreateRotatedFont(Font: TFont; Angle: Integer): HFONT;\r\n\r\n//1 This function validates if the control or any of it subcontrols has the focus.\r\nfunction IsSubControlFocused(AControl: TWinControl): Boolean;\r\n\r\n// launches the specified CPL file\r\n// format: [,@n] or [,,m] or [,@n,m]\r\n// where @n = zero-based index of the applet to start (if there is more than one\r\n// m is the zero-based index of the tab to display\r\n\r\nprocedure LaunchCpl(const FileName: string);\r\n\r\n// for Win 2000 and XP\r\nprocedure ShowSafeRemovalDialog;\r\n\r\n{\r\n GetControlPanelApplets retrieves information about all control panel applets in a specified folder.\r\n APath is the Path to the folder to search and AMask is the filename mask (containing wildcards if necessary) to use.\r\n\r\n The information is returned in the Strings and Images lists according to the following rules:\r\n The Display Name and Path to the CPL file is returned in Strings with the following format:\r\n '='\r\n You can access the DisplayName by using the Strings.Names array and the Path by accessing the Strings.Values array\r\n Strings.Objects can contain either of two values depending on if Images is nil or not:\r\n * If Images is nil then Strings.Objects contains the image for the applet as a TBitmap. Note that the caller (you)\r\n is responsible for freeing the bitmaps in this case\r\n * If Images <> nil, then the Strings.Objects array contains the index of the image in the Images array for the selected item.\r\n To access and use the ImageIndex, typecast Strings.Objects to an int:\r\n Tmp.Name := Strings.Name[I];\r\n Tmp.ImageIndex := Integer(Strings.Objects[I]);\r\n The function returns True if any Control Panel Applets were found (i.e Strings.Count is > 0 when returning)\r\n}\r\n\r\nfunction GetControlPanelApplets(const APath, AMask: string; Strings: TStrings;\r\n Images: TCustomImageList = nil): Boolean;\r\n{ GetControlPanelApplet works like GetControlPanelApplets, with the difference that it only loads and searches one cpl file (according to AFilename).\r\n Note though, that some CPL's contains multiple applets, so the Strings and Images lists can contain multiple return values.\r\n The function returns True if any Control Panel Applets were found in AFilename (i.e if items were added to Strings)\r\n}\r\nfunction GetControlPanelApplet(const AFileName: string; Strings: TStrings;\r\n Images: TCustomImageList = nil): Boolean;\r\n\r\nfunction PointInPolyRgn(const P: TPoint; const Points: array of TPoint): Boolean;\r\nfunction PaletteColor(Color: TColor): Longint;\r\nprocedure PaintInverseRect(const RectOrg, RectEnd: TPoint);\r\nprocedure DrawInvertFrame(ScreenRect: TRect; Width: Integer);\r\n\r\nprocedure ShowMDIClientEdge(ClientHandle: THandle; ShowEdge: Boolean);\r\n\r\nfunction GetTickCount64: Int64;\r\nprocedure Delay(MSecs: Int64); // WARNING: This function calls ProcessMessages\r\nprocedure CenterControl(Control: TControl);\r\n\r\nprocedure MergeForm(AControl: TWinControl; AForm: TForm; Align: TAlign;\r\n Show: Boolean);\r\nfunction GetAveCharSize(Canvas: TCanvas): TPoint;\r\n\r\n{ Gradient filling routine }\r\n\r\ntype\r\n TFillDirection = (fdTopToBottom, fdBottomToTop, fdLeftToRight, fdRightToLeft);\r\n\r\nprocedure GradientFillRect(Canvas: TCanvas; ARect: TRect; StartColor,\r\n EndColor: TColor; Direction: TFillDirection; Colors: Byte);\r\n\r\nprocedure StartWait;\r\nprocedure StopWait;\r\nfunction DefineCursor(Instance: THandle; ResID: PChar): TCursor;\r\nfunction GetNextFreeCursorIndex(StartHint: Integer; PreDefined: Boolean): Integer;\r\nfunction WaitCursor: IInterface;\r\nfunction ScreenCursor(ACursor: TCursor): IInterface;\r\n{$IFDEF MSWINDOWS}\r\n// loads the more modern looking drag cursors from OLE32.DLL\r\nfunction LoadOLEDragCursors: Boolean;\r\n// set some default cursor from JVCL\r\n{$ENDIF MSWINDOWS}\r\nprocedure SetDefaultJVCLCursors;\r\n\r\n\r\nfunction LoadAniCursor(Instance: THandle; ResID: PChar): HCURSOR;\r\n\r\n{ Windows API level routines }\r\n\r\nprocedure StretchBltTransparent(DstDC: HDC; DstX, DstY, DstW, DstH: Integer;\r\n SrcDC: HDC; SrcX, SrcY, SrcW, Srch: Integer;\r\n Palette: HPALETTE; TransparentColor: TColorRef);\r\nprocedure DrawTransparentBitmap(DC: HDC; Bitmap: HBITMAP;\r\n DstX, DstY: Integer; TransparentColor: TColorRef);\r\nfunction PaletteEntries(Palette: HPALETTE): Integer;\r\nprocedure ShadeRect(DC: HDC; const Rect: TRect);\r\n\r\nfunction ScreenWorkArea: TRect;\r\n\r\n{ Grid drawing }\r\n\r\ntype\r\n TVertAlignment = (vaTopJustify, vaCenterJustify, vaBottomJustify);\r\n\r\nprocedure WriteText(ACanvas: TCanvas; ARect: TRect; DX, DY: Integer;\r\n const Text: string; Alignment: TAlignment; WordWrap: Boolean; ARightToLeft:\r\n Boolean = False);\r\nprocedure DrawCellText(Control: TCustomControl; ACol, ARow: Longint;\r\n const S: string; const ARect: TRect; Align: TAlignment;\r\n VertAlign: TVertAlignment); overload;\r\nprocedure DrawCellTextEx(Control: TCustomControl; ACol, ARow: Longint;\r\n const S: string; const ARect: TRect; Align: TAlignment;\r\n VertAlign: TVertAlignment; WordWrap: Boolean); overload;\r\nprocedure DrawCellText(Control: TCustomControl; ACol, ARow: Longint;\r\n const S: string; const ARect: TRect; Align: TAlignment;\r\n VertAlign: TVertAlignment; ARightToLeft: Boolean); overload;\r\nprocedure DrawCellTextEx(Control: TCustomControl; ACol, ARow: Longint;\r\n const S: string; const ARect: TRect; Align: TAlignment;\r\n VertAlign: TVertAlignment; WordWrap: Boolean; ARightToLeft: Boolean);\r\noverload;\r\nprocedure DrawCellBitmap(Control: TCustomControl; ACol, ARow: Longint;\r\n Bmp: TGraphic; Rect: TRect);\r\n\r\n\r\ntype\r\n TJvDesktopCanvas = class(TCanvas)\r\n private\r\n FDC: HDC;\r\n protected\r\n procedure CreateHandle; override;\r\n public\r\n destructor Destroy; override;\r\n procedure SetOrigin(X, Y: Integer);\r\n procedure FreeHandle;\r\n end;\r\n\r\n\r\n\r\n { end from JvVCLUtils }\r\n\r\n { begin JvUtils }\r\n {**** other routines - }\r\n { FindByTag returns the control with specified class,\r\n ComponentClass, from WinContol.Controls property,\r\n having Tag property value, equaled to Tag parameter }\r\nfunction FindByTag(WinControl: TWinControl; ComponentClass: TComponentClass;\r\n const Tag: Integer): TComponent;\r\n{ ControlAtPos2 equal to TWinControl.ControlAtPos function,\r\n but works better }\r\nfunction ControlAtPos2(Parent: TWinControl; X, Y: Integer): TControl;\r\n{ RBTag searches WinControl.Controls for checked\r\n RadioButton and returns its Tag property value }\r\nfunction RBTag(Parent: TWinControl): Integer;\r\n{ FindFormByClass returns first form with specified\r\n class, FormClass, owned by Application global variable }\r\nfunction FindFormByClass(FormClass: TFormClass): TForm;\r\nfunction FindFormByClassName(const FormClassName: string): TForm;\r\n{ AppMinimized returns True, if Application is minimized }\r\nfunction AppMinimized: Boolean;\r\nfunction IsForegroundTask: Boolean;\r\n\r\nfunction MsgBox(const Caption, Text: string; Flags: Integer): Integer; overload;\r\nfunction MsgBox(Handle: THandle; const Caption, Text: string; Flags: Integer): Integer; overload;\r\nfunction MsgDlg(const Msg: string; AType: TMsgDlgType; AButtons: TMsgDlgButtons; HelpCtx: Longint): Word;\r\nfunction MsgDlg2(const Msg, ACaption: string; DlgType: TMsgDlgType;\r\n Buttons: TMsgDlgButtons; HelpContext: Integer; Control: TWinControl): Integer;\r\nfunction MsgDlgDef(const Msg, ACaption: string; DlgType: TMsgDlgType;\r\n Buttons: TMsgDlgButtons; DefButton: TMsgDlgBtn; HelpContext: Integer;\r\n Control: TWinControl): Integer;\r\n\r\n(***** Utility MessageBox based dialogs *)\r\n// returns True if user clicked Yes\r\nfunction MsgYesNo(Handle: Integer; const Msg, Caption: string; Flags: DWORD = 0): Boolean;\r\n// returns True if user clicked Retry\r\nfunction MsgRetryCancel(Handle: Integer; const Msg, Caption: string; Flags: DWORD = 0): Boolean;\r\n// returns IDABORT, IDRETRY or IDIGNORE\r\nfunction MsgAbortRetryIgnore(Handle: Integer; const Msg, Caption: string; Flags: DWORD = 0): Integer;\r\n// returns IDYES, IDNO or IDCANCEL\r\nfunction MsgYesNoCancel(Handle: Integer; const Msg, Caption: string; Flags: DWORD = 0): Integer;\r\n// returns True if user clicked OK\r\nfunction MsgOKCancel(Handle: Integer; const Msg, Caption: string; Flags: DWORD = 0): Boolean;\r\n\r\n// dialog without icon\r\nprocedure MsgOK(Handle: Integer; const Msg, Caption: string; Flags: DWORD = 0);\r\n// dialog with info icon\r\nprocedure MsgInfo(Handle: Integer; const Msg, Caption: string; Flags: DWORD = 0);\r\n// dialog with warning icon\r\nprocedure MsgWarn(Handle: Integer; const Msg, Caption: string; Flags: DWORD = 0);\r\n// dialog with question icon\r\nprocedure MsgQuestion(Handle: Integer; const Msg, Caption: string; Flags: DWORD = 0);\r\n// dialog with error icon\r\nprocedure MsgError(Handle: Integer; const Msg, Caption: string; Flags: DWORD = 0);\r\n// dialog with custom icon (must be available in the app resource)\r\nprocedure MsgAbout(Handle: Integer; const Msg, Caption: string; const IcoName: string = 'MAINICON'; Flags: DWORD = MB_OK);\r\n\r\n{**** Windows routines }\r\n\r\n{ LoadIcoToImage loads two icons from resource named NameRes,\r\n into two image lists ALarge and ASmall}\r\nprocedure LoadIcoToImage(ALarge, ASmall: ImgList.TCustomImageList;\r\n const NameRes: string);\r\n\r\n{ Works like InputQuery but displays 2 edits. If PasswordChar <> #0, the second edit's PasswordChar is set }\r\nfunction DualInputQuery(const ACaption, Prompt1, Prompt2: string;\r\n var AValue1, AValue2: string; PasswordChar: Char = #0): Boolean;\r\n\r\n{ Works like InputQuery but set the edit's PasswordChar to PasswordChar. If PasswordChar = #0, works exactly like InputQuery }\r\nfunction InputQueryPassword(const ACaption, APrompt: string; PasswordChar: Char; var Value: string): Boolean;\r\n\r\n\r\n{ returns the sum of pc.Left, pc.Width and piSpace}\r\nfunction ToRightOf(const pc: TControl; piSpace: Integer = 0): Integer;\r\n{ sets the top of pc to be in the middle of pcParent }\r\nprocedure CenterHeight(const pc, pcParent: TControl);\r\nprocedure CenterHor(Parent: TControl; MinLeft: Integer; Controls: array of TControl);\r\nprocedure EnableControls(Control: TWinControl; const Enable: Boolean);\r\nprocedure EnableMenuItems(MenuItem: TMenuItem; const Tag: Integer; const Enable: Boolean);\r\nprocedure ExpandWidth(Parent: TControl; MinWidth: Integer; Controls: array of TControl);\r\nfunction PanelBorder(Panel: TCustomPanel): Integer;\r\nfunction Pixels(Control: TControl; APixels: Integer): Integer;\r\n\r\ntype\r\n TMenuAnimation = (maNone, maRandom, maUnfold, maSlide);\r\n\r\nprocedure ShowMenu(Form: TForm; MenuAni: TMenuAnimation);\r\n\r\n{$IFDEF MSWINDOWS}\r\n{ TargetFileName - if FileName is ShortCut returns filename ShortCut linked to }\r\nfunction TargetFileName(const FileName: TFileName): TFileName;\r\n{ return filename ShortCut linked to }\r\nfunction ResolveLink(const HWND: THandle; const LinkFile: TFileName;\r\n var FileName: TFileName): HRESULT;\r\n{$ENDIF MSWINDOWS}\r\n\r\ntype\r\n TProcObj = procedure of object;\r\n\r\nprocedure ExecAfterPause(Proc: TProcObj; Pause: Integer);\r\n\r\n{ end JvUtils }\r\n\r\n{ begin JvAppUtils}\r\nfunction GetFirstParentForm(Control: TControl): TCustomForm;\r\nfunction GetDefaultSection(Component: TComponent): string;\r\nfunction GetDefaultIniName: string;\r\n\r\ntype\r\n TOnGetDefaultIniName = function: string;\r\n TPlacementOption = (fpState, fpSize, fpLocation, fpActiveControl);\r\n TPlacementOptions = set of TPlacementOption;\r\n TPlacementOperation = (poSave, poRestore);\r\n\r\nvar\r\n OnGetDefaultIniName: TOnGetDefaultIniName = nil;\r\n DefCompanyName: string = '';\r\n RegUseAppTitle: Boolean = False;\r\n\r\nfunction GetDefaultIniRegKey: string;\r\nfunction FindForm(FormClass: TFormClass): TForm;\r\nfunction FindShowForm(FormClass: TFormClass; const Caption: string): TForm;\r\nfunction ShowDialog(FormClass: TFormClass): Boolean;\r\nfunction InstantiateForm(FormClass: TFormClass; var Reference): TForm;\r\n\r\nprocedure SaveFormPlacement(Form: TForm; const AppStorage: TJvCustomAppStorage; Options: TPlacementOptions);\r\nprocedure RestoreFormPlacement(Form: TForm; const AppStorage: TJvCustomAppStorage; Options: TPlacementOptions);\r\n\r\nprocedure SaveMDIChildren(MainForm: TForm; const AppStorage: TJvCustomAppStorage);\r\nprocedure RestoreMDIChildren(MainForm: TForm; const AppStorage: TJvCustomAppStorage);\r\nprocedure RestoreGridLayout(Grid: TCustomGrid; const AppStorage: TJvCustomAppStorage);\r\nprocedure SaveGridLayout(Grid: TCustomGrid; const AppStorage: TJvCustomAppStorage);\r\n\r\nfunction StrToIniStr(const Str: string): string;\r\nfunction IniStrToStr(const Str: string): string;\r\n\r\n// Ini Utilitie Functions\r\n// Added by RDB\r\n\r\nfunction FontStylesToString(Styles: TFontStyles): string;\r\nfunction StringToFontStyles(const Styles: string): TFontStyles;\r\n\r\nfunction FontToString(Font: TFont): string;\r\nfunction StringToFont(const Str: string): TFont;\r\n\r\nfunction RectToStr(Rect: TRect): string;\r\nfunction StrToRect(const Str: string; const Def: TRect): TRect;\r\nfunction PointToStr(P: TPoint): string;\r\nfunction StrToPoint(const Str: string; const Def: TPoint): TPoint;\r\n\r\nprocedure AppBroadcast(Msg: UINT; wParam: WPARAM; lParam: LPARAM);\r\n\r\nprocedure AppTaskbarIcons(AppOnly: Boolean);\r\n\r\n\r\n{ Internal using utilities }\r\n\r\nprocedure InternalSaveFormPlacement(Form: TForm; const AppStorage: TJvCustomAppStorage;\r\n const StorePath: string; Options: TPlacementOptions = [fpState, fpSize, fpLocation]);\r\nprocedure InternalRestoreFormPlacement(Form: TForm; const AppStorage: TJvCustomAppStorage;\r\n const StorePath: string; Options: TPlacementOptions = [fpState, fpSize, fpLocation]);\r\nprocedure InternalSaveGridLayout(Grid: TCustomGrid; const AppStorage: TJvCustomAppStorage; const StorePath: string);\r\nprocedure InternalRestoreGridLayout(Grid: TCustomGrid; const AppStorage: TJvCustomAppStorage; const StorePath: string);\r\nprocedure InternalSaveMDIChildren(MainForm: TForm; const AppStorage: TJvCustomAppStorage; const StorePath: string);\r\nprocedure InternalRestoreMDIChildren(MainForm: TForm; const AppStorage: TJvCustomAppStorage; const StorePath: string);\r\n\r\n{ end JvAppUtils }\r\n{ begin JvGraph }\r\ntype\r\n TMappingMethod = (mmHistogram, mmQuantize, mmTrunc784, mmTrunc666,\r\n mmTripel, mmGrayscale);\r\n\r\nfunction GetBitmapPixelFormat(Bitmap: TBitmap): TPixelFormat;\r\n\r\nfunction GetPaletteBitmapFormat(Bitmap: TBitmap): TPixelFormat;\r\nprocedure SetBitmapPixelFormat(Bitmap: TBitmap; PixelFormat: TPixelFormat;\r\n Method: TMappingMethod);\r\nfunction BitmapToMemoryStream(Bitmap: TBitmap; PixelFormat: TPixelFormat;\r\n Method: TMappingMethod): TMemoryStream;\r\nprocedure GrayscaleBitmap(Bitmap: TBitmap);\r\n\r\nfunction BitmapToMemory(Bitmap: TBitmap; Colors: Integer): TStream;\r\nprocedure SaveBitmapToFile(const FileName: string; Bitmap: TBitmap;\r\n Colors: Integer);\r\n\r\nfunction ScreenPixelFormat: TPixelFormat;\r\nfunction ScreenColorCount: Integer;\r\n\r\nvar\r\n DefaultMappingMethod: TMappingMethod = mmHistogram;\r\n\r\n\r\nfunction GetWorkareaRect(Monitor: TMonitor): TRect;\r\nfunction FindMonitor(Handle: HMONITOR): TMonitor;\r\n\r\nprocedure TileImage(Canvas: TCanvas; Rect: TRect; Image: TGraphic);\r\nfunction ZoomImage(ImageW, ImageH, MaxW, MaxH: Integer; Stretch: Boolean): TPoint;\r\n\r\ntype\r\n TJvGradientOptions = class(TPersistent)\r\n private\r\n FStartColor: TColor;\r\n FEndColor: TColor;\r\n FDirection: TFillDirection;\r\n FStepCount: Byte;\r\n FVisible: Boolean;\r\n FOnChange: TNotifyEvent;\r\n procedure SetStartColor(Value: TColor);\r\n procedure SetEndColor(Value: TColor);\r\n procedure SetDirection(Value: TFillDirection);\r\n procedure SetStepCount(Value: Byte);\r\n procedure SetVisible(Value: Boolean);\r\n protected\r\n procedure Changed; dynamic;\r\n public\r\n constructor Create;\r\n procedure Assign(Source: TPersistent); override;\r\n procedure Draw(Canvas: TCanvas; Rect: TRect);\r\n published\r\n property Direction: TFillDirection read FDirection write SetDirection default fdTopToBottom;\r\n property EndColor: TColor read FEndColor write SetEndColor default clGray;\r\n property StartColor: TColor read FStartColor write SetStartColor default clSilver;\r\n property StepCount: Byte read FStepCount write SetStepCount default 64;\r\n property Visible: Boolean read FVisible write SetVisible default False;\r\n property OnChange: TNotifyEvent read FOnChange write FOnChange;\r\n end;\r\n{ end JvGraph }\r\n\r\ntype\r\n // equivalent of TPoint, but that can be a published property\r\n TJvPoint = class(TPersistent)\r\n private\r\n FY: Longint;\r\n FX: Longint;\r\n FOnChange: TNotifyEvent;\r\n procedure SetX(Value: Longint);\r\n procedure SetY(Value: Longint);\r\n function GetAsPoint: TPoint;\r\n procedure SetAsPoint(const Value: TPoint);\r\n protected\r\n procedure DoChange;\r\n public\r\n procedure AssignPoint(const Source: TPoint);\r\n procedure Assign(Source: TPersistent); overload; override;\r\n procedure Assign(const Source: TPoint); reintroduce; overload;\r\n procedure CopyToPoint(var Point: TPoint);\r\n property OnChange: TNotifyEvent read FOnChange write FOnChange;\r\n property AsPoint: TPoint read GetAsPoint write SetAsPoint; \r\n published\r\n property X: Longint read FX write SetX default 0;\r\n property Y: Longint read FY write SetY default 0;\r\n end;\r\n\r\n // equivalent of TRect, but that can be a published property\r\n TJvRect = class(TPersistent)\r\n private\r\n FTopLeft: TJvPoint;\r\n FBottomRight: TJvPoint;\r\n FOnChange: TNotifyEvent;\r\n function GetBottom: Integer;\r\n function GetLeft: Integer;\r\n function GetRight: Integer;\r\n function GetTop: Integer;\r\n procedure SetBottom(Value: Integer);\r\n procedure SetLeft(Value: Integer);\r\n procedure SetRight(Value: Integer);\r\n procedure SetTop(Value: Integer);\r\n procedure SetBottomRight(Value: TJvPoint);\r\n procedure SetTopLeft(Value: TJvPoint);\r\n procedure PointChange(Sender: TObject);\r\n function GetHeight: Integer;\r\n function GetWidth: Integer;\r\n procedure SetHeight(Value: Integer);\r\n procedure SetWidth(Value: Integer);\r\n protected\r\n procedure DoChange;\r\n public\r\n constructor Create;\r\n destructor Destroy; override;\r\n procedure AssignRect(const Source: TRect);\r\n procedure Assign(Source: TPersistent); overload; override;\r\n procedure Assign(const Source: TRect); reintroduce; overload;\r\n procedure CopyToRect(var Rect: TRect);\r\n property TopLeft: TJvPoint read FTopLeft write SetTopLeft;\r\n property BottomRight: TJvPoint read FBottomRight write SetBottomRight;\r\n property Width: Integer read GetWidth write SetWidth;\r\n property Height: Integer read GetHeight write SetHeight;\r\n property OnChange: TNotifyEvent read FOnChange write FOnChange;\r\n published\r\n property Left: Integer read GetLeft write SetLeft default 0;\r\n property Top: Integer read GetTop write SetTop default 0;\r\n property Right: Integer read GetRight write SetRight default 0;\r\n property Bottom: Integer read GetBottom write SetBottom default 0;\r\n end;\r\n\r\n TJvSize = class(TPersistent)\r\n private\r\n FWidth: Longint;\r\n FHeight: Longint;\r\n FOnChange: TNotifyEvent;\r\n procedure SetWidth(Value: Longint);\r\n procedure SetHeight(Value: Longint);\r\n function GetSize: TSize;\r\n procedure SetSize(const Value: TSize);\r\n protected\r\n procedure DoChange;\r\n public\r\n procedure AssignSize(const Source: TSize);\r\n procedure Assign(Source: TPersistent); overload; override;\r\n procedure Assign(const Source: TSize); reintroduce; overload;\r\n procedure CopyToSize(var Size: TSize);\r\n property OnChange: TNotifyEvent read FOnChange write FOnChange;\r\n property AsSize: TSize read GetSize write SetSize;\r\n published\r\n property Width: Longint read FWidth write SetWidth default 0;\r\n property Height: Longint read FHeight write SetHeight default 0;\r\n end;\r\n\r\n{ begin JvCtrlUtils }\r\n\r\n//------------------------------------------------------------------------------\r\n// ToolBarMenu\r\n//------------------------------------------------------------------------------\r\n\r\nprocedure JvCreateToolBarMenu(AForm: TForm; AToolBar: TToolBar;\r\n AMenu: TMainMenu = nil);\r\n\r\n//------------------------------------------------------------------------------\r\n// ListView functions\r\n//------------------------------------------------------------------------------\r\n\r\ntype\r\n PJvLVItemStateData = ^TJvLVItemStateData;\r\n TJvLVItemStateData = record\r\n Caption: string;\r\n Data: Pointer;\r\n Focused: Boolean;\r\n Selected: Boolean;\r\n end;\r\n\r\n{ listview functions }\r\nfunction ConvertStates(const State: Integer): TItemStates;\r\n\r\nfunction ChangeHasDeselect(const peOld, peNew: TItemStates): Boolean;\r\nfunction ChangeHasSelect(const peOld, peNew: TItemStates): Boolean;\r\n\r\nfunction ChangeHasDefocus(const peOld, peNew: TItemStates): Boolean;\r\nfunction ChangeHasFocus(const peOld, peNew: TItemStates): Boolean;\r\n\r\nfunction GetListItemColumn(const pcItem: TListItem; piIndex: Integer): string;\r\n\r\nprocedure JvListViewToStrings(ListView: TListView; Strings: TStrings;\r\n SelectedOnly: Boolean = False; Headers: Boolean = True);\r\n\r\nfunction JvListViewSafeSubItemString(Item: TListItem; SubItemIndex: Integer): string;\r\n\r\nprocedure JvListViewSortClick(Column: TListColumn;\r\n AscendingSortImage: Integer = -1; DescendingSortImage: Integer = -1);\r\n\r\nprocedure JvListViewCompare(ListView: TListView; Item1, Item2: TListItem;\r\n var Compare: Integer);\r\n\r\nprocedure JvListViewSelectAll(ListView: TListView; Deselect: Boolean = False);\r\n\r\nfunction JvListViewSaveState(ListView: TListView): TJvLVItemStateData;\r\n\r\nfunction JvListViewRestoreState(ListView: TListView; Data: TJvLVItemStateData;\r\n MakeVisible: Boolean = True; FocusFirst: Boolean = False): Boolean;\r\n\r\n\r\nfunction JvListViewGetOrderedColumnIndex(Column: TListColumn): Integer;\r\nprocedure JvListViewSetSystemImageList(ListView: TListView);\r\n\r\n\r\n//------------------------------------------------------------------------------\r\n// MessageBox\r\n//------------------------------------------------------------------------------\r\n\r\nfunction JvMessageBox(const Text, Caption: string; Flags: DWORD): Integer; overload;\r\nfunction JvMessageBox(const Text: string; Flags: DWORD): Integer; overload;\r\n\r\n{ end JvCtrlUtils }\r\n\r\nprocedure UpdateTrackFont(TrackFont, Font: TFont; TrackOptions: TJvTrackFontOptions);\r\n// Returns the size of the image\r\n// used for checkboxes and radiobuttons.\r\n// Originally from Mike Lischke\r\nfunction GetDefaultCheckBoxSize: TSize;\r\n\r\nfunction CanvasMaxTextHeight(Canvas: TCanvas): Integer;\r\n\r\n{$IFDEF MSWINDOWS}\r\n// AllocateHWndEx works like Classes.AllocateHWnd but does not use any virtual memory pages\r\nfunction AllocateHWndEx(Method: TWndMethod; const AClassName: string = ''): THandle;\r\n// DeallocateHWndEx works like Classes.DeallocateHWnd but does not use any virtual memory pages\r\nprocedure DeallocateHWndEx(Wnd: THandle);\r\n\r\nfunction JvMakeObjectInstance(Method: TWndMethod): Pointer;\r\nprocedure JvFreeObjectInstance(ObjectInstance: Pointer);\r\n{$ENDIF MSWINDOWS}\r\n\r\nfunction GetAppHandle: THandle;\r\n// DrawArrow draws a standard arrow in any of four directions and with the specifed color.\r\n// Rect is the area to draw the arrow in and also defines the size of the arrow\r\n// Note that this procedure might shrink Rect so that it's width and height is always\r\n// the same and the width and height are always even, i.e calling with\r\n// Rect(0,0,12,12) (odd) is the same as calling with Rect(0,0,11,11) (even)\r\n// Direction defines the direction of the arrow. If Direction is akLeft, the arrow point is\r\n// pointing to the left\r\nprocedure DrawArrow(Canvas: TCanvas; ARect: TRect; Color: TColor = clBlack;\r\n Direction: TAnchorKind = akBottom; Margin: Integer = 0); overload;\r\n\r\n// The param X and Y is the topleft.X and topleft.Y of rect to draw arrow\r\nprocedure DrawArrow(Canvas: TCanvas; X, Y: Integer; Size: Integer;\r\n Color: TColor = clBlack; Direction: TAnchorKind = akBottom); overload;\r\n\r\n\r\nprocedure DrawLine(Canvas: TCanvas; X, Y, X2, Y2: Integer);\r\n \r\nfunction IsPositiveResult(Value: TModalResult): Boolean;\r\nfunction IsNegativeResult(Value: TModalResult): Boolean;\r\nfunction IsAbortResult(const Value: TModalResult): Boolean;\r\nfunction StripAllFromResult(const Value: TModalResult): TModalResult;\r\n// returns either BrightColor or DarkColor depending on the luminance of AColor\r\n// This function gives the same result (AFAIK) as the function used in Windows to\r\n// calculate the desktop icon text color based on the desktop background color\r\nfunction SelectColorByLuminance(AColor, DarkColor, BrightColor: TColor): TColor;\r\n\r\n// (peter3) implementation moved from JvHTControls.\r\ntype\r\n TJvHTMLCalcType = (htmlShow, htmlCalcWidth, htmlCalcHeight, htmlHyperLink);\r\n\r\nprocedure HTMLDrawTextEx(Canvas: TCanvas; Rect: TRect;\r\n const State: TOwnerDrawState; const Text: string; var Width: Integer;\r\n CalcType: TJvHTMLCalcType; MouseX, MouseY: Integer; var MouseOnLink: Boolean;\r\n var LinkName: string; SuperSubScriptRatio: Double; Scale: Integer = 100); overload;\r\nprocedure HTMLDrawTextEx(Canvas: TCanvas; Rect: TRect;\r\n const State: TOwnerDrawState; const Text: string; var Width, Height: Integer;\r\n CalcType: TJvHTMLCalcType; MouseX, MouseY: Integer; var MouseOnLink: Boolean;\r\n var LinkName: string; SuperSubScriptRatio: Double; Scale: Integer = 100); overload;\r\nfunction HTMLDrawText(Canvas: TCanvas; Rect: TRect;\r\n const State: TOwnerDrawState; const Text: string; SuperSubScriptRatio: Double; Scale: Integer = 100): string;\r\nfunction HTMLDrawTextHL(Canvas: TCanvas; Rect: TRect;\r\n const State: TOwnerDrawState; const Text: string; MouseX, MouseY: Integer; SuperSubScriptRatio: Double; \r\n Scale: Integer = 100): string;\r\nfunction HTMLPlainText(const Text: string): string;\r\nfunction HTMLTextExtent(Canvas: TCanvas; Rect: TRect;\r\n const State: TOwnerDrawState; const Text: string; SuperSubScriptRatio: Double; Scale: Integer = 100): TSize;\r\nfunction HTMLTextWidth(Canvas: TCanvas; Rect: TRect;\r\n const State: TOwnerDrawState; const Text: string; SuperSubScriptRatio: Double; Scale: Integer = 100): Integer;\r\nfunction HTMLTextHeight(Canvas: TCanvas; const Text: string; SuperSubScriptRatio: Double; Scale: Integer = 100): Integer;\r\nfunction HTMLPrepareText(const Text: string): string;\r\n\r\n// This type is used to allow an easy migration from a TBitmap property to a\r\n// TPicture property. It is, for instance, used in TJvXPButton so that users\r\n// migrating to the JVCL can still open their applications and benefit\r\n// automatically from the change of format. The whole point is that a TPicture\r\n// can also contain an Icon, which could be a valid source for a button glyph.\r\ntype\r\n TJvPicture = class (TPicture)\r\n private\r\n procedure ReadBitmapData(Stream: TStream);\r\n protected\r\n procedure DefineProperties(Filer: TFiler); override;\r\n end;\r\n\r\n// This class is here because of issue 4859. Basically, using TBitmap as a\r\n// parameter for an event handler is the source of an ambiguity under\r\n// C++ Builder because of Windows::TBitmap. The only solution is to replace\r\n// TBitmap by TJvBitmap in the event handler declarations. This, however,\r\n// forces the Delphi users to change their event handlers so that the IDE\r\n// will not complain when opening the forms.\r\ntype\r\n TJvBitmap = class(TBitmap)\r\n end;\r\n\r\n{\r\nDocumentation:\r\n*************\r\n\r\nWHAT IT IS:\r\n These are helper functions to register graphic formats than can\r\n later be recognized from a stream, thus allowing to rely on the actual\r\n content of a file rather than from its filename extension.\r\n This is used in TJvDBImage and TJvImage.\r\n\r\nIMAGE FORMATS:\r\n The implementation is simple: Just register image signatures with\r\n RegisterGraphicSignature procedure and the methods takes care\r\n of the correct instantiation of the TGraphic object. The signatures\r\n register at unit's initialization are: BMP, WMF, EMF, ICO, JPG.\r\n If you got some other image library (such as GIF, PCX, TIFF, ANI or PNG),\r\n just register the signature:\r\n\r\n RegisterGraphicSignature(, , )\r\n\r\n or\r\n\r\n RegisterGraphicSignature([], , )\r\n\r\n This means:\r\n When (or byte values) found at the graphic\r\n class to use is \r\n\r\n For example (actual code of the initialization section):\r\n\r\n RegisterGraphicSignature([$D7, $CD], 0, TMetaFile); // WMF\r\n RegisterGraphicSignature([1, 0], 0, TMetaFile); // EMF\r\n RegisterGraphicSignature('JFIF', 6, TJPEGImage);\r\n\r\n You can also unregister signature. IF you want use TGIFImage instead of\r\n TJvGIFImage, you can unregister with:\r\n\r\n UnregisterGraphicSignature('GIF', 0);\r\n\r\n or just\r\n\r\n UnregisterGraphicSignature(TJvGIFImage); // must add JvGIF unit in uses clause\r\n\r\n then:\r\n RegisterGraphicSignature('GIF', 0, TGIFImage); // must add GIFImage to uses clause\r\n\r\n If you dont like the signature registration there is a new event called\r\n OnGetGraphicClass. The event gets the following parameters:\r\n\r\n Sender: TObject;\r\n Stream: TMemoryStream;\r\n var GraphicClass: TGraphicClass)\r\n\r\n The memory stream containing the blob data is sent in Stream to allow the user\r\n to inspect the contents and figure out which graphic class is.\r\n\r\n The graphic class to be used must implement LoadFromStream and SaveToStream\r\n methods in order to work properly.\r\n}\r\n\r\ntype\r\n TJvGetGraphicClassEvent = procedure(Sender: TObject; AStream: TMemoryStream;\r\n var GraphicClass: TGraphicClass) of object;\r\n\r\nprocedure RegisterGraphicSignature(const ASignature: AnsiString; AOffset: Integer;\r\n AGraphicClass: TGraphicClass); overload;\r\nprocedure RegisterGraphicSignature(const ASignature: array of Byte; AOffset: Integer;\r\n AGraphicClass: TGraphicClass); overload;\r\n\r\nprocedure UnregisterGraphicSignature(AGraphicClass: TGraphicClass); overload;\r\nprocedure UnregisterGraphicSignature(const ASignature: AnsiString; AOffset: Integer); overload;\r\nprocedure UnregisterGraphicSignature(const ASignature: array of Byte; AOffset: Integer); overload;\r\n\r\nfunction GetGraphicClass(AStream: TStream): TGraphicClass;\r\nfunction GetGraphicObject(AStream: TStream): TGraphic; overload;\r\nfunction GetGraphicObject(AStream: TStream; ASender: TObject; AOnProc: TJvGetGraphicClassEvent): TGraphic; overload;\r\n\r\n// Coordinate Space/rectangle and Transformation Functions added by dejoy\r\n\r\n{Translates child coordinates to parent coordinates.\r\n not found by iterating up the chain of Parent, not equal to TControl.ClientToParent\r\n If AParent is nil (Delphi) or NULL (C++), the AChild control's immediate parent is used.\r\n}\r\nfunction PointChildToParent(APoint: TPoint; AChild: TControl; AParent: TWinControl = nil): TPoint;\r\n{extended PointChildToParent to TRect}\r\nfunction RectChildToParent(ARect: TRect; AChild: TControl; AParent: TWinControl = nil): TRect;\r\n{union TControl.ClientToScreen from Point to Rect}\r\nfunction RectClientToScreen(AClientRect: TRect; AControl: TControl): TRect;\r\n{union TControl.ScreenToClient from Point to Rect}\r\nfunction RectScreenToClient(AScreenRect: TRect; AControl: TControl): TRect;\r\n{converts (maps) a rect from a control client area coordinates to another control client area coordinates}\r\nfunction MapControlRect(ACtlFrom, ACtlTo: TControl; AClientRect: TRect): TRect;\r\n{converts (maps) a point from a control client area coordinates to another control client area coordinates}\r\nfunction MapControlPoint(ACtlFrom, ACtlTo: TControl; APoint: TPoint): TPoint;\r\n{converts (maps) a rect from a coordinate space relative to one window to a coordinate space relative to another window}\r\nfunction MapWindowRect(hWndFrom, hWndTo: HWND; ARect: TRect): TRect;\r\n{specifies the size (in pixels) of a control's windows area.\r\n TControl.ClientRect likely, but including client area and noclient area.}\r\nfunction GetControlRect(AControl: TControl): TRect;\r\n{specifies the screen coordinates of a control's windows area, the size of rect is equaled to GetControlRect.}\r\nfunction GetControlScreenRect(AControl: TControl): TRect;\r\n\r\n{retrieves a handle of a device context (DC) for the client area of the control}\r\nfunction GetControlDC(Control: TControl; var WindowHandle: HWND): HDC;\r\n{retrieves the device context (DC) for the entire window,\r\n including title bar, menus, and scroll bars, that client area and noclient area\r\n }\r\nfunction GetControlWindowDC(Control: TControl; var WindowHandle: HWND): HDC;\r\n{retrieves the max rectangle of combined with all child controls of AContainer,\r\n expressed in the coordinate system of the AContainer control.\r\n equal to AContainer.BoundsRect if AContainer.ControlCount = 0.\r\n}\r\nfunction GetContainerMaxBoundsRect(AContainer: TWinControl): TRect;\r\n{retrieves the top handle of a specified control,function GetParentForm likely. }\r\nfunction GetParentWindow(ASender: TWinControl): HWnd;\r\n\r\nfunction BeginClipRect(DC: HDC; AClipRect: TRect; fnMode: Integer = RGN_COPY): Integer;\r\nfunction EndClipRect(DC: HDC): Integer;\r\n\r\nfunction GetTopOwner(aCmp: TComponent): TComponent;\r\nfunction GetTopForm(aCmp: TComponent): TCustomForm;\r\nfunction IsOwnedComponent(aCmp, aOwner: TComponent): Boolean;\r\nfunction IsChildWindow(const AChild, AParent: THandle): Boolean;\r\n\r\n// This function generates a unique name for a component inside the list of all\r\n// owner components.\r\n// The name is generated in the login _ or\r\n// _ when the AComponentName parameter\r\n// is not defined. The number will be increased until the name is unique.\r\nfunction GenerateUniqueComponentName(AOwner, AComponent: TComponent; const\r\n AComponentName: string = ''): string;\r\n\r\nfunction ReplaceImageListReference(This: TComponent; NewReference: TCustomImageList;\r\n var VarReference: TCustomImageList; ChangeLink: TChangeLink): Boolean;\r\nfunction ReplaceComponentReference(This, NewReference: TComponent; var VarReference: TComponent): Boolean;\r\n\r\n\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvJVCLUtils.pas $';\r\n Revision: '$Revision: 13415 $';\r\n Date: '$Date: 2012-09-10 11:51:54 +0200 (lun. 10 sept. 2012) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n Consts,\r\n {$IFDEF MSWINDOWS}\r\n CommCtrl, ShlObj, ActiveX,\r\n {$ENDIF MSWINDOWS}\r\n Math, Contnrs,\r\n jpeg,\r\n JclFileUtils,\r\n JvConsts, JvResources;\r\n\r\n{$R JvConsts.res}\r\n\r\nconst\r\n {$IFDEF MSWINDOWS}\r\n RC_ControlRegistry = 'Control Panel\\Desktop';\r\n RC_WallPaperStyle = 'WallpaperStyle';\r\n RC_WallpaperRegistry = 'Wallpaper';\r\n RC_TileWallpaper = 'TileWallpaper';\r\n RC_RunCpl = 'rundll32.exe shell32,Control_RunDLL ';\r\n {$ENDIF MSWINDOWS}\r\n\r\nfunction GetAppHandle: THandle;\r\nbegin\r\n Result := Application.Handle;\r\nend;\r\n\r\ntype\r\n TWaitCursor = class(TInterfacedObject, IInterface)\r\n private\r\n FCursor: TCursor;\r\n public\r\n constructor Create(ACursor: TCursor);\r\n destructor Destroy; override;\r\n end;\r\n\r\nconstructor TWaitCursor.Create(ACursor: TCursor);\r\nbegin\r\n inherited Create;\r\n FCursor := Screen.Cursor;\r\n Screen.Cursor := ACursor;\r\nend;\r\n\r\ndestructor TWaitCursor.Destroy;\r\nbegin\r\n Screen.Cursor := FCursor;\r\n inherited Destroy;\r\nend;\r\n\r\n\r\nfunction IconToBitmap(Ico: HICON): TBitmap;\r\nvar\r\n Pic: TPicture;\r\nbegin\r\n Pic := TPicture.Create;\r\n try\r\n Pic.Icon.Handle := Ico;\r\n Result := TBitmap.Create;\r\n Result.Height := Pic.Icon.Height;\r\n Result.Width := Pic.Icon.Width;\r\n Result.Canvas.Draw(0, 0, Pic.Icon);\r\n finally\r\n Pic.Free;\r\n end;\r\nend;\r\n\r\nfunction IconToBitmap2(Ico: HICON; Size: Integer = 32;\r\n TransparentColor: TColor = clNone): TBitmap;\r\nbegin\r\n // (p3) this seems to generate \"better\" bitmaps...\r\n with TImageList.CreateSize(Size, Size) do\r\n try\r\n Masked := True;\r\n BkColor := TransparentColor;\r\n ImageList_AddIcon(Handle, Ico);\r\n Result := TBitmap.Create;\r\n Result.PixelFormat := pf24bit;\r\n if TransparentColor <> clNone then\r\n Result.TransparentColor := TransparentColor;\r\n Result.Transparent := TransparentColor <> clNone;\r\n GetBitmap(0, Result);\r\n finally\r\n Free;\r\n end;\r\nend;\r\n\r\nfunction IconToBitmap3(Ico: HICON; Size: Integer = 32;\r\n TransparentColor: TColor = clNone): TBitmap;\r\nvar\r\n Icon: TIcon;\r\n Tmp: TBitmap;\r\nbegin\r\n Icon := TIcon.Create;\r\n Tmp := TBitmap.Create;\r\n try\r\n Icon.Handle := CopyIcon(Ico);\r\n Result := TBitmap.Create;\r\n Result.Width := Icon.Width;\r\n Result.Height := Icon.Height;\r\n Result.PixelFormat := pf24bit;\r\n // fill the bitmap with the transparent color\r\n Result.Canvas.Brush.Color := TransparentColor;\r\n Result.Canvas.FillRect(Rect(0, 0, Result.Width, Result.Height));\r\n Result.Canvas.Draw(0, 0, Icon);\r\n Result.TransparentColor := TransparentColor;\r\n Tmp.Assign(Result);\r\n // Result.Width := Size;\r\n // Result.Height := Size;\r\n Result.Canvas.StretchDraw(Rect(0, 0, Result.Width, Result.Height), Tmp);\r\n Result.Transparent := True;\r\n finally\r\n Icon.Free;\r\n Tmp.Free;\r\n end;\r\nend;\r\n\r\nprocedure RGBToHSV(R, G, B: Integer; var H, S, V: Integer);\r\nvar\r\n Delta: Integer;\r\n Min, Max: Integer;\r\n\r\n function GetMax(I, J, K: Integer): Integer;\r\n begin\r\n if J > I then\r\n I := J;\r\n if K > I then\r\n I := K;\r\n Result := I;\r\n end;\r\n\r\n function GetMin(I, J, K: Integer): Integer;\r\n begin\r\n if J < I then\r\n I := J;\r\n if K < I then\r\n I := K;\r\n Result := I;\r\n end;\r\n\r\nbegin\r\n Min := GetMin(R, G, B);\r\n Max := GetMax(R, G, B);\r\n V := Max;\r\n Delta := Max - Min;\r\n if Max = 0 then\r\n S := 0\r\n else\r\n S := (255 * Delta) div Max;\r\n if S = 0 then\r\n H := 0\r\n else\r\n begin\r\n if R = Max then\r\n H := (60 * (G - B)) div Delta\r\n else\r\n if G = Max then\r\n H := 120 + (60 * (B - R)) div Delta\r\n else\r\n H := 240 + (60 * (R - G)) div Delta;\r\n if H < 0 then\r\n H := H + 360;\r\n end;\r\nend;\r\n\r\n{$IFDEF MSWINDOWS}\r\n\r\nprocedure SetWallpaper(const Path: string);\r\nbegin\r\n SystemParametersInfo(SPI_SETDESKWALLPAPER, 0, PChar(Path), SPIF_UPDATEINIFILE);\r\nend;\r\n\r\nprocedure SetWallpaper(const Path: string; Style: TJvWallpaperStyle);\r\nbegin\r\n with TRegistry.Create do\r\n begin\r\n try\r\n OpenKey(RC_ControlRegistry, False);\r\n case Style of\r\n wpTile:\r\n begin\r\n WriteString(RC_TileWallpaper, '1');\r\n WriteString(RC_WallPaperStyle, '0');\r\n end;\r\n wpCenter:\r\n begin\r\n WriteString(RC_TileWallpaper, '0');\r\n WriteString(RC_WallPaperStyle, '0');\r\n end;\r\n wpStretch:\r\n begin\r\n WriteString(RC_TileWallpaper, '0');\r\n WriteString(RC_WallPaperStyle, '2');\r\n end;\r\n end;\r\n WriteString(RC_WallpaperRegistry, Path);\r\n finally\r\n Free;\r\n end;\r\n end;\r\n SystemParametersInfo(SPI_SETDESKWALLPAPER, 0, nil, SPIF_SENDWININICHANGE);\r\nend;\r\n\r\n{$ENDIF MSWINDOWS}\r\n\r\ntype\r\n TGetXBitmapMode =(gxRed, gxGreen, gxBlue, gxHue, gxSaturation, gxValue);\r\n\r\nprocedure GetXBitmap(var Dest: TBitmap; const Source: TBitmap; Mode: TGetXBitmapMode);\r\nvar\r\n I, J, H, S, V: Integer;\r\n Line: PJvRGBArray;\r\nbegin\r\n if not Assigned(Dest) then\r\n Dest := TBitmap.Create;\r\n Dest.Assign(Source);\r\n Dest.PixelFormat := pf24bit;\r\n for J := Dest.Height - 1 downto 0 do\r\n begin\r\n Line := Dest.ScanLine[J];\r\n case Mode of\r\n gxRed:\r\n for I := Dest.Width - 1 downto 0 do\r\n begin\r\n Line[I].rgbGreen := 0;\r\n Line[I].rgbBlue := 0;\r\n end;\r\n gxGreen:\r\n for I := Dest.Width - 1 downto 0 do\r\n begin\r\n Line[I].rgbRed := 0;\r\n Line[I].rgbBlue := 0;\r\n end;\r\n gxBlue:\r\n for I := Dest.Width - 1 downto 0 do\r\n begin\r\n Line[I].rgbRed := 0;\r\n Line[I].rgbGreen := 0;\r\n end;\r\n gxHue:\r\n for I := Dest.Width - 1 downto 0 do\r\n begin\r\n RGBToHSV(Line[I].rgbRed, Line[I].rgbGreen, Line[I].rgbBlue, H, S, V);\r\n Line[I].rgbRed := H;\r\n Line[I].rgbGreen := H;\r\n Line[I].rgbBlue := H;\r\n end;\r\n gxSaturation:\r\n for I := Dest.Width - 1 downto 0 do\r\n begin\r\n RGBToHSV(Line[I].rgbRed, Line[I].rgbGreen, Line[I].rgbBlue, H, S, V);\r\n Line[I].rgbRed := S;\r\n Line[I].rgbGreen := S;\r\n Line[I].rgbBlue := S;\r\n end;\r\n gxValue:\r\n for I := Dest.Width - 1 downto 0 do\r\n begin\r\n RGBToHSV(Line[I].rgbRed, Line[I].rgbGreen, Line[I].rgbBlue, H, S, V);\r\n Line[I].rgbRed := V;\r\n Line[I].rgbGreen := V;\r\n Line[I].rgbBlue := V;\r\n end;\r\n end;\r\n end;\r\n Dest.PixelFormat := Source.PixelFormat;\r\nend;\r\n\r\nprocedure GetRBitmap(var Dest: TBitmap; const Source: TBitmap);\r\nbegin\r\n GetXBitmap(Dest, Source, gxRed);\r\nend;\r\n\r\nprocedure GetBBitmap(var Dest: TBitmap; const Source: TBitmap);\r\nbegin\r\n GetXBitmap(Dest, Source, gxBlue);\r\nend;\r\n\r\nprocedure GetGBitmap(var Dest: TBitmap; const Source: TBitmap);\r\nbegin\r\n GetXBitmap(Dest, Source, gxGreen);\r\nend;\r\n\r\nprocedure GetMonochromeBitmap(var Dest: TBitmap; const Source: TBitmap);\r\nbegin\r\n if not Assigned(Dest) then\r\n Dest := TBitmap.Create;\r\n Dest.Assign(Source);\r\n Dest.Monochrome := True;\r\nend;\r\n\r\nprocedure GetHueBitmap(var Dest: TBitmap; const Source: TBitmap);\r\nbegin\r\n GetXBitmap(Dest, Source, gxHue);\r\nend;\r\n\r\nprocedure GetSaturationBitmap(var Dest: TBitmap; const Source: TBitmap);\r\nbegin\r\n GetXBitmap(Dest, Source, gxSaturation);\r\nend;\r\n\r\nprocedure GetValueBitmap(var Dest: TBitmap; const Source: TBitmap);\r\nbegin\r\n GetXBitmap(Dest, Source, gxValue);\r\nend;\r\n\r\n\r\n{ (rb) Duplicate of JvAppUtils.AppTaskbarIcons }\r\n\r\nprocedure HideFormCaption(FormHandle: THandle; Hide: Boolean);\r\nbegin\r\n if Hide then\r\n SetWindowLong(FormHandle, GWL_STYLE,\r\n GetWindowLong(FormHandle, GWL_STYLE) and not WS_CAPTION)\r\n else\r\n SetWindowLong(FormHandle, GWL_STYLE,\r\n GetWindowLong(FormHandle, GWL_STYLE) or WS_CAPTION);\r\nend;\r\n\r\n\r\nprocedure LaunchCpl(const FileName: string);\r\nbegin\r\n // rundll32.exe shell32,Control_RunDLL ';\r\n RunDLL32('shell32.dll', 'Control_RunDLL', FileName, True);\r\n // WinExec(PChar(RC_RunCpl + FileName), SW_SHOWNORMAL);\r\nend;\r\n\r\nprocedure ShowSafeRemovalDialog;\r\nbegin\r\n LaunchCpl('HOTPLUG.DLL');\r\nend;\r\n\r\nconst\r\n {$EXTERNALSYM WM_CPL_LAUNCH}\r\n WM_CPL_LAUNCH = (WM_USER + 1000);\r\n {$EXTERNALSYM WM_CPL_LAUNCHED}\r\n WM_CPL_LAUNCHED = (WM_USER + 1001);\r\n\r\n { (p3) just define enough to make the Cpl unnecessary for us (for the benefit of PE users) }\r\n cCplAddress = 'CPlApplet';\r\n CPL_INIT = 1;\r\n {$EXTERNALSYM CPL_INIT}\r\n CPL_GETCOUNT = 2;\r\n {$EXTERNALSYM CPL_GETCOUNT}\r\n CPL_INQUIRE = 3;\r\n {$EXTERNALSYM CPL_INQUIRE}\r\n CPL_EXIT = 7;\r\n {$EXTERNALSYM CPL_EXIT}\r\n CPL_NEWINQUIRE = 8;\r\n {$EXTERNALSYM CPL_NEWINQUIRE}\r\n\r\ntype\r\n TCPLApplet = function(hwndCPl: THandle; uMsg: UINT;\r\n lParam1, lParam2: LPARAM): Longint; stdcall;\r\n\r\n TCPLInfo = record\r\n idIcon: Integer;\r\n idName: Integer;\r\n idInfo: Integer;\r\n lData: LONG_PTR;\r\n end;\r\n\r\n TNewCPLInfoA = record\r\n dwSize: DWORD;\r\n dwFlags: DWORD;\r\n dwHelpContext: DWORD;\r\n lData: LONG_PTR;\r\n HICON: HICON;\r\n szName: array [0..31] of AnsiChar;\r\n szInfo: array [0..63] of AnsiChar;\r\n szHelpFile: array [0..127] of AnsiChar;\r\n end;\r\n TNewCPLInfoW = record\r\n dwSize: DWORD;\r\n dwFlags: DWORD;\r\n dwHelpContext: DWORD;\r\n lData: LONG_PTR;\r\n HICON: HICON;\r\n szName: array [0..31] of WideChar;\r\n szInfo: array [0..63] of WideChar;\r\n szHelpFile: array [0..127] of WideChar;\r\n end;\r\n\r\nfunction GetControlPanelApplet(const AFileName: string; Strings: TStrings;\r\n Images: TCustomImageList = nil): Boolean;\r\nvar\r\n hLib: HMODULE; // Library Handle to *.cpl file\r\n hIco: HICON;\r\n CplCall: TCPLApplet; // Pointer to CPlApplet() function\r\n I: Longint;\r\n TmpCount, Count: Longint;\r\n S: WideString;\r\n // the three types of information that can be returned\r\n CPLInfo: TCPLInfo;\r\n InfoW: TNewCPLInfoW;\r\n InfoA: TNewCPLInfoA;\r\n HWND: THandle;\r\nbegin\r\n Result := False;\r\n hLib := SafeLoadLibrary(AFileName);\r\n if hLib = 0 then\r\n Exit;\r\n HWND := GetForegroundWindow;\r\n TmpCount := Strings.Count;\r\n Strings.BeginUpdate;\r\n try\r\n @CplCall := GetProcAddress(hLib, cCplAddress);\r\n if not Assigned(CplCall) then\r\n Exit;\r\n CplCall(HWND, CPL_INIT, 0, 0); // Init the *.cpl file\r\n try\r\n Count := CplCall(HWND, CPL_GETCOUNT, 0, 0);\r\n for I := 0 to Count - 1 do\r\n begin\r\n FillChar(InfoW, SizeOf(InfoW), 0);\r\n FillChar(InfoA, SizeOf(InfoA), 0);\r\n FillChar(CPLInfo, SizeOf(CPLInfo), 0);\r\n S := '';\r\n CplCall(HWND, CPL_NEWINQUIRE, I, LPARAM(@InfoW));\r\n if InfoW.dwSize = SizeOf(InfoW) then\r\n begin\r\n hIco := InfoW.HICON;\r\n S := WideString(InfoW.szName);\r\n end\r\n else\r\n begin\r\n if InfoW.dwSize = SizeOf(InfoA) then\r\n begin\r\n Move(InfoW, InfoA, SizeOf(InfoA));\r\n hIco := CopyIcon(InfoA.HICON);\r\n S := string(InfoA.szName);\r\n end\r\n else\r\n begin\r\n CplCall(HWND, CPL_INQUIRE, I, LPARAM(@CPLInfo));\r\n LoadStringA(hLib, CPLInfo.idName, InfoA.szName,\r\n SizeOf(InfoA.szName));\r\n hIco := LoadImage(hLib, PChar(CPLInfo.idIcon), IMAGE_ICON, 16, 16,\r\n LR_DEFAULTCOLOR);\r\n S := string(InfoA.szName);\r\n end;\r\n end;\r\n if S <> '' then\r\n begin\r\n S := Format('%s=%s,@%d', [S, AFileName, I]);\r\n if Images <> nil then\r\n begin\r\n hIco := CopyIcon(hIco);\r\n ImageList_AddIcon(Images.Handle, hIco);\r\n Strings.AddObject(S, TObject(Images.Count - 1));\r\n end\r\n else\r\n Strings.AddObject(S, IconToBitmap2(hIco, 16, clMenu));\r\n // (p3) not sure this is really needed...\r\n // DestroyIcon(hIco);\r\n end;\r\n end;\r\n Result := TmpCount < Strings.Count;\r\n finally\r\n CplCall(HWND, CPL_EXIT, 0, 0);\r\n end;\r\n finally\r\n FreeLibrary(hLib);\r\n Strings.EndUpdate;\r\n end;\r\nend;\r\n\r\nfunction GetControlPanelApplets(const APath, AMask: string; Strings: TStrings;\r\n Images: TCustomImageList = nil): Boolean;\r\nvar\r\n H: THandle;\r\n F: TSearchRec;\r\nbegin\r\n Result := False;\r\n if Strings = nil then\r\n Exit;\r\n H := FindFirst(IncludeTrailingPathDelimiter(APath) + AMask, faAnyFile, F);\r\n if Images <> nil then\r\n begin\r\n Images.Clear;\r\n Images.BkColor := clMenu;\r\n end;\r\n Strings.BeginUpdate;\r\n try\r\n Strings.Clear;\r\n while H = 0 do\r\n begin\r\n if F.Attr and faDirectory = 0 then\r\n // if (F.Name <> '.') and (F.Name <> '..') then\r\n GetControlPanelApplet(APath + F.Name, Strings, Images);\r\n H := FindNext(F);\r\n end;\r\n SysUtils.FindClose(F);\r\n Result := Strings.Count > 0;\r\n finally\r\n Strings.EndUpdate;\r\n end;\r\nend;\r\n\r\n{ imported from VCLFunctions }\r\n\r\nprocedure CenterHeight(const pc, pcParent: TControl);\r\nbegin\r\n pc.Top := //pcParent.Top +\r\n ((pcParent.Height - pc.Height) div 2);\r\nend;\r\n\r\nfunction ToRightOf(const pc: TControl; piSpace: Integer): Integer;\r\nbegin\r\n if pc <> nil then\r\n Result := pc.Left + pc.Width + piSpace\r\n else\r\n Result := piSpace;\r\nend;\r\n\r\n{ compiled from ComCtrls.pas's implmentation section }\r\n\r\nfunction HasFlag(A, B: Integer): Boolean;\r\nbegin\r\n Result := (A and B) <> 0;\r\nend;\r\n\r\nfunction ConvertStates(const State: Integer): TItemStates;\r\nbegin\r\n Result := [];\r\n if HasFlag(State, LVIS_ACTIVATING) then\r\n Include(Result, isActivating);\r\n if HasFlag(State, LVIS_CUT) then\r\n Include(Result, isCut);\r\n if HasFlag(State, LVIS_DROPHILITED) then\r\n Include(Result, isDropHilited);\r\n if HasFlag(State, LVIS_FOCUSED) then\r\n Include(Result, IsFocused);\r\n if HasFlag(State, LVIS_SELECTED) then\r\n Include(Result, isSelected);\r\nend;\r\n\r\nfunction ChangeHasSelect(const peOld, peNew: TItemStates): Boolean;\r\nbegin\r\n Result := (not (isSelected in peOld)) and (isSelected in peNew);\r\nend;\r\n\r\nfunction ChangeHasDeselect(const peOld, peNew: TItemStates): Boolean;\r\nbegin\r\n Result := (isSelected in peOld) and (not (isSelected in peNew));\r\nend;\r\n\r\nfunction ChangeHasFocus(const peOld, peNew: TItemStates): Boolean;\r\nbegin\r\n Result := (not (IsFocused in peOld)) and (IsFocused in peNew);\r\nend;\r\n\r\nfunction ChangeHasDefocus(const peOld, peNew: TItemStates): Boolean;\r\nbegin\r\n Result := (IsFocused in peOld) and (not (IsFocused in peNew));\r\nend;\r\n\r\nfunction GetListItemColumn(const pcItem: TListItem; piIndex: Integer): string;\r\nbegin\r\n if pcItem = nil then\r\n begin\r\n Result := '';\r\n Exit;\r\n end;\r\n\r\n if (piIndex < 0) or (piIndex > pcItem.SubItems.Count) then\r\n begin\r\n Result := '';\r\n Exit;\r\n end;\r\n\r\n if piIndex = 0 then\r\n Result := pcItem.Caption\r\n else\r\n Result := pcItem.SubItems[piIndex - 1];\r\nend;\r\n\r\n{from JvVCLUtils }\r\n\r\n{ Bitmaps }\r\n\r\ntype\r\n TAccessWinControl = class(TWinControl);\r\n\r\nprocedure CopyParentImage(Control: TControl; Dest: TCanvas);\r\nvar\r\n I, Count, SaveIndex: Integer;\r\n DC: HDC;\r\n R, SelfR, CtlR: TRect;\r\n ViewPortOrg: TPoint;\r\nbegin\r\n if (Control = nil) or (Control.Parent = nil) then\r\n Exit;\r\n Count := Control.Parent.ControlCount;\r\n DC := Dest.Handle;\r\n Control.Parent.ControlState := Control.Parent.ControlState + [csPaintCopy];\r\n try\r\n // The view port may already be set. This is especially true when\r\n // a control using CopyParentImage is placed inside a control that\r\n // calls it as well. Best example is a TJvSpeeButton in a TJvPanel,\r\n // both with Transparent set to True (discovered while working on\r\n // Mantis 3624)\r\n GetViewPortOrgEx(DC, ViewPortOrg);\r\n\r\n SelfR := Bounds(Control.Left, Control.Top, Control.Width, Control.Height);\r\n\r\n ViewPortOrg.X := ViewPortOrg.X-Control.Left;\r\n ViewPortOrg.Y := ViewPortOrg.Y-Control.Top;\r\n\r\n // Copy parent control image\r\n SaveIndex := SaveDC(DC);\r\n try\r\n SetViewPortOrgEx(DC, ViewPortOrg.X, ViewPortOrg.Y, nil);\r\n IntersectClipRect(DC, 0, 0, Control.Parent.ClientWidth,\r\n Control.Parent.ClientHeight);\r\n TAccessWinControl(Control.Parent).Perform(WM_ERASEBKGND, WPARAM(DC), 0);\r\n TAccessWinControl(Control.Parent).PaintWindow(DC);\r\n finally\r\n RestoreDC(DC, SaveIndex);\r\n end;\r\n\r\n // Copy images of control's siblings\r\n // Note: while working on Mantis 3624 it was decided that there was no\r\n // real reason to limit this to controls derived from TGraphicControl.\r\n for I := 0 to Count - 1 do\r\n begin\r\n if Control.Parent.Controls[I] = Control then\r\n Break\r\n else\r\n if (Control.Parent.Controls[I] <> nil) then\r\n begin\r\n with Control.Parent.Controls[I] do\r\n begin\r\n CtlR := Bounds(Left, Top, Width, Height);\r\n if IntersectRect(R, SelfR, CtlR) and Visible then\r\n begin\r\n ControlState := ControlState + [csPaintCopy];\r\n SaveIndex := SaveDC(DC);\r\n try\r\n SetViewPortOrgEx(DC, Left + ViewPortOrg.X, Top + ViewPortOrg.Y, nil);\r\n IntersectClipRect(DC, 0, 0, Width, Height);\r\n Perform(WM_PAINT, DC, 0);\r\n finally\r\n RestoreDC(DC, SaveIndex);\r\n ControlState := ControlState - [csPaintCopy];\r\n end;\r\n end;\r\n end;\r\n end;\r\n end;\r\n finally\r\n Control.Parent.ControlState := Control.Parent.ControlState - [csPaintCopy];\r\n end;\r\nend;\r\n\r\nfunction MakeModuleBitmap(Module: THandle; ResID: PChar): TBitmap;\r\nbegin\r\n Result := TBitmap.Create;\r\n try\r\n if Module <> 0 then\r\n begin\r\n if DWORD_PTR(ResID) <= $FFFF then\r\n Result.LoadFromResourceID(Module, INT_PTR(ResID))\r\n else\r\n Result.LoadFromResourceName(Module, StrPas(ResID));\r\n end\r\n else\r\n begin\r\n Result.Handle := LoadBitmap(Module, ResID);\r\n if Result.Handle = 0 then\r\n ResourceNotFound(ResID);\r\n end;\r\n except\r\n Result.Free;\r\n Result := nil;\r\n end;\r\nend;\r\n\r\nfunction MakeBitmap(ResID: PChar): TBitmap;\r\nbegin\r\n Result := MakeModuleBitmap(HInstance, ResID);\r\nend;\r\n\r\nfunction MakeBitmapID(ResID: Word): TBitmap;\r\nbegin\r\n Result := MakeModuleBitmap(HInstance, MakeIntResource(ResID));\r\nend;\r\n\r\nprocedure AssignBitmapCell(Source: TGraphic; Dest: TBitmap;\r\n Cols, Rows, Index: Integer);\r\nvar\r\n CellWidth, CellHeight: Integer;\r\nbegin\r\n if (Source <> nil) and (Dest <> nil) then\r\n begin\r\n if Cols <= 0 then\r\n Cols := 1;\r\n if Rows <= 0 then\r\n Rows := 1;\r\n if Index < 0 then\r\n Index := 0;\r\n CellWidth := Source.Width div Cols;\r\n CellHeight := Source.Height div Rows;\r\n Dest.Width := CellWidth;\r\n Dest.Height := CellHeight;\r\n if Source is TBitmap then\r\n begin\r\n Dest.Canvas.CopyRect(Bounds(0, 0, CellWidth, CellHeight),\r\n TBitmap(Source).Canvas, Bounds((Index mod Cols) * CellWidth,\r\n (Index div Cols) * CellHeight, CellWidth, CellHeight));\r\n Dest.TransparentColor := TBitmap(Source).TransparentColor;\r\n end\r\n else\r\n begin\r\n Dest.Canvas.Brush.Color := clSilver;\r\n Dest.Canvas.FillRect(Bounds(0, 0, CellWidth, CellHeight));\r\n Dest.Canvas.Draw(-(Index mod Cols) * CellWidth,\r\n -(Index div Cols) * CellHeight, Source);\r\n end;\r\n Dest.Transparent := Source.Transparent;\r\n end;\r\nend;\r\n\r\n{ Transparent bitmap }\r\n\r\n\r\n\r\nprocedure StretchBltTransparent(DstDC: HDC; DstX, DstY, DstW, DstH: Integer;\r\n SrcDC: HDC; SrcX, SrcY, SrcW, Srch: Integer; Palette: HPALETTE;\r\n TransparentColor: TColorRef);\r\nvar\r\n Color: TColorRef;\r\n bmAndBack, bmAndObject, bmAndMem, bmSave: HBITMAP;\r\n bmBackOld, bmObjectOld, bmMemOld, bmSaveOld: HBITMAP;\r\n MemDC, BackDC, ObjectDC, SaveDC: HDC;\r\n palDst, palMem, palSave, palObj: HPALETTE;\r\nbegin\r\n { Create some DCs to hold temporary data }\r\n BackDC := CreateCompatibleDC(DstDC);\r\n ObjectDC := CreateCompatibleDC(DstDC);\r\n MemDC := CreateCompatibleDC(DstDC);\r\n SaveDC := CreateCompatibleDC(DstDC);\r\n { Create a bitmap for each DC }\r\n bmAndObject := CreateBitmap(SrcW, Srch, 1, 1, nil);\r\n bmAndBack := CreateBitmap(SrcW, Srch, 1, 1, nil);\r\n bmAndMem := CreateCompatibleBitmap(DstDC, DstW, DstH);\r\n bmSave := CreateCompatibleBitmap(DstDC, SrcW, Srch);\r\n { Each DC must select a bitmap object to store pixel data }\r\n bmBackOld := SelectObject(BackDC, bmAndBack);\r\n bmObjectOld := SelectObject(ObjectDC, bmAndObject);\r\n bmMemOld := SelectObject(MemDC, bmAndMem);\r\n bmSaveOld := SelectObject(SaveDC, bmSave);\r\n { Select palette }\r\n palDst := 0;\r\n palMem := 0;\r\n palSave := 0;\r\n palObj := 0;\r\n if Palette <> 0 then\r\n begin\r\n palDst := SelectPalette(DstDC, Palette, True);\r\n RealizePalette(DstDC);\r\n palSave := SelectPalette(SaveDC, Palette, False);\r\n RealizePalette(SaveDC);\r\n palObj := SelectPalette(ObjectDC, Palette, False);\r\n RealizePalette(ObjectDC);\r\n palMem := SelectPalette(MemDC, Palette, True);\r\n RealizePalette(MemDC);\r\n end;\r\n { Set proper mapping mode }\r\n SetMapMode(SrcDC, GetMapMode(DstDC));\r\n SetMapMode(SaveDC, GetMapMode(DstDC));\r\n { Save the bitmap sent here }\r\n BitBlt(SaveDC, 0, 0, SrcW, Srch, SrcDC, SrcX, SrcY, SRCCOPY);\r\n { Set the background color of the source DC to the color, }\r\n { contained in the parts of the bitmap that should be transparent }\r\n Color := SetBkColor(SaveDC, PaletteColor(TransparentColor));\r\n { Create the object mask for the bitmap by performing a BitBlt() }\r\n { from the source bitmap to a monochrome bitmap }\r\n BitBlt(ObjectDC, 0, 0, SrcW, Srch, SaveDC, 0, 0, SRCCOPY);\r\n { Set the background color of the source DC back to the original }\r\n SetBkColor(SaveDC, Color);\r\n { Create the inverse of the object mask }\r\n BitBlt(BackDC, 0, 0, SrcW, Srch, ObjectDC, 0, 0, NOTSRCCOPY);\r\n { Copy the background of the main DC to the destination }\r\n BitBlt(MemDC, 0, 0, DstW, DstH, DstDC, DstX, DstY, SRCCOPY);\r\n { Mask out the places where the bitmap will be placed }\r\n StretchBlt(MemDC, 0, 0, DstW, DstH, ObjectDC, 0, 0, SrcW, Srch, SRCAND);\r\n { Mask out the transparent colored pixels on the bitmap }\r\n BitBlt(SaveDC, 0, 0, SrcW, Srch, BackDC, 0, 0, SRCAND);\r\n { XOR the bitmap with the background on the destination DC }\r\n StretchBlt(MemDC, 0, 0, DstW, DstH, SaveDC, 0, 0, SrcW, Srch, SRCPAINT);\r\n { Copy the destination to the screen }\r\n BitBlt(DstDC, DstX, DstY, DstW, DstH, MemDC, 0, 0, SRCCOPY);\r\n { Restore palette }\r\n if Palette <> 0 then\r\n begin\r\n SelectPalette(MemDC, palMem, False);\r\n SelectPalette(ObjectDC, palObj, False);\r\n SelectPalette(SaveDC, palSave, False);\r\n SelectPalette(DstDC, palDst, True);\r\n end;\r\n { Delete the memory bitmaps }\r\n DeleteObject(SelectObject(BackDC, bmBackOld));\r\n DeleteObject(SelectObject(ObjectDC, bmObjectOld));\r\n DeleteObject(SelectObject(MemDC, bmMemOld));\r\n DeleteObject(SelectObject(SaveDC, bmSaveOld));\r\n { Delete the memory DCs }\r\n DeleteDC(MemDC);\r\n DeleteDC(BackDC);\r\n DeleteDC(ObjectDC);\r\n DeleteDC(SaveDC);\r\nend;\r\n\r\n\r\n\r\nprocedure DrawTransparentBitmapRect(DC: HDC; Bitmap: HBITMAP; DstX, DstY,\r\n DstW, DstH: Integer; SrcRect: TRect; TransparentColor: TColorRef);\r\nvar\r\n hdcTemp: HDC;\r\nbegin\r\n hdcTemp := CreateCompatibleDC(DC);\r\n try\r\n SelectObject(hdcTemp, Bitmap);\r\n StretchBltTransparent(DC, DstX, DstY, DstW, DstH, hdcTemp,\r\n SrcRect.Left, SrcRect.Top, SrcRect.Right - SrcRect.Left, SrcRect.Bottom - SrcRect.Top, 0, TransparentColor);\r\n finally\r\n DeleteDC(hdcTemp);\r\n end;\r\nend;\r\n\r\nprocedure DrawTransparentBitmap(DC: HDC; Bitmap: HBITMAP;\r\n DstX, DstY: Integer; TransparentColor: TColorRef);\r\nvar\r\n BM: tagBITMAP;\r\nbegin\r\n GetObject(Bitmap, SizeOf(BM), @BM);\r\n DrawTransparentBitmapRect(DC, Bitmap, DstX, DstY, BM.bmWidth, BM.bmHeight,\r\n Rect(0, 0, BM.bmWidth, BM.bmHeight), TransparentColor);\r\nend;\r\n\r\nprocedure StretchBitmapTransparent(Dest: TCanvas; Bitmap: TBitmap;\r\n TransparentColor: TColor; DstX, DstY, DstW, DstH, SrcX, SrcY,\r\n SrcW, Srch: Integer);\r\nvar\r\n CanvasChanging: TNotifyEvent;\r\nbegin\r\n if DstW <= 0 then\r\n DstW := Bitmap.Width;\r\n if DstH <= 0 then\r\n DstH := Bitmap.Height;\r\n if (SrcW <= 0) or (Srch <= 0) then\r\n begin\r\n SrcX := 0;\r\n SrcY := 0;\r\n SrcW := Bitmap.Width;\r\n Srch := Bitmap.Height;\r\n end;\r\n if not Bitmap.Monochrome then\r\n SetStretchBltMode(Dest.Handle, STRETCH_DELETESCANS);\r\n CanvasChanging := Bitmap.Canvas.OnChanging;\r\n Bitmap.Canvas.Lock;\r\n try\r\n Bitmap.Canvas.OnChanging := nil;\r\n if TransparentColor = clNone then\r\n begin\r\n StretchBlt(Dest.Handle, DstX, DstY, DstW, DstH, Bitmap.Canvas.Handle,\r\n SrcX, SrcY, SrcW, Srch, Cardinal(Dest.CopyMode));\r\n end\r\n else\r\n begin\r\n if TransparentColor = clDefault then\r\n TransparentColor := Bitmap.Canvas.Pixels[0, Bitmap.Height - 1];\r\n if Bitmap.Monochrome then\r\n TransparentColor := clWhite\r\n else\r\n TransparentColor := ColorToRGB(TransparentColor);\r\n StretchBltTransparent(Dest.Handle, DstX, DstY, DstW, DstH,\r\n Bitmap.Canvas.Handle, SrcX, SrcY, SrcW, Srch,\r\n Bitmap.Palette, TransparentColor);\r\n end;\r\n finally\r\n Bitmap.Canvas.OnChanging := CanvasChanging;\r\n Bitmap.Canvas.Unlock;\r\n end;\r\nend;\r\n\r\nprocedure StretchBitmapRectTransparent(Dest: TCanvas; DstX, DstY,\r\n DstW, DstH: Integer; SrcRect: TRect; Bitmap: TBitmap;\r\n TransparentColor: TColor);\r\nbegin\r\n StretchBitmapTransparent(Dest, Bitmap, TransparentColor,\r\n DstX, DstY, DstW, DstH, SrcRect.Left, SrcRect.Top, SrcRect.Right - SrcRect.Left, SrcRect.Bottom - SrcRect.Top);\r\nend;\r\n\r\nprocedure DrawBitmapRectTransparent(Dest: TCanvas; DstX, DstY: Integer;\r\n SrcRect: TRect; Bitmap: TBitmap; TransparentColor: TColor);\r\nbegin\r\n StretchBitmapTransparent(Dest, Bitmap, TransparentColor,\r\n DstX, DstY, SrcRect.Right - SrcRect.Left, SrcRect.Bottom - SrcRect.Top, SrcRect.Left, SrcRect.Top, SrcRect.Right - SrcRect.Left,\r\n SrcRect.Bottom - SrcRect.Top);\r\nend;\r\n\r\nprocedure DrawBitmapTransparent(Dest: TCanvas; DstX, DstY: Integer;\r\n Bitmap: TBitmap; TransparentColor: TColor);\r\nbegin\r\n StretchBitmapTransparent(Dest, Bitmap, TransparentColor, DstX, DstY,\r\n Bitmap.Width, Bitmap.Height, 0, 0, Bitmap.Width, Bitmap.Height);\r\nend;\r\n\r\n{ CreateDisabledBitmap. Creating TBitmap object with disable button glyph\r\n image. You must destroy it outside by calling TBitmap.Free method. }\r\n\r\nfunction CreateDisabledBitmap_NewStyle(FOriginal: TBitmap; BackColor: TColor):\r\n TBitmap;\r\nvar\r\n MonoBmp: TBitmap;\r\n R: TRect;\r\n DestDC, SrcDC: HDC;\r\nbegin\r\n R := Rect(0, 0, FOriginal.Width, FOriginal.Height);\r\n Result := TBitmap.Create;\r\n try\r\n Result.Width := FOriginal.Width;\r\n Result.Height := FOriginal.Height;\r\n Result.Canvas.Brush.Color := BackColor;\r\n Result.Canvas.FillRect(R);\r\n\r\n MonoBmp := TBitmap.Create;\r\n try\r\n MonoBmp.Width := FOriginal.Width;\r\n MonoBmp.Height := FOriginal.Height;\r\n MonoBmp.Canvas.Brush.Color := clWhite;\r\n MonoBmp.Canvas.FillRect(R);\r\n DrawBitmapTransparent(MonoBmp.Canvas, 0, 0, FOriginal, BackColor);\r\n MonoBmp.Monochrome := True;\r\n\r\n SrcDC := MonoBmp.Canvas.Handle;\r\n { Convert Black to clBtnHighlight }\r\n Result.Canvas.Brush.Color := clBtnHighlight;\r\n DestDC := Result.Canvas.Handle;\r\n SetTextColor(DestDC, clWhite);\r\n SetBkColor(DestDC, clBlack);\r\n BitBlt(DestDC, 1, 1, FOriginal.Width, FOriginal.Height, SrcDC, 0, 0,\r\n ROP_DSPDxax);\r\n { Convert Black to clBtnShadow }\r\n Result.Canvas.Brush.Color := clBtnShadow;\r\n DestDC := Result.Canvas.Handle;\r\n SetTextColor(DestDC, clWhite);\r\n SetBkColor(DestDC, clBlack);\r\n BitBlt(DestDC, 0, 0, FOriginal.Width, FOriginal.Height, SrcDC, 0, 0,\r\n ROP_DSPDxax);\r\n finally\r\n MonoBmp.Free;\r\n end;\r\n except\r\n Result.Free;\r\n raise;\r\n end;\r\nend;\r\n\r\nfunction CreateDisabledBitmapEx(FOriginal: TBitmap; OutlineColor, BackColor,\r\n HighLightColor, ShadowColor: TColor; DrawHighlight: Boolean): TBitmap;\r\nvar\r\n MonoBmp: TBitmap;\r\n IRect: TRect;\r\nbegin\r\n IRect := Rect(0, 0, FOriginal.Width, FOriginal.Height);\r\n Result := TBitmap.Create;\r\n try\r\n Result.Width := FOriginal.Width;\r\n Result.Height := FOriginal.Height;\r\n MonoBmp := TBitmap.Create;\r\n try\r\n with MonoBmp do\r\n begin\r\n Width := FOriginal.Width;\r\n Height := FOriginal.Height;\r\n Canvas.CopyRect(IRect, FOriginal.Canvas, IRect);\r\n HandleType := bmDDB;\r\n Canvas.Brush.Color := OutlineColor;\r\n if Monochrome then\r\n begin\r\n Canvas.Font.Color := clWhite;\r\n Monochrome := False;\r\n Canvas.Brush.Color := clWhite;\r\n end;\r\n Monochrome := True;\r\n end;\r\n with Result.Canvas do\r\n begin\r\n Brush.Color := BackColor;\r\n FillRect(IRect);\r\n if DrawHighlight then\r\n begin\r\n Brush.Color := HighLightColor;\r\n SetTextColor(Handle, clBlack);\r\n SetBkColor(Handle, clWhite);\r\n BitBlt(Handle, 1, 1, RectWidth(IRect), RectHeight(IRect),\r\n MonoBmp.Canvas.Handle, 0, 0, ROP_DSPDxax);\r\n end;\r\n Brush.Color := ShadowColor;\r\n SetTextColor(Handle, clBlack);\r\n SetBkColor(Handle, clWhite);\r\n BitBlt(Handle, 0, 0, RectWidth(IRect), RectHeight(IRect),\r\n MonoBmp.Canvas.Handle, 0, 0, ROP_DSPDxax);\r\n end;\r\n finally\r\n MonoBmp.Free;\r\n end;\r\n except\r\n Result.Free;\r\n raise;\r\n end;\r\nend;\r\n\r\nfunction CreateDisabledBitmap(FOriginal: TBitmap; OutlineColor: TColor):\r\n TBitmap;\r\nbegin\r\n Result := CreateDisabledBitmapEx(FOriginal, OutlineColor,\r\n clBtnFace, clBtnHighlight, clBtnShadow, True);\r\nend;\r\n\r\n{ ChangeBitmapColor. This function create new TBitmap object.\r\n You must destroy it outside by calling TBitmap.Free method. }\r\n\r\nfunction ChangeBitmapColor(Bitmap: TBitmap; Color, NewColor: TColor): TBitmap;\r\nvar\r\n R: TRect;\r\nbegin\r\n Result := TBitmap.Create;\r\n try\r\n Result.Height := Bitmap.Height;\r\n Result.Width := Bitmap.Width;\r\n\r\n R := Bounds(0, 0, Result.Width, Result.Height);\r\n\r\n Result.Canvas.Brush.Color := NewColor;\r\n Result.Canvas.FillRect(R);\r\n Result.Canvas.BrushCopy( R, Bitmap, R, Color);\r\n except\r\n Result.Free;\r\n raise;\r\n end;\r\nend;\r\n\r\nprocedure ImageListDrawDisabled(Images: TCustomImageList; Canvas: TCanvas;\r\n X, Y, Index: Integer; HighLightColor, GrayColor: TColor;\r\n DrawHighlight: Boolean);\r\nvar\r\n Bmp: TBitmap;\r\n SaveColor: TColor;\r\nbegin\r\n SaveColor := Canvas.Brush.Color;\r\n Bmp := TBitmap.Create;\r\n try\r\n Bmp.Width := Images.Width;\r\n Bmp.Height := Images.Height;\r\n with Bmp.Canvas do\r\n begin\r\n Brush.Color := clWhite;\r\n FillRect(Rect(0, 0, Images.Width, Images.Height));\r\n ImageList_Draw(Images.Handle, Index, Handle, 0, 0, ILD_MASK);\r\n end;\r\n Bmp.Monochrome := True;\r\n if DrawHighlight then\r\n begin\r\n Canvas.Brush.Color := HighLightColor;\r\n SetTextColor(Canvas.Handle, clWhite);\r\n SetBkColor(Canvas.Handle, clBlack);\r\n BitBlt(Canvas.Handle, X + 1, Y + 1, Images.Width,\r\n Images.Height, Bmp.Canvas.Handle, 0, 0, ROP_DSPDxax);\r\n end;\r\n Canvas.Brush.Color := GrayColor;\r\n SetTextColor(Canvas.Handle, clWhite);\r\n SetBkColor(Canvas.Handle, clBlack);\r\n BitBlt(Canvas.Handle, X, Y, Images.Width,\r\n Images.Height, Bmp.Canvas.Handle, 0, 0, ROP_DSPDxax);\r\n finally\r\n Bmp.Free;\r\n Canvas.Brush.Color := SaveColor;\r\n end;\r\nend;\r\n\r\n{ Brush Pattern }\r\n\r\nfunction CreateTwoColorsBrushPattern(Color1, Color2: TColor): TBitmap;\r\nvar\r\n X, Y: Integer;\r\nbegin\r\n Result := TBitmap.Create;\r\n Result.Width := 8;\r\n Result.Height := 8;\r\n Result.Canvas.Brush.Style := bsSolid;\r\n Result.Canvas.Brush.Color := Color1;\r\n Result.Canvas.FillRect(Rect(0, 0, Result.Width, Result.Height));\r\n for Y := 0 to 7 do\r\n for X := 0 to 7 do\r\n if (Y mod 2) = (X mod 2) then { toggles between even/odd pixles }\r\n Result.Canvas.Pixels[X, Y] := Color2; { on even/odd rows }\r\nend;\r\n\r\n{ Icons }\r\n\r\nfunction MakeIcon(ResID: PChar): TIcon;\r\nbegin\r\n Result := MakeModuleIcon(HInstance, ResID);\r\nend;\r\n\r\nfunction MakeIconID(ResID: Word): TIcon;\r\nbegin\r\n Result := MakeModuleIcon(HInstance, MakeIntResource(ResID));\r\nend;\r\n\r\nfunction MakeModuleIcon(Module: THandle; ResID: PChar): TIcon;\r\nbegin\r\n Result := TIcon.Create;\r\n Result.Handle := LoadIcon(Module, ResID);\r\n if Result.Handle = 0 then\r\n begin\r\n Result.Free;\r\n Result := nil;\r\n end;\r\nend;\r\n\r\n{ Create TBitmap object from TIcon }\r\n\r\nfunction CreateBitmapFromIcon(Icon: TIcon; BackColor: TColor): TBitmap;\r\nvar\r\n IWidth, IHeight: Integer;\r\nbegin\r\n IWidth := Icon.Width;\r\n IHeight := Icon.Height;\r\n Result := TBitmap.Create;\r\n try\r\n Result.Width := IWidth;\r\n Result.Height := IHeight;\r\n Result.Canvas.Brush.Color := BackColor;\r\n Result.Canvas.FillRect(Rect(0, 0, IWidth, IHeight));\r\n Result.Canvas.Draw(0, 0, Icon);\r\n Result.TransparentColor := BackColor;\r\n Result.Transparent := True;\r\n except\r\n Result.Free;\r\n raise;\r\n end;\r\nend;\r\n\r\nfunction CreateIconFromBitmap(Bitmap: TBitmap; TransparentColor: TColor): TIcon;\r\n\r\nbegin\r\n with TImageList.CreateSize(Bitmap.Width, Bitmap.Height) do\r\n try\r\n if TransparentColor = clDefault then\r\n TransparentColor := Bitmap.TransparentColor;\r\n AllocBy := 1;\r\n AddMasked(Bitmap, TransparentColor);\r\n Result := TIcon.Create;\r\n try\r\n GetIcon(0, Result);\r\n except\r\n Result.Free;\r\n raise;\r\n end;\r\n finally\r\n Free;\r\n end;\r\nend;\r\n\r\ntype\r\n TCustomControlAccessProtected = class(TCustomControl);\r\n\r\nprocedure PaintInverseRect(const RectOrg, RectEnd: TPoint);\r\nvar\r\n DC: Windows.HDC;\r\n R: TRect;\r\nbegin\r\n DC := Windows.GetDC(HWND_DESKTOP);\r\n try\r\n R := Rect(RectOrg.X, RectOrg.Y, RectEnd.X, RectEnd.Y);\r\n Windows.InvertRect(DC, R);\r\n finally\r\n Windows.ReleaseDC(HWND_DESKTOP, DC);\r\n end;\r\nend;\r\n\r\nprocedure DrawInvertFrame(ScreenRect: TRect; Width: Integer);\r\nvar\r\n DC: Windows.HDC;\r\n I: Integer;\r\nbegin\r\n DC := Windows.GetDC(HWND_DESKTOP);\r\n try\r\n for I := 1 to Width do\r\n begin\r\n Windows.DrawFocusRect(DC, ScreenRect);\r\n //InflateRect(ScreenRect, -1, -1);\r\n end;\r\n finally\r\n Windows.ReleaseDC(HWND_DESKTOP, DC);\r\n end;\r\nend;\r\n\r\nfunction PointInPolyRgn(const P: TPoint; const Points: array of TPoint):\r\n Boolean;\r\ntype\r\n PPoints = ^TPoints;\r\n TPoints = array [0..0] of TPoint;\r\nvar\r\n Rgn: HRGN;\r\nbegin\r\n Rgn := CreatePolygonRgn(PPoints(@Points)^, High(Points) + 1, WINDING);\r\n try\r\n Result := PtInRegion(Rgn, P.X, P.Y);\r\n finally\r\n DeleteObject(Rgn);\r\n end;\r\nend;\r\n\r\nfunction PaletteColor(Color: TColor): Longint;\r\nbegin\r\n Result := ColorToRGB(Color) or PaletteMask;\r\nend;\r\n\r\nfunction CreateRotatedFont(Font: TFont; Angle: Integer): HFONT;\r\nvar\r\n LogFont: TLogFont;\r\nbegin\r\n FillChar(LogFont, SizeOf(LogFont), 0);\r\n with LogFont do\r\n begin\r\n lfHeight := Font.Height;\r\n lfWidth := 0;\r\n lfEscapement := Angle * 10;\r\n lfOrientation := 0;\r\n if fsBold in Font.Style then\r\n lfWeight := FW_BOLD\r\n else\r\n lfWeight := FW_NORMAL;\r\n lfItalic := Ord(fsItalic in Font.Style);\r\n lfUnderline := Ord(fsUnderline in Font.Style);\r\n lfStrikeOut := Byte(fsStrikeOut in Font.Style);\r\n lfCharSet := Byte(Font.Charset);\r\n if SameText(Font.Name, 'Default') then\r\n StrPCopy(lfFaceName, string(DefFontData.Name))\r\n else\r\n StrPCopy(lfFaceName, Font.Name);\r\n lfQuality := DEFAULT_QUALITY;\r\n lfOutPrecision := OUT_TT_PRECIS;\r\n lfClipPrecision := CLIP_DEFAULT_PRECIS;\r\n case Font.Pitch of\r\n fpVariable:\r\n lfPitchAndFamily := VARIABLE_PITCH;\r\n fpFixed:\r\n lfPitchAndFamily := FIXED_PITCH;\r\n else\r\n lfPitchAndFamily := DEFAULT_PITCH;\r\n end;\r\n end;\r\n Result := CreateFontIndirect(LogFont);\r\nend;\r\n\r\nfunction PaletteEntries(Palette: HPALETTE): Integer;\r\nbegin\r\n GetObject(Palette, SizeOf(Integer), @Result);\r\nend;\r\n\r\nprocedure Delay(MSecs: Int64);\r\nvar\r\n FirstTickCount, Now: Int64;\r\nbegin\r\n FirstTickCount := GetTickCount64;\r\n repeat\r\n Application.ProcessMessages;\r\n { allowing access to other controls, etc. }\r\n Now := GetTickCount64;\r\n until (Now - FirstTickCount >= MSecs);\r\nend;\r\n\r\nfunction GetTickCount64: Int64;\r\nvar\r\n QFreq, QCount: Int64;\r\nbegin\r\n Result := GetTickCount;\r\n if QueryPerformanceFrequency(QFreq) then\r\n begin\r\n QueryPerformanceCounter(QCount);\r\n if QFreq <> 0 then\r\n Result := (QCount div QFreq) * 1000;\r\n end;\r\nend;\r\n\r\nprocedure CenterControl(Control: TControl);\r\nvar\r\n X, Y: Integer;\r\nbegin\r\n X := Control.Left;\r\n Y := Control.Top;\r\n if Control is TForm then\r\n begin\r\n if (TForm(Control).FormStyle = fsMDIChild) and\r\n (Application.MainForm <> nil) then\r\n begin\r\n X := (Application.MainForm.ClientWidth - Control.Width) div 2;\r\n Y := (Application.MainForm.ClientHeight - Control.Height) div 2;\r\n end\r\n else\r\n begin\r\n X := (Screen.Width - Control.Width) div 2;\r\n Y := (Screen.Height - Control.Height) div 2;\r\n end;\r\n end\r\n else\r\n if Control.Parent <> nil then\r\n begin\r\n Control.Parent.HandleNeeded;\r\n X := (Control.Parent.ClientWidth - Control.Width) div 2;\r\n Y := (Control.Parent.ClientHeight - Control.Height) div 2;\r\n end;\r\n if X < 0 then\r\n X := 0;\r\n if Y < 0 then\r\n Y := 0;\r\n Control.SetBounds(X, Y, Control.Width, Control.Height);\r\nend;\r\n\r\nprocedure MergeForm(AControl: TWinControl; AForm: TForm; Align: TAlign;\r\n Show: Boolean);\r\nvar\r\n R: TRect;\r\n AutoScroll: Boolean;\r\nbegin\r\n AutoScroll := AForm.AutoScroll;\r\n AForm.Hide;\r\n TCustomControlAccessProtected(AForm).DestroyHandle;\r\n AForm.BorderStyle := bsNone;\r\n AForm.BorderIcons := [];\r\n AForm.Parent := AControl;\r\n AControl.DisableAlign;\r\n try\r\n if Align <> alNone then\r\n AForm.Align := Align\r\n else\r\n begin\r\n R := AControl.ClientRect;\r\n AForm.SetBounds(R.Left + AForm.Left, R.Top + AForm.Top, AForm.Width,\r\n AForm.Height);\r\n end;\r\n AForm.AutoScroll := AutoScroll;\r\n AForm.Visible := Show;\r\n finally\r\n AControl.EnableAlign;\r\n end;\r\nend;\r\n\r\n\r\n{ ShowMDIClientEdge function has been copied from Inprise's FORMS.PAS unit,\r\n Delphi 4 version }\r\n\r\nprocedure ShowMDIClientEdge(ClientHandle: THandle; ShowEdge: Boolean);\r\nvar\r\n Style: Longint;\r\nbegin\r\n if ClientHandle <> 0 then\r\n begin\r\n Style := GetWindowLong(ClientHandle, GWL_EXSTYLE);\r\n if ShowEdge then\r\n if Style and WS_EX_CLIENTEDGE = 0 then\r\n Style := Style or WS_EX_CLIENTEDGE\r\n else\r\n Exit\r\n else\r\n if Style and WS_EX_CLIENTEDGE <> 0 then\r\n Style := Style and not WS_EX_CLIENTEDGE\r\n else\r\n Exit;\r\n SetWindowLong(ClientHandle, GWL_EXSTYLE, Style);\r\n SetWindowPos(ClientHandle, 0, 0, 0, 0, 0,\r\n SWP_FRAMECHANGED or SWP_NOACTIVATE or SWP_NOMOVE or SWP_NOSIZE or SWP_NOZORDER);\r\n end;\r\nend;\r\n\r\n{ Shade rectangle }\r\n\r\nprocedure ShadeRect(DC: HDC; const Rect: TRect);\r\nconst\r\n HatchBits: array [0..7] of Word = ($11, $22, $44, $88, $11, $22, $44, $88);\r\nvar\r\n Bitmap: HBITMAP;\r\n SaveBrush: HBRUSH;\r\n SaveTextColor, SaveBkColor: TColorRef;\r\nbegin\r\n Bitmap := CreateBitmap(8, 8, 1, 1, @HatchBits);\r\n SaveBrush := SelectObject(DC, CreatePatternBrush(Bitmap));\r\n try\r\n SaveTextColor := SetTextColor(DC, clWhite);\r\n SaveBkColor := SetBkColor(DC, clBlack);\r\n PatBlt(DC, Rect.Left, Rect.Top, Rect.Right - Rect.Left, Rect.Bottom - Rect.Top, $00A000C9);\r\n SetBkColor(DC, SaveBkColor);\r\n SetTextColor(DC, SaveTextColor);\r\n finally\r\n DeleteObject(SelectObject(DC, SaveBrush));\r\n DeleteObject(Bitmap);\r\n end;\r\nend;\r\n\r\nfunction ScreenWorkArea: TRect;\r\nbegin\r\n {$IFDEF MSWINDOWS}\r\n if not SystemParametersInfo(SPI_GETWORKAREA, 0, @Result, 0) then\r\n {$ENDIF MSWINDOWS}\r\n Result := Bounds(0, 0, Screen.Width, Screen.Height);\r\nend;\r\n\r\n{ Standard Windows MessageBox function }\r\n\r\nfunction MsgBox(const Caption, Text: string; Flags: Integer): Integer;\r\nbegin\r\n Result := Application.MessageBox(PChar(Text), PChar(Caption), Flags);\r\nend;\r\n\r\nfunction MsgDlg(const Msg: string; AType: TMsgDlgType; AButtons: TMsgDlgButtons;\r\n HelpCtx: Longint): Word;\r\nbegin\r\n Result := MessageDlg(Msg, AType, AButtons, HelpCtx);\r\nend;\r\n\r\nfunction MsgBox(Handle: THandle; const Caption, Text: string; Flags: Integer): Integer;\r\nbegin\r\n {$IFDEF MSWINDOWS}\r\n Result := Windows.MessageBox(Handle, PChar(Text), PChar(Caption), Flags);\r\n {$ENDIF MSWINDOWS}\r\n {$IFDEF UNIX}\r\n Result := MsgBox(Caption, Text, Flags);\r\n {$ENDIF UNIX}\r\nend;\r\n\r\n{ Gradient fill procedure - displays a gradient beginning with a chosen }\r\n{ color and ending with another chosen color. Based on TGradientFill }\r\n{ component source code written by Curtis White, cwhite att teleport dott com. }\r\n\r\nprocedure GradientFillRect(Canvas: TCanvas; ARect: TRect; StartColor,\r\n EndColor: TColor; Direction: TFillDirection; Colors: Byte);\r\nvar\r\n StartRGB: array [0..2] of Byte; { Start RGB values }\r\n RGBDelta: array [0..2] of Integer;\r\n { Difference between start and end RGB values }\r\n ColorBand: TRect; { Color band rectangular coordinates }\r\n I, Delta: Integer;\r\n Brush: HBRUSH;\r\n TmpColor: TColor;\r\nbegin\r\n Canvas.Lock;\r\n try\r\n if (StartColor = clNone) and (EndColor = clNone) then\r\n Exit;\r\n if not (IsRectEmpty(ARect) and (GetMapMode(Canvas.Handle) = MM_TEXT)) then\r\n begin\r\n StartColor := ColorToRGB(StartColor);\r\n EndColor := ColorToRGB(EndColor);\r\n if Direction in [fdBottomToTop, fdRightToLeft] then\r\n begin\r\n // just swap the colors\r\n TmpColor := StartColor;\r\n StartColor := EndColor;\r\n EndColor := TmpColor;\r\n if Direction = fdBottomToTop then\r\n Direction := fdTopToBottom\r\n else\r\n Direction := fdLeftToRight;\r\n end;\r\n if (Colors < 2) or (StartColor = EndColor) then\r\n begin\r\n Brush := CreateSolidBrush(ColorToRGB(StartColor));\r\n FillRect(Canvas.Handle, ARect, Brush);\r\n DeleteObject(Brush);\r\n Exit;\r\n end;\r\n { Set the Red, Green and Blue colors }\r\n StartRGB[0] := GetRValue(StartColor);\r\n StartRGB[1] := GetGValue(StartColor);\r\n StartRGB[2] := GetBValue(StartColor);\r\n { Calculate the difference between begin and end RGB values }\r\n RGBDelta[0] := GetRValue(EndColor) - StartRGB[0];\r\n RGBDelta[1] := GetGValue(EndColor) - StartRGB[1];\r\n RGBDelta[2] := GetBValue(EndColor) - StartRGB[2];\r\n { Calculate the color band's coordinates }\r\n ColorBand := ARect;\r\n if Direction = fdTopToBottom then\r\n begin\r\n Colors := Max(2, Min(Colors, RectHeight(ARect)));\r\n Delta := RectHeight(ARect) div Colors;\r\n end\r\n else\r\n begin\r\n Colors := Max(2, Min(Colors, RectWidth(ARect)));\r\n Delta := RectWidth(ARect) div Colors;\r\n end;\r\n Canvas.Pen.Style := psSolid;\r\n Canvas.Pen.Mode := pmCopy;\r\n { Perform the fill }\r\n if Delta > 0 then\r\n begin\r\n for I := 0 to Colors - 1 do\r\n begin\r\n if Direction = fdTopToBottom then\r\n { Calculate the color band's top and bottom coordinates }\r\n begin\r\n ColorBand.Top := ARect.Top + I * Delta;\r\n ColorBand.Bottom := ColorBand.Top + Delta;\r\n end\r\n { Calculate the color band's left and right coordinates }\r\n else\r\n begin\r\n ColorBand.Left := ARect.Left + I * Delta;\r\n ColorBand.Right := ColorBand.Left + Delta;\r\n end;\r\n { Calculate the color band's color }\r\n Brush := CreateSolidBrush(RGB(\r\n StartRGB[0] + MulDiv(I, RGBDelta[0], Colors - 1),\r\n StartRGB[1] + MulDiv(I, RGBDelta[1], Colors - 1),\r\n StartRGB[2] + MulDiv(I, RGBDelta[2], Colors - 1)));\r\n FillRect(Canvas.Handle, ColorBand, Brush);\r\n DeleteObject(Brush);\r\n end;\r\n end;\r\n if Direction = fdTopToBottom then\r\n Delta := RectHeight(ARect) mod Colors\r\n else\r\n Delta := RectWidth(ARect) mod Colors;\r\n if Delta > 0 then\r\n begin\r\n if Direction = fdTopToBottom then\r\n { Calculate the color band's top and bottom coordinates }\r\n begin\r\n ColorBand.Top := ARect.Bottom - Delta;\r\n ColorBand.Bottom := ColorBand.Top + Delta;\r\n end\r\n else\r\n { Calculate the color band's left and right coordinates }\r\n begin\r\n ColorBand.Left := ARect.Right - Delta;\r\n ColorBand.Right := ColorBand.Left + Delta;\r\n end;\r\n Brush := CreateSolidBrush(EndColor);\r\n FillRect(Canvas.Handle, ColorBand, Brush);\r\n DeleteObject(Brush);\r\n end;\r\n end; // if Not (IsRectEmpty(ARect) and ...\r\n finally\r\n Canvas.Unlock;\r\n end;\r\nend;\r\n\r\nfunction GetAveCharSize(Canvas: TCanvas): TPoint;\r\nvar\r\n I: Integer;\r\n Buffer: array [0..51] of Char;\r\nbegin\r\n for I := 0 to 25 do\r\n Buffer[I] := Chr(I + Ord('A'));\r\n for I := 0 to 25 do\r\n Buffer[I + 26] := Chr(I + Ord('a'));\r\n GetTextExtentPoint32(Canvas.Handle, Buffer, 52, TSize(Result));\r\n Result.X := Result.X div 52;\r\nend;\r\n\r\n{ Cursor routines }\r\n\r\n{$IFDEF MSWINDOWS}\r\nfunction LoadAniCursor(Instance: THandle; ResID: PChar): HCURSOR;\r\n{ Unfortunately I don't know how we can load animated cursor from\r\n executable resource directly. So I write this routine using temporary\r\n file and LoadCursorFromFile function. }\r\nvar\r\n S: TFileStream;\r\n FileName: string;\r\n RSrc: HRSRC;\r\n Res: THandle;\r\n Data: Pointer;\r\nbegin\r\n Result := 0;\r\n RSrc := FindResource(Instance, ResID, RT_ANICURSOR);\r\n if RSrc <> 0 then\r\n begin\r\n FileName := FileGetTempName('ANI');\r\n try\r\n Res := LoadResource(Instance, RSrc);\r\n try\r\n Data := LockResource(Res);\r\n if Data <> nil then\r\n try\r\n S := TFileStream.Create(FileName, fmCreate);\r\n try\r\n S.WriteBuffer(Data^, SizeOfResource(Instance, RSrc));\r\n finally\r\n S.Free;\r\n end;\r\n Result := LoadCursorFromFile(PChar(FileName));\r\n finally\r\n UnlockResource(Res);\r\n end;\r\n finally\r\n FreeResource(Res);\r\n end;\r\n finally\r\n Windows.DeleteFile(PChar(FileName));\r\n end;\r\n end;\r\nend;\r\n{$ENDIF MSWINDOWS}\r\n\r\nfunction GetNextFreeCursorIndex(StartHint: Integer; PreDefined: Boolean): Integer;\r\nbegin\r\n Result := StartHint;\r\n if PreDefined then\r\n begin\r\n if Result >= crSizeAll then\r\n Result := crSizeAll - 1;\r\n end\r\n else\r\n if Result <= crDefault then\r\n Result := crDefault + 1;\r\n while (Screen.Cursors[Result] <> Screen.Cursors[crDefault]) do\r\n begin\r\n if PreDefined then\r\n Dec(Result)\r\n else\r\n Inc(Result);\r\n if (Result < Low(TCursor)) or (Result > High(TCursor)) then\r\n raise EOutOfResources.CreateRes(@SOutOfResources);\r\n end;\r\nend;\r\n\r\nfunction DefineCursor(Instance: THandle; ResID: PChar): TCursor;\r\nvar\r\n Handle: HCURSOR;\r\nbegin\r\n Handle := LoadCursor(Instance, ResID);\r\n if Handle = 0 then\r\n Handle := LoadAniCursor(Instance, ResID);\r\n if Handle = 0 then\r\n ResourceNotFound(ResID);\r\n try\r\n Result := GetNextFreeCursorIndex(crJVCLFirst, False);\r\n Screen.Cursors[Result] := Handle;\r\n except\r\n DestroyCursor(Handle);\r\n raise;\r\n end;\r\nend;\r\n\r\nvar\r\n WaitCount: Integer = 0;\r\n SaveCursor: TCursor = crDefault;\r\n\r\nconst\r\n FWaitCursor: TCursor = crHourGlass;\r\n\r\nprocedure StartWait;\r\nbegin\r\n if WaitCount = 0 then\r\n begin\r\n SaveCursor := Screen.Cursor;\r\n Screen.Cursor := FWaitCursor;\r\n end;\r\n Inc(WaitCount);\r\nend;\r\n\r\nprocedure StopWait;\r\nbegin\r\n if WaitCount > 0 then\r\n begin\r\n Dec(WaitCount);\r\n if WaitCount = 0 then\r\n Screen.Cursor := SaveCursor;\r\n end;\r\nend;\r\n\r\nfunction WaitCursor: IInterface;\r\nbegin\r\n Result := ScreenCursor(crHourGlass);\r\nend;\r\n\r\nfunction ScreenCursor(ACursor: TCursor): IInterface;\r\nbegin\r\n Result := TWaitCursor.Create(ACursor);\r\nend;\r\n\r\n{$IFDEF MSWINDOWS}\r\n\r\nvar\r\n OLEDragCursorsLoaded: Boolean = False;\r\n\r\nfunction LoadOLEDragCursors: Boolean;\r\nconst\r\n cOle32DLL = 'ole32.dll';\r\nvar\r\n Handle: Cardinal;\r\nbegin\r\n if OLEDragCursorsLoaded then\r\n begin\r\n Result := True;\r\n Exit;\r\n end;\r\n OLEDragCursorsLoaded := True;\r\n\r\n Result := False;\r\n if Screen <> nil then\r\n begin\r\n Handle := GetModuleHandle(cOle32DLL);\r\n if Handle = 0 then\r\n Handle := LoadLibraryEx(cOle32DLL, 0, LOAD_LIBRARY_AS_DATAFILE);\r\n if Handle <> 0 then // (p3) don't free the lib handle!\r\n try\r\n Screen.Cursors[crNoDrop] := LoadCursor(Handle, PChar(1));\r\n Screen.Cursors[crDrag] := LoadCursor(Handle, PChar(2));\r\n Screen.Cursors[crMultiDrag] := LoadCursor(Handle, PChar(3));\r\n Screen.Cursors[crMultiDragLink] := LoadCursor(Handle, PChar(4));\r\n Screen.Cursors[crDragAlt] := LoadCursor(Handle, PChar(5));\r\n Screen.Cursors[crMultiDragAlt] := LoadCursor(Handle, PChar(6));\r\n Screen.Cursors[crMultiDragLinkAlt] := LoadCursor(Handle, PChar(7));\r\n Result := True;\r\n except\r\n end;\r\n end;\r\nend;\r\n\r\n{$ENDIF MSWINDOWS}\r\n\r\nprocedure SetDefaultJVCLCursors;\r\nbegin\r\n if Screen <> nil then\r\n begin\r\n // dynamically assign the first available cursor id to our cursor defines\r\n crMultiDragLink := GetNextFreeCursorIndex(crJVCLFirst, False);\r\n Screen.Cursors[crMultiDragLink] := Screen.Cursors[crMultiDrag];\r\n crDragAlt := GetNextFreeCursorIndex(crJVCLFirst, False);\r\n Screen.Cursors[crDragAlt] := Screen.Cursors[crDrag];\r\n crMultiDragAlt := GetNextFreeCursorIndex(crJVCLFirst, False);\r\n Screen.Cursors[crMultiDragAlt] := Screen.Cursors[crMultiDrag];\r\n crMultiDragLinkAlt := GetNextFreeCursorIndex(crJVCLFirst, False);\r\n Screen.Cursors[crMultiDragLinkAlt] := Screen.Cursors[crMultiDrag];\r\n crHand := GetNextFreeCursorIndex(crJVCLFirst, False);\r\n Screen.Cursors[crHand] := LoadCursor(HInstance, 'JvHANDCURSOR');\r\n crDragHand := GetNextFreeCursorIndex(crJVCLFirst, False);\r\n Screen.Cursors[crDragHand] := LoadCursor(hInstance, 'JvDRAGCURSOR');\r\n end;\r\nend;\r\n\r\n{ Grid drawing }\r\n\r\nvar\r\n DrawBitmap: TBitmap = nil;\r\n\r\nprocedure UsesBitmap;\r\nbegin\r\n if DrawBitmap = nil then\r\n DrawBitmap := TBitmap.Create;\r\nend;\r\n\r\nprocedure WriteText(ACanvas: TCanvas; ARect: TRect; DX, DY: Integer;\r\n const Text: string; Alignment: TAlignment; WordWrap: Boolean;\r\n ARightToLeft: Boolean = False);\r\nconst\r\n AlignFlags: array [TAlignment] of Integer =\r\n (DT_LEFT or DT_EXPANDTABS or DT_NOPREFIX,\r\n DT_RIGHT or DT_EXPANDTABS or DT_NOPREFIX,\r\n DT_CENTER or DT_EXPANDTABS or DT_NOPREFIX);\r\n WrapFlags: array [Boolean] of Integer = (0, DT_WORDBREAK);\r\n\r\n RTL: array [Boolean] of Integer = (0, DT_RTLREADING);\r\nvar\r\n B, R: TRect;\r\n I, Left: Integer;\r\nbegin\r\n UsesBitmap;\r\n I := ColorToRGB(ACanvas.Brush.Color);\r\n if not WordWrap and (Integer(GetNearestColor(ACanvas.Handle, I)) = I) and\r\n (Pos(Cr, Text) = 0) then\r\n begin { Use ExtTextOut for solid colors }\r\n { In BiDi, because we changed the window origin, the text that does not\r\n change alignment, actually gets its alignment changed. }\r\n if (ACanvas.CanvasOrientation = coRightToLeft) and (not ARightToLeft) then\r\n ChangeBiDiModeAlignment(Alignment);\r\n case Alignment of\r\n taLeftJustify:\r\n Left := ARect.Left + DX;\r\n taRightJustify:\r\n Left := ARect.Right - ACanvas.TextWidth(Text) - 3;\r\n else { taCenter }\r\n Left := ARect.Left + (ARect.Right - ARect.Left) shr 1 -\r\n (ACanvas.TextWidth(Text) shr 1);\r\n end;\r\n ACanvas.TextRect(ARect, Left, ARect.Top + DY, Text);\r\n end\r\n else\r\n begin { Use FillRect and DrawText for dithered colors }\r\n DrawBitmap.Canvas.Lock;\r\n try\r\n { Use offscreen bitmap to eliminate flicker and }\r\n { brush origin tics in painting / scrolling. }\r\n DrawBitmap.Width := Max(DrawBitmap.Width, ARect.Right - ARect.Left);\r\n DrawBitmap.Height := Max(DrawBitmap.Height, ARect.Bottom - ARect.Top);\r\n R := Rect(DX, DY, ARect.Right - ARect.Left - 1, ARect.Bottom - ARect.Top - 1);\r\n B := Rect(0, 0, ARect.Right - ARect.Left, ARect.Bottom - ARect.Top);\r\n\r\n DrawBitmap.Canvas.Font := ACanvas.Font;\r\n DrawBitmap.Canvas.Font.Color := ACanvas.Font.Color;\r\n DrawBitmap.Canvas.Brush := ACanvas.Brush;\r\n DrawBitmap.Canvas.Brush.Style := bsSolid;\r\n DrawBitmap.Canvas.FillRect(B);\r\n SetBkMode(DrawBitmap.Canvas.Handle, Transparent);\r\n if (ACanvas.CanvasOrientation = coRightToLeft) then\r\n ChangeBiDiModeAlignment(Alignment);\r\n DrawText(DrawBitmap.Canvas, Text, Length(Text), R,\r\n //Windows.DrawText(Handle, PChar(Text), Length(Text), R,\r\n AlignFlags[Alignment] or RTL[ARightToLeft] or WrapFlags[WordWrap]);\r\n\r\n ACanvas.CopyRect(ARect, DrawBitmap.Canvas, B);\r\n finally\r\n DrawBitmap.Canvas.Unlock;\r\n end;\r\n end;\r\nend;\r\n\r\n\r\n\r\nprocedure DrawCellTextEx(Control: TCustomControl; ACol, ARow: Longint;\r\n const S: string; const ARect: TRect; Align: TAlignment;\r\n VertAlign: TVertAlignment; WordWrap: Boolean; ARightToLeft: Boolean); overload;\r\nconst\r\n MinOffs = 2;\r\nvar\r\n H: Integer;\r\nbegin\r\n case VertAlign of\r\n vaTopJustify:\r\n H := MinOffs;\r\n vaCenterJustify:\r\n H := Max(1, (ARect.Bottom - ARect.Top - TCustomControlAccessProtected(Control).Canvas.TextHeight('W')) div 2);\r\n else {vaBottomJustify}\r\n H := Max(MinOffs, ARect.Bottom - ARect.Top - TCustomControlAccessProtected(Control).Canvas.TextHeight('W'));\r\n end;\r\n WriteText(TCustomControlAccessProtected(Control).Canvas, ARect, MinOffs,\r\n H, S, Align, WordWrap, ARightToLeft);\r\nend;\r\n\r\nprocedure DrawCellText(Control: TCustomControl; ACol, ARow: Longint;\r\n const S: string; const ARect: TRect; Align: TAlignment;\r\n VertAlign: TVertAlignment; ARightToLeft: Boolean); overload;\r\nbegin\r\n DrawCellTextEx(Control, ACol, ARow, S, ARect, Align, VertAlign,\r\n Align = taCenter, ARightToLeft);\r\nend;\r\n\r\nprocedure DrawCellTextEx(Control: TCustomControl; ACol, ARow: Longint;\r\n const S: string; const ARect: TRect; Align: TAlignment;\r\n VertAlign: TVertAlignment; WordWrap: Boolean); overload;\r\nconst\r\n MinOffs = 2;\r\nvar\r\n H: Integer;\r\nbegin\r\n case VertAlign of\r\n vaTopJustify:\r\n H := MinOffs;\r\n vaCenterJustify:\r\n H := Max(1, (ARect.Bottom - ARect.Top - TCustomControlAccessProtected(Control).Canvas.TextHeight('W')) div 2);\r\n else {vaBottomJustify}\r\n H := Max(MinOffs, ARect.Bottom - ARect.Top - TCustomControlAccessProtected(Control).Canvas.TextHeight('W'));\r\n end;\r\n WriteText(TCustomControlAccessProtected(Control).Canvas, ARect, MinOffs, H, S, Align, WordWrap);\r\nend;\r\n\r\nprocedure DrawCellText(Control: TCustomControl; ACol, ARow: Longint;\r\n const S: string; const ARect: TRect; Align: TAlignment;\r\n VertAlign: TVertAlignment); overload;\r\nbegin\r\n DrawCellTextEx(Control, ACol, ARow, S, ARect, Align, VertAlign, Align = taCenter);\r\nend;\r\n\r\nprocedure DrawCellBitmap(Control: TCustomControl; ACol, ARow: Longint;\r\n Bmp: TGraphic; Rect: TRect);\r\nbegin\r\n Rect.Top := (Rect.Bottom + Rect.Top - Bmp.Height) div 2;\r\n Rect.Left := (Rect.Right + Rect.Left - Bmp.Width) div 2;\r\n TCustomControlAccessProtected(Control).Canvas.Draw(Rect.Left, Rect.Top, Bmp);\r\nend;\r\n\r\n//=== { TJvDesktopCanvas } ===================================================\r\n\r\ndestructor TJvDesktopCanvas.Destroy;\r\nbegin\r\n FreeHandle;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvDesktopCanvas.CreateHandle;\r\nbegin\r\n if FDC = 0 then\r\n FDC := GetWindowDC(GetDesktopWindow);\r\n Handle := FDC;\r\nend;\r\n\r\nprocedure TJvDesktopCanvas.FreeHandle;\r\nbegin\r\n if FDC <> 0 then\r\n begin\r\n Handle := 0;\r\n ReleaseDC(GetDesktopWindow, FDC);\r\n FDC := 0;\r\n end;\r\nend;\r\n\r\n\r\nprocedure TJvDesktopCanvas.SetOrigin(X, Y: Integer);\r\nvar\r\n FOrigin: TPoint;\r\nbegin\r\n SetWindowOrgEx(Handle, -X, -Y, @FOrigin);\r\nend;\r\n\r\n// (rom) moved to file end to minimize W- switch impact at end of function\r\n\r\n{ end JvVCLUtils }\r\n{ begin JvUtils }\r\n\r\nfunction FindByTag(WinControl: TWinControl; ComponentClass: TComponentClass;\r\n const Tag: Integer): TComponent;\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := 0 to WinControl.ControlCount - 1 do\r\n begin\r\n Result := WinControl.Controls[I];\r\n if (Result is ComponentClass) and (Result.Tag = Tag) then\r\n Exit;\r\n end;\r\n Result := nil;\r\nend;\r\n\r\nfunction ControlAtPos2(Parent: TWinControl; X, Y: Integer): TControl;\r\nvar\r\n I: Integer;\r\n P: TPoint;\r\nbegin\r\n P := Point(X, Y);\r\n for I := Parent.ControlCount - 1 downto 0 do\r\n begin\r\n Result := Parent.Controls[I];\r\n if PtInRect(Result.BoundsRect, P) then\r\n Exit;\r\n end;\r\n Result := nil;\r\nend;\r\n\r\nfunction RBTag(Parent: TWinControl): Integer;\r\nvar\r\n RB: TRadioButton;\r\n I: Integer;\r\nbegin\r\n RB := nil;\r\n for I := 0 to Parent.ControlCount - 1 do\r\n if (Parent.Controls[I] is TRadioButton) and\r\n (Parent.Controls[I] as TRadioButton).Checked then\r\n begin\r\n RB := Parent.Controls[I] as TRadioButton;\r\n Break;\r\n end;\r\n if RB <> nil then\r\n Result := RB.Tag\r\n else\r\n Result := 0;\r\nend;\r\n\r\nfunction FindFormByClass(FormClass: TFormClass): TForm;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := nil;\r\n for I := 0 to Application.ComponentCount - 1 do\r\n if Application.Components[I].ClassName = FormClass.ClassName then\r\n begin\r\n Result := Application.Components[I] as TForm;\r\n Break;\r\n end;\r\nend;\r\n\r\nfunction FindFormByClassName(const FormClassName: string): TForm;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := nil;\r\n for I := 0 to Application.ComponentCount - 1 do\r\n if Application.Components[I].ClassName = FormClassName then\r\n begin\r\n Result := Application.Components[I] as TForm;\r\n Break;\r\n end;\r\nend;\r\n\r\nfunction AppMinimized: Boolean;\r\nbegin\r\n Result := IsIconic(GetAppHandle);\r\nend;\r\n\r\n{$IFDEF MSWINDOWS}\r\n{ Check if this is the active Windows task }\r\n{ Copied from implementation of FORMS.PAS }\r\ntype\r\n PCheckTaskInfo = ^TCheckTaskInfo;\r\n TCheckTaskInfo = record\r\n FocusWnd: Windows.HWND;\r\n Found: Boolean;\r\n end;\r\n\r\nfunction CheckTaskWindow(Window: HWND; Data: LPARAM): BOOL; stdcall;\r\nbegin\r\n Result := True;\r\n if PCheckTaskInfo(Data).FocusWnd = Window then\r\n begin\r\n PCheckTaskInfo(Data).Found := True;\r\n Result := False;\r\n end;\r\nend;\r\n\r\nfunction IsForegroundTask: Boolean;\r\nvar\r\n Info: TCheckTaskInfo;\r\nbegin\r\n Info.FocusWnd := Windows.GetActiveWindow;\r\n Info.Found := False;\r\n EnumThreadWindows(GetCurrentThreadId, @CheckTaskWindow, LPARAM(@Info));\r\n Result := Info.Found;\r\nend;\r\n{$ENDIF MSWINDOWS}\r\n\r\n{$IFDEF UNIX}\r\nfunction IsForegroundTask: Boolean;\r\nbegin\r\n Result := Application.Active;\r\nend;\r\n{$ENDIF UNIX}\r\n\r\nconst\r\n NoHelp = 0; { for MsgDlg2 }\r\n MsgDlgCharSet: Integer = DEFAULT_CHARSET;\r\n\r\nfunction MsgDlgDef1(const Msg, ACaption: string; DlgType: TMsgDlgType;\r\n Buttons: TMsgDlgButtons; DefButton: TMsgDlgBtn; UseDefButton: Boolean;\r\n AHelpContext: Integer; Control: TWinControl): Integer;\r\nconst\r\n ButtonNames: array [TMsgDlgBtn] of string =\r\n ('Yes', 'No', 'OK', 'Cancel', 'Abort', 'Retry', 'Ignore', 'All', 'NoToAll',\r\n 'YesToAll', 'Help'{$IFDEF RTL200_UP}, 'Close'{$ENDIF RTL200_UP});\r\nvar\r\n P: TPoint;\r\n I: Integer;\r\n Btn: TButton;\r\n StayOnTop: Boolean;\r\nbegin\r\n if AHelpContext <> 0 then\r\n Buttons := Buttons + [mbHelp];\r\n StayOnTop := False;\r\n with CreateMessageDialog(Msg, DlgType, Buttons) do\r\n try\r\n Font.Charset := MsgDlgCharSet;\r\n if (Screen.ActiveForm <> nil) and\r\n (Screen.ActiveForm.FormStyle = fsStayOnTop) then\r\n begin\r\n StayOnTop := True;\r\n SetWindowTop(Screen.ActiveForm.Handle, False);\r\n end;\r\n if ACaption <> '' then\r\n Caption := ACaption;\r\n if Control = nil then\r\n begin\r\n Left := (Screen.Width - Width) div 2;\r\n Top := (Screen.Height - Height) div 2;\r\n end\r\n else\r\n begin\r\n P := Point((Control.Width - Width) div 2,\r\n (Control.Height - Height) div 2);\r\n P := Control.ClientToScreen(P);\r\n Left := P.X;\r\n Top := P.Y\r\n end;\r\n if Left < 0 then\r\n Left := 0\r\n else\r\n if Left > Screen.Width then\r\n Left := Screen.Width - Width;\r\n if Top < 0 then\r\n Top := 0\r\n else\r\n if Top > Screen.Height then\r\n Top := Screen.Height - Height;\r\n HelpContext := AHelpContext;\r\n\r\n Btn := FindComponent(ButtonNames[DefButton]) as TButton;\r\n if UseDefButton and (Btn <> nil) then\r\n begin\r\n for I := 0 to ComponentCount - 1 do\r\n if Components[I] is TButton then\r\n (Components[I] as TButton).Default := False;\r\n Btn.Default := True;\r\n ActiveControl := Btn;\r\n end;\r\n Btn := FindComponent(ButtonNames[mbIgnore]) as TButton;\r\n if Btn <> nil then\r\n begin\r\n // Btn.Width := Btn.Width * 5 div 4; {To shift the Help button Help [translated] }\r\n end;\r\n Result := ShowModal;\r\n finally\r\n Free;\r\n if (Screen.ActiveForm <> nil) and StayOnTop then\r\n SetWindowTop(Screen.ActiveForm.Handle, True);\r\n end;\r\nend;\r\n\r\nfunction MsgDlgDef(const Msg, ACaption: string; DlgType: TMsgDlgType;\r\n Buttons: TMsgDlgButtons; DefButton: TMsgDlgBtn; HelpContext: Integer;\r\n Control: TWinControl): Integer;\r\nbegin\r\n Result := MsgDlgDef1(Msg, ACaption, DlgType, Buttons, DefButton, True,\r\n HelpContext, Control);\r\nend;\r\n\r\nfunction MsgDlg2(const Msg, ACaption: string; DlgType: TMsgDlgType;\r\n Buttons: TMsgDlgButtons; HelpContext: Integer;\r\n Control: TWinControl): Integer;\r\nbegin\r\n Result := MsgDlgDef1(Msg, ACaption, DlgType, Buttons, mbHelp, False,\r\n HelpContext, Control);\r\nend;\r\n\r\nfunction MsgYesNo(Handle: Integer; const Msg, Caption: string; Flags: DWORD = 0): Boolean;\r\nbegin\r\n Result := MsgBox(Handle, Caption, Msg, MB_YESNO or Flags) = IDYES;\r\nend;\r\n\r\nfunction MsgRetryCancel(Handle: Integer; const Msg, Caption: string; Flags: DWORD = 0): Boolean;\r\nbegin\r\n Result := MsgBox(Handle, Caption, Msg, MB_RETRYCANCEL or Flags) = IDRETRY;\r\nend;\r\n\r\nfunction MsgAbortRetryIgnore(Handle: Integer; const Msg, Caption: string; Flags: DWORD = 0): Integer;\r\nbegin\r\n Result := MsgBox(Handle, Caption, Msg, MB_ABORTRETRYIGNORE or Flags);\r\nend;\r\n\r\nfunction MsgYesNoCancel(Handle: Integer; const Msg, Caption: string; Flags: DWORD = 0): Integer;\r\nbegin\r\n Result := MsgBox(Handle, Caption, Msg, MB_YESNOCANCEL or Flags);\r\nend;\r\n\r\nfunction MsgOKCancel(Handle: Integer; const Msg, Caption: string; Flags: DWORD = 0): Boolean;\r\nbegin\r\n Result := MsgBox(Handle, Caption, Msg, MB_OKCANCEL or Flags) = IDOK;\r\nend;\r\n\r\nprocedure MsgOK(Handle: Integer; const Msg, Caption: string; Flags: DWORD = 0);\r\nbegin\r\n MsgBox(Handle, Caption, Msg, MB_OK or Flags);\r\nend;\r\n\r\nprocedure MsgInfo(Handle: Integer; const Msg, Caption: string; Flags: DWORD = 0);\r\nbegin\r\n MsgOK(Handle, Msg, Caption, MB_ICONINFORMATION or Flags);\r\nend;\r\n\r\nprocedure MsgWarn(Handle: Integer; const Msg, Caption: string; Flags: DWORD = 0);\r\nbegin\r\n MsgOK(Handle, Msg, Caption, MB_ICONWARNING or Flags);\r\nend;\r\n\r\nprocedure MsgQuestion(Handle: Integer; const Msg, Caption: string; Flags: DWORD = 0);\r\nbegin\r\n MsgOK(Handle, Msg, Caption, MB_ICONQUESTION or Flags);\r\nend;\r\n\r\nprocedure MsgError(Handle: Integer; const Msg, Caption: string; Flags: DWORD = 0);\r\nbegin\r\n MsgOK(Handle, Msg, Caption, MB_ICONERROR or Flags);\r\nend;\r\n\r\nfunction FindIcon(hInstance: DWORD; const IconName: string): Boolean;\r\nbegin\r\n if Win32Platform = VER_PLATFORM_WIN32_NT then\r\n Result := (IconName <> '') and\r\n (FindResourceW(hInstance, PWideChar(WideString(IconName)), PWideChar(RT_GROUP_ICON)) <> 0) or\r\n (FindResourceW(hInstance, PWideChar(WideString(IconName)), PWideChar(RT_ICON)) <> 0)\r\n else\r\n Result := (IconName <> '') and\r\n (FindResourceA(hInstance, PAnsiChar(AnsiString(IconName)), PAnsiChar(RT_GROUP_ICON)) <> 0) or\r\n (FindResourceA(hInstance, PAnsiChar(AnsiString(IconName)), PAnsiChar(RT_ICON)) <> 0);\r\nend;\r\n\r\ntype\r\n TMsgBoxParamsRec = record\r\n case Boolean of\r\n False: (ParamsA: TMsgBoxParamsA);\r\n True: (ParamsW: TMsgBoxParamsW);\r\n end;\r\n\r\nprocedure MsgAbout(Handle: Integer; const Msg, Caption: string; const IcoName: string = 'MAINICON'; Flags: DWORD = MB_OK);\r\nvar\r\n Params: TMsgBoxParamsRec;\r\nbegin\r\n if Win32Platform = VER_PLATFORM_WIN32_NT then\r\n begin\r\n Params.ParamsW.hInstance := hInstance;\r\n Params.ParamsW.cbSize := SizeOf(TMsgBoxParamsW);\r\n Params.ParamsW.hwndOwner := Handle;\r\n Params.ParamsW.lpszText := PWideChar(WideString(Msg));\r\n Params.ParamsW.lpszCaption := PWideChar(WideString(Caption));\r\n Params.ParamsW.dwStyle := Flags;\r\n if FindIcon(hInstance, IcoName) then\r\n begin\r\n Params.ParamsW.dwStyle := Params.ParamsW.dwStyle or MB_USERICON;\r\n Params.ParamsW.lpszIcon := PWideChar(WideString(IcoName));\r\n end\r\n else\r\n Params.ParamsW.dwStyle := Params.ParamsW.dwStyle or MB_ICONINFORMATION;\r\n Params.ParamsW.dwContextHelpId := 0;\r\n Params.ParamsW.lpfnMsgBoxCallback := nil;\r\n Params.ParamsW.dwLanguageId := GetUserDefaultLangID;\r\n MessageBoxIndirectW(Params.ParamsW);\r\n end\r\n else\r\n begin\r\n Params.ParamsA.hInstance := hInstance;\r\n Params.ParamsA.cbSize := SizeOf(TMsgBoxParamsA);\r\n Params.ParamsA.hwndOwner := Handle;\r\n Params.ParamsA.lpszText := PAnsiChar(AnsiString(Msg));\r\n Params.ParamsA.lpszCaption := PAnsiChar(AnsiString(Caption));\r\n Params.ParamsA.dwStyle := Flags;\r\n if FindIcon(hInstance, IcoName) then\r\n begin\r\n Params.ParamsA.dwStyle := Params.ParamsA.dwStyle or MB_USERICON;\r\n Params.ParamsA.lpszIcon := PAnsiChar(AnsiString(IcoName));\r\n end\r\n else\r\n Params.ParamsA.dwStyle := Params.ParamsA.dwStyle or MB_ICONINFORMATION;\r\n Params.ParamsA.dwContextHelpId := 0;\r\n Params.ParamsA.lpfnMsgBoxCallback := nil;\r\n Params.ParamsA.dwLanguageId := GetUserDefaultLangID;\r\n MessageBoxIndirectA(Params.ParamsA);\r\n end;\r\nend;\r\n\r\nprocedure LoadIcoToImage(ALarge, ASmall: ImgList.TCustomImageList; const NameRes: string);\r\nvar\r\n Ico: TIcon;\r\nbegin\r\n Ico := TIcon.Create;\r\n if ALarge <> nil then\r\n begin\r\n Ico.Handle := LoadImage(HInstance, PChar(NameRes), IMAGE_ICON, 32, 32, 0);\r\n ALarge.AddIcon(Ico);\r\n end;\r\n if ASmall <> nil then\r\n begin\r\n Ico.Handle := LoadImage(HInstance, PChar(NameRes), IMAGE_ICON, 16, 16, 0);\r\n ASmall.AddIcon(Ico);\r\n end;\r\n Ico.Free;\r\nend;\r\n\r\nfunction DualInputQuery(const ACaption, Prompt1, Prompt2: string;\r\n var AValue1, AValue2: string; PasswordChar: Char = #0): Boolean;\r\nvar\r\n AForm: TForm;\r\n ALabel1, ALabel2: TLabel;\r\n AEdit1, AEdit2: TEdit;\r\n ASize, I: Integer;\r\nbegin\r\n Result := False;\r\n AForm := CreateMessageDialog(Prompt1, mtCustom, [mbOK, mbCancel]);\r\n ASize := 0;\r\n if AForm <> nil then\r\n try\r\n AForm.Caption := ACaption;\r\n ALabel1 := AForm.FindComponent('Message') as TLabel;\r\n for I := 0 to AForm.ControlCount - 1 do\r\n if AForm.Controls[I] is TButton then\r\n TButton(AForm.Controls[I]).Anchors := [akRight, akBottom];\r\n if ALabel1 <> nil then\r\n begin\r\n AEdit1 := TEdit.Create(AForm);\r\n AEdit1.Left := ALabel1.Left;\r\n AEdit1.Width := AForm.ClientWidth - AEdit1.Left * 2;\r\n AEdit1.Top := ALabel1.Top + ALabel1.Height + 2;\r\n AEdit1.Parent := AForm;\r\n AEdit1.Anchors := [akLeft, akTop, akRight];\r\n AEdit1.Text := AValue1;\r\n ALabel1.Caption := Prompt1;\r\n ALabel1.FocusControl := AEdit1;\r\n Inc(ASize, AEdit1.Height + 2);\r\n\r\n ALabel2 := TLabel.Create(AForm);\r\n ALabel2.Left := ALabel1.Left;\r\n ALabel2.Top := AEdit1.Top + AEdit1.Height + 7;\r\n ALabel2.Caption := Prompt2;\r\n ALabel2.Parent := AForm;\r\n Inc(ASize, ALabel2.Height + 7);\r\n\r\n AEdit2 := TEdit.Create(AForm);\r\n AEdit2.Left := ALabel1.Left;\r\n AEdit2.Width := AForm.ClientWidth - AEdit2.Left * 2;\r\n AEdit2.Top := ALabel2.Top + ALabel2.Height + 2;\r\n AEdit2.Parent := AForm;\r\n AEdit2.Anchors := [akLeft, akTop, akRight];\r\n AEdit2.Text := AValue1;\r\n if PasswordChar <> #0 then\r\n AEdit2.PasswordChar := PasswordChar;\r\n ALabel2.FocusControl := AEdit2;\r\n\r\n Inc(ASize, AEdit2.Height + 8);\r\n AForm.ClientHeight := AForm.ClientHeight + ASize;\r\n AForm.ClientWidth := 320;\r\n AForm.ActiveControl := AEdit1;\r\n Result := AForm.ShowModal = mrOk;\r\n if Result then\r\n begin\r\n AValue1 := AEdit1.Text;\r\n AValue2 := AEdit2.Text;\r\n end;\r\n end;\r\n finally\r\n AForm.Free;\r\n end;\r\nend;\r\n\r\nfunction InputQueryPassword(const ACaption, APrompt: string; PasswordChar: Char; var Value: string): Boolean;\r\nvar\r\n AForm: TForm;\r\n ALabel: TLabel;\r\n AEdit: TEdit;\r\n ASize: Integer;\r\nbegin\r\n Result := False;\r\n AForm := CreateMessageDialog(APrompt, mtCustom, [mbOK, mbCancel]);\r\n if AForm <> nil then\r\n try\r\n AForm.Caption := ACaption;\r\n ALabel := AForm.FindComponent('Message') as TLabel;\r\n for ASize := 0 to AForm.ControlCount - 1 do\r\n if AForm.Controls[ASize] is TButton then\r\n TButton(AForm.Controls[ASize]).Anchors := [akRight, akBottom];\r\n ASize := 0;\r\n if ALabel <> nil then\r\n begin\r\n AEdit := TEdit.Create(AForm);\r\n AEdit.Left := ALabel.Left;\r\n AEdit.Width := AForm.ClientWidth - AEdit.Left * 2;\r\n AEdit.Top := ALabel.Top + ALabel.Height + 2;\r\n AEdit.Parent := AForm;\r\n AEdit.Anchors := [akLeft, akTop, akRight];\r\n AEdit.Text := Value;\r\n AEdit.PasswordChar := PasswordChar;\r\n ALabel.Caption := APrompt;\r\n ALabel.FocusControl := AEdit;\r\n Inc(ASize, AEdit.Height + 2);\r\n\r\n AForm.ClientHeight := AForm.ClientHeight + ASize;\r\n AForm.ClientWidth := 320;\r\n AForm.ActiveControl := AEdit;\r\n Result := AForm.ShowModal = mrOk;\r\n if Result then\r\n Value := AEdit.Text;\r\n end;\r\n finally\r\n AForm.Free;\r\n end;\r\nend;\r\n\r\n\r\nprocedure CenterHor(Parent: TControl; MinLeft: Integer; Controls: array of TControl);\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := Low(Controls) to High(Controls) do\r\n Controls[I].Left := Max(MinLeft, (Parent.Width - Controls[I].Width) div 2);\r\nend;\r\n\r\nprocedure EnableControls(Control: TWinControl; const Enable: Boolean);\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := 0 to Control.ControlCount - 1 do\r\n Control.Controls[I].Enabled := Enable;\r\nend;\r\n\r\nprocedure EnableMenuItems(MenuItem: TMenuItem; const Tag: Integer; const Enable: Boolean);\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := 0 to MenuItem.Count - 1 do\r\n if MenuItem[I].Tag <> Tag then\r\n MenuItem[I].Enabled := Enable;\r\nend;\r\n\r\nprocedure ExpandWidth(Parent: TControl; MinWidth: Integer; Controls: array of TControl);\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := Low(Controls) to High(Controls) do\r\n Controls[I].Width := Max(MinWidth, Parent.ClientWidth - 2 * Controls[I].Left);\r\nend;\r\n\r\nfunction PanelBorder(Panel: TCustomPanel): Integer;\r\nbegin\r\n Result := TPanel(Panel).BorderWidth;\r\n if TPanel(Panel).BevelOuter <> bvNone then\r\n Inc(Result, TPanel(Panel).BevelWidth);\r\n if TPanel(Panel).BevelInner <> bvNone then\r\n Inc(Result, TPanel(Panel).BevelWidth);\r\nend;\r\n\r\nfunction Pixels(Control: TControl; APixels: Integer): Integer;\r\nvar\r\n Form: TForm;\r\nbegin\r\n Result := APixels;\r\n if Control is TForm then\r\n Form := TForm(Control)\r\n else\r\n Form := TForm(GetParentForm(Control));\r\n if Form.Scaled then\r\n Result := Result * Form.PixelsPerInch div 96;\r\nend;\r\n\r\nprocedure ShowMenu(Form: TForm; MenuAni: TMenuAnimation);\r\nvar\r\n I: Integer;\r\n H: Integer;\r\n W: Integer;\r\nbegin\r\n case MenuAni of\r\n maNone:\r\n Form.Show;\r\n maRandom:\r\n ;\r\n maUnfold:\r\n begin\r\n H := Form.Height;\r\n Form.Height := 0;\r\n Form.Show;\r\n for I := 0 to H div 10 do\r\n if Form.Height < H then\r\n Form.Height := Form.Height + 10;\r\n end;\r\n maSlide:\r\n begin\r\n H := Form.Height;\r\n W := Form.Width;\r\n Form.Height := 0;\r\n Form.Width := 0;\r\n Form.Show;\r\n for I := 0 to Max(H div 5, W div 5) do\r\n begin\r\n if Form.Height < H then\r\n Form.Height := Form.Height + 5;\r\n if Form.Width < W then\r\n Form.Width := Form.Width + 5;\r\n end;\r\n // CS_SAVEBITS\r\n end;\r\n end;\r\nend;\r\n\r\n{$IFDEF MSWINDOWS}\r\n\r\nfunction TargetFileName(const FileName: TFileName): TFileName;\r\nbegin\r\n Result := FileName;\r\n if SameFileName(ExtractFileExt(FileName), '.lnk') then\r\n if ResolveLink(GetAppHandle, FileName, Result) <> 0 then\r\n raise EJVCLException.CreateResFmt(@RsECantGetShortCut, [FileName]);\r\nend;\r\n\r\nfunction ResolveLink(const HWND: THandle; const LinkFile: TFileName;\r\n var FileName: TFileName): HRESULT;\r\nvar\r\n psl: IShellLink;\r\n WLinkFile: array [0..MAX_PATH] of WideChar;\r\n wfd: TWin32FindData;\r\n ppf: IPersistFile;\r\n wnd: Windows.HWND;\r\nbegin\r\n wnd := HWND;\r\n Pointer(psl) := nil;\r\n Pointer(ppf) := nil;\r\n Result := CoInitialize(nil);\r\n if Succeeded(Result) then\r\n begin\r\n // Get a Pointer to the IShellLink interface.\r\n Result := CoCreateInstance(CLSID_ShellLink, nil,\r\n CLSCTX_INPROC_SERVER, IShellLink, psl);\r\n if Succeeded(Result) then\r\n begin\r\n\r\n // Get a Pointer to the IPersistFile interface.\r\n Result := psl.QueryInterface(IPersistFile, ppf);\r\n if Succeeded(Result) then\r\n begin\r\n StringToWideChar(LinkFile, WLinkFile, SizeOf(WLinkFile) - 1);\r\n // Load the shortcut.\r\n Result := ppf.Load(WLinkFile, STGM_READ);\r\n if Succeeded(Result) then\r\n begin\r\n // Resolve the link.\r\n Result := psl.Resolve(wnd, SLR_ANY_MATCH);\r\n if Succeeded(Result) then\r\n begin\r\n // Get the path to the link target.\r\n SetLength(FileName, MAX_PATH);\r\n Result := psl.GetPath(PChar(FileName), MAX_PATH, wfd,\r\n SLGP_UNCPRIORITY);\r\n if not Succeeded(Result) then\r\n Exit;\r\n SetLength(FileName, Length(PChar(FileName)));\r\n end;\r\n end;\r\n // Release the Pointer to the IPersistFile interface.\r\n ppf._Release;\r\n end;\r\n // Release the Pointer to the IShellLink interface.\r\n psl._Release;\r\n end;\r\n CoUninitialize;\r\n end;\r\n Pointer(psl) := nil;\r\n Pointer(ppf) := nil;\r\nend;\r\n\r\n{$ENDIF MSWINDOWS}\r\n\r\nvar\r\n ProcList: TList = nil;\r\n\r\ntype\r\n TJvProcItem = class(TObject)\r\n private\r\n FProcObj: TProcObj;\r\n public\r\n constructor Create(AProcObj: TProcObj);\r\n end;\r\n\r\nconstructor TJvProcItem.Create(AProcObj: TProcObj);\r\nbegin\r\n inherited Create;\r\n FProcObj := AProcObj;\r\nend;\r\n\r\nprocedure TmrProc(hwnd: THandle; uMsg: Integer; idEvent: Integer; dwTime: Integer); stdcall;\r\nvar\r\n Pr: TProcObj;\r\nbegin\r\n if ProcList[idEvent] <> nil then\r\n begin\r\n Pr := TJvProcItem(ProcList[idEvent]).FProcObj;\r\n TJvProcItem(ProcList[idEvent]).Free;\r\n end\r\n else\r\n Pr := nil;\r\n ProcList.Delete(idEvent);\r\n KillTimer(hwnd, idEvent);\r\n if ProcList.Count <= 0 then\r\n begin\r\n ProcList.Free;\r\n ProcList := nil;\r\n end;\r\n if Assigned(Pr) then\r\n Pr;\r\nend;\r\n\r\nprocedure ExecAfterPause(Proc: TProcObj; Pause: Integer);\r\nvar\r\n Num: Integer;\r\n I: Integer;\r\nbegin\r\n if ProcList = nil then\r\n ProcList := TList.Create;\r\n Num := -1;\r\n for I := 0 to ProcList.Count - 1 do\r\n if @TJvProcItem(ProcList[I]).FProcObj = @Proc then\r\n begin\r\n Num := I;\r\n Break;\r\n end;\r\n if Num <> -1 then\r\n KillTimer(GetAppHandle, Num)\r\n else\r\n Num := ProcList.Add(TJvProcItem.Create(Proc));\r\n SetTimer(GetAppHandle, Num, Pause, @TmrProc);\r\nend;\r\n\r\n{ end JvUtils }\r\n\r\n{ begin JvApputils }\r\n\r\nfunction GetFirstParentForm(Control: TControl): TCustomForm;\r\nbegin\r\n while not (Control is TCustomForm) and (Control.Parent <> nil) do\r\n Control := Control.Parent;\r\n if Control is TCustomForm then\r\n Result := TCustomForm(Control) else\r\n Result := nil;\r\nend;\r\n\r\nfunction GetDefaultSection(Component: TComponent): string;\r\nvar\r\n F: TCustomForm;\r\n Owner: TComponent;\r\nbegin\r\n if Component <> nil then\r\n begin\r\n if Component is TCustomForm then\r\n Result := Component.ClassName\r\n else\r\n begin\r\n Result := Component.Name;\r\n if Component is TControl then\r\n begin\r\n // GetParentForm will not stop at the first TCustomForm it finds.\r\n // Starting with Delphi 2005, we can pass False as the second parameter\r\n // to stop at the FIRST parent that is a TCustomForm, but this is not\r\n // available in earlier versions of Delphi. Hence the creation and\r\n // use of GetFirstParentForm.\r\n // This is required to fix Mantis 3785. Indeed with GetParentForm, the\r\n // returned form would be the top most form.\r\n // Say, you have a control in Form2, with an instance of Form2 docked\r\n // in Form1. When loading, F would Form1, because the parent chain\r\n // is completely set. But when destroying, the parent chain would be\r\n // already broken, and F would then be Form2, thus returning a different\r\n // section name than the one returned when loading.\r\n F := GetFirstParentForm(TControl(Component));\r\n if F <> nil then\r\n Result := F.ClassName + Result\r\n else\r\n begin\r\n if TControl(Component).Parent <> nil then\r\n Result := TControl(Component).Parent.Name + Result;\r\n end;\r\n end\r\n else\r\n begin\r\n Owner := Component.Owner;\r\n if Owner is TForm then\r\n Result := Format('%s.%s', [Owner.ClassName, Result]);\r\n end;\r\n end;\r\n end\r\n else\r\n Result := '';\r\nend;\r\n\r\nfunction GetDefaultIniName: string;\r\nbegin\r\n if Assigned(OnGetDefaultIniName) then\r\n Result := OnGetDefaultIniName\r\n else\r\n {$IFDEF UNIX}\r\n Result := GetEnvironmentVariable('HOME') + PathDelim +\r\n '.' + ExtractFileName(Application.ExeName);\r\n {$ENDIF UNIX}\r\n {$IFDEF MSWINDOWS}\r\n Result := ExtractFileName(ChangeFileExt(Application.ExeName, '.ini'));\r\n {$ENDIF MSWINDOWS}\r\nend;\r\n\r\nfunction GetDefaultIniRegKey: string;\r\nbegin\r\n if RegUseAppTitle and (Application.Title <> '') then\r\n Result := Application.Title\r\n else\r\n Result := ExtractFileName(ChangeFileExt(Application.ExeName, ''));\r\n if DefCompanyName <> '' then\r\n Result := DefCompanyName + '\\' + Result;\r\n Result := 'Software\\' + Result;\r\nend;\r\n\r\nfunction FindForm(FormClass: TFormClass): TForm;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := nil;\r\n for I := 0 to Screen.FormCount - 1 do\r\n begin\r\n if Screen.Forms[I] is FormClass then\r\n begin\r\n Result := Screen.Forms[I];\r\n Break;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction InternalFindShowForm(FormClass: TFormClass;\r\n const Caption: string; Restore: Boolean): TForm;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := nil;\r\n for I := 0 to Screen.FormCount - 1 do\r\n begin\r\n if Screen.Forms[I] is FormClass then\r\n if (Caption = '') or (Caption = Screen.Forms[I].Caption) then\r\n begin\r\n Result := Screen.Forms[I];\r\n Break;\r\n end;\r\n end;\r\n if Result = nil then\r\n begin\r\n Application.CreateForm(FormClass, Result);\r\n if Caption <> '' then\r\n Result.Caption := Caption;\r\n end;\r\n if Restore and (Result.WindowState = wsMinimized) then\r\n Result.WindowState := wsNormal;\r\n Result.Show;\r\nend;\r\n\r\nfunction FindShowForm(FormClass: TFormClass; const Caption: string): TForm;\r\nbegin\r\n Result := InternalFindShowForm(FormClass, Caption, True);\r\nend;\r\n\r\nfunction ShowDialog(FormClass: TFormClass): Boolean;\r\nvar\r\n Dlg: TForm;\r\nbegin\r\n Application.CreateForm(FormClass, Dlg);\r\n try\r\n Result := Dlg.ShowModal in [mrOk, mrYes];\r\n finally\r\n Dlg.Free;\r\n end;\r\nend;\r\n\r\nfunction InstantiateForm(FormClass: TFormClass; var Reference): TForm;\r\nbegin\r\n if TForm(Reference) = nil then\r\n Application.CreateForm(FormClass, Reference);\r\n Result := TForm(Reference);\r\nend;\r\n\r\n// (rom) use StrStringToEscaped, StrEscapedToString from JclStrings.pas\r\n\r\nfunction StrToIniStr(const Str: string): string;\r\nvar\r\n N: Integer;\r\nbegin\r\n Result := Str;\r\n repeat\r\n N := Pos(CrLf, Result);\r\n if N > 0 then\r\n Result := Copy(Result, 1, N - 1) + '\\n' + Copy(Result, N + 2, Length(Result));\r\n until N = 0;\r\n repeat\r\n N := Pos(#10#13, Result);\r\n if N > 0 then\r\n Result := Copy(Result, 1, N - 1) + '\\n' + Copy(Result, N + 2, Length(Result));\r\n until N = 0;\r\nend;\r\n\r\nfunction IniStrToStr(const Str: string): string;\r\nvar\r\n N: Integer;\r\nbegin\r\n Result := Str;\r\n repeat\r\n N := Pos('\\n', Result);\r\n if N > 0 then\r\n Result := Copy(Result, 1, N - 1) + CrLf + Copy(Result, N + 2, Length(Result));\r\n until N = 0;\r\nend;\r\n\r\n{ The following strings should not be localized }\r\nconst\r\n siFlags = 'Flags';\r\n siShowCmd = 'ShowCmd';\r\n siMinMaxPos = 'MinMaxPos';\r\n siNormPos = 'NormPos';\r\n siPixels = 'PixelsPerInch';\r\n siMDIChild = 'MDI Children';\r\n siListCount = 'Count';\r\n siItem = 'Item%d';\r\n\r\n{$HINTS OFF}\r\ntype\r\n TComponentAccessProtected = class(TComponent);\r\n{$HINTS ON}\r\n\r\nfunction CrtResString: string;\r\nbegin\r\n// Result := Format('(%dx%d)', [GetSystemMetrics(SM_CXSCREEN),\r\n// GetSystemMetrics(SM_CYSCREEN)]);\r\n\r\n//! New Resolution Identifier, because old method did not work\r\n// properly for Multi-screen systems (returned only width/height of current screen)\r\n Result := Format('(%dx%d)', [Screen.DesktopWidth, Screen.DesktopHeight]);\r\nend;\r\n\r\nfunction ReadPosStr(AppStorage: TJvCustomAppStorage; const Path: string): string;\r\nbegin\r\n if AppStorage.ValueStored(Path + CrtResString) then\r\n Result := AppStorage.ReadString(Path + CrtResString)\r\n else\r\n Result := AppStorage.ReadString(Path);\r\nend;\r\n\r\nprocedure WritePosStr(AppStorage: TJvCustomAppStorage; const Path, Value: string);\r\nbegin\r\n AppStorage.WriteString(Path + CrtResString, Value);\r\n AppStorage.WriteString(Path, Value);\r\nend;\r\n\r\nprocedure InternalSaveMDIChildren(MainForm: TForm;\r\n const AppStorage: TJvCustomAppStorage; const StorePath: string);\r\nvar\r\n I: Integer;\r\nbegin\r\n if (MainForm = nil) or (MainForm.FormStyle <> fsMDIForm) then\r\n raise EInvalidOperation.CreateRes(@SNoMDIForm);\r\n AppStorage.BeginUpdate;\r\n try\r\n AppStorage.DeleteSubTree(AppStorage.ConcatPaths([StorePath, siMDIChild]));\r\n if MainForm.MDIChildCount > 0 then\r\n begin\r\n AppStorage.WriteInteger(AppStorage.ConcatPaths([StorePath, siMDIChild,\r\n siListCount]), MainForm.MDIChildCount);\r\n for I := 0 to MainForm.MDIChildCount - 1 do\r\n AppStorage.WriteString(AppStorage.ConcatPaths([StorePath, siMDIChild,\r\n Format(siItem, [I])]), MainForm.MDIChildren[I].ClassName);\r\n end;\r\n finally\r\n AppStorage.EndUpdate;\r\n end;\r\nend;\r\n\r\nprocedure InternalRestoreMDIChildren(MainForm: TForm;\r\n const AppStorage: TJvCustomAppStorage; const StorePath: string);\r\nvar\r\n I: Integer;\r\n Count: Integer;\r\n FormClass: TFormClass;\r\nbegin\r\n if (MainForm = nil) or (MainForm.FormStyle <> fsMDIForm) then\r\n raise EInvalidOperation.CreateRes(@SNoMDIForm);\r\n AppStorage.BeginUpdate;\r\n try\r\n StartWait;\r\n try\r\n Count := AppStorage.ReadInteger(AppStorage.ConcatPaths([StorePath, siMDIChild, siListCount]), 0);\r\n if Count > 0 then\r\n begin\r\n for I := Count - 1 downto 0 do\r\n begin\r\n FormClass :=\r\n TFormClass(GetClass(AppStorage.ReadString(AppStorage.ConcatPaths([StorePath,\r\n siMDIChild, Format(siItem, [I])]), '')));\r\n if FormClass <> nil then\r\n InternalFindShowForm(FormClass, '', False);\r\n end;\r\n end;\r\n finally\r\n StopWait;\r\n end;\r\n finally\r\n AppStorage.EndUpdate;\r\n end;\r\nend;\r\n\r\nprocedure SaveMDIChildren(MainForm: TForm; const AppStorage: TJvCustomAppStorage);\r\nbegin\r\n InternalSaveMDIChildren(MainForm, AppStorage, '');\r\nend;\r\n\r\nprocedure RestoreMDIChildren(MainForm: TForm; const AppStorage: TJvCustomAppStorage);\r\nbegin\r\n InternalRestoreMDIChildren(MainForm, AppStorage, '');\r\nend;\r\n\r\nprocedure InternalSaveFormPlacement(Form: TForm; const AppStorage: TJvCustomAppStorage;\r\n const StorePath: string; Options: TPlacementOptions = [fpState, fpSize, fpLocation]);\r\nvar\r\n Placement: TWindowPlacement;\r\nbegin\r\n if Options = [fpActiveControl] then\r\n Exit;\r\n AppStorage.BeginUpdate;\r\n try\r\n Placement.Length := SizeOf(TWindowPlacement);\r\n GetWindowPlacement(Form.Handle, @Placement);\r\n if (Form = Application.MainForm) and AppMinimized then\r\n Placement.ShowCmd := SW_SHOWMINIMIZED;\r\n if (Form.FormStyle = fsMDIChild) and (Form.WindowState = wsMinimized) then\r\n Placement.Flags := Placement.Flags or WPF_SETMINPOSITION;\r\n if fpState in Options then\r\n AppStorage.WriteInteger(AppStorage.ConcatPaths([StorePath, siShowCmd]), Placement.ShowCmd);\r\n if [fpSize, fpLocation] * Options <> [] then\r\n begin\r\n AppStorage.WriteInteger(AppStorage.ConcatPaths([StorePath, siFlags]), Placement.Flags);\r\n AppStorage.WriteInteger(AppStorage.ConcatPaths([StorePath, siPixels]), Screen.PixelsPerInch);\r\n WritePosStr(AppStorage, AppStorage.ConcatPaths([StorePath, siMinMaxPos]), Format('%d,%d,%d,%d',\r\n [Placement.ptMinPosition.X, Placement.ptMinPosition.Y, Placement.ptMaxPosition.X, Placement.ptMaxPosition.Y]));\r\n WritePosStr(AppStorage, AppStorage.ConcatPaths([StorePath, siNormPos]), Format('%d,%d,%d,%d',\r\n [Placement.rcNormalPosition.Left, Placement.rcNormalPosition.Top, Placement.rcNormalPosition.Right,\r\n Placement.rcNormalPosition.Bottom]));\r\n end;\r\n finally\r\n AppStorage.EndUpdate;\r\n end;\r\nend;\r\n\r\nprocedure InternalRestoreFormPlacement(Form: TForm; const AppStorage: TJvCustomAppStorage;\r\n const StorePath: string; Options: TPlacementOptions = [fpState, fpSize, fpLocation]);\r\nconst\r\n Delims = [',', ' '];\r\nvar\r\n PosStr: string;\r\n Placement: TWindowPlacement;\r\n WinState: TWindowState;\r\n DataFound: Boolean;\r\n OriginalShowCmd: UINT;\r\n\r\n procedure ChangePosition(APosition: TPosition);\r\n begin\r\n TComponentAccessProtected(Form).SetDesigning(True);\r\n try\r\n Form.Position := APosition;\r\n finally\r\n TComponentAccessProtected(Form).SetDesigning(False);\r\n end;\r\n end;\r\n\r\n function IsOnAnyMonitor(ARect: TRect) : Boolean;\r\n var\r\n BottomRight : TPoint;\r\n begin\r\n BottomRight := ARect.BottomRight;\r\n Dec(BottomRight.X);\r\n Dec(BottomRight.Y);\r\n Result := (Screen.MonitorFromPoint(ARect.TopLeft, mdNull) <> Nil) and\r\n (Screen.MonitorFromPoint(BottomRight, mdNull) <> Nil);\r\n end;\r\n\r\nbegin\r\n if Options = [fpActiveControl] then\r\n Exit;\r\n AppStorage.BeginUpdate;\r\n try\r\n Placement.Length := SizeOf(TWindowPlacement);\r\n GetWindowPlacement(Form.Handle, @Placement);\r\n OriginalShowCmd := Placement.ShowCmd;\r\n if not IsWindowVisible(Form.Handle) then\r\n Placement.ShowCmd := SW_HIDE;\r\n if [fpSize, fpLocation] * Options <> [] then\r\n begin\r\n DataFound := False;\r\n Placement.Flags := AppStorage.ReadInteger(AppStorage.ConcatPaths([StorePath, siFlags]), Placement.Flags);\r\n PosStr := ReadPosStr(AppStorage, AppStorage.ConcatPaths([StorePath, siMinMaxPos]));\r\n if PosStr <> '' then\r\n begin\r\n DataFound := True;\r\n if fpLocation in Options then\r\n begin\r\n Placement.ptMinPosition.X := StrToIntDef(ExtractWord(1, PosStr, Delims), 0);\r\n Placement.ptMinPosition.Y := StrToIntDef(ExtractWord(2, PosStr, Delims), 0);\r\n end;\r\n if fpSize in Options then\r\n begin\r\n Placement.ptMaxPosition.X := StrToIntDef(ExtractWord(3, PosStr, Delims), 0);\r\n Placement.ptMaxPosition.Y := StrToIntDef(ExtractWord(4, PosStr, Delims), 0);\r\n end;\r\n end;\r\n PosStr := ReadPosStr(AppStorage, AppStorage.ConcatPaths([StorePath, siNormPos]));\r\n if PosStr <> '' then\r\n begin\r\n DataFound := True;\r\n if fpLocation in Options then\r\n begin\r\n Placement.rcNormalPosition.Left := StrToIntDef(ExtractWord(1, PosStr, Delims), Form.Left);\r\n Placement.rcNormalPosition.Top := StrToIntDef(ExtractWord(2, PosStr, Delims), Form.Top);\r\n end\r\n else\r\n begin\r\n Placement.rcNormalPosition.Left := Form.Left;\r\n Placement.rcNormalPosition.Top := Form.Top;\r\n end;\r\n if fpSize in Options then\r\n begin\r\n Placement.rcNormalPosition.Right := Placement.rcNormalPosition.Left +\r\n StrToIntDef(ExtractWord(3, PosStr, Delims), Form.Width)-\r\n StrToIntDef(ExtractWord(1, PosStr, Delims), Form.Left);\r\n Placement.rcNormalPosition.Bottom := Placement.rcNormalPosition.Top +\r\n StrToIntDef(ExtractWord(4, PosStr, Delims), Form.Height)-\r\n StrToIntDef(ExtractWord(2, PosStr, Delims), Form.Top);\r\n end\r\n else\r\n if fpLocation in Options then\r\n begin\r\n Placement.rcNormalPosition.Right := Placement.rcNormalPosition.Left + Form.Width;\r\n Placement.rcNormalPosition.Bottom := Placement.rcNormalPosition.Top + Form.Height;\r\n end;\r\n end;\r\n DataFound := DataFound and (Screen.PixelsPerInch = AppStorage.ReadInteger(\r\n AppStorage.ConcatPaths([StorePath, siPixels]), Screen.PixelsPerInch));\r\n if DataFound then\r\n begin\r\n if (Placement.rcNormalPosition.Right > Placement.rcNormalPosition.Left) and\r\n IsOnAnyMonitor(Placement.rcNormalPosition) then\r\n begin\r\n if not (csDesigning in Form.ComponentState) then\r\n begin\r\n if (fpSize in Options) and (fpLocation in Options) then\r\n ChangePosition(poDesigned)\r\n else\r\n if fpSize in Options then\r\n begin\r\n if Form.Position = poDefault then\r\n ChangePosition(poDefaultPosOnly);\r\n end\r\n else\r\n if fpLocation in Options then // obsolete but better to read\r\n if Form.Position = poDefault then\r\n ChangePosition(poDefaultSizeOnly)\r\n else\r\n if Form.Position <> poDesigned then\r\n ChangePosition(poDesigned);\r\n end;\r\n SetWindowPlacement(Form.Handle, @Placement);\r\n end;\r\n end;\r\n end;\r\n if fpState in Options then\r\n begin\r\n WinState := wsNormal;\r\n { default maximize MDI main form }\r\n if ((Application.MainForm = Form) or\r\n (Application.MainForm = nil)) and ((Form.FormStyle = fsMDIForm) or\r\n ((Form.FormStyle = fsNormal) and (Form.Position = poDefault))) then\r\n WinState := wsMaximized;\r\n Placement.ShowCmd := AppStorage.ReadInteger(AppStorage.ConcatPaths([StorePath, siShowCmd]), OriginalShowCmd);\r\n case Placement.ShowCmd of\r\n SW_SHOWNORMAL, SW_RESTORE, SW_SHOW:\r\n WinState := wsNormal;\r\n SW_MINIMIZE, SW_SHOWMINIMIZED, SW_SHOWMINNOACTIVE:\r\n WinState := wsMinimized;\r\n SW_MAXIMIZE:\r\n WinState := wsMaximized;\r\n end;\r\n if (WinState = wsMinimized) and ((Form = Application.MainForm) or\r\n (Application.MainForm = nil)) then\r\n begin\r\n TWindowState(Pointer(@Form.WindowState)^) := wsNormal;\r\n PostMessage(Application.Handle, WM_SYSCOMMAND, SC_MINIMIZE, 0);\r\n Exit;\r\n end;\r\n if Form.FormStyle in [fsMDIChild, fsMDIForm] then\r\n TWindowState(Pointer(@Form.WindowState)^) := WinState\r\n else\r\n Form.WindowState := WinState;\r\n end;\r\n Form.Update;\r\n finally\r\n AppStorage.EndUpdate;\r\n end;\r\nend;\r\n\r\nprocedure InternalSaveGridLayout(Grid: TCustomGrid;\r\n const AppStorage: TJvCustomAppStorage; const StorePath: string);\r\nvar\r\n I: Longint;\r\nbegin\r\n AppStorage.BeginUpdate;\r\n try\r\n for I := 0 to TDrawGrid(Grid).ColCount - 1 do\r\n AppStorage.WriteInteger(AppStorage.ConcatPaths([StorePath, Format(siItem, [I])]),\r\n TDrawGrid(Grid).ColWidths[I]);\r\n finally\r\n AppStorage.EndUpdate;\r\n end;\r\nend;\r\n\r\nprocedure InternalRestoreGridLayout(Grid: TCustomGrid;\r\n const AppStorage: TJvCustomAppStorage; const StorePath: string);\r\nvar\r\n I: Longint;\r\nbegin\r\n AppStorage.BeginUpdate;\r\n try\r\n for I := 0 to TDrawGrid(Grid).ColCount - 1 do\r\n TDrawGrid(Grid).ColWidths[I] :=\r\n AppStorage.ReadInteger(AppStorage.ConcatPaths([StorePath,\r\n Format(siItem, [I])]), TDrawGrid(Grid).ColWidths[I]);\r\n finally\r\n AppStorage.EndUpdate;\r\n end;\r\nend;\r\n\r\nprocedure RestoreGridLayout(Grid: TCustomGrid; const AppStorage: TJvCustomAppStorage);\r\nbegin\r\n InternalRestoreGridLayout(Grid, AppStorage, GetDefaultSection(Grid));\r\nend;\r\n\r\nprocedure SaveGridLayout(Grid: TCustomGrid; const AppStorage: TJvCustomAppStorage);\r\nbegin\r\n InternalSaveGridLayout(Grid, AppStorage, GetDefaultSection(Grid));\r\nend;\r\n\r\nprocedure SaveFormPlacement(Form: TForm; const AppStorage: TJvCustomAppStorage; Options: TPlacementOptions);\r\nbegin\r\n InternalSaveFormPlacement(Form, AppStorage, GetDefaultSection(Form), Options);\r\nend;\r\n\r\nprocedure RestoreFormPlacement(Form: TForm; const AppStorage: TJvCustomAppStorage; Options: TPlacementOptions);\r\nbegin\r\n InternalRestoreFormPlacement(Form, AppStorage, GetDefaultSection(Form), Options);\r\nend;\r\n\r\n\r\nprocedure AppBroadcast(Msg: UINT; wParam: WPARAM; lParam: LPARAM);\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := 0 to Screen.FormCount - 1 do\r\n SendMessage(Screen.Forms[I].Handle, Msg, wParam, lParam);\r\nend;\r\n\r\nprocedure AppTaskbarIcons(AppOnly: Boolean);\r\nvar\r\n Style: Longint;\r\nbegin\r\n Style := GetWindowLong(Application.Handle, GWL_STYLE);\r\n if AppOnly then\r\n Style := Style or WS_CAPTION\r\n else\r\n Style := Style and not WS_CAPTION;\r\n SetWindowLong(Application.Handle, GWL_STYLE, Style);\r\n if AppOnly then\r\n SwitchToWindow(Application.Handle, False);\r\nend;\r\n\r\n{ end JvAppUtils }\r\n{ begin JvGraph }\r\n// (rom) moved here to make JvMaxMin obsolete\r\n\r\nfunction MaxFloat(const Values: array of Extended): Extended;\r\nvar\r\n I: Cardinal;\r\nbegin\r\n Result := Values[Low(Values)];\r\n for I := Low(Values) + 1 to High(Values) do\r\n if Values[I] > Result then\r\n Result := Values[I];\r\nend;\r\n\r\nprocedure InvalidBitmap;\r\nbegin\r\n raise EInvalidGraphic.CreateRes(@SInvalidBitmap);\r\nend;\r\n\r\nfunction WidthBytes(I: Longint): Longint;\r\nbegin\r\n Result := ((I + 31) div 32) * 4;\r\nend;\r\n\r\nfunction PixelFormatToColors(PixelFormat: TPixelFormat): Integer;\r\nbegin\r\n case PixelFormat of\r\n pf1bit:\r\n Result := 2;\r\n pf4bit:\r\n Result := 16;\r\n pf8bit:\r\n Result := 256;\r\n else\r\n Result := 0;\r\n end;\r\nend;\r\n\r\n\r\n\r\nfunction ScreenPixelFormat: TPixelFormat;\r\nvar\r\n DC: HDC;\r\nbegin\r\n DC := CreateIC('DISPLAY', nil, nil, nil);\r\n try\r\n case GetDeviceCaps(DC, PLANES) * GetDeviceCaps(DC, BITSPIXEL) of\r\n 1:\r\n Result := pf1bit;\r\n 4:\r\n Result := pf4bit;\r\n 8:\r\n Result := pf8bit;\r\n 15:\r\n Result := pf15bit;\r\n 16:\r\n Result := pf16bit;\r\n 24:\r\n Result := pf24bit;\r\n 32:\r\n Result := pf32bit;\r\n else\r\n Result := pfDevice;\r\n end;\r\n finally\r\n DeleteDC(DC);\r\n end;\r\nend;\r\n\r\nfunction ScreenColorCount: Integer;\r\nbegin\r\n Result := PixelFormatToColors(ScreenPixelFormat);\r\nend;\r\n\r\n\r\nfunction GetWorkareaRect(Monitor: TMonitor): TRect;\r\nvar\r\n MonInfo: TMonitorInfo;\r\nbegin\r\n MonInfo.cbSize := SizeOf(MonInfo);\r\n GetMonitorInfo(Monitor.Handle, @MonInfo);\r\n Result := MonInfo.rcWork;\r\nend;\r\n\r\nfunction FindMonitor(Handle: HMONITOR): TMonitor;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := nil;\r\n for I := 0 to Screen.MonitorCount - 1 do\r\n if Screen.Monitors[I].Handle = Handle then\r\n begin\r\n Result := Screen.Monitors[I];\r\n Break;\r\n end;\r\nend;\r\n\r\n{ Quantizing }\r\n{ Quantizing procedures based on free C source code written by\r\n Joe C. Oliphant, CompuServe 71742, 1451, joe_oliphant att csufresno dott edu }\r\n\r\nconst\r\n MAX_COLORS = 4096;\r\n\r\ntype\r\n TTriple = array [0..2] of Byte;\r\n\r\n PQColor = ^TQColor;\r\n TQColor = record\r\n RGB: TTriple;\r\n NewColorIndex: Byte;\r\n Count: Longint;\r\n PNext: PQColor;\r\n end;\r\n\r\n PQColorArray = ^TQColorArray;\r\n TQColorArray = array [0..MAX_COLORS - 1] of TQColor;\r\n\r\n PQColorList = ^TQColorList;\r\n TQColorList = array [0..{$IFDEF RTL230_UP}Maxint div 16{$ELSE}MaxListSize{$ENDIF RTL230_UP} - 1] of PQColor;\r\n\r\n PNewColor = ^TNewColor;\r\n TNewColor = record\r\n RGBMin: TTriple;\r\n RGBWidth: TTriple;\r\n NumEntries: Longint;\r\n Count: Longint;\r\n QuantizedColors: PQColor;\r\n end;\r\n\r\n PNewColorArray = ^TNewColorArray;\r\n TNewColorArray = array [Byte] of TNewColor;\r\n\r\nprocedure PInsert(ColorList: PQColorList;\r\n Number: Integer; SortRGBAxis: Integer);\r\nvar\r\n Q1, Q2: PQColor;\r\n I, J: Integer;\r\n Temp: PQColor;\r\nbegin\r\n for I := 1 to Number - 1 do\r\n begin\r\n Temp := ColorList[I];\r\n J := I - 1;\r\n while J >= 0 do\r\n begin\r\n Q1 := Temp;\r\n Q2 := ColorList[J];\r\n if Q1.RGB[SortRGBAxis] - Q2.RGB[SortRGBAxis] > 0 then\r\n Break;\r\n ColorList[J + 1] := ColorList[J];\r\n Dec(J);\r\n end;\r\n ColorList[J + 1] := Temp;\r\n end;\r\nend;\r\n\r\nprocedure PSort(ColorList: PQColorList;\r\n Number: Integer; SortRGBAxis: Integer);\r\nvar\r\n Q1, Q2: PQColor;\r\n I, J, N, Nr: Integer;\r\n Temp, Part: PQColor;\r\nbegin\r\n if Number < 8 then\r\n begin\r\n PInsert(ColorList, Number, SortRGBAxis);\r\n Exit;\r\n end;\r\n Part := ColorList[Number div 2];\r\n I := -1;\r\n J := Number;\r\n repeat\r\n repeat\r\n Inc(I);\r\n Q1 := ColorList[I];\r\n Q2 := Part;\r\n N := Q1.RGB[SortRGBAxis] - Q2.RGB[SortRGBAxis];\r\n until N >= 0;\r\n repeat\r\n Dec(J);\r\n Q1 := ColorList[J];\r\n Q2 := Part;\r\n N := Q1.RGB[SortRGBAxis] - Q2.RGB[SortRGBAxis];\r\n until N <= 0;\r\n if I >= J then\r\n Break;\r\n Temp := ColorList[I];\r\n ColorList[I] := ColorList[J];\r\n ColorList[J] := Temp;\r\n until False;\r\n Nr := Number - I;\r\n if I < Number div 2 then\r\n begin\r\n PSort(ColorList, I, SortRGBAxis);\r\n PSort(PQColorList(@ColorList[I]), Nr, SortRGBAxis);\r\n end\r\n else\r\n begin\r\n PSort(PQColorList(@ColorList[I]), Nr, SortRGBAxis);\r\n PSort(ColorList, I, SortRGBAxis);\r\n end;\r\nend;\r\n\r\nfunction DivideMap(NewColorSubdiv: PNewColorArray; ColorMapSize: Integer;\r\n var NewColormapSize: Integer; LPSTR: Pointer): Integer;\r\nvar\r\n I, J: Integer;\r\n MaxSize, Index: Integer;\r\n NumEntries, MinColor, MaxColor: Integer;\r\n Sum, Count: Longint;\r\n QuantizedColor: PQColor;\r\n SortArray: PQColorList;\r\n SortRGBAxis: Integer;\r\nbegin\r\n Index := 0;\r\n SortRGBAxis := 0;\r\n while ColorMapSize > NewColormapSize do\r\n begin\r\n MaxSize := -1;\r\n for I := 0 to NewColormapSize - 1 do\r\n begin\r\n for J := 0 to 2 do\r\n begin\r\n if (NewColorSubdiv[I].RGBWidth[J] > MaxSize) and\r\n (NewColorSubdiv[I].NumEntries > 1) then\r\n begin\r\n MaxSize := NewColorSubdiv[I].RGBWidth[J];\r\n Index := I;\r\n SortRGBAxis := J;\r\n end;\r\n end;\r\n end;\r\n if MaxSize = -1 then\r\n begin\r\n Result := 1;\r\n Exit;\r\n end;\r\n SortArray := PQColorList(LPSTR);\r\n J := 0;\r\n QuantizedColor := NewColorSubdiv[Index].QuantizedColors;\r\n while (J < NewColorSubdiv[Index].NumEntries) and\r\n (QuantizedColor <> nil) do\r\n begin\r\n SortArray[J] := QuantizedColor;\r\n Inc(J);\r\n QuantizedColor := QuantizedColor.PNext;\r\n end;\r\n PSort(SortArray, NewColorSubdiv[Index].NumEntries, SortRGBAxis);\r\n for J := 0 to NewColorSubdiv[Index].NumEntries - 2 do\r\n SortArray[J].PNext := SortArray[J + 1];\r\n SortArray[NewColorSubdiv[Index].NumEntries - 1].PNext := nil;\r\n NewColorSubdiv[Index].QuantizedColors := SortArray[0];\r\n QuantizedColor := SortArray[0];\r\n Sum := NewColorSubdiv[Index].Count div 2 - QuantizedColor.Count;\r\n NumEntries := 1;\r\n Count := QuantizedColor.Count;\r\n Dec(Sum, QuantizedColor.PNext.Count);\r\n while (Sum >= 0) and (QuantizedColor.PNext <> nil) and\r\n (QuantizedColor.PNext.PNext <> nil) do\r\n begin\r\n QuantizedColor := QuantizedColor.PNext;\r\n Inc(NumEntries);\r\n Inc(Count, QuantizedColor.Count);\r\n Dec(Sum, QuantizedColor.PNext.Count);\r\n end;\r\n MaxColor := (QuantizedColor.RGB[SortRGBAxis]) shl 4;\r\n MinColor := (QuantizedColor.PNext.RGB[SortRGBAxis]) shl 4;\r\n NewColorSubdiv[NewColormapSize].QuantizedColors := QuantizedColor.PNext;\r\n QuantizedColor.PNext := nil;\r\n NewColorSubdiv[NewColormapSize].Count := Count;\r\n Dec(NewColorSubdiv[Index].Count, Count);\r\n NewColorSubdiv[NewColormapSize].NumEntries := NewColorSubdiv[Index].NumEntries - NumEntries;\r\n NewColorSubdiv[Index].NumEntries := NumEntries;\r\n for J := 0 to 2 do\r\n begin\r\n NewColorSubdiv[NewColormapSize].RGBMin[J] :=\r\n NewColorSubdiv[Index].RGBMin[J];\r\n NewColorSubdiv[NewColormapSize].RGBWidth[J] :=\r\n NewColorSubdiv[Index].RGBWidth[J];\r\n end;\r\n NewColorSubdiv[NewColormapSize].RGBWidth[SortRGBAxis] :=\r\n NewColorSubdiv[NewColormapSize].RGBMin[SortRGBAxis] +\r\n NewColorSubdiv[NewColormapSize].RGBWidth[SortRGBAxis] -\r\n MinColor;\r\n NewColorSubdiv[NewColormapSize].RGBMin[SortRGBAxis] := MinColor;\r\n NewColorSubdiv[Index].RGBWidth[SortRGBAxis] := MaxColor - NewColorSubdiv[Index].RGBMin[SortRGBAxis];\r\n Inc(NewColormapSize);\r\n end;\r\n Result := 1;\r\nend;\r\n\r\nfunction Quantize(const Bmp: TBitmapInfoHeader; gptr, Data8: Pointer;\r\n var ColorCount: Integer; var OutputColormap: TRGBPalette): Integer;\r\ntype\r\n PWord = ^Word;\r\nvar\r\n P: PByteArray;\r\n LineBuffer, Data: PAnsiChar;\r\n LineWidth: Longint;\r\n TmpLineWidth, NewLineWidth: Longint;\r\n I, J: Longint;\r\n Index: Word;\r\n NewColormapSize, NumOfEntries: Integer;\r\n Mems: Longint;\r\n cRed, cGreen, cBlue: Longint;\r\n LPSTR, Temp, Tmp: PAnsiChar;\r\n NewColorSubdiv: PNewColorArray;\r\n ColorArrayEntries: PQColorArray;\r\n QuantizedColor: PQColor;\r\nbegin\r\n LineWidth := WidthBytes(Longint(Bmp.biWidth) * Bmp.biBitCount);\r\n Mems := (Longint(SizeOf(TQColor)) * (MAX_COLORS)) +\r\n (Longint(SizeOf(TNewColor)) * 256) + LineWidth +\r\n (Longint(SizeOf(PQColor)) * (MAX_COLORS));\r\n LPSTR := AllocMem(Mems);\r\n try\r\n Temp := AllocMem(Longint(Bmp.biWidth) * Longint(Bmp.biHeight) * SizeOf(Word));\r\n try\r\n ColorArrayEntries := PQColorArray(LPSTR);\r\n NewColorSubdiv := PNewColorArray(LPSTR + Longint(SizeOf(TQColor)) * (MAX_COLORS));\r\n LineBuffer := LPSTR + (Longint(SizeOf(TQColor)) * (MAX_COLORS))\r\n +\r\n (Longint(SizeOf(TNewColor)) * 256);\r\n for I := 0 to MAX_COLORS - 1 do\r\n begin\r\n ColorArrayEntries^[I].RGB[0] := I shr 8;\r\n ColorArrayEntries^[I].RGB[1] := (I shr 4) and $0F;\r\n ColorArrayEntries^[I].RGB[2] := I and $0F;\r\n ColorArrayEntries^[I].Count := 0;\r\n end;\r\n Tmp := Temp;\r\n for I := 0 to Bmp.biHeight - 1 do\r\n begin\r\n Move(Pointer(PAnsiChar(gptr) + (Bmp.biHeight - 1 - I) * LineWidth)^, LineBuffer^, LineWidth);\r\n P := PByteArray(LineBuffer);\r\n for J := 0 to Bmp.biWidth - 1 do\r\n begin\r\n Index := (Longint(P^[2] and $F0) shl 4) +\r\n Longint(P^[1] and $F0) + (Longint(P^[0] and $F0) shr 4);\r\n Inc(ColorArrayEntries^[Index].Count);\r\n Inc(PByte(P), 3);\r\n PWord(Tmp)^ := Index;\r\n Inc(Tmp, 2);\r\n end;\r\n end;\r\n for I := 0 to 255 do\r\n begin\r\n NewColorSubdiv^[I].QuantizedColors := nil;\r\n NewColorSubdiv^[I].Count := 0;\r\n NewColorSubdiv^[I].NumEntries := 0;\r\n for J := 0 to 2 do\r\n begin\r\n NewColorSubdiv^[I].RGBMin[J] := 0;\r\n NewColorSubdiv^[I].RGBWidth[J] := 255;\r\n end;\r\n end;\r\n I := 0;\r\n while I < MAX_COLORS do\r\n begin\r\n if ColorArrayEntries^[I].Count > 0 then\r\n Break;\r\n Inc(I);\r\n end;\r\n QuantizedColor := @ColorArrayEntries^[I];\r\n NewColorSubdiv^[0].QuantizedColors := @ColorArrayEntries^[I];\r\n NumOfEntries := 1;\r\n Inc(I);\r\n while I < MAX_COLORS do\r\n begin\r\n if ColorArrayEntries^[I].Count > 0 then\r\n begin\r\n QuantizedColor^.PNext := @ColorArrayEntries^[I];\r\n QuantizedColor := @ColorArrayEntries^[I];\r\n Inc(NumOfEntries);\r\n end;\r\n Inc(I);\r\n end;\r\n QuantizedColor^.PNext := nil;\r\n NewColorSubdiv^[0].NumEntries := NumOfEntries;\r\n NewColorSubdiv^[0].Count := Longint(Bmp.biWidth) * Longint(Bmp.biHeight);\r\n NewColormapSize := 1;\r\n DivideMap(NewColorSubdiv, ColorCount, NewColormapSize,\r\n LPSTR + Longint(SizeOf(TQColor)) * (MAX_COLORS) + Longint(SizeOf(TNewColor)) * 256 + LineWidth);\r\n if NewColormapSize < ColorCount then\r\n begin\r\n for I := NewColormapSize to ColorCount - 1 do\r\n FillChar(OutputColormap[I], SizeOf(TRGBQuad), 0);\r\n end;\r\n for I := 0 to NewColormapSize - 1 do\r\n begin\r\n J := NewColorSubdiv^[I].NumEntries;\r\n if J > 0 then\r\n begin\r\n QuantizedColor := NewColorSubdiv^[I].QuantizedColors;\r\n cRed := 0;\r\n cGreen := 0;\r\n cBlue := 0;\r\n while QuantizedColor <> nil do\r\n begin\r\n QuantizedColor^.NewColorIndex := I;\r\n Inc(cRed, QuantizedColor^.RGB[0]);\r\n Inc(cGreen, QuantizedColor^.RGB[1]);\r\n Inc(cBlue, QuantizedColor^.RGB[2]);\r\n QuantizedColor := QuantizedColor^.PNext;\r\n end;\r\n with OutputColormap[I] do\r\n begin\r\n rgbRed := (Longint(cRed shl 4) or $0F) div J;\r\n rgbGreen := (Longint(cGreen shl 4) or $0F) div J;\r\n rgbBlue := (Longint(cBlue shl 4) or $0F) div J;\r\n rgbReserved := 0;\r\n if (rgbRed <= $10) and (rgbGreen <= $10) and (rgbBlue <= $10) then\r\n FillChar(OutputColormap[I], SizeOf(TRGBQuad), 0); { clBlack }\r\n end;\r\n end;\r\n end;\r\n TmpLineWidth := Longint(Bmp.biWidth) * SizeOf(Word);\r\n NewLineWidth := WidthBytes(Longint(Bmp.biWidth) * 8);\r\n FillChar(Data8^, NewLineWidth * Bmp.biHeight, #0);\r\n for I := 0 to Bmp.biHeight - 1 do\r\n begin\r\n LineBuffer := Temp + (Bmp.biHeight - 1 - I) * TmpLineWidth;\r\n Data := PAnsiChar(Data8) + I * NewLineWidth;\r\n for J := 0 to Bmp.biWidth - 1 do\r\n begin\r\n PByte(Data)^ := ColorArrayEntries^[PWord(LineBuffer)^].NewColorIndex;\r\n Inc(LineBuffer, 2);\r\n Inc(Data);\r\n end;\r\n end;\r\n finally\r\n FreeMem(Temp);\r\n end;\r\n finally\r\n FreeMem(LPSTR);\r\n end;\r\n ColorCount := NewColormapSize;\r\n Result := 0;\r\nend;\r\n\r\n{\r\n Procedures to truncate to lower bits-per-pixel, grayscale, tripel and\r\n histogram conversion based on freeware C source code of GBM package by\r\n Andy Key (nyangau att interalpha dott co dott uk). The home page of GBM\r\n author is at http://www.interalpha.net/customer/nyangau/.\r\n}\r\n\r\n{ Truncate to lower bits per pixel }\r\n\r\ntype\r\n TTruncLine = procedure(Src, Dest: Pointer; CX: Integer);\r\n\r\n { For 6Rx6Gx6B, 7Rx8Gx4B palettes etc. }\r\n\r\nconst\r\n Scale04: array [0..3] of Byte = (0, 85, 170, 255);\r\n Scale06: array [0..5] of Byte = (0, 51, 102, 153, 204, 255);\r\n Scale07: array [0..6] of Byte = (0, 43, 85, 128, 170, 213, 255);\r\n Scale08: array [0..7] of Byte = (0, 36, 73, 109, 146, 182, 219, 255);\r\n\r\n { For 6Rx6Gx6B, 7Rx8Gx4B palettes etc. }\r\n\r\nvar\r\n TruncTablesInitialized: Boolean = False;\r\n TruncIndex04: array [Byte] of Byte;\r\n TruncIndex06: array [Byte] of Byte;\r\n TruncIndex07: array [Byte] of Byte;\r\n TruncIndex08: array [Byte] of Byte;\r\n\r\n { These functions initialises this module }\r\n\r\nprocedure InitTruncTables;\r\n\r\n function NearestIndex(Value: Byte; const Bytes: array of Byte): Byte;\r\n var\r\n B, I: Byte;\r\n Diff, DiffMin: Word;\r\n begin\r\n Result := 0;\r\n B := Bytes[0];\r\n DiffMin := Abs(Value - B);\r\n for I := 1 to High(Bytes) do\r\n begin\r\n B := Bytes[I];\r\n Diff := Abs(Value - B);\r\n if Diff < DiffMin then\r\n begin\r\n DiffMin := Diff;\r\n Result := I;\r\n end;\r\n end;\r\n end;\r\n\r\nvar\r\n I: Integer;\r\nbegin\r\n if not TruncTablesInitialized then\r\n begin\r\n TruncTablesInitialized := True;\r\n // (rom) secured because it is called in initialization section\r\n // (ahuser) moved from initialization section to \"on demand\" initialization\r\n try\r\n { For 7 Red X 8 Green X 4 Blue palettes etc. }\r\n for I := 0 to 255 do\r\n begin\r\n TruncIndex04[I] := NearestIndex(Byte(I), Scale04);\r\n TruncIndex06[I] := NearestIndex(Byte(I), Scale06);\r\n TruncIndex07[I] := NearestIndex(Byte(I), Scale07);\r\n TruncIndex08[I] := NearestIndex(Byte(I), Scale08);\r\n end;\r\n except\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure Trunc(const Header: TBitmapInfoHeader; Src, Dest: Pointer;\r\n DstBitsPerPixel: Integer; TruncLineProc: TTruncLine);\r\nvar\r\n SrcScanline, DstScanline: Longint;\r\n Y: Integer;\r\nbegin\r\n SrcScanline := (Header.biWidth * 3 + 3) and not 3;\r\n DstScanline := ((Header.biWidth * DstBitsPerPixel + 31) div 32) * 4;\r\n for Y := 0 to Header.biHeight - 1 do\r\n TruncLineProc(PAnsiChar(Src) + Y * SrcScanline, PAnsiChar(Dest) + Y * DstScanline, Header.biWidth);\r\nend;\r\n\r\n{ return 6Rx6Gx6B palette\r\n This function makes the palette for the 6 red X 6 green X 6 blue palette.\r\n 216 palette entrys used. Remaining 40 Left blank.\r\n}\r\n\r\nprocedure TruncPal6R6G6B(var Colors: TRGBPalette);\r\nvar\r\n I, R, G, B: Byte;\r\nbegin\r\n FillChar(Colors, SizeOf(TRGBPalette), $80);\r\n I := 0;\r\n for R := 0 to 5 do\r\n for G := 0 to 5 do\r\n for B := 0 to 5 do\r\n begin\r\n Colors[I].rgbRed := Scale06[R];\r\n Colors[I].rgbGreen := Scale06[G];\r\n Colors[I].rgbBlue := Scale06[B];\r\n Colors[I].rgbReserved := 0;\r\n Inc(I);\r\n end;\r\nend;\r\n\r\n{ truncate to 6Rx6Gx6B one line }\r\n\r\nprocedure TruncLine6R6G6B(Src, Dest: Pointer; CX: Integer);\r\nvar\r\n X: Integer;\r\n R, G, B: Byte;\r\nbegin\r\n InitTruncTables;\r\n for X := 0 to CX - 1 do\r\n begin\r\n B := TruncIndex06[Byte(Src^)];\r\n Inc(PByte(Src));\r\n G := TruncIndex06[Byte(Src^)];\r\n Inc(PByte(Src));\r\n R := TruncIndex06[Byte(Src^)];\r\n Inc(PByte(Src), 1);\r\n PByte(Dest)^ := 6 * (6 * R + G) + B;\r\n Inc(PByte(Dest));\r\n end;\r\nend;\r\n\r\n{ truncate to 6Rx6Gx6B }\r\n\r\nprocedure Trunc6R6G6B(const Header: TBitmapInfoHeader;\r\n const Data24, Data8: Pointer);\r\nbegin\r\n Trunc(Header, Data24, Data8, 8, TruncLine6R6G6B);\r\nend;\r\n\r\n{ return 7Rx8Gx4B palette\r\n This function makes the palette for the 7 red X 8 green X 4 blue palette.\r\n 224 palette entrys used. Remaining 32 Left blank.\r\n Colours calculated to match those used by 8514/A PM driver.\r\n}\r\n\r\nprocedure TruncPal7R8G4B(var Colors: TRGBPalette);\r\nvar\r\n I, R, G, B: Byte;\r\nbegin\r\n FillChar(Colors, SizeOf(TRGBPalette), $80);\r\n I := 0;\r\n for R := 0 to 6 do\r\n for G := 0 to 7 do\r\n for B := 0 to 3 do\r\n begin\r\n Colors[I].rgbRed := Scale07[R];\r\n Colors[I].rgbGreen := Scale08[G];\r\n Colors[I].rgbBlue := Scale04[B];\r\n Colors[I].rgbReserved := 0;\r\n Inc(I);\r\n end;\r\nend;\r\n\r\n{ truncate to 7Rx8Gx4B one line }\r\n\r\nprocedure TruncLine7R8G4B(Src, Dest: Pointer; CX: Integer);\r\nvar\r\n X: Integer;\r\n R, G, B: Byte;\r\nbegin\r\n InitTruncTables;\r\n for X := 0 to CX - 1 do\r\n begin\r\n B := TruncIndex04[Byte(Src^)];\r\n Inc(PByte(Src));\r\n G := TruncIndex08[Byte(Src^)];\r\n Inc(PByte(Src));\r\n R := TruncIndex07[Byte(Src^)];\r\n Inc(PByte(Src));\r\n PByte(Dest)^ := 4 * (8 * R + G) + B;\r\n Inc(PByte(Dest));\r\n end;\r\nend;\r\n\r\n{ truncate to 7Rx8Gx4B }\r\n\r\nprocedure Trunc7R8G4B(const Header: TBitmapInfoHeader;\r\n const Data24, Data8: Pointer);\r\nbegin\r\n Trunc(Header, Data24, Data8, 8, TruncLine7R8G4B);\r\nend;\r\n\r\n{ Grayscale support }\r\n\r\nprocedure GrayPal(var Colors: TRGBPalette);\r\nvar\r\n I: Byte;\r\nbegin\r\n FillChar(Colors, SizeOf(TRGBPalette), 0);\r\n for I := 0 to 255 do\r\n FillChar(Colors[I], 3, I);\r\nend;\r\n\r\nprocedure GrayScale(const Header: TBitmapInfoHeader; Data24, Data8: Pointer);\r\nvar\r\n SrcScanline, DstScanline: Longint;\r\n Y, X: Integer;\r\n Src, Dest: PByte;\r\n R, G, B: Byte;\r\nbegin\r\n SrcScanline := (Header.biWidth * 3 + 3) and not 3;\r\n DstScanline := (Header.biWidth + 3) and not 3;\r\n for Y := 0 to Header.biHeight - 1 do\r\n begin\r\n Src := Data24;\r\n Dest := Data8;\r\n for X := 0 to Header.biWidth - 1 do\r\n begin\r\n B := Src^;\r\n Inc(Src);\r\n G := Src^;\r\n Inc(Src);\r\n R := Src^;\r\n Inc(Src);\r\n Dest^ := Byte(Longint(Word(R) * 77 + Word(G) * 150 + Word(B) * 29) shr 8);\r\n Inc(Dest);\r\n end;\r\n Data24 := PAnsiChar(Data24) + SrcScanline;\r\n Data8 := PAnsiChar(Data8) + DstScanline;\r\n end;\r\nend;\r\n\r\n{ Tripel conversion }\r\n\r\nprocedure TripelPal(var Colors: TRGBPalette);\r\nvar\r\n I: Byte;\r\nbegin\r\n FillChar(Colors, SizeOf(TRGBPalette), 0);\r\n for I := 0 to $40 do\r\n begin\r\n Colors[I].rgbRed := I shl 2;\r\n Colors[I + $40].rgbGreen := I shl 2;\r\n Colors[I + $80].rgbBlue := I shl 2;\r\n end;\r\nend;\r\n\r\nprocedure Tripel(const Header: TBitmapInfoHeader; Data24, Data8: Pointer);\r\nvar\r\n SrcScanline, DstScanline: Longint;\r\n Y, X: Integer;\r\n Src, Dest: PByte;\r\n R, G, B: Byte;\r\nbegin\r\n SrcScanline := (Header.biWidth * 3 + 3) and not 3;\r\n DstScanline := (Header.biWidth + 3) and not 3;\r\n for Y := 0 to Header.biHeight - 1 do\r\n begin\r\n Src := Data24;\r\n Dest := Data8;\r\n for X := 0 to Header.biWidth - 1 do\r\n begin\r\n B := Src^;\r\n Inc(Src);\r\n G := Src^;\r\n Inc(Src);\r\n R := Src^;\r\n Inc(Src);\r\n case ((X + Y) mod 3) of\r\n 0: Dest^ := Byte(R shr 2);\r\n 1: Dest^ := Byte($40 + (G shr 2));\r\n 2: Dest^ := Byte($80 + (B shr 2));\r\n end;\r\n Inc(Dest);\r\n end;\r\n Data24 := PAnsiChar(Data24) + SrcScanline;\r\n Data8 := PAnsiChar(Data8) + DstScanline;\r\n end;\r\nend;\r\n\r\n{ Histogram/Frequency-of-use method of color reduction }\r\n\r\nconst\r\n MAX_N_COLS = 2049;\r\n MAX_N_HASH = 5191;\r\n\r\nfunction Hash(R, G, B: Byte): Word;\r\nbegin\r\n Result := Word(Longint(Longint(R + G) * Longint(G + B) * Longint(B + R)) mod MAX_N_HASH);\r\nend;\r\n\r\ntype\r\n PFreqRecord = ^TFreqRecord;\r\n TFreqRecord = record\r\n B: Byte;\r\n G: Byte;\r\n R: Byte;\r\n Frequency: Longint;\r\n Nearest: Byte;\r\n end;\r\n\r\n PHist = ^THist;\r\n THist = record\r\n ColCount: Longint;\r\n Rm: Byte;\r\n Gm: Byte;\r\n BM: Byte;\r\n Freqs: array [0..MAX_N_COLS - 1] of TFreqRecord;\r\n HashTable: array [0..MAX_N_HASH - 1] of Word;\r\n end;\r\n\r\nfunction CreateHistogram(R, G, B: Byte): PHist;\r\n{ create empty histogram }\r\nbegin\r\n GetMem(Result, SizeOf(THist));\r\n with Result^ do\r\n begin\r\n Rm := R;\r\n Gm := G;\r\n BM := B;\r\n ColCount := 0;\r\n end;\r\n FillChar(Result^.HashTable, MAX_N_HASH * SizeOf(Word), 255);\r\nend;\r\n\r\nprocedure ClearHistogram(var Hist: PHist; R, G, B: Byte);\r\nbegin\r\n with Hist^ do\r\n begin\r\n Rm := R;\r\n Gm := G;\r\n BM := B;\r\n ColCount := 0;\r\n end;\r\n FillChar(Hist^.HashTable, MAX_N_HASH * SizeOf(Word), 255);\r\nend;\r\n\r\nprocedure DeleteHistogram(var Hist: PHist);\r\nbegin\r\n FreeMem(Hist, SizeOf(THist));\r\n Hist := nil;\r\nend;\r\n\r\nfunction AddToHistogram(var Hist: THist; const Header: TBitmapInfoHeader;\r\n Data24: Pointer): Boolean;\r\n{ add bitmap data to histogram }\r\nvar\r\n Step24: Integer;\r\n HashColor, Index: Word;\r\n Rm, Gm, BM, R, G, B: Byte;\r\n X, Y, ColCount: Longint;\r\nbegin\r\n Step24 := ((Header.biWidth * 3 + 3) and not 3) - Header.biWidth * 3;\r\n Rm := Hist.Rm;\r\n Gm := Hist.Gm;\r\n BM := Hist.BM;\r\n ColCount := Hist.ColCount;\r\n for Y := 0 to Header.biHeight - 1 do\r\n begin\r\n for X := 0 to Header.biWidth - 1 do\r\n begin\r\n B := Byte(Data24^) and BM;\r\n Inc(PByte(Data24));\r\n G := Byte(Data24^) and Gm;\r\n Inc(PByte(Data24));\r\n R := Byte(Data24^) and Rm;\r\n Inc(PByte(Data24));\r\n HashColor := Hash(R, G, B);\r\n repeat\r\n Index := Hist.HashTable[HashColor];\r\n if (Index = $FFFF) or ((Hist.Freqs[Index].R = R) and\r\n (Hist.Freqs[Index].G = G) and (Hist.Freqs[Index].B = B)) then\r\n Break;\r\n Inc(HashColor);\r\n if HashColor = MAX_N_HASH then\r\n HashColor := 0;\r\n until False;\r\n { Note: loop will always be broken out of }\r\n { We don't allow HashTable to fill up above half full }\r\n if Index = $FFFF then\r\n begin\r\n { Not found in Hash table }\r\n if ColCount = MAX_N_COLS then\r\n begin\r\n Result := False;\r\n Exit;\r\n end;\r\n Hist.Freqs[ColCount].Frequency := 1;\r\n Hist.Freqs[ColCount].B := B;\r\n Hist.Freqs[ColCount].G := G;\r\n Hist.Freqs[ColCount].R := R;\r\n Hist.HashTable[HashColor] := ColCount;\r\n Inc(ColCount);\r\n end\r\n else\r\n begin\r\n { Found in Hash table, update index }\r\n Inc(Hist.Freqs[Index].Frequency);\r\n end;\r\n end;\r\n Inc(PByte(Data24), Step24);\r\n end;\r\n Hist.ColCount := ColCount;\r\n Result := True;\r\nend;\r\n\r\nprocedure PalHistogram(var Hist: THist; var Colors: TRGBPalette;\r\n ColorsWanted: Integer);\r\n{ work out a palette from Hist }\r\nvar\r\n I, J: Longint;\r\n MinDist, Dist: Longint;\r\n MaxJ, MinJ: Longint;\r\n DeltaB, DeltaG, DeltaR: Longint;\r\n MaxFreq: Longint;\r\nbegin\r\n I := 0;\r\n MaxJ := 0;\r\n MinJ := 0;\r\n { Now find the ColorsWanted most frequently used ones }\r\n while (I < ColorsWanted) and (I < Hist.ColCount) do\r\n begin\r\n MaxFreq := 0;\r\n for J := 0 to Hist.ColCount - 1 do\r\n if Hist.Freqs[J].Frequency > MaxFreq then\r\n begin\r\n MaxJ := J;\r\n MaxFreq := Hist.Freqs[J].Frequency;\r\n end;\r\n Hist.Freqs[MaxJ].Nearest := Byte(I);\r\n Hist.Freqs[MaxJ].Frequency := 0; { Prevent later use of Freqs[MaxJ] }\r\n Colors[I].rgbBlue := Hist.Freqs[MaxJ].B;\r\n Colors[I].rgbGreen := Hist.Freqs[MaxJ].G;\r\n Colors[I].rgbRed := Hist.Freqs[MaxJ].R;\r\n Colors[I].rgbReserved := 0;\r\n Inc(I);\r\n end;\r\n { Unused palette entries will be medium grey }\r\n while I <= 255 do\r\n begin\r\n Colors[I].rgbRed := $80;\r\n Colors[I].rgbGreen := $80;\r\n Colors[I].rgbBlue := $80;\r\n Colors[I].rgbReserved := 0;\r\n Inc(I);\r\n end;\r\n { For the rest, find the closest one in the first ColorsWanted }\r\n for I := 0 to Hist.ColCount - 1 do\r\n begin\r\n if Hist.Freqs[I].Frequency <> 0 then\r\n begin\r\n MinDist := 3 * 256 * 256;\r\n for J := 0 to ColorsWanted - 1 do\r\n begin\r\n DeltaB := Hist.Freqs[I].B - Colors[J].rgbBlue;\r\n DeltaG := Hist.Freqs[I].G - Colors[J].rgbGreen;\r\n DeltaR := Hist.Freqs[I].R - Colors[J].rgbRed;\r\n Dist := Longint(DeltaR * DeltaR) + Longint(DeltaG * DeltaG) +\r\n Longint(DeltaB * DeltaB);\r\n if Dist < MinDist then\r\n begin\r\n MinDist := Dist;\r\n MinJ := J;\r\n end;\r\n end;\r\n Hist.Freqs[I].Nearest := Byte(MinJ);\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure MapHistogram(var Hist: THist; const Header: TBitmapInfoHeader;\r\n Data24, Data8: Pointer);\r\n{ map bitmap data to Hist palette }\r\nvar\r\n Step24: Integer;\r\n Step8: Integer;\r\n HashColor, Index: Longint;\r\n Rm, Gm, BM, R, G, B: Byte;\r\n X, Y: Longint;\r\nbegin\r\n Step24 := ((Header.biWidth * 3 + 3) and not 3) - Header.biWidth * 3;\r\n Step8 := ((Header.biWidth + 3) and not 3) - Header.biWidth;\r\n Rm := Hist.Rm;\r\n Gm := Hist.Gm;\r\n BM := Hist.BM;\r\n for Y := 0 to Header.biHeight - 1 do\r\n begin\r\n for X := 0 to Header.biWidth - 1 do\r\n begin\r\n B := Byte(Data24^) and BM;\r\n Inc(PByte(Data24));\r\n G := Byte(Data24^) and Gm;\r\n Inc(PByte(Data24));\r\n R := Byte(Data24^) and Rm;\r\n Inc(PByte(Data24));\r\n HashColor := Hash(R, G, B);\r\n repeat\r\n Index := Hist.HashTable[HashColor];\r\n if (Hist.Freqs[Index].R = R) and (Hist.Freqs[Index].G = G) and\r\n (Hist.Freqs[Index].B = B) then\r\n Break;\r\n Inc(HashColor);\r\n if HashColor = MAX_N_HASH then\r\n HashColor := 0;\r\n until False;\r\n PByte(Data8)^ := Hist.Freqs[Index].Nearest;\r\n Inc(PByte(Data8));\r\n end;\r\n Inc(PByte(Data24), Step24);\r\n Inc(PByte(Data8), Step8);\r\n end;\r\nend;\r\n\r\nprocedure Histogram(const Header: TBitmapInfoHeader; var Colors: TRGBPalette;\r\n Data24, Data8: Pointer; ColorsWanted: Integer; Rm, Gm, BM: Byte);\r\n{ map single bitmap to frequency optimised palette }\r\nvar\r\n Hist: PHist;\r\nbegin\r\n Hist := CreateHistogram(Rm, Gm, BM);\r\n try\r\n repeat\r\n if AddToHistogram(Hist^, Header, Data24) then\r\n Break\r\n else\r\n begin\r\n if Gm > Rm then\r\n Gm := Gm shl 1\r\n else\r\n if Rm > BM then\r\n Rm := Rm shl 1\r\n else\r\n BM := BM shl 1;\r\n ClearHistogram(Hist, Rm, Gm, BM);\r\n end;\r\n until False;\r\n { Above loop will always be exited as if masks get rough }\r\n { enough, ultimately number of unique colours < MAX_N_COLS }\r\n PalHistogram(Hist^, Colors, ColorsWanted);\r\n MapHistogram(Hist^, Header, Data24, Data8);\r\n finally\r\n DeleteHistogram(Hist);\r\n end;\r\nend;\r\n\r\n{ expand to 24 bits-per-pixel }\r\n\r\n(*\r\nprocedure ExpandTo24Bit(const Header: TBitmapInfoHeader; Colors: TRGBPalette;\r\n Data, NewData: Pointer);\r\nvar\r\n Scanline, NewScanline: Longint;\r\n Y, X: Integer;\r\n Src, Dest: PAnsiChar;\r\n C: Byte;\r\nbegin\r\n if Header.biBitCount = 24 then\r\n begin\r\n Exit;\r\n end;\r\n Scanline := ((Header.biWidth * Header.biBitCount + 31) div 32) * 4;\r\n NewScanline := ((Header.biWidth * 3 + 3) and not 3);\r\n for Y := 0 to Header.biHeight - 1 do\r\n begin\r\n Src := PAnsiChar(Data) + Y * Scanline;\r\n Dest := PAnsiChar(NewData) + Y * NewScanline;\r\n case Header.biBitCount of\r\n 1:\r\n begin\r\n C := 0;\r\n for X := 0 to Header.biWidth - 1 do\r\n begin\r\n if (X and 7) = 0 then\r\n begin\r\n C := Byte(Src^);\r\n Inc(Src);\r\n end\r\n else C := C shl 1;\r\n PByte(Dest)^ := Colors[C shr 7].rgbBlue;\r\n Inc(Dest);\r\n PByte(Dest)^ := Colors[C shr 7].rgbGreen;\r\n Inc(Dest);\r\n PByte(Dest)^ := Colors[C shr 7].rgbRed;\r\n Inc(Dest);\r\n end;\r\n end;\r\n 4:\r\n begin\r\n X := 0;\r\n while X < Header.biWidth - 1 do\r\n begin\r\n C := Byte(Src^);\r\n Inc(Src);\r\n PByte(Dest)^ := Colors[C shr 4].rgbBlue;\r\n Inc(Dest);\r\n PByte(Dest)^ := Colors[C shr 4].rgbGreen;\r\n Inc(Dest);\r\n PByte(Dest)^ := Colors[C shr 4].rgbRed;\r\n Inc(Dest);\r\n PByte(Dest)^ := Colors[C and 15].rgbBlue;\r\n Inc(Dest);\r\n PByte(Dest)^ := Colors[C and 15].rgbGreen;\r\n Inc(Dest);\r\n PByte(Dest)^ := Colors[C and 15].rgbRed;\r\n Inc(Dest);\r\n Inc(X, 2);\r\n end;\r\n if X < Header.biWidth then\r\n begin\r\n C := Byte(Src^);\r\n PByte(Dest)^ := Colors[C shr 4].rgbBlue;\r\n Inc(Dest);\r\n PByte(Dest)^ := Colors[C shr 4].rgbGreen;\r\n Inc(Dest);\r\n PByte(Dest)^ := Colors[C shr 4].rgbRed;\r\n {Inc(Dest);}\r\n end;\r\n end;\r\n 8:\r\n begin\r\n for X := 0 to Header.biWidth - 1 do\r\n begin\r\n C := Byte(Src^);\r\n Inc(Src);\r\n PByte(Dest)^ := Colors[C].rgbBlue;\r\n Inc(Dest);\r\n PByte(Dest)^ := Colors[C].rgbGreen;\r\n Inc(Dest);\r\n PByte(Dest)^ := Colors[C].rgbRed;\r\n Inc(Dest);\r\n end;\r\n end;\r\n end;\r\n end;\r\nend;\r\n*)\r\n\r\n{ DIB utility routines }\r\n\r\nfunction GetPaletteBitmapFormat(Bitmap: TBitmap): TPixelFormat;\r\nvar\r\n PalSize: Integer;\r\nbegin\r\n Result := pfDevice;\r\n if Bitmap.Palette <> 0 then\r\n begin\r\n GetObject(Bitmap.Palette, SizeOf(Integer), @PalSize);\r\n if PalSize > 0 then\r\n begin\r\n if PalSize <= 2 then\r\n Result := pf1bit\r\n else\r\n if PalSize <= 16 then\r\n Result := pf4bit\r\n else\r\n if PalSize <= 256 then\r\n Result := pf8bit;\r\n end;\r\n end;\r\nend;\r\n\r\n\r\nfunction GetBitmapPixelFormat(Bitmap: TBitmap): TPixelFormat;\r\nbegin\r\n Result := Bitmap.PixelFormat;\r\nend;\r\n\r\nfunction BytesPerScanLine(PixelsPerScanline, BitsPerPixel,\r\n Alignment: Longint): Longint;\r\nbegin\r\n Dec(Alignment);\r\n Result := ((PixelsPerScanline * BitsPerPixel) + Alignment) and not Alignment;\r\n Result := Result div 8;\r\nend;\r\n\r\nprocedure InitializeBitmapInfoHeader(Bitmap: HBITMAP; var BI: TBitmapInfoHeader;\r\n PixelFormat: TPixelFormat);\r\nvar\r\n DS: TDIBSection;\r\n Bytes: Integer;\r\nbegin\r\n DS.dsbmih.biSize := 0;\r\n { Retrieve the info for the current bitmap, thus with the current bit size/PixelFormat }\r\n Bytes := GetObject(Bitmap, SizeOf(DS), @DS);\r\n if Bytes = 0 then\r\n InvalidBitmap\r\n else\r\n if (Bytes >= (SizeOf(DS.dsbm) + SizeOf(DS.dsbmih))) and\r\n (DS.dsbmih.biSize >= DWORD(SizeOf(DS.dsbmih))) then\r\n BI := DS.dsbmih\r\n else\r\n begin\r\n FillChar(BI, SizeOf(BI), 0);\r\n BI.biSize := SizeOf(BI);\r\n BI.biWidth := DS.dsbm.bmWidth;\r\n BI.biHeight := DS.dsbm.bmHeight;\r\n end;\r\n case PixelFormat of\r\n pf1bit:\r\n BI.biBitCount := 1;\r\n pf4bit:\r\n BI.biBitCount := 4;\r\n pf8bit:\r\n BI.biBitCount := 8;\r\n pf24bit:\r\n BI.biBitCount := 24;\r\n else\r\n BI.biBitCount := DS.dsbm.bmBitsPixel * DS.dsbm.bmPlanes;\r\n end;\r\n BI.biPlanes := 1;\r\n { Calculate the size of the image with the new bit count; better would be to\r\n call GetDIBits, see http://support.microsoft.com/default.aspx?scid=kb;EN-US;80080\r\n }\r\n BI.biSizeImage := BytesPerScanLine(BI.biWidth, BI.biBitCount, 32) *\r\n Abs(BI.biHeight);\r\n BI.biClrUsed := 0;\r\n BI.biClrImportant := 0;\r\nend;\r\n\r\nprocedure InternalGetDIBSizes(Bitmap: HBITMAP; var InfoHeaderSize: Integer;\r\n var ImageSize: Longint; BitCount: TPixelFormat);\r\nvar\r\n BI: TBitmapInfoHeader;\r\nbegin\r\n InitializeBitmapInfoHeader(Bitmap, BI, BitCount);\r\n if BI.biBitCount > 8 then\r\n begin\r\n InfoHeaderSize := SizeOf(TBitmapInfoHeader);\r\n if (BI.biCompression and BI_BITFIELDS) <> 0 then\r\n Inc(InfoHeaderSize, 12);\r\n end\r\n else\r\n InfoHeaderSize := SizeOf(TBitmapInfoHeader) + SizeOf(TRGBQuad) * (1 shl BI.biBitCount);\r\n ImageSize := BI.biSizeImage;\r\nend;\r\n\r\nfunction GetDInColors(const BI: TBitmapInfoHeader): Integer;\r\nbegin\r\n if (BI.biClrUsed = 0) and (BI.biBitCount <= 8) then\r\n Result := 1 shl BI.biBitCount\r\n else\r\n Result := BI.biClrUsed;\r\nend;\r\n\r\nfunction InternalGetDIB(Bitmap: HBITMAP; Palette: HPALETTE;\r\n var BitmapInfo; var Bits; PixelFormat: TPixelFormat): Boolean;\r\nvar\r\n OldPal: HPALETTE;\r\n DC: HDC;\r\nbegin\r\n InitializeBitmapInfoHeader(Bitmap, TBitmapInfoHeader(BitmapInfo), PixelFormat);\r\n with TBitmapInfoHeader(BitmapInfo) do\r\n biHeight := Abs(biHeight);\r\n OldPal := 0;\r\n DC := CreateScreenCompatibleDC;\r\n try\r\n if Palette <> 0 then\r\n begin\r\n OldPal := SelectPalette(DC, Palette, False);\r\n RealizePalette(DC);\r\n end;\r\n Result := GetDIBits(DC, Bitmap, 0, TBitmapInfoHeader(BitmapInfo).biHeight,\r\n @Bits, TBitmapInfo(BitmapInfo), DIB_RGB_COLORS) <> 0;\r\n\r\n TBitmapInfoHeader(BitmapInfo).biClrUsed := GetDInColors(TBitmapInfoHeader(BitmapInfo));\r\n finally\r\n if OldPal <> 0 then\r\n SelectPalette(DC, OldPal, False);\r\n DeleteDC(DC);\r\n end;\r\nend;\r\n\r\nfunction DIBFromBit(Src: HBITMAP; Pal: HPALETTE; PixelFormat: TPixelFormat;\r\n var Length: Longint): Pointer;\r\nvar\r\n HeaderSize: Integer;\r\n ImageSize: Longint;\r\n FileHeader: PBitmapFileHeader;\r\n BI: PBitmapInfoHeader;\r\n Bits: Pointer;\r\nbegin\r\n if Src = 0 then\r\n InvalidBitmap;\r\n InternalGetDIBSizes(Src, HeaderSize, ImageSize, PixelFormat);\r\n Length := SizeOf(TBitmapFileHeader) + HeaderSize + ImageSize;\r\n Result := GlobalAllocPtr(GMEM_ZEROINIT, Length);\r\n try\r\n FileHeader := Result;\r\n with FileHeader^ do\r\n begin\r\n bfType := $4D42;\r\n bfSize := Length;\r\n bfOffBits := SizeOf(FileHeader^) + HeaderSize;\r\n end;\r\n BI := PBitmapInfoHeader(PAnsiChar(FileHeader) + SizeOf(FileHeader^));\r\n Bits := Pointer(PAnsiChar(BI) + HeaderSize);\r\n InternalGetDIB(Src, Pal, BI^, Bits^, PixelFormat);\r\n except\r\n GlobalFreePtr(Result);\r\n raise;\r\n end;\r\nend;\r\n\r\n{ Change bits per pixel in a General Bitmap }\r\n\r\nfunction BitmapToMemoryStream(Bitmap: TBitmap; PixelFormat: TPixelFormat;\r\n Method: TMappingMethod): TMemoryStream;\r\nvar\r\n FileHeader: PBitmapFileHeader;\r\n BI, NewBI: PBitmapInfoHeader;\r\n Bits: Pointer;\r\n NewPalette: PRGBPalette;\r\n NewHeaderSize: Integer;\r\n ImageSize, Length, Len: Longint;\r\n P, InitData: Pointer;\r\n ColorCount: Integer;\r\n SourceBitmapFormat: TPixelFormat;\r\nbegin\r\n Result := nil;\r\n if Bitmap.Handle = 0 then\r\n InvalidBitmap;\r\n SourceBitmapFormat := GetBitmapPixelFormat(Bitmap);\r\n if (SourceBitmapFormat = PixelFormat) and\r\n (Method <> mmGrayscale) then\r\n begin\r\n Result := TMemoryStream.Create;\r\n try\r\n Bitmap.SaveToStream(Result);\r\n Result.Position := 0;\r\n except\r\n Result.Free;\r\n raise;\r\n end;\r\n Exit;\r\n end;\r\n case PixelFormat of\r\n pf1bit, pf4bit, pf24bit:\r\n begin\r\n P := DIBFromBit(Bitmap.Handle, Bitmap.Palette, PixelFormat, Length);\r\n try\r\n Result := TMemoryStream.Create;\r\n try\r\n Result.Write(P^, Length);\r\n Result.Position := 0;\r\n except\r\n Result.Free;\r\n raise;\r\n end;\r\n finally\r\n GlobalFreePtr(P);\r\n end;\r\n end;\r\n pf8bit:\r\n begin\r\n { pf8bit - expand to 24bit first }\r\n InitData := DIBFromBit(Bitmap.Handle, Bitmap.Palette, pf24bit, Len);\r\n try\r\n BI := PBitmapInfoHeader(PAnsiChar(InitData) + SizeOf(TBitmapFileHeader));\r\n if BI^.biBitCount <> 24 then\r\n raise EJVCLException.CreateRes(@RsEBitCountNotImplemented);\r\n Bits := Pointer(PAnsiChar(BI) + SizeOf(TBitmapInfoHeader));\r\n InternalGetDIBSizes(Bitmap.Handle, NewHeaderSize, ImageSize, PixelFormat);\r\n Length := SizeOf(TBitmapFileHeader) + NewHeaderSize;\r\n P := AllocMem(Length);\r\n try\r\n NewBI := PBitmapInfoHeader(PAnsiChar(P) + SizeOf(TBitmapFileHeader));\r\n if NewHeaderSize <= SizeOf(TBitmapInfoHeader) then\r\n NewPalette := nil\r\n else\r\n NewPalette := PRGBPalette(PAnsiChar(NewBI) + SizeOf(TBitmapInfoHeader));\r\n FileHeader := PBitmapFileHeader(P);\r\n InitializeBitmapInfoHeader(Bitmap.Handle, NewBI^, PixelFormat);\r\n if Assigned(NewPalette) then\r\n case Method of\r\n mmQuantize:\r\n begin\r\n ColorCount := 256;\r\n Quantize(BI^, Bits, Bits, ColorCount, NewPalette^);\r\n NewBI^.biClrImportant := ColorCount;\r\n end;\r\n mmTrunc784:\r\n begin\r\n TruncPal7R8G4B(NewPalette^);\r\n Trunc7R8G4B(BI^, Bits, Bits);\r\n NewBI^.biClrImportant := 224;\r\n end;\r\n mmTrunc666:\r\n begin\r\n TruncPal6R6G6B(NewPalette^);\r\n Trunc6R6G6B(BI^, Bits, Bits);\r\n NewBI^.biClrImportant := 216;\r\n end;\r\n mmTripel:\r\n begin\r\n TripelPal(NewPalette^);\r\n Tripel(BI^, Bits, Bits);\r\n end;\r\n mmHistogram:\r\n begin\r\n Histogram(BI^, NewPalette^, Bits, Bits,\r\n PixelFormatToColors(PixelFormat), 255, 255, 255);\r\n end;\r\n mmGrayscale:\r\n begin\r\n GrayPal(NewPalette^);\r\n GrayScale(BI^, Bits, Bits);\r\n end;\r\n end;\r\n with FileHeader^ do\r\n begin\r\n bfType := $4D42;\r\n bfSize := Length;\r\n bfOffBits := SizeOf(FileHeader^) + NewHeaderSize;\r\n end;\r\n Result := TMemoryStream.Create;\r\n try\r\n Result.Write(P^, Length);\r\n Result.Write(Bits^, ImageSize);\r\n Result.Position := 0;\r\n except\r\n Result.Free;\r\n raise;\r\n end;\r\n finally\r\n FreeMem(P);\r\n end;\r\n finally\r\n GlobalFreePtr(InitData);\r\n end;\r\n end\r\n else\r\n raise EJVCLException.CreateRes(@RsEPixelFormatNotImplemented)\r\n end;\r\nend;\r\n\r\nfunction BitmapToMemory(Bitmap: TBitmap; Colors: Integer): TStream;\r\nvar\r\n PixelFormat: TPixelFormat;\r\nbegin\r\n if Colors <= 2 then\r\n PixelFormat := pf1bit\r\n else\r\n if Colors <= 16 then\r\n PixelFormat := pf4bit\r\n else\r\n if Colors <= 256 then\r\n PixelFormat := pf8bit\r\n else\r\n PixelFormat := pf24bit;\r\n Result := BitmapToMemoryStream(Bitmap, PixelFormat, DefaultMappingMethod);\r\nend;\r\n\r\nprocedure SaveBitmapToFile(const FileName: string; Bitmap: TBitmap;\r\n Colors: Integer);\r\nvar\r\n Memory: TStream;\r\nbegin\r\n if Bitmap.Monochrome then\r\n Colors := 2;\r\n Memory := BitmapToMemory(Bitmap, Colors);\r\n try\r\n TMemoryStream(Memory).SaveToFile(FileName);\r\n finally\r\n Memory.Free;\r\n end;\r\nend;\r\n\r\nprocedure SetBitmapPixelFormat(Bitmap: TBitmap; PixelFormat: TPixelFormat;\r\n Method: TMappingMethod);\r\nvar\r\n M: TMemoryStream;\r\nbegin\r\n if (Bitmap.Handle = 0) or ((GetBitmapPixelFormat(Bitmap) = PixelFormat) and (Method <> mmGrayscale)) then\r\n Exit;\r\n M := BitmapToMemoryStream(Bitmap, PixelFormat, Method);\r\n try\r\n Bitmap.LoadFromStream(M);\r\n finally\r\n M.Free;\r\n end;\r\nend;\r\n\r\nprocedure GrayscaleBitmap(Bitmap: TBitmap);\r\nbegin\r\n SetBitmapPixelFormat(Bitmap, pf8bit, mmGrayscale);\r\nend;\r\n\r\nfunction ZoomImage(ImageW, ImageH, MaxW, MaxH: Integer; Stretch: Boolean):\r\n TPoint;\r\nvar\r\n Zoom: Double;\r\nbegin\r\n Result := Point(0, 0);\r\n if (MaxW <= 0) or (MaxH <= 0) or (ImageW <= 0) or (ImageH <= 0) then\r\n Exit;\r\n if Stretch then\r\n begin\r\n Zoom := MaxFloat([ImageW / MaxW, ImageH / MaxH]);\r\n if Zoom > 0 then\r\n begin\r\n Result.X := Round(ImageW * 0.98 / Zoom);\r\n Result.Y := Round(ImageH * 0.98 / Zoom);\r\n end\r\n else\r\n begin\r\n Result.X := ImageW;\r\n Result.Y := ImageH;\r\n end;\r\n end\r\n else\r\n begin\r\n Result.X := MaxW;\r\n Result.Y := MaxH;\r\n end;\r\nend;\r\n\r\nprocedure TileImage(Canvas: TCanvas; Rect: TRect; Image: TGraphic);\r\nvar\r\n X, Y: Integer;\r\n SaveIndex: Integer;\r\nbegin\r\n if (Image.Width = 0) or (Image.Height = 0) then\r\n Exit;\r\n SaveIndex := SaveDC(Canvas.Handle);\r\n try\r\n IntersectClipRect(Canvas.Handle, Rect.Left, Rect.Top, Rect.Right, Rect.Bottom);\r\n for X := 0 to (RectWidth(Rect) div Image.Width) do\r\n for Y := 0 to (RectHeight(Rect) div Image.Height) do\r\n Canvas.Draw(Rect.Left + X * Image.Width,\r\n Rect.Top + Y * Image.Height, Image);\r\n finally\r\n RestoreDC(Canvas.Handle, SaveIndex);\r\n end;\r\nend;\r\n\r\n//=== { TJvGradientOptions } =================================================\r\n\r\nconstructor TJvGradientOptions.Create;\r\nbegin\r\n inherited Create;\r\n FStartColor := clSilver;\r\n FEndColor := clGray;\r\n FStepCount := 64;\r\n FDirection := fdTopToBottom;\r\nend;\r\n\r\nprocedure TJvGradientOptions.Assign(Source: TPersistent);\r\nbegin\r\n if Source is TJvGradientOptions then\r\n begin\r\n Self.FStartColor := TJvGradientOptions(Source).StartColor;\r\n Self.FEndColor := TJvGradientOptions(Source).EndColor;\r\n Self.FStepCount := TJvGradientOptions(Source).StepCount;\r\n Self.FDirection := TJvGradientOptions(Source).Direction;\r\n Self.FVisible := TJvGradientOptions(Source).Visible;\r\n Changed;\r\n end\r\n else\r\n inherited Assign(Source);\r\nend;\r\n\r\nprocedure TJvGradientOptions.Changed;\r\nbegin\r\n if Assigned(FOnChange) then\r\n FOnChange(Self);\r\nend;\r\n\r\nprocedure TJvGradientOptions.Draw(Canvas: TCanvas; Rect: TRect);\r\nbegin\r\n GradientFillRect(Canvas, Rect, FStartColor, FEndColor, FDirection, FStepCount);\r\nend;\r\n\r\nprocedure TJvGradientOptions.SetStartColor(Value: TColor);\r\nbegin\r\n if Value <> FStartColor then\r\n begin\r\n FStartColor := Value;\r\n Changed;\r\n end;\r\nend;\r\n\r\nprocedure TJvGradientOptions.SetEndColor(Value: TColor);\r\nbegin\r\n if Value <> FEndColor then\r\n begin\r\n FEndColor := Value;\r\n Changed;\r\n end;\r\nend;\r\n\r\nprocedure TJvGradientOptions.SetDirection(Value: TFillDirection);\r\nbegin\r\n if Value <> FDirection then\r\n begin\r\n FDirection := Value;\r\n Changed;\r\n end;\r\nend;\r\n\r\nprocedure TJvGradientOptions.SetStepCount(Value: Byte);\r\nbegin\r\n if Value <> FStepCount then\r\n begin\r\n FStepCount := Value;\r\n Changed;\r\n end;\r\nend;\r\n\r\nprocedure TJvGradientOptions.SetVisible(Value: Boolean);\r\nbegin\r\n if FVisible <> Value then\r\n begin\r\n FVisible := Value;\r\n Changed;\r\n end;\r\nend;\r\n{ end JvGraph }\r\n\r\n{ begin JvCtrlUtils }\r\n\r\n//=== ToolBarMenu ============================================================\r\n\r\nprocedure JvCreateToolBarMenu(AForm: TForm; AToolBar: TToolBar;\r\n AMenu: TMainMenu);\r\nvar\r\n I, TotalWidth: Integer;\r\n Button: TToolButton;\r\nbegin\r\n if AForm.FormStyle = fsMDIForm then\r\n raise EJVCLException.CreateRes(@RsENotForMdi);\r\n if AMenu = nil then\r\n AMenu := AForm.Menu;\r\n if AMenu = nil then\r\n Exit;\r\n\r\n TotalWidth := AToolbar.BorderWidth;\r\n for I := AToolbar.ButtonCount - 1 downto 0 do\r\n AToolbar.Buttons[I].Free;\r\n AToolbar.ShowCaptions := True;\r\n\r\n for I := AMenu.Items.Count - 1 downto 0 do\r\n begin\r\n Button := TToolButton.Create(AToolBar);\r\n Button.Parent := AToolBar;\r\n Button.AutoSize := True;\r\n Button.Caption := AMenu.Items[I].Caption;\r\n Button.Grouped := True;\r\n Button.MenuItem := AMenu.Items[I];\r\n Inc(TotalWidth, Button.Width + AToolBar.BorderWidth);\r\n end;\r\n\r\n AToolBar.Width := TotalWidth;\r\n AForm.Menu := nil;\r\nend;\r\n\r\n//=== ListView functions =====================================================\r\n\r\nprocedure JvListViewToStrings(ListView: TListView; Strings: TStrings;\r\n SelectedOnly: Boolean; Headers: Boolean);\r\nvar\r\n ColWidths: array of Word;\r\n\r\n procedure AddLine(const S: string);\r\n begin\r\n Strings.Add(TrimRight(S));\r\n end;\r\n\r\n function StrPadRight(const S: string; Len: Integer): string;\r\n begin\r\n Result := S;\r\n if Len > Length(S) then\r\n Result := Result + MakeStr(' ', Len - Length(S))\r\n end;\r\n\r\n function StrPadLeft(const S: string; Len: Integer): string;\r\n begin\r\n Result := S;\r\n if Len > Length(S) then\r\n Result := MakeStr(' ', Len - Length(S)) + Result;\r\n end;\r\n\r\n function MakeCellStr(const Text: string; Index: Integer): string;\r\n begin\r\n with ListView.Columns[Index] do\r\n if Alignment = taLeftJustify then\r\n Result := StrPadRight(Text, ColWidths[Index] + 1)\r\n else\r\n Result := StrPadLeft(Text, ColWidths[Index]) + ' ';\r\n end;\r\n\r\nvar\r\n R, C: Integer;\r\n S: string;\r\nbegin\r\n SetLength(S, 256);\r\n with ListView do\r\n begin\r\n SetLength(ColWidths, Columns.Count);\r\n if Headers then\r\n for C := 0 to Columns.Count - 1 do\r\n ColWidths[C] := Length(Trim(Columns[C].Caption));\r\n for R := 0 to Items.Count - 1 do\r\n if not SelectedOnly or Items[R].Selected then\r\n begin\r\n ColWidths[0] := Max(ColWidths[0], Length(Trim(Items[R].Caption)));\r\n for C := 0 to Items[R].SubItems.Count - 1 do\r\n ColWidths[C + 1] := Max(ColWidths[C + 1],\r\n Length(Trim(Items[R].SubItems[C])));\r\n end;\r\n Strings.BeginUpdate;\r\n try\r\n if Headers then\r\n with Columns do\r\n begin\r\n S := '';\r\n for C := 0 to Count - 1 do\r\n S := S + MakeCellStr(Items[C].Caption, C);\r\n AddLine(S);\r\n S := '';\r\n for C := 0 to Count - 1 do\r\n S := S + StringOfChar('-', ColWidths[C]) + ' ';\r\n AddLine(S);\r\n end;\r\n for R := 0 to Items.Count - 1 do\r\n if not SelectedOnly or Items[R].Selected then\r\n with Items[R] do\r\n begin\r\n S := MakeCellStr(Caption, 0);\r\n for C := 0 to Min(SubItems.Count, Columns.Count - 1) - 1 do\r\n S := S + MakeCellStr(SubItems[C], C + 1);\r\n AddLine(S);\r\n end;\r\n finally\r\n Strings.EndUpdate;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction JvListViewSafeSubItemString(Item: TListItem; SubItemIndex: Integer): string;\r\nbegin\r\n if Item.SubItems.Count > SubItemIndex then\r\n Result := Item.SubItems[SubItemIndex]\r\n else\r\n Result := '';\r\nend;\r\n\r\nprocedure JvListViewSortClick(Column: TListColumn; AscendingSortImage: Integer;\r\n DescendingSortImage: Integer);\r\nvar\r\n ListView: TListView;\r\n I: Integer;\r\nbegin\r\n ListView := TListColumns(Column.Collection).Owner as TListView;\r\n ListView.Columns.BeginUpdate;\r\n try\r\n with ListView.Columns do\r\n for I := 0 to Count - 1 do\r\n Items[I].ImageIndex := -1;\r\n if ListView.Tag and $FF = Column.Index then\r\n ListView.Tag := ListView.Tag xor $100\r\n else\r\n ListView.Tag := Column.Index;\r\n if ListView.Tag and $100 = 0 then\r\n Column.ImageIndex := AscendingSortImage\r\n else\r\n Column.ImageIndex := DescendingSortImage;\r\n finally\r\n ListView.Columns.EndUpdate;\r\n end;\r\nend;\r\n\r\nprocedure JvListViewCompare(ListView: TListView; Item1, Item2: TListItem;\r\n var Compare: Integer);\r\n\r\n function FmtStrToInt(S: string): Integer;\r\n var\r\n I: Integer;\r\n begin\r\n I := 1;\r\n while I <= Length(S) do\r\n if not CharInSet(S[I], DigitChars + ['-']) then\r\n Delete(S, I, 1)\r\n else\r\n Inc(I);\r\n Result := StrToInt(S);\r\n end;\r\n\r\nvar\r\n ColIndex: Integer;\r\nbegin\r\n with ListView do\r\n begin\r\n ColIndex := Tag and $FF - 1;\r\n if Columns[ColIndex + 1].Alignment = taLeftJustify then\r\n begin\r\n if ColIndex = -1 then\r\n Compare := AnsiCompareText(Item1.Caption, Item2.Caption)\r\n else\r\n Compare := AnsiCompareText(Item1.SubItems[ColIndex], Item2.SubItems[ColIndex]);\r\n end\r\n else\r\n begin\r\n if ColIndex = -1 then\r\n Compare := FmtStrToInt(Item1.Caption) - FmtStrToInt(Item2.Caption)\r\n else\r\n Compare := FmtStrToInt(Item1.SubItems[ColIndex]) -\r\n FmtStrToInt(Item2.SubItems[ColIndex]);\r\n end;\r\n if Tag and $100 <> 0 then\r\n Compare := -Compare;\r\n end;\r\nend;\r\n\r\nprocedure JvListViewSelectAll(ListView: TListView; Deselect: Boolean);\r\nvar\r\n I: Integer;\r\n H: THandle;\r\n Data: Integer;\r\n SaveOnSelectItem: TLVSelectItemEvent;\r\nbegin\r\n with ListView do\r\n if MultiSelect then\r\n begin\r\n Items.BeginUpdate;\r\n SaveOnSelectItem := OnSelectItem;\r\n WaitCursor;\r\n try\r\n H := Handle;\r\n OnSelectItem := nil;\r\n if Deselect then\r\n Data := 0\r\n else\r\n Data := LVIS_SELECTED;\r\n for I := 0 to Items.Count - 1 do\r\n ListView_SetItemState(H, I, Data, LVIS_SELECTED);\r\n finally\r\n OnSelectItem := SaveOnSelectItem;\r\n Items.EndUpdate;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction JvListViewSaveState(ListView: TListView): TJvLVItemStateData;\r\nvar\r\n TempItem: TListItem;\r\nbegin\r\n with Result do\r\n begin\r\n Focused := Assigned(ListView.ItemFocused);\r\n Selected := Assigned(ListView.Selected);\r\n if Focused then\r\n TempItem := ListView.ItemFocused\r\n else\r\n if Selected then\r\n TempItem := ListView.Selected\r\n else\r\n TempItem := nil;\r\n if TempItem <> nil then\r\n begin\r\n Caption := TempItem.Caption;\r\n Data := TempItem.Data;\r\n end\r\n else\r\n begin\r\n Caption := '';\r\n Data := nil;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction JvListViewRestoreState(ListView: TListView; Data: TJvLVItemStateData;\r\n MakeVisible: Boolean; FocusFirst: Boolean): Boolean;\r\nvar\r\n TempItem: TListItem;\r\nbegin\r\n with ListView do\r\n begin\r\n TempItem := FindCaption(0, Data.Caption, False, True, False);\r\n Result := TempItem <> nil;\r\n if Result then\r\n begin\r\n TempItem.Focused := Data.Focused;\r\n TempItem.Selected := Data.Selected;\r\n end\r\n else\r\n if FocusFirst and (Items.Count > 0) then\r\n begin\r\n TempItem := Items[0];\r\n TempItem.Focused := True;\r\n TempItem.Selected := True;\r\n end;\r\n if MakeVisible and (TempItem <> nil) then\r\n TempItem.MakeVisible(True);\r\n end;\r\nend;\r\n\r\nfunction JvListViewGetOrderedColumnIndex(Column: TListColumn): Integer;\r\nvar\r\n ColumnOrder: array of Integer;\r\n Columns: TListColumns;\r\n I: Integer;\r\nbegin\r\n Result := -1;\r\n Columns := TListColumns(Column.Collection);\r\n SetLength(ColumnOrder, Columns.Count);\r\n ListView_GetColumnOrderArray(Columns.Owner.Handle, Columns.Count, PInteger(ColumnOrder));\r\n for I := 0 to High(ColumnOrder) do\r\n if ColumnOrder[I] = Column.Index then\r\n begin\r\n Result := I;\r\n Break;\r\n end;\r\nend;\r\n\r\nprocedure JvListViewSetSystemImageList(ListView: TListView);\r\nvar\r\n FileInfo: TSHFileInfo;\r\n ImageListHandle: THandle;\r\nbegin\r\n FillChar(FileInfo, SizeOf(FileInfo), 0);\r\n ImageListHandle := SHGetFileInfo('', 0, FileInfo, SizeOf(FileInfo),\r\n SHGFI_SYSICONINDEX or SHGFI_SMALLICON);\r\n SendMessage(ListView.Handle, LVM_SETIMAGELIST, LVSIL_SMALL, LPARAM(ImageListHandle));\r\n\r\n FillChar(FileInfo, SizeOf(FileInfo), 0);\r\n ImageListHandle := SHGetFileInfo('', 0, FileInfo, SizeOf(FileInfo),\r\n SHGFI_SYSICONINDEX or SHGFI_LARGEICON);\r\n SendMessage(ListView.Handle, LVM_SETIMAGELIST, LVSIL_NORMAL, LPARAM(ImageListHandle));\r\nend;\r\n\r\n//== MessageBox ==============================================================\r\n\r\nfunction JvMessageBox(const Text, Caption: string; Flags: DWORD): Integer;\r\nbegin\r\n Result := MsgBox(Text, Caption, Flags);\r\nend;\r\n\r\nfunction JvMessageBox(const Text: string; Flags: DWORD): Integer;\r\nbegin\r\n Result := MsgBox(Text, Application.Title, Flags);\r\nend;\r\n\r\nprocedure UpdateTrackFont(TrackFont, Font: TFont; TrackOptions: TJvTrackFontOptions);\r\nbegin\r\n if hoFollowFont in TrackOptions then\r\n begin\r\n if not (hoPreserveCharSet in TrackOptions) then\r\n TrackFont.Charset := Font.Charset;\r\n if not (hoPreserveColor in TrackOptions) then\r\n TrackFont.Color := Font.Color;\r\n if not (hoPreserveHeight in TrackOptions) then\r\n TrackFont.Height := Font.Height;\r\n if not (hoPreserveName in TrackOptions) then\r\n TrackFont.Name := Font.Name;\r\n if not (hoPreservePitch in TrackOptions) then\r\n TrackFont.Pitch := Font.Pitch;\r\n if not (hoPreserveStyle in TrackOptions) then\r\n TrackFont.Style := Font.Style;\r\n end;\r\nend;\r\n\r\n{ end JvCtrlUtils }\r\n\r\nfunction GetDefaultCheckBoxSize: TSize;\r\nbegin\r\n with TBitmap.Create do\r\n try\r\n Handle := LoadBitmap(0, PChar(OBM_CHECKBOXES));\r\n Result.cx := Width div 4;\r\n Result.cy := Height div 3;\r\n finally\r\n Free;\r\n end;\r\nend;\r\n\r\nfunction CanvasMaxTextHeight(Canvas: TCanvas): Integer;\r\nvar\r\n tt: TTextMetric;\r\nbegin\r\n GetTextMetrics(Canvas.Handle, tt);\r\n Result := tt.tmHeight;\r\nend;\r\n\r\n{$IFDEF MSWINDOWS}\r\n\r\n//=== AllocateHWndEx =========================================================\r\n\r\nconst\r\n cUtilWindowExClass: TWndClass = (\r\n style: 0;\r\n lpfnWndProc: nil;\r\n cbClsExtra: 0;\r\n cbWndExtra: SizeOf(TMethod);\r\n hInstance: 0;\r\n hIcon: 0;\r\n hCursor: 0;\r\n hbrBackground: 0;\r\n lpszMenuName: nil;\r\n lpszClassName: 'TPUtilWindowEx');\r\n\r\nfunction StdWndProc(Window: THandle; Message, WParam: WPARAM;\r\n LParam: LPARAM): LRESULT; stdcall;\r\nvar\r\n Msg: Messages.TMessage;\r\n WndProc: TWndMethod;\r\nbegin\r\n TMethod(WndProc).Code := Pointer(GetWindowLongPtr(Window, 0));\r\n TMethod(WndProc).Data := Pointer(GetWindowLongPtr(Window, SizeOf(Pointer)));\r\n if Assigned(WndProc) then\r\n begin\r\n Msg.Msg := Message;\r\n Msg.WParam := WParam;\r\n Msg.LParam := LParam;\r\n Msg.Result := 0;\r\n WndProc(Msg);\r\n Result := Msg.Result;\r\n end\r\n else\r\n Result := DefWindowProc(Window, Message, WParam, LParam);\r\nend;\r\n\r\nfunction AllocateHWndEx(Method: TWndMethod; const AClassName: string = ''): THandle;\r\nvar\r\n TempClass: TWndClass;\r\n UtilWindowExClass: TWndClass;\r\n ClassRegistered: Boolean;\r\nbegin\r\n UtilWindowExClass := cUtilWindowExClass;\r\n UtilWindowExClass.hInstance := HInstance;\r\n UtilWindowExClass.lpfnWndProc := @DefWindowProc;\r\n if AClassName <> '' then\r\n UtilWindowExClass.lpszClassName := PChar(AClassName);\r\n\r\n ClassRegistered := Windows.GetClassInfo(HInstance, UtilWindowExClass.lpszClassName,\r\n TempClass);\r\n if not ClassRegistered or (TempClass.lpfnWndProc <> @DefWindowProc) then\r\n begin\r\n if ClassRegistered then\r\n Windows.UnregisterClass(UtilWindowExClass.lpszClassName, HInstance);\r\n Windows.RegisterClass(UtilWindowExClass);\r\n end;\r\n Result := Windows.CreateWindowEx(Windows.WS_EX_TOOLWINDOW, UtilWindowExClass.lpszClassName,\r\n '', Windows.WS_POPUP, 0, 0, 0, 0, 0, 0, HInstance, nil);\r\n\r\n if Assigned(Method) then\r\n begin\r\n SetWindowLongPtr(Result, 0, LONG_PTR(TMethod(Method).Code));\r\n SetWindowLongPtr(Result, SizeOf(TMethod(Method).Code), LONG_PTR(TMethod(Method).Data));\r\n SetWindowLongPtr(Result, GWL_WNDPROC, LONG_PTR(@StdWndProc));\r\n end;\r\nend;\r\n\r\nprocedure DeallocateHWndEx(Wnd: THandle);\r\nbegin\r\n Windows.DestroyWindow(Wnd);\r\nend;\r\n\r\nfunction JvMakeObjectInstance(Method: TWndMethod): Pointer;\r\nbegin\r\n Result := MakeObjectInstance(Method);\r\nend;\r\n\r\nprocedure JvFreeObjectInstance(ObjectInstance: Pointer);\r\nbegin\r\n if Assigned(ObjectInstance) then\r\n FreeObjectInstance(ObjectInstance);\r\nend;\r\n\r\n{$ENDIF MSWINDOWS}\r\n\r\nprocedure InitScreenCursors;\r\nbegin\r\n try\r\n if Screen <> nil then\r\n begin\r\n // now only available through SetDefaultJVCLCursors\r\n Screen.Cursors[crMultiDragLink] := Screen.Cursors[crMultiDrag];\r\n Screen.Cursors[crDragAlt] := Screen.Cursors[crDrag];\r\n Screen.Cursors[crMultiDragAlt] := Screen.Cursors[crMultiDrag];\r\n Screen.Cursors[crMultiDragLinkAlt] := Screen.Cursors[crMultiDrag];\r\n end;\r\n except\r\n end;\r\nend;\r\n\r\nconst\r\n LeftBrackets = ['[', '{', '('];\r\n RightsBrackets = [']', '}', ')'];\r\n\r\n{ Utilities routines }\r\n\r\nfunction FontStylesToString(Styles: TFontStyles): string;\r\nbegin\r\n Result := '';\r\n if fsBold in Styles then\r\n Result := Result + 'B';\r\n if fsItalic in Styles then\r\n Result := Result + 'I';\r\n if fsUnderline in Styles then\r\n Result := Result + 'U';\r\n if fsStrikeOut in Styles then\r\n Result := Result + 'S';\r\nend;\r\n\r\nfunction StringToFontStyles(const Styles: string): TFontStyles;\r\nbegin\r\n Result := [];\r\n if Pos('B', UpperCase(Styles)) > 0 then\r\n Include(Result, fsBold);\r\n if Pos('I', UpperCase(Styles)) > 0 then\r\n Include(Result, fsItalic);\r\n if Pos('U', UpperCase(Styles)) > 0 then\r\n Include(Result, fsUnderline);\r\n if Pos('S', UpperCase(Styles)) > 0 then\r\n Include(Result, fsStrikeOut);\r\nend;\r\n\r\nfunction FontToString(Font: TFont): string;\r\nbegin\r\n Result := Format('%s,%d,%s,%d,%s,%d', [Font.Name, Font.Size,\r\n FontStylesToString(Font.Style), Ord(Font.Pitch), ColorToString(Font.Color), Font.Charset]);\r\nend;\r\n\r\nfunction StringToFont(const Str: string): TFont;\r\nconst\r\n Delims = [',', ';'];\r\nvar\r\n Pos: Integer;\r\n I: Byte;\r\n S: string;\r\nbegin\r\n Result := TFont.Create;\r\n try\r\n Pos := 1;\r\n I := 0;\r\n while Pos <= Length(Str) do\r\n begin\r\n Inc(I);\r\n S := Trim(ExtractSubstr(Str, Pos, Delims));\r\n case I of\r\n 1:\r\n Result.Name := S;\r\n 2:\r\n Result.Size := StrToIntDef(S, Result.Size);\r\n 3:\r\n Result.Style := StringToFontStyles(S);\r\n 4:\r\n Result.Pitch := TFontPitch(StrToIntDef(S, Ord(Result.Pitch)));\r\n 5:\r\n Result.Color := StringToColor(S);\r\n 6:\r\n Result.Charset := TFontCharset(StrToIntDef(S, Result.Charset));\r\n end;\r\n end;\r\n finally\r\n end;\r\nend;\r\n\r\n\r\nfunction RectToStr(Rect: TRect): string;\r\nbegin\r\n Result := Format('[%d,%d,%d,%d]', [Rect.Left, Rect.Top, Rect.Right, Rect.Bottom]);\r\nend;\r\n\r\nfunction StrToRect(const Str: string; const Def: TRect): TRect;\r\nvar\r\n S: string;\r\n Temp: string{$IFNDEF RTL200_UP}[10]{$ENDIF ~RTL200_UP};\r\n I: Integer;\r\nbegin\r\n Result := Def;\r\n S := Str;\r\n if (S <> '') and CharInSet(S[1], LeftBrackets) and CharInSet(S[Length(S)], RightsBrackets) then\r\n begin\r\n Delete(S, 1, 1);\r\n SetLength(S, Length(S) - 1);\r\n end;\r\n I := Pos(',', S);\r\n if I > 0 then\r\n begin\r\n Temp := Trim(Copy(S, 1, I - 1));\r\n Result.Left := StrToIntDef(Temp, Def.Left);\r\n Delete(S, 1, I);\r\n I := Pos(',', S);\r\n if I > 0 then\r\n begin\r\n Temp := Trim(Copy(S, 1, I - 1));\r\n Result.Top := StrToIntDef(Temp, Def.Top);\r\n Delete(S, 1, I);\r\n I := Pos(',', S);\r\n if I > 0 then\r\n begin\r\n Temp := Trim(Copy(S, 1, I - 1));\r\n Result.Right := StrToIntDef(Temp, Def.Right);\r\n Delete(S, 1, I);\r\n Temp := Trim(S);\r\n Result.Bottom := StrToIntDef(Temp, Def.Bottom);\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction PointToStr(P: TPoint): string;\r\nbegin\r\n Result := Format('[%d,%d]', [P.X, P.Y]);\r\nend;\r\n\r\nfunction StrToPoint(const Str: string; const Def: TPoint): TPoint;\r\nvar\r\n S: string;\r\n Temp: string{$IFNDEF RTL200_UP}[10]{$ENDIF ~RTL200_UP};\r\n I: Integer;\r\nbegin\r\n Result := Def;\r\n S := Str;\r\n if (S <> '') and CharInSet(S[1], LeftBrackets) and CharInSet(S[Length(Str)], RightsBrackets) then\r\n begin\r\n Delete(S, 1, 1);\r\n SetLength(S, Length(S) - 1);\r\n end;\r\n I := Pos(',', S);\r\n if I > 0 then\r\n begin\r\n Temp := Trim(Copy(S, 1, I - 1));\r\n Result.X := StrToIntDef(Temp, Def.X);\r\n Delete(S, 1, I);\r\n Temp := Trim(S);\r\n Result.Y := StrToIntDef(Temp, Def.Y);\r\n end;\r\nend;\r\n\r\nprocedure DrawLine(Canvas: TCanvas; X, Y, X2, Y2: Integer);\r\nbegin\r\n Canvas.MoveTo(X, Y);\r\n Canvas.LineTo(X2, Y2);\r\nend;\r\n\r\nprocedure DrawArrow(Canvas: TCanvas; X, Y: Integer; Size: Integer;\r\n Color: TColor = clBlack; Direction: TAnchorKind = akBottom);\r\nbegin\r\n if (X >= 0) and (Y >= 0) and (Size > 0) then\r\n DrawArrow(Canvas, Bounds(X, Y, Size, Size), Color, Direction, 0);\r\nend;\r\n\r\nprocedure DrawArrow(Canvas: TCanvas; ARect: TRect; Color: TColor = clBlack;\r\n Direction: TAnchorKind = akBottom; Margin: Integer = 0);\r\nvar\r\n Size: Integer;\r\nbegin\r\n RectNormalize(ARect);\r\n\r\n if Margin <> 0 then\r\n InflateRect(ARect, -Margin, -Margin);\r\n\r\n Size := RectWidth(ARect);\r\n if Odd(Size) then\r\n Dec(ARect.Right);\r\n\r\n RectSquare(ARect);\r\n Size := RectWidth(ARect);\r\n\r\n Canvas.Pen.Color := Color;\r\n case Direction of\r\n akLeft: {Draw from right to left}\r\n begin\r\n ARect.Right := ARect.Right - (Size div 4); {Because rect is Square, Thus origin sub size/4 is center}\r\n while ARect.Top < ARect.Bottom {+ 1} do\r\n begin\r\n DrawLine(Canvas, ARect.Right, ARect.Top, ARect.Right, ARect.Bottom);\r\n InflateRect(ARect, -1, -1);\r\n end;\r\n end;\r\n akRight: {Draw from left to right}\r\n begin\r\n ARect.Left := ARect.Left + (Size div 4); {Because rect is Square, Thus origin add size/4 is center}\r\n while ARect.Top < ARect.Bottom + 1 do\r\n begin\r\n DrawLine(Canvas, ARect.Left, ARect.Top, ARect.Left, ARect.Bottom);\r\n InflateRect(ARect, -1, -1);\r\n end;\r\n end;\r\n akTop: {Draw from Bottom to top}\r\n begin\r\n ARect.Bottom := ARect.Bottom - (Size div 4); {Because rect is Square, Thus origin sub size/4 is center}\r\n while ARect.Left < ARect.Right + 1 do\r\n begin\r\n DrawLine(Canvas, ARect.Left, ARect.Bottom, ARect.Right, ARect.Bottom);\r\n InflateRect(ARect, -1, -1);\r\n end;\r\n end;\r\n akBottom: {Draw from top to Bottom}\r\n begin\r\n ARect.Top := ARect.Top + (Size div 4); {Because rect is Square, Thus origin add size/4 is center}\r\n while ARect.Left < ARect.Right + 1 do\r\n begin\r\n DrawLine(Canvas, ARect.Left, ARect.Top, ARect.Right, ARect.Top);\r\n InflateRect(ARect, -1, -1);\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction IsPositiveResult(Value: TModalResult): Boolean;\r\nbegin\r\n Result := Value in [mrOk, mrYes, mrAll, mrYesToAll];\r\nend;\r\n\r\nfunction IsNegativeResult(Value: TModalResult): Boolean;\r\nbegin\r\n Result := Value in [mrNo, mrNoToAll];\r\nend;\r\n\r\nfunction IsAbortResult(const Value: TModalResult): Boolean;\r\nbegin\r\n Result := Value in [mrCancel, mrAbort];\r\nend;\r\n\r\nfunction StripAllFromResult(const Value: TModalResult): TModalResult;\r\nbegin\r\n case Value of\r\n mrAll:\r\n Result := mrOk;\r\n mrNoToAll:\r\n Result := mrNo;\r\n mrYesToAll:\r\n Result := mrYes;\r\n else\r\n Result := Value;\r\n end;\r\nend;\r\n\r\n//=== { TJvPoint } ===========================================================\r\n\r\nprocedure TJvPoint.Assign(Source: TPersistent);\r\nbegin\r\n if Source is TJvPoint then\r\n begin\r\n FX := TJvPoint(Source).X;\r\n FY := TJvPoint(Source).Y;\r\n DoChange;\r\n end\r\n else\r\n inherited Assign(Source);\r\nend;\r\n\r\nprocedure TJvPoint.AssignPoint(const Source: TPoint);\r\nbegin\r\n X := Source.X;\r\n Y := Source.Y;\r\nend;\r\n\r\nprocedure TJvPoint.Assign(const Source: TPoint);\r\nbegin\r\n X := Source.X;\r\n Y := Source.Y;\r\nend;\r\n\r\nprocedure TJvPoint.CopyToPoint(var Point: TPoint);\r\nbegin\r\n Point.X := X;\r\n Point.Y := Y;\r\nend;\r\n\r\nprocedure TJvPoint.DoChange;\r\nbegin\r\n if Assigned(FOnChange) then\r\n FOnChange(Self);\r\nend;\r\n\r\nfunction TJvPoint.GetAsPoint: TPoint;\r\nbegin\r\n Result := Point(FX, FY);\r\nend;\r\n\r\nprocedure TJvPoint.SetAsPoint(const Value: TPoint);\r\nbegin\r\n if (Value.X <> FX) or (Value.Y <> FY) then\r\n begin\r\n FX := Value.X;\r\n FY := Value.Y;\r\n DoChange;\r\n end;\r\nend;\r\n\r\nprocedure TJvPoint.SetX(Value: Longint);\r\nbegin\r\n if Value <> FX then\r\n begin\r\n FX := Value;\r\n DoChange;\r\n end;\r\nend;\r\n\r\nprocedure TJvPoint.SetY(Value: Longint);\r\nbegin\r\n if Value <> FY then\r\n begin\r\n FY := Value;\r\n DoChange;\r\n end;\r\nend;\r\n\r\n//=== { TJvRect } ============================================================\r\n\r\nconstructor TJvRect.Create;\r\nbegin\r\n inherited Create;\r\n FTopLeft := TJvPoint.Create;\r\n FBottomRight := TJvPoint.Create;\r\n FTopLeft.OnChange := PointChange;\r\n FBottomRight.OnChange := PointChange;\r\nend;\r\n\r\ndestructor TJvRect.Destroy;\r\nbegin\r\n FTopLeft.Free;\r\n FBottomRight.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvRect.Assign(Source: TPersistent);\r\nbegin\r\n if Source is TJvRect then\r\n begin\r\n TopLeft.Assign(TJvRect(Source).TopLeft);\r\n BottomRight.Assign(TJvRect(Source).BottomRight);\r\n DoChange;\r\n end\r\n else\r\n inherited Assign(Source);\r\nend;\r\n\r\nprocedure TJvRect.AssignRect(const Source: TRect);\r\nbegin\r\n TopLeft.AssignPoint(Source.TopLeft);\r\n BottomRight.AssignPoint(Source.BottomRight);\r\nend;\r\n\r\nprocedure TJvRect.Assign(const Source: TRect);\r\nbegin\r\n TopLeft.Assign(Source.TopLeft);\r\n BottomRight.Assign(Source.BottomRight);\r\nend;\r\n\r\nprocedure TJvRect.CopyToRect(var Rect: TRect);\r\nbegin\r\n TopLeft.CopyToPoint(Rect.TopLeft);\r\n BottomRight.CopyToPoint(Rect.BottomRight);\r\nend;\r\n\r\nprocedure TJvRect.DoChange;\r\nbegin\r\n if Assigned(FOnChange) then\r\n FOnChange(Self);\r\nend;\r\n\r\nfunction TJvRect.GetBottom: Integer;\r\nbegin\r\n Result := FBottomRight.Y;\r\nend;\r\n\r\nfunction TJvRect.GetLeft: Integer;\r\nbegin\r\n Result := FTopLeft.X;\r\nend;\r\n\r\nfunction TJvRect.GetRight: Integer;\r\nbegin\r\n Result := FBottomRight.X;\r\nend;\r\n\r\nfunction TJvRect.GetTop: Integer;\r\nbegin\r\n Result := FTopLeft.Y;\r\nend;\r\n\r\nprocedure TJvRect.PointChange(Sender: TObject);\r\nbegin\r\n DoChange;\r\nend;\r\n\r\nprocedure TJvRect.SetBottom(Value: Integer);\r\nbegin\r\n FBottomRight.Y := Value;\r\nend;\r\n\r\nprocedure TJvRect.SetBottomRight(Value: TJvPoint);\r\nbegin\r\n FBottomRight.Assign(Value);\r\nend;\r\n\r\nprocedure TJvRect.SetLeft(Value: Integer);\r\nbegin\r\n FTopLeft.X := Value;\r\nend;\r\n\r\nprocedure TJvRect.SetRight(Value: Integer);\r\nbegin\r\n FBottomRight.X := Value;\r\nend;\r\n\r\nprocedure TJvRect.SetTop(Value: Integer);\r\nbegin\r\n FTopLeft.Y := Value;\r\nend;\r\n\r\nprocedure TJvRect.SetTopLeft(Value: TJvPoint);\r\nbegin\r\n FTopLeft.Assign(Value);\r\nend;\r\n\r\nfunction TJvRect.GetHeight: Integer;\r\nbegin\r\n Result := FBottomRight.Y - FTopLeft.Y;\r\nend;\r\n\r\nfunction TJvRect.GetWidth: Integer;\r\nbegin\r\n Result := FBottomRight.X - FTopLeft.X;\r\nend;\r\n\r\nprocedure TJvRect.SetHeight(Value: Integer);\r\nbegin\r\n FBottomRight.Y := FTopLeft.Y + Value;\r\nend;\r\n\r\nprocedure TJvRect.SetWidth(Value: Integer);\r\nbegin\r\n FBottomRight.X := FTopLeft.X + Value;\r\nend;\r\n\r\n{ TJvSize }\r\n\r\nprocedure TJvSize.Assign(Source: TPersistent);\r\nbegin\r\n if Source is TJvSize then\r\n begin\r\n FWidth := (Source as TJvSize).Width;\r\n FHeight := (Source as TJvSize).Height;\r\n DoChange;\r\n end\r\n else\r\n begin\r\n inherited Assign(Source);\r\n end;\r\nend;\r\n\r\nprocedure TJvSize.AssignSize(const Source: TSize);\r\nbegin\r\n FWidth := Source.cx;\r\n FHeight := Source.cy;\r\n DoChange;\r\nend;\r\n\r\nprocedure TJvSize.Assign(const Source: TSize);\r\nbegin\r\n FWidth := Source.cx;\r\n FHeight := Source.cy;\r\n DoChange;\r\nend;\r\n\r\nprocedure TJvSize.CopyToSize(var Size: TSize);\r\nbegin\r\n Size.cx := Width;\r\n Size.cy := Height;\r\nend;\r\n\r\nprocedure TJvSize.DoChange;\r\nbegin\r\n if Assigned(OnChange) then\r\n OnChange(Self);\r\nend;\r\n\r\nfunction TJvSize.GetSize: TSize;\r\nbegin\r\n Result.cx := FWidth;\r\n Result.cy := FHeight;\r\nend;\r\n\r\nprocedure TJvSize.SetSize(const Value: TSize);\r\nbegin\r\n if (Value.cx <> FWidth) or (Value.cy <> FHeight) then\r\n begin\r\n FWidth := Value.cx;\r\n FHeight := Value.cy;\r\n DoChange;\r\n end;\r\nend;\r\n\r\nprocedure TJvSize.SetHeight(Value: Integer);\r\nbegin\r\n if FHeight <> Value then\r\n begin\r\n FHeight := Value;\r\n DoChange;\r\n end;\r\nend;\r\n\r\nprocedure TJvSize.SetWidth(Value: Integer);\r\nbegin\r\n if FWidth <> Value then\r\n begin\r\n FWidth := Value;\r\n DoChange;\r\n end;\r\nend;\r\n\r\nfunction SelectColorByLuminance(AColor, DarkColor, BrightColor: TColor): TColor;\r\nvar\r\n ACol: Longint;\r\nbegin\r\n ACol := ColorToRGB(AColor) and $00FFFFFF;\r\n if ((2.99 * GetRValue(ACol) + 5.87 * GetGValue(ACol) + 1.14 * GetBValue(ACol)) > $400) then\r\n Result := DarkColor\r\n else\r\n Result := BrightColor;\r\nend;\r\n\r\nconst\r\n cBR = '
';\r\n cHR = '
';\r\n cTagBegin = '<';\r\n cTagEnd = '>';\r\n cLT = '<';\r\n cGT = '>';\r\n cQuote = '\"';\r\n cCENTER = 'CENTER';\r\n cRIGHT = 'RIGHT';\r\n cHREF = 'HREF';\r\n cIND = 'IND';\r\n cCOLOR = 'COLOR';\r\n cBGCOLOR = 'BGCOLOR';\r\n\r\n// moved from JvHTControls and renamed\r\nfunction HTMLPrepareText(const Text: string): string;\r\ntype\r\n THtmlCode = record\r\n Html: string;\r\n Text: UTF8String;\r\n end;\r\nconst\r\n Conversions: array [0..6] of THtmlCode = (\r\n (Html: '&'; Text: '&'),\r\n (Html: '"'; Text: '\"'),\r\n (Html: '®'; Text: #$C2#$AE),\r\n (Html: '©'; Text: #$C2#$A9),\r\n (Html: '™'; Text: #$E2#$84#$A2),\r\n (Html: '€'; Text: #$E2#$82#$AC),\r\n (Html: ' '; Text: ' ')\r\n );\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := Text;\r\n for I := Low(Conversions) to High(Conversions) do\r\n Result := StringReplace(Result, Conversions[I].Html, Utf8ToAnsi(Conversions[I].Text), [rfReplaceAll, rfIgnoreCase]);\r\n Result := StringReplace(Result, sLineBreak, '', [rfReplaceAll, rfIgnoreCase]); // only
can be new line\r\n Result := StringReplace(Result, cBR, sLineBreak, [rfReplaceAll, rfIgnoreCase]);\r\n Result := StringReplace(Result, cHR, cHR + sLineBreak, [rfReplaceAll, rfIgnoreCase]); // fixed

\r\nend;\r\n\r\nfunction HTMLBeforeTag(var Str: string; DeleteToTag: Boolean = False): string;\r\nbegin\r\n if Pos(cTagBegin, Str) > 0 then\r\n begin\r\n Result := Copy(Str, 1, Pos(cTagBegin, Str) - 1);\r\n if DeleteToTag then\r\n Delete(Str, 1, Pos(cTagBegin, Str) - 1);\r\n end\r\n else\r\n begin\r\n Result := Str;\r\n if DeleteToTag then\r\n Str := '';\r\n end;\r\nend;\r\n\r\nfunction GetChar(const Str: string; Pos: Word; Up: Boolean = False): Char;\r\nbegin\r\n if Length(Str) >= Pos then\r\n Result := Str[Pos]\r\n else\r\n Result := ' ';\r\n if Up then\r\n Result := UpCase(Result);\r\nend;\r\n\r\nfunction HTMLDeleteTag(const Str: string): string;\r\nbegin\r\n Result := Str;\r\n if (GetChar(Result, 1) = cTagBegin) and (Pos(cTagEnd, Result) > 1) then\r\n Delete(Result, 1, Pos(cTagEnd, Result));\r\nend;\r\n\r\nprocedure HTMLDrawTextEx(Canvas: TCanvas; Rect: TRect;\r\n const State: TOwnerDrawState; const Text: string; var Width: Integer;\r\n CalcType: TJvHTMLCalcType; MouseX, MouseY: Integer; var MouseOnLink: Boolean;\r\n var LinkName: string; SuperSubScriptRatio: Double; Scale: Integer);\r\nvar\r\n H: Integer;\r\nbegin\r\n HTMLDrawTextEx(Canvas, Rect, State, Text, Width, H, CalcType, MouseX, MouseY, MouseOnLink,\r\n LinkName, SuperSubScriptRatio, Scale);\r\n if CalcType = htmlCalcHeight then\r\n Width := H;\r\nend;\r\n\r\ntype\r\n TScriptPosition = (spNormal, spSuperscript, spSubscript);\r\n\r\nprocedure HTMLDrawTextEx(Canvas: TCanvas; Rect: TRect;\r\n const State: TOwnerDrawState; const Text: string; var Width, Height: Integer;\r\n CalcType: TJvHTMLCalcType; MouseX, MouseY: Integer; var MouseOnLink: Boolean;\r\n var LinkName: string; SuperSubScriptRatio: Double; Scale: Integer);\r\nconst\r\n DefaultLeft = 0; // (ahuser) was 2\r\nvar\r\n vText, vM, TagPrp, Prp, TempLink: string;\r\n vCount: Integer;\r\n vStr: TStringList;\r\n Selected: Boolean;\r\n Alignment: TAlignment;\r\n Trans, IsLink: Boolean;\r\n CurLeft: Integer;\r\n // for begin and end\r\n OldFontStyles: TFontStyles;\r\n OldFontColor: TColor;\r\n OldBrushColor: TColor;\r\n OldBrushStyle: TBrushStyle;\r\n OldAlignment: TAlignment;\r\n OldFont: TFont;\r\n OldWidth: Integer;\r\n // for font style\r\n RemFontColor,\r\n RemBrushColor: TColor;\r\n RemFontSize: Integer;\r\n ScriptPosition: TScriptPosition;\r\n\r\n function ExtractPropertyValue(const Tag: string; PropName: string): string;\r\n var\r\n I: Integer;\r\n begin\r\n Result := '';\r\n PropName := UpperCase(PropName);\r\n if Pos(PropName, UpperCase(Tag)) > 0 then\r\n begin\r\n Result := Copy(Tag, Pos(PropName, UpperCase(Tag)) + Length(PropName), Length(Tag));\r\n if Pos('\"', Result) <> 0 then\r\n begin\r\n Result := Copy(Result, Pos('\"', Result) + 1, Length(Result));\r\n Result := Copy(Result, 1, Pos('\"', Result) - 1);\r\n end\r\n else\r\n if Pos('''', Result) <> 0 then\r\n begin\r\n Result := Copy(Result, Pos('''', Result) + 1, Length(Result));\r\n Result := Copy(Result, 1, Pos('''', Result) - 1);\r\n end\r\n else\r\n begin\r\n Result := Trim(Result);\r\n Delete(Result, 1, 1);\r\n Result := Trim(Result);\r\n I := 1;\r\n while (I < Length(Result)) and (Result[I+1] <> ' ') do\r\n Inc(I);\r\n Result := Copy(Result, 1, I);\r\n end;\r\n end;\r\n end;\r\n\r\n procedure Style(const Style: TFontStyle; const Include: Boolean);\r\n begin\r\n if Assigned(Canvas) then\r\n if Include then\r\n Canvas.Font.Style := Canvas.Font.Style + [Style]\r\n else\r\n Canvas.Font.Style := Canvas.Font.Style - [Style];\r\n end;\r\n\r\n function CalcPos(const Str: string): Integer;\r\n begin\r\n case Alignment of\r\n taRightJustify:\r\n Result := (Rect.Right - Rect.Left) - HTMLTextWidth(Canvas, Rect, State, Str, Scale);\r\n taCenter:\r\n Result := DefaultLeft + ((Rect.Right - Rect.Left) - HTMLTextWidth(Canvas, Rect, State, Str, SuperSubScriptRatio)) div 2;\r\n else\r\n Result := DefaultLeft;\r\n end;\r\n if Result <= 0 then\r\n Result := DefaultLeft;\r\n end;\r\n\r\n procedure Draw(const M: string);\r\n var\r\n Width, Height: Integer;\r\n R: TRect;\r\n OriginalFontSize: Integer;\r\n begin\r\n R := Rect;\r\n Inc(R.Left, CurLeft);\r\n if Assigned(Canvas) then\r\n begin\r\n OriginalFontSize := Canvas.Font.Size; \r\n try\r\n if ScriptPosition <> spNormal then\r\n Canvas.Font.Size := Round(Canvas.Font.Size * SuperSubScriptRatio);\r\n \r\n Width := Canvas.TextWidth(M);\r\n Height := CanvasMaxTextHeight(Canvas);\r\n\r\n if ScriptPosition = spSubscript then\r\n R.Top := R.Bottom - Height - 1;\r\n\r\n if IsLink and not MouseOnLink then\r\n if (MouseY >= R.Top) and (MouseY <= R.Top + Height) and\r\n (MouseX >= R.Left) and (MouseX <= R.Left + Width) and\r\n ((MouseY > 0) or (MouseX > 0)) then\r\n begin\r\n MouseOnLink := True;\r\n Canvas.Font.Color := clRed; // hover link\r\n LinkName := TempLink;\r\n end;\r\n if CalcType = htmlShow then\r\n begin\r\n if Trans then\r\n Canvas.Brush.Style := bsClear; // for transparent\r\n Canvas.TextOut(R.Left, R.Top, M);\r\n end;\r\n CurLeft := CurLeft + Width;\r\n finally\r\n Canvas.Font.Size := OriginalFontSize;\r\n end;\r\n end;\r\n end;\r\n\r\n procedure NewLine(Always: Boolean = False);\r\n begin\r\n if Assigned(Canvas) then\r\n if Always or (vCount < vStr.Count - 1) then\r\n begin\r\n Width := Max(Width, CurLeft);\r\n CurLeft := DefaultLeft;\r\n Rect.Top := Rect.Top + CanvasMaxTextHeight(Canvas);\r\n end;\r\n end;\r\n\r\nbegin\r\n // (p3) remove warnings\r\n OldFontColor := 0;\r\n OldBrushColor := 0;\r\n OldBrushStyle := bsClear;\r\n RemFontSize := 0;\r\n RemFontColor := 0;\r\n RemBrushColor := 0;\r\n OldAlignment := taLeftJustify;\r\n OldFont := TFont.Create;\r\n\r\n if Canvas <> nil then\r\n begin\r\n OldFontStyles := Canvas.Font.Style;\r\n OldFontColor := Canvas.Font.Color;\r\n OldBrushColor := Canvas.Brush.Color;\r\n OldBrushStyle := Canvas.Brush.Style;\r\n OldAlignment := Alignment;\r\n RemFontColor := Canvas.Font.Color;\r\n RemBrushColor := Canvas.Brush.Color;\r\n RemFontSize := Canvas.Font.size;\r\n end;\r\n try\r\n Alignment := taLeftJustify;\r\n IsLink := False;\r\n MouseOnLink := False;\r\n vText := Text;\r\n vStr := TStringList.Create;\r\n vStr.Text := HTMLPrepareText(vText);\r\n LinkName := '';\r\n TempLink := '';\r\n ScriptPosition := spNormal;\r\n\r\n Selected := (odSelected in State) or (odDisabled in State);\r\n Trans := (Canvas.Brush.Style = bsClear) and not selected;\r\n\r\n Width := DefaultLeft;\r\n CurLeft := DefaultLeft;\r\n\r\n vM := '';\r\n for vCount := 0 to vStr.Count - 1 do\r\n begin\r\n vText := vStr[vCount];\r\n CurLeft := CalcPos(vText);\r\n while vText <> '' do\r\n begin\r\n vM := HTMLBeforeTag(vText, True);\r\n vM := StringReplace(vM, '<', cLT, [rfReplaceAll, rfIgnoreCase]); // <--+ this must be here\r\n vM := StringReplace(vM, '>', cGT, [rfReplaceAll, rfIgnoreCase]); // <--/\r\n if GetChar(vText, 1) = cTagBegin then\r\n begin\r\n if vM <> '' then\r\n Draw(vM);\r\n if Pos(cTagEnd, vText) = 0 then\r\n Insert(cTagEnd, vText, 2);\r\n if GetChar(vText, 2) = '/' then\r\n begin\r\n case GetChar(vText, 3, True) of\r\n 'A':\r\n begin\r\n IsLink := False;\r\n Canvas.Font.Assign(OldFont);\r\n end;\r\n 'B':\r\n Style(fsBold, False);\r\n 'I':\r\n Style(fsItalic, False);\r\n 'U':\r\n Style(fsUnderline, False);\r\n 'S':\r\n begin\r\n ScriptPosition := spNormal;\r\n Style(fsStrikeOut, False);\r\n end;\r\n 'F':\r\n begin\r\n if not Selected then // restore old colors\r\n begin\r\n Canvas.Font.Color := RemFontColor;\r\n Canvas.Brush.Color := RemBrushColor;\r\n Canvas.Font.Size := RemFontSize;\r\n Trans := True;\r\n end;\r\n end;\r\n end\r\n end\r\n else\r\n begin\r\n case GetChar(vText, 2, True) of\r\n 'A':\r\n begin\r\n if GetChar(vText, 3, True) = 'L' then // ALIGN\r\n begin\r\n TagPrp := UpperCase(Copy(vText, 2, Pos(cTagEnd, vText) - 2));\r\n if Pos(cCENTER, TagPrp) > 0 then\r\n Alignment := taCenter\r\n else\r\n if Pos(cRIGHT, TagPrp) > 0 then\r\n Alignment := taRightJustify\r\n else\r\n Alignment := taLeftJustify;\r\n CurLeft := DefaultLeft;\r\n if CalcType in [htmlShow, htmlHyperLink] then\r\n CurLeft := CalcPos(vText);\r\n end\r\n else\r\n begin // A HREF\r\n TagPrp := Copy(vText, 2, Pos(cTagEnd, vText) - 2);\r\n if Pos(cHREF, UpperCase(TagPrp)) > 0 then\r\n begin\r\n IsLink := True;\r\n OldFont.Assign(Canvas.Font);\r\n if not Selected then\r\n Canvas.Font.Color := clBlue;\r\n TempLink := ExtractPropertyValue(TagPrp, cHREF);\r\n end;\r\n end;\r\n end;\r\n 'B':\r\n Style(fsBold, True);\r\n 'I':\r\n if GetChar(vText, 3, True) = 'N' then //IND=\"%d\"\r\n begin\r\n TagPrp := Copy(vText, 2, Pos(cTagEnd, vText) - 2);\r\n CurLeft := StrToInt(ExtractPropertyValue(TagPrp, cIND)); // ex IND=\"10\"\r\n if odReserved1 in State then\r\n CurLeft := Round((CurLeft * Scale) div 100);\r\n end\r\n else\r\n Style(fsItalic, True); // ITALIC\r\n 'U':\r\n Style(fsUnderline, True);\r\n 'S':\r\n begin\r\n if GetChar(vText, 4, True) = 'P' then\r\n begin\r\n ScriptPosition := spSuperscript;\r\n end\r\n else if GetChar(vText, 4, True) = 'B' then\r\n begin\r\n ScriptPosition := spSubscript;\r\n end\r\n else\r\n begin\r\n ScriptPosition := spNormal;\r\n Style(fsStrikeOut, True);\r\n end;\r\n end;\r\n 'H':\r\n if (GetChar(vText, 3, True) = 'R') and Assigned(Canvas) then // HR\r\n begin\r\n if odDisabled in State then // only when disabled\r\n Canvas.Pen.Color := Canvas.Font.Color;\r\n OldWidth := Canvas.Pen.Width;\r\n TagPrp := UpperCase(Copy(vText, 2, Pos(cTagEnd, vText)-2));\r\n Canvas.Pen.Width := StrToIntDef(ExtractPropertyValue(TagPrp, 'SIZE'), 1); // ex HR=\"10\"\r\n if odReserved1 in State then\r\n Canvas.Pen.Width := Round((Canvas.Pen.Width * Scale) div 100);\r\n if CalcType = htmlShow then\r\n begin\r\n Canvas.MoveTo(Rect.Left, Rect.Top + CanvasMaxTextHeight(Canvas));\r\n Canvas.LineTo(Rect.Right, Rect.Top + CanvasMaxTextHeight(Canvas));\r\n end;\r\n Rect.Top := Rect.Top + 1 + Canvas.Pen.Width;\r\n Canvas.Pen.Width := OldWidth;\r\n NewLine(HTMLDeleteTag(vText) <> '');\r\n end;\r\n 'F':\r\n if (Pos(cTagEnd, vText) > 0) and (not Selected) and Assigned(Canvas) {and (CalcType in [htmlShow, htmlHyperLink])} then // F from FONT\r\n begin\r\n TagPrp := UpperCase(Copy(vText, 2, Pos(cTagEnd, vText) - 2));\r\n RemFontColor := Canvas.Font.Color;\r\n RemBrushColor := Canvas.Brush.Color;\r\n\r\n if Pos(cCOLOR, TagPrp) > 0 then\r\n begin\r\n Prp := ExtractPropertyValue(TagPrp, cCOLOR);\r\n if Prp[1] = '#' then\r\n Prp[1] := '$';\r\n Canvas.Font.Color := StringToColor(Prp);\r\n end;\r\n if Pos(cBGCOLOR, TagPrp) > 0 then\r\n begin\r\n Prp := ExtractPropertyValue(TagPrp, cBGCOLOR);\r\n if Prp[1] = '#' then\r\n Prp[1] := '$';\r\n if UpperCase(Prp) = 'CLNONE' then\r\n Trans := True\r\n else\r\n begin\r\n Canvas.Brush.Color := StringToColor(Prp);\r\n Trans := False;\r\n end;\r\n end;\r\n if Pos('SIZE', TagPrp) > 0 then\r\n begin\r\n Prp := ExtractPropertyValue(TagPrp, 'SIZE');\r\n Canvas.Font.Size := StrToIntDef(Prp,2) * Canvas.Font.Size div 2;\r\n end;\r\n end;\r\n end;\r\n end;\r\n vText := HTMLDeleteTag(vText);\r\n vM := '';\r\n end;\r\n end;\r\n if vM <> '' then\r\n Draw(vM);\r\n NewLine;\r\n vM := '';\r\n end;\r\n finally\r\n if Canvas <> nil then\r\n begin\r\n Canvas.Font.Style := OldFontStyles;\r\n Canvas.Font.Color := OldFontColor;\r\n Canvas.Brush.Color := OldBrushColor;\r\n Canvas.Brush.Style := OldBrushStyle;\r\n Alignment := OldAlignment;\r\n { Canvas.Font.Color := RemFontColor;\r\n Canvas.Brush.Color:= RemBrushColor;}\r\n end;\r\n FreeAndNil(vStr);\r\n FreeAndNil(OldFont);\r\n end;\r\n Width := Max(Width, CurLeft - DefaultLeft);\r\n Height := Rect.Top + CanvasMaxTextHeight(Canvas);\r\nend;\r\n\r\nfunction HTMLDrawText(Canvas: TCanvas; Rect: TRect;\r\n const State: TOwnerDrawState; const Text: string; SuperSubScriptRatio: Double; Scale: Integer): string;\r\nvar\r\n W: Integer;\r\n S: Boolean;\r\n St: string;\r\nbegin\r\n HTMLDrawTextEx(Canvas, Rect, State, Text, W, htmlShow, 0, 0, S, St, SuperSubScriptRatio, Scale);\r\nend;\r\n\r\nfunction HTMLDrawTextHL(Canvas: TCanvas; Rect: TRect;\r\n const State: TOwnerDrawState; const Text: string; MouseX, MouseY: Integer;\r\n SuperSubScriptRatio: Double; Scale: Integer): string;\r\nvar\r\n W: Integer;\r\n S: Boolean;\r\n St: string;\r\nbegin\r\n HTMLDrawTextEx(Canvas, Rect, State, Text, W, htmlShow, MouseX, MouseY, S, St, SuperSubScriptRatio, Scale);\r\nend;\r\n\r\nfunction HTMLPlainText(const Text: string): string;\r\nvar\r\n S: string;\r\nbegin\r\n Result := '';\r\n S := HTMLPrepareText(Text);\r\n while Pos(cTagBegin, S) > 0 do\r\n begin\r\n Result := Result + Copy(S, 1, Pos(cTagBegin, S)-1);\r\n if Pos(cTagEnd, S) > 0 then\r\n Delete(S, 1, Pos(cTagEnd, S))\r\n else\r\n Delete(S, 1, Pos(cTagBegin, S));\r\n end;\r\n Result := Result + S;\r\nend;\r\n\r\nfunction HTMLTextExtent(Canvas: TCanvas; Rect: TRect;\r\n const State: TOwnerDrawState; const Text: string; SuperSubScriptRatio: Double; Scale: Integer = 100): TSize;\r\nvar\r\n S: Boolean;\r\n St: string;\r\nbegin\r\n HTMLDrawTextEx(Canvas, Rect, State, Text, Result.cx, Result.cy, htmlCalcWidth, 0, 0, S, St, SuperSubScriptRatio, Scale);\r\n if Result.cy = 0 then\r\n Result.cy := CanvasMaxTextHeight(Canvas);\r\n Inc(Result.cy);\r\nend;\r\n\r\nfunction HTMLTextWidth(Canvas: TCanvas; Rect: TRect;\r\n const State: TOwnerDrawState; const Text: string; SuperSubScriptRatio: Double; Scale: Integer = 100): Integer;\r\nvar\r\n S: Boolean;\r\n St: string;\r\nbegin\r\n HTMLDrawTextEx(Canvas, Rect, State, Text, Result, htmlCalcWidth, 0, 0, S, St, SuperSubScriptRatio, Scale);\r\nend;\r\n\r\nfunction HTMLTextHeight(Canvas: TCanvas; const Text: string; SuperSubScriptRatio: Double; Scale: Integer = 100): Integer;\r\nvar\r\n S: Boolean;\r\n St: string;\r\n R: TRect;\r\nbegin\r\n R := Rect(0, 0, 0, 0);\r\n HTMLDrawTextEx(Canvas, R, [], Text, Result, htmlCalcHeight, 0, 0, S, St, SuperSubScriptRatio, Scale);\r\n if Result = 0 then\r\n Result := CanvasMaxTextHeight(Canvas);\r\n Inc(Result);\r\nend;\r\n\r\n{ TJvPicture }\r\nprocedure TJvPicture.ReadBitmapData(Stream: TStream);\r\nvar\r\n Size: Longint;\r\nbegin\r\n Stream.Read(Size, SizeOf(Size));\r\n Bitmap.LoadFromStream(Stream);\r\nend;\r\n\r\nprocedure TJvPicture.DefineProperties(Filer: TFiler);\r\nvar\r\n SavedPosition: Integer;\r\n Reader: TReader;\r\n VType : TValueType;\r\n WasBitmap : Boolean;\r\n Count : Longint;\r\n NameLength: Byte;\r\nbegin\r\n if Filer is TReader then\r\n begin\r\n // When we are reading, we must detect if the data is a valid TPicture\r\n // data or just a TBitmap data. This is done by having a sneak peak at\r\n // what's in the reader stream. If we find a NameLength tag that is\r\n // greater than 63 (it's built-in limit, see TPicture.DefineProperties)\r\n // then it must be a TBitmap and we then tell the bitmap to load itself\r\n // from the Filter.\r\n // Note: the test must be done here, before any call to the\r\n // DefineBinaryProperty of the Reader. If not, then the FPropName field\r\n // would be put back to blank and prevent the inherited DefineProperties\r\n // from working correctly.\r\n Reader := Filer as TReader;\r\n WasBitmap := False;\r\n SavedPosition := Reader.Position;\r\n\r\n VType := Reader.ReadValue;\r\n if VType = vaBinary then\r\n begin\r\n Reader.Read(Count, SizeOf(Count));\r\n Reader.Read(NameLength, SizeOf(NameLength));\r\n WasBitmap := NameLength > 63;\r\n end;\r\n\r\n Reader.Position := SavedPosition;\r\n\r\n if WasBitmap then\r\n Filer.DefineBinaryProperty('Data', ReadBitmapData, nil, True)\r\n else\r\n inherited DefineProperties(Filer);\r\n end\r\n else\r\n inherited DefineProperties(Filer);\r\nend;\r\n\r\n//=== { TGraphicSignature } ==================================================\r\n\r\n// Code to manage graphic's signatures.\r\ntype\r\n TGraphicSignature = class(TObject)\r\n public\r\n Signature: AnsiString;\r\n Offset: Integer;\r\n GraphicClass: TGraphicClass;\r\n constructor Create(const ASignature: AnsiString; AOffset: Integer; AGraphicClass: TGraphicClass);\r\n function CheckSignature(AStream: TStream): Boolean;\r\n end;\r\n\r\nconstructor TGraphicSignature.Create(const ASignature: AnsiString; AOffset: Integer; AGraphicClass: TGraphicClass);\r\nbegin\r\n inherited Create;\r\n Signature := ASignature;\r\n Offset := AOffset;\r\n GraphicClass := AGraphicClass;\r\nend;\r\n\r\nfunction TGraphicSignature.CheckSignature(AStream: TStream): Boolean;\r\nvar\r\n Buffer: AnsiString;\r\n Count: Integer;\r\n BytesRead: Integer;\r\nbegin\r\n Result := False;\r\n try\r\n Count := Length(Signature);\r\n AStream.Position := Offset;\r\n SetLength(Buffer, Count);\r\n BytesRead := AStream.Read(Buffer[1], Count);\r\n Result := (BytesRead = Count) and (Buffer = Signature);\r\n except\r\n // Ignore any error...\r\n end;\r\nend;\r\n\r\nvar\r\n GraphicSignatures: TObjectList = nil;\r\n\r\nprocedure GraphicSignaturesNeeded;\r\nbegin\r\n if not Assigned(GraphicSignatures) then\r\n begin\r\n GraphicSignatures := TObjectList.Create;\r\n\r\n RegisterGraphicSignature('BM', 0, TBitmap);\r\n RegisterGraphicSignature([0, 0, 1, 0], 0, TIcon);\r\n RegisterGraphicSignature([$D7, $CD], 0, TMetafile); // WMF\r\n RegisterGraphicSignature([1, 0], 0, TMetafile); // EMF\r\n RegisterGraphicSignature('JFIF', 6, TJPEGImage);\r\n RegisterGraphicSignature('Exif', 6 , TJPEGImage);\r\n // NB! Registering these will add a requirement on having the JvMM package installed\r\n // Let users register these manually\r\n // RegisterGraphicSignature([$0A], 0, TJvPcx);\r\n // RegisterGraphicSignature('ACON', 8, TJvAni);\r\n // JvCursorImage cannot be registered because it doesn't support\r\n // LoadFromStream/SaveToStream but here's the signature for future reference:\r\n // RegisterGraphicSignature([0, 0, 2, 0], 0, TJvCursorImage);\r\n {$IFDEF USE_JV_GIF}\r\n // RegisterGraphicSignature('GIF', 0, TJvGIFImage);\r\n {$ENDIF USE_JV_GIF}\r\n// RegisterGraphicSignature('GIF', 0, TGIFGraphic);\r\n// RegisterGraphicSignature('PNG', 1, TPNGGraphic);\r\n end;\r\nend;\r\n\r\nprocedure RegisterGraphicSignature(const ASignature: AnsiString; AOffset: Integer; AGraphicClass: TGraphicClass);\r\nvar\r\n GraphicSignature: TGraphicSignature;\r\nbegin\r\n // Avoid bad signatures\r\n if (ASignature = '') or (AOffset < 0) or (AGraphicClass = nil) then\r\n raise EJVCLException.CreateRes(@RsEBadGraphicSignature);\r\n GraphicSignaturesNeeded;\r\n // Should raise an exception if empty signature, negative offset or null class.\r\n GraphicSignature := TGraphicSignature.Create(ASignature, AOffset, AGraphicClass);\r\n try\r\n GraphicSignatures.Add(GraphicSignature);\r\n except\r\n GraphicSignature.Free;\r\n end;\r\nend;\r\n\r\nprocedure RegisterGraphicSignature(const ASignature: array of Byte; AOffset: Integer; AGraphicClass: TGraphicClass);\r\nbegin\r\n if Length(ASignature) > 0 then\r\n RegisterGraphicSignature(StringOf(ASignature), AOffset, AGraphicClass);\r\nend;\r\n\r\nprocedure UnregisterGraphicSignature(AGraphicClass: TGraphicClass); overload;\r\nvar\r\n I: Integer;\r\nbegin\r\n if Assigned(GraphicSignatures) then\r\n for I := GraphicSignatures.Count - 1 downto 0 do\r\n if TGraphicSignature(GraphicSignatures[I]).GraphicClass = AGraphicClass then\r\n GraphicSignatures.Delete(I);\r\nend;\r\n\r\nprocedure UnregisterGraphicSignature(const ASignature: AnsiString; AOffset: Integer);\r\nvar\r\n I: Integer;\r\nbegin\r\n if Assigned(GraphicSignatures) then\r\n for I := GraphicSignatures.Count - 1 downto 0 do\r\n with TGraphicSignature(GraphicSignatures[I]) do\r\n if (Signature = ASignature) and (Offset = AOffset) then\r\n GraphicSignatures.Delete(I);\r\nend;\r\n\r\nprocedure UnregisterGraphicSignature(const ASignature: array of Byte; AOffset: Integer);\r\nbegin\r\n UnregisterGraphicSignature(StringOf(ASignature), AOffset);\r\nend;\r\n\r\nfunction GetGraphicClass(AStream: TStream): TGraphicClass;\r\nvar\r\n P: Integer;\r\n I: Integer;\r\n S: TGraphicSignature;\r\nbegin\r\n Result := nil;\r\n GraphicSignaturesNeeded;\r\n if Assigned(GraphicSignatures) then\r\n begin\r\n P := AStream.Position;\r\n try\r\n for I := 0 to GraphicSignatures.Count - 1 do\r\n begin\r\n S := TGraphicSignature(GraphicSignatures[I]);\r\n if S.CheckSignature(AStream) then\r\n begin\r\n Result := S.GraphicClass;\r\n Exit;\r\n end;\r\n end;\r\n finally\r\n AStream.Position := P;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction GetGraphicObject(AStream: TStream): TGraphic;\r\nvar\r\n LOnProc: TJvGetGraphicClassEvent;\r\nbegin\r\n LOnProc := nil;\r\n Result := GetGraphicObject(AStream, nil, LOnProc);\r\nend;\r\n\r\nfunction GetGraphicObject(AStream: TStream; ASender: TObject; AOnProc: TJvGetGraphicClassEvent): TGraphic; overload;\r\nvar\r\n GraphicClass: TGraphicClass;\r\nbegin\r\n // Figure out which Graphic class is...\r\n GraphicClass := GetGraphicClass(AStream);\r\n // Call user event\r\n if Assigned(AOnProc) and (AStream is TMemoryStream) then\r\n AOnProc(ASender, TMemoryStream(AStream), GraphicClass);\r\n // If we got one, load it..\r\n if Assigned(GraphicClass) then\r\n begin\r\n Result := GraphicClass.Create;\r\n Result.LoadFromStream(AStream);\r\n end\r\n else // nope.\r\n Result := nil;\r\nend;\r\n\r\nfunction PointChildToParent(APoint: TPoint; AChild: TControl; AParent: TWinControl): TPoint;\r\nvar\r\n LParent: TWinControl;\r\nbegin\r\n if AChild = nil then\r\n raise EInvalidOperation.Create(RsEChildControlMissing);\r\n\r\n if AParent = nil then\r\n AParent := AChild.Parent;\r\n if AParent = nil then\r\n raise EInvalidOperation.CreateFmt(SParentRequired, [AChild.Name]);\r\n Result := APoint;\r\n LParent := AChild.Parent;\r\n if AParent.ContainsControl(AChild) then\r\n begin\r\n Inc(Result.X, AChild.Left);\r\n Inc(Result.Y, AChild.Top);\r\n while (LParent <> nil) do\r\n begin\r\n if (LParent.Parent <> nil) and (LParent <> AParent) then\r\n begin\r\n Inc(Result.X, LParent.Left);\r\n Inc(Result.Y, LParent.Top);\r\n end;\r\n if LParent = AParent then\r\n Break\r\n else\r\n LParent := LParent.Parent;\r\n end;\r\n end else\r\n raise EInvalidOperation.CreateFmt(SParentGivenNotAParent, [AChild.Name]);\r\nend;\r\n\r\nfunction RectChildToParent(ARect: TRect; AChild: TControl; AParent: TWinControl = nil): TRect;\r\nvar\r\n Pt1, Pt2: TPoint;\r\nbegin\r\n Pt1 := PointChildToParent(ARect.TopLeft, AChild, AParent);\r\n Pt2 := PointChildToParent(ARect.BottomRight, AChild, AParent);\r\n Result := Rect(Pt1.X, Pt1.Y, Pt2.X, Pt2.Y);\r\nend;\r\n\r\nfunction RectClientToScreen(AClientRect: TRect; AControl: TControl): TRect;\r\nbegin\r\n Result.TopLeft := AControl.ClientToScreen(AClientRect.TopLeft);\r\n Result.BottomRight := AControl.ClientToScreen(AClientRect.BottomRight);\r\nend;\r\n\r\nfunction RectScreenToClient(AScreenRect: TRect; AControl: TControl): TRect;\r\nbegin\r\n Result.TopLeft := AControl.ScreenToClient(AScreenRect.TopLeft);\r\n Result.BottomRight := AControl.ScreenToClient(AScreenRect.BottomRight);\r\nend;\r\n\r\nfunction MapControlRect(ACtlFrom, ACtlTo: TControl; AClientRect: TRect):\r\n TRect;\r\nbegin\r\n Result := RectClientToScreen(AClientRect, ACtlFrom);\r\n Result := RectScreenToClient(Result, ACtlTo);\r\nend;\r\n\r\nfunction MapControlPoint(ACtlFrom, ACtlTo: TControl; APoint: TPoint): TPoint;\r\nbegin\r\n Result := ACtlFrom.ClientToScreen(APoint);\r\n Result := ACtlTo.ScreenToClient(Result);\r\nend;\r\n\r\nfunction MapWindowRect(hWndFrom, hWndTo: HWND; ARect: TRect): TRect;\r\nbegin\r\n MapWindowPoints(hWndFrom, hWndTo, ARect, 2);\r\n Result := ARect;\r\nend;\r\n\r\nfunction GetControlRect(AControl: TControl): TRect;\r\nbegin\r\n Assert(AControl <> nil, 'Control is nil');\r\n\r\n Result := Rect(0, 0, AControl.Width, AControl.Height);\r\nend;\r\n\r\nfunction GetControlScreenRect(AControl: TControl): TRect;\r\nbegin\r\n Assert(AControl <> nil, 'Control is nil');\r\n\r\n Result := AControl.BoundsRect;\r\n if AControl.Parent <> nil then\r\n Result := RectClientToScreen(Result, AControl.Parent);\r\nend;\r\n\r\nfunction GetControlDC(Control: TControl; var WindowHandle: HWND): HDC;\r\nvar\r\n lWinCtl: TWinControl;\r\nbegin\r\n Result := 0;\r\n if Control = nil then\r\n Exit;\r\n if Control is TWinControl then\r\n begin\r\n lWinCtl := TWinControl(Control);\r\n if not lWinCtl.HandleAllocated then\r\n Exit;\r\n Result := GetDC(lWinCtl.Handle);\r\n WindowHandle := lWinCtl.Handle;\r\n end\r\n else\r\n begin\r\n lWinCtl := Control.Parent;\r\n if lWinCtl = nil then\r\n raise EInvalidOperation.CreateFmt(SParentRequired, [Control.Name]);\r\n\r\n if not lWinCtl.HandleAllocated then\r\n Exit;\r\n Result := GetDC(lWinCtl.Handle);\r\n WindowHandle := lWinCtl.Handle;\r\n\r\n SetViewportOrgEx(Result, Control.Left, Control.Top, nil);\r\n IntersectClipRect(Result, 0, 0, Control.Width, Control.Height);\r\n end;\r\nend;\r\n\r\nfunction GetControlWindowDC(Control: TControl; var WindowHandle: HWND): HDC;\r\nvar\r\n lWinCtl: TWinControl;\r\nbegin\r\n Result := 0;\r\n if Control = nil then\r\n Exit;\r\n if Control is TWinControl then\r\n begin\r\n lWinCtl := TWinControl(Control);\r\n Result := GetWindowDC(lWinCtl.Handle);\r\n WindowHandle := lWinCtl.Handle;\r\n end\r\n else\r\n begin\r\n Result:= GetControlDC(Control,WindowHandle);\r\n end;\r\nend;\r\n\r\nfunction GetContainerMaxBoundsRect(AContainer: TWinControl): TRect;\r\nvar\r\n I: Integer;\r\nbegin\r\n if (AContainer = nil) or not Assigned(AContainer) then\r\n Exit;\r\n\r\n if AContainer.ControlCount = 0 then\r\n Result := AContainer.BoundsRect\r\n else\r\n begin\r\n for I := 0 to AContainer.ControlCount - 1 do\r\n begin\r\n with AContainer.Controls[I] do\r\n begin\r\n if I = 0 then\r\n Result := Bounds(Left, Top, Width, Height)\r\n else\r\n begin\r\n if Top < Result.Top then\r\n Result.Top := Top;\r\n if Left < Result.Left then\r\n Result.Left := Left;\r\n if Left + Width > Result.Right then\r\n Result.Right := Left + Width;\r\n if Top + Height > Result.Bottom then\r\n Result.Bottom := Top + Height;\r\n end;\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction GetParentWindow(ASender: TWinControl): HWND;\r\nvar\r\n Last, P: HWND;\r\nbegin\r\n if ASender = nil then\r\n raise EInvalidOperation.Create(RsEChildControlMissing);\r\n\r\n Last := ASender.Handle;\r\n P := GetParent(ASender.Handle);\r\n while P <> 0 do\r\n begin\r\n Last := P;\r\n P := GetParent(P);\r\n end;\r\n Result := Last;\r\nend;\r\n\r\nfunction BeginClipRect(DC: HDC; AClipRect: TRect; fnMode: Integer): Integer; \r\nvar\r\n MyRgn: HRGN;\r\nbegin\r\n Result := RGN_ERROR;\r\n if not IsRectEmpty(AClipRect) then\r\n begin\r\n MyRgn := CreateRectRgnIndirect(AClipRect);\r\n try\r\n Result := ExtSelectClipRgn(DC, MyRgn, fnMode);\r\n finally\r\n DeleteObject(MyRgn);\r\n end;\r\n end;\r\nend;\r\n\r\nfunction EndClipRect(DC: HDC): Integer;\r\nbegin\r\n Result := SelectClipRgn(DC, 0);\r\nend;\r\n\r\nfunction GetTopOwner(aCmp: TComponent): TComponent;\r\nbegin\r\n if aCmp = nil then\r\n Result := nil\r\n else\r\n if aCmp.Owner <> nil then\r\n Result := GetTopOwner(aCmp.Owner)\r\n else\r\n Result := aCmp;\r\nend;\r\n\r\nfunction GetTopForm(aCmp: TComponent): TCustomForm;\r\nbegin\r\n if aCmp is TControl then\r\n begin\r\n while (aCmp <> nil) and not (aCmp is TCustomForm) do\r\n aCmp := TControl(aCmp).Parent;\r\n end\r\n else // aCmp is TComponent\r\n while (aCmp <> nil) and not (aCmp is TCustomForm) do\r\n aCmp := aCmp.Owner;\r\n\r\n Result := TCustomForm(aCmp);\r\nend;\r\n\r\nfunction IsOwnedComponent(aCmp, aOwner: TComponent): Boolean;\r\nbegin\r\n Result := False;\r\n if not (Assigned(aCmp) or Assigned(aOwner)) then\r\n Exit;\r\n\r\n Result := True;\r\n while aCmp.Owner <> nil do\r\n begin\r\n if aCmp.Owner = aOwner then\r\n Exit;\r\n aCmp := aCmp.Owner;\r\n end;\r\n Result := False;\r\nend;\r\n\r\nfunction IsChildWindow(const AChild, AParent: THandle): Boolean;\r\nvar\r\n LParent: HWND;\r\nbegin\r\n { Determines whether a window is the child (or grand^x-child) of another window }\r\n LParent := AChild;\r\n if LParent = AParent then\r\n Result := False // (ahuser) a parent is no a child of itself\r\n else\r\n begin\r\n while (LParent <> AParent) and (LParent <> NullHandle) do\r\n LParent := GetParent(LParent);\r\n Result := (LParent = AParent) and (LParent <> NullHandle);\r\n end;\r\nend;\r\n\r\nfunction GenerateUniqueComponentName(AOwner, AComponent: TComponent; const\r\n AComponentName: string = ''): string;\r\n\r\n function ValidateName(const AName: string): String;\r\n var\r\n I: Integer;\r\n Ignore : Boolean;\r\n C : Char;\r\n begin\r\n Ignore := True;\r\n Result := '';\r\n for I := 1 to Length(AName) do\r\n begin\r\n C := AName[I];\r\n if CharInSet(C, ['A'..'Z', 'a'..'z', '_']) or\r\n ((Result <> '') and CharInSet(C, ['0'..'9'])) then\r\n begin\r\n Ignore := False;\r\n Result := Result+C;\r\n end\r\n else if Result <> '' then\r\n begin\r\n if not Ignore then\r\n Result := Result+'_';\r\n Ignore := True;\r\n end;\r\n end;\r\n end;\r\n\r\n function GenerateName(const AName: string; ANumber: Integer): string;\r\n begin\r\n Result := ValidateName (AName);\r\n if Assigned(AOwner) and (AOwner.Name <> '') then\r\n Result := AOwner.Name + '_' + Result;\r\n if ANumber > 0 then\r\n Result := Result + IntToStr(ANumber);\r\n end;\r\n\r\n function IsUnique(const AName: string): Boolean;\r\n var\r\n I: Integer;\r\n begin\r\n Result := True;\r\n if AName <> '' then\r\n for I := 0 to AOwner.ComponentCount - 1 do\r\n if (AOwner.Components[I] <> AComponent) and\r\n (CompareText(AOwner.Components[I].Name, AName) = 0) then\r\n begin\r\n Result := False;\r\n Break;\r\n end;\r\n end;\r\n\r\nvar\r\n I: Integer;\r\nbegin\r\n if not Assigned(AOwner) then\r\n Result := ''\r\n else\r\n for I := 0 to MaxInt do\r\n begin\r\n if (AComponentName <> '') then\r\n Result := GenerateName(AComponentName, I)\r\n else\r\n if Assigned(AComponent) then\r\n Result := GenerateName(AComponent.ClassName, I)\r\n else\r\n Result := GenerateName('', I);\r\n if IsUnique(Result) then\r\n Break;\r\n end;\r\nend;\r\n\r\nfunction ReplaceComponentReference(This, NewReference: TComponent; var VarReference: TComponent): Boolean;\r\nbegin\r\n Result := (VarReference <> NewReference) and Assigned(This);\r\n if Result then\r\n begin\r\n if Assigned(VarReference) then\r\n VarReference.RemoveFreeNotification(This);\r\n VarReference := NewReference;\r\n if Assigned(VarReference) then\r\n VarReference.FreeNotification(This);\r\n end;\r\nend;\r\n\r\nfunction ReplaceImageListReference(This: TComponent; NewReference: TCustomImageList;\r\n var VarReference: TCustomImageList; ChangeLink: TChangeLink): Boolean;\r\nbegin\r\n Result := (VarReference <> NewReference) and Assigned(This);\r\n if Result then\r\n begin\r\n if Assigned(VarReference) then\r\n begin\r\n VarReference.RemoveFreeNotification(This);\r\n VarReference.UnRegisterChanges(ChangeLink);\r\n end;\r\n VarReference := NewReference;\r\n if Assigned(VarReference) then\r\n begin\r\n VarReference.RegisterChanges(ChangeLink);\r\n VarReference.FreeNotification(This);\r\n end;\r\n end;\r\nend;\r\n\r\nfunction IsSubControlFocused(AControl: TWinControl): Boolean;\r\nvar\r\n Form: TCustomForm;\r\n Ctrl: TWinControl;\r\nbegin\r\n Result := False;\r\n if AControl = nil then\r\n Exit;\r\n\r\n if AControl.Focused then\r\n Result := True\r\n else\r\n begin\r\n Form := GetParentForm(AControl);\r\n if Form <> nil then\r\n begin\r\n Ctrl := Form.ActiveControl;\r\n while Ctrl <> nil do\r\n begin\r\n if Ctrl = AControl then\r\n begin\r\n Result := True;\r\n Exit;\r\n end;\r\n Ctrl := Ctrl.Parent;\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\ninitialization\r\n {$IFDEF UNITVERSIONING}\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n {$ENDIF UNITVERSIONING}\r\n InitScreenCursors;\r\n\r\nfinalization\r\n FreeAndNil(DrawBitmap);\r\n FreeAndNil(GraphicSignatures);\r\n {$IFDEF UNITVERSIONING}\r\n UnregisterUnitVersion(HInstance);\r\n {$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvJanTreeView.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvJanTreeView.PAS, released on 2002-06-15.\r\n\r\nThe Initial Developer of the Original Code is Jan Verhoeven [jan1 dott verhoeven att wxs dott nl]\r\nPortions created by Jan Verhoeven are Copyright (C) 2002 Jan Verhoeven.\r\nAll Rights Reserved.\r\n\r\nContributor(s): Robert Love [rlove att slcdug dott org].\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvJanTreeView.pas 13104 2011-09-07 06:50:43Z obones $\r\n\r\nunit JvJanTreeView;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows,\r\n ShellAPI, Messages,\r\n SysUtils, Classes,\r\n Graphics, Controls, Forms, Dialogs, ComCtrls, Menus;\r\n\r\ntype\r\n TGetVarEvent = procedure(Sender: TObject; VarName: string;\r\n var Value: Extended; var Found: Boolean) of object;\r\n\r\n TParseErrorEvent = procedure(Sender: TObject; ParseError: Integer) of object;\r\n\r\nconst\r\n ParserStackSize = 15;\r\n MaxFuncNameLen = 5;\r\n ExpLimit = 11356;\r\n SqrLimit = 1E2466;\r\n MaxExpLen = 4;\r\n TotalErrors = 7;\r\n ErrParserStack = 1;\r\n ErrBadRange = 2;\r\n ErrExpression = 3;\r\n ErrOperator = 4;\r\n ErrOpenParen = 5;\r\n ErrOpCloseParen = 6;\r\n ErrInvalidNum = 7;\r\n\r\ntype\r\n ErrorRange = 0..TotalErrors;\r\n\r\n TokenTypes = (ttPlus, ttMinus, ttTimes, ttDivide, ttExpo, ttOParen,\r\n ttCParen, ttNum, ttFunc, ttEol, ttBad, ttErr, ttModu);\r\n\r\n TokenRec = record\r\n State: Byte;\r\n case Byte of\r\n 0:\r\n (Value: Extended);\r\n 2:\r\n (FuncName: string[MaxFuncNameLen]);\r\n end;\r\n\r\ntype\r\n TStack = array [1..ParserStackSize] of TokenRec;\r\n TStackTop = 0..ParserStackSize;\r\n\r\n TJvMathParser = class(TComponent)\r\n private\r\n FInput: string;\r\n FOnGetVar: TGetVarEvent;\r\n FOnParseError: TParseErrorEvent;\r\n FPosition: Word;\r\n FParseError: Boolean;\r\n FParseValue: Extended;\r\n protected\r\n CurrToken: TokenRec;\r\n MathError: Boolean;\r\n Stack: TStack;\r\n StackTop: TStackTop;\r\n TokenError: ErrorRange;\r\n TokenLen: Word;\r\n TokenType: TokenTypes;\r\n function GotoState(Production: Word): Word;\r\n function IsFunc(S: string): Boolean;\r\n function IsVar(var Value: Extended): Boolean;\r\n function NextToken: TokenTypes;\r\n procedure Push(Token: TokenRec);\r\n procedure Pop(var Token: TokenRec);\r\n procedure Reduce(Reduction: Word);\r\n procedure Shift(State: Word);\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n procedure Parse;\r\n property Position: Word read FPosition write FPosition;\r\n property ParseError: Boolean read FParseError write FParseError;\r\n property ParseValue: Extended read FParseValue write FParseValue;\r\n published\r\n property OnGetVar: TGetVarEvent read FOnGetVar write FOnGetVar;\r\n property OnParseError: TParseErrorEvent read FOnParseError write FOnParseError;\r\n property ParseString: string read FInput write FInput;\r\n end;\r\n\r\n TTreeKeyMappings = class(TPersistent)\r\n private\r\n FAddNode: TShortCut;\r\n FInsertNode: TShortCut;\r\n FAddChildNode: TShortCut;\r\n FDeleteNode: TShortCut;\r\n FDuplicateNode: TShortCut;\r\n FEditNode: TShortCut;\r\n FSaveTree: TShortCut;\r\n FLoadTree: TShortCut;\r\n FCloseTree: TShortCut;\r\n FSaveTreeAs: TShortCut;\r\n FFindNode: TShortCut;\r\n procedure SetAddNode(const Value: TShortCut);\r\n procedure SetInsertNode(const Value: TShortCut);\r\n procedure SetDeleteNode(const Value: TShortCut);\r\n procedure SetAddChildNode(const Value: TShortCut);\r\n procedure SetDuplicateNode(const Value: TShortCut);\r\n procedure SetEditNode(const Value: TShortCut);\r\n procedure SetLoadTree(const Value: TShortCut);\r\n procedure SetSaveTree(const Value: TShortCut);\r\n procedure SetCloseTree(const Value: TShortCut);\r\n procedure SetSaveTreeAs(const Value: TShortCut);\r\n procedure SetFindNode(const Value: TShortCut);\r\n published\r\n property AddNode: TShortCut read FAddNode write SetAddNode;\r\n property DeleteNode: TShortCut read FDeleteNode write SetDeleteNode;\r\n property InsertNode: TShortCut read FInsertNode write SetInsertNode;\r\n property AddChildNode: TShortCut read FAddChildNode write SetAddChildNode;\r\n property DuplicateNode: TShortCut read FDuplicateNode write SetDuplicateNode;\r\n property EditNode: TShortCut read FEditNode write SetEditNode;\r\n property FindNode: TShortCut read FFindNode write SetFindNode;\r\n property LoadTree: TShortCut read FLoadTree write SetLoadTree;\r\n property SaveTree: TShortCut read FSaveTree write SetSaveTree;\r\n property SaveTreeAs: TShortCut read FSaveTreeAs write SetSaveTreeAs;\r\n property CloseTree: TShortCut read FCloseTree write SetCloseTree;\r\n end;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvJanTreeView = class(TTreeView)\r\n private\r\n FParser: TJvMathParser;\r\n FParseError: Boolean;\r\n FKeyMappings: TTreeKeyMappings;\r\n FKeyMappingsEnabled: Boolean;\r\n FVarList: TStringList;\r\n FColorFormulas: Boolean;\r\n FFormuleColor: TColor;\r\n FDefaultExt: string;\r\n FFileName: TFileName;\r\n FSearchText: string;\r\n procedure ParseVariables;\r\n procedure NodeDuplicate(ATree: TJvJanTreeView; FromNode, ToNode: TTreeNode);\r\n procedure SetKeyMappings(const Value: TTreeKeyMappings);\r\n procedure SetKeyMappingsEnabled(const Value: Boolean);\r\n procedure SetupKeyMappings;\r\n procedure ParserGetVar(Sender: TObject; VarName: string; var Value: Extended; var Found: Boolean);\r\n procedure ParserParseError(Sender: TObject; ParseError: Integer);\r\n procedure DoCustomDrawItem(Sender: TCustomTreeView; Node: TTreeNode; State: TCustomDrawState; var DefaultDraw: Boolean);\r\n procedure SetColorFormulas(const Value: Boolean);\r\n procedure SetFormuleColor(const Value: TColor);\r\n procedure SetDefaultExt(const Value: string);\r\n procedure SetFileName(const Value: TFileName);\r\n protected\r\n procedure DragOver(Source: TObject; X, Y: Integer; State: TDragState; var Accept: Boolean); override;\r\n procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;\r\n procedure DblClick; override;\r\n procedure KeyUp(var Key: Word; Shift: TShiftState); override;\r\n procedure KeyPress(var Key: Char); override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n procedure DuplicateNode;\r\n procedure DragDrop(Source: TObject; X, Y: Integer); override;\r\n procedure DoAddNode;\r\n procedure DoAddChildNode;\r\n procedure DoDeleteNode;\r\n procedure DoInsertNode;\r\n procedure DoEditNode;\r\n procedure DoFindNode;\r\n procedure DoLoadTree;\r\n procedure DoSaveTree;\r\n procedure DoSaveTreeAs;\r\n procedure DoCloseTree;\r\n procedure Recalculate;\r\n published\r\n property KeyMappings: TTreeKeyMappings read FKeyMappings write SetKeyMappings;\r\n property KeyMappingsEnabled: Boolean read FKeyMappingsEnabled write SetKeyMappingsEnabled default True;\r\n property ColorFormulas: Boolean read FColorFormulas write SetColorFormulas default True;\r\n property FormuleColor: TColor read FFormuleColor write SetFormuleColor;\r\n property FileName: TFileName read FFileName write SetFileName;\r\n property DefaultExt: string read FDefaultExt write SetDefaultExt;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvJanTreeView.pas $';\r\n Revision: '$Revision: 13104 $';\r\n Date: '$Date: 2011-09-07 08:50:43 +0200 (mer. 07 sept. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n {$IFNDEF COMPILER12_UP}\r\n JvJCLUtils,\r\n {$ENDIF ~COMPILER12_UP}\r\n JvConsts, JvResources, JvTypes;\r\n\r\n//=== { TJvJanTreeView } =====================================================\r\n\r\nconstructor TJvJanTreeView.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n DragMode := dmAutomatic;\r\n FDefaultExt := 'txt';\r\n FKeyMappings := TTreeKeyMappings.Create;\r\n SetupKeyMappings;\r\n FColorFormulas := True;\r\n FKeyMappingsEnabled := True;\r\n FParser := TJvMathParser.Create(Self);\r\n FParser.OnGetVar := ParserGetVar;\r\n FParser.OnParseError := ParserParseError;\r\n FVarList := TStringList.Create;\r\n OnCustomDrawItem := DoCustomDrawItem;\r\nend;\r\n\r\ndestructor TJvJanTreeView.Destroy;\r\nbegin\r\n FParser.Free;\r\n FKeyMappings.Free;\r\n FVarList.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvJanTreeView.SetupKeyMappings;\r\nbegin\r\n with FKeyMappings do\r\n begin\r\n AddChildNode := TextToShortCut('Ctrl+Ins');\r\n AddNode := TextToShortCut('Ctrl+Shift+Ins');\r\n InsertNode := TextToShortCut('Shift+Ins');\r\n DeleteNode := TextToShortCut('Shift+Del');\r\n DuplicateNode := TextToShortCut('Ctrl+D');\r\n EditNode := TextToShortCut('F2');\r\n FindNode := TextToShortCut('Ctrl+F');\r\n LoadTree := TextToShortCut('Ctrl+O');\r\n SaveTree := TextToShortCut('Ctrl+S');\r\n CloseTree := TextToShortCut('Ctrl+Alt+C');\r\n SaveTreeAs := TextToShortCut('Ctrl+Alt+S');\r\n end;\r\nend;\r\n\r\nprocedure TJvJanTreeView.DblClick;\r\nvar\r\n N: TTreeNode;\r\n S: string;\r\nbegin\r\n if Selected <> nil then\r\n begin\r\n N := Selected;\r\n S := N.Text;\r\n if (Copy(S, 1, 7) = 'http://') or (Copy(S, 1, 7) = 'mailto:') then\r\n ShellExecute(Handle, 'open', PChar(S), nil, nil, SW_SHOWNORMAL);\r\n end;\r\n if Assigned(OnDblClick) then\r\n OnDblClick(Self);\r\nend;\r\n\r\nprocedure TJvJanTreeView.DoAddChildNode;\r\nvar\r\n N: TTreeNode;\r\nbegin\r\n if Selected <> nil then\r\n begin\r\n N := Selected;\r\n N := Items.AddChild(N, RsNewNode);\r\n Selected := N;\r\n end;\r\nend;\r\n\r\nprocedure TJvJanTreeView.DoAddNode;\r\nvar\r\n N: TTreeNode;\r\nbegin\r\n Items.BeginUpdate;\r\n N := Items.Add(Selected, RsNewNode);\r\n Items.EndUpdate;\r\n Selected := N;\r\nend;\r\n\r\nprocedure TJvJanTreeView.DoDeleteNode;\r\nbegin\r\n if Selected <> nil then\r\n Items.Delete(Selected);\r\nend;\r\n\r\nprocedure TJvJanTreeView.DoEditNode;\r\nvar\r\n N: TTreeNode;\r\nbegin\r\n if Selected <> nil then\r\n begin\r\n N := Selected;\r\n N.EditText;\r\n end;\r\nend;\r\n\r\nprocedure TJvJanTreeView.DoInsertNode;\r\nvar\r\n N: TTreeNode;\r\nbegin\r\n if Selected <> nil then\r\n begin\r\n N := Selected;\r\n Items.BeginUpdate;\r\n N := Items.Insert(N, RsNewNode);\r\n Items.EndUpdate;\r\n Selected := N;\r\n end;\r\nend;\r\n\r\nprocedure TJvJanTreeView.DragDrop(Source: TObject; X, Y: Integer);\r\nvar\r\n HitTest: THitTests;\r\n N: TTreeNode;\r\nbegin\r\n inherited DragDrop(Source, X, Y);\r\n HitTest := Self.GetHitTestInfoAt(X, Y);\r\n if htOnLabel in HitTest then\r\n begin\r\n N := Self.GetNodeAt(X, Y);\r\n if Source = Self then\r\n begin\r\n if Selected = nil then\r\n Exit;\r\n Selected.MoveTo(N, naInsert);\r\n end;\r\n end;\r\n if Assigned(OnDragDrop) then\r\n OnDragDrop(Self, Source, X, Y);\r\nend;\r\n\r\nprocedure TJvJanTreeView.DragOver(Source: TObject; X, Y: Integer;\r\n State: TDragState; var Accept: Boolean);\r\nbegin\r\n inherited DragOver(Source, X, Y, State, Accept);\r\n Accept := (Source = Self);\r\n if Assigned(OnDragOver) then\r\n OnDragOver(Self, Source, X, Y, State, Accept);\r\nend;\r\n\r\nprocedure TJvJanTreeView.DuplicateNode;\r\nvar\r\n Node, NewNode: TTreeNode;\r\nbegin\r\n if Selected <> nil then\r\n begin\r\n Node := Selected;\r\n NewNode := Items.Add(Node, Node.Text);\r\n NodeDuplicate(Self, Node, NewNode);\r\n end;\r\nend;\r\n\r\nprocedure TJvJanTreeView.KeyUp(var Key: Word; Shift: TShiftState);\r\nvar\r\n MKey: Word;\r\n MShift: TShiftState;\r\n\r\n function MLoadTree: Boolean;\r\n begin\r\n ShortCutToKey(KeyMappings.LoadTree, MKey, MShift);\r\n Result := ((MKey = Key) and (MShift = Shift));\r\n end;\r\n\r\n function MSaveTree: Boolean;\r\n begin\r\n ShortCutToKey(KeyMappings.SaveTree, MKey, MShift);\r\n Result := ((MKey = Key) and (MShift = Shift));\r\n end;\r\n\r\n function MSaveTreeAs: Boolean;\r\n begin\r\n ShortCutToKey(KeyMappings.SaveTreeAs, MKey, MShift);\r\n Result := ((MKey = Key) and (MShift = Shift));\r\n end;\r\n\r\n function MCloseTree: Boolean;\r\n begin\r\n ShortCutToKey(KeyMappings.CloseTree, MKey, MShift);\r\n Result := ((MKey = Key) and (MShift = Shift));\r\n end;\r\n\r\n function MAddNode: Boolean;\r\n begin\r\n ShortCutToKey(KeyMappings.AddNode, MKey, MShift);\r\n Result := ((MKey = Key) and (MShift = Shift));\r\n end;\r\n\r\n function MDeleteNode: Boolean;\r\n begin\r\n ShortCutToKey(KeyMappings.DeleteNode, MKey, MShift);\r\n Result := ((MKey = Key) and (MShift = Shift));\r\n end;\r\n\r\n function MInsertNode: Boolean;\r\n begin\r\n ShortCutToKey(KeyMappings.InsertNode, MKey, MShift);\r\n Result := ((MKey = Key) and (MShift = Shift));\r\n end;\r\n\r\n function MAddChildNode: Boolean;\r\n begin\r\n ShortCutToKey(KeyMappings.AddChildNode, MKey, MShift);\r\n Result := ((MKey = Key) and (MShift = Shift));\r\n end;\r\n\r\n function MDuplicateNode: Boolean;\r\n begin\r\n ShortCutToKey(KeyMappings.DuplicateNode, MKey, MShift);\r\n Result := ((MKey = Key) and (MShift = Shift));\r\n end;\r\n\r\n function MEditNode: Boolean;\r\n begin\r\n ShortCutToKey(KeyMappings.EditNode, MKey, MShift);\r\n Result := ((MKey = Key) and (MShift = Shift));\r\n end;\r\n\r\n function MFindNode: Boolean;\r\n begin\r\n ShortCutToKey(KeyMappings.FindNode, MKey, MShift);\r\n Result := ((MKey = Key) and (MShift = Shift));\r\n end;\r\n\r\nbegin\r\n inherited KeyUp(Key, Shift);\r\n if KeyMappingsEnabled then\r\n begin\r\n if MAddNode then\r\n DoAddNode\r\n else\r\n if MDeleteNode then\r\n DoDeleteNode\r\n else\r\n if MInsertNode then\r\n DoInsertNode\r\n else\r\n if MAddChildNode then\r\n DoAddChildNode\r\n else\r\n if MDuplicateNode then\r\n DuplicateNode\r\n else\r\n if MEditNode then\r\n DoEditNode\r\n else\r\n if MFindNode then\r\n DoFindNode\r\n else\r\n if MLoadTree then\r\n DoLoadTree\r\n else\r\n if MSaveTree then\r\n DoSaveTree\r\n else\r\n if MSaveTreeAs then\r\n DoSaveTreeAs\r\n else\r\n if MCloseTree then\r\n DoCloseTree;\r\n end;\r\n if Assigned(OnKeyDown) then\r\n OnKeyDown(Self, Key, Shift);\r\nend;\r\n\r\nprocedure TJvJanTreeView.SetKeyMappings(const Value: TTreeKeyMappings);\r\nbegin\r\n FKeyMappings := Value;\r\nend;\r\n\r\nprocedure TJvJanTreeView.SetKeyMappingsEnabled(const Value: Boolean);\r\nbegin\r\n FKeyMappingsEnabled := Value;\r\nend;\r\n\r\nprocedure TJvJanTreeView.MouseMove(Shift: TShiftState; X, Y: Integer);\r\nvar\r\n\r\n HitTest: THitTests;\r\n\r\n N: TTreeNode;\r\n S: string;\r\nbegin\r\n\r\n HitTest := GetHitTestInfoAt(X, Y);\r\n if htOnLabel in HitTest then\r\n begin\r\n\r\n N := GetNodeAt(X, Y);\r\n S := N.Text;\r\n if (Copy(S, 1, 7) = 'http://') or (Copy(S, 1, 7) = 'mailto:') then\r\n Cursor := crHandPoint\r\n else\r\n Cursor := crDefault;\r\n end\r\n else\r\n Cursor := crDefault;\r\n if Assigned(OnMouseMove) then\r\n OnMouseMove(Self, Shift, X, Y);\r\nend;\r\n\r\nprocedure TJvJanTreeView.NodeDuplicate(ATree: TJvJanTreeView;\r\n FromNode, ToNode: TTreeNode);\r\nvar\r\n I: Integer;\r\nbegin\r\n if FromNode.Count > 0 then\r\n for I := 1 to FromNode.Count do\r\n begin\r\n ATree.Items.AddChild(ToNode, FromNode.Item[I - 1].Text);\r\n if FromNode.Item[I - 1].Count > 0 then\r\n NodeDuplicate(ATree, FromNode.Item[I - 1], ToNode.Item[I - 1]);\r\n end;\r\nend;\r\n\r\nprocedure TJvJanTreeView.ParserGetVar(Sender: TObject; VarName: string;\r\n var Value: Extended; var Found: Boolean);\r\nvar\r\n N: TTreeNode;\r\n Index: Integer;\r\nbegin\r\n Found := False;\r\n Index := FVarList.IndexOf(VarName);\r\n if Index <> -1 then\r\n begin\r\n N := TTreeNode(FVarList.Objects[Index]);\r\n if N.Count > 0 then\r\n try\r\n Value := StrToFloat(N.Item[0].Text);\r\n Found := True;\r\n except\r\n end;\r\n end\r\n else\r\n if LowerCase(VarName) = 'pi' then\r\n begin\r\n Value := Pi;\r\n Found := True;\r\n end;\r\nend;\r\n\r\nprocedure TJvJanTreeView.ParserParseError(Sender: TObject; ParseError: Integer);\r\nbegin\r\n FParseError := True;\r\nend;\r\n\r\nprocedure TJvJanTreeView.Recalculate;\r\nvar\r\n N, NV: TTreeNode;\r\n S: string;\r\n I, P: Integer;\r\nbegin\r\n if Items.Count = 0 then\r\n Exit;\r\n ParseVariables;\r\n for I := 0 to Items.Count - 1 do\r\n begin\r\n N := Items[I];\r\n S := N.Text;\r\n P := Pos('=', S);\r\n if P = 0 then\r\n Continue;\r\n S := Copy(S, P + 1, Length(S));\r\n if S = '' then\r\n Continue;\r\n FParser.ParseString := S;\r\n FParseError := False;\r\n FParser.Parse;\r\n if not FParseError then\r\n begin\r\n if N.Count = 0 then\r\n Items.AddChild(N, RsNew);\r\n NV := N.Item[0];\r\n NV.Text := FloatToStr(FParser.ParseValue);\r\n end\r\n else\r\n begin\r\n ShowMessageFmt(RsRecalculateErr, [S]);\r\n Exit;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvJanTreeView.ParseVariables;\r\nvar\r\n I, P: Integer;\r\n N: TTreeNode;\r\n S: string;\r\nbegin\r\n FVarList.Clear;\r\n if Items.Count = 0 then\r\n Exit;\r\n for I := 0 to Items.Count - 1 do\r\n begin\r\n N := Items[I];\r\n S := N.Text;\r\n P := Pos('=', S);\r\n if P = 0 then\r\n Continue;\r\n S := Copy(S, 1, P - 1);\r\n if S <> '' then\r\n FVarList.AddObject(S, TObject(N));\r\n end;\r\nend;\r\n\r\n\r\n\r\nprocedure TJvJanTreeView.DoCustomDrawItem(Sender: TCustomTreeView;\r\n Node: TTreeNode; State: TCustomDrawState; var DefaultDraw: Boolean);\r\n\r\nvar\r\n S: string;\r\n R: TRect;\r\nbegin\r\n S := Node.Text;\r\n if (cdsSelected in State) or (cdsFocused in State) then\r\n begin\r\n DefaultDraw := True;\r\n Exit;\r\n end;\r\n if (Copy(S, 1, 7) = 'http://') or (Copy(S, 1, 7) = 'mailto:') then\r\n with Canvas do\r\n begin\r\n R := Node.DisplayRect(True);\r\n Font := Self.Font;\r\n Font.Style := Font.Style + [fsUnderline];\r\n Font.Color := clBlue;\r\n TextRect(R, R.Left, R.Top, S);\r\n DefaultDraw := False;\r\n end\r\n else\r\n if FColorFormulas and (Pos('=', S) > 0) then\r\n with Canvas do\r\n begin\r\n R := Node.DisplayRect(True);\r\n Font := Self.Font;\r\n Font.Color := FFormuleColor;\r\n TextRect(R, R.Left, R.Top, S);\r\n DefaultDraw := False;\r\n end\r\n else\r\n DefaultDraw := True;\r\nend;\r\n\r\nprocedure TJvJanTreeView.SetColorFormulas(const Value: Boolean);\r\nbegin\r\n FColorFormulas := Value;\r\nend;\r\n\r\nprocedure TJvJanTreeView.SetFormuleColor(const Value: TColor);\r\nbegin\r\n FFormuleColor := Value;\r\nend;\r\n\r\nprocedure TTreeKeyMappings.SetLoadTree(const Value: TShortCut);\r\nbegin\r\n FLoadTree := Value;\r\nend;\r\n\r\nprocedure TTreeKeyMappings.SetSaveTree(const Value: TShortCut);\r\nbegin\r\n FSaveTree := Value;\r\nend;\r\n\r\nprocedure TJvJanTreeView.DoLoadTree;\r\nvar\r\n Dlg: TOpenDialog;\r\n S: string;\r\nbegin\r\n Dlg := TOpenDialog.Create(Self);\r\n try\r\n Dlg.DefaultExt := FDefaultExt;\r\n S := FDefaultExt;\r\n if S = '' then\r\n S := '*';\r\n Dlg.Filter := RsTreeViewFiles + '|*.' + S;\r\n if Dlg.Execute then\r\n begin\r\n LoadFromFile(Dlg.FileName);\r\n FFileName := Dlg.FileName;\r\n Recalculate;\r\n end;\r\n finally\r\n Dlg.Free;\r\n end;\r\nend;\r\n\r\nprocedure TJvJanTreeView.DoSaveTreeAs;\r\nvar\r\n Dlg: TSaveDialog;\r\n S: string;\r\nbegin\r\n Dlg := TSaveDialog.Create(Self);\r\n try\r\n Dlg.DefaultExt := FDefaultExt;\r\n S := FDefaultExt;\r\n if S = '' then\r\n S := '*';\r\n Dlg.Filter := RsTreeViewFiles + '|*.' + S;\r\n if Dlg.Execute then\r\n begin\r\n SaveToFile(Dlg.FileName);\r\n FFileName := Dlg.FileName;\r\n end;\r\n finally\r\n Dlg.Free;\r\n end;\r\nend;\r\n\r\nprocedure TJvJanTreeView.SetDefaultExt(const Value: string);\r\nbegin\r\n FDefaultExt := Value;\r\nend;\r\n\r\nprocedure TJvJanTreeView.SetFileName(const Value: TFileName);\r\nbegin\r\n FFileName := Value;\r\nend;\r\n\r\nprocedure TJvJanTreeView.DoCloseTree;\r\nbegin\r\n if MessageDlg(RsSaveCurrentTree, mtConfirmation, [mbYes, mbNo], 0) = mrYes then\r\n begin\r\n if FFileName <> '' then\r\n SaveToFile(FFileName)\r\n else\r\n DoSaveTreeAs;\r\n end;\r\n Items.BeginUpdate;\r\n Items.Clear;\r\n Items.EndUpdate;\r\n FFileName := '';\r\nend;\r\n\r\nprocedure TTreeKeyMappings.SetCloseTree(const Value: TShortCut);\r\nbegin\r\n FCloseTree := Value;\r\nend;\r\n\r\nprocedure TTreeKeyMappings.SetSaveTreeAs(const Value: TShortCut);\r\nbegin\r\n FSaveTreeAs := Value;\r\nend;\r\n\r\nprocedure TJvJanTreeView.DoSaveTree;\r\nbegin\r\n if FFileName <> '' then\r\n SaveToFile(FFileName)\r\n else\r\n DoSaveTreeAs;\r\nend;\r\n\r\nprocedure TTreeKeyMappings.SetFindNode(const Value: TShortCut);\r\nbegin\r\n FFindNode := Value;\r\nend;\r\n\r\nprocedure TJvJanTreeView.DoFindNode;\r\nvar\r\n N: TTreeNode;\r\n I, FR: Integer;\r\n S: string;\r\nbegin\r\n N := Selected;\r\n if N = nil then\r\n Exit;\r\n S := InputBox(RsSearch, RsSearchFor, FSearchText);\r\n if S = '' then\r\n Exit;\r\n FSearchText := S;\r\n S := LowerCase(S);\r\n FR := N.AbsoluteIndex;\r\n if FR < Items.Count - 1 then\r\n for I := FR + 1 to Items.Count - 1 do\r\n if Pos(S, LowerCase(Items[I].Text)) > 0 then\r\n begin\r\n Selected := Items[I];\r\n Exit;\r\n end;\r\n ShowMessage(Format(RsNoMoresFound, [S]));\r\nend;\r\n\r\n//=== { TJvMathParser } ======================================================\r\n\r\nconstructor TJvMathParser.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n { defaults }\r\n FInput := '';\r\nend;\r\n\r\n{ Finds the new state based on the just-completed production and the\r\n top state. }\r\n\r\nfunction TJvMathParser.GotoState(Production: Word): Word;\r\nvar\r\n State: Word;\r\nbegin\r\n Result := 0; // removes warning\r\n State := Stack[StackTop].State;\r\n if Production <= 3 then\r\n case State of\r\n 0:\r\n GotoState := 1;\r\n 9:\r\n GotoState := 19;\r\n 20:\r\n GotoState := 28;\r\n end\r\n else\r\n if Production <= 6 then\r\n case State of\r\n 0, 9, 20:\r\n GotoState := 2;\r\n 12:\r\n GotoState := 21;\r\n 13:\r\n GotoState := 22;\r\n end\r\n else\r\n if (Production <= 8) or (Production = 100) then\r\n case State of\r\n 0, 9, 12, 13, 20:\r\n GotoState := 3;\r\n 14:\r\n GotoState := 23;\r\n 15:\r\n GotoState := 24;\r\n 16:\r\n GotoState := 25;\r\n 40:\r\n GotoState := 80;\r\n end\r\n else\r\n if Production <= 10 then\r\n case State of\r\n 0, 9, 12..16, 20, 40:\r\n GotoState := 4;\r\n end\r\n else\r\n if Production <= 12 then\r\n case State of\r\n 0, 9, 12..16, 20, 40:\r\n GotoState := 6;\r\n 5:\r\n GotoState := 17;\r\n end\r\n else\r\n case State of\r\n 0, 5, 9, 12..16, 20, 40:\r\n GotoState := 8;\r\n end;\r\nend;\r\n\r\n{ Checks to see if the parser is about to read a function }\r\n\r\nfunction TJvMathParser.IsFunc(S: string): Boolean;\r\nvar\r\n P, SLen: Word;\r\n FuncName: string;\r\nbegin\r\n P := Position;\r\n FuncName := '';\r\n while (P <= Length(FInput)) and CharInSet(FInput[P], IdentifierSymbols) do\r\n begin\r\n FuncName := FuncName + FInput[P];\r\n Inc(P);\r\n end;\r\n if UpperCase(FuncName) = S then\r\n begin\r\n SLen := Length(S);\r\n CurrToken.FuncName := {$IFDEF SUPPORTS_UNICODE}UTF8Encode{$ENDIF SUPPORTS_UNICODE}(UpperCase(Copy(FInput, Position, SLen)));\r\n Position := Position + SLen;\r\n IsFunc := True;\r\n end\r\n else\r\n IsFunc := False;\r\nend;\r\n\r\nfunction TJvMathParser.IsVar(var Value: Extended): Boolean;\r\nvar\r\n VarName: string;\r\n VarFound: Boolean;\r\nbegin\r\n VarFound := False;\r\n VarName := '';\r\n while (Position <= Length(FInput)) and CharInSet(FInput[Position], IdentifierSymbols) do\r\n begin\r\n VarName := VarName + FInput[Position];\r\n Position := Position + 1;\r\n end;\r\n if Assigned(FOnGetVar) then\r\n FOnGetVar(Self, VarName, Value, VarFound);\r\n IsVar := VarFound;\r\nend;\r\n\r\n{ Gets the next Token from the Input stream }\r\n\r\nfunction TJvMathParser.NextToken: TokenTypes;\r\nvar\r\n NumString: string;\r\n TLen, NumLen: Word;\r\n Check: Integer;\r\n Ch: Char;\r\n Decimal: Boolean;\r\nbegin\r\n NextToken := ttBad;\r\n while (Position <= Length(FInput)) and (FInput[Position] = ' ') do\r\n Position := Position + 1;\r\n TokenLen := Position;\r\n if Position > Length(FInput) then\r\n begin\r\n NextToken := ttEol;\r\n TokenLen := 0;\r\n Exit;\r\n end;\r\n Ch := UpCase(FInput[Position]);\r\n if Ch = '!' then\r\n begin\r\n NextToken := ttErr;\r\n TokenLen := 0;\r\n Exit;\r\n end;\r\n if CharInSet(Ch, ['0'..'9', '.']) then\r\n begin\r\n NumString := '';\r\n TLen := Position;\r\n Decimal := False;\r\n while (TLen <= Length(FInput)) and\r\n (CharInSet(FInput[TLen], DigitSymbols) or\r\n ((FInput[TLen] = '.') and (not Decimal))) do\r\n begin\r\n NumString := NumString + FInput[TLen];\r\n if Ch = '.' then\r\n Decimal := True;\r\n Inc(TLen);\r\n end;\r\n if (TLen = 2) and (Ch = '.') then\r\n begin\r\n NextToken := ttBad;\r\n TokenLen := 0;\r\n Exit;\r\n end;\r\n if (TLen <= Length(FInput)) and (UpCase(FInput[TLen]) = 'E') then\r\n begin\r\n NumString := NumString + 'E';\r\n Inc(TLen);\r\n if CharInSet(FInput[TLen], ['+', '-']) then\r\n begin\r\n NumString := NumString + FInput[TLen];\r\n Inc(TLen);\r\n end;\r\n NumLen := 1;\r\n while (TLen <= Length(FInput)) and CharInSet(FInput[TLen], DigitSymbols) and\r\n (NumLen <= MaxExpLen) do\r\n begin\r\n NumString := NumString + FInput[TLen];\r\n Inc(NumLen);\r\n Inc(TLen);\r\n end;\r\n end;\r\n if NumString[1] = '.' then\r\n NumString := '0' + NumString;\r\n Val(NumString, CurrToken.Value, Check);\r\n if Check <> 0 then\r\n begin\r\n MathError := True;\r\n TokenError := ErrInvalidNum;\r\n Position := Position + Pred(Check);\r\n end\r\n else\r\n begin\r\n NextToken := ttNum;\r\n Position := Position + System.Length(NumString);\r\n TokenLen := Position - TokenLen;\r\n end;\r\n Exit;\r\n end\r\n else\r\n if CharInSet(Ch, IdentifierLetters) then\r\n begin\r\n if IsFunc('ABS') or IsFunc('ATAN') or IsFunc('COS') or\r\n IsFunc('EXP') or IsFunc('LN') or IsFunc('ROUND') or\r\n IsFunc('SIN') or IsFunc('SQRT') or IsFunc('SQR') or IsFunc('TRUNC') then\r\n begin\r\n NextToken := ttFunc;\r\n TokenLen := Position - TokenLen;\r\n Exit;\r\n end;\r\n if IsFunc('MOD') then\r\n begin\r\n NextToken := ttModu;\r\n TokenLen := Position - TokenLen;\r\n Exit;\r\n end;\r\n if IsVar(CurrToken.Value) then\r\n begin\r\n NextToken := ttNum;\r\n TokenLen := Position - TokenLen;\r\n Exit;\r\n end\r\n else\r\n begin\r\n NextToken := ttBad;\r\n TokenLen := 0;\r\n Exit;\r\n end;\r\n end\r\n else\r\n begin\r\n case Ch of\r\n '+':\r\n NextToken := ttPlus;\r\n '-':\r\n NextToken := ttMinus;\r\n '*':\r\n NextToken := ttTimes;\r\n '/':\r\n NextToken := ttDivide;\r\n '^':\r\n NextToken := ttExpo;\r\n '(':\r\n NextToken := ttOParen;\r\n ')':\r\n NextToken := ttCParen;\r\n else\r\n begin\r\n NextToken := ttBad;\r\n TokenLen := 0;\r\n Exit;\r\n end;\r\n end;\r\n Position := Position + 1;\r\n TokenLen := Position - TokenLen;\r\n Exit;\r\n end;\r\nend;\r\n\r\n{ Pops the top Token off of the stack }\r\n\r\nprocedure TJvMathParser.Pop(var Token: TokenRec);\r\nbegin\r\n Token := Stack[StackTop];\r\n Dec(StackTop);\r\nend;\r\n\r\n{ Pushes a new Token onto the stack }\r\n\r\nprocedure TJvMathParser.Push(Token: TokenRec);\r\nbegin\r\n if StackTop = ParserStackSize then\r\n TokenError := ErrParserStack\r\n else\r\n begin\r\n Inc(StackTop);\r\n Stack[StackTop] := Token;\r\n end;\r\nend;\r\n\r\n{ Parses an input stream }\r\n\r\nprocedure TJvMathParser.Parse;\r\nvar\r\n FirstToken: TokenRec;\r\n Accepted: Boolean;\r\nbegin\r\n Position := 1;\r\n StackTop := 0;\r\n TokenError := 0;\r\n MathError := False;\r\n ParseError := False;\r\n Accepted := False;\r\n FirstToken.State := 0;\r\n FirstToken.Value := 0;\r\n Push(FirstToken);\r\n TokenType := NextToken;\r\n repeat\r\n case Stack[StackTop].State of\r\n 0, 9, 12..16, 20, 40:\r\n begin\r\n if TokenType = ttNum then\r\n Shift(10)\r\n else\r\n if TokenType = ttFunc then\r\n Shift(11)\r\n else\r\n if TokenType = ttMinus then\r\n Shift(5)\r\n else\r\n if TokenType = ttOParen then\r\n Shift(9)\r\n else\r\n if TokenType = ttErr then\r\n begin\r\n MathError := True;\r\n Accepted := True;\r\n end\r\n else\r\n begin\r\n TokenError := ErrExpression;\r\n Position := Position - TokenLen;\r\n end;\r\n end;\r\n 1:\r\n begin\r\n if TokenType = ttEol then\r\n Accepted := True\r\n else\r\n if TokenType = ttPlus then\r\n Shift(12)\r\n else\r\n if TokenType = ttMinus then\r\n Shift(13)\r\n else\r\n begin\r\n TokenError := ErrOperator;\r\n Position := Position - TokenLen;\r\n end;\r\n end;\r\n 2:\r\n begin\r\n if TokenType = ttTimes then\r\n Shift(14)\r\n else\r\n if TokenType = ttDivide then\r\n Shift(15)\r\n else\r\n Reduce(3);\r\n end;\r\n 3:\r\n begin\r\n if TokenType = ttModu then\r\n Shift(40)\r\n else\r\n Reduce(6);\r\n end;\r\n 4:\r\n begin\r\n if TokenType = ttExpo then\r\n Shift(16)\r\n else\r\n Reduce(8);\r\n end;\r\n 5:\r\n begin\r\n if TokenType = ttNum then\r\n Shift(10)\r\n else\r\n if TokenType = ttFunc then\r\n Shift(11)\r\n else\r\n if TokenType = ttOParen then\r\n Shift(9)\r\n else\r\n begin\r\n TokenError := ErrExpression;\r\n Position := Position - TokenLen;\r\n end;\r\n end;\r\n 6:\r\n Reduce(10);\r\n 7:\r\n Reduce(13);\r\n 8:\r\n Reduce(12);\r\n 10:\r\n Reduce(15);\r\n 11:\r\n if TokenType = ttOParen then\r\n Shift(20)\r\n else\r\n begin\r\n TokenError := ErrOpenParen;\r\n Position := Position - TokenLen;\r\n end;\r\n 17:\r\n Reduce(9);\r\n 18:\r\n raise EJVCLException.CreateRes(@RsEBadTokenState);\r\n 19:\r\n if TokenType = ttPlus then\r\n Shift(12)\r\n else\r\n if TokenType = ttMinus then\r\n Shift(13)\r\n else\r\n if TokenType = ttCParen then\r\n Shift(27)\r\n else\r\n begin\r\n TokenError := ErrOpCloseParen;\r\n Position := Position - TokenLen;\r\n end;\r\n 21:\r\n if TokenType = ttTimes then\r\n Shift(14)\r\n else\r\n if TokenType = ttDivide then\r\n Shift(15)\r\n else\r\n Reduce(1);\r\n 22:\r\n if TokenType = ttTimes then\r\n Shift(14)\r\n else\r\n if TokenType = ttDivide then\r\n Shift(15)\r\n else\r\n Reduce(2);\r\n 23:\r\n Reduce(4);\r\n 24:\r\n Reduce(5);\r\n 25:\r\n Reduce(7);\r\n 26:\r\n Reduce(11);\r\n 27:\r\n Reduce(14);\r\n 28:\r\n if TokenType = ttPlus then\r\n Shift(12)\r\n else\r\n if TokenType = ttMinus then\r\n Shift(13)\r\n else\r\n if TokenType = ttCParen then\r\n Shift(29)\r\n else\r\n begin\r\n TokenError := ErrOpCloseParen;\r\n Position := Position - TokenLen;\r\n end;\r\n 29:\r\n Reduce(16);\r\n 80:\r\n Reduce(100);\r\n end;\r\n until Accepted or (TokenError <> 0);\r\n if TokenError <> 0 then\r\n begin\r\n if TokenError = ErrBadRange then\r\n Position := Position - TokenLen;\r\n if Assigned(FOnParseError) then\r\n FOnParseError(Self, TokenError);\r\n end;\r\n if MathError or (TokenError <> 0) then\r\n begin\r\n ParseError := True;\r\n ParseValue := 0;\r\n Exit;\r\n end;\r\n ParseError := False;\r\n ParseValue := Stack[StackTop].Value;\r\nend;\r\n\r\n{ Completes a reduction }\r\n\r\nprocedure TJvMathParser.Reduce(Reduction: Word);\r\nvar\r\n Token1, Token2: TokenRec;\r\nbegin\r\n case Reduction of\r\n 1:\r\n begin\r\n Pop(Token1);\r\n Pop(Token2);\r\n Pop(Token2);\r\n CurrToken.Value := Token1.Value + Token2.Value;\r\n end;\r\n 2:\r\n begin\r\n Pop(Token1);\r\n Pop(Token2);\r\n Pop(Token2);\r\n CurrToken.Value := Token2.Value - Token1.Value;\r\n end;\r\n 4:\r\n begin\r\n Pop(Token1);\r\n Pop(Token2);\r\n Pop(Token2);\r\n CurrToken.Value := Token1.Value * Token2.Value;\r\n end;\r\n 5:\r\n begin\r\n Pop(Token1);\r\n Pop(Token2);\r\n Pop(Token2);\r\n if Token1.Value = 0 then\r\n MathError := True\r\n else\r\n CurrToken.Value := Token2.Value / Token1.Value;\r\n end;\r\n { MOD operator }\r\n 100:\r\n begin\r\n Pop(Token1);\r\n Pop(Token2);\r\n Pop(Token2);\r\n if Token1.Value = 0 then\r\n MathError := True\r\n else\r\n CurrToken.Value := Round(Token2.Value) mod Round(Token1.Value);\r\n end;\r\n 7:\r\n begin\r\n Pop(Token1);\r\n Pop(Token2);\r\n Pop(Token2);\r\n if Token2.Value <= 0 then\r\n MathError := True\r\n else\r\n if (Token1.Value * Ln(Token2.Value) < -ExpLimit) or\r\n (Token1.Value * Ln(Token2.Value) > ExpLimit) then\r\n MathError := True\r\n else\r\n CurrToken.Value := Exp(Token1.Value * Ln(Token2.Value));\r\n end;\r\n 9:\r\n begin\r\n Pop(Token1);\r\n Pop(Token2);\r\n CurrToken.Value := -Token1.Value;\r\n end;\r\n 11:\r\n raise EJVCLException.CreateRes(@RsEInvalidReduction);\r\n 13:\r\n raise EJVCLException.CreateRes(@RsEInvalidReduction);\r\n 14:\r\n begin\r\n Pop(Token1);\r\n Pop(CurrToken);\r\n Pop(Token1);\r\n end;\r\n 16:\r\n begin\r\n Pop(Token1);\r\n Pop(CurrToken);\r\n Pop(Token1);\r\n Pop(Token1);\r\n if Token1.FuncName = 'ABS' then\r\n CurrToken.Value := Abs(CurrToken.Value)\r\n else\r\n if Token1.FuncName = 'ATAN' then\r\n CurrToken.Value := ArcTan(CurrToken.Value)\r\n else\r\n if Token1.FuncName = 'COS' then\r\n begin\r\n if (CurrToken.Value < -9E18) or (CurrToken.Value > 9E18) then\r\n MathError := True\r\n else\r\n CurrToken.Value := Cos(CurrToken.Value)\r\n end\r\n else\r\n if Token1.FuncName = 'EXP' then\r\n begin\r\n if (CurrToken.Value < -ExpLimit) or (CurrToken.Value > ExpLimit) then\r\n MathError := True\r\n else\r\n CurrToken.Value := Exp(CurrToken.Value);\r\n end\r\n else\r\n if Token1.FuncName = 'LN' then\r\n begin\r\n if CurrToken.Value <= 0 then\r\n MathError := True\r\n else\r\n CurrToken.Value := Ln(CurrToken.Value);\r\n end\r\n else\r\n if Token1.FuncName = 'ROUND' then\r\n begin\r\n if (CurrToken.Value < -1E9) or (CurrToken.Value > 1E9) then\r\n MathError := True\r\n else\r\n CurrToken.Value := Round(CurrToken.Value);\r\n end\r\n else\r\n if Token1.FuncName = 'SIN' then\r\n begin\r\n if (CurrToken.Value < -9E18) or (CurrToken.Value > 9E18) then\r\n MathError := True\r\n else\r\n CurrToken.Value := Sin(CurrToken.Value)\r\n end\r\n else\r\n if Token1.FuncName = 'SQRT' then\r\n begin\r\n if CurrToken.Value < 0 then\r\n MathError := True\r\n else\r\n CurrToken.Value := Sqrt(CurrToken.Value);\r\n end\r\n else\r\n if Token1.FuncName = 'SQR' then\r\n begin\r\n if (CurrToken.Value < -SqrLimit) or (CurrToken.Value > SqrLimit) then\r\n MathError := True\r\n else\r\n CurrToken.Value := Sqr(CurrToken.Value);\r\n end\r\n else\r\n if Token1.FuncName = 'TRUNC' then\r\n begin\r\n if (CurrToken.Value < -1E9) or (CurrToken.Value > 1E9) then\r\n MathError := True\r\n else\r\n CurrToken.Value := Trunc(CurrToken.Value);\r\n end;\r\n end;\r\n 3, 6, 8, 10, 12, 15:\r\n Pop(CurrToken);\r\n end;\r\n CurrToken.State := GotoState(Reduction);\r\n Push(CurrToken);\r\nend;\r\n\r\n{ Shifts a Token onto the stack }\r\n\r\nprocedure TJvMathParser.Shift(State: Word);\r\nbegin\r\n CurrToken.State := State;\r\n Push(CurrToken);\r\n TokenType := NextToken;\r\nend;\r\n\r\n//=== { TTreeKeyMappings } ===================================================\r\n\r\nprocedure TTreeKeyMappings.SetAddNode(const Value: TShortCut);\r\nbegin\r\n FAddNode := Value;\r\nend;\r\n\r\nprocedure TTreeKeyMappings.SetDeleteNode(const Value: TShortCut);\r\nbegin\r\n FDeleteNode := Value;\r\nend;\r\n\r\nprocedure TTreeKeyMappings.SetInsertNode(const Value: TShortCut);\r\nbegin\r\n FInsertNode := Value;\r\nend;\r\n\r\nprocedure TTreeKeyMappings.SetAddChildNode(const Value: TShortCut);\r\nbegin\r\n FAddChildNode := Value;\r\nend;\r\n\r\nprocedure TTreeKeyMappings.SetDuplicateNode(const Value: TShortCut);\r\nbegin\r\n FDuplicateNode := Value;\r\nend;\r\n\r\nprocedure TTreeKeyMappings.SetEditNode(const Value: TShortCut);\r\nbegin\r\n FEditNode := Value;\r\nend;\r\n\r\nprocedure TJvJanTreeView.KeyPress(var Key: Char);\r\nbegin\r\n if Key = Cr then\r\n Recalculate;\r\n if Assigned(OnKeyPress) then\r\n OnKeyPress(Self, Key);\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend." }, { "path": "External/Jedi/Jvcl/run/JvJclUnitVersioningBrowser.pas", "content": "{ -----------------------------------------------------------------------------\r\n The contents of this file are subject to the Mozilla Public License\r\n Version 1.1 (the \"License\"); you may not use this file except in compliance\r\n with the License. You may obtain a copy of the License at\r\n http://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\n Software distributed under the License is distributed on an \"AS IS\" basis,\r\n WITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\n the specific language governing rights and limitations under the License.\r\n\r\n The Original Code is: JvJclUnitVersioningBrowser.pas, released on 2009-03-09.\r\n\r\n The Initial Developers of the Original Code is: Jens Fudickar\r\n All Rights Reserved.\r\n\r\n Contributor(s):\r\n Jens Fudickar\r\n\r\n You may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\n located at http://jvcl.delphi-jedi.org\r\n\r\n Known Issues:\r\n\r\n ----------------------------------------------------------------------------- }\r\n// $Id: JvJclUnitVersioningBrowser.pas 13183 2011-11-23 21:48:44Z jfudickar $\r\n\r\nunit JvJclUnitVersioningBrowser;\r\n\r\n{$I jvcl.inc}\r\n{$I crossplatform.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Classes, ComCtrls, Controls, Forms, JvDynControlEngine;\r\n\r\ntype\r\n TJvJclUnitVersioningBrowser = class(TPersistent)\r\n private\r\n RCSFilePanel, RevisionPanel, DatePanel, ExtraPanel, PathPanel, LabelControl,\r\n RCSFileEdit, RevisionEdit, DateEdit, ExtraEdit, PathEdit: TWinControl;\r\n { Private-Deklarationen }\r\n UnitVersionForm: TCustomForm;\r\n procedure CloseButtonOnClick(Sender: TObject);\r\n {$IFDEF UNITVERSIONING}\r\n procedure ExportButtonOnClick(Sender: TObject);\r\n {$ENDIF UNITVERSIONING}\r\n procedure TreeViewOnChange(Sender: TObject; Node: TTreeNode);\r\n public\r\n procedure ShowUnitVersioning(const aDynControlEngine: tJvDynControlEngine);\r\n end;\r\n\r\nprocedure ShowUnitVersioning(const aDynControlEngine: tJvDynControlEngine = nil);\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvJclUnitVersioningBrowser.pas $';\r\n Revision: '$Revision: 13183 $';\r\n Date: '$Date: 2011-11-23 22:48:44 +0100 (mer. 23 nov. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n StdCtrls, SysUtils, JclStrings, JvDynControlEngineIntf, ExtCtrls,\r\n JclFileUtils, Dialogs;\r\n\r\nprocedure ShowUnitVersioning(const aDynControlEngine: tJvDynControlEngine = nil);\r\nvar\r\n JvJclUnitVersioningBrowser: TJvJclUnitVersioningBrowser;\r\nbegin\r\n JvJclUnitVersioningBrowser := TJvJclUnitVersioningBrowser.Create;\r\n try\r\n JvJclUnitVersioningBrowser.ShowUnitVersioning(aDynControlEngine);\r\n finally\r\n FreeAndNil(JvJclUnitVersioningBrowser);\r\n end;\r\nend;\r\n\r\nprocedure TJvJclUnitVersioningBrowser.CloseButtonOnClick(Sender: TObject);\r\nbegin\r\n if Assigned(UnitVersionForm) then\r\n UnitVersionForm.ModalResult := mrOk;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nprocedure TJvJclUnitVersioningBrowser.ExportButtonOnClick(Sender: TObject);\r\nvar\r\n SaveDialog: TSaveDialog;\r\nbegin\r\n SaveDialog := TSaveDialog.Create(nil);\r\n try\r\n SaveDialog.DefaultExt := 'lst';\r\n SaveDialog.Filter := '*.lst|Versionlist (*.lst)';\r\n SaveDialog.Options := [ofHideReadOnly, ofPathMustExist, ofNoReadOnlyReturn, ofEnableSizing];\r\n if SaveDialog.Execute then\r\n ExportUnitVersioningToFile(SaveDialog.FileName);\r\n finally\r\n SaveDialog.Free;\r\n end;\r\nend;\r\n{$ENDIF UNITVERSIONING}\r\n\r\nprocedure TJvJclUnitVersioningBrowser.ShowUnitVersioning(const aDynControlEngine: tJvDynControlEngine);\r\n\r\n function FindMasterNode(iNodes: TTreeNodes; iNode: TTreeNode; const iPath: string): TTreeNode;\r\n var\r\n Part1, Part2: string;\r\n I: Integer;\r\n begin\r\n Result := nil;\r\n Part2 := iPath;\r\n Part1 := '';\r\n while (Part1 = '') and (Part2 <> '') do\r\n begin\r\n Part1 := trim(StrBefore('\\', Part2));\r\n Part2 := trim(StrAfter('\\', Part2));\r\n end;\r\n if Part1 <> '' then\r\n begin\r\n for I := 0 to iNode.Count - 1 do\r\n begin\r\n if iNode.Item[I].Text = Part1 then\r\n begin\r\n Result := FindMasterNode(iNodes, iNode.Item[I], Part2);\r\n break;\r\n end;\r\n end;\r\n if Result = nil then\r\n begin\r\n Result := iNodes.AddChild(iNode, Part1);\r\n Result := FindMasterNode(iNodes, Result, Part2);\r\n end;\r\n end\r\n else\r\n Result := iNode;\r\n end;\r\n\r\nvar\r\n DynEngine: tJvDynControlEngine;\r\n MainPanel, ButtonPanel: TWinControl;\r\n TopBox, BottomBox: TWinControl;\r\n Button: TButton;\r\n TreeView: TWinControl;\r\n IJvReadOnly: IJvDynControlReadOnly;\r\n IJvTreeView: IJvDynControlTreeView;\r\n MainNode: TTreeNode;\r\n Nodes: TTreeNodes;\r\n {$IFDEF UNITVERSIONING}\r\n I: Integer;\r\n Item: TUnitVersion;\r\n {$ENDIF UNITVERSIONING}\r\nbegin\r\n if Assigned(aDynControlEngine) then\r\n DynEngine := aDynControlEngine\r\n else\r\n DynEngine := DefaultDynControlEngine;\r\n UnitVersionForm := DynEngine.CreateForm('Unit Versioning', '');\r\n try\r\n if UnitVersionForm is TForm then\r\n TForm(UnitVersionForm).Position := poScreenCenter;\r\n UnitVersionForm.Width := 500;\r\n UnitVersionForm.Height := 500;\r\n ButtonPanel := DynEngine.CreatePanelControl(UnitVersionForm, UnitVersionForm, 'ButtonPanel', '', alBottom);\r\n MainPanel := DynEngine.CreatePanelControl(UnitVersionForm, UnitVersionForm, 'MainPanel', '', alClient);\r\n if MainPanel is TPanel then\r\n TPanel(MainPanel).borderWidth := 3;\r\n Button := DynEngine.CreateButton(UnitVersionForm, ButtonPanel, 'CloseBtn', 'Close', '', CloseButtonOnClick, True, True);\r\n Button.Left := Round((UnitVersionForm.Width - Button.Width) / 2);\r\n ButtonPanel.Height := Button.Height + 6;\r\n Button.Top := Round((ButtonPanel.Height - Button.Height) / 2);\r\n {$IFDEF UNITVERSIONING}\r\n Button := DynEngine.CreateButton(UnitVersionForm, ButtonPanel, 'ExportBtn', 'Export', '', ExportButtonOnClick, True, True);\r\n Button.Left := 10;\r\n Button.Top := Round((ButtonPanel.Height - Button.Height) / 2);\r\n {$ENDIF UNITVERSIONING}\r\n BottomBox := DynEngine.CreateGroupBoxControl(UnitVersionForm, MainPanel, 'BottomBox', 'Details');\r\n BottomBox.Align := alBottom;\r\n TopBox := DynEngine.CreateGroupBoxControl(UnitVersionForm, MainPanel, 'TopBox', 'Unit Versions');\r\n TopBox.Align := alClient;\r\n TreeView := DynEngine.CreateTreeViewControl(UnitVersionForm, TopBox, 'TreeView');\r\n TreeView.Align := alClient;\r\n RCSFilePanel := DynEngine.CreatePanelControl(UnitVersionForm, BottomBox, 'RCSFilePanel', '', alTop);\r\n RCSFilePanel.Align := alTop;\r\n RCSFileEdit := DynEngine.CreateEditControl(UnitVersionForm, RCSFilePanel, 'RCSFileEdit');\r\n RCSFileEdit.Width := 380;\r\n if Supports(RCSFileEdit, IJvDynControlReadOnly, IJvReadOnly) then\r\n IJvReadOnly.ControlSetReadOnly(True);\r\n LabelControl := DynEngine.CreateLabelControlPanel(UnitVersionForm, RCSFilePanel, 'RCSFileLabel', 'RCS File',\r\n RCSFileEdit, False, 80);\r\n RCSFilePanel.Height := RCSFileEdit.Height + 1;\r\n RevisionPanel := DynEngine.CreatePanelControl(UnitVersionForm, BottomBox, 'RevisionPanel', '', alTop);\r\n RevisionPanel.Align := alTop;\r\n RevisionEdit := DynEngine.CreateEditControl(UnitVersionForm, RevisionPanel, 'RevisionEdit');\r\n RevisionEdit.Width := 380;\r\n LabelControl := DynEngine.CreateLabelControlPanel(UnitVersionForm, RevisionPanel, 'RevisionLabel', 'Revision',\r\n RevisionEdit, False, 80);\r\n if Supports(RevisionEdit, IJvDynControlReadOnly, IJvReadOnly) then\r\n IJvReadOnly.ControlSetReadOnly(True);\r\n RevisionPanel.Height := RevisionEdit.Height + 1;\r\n DatePanel := DynEngine.CreatePanelControl(UnitVersionForm, BottomBox, 'DatePanel', '', alTop);\r\n DatePanel.Align := alTop;\r\n DateEdit := DynEngine.CreateEditControl(UnitVersionForm, DatePanel, 'DateEdit');\r\n DateEdit.Width := 380;\r\n LabelControl := DynEngine.CreateLabelControlPanel(UnitVersionForm, DatePanel, 'DateLabel', 'Date', DateEdit, False,\r\n 80);\r\n if Supports(DateEdit, IJvDynControlReadOnly, IJvReadOnly) then\r\n IJvReadOnly.ControlSetReadOnly(True);\r\n DatePanel.Height := DateEdit.Height + 1;\r\n PathPanel := DynEngine.CreatePanelControl(UnitVersionForm, BottomBox, 'PathPanel', '', alTop);\r\n PathPanel.Align := alTop;\r\n PathEdit := DynEngine.CreateEditControl(UnitVersionForm, PathPanel, 'PathEdit');\r\n PathEdit.Width := 380;\r\n LabelControl := DynEngine.CreateLabelControlPanel(UnitVersionForm, PathPanel, 'PathLabel', 'Path', PathEdit, False, 80);\r\n if Supports(PathEdit, IJvDynControlReadOnly, IJvReadOnly) then\r\n IJvReadOnly.ControlSetReadOnly(True);\r\n PathPanel.Height := PathEdit.Height + 1;\r\n ExtraPanel := DynEngine.CreatePanelControl(UnitVersionForm, BottomBox, 'ExtraPanel', '', alTop);\r\n ExtraPanel.Align := alTop;\r\n ExtraEdit := DynEngine.CreateMemoControl(UnitVersionForm, ExtraPanel, 'ExtraEdit');\r\n // if Supports(ExtraEdit, IJvDynControlReadOnly, IJvReadOnly) then\r\n // IJvReadOnly.ControlSetReadOnly(True);\r\n ExtraEdit.Width := 400;\r\n LabelControl := DynEngine.CreateLabelControlPanel(UnitVersionForm, ExtraPanel, 'ExtraLabel', 'Extra', ExtraEdit, True, 80);\r\n LabelControl.Width := 80 + PathEdit.Width;\r\n ExtraPanel.Height := LabelControl.Height;\r\n\r\n BottomBox.Height := DatePanel.Height * 4 + 10 + ExtraPanel.Height;\r\n\r\n if Supports(TreeView, IJvDynControlReadOnly, IJvReadOnly) then\r\n IJvReadOnly.ControlSetReadOnly(True);\r\n\r\n if Supports(TreeView, IJvDynControlTreeView, IJvTreeView) then\r\n begin\r\n Nodes := IJvTreeView.ControlGetItems;\r\n Nodes.Clear;\r\n IJvTreeView.ControlSetOnChange(TreeViewOnChange);\r\n MainNode := Nodes.AddChild(nil, ExtractFileName(ParamStr(0)) + ' ' + VersionFixedFileInfoString(ParamStr(0)));\r\n {$IFDEF UNITVERSIONING}\r\n for I := 0 to GetUnitVersioning.Count - 1 do\r\n begin\r\n Item := GetUnitVersioning.Items[I];\r\n Nodes.AddChildObject(FindMasterNode(Nodes, MainNode, Item.LogPath),\r\n StrRestOf(Item.RCSfile, StrLastPos('/', Item.RCSfile) + 1) + ' - ' + Item.Revision, Item);\r\n end;\r\n {$ENDIF UNITVERSIONING}\r\n IJvTreeView.ControlSetSortType(stText);\r\n if TreeView is TTreeView then\r\n TTreeView(TreeView).FullExpand;\r\n MainNode.Selected := True;\r\n end;\r\n TreeViewOnChange(nil, nil);\r\n UnitVersionForm.ShowModal;\r\n finally\r\n UnitVersionForm.Release; // keep the form created till all used interfaces are cleared\r\n end;\r\nend;\r\n\r\nprocedure TJvJclUnitVersioningBrowser.TreeViewOnChange(Sender: TObject; Node: TTreeNode);\r\n{$IFDEF UNITVERSIONING}\r\nvar\r\n IJvData: IJvDynControlData;\r\n{$ENDIF UNITVERSIONING}\r\nbegin\r\n {$IFDEF UNITVERSIONING}\r\n if Assigned(Node) and Assigned(Node.Data) and\r\n (TObject(Node.Data) is TUnitVersion) then\r\n begin\r\n if Supports(RCSFileEdit, IJvDynControlData, IJvData) then\r\n begin\r\n IJvData.ControlValue := TUnitVersion(Node.Data).RCSfile;\r\n RCSFilePanel.Visible := True;\r\n end\r\n else\r\n RCSFilePanel.Visible := False;\r\n if Supports(RevisionEdit, IJvDynControlData, IJvData) then\r\n begin\r\n IJvData.ControlValue := TUnitVersion(Node.Data).Revision;\r\n RevisionPanel.Visible := True;\r\n end\r\n else\r\n RevisionPanel.Visible := False;\r\n if Supports(DateEdit, IJvDynControlData, IJvData) then\r\n begin\r\n IJvData.ControlValue := TUnitVersion(Node.Data).Date;\r\n DatePanel.Visible := True;\r\n end\r\n else\r\n DatePanel.Visible := False;\r\n if Supports(ExtraEdit, IJvDynControlData, IJvData) and\r\n (TUnitVersion(Node.Data).Extra <> '') then\r\n begin\r\n IJvData.ControlValue := TUnitVersion(Node.Data).Extra;\r\n ExtraPanel.Visible := True;\r\n end\r\n else\r\n ExtraPanel.Visible := False;\r\n if Supports(PathEdit, IJvDynControlData, IJvData) then\r\n begin\r\n IJvData.ControlValue := TUnitVersion(Node.Data).LogPath;\r\n PathPanel.Visible := True;\r\n end\r\n else\r\n PathPanel.Visible := False;\r\n end\r\n else\r\n {$ENDIF UNITVERSIONING}\r\n begin\r\n RCSFilePanel.Visible := False;\r\n RevisionPanel.Visible := False;\r\n DatePanel.Visible := False;\r\n ExtraPanel.Visible := False;\r\n PathPanel.Visible := False;\r\n end;\r\nend;\r\n\r\ninitialization\r\n {$IFDEF UNITVERSIONING}\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n {$ENDIF UNITVERSIONING}\r\nfinalization\r\n {$IFDEF UNITVERSIONING}\r\n UnregisterUnitVersion(HInstance);\r\n {$ENDIF UNITVERSIONING}\r\nend." }, { "path": "External/Jedi/Jvcl/run/JvJoystick.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvJoystick.PAS, released on 2001-02-28.\r\n\r\nThe Initial Developer of the Original Code is Sbastien Buysse [sbuysse att buypin dott com]\r\nPortions created by Sbastien Buysse are Copyright (C) 2001 Sbastien Buysse.\r\nAll Rights Reserved.\r\n\r\nContributor(s): Michael Beck [mbeck att bigfoot dott com].\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvJoystick.pas 13104 2011-09-07 06:50:43Z obones $\r\n\r\nunit JvJoystick;\r\n\r\n{$I jvcl.inc}\r\n{$I windowsonly.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n {$IFDEF MSWINDOWS}\r\n Windows, Messages,\r\n {$ENDIF MSWINDOWS}\r\n SysUtils, Classes, MMSystem,\r\n Forms,\r\n JvTypes, JvComponentBase;\r\n\r\n// (rom) in the time of USB this unit may have to support more than 2 joysticks\r\n\r\ntype\r\n TJoyCap = (joHasZCoordinate, joHasRudder, joHasUCoordinate, joHasVCoordinate, joHasPointOfVue,\r\n joHasPointOfVDiscrete, joHasPointOfVContinuous);\r\n TJoyCaps = set of TJoyCap;\r\n TJoyButtonDown = procedure(Sender: TObject; X, Y: Integer; ButtonChanged: Integer; But1Pressed, But2Pressed,\r\n But3Pressed, But4Pressed: Boolean) of object;\r\n TJoyMove = procedure(Sender: TObject; X, Y: Integer;\r\n But1Pressed, But2Pressed, But3Pressed, But4Pressed: Boolean) of object;\r\n TJoyZMove = procedure(Sender: TObject; Z: Integer;\r\n But1Pressed, But2Pressed, But3Pressed, But4Pressed: Boolean) of object;\r\n TJoyErrorMsg = procedure(Sender: TObject; code: Integer; Msg: string) of object;\r\n\r\n TJoystick = class(TPersistent)\r\n private\r\n FJoyInfo: JOYINFO;\r\n FJoy: JOYCAPS;\r\n FDummy: Cardinal;\r\n FDummyW: Word;\r\n FDummyS: string;\r\n FCapabilities: TJoyCaps;\r\n FCapsDummy: TJoyCaps;\r\n FRegKey: string;\r\n FOEMVxD: string;\r\n FProductName: string;\r\n FDummyI: Integer;\r\n FDummyB: Boolean;\r\n FJoyNumber: Integer;\r\n function GetButton1: Boolean;\r\n function GetButton2: Boolean;\r\n function GetButton3: Boolean;\r\n function GetButton4: Boolean;\r\n function GetXPosition: Integer;\r\n function GetYPosition: Integer;\r\n function GetZPosition: Integer;\r\n procedure RefreshJoy;\r\n public\r\n constructor CreateJoy(AOwner: TComponent; Joy: Integer);\r\n published\r\n { Do not store dummies }\r\n property XPosition: Integer read GetXPosition write FDummyI stored False;\r\n property YPosition: Integer read GetYPosition write FDummyI stored False;\r\n property ZPosition: Integer read GetZPosition write FDummyI stored False;\r\n property Button1Pressed: Boolean read GetButton1 write FDummyB stored False;\r\n property Button2Pressed: Boolean read GetButton2 write FDummyB stored False;\r\n property Button3Pressed: Boolean read GetButton3 write FDummyB stored False;\r\n property Button4Pressed: Boolean read GetButton4 write FDummyB stored False;\r\n property Manufacturer: Word read FJoy.wMid write FDummyW stored False;\r\n property ProductIdentifier: Word read FJoy.wPid write FDummyW stored False;\r\n property ProductName: string read FProductName write FDummyS stored False;\r\n property XMin: Cardinal read FJoy.wXMin write FDummy stored False;\r\n property XMax: Cardinal read FJoy.wXMax write FDummy stored False;\r\n property YMin: Cardinal read FJoy.wYMin write FDummy stored False;\r\n property YMax: Cardinal read FJoy.wYMax write FDummy stored False;\r\n property ZMin: Cardinal read FJoy.wZmin write FDummy stored False;\r\n property ZMax: Cardinal read FJoy.wZmax write FDummy stored False;\r\n property NumButtons: Cardinal read FJoy.wNumButtons write FDummy stored False;\r\n property PeriodMin: Cardinal read FJoy.wPeriodMin write FDummy stored False;\r\n property PeriodMax: Cardinal read FJoy.wPeriodMax write FDummy stored False;\r\n property RudderMin: Cardinal read FJoy.wRmin write FDummy stored False;\r\n property RudderMax: Cardinal read FJoy.wRmax write FDummy stored False;\r\n property UMin: Cardinal read FJoy.wUMin write FDummy stored False;\r\n property UMax: Cardinal read FJoy.wUMax write FDummy stored False;\r\n property VMin: Cardinal read FJoy.wVMin write FDummy stored False;\r\n property VMax: Cardinal read FJoy.wVMax write FDummy stored False;\r\n property Capabilities: TJoyCaps read FCapabilities write FCapsDummy stored False;\r\n property MaxAxis: Cardinal read FJoy.wMaxAxes write FDummy stored False;\r\n property NumAxis: Cardinal read FJoy.wNumAxes write FDummy stored False;\r\n property MaxButtons: Cardinal read FJoy.wMaxButtons write FDummy stored False;\r\n property RegKey: string read FRegKey write FDummyS stored False;\r\n property OemVxD: string read FOEMVxD write FDummyS stored False;\r\n end;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvJoystick = class(TJvComponent)\r\n private\r\n FJoyDummy: Boolean;\r\n FJoy1: TJoystick;\r\n FJoy2: TJoystick;\r\n FJoystick1: Boolean;\r\n FJoystick2: Boolean;\r\n FHandle: THandle;\r\n FCapture1: Boolean;\r\n FCapture2: Boolean;\r\n FPoll: Cardinal;\r\n FJoy1ButtonDown: TJoyButtonDown;\r\n FJoy2ButtonDown: TJoyButtonDown;\r\n FJoy1ButtonUp: TJoyButtonDown;\r\n FJoy2ButtonUp: TJoyButtonDown;\r\n FJoy2Move: TJoyMove;\r\n FJoy1Move: TJoyMove;\r\n FJoy1ZMove: TJoyZMove;\r\n FJoy2ZMove: TJoyZMove;\r\n FOnError: TJoyErrorMsg;\r\n procedure SetCapture1(const Value: Boolean);\r\n procedure SetCapture2(const Value: Boolean);\r\n function GetJoystick1: Boolean;\r\n function GetJoystick2: Boolean;\r\n function GetThreshold1: MMRESULT;\r\n function GetThreshold2: MMRESULT;\r\n procedure SetThreshold1(const Value: MMRESULT);\r\n procedure SetThreshold2(const Value: MMRESULT);\r\n procedure RaiseErrorCapture(Value: MMRESULT);\r\n procedure RaiseErrorRelease(Value: MMRESULT);\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n procedure WndProc(var Msg: TMessage);\r\n destructor Destroy; override;\r\n published\r\n property Joy1Threshold: MMRESULT read GetThreshold1 write SetThreshold1;\r\n property Joy2Threshold: MMRESULT read GetThreshold2 write SetThreshold2;\r\n property HasJoystick1: Boolean read GetJoystick1 write FJoyDummy stored False;\r\n property HasJoystick2: Boolean read GetJoystick2 write FJoyDummy stored False;\r\n property PollTime: Cardinal read FPoll write FPoll default 50;\r\n property CaptureJoystick1: Boolean read FCapture1 write SetCapture1 default False;\r\n property CaptureJoystick2: Boolean read FCapture2 write SetCapture2 default False;\r\n property JoyStick1: TJoystick read FJoy1;\r\n property JoyStick2: TJoystick read FJoy2;\r\n property Joy1ButtonDown: TJoyButtonDown read FJoy1ButtonDown write FJoy1ButtonDown;\r\n property Joy2ButtonDown: TJoyButtonDown read FJoy2ButtonDown write FJoy2ButtonDown;\r\n property Joy1ButtonUp: TJoyButtonDown read FJoy1ButtonUp write FJoy1ButtonUp;\r\n property Joy2ButtonUp: TJoyButtonDown read FJoy2ButtonUp write FJoy2ButtonUp;\r\n property Joy1Move: TJoyMove read FJoy1Move write FJoy1Move;\r\n property Joy2Move: TJoyMove read FJoy2Move write FJoy2Move;\r\n property Joy1ZMove: TJoyZMove read FJoy1ZMove write FJoy1ZMove;\r\n property Joy2ZMove: TJoyZMove read FJoy2ZMove write FJoy2ZMove;\r\n property OnError: TJoyErrorMsg read FOnError write FOnError;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvJoystick.pas $';\r\n Revision: '$Revision: 13104 $';\r\n Date: '$Date: 2011-09-07 08:50:43 +0200 (mer. 07 sept. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n JvJVCLUtils, JvResources;\r\n\r\n//=== { TJvJoystick } ========================================================\r\n\r\nconstructor TJvJoystick.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FJoystick1 := joyGetNumDevs > 0;\r\n FJoystick2 := joyGetNumDevs > 1;\r\n FJoy1 := TJoystick.CreateJoy(Self, JOYSTICKID1);\r\n FJoy2 := TJoystick.CreateJoy(Self, JOYSTICKID2);\r\n FHandle := AllocateHWndEx(WndProc);\r\n FCapture1 := False;\r\n FCapture2 := False;\r\n FPoll := 50;\r\nend;\r\n\r\ndestructor TJvJoystick.Destroy;\r\nbegin\r\n FJoy1.Free;\r\n FJoy2.Free;\r\n DeallocateHWndEx(FHandle);\r\n if FCapture1 then\r\n joyReleaseCapture(JOYSTICKID1);\r\n if FCapture2 then\r\n joyReleaseCapture(JOYSTICKID2);\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJvJoystick.GetJoystick1: Boolean;\r\nvar\r\n J: JOYINFO;\r\nbegin\r\n Result := joyGetPos(JOYSTICKID1, @J) = JOYERR_NOERROR;\r\nend;\r\n\r\nfunction TJvJoystick.GetJoystick2: Boolean;\r\nvar\r\n J: JOYINFO;\r\nbegin\r\n Result := joyGetPos(JOYSTICKID2, @J) = JOYERR_NOERROR;\r\nend;\r\n\r\nfunction TJvJoystick.GetThreshold1: MMRESULT;\r\nbegin\r\n joyGetThreshold(JOYSTICKID1, @Result);\r\nend;\r\n\r\nfunction TJvJoystick.GetThreshold2: MMRESULT;\r\nbegin\r\n joyGetThreshold(JOYSTICKID2, @Result);\r\nend;\r\n\r\nprocedure TJvJoystick.RaiseErrorCapture(Value: MMRESULT);\r\nbegin\r\n case Value of\r\n MMSYSERR_NODRIVER:\r\n if Assigned(FOnError) then\r\n FOnError(Self, MMSYSERR_NODRIVER, RsNoJoystickDriver);\r\n JOYERR_NOCANDO:\r\n if Assigned(FOnError) then\r\n FOnError(Self, JOYERR_NOCANDO, RsCannotCaptureJoystick);\r\n JOYERR_UNPLUGGED:\r\n if Assigned(FOnError) then\r\n FOnError(Self, JOYERR_NOCANDO, RsJoystickUnplugged);\r\n end;\r\nend;\r\n\r\nprocedure TJvJoystick.RaiseErrorRelease(Value: MMRESULT);\r\nbegin\r\n case Value of\r\n MMSYSERR_NODRIVER:\r\n if Assigned(FOnError) then\r\n FOnError(Self, MMSYSERR_NODRIVER, RsNoJoystickDriver);\r\n JOYERR_PARMS:\r\n if Assigned(FOnError) then\r\n FOnError(Self, JOYERR_PARMS, RsJoystickErrorParam);\r\n end;\r\nend;\r\n\r\nprocedure TJvJoystick.SetCapture1(const Value: Boolean);\r\nbegin\r\n FCapture1 := Value;\r\n if Value then\r\n RaiseErrorCapture(JoySetCapture(FHandle, JOYSTICKID1, FPoll, True))\r\n else\r\n RaiseErrorRelease(joyReleaseCapture(JOYSTICKID1));\r\nend;\r\n\r\nprocedure TJvJoystick.SetCapture2(const Value: Boolean);\r\nbegin\r\n FCapture2 := Value;\r\n if Value then\r\n RaiseErrorCapture(JoySetCapture(FHandle, JOYSTICKID2, FPoll, True))\r\n else\r\n RaiseErrorRelease(joyReleaseCapture(JOYSTICKID2));\r\nend;\r\n\r\nprocedure TJvJoystick.SetThreshold1(const Value: MMRESULT);\r\nbegin\r\n joySetThreshold(JOYSTICKID1, Value);\r\nend;\r\n\r\nprocedure TJvJoystick.SetThreshold2(const Value: MMRESULT);\r\nbegin\r\n joySetThreshold(JOYSTICKID2, Value);\r\nend;\r\n\r\nprocedure TJvJoystick.WndProc(var Msg: TMessage);\r\nvar\r\n X, Y: Byte;\r\n I: Integer;\r\n B1, B2, B3, B4: Boolean;\r\n\r\n procedure TestButtonDown(Value: TJoyButtonDown);\r\n begin\r\n if Assigned(Value) then\r\n begin\r\n X := Msg.LParamLo;\r\n Y := Msg.LParamHi;\r\n if (Msg.WParam and JOY_BUTTON1CHG) = JOY_BUTTON1CHG then\r\n I := 1\r\n else\r\n if (Msg.WParam and JOY_BUTTON2CHG) = JOY_BUTTON2CHG then\r\n I := 2\r\n else\r\n if (Msg.WParam and JOY_BUTTON3CHG) = JOY_BUTTON3CHG then\r\n I := 3\r\n else\r\n if (Msg.WParam and JOY_BUTTON4CHG) = JOY_BUTTON4CHG then\r\n I := 4\r\n else\r\n I := 0;\r\n B1 := (Msg.WParam and JOY_BUTTON1) = JOY_BUTTON1;\r\n B2 := (Msg.WParam and JOY_BUTTON2) = JOY_BUTTON2;\r\n B3 := (Msg.WParam and JOY_BUTTON3) = JOY_BUTTON3;\r\n B4 := (Msg.WParam and JOY_BUTTON4) = JOY_BUTTON4;\r\n Value(Self, X, Y, I, B1, B2, B3, B4);\r\n end;\r\n end;\r\n\r\n procedure TestButtonMove(Value: TJoyMove);\r\n begin\r\n if Assigned(Value) then\r\n begin\r\n X := Msg.LParamLo;\r\n Y := Msg.LParamHi;\r\n B1 := (Msg.WParam and JOY_BUTTON1) = JOY_BUTTON1;\r\n B2 := (Msg.WParam and JOY_BUTTON2) = JOY_BUTTON2;\r\n B3 := (Msg.WParam and JOY_BUTTON3) = JOY_BUTTON3;\r\n B4 := (Msg.WParam and JOY_BUTTON4) = JOY_BUTTON4;\r\n Value(Self, X, Y, B1, B2, B3, B4);\r\n end;\r\n end;\r\n\r\n procedure TestButtonZMove(Value: TJoyZMove);\r\n begin\r\n if Assigned(Value) then\r\n begin\r\n X := Msg.LParamLo;\r\n B1 := (Msg.WParam and JOY_BUTTON1) = JOY_BUTTON1;\r\n B2 := (Msg.WParam and JOY_BUTTON2) = JOY_BUTTON2;\r\n B3 := (Msg.WParam and JOY_BUTTON3) = JOY_BUTTON3;\r\n B4 := (Msg.WParam and JOY_BUTTON4) = JOY_BUTTON4;\r\n Value(Self, X, B1, B2, B3, B4);\r\n end;\r\n end;\r\n\r\nbegin\r\n case Msg.Msg of\r\n MM_JOY1BUTTONDOWN:\r\n TestButtonDown(FJoy1ButtonDown);\r\n MM_JOY1BUTTONUP:\r\n TestButtonDown(FJoy1ButtonUp);\r\n MM_JOY1MOVE:\r\n TestButtonMove(FJoy1Move);\r\n MM_JOY1ZMOVE:\r\n TestButtonZMove(FJoy1ZMove);\r\n MM_JOY2BUTTONDOWN:\r\n TestButtonDown(FJoy2ButtonDown);\r\n MM_JOY2BUTTONUP:\r\n TestButtonDown(FJoy1ButtonUp);\r\n MM_JOY2MOVE:\r\n TestButtonMove(FJoy1Move);\r\n MM_JOY2ZMOVE:\r\n TestButtonZMove(FJoy1ZMove);\r\n else\r\n Msg.Result := DefWindowProc(FHandle, Msg.Msg, Msg.WParam, Msg.LParam);\r\n end;\r\nend;\r\n\r\n//=== { TJoystick } ==========================================================\r\n\r\nconstructor TJoystick.CreateJoy(AOwner: TComponent; Joy: Integer);\r\nbegin\r\n FJoyNumber := Joy;\r\n if joyGetDevCaps(Joy, @FJoy, SizeOf(FJoy)) = MMSYSERR_NODRIVER then\r\n raise EJVCLException.CreateRes(@RsEJoystickError);\r\n FCapabilities := [];\r\n if (JOYCAPS_HASZ and FJoy.wCaps) = JOYCAPS_HASZ then\r\n FCapabilities := FCapabilities + [joHasZCoordinate];\r\n if (JOYCAPS_HASR and FJoy.wCaps) = JOYCAPS_HASR then\r\n FCapabilities := FCapabilities + [joHasRudder];\r\n if (JOYCAPS_HASU and FJoy.wCaps) = JOYCAPS_HASU then\r\n FCapabilities := FCapabilities + [joHasUCoordinate];\r\n if (JOYCAPS_HASV and FJoy.wCaps) = JOYCAPS_HASV then\r\n FCapabilities := FCapabilities + [joHasVCoordinate];\r\n if (JOYCAPS_HASPOV and FJoy.wCaps) = JOYCAPS_HASPOV then\r\n FCapabilities := FCapabilities + [joHasPointOfVue];\r\n if (JOYCAPS_POV4DIR and FJoy.wCaps) = JOYCAPS_POV4DIR then\r\n FCapabilities := FCapabilities + [joHasPointOfVDiscrete];\r\n if (JOYCAPS_POVCTS and FJoy.wCaps) = JOYCAPS_POVCTS then\r\n FCapabilities := FCapabilities + [joHasPointOfVContinuous];\r\n FRegKey := FJoy.szRegKey;\r\n FOEMVxD := FJoy.szOEMVxD;\r\n FProductName := FJoy.szPName;\r\nend;\r\n\r\nfunction TJoystick.GetButton1: Boolean;\r\nbegin\r\n RefreshJoy;\r\n Result := (FJoyInfo.wButtons and JOY_BUTTON1) = JOY_BUTTON1;\r\nend;\r\n\r\nfunction TJoystick.GetButton2: Boolean;\r\nbegin\r\n RefreshJoy;\r\n Result := (FJoyInfo.wButtons and JOY_BUTTON2) = JOY_BUTTON2;\r\nend;\r\n\r\nfunction TJoystick.GetButton3: Boolean;\r\nbegin\r\n RefreshJoy;\r\n Result := (FJoyInfo.wButtons and JOY_BUTTON3) = JOY_BUTTON3;\r\nend;\r\n\r\nfunction TJoystick.GetButton4: Boolean;\r\nbegin\r\n RefreshJoy;\r\n Result := (FJoyInfo.wButtons and JOY_BUTTON4) = JOY_BUTTON4;\r\nend;\r\n\r\nfunction TJoystick.GetXPosition: Integer;\r\nbegin\r\n RefreshJoy;\r\n Result := FJoyInfo.wXpos;\r\nend;\r\n\r\nfunction TJoystick.GetYPosition: Integer;\r\nbegin\r\n RefreshJoy;\r\n Result := FJoyInfo.wYpos;\r\nend;\r\n\r\nfunction TJoystick.GetZPosition: Integer;\r\nbegin\r\n RefreshJoy;\r\n Result := FJoyInfo.wZpos;\r\nend;\r\n\r\nprocedure TJoystick.RefreshJoy;\r\nbegin\r\n joyGetPos(FJoyNumber, @FJoyInfo);\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvLED.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvTransled.PAS, released on 2002-12-23.\r\n\r\nThe Initial Developer of the Original Code is Thomas Hensle (http://www.thensle.de)\r\nPortions created by Thomas Hensle are Copyright (C) 2002 Thomas Hensle.\r\nPortions created by XXXX Corp. are Copyright (C) 2002, 2003 XXXX Corp.\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\n Thomas Huber (Thomas_D_huber att t-online dott de)\r\n peter3 (load new image only when needed, center image in control, draw border at designtime)\r\n marcelb (merging of JvTransLED and JvBlinkingLED)\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvLED.pas 13104 2011-09-07 06:50:43Z obones $\r\n\r\nunit JvLED;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, Messages, Controls, Forms, Graphics, ExtCtrls, Classes,\r\n JvComponent;\r\n\r\ntype\r\n TJvCustomLED = class(TJvGraphicControl)\r\n private\r\n FImgPict: TBitmap;\r\n FImgMask: TBitmap;\r\n FTimer: TTimer;\r\n FColorOn: TColor;\r\n FColorOff: TColor;\r\n FActive: Boolean;\r\n FStatus: Boolean;\r\n FOnChange: TNotifyEvent;\r\n procedure SetColorOn(Value: TColor);\r\n procedure SetColorOff(Value: TColor);\r\n procedure SetInterval(Value: Cardinal);\r\n function GetInterval: Cardinal;\r\n procedure SetActive(Value: Boolean);\r\n function GetActive: Boolean;\r\n procedure SetStatus(Value: Boolean);\r\n function GetStatus: Boolean;\r\n procedure DoBlink(Sender: TObject);\r\n protected\r\n procedure ColorChanged; override;\r\n procedure Paint; override;\r\n property Active: Boolean read GetActive write SetActive default False;\r\n property Color default clLime;\r\n property ColorOn: TColor read FColorOn write SetColorOn default clLime;\r\n property ColorOff: TColor read FColorOff write SetColorOff default clRed;\r\n property Interval: Cardinal read GetInterval write SetInterval default 1000;\r\n property Status: Boolean read GetStatus write SetStatus default True;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n procedure SetBounds(ALeft, ATop, AWidth, AHeight: Integer); override;\r\n end;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvLED = class(TJvCustomLED)\r\n published\r\n property Active;\r\n property Align;\r\n property Anchors;\r\n property AutoSize;\r\n property DragCursor;\r\n property DragKind;\r\n property OnEndDock;\r\n property OnStartDock;\r\n property ColorOn;\r\n property ColorOff;\r\n property Constraints;\r\n property DragMode;\r\n property Height default 17;\r\n property Interval;\r\n property ParentShowHint;\r\n property PopupMenu;\r\n property ShowHint;\r\n property Status;\r\n property Visible;\r\n property Width default 17;\r\n property OnClick;\r\n property OnContextPopup;\r\n property OnDblClick;\r\n property OnDragDrop;\r\n property OnDragOver;\r\n property OnEndDrag;\r\n property OnMouseDown;\r\n property OnMouseMove;\r\n property OnMouseUp;\r\n property OnStartDrag;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvLED.pas $';\r\n Revision: '$Revision: 13104 $';\r\n Date: '$Date: 2011-09-07 08:50:43 +0200 (mer. 07 sept. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n SysUtils;\r\n\r\n{$R JvLED.res}\r\n\r\nconst\r\n cMaskLEDName = 'JvCustomLEDMASK';\r\n cGreenLEDName = 'JvCustomLEDGREEN';\r\n\r\n//=== { TJvCustomLED } =======================================================\r\n\r\nconstructor TJvCustomLED.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FImgPict := TBitmap.Create;\r\n FImgMask := TBitmap.Create;\r\n FImgMask.LoadFromResourceName(HInstance, cMaskLEDName);\r\n FTimer := TTimer.Create(Self);\r\n FTimer.Enabled := False;\r\n FTimer.OnTimer := DoBlink;\r\n FTimer.Interval := 1000;\r\n Color := clLime;\r\n Width := 17;\r\n Height := 17;\r\n ColorOn := clLime;\r\n ColorOff := clRed;\r\n Active := False;\r\n Status := True;\r\nend;\r\n\r\ndestructor TJvCustomLED.Destroy;\r\nbegin\r\n FTimer.Enabled := False;\r\n FTimer.OnTimer := nil;\r\n FImgPict.Free;\r\n FImgMask.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvCustomLED.Paint;\r\nvar\r\n DestRect, SrcRect: TRect;\r\nbegin\r\n if csDesigning in ComponentState then\r\n begin\r\n Canvas.Pen.Style := psDash;\r\n Canvas.Brush.Style := bsClear;\r\n Canvas.Rectangle(ClientRect);\r\n end;\r\n SrcRect := Rect(0, 0, FImgPict.Width, FImgPict.Height);\r\n DestRect := SrcRect;\r\n OffsetRect(DestRect, (ClientWidth - FImgPict.Width) div 2, (ClientHeight - FImgPict.Height) div 2);\r\n Canvas.CopyMode := cmSrcAnd;\r\n with Canvas do\r\n begin\r\n CopyRect(DestRect, FImgMask.Canvas, SrcRect);\r\n CopyMode := cmSrcPaint;\r\n CopyRect(DestRect, FImgPict.Canvas, SrcRect);\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomLED.SetColorOn(Value: TColor);\r\nbegin\r\n FColorOn := Value;\r\n if Status then\r\n Color := Value;\r\nend;\r\n\r\nprocedure TJvCustomLED.SetColorOff(Value: TColor);\r\nbegin\r\n FColorOff := Value;\r\n if not Status then\r\n Color := Value;\r\nend;\r\n\r\nfunction TJvCustomLED.GetInterval: Cardinal;\r\nbegin\r\n Result := FTimer.Interval;\r\nend;\r\n\r\nprocedure TJvCustomLED.SetInterval(Value: Cardinal);\r\nbegin\r\n if Value <> FTimer.Interval then\r\n FTimer.Interval := Value;\r\nend;\r\n\r\nfunction TJvCustomLED.GetActive: Boolean;\r\nbegin\r\n Result := FActive;\r\nend;\r\n\r\nprocedure TJvCustomLED.SetActive(Value: Boolean);\r\nbegin\r\n FActive := Value;\r\n if not (csDesigning in ComponentState) then\r\n FTimer.Enabled := Value;\r\nend;\r\n\r\nprocedure TJvCustomLED.SetStatus(Value: Boolean);\r\nbegin\r\n FStatus := Value;\r\n if Status then\r\n Color := ColorOn\r\n else\r\n Color := ColorOff;\r\n if Assigned(FOnChange) then\r\n FOnChange(Self);\r\nend;\r\n\r\nfunction TJvCustomLED.GetStatus: Boolean;\r\nbegin\r\n Result := FStatus;\r\nend;\r\n\r\nprocedure TJvCustomLED.DoBlink(Sender: TObject);\r\nbegin\r\n if not IsIconic(Application.Handle) then\r\n Status := not Status;\r\nend;\r\n\r\nprocedure TJvCustomLED.SetBounds(ALeft, ATop, AWidth, AHeight: Integer);\r\nbegin\r\n if AutoSize and (Align in [alNone, alCustom]) then\r\n inherited SetBounds(ALeft, ATop, FImgPict.Width, FImgPict.Height)\r\n else\r\n inherited SetBounds(ALeft, ATop, AWidth, AHeight);\r\nend;\r\n\r\n\r\n\r\nprocedure TJvCustomLED.ColorChanged;\r\nvar\r\n X, Y: Integer;\r\nbegin\r\n inherited ColorChanged;\r\n { Work around a TBitmap.ReadDIB() bug where FreeContext() is not called. This\r\n missing call leads to a GDI-Handle leak when the application is minimized\r\n because then FreeBitmapContexts() is not called. }\r\n FImgPict.Assign(nil);\r\n FImgPict.LoadFromResourceName(HInstance, cGreenLEDName);\r\n FImgPict.PixelFormat := pf24bit;\r\n for X := 0 to FImgPict.Width - 1 do\r\n for Y := 0 to FImgPict.Height - 1 do\r\n if FImgPict.Canvas.Pixels[X, Y] = clLime then\r\n FImgPict.Canvas.Pixels[X, Y] := Color;\r\n Repaint;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvLabel.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvLabel.PAS, released on 2001-02-28.\r\n\r\nThe Initial Developer of the Original Code is S?stien Buysse [sbuysse att buypin dott com]\r\nPortions created by S?stien Buysse are Copyright (C) 2001 S?stien Buysse.\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\nMichael Beck [mbeck att bigfoot dott com].\r\nPeter Thornqvist [peter3 at sourceforge dot net]\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nChanges:\r\n2005-07-20:(dejoy)\r\n * TJvCustomLabel implemented interface of IJvHotTrack.\r\n2005-04-02:\r\n * Fixed (Added) support for Alignment when used with Angle. (Layout still to do)\r\n * Fixed Shadow (was not visible when JvLabel not Transparent).\r\n * Fixed RoundedFrame (was not visible when not Transparent).\r\n2004-04-05:\r\n * Add property RoundedFrame in TJvCustomLabel (Integer>0 is the radius corner)\r\n2003-10-19:\r\n * Moved TJvCustomLabel from JvxCtrls to this unit\r\n2003-09-13:\r\n * Turned TJvCustomLabel into a consumer.\r\n Notes: * angled labels will simply use the current item's Text to render and ignore any provider\r\n specified rendering implementations.\r\n * D5 users: when changing a property that might clear out the provider (Caption,\r\n ImageIndex and Image) you can run into Access Violations if the Provider property is\r\n collapsed. This is due to a limitation in D5 property editors and can not be solved.\r\n2003-08-17:\r\n * Implementation moved to TJvCustomLabel. TJvLabel now only publishes properties and events.\r\n2003-03-24:\r\n * JvHotLink merged into JvLabel:\r\n To simulate JvHotlink, set AutoOpenURL to True, modify HotTrackFont to fit and assign\r\n a URL (or file-path) to the URL property.\r\n * JvAngleLabel merged into JvLabel: set Angle > 0 and font to a TrueTrype font to rotate the text // peter3\r\n\r\n Contributor(s):\r\n Dierk schmid\r\n Stephane Bischoff (Tief)\r\n Dejoy Den\r\n\r\nKnown Issues:\r\n* AutoSize calculations aren't correct when RoundedFrame and/or Shadow are active\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvLabel.pas 13415 2012-09-10 09:51:54Z obones $\r\n\r\nunit JvLabel;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, Messages, Types, Classes, Graphics, Controls, StdCtrls, ImgList,\r\n {$IFDEF HAS_UNIT_SYSTEM_UITYPES}\r\n System.UITypes,\r\n {$ENDIF HAS_UNIT_SYSTEM_UITYPES}\r\n JvTypes, JvComponent, JvDataProvider, JvExControls, JvHotTrackPersistent;\r\n\r\ntype\r\n TShadowPosition = (spLeftTop, spLeftBottom, spRightBottom, spRightTop);\r\n TJvLabelRotateAngle = -360..360;\r\n TJvTextEllipsis = (teNone, teWordEllipsis, tePathEllipsis, teEndEllipsis);\r\n\r\n TAngleInfo = record\r\n TextWidth: Integer;\r\n TextHeight: Integer;\r\n TextGapWidth: Integer;\r\n TextGapHeight: Integer;\r\n TotalWidth: Integer;\r\n TotalHeight: Integer;\r\n PosX: Integer;\r\n PosY: Integer;\r\n end;\r\n\r\n TJvLabelHotTrackOptions = TJvHotTrackOptions;\r\n\r\n TJvCustomLabel = class(TJvGraphicControl, IJvHotTrack)\r\n private\r\n FFocusControl: TWinControl;\r\n FAlignment: TAlignment;\r\n FAutoSize: Boolean;\r\n FLayout: TTextLayout;\r\n FShadowColor: TColor;\r\n FShadowSize: Byte;\r\n FShadowPos: TShadowPosition;\r\n FWordWrap: Boolean;\r\n FShowAccelChar: Boolean;\r\n FShowFocus: Boolean;\r\n FFocused: Boolean;\r\n FDragging: Boolean;\r\n FImageIndex: TImageIndex;\r\n FImages: TCustomImageList;\r\n FChangeLink: TChangeLink;\r\n FHotTrack: Boolean;\r\n FHotTrackFont: TFont;\r\n FHotTrackFontOptions: TJvTrackFontOptions;\r\n FHotTrackOptions: TJvLabelHotTrackOptions;\r\n\r\n FAutoOpenURL: Boolean;\r\n FURL: string;\r\n FAngle: TJvLabelRotateAngle;\r\n FSpacing: Integer;\r\n FConsumerSvc: TJvDataConsumer;\r\n FNeedsResize: Boolean;\r\n FTextEllipsis: TJvTextEllipsis;\r\n FFrameColor: TColor;\r\n FRoundedFrame: Integer; // DS\r\n FMarginLeft: Integer;\r\n FMarginTop: Integer;\r\n FMarginRight: Integer;\r\n FMarginBottom: Integer;\r\n function GetTransparent: Boolean;\r\n procedure UpdateTracking;\r\n procedure SetAlignment(Value: TAlignment);\r\n procedure SetFocusControl(Value: TWinControl);\r\n procedure SetLayout(Value: TTextLayout);\r\n procedure SetMargin(Value: Integer);\r\n procedure SetShadowColor(Value: TColor);\r\n procedure SetShadowSize(Value: Byte);\r\n procedure SetShadowPos(Value: TShadowPosition);\r\n procedure SetShowAccelChar(Value: Boolean);\r\n procedure SetTransparent(Value: Boolean);\r\n procedure SetWordWrap(Value: Boolean);\r\n procedure SetShowFocus(Value: Boolean);\r\n procedure SetImageIndex(Value: TImageIndex);\r\n procedure SetImages(Value: TCustomImageList);\r\n procedure DoImagesChange(Sender: TObject);\r\n procedure DrawAngleText(var Rect: TRect; Flags: Word; HasImage: Boolean;\r\n ShadowSize: Byte; ShadowColor: TColorRef; ShadowPos: TShadowPosition);\r\n procedure SetAngle(Value: TJvLabelRotateAngle);\r\n procedure SetSpacing(Value: Integer);\r\n procedure SetTextEllipsis(Value: TJvTextEllipsis);\r\n procedure SetFrameColor(const Value: TColor);\r\n procedure SetRoundedFrame(const Value: Integer);\r\n function GetMargin: Integer;\r\n procedure HotFontChanged(Sender: TObject);\r\n\r\n {IJvHotTrack} //added by dejoy 2005-07-20\r\n function GetHotTrack: Boolean;\r\n function GetHotTrackFont: TFont;\r\n function GetHotTrackFontOptions: TJvTrackFontOptions;\r\n function GetHotTrackOptions: TJvLabelHotTrackOptions;\r\n procedure SetHotTrack(Value: Boolean);\r\n procedure SetHotTrackFont(Value: TFont);\r\n procedure SetHotTrackFontOptions(Value: TJvTrackFontOptions);\r\n procedure SetHotTrackOptions(Value: TJvLabelHotTrackOptions);\r\n procedure IJvHotTrack_Assign(Source: IJvHotTrack);\r\n procedure IJvHotTrack.Assign = IJvHotTrack_Assign;\r\n protected\r\n procedure DoDrawCaption(var Rect: TRect; Flags: Integer); virtual;\r\n procedure DoProviderDraw(var Rect: TRect; Flags: Integer); virtual;\r\n procedure FocusChanged(AControl: TWinControl); override;\r\n procedure TextChanged; override;\r\n procedure FontChanged; override;\r\n function WantKey(Key: Integer; Shift: TShiftState): Boolean; override;\r\n procedure EnabledChanged; override;\r\n\r\n procedure DoDrawText(var Rect: TRect; Flags: Integer); virtual;\r\n procedure AdjustBounds; virtual;\r\n procedure SetAutoSize(Value: Boolean); override;\r\n\r\n // MarginXxx do not update the control.\r\n property MarginLeft: Integer read FMarginLeft write FMarginLeft;\r\n property MarginTop: Integer read FMarginTop write FMarginTop;\r\n property MarginRight: Integer read FMarginRight write FMarginRight;\r\n property MarginBottom: Integer read FMarginBottom write FMarginBottom;\r\n\r\n function GetDefaultFontColor: TColor; virtual;\r\n function GetLabelCaption: string; virtual;\r\n function IsValidImage: Boolean;\r\n procedure MouseDown(Button: TMouseButton; Shift: TShiftState;\r\n X, Y: Integer); override;\r\n procedure MouseUp(Button: TMouseButton; Shift: TShiftState;\r\n X, Y: Integer); override;\r\n procedure Notification(AComponent: TComponent; Operation: TOperation); override;\r\n procedure Click; override;\r\n procedure Paint; override;\r\n procedure Loaded; override;\r\n procedure MouseEnter(Control: TControl); override;\r\n procedure MouseLeave(Control: TControl); override;\r\n function GetImageWidth: Integer; virtual;\r\n function GetImageHeight: Integer; virtual;\r\n procedure SetConsumerService(Value: TJvDataConsumer);\r\n function ProviderActive: Boolean;\r\n procedure ConsumerServiceChanged(Sender: TJvDataConsumer; Reason: TJvDataConsumerChangeReason);\r\n procedure NonProviderChange;\r\n property Angle: TJvLabelRotateAngle read FAngle write SetAngle default 0;\r\n property AutoOpenURL: Boolean read FAutoOpenURL write FAutoOpenURL default True;\r\n\r\n property HotTrack: Boolean read GetHotTrack write SetHotTrack default False;\r\n property HotTrackFont: TFont read GetHotTrackFont write SetHotTrackFont;\r\n property HotTrackFontOptions: TJvTrackFontOptions read GetHotTrackFontOptions write SetHotTrackFontOptions default\r\n DefaultTrackFontOptions;\r\n property HotTrackOptions: TJvLabelHotTrackOptions read GetHotTrackOptions write SetHotTrackOptions;\r\n\r\n property NeedsResize: Boolean read FNeedsResize write FNeedsResize;\r\n\r\n property Alignment: TAlignment read FAlignment write SetAlignment default taLeftJustify;\r\n property AutoSize: Boolean read FAutoSize write SetAutoSize default True;\r\n property FocusControl: TWinControl read FFocusControl write SetFocusControl;\r\n property FrameColor: TColor read FFrameColor write SetFrameColor default clNone;\r\n property Images: TCustomImageList read FImages write SetImages;\r\n property ImageIndex: TImageIndex read FImageIndex write SetImageIndex default -1;\r\n property TextEllipsis: TJvTextEllipsis read FTextEllipsis write SetTextEllipsis default teNone;\r\n // specifies the offset between the right edge of the image and the left edge of the text (in pixels)\r\n property Spacing: Integer read FSpacing write SetSpacing default 4;\r\n property Layout: TTextLayout read FLayout write SetLayout default tlTop;\r\n property Margin: Integer read GetMargin write SetMargin default 0;\r\n property RoundedFrame: Integer read FRoundedFrame write SetRoundedFrame default 0; //DS\r\n property ShadowColor: TColor read FShadowColor write SetShadowColor default clBtnHighlight;\r\n property ShadowSize: Byte read FShadowSize write SetShadowSize default 0;\r\n property ShadowPos: TShadowPosition read FShadowPos write SetShadowPos default spRightBottom;\r\n property ShowAccelChar: Boolean read FShowAccelChar write SetShowAccelChar default True;\r\n property ShowFocus: Boolean read FShowFocus write SetShowFocus default False;\r\n property Transparent: Boolean read GetTransparent write SetTransparent default False;\r\n property URL: string read FURL write FURL;\r\n property Provider: TJvDataConsumer read FConsumerSvc write SetConsumerService;\r\n property WordWrap: Boolean read FWordWrap write SetWordWrap default False;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n property Canvas;\r\n property MouseOver;\r\n procedure SetBounds(ALeft: Integer; ATop: Integer; AWidth: Integer; AHeight: Integer); override;\r\n end;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvLabel = class(TJvCustomLabel)\r\n published\r\n property Action;\r\n property Align;\r\n property Alignment;\r\n property AutoSize;\r\n property Caption;\r\n property Color;\r\n property DragCursor;\r\n property BiDiMode;\r\n property DragKind;\r\n property ParentBiDiMode;\r\n property DragMode;\r\n property Enabled;\r\n property FocusControl;\r\n property FrameColor;\r\n property Font;\r\n property Anchors;\r\n property Constraints;\r\n property Layout;\r\n property Margin;\r\n property ParentColor;\r\n property ParentFont;\r\n property ParentShowHint;\r\n property PopupMenu;\r\n property RoundedFrame;\r\n property ShadowColor;\r\n property ShadowSize;\r\n property ShadowPos;\r\n property ShowAccelChar;\r\n property ShowFocus;\r\n property ShowHint;\r\n property Transparent;\r\n property Visible;\r\n property WordWrap;\r\n property OnClick;\r\n property OnDblClick;\r\n property OnDragDrop;\r\n property OnDragOver;\r\n property OnEndDrag;\r\n property OnMouseDown;\r\n property OnMouseMove;\r\n property OnMouseUp;\r\n property OnMouseEnter;\r\n property OnMouseLeave;\r\n property OnStartDrag;\r\n property OnContextPopup;\r\n\r\n property Angle;\r\n property AutoOpenURL;\r\n property HintColor;\r\n property HotTrack;\r\n property HotTrackFont;\r\n property HotTrackFontOptions;\r\n property HotTrackOptions;\r\n property Images;\r\n property ImageIndex;\r\n property Provider;\r\n property Spacing;\r\n property TextEllipsis;\r\n property URL;\r\n property OnParentColorChange;\r\n end;\r\n\r\nfunction DrawShadowText(Canvas: TCanvas; Str: PChar; Count: Integer; var Rect: TRect;\r\n Format: Word; ShadowSize: Byte; ShadowColor: TColorRef;\r\n ShadowPos: TShadowPosition): Integer;\r\n\r\nprocedure FrameRounded(Canvas: TCanvas; ARect: TRect; AColor: TColor; R: Integer);\r\n\r\nfunction CalculateAlignment(Alignment: TAlignment; Angle: Integer; X, Y: Real;\r\n Info: TAngleInfo): TPoint;\r\nprocedure CalculateAngleInfo(Canvas: TCanvas; Angle: Integer; Text: string;\r\n Rect: TRect; var Info: TAngleInfo; AutoSize: Boolean = True;\r\n Alignment: TAlignment = taLeftJustify);\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvLabel.pas $';\r\n Revision: '$Revision: 13415 $';\r\n Date: '$Date: 2012-09-10 11:51:54 +0200 (lun. 10 sept. 2012) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n SysUtils, Math, Forms,\r\n JvDataProviderIntf, JvConsts, JvThemes, JvJCLUtils, JvJVCLUtils;\r\n\r\nconst\r\n Alignments: array [TAlignment] of Word = (DT_LEFT, DT_RIGHT, DT_CENTER);\r\n WordWraps: array [Boolean] of Word = (0, DT_WORDBREAK);\r\n\r\n//=== { TJvCustomLabel } =====================================================\r\n\r\nfunction CalculateAlignment(Alignment: TAlignment; Angle: Integer; X, Y: Real; Info: TAngleInfo): TPoint;\r\nbegin\r\n with Info do\r\n case Angle of\r\n 0..89:\r\n case Alignment of\r\n taLeftJustify:\r\n Result := Point(0, Round(Y + (TotalHeight - 2 * TextGapHeight) / 2));\r\n taCenter:\r\n Result := Point(Round(X - TotalWidth / 2), Round(Y + (TotalHeight - 2 * TextGapHeight) / 2));\r\n taRightJustify:\r\n Result := Point(Round(X * 2 - TotalWidth), Round(Y + (TotalHeight - 2 * TextGapHeight) / 2));\r\n end;\r\n 90..179:\r\n case Alignment of\r\n taLeftJustify:\r\n Result := Point(TextWidth, Round(Y + TotalHeight / 2));\r\n taCenter:\r\n Result := Point(Round(X + (TotalWidth - 2 * TextGapWidth) / 2), Round(Y + TotalHeight / 2));\r\n taRightJustify:\r\n Result := Point(Round(X * 2 - TextGapWidth), Round(Y + TotalHeight / 2));\r\n end;\r\n 180..269:\r\n case Alignment of\r\n taLeftJustify:\r\n Result := Point(TotalWidth, Round(Y - (TotalHeight - 2 * TextGapHeight) / 2));\r\n taCenter:\r\n Result := Point(Round(X + TotalWidth / 2), Round(Y - (TotalHeight - 2 * TextGapHeight) / 2));\r\n taRightJustify:\r\n Result := Point(Round(X * 2), Round(Y - (TotalHeight - 2 * TextGapHeight) / 2));\r\n end;\r\n else\r\n case Alignment of\r\n taLeftJustify:\r\n Result := Point(TextGapWidth, Round(Y - TotalHeight / 2));\r\n taCenter:\r\n Result := Point(Round(X - (TotalWidth - 2 * TextGapWidth) / 2), Round(Y - TotalHeight / 2));\r\n taRightJustify:\r\n Result := Point(Round(X * 2 - TextWidth), Round(Y - TotalHeight / 2));\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure CalculateAngleInfo(Canvas: TCanvas; Angle: Integer; Text: string;\r\n Rect: TRect; var Info: TAngleInfo; AutoSize: Boolean = True;\r\n Alignment: TAlignment = taLeftJustify);\r\nvar\r\n TxtWdt, TxtHgt: Extended;\r\n AngleB, X, Y: Real;\r\n Origin: TPoint;\r\nbegin\r\n // Calculate intermediate values\r\n case Angle of\r\n 0..89:\r\n AngleB := DegToRad(90 - Angle);\r\n 90..179:\r\n AngleB := DegToRad(Angle - 90);\r\n 180..269:\r\n AngleB := DegToRad(270 - Angle);\r\n else {270..359}\r\n AngleB := DegToRad(Angle - 270);\r\n end;\r\n with Canvas do\r\n begin\r\n TxtWdt := TextWidth(Text);\r\n TxtHgt := TextHeight(Text);\r\n end;\r\n with Info do\r\n begin\r\n TextWidth := Round(Sin(AngleB) * TxtWdt);\r\n TextGapWidth := Round(Cos(AngleB) * TxtHgt);\r\n TextHeight := Round(Cos(AngleB) * TxtWdt);\r\n TextGapHeight := Round(Sin(AngleB) * TxtHgt);\r\n // Calculate new sizes of component\r\n TotalWidth := (TextWidth + TextGapWidth);\r\n TotalHeight := (TextHeight + TextGapHeight);\r\n end;\r\n // Calculate draw position of text\r\n X := (Rect.Right - Rect.Left) / 2;\r\n Y := (Rect.Bottom - Rect.Top) / 2;\r\n // Calculate Layout and Alignment Position\r\n //SetTextAlign(Canvas.Handle, TA_LEFT);\r\n Origin := CalculateAlignment(Alignment, Angle, X, Y, Info);\r\n if AutoSize then\r\n begin\r\n case Angle of\r\n 0..89:\r\n begin\r\n Info.PosX := 0;\r\n Info.PosY := Info.TextHeight;\r\n end;\r\n 90..179:\r\n begin\r\n Info.PosX := Info.TextWidth;\r\n Info.PosY := Info.TotalHeight;\r\n end;\r\n 180..269:\r\n begin\r\n Info.posX := Info.TotalWidth;\r\n Info.posY := Info.TextGapHeight;\r\n end;\r\n else{270..359}\r\n Info.PosX := Info.TextGapWidth;\r\n Info.PosY := 0;\r\n end;\r\n end\r\n else\r\n begin\r\n Info.PosX := Origin.X;\r\n Info.PosY := Origin.Y;\r\n end;\r\nend;\r\n\r\nfunction DrawShadowText(Canvas: TCanvas; Str: PChar; Count: Integer; var Rect: TRect;\r\n Format: Word; ShadowSize: Byte; ShadowColor: TColorRef;\r\n ShadowPos: TShadowPosition): Integer;\r\nvar\r\n RText, RShadow: TRect;\r\n Color: TColorRef;\r\nbegin\r\n RText := Rect;\r\n RShadow := Rect;\r\n Color := SetTextColor(Canvas.Handle, ShadowColor);\r\n case ShadowPos of\r\n spLeftTop:\r\n OffsetRect(RShadow, -ShadowSize, -ShadowSize);\r\n spRightBottom:\r\n OffsetRect(RShadow, ShadowSize, ShadowSize);\r\n spLeftBottom:\r\n begin\r\n {OffsetRect(RText, ShadowSize, 0);}\r\n OffsetRect(RShadow, -ShadowSize, ShadowSize);\r\n end;\r\n spRightTop:\r\n begin\r\n {OffsetRect(RText, 0, ShadowSize);}\r\n OffsetRect(RShadow, ShadowSize, -ShadowSize);\r\n end;\r\n end;\r\n Canvas.Brush.Style := bsClear;\r\n Result := DrawText(Canvas, Str, Count, RShadow, Format);\r\n if Result > 0 then\r\n Inc(Result, ShadowSize);\r\n SetTextColor(Canvas.Handle, Color);\r\n DrawText(Canvas, Str, Count, RText, Format);\r\n UnionRect(Rect, RText, RShadow);\r\nend;\r\n\r\nconstructor TJvCustomLabel.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FFrameColor := clNone;\r\n FImageIndex := -1;\r\n FConsumerSvc := TJvDataConsumer.Create(Self, [DPA_RendersSingleItem]);\r\n FConsumerSvc.OnChanged := ConsumerServiceChanged;\r\n FChangeLink := TChangeLink.Create;\r\n FChangeLink.OnChange := DoImagesChange;\r\n ControlStyle := ControlStyle + [csOpaque, csReplicatable];\r\n {$IFDEF JVCLThemesEnabled}\r\n if ThemeServices.Enabled then\r\n ControlStyle := ControlStyle - [csOpaque];\r\n {$ENDIF JVCLThemesEnabled}\r\n\r\n FHotTrack := False;\r\n // (rom) needs better font handling\r\n FHotTrackFont := TFont.Create;\r\n FHotTrackFontOptions := DefaultTrackFontOptions;\r\n FHotTrackOptions := TJvLabelHotTrackOptions.Create(Self);\r\n // (rom) needs better font handling\r\n FHotTrackFont.OnChange := HotFontChanged;\r\n\r\n Width := 65;\r\n Height := 17;\r\n FAutoSize := True;\r\n FSpacing := 4;\r\n FShowAccelChar := True;\r\n FShadowColor := clBtnHighlight;\r\n FShadowSize := 0;\r\n FShadowPos := spRightBottom;\r\n FAutoOpenURL := True;\r\nend;\r\n\r\ndestructor TJvCustomLabel.Destroy;\r\nbegin\r\n FChangeLink.Free;\r\n FHotTrackFont.Free;\r\n FHotTrackOptions.Free;\r\n FreeAndNil(FConsumerSvc);\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJvCustomLabel.GetLabelCaption: string;\r\nvar\r\n ItemText: IJvDataItemText;\r\nbegin\r\n if ProviderActive then\r\n begin\r\n Provider.Enter;\r\n try\r\n if Supports((Provider as IJvDataConsumerItemSelect).GetItem, IJvDataItemText, ItemText) then\r\n Result := ItemText.Text\r\n else\r\n Result := Caption;\r\n finally\r\n Provider.Leave;\r\n end;\r\n end\r\n else\r\n Result := Caption;\r\nend;\r\n\r\nfunction TJvCustomLabel.GetDefaultFontColor: TColor;\r\nbegin\r\n Result := Font.Color;\r\nend;\r\n\r\nprocedure TJvCustomLabel.DoProviderDraw(var Rect: TRect; Flags: Integer);\r\nvar\r\n Tmp: TSize;\r\n TmpItem: IJvDataItem;\r\n ItemsRenderer: IJvDataItemsRenderer;\r\n ItemRenderer: IJvDataItemRenderer;\r\n DrawState: TProviderDrawStates;\r\nbegin\r\n Provider.Enter;\r\n try\r\n if not Enabled then\r\n DrawState := [pdsDisabled]\r\n else\r\n DrawState := [];\r\n TmpItem := (Provider as IJvDataConsumerItemSelect).GetItem;\r\n if (TmpItem <> nil) and (Supports(TmpItem.GetItems, IJvDataItemsRenderer, ItemsRenderer) or\r\n Supports(TmpItem, IJvDataItemRenderer, ItemRenderer)) then\r\n begin\r\n Canvas.Brush.Color := Color;\r\n if MouseOver then\r\n Canvas.Font := HotTrackFont\r\n else\r\n Canvas.Font := Font;\r\n if (Flags and DT_CALCRECT) <> 0 then\r\n begin\r\n if ItemsRenderer <> nil then\r\n Tmp := ItemsRenderer.MeasureItem(Canvas, TmpItem)\r\n else\r\n Tmp := ItemRenderer.Measure(Canvas);\r\n Rect.Right := Tmp.cx;\r\n Rect.Bottom := Tmp.cy;\r\n end\r\n else\r\n begin\r\n if ItemsRenderer <> nil then\r\n ItemsRenderer.DrawItem(Canvas, Rect, TmpItem, DrawState)\r\n else\r\n ItemRenderer.Draw(Canvas, Rect, DrawState);\r\n end;\r\n end\r\n else\r\n DoDrawCaption(Rect, Flags);\r\n finally\r\n Provider.Leave;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomLabel.DoDrawCaption(var Rect: TRect; Flags: Integer);\r\nconst\r\n EllipsisFlags: array [TJvTextEllipsis] of Integer =\r\n (0, DT_WORD_ELLIPSIS, DT_PATH_ELLIPSIS, DT_END_ELLIPSIS);\r\nvar\r\n Text: string;\r\n PosShadow: TShadowPosition;\r\n SizeShadow: Byte;\r\n ColorShadow: TColor;\r\n X, Y: Integer;\r\nbegin\r\n Text := GetLabelCaption;\r\n if (Flags and DT_CALCRECT <> 0) and ((Text = '') or FShowAccelChar and\r\n (Text[1] = '&') and (Text[2] = #0)) then\r\n Text := Text + ' ';\r\n if not FShowAccelChar then\r\n Flags := Flags or DT_NOPREFIX;\r\n Flags := Flags or EllipsisFlags[TextEllipsis];\r\n Flags := DrawTextBiDiModeFlags(Flags);\r\n if not MouseOver or not HotTrack then\r\n begin\r\n Canvas.Font := Font;\r\n Canvas.Font.Color := GetDefaultFontColor;\r\n end\r\n else\r\n begin\r\n if HotTrack then\r\n if MouseOver then\r\n Canvas.Font := HotTrackFont\r\n end;\r\n PosShadow := FShadowPos;\r\n SizeShadow := FShadowSize;\r\n ColorShadow := FShadowColor;\r\n if not Enabled then\r\n begin\r\n if FShadowSize = 0 then\r\n begin\r\n PosShadow := spRightBottom;\r\n SizeShadow := 1;\r\n end;\r\n Canvas.Font.Color := clGrayText;\r\n ColorShadow := clBtnHighlight;\r\n end;\r\n if IsValidImage then\r\n Inc(Rect.Left, GetImageWidth + Spacing);\r\n if Angle <> 0 then\r\n DrawAngleText(Rect, Flags, IsValidImage, SizeShadow, ColorToRGB(ColorShadow), PosShadow)\r\n else\r\n DrawShadowText(Canvas, PChar(Text), Length(Text), Rect, Flags,\r\n SizeShadow, ColorToRGB(ColorShadow), PosShadow);\r\n // (p3) draw image here since it can potentionally change background and font color\r\n if IsValidImage and (Flags and DT_CALCRECT = 0) then\r\n begin\r\n X := MarginLeft;\r\n case Layout of\r\n tlTop:\r\n Y := MarginTop;\r\n tlBottom:\r\n Y := Height - Images.Height - MarginBottom;\r\n else\r\n Y := (Height - Images.Height) div 2;\r\n end;\r\n if Y < MarginTop then\r\n Y := MarginTop;\r\n Images.Draw(Canvas, X, Y, ImageIndex, Enabled);\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomLabel.DoDrawText(var Rect: TRect; Flags: Integer);\r\nbegin\r\n if ProviderActive then\r\n DoProviderDraw(Rect, Flags)\r\n else\r\n DoDrawCaption(Rect, Flags);\r\nend;\r\n\r\n\r\n//\r\n// TODO: check if code for VCL is applicable to CLX. If so, make change\r\n//\r\nprocedure TJvCustomLabel.DrawAngleText(var Rect: TRect; Flags: Word; HasImage: Boolean;\r\n ShadowSize: Byte; ShadowColor: TColorRef; ShadowPos: TShadowPosition);\r\nvar\r\n Text: array [0..4096] of Char;\r\n LogFont, NewLogFont: TLogFont;\r\n NewFont: HFont;\r\n TextX, TextY, ShadowX, ShadowY: Integer;\r\n Angle10: Integer;\r\n W, H: Integer;\r\n Info: TAngleInfo;\r\n CalcRect: Boolean;\r\nbegin\r\n Angle10 := Angle * 10;\r\n CalcRect := (Flags and DT_CALCRECT <> 0);\r\n StrLCopy(@Text, PChar(GetLabelCaption), SizeOf(Text) - 1);\r\n if CalcRect and ((Text[0] = #0) or ShowAccelChar and\r\n (Text[0] = '&') and (Text[1] = #0)) then\r\n StrCopy(Text, ' ');\r\n if MouseOver then\r\n Canvas.Font := HotTrackFont\r\n else\r\n Canvas.Font := Font;\r\n if GetObject(Font.Handle, SizeOf(TLogFont), @LogFont) = 0 then\r\n RaiseLastOSError;\r\n NewLogFont := LogFont;\r\n NewLogFont.lfEscapement := Angle10;\r\n NewLogFont.lfOutPrecision := OUT_TT_ONLY_PRECIS;\r\n NewFont := CreateFontIndirect(NewLogFont);\r\n {\r\n (p3) unnecessary\r\n OldFont := SelectObject(Canvas.Font.Handle, NewFont);\r\n DeleteObject(OldFont);\r\n ...this does the same thing:\r\n }\r\n Canvas.Font.Handle := NewFont;\r\n Canvas.Brush.Style := bsClear; // Do not Erase Shadow or Background\r\n\r\n CalculateAngleInfo(Canvas, Angle, Text, ClientRect, Info, AutoSize, Alignment);\r\n W := Info.TotalWidth;\r\n H := Info.TotalHeight;\r\n TextX := Info.posX;\r\n TextY := Info.posY;\r\n\r\n if CalcRect then\r\n begin\r\n Rect.Right := Rect.Left + W;\r\n Rect.Bottom := Rect.Top + H;\r\n if HasImage then\r\n Inc(Rect.Right, Images.Width);\r\n Inc(Rect.Right, MarginLeft + MarginRight);\r\n Inc(Rect.Bottom, MarginTop + MarginBottom);\r\n end\r\n else\r\n begin\r\n if HasImage then\r\n begin\r\n case Alignment of\r\n taLeftJustify:\r\n Inc(TextX, Images.Width);\r\n taCenter:\r\n Inc(TextX, Images.Width div 2);\r\n taRightJustify:\r\n Inc(TextX, 0);\r\n end;\r\n end;\r\n Inc(TextX, MarginLeft);\r\n Inc(TextY, MarginTop);\r\n if ShadowSize > 0 then\r\n begin\r\n ShadowX := TextX;\r\n ShadowY := TextY;\r\n case ShadowPos of\r\n spLeftTop:\r\n begin\r\n Dec(ShadowX, ShadowSize);\r\n Dec(ShadowY, ShadowSize);\r\n end;\r\n spRightBottom:\r\n begin\r\n Inc(ShadowX, ShadowSize);\r\n Inc(ShadowY, ShadowSize);\r\n end;\r\n spLeftBottom:\r\n begin\r\n Dec(ShadowX, ShadowSize);\r\n Inc(ShadowY, ShadowSize);\r\n end;\r\n spRightTop:\r\n begin\r\n Inc(ShadowX, ShadowSize);\r\n Dec(ShadowY, ShadowSize);\r\n end;\r\n end;\r\n Canvas.Font.Color := ShadowColor;\r\n Canvas.TextOut(ShadowX, ShadowY, Text);\r\n end;\r\n Canvas.Font.Color := Self.Font.Color;\r\n if not Enabled then\r\n begin\r\n Canvas.Font.Color := clBtnHighlight;\r\n Canvas.TextOut(TextX + 1, TextY + 1, Text);\r\n Canvas.Font.Color := clBtnShadow;\r\n end;\r\n Canvas.TextOut(TextX, TextY, Text);\r\n end;\r\nend;\r\n\r\n\r\n\r\n\r\nprocedure TJvCustomLabel.Paint;\r\nvar\r\n Rect,CalcRect: TRect;\r\n DrawStyle: Integer;\r\n InteriorMargin: Integer;\r\n OldPenColor: TColor;\r\nbegin\r\n InteriorMargin := 0;\r\n if not Enabled and not (csDesigning in ComponentState) then\r\n FDragging := False;\r\n\r\n with Canvas do\r\n begin\r\n Rect := ClientRect;\r\n\r\n {Inserted by (dejoy) 2005-07-20}\r\n if Enabled and MouseOver and HotTrack then\r\n begin\r\n if HotTrackOptions.Enabled then\r\n begin\r\n Canvas.Brush.Color := HotTrackOptions.Color;\r\n Canvas.Brush.Style := bsSolid;\r\n if HotTrackOptions.FrameVisible then\r\n begin\r\n OldPenColor := Pen.Color;\r\n if RoundedFrame = 0 then\r\n begin\r\n Canvas.Pen.Color := HotTrackOptions.FrameColor;\r\n Canvas.Rectangle(0, 0, Width, Height);\r\n end\r\n else\r\n begin\r\n if not Transparent then // clx: TODO\r\n FloodFill(ClientRect.Left + 1, ClientRect.Top + RoundedFrame, HotTrackOptions.FrameColor, fsBorder);\r\n FrameRounded(Canvas, ClientRect, HotTrackOptions.FrameColor, RoundedFrame);\r\n end;\r\n Canvas.Pen.Color := OldPenColor;\r\n end\r\n else\r\n Canvas.FillRect(Rect);\r\n end;\r\n end\r\n else\r\n begin\r\n Canvas.Font := Self.Font;\r\n {Insert End by (dejoy)}\r\n\r\n Canvas.Brush.Color := Color;\r\n Canvas.Brush.Style := bsSolid;\r\n if not Transparent and ((RoundedFrame = 0) or (FrameColor = clNone)) then\r\n DrawThemedBackground(Self, Canvas, ClientRect)\r\n else\r\n if Transparent then\r\n Canvas.Brush.Style := bsClear;\r\n\r\n if FrameColor <> clNone then\r\n begin\r\n if RoundedFrame = 0 then\r\n begin\r\n Brush.Color := FrameColor;\r\n FrameRect( ClientRect);\r\n end\r\n else\r\n begin\r\n Brush.Color := Color;\r\n if not Transparent then // clx: TODO\r\n FloodFill(ClientRect.Left + 1, ClientRect.Top + RoundedFrame, FrameColor, fsBorder);\r\n FrameRounded(Canvas, ClientRect, FrameColor, RoundedFrame);\r\n end;\r\n end;\r\n end;\r\n\r\n Inc(Rect.Left, MarginLeft + InteriorMargin);\r\n Dec(Rect.Right, MarginRight + InteriorMargin);\r\n Inc(Rect.Top, MarginTop + InteriorMargin);\r\n Dec(Rect.Bottom, MarginBottom + InteriorMargin);\r\n InflateRect(Rect, -1, 0);\r\n DrawStyle := DT_EXPANDTABS or WordWraps[FWordWrap] or\r\n Alignments[FAlignment];\r\n { Calculate vertical layout }\r\n if FLayout <> tlTop then\r\n begin\r\n CalcRect := Rect;\r\n DoDrawText(CalcRect, DrawStyle or DT_CALCRECT);\r\n if FLayout = tlBottom then\r\n OffsetRect(Rect, 0, Height - CalcRect.Bottom)\r\n else\r\n OffsetRect(Rect, 0, (Height - CalcRect.Bottom) div 2);\r\n end;\r\n Rect.Left := MarginLeft;\r\n Rect.Right := Rect.Right - MarginRight;\r\n DoDrawText(Rect, DrawStyle);\r\n if FShowFocus and Assigned(FFocusControl) and FFocused and\r\n not (csDesigning in ComponentState) then\r\n begin\r\n InflateRect(Rect, 1, 0);\r\n Brush.Color := Self.Color;\r\n DrawFocusRect(Rect);\r\n end;\r\n// if Angle = 0 then\r\n// AdjustBounds;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomLabel.Loaded;\r\nbegin\r\n inherited Loaded;\r\n Provider.Loaded;\r\n FNeedsResize := True;\r\n AdjustBounds;\r\nend;\r\n\r\nprocedure TJvCustomLabel.AdjustBounds;\r\nvar\r\n DC: HDC;\r\n X: Integer;\r\n Rect, R: TRect;\r\n AAlignment: TAlignment;\r\nbegin\r\n if not (csReading in ComponentState) and AutoSize and FNeedsResize then\r\n begin\r\n Rect := ClientRect;\r\n InflateRect(Rect, -1, 0);\r\n DC := GetDC(NullHandle);\r\n Canvas.Handle := DC;\r\n if Angle = 0 then\r\n begin\r\n R := Rect;\r\n Inc(Rect.Left, MarginLeft);\r\n Inc(Rect.Top, MarginTop);\r\n Dec(Rect.Right, MarginRight);\r\n Dec(Rect.Bottom, MarginBottom);\r\n //InflateRect(Rect, -Margin, -Margin);\r\n\r\n DoDrawText(Rect, DT_EXPANDTABS or DT_CALCRECT or WordWraps[FWordWrap]);\r\n\r\n Dec(Rect.Left, MarginLeft);\r\n Dec(Rect.Top, MarginTop);\r\n Inc(Rect.Right, MarginRight);\r\n Inc(Rect.Bottom, MarginBottom);\r\n //InflateRect(Rect, Margin, Margin);\r\n\r\n Inc(Rect.Bottom, MarginTop);\r\n end\r\n else\r\n DrawAngleText(Rect, DT_CALCRECT or DT_EXPANDTABS or DT_WORDBREAK or Alignments[Alignment], IsValidImage, 0, 0, spLeftTop);\r\n Canvas.Handle := NullHandle;\r\n ReleaseDC(NullHandle, DC);\r\n InflateRect(Rect, 1, 0);\r\n X := Left;\r\n AAlignment := FAlignment;\r\n if UseRightToLeftAlignment then\r\n ChangeBiDiModeAlignment(AAlignment);\r\n if IsValidImage then\r\n begin\r\n Rect.Bottom := Max(Rect.Bottom, Rect.Top + GetImageHeight);\r\n// Inc(Rect.Right, Spacing);\r\n end;\r\n if (AAlignment = taRightJustify) and not IsValidImage then\r\n Inc(X, Width - Rect.Right);\r\n SetBounds(X, Top, Rect.Right, Rect.Bottom);\r\n end;\r\n FNeedsResize := False;\r\nend;\r\n\r\nprocedure TJvCustomLabel.HotFontChanged(Sender: TObject);\r\nbegin\r\n if MouseOver then\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvCustomLabel.SetAlignment(Value: TAlignment);\r\nbegin\r\n if FAlignment <> Value then\r\n begin\r\n FAlignment := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomLabel.SetAutoSize(Value: Boolean);\r\nbegin\r\n inherited SetAutoSize(Value);\r\n FAutoSize := Value;\r\n FNeedsResize := FAutoSize;\r\n AdjustBounds;\r\nend;\r\n\r\nprocedure TJvCustomLabel.SetLayout(Value: TTextLayout);\r\nbegin\r\n if FLayout <> Value then\r\n begin\r\n FLayout := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nfunction TJvCustomLabel.GetMargin: Integer;\r\nbegin\r\n Result := FMarginLeft;\r\nend;\r\n\r\nprocedure TJvCustomLabel.SetMargin(Value: Integer);\r\nbegin\r\n Value := Max(Value, 0);\r\n if Margin <> Value then\r\n begin\r\n MarginLeft := Value;\r\n MarginTop := Value;\r\n MarginRight := Value;\r\n MarginBottom := Value;\r\n\r\n FNeedsResize := True;\r\n AdjustBounds;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomLabel.SetShadowColor(Value: TColor);\r\nbegin\r\n if Value <> FShadowColor then\r\n begin\r\n FShadowColor := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomLabel.SetShadowSize(Value: Byte);\r\nbegin\r\n if Value <> FShadowSize then\r\n begin\r\n FShadowSize := Value;\r\n FNeedsResize := True;\r\n AdjustBounds;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomLabel.SetShadowPos(Value: TShadowPosition);\r\nbegin\r\n if Value <> FShadowPos then\r\n begin\r\n FShadowPos := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nfunction TJvCustomLabel.GetTransparent: Boolean;\r\nbegin\r\n Result := not (csOpaque in ControlStyle);\r\nend;\r\n\r\nprocedure TJvCustomLabel.SetFocusControl(Value: TWinControl);\r\nbegin\r\n ReplaceComponentReference(Self, Value, TComponent(FFocusControl));\r\n if FShowFocus then\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvCustomLabel.SetShowAccelChar(Value: Boolean);\r\nbegin\r\n if FShowAccelChar <> Value then\r\n begin\r\n FShowAccelChar := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomLabel.SetTransparent(Value: Boolean);\r\nbegin\r\n if Transparent <> Value then\r\n begin\r\n {$IFDEF JVCLThemesEnabled}\r\n if ThemeServices.Enabled then\r\n Value := True; // themes aware Labels are always transparent\r\n {$ENDIF JVCLThemesEnabled}\r\n if Value then\r\n ControlStyle := ControlStyle - [csOpaque]\r\n else\r\n ControlStyle := ControlStyle + [csOpaque];\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomLabel.SetShowFocus(Value: Boolean);\r\nbegin\r\n if FShowFocus <> Value then\r\n begin\r\n FShowFocus := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomLabel.SetWordWrap(Value: Boolean);\r\nbegin\r\n if FWordWrap <> Value then\r\n begin\r\n FWordWrap := Value;\r\n FNeedsResize := True;\r\n AdjustBounds;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomLabel.Notification(AComponent: TComponent;\r\n Operation: TOperation);\r\nbegin\r\n inherited Notification(AComponent, Operation);\r\n if Operation = opRemove then\r\n begin\r\n if AComponent = FFocusControl then\r\n FocusControl := nil;\r\n if AComponent = Images then\r\n Images := nil;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomLabel.MouseDown(Button: TMouseButton; Shift: TShiftState;\r\n X, Y: Integer);\r\nbegin\r\n inherited MouseDown(Button, Shift, X, Y);\r\n if (Button = mbLeft) and Enabled then\r\n FDragging := True;\r\nend;\r\n\r\nprocedure TJvCustomLabel.MouseUp(Button: TMouseButton; Shift: TShiftState;\r\n X, Y: Integer);\r\nbegin\r\n inherited MouseUp(Button, Shift, X, Y);\r\n if FDragging and (Button = mbLeft) then\r\n FDragging := False;\r\n UpdateTracking;\r\nend;\r\n\r\nprocedure TJvCustomLabel.UpdateTracking;\r\nvar\r\n OldValue, OtherDragging: Boolean;\r\nbegin\r\n OldValue := MouseOver;\r\n OtherDragging := KeyPressed(VK_LBUTTON) or Mouse.IsDragging;\r\n\r\n MouseOver := Enabled and not OtherDragging and\r\n (FindDragTarget(Mouse.CursorPos, True) = Self) and IsForegroundTask;\r\n if MouseOver <> OldValue then\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvCustomLabel.FocusChanged(AControl: TWinControl);\r\nvar\r\n Active: Boolean;\r\nbegin\r\n Active := Assigned(FFocusControl) and (AControl = FFocusControl);\r\n if FFocused <> Active then\r\n begin\r\n FFocused := Active;\r\n if FShowFocus then\r\n Invalidate;\r\n end;\r\n inherited FocusChanged(AControl);\r\nend;\r\n\r\nprocedure TJvCustomLabel.TextChanged;\r\nbegin\r\n inherited TextChanged;\r\n NonProviderChange;\r\n Invalidate;\r\n FNeedsResize := True;\r\n AdjustBounds;\r\nend;\r\n\r\nprocedure TJvCustomLabel.FontChanged;\r\nbegin\r\n inherited FontChanged;\r\n FNeedsResize := True;\r\n AdjustBounds;\r\n UpdateTrackFont(HotTrackFont, Font, FHotTrackFontOptions);\r\nend;\r\n\r\nfunction TJvCustomLabel.WantKey(Key: Integer; Shift: TShiftState): Boolean;\r\nbegin\r\n Result := (FFocusControl <> nil) and Enabled and ShowAccelChar and\r\n IsAccel(Key, GetLabelCaption) and (ssAlt in Shift);\r\n if Result then\r\n if FFocusControl.CanFocus then\r\n FFocusControl.SetFocus;\r\nend;\r\n\r\nprocedure TJvCustomLabel.EnabledChanged;\r\nbegin\r\n inherited EnabledChanged;\r\n UpdateTracking;\r\nend;\r\n\r\nprocedure TJvCustomLabel.MouseEnter(Control: TControl);\r\nvar\r\n NeedRepaint: Boolean;\r\n OtherDragging:Boolean;\r\nbegin\r\n if csDesigning in ComponentState then\r\n Exit;\r\n\r\n if not MouseOver and Enabled and IsForegroundTask then\r\n begin\r\n OtherDragging := KeyPressed(VK_LBUTTON) or Mouse.IsDragging;\r\n NeedRepaint := not Transparent and\r\n (\r\n {$IFDEF JVCLThemesEnabled}\r\n ThemeServices.Enabled or\r\n {$ENDIF JVCLThemesEnabled}\r\n (FHotTrack and not (FDragging or OtherDragging)));\r\n\r\n UpdateTracking; // set MouseOver\r\n\r\n inherited MouseEnter(Control);\r\n\r\n if NeedRepaint then\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomLabel.MouseLeave(Control: TControl);\r\nvar\r\n NeedRepaint: Boolean;\r\n OtherDragging: Boolean;\r\nbegin\r\n if csDesigning in ComponentState then\r\n Exit;\r\n if MouseOver and Enabled then\r\n begin\r\n OtherDragging := KeyPressed(VK_LBUTTON) or Mouse.IsDragging;\r\n\r\n NeedRepaint := not Transparent and\r\n (\r\n {$IFDEF JVCLThemesEnabled}\r\n ThemeServices.Enabled or\r\n {$ENDIF JVCLThemesEnabled}\r\n (FHotTrack and (FDragging or not OtherDragging)));\r\n\r\n UpdateTracking; // set MouseOver\r\n\r\n inherited MouseLeave(Control);\r\n\r\n if NeedRepaint then\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomLabel.SetImageIndex(Value: TImageIndex);\r\nbegin\r\n if FImageIndex <> Value then\r\n begin\r\n if IsValidImage then\r\n NonProviderChange;\r\n FNeedsResize := True;\r\n FImageIndex := Value;\r\n AdjustBounds;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomLabel.SetImages(Value: TCustomImageList);\r\nbegin\r\n if FImages <> Value then\r\n begin\r\n NonProviderChange;\r\n ReplaceImageListReference(Self, Value, FImages, FChangeLink);\r\n if AutoSize then\r\n begin\r\n FNeedsResize := True;\r\n AdjustBounds;\r\n end\r\n else\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nfunction TJvCustomLabel.GetImageHeight: Integer;\r\nbegin\r\n Result := 0;\r\n if not ProviderActive and IsValidImage then\r\n Result := Images.Height;\r\nend;\r\n\r\nprocedure TJvCustomLabel.SetConsumerService(Value: TJvDataConsumer);\r\nbegin\r\nend;\r\n\r\nfunction TJvCustomLabel.ProviderActive: Boolean;\r\nbegin\r\n Result := (Provider <> nil) and (Provider.ProviderIntf <> nil);\r\nend;\r\n\r\nprocedure TJvCustomLabel.ConsumerServiceChanged(Sender: TJvDataConsumer;\r\n Reason: TJvDataConsumerChangeReason);\r\nbegin\r\n if ProviderActive or (Reason = ccrProviderSelect) then\r\n begin\r\n FNeedsResize := True;\r\n AdjustBounds;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomLabel.NonProviderChange;\r\nbegin\r\n { TODO 3 -oJVCL -cPROVIDER : Causes AV at designtime when trying to change Images property }\r\n if ProviderActive then\r\n Provider.Provider := nil;\r\nend;\r\n\r\nfunction TJvCustomLabel.GetImageWidth: Integer;\r\nbegin\r\n Result := 0;\r\n if not ProviderActive and IsValidImage then\r\n Result := Images.Width;\r\nend;\r\n\r\nprocedure TJvCustomLabel.SetHotTrackFont(Value: TFont);\r\nbegin\r\n FHotTrackFont.Assign(Value);\r\nend;\r\n\r\nprocedure TJvCustomLabel.Click;\r\nvar\r\n HasBeenHandled: Boolean;\r\n TmpItem: IJvDataItem;\r\n ItemHandler: IJvDataItemBasicAction;\r\nbegin\r\n HasBeenHandled := False;\r\n if ProviderActive then\r\n begin\r\n Provider.Enter;\r\n try\r\n TmpItem := (Provider as IJvDataConsumerItemSelect).GetItem;\r\n if (TmpItem <> nil) and Supports(TmpItem, IJvDataItemBasicAction, ItemHandler) then\r\n HasBeenHandled := ItemHandler.Execute(Self);\r\n finally\r\n Provider.Leave;\r\n end;\r\n end;\r\n if not HasBeenHandled then\r\n begin\r\n inherited Click;\r\n if AutoOpenURL and (URL <> '') then\r\n OpenObject(URL);\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomLabel.SetAngle(Value: TJvLabelRotateAngle);\r\nbegin\r\n if FAngle <> Value then\r\n begin\r\n FAngle := Value;\r\n if FAngle < 0 then\r\n Inc(FAngle, 360);\r\n FNeedsResize := AutoSize;\r\n AdjustBounds;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomLabel.DoImagesChange(Sender: TObject);\r\nbegin\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvCustomLabel.SetSpacing(Value: Integer);\r\nbegin\r\n if FSpacing <> Value then\r\n begin\r\n FSpacing := Value;\r\n if AutoSize then\r\n begin\r\n FNeedsResize := True;\r\n AdjustBounds;\r\n end\r\n else\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomLabel.SetHotTrackFontOptions(Value: TJvTrackFontOptions);\r\nbegin\r\n if FHotTrackFontOptions <> Value then\r\n begin\r\n FHotTrackFontOptions := Value;\r\n UpdateTrackFont(HotTrackFont, Font, FHotTrackFontOptions);\r\n end;\r\nend;\r\n\r\nfunction TJvCustomLabel.GetHotTrack: Boolean;\r\nbegin\r\n Result := FHotTrack;\r\nend;\r\n\r\nfunction TJvCustomLabel.GetHotTrackFont: TFont;\r\nbegin\r\n Result := FHotTrackFont;\r\nend;\r\n\r\nfunction TJvCustomLabel.GetHotTrackFontOptions: TJvTrackFontOptions;\r\nbegin\r\n Result := FHotTrackFontOptions;\r\nend;\r\n\r\nfunction TJvCustomLabel.GetHotTrackOptions: TJvLabelHotTrackOptions;\r\nbegin\r\n Result := FHotTrackOptions;\r\nend;\r\n\r\nprocedure TJvCustomLabel.SetHotTrack(Value: Boolean);\r\nbegin\r\n FHotTrack := Value;\r\nend;\r\n\r\nprocedure TJvCustomLabel.SetHotTrackOptions(Value: TJvLabelHotTrackOptions);\r\nbegin\r\n if (FHotTrackOptions <> Value) and (Value <> nil) then\r\n FHotTrackOptions.Assign(Value);\r\nend;\r\n\r\nprocedure TJvCustomLabel.IJvHotTrack_Assign(\r\n Source: IJvHotTrack);\r\nbegin\r\n if (Source <> nil) and (IJvHotTrack(Self) <> Source) then\r\n begin\r\n HotTrack := Source.HotTrack;\r\n HotTrackFont :=Source.HotTrackFont;\r\n HotTrackFontOptions := Source.HotTrackFontOptions;\r\n HotTrackOptions := Source.HotTrackOptions;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomLabel.SetBounds(ALeft, ATop, AWidth, AHeight: Integer);\r\nbegin\r\n FNeedsResize := (ALeft <> Left) or (ATop <> Top) or (AWidth <> Width) or (AHeight <> Height);\r\n inherited SetBounds(ALeft, ATop, AWidth, AHeight);\r\nend;\r\n\r\nprocedure TJvCustomLabel.SetTextEllipsis(Value: TJvTextEllipsis);\r\nbegin\r\n if Value <> FTextEllipsis then\r\n begin\r\n FTextEllipsis := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomLabel.SetFrameColor(const Value: TColor);\r\nbegin\r\n if FFrameColor <> Value then\r\n begin\r\n FFrameColor := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomLabel.SetRoundedFrame(const Value: Integer);\r\nbegin\r\n if FRoundedFrame <> Value then\r\n if (Value < Height div 2) and (Value >= 0) then\r\n begin\r\n FRoundedFrame := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure FrameRounded(Canvas: TCanvas; ARect: TRect; AColor: TColor; R: Integer);\r\nbegin\r\n // Draw Frame with round corners\r\n Canvas.Pen.Color := AColor;\r\n Dec(ARect.Right);\r\n Dec(ARect.Bottom);\r\n Canvas.Polygon(\r\n [Point(ARect.Left + R, ARect.Top ),\r\n Point(ARect.Right - R, ARect.Top ),\r\n Point(ARect.Right , ARect.Top + R),\r\n Point(ARect.Right , ARect.Bottom - R),\r\n Point(ARect.Right - R, ARect.Bottom ),\r\n Point(ARect.Left + R, ARect.Bottom ),\r\n Point(ARect.Left , ARect.Bottom - R),\r\n Point(ARect.Left , ARect.Top + R),\r\n Point(ARect.Left + R, ARect.Top )]);\r\n Inc(ARect.Right);\r\n Inc(ARect.Bottom);\r\nend;\r\n\r\nfunction TJvCustomLabel.IsValidImage: Boolean;\r\nbegin\r\n Result := (Images <> nil) and (ImageIndex >= 0);\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n\r\n" }, { "path": "External/Jedi/Jvcl/run/JvLinkLabel.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvLinkLabel.pas, released 2002-01-06.\r\n\r\nThe Initial Developer of the Original Code is David Polberger \r\nPortions created by David Polberger are Copyright (C) 2002 David Polberger.\r\nAll Rights Reserved.\r\n\r\nContributor(s): Bianconi, Cetkovsky\r\n\r\nCurrent Version: 2.00\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n Please see the accompanying documentation.\r\nDescription:\r\n LinkLabel.pas contains the main component, TJvLinkLabel, a rich-text label.\r\n It makes use of the renderer and parser stored in Renderer.pas and Parser.pas,\r\n respectively.\r\n\r\n Note: Documentation for this unit can be found in Doc\\Source.txt and\r\n Doc\\Readme.txt!\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvLinkLabel.pas 13138 2011-10-26 23:17:50Z jfudickar $\r\n\r\nunit JvLinkLabel;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n SysUtils, Classes,\r\n Messages,\r\n Windows, Graphics, Controls, Forms, StdCtrls,\r\n JvLinkLabelParser, JvLinkLabelRenderer, JvLinkLabelTree,\r\n JvTypes, JvComponent;\r\n\r\ntype\r\n ELinkLabelError = class(EJVCLException);\r\n\r\n TLinkClickEvent = procedure(Sender: TObject; LinkNumber: Integer;\r\n LinkText, LinkParam: string) of object; // added LinkParam by Cetkovsky\r\n TDynamicTagInitEvent = procedure(Sender: TObject; out Source: string;\r\n Number: Integer) of object;\r\n\r\n TJvCustomLinkLabel = class(TJvGraphicControl, IDynamicNodeHandler)\r\n private\r\n FText: TStringList;\r\n FRenderer: IRenderer;\r\n FActiveLinkNode: TLinkNode;\r\n FHotLinks: Boolean;\r\n FLinkCursor: TCursor;\r\n FAutoHeight: Boolean;\r\n FMarginWidth: Integer;\r\n FMarginHeight: Integer;\r\n FOriginalCursor: TCursor;\r\n FOnCaptionChanged: TNotifyEvent;\r\n FOnLinkClick: TLinkClickEvent;\r\n FOnDynamicTagInit: TDynamicTagInitEvent;\r\n FParser: IParser;\r\n FLayout: TTextLayout;\r\n FCaption: TCaption;\r\n procedure SetText(const Value: TCaption);\r\n procedure SetTransparent(const Value: Boolean);\r\n function GetLinkColor: TColor;\r\n function GetLinkStyle: TFontStyles;\r\n procedure SetLinkColor(const Value: TColor);\r\n procedure SetLinkStyle(const Value: TFontStyles);\r\n procedure SynchronizeRootAndFont;\r\n function GetLinkColorClicked: TColor;\r\n procedure SetLinkColorClicked(const Value: TColor);\r\n function GetLinkColorHot: TColor;\r\n procedure SetLinkColorHot(const Value: TColor);\r\n procedure ActivateLinkNodeAtPos(const P: TPoint; State: TLinkState);\r\n procedure DeactivateActiveLinkNode;\r\n procedure HandleDynamicNode(out Source: string; const Node: TDynamicNode);\r\n function GetTransparent: Boolean;\r\n function IsActiveLinkNodeClicked: Boolean;\r\n procedure SetAutoHeight(const Value: Boolean);\r\n procedure SetMarginHeight(const Value: Integer);\r\n procedure SetMarginWidth(const Value: Integer);\r\n function GetStrings: TStrings;\r\n procedure SetStrings(const Value: TStrings);\r\n procedure SetLayout(AValue: TTextLayout);\r\n protected\r\n FNodeTree: TNodeTree;\r\n procedure TextChanged; override;\r\n procedure FontChanged; override;\r\n procedure Paint; override;\r\n procedure DrawBackground(NodeAtPoint: TLinkNode);\r\n function CreateParser: IParser; virtual;\r\n function CreateRenderer: IRenderer; virtual;\r\n procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;\r\n procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;\r\n procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;\r\n procedure MouseLeave(Control: TControl); override;\r\n procedure DoCaptionChanged; virtual;\r\n procedure DoLinkClicked(LinkNumber: Integer; LinkText, LinkParam: string); virtual; // added LinkParam by Cetkovsky\r\n procedure DoDynamicTagInit(out Source: string; Number: Integer); virtual;\r\n property Parser: IParser read FParser;\r\n property Renderer: IRenderer read FRenderer;\r\n property Caption: TCaption read FCaption write SetText;\r\n property Text: TStrings read GetStrings write SetStrings;\r\n property Transparent: Boolean read GetTransparent write SetTransparent default False;\r\n property Layout: TTextLayout read FLayout write SetLayout default tlTop;\r\n property LinkColor: TColor read GetLinkColor write SetLinkColor default clBlue;\r\n property LinkColorClicked: TColor read GetLinkColorClicked write SetLinkColorClicked default clRed;\r\n property LinkColorHot: TColor read GetLinkColorHot write SetLinkColorHot default clPurple;\r\n property LinkCursor: TCursor read FLinkCursor write FLinkCursor default crHandPoint;\r\n property LinkStyle: TFontStyles read GetLinkStyle write SetLinkStyle default [fsUnderline];\r\n property HotLinks: Boolean read FHotLinks write FHotLinks default False;\r\n property AutoHeight: Boolean read FAutoHeight write SetAutoHeight default True;\r\n property MarginWidth: Integer read FMarginWidth write SetMarginWidth default 0;\r\n property MarginHeight: Integer read FMarginHeight write SetMarginHeight default 0;\r\n property OnDynamicTagInit: TDynamicTagInitEvent read FOnDynamicTagInit write FOnDynamicTagInit;\r\n property OnCaptionChanged: TNotifyEvent read FOnCaptionChanged write FOnCaptionChanged;\r\n property OnLinkClick: TLinkClickEvent read FOnLinkClick write FOnLinkClick;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n procedure Loaded; override;\r\n procedure UpdateDynamicTag(Number: Integer; const Source: string);\r\n function GetDynamicTagContents(Number: Integer): string;\r\n end;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvLinkLabel = class(TJvCustomLinkLabel)\r\n published\r\n property Caption;\r\n property Text;\r\n property Anchors;\r\n property Transparent;\r\n property Layout;\r\n property LinkColor;\r\n property LinkColorClicked;\r\n property LinkColorHot;\r\n property LinkCursor;\r\n property LinkStyle;\r\n property HotLinks;\r\n property AutoHeight;\r\n property MarginWidth;\r\n property MarginHeight;\r\n\r\n property OnDynamicTagInit;\r\n property OnCaptionChanged;\r\n property OnLinkClick;\r\n\r\n property Enabled; // Cetkovsky\r\n\r\n property Align;\r\n property Color;\r\n property Constraints;\r\n property DragCursor;\r\n property DragMode;\r\n property Font;\r\n property Height default 17;\r\n property ParentColor;\r\n property ParentFont;\r\n property ParentShowHint;\r\n property PopupMenu;\r\n property ShowHint;\r\n property Visible;\r\n property Width default 160;\r\n property OnClick;\r\n property OnDblClick;\r\n property OnDragDrop;\r\n property OnDragOver;\r\n property OnStartDrag;\r\n property OnEndDrag;\r\n property OnMouseUp;\r\n property OnMouseDown;\r\n property OnMouseMove;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvLinkLabel.pas $';\r\n Revision: '$Revision: 13138 $';\r\n Date: '$Date: 2011-10-27 01:17:50 +0200 (jeu. 27 oct. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n JvThemes, JvResources;\r\n\r\nconst\r\n crNewLinkHand = 1;\r\n\r\nconstructor TJvCustomLinkLabel.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FLinkCursor := crHandPoint;\r\n FText := TStringList.Create;\r\n ControlStyle := ControlStyle + [csOpaque, csReplicatable];\r\n IncludeThemeStyle(Self, [csParentBackground]);\r\n Width := 160;\r\n Height := 17;\r\n FNodeTree := TNodeTree.Create;\r\n FAutoHeight := True;\r\n\r\n // Give descendant components an opportunity to replace the default classes\r\n FParser := CreateParser;\r\n FParser.SetDynamicNodeHandler(Self);\r\n FRenderer := CreateRenderer;\r\n\r\n FLayout := tlTop;\r\n\r\n SetLinkColor(clBlue);\r\n SetLinkColorClicked(clRed);\r\n SetLinkColorHot(clPurple);\r\n SetLinkStyle([fsUnderline]);\r\nend;\r\n\r\ndestructor TJvCustomLinkLabel.Destroy;\r\nbegin\r\n FNodeTree.Free;\r\n FText.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvCustomLinkLabel.ActivateLinkNodeAtPos(const P: TPoint; State: TLinkState);\r\nvar\r\n NodeAtPoint: TLinkNode;\r\n Pt: TPoint;\r\n TmpRect: TRect;\r\n\r\n function IsNewNode: Boolean;\r\n begin\r\n { We must only redraw the TLinkNode if it either isn't the same as the\r\n currently active TLinkNode (FActiveLinkNode), or if we're trying to change\r\n the state (that is, alter the color). }\r\n Result := (FActiveLinkNode <> NodeAtPoint);\r\n if not Result and Assigned(FActiveLinkNode) then\r\n Result := FActiveLinkNode.State <> State;\r\n end;\r\n\r\nbegin\r\n // Changes Control's canvas point to relative coordinates\r\n Pt := Point(P.X - FNodeTree.Root.StartingPoint.X,P.Y - FNodeTree.Root.StartingPoint.Y);\r\n\r\n if FNodeTree.IsPointInNodeClass(Pt, TLinkNode) then\r\n begin\r\n NodeAtPoint := FNodeTree.GetNodeAtPointOfClass(Pt, TLinkNode) as TLinkNode;\r\n if Assigned(NodeAtPoint) and IsNewNode then\r\n begin\r\n DeactivateActiveLinkNode;\r\n NodeAtPoint.State := State;\r\n FActiveLinkNode := NodeAtPoint;\r\n TmpRect := ClientRect;\r\n InflateRect(TmpRect, -FMarginWidth, -FMarginHeight);\r\n Canvas.Lock;\r\n try\r\n DrawBackground(NodeAtPoint);\r\n FRenderer.RenderNode(Canvas, TmpRect, NodeAtPoint);\r\n finally\r\n Canvas.Unlock;\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomLinkLabel.DeactivateActiveLinkNode;\r\nvar\r\n TmpRect: TRect;\r\nbegin\r\n if Assigned(FActiveLinkNode) then\r\n try\r\n FActiveLinkNode.State := lsNormal;\r\n TmpRect := ClientRect;\r\n InflateRect(TmpRect, -FMarginWidth, -FMarginHeight);\r\n Canvas.Lock;\r\n try\r\n DrawBackground(FActiveLinkNode);\r\n FRenderer.RenderNode(Canvas, TmpRect, FActiveLinkNode);\r\n finally\r\n Canvas.Unlock;\r\n end;\r\n finally\r\n FActiveLinkNode := nil;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomLinkLabel.FontChanged;\r\n\r\n procedure ClearWordInfo;\r\n var\r\n Enum: INodeEnumerator;\r\n begin\r\n Enum := FNodeTree.GetTopLevelNodeEnumerator(TStringNode);\r\n while Enum.HasNext do\r\n (Enum.GetNext as TStringNode).ClearWordInfo;\r\n end;\r\n\r\nbegin\r\n inherited FontChanged;\r\n SynchronizeRootAndFont;\r\n ClearWordInfo;\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvCustomLinkLabel.MouseLeave(Control: TControl);\r\nbegin\r\n if csDesigning in ComponentState then\r\n Exit;\r\n inherited MouseLeave(Control);;\r\n if FHotLinks and not IsActiveLinkNodeClicked then\r\n DeactivateActiveLinkNode;\r\nend;\r\n\r\nprocedure TJvCustomLinkLabel.TextChanged;\r\nbegin\r\n inherited TextChanged;\r\n Invalidate;\r\nend;\r\n\r\nfunction TJvCustomLinkLabel.CreateParser: IParser;\r\nbegin\r\n { Descendant components wishing to use another parser (implementing the\r\n IParser interface) should override this routine and provide their own. A\r\n pointer to this object should be returned.\r\n\r\n function TMyLinkLabel.CreateParser: IParser;\r\n begin\r\n Result := TMyParser.Create;\r\n end; }\r\n Result := TDefaultParser.Create;\r\nend;\r\n\r\nfunction TJvCustomLinkLabel.CreateRenderer: IRenderer;\r\nbegin\r\n // Please refer to the comment in TJvCustomLinkLabel.CreateParser above.\r\n Result := TDefaultRenderer.Create;\r\nend;\r\n\r\nprocedure TJvCustomLinkLabel.DoCaptionChanged;\r\nbegin\r\n if Assigned(FOnCaptionChanged) then\r\n FOnCaptionChanged(Self);\r\nend;\r\n\r\nprocedure TJvCustomLinkLabel.DoDynamicTagInit(out Source: string; Number: Integer);\r\nbegin\r\n if Assigned(FOnDynamicTagInit) then\r\n FOnDynamicTagInit(Self, Source, Number);\r\nend;\r\n\r\n // added LinkParam by Cetkovsky\r\nprocedure TJvCustomLinkLabel.DoLinkClicked(LinkNumber: Integer; LinkText, LinkParam: string);\r\nbegin\r\n if Assigned(FOnLinkClick) then\r\n FOnLinkClick(Self, LinkNumber, LinkText, LinkParam);\r\nend;\r\n\r\nprocedure TJvCustomLinkLabel.DrawBackground(NodeAtPoint: TLinkNode);\r\nvar\r\n TmpR: TRect;\r\n Enum: IRectEnumerator;\r\nbegin\r\n if (NodeAtPoint <> nil) and (Parent <> nil) and Parent.HandleAllocated then\r\n begin\r\n Enum := NodeAtPoint.GetRectEnumerator;\r\n if Enum.HasNext then\r\n begin\r\n TmpR := Enum.GetNext;\r\n while Enum.HasNext do\r\n UnionRect(TmpR, TmpR, Enum.GetNext);\r\n end;\r\n\r\n if Transparent then\r\n begin\r\n OffsetRect(TmpR, Left, Top);\r\n PerformEraseBackground(Self, Canvas.Handle, Point(0, 0), TmpR);\r\n end\r\n else\r\n begin\r\n Canvas.Brush.Color := Color;\r\n Canvas.FillRect(TmpR);\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJvCustomLinkLabel.GetDynamicTagContents(Number: Integer): string;\r\nvar\r\n Node: TAreaNode;\r\nbegin\r\n { Note that the output of this method is not serialized, that is, it will be\r\n plain text, with no tags present. In other words, simply the contents of\r\n the TStringNodes owned by the sought TDynamicNode. }\r\n Node := FNodeTree.GetSpecificNodeOfClass(Number, TDynamicNode) as TAreaNode;\r\n if Assigned(Node) then\r\n Result := Node.Text\r\n else\r\n raise ELinkLabelError.CreateRes(@RsEUnableToLocateMode);\r\nend;\r\n\r\nfunction TJvCustomLinkLabel.GetLinkColor: TColor;\r\nbegin\r\n Result := FRenderer.LinkColor;\r\nend;\r\n\r\nfunction TJvCustomLinkLabel.GetLinkColorClicked: TColor;\r\nbegin\r\n Result := FRenderer.LinkColorClicked;\r\nend;\r\n\r\nfunction TJvCustomLinkLabel.GetLinkColorHot: TColor;\r\nbegin\r\n Result := FRenderer.LinkColorHot;\r\nend;\r\n\r\nfunction TJvCustomLinkLabel.GetLinkStyle: TFontStyles;\r\nbegin\r\n Result := FRenderer.LinkStyle;\r\nend;\r\n\r\nfunction TJvCustomLinkLabel.GetTransparent: Boolean;\r\nbegin\r\n Result := not (csOpaque in ControlStyle);\r\nend;\r\n\r\nprocedure TJvCustomLinkLabel.HandleDynamicNode(out Source: string; const Node: TDynamicNode);\r\nbegin\r\n if Assigned(Node) then\r\n DoDynamicTagInit(Source, Node.Number);\r\nend;\r\n\r\nfunction TJvCustomLinkLabel.IsActiveLinkNodeClicked: Boolean;\r\nbegin\r\n Result := Assigned(FActiveLinkNode);\r\n if Result then\r\n Result := FActiveLinkNode.State = lsClicked;\r\nend;\r\n\r\nprocedure TJvCustomLinkLabel.Loaded;\r\nbegin\r\n inherited Loaded;\r\n FOriginalCursor := Cursor;\r\nend;\r\n\r\nprocedure TJvCustomLinkLabel.MouseDown(Button: TMouseButton; Shift: TShiftState;\r\n X, Y: Integer);\r\nbegin\r\n inherited MouseDown(Button, Shift, X, Y);\r\n ActivateLinkNodeAtPos(Point(X, Y), lsClicked);\r\nend;\r\n\r\nprocedure TJvCustomLinkLabel.MouseMove(Shift: TShiftState; X, Y: Integer);\r\nvar\r\n Pt: TPoint;\r\nbegin\r\n inherited MouseMove(Shift, X, Y);\r\n\r\n Pt := Point(X - FNodeTree.Root.StartingPoint.X,Y - FNodeTree.Root.StartingPoint.Y);\r\n if FNodeTree.IsPointInNodeClass(Pt, TLinkNode) then\r\n begin\r\n Cursor := LinkCursor;\r\n if FHotLinks and not IsActiveLinkNodeClicked then\r\n ActivateLinkNodeAtPos(Point(X, Y), lsHot);\r\n end\r\n else\r\n begin\r\n Cursor := FOriginalCursor;\r\n if FHotLinks and not IsActiveLinkNodeClicked then\r\n DeactivateActiveLinkNode;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomLinkLabel.MouseUp(Button: TMouseButton; Shift: TShiftState;\r\n X, Y: Integer);\r\nvar\r\n NodeAtPoint: TLinkNode;\r\n Pt: TPoint;\r\nbegin\r\n inherited MouseUp(Button, Shift, X, Y);\r\n\r\n Pt := Point(X - FNodeTree.Root.StartingPoint.X,Y - FNodeTree.Root.StartingPoint.Y);\r\n if FNodeTree.IsPointInNodeClass(Pt, TLinkNode) then\r\n begin\r\n NodeAtPoint := FNodeTree.GetNodeAtPointOfClass(Pt, TLinkNode) as TLinkNode;\r\n if Assigned(NodeAtPoint) then\r\n DoLinkClicked(NodeAtPoint.Number, NodeAtPoint.Text, NodeAtPoint.Param); // added LinkParam by Cetkovsky\r\n end;\r\n\r\n DeactivateActiveLinkNode;\r\nend;\r\n\r\nprocedure TJvCustomLinkLabel.Paint;\r\nvar\r\n TmpBmp: TBitmap;\r\n TmpRect: TRect;\r\nbegin\r\n TmpBmp := nil;\r\n if Assigned(FNodeTree) then\r\n begin\r\n if not Transparent then\r\n begin\r\n // repaint canvas\r\n DrawThemedBackground(Self, Canvas, ClientRect);\r\n end;\r\n\r\n try\r\n Canvas.Font := Font;\r\n TmpBmp := TBitmap.Create;\r\n TmpRect := ClientRect;\r\n TmpBmp.Canvas.Brush.Color := Color;\r\n TmpBmp.Canvas.Brush.Style := bsSolid;\r\n TmpBmp.Height := TmpRect.Bottom - (FMarginHeight shl 1) + 1; // TmpRect.Top = 0, ignore it\r\n TmpBmp.Width := TmpRect.Right - (FMarginWidth shl 1) + 1; // TmpRect.left = 0, ignore it\r\n TmpBmp.Canvas.Font.Assign(Canvas.Font);\r\n TmpBmp.Canvas.Pen.Assign(Canvas.Pen);\r\n\r\n if Transparent then\r\n begin\r\n TmpBmp.Canvas.CopyRect(ClientRect, Canvas, ClientRect);\r\n TmpBmp.Canvas.Brush.Style := bsClear;\r\n end;\r\n Canvas.Brush.Style := bsClear;\r\n\r\n // Set new start point\r\n // The new start point is relative to temporary canvas, Left & Top Corner\r\n FNodeTree.Root.StartingPoint := Point(0,0);\r\n FRenderer.RenderTree(TmpBmp.Canvas, Rect(0,0,TmpBmp.Width - 1,TmpBmp.Height - 1), FNodeTree);\r\n\r\n // Set new height e don't draw in this pass.\r\n // Wait for next paint event.\r\n // Allow correctly layout position and improve some performance\r\n if FAutoHeight and\r\n (Align in [alNone, alTop, alBottom]) and\r\n (ClientHeight <> (FRenderer.GetTextHeight + (FMarginHeight shl 1)) ) then\r\n ClientHeight := FRenderer.GetTextHeight + (FMarginHeight shl 1)\r\n else\r\n begin\r\n TmpRect := ClientRect;\r\n InflateRect(TmpRect, -FMarginWidth, -FMarginHeight);\r\n\r\n case FLayout of\r\n tlTop:\r\n begin\r\n // Nothing to do\r\n end;\r\n tlCenter:\r\n begin\r\n TmpRect.Top := TmpRect.Top +\r\n (TmpRect.Bottom - TmpRect.Top - FRenderer.GetTextHeight) div 2;\r\n if TmpRect.Top < FMarginHeight then\r\n TmpRect.Top := FMarginHeight;\r\n end;\r\n tlBottom:\r\n begin\r\n TmpRect.Top := TmpRect.Bottom - FRenderer.GetTextHeight;\r\n if TmpRect.Top < FMarginHeight then\r\n TmpRect.Top := FMarginHeight;\r\n end;\r\n end;\r\n // Adjust Root start point relative to control's canvas.\r\n FNodeTree.Root.StartingPoint := Point(TmpRect.Left, TmpRect.Top);\r\n Canvas.Draw(TmpRect.Left, TmpRect.Top, TmpBmp);\r\n end;\r\n finally\r\n TmpBmp.Free;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomLinkLabel.SetAutoHeight(const Value: Boolean);\r\nbegin\r\n if FAutoHeight <> Value then\r\n begin\r\n FAutoHeight := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomLinkLabel.SetText(const Value: TCaption);\r\nbegin\r\n if Value <> Caption then\r\n begin\r\n Text.Clear;\r\n FCaption := Value;\r\n Text.Add(Caption);\r\n FActiveLinkNode := nil; // We're about to free the tree containing the node it's pointing to\r\n FNodeTree.Free;\r\n ResetNodeCount;\r\n FNodeTree := FParser.Parse(Value);\r\n SynchronizeRootAndFont;\r\n Invalidate;\r\n DoCaptionChanged;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomLinkLabel.SetLinkColor(const Value: TColor);\r\nbegin\r\n if Value <> GetLinkColor then\r\n begin\r\n FRenderer.LinkColor := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomLinkLabel.SetLinkColorClicked(const Value: TColor);\r\nbegin\r\n if Value <> GetLinkColorClicked then\r\n FRenderer.LinkColorClicked := Value;\r\nend;\r\n\r\nprocedure TJvCustomLinkLabel.SetLinkColorHot(const Value: TColor);\r\nbegin\r\n FRenderer.LinkColorHot := Value;\r\nend;\r\n\r\nprocedure TJvCustomLinkLabel.SetLinkStyle(const Value: TFontStyles);\r\nbegin\r\n if Value <> GetLinkStyle then\r\n begin\r\n FRenderer.LinkStyle := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomLinkLabel.SetMarginHeight(const Value: Integer);\r\nbegin\r\n if FMarginHeight <> Value then\r\n begin\r\n FMarginHeight := Value;\r\n Resize;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomLinkLabel.SetMarginWidth(const Value: Integer);\r\nbegin\r\n if FMarginWidth <> Value then\r\n begin\r\n FMarginWidth := Value;\r\n Resize;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nfunction TJvCustomLinkLabel.GetStrings: TStrings;\r\nbegin\r\n Result := FText;\r\nend;\r\n\r\nprocedure TJvCustomLinkLabel.SetStrings(const Value: TStrings);\r\nbegin\r\n FText.Assign(Value); SetText(FText.Text);\r\nend;\r\n\r\nprocedure TJvCustomLinkLabel.SetLayout(AValue: TTextLayout);\r\nbegin\r\n if FLayout <> AValue then\r\n begin\r\n FLayout := AValue;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomLinkLabel.SetTransparent(const Value: Boolean);\r\nbegin\r\n if Transparent <> Value then\r\n begin\r\n if Value then\r\n begin\r\n ControlStyle := ControlStyle - [csOpaque];\r\n ExcludeThemeStyle(Self, [csParentBackground]);\r\n end\r\n else\r\n begin\r\n ControlStyle := ControlStyle + [csOpaque];\r\n IncludeThemeStyle(Self, [csParentBackground]);\r\n end;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomLinkLabel.SynchronizeRootAndFont;\r\nbegin\r\n if Assigned(FNodeTree) then\r\n with FNodeTree.Root do\r\n begin\r\n Styles := Font.Style;\r\n Color := Font.Color;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomLinkLabel.UpdateDynamicTag(Number: Integer; const Source: string);\r\nvar\r\n NodeEnum: INodeEnumerator;\r\n Parser: IParser;\r\n CurrentNode: TDynamicNode;\r\nbegin\r\n NodeEnum := FNodeTree.GetTopLevelNodeEnumerator(TDynamicNode);\r\n while NodeEnum.HasNext do\r\n begin\r\n CurrentNode := NodeEnum.GetNext as TDynamicNode;\r\n if CurrentNode.Number = Number then\r\n begin\r\n Parser := CreateParser;\r\n CurrentNode.DestroyChildren;\r\n Parser.AddSourceTreeToDynamicNode(CurrentNode, Source);\r\n Repaint;\r\n Exit;\r\n end;\r\n end;\r\n\r\n raise ELinkLabelError.CreateRes(@RsETagNotFound);\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvLinkLabelDebug.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: LinkDebug.pas, released 2002-01-06.\r\n\r\nThe Initial Developer of the Original Code is David Polberger \r\nPortions created by David Polberger are Copyright (C) 2002 David Polberger.\r\nAll Rights Reserved.\r\n\r\nContributor(s): ______________________________________.\r\n\r\nCurrent Version: 2.00\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nDescription:\r\n LinkDebug.pas provides utility routines designed to aid debugging.\r\nKnown Issues:\r\n Please see the accompanying documentation.\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvLinkLabelDebug.pas 12538 2009-10-03 12:18:34Z ahuser $\r\n\r\nunit JvLinkLabelDebug;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n TypInfo, SysUtils,\r\n ComCtrls, Graphics,\r\n JvLinkLabelTree, JvLinkLabelTools, JvLinkLabel;\r\n\r\ntype\r\n TDebugLinkLabelTools = class(TStaticObject)\r\n public\r\n class procedure NodeTreeToTreeNodes(const LinkLabel: TJvLinkLabel;\r\n const Tree: TTreeNodes);\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvLinkLabelDebug.pas $';\r\n Revision: '$Revision: 12538 $';\r\n Date: '$Date: 2009-10-03 14:18:34 +0200 (sam. 03 oct. 2009) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\n\r\ntype\r\n TJvLinkLabelAccessProtected = class(TJvLinkLabel);\r\n\r\nclass procedure TDebugLinkLabelTools.NodeTreeToTreeNodes(const LinkLabel: TJvLinkLabel;\r\n const Tree: TTreeNodes);\r\n\r\n function GetNodeDescription(const Node: TNode): string;\r\n begin\r\n Result := Node.ClassName;\r\n case Node.GetNodeType of\r\n ntStyleNode:\r\n Result := Result + ' (' +\r\n GetEnumName(TypeInfo(TFontStyle), Integer((Node as TStyleNode).Style)) + ')';\r\n ntLinkNode:\r\n Result := Result + ' (' +\r\n GetEnumName(TypeInfo(TLinkState), Integer((Node as TLinkNode).State)) + ')';\r\n ntStringNode:\r\n Result := Result + ' (\"' + (Node as TStringNode).Text + '\")';\r\n ntActionNode:\r\n Result := Result + ' (' +\r\n GetEnumName(TypeInfo(TActionType), Integer((Node as TActionNode).Action)) + ')';\r\n ntColorNode:\r\n Result := Result + ' ( ' + ColorToString(TColorNode(Node).Color) + ' )';\r\n ntUnknownNode:\r\n Result := Result + ' (\"' + (Node as TUnknownNode).Tag + '\")';\r\n end;\r\n\r\n if Node is TAreaNode then\r\n Result := Result + ' [X: ' + IntToStr(TAreaNode(Node).StartingPoint.X) +\r\n ', Y: ' + IntToStr(TAreaNode(Node).StartingPoint.Y) + ']';\r\n end;\r\n\r\n procedure Recurse(const Parent: TTreeNode; Node: TNode);\r\n var\r\n TreeParent: TTreeNode;\r\n I: Integer;\r\n begin\r\n TreeParent := Tree.AddChild(Parent, GetNodeDescription(Node));\r\n\r\n if Node is TParentNode then\r\n for I := 0 to TParentNode(Node).Children.Count - 1 do\r\n Recurse(TreeParent, TParentNode(Node).Children[I]);\r\n end;\r\n\r\nbegin\r\n if Assigned(TJvLinkLabelAccessProtected(LinkLabel).FNodeTree) and Assigned(Tree) then\r\n begin\r\n Tree.Clear;\r\n Recurse(nil, TJvLinkLabelAccessProtected(LinkLabel).FNodeTree.Root);\r\n end;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvLinkLabelParser.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: Parser.pas, released 2002-01-06.\r\n\r\nThe Initial Developer of the Original Code is David Polberger \r\nPortions created by David Polberger are Copyright (C) 2002 David Polberger.\r\nAll Rights Reserved.\r\n\r\nContributor(s): Cetkovsky\r\n\r\nCurrent Version: 2.00\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n Please see the accompanying documentation.\r\nDescription:\r\n Parser.pas provides both the IParser interface, as well as a class providing\r\n a default implementation. A class implementing IParser is supposed to parse\r\n a string, and return a tree representation represented by a TNodeTree.\r\n\r\n Note: Documentation for this unit can be found in Doc\\Source.txt and\r\n Doc\\Readme.txt!\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvLinkLabelParser.pas 12461 2009-08-14 17:21:33Z obones $\r\n\r\nunit JvLinkLabelParser;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Classes, SysUtils, Graphics,\r\n JvLinkLabelTree, JvLinkLabelTools;\r\n\r\ntype\r\n IDynamicNodeHandler = interface\r\n procedure HandleDynamicNode(out Source: string; const Node: TDynamicNode);\r\n end;\r\n\r\n IParser = interface\r\n function Parse(const Text: string): TNodeTree; overload;\r\n function Parse(const List: TStringList): TNodeTree; overload;\r\n procedure SetDynamicNodeHandler(Handler: IDynamicNodeHandler);\r\n procedure AddSourceTreeToDynamicNode(const Node: TDynamicNode;\r\n const Source: string);\r\n end;\r\n\r\n IElementEnumerator = interface;\r\n\r\n TDefaultParser = class(TInterfacedObject, IParser)\r\n private\r\n FEnum: IElementEnumerator;\r\n FDynamicNodeHandler: IDynamicNodeHandler;\r\n procedure ParseNode(const Node: TParentNode);\r\n protected\r\n function GetNodeFromTag(const Tag: string): TNode; virtual;\r\n procedure HandleDynamicTag(const Node: TDynamicNode);\r\n public\r\n procedure SetElementEnumerator(NewEnum: IElementEnumerator);\r\n function Parse(const Text: string): TNodeTree; overload;\r\n function Parse(const List: TStringList): TNodeTree; overload;\r\n procedure SetDynamicNodeHandler(Handler: IDynamicNodeHandler);\r\n procedure AddSourceTreeToDynamicNode(const Node: TDynamicNode;\r\n const Source: string);\r\n end;\r\n\r\n TElementKind = (ekBeginTag, ekEndTag, ekString);\r\n TElement = record\r\n Kind: TElementKind;\r\n Text: string;\r\n end;\r\n\r\n IElementEnumerator = interface\r\n function PopNextElement: TElement;\r\n function PeekNextElement: TElement;\r\n function IsEndReached: Boolean;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvLinkLabelParser.pas $';\r\n Revision: '$Revision: 12461 $';\r\n Date: '$Date: 2009-08-14 19:21:33 +0200 (ven. 14 août 2009) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n JvResources;\r\n\r\n//=== { TElementEnumerator } =================================================\r\n\r\ntype\r\n TElementEnumerator = class(TInterfacedObject, IElementEnumerator)\r\n private\r\n FText: string;\r\n FPosInText: Integer;\r\n FOldPosInText: Integer; // Used to see whether we should use our cached copy\r\n FCachedElement: TElement;\r\n FNewPosInText: Integer;\r\n function GetNextElement(const IncrementPos: Boolean): TElement;\r\n public\r\n constructor Create(const Text: string);\r\n function PopNextElement: TElement;\r\n function PeekNextElement: TElement;\r\n function IsEndReached: Boolean;\r\n end;\r\n\r\nconst\r\n OpenTag = '<';\r\n CloseTag = '>';\r\n EndMarker = '/';\r\n\r\nconstructor TElementEnumerator.Create(const Text: string);\r\nbegin\r\n inherited Create;\r\n FPosInText := 1;\r\n FOldPosInText := -1;\r\n FText := Text;\r\nend;\r\n\r\nfunction TElementEnumerator.GetNextElement(const IncrementPos: Boolean): TElement;\r\n\r\n function GetElementKind: TElementKind;\r\n var\r\n TempString: string;\r\n begin\r\n TempString := Copy(FText, FPosInText, 2);\r\n\r\n if Copy(TempString, 1, 2) = OpenTag + EndMarker then // \" CloseTag) do\r\n Inc(EndPos);\r\n Inc(EndPos);\r\n Padding := 1;\r\n end;\r\n\r\n begin\r\n StartPos := FPosInText;\r\n EndPos := FPosInText;\r\n Padding := 0;\r\n\r\n case Kind of\r\n ekBeginTag:\r\n FindNewTagPos(1);\r\n ekEndTag:\r\n FindNewTagPos(2);\r\n ekString:\r\n while (EndPos <= Length(FText)) and (FText[EndPos] <> OpenTag) do\r\n Inc(EndPos);\r\n end;\r\n\r\n Result := Copy(FText, StartPos, (EndPos - StartPos - Padding));\r\n FNewPosInText := EndPos;\r\n end;\r\n\r\nbegin\r\n if IsEndReached then\r\n raise EParserError.CreateRes(@RsENoMoreElementsToReturn);\r\n\r\n if FOldPosInText = FPosInText then // Use cached element\r\n Result := FCachedElement\r\n else\r\n begin\r\n FOldPosInText := FPosInText;\r\n\r\n Result.Kind := GetElementKind;\r\n Result.Text := GetElementText(Result.Kind);\r\n\r\n FCachedElement := Result;\r\n end;\r\n\r\n if IncrementPos then\r\n FPosInText := FNewPosInText;\r\nend;\r\n\r\nfunction TElementEnumerator.IsEndReached: Boolean;\r\nbegin\r\n Result := FPosInText > Length(FText);\r\nend;\r\n\r\nfunction TElementEnumerator.PeekNextElement: TElement;\r\nbegin\r\n Result := GetNextElement(False);\r\nend;\r\n\r\nfunction TElementEnumerator.PopNextElement: TElement;\r\nbegin\r\n Result := GetNextElement(True);\r\nend;\r\n\r\n//=== { TDefaultParser } =====================================================\r\n\r\nprocedure TDefaultParser.AddSourceTreeToDynamicNode(const Node: TDynamicNode;\r\n const Source: string);\r\nvar\r\n Parser: TDefaultParser;\r\n Tree: TNodeTree;\r\n I: Integer;\r\nbegin\r\n Tree := nil;\r\n try\r\n Parser := TDefaultParser.Create;\r\n try\r\n Tree := Parser.Parse(Source);\r\n finally\r\n Parser.Free;\r\n end;\r\n\r\n Tree.Root.OwnsChildren := False;\r\n for I := 0 to Tree.Root.Children.Count - 1 do\r\n Node.AddChild(Tree.Root.Children[I], Node.Root);\r\n finally\r\n Tree.Free;\r\n end;\r\nend;\r\n\r\nfunction TDefaultParser.GetNodeFromTag(const Tag: string): TNode;\r\ntype\r\n TTag = (ttBold, ttItalic, ttUnderline, ttColor,\r\n ttLink, ttLineBreak, ttParagraphBreak, ttDynamic);\r\nvar\r\n CurrentTag: TTag;\r\n UnknownTag: Boolean;\r\n\r\n //Cetkovsky -->\r\n function GetStringFromTag: string;\r\n begin\r\n if (Pos('=', Tag) > 0) then\r\n Result := Copy(Tag, Pos('=', Tag) + 1, Length(Tag))\r\n else\r\n Result := '';\r\n end;\r\n //<-- Cetkovsky\r\n\r\n // Bianconi\r\n function GetColorFromTag: TColor;\r\n var\r\n sVar: string;\r\n begin\r\n Result := clNone;\r\n //Cetkovsky -->\r\n sVar := GetStringFromTag;\r\n //<-- Cetkovsky\r\n try\r\n Result := StringToColor(sVar);\r\n except // Only to avoid raise an exception on invalid color\r\n end;\r\n end;\r\n // End of Bianconi\r\n\r\n function GetTagFromString: TTag;\r\n const\r\n TagStrings: array [TTag] of PChar =\r\n ('B',\r\n 'I',\r\n 'U',\r\n 'COLOR=', // Bianconi\r\n// 'LINK',\r\n //Cetkovsky -->\r\n 'LINK=',\r\n //<-- Cetkovsky\r\n 'BR',\r\n 'P',\r\n 'DYNAMIC');\r\n DontCare = 0;\r\n var\r\n S: string;\r\n begin\r\n UnknownTag := False;\r\n // Bianconi\r\n for Result := Low(TTag) to High(TTag) do\r\n begin\r\n S := TagStrings[Result];\r\n if (AnsiUpperCase(Tag) = S) or\r\n// (Copy(AnsiUpperCase(Tag), 1, Length(TagStrings[Result])) = 'COLOR=')\r\n //Cetkovsky -->\r\n //We allow style tag without \"=\"\r\n ((Pos('=', S) > 0) and\r\n ((Copy(AnsiUpperCase(Tag), 1, Length(S) - 1) = Copy(S, 1, Length(S) - 1)))) then\r\n //<-- Cetkovsky\r\n Exit;\r\n end;\r\n //End of Bianconi\r\n Result := TTag(DontCare);\r\n UnknownTag := True;\r\n end;\r\n\r\nbegin\r\n { Descendant parsers should override this routine, call inherited and add\r\n support for proprietary tags (using custom node objects, which descend from\r\n TNode). Note that appropriate modifications need to be made to the renderer\r\n as well, either by creating a new class which implements the IRenderer\r\n interface, or by extending the TDefaultRenderer class. See this class for\r\n more information. }\r\n CurrentTag := GetTagFromString;\r\n\r\n if not UnknownTag then\r\n case CurrentTag of\r\n ttBold:\r\n Result := TStyleNode.Create(fsBold);\r\n ttItalic:\r\n Result := TStyleNode.Create(fsItalic);\r\n ttUnderline:\r\n Result := TStyleNode.Create(fsUnderline);\r\n // Bianconi\r\n ttColor:\r\n Result := TColorNode.Create(GetColorFromTag);\r\n // End of Bianconi\r\n //Cetkovsky -->\r\n ttLink:\r\n Result := TLinkNode.Create(GetStringFromTag);\r\n //<-- Cetkovsky\r\n ttLineBreak:\r\n Result := TActionNode.Create(atLineBreak);\r\n ttParagraphBreak:\r\n Result := TActionNode.Create(atParagraphBreak);\r\n ttDynamic:\r\n Result := TDynamicNode.Create;\r\n else\r\n Result := TUnknownNode.Create(Tag);\r\n end\r\n else\r\n Result := TUnknownNode.Create(Tag);\r\n\r\nend;\r\n\r\nprocedure TDefaultParser.HandleDynamicTag(const Node: TDynamicNode);\r\nvar\r\n Source: string;\r\nbegin\r\n if Assigned(FDynamicNodeHandler) then\r\n begin\r\n FDynamicNodeHandler.HandleDynamicNode(Source, Node);\r\n if Source <> '' then\r\n AddSourceTreeToDynamicNode(Node, Source);\r\n end;\r\nend;\r\n\r\nfunction TDefaultParser.Parse(const List: TStringList): TNodeTree;\r\nbegin\r\n Result := Parse(List.Text);\r\nend;\r\n\r\nfunction TDefaultParser.Parse(const Text: string): TNodeTree;\r\nbegin\r\n Result := TNodeTree.Create;\r\n FEnum := TElementEnumerator.Create(TStringTools.RemoveCRLF(Text));\r\n try\r\n ParseNode(Result.Root);\r\n finally\r\n FEnum := nil;\r\n end;\r\nend;\r\n\r\nprocedure TDefaultParser.ParseNode(const Node: TParentNode);\r\nvar\r\n Element: TElement;\r\n NewNode: TNode;\r\n\r\n function EndReached: Boolean;\r\n begin\r\n Result := FEnum.IsEndReached or (FEnum.PeekNextElement.Kind = ekEndTag);\r\n end;\r\n\r\n function IsNodeContainer(const Node: TNode; const Element: TElement): Boolean;\r\n begin\r\n { Returns whether the given node is can contain other elements and thus\r\n descends from TParentNode. Descendants from this class begin with and\r\n end with (for example, and . Nodes that descend from\r\n TActionNode shouldn't be terminated with (for example,

). Note\r\n that TDynamicNode is special; while it descends from TParentNode, it never\r\n contains children at parse-time, thus we shouldn't wait for a redundant\r\n . Instead, its contents are supplied before it's rendered by\r\n compiled program code. }\r\n Result := (Element.Kind = ekBeginTag) and\r\n (Node is TParentNode) and not (Node is TDynamicNode);\r\n end;\r\n\r\nbegin\r\n while not EndReached do\r\n begin\r\n Element := FEnum.PopNextElement;\r\n\r\n case Element.Kind of\r\n ekString:\r\n NewNode := TStringNode.Create(Element.Text);\r\n ekBeginTag:\r\n NewNode := GetNodeFromTag(Element.Text);\r\n else\r\n raise EParserError.CreateRes(@RsEUnsupportedState);\r\n end;\r\n\r\n if (Node.GetNodeType = ntRootNode) then\r\n Node.AddChild(NewNode, TRootNode(Node))\r\n else\r\n Node.AddChild(NewNode, Node.Root);\r\n\r\n if NewNode is TDynamicNode then\r\n HandleDynamicTag(NewNode as TDynamicNode);\r\n\r\n if IsNodeContainer(NewNode, Element) then\r\n ParseNode(NewNode as TParentNode);\r\n end;\r\n\r\n { When we have reached the end of a tag ( for example) we don't enter\r\n the main body. We have called FEnum.PeekElement and have determined (in\r\n EndReached in this routine) that the next element to be returned by FEnum.\r\n PopElement will be an end-tag. Thus, we exit this routine and return either\r\n to another copy of ParseNode (if we've been called recursively) or to Parse.\r\n\r\n However, if we only check the next element to be returned using PeekElement,\r\n it won't be popped off our \"stack\", which is what we do here. If we hadn't\r\n popped it here, EndReached would've returned True in all other incarnations\r\n of this routine in the call stack; thus, one single end-tag would've caused\r\n the whole parse process to stop. This is obviously not what we want. }\r\n if not FEnum.IsEndReached then\r\n FEnum.PopNextElement;\r\nend;\r\n\r\nprocedure TDefaultParser.SetDynamicNodeHandler(\r\n Handler: IDynamicNodeHandler);\r\nbegin\r\n FDynamicNodeHandler := Handler;\r\nend;\r\n\r\nprocedure TDefaultParser.SetElementEnumerator(NewEnum: IElementEnumerator);\r\nbegin\r\n if Assigned(NewEnum) then\r\n FEnum := NewEnum;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvLinkLabelRenderer.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: Renderer.pas, released 2002-01-06.\r\n\r\nThe Initial Developer of the Original Code is David Polberger \r\nPortions created by David Polberger are Copyright (C) 2002 David Polberger.\r\nAll Rights Reserved.\r\n\r\nContributor(s): Cetkvosky, Bianconi\r\n\r\nCurrent Version: 2.00\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n Please see the accompanying documentation.\r\nDescription:\r\n Renderer.pas provides both the IRenderer interface, as well as a class\r\n providing a default implementation. A class implementing the IRenderer\r\n interface is supposed to render the output of the supplied TNodeTree to the\r\n screen.\r\n\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvLinkLabelRenderer.pas 12538 2009-10-03 12:18:34Z ahuser $\r\n\r\nunit JvLinkLabelRenderer;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Classes, SysUtils, Windows, Graphics,\r\n JvLinkLabelTree, JvLinkLabelTextHandler, JvTypes;\r\n\r\ntype\r\n ERendererError = class(EJVCLException);\r\n\r\n IRenderer = interface\r\n function GetLinkColor: TColor;\r\n procedure SetLinkColor(const Value: TColor);\r\n function GetLinkColorClicked: TColor;\r\n procedure SetLinkColorClicked(const Value: TColor);\r\n function GetLinkColorHot: TColor;\r\n procedure SetLinkColorHot(const Value: TColor);\r\n function GetLinkStyle: TFontStyles;\r\n procedure SetLinkStyle(const Value: TFontStyles);\r\n\r\n procedure RenderTree(const Canvas: TCanvas; Rect: TRect; const Tree: TNodeTree);\r\n procedure RenderNode(const Canvas: TCanvas; Rect: TRect; const Node: TAreaNode);\r\n function GetTextHeight: Integer;\r\n property LinkColor: TColor read GetLinkColor write SetLinkColor;\r\n property LinkColorClicked: TColor read GetLinkColorClicked write SetLinkColorClicked;\r\n property LinkColorHot: TColor read GetLinkColorHot write SetLinkColorHot;\r\n property LinkStyle: TFontStyles read GetLinkStyle write SetLinkStyle;\r\n end;\r\n\r\n TDefaultRenderer = class(TInterfacedObject, IRenderer, IStartingPosObserver)\r\n private\r\n FLinkColor: TColor;\r\n FLinkColorClicked: TColor;\r\n FLinkColorHot: TColor;\r\n FLinkStyle: TFontStyles;\r\n FTextHandler: ITextHandler;\r\n FTextHeight: Integer;\r\n function GetLinkColor: TColor;\r\n procedure SetLinkColor(const Value: TColor);\r\n function GetLinkColorClicked: TColor;\r\n procedure SetLinkColorClicked(const Value: TColor);\r\n function GetLinkColorHot: TColor;\r\n procedure SetLinkColorHot(const Value: TColor);\r\n function GetLinkStyle: TFontStyles;\r\n procedure SetLinkStyle(const Value: TFontStyles);\r\n protected\r\n procedure DoRenderNode(const Node: TAreaNode; Styles: TFontStyles;\r\n Color: TColor); virtual;\r\n procedure StartingPosUpdated(PosX, PosY: Integer; const Node: TAreaNode);\r\n function TranslateColor(const Color: TColor): TColor; virtual;\r\n public\r\n procedure RenderTree(const Canvas: TCanvas; Rect: TRect; const Tree: TNodeTree);\r\n procedure RenderNode(const Canvas: TCanvas; Rect: TRect;\r\n const Node: TAreaNode);\r\n function GetTextHeight: Integer;\r\n property LinkColor: TColor read GetLinkColor write SetLinkColor;\r\n property LinkColorClicked: TColor read GetLinkColorClicked write SetLinkColorClicked;\r\n property LinkColorHot: TColor read GetLinkColorHot write SetLinkColorHot;\r\n property LinkStyle: TFontStyles read GetLinkStyle write SetLinkStyle;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvLinkLabelRenderer.pas $';\r\n Revision: '$Revision: 12538 $';\r\n Date: '$Date: 2009-10-03 14:18:34 +0200 (sam. 03 oct. 2009) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\n\r\nprocedure TDefaultRenderer.DoRenderNode(const Node: TAreaNode;\r\n Styles: TFontStyles; Color: TColor);\r\nvar\r\n I: Integer;\r\n ChildNode: TNode;\r\n NewStyles: TFontStyles;\r\n NewColor: TColor;\r\nbegin\r\n if FTextHandler.IsPosCurrent then\r\n Node.StartingPoint := Point(FTextHandler.GetPosX, FTextHandler.GetPosY)\r\n else\r\n FTextHandler.AddStartingPosObserver(Self, Node);\r\n\r\n Node.Styles := Styles;\r\n Node.Color := TranslateColor(Color);\r\n\r\n for I := 0 to Node.Children.Count - 1 do\r\n begin\r\n ChildNode := Node.Children[I];\r\n NewColor := TranslateColor(Color);\r\n NewStyles := Styles;\r\n\r\n case ChildNode.GetNodeType of\r\n ntStringNode:\r\n FTextHandler.TextOut(ChildNode as TStringNode, NewStyles, NewColor);\r\n ntActionNode:\r\n case (ChildNode as TActionNode).Action of\r\n atLineBreak:\r\n FTextHandler.DoLineBreak;\r\n atParagraphBreak:\r\n FTextHandler.DoParagraphBreak;\r\n end;\r\n ntStyleNode:\r\n NewStyles := Styles + [(ChildNode as TStyleNode).Style];\r\n ntColorNode:\r\n NewColor := (ChildNode as TColorNode).Color;\r\n ntLinkNode:\r\n begin\r\n NewStyles := Styles + LinkStyle;\r\n NewColor := LinkColor;\r\n end;\r\n end;\r\n\r\n if ChildNode is TAreaNode then\r\n DoRenderNode(TAreaNode(ChildNode), NewStyles, NewColor);\r\n end;\r\nend;\r\n\r\nfunction TDefaultRenderer.GetLinkColorClicked: TColor;\r\nbegin\r\n Result := FLinkColorClicked;\r\nend;\r\n\r\nfunction TDefaultRenderer.GetLinkColor: TColor;\r\nbegin\r\n Result := FLinkColor;\r\nend;\r\n\r\nfunction TDefaultRenderer.GetLinkStyle: TFontStyles;\r\nbegin\r\n Result := FLinkStyle;\r\nend;\r\n\r\nprocedure TDefaultRenderer.RenderNode(const Canvas: TCanvas; Rect: TRect;\r\n const Node: TAreaNode);\r\nbegin\r\n FTextHandler := TTextHandler.Create(Rect,\r\n Node.StartingPoint.X, Node.StartingPoint.Y, Canvas);\r\n try\r\n DoRenderNode(Node, Node.Styles, Node.Color);\r\n FTextHandler.EmptyBuffer;\r\n FTextHeight := FTextHandler.GetTextHeight;\r\n finally\r\n FTextHandler := nil;\r\n end;\r\nend;\r\n\r\nprocedure TDefaultRenderer.RenderTree(const Canvas: TCanvas; Rect: TRect;\r\n const Tree: TNodeTree);\r\nbegin\r\n Tree.Root.StartingPoint := Point(Rect.Left, Rect.Top);\r\n RenderNode(Canvas, Rect, Tree.Root);\r\n Tree.Root.RetrieveRectsOfTLinkNodeChildren;\r\nend;\r\n\r\nprocedure TDefaultRenderer.SetLinkColorClicked(const Value: TColor);\r\nbegin\r\n FLinkColorClicked := Value;\r\nend;\r\n\r\nprocedure TDefaultRenderer.SetLinkColor(const Value: TColor);\r\nbegin\r\n FLinkColor := Value;\r\nend;\r\n\r\nprocedure TDefaultRenderer.SetLinkStyle(const Value: TFontStyles);\r\nbegin\r\n FLinkStyle := Value;\r\nend;\r\n\r\nfunction TDefaultRenderer.GetLinkColorHot: TColor;\r\nbegin\r\n Result := FLinkColorHot;\r\nend;\r\n\r\nprocedure TDefaultRenderer.SetLinkColorHot(const Value: TColor);\r\nbegin\r\n FLinkColorHot := Value;\r\nend;\r\n\r\nfunction TDefaultRenderer.TranslateColor(const Color: TColor): TColor;\r\nbegin\r\n case Color of\r\n clNormalLink:\r\n Result := FLinkColor;\r\n clClickedLink:\r\n Result := FLinkColorClicked;\r\n clHotLink:\r\n Result := FLinkColorHot;\r\n else\r\n Result := Color;\r\n end;\r\nend;\r\n\r\nprocedure TDefaultRenderer.StartingPosUpdated(PosX, PosY: Integer;\r\n const Node: TAreaNode);\r\nbegin\r\n Node.StartingPoint := Point(PosX, PosY);\r\nend;\r\n\r\nfunction TDefaultRenderer.GetTextHeight: Integer;\r\nbegin\r\n Result := FTextHeight;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvLinkLabelTextHandler.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: TextHandler.pas, released 2002-01-06.\r\n\r\nThe Initial Developer of the Original Code is David Polberger \r\nPortions created by David Polberger are Copyright (C) 2002 David Polberger.\r\nAll Rights Reserved.\r\n\r\nContributor(s): ______________________________________.\r\n\r\nCurrent Version: 2.00\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n Please see the accompanying documentation.\r\nDescription:\r\n This unit, and its supporting types and classes, exist for the sole purpose of\r\n supporting words broken into different nodes in the tree. These strings are\r\n rendered correctly, but they are unfortunattreated as different words when\r\n the time comes to do word-wrapping. This means that one substring of a word\r\n gets placed on one row, and the others on different rows. Consider this word:\r\n\r\n Test\r\n\r\n In this case, \"Te\" would be placed on the first row while \"st\" would be placed\r\n on the second row, if we were short on space. The first TJvLinkLabel engine\r\n did not support this at all, while the second engine supported it most of the\r\n time, although using a hack.\r\n\r\n One could argue that few would ever want to have something like the above\r\n rendered, but all current browsers support it, and it _is_ used on the\r\n Internet to achieve special formatting. The syntax clearly supports words\r\n with characters styled differently; if the engine didn't support this, it\r\n would be a technical shortcoming.\r\n\r\n Note: Documentation for this unit can be found in Doc\\Source.txt and\r\n Doc\\Readme.txt!\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvLinkLabelTextHandler.pas 12461 2009-08-14 17:21:33Z obones $\r\n\r\nunit JvLinkLabelTextHandler;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Classes, SysUtils,\r\n Graphics, Windows,\r\n JvLinkLabelTree, JvLinkLabelTools, JvTypes;\r\n\r\ntype\r\n ETextHandlerError = class(EJVCLException);\r\n\r\n IStartingPosObserver = interface\r\n procedure StartingPosUpdated(PosX, PosY: Integer; const Node: TAreaNode);\r\n end;\r\n\r\n ITextHandler = interface\r\n function GetPosX: Integer;\r\n function GetPosY: Integer;\r\n function GetLineHeight: Integer;\r\n function GetCanvas: TCanvas;\r\n\r\n procedure TextOut(Node: TStringNode; Style: TFontStyles; Color: TColor);\r\n procedure DoParagraphBreak;\r\n procedure DoLineBreak;\r\n procedure EmptyBuffer;\r\n function GetTextHeight: Integer;\r\n function IsPosCurrent: Boolean;\r\n procedure AddStartingPosObserver(Observer: IStartingPosObserver;\r\n Node: TAreaNode);\r\n\r\n property PosX: Integer read GetPosX;\r\n property PosY: Integer read GetPosY;\r\n property LineHeight: Integer read GetLineHeight;\r\n property Canvas: TCanvas read GetCanvas;\r\n end;\r\n\r\n TTextElementList = class;\r\n TNodeObserverList = class;\r\n TTextHandler = class(TInterfacedObject, ITextHandler)\r\n private\r\n FPosX: Integer;\r\n FPosY: Integer;\r\n FList: TTextElementList;\r\n FRect: TRect;\r\n FCanvas: TCanvas;\r\n FLineHeight: Integer;\r\n FObservers: TNodeObserverList;\r\n function GetPosX: Integer;\r\n function GetPosY: Integer;\r\n function GetLineHeight: Integer;\r\n function GetCanvas: TCanvas;\r\n public\r\n constructor Create(const Rect: TRect; InitialX, InitialY: Integer;\r\n const Canvas: TCanvas);\r\n destructor Destroy; override;\r\n procedure TextOut(Node: TStringNode; Style: TFontStyles; Color: TColor);\r\n procedure DoParagraphBreak;\r\n procedure DoLineBreak;\r\n procedure EmptyBuffer;\r\n function GetTextHeight: Integer;\r\n function IsPosCurrent: Boolean;\r\n procedure AddStartingPosObserver(Observer: IStartingPosObserver;\r\n Node: TAreaNode);\r\n end;\r\n\r\n TParentTextElement = class(TObject)\r\n end;\r\n\r\n TStringElement = class(TParentTextElement)\r\n private\r\n FNode: TStringNode;\r\n FStyle: TFontStyles;\r\n FColor: TColor;\r\n public\r\n constructor Create(const Node: TStringNode; Style: TFontStyles; Color: TColor);\r\n function BeginsWithSpace: Boolean;\r\n function EndsWithSpace: Boolean;\r\n property Node: TStringNode read FNode;\r\n property Style: TFontStyles read FStyle;\r\n property Color: TColor read FColor;\r\n end;\r\n\r\n TActionElement = class(TParentTextElement)\r\n private\r\n FActionType: TActionType;\r\n public\r\n constructor Create(ActionType: TActionType);\r\n property ActionType: TActionType read FActionType;\r\n end;\r\n\r\n TTextElementList = class(TObject)\r\n private\r\n FList: TList;\r\n function Get(Index: Integer): TParentTextElement;\r\n function GetCount: Integer;\r\n protected\r\n procedure Clear;\r\n public\r\n constructor Create;\r\n destructor Destroy; override;\r\n procedure AddStringElement(const Node: TStringNode; Style: TFontStyles; Color: TColor);\r\n procedure AddParagraphBreak;\r\n procedure AddLineBreak;\r\n property Items[Index: Integer]: TParentTextElement read Get; default;\r\n property Count: Integer read GetCount;\r\n end;\r\n\r\n PNodeObserver = ^TNodeObserver;\r\n TNodeObserver = record\r\n Observer: IStartingPosObserver;\r\n ParentNode: TAreaNode;\r\n FirstStringNode: TStringNode;\r\n end;\r\n\r\n TNodeObserverList = class(TOwnerPointerList)\r\n private\r\n function Get(Index: Integer): PNodeObserver;\r\n procedure Put(Index: Integer; const Value: PNodeObserver);\r\n public\r\n procedure AddObserver(Observer: IStartingPosObserver; ParentNode: TAreaNode;\r\n FirstStringNode: TStringNode);\r\n procedure RemoveObserver(Item: PNodeObserver);\r\n function IndexOfStringNode(Node: TStringNode): Integer;\r\n property Items[Index: Integer]: PNodeObserver read Get write Put; default;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvLinkLabelTextHandler.pas $';\r\n Revision: '$Revision: 12461 $';\r\n Date: '$Date: 2009-08-14 19:21:33 +0200 (ven. 14 août 2009) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n JvResources;\r\n\r\n//=== { TWordEnumerator } ====================================================\r\n\r\nconst\r\n Space = ' ';\r\n\r\ntype\r\n IWordEnumerator = interface\r\n procedure SetText(const Text: string);\r\n function GetText: string;\r\n function GetCount: Integer;\r\n\r\n function PopNext: string;\r\n function PeekNext: string;\r\n function HasNext: Boolean;\r\n procedure Reset;\r\n property Text: string read GetText write SetText;\r\n property Count: Integer read GetCount;\r\n end;\r\n\r\n TWordEnumerator = class(TInterfacedObject, IWordEnumerator)\r\n private\r\n FPos: Integer;\r\n FText: string;\r\n FCount: Integer;\r\n procedure SetText(const Text: string);\r\n function GetText: string;\r\n function GetNext(const IncrementPos: Boolean): string;\r\n function GetCount: Integer;\r\n public\r\n constructor Create(const Text: string);\r\n function PopNext: string;\r\n function PeekNext: string;\r\n function HasNext: Boolean;\r\n procedure Reset;\r\n end;\r\n\r\nconstructor TWordEnumerator.Create(const Text: string);\r\nbegin\r\n inherited Create;\r\n Reset;\r\n SetText(Text);\r\nend;\r\n\r\nfunction TWordEnumerator.GetCount: Integer;\r\nbegin\r\n Result := FCount;\r\nend;\r\n\r\nfunction TWordEnumerator.GetNext(const IncrementPos: Boolean): string;\r\nvar\r\n StartPos: Integer;\r\n EndPos: Integer;\r\nbegin\r\n if not HasNext then\r\n raise ETextHandlerError.CreateRes(@RsENoMoreWords);\r\n\r\n StartPos := FPos;\r\n EndPos := FPos;\r\n while (EndPos <= Length(FText)) and (FText[EndPos] <> Space) do\r\n Inc(EndPos);\r\n Inc(EndPos);\r\n Result := Copy(FText, StartPos, EndPos - StartPos);\r\n\r\n if IncrementPos then\r\n begin\r\n FPos := EndPos;\r\n Inc(FCount);\r\n end;\r\nend;\r\n\r\nfunction TWordEnumerator.GetText: string;\r\nbegin\r\n Result := FText;\r\nend;\r\n\r\nfunction TWordEnumerator.HasNext: Boolean;\r\nbegin\r\n Result := FPos <= Length(FText);\r\nend;\r\n\r\nfunction TWordEnumerator.PeekNext: string;\r\nbegin\r\n Result := GetNext(False);\r\nend;\r\n\r\nfunction TWordEnumerator.PopNext: string;\r\nbegin\r\n Result := GetNext(True);\r\nend;\r\n\r\nprocedure TWordEnumerator.Reset;\r\nbegin\r\n FPos := 1;\r\n FCount := 0;\r\nend;\r\n\r\nprocedure TWordEnumerator.SetText(const Text: string);\r\nbegin\r\n FText := Text;\r\n FCount := 0;\r\nend;\r\n\r\n//=== { TTextElementList } ===================================================\r\n\r\nconstructor TTextElementList.Create;\r\nbegin\r\n inherited Create;\r\n FList := TList.Create;\r\nend;\r\n\r\ndestructor TTextElementList.Destroy;\r\nbegin\r\n Clear;\r\n FList.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TTextElementList.AddLineBreak;\r\nbegin\r\n FList.Add(TActionElement.Create(atLineBreak));\r\nend;\r\n\r\nprocedure TTextElementList.AddParagraphBreak;\r\nbegin\r\n FList.Add(TActionElement.Create(atParagraphBreak));\r\nend;\r\n\r\nprocedure TTextElementList.AddStringElement(const Node: TStringNode;\r\n Style: TFontStyles; Color: TColor);\r\nbegin\r\n FList.Add(TStringElement.Create(Node, Style, Color));\r\nend;\r\n\r\nprocedure TTextElementList.Clear;\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := 0 to FList.Count - 1 do\r\n Get(I).Free;\r\n FList.Clear;\r\nend;\r\n\r\nfunction TTextElementList.Get(Index: Integer): TParentTextElement;\r\nbegin\r\n Result := FList[Index];\r\nend;\r\n\r\nfunction TTextElementList.GetCount: Integer;\r\nbegin\r\n Result := FList.Count;\r\nend;\r\n\r\n//=== { TTextHandler } =======================================================\r\n\r\nconstructor TTextHandler.Create(const Rect: TRect; InitialX, InitialY: Integer;\r\n const Canvas: TCanvas);\r\nvar\r\n TempFontStyle: TFontStyles;\r\nconst\r\n // (rom) i have seen other letter combinations elsewhere\r\n // Bianconi #2\r\n // MaximumHeightString = 'fg';\r\n MaximumHeightString = 'Yy';\r\nbegin\r\n inherited Create;\r\n FRect := Rect;\r\n FPosX := InitialX;\r\n FPosY := InitialY;\r\n FCanvas := Canvas;\r\n\r\n { TextHeight returns slightly different values depending on whether fsBold is\r\n in Canvas.Font.Style. This is not acceptable, as it's important that\r\n FLineHeight stays constant between TTextHandler instances. Thus we set\r\n Canvas.Font.Style to [] before calculating the line height. }\r\n TempFontStyle := Canvas.Font.Style;\r\n Canvas.Font.Style := [];\r\n try\r\n FLineHeight := Canvas.TextHeight(MaximumHeightString);\r\n finally\r\n Canvas.Font.Style := TempFontStyle;\r\n end;\r\n\r\n FList := TTextElementList.Create;\r\n FObservers := TNodeObserverList.Create;\r\nend;\r\n\r\ndestructor TTextHandler.Destroy;\r\nbegin\r\n FObservers.Free;\r\n FList.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TTextHandler.AddStartingPosObserver(\r\n Observer: IStartingPosObserver; Node: TAreaNode);\r\nbegin\r\n FObservers.AddObserver(Observer, Node,\r\n Node.GetFirstNodeOfClass(TStringNode) as TStringNode);\r\nend;\r\n\r\nprocedure TTextHandler.DoLineBreak;\r\nbegin\r\n FList.AddLineBreak;\r\n EmptyBuffer;\r\nend;\r\n\r\nprocedure TTextHandler.DoParagraphBreak;\r\nbegin\r\n FList.AddParagraphBreak;\r\n EmptyBuffer;\r\nend;\r\n\r\nfunction TTextHandler.GetCanvas: TCanvas;\r\nbegin\r\n Result := FCanvas;\r\nend;\r\n\r\nfunction TTextHandler.GetLineHeight: Integer;\r\nbegin\r\n Result := FLineHeight;\r\nend;\r\n\r\nfunction TTextHandler.GetPosX: Integer;\r\nbegin\r\n Result := FPosX;\r\nend;\r\n\r\nfunction TTextHandler.GetPosY: Integer;\r\nbegin\r\n Result := FPosY;\r\nend;\r\n\r\nfunction TTextHandler.GetTextHeight: Integer;\r\nbegin\r\n Result := FPosY + FLineHeight;\r\nend;\r\n\r\nfunction TTextHandler.IsPosCurrent: Boolean;\r\nbegin\r\n Result := FList.Count = 0;\r\nend;\r\n\r\nprocedure TTextHandler.EmptyBuffer;\r\nvar\r\n I: Integer;\r\n Element: TStringElement;\r\n Enum: IWordEnumerator;\r\n Buffer: string;\r\n NextWord: string;\r\n NextWordWidth: Integer;\r\n Width: Integer;\r\n SpaceInfo: TSpaceInfo;\r\n\r\n function GetWidth(out SpaceInfo: TSpaceInfo): Integer;\r\n var\r\n J: Integer;\r\n PrivateEnum: IWordEnumerator;\r\n WordElement: string;\r\n CurrentElement: TStringElement;\r\n begin\r\n { If the width of the first word has already been included in the count,\r\n don't count it again; thus, return 0. }\r\n if Element.Node.FirstWordWidthRetrieved and (Enum.Count = 1) then\r\n Result := 0\r\n else\r\n Result := FCanvas.TextWidth(NextWord);\r\n\r\n { Update record with default information; might be overwritten later if\r\n we're dealing with quite special markup. }\r\n with SpaceInfo do\r\n begin\r\n LastWordEndsWithSpace := TStringTools.EndsWith(NextWord);\r\n SpaceWidth := FCanvas.TextWidth(Space);\r\n end;\r\n\r\n if (not Enum.HasNext) and not (Element.Node.FirstWordWidthRetrieved and (Enum.Count = 1)) then\r\n begin\r\n J := I + 1;\r\n\r\n while (J < FList.Count) and\r\n (FList[J - 1] is TStringElement) and\r\n (FList[J] is TStringElement) and\r\n (not TStringElement(FList[J - 1]).EndsWithSpace) and\r\n (not TStringElement(FList[J]).BeginsWithSpace) do // Part of the same word\r\n begin\r\n CurrentElement := TStringElement(FList[J]);\r\n PrivateEnum := TWordEnumerator.Create(CurrentElement.Node.Text);\r\n\r\n FCanvas.Font.Style := CurrentElement.Style;\r\n WordElement := PrivateEnum.PopNext;\r\n Inc(Result, FCanvas.TextWidth(WordElement));\r\n CurrentElement.Node.FirstWordWidthRetrieved := True;\r\n\r\n // Update record\r\n if J = FList.Count - 1 then\r\n with SpaceInfo do\r\n begin\r\n LastWordEndsWithSpace := TStringTools.EndsWith(WordElement);\r\n SpaceWidth := FCanvas.TextWidth(Space);\r\n end;\r\n\r\n // We're only nterested in the first word; let's break if there are more\r\n if PrivateEnum.HasNext then\r\n Break;\r\n Inc(J);\r\n end;\r\n\r\n // Restore canvas\r\n FCanvas.Font.Style := Element.Style;\r\n end;\r\n end;\r\n\r\n function GetWidthWithoutLastSpace: Integer;\r\n begin\r\n if SpaceInfo.LastWordEndsWithSpace then\r\n Result := Width - SpaceInfo.SpaceWidth\r\n else\r\n Result := Width;\r\n end;\r\n\r\n function IsFirstWordOfSource: Boolean;\r\n begin\r\n { If we are processing the first word of the source, we don't want to word\r\n wrap; we'd simply leave an empty line at the top. }\r\n Result := ((FPosX = FRect.Left) and (FPosY = FRect.Top) and (Enum.Count = 1));\r\n end;\r\n\r\n function IsInWord: Boolean;\r\n begin\r\n Result := Element.Node.FirstWordWidthRetrieved and (Enum.Count = 1);\r\n end;\r\n\r\n procedure NotifyObservers;\r\n var\r\n Index: Integer;\r\n begin\r\n { Notify observers that we are processing the node they are interested in.\r\n Note that more than one observer may be interested in monitoring the same\r\n node; TDynamicNode is a good example. }\r\n Index := FObservers.IndexOfStringNode(Element.Node);\r\n\r\n while Index <> -1 do\r\n begin\r\n with FObservers[Index]^ do\r\n if Assigned(Observer) then\r\n Observer.StartingPosUpdated(FPosX, FPosY, ParentNode);\r\n FObservers.RemoveObserver(FObservers[Index]);\r\n Index := FObservers.IndexOfStringNode(Element.Node);\r\n end;\r\n end;\r\n\r\n function GetCurrentRect: TRect;\r\n begin\r\n Result := Rect( FPosX,\r\n FPosY,\r\n FPosX + FCanvas.TextWidth(Buffer),\r\n FPosY + FLineHeight);\r\n end;\r\n\r\nbegin\r\n for I := 0 to FList.Count - 1 do\r\n if FList[I] is TActionElement then\r\n begin\r\n // Bianconi #2\r\n FPosX := 0;\r\n // End of Bianconi #2\r\n case TActionElement(FList[I]).ActionType of\r\n atLineBreak:\r\n Inc(FPosY, FLineHeight);\r\n atParagraphBreak:\r\n Inc(FPosY, FLineHeight * 2);\r\n end;\r\n end\r\n else\r\n if FList[I] is TStringElement then\r\n with FCanvas do\r\n begin\r\n Element := TStringElement(FList[I]);\r\n NotifyObservers;\r\n\r\n Font.Style := Element.Style;\r\n Font.Color := Element.Color;\r\n\r\n Enum := TWordEnumerator.Create(Element.Node.Text);\r\n Buffer := '';\r\n Width := 0;\r\n Element.Node.ClearRects;\r\n\r\n while Enum.HasNext do\r\n begin\r\n NextWord := Enum.PopNext;\r\n\r\n { We cache information about each individual word to speed rendering;\r\n this way, we don't have to recalculate this information every time\r\n this routine is called (basically every time the tree needs to be\r\n repainted). We also do this as we otherwise wouldn't get correct\r\n output when rendering nodes individually (for example, we frequently\r\n rerender TLinkNodes with a different color). We only break after every\r\n complete word, and one node might not contain complete words. GetWidth\r\n makes use of information from other nodes succeeding the current one\r\n if necessary; this explains why it's important to only store\r\n information gathered when rendering the complete tree, that is, the\r\n first time we render anything at all. }\r\n if Element.Node.IsWordInfoInArray(Enum.Count - 1) then\r\n begin\r\n NextWordWidth := Element.Node.GetWordInfo(Enum.Count - 1).Width;\r\n SpaceInfo := Element.Node.GetWordInfo(Enum.Count - 1).SpaceInfo;\r\n end\r\n else\r\n begin\r\n NextWordWidth := GetWidth(SpaceInfo);\r\n Element.Node.AddWordInfo(SpaceInfo, NextWordWidth);\r\n end;\r\n\r\n Inc(Width, NextWordWidth);\r\n\r\n // Bianconi #2\r\n // Original Code -> ... FPosX + GetWidthWithoutLastSpace ...\r\n if( ( (FPosX + Element.Node.Root.StartingPoint.X + GetWidthWithoutLastSpace) >= FRect.Right) and\r\n not (NextWord = Space) and // Never wrap because of lone space elements\r\n not IsFirstWordOfSource and // Don't wrap if we have yet to output anything\r\n not IsInWord ) then // We can't wrap if we're in the middle of rendering a word\r\n begin // Word wrap\r\n { Output contents of buffer, empty it and start on a new line, thus\r\n resetting FPosX and incrementing FPosY. }\r\n\r\n TextOut( FPosX + Element.Node.Root.StartingPoint.X,\r\n FPosY + Element.Node.Root.StartingPoint.Y,\r\n TrimRight(Buffer));\r\n Element.Node.AddRect(GetCurrentRect);\r\n Buffer := '';\r\n // Bianconi #2\r\n // FPosX := FRect.Left;\r\n FPosX := 0;\r\n // End of Bianconi #2\r\n Width := NextWordWidth;\r\n Inc(FPosY, FLineHeight);\r\n end\r\n else\r\n if (Element.Node.FirstWordWidthRetrieved) and (Enum.HasNext) and\r\n (Enum.Count = 1) then\r\n Inc(Width, TextWidth(NextWord));\r\n\r\n Buffer := Buffer + NextWord;\r\n end; // while Enum.HasNext\r\n\r\n TextOut( FPosX + Element.Node.Root.StartingPoint.X,\r\n FPosY + Element.Node.Root.StartingPoint.Y,\r\n Buffer);\r\n Element.Node.AddRect(GetCurrentRect);\r\n Inc(FPosX, TextWidth(Buffer));\r\n end\r\n else\r\n raise ETextHandlerError.CreateRes(@RsEUnsupported);\r\n\r\n FList.Clear;\r\nend;\r\n\r\nprocedure TTextHandler.TextOut(Node: TStringNode; Style: TFontStyles;\r\n Color: TColor);\r\nbegin\r\n { Consider these strings:\r\n \"This is a test\"\r\n We first store the string and its attributes in our list. As it ends with\r\n a space character, we know it's safe to empty our buffer (thus rendering\r\n the results to the screen). When we encounter \"test\", we don't know for\r\n sure whether it'll be followed by a new word or a new substring (\"run\"?).\r\n We have to wait until someone tells us that we've reached the end of the\r\n string by calling our public EmptyBuffer method.\r\n \"This is a test\"\r\n As usual, we store the first node element (\"This is a\"). As it doesn't end\r\n with a space, it could be followed by another character. However, when we\r\n encounter \" test\", we know that it was indeed a separate word. We\r\n immediately call EmptyBuffer before parsing the new string.\r\n \"Testing stuff \"\r\n Here's an instance of the general problem this class was designed to\r\n solve. We first store \"Te\" and its attributes, as it might only be a part\r\n of a word. Indeed, in this case we're right. When we get to \"s\", we store\r\n this in a second entry in the list. \"ting\" is then stored in a third\r\n entry after which we discover that the last character is a space, meaning\r\n that we've assembled an entire word. Thus we empty our buffer. }\r\n\r\n if Copy(Node.Text, 1, 1) = Space then\r\n EmptyBuffer;\r\n\r\n FList.AddStringElement(Node, Style, Color);\r\n\r\n if Copy(Node.Text, Length(Node.Text), 1) = Space then\r\n EmptyBuffer;\r\nend;\r\n\r\n//=== { TNodeObserverList } ==================================================\r\n\r\nprocedure TNodeObserverList.AddObserver(Observer: IStartingPosObserver;\r\n ParentNode: TAreaNode; FirstStringNode: TStringNode);\r\nvar\r\n NewRecord: PNodeObserver;\r\nbegin\r\n New(NewRecord);\r\n\r\n try\r\n NewRecord^.Observer := Observer;\r\n NewRecord^.ParentNode := ParentNode;\r\n NewRecord^.FirstStringNode := FirstStringNode;\r\n\r\n FList.Add(NewRecord);\r\n except\r\n Dispose(NewRecord);\r\n raise;\r\n end;\r\nend;\r\n\r\nfunction TNodeObserverList.Get(Index: Integer): PNodeObserver;\r\nbegin\r\n Result := FList[Index];\r\nend;\r\n\r\nfunction TNodeObserverList.IndexOfStringNode(Node: TStringNode): Integer;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := -1;\r\n for I := 0 to FList.Count - 1 do\r\n if Get(I)^.FirstStringNode = Node then\r\n begin\r\n Result := I;\r\n Break;\r\n end;\r\nend;\r\n\r\nprocedure TNodeObserverList.Put(Index: Integer;\r\n const Value: PNodeObserver);\r\nbegin\r\n FList[Index] := Value;\r\nend;\r\n\r\nprocedure TNodeObserverList.RemoveObserver(Item: PNodeObserver);\r\nbegin\r\n FList.Remove(Item);\r\n Dispose(Item);\r\nend;\r\n\r\n//=== { TNodeObserverList } ==================================================\r\n\r\nconstructor TStringElement.Create(const Node: TStringNode;\r\n Style: TFontStyles; Color: TColor);\r\nbegin\r\n inherited Create;\r\n FNode := Node;\r\n FStyle := Style;\r\n FColor := Color;\r\nend;\r\n\r\nfunction TStringElement.BeginsWithSpace: Boolean;\r\nbegin\r\n Result := TStringTools.BeginsWith(FNode.Text);\r\nend;\r\n\r\nfunction TStringElement.EndsWithSpace: Boolean;\r\nbegin\r\n Result := TStringTools.EndsWith(FNode.Text);\r\nend;\r\n\r\n//=== { TActionElement } =====================================================\r\n\r\nconstructor TActionElement.Create(ActionType: TActionType);\r\nbegin\r\n inherited Create;\r\n FActionType := ActionType;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend." }, { "path": "External/Jedi/Jvcl/run/JvLinkLabelTools.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: LinkTools.pas, released 2002-01-06.\r\n\r\nThe Initial Developer of the Original Code is David Polberger \r\nPortions created by David Polberger are Copyright (C) 2002 David Polberger.\r\nAll Rights Reserved.\r\n\r\nContributor(s): ______________________________________.\r\n\r\nCurrent Version: 2.00\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nDescription:\r\n Various common utility routines grouped together in groups, represented by\r\n non-instantiable classes containing class methods. The design of these classes\r\n has been influenced by Java's class library.\r\n\r\nKnown Issues:\r\n Please see the accompanying documentation.\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvLinkLabelTools.pas 12461 2009-08-14 17:21:33Z obones $\r\n\r\nunit JvLinkLabelTools;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n SysUtils, Classes, Windows,\r\n ShellAPI,\r\n JvTypes;\r\n\r\ntype\r\n EGenericToolsError = class(EJVCLException);\r\n\r\n TStaticObject = class(TObject)\r\n public\r\n constructor Create; virtual;\r\n end;\r\n\r\n TStringTools = class(TStaticObject)\r\n private\r\n class function RemoveChars(const S: string; const Chars: array of Char): string;\r\n public\r\n class function RemoveCRLF(const S: string): string;\r\n class function EndsWith(const S: string; const SubS: string = ' '): Boolean;\r\n class function BeginsWith(const S: string; const SubS: string = ' '): Boolean;\r\n class function EscapeBackslashes(const S: string): string;\r\n class function Replace(OldSubstr, NewSubstr: string; var S: string): Boolean;\r\n end;\r\n\r\n TGraphicTools = class(TStaticObject)\r\n public\r\n class function IsPointInRect(const Rect: TRect; const Point: TPoint): Boolean;\r\n end;\r\n\r\n TConversionTools = class(TStaticObject)\r\n public\r\n class function BoolToYesNo(const B: Boolean): string;\r\n class function BoolToStr(const B: Boolean): string;\r\n end;\r\n\r\n TWebTools = class(TStaticObject)\r\n public\r\n class function OpenWebPage(const URI: string): Boolean;\r\n end;\r\n\r\n TOwnerPointerList = class(TObject)\r\n private\r\n function GetCount: Integer;\r\n protected\r\n FList: TList;\r\n public\r\n constructor Create;\r\n destructor Destroy; override;\r\n procedure Clear; virtual;\r\n property Count: Integer read GetCount;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvLinkLabelTools.pas $';\r\n Revision: '$Revision: 12461 $';\r\n Date: '$Date: 2009-08-14 19:21:33 +0200 (ven. 14 août 2009) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n {$IFDEF MSWINDOWS}\r\n// ShellAPI,\r\n {$ENDIF MSWINDOWS}\r\n {$IFDEF HAS_UNIT_LIBC}\r\n// Libc,\r\n {$ENDIF HAS_UNIT_LIBC}\r\n JvConsts, JvResources;\r\n\r\n//=== { TStaticObject } ======================================================\r\n\r\nconstructor TStaticObject.Create;\r\nbegin\r\n raise EGenericToolsError.CreateRes(@RsECannotBeInstantiated);\r\nend;\r\n\r\n//=== { TStringTools } =======================================================\r\n\r\nclass function TStringTools.BeginsWith(const S, SubS: string): Boolean;\r\nbegin\r\n Result := Copy(S, 1, Length(SubS)) = SubS;\r\nend;\r\n\r\nclass function TStringTools.EndsWith(const S, SubS: string): Boolean;\r\nbegin\r\n Result := Copy(S, Length(S) - Length(SubS) + 1, Length(SubS)) = SubS;\r\nend;\r\n\r\nclass function TStringTools.RemoveChars(const S: string;\r\n const Chars: array of Char): string;\r\nbegin\r\n Result := StringReplace(S, Chars, '', [rfReplaceAll, rfIgnoreCase]);\r\nend;\r\n\r\nclass function TStringTools.RemoveCRLF(const S: string): string;\r\nbegin\r\n Result := RemoveChars(S, [Cr, Lf]);\r\nend;\r\n\r\nclass function TStringTools.EscapeBackslashes(const S: string): string;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := S;\r\n for I := Length(Result) downto 1 do\r\n if Result[I] = '\\' then\r\n Insert('\\', Result, I);\r\nend;\r\n\r\nclass function TStringTools.Replace(OldSubstr, NewSubstr: string;\r\n var S: string): Boolean;\r\nvar\r\n Pos: Integer;\r\nbegin\r\n Result := False;\r\n while AnsiPos(OldSubstr, S) <> 0 do\r\n begin\r\n Pos := AnsiPos(OldSubstr, S);\r\n Result := Pos <> 0;\r\n\r\n if Result then\r\n begin\r\n Delete(S, Pos, Length(OldSubstr));\r\n Insert(NewSubstr, S, Pos);\r\n end;\r\n end;\r\nend;\r\n\r\n//=== { TGraphicTools } ======================================================\r\n\r\nclass function TGraphicTools.IsPointInRect(const Rect: TRect;\r\n const Point: TPoint): Boolean;\r\nbegin\r\n Result :=\r\n (Point.X >= Rect.Left) and (Point.X <= Rect.Right) and\r\n (Point.Y >= Rect.Top) and (Point.Y <= Rect.Bottom);\r\nend;\r\n\r\n//=== { TConversionTools } ===================================================\r\n\r\nclass function TConversionTools.BoolToStr(const B: Boolean): string;\r\nbegin\r\n if B then\r\n Result := 'True'\r\n else\r\n Result := 'False';\r\nend;\r\n\r\nclass function TConversionTools.BoolToYesNo(const B: Boolean): string;\r\nbegin\r\n if B then\r\n Result := 'Yes'\r\n else\r\n Result := 'No';\r\nend;\r\n\r\n//=== { TWebTools } ==========================================================\r\n\r\nclass function TWebTools.OpenWebPage(const URI: string): Boolean;\r\nbegin\r\n Result := ShellExecute(0, 'open', PChar(URI), nil, nil, SW_SHOWNORMAL) > 32;\r\nend;\r\n\r\n//=== { TOwnerPointerList } ==================================================\r\n\r\nconstructor TOwnerPointerList.Create;\r\nbegin\r\n inherited Create;\r\n FList := TList.Create;\r\nend;\r\n\r\ndestructor TOwnerPointerList.Destroy;\r\nbegin\r\n Clear;\r\n FList.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TOwnerPointerList.Clear;\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := 0 to FList.Count - 1 do\r\n Dispose(FList[I]);\r\n FList.Clear;\r\nend;\r\n\r\nfunction TOwnerPointerList.GetCount: Integer;\r\nbegin\r\n Result := FList.Count;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend." }, { "path": "External/Jedi/Jvcl/run/JvLinkLabelTree.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: Tree.pas, released 2002-01-06.\r\n\r\nThe Initial Developer of the Original Code is David Polberger \r\nPortions created by David Polberger are Copyright (C) 2002 David Polberger.\r\nAll Rights Reserved.\r\n\r\nContributor(s): Cetkovsky\r\n\r\nCurrent Version: 2.00\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n Please see the accompanying documentation.\r\nDescription:\r\n Tree.pas provides the tree data structure used elsewhere, TNodeTree, as well\r\n as supporting classes.\r\n\r\n Note: Documentation for this unit can be found in Doc\\Source.txt and\r\n Doc\\Readme.txt!\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvLinkLabelTree.pas 13138 2011-10-26 23:17:50Z jfudickar $\r\n\r\nunit JvLinkLabelTree;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Classes, SysUtils, Windows, Graphics,\r\n JvLinkLabelTools, JvTypes;\r\n\r\ntype\r\n ENodeError = class(EJVCLException);\r\n\r\n { Object hierarchy:\r\n\r\n TNode\r\n | TParentNode\r\n | | TAreaNode\r\n | | | TStyleNode\r\n | | | TColorNode\r\n | | | TLinkNode\r\n | | | TDynamicNode\r\n | | | TRootNode\r\n | TStringNode\r\n | TActionNode\r\n | TUnknownNode\r\n }\r\n\r\n TNodeClass = class of TNode;\r\n TNodeType = (ntNode, ntParentNode, ntAreaNode, ntStyleNode, ntColorNode, // Bianconi\r\n ntLinkNode, ntDynamicNode, ntRootNode, ntStringNode, ntActionNode, ntUnknownNode);\r\n TParentNode = class;\r\n TRootNode = class;\r\n\r\n TNode = class(TObject)\r\n private\r\n FParent: TParentNode;\r\n FRootNode: TRootNode;\r\n public\r\n // Bianconi #2\r\n constructor Create;\r\n destructor Destroy; override;\r\n // End of Bianconi #2\r\n function GetNodeType: TNodeType;\r\n property Parent: TParentNode read FParent write FParent;\r\n property Root: TRootNode read FRootNode write FRootNode;\r\n end;\r\n\r\n INodeEnumerator = interface\r\n function GetNext: TNode;\r\n function HasNext: Boolean;\r\n procedure Reset;\r\n end;\r\n\r\n TNodeList = class;\r\n TParentNode = class(TNode)\r\n private\r\n FChildren: TNodeList;\r\n FOwnsChildren: Boolean;\r\n public\r\n constructor Create;\r\n destructor Destroy; override;\r\n procedure AddChild(const ANode: TNode; const ARoot: TRootNode);\r\n procedure DestroyChildren;\r\n function IndexOfChild(const Node: TNode): Integer;\r\n function GetTopLevelNodeEnumerator(const NodeClass: TNodeClass): INodeEnumerator;\r\n function GetFirstNodeOfClass(NodeClass: TNodeClass): TNode;\r\n function GetSpecificNodeOfClass(Index: Integer; NodeClass: TNodeClass): TNode;\r\n property Children: TNodeList read FChildren;\r\n property OwnsChildren: Boolean read FOwnsChildren write FOwnsChildren;\r\n end;\r\n\r\n IRectEnumerator = interface;\r\n\r\n TAreaNode = class(TParentNode)\r\n private\r\n FStartingPoint: TPoint;\r\n FStyles: TFontStyles;\r\n FColor: TColor;\r\n function GetText: string;\r\n protected\r\n function GetStyles: TFontStyles; virtual;\r\n function GetColor: TColor; virtual;\r\n public\r\n constructor Create;\r\n function GetRectEnumerator: IRectEnumerator;\r\n function IsPointInNode(const P: TPoint): Boolean;\r\n function IsPointInNodeClass(const P: TPoint; NodeClass: TNodeClass): Boolean; virtual;\r\n function GetNodeAtPointOfClass(const P: TPoint; NodeClass: TNodeClass): TNode;\r\n property StartingPoint: TPoint read FStartingPoint write FStartingPoint;\r\n property Styles: TFontStyles read GetStyles write FStyles;\r\n property Color: TColor read GetColor write FColor;\r\n property Text: string read GetText;\r\n end;\r\n\r\n TStyleNode = class(TAreaNode)\r\n private\r\n FStyle: TFontStyle;\r\n public\r\n constructor Create(const Style: TFontStyle);\r\n property Style: TFontStyle read FStyle write FStyle;\r\n end;\r\n\r\n // Bianconi\r\n TColorNode = class(TAreaNode)\r\n private\r\n FColor: TColor;\r\n public\r\n constructor Create(const AColor: TColor);\r\n property Color: TColor read FColor write FColor;\r\n end;\r\n // End of Bianconi\r\n\r\n TLinkState = (lsNormal, lsClicked, lsHot);\r\n TLinkNode = class(TAreaNode)\r\n private\r\n FState: TLinkState;\r\n FNumber: Integer;\r\n //Cetkovsky -->\r\n FParam: string;\r\n //<-- Cetkovsky\r\n protected\r\n function GetColor: TColor; override;\r\n\r\n //Cetkovsky -->\r\n function GetParam: string; virtual;\r\n procedure SetParam(Value: string); virtual;\r\n //<-- Cetkovsky\r\n public\r\n //Cetkovsky -->\r\n constructor Create(const AParam: string);\r\n //<-- Cetkovsky\r\n //constructor Create;\r\n class procedure ResetCount;\r\n property State: TLinkState read FState write FState;\r\n property Number: Integer read FNumber;\r\n\r\n //Cetkovsky -->\r\n property Param: string read GetParam write SetParam;\r\n //<-- Cetkovsky\r\n end;\r\n\r\n TDynamicNode = class(TAreaNode)\r\n private\r\n FNumber: Integer;\r\n public\r\n constructor Create;\r\n class procedure ResetCount;\r\n property Number: Integer read FNumber;\r\n end;\r\n\r\n TRectArray = array of TRect;\r\n\r\n TRootNode = class(TAreaNode)\r\n private\r\n FRectArray: TRectArray;\r\n procedure AddRect(const Rect: TRect);\r\n public\r\n procedure RetrieveRectsOfTLinkNodeChildren;\r\n function IsPointInNodeClass(const P: TPoint; NodeClass: TNodeClass): Boolean; override;\r\n end;\r\n\r\n TSpaceInfo = record\r\n LastWordEndsWithSpace: Boolean;\r\n SpaceWidth: Integer;\r\n end;\r\n\r\n TWordInfo = record\r\n SpaceInfo: TSpaceInfo;\r\n Width: Integer;\r\n end;\r\n\r\n TWordInfoArray = array of TWordInfo;\r\n\r\n TStringNode = class(TNode)\r\n private\r\n FText: string;\r\n FRectArray: TRectArray;\r\n FWordInfoArray: TWordInfoArray;\r\n FFirstWordWidthRetrieved: Boolean;\r\n protected\r\n //Cetkovsky -->\r\n class function ConvertEntities(Text: string): string;\r\n //<-- Cetkovsky\r\n// function ConvertEntities(Text: string): string;\r\n public\r\n constructor Create(const Text: string);\r\n procedure AddRect(const Rect: TRect);\r\n procedure ClearRects;\r\n procedure AddWordInfo(SpaceInfo: TSpaceInfo; Width: Integer);\r\n procedure ClearWordInfo;\r\n function IsWordInfoInArray(const Pos: Integer): Boolean;\r\n function GetWordInfo(const Pos: Integer): TWordInfo;\r\n function IsPointInNode(const P: TPoint): Boolean;\r\n property Text: string read FText write FText;\r\n property RectArray: TRectArray read FRectArray;\r\n property FirstWordWidthRetrieved: Boolean read FFirstWordWidthRetrieved write FFirstWordWidthRetrieved;\r\n end;\r\n\r\n TActionType = (atLineBreak, atParagraphBreak);\r\n\r\n TActionNode = class(TNode)\r\n private\r\n FAction: TActionType;\r\n public\r\n constructor Create(const Action: TActionType);\r\n property Action: TActionType read FAction write FAction;\r\n end;\r\n\r\n TUnknownNode = class(TNode)\r\n private\r\n FTag: string;\r\n public\r\n constructor Create(const Tag: string);\r\n property Tag: string read FTag;\r\n end;\r\n\r\n TNodeList = class(TList)\r\n private\r\n function Get(Index: Integer): TNode;\r\n procedure Put(Index: Integer; const Value: TNode);\r\n public\r\n function Add(Item: TNode): Integer;\r\n procedure Insert(Index: Integer; Item: TNode);\r\n function Remove(Item: TNode): Integer;\r\n function IndexOf(Item: TNode): Integer;\r\n property Items[Index: Integer]: TNode read Get write Put; default;\r\n end;\r\n\r\n TNodeTree = class(TObject)\r\n private\r\n FRoot: TRootNode;\r\n public\r\n constructor Create;\r\n destructor Destroy; override;\r\n function GetTopLevelNodeEnumerator(const NodeClass: TNodeClass): INodeEnumerator;\r\n function IsPointInTree(const P: TPoint): Boolean;\r\n function IsPointInNodeClass(const P: TPoint; NodeClass: TNodeClass): Boolean;\r\n function GetNodeAtPointOfClass(const P: TPoint; NodeClass: TNodeClass): TNode;\r\n function GetSpecificNodeOfClass(Index: Integer; NodeClass: TNodeClass): TNode;\r\n procedure Clear;\r\n property Root: TRootNode read FRoot;\r\n end;\r\n\r\n IRectEnumerator = interface\r\n function GetNext: TRect;\r\n function HasNext: Boolean;\r\n procedure Reset;\r\n end;\r\n\r\nconst\r\n clNormalLink = TColor($400 or $80000000);\r\n clClickedLink = TColor($401 or $80000000);\r\n clHotLink = TColor($402 or $80000000);\r\n\r\nprocedure ResetNodeCount;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvLinkLabelTree.pas $';\r\n Revision: '$Revision: 13138 $';\r\n Date: '$Date: 2011-10-27 01:17:50 +0200 (jeu. 27 oct. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n JvResources;\r\n\r\ntype\r\n TRectList = class(TOwnerPointerList)\r\n private\r\n function Get(Index: Integer): PRect;\r\n public\r\n procedure AddRect(const Rect: TRect);\r\n property Items[Index: Integer]: PRect read Get; default;\r\n end;\r\n\r\n TRectEnumerator = class(TInterfacedObject, IRectEnumerator)\r\n private\r\n FList: TRectList;\r\n FIndex: Integer;\r\n public\r\n constructor Create(const List: TRectList);\r\n destructor Destroy; override;\r\n function GetNext: TRect;\r\n function HasNext: Boolean;\r\n procedure Reset;\r\n end;\r\n\r\n TTopLevelNodeEnumerator = class(TInterfacedObject, INodeEnumerator)\r\n private\r\n FRoot: TParentNode;\r\n FNodeClass: TNodeClass;\r\n FList: TNodeList;\r\n FIndex: Integer;\r\n procedure BuildList;\r\n public\r\n constructor Create(const Root: TParentNode; NodeClass: TNodeClass);\r\n destructor Destroy; override;\r\n function GetNext: TNode;\r\n function HasNext: Boolean;\r\n procedure Reset;\r\n end;\r\n\r\nvar\r\n LinkNodeCount: Integer = 0;\r\n DynamicNodeCount: Integer = 0;\r\n\r\nprocedure ResetNodeCount;\r\nbegin\r\n TLinkNode.ResetCount;\r\n TDynamicNode.ResetCount;\r\nend;\r\n\r\n//=== { TNodeTree } ==========================================================\r\n\r\nconstructor TNodeTree.Create;\r\nbegin\r\n inherited Create;\r\n FRoot := TRootNode.Create;\r\n FRoot.Styles := [];\r\n FRoot.Color := clWindowText;\r\nend;\r\n\r\ndestructor TNodeTree.Destroy;\r\nbegin\r\n Clear;\r\n FRoot.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TNodeTree.Clear;\r\nbegin\r\n FRoot.DestroyChildren;\r\nend;\r\n\r\nfunction TNodeTree.GetNodeAtPointOfClass(const P: TPoint; NodeClass: TNodeClass): TNode;\r\nbegin\r\n Result := FRoot.GetNodeAtPointOfClass(P, NodeClass);\r\nend;\r\n\r\nfunction TNodeTree.GetSpecificNodeOfClass(Index: Integer;\r\n NodeClass: TNodeClass): TNode;\r\nbegin\r\n Result := FRoot.GetSpecificNodeOfClass(Index, NodeClass);\r\nend;\r\n\r\nfunction TNodeTree.GetTopLevelNodeEnumerator(\r\n const NodeClass: TNodeClass): INodeEnumerator;\r\nbegin\r\n Result := FRoot.GetTopLevelNodeEnumerator(NodeClass);\r\nend;\r\n\r\nfunction TNodeTree.IsPointInNodeClass(const P: TPoint;\r\n NodeClass: TNodeClass): Boolean;\r\nbegin\r\n Result := FRoot.IsPointInNodeClass(P, NodeClass);\r\nend;\r\n\r\nfunction TNodeTree.IsPointInTree(const P: TPoint): Boolean;\r\nbegin\r\n Result := FRoot.IsPointInNode(P);\r\nend;\r\n\r\n//=== { TParentNode } ========================================================\r\n\r\nconstructor TParentNode.Create;\r\nbegin\r\n inherited Create;\r\n FChildren := TNodeList.Create;\r\n FOwnsChildren := True;\r\nend;\r\n\r\ndestructor TParentNode.Destroy;\r\nbegin\r\n DestroyChildren;\r\n FChildren.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TParentNode.AddChild(const ANode: TNode; const ARoot: TRootNode);\r\nbegin\r\n FChildren.Add(ANode);\r\n ANode.Parent := Self;\r\n ANode.Root := ARoot;\r\nend;\r\n\r\nprocedure TParentNode.DestroyChildren;\r\nvar\r\n I: Integer;\r\nbegin\r\n if FOwnsChildren then\r\n for I := FChildren.Count - 1 downto 0 do\r\n begin\r\n FChildren[I].Free;\r\n FChildren.Delete(I);\r\n end;\r\nend;\r\n\r\nfunction TParentNode.GetFirstNodeOfClass(NodeClass: TNodeClass): TNode;\r\n\r\n function RecurseTree(CurrentRoot: TParentNode): TNode;\r\n var\r\n I: Integer;\r\n begin\r\n Result := nil;\r\n for I := 0 to CurrentRoot.Children.Count - 1 do\r\n begin\r\n if CurrentRoot.Children[I] is NodeClass then\r\n begin\r\n Result := CurrentRoot.FChildren[I];\r\n Break;\r\n end\r\n else\r\n if CurrentRoot.Children[I] is TParentNode then\r\n Result := RecurseTree(TParentNode(CurrentRoot.Children[I]));\r\n end;\r\n end;\r\n\r\nbegin\r\n Result := RecurseTree(Self);\r\nend;\r\n\r\nfunction TParentNode.GetSpecificNodeOfClass(Index: Integer;\r\n NodeClass: TNodeClass): TNode;\r\nvar\r\n NodeEnum: INodeEnumerator;\r\n CurrentNode: TNode;\r\n CurrentIndex: Integer;\r\nbegin\r\n Result := nil;\r\n CurrentIndex := 0;\r\n NodeEnum := Self.GetTopLevelNodeEnumerator(NodeClass);\r\n while NodeEnum.HasNext do\r\n begin\r\n CurrentNode := NodeEnum.GetNext;\r\n if CurrentIndex = Index then\r\n Result := CurrentNode;\r\n Inc(CurrentIndex);\r\n end;\r\nend;\r\n\r\nfunction TParentNode.GetTopLevelNodeEnumerator(const NodeClass: TNodeClass): INodeEnumerator;\r\nbegin\r\n Result := TTopLevelNodeEnumerator.Create(Self, NodeClass);\r\nend;\r\n\r\nfunction TParentNode.IndexOfChild(const Node: TNode): Integer;\r\nbegin\r\n Result := FChildren.IndexOf(Node);\r\nend;\r\n\r\n//=== { TNodeList } ==========================================================\r\n\r\nfunction TNodeList.Add(Item: TNode): Integer;\r\nbegin\r\n Result := inherited Add(Item);\r\nend;\r\n\r\nfunction TNodeList.Get(Index: Integer): TNode;\r\nbegin\r\n Result := inherited Get(Index);\r\nend;\r\n\r\nfunction TNodeList.IndexOf(Item: TNode): Integer;\r\nbegin\r\n Result := inherited IndexOf(Item);\r\nend;\r\n\r\nprocedure TNodeList.Insert(Index: Integer; Item: TNode);\r\nbegin\r\n inherited Insert(Index, Item);\r\nend;\r\n\r\nprocedure TNodeList.Put(Index: Integer; const Value: TNode);\r\nbegin\r\n inherited Put(Index, Value);\r\nend;\r\n\r\nfunction TNodeList.Remove(Item: TNode): Integer;\r\nbegin\r\n Result := inherited Remove(Item);\r\nend;\r\n\r\n//=== { TStringNode } ========================================================\r\n\r\nconstructor TStringNode.Create(const Text: string);\r\nbegin\r\n inherited Create;\r\n FText := ConvertEntities(Text);\r\nend;\r\n\r\nprocedure TStringNode.AddRect(const Rect: TRect);\r\nbegin\r\n SetLength(FRectArray, Length(FRectArray) + 1);\r\n FRectArray[High(FRectArray)] := Rect;\r\nend;\r\n\r\nprocedure TStringNode.AddWordInfo(SpaceInfo: TSpaceInfo; Width: Integer);\r\nbegin\r\n SetLength(FWordInfoArray, Length(FWordInfoArray) + 1);\r\n FWordInfoArray[High(FWordInfoArray)].Width := Width;\r\n FWordInfoArray[High(FWordInfoArray)].SpaceInfo := SpaceInfo;\r\nend;\r\n\r\nprocedure TStringNode.ClearRects;\r\nbegin\r\n FRectArray := nil;\r\nend;\r\n\r\nprocedure TStringNode.ClearWordInfo;\r\nbegin\r\n FWordInfoArray := nil;\r\nend;\r\n\r\n//Cetkovsky -->\r\nclass function TStringNode.ConvertEntities(Text: string): string;\r\n//<-- Cetkovsky\r\ntype\r\n TEntity = record\r\n Entity: PChar;\r\n Str: PChar;\r\n end;\r\nconst\r\n NumberOfEntities = 2;\r\n Entities: array [0..NumberOfEntities - 1] of TEntity =\r\n ((Entity: '<'; Str: '<'),\r\n (Entity: '>'; Str: '>'));\r\nvar\r\n I: Integer;\r\nbegin\r\n { Our support for entities is very limited. Right now, we only use it as a way\r\n to write the \"<\" and \">\" characters, which would've been impossible without\r\n the use of entities. To implement full support, akin to XHTML, we would need\r\n to revise this simple implementation, which only handles simple string\r\n replacement (the renderer is oblivious to entities). For our uses, however,\r\n it's sufficient. }\r\n for I := Low(Entities) to High(Entities) do\r\n with Entities[I] do\r\n TStringTools.Replace(Entity, Str, Text);\r\n Result := Text;\r\nend;\r\n\r\nfunction TStringNode.GetWordInfo(const Pos: Integer): TWordInfo;\r\nbegin\r\n if IsWordInfoInArray(Pos) then\r\n Result := FWordInfoArray[Pos]\r\n else\r\n raise ENodeError.CreateRes(@RsEWordInfoIndexOutOfBounds);\r\nend;\r\n\r\nfunction TStringNode.IsPointInNode(const P: TPoint): Boolean;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := False;\r\n for I := Low(FRectArray) to High(FRectArray) do\r\n begin\r\n Result := TGraphicTools.IsPointInRect(FRectArray[I], P);\r\n if Result then\r\n Break;\r\n end;\r\nend;\r\n\r\nfunction TStringNode.IsWordInfoInArray(const Pos: Integer): Boolean;\r\nbegin\r\n Result := Pos <= High(FWordInfoArray);\r\nend;\r\n\r\n//=== { TStyleNode } =========================================================\r\n\r\nconstructor TStyleNode.Create(const Style: TFontStyle);\r\nbegin\r\n inherited Create;\r\n FStyle := Style;\r\nend;\r\n\r\n// Bianconi\r\n//=== { TColorNode } =========================================================\r\n\r\nconstructor TColorNode.Create(const AColor: TColor);\r\nbegin\r\n inherited Create;\r\n if AColor <> clNone then\r\n FColor := AColor\r\n else\r\n FColor := inherited GetColor;\r\nend;\r\n// End of Bianconi\r\n\r\n//=== { TUnknownNode } =======================================================\r\n\r\nconstructor TUnknownNode.Create(const Tag: string);\r\nbegin\r\n inherited Create;\r\n FTag := Tag;\r\nend;\r\n\r\n//=== { TActionNode } ========================================================\r\n\r\nconstructor TActionNode.Create(const Action: TActionType);\r\nbegin\r\n inherited Create;\r\n FAction := Action;\r\nend;\r\n\r\n//=== { TAreaNode } ==========================================================\r\n\r\nconstructor TAreaNode.Create;\r\nbegin\r\n inherited Create;\r\n FStartingPoint := Point(0, 0);\r\nend;\r\n\r\nfunction TAreaNode.GetColor: TColor;\r\nbegin\r\n Result := FColor;\r\nend;\r\n\r\nfunction TAreaNode.GetNodeAtPointOfClass(const P: TPoint; NodeClass: TNodeClass): TNode;\r\nvar\r\n NodeEnum: INodeEnumerator;\r\n CurrentNode: TAreaNode;\r\nbegin\r\n Result := nil;\r\n NodeEnum := Self.GetTopLevelNodeEnumerator(TAreaNode);\r\n while NodeEnum.HasNext do\r\n begin\r\n CurrentNode := NodeEnum.GetNext as TAreaNode;\r\n if CurrentNode.IsPointInNode(P) then\r\n if CurrentNode is NodeClass then\r\n begin\r\n Result := CurrentNode;\r\n Break;\r\n end\r\n else\r\n Result := CurrentNode.GetNodeAtPointOfClass(P, NodeClass);\r\n end;\r\nend;\r\n\r\nfunction TAreaNode.GetRectEnumerator: IRectEnumerator;\r\nvar\r\n NodeEnum: INodeEnumerator;\r\n CurrentNode: TStringNode;\r\n FList: TRectList;\r\n I: Integer;\r\nbegin\r\n FList := TRectList.Create;\r\n\r\n try\r\n { Retrieve a top-level enumerator which we use to get pointers to all\r\n TStringNodes we own (we write Self.Get... to make explicit the fact that\r\n we only get pointers to TStringNodes we own). }\r\n NodeEnum := Self.GetTopLevelNodeEnumerator(TStringNode);\r\n while NodeEnum.HasNext do\r\n begin\r\n CurrentNode := NodeEnum.GetNext as TStringNode;\r\n for I := Low(CurrentNode.RectArray) to High(CurrentNode.RectArray) do\r\n FList.AddRect(CurrentNode.RectArray[I]);\r\n end;\r\n\r\n // FList will be destroyed by TRectEnumerator's destructor\r\n Result := TRectEnumerator.Create(FList);\r\n except\r\n FList.Free;\r\n raise;\r\n end;\r\nend;\r\n\r\nfunction TAreaNode.GetStyles: TFontStyles;\r\nbegin\r\n Result := FStyles;\r\nend;\r\n\r\nfunction TAreaNode.GetText: string;\r\nvar\r\n NodeEnum: INodeEnumerator;\r\nbegin\r\n Result := '';\r\n NodeEnum := Self.GetTopLevelNodeEnumerator(TStringNode);\r\n while NodeEnum.HasNext do\r\n Result := Result + (NodeEnum.GetNext as TStringNode).Text;\r\nend;\r\n\r\nfunction TAreaNode.IsPointInNode(const P: TPoint): Boolean;\r\nvar\r\n NodeEnum: INodeEnumerator;\r\n CurrentNode: TStringNode;\r\nbegin\r\n Result := False;\r\n NodeEnum := Self.GetTopLevelNodeEnumerator(TStringNode);\r\n while NodeEnum.HasNext do\r\n begin\r\n CurrentNode := NodeEnum.GetNext as TStringNode;\r\n Result := CurrentNode.IsPointInNode(P);\r\n if Result then\r\n Break;\r\n end;\r\nend;\r\n\r\nfunction TAreaNode.IsPointInNodeClass(const P: TPoint;\r\n NodeClass: TNodeClass): Boolean;\r\nvar\r\n NodeEnum: INodeEnumerator;\r\n CurrentNode: TNode;\r\nbegin\r\n Result := False;\r\n NodeEnum := Self.GetTopLevelNodeEnumerator(NodeClass);\r\n while NodeEnum.HasNext do\r\n begin\r\n CurrentNode := NodeEnum.GetNext;\r\n if (CurrentNode is TAreaNode) then\r\n begin\r\n Result := TAreaNode(CurrentNode).IsPointInNode(P);\r\n if Result then\r\n Break;\r\n end;\r\n end;\r\nend;\r\n\r\n//=== { TNode } ==============================================================\r\n\r\n// Bianconi #2\r\nconstructor TNode.Create;\r\nbegin\r\n inherited Create;\r\n FParent := nil;\r\n FRootNode := nil;\r\nend;\r\n\r\ndestructor TNode.Destroy;\r\nbegin\r\n FParent := nil;\r\n FRootNode := nil;\r\n inherited Destroy;\r\nend;\r\n// End of Bianconi #2\r\n\r\nfunction TNode.GetNodeType: TNodeType;\r\nvar\r\n NodeClass: TClass;\r\nconst\r\n NodeClasses: array [TNodeType] of TClass =\r\n (TNode, TParentNode, TAreaNode, TStyleNode, TColorNode, // Bianconi\r\n TLinkNode, TDynamicNode, TRootNode, TStringNode, TActionNode, TUnknownNode);\r\nbegin\r\n { We get the dynamic type using TObject.ClassType, which returns a pointer to\r\n the class' virtual memory table, instead of testing using the \"is\" reserved\r\n word. We do this as any node is a TNode (thanks to polymorphism); we would\r\n have to test in reverse order, as if we tested for TNode first everything\r\n would appear to be a TNode. This could get messy when we add more TNode\r\n descendants later. }\r\n NodeClass := Self.ClassType;\r\n\r\n for Result := Low(TNodeType) to High(TNodeType) do\r\n if NodeClasses[Result] = NodeClass then\r\n Exit;\r\n\r\n raise ENodeError.CreateRes(@RsETNodeGetNodeTypeUnknownClass);\r\nend;\r\n\r\n//=== { TTopLevelNodeEnumerator } ============================================\r\n\r\nconstructor TTopLevelNodeEnumerator.Create(const Root: TParentNode;\r\n NodeClass: TNodeClass);\r\nbegin\r\n inherited Create;\r\n FRoot := Root;\r\n FNodeClass := NodeClass;\r\n FIndex := 0;\r\n\r\n FList := TNodeList.Create;\r\n BuildList;\r\nend;\r\n\r\ndestructor TTopLevelNodeEnumerator.Destroy;\r\nbegin\r\n FList.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TTopLevelNodeEnumerator.BuildList;\r\n\r\n procedure RecurseTree(CurrentRoot: TParentNode);\r\n var\r\n I: Integer;\r\n begin\r\n for I := 0 to CurrentRoot.Children.Count - 1 do\r\n begin\r\n { If we find a child that is of the requested type, add it to the list.\r\n Don't continue to recurse, as we're not interested in this node's\r\n children (after all, we're a top level enumerator!). }\r\n if CurrentRoot.Children[I] is FNodeClass then\r\n FList.Add(CurrentRoot.FChildren[I])\r\n else\r\n if CurrentRoot.Children[I] is TParentNode then\r\n RecurseTree(TParentNode(CurrentRoot.Children[I]));\r\n end;\r\n end;\r\n\r\nbegin\r\n FList.Clear;\r\n RecurseTree(FRoot);\r\nend;\r\n\r\nfunction TTopLevelNodeEnumerator.GetNext: TNode;\r\nbegin\r\n if HasNext then\r\n begin\r\n Result := FList[FIndex];\r\n Inc(FIndex);\r\n end\r\n else\r\n raise ENodeError.CreateRes(@RsENoMoreNodesToReturn);\r\nend;\r\n\r\nfunction TTopLevelNodeEnumerator.HasNext: Boolean;\r\nbegin\r\n Result := FIndex < FList.Count;\r\nend;\r\n\r\nprocedure TTopLevelNodeEnumerator.Reset;\r\nbegin\r\n FIndex := 0;\r\nend;\r\n\r\n//=== { TRectEnumerator } ====================================================\r\n\r\nconstructor TRectEnumerator.Create(const List: TRectList);\r\nbegin\r\n inherited Create;\r\n FList := List;\r\n FIndex := 0;\r\nend;\r\n\r\ndestructor TRectEnumerator.Destroy;\r\nbegin\r\n FList.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TRectEnumerator.GetNext: TRect;\r\nbegin\r\n if HasNext then\r\n begin\r\n Result := FList[FIndex]^;\r\n Inc(FIndex);\r\n end\r\n else\r\n raise ENodeError.CreateRes(@RsENoMoreRecordsToReturn);\r\nend;\r\n\r\nfunction TRectEnumerator.HasNext: Boolean;\r\nbegin\r\n Result := FIndex < FList.Count;\r\nend;\r\n\r\nprocedure TRectEnumerator.Reset;\r\nbegin\r\n FIndex := 0;\r\nend;\r\n\r\n//=== { TRectList } ==========================================================\r\n\r\nprocedure TRectList.AddRect(const Rect: TRect);\r\nvar\r\n NewRecord: PRect;\r\nbegin\r\n New(NewRecord);\r\n try\r\n NewRecord^.Left := Rect.Left;\r\n NewRecord^.Top := Rect.Top;\r\n NewRecord^.Right := Rect.Right;\r\n NewRecord^.Bottom := Rect.Bottom;\r\n FList.Add(NewRecord);\r\n except\r\n Dispose(NewRecord);\r\n raise;\r\n end;\r\nend;\r\n\r\nfunction TRectList.Get(Index: Integer): PRect;\r\nbegin\r\n Result := FList[Index];\r\nend;\r\n\r\n//=== { TLinkNode } ==========================================================\r\n\r\n//Cetkovsky -->\r\nconstructor TLinkNode.Create(const AParam: string);\r\n//<-- Cetkovsky\r\nbegin\r\n inherited Create;\r\n FNumber := LinkNodeCount;\r\n Inc(LinkNodeCount);\r\n //Cetkovsky -->\r\n FParam := AParam;\r\n //<-- Cetkovsky\r\nend;\r\n\r\nfunction TLinkNode.GetColor: TColor;\r\nbegin\r\n case State of\r\n lsNormal:\r\n Result := clNormalLink;\r\n lsClicked:\r\n Result := clClickedLink;\r\n lsHot:\r\n Result := clHotLink;\r\n else\r\n Result := inherited GetColor; // To get rid of a compiler warning\r\n end;\r\nend;\r\n\r\nclass procedure TLinkNode.ResetCount;\r\nbegin\r\n LinkNodeCount := 0;\r\nend;\r\n\r\n//Cetkovsky -->\r\nfunction TLinkNode.GetParam: string;\r\nbegin\r\n Result := FParam;\r\nend;\r\n\r\nprocedure TLinkNode.SetParam(Value: string);\r\nbegin\r\n FParam := Value;\r\nend;\r\n//<-- Cetkovsky\r\n\r\n//=== { TRootNode } ==========================================================\r\n\r\nprocedure TRootNode.AddRect(const Rect: TRect);\r\nbegin\r\n SetLength(FRectArray, Length(FRectArray) + 1);\r\n FRectArray[High(FRectArray)] := Rect;\r\nend;\r\n\r\nfunction TRootNode.IsPointInNodeClass(const P: TPoint; NodeClass: TNodeClass): Boolean;\r\nvar\r\n I: Integer;\r\nbegin\r\n { In the root, we cache the locations of all our TLinkNode children, not only\r\n our most immediate children but all of them, even if they have a parent\r\n other than the root node. We do this to improve performance, as this routine\r\n might be queried every time the mouse is moved. On a PII-400 MHz computer,\r\n TJvLinkLabel alone might consume 20% CPU power without this optimization when\r\n we move the mouse pointer as fast as we can, which is not acceptable. With\r\n this optimization, we consume only about a third as much CPU power. }\r\n if (NodeClass = TLinkNode) and (Length(FRectArray) <> 0) then\r\n begin\r\n Result := False;\r\n for I := Low(FRectArray) to High(FRectArray) do\r\n if TGraphicTools.IsPointInRect(FRectArray[I], P) then\r\n begin\r\n Result := True;\r\n Break;\r\n end;\r\n end\r\n else\r\n Result := inherited IsPointInNodeClass(P, NodeClass);\r\nend;\r\n\r\nprocedure TRootNode.RetrieveRectsOfTLinkNodeChildren;\r\nvar\r\n NodeEnum: INodeEnumerator;\r\n RectEnum: IRectEnumerator;\r\nbegin\r\n FRectArray := nil;\r\n NodeEnum := Self.GetTopLevelNodeEnumerator(TLinkNode);\r\n while NodeEnum.HasNext do\r\n begin\r\n RectEnum := (NodeEnum.GetNext as TLinkNode).GetRectEnumerator;\r\n while RectEnum.HasNext do\r\n AddRect(RectEnum.GetNext);\r\n end;\r\nend;\r\n\r\n//=== { TDynamicNode } =======================================================\r\n\r\nconstructor TDynamicNode.Create;\r\nbegin\r\n inherited Create;\r\n FNumber := DynamicNodeCount;\r\n Inc(DynamicNodeCount);\r\nend;\r\n\r\nclass procedure TDynamicNode.ResetCount;\r\nbegin\r\n DynamicNodeCount := 0;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend." }, { "path": "External/Jedi/Jvcl/run/JvLinkedControls.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvLinkedControls.PAS, released on 2004-01-26.\r\n\r\nThe Initial Developer of the Original Code is Peter Thrnqvist\r\nPortions created by Peter Thrnqvist are Copyright (C) 2004 Peter Thrnqvist.\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvLinkedControls.pas 12556 2009-10-13 18:34:42Z ahuser $\r\n\r\nunit JvLinkedControls;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n SysUtils, Controls,\r\n Classes;\r\n\r\ntype\r\n TJvLinkedControlsOption = (loLinkChecked, loLinkEnabled, loInvertChecked, loInvertEnabled, loForceFocus);\r\n TJvLinkedControlsOptions = set of TJvLinkedControlsOption;\r\n\r\n TJvLinkedControl = class(TCollectionItem)\r\n private\r\n FOwnerControl, FControl: TControl;\r\n FOptions: TJvLinkedControlsOptions;\r\n FOriginalEnabled: Boolean;\r\n procedure SetControl(const Value: TControl);\r\n procedure SetOptions(const Value: TJvLinkedControlsOptions);\r\n protected\r\n function GetDisplayName: string; override;\r\n public\r\n constructor Create(Collection: TCollection); override;\r\n destructor Destroy; override;\r\n procedure Assign(Source: TPersistent); override;\r\n published\r\n property Control: TControl read FControl write SetControl;\r\n property Options: TJvLinkedControlsOptions read FOptions write SetOptions default [loLinkChecked, loLinkEnabled];\r\n end;\r\n\r\n TJvLinkedControls = class(TOwnedCollection)\r\n private\r\n FControl: TControl;\r\n FOnChange: TNotifyEvent;\r\n FRestoreEnabled: Boolean;\r\n function GetItems(Index: Integer): TJvLinkedControl;\r\n procedure SetItems(Index: Integer; const Value: TJvLinkedControl);\r\n protected\r\n procedure Update(Item: TCollectionItem); override;\r\n public\r\n // You must call Notification in the Owning controls overridden Notification\r\n // or hell will break loose when linked controls are removed!!!\r\n procedure Notification(AComponent: TComponent; Operation: TOperation); virtual;\r\n constructor Create(AControl: TControl);\r\n function Add: TJvLinkedControl;\r\n procedure Assign(Source: TPersistent); override;\r\n // If RestoreEnabled is True, TJvLinkedControls will try to restore the Enabled state\r\n // of linked controls when an item is changed or removed\r\n property Items[Index: Integer]: TJvLinkedControl read GetItems write SetItems; default;\r\n property OnChange: TNotifyEvent read FOnChange write FOnChange;\r\n published\r\n property RestoreEnabled: Boolean read FRestoreEnabled write FRestoreEnabled default True;\r\n end;\r\n\r\nfunction CheckLinkControlEnabled(Enabled, Checked: Boolean; Options: TJvLinkedControlsOptions): Boolean;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvLinkedControls.pas $';\r\n Revision: '$Revision: 12556 $';\r\n Date: '$Date: 2009-10-13 20:34:42 +0200 (mar. 13 oct. 2009) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n JvResources;\r\n\r\nfunction CheckLinkControlEnabled(Enabled, Checked: Boolean; Options: TJvLinkedControlsOptions): Boolean;\r\nvar\r\n IsChecked, IsEnabled: Boolean;\r\nbegin\r\n if loInvertChecked in Options then\r\n IsChecked := not Checked\r\n else\r\n IsChecked := Checked;\r\n\r\n if loInvertEnabled in Options then\r\n IsEnabled := not Enabled\r\n else\r\n IsEnabled := Enabled;\r\n\r\n if (loLinkChecked in Options) and (loLinkEnabled in Options) then\r\n Result := IsChecked and IsEnabled\r\n else\r\n Result := ((loLinkChecked in Options) and IsChecked) or ((loLinkEnabled in Options) and IsEnabled);\r\n\r\n // Result := ((loLinkChecked in Options) and ((not Checked and (loInvertChecked in Options) or (Checked and not (loInvertChecked in Options))))) or\r\n // ((loLinkEnabled in Options) and (not Enabled and (loInvertEnabled in Options)) or (Enabled and not (loInvertEnabled in Options)));\r\nend;\r\n\r\n//=== { TJvLinkedControl } ===================================================\r\n\r\nconstructor TJvLinkedControl.Create(Collection: TCollection);\r\nbegin\r\n inherited Create(Collection);\r\n if (Collection is TJvLinkedControls) then\r\n FOwnerControl := TJvLinkedControls(Collection).FControl;\r\n FOptions := [loLinkChecked, loLinkEnabled];\r\nend;\r\n\r\ndestructor TJvLinkedControl.Destroy;\r\nbegin\r\n if (FControl <> nil) and not (csDestroying in FControl.ComponentState) and\r\n (Collection is TJvLinkedControls) and TJvLinkedControls(Collection).RestoreEnabled then\r\n FControl.Enabled := FOriginalEnabled;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvLinkedControl.Assign(Source: TPersistent);\r\nbegin\r\n if Source is TJvLinkedControl then\r\n begin\r\n if Source <> Self then\r\n begin\r\n Control := TJvLinkedControl(Source).Control;\r\n Options := TJvLinkedControl(Source).Options;\r\n Changed(False);\r\n end;\r\n end\r\n else\r\n inherited Assign(Source);\r\nend;\r\n\r\nfunction TJvLinkedControl.GetDisplayName: string;\r\nbegin\r\n if Control <> nil then\r\n Result := Control.Name\r\n else\r\n Result := inherited GetDisplayName;\r\nend;\r\n\r\nprocedure TJvLinkedControl.SetControl(const Value: TControl);\r\nbegin\r\n if FControl <> Value then\r\n begin\r\n if (FOwnerControl = nil) and (Collection is TJvLinkedControls) then\r\n FOwnerControl := TJvLinkedControls(Collection).FControl;\r\n if (Value = FOwnerControl) and (FOwnerControl <> nil) then\r\n raise Exception.CreateRes(@RsEOwnerLinkError);\r\n if Assigned(FControl) then\r\n begin\r\n if Assigned(FOwnerControl) then\r\n FControl.RemoveFreeNotification(FOwnerControl);\r\n if (Collection is TJvLinkedControls) and TJvLinkedControls(Collection).RestoreEnabled and\r\n not (csDestroying in FControl.ComponentState) then\r\n FControl.Enabled := FOriginalEnabled;\r\n end;\r\n if (FOwnerControl <> nil) and (csDestroying in FOwnerControl.ComponentState) then\r\n FControl := nil\r\n else\r\n FControl := Value;\r\n if Assigned(FControl) then\r\n begin\r\n FOriginalEnabled := FControl.Enabled;\r\n if Assigned(FOwnerControl) then\r\n FControl.FreeNotification(FOwnerControl);\r\n end;\r\n Changed(False);\r\n end;\r\nend;\r\n\r\nprocedure TJvLinkedControl.SetOptions(const Value: TJvLinkedControlsOptions);\r\nbegin\r\n if FOptions <> Value then\r\n begin\r\n FOptions := Value;\r\n Changed(False);\r\n end;\r\nend;\r\n\r\n//=== { TJvLinkedControls } ==================================================\r\n\r\nconstructor TJvLinkedControls.Create(AControl: TControl);\r\nbegin\r\n inherited Create(AControl, TJvLinkedControl);\r\n FControl := AControl;\r\n FRestoreEnabled := True;\r\nend;\r\n\r\nfunction TJvLinkedControls.Add: TJvLinkedControl;\r\nbegin\r\n Result := TJvLinkedControl(inherited Add);\r\n Result.FOwnerControl := FControl;\r\nend;\r\n\r\nprocedure TJvLinkedControls.Assign(Source: TPersistent);\r\nvar\r\n I: Integer;\r\nbegin\r\n if Source is TJvLinkedControls then\r\n begin\r\n if Source <> Self then\r\n begin\r\n BeginUpdate;\r\n try\r\n Clear;\r\n for I := 0 to TJvLinkedControls(Source).Count - 1 do\r\n Add.Assign(TJvLinkedControls(Source)[I]);\r\n RestoreEnabled := TJvLinkedControls(Source).RestoreEnabled;\r\n finally\r\n EndUpdate;\r\n end;\r\n end;\r\n end\r\n else\r\n inherited Assign(Source);\r\nend;\r\n\r\nfunction TJvLinkedControls.GetItems(Index: Integer): TJvLinkedControl;\r\nbegin\r\n Result := TJvLinkedControl(inherited Items[Index]);\r\nend;\r\n\r\nprocedure TJvLinkedControls.Notification(AComponent: TComponent; Operation: TOperation);\r\nvar\r\n I: Integer;\r\nbegin\r\n if (Operation = opRemove) and (AComponent is TControl) then\r\n begin\r\n BeginUpdate;\r\n try\r\n for I := 0 to Count - 1 do\r\n if Items[I].Control = AComponent then\r\n Items[I].Control := nil;\r\n finally\r\n EndUpdate;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvLinkedControls.SetItems(Index: Integer; const Value: TJvLinkedControl);\r\nbegin\r\n inherited Items[Index] := Value;\r\nend;\r\n\r\nprocedure TJvLinkedControls.Update(Item: TCollectionItem);\r\nbegin\r\n inherited Update(Item);\r\n if Item <> nil then\r\n TJvLinkedControl(Item).FOwnerControl := FControl;\r\n if Assigned(FOnChange) then\r\n FOnChange(Self);\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvListBox.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvListbox2.PAS, released on 2001-02-28.\r\n\r\nThe Initial Developer of the Original Code is Sbastien Buysse [sbuysse att buypin dott com]\r\nPortions created by Sbastien Buysse are Copyright (C) 2001 Sbastien Buysse.\r\nAll Rights Reserved.\r\n\r\nThis unit is a merging of the original TJvListBox, JvListBox2, TJvExListBox.\r\nMerging done 2002-06-15 by Peter Thornqvist [peter3 at sourceforge dot net]\r\n\r\nContributor(s):\r\nMichael Beck [mbeck att bigfoot dott com].\r\nPetr Vones (petr dott v att mujmail dott cz)\r\nPeter Below <100113 dott 1101 att compuserve dott com>\r\n\r\nMERGE NOTES:\r\n * The Alignment property might mess things up depending on other property settings\r\n * not very extensively tested\r\n * TJvListBox in JvCtrls inherits from TJvCustomListbox in this unit.\r\n Maybe TJvListBox should be moved here instead (or this code into JvCtrls)?\r\n * TJvPlaylist now inherits from JvListBox\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\nKnown Issues:\r\n\r\nMerge notes (2002-03-21):\r\n* (p3) merged JvMultilineListBox, JvReorderListBox, JvTextListBox, JvBMPListBox\r\nNotes (2003-05-21) // Remko Bonte\r\n* Removed OwnerData\r\n* Some bug-fixes. Combinations of Multiline, Alignment, Scrollbars seem to work now.\r\n* Did some rewrite of background-drawing. Most of it seems to work, but a lot\r\n of flickering, best avoid it or set ScrollBars to ssNone.\r\n* Updated drag image to use with MultiLine.\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvListBox.pas 13415 2012-09-10 09:51:54Z obones $\r\n\r\nunit JvListBox;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, Messages, SysUtils, Classes, Graphics, StdCtrls, Controls, Forms,\r\n {$IFDEF HAS_UNIT_SYSTEM_UITYPES}\r\n System.UITypes,\r\n {$ENDIF HAS_UNIT_SYSTEM_UITYPES}\r\n JvItemsSearchs, JvDataProvider, JvDataProviderIntf, JvExStdCtrls;\r\n\r\ntype\r\n TJvListboxFillMode = (bfmTile, bfmStretch);\r\n TJvListBoxDataEvent = procedure(Sender: TWinControl; Index: Integer; var Text: string) of object;\r\n TJvListboxChange = procedure(Sender: TObject; Item: string) of object;\r\n TJvScrollEvent = procedure(Sender: TObject; const Msg: TWMScroll; var DontScroll: Boolean) of object;\r\n\r\n TJvListBoxBackground = class(TPersistent)\r\n private\r\n FOnChange: TNotifyEvent;\r\n FImage: TBitmap;\r\n FFillMode: TJvListboxFillMode;\r\n FVisible: Boolean;\r\n procedure SetFillMode(const Value: TJvListboxFillMode);\r\n procedure SetImage(const Value: TBitmap);\r\n procedure SetVisible(const Value: Boolean);\r\n function GetDoDraw: Boolean;\r\n protected\r\n procedure Change;\r\n public\r\n constructor Create;\r\n destructor Destroy; override;\r\n procedure Assign(Source: TPersistent); override;\r\n published\r\n property DoDraw: Boolean read GetDoDraw;\r\n property Image: TBitmap read FImage write SetImage;\r\n property FillMode: TJvListboxFillMode read FFillMode write SetFillMode;\r\n property Visible: Boolean read FVisible write SetVisible;\r\n property OnChange: TNotifyEvent read FOnChange write FOnChange;\r\n end;\r\n\r\n TJvCustomListBox = class;\r\n\r\n { This class will be used for the Items property of the list box.\r\n\r\n If a provider is active at the list box, this list will keep the strings stored in an internal\r\n list.\r\n\r\n Whenever an item is added to the list the provider will be deactivated and the list will be\r\n handled by the list box as usual. }\r\n TJvListBoxStrings = class(TStrings)\r\n private\r\n FListBox: TJvCustomListBox;\r\n FInternalList: TStringList;\r\n FUseInternal: Boolean;\r\n FUpdating: Boolean;\r\n FDestroyCnt: Integer;\r\n function GetInternalList: TStrings;\r\n protected\r\n function Get(Index: Integer): string; override;\r\n function GetCount: Integer; override;\r\n function GetObject(Index: Integer): TObject; override;\r\n procedure Put(Index: Integer; const S: string); override;\r\n procedure PutObject(Index: Integer; AObject: TObject); override;\r\n procedure SetUpdateState(Updating: Boolean); override;\r\n procedure SetWndDestroying(Destroying: Boolean);\r\n function GetListBox: TJvCustomListBox;\r\n procedure SetListBox(Value: TJvCustomListBox);\r\n property ListBox: TJvCustomListBox read GetListBox write SetListBox;\r\n property InternalList: TStrings read GetInternalList;\r\n property UseInternal: Boolean read FUseInternal write FUseInternal;\r\n property Updating: Boolean read FUpdating;\r\n property DestroyCount: Integer read FDestroyCnt;\r\n public\r\n constructor Create; virtual;\r\n destructor Destroy; override;\r\n function Add(const S: string): Integer; override;\r\n procedure Clear; override;\r\n procedure Delete(Index: Integer); override;\r\n function IndexOf(const S: string): Integer; override;\r\n procedure Insert(Index: Integer; const S: string); override;\r\n procedure Move(CurIndex, NewIndex: Integer); override;\r\n procedure MakeListInternal; virtual;\r\n procedure ActivateInternal; virtual;\r\n end;\r\n TJvListBoxStringsClass = class of TJvListBoxStrings;\r\n\r\n TJvCustomListBox = class(TJvExCustomListBox)\r\n private\r\n FHotTrack: Boolean;\r\n FAlignment: TAlignment;\r\n FMaxWidth: Integer;\r\n FScrollBars: TScrollStyle;\r\n FSorted: Boolean;\r\n FOnGetText: TJvListBoxDataEvent;\r\n FOnSelectCancel: TNotifyEvent;\r\n FOnDeleteString: TJvListboxChange;\r\n FOnAddString: TJvListboxChange;\r\n FOnChange: TNotifyEvent;\r\n FOnHorizontalScroll: TJvScrollEvent;\r\n FOnVerticalScroll: TJvScrollEvent;\r\n FDragIndex: Integer;\r\n FDragImage: TDragImageList;\r\n FMultiline: Boolean;\r\n FShowFocusRect: Boolean;\r\n FSelectedTextColor: TColor;\r\n FSelectedColor: TColor;\r\n FDisabledTextColor: TColor;\r\n FBackground: TJvListBoxBackground;\r\n FLeftPosition: Integer;\r\n\r\n FConsumerSvc: TJvDataConsumer;\r\n FConsumerStrings: TJvConsumerStrings;\r\n FProviderIsActive: Boolean;\r\n FProviderToggle: Boolean;\r\n FMoving: Boolean;\r\n\r\n procedure WMVScroll(var Msg: TWMVScroll); message WM_VSCROLL;\r\n procedure WMHScroll(var Msg: TWMHScroll); message WM_HSCROLL;\r\n procedure CNKeyDown(var Msg: TWMKeyDown); message CN_KEYDOWN;\r\n\r\n procedure DrawBackGround(ADC: HDC; const DoOffSet: Boolean);\r\n procedure UpdateStyle;\r\n\r\n { Handle messages that insert or delete strings from the listbox to\r\n manage the horizontal scrollbar if FMutliline is false. }\r\n procedure LBAddString(var Msg: TMessage); message LB_ADDSTRING;\r\n procedure LBInsertString(var Msg: TMessage); message LB_INSERTSTRING;\r\n procedure LBDeleteString(var Msg: TMessage); message LB_DELETESTRING;\r\n { Override CN_DRAWITEM handling to be able to switch off focus rect. }\r\n procedure CNDrawItem(var Msg: TWMDrawItem); message CN_DRAWITEM;\r\n procedure SetAlignment(const Value: TAlignment);\r\n procedure SetMultiline(const Value: Boolean);\r\n procedure SetSelectedColor(const Value: TColor);\r\n procedure SetSelectedTextColor(const Value: TColor);\r\n procedure SetShowFocusRect(const Value: Boolean);\r\n procedure SetDisabledTextColor(const Value: TColor);\r\n procedure SetMaxWidth(const Value: Integer);\r\n procedure SetScrollBars(const Value: TScrollStyle);\r\n procedure SetSorted(const Value: Boolean);\r\n procedure SetHotTrack(const Value: Boolean);\r\n procedure SetBackground(const Value: TJvListBoxBackground);\r\n function GetLimitToClientWidth: Boolean;\r\n function GetFlat: Boolean;\r\n procedure SetFlat(const Value: Boolean);\r\n function GetParentFlat: Boolean;\r\n procedure SetParentFlat(const Value: Boolean);\r\n protected\r\n procedure FontChanged; override;\r\n function GetItemsClass: TJvListBoxStringsClass; virtual;\r\n procedure BeginRedraw;\r\n procedure EndRedraw;\r\n\r\n procedure SetConsumerService(Value: TJvDataConsumer);\r\n procedure ConsumerServiceChanging(Sender: TJvDataConsumer; Reason: TJvDataConsumerChangeReason);\r\n procedure ConsumerServiceChanged(Sender: TJvDataConsumer; Reason: TJvDataConsumerChangeReason);\r\n procedure ConsumerSubServiceCreated(Sender: TJvDataConsumer;\r\n SubSvc: TJvDataConsumerAggregatedObject);\r\n function IsProviderSelected: Boolean;\r\n function IsProviderToggle: Boolean;\r\n procedure DeselectProvider;\r\n procedure UpdateItemCount;\r\n property Provider: TJvDataConsumer read FConsumerSvc write SetConsumerService;\r\n property ConsumerStrings: TJvConsumerStrings read FConsumerStrings;\r\n procedure LBFindString(var Msg: TMessage); message LB_FINDSTRING;\r\n procedure LBFindStringExact(var Msg: TMessage); message LB_FINDSTRINGEXACT;\r\n procedure LBSelectString(var Msg: TMessage); message LB_SELECTSTRING;\r\n procedure LBGetText(var Msg: TMessage); message LB_GETTEXT;\r\n procedure LBGetTextLen(var Msg: TMessage); message LB_GETTEXTLEN;\r\n\r\n procedure DoStartDrag(var DragObject: TDragObject); override;\r\n procedure DragOver(Source: TObject; X, Y: Integer; State: TDragState;\r\n var Accept: Boolean); override;\r\n function DoEraseBackground(Canvas: TCanvas; Param: LPARAM): Boolean; override;\r\n procedure MouseEnter(Control: TControl); override;\r\n procedure MouseLeave(Control: TControl); override;\r\n procedure SelectCancel(var Msg: TMessage); message LBN_SELCANCEL;\r\n procedure Changed; virtual;\r\n procedure DrawItem(Index: Integer; Rect: TRect;\r\n State: TOwnerDrawState); override;\r\n procedure MeasureItem(Index: Integer; var Height: Integer); override;\r\n procedure RemeasureAll;\r\n procedure DoBackgroundChange(Sender: TObject);\r\n\r\n procedure Loaded; override;\r\n procedure DrawProviderItem(Canvas: TCanvas; Rect: TRect; Index: Integer;\r\n State: TOwnerDrawState);\r\n procedure DoGetText(Index: Integer; var AText: string); virtual;\r\n\r\n property LimitToClientWidth: Boolean read GetLimitToClientWidth;\r\n property MaxWidth: Integer read FMaxWidth write SetMaxWidth;\r\n property ScrollBars: TScrollStyle read FScrollBars write SetScrollBars default ssBoth;\r\n property Sorted: Boolean read FSorted write SetSorted default False;\r\n property OnGetText: TJvListBoxDataEvent read FOnGetText write FOnGetText;\r\n property Alignment: TAlignment read FAlignment write SetAlignment\r\n default taLeftJustify;\r\n property HotTrack: Boolean read FHotTrack write SetHotTrack default False;\r\n property OnSelectCancel: TNotifyEvent read FOnSelectCancel write FOnSelectCancel;\r\n property OnChange: TNotifyEvent read FOnChange write FOnChange;\r\n property OnDeleteString: TJvListboxChange read FOnDeleteString write FOnDeleteString;\r\n property OnAddString: TJvListboxChange read FOnAddString write FOnAddString;\r\n property OnVerticalScroll: TJvScrollEvent read FOnVerticalScroll write FOnVerticalScroll;\r\n property OnHorizontalScroll: TJvScrollEvent read FOnHorizontalScroll write FOnHorizontalScroll;\r\n property Moving: Boolean read FMoving write FMoving;\r\n\r\n property DragIndex: Integer read FDragIndex;\r\n property DragImages: TDragImageList read GetDragImages;\r\n procedure WndProc(var Msg: TMessage); override;\r\n procedure CreateParams(var Params: TCreateParams); override;\r\n procedure CreateWnd; override;\r\n procedure DestroyWnd; override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n function ItemRect(Index: Integer): TRect;\r\n function ItemsShowing: TStrings; virtual;\r\n\r\n procedure MeasureProviderItem(Index, WidthAvail: Integer; var ASize: TSize);\r\n procedure MeasureString(const S: string; WidthAvail: Integer; var ASize: TSize);\r\n\r\n procedure DefaultDrawItem(Index: Integer; ARect: TRect;\r\n State: TOwnerDrawState); virtual;\r\n procedure DefaultDragOver(Source: TObject; X, Y: Integer; State: TDragState;\r\n var Accept: Boolean); virtual;\r\n procedure DefaultStartDrag(var DragObject: TDragObject); virtual;\r\n procedure DefaultDragDrop(Source: TObject; X, Y: Integer); virtual;\r\n procedure CreateDragImage(const S: string);\r\n procedure UpdateHorizontalExtent;\r\n function SearchExactString(const Value: string; CaseSensitive: Boolean = True;\r\n StartIndex: Integer = -1): Integer;\r\n function SearchPrefix(const Value: string; CaseSensitive: Boolean = True;\r\n StartIndex: Integer = -1): Integer;\r\n function SearchSubString(const Value: string; CaseSensitive: Boolean = True;\r\n StartIndex: Integer = -1): Integer;\r\n function DeleteExactString(const Value: string; All: Boolean;\r\n CaseSensitive: Boolean = True): Integer;\r\n procedure DragDrop(Source: TObject; X, Y: Integer); override;\r\n function GetDragImages: TDragImageList; override;\r\n procedure SelectAll; override;\r\n procedure UnselectAll;\r\n procedure InvertSelection;\r\n procedure MoveSelectedUp; virtual;\r\n procedure MoveSelectedDown; virtual;\r\n procedure DeleteSelected; override;\r\n procedure DeleteAllButSelected;\r\n procedure SetBounds(ALeft, ATop, AWidth, AHeight: Integer); override;\r\n protected\r\n property MultiLine: Boolean read FMultiline write SetMultiline default False;\r\n property SelectedColor: TColor read FSelectedColor write SetSelectedColor default clHighlight;\r\n property SelectedTextColor: TColor read FSelectedTextColor write SetSelectedTextColor default clHighlightText;\r\n property DisabledTextColor: TColor read FDisabledTextColor write SetDisabledTextColor default clGrayText;\r\n property ShowFocusRect: Boolean read FShowFocusRect write SetShowFocusRect default True;\r\n property Background: TJvListBoxBackground read FBackground write SetBackground;\r\n property Flat: Boolean read GetFlat write SetFlat default False;\r\n property ParentFlat: Boolean read GetParentFlat write SetParentFlat default True;\r\n end;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvListBox = class(TJvCustomListBox)\r\n public\r\n property Count;\r\n published\r\n property Align;\r\n property Anchors;\r\n property BiDiMode;\r\n property BorderStyle;\r\n property Color;\r\n property Columns;\r\n property Constraints;\r\n property DragCursor;\r\n property DragKind;\r\n property DragMode;\r\n property Enabled;\r\n property ExtendedSelect;\r\n property Font;\r\n property ImeMode;\r\n property ImeName;\r\n property IntegralHeight;\r\n property ItemHeight;\r\n property Items;\r\n\r\n property MultiLine;\r\n property SelectedColor;\r\n property SelectedTextColor;\r\n property DisabledTextColor;\r\n property ShowFocusRect;\r\n property Background;\r\n property Flat;\r\n property ParentFlat;\r\n\r\n property MultiSelect;\r\n property ParentBiDiMode;\r\n property ParentColor;\r\n property ParentFont;\r\n property ParentShowHint;\r\n property PopupMenu;\r\n property Provider;\r\n property ScrollBars;\r\n property ShowHint;\r\n property Sorted;\r\n property Style;\r\n property TabOrder;\r\n property TabStop;\r\n property TabWidth;\r\n property Visible;\r\n property OnClick;\r\n property OnContextPopup;\r\n property OnDblClick;\r\n property OnDragDrop;\r\n property OnDragOver;\r\n property OnDrawItem;\r\n property OnEndDock;\r\n property OnEndDrag;\r\n property OnEnter;\r\n property OnExit;\r\n property OnGetText;\r\n property OnKeyDown;\r\n property OnKeyPress;\r\n property OnKeyUp;\r\n property OnMeasureItem;\r\n property OnMouseDown;\r\n property OnMouseMove;\r\n property OnMouseUp;\r\n property OnStartDock;\r\n property OnStartDrag;\r\n property Alignment;\r\n property HotTrack;\r\n property HintColor;\r\n\r\n property OnMouseEnter;\r\n property OnMouseLeave;\r\n property OnParentColorChange;\r\n property OnSelectCancel;\r\n property OnChange;\r\n property OnDeleteString;\r\n property OnAddString;\r\n property OnVerticalScroll;\r\n property OnHorizontalScroll;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvListBox.pas $';\r\n Revision: '$Revision: 13415 $';\r\n Date: '$Date: 2012-09-10 11:51:54 +0200 (lun. 10 sept. 2012) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n Consts,\r\n {$IFDEF COMPILER10_UP}\r\n Types,\r\n {$ENDIF COMPILER10_UP}\r\n RTLConsts,\r\n JvJCLUtils, JvJVCLUtils, JvConsts, JvResources;\r\n\r\nconst\r\n AlignFlags: array [TAlignment] of DWORD = (DT_LEFT, DT_RIGHT, DT_CENTER);\r\n\r\ntype\r\n PStrings = ^TStrings;\r\n\r\n//=== { TJvListBoxStrings } ==================================================\r\n\r\nconstructor TJvListBoxStrings.Create;\r\nbegin\r\n inherited Create;\r\n FInternalList := TStringList.Create;\r\nend;\r\n\r\ndestructor TJvListBoxStrings.Destroy;\r\nbegin\r\n FreeAndNil(FInternalList);\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJvListBoxStrings.Get(Index: Integer): string;\r\nvar\r\n Len: Integer;\r\nbegin\r\n if UseInternal then\r\n Result := InternalList[Index]\r\n else\r\n if ListBox.Style in [lbVirtual, lbVirtualOwnerDraw] then\r\n Result := ListBox.DoGetData(Index)\r\n else\r\n begin\r\n Len := SendMessage(ListBox.Handle, LB_GETTEXTLEN, Index, 0);\r\n if Len = LB_ERR then\r\n Error(SListIndexError, Index);\r\n SetLength(Result, Len);\r\n if Len <> 0 then\r\n begin\r\n Len := SendMessage(ListBox.Handle, LB_GETTEXT, Index, LPARAM(PChar(Result)));\r\n SetLength(Result, Len);\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJvListBoxStrings.GetCount: Integer;\r\nbegin\r\n if (DestroyCount > 0) and UseInternal then\r\n Result := 0\r\n else\r\n begin\r\n if UseInternal then\r\n Result := InternalList.Count\r\n else\r\n Result := SendMessage(ListBox.Handle, LB_GETCOUNT, 0, 0);\r\n end;\r\nend;\r\n\r\nfunction TJvListBoxStrings.GetObject(Index: Integer): TObject;\r\nbegin\r\n if UseInternal then\r\n Result := InternalList.Objects[Index]\r\n else\r\n if ListBox.Style in [lbVirtual, lbVirtualOwnerDraw] then\r\n Result := ListBox.DoGetDataObject(Index)\r\n else\r\n begin\r\n Result := TObject(ListBox.GetItemData(Index));\r\n if LPARAM(Result) = LPARAM(LB_ERR) then\r\n Error(SListIndexError, Index);\r\n end;\r\nend;\r\n\r\nprocedure TJvListBoxStrings.Put(Index: Integer; const S: string);\r\nvar\r\n I: Integer;\r\n TempData: Longint;\r\nbegin\r\n if UseInternal then\r\n InternalList[Index] := S\r\n else\r\n begin\r\n ListBox.DeselectProvider;\r\n I := ListBox.ItemIndex;\r\n TempData := ListBox.InternalGetItemData(Index);\r\n // Set the Item to 0 in case it is an object that gets freed during Delete\r\n ListBox.InternalSetItemData(Index, 0);\r\n Delete(Index);\r\n InsertObject(Index, S, nil);\r\n ListBox.InternalSetItemData(Index, TempData);\r\n ListBox.ItemIndex := I;\r\n end;\r\nend;\r\n\r\nprocedure TJvListBoxStrings.PutObject(Index: Integer; AObject: TObject);\r\nbegin\r\n if UseInternal then\r\n InternalList.Objects[Index] := AObject\r\n else\r\n begin\r\n if (Index <> -1) and not (ListBox.Style in [lbVirtual, lbVirtualOwnerDraw]) then\r\n begin\r\n ListBox.DeselectProvider;\r\n ListBox.SetItemData(Index, LPARAM(AObject));\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvListBoxStrings.SetUpdateState(Updating: Boolean);\r\nbegin\r\n FUpdating := Updating;\r\n if ListBox.HandleAllocated then\r\n begin\r\n SendMessage(ListBox.Handle, WM_SETREDRAW, Ord(not Updating), 0);\r\n if not Updating then\r\n ListBox.Refresh;\r\n end;\r\nend;\r\n\r\nprocedure TJvListBoxStrings.SetWndDestroying(Destroying: Boolean);\r\nbegin\r\n if Destroying then\r\n Inc(FDestroyCnt)\r\n else\r\n if FDestroyCnt > 0 then\r\n Dec(FDestroyCnt);\r\nend;\r\n\r\nfunction TJvListBoxStrings.GetListBox: TJvCustomListBox;\r\nbegin\r\n Result := FListBox;\r\nend;\r\n\r\nprocedure TJvListBoxStrings.SetListBox(Value: TJvCustomListBox);\r\nbegin\r\n FListBox := Value;\r\nend;\r\n\r\nfunction TJvListBoxStrings.GetInternalList: TStrings;\r\nbegin\r\n Result := FInternalList;\r\nend;\r\n\r\nfunction TJvListBoxStrings.Add(const S: string): Integer;\r\nbegin\r\n if (csLoading in ListBox.ComponentState) and UseInternal then\r\n Result := InternalList.Add(S)\r\n else\r\n begin\r\n Result := -1;\r\n if ListBox.Style in [lbVirtual, lbVirtualOwnerDraw] then\r\n Exit;\r\n ListBox.DeselectProvider;\r\n Result := SendMessage(ListBox.Handle, LB_ADDSTRING, 0, LPARAM(PChar(S)));\r\n if Result < 0 then\r\n raise EOutOfResources.CreateRes(@SInsertLineError);\r\n end;\r\nend;\r\n\r\nprocedure TJvListBoxStrings.Clear;\r\nbegin\r\n if (FDestroyCnt <> 0) and UseInternal then\r\n Exit;\r\n if (csLoading in ListBox.ComponentState) and UseInternal then\r\n InternalList.Clear\r\n else\r\n begin\r\n ListBox.DeselectProvider;\r\n ListBox.ResetContent;\r\n end;\r\nend;\r\n\r\nprocedure TJvListBoxStrings.Delete(Index: Integer);\r\nbegin\r\n if (csLoading in ListBox.ComponentState) and UseInternal then\r\n InternalList.Delete(Index)\r\n else\r\n begin\r\n ListBox.DeselectProvider;\r\n ListBox.DeleteString(Index);\r\n end;\r\nend;\r\n\r\nfunction TJvListBoxStrings.IndexOf(const S: string): Integer;\r\nbegin\r\n if UseInternal then\r\n Result := InternalList.IndexOf(S)\r\n else\r\n if ListBox.Style in [lbVirtual, lbVirtualOwnerDraw] then\r\n Result := ListBox.DoFindData(S)\r\n else\r\n Result := SendMessage(ListBox.Handle, LB_FINDSTRINGEXACT, -1, LPARAM(PChar(S)));\r\nend;\r\n\r\nprocedure TJvListBoxStrings.Insert(Index: Integer; const S: string);\r\nbegin\r\n if (csLoading in ListBox.ComponentState) and UseInternal then\r\n InternalList.Insert(Index, S)\r\n else\r\n begin\r\n ListBox.DeselectProvider;\r\n if ListBox.Style in [lbVirtual, lbVirtualOwnerDraw] then\r\n Exit;\r\n if SendMessage(ListBox.Handle, LB_INSERTSTRING, Index, LPARAM(PChar(S))) < 0 then\r\n raise EOutOfResources.CreateRes(@SInsertLineError);\r\n end;\r\nend;\r\n\r\nprocedure TJvListBoxStrings.Move(CurIndex, NewIndex: Integer);\r\nvar\r\n TempString: string;\r\n TempData: Longint;\r\nbegin\r\n if (csLoading in ListBox.ComponentState) and UseInternal then\r\n InternalList.Move(CurIndex, NewIndex)\r\n else\r\n begin\r\n if ListBox.Style in [lbVirtual, lbVirtualOwnerDraw] then\r\n Exit;\r\n BeginUpdate;\r\n ListBox.Moving := True;\r\n try\r\n if CurIndex <> NewIndex then\r\n begin\r\n TempString := Get(CurIndex);\r\n TempData := ListBox.InternalGetItemData(CurIndex);\r\n ListBox.InternalSetItemData(CurIndex, 0);\r\n Delete(CurIndex);\r\n Insert(NewIndex, TempString);\r\n ListBox.InternalSetItemData(NewIndex, TempData);\r\n end;\r\n finally\r\n ListBox.Moving := False;\r\n EndUpdate;\r\n end;\r\n end;\r\nend;\r\n\r\n{ Copies the strings at the list box to the FInternalList. To minimize the memory usage when a\r\n large list is used, each item copied is immediately removed from the list box list. }\r\nprocedure TJvListBoxStrings.MakeListInternal;\r\nvar\r\n Cnt: Integer;\r\n Text: array [0..4095] of Char;\r\n Len: Integer;\r\n S: string;\r\n Obj: TObject;\r\nbegin\r\n if ListBox.HandleAllocated then\r\n SendMessage(ListBox.Handle, WM_SETREDRAW, Ord(False), 0);\r\n try\r\n InternalList.Clear;\r\n if ListBox.HandleAllocated then\r\n Cnt := SendMessage(ListBox.Handle, LB_GETCOUNT, 0, 0)\r\n else\r\n Cnt := 0;\r\n while Cnt > 0 do\r\n begin\r\n Len := SendMessage(ListBox.Handle, LB_GETTEXT, 0, LPARAM(@Text));\r\n SetString(S, Text, Len);\r\n Obj := TObject(SendMessage(ListBox.Handle, LB_GETITEMDATA, 0, 0));\r\n SendMessage(ListBox.Handle, LB_DELETESTRING, 0, 0);\r\n InternalList.AddObject(S, Obj);\r\n Dec(Cnt);\r\n end;\r\n finally\r\n UseInternal := True;\r\n if not Updating and ListBox.HandleAllocated then\r\n SendMessage(ListBox.Handle, WM_SETREDRAW, Ord(True), 0);\r\n end;\r\nend;\r\n\r\nprocedure TJvListBoxStrings.ActivateInternal;\r\nvar\r\n S: string;\r\n Obj: TObject;\r\n Index: Integer;\r\nbegin\r\n SendMessage(ListBox.Handle, WM_SETREDRAW, Ord(False), 0);\r\n try\r\n InternalList.BeginUpdate;\r\n try\r\n SendMessage(ListBox.Handle, LB_RESETCONTENT, 0, 0);\r\n while InternalList.Count > 0 do\r\n begin\r\n S := InternalList[0];\r\n Obj := InternalList.Objects[0];\r\n Index := SendMessage(ListBox.Handle, LB_ADDSTRING, 0, LPARAM(PChar(S)));\r\n if Index < 0 then\r\n raise EOutOfResources.CreateRes(@SInsertLineError);\r\n SendMessage(ListBox.Handle, LB_SETITEMDATA, Index, LPARAM(Obj));\r\n InternalList.Delete(0);\r\n end;\r\n finally\r\n InternalList.EndUpdate;\r\n end;\r\n finally\r\n if not Updating then\r\n SendMessage(ListBox.Handle, WM_SETREDRAW, Ord(True), 0);\r\n UseInternal := False;\r\n end;\r\nend;\r\n\r\n//=== { TJvCustomListBox } ===================================================\r\n\r\nconstructor TJvCustomListBox.Create(AOwner: TComponent);\r\nvar\r\n PStringsAddr: PStrings;\r\nbegin\r\n inherited Create(AOwner);\r\n // JvBMPListBox:\r\n // Style := lbOwnerDrawFixed;\r\n\r\n FConsumerSvc := TJvDataConsumer.Create(Self, [DPA_RenderDisabledAsGrayed,\r\n DPA_ConsumerDisplaysList]);\r\n FConsumerSvc.OnChanging := ConsumerServiceChanging;\r\n FConsumerSvc.OnChanged := ConsumerServiceChanged;\r\n FConsumerSvc.AfterCreateSubSvc := ConsumerSubServiceCreated;\r\n FConsumerStrings := TJvConsumerStrings.Create(FConsumerSvc);\r\n { The following hack assumes that TJvListBox.Items reads directly from the private FItems field\r\n of TCustomListBox.\r\n\r\n What we do here is remove the original string list used and place our own version in it's place.\r\n This would give us the benefit of keeping the list of strings (and objects) even if a provider\r\n is active and the list box windows has no strings at all. }\r\n PStringsAddr := @Self.Items;\r\n Items.Free; // remove original item list (TListBoxStrings instance)\r\n PStringsAddr^ := GetItemsClass.Create; // create our own implementation and put it in place.\r\n TJvListBoxStrings(Items).ListBox := Self; // link it to the list box.\r\n\r\n FBackground := TJvListBoxBackground.Create;\r\n FBackground.OnChange := DoBackgroundChange;\r\n FScrollBars := ssBoth;\r\n FAlignment := taLeftJustify;\r\n FMultiline := False;\r\n FSelectedColor := clHighlight;\r\n FSelectedTextColor := clHighlightText;\r\n FDisabledTextColor := clGrayText;\r\n FShowFocusRect := True;\r\n // Style := lbOwnerDrawVariable;\r\n\r\n FMaxWidth := 0;\r\n FHotTrack := False;\r\n // ControlStyle := ControlStyle + [csAcceptsControls];\r\nend;\r\n\r\ndestructor TJvCustomListBox.Destroy;\r\nbegin\r\n FreeAndNil(FBackground);\r\n FreeAndNil(FConsumerStrings);\r\n FreeAndNil(FConsumerSvc);\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJvCustomListBox.GetItemsClass: TJvListBoxStringsClass;\r\nbegin\r\n Result := TJvListBoxStrings;\r\nend;\r\n\r\nprocedure TJvCustomListBox.BeginRedraw;\r\nbegin\r\n SendMessage(Handle, WM_SETREDRAW, Ord(False), 0);\r\nend;\r\n\r\nprocedure TJvCustomListBox.Changed;\r\nbegin\r\n // (rom) TODO?\r\n inherited Changed; // (marcelb): I added this, 'caus I assume it needs to be called.\r\nend;\r\n\r\nprocedure TJvCustomListBox.FontChanged;\r\nconst\r\n CShowFocusRect: array [Boolean] of Integer = (0, 2);\r\nbegin\r\n inherited FontChanged;\r\n Canvas.Font := Font;\r\n if [Style] * [lbStandard, lbOwnerDrawFixed] = [] then\r\n ItemHeight := CanvasMaxTextHeight(Canvas) + CShowFocusRect[ShowFocusRect];\r\n RemeasureAll;\r\nend;\r\n\r\nprocedure TJvCustomListBox.MouseEnter(Control: TControl);\r\nbegin\r\n if csDesigning in ComponentState then\r\n Exit;\r\n if not MouseOver then\r\n begin\r\n if FHotTrack then\r\n Ctl3D := True;\r\n inherited MouseEnter(Control);\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomListBox.MouseLeave(Control: TControl);\r\nbegin\r\n if MouseOver then\r\n begin\r\n if FHotTrack then\r\n Ctl3D := False;\r\n inherited MouseLeave(Control);\r\n end;\r\nend;\r\n\r\n{ This routine is copied mostly from TCustomListbox.CNDrawItem.\r\n The setting of colors is modified.\r\n Drawing of the focus rectangle is delegated to DrawItem.}\r\n\r\nprocedure TJvCustomListBox.CNDrawItem(var Msg: TWMDrawItem);\r\nvar\r\n State: TOwnerDrawState;\r\nbegin\r\n with Msg.DrawItemStruct^ do\r\n begin\r\n State := TOwnerDrawState(Word(itemState and $FFFF));\r\n Canvas.Handle := hDC;\r\n Canvas.Font := Font;\r\n Canvas.Brush := Brush;\r\n if Integer(itemID) >= 0 then\r\n begin\r\n if odSelected in State then\r\n begin\r\n Canvas.Brush.Color := FSelectedColor;\r\n Canvas.Font.Color := FSelectedTextColor;\r\n end;\r\n if (([odDisabled, odGrayed] * State) <> []) or not Enabled then\r\n Canvas.Font.Color := FDisabledTextColor;\r\n end;\r\n if Integer(itemID) >= 0 then\r\n DrawItem(itemID, rcItem, State)\r\n else\r\n begin\r\n if Background.DoDraw then\r\n begin\r\n Perform(WM_ERASEBKGND, WPARAM(Canvas.Handle), 0);\r\n if odFocused in State then\r\n DrawFocusRect(hDC, rcItem);\r\n end\r\n else\r\n begin\r\n Canvas.FillRect(rcItem);\r\n if odFocused in State then\r\n DrawFocusRect(hDC, rcItem);\r\n end;\r\n end;\r\n Canvas.Handle := 0;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomListBox.CNKeyDown(var Msg: TWMKeyDown);\r\nbegin\r\n if Background.DoDraw and (Msg.Result = 0) and\r\n (Msg.CharCode in [VK_LEFT, VK_RIGHT, VK_UP, VK_DOWN]) then\r\n begin\r\n BeginRedraw;\r\n try\r\n inherited;\r\n finally\r\n EndRedraw;\r\n end;\r\n end\r\n else\r\n inherited;\r\nend;\r\n\r\nprocedure TJvCustomListBox.CreateDragImage(const S: string);\r\nconst\r\n CLeftMargin = 15;\r\nvar\r\n Size: TSize;\r\n Bmp: TBitmap;\r\n SizeRect: TRect;\r\nbegin\r\n if not Assigned(FDragImage) then\r\n FDragImage := TDragImageList.Create(Self)\r\n else\r\n FDragImage.Clear;\r\n Canvas.Font := Font;\r\n if MultiLine then\r\n begin\r\n SizeRect := Rect(0, 0, MaxInt, 0);\r\n DrawText(Canvas.Handle, PChar(S), -1, SizeRect, DT_CALCRECT or\r\n DrawTextBiDiModeFlags(DT_WORDBREAK or DT_NOPREFIX or AlignFlags[FAlignment]));\r\n Size.cx := SizeRect.Right;\r\n Size.cy := SizeRect.Bottom;\r\n end\r\n else\r\n Size := Canvas.TextExtent(S);\r\n Inc(Size.cx, CLeftMargin);\r\n if Size.cy = 0 then // 0 is an invalid size for a ImageList\r\n Size.cy := 1;\r\n\r\n FDragImage.Width := Size.cx;\r\n FDragImage.Height := Size.cy;\r\n Bmp := TBitmap.Create;\r\n try\r\n Bmp.Width := Size.cx;\r\n Bmp.Height := Size.cy;\r\n Bmp.Canvas.Font := Font;\r\n Bmp.Canvas.Font.Color := clBlack;\r\n Bmp.Canvas.Brush.Color := clWhite;\r\n Bmp.Canvas.Brush.Style := bsSolid;\r\n if MultiLine then\r\n begin\r\n Inc(SizeRect.Right, CLeftMargin);\r\n Bmp.Canvas.FillRect(SizeRect);\r\n Inc(SizeRect.Left, CLeftMargin);\r\n DrawText(Bmp.Canvas.Handle, PChar(S), -1, SizeRect,\r\n DrawTextBiDiModeFlags(DT_WORDBREAK or DT_NOPREFIX or AlignFlags[FAlignment]));\r\n end\r\n else\r\n Bmp.Canvas.TextOut(CLeftMargin, 0, S);\r\n FDragImage.AddMasked(Bmp, clWhite);\r\n finally\r\n Bmp.Free;\r\n end;\r\n ControlStyle := ControlStyle + [csDisplayDragImage];\r\nend;\r\n\r\nprocedure TJvCustomListBox.CreateParams(var Params: TCreateParams);\r\nconst\r\n ScrollBar: array [TScrollStyle] of DWORD =\r\n (0, WS_HSCROLL, WS_VSCROLL, WS_HSCROLL or WS_VSCROLL);\r\n Sorted: array [Boolean] of DWORD =\r\n (0, LBS_SORT);\r\nbegin\r\n inherited CreateParams(Params);\r\n with Params do\r\n begin\r\n Style := Style and not (WS_HSCROLL or WS_VSCROLL) or ScrollBar[FScrollBars] or\r\n Sorted[FSorted];\r\n end;\r\n if IsProviderSelected then\r\n begin\r\n Params.Style := Params.Style and not (LBS_SORT or LBS_HASSTRINGS or LBS_NODATA);\r\n if Params.Style and (LBS_OWNERDRAWVARIABLE or LBS_OWNERDRAWFIXED) = 0 then\r\n Params.Style := Params.Style or LBS_OWNERDRAWFIXED;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomListBox.CreateWnd;\r\nbegin\r\n if not (csLoading in ComponentState) then\r\n begin\r\n FMultiline := MultiLine and (Style = lbOwnerDrawVariable);\r\n\r\n if not (Style in [lbOwnerDrawVariable, lbOwnerDrawFixed]) then\r\n FAlignment := taLeftJustify;\r\n end;\r\n FLeftPosition := 0;\r\n inherited CreateWnd;\r\n UpdateItemCount;\r\n UpdateHorizontalExtent;\r\nend;\r\n\r\nprocedure TJvCustomListBox.DestroyWnd;\r\nbegin\r\n if IsProviderSelected then\r\n TJvListBoxStrings(Items).SetWndDestroying(True);\r\n try\r\n inherited DestroyWnd;\r\n finally\r\n if IsProviderSelected then\r\n TJvListBoxStrings(Items).SetWndDestroying(False);\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomListBox.DefaultDragDrop(Source: TObject;\r\n X, Y: Integer);\r\nvar\r\n DropIndex, Ti: Integer;\r\n S: string;\r\n Obj: TObject;\r\nbegin\r\n if not IsProviderSelected and (Source = Self) then\r\n begin\r\n S := Items[FDragIndex];\r\n Obj := Items.Objects[FDragIndex];\r\n DropIndex := ItemAtPos(Point(X, Y), True);\r\n Ti := TopIndex;\r\n if DropIndex > FDragIndex then\r\n Dec(DropIndex);\r\n Items.Delete(FDragIndex);\r\n if DropIndex < 0 then\r\n Items.AddObject(S, Obj)\r\n else\r\n Items.InsertObject(DropIndex, S, Obj);\r\n TopIndex := Ti;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomListBox.DefaultDragOver(Source: TObject; X, Y: Integer;\r\n State: TDragState; var Accept: Boolean);\r\nbegin\r\n Accept := not IsProviderSelected and (Source = Self);\r\n if Accept then\r\n begin\r\n // Handle autoscroll in the \"hot zone\" 5 pixels from top or bottom of\r\n // client area\r\n if (Y < 5) or ((ClientHeight - Y) <= 5) then\r\n begin\r\n FDragImage.HideDragImage;\r\n try\r\n if Y < 5 then\r\n begin\r\n Perform(WM_VSCROLL, SB_LINEUP, 0);\r\n Perform(WM_VSCROLL, SB_ENDSCROLL, 0);\r\n end\r\n else\r\n if (ClientHeight - Y) <= 5 then\r\n begin\r\n Perform(WM_VSCROLL, SB_LINEDOWN, 0);\r\n Perform(WM_VSCROLL, SB_ENDSCROLL, 0);\r\n end\r\n finally\r\n FDragImage.ShowDragImage;\r\n end;\r\n end;\r\n // i := ItemAtPos(Point(X,Y),true);\r\n // if i > -1 then ItemIndex := i;\r\n end;\r\nend;\r\n\r\n{ This procedure is a slightly modified version of TCustomListbox.DrawItem! }\r\n\r\nprocedure TJvCustomListBox.DefaultDrawItem(Index: Integer; ARect: TRect;\r\n State: TOwnerDrawState);\r\nconst\r\n AlignFlags: array [TAlignment] of DWORD =\r\n (DT_LEFT, DT_RIGHT, DT_CENTER);\r\nvar\r\n Flags: Longint;\r\n ActualRect: TRect;\r\n AText: string;\r\nbegin\r\n if csDestroying in ComponentState then\r\n Exit;\r\n // JvBMPListBox:\r\n // draw text transparently\r\n if ScrollBars in [ssHorizontal, ssBoth] then\r\n begin\r\n if FMaxWidth < ClientWidth then\r\n ActualRect := Rect(0, ARect.Top, ClientWidth, ARect.Bottom)\r\n else\r\n ActualRect := Rect(0, ARect.Top, FMaxWidth, ARect.Bottom);\r\n end\r\n else\r\n ActualRect := ARect;\r\n\r\n if Background.DoDraw then\r\n begin\r\n Canvas.Brush.Style := bsClear;\r\n // always use font color, CNDrawItem sets it to clHighlitetext for\r\n // selected items.\r\n Canvas.Font.Color := Font.Color;\r\n\r\n // The listbox does not erase the background for the item before\r\n // sending the WM_DRAWITEM message! We have to do that here manually.\r\n SaveDC(Canvas.Handle);\r\n IntersectClipRect(Canvas.Handle, ActualRect.Left, ActualRect.Top, ActualRect.Right, ActualRect.Bottom);\r\n DrawBackGround(Canvas.Handle, True);\r\n RestoreDC(Canvas.Handle, -1);\r\n end;\r\n\r\n if Index < ItemsShowing.Count then\r\n begin\r\n if not Background.DoDraw then\r\n Canvas.FillRect(ActualRect);\r\n\r\n if FMultiline then\r\n Flags := DrawTextBiDiModeFlags(DT_WORDBREAK or DT_NOPREFIX or\r\n AlignFlags[FAlignment])\r\n else\r\n Flags := DrawTextBiDiModeFlags(DT_SINGLELINE or DT_VCENTER or DT_NOPREFIX or\r\n AlignFlags[FAlignment]);\r\n if not UseRightToLeftAlignment then\r\n Inc(ActualRect.Left, 2)\r\n else\r\n Dec(ActualRect.Right, 2);\r\n\r\n if IsProviderSelected then\r\n DrawProviderItem(Canvas, ActualRect, Index, State)\r\n else\r\n begin\r\n AText := ItemsShowing[Index];\r\n DoGetText(Index, AText);\r\n DrawText(Canvas.Handle, PChar(AText),\r\n Length(AText), ActualRect, Flags);\r\n end;\r\n\r\n //if (Index >= 0) and (Index < Items.Count) then\r\n // Canvas.TextOut(ActualRect.Left + 2, ActualRect.Top, Items[Index]);\r\n\r\n // invert the item if selected\r\n if Background.DoDraw and (odSelected in State) then\r\n InvertRect(Canvas.Handle, ActualRect);\r\n // no need to draw focus rect, CNDrawItem does that for us\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomListBox.DefaultStartDrag(var DragObject: TDragObject);\r\nbegin\r\n FDragIndex := ItemIndex;\r\n if FDragIndex >= Items.Count then\r\n FDragIndex := Items.Count-1;\r\n if not IsProviderSelected and (FDragIndex >= 0) then\r\n CreateDragImage(Items[FDragIndex])\r\n else\r\n CancelDrag;\r\nend;\r\n\r\nprocedure TJvCustomListBox.DeleteAllButSelected;\r\nvar\r\n I: Integer;\r\nbegin\r\n if not IsProviderSelected and MultiSelect then\r\n begin\r\n I := 0;\r\n while I < Items.Count do\r\n if not Selected[I] then\r\n Items.Delete(I)\r\n else\r\n Inc(I);\r\n Changed;\r\n end;\r\nend;\r\n\r\nfunction TJvCustomListBox.DeleteExactString(const Value: string; All: Boolean;\r\n CaseSensitive: Boolean): Integer;\r\nbegin\r\n if not IsProviderSelected then\r\n begin\r\n Result := TJvItemsSearchs.DeleteExactString(Items, Value, CaseSensitive);\r\n Changed;\r\n end\r\n else\r\n Result := 0;\r\nend;\r\n\r\nprocedure TJvCustomListBox.DeleteSelected;\r\nvar\r\n I: Integer;\r\nbegin\r\n if not IsProviderSelected then\r\n begin\r\n if MultiSelect then\r\n begin\r\n for I := Items.Count - 1 downto 0 do\r\n if Selected[I] then\r\n Items.Delete(I);\r\n end\r\n else\r\n if ItemIndex <> -1 then\r\n begin\r\n I := ItemIndex;\r\n Items.Delete(I);\r\n if I > 0 then\r\n Dec(I);\r\n if Items.Count > 0 then\r\n ItemIndex := I;\r\n end;\r\n Changed;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomListBox.DoBackgroundChange(Sender: TObject);\r\nbegin\r\n UpdateStyle;\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvCustomListBox.DoStartDrag(var DragObject: TDragObject);\r\nbegin\r\n if Assigned(OnStartDrag) then\r\n inherited DoStartDrag(DragObject)\r\n else\r\n DefaultStartDrag(DragObject);\r\nend;\r\n\r\nprocedure TJvCustomListBox.DragDrop(Source: TObject; X, Y: Integer);\r\nbegin\r\n if Assigned(OnDragDrop) then\r\n inherited DragDrop(Source, X, Y)\r\n else\r\n DefaultDragDrop(Source, X, Y);\r\nend;\r\n\r\nprocedure TJvCustomListBox.DragOver(Source: TObject; X, Y: Integer;\r\n State: TDragState; var Accept: Boolean);\r\nbegin\r\n if Assigned(OnDragOver) then\r\n inherited DragOver(Source, X, Y, State, Accept)\r\n else\r\n DefaultDragOver(Source, X, Y, State, Accept);\r\nend;\r\n\r\nprocedure TJvCustomListBox.DrawBackGround(ADC: HDC; const DoOffSet: Boolean);\r\nvar\r\n ImageRect, ClipBox, ClientRect, Temp: TRect;\r\n Canvas: TCanvas;\r\n ClipComplexity: Integer;\r\nbegin\r\n if (ADC = 0) or not Background.DoDraw or (csDestroying in ComponentState) then\r\n Exit;\r\n ClientRect := Self.ClientRect;\r\n ClipComplexity := GetClipBox(ADC, ClipBox);\r\n if ClipComplexity = NULLREGION then\r\n Exit; // nothing to paint\r\n if ClipComplexity = Windows.ERROR then\r\n ClipBox := ClientRect;\r\n\r\n if DoOffSet then\r\n OffsetRect(ClientRect, FLeftPosition, 0);\r\n\r\n Canvas := TCanvas.Create;\r\n try\r\n Canvas.Handle := ADC;\r\n if Canvas.Handle = 0 then\r\n Exit;\r\n if Background.FillMode = bfmStretch then\r\n Canvas.StretchDraw(ClientRect, Background.Image)\r\n else\r\n begin\r\n ImageRect := Background.Image.Canvas.ClipRect;\r\n while ImageRect.Top < ClientRect.Bottom do\r\n begin\r\n while ImageRect.Left < ClientRect.Right do\r\n begin\r\n if IntersectRect(Temp, ClipBox, ImageRect) then\r\n Canvas.Draw(ImageRect.Left, ImageRect.Top, Background.Image);\r\n OffsetRect(ImageRect, ImageRect.Right - ImageRect.Left, 0);\r\n end;\r\n OffsetRect(ImageRect, -ImageRect.Left,\r\n ImageRect.Bottom - ImageRect.Top);\r\n end;\r\n end;\r\n finally\r\n Canvas.Handle := 0;\r\n Canvas.Free;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomListBox.DrawItem(Index: Integer; Rect: TRect;\r\n State: TOwnerDrawState);\r\nbegin\r\n if csDestroying in ComponentState then\r\n Exit;\r\n if Assigned(OnDrawItem) then\r\n inherited DrawItem(Index, Rect, State)\r\n else\r\n begin\r\n { Call the drawing code. This is isolated in its own public routine\r\n so a OnDrawItem handler can use it, too. }\r\n DefaultDrawItem(Index, Rect, State);\r\n if FShowFocusRect and (odFocused in State) then\r\n Canvas.DrawFocusRect(Rect);\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomListBox.EndRedraw;\r\nvar\r\n R: TRect;\r\nbegin\r\n SendMessage(Handle, WM_SETREDRAW, Ord(True), 0);\r\n R := Rect(0, 0, Width, Height);\r\n Windows.InvalidateRect(Handle, @R, True);\r\nend;\r\n\r\nprocedure TJvCustomListBox.SetConsumerService(Value: TJvDataConsumer);\r\nbegin\r\nend;\r\n\r\nprocedure TJvCustomListBox.ConsumerServiceChanging(Sender: TJvDataConsumer;\r\n Reason: TJvDataConsumerChangeReason);\r\nbegin\r\n { If we're changing providers, make sure a list box is created; this will post the saved list back\r\n now instead of after a provider is assigned (which will then be deselected again as the string\r\n list is changed). }\r\n if (Reason = ccrProviderSelect) and not (csDestroying in ComponentState) then\r\n HandleNeeded;\r\n if (Reason = ccrProviderSelect) and IsProviderSelected and not FProviderToggle then\r\n begin\r\n FProviderIsActive := False;\r\n FProviderToggle := True;\r\n end\r\n else\r\n if (Reason = ccrProviderSelect) and not IsProviderSelected and not FProviderToggle and\r\n not TJvListBoxStrings(Items).UseInternal then\r\n TJvListBoxStrings(Items).MakeListInternal;\r\nend;\r\n\r\nprocedure TJvCustomListBox.ConsumerServiceChanged(Sender: TJvDataConsumer;\r\n Reason: TJvDataConsumerChangeReason);\r\nbegin\r\n if (Reason = ccrProviderSelect) and not IsProviderSelected and not FProviderToggle then\r\n begin\r\n FProviderToggle := True;\r\n FProviderIsActive := True;\r\n RecreateWnd;\r\n{ if not TJvListBoxStrings(Items).UseInternal then\r\n begin\r\n TJvListBoxStrings(Items).MakeListInternal;\r\n RecreateWnd;\r\n end;}\r\n end\r\n else\r\n if (Reason = ccrProviderSelect) and not IsProviderSelected and FProviderToggle and\r\n TJvListBoxStrings(Items).UseInternal then\r\n begin\r\n RecreateWnd;\r\n TJvListBoxStrings(Items).ActivateInternal; // apply internal string list to list box\r\n{ end\r\n else\r\n if (Reason = ccrProviderSelect) and IsProviderSelected and not FProviderToggle then\r\n begin\r\n FProviderIsActive := False;\r\n FProviderToggle := True;\r\n TJvListBoxStrings(Items).ActivateInternal; // apply internal string list to list box\r\n RecreateWnd;}\r\n end;\r\n if (not FProviderToggle or (Reason = ccrProviderSelect)) and IsProviderSelected then\r\n begin\r\n UpdateItemCount;\r\n Refresh;\r\n end;\r\n if FProviderToggle and (Reason = ccrProviderSelect) then\r\n FProviderToggle := False;\r\nend;\r\n\r\nprocedure TJvCustomListBox.ConsumerSubServiceCreated(Sender: TJvDataConsumer;\r\n SubSvc: TJvDataConsumerAggregatedObject);\r\nvar\r\n VL: IJvDataConsumerViewList;\r\nbegin\r\n if SubSvc.GetInterface(IJvDataConsumerViewList, VL) then\r\n begin\r\n VL.ExpandOnNewItem := True;\r\n VL.AutoExpandLevel := -1;\r\n VL.RebuildView;\r\n end;\r\nend;\r\n\r\nfunction TJvCustomListBox.IsProviderSelected: Boolean;\r\nbegin\r\n Result := FProviderIsActive;\r\nend;\r\n\r\nfunction TJvCustomListBox.IsProviderToggle: Boolean;\r\nbegin\r\n Result := FProviderToggle;\r\nend;\r\n\r\nprocedure TJvCustomListBox.DeselectProvider;\r\nbegin\r\n Provider.Provider := nil;\r\nend;\r\n\r\nprocedure TJvCustomListBox.UpdateItemCount;\r\nvar\r\n VL: IJvDataConsumerViewList;\r\n Cnt: Integer;\r\n EmptyChr: Char;\r\nbegin\r\n if HandleAllocated and IsProviderSelected and\r\n Supports(Provider as IJvDataConsumer, IJvDataConsumerViewList, VL) then\r\n begin\r\n Cnt := VL.Count - SendMessage(Handle, LB_GETCOUNT, 0, 0);\r\n EmptyChr := #0;\r\n while Cnt > 0 do\r\n begin\r\n SendMessage(Handle, LB_ADDSTRING, 0, LPARAM(@EmptyChr));\r\n Dec(Cnt);\r\n end;\r\n while Cnt < 0 do\r\n begin\r\n SendMessage(Handle, LB_DELETESTRING, 0, 0);\r\n Inc(Cnt);\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomListBox.LBFindString(var Msg: TMessage);\r\nbegin\r\n if IsProviderSelected then\r\n Msg.Result := SearchPrefix(PChar(Msg.LParam), False, Msg.WParam)\r\n else\r\n inherited;\r\nend;\r\n\r\nprocedure TJvCustomListBox.LBFindStringExact(var Msg: TMessage);\r\nbegin\r\n if IsProviderSelected then\r\n Msg.Result := SearchExactString(PChar(Msg.LParam), False, Msg.WParam)\r\n else\r\n inherited;\r\nend;\r\n\r\nprocedure TJvCustomListBox.LBSelectString(var Msg: TMessage);\r\nbegin\r\n if IsProviderSelected then\r\n begin\r\n Msg.Result := SearchExactString(PChar(Msg.LParam), False, Msg.WParam);\r\n if Msg.Result > 0 then\r\n Perform(LB_SETCURSEL, Msg.Result, 0);\r\n end\r\n else\r\n inherited;\r\nend;\r\n\r\nprocedure TJvCustomListBox.LBGetText(var Msg: TMessage);\r\nbegin\r\n if IsProviderSelected then\r\n begin\r\n if (LPARAM(Msg.WParam) >= 0) and (Msg.WParam < WPARAM(ConsumerStrings.Count)) then\r\n begin\r\n StrCopy(PChar(Msg.LParam), PChar(ConsumerStrings[Msg.WParam]));\r\n Msg.Result := StrLen(PChar(Msg.LParam));\r\n end\r\n else\r\n Msg.Result := LB_ERR;\r\n end\r\n else\r\n inherited;\r\nend;\r\n\r\nprocedure TJvCustomListBox.LBGetTextLen(var Msg: TMessage);\r\nbegin\r\n if IsProviderSelected then\r\n begin\r\n if (LPARAM(Msg.WParam) >= 0) and (Msg.WParam < WPARAM(ConsumerStrings.Count)) then\r\n Msg.Result := Length(ConsumerStrings[Msg.WParam])\r\n else\r\n Msg.Result := LB_ERR;\r\n end\r\n else\r\n inherited;\r\nend;\r\n\r\nfunction TJvCustomListBox.GetDragImages: TDragImageList;\r\nbegin\r\n Result := FDragImage;\r\nend;\r\n\r\nfunction TJvCustomListBox.GetFlat: Boolean;\r\nbegin\r\n Result := not Ctl3D;\r\nend;\r\n\r\nfunction TJvCustomListBox.GetLimitToClientWidth: Boolean;\r\nbegin\r\n Result := FMultiline and (ScrollBars in [ssNone, ssVertical]);\r\nend;\r\n\r\nfunction TJvCustomListBox.GetParentFlat: Boolean;\r\nbegin\r\n Result := ParentCtl3D;\r\nend;\r\n\r\nprocedure TJvCustomListBox.InvertSelection;\r\nvar\r\n I: Integer;\r\nbegin\r\n if MultiSelect then\r\n begin\r\n ItemsShowing.BeginUpdate;\r\n for I := 0 to ItemsShowing.Count - 1 do\r\n Selected[I] := not Selected[I];\r\n ItemsShowing.EndUpdate;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomListBox.LBAddString(var Msg: TMessage);\r\nvar\r\n LSize: TSize;\r\nbegin\r\n { (rb) Because TJvDirectoryListBox displays shorter strings than it stores in\r\n it's Items property - ie it stores the complete path, displays only\r\n the last part of a directory - the following code will cause the\r\n TJvCustomListBox think that the size of the strings are bigger than\r\n they really are (thus you probably will see a horizontal scroll bar)\r\n }\r\n if not LimitToClientWidth then\r\n begin\r\n MeasureString(PChar(Msg.LParam), 0, LSize);\r\n if LSize.cx > FMaxWidth then\r\n SetMaxWidth(LSize.cx);\r\n end;\r\n inherited;\r\n if Assigned(FOnAddString) then\r\n FOnAddString(Self, StrPas(PChar(Msg.LParam)));\r\n if Assigned(FOnChange) then\r\n FOnChange(Self);\r\nend;\r\n\r\nprocedure TJvCustomListBox.LBDeleteString(var Msg: TMessage);\r\nvar\r\n LSize: TSize;\r\n InheritedCalled: Boolean;\r\nbegin\r\n InheritedCalled := False;\r\n if not LimitToClientWidth then\r\n begin\r\n if Msg.WParam < WPARAM(ItemsShowing.Count) then\r\n MeasureString(ItemsShowing[Msg.WParam], 0, LSize)\r\n else\r\n LSize.cx := FMaxWidth;\r\n InheritedCalled := LSize.cx = FMaxWidth;\r\n if InheritedCalled then\r\n begin\r\n inherited;\r\n RemeasureAll;\r\n end;\r\n end;\r\n if (Msg.WParam < WPARAM(ItemsShowing.Count)) and Assigned(FOnDeleteString) then\r\n FOnDeleteString(Self, ItemsShowing.Strings[Msg.WParam]);\r\n if not InheritedCalled then\r\n inherited;\r\n if Assigned(FOnChange) then\r\n FOnChange(Self);\r\nend;\r\n\r\nprocedure TJvCustomListBox.LBInsertString(var Msg: TMessage);\r\nvar\r\n LSize: TSize;\r\nbegin\r\n if not LimitToClientWidth then\r\n begin\r\n MeasureString(PChar(Msg.LParam), 0, LSize);\r\n if LSize.cx > FMaxWidth then\r\n SetMaxWidth(LSize.cx);\r\n end;\r\n inherited;\r\nend;\r\n\r\nprocedure TJvCustomListBox.Loaded;\r\nbegin\r\n inherited Loaded;\r\n UpdateStyle;\r\nend;\r\n\r\nprocedure TJvCustomListBox.DrawProviderItem(Canvas: TCanvas; Rect: TRect; Index: Integer;\r\n State: TOwnerDrawState);\r\nvar\r\n DrawState: TProviderDrawStates;\r\n VL: IJvDataConsumerViewList;\r\n Item: IJvDataItem;\r\n ItemsRenderer: IJvDataItemsRenderer;\r\n ItemRenderer: IJvDataItemRenderer;\r\n ItemText: IJvDataItemText;\r\n AText: string;\r\nbegin\r\n DrawState := DP_OwnerDrawStateToProviderDrawState(State);\r\n if not Enabled then\r\n DrawState := DrawState + [pdsDisabled, pdsGrayed];\r\n Provider.Enter;\r\n try\r\n if Supports(Provider as IJvDataConsumer, IJvDataConsumerViewList, VL) then\r\n begin\r\n Item := VL.Item(Index);\r\n if Item <> nil then\r\n begin\r\n Inc(Rect.Left, VL.ItemLevel(Index) * VL.LevelIndent);\r\n if Supports(Item, IJvDataItemRenderer, ItemRenderer) then\r\n ItemRenderer.Draw(Canvas, Rect, DrawState)\r\n else\r\n if DP_FindItemsRenderer(Item, ItemsRenderer) then\r\n ItemsRenderer.DrawItem(Canvas, Rect, Item, DrawState)\r\n else\r\n if Supports(Item, IJvDataItemText, ItemText) then\r\n begin\r\n AText := ItemText.Text;\r\n DoGetText(Index,AText);\r\n Canvas.TextRect(Rect, Rect.Left, Rect.Top, AText);\r\n end\r\n else\r\n begin\r\n AText := RsDataItemRenderHasNoText;\r\n DoGetText(Index,AText);\r\n Canvas.TextRect(Rect, Rect.Left, Rect.Top, AText);\r\n end;\r\n end;\r\n end;\r\n finally\r\n Provider.Leave;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomListBox.DoGetText(Index: Integer; var AText: string);\r\nbegin\r\n if Assigned(FOnGetText) then\r\n FOnGetText(Self, Index, AText);\r\nend;\r\n\r\nprocedure TJvCustomListBox.MeasureItem(Index: Integer;\r\n var Height: Integer);\r\nvar\r\n AvailWidth: Integer;\r\n LSize: TSize;\r\nbegin\r\n if Assigned(OnMeasureItem) or (not MultiLine and not IsProviderSelected) or\r\n (Index < 0) or (Index >= ItemsShowing.Count) then\r\n inherited MeasureItem(Index, Height)\r\n else\r\n begin\r\n if LimitToClientWidth then\r\n AvailWidth := ClientWidth\r\n else\r\n AvailWidth := MaxInt;\r\n\r\n if IsProviderSelected then\r\n MeasureProviderItem(Index, AvailWidth, LSize)\r\n else\r\n MeasureString(ItemsShowing[Index], AvailWidth, LSize);\r\n\r\n Height := LSize.cy;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomListBox.MeasureProviderItem(Index, WidthAvail: Integer; var ASize: TSize);\r\nvar\r\n VL: IJvDataConsumerViewList;\r\n Item: IJvDataItem;\r\n ItemsRenderer: IJvDataItemsRenderer;\r\n ItemRenderer: IJvDataItemRenderer;\r\n ItemText: IJvDataItemText;\r\nbegin\r\n Canvas.Font := Font;\r\n { Note: doing the TextHeight unconditionally makes sure the font is properly\r\n selected into the device context. }\r\n ASize.cy := CanvasMaxTextHeight(Canvas);\r\n ASize.cx := ClientWidth - 4;\r\n Provider.Enter;\r\n try\r\n if Supports(Provider as IJvDataConsumer, IJvDataConsumerViewList, VL) then\r\n begin\r\n Item := VL.Item(Index);\r\n if Item <> nil then\r\n begin\r\n if Supports(Item, IJvDataItemRenderer, ItemRenderer) then\r\n ASize := ItemRenderer.Measure(Canvas)\r\n else\r\n if DP_FindItemsRenderer(Item, ItemsRenderer) then\r\n ASize := ItemsRenderer.MeasureItem(Canvas, Item)\r\n else\r\n if Supports(Item, IJvDataItemText, ItemText) then\r\n ASize := Canvas.TextExtent(ItemText.Text)\r\n else\r\n ASize := Canvas.TextExtent(RsDataItemRenderHasNoText);\r\n Inc(ASize.cx, VL.ItemLevel(Index) * VL.LevelIndent);\r\n end;\r\n end;\r\n finally\r\n Provider.Leave;\r\n end;\r\n { Note: item height in a listbox is limited to 255 pixels since Windows\r\n stores the height in a single byte.}\r\n if ASize.cy > 255 then\r\n ASize.cy := 255;\r\n if ASize.cy < ItemHeight then\r\n ASize.cy := ItemHeight;\r\nend;\r\n\r\nprocedure TJvCustomListBox.MeasureString(const S: string; WidthAvail: Integer; var ASize: TSize);\r\nvar\r\n Flags: Longint;\r\n R: TRect;\r\nbegin\r\n Canvas.Font := Font;\r\n { Note: doing the TextHeight unconditionally makes sure the font is properly\r\n selected into the device context. }\r\n ASize.cx := Canvas.TextHeight(S);\r\n\r\n Flags := DrawTextBiDiModeFlags(\r\n DT_WORDBREAK or DT_NOPREFIX or DT_CALCRECT or AlignFlags[FAlignment]);\r\n if WidthAvail = 0 then\r\n WidthAvail := MaxInt\r\n else\r\n Dec(WidthAvail, 2);\r\n R := Rect(0, 0, WidthAvail, 1);\r\n DrawText(Canvas.Handle, PChar(S), Length(S), R, Flags);\r\n ASize.cx := R.Right + 4;\r\n ASize.cy := R.Bottom;\r\n\r\n { Note: item height in a listbox is limited to 255 pixels since Windows\r\n stores the height in a single byte.}\r\n if ASize.cy > 255 then\r\n ASize.cy := 255;\r\n if ASize.cy < ItemHeight then\r\n ASize.cy := ItemHeight;\r\nend;\r\n\r\nprocedure TJvCustomListBox.MoveSelectedDown;\r\nvar\r\n I: Integer;\r\nbegin\r\n if not IsProviderSelected then\r\n begin\r\n if not MultiSelect then\r\n begin\r\n if (ItemIndex <> -1) and (ItemIndex < Items.Count - 1) then\r\n begin\r\n Items.Exchange(ItemIndex, ItemIndex + 1);\r\n ItemIndex := ItemIndex + 1;\r\n end;\r\n Exit;\r\n end;\r\n if (Items.Count > 0) and (SelCount > 0) and (not Selected[Items.Count - 1]) then\r\n begin\r\n I := Items.Count - 2;\r\n while I >= 0 do\r\n begin\r\n if Selected[I] then\r\n begin\r\n Items.Exchange(I, I + 1);\r\n Selected[I + 1] := True;\r\n end;\r\n Dec(I);\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomListBox.MoveSelectedUp;\r\nvar\r\n I: Integer;\r\nbegin\r\n if not IsProviderSelected then\r\n begin\r\n if not MultiSelect then\r\n begin\r\n if ItemIndex > 0 then\r\n begin\r\n Items.Exchange(ItemIndex, ItemIndex - 1);\r\n ItemIndex := ItemIndex - 1;\r\n end;\r\n Exit;\r\n end;\r\n if (Items.Count > 0) and (SelCount > 0) and not Selected[0] then\r\n begin\r\n I := 1;\r\n while I < Items.Count do\r\n begin\r\n if Selected[I] then\r\n begin\r\n Items.Exchange(I, I - 1);\r\n Selected[I - 1] := True;\r\n end;\r\n Inc(I);\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomListBox.RemeasureAll;\r\nvar\r\n I: Integer;\r\n LMaxWidth, cx: Integer;\r\n LItemSize: TSize;\r\nbegin\r\n LMaxWidth := 0;\r\n if LimitToClientWidth then\r\n cx := ClientWidth\r\n else\r\n cx := 0;\r\n\r\n for I := 0 to ItemsShowing.Count - 1 do\r\n begin\r\n MeasureString(ItemsShowing[I], cx, LItemSize);\r\n if MultiLine then\r\n Perform(LB_SETITEMHEIGHT, I, LItemSize.cy);\r\n\r\n if not LimitToClientWidth and (LItemSize.cx > LMaxWidth) then\r\n LMaxWidth := LItemSize.cx;\r\n end;\r\n if not LimitToClientWidth then\r\n MaxWidth := LMaxWidth;\r\nend;\r\n\r\nfunction TJvCustomListBox.SearchExactString(const Value: string;\r\n CaseSensitive: Boolean; StartIndex: Integer): Integer;\r\nbegin\r\n Result := TJvItemsSearchs.SearchExactString(ItemsShowing, Value, CaseSensitive, StartIndex);\r\nend;\r\n\r\nfunction TJvCustomListBox.SearchPrefix(const Value: string;\r\n CaseSensitive: Boolean; StartIndex: Integer): Integer;\r\nbegin\r\n Result := TJvItemsSearchs.SearchPrefix(ItemsShowing, Value, CaseSensitive, StartIndex);\r\nend;\r\n\r\nfunction TJvCustomListBox.SearchSubString(const Value: string;\r\n CaseSensitive: Boolean; StartIndex: Integer): Integer;\r\nbegin\r\n Result := TJvItemsSearchs.SearchSubString(ItemsShowing, Value, CaseSensitive, StartIndex);\r\nend;\r\n\r\nprocedure TJvCustomListBox.SelectAll;\r\nvar\r\n I: Integer;\r\nbegin\r\n if MultiSelect then\r\n begin\r\n ItemsShowing.BeginUpdate;\r\n for I := 0 to ItemsShowing.Count - 1 do\r\n Selected[I] := True;\r\n ItemsShowing.EndUpdate;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomListBox.SelectCancel(var Msg: TMessage);\r\nbegin\r\n if Assigned(FOnSelectCancel) then\r\n FOnSelectCancel(Self);\r\nend;\r\n\r\nprocedure TJvCustomListBox.SetAlignment(const Value: TAlignment);\r\nbegin\r\n if FAlignment <> Value then\r\n begin\r\n FAlignment := Value;\r\n\r\n UpdateStyle;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomListBox.SetBackground(const Value: TJvListBoxBackground);\r\nbegin\r\n FBackground.Assign(Value);\r\nend;\r\n\r\nprocedure TJvCustomListBox.SetBounds(ALeft, ATop, AWidth, AHeight: Integer);\r\nbegin\r\n inherited SetBounds(ALeft, ATop, AWidth, AHeight);\r\n if Alignment <> taLeftJustify then\r\n Repaint;\r\nend;\r\n\r\nprocedure TJvCustomListBox.SetDisabledTextColor(const Value: TColor);\r\nbegin\r\n if FDisabledTextColor <> Value then\r\n begin\r\n FDisabledTextColor := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomListBox.SetFlat(const Value: Boolean);\r\nbegin\r\n Ctl3D := not Value;\r\nend;\r\n\r\nprocedure TJvCustomListBox.SetHotTrack(const Value: Boolean);\r\nbegin\r\n if FHotTrack <> Value then\r\n begin\r\n FHotTrack := Value;\r\n Ctl3D := not FHotTrack;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomListBox.SetMaxWidth(const Value: Integer);\r\nbegin\r\n if not LimitToClientWidth and (FMaxWidth <> Value) then\r\n begin\r\n FMaxWidth := Value;\r\n Perform(LB_SETHORIZONTALEXTENT, Value, 0);\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomListBox.SetMultiline(const Value: Boolean);\r\nbegin\r\n if FMultiline <> Value then\r\n begin\r\n FMultiline := Value;\r\n\r\n UpdateStyle;\r\n if FMultiline then\r\n begin\r\n // make sure scrollbars matches\r\n if ScrollBars = ssBoth then\r\n ScrollBars := ssVertical;\r\n if ScrollBars = ssHorizontal then\r\n ScrollBars := ssNone;\r\n FMaxWidth := 0;\r\n Perform(LB_SETHORIZONTALEXTENT, 0, 0);\r\n end\r\n else\r\n RemeasureAll;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomListBox.SetParentFlat(const Value: Boolean);\r\nbegin\r\n ParentCtl3D := Value;\r\nend;\r\n\r\nprocedure TJvCustomListBox.SetScrollBars(const Value: TScrollStyle);\r\nbegin\r\n if FScrollBars <> Value then\r\n begin\r\n FScrollBars := Value;\r\n RecreateWnd;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomListBox.SetSelectedColor(const Value: TColor);\r\nbegin\r\n if FSelectedColor <> Value then\r\n begin\r\n FSelectedColor := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomListBox.SetSelectedTextColor(const Value: TColor);\r\nbegin\r\n if FSelectedTextColor <> Value then\r\n begin\r\n FSelectedTextColor := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomListBox.SetShowFocusRect(const Value: Boolean);\r\nconst\r\n CShowFocusRect: array [Boolean] of Integer = (0, 2);\r\nbegin\r\n if FShowFocusRect <> Value then\r\n begin\r\n FShowFocusRect := Value;\r\n\r\n ItemHeight := CanvasMaxTextHeight(Canvas) + CShowFocusRect[ShowFocusRect];\r\n RemeasureAll;\r\n if Focused then\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomListBox.SetSorted(const Value: Boolean);\r\nbegin\r\n if FSorted <> Value then\r\n begin\r\n FSorted := Value;\r\n RecreateWnd;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomListBox.UnselectAll;\r\nvar\r\n I: Integer;\r\nbegin\r\n if MultiSelect then\r\n begin\r\n ItemsShowing.BeginUpdate;\r\n for I := 0 to ItemsShowing.Count - 1 do\r\n Selected[I] := False;\r\n ItemsShowing.EndUpdate;\r\n end\r\n else\r\n ItemIndex := -1;\r\nend;\r\n\r\nprocedure TJvCustomListBox.UpdateHorizontalExtent;\r\nbegin\r\n if HandleAllocated and (FScrollBars in [ssHorizontal, ssBoth]) then\r\n RemeasureAll;\r\n // SendMessage(Handle, LB_SETHORIZONTALEXTENT, FHorizontalExtent, 0);\r\nend;\r\n\r\nprocedure TJvCustomListBox.UpdateStyle;\r\nconst\r\n CShowFocusRect: array [Boolean] of Integer = (0, 2);\r\nvar\r\n PreviousStyle: TListBoxStyle;\r\nbegin\r\n if csLoading in ComponentState then\r\n Exit;\r\n\r\n PreviousStyle := Style;\r\n\r\n if MultiLine then\r\n Style := lbOwnerDrawVariable\r\n else\r\n if Alignment <> taLeftJustify then\r\n Style := lbOwnerDrawFixed;\r\n\r\n // Mantis 3477: Background requires the list to be ownerdrawn\r\n if Background.Visible and Assigned(Background.Image) and\r\n not (Style in [lbOwnerDrawVariable, lbOwnerDrawFixed]) then\r\n Style := lbOwnerDrawFixed;\r\n\r\n if (PreviousStyle = lbStandard) and (Style <> lbStandard) then\r\n begin\r\n ItemHeight := CanvasMaxTextHeight(Canvas) + CShowFocusRect[ShowFocusRect];\r\n RemeasureAll;\r\n end;\r\nend;\r\n\r\nfunction TJvCustomListBox.DoEraseBackground(Canvas: TCanvas; Param: LPARAM): Boolean;\r\nbegin\r\n if not Background.DoDraw then\r\n Result := inherited DoEraseBackground(Canvas, Param)\r\n else\r\n begin\r\n Result := True;\r\n DrawBackGround(Canvas.Handle, False);\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomListBox.WMHScroll(var Msg: TWMHScroll);\r\nvar\r\n DontScroll: Boolean;\r\n DoUpdate: Boolean;\r\n ScrollInfo: TScrollInfo;\r\nbegin\r\n DoUpdate := Background.DoDraw;\r\n\r\n if DoUpdate then\r\n BeginRedraw;\r\n try\r\n if Assigned(FOnHorizontalScroll) then\r\n begin\r\n DontScroll := False;\r\n FOnHorizontalScroll(Self, Msg, DontScroll);\r\n if DontScroll then\r\n Exit;\r\n end;\r\n inherited;\r\n\r\n if DoUpdate and (FMaxWidth > 0) then\r\n begin\r\n with ScrollInfo do\r\n begin\r\n cbSize := SizeOf(ScrollInfo);\r\n fMask := SIF_ALL;\r\n if GetScrollInfo(Handle, SB_HORZ, ScrollInfo) then\r\n FLeftPosition := Round((FMaxWidth / nMax) * nPos);\r\n end;\r\n end\r\n else\r\n FLeftPosition := 0;\r\n\r\n //if DoUpdate then\r\n // Invalidate;\r\n finally\r\n if DoUpdate then\r\n EndRedraw;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomListBox.WMVScroll(var Msg: TWMVScroll);\r\nvar\r\n DontScroll: Boolean;\r\n DoUpdate: Boolean;\r\nbegin\r\n DoUpdate := Background.DoDraw;\r\n\r\n if DoUpdate then\r\n BeginRedraw;\r\n try\r\n if Assigned(FOnVerticalScroll) then\r\n begin\r\n DontScroll := False;\r\n FOnVerticalScroll(Self, Msg, DontScroll);\r\n if DontScroll then\r\n Exit;\r\n end;\r\n inherited;\r\n\r\n //if DoUpdate then\r\n // Invalidate;\r\n finally\r\n if DoUpdate then\r\n EndRedraw;\r\n end;\r\nend;\r\n\r\nfunction TJvCustomListBox.ItemRect(Index: Integer): TRect;\r\nvar\r\n Count: Integer;\r\nbegin\r\n Count := ItemsShowing.Count;\r\n if (Index >= 0) and (Index < Count) then\r\n Perform(LB_GETITEMRECT, Index, LPARAM(@Result))\r\n else\r\n if Index = Count then\r\n begin\r\n Perform(LB_GETITEMRECT, Index - 1, LPARAM(@Result));\r\n OffsetRect(Result, 0, Result.Bottom - Result.Top);\r\n end\r\n else\r\n FillChar(Result, SizeOf(Result), 0);\r\nend;\r\n\r\nfunction TJvCustomListBox.ItemsShowing: TStrings;\r\nbegin\r\n if IsProviderSelected then\r\n Result := ConsumerStrings\r\n else\r\n Result := Items;\r\nend;\r\n\r\nprocedure TJvCustomListBox.WndProc(var Msg: TMessage);\r\nvar\r\n ItemWidth: Word;\r\nbegin\r\n case Msg.Msg of\r\n LB_ADDSTRING, LB_INSERTSTRING:\r\n begin\r\n ItemWidth := Canvas.TextWidth(StrPas(PChar(Msg.LParam)) + ' ');\r\n if FMaxWidth < ItemWidth then\r\n FMaxWidth := ItemWidth;\r\n SendMessage(Handle, LB_SETHORIZONTALEXTENT, FMaxWidth, 0);\r\n end;\r\n LB_DELETESTRING:\r\n begin\r\n if Msg.WParam < WPARAM(ItemsShowing.Count) then\r\n ItemWidth := Canvas.TextWidth(ItemsShowing[Msg.WParam] + ' ')\r\n else\r\n ItemWidth := FMaxWidth;\r\n if ItemWidth = FMaxWidth then\r\n begin\r\n inherited WndProc(Msg);\r\n UpdateHorizontalExtent;\r\n Exit;\r\n end;\r\n end;\r\n LB_RESETCONTENT:\r\n SendMessage(Handle, LB_SETHORIZONTALEXTENT, 0, 0);\r\n WM_SETFONT:\r\n begin\r\n inherited WndProc(Msg);\r\n Canvas.Font.Assign(Font);\r\n UpdateHorizontalExtent;\r\n Exit;\r\n end;\r\n end;\r\n inherited WndProc(Msg);\r\nend;\r\n\r\n//=== { TJvListBoxBackground } ===============================================\r\n\r\nconstructor TJvListBoxBackground.Create;\r\nbegin\r\n inherited Create;\r\n FImage := TBitmap.Create;\r\nend;\r\n\r\ndestructor TJvListBoxBackground.Destroy;\r\nbegin\r\n FImage.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvListBoxBackground.Assign(Source: TPersistent);\r\nbegin\r\n if Source is TJvListBoxBackground then\r\n begin\r\n FImage.Assign(TJvListBoxBackground(Source).Image);\r\n FFillMode := TJvListBoxBackground(Source).FillMode;\r\n FVisible := TJvListBoxBackground(Source).Visible;\r\n end\r\n else\r\n inherited Assign(Source);\r\nend;\r\n\r\nprocedure TJvListBoxBackground.Change;\r\nbegin\r\n if Assigned(FOnChange) then\r\n FOnChange(Self);\r\nend;\r\n\r\nfunction TJvListBoxBackground.GetDoDraw: Boolean;\r\nbegin\r\n Result := Visible and not Image.Empty;\r\nend;\r\n\r\nprocedure TJvListBoxBackground.SetFillMode(const Value: TJvListboxFillMode);\r\nbegin\r\n if FFillMode <> Value then\r\n begin\r\n FFillMode := Value;\r\n Change;\r\n end;\r\nend;\r\n\r\nprocedure TJvListBoxBackground.SetImage(const Value: TBitmap);\r\nbegin\r\n FImage.Assign(Value);\r\n Change;\r\nend;\r\n\r\nprocedure TJvListBoxBackground.SetVisible(const Value: Boolean);\r\nbegin\r\n if FVisible <> Value then\r\n begin\r\n FVisible := Value;\r\n Change;\r\n end;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvListComb.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvListComb.PAS, released on 2002-05-26.\r\n\r\nThe Initial Developer of the Original Code is Peter Thrnqvist [peter3 at sourceforge dot net]\r\nPortions created by Peter Thrnqvist are Copyright (C) 2002 Peter Thrnqvist.\r\nAll Rights Reserved.\r\n\r\nThis is a merging of the original TJvListBox3 and TJvImageListBox\r\nTJvListBox3 has been renamed TJvImageListBox and the original TJvImageListBox has been moved to \\archive\r\n\r\nContributor(s):\r\nSbastien Buysse [sbuysse att buypin dott com]\r\nMichael Beck [mbeck att bigfoot dott com]\r\nOlivier Sannier [obones att altern dott org]\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nDescription:\r\n A unit to allow display of bitmaps in TComboboxes and TListboxes\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvListComb.pas 13350 2012-06-13 14:54:41Z obones $\r\n\r\nunit JvListComb;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, Messages,\r\n SysUtils, Classes, Graphics, Controls, ExtCtrls, StdCtrls, ImgList,\r\n JvJCLUtils, JvCombobox,\r\n JvExStdCtrls;\r\n\r\ntype\r\n TJvButtonColors = (fsLighter, fsLight, fsMedium, fsDark, fsDarker);\r\n TJvListPropertiesUsed = set of (puFont, puColorHighlight, puColorHighlightText);\r\n\r\nconst\r\n AllListPropertiesUsed = [puFont, puColorHighlight, puColorHighlightText];\r\n\r\ntype\r\n IJvResetItemHeight = interface\r\n ['{29F7C34D-F03C-41FE-8423-0388289A505B}']\r\n procedure ResetItemHeight;\r\n end;\r\n\r\n TJvImageItems = class;\r\n\r\n TJvImageItem = class(TCollectionItem)\r\n private\r\n FOwner: TJvImageItems;\r\n FImageIndex: Integer;\r\n FIndent: Integer;\r\n FListPropertiesUsed: TJvListPropertiesUsed;\r\n FFont: TFont;\r\n FColorHighlight: TColor;\r\n FColorHighlightText: TColor;\r\n FGlyph: TBitmap;\r\n FLinkedObject: TObject;\r\n FNoTextAssign: Boolean;\r\n FBrush: TBrush;\r\n procedure SetImageIndex(const Value: Integer);\r\n procedure SetText(const Value: string);\r\n procedure SetIndent(const Value: Integer);\r\n function GetWinControl: TWinControl;\r\n procedure Change;\r\n function GetText: string;\r\n function GetOwnerStrings: TStrings;\r\n function GetFont: TFont;\r\n function GetGlyph: TBitmap;\r\n procedure SetGlyph(const Value: TBitmap);\r\n procedure SetFont(const Value: TFont);\r\n function GetColorHighlight: TColor;\r\n function GetColorHighlightText: TColor;\r\n procedure SetColorHighlight(const Value: TColor);\r\n procedure SetColorHighlightText(const Value: TColor);\r\n function IsColorHighlightTextStored: Boolean;\r\n function IsColorHighlightStored: Boolean;\r\n procedure SetBrush(const Value: TBrush);\r\n protected\r\n procedure SetIndex(Value: Integer); override;\r\n function GetDisplayName: string; override;\r\n\r\n function IsFontStored: Boolean;\r\n procedure FontChange(Sender: TObject);\r\n public\r\n constructor Create(Collection: Classes.TCollection); override;\r\n destructor Destroy; override;\r\n procedure Assign(Source: TPersistent); override;\r\n property LinkedObject: TObject read FLinkedObject write FLinkedObject;\r\n published\r\n // ListPropertiesUsed must come before properties named the same\r\n // as in the list or the component will not be created\r\n // correctly when restored from a DFM stream.\r\n property ListPropertiesUsed: TJvListPropertiesUsed read FListPropertiesUsed\r\n write FListPropertiesUsed default AllListPropertiesUsed;\r\n property ColorHighlight: TColor read GetColorHighlight\r\n write SetColorHighlight stored IsColorHighlightStored default clHighlight;\r\n property ColorHighlightText: TColor read GetColorHighlightText\r\n write SetColorHighlightText stored IsColorHighlightTextStored default clHighlightText;\r\n property Font: TFont read GetFont write SetFont stored IsFontStored;\r\n property Brush: TBrush read FBrush write SetBrush;\r\n property Glyph: TBitmap read GetGlyph write SetGlyph stored True;\r\n property ImageIndex: Integer read FImageIndex write SetImageIndex default -1;\r\n property Indent: Integer read FIndent write SetIndent default 2;\r\n property Text: string read GetText write SetText;\r\n end;\r\n\r\n TJvImageItems = class(TOwnedCollection)\r\n private\r\n function GetItems(Index: Integer): TJvImageItem;\r\n procedure SetItems(Index: Integer; const Value: TJvImageItem);\r\n function GetObjects(Index: Integer): TObject;\r\n procedure SetObjects(Index: Integer; const Value: TObject);\r\n protected\r\n FStrings: TStrings; // Protected to allow to use it in derived classes\r\n FDestroying: Boolean; // True when our Destroy has been called.\r\n\r\n procedure Update(Item: TCollectionItem); override;\r\n procedure FillItems;\r\n procedure Notify(Item: TCollectionItem; Action: TCollectionNotification); override;\r\n public\r\n constructor Create(AOwner: TPersistent);\r\n destructor Destroy; override;\r\n procedure Assign(Source: TPersistent); override;\r\n function Add: TJvImageItem;\r\n function AddText(const Text: string): Integer;\r\n function AddObject(const Text: string; ALinkedObject: TObject): Integer;\r\n function Insert(Index: Integer): TJvImageItem;\r\n procedure InsertText(Index: Integer; const Text: string);\r\n procedure InsertObject(Index: Integer; const Text: string; ALinkedObject: TObject);\r\n procedure Move(CurIndex, NewIndex: Integer);\r\n procedure Sort(SortProc: TCollectionSortProc);\r\n\r\n procedure BeginUpdate; override;\r\n procedure EndUpdate; override;\r\n\r\n function IndexOfLinkedObject(ALinkedObject: TObject): Integer;\r\n\r\n property Items[Index: Integer]: TJvImageItem read GetItems write SetItems; default;\r\n property Objects[Index: Integer]: TObject read GetObjects write SetObjects;\r\n end;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvImageComboBox = class(TJvCustomComboBox, IUnknown, IJvResetItemHeight)\r\n private\r\n FItems: TJvImageItems;\r\n FImageList: TCustomImageList;\r\n FDefaultIndent: Integer;\r\n FChangeLink: TChangeLink;\r\n FMouseInControl: Boolean;\r\n FImageWidth: Integer;\r\n FImageHeight: Integer;\r\n FColorHighlight: TColor;\r\n FColorHighlightText: TColor;\r\n FOnChange: TNotifyEvent;\r\n FButtonFrame: Boolean;\r\n FButtonStyle: TJvButtonColors;\r\n FIndentSelected: Boolean;\r\n FDroppedWidth: Integer;\r\n FFullWidthItemDraw: Boolean;\r\n FCanvas: TControlCanvas;\r\n FSorted: Boolean;\r\n function GetCanvas: TCanvas;\r\n function GetDroppedWidth: Integer;\r\n procedure SetDroppedWidth(Value: Integer);\r\n procedure SetColorHighlight(Value: TColor);\r\n procedure SetColorHighlightText(Value: TColor);\r\n procedure SetImageList(Value: TCustomImageList);\r\n\r\n procedure ImageListChange(Sender: TObject);\r\n procedure SetDefaultIndent(const Value: Integer);\r\n procedure SetItems(const Value: TJvImageItems); reintroduce;\r\n procedure SetIndentSelected(const Value: Boolean);\r\n procedure SetFullWidthItemDraw(const Value: Boolean);\r\n { IJvResetItemHeight }\r\n procedure ResetItemHeight;\r\n function GetSorted: Boolean;\r\n procedure SetSorted(const Value: Boolean);\r\n protected\r\n procedure MouseEnter(AControl: TControl); override;\r\n procedure MouseLeave(AControl: TControl); override;\r\n procedure FontChanged; override;\r\n procedure EnabledChanged; override;\r\n procedure Notification(AComponent: TComponent; Operation: TOperation); override;\r\n procedure RecreateWnd;\r\n procedure CreateWnd; override;\r\n procedure DrawItem(Index: Integer; R: TRect; State: TOwnerDrawState); override;\r\n procedure MeasureItem(Index: Integer; var Height: Integer); override;\r\n procedure CNDrawItem(var Msg: TWMDrawItem); message CN_DRAWITEM;\r\n procedure CNCommand(var Msg: TWMCommand); message CN_COMMAND;\r\n\r\n procedure Change; override;\r\n\r\n function GetImageWidth(Index: Integer): Integer;\r\n function GetImageHeight(Index: Integer): Integer;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n property Canvas: TCanvas read GetCanvas;\r\n property Text;\r\n published\r\n property Style; {Must be published before Items}\r\n\r\n property Align;\r\n property Anchors;\r\n property AutoComplete default True;\r\n property AutoDropDown default False;\r\n property BevelEdges;\r\n property BevelInner;\r\n property BevelKind default bkNone;\r\n property BevelOuter;\r\n property BiDiMode;\r\n property ButtonFrame: Boolean read FButtonFrame write FButtonFrame default False;\r\n property ButtonStyle: TJvButtonColors read FButtonStyle write FButtonStyle;\r\n property CharCase;\r\n property Color;\r\n property ColorHighlight: TColor read FColorHighlight write SetColorHighlight default clHighlight;\r\n property ColorHighlightText: TColor read FColorHighlightText write SetColorHighlightText default clHighlightText;\r\n property Constraints;\r\n property DefaultIndent: Integer read FDefaultIndent write SetDefaultIndent default 0;\r\n property DragCursor;\r\n property DragKind;\r\n property DroppedWidth: Integer read GetDroppedWidth write SetDroppedWidth;\r\n property DragMode;\r\n property DropDownCount;\r\n property EmptyValue;\r\n property EmptyFontColor;\r\n property Enabled;\r\n property Font;\r\n property FullWidthItemDraw: Boolean read FFullWidthItemDraw write SetFullWidthItemDraw default False;\r\n property HintColor;\r\n property ImageHeight: Integer read FImageHeight write FImageHeight;\r\n property ImageWidth: Integer read FImageWidth write FImageWidth;\r\n property Images: TCustomImageList read FImageList write SetImageList;\r\n property ImeMode;\r\n property ImeName;\r\n property IndentSelected: Boolean read FIndentSelected write SetIndentSelected default False;\r\n property ItemHeight;\r\n property ItemIndex;\r\n property MaxLength;\r\n property MaxPixel;\r\n property MeasureStyle;\r\n property ParentBiDiMode;\r\n property ParentColor;\r\n property ParentFont;\r\n property ParentShowHint;\r\n property PopupMenu;\r\n property Provider;\r\n property ReadOnly;\r\n property ShowHint;\r\n property Sorted: Boolean read GetSorted write SetSorted default False;\r\n property Tag;\r\n property TabOrder;\r\n property TabStop;\r\n property Visible;\r\n\r\n property OnChange: TNotifyEvent read FOnChange write FOnChange;\r\n property OnClick;\r\n property OnCloseUp;\r\n property OnContextPopup;\r\n property OnDblClick;\r\n property OnDragDrop;\r\n property OnDragOver;\r\n property OnDrawItem;\r\n property OnDropDown;\r\n property OnEndDrag;\r\n property OnEndDock;\r\n property OnEnter;\r\n property OnExit;\r\n property OnKeyDown;\r\n property OnKeyPress;\r\n property OnKeyUp;\r\n property OnMeasureItem;\r\n property OnMouseEnter;\r\n property OnMouseLeave;\r\n property OnParentColorChange;\r\n property OnSelect;\r\n property OnStartDock;\r\n property OnStartDrag;\r\n\r\n property Items: TJvImageItems read FItems write SetItems; // must be declared after OnMeasureItem\r\n end;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvImageListBox = class(TJvExCustomListBox, IUnknown, IJvResetItemHeight)\r\n private\r\n FImageList: TCustomImageList;\r\n FItems: TJvImageItems;\r\n FChangeLink: TChangeLink;\r\n FImageWidth: Integer;\r\n FImageHeight: Integer;\r\n FAlignment: TAlignment;\r\n FColorHighlight: TColor;\r\n FColorHighlightText: TColor;\r\n FButtonFrame: Boolean;\r\n FButtonStyle: TJvButtonColors;\r\n FFullWidthItemDraw: Boolean;\r\n FCanvas: TControlCanvas;\r\n function GetCanvas: TCanvas;\r\n procedure SetColorHighlight(Value: TColor);\r\n procedure SetColorHighlightText(Value: TColor);\r\n procedure SetImageList(Value: TCustomImageList);\r\n procedure SetAlignment(Value: TAlignment);\r\n procedure DrawLeftGlyph(Index: Integer; R: TRect; State: TOwnerDrawState);\r\n procedure DrawRightGlyph(Index: Integer; R: TRect; State: TOwnerDrawState);\r\n procedure DrawCenteredGlyph(Index: Integer; R: TRect; State: TOwnerDrawState);\r\n procedure SetItems(const Value: TJvImageItems);\r\n procedure SetFullWidthItemDraw(const Value: Boolean);\r\n { IJvResetItemHeight }\r\n procedure ResetItemHeight;\r\n protected\r\n procedure FontChanged; override;\r\n procedure ImageListChange(Sender: TObject);\r\n procedure Notification(AComponent: TComponent; Operation: TOperation); override;\r\n procedure CreateWnd; override;\r\n procedure DrawItem(Index: Integer; Rect: TRect; State: TOwnerDrawState); override;\r\n procedure MeasureItem(Index: Integer; var Height: Integer); override;\r\n procedure CNDrawItem(var Msg: TWMDrawItem); message CN_DRAWITEM;\r\n procedure Resize; override;\r\n\r\n function GetImageWidth(Index: Integer): Integer;\r\n function GetImageHeight(Index: Integer): Integer;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n property Canvas: TCanvas read GetCanvas;\r\n published\r\n property Anchors;\r\n property Align;\r\n property Alignment: TAlignment read FAlignment write SetAlignment default taLeftJustify;\r\n property BorderStyle;\r\n property Color;\r\n property DragMode;\r\n property DragCursor;\r\n property IntegralHeight;\r\n property Enabled;\r\n property Font;\r\n property Items: TJvImageItems read FItems write SetItems;\r\n property ImageHeight: Integer read FImageHeight write FImageHeight;\r\n property ImageWidth: Integer read FImageWidth write FImageWidth;\r\n property ButtonFrame: Boolean read FButtonFrame write FButtonFrame default False;\r\n property ButtonStyle: TJvButtonColors read FButtonStyle write FButtonStyle;\r\n property ColorHighlight: TColor read FColorHighlight write SetColorHighlight default clHighlight;\r\n property ColorHighlightText: TColor read FColorHighlightText write SetColorHighlightText default clHighlightText;\r\n property Images: TCustomImageList read FImageList write SetImageList;\r\n property FullWidthItemDraw: Boolean read FFullWidthItemDraw write SetFullWidthItemDraw default False;\r\n property MultiSelect;\r\n property ItemHeight;\r\n property ParentColor;\r\n property ParentFont;\r\n property ParentShowHint;\r\n property PopupMenu;\r\n property ShowHint;\r\n property TabOrder;\r\n property TabStop;\r\n property Visible;\r\n property OnClick;\r\n property OnDblClick;\r\n property OnDragDrop;\r\n property OnDragOver;\r\n property OnEndDrag;\r\n property OnEnter;\r\n property OnExit;\r\n property OnKeyDown;\r\n property OnKeyPress;\r\n property OnKeyUp;\r\n property OnMouseDown;\r\n property OnMouseMove;\r\n property OnMouseUp;\r\n property OnStartDrag;\r\n property Sorted;\r\n property Tag;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvListComb.pas $';\r\n Revision: '$Revision: 13350 $';\r\n Date: '$Date: 2012-06-13 16:54:41 +0200 (mer. 13 juin 2012) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n Math, JvJVCLUtils;\r\n\r\ntype\r\n TWinControlAccessProtected = class(TWinControl);\r\n\r\n{ utility }\r\n\r\n{\r\nfunction DropArrowWidth: Integer;\r\nbegin\r\n Result := GetSystemMetrics(SM_CXVSCROLL);\r\nend;\r\n}\r\n\r\n\r\nfunction GetItemHeight(Font: TFont): Integer;\r\nvar\r\n DC: HDC;\r\n SaveFont: HFont;\r\n Metrics: TTextMetric;\r\nbegin\r\n DC := GetDC(HWND_DESKTOP);\r\n SaveFont := SelectObject(DC, Font.Handle);\r\n GetTextMetrics(DC, Metrics);\r\n SelectObject(DC, SaveFont);\r\n ReleaseDC(HWND_DESKTOP, DC);\r\n Result := Metrics.tmHeight;\r\nend;\r\n\r\nprocedure DrawBtnFrame(Canvas: TCanvas; ButtonStyle: TJvButtonColors; DefColor: TColor; Default: Boolean; R: TRect);\r\nconst\r\n TopStyles: array [TJvButtonColors] of TColor =\r\n (clBtnHighLight, clBtnHighLight, clBtnHighLight, clBtnFace, clBtnShadow);\r\n BottomStyles: array [TJvButtonColors] of TColor =\r\n (clBtnFace, clBtnShadow, cl3DDkShadow, cl3DDkShadow, cl3DDkShadow);\r\nbegin\r\n if Default then\r\n Frame3D(Canvas, R, DefColor, DefColor, 1)\r\n else\r\n Frame3D(Canvas, R, TopStyles[ButtonStyle], BottomStyles[ButtonStyle], 1);\r\nend;\r\n\r\nprocedure TJvImageItem.Assign(Source: TPersistent);\r\nbegin\r\n if Source is TJvImageItem then\r\n begin\r\n if not FNoTextAssign then\r\n Text := TJvImageItem(Source).Text;\r\n FImageIndex := TJvImageItem(Source).ImageIndex;\r\n FIndent := TJvImageItem(Source).Indent;\r\n FLinkedObject := TJvImageItem(Source).LinkedObject;\r\n Glyph := TJvImageItem(Source).Glyph;\r\n FColorHighlight := TJvImageItem(Source).ColorHighlight;\r\n FColorHighlightText := TJvImageItem(Source).ColorHighlightText;\r\n if TJvImageItem(Source).FFont <> nil then\r\n Font := TJvImageItem(Source).Font\r\n else\r\n FreeAndNil(FFont);\r\n ListPropertiesUsed := TJvImageItem(Source).ListPropertiesUsed;\r\n Change;\r\n end\r\n else\r\n inherited Assign(Source);\r\nend;\r\n\r\n//=== { TJvImageItem } =======================================================\r\n\r\nconstructor TJvImageItem.Create(Collection: Classes.TCollection);\r\nbegin\r\n // FGlyph and FBrush MUST be created before calling inherited or the\r\n // creation of the item from a stream (DFM for instance)\r\n // will not work correctly.\r\n FGlyph := TBitmap.Create;\r\n FBrush := TBrush.Create;\r\n FBrush.Style := bsClear;\r\n\r\n inherited Create(Collection);\r\n FImageIndex := -1;\r\n FOwner := Collection as TJvImageItems;\r\n FListPropertiesUsed := AllListPropertiesUsed;\r\n FFont := nil;\r\n FColorHighlight := clHighlight;\r\n FColorHighlightText := clHighlightText;\r\nend;\r\n\r\ndestructor TJvImageItem.Destroy;\r\nvar\r\n S: TStrings;\r\n I: Integer;\r\nbegin\r\n S := GetOwnerStrings;\r\n FOwner := nil; // indicate that the item is in the destructor\r\n // PRY 2002.06.04\r\n //if (S <> nil) and not (csDestroying in TComponent(FOwner.GetWinControl).ComponentState) then\r\n if (S <> nil) and (GetWinControl <> nil) and not (csDestroying in GetWinControl.ComponentState) then\r\n begin\r\n S.Delete(Index);\r\n for I := 0 to S.Count - 1 do\r\n TJvImageItem(S.Objects[I]).Index := I;\r\n end;\r\n FFont.Free;\r\n FGlyph.Free;\r\n FBrush.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJvImageItem.GetDisplayName: string;\r\nbegin\r\n if Text = '' then\r\n Result := inherited GetDisplayName\r\n else\r\n Result := Text;\r\nend;\r\n\r\nprocedure TJvImageItem.Change;\r\nbegin\r\n if Assigned(FOwner) then\r\n FOwner.Update(Self);\r\nend;\r\n\r\nprocedure TJvImageItem.SetImageIndex(const Value: Integer);\r\nbegin\r\n if FImageIndex <> Value then\r\n begin\r\n FImageIndex := Value;\r\n Change;\r\n end;\r\nend;\r\n\r\nprocedure TJvImageItem.SetIndent(const Value: Integer);\r\nbegin\r\n if FIndent <> Value then\r\n begin\r\n FIndent := Value;\r\n Change;\r\n end;\r\nend;\r\n\r\nfunction TJvImageItem.GetOwnerStrings: TStrings;\r\nbegin\r\n Result := nil;\r\n if Assigned(FOwner) then\r\n Result := FOwner.FStrings;\r\nend;\r\n\r\nprocedure TJvImageItem.SetText(const Value: string);\r\nvar\r\n S: TStrings;\r\n SavedOwner: TJvImageItems;\r\nbegin\r\n S := GetOwnerStrings;\r\n if Assigned(FOwner) and (FOwner.FStrings.Count <> FOwner.Count) then\r\n FOwner.FillItems;\r\n if S <> nil then\r\n begin\r\n if S[Index] <> Value then\r\n begin\r\n // do not add the item in FillItems which might be called by the draw message handler while deleting the string\r\n SavedOwner := FOwner;\r\n try\r\n FOwner := nil;\r\n S.Delete(Index);\r\n if (SavedOwner.GetOwner is TJvImageListBox) and (TJvImageListBox(SavedOwner.GetOwner).Sorted) then\r\n S.AddObject(Value, Self)\r\n else\r\n S.InsertObject(Index, Value, Self);\r\n finally\r\n FOwner := SavedOwner;\r\n end;\r\n Index := S.IndexOfObject(Self);\r\n Change;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJvImageItem.GetText: string;\r\nvar\r\n S: TStrings;\r\nbegin\r\n Result := '';\r\n if Assigned(FOwner) and (FOwner.FStrings.Count <> FOwner.Count) then\r\n FOwner.FillItems;\r\n S := GetOwnerStrings;\r\n if S <> nil then\r\n Result := S[Index];\r\nend;\r\n\r\nprocedure TJvImageItem.SetIndex(Value: Integer);\r\nvar\r\n OldIndex, TmpIndex: Integer;\r\n S: TStrings;\r\nbegin\r\n if Value <> Index then\r\n begin\r\n OldIndex := Index;\r\n inherited SetIndex(Value);\r\n S := GetOwnerStrings;\r\n TmpIndex := S.IndexOfObject(Self);\r\n if (TmpIndex > -1) and (TmpIndex <> Value) then\r\n S.Move(OldIndex,Value);\r\n end;\r\nend;\r\n\r\n//=== { TJvImageItems } ======================================================\r\n\r\nconstructor TJvImageItems.Create(AOwner: TPersistent);\r\nbegin\r\n inherited Create(AOwner, TJvImageItem);\r\n FDestroying := False;\r\nend;\r\n\r\ndestructor TJvImageItems.Destroy;\r\nbegin\r\n FDestroying := True;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJvImageItems.Add: TJvImageItem;\r\nbegin\r\n Result := TJvImageItem(inherited Add);\r\n while FStrings.Count < Count do\r\n Result.Index := FStrings.AddObject('', Result);\r\nend;\r\n\r\nfunction TJvImageItems.AddText(const Text: string): Integer;\r\nvar\r\n Item: TJvImageItem;\r\nbegin\r\n Item := Add;\r\n Item.Text := Text;\r\n Result := Item.Index;\r\nend;\r\n\r\nfunction TJvImageItems.Insert(Index: Integer): TJvImageItem;\r\nbegin\r\n Result := TJvImageItem(inherited Insert(Index));\r\n FStrings.InsertObject(Index, '', Result);\r\n Result.Index := FStrings.IndexOfObject(Result);\r\nend;\r\n\r\nprocedure TJvImageItems.InsertText(Index: Integer; const Text: string);\r\nbegin\r\n Insert(Index).Text := Text;\r\nend;\r\n\r\nprocedure TJvImageItems.Move(CurIndex, NewIndex: Integer);\r\nvar\r\n Item: TJvImageItem;\r\n ItemText: string;\r\nbegin\r\n if NewIndex < 0 then\r\n NewIndex := 0;\r\n if NewIndex > Count then\r\n NewIndex := Count;\r\n\r\n if CurIndex <> NewIndex then\r\n begin\r\n BeginUpdate;\r\n try\r\n Item := TJvImageItem(FStrings.Objects[CurIndex]);\r\n ItemText := Item.Text;\r\n FStrings.Delete(CurIndex);\r\n FStrings.InsertObject(NewIndex,ItemText,Item);\r\n Item.Index := FStrings.IndexOfObject(Item);\r\n finally\r\n EndUpdate;\r\n end;\r\n Changed;\r\n end;\r\nend;\r\n\r\nfunction TJvImageItems.IndexOfLinkedObject(ALinkedObject: TObject): Integer;\r\nbegin\r\n for Result := 0 to Count - 1 do\r\n if Items[Result].LinkedObject = ALinkedObject then\r\n Exit;\r\n Result := -1;\r\nend;\r\n\r\nprocedure TJvImageItems.Assign(Source: TPersistent);\r\nvar\r\n I: Integer;\r\nbegin\r\n if Source is TJvImageItems then\r\n begin\r\n BeginUpdate;\r\n try\r\n Clear;\r\n for I := 0 to TJvImageItems(Source).Count - 1 do\r\n Add.Assign(TJvImageItems(Source)[I]);\r\n finally\r\n EndUpdate;\r\n end;\r\n end\r\n else\r\n if Source is TStrings then\r\n begin\r\n BeginUpdate;\r\n try\r\n Clear;\r\n for I := 0 to TStrings(Source).Count - 1 do\r\n Add.Text := TStrings(Source)[I];\r\n finally\r\n EndUpdate;\r\n end;\r\n end\r\n else\r\n inherited Assign(Source);\r\nend;\r\n\r\nfunction TJvImageItems.GetItems(Index: Integer): TJvImageItem;\r\nbegin\r\n Result := TJvImageItem(inherited Items[Index]);\r\nend;\r\n\r\nprocedure TJvImageItems.SetItems(Index: Integer; const Value: TJvImageItem);\r\nbegin\r\n inherited Items[Index] := Value;\r\nend;\r\n\r\nfunction TJvImageItems.GetObjects(Index: Integer): TObject;\r\nbegin\r\n Result := Items[Index].LinkedObject;\r\nend;\r\n\r\nprocedure TJvImageItems.SetObjects(Index: Integer; const Value: TObject);\r\nbegin\r\n Items[Index].LinkedObject := Value;\r\nend;\r\n\r\nprocedure TJvImageItems.Update(Item: TCollectionItem);\r\nvar\r\n W: TPersistent;\r\n Obj: IJvResetItemHeight;\r\nbegin\r\n if UpdateCount <> 0 then\r\n Exit;\r\n inherited Update(Item);\r\n W := GetOwner;\r\n if Supports(W, IJvResetItemHeight, Obj) then\r\n Obj.ResetItemHeight\r\n else\r\n if W is TWinControl then\r\n TWinControl(W).Invalidate;\r\nend;\r\n\r\nprocedure TJvImageItems.BeginUpdate;\r\nbegin\r\n inherited BeginUpdate;\r\n if not FDestroying then\r\n FStrings.BeginUpdate;\r\nend;\r\n\r\nprocedure TJvImageItems.EndUpdate;\r\nbegin\r\n if not FDestroying then\r\n FStrings.EndUpdate;\r\n inherited EndUpdate;\r\nend;\r\n\r\nprocedure TJvImageItems.FillItems;\r\nvar\r\n Index: Integer;\r\nbegin\r\n for Index := 0 to Count - 1 do\r\n if Items[Index].FOwner = Self then // not in destructor\r\n if FStrings.IndexOfObject(Items[Index]) = -1 then\r\n FStrings.InsertObject(Index, '', Items[Index]);\r\n for Index := 0 to FStrings.Count - 1 do\r\n TJvImageItem(FStrings.Objects[Index]).Index := Index;\r\nend;\r\n\r\nfunction TJvImageItems.AddObject(const Text: string; ALinkedObject: TObject): Integer;\r\nvar\r\n Item: TJvImageItem;\r\nbegin\r\n Item := Add;\r\n Item.Text := Text;\r\n Item.LinkedObject := ALinkedObject;\r\n Result := Item.Index;\r\nend;\r\n\r\nprocedure TJvImageItems.InsertObject(Index: Integer; const Text: string; ALinkedObject: TObject);\r\nvar\r\n Item: TJvImageItem;\r\nbegin\r\n Item := Insert(Index);\r\n Item.Text := Text;\r\n Item.LinkedObject := ALinkedObject;\r\nend;\r\n\r\nprocedure TJvImageItems.Sort(SortProc: TCollectionSortProc);\r\nbegin\r\n CollectionSort(Self, SortProc);\r\nend;\r\n\r\nprocedure TJvImageItems.Notify(Item: TCollectionItem;\r\n Action: TCollectionNotification);\r\nbegin\r\n inherited Notify(Item, Action);\r\n\r\n if FDestroying then\r\n Exit;\r\n\r\n // For Added and Deleting, the TListBoxStrings class will deal with\r\n // notifying the list box. In the case of Extracting though, we must\r\n // remove the item ourselves or the count in FStrings will be out of\r\n // sync with the count in this class.\r\n case Action of\r\n cnAdded: ;\r\n cnExtracting: FStrings.Delete(FStrings.IndexOfObject(Item));\r\n cnDeleting: ;\r\n end;\r\nend;\r\n\r\n//=== { TJvImageComboBox } ===================================================\r\n\r\nconstructor TJvImageComboBox.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FItems := TJvImageItems.Create(Self);\r\n FItems.FStrings := inherited Items;\r\n FImageWidth := 0;\r\n FImageHeight := 0;\r\n FImageList := nil;\r\n FDefaultIndent := 0;\r\n FButtonFrame := False;\r\n Style := csOwnerDrawVariable;\r\n Color := clWindow;\r\n FColorHighlight := clHighlight;\r\n FColorHighlightText := clHighlightText;\r\n FCanvas := TControlCanvas.Create;\r\n FCanvas.Control := Self;\r\n ResetItemHeight;\r\n FChangeLink := TChangeLink.Create;\r\n FChangeLink.OnChange := ImageListChange;\r\n\r\n FFullWidthItemDraw := False;\r\nend;\r\n\r\ndestructor TJvImageComboBox.Destroy;\r\nbegin\r\n FItems.Free;\r\n FChangeLink.Free;\r\n inherited Destroy;\r\n // (rom) destroy Canvas AFTER inherited Destroy\r\n FCanvas.Free;\r\nend;\r\n\r\n\r\nfunction TJvImageComboBox.GetCanvas: TCanvas;\r\nbegin\r\n Result := FCanvas;\r\nend;\r\n\r\n\r\nprocedure TJvImageComboBox.ImageListChange(Sender: TObject);\r\nbegin\r\n // Invalidate;\r\nend;\r\n\r\nprocedure TJvImageComboBox.SetImageList(Value: TCustomImageList);\r\nbegin\r\n if FImageList <> Value then\r\n begin\r\n ReplaceImageListReference(Self, Value, FImageList, FChangeLink);\r\n ResetItemHeight;\r\n RecreateWnd;\r\n end;\r\nend;\r\n\r\nprocedure TJvImageComboBox.SetFullWidthItemDraw(const Value: Boolean);\r\nbegin\r\n if Value <> FFullWidthItemDraw then\r\n begin\r\n FFullWidthItemDraw := Value;\r\n Invalidate\r\n end;\r\nend;\r\n\r\n\r\nprocedure TJvImageComboBox.CreateWnd;\r\nbegin\r\n inherited CreateWnd;\r\n SetDroppedWidth(FDroppedWidth);\r\nend;\r\n\r\nprocedure TJvImageComboBox.RecreateWnd;\r\nbegin\r\n inherited RecreateWnd;\r\n SetDroppedWidth(FDroppedWidth);\r\nend;\r\n\r\n\r\n\r\n\r\n\r\nprocedure TJvImageComboBox.Notification(AComponent: TComponent; Operation: TOperation);\r\nbegin\r\n inherited Notification(AComponent, Operation);\r\n if (Operation = opRemove) and (AComponent = FImageList) then\r\n FImageList := nil;\r\nend;\r\n\r\n\r\nprocedure TJvImageComboBox.CNDrawItem(var Msg: TWMDrawItem);\r\nvar\r\n State: TOwnerDrawState;\r\nbegin\r\n if csDestroying in ComponentState then\r\n Exit;\r\n with Msg.DrawItemStruct^ do\r\n begin\r\n State := [];\r\n if (itemState and ODS_CHECKED) <> 0 then\r\n Include(State, odChecked);\r\n if (itemState and ODS_COMBOBOXEDIT) <> 0 then\r\n Include(State, odComboBoxEdit);\r\n if (itemState and ODS_DEFAULT) <> 0 then\r\n Include(State, odDefault);\r\n if (itemState and ODS_DISABLED) <> 0 then\r\n Include(State, odDisabled);\r\n if (itemState and ODS_FOCUS) <> 0 then\r\n Include(State, odFocused);\r\n if (itemState and ODS_GRAYED) <> 0 then\r\n Include(State, odGrayed);\r\n if (itemState and ODS_SELECTED) <> 0 then\r\n Include(State, odSelected);\r\n\r\n FCanvas.Handle := hDC;\r\n FCanvas.Font := Font;\r\n FCanvas.Brush := Brush;\r\n\r\n if (Integer(itemID) >= 0) then\r\n begin\r\n if Items[itemID].Brush.Style <> bsClear then\r\n FCanvas.Brush := Items[itemID].Brush;\r\n if (odSelected in State) then\r\n begin\r\n FCanvas.Brush.Color := FColorHighlight;\r\n FCanvas.Font.Color := FColorHighlightText;\r\n end;\r\n\r\n DrawItem(itemID, rcItem, State)\r\n end\r\n else\r\n begin\r\n FCanvas.FillRect(rcItem);\r\n end;\r\n\r\n FCanvas.Handle := 0;\r\n end;\r\nend;\r\n\r\n\r\n\r\nprocedure TJvImageComboBox.DrawItem(Index: Integer; R: TRect; State: TOwnerDrawState);\r\n\r\n\r\nvar\r\n Offset, Tmp: Integer;\r\n TmpCol: TColor;\r\n TmpR, OrigR: TRect;\r\n SavedColor: TColor;\r\nbegin\r\n if csDestroying in ComponentState then\r\n Exit;\r\n SavedColor := Canvas.Font.Color;\r\n\r\n if odSelected in State then\r\n begin\r\n Canvas.Brush.Color := FColorHighlight;\r\n Canvas.Font.Color := FColorHighlightText;\r\n end;\r\n\r\n if State <> [] then\r\n Canvas.Font.Color := SavedColor;\r\n OrigR := R;\r\n with Canvas do\r\n begin\r\n if not FullWidthItemDraw then\r\n begin\r\n TmpCol := Brush.Color;\r\n Brush.Color := Color;\r\n FillRect(R);\r\n Brush.Color := TmpCol;\r\n end;\r\n\r\n // (p3) don't draw indentation for edit item unless explicitly told to do so\r\n if not (odComboBoxEdit in State) or IndentSelected then\r\n R.Left := R.Left + Items[Index].Indent;\r\n\r\n if not Items[Index].Glyph.Empty then\r\n begin\r\n Offset := ((R.Bottom - R.Top) - GetImageHeight(Index)) div 2;\r\n\r\n Canvas.Draw(R.Left + 2, R.Top + Offset, Items[Index].Glyph);\r\n\r\n if FButtonFrame then\r\n begin\r\n TmpR := Rect(R.Left, R.Top, R.Left + FImageList.Width + 4, R.Top + FImageList.Height + 4);\r\n DrawBtnFrame(Canvas, FButtonStyle, Color,\r\n not ((odFocused in State) and not (odComboBoxEdit in State)), TmpR);\r\n end;\r\n\r\n Inc(R.Left, GetImageWidth(Index) + 8);\r\n OrigR.Left := R.Left;\r\n end\r\n else\r\n if Assigned(FImageList) then\r\n begin\r\n Tmp := Items[Index].ImageIndex;\r\n // R.Left := R.Left + Items[Index].Indent;\r\n Offset := ((R.Bottom - R.Top) - GetImageHeight(Index)) div 2;\r\n // PRY 2002.06.04\r\n //FImageList.Draw(FCanvas, R.Left + 2, R.Top + Offset, Tmp, dsTransparent, itImage);\r\n FImageList.Draw(Canvas, R.Left + 2, R.Top + Offset, Tmp, dsTransparent, itImage);\r\n // PRY END\r\n if FButtonFrame then\r\n begin\r\n TmpR := Rect(R.Left, R.Top, R.Left + FImageList.Width + 4, R.Top + FImageList.Height + 4);\r\n DrawBtnFrame(Canvas, FButtonStyle, Color,\r\n not ((Tmp in [0..FImageList.Count - 1]) and\r\n (odFocused in State) and not (odComboBoxEdit in State)), TmpR);\r\n end;\r\n Inc(R.Left, GetImageWidth(Index) + 8);\r\n OrigR.Left := R.Left;\r\n end;\r\n\r\n R.Right := R.Left + TextWidth(Items[Index].Text);\r\n InflateRect(R, 2, -1);\r\n if Length(Items[Index].Text) > 0 then\r\n begin\r\n Inc(R.Right,2);\r\n if FullWidthItemDraw then\r\n FillRect(OrigR)\r\n else\r\n FillRect(R);\r\n Inc(R.Left, 2);\r\n DrawText(Canvas, Items[Index].Text, Length(Items[Index].Text), R,\r\n DT_SINGLELINE or DT_NOPREFIX or DT_VCENTER);\r\n Dec(R.Left, 2);\r\n if (odSelected in State) and (Color <> FColorHighlight) then\r\n begin\r\n if FullWidthItemDraw then\r\n DrawFocusRect(OrigR)\r\n else\r\n DrawFocusRect(R);\r\n end;\r\n end\r\n else\r\n begin\r\n FillRect(OrigR);\r\n if (odSelected in State) and (Color <> FColorHighlight) then\r\n DrawFocusRect(OrigR);\r\n end;\r\n end;\r\nend;\r\n\r\n\r\nprocedure TJvImageComboBox.MeasureItem(Index: Integer; var Height: Integer);\r\nbegin\r\n Height := Max(GetItemHeight(Font) + 4, GetImageHeight(Index) + (Ord(ButtonFrame) * 4));\r\n// if Assigned(FImageList) then\r\n// Height := Max(Height,FImageList.Height);\r\nend;\r\n\r\n\r\n\r\n\r\nprocedure TJvImageComboBox.SetColorHighlight(Value: TColor);\r\nbegin\r\n if FColorHighlight <> Value then\r\n begin\r\n FColorHighlight := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvImageComboBox.SetColorHighlightText(Value: TColor);\r\nbegin\r\n if FColorHighlightText <> Value then\r\n begin\r\n FColorHighlightText := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\n\r\n\r\nfunction TJvImageComboBox.GetDroppedWidth: Integer;\r\nbegin\r\n HandleNeeded;\r\n Result := SendMessage(Handle, CB_GETDROPPEDWIDTH, 0, 0);\r\nend;\r\n\r\nprocedure TJvImageComboBox.SetDroppedWidth(Value: Integer);\r\nbegin\r\n HandleNeeded;\r\n FDroppedWidth := SendMessage(Handle, CB_SETDROPPEDWIDTH, Value, 0);\r\nend;\r\n\r\n\r\n\r\n\r\n\r\nprocedure TJvImageComboBox.FontChanged;\r\nbegin\r\n inherited FontChanged;\r\n ResetItemHeight;\r\n RecreateWnd;\r\nend;\r\n\r\nprocedure TJvImageComboBox.ResetItemHeight;\r\nvar\r\n MaxImageHeight: Integer;\r\n I: Integer;\r\nbegin\r\n MaxImageHeight := GetImageHeight(-1);\r\n for I := 0 to FItems.Count-1 do\r\n begin\r\n if GetImageHeight(I) > MaxImageHeight then\r\n MaxImageHeight := GetImageHeight(I);\r\n end;\r\n ItemHeight := Max(GetItemHeight(Font) + 4, MaxImageHeight + Ord(ButtonFrame) * 4);\r\nend;\r\n\r\nprocedure TJvImageComboBox.Change;\r\nbegin\r\n if Assigned(FOnChange) then\r\n FOnChange(Self);\r\nend;\r\n\r\n\r\nprocedure TJvImageComboBox.CNCommand(var Msg: TWMCommand);\r\nbegin\r\n inherited;\r\n // If OnSelect is Assigned, OnChange is not triggered\r\n // so we do it ourselves. But to avoid triggering OnChange twice (Mantis 3175)\r\n // for the same change of Item, we only do it if OnSelect is Assigned.\r\n case Msg.NotifyCode of\r\n CBN_SELCHANGE:\r\n if Assigned(OnSelect) then\r\n Change;\r\n end;\r\nend;\r\n\r\n\r\nprocedure TJvImageComboBox.EnabledChanged;\r\nconst\r\n EnableColors: array [Boolean] of TColor = (clBtnFace, clWindow);\r\nbegin\r\n inherited EnabledChanged;\r\n Color := EnableColors[Enabled];\r\nend;\r\n\r\nprocedure TJvImageComboBox.MouseEnter(AControl: TControl);\r\nbegin\r\n inherited MouseEnter(AControl);\r\n FMouseInControl := True;\r\nend;\r\n\r\nprocedure TJvImageComboBox.MouseLeave(AControl: TControl);\r\nbegin\r\n FMouseInControl := False;\r\n inherited MouseLeave(AControl);\r\nend;\r\n\r\nprocedure TJvImageComboBox.SetDefaultIndent(const Value: Integer);\r\nbegin\r\n if FDefaultIndent <> Value then\r\n begin\r\n FDefaultIndent := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvImageComboBox.SetItems(const Value: TJvImageItems);\r\nbegin\r\n FItems.Assign(Value);\r\n FItems.Update(nil);\r\nend;\r\n\r\nfunction NamesSorter(Item1, Item2: TCollectionItem): Integer;\r\nbegin\r\n Result := CompareStr(Item1.DisplayName, Item2.DisplayName);\r\nend;\r\n\r\nprocedure TJvImageComboBox.SetSorted(const Value: Boolean);\r\nbegin\r\n if FSorted <> Value then\r\n begin\r\n FSorted := Value;\r\n\r\n if FSorted then\r\n FItems.Sort(NamesSorter);\r\n end;\r\nend;\r\n\r\nprocedure TJvImageComboBox.SetIndentSelected(const Value: Boolean);\r\nbegin\r\n if FIndentSelected <> Value then\r\n begin\r\n FIndentSelected := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nfunction TJvImageComboBox.GetImageWidth(Index: Integer): Integer;\r\nbegin\r\n if (Index > -1) and not Items[Index].Glyph.Empty then\r\n Result := Items[Index].Glyph.Width\r\n else\r\n if Assigned(FImageList) then\r\n Result := FImageList.Width\r\n else\r\n Result := FImageWidth;\r\nend;\r\n\r\nfunction TJvImageComboBox.GetSorted: Boolean;\r\nbegin\r\n Result := FSorted;\r\nend;\r\n\r\nfunction TJvImageComboBox.GetImageHeight(Index: Integer): Integer;\r\nbegin\r\n if (Index > -1) and not Items[Index].Glyph.Empty then\r\n Result := Items[Index].Glyph.Height\r\n else\r\n if Assigned(FImageList) then\r\n Result := FImageList.Height\r\n else\r\n Result := FImageHeight;\r\nend;\r\n\r\n//=== { TJvImageListBox } ====================================================\r\n\r\nconstructor TJvImageListBox.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n // ControlStyle := ControlStyle + [csAcceptsControls];\r\n SetBounds(0, 0, 121, 97);\r\n FItems := TJvImageItems.Create(Self);\r\n FItems.FStrings := inherited Items;\r\n Color := clWindow;\r\n FColorHighlight := clHighlight;\r\n FColorHighlightText := clHighlightText;\r\n FImageWidth := 0;\r\n FImageHeight := 0;\r\n FAlignment := taLeftJustify;\r\n\r\n FButtonFrame := False;\r\n Style := lbOwnerDrawFixed;\r\n FCanvas := TControlCanvas.Create;\r\n FCanvas.Control := Self;\r\n ResetItemHeight;\r\n FChangeLink := TChangeLink.Create;\r\n FChangeLink.OnChange := ImageListChange;\r\n\r\n FFullWidthItemDraw := False;\r\nend;\r\n\r\ndestructor TJvImageListBox.Destroy;\r\nbegin\r\n FItems.Free;\r\n FChangeLink.Free;\r\n inherited Destroy;\r\n // (rom) destroy Canvas AFTER inherited Destroy\r\n FCanvas.Free;\r\nend;\r\n\r\n\r\nfunction TJvImageListBox.GetCanvas: TCanvas;\r\nbegin\r\n Result := FCanvas;\r\nend;\r\n\r\n\r\nprocedure TJvImageListBox.ImageListChange;\r\nbegin\r\n // Invalidate;\r\nend;\r\n\r\nprocedure TJvImageListBox.SetImageList(Value: TCustomImageList);\r\nbegin\r\n if ReplaceImageListReference(Self, Value, FImageList, FChangeLink) then\r\n begin\r\n ResetItemHeight;\r\n RecreateWnd;\r\n end;\r\nend;\r\n\r\nprocedure TJvImageListBox.SetFullWidthItemDraw(const Value: Boolean);\r\nbegin\r\n if Value <> FFullWidthItemDraw then\r\n begin\r\n FFullWidthItemDraw := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvImageListBox.SetAlignment(Value: TAlignment);\r\nbegin\r\n if FAlignment <> Value then\r\n begin\r\n FAlignment := Value;\r\n ResetItemHeight;\r\n end;\r\nend;\r\n\r\n\r\nprocedure TJvImageListBox.CreateWnd;\r\nbegin\r\n inherited CreateWnd;\r\n Items.FillItems;\r\n SetBkMode(FCanvas.Handle, TRANSPARENT);\r\nend;\r\n\r\n\r\nprocedure TJvImageListBox.Notification(AComponent: TComponent; Operation: TOperation);\r\nbegin\r\n inherited Notification(AComponent, Operation);\r\n if (Operation = opRemove) and (AComponent = FImageList) then\r\n FImageList := nil;\r\nend;\r\n\r\nprocedure TJvImageListBox.SetColorHighlight(Value: TColor);\r\nbegin\r\n if FColorHighlight <> Value then\r\n begin\r\n FColorHighlight := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvImageListBox.SetColorHighlightText(Value: TColor);\r\nbegin\r\n if FColorHighlightText <> Value then\r\n begin\r\n FColorHighlightText := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\n\r\nprocedure TJvImageListBox.CNDrawItem(var Msg: TWMDrawItem);\r\nvar\r\n State: TOwnerDrawState;\r\nbegin\r\n if csDestroying in ComponentState then\r\n Exit;\r\n with Msg.DrawItemStruct^ do\r\n begin\r\n State := [];\r\n if (itemState and ODS_CHECKED) <> 0 then\r\n Include(State, odChecked);\r\n if (itemState and ODS_COMBOBOXEDIT) <> 0 then\r\n Include(State, odComboBoxEdit);\r\n if (itemState and ODS_DEFAULT) <> 0 then\r\n Include(State, odDefault);\r\n if (itemState and ODS_DISABLED) <> 0 then\r\n Include(State, odDisabled);\r\n if (itemState and ODS_FOCUS) <> 0 then\r\n Include(State, odFocused);\r\n if (itemState and ODS_GRAYED) <> 0 then\r\n Include(State, odGrayed);\r\n if (itemState and ODS_SELECTED) <> 0 then\r\n Include(State, odSelected);\r\n FCanvas.Handle := hDC;\r\n FCanvas.Font := Font;\r\n FCanvas.Brush := Brush;\r\n\r\n if (Integer(itemID) >= 0) then\r\n begin\r\n if Items[Integer(itemID)].Brush.Style <> bsClear then\r\n begin\r\n FCanvas.Brush := Items[Integer(itemID)].Brush;\r\n FCanvas.FillRect(rcItem);\r\n end;\r\n\r\n if (odSelected in State) then\r\n begin\r\n FCanvas.Brush.Color := Items[Integer(itemID)].ColorHighlight;\r\n FCanvas.Font.Color := Items[Integer(itemID)].ColorHighlightText;\r\n end;\r\n\r\n DrawItem(itemID, rcItem, State)\r\n end\r\n else\r\n begin\r\n FCanvas.FillRect(rcItem);\r\n end;\r\n\r\n FCanvas.Handle := 0;\r\n end;\r\nend;\r\n\r\n\r\n\r\nprocedure TJvImageListBox.DrawItem(Index: Integer; Rect: TRect; State: TOwnerDrawState);\r\n\r\n\r\nvar\r\n SavedColor: TColor;\r\nbegin\r\n if csDestroying in ComponentState then\r\n Exit;\r\n SavedColor := Canvas.Font.Color;\r\n Canvas.Font.Assign(Items[Index].Font);\r\n\r\n if State <> [] then\r\n Canvas.Font.Color := SavedColor;\r\n case FAlignment of\r\n taLeftJustify:\r\n DrawLeftGlyph(Index, Rect, State);\r\n taRightJustify:\r\n DrawRightGlyph(Index, Rect, State);\r\n taCenter:\r\n DrawCenteredGlyph(Index, Rect, State);\r\n end;\r\nend;\r\n\r\nprocedure TJvImageListBox.DrawCenteredGlyph(Index: Integer; R: TRect; State: TOwnerDrawState);\r\nvar\r\n Tmp, Tmp2: Integer;\r\n TmpCol: TColor;\r\n TmpR, OrigR: TRect;\r\nbegin\r\n if csDestroying in ComponentState then\r\n Exit;\r\n OrigR := R;\r\n with Canvas do\r\n begin\r\n if not FullWidthItemDraw then\r\n begin\r\n TmpCol := Brush.Color;\r\n Brush.Color := Color;\r\n FillRect(R);\r\n Brush.Color := TmpCol;\r\n end;\r\n\r\n if not Items[Index].Glyph.Empty then\r\n begin\r\n Tmp := ((R.Right - R.Left) - GetImageWidth(Index)) div 2;\r\n\r\n Draw(R.Left + Tmp, R.Top + 2, Items[Index].Glyph);\r\n\r\n if FButtonFrame then\r\n begin\r\n TmpR := Rect(R.Left + Tmp - 2, R.Top + 2,\r\n R.Left + Tmp + FImageList.Width + 2, R.Top + FImageList.Height + 2);\r\n DrawBtnFrame(Canvas, FButtonStyle, Color, not (odSelected in State), TmpR);\r\n end;\r\n InflateRect(R, 1, -4);\r\n end\r\n else\r\n if Assigned(FImageList) then\r\n begin\r\n Tmp := ((R.Right - R.Left) - GetImageWidth(Index)) div 2;\r\n Tmp2 := Items[Index].ImageIndex;\r\n // PRY 2002.06.04\r\n //FImageList.Draw(FCanvas, R.Left + Tmp, R.Top + 2, Tmp2, dsTransparent, itImage);\r\n FImageList.Draw(Canvas, R.Left + Tmp, R.Top + 2, Tmp2, dsTransparent, itImage);\r\n // PRY END\r\n if FButtonFrame then\r\n begin\r\n TmpR := Rect(R.Left + Tmp - 2, R.Top + 2,\r\n R.Left + Tmp + FImageList.Width + 2, R.Top + FImageList.Height + 2);\r\n DrawBtnFrame(Canvas, FButtonStyle, Color,\r\n not ((Tmp2 in [0..FImageList.Count - 1]) and (odSelected in State)), TmpR);\r\n end;\r\n InflateRect(R, 1, -4);\r\n end;\r\n R.Left := ((R.Right - R.Left) - TextWidth(Items[Index].Text)) div 2 - 1;\r\n R.Right := R.Left + TextWidth(Items[Index].Text) + 1;\r\n R.Top := R.Bottom - TextHeight(Items[Index].Text) - 1;\r\n if Length(Items[Index].Text) > 0 then\r\n begin\r\n if FullWidthItemDraw then\r\n FillRect(OrigR)\r\n else\r\n FillRect(R);\r\n\r\n DrawText(Canvas, Items[Index].Text, Length(Items[Index].Text), R,\r\n DT_SINGLELINE or DT_NOPREFIX or DT_CENTER or DT_BOTTOM);\r\n\r\n if (odSelected in State) and (Color <> FColorHighlight) then\r\n begin\r\n if FullWidthItemDraw then\r\n DrawFocusRect(OrigR)\r\n else\r\n DrawFocusRect(R);\r\n end;\r\n end\r\n else\r\n begin\r\n FillRect(OrigR);\r\n if (odSelected in State) and (Color <> FColorHighlight) then\r\n DrawFocusRect(OrigR);\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvImageListBox.DrawLeftGlyph(Index: Integer; R: TRect; State: TOwnerDrawState);\r\nvar\r\n Offset, Tmp: Integer;\r\n TmpCol: TColor;\r\n TmpR, OrigR: TRect;\r\nbegin\r\n if csDestroying in ComponentState then\r\n Exit;\r\n OrigR := R;\r\n with Canvas do\r\n begin\r\n if not FullWidthItemDraw then\r\n begin\r\n TmpCol := Brush.Color;\r\n Brush.Color := Color;\r\n FillRect(R);\r\n Brush.Color := TmpCol;\r\n end;\r\n\r\n if not Items[Index].Glyph.Empty then\r\n begin\r\n Offset := ((R.Bottom - R.Top) - GetImageHeight(Index)) div 2;\r\n\r\n Draw(R.Left + 2, R.Top + Offset, Items[Index].Glyph);\r\n\r\n if FButtonFrame then\r\n begin\r\n TmpR := Rect(R.Left, R.Top, R.Left + FImageList.Width + 4, R.Top + FImageList.Height + 4);\r\n DrawBtnFrame(Canvas, FButtonStyle, Color, not (odSelected in State), TmpR);\r\n end;\r\n\r\n Inc(R.Left, GetImageWidth(Index) + 8);\r\n OrigR.Left := R.Left;\r\n end\r\n else\r\n if Assigned(FImageList) then\r\n begin\r\n Offset := ((R.Bottom - R.Top) - GetImageHeight(Index)) div 2;\r\n Tmp := Items[Index].ImageIndex;\r\n // PRY 2002.06.04\r\n //FImageList.Draw(FCanvas, R.Left + 2, R.Top + Offset, Tmp, dsTransparent, itImage);\r\n FImageList.Draw(Canvas, R.Left + 2, R.Top + Offset, Tmp, dsTransparent, itImage);\r\n // PRY END\r\n if FButtonFrame then\r\n begin\r\n TmpR := Rect(R.Left, R.Top, R.Left + FImageList.Width + 4, R.Top + FImageList.Height + 4);\r\n DrawBtnFrame(Canvas, FButtonStyle, Color,\r\n not ((Tmp in [0..FImageList.Count - 1]) and (odSelected in State)), TmpR);\r\n end;\r\n Inc(R.Left, GetImageWidth(Index) + 8);\r\n OrigR.Left := R.Left;\r\n end;\r\n\r\n R.Right := R.Left + TextWidth(Items[Index].Text);\r\n InflateRect(R, 2, -1);\r\n if Length(Items[Index].Text) > 0 then\r\n begin\r\n Inc(R.Right, 2);\r\n if FullWidthItemDraw then\r\n FillRect(OrigR)\r\n else\r\n FillRect(R);\r\n Inc(R.Left, 2);\r\n DrawText(Canvas, Items[Index].Text, Length(Items[Index].Text), R,\r\n DT_SINGLELINE or DT_NOPREFIX or DT_VCENTER);\r\n Dec(R.Left, 2);\r\n if (odSelected in State) and (Color <> FColorHighlight) then\r\n begin\r\n if FullWidthItemDraw then\r\n DrawFocusRect(OrigR)\r\n else\r\n DrawFocusRect(R);\r\n end;\r\n end\r\n else\r\n begin\r\n FillRect(OrigR);\r\n if (odSelected in State) and (Color <> FColorHighlight) then\r\n DrawFocusRect(OrigR);\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvImageListBox.DrawRightGlyph(Index: Integer; R: TRect; State: TOwnerDrawState);\r\nvar\r\n Offset, Tmp: Integer;\r\n TmpCol: TColor;\r\n TmpR, OrigR: TRect;\r\nbegin\r\n if csDestroying in ComponentState then\r\n Exit;\r\n OrigR := R;\r\n with Canvas do\r\n begin\r\n if not FullWidthItemDraw then\r\n begin\r\n TmpCol := Brush.Color;\r\n Brush.Color := Color;\r\n FillRect(R);\r\n Brush.Color := TmpCol;\r\n end;\r\n\r\n if not Items[Index].Glyph.Empty then\r\n begin\r\n Offset := ((R.Bottom - R.Top) - GetImageHeight(Index)) div 2;\r\n\r\n Draw(R.Right - (GetImageWidth(Index) + 2), R.Top + Offset, Items[Index].Glyph);\r\n\r\n if FButtonFrame then\r\n begin\r\n TmpR := Rect(R.Right - (FImageList.Width + 2) - 2,\r\n R.Top + Offset - 2, R.Right - 2, R.Top + Offset + FImageList.Height + 2);\r\n DrawBtnFrame(Canvas, FButtonStyle, Color, not (odSelected in State), TmpR);\r\n end;\r\n\r\n Dec(R.Right, FImageList.Width + 4);\r\n OrigR.Right := R.Right;\r\n end\r\n else\r\n if Assigned(FImageList) then\r\n begin\r\n Tmp := Items[Index].ImageIndex;\r\n\r\n Offset := ((R.Bottom - R.Top) - GetImageHeight(Index)) div 2;\r\n // PRY 2002.06.04\r\n //FImageList.Draw(FCanvas, R.Right - (FWidth + 2), R.Top + Offset, Tmp, dsTransparent, itImage);\r\n FImageList.Draw(Canvas, R.Right - (GetImageWidth(Index) + 2), R.Top + Offset, Tmp, dsTransparent, itImage);\r\n // PRY END\r\n if FButtonFrame then\r\n begin\r\n TmpR := Rect(R.Right - (FImageList.Width + 2) - 2,\r\n R.Top + Offset - 2, R.Right - 2, R.Top + Offset + FImageList.Height + 2);\r\n DrawBtnFrame(Canvas, FButtonStyle, Color,\r\n not ((Tmp in [0..FImageList.Count - 1]) and (odSelected in State)), TmpR);\r\n end;\r\n Dec(R.Right, FImageList.Width + 4);\r\n OrigR.Right := R.Right;\r\n end;\r\n\r\n R.Left := R.Right - TextWidth(Items[Index].Text);\r\n // R.Right := R.Left + TextWidth(Items[Index].Text);\r\n InflateRect(R, 2, -1);\r\n if Length(Items[Index].Text) > 0 then\r\n begin\r\n Dec(R.Right, 2);\r\n if FullWidthItemDraw then\r\n FillRect(OrigR)\r\n else\r\n FillRect(R);\r\n DrawText(Canvas, Items[Index].Text, Length(Items[Index].Text), R,\r\n DT_SINGLELINE or DT_NOPREFIX or DT_VCENTER or DT_RIGHT);\r\n Inc(R.Right, 2);\r\n if (odSelected in State) and (Color <> FColorHighlight) then\r\n begin\r\n if FullWidthItemDraw then\r\n DrawFocusRect(OrigR)\r\n else\r\n DrawFocusRect(R);\r\n end;\r\n end\r\n else\r\n begin\r\n FillRect(OrigR);\r\n if (odSelected in State) and (Color <> FColorHighlight) then\r\n DrawFocusRect(OrigR);\r\n end;\r\n end;\r\nend;\r\n\r\n\r\nprocedure TJvImageListBox.MeasureItem(Index: Integer; var Height: Integer);\r\nbegin\r\n Height := Max(GetItemHeight(Font) + 4, GetImageHeight(Index) + Ord(ButtonFrame) * 4);\r\nend;\r\n\r\n\r\n\r\n\r\nprocedure TJvImageListBox.FontChanged;\r\nbegin\r\n inherited FontChanged;\r\n ResetItemHeight;\r\n RecreateWnd;\r\nend;\r\n\r\nprocedure TJvImageListBox.ResetItemHeight;\r\nvar\r\n MaxImageHeight: Integer;\r\n I: Integer;\r\nbegin\r\n MaxImageHeight := GetImageHeight(-1);\r\n for I := 0 to FItems.Count - 1 do\r\n begin\r\n if GetImageHeight(I) > MaxImageHeight then\r\n MaxImageHeight := GetImageHeight(I);\r\n end;\r\n case FAlignment of\r\n taLeftJustify, taRightJustify:\r\n ItemHeight := Max(ItemHeight, Max(GetItemHeight(Font) + 4, MaxImageHeight + Ord(ButtonFrame) * 4));\r\n taCenter:\r\n ItemHeight := Max(ItemHeight, Max(GetItemHeight(Font) + 4, MaxImageHeight + Ord(ButtonFrame) * 8));\r\n end;\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvImageListBox.Resize;\r\nbegin\r\n inherited Resize;\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvImageListBox.SetItems(const Value: TJvImageItems);\r\nbegin\r\n FItems.Assign(Value);\r\n FItems.Update(nil);\r\nend;\r\n\r\nfunction TJvImageListBox.GetImageWidth(Index: Integer): Integer;\r\nbegin\r\n if (Index > -1) and not Items[Index].Glyph.Empty then\r\n Result := Items[Index].Glyph.Width\r\n else\r\n if Assigned(FImageList) then\r\n Result := FImageList.Width\r\n else\r\n Result := FImageWidth;\r\nend;\r\n\r\nfunction TJvImageListBox.GetImageHeight(Index: Integer): Integer;\r\nbegin\r\n if (Index > -1) and not Items[Index].Glyph.Empty then\r\n Result := Items[Index].Glyph.Height\r\n else\r\n if Assigned(FImageList) then\r\n Result := FImageList.Height\r\n else\r\n Result := FImageHeight;\r\nend;\r\n\r\nprocedure TJvImageItem.SetBrush(const Value: TBrush);\r\nbegin\r\n FBrush.Assign(Value);\r\nend;\r\n\r\nprocedure TJvImageItem.SetFont(const Value: TFont);\r\nbegin\r\n if not (puFont in FListPropertiesUsed) then\r\n Font.Assign(Value);\r\nend;\r\n\r\nfunction TJvImageItem.GetFont: TFont;\r\nbegin\r\n if puFont in FListPropertiesUsed then\r\n begin\r\n Result := TWinControlAccessProtected(GetWinControl).Font\r\n end\r\n else\r\n begin\r\n if not Assigned(FFont) then\r\n begin\r\n FFont := TFont.Create;\r\n FFont.OnChange := FontChange;\r\n FFont.Assign(TWinControlAccessProtected(GetWinControl).Font);\r\n end;\r\n Result := FFont;\r\n end;\r\nend;\r\n\r\nfunction TJvImageItem.GetGlyph: TBitmap;\r\nbegin\r\n Result := FGlyph;\r\nend;\r\n\r\nprocedure TJvImageItem.SetGlyph(const Value: TBitmap);\r\nbegin\r\n FGlyph.Assign(Value);\r\n if GetWinControl <> nil then\r\n GetWinControl.Invalidate;\r\nend;\r\n\r\nprocedure TJvImageItem.FontChange(Sender: TObject);\r\nbegin\r\n if not (puFont in FListPropertiesUsed) then\r\n if GetWinControl <> nil then\r\n GetWinControl.Invalidate;\r\nend;\r\n\r\nfunction TJvImageItem.GetWinControl: TWinControl;\r\nbegin\r\n Result := nil;\r\n if Assigned(Collection) then\r\n Result := TWinControl(TJvImageItems(Collection).GetOwner);\r\nend;\r\n\r\nfunction TJvImageItem.GetColorHighlight: TColor;\r\nbegin\r\n if (puColorHighlight in FListPropertiesUsed) and (GetWinControl <> nil) then\r\n begin\r\n if GetWinControl is TJvImageListBox then\r\n Result := TJvImageListBox(GetWinControl).ColorHighlight\r\n else\r\n Result := TJvImageComboBox(GetWinControl).ColorHighlight;\r\n end\r\n else\r\n Result := FColorHighlight;\r\nend;\r\n\r\nfunction TJvImageItem.GetColorHighlightText: TColor;\r\nbegin\r\n if (puColorHighlightText in FListPropertiesUsed) and (GetWinControl <> nil) then\r\n begin\r\n if GetWinControl is TJvImageListBox then\r\n Result := TJvImageListBox(GetWinControl).ColorHighlightText\r\n else\r\n Result := TJvImageComboBox(GetWinControl).ColorHighlightText;\r\n end\r\n else\r\n Result := FColorHighlightText;\r\nend;\r\n\r\nprocedure TJvImageItem.SetColorHighlight(const Value: TColor);\r\nbegin\r\n if (puColorHighlight in FListPropertiesUsed) and (GetWinControl <> nil) then\r\n begin\r\n if GetWinControl is TJvImageListBox then\r\n TJvImageListBox(GetWinControl).ColorHighlight := Value\r\n else\r\n TJvImageComboBox(GetWinControl).ColorHighlight := Value;\r\n end\r\n else\r\n FColorHighlight := Value;\r\nend;\r\n\r\nprocedure TJvImageItem.SetColorHighlightText(const Value: TColor);\r\nbegin\r\n if (puColorHighlightText in FListPropertiesUsed) and (GetWinControl <> nil) then\r\n begin\r\n if GetWinControl is TJvImageListBox then\r\n TJvImageListBox(GetWinControl).ColorHighlightText := Value\r\n else\r\n TJvImageComboBox(GetWinControl).ColorHighlightText := Value\r\n end\r\n else\r\n FColorHighlightText := Value;\r\nend;\r\n\r\nfunction TJvImageItem.IsColorHighlightTextStored: Boolean;\r\nbegin\r\n Result := not (puColorHighlightText in FListPropertiesUsed);\r\nend;\r\n\r\nfunction TJvImageItem.IsFontStored: Boolean;\r\nbegin\r\n Result := not (puFont in FListPropertiesUsed);\r\nend;\r\n\r\nfunction TJvImageItem.IsColorHighlightStored: Boolean;\r\nbegin\r\n Result := not (puColorHighlight in FListPropertiesUsed);\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvListView.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvListView.PAS, released on 2001-02-28.\r\n\r\nThe Initial Developer of the Original Code is Sbastien Buysse [sbuysse att buypin dott com]\r\nPortions created by Sbastien Buysse are Copyright (C) 2001 Sbastien Buysse.\r\nAll Rights Reserved.\r\n\r\nContributor(s): Michael Beck [mbeck att bigfoot dott com].\r\n dejoy\r\n Olivier Sannier [obones att altern dott org]\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n Mantis 3932: In the OnCustomDrawItem, if you change the canvas font directly,\r\n then your changes will be ignored and the items be drawn bold if\r\n the item brush is not used for the given list view style\r\n (report for instance). As a workaround, always change the item's\r\n properties, never the canvas' directly.\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvListView.pas 13415 2012-09-10 09:51:54Z obones $\r\n\r\nunit JvListView;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,\r\n ComCtrls, CommCtrl, Menus, ImgList, Clipbrd,\r\n JvJCLUtils, JvJVCLUtils, JvTypes, JvExComCtrls, JvAppStorage;\r\n\r\ntype\r\n TJvViewStyle = (vsIcon, vsSmallIcon, vsList, vsReport, vsTile);\r\n TJvHeaderImagePosition = (hipLeft, hipRight);\r\n\r\nconst\r\n WM_AUTOSELECT = WM_USER + 1;\r\n ALL_VIEW_STYLES = [vsIcon, vsSmallIcon, vsList, vsReport, vsTile];\r\n\r\ntype\r\n TJvListView = class;\r\n {$IFNDEF RTL200_UP}\r\n TJvListViewGroup = class;\r\n {$ENDIF !RTL200_UP}\r\n EJvListViewError = EJVCLException;\r\n\r\n // Mantis 980: new type for Groups\r\n TLVGROUP = record\r\n cbSize: UINT;\r\n mask: UINT;\r\n pszHeader: LPWSTR;\r\n cchHeader: Integer;\r\n pszFooter: LPWSTR;\r\n cchFooter: Integer;\r\n iGroupId: Integer;\r\n stateMask: UINT;\r\n state: UINT;\r\n uAlign: UINT;\r\n end;\r\n\r\n // TJvSortMethod = (smAutomatic, smAlphabetic, smNonCaseSensitive, smNumeric, smDate, smTime, smDateTime, smCurrency);\r\n TJvOnProgress = procedure(Sender: TObject; Progression, Total: Integer) of object;\r\n TListViewItemClickNotifyEvent = procedure(Sender: TObject; Item: TListItem; SubItemIndex: Integer; X, Y: Integer) of object;\r\n {$IFNDEF RTL200_UP}\r\n TJvListViewCompareGroupEvent = procedure(Sender: TObject; Group1, Group2: TJvListViewGroup; var Compare: Integer) of object;\r\n {$ENDIF !RTL200_UP}\r\n TJvListViewCancelEditEvent = procedure(Sender: TObject; Item: TListItem) of object;\r\n TJvListViewBeginColumnResizeEvent = procedure(Sender: TCustomListview; ColumnIndex: Integer; ColumnWidth: Integer; var CanResize: Boolean) of object;\r\n TJvListViewColumnResizeEvent = procedure(Sender: TCustomListview; ColumnIndex: Integer; ColumnWidth: Integer) of Object;\r\n\r\n TJvListItems = class(TListItems, IJvAppStorageHandler, IJvAppStoragePublishedProps)\r\n private\r\n FOwnerInterface: IInterface;\r\n protected\r\n { IInterface }\r\n function _AddRef: Integer; stdcall;\r\n function _Release: Integer; stdcall;\r\n { IJvAppStorageHandler }\r\n procedure ReadFromAppStorage(AppStorage: TJvCustomAppStorage; const BasePath: string);\r\n procedure WriteToAppStorage(AppStorage: TJvCustomAppStorage; const BasePath: string);\r\n\r\n { List item reader used in the call to ReadList. }\r\n procedure ReadListItem(Sender: TJvCustomAppStorage; const Path: string;\r\n const List: TObject; const Index: Integer; const ItemName: string);\r\n { List item writer used in the call to WriteList. }\r\n procedure WriteListItem(Sender: TJvCustomAppStorage; const Path: string;\r\n const List: TObject; const Index: Integer; const ItemName: string);\r\n { List item deleter used in the call to WriteList. }\r\n procedure DeleteListItem(Sender: TJvCustomAppStorage; const Path: string;\r\n const List: TObject; const First, Last: Integer; const ItemName: string);\r\n public\r\n function QueryInterface(const IID: TGUID; out Obj): HRESULT; virtual; stdcall;\r\n procedure AfterConstruction; override;\r\n end;\r\n\r\n TJvListItem = class(TListItem)\r\n private\r\n FPopupMenu: TPopupMenu;\r\n FBold: Boolean;\r\n FFont: TFont;\r\n FBrush: TBrush;\r\n FGroupId: Integer;\r\n FTileColumns: TIntegerList;\r\n procedure SetBrush(const Value: TBrush);\r\n procedure SetGroupId(const Value: Integer);\r\n procedure SetTileColumns(const Value: TIntegerList);\r\n\r\n procedure ReadTileColumns(Reader: TReader);\r\n procedure WriteTileColumns(Writer: TWriter);\r\n procedure TileColumnsChange(Sender: TObject; Item: Integer; Action: TListNotification);\r\n protected\r\n procedure SetPopupMenu(const Value: TPopupMenu);\r\n procedure SetFont(const Value: TFont);\r\n procedure UpdateTileColumns;\r\n public\r\n constructor CreateEnh(AOwner: TListItems; const Popup: TPopupMenu);\r\n destructor Destroy; override;\r\n\r\n procedure DefineProperties(Filer: TFiler); override;\r\n\r\n property PopupMenu: TPopupMenu read FPopupMenu write SetPopupMenu;\r\n property TileColumns: TIntegerList read FTileColumns write SetTileColumns;\r\n published\r\n property Font: TFont read FFont write SetFont;\r\n property Brush: TBrush read FBrush write SetBrush;\r\n property GroupId: Integer read FGroupId write SetGroupId default -1;\r\n // Published now for the usage of AppStorage.Read/WritePersistent\r\n property Caption;\r\n property Checked;\r\n property Selected;\r\n property SubItems;\r\n end;\r\n\r\n TJvListExtendedColumn = class(TCollectionItem)\r\n private\r\n FSortMethod: TJvSortMethod;\r\n FUseParentSortMethod: Boolean;\r\n FHeaderImagePosition: TJvHeaderImagePosition;\r\n FUseParentHeaderImagePosition: Boolean;\r\n function GetSortMethod: TJvSortMethod;\r\n procedure SetSortMethod(const Value: TJvSortMethod);\r\n function GetHeaderImagePosition: TJvHeaderImagePosition;\r\n procedure SetHeaderImagePosition(const Value: TJvHeaderImagePosition);\r\n procedure SetUseParentHeaderImagePosition(const Value: Boolean);\r\n public\r\n constructor Create(Collection: Classes.TCollection); override;\r\n\r\n procedure Assign(AValue: TPersistent); override;\r\n published\r\n property SortMethod: TJvSortMethod read GetSortMethod write SetSortMethod default smAutomatic;\r\n property UseParentSortMethod : Boolean read FUseParentSortMethod write FUseParentSortMethod default True;\r\n property HeaderImagePosition: TJvHeaderImagePosition read GetHeaderImagePosition write SetHeaderImagePosition default hipLeft;\r\n property UseParentHeaderImagePosition : Boolean read FUseParentHeaderImagePosition write SetUseParentHeaderImagePosition default True;\r\n end;\r\n\r\n TJvListExtendedColumns = class(TOwnedCollection)\r\n private\r\n function GetItem(Index: Integer): TJvListExtendedColumn;\r\n procedure SetItem(Index: Integer; const Value: TJvListExtendedColumn);\r\n\r\n function Owner : TPersistent;\r\n public\r\n constructor Create(AOwner: TPersistent);\r\n property Items[Index: Integer] : TJvListExtendedColumn read GetItem write SetItem; default;\r\n end;\r\n\r\n {$IFNDEF RTL200_UP}\r\n TJvListViewGroup = class(TCollectionItem)\r\n private\r\n FHeader: WideString;\r\n FGroupId: Integer;\r\n FHeaderAlignment: TAlignment;\r\n procedure SetHeader(const Value: WideString);\r\n procedure SetHeaderAlignment(const Value: TAlignment);\r\n procedure SetGroupId(const Value: Integer);\r\n\r\n procedure UpdateGroupProperties(const NewGroupId: Integer = -1);\r\n public\r\n constructor Create(Collection: Classes.TCollection); override;\r\n destructor Destroy; override;\r\n procedure Assign(AValue: TPersistent); override;\r\n procedure SetLVGROUP(var GroupInfo: TLVGROUP);\r\n published\r\n property GroupId: Integer read FGroupId write SetGroupId default -1;\r\n property Header: WideString read FHeader write SetHeader;\r\n property HeaderAlignment: TAlignment read FHeaderAlignment write SetHeaderAlignment default taLeftJustify;\r\n end;\r\n\r\n TJvListViewGroups = class(TOwnedCollection)\r\n private\r\n FSorted: Boolean;\r\n function GetItem(Index: Integer): TJvListViewGroup;\r\n procedure SetItem(Index: Integer; const Value: TJvListViewGroup);\r\n\r\n function ParentList: TJvListView;\r\n procedure InsertGroupIntoList(group: TJvListViewGroup);\r\n procedure RemoveGroupFromList(group: TJvListViewGroup);\r\n\r\n function Compare(Id1, Id2: Integer): Integer;\r\n function GetItemById(GroupId: Integer): TJvListViewGroup;\r\n procedure SetSorted(const Value: Boolean);\r\n protected\r\n procedure Notify(Item: TCollectionItem; Action: TCollectionNotification); override;\r\n public\r\n constructor Create(AOwner: TPersistent);\r\n procedure Sort;\r\n\r\n property Items[Index: Integer] : TJvListViewGroup read GetItem write SetItem; default;\r\n property ItemsById[GroupId: Integer]: TJvListViewGroup read GetItemById;\r\n published\r\n property Sorted: Boolean read FSorted write SetSorted default False;\r\n end;\r\n\r\n TJvGroupsPropertiesBorderRect = class(TJvRect)\r\n public\r\n constructor Create;\r\n published\r\n property Top default 12;\r\n end;\r\n\r\n TJvGroupsPropertiesBorderColors = class(TPersistent)\r\n private\r\n FRight: TColor;\r\n FBottom: TColor;\r\n FTop: TColor;\r\n FLeft: TColor;\r\n FOnChange: TNotifyEvent;\r\n procedure SetBottom(const Value: TColor);\r\n procedure SetLeft(const Value: TColor);\r\n procedure SetRight(const Value: TColor);\r\n procedure SetTop(const Value: TColor);\r\n protected\r\n procedure DoChange;\r\n public\r\n constructor Create;\r\n\r\n procedure Assign(Source: TPersistent); override;\r\n\r\n property OnChange: TNotifyEvent read FOnChange write FOnChange;\r\n published\r\n property Top: TColor read FTop write SetTop default $C8D0D4;\r\n property Left: TColor read FLeft write SetLeft default clWhite;\r\n property Bottom: TColor read FBottom write SetBottom default clWhite;\r\n property Right: TColor read FRight write SetRight default clWhite;\r\n end;\r\n\r\n TJvGroupsProperties = class(TPersistent)\r\n private\r\n FBorderSize: TJvGroupsPropertiesBorderRect;\r\n FBorderColor: TJvGroupsPropertiesBorderColors;\r\n FHeaderColor: TColor;\r\n\r\n FOnChange: TNotifyEvent;\r\n FLoading: Boolean;\r\n procedure SetBorderSize(const Value: TJvGroupsPropertiesBorderRect);\r\n procedure SetBorderColor(const Value: TJvGroupsPropertiesBorderColors);\r\n\r\n procedure BorderSizeChange(Sender: TObject);\r\n procedure BorderColorChange(Sender: TObject);\r\n procedure SetHeaderColor(const Value: TColor);\r\n protected\r\n procedure DoChange;\r\n public\r\n constructor Create;\r\n destructor Destroy; override;\r\n\r\n procedure LoadFromList(List: TCustomListView);\r\n\r\n property OnChange: TNotifyEvent read FOnChange write FOnChange;\r\n published\r\n property BorderSize: TJvGroupsPropertiesBorderRect read FBorderSize write SetBorderSize;\r\n property HeaderColor: TColor read FHeaderColor write SetHeaderColor default clBlack;\r\n\r\n // Note that BorderColor is currently ignored by the Win32 API\r\n property BorderColor: TJvGroupsPropertiesBorderColors read FBorderColor write SetBorderColor;\r\n end;\r\n {$ENDIF !RTL200_UP}\r\n\r\n TJvViewStyles = set of TJvViewStyle;\r\n\r\n TJvTileSizeKind = (tskAutoSize, tskFixedWidth, tskFixedHeight, tskFixedSize);\r\n\r\n TJvTileViewProperties = class(TPersistent)\r\n private\r\n FLabelMargin: TJvRect;\r\n FTileSize: TJvSize;\r\n FSubLinesCount: Integer;\r\n FTileSizeKind: TJvTileSizeKind;\r\n FOnChange: TNotifyEvent;\r\n FLoading: Boolean;\r\n procedure SetLabelMargin(const Value: TJvRect);\r\n procedure SetSubLinesCount(const Value: Integer);\r\n procedure SetTileSize(const Value: TJvSize);\r\n procedure SetTileSizeKind(const Value: TJvTileSizeKind);\r\n\r\n procedure LabelMarginChange(Sender: TObject);\r\n procedure TileSizeChange(Sender: TObject);\r\n protected\r\n procedure DoChange;\r\n public\r\n constructor Create;\r\n destructor Destroy; override;\r\n\r\n procedure LoadFromList(List: TCustomListView);\r\n\r\n property OnChange: TNotifyEvent read FOnChange write FOnChange;\r\n published\r\n property TileSizeKind: TJvTileSizeKind read FTileSizeKind write SetTileSizeKind default tskAutoSize;\r\n property TileSize: TJvSize read FTileSize write SetTileSize;\r\n property SubLinesCount: Integer read FSubLinesCount write SetSubLinesCount default 1;\r\n property LabelMargin: TJvRect read FLabelMargin write SetLabelMargin;\r\n end;\r\n\r\n TJvInsertMarkPosition = (impBefore, impAfter);\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvListView = class(TJvExListView)\r\n private\r\n FAutoClipboardCopy: Boolean;\r\n FSortOnClick: Boolean;\r\n FLast: Integer;\r\n FOnSaveProgress: TJvOnProgress;\r\n FOnLoadProgress: TJvOnProgress;\r\n FOnAutoSort: TJvListViewColumnSortEvent;\r\n FSortMethod: TJvSortMethod;\r\n FOnHorizontalScroll: TNotifyEvent;\r\n FOnVerticalScroll: TNotifyEvent;\r\n FImageChangeLink: TChangeLink;\r\n FHeaderImagePosition: TJvHeaderImagePosition;\r\n FHeaderImages: TCustomImageList;\r\n FAutoSelect: Boolean;\r\n FPicture: TPicture;\r\n FExtendedColumns: TJvListExtendedColumns;\r\n FSavedExtendedColumns: TJvListExtendedColumns;\r\n FSavedColumnOrder: string;\r\n FViewStylesItemBrush: TJvViewStyles; // use for Create/DestroyWnd process\r\n {$IFNDEF RTL200_UP}\r\n FGroupView: Boolean;\r\n FGroups: TJvListViewGroups;\r\n FGroupsProperties: TJvGroupsProperties;\r\n FOnCompareGroups: TJvListViewCompareGroupEvent;\r\n {$ENDIF !RTL200_UP}\r\n FViewStyle: TJvViewStyle;\r\n FTileViewProperties: TJvTileViewProperties;\r\n FInsertMarkColor: TColor;\r\n FSettingJvViewStyle: Boolean;\r\n FSettingHeaderImagePosition: Boolean;\r\n FReturnKeyTriggersItemDblClick: Boolean;\r\n FOnItemClick: TListViewItemClickNotifyEvent;\r\n FOnItemDblClick: TListViewItemClickNotifyEvent;\r\n FOnCancelEdit: TJvListViewCancelEditEvent;\r\n FOnBeginColumnResize: TJvListViewBeginColumnResizeEvent;\r\n FOnEndColumnResize: TJvListViewColumnResizeEvent;\r\n FOnColumnResizing: TJvListViewColumnResizeEvent;\r\n FLastSortedColumnIndex: Integer;\r\n\r\n procedure DoPictureChange(Sender: TObject);\r\n procedure SetPicture(const Value: TPicture);\r\n {$IFNDEF RTL200_UP}\r\n procedure SetGroupView(const Value: Boolean);\r\n procedure SetGroups(const Value: TJvListViewGroups);\r\n procedure SetGroupsProperties(const Value: TJvGroupsProperties);\r\n {$ENDIF !RTL200_UP}\r\n procedure SetTileViewProperties(const Value: TJvTileViewProperties);\r\n procedure SetInsertMarkColor(const Value: TColor);\r\n procedure SetHeaderImagePosition(const Value: TJvHeaderImagePosition);\r\n procedure SetHeaderImages(const Value: TCustomImageList);\r\n procedure UpdateHeaderImages(HeaderHandle: Integer);\r\n procedure WMAutoSelect(var Msg: TMessage); message WM_AUTOSELECT;\r\n procedure SetExtendedColumns(const Value: TJvListExtendedColumns);\r\n procedure SetViewStylesItemBrush(const Value: TJvViewStyles);\r\n {$IFNDEF RTL200_UP}\r\n function DoCompareGroups(Group1, Group2: TJvListViewGroup): Integer;\r\n procedure GroupsPropertiesChange(Sender: TObject);\r\n procedure LoadGroupsProperties;\r\n {$ENDIF !RTL200_UP}\r\n procedure TileViewPropertiesChange(Sender: TObject);\r\n procedure LoadTileViewProperties;\r\n function GetColumnIndex(PHeader: PNMHdr): Integer;\r\n function GetColumnWidth(PHeader: PNMHdr): Integer;\r\n protected\r\n function CreateListItem: TListItem; override;\r\n function CreateListItems: TListItems; override;\r\n procedure WMHScroll(var Msg: TWMHScroll); message WM_HSCROLL;\r\n procedure WMVScroll(var Msg: TWMVScroll); message WM_VSCROLL;\r\n procedure KeyPress(var Key: Char); override;\r\n procedure KeyUp(var Key: Word; Shift: TShiftState); override;\r\n procedure Notification(AComponent: TComponent; Operation: TOperation); override;\r\n function GetColumnsOrder: string;\r\n procedure SetColumnsOrder(const Order: string);\r\n procedure SetItemPopup(Node: TListItem; Value: TPopupMenu);\r\n function GetItemPopup(Node: TListItem): TPopupMenu;\r\n procedure DoHeaderImagesChange(Sender: TObject);\r\n procedure Loaded; override;\r\n procedure SetViewStyle(Value: TViewStyle); override;\r\n procedure SetJvViewStyle(Value: TJvViewStyle); virtual;\r\n procedure ItemClick(AItem: TListItem; SubItemIndex: Integer; X, Y: Integer); virtual;\r\n procedure ItemDblClick(AItem: TListItem; SubItemIndex: Integer; X, Y: Integer); virtual;\r\n procedure SetLastSortedColumnIndex(const Value: Integer); virtual;\r\n\r\n procedure CreateWnd; override;\r\n procedure DestroyWnd; override;\r\n\r\n procedure WMNCCalcSize(var Msg: TWMNCCalcSize); message WM_NCCALCSIZE;\r\n procedure LVMDeleteColumn(var Msg: TMessage); message LVM_DELETECOLUMN;\r\n procedure LVMInsertColumn(var Msg: TMessage); message LVM_INSERTCOLUMN;\r\n procedure LVMSetColumn(var Msg: TMessage); message LVM_SETCOLUMN;\r\n procedure CNNotify(var Message: TWMNotify); message CN_NOTIFY;\r\n procedure WMNotify(var Msg: TWMNotify); message WM_NOTIFY;\r\n\r\n procedure InsertItem(Item: TListItem); override;\r\n function IsCustomDrawn(Target: TCustomDrawTarget; Stage: TCustomDrawStage): Boolean; override;\r\n function CustomDraw(const ARect: TRect; Stage: TCustomDrawStage): Boolean; override;\r\n function CustomDrawItem(Item: TListItem; State: TCustomDrawState;\r\n Stage: TCustomDrawStage): Boolean; override;\r\n function CustomDrawSubItem(Item: TListItem; SubItem: Integer;\r\n State: TCustomDrawState; Stage: TCustomDrawStage): Boolean; override;\r\n\r\n procedure EditCanceled(Item: TListItem); virtual;\r\n function DoBeginColumnResize(ColumnIndex, ColumnWidth: Integer): Boolean; virtual;\r\n procedure DoColumnResizing(ColumnIndex, ColumnWidth: Integer); virtual;\r\n procedure DoEndColumnResize(ColumnIndex, ColumnWidth: Integer); virtual;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n procedure ColClick(Column: TListColumn); override;\r\n procedure SaveToStrings(Strings: TStrings; Separator: Char);\r\n procedure LoadFromStrings(Strings: TStrings; Separator: Char; ClearItems: Boolean = False);\r\n procedure SaveToFile(FileName: string; ForceOldStyle: Boolean = False);\r\n procedure LoadFromFile(FileName: string);\r\n procedure SaveToStream(Stream: TStream; ForceOldStyle: Boolean = False);\r\n procedure LoadFromStream(Stream: TStream);\r\n procedure SaveToCSV(FileName: string; Separator: Char = ';');\r\n procedure LoadFromCSV(FileName: string; Separator: Char = ';');\r\n procedure SetSmallImages(const Value: TCustomImageList);\r\n procedure UnselectAll;\r\n procedure InvertSelection;\r\n function MoveUp(Index: Integer; Focus: Boolean = True): Integer;\r\n function MoveDown(Index: Integer; Focus: Boolean = True): Integer;\r\n function SelectNextItem(Focus: Boolean = True): Integer;\r\n function SelectPrevItem(Focus: Boolean = True): Integer;\r\n\r\n function ShowInsertMark(ItemIndex: Integer; Position: TJvInsertMarkPosition): Boolean;\r\n function HideInsertMark: Boolean;\r\n function GetInsertMarkPosition(const X, Y: Integer; var ItemIndex: Integer; var Position: TJvInsertMarkPosition): Boolean;\r\n\r\n property ItemPopup[Item: TListItem]: TPopupMenu read GetItemPopup write SetItemPopup;\r\n procedure SetBounds(ALeft, ATop, AWidth, AHeight: Integer); override;\r\n procedure SetFocus; override;\r\n\r\n property LastSortedColumnIndex: Integer read FLastSortedColumnIndex write SetLastSortedColumnIndex;\r\n published\r\n property AutoSelect: Boolean read FAutoSelect write FAutoSelect default True;\r\n property ColumnsOrder: string read GetColumnsOrder write SetColumnsOrder;\r\n property HintColor;\r\n property Picture: TPicture read FPicture write SetPicture;\r\n property HeaderImagePosition: TJvHeaderImagePosition read FHeaderImagePosition write SetHeaderImagePosition default hipLeft;\r\n property HeaderImages: TCustomImageList read FHeaderImages write SetHeaderImages;\r\n property SortMethod: TJvSortMethod read FSortMethod write FSortMethod default smAutomatic;\r\n property SortOnClick: Boolean read FSortOnClick write FSortOnClick default True;\r\n property SmallImages write SetSmallImages;\r\n property AutoClipboardCopy: Boolean read FAutoClipboardCopy write FAutoClipboardCopy default True;\r\n property ReturnKeyTriggersItemDblClick: Boolean read FReturnKeyTriggersItemDblClick write FReturnKeyTriggersItemDblClick default True;\r\n {$IFNDEF RTL200_UP}\r\n property GroupView: Boolean read FGroupView write SetGroupView default False;\r\n property Groups: TJvListViewGroups read FGroups write SetGroups;\r\n property GroupsProperties: TJvGroupsProperties read FGroupsProperties write SetGroupsProperties;\r\n {$ENDIF !RTL200_UP}\r\n property TileViewProperties: TJvTileViewProperties read FTileViewProperties write SetTileViewProperties;\r\n property InsertMarkColor: TColor read FInsertMarkColor write SetInsertMarkColor default clBlack;\r\n\r\n property ViewStylesItemBrush : TJvViewStyles read FViewStylesItemBrush write SetViewStylesItemBrush default ALL_VIEW_STYLES;\r\n property ViewStyle: TJvViewStyle read FViewStyle write SetJvViewStyle default vsIcon;\r\n\r\n property OnAutoSort: TJvListViewColumnSortEvent read FOnAutoSort write FOnAutoSort;\r\n property OnCancelEdit: TJvListViewCancelEditEvent read FOnCancelEdit write FOnCancelEdit;\r\n property OnHorizontalScroll: TNotifyEvent read FOnHorizontalScroll write FOnHorizontalScroll;\r\n property OnLoadProgress: TJvOnProgress read FOnLoadProgress write FOnLoadProgress;\r\n property OnSaveProgress: TJvOnProgress read FOnSaveProgress write FOnSaveProgress;\r\n property OnVerticalScroll: TNotifyEvent read FOnVerticalScroll write FOnVerticalScroll;\r\n {$IFNDEF RTL200_UP}\r\n property OnCompareGroups: TJvListViewCompareGroupEvent read FOnCompareGroups write FOnCompareGroups;\r\n {$ENDIF !RTL200_UP}\r\n property OnMouseEnter;\r\n property OnMouseLeave;\r\n property OnParentColorChange;\r\n property OnItemClick: TListViewItemClickNotifyEvent read FOnItemClick write FOnItemClick;\r\n property OnItemDblClick: TListViewItemClickNotifyEvent read FOnItemDblClick write FOnItemDblClick;\r\n property OnBeginColumnResize: TJvListViewBeginColumnResizeEvent read FOnBeginColumnResize write FOnBeginColumnResize;\r\n property OnEndColumnResize: TJvListViewColumnResizeEvent read FOnEndColumnResize write FOnEndColumnResize;\r\n property OnColumnResizing: TJvListViewColumnResizeEvent read FOnColumnResizing write FOnColumnResizing;\r\n\r\n // This property contains a collection that allows to specify additional\r\n // properties for each columns (sort method for instance). It can not be\r\n // included in the Columns collection as the VCL does not offer a way\r\n // to specify which class to use for the items of the Columns collection.\r\n // Note that this one (ExtendedColumns) is populated automatically when\r\n // a column is added or deleted. But because the VCL code for add starts\r\n // by deleting all columns to reinsert them after, you should not change\r\n // the properties for any item of ExtendedColumns in a loop that contains\r\n // a call to the Add method of the Columns property.\r\n property ExtendedColumns : TJvListExtendedColumns read FExtendedColumns write SetExtendedColumns;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvListView.pas $';\r\n Revision: '$Revision: 13415 $';\r\n Date: '$Date: 2012-09-10 11:51:54 +0200 (lun. 10 sept. 2012) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n {$IFDEF COMPILER10_UP}\r\n Types,\r\n {$ENDIF COMPILER10_UP}\r\n VarUtils, Variants,\r\n JvConsts;\r\n\r\ntype\r\n // Mantis 980: New types for group/tile/insert mark handling\r\n tagLVITEMA = record\r\n mask: UINT;\r\n iItem: Integer;\r\n iSubItem: Integer;\r\n state: UINT;\r\n stateMask: UINT;\r\n pszText: PAnsiChar;\r\n cchTextMax: Integer;\r\n iImage: Integer;\r\n lParam: LPARAM;\r\n iIndent: Integer;\r\n iGroupId: Integer;\r\n cColumns: UINT;\r\n puColumns: PUINT;\r\n end;\r\n TLVITEMA = tagLVITEMA;\r\n\r\n TFNLVGROUPCOMPARE = function (Group1_ID: Integer; Group2_ID: Integer; pvData: Pointer): Integer; stdcall;\r\n PFNLVGROUPCOMPARE = ^TFNLVGROUPCOMPARE;\r\n\r\n tagLVINSERTGROUPSORTED = record\r\n pfnGroupCompare: PFNLVGROUPCOMPARE;\r\n pvData: Pointer;\r\n lvGroup: TLVGROUP;\r\n end;\r\n TLVINSERTGROUPSORTED = tagLVINSERTGROUPSORTED;\r\n PLVINSERTGROUPSORTED = ^TLVINSERTGROUPSORTED;\r\n\r\n tagLVTILEVIEWINFO = record\r\n cbSize: UINT;\r\n dwMask: DWORD;\r\n dwFlags: DWORD;\r\n sizeTile: TSize;\r\n cLines: Integer;\r\n rcLabelMargin: TRect;\r\n end;\r\n TLVTILEVIEWINFO = tagLVTILEVIEWINFO;\r\n PLVTILEVIEWINFO = ^TLVTILEVIEWINFO;\r\n\r\n tagLVTILEINFO = record\r\n cbSize: UINT;\r\n iItem: Integer;\r\n cColumns: UINT;\r\n puColumns: PUINT;\r\n end;\r\n TLVTILEINFO = tagLVTILEINFO;\r\n PLVTILEINFO = ^TLVTILEINFO;\r\n\r\n tagLVINSERTMARK = record\r\n cbSize: UINT;\r\n dwFlags: DWORD;\r\n iItem: Integer;\r\n dwReserved: DWORD;\r\n end;\r\n TLVINSERTMARK = tagLVINSERTMARK;\r\n PLVINSERTMARK = ^TLVINSERTMARK;\r\n\r\n tagLVGROUPMETRICS = record\r\n cbSize: UINT;\r\n mask: UINT;\r\n Left: UINT;\r\n Top: UINT;\r\n Right: UINT;\r\n Bottom: UINT;\r\n crLeft: COLORREF;\r\n crTop: COLORREF;\r\n crRight: COLORREF;\r\n crBottom: COLORREF;\r\n crHeader: COLORREF;\r\n crFooter: COLORREF;\r\n end;\r\n TLVGROUPMETRICS = tagLVGROUPMETRICS;\r\n PLVGROUPMETRICS = ^TLVGROUPMETRICS;\r\n\r\nconst\r\n // Mantis 980: New constants for group/tile/insert mark handling\r\n LVM_SETTILEWIDTH = LVM_FIRST + 141;\r\n LVM_SETVIEW = LVM_FIRST + 142;\r\n LVM_INSERTGROUP = LVM_FIRST + 145;\r\n LVM_SETGROUPINFO = LVM_FIRST + 147;\r\n LVM_REMOVEGROUP = LVM_FIRST + 150;\r\n LVM_MOVEITEMTOGROUP = LVM_FIRST + 154;\r\n LVM_SETGROUPMETRICS = LVM_FIRST + 155;\r\n LVM_GETGROUPMETRICS = LVM_FIRST + 156;\r\n LVM_ENABLEGROUPVIEW = LVM_FIRST + 157;\r\n LVM_SORTGROUPS = LVM_FIRST + 158;\r\n LVM_INSERTGROUPSORTED = LVM_FIRST + 159;\r\n LVM_REMOVEALLGROUPS = LVM_FIRST + 160;\r\n LVM_SETTILEVIEWINFO = LVM_FIRST + 162;\r\n LVM_GETTILEVIEWINFO = LVM_FIRST + 163;\r\n LVM_SETTILEINFO = LVM_FIRST + 164;\r\n LVM_GETTILEINFO = LVM_FIRST + 165;\r\n LVM_SETINSERTMARK = LVM_FIRST + 166;\r\n LVM_INSERTMARKHITTEST = LVM_FIRST + 168;\r\n LVM_GETINSERTMARKRECT = LVM_FIRST + 169;\r\n LVM_SETINSERTMARKCOLOR = LVM_FIRST + 170;\r\n LVM_GETINSERTMARKCOLOR = LVM_FIRST + 171;\r\n\r\n // ListViewItemFlag\r\n LVIF_GROUPID = $0100;\r\n\r\n // ListViewGroupFlag\r\n LVGF_HEADER = $00000001;\r\n LVGF_ALIGN = $00000008;\r\n LVGF_GROUPID = $00000010;\r\n\r\n // group alignment\r\n LVGA_HEADER_LEFT = $00000001;\r\n LVGA_HEADER_CENTER = $00000002;\r\n LVGA_HEADER_RIGHT = $00000004;\r\n\r\n // view styles\r\n LV_VIEW_ICON = $00;\r\n LV_VIEW_DETAILS = $01;\r\n LV_VIEW_SMALLICON = $02;\r\n LV_VIEW_LIST = $03;\r\n LV_VIEW_TILE = $04;\r\n\r\n // LVTVIF (ListViewTileViewInfoFlag Constants)\r\n LVTVIF_AUTOSIZE = 0;\r\n LVTVIF_FIXEDWIDTH = 1;\r\n LVTVIF_FIXEDHEIGHT = 2;\r\n LVTVIF_FIXEDSIZE = 3;\r\n\r\n // LVTVIM (ListViewTileViewInfoMask Constants)\r\n LVTVIM_TILESIZE = 1;\r\n LVTVIM_COLUMNS = 2;\r\n LVTVIM_LABELMARGIN = 4;\r\n\r\n // LVIM (ListViewInsertMark Constants)\r\n LVIM_AFTER = 1;\r\n\r\n // LVGMF (ListViewGroupMetricsFlag Constants)\r\n LVGMF_NONE = $00000000;\r\n LVGMF_BORDERSIZE = $00000001;\r\n LVGMF_BORDERCOLOR = $00000002;\r\n LVGMF_TEXTCOLOR = $00000004;\r\n\r\n AlignmentToLVGA: array[TAlignment] of Integer = (LVGA_HEADER_LEFT, LVGA_HEADER_RIGHT, LVGA_HEADER_CENTER);\r\n TileSizeKindToLVTVIF: array[TJvTileSizeKind] of Integer = (LVTVIF_AUTOSIZE, LVTVIF_FIXEDWIDTH, LVTVIF_FIXEDHEIGHT, LVTVIF_FIXEDSIZE);\r\n InsertMarkPositionToLVIM: array[TJvInsertMarkPosition] of Integer = (0, LVIM_AFTER);\r\n\r\n//=== { TJvListItem } ========================================================\r\n\r\nconstructor TJvListItem.CreateEnh(AOwner: TListItems; const Popup: TPopupMenu);\r\nbegin\r\n inherited Create(AOwner);\r\n\r\n FBold := False;\r\n FPopupMenu := Popup; // (Salvatore) Get it from the JvListView\r\n FFont := TFont.Create;\r\n FBrush := TBrush.Create;\r\n FGroupId := -1;\r\n FTileColumns := TIntegerList.Create;\r\n\r\n FTileColumns.OnChange := TileColumnsChange;\r\n if AOwner.Owner is TJvListView then\r\n FFont.Assign((AOwner.Owner as TJvListView).Canvas.Font);\r\nend;\r\n\r\nprocedure TJvListItem.DefineProperties(Filer: TFiler);\r\nbegin\r\n inherited DefineProperties(Filer);\r\n\r\n // Because a TList is not saved natively by Delphi, we do it ourselves.\r\n Filer.DefineProperty('TileColumns', ReadTileColumns, WriteTileColumns, True);\r\nend;\r\n\r\ndestructor TJvListItem.Destroy;\r\nbegin\r\n FTileColumns.Free;\r\n FFont.Free;\r\n FBrush.Free;\r\n\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvListItem.ReadTileColumns(Reader: TReader);\r\nbegin\r\n FTileColumns.ReadData(Reader);\r\n UpdateTileColumns;\r\nend;\r\n\r\nprocedure TJvListItem.SetBrush(const Value: TBrush);\r\nbegin\r\n FBrush.Assign(Value);\r\nend;\r\n\r\nprocedure TJvListItem.SetFont(const Value: TFont);\r\nbegin\r\n FFont.Assign(Value);\r\nend;\r\n\r\nprocedure TJvListItem.SetGroupId(const Value: Integer);\r\nvar\r\n Infos: JvListView.TLVITEMA;\r\n List: TCustomListView;\r\nbegin\r\n if FGroupId <> Value then\r\n begin\r\n FGroupId := Value;\r\n\r\n List := Owner.Owner;\r\n if Assigned(List) then\r\n begin\r\n ZeroMemory(@Infos, sizeof(Infos));\r\n Infos.mask := LVIF_GROUPID;\r\n Infos.iItem := Index;\r\n Infos.iGroupId := FGroupId;\r\n\r\n SendMessage(List.Handle, LVM_SETITEM, 0, LPARAM(@Infos));\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvListItem.SetPopupMenu(const Value: TPopupMenu);\r\nbegin\r\n FPopupMenu := Value;\r\nend;\r\n\r\nprocedure TJvListItem.SetTileColumns(const Value: TIntegerList);\r\nbegin\r\n FTileColumns.Assign(Value);\r\nend;\r\n\r\nprocedure TJvListItem.TileColumnsChange(Sender: TObject; Item: Integer;\r\n Action: TListNotification);\r\nbegin\r\n if not TileColumns.Loading then\r\n UpdateTileColumns;\r\nend;\r\n\r\nprocedure TJvListItem.UpdateTileColumns;\r\ntype\r\n TCardinalArray = array [0..0] of Cardinal;\r\nvar\r\n List: TCustomListView;\r\n TileInfos: TLVTILEINFO;\r\n Cols: ^TCardinalArray;\r\n I: Integer;\r\nbegin\r\n List := Owner.Owner;\r\n if Assigned(List) then\r\n begin\r\n GetMem(Cols, FTileColumns.Count);\r\n try\r\n for I := 0 to FTileColumns.Count - 1 do\r\n begin\r\n Cols[I] := FTileColumns[I];\r\n end;\r\n\r\n ZeroMemory(@TileInfos, SizeOf(TileInfos));\r\n TileInfos.cbSize := SizeOf(TileInfos);\r\n TileInfos.iItem := Index;\r\n TileInfos.cColumns := FTileColumns.Count;\r\n TileInfos.puColumns := PUINT(Cols);\r\n SendMessage(List.Handle, LVM_SETTILEINFO, 0, LPARAM(@TileInfos));\r\n finally\r\n FreeMem(Cols);\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvListItem.WriteTileColumns(Writer: TWriter);\r\nbegin\r\n FTileColumns.WriteData(Writer);\r\nend;\r\n\r\n//=== { TJvListItems } =======================================================\r\n\r\nprocedure TJvListItems.AfterConstruction;\r\nbegin\r\n inherited AfterConstruction;\r\n if GetOwner <> nil then\r\n GetOwner.GetInterface(IInterface, FOwnerInterface);\r\nend;\r\n\r\nfunction TJvListItems._AddRef: Integer;\r\nbegin\r\n if FOwnerInterface <> nil then\r\n Result := FOwnerInterface._AddRef\r\n else\r\n Result := -1;\r\nend;\r\n\r\nfunction TJvListItems._Release: Integer;\r\nbegin\r\n if FOwnerInterface <> nil then\r\n Result := FOwnerInterface._Release\r\n else\r\n Result := -1;\r\nend;\r\n\r\nfunction TJvListItems.QueryInterface(const IID: TGUID; out Obj): HRESULT;\r\nconst\r\n E_NOINTERFACE = HRESULT($80004002);\r\nbegin\r\n if GetInterface(IID, Obj) then\r\n Result := 0\r\n else\r\n Result := E_NOINTERFACE;\r\nend;\r\n\r\nprocedure TJvListItems.ReadFromAppStorage(AppStorage: TJvCustomAppStorage; const BasePath: string);\r\nbegin\r\n BeginUpdate;\r\n try\r\n Clear;\r\n AppStorage.ReadList(BasePath, Self, ReadListItem, cItem);\r\n finally\r\n EndUpdate;\r\n end;\r\nend;\r\n\r\nprocedure TJvListItems.WriteToAppStorage(AppStorage: TJvCustomAppStorage; const BasePath: string);\r\nbegin\r\n AppStorage.WriteList(BasePath, Self, Count, WriteListItem, DeleteListItem, cItem);\r\nend;\r\n\r\nprocedure TJvListItems.ReadListItem(Sender: TJvCustomAppStorage;\r\n const Path: string; const List: TObject; const Index: Integer; const ItemName: string);\r\nvar\r\n NewItem: TPersistent;\r\n NewPath: string;\r\nbegin\r\n if List is TJvListItems then\r\n try\r\n NewPath := Sender.ConcatPaths([Path, ItemName + IntToStr(Index)]);\r\n NewItem := TJvListItems(List).Add;\r\n Sender.ReadPersistent(NewPath, NewItem);\r\n except\r\n end;\r\nend;\r\n\r\nprocedure TJvListItems.WriteListItem(Sender: TJvCustomAppStorage;\r\n const Path: string; const List: TObject; const Index: Integer; const ItemName: string);\r\nbegin\r\n if List is TJvListItems then\r\n if Assigned(TJvListItems(List)[Index]) then\r\n Sender.WritePersistent(Sender.ConcatPaths([Path, ItemName + IntToStr(Index)]), TPersistent(TJvListItems(List)[Index]));\r\nend;\r\n\r\nprocedure TJvListItems.DeleteListItem(Sender: TJvCustomAppStorage;\r\n const Path: string; const List: TObject; const First, Last: Integer; const ItemName: string);\r\nvar\r\n I: Integer;\r\nbegin\r\n if List is TJvListItems then\r\n for I := First to Last do\r\n Sender.DeleteValue(Sender.ConcatPaths([Path, ItemName + IntToStr(I)]));\r\nend;\r\n\r\n{ TJvListExtendedColumn }\r\n\r\nprocedure TJvListExtendedColumn.Assign(AValue: TPersistent);\r\nbegin\r\n if AValue is TJvListExtendedColumn then\r\n begin\r\n FSortMethod := TJvListExtendedColumn(AValue). SortMethod;\r\n FUseParentSortMethod := TJvListExtendedColumn(AValue).UseParentSortMethod;\r\n\r\n FHeaderImagePosition := TJvListExtendedColumn(AValue).HeaderImagePosition;\r\n FUseParentHeaderImagePosition := TJvListExtendedColumn(AValue).UseParentHeaderImagePosition;\r\n end\r\n else\r\n inherited Assign(AValue);\r\nend;\r\n\r\nconstructor TJvListExtendedColumn.Create(Collection: Classes.TCollection);\r\nbegin\r\n inherited Create(Collection);\r\n\r\n FSortMethod := smAutomatic;\r\n FUseParentSortMethod := True;\r\n\r\n FHeaderImagePosition := hipLeft;\r\n FUseParentHeaderImagePosition := True;\r\nend;\r\n\r\nfunction TJvListExtendedColumn.GetHeaderImagePosition: TJvHeaderImagePosition;\r\nbegin\r\n if (TJvListExtendedColumns(Collection).Owner is TJvListView) and UseParentHeaderImagePosition then\r\n Result := TJvListView(TJvListExtendedColumns(Collection).Owner).HeaderImagePosition\r\n else\r\n Result := FHeaderImagePosition;\r\nend;\r\n\r\nfunction TJvListExtendedColumn.GetSortMethod: TJvSortMethod;\r\nbegin\r\n if (TJvListExtendedColumns(Collection).Owner is TJvListView) and UseParentSortMethod then\r\n Result := TJvListView(TJvListExtendedColumns(Collection).Owner).SortMethod\r\n else\r\n Result := FSortMethod;\r\nend;\r\n\r\nprocedure TJvListExtendedColumn.SetHeaderImagePosition(\r\n const Value: TJvHeaderImagePosition);\r\nbegin\r\n FHeaderImagePosition := Value;\r\n UseParentHeaderImagePosition := False;\r\n\r\n if (TJvListExtendedColumns(Collection).Owner is TJvListView) then\r\n begin\r\n TJvListView(TJvListExtendedColumns(Collection).Owner).DoHeaderImagesChange(Self);\r\n end;\r\nend;\r\n\r\nprocedure TJvListExtendedColumn.SetSortMethod(\r\n const Value: TJvSortMethod);\r\nbegin\r\n FSortMethod := Value;\r\n UseParentSortMethod := False;\r\nend;\r\n\r\nprocedure TJvListExtendedColumn.SetUseParentHeaderImagePosition(\r\n const Value: Boolean);\r\nbegin\r\n if FUseParentHeaderImagePosition <> Value then\r\n begin\r\n FUseParentHeaderImagePosition := Value;\r\n if (TJvListExtendedColumns(Collection).Owner is TJvListView) then\r\n begin\r\n TJvListView(TJvListExtendedColumns(Collection).Owner).DoHeaderImagesChange(Self);\r\n end;\r\n end;\r\nend;\r\n\r\n{ TJvListExtendedColumns }\r\n\r\nconstructor TJvListExtendedColumns.Create(AOwner: TPersistent);\r\nbegin\r\n inherited Create(AOwner, TJvListExtendedColumn);\r\nend;\r\n\r\nfunction TJvListExtendedColumns.GetItem(\r\n Index: Integer): TJvListExtendedColumn;\r\nbegin\r\n Result := TJvListExtendedColumn(inherited Items[Index]);\r\nend;\r\n\r\nfunction TJvListExtendedColumns.Owner: TPersistent;\r\nbegin\r\n Result := GetOwner;\r\nend;\r\n\r\nprocedure TJvListExtendedColumns.SetItem(Index: Integer;\r\n const Value: TJvListExtendedColumn);\r\nbegin\r\n inherited Items[Index] := Value;\r\nend;\r\n\r\n//=== { TJvListView } ========================================================\r\n\r\nconst\r\n cLISTVIEW01: PAnsiChar = 'LISTVIEW01'; // 10 chars\r\n\r\nconstructor TJvListView.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FSortOnClick := True;\r\n FSortMethod := smAutomatic;\r\n FLast := -1;\r\n FInsertMarkColor := clBlack;\r\n FAutoClipboardCopy := True;\r\n FReturnKeyTriggersItemDblClick := True;\r\n FHeaderImagePosition := hipLeft;\r\n FImageChangeLink := TChangeLink.Create;\r\n FImageChangeLink.OnChange := DoHeaderImagesChange;\r\n FAutoSelect := True;\r\n FPicture := TPicture.Create;\r\n FPicture.OnChange := DoPictureChange;\r\n\r\n FViewStylesItemBrush := ALL_VIEW_STYLES;\r\n FExtendedColumns := TJvListExtendedColumns.Create(Self);\r\n FSavedExtendedColumns := TJvListExtendedColumns.Create(Self);\r\n {$IFNDEF RTL200_UP}\r\n FGroups := TJvListViewGroups.Create(Self);\r\n FGroupsProperties := TJvGroupsProperties.Create;\r\n {$ENDIF !RTL200_UP}\r\n FTileViewProperties := TJvTileViewProperties.Create;\r\n\r\n FTileViewProperties.OnChange := TileViewPropertiesChange;\r\n {$IFNDEF RTL200_UP}\r\n FGroupsProperties.OnChange := GroupsPropertiesChange;\r\n {$ENDIF !RTL200_UP}\r\nend;\r\n\r\ndestructor TJvListView.Destroy;\r\nbegin\r\n {$IFNDEF RTL200_UP}\r\n FGroupsProperties.Free;\r\n FGroups.Free;\r\n {$ENDIF !RTL200_UP}\r\n FTileViewProperties.Free;\r\n FExtendedColumns.Free;\r\n FSavedExtendedColumns.Free;\r\n\r\n FImageChangeLink.Free;\r\n FPicture.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvListView.WMHScroll(var Msg: TWMHScroll);\r\nbegin\r\n inherited;\r\n UpdateHeaderImages(ListView_GetHeader(Handle));\r\n if Assigned(FOnHorizontalScroll) then\r\n FOnHorizontalScroll(Self);\r\nend;\r\n\r\nprocedure TJvListView.WMVScroll(var Msg: TWMVScroll);\r\nbegin\r\n inherited;\r\n UpdateHeaderImages(ListView_GetHeader(Handle));\r\n if Assigned(FOnVerticalScroll) then\r\n FOnVerticalScroll(Self);\r\nend;\r\n\r\nprocedure TJvListView.ColClick(Column: TListColumn);\r\ntype\r\n TParamSort = record\r\n ColumnIndex: Integer;\r\n Sender: TObject;\r\n end;\r\nvar\r\n Parm: TParamSort;\r\n\r\n function CustomCompare1(Item1, Item2, ParamSort: LPARAM): Integer stdcall;\r\n var\r\n Parm: TParamSort;\r\n i1, i2: TListItem;\r\n S1, S2: string;\r\n I: Integer;\r\n SortKind: TJvSortMethod;\r\n\r\n function IsBigger(First, Second: string; SortType: TJvSortMethod): Boolean;\r\n var\r\n I, J: Double;\r\n d, e: TDateTime;\r\n a, b: Currency;\r\n l, m: Int64;\r\n st, st2: string;\r\n int1, int2: Integer;\r\n\r\n function FirstNonAlpha(Value: string): Integer;\r\n var\r\n Len: Integer;\r\n I, J: Integer;\r\n Comma: Boolean;\r\n begin\r\n Len := Length(Value);\r\n I := 1;\r\n J := 0;\r\n Comma := False;\r\n\r\n while I <= Len do\r\n begin\r\n case Value[I] of\r\n '0', '1', '2', '3', '4', '5', '6', '7', '8', '9':\r\n J := I;\r\n ',', '.':\r\n if not Comma then\r\n Comma := True\r\n else\r\n begin\r\n J := I - 1;\r\n I := Len;\r\n end;\r\n else\r\n begin\r\n J := I - 1;\r\n I := Len;\r\n end;\r\n end;\r\n Inc(I);\r\n end;\r\n\r\n Result := J;\r\n end;\r\n\r\n begin\r\n Result := False;\r\n if Trim(First) = '' then\r\n Result := False\r\n else\r\n if Trim(Second) = '' then\r\n Result := True\r\n else\r\n begin\r\n case SortType of\r\n smAlphabetic:\r\n Result := First > Second;\r\n smNonCaseSensitive:\r\n Result := UpperCase(First) > UpperCase(Second);\r\n smNumeric:\r\n begin\r\n try\r\n VarR8FromStr({$IFDEF RTL240_UP}PChar{$ENDIF RTL240_UP}(First), LOCALE_USER_DEFAULT, 0, I);\r\n VarR8FromStr({$IFDEF RTL240_UP}PChar{$ENDIF RTL240_UP}(Second), LOCALE_USER_DEFAULT, 0, J);\r\n Result := I > J;\r\n except\r\n try\r\n l := StrToInt64(First);\r\n except\r\n l := 0;\r\n end;\r\n try\r\n m := StrToInt64(Second);\r\n except\r\n m := 0;\r\n end;\r\n Result := l > m;\r\n end;\r\n end;\r\n smDate:\r\n begin\r\n d := StrToDate(First);\r\n e := StrToDate(Second);\r\n Result := d > e;\r\n end;\r\n smTime:\r\n begin\r\n d := StrToTime(First);\r\n e := StrToTime(Second);\r\n Result := d > e;\r\n end;\r\n smDateTime:\r\n begin\r\n d := StrToDateTime(First);\r\n e := StrToDateTime(Second);\r\n Result := d > e;\r\n end;\r\n smCurrency:\r\n begin\r\n VarCyFromStr({$IFDEF RTL240_UP}PChar{$ENDIF RTL240_UP}(First), LOCALE_USER_DEFAULT, 0, a);\r\n VarCyFromStr({$IFDEF RTL240_UP}PChar{$ENDIF RTL240_UP}(Second), LOCALE_USER_DEFAULT, 0, b);\r\n Result := a > b;\r\n end;\r\n smAutomatic:\r\n begin\r\n int1 := FirstNonAlpha(First);\r\n int2 := FirstNonAlpha(Second);\r\n if (int1 <> 0) and (int2 <> 0) then\r\n begin\r\n st := Copy(First, 1, int1);\r\n st2 := Copy(Second, 1, int2);\r\n try\r\n Result := StrToFloat(st) > StrToFloat(st2);\r\n except\r\n Result := First > Second;\r\n end;\r\n end\r\n else\r\n Result := First > Second;\r\n end;\r\n end;\r\n end;\r\n end;\r\n\r\n begin\r\n Parm := TParamSort(Pointer(ParamSort)^);\r\n i1 := TListItem(Item1);\r\n i2 := TListItem(Item2);\r\n I := Parm.ColumnIndex;\r\n\r\n // (Salvatore)\r\n if Parm.ColumnIndex < TJvListView(Parm.Sender).ExtendedColumns.Count then\r\n SortKind := TJvListView(Parm.Sender).ExtendedColumns[Parm.ColumnIndex].SortMethod\r\n else\r\n SortKind := TJvListView(Parm.Sender).SortMethod;\r\n\r\n if Assigned(TJvListView(Parm.Sender).OnAutoSort) then\r\n TJvListView(Parm.Sender).OnAutoSort(Parm.Sender, Parm.ColumnIndex, SortKind);\r\n\r\n case I of\r\n {sort by caption}\r\n 0:\r\n begin\r\n S1 := i1.Caption;\r\n S2 := i2.Caption;\r\n\r\n if IsBigger(S1, S2, SortKind) then\r\n Result := 1\r\n else\r\n if IsBigger(S2, S1, SortKind) then\r\n Result := -1\r\n else\r\n Result := 0;\r\n end;\r\n else\r\n {sort by Column}\r\n begin\r\n if I > i1.SubItems.Count then\r\n begin\r\n if I > i2.SubItems.Count then\r\n Result := 0\r\n else\r\n Result := -1;\r\n end\r\n else\r\n if I > i2.SubItems.Count then\r\n Result := 1\r\n else\r\n begin\r\n S1 := i1.SubItems[I - 1];\r\n S2 := i2.SubItems[I - 1];\r\n if IsBigger(S1, S2, SortKind) then\r\n Result := 1\r\n else\r\n if IsBigger(S2, S1, SortKind) then\r\n Result := -1\r\n else\r\n Result := 0;\r\n end;\r\n end;\r\n end;\r\n end;\r\n\r\n function CustomCompare2(Item1, Item2, ParamSort: LPARAM): Integer; stdcall;\r\n begin\r\n Result := -CustomCompare1(Item1, Item2, ParamSort);\r\n end;\r\n\r\nbegin\r\n inherited ColClick(Column);\r\n if FSortOnClick then\r\n begin\r\n FLastSortedColumnIndex := Column.Index;\r\n Parm.ColumnIndex := Column.Index;\r\n Parm.Sender := Self;\r\n if FLast = Column.Index then\r\n begin\r\n FLast := -1;\r\n CustomSort(TLVCompare(@CustomCompare2), LPARAM(@Parm));\r\n end\r\n else\r\n begin\r\n FLast := Column.Index;\r\n CustomSort(TLVCompare(@CustomCompare1), LPARAM(@Parm));\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJvListView.CreateListItem: TListItem;\r\nbegin\r\n Result := TJvListItem.CreateEnh(Items, Self.PopupMenu);\r\nend;\r\n\r\nfunction TJvListView.CreateListItems: TListItems;\r\nbegin\r\n Result := TJvListItems.Create(Self);\r\nend;\r\n\r\nfunction TJvListView.GetItemPopup(Node: TListItem): TPopupMenu;\r\nbegin\r\n Result := TJvListItem(Node).PopupMenu;\r\nend;\r\n\r\nprocedure TJvListView.SetItemPopup(Node: TListItem; Value: TPopupMenu);\r\nbegin\r\n TJvListItem(Node).PopupMenu := Value;\r\nend;\r\n\r\nprocedure TJvListView.LoadFromFile(FileName: string);\r\nvar\r\n Stream: TFileStream;\r\nbegin\r\n Stream := TFileStream.Create(FileName, fmOpenRead or fmShareDenyWrite);\r\n try\r\n LoadFromStream(Stream);\r\n finally\r\n Stream.Free;\r\n end;\r\nend;\r\n\r\nprocedure TJvListView.LoadFromStream(Stream: TStream);\r\nvar\r\n Start: Integer;\r\n\r\n procedure LoadOldStyle(Stream: TStream);\r\n var\r\n I, J, K: Integer;\r\n Buf: array [0..100] of Byte;\r\n S: AnsiString;\r\n ch1, Checks: Boolean;\r\n ListItem: TListItem;\r\n begin\r\n I := Stream.Position;\r\n ListItem := nil;\r\n S := '';\r\n if Assigned(FOnLoadProgress) then\r\n FOnLoadProgress(Self, 0, Stream.Size - Start);\r\n Checks := False;\r\n ch1 := CheckBoxes;\r\n while I < Stream.Size do\r\n begin\r\n J := Stream.Read(Buf, SizeOf(Buf));\r\n if Assigned(FOnLoadProgress) then\r\n FOnLoadProgress(Self, J, Stream.Size - Start);\r\n I := I + J;\r\n K := 0;\r\n while K < J do\r\n begin\r\n while (K < J) and (Buf[K] <> 0) and (Buf[K] <> 1) do\r\n begin\r\n S := S + AnsiChar(Buf[K]);\r\n Inc(K);\r\n end;\r\n\r\n if K < J then\r\n begin\r\n if ListItem <> nil then\r\n ListItem.SubItems.Add(string(S))\r\n else\r\n begin\r\n ListItem := Items.Add;\r\n Checks := Checks or (S[1] = 'T');\r\n ListItem.Checked := S[1] = 'T';\r\n S := Copy(S, 2, Length(S));\r\n ListItem.Caption := string(S);\r\n end;\r\n if Buf[K] = 1 then\r\n ListItem := nil;\r\n S := '';\r\n end;\r\n Inc(K);\r\n end;\r\n end;\r\n if not ch1 and not Checks then\r\n CheckBoxes := False;\r\n end;\r\n\r\n procedure LoadNewStyle(Stream: TStream);\r\n const\r\n LV_HASCHECKBOXES = $80;\r\n var\r\n Count, J: SmallInt;\r\n I: Integer;\r\n Options: Byte;\r\n UTF8St: UTF8String;\r\n S: string;\r\n ListItem: TListItem;\r\n Buf: array of AnsiChar;\r\n begin\r\n Stream.Read(Options, SizeOf(Options));\r\n CheckBoxes := (Options and LV_HASCHECKBOXES) = LV_HASCHECKBOXES;\r\n\r\n //Read all lines\r\n while Stream.Position < Stream.Size do\r\n begin\r\n Stream.Read(Count, SizeOf(Count));\r\n\r\n //statistics\r\n if Assigned(FOnLoadProgress) then\r\n FOnLoadProgress(Self, Stream.Position, Stream.Size - Start);\r\n\r\n //Read all columns\r\n ListItem := Self.Items.Add;\r\n for I := 1 to Count do\r\n begin\r\n if I = 1 then\r\n begin\r\n Stream.Read(Options, SizeOf(Options));\r\n if CheckBoxes then\r\n ListItem.Checked := Boolean(Options and Ord(True));\r\n end;\r\n\r\n Stream.Read(J, SizeOf(J));\r\n\r\n //Read the string\r\n if Length(Buf) < J then\r\n SetLength(Buf, J);\r\n if J > 0 then\r\n begin\r\n Stream.Read(Buf[0], J);\r\n SetString(UTF8St, PAnsiChar(@Buf[0]), J);\r\n S := UTF8ToString(UTF8St);\r\n end\r\n else\r\n S := '';\r\n\r\n if I = 1 then\r\n ListItem.Caption := S\r\n else\r\n ListItem.SubItems.Add(S);\r\n end;\r\n end;\r\n end;\r\n\r\nvar\r\n Buf: array [0..10] of AnsiChar;\r\nbegin\r\n Start := Stream.Position;\r\n Stream.Read(Buf, 10);\r\n Buf[10] := #0;\r\n\r\n Items.BeginUpdate;\r\n try\r\n Items.Clear;\r\n if StrComp(Buf, cLISTVIEW01) <> 0 then\r\n begin\r\n Stream.Position := Start;\r\n LoadOldStyle(Stream);\r\n end\r\n else\r\n LoadNewStyle(Stream);\r\n finally\r\n Items.EndUpdate;\r\n end;\r\nend;\r\n\r\nprocedure TJvListView.SaveToFile(FileName: string; ForceOldStyle: Boolean);\r\nvar\r\n Stream: TFileStream;\r\nbegin\r\n Stream := TFileStream.Create(FileName, fmCreate or fmShareExclusive);\r\n try\r\n SaveToStream(Stream, ForceOldStyle);\r\n finally\r\n Stream.Free;\r\n end;\r\nend;\r\n\r\nprocedure TJvListView.SaveToStream(Stream: TStream; ForceOldStyle: Boolean);\r\n\r\n procedure SaveOldStyle(Stream: TStream);\r\n var\r\n I, SubItemIndex, K: Integer;\r\n b, c, d, e: Byte;\r\n S: AnsiString;\r\n Buf: array [0..1000] of Byte;\r\n begin\r\n b := 0;\r\n c := 1;\r\n d := Ord('T'); //checked\r\n e := Ord('F'); //not checked\r\n if Assigned(FOnSaveProgress) then\r\n FOnSaveProgress(Self, 0, Self.Items.Count);\r\n for I := 0 to Self.Items.Count - 1 do\r\n begin\r\n if Assigned(FOnSaveProgress) then\r\n FOnSaveProgress(Self, I + 1, Self.Items.Count);\r\n S := AnsiString(Self.Items[I].Caption);\r\n for K := 1 to Length(S) do\r\n Buf[K - 1] := Byte(S[K]);\r\n K := Length(S);\r\n //write checked,not\r\n if Self.Items[I].Checked then\r\n Stream.Write(d, 1)\r\n else\r\n Stream.Write(e, 1);\r\n Stream.Write(Buf, K);\r\n if Self.Items[I].SubItems.Count = 0 then\r\n Stream.Write(c, 1)\r\n else\r\n begin\r\n Stream.Write(b, 1);\r\n for SubItemIndex := 0 to Self.Items[I].SubItems.Count - 2 do\r\n begin\r\n S := AnsiString(Self.Items[I].SubItems[SubItemIndex]);\r\n for K := 1 to Length(S) do\r\n Buf[K - 1] := Byte(S[K]);\r\n K := Length(S);\r\n Stream.Write(Buf, K);\r\n Stream.Write(b, 1);\r\n end;\r\n SubItemIndex := Self.Items[I].SubItems.Count - 1;\r\n S := AnsiString(Self.Items[I].SubItems[SubItemIndex]);\r\n for K := 1 to Length(S) do\r\n Buf[K - 1] := Byte(S[K]);\r\n K := Length(S);\r\n Stream.Write(Buf, K);\r\n Stream.Write(c, 1);\r\n end;\r\n end;\r\n end;\r\n\r\n procedure SaveNewStyle(Stream: TStream);\r\n const\r\n LV_HASCHECKBOXES = $80;\r\n\r\n procedure WriteString(const Txt: string);\r\n var\r\n I: Word;\r\n UTF8Txt: UTF8String;\r\n begin\r\n UTF8Txt := UTF8Encode(Txt);\r\n I := Length(UTF8Txt);\r\n Stream.Write(I, SizeOf(I));\r\n if I > 0 then\r\n Stream.Write(UTF8Txt[1], I);\r\n end;\r\n\r\n var\r\n I: Integer;\r\n J: SmallInt;\r\n Options, IsChecked: Byte;\r\n begin\r\n Stream.Write(cLISTVIEW01[0], 10);\r\n Options := 0;\r\n if CheckBoxes then\r\n Options := LV_HASCHECKBOXES;\r\n Stream.Write(Options, SizeOf(Options));\r\n for I := 0 to Items.Count - 1 do\r\n with Items[I] do\r\n begin\r\n J := SubItems.Count + 1;\r\n Stream.Write(J, SizeOf(J));\r\n IsChecked := Options or (Byte(Ord(Checked)));\r\n Stream.Write(IsChecked, SizeOf(IsChecked));\r\n WriteString(Items[I].Caption);\r\n for J := 0 to Items[I].SubItems.Count - 1 do\r\n WriteString(SubItems[J]);\r\n end;\r\n end;\r\n\r\nbegin\r\n if ForceOldStyle then\r\n SaveOldStyle(Stream)\r\n else\r\n SaveNewStyle(Stream);\r\nend;\r\n\r\nprocedure TJvListView.SaveToStrings(Strings: TStrings; Separator: Char);\r\nvar\r\n I, J: Integer;\r\n TmpStr: string;\r\nbegin\r\n if Assigned(FOnSaveProgress) then\r\n FOnSaveProgress(Self, 0, Items.Count);\r\n for I := 0 to Items.Count - 1 do\r\n begin\r\n if Assigned(FOnSaveProgress) then\r\n FOnSaveProgress(Self, I + 1, Items.Count);\r\n TmpStr := AnsiQuotedStr(Items[I].Caption, '\"');\r\n for J := 0 to Items[I].SubItems.Count - 1 do\r\n TmpStr := TmpStr + Separator + AnsiQuotedStr(Items[I].SubItems[J], '\"');\r\n Strings.Add(TmpStr);\r\n end;\r\nend;\r\n\r\nprocedure TJvListView.LoadFromStrings(Strings: TStrings; Separator: Char; ClearItems: Boolean);\r\nvar\r\n I: Integer;\r\n Start, Stop, TmpStart: PChar;\r\n TmpStr: string;\r\n ListItem: TListItem;\r\nbegin\r\n Items.BeginUpdate;\r\n try\r\n if ClearItems then\r\n Items.Clear;\r\n\r\n for I := 0 to Strings.Count - 1 do\r\n begin\r\n ListItem := nil;\r\n Start := PChar(Strings[I]);\r\n Stop := Start + Length(Strings[I]);\r\n if (Start <> Stop) and (Start <> nil) and (Start^ <> #0) then\r\n begin\r\n if Start^ = '\"' then\r\n begin\r\n ListItem := Items.Add;\r\n TmpStr := AnsiExtractQuotedStr(Start, '\"'); // this moves the PChar pointer\r\n ListItem.Caption := TmpStr;\r\n end\r\n else\r\n begin\r\n TmpStart := Start;\r\n while Start^ <> Separator do\r\n begin\r\n if Start = Stop then\r\n Break;\r\n Inc(Start);\r\n end;\r\n SetString(TmpStr, TmpStart, Start - TmpStart);\r\n ListItem := Items.Add;\r\n ListItem.Caption := TmpStr;\r\n end;\r\n end;\r\n if ListItem <> nil then\r\n begin\r\n while (Start <> Stop) and (Start <> nil) and (Start^ <> #0) do\r\n begin\r\n while Start^ = Separator do\r\n Inc(Start);\r\n if Start^ = '\"' then\r\n begin\r\n TmpStr := AnsiExtractQuotedStr(Start, '\"'); // this moves the PChar pointer\r\n ListItem.SubItems.Add(TmpStr);\r\n end\r\n else\r\n begin\r\n TmpStart := Start;\r\n while Start^ <> Separator do\r\n begin\r\n if Start = Stop then\r\n Break;\r\n Inc(Start);\r\n end;\r\n SetString(TmpStr, TmpStart, Start - TmpStart);\r\n ListItem.SubItems.Add(TmpStr);\r\n end;\r\n end;\r\n end;\r\n end;\r\n finally\r\n Items.EndUpdate;\r\n end;\r\nend;\r\n\r\nprocedure TJvListView.LoadFromCSV(FileName: string; Separator: Char);\r\nvar\r\n S: TStringList;\r\nbegin\r\n S := TStringList.Create;\r\n try\r\n S.LoadFromFile(FileName);\r\n LoadFromStrings(S, Separator, True);\r\n finally\r\n S.Free;\r\n end;\r\nend;\r\n\r\nprocedure TJvListView.SaveToCSV(FileName: string; Separator: Char);\r\nvar\r\n S: TStringList;\r\nbegin\r\n S := TStringList.Create;\r\n try\r\n SaveToStrings(S, Separator);\r\n S.SaveToFile(FileName);\r\n finally\r\n S.Free;\r\n end;\r\nend;\r\n\r\nprocedure TJvListView.InvertSelection;\r\nvar\r\n I: Integer;\r\nbegin\r\n Items.BeginUpdate;\r\n try\r\n for I := 0 to Items.Count - 1 do\r\n Items[I].Selected := not Items[I].Selected;\r\n finally\r\n Items.EndUpdate;\r\n end;\r\nend;\r\n\r\nprocedure TJvListView.UnselectAll;\r\nvar\r\n I: Integer;\r\nbegin\r\n Items.BeginUpdate;\r\n try\r\n for I := 0 to Items.Count - 1 do\r\n Items[I].Selected := False;\r\n finally\r\n Items.EndUpdate;\r\n end;\r\nend;\r\n\r\nprocedure TJvListView.KeyPress(var Key: Char);\r\nbegin\r\n inherited KeyPress(Key);\r\n if ReturnKeyTriggersItemDblClick and (Key = #13) and (Selected <> nil) and (SelCount = 1) then\r\n ItemDblClick(Selected, -1, -1, -1);\r\nend;\r\n\r\nprocedure TJvListView.KeyUp(var Key: Word; Shift: TShiftState);\r\nvar\r\n S: string;\r\n I, J: Integer;\r\nbegin\r\n inherited KeyUp(Key, Shift);\r\n if AutoClipboardCopy then\r\n if (Key in [Ord('c'), Ord('C')]) and (ssCtrl in Shift) then\r\n begin\r\n for I := 0 to Columns.Count - 1 do\r\n S := S + Columns[I].Caption + Tab;\r\n if S <> '' then\r\n S := S + sLineBreak;\r\n for I := 0 to Items.Count - 1 do\r\n if (SelCount = 0) or Items[I].Selected then\r\n begin\r\n S := S + Items[I].Caption;\r\n for J := 0 to Items[I].SubItems.Count - 1 do\r\n S := S + Tab + Items[I].SubItems[J];\r\n S := S + sLineBreak;\r\n end;\r\n Clipboard.SetTextBuf(PChar(S));\r\n end;\r\nend;\r\n\r\nfunction TJvListView.GetColumnIndex(PHeader: PNMHdr): Integer;\r\nvar\r\n HwndHeader: HWND;\r\n ItemInfo: THdItem;\r\n ItemIndex: Integer;\r\n Buffer: array [0..128] of Char;\r\nbegin\r\n Result := -1;\r\n HwndHeader := pHeader^.hwndFrom;\r\n ItemIndex := pHDNotify(pHeader)^.Item;\r\n FillChar(ItemInfo, SizeOf(ItemInfo), 0);\r\n ItemInfo.Mask := HDI_TEXT;\r\n ItemInfo.pszText := Buffer;\r\n ItemInfo.cchTextMax := SizeOf(Buffer) - 1;\r\n Header_GetItem(HwndHeader, ItemIndex, ItemInfo);\r\n if CompareStr(Columns[ItemIndex].Caption, ItemInfo.pszText) = 0 then\r\n begin\r\n Result := ItemIndex;\r\n end\r\n else\r\n begin\r\n for ItemIndex := 0 to Columns.Count - 1 do\r\n if CompareStr(Columns[ItemIndex].Caption, ItemInfo.pszText) = 0 then\r\n begin\r\n Result := ItemIndex;\r\n Break;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJvListView.GetColumnsOrder: string;\r\nvar\r\n Res: array of Integer;\r\n I: Integer;\r\nbegin\r\n if Columns.Count > 0 then\r\n begin\r\n if not Columns.Owner.HandleAllocated then\r\n Result := FSavedColumnOrder\r\n else\r\n begin\r\n SetLength(Res, Columns.Count);\r\n ListView_GetColumnOrderArray(Columns.Owner.Handle, Columns.Count, @Res[0]);\r\n Result := '';\r\n for I := 0 to Columns.Count - 1 do\r\n begin\r\n if Result <> '' then\r\n Result := Result + ',';\r\n Result := Result + IntToStr(Res[I]) + '=' + IntToStr(Columns[I].Width);\r\n end;\r\n end;\r\n end\r\n else\r\n Result := '';\r\nend;\r\n\r\nfunction TJvListView.GetColumnWidth(PHeader: PNMHdr): Integer;\r\nbegin\r\n Result := -1;\r\n if Assigned(PHDNotify(PHeader)^.PItem) and\r\n ((PHDNotify(PHeader)^.PItem^.Mask and HDI_WIDTH) <> 0) then\r\n Result := PHDNotify(PHeader)^.PItem^.cxy;\r\nend;\r\n\r\nprocedure TJvListView.SetColumnsOrder(const Order: string);\r\nvar\r\n Res: array of Integer;\r\n I, J: Integer;\r\n S: string;\r\n SL: TStrings;\r\nbegin\r\n if not Columns.Owner.HandleAllocated then\r\n FSavedColumnOrder := Order\r\n else\r\n begin\r\n if Columns.Count > 0 then\r\n begin\r\n SetLength(Res, Columns.Count);\r\n FillChar(Res[0], Length(Res) * SizeOf(Integer), 0);\r\n SL := TStringList.Create;\r\n try\r\n SL.CommaText := Order;\r\n for I := 0 to SL.Count - 1 do\r\n begin\r\n S := SL[I];\r\n J := Pos('=', S);\r\n if (J <> 0) and (I < Columns.Count) then\r\n begin\r\n Columns[I].Width := StrToIntDef(Copy(S, J + 1, Length(S)), Columns[I].Width);\r\n S := Copy(S, 1, J - 1);\r\n end;\r\n Res[I] := StrToIntDef(S, 0);\r\n end;\r\n finally\r\n SL.Free;\r\n end;\r\n ListView_SetColumnOrderArray(Columns.Owner.Handle, Columns.Count, @Res[0]);\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvListView.SetHeaderImages(const Value: TCustomImageList);\r\nbegin\r\n if ReplaceImageListReference(Self, Value, FHeaderImages, FImageChangeLink) then\r\n UpdateHeaderImages(ListView_GetHeader(Handle));\r\nend;\r\n\r\nprocedure TJvListView.SetExtendedColumns(\r\n const Value: TJvListExtendedColumns);\r\nbegin\r\n FExtendedColumns.Assign(Value);\r\nend;\r\n\r\nprocedure TJvListView.Notification(AComponent: TComponent;\r\n Operation: TOperation);\r\nvar\r\n I: Integer;\r\nbegin\r\n inherited Notification(AComponent, Operation);\r\n if Operation = opRemove then\r\n if AComponent = HeaderImages then\r\n HeaderImages := nil\r\n else\r\n if not (csDestroying in ComponentState) and (AComponent is TPopupMenu) then\r\n for I := 0 to Items.Count - 1 do\r\n if TJvListItem(Items[I]).PopupMenu = AComponent then\r\n TJvListItem(Items[I]).PopupMenu := nil;\r\nend;\r\n\r\nprocedure TJvListView.CreateWnd;\r\nvar\r\n Wnd: HWND;\r\nbegin\r\n inherited CreateWnd;\r\n\r\n UpdateHeaderImages(ListView_GetHeader(Handle));\r\n if FSavedExtendedColumns.Count > 0 then\r\n FExtendedColumns.Assign(FSavedExtendedColumns);\r\n\r\n // Get the values from the newly created list view\r\n LoadTileViewProperties;\r\n {$IFNDEF RTL200_UP}\r\n LoadGroupsProperties;\r\n {$ENDIF !RTL200_UP}\r\n FInsertMarkColor := SendMessage(Handle, LVM_GETINSERTMARKCOLOR, 0, 0);\r\n\r\n {$IFNDEF RTL200_UP}\r\n // Force a change from True to False so that InsertMarks work correctly.\r\n SendMessage(Handle, LVM_ENABLEGROUPVIEW, WPARAM(Integer(not FGroupView)), 0);\r\n SendMessage(Handle, LVM_ENABLEGROUPVIEW, WPARAM(Integer(FGroupView)), 0);\r\n {$ENDIF !RTL200_UP}\r\n if FSavedColumnOrder <> '' then\r\n begin\r\n ColumnsOrder := FSavedColumnOrder;\r\n FSavedColumnOrder := '';\r\n end;\r\n\r\n // This will ensure the HDN_Track notification message is sent:\r\n Wnd := GetWindow(Handle, GW_CHILD);\r\n SetWindowLong(wnd, GWL_STYLE, GetWindowLong(wnd, GWL_STYLE) and not HDS_FULLDRAG);\r\nend;\r\n\r\nprocedure TJvListView.UpdateHeaderImages(HeaderHandle: Integer);\r\n//var\r\n// WP: TWindowPlacement;\r\nbegin\r\n if (HeaderHandle <> 0) and (ViewStyle = vsReport) and ShowColumnHeaders then\r\n begin\r\n// WP.length := SizeOf(WP);\r\n// GetWindowPlacement(HeaderHandle, @WP);\r\n if HeaderImages <> nil then\r\n begin\r\n Header_SetImageList(HeaderHandle, HeaderImages.Handle);\r\n// WP.rcNormalPosition.Bottom := WP.rcNormalPosition.Top + HeaderImages.Height + 3;\r\n end\r\n else\r\n if ComponentState * [csLoading, csDestroying] = [] then\r\n begin\r\n Header_SetImageList(HeaderHandle, 0);\r\n// WP.rcNormalPosition.Bottom := WP.rcNormalPosition.Top + 17;\r\n end;\r\n // the problem with resizing the header is that there doesn't seem to be an easy way of telling the listview about it...\r\n// SetWindowPlacement(HeaderHandle, @WP);\r\n UpdateColumns;\r\n Windows.InvalidateRect(HeaderHandle, nil, True)\r\n end;\r\nend;\r\n\r\nprocedure TJvListView.DoHeaderImagesChange(Sender: TObject);\r\nbegin\r\n UpdateHeaderImages(ListView_GetHeader(Handle));\r\nend;\r\n\r\nprocedure TJvListView.SetSmallImages(const Value: TCustomImageList);\r\nbegin\r\n inherited SmallImages := Value;\r\n UpdateHeaderImages(ListView_GetHeader(Handle));\r\nend;\r\n\r\nprocedure TJvListView.Loaded;\r\nbegin\r\n inherited Loaded;\r\n UpdateHeaderImages(ListView_GetHeader(Handle));\r\n TileViewProperties.DoChange;\r\nend;\r\n\r\nprocedure TJvListView.WMNCCalcSize(var Msg: TWMNCCalcSize);\r\n//var\r\n// R: TRect;\r\nbegin\r\n inherited;\r\n// if Msg.CalcValidRects and Assigned(HeaderImages) and (ViewStyle = vsReport) and ShowColumnHeaders then\r\n// with Msg.CalcSize_Params^.rgrc[0] do\r\n// Top := Top + HeaderImages.Height + 3;\r\nend;\r\n\r\nprocedure TJvListView.WMNotify(var Msg: TWMNotify);\r\nbegin\r\n inherited;\r\n\r\n // Must be tested for in WM_NOTIFY handler because the CN_NOTIFY handler\r\n // does not receive them.\r\n // Must also be processed AFTER the inherited handler or the code won't work\r\n case Msg.NMHdr^.code of\r\n HDN_ENDTRACK:\r\n DoEndColumnResize(GetColumnIndex(Msg.NMHdr), GetColumnWidth(Msg.NMHdr));\r\n HDN_BEGINTRACK:\r\n if not DoBeginColumnResize(GetColumnIndex(Msg.NMHdr), GetColumnWidth(Msg.NMHdr)) Then\r\n Msg.Result := 1;\r\n HDN_TRACK:\r\n DoColumnResizing(GetColumnIndex(Msg.NMHdr), GetColumnWidth(Msg.NMHdr));\r\n end;\r\nend;\r\n\r\nprocedure TJvListView.SetBounds(ALeft, ATop, AWidth, AHeight: Integer);\r\nbegin\r\n inherited SetBounds(ALeft, ATop, AWidth, AHeight);\r\n if HandleAllocated then\r\n UpdateHeaderImages(ListView_GetHeader(Handle));\r\nend;\r\n\r\nprocedure TJvListView.InsertItem(Item: TListItem);\r\nbegin\r\n inherited InsertItem(Item);\r\n if AutoSelect and (Selected = nil) and (Items.Count < 2) then\r\n PostMessage(Handle, WM_AUTOSELECT, WPARAM(Item), 1);\r\nend;\r\n\r\nprocedure TJvListView.WMAutoSelect(var Msg: TMessage);\r\nvar\r\n lv: TListItem;\r\nbegin\r\n with Msg do\r\n begin\r\n lv := TListItem(WParam);\r\n if Assigned(lv) and (Items.IndexOf(lv) >= 0) and (LParam = 1) then\r\n begin\r\n lv.Selected := True;\r\n lv.Focused := True;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJvListView.MoveDown(Index: Integer; Focus: Boolean = True): Integer;\r\nvar\r\n lv, lv2: TListItem;\r\n FOnInsert, FOnDeletion: TLVDeletedEvent;\r\n FOnCompare: TLVCompareEvent;\r\nbegin\r\n Result := Index;\r\n if (Index >= 0) and (Index < Items.Count) then\r\n begin\r\n lv2 := Items[Index];\r\n FOnInsert := OnInsert;\r\n FOnDeletion := OnDeletion;\r\n FOnCompare := OnCompare;\r\n try\r\n OnInsert := nil;\r\n OnDeletion := nil;\r\n OnCompare := nil;\r\n lv := Items.Insert(Index + 2);\r\n lv.Assign(lv2);\r\n lv2.Delete;\r\n finally\r\n OnInsert := FOnInsert;\r\n OnDeletion := FOnDeletion;\r\n OnCompare := FOnCompare;\r\n end;\r\n if Focus then\r\n begin\r\n lv.Selected := True;\r\n lv.Focused := True;\r\n end;\r\n Result := lv.Index;\r\n end;\r\nend;\r\n\r\nfunction TJvListView.MoveUp(Index: Integer; Focus: Boolean = True): Integer;\r\nvar\r\n lv, lv2: TListItem;\r\n FOnInsert, FOnDeletion: TLVDeletedEvent;\r\n FOnCompare: TLVCompareEvent;\r\nbegin\r\n Result := Index;\r\n if (Index > 0) and (Index < Items.Count) then\r\n begin\r\n lv2 := Items[Index];\r\n FOnInsert := OnInsert;\r\n FOnDeletion := OnDeletion;\r\n FOnCompare := OnCompare;\r\n try\r\n OnInsert := nil;\r\n OnDeletion := nil;\r\n OnCompare := nil;\r\n lv := Items.Insert(Index - 1);\r\n lv.Assign(lv2);\r\n lv2.Delete;\r\n finally\r\n OnInsert := FOnInsert;\r\n OnDeletion := FOnDeletion;\r\n OnCompare := FOnCompare;\r\n end;\r\n if Focus then\r\n begin\r\n lv.Selected := True;\r\n lv.Focused := True;\r\n end;\r\n Result := lv.Index;\r\n end;\r\nend;\r\n\r\nfunction TJvListView.SelectNextItem(Focus: Boolean = True): Integer;\r\nbegin\r\n Result := ItemIndex + 1;\r\n if Result < Items.Count then\r\n ItemIndex := Result;\r\n Result := ItemIndex;\r\n if Focus and (Result >= 0) and (Result < Items.Count) then\r\n begin\r\n Items[Result].Selected := True;\r\n Items[Result].Focused := True;\r\n end;\r\nend;\r\n\r\nfunction TJvListView.SelectPrevItem(Focus: Boolean = True): Integer;\r\nbegin\r\n Result := ItemIndex - 1;\r\n if Result >= 0 then\r\n ItemIndex := Result;\r\n Result := ItemIndex;\r\n if Focus and (Result >= 0) and (Result < Items.Count) then\r\n begin\r\n Items[Result].Selected := True;\r\n Items[Result].Focused := True;\r\n end;\r\nend;\r\n\r\nprocedure TJvListView.SetFocus;\r\nvar\r\n Index: Integer;\r\nbegin\r\n inherited SetFocus;\r\n\r\n Index := 0;\r\n if Assigned(ItemFocused) then\r\n Index := ItemIndex;\r\n\r\n if AutoSelect and (Selected = nil) and (Items.Count > 0) then\r\n PostMessage(Handle, WM_AUTOSELECT, WPARAM(Items[Index]), 1);\r\nend;\r\n\r\nfunction TJvListView.ShowInsertMark(ItemIndex: Integer; Position: TJvInsertMarkPosition): Boolean;\r\nvar\r\n Infos: TLVINSERTMARK;\r\nbegin\r\n ZeroMemory(@Infos, SizeOf(Infos));\r\n\r\n Infos.cbSize := SizeOf(Infos);\r\n Infos.dwFlags := InsertMarkPositionToLVIM[Position];\r\n Infos.iItem := ItemIndex;\r\n\r\n Result := Bool(SendMessage(Handle, LVM_SETINSERTMARK, 0, LPARAM(@Infos)));\r\nend;\r\n\r\nfunction TJvListView.HideInsertMark: Boolean;\r\nbegin\r\n Result := ShowInsertMark(-1, impBefore);\r\nend;\r\n\r\nfunction TJvListView.GetInsertMarkPosition(const X, Y: Integer;\r\n var ItemIndex: Integer; var Position: TJvInsertMarkPosition): Boolean;\r\nvar\r\n Infos: TLVINSERTMARK;\r\n Point: TPoint;\r\nbegin\r\n Point.X := X;\r\n Point.Y := Y;\r\n\r\n ZeroMemory(@Infos, SizeOf(Infos));\r\n\r\n Infos.cbSize := SizeOf(Infos);\r\n Result := Bool(SendMessage(Handle, LVM_INSERTMARKHITTEST, WPARAM(@Point), LPARAM(@Infos)));\r\n if Result then\r\n begin\r\n ItemIndex := Infos.iItem;\r\n if (Infos.dwFlags and LVIM_AFTER) = LVIM_AFTER then\r\n Position := impAfter\r\n else\r\n Position := impBefore;\r\n end;\r\nend;\r\n\r\nfunction TJvListView.IsCustomDrawn(Target: TCustomDrawTarget; Stage: TCustomDrawStage): Boolean;\r\nbegin\r\n { We must custom draw both cdPrePaint and cdPostPaint because without the\r\n cdPostPaint the TListView creates GDI fonts without releasing them. }\r\n Result := inherited IsCustomDrawn(Target, Stage) or\r\n ((Stage in [cdPrePaint, cdPostPaint]) and (Picture.Graphic <> nil) and not Picture.Graphic.Empty) or\r\n ((Stage in [cdPrePaint, cdPostPaint]) and ((Target = dtItem) or (Target = dtSubItem)));\r\nend;\r\n\r\n\r\nfunction TJvListView.CustomDraw(const ARect: TRect; Stage: TCustomDrawStage): Boolean;\r\nvar\r\n BmpXPos, BmpYPos: Integer; // X and Y position for bitmap\r\n ItemRect: TRect; // List item bounds rectangle\r\n TopOffset: Integer; // Y pos where bmp drawing starts\r\n Bmp: TBitmap;\r\n\r\n function GetHeaderHeight: Integer;\r\n var\r\n Header: HWND; // header window handle\r\n Pl: TWindowPlacement; // header window placement\r\n begin\r\n // Get header window\r\n Header := SendMessage(Handle, LVM_GETHEADER, 0, 0);\r\n // Get header window placement\r\n FillChar(Pl, SizeOf(Pl), 0);\r\n Pl.length := SizeOf(Pl);\r\n GetWindowPlacement(Header, @Pl);\r\n // Calculate header window height\r\n Result := Pl.rcNormalPosition.Bottom - Pl.rcNormalPosition.Top;\r\n end;\r\n\r\nbegin\r\n Result := inherited CustomDraw(ARect, Stage);\r\n if Result and (Stage = cdPrePaint) and (FPicture <> nil) and (FPicture.Graphic <> nil) and not\r\n FPicture.Graphic.Empty and (FPicture.Graphic.Width > 0) and (FPicture.Graphic.Height > 0) then\r\n begin\r\n Bmp := TBitmap.Create;\r\n try\r\n Bmp.Width := ClientWidth;\r\n Bmp.Height := ClientHeight;\r\n Bmp.Canvas.Brush.Color := Self.Color;\r\n Bmp.Canvas.FillRect(ClientRect);\r\n\r\n // Get top offset where drawing starts\r\n if Items.Count > 0 then\r\n begin\r\n ListView_GetItemRect(Handle, 0, ItemRect, LVIR_BOUNDS);\r\n TopOffset := ListView_GetTopIndex(Handle) * (ItemRect.Bottom - ItemRect.Top);\r\n end\r\n else\r\n TopOffset := 0;\r\n if ViewStyle = vsReport then\r\n BmpYPos := ARect.Top - TopOffset + GetHeaderHeight\r\n else\r\n BmpYPos := 0;\r\n // Draw the image\r\n while BmpYPos < ARect.Bottom do\r\n begin\r\n // draw image across width of display\r\n BmpXPos := ARect.Left;\r\n while BmpXPos < ARect.Right do\r\n begin\r\n// DrawIconEx draws alpha-blended icons better (on XP) but gives problems with selecting in the listview\r\n// if Picture.Graphic is TIcon then\r\n// DrawIconEx(Canvas.Handle, BmpXPos, BmpYPos, Picture.Icon.Handle, 0, 0, 0, 0, DI_NORMAL)\r\n// else\r\n Bmp.Canvas.Draw(BmpXPos, BmpYPos, Picture.Graphic);\r\n Inc(BmpXPos, Picture.Graphic.Width);\r\n end;\r\n // move to next row\r\n Inc(BmpYPos, Picture.Graphic.Height);\r\n end;\r\n BitBlt(Canvas, 0, 0, ClientWidth, ClientHeight, Bmp.Canvas, 0, 0, SRCCOPY);\r\n // Ensure that the items are drawn transparently\r\n SetBkMode(Canvas.Handle, TRANSPARENT);\r\n ListView_SetTextBkColor(Handle, CLR_NONE);\r\n ListView_SetBKColor(Handle, CLR_NONE);\r\n finally\r\n Bmp.Free;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJvListView.CustomDrawItem(Item: TListItem;\r\n State: TCustomDrawState; Stage: TCustomDrawStage): Boolean;\r\n//var\r\n// PV: TextColor: TColorRef;\r\nbegin\r\n// PV: TextColor := 0; // silence the compiler\r\n if (Stage = cdPrePaint) and Assigned(Item) then\r\n begin\r\n// PV: TextColor := GetTextColor(Canvas.Handle);\r\n// PV: Canvas.Font := TJvListItem(Item).Font;\r\n if ViewStyle in ViewStylesItemBrush then\r\n begin\r\n// PV: eventueel deze canvas.handle ook uit, maar vooralsnog is viewstylebrush aangepast (uit)\r\n if CheckWin32Version(6, 0) then\r\n SetBkMode(Canvas.Handle, TRANSPARENT);\r\n Canvas.Brush := TJvListItem(Item).Brush;\r\n end;\r\n// PV: Canvas.Handle;\r\n end;\r\n\r\n Result := inherited CustomDrawItem(Item, State, Stage);\r\n\r\n // Restore the text color to allow the ListView to paint the focus rectangle correctly.\r\n// PV: if (Stage = cdPrePaint) and Assigned(Item) then\r\n// SetTextColor(Canvas.Handle, TextColor);\r\nend;\r\n\r\n\r\nprocedure TJvListView.CNNotify(var Message: TWMNotify);\r\nvar\r\n HitTestInfo: TLVHitTestInfo;\r\nbegin\r\n with Message do\r\n begin\r\n case NMHdr^.code of\r\n NM_CUSTOMDRAW:\r\n with PNMCustomDraw(NMHdr)^ do\r\n begin\r\n if (dwDrawStage and CDDS_SUBITEM <> 0) and\r\n (PNMLVCustomDraw(NMHdr)^.iSubItem = 0) then\r\n begin\r\n // Mantis 3908: For some reason, the inherited handler will not call\r\n // the CustomDrawSubItem if iSubItem is equal to zero. But not calling\r\n // it has the consequence to trigger wrong rendering if the order of\r\n // columns is modified and the list item has a non standard font.\r\n // Calling it ourselves here is not enough as the inherited handler\r\n // does some very specific management with the canvas. So we must\r\n // trick it by changing the value to a recognizable value used\r\n // in our CustomDrawSubItem handler.\r\n PNMLVCustomDraw(NMHdr)^.iSubItem := -1;\r\n inherited;\r\n PNMLVCustomDraw(NMHdr)^.iSubItem := 0;\r\n Exit;\r\n end;\r\n end;\r\n\r\n LVN_ENDLABELEDITA, LVN_ENDLABELEDITW:\r\n with PLVDispInfo(Message.NMHdr)^ do\r\n if (item.pszText = nil) and (item.iItem <> -1) then\r\n EditCanceled(Items[item.iItem]);\r\n\r\n NM_CLICK, NM_DBLCLK:\r\n with PNMListView(NMHdr)^ do\r\n begin\r\n HitTestInfo.iItem := iItem;\r\n if HitTestInfo.iItem = -1 then\r\n begin\r\n HitTestInfo.pt := ptAction;\r\n ListView_SubItemHitTest(Handle, @HitTestInfo);\r\n end;\r\n if HitTestInfo.iItem <> -1 then\r\n begin\r\n if NMHdr^.code = NM_CLICK then\r\n ItemClick(Items[HitTestInfo.iItem], iSubItem - 1, ptAction.X, ptAction.Y)\r\n else\r\n ItemDblClick(Items[HitTestInfo.iItem], iSubItem - 1, ptAction.X, ptAction.Y);\r\n end;\r\n end;\r\n end;\r\n end;\r\n\r\n inherited;\r\nend;\r\n\r\nprocedure TJvListView.ItemClick(AItem: TListItem; SubItemIndex: Integer; X, Y: Integer);\r\nbegin\r\n if Assigned(FOnItemClick) then\r\n FOnItemClick(Self, AItem, SubItemIndex, X, Y);\r\nend;\r\n\r\nprocedure TJvListView.ItemDblClick(AItem: TListItem; SubItemIndex: Integer; X, Y: Integer);\r\nbegin\r\n if Assigned(FOnItemDblClick) then\r\n FOnItemDblClick(Self, AItem, SubItemIndex, X, Y);\r\nend;\r\n\r\nprocedure TJvListView.EditCanceled(Item: TListItem);\r\nbegin\r\n if Assigned(FOnCancelEdit) then\r\n FOnCancelEdit(Self, Item);\r\nend;\r\n\r\nfunction TJvListView.CustomDrawSubItem(Item: TListItem; SubItem: Integer;\r\n State: TCustomDrawState; Stage: TCustomDrawStage): Boolean;\r\nbegin\r\n if SubItem = -1 then // See above\r\n SubItem := 0;\r\n\r\n// PV: DIT gaat fout in 2010 ivm Tahoma als default, dat wijkt af van mssansserif (en de 2e keer NIET?)\r\n// if {(Stage = cdPrePaint) and} Assigned(Item) then\r\n// begin\r\n// Canvas.Font := TJvListItem(Item).Font;\r\n// if (ViewStyle in ViewStylesItemBrush) then\r\n// Canvas.Brush := TJvListItem(Item).Brush;\r\n// end;\r\n\r\n Result := inherited CustomDrawSubItem(Item, SubItem, State, Stage);\r\nend;\r\n\r\nprocedure TJvListView.SetPicture(const Value: TPicture);\r\nbegin\r\n FPicture.Assign(Value);\r\nend;\r\n\r\n{$IFNDEF RTL200_UP}\r\nprocedure TJvListView.SetGroupView(const Value: Boolean);\r\nbegin\r\n if FGroupView <> Value then\r\n begin\r\n FGroupView := Value;\r\n SendMessage(Handle, LVM_ENABLEGROUPVIEW, WPARAM(FGroupView), 0);\r\n end;\r\nend;\r\n\r\nprocedure TJvListView.SetGroups(const Value: TJvListViewGroups);\r\nbegin\r\n FGroups.Assign(Value);\r\nend;\r\n\r\nprocedure TJvListView.SetGroupsProperties(const Value: TJvGroupsProperties);\r\nbegin\r\n FGroupsProperties.Assign(Value);\r\nend;\r\n{$ENDIF !RTL200_UP}\r\n\r\nprocedure TJvListView.SetTileViewProperties(const Value: TJvTileViewProperties);\r\nbegin\r\n FTileViewProperties.Assign(Value);\r\nend;\r\n\r\nprocedure TJvListView.SetInsertMarkColor(const Value: TColor);\r\nbegin\r\n if FInsertMarkColor <> Value then\r\n begin\r\n FInsertMarkColor := Value;\r\n\r\n SendMessage(Handle, LVM_SETINSERTMARKCOLOR, 0, ColorToRGB(FInsertMarkColor));\r\n end;\r\nend;\r\n\r\nprocedure TJvListView.SetHeaderImagePosition(const Value: TJvHeaderImagePosition);\r\nbegin\r\n if FHeaderImagePosition <> Value then\r\n begin\r\n FHeaderImagePosition := Value;\r\n UpdateHeaderImages(ListView_GetHeader(Handle));\r\n end;\r\nend;\r\n\r\nprocedure TJvListView.DoPictureChange(Sender: TObject);\r\nbegin\r\n// if (Picture.Graphic <> nil) and not Picture.Graphic.Empty then\r\n// Picture.Graphic.Transparent := true;\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvListView.LVMDeleteColumn(var Msg: TMessage);\r\nbegin\r\n inherited;\r\n // This may happen at design time, especially when migrating\r\n // a project that uses an old version of TJvListView that did\r\n // not have the ExtendedColumns\r\n if Msg.WParam < WPARAM(FExtendedColumns.Count) then\r\n FExtendedColumns.Delete(Msg.WParam);\r\nend;\r\n\r\nprocedure TJvListView.LVMInsertColumn(var Msg: TMessage);\r\nbegin\r\n inherited;\r\n FExtendedColumns.Insert(Msg.WParam);\r\nend;\r\n\r\nprocedure TJvListView.LVMSetColumn(var Msg: TMessage);\r\nvar\r\n i: Integer;\r\n Column: tagLVCOLUMN;\r\nbegin\r\n inherited;\r\n\r\n if not FSettingHeaderImagePosition then\r\n begin\r\n for i := 0 to ExtendedColumns.Count - 1 do\r\n begin\r\n if ExtendedColumns[i].GetHeaderImagePosition = hipRight then\r\n begin\r\n Column.mask := LVCF_FMT;\r\n ListView_GetColumn(Handle, i, Column);\r\n if Column.fmt and LVCFMT_IMAGE <> 0 then\r\n begin\r\n Column.fmt := Column.fmt or LVCFMT_BITMAP_ON_RIGHT;\r\n FSettingHeaderImagePosition := True;\r\n try\r\n ListView_SetColumn(Handle, i, Column);\r\n finally\r\n FSettingHeaderImagePosition := False;\r\n end;\r\n end;\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvListView.DestroyWnd;\r\nbegin\r\n if not (csDestroying in ComponentState) then\r\n begin\r\n FSavedColumnOrder := ColumnsOrder;\r\n FSavedExtendedColumns.Assign(FExtendedColumns);\r\n end;\r\n inherited DestroyWnd;\r\nend;\r\n\r\nprocedure TJvListView.SetViewStylesItemBrush(const Value: TJvViewStyles);\r\nbegin\r\n FViewStylesItemBrush := Value;\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvListView.SetViewStyle(Value: TViewStyle);\r\nbegin\r\n // If someone is setting the view style via an ancestor class reference,\r\n // we force it to be set through our setter. But if it's set via our setter\r\n // then we inform the ancestor class' code so that display is updated.\r\n if not FSettingJvViewStyle then\r\n SetJvViewStyle(TJvViewStyle(Value))\r\n else\r\n inherited SetViewStyle(Value);\r\nend;\r\n\r\nprocedure TJvListView.SetJvViewStyle(Value: TJvViewStyle);\r\nbegin\r\n if Value <> FViewStyle then\r\n begin\r\n FSettingJvViewStyle := True;\r\n try\r\n FViewStyle := Value;\r\n if Value = vsTile then\r\n begin\r\n if HandleAllocated then\r\n begin\r\n SendMessage(Handle, LVM_SETVIEW, LV_VIEW_TILE, 0);\r\n end;\r\n end\r\n else\r\n begin\r\n inherited ViewStyle := TViewStyle(Value);\r\n end;\r\n finally\r\n FSettingJvViewStyle := False;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvListView.SetLastSortedColumnIndex(const Value: Integer);\r\nbegin\r\n if FLastSortedColumnIndex <> Value then\r\n begin\r\n FLastSortedColumnIndex := Value;\r\n ColClick(Columns[Value]);\r\n end;\r\nend;\r\n\r\nfunction TJvListView.DoBeginColumnResize(ColumnIndex,\r\n ColumnWidth: Integer): Boolean;\r\nbegin\r\n Result := True;\r\n if Assigned(FOnBeginColumnResize) then\r\n FOnBeginColumnResize(Self, ColumnIndex, ColumnWidth, Result);\r\nend;\r\n\r\n{$IFNDEF RTL200_UP}\r\nfunction TJvListView.DoCompareGroups(Group1, Group2: TJvListViewGroup): Integer;\r\nbegin\r\n if Assigned(OnCompareGroups) then\r\n OnCompareGroups(Self, Group1, Group2, Result)\r\n else\r\n Result := Group2.GroupId - Group1.GroupId;\r\nend;\r\n{$ENDIF !RTL200_UP}\r\n\r\nprocedure TJvListView.DoColumnResizing(ColumnIndex, ColumnWidth: Integer);\r\nbegin\r\n if Assigned(FOnColumnResizing) then\r\n FOnColumnResizing(Self, ColumnIndex, ColumnWidth);\r\nend;\r\n\r\nprocedure TJvListView.DoEndColumnResize(ColumnIndex, ColumnWidth: Integer);\r\nbegin\r\n if Assigned(FOnEndColumnResize) then\r\n FOnEndColumnResize(Self, ColumnIndex, ColumnWidth);\r\nend;\r\n\r\nprocedure TJvListView.TileViewPropertiesChange(Sender: TObject);\r\nvar\r\n Infos: TLVTILEVIEWINFO;\r\nbegin\r\n if not (csLoading in ComponentState) then\r\n begin\r\n Infos.cbSize := SizeOf(Infos);\r\n Infos.dwMask := LVTVIM_TILESIZE or LVTVIM_COLUMNS or LVTVIM_LABELMARGIN;\r\n Infos.dwFlags := TileSizeKindToLVTVIF[TileViewProperties.TileSizeKind];\r\n TileViewProperties.TileSize.CopyToSize(Infos.sizeTile);\r\n infos.cLines := TileViewProperties.SubLinesCount;\r\n TileViewProperties.LabelMargin.CopyToRect(infos.rcLabelMargin);\r\n\r\n SendMessage(Handle, LVM_SETTILEVIEWINFO, 0, LPARAM(@Infos));\r\n end;\r\nend;\r\n\r\n{$IFNDEF RTL200_UP}\r\nprocedure TJvListView.GroupsPropertiesChange(Sender: TObject);\r\nvar\r\n Infos: TLVGROUPMETRICS;\r\nbegin\r\n if not (csLoading in ComponentState) then\r\n begin\r\n ZeroMemory(@Infos, SizeOf(Infos));\r\n\r\n Infos.cbSize := SizeOf(Infos);\r\n Infos.mask := LVGMF_BORDERSIZE or LVGMF_BORDERCOLOR or LVGMF_TEXTCOLOR;\r\n Infos.Top := GroupsProperties.BorderSize.Top;\r\n Infos.Left := GroupsProperties.BorderSize.Left;\r\n Infos.Bottom := GroupsProperties.BorderSize.Bottom;\r\n Infos.Right := GroupsProperties.BorderSize.Right;\r\n Infos.crTop := GroupsProperties.BorderColor.Top;\r\n Infos.crLeft := GroupsProperties.BorderColor.Left;\r\n Infos.crBottom := GroupsProperties.BorderColor.Bottom;\r\n Infos.crRight := GroupsProperties.BorderColor.Right;\r\n Infos.crHeader := GroupsProperties.HeaderColor;\r\n\r\n SendMessage(Handle, LVM_SETGROUPMETRICS, 0, LPARAM(@Infos));\r\n end;\r\nend;\r\n{$ENDIF !RTL200_UP}\r\n\r\nprocedure TJvListView.LoadTileViewProperties;\r\nbegin\r\n TileViewProperties.LoadFromList(Self);\r\nend;\r\n\r\n{$IFNDEF RTL200_UP}\r\nprocedure TJvListView.LoadGroupsProperties;\r\nbegin\r\n GroupsProperties.LoadFromList(Self);\r\nend;\r\n{$ENDIF !RTL200_UP}\r\n\r\n{$IFNDEF RTL200_UP}\r\n { TJvListViewGroup }\r\n\r\nprocedure TJvListViewGroup.Assign(AValue: TPersistent);\r\nvar\r\n Source: TJvListViewGroup;\r\nbegin\r\n if AValue is TJvListViewGroup then\r\n begin\r\n Source := AValue as TJvListViewGroup;\r\n\r\n FHeader := Source.Header;\r\n FHeaderAlignment := Source.HeaderAlignment;\r\n FGroupId := Source.GroupId;\r\n UpdateGroupProperties;\r\n end;\r\nend;\r\n\r\nconstructor TJvListViewGroup.Create(Collection: Classes.TCollection);\r\nbegin\r\n // Before inherited for Notify to acces it\r\n FGroupId := -1;\r\n FHeaderAlignment := taLeftJustify;\r\n FHeader := 'Group';\r\n\r\n inherited Create(Collection);\r\nend;\r\n\r\ndestructor TJvListViewGroup.Destroy;\r\nbegin\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvListViewGroup.SetHeader(const Value: WideString);\r\nvar\r\n SavedGroupId: Integer;\r\nbegin\r\n if FHeader <> Value then\r\n begin\r\n FHeader := Value;\r\n\r\n // Due to a undocumented bug/feature in the list view, one has to change\r\n // the GroupId as well when changing the caption or the modification is\r\n // not taken into account.\r\n SavedGroupId := GroupId;\r\n UpdateGroupProperties(MaxInt);\r\n FGroupId := MaxInt;\r\n UpdateGroupProperties(SavedGroupId);\r\n FGroupId := SavedGroupId;\r\n end;\r\nend;\r\n\r\nprocedure TJvListViewGroup.SetHeaderAlignment(const Value: TAlignment);\r\nbegin\r\n if FHeaderAlignment <> Value then\r\n begin\r\n FHeaderAlignment := Value;\r\n UpdateGroupProperties;\r\n end;\r\nend;\r\n\r\nprocedure TJvListViewGroup.SetLVGROUP(var GroupInfo: TLVGROUP);\r\nbegin\r\n ZeroMemory(@GroupInfo, sizeof(GroupInfo));\r\n\r\n GroupInfo.cbSize := sizeof(GroupInfo);\r\n GroupInfo.mask := LVGF_HEADER or LVGF_ALIGN or LVGF_GROUPID;\r\n GroupInfo.iGroupId := FGroupId;\r\n GroupInfo.pszHeader := PWideChar(FHeader);\r\n GroupInfo.cchHeader := Length(FHeader);\r\n GroupInfo.uAlign := AlignmentToLVGA[HeaderAlignment];\r\nend;\r\n\r\nprocedure TJvListViewGroup.SetGroupId(const Value: Integer);\r\nbegin\r\n if FGroupId <> Value then\r\n begin\r\n UpdateGroupProperties(Value);\r\n FGroupId := Value;\r\n end;\r\nend;\r\n\r\nprocedure TJvListViewGroup.UpdateGroupProperties(const NewGroupId: Integer = -1);\r\nvar\r\n GroupInfo: TLVGROUP;\r\n List: TJvListView;\r\nbegin\r\n List := (Collection as TJvListViewGroups).ParentList;\r\n if Assigned(List) then\r\n begin\r\n SetLVGROUP(GroupInfo);\r\n if NewGroupId <> -1 then\r\n GroupInfo.iGroupId := NewGroupId;\r\n SendMessage(List.Handle, LVM_SETGROUPINFO, FGroupId, LPARAM(@GroupInfo));\r\n List.Invalidate;\r\n end;\r\nend;\r\n\r\n{ TJvListViewGroups }\r\n\r\nfunction TJvListViewGroups.Compare(Id1, Id2: Integer): Integer;\r\nvar\r\n List: TJvListView;\r\nbegin\r\n Result := Id2 - Id1;\r\n List := ParentList;\r\n if Assigned(List) then\r\n begin\r\n Result := List.DoCompareGroups(ItemsById[Id1], ItemsById[Id2]);\r\n end;\r\nend;\r\n\r\nconstructor TJvListViewGroups.Create(AOwner: TPersistent);\r\nbegin\r\n inherited Create(AOwner, TJvListViewGroup);\r\nend;\r\n\r\nfunction TJvListViewGroups.GetItem(Index: Integer): TJvListViewGroup;\r\nbegin\r\n Result := inherited Items[Index] as TJvListViewGroup;\r\nend;\r\n\r\nfunction TJvListViewGroups.GetItemById(GroupId: Integer): TJvListViewGroup;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := nil;\r\n I := 0;\r\n while (I < Count) and not Assigned(Result) do\r\n begin\r\n if Items[I].GroupId = GroupId then\r\n Result := Items[I];\r\n Inc(I);\r\n end;\r\nend;\r\n\r\nfunction LVGroupCompare(Group1_ID: Integer; Group2_ID: Integer; pvData: Pointer): Integer; stdcall;\r\nbegin\r\n Result := TJvListViewGroups(pvData).Compare(Group1_ID, Group2_ID);\r\nend;\r\n\r\nprocedure TJvListViewGroups.InsertGroupIntoList(group: TJvListViewGroup);\r\nvar\r\n List: TJvListView;\r\n GroupInfo: TLVGROUP;\r\n GroupSortedInfo: TLVINSERTGROUPSORTED;\r\nbegin\r\n List := ParentList;\r\n if Assigned(List) then\r\n begin\r\n if group.GroupId = -1 then\r\n group.FGroupId := Count;\r\n if Sorted then\r\n begin\r\n GroupSortedInfo.pfnGroupCompare := @LVGroupCompare;\r\n GroupSortedInfo.pvData := Self;\r\n group.SetLVGROUP(GroupSortedInfo.lvGroup);\r\n SendMessage(List.Handle, LVM_INSERTGROUPSORTED, WPARAM(@GroupSortedInfo), 0);\r\n end\r\n else\r\n begin\r\n group.SetLVGROUP(GroupInfo);\r\n SendMessage(List.Handle, LVM_INSERTGROUP, group.Index, LPARAM(@GroupInfo));\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvListViewGroups.Notify(Item: TCollectionItem;\r\n Action: TCollectionNotification);\r\nbegin\r\n case Action of\r\n cnAdded:\r\n InsertGroupIntoList(Item as TJvListViewGroup);\r\n cnDeleting:\r\n RemoveGroupFromList(Item as TJvListViewGroup);\r\n end;\r\nend;\r\n\r\nfunction TJvListViewGroups.ParentList: TJvListView;\r\nvar\r\n Owner: TPersistent;\r\nbegin\r\n Result := nil;\r\n Owner := GetOwner;\r\n if Owner is TJvListView then\r\n Result := Owner as TJvListView;\r\nend;\r\n\r\nprocedure TJvListViewGroups.RemoveGroupFromList(group: TJvListViewGroup);\r\nvar\r\n List: TJvListView;\r\nbegin\r\n List := ParentList;\r\n if Assigned(List) then\r\n begin\r\n SendMessage(List.Handle, LVM_REMOVEGROUP, group.GroupId, 0);\r\n end;\r\nend;\r\n\r\nprocedure TJvListViewGroups.SetItem(Index: Integer;\r\n const Value: TJvListViewGroup);\r\nbegin\r\n inherited Items[Index] := Value;\r\nend;\r\n\r\nprocedure TJvListViewGroups.SetSorted(const Value: Boolean);\r\nbegin\r\n if FSorted <> Value then\r\n begin\r\n FSorted := Value;\r\n if FSorted then\r\n Sort;\r\n end;\r\nend;\r\n\r\nprocedure TJvListViewGroups.Sort;\r\nvar\r\n List: TJvListView;\r\nbegin\r\n List := ParentList;\r\n if Assigned(List) then\r\n begin\r\n SendMessage(List.Handle, LVM_SORTGROUPS, WPARAM(@LVGroupCompare), LPARAM(Self));\r\n end;\r\nend;\r\n{$ENDIF !RTL200_UP}\r\n\r\n { TJvTileViewProperties }\r\n\r\nconstructor TJvTileViewProperties.Create;\r\nbegin\r\n inherited Create;\r\n\r\n FLabelMargin := TJvRect.Create;\r\n FTileSize := TJvSize.Create;\r\n\r\n FLabelMargin.OnChange := LabelMarginChange;\r\n FTileSize.OnChange := TileSizeChange;\r\n\r\n FSubLinesCount := 1;\r\n FTileSizeKind := tskAutoSize;\r\nend;\r\n\r\ndestructor TJvTileViewProperties.Destroy;\r\nbegin\r\n FTileSize.Free;\r\n FLabelMargin.Free;\r\n\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvTileViewProperties.DoChange;\r\nbegin\r\n if not FLoading and Assigned(OnChange) then\r\n OnChange(Self);\r\nend;\r\n\r\nprocedure TJvTileViewProperties.LabelMarginChange(Sender: TObject);\r\nbegin\r\n DoChange;\r\nend;\r\n\r\nprocedure TJvTileViewProperties.LoadFromList(List: TCustomListView);\r\nvar\r\n Infos: TLVTILEVIEWINFO;\r\nbegin\r\n if not (csDesigning in List.ComponentState) then\r\n begin\r\n Infos.cbSize := SizeOf(Infos);\r\n Infos.dwMask := LVTVIM_TILESIZE or LVTVIM_COLUMNS or LVTVIM_LABELMARGIN;\r\n\r\n SendMessage(List.Handle, LVM_GETTILEVIEWINFO, 0, LPARAM(@Infos));\r\n\r\n FLoading := True;\r\n try\r\n case Infos.dwFlags of\r\n LVTVIF_FIXEDHEIGHT:\r\n FTileSizeKind := tskFixedHeight;\r\n LVTVIF_FIXEDWIDTH:\r\n FTileSizeKind := tskFixedWidth;\r\n LVTVIF_FIXEDSIZE:\r\n FTileSizeKind := tskFixedSize;\r\n else\r\n FTileSizeKind := tskAutoSize;\r\n end;\r\n TileSize.Assign(Infos.sizeTile);\r\n FSubLinesCount := infos.cLines;\r\n LabelMargin.Assign(infos.rcLabelMargin);\r\n finally\r\n FLoading := False;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvTileViewProperties.SetLabelMargin(const Value: TJvRect);\r\nbegin\r\n FLabelMargin.Assign(Value);\r\nend;\r\n\r\nprocedure TJvTileViewProperties.SetSubLinesCount(const Value: Integer);\r\nbegin\r\n FSubLinesCount := Value;\r\n DoChange;\r\nend;\r\n\r\nprocedure TJvTileViewProperties.SetTileSize(const Value: TJvSize);\r\nbegin\r\n FTileSize.Assign(Value);\r\nend;\r\n\r\nprocedure TJvTileViewProperties.SetTileSizeKind(const Value: TJvTileSizeKind);\r\nbegin\r\n FTileSizeKind := Value;\r\n DoChange;\r\nend;\r\n\r\nprocedure TJvTileViewProperties.TileSizeChange(Sender: TObject);\r\nbegin\r\n DoChange;\r\nend;\r\n\r\n{$IFNDEF RTL200_UP}\r\n { TJvGroupProperties }\r\n\r\nprocedure TJvGroupsProperties.BorderColorChange(Sender: TObject);\r\nbegin\r\n DoChange;\r\nend;\r\n\r\nprocedure TJvGroupsProperties.BorderSizeChange(Sender: TObject);\r\nbegin\r\n DoChange;\r\nend;\r\n\r\nconstructor TJvGroupsProperties.Create;\r\nbegin\r\n inherited Create;\r\n\r\n FBorderSize := TJvGroupsPropertiesBorderRect.Create;\r\n FBorderColor := TJvGroupsPropertiesBorderColors.Create;\r\n\r\n FBorderSize.OnChange := BorderSizeChange;\r\n FBorderColor.OnChange := BorderColorChange;\r\nend;\r\n\r\ndestructor TJvGroupsProperties.Destroy;\r\nbegin\r\n FBorderSize.Free;\r\n FBorderColor.Free;\r\n\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvGroupsProperties.DoChange;\r\nbegin\r\n if not FLoading and Assigned(OnChange) then\r\n OnChange(Self);\r\nend;\r\n\r\nprocedure TJvGroupsProperties.LoadFromList(List: TCustomListView);\r\nvar\r\n Infos: TLVGROUPMETRICS;\r\nbegin\r\n if not (csDesigning in List.ComponentState) then\r\n begin\r\n ZeroMemory(@Infos, SizeOf(Infos));\r\n\r\n Infos.cbSize := SizeOf(Infos);\r\n Infos.mask := LVGMF_BORDERSIZE or LVGMF_BORDERCOLOR or LVGMF_TEXTCOLOR;\r\n SendMessage(List.Handle, LVM_GETGROUPMETRICS, 0, LPARAM(@Infos));\r\n\r\n FLoading := True;\r\n try\r\n BorderSize.Top := Infos.Top;\r\n BorderSize.Left := Infos.Left;\r\n BorderSize.Bottom := Infos.Bottom;\r\n BorderSize.Right := Infos.Right;\r\n BorderColor.Top := Infos.crTop and $00FFFFFF;\r\n BorderColor.Left := Infos.crLeft and $00FFFFFF;\r\n BorderColor.Bottom := Infos.crBottom and $00FFFFFF;\r\n BorderColor.Right := Infos.crRight and $00FFFFFF;\r\n HeaderColor := Infos.crHeader and $00FFFFFF;\r\n finally\r\n FLoading := False;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvGroupsProperties.SetBorderColor(const Value: TJvGroupsPropertiesBorderColors);\r\nbegin\r\n FBorderColor.Assign(Value);\r\nend;\r\n\r\nprocedure TJvGroupsProperties.SetBorderSize(const Value: TJvGroupsPropertiesBorderRect);\r\nbegin\r\n FBorderSize.Assign(Value);\r\nend;\r\n\r\nprocedure TJvGroupsProperties.SetHeaderColor(const Value: TColor);\r\nbegin\r\n if FHeaderColor <> Value then\r\n begin\r\n FHeaderColor := Value;\r\n DoChange;\r\n end;\r\nend;\r\n\r\n { TJvGroupsPropertiesBorderRect }\r\n\r\nconstructor TJvGroupsPropertiesBorderRect.Create;\r\nbegin\r\n inherited Create;\r\n\r\n Top := 12;\r\nend;\r\n\r\n{ TJvGroupsPropertiesBorderColors }\r\n\r\nprocedure TJvGroupsPropertiesBorderColors.Assign(Source: TPersistent);\r\nvar\r\n SourceColors: TJvGroupsPropertiesBorderColors;\r\nbegin\r\n if Source is TJvGroupsPropertiesBorderColors then\r\n begin\r\n SourceColors := Source as TJvGroupsPropertiesBorderColors;\r\n FTop := SourceColors.Top;\r\n FLeft := SourceColors.Left;\r\n FBottom := SourceColors.Bottom;\r\n FRight := SourceColors.Right;\r\n DoChange;\r\n end\r\n else\r\n begin\r\n inherited Assign(Source);\r\n end;\r\nend;\r\n\r\nconstructor TJvGroupsPropertiesBorderColors.Create;\r\nbegin\r\n inherited Create;\r\n\r\n Top := $C8D0D4;\r\n Left := clWhite;\r\n Bottom := clWhite;\r\n Right := clWhite;\r\nend;\r\n\r\nprocedure TJvGroupsPropertiesBorderColors.DoChange;\r\nbegin\r\n if Assigned(OnChange) then\r\n OnChange(Self);\r\nend;\r\n\r\nprocedure TJvGroupsPropertiesBorderColors.SetBottom(const Value: TColor);\r\nbegin\r\n if FBottom <> Value then\r\n begin\r\n FBottom := Value;\r\n DoChange;\r\n end;\r\nend;\r\n\r\nprocedure TJvGroupsPropertiesBorderColors.SetLeft(const Value: TColor);\r\nbegin\r\n if FLeft <> Value then\r\n begin\r\n FLeft := Value;\r\n DoChange;\r\n end;\r\nend;\r\n\r\nprocedure TJvGroupsPropertiesBorderColors.SetRight(const Value: TColor);\r\nbegin\r\n if FRight <> Value then\r\n begin\r\n FRight := Value;\r\n DoChange;\r\n end;\r\nend;\r\n\r\nprocedure TJvGroupsPropertiesBorderColors.SetTop(const Value: TColor);\r\nbegin\r\n if FTop <> Value then\r\n begin\r\n FTop := Value;\r\n DoChange;\r\n end;\r\nend;\r\n{$ENDIF !RTL200_UP}\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvLogClasses.pas", "content": "unit JvLogClasses;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n SysUtils, Contnrs;\r\n\r\ntype\r\n TJvLogEventSeverity = (lesError, lesWarning, lesInformation);\r\n\r\n TJvLogRecord = class(TObject)\r\n public\r\n Time: string;\r\n Title: string;\r\n Description: string;\r\n Severity : TJvLogEventSeverity;\r\n\r\n function GetOutputString: string;\r\n end;\r\n\r\n TJvLogRecordList = class(TObjectList)\r\n private\r\n function GetItem(Index: Integer): TJvLogRecord;\r\n procedure SetItem(Index: Integer; const ALogRecord: TJvLogRecord);\r\n public\r\n property Items[Index: Integer]: TJvLogRecord read GetItem write SetItem; default;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvLogClasses.pas $';\r\n Revision: '$Revision: 12991 $';\r\n Date: '$Date: 2011-02-26 09:25:34 +0100 (sam. 26 févr. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nfunction GetSeverityString( const Severity : TJvLogEventSeverity) : string;\r\nfunction GetSeverityFromString( const SeverityString : string) : TJvLogEventSeverity;\r\n\r\n\r\nimplementation\r\n\r\nresourcestring\r\n STR_SEVERITY_INFORMATION = 'Information';\r\n STR_SEVERITY_WARNING = 'Warning';\r\n STR_SEVERITY_ERROR = 'Error';\r\n\r\nfunction GetSeverityString( const Severity : TJvLogEventSeverity) : string;\r\nbegin\r\n case Severity of\r\n lesError:\r\n result := STR_SEVERITY_ERROR;\r\n lesWarning:\r\n result := STR_SEVERITY_WARNING;\r\n lesInformation:\r\n result := STR_SEVERITY_INFORMATION;\r\n end;\r\nend;\r\n\r\nfunction GetSeverityFromString( const SeverityString : string) : TJvLogEventSeverity;\r\nbegin\r\n if SeverityString = STR_SEVERITY_ERROR then\r\n Result := lesError\r\n else if SeverityString = STR_SEVERITY_WARNING then\r\n Result := lesWarning\r\n else\r\n Result := lesInformation;\r\nend;\r\n\r\n// === { TJvLogRecord } =======================================\r\nfunction TJvLogRecord.GetOutputString: string;\r\nbegin\r\n Result := '[' + Time + ']' + GetSeverityString( Severity) + '>' +\r\n StringReplace(Title, '>', '>>', [rfReplaceAll]) +\r\n '>' + Description + sLineBreak;\r\nend;\r\n\r\n// === { TJvLogRecordList } ===================================\r\n\r\nfunction TJvLogRecordList.GetItem(Index: Integer): TJvLogRecord;\r\nbegin\r\n Result := TJvLogRecord(inherited Items[Index]);\r\nend;\r\n\r\nprocedure TJvLogRecordList.SetItem(Index: Integer;\r\n const ALogRecord: TJvLogRecord);\r\nbegin\r\n inherited Items[Index] := ALogRecord;\r\nend;\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvLogFile.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvLogFile.PAS, released on 2001-02-28.\r\n\r\nThe Initial Developer of the Original Code is Sbastien Buysse [sbuysse att buypin dott com]\r\nPortions created by Sbastien Buysse are Copyright (C) 2001 Sbastien Buysse.\r\nAll Rights Reserved.\r\n\r\nContributor(s): Michael Beck [mbeck att bigfoot dott com].\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvLogFile.pas 13268 2012-03-02 14:49:25Z obones $\r\n\r\nunit JvLogFile;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n SysUtils, Classes, Controls, Forms, Contnrs, Graphics,\r\n JvComponentBase, JvLogClasses;\r\n\r\ntype\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64 or pidOSX32)]\r\n {$ENDIF RTL230_UP}\r\n TJvLogFile = class(TJvComponent)\r\n private\r\n FList: TJvLogRecordList;\r\n FOnClose: TNotifyEvent;\r\n FOnShow: TNotifyEvent;\r\n FFileName: TFileName;\r\n FActive: Boolean;\r\n FAutoSave: Boolean;\r\n FSizeLimit: Cardinal;\r\n FSeverity : TJvLogEventSeverity;\r\n FDefaultSeverity: TJvLogEventSeverity;\r\n function GetElement(Index: Integer): TJvLogRecord;\r\n procedure SetAutoSave(const Value: Boolean);\r\n procedure DoAutoSave;\r\n procedure EnsureSize;\r\n procedure SetFileName(const Value: TFileName);\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n\r\n procedure LoadFromFile(const FileName: TFileName);\r\n procedure SaveToFile(const FileName: TFileName);\r\n procedure SaveToStream(Stream: TStream);\r\n procedure LoadFromStream(Stream: TStream);\r\n\r\n procedure Add(const Time, Title: string; const Severity : TJvLogEventSeverity; const Description: string); overload;\r\n procedure Add(const Title: string; const Severity : TJvLogEventSeverity; const Description: string = ''); overload;\r\n procedure Add(const Time, Title: string; const Description: string); overload;\r\n procedure Add(const Title: string; const Description: string = ''); overload;\r\n procedure Delete(Index: Integer);\r\n procedure Clear;\r\n function Count: Integer;\r\n property Elements[Index: Integer]: TJvLogRecord read GetElement; default;\r\n\r\n procedure ShowLog(const Title: string); overload;\r\n procedure ShowLog(const Title: string; const aIcon : TIcon); overload;\r\n published\r\n // (obones) some extra properties to make transparent use a bit easier\r\n property FileName: TFileName read FFileName write SetFileName;\r\n property Active: Boolean read FActive write FActive default True;\r\n property AutoSave: Boolean read FAutoSave write SetAutoSave default False;\r\n property SizeLimit: Cardinal read FSizeLimit write FSizeLimit default 0; // 0 for infinity\r\n property Severity: TJvLogEventSeverity read FSeverity write FSeverity default lesInformation;\r\n property DefaultSeverity: TJvLogEventSeverity read FDefaultSeverity write FDefaultSeverity default lesError;\r\n\r\n property OnShow: TNotifyEvent read FOnShow write FOnShow;\r\n property OnClose: TNotifyEvent read FOnClose write FOnClose;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvLogFile.pas $';\r\n Revision: '$Revision: 13268 $';\r\n Date: '$Date: 2012-03-02 15:49:25 +0100 (ven. 02 mars 2012) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n JvLogForm, JvConsts;\r\n\r\n\r\n// === { TJvLogFile } =========================================\r\n\r\nconstructor TJvLogFile.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FList := TJvLogRecordList.Create(True);\r\n\r\n // Set default values\r\n FActive := True;\r\n FAutoSave := False;\r\n FSizeLimit := 0;\r\n FSeverity := lesInformation;\r\n FDefaultSeverity := lesError;\r\nend;\r\n\r\ndestructor TJvLogFile.Destroy;\r\nbegin\r\n DoAutoSave;\r\n FList.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvLogFile.Add(const Time, Title : string; const Severity : TJvLogEventSeverity; const Description: string);\r\nvar\r\n LogRecord: TJvLogRecord;\r\nbegin\r\n if not Active then // Do not log if not active (obones)\r\n Exit;\r\n\r\n if Severity > FSeverity then //not all the information is required to be keeped\r\n Exit;\r\n\r\n LogRecord := TJvLogRecord.Create;\r\n LogRecord.Time := Time;\r\n LogRecord.Title := Title;\r\n LogRecord.Severity := Severity;\r\n LogRecord.Description := Description;\r\n FList.Add(LogRecord);\r\n EnsureSize;\r\n DoAutoSave;\r\nend;\r\n\r\nprocedure TJvLogFile.Add(const Title : string; const Severity : TJvLogEventSeverity; const Description: string);\r\nbegin\r\n Add(DateTimeToStr(Now), Title, Severity, Description);\r\nend;\r\n\r\nprocedure TJvLogFile.Add(const Time, Title, Description: string);\r\nbegin\r\n Add(Time, Title, FDefaultSeverity, Description);\r\nend;\r\n\r\nprocedure TJvLogFile.Add(const Title, Description: string);\r\nbegin\r\n Add(DateTimeToStr(Now), Title, Description);\r\nend;\r\n\r\nprocedure TJvLogFile.Clear;\r\nbegin\r\n FList.Clear;\r\n DoAutoSave;\r\nend;\r\n\r\nfunction TJvLogFile.Count: Integer;\r\nbegin\r\n Result := FList.Count;\r\nend;\r\n\r\nprocedure TJvLogFile.Delete(Index: Integer);\r\nbegin\r\n FList.Delete(Index);\r\n DoAutoSave;\r\nend;\r\n\r\nprocedure TJvLogFile.DoAutoSave;\r\nbegin\r\n if AutoSave then\r\n SaveToFile(FileName);\r\nend;\r\n\r\nprocedure TJvLogFile.EnsureSize;\r\nvar\r\n SavedAutoSave: Boolean;\r\n I, J: Integer;\r\n Size: Cardinal;\r\nbegin\r\n if SizeLimit > 0 then\r\n begin\r\n // prevent file from being updated while we modify it\r\n SavedAutoSave := FAutoSave;\r\n AutoSave := False;\r\n\r\n // Calculate size, starting from the last item, so that\r\n // we will only delete the oldest items if required.\r\n I := FList.Count - 1;\r\n Size := 0;\r\n while (I >= 0) and (Size < SizeLimit) do\r\n begin\r\n Inc(Size, Length(FList[I].GetOutputString));\r\n Dec(I);\r\n end;\r\n\r\n // Delete any left over items\r\n if (I >= 0) and (Size >= SizeLimit) then\r\n for J := 0 to I do\r\n Delete(0);\r\n\r\n // Restore saved value and force save if required\r\n FAutoSave := SavedAutoSave;\r\n DoAutoSave;\r\n end;\r\nend;\r\n\r\nfunction TJvLogFile.GetElement(Index: Integer): TJvLogRecord;\r\nbegin\r\n Result := TJvLogRecord(FList[Index]);\r\nend;\r\n\r\nprocedure TJvLogFile.LoadFromFile(const FileName: TFileName);\r\nvar\r\n Stream: TFileStream;\r\nbegin\r\n Stream := TFileStream.Create(FileName, fmOpenRead or fmShareDenyWrite);\r\n try\r\n LoadFromStream(Stream);\r\n finally\r\n Stream.Free;\r\n end;\r\nend;\r\n\r\nprocedure TJvLogFile.LoadFromStream(Stream: TStream);\r\nvar\r\n I, J, L: Integer;\r\n LogRecord: TJvLogRecord;\r\n Found: Boolean;\r\n SavedAutoSave: Boolean;\r\nbegin\r\n SavedAutoSave := AutoSave;\r\n AutoSave := False;\r\n Clear;\r\n AutoSave := SavedAutoSave;\r\n with TStringList.Create do\r\n try\r\n LoadFromStream(Stream);\r\n for I := 0 to Count - 1 do\r\n begin\r\n LogRecord := TJvLogRecord.Create;\r\n\r\n //Extract time\r\n J := Pos('[', Strings[I]);\r\n if J = 0 then\r\n begin\r\n LogRecord.Free;\r\n Continue;\r\n end;\r\n LogRecord.Time := Copy(Strings[I], J + 1, MaxInt);\r\n J := Pos(']', LogRecord.Time);\r\n if J = 0 then\r\n begin\r\n LogRecord.Free;\r\n Continue;\r\n end;\r\n LogRecord.Title := Copy(LogRecord.Time, J + 1, MaxInt);\r\n System.Delete(LogRecord.Time, J, MaxInt);\r\n\r\n J := Pos( '>', LogRecord.Title);\r\n LogRecord.Severity := GetSeverityFromString( Copy( LogRecord.Title, 1, J - 1));\r\n LogRecord.Title := Copy(LogRecord.Title, J + 1, MaxInt);\r\n\r\n //Extract title and description\r\n J := 1;\r\n L := Length(LogRecord.Title);\r\n Found := False;\r\n while (J <= L) and not Found do\r\n begin\r\n if LogRecord.Title[J] = '>' then\r\n begin\r\n if (J < L) and (LogRecord.Title[J + 1] = '>') then\r\n Inc(J, 2)\r\n else\r\n Found := True;\r\n end\r\n else\r\n Inc(J);\r\n end;\r\n // if there's '>', get description field, otherwise assume there's no description\r\n if Found then\r\n LogRecord.Description := Copy(LogRecord.Title, J + 1, MaxInt);\r\n // if J = L (nothing was found), then nothing is deleted,\r\n // otherwise everything is deleted starting with '>' found\r\n System.Delete(LogRecord.Title, J, L);\r\n LogRecord.Title := StringReplace(LogRecord.Title, '>>', '>', [rfReplaceAll]);\r\n FList.Add(LogRecord);\r\n end;\r\n finally\r\n Free;\r\n end;\r\nend;\r\n\r\nprocedure TJvLogFile.SaveToFile(const FileName: TFileName);\r\nvar\r\n Stream: TFileStream;\r\nbegin\r\n if FileName = '' then\r\n Exit;\r\n if csDesigning in ComponentState then\r\n Exit;\r\n Stream := TFileStream.Create(FileName, fmCreate);\r\n try\r\n SaveToStream(Stream);\r\n finally\r\n Stream.Free;\r\n end;\r\nend;\r\n\r\nprocedure TJvLogFile.SaveToStream(Stream: TStream);\r\nvar\r\n I: Integer;\r\n St: AnsiString;\r\nbegin\r\n with TStringList.Create do\r\n try\r\n for I := 0 to FList.Count - 1 do\r\n with FList[I] do\r\n begin\r\n St := AnsiString(GetOutputString);\r\n Stream.WriteBuffer(PAnsiChar(St)^, Length(St) * SizeOf(AnsiChar));\r\n end;\r\n finally\r\n Free;\r\n end;\r\nend;\r\n\r\nprocedure TJvLogFile.SetAutoSave(const Value: Boolean);\r\nbegin\r\n FAutoSave := Value and (FileName <> ''); // can't autosave if no filename (obones)\r\nend;\r\n\r\nprocedure TJvLogFile.SetFileName(const Value: TFileName);\r\nbegin\r\n FFileName := Value;\r\n if FileExists(FileName) then\r\n LoadFromFile(FileName);\r\nend;\r\n\r\nprocedure TJvLogFile.ShowLog(const Title: string);\r\nbegin\r\n ShowLog(Title, nil);\r\nend;\r\n\r\nprocedure TJvLogFile.ShowLog(const Title: string; const aIcon : TIcon);\r\nbegin\r\n with TFoLog.Create(nil) do\r\n try\r\n Icon := aIcon;\r\n Caption := Title;\r\n LogRecordList := FList;\r\n FillList;\r\n\r\n if Assigned(FOnShow) then\r\n FOnShow(Self);\r\n ShowModal;\r\n if Assigned(FOnClose) then\r\n FOnClose(Self);\r\n finally\r\n Free;\r\n end;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvLogForm.dfm", "content": "object FoLog: TFoLog\r\n Left = 454\r\n Top = 250\r\n Caption = 'FoLog'\r\n ClientHeight = 348\r\n ClientWidth = 527\r\n Color = clBtnFace\r\n Constraints.MinHeight = 300\r\n Constraints.MinWidth = 300\r\n Font.Charset = DEFAULT_CHARSET\r\n Font.Color = clWindowText\r\n Font.Height = -11\r\n Font.Name = 'MS Sans Serif'\r\n Font.Style = []\r\n Icon.Data = {\r\n 0000010001001010100001001000280100001600000028000000100000002000\r\n 00000100040000000000C0000000000000000000000000000000000000000000\r\n 0000000080000080000000808000800000008000800080800000C0C0C0008080\r\n 80000000FF0000FF000000FFFF00FF000000FF00FF00FFFF0000FFFFFF000000\r\n 00000000000000000BBBB0000000000BB000BB000000000BB0000B000000000B\r\n BB000BB00000000BBB000BB00000000000000BB00000000000000BB000000000\r\n 00000BB00000000000000BB00000000000000BB00000000000000BB000000000\r\n 00000BB0000000000000BBBB00000000000BBBBBB0000000000000000000FFFF\r\n 0000F87F0000E73F0000E7BF0000E39F0000E39F0000FF9F0000FF9F0000FF9F\r\n 0000FF9F0000FF9F0000FF9F0000FF9F0000FF0F0000FE070000FFFF0000}\r\n OldCreateOrder = False\r\n Position = poScreenCenter\r\n OnCreate = FormCreate\r\n PixelsPerInch = 96\r\n TextHeight = 13\r\n object ToolBar1: TToolBar\r\n Left = 0\r\n Top = 0\r\n Width = 527\r\n Height = 24\r\n AutoSize = True\r\n ButtonWidth = 24\r\n Caption = 'ToolBar1'\r\n EdgeBorders = [ebBottom]\r\n Images = ImageList1\r\n ParentShowHint = False\r\n ShowHint = True\r\n TabOrder = 0\r\n ExplicitWidth = 413\r\n object ToolButton2: TToolButton\r\n Left = 0\r\n Top = 0\r\n Action = Save\r\n end\r\n object ToolButton1: TToolButton\r\n Left = 24\r\n Top = 0\r\n Action = Print\r\n end\r\n object ToolButton3: TToolButton\r\n Left = 48\r\n Top = 0\r\n Width = 8\r\n Caption = 'ToolButton3'\r\n ImageIndex = 2\r\n Style = tbsSeparator\r\n end\r\n object ToolButton4: TToolButton\r\n Left = 56\r\n Top = 0\r\n Caption = 'ToolButton4'\r\n DropdownMenu = PopupMenu1\r\n ImageIndex = 2\r\n end\r\n end\r\n object ListView1: TListView\r\n Left = 0\r\n Top = 24\r\n Width = 527\r\n Height = 324\r\n Align = alClient\r\n Columns = <\r\n item\r\n Caption = 'Time'\r\n Width = 115\r\n end\r\n item\r\n Caption = 'Severity'\r\n end\r\n item\r\n Caption = 'Title'\r\n Width = 120\r\n end\r\n item\r\n Caption = 'Description'\r\n Width = 150\r\n end>\r\n FlatScrollBars = True\r\n GridLines = True\r\n HotTrack = True\r\n ReadOnly = True\r\n RowSelect = True\r\n TabOrder = 1\r\n ViewStyle = vsReport\r\n ExplicitWidth = 413\r\n ExplicitHeight = 313\r\n end\r\n object ImageList1: TImageList\r\n Left = 16\r\n Top = 56\r\n Bitmap = {\r\n 494C010105003000300010001000FFFFFFFFFF10FFFFFFFFFFFFFFFF424D3600\r\n 0000000000003600000028000000400000002000000001002000000000000020\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 000000000000747EF7003242F7001126F6001126F6003242F700747EF7000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 000000000000000000000000000000000000000000000000000000000000757F\r\n F900041EF7000621F1000621F1000723EF000723EF000621F1000621F100041E\r\n F700757FF9000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 00000000000000000000000000000000000000000000000000004B59F7000621\r\n F1000621F1000729EF001125AD001E2246002023410013249E000926EE000723\r\n EF000621F1004857F70000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 000000000000000000000000000000000000000000007781F9000621F100062A\r\n F1000729EF000729EF001F265A002827310028273100242844000729EF000729\r\n EF00062AF1000621F100757FF900000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 000000000000000000000000000000000000000000000420F600062AF100062A\r\n F1000732EF000729EF000D2DC8001C2A70001E296C000F2CBE000732EF00072E\r\n EE00062AF100062AF1000420F600000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000007781F9000328F6000631F0000631\r\n F0000732EF000631F0000631F0000B31DC000B31DC000732EF000631F0000631\r\n F0000631F0000631F0000328F6007781F9000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000003547F8000631F0000439F6000439\r\n F6000439F6000638F2000439F6001C359B001F368F000439F6000439F6000638\r\n F2000439F6000439F6000631F0003043F8000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 000000000000000000000000000000000000142BF7000439F6000541F4000541\r\n F4000541F4000541F4000541F400283A80002B3D78000541F4000541F4000541\r\n F4000541F4000541F4000439F600102AF8000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 000000000000000000000000000000000000142CF7000242F700034AF500034A\r\n F500034AF500034AF500044AF2003E4358003E435800044AF200034AF500034A\r\n F500034AF500034AF5000541F400102AF8000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000003548F9000242F7000557F8000557\r\n F8000557F8000557F8001453D00043435B0043435B001453D0000557F8000557\r\n F8000557F8000557F8000242F7003548F9000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000007987FA000242F7001468FA001468\r\n FA001468FA001468FA002C58AD0050505B0050505B00335CA4001468FA001468\r\n FA001468FA001468FA000242F7007781F9000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 000000000000000000000000000000000000000000000328F6002972FB003280\r\n FA003280FA003280FA00435C8C004E5067004E506700445887003280FA003280\r\n FA003280FA002972FB000328F600000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 000000000000000000000000000000000000000000007987FA001042FC005796\r\n FC005D9DFB005D9DFB004C5782004C4C72004C4C72004C557C005D9DFB005D9D\r\n FB005897FB001042FC007781F900000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 00000000000000000000000000000000000000000000000000005263F9001A4A\r\n FD007BA9FC0092BEFD007E9DC900606D7E00606D7E007C99C40092BEFD007BA9\r\n FC001A4AFD004E61F90000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000007987\r\n FA00092EFB004570FD0084A7FE00A3C0FD00A3C0FD0084A7FE004570FD00102A\r\n F8007987FA000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000008592F8003548F9001531F9001531F9003548F900808DF9000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 000000000000DDD09100D0B95C00C7AD3E00C7AD3E00D0B95C00DCD08E000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 00000000000078BDF70034A0F7001190F6001190F600339FF70077BDF7000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 000000000000000000000000000000000000000000000000000000000000DDD0\r\n 9100C4A93600C1A53500C1A53500C1A53500C1A53500C1A53500C1A53500C4A9\r\n 3600DCD08E0000000000000000000000000000000000000000000000000074BB\r\n F900028EF6000791F3000891F1000891F1000894F6000891F1000791F300028E\r\n F60077BDF7000000000000000000000000000000000031636300639C9C00639C\r\n 9C00313131003131310031313100313131003131310031313100B5B5B500B5B5\r\n B500313131000063630000000000000000000000000000000000FFFFFF00FFFF\r\n FF00FFFFFF00DEDEDE00DEDEDE00CECECE00CECECE00B5B5B500B5B5B5000000\r\n 00005A5A5A000000000000000000000000000000000000000000D3C36E00C1A5\r\n 3500C1A53500C1A535008D7930003D3926003A36260081702E00C1A53500C1A5\r\n 3500C1A53500D3C36E000000000000000000000000000000000046A6F7000791\r\n F3000A92ED000A92ED001670AC00262E3400292C2E0018679B000891F1000A92\r\n ED000791F30043A5F70000000000000000000000000031636300639C9C009CCE\r\n CE004A4A4A004A4A4A0031313100313131003131310031313100CECECE00B5B5\r\n B50031313100639C9C0000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000005A5A5A00000000000000000000000000DDD09100C1A53500C1A0\r\n 3600BE9D3600BE9D36004D462A002E2E29002E2E29003D392A00BE9D3600BE9D\r\n 3600C1A53500C1A53500DDCF8E00000000000000000074BBF9000791F3000999\r\n F1000A92ED000999F100273945002C2928002C2928002C2928000999F1000A92\r\n ED000A99ED000791F30074BBF9000000000000000000316363009CCECE009CCE\r\n CE004A4A4A004A4A4A004A4A4A004A4A4A004A4A4A0031313100FFFFFF00CECE\r\n CE0031313100639C9C00000000000000000084848400FFFFFF00FFFFFF00DEDE\r\n DE00CECECE00CECECE00CECECE0000FF000000FF000000FF0000CECECE00CECE\r\n CE000000000000000000000000000000000000000000C4A93600C1A53500C1A0\r\n 3600BE9D3600BE9D3600A28633005E522D005E522D009A803200BE9D3600BE9D\r\n 3600BE9D3600C1A03600C4A9360000000000000000000191F8000999F1000A99\r\n ED000A99ED000A99ED001187CC00264C6200274A5E001480C0000999F1000A99\r\n ED000A99ED000999F1000791F3000000000000000000316363009CCECE009CCE\r\n CE004A4A4A004A4A4A004A4A4A004A4A4A004A4A4A004A4A4A004A4A4A004A4A\r\n 4A0031313100639C9C00000000000000000084848400FFFFFF00FFFFFF00FFFF\r\n FF00DEDEDE00CECECE00CECECE00008400000084000000840000CECECE00CECE\r\n CE0000000000848484000000000000000000DDD09100C1A53500C3943600C1A0\r\n 3600C3943600BE9D3600BE9D3600B18F3500AE8E3500BE9D3600BE9D3600C394\r\n 3600BE9D3600C1A03600C1A03600DDCF8E0079C1F9000999F10007A0F200089E\r\n EE00089EEE00089EEE0008A0F1000D97E3000D97E30007A0F200089EEE00089E\r\n EE00089EEE0007A0F2000999F10076C1F9000000000031636300CEFFFF009CCE\r\n CE009CCECE009CCECE009CCECE009CCECE009CCECE009CCECE009CCECE009CCE\r\n CE009CCECE00639C9C0000000000000000008484840084848400848484008484\r\n 8400848484008484840084848400848484008484840084848400848484008484\r\n 840000000000848484008484840000000000D0B95C00C1A03600C3943600C394\r\n 3600C3943600C3943600C3943600806B350078653600C3943600C3943600BE9D\r\n 3600C3943600C3943600C1A03600CEB9590036A2F80007A0F20008A0F10009A5\r\n F00009A5F00008A0F10006A9F500246C8E002763810009A5F00009A5F00009A5\r\n F00009A5F00008A0F10006A1F50031A1F8000000000031636300CEFFFF009CCE\r\n CE00316363003163630031636300316363003163630031636300316363003163\r\n 63009CCECE00639C9C00000000000000000084848400FFFFFF00FFFFFF00FFFF\r\n FF00FFFFFF00FFFFFF00DEDEDE00DEDEDE00CECECE00CECECE00CECECE000000\r\n 000084848400000000008484840000000000C8AD4200C3943600C3943600C394\r\n 3600C3943600C3943600C39436006C5D380068593A00C3943600C3943600C394\r\n 3600C3943600C3943600C3943600C7AD3E001495F60006A9F50004B6F70007B0\r\n F20004B6F70009A5F00004B6F70033607200355C6B0004B3F90007B0F20004B6\r\n F70009A5F00004B6F70006A9F5000894F6000000000031636300CEFFFF00639C\r\n 9C00CEFFFF00CEFFFF009CFFFF009CFFFF009CFFFF009CFFFF009CFFFF009CFF\r\n FF00316363009CCECE0000000000000000000000000084848400848484008484\r\n 8400848484008484840084848400848484008484840084848400848484008484\r\n 840000000000848484000000000000000000C8AD4200C3943600C38C3400C38C\r\n 3400C38C3400C38C3400C08B3400524E4300524E4300C08B3400C38C3400C38C\r\n 3400C38C3400C38C3400C3943600C7AD3E001495F60004B3F90004BCF40004BC\r\n F40004BCF40004BCF40003C0FB00494848004948480003C0FB0004BCF40004BC\r\n F40004BCF40004BCF40004BCF4001495F6000000000031636300CEFFFF00639C\r\n 9C00CEFFFF00CEFFFF00CEFFFF00CEFFFF00CEFFFF00CEFFFF009CFFFF009CFF\r\n FF00316363009CCECE000000000000000000000000000000000084848400CECE\r\n CE00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF000000\r\n 000084848400000000008484840000000000D0B95C00C5923400C38C3400C38C\r\n 3400C38C3400C38C3400AB7C3A00524E430056544700AB7C3A00C38C3400C38C\r\n 3400C5893600C38C3400C5923400D0B95C0036A2F80004B6F70008C9F80008C9\r\n F80007C9F60008C9F80017AED300514949005149490018ACD00008C9F80007C9\r\n F60007C9F60008C9F80004B6F70036A2F8000000000031636300CEFFFF00639C\r\n 9C00FFFFFF00FFFFFF00FFFFFF00FFFFFF00CEFFFF00CEFFFF00CEFFFF009CFF\r\n FF00316363009CCECE0000000000000000000000000000000000000000008484\r\n 8400FFFFFF00FF313100FF313100FF313100FF313100FF313100FFFFFF000000\r\n 000000000000000000000000000000000000DFD09400C8993800CA8C4200CA8C\r\n 4200CA8C4200CA8C42009272460059585200595852008C6E4A00CA8C4200CA8C\r\n 4200CA8C4200CA8C4200C8993800DDCF8E0079C1F90008B5FB0015D4F90015D4\r\n F90015D4F90013D7FE003791A3005653520056535200398E9E0015D4F90015D4\r\n F90015D4F90015D4F90008B5FB0076C1F9000000000031636300CEFFFF00639C\r\n 9C00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00CEFFFF00CEFFFF009CFF\r\n FF00316363009CCECE0000000000000000000000000000000000000000008484\r\n 8400CECECE00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00CECE\r\n CE000000000000000000000000000000000000000000C8A53700D09A5400D198\r\n 5A00D1985A00D1985A007D6A5100615F5300615F53007D6A5100D1985A00D198\r\n 5A00D1985A00D09A5400C8A5370000000000000000000098FB002DD9FA0034DF\r\n FB0032DFFB0034DFFB0053757B005B595A005B595A00556E730034DFFB0034DF\r\n FB0034DFFB002DD9FA000098FB00000000000000000031636300CEFFFF00639C\r\n 9C00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00CEFFFF00CEFFFF009CFF\r\n FF00316363003163630000000000000000000000000000000000000000000000\r\n 000084848400FFFFFF00FF633100FF633100FF633100FF633100FF633100FFFF\r\n FF000000000000000000000000000000000000000000DFD09400CBA24000D9AC\r\n 7800D9AC7800D9AC7800776D56006A6753006A675300776D5600DAAB7C00D9AC\r\n 7800D9AC7800CBA24000DECF9000000000000000000079C1F90008B5FB0061E8\r\n FB005EE8FC005EEFFF005D6464005B595A005D5D5E005D5D5E005EEFFF005EE8\r\n FC005EE8FC0008B5FB0074BBF900000000000000000031636300FFFFFF00639C\r\n 9C00639C6300639C6300639C6300639C6300639C6300639C6300639C6300639C\r\n 630031636300C6C6C60000000000000000000000000000000000000000000000\r\n 000084848400CECECE00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFF\r\n FF00CECECE000000000000000000000000000000000000000000D6C37400CEA6\r\n 4800E1C09600E6C7A700B9A38D00766D6500766D6500B5A08A00E6C7A700E1C0\r\n 9600CEA64800D6C37400000000000000000000000000000000004CABF80014B4\r\n FD0087ECFD009CF6FF0087C0C600666A6A00666A6A0086BABF009CF6FF0087EC\r\n FD0014B4FD004CABF8000000000000000000000000003163630031636300639C\r\n 9C00639C6300639C6300639C6300639C6300639C6300639C6300639C6300639C\r\n 6300316363003163630000000000000000000000000000000000000000000000\r\n 0000000000008484840084848400848484008484840084848400848484008484\r\n 840084848400848484000000000000000000000000000000000000000000E0D2\r\n 9800C7AD3E00D7B46A00E4C99C00EAD4B500EAD4B500E4C99C00D7B46A00C9A6\r\n 3A00E0D2980000000000000000000000000000000000000000000000000079C1\r\n F9000098FB0044C7FE008BE7FF00B0F6FF00B0F6FF008BE7FF0046C9FE000098\r\n FB0079C1F9000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 000000000000E0D29800D0B95C00C8AD4200C8AD4200D0B95C00E0D29C000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 00000000000086C8F80038A5F8001598F8001598F80037A5FA0086C8F8000000\r\n 000000000000000000000000000000000000424D3E000000000000003E000000\r\n 2800000040000000200000000100010000000000000100000000000000000000\r\n 000000000000000000000000FFFFFF00F81F000000000000E007000000000000\r\n C003000000000000800100000000000080010000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 000000000000000080010000000000008001000000000000C003000000000000\r\n E007000000000000F81F000000000000FFFFFFFFF81FF81FC001C007E007E007\r\n 80018003C003C003800100018001800180010001800180018001000100000000\r\n 8001000000000000800100000000000080018000000000008001C00000000000\r\n 8001E001000000008001E007800180018001F007800180018001F003C003C003\r\n 8001F803E007E007FFFFFFFFF81FF81F00000000000000000000000000000000\r\n 000000000000}\r\n end\r\n object ActionList1: TActionList\r\n Left = 80\r\n Top = 56\r\n object Save: TAction\r\n Caption = 'Save'\r\n Hint = 'Save'\r\n ImageIndex = 0\r\n ShortCut = 16467\r\n OnExecute = SaveExecute\r\n end\r\n object Print: TAction\r\n Caption = '&Print'\r\n Hint = 'Print'\r\n ImageIndex = 1\r\n ShortCut = 16464\r\n OnExecute = PrintExecute\r\n end\r\n end\r\n object SaveDialog1: TSaveDialog\r\n DefaultExt = 'csv'\r\n Filter = 'CSV File (*.csv)|*.csv|Binary File (*.dat)|*.dat'\r\n Left = 136\r\n Top = 56\r\n end\r\n object PopupMenu1: TPopupMenu\r\n Images = ImageList1\r\n Left = 208\r\n Top = 56\r\n object mnuInformation: TMenuItem\r\n AutoCheck = True\r\n Caption = 'Information'\r\n ImageIndex = 2\r\n RadioItem = True\r\n OnClick = mnuInformationClick\r\n end\r\n object mnuWarning: TMenuItem\r\n AutoCheck = True\r\n Caption = 'Warning'\r\n ImageIndex = 3\r\n RadioItem = True\r\n OnClick = mnuWarningClick\r\n end\r\n object mnuError: TMenuItem\r\n AutoCheck = True\r\n Caption = 'Error'\r\n ImageIndex = 4\r\n RadioItem = True\r\n OnClick = mnuErrorClick\r\n end\r\n end\r\nend\r\n" }, { "path": "External/Jedi/Jvcl/run/JvLogForm.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvLogForm.PAS, released on 2001-02-28.\r\n\r\nThe Initial Developer of the Original Code is Sbastien Buysse [sbuysse att buypin dott com]\r\nPortions created by Sbastien Buysse are Copyright (C) 2001 Sbastien Buysse.\r\nAll Rights Reserved.\r\n\r\nContributor(s): Michael Beck [mbeck att bigfoot dott com].\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvLogForm.pas 12863 2010-10-11 08:10:36Z obones $\r\n\r\nunit JvLogForm;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Controls, Forms, Dialogs, ComCtrls, ActnList, ImgList, ToolWin,\r\n SysUtils, Classes, JvComponent, JvLogClasses, Menus;\r\n\r\ntype\r\n TFoLog = class(TJvForm)\r\n ToolBar1: TToolBar;\r\n ToolButton1: TToolButton;\r\n ToolButton2: TToolButton;\r\n ImageList1: TImageList;\r\n ActionList1: TActionList;\r\n Save: TAction;\r\n Print: TAction;\r\n ListView1: TListView;\r\n SaveDialog1: TSaveDialog;\r\n ToolButton3: TToolButton;\r\n ToolButton4: TToolButton;\r\n PopupMenu1: TPopupMenu;\r\n mnuInformation: TMenuItem;\r\n mnuWarning: TMenuItem;\r\n mnuError: TMenuItem;\r\n procedure SaveExecute(Sender: TObject);\r\n procedure PrintExecute(Sender: TObject);\r\n procedure FormCreate(Sender: TObject);\r\n procedure mnuInformationClick(Sender: TObject);\r\n procedure mnuWarningClick(Sender: TObject);\r\n procedure mnuErrorClick(Sender: TObject);\r\n private\r\n FLogRecordList : TJvLogRecordList;\r\n FSeverity : TJvLogEventSeverity;\r\n\r\n procedure MakeLogLines(S: TStrings);\r\n public\r\n property LogRecordList : TJvLogRecordList read FLogRecordList write FLogRecordList;\r\n\r\n procedure FillList;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvLogForm.pas $';\r\n Revision: '$Revision: 12863 $';\r\n Date: '$Date: 2010-10-11 10:10:36 +0200 (lun. 11 oct. 2010) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n Printers;\r\n\r\n{$R *.dfm}\r\n\r\nprocedure TFoLog.SaveExecute(Sender: TObject);\r\nvar\r\n S: TStringList;\r\nbegin\r\n if SaveDialog1.Execute then\r\n begin\r\n S := TStringList.Create;\r\n try\r\n MakeLogLines(S);\r\n S.SaveToFile(SaveDialog1.FileName);\r\n finally\r\n S.Free;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TFoLog.FillList;\r\nvar\r\n I: Integer;\r\nbegin\r\n with ListView1 do\r\n begin\r\n Items.Clear;\r\n\r\n Items.BeginUpdate;\r\n for I := 0 to FLogRecordList.Count - 1 do\r\n with FLogRecordList[I] do\r\n begin\r\n if Severity > FSeverity then\r\n continue;\r\n\r\n with Items.Add do\r\n begin\r\n Caption := Time;\r\n SubItems.Add(GetSeverityString( Severity));\r\n SubItems.Add(Title);\r\n SubItems.Add(Description);\r\n end;\r\n end;\r\n Items.EndUpdate;\r\n end;\r\nend;\r\n\r\nprocedure TFoLog.FormCreate(Sender: TObject);\r\nbegin\r\n FSeverity := lesInformation;\r\n mnuInformation.Checked := true;\r\nend;\r\n\r\nprocedure TFoLog.MakeLogLines(S: TStrings);\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := 0 to ListView1.Items.Count-1 do\r\n // (rom) Format parameters were missing\r\n S.Add(Format('[%s] %s > %s > %s',\r\n [ListView1.Items[I].Caption, ListView1.Items[I].SubItems[0],\r\n ListView1.Items[I].SubItems[1], ListView1.Items[I].SubItems[2]]));\r\nend;\r\n\r\nprocedure TFoLog.mnuErrorClick(Sender: TObject);\r\nbegin\r\n FSeverity := lesError;\r\n ToolButton4.Caption := 'E';\r\n ToolButton4.ImageIndex := 4;\r\n FillList;\r\nend;\r\n\r\nprocedure TFoLog.mnuInformationClick(Sender: TObject);\r\nbegin\r\n FSeverity := lesInformation;\r\n ToolButton4.Caption := 'I';\r\n ToolButton4.ImageIndex := 2;\r\n FillList;\r\nend;\r\n\r\nprocedure TFoLog.mnuWarningClick(Sender: TObject);\r\nbegin\r\n FSeverity := lesWarning;\r\n ToolButton4.Caption := 'W';\r\n ToolButton4.ImageIndex := 3;\r\n FillList;\r\nend;\r\n\r\nprocedure TFoLog.PrintExecute(Sender: TObject);\r\nvar\r\n I: Integer;\r\n S: TStringList;\r\n F: TextFile;\r\nbegin\r\n S := TStringList.Create;\r\n try\r\n MakeLogLines(S);\r\n AssignPrn(F);\r\n Rewrite(F);\r\n for I := 0 to S.Count-1 do\r\n Writeln(F, S[I]);\r\n CloseFile(F);\r\n finally\r\n S.Free;\r\n end;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend." }, { "path": "External/Jedi/Jvcl/run/JvLoginForm.dfm", "content": "object JvLoginForm: TJvLoginForm\r\n Left = 213\r\n Top = 102\r\n Cursor = crArrow\r\n BorderIcons = []\r\n BorderStyle = bsDialog\r\n ClientHeight = 159\r\n ClientWidth = 442\r\n Color = clBtnFace\r\n Font.Charset = DEFAULT_CHARSET\r\n Font.Color = clWindowText\r\n Font.Height = -11\r\n Font.Name = 'MS Sans Serif'\r\n Font.Style = []\r\n FormStyle = fsStayOnTop\r\n OldCreateOrder = True\r\n Position = poScreenCenter\r\n OnCreate = FormCreate\r\n OnShow = FormShow\r\n PixelsPerInch = 96\r\n TextHeight = 13\r\n object AppIcon: TImage\r\n Left = 14\r\n Top = 12\r\n Width = 32\r\n Height = 32\r\n AutoSize = True\r\n end\r\n object KeyImage: TImage\r\n Left = 10\r\n Top = 15\r\n Width = 32\r\n Height = 32\r\n AutoSize = True\r\n Picture.Data = {\r\n 055449636F6E0000010001002020100000000000E80200001600000028000000\r\n 2000000040000000010004000000000080020000000000000000000000000000\r\n 0000000000000000000080000080000000808000800000008000800080800000\r\n C0C0C000808080000000FF0000FF000000FFFF00FF000000FF00FF00FFFF0000\r\n FFFFFF00000000000000000000000000000000008FFFFFFFFFFFFFFFFF000000\r\n 000000008FFFFFFFFFFFFFFFFF000000000000008FFFFFFFFFF00F00FF000000\r\n 000000008FF800FFFFF00F00FF000000000000008F80800FFFF00F00FF000000\r\n 000000008F00FF00000000000F000000000000008F00FF00000000000F000000\r\n 000000008F80800FFFFFFFFFFF000000000000008FF800FFFFFFFFFFFF000000\r\n 000000008FFFFFFFFFFFFFFFFF00000000000000888888888888888888000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000001FFF00001FFF00001FFF00001FFF00001FFF00001FFF00001FFF\r\n 00001FFF00001FFF00001FFF00001FFF00001FFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFF}\r\n end\r\n object HintLabel: TLabel\r\n Left = 64\r\n Top = 31\r\n Width = 285\r\n Height = 13\r\n AutoSize = False\r\n ShowAccelChar = False\r\n end\r\n object UserNameLabel: TLabel\r\n Left = 64\r\n Top = 64\r\n Width = 105\r\n Height = 13\r\n AutoSize = False\r\n FocusControl = UserNameEdit\r\n end\r\n object PasswordLabel: TLabel\r\n Left = 64\r\n Top = 96\r\n Width = 105\r\n Height = 13\r\n AutoSize = False\r\n FocusControl = PasswordEdit\r\n end\r\n object AppTitleLabel: TLabel\r\n Left = 64\r\n Top = 12\r\n Width = 285\r\n Height = 13\r\n AutoSize = False\r\n ShowAccelChar = False\r\n end\r\n object CustomLabel: TLabel\r\n Left = 64\r\n Top = 128\r\n Width = 105\r\n Height = 13\r\n AutoSize = False\r\n FocusControl = CustomCombo\r\n end\r\n object UserNameEdit: TEdit\r\n Left = 172\r\n Top = 60\r\n Width = 169\r\n Height = 21\r\n Cursor = crIBeam\r\n TabOrder = 0\r\n end\r\n object PasswordEdit: TEdit\r\n Left = 172\r\n Top = 92\r\n Width = 169\r\n Height = 21\r\n Cursor = crIBeam\r\n PasswordChar = '*'\r\n TabOrder = 1\r\n end\r\n object OkBtn: TButton\r\n Left = 356\r\n Top = 12\r\n Width = 77\r\n Height = 25\r\n Caption = 'OK'\r\n Default = True\r\n TabOrder = 3\r\n OnClick = OkBtnClick\r\n end\r\n object CancelBtn: TButton\r\n Left = 356\r\n Top = 44\r\n Width = 77\r\n Height = 25\r\n Cancel = True\r\n Caption = 'Cancel'\r\n ModalResult = 2\r\n TabOrder = 4\r\n end\r\n object CustomCombo: TComboBox\r\n Left = 172\r\n Top = 124\r\n Width = 169\r\n Height = 21\r\n Style = csDropDownList\r\n Sorted = True\r\n TabOrder = 2\r\n end\r\nend\r\n" }, { "path": "External/Jedi/Jvcl/run/JvLoginForm.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvxLogin.PAS, released on 2002-07-04.\r\n\r\nThe Initial Developers of the Original Code are: Fedor Koshevnikov, Igor Pavluk and Serge Korolev\r\nCopyright (c) 1997, 1998 Fedor Koshevnikov, Igor Pavluk and Serge Korolev\r\nCopyright (c) 2001,2002 SGB Software\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\n Hofi\r\n\r\nLast Modified: 2004-10-07\r\n\r\nChanges:\r\n2004-10-07:\r\n * Added\r\n TJvCustomLogin\r\n property Caption to support a custom dialog Caption.\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvLoginForm.pas 13352 2012-06-14 09:21:26Z obones $\r\n\r\nunit JvLoginForm;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n SysUtils, Classes,\r\n {$IFDEF MSWINDOWS}\r\n Windows, // GetCurrentThreadID => Linux: System.pas\r\n {$ENDIF MSWINDOWS}\r\n {$IFDEF HAS_UNIT_LIBC}\r\n Libc, // GetCurrentThreadID Linux\r\n {$ENDIF HAS_UNIT_LIBC}\r\n Messages, Graphics, Controls, Forms, StdCtrls, ExtCtrls,\r\n JvComponent, JvBaseDlg, JvAppStorage;\r\n\r\ntype\r\n TUpdateCaption = (ucNoChange, ucAppTitle, ucFormCaption);\r\n TJvLoginEvent = procedure(Sender: TObject; const UserName, Password: string;\r\n var AllowLogin: Boolean) of object;\r\n TCheckUnlockEvent = function(const Password: string): Boolean of object;\r\n TUnlockAppEvent = procedure(Sender: TObject; const UserName,\r\n Password: string; var AllowUnlock: Boolean) of object;\r\n TJvOnGetPassword = procedure(Sender: TObject; const UserName: string; var Password: string) of object;\r\n\r\n TJvLoginForm = class;\r\n\r\n TJvCustomLogin = class(TJvCommonDialog)\r\n private\r\n FActive: Boolean;\r\n FAttemptNumber: Integer;\r\n FCaption: string;\r\n FLoggedUser: string;\r\n FMaxPasswordLen: Integer;\r\n FAllowEmptyPassword: Boolean;\r\n FUpdateCaption: TUpdateCaption;\r\n FAppStorage: TJvCustomAppStorage;\r\n FAppStoragePath: string;\r\n FLocked: Boolean;\r\n FSaveOnRestore: TNotifyEvent;\r\n FAfterLogin: TNotifyEvent;\r\n FBeforeLogin: TNotifyEvent;\r\n FOnUnlock: TCheckUnlockEvent;\r\n FOnUnlockApp: TUnlockAppEvent;\r\n FOnIconDblClick: TNotifyEvent;\r\n FOnGetPassword: TJvOnGetPassword;\r\n FAppTitleLabelCaption: string;\r\n FPasswordLabelCaption: string;\r\n FUserNameLabelCaption: string;\r\n FUnlockDlgShowing: Boolean;\r\n FPasswordChar: Char;\r\n function UnlockHook(var Msg: TMessage): Boolean;\r\n function GetLoggedUser: string;\r\n procedure SetAppStorage(Value: TJvCustomAppStorage);\r\n protected\r\n function CheckUnlock(const UserName, Password: string): Boolean; dynamic;\r\n function CreateLoginForm(UnlockMode: Boolean): TJvLoginForm; virtual;\r\n procedure DoAfterLogin; dynamic;\r\n procedure DoBeforeLogin; dynamic;\r\n procedure DoIconDblClick(Sender: TObject); dynamic;\r\n function DoLogin(var UserName: string): Boolean; virtual; abstract;\r\n function DoUnlockDialog: Boolean; virtual;\r\n procedure SetLoggedUser(const Value: string);\r\n procedure DoUpdateCaption;\r\n procedure UnlockOkClick(Sender: TObject);\r\n property Active: Boolean read FActive write FActive default True;\r\n property AllowEmptyPassword: Boolean read FAllowEmptyPassword write FAllowEmptyPassword default True;\r\n property AttemptNumber: Integer read FAttemptNumber write FAttemptNumber default 3;\r\n property MaxPasswordLen: Integer read FMaxPasswordLen write FMaxPasswordLen default 0;\r\n property UpdateCaption: TUpdateCaption read FUpdateCaption write FUpdateCaption default ucNoChange;\r\n property PasswordChar: Char read FPasswordChar write FPasswordChar default '*';\r\n property AfterLogin: TNotifyEvent read FAfterLogin write FAfterLogin;\r\n property BeforeLogin: TNotifyEvent read FBeforeLogin write FBeforeLogin;\r\n property OnUnlock: TCheckUnlockEvent read FOnUnlock write FOnUnlock; { obsolete }\r\n property OnUnlockApp: TUnlockAppEvent read FOnUnlockApp write FOnUnlockApp;\r\n property OnIconDblClick: TNotifyEvent read FOnIconDblClick write FOnIconDblClick;\r\n property AppStorage: TJvCustomAppStorage read FAppStorage write SetAppStorage;\r\n property AppStoragePath: string read FAppStoragePath write FAppStoragePath;\r\n property AppTitleLabelCaption: string read FAppTitleLabelCaption write FAppTitleLabelCaption;\r\n property PasswordLabelCaption: string read FPasswordLabelCaption write FPasswordLabelCaption;\r\n property UserNameLabelCaption: string read FUserNameLabelCaption write FUserNameLabelCaption;\r\n property OnGetPassword: TJvOnGetPassword read FOnGetPassword write FOnGetPassword;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n function Login: Boolean; virtual;\r\n function Execute(ParentWnd: HWND): Boolean; overload; override;\r\n procedure TerminateApplication;\r\n procedure Lock;\r\n property LoggedUser: string read GetLoggedUser write SetLoggedUser;\r\n published\r\n property Caption: string read FCaption write FCaption;\r\n end;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvLoginDialog = class(TJvCustomLogin)\r\n private\r\n FOnCheckUser: TJvLoginEvent;\r\n procedure OkButtonClick(Sender: TObject);\r\n procedure WriteUserName(const UserName: string);\r\n function ReadUserName(const UserName: string): string;\r\n protected\r\n function DoCheckUser(const UserName, Password: string): Boolean; dynamic;\r\n function DoLogin(var UserName: string): Boolean; override;\r\n function DoGetPassword(const UserName, Password: string): string;\r\n procedure Loaded; override;\r\n published\r\n property Active;\r\n property AppStorage;\r\n property AppStoragePath;\r\n property AppTitleLabelCaption;\r\n property PasswordLabelCaption;\r\n property UserNameLabelCaption;\r\n property AttemptNumber;\r\n property Caption;\r\n property MaxPasswordLen;\r\n property UpdateCaption;\r\n property PasswordChar;\r\n property OnCheckUser: TJvLoginEvent read FOnCheckUser write FOnCheckUser;\r\n property OnGetPassword;\r\n property AfterLogin;\r\n property BeforeLogin;\r\n property OnUnlockApp;\r\n property OnIconDblClick;\r\n end;\r\n\r\n TJvLoginForm = class(TJvForm)\r\n AppIcon: TImage;\r\n KeyImage: TImage;\r\n HintLabel: TLabel;\r\n UserNameLabel: TLabel;\r\n PasswordLabel: TLabel;\r\n UserNameEdit: TEdit;\r\n PasswordEdit: TEdit;\r\n AppTitleLabel: TLabel;\r\n OkBtn: TButton;\r\n CancelBtn: TButton;\r\n CustomLabel: TLabel;\r\n CustomCombo: TComboBox;\r\n procedure FormCreate(Sender: TObject);\r\n procedure OkBtnClick(Sender: TObject);\r\n procedure FormShow(Sender: TObject);\r\n private\r\n FSelectDatabase: Boolean;\r\n FUnlockMode: Boolean;\r\n FAttempt: Integer;\r\n FOnFormShow: TNotifyEvent;\r\n FOnOkClick: TNotifyEvent;\r\n FOnGetPassword: TJvOnGetPassword;\r\n protected\r\n procedure CreateParams(var Params: TCreateParams); override;\r\n public\r\n AttemptNumber: Integer;\r\n property Attempt: Integer read FAttempt;\r\n property SelectDatabase: Boolean read FSelectDatabase write FSelectDatabase;\r\n property OnFormShow: TNotifyEvent read FOnFormShow write FOnFormShow;\r\n property OnOkClick: TNotifyEvent read FOnOkClick write FOnOkClick;\r\n property OnGetPassword: TJvOnGetPassword read FOnGetPassword write FOnGetPassword;\r\n end;\r\n\r\nfunction CreateLoginDialog(UnlockMode, ASelectDatabase: Boolean;\r\n FormShowEvent, OkClickEvent: TNotifyEvent;\r\n ACaption: string = ''): TJvLoginForm;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvLoginForm.pas $';\r\n Revision: '$Revision: 13352 $';\r\n Date: '$Date: 2012-06-14 11:21:26 +0200 (jeu. 14 juin 2012) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n Consts,\r\n JvJCLUtils, JvResources, JvConsts;\r\n\r\n{$R *.dfm}\r\n\r\nfunction CreateLoginDialog(UnlockMode, ASelectDatabase: Boolean;\r\n FormShowEvent, OkClickEvent: TNotifyEvent; ACaption: string = ''): TJvLoginForm;\r\nbegin\r\n Result := TJvLoginForm.Create(Application);\r\n with Result do\r\n begin\r\n Caption := ACaption;\r\n FSelectDatabase := ASelectDatabase;\r\n FUnlockMode := UnlockMode;\r\n if FUnlockMode then\r\n begin\r\n FormStyle := fsNormal;\r\n FSelectDatabase := False;\r\n end\r\n else\r\n FormStyle := fsStayOnTop;\r\n OnFormShow := FormShowEvent;\r\n OnOkClick := OkClickEvent;\r\n end;\r\nend;\r\n\r\n//=== { TJvCustomLogin } =====================================================\r\n\r\nconstructor TJvCustomLogin.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FLoggedUser := '';\r\n FActive := True;\r\n FAttemptNumber := 3;\r\n FPasswordChar := '*';\r\n FAllowEmptyPassword := True;\r\nend;\r\n\r\ndestructor TJvCustomLogin.Destroy;\r\nbegin\r\n if FLocked then\r\n begin\r\n Application.UnhookMainWindow(UnlockHook);\r\n FLocked := False;\r\n end;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvCustomLogin.SetAppStorage(Value: TJvCustomAppStorage);\r\nbegin\r\n FAppStorage := Value;\r\nend;\r\n\r\nfunction TJvCustomLogin.GetLoggedUser: string;\r\nbegin\r\n Result := FLoggedUser;\r\nend;\r\n\r\nprocedure TJvCustomLogin.SetLoggedUser(const Value: string);\r\nbegin\r\n FLoggedUser := Value;\r\nend;\r\n\r\nprocedure TJvCustomLogin.DoAfterLogin;\r\nbegin\r\n if Assigned(FAfterLogin) then\r\n FAfterLogin(Self);\r\nend;\r\n\r\nprocedure TJvCustomLogin.DoBeforeLogin;\r\nbegin\r\n if Assigned(FBeforeLogin) then\r\n FBeforeLogin(Self);\r\nend;\r\n\r\nprocedure TJvCustomLogin.DoIconDblClick(Sender: TObject);\r\nbegin\r\n if Assigned(FOnIconDblClick) then\r\n FOnIconDblClick(Self);\r\nend;\r\n\r\nprocedure TJvCustomLogin.DoUpdateCaption;\r\nvar\r\n F: TCustomForm;\r\nbegin\r\n F := Application.MainForm;\r\n if (F = nil) and (Owner is TForm) then\r\n F := Owner as TForm;\r\n if (F <> nil) and (LoggedUser <> '') then\r\n case UpdateCaption of\r\n ucAppTitle:\r\n F.Caption := Format('%s (%s)', [Application.Title, LoggedUser]);\r\n ucFormCaption:\r\n begin\r\n F.Caption := Format('%s (%s)', [F.Caption, LoggedUser]);\r\n UpdateCaption := ucNoChange;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJvCustomLogin.Login: Boolean;\r\nvar\r\n LoginName: string;\r\nbegin\r\n LoginName := '';\r\n DoBeforeLogin;\r\n LoginName := LoggedUser;\r\n Result := DoLogin(LoginName);\r\n if Result then\r\n begin\r\n SetLoggedUser(LoginName);\r\n DoUpdateCaption;\r\n DoAfterLogin;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomLogin.Lock;\r\nbegin\r\n FSaveOnRestore := Application.OnRestore;\r\n Application.Minimize;\r\n Application.HookMainWindow(UnlockHook);\r\n FLocked := True;\r\nend;\r\n\r\nprocedure TJvCustomLogin.TerminateApplication;\r\nbegin\r\n with Application do\r\n begin\r\n ShowMainForm := False;\r\n if Handle <> 0 then\r\n ShowOwnedPopups(Handle, False);\r\n Terminate;\r\n end;\r\n CallTerminateProcs;\r\nend;\r\n\r\nprocedure TJvCustomLogin.UnlockOkClick(Sender: TObject);\r\nvar\r\n Ok: Boolean;\r\nbegin\r\n with TJvLoginForm(Sender) do\r\n begin\r\n Ok := False;\r\n try\r\n Ok := CheckUnlock(UserNameEdit.Text, PasswordEdit.Text);\r\n except\r\n Application.HandleException(Self);\r\n end;\r\n if Ok then\r\n ModalResult := mrOk\r\n else\r\n ModalResult := mrCancel;\r\n end;\r\nend;\r\n\r\nfunction TJvCustomLogin.CheckUnlock(const UserName, Password: string): Boolean;\r\nbegin\r\n Result := True;\r\n if Assigned(FOnUnlockApp) then\r\n FOnUnlockApp(Self, UserName, Password, Result)\r\n else\r\n if Assigned(FOnUnlock) then\r\n Result := FOnUnlock(Password);\r\nend;\r\n\r\nfunction TJvCustomLogin.CreateLoginForm(UnlockMode: Boolean): TJvLoginForm;\r\nbegin\r\n Result := TJvLoginForm.Create(Application);\r\n Result.Caption := FCaption;\r\n with Result do\r\n begin\r\n FUnlockMode := UnlockMode;\r\n if FUnlockMode then\r\n begin\r\n FormStyle := fsNormal;\r\n FSelectDatabase := False;\r\n end\r\n else\r\n FormStyle := fsStayOnTop;\r\n if Assigned(Self.FOnIconDblClick) then\r\n begin\r\n with AppIcon do\r\n begin\r\n OnDblClick := DoIconDblClick;\r\n Cursor := crHand;\r\n end;\r\n with KeyImage do\r\n begin\r\n OnDblClick := DoIconDblClick;\r\n Cursor := crHand;\r\n end;\r\n end;\r\n PasswordEdit.MaxLength := FMaxPasswordLen;\r\n PasswordEdit.PasswordChar := PasswordChar;\r\n AttemptNumber := Self.AttemptNumber;\r\n if AppTitleLabelCaption <> '' then\r\n AppTitleLabel.Caption := AppTitleLabelCaption;\r\n if PasswordLabelCaption <> '' then\r\n PasswordLabel.Caption := PasswordLabelCaption;\r\n if UserNameLabelCaption <> '' then\r\n UserNameLabel.Caption := UserNameLabelCaption;\r\n end;\r\nend;\r\n\r\nfunction TJvCustomLogin.DoUnlockDialog: Boolean;\r\nbegin\r\n with CreateLoginForm(True) do\r\n try\r\n OnFormShow := nil;\r\n OnOkClick := UnlockOkClick;\r\n with UserNameEdit do\r\n begin\r\n Text := LoggedUser;\r\n ReadOnly := True;\r\n Font.Color := clGrayText;\r\n end;\r\n Result := ShowModal = mrOk;\r\n finally\r\n Free;\r\n end;\r\nend;\r\n\r\n\r\nfunction TJvCustomLogin.UnlockHook(var Msg: TMessage): Boolean;\r\n\r\n function DoUnlock: Boolean;\r\n var\r\n Popup: HWND;\r\n begin\r\n with Application do\r\n if IsWindowVisible(Handle) and IsWindowEnabled(Handle) then\r\n SetForegroundWindow(Handle);\r\n if FUnlockDlgShowing then\r\n begin\r\n Popup := GetLastActivePopup(Application.Handle);\r\n if (Popup <> 0) and IsWindowVisible(Popup) and\r\n (WindowClassName(Popup) = TJvLoginForm.ClassName) then\r\n SetForegroundWindow(Popup);\r\n Result := False;\r\n Exit;\r\n end;\r\n FUnlockDlgShowing := True;\r\n try\r\n Result := DoUnlockDialog;\r\n finally\r\n FUnlockDlgShowing := False;\r\n end;\r\n if Result then\r\n begin\r\n Application.UnhookMainWindow(UnlockHook);\r\n FLocked := False;\r\n end;\r\n end;\r\n\r\nbegin\r\n Result := False;\r\n if not FLocked then\r\n Exit;\r\n with Msg do\r\n begin\r\n case Msg of\r\n WM_QUERYOPEN:\r\n UnlockHook := not DoUnlock;\r\n WM_SHOWWINDOW:\r\n if WParam <> 0 then\r\n UnlockHook := not DoUnlock;\r\n WM_SYSCOMMAND:\r\n if ((WParam and $FFF0) = SC_RESTORE) or ((WParam and $FFF0) = SC_ZOOM) then\r\n UnlockHook := not DoUnlock;\r\n end;\r\n end;\r\nend;\r\n\r\n\r\n//=== { TJvLoginDialog } =====================================================\r\n\r\nprocedure TJvLoginDialog.Loaded;\r\nvar\r\n Loading: Boolean;\r\nbegin\r\n Loading := csLoading in ComponentState;\r\n inherited Loaded;\r\n if not (csDesigning in ComponentState) and Loading then\r\n if Active and not Login then\r\n TerminateApplication;\r\nend;\r\n\r\nprocedure TJvLoginDialog.OkButtonClick(Sender: TObject);\r\nvar\r\n SetCursor: Boolean;\r\nbegin\r\n with TJvLoginForm(Sender) do\r\n begin\r\n SetCursor := GetCurrentThreadID = MainThreadID;\r\n try\r\n if SetCursor then\r\n Screen.Cursor := crHourGlass;\r\n try\r\n if DoCheckUser(UserNameEdit.Text, DoGetPassword(UserNameEdit.Text, PasswordEdit.Text)) then\r\n ModalResult := mrOk\r\n else\r\n ModalResult := mrNone;\r\n finally\r\n if SetCursor then\r\n Screen.Cursor := crDefault;\r\n end;\r\n except\r\n Application.HandleException(Self);\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJvLoginDialog.DoCheckUser(const UserName, Password: string): Boolean;\r\nbegin\r\n Result := True;\r\n if Assigned(FOnCheckUser) then\r\n FOnCheckUser(Self, UserName, Password, Result);\r\nend;\r\n\r\nprocedure TJvLoginDialog.WriteUserName(const UserName: string);\r\nbegin\r\n if Assigned(AppStorage) then\r\n AppStorage.WriteString(AppStorage.ConcatPaths([AppStoragePath, RsLastLoginUserName]), UserName);\r\nend;\r\n\r\nfunction TJvLoginDialog.ReadUserName(const UserName: string): string;\r\nbegin\r\n if Assigned(AppStorage) then\r\n Result := AppStorage.ReadString(AppStorage.ConcatPaths([AppStoragePath, RsLastLoginUserName]), UserName)\r\n else\r\n Result := UserName;\r\nend;\r\n\r\nfunction TJvLoginDialog.DoGetPassword(const UserName, Password: string): string;\r\nbegin\r\n Result := Password;\r\n if Assigned(OnGetPassword) then\r\n OnGetPassword(Self, UserName, Result);\r\nend;\r\n\r\nfunction TJvLoginDialog.DoLogin(var UserName: string): Boolean;\r\nbegin\r\n try\r\n with CreateLoginForm(False) do\r\n try\r\n OnOkClick := Self.OkButtonClick;\r\n UserName := ReadUserName(UserName);\r\n UserNameEdit.Text := UserName;\r\n Result := (ShowModal = mrOk);\r\n if Result then\r\n begin\r\n UserName := UserNameEdit.Text;\r\n WriteUserName(UserName);\r\n end;\r\n finally\r\n Free;\r\n end;\r\n except\r\n Application.HandleException(Self);\r\n Result := False;\r\n end;\r\nend;\r\n\r\n//=== { TJvLoginForm } =======================================================\r\n\r\nprocedure TJvLoginForm.CreateParams(var Params: TCreateParams);\r\nbegin\r\n inherited CreateParams(Params);\r\n\r\n // required for latest versions of Delphi to cooperate nicely with latest versions of Windows\r\n Params.ExStyle := Params.ExStyle or WS_EX_APPWINDOW;\r\nend;\r\n\r\nprocedure TJvLoginForm.FormCreate(Sender: TObject);\r\nbegin\r\n Icon := Application.Icon;\r\n if Icon.Empty then\r\n Icon.Handle := LoadIcon(0, IDI_APPLICATION);\r\n AppIcon.Picture.Assign(Icon);\r\n AppTitleLabel.Caption := Format(RsAppTitleLabel, [Application.Title]);\r\n PasswordLabel.Caption := RsPasswordLabel;\r\n UserNameLabel.Caption := RsUserNameLabel;\r\n OkBtn.Caption := SOKButton;\r\n CancelBtn.Caption := SCancelButton;\r\nend;\r\n\r\nprocedure TJvLoginForm.OkBtnClick(Sender: TObject);\r\nbegin\r\n Inc(FAttempt);\r\n if Assigned(FOnOkClick) then\r\n FOnOkClick(Self)\r\n else\r\n ModalResult := mrOk;\r\n if (ModalResult <> mrOk) and (FAttempt >= AttemptNumber) then\r\n ModalResult := mrCancel;\r\nend;\r\n\r\nprocedure TJvLoginForm.FormShow(Sender: TObject);\r\nvar\r\n I: Integer;\r\n S: string;\r\nbegin\r\n if FSelectDatabase then\r\n begin\r\n ClientHeight := CustomCombo.Top + PasswordEdit.Top - UserNameEdit.Top;\r\n S := RsDatabaseName;\r\n I := Pos(':', S);\r\n if I = 0 then\r\n I := Length(S);\r\n CustomLabel.Caption := '&' + Copy(S, 1, I);\r\n end\r\n else\r\n begin\r\n ClientHeight := PasswordEdit.Top + PasswordEdit.Top - UserNameEdit.Top;\r\n CustomLabel.Visible := False;\r\n CustomCombo.Visible := False;\r\n end;\r\n if not FUnlockMode then\r\n begin\r\n HintLabel.Caption := RsHintLabel;\r\n if Caption = '' then\r\n Caption := RsRegistrationCaption;\r\n end\r\n else\r\n begin\r\n HintLabel.Caption := RsUnlockHint;\r\n if Caption = '' then\r\n Caption := RsUnlockCaption;\r\n end;\r\n if (UserNameEdit.Text = '') and not FUnlockMode then\r\n ActiveControl := UserNameEdit\r\n else\r\n ActiveControl := PasswordEdit;\r\n if Assigned(FOnFormShow) then\r\n FOnFormShow(Self);\r\n FAttempt := 0;\r\nend;\r\n\r\nfunction TJvCustomLogin.Execute(ParentWnd: HWND): Boolean;\r\nbegin\r\n Result := Login;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvLookOut.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvLookOut.PAS, released on 2002-05-26.\r\n\r\nThe Initial Developer of the Original Code is Peter Thrnqvist [peter3 at sourceforge dot net]\r\nPortions created by Peter Thrnqvist are Copyright (C) 2002 Peter Thrnqvist.\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvLookOut.pas 13415 2012-09-10 09:51:54Z obones $\r\n\r\nunit JvLookOut;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n SysUtils, Classes,\r\n Windows, Messages,\r\n Graphics, Controls, Forms, StdCtrls, ExtCtrls, Buttons, Menus, ImgList,\r\n {$IFDEF HAS_UNIT_SYSTEM_UITYPES}\r\n System.UITypes,\r\n {$ENDIF HAS_UNIT_SYSTEM_UITYPES}\r\n JvJCLUtils, JvTypes, JvConsts, JvComponent, JvThemes, JvExControls, JvExButtons;\r\n\r\ntype\r\n TJvButtonBorder = (bbDark, bbLight, bbMono);\r\n\r\n TJvUpArrowBtn = class(TJvExSpeedButton, IJvDenySubClassing)\r\n private\r\n FTimer: TTimer;\r\n FAutoRepeat: Boolean;\r\n FDown: Boolean;\r\n FFlat: Boolean;\r\n procedure SetFlat(Value: Boolean);\r\n procedure CMDesignHitTest(var Msg: TCMDesignHitTest); message CM_DESIGNHITTEST;\r\n protected\r\n procedure OnTime(Sender: TObject); virtual;\r\n procedure Paint; override;\r\n procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;\r\n procedure MouseUp(Button: TMouseButton; Shift: TShiftState;\r\n X, Y: Integer); override;\r\n procedure MouseEnter(Control: TControl); override;\r\n procedure MouseLeave(Control: TControl); override;\r\n public\r\n procedure Click; override;\r\n constructor Create(AOwner: TComponent); override;\r\n published\r\n property Flat: Boolean read FFlat write SetFlat default False;\r\n property AutoRepeat: Boolean read FAutoRepeat write FAutoRepeat default True;\r\n end;\r\n\r\n TJvDwnArrowBtn = class(TJvUpArrowBtn)\r\n protected\r\n procedure Paint; override;\r\n procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;\r\n procedure MouseUp(Button: TMouseButton; Shift: TShiftState;\r\n X, Y: Integer); override;\r\n procedure OnTime(Sender: TObject); override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n end;\r\n\r\n TJvLookOutEditedEvent = procedure(Sender: TObject; var Caption: string) of object;\r\n\r\n TJvCustomLookOutButton = class(TJvGraphicControl)\r\n private\r\n FEdit: TEdit;\r\n FData: Pointer;\r\n FParentImageSize: Boolean;\r\n FDown: Boolean;\r\n FStayDown: Boolean;\r\n FCentered: Boolean;\r\n FImageIndex: TImageIndex;\r\n FSpacing: Integer;\r\n FOffset: Integer;\r\n FImageSize: TJvImageSize;\r\n FImageRect: TRect;\r\n FTextRect: TRect;\r\n FFillColor: TColor;\r\n FHighlightFont: TFont;\r\n FButtonBorder: TJvButtonBorder;\r\n FPopupMenu: TPopupMenu;\r\n FGroupIndex: Integer;\r\n FSmallImages: TCustomImageList;\r\n FLargeImages: TCustomImageList;\r\n FOnEdited: TJvLookOutEditedEvent;\r\n FLargeImageChangeLink: TChangeLink;\r\n FSmallImageChangeLink: TChangeLink;\r\n procedure SetGroupIndex(Value: Integer);\r\n procedure UpdateExclusive;\r\n procedure SetCentered(Value: Boolean);\r\n procedure SetDown(Value: Boolean);\r\n procedure SetOffset(Value: Integer);\r\n procedure SetFillColor(Value: TColor);\r\n procedure SetHighlightFont(Value: TFont);\r\n procedure SetSpacing(Value: Integer);\r\n procedure SetParentImageSize(Value: Boolean);\r\n procedure SetButtonBorder(Value: TJvButtonBorder);\r\n procedure SetSmallImages(const Value: TCustomImageList);\r\n procedure SetLargeImages(const Value: TCustomImageList);\r\n procedure SetImageIndex(Value: TImageIndex);\r\n procedure SetImageSize(Value: TJvImageSize);\r\n procedure DrawSmallImages;\r\n procedure DrawLargeImages;\r\n procedure ImageListChange(Sender: TObject);\r\n procedure CMButtonPressed(var Msg: TCMButtonPressed); message CM_JVBUTTONPRESSED;\r\n procedure CMParentImageSizeChanged(var Msg: TMessage); message CM_IMAGESIZECHANGED;\r\n procedure CMLeaveButton(var Msg: TMessage); message CM_LEAVEBUTTON;\r\n procedure CMTextChanged(var Msg:TMessage); message CM_TEXTCHANGED;\r\n function ParentVisible: Boolean;\r\n procedure SetPopupMenu(const Value: TPopupMenu);\r\n protected\r\n\r\n procedure ActionChange(Sender: TObject; CheckDefaults: Boolean); override;\r\n function GetActionLinkClass: TControlActionLinkClass; override;\r\n procedure Notification(AComponent: TComponent; Operation: TOperation); override;\r\n procedure DoOnEdited(var Caption: string); virtual;\r\n procedure EditKeyDown(Sender: TObject; var Key: Char);\r\n procedure EditMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState;\r\n X, Y: Integer);\r\n procedure PaintFrame; virtual;\r\n procedure SetParent( AParent: TWinControl); override;\r\n procedure Paint; override;\r\n procedure MouseEnter(Control: TControl); override;\r\n procedure MouseLeave(Control: TControl); override;\r\n procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;\r\n procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;\r\n procedure MouseUp(Button: TMouseButton; Shift: TShiftState;\r\n X, Y: Integer); override;\r\n function WantKey(Key: Integer; Shift: TShiftState): Boolean; override;\r\n procedure VisibleChanged; override;\r\n\r\n property FillColor: TColor read FFillColor write SetFillColor default clNone;\r\n property Offset: Integer read FOffset write SetOffset default 0;\r\n property ButtonBorder: TJvButtonBorder read FButtonBorder write SetButtonBorder default bbDark;\r\n property Centered: Boolean read FCentered write SetCentered;\r\n property Down: Boolean read FStayDown write SetDown default False;\r\n // (rom) renamed\r\n property HighlightFont: TFont read FHighlightFont write SetHighlightFont;\r\n property ImageIndex: TImageIndex read FImageIndex write SetImageIndex default -1;\r\n property ImageSize: TJvImageSize read FImageSize write SetImageSize default isLarge;\r\n property ParentImageSize: Boolean read FParentImageSize write SetParentImageSize default True;\r\n property PopupMenu: TPopupMenu read FPopupMenu write SetPopupMenu;\r\n property LargeImages: TCustomImageList read FLargeImages write SetLargeImages;\r\n property Spacing: Integer read FSpacing write SetSpacing default 4; { border offset from bitmap }\r\n property SmallImages: TCustomImageList read FSmallImages write SetSmallImages;\r\n property Data: Pointer read FData write FData;\r\n property GroupIndex: Integer read FGroupIndex write SetGroupIndex default 0;\r\n property OnEdited: TJvLookOutEditedEvent read FOnEdited write FOnEdited;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n procedure Click; override;\r\n procedure Assign(Source: TPersistent); override;\r\n procedure EditCaption;\r\n end;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvLookOutButton = class(TJvCustomLookOutButton)\r\n public\r\n property Data;\r\n published\r\n property Action;\r\n property Align;\r\n property Anchors;\r\n property ButtonBorder;\r\n property Caption;\r\n property Constraints;\r\n property Down;\r\n property DragCursor;\r\n property DragMode;\r\n property Enabled;\r\n property Font;\r\n property GroupIndex;\r\n property Height default 60;\r\n property HighlightFont;\r\n property ImageIndex;\r\n property ImageSize;\r\n property LargeImages;\r\n property Left;\r\n property ParentFont;\r\n property ParentImageSize;\r\n property ParentShowHint;\r\n property PopupMenu;\r\n property ShowHint;\r\n property SmallImages;\r\n property Spacing;\r\n property Top;\r\n property Visible;\r\n property Width default 60;\r\n property OnClick;\r\n property OnDragDrop;\r\n property OnDragOver;\r\n property OnEdited;\r\n property OnEndDrag;\r\n property OnMouseDown;\r\n property OnMouseEnter;\r\n property OnMouseLeave;\r\n property OnMouseMove;\r\n property OnMouseUp;\r\n property OnStartDrag;\r\n end;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvExpressButton = class(TJvCustomLookOutButton)\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n property Data;\r\n published\r\n property Action;\r\n property Align;\r\n property Anchors;\r\n property ButtonBorder default bbLight;\r\n property Caption;\r\n property Constraints;\r\n property Down;\r\n property DragCursor;\r\n property DragMode;\r\n property Enabled;\r\n property FillColor default clBtnFace;\r\n property Font;\r\n property GroupIndex;\r\n property Height default 60;\r\n property HighlightFont;\r\n property ImageIndex;\r\n property ImageSize;\r\n property LargeImages;\r\n property Left;\r\n property Offset default 1;\r\n property ParentFont default False;\r\n property ParentImageSize;\r\n property ParentShowHint;\r\n property PopupMenu;\r\n property ShowHint;\r\n property SmallImages;\r\n property Spacing;\r\n property Top;\r\n property Visible;\r\n property Width default 60;\r\n property OnClick;\r\n property OnDragDrop;\r\n property OnDragOver;\r\n property OnEdited;\r\n property OnEndDrag;\r\n property OnMouseDown;\r\n property OnMouseEnter;\r\n property OnMouseLeave;\r\n property OnMouseMove;\r\n property OnMouseUp;\r\n property OnStartDrag;\r\n end;\r\n\r\n TJvLookOut = class;\r\n TJvLookOutPage = class(TJvCustomControl)\r\n private\r\n FEdit: TEdit;\r\n FInScroll: Boolean;\r\n FAutoRepeat: Boolean;\r\n FAutoCenter: Boolean;\r\n FParentImageSize: Boolean;\r\n FDown: Boolean;\r\n FShowPressed: Boolean;\r\n FMargin: Integer;\r\n FTopControl: Integer;\r\n FPopUpMenu: TPopupMenu;\r\n FOnClick: TNotifyEvent;\r\n FDownArrow: TJvDwnArrowBtn;\r\n FScrolling: Integer;\r\n FUpArrow: TJvUpArrowBtn;\r\n FBitmap: TBitmap;\r\n FImageSize: TJvImageSize;\r\n FManager: TJvLookOut;\r\n FOnCollapse: TNotifyEvent;\r\n FHighlightFont: TFont;\r\n FButtons: TList;\r\n FActiveButton: TJvCustomLookOutButton;\r\n FOnEdited: TJvLookOutEditedEvent;\r\n procedure SetActiveButton(Value: TJvCustomLookOutButton);\r\n procedure EditMouseDown(Sender: TObject; Button: TMouseButton;\r\n Shift: TShiftState; X, Y: Integer);\r\n procedure EditKeyDown(Sender: TObject; var Key: Char);\r\n procedure SetAutoRepeat(Value: Boolean);\r\n procedure SetHighlightFont(Value: TFont);\r\n procedure SetImageSize(Value: TJvImageSize);\r\n procedure SetParentImageSize(Value: Boolean);\r\n procedure SetBitmap(Value: TBitmap);\r\n procedure SetMargin(Value: Integer);\r\n procedure SetButton(Index: Integer; Value: TJvCustomLookOutButton);\r\n function GetButton(Index: Integer): TJvCustomLookOutButton;\r\n function GetButtonCount: Integer;\r\n procedure SetAutoCenter(Value: Boolean);\r\n function IsVisible(Control: TControl): Boolean;\r\n procedure CMParentImageSizeChanged(var Msg: TMessage); message CM_IMAGESIZECHANGED;\r\n procedure CMTextChanged(var Msg:TMessage); message CM_TEXTCHANGED;\r\n procedure TileBitmap;\r\n protected\r\n function WantKey(Key: Integer; Shift: TShiftState): Boolean; override;\r\n procedure MouseLeave(Control: TControl); override;\r\n procedure EnabledChanged; override;\r\n procedure DoOnEdited(var Caption: string); virtual;\r\n procedure UpArrowClick(Sender: TObject); virtual;\r\n procedure DownArrowClick(Sender: TObject); virtual;\r\n procedure DrawTopButton; virtual;\r\n procedure CalcArrows; virtual;\r\n procedure ScrollChildren(Start: Word); virtual;\r\n procedure AlignControls(Control: TControl; var Rect: TRect); override;\r\n procedure SetParent( AParent: TWinControl); override;\r\n procedure CreateWnd; override;\r\n procedure SmoothScroll(AControl: TControl; NewTop, AInterval: Integer; Smooth: Boolean); virtual;\r\n procedure Notification(AComponent: TComponent; Operation: TOperation); override;\r\n procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;\r\n procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;\r\n procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;\r\n procedure Paint; override;\r\n property AutoCenter: Boolean read FAutoCenter write SetAutoCenter;\r\n public\r\n procedure Click; override;\r\n procedure DownArrow;\r\n procedure UpArrow;\r\n function AddButton: TJvCustomLookOutButton;\r\n function InsertButton(Index: integer): TJvCustomLookOutButton;\r\n procedure ExchangeButtons(Button1, Button2: TJvCustomLookOutButton); virtual;\r\n procedure MoveButton(Button: TJvCustomLookOutButton; NewIndex:integer);virtual;\r\n procedure EditCaption; virtual;\r\n procedure DisableAdjust;\r\n procedure EnableAdjust;\r\n\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n property Buttons[Index: Integer]: TJvCustomLookOutButton read GetButton write SetButton;\r\n property ButtonCount: Integer read GetButtonCount;\r\n property ActiveButton: TJvCustomLookOutButton read FActiveButton write SetActiveButton;\r\n published\r\n property Align;\r\n property AutoRepeat: Boolean read FAutoRepeat write SetAutoRepeat default False;\r\n property Bitmap: TBitmap read FBitmap write SetBitmap;\r\n property ImageSize: TJvImageSize read FImageSize write SetImageSize default isLarge;\r\n property HighlightFont: TFont read FHighlightFont write SetHighlightFont;\r\n property ParentImageSize: Boolean read FParentImageSize write SetParentImageSize default True;\r\n property ShowPressed: Boolean read FShowPressed write FShowPressed default False;\r\n property Caption;\r\n property Color;\r\n property DragCursor;\r\n property DragMode;\r\n property ShowHint;\r\n property Visible;\r\n property Enabled;\r\n property Font;\r\n property ParentFont;\r\n property ParentShowHint;\r\n property PopupMenu: TPopupMenu read FPopUpMenu write FPopUpMenu;\r\n property Left;\r\n property Top;\r\n property Width;\r\n property Height;\r\n property Cursor;\r\n property Hint;\r\n property Margin: Integer read FMargin write SetMargin default 0;\r\n property OnEdited: TJvLookOutEditedEvent read FOnEdited write FOnEdited;\r\n property OnClick: TNotifyEvent read FOnClick write FOnClick;\r\n property OnMouseDown;\r\n property OnMouseMove;\r\n property OnMouseUp;\r\n property OnDragDrop;\r\n property OnDragOver;\r\n property OnEndDrag;\r\n property OnStartDrag;\r\n end;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvLookOut = class(TJvCustomControl)\r\n private\r\n FAutoSize: Boolean;\r\n FSmooth: Boolean;\r\n FBorderStyle: TBorderStyle;\r\n FOnCollapse: TNotifyEvent;\r\n FOnClick: TNotifyEvent;\r\n FActivePage: TJvLookOutPage;\r\n FCurrentPage: TJvLookOutPage;\r\n FPages: TList;\r\n FImageSize: TJvImageSize;\r\n FFlatButtons: Boolean;\r\n procedure SetImageSize(Value: TJvImageSize);\r\n procedure SetBorderStyle(Value: TBorderStyle);\r\n procedure UpdateControls;\r\n procedure DoCollapse(Sender: TObject);\r\n procedure SetActiveOutlook(Value: TJvLookOutPage);\r\n function GetActiveOutlook: TJvLookOutPage;\r\n function GetPageCount: Integer;\r\n function GetPage(Index: Integer): TJvLookOutPage;\r\n procedure SetPage(Index: Integer; Value: TJvLookOutPage);\r\n procedure SetFlatButtons(Value: Boolean);\r\n procedure WMNCCalcSize(var Msg: TWMNCCalcSize); message WM_NCCALCSIZE;\r\n procedure WMNCPaint(var Msg: TMessage); message WM_NCPAINT;\r\n protected\r\n procedure SetAutoSize(Value: Boolean); override;\r\n procedure SmoothScroll(AControl: TControl; NewTop, AInterval: Integer; Smooth: Boolean); virtual;\r\n procedure Paint; override;\r\n procedure Notification(AComponent: TComponent; Operation: TOperation); override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n function AddPage: TJvLookOutPage;\r\n property Pages[Index: Integer]: TJvLookOutPage read GetPage write SetPage;\r\n property PageCount: Integer read GetPageCount;\r\n published\r\n property ActivePage: TJvLookOutPage read GetActiveOutlook write SetActiveOutlook;\r\n property Align;\r\n property Anchors;\r\n property Constraints;\r\n property AutoSize: Boolean read FAutoSize write SetAutoSize default False;\r\n property BorderStyle: TBorderStyle read FBorderStyle write SetBorderStyle default bsSingle;\r\n property Color default clBtnShadow;\r\n property FlatButtons: Boolean read FFlatButtons write SetFlatButtons default False;\r\n property DragCursor;\r\n property DragMode;\r\n property ImageSize: TJvImageSize read FImageSize write SetImageSize default isLarge;\r\n property ShowHint;\r\n property Smooth: Boolean read FSmooth write FSmooth default False;\r\n property Visible;\r\n property Enabled;\r\n property Left;\r\n property Top;\r\n property Width default 92;\r\n property Height default 300;\r\n property Cursor;\r\n property Hint;\r\n property OnClick: TNotifyEvent read FOnClick write FOnClick;\r\n property OnDragDrop;\r\n property OnDragOver;\r\n property OnEndDrag;\r\n property OnStartDrag;\r\n end;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvExpress = class(TJvLookOutPage, IJvDenySubClassing)\r\n private\r\n FBorderStyle: TBorderStyle;\r\n FButtonHeight: Integer;\r\n procedure SetButtonHeight(Value: Integer);\r\n protected\r\n procedure CalcArrows; override;\r\n procedure ScrollChildren(Start: Word); override;\r\n procedure DrawTopButton; override;\r\n procedure Paint; override;\r\n procedure CreateWnd; override;\r\n procedure AlignControls(Control: TControl; var Rect: TRect); override;\r\n procedure WMNCCalcSize(var Msg: TWMNCCalcSize); message WM_NCCALCSIZE;\r\n procedure WMNCPaint(var Msg: TMessage); message WM_NCPAINT;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n function AddButton: TJvExpressButton;\r\n published\r\n property Anchors;\r\n property Constraints;\r\n property ButtonHeight: Integer read FButtonHeight write SetButtonHeight default 60;\r\n property ImageSize default isLarge;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvLookOut.pas $';\r\n Revision: '$Revision: 13415 $';\r\n Date: '$Date: 2012-09-10 11:51:54 +0200 (lun. 10 sept. 2012) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n {$IFDEF COMPILER10_UP}\r\n Types,\r\n {$ENDIF COMPILER10_UP}\r\n ActnList, JvJVCLUtils;\r\n\r\nconst\r\n cSpeed = 20;\r\n cHeight = 19;\r\n cInitTime = 400;\r\n cTimeDelay = 120;\r\n\r\n { utility }\r\n\r\n { this creates a correctly masked bitmap - for use with D2 TImageList }\r\n {\r\n procedure CreateMaskedImageList(ImageList: TImageList);\r\n var\r\n Bmp: TBitmap;\r\n I: Integer;\r\n begin\r\n Bmp := TBitmap.Create;\r\n Bmp.Width := ImageList.Width;\r\n Bmp.Height := ImageList.Height;\r\n try\r\n for I := 0 to ImageList.Count - 1 do\r\n begin\r\n ImageList.GetBitmap(I,Bmp);\r\n ImageList.ReplaceMasked(I,Bmp,Bmp.TransparentColor);\r\n end;\r\n finally\r\n Bmp.Free;\r\n end;\r\n end;\r\n }\r\n\r\n { returns number of visible children }\r\n {\r\n function NoOfVisibles(Control: TWinControl): Integer;\r\n var\r\n R: TRect;\r\n I: Integer;\r\n begin\r\n R := Control.ClientRect;\r\n Result := 0;\r\n if Control = nil then\r\n Exit;\r\n for I := 0 to Control.ControlCount - 1 do\r\n if (PtInRect(R,Point(R.Left + 1,Control.Controls[I].Top)) and\r\n PtInRect(R,Point(R.Left + 1,Control.Controls[I].Top + Control.Controls[I].Height))) then\r\n Inc(Result);\r\n end;\r\n }\r\n\r\n {\r\n function IMax(Val1, Val2: Integer): Integer;\r\n begin\r\n Result := Val1;\r\n if Val2 > Val1 then\r\n Result := Val2;\r\n end;\r\n\r\n function IMin(Val1, Val2: Integer): Integer;\r\n begin\r\n Result := Val1;\r\n if Val2 < Val1 then\r\n Result := Val2;\r\n end;\r\n }\r\n\r\n { returns Atleast if Value < AtLeast, Val1 otherwise }\r\n {\r\n function IAtLeast(Value, AtLeast: Integer): Integer;\r\n begin\r\n Result := Value;\r\n if Value < AtLeast then\r\n Result := AtLeast;\r\n end;\r\n }\r\n\r\n//=== { TJvLookOutEdit } =====================================================\r\n\r\ntype\r\n TJvLookOutEdit = class(TEdit)\r\n private\r\n procedure DoExit; override;\r\n end;\r\n\r\nprocedure TJvLookOutEdit.DoExit;\r\nbegin\r\n Visible := False;\r\n // (ahuser) What is with OnExit() ?\r\nend;\r\n\r\n//=== { TJvLookOutButtonActionLink } =========================================\r\n\r\ntype\r\n TJvLookOutButtonActionLink = class(TControlActionLink)\r\n protected\r\n FClient: TJvCustomLookOutButton;\r\n procedure AssignClient(AClient: TObject); override;\r\n function IsCheckedLinked: Boolean; override;\r\n procedure SetChecked(Value: Boolean); override;\r\n function IsImageIndexLinked: Boolean; override;\r\n procedure SetImageIndex(Value: Integer); override;\r\n function IsGroupIndexLinked: Boolean; override;\r\n procedure SetGroupIndex(Value: Integer); override;\r\n end;\r\n\r\n TJvLookOutButtonActionLinkClass = class of TJvLookOutButtonActionLink;\r\n\r\nprocedure TJvLookOutButtonActionLink.AssignClient(AClient: TObject);\r\nbegin\r\n inherited AssignClient(AClient);\r\n FClient := AClient as TJvCustomLookOutButton;\r\nend;\r\n\r\nfunction TJvLookOutButtonActionLink.IsCheckedLinked: Boolean;\r\nbegin\r\n Result := inherited IsCheckedLinked and\r\n (FClient.Down = (Action as TCustomAction).Checked);\r\nend;\r\n\r\nprocedure TJvLookOutButtonActionLink.SetChecked(Value: Boolean);\r\nbegin\r\n if IsCheckedLinked then\r\n FClient.Down := Value;\r\nend;\r\n\r\nfunction TJvLookOutButtonActionLink.IsImageIndexLinked: Boolean;\r\nbegin\r\n Result := inherited IsImageIndexLinked and\r\n (FClient.ImageIndex = (Action as TCustomAction).ImageIndex);\r\nend;\r\n\r\nprocedure TJvLookOutButtonActionLink.SetImageIndex(Value: Integer);\r\nbegin\r\n if IsImageIndexLinked then\r\n FClient.ImageIndex := Value;\r\n\r\nend;\r\n\r\nfunction TJvLookOutButtonActionLink.IsGroupIndexLinked: Boolean;\r\nbegin\r\n Result := inherited IsGroupIndexLinked and\r\n (FClient.GroupIndex = (Action as TCustomAction).GroupIndex);\r\nend;\r\n\r\nprocedure TJvLookOutButtonActionLink.SetGroupIndex(Value: Integer);\r\nbegin\r\n if IsGroupIndexLinked then\r\n FClient.GroupIndex := Value;\r\nend;\r\n\r\n//=== { TJvUpArrowBtn } ======================================================\r\n\r\nconstructor TJvUpArrowBtn.Create(AOwner: TComponent);\r\nvar\r\n FSize: Word;\r\nbegin\r\n inherited Create(AOwner);\r\n ControlStyle := [csCaptureMouse, csClickEvents, csSetCaption];\r\n ParentColor := True;\r\n FDown := False;\r\n FAutoRepeat := False;\r\n FFlat := False;\r\n FSize := GetSystemMetrics(SM_CXVSCROLL);\r\n SetBounds(0, 0, FSize, FSize);\r\nend;\r\n\r\nprocedure TJvUpArrowBtn.SetFlat(Value: Boolean);\r\nbegin\r\n if FFlat <> Value then\r\n begin\r\n FFlat := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvUpArrowBtn.MouseEnter(Control: TControl);\r\nbegin\r\n if csDesigning in ComponentState then\r\n Exit;\r\n if not MouseOver then\r\n begin\r\n inherited MouseEnter(Control);\r\n if FFlat {$IFDEF JVCLThemesEnabled} or ThemeServices.{$IFDEF RTL230_UP}Enabled{$ELSE}ThemesEnabled{$ENDIF RTL230_UP} {$ENDIF} then\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvUpArrowBtn.MouseLeave(Control: TControl);\r\nbegin\r\n if MouseOver then\r\n begin\r\n inherited MouseLeave(Control);\r\n // FDown := False;\r\n if FFlat {$IFDEF JVCLThemesEnabled} or ThemeServices.{$IFDEF RTL230_UP}Enabled{$ELSE}ThemesEnabled{$ENDIF RTL230_UP} {$ENDIF} then\r\n Invalidate;\r\n end;\r\nend;\r\n\r\n\r\nprocedure TJvUpArrowBtn.CMDesignHitTest(var Msg: TCMDesignHitTest);\r\nbegin\r\n Msg.Result := 1;\r\nend;\r\n\r\n\r\nprocedure TJvUpArrowBtn.Paint;\r\nvar\r\n Flags: Integer;\r\n R: TRect;\r\nbegin\r\n // if not Visible then Exit;\r\n R := GetClientRect;\r\n\r\n if FDown then\r\n Flags := DFCS_PUSHED\r\n else\r\n Flags := 0;\r\n if not Enabled then\r\n Flags := Flags or DFCS_INACTIVE;\r\n\r\n if FFlat and not MouseOver then\r\n begin\r\n Flags := Flags or DFCS_FLAT;\r\n OffsetRect(R, 0, -2);\r\n end;\r\n\r\n if FFlat then\r\n InflateRect(R, 1, 1);\r\n if MouseOver then\r\n Flags := Flags or DFCS_HOT;\r\n Canvas.Brush.Color := Color;\r\n Canvas.Pen.Color := Color;\r\n DrawThemedFrameControl(Canvas.Handle, R, DFC_SCROLL, DFCS_SCROLLUP or Flags);\r\n\r\n if FFlat and MouseOver then\r\n begin\r\n R := GetClientRect;\r\n\r\n if FDown then\r\n Frame3D(Canvas, R, clBlack, clWhite, 1)\r\n else\r\n Frame3D(Canvas, R, clWhite, clBlack, 1);\r\n end;\r\nend;\r\n\r\nprocedure TJvUpArrowBtn.Click;\r\nbegin\r\n if Enabled then\r\n begin\r\n inherited Click;\r\n ReleaseCapture;\r\n end;\r\nend;\r\n\r\nprocedure TJvUpArrowBtn.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);\r\nbegin\r\n FDown := True;\r\n inherited MouseDown(Button, Shift, X, Y);\r\n if Parent is TJvLookOutPage then\r\n FAutoRepeat := TJvLookOutPage(Parent).AutoRepeat;\r\n if FAutoRepeat then\r\n begin\r\n if not Assigned(FTimer) then\r\n FTimer := TTimer.Create(Self);\r\n with FTimer do\r\n begin\r\n OnTimer := OnTime;\r\n Interval := cInitTime;\r\n Enabled := True;\r\n end;\r\n end;\r\n Repaint;\r\nend;\r\n\r\nprocedure TJvUpArrowBtn.MouseUp(Button: TMouseButton; Shift: TShiftState;\r\n X, Y: Integer);\r\nbegin\r\n inherited MouseUp(Button, Shift, X, Y);\r\n if Assigned(FTimer) then\r\n begin\r\n FTimer.Free;\r\n FTimer := nil;\r\n end;\r\n FDown := False;\r\n (Parent as TJvLookOutPage).UpArrowClick(Self);\r\nend;\r\n\r\nprocedure TJvUpArrowBtn.OnTime(Sender: TObject);\r\nvar\r\n R: TRect;\r\nbegin\r\n FTimer.Interval := cTimeDelay;\r\n if FDown and MouseCapture and Visible then\r\n begin\r\n (Parent as TJvLookOutPage).UpArrowClick(Self);\r\n R := Parent.ClientRect;\r\n R := Rect(R.Left, R.Top + cHeight, R.Right, R.Bottom);\r\n Windows.InvalidateRect(Parent.Handle, @R, False);\r\n Parent.Update;\r\n end;\r\nend;\r\n\r\n//=== { TJvDwnArrowBtn } =====================================================\r\n\r\nconstructor TJvDwnArrowBtn.Create(AOwner: TComponent);\r\nvar\r\n FSize: Word;\r\nbegin\r\n inherited Create(AOwner);\r\n ControlStyle := [csCaptureMouse, csClickEvents, csSetCaption];\r\n ParentColor := True;\r\n FDown := False;\r\n FFlat := False;\r\n FSize := GetSystemMetrics(SM_CXVSCROLL);\r\n SetBounds(0, 0, FSize, FSize);\r\nend;\r\n\r\nprocedure TJvDwnArrowBtn.Paint;\r\nvar\r\n Flags: Integer;\r\n R: TRect;\r\nbegin\r\n // if not Visible then Exit;\r\n R := GetClientRect;\r\n if FDown then\r\n Flags := DFCS_PUSHED\r\n else\r\n Flags := 0;\r\n if not Enabled then\r\n Flags := Flags or DFCS_INACTIVE;\r\n if FFlat and not MouseOver then\r\n begin\r\n Flags := Flags or DFCS_FLAT;\r\n OffsetRect(R, 0, 2);\r\n end;\r\n\r\n if FFlat then\r\n InflateRect(R, 1, 1);\r\n if MouseOver then\r\n Flags := Flags or DFCS_HOT;\r\n Canvas.Brush.Color := Color;\r\n Canvas.Pen.Color := Color;\r\n DrawThemedFrameControl(Canvas.Handle, R, DFC_SCROLL, DFCS_SCROLLDOWN or Flags);\r\n\r\n if FFlat and MouseOver then\r\n begin\r\n R := GetClientRect;\r\n if FDown then\r\n Frame3D(Canvas, R, clBlack, clBtnShadow, 1)\r\n else\r\n Frame3D(Canvas, R, clWhite, clBlack, 1);\r\n end;\r\nend;\r\n\r\nprocedure TJvDwnArrowBtn.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);\r\nbegin\r\n FDown := True;\r\n // inherited MouseDown(Button, Shift, X, Y);\r\n if Assigned(OnMouseDown) then\r\n OnMouseDown(Self, Button, Shift, X, Y);\r\n if Parent is TJvLookOutPage then\r\n FAutoRepeat := TJvLookOutPage(Parent).AutoRepeat;\r\n if FAutoRepeat then\r\n begin\r\n if not Assigned(FTimer) then\r\n FTimer := TTimer.Create(Self);\r\n with FTimer do\r\n begin\r\n OnTimer := OnTime;\r\n Interval := cInitTime;\r\n Enabled := True;\r\n end;\r\n end;\r\n Repaint;\r\nend;\r\n\r\nprocedure TJvDwnArrowBtn.MouseUp(Button: TMouseButton; Shift: TShiftState;\r\n X, Y: Integer);\r\nbegin\r\n // inherited MouseUp(Button, Shift, X, Y);\r\n if Assigned(OnMouseUp) then\r\n OnMouseUp(Self, Button, Shift, X, Y);\r\n FDown := False;\r\n (Parent as TJvLookOutPage).DownArrowClick(Self);\r\n // Parent.ScrollBy(0,-50);\r\n if Assigned(FTimer) then\r\n begin\r\n FTimer.Free;\r\n FTimer := nil;\r\n end;\r\n Repaint;\r\nend;\r\n\r\nprocedure TJvDwnArrowBtn.OnTime(Sender: TObject);\r\nvar\r\n R: TRect;\r\nbegin\r\n FTimer.Interval := cTimeDelay;\r\n if FDown and MouseCapture then\r\n begin\r\n (Parent as TJvLookOutPage).DownArrowClick(Self);\r\n // Parent.ScrollBy(0,-50);\r\n R := Parent.ClientRect;\r\n R := Rect(R.Left, R.Top + cHeight, R.Right, R.Bottom);\r\n Windows.InvalidateRect(Parent.Handle, @R, False);\r\n Parent.Update;\r\n if not Visible then\r\n FDown := False;\r\n end;\r\nend;\r\n\r\n//=== { TJvCustomLookOutButton } =============================================\r\n\r\nconstructor TJvCustomLookOutButton.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n ControlStyle := [csCaptureMouse, csClickEvents];\r\n FButtonBorder := bbDark;\r\n FParentImageSize := True;\r\n FImageSize := isLarge;\r\n FFillColor := clNone;\r\n FSpacing := 4;\r\n FOffset := 0;\r\n FStayDown := False;\r\n FHighlightFont := TFont.Create;\r\n FHighlightFont.Assign(Font);\r\n Width := 60;\r\n Height := 60;\r\n FImageIndex := -1;\r\n FLargeImageChangeLink := TChangeLink.Create;\r\n FSmallImageChangeLink := TChangeLink.Create;\r\n FLargeImageChangeLink.OnChange := ImageListChange;\r\n FSmallImageChangeLink.OnChange := ImageListChange;\r\nend;\r\n\r\ndestructor TJvCustomLookOutButton.Destroy;\r\nbegin\r\n FEdit.Free;\r\n FLargeImageChangeLink.Free;\r\n FSmallImageChangeLink.Free;\r\n FHighlightFont.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvCustomLookOutButton.Click;\r\nbegin\r\n inherited Click;\r\nend;\r\n\r\nprocedure TJvCustomLookOutButton.EditCaption;\r\nbegin\r\n if not Assigned(FEdit) then\r\n begin\r\n FEdit := TJvLookOutEdit.Create(nil);\r\n FEdit.Parent := Self.Parent;\r\n FEdit.Visible := False;\r\n end;\r\n\r\n FEdit.SetBounds(Left + FTextRect.Left, Top + FTextRect.Top,\r\n Width, FTextRect.Bottom - FTextRect.Top);\r\n with FEdit do\r\n begin\r\n Text := Caption;\r\n BorderStyle := bsNone;\r\n AutoSelect := True;\r\n OnKeyPress := EditKeyDown;\r\n OnMouseDown := EditMouseDown;\r\n if not Visible then\r\n Show;\r\n SetFocus;\r\n SetCapture(FEdit.Handle);\r\n SelStart := 0;\r\n SelLength := Length(Caption);\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomLookOutButton.DoOnEdited(var Caption: string);\r\nbegin\r\n if Assigned(FOnEdited) then\r\n FOnEdited(Self, Caption);\r\nend;\r\n\r\nprocedure TJvCustomLookOutButton.EditKeyDown(Sender: TObject; var Key: Char);\r\nvar\r\n ACaption: string;\r\n Modify: Boolean;\r\nbegin\r\n Modify := False;\r\n if Sender = FEdit then\r\n case Key of\r\n Cr:\r\n begin\r\n ACaption := FEdit.Text;\r\n DoOnEdited(ACaption);\r\n FEdit.Text := ACaption;\r\n Key := #0;\r\n Modify := True;\r\n if FEdit.Handle = GetCapture then\r\n ReleaseCapture;\r\n FEdit.Hide;\r\n FEdit.Free;\r\n FEdit := nil;\r\n Screen.Cursor := crDefault;\r\n end;\r\n Esc:\r\n begin\r\n Key := #0;\r\n if FEdit.Handle = GetCapture then\r\n ReleaseCapture;\r\n FEdit.Hide;\r\n FEdit.Free;\r\n FEdit := nil;\r\n Screen.Cursor := crDefault;\r\n end;\r\n end;\r\n if Modify then\r\n Caption := ACaption;\r\nend;\r\n\r\nprocedure TJvCustomLookOutButton.EditMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState;\r\n X, Y: Integer);\r\nbegin\r\n if Assigned(FEdit) then\r\n begin\r\n if not PtInRect(FEdit.ClientRect, Point(X, Y)) or ((Button = mbRight) and FEdit.Visible) then\r\n begin\r\n if FEdit.Handle = GetCapture then\r\n ReleaseCapture;\r\n Screen.Cursor := crDefault;\r\n FEdit.Hide;\r\n FEdit.Free;\r\n FEdit := nil;\r\n end\r\n else\r\n begin\r\n ReleaseCapture;\r\n Screen.Cursor := crIBeam;\r\n SetCapture(FEdit.Handle);\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomLookOutButton.Assign(Source: TPersistent);\r\nbegin\r\n if Source is TJvCustomLookOutButton then\r\n begin\r\n Offset := TJvCustomLookOutButton(Source).Offset;\r\n Height := TJvCustomLookOutButton(Source).Height;\r\n Width := TJvCustomLookOutButton(Source).Width;\r\n ButtonBorder := TJvCustomLookOutButton(Source).ButtonBorder;\r\n Caption := TJvCustomLookOutButton(Source).Caption;\r\n Centered := TJvCustomLookOutButton(Source).Centered;\r\n Down := TJvCustomLookOutButton(Source).Down;\r\n Font := TJvCustomLookOutButton(Source).Font;\r\n HighlightFont := TJvCustomLookOutButton(Source).HighlightFont;\r\n ParentImageSize := TJvCustomLookOutButton(Source).ParentImageSize;\r\n ImageSize := TJvCustomLookOutButton(Source).ImageSize;\r\n ImageIndex := TJvCustomLookOutButton(Source).ImageIndex;\r\n LargeImages := TJvCustomLookOutButton(Source).LargeImages;\r\n SmallImages := TJvCustomLookOutButton(Source).SmallImages;\r\n Spacing := TJvCustomLookOutButton(Source).Spacing;\r\n end\r\n else\r\n inherited Assign(Source);\r\nend;\r\n\r\nfunction TJvCustomLookOutButton.WantKey(Key: Integer; Shift: TShiftState): Boolean;\r\nbegin\r\n Result := IsAccel(Key, Caption) and Enabled and\r\n Visible and ParentVisible and (ssAlt in Shift);\r\n if Result then\r\n Click\r\n else\r\n Result := inherited WantKey(Key, Shift);\r\nend;\r\n\r\nfunction TJvCustomLookOutButton.ParentVisible: Boolean;\r\nbegin\r\n Result := False;\r\n if Parent = nil then\r\n Exit;\r\n if (Parent is TJvLookOutPage) and (Parent.Parent is TJvLookOut) then\r\n Result := TJvLookOutPage(Parent) = TJvLookOut(Parent.Parent).ActivePage\r\n else\r\n Result := Parent.Visible;\r\nend;\r\n\r\nprocedure TJvCustomLookOutButton.SetGroupIndex(Value: Integer);\r\nbegin\r\n if FGroupIndex <> Value then\r\n begin\r\n FGroupIndex := Value;\r\n UpdateExclusive;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomLookOutButton.UpdateExclusive;\r\nvar\r\n Msg: TCMButtonPressed;\r\nbegin\r\n if (FGroupIndex <> 0) and (Parent <> nil) then\r\n begin\r\n Msg.Msg := CM_JVBUTTONPRESSED;\r\n Msg.Index := FGroupIndex;\r\n Msg.Control := Self;\r\n Msg.Result := 0;\r\n Parent.Broadcast(Msg);\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomLookOutButton.SetCentered(Value: Boolean);\r\nbegin\r\n if FCentered <> Value then\r\n begin\r\n FCentered := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomLookOutButton.SetDown(Value: Boolean);\r\nbegin\r\n if FStayDown <> Value then\r\n begin\r\n FStayDown := Value;\r\n if FStayDown then\r\n begin\r\n MouseOver := True;\r\n FDown := True;\r\n end\r\n else\r\n FDown := False;\r\n if FStayDown then\r\n UpdateExclusive;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomLookOutButton.SetOffset(Value: Integer);\r\nbegin\r\n if FOffset <> Value then\r\n FOffset := Value;\r\nend;\r\n\r\nprocedure TJvCustomLookOutButton.SetButtonBorder(Value: TJvButtonBorder);\r\nbegin\r\n if FButtonBorder <> Value then\r\n begin\r\n FButtonBorder := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomLookOutButton.SetSmallImages(const Value: TCustomImageList);\r\nbegin\r\n ReplaceImageListReference(Self, Value, FSmallImages, FSmallImageChangeLink);\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvCustomLookOutButton.SetLargeImages(const Value: TCustomImageList);\r\nbegin\r\n ReplaceImageListReference(Self, Value, FLargeImages, FLargeImageChangeLink);\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvCustomLookOutButton.SetImageIndex(Value: TImageIndex);\r\nbegin\r\n if FImageIndex <> Value then\r\n begin\r\n FImageIndex := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomLookOutButton.SetImageSize(Value: TJvImageSize);\r\nbegin\r\n if FImageSize <> Value then\r\n begin\r\n FImageSize := Value;\r\n if csDesigning in ComponentState then\r\n SetParentImageSize(False);\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomLookOutButton.SetFillColor(Value: TColor);\r\nbegin\r\n if FFillColor <> Value then\r\n begin\r\n FFillColor := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomLookOutButton.SetHighlightFont(Value: TFont);\r\nbegin\r\n FHighlightFont.Assign(Value);\r\n if FHighlightFont <> Font then\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvCustomLookOutButton.SetSpacing(Value: Integer);\r\nbegin\r\n if FSpacing <> Value then\r\n begin\r\n FSpacing := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomLookOutButton.SetParentImageSize(Value: Boolean);\r\nbegin\r\n FParentImageSize := Value;\r\n if FParentImageSize and (Parent is TJvLookOutPage) then\r\n SetImageSize(TJvLookOutPage(Parent).ImageSize);\r\nend;\r\n\r\nprocedure TJvCustomLookOutButton.Paint;\r\nvar\r\n R: TRect;\r\n Flags, H: Integer;\r\nbegin\r\n R := GetClientRect;\r\n\r\n with Canvas do\r\n begin\r\n if csDesigning in ComponentState then\r\n begin\r\n Brush.Color := clBlack;\r\n FrameRect( R);\r\n end;\r\n\r\n if (FImageSize = isSmall) and Assigned(FSmallImages) then\r\n begin\r\n FImageRect.Left := FSpacing;\r\n FImageRect.Right := FImageRect.Left + FSmallImages.Width;\r\n FImageRect.Top := (Height - FSmallImages.Height) div 2;\r\n FImageRect.Bottom := FImageRect.Top + FSmallImages.Height;\r\n end\r\n else\r\n if Assigned(FLargeImages) then\r\n begin\r\n FImageRect.Left := (Width - FLargeImages.Width) div 2;\r\n FImageRect.Right := FImageRect.Left + FLargeImages.Width;\r\n FImageRect.Top := FSpacing;\r\n FImageRect.Bottom := FImageRect.Top + FLargeImages.Height;\r\n end;\r\n\r\n PaintFrame;\r\n\r\n Flags := DT_END_ELLIPSIS or DT_EDITCONTROL ;\r\n\r\n if (FImageSize = isSmall) and Assigned(FSmallImages) then\r\n begin\r\n DrawSmallImages;\r\n Flags := Flags or DT_VCENTER or DT_SINGLELINE;\r\n // W := FSmallImages.Width;\r\n end\r\n else\r\n if (FImageSize = isLarge) and Assigned(FLargeImages) then\r\n begin\r\n DrawLargeImages;\r\n // W := FLargeImages.Width;\r\n Flags := Flags or DT_WORDBREAK or DT_CENTER;\r\n end;\r\n end;\r\n\r\n { draw text }\r\n if Length(Caption) > 0 then\r\n begin\r\n if MouseOver then\r\n Canvas.Font := FHighlightFont\r\n else\r\n Canvas.Font := Font;\r\n\r\n // W := FSpacing + W;\r\n SetBkMode(Canvas.Handle, Windows.Transparent);\r\n R := GetClientRect;\r\n if (ImageSize = isLarge) and Assigned(FLargeImages) then\r\n R.Top := R.Top + FLargeImages.Height + (FSpacing * 2)\r\n else\r\n if (ImageSize = isSmall) and Assigned(FSmallImages) then\r\n R.Left := R.Left + FSmallImages.Width + (FSpacing * 3)\r\n else\r\n Flags := DT_END_ELLIPSIS or DT_WORDBREAK or DT_CENTER or DT_VCENTER or DT_EDITCONTROL ;\r\n if FDown then\r\n OffsetRect(R, FOffset, FOffset);\r\n FTextRect := R;\r\n H := DrawText(Canvas, Caption, -1, FTextRect, Flags or DT_CALCRECT);\r\n if ImageSize = isLarge then\r\n begin\r\n FTextRect.Top := R.Top;\r\n FTextRect.Bottom := FTextRect.Top + H;\r\n FTextRect.Right := R.Left + Canvas.TextWidth(Caption);\r\n end\r\n else\r\n begin\r\n FTextRect.Top := (Height - Canvas.TextHeight(Caption)) div 2;\r\n FTextRect.Bottom := FTextRect.Top + Canvas.TextHeight(Caption);\r\n FTextRect.Right := R.Left + Canvas.TextWidth(Caption);\r\n end;\r\n DrawText(Canvas, Caption, -1, R, Flags);\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomLookOutButton.DrawSmallImages;\r\nvar\r\n Icon: TIcon;\r\nbegin\r\n if FDown then\r\n OffsetRect(FImageRect, FOffset, FOffset);\r\n Icon := TIcon.Create;\r\n try\r\n FSmallImages.GetIcon(FImageIndex, Icon);\r\n DrawIconEx(Canvas.Handle, FImageRect.Left, FImageRect.Top, Icon.Handle, 0, 0, 0, 0, DI_NORMAL);\r\n finally\r\n Icon.Free;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomLookOutButton.DrawLargeImages;\r\nvar\r\n Icon: TIcon;\r\nbegin\r\n if FDown then\r\n OffsetRect(FImageRect, FOffset, FOffset);\r\n Icon := TIcon.Create;\r\n try\r\n FLargeImages.GetIcon(FImageIndex, Icon);\r\n DrawIconEx(Canvas.Handle, FImageRect.Left, FImageRect.Top, Icon.Handle, 0, 0, 0, 0, DI_NORMAL);\r\n finally\r\n Icon.Free;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomLookOutButton.PaintFrame;\r\nvar\r\n R: TRect;\r\nbegin\r\n R := GetClientRect;\r\n\r\n if csDesigning in ComponentState then\r\n begin\r\n Canvas.Brush.Color := clBlack;\r\n with Canvas do\r\n FrameRect( R);\r\n Canvas.Brush.Color := Color;\r\n end;\r\n\r\n if not Enabled then\r\n Exit;\r\n if MouseOver or (csDesigning in ComponentState) then\r\n begin\r\n if (csDesigning in ComponentState) and not Visible then\r\n begin\r\n Canvas.Brush.Style := bsBDiagonal;\r\n Windows.FillRect(Canvas.Handle, R, Canvas.Brush.Handle);\r\n Canvas.Brush.Style := bsSolid;\r\n end\r\n else\r\n if FFillColor = clNone then\r\n begin\r\n R := FImageRect;\r\n InflateRect(R, Spacing, Spacing);\r\n end\r\n else\r\n begin { fill it up! }\r\n Canvas.Brush.Color := FFillColor;\r\n Windows.FillRect(Canvas.Handle, R, Canvas.Brush.Handle);\r\n end;\r\n\r\n if FDown then\r\n begin\r\n if FButtonBorder = bbDark then\r\n Frame3D(Canvas, R, cl3DDkShadow, clBtnFace, 1)\r\n else\r\n if FButtonBorder = bbLight then\r\n Frame3D(Canvas, R, clBtnShadow, clBtnHighlight, 1)\r\n else\r\n Frame3D(Canvas, R, cl3DDkShadow, clBtnHighlight, 1)\r\n end\r\n else\r\n case FButtonBorder of\r\n bbDark:\r\n Frame3D(Canvas, R, clBtnFace, cl3DDkShadow, 1);\r\n bbLight:\r\n Frame3D(Canvas, R, clBtnHighlight, clBtnShadow, 1);\r\n else\r\n Frame3D(Canvas, R, clBtnHighlight, cl3DDkShadow, 1);\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomLookOutButton.ImageListChange(Sender: TObject);\r\nbegin\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvCustomLookOutButton.CMParentImageSizeChanged(var Msg: TMessage);\r\nvar\r\n FTmp: Boolean;\r\nbegin\r\n if (Msg.LParam <> LPARAM(Self)) and FParentImageSize then\r\n begin\r\n FTmp := FParentImageSize;\r\n SetImageSize(TJvImageSize(Msg.WParam));\r\n FParentImageSize := FTmp;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomLookOutButton.CMButtonPressed(var Msg: TCMButtonPressed);\r\nvar\r\n Sender: TJvCustomLookOutButton;\r\nbegin\r\n if Msg.Index = FGroupIndex then\r\n begin\r\n Sender := TJvCustomLookOutButton(Msg.Control);\r\n if Sender <> Self then\r\n begin\r\n if Sender.Down and FDown then\r\n begin\r\n FStayDown := False;\r\n FDown := False;\r\n MouseOver := False;\r\n Invalidate;\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomLookOutButton.MouseEnter(Control: TControl);\r\nbegin\r\n if csDesigning in ComponentState then\r\n Exit;\r\n if not MouseOver then\r\n begin\r\n if FFillColor = clNone then\r\n PaintFrame\r\n else\r\n Invalidate;\r\n end;\r\n inherited MouseEnter(Control);\r\nend;\r\n\r\nprocedure TJvCustomLookOutButton.MouseLeave(Control: TControl);\r\nbegin\r\n if MouseOver then\r\n begin\r\n if not FStayDown then\r\n Invalidate;\r\n end;\r\n inherited MouseLeave(Control);\r\nend;\r\n\r\nprocedure TJvCustomLookOutButton.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);\r\nvar\r\n Tmp: TPoint;\r\n Msg: TMsg;\r\nbegin\r\n if Parent is TJvLookOutPage then\r\n TJvLookOutPage(Parent).ActiveButton := Self;\r\n\r\n inherited MouseDown(Button, Shift, X, Y);\r\n if Button = mbRight then\r\n begin\r\n if Assigned(FPopUpMenu) then\r\n begin\r\n { calc where to put menu }\r\n Tmp := ClientToScreen(Point(X, Y));\r\n FPopUpMenu.PopupComponent := Self;\r\n FPopUpMenu.Popup(Tmp.X, Tmp.Y);\r\n { wait 'til menu is Done }\r\n // TODO\r\n while PeekMessage(Msg, 0, WM_MOUSEFIRST, WM_MOUSELAST, PM_REMOVE) do\r\n {nothing};\r\n end;\r\n { release button }\r\n if not FStayDown then\r\n FDown := False;\r\n end\r\n else\r\n if MouseOver and (Button = mbLeft) then\r\n FDown := True\r\n else\r\n if not FStayDown then\r\n FDown := False;\r\n\r\n if FGroupIndex <> 0 then\r\n SetDown(not FStayDown);\r\n if FOffset = 0 then\r\n PaintFrame\r\n else\r\n Invalidate;\r\n // Parent.Update;\r\nend;\r\n\r\nprocedure TJvCustomLookOutButton.MouseMove(Shift: TShiftState; X, Y: Integer);\r\nvar\r\n Msg: TMessage;\r\nbegin\r\n inherited MouseMove(Shift, X, Y);\r\n\r\n if PtInRect(GetClientRect, Point(X, Y)) then { entire button }\r\n begin\r\n if not MouseOver then\r\n begin\r\n MouseOver := True;\r\n { notify others }\r\n Msg.Msg := CM_LEAVEBUTTON;\r\n Msg.WParam := 0;\r\n Msg.LParam := LPARAM(Self);\r\n Msg.Result := 0;\r\n Invalidate;\r\n Parent.Broadcast(Msg);\r\n end;\r\n end\r\n else\r\n if MouseOver then\r\n begin\r\n MouseOver := False;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomLookOutButton.MouseUp(Button: TMouseButton; Shift: TShiftState;\r\n X, Y: Integer);\r\nbegin\r\n inherited MouseUp(Button, Shift, X, Y);\r\n if FDown and not FStayDown then\r\n begin\r\n FDown := False;\r\n if FOffset = 0 then\r\n PaintFrame\r\n else\r\n Invalidate;\r\n // Parent.Update;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomLookOutButton.CMLeaveButton(var Msg: TMessage);\r\nbegin\r\n if (Msg.LParam <> LPARAM(Self)) and MouseOver and not FStayDown then\r\n begin\r\n MouseOver := False;\r\n // FDown := False;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomLookOutButton.CMTextChanged(var Msg: TMessage);\r\nbegin\r\n inherited;\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvCustomLookOutButton.SetParent( AParent: TWinControl);\r\nbegin\r\n if AParent <> Parent then\r\n begin\r\n if (Parent <> nil) and (Parent is TJvLookOutPage) then\r\n TJvLookOutPage(Parent).FButtons.Delete(TJvLookOutPage(Parent).FButtons.IndexOf(Self));\r\n if (AParent <> nil) and (AParent is TJvLookOutPage) then\r\n TJvLookOutPage(AParent).FButtons.Add(Self);\r\n end;\r\n inherited SetParent(AParent);\r\nend;\r\n\r\nprocedure TJvCustomLookOutButton.Notification(AComponent: TComponent; Operation: TOperation);\r\nbegin\r\n inherited Notification(AComponent, Operation);\r\n if Operation = opRemove then\r\n begin\r\n if AComponent = FSmallImages then\r\n FSmallImages := nil;\r\n if AComponent = FLargeImages then\r\n FLargeImages := nil;\r\n if AComponent = FPopUpMenu then\r\n FPopUpMenu := nil;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomLookOutButton.ActionChange(Sender: TObject;\r\n CheckDefaults: Boolean);\r\nbegin\r\n inherited ActionChange(Sender, CheckDefaults);\r\n if Sender is TCustomAction then\r\n with TCustomAction(Sender) do\r\n begin\r\n if not CheckDefaults or (Self.ImageIndex = -1) then\r\n Self.ImageIndex := ImageIndex;\r\n if not CheckDefaults or (Self.GroupIndex = 0) then\r\n Self.GroupIndex := GroupIndex;\r\n if not CheckDefaults or not Self.Down then\r\n Self.Down := Checked;\r\n end;\r\nend;\r\n\r\nfunction TJvCustomLookOutButton.GetActionLinkClass: TControlActionLinkClass;\r\nbegin\r\n Result := TJvLookOutButtonActionLink;\r\nend;\r\n\r\nprocedure TJvCustomLookOutButton.SetPopupMenu(const Value: TPopupMenu);\r\nbegin\r\n ReplaceComponentReference(Self, Value, TComponent(FPopupMenu));\r\nend;\r\n\r\nprocedure TJvCustomLookOutButton.VisibleChanged;\r\nbegin\r\n inherited VisibleChanged;\r\n if not (csCreating in ControlState) then\r\n begin\r\n Invalidate;\r\n if Parent is TJvLookOutPage then\r\n TJvLookOutPage(Parent).ScrollChildren(0);\r\n end;\r\nend;\r\n\r\n//=== { TJvExpressButton } ===================================================\r\n\r\nconstructor TJvExpressButton.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FillColor := clBtnFace;\r\n Offset := 1;\r\n FButtonBorder := bbLight;\r\n FHighlightFont.Color := clWindowText;\r\n ParentFont := False;\r\n Font.Color := clHighlightText;\r\nend;\r\n\r\n//=== { TJvLookOutPage } =====================================================\r\n\r\nconstructor TJvLookOutPage.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n ControlStyle := [csAcceptsControls, csCaptureMouse, csSetCaption];\r\n Color := clBtnShadow;\r\n FScrolling := 0;\r\n Caption := 'Outlook';\r\n FButtons := TList.Create;\r\n FDown := False;\r\n FShowPressed := False;\r\n Width := 92;\r\n Height := 100;\r\n // SetBounds(0, 0, 92, 100);\r\n FHighlightFont := TFont.Create;\r\n FHighlightFont.Assign(Font);\r\n FMargin := 0;\r\n FTopControl := 0;\r\n FParentImageSize := True;\r\n FAutoRepeat := False;\r\n FAutoCenter := True;\r\n FBitmap := TBitmap.Create;\r\nend;\r\n\r\ndestructor TJvLookOutPage.Destroy;\r\nbegin\r\n FEdit.Free;\r\n FUpArrow.Free;\r\n FDownArrow.Free;\r\n FBitmap.Free;\r\n FHighlightFont.Free;\r\n FButtons.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvLookOutPage.DisableAdjust;\r\nbegin\r\n Inc(FScrolling);\r\nend;\r\n\r\nprocedure TJvLookOutPage.EnableAdjust;\r\nbegin\r\n Dec(FScrolling);\r\nend;\r\n\r\nprocedure TJvLookOutPage.DownArrow;\r\nbegin\r\n if Enabled then\r\n DownArrowClick(Self);\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvLookOutPage.UpArrow;\r\nbegin\r\n if Enabled then\r\n UpArrowClick(Self);\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvLookOutPage.ExchangeButtons(Button1, Button2: TJvCustomLookOutButton);\r\nvar\r\n Tmp: Integer;\r\nbegin\r\n Tmp := Button1.Top;\r\n Button1.Top := Button2.Top;\r\n Button2.Top := Tmp;\r\n FButtons.Exchange(FButtons.IndexOf(Button1), FButtons.IndexOf(Button2));\r\nend;\r\n\r\nprocedure TJvLookOutPage.MoveButton(Button: TJvCustomLookOutButton; NewIndex: integer);\r\nvar OldIndex:integer;\r\nbegin\r\n OldIndex := FButtons.IndexOf(Button);\r\n FButtons.Move(OldIndex, NewIndex);\r\nend;\r\n\r\nfunction TJvLookOutPage.InsertButton(Index:integer): TJvCustomLookOutButton;\r\nbegin\r\n Result := AddButton;\r\n MoveButton(Result, Index);\r\nend;\r\n\r\nfunction TJvLookOutPage.AddButton: TJvCustomLookOutButton;\r\nbegin\r\n Result := TJvLookOutButton.Create(Self.Owner);\r\n Result.ImageIndex := ButtonCount;\r\n Result.Parent := Self;\r\n Result.Top := MaxInt;\r\n if Assigned(FUpArrow) and Assigned(FDownArrow) then\r\n begin\r\n FUpArrow.SetZOrder(True);\r\n FDownArrow.SetZOrder(True);\r\n end;\r\nend;\r\n\r\nprocedure TJvLookOutPage.DoOnEdited(var Caption: string);\r\nbegin\r\n if Self is TJvExpress then\r\n Exit;\r\n if Assigned(FOnEdited) then\r\n FOnEdited(Self, Caption);\r\nend;\r\n\r\nprocedure TJvLookOutPage.EditCaption;\r\nbegin\r\n if Self is TJvExpress then\r\n Exit;\r\n\r\n if not Assigned(FEdit) then\r\n begin\r\n FEdit := TJvLookOutEdit.Create(nil);\r\n FEdit.Parent := Self;\r\n end\r\n else\r\n if not FEdit.Visible then\r\n FEdit.Show;\r\n\r\n with FEdit do\r\n begin\r\n Text := Caption;\r\n // BorderStyle := bsNone;\r\n SetBounds(0, 0, Width, cHeight);\r\n AutoSelect := True;\r\n OnKeyPress := EditKeyDown;\r\n OnMouseDown := EditMouseDown;\r\n SetFocus;\r\n SetCapture(FEdit.Handle);\r\n SelStart := 0;\r\n SelLength := Length(Caption);\r\n end;\r\nend;\r\n\r\nprocedure TJvLookOutPage.EditMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState;\r\n X, Y: Integer);\r\nbegin\r\n if Assigned(FEdit) then\r\n begin\r\n if not PtInRect(FEdit.ClientRect, Point(X, Y)) or ((Button = mbRight) and FEdit.Visible) then\r\n begin\r\n if FEdit.Handle = GetCapture then\r\n ReleaseCapture;\r\n Screen.Cursor := crDefault;\r\n FEdit.Hide;\r\n FEdit.Free;\r\n FEdit := nil;\r\n end\r\n else\r\n begin\r\n ReleaseCapture;\r\n Screen.Cursor := crIBeam;\r\n SetCapture(FEdit.Handle);\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvLookOutPage.EditKeyDown(Sender: TObject; var Key: Char);\r\nvar\r\n ACaption: string;\r\n Modify: Boolean;\r\nbegin\r\n Modify := False;\r\n if Sender = FEdit then\r\n case Key of\r\n Cr:\r\n begin\r\n Key := #0;\r\n ACaption := FEdit.Text;\r\n DoOnEdited(ACaption);\r\n FEdit.Text := ACaption;\r\n Modify := True;\r\n if FEdit.Handle = GetCapture then\r\n ReleaseCapture;\r\n FEdit.Hide;\r\n FEdit.Free;\r\n FEdit := nil;\r\n Screen.Cursor := crDefault;\r\n end;\r\n Esc:\r\n begin\r\n Key := #0;\r\n if FEdit.Handle = GetCapture then\r\n ReleaseCapture;\r\n FEdit.Hide;\r\n FEdit.Free;\r\n FEdit := nil;\r\n Screen.Cursor := crDefault;\r\n end;\r\n end;\r\n if Modify then\r\n Caption := ACaption;\r\nend;\r\n\r\nfunction TJvLookOutPage.WantKey(Key: Integer; Shift: TShiftState): Boolean;\r\nbegin\r\n Result := IsAccel(Key, Caption) and Enabled and (ssAlt in Shift);\r\n if Result then\r\n Click\r\n else\r\n Result := inherited WantKey(Key, Shift);\r\nend;\r\n\r\nprocedure TJvLookOutPage.SetActiveButton(Value: TJvCustomLookOutButton);\r\nbegin\r\n if (Value <> nil) and (FActiveButton <> Value) and (Value.Parent = Self) then\r\n FActiveButton := Value;\r\nend;\r\n\r\nprocedure TJvLookOutPage.SetParent( AParent: TWinControl);\r\nbegin\r\n if AParent <> Parent then\r\n begin\r\n if (Parent <> nil) and (Parent is TJvLookOut) then\r\n TJvLookOut(Parent).FPages.Delete(TJvLookOut(Parent).FPages.IndexOf(Self));\r\n if (AParent <> nil) and (AParent is TJvLookOut) then\r\n TJvLookOut(AParent).FPages.Add(Self);\r\n end;\r\n inherited SetParent(AParent);\r\nend;\r\n\r\nprocedure TJvLookOutPage.Notification(AComponent: TComponent; Operation: TOperation);\r\nbegin\r\n inherited Notification(AComponent, Operation);\r\n if Operation = opRemove then\r\n begin\r\n if AComponent = FPopUpMenu then\r\n FPopUpMenu := nil;\r\n end;\r\n if Operation = opInsert then\r\n begin\r\n if not (csDesigning in ComponentState) and not (csLoading in ComponentState) then\r\n if Assigned(FUpArrow) and Assigned(FDownArrow) then\r\n begin\r\n FUpArrow.SetZOrder(True);\r\n FDownArrow.SetZOrder(True);\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvLookOutPage.AlignControls(Control: TControl; var Rect: TRect);\r\nbegin\r\n Inc(Rect.Top, cHeight);\r\n inherited AlignControls(Control, Rect);\r\nend;\r\n\r\nprocedure TJvLookOutPage.SmoothScroll(AControl: TControl; NewTop, AInterval: Integer; Smooth: Boolean);\r\nbegin\r\n if Smooth and not (csDesigning in ComponentState) and not (csLoading in ComponentState) and not FInScroll then\r\n begin\r\n FInScroll := True;\r\n if AControl.Top < NewTop then\r\n if AControl.Top > 0 then\r\n begin\r\n while AControl.Top < NewTop do\r\n begin\r\n AControl.Top := AControl.Top + AInterval;\r\n // (rom) not a good implementation\r\n Application.ProcessMessages;\r\n end;\r\n end\r\n else\r\n begin\r\n while AControl.Top < NewTop do\r\n begin\r\n AControl.Top := AControl.Top - AInterval;\r\n Application.ProcessMessages;\r\n end;\r\n end\r\n else\r\n if AControl.Top > 0 then\r\n begin\r\n while AControl.Top > NewTop do\r\n begin\r\n AControl.Top := AControl.Top - AInterval;\r\n Application.ProcessMessages;\r\n end;\r\n end\r\n else\r\n begin\r\n while AControl.Top > NewTop do\r\n begin\r\n AControl.Top := AControl.Top + AInterval;\r\n Application.ProcessMessages;\r\n end;\r\n end;\r\n end;\r\n { adjust }\r\n AControl.Top := NewTop;\r\n Application.ProcessMessages;\r\n FInScroll := False;\r\nend;\r\n\r\nfunction Compare(Item1, Item2: Pointer): Integer;\r\nbegin\r\n Result := TControl(Item1).Top - TControl(Item2).Top;\r\nend;\r\n\r\nprocedure TJvLookOutPage.ScrollChildren(Start: Word);\r\nvar\r\n R: TRect;\r\n I, X, ACount: Integer; {AList: TList;}\r\n AControl: TControl;\r\nbegin\r\n if FScrolling <> 0 then\r\n Exit;\r\n if (csReading in ComponentState) or (csLoading in ComponentState) or (csWriting in ComponentState) or\r\n (csDestroying in ComponentState) then\r\n Exit;\r\n { draw all owned controls }\r\n if ControlCount < 3 then\r\n begin\r\n if Assigned(FUpArrow) and Assigned(FDownArrow) then\r\n begin\r\n FUpArrow.Visible := False;\r\n FDownArrow.Visible := False;\r\n end;\r\n Exit;\r\n end;\r\n if FInScroll then\r\n Exit;\r\n R := GetClientRect;\r\n X := Width;\r\n ACount := GetButtonCount;\r\n if ACount = 0 then\r\n Exit;\r\n\r\n// Mantis 2842: Sorting triggers the issue, and I can't see any reason why\r\n// it should be sorted according to \"Top\" in the first place. (obones)\r\n// FButtons.Sort(Compare);\r\n\r\n FInScroll := True;\r\n for I := 0 to ACount - 1 do\r\n begin\r\n AControl := FButtons[I];\r\n if not AControl.Visible and not (csDesigning in ComponentState) then\r\n Continue;\r\n if AControl.Align <> alNone then\r\n AControl.Align := alNone;\r\n\r\n if I < FTopControl then\r\n AControl.Top := -(AControl.Height + 1) * (ACount - I)\r\n else\r\n if Start > Height then\r\n AControl.Top := (Height + 1) * (I + 1)\r\n else\r\n begin\r\n AControl.Top := Start + FMargin;\r\n Inc(Start, (AControl.Height + FMargin));\r\n end;\r\n\r\n if FAutoCenter and (AControl is TJvCustomLookOutButton) and\r\n (TJvCustomLookOutButton(AControl).ImageSize = isLarge) then\r\n AControl.Left := (X - AControl.Width) div 2;\r\n end;\r\n FInScroll := False;\r\nend;\r\n\r\nprocedure TJvLookOutPage.CreateWnd;\r\nvar\r\n R: TRect;\r\nbegin\r\n inherited CreateWnd;\r\n R := GetClientRect;\r\n if not Assigned(FUpArrow) then\r\n begin\r\n FUpArrow := TJvUpArrowBtn.Create(nil);\r\n FUpArrow.Parent := Self;\r\n end;\r\n\r\n if not Assigned(FDownArrow) then\r\n begin\r\n FDownArrow := TJvDwnArrowBtn.Create(nil);\r\n FDownArrow.Parent := Self;\r\n end;\r\n\r\n with FUpArrow do\r\n begin\r\n Visible := False;\r\n SetBounds(R.Right - 23, R.Top + 25, 16, 16);\r\n end;\r\n\r\n with FDownArrow do\r\n begin\r\n Visible := False;\r\n SetBounds(R.Right - 23, R.Bottom - 23, 16, 16);\r\n end;\r\n\r\n if Assigned(Parent) and (Parent is TJvLookOut) then\r\n begin\r\n FManager := TJvLookOut(Parent);\r\n FOnCollapse := FManager.FOnCollapse;\r\n end;\r\n // (p3) fix to work with frames\r\n if GetParentForm(Self) <> nil then\r\n begin\r\n FUpArrow.SetZOrder(True);\r\n FDownArrow.SetZOrder(True);\r\n end;\r\nend;\r\n\r\nprocedure TJvLookOutPage.Click;\r\nbegin\r\n if not Enabled then\r\n Exit;\r\n if Assigned(FOnCollapse) then\r\n FOnCollapse(Self);\r\n inherited Click;\r\nend;\r\n\r\nprocedure TJvLookOutPage.EnabledChanged;\r\nbegin\r\n if not (Assigned(FUpArrow) or Assigned(FDownArrow)) then\r\n Exit;\r\n if not Enabled then\r\n begin\r\n FUpArrow.Enabled := False;\r\n FDownArrow.Enabled := False;\r\n end\r\n else\r\n begin\r\n FUpArrow.Enabled := True;\r\n FDownArrow.Enabled := True;\r\n end;\r\n inherited EnabledChanged;\r\n Refresh;\r\nend;\r\n\r\nfunction TJvLookOutPage.IsVisible(Control: TControl): Boolean;\r\nvar\r\n R: TRect;\r\nbegin\r\n Result := False;\r\n if Control = nil then\r\n Exit;\r\n R := GetClientRect;\r\n Result := (PtInRect(R, Point(R.Left + 1, Control.Top)) and\r\n PtInRect(R, Point(R.Left + 1, Control.Top + Control.Height)));\r\nend;\r\n\r\nprocedure TJvLookOutPage.SetAutoRepeat(Value: Boolean);\r\nbegin\r\n if FAutoRepeat <> Value then\r\n begin\r\n FAutoRepeat := Value;\r\n if Assigned(FUpArrow) and Assigned(FDownArrow) then\r\n begin\r\n FUpArrow.AutoRepeat := FAutoRepeat;\r\n FDownArrow.AutoRepeat := FAutoRepeat;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvLookOutPage.SetHighlightFont(Value: TFont);\r\nbegin\r\n FHighlightFont.Assign(Value);\r\n if FHighlightFont <> Font then\r\n DrawTopButton;\r\nend;\r\n\r\nprocedure TJvLookOutPage.SetButton(Index: Integer; Value: TJvCustomLookOutButton);\r\nbegin\r\n FButtons[Index] := Value;\r\nend;\r\n\r\nfunction TJvLookOutPage.GetButton(Index: Integer): TJvCustomLookOutButton;\r\nbegin\r\n Result := TJvLookOutButton(FButtons[Index]);\r\nend;\r\n\r\nfunction TJvLookOutPage.GetButtonCount: Integer;\r\nbegin\r\n Result := FButtons.Count;\r\nend;\r\n\r\nprocedure TJvLookOutPage.SetAutoCenter(Value: Boolean);\r\nbegin\r\n if FAutoCenter <> Value then\r\n begin\r\n FAutoCenter := Value;\r\n if FAutoCenter then\r\n ScrollChildren(cHeight + 7 - FMargin);\r\n end;\r\nend;\r\n\r\nprocedure TJvLookOutPage.SetMargin(Value: Integer);\r\nbegin\r\n if FMargin <> Value then\r\n begin\r\n FMargin := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvLookOutPage.SetImageSize(Value: TJvImageSize);\r\nvar\r\n Msg: TMessage;\r\nbegin\r\n if FImageSize <> Value then\r\n begin\r\n FImageSize := Value;\r\n if csDesigning in ComponentState then\r\n SetParentImageSize(False);\r\n { notify children }\r\n Msg.Msg := CM_IMAGESIZECHANGED;\r\n Msg.WParam := WPARAM(Ord(FImageSize));\r\n Msg.LParam := LPARAM(Self);\r\n Msg.Result := 0;\r\n if Parent <> nil then\r\n Parent.Broadcast(Msg);\r\n Broadcast(Msg);\r\n end;\r\nend;\r\n\r\nprocedure TJvLookOutPage.SetParentImageSize(Value: Boolean);\r\nbegin\r\n FParentImageSize := Value;\r\n if FParentImageSize and (FManager <> nil) then\r\n SetImageSize(FManager.ImageSize);\r\nend;\r\n\r\nprocedure TJvLookOutPage.CMParentImageSizeChanged(var Msg: TMessage);\r\nvar\r\n Tmp: Boolean;\r\nbegin\r\n if (Msg.LParam <> LPARAM(Self)) and FParentImageSize then\r\n begin\r\n Tmp := FParentImageSize;\r\n SetImageSize(TJvImageSize(Msg.WParam));\r\n FParentImageSize := Tmp;\r\n end;\r\nend;\r\n\r\nprocedure TJvLookOutPage.SetBitmap(Value: TBitmap);\r\nbegin\r\n FBitmap.Assign(Value);\r\n if FBitmap.Empty then\r\n ControlStyle := ControlStyle - [csOpaque]\r\n else\r\n ControlStyle := ControlStyle + [csOpaque];\r\n // RecreateWnd;\r\n Invalidate;\r\nend;\r\n\r\n{ determine if arrows should be visible }\r\n\r\nprocedure TJvLookOutPage.CalcArrows;\r\nvar\r\n I: Integer;\r\n R: TRect;\r\n AList: TList;\r\nbegin\r\n if Assigned(FUpArrow) and Assigned(FDownArrow) then\r\n begin\r\n // (rom) needs constants instead of numbers\r\n if Height < 65 then\r\n begin\r\n // FUpArrow.Visible := False;\r\n // FDownArrow.Visible := False;\r\n FDownArrow.Top := FUpArrow.Top + 16;\r\n Exit;\r\n end;\r\n\r\n R := GetClientRect;\r\n FUpArrow.SetBounds(R.Right - 23, R.Top + 25, 16, 16);\r\n FDownArrow.SetBounds(R.Right - 23, R.Bottom - 23, 16, 16);\r\n AList := TList.Create;\r\n try\r\n for I := 0 to ControlCount - 1 do\r\n begin\r\n if (Controls[I] = FUpArrow) or (Controls[I] = FDownArrow) or (Controls[I] = FEdit) then\r\n Continue;\r\n\r\n if not Controls[I].Visible and not (csDesigning in ComponentState) then\r\n Continue;\r\n \r\n if Controls[I].Align = alClient then\r\n Continue;\r\n\r\n AList.Insert(AList.Count, Controls[I]);\r\n end;\r\n\r\n if AList.Count = 0 then\r\n Exit;\r\n AList.Sort(Compare);\r\n FDownArrow.Visible := not IsVisible(AList.Items[AList.Count - 1]);\r\n FUpArrow.Visible := not IsVisible(AList.Items[0]);\r\n finally\r\n AList.Free;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvLookOutPage.UpArrowClick(Sender: TObject);\r\nbegin\r\n if (FScrolling = 0) and (FTopControl > 0) then\r\n Dec(FTopControl);\r\nend;\r\n\r\nprocedure TJvLookOutPage.DownArrowClick(Sender: TObject);\r\nbegin\r\n if (FScrolling = 0) and (FTopControl < ControlCount - 3) then\r\n Inc(FTopControl);\r\nend;\r\n\r\nprocedure TJvLookOutPage.Paint;\r\nbegin\r\n if not FBitmap.Empty then\r\n begin\r\n ControlStyle := ControlStyle + [csOpaque];\r\n TileBitmap;\r\n end\r\n else\r\n ControlStyle := ControlStyle - [csOpaque];\r\n\r\n DrawTopButton;\r\n CalcArrows;\r\n ScrollChildren(cHeight + 7 - FMargin);\r\nend;\r\n\r\nprocedure TJvLookOutPage.DrawTopButton;\r\nvar\r\n R, R2: TRect;\r\n DC: HDC;\r\n FFlat, FPush: Boolean;\r\nbegin\r\n if MouseOver then\r\n Canvas.Font := FHighlightFont\r\n else\r\n Canvas.Font := Self.Font;\r\n\r\n Canvas.Brush.Color := clBtnFace;\r\n DC := Canvas.Handle;\r\n R := GetClientRect;\r\n\r\n { draw top button }\r\n R.Bottom := cHeight;\r\n Canvas.FillRect(R);\r\n FPush := FShowPressed and FDown;\r\n FFlat := Assigned(FManager) and (FManager.FFlatButtons);\r\n if FFlat then\r\n begin\r\n if FManager.ActivePage = Self then\r\n begin\r\n R2 := GetClientRect;\r\n R2.Top := R.Bottom;\r\n Frame3D(Canvas, R2, cl3DDkShadow, clBtnFace, 1);\r\n end;\r\n\r\n if FPush then\r\n Frame3D(Canvas, R, clBtnShadow, clBtnHighlight, 1)\r\n else\r\n if MouseOver then\r\n begin\r\n Frame3D(Canvas, R, clBtnHighlight, cl3DDkShadow, 1);\r\n Frame3D(Canvas, R, clBtnFace, clBtnShadow, 1);\r\n end\r\n else\r\n Frame3D(Canvas, R, clBtnHighlight, clBtnShadow, 1)\r\n end\r\n else\r\n begin\r\n if FPush then\r\n begin\r\n Frame3D(Canvas, R, cl3DDkShadow, clBtnHighlight, 1);\r\n Frame3D(Canvas, R, clBtnShadow, clBtnFace, 1);\r\n end\r\n else\r\n begin\r\n Frame3D(Canvas, R, clBtnHighlight, cl3DDkShadow, 1);\r\n Frame3D(Canvas, R, clBtnFace, clBtnShadow, 1);\r\n end;\r\n end;\r\n\r\n { draw top caption }\r\n R := GetClientRect;\r\n R.Bottom := cHeight;\r\n SetBkMode(DC, Windows.Transparent);\r\n if Caption <> '' then\r\n begin\r\n if not Enabled then\r\n begin\r\n { draw disabled text }\r\n SetTextColor(DC, ColorToRGB(clBtnHighlight));\r\n OffsetRect(R, 1, 1);\r\n DrawText(DC, Caption, Length(Caption), R, DT_CENTER or DT_VCENTER or DT_SINGLELINE);\r\n OffsetRect(R, -1, -1);\r\n SetTextColor(DC, ColorToRGB(clBtnShadow));\r\n end\r\n else\r\n SetTextColor(DC, ColorToRGB(Canvas.Font.Color));\r\n if FShowPressed and FDown then\r\n OffsetRect(R, 1, 1);\r\n DrawText(DC, Caption, Length(Caption), R, DT_CENTER or DT_VCENTER or DT_SINGLELINE);\r\n end;\r\nend;\r\n\r\nprocedure TJvLookOutPage.TileBitmap;\r\nvar\r\n X, Y, W, H: Longint;\r\n Dest, Source: TRect;\r\n Tmp: TBitmap;\r\nbegin\r\n if not FBitmap.Empty then\r\n begin\r\n with FBitmap do\r\n begin\r\n W := Width;\r\n H := Height;\r\n end;\r\n\r\n Tmp := TBitmap.Create;\r\n Tmp.Width := Width;\r\n Tmp.Height := Height;\r\n\r\n Y := 0;\r\n Source := Rect(0, 0, W, H);\r\n while Y < Height do\r\n begin\r\n X := 0;\r\n while X < Width do\r\n begin\r\n Dest := Rect(X, Y, X + W, Y + H);\r\n Tmp.Canvas.CopyRect(Dest, FBitmap.Canvas, Source);\r\n Inc(X, W);\r\n end;\r\n Inc(Y, H);\r\n end;\r\n Canvas.Draw(0, 0, Tmp);\r\n Tmp.Free;\r\n end;\r\nend;\r\n\r\nprocedure TJvLookOutPage.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);\r\nvar\r\n R: TRect;\r\n Tmp: TPoint;\r\n Msg: TMsg;\r\nbegin\r\n inherited MouseDown(Button, Shift, X, Y);\r\n if Assigned(FPopUpMenu) and (Button = mbRight) then\r\n begin\r\n { calc where to put menu }\r\n Tmp := ClientToScreen(Point(X, Y));\r\n FPopUpMenu.PopupComponent := Self;\r\n FPopUpMenu.Popup(Tmp.X, Tmp.Y);\r\n { wait 'til menu is Done }\r\n while PeekMessage(Msg, 0, WM_MOUSEFIRST, WM_MOUSELAST, PM_REMOVE) do\r\n {nothing};\r\n FDown := False;\r\n end\r\n else\r\n begin\r\n R := GetClientRect;\r\n R.Bottom := cHeight;\r\n if PtInRect(R, Point(X, Y)) and (Button = mbLeft) then\r\n begin\r\n FDown := True;\r\n DrawTopButton;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvLookOutPage.MouseMove(Shift: TShiftState; X, Y: Integer);\r\nvar\r\n R: TRect;\r\nbegin\r\n R := GetClientRect;\r\n R.Bottom := cHeight;\r\n if PtInRect(R, Point(X, Y)) then\r\n begin\r\n if not MouseOver then\r\n begin\r\n MouseOver := True;\r\n DrawTopButton;\r\n end\r\n end\r\n else\r\n if MouseOver or FDown then\r\n begin\r\n MouseOver := False;\r\n // FDown := False;\r\n DrawTopButton;\r\n end;\r\n inherited MouseMove(Shift, X, Y);\r\nend;\r\n\r\nprocedure TJvLookOutPage.MouseUp(Button: TMouseButton; Shift: TShiftState;\r\n X, Y: Integer);\r\nvar\r\n R: TRect;\r\nbegin\r\n inherited MouseUp(Button, Shift, X, Y);\r\n if not Enabled then\r\n Exit;\r\n FDown := False;\r\n R := GetClientRect;\r\n R.Bottom := cHeight;\r\n if PtInRect(R, Point(X, Y)) and (Button = mbLeft) then\r\n begin\r\n if Assigned(FOnCollapse) then\r\n FOnCollapse(Self);\r\n if Assigned(FOnClick) then\r\n FOnClick(Self);\r\n end;\r\n DrawTopButton;\r\nend;\r\n\r\nprocedure TJvLookOutPage.MouseLeave(Control: TControl);\r\nbegin\r\n if MouseOver then\r\n begin\r\n inherited MouseLeave(Control);\r\n // FDown := False;\r\n DrawTopButton;\r\n end;\r\nend;\r\n\r\nprocedure TJvLookOut.SetFlatButtons(Value: Boolean);\r\nbegin\r\n if FFlatButtons <> Value then\r\n begin\r\n FFlatButtons := Value;\r\n // for I := 0 to PageCount - 1 do\r\n // Pages[I].DrawTopButton;\r\n RecreateWnd;\r\n end;\r\nend;\r\n\r\n//=== { TJvLookOut } =========================================================\r\n\r\nconstructor TJvLookOut.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n ControlStyle := [csAcceptsControls, csCaptureMouse, csClickEvents,\r\n csSetCaption, csOpaque];\r\n FPages := TList.Create;\r\n Width := 92;\r\n Height := 300;\r\n FBorderStyle := bsSingle;\r\n FAutoSize := False;\r\n FSmooth := False;\r\n FFlatButtons := False;\r\n Color := clBtnFace;\r\n FOnCollapse := DoCollapse;\r\n FImageSize := isLarge;\r\nend;\r\n\r\ndestructor TJvLookOut.Destroy;\r\nbegin\r\n FPages.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJvLookOut.AddPage: TJvLookOutPage;\r\nbegin\r\n Result := TJvLookOutPage.Create(Self.Owner);\r\n Result.Parent := Self;\r\n ActivePage := Result;\r\nend;\r\n\r\nprocedure TJvLookOut.Notification(AComponent: TComponent; Operation: TOperation);\r\nvar\r\n I: Integer;\r\nbegin\r\n inherited Notification(AComponent, Operation);\r\n if Operation = opRemove then\r\n begin\r\n if AComponent = FActivePage then\r\n FActivePage := nil;\r\n if AComponent = FCurrentPage then\r\n FCurrentPage := nil;\r\n if (AComponent is TJvLookOutPage) and (TJvLookOutPage(AComponent).Parent = Self) then\r\n begin\r\n I := FPages.IndexOf(AComponent);\r\n if I > -1 then\r\n FPages.Delete(I);\r\n end;\r\n end\r\n else {// insertion}\r\n if (AComponent is TJvLookOutPage) and (TJvLookOutPage(AComponent).Parent = Self) then\r\n begin\r\n if FPages.IndexOf(AComponent) = -1 then\r\n FPages.Add(AComponent);\r\n end;\r\n\r\n if Canvas <> nil then\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvLookOut.UpdateControls;\r\nbegin\r\n if FCurrentPage <> nil then\r\n DoCollapse(FCurrentPage)\r\n else\r\n if FActivePage <> nil then\r\n DoCollapse(FActivePage)\r\n else\r\n if (ControlCount > 0) and (Controls[0] is TJvLookOutPage) then\r\n DoCollapse(Controls[0]);\r\nend;\r\n\r\nprocedure TJvLookOut.SetAutoSize(Value: Boolean);\r\nbegin\r\n if FAutoSize <> Value then\r\n begin\r\n FAutoSize := Value;\r\n if FAutoSize then\r\n UpdateControls;\r\n end;\r\nend;\r\n\r\nprocedure TJvLookOut.SetImageSize(Value: TJvImageSize);\r\nvar\r\n Msg: TMessage;\r\nbegin\r\n if FImageSize <> Value then\r\n begin\r\n FImageSize := Value;\r\n { notify children }\r\n Msg.Msg := CM_IMAGESIZECHANGED;\r\n Msg.WParam := WPARAM(Ord(FImageSize));\r\n Msg.LParam := LPARAM(Self);\r\n Msg.Result := 0;\r\n Broadcast(Msg);\r\n end;\r\nend;\r\n\r\nprocedure TJvLookOut.SetBorderStyle(Value: TBorderStyle);\r\nbegin\r\n if FBorderStyle <> Value then\r\n begin\r\n FBorderStyle := Value;\r\n RecreateWnd;\r\n end;\r\nend;\r\n\r\n{ calculate which TJvLookOutPage should be visible and which should not }\r\n\r\nprocedure TJvLookOut.DoCollapse(Sender: TObject);\r\nvar\r\n C: TControl;\r\n Done: Boolean;\r\n vis, I, ht, ofs, bh, cc, flt: Integer;\r\nbegin\r\n if Sender is TJvLookOutPage then\r\n begin\r\n FCurrentPage := TJvLookOutPage(Sender);\r\n FActivePage := FCurrentPage;\r\n FCurrentPage.DrawTopButton;\r\n end;\r\n\r\n if Assigned(FOnClick) then\r\n FOnClick(Sender);\r\n\r\n cc := ControlCount - 1;\r\n Done := False;\r\n ht := Height;\r\n vis := 0;\r\n ofs := 0;\r\n\r\n { make sure non-visible pages don't mess up the display }\r\n for I := 0 to cc do\r\n if Controls[I].Visible then\r\n Inc(vis);\r\n if Height <= (cHeight * vis) + 65 then\r\n Exit;\r\n if FFlatButtons then\r\n flt := 2\r\n else\r\n flt := 4;\r\n\r\n for I := 0 to cc do\r\n begin\r\n C := Controls[I];\r\n\r\n if not C.Visible then\r\n begin\r\n Inc(ofs);\r\n Continue;\r\n end;\r\n\r\n C.Align := alNone;\r\n bh := cHeight + 1;\r\n\r\n if FAutoSize then\r\n C.SetBounds(0, C.Top, Width - flt, C.Height);\r\n\r\n C.Height := ht - (vis - 1) * bh;\r\n\r\n if C = Sender then\r\n Done := True;\r\n\r\n if (C = Sender) or (I = 0) then { first or caller }\r\n SmoothScroll(C, (I - ofs) * bh, cSpeed, FSmooth)\r\n else\r\n if Done and (C <> Sender) then { place at bottom }\r\n SmoothScroll(C, ht - (vis - I + ofs) * bh - flt + 1, cSpeed, FSmooth)\r\n else { place at top }\r\n SmoothScroll(C, (I - ofs) * bh, cSpeed, FSmooth);\r\n end;\r\nend;\r\n\r\nprocedure TJvLookOut.SmoothScroll(AControl: TControl; NewTop, AInterval: Integer; Smooth: Boolean);\r\nbegin\r\n if Smooth and not (csDesigning in ComponentState) then\r\n begin\r\n if AControl.Top < NewTop then\r\n while AControl.Top < NewTop do\r\n begin\r\n AControl.Top := AControl.Top + AInterval;\r\n end\r\n else\r\n while AControl.Top > NewTop do\r\n begin\r\n AControl.Top := AControl.Top - AInterval;\r\n end;\r\n end;\r\n { adjust }\r\n AControl.Top := NewTop;\r\nend;\r\n\r\nprocedure TJvLookOut.SetActiveOutlook(Value: TJvLookOutPage);\r\nvar\r\n I: Integer;\r\nbegin\r\n if (Value <> nil) and (Value.Parent = Self) and (Value.Visible) then\r\n DoCollapse(Value)\r\n else\r\n if PageCount > 0 then\r\n for I := 0 to PageCount - 1 do\r\n if Pages[I].Visible then\r\n DoCollapse(Pages[I])\r\n else\r\n FActivePage := nil;\r\nend;\r\n\r\nfunction TJvLookOut.GetActiveOutlook: TJvLookOutPage;\r\nbegin\r\n if csDesigning in ComponentState then\r\n Result := FActivePage\r\n else\r\n Result := FCurrentPage;\r\nend;\r\n\r\nfunction TJvLookOut.GetPageCount: Integer;\r\nbegin\r\n Result := FPages.Count;\r\nend;\r\n\r\nfunction TJvLookOut.GetPage(Index: Integer): TJvLookOutPage;\r\nbegin\r\n Result := TJvLookOutPage(FPages[Index]);\r\nend;\r\n\r\nprocedure TJvLookOut.SetPage(Index: Integer; Value: TJvLookOutPage);\r\nbegin\r\n FPages[Index] := Value;\r\nend;\r\n\r\n\r\nprocedure TJvLookOut.WMNCCalcSize(var Msg: TWMNCCalcSize);\r\nbegin\r\n with Msg.CalcSize_Params^ do\r\n if FFlatButtons then\r\n InflateRect(rgrc[0], -1, -1)\r\n else\r\n InflateRect(rgrc[0], -2, -2);\r\n inherited;\r\nend;\r\n\r\n\r\n\r\nprocedure TJvLookOut.WMNCPaint(var Msg: TMessage);\r\nvar\r\n DC: HDC;\r\n RC, RW: TRect;\r\nbegin\r\n DC := GetWindowDC(Handle);\r\n try\r\n GetWindowRect(Handle, RW);\r\n Windows.GetClientRect(Handle, RC);\r\n MapWindowPoints(NullHandle, Handle, RW, 2);\r\n OffsetRect(RC, -RW.Left, -RW.Top);\r\n ExcludeClipRect(DC, RC.Left, RC.Top, RC.Right, RC.Bottom);\r\n OffsetRect(RW, -RW.Left, -RW.Top);\r\n if FBorderStyle = bsSingle then\r\n begin\r\n {$IFDEF JVCLThemesEnabled}\r\n if ThemeServices.{$IFDEF RTL230_UP}Enabled{$ELSE}ThemesEnabled{$ENDIF RTL230_UP} then\r\n DrawThemedBorder(Self)\r\n else\r\n {$ENDIF JVCLThemesEnabled}\r\n DrawEdge(DC, RW, EDGE_SUNKEN, BF_RECT)\r\n end\r\n else\r\n begin\r\n Canvas.Brush.Color := Color;\r\n Windows.FrameRect(DC, RW, Canvas.Brush.Handle);\r\n InflateRect(RW, -1, -1);\r\n Windows.FrameRect(DC, RW, Canvas.Brush.Handle);\r\n InflateRect(RW, 1, 1);\r\n end;\r\n { Erase parts not drawn }\r\n IntersectClipRect(DC, RW.Left, RW.Top, RW.Right, RW.Bottom);\r\n finally\r\n ReleaseDC(Handle, DC);\r\n end;\r\nend;\r\n\r\nprocedure TJvLookOut.Paint;\r\nbegin\r\n if not (Visible or (csDesigning in ComponentState)) then\r\n Exit;\r\n Canvas.Brush.Color := Color;\r\n Canvas.FillRect(GetClientRect);\r\n { make TJvLookOuts adjust to Managers size }\r\n if (ControlCount > 0) and FAutoSize then\r\n UpdateControls;\r\nend;\r\n\r\n//=== { TJvExpress } =========================================================\r\n\r\nconstructor TJvExpress.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n AutoCenter := False;\r\n ImageSize := isLarge;\r\n FBorderStyle := bsSingle;\r\n FTopControl := 0;\r\n FButtonHeight := 60;\r\nend;\r\n\r\nprocedure TJvExpress.Paint;\r\nbegin\r\n if not FBitmap.Empty then\r\n begin\r\n ControlStyle := ControlStyle + [csOpaque];\r\n TileBitmap;\r\n end\r\n else\r\n begin\r\n ControlStyle := ControlStyle - [csOpaque];\r\n Canvas.Brush.Color := Color;\r\n Canvas.FillRect(GetClientRect);\r\n end;\r\n\r\n CalcArrows;\r\n ScrollChildren(0);\r\nend;\r\n\r\nfunction TJvExpress.AddButton: TJvExpressButton;\r\nbegin\r\n Result := TJvExpressButton.Create(Self.Owner);\r\n Result.Parent := Self;\r\n Result.ImageIndex := ButtonCount;\r\n Result.Top := MaxInt;\r\n if Assigned(FUpArrow) and Assigned(FDownArrow) then\r\n begin\r\n FUpArrow.SetZOrder(True);\r\n FDownArrow.SetZOrder(True);\r\n end;\r\nend;\r\n\r\nprocedure TJvExpress.AlignControls(Control: TControl; var Rect: TRect);\r\nbegin\r\n // TJvLookoutPage adjusts the rects top, so move it back\r\n Dec(Rect.Top, cHeight);\r\n inherited AlignControls(Control, Rect);\r\nend;\r\n\r\nprocedure TJvExpress.CalcArrows;\r\nvar\r\n I: Integer;\r\n R: TRect;\r\n AList: TList;\r\nbegin\r\n if Assigned(FUpArrow) and Assigned(FDownArrow) then\r\n begin\r\n if Height < 65 then\r\n begin\r\n // FDownArrow.Top := FUpArrow.Top + 16;\r\n Exit;\r\n end;\r\n\r\n R := GetClientRect;\r\n AList := TList.Create;\r\n try\r\n for I := 0 to ControlCount - 1 do\r\n begin\r\n if (Controls[I] = FUpArrow) or (Controls[I] = FDownArrow) or (Controls[I] = FEdit) then\r\n Continue;\r\n\r\n if not (Controls[I].Visible or (csDesigning in ComponentState)) then\r\n Continue;\r\n AList.Insert(AList.Count, Controls[I]);\r\n end;\r\n\r\n if AList.Count = 0 then\r\n Exit;\r\n AList.Sort(Compare);\r\n FDownArrow.Visible := not IsVisible(AList.Items[AList.Count - 1]);\r\n FUpArrow.Visible := not IsVisible(AList.Items[0]);\r\n finally\r\n AList.Free;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvExpress.ScrollChildren(Start: Word);\r\nvar\r\n I: Integer;\r\nbegin\r\n { size all children to width of TJvExpress }\r\n if not AutoCenter then\r\n for I := 0 to ControlCount - 1 do\r\n if Controls[I] is TJvExpressButton then\r\n Controls[I].SetBounds(0, Controls[I].Top, Width - 4, FButtonHeight);\r\n\r\n if Assigned(FUpArrow) then\r\n Start := 12 * Ord(FUpArrow.Visible)\r\n else\r\n Start := 0;\r\n inherited ScrollChildren(Start);\r\nend;\r\n\r\nprocedure TJvExpress.DrawTopButton;\r\nbegin\r\n { do nothing }\r\nend;\r\n\r\nprocedure TJvExpress.SetButtonHeight(Value: Integer);\r\nvar\r\n I: Integer;\r\nbegin\r\n if FButtonHeight <> Value then\r\n begin\r\n FButtonHeight := Value;\r\n for I := 0 to ButtonCount - 1 do\r\n Buttons[I].Height := FButtonHeight;\r\n end;\r\nend;\r\n\r\n\r\nprocedure TJvExpress.WMNCCalcSize(var Msg: TWMNCCalcSize);\r\nbegin\r\n with Msg.CalcSize_Params^ do\r\n InflateRect(rgrc[0], -2, -2);\r\n inherited;\r\nend;\r\n\r\n\r\nprocedure TJvExpress.CreateWnd;\r\nbegin\r\n inherited CreateWnd;\r\n if not Assigned(FUpArrow) then\r\n FUpArrow := TJvUpArrowBtn.Create(nil);\r\n\r\n if not Assigned(FDownArrow) then\r\n FDownArrow := TJvDwnArrowBtn.Create(nil);\r\n with FUpArrow do\r\n begin\r\n Parent := Self;\r\n Flat := True;\r\n Height := 13;\r\n Align := alTop;\r\n SetZOrder(True);\r\n end;\r\n\r\n with FDownArrow do\r\n begin\r\n Parent := Self;\r\n Flat := True;\r\n Height := 13;\r\n Align := alBottom;\r\n SetZOrder(True);\r\n end;\r\nend;\r\n\r\nprocedure TJvExpress.WMNCPaint(var Msg: TMessage);\r\nvar\r\n DC: HDC;\r\n RC, RW: TRect;\r\nbegin\r\n DC := GetWindowDC(Handle);\r\n try\r\n GetWindowRect(Handle, RW);\r\n Windows.GetClientRect(Handle, RC);\r\n MapWindowPoints(NullHandle, Handle, RW, 2);\r\n OffsetRect(RC, -RW.Left, -RW.Top);\r\n ExcludeClipRect(DC, RC.Left, RC.Top, RC.Right, RC.Bottom);\r\n OffsetRect(RW, -RW.Left, -RW.Top);\r\n if FBorderStyle = bsSingle then\r\n begin\r\n {$IFDEF JVCLThemesEnabled}\r\n if ThemeServices.{$IFDEF RTL230_UP}Enabled{$ELSE}ThemesEnabled{$ENDIF RTL230_UP} then\r\n DrawThemedBorder(Self)\r\n else\r\n {$ENDIF JVCLThemesEnabled}\r\n DrawEdge(DC, RW, EDGE_SUNKEN, BF_RECT);\r\n end\r\n else\r\n begin\r\n if csDesigning in ComponentState then\r\n Canvas.Brush.Color := clBlack\r\n else\r\n Canvas.Brush.Color := Color;\r\n FrameRect(DC, RW, Canvas.Brush.Handle);\r\n InflateRect(RW, -1, -1);\r\n if csDesigning in ComponentState then\r\n Canvas.Brush.Color := Color;\r\n FrameRect(DC, RW, Canvas.Brush.Handle);\r\n InflateRect(RW, 1, 1);\r\n end;\r\n { Erase parts not drawn }\r\n IntersectClipRect(DC, RW.Left, RW.Top, RW.Right, RW.Bottom);\r\n finally\r\n ReleaseDC(Handle, DC);\r\n end;\r\nend;\r\n\r\nprocedure TJvLookOutPage.CMTextChanged(var Msg: TMessage);\r\nbegin\r\n inherited;\r\n Invalidate;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\n\r\n\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvMRUList.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvMru.PAS, released on 2001-02-28.\r\n\r\nThe Initial Developer of the Original Code is S?stien Buysse [sbuysse att buypin dott com]\r\nPortions created by S?stien Buysse are Copyright (C) 2001 S?stien Buysse.\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\nMichael Beck [mbeck att bigfoot dott com].\r\nArioch [the_Arioch att nm dott ru]\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nDescription:\r\n This unit is an interface to the MRU List (comctl32)\r\n Informations from :\r\n http://www.geocities.com/SiliconValley/4942\r\n\r\nthe_Arioch att nm dott ru\r\n\r\nChanges are:\r\n 0) Memory leaks in GetItem and EnumerateItems been fixed in JVCL 1.32\r\n 1) fixed bug 2 Microsoft bugs. Read article at URL above.\r\n 2) added ItemData property that allows to read data w|o using event\r\n 3) EnumerateItems now relies upon GetItem to remove duplication of code.\r\n Now, if any bug - You may fix it one time, not 2 times :)\r\n 4) one more thing - i cannot get the reason that almost all of the methods\r\n of the component are published rather than public. I think it is also a bug\r\n 5) added MoveToTop(index) method; Warning! it changes ItemData property\r\n 6) added DelayedWrite property\r\n 7) renamed DeleteString to DeleteItem - cause it is the same for both String and Data\r\n 8) added UseUnicode property - if List is of string type then it will use WideString methods\r\n 9) added WantUnicode property - it will set UseUnicode respecting to used platform\r\n10) some storage modifiers added for published property\r\nxx) why keep UnicodeAvailable in every component? I wish Delphi could map\r\n property to a global variable :(\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvMRUList.pas 13104 2011-09-07 06:50:43Z obones $\r\n\r\nunit JvMRUList;\r\n\r\n{$I jvcl.inc}\r\n{$I windowsonly.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n {$IFDEF MSWINDOWS}\r\n Windows,\r\n {$ENDIF MSWINDOWS}\r\n SysUtils, Classes,\r\n JvComponentBase, JvTypes;\r\n\r\ntype\r\n TJvDataType = (dtString, dtBinary);\r\n TOnEnumData = procedure(Sender: TObject; Data: Pointer; Size: Integer; Index: Integer) of object;\r\n TOnEnumText = procedure(Sender: TObject; Value: string; Index: Integer) of object;\r\n TOnEnumUnicodeText = procedure(Sender: TObject; Value: WideString; Index: Integer) of object;\r\n\r\n TJvMruReturnData = record\r\n case Byte of\r\n 0: (P: Pointer; );\r\n 1: (S: PAnsiChar; );\r\n 2: (Ws: PWideChar; );\r\n end;\r\n PJvMruReturnData = ^TJvMruReturnData;\r\n TMruCount = 0..29;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvMruList = class(TJvComponent)\r\n private\r\n FUnicodeAvailable: Boolean;\r\n FUseUnicode: Boolean;\r\n FDelayedWrite: Boolean;\r\n FWantUnicode: Boolean;\r\n FMax: TMruCount;\r\n FSubKey: WideString;\r\n FKey: TJvRegKey;\r\n FList: THandle;\r\n FType: TJvDataType;\r\n FOnEnumData: TOnEnumData;\r\n FOnEnumText: TOnEnumText;\r\n FOnEnumUnicodeText: TOnEnumUnicodeText;\r\n FItemIndex: Integer;\r\n FItemData: TJvMruReturnData;\r\n procedure SetKey(const Value: TJvRegKey);\r\n procedure SetMax(const Value: TMruCount);\r\n function GetSubKey: string;\r\n procedure SetSubKeyUnicode(const Value: WideString);\r\n procedure SetSubKey(const Value: string);\r\n procedure SetType(const Value: TJvDataType);\r\n procedure SetUseUnicode(const Value: Boolean);\r\n procedure SetWantUnicode(const Value: Boolean);\r\n procedure SetItemData(const P: Pointer);\r\n function GetActive: Boolean;\r\n procedure SetActive(const Value: Boolean);\r\n function GetItemDataAsPChar: PChar;\r\n function GetItemDataAsPAnsiChar: PAnsiChar;\r\n function GetItemDataAsPWideChar: PWideChar;\r\n protected\r\n function InternalGetItem(Index: Integer; FireEvent: Boolean = True): Boolean;\r\n procedure ReCreateList;\r\n procedure NeedUnicode;\r\n procedure DoEnumText; virtual;\r\n procedure DoUnicodeEnumText; virtual;\r\n // Arioch: even DataSize can be retained later from properties - but let 'em be.\r\n procedure DoEnumData(DataSize: Integer); virtual;\r\n public\r\n procedure Close;\r\n procedure Open;\r\n function ItemDataSize: Integer;\r\n property ItemDataAsPointer: Pointer read FItemData.P;\r\n property ItemDataAsPChar: PChar read GetItemDataAsPChar;\r\n property ItemDataAsPAnsiChar: PAnsiChar read GetItemDataAsPAnsiChar;\r\n property ItemDataAsPWideChar: PWideChar read GetItemDataAsPWideChar;\r\n property ItemIndex: Integer read FItemIndex;\r\n\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n procedure MoveToTop(const Index: Integer);\r\n\r\n property UnicodeAvailable: Boolean read FUnicodeAvailable;\r\n property UseUnicode: Boolean read FUseUnicode write SetUseUnicode;\r\n\r\n // Arioch: the methods below are not public but published in original code\r\n function AddString(const Value: string): Boolean;\r\n function AddPChar(Value: PChar): Boolean;\r\n function AddAnsiString(const Value: AnsiString): Boolean;\r\n function AddAnsiPChar(Value: PAnsiChar): Boolean;\r\n function AddData(Value: Pointer; Size: Integer): Boolean;\r\n function GetItemsCount: Integer;\r\n function EnumItems: Boolean;\r\n function GetMostRecentItem: Boolean;\r\n function GetItem(Index: Integer = 0): Boolean;\r\n function FindString(const Value: string): Integer;\r\n function FindAnsiString(const Value: AnsiString): Integer;\r\n function FindData(Value: Pointer; Size: Integer): Integer;\r\n\r\n function DeleteItem(Index: Integer = 0): Boolean;\r\n function DeleteKey: Boolean;\r\n\r\n // Arioch: the following are function for Unicode Enabling\r\n function AddUnicodeString(const Value: WideString): Boolean;\r\n function AddUnicodePChar(Value: PWideChar): Boolean;\r\n function FindUnicodeString(const Value: WideString): Integer;\r\n published\r\n property DelayedWrite: Boolean read FDelayedWrite write FDelayedWrite default False;\r\n property WantUnicode: Boolean read FWantUnicode write SetWantUnicode default False;\r\n property RootKey: TJvRegKey read FKey write SetKey default hkCurrentUser;\r\n property SubKey: string read GetSubKey write SetSubKey stored False;\r\n // Arioch: it will be read from RCDATA for compatiblility, but unicode value should be stored!\r\n property SubKeyUnicode: WideString read FSubKey write SetSubKeyUnicode stored True;\r\n\r\n property MaxItems: TMruCount read FMax write SetMax default 10;\r\n property DataType: TJvDataType read FType write SetType default dtString;\r\n\r\n property OnEnumText: TOnEnumText read FOnEnumText write FOnEnumText;\r\n property OnEnumUnicodeText: TOnEnumUnicodeText read FOnEnumUnicodeText write FOnEnumUnicodeText;\r\n property OnEnumData: TOnEnumData read FOnEnumData write FOnEnumData;\r\n property Active: Boolean read GetActive write SetActive;\r\n end;\r\n\r\n EMruException = class(EJVCLException);\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvMRUList.pas $';\r\n Revision: '$Revision: 13104 $';\r\n Date: '$Date: 2011-09-07 08:50:43 +0200 (mer. 07 sept. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n Registry,\r\n JvJCLUtils, JvResources;\r\n\r\nvar\r\n hComCtlDll: HMODULE = 0;\r\n\r\nconst\r\n DllComCtlName = 'COMCTL32.DLL';\r\n\r\ntype\r\n MruCompareString = function(lpszString1, lpszString2: PAnsiChar): Integer;\r\n MruCompareData = function(lpData1, lpData2: Pointer; cbData: DWORD): Integer;\r\n MruCompareStringW = function(lpszString1, lpszString2: PWideChar): Integer;\r\n\r\n PMruRec = ^TMruRec;\r\n TMruRec = record\r\n cbSize: DWORD;\r\n nMaxItems: DWORD;\r\n dwFlags: DWORD;\r\n hKey: HKEY;\r\n case Boolean of\r\n False: (\r\n lpszSubKey: PAnsiChar;\r\n case Boolean of\r\n False:\r\n (lpfnCompareString: MruCompareString; );\r\n True:\r\n (lpfnCompareData: MruCompareData; );\r\n );\r\n True: (\r\n lpszSubKeyW: PWideChar;\r\n lpfnCompareStringW: MruCompareStringW; );\r\n end;\r\n\r\nconst\r\n MRUF_STRING_LIST = 0;\r\n MRUF_BINARY_LIST = 1;\r\n MRUF_DELAYED_SAVE = 2;\r\n\r\ntype\r\n TCreateMruList = function(lpCreateInfo: PMruRec): THandle; stdcall;\r\n TFreeMruList = procedure(hList: THandle); stdcall;\r\n\r\n TAddMruString = function(hList: THandle; lpszString: PAnsiChar): Integer; stdcall;\r\n TAddMruStringW = function(hList: THandle; lpszString: PWideChar): Integer; stdcall;\r\n TAddMruData = function(hList: THandle; lpData: Pointer; cbData: DWORD): Integer; stdcall;\r\n\r\n TDelMruString = function(hList: THandle; nItemPos: Integer): Boolean; stdcall;\r\n\r\n TEnumMruList = function(hList: THandle; nItemPos: Integer; lpBuffer: Pointer; nBufferSize: DWORD): Integer; stdcall;\r\n\r\n TFindMruString = function(hList: THandle; lpszString: PAnsiChar; lpRegNum: PInteger): Integer; stdcall;\r\n TFindMruStringW = function(hList: THandle; lpszString: PWideChar; lpRegNum: PInteger): Integer; stdcall;\r\n TFindMruData = function(hList: THandle; lpData: Pointer; cbData: DWORD; lpRegNum: PInteger): Integer; stdcall;\r\n\r\nvar\r\n CreateMruList: TCreateMruList;\r\n FreeMruList: TFreeMruList;\r\n AddMruString: TAddMruString;\r\n AddMruData: TAddMruData;\r\n DelMruString: TDelMruString;\r\n EnumMruList: TEnumMruList;\r\n FindMruString: TFindMruString;\r\n FindMruData: TFindMruData;\r\n\r\n //Arioch: Unicode functions for WinNT\r\n CreateMruListW: TCreateMruList;\r\n AddMruStringW: TAddMruStringW;\r\n FindMruStringW: TFindMruStringW;\r\n EnumMruListW: TEnumMruList;\r\n\r\nprocedure InitializeDLL; forward;\r\n\r\nconstructor TJvMruList.Create(AOwner: TComponent);\r\nbegin\r\n InitializeDLL;\r\n\r\n inherited Create(AOwner);\r\n FList := 0;\r\n FMax := 10;\r\n FType := dtString;\r\n FKey := hkCurrentUser;\r\n FUnicodeAvailable := Win32Platform = VER_PLATFORM_WIN32_NT;\r\n FDelayedWrite := False;\r\n SetWantUnicode(False);\r\n FItemData.P := nil;\r\n\r\n // ReCreateList;\r\n Close; // since there is PUBLISHED .Active property - let it control how it will be.\r\nend;\r\n\r\ndestructor TJvMruList.Destroy;\r\nbegin\r\n if FList <> 0 then\r\n FreeMruList(FList);\r\n SetItemData(Pointer(nil));\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJvMruList.AddData(Value: Pointer; Size: Integer): Boolean;\r\nbegin\r\n Result := False;\r\n if FList <> 0 then\r\n Result := AddMruData(FList, Value, Size) <> -1;\r\nend;\r\n\r\nfunction TJvMruList.AddPChar(Value: PChar): Boolean;\r\nbegin\r\n {$IFDEF SUPPORTS_UNICODE}\r\n Result := AddUnicodePChar(Value);\r\n {$ELSE}\r\n Result := AddAnsiPChar(Value);\r\n {$ENDIF SUPPORTS_UNICODE}\r\nend;\r\n\r\nfunction TJvMruList.AddAnsiPChar(Value: PAnsiChar): Boolean;\r\nbegin\r\n Result := False;\r\n if FList <> 0 then\r\n begin\r\n Result := AddMruString(FList, Value) <> -1;\r\n // (p3) call EnumText here ?\r\n // Arioch: Why? What for?\r\n // Whether You want them - make a special separate set of events\r\n // And there's danger that eventHandler tries to get a list of items,\r\n // thus, killing current section!\r\n end;\r\nend;\r\n\r\nfunction TJvMruList.AddUnicodePChar(Value: PWideChar): Boolean;\r\nbegin\r\n NeedUnicode;\r\n Result := False;\r\n if FList <> 0 then\r\n begin\r\n Result := AddMruStringW(FList, PWideChar(Value)) <> -1;\r\n // (p3) call EnumText here?\r\n // See above\r\n end;\r\nend;\r\n\r\nfunction TJvMruList.AddString(const Value: string): Boolean;\r\nbegin\r\n {$IFDEF SUPPORTS_UNICODE}\r\n Result := AddUnicodeString(Value);\r\n {$ELSE}\r\n Result := AddAnsiString(Value);\r\n {$ENDIF SUPPORTS_UNICODE}\r\nend;\r\n\r\nfunction TJvMruList.AddAnsiString(const Value: AnsiString): Boolean;\r\nbegin\r\n Result := AddAnsiPChar(PAnsiChar(Value));\r\nend;\r\n\r\nfunction TJvMruList.AddUnicodeString(const Value: WideString): Boolean;\r\nbegin\r\n Result := AddUnicodePChar(PWideChar(Value));\r\nend;\r\n\r\nfunction TJvMruList.DeleteItem(Index: Integer): Boolean;\r\nbegin\r\n Result := False;\r\n if FList <> 0 then\r\n begin\r\n Result := DelMruString(FList, Index);\r\n ReCreateList; // Arioch: fixes MS's bug\r\n end;\r\nend;\r\n\r\nfunction TJvMruList.EnumItems: Boolean;\r\nvar\r\n Index: Integer;\r\nbegin\r\n Result := False;\r\n if FList = 0 then\r\n Exit;\r\n\r\n Index := 0;\r\n while GetItem(Index) do\r\n Inc(Index);\r\n if Index > 0 then\r\n Result := True;\r\nend;\r\n\r\nfunction TJvMruList.FindData(Value: Pointer; Size: Integer): Integer;\r\nbegin\r\n Result := -1;\r\n if FList <> 0 then\r\n Result := FindMruData(FList, Value, Size, nil);\r\nend;\r\n\r\nfunction TJvMruList.FindString(const Value: string): Integer;\r\nbegin\r\n {$IFDEF SUPPORTS_UNICODE}\r\n Result := FindUnicodeString(Value);\r\n {$ELSE}\r\n Result := FindAnsiString(Value);\r\n {$ENDIF SUPPORTS_UNICODE}\r\nend;\r\n\r\nfunction TJvMruList.FindAnsiString(const Value: AnsiString): Integer;\r\nbegin\r\n Result := -1;\r\n if FList <> 0 then\r\n Result := FindMruString(FList, PAnsiChar(Value), nil);\r\nend;\r\n\r\nfunction TJvMruList.FindUnicodeString(const Value: WideString): Integer;\r\nbegin\r\n NeedUnicode;\r\n Result := -1;\r\n if FList <> 0 then\r\n Result := FindMruStringW(FList, PWideChar(Value), nil);\r\nend;\r\n\r\nfunction TJvMruList.GetItem(Index: Integer): Boolean;\r\nbegin\r\n Result := InternalGetItem(Index);\r\nend;\r\n\r\nfunction TJvMruList.InternalGetItem(Index: Integer; FireEvent: Boolean): Boolean;\r\nvar\r\n I: Integer;\r\n P: Pointer;\r\n EnP: TEnumMruList;\r\n CanFree: Boolean;\r\nbegin\r\n Result := False;\r\n if FList = 0 then\r\n Exit;\r\n P := nil;\r\n CanFree := True;\r\n\r\n try\r\n if FType = dtString then\r\n begin\r\n if not UseUnicode then\r\n begin\r\n ReAllocMem(P, 256);\r\n I := EnumMruList(FList, Index, P, 256);\r\n if I > 255 then\r\n begin\r\n ReAllocMem(P, I + 1);\r\n I := EnumMruList(FList, Index, P, I + 1);\r\n end;\r\n if I <> -1 then\r\n begin\r\n Result := True;\r\n SetItemData(P);\r\n CanFree := False;\r\n FItemIndex := Index;\r\n if FireEvent then\r\n DoEnumText\r\n end;\r\n end\r\n else\r\n begin // Unicode\r\n ReAllocMem(P, 512);\r\n I := EnumMruListW(FList, Index, P, 256);\r\n if I > 255 then\r\n begin\r\n ReAllocMem(P, (I + 1) * 2);\r\n I := EnumMruListW(FList, Index, P, I + 1);\r\n end;\r\n if I <> -1 then\r\n begin\r\n Result := True;\r\n SetItemData(P);\r\n CanFree := False;\r\n FItemIndex := Index;\r\n if FireEvent then\r\n DoUnicodeEnumText;\r\n end;\r\n end\r\n end\r\n else // FType = dtBinary\r\n begin\r\n ReAllocMem(P, 1024);\r\n\r\n if UnicodeAvailable then\r\n EnP := EnumMruListW\r\n else\r\n EnP := EnumMruList;\r\n //Arioch: work-around MS bug\r\n\r\n I := EnP(FList, Index, P, 1024);\r\n\r\n if I >= 1024 then\r\n begin\r\n ReAllocMem(P, 64000); // Arioch: Hmmm We'll never guess how much may there appear :)\r\n I := EnP(FList, 0, P, 64000);\r\n end;\r\n\r\n if I <> -1 then\r\n begin\r\n Result := True;\r\n ReAllocMem(P, I);\r\n // Arioch: should we waste more memory than we need?\r\n // and we can know the size of memory allocated\r\n // with GetMem and ReAllocMem, so we know how big Data was\r\n SetItemData(P);\r\n CanFree := False;\r\n FItemIndex := Index;\r\n if FireEvent then\r\n DoEnumData(I);\r\n end;\r\n end;\r\n finally\r\n // Free the memory\r\n if Assigned(P) and CanFree then\r\n FreeMem(P);\r\n end;\r\nend;\r\n\r\nfunction TJvMruList.GetItemsCount: Integer;\r\nbegin\r\n if FList <> 0 then\r\n Result := EnumMruList(FList, -1, nil, 0)\r\n else\r\n Result := 0;\r\nend;\r\n\r\nfunction TJvMruList.GetMostRecentItem: Boolean;\r\nbegin\r\n Result := GetItem(0);\r\nend;\r\n\r\nfunction TJvMruList.GetSubKey: string;\r\nbegin\r\n Result := string(FSubKey);\r\nend;\r\n\r\nprocedure TJvMruList.MoveToTop(const Index: Integer);\r\nvar\r\n B: Boolean;\r\nbegin\r\n B := False;\r\n if InternalGetItem(Index, False) then\r\n begin\r\n if FType = dtString then\r\n begin\r\n if UseUnicode then\r\n B := AddUnicodePChar(ItemDataAsPWideChar)\r\n else\r\n B := AddAnsiPChar(ItemDataAsPAnsiChar);\r\n end\r\n else\r\n B := AddData(ItemDataAsPointer, ItemDataSize);\r\n end;\r\n if B then\r\n FItemIndex := 0;\r\nend;\r\n\r\nprocedure TJvMruList.NeedUnicode;\r\nbegin\r\n if not UnicodeAvailable then\r\n raise EMruException.CreateRes(@RsEErrorMruUnicode);\r\nend;\r\n\r\nprocedure TJvMruList.ReCreateList;\r\nbegin\r\n Close;\r\n Open;\r\nend;\r\n\r\nprocedure TJvMruList.SetItemData(const P: Pointer);\r\nbegin\r\n if P = FItemData.P then\r\n Exit;\r\n if FItemData.P <> nil then\r\n FreeMem(FItemData.P);\r\n FItemData.P := P;\r\nend;\r\n\r\nprocedure TJvMruList.SetKey(const Value: TJvRegKey);\r\nbegin\r\n if Value <> FKey then\r\n begin\r\n FKey := Value;\r\n ReCreateList;\r\n end;\r\nend;\r\n\r\nprocedure TJvMruList.SetMax(const Value: TMruCount);\r\nbegin\r\n if Value <> FMax then\r\n begin\r\n FMax := Value;\r\n ReCreateList;\r\n end;\r\nend;\r\n\r\nprocedure TJvMruList.SetSubKey(const Value: string);\r\nbegin\r\n SetSubKeyUnicode(WideString(Value));\r\nend;\r\n\r\nprocedure TJvMruList.SetSubKeyUnicode(const Value: WideString);\r\nbegin\r\n if Value <> FSubKey then\r\n begin\r\n FSubKey := Value;\r\n ReCreateList;\r\n end;\r\nend;\r\n\r\nprocedure TJvMruList.SetType(const Value: TJvDataType);\r\nbegin\r\n if Value <> FType then\r\n begin\r\n FType := Value;\r\n ReCreateList;\r\n end;\r\nend;\r\n\r\nprocedure TJvMruList.SetUseUnicode(const Value: Boolean);\r\nbegin\r\n if Value then\r\n NeedUnicode;\r\n if FUseUnicode = Value then\r\n Exit;\r\n FUseUnicode := Value;\r\nend;\r\n\r\nprocedure TJvMruList.SetWantUnicode(const Value: Boolean);\r\nbegin\r\n if FWantUnicode = Value then\r\n Exit;\r\n\r\n FWantUnicode := Value;\r\n FUseUnicode := FWantUnicode and FUnicodeAvailable;\r\nend;\r\n\r\nprocedure TJvMruList.Close;\r\nbegin\r\n if FList <> 0 then\r\n begin\r\n FreeMruList(FList);\r\n FList := 0;\r\n end;\r\n\r\n FItemIndex := -1;\r\n SetItemData(Pointer(nil));\r\nend;\r\n\r\nprocedure TJvMruList.Open;\r\nvar\r\n FLst: TMruRec;\r\nbegin\r\n if csDesigning in ComponentState then\r\n Exit;\r\n\r\n if FSubKey <> '' then\r\n begin\r\n FLst.cbSize := SizeOf(FList);\r\n FLst.nMaxItems := FMax;\r\n case FType of\r\n dtString:\r\n begin\r\n FLst.dwFlags := MRUF_STRING_LIST;\r\n FLst.lpfnCompareString := nil;\r\n end;\r\n dtBinary:\r\n begin\r\n FLst.dwFlags := MRUF_BINARY_LIST;\r\n FLst.lpfnCompareData := nil;\r\n end;\r\n end;\r\n if FDelayedWrite then\r\n with FLst do\r\n dwFlags := MRUF_DELAYED_SAVE or dwFlags;\r\n case FKey of\r\n hkClassesRoot:\r\n FLst.hKey := HKEY_CLASSES_ROOT;\r\n hkCurrentUser:\r\n FLst.hKey := HKEY_CURRENT_USER;\r\n hkLocalMachine:\r\n FLst.hKey := HKEY_LOCAL_MACHINE;\r\n hkUsers:\r\n FLst.hKey := HKEY_USERS;\r\n hkCurrentConfig:\r\n FLst.hKey := HKEY_CURRENT_CONFIG;\r\n end;\r\n if UseUnicode then\r\n // Arioch changed this\r\n FLst.lpszSubKeyW := PWideChar(FSubKey)\r\n else\r\n FLst.lpszSubKey := PAnsiChar(AnsiString(GetSubKey)); // might lose values here, but easy to avoid by setting \"UseUnicode\" to True\r\n\r\n if UseUnicode then\r\n // Arioch changed this\r\n FList := CreateMruListW(@FLst)\r\n else\r\n FList := CreateMruList(@FLst);\r\n\r\n if FList = 0 then\r\n raise EMruException.CreateRes(@RsEErrorMruCreating);\r\n end;\r\nend;\r\n\r\nfunction TJvMruList.ItemDataSize: Integer;\r\n// Arioch: Here we rely on undocumented internal structure\r\n// that has been used by GetMem/FreeMem for ages!\r\n// for example see sources for GetMem.Inc in VCL sources\r\n//\r\n// JVCL should have a list were it relies upon undocumented parts of Delphi,\r\n// Windows, etc..., so when new version of D,Win,... is released we could\r\n// check the list instead of hunting for misty bug;\r\nbegin\r\n if ItemDataAsPointer <> nil then\r\n Result := Integer(Pointer(PAnsiChar(ItemDataAsPointer) - SizeOf(Integer))^)\r\n else\r\n Result := 0;\r\nend;\r\n\r\nprocedure TJvMruList.DoEnumText;\r\nbegin\r\n if Assigned(FOnEnumText) then\r\n FOnEnumText(Self, string(FItemData.S), ItemIndex);\r\n// FOnEnumText(Self, S, Index);\r\nend;\r\n\r\nprocedure TJvMruList.DoUnicodeEnumText;\r\nbegin\r\n if Assigned(FOnEnumUnicodeText) then\r\n FOnEnumUnicodeText(Self, WideString(FItemData.Ws), FItemIndex);\r\n// FOnEnumUnicodeText(Self, S, Index);\r\nend;\r\n\r\nprocedure TJvMruList.DoEnumData(DataSize: Integer);\r\nbegin\r\n if Assigned(FOnEnumData) then\r\n FOnEnumData(Self, FItemData.P, DataSize, FItemIndex);\r\nend;\r\n\r\nfunction TJvMruList.DeleteKey: Boolean;\r\nbegin\r\n Result := False;\r\n with TRegistry.Create do\r\n try\r\n if (FList = 0) and (SubKey <> '') and KeyExists(SubKey) then\r\n Result := DeleteKey(SubKey);\r\n finally\r\n Free;\r\n end;\r\nend;\r\n\r\nfunction TJvMruList.GetActive: Boolean;\r\nbegin\r\n Result := FList <> 0;\r\nend;\r\n\r\nprocedure TJvMruList.SetActive(const Value: Boolean);\r\nbegin\r\n if GetActive <> Value then\r\n begin\r\n if Value then\r\n Open\r\n else\r\n Close;\r\n end;\r\nend;\r\n\r\nfunction TJvMruList.GetItemDataAsPChar: PChar;\r\nbegin\r\n {$IFDEF SUPPORTS_UNICODE}\r\n Result := FItemData.Ws;\r\n {$ELSE}\r\n Result := FItemData.S;\r\n {$ENDIF SUPPORTS_UNICODE}\r\nend;\r\n\r\nfunction TJvMruList.GetItemDataAsPAnsiChar: PAnsiChar;\r\nbegin\r\n Result := FItemData.S;\r\nend;\r\n\r\nfunction TJvMruList.GetItemDataAsPWideChar: PWideChar;\r\nbegin\r\n Result := FItemData.Ws;\r\nend;\r\n\r\nprocedure FinalizeDLL;\r\nbegin\r\n if hComCtlDll > 0 then\r\n begin\r\n FreeLibrary(hComCtlDll);\r\n hComCtlDll := 0;\r\n end;\r\nend;\r\n\r\nprocedure InitializeDLL;\r\nbegin\r\n if hComCtlDll = 0 then\r\n begin\r\n hComCtlDll := SafeLoadLibrary(DllComCtlName);\r\n if hComCtlDll <> 0 then\r\n begin\r\n // (rom) can we get them by name?\r\n CreateMruList := GetProcAddress(hComCtlDll, PChar(151));\r\n FreeMruList := GetProcAddress(hComCtlDll, PChar(152));\r\n AddMruString := GetProcAddress(hComCtlDll, PChar(153));\r\n AddMruData := GetProcAddress(hComCtlDll, PChar(167));\r\n DelMruString := GetProcAddress(hComCtlDll, PChar(156));\r\n EnumMruList := GetProcAddress(hComCtlDll, PChar(154));\r\n FindMruString := GetProcAddress(hComCtlDll, PChar(155));\r\n FindMruData := GetProcAddress(hComCtlDll, PChar(169));\r\n\r\n if Win32Platform = VER_PLATFORM_WIN32_NT then\r\n begin\r\n CreateMruListW := GetProcAddress(hComCtlDll, PChar(400));\r\n AddMruStringW := GetProcAddress(hComCtlDll, PChar(401));\r\n FindMruStringW := GetProcAddress(hComCtlDll, PChar(402));\r\n EnumMruListW := GetProcAddress(hComCtlDll, PChar(403));\r\n end;\r\n end\r\n else\r\n RaiseLastOSError;\r\n end;\r\nend;\r\n\r\ninitialization\r\n {$IFDEF UNITVERSIONING}\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n {$ENDIF UNITVERSIONING}\r\n\r\nfinalization\r\n FinalizeDLL;\r\n {$IFDEF UNITVERSIONING}\r\n UnregisterUnitVersion(HInstance);\r\n {$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvMRUManager.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvMRUList.PAS, released on 2002-07-04.\r\n\r\nThe Initial Developers of the Original Code are: Fedor Koshevnikov, Igor Pavluk and Serge Korolev\r\nCopyright (c) 1997, 1998 Fedor Koshevnikov, Igor Pavluk and Serge Korolev\r\nCopyright (c) 2001,2002 SGB Software\r\nAll Rights Reserved.\r\n\r\nContributors:\r\nMichael Fritz (MenuLocation)\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n* Using a divider as RecentMenu when MenuLocation = mruChild doesn't work\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvMRUManager.pas 13104 2011-09-07 06:50:43Z obones $\r\n\r\nunit JvMRUManager;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n SysUtils, Classes,\r\n Windows, Menus, Graphics, Controls, Forms,\r\n JvFormPlacement, JvAppStorage, JvComponentBase;\r\n\r\ntype\r\n TJvRecentStrings = class;\r\n\r\n TGetItemEvent = procedure(Sender: TObject; var Caption: string;\r\n var ShortCut: TShortCut; UserData: Longint) of object;\r\n TReadItemEvent = procedure(Sender: TObject; AppStorage: TJvCustomAppStorage;\r\n const Path: string; Index: Integer; var RecentName: string;\r\n var UserData: Longint) of object;\r\n TWriteItemEvent = procedure(Sender: TObject; AppStorage: TJvCustomAppStorage;\r\n const Path: string; Index: Integer; const RecentName: string;\r\n UserData: Longint) of object;\r\n TClickMenuEvent = procedure(Sender: TObject; const RecentName,\r\n Caption: string; UserData: Longint) of object;\r\n TGetItemInfoEvent = procedure(Sender: TObject; Item: TMenuItem) of object;\r\n TGetItemInfoExEvent = procedure(Sender: TObject; Item: TMenuItem; Index: Integer) of object;\r\n\r\n TAccelDelimiter = (adTab, adSpace);\r\n TRecentMode = (rmInsert, rmAppend);\r\n TMenuLocation = (mruChild, mruSibling);\r\n\r\n TJvRecentStrings = class(TStringList)\r\n private\r\n FMaxSize: Integer;\r\n FMode: TRecentMode;\r\n procedure SetMaxSize(Value: Integer);\r\n protected\r\n procedure SetTextStr(const Value: String); override;\r\n public\r\n constructor Create;\r\n function Add(const S: string): Integer; override;\r\n procedure AddStrings(Strings: TStrings); override;\r\n procedure DeleteExceed;\r\n procedure Remove(const S: string);\r\n property MaxSize: Integer read FMaxSize write SetMaxSize;\r\n property Mode: TRecentMode read FMode write FMode;\r\n end;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvMRUManager = class(TJvComponent)\r\n private\r\n FStrings: TJvRecentStrings;\r\n FItems: TList;\r\n FIniLink: TJvIniLink;\r\n FSeparateSize: Word;\r\n FAutoEnable: Boolean;\r\n FAutoUpdate: Boolean;\r\n FShowAccelChar: Boolean;\r\n FRemoveOnSelect: Boolean;\r\n FStartAccel: Cardinal;\r\n FAccelDelimiter: TAccelDelimiter;\r\n FRecentMenu: TMenuItem;\r\n FOnChange: TNotifyEvent;\r\n FOnGetItem: TGetItemEvent;\r\n FOnClick: TClickMenuEvent;\r\n FOnReadItem: TReadItemEvent;\r\n FOnWriteItem: TWriteItemEvent;\r\n FOnAfterUpdate: TNotifyEvent;\r\n FOnBeforeUpdate: TNotifyEvent;\r\n FOnItemInfo: TGetItemInfoEvent;\r\n FOnItemInfoEx: TGetItemInfoExEvent;\r\n FDuplicates: TDuplicates;\r\n FMenuLocation: TMenuLocation;\r\n FMaxLength: Integer;\r\n FCanvas: TCanvas;\r\n FStartEllipsis: Boolean;\r\n procedure ListChanged(Sender: TObject);\r\n procedure ClearRecentMenu;\r\n procedure SetRecentMenu(Value: TMenuItem);\r\n procedure SetSeparateSize(Value: Word);\r\n function GetStorage: TJvFormPlacement;\r\n procedure SetStorage(Value: TJvFormPlacement);\r\n function GetCapacity: Integer;\r\n procedure SetCapacity(Value: Integer);\r\n function GetMode: TRecentMode;\r\n procedure SetMode(Value: TRecentMode);\r\n procedure SetStartAccel(Value: Cardinal);\r\n procedure SetShowAccelChar(Value: Boolean);\r\n procedure SetAccelDelimiter(Value: TAccelDelimiter);\r\n procedure SetAutoEnable(Value: Boolean);\r\n procedure AddMenuItem(Item: TMenuItem);\r\n procedure MenuItemClick(Sender: TObject);\r\n procedure IniSave(Sender: TObject);\r\n procedure IniLoad(Sender: TObject);\r\n procedure InternalLoad(const Section: string);\r\n procedure InternalSave(const Section: string);\r\n procedure SetDuplicates(const Value: TDuplicates);\r\n procedure DoDuplicateFixUp;\r\n function GetStrings: TStrings;\r\n procedure SetMenuLocation(const Value: TMenuLocation);\r\n procedure SetMaxLength(const Value: Integer);\r\n procedure SetStartEllipsis(const Value: Boolean);\r\n protected\r\n function GetCanvas: TCanvas;\r\n function DoMinimizeName(const S: string): string;\r\n procedure Change; dynamic;\r\n procedure Notification(AComponent: TComponent; Operation: TOperation); override;\r\n procedure DoReadItem(AppStorage: TJvCustomAppStorage; const Path: string; Index: Integer; var RecentName: string; var\r\n UserData: Longint); dynamic;\r\n procedure DoWriteItem(AppStorage: TJvCustomAppStorage; const Path: string; Index: Integer; const RecentName: string;\r\n UserData: Longint); dynamic;\r\n procedure GetItemData(var Caption: string; var ShortCut: TShortCut; UserData: Longint); dynamic;\r\n procedure GetItemInfo(Item: TMenuItem); dynamic;\r\n procedure GetItemInfoEx(Item: TMenuItem; Index: Integer); dynamic;\r\n procedure DoClick(const RecentName, Caption: string; UserData: Longint); dynamic;\r\n procedure DoBeforeUpdate; virtual;\r\n procedure DoAfterUpdate; virtual;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n procedure Add(const RecentName: string; UserData: Longint);\r\n procedure Clear;\r\n procedure Remove(const RecentName: string);\r\n procedure UpdateRecentMenu;\r\n procedure RemoveInvalid;\r\n procedure LoadFromAppStorage(const AppStorage: TJvCustomAppStorage; const Path: string);\r\n procedure SaveToAppStorage(const AppStorage: TJvCustomAppStorage; const Path: string);\r\n procedure Load;\r\n procedure Save;\r\n function IsMenuEnabled: Boolean;\r\n property Strings: TStrings read GetStrings;\r\n published\r\n // Duplicates works just as for TStrings, but the list doesn't need to be sorted\r\n property Duplicates: TDuplicates read FDuplicates write SetDuplicates;\r\n property AccelDelimiter: TAccelDelimiter read FAccelDelimiter write SetAccelDelimiter default adTab;\r\n property AutoEnable: Boolean read FAutoEnable write SetAutoEnable default True;\r\n property AutoUpdate: Boolean read FAutoUpdate write FAutoUpdate default True;\r\n property MaxLength: Integer read FMaxLength write SetMaxLength default 0;\r\n property StartEllipsis: Boolean read FStartEllipsis write SetStartEllipsis default False;\r\n property Capacity: Integer read GetCapacity write SetCapacity default 10;\r\n property MenuLocation: TMenuLocation read FMenuLocation write SetMenuLocation default mruChild;\r\n property Mode: TRecentMode read GetMode write SetMode default rmInsert;\r\n property RemoveOnSelect: Boolean read FRemoveOnSelect write FRemoveOnSelect default False;\r\n property IniStorage: TJvFormPlacement read GetStorage write SetStorage;\r\n property SeparateSize: Word read FSeparateSize write SetSeparateSize default 0;\r\n property RecentMenu: TMenuItem read FRecentMenu write SetRecentMenu;\r\n property ShowAccelChar: Boolean read FShowAccelChar write SetShowAccelChar default True;\r\n property StartAccel: Cardinal read FStartAccel write SetStartAccel default 1;\r\n property OnChange: TNotifyEvent read FOnChange write FOnChange;\r\n property OnClick: TClickMenuEvent read FOnClick write FOnClick;\r\n // OnGetItemData is called just before the menu item is created\r\n property OnGetItemData: TGetItemEvent read FOnGetItem write FOnGetItem;\r\n property OnReadItem: TReadItemEvent read FOnReadItem write FOnReadItem;\r\n property OnWriteItem: TWriteItemEvent read FOnWriteItem write FOnWriteItem;\r\n // called just before the menu items are updated\r\n property OnBeforeUpdate: TNotifyEvent read FOnBeforeUpdate write FOnBeforeUpdate;\r\n // called just after the menu items have been updated\r\n property OnAfterUpdate: TNotifyEvent read FOnAfterUpdate write FOnAfterUpdate;\r\n // called just before the newly created menu item is added to the RecentMenu submenu\r\n // this makes it easier to set any additional properties of the menu item not\r\n // handled by OnGetItemData.\r\n property OnGetItemInfo: TGetItemInfoEvent read FOnItemInfo write FOnItemInfo;\r\n property OnGetItemInfoEx: TGetItemInfoExEvent read FOnItemInfoEx write FOnItemInfoEx;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvMRUManager.pas $';\r\n Revision: '$Revision: 13104 $';\r\n Date: '$Date: 2011-09-07 08:50:43 +0200 (mer. 07 sept. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n Math,\r\n JclFileUtils,\r\n JvJVCLUtils, JvConsts, JvResources, JvTypes;\r\n\r\nconst\r\n siRecentItem = 'Item_%d';\r\n siRecentData = 'User_%d';\r\n\r\n//=== { TJvMRUManager } ======================================================\r\n\r\nconstructor TJvMRUManager.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FStrings := TJvRecentStrings.Create;\r\n FItems := TList.Create;\r\n FStrings.OnChange := ListChanged;\r\n FIniLink := TJvIniLink.Create;\r\n FIniLink.OnSave := IniSave;\r\n FIniLink.OnLoad := IniLoad;\r\n FAutoUpdate := True;\r\n FAutoEnable := True;\r\n FShowAccelChar := True;\r\n FStartAccel := 1;\r\n FMenuLocation := mruChild;\r\nend;\r\n\r\ndestructor TJvMRUManager.Destroy;\r\nbegin\r\n ClearRecentMenu;\r\n FIniLink.Free;\r\n FStrings.OnChange := nil;\r\n FStrings.Free;\r\n FreeAndNil(FItems);\r\n FreeAndNil(FCanvas);\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvMRUManager.Notification(AComponent: TComponent; Operation: TOperation);\r\nbegin\r\n inherited Notification(AComponent, Operation);\r\n if (AComponent = RecentMenu) and (Operation = opRemove) then\r\n RecentMenu := nil;\r\nend;\r\n\r\nfunction TJvMRUManager.GetStrings: TStrings;\r\nbegin\r\n Result := FStrings;\r\nend;\r\n\r\nprocedure TJvMRUManager.GetItemData(var Caption: string; var ShortCut: TShortCut; UserData: Longint);\r\nbegin\r\n if Assigned(FOnGetItem) then\r\n FOnGetItem(Self, Caption, ShortCut, UserData);\r\nend;\r\n\r\nprocedure TJvMRUManager.DoClick(const RecentName, Caption: string; UserData: Longint);\r\nbegin\r\n if Assigned(FOnClick) then\r\n FOnClick(Self, RecentName, Caption, UserData);\r\nend;\r\n\r\nprocedure TJvMRUManager.MenuItemClick(Sender: TObject);\r\nvar\r\n I: Integer;\r\nbegin\r\n if Sender is TMenuItem then\r\n begin\r\n I := TMenuItem(Sender).Tag;\r\n if (I >= 0) and (I < Strings.Count) then\r\n try\r\n DoClick(Strings[I], TMenuItem(Sender).Caption, Longint(Strings.Objects[I]));\r\n finally\r\n if RemoveOnSelect then\r\n Remove(Strings[I]);\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJvMRUManager.GetCapacity: Integer;\r\nbegin\r\n Result := FStrings.MaxSize;\r\nend;\r\n\r\nprocedure TJvMRUManager.SetCapacity(Value: Integer);\r\nbegin\r\n FStrings.MaxSize := Value;\r\nend;\r\n\r\nfunction TJvMRUManager.GetMode: TRecentMode;\r\nbegin\r\n Result := FStrings.Mode;\r\nend;\r\n\r\nprocedure TJvMRUManager.SetMode(Value: TRecentMode);\r\nbegin\r\n FStrings.Mode := Value;\r\nend;\r\n\r\nfunction TJvMRUManager.GetStorage: TJvFormPlacement;\r\nbegin\r\n Result := FIniLink.Storage;\r\nend;\r\n\r\nprocedure TJvMRUManager.SetStorage(Value: TJvFormPlacement);\r\nbegin\r\n FIniLink.Storage := Value;\r\nend;\r\n\r\nprocedure TJvMRUManager.SetAutoEnable(Value: Boolean);\r\nbegin\r\n if FAutoEnable <> Value then\r\n begin\r\n FAutoEnable := Value;\r\n if Assigned(FRecentMenu) then\r\n begin\r\n if FAutoEnable then\r\n FRecentMenu.Enabled := IsMenuEnabled\r\n else\r\n FRecentMenu.Enabled := True;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvMRUManager.SetStartAccel(Value: Cardinal);\r\nbegin\r\n if FStartAccel <> Value then\r\n begin\r\n FStartAccel := Value;\r\n if FAutoUpdate then\r\n UpdateRecentMenu;\r\n end;\r\nend;\r\n\r\nprocedure TJvMRUManager.SetAccelDelimiter(Value: TAccelDelimiter);\r\nbegin\r\n if FAccelDelimiter <> Value then\r\n begin\r\n FAccelDelimiter := Value;\r\n if FAutoUpdate and ShowAccelChar then\r\n UpdateRecentMenu;\r\n end;\r\nend;\r\n\r\nprocedure TJvMRUManager.SetShowAccelChar(Value: Boolean);\r\nbegin\r\n if FShowAccelChar <> Value then\r\n begin\r\n FShowAccelChar := Value;\r\n if FAutoUpdate then\r\n UpdateRecentMenu;\r\n end;\r\nend;\r\n\r\nprocedure TJvMRUManager.Add(const RecentName: string; UserData: Longint);\r\nvar\r\n I: Integer;\r\nbegin\r\n if not (Duplicates = dupAccept) and (Strings.IndexOf(RecentName) > -1) then\r\n begin\r\n if Duplicates = dupError then\r\n raise EJVCLException.CreateRes(@RsEDuplicatesNotAllowedInMRUList);\r\n end\r\n else\r\n begin\r\n I := FStrings.Add(RecentName);\r\n Strings.Objects[I] := TObject(UserData);\r\n end;\r\nend;\r\n\r\nprocedure TJvMRUManager.Clear;\r\nbegin\r\n Strings.Clear;\r\nend;\r\n\r\nprocedure TJvMRUManager.Remove(const RecentName: string);\r\nbegin\r\n FStrings.Remove(RecentName);\r\nend;\r\n\r\nprocedure TJvMRUManager.AddMenuItem(Item: TMenuItem);\r\nbegin\r\n if Assigned(Item) then\r\n begin\r\n if FMenuLocation = mruSibling then\r\n begin\r\n if FRecentMenu.HasParent and (FRecentMenu.Parent.MenuIndex >= 0) then\r\n FRecentMenu.Parent.Insert(FRecentMenu.MenuIndex + FItems.Count + 1, Item)\r\n else\r\n FRecentMenu.Add(Item);\r\n end\r\n else\r\n FRecentMenu.Add(Item);\r\n FItems.Add(Item);\r\n end;\r\nend;\r\n\r\nprocedure TJvMRUManager.DoDuplicateFixUp;\r\nvar\r\n I, J: Integer;\r\n Tmp: Boolean;\r\nbegin\r\n if Duplicates = dupAccept then\r\n Exit;\r\n Tmp := AutoUpdate;\r\n try\r\n AutoUpdate := False;\r\n I := Strings.Count - 1;\r\n while I >= 0 do\r\n begin\r\n // we don't raise an error here even if Duplicates is dupError\r\n J := Strings.IndexOf(Strings[I]);\r\n while (J > -1) and (J <> I) do\r\n begin\r\n Strings.Delete(J);\r\n Dec(I);\r\n J := Strings.IndexOf(Strings[I]);\r\n end;\r\n Dec(I);\r\n end;\r\n finally\r\n AutoUpdate := Tmp;\r\n end;\r\nend;\r\n\r\nprocedure TJvMRUManager.UpdateRecentMenu;\r\nconst\r\n AccelDelimChars: array[TAccelDelimiter] of Char = (Tab, ' ');\r\nvar\r\n I: Integer;\r\n L: Cardinal;\r\n S: string;\r\n C: string{$IFNDEF RTL200_UP}[2]{$ENDIF ~RTL200_UP};\r\n ShortCut: TShortCut;\r\n Item: TMenuItem;\r\nbegin\r\n ClearRecentMenu;\r\n DoDuplicateFixUp;\r\n DoBeforeUpdate;\r\n if Assigned(FRecentMenu) then\r\n begin\r\n if ((Strings.Count > 0) and (FRecentMenu.Count > 0) and (MenuLocation = mruChild)) then\r\n AddMenuItem(NewLine);\r\n for I := 0 to Strings.Count - 1 do\r\n begin\r\n if (FSeparateSize > 0) and (I > 0) and (I mod FSeparateSize = 0) then\r\n AddMenuItem(NewLine)\r\n else\r\n if (I = 0) and (MenuLocation = mruSibling) and (FRecentMenu.Count = 0) then\r\n AddMenuItem(NewLine);\r\n S := Strings[I];\r\n ShortCut := scNone;\r\n GetItemData(S, ShortCut, Longint(Strings.Objects[I]));\r\n Item := NewItem(GetShortHint(S), ShortCut, False, True,\r\n MenuItemClick, 0, '');\r\n Item.Hint := GetLongHint(S);\r\n if FShowAccelChar then\r\n begin\r\n L := Cardinal(I) + FStartAccel;\r\n if L < 10 then\r\n C := '&' + Char(Ord('0') + L)\r\n else\r\n if L <= (Ord('Z') + 10) then\r\n C := '&' + Char(L + Ord('A') - 10)\r\n else\r\n C := ' ';\r\n Item.Caption := C + AccelDelimChars[FAccelDelimiter] + DoMinimizeName(S);\r\n end\r\n else\r\n begin\r\n Item.Caption := DoMinimizeName(S);\r\n end;\r\n Item.Tag := I;\r\n AddMenuItem(Item);\r\n GetItemInfoEx(Item, I);\r\n end;\r\n DoAfterUpdate;\r\n if AutoEnable then\r\n FRecentMenu.Enabled := IsMenuEnabled;\r\n end;\r\nend;\r\n\r\nprocedure TJvMRUManager.ClearRecentMenu;\r\nvar\r\n Item: TMenuItem;\r\nbegin\r\n while FItems.Count > 0 do\r\n begin\r\n Item := TMenuItem(FItems[0]);\r\n FItems.Remove(Item);\r\n // (p3) it doesn't matter if the item is in FRecentMenu or not - it still needs to be freed\r\n // this also avoids duplicates when MenuLocation = mruSibling\r\n// if Assigned(FRecentMenu) and (FRecentMenu.IndexOf(Item) >= 0) then\r\n Item.Free;\r\n end;\r\n if Assigned(FRecentMenu) and AutoEnable then\r\n FRecentMenu.Enabled := IsMenuEnabled;\r\nend;\r\n\r\nprocedure TJvMRUManager.SetRecentMenu(Value: TMenuItem);\r\nbegin\r\n ClearRecentMenu;\r\n ReplaceComponentReference(Self, Value, TComponent(FRecentMenu));\r\n FreeAndNil(FCanvas);\r\n UpdateRecentMenu;\r\nend;\r\n\r\nprocedure TJvMRUManager.SetSeparateSize(Value: Word);\r\nbegin\r\n if FSeparateSize <> Value then\r\n begin\r\n FSeparateSize := Value;\r\n if FAutoUpdate then\r\n UpdateRecentMenu;\r\n end;\r\nend;\r\n\r\nprocedure TJvMRUManager.ListChanged(Sender: TObject);\r\nbegin\r\n Change;\r\n if FAutoUpdate then\r\n UpdateRecentMenu;\r\nend;\r\n\r\nprocedure TJvMRUManager.IniSave(Sender: TObject);\r\nbegin\r\n if (Name <> '') and Assigned(IniStorage) then\r\n InternalSave(GetDefaultSection(Self));\r\nend;\r\n\r\nprocedure TJvMRUManager.IniLoad(Sender: TObject);\r\nbegin\r\n if (Name <> '') and Assigned(IniStorage) then\r\n InternalLoad(GetDefaultSection(Self));\r\nend;\r\n\r\nprocedure TJvMRUManager.Change;\r\nbegin\r\n if Assigned(FOnChange) then\r\n FOnChange(Self);\r\nend;\r\n\r\nprocedure TJvMRUManager.DoReadItem(AppStorage: TJvCustomAppStorage; const Path: string; Index: Integer; var RecentName:\r\n string; var UserData: Longint);\r\nbegin\r\n if Assigned(FOnReadItem) then\r\n FOnReadItem(Self, AppStorage, Path, Index, RecentName, UserData)\r\n else\r\n begin\r\n RecentName := AppStorage.ReadString(AppStorage.ConcatPaths(\r\n [Path, Format(siRecentItem, [Index])]), RecentName);\r\n UserData := AppStorage.ReadInteger(AppStorage.ConcatPaths(\r\n [Path, Format(siRecentData, [Index])]), UserData);\r\n end;\r\nend;\r\n\r\nprocedure TJvMRUManager.DoWriteItem(AppStorage: TJvCustomAppStorage; const Path: string; Index: Integer; const\r\n RecentName: string; UserData: Longint);\r\nbegin\r\n if Assigned(FOnWriteItem) then\r\n FOnWriteItem(Self, AppStorage, Path, Index, RecentName, UserData)\r\n else\r\n begin\r\n AppStorage.WriteString(AppStorage.ConcatPaths(\r\n [Path, Format(siRecentItem, [Index])]), RecentName);\r\n if UserData = 0 then\r\n AppStorage.DeleteValue(AppStorage.ConcatPaths(\r\n [Path, Format(siRecentData, [Index])]))\r\n else\r\n AppStorage.WriteInteger(AppStorage.ConcatPaths(\r\n [Path, Format(siRecentData, [Index])]), UserData);\r\n end;\r\nend;\r\n\r\nprocedure TJvMRUManager.InternalLoad(const Section: string);\r\nbegin\r\n if Assigned(IniStorage) then\r\n LoadFromAppStorage(IniStorage.AppStorage, IniStorage.AppStorage.ConcatPaths([IniStorage.AppStoragePath, Section]));\r\nend;\r\n\r\nprocedure TJvMRUManager.InternalSave(const Section: string);\r\nbegin\r\n if Assigned(IniStorage) then\r\n SaveToAppStorage(IniStorage.AppStorage, IniStorage.AppStorage.ConcatPaths([IniStorage.AppStoragePath, Section]));\r\nend;\r\n\r\nprocedure TJvMRUManager.LoadFromAppStorage(const AppStorage: TJvCustomAppStorage; const Path: string);\r\nvar\r\n I: Integer;\r\n S: string;\r\n UserData: Longint;\r\n AMode: TRecentMode;\r\nbegin\r\n AMode := Mode;\r\n Strings.BeginUpdate;\r\n AppStorage.BeginUpdate;\r\n try\r\n Strings.Clear;\r\n Mode := rmInsert;\r\n for I := FStrings.MaxSize - 1 downto 0 do\r\n begin\r\n S := '';\r\n UserData := 0;\r\n DoReadItem(AppStorage, Path, I, S, UserData);\r\n if S <> '' then\r\n Add(S, UserData);\r\n end;\r\n finally\r\n Mode := AMode;\r\n AppStorage.EndUpdate;\r\n Strings.EndUpdate;\r\n end;\r\nend;\r\n\r\nprocedure TJvMRUManager.SaveToAppStorage(const AppStorage: TJvCustomAppStorage; const Path: string);\r\nvar\r\n I: Integer;\r\nbegin\r\n AppStorage.BeginUpdate;\r\n try\r\n AppStorage.DeleteSubTree(Path);\r\n for I := 0 to Strings.Count - 1 do\r\n DoWriteItem(AppStorage, Path, I, Strings[I], Longint(Strings.Objects[I]));\r\n finally\r\n AppStorage.EndUpdate;\r\n end;\r\nend;\r\n\r\nprocedure TJvMRUManager.Load;\r\nbegin\r\n IniLoad(nil);\r\nend;\r\n\r\nprocedure TJvMRUManager.Save;\r\nbegin\r\n IniSave(nil);\r\nend;\r\n\r\nprocedure TJvMRUManager.DoAfterUpdate;\r\nbegin\r\n if Assigned(FOnAfterUpdate) then\r\n FOnAfterUpdate(Self);\r\nend;\r\n\r\nprocedure TJvMRUManager.DoBeforeUpdate;\r\nbegin\r\n if Assigned(FOnBeforeUpdate) then\r\n FOnBeforeUpdate(Self);\r\nend;\r\n\r\nprocedure TJvMRUManager.RemoveInvalid;\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := Strings.Count - 1 downto 0 do\r\n if not FileExists(Strings[I]) then\r\n Strings.Delete(I);\r\nend;\r\n\r\nprocedure TJvMRUManager.GetItemInfo(Item: TMenuItem);\r\nbegin\r\n if Assigned(FOnItemInfo) then\r\n FOnItemInfo(Self, Item);\r\nend;\r\n\r\nprocedure TJvMRUManager.GetItemInfoEx(Item: TMenuItem; Index: Integer);\r\nbegin\r\n GetItemInfo(Item);\r\n if Assigned(FOnItemInfoEx) then\r\n FOnItemInfoEx(Self, Item, Index);\r\nend;\r\n\r\nprocedure TJvMRUManager.SetDuplicates(const Value: TDuplicates);\r\nbegin\r\n if FDuplicates <> Value then\r\n begin\r\n FDuplicates := Value;\r\n if FAutoUpdate then\r\n UpdateRecentMenu;\r\n end;\r\nend;\r\n\r\n//=== { TJvRecentStrings } ===================================================\r\n\r\nconstructor TJvRecentStrings.Create;\r\nbegin\r\n inherited Create;\r\n FMaxSize := 10;\r\n FMode := rmInsert;\r\nend;\r\n\r\nprocedure TJvRecentStrings.SetTextStr(const Value: String);\r\nvar\r\n LastMode: TRecentMode;\r\nbegin\r\n { Temporary change the FMode to rmAppend so the lines in Value will be added\r\n in the correct ordern. }\r\n LastMode := FMode;\r\n try\r\n FMode := rmAppend;\r\n inherited SetTextStr(Value);\r\n finally\r\n FMode := LastMode;\r\n end;\r\nend;\r\n\r\nprocedure TJvRecentStrings.SetMaxSize(Value: Integer);\r\nbegin\r\n if FMaxSize <> Value then\r\n begin\r\n FMaxSize := Max(1, Value);\r\n DeleteExceed;\r\n end;\r\nend;\r\n\r\nprocedure TJvRecentStrings.DeleteExceed;\r\nvar\r\n I: Integer;\r\nbegin\r\n BeginUpdate;\r\n try\r\n if FMode = rmInsert then\r\n for I := Count - 1 downto FMaxSize do\r\n Delete(I)\r\n else\r\n begin { rmAppend }\r\n while Count > FMaxSize do\r\n Delete(0);\r\n end;\r\n finally\r\n EndUpdate;\r\n end;\r\nend;\r\n\r\nprocedure TJvRecentStrings.Remove(const S: string);\r\nvar\r\n I: Integer;\r\nbegin\r\n I := IndexOf(S);\r\n if I >= 0 then\r\n Delete(I);\r\nend;\r\n\r\nfunction TJvRecentStrings.Add(const S: string): Integer;\r\nbegin\r\n Result := IndexOf(S);\r\n if Result >= 0 then\r\n begin\r\n if FMode = rmInsert then\r\n Move(Result, 0)\r\n else { rmAppend }\r\n Move(Result, Count - 1);\r\n end\r\n else\r\n begin\r\n BeginUpdate;\r\n try\r\n if FMode = rmInsert then\r\n Insert(0, S)\r\n else { rmAppend }\r\n Insert(Count, S);\r\n DeleteExceed;\r\n finally\r\n EndUpdate;\r\n end;\r\n end;\r\n if FMode = rmInsert then\r\n Result := 0\r\n else { rmAppend }\r\n Result := Count - 1;\r\nend;\r\n\r\nprocedure TJvRecentStrings.AddStrings(Strings: TStrings);\r\nvar\r\n I: Integer;\r\nbegin\r\n BeginUpdate;\r\n try\r\n if FMode = rmInsert then\r\n begin\r\n for I := Min(Strings.Count, FMaxSize) - 1 downto 0 do\r\n AddObject(Strings[I], Strings.Objects[I]);\r\n end\r\n else { rmAppend }\r\n for I := 0 to Min(Strings.Count, FMaxSize) - 1 do\r\n AddObject(Strings[I], Strings.Objects[I]);\r\n DeleteExceed;\r\n finally\r\n EndUpdate;\r\n end;\r\nend;\r\n\r\nprocedure TJvMRUManager.SetMenuLocation(const Value: TMenuLocation);\r\nbegin\r\n if FMenuLocation <> Value then\r\n begin\r\n FMenuLocation := Value;\r\n UpdateRecentMenu;\r\n end;\r\nend;\r\n\r\nfunction TJvMRUManager.IsMenuEnabled: Boolean;\r\nbegin\r\n Result := ((MenuLocation = mruChild) and (FRecentMenu.Count > 0)) or\r\n ((MenuLocation = mruSibling) and (Strings.Count > 0));\r\nend;\r\n\r\nprocedure TJvMRUManager.SetMaxLength(const Value: Integer);\r\nbegin\r\n if FMaxLength <> Value then\r\n begin\r\n FMaxLength := Value;\r\n UpdateRecentMenu;\r\n end;\r\nend;\r\n\r\nfunction TJvMRUManager.GetCanvas: TCanvas;\r\nbegin\r\n if FCanvas = nil then\r\n begin\r\n FCanvas := TCanvas.Create;\r\n if RecentMenu <> nil then\r\n FCanvas.Handle := GetDC(GetDesktopWindow);\r\n end;\r\n Result := FCanvas;\r\nend;\r\n\r\nfunction TJvMRUManager.DoMinimizeName(const S: string): string;\r\nbegin\r\n Result := '';\r\n if MaxLength > 0 then\r\n begin\r\n if not StartEllipsis then\r\n Result := PathCompactPath(\r\n GetCanvas.Handle,\r\n S, GetCanvas.TextWidth('n') * MaxLength, cpCenter)\r\n else\r\n if Length(S) > MaxLength then\r\n Result := '...' + Copy(S, Length(S) - MaxLength + 1, MaxInt);\r\n end;\r\n if (Result = '...') or (Result = '') then\r\n Result := S;\r\nend;\r\n\r\nprocedure TJvMRUManager.SetStartEllipsis(const Value: Boolean);\r\nbegin\r\n if FStartEllipsis <> Value then\r\n begin\r\n FStartEllipsis := Value;\r\n UpdateRecentMenu;\r\n end;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvMTComponents.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: MTComponents.pas, released on 2000-09-22.\r\n\r\nThe Initial Developer of the Original Code is Erwin Molendijk.\r\nPortions created by Erwin Molendijk are Copyright (C) 2002 Erwin Molendijk.\r\nAll Rights Reserved.\r\n\r\nContributor(s): ______________________________________.\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI home page,\r\nlocated at http://www.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvMTComponents.pas 13104 2011-09-07 06:50:43Z obones $\r\n\r\nunit JvMTComponents;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n SysUtils, Classes, SyncObjs,\r\n Consts,\r\n JvComponentBase,\r\n JvMTThreading, JvMTConsts, JvMTData, JvMTSync, JvMTSyncMon;\r\n\r\ntype\r\n TJvMTComponent = class(TJvComponent);\r\n TJvMTSingleThread = class(TMTThread);\r\n TJvMTThread = class;\r\n\r\n TJvMTThreadEvent = procedure (Sender: TJvMTThread;\r\n MTThread: TJvMTSingleThread) of object;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvMTManager = class(TJvMTComponent)\r\n private\r\n FManager: TMTManager;\r\n protected\r\n procedure Notification(AComponent: TComponent; Operation: TOperation);\r\n override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n function AcquireNewThread: TJvMTSingleThread;\r\n function AcquireThread(Ticket: TMTTicket;\r\n var Thread: TJvMTSingleThread): Boolean;\r\n function ActiveThreads: Boolean;\r\n procedure ReleaseThread(Ticket: TMTTicket);\r\n procedure TerminateThreads;\r\n procedure WaitThreads;\r\n end;\r\n\r\n TJvMTManagedComponent = class(TJvMTComponent)\r\n private\r\n FManager: TJvMTManager;\r\n protected\r\n procedure Notification(AComponent: TComponent; Operation: TOperation);\r\n override;\r\n procedure SetManager(Value: TJvMTManager); virtual;\r\n published\r\n property Manager: TJvMTManager read FManager write SetManager;\r\n end;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvMTThread = class(TJvMTManagedComponent)\r\n private\r\n FOnExecute: TJvMTThreadEvent;\r\n FOnFinished: TJvMTThreadEvent;\r\n FOnTerminating: TJvMTThreadEvent;\r\n FThread: TJvMTSingleThread;\r\n FRunOnCreate: Boolean;\r\n function GetStatus: TMTThreadStatus;\r\n function GetTicket: TMTTicket;\r\n procedure HookThread;\r\n procedure OnIntExecute(Thread: TMTThread);\r\n procedure OnIntFinished(Thread: TMTThread);\r\n procedure OnIntTerminating(Thread: TMTThread);\r\n procedure ReleaseThread;\r\n procedure SetOnExecute(Value: TJvMTThreadEvent);\r\n procedure SetOnFinished(Value: TJvMTThreadEvent);\r\n procedure SetOnTerminating(Value: TJvMTThreadEvent);\r\n procedure UnHookThread;\r\n protected\r\n procedure Loaded; override;\r\n procedure Notification(AComponent: TComponent; Operation: TOperation);\r\n override;\r\n procedure SetManager(Value: TJvMTManager); override;\r\n procedure DoExecute(MTThread: TJvMTSingleThread); dynamic;\r\n procedure DoFinished(MTThread: TJvMTSingleThread); dynamic;\r\n procedure DoTerminating(MTThread: TJvMTSingleThread); dynamic;\r\n public\r\n destructor Destroy; override;\r\n procedure CheckTerminate;\r\n procedure Run;\r\n procedure RunCopy;\r\n procedure Synchronize(Method: TThreadMethod);\r\n procedure Terminate;\r\n procedure Wait;\r\n property Status: TMTThreadStatus read GetStatus;\r\n property Ticket: TMTTicket read GetTicket;\r\n published\r\n property RunOnCreate: Boolean read FRunOnCreate write FRunOnCreate;\r\n property OnExecute: TJvMTThreadEvent read FOnExecute write SetOnExecute;\r\n property OnFinished: TJvMTThreadEvent read FOnFinished write SetOnFinished;\r\n property OnTerminating: TJvMTThreadEvent read FOnTerminating write\r\n SetOnTerminating;\r\n end;\r\n\r\n TJvMTSectionBase = class(TJvMTComponent)\r\n private\r\n FSync: TSynchroObject;\r\n function GetActive: Boolean;\r\n procedure HookSync;\r\n protected\r\n procedure CheckInactiveProperty;\r\n procedure CreateSync; virtual; abstract;\r\n public\r\n destructor Destroy; override;\r\n procedure Enter;\r\n procedure Leave;\r\n published\r\n property Active: Boolean read GetActive;\r\n end;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvMTSection = class(TJvMTSectionBase)\r\n private\r\n FAllowRecursion: Boolean;\r\n FInitEntered: Boolean;\r\n procedure SetAllowRecursion(Value: Boolean);\r\n procedure SetInitEntered(Value: Boolean);\r\n protected\r\n procedure CreateSync; override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n published\r\n property AllowRecursion: Boolean read FAllowRecursion write\r\n SetAllowRecursion default True;\r\n property InitEntered: Boolean read FInitEntered write SetInitEntered\r\n default False;\r\n end;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvMTCountingSection = class(TJvMTSectionBase)\r\n private\r\n FInitCount: Integer;\r\n FMaxCount: Integer;\r\n procedure SetInitAndMax(Init,Max: Integer);\r\n procedure SetInitCount(Value: Integer);\r\n procedure SetMaxCount(Value: Integer);\r\n protected\r\n procedure CreateSync; override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n published\r\n property InitCount: Integer read FInitCount write SetInitCount default 0;\r\n property MaxCount: Integer read FMaxCount write SetMaxCount default 1;\r\n end;\r\n\r\n TJvMTAsyncBufferBase = class(TJvMTComponent)\r\n private\r\n FBuffer: TMTAsyncBuffer;\r\n FHooking: TCriticalSection;\r\n FMaxBufferSize: Integer;\r\n procedure SetMaxBufferSize(Value: Integer);\r\n protected\r\n procedure CreateBuffer; virtual; abstract;\r\n procedure HookBuffer;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n function Read: TObject;\r\n procedure Write(AObject: TObject);\r\n published\r\n property MaxBufferSize: Integer read FMaxBufferSize write SetMaxBufferSize\r\n default MTDefaultBufferSize;\r\n end;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvMTThreadToVCL = class(TJvMTAsyncBufferBase)\r\n private\r\n FOnCanRead: TNotifyEvent;\r\n protected\r\n procedure DoCanRead(Sender: TObject); dynamic;\r\n procedure CreateBuffer; override;\r\n published\r\n property OnCanRead: TNotifyEvent read FOnCanRead write FOnCanRead;\r\n end;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvMTVCLToThread = class(TJvMTAsyncBufferBase)\r\n private\r\n FOnCanWrite: TNotifyEvent;\r\n protected\r\n procedure DoCanWrite(Sender: TObject); dynamic;\r\n procedure CreateBuffer; override;\r\n procedure Loaded; override;\r\n published\r\n property OnCanWrite: TNotifyEvent read FOnCanWrite write FOnCanWrite;\r\n end;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvMTThreadToThread = class(TJvMTComponent)\r\n private\r\n FHooking: TCriticalSection;\r\n FMaxBufferSize: Integer;\r\n FQueue: TMTBoundedQueue;\r\n procedure HookQueue;\r\n procedure SetMaxBufferSize(Value: Integer);\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n function Read: TObject;\r\n procedure Write(AObject: TObject);\r\n published\r\n property MaxBufferSize: Integer read FMaxBufferSize write SetMaxBufferSize\r\n default MTDefaultBufferSize;\r\n end;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvMTMonitorSection = class(TJvMTComponent)\r\n private\r\n FMonitor: TMTMonitor;\r\n function GetCondition(ID: Integer): TMTCondition;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n procedure Enter;\r\n procedure Leave;\r\n property Condition[ID: Integer]: TMTCondition read GetCondition; default;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvMTComponents.pas $';\r\n Revision: '$Revision: 13104 $';\r\n Date: '$Date: 2011-09-07 08:50:43 +0200 (mer. 07 sept. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n JvResources, JvJVCLUtils;\r\n\r\nconstructor TJvMTManager.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n\r\n // We want to know about the form going down\r\n if AOwner <> nil then\r\n AOwner.FreeNotification(Self);\r\n\r\n // hook to a manager object if not designing in the IDE\r\n if not (csDesigning in ComponentState) then\r\n FManager := TMTManager.Create;\r\nend;\r\n\r\ndestructor TJvMTManager.Destroy;\r\nbegin\r\n // call inherited destroy, this will send Notification's to all the mtcThread\r\n // components. These will release all their threads.\r\n inherited Destroy;\r\n\r\n // Now all threads have been released.\r\n // Free the manager and the threads belonging to this manager.\r\n FManager.Free;\r\nend;\r\n\r\nfunction TJvMTManager.AcquireNewThread: TJvMTSingleThread;\r\nbegin\r\n Result := TJvMTSingleThread(FManager.AcquireNewThread);\r\nend;\r\n\r\nfunction TJvMTManager.AcquireThread(Ticket: TMTTicket;\r\n var Thread: TJvMTSingleThread): Boolean;\r\nbegin\r\n Result := FManager.AcquireThread(Ticket, TMTThread(Thread));\r\nend;\r\n\r\nfunction TJvMTManager.ActiveThreads: Boolean;\r\nbegin\r\n Result := FManager.ActiveThreads;\r\nend;\r\n\r\nprocedure TJvMTManager.Notification(AComponent: TComponent; Operation:\r\n TOperation);\r\nbegin\r\n // check if the form is being destroyed\r\n if (not (csDesigning in ComponentState)) and (Operation = opRemove) and\r\n (AComponent = Owner) then\r\n begin\r\n // form is going down: terminate all threads\r\n TerminateThreads;\r\n // and wait until all is well\r\n WaitThreads;\r\n end;\r\n\r\n inherited Notification(AComponent, Operation);\r\nend;\r\n\r\nprocedure TJvMTManager.ReleaseThread(Ticket: TMTTicket);\r\nbegin\r\n FManager.ReleaseThread(Ticket);\r\nend;\r\n\r\nprocedure TJvMTManager.TerminateThreads;\r\nbegin\r\n FManager.TerminateThreads;\r\nend;\r\n\r\nprocedure TJvMTManager.WaitThreads;\r\nbegin\r\n FManager.WaitThreads;\r\nend;\r\n\r\n//=== { TJvMTManagedComponent } ==============================================\r\n\r\nprocedure TJvMTManagedComponent.Notification(AComponent: TComponent; Operation:\r\n TOperation);\r\nbegin\r\n if (Operation = opRemove) and (AComponent = FManager) then\r\n FManager := nil; // important during designtime\r\n\r\n inherited Notification(AComponent, Operation);\r\nend;\r\n\r\nprocedure TJvMTManagedComponent.SetManager(Value: TJvMTManager);\r\nbegin\r\n ReplaceComponentReference(Self, Value, TComponent(FManager));\r\nend;\r\n\r\n//=== { TJvMTThread } ========================================================\r\n\r\ndestructor TJvMTThread.Destroy;\r\nbegin\r\n ReleaseThread;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvMTThread.CheckTerminate;\r\nbegin\r\n HookThread;\r\n FThread.CheckTerminate;\r\nend;\r\n\r\nfunction TJvMTThread.GetStatus: TMTThreadStatus;\r\nbegin\r\n HookThread;\r\n Result := FThread.Status;\r\nend;\r\n\r\nfunction TJvMTThread.GetTicket: TMTTicket;\r\nbegin\r\n HookThread;\r\n Result := FThread.Ticket;\r\nend;\r\n\r\nprocedure TJvMTThread.HookThread;\r\nbegin\r\n if FThread = nil then\r\n begin\r\n if FManager = nil then\r\n raise EThread.CreateRes(@RsENoThreadManager);\r\n\r\n // get the new thread\r\n FThread := FManager.AcquireNewThread;\r\n\r\n // hook up the nessesary events\r\n if Assigned(FOnExecute) then\r\n FThread.OnExecute := OnIntExecute;\r\n if Assigned(FOnTerminating) then\r\n FThread.OnTerminating := OnIntTerminating;\r\n if Assigned(FOnFinished) then\r\n FThread.OnFinished := OnIntFinished;\r\n\r\n // give it a name\r\n FThread.Name := Name;\r\n end;\r\nend;\r\n\r\nprocedure TJvMTThread.Notification(AComponent: TComponent; Operation:\r\n TOperation);\r\nbegin\r\n if (Operation = opRemove) and (AComponent = FManager) then\r\n ReleaseThread; // important during runtime\r\n\r\n // now can inherited (this wil invalidate FManager)\r\n inherited Notification(AComponent, Operation);\r\nend;\r\n\r\nprocedure TJvMTThread.OnIntExecute(Thread: TMTThread);\r\nbegin\r\n DoExecute(TJvMTSingleThread(Thread));\r\nend;\r\n\r\nprocedure TJvMTThread.OnIntFinished(Thread: TMTThread);\r\nbegin\r\n DoFinished(TJvMTSingleThread(Thread));\r\nend;\r\n\r\nprocedure TJvMTThread.OnIntTerminating(Thread: TMTThread);\r\nbegin\r\n DoTerminating(TJvMTSingleThread(Thread));\r\nend;\r\n\r\nprocedure TJvMTThread.ReleaseThread;\r\nbegin\r\n // check if there is an acquired thread\r\n if FThread <> nil then\r\n begin\r\n // release the thread and invalidate the pointer\r\n FThread.Release;\r\n FThread := nil;\r\n end;\r\nend;\r\n\r\nprocedure TJvMTThread.Run;\r\nbegin\r\n HookThread;\r\n FThread.Run;\r\nend;\r\n\r\nprocedure TJvMTThread.RunCopy;\r\nbegin\r\n ReleaseThread;\r\n Run;\r\nend;\r\n\r\nprocedure TJvMTThread.SetManager(Value: TJvMTManager);\r\nbegin\r\n UnHookThread;\r\n inherited SetManager(Value);\r\nend;\r\n\r\nprocedure TJvMTThread.SetOnExecute(Value: TJvMTThreadEvent);\r\nbegin\r\n UnHookThread;\r\n FOnExecute := Value;\r\nend;\r\n\r\nprocedure TJvMTThread.SetOnFinished(Value: TJvMTThreadEvent);\r\nbegin\r\n UnHookThread;\r\n FOnFinished := Value;\r\nend;\r\n\r\nprocedure TJvMTThread.SetOnTerminating(Value: TJvMTThreadEvent);\r\nbegin\r\n UnHookThread;\r\n FOnTerminating := Value;\r\nend;\r\n\r\nprocedure TJvMTThread.Synchronize(Method: TThreadMethod);\r\nbegin\r\n HookThread;\r\n FThread.Synchronize(Method);\r\nend;\r\n\r\nprocedure TJvMTThread.Terminate;\r\nbegin\r\n HookThread;\r\n FThread.Terminate;\r\nend;\r\n\r\nprocedure TJvMTThread.UnHookThread;\r\nbegin\r\n if FThread <> nil then\r\n begin\r\n if FThread.Status in [tsInitializing, tsFinished] then\r\n begin\r\n FThread.Terminate; {incase initializing}\r\n FThread.Release;\r\n FThread := nil;\r\n end\r\n else\r\n raise EThread.CreateRes(@RsEOperatorNotAvailable);\r\n end;\r\nend;\r\n\r\nprocedure TJvMTThread.Wait;\r\nbegin\r\n HookThread;\r\n FThread.Wait;\r\nend;\r\n\r\nprocedure TJvMTThread.DoExecute(MTThread: TJvMTSingleThread);\r\nbegin\r\n if Assigned(FOnExecute) then\r\n FOnExecute(Self, MTThread);\r\nend;\r\n\r\nprocedure TJvMTThread.DoFinished(MTThread: TJvMTSingleThread);\r\nbegin\r\n if Assigned(FOnFinished) then\r\n FOnFinished(Self, MTThread);\r\nend;\r\n\r\nprocedure TJvMTThread.DoTerminating(MTThread: TJvMTSingleThread);\r\nbegin\r\n if Assigned(FOnTerminating) then\r\n FOnTerminating(Self, MTThread);\r\nend;\r\n\r\nprocedure TJvMTThread.Loaded;\r\nbegin\r\n inherited Loaded;\r\n // Component is ready. Shall we start a thread?\r\n if (not (csDesigning in ComponentState)) and FRunOnCreate then\r\n Run;\r\nend;\r\n\r\n//=== { TJvMTSectionBase } ===================================================\r\n\r\ndestructor TJvMTSectionBase.Destroy;\r\nbegin\r\n // signal interested components that we are going down\r\n inherited Destroy;\r\n // cleanup\r\n FSync.Free;\r\nend;\r\n\r\nprocedure TJvMTSectionBase.CheckInactiveProperty;\r\nbegin\r\n if Active then\r\n raise EThread.CreateRes(@RsECannotChangePropertySection);\r\nend;\r\n\r\nprocedure TJvMTSectionBase.Enter;\r\nbegin\r\n HookSync;\r\n FSync.Acquire;\r\nend;\r\n\r\nfunction TJvMTSectionBase.GetActive: Boolean;\r\nbegin\r\n Result := FSync <> nil;\r\nend;\r\n\r\nprocedure TJvMTSectionBase.HookSync;\r\nbegin\r\n if not Active then\r\n CreateSync;\r\nend;\r\n\r\nprocedure TJvMTSectionBase.Leave;\r\nbegin\r\n HookSync;\r\n FSync.Release;\r\nend;\r\n\r\n//=== { TJvMTSection } =======================================================\r\n\r\nconstructor TJvMTSection.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FAllowRecursion := True;\r\nend;\r\n\r\nprocedure TJvMTSection.CreateSync;\r\nbegin\r\n if FAllowRecursion then\r\n FSync := TMTCriticalSection.Create(Name)\r\n else\r\n FSync := TMTMutex.Create(Name);\r\n\r\n if FInitEntered then\r\n Enter;\r\nend;\r\n\r\nprocedure TJvMTSection.SetAllowRecursion(Value: Boolean);\r\nbegin\r\n CheckInactiveProperty;\r\n FAllowRecursion := Value;\r\nend;\r\n\r\nprocedure TJvMTSection.SetInitEntered(Value: Boolean);\r\nbegin\r\n CheckInactiveProperty;\r\n FInitEntered := Value;\r\nend;\r\n\r\n//=== { TJvMTCountingSection } ===============================================\r\n\r\nconstructor TJvMTCountingSection.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FMaxCount := 1;\r\nend;\r\n\r\nprocedure TJvMTCountingSection.CreateSync;\r\nbegin\r\n FSync := TMTSemaphore.Create(FMaxCount-FInitCount, FMaxCount, Name);\r\nend;\r\n\r\nprocedure TJvMTCountingSection.SetInitAndMax(Init,Max: Integer);\r\nbegin\r\n CheckInactiveProperty;\r\n if (Max < 1) or (Init < 0) or (Init > Max) then\r\n raise EInvalidOperation.CreateResFmt(@SPropertyOutOfRange, [ClassName]);\r\n\r\n FInitCount := Init;\r\n FMaxCount := Max;\r\nend;\r\n\r\nprocedure TJvMTCountingSection.SetInitCount(Value: Integer);\r\nbegin\r\n SetInitAndMax(Value, FMaxCount);\r\nend;\r\n\r\nprocedure TJvMTCountingSection.SetMaxCount(Value: Integer);\r\nbegin\r\n SetInitAndMax(FInitCount, Value);\r\nend;\r\n\r\n//=== { TJvMTAsyncBufferBase } ===============================================\r\n\r\nconstructor TJvMTAsyncBufferBase.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FMaxBufferSize := MTDefaultBufferSize;\r\n FHooking := TCriticalSection.Create;\r\nend;\r\n\r\ndestructor TJvMTAsyncBufferBase.Destroy;\r\nbegin\r\n // notify interested components\r\n inherited Destroy;\r\n // cleanup\r\n FBuffer.Free;\r\n FHooking.Free;\r\nend;\r\n\r\nprocedure TJvMTAsyncBufferBase.HookBuffer;\r\nbegin\r\n // buffer still uncreated?\r\n if FBuffer = nil then\r\n begin\r\n // enter critical section\r\n FHooking.Enter;\r\n try\r\n // perform check again. and create if we are the first in this section\r\n if FBuffer = nil then\r\n CreateBuffer;\r\n finally\r\n FHooking.Leave;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJvMTAsyncBufferBase.Read: TObject;\r\nbegin\r\n HookBuffer;\r\n Result := FBuffer.Read;\r\nend;\r\n\r\nprocedure TJvMTAsyncBufferBase.SetMaxBufferSize(Value: Integer);\r\nbegin\r\n if FBuffer <> nil then\r\n raise EThread.CreateRes(@RsECannotChangePropertyBuffer);\r\n FMaxBufferSize := Value;\r\nend;\r\n\r\nprocedure TJvMTAsyncBufferBase.Write(AObject: TObject);\r\nbegin\r\n HookBuffer;\r\n FBuffer.Write(AObject);\r\nend;\r\n\r\n//=== { TJvMTThreadToVCL } ===================================================\r\n\r\nprocedure TJvMTThreadToVCL.CreateBuffer;\r\nbegin\r\n FBuffer := TMTBufferToVCL.Create(FMaxBufferSize, Name);\r\n TMTBufferToVCL(FBuffer).OnCanRead := DoCanRead;\r\nend;\r\n\r\nprocedure TJvMTThreadToVCL.DoCanRead(Sender: TObject);\r\nbegin\r\n // call the OnCanRead event with this object as the sender\r\n if Assigned(FOnCanRead) then\r\n FOnCanRead(Self);\r\nend;\r\n\r\n//=== { TJvMTVCLToThread } ===================================================\r\n\r\nprocedure TJvMTVCLToThread.CreateBuffer;\r\nbegin\r\n FBuffer := TMTVCLToBuffer.Create(FMaxBufferSize, Name);\r\n TMTVCLToBuffer(FBuffer).OnCanWrite := DoCanWrite;\r\nend;\r\n\r\nprocedure TJvMTVCLToThread.DoCanWrite(Sender: TObject);\r\nbegin\r\n // call the OnCanWrite event with this object as the sender\r\n if Assigned(FOnCanWrite) then\r\n FOnCanWrite(Self);\r\nend;\r\n\r\nprocedure TJvMTVCLToThread.Loaded;\r\nbegin\r\n inherited Loaded;\r\n // force first Event\r\n HookBuffer;\r\n if Assigned(FOnCanWrite) then\r\n FOnCanWrite(Self);\r\nend;\r\n\r\n//=== { TJvMTThreadToThread } ================================================\r\n\r\nconstructor TJvMTThreadToThread.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FMaxBufferSize := MTDefaultBufferSize;\r\n FHooking := TCriticalSection.Create;\r\nend;\r\n\r\ndestructor TJvMTThreadToThread.Destroy;\r\nbegin\r\n inherited Destroy;\r\n FQueue.Free;\r\n FHooking.Free;\r\nend;\r\n\r\nprocedure TJvMTThreadToThread.HookQueue;\r\nbegin\r\n // buffer still uncreated?\r\n if FQueue = nil then\r\n begin\r\n // enter critical section\r\n FHooking.Enter;\r\n try\r\n // perform check again. and create if we are the first in this section\r\n if FQueue = nil then\r\n FQueue := TMTBoundedQueue.Create(FMaxBufferSize,Name);\r\n finally\r\n FHooking.Leave;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJvMTThreadToThread.Read: TObject;\r\nbegin\r\n HookQueue;\r\n Result := FQueue.Pop;\r\nend;\r\n\r\nprocedure TJvMTThreadToThread.SetMaxBufferSize(Value: Integer);\r\nbegin\r\n if FQueue <> nil then\r\n raise EThread.CreateRes(@RsECannotChangePropertyBuffer);\r\n if Value < 1 then\r\n raise EInvalidOperation.CreateResFmt(@SPropertyOutOfRange, [ClassName]);\r\n FMaxBufferSize := Value;\r\nend;\r\n\r\nprocedure TJvMTThreadToThread.Write(AObject: TObject);\r\nbegin\r\n HookQueue;\r\n FQueue.Push(AObject);\r\nend;\r\n\r\n//=== { TJvMTMonitorSection } ================================================\r\n\r\nconstructor TJvMTMonitorSection.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FMonitor := TMTMonitor.Create;\r\nend;\r\n\r\ndestructor TJvMTMonitorSection.Destroy;\r\nbegin\r\n FMonitor.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvMTMonitorSection.Enter;\r\nbegin\r\n FMonitor.Enter;\r\nend;\r\n\r\nfunction TJvMTMonitorSection.GetCondition(ID: Integer): TMTCondition;\r\nbegin\r\n Result := FMonitor.Condition[ID];\r\nend;\r\n\r\nprocedure TJvMTMonitorSection.Leave;\r\nbegin\r\n FMonitor.Leave;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvMTConsts.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: MTConst.PAS, released on 2002-09-24.\r\n\r\nThe Initial Developer of the Original Code is Erwin Molendijk.\r\nPortions created by Erwin Molendijk are Copyright (C) 2002 Erwin Molendijk.\r\nAll Rights Reserved.\r\n\r\nContributor(s): ______________________________________.\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvMTConsts.pas 12337 2009-06-11 10:42:10Z ahuser $\r\n\r\nunit JvMTConsts;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n SysUtils, Classes;\r\n\r\ntype\r\n TMTTicket = Integer;\r\n\r\ntype\r\n EMTThreadError = class(EThread);\r\n EMTTerminateError = class(EAbort);\r\n\r\ntype\r\n TMTThreadStatus =\r\n (tsInitializing, tsWaiting, tsRunning, tsTerminating, tsFinished);\r\n\r\ntype\r\n TThreadNameInfo = record\r\n FType: Longword; // must be 0x1000\r\n FName: PChar; // pointer to name (in user address space)\r\n FThreadID: Longword; // thread ID (-1 indicates caller thread)\r\n FFlags: Longword; // reserved for future use, must be zero\r\n end;\r\n\r\nconst\r\n MTDefaultBufferSize = 32;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvMTConsts.pas $';\r\n Revision: '$Revision: 12337 $';\r\n Date: '$Date: 2009-06-11 12:42:10 +0200 (jeu. 11 juin 2009) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvMTData.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: MTData.pas, released on 2000-09-22.\r\n\r\nThe Initial Developer of the Original Code is Erwin Molendijk.\r\nPortions created by Erwin Molendijk are Copyright (C) 2002 Erwin Molendijk.\r\nAll Rights Reserved.\r\n\r\nContributor(s): ______________________________________.\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI home page,\r\nlocated at http://www.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvMTData.pas 13138 2011-10-26 23:17:50Z jfudickar $\r\n\r\nunit JvMTData;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n SysUtils, Classes, Contnrs,\r\n {$IFDEF MSWINDOWS}\r\n {$IFDEF DEBUGINFO_ON}\r\n Windows, // for OutputDebugString\r\n {$ENDIF DEBUGINFO_ON}\r\n {$ENDIF MSWINDOWS}\r\n JvMTSync, JvMTThreading;\r\n\r\ntype\r\n TMTBoundedQueue = class(TObjectQueue)\r\n private\r\n FEmpty: TMTSemaphore;\r\n FFull: TMTSemaphore;\r\n FMutex: TMTMutex;\r\n FName: string;\r\n public\r\n constructor Create(Size: Integer; Name: string = '');\r\n destructor Destroy; override;\r\n function Peek: TObject;\r\n function Pop: TObject;\r\n procedure Push(AObject: TObject);\r\n end;\r\n\r\n TMTAsyncBuffer = class(TObject)\r\n private\r\n FBuffer: TMTBoundedQueue;\r\n FData: TObject;\r\n FDataReady: TMTMutex;\r\n FName: string;\r\n FVCLReady: TMTMutex;\r\n FWorkerThread: TMTThread;\r\n procedure WorkerExecute(Thread: TMTThread);\r\n protected\r\n procedure DoDataEvent; virtual; abstract;\r\n procedure InitMutex; virtual; abstract;\r\n procedure PerformDataXChg; virtual; abstract;\r\n public\r\n constructor Create(Size: Integer; Name: string = '');\r\n destructor Destroy; override;\r\n function Read: TObject; virtual; abstract;\r\n procedure Write(AObject: TObject; FreeOnFail: Boolean = True); virtual; abstract;\r\n end;\r\n\r\n TMTBufferToVCL = class(TMTAsyncBuffer)\r\n private\r\n FOnCanRead: TNotifyEvent;\r\n protected\r\n procedure DoDataEvent; override;\r\n procedure InitMutex; override;\r\n procedure PerformDataXChg; override;\r\n public\r\n destructor Destroy; override;\r\n function Read: TObject; override;\r\n procedure Write(AObject: TObject; FreeOnFail: Boolean = True); override;\r\n property OnCanRead: TNotifyEvent read FOnCanRead write FOnCanRead;\r\n end;\r\n\r\n {$M+}\r\n TMTVCLToBuffer = class(TMTAsyncBuffer)\r\n private\r\n FOnCanWrite: TNotifyEvent;\r\n protected\r\n procedure DoDataEvent; override;\r\n procedure InitMutex; override;\r\n procedure PerformDataXChg; override;\r\n public\r\n destructor Destroy; override;\r\n function Read: TObject; override;\r\n procedure Write(AObject: TObject; FreeOnFail: Boolean = True); override;\r\n published\r\n property OnCanWrite: TNotifyEvent read FOnCanWrite write FOnCanWrite;\r\n end;\r\n {$M-}\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvMTData.pas $';\r\n Revision: '$Revision: 13138 $';\r\n Date: '$Date: 2011-10-27 01:17:50 +0200 (jeu. 27 oct. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n JvResources;\r\n\r\nvar\r\n GlobalDataThreadsMan: TMTManager = nil;\r\n\r\nfunction DataThreadsMan: TMTManager;\r\nbegin\r\n if not Assigned(GlobalDataThreadsMan) then\r\n GlobalDataThreadsMan := TMTManager.Create;\r\n Result := GlobalDataThreadsMan;\r\nend;\r\n\r\nconst\r\n cRead = 'Read';\r\n cWrite = 'Write';\r\n\r\n//=== { TMTBoundedQueue } ====================================================\r\n\r\nconstructor TMTBoundedQueue.Create(Size: Integer; Name: string = '');\r\nbegin\r\n inherited Create;\r\n if Name = '' then\r\n FName := ClassName\r\n else\r\n FName := Name;\r\n\r\n FMutex := TMTMutex.Create;\r\n FEmpty := TMTSemaphore.Create(Size, Size + 1, FName + '.Space'); // do not localize\r\n FFull := TMTSemaphore.Create(0, Size + 1, FName + '.Data'); // do not localize\r\nend;\r\n\r\ndestructor TMTBoundedQueue.Destroy;\r\nbegin\r\n while Count > 0 do\r\n Pop.Free;\r\n\r\n FMutex.Free;\r\n FEmpty.Free;\r\n FFull.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TMTBoundedQueue.Peek: TObject;\r\nbegin\r\n FFull.Wait;\r\n FMutex.Enter;\r\n try\r\n Result := inherited Peek;\r\n finally\r\n FMutex.Leave;\r\n FFull.Signal;\r\n end;\r\nend;\r\n\r\nfunction TMTBoundedQueue.Pop: TObject;\r\nbegin\r\n FFull.Wait;\r\n FMutex.Enter;\r\n try\r\n Result := inherited Pop;\r\n finally\r\n FMutex.Leave;\r\n FEmpty.Signal;\r\n end;\r\nend;\r\n\r\nprocedure TMTBoundedQueue.Push(AObject: TObject);\r\nbegin\r\n FEmpty.Wait;\r\n FMutex.Enter;\r\n try\r\n inherited Push(AObject);\r\n finally\r\n FMutex.Leave;\r\n FFull.Signal;\r\n end;\r\nend;\r\n\r\n//=== { TMTAsyncBuffer } =====================================================\r\n\r\nconstructor TMTAsyncBuffer.Create(Size: Integer; Name: string = '');\r\nbegin\r\n inherited Create;\r\n if Name = '' then\r\n FName := ClassName\r\n else\r\n FName := Name;\r\n\r\n FBuffer := TMTBoundedQueue.Create(Size, 'Queue'); // do not localize\r\n FDataReady := TMTMutex.Create('DataReady'); // do not localize\r\n FVCLReady := TMTMutex.Create('VCLReady'); // do not localize\r\n\r\n InitMutex;\r\n\r\n FWorkerThread := DataThreadsMan.AcquireNewThread;\r\n FWorkerThread.OnExecute := WorkerExecute;\r\n FWorkerThread.Name := Name + '.WorkerThread'; // do not localize\r\n FWorkerThread.Run;\r\nend;\r\n\r\ndestructor TMTAsyncBuffer.Destroy;\r\nbegin\r\n FWorkerThread.Terminate;\r\n FWorkerThread.Wait;\r\n FWorkerThread.Release;\r\n\r\n FBuffer.Free;\r\n FData.Free;\r\n FDataReady.Free;\r\n FVCLReady.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TMTAsyncBuffer.WorkerExecute(Thread: TMTThread);\r\nbegin\r\n while True do\r\n begin\r\n // wait until the data has been read (can be outside OnCanRead event)\r\n FVCLReady.Wait;\r\n // perform blocking read or write from the buffer\r\n PerformDataXChg;\r\n // set data is ready flag\r\n FDataReady.Signal;\r\n // Perform OnCanRead event in VCL thread context\r\n Thread.Synchronize(DoDataEvent);\r\n end;\r\nend;\r\n\r\n\r\n//=== { TMTBufferToVCL } =====================================================\r\n\r\ndestructor TMTBufferToVCL.Destroy;\r\nbegin\r\n FOnCanRead := nil;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TMTBufferToVCL.DoDataEvent;\r\nbegin\r\n if Assigned(FOnCanRead) then\r\n FOnCanRead(Self);\r\nend;\r\n\r\nprocedure TMTBufferToVCL.InitMutex;\r\nbegin\r\n FDataReady.Wait;\r\nend;\r\n\r\nprocedure TMTBufferToVCL.PerformDataXChg;\r\nbegin\r\n // perform blocking read from the buffer\r\n FData := FBuffer.Pop;\r\nend;\r\n\r\nfunction TMTBufferToVCL.Read: TObject;\r\nbegin\r\n if CurrentMTThread <> nil then\r\n raise EThread.CreateResFmt(@RsEMethodOnlyForMainThread, [cRead]);\r\n\r\n // Check if data ready\r\n FDataReady.Wait;\r\n // get data\r\n Result := FData;\r\n // make sure it we dont own it anymore\r\n FData := nil;\r\n // signal worker to continue\r\n FVCLReady.Signal;\r\nend;\r\n\r\nprocedure TMTBufferToVCL.Write(AObject: TObject; FreeOnFail: Boolean = True);\r\nbegin\r\n try\r\n if CurrentMTThread = nil then\r\n raise EThread.CreateResFmt(@RsEMethodOnlyForMainThread, [cWrite]);\r\n\r\n // Perform blocking write to buffer\r\n FBuffer.Push(AObject);\r\n except\r\n if FreeOnFail then\r\n AObject.Free;\r\n raise;\r\n end;\r\nend;\r\n\r\n//=== { TMTVCLToBuffer } =====================================================\r\n\r\ndestructor TMTVCLToBuffer.Destroy;\r\nbegin\r\n FOnCanWrite := nil;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TMTVCLToBuffer.DoDataEvent;\r\nbegin\r\n if Assigned(FOnCanWrite) then\r\n FOnCanWrite(Self);\r\nend;\r\n\r\nprocedure TMTVCLToBuffer.InitMutex;\r\nbegin\r\n FVCLReady.Wait;\r\n //FDataReady.Wait;\r\nend;\r\n\r\nprocedure TMTVCLToBuffer.PerformDataXChg;\r\nbegin\r\n FBuffer.Push(FData);\r\n FData := nil;\r\nend;\r\n\r\nfunction TMTVCLToBuffer.Read: TObject;\r\nbegin\r\n if CurrentMTThread = nil then\r\n raise EThread.CreateResFmt(@RsEMethodOnlyForMainThread, [cRead]);\r\n\r\n Result := FBuffer.Pop;\r\nend;\r\n\r\nprocedure TMTVCLToBuffer.Write(AObject: TObject; FreeOnFail: Boolean = True);\r\nbegin\r\n try\r\n if CurrentMTThread <> nil then\r\n raise EThread.CreateResFmt(@RsEMethodOnlyForMainThread, [cWrite]);\r\n\r\n // Check if data ready\r\n FDataReady.Wait;\r\n except\r\n if FreeOnFail then\r\n AObject.Free;\r\n raise;\r\n end;\r\n\r\n // save data object\r\n FData := AObject;\r\n\r\n // signal worker to continue\r\n FVCLReady.Signal;\r\nend;\r\n\r\ninitialization\r\n {$IFDEF UNITVERSIONING}\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n {$ENDIF UNITVERSIONING}\r\n\r\nfinalization\r\n {$IFDEF MSWINDOWS}\r\n // (rom) no OutputDebugString in production code\r\n {$IFDEF DEBUGINFO_ON}\r\n if DataThreadsMan.ActiveThreads then\r\n OutputDebugString(\r\n 'Memory leak detected: free MTData objects before application shutdown'); // do not localize\r\n {$ENDIF DEBUGINFO_ON}\r\n {$ENDIF MSWINDOWS}\r\n FreeAndNil(GlobalDataThreadsMan);\r\n {$IFDEF UNITVERSIONING}\r\n UnregisterUnitVersion(HInstance);\r\n {$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvMTSync.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: MTSync.pas, released on 2000-09-22.\r\n\r\nThe Initial Developer of the Original Code is Erwin Molendijk.\r\nPortions created by Erwin Molendijk are Copyright (C) 2002 Erwin Molendijk.\r\nAll Rights Reserved.\r\n\r\nContributor(s): ______________________________________.\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI home page,\r\nlocated at http://www.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvMTSync.pas 12833 2010-09-05 13:25:12Z obones $\r\n\r\nunit JvMTSync;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n SysUtils, Classes, SyncObjs,\r\n {$IFDEF MSWINDOWS}\r\n Windows,\r\n {$ENDIF MSWINDOWS}\r\n {$IFDEF HAS_UNIT_LIBC}\r\n Libc,\r\n {$ENDIF HAS_UNIT_LIBC}\r\n JvMTConsts;\r\n\r\ntype\r\n TMTSynchroObject = class(TSynchroObject)\r\n private\r\n FHandle: THandle;\r\n FLastError: Integer;\r\n FName: string;\r\n protected\r\n function CreateHandle: THandle; virtual; abstract;\r\n public\r\n constructor Create(Name: string = '');\r\n destructor Destroy; override;\r\n procedure Acquire; override;\r\n procedure Release; override;\r\n procedure Signal;\r\n procedure Wait;\r\n function WaitFor(Timeout: LongWord): Boolean; {$IFDEF RTL220_UP}reintroduce;{$ENDIF RTL220_UP} virtual;\r\n property Handle: THandle read FHandle;\r\n property LastError: Integer read FLastError;\r\n property Name: string read FName;\r\n end;\r\n\r\n TMTSimpleEvent = class(TMTSynchroObject)\r\n protected\r\n function CreateHandle: THandle; override;\r\n public\r\n procedure Release; override;\r\n procedure SetEvent;\r\n procedure ResetEvent;\r\n end;\r\n\r\n TMTSemaphore = class(TMTSynchroObject)\r\n private\r\n FInitialCount: Integer;\r\n FMaximumCount: Integer;\r\n protected\r\n function CreateHandle: THandle; override;\r\n public\r\n constructor Create(InitialCount, MaximumCount: Integer; Name: string = '');\r\n procedure Release; override;\r\n end;\r\n\r\n TMTMutex = class(TMTSemaphore)\r\n public\r\n constructor Create(Name: string = '');\r\n procedure Enter;\r\n procedure Leave;\r\n end;\r\n\r\n TMTCriticalSection = class(TMTMutex)\r\n private\r\n FOwnerThread: TObject;\r\n FSelfCount: Integer;\r\n public\r\n procedure Release; override;\r\n function WaitFor(Timeout: LongWord): Boolean; override;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvMTSync.pas $';\r\n Revision: '$Revision: 12833 $';\r\n Date: '$Date: 2010-09-05 15:25:12 +0200 (dim. 05 sept. 2010) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n JvResources,\r\n JvMTThreading;\r\n\r\n//=== { TMTSemaphore } =======================================================\r\n\r\nconstructor TMTSynchroObject.Create(Name: string);\r\nbegin\r\n inherited Create;\r\n if Name = '' then\r\n FName := ClassName\r\n else\r\n FName := Name;\r\n FHandle := CreateHandle;\r\nend;\r\n\r\ndestructor TMTSynchroObject.Destroy;\r\nbegin\r\n CloseHandle(FHandle);\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TMTSynchroObject.Acquire;\r\nvar\r\n OldName: string;\r\nbegin\r\n // first wait for 500 ms\r\n if not WaitFor(500) then\r\n begin\r\n // still not succeeded: change the name of the thread and wait again\r\n if CurrentMTThread <> nil then\r\n begin\r\n OldName := CurrentMTThread.Name;\r\n CurrentMTThread.Name := OldName + '.' + FName + '.Wait';\r\n end;\r\n try\r\n WaitFor(INFINITE); // this time, wait forever (ETerminate can be raised though)\r\n finally\r\n if CurrentMTThread <> nil then\r\n CurrentMTThread.Name := OldName;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TMTSynchroObject.Release;\r\nbegin\r\n// ReleaseSemaphore(FHandle, 1, nil);\r\nend;\r\n\r\nprocedure TMTSynchroObject.Signal;\r\nbegin\r\n Release;\r\nend;\r\n\r\nprocedure TMTSynchroObject.Wait;\r\nbegin\r\n Acquire;\r\nend;\r\n\r\n{\r\n WaitFor()\r\n\r\n Wait for the semaphore to become signalled or the for the timeout time to pass.\r\n If the Thread is terminated before or during the waiting, an EMTTerminateError\r\n exception will be raised.\r\n The exception will only be raised if the semaphore was not signalled\r\n during the wait. This will ensure that the caller can take appropriate\r\n measures to return the semaphore to the appropriate state before terminating\r\n the thread.\r\n}\r\n\r\nfunction TMTSynchroObject.WaitFor(Timeout: LongWord): Boolean;\r\nvar\r\n HandleArray: array [0..1] of THandle;\r\nbegin\r\n Result := False;\r\n\r\n if CurrentMTThread <> nil then\r\n begin {MT thread}\r\n // don't wait if we are already terminated\r\n // because we don't want to take the risk of getting the\r\n // semaphore in that case.\r\n CurrentMTThread.CheckTerminate;\r\n\r\n // setup the handle array.\r\n // the semphore has priority over the terminate signal\r\n // because if we get the semaphore we must not raise an EMTTerminateError\r\n HandleArray[0] := FHandle;\r\n HandleArray[1] := CurrentMTThread.TerminateSignal;\r\n\r\n // perform the wait\r\n case WaitForMultipleObjects(2, @HandleArray[0], False, Timeout) of\r\n WAIT_FAILED:\r\n begin\r\n FLastError := GetLastError;\r\n raise EMTThreadError.CreateResFmt(@RsESemaphoreFailure, [FLastError]);\r\n end;\r\n WAIT_TIMEOUT:\r\n Result := False;\r\n WAIT_OBJECT_0:\r\n Result := True;\r\n WAIT_OBJECT_0 + 1:\r\n CurrentMTThread.CheckTerminate; // do raise EMTTerminateError\r\n WAIT_ABANDONED:\r\n raise EMTTerminateError.CreateRes(@RsESemaphoreAbandoned);\r\n WAIT_ABANDONED + 1:\r\n raise EMTTerminateError.CreateRes(@RsEThreadAbandoned);\r\n end;\r\n end\r\n else\r\n begin {main VCL thread}\r\n // perform the wait without checking the TerminateSignal since the\r\n // main VCL thread does not have such a signal\r\n case WaitForSingleObject(FHandle, Timeout) of\r\n WAIT_OBJECT_0:\r\n Result := True;\r\n WAIT_ABANDONED:\r\n raise EMTTerminateError.CreateRes(@RsESemaphoreAbandoned);\r\n WAIT_TIMEOUT:\r\n Result := False;\r\n WAIT_FAILED:\r\n begin\r\n FLastError := GetLastError;\r\n raise EMTThreadError.CreateRes(@RsESemaphoreFailure);\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\n//=== { TMTSemaphore } =======================================================\r\n\r\nconstructor TMTSemaphore.Create(InitialCount, MaximumCount: Integer;\r\n Name: string);\r\nbegin\r\n FInitialCount := InitialCount;\r\n FMaximumCount := MaximumCount;\r\n inherited Create(Name);\r\nend;\r\n\r\nfunction TMTSemaphore.CreateHandle: THandle;\r\nbegin\r\n Result := CreateSemaphore(nil, FInitialCount, FMaximumCount, '');\r\nend;\r\n\r\nprocedure TMTSemaphore.Release;\r\nbegin\r\n ReleaseSemaphore(FHandle, 1, nil);\r\nend;\r\n\r\n//=== { TMTMutex } ===========================================================\r\n\r\nconstructor TMTMutex.Create(Name: string = '');\r\nbegin\r\n inherited Create(1, 1);\r\nend;\r\n\r\nprocedure TMTMutex.Enter;\r\nbegin\r\n Acquire;\r\nend;\r\n\r\nprocedure TMTMutex.Leave;\r\nbegin\r\n Release;\r\nend;\r\n\r\n//=== { TMTCriticalSection } =================================================\r\n\r\nprocedure TMTCriticalSection.Release;\r\nbegin\r\n Dec(FSelfCount);\r\n if FSelfCount = 0 then\r\n begin\r\n FOwnerThread := nil;\r\n inherited Release;\r\n end;\r\nend;\r\n\r\nfunction TMTCriticalSection.WaitFor(Timeout: LongWord): Boolean;\r\nbegin\r\n if CurrentMTThread <> FOwnerThread then\r\n begin\r\n Result := inherited WaitFor(Timeout);\r\n if Result then\r\n begin\r\n FOwnerThread := CurrentMTThread;\r\n FSelfCount := 1;\r\n end;\r\n end\r\n else\r\n begin\r\n Result := True;\r\n Inc(FSelfCount);\r\n end;\r\nend;\r\n\r\n\r\n//=== { TMTSimpleEvent } =====================================================\r\n\r\nfunction TMTSimpleEvent.CreateHandle: THandle;\r\nbegin\r\n Result := CreateEvent(nil, True, False, '');\r\nend;\r\n\r\nprocedure TMTSimpleEvent.Release;\r\nbegin\r\n SetEvent;\r\nend;\r\n\r\nprocedure TMTSimpleEvent.ResetEvent;\r\nbegin\r\n Windows.ResetEvent(FHandle);\r\nend;\r\n\r\nprocedure TMTSimpleEvent.SetEvent;\r\nbegin\r\n Windows.SetEvent(FHandle);\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvMTSyncMon.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: MTSyncMon.pas, released on 2000-09-22.\r\n\r\nThe Initial Developer of the Original Code is Erwin Molendijk.\r\nPortions created by Erwin Molendijk are Copyright (C) 2002 Erwin Molendijk.\r\nAll Rights Reserved.\r\n\r\nContributor(s): ______________________________________.\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI home page,\r\nlocated at http://www.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvMTSyncMon.pas 12337 2009-06-11 10:42:10Z ahuser $\r\n\r\nunit JvMTSyncMon;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n {$IFDEF MSWINDOWS}\r\n Windows,\r\n {$ENDIF MSWINDOWS}\r\n SysUtils, Classes, Contnrs, SyncObjs,\r\n JvMTThreading, JvMTSync, JvMTConsts;\r\n\r\ntype\r\n TMTCondition = class;\r\n\r\n TMTMonitor = class(TObject)\r\n private\r\n FActiveThread: TMTThread;\r\n FConditions: TObjectList;\r\n FCriticalTransition: TCriticalSection;\r\n FMutex: TMTSemaphore;\r\n FNext: TMTSemaphore;\r\n FNextCount: Integer;\r\n function GetCondition(ID: Integer): TMTCondition;\r\n protected\r\n procedure CriticalEnter;\r\n procedure CriticalLeave;\r\n procedure DecNextCount;\r\n function GetNextCount: Integer;\r\n procedure IncNextCount;\r\n procedure InvalidateActiveThread;\r\n function IsValidActiveThread: Boolean;\r\n procedure SignalMutex;\r\n procedure SignalNext;\r\n procedure WaitMutex;\r\n procedure WaitNext;\r\n property ActiveThread: TMTThread read FActiveThread write FActiveThread;\r\n public\r\n constructor Create;\r\n destructor Destroy; override;\r\n procedure Enter;\r\n procedure Leave;\r\n property Condition[ID: Integer]: TMTCondition read GetCondition; default;\r\n end;\r\n\r\n TMTCondition = class(TObject)\r\n private\r\n FID: Integer;\r\n FMonitor: TMTMonitor;\r\n FXCount: Integer;\r\n FXSem: TMTSemaphore;\r\n public\r\n constructor Create(AMonitor: TMTMonitor; AID: Integer);\r\n destructor Destroy; override;\r\n procedure Signal;\r\n procedure Wait;\r\n property ID: Integer read FID;\r\n property Monitor: TMTMonitor read FMonitor;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvMTSyncMon.pas $';\r\n Revision: '$Revision: 12337 $';\r\n Date: '$Date: 2009-06-11 12:42:10 +0200 (jeu. 11 juin 2009) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\n// Invalid is -1 pointer. The nil pointer is used for the main VCL thread\r\nconst\r\n InvalidThreadPtr = TMTThread(-1);\r\n\r\n{$IFDEF LINUX}\r\n\r\nfunction InterlockedIncrement(var I: Integer): Integer;\r\nasm\r\n MOV EDX, 1\r\n XCHG EAX, EDX\r\n LOCK XADD [EDX], EAX\r\n INC EAX\r\nend;\r\n\r\nfunction InterlockedDecrement(var I: Integer): Integer;\r\nasm\r\n MOV EDX, -1\r\n XCHG EAX, EDX\r\n LOCK XADD [EDX], EAX\r\n DEC EAX\r\nend;\r\n\r\n{$ENDIF LINUX}\r\n\r\n//=== { TMTMonitor } =========================================================\r\n\r\nconstructor TMTMonitor.Create;\r\nbegin\r\n inherited Create;\r\n FConditions := TObjectList.Create;\r\n FMutex := TMTSemaphore.Create(1, 1);\r\n FNext := TMTSemaphore.Create(0, 1);\r\n FCriticalTransition := TCriticalSection.Create;\r\n InvalidateActiveThread;\r\nend;\r\n\r\ndestructor TMTMonitor.Destroy;\r\nbegin\r\n FCriticalTransition.Free;\r\n FConditions.Free;\r\n FMutex.Free;\r\n FNext.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TMTMonitor.CriticalEnter;\r\nbegin\r\n FCriticalTransition.Enter;\r\nend;\r\n\r\nprocedure TMTMonitor.CriticalLeave;\r\nbegin\r\n FCriticalTransition.Leave;\r\nend;\r\n\r\nprocedure TMTMonitor.DecNextCount;\r\nbegin\r\n InterlockedDecrement(FNextCount);\r\nend;\r\n\r\nprocedure TMTMonitor.Enter;\r\nbegin\r\n WaitMutex;\r\n Assert(not IsValidActiveThread);\r\n FActiveThread := CurrentMTThread;\r\nend;\r\n\r\nfunction TMTMonitor.GetCondition(ID: Integer): TMTCondition;\r\nvar\r\n I: Integer;\r\nbegin\r\n // search for condition. start at top\r\n I := FConditions.Count-1;\r\n while (I <> -1) and (TMTCondition(FConditions[I]).ID <> ID) do\r\n Dec(I);\r\n\r\n // if not found, add the condition\r\n if I = -1 then\r\n I := FConditions.Add(TMTCondition.Create(Self, ID));\r\n\r\n // return the condition\r\n Result := TMTCondition(FConditions[I])\r\nend;\r\n\r\nfunction TMTMonitor.GetNextCount: Integer;\r\nbegin\r\n Result := FNextCount;\r\nend;\r\n\r\nprocedure TMTMonitor.IncNextCount;\r\nbegin\r\n InterlockedIncrement(FNextCount);\r\nend;\r\n\r\nprocedure TMTMonitor.InvalidateActiveThread;\r\nbegin\r\n FActiveThread := InvalidThreadPtr;\r\nend;\r\n\r\nfunction TMTMonitor.IsValidActiveThread: Boolean;\r\nbegin\r\n Result := FActiveThread <> InvalidThreadPtr;\r\nend;\r\n\r\nprocedure TMTMonitor.Leave;\r\nbegin\r\n CriticalEnter;\r\n try\r\n if (CurrentMTThread = FActiveThread) or (not IsValidActiveThread) then\r\n begin\r\n InvalidateActiveThread;\r\n if GetNextCount > 0 then\r\n SignalNext\r\n else\r\n SignalMutex;\r\n end;\r\n finally\r\n CriticalLeave;\r\n end;\r\nend;\r\n\r\nprocedure TMTMonitor.SignalMutex;\r\nbegin\r\n FMutex.Signal;\r\nend;\r\n\r\nprocedure TMTMonitor.SignalNext;\r\nbegin\r\n FNext.Signal;\r\nend;\r\n\r\nprocedure TMTMonitor.WaitMutex;\r\nbegin\r\n FMutex.Wait;\r\nend;\r\n\r\nprocedure TMTMonitor.WaitNext;\r\nbegin\r\n FNext.Wait;\r\nend;\r\n\r\n//=== { TMTCondition } =======================================================\r\n\r\nconstructor TMTCondition.Create(AMonitor: TMTMonitor; AID: Integer);\r\nbegin\r\n inherited Create;\r\n FID := AID;\r\n FMonitor := AMonitor;\r\n FXSem := TMTSemaphore.Create(0, 1);\r\nend;\r\n\r\ndestructor TMTCondition.Destroy;\r\nbegin\r\n FXSem.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TMTCondition.Signal;\r\nvar\r\n OtherWaiting: Boolean;\r\nbegin\r\n FMonitor.CriticalEnter;\r\n try\r\n //FMonitor.FActiveThread := nil;\r\n FMonitor.InvalidateActiveThread;\r\n FMonitor.IncNextCount;\r\n OtherWaiting := FXCount > 0;\r\n if OtherWaiting then\r\n FXSem.Signal;\r\n finally\r\n FMonitor.CriticalLeave;\r\n end;\r\n\r\n if OtherWaiting then\r\n try\r\n FMonitor.WaitNext; // Can raise EMTTerminateError\r\n except\r\n on EMTTerminateError do\r\n begin\r\n FMonitor.CriticalEnter;\r\n try\r\n FMonitor.DecNextCount;\r\n finally\r\n FMonitor.CriticalLeave;\r\n end;\r\n raise;\r\n end;\r\n end;\r\n\r\n FMonitor.CriticalEnter;\r\n try\r\n FMonitor.DecNextCount;\r\n FMonitor.ActiveThread := CurrentMTThread;\r\n finally\r\n FMonitor.CriticalLeave;\r\n end;\r\nend;\r\n\r\nprocedure TMTCondition.Wait;\r\nbegin\r\n FMonitor.CriticalEnter;\r\n try\r\n //FMonitor.FActiveThread := nil;\r\n FMonitor.InvalidateActiveThread;\r\n InterlockedIncrement(FXCount);\r\n\r\n if FMonitor.GetNextCount > 0 then\r\n FMonitor.SignalNext\r\n else\r\n FMonitor.SignalMutex;\r\n finally\r\n FMonitor.CriticalLeave;\r\n end;\r\n\r\n try\r\n FXSem.Wait; // Can raise EMTTerminateError\r\n except\r\n on EMTTerminateError do\r\n begin\r\n FMonitor.CriticalEnter;\r\n try\r\n InterlockedDecrement(FXCount);\r\n finally\r\n FMonitor.CriticalLeave;\r\n end;\r\n raise;\r\n end;\r\n end;\r\n\r\n FMonitor.CriticalEnter;\r\n try\r\n InterlockedDecrement(FXCount);\r\n FMonitor.ActiveThread := CurrentMTThread;\r\n finally\r\n FMonitor.CriticalLeave;\r\n end;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvMTThreading.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: MTThreading.pas, released on 2000-09-22.\r\n\r\nThe Initial Developer of the Original Code is Erwin Molendijk.\r\nPortions created by Erwin Molendijk are Copyright (C) 2002 Erwin Molendijk.\r\nAll Rights Reserved.\r\n\r\nContributor(s): ______________________________________.\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI home page,\r\nlocated at http://www.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvMTThreading.pas 13138 2011-10-26 23:17:50Z jfudickar $\r\n\r\nunit JvMTThreading;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n SysUtils, Classes, SyncObjs, Contnrs,\r\n {$IFDEF MSWINDOWS}\r\n Windows, Messages,\r\n {$ENDIF MSWINDOWS}\r\n {$IFDEF HAS_UNIT_LIBC}\r\n Libc,\r\n {$ENDIF HAS_UNIT_LIBC}\r\n JvMTConsts;\r\n\r\ntype\r\n TMTManager = class;\r\n TMTThread = class;\r\n\r\n TMTEvent = procedure(Thread: TMTThread) of object;\r\n\r\n TIntThread = TThread;\r\n\r\n TMTInternalThread = class(TIntThread)\r\n private\r\n FName: string;\r\n FOnExecute: TNotifyEvent;\r\n protected\r\n procedure Execute; override;\r\n procedure RaiseName;\r\n public\r\n property Name: string read FName write FName;\r\n property OnExecute: TNotifyEvent read FOnExecute write FOnExecute;\r\n end;\r\n\r\n TMTThread = class(TObject)\r\n private\r\n FFinished: Boolean;\r\n FIntThread: TMTInternalThread;\r\n FManager: TMTManager;\r\n FName: string;\r\n FOnExecute: TMTEvent;\r\n FOnFinished: TMTEvent;\r\n FOnTerminating: TMTEvent;\r\n FReferenceCount: Integer;\r\n FStatusChange: TCriticalSection;\r\n FTerminateSignal: THandle;\r\n FTicket: TMTTicket;\r\n procedure CreateAndRun;\r\n function GetStatus: TMTThreadStatus;\r\n procedure Log(const Msg: string);\r\n procedure OnIntThreadExecute(Sender: TObject);\r\n procedure OnIntThreadTerminate(Sender: TObject);\r\n procedure SetName(const Value: string);\r\n protected\r\n procedure DecRef;\r\n procedure IncRef;\r\n public\r\n constructor Create(Manager: TMTManager; Ticket: Integer);\r\n destructor Destroy; override;\r\n procedure CheckTerminate;\r\n procedure Release;\r\n procedure Run;\r\n procedure Synchronize(Method: TThreadMethod);\r\n procedure Terminate;\r\n procedure Wait;\r\n property Name: string read FName write SetName;\r\n property OnExecute: TMTEvent read FOnExecute write FOnExecute;\r\n property OnFinished: TMTEvent read FOnFinished write FOnFinished;\r\n property OnTerminating: TMTEvent read FOnTerminating write FOnTerminating;\r\n property ReferenceCount: Integer read FReferenceCount;\r\n property Status: TMTThreadStatus read GetStatus;\r\n property TerminateSignal: THandle read FTerminateSignal;\r\n property ThreadManager: TMTManager read FManager;\r\n property Ticket: TMTTicket read FTicket;\r\n end;\r\n\r\n TMTManager = class(TObject)\r\n private\r\n FGenTicket: TCriticalSection;\r\n FNextTicket: TMTTicket;\r\n FThreads: TObjectList;\r\n FThreadsChange: TCriticalSection;\r\n function FindThread(Ticket: TMTTicket; var Thread: TMTThread): Boolean;\r\n function GenerateTicket: TMTTicket;\r\n procedure Log(const Msg: string);\r\n procedure TryRemoveThread(Thread: TMTThread);\r\n function InternalActiveThreads(RaiseID: Longword): Integer;\r\n protected\r\n procedure OnThreadFinished(Thread: TMTThread);\r\n public\r\n constructor Create;\r\n destructor Destroy; override;\r\n function AcquireNewThread: TMTThread;\r\n function AcquireThread(Ticket: TMTTicket; var Thread: TMTThread): Boolean;\r\n function ActiveThreads: Boolean;\r\n procedure ReleaseThread(Ticket: TMTTicket);\r\n procedure TerminateThreads;\r\n procedure WaitThreads;\r\n end;\r\n\r\nfunction CurrentMTThread: TMTThread;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvMTThreading.pas $';\r\n Revision: '$Revision: 13138 $';\r\n Date: '$Date: 2011-10-27 01:17:50 +0200 (jeu. 27 oct. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n JvResources;\r\n\r\nthreadvar\r\n _CurrentMTThread: TMTThread;\r\n\r\nfunction CurrentMTThread: TMTThread;\r\nbegin\r\n Result := _CurrentMTThread;\r\nend;\r\n\r\n\r\n//=== { TMTInternalThread } ==================================================\r\n\r\nprocedure TMTInternalThread.Execute;\r\nbegin\r\n RaiseName;\r\n if Assigned(FOnExecute) then\r\n FOnExecute(Self);\r\nend;\r\n\r\nprocedure TMTInternalThread.RaiseName;\r\n{$IFDEF COMPILER7_UP}\r\nvar\r\n ThreadNameInfo: TThreadNameInfo;\r\n{$ENDIF COMPILER7_UP}\r\nbegin\r\n {$IFDEF COMPILER7_UP}\r\n ThreadNameInfo.FType := $1000;\r\n ThreadNameInfo.FName := PChar(FName);\r\n ThreadNameInfo.FThreadID := $FFFFFFFF;\r\n ThreadNameInfo.FFlags := 0;\r\n try\r\n RaiseException($406D1388, 0, SizeOf(ThreadNameInfo) div SizeOf(Longword),\r\n @ThreadNameInfo);\r\n except\r\n end;\r\n {$ENDIF COMPILER7_UP}\r\nend;\r\n\r\n//=== { TMTThread } ==========================================================\r\n\r\nconstructor TMTThread.Create(Manager: TMTManager; Ticket: Integer);\r\nbegin\r\n inherited Create;\r\n FStatusChange := TCriticalSection.Create;\r\n FManager := Manager;\r\n FTicket := Ticket;\r\n FName := 'MT' + IntToStr(Ticket); // do not localize\r\n FTerminateSignal := CreateSemaphore(nil, 0, 1, '');\r\nend;\r\n\r\ndestructor TMTThread.Destroy;\r\nbegin\r\n CloseHandle(FTerminateSignal);\r\n FStatusChange.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TMTThread.CheckTerminate;\r\nbegin\r\n if CurrentMTThread <> Self then\r\n raise EMTThreadError.CreateRes(@RsECheckTerminateCalledByWrongThread);\r\n\r\n if Status = tsTerminating then\r\n raise EMTTerminateError.Create('');\r\nend;\r\n\r\nprocedure TMTThread.CreateAndRun;\r\nbegin\r\n FStatusChange.Acquire;\r\n try\r\n FIntThread := TMTInternalThread.Create(True);\r\n FIntThread.OnExecute := OnIntThreadExecute;\r\n FIntThread.OnTerminate := OnIntThreadTerminate;\r\n FIntThread.FreeOnTerminate := True;\r\n FIntThread.Name := FName;\r\n FIntThread.{$IFDEF COMPILER14_UP}Start{$ELSE}Resume{$ENDIF COMPILER14_UP};\r\n finally\r\n FStatusChange.Release;\r\n end;\r\nend;\r\n\r\nprocedure TMTThread.DecRef;\r\nbegin\r\n InterlockedDecrement(FReferenceCount);\r\nend;\r\n\r\nfunction TMTThread.GetStatus: TMTThreadStatus;\r\nbegin\r\n FStatusChange.Acquire;\r\n try\r\n if FFinished then\r\n Result := tsFinished\r\n else\r\n if FIntThread = nil then\r\n Result := tsInitializing\r\n else\r\n if FIntThread.Suspended then\r\n Result := tsWaiting\r\n else\r\n if FIntThread.Terminated then\r\n Result := tsTerminating\r\n else\r\n Result := tsRunning;\r\n finally\r\n FStatusChange.Release;\r\n end;\r\nend;\r\n\r\nprocedure TMTThread.IncRef;\r\nbegin\r\n InterlockedIncrement(FReferenceCount);\r\nend;\r\n\r\nprocedure TMTThread.Log(const Msg: string);\r\nbegin\r\n // (rom) no OutputDebugString in production code\r\n {$IFDEF DEBUGINFO_ON}\r\n OutputDebugString(PChar('[' + ClassName + '] ' + Msg));\r\n {$ENDIF DEBUGINFO_ON}\r\nend;\r\n\r\nprocedure TMTThread.OnIntThreadExecute(Sender: TObject);\r\nbegin\r\n // set the CurrentMTThread variable.\r\n // this variable is global, but only to this thread.\r\n _CurrentMTThread := Self;\r\n\r\n // run OnExecute event\r\n try\r\n if Assigned(FOnExecute) then\r\n FOnExecute(Self);\r\n except\r\n on E: EMTTerminateError do\r\n {nothing};\r\n on E: Exception do\r\n Log('OnExecute Exception: \"' + E.Message + '\"'); // do not localize\r\n end;\r\n\r\n // make sure terminate flag is set\r\n FIntThread.Terminate;\r\n\r\n // run OnTerminating event\r\n try\r\n if Assigned(FOnTerminating) then\r\n FOnTerminating(Self);\r\n except\r\n on E: Exception do\r\n Log('OnTerminate Exception: \"' + E.Message + '\"'); // do not localize\r\n end;\r\nend;\r\n\r\nprocedure TMTThread.OnIntThreadTerminate(Sender: TObject);\r\nbegin\r\n FStatusChange.Acquire;\r\n try\r\n if FFinished then\r\n Exit;\r\n FFinished := True;\r\n finally\r\n FStatusChange.Release;\r\n end;\r\n\r\n if Assigned(FOnFinished) then\r\n FOnFinished(Self);\r\n\r\n FStatusChange.Acquire;\r\n try\r\n FIntThread := nil;\r\n finally\r\n FStatusChange.Release;\r\n end;\r\n\r\n // After a call to OnThreadFinished, this object might be destroyed.\r\n // So don't access any fields after this call.\r\n FManager.OnThreadFinished(Self);\r\nend;\r\n\r\nprocedure TMTThread.Release;\r\nbegin\r\n FManager.ReleaseThread(FTicket);\r\nend;\r\n\r\nprocedure TMTThread.Run;\r\nbegin\r\n FStatusChange.Acquire;\r\n try\r\n if Status = tsInitializing then\r\n CreateAndRun\r\n else\r\n if Status = tsWaiting then\r\n FIntThread.Suspended := False\r\n else\r\n raise EMTThreadError.CreateRes(@RsEThreadNotInitializedOrWaiting);\r\n finally\r\n FStatusChange.Release;\r\n end;\r\nend;\r\n\r\nprocedure TMTThread.SetName(const Value: string);\r\nbegin\r\n FStatusChange.Acquire;\r\n try\r\n if Status in [tsInitializing, tsFinished] then\r\n FName := Value\r\n else\r\n begin\r\n if CurrentMTThread <> Self then\r\n raise EMTThreadError.CreateRes(@RsECannotChangeNameOfOtherActiveThread);\r\n\r\n FName := Value;\r\n if FIntThread <> nil then\r\n begin\r\n FIntThread.Name := FName;\r\n FIntThread.RaiseName;\r\n end;\r\n end;\r\n finally\r\n FStatusChange.Release;\r\n end;\r\nend;\r\n\r\nprocedure TMTThread.Synchronize(Method: TThreadMethod);\r\nbegin\r\n if CurrentMTThread = Self then\r\n FIntThread.Synchronize(Method)\r\n else\r\n if CurrentMTThread = nil then\r\n Method\r\n else\r\n CurrentMTThread.Synchronize(Method);\r\nend;\r\n\r\nprocedure TMTThread.Terminate;\r\nbegin\r\n if Status in [tsTerminating, tsFinished] then\r\n Exit;\r\n\r\n FStatusChange.Acquire;\r\n try\r\n if FIntThread <> nil then\r\n FIntThread.Terminate {thread was Running}\r\n else\r\n FFinished := True; {thread was initializing}\r\n\r\n // make sure thread escapes from any Wait() calls\r\n ReleaseSemaphore(FTerminateSignal, 1, nil);\r\n finally\r\n FStatusChange.Release;\r\n end;\r\nend;\r\n\r\nprocedure TMTThread.Wait;\r\nvar\r\n SelfRef: TMTThread;\r\nbegin\r\n if FManager.AcquireThread(Ticket, SelfRef) then\r\n try\r\n if GetCurrentThreadID = MainThreadID then\r\n begin\r\n while Status <> tsFinished do\r\n begin\r\n CheckSynchronize;\r\n Sleep(1);\r\n end;\r\n end\r\n else\r\n begin\r\n while Status <> tsFinished do\r\n Sleep(1);\r\n end;\r\n finally\r\n Release;\r\n end;\r\nend;\r\n\r\n//=== { TMTManager } =========================================================\r\n\r\nconstructor TMTManager.Create;\r\nbegin\r\n inherited Create;\r\n FGenTicket := TCriticalSection.Create;\r\n FThreadsChange := TCriticalSection.Create;\r\n FThreads := TObjectList.Create(True);\r\nend;\r\n\r\ndestructor TMTManager.Destroy;\r\nvar\r\n I: Integer;\r\nbegin\r\n // set the terminate flag at each thread\r\n TerminateThreads;\r\n // wait for them to finish\r\n WaitThreads;\r\n\r\n FThreadsChange.Acquire;\r\n try\r\n for I := 0 to FThreads.Count-1 do\r\n Log('Unreleased thread: \"' + TMTThread(FThreads[I]).Name + '\"'); // do not localize\r\n finally\r\n FThreadsChange.Release;\r\n end;\r\n\r\n FThreads.Free;\r\n FThreadsChange.Free;\r\n FGenTicket.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TMTManager.AcquireNewThread: TMTThread;\r\nbegin\r\n Result := TMTThread.Create(Self, GenerateTicket);\r\n try\r\n Result.IncRef;\r\n FThreadsChange.Acquire;\r\n try\r\n FThreads.Add(Result);\r\n finally\r\n FThreadsChange.Release;\r\n end;\r\n except\r\n Result.Free;\r\n raise;\r\n end;\r\nend;\r\n\r\nfunction TMTManager.AcquireThread(Ticket: TMTTicket; var Thread: TMTThread):\r\n Boolean;\r\nbegin\r\n FThreadsChange.Acquire;\r\n try\r\n Result := FindThread(Ticket, Thread);\r\n if Result then\r\n Thread.IncRef;\r\n finally\r\n FThreadsChange.Release;\r\n end;\r\nend;\r\n\r\n// returns 0 = False\r\n// 1 = True\r\n// -1 = RaiseID found and active\r\n\r\nfunction TMTManager.InternalActiveThreads(RaiseID: Longword): Integer;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := 0;\r\n FThreadsChange.Acquire;\r\n try\r\n for I := 0 to FThreads.Count - 1 do\r\n if TMTThread(FThreads[I]).Status <> tsFinished then\r\n begin\r\n if (RaiseID <> 0) and\r\n (TMTThread(FThreads[I]).FIntThread.ThreadID = RaiseID) then\r\n Result := -1\r\n // no Break; here: Return -1 only when RaiseID is the last active thread\r\n else\r\n begin\r\n Result := 1;\r\n Break;\r\n end;\r\n end;\r\n finally\r\n FThreadsChange.Release;\r\n end;\r\nend;\r\n\r\nfunction TMTManager.ActiveThreads: Boolean;\r\nbegin\r\n Result := InternalActiveThreads(0) <> 0;\r\nend;\r\n\r\nfunction TMTManager.FindThread(Ticket: TMTTicket; var Thread: TMTThread):\r\n Boolean;\r\nvar\r\n I: Integer;\r\nbegin\r\n FThreadsChange.Acquire;\r\n try\r\n I := FThreads.Count-1;\r\n while (I <> -1) and (TMTThread(FThreads[I]).Ticket <> Ticket) do\r\n Dec(I);\r\n\r\n Result := I <> -1;\r\n if Result then\r\n Thread := TMTThread(FThreads[I])\r\n else\r\n Thread := nil;\r\n\r\n finally\r\n FThreadsChange.Release;\r\n end;\r\nend;\r\n\r\nfunction TMTManager.GenerateTicket: TMTTicket;\r\nbegin\r\n FGenTicket.Acquire;\r\n try\r\n Result := FNextTicket;\r\n Inc(FNextTicket);\r\n finally\r\n FGenTicket.Release;\r\n end;\r\nend;\r\n\r\nprocedure TMTManager.Log(const Msg: string);\r\nbegin\r\n // (rom) no OutputDebugString in production code\r\n {$IFDEF DEBUGINFO_ON}\r\n OutputDebugString(PChar('[' + ClassName + '] ' + Msg));\r\n {$ENDIF DEBUGINFO_ON}\r\nend;\r\n\r\nprocedure TMTManager.OnThreadFinished(Thread: TMTThread);\r\nbegin\r\n TryRemoveThread(Thread);\r\nend;\r\n\r\nprocedure TMTManager.ReleaseThread(Ticket: TMTTicket);\r\nvar\r\n Thread: TMTThread;\r\nbegin\r\n FThreadsChange.Acquire;\r\n try\r\n if FindThread(Ticket, Thread) then\r\n Thread.DecRef\r\n else\r\n raise EMTThreadError.CreateRes(@RsEReleaseOfUnusedTicket);\r\n\r\n // if this was the last reference then the thread must be removed\r\n TryRemoveThread(Thread);\r\n finally\r\n FThreadsChange.Release;\r\n end;\r\nend;\r\n\r\nprocedure TMTManager.TerminateThreads;\r\nvar\r\n I: Integer;\r\nbegin\r\n FThreadsChange.Acquire;\r\n try\r\n for I := 0 to FThreads.Count-1 do\r\n TMTThread(FThreads[I]).Terminate;\r\n finally\r\n FThreadsChange.Release;\r\n end;\r\nend;\r\n\r\nprocedure TMTManager.TryRemoveThread(Thread: TMTThread);\r\nbegin\r\n FThreadsChange.Acquire;\r\n try\r\n if (Thread.Status = tsFinished) and (Thread.ReferenceCount = 0) then\r\n FThreads.Remove(Thread);\r\n finally\r\n FThreadsChange.Release;\r\n end;\r\nend;\r\n\r\n// wait until the threads are all finished\r\n\r\nprocedure TMTManager.WaitThreads;\r\nbegin\r\n // running from inside the main VCL thread?\r\n if GetCurrentThreadID = MainThreadID then\r\n begin\r\n // use CheckSynchronise to process the OnFinished events\r\n while ActiveThreads do\r\n begin\r\n CheckSynchronize;\r\n Sleep(1);\r\n end;\r\n end\r\n else\r\n begin\r\n //running in a MTThread, just wait for all threads to finish\r\n while True do\r\n begin\r\n case InternalActiveThreads(GetCurrentThreadID) of\r\n 0:\r\n Break;\r\n 1:\r\n { Nothing };\r\n -1:\r\n raise EMTThreadError.CreateRes(@RsECurThreadIsPartOfManager);\r\n end;\r\n Sleep(1);\r\n end;\r\n end;\r\nend;\r\n\r\ninitialization\r\n {$IFDEF UNITVERSIONING}\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n {$ENDIF UNITVERSIONING}\r\n\r\nfinalization\r\n {$IFDEF UNITVERSIONING}\r\n UnregisterUnitVersion(HInstance);\r\n {$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvMail.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvMail.PAS, released Jun 10, 2000.\r\n\r\nThe Initial Developer of the Original Code is Petr Vones (petr dott v att mujmail dott cz)\r\nPortions created by Petr Vones are Copyright (C) 2000 Petr Vones.\r\nPortions created by Microsoft are Copyright (C) 1998, 1999 Microsoft Corp.\r\nAll Rights Reserved.\r\n\r\nContributor(s): ______________________________________.\r\n\r\nCurrent Version: 0.50\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n Doesn't work with Paegasus Mail because it has no MAPI support at all.\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvMail.pas 13138 2011-10-26 23:17:50Z jfudickar $\r\n\r\nunit JvMail;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, SysUtils, Classes, Controls, Forms,\r\n Mapi,\r\n JclMapi,\r\n JvComponentBase;\r\n\r\ntype\r\n TJvMail = class;\r\n\r\n // (rom) renamed\r\n TJvMailRecipient = class(TCollectionItem)\r\n private\r\n FAddress: string;\r\n FName: string;\r\n function GetAddressAndName: string;\r\n function GetValid: Boolean;\r\n protected\r\n function GetDisplayName: string; override;\r\n public\r\n // (rom) renamed\r\n property AddressAndName: string read GetAddressAndName;\r\n published\r\n property Address: string read FAddress write FAddress;\r\n property Name: string read FName write FName;\r\n property Valid: Boolean read GetValid;\r\n end;\r\n\r\n // (rom) renamed\r\n TJvMailRecipients = class(TCollection)\r\n private\r\n FOwner: TJvMail;\r\n FRecipientClass: DWORD;\r\n function GetItem(Index: Integer): TJvMailRecipient;\r\n procedure SetItem(Index: Integer; const Value: TJvMailRecipient);\r\n protected\r\n procedure AssignTo(Dest: TPersistent); override;\r\n function GetOwner: TPersistent; override;\r\n public\r\n constructor Create(AOwner: TJvMail; ARecipientClass: DWORD);\r\n function Add: TJvMailRecipient;\r\n function AddRecipient(const Address: string; const Name: string = ''): Integer;\r\n procedure Assign(Source: TPersistent); override;\r\n property Items[Index: Integer]: TJvMailRecipient read GetItem write SetItem; default;\r\n property RecipientClass: DWORD read FRecipientClass;\r\n end;\r\n\r\n TJvMailLogonOption = (loLogonUI, loNewSession, loDownloadMail);\r\n TJvMailLogonOptions = set of TJvMailLogonOption;\r\n TJvMailReadOption = (roUnreadOnly, roFifo, roPeek, roHeaderOnly, roAttachments);\r\n TJvMailReadOptions = set of TJvMailReadOption;\r\n\r\n TJvMailReadedData = record\r\n RecipientAddress: string;\r\n RecipientName: string;\r\n ConversationID: string;\r\n DateReceived: TDateTime;\r\n end;\r\n\r\n TJvMailErrorEvent = procedure(Sender: TJvMail; ErrorCode: ULONG) of object;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvMail = class(TJvComponent)\r\n private\r\n FAttachment: TStrings;\r\n FAttachArray: array of TMapiFileDesc;\r\n FBlindCopy: TJvMailRecipients;\r\n FBody: TStrings;\r\n FCarbonCopy: TJvMailRecipients;\r\n FRecipient: TJvMailRecipients;\r\n FSimpleMapi: TJclSimpleMapi;\r\n FSubject: string;\r\n FSessionHandle: THandle;\r\n FMapiMessage: TMapiMessage;\r\n FRecipArray: array of TMapiRecipDesc;\r\n FLongMsgId: Boolean;\r\n FLogonOptions: TJvMailLogonOptions;\r\n FPassword: string;\r\n FProfileName: string;\r\n FSaveTaskWindows: array of Boolean;\r\n FSaveTaskActiveForm: TForm;\r\n FSeedMessageID: string;\r\n FReadOptions: TJvMailReadOptions;\r\n FReadedMail: TJvMailReadedData;\r\n FOnError: TJvMailErrorEvent;\r\n procedure BeforeClientLibUnload(Sender: TObject);\r\n procedure SetBlindCopy(const Value: TJvMailRecipients);\r\n procedure SetCarbonCopy(const Value: TJvMailRecipients);\r\n procedure SetRecipient(const Value: TJvMailRecipients);\r\n procedure SetBody(const Value: TStrings);\r\n function GetUserLogged: Boolean;\r\n procedure SetAttachment(const Value: TStrings);\r\n function GetSimpleMapi: TJclSimpleMapi;\r\n protected\r\n procedure CheckLoadLib;\r\n procedure CheckUserLogged;\r\n procedure CreateMapiMessage;\r\n procedure CreateRecips;\r\n procedure DecodeAttachments(Attachments: PMapiFileDesc; AttachCount: Integer);\r\n procedure DecodeRecipients(Recips: PMapiRecipDesc; RecipCount: Integer);\r\n procedure FreeMapiMessage;\r\n procedure FreeRecipArray;\r\n function LogonFlags: DWORD;\r\n procedure RestoreTaskWindowsState;\r\n procedure SaveTaskWindowsState;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n function Address(const Caption: string = ''; EditFields: Integer = 3): Boolean;\r\n procedure Clear;\r\n function ErrorCheck(Res: DWORD): DWORD;\r\n function FindFirstMail: Boolean;\r\n function FindNextMail: Boolean;\r\n procedure FreeSimpleMapi;\r\n procedure LogOff;\r\n procedure LogOn;\r\n procedure ReadMail;\r\n function ResolveName(const Name: string): string;\r\n function SaveMail(const MessageID: string): string;\r\n procedure SendMail(ShowDialog: Boolean = True);\r\n property ReadedMail: TJvMailReadedData read FReadedMail;\r\n property SeedMessageID: string read FSeedMessageID write FSeedMessageID;\r\n property SessionHandle: THandle read FSessionHandle;\r\n property SimpleMAPI: TJclSimpleMapi read GetSimpleMapi;\r\n property UserLogged: Boolean read GetUserLogged;\r\n published\r\n property Attachment: TStrings read FAttachment write SetAttachment;\r\n property BlindCopy: TJvMailRecipients read FBlindCopy write SetBlindCopy;\r\n property Body: TStrings read FBody write SetBody;\r\n property CarbonCopy: TJvMailRecipients read FCarbonCopy write SetCarbonCopy;\r\n property LogonOptions: TJvMailLogonOptions read FLogonOptions write FLogonOptions\r\n default [loLogonUI, loNewSession];\r\n property LongMsgId: Boolean read FLongMsgId write FLongMsgId default True;\r\n property Password: string read FPassword write FPassword;\r\n property ProfileName: string read FProfileName write FProfileName;\r\n property ReadOptions: TJvMailReadOptions read FReadOptions write FReadOptions\r\n default [roFifo, roPeek];\r\n property Recipient: TJvMailRecipients read FRecipient write SetRecipient;\r\n property Subject: string read FSubject write FSubject;\r\n property OnError: TJvMailErrorEvent read FOnError write FOnError;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvMail.pas $';\r\n Revision: '$Revision: 13138 $';\r\n Date: '$Date: 2011-10-27 01:17:50 +0200 (jeu. 27 oct. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n JvResources, JclSysUtils;\r\n\r\n//=== { TJvMailRecipient } ===================================================\r\n\r\nfunction TJvMailRecipient.GetAddressAndName: string;\r\nvar\r\n N: string;\r\nbegin\r\n if Name = '' then\r\n N := Address\r\n else\r\n N := Name;\r\n Result := Format('\"%s\" <%s>', [N, Address]);\r\nend;\r\n\r\nfunction TJvMailRecipient.GetDisplayName: string;\r\nbegin\r\n if Valid then\r\n Result := AddressAndName\r\n else\r\n Result := inherited GetDisplayName;\r\nend;\r\n\r\nfunction TJvMailRecipient.GetValid: Boolean;\r\nbegin\r\n Result := FAddress <> '';\r\nend;\r\n\r\n//=== { TJvMailRecipients } ==================================================\r\n\r\nfunction TJvMailRecipients.Add: TJvMailRecipient;\r\nbegin\r\n Result := TJvMailRecipient(inherited Add);\r\nend;\r\n\r\nfunction TJvMailRecipients.AddRecipient(const Address, Name: string): Integer;\r\nvar\r\n Item: TJvMailRecipient;\r\nbegin\r\n Item := Add;\r\n Result := Item.Index;\r\n try\r\n Item.Address := Address;\r\n Item.Name := Name;\r\n except\r\n Item.Free;\r\n raise;\r\n end;\r\nend;\r\n\r\nprocedure TJvMailRecipients.Assign(Source: TPersistent);\r\nvar\r\n I: Integer;\r\nbegin\r\n if Source is TStrings then\r\n begin\r\n BeginUpdate;\r\n try\r\n for I := 0 to TStrings(Source).Count - 1 do\r\n AddRecipient(TStrings(Source)[I]);\r\n finally\r\n EndUpdate;\r\n end;\r\n end\r\n else\r\n inherited Assign(Source);\r\nend;\r\n\r\nprocedure TJvMailRecipients.AssignTo(Dest: TPersistent);\r\nvar\r\n I: Integer;\r\nbegin\r\n if Dest is TStrings then\r\n begin\r\n TStrings(Dest).BeginUpdate;\r\n try\r\n for I := 0 to Count - 1 do\r\n TStrings(Dest).Add(Items[I].Address);\r\n finally\r\n TStrings(Dest).EndUpdate;\r\n end;\r\n end\r\n else\r\n inherited AssignTo(Dest);\r\nend;\r\n\r\nconstructor TJvMailRecipients.Create(AOwner: TJvMail; ARecipientClass: DWORD);\r\nbegin\r\n inherited Create(TJvMailRecipient);\r\n FOwner := AOwner;\r\n FRecipientClass := ARecipientClass;\r\nend;\r\n\r\nfunction TJvMailRecipients.GetItem(Index: Integer): TJvMailRecipient;\r\nbegin\r\n Result := TJvMailRecipient(inherited GetItem(Index));\r\nend;\r\n\r\nfunction TJvMailRecipients.GetOwner: TPersistent;\r\nbegin\r\n Result := FOwner;\r\nend;\r\n\r\nprocedure TJvMailRecipients.SetItem(Index: Integer; const Value: TJvMailRecipient);\r\nbegin\r\n inherited SetItem(Index, Value);\r\nend;\r\n\r\n//=== { TJvMail } ============================================================\r\n\r\nconstructor TJvMail.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FAttachment := TStringList.Create;\r\n FBody := TStringList.Create;\r\n FBlindCopy := TJvMailRecipients.Create(Self, MAPI_BCC);\r\n FCarbonCopy := TJvMailRecipients.Create(Self, MAPI_CC);\r\n FRecipient := TJvMailRecipients.Create(Self, MAPI_TO);\r\n FLongMsgId := True;\r\n FLogonOptions := [loLogonUI, loNewSession];\r\n FReadOptions := [roFifo, roPeek];\r\nend;\r\n\r\ndestructor TJvMail.Destroy;\r\nbegin\r\n FreeSimpleMapi;\r\n FreeAndNil(FAttachment);\r\n FreeAndNil(FBody);\r\n FreeAndNil(FBlindCopy);\r\n FreeAndNil(FCarbonCopy);\r\n FreeAndNil(FRecipient);\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJvMail.Address(const Caption: string; EditFields: Integer): Boolean;\r\nvar\r\n NewRecipCount: ULONG;\r\n NewRecips: PMapiRecipDesc;\r\nbegin\r\n CheckLoadLib;\r\n CreateRecips;\r\n try\r\n SaveTaskWindowsState;\r\n try\r\n Result := (ErrorCheck(FSimpleMapi.MapiAddress(FSessionHandle, Application.Handle,\r\n PAnsiChar(AnsiString(Caption)), EditFields, nil, Length(FRecipArray), FRecipArray[0],\r\n LogonFlags, 0, @NewRecipCount, NewRecips)) = SUCCESS_SUCCESS);\r\n finally\r\n RestoreTaskWindowsState;\r\n end;\r\n if Result then\r\n DecodeRecipients(NewRecips, NewRecipCount);\r\n FSimpleMapi.MapiFreeBuffer(NewRecips);\r\n finally\r\n FreeRecipArray;\r\n end;\r\nend;\r\n\r\nprocedure TJvMail.BeforeClientLibUnload(Sender: TObject);\r\nbegin\r\n if UserLogged then\r\n LogOff;\r\nend;\r\n\r\nprocedure TJvMail.CheckLoadLib;\r\nbegin\r\n GetSimpleMapi;\r\n FSimpleMapi.LoadClientLib;\r\n if not FSimpleMapi.ClientLibLoaded then\r\n raise EJclMapiError.CreateRes(@RsNoClientInstalled);\r\nend;\r\n\r\nprocedure TJvMail.CheckUserLogged;\r\nbegin\r\n if not UserLogged then\r\n raise EJclMapiError.CreateRes(@RsNoUserLogged);\r\nend;\r\n\r\nprocedure TJvMail.Clear;\r\nbegin\r\n Body.Clear;\r\n BlindCopy.Clear;\r\n CarbonCopy.Clear;\r\n Recipient.Clear;\r\n Attachment.Clear;\r\n Subject := '';\r\n with FReadedMail do\r\n begin\r\n RecipientAddress := '';\r\n RecipientName := '';\r\n ConversationID := '';\r\n DateReceived := 0;\r\n end;\r\n FreeMapiMessage;\r\nend;\r\n\r\nprocedure TJvMail.CreateMapiMessage;\r\n\r\n procedure MakeAttachments;\r\n var\r\n I: Integer;\r\n begin\r\n if Attachment.Count > 0 then\r\n begin\r\n SetLength(FAttachArray, Attachment.Count);\r\n for I := 0 to Attachment.Count - 1 do\r\n begin\r\n if not FileExists(Attachment[I]) then\r\n raise EJclMapiError.CreateResFmt(@RsAttachmentNotFound, [Attachment[I]]);\r\n\r\n FillChar(FAttachArray[I], SizeOf(TMapiFileDesc), #0);\r\n FAttachArray[I].nPosition := $FFFFFFFF;\r\n FAttachArray[I].lpszFileName := StrNew(PAnsiChar(AnsiString(ExtractFileName(Attachment[I]))));\r\n FAttachArray[I].lpszPathName := StrNew(PAnsiChar(AnsiString(Attachment[I])));\r\n end;\r\n end\r\n else\r\n FAttachArray := nil;\r\n end;\r\n\r\nbegin\r\n try\r\n FillChar(FMapiMessage, SizeOf(FMapiMessage), #0);\r\n CreateRecips;\r\n MakeAttachments;\r\n\r\n FMapiMessage.lpszSubject := StrNew(PAnsiChar(AnsiString(FSubject)));\r\n FMapiMessage.lpszNoteText := StrNew(PAnsiChar(AnsiString(FBody.Text)));\r\n FMapiMessage.lpRecips := PMapiRecipDesc(FRecipArray);\r\n FMapiMessage.nRecipCount := Length(FRecipArray);\r\n FMapiMessage.lpFiles := PMapiFileDesc(FAttachArray);\r\n FMapiMessage.nFileCount := Length(FAttachArray);\r\n except\r\n FreeMapiMessage;\r\n raise;\r\n end;\r\nend;\r\n\r\nprocedure TJvMail.CreateRecips;\r\nvar\r\n RecipIndex: Integer;\r\n\r\n procedure MakeRecips(RecipList: TJvMailRecipients);\r\n var\r\n I: Integer;\r\n begin\r\n for I := 0 to RecipList.Count - 1 do\r\n begin\r\n if not RecipList[I].Valid then\r\n raise EJclMapiError.CreateResFmt(@RsRecipNotValid, [RecipList[I].GetNamePath]);\r\n\r\n FillChar(FRecipArray[RecipIndex], SizeOf(TMapiRecipDesc), #0);\r\n FRecipArray[RecipIndex].ulRecipClass := RecipList.RecipientClass;\r\n FRecipArray[RecipIndex].lpszAddress := StrNew(PAnsiChar(AnsiString(RecipList[I].Address)));\r\n if RecipList[I].Name = '' then // some clients requires Name item always filled\r\n FRecipArray[RecipIndex].lpszName := FRecipArray[RecipIndex].lpszAddress\r\n else\r\n FRecipArray[RecipIndex].lpszName := StrNew(PAnsiChar(AnsiString(RecipList[I].Name)));\r\n\r\n Inc(RecipIndex);\r\n end;\r\n end;\r\n\r\nbegin\r\n SetLength(FRecipArray, FBlindCopy.Count + FCarbonCopy.Count + FRecipient.Count);\r\n RecipIndex := 0;\r\n MakeRecips(FBlindCopy);\r\n MakeRecips(FCarbonCopy);\r\n MakeRecips(FRecipient);\r\nend;\r\n\r\nprocedure TJvMail.DecodeAttachments(Attachments: PMapiFileDesc; AttachCount: Integer);\r\nvar\r\n I: Integer;\r\nbegin\r\n Attachment.Clear;\r\n if Attachments = nil then\r\n Exit;\r\n for I := 0 to AttachCount - 1 do\r\n begin\r\n Attachment.Add(string(Attachments^.lpszPathName));\r\n Inc(Attachments);\r\n end;\r\nend;\r\n\r\nprocedure TJvMail.DecodeRecipients(Recips: PMapiRecipDesc; RecipCount: Integer);\r\nvar\r\n I: Integer;\r\nbegin\r\n FBlindCopy.Clear;\r\n FCarbonCopy.Clear;\r\n FRecipient.Clear;\r\n if Recips = nil then\r\n Exit;\r\n for I := 0 to RecipCount - 1 do\r\n begin\r\n with Recips^ do\r\n case ulRecipClass of\r\n MAPI_BCC:\r\n BlindCopy.AddRecipient(string(lpszAddress), string(lpszName));\r\n MAPI_CC:\r\n CarbonCopy.AddRecipient(string(lpszAddress), string(lpszName));\r\n MAPI_TO:\r\n Recipient.AddRecipient(string(lpszAddress), string(lpszName));\r\n end;\r\n Inc(Recips);\r\n end;\r\nend;\r\n\r\nfunction TJvMail.ErrorCheck(Res: DWORD): DWORD;\r\nbegin\r\n if Assigned(FOnError) then\r\n begin\r\n Result := Res;\r\n if Res <> SUCCESS_SUCCESS then\r\n FOnError(Self, Res);\r\n end\r\n else\r\n Result := MapiCheck(Res);\r\nend;\r\n\r\nfunction TJvMail.FindFirstMail: Boolean;\r\nbegin\r\n FSeedMessageID := '';\r\n Result := FindNextMail;\r\nend;\r\n\r\nfunction TJvMail.FindNextMail: Boolean;\r\nvar\r\n MsgID: array [0..512] of AnsiChar;\r\n Flags, Res: ULONG;\r\nbegin\r\n CheckUserLogged;\r\n Flags := 0;\r\n if FLongMsgId then\r\n Inc(Flags, MAPI_LONG_MSGID);\r\n if roFifo in FReadOptions then\r\n Inc(Flags, MAPI_GUARANTEE_FIFO);\r\n if roUnreadOnly in FReadOptions then\r\n Inc(Flags, MAPI_UNREAD_ONLY);\r\n Res := FSimpleMapi.MapiFindNext(SessionHandle, Application.Handle, nil,\r\n PAnsiChar(AnsiString(FSeedMessageID)), Flags, 0, @MsgID[0]);\r\n Result := (Res = SUCCESS_SUCCESS);\r\n if Result then\r\n FSeedMessageID := string(MsgID)\r\n else\r\n begin\r\n FSeedMessageID := '';\r\n if Res <> MAPI_E_NO_MESSAGES then\r\n ErrorCheck(Res);\r\n end;\r\nend;\r\n\r\nprocedure TJvMail.FreeMapiMessage;\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := 0 to High(FAttachArray) do\r\n begin\r\n if FAttachArray[I].lpszPathName <> FAttachArray[I].lpszFileName then\r\n StrDispose(FAttachArray[I].lpszPathName);\r\n StrDispose(FAttachArray[I].lpszFileName);\r\n end;\r\n FAttachArray := nil;\r\n FreeRecipArray;\r\n StrDispose(FMapiMessage.lpszSubject);\r\n StrDispose(FMapiMessage.lpszNoteText);\r\n FillChar(FMapiMessage, SizeOf(FMapiMessage), #0);\r\nend;\r\n\r\nprocedure TJvMail.FreeRecipArray;\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := 0 to High(FRecipArray) do\r\n begin\r\n if FRecipArray[I].lpszName <> FRecipArray[I].lpszAddress then\r\n StrDispose(FRecipArray[I].lpszName);\r\n StrDispose(FRecipArray[I].lpszAddress);\r\n end;\r\n FRecipArray := nil;\r\nend;\r\n\r\nprocedure TJvMail.FreeSimpleMapi;\r\nbegin\r\n try\r\n if FSimpleMapi <> nil then\r\n begin\r\n FSimpleMapi.BeforeUnloadClient := nil; // prevent memory leak\r\n LogOff;\r\n end;\r\n finally\r\n FreeAndNil(FSimpleMapi);\r\n end;\r\nend;\r\n\r\nfunction TJvMail.GetSimpleMapi: TJclSimpleMapi;\r\nbegin\r\n if not Assigned(FSimpleMapi) then\r\n begin\r\n FSimpleMapi := TJclSimpleMapi.Create;\r\n FSimpleMapi.BeforeUnloadClient := BeforeClientLibUnload;\r\n end;\r\n Result := FSimpleMapi;\r\nend;\r\n\r\nfunction TJvMail.GetUserLogged: Boolean;\r\nbegin\r\n Result := FSessionHandle <> 0;\r\nend;\r\n\r\nprocedure TJvMail.LogOff;\r\nbegin\r\n CheckLoadLib;\r\n if UserLogged then\r\n begin\r\n ErrorCheck(FSimpleMapi.MapiLogOff(FSessionHandle, Application.Handle, 0, 0));\r\n FSessionHandle := 0;\r\n end;\r\nend;\r\n\r\nprocedure TJvMail.LogOn;\r\nbegin\r\n CheckLoadLib;\r\n if UserLogged then\r\n Exit;\r\n SaveTaskWindowsState;\r\n try\r\n ErrorCheck(FSimpleMapi.MapiLogOn(Application.Handle, PAnsiChar(AnsiString(FProfileName)),\r\n PAnsiChar(AnsiString(FPassword)), LogonFlags, 0, @FSessionHandle));\r\n finally\r\n RestoreTaskWindowsState;\r\n end;\r\nend;\r\n\r\nfunction TJvMail.LogonFlags: DWORD;\r\nbegin\r\n Result := 0;\r\n if not UserLogged then\r\n begin\r\n if loLogonUI in FLogonOptions then\r\n Inc(Result, MAPI_LOGON_UI);\r\n if loNewSession in FLogonOptions then\r\n Inc(Result, MAPI_NEW_SESSION);\r\n if loDownloadMail in FLogonOptions then\r\n Inc(Result, MAPI_FORCE_DOWNLOAD);\r\n end;\r\nend;\r\n\r\nprocedure TJvMail.ReadMail;\r\nvar\r\n Flags: ULONG;\r\n Msg: PMapiMessage;\r\n SOldDateFormat: string;\r\n OldDateSeparator: Char;\r\nbegin\r\n CheckUserLogged;\r\n Clear;\r\n Flags := 0;\r\n if roHeaderOnly in FReadOptions then\r\n Inc(Flags, MAPI_ENVELOPE_ONLY);\r\n if roPeek in FReadOptions then\r\n Inc(Flags, MAPI_PEEK);\r\n if not (roAttachments in FReadOptions) then\r\n Inc(Flags, MAPI_SUPPRESS_ATTACH);\r\n ErrorCheck(FSimpleMapi.MapiReadMail(SessionHandle, Application.Handle,\r\n PAnsiChar(AnsiString(FSeedMessageID)), Flags, 0, Msg));\r\n with Msg^ do\r\n begin\r\n if lpOriginator <> nil then\r\n begin\r\n FReadedMail.RecipientAddress := string(lpOriginator^.lpszAddress);\r\n FReadedMail.RecipientName := string(lpOriginator^.lpszName);\r\n end;\r\n DecodeRecipients(lpRecips, nRecipCount);\r\n FSubject := string(lpszSubject);\r\n Body.Text := string(lpszNoteText);\r\n // FDateReceived := StrToDateTime(lpszDateReceived);\r\n SOldDateFormat := JclFormatSettings.ShortDateFormat;\r\n OldDateSeparator := JclFormatSettings.DateSeparator;\r\n try\r\n JclFormatSettings.ShortDateFormat := 'yyyy/M/d';\r\n JclFormatSettings.DateSeparator := '/';\r\n FReadedMail.DateReceived := StrToDateTime(string(lpszDateReceived));\r\n finally\r\n JclFormatSettings.ShortDateFormat := SOldDateFormat;\r\n JclFormatSettings.DateSeparator := OldDateSeparator;\r\n end;\r\n FReadedMail.ConversationID := string(lpszConversationID);\r\n DecodeAttachments(lpFiles, nFileCount);\r\n end;\r\n FSimpleMapi.MapiFreeBuffer(Msg);\r\nend;\r\n\r\nfunction TJvMail.ResolveName(const Name: string): string;\r\nvar\r\n RecipDesc: PMapiRecipDesc;\r\n Res: DWORD;\r\nbegin\r\n Result := '';\r\n CheckLoadLib;\r\n SaveTaskWindowsState;\r\n Res := FSimpleMapi.MapiResolveName(SessionHandle, Application.Handle,\r\n PAnsiChar(AnsiString(Name)), LogonFlags or MAPI_AB_NOMODIFY or MAPI_DIALOG, 0, RecipDesc);\r\n RestoreTaskWindowsState;\r\n if (Res <> MAPI_E_AMBIGUOUS_RECIPIENT) and (Res <> MAPI_E_UNKNOWN_RECIPIENT) then\r\n begin\r\n Result := string(RecipDesc^.lpszName);\r\n FSimpleMapi.MapiFreeBuffer(RecipDesc);\r\n ErrorCheck(Res);\r\n end;\r\nend;\r\n\r\nprocedure TJvMail.RestoreTaskWindowsState;\r\nvar\r\n I: Integer;\r\nbegin\r\n if (FSaveTaskWindows <> nil) and (Length(FSaveTaskWindows) >= Screen.FormCount) then\r\n for I := 0 to Screen.FormCount - 1 do\r\n EnableWindow(Screen.Forms[I].Handle, FSaveTaskWindows[I]);\r\n FSaveTaskWindows := nil;\r\n if FSaveTaskActiveForm <> nil then\r\n SetFocus(FSaveTaskActiveForm.Handle);\r\nend;\r\n\r\nfunction TJvMail.SaveMail(const MessageID: string): string;\r\nvar\r\n MsgID: array [0..512] of AnsiChar;\r\n Flags: ULONG;\r\nbegin\r\n Result := '';\r\n CheckLoadLib;\r\n CreateMapiMessage;\r\n try\r\n StrPCopy(MsgID, AnsiString(MessageID));\r\n SaveTaskWindowsState;\r\n Flags := LogonFlags;\r\n if FLongMsgId then\r\n Flags := Flags or MAPI_LONG_MSGID;\r\n try\r\n ErrorCheck(FSimpleMapi.MapiSaveMail(FSessionHandle, Application.Handle,\r\n FMapiMessage, Flags, 0, MsgID));\r\n finally\r\n RestoreTaskWindowsState;\r\n end;\r\n Result := string(MsgID);\r\n finally\r\n FreeMapiMessage;\r\n end;\r\nend;\r\n\r\nprocedure TJvMail.SaveTaskWindowsState;\r\nvar\r\n I: Integer;\r\n W: HWND;\r\nbegin\r\n SetLength(FSaveTaskWindows, Screen.FormCount);\r\n FSaveTaskActiveForm := Screen.ActiveForm;\r\n for I := 0 to Screen.FormCount - 1 do\r\n begin\r\n W := Screen.Forms[I].Handle;\r\n FSaveTaskWindows[I] := IsWindowEnabled(W);\r\n EnableWindow(W, False);\r\n end;\r\nend;\r\n\r\nprocedure TJvMail.SendMail(ShowDialog: Boolean);\r\nvar\r\n Flags: ULONG;\r\nbegin\r\n CheckLoadLib;\r\n CreateMapiMessage;\r\n try\r\n Flags := LogonFlags;\r\n if ShowDialog then\r\n Flags := Flags or MAPI_DIALOG;\r\n SaveTaskWindowsState;\r\n try\r\n ErrorCheck(FSimpleMapi.MapiSendMail(FSessionHandle, Application.Handle,\r\n FMapiMessage, Flags, 0));\r\n finally\r\n RestoreTaskWindowsState;\r\n end;\r\n finally\r\n FreeMapiMessage;\r\n end;\r\nend;\r\n\r\nprocedure TJvMail.SetAttachment(const Value: TStrings);\r\nbegin\r\n FAttachment.Assign(Value);\r\nend;\r\n\r\nprocedure TJvMail.SetBlindCopy(const Value: TJvMailRecipients);\r\nbegin\r\n FBlindCopy.Assign(Value);\r\nend;\r\n\r\nprocedure TJvMail.SetBody(const Value: TStrings);\r\nbegin\r\n FBody.Assign(Value);\r\nend;\r\n\r\nprocedure TJvMail.SetCarbonCopy(const Value: TJvMailRecipients);\r\nbegin\r\n FCarbonCopy.Assign(Value);\r\nend;\r\n\r\nprocedure TJvMail.SetRecipient(const Value: TJvMailRecipients);\r\nbegin\r\n FRecipient.Assign(Value);\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend." }, { "path": "External/Jedi/Jvcl/run/JvMailSlots.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvgMailSlots.PAS, released on 2003-01-15.\r\n\r\nThe Initial Developer of the Original Code is Andrey V. Chudin, [chudin att yandex dott ru]\r\nPortions created by Andrey V. Chudin are Copyright (C) 2003 Andrey V. Chudin.\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\nMichael Beck [mbeck att bigfoot dott com].\r\nBurov Dmitry, translation of russian text.\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\nDelivery network messages longer then 424 bytes requires installation of\r\nNetBEUI protocol. There is no direct support of this old protocol in XP\r\nbut driver is available for manual installation (search for 'NetBEUI' on\r\nwww.microsoft.com). Delivery network messages longer then 1365 bytes can be\r\nproblem too (if it's possible at all).\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvMailSlots.pas 13138 2011-10-26 23:17:50Z jfudickar $\r\n\r\nunit JvMailSlots;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, Messages, SysUtils, Classes, Graphics,\r\n Controls, Forms, Dialogs, ExtCtrls,\r\n JvComponentBase;\r\n\r\ntype\r\n TOnNewMessage = procedure(Sender: TObject; MessageText: string) of object;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvMailSlotServer = class(TJvComponent)\r\n private\r\n FMailSlotName: string;\r\n FLastMessage: string;\r\n FOnNewMessage: TOnNewMessage;\r\n FOnError: TNotifyEvent;\r\n FTimer: TTimer;\r\n FDeliveryCheckInterval: Integer;\r\n FHandle: THandle;\r\n FData: TMemoryStream;\r\n procedure SetMailSlotName(const SlotName: string);\r\n procedure SetDeliveryCheckInterval(Value: Integer);\r\n procedure OnTimer(Sender: TObject);\r\n function GetMessageDataPointer: Pointer;\r\n function GetMessageLength: LongWord;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n procedure Open;\r\n procedure Close;\r\n // Message as binary data:\r\n property MessageData: Pointer read GetMessageDataPointer;\r\n property MessageLength: LongWord read GetMessageLength;\r\n published\r\n property MailSlotName: string read FMailSlotName write SetMailSlotName;\r\n property DeliveryCheckInterval: Integer read FDeliveryCheckInterval write SetDeliveryCheckInterval default 1000;\r\n property OnNewMessage: TOnNewMessage read FOnNewMessage write FOnNewMessage;\r\n property OnError: TNotifyEvent read FOnError write FOnError;\r\n end;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvMailSlotClient = class(TJvComponent)\r\n private\r\n FMailSlotName: string;\r\n FServerName: string;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n function Send(const Msg: string): Boolean; overload;\r\n // For sending binary data\r\n function Send(const MessageData; MessageLength: LongWord): Boolean; overload;\r\n published\r\n property ServerName: string read FServerName write FServerName;\r\n property MailSlotName: string read FMailSlotName write FMailSlotName;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvMailSlots.pas $';\r\n Revision: '$Revision: 13138 $';\r\n Date: '$Date: 2011-10-27 01:17:50 +0200 (jeu. 27 oct. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n JvResources;\r\n\r\nconstructor TJvMailSlotServer.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FTimer := TTimer.Create(nil);\r\n FTimer.Enabled := False;\r\n FTimer.OnTimer := OnTimer;\r\n\r\n FMailSlotName := 'MailSlot';\r\n FHandle := INVALID_HANDLE_VALUE;\r\n FData := TMemoryStream.Create;\r\n\r\n FDeliveryCheckInterval := 1000;\r\n FTimer.Interval := FDeliveryCheckInterval;\r\nend;\r\n\r\ndestructor TJvMailSlotServer.Destroy;\r\nbegin\r\n Close;\r\n FTimer.Free;\r\n FData.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvMailSlotServer.Open;\r\nbegin\r\n Close;\r\n // FHandle := CreateMailSlot(PChar('\\\\.\\mailslot\\' + MailSlotName), 0, MAILSLOT_WAIT_FOREVER, nil);\r\n // IMO Immediate return is better (no chance of hang up)\r\n FHandle := CreateMailSlot(PChar('\\\\.\\mailslot\\' + MailSlotName), High(Word), 0 , nil);\r\n if FHandle = INVALID_HANDLE_VALUE then\r\n raise Exception.CreateRes(@RsJvMailSlotServerErrorCreatingChan);\r\n FTimer.Enabled := True;\r\nend;\r\n\r\nprocedure TJvMailSlotServer.Close;\r\nbegin\r\n if FHandle <> INVALID_HANDLE_VALUE then\r\n begin\r\n CloseHandle(FHandle);\r\n FHandle := INVALID_HANDLE_VALUE;\r\n end;\r\n FTimer.Enabled := False;\r\nend;\r\n\r\nprocedure TJvMailSlotServer.SetMailSlotName(const SlotName: string);\r\nbegin\r\n if FMailSlotName <> SlotName then\r\n begin\r\n Close;\r\n FMailSlotName := SlotName;\r\n end;\r\nend;\r\n\r\nprocedure TJvMailSlotServer.SetDeliveryCheckInterval(Value: Integer);\r\nbegin\r\n if Value < 1 then\r\n Value := 1;\r\n FTimer.Interval := Value;\r\n FDeliveryCheckInterval := Value;\r\nend;\r\n\r\nprocedure TJvMailSlotServer.OnTimer(Sender: TObject);\r\nvar\r\n MsgSize: DWORD;\r\n MsgNumber: DWORD;\r\n Read: DWORD;\r\n Buffer: Pointer;\r\nbegin\r\n // Determining if there's message\r\n if not GetMailSlotInfo(FHandle, nil, MsgSize, @MsgNumber, nil) then\r\n begin\r\n if Assigned(FOnError) then\r\n FOnError(Self) // user-defined handling\r\n else\r\n // default error notification; not recommended:\r\n // if error is permanent it will produce endless exceptions in timer\r\n raise Exception.CreateRes(@RsJvMailSlotServerErrorGatheringInf);\r\n end\r\n else\r\n begin\r\n if MsgSize <> MAILSLOT_NO_MESSAGE then\r\n begin\r\n // Allocate memory for the message\r\n FData.Size := MsgSize;\r\n Buffer := FData.Memory;\r\n // Reading message\r\n if ReadFile(FHandle, Buffer^, MsgSize, Read, nil) then\r\n begin\r\n SetString(FLastMessage, PChar(Buffer), (MsgSize - 1) div SizeOf(Char)); // exclude trailing #0\r\n if Assigned(FOnNewMessage) then\r\n FOnNewMessage(Self, FLastMessage);\r\n end\r\n else\r\n begin\r\n if Assigned(FOnError) then\r\n FOnError(Self) // user-defined handling\r\n else\r\n // default error notification; not recommended:\r\n // if error is permanent it will produce endless exceptions in timer\r\n raise Exception.CreateRes(@RsJvMailSlotServerErrorReadingMessa);\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJvMailSlotServer.GetMessageDataPointer: Pointer;\r\nbegin\r\n Result := FData.Memory;\r\nend;\r\n\r\nfunction TJvMailSlotServer.GetMessageLength: LongWord;\r\nbegin\r\n Result := FData.Size;\r\nend;\r\n\r\n//------------------------------------------------------------------------------\r\n\r\nconstructor TJvMailSlotClient.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FMailSlotName := 'MailSlot';\r\n FServerName := '';\r\nend;\r\n\r\nfunction TJvMailSlotClient.Send(const Msg: string): Boolean;\r\nvar\r\n Buffer: PChar;\r\nbegin\r\n Buffer := PChar(Msg);\r\n Result := Send(Pointer(Buffer)^, (Length(Msg) + 1) * SizeOf(Char)); // include trailing #0\r\nend;\r\n\r\nfunction TJvMailSlotClient.Send(const MessageData; MessageLength: LongWord): Boolean;\r\nvar\r\n FHandle: THandle;\r\n Written: DWORD;\r\nbegin\r\n if FServerName = '' then\r\n FServerName := '.\\'; // the same computer\r\n FHandle := CreateFile(PChar('\\\\' + FServerName + '\\mailslot\\' + FMailSlotName),\r\n GENERIC_WRITE, FILE_SHARE_READ, nil, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0);\r\n Result := FHandle <> INVALID_HANDLE_VALUE;\r\n if Result then\r\n begin\r\n Result := WriteFile(FHandle, MessageData, MessageLength, Written, nil);\r\n CloseHandle(FHandle);\r\n end;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend." }, { "path": "External/Jedi/Jvcl/run/JvMarkupCommon.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvMarkupCommon.PAS, released on 2002-06-15.\r\n\r\nThe Initial Developer of the Original Code is Jan Verhoeven [jan1 dott verhoeven att wxs dott nl]\r\nPortions created by Jan Verhoeven are Copyright (C) 2002 Jan Verhoeven.\r\nAll Rights Reserved.\r\n\r\nContributor(s): Robert Love [rlove att slcdug dott org].\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n * Classes extracted from JvMarkupLabel and JvMarkupViewer (duplicates)\r\n\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvMarkupCommon.pas 12461 2009-08-14 17:21:33Z obones $\r\n\r\nunit JvMarkupCommon;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, Controls, Graphics, SysUtils, Classes;\r\n\r\ntype\r\n TJvHTMLElement = class(TObject)\r\n private\r\n FFontSize: Integer;\r\n FText: string;\r\n FFontName: string;\r\n FFontStyle: TFontStyles;\r\n FFontColor: TColor;\r\n FAscent: Integer;\r\n FHeight: Integer;\r\n FWidth: Integer;\r\n FSolText: string;\r\n FEolText: string;\r\n FBreakLine: Boolean;\r\n procedure SetFontName(const Value: string);\r\n procedure SetFontSize(const Value: Integer);\r\n procedure SetFontStyle(const Value: TFontStyles);\r\n procedure SetText(const Value: string);\r\n procedure SetFontColor(const Value: TColor);\r\n procedure SetAscent(const Value: Integer);\r\n procedure SetHeight(const Value: Integer);\r\n procedure SetWidth(const Value: Integer);\r\n procedure SetEolText(const Value: string);\r\n procedure SetSolText(const Value: string);\r\n procedure SetBreakLine(const Value: Boolean);\r\n public\r\n procedure Breakup(ACanvas: TCanvas; Available: Integer);\r\n property Text: string read FText write SetText;\r\n property SolText: string read FSolText write SetSolText;\r\n property EolText: string read FEolText write SetEolText;\r\n property FontName: string read FFontName write SetFontName;\r\n property FontSize: Integer read FFontSize write SetFontSize;\r\n property FontStyle: TFontStyles read FFontStyle write SetFontStyle;\r\n property FontColor: TColor read FFontColor write SetFontColor;\r\n property Height: Integer read FHeight write SetHeight;\r\n property Width: Integer read FWidth write SetWidth;\r\n property Ascent: Integer read FAscent write SetAscent;\r\n property BreakLine: Boolean read FBreakLine write SetBreakLine;\r\n end;\r\n\r\n TJvHTMLElementStack = class(TList)\r\n public\r\n destructor Destroy; override;\r\n procedure Clear; override;\r\n // will free ALL elements in the stack\r\n procedure Push(Element: TJvHTMLElement);\r\n function Pop: TJvHTMLElement;\r\n // calling routine is responsible for freeing the element.\r\n function Peek: TJvHTMLElement;\r\n // calling routine must NOT free the element\r\n end;\r\n\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvMarkupCommon.pas $';\r\n Revision: '$Revision: 12461 $';\r\n Date: '$Date: 2009-08-14 19:21:33 +0200 (ven. 14 août 2009) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\n\r\n//=== { TJvHTMLElement } =====================================================\r\n\r\nprocedure TJvHTMLElement.Breakup(ACanvas: TCanvas; Available: Integer);\r\nvar\r\n S: string;\r\n I, W: Integer;\r\nbegin\r\n ACanvas.Font.Name := FontName;\r\n ACanvas.Font.Size := FontSize;\r\n ACanvas.Font.Style := FontStyle;\r\n ACanvas.Font.Color := FontColor;\r\n if SolText = '' then\r\n S := Text\r\n else\r\n S := EolText;\r\n if ACanvas.TextWidth(S) <= Available then\r\n begin\r\n SolText := S;\r\n EolText := '';\r\n Exit;\r\n end;\r\n for I := Length(S) downto 1 do\r\n begin\r\n if S[I] = ' ' then\r\n begin\r\n W := ACanvas.TextWidth(Copy(S, 1, I));\r\n if W <= Available then\r\n begin\r\n SolText := Copy(S, 1, I);\r\n EolText := Copy(S, I + 1, Length(S));\r\n Break;\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvHTMLElement.SetAscent(const Value: Integer);\r\nbegin\r\n FAscent := Value;\r\nend;\r\n\r\nprocedure TJvHTMLElement.SetBreakLine(const Value: Boolean);\r\nbegin\r\n FBreakLine := Value;\r\nend;\r\n\r\nprocedure TJvHTMLElement.SetEolText(const Value: string);\r\nbegin\r\n FEolText := Value;\r\nend;\r\n\r\nprocedure TJvHTMLElement.SetFontColor(const Value: TColor);\r\nbegin\r\n FFontColor := Value;\r\nend;\r\n\r\nprocedure TJvHTMLElement.SetFontName(const Value: string);\r\nbegin\r\n FFontName := Value;\r\nend;\r\n\r\nprocedure TJvHTMLElement.SetFontSize(const Value: Integer);\r\nbegin\r\n FFontSize := Value;\r\nend;\r\n\r\nprocedure TJvHTMLElement.SetFontStyle(const Value: TFontStyles);\r\nbegin\r\n FFontStyle := Value;\r\nend;\r\n\r\nprocedure TJvHTMLElement.SetHeight(const Value: Integer);\r\nbegin\r\n FHeight := Value;\r\nend;\r\n\r\nprocedure TJvHTMLElement.SetSolText(const Value: string);\r\nbegin\r\n FSolText := Value;\r\nend;\r\n\r\nprocedure TJvHTMLElement.SetText(const Value: string);\r\nbegin\r\n FText := Value;\r\nend;\r\n\r\nprocedure TJvHTMLElement.SetWidth(const Value: Integer);\r\nbegin\r\n FWidth := Value;\r\nend;\r\n\r\n//=== { TJvHTMLElementStack } ================================================\r\n\r\ndestructor TJvHTMLElementStack.Destroy;\r\nbegin\r\n Clear;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvHTMLElementStack.Clear;\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := Count - 1 downto 0 do\r\n TJvHTMLElement(Items[I]).Free;\r\n inherited Clear;\r\nend;\r\n\r\nfunction TJvHTMLElementStack.Peek: TJvHTMLElement;\r\nbegin\r\n if Count = 0 then\r\n Result := nil\r\n else\r\n Result := TJvHTMLElement(Items[Count - 1]);\r\nend;\r\n\r\nfunction TJvHTMLElementStack.Pop: TJvHTMLElement;\r\nbegin\r\n if Count = 0 then\r\n Result := nil\r\n else\r\n begin\r\n Result := TJvHTMLElement(Items[Count - 1]);\r\n Delete(Count - 1);\r\n end;\r\nend;\r\n\r\nprocedure TJvHTMLElementStack.Push(Element: TJvHTMLElement);\r\nbegin\r\n Add(Element);\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend." }, { "path": "External/Jedi/Jvcl/run/JvMarkupLabel.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvMarkupLabel.PAS, released on 2002-06-15.\r\n\r\nThe Initial Developer of the Original Code is Jan Verhoeven [jan1 dott verhoeven att wxs dott nl]\r\nPortions created by Jan Verhoeven are Copyright (C) 2002 Jan Verhoeven.\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\nRobert Love [rlove att slcdug dott org].\r\nLionel Reynaud\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvMarkupLabel.pas 13104 2011-09-07 06:50:43Z obones $\r\n\r\nunit JvMarkupLabel;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, Messages, Graphics, Controls,\r\n SysUtils, Classes,\r\n JvComponent, JvMarkupCommon;\r\n\r\ntype\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvMarkupLabel = class(TJvPubGraphicControl)\r\n private\r\n FElementStack: TJvHTMLElementStack;\r\n FTagStack: TJvHTMLElementStack;\r\n FMarginLeft: Integer;\r\n FMarginRight: Integer;\r\n FMarginTop: Integer;\r\n FAlignment: TAlignment;\r\n FText: TCaption;\r\n procedure Refresh;\r\n procedure ParseHTML(S: string);\r\n procedure RenderHTML;\r\n procedure HTMLClearBreaks;\r\n procedure HTMLElementDimensions;\r\n procedure SetMarginLeft(const Value: Integer);\r\n procedure SetMarginRight(const Value: Integer);\r\n procedure SetMarginTop(const Value: Integer);\r\n procedure SetAlignment(const Value: TAlignment);\r\n procedure DoReadBackColor(Reader: TReader);\r\n protected\r\n procedure FontChanged; override;\r\n procedure SetText(const Value: TCaption);\r\n procedure SetAutoSize(Value: Boolean); override;\r\n procedure DefineProperties(Filer: TFiler); override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n procedure Paint; override;\r\n published\r\n property Height default 100;\r\n property Width default 200;\r\n property MarginLeft: Integer read FMarginLeft write SetMarginLeft default 5;\r\n property MarginRight: Integer read FMarginRight write SetMarginRight default 5;\r\n property MarginTop: Integer read FMarginTop write SetMarginTop default 5;\r\n property Alignment: TAlignment read FAlignment write SetAlignment default taLeftJustify;\r\n property Text: TCaption read FText write SetText;\r\n property AutoSize;\r\n property Align;\r\n property Font;\r\n property Anchors;\r\n property Enabled;\r\n property Color default clBtnFace; // Duplicates BackColor\r\n property Constraints;\r\n property ParentColor default True;\r\n property ParentFont;\r\n property ParentShowHint;\r\n property PopupMenu;\r\n property ShowHint;\r\n property Visible;\r\n property OnClick;\r\n property OnContextPopup;\r\n property OnDblClick;\r\n property OnDragDrop;\r\n property OnDragOver;\r\n property OnEndDrag;\r\n property OnMouseDown;\r\n property OnMouseMove;\r\n property OnMouseUp;\r\n property OnMouseEnter;\r\n property OnMouseLeave;\r\n property OnStartDrag;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvMarkupLabel.pas $';\r\n Revision: '$Revision: 13104 $';\r\n Date: '$Date: 2011-09-07 08:50:43 +0200 (mer. 07 sept. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n {$IFNDEF COMPILER12_UP}\r\n JvJCLUtils,\r\n {$ENDIF ~COMPILER12_UP}\r\n JvConsts, JvThemes;\r\n\r\nconstructor TJvMarkupLabel.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n IncludeThemeStyle(Self, [csParentBackground]);\r\n FElementStack := TJvHTMLElementStack.Create;\r\n FTagStack := TJvHTMLElementStack.Create;\r\n FAlignment := taLeftJustify;\r\n Width := 200;\r\n Height := 100;\r\n FMarginLeft := 5;\r\n FMarginRight := 5;\r\n FMarginTop := 5;\r\n Color := clBtnFace;\r\n ParentColor := True;\r\nend;\r\n\r\ndestructor TJvMarkupLabel.Destroy;\r\nbegin\r\n FElementStack.Free;\r\n FTagStack.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvMarkupLabel.HTMLClearBreaks;\r\nvar\r\n I, C: Integer;\r\n El: TJvHTMLElement;\r\nbegin\r\n C := FElementStack.Count;\r\n if C = 0 then\r\n Exit;\r\n for I := 0 to C - 1 do\r\n begin\r\n El := TJvHTMLElement(FElementStack.Items[I]);\r\n El.SolText := '';\r\n El.EolText := '';\r\n end;\r\nend;\r\n\r\nprocedure TJvMarkupLabel.HTMLElementDimensions;\r\nvar\r\n I, C: Integer;\r\n El: TJvHTMLElement;\r\n H, A, W: Integer;\r\n Tm: TTextMetric;\r\n S: string;\r\nbegin\r\n C := FElementStack.Count;\r\n if C = 0 then\r\n Exit;\r\n for I := 0 to C - 1 do\r\n begin\r\n El := TJvHTMLElement(FElementStack.Items[I]);\r\n S := El.Text;\r\n Canvas.Font.Name := El.FontName;\r\n Canvas.Font.Size := El.FontSize;\r\n Canvas.Font.Style := El.FontStyle;\r\n Canvas.Font.Color := El.FontColor;\r\n GetTextMetrics(Canvas.Handle, Tm);\r\n H := Tm.tmHeight;\r\n A := Tm.tmAscent;\r\n W := Canvas.TextWidth(S);\r\n El.Height := H;\r\n El.Ascent := A;\r\n El.Width := W;\r\n end;\r\nend;\r\n\r\nprocedure TJvMarkupLabel.Refresh;\r\nbegin\r\n ParseHTML(FText);\r\n HTMLElementDimensions;\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvMarkupLabel.Paint;\r\nbegin\r\n RenderHTML;\r\nend;\r\n\r\nprocedure TJvMarkupLabel.FontChanged;\r\nbegin\r\n inherited FontChanged;\r\n Refresh;\r\nend;\r\n\r\nprocedure TJvMarkupLabel.ParseHTML(S: string);\r\nvar\r\n P: Integer;\r\n SE, ST: string;\r\n FText: string;\r\n FStyle: TFontStyles;\r\n FName: string;\r\n FSize: Integer;\r\n FBreakLine: Boolean;\r\n AColor, FColor: TColor;\r\n Element: TJvHTMLElement;\r\n\r\n function HTMLStringToColor(V: string; var Col: TColor): Boolean;\r\n var\r\n VV: string;\r\n begin\r\n Result := False;\r\n if Length(V) < 2 then\r\n Exit;\r\n if not CharInSet(V[1], ['#', '$']) then\r\n begin\r\n // allow the use of both \"clBlack\" and \"Black\"\r\n if Pos('cl', AnsiLowerCase(V)) = 1 then\r\n VV := V\r\n else\r\n VV := 'cl' + V;\r\n try\r\n Col := StringToColor(VV);\r\n Result := True;\r\n except\r\n Result := False;\r\n end;\r\n end\r\n else\r\n // this is either #FFFFFF or $FFFFFF - we treat them the same\r\n begin\r\n try\r\n VV := '$' + Copy(V, 6, 2) + Copy(V, 4, 2) + Copy(V, 2, 2);\r\n Col := StringToColor(VV);\r\n Result := True;\r\n except\r\n Result := False;\r\n end\r\n end;\r\n end;\r\n\r\n procedure PushTag;\r\n begin\r\n Element := TJvHTMLElement.Create;\r\n Element.FontName := FName;\r\n Element.FontSize := FSize;\r\n Element.FontStyle := FStyle;\r\n Element.FontColor := FColor;\r\n FTagStack.Push(Element);\r\n end;\r\n\r\n procedure PopTag;\r\n begin\r\n Element := FTagStack.Pop;\r\n if Element <> nil then\r\n begin\r\n FName := Element.FontName;\r\n FSize := Element.FontSize;\r\n FStyle := Element.FontStyle;\r\n FColor := Element.FontColor;\r\n Element.Free;\r\n end;\r\n end;\r\n\r\n procedure PushElement;\r\n begin\r\n Element := TJvHTMLElement.Create;\r\n Element.Text := FText;\r\n Element.FontName := FName;\r\n Element.FontSize := FSize;\r\n Element.FontStyle := FStyle;\r\n Element.FontColor := FColor;\r\n Element.BreakLine := FBreakLine;\r\n FBreakLine := False;\r\n FElementStack.Push(Element);\r\n end;\r\n\r\n procedure ParseTag(SS: string);\r\n var\r\n PP: Integer;\r\n ATag, APar, AVal: string;\r\n HaveParams: Boolean;\r\n begin\r\n SS := Trim(SS);\r\n HaveParams := False;\r\n PP := Pos(' ', SS);\r\n if PP = 0 then\r\n ATag := SS // tag only\r\n else\r\n begin // tag + attributes\r\n ATag := Copy(SS, 1, PP - 1);\r\n SS := Trim(Copy(SS, PP + 1, Length(SS)));\r\n HaveParams := True;\r\n end;\r\n // handle ATag\r\n ATag := LowerCase(ATag);\r\n if ATag = 'br' then\r\n FBreakLine := True\r\n else\r\n if ATag = 'b' then\r\n begin // bold\r\n PushTag;\r\n FStyle := FStyle + [fsBold];\r\n end\r\n else\r\n if ATag = '/b' then\r\n begin // cancel bold\r\n FStyle := FStyle - [fsBold];\r\n PopTag;\r\n end\r\n else\r\n if ATag = 'i' then\r\n begin // italic\r\n PushTag;\r\n FStyle := FStyle + [fsItalic];\r\n end\r\n else\r\n if ATag = '/i' then\r\n begin // cancel italic\r\n FStyle := FStyle - [fsItalic];\r\n PopTag;\r\n end\r\n else\r\n if ATag = 'u' then\r\n begin // underline\r\n PushTag;\r\n FStyle := FStyle + [fsUnderline];\r\n end\r\n else\r\n if ATag = '/u' then\r\n begin // cancel underline\r\n FStyle := FStyle - [fsUnderline];\r\n PopTag;\r\n end\r\n else\r\n if ATag = 'font' then\r\n PushTag\r\n else\r\n if ATag = '/font' then\r\n PopTag;\r\n if HaveParams then\r\n begin\r\n repeat\r\n PP := Pos('=\"', SS);\r\n if PP > 0 then\r\n begin\r\n APar := LowerCase(Trim(Copy(SS, 1, PP - 1)));\r\n Delete(SS, 1, PP + 1);\r\n PP := Pos('\"', SS);\r\n if PP > 0 then\r\n begin\r\n AVal := Copy(SS, 1, PP - 1);\r\n Delete(SS, 1, PP);\r\n if APar = 'face' then\r\n FName := AVal\r\n else\r\n if APar = 'size' then\r\n try\r\n FSize := StrToInt(AVal);\r\n except\r\n end\r\n else\r\n if APar = 'color' then\r\n try\r\n if HTMLStringToColor(AVal, AColor) then\r\n FColor := AColor;\r\n except\r\n end;\r\n end;\r\n end;\r\n until PP = 0;\r\n end;\r\n end;\r\n\r\nbegin\r\n FElementStack.Clear;\r\n FTagStack.Clear;\r\n FStyle := Font.Style;\r\n FName := Font.Name;\r\n FSize := Font.Size;\r\n FColor := Font.Color;\r\n FBreakLine := False;\r\n repeat\r\n P := Pos('<', S);\r\n if P = 0 then\r\n begin\r\n FText := S;\r\n PushElement;\r\n end\r\n else\r\n begin\r\n if P > 1 then\r\n begin\r\n SE := Copy(S, 1, P - 1);\r\n FText := SE;\r\n PushElement;\r\n Delete(S, 1, P - 1);\r\n end;\r\n P := Pos('>', S);\r\n if P > 0 then\r\n begin\r\n ST := Copy(S, 2, P - 2);\r\n Delete(S, 1, P);\r\n ParseTag(ST);\r\n end;\r\n end;\r\n until P = 0;\r\nend;\r\n\r\nprocedure TJvMarkupLabel.RenderHTML;\r\nvar\r\n R: TRect;\r\n I, C, X, Y: Integer;\r\n ATotalWidth, AClientWidth, ATextWidth, BaseLine: Integer;\r\n iSol, iEol, PendingCount, MaxHeight, MaxAscent: Integer;\r\n El: TJvHTMLElement;\r\n Eol: Boolean;\r\n PendingBreak: Boolean;\r\n lSolText: string;\r\n MaxWidth: Integer;\r\n\r\n procedure SetFont(EE: TJvHTMLElement);\r\n begin\r\n with Canvas do\r\n begin\r\n Font.Name := EE.FontName;\r\n Font.Size := EE.FontSize;\r\n Font.Style := EE.FontStyle;\r\n Font.Color := EE.FontColor;\r\n end;\r\n end;\r\n\r\n procedure RenderString(EE: TJvHTMLElement; Test: Boolean);\r\n var\r\n SS: string;\r\n WW: Integer;\r\n begin\r\n SetFont(EE);\r\n if EE.SolText <> '' then\r\n begin\r\n SS := TrimLeft(EE.SolText);\r\n WW := Canvas.TextWidth(SS);\r\n if not Test then\r\n Canvas.TextOut(X, Y + BaseLine - EE.Ascent, SS);\r\n X := X + WW;\r\n end;\r\n end;\r\n\r\nbegin\r\n iEol := 0; // Not Needed but removes warning.\r\n R := ClientRect;\r\n Canvas.Brush.Color := Color;\r\n DrawThemedBackground(Self, Canvas, R);\r\n C := FElementStack.Count;\r\n if C = 0 then\r\n Exit;\r\n HTMLClearBreaks;\r\n if AutoSize then\r\n AClientWidth := 10000\r\n else\r\n AClientWidth := ClientWidth - MarginLeft - MarginRight;\r\n\r\n Canvas.Brush.Style := bsClear;\r\n Y := MarginTop;\r\n iSol := 0;\r\n PendingBreak := False;\r\n PendingCount := -1;\r\n MaxWidth := 0;\r\n repeat\r\n I := iSol;\r\n ATotalWidth := AClientWidth;\r\n ATextWidth := 0;\r\n MaxHeight := 0;\r\n MaxAscent := 0;\r\n Eol := False;\r\n repeat // scan line\r\n El := TJvHTMLElement(FElementStack.Items[I]);\r\n if El.BreakLine then\r\n begin\r\n if not PendingBreak and (PendingCount <> I) then\r\n begin\r\n PendingBreak := True;\r\n PendingCount := I;\r\n iEol := I;\r\n Break;\r\n end\r\n else\r\n PendingBreak := False;\r\n end;\r\n if El.Height > MaxHeight then\r\n MaxHeight := El.Height;\r\n if El.Ascent > MaxAscent then\r\n MaxAscent := El.Ascent;\r\n if El.Text <> '' then\r\n begin\r\n lSolText := El.SolText;\r\n // (Lionel) If Breakup can do something, I increase a bit the space until\r\n // it can do the break ...\r\n repeat\r\n El.Breakup(Canvas, ATotalWidth);\r\n Inc(ATotalWidth, 5);\r\n until lSolText <> El.SolText;\r\n end;\r\n if El.SolText <> '' then\r\n begin\r\n ATotalWidth := ATotalWidth - Canvas.TextWidth(El.SolText) - 5;\r\n ATextWidth := ATextWidth + Canvas.TextWidth(El.SolText);\r\n if El.EolText = '' then\r\n begin\r\n if I >= C - 1 then\r\n begin\r\n Eol := True;\r\n iEol := I;\r\n end\r\n else\r\n Inc(I);\r\n end\r\n else\r\n begin\r\n Eol := True;\r\n iEol := I;\r\n end;\r\n end\r\n else\r\n begin // Eol\r\n Eol := True;\r\n iEol := I;\r\n end;\r\n until Eol;\r\n\r\n // render line\r\n BaseLine := MaxAscent;\r\n\r\n if AutoSize then\r\n begin\r\n X := MarginLeft;\r\n if (ATextWidth + MarginLeft + MarginRight) > MaxWidth then\r\n MaxWidth := (ATextWidth + MarginLeft + MarginRight);\r\n end\r\n else\r\n case Alignment of\r\n taLeftJustify:\r\n X := MarginLeft;\r\n taRightJustify:\r\n X := Width - MarginRight - ATextWidth;\r\n taCenter:\r\n X := MarginLeft + (Width - MarginLeft - MarginRight - ATextWidth) div 2;\r\n end;\r\n\r\n for I := iSol to iEol do\r\n begin\r\n El := TJvHTMLElement(FElementStack.Items[I]);\r\n RenderString(El, False);\r\n end;\r\n\r\n Y := Y + MaxHeight;\r\n iSol := iEol;\r\n until (iEol >= C - 1) and (El.EolText = '');\r\n if AutoSize then\r\n begin\r\n Width := MaxWidth;\r\n Height := Y + 5;\r\n end;\r\nend;\r\n\r\nprocedure TJvMarkupLabel.SetAlignment(const Value: TAlignment);\r\nbegin\r\n if Value <> FAlignment then\r\n begin\r\n FAlignment := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvMarkupLabel.SetAutoSize(Value: Boolean);\r\nbegin\r\n inherited SetAutoSize(Value);\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvMarkupLabel.SetMarginLeft(const Value: Integer);\r\nbegin\r\n FMarginLeft := Value;\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvMarkupLabel.SetMarginRight(const Value: Integer);\r\nbegin\r\n FMarginRight := Value;\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvMarkupLabel.SetMarginTop(const Value: Integer);\r\nbegin\r\n FMarginTop := Value;\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvMarkupLabel.SetText(const Value: TCaption);\r\nvar\r\n S: string;\r\nbegin\r\n if Value = FText then\r\n Exit;\r\n S := Value;\r\n S := StringReplace(S, SLineBreak, ' ', [rfReplaceAll]);\r\n S := TrimRight(S);\r\n FText := S;\r\n Refresh;\r\nend;\r\n\r\n{function TJvMarkupLabel.GetBackColor: TColor;\r\nbegin\r\n Result := Color;\r\nend;\r\n\r\nprocedure TJvMarkupLabel.SetBackColor(const Value: TColor);\r\nbegin\r\n Color := Value;\r\nend;}\r\n\r\nprocedure TJvMarkupLabel.DoReadBackColor(Reader: TReader);\r\nbegin\r\n if Reader.NextValue = vaIdent then\r\n Color := StringToColor(Reader.ReadIdent)\r\n else\r\n Color := Reader.ReadInteger;\r\nend;\r\n\r\nprocedure TJvMarkupLabel.DefineProperties(Filer: TFiler);\r\nbegin\r\n inherited DefineProperties(Filer);\r\n Filer.DefineProperty('BackColor', DoReadBackColor, nil, False);\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvMarkupViewer.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvMarkupViewer.PAS, released on 2002-06-15.\r\n\r\nThe Initial Developer of the Original Code is Jan Verhoeven [jan1 dott verhoeven att wxs dott nl]\r\nPortions created by Jan Verhoeven are Copyright (C) 2002 Jan Verhoeven.\r\nAll Rights Reserved.\r\n\r\nContributor(s): Robert Love [rlove att slcdug dott org].\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvMarkupViewer.pas 13104 2011-09-07 06:50:43Z obones $\r\n\r\nunit JvMarkupViewer;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n SysUtils, Classes,\r\n Windows, Messages, Graphics, Forms, Controls, StdCtrls,\r\n JvComponent, JvMarkupCommon;\r\n\r\ntype\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvMarkupViewer = class(TJvCustomControl)\r\n private\r\n FScrollBar: TScrollBar;\r\n FBmp: TBitmap;\r\n FrameTop: Integer;\r\n FrameBottom: Integer;\r\n PageBottom: Integer;\r\n FElementStack: TJvHTMLElementStack;\r\n FTagStack: TJvHTMLElementStack;\r\n FBackColor: TColor;\r\n FMarginLeft: Integer;\r\n FMarginRight: Integer;\r\n FMarginTop: Integer;\r\n FText: TCaption;\r\n function GetText: TCaption;\r\n procedure SetText(const Value: TCaption);\r\n procedure ParseHTML(s: string);\r\n procedure RenderHTML;\r\n procedure HTMLClearBreaks;\r\n procedure HTMLElementDimensions;\r\n procedure SetBackColor(const Value: TColor);\r\n procedure SetMarginLeft(const Value: Integer);\r\n procedure SetMarginRight(const Value: Integer);\r\n procedure SetMarginTop(const Value: Integer);\r\n procedure ScrollViewer(Sender: TObject);\r\n protected\r\n procedure CreateWnd; override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n procedure Paint; override;\r\n published\r\n property Align;\r\n property Width default 300;\r\n property Height default 275;\r\n property Text: TCaption read GetText write SetText;\r\n property BackColor: TColor read FBackColor write SetBackColor default clWhite;\r\n property MarginLeft: Integer read FMarginLeft write SetMarginLeft default 5;\r\n property MarginRight: Integer read FMarginRight write SetMarginRight default 5;\r\n property MarginTop: Integer read FMarginTop write SetMarginTop default 5;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvMarkupViewer.pas $';\r\n Revision: '$Revision: 13104 $';\r\n Date: '$Date: 2011-09-07 08:50:43 +0200 (mer. 07 sept. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n JvConsts, JvThemes;\r\n\r\nconstructor TJvMarkupViewer.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n IncludeThemeStyle(Self, [csParentBackground]);\r\n FElementStack := TJvHTMLElementStack.Create;\r\n FTagStack := TJvHTMLElementStack.Create;\r\n Width := 300;\r\n Height := 275;\r\n FMarginLeft := 5;\r\n FMarginRight := 5;\r\n FMarginTop := 5;\r\n FBackColor := clWhite;\r\nend;\r\n\r\ndestructor TJvMarkupViewer.Destroy;\r\nbegin\r\n FElementStack.Free;\r\n FTagStack.Free;\r\n FBmp.Free;\r\n FScrollBar.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvMarkupViewer.HTMLClearBreaks;\r\nvar\r\n I, C: Integer;\r\n Element: TJvHTMLElement;\r\nbegin\r\n C := FElementStack.Count;\r\n if C = 0 then\r\n Exit;\r\n for I := 0 to C - 1 do\r\n begin\r\n Element := TJvHTMLElement(FElementStack.Items[I]);\r\n Element.SolText := '';\r\n Element.EolText := '';\r\n end;\r\nend;\r\n\r\nprocedure TJvMarkupViewer.HTMLElementDimensions;\r\nvar\r\n I, C: Integer;\r\n Element: TJvHTMLElement;\r\n h, a, w: Integer;\r\n tm: TEXTMETRIC;\r\n s: string;\r\nbegin\r\n C := FElementStack.Count;\r\n if C = 0 then\r\n Exit;\r\n for I := 0 to C - 1 do\r\n begin\r\n Element := TJvHTMLElement(FElementStack.Items[I]);\r\n s := Element.Text;\r\n Canvas.Font.Name := Element.FontName;\r\n Canvas.Font.Size := Element.FontSize;\r\n Canvas.Font.Style := Element.FontStyle;\r\n Canvas.Font.Color := Element.FontColor;\r\n GetTextMetrics(Canvas.Handle, tm);\r\n h := tm.tmHeight;\r\n a := tm.tmAscent;\r\n w := Canvas.TextWidth(s);\r\n Element.Height := h;\r\n Element.Ascent := a;\r\n Element.Width := w;\r\n end;\r\nend;\r\n\r\nprocedure TJvMarkupViewer.CreateWnd;\r\nbegin\r\n inherited CreateWnd;\r\n FScrollBar := TScrollBar.Create(Self);\r\n FScrollBar.Kind := sbVertical;\r\n FScrollBar.Parent := Self;\r\n FScrollBar.Align := alRight;\r\n FScrollBar.Min := 0;\r\n FScrollBar.Max := 0;\r\n FScrollBar.OnChange := ScrollViewer;\r\n FrameTop := 0;\r\n FrameBottom := ClientHeight;\r\n FBmp := TBitmap.Create;\r\n FBmp.Width := ClientWidth - FScrollBar.Width;\r\n FBmp.Height := ClientHeight;\r\nend;\r\n\r\nprocedure TJvMarkupViewer.Paint;\r\nvar\r\n sm: Integer;\r\n w, h: Integer;\r\nbegin\r\n w := ClientWidth - FScrollBar.Width;\r\n h := ClientHeight;\r\n FBmp.Width := w;\r\n FBmp.Height := h;\r\n RenderHTML;\r\n Canvas.Draw(0, 0, FBmp);\r\n FScrollBar.Min := 0;\r\n sm := PageBottom - ClientHeight;\r\n if sm > 0 then\r\n FScrollBar.Max := sm\r\n else\r\n FScrollBar.Max := 0;\r\n FScrollBar.Position := 0;\r\n FScrollBar.LargeChange := Trunc(0.8 * ClientHeight);\r\nend;\r\n\r\nprocedure TJvMarkupViewer.ParseHTML(s: string);\r\nvar\r\n p: Integer;\r\n se, st: string;\r\n LText: string;\r\n FStyle: TFontStyles;\r\n FName: string;\r\n FSize: Integer;\r\n LBreakLine: Boolean;\r\n AColor, FColor: TColor;\r\n Element: TJvHTMLElement;\r\n\r\n function HTMLStringToColor(v: string; var col: TColor): Boolean;\r\n var\r\n vv: string;\r\n begin\r\n if Copy(v, 1, 1) <> '#' then\r\n begin\r\n vv := 'cl' + v;\r\n try\r\n col := StringToColor(vv);\r\n Result := True;\r\n except\r\n Result := False;\r\n end;\r\n end\r\n else\r\n begin\r\n try\r\n vv := '$' + Copy(v, 6, 2) + Copy(v, 4, 2) + Copy(v, 2, 2);\r\n col := StringToColor(vv);\r\n Result := True;\r\n except\r\n Result := False;\r\n end\r\n end\r\n end;\r\n\r\n procedure PushTag;\r\n begin\r\n Element := TJvHTMLElement.Create;\r\n Element.FontName := FName;\r\n Element.FontSize := FSize;\r\n Element.FontStyle := FStyle;\r\n Element.FontColor := FColor;\r\n FTagStack.Push(Element);\r\n end;\r\n\r\n procedure PopTag;\r\n begin\r\n Element := FTagStack.Pop;\r\n if Element <> nil then\r\n begin\r\n FName := Element.FontName;\r\n FSize := Element.FontSize;\r\n FStyle := Element.FontStyle;\r\n FColor := Element.FontColor;\r\n Element.Free;\r\n end;\r\n end;\r\n\r\n procedure PushElement;\r\n begin\r\n Element := TJvHTMLElement.Create;\r\n Element.Text := LText;\r\n Element.FontName := FName;\r\n Element.FontSize := FSize;\r\n Element.FontStyle := FStyle;\r\n Element.FontColor := FColor;\r\n Element.BreakLine := LBreakLine;\r\n LBreakLine := False;\r\n FElementStack.Push(Element);\r\n end;\r\n\r\n procedure ParseTag(SS: string);\r\n var\r\n PP: Integer;\r\n LTag, LPar, LVal: string;\r\n HavePar: Boolean;\r\n begin\r\n SS := Trim(SS);\r\n HavePar := False;\r\n PP := Pos(' ', SS);\r\n if PP = 0 then\r\n LTag := SS // tag only\r\n else\r\n begin // tag + attributes\r\n LTag := Copy(SS, 1, PP - 1);\r\n SS := Trim(Copy(SS, PP + 1, Length(SS)));\r\n HavePar := True;\r\n end;\r\n // handle LTag\r\n LTag := LowerCase(LTag);\r\n if LTag = 'br' then\r\n LBreakLine := True\r\n else\r\n if LTag = 'b' then\r\n begin // bold\r\n PushTag;\r\n FStyle := FStyle + [fsBold];\r\n end\r\n else\r\n if LTag = '/b' then\r\n begin // cancel bold\r\n FStyle := FStyle - [fsBold];\r\n PopTag;\r\n end\r\n else\r\n if LTag = 'i' then\r\n begin // italic\r\n PushTag;\r\n FStyle := FStyle + [fsItalic];\r\n end\r\n else\r\n if LTag = '/i' then\r\n begin // cancel italic\r\n FStyle := FStyle - [fsItalic];\r\n PopTag;\r\n end\r\n else\r\n if LTag = 'u' then\r\n begin // underline\r\n PushTag;\r\n FStyle := FStyle + [fsUnderline];\r\n end\r\n else\r\n if LTag = '/u' then\r\n begin // cancel underline\r\n FStyle := FStyle - [fsUnderline];\r\n PopTag;\r\n end\r\n else\r\n if LTag = 'font' then\r\n PushTag\r\n else\r\n if LTag = '/font' then\r\n PopTag;\r\n if HavePar then\r\n begin\r\n repeat\r\n PP := Pos('=\"', SS);\r\n if PP > 0 then\r\n begin\r\n LPar := LowerCase(Trim(Copy(SS, 1, PP - 1)));\r\n Delete(SS, 1, PP + 1);\r\n PP := Pos('\"', SS);\r\n if PP > 0 then\r\n begin\r\n LVal := Copy(SS, 1, PP - 1);\r\n Delete(SS, 1, PP);\r\n if LPar = 'face' then\r\n FName := LVal\r\n else\r\n if LPar = 'size' then\r\n try\r\n FSize := StrToInt(LVal);\r\n except\r\n end\r\n else\r\n if LPar = 'color' then\r\n try\r\n if HTMLStringToColor(LVal, AColor) then\r\n FColor := AColor;\r\n except\r\n end\r\n end;\r\n end;\r\n until PP = 0;\r\n end;\r\n end;\r\n\r\nbegin\r\n FElementStack.Clear;\r\n FTagStack.Clear;\r\n FStyle := [];\r\n FName := 'Arial';\r\n FSize := 12;\r\n FColor := clBlack;\r\n LBreakLine := False;\r\n repeat\r\n p := Pos('<', s);\r\n if p = 0 then\r\n begin\r\n LText := s;\r\n PushElement;\r\n end\r\n else\r\n begin\r\n if p > 1 then\r\n begin\r\n se := Copy(s, 1, p - 1);\r\n LText := se;\r\n PushElement;\r\n Delete(s, 1, p - 1);\r\n end;\r\n p := Pos('>', s);\r\n if p > 0 then\r\n begin\r\n st := Copy(s, 2, p - 2);\r\n Delete(s, 1, p);\r\n ParseTag(st);\r\n end;\r\n end;\r\n until p = 0;\r\nend;\r\n\r\nprocedure TJvMarkupViewer.RenderHTML;\r\nvar\r\n R: TRect;\r\n X, Y, xav, clw: Integer;\r\n BaseLine: Integer;\r\n I, C: Integer;\r\n el: TJvHTMLElement;\r\n eol: Boolean;\r\n ml: Integer; // margin left\r\n isol, ieol: Integer;\r\n MaxHeight, MaxAscent: Integer;\r\n PendingBreak: Boolean;\r\n\r\n procedure SetFont(AElem: TJvHTMLElement);\r\n begin\r\n with FBmp.Canvas do\r\n begin\r\n Font.Name := AElem.FontName;\r\n Font.Size := AElem.FontSize;\r\n Font.Style := AElem.FontStyle;\r\n Font.Color := AElem.FontColor;\r\n end;\r\n end;\r\n\r\n procedure RenderString(ee: TJvHTMLElement);\r\n var\r\n SS: string;\r\n w: Integer;\r\n begin\r\n SetFont(ee);\r\n if ee.SolText <> '' then\r\n begin\r\n SS := ee.SolText;\r\n w := FBmp.Canvas.TextWidth(SS);\r\n FBmp.Canvas.TextOut(X, Y + BaseLine - ee.Ascent - FrameTop, SS);\r\n X := X + w;\r\n end;\r\n end;\r\n\r\nbegin\r\n ieol := 0; // Not needed but removed Warning\r\n R := Rect(0, 0, FBmp.Width, FBmp.Height);\r\n FBmp.Canvas.Brush.Color := BackColor;\r\n FBmp.Canvas.FillRect(R);\r\n C := FElementStack.Count;\r\n if C = 0 then\r\n Exit;\r\n HTMLClearBreaks;\r\n clw := FBmp.Width - FMarginRight;\r\n ml := MarginLeft;\r\n FBmp.Canvas.Brush.Style := bsClear;\r\n Y := FMarginTop;\r\n isol := 0;\r\n PendingBreak := False;\r\n repeat\r\n I := isol;\r\n xav := clw;\r\n MaxHeight := 0;\r\n MaxAscent := 0;\r\n eol := False;\r\n repeat // scan line\r\n el := TJvHTMLElement(FElementStack.Items[I]);\r\n if el.BreakLine then\r\n begin\r\n if not PendingBreak then\r\n begin\r\n eol := True;\r\n ieol := I - 1;\r\n // break;\r\n end;\r\n PendingBreak := not PendingBreak;\r\n end;\r\n if not PendingBreak then\r\n begin\r\n if el.Height > MaxHeight then\r\n MaxHeight := el.Height;\r\n if el.Ascent > MaxAscent then\r\n MaxAscent := el.Ascent;\r\n el.Breakup(FBmp.Canvas, xav);\r\n if el.SolText <> '' then\r\n begin\r\n xav := xav - FBmp.Canvas.TextWidth(el.SolText);\r\n if el.EolText = '' then\r\n begin\r\n if I >= C - 1 then\r\n begin\r\n eol := True;\r\n ieol := I;\r\n end\r\n else\r\n Inc(I);\r\n end\r\n else\r\n begin\r\n eol := True;\r\n ieol := I;\r\n end;\r\n end\r\n else\r\n begin\r\n eol := True;\r\n ieol := I;\r\n end;\r\n end;\r\n until eol;\r\n\r\n // render line, only when in visible frame\r\n X := ml;\r\n BaseLine := MaxAscent;\r\n if (Y + MaxHeight >= FrameTop) and (Y <= FrameBottom) then\r\n for I := isol to ieol do\r\n begin\r\n el := TJvHTMLElement(FElementStack.Items[I]);\r\n RenderString(el);\r\n end;\r\n Y := Y + MaxHeight;\r\n if not PendingBreak then\r\n isol := ieol\r\n else\r\n isol := ieol + 1;\r\n until (ieol >= C - 1) and (el.EolText = '');\r\n // clxfix: set transparency after bitmap has be drawn\r\n FBmp.TransparentColor := BackColor;\r\n FBmp.Transparent := True;\r\n PageBottom := Y;\r\nend;\r\n\r\nprocedure TJvMarkupViewer.ScrollViewer(Sender: TObject);\r\nbegin\r\n FrameTop := FScrollBar.Position;\r\n FrameBottom := FrameTop + ClientHeight - 1;\r\n RenderHTML;\r\n Canvas.Draw(0, 0, FBmp);\r\nend;\r\n\r\nprocedure TJvMarkupViewer.SetBackColor(const Value: TColor);\r\nbegin\r\n if Value <> FBackColor then\r\n begin\r\n FBackColor := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvMarkupViewer.SetMarginLeft(const Value: Integer);\r\nbegin\r\n if Value <> FMarginLeft then\r\n begin\r\n FMarginLeft := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvMarkupViewer.SetMarginRight(const Value: Integer);\r\nbegin\r\n if Value <> FMarginRight then\r\n begin\r\n FMarginRight := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvMarkupViewer.SetMarginTop(const Value: Integer);\r\nbegin\r\n if Value <> FMarginTop then\r\n begin\r\n FMarginTop := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\n\r\nfunction TJvMarkupViewer.GetText: TCaption;\r\nbegin\r\n Result := FText;\r\nend;\r\n\r\n\r\nprocedure TJvMarkupViewer.SetText(const Value: TCaption);\r\nvar\r\n S: string;\r\nbegin\r\n if Value = FText then\r\n Exit;\r\n S := Value;\r\n S := StringReplace(S, sLineBreak, ' ', [rfReplaceAll]);\r\n S := TrimRight(S);\r\n ParseHTML(S);\r\n HTMLElementDimensions;\r\n FText := S;\r\n Invalidate;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvMaskEdit.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvMaskEdit.PAS, released on 2001-02-28.\r\n\r\nThe Initial Developer of the Original Code is Sbastien Buysse [sbuysse att buypin dott com]\r\nPortions created by Sbastien Buysse are Copyright (C) 2001 Sbastien Buysse.\r\nAll Rights Reserved.\r\n\r\nContributor(s): Michael Beck [mbeck att bigfoot dott com],\r\n Rob den Braasem [rbraasem att xs4all dott nl],\r\n Oliver Giesen [ogware att gmx dott net],\r\n Peter Thornqvist [peter3 at sourceforge dot net].\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvMaskEdit.pas 13415 2012-09-10 09:51:54Z obones $\r\n\r\nunit JvMaskEdit;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, Messages,\r\n SysUtils, Classes, Graphics, Controls, Mask, Forms, StdCtrls,\r\n {$IFDEF HAS_UNIT_SYSTEM_UITYPES}\r\n System.UITypes,\r\n {$ENDIF HAS_UNIT_SYSTEM_UITYPES}\r\n JvTypes, JvCaret, JvToolEdit, JvExMask;\r\n\r\ntype\r\n TJvCustomMaskEdit = class(TJvCustomComboEdit)\r\n private\r\n FHotTrack: Boolean;\r\n FCaret: TJvCaret;\r\n FEntering: Boolean;\r\n FLeaving: Boolean;\r\n FProtectPassword: Boolean;\r\n FLastNotifiedText: string;\r\n FHasLastNotifiedText: Boolean;\r\n FOnSetFocus: TJvFocusChangeEvent;\r\n FOnKillFocus: TJvFocusChangeEvent;\r\n FWordWrap: Boolean;\r\n FMultiLine: Boolean;\r\n FOnAfterPaint: TNotifyEvent;\r\n FScrollBars: TScrollStyle;\r\n FCanvas: TControlCanvas;\r\n procedure SetHotTrack(Value: Boolean);\r\n procedure SetMultiLine(const Value: Boolean);\r\n procedure SetScrollBars(const Value: TScrollStyle);\r\n procedure SetWordWrap(const Value: Boolean);\r\n function GetCanvas: TCanvas;\r\n procedure SetPasswordChar(const Value: Char);\r\n function GetPasswordChar: Char;\r\n function GetText: TCaption;\r\n procedure SetText(const Value: TCaption);\r\n protected\r\n procedure CreateParams(var Params: TCreateParams); override;\r\n procedure CaretChanged(Sender: TObject); dynamic;\r\n procedure FocusKilled(NextWnd: THandle); override;\r\n procedure FocusSet(PrevWnd: THandle); override;\r\n procedure DoKillFocus(const ANextControl: TWinControl); virtual;\r\n procedure DoSetFocus(const APreviousControl: TWinControl); virtual;\r\n procedure MouseEnter(Control: TControl); override;\r\n procedure MouseLeave(Control: TControl); override;\r\n procedure SetCaret(const Value: TJvCaret);\r\n procedure NotifyIfChanged;\r\n procedure Change; override;\r\n procedure WMPaint(var Msg: TWMPaint); message WM_PAINT;\r\n public\r\n procedure DefaultHandler(var Msg); override;\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n\r\n property Entering: Boolean read FEntering;\r\n property Leaving: Boolean read FLeaving;\r\n protected\r\n property Text: TCaption read GetText write SetText;\r\n property PasswordChar: Char read GetPasswordChar write SetPasswordChar default #0;\r\n // set to True to disable read/write of PasswordChar and read of Text\r\n property ProtectPassword: Boolean read FProtectPassword write FProtectPassword default False;\r\n property HotTrack: Boolean read FHotTrack write SetHotTrack default False;\r\n property Caret: TJvCaret read FCaret write SetCaret;\r\n property ShowButton default False;\r\n\r\n property OnSetFocus: TJvFocusChangeEvent read FOnSetFocus write FOnSetFocus;\r\n property OnKillFocus: TJvFocusChangeEvent read FOnKillFocus write FOnKillFocus;\r\n\r\n property ScrollBars: TScrollStyle read FScrollBars write SetScrollBars default ssNone;\r\n property MultiLine: Boolean read FMultiLine write SetMultiLine default False;\r\n property WordWrap: Boolean read FWordWrap write SetWordWrap default False;\r\n property OnAfterPaint: TNotifyEvent read FOnAfterPaint write FOnAfterPaint;\r\n public\r\n property Canvas: TCanvas read GetCanvas;\r\n end;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvMaskEdit = class(TJvCustomMaskEdit)\r\n published\r\n property BevelEdges;\r\n property BevelInner;\r\n property BevelKind default bkNone;\r\n property BevelOuter;\r\n property Alignment;\r\n property Caret;\r\n property CheckOnExit;\r\n property ClipboardCommands;\r\n property DisabledTextColor;\r\n property DisabledColor;\r\n property HintColor;\r\n property HotTrack;\r\n {property MultiLine; ahuser: not working properly, Height is always reset\r\n property ScrollBars;\r\n property WordWrap;}\r\n property ProtectPassword;\r\n property OnAfterPaint;\r\n property OnEnabledChanged;\r\n property OnMouseEnter;\r\n property OnMouseLeave;\r\n property OnParentColorChange;\r\n\r\n property Anchors;\r\n property AutoSelect;\r\n property AutoSize;\r\n property BorderStyle;\r\n property CharCase;\r\n property Color;\r\n property Constraints;\r\n property DragMode;\r\n property Enabled;\r\n property EditMask;\r\n property Font;\r\n property Flat;\r\n property GroupIndex;\r\n property ImeMode;\r\n property ImeName;\r\n property ParentFlat;\r\n property MaxLength;\r\n property ParentColor;\r\n property ParentFont;\r\n property ParentShowHint;\r\n property PasswordChar;\r\n property PopupMenu;\r\n property ReadOnly;\r\n property ShowHint;\r\n property ShowButton;\r\n property TabOrder;\r\n property TabStop;\r\n property Text;\r\n property Visible;\r\n\r\n property OnChange;\r\n property OnClick;\r\n property OnDblClick;\r\n property OnDragDrop;\r\n property OnDragOver;\r\n property OnEndDrag;\r\n property OnEnter;\r\n property OnExit;\r\n property OnKeyDown;\r\n property OnKeyPress;\r\n property OnKeyUp;\r\n property OnMouseDown;\r\n property OnMouseMove;\r\n property OnMouseUp;\r\n property OnSetFocus;\r\n property OnKillFocus;\r\n property OnStartDrag;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvMaskEdit.pas $';\r\n Revision: '$Revision: 13415 $';\r\n Date: '$Date: 2012-09-10 11:51:54 +0200 (lun. 10 sept. 2012) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nconstructor TJvCustomMaskEdit.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n\r\n FCanvas := TControlCanvas.Create;\r\n FCanvas.Control := Self; //...i can draw now! :)\r\n\r\n FHotTrack := False;\r\n FCaret := TJvCaret.Create(Self);\r\n FCaret.OnChanged := CaretChanged;\r\n FEntering := False;\r\n FLeaving := False;\r\n\r\n FScrollBars := ssNone;\r\n FMultiLine := False;\r\n FWordWrap := False;\r\n\r\n ControlState := ControlState + [csCreating];\r\n try\r\n ShowButton := False; { force update }\r\n finally\r\n ControlState := ControlState - [csCreating];\r\n end;\r\nend;\r\n\r\ndestructor TJvCustomMaskEdit.Destroy;\r\nbegin\r\n FCaret.OnChanged := nil;\r\n FreeAndNil(FCaret);\r\n FCanvas.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvCustomMaskEdit.DefaultHandler(var Msg);\r\nbegin\r\n case TMessage(Msg).Msg of\r\n WM_CUT, WM_PASTE, EM_SETPASSWORDCHAR, WM_GETTEXT, WM_GETTEXTLENGTH:\r\n if not ProtectPassword then\r\n inherited DefaultHandler(Msg);\r\n else\r\n inherited DefaultHandler(Msg);\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomMaskEdit.CaretChanged(Sender: TObject);\r\nbegin\r\n FCaret.CreateCaret;\r\nend;\r\n\r\nprocedure TJvCustomMaskEdit.Change;\r\nbegin\r\n FLastNotifiedText := Text;\r\n FHasLastNotifiedText := True;\r\n inherited Change;\r\nend;\r\n\r\nprocedure TJvCustomMaskEdit.FocusKilled(NextWnd: THandle);\r\nbegin\r\n FLeaving := True;\r\n try\r\n FCaret.DestroyCaret;\r\n inherited FocusKilled(NextWnd);\r\n DoKillFocus(FindControl(NextWnd));\r\n finally\r\n FLeaving := False;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomMaskEdit.DoKillFocus(const ANextControl: TWinControl);\r\nbegin\r\n NotifyIfChanged;\r\n if Assigned(FOnKillFocus) then\r\n FOnKillFocus(Self, ANextControl);\r\nend;\r\n\r\nprocedure TJvCustomMaskEdit.FocusSet(PrevWnd: THandle);\r\nbegin\r\n FEntering := True;\r\n try\r\n inherited FocusSet(PrevWnd);\r\n FCaret.CreateCaret;\r\n DoSetFocus(FindControl(PrevWnd));\r\n finally\r\n FEntering := False;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomMaskEdit.DoSetFocus(const APreviousControl: TWinControl);\r\nbegin\r\n if Assigned(FOnSetFocus) then\r\n FOnSetFocus(Self, APreviousControl);\r\nend;\r\n\r\nfunction TJvCustomMaskEdit.GetPasswordChar: Char;\r\nbegin\r\n Result := inherited PasswordChar;\r\nend;\r\n\r\nfunction TJvCustomMaskEdit.GetText: TCaption;\r\nvar\r\n Tmp: Boolean;\r\nbegin\r\n Tmp := ProtectPassword;\r\n try\r\n ProtectPassword := False;\r\n Result := inherited Text;\r\n finally\r\n ProtectPassword := Tmp;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomMaskEdit.MouseEnter(Control: TControl);\r\nbegin\r\n if csDesigning in ComponentState then\r\n Exit;\r\n if not MouseOver then\r\n begin\r\n if HotTrack then\r\n Ctl3D := True;\r\n inherited MouseEnter(Control);\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomMaskEdit.MouseLeave(Control: TControl);\r\nbegin\r\n if MouseOver then\r\n begin\r\n if FHotTrack then\r\n Ctl3D := False;\r\n inherited MouseLeave(Control);\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomMaskEdit.NotifyIfChanged;\r\nbegin\r\n if FHasLastNotifiedText and (FLastNotifiedText <> Text) then\r\n Change;\r\nend;\r\n\r\nprocedure TJvCustomMaskEdit.SetCaret(const Value: TJvCaret);\r\nbegin\r\n FCaret.Assign(Value);\r\nend;\r\n\r\nprocedure TJvCustomMaskEdit.SetHotTrack(Value: Boolean);\r\nbegin\r\n FHotTrack := Value;\r\n if Value then\r\n begin\r\n Ctl3D := False;\r\n end\r\n else\r\n begin\r\n Ctl3D := True;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomMaskEdit.SetPasswordChar(const Value: Char);\r\nvar\r\n Tmp: Boolean;\r\nbegin\r\n Tmp := ProtectPassword;\r\n try\r\n ProtectPassword := False;\r\n inherited PasswordChar := Value;\r\n finally\r\n ProtectPassword := Tmp;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomMaskEdit.SetText(const Value: TCaption);\r\nbegin\r\n inherited Text := Value;\r\nend;\r\n\r\nprocedure TJvCustomMaskEdit.SetMultiLine(const Value: Boolean);\r\nbegin\r\n if FMultiLine <> Value then\r\n begin\r\n FMultiLine := Value;\r\n RecreateWnd;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomMaskEdit.SetScrollBars(const Value: TScrollStyle);\r\nbegin\r\n if FScrollBars <> Value then\r\n begin\r\n FScrollBars := Value;\r\n RecreateWnd;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomMaskEdit.SetWordWrap(const Value: Boolean);\r\nbegin\r\n if FWordWrap <> Value then\r\n begin\r\n FWordWrap := Value;\r\n RecreateWnd;\r\n end;\r\nend;\r\n\r\nfunction TJvCustomMaskEdit.GetCanvas: TCanvas;\r\nbegin\r\n Result := FCanvas;\r\nend;\r\n\r\nprocedure TJvCustomMaskEdit.CreateParams(var Params: TCreateParams);\r\nbegin\r\n inherited CreateParams(Params);\r\n\r\n Params.Style := Params.Style or WS_CLIPCHILDREN;\r\n\r\n if FMultiline then\r\n Params.Style := Params.Style or ES_MULTILINE;\r\n\r\n case FScrollBars of\r\n ssHorizontal:\r\n Params.Style := Params.Style or WS_HSCROLL;\r\n ssVertical:\r\n Params.Style := Params.Style or WS_VSCROLL;\r\n ssBoth:\r\n Params.Style := Params.Style or WS_HSCROLL or WS_VSCROLL;\r\n end;\r\n\r\n if FWordWrap then\r\n Params.Style := Params.Style or ES_AUTOHSCROLL;\r\nend;\r\n\r\nprocedure TJvCustomMaskEdit.WMPaint(var Msg: TWMPaint);\r\nbegin\r\n inherited;\r\n if Assigned(FOnAfterPaint) then\r\n FOnAfterPaint(Self);\r\nend;\r\n\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend." }, { "path": "External/Jedi/Jvcl/run/JvMaxPixel.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvMaxPixel.PAS, released on 2001-02-28.\r\n\r\nThe Initial Developer of the Original Code is Sbastien Buysse [sbuysse att buypin dott com]\r\nPortions created by Sbastien Buysse are Copyright (C) 2001 Sbastien Buysse.\r\nAll Rights Reserved.\r\n\r\nContributor(s): Michael Beck [mbeck att bigfoot dott com].\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvMaxPixel.pas 12461 2009-08-14 17:21:33Z obones $\r\n\r\nunit JvMaxPixel;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n SysUtils, Graphics, Controls, Classes;\r\n\r\ntype\r\n TJvMaxPixel = class(TPersistent)\r\n private\r\n FUseControlFont: Boolean;\r\n FLength: Integer;\r\n FFont: TFont;\r\n FOnChanged: TNotifyEvent;\r\n FParent: TControl;\r\n function IsFontStored: Boolean;\r\n procedure SetFont(const Value: TFont);\r\n procedure SetLength(const Value: Integer);\r\n procedure SetUseControlFont(const Value: Boolean);\r\n protected\r\n procedure FontChanged(Sender: TObject);\r\n procedure Changed;\r\n public\r\n constructor Create(AOwner: TControl);\r\n destructor Destroy; override;\r\n function Test(var Value: string; ParentFont: TFont): Boolean;\r\n property OnChanged: TNotifyEvent read FOnChanged write FOnChanged;\r\n published\r\n property Length: Integer read FLength write SetLength default 0;\r\n property UseControlFont: Boolean read FUseControlFont write SetUseControlFont default True;\r\n property Font: TFont read FFont write SetFont stored IsFontStored;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvMaxPixel.pas $';\r\n Revision: '$Revision: 12461 $';\r\n Date: '$Date: 2009-08-14 19:21:33 +0200 (ven. 14 août 2009) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nconstructor TJvMaxPixel.Create(AOwner: TControl);\r\nbegin\r\n inherited Create;\r\n FFont := TFont.Create;\r\n FFont.OnChange := FontChanged;\r\n FUseControlFont := True;\r\n FLength := 0;\r\n FParent := AOwner;\r\nend;\r\n\r\ndestructor TJvMaxPixel.Destroy;\r\nbegin\r\n FFont.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvMaxPixel.Changed;\r\nbegin\r\n if Assigned(FOnChanged) then\r\n FOnChanged(Self);\r\nend;\r\n\r\nprocedure TJvMaxPixel.FontChanged(Sender: TObject);\r\nbegin\r\n Changed;\r\nend;\r\n\r\nprocedure TJvMaxPixel.SetFont(const Value: TFont);\r\nbegin\r\n if Value <> FFont then\r\n FFont.Assign(Value);\r\nend;\r\n\r\nprocedure TJvMaxPixel.SetLength(const Value: Integer);\r\nbegin\r\n if Value <> FLength then\r\n begin\r\n FLength := Value;\r\n Changed;\r\n end;\r\nend;\r\n\r\nprocedure TJvMaxPixel.SetUseControlFont(const Value: Boolean);\r\nbegin\r\n if Value <> FUseControlFont then\r\n begin\r\n FUseControlFont := Value;\r\n Changed;\r\n end;\r\nend;\r\n\r\nfunction TJvMaxPixel.Test(var Value: string; ParentFont: TFont): Boolean;\r\nbegin\r\n Result := True;\r\n if Length = 0 then\r\n Exit;\r\n\r\n with TControlCanvas.Create do\r\n try\r\n Result := False;\r\n Control := FParent;\r\n if FUseControlFont then\r\n Font.Assign(ParentFont)\r\n else\r\n Font.Assign(FFont);\r\n\r\n Result := TextWidth(Value) > Length;\r\n while (Value <> '') and (TextWidth(Value) > Length) do\r\n Delete(Value, System.Length(Value), 1);\r\n finally\r\n Free;\r\n end;\r\nend;\r\n\r\nfunction TJvMaxPixel.IsFontStored: Boolean;\r\nbegin\r\n Result := not UseControlFont;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvMemo.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvMemo.PAS, released on 2001-02-28.\r\n\r\nThe Initial Developer of the Original Code is Sbastien Buysse [sbuysse att buypin dott com]\r\nPortions created by Sbastien Buysse are Copyright (C) 2001 Sbastien Buysse.\r\nAll Rights Reserved.\r\n\r\nThis unit is a merging of the original TJvMemo, JvDisplayMemo, JvCaretMemo,JvMemoEx.\r\nMerging done 2002-06-11 by Peter Thornqvist [peter3 at sourceforge dot net]\r\n\r\nContributor(s):\r\n Michael Beck [mbeck att bigfoot dott com]\r\n Anthony Steele [asteele att iafrica dott com]\r\n Peter Below [100113 dott 1101 att compuserve dott com]\r\n\r\n MERGE NOTES:\r\n * TjvCustomMemo has been removed from JvComponent and put here instead.\r\n * The HotTrack property only works if BorderStyle := bsSingle\r\n * To simulate the behaviour of JvDisplayMemo, set HideCaret to True,\r\n Readonly to True, Color to $C0FFFF and Cursor to crArrow\r\n * The MaxLines property has changed: it stills displays only the selected number of lines,\r\n but now saves the original content in an internal stringlist that can be restored by\r\n setting MaxLines to 0.\r\n * Added ClipboardCommands\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n Under Vista and upper, the Transparent is working but causes flicker\r\n This comes from ForceRefreshIfNeeded that recreates the window, but at the\r\n time of writing, that was the only method that worked to get the control\r\n to be refreshed. If you find a better way, please do the change.\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvMemo.pas 13256 2012-02-28 08:18:58Z obones $\r\n\r\nunit JvMemo;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, StdCtrls,\r\n JvCaret, JvTypes, JvExStdCtrls;\r\n\r\ntype\r\n TJvCustomMemo = class(TJvExCustomMemo)\r\n private\r\n FMaxLines: Integer;\r\n FHotTrack: Boolean;\r\n FOnHorizontalScroll: TNotifyEvent;\r\n FOnVerticalScroll: TNotifyEvent;\r\n FCaret: TJvCaret;\r\n FHideCaret: Boolean;\r\n FOrigLines: TStringList;\r\n FTransparent: Boolean;\r\n FSelLengthButtonDown: Integer;\r\n procedure SetHotTrack(Value: Boolean);\r\n procedure SetCaret(const Value: TJvCaret);\r\n procedure WMHScroll(var Msg: TWMHScroll); message WM_HSCROLL;\r\n procedure WMVScroll(var Msg: TWMVScroll); message WM_VSCROLL;\r\n procedure WMPaint(var Msg: TWMPaint); message WM_PAINT;\r\n procedure CNCtlColorEdit(var Message: TWMCtlColorEdit); message CN_CTLCOLOREDIT;\r\n procedure CNCtlColorStatic(var Message: TWMCtlColorStatic); message CN_CTLCOLORSTATIC;\r\n procedure WMNCPaint(var Message: TWMNCPaint); message WM_NCPAINT;\r\n procedure WMKeyDown(var Message: TWMKeyDown); message WM_KEYDOWN;\r\n procedure WMLButtonDown(var Message: TWMLButtonDown); message WM_LBUTTONDOWN;\r\n procedure WMLButtonUp(var Message: TWMLButtonUp); message WM_LBUTTONUP;\r\n procedure SetMaxLines(const Value: Integer);\r\n function GetLines: TStrings;\r\n procedure SetLines(const Value: TStrings);\r\n procedure SetHideCaret(const Value: Boolean);\r\n function GetFlat: Boolean;\r\n function GetParentFlat: Boolean;\r\n procedure SetFlat(const Value: Boolean);\r\n procedure SetParentFlat(const Value: Boolean);\r\n procedure ForceRefreshIfNeeded;\r\n protected\r\n procedure SetClipboardCommands(const Value: TJvClipboardCommands); override;\r\n procedure WMCut(var Msg: TMessage); message WM_CUT;\r\n procedure WMPaste(var Msg: TMessage); message WM_PASTE;\r\n procedure WMClear(var Msg: TMessage); message WM_CLEAR;\r\n procedure WMUndo(var Msg: TMessage); message WM_UNDO;\r\n procedure CaretChange(Sender: TObject); dynamic;\r\n procedure FocusKilled(NextWnd: THandle); override;\r\n procedure FocusSet(PrevWnd: THandle); override;\r\n function DoEraseBackground(Canvas: TCanvas; Param: LPARAM): Boolean; override;\r\n procedure MouseEnter(Control: TControl); override;\r\n procedure MouseLeave(Control: TControl); override;\r\n procedure KeyPress(var Key: Char); override;\r\n procedure Change; override;\r\n procedure CreateParams(var Params: TCreateParams); override;\r\n function GetCurrentLine: Integer;\r\n procedure SetCurrentLine(NewLine: Integer);\r\n procedure SetTransparent(Value: Boolean);\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n { these wrap the windows messages }\r\n procedure LineScroll(X, Y: Integer);\r\n function CharOfLine(iLine: Integer): Integer;\r\n procedure DefaultHandler(var Message); override;\r\n property CurrentLine: Integer read GetCurrentLine write SetCurrentLine;\r\n protected\r\n property Caret: TJvCaret read FCaret write SetCaret;\r\n property HideCaret: Boolean read FHideCaret write SetHideCaret default False;\r\n property MaxLines: Integer read FMaxLines write SetMaxLines default 0;\r\n property HotTrack: Boolean read FHotTrack write SetHotTrack default False;\r\n property Lines: TStrings read GetLines write SetLines;\r\n property Transparent: Boolean read FTransparent write SetTransparent default False;\r\n property Flat: Boolean read GetFlat write SetFlat default False;\r\n property ParentFlat: Boolean read GetParentFlat write SetParentFlat default True;\r\n property OnVerticalScroll: TNotifyEvent read FOnVerticalScroll write FOnVerticalScroll;\r\n property OnHorizontalScroll: TNotifyEvent read FOnHorizontalScroll write FOnHorizontalScroll;\r\n end;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvMemo = class(TJvCustomMemo)\r\n published\r\n property AutoSize default False; // TCustomMemo.Create sets AutoSize:=False\r\n property Caret;\r\n property ClipboardCommands;\r\n property MaxLines;\r\n property HideCaret;\r\n property HotTrack;\r\n property HintColor;\r\n property BevelEdges;\r\n property BevelInner;\r\n property BevelKind default bkNone;\r\n property BevelOuter;\r\n\r\n property OnMouseEnter;\r\n property OnMouseLeave;\r\n property OnParentColorChange;\r\n property OnVerticalScroll;\r\n property OnHorizontalScroll;\r\n\r\n property Align;\r\n property Alignment;\r\n property Anchors;\r\n property BiDiMode;\r\n property BorderStyle;\r\n property Color;\r\n property Constraints;\r\n property DragCursor;\r\n property DragKind;\r\n property DragMode;\r\n property Enabled;\r\n property Flat;\r\n property Font;\r\n property HideSelection;\r\n property ImeMode;\r\n property ImeName;\r\n property Lines;\r\n property MaxLength;\r\n property OEMConvert;\r\n property ParentBiDiMode;\r\n property ParentColor;\r\n property ParentFlat;\r\n property ParentFont;\r\n property ParentShowHint;\r\n property PopupMenu;\r\n property ReadOnly;\r\n property Transparent;\r\n property ScrollBars;\r\n property ShowHint;\r\n property TabOrder;\r\n property TabStop;\r\n // property Text;\r\n property Visible;\r\n property WantReturns;\r\n property WantTabs;\r\n property WordWrap;\r\n property OnChange;\r\n property OnClick;\r\n property OnContextPopup;\r\n property OnDblClick;\r\n property OnDragDrop;\r\n property OnDragOver;\r\n property OnEndDock;\r\n property OnEndDrag;\r\n property OnEnter;\r\n property OnExit;\r\n property OnKeyDown;\r\n property OnKeyPress;\r\n property OnKeyUp;\r\n property OnMouseDown;\r\n property OnMouseMove;\r\n property OnMouseUp;\r\n property OnStartDock;\r\n property OnStartDrag;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvMemo.pas $';\r\n Revision: '$Revision: 13256 $';\r\n Date: '$Date: 2012-02-28 09:18:58 +0100 (mar. 28 févr. 2012) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n JclStrings;\r\n\r\nconstructor TJvCustomMemo.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FOrigLines := TStringList.Create;\r\n FHotTrack := False;\r\n // ControlStyle := ControlStyle + [csAcceptsControls];\r\n FCaret := TJvCaret.Create(Self);\r\n FCaret.OnChanged := CaretChange;\r\n FTransparent := False;\r\nend;\r\n\r\ndestructor TJvCustomMemo.Destroy;\r\nbegin\r\n FOrigLines.Free;\r\n FCaret.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvCustomMemo.WMHScroll(var Msg: TWMHScroll);\r\nbegin\r\n inherited;\r\n if Assigned(FOnHorizontalScroll) then\r\n FOnHorizontalScroll(Self);\r\nend;\r\n\r\nprocedure TJvCustomMemo.WMKeyDown(var Message: TWMKeyDown);\r\nvar\r\n SelLengthBefore: Integer;\r\nbegin\r\n SelLengthBefore := SelLength;\r\n\r\n inherited;\r\n \r\n if SelLength <> SelLengthBefore then\r\n ForceRefreshIfNeeded;\r\nend;\r\n\r\nprocedure TJvCustomMemo.WMLButtonDown(var Message: TWMLButtonDown);\r\nbegin\r\n FSelLengthButtonDown := SelLength;\r\n \r\n inherited;\r\nend;\r\n\r\nprocedure TJvCustomMemo.WMLButtonUp(var Message: TWMLButtonUp);\r\nbegin\r\n inherited;\r\n\r\n if SelLength <> FSelLengthButtonDown then\r\n ForceRefreshIfNeeded;\r\nend;\r\n\r\nprocedure TJvCustomMemo.WMNCPaint(var Message: TWMNCPaint);\r\nbegin\r\n // prevent drawing borders when transparent\r\n if not Transparent then\r\n inherited;\r\nend;\r\n\r\nprocedure TJvCustomMemo.WMVScroll(var Msg: TWMVScroll);\r\nbegin\r\n inherited;\r\n if Assigned(FOnVerticalScroll) then\r\n FOnVerticalScroll(Self);\r\nend;\r\n\r\nprocedure TJvCustomMemo.MouseEnter(Control: TControl);\r\nbegin\r\n if csDesigning in ComponentState then\r\n Exit;\r\n if not MouseOver then\r\n begin\r\n if FHotTrack then\r\n Ctl3D := True;\r\n inherited MouseEnter(Control);\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomMemo.MouseLeave(Control: TControl);\r\nbegin\r\n if MouseOver then\r\n begin\r\n if FHotTrack then\r\n Ctl3D := False;\r\n inherited MouseLeave(Control);\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomMemo.SetHotTrack(Value: Boolean);\r\nbegin\r\n FHotTrack := Value;\r\n Ctl3D := not FHotTrack;\r\nend;\r\n\r\n{ This does not recurse it seems }\r\n\r\nprocedure TJvCustomMemo.Change;\r\nbegin\r\n { only process if maxlines is set - truncate }\r\n if MaxLines > 0 then\r\n while Lines.Count > MaxLines do\r\n Lines.Delete(Lines.Count - 1);\r\n inherited Change;\r\n \r\n ForceRefreshIfNeeded;\r\nend;\r\n\r\nprocedure TJvCustomMemo.CreateParams(var Params: TCreateParams);\r\nbegin\r\n inherited CreateParams(Params);\r\n if Transparent then\r\n begin\r\n ControlStyle := ControlStyle - [csOpaque];\r\n Params.ExStyle := Params.ExStyle or WS_EX_TRANSPARENT\r\n end\r\n else\r\n begin\r\n ControlStyle := ControlStyle + [csOpaque];\r\n Params.ExStyle := Params.ExStyle and not WS_EX_TRANSPARENT;\r\n end;\r\nend;\r\n\r\nfunction TJvCustomMemo.CharOfLine(iLine: Integer): Integer;\r\nbegin\r\n Result := Perform(EM_LINEINDEX, iLine, 0);\r\nend;\r\n\r\nprocedure TJvCustomMemo.CNCtlColorEdit(var Message: TWMCtlColorEdit);\r\nvar\r\n NullBrush: HGDIOBJ;\r\nbegin\r\n inherited;\r\n if Transparent then\r\n begin\r\n NullBrush := GetStockObject(NULL_BRUSH);\r\n SelectObject(Message.ChildDC, NullBrush);\r\n Message.Result := NullBrush;\r\n SetBkMode(Message.ChildDC, Windows.TRANSPARENT);\r\n end\r\n else\r\n begin\r\n SetBkMode(Message.ChildDC, Windows.OPAQUE);\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomMemo.CNCtlColorStatic(var Message: TWMCtlColorStatic);\r\nvar\r\n NullBrush: HGDIOBJ;\r\nbegin\r\n inherited;\r\n if Transparent then\r\n begin\r\n NullBrush := GetStockObject(NULL_BRUSH);\r\n SelectObject(Message.ChildDC, NullBrush);\r\n Message.Result := NullBrush;\r\n SetBkMode(Message.ChildDC, Windows.TRANSPARENT);\r\n end\r\n else\r\n begin\r\n SetBkMode(Message.ChildDC, Windows.OPAQUE);\r\n end;\r\nend;\r\n\r\nfunction TJvCustomMemo.GetCurrentLine: Integer;\r\nbegin\r\n Result := Perform(EM_LINEFROMCHAR, WPARAM(-1), 0);\r\nend;\r\n\r\nfunction TJvCustomMemo.GetFlat: Boolean;\r\nbegin\r\n Result := not Ctl3D;\r\nend;\r\n\r\nprocedure TJvCustomMemo.KeyPress(var Key: Char);\r\nbegin\r\n { only process if maxlines is set }\r\n if MaxLines > 0 then\r\n if Lines.Count >= MaxLines then\r\n begin\r\n { take steps to halt the overflow }\r\n\r\n { no returns - that would make another line }\r\n if CharIsReturn(Key) then\r\n Key := #0;\r\n\r\n { no text at the end except for delete & backspace }\r\n if (CurrentLine >= MaxLines) and not (Key = NativeBackSpace) then\r\n Key := #0;\r\n end;\r\n\r\n inherited KeyPress(Key);\r\nend;\r\n\r\nprocedure TJvCustomMemo.LineScroll(X, Y: Integer);\r\nbegin\r\n Perform(EM_LINESCROLL, X, Y);\r\nend;\r\n\r\nprocedure TJvCustomMemo.SetCurrentLine(NewLine: Integer);\r\nvar\r\n Delta: Integer;\r\nbegin\r\n { truncate the range }\r\n if NewLine >= Lines.Count then\r\n NewLine := Lines.Count - 1;\r\n if NewLine < 0 then\r\n NewLine := 0;\r\n\r\n Delta := NewLine - CurrentLine;\r\n { e.g want to be at line 10, currently on line 8, delta = 2\r\n on want to be on line 5, currently line 15, delta = -10 }\r\n if Delta <> 0 then\r\n begin\r\n { scroll into view }\r\n LineScroll(0, Delta);\r\n { move caret }\r\n SelStart := CharOfLine(NewLine);\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomMemo.SetFlat(const Value: Boolean);\r\nbegin\r\n Ctl3D := not Value;\r\nend;\r\n\r\nprocedure TJvCustomMemo.SetTransparent(Value: Boolean);\r\nbegin\r\n if Value <> FTransparent then\r\n begin\r\n FTransparent := Value;\r\n RecreateWnd;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomMemo.CaretChange(Sender: TObject);\r\nbegin\r\n FCaret.CreateCaret;\r\nend;\r\n\r\nprocedure TJvCustomMemo.SetCaret(const Value: TJvCaret);\r\nbegin\r\n FCaret.Assign(Value);\r\nend;\r\n\r\nprocedure TJvCustomMemo.FocusSet(PrevWnd: THandle);\r\nbegin\r\n inherited FocusSet(PrevWnd);\r\n FCaret.CreateCaret;\r\n if FHideCaret then\r\n Windows.HideCaret(Handle);\r\nend;\r\n\r\nprocedure TJvCustomMemo.SetMaxLines(const Value: Integer);\r\nbegin\r\n if FMaxLines <> Value then\r\n begin\r\n if FMaxLines = 0 then\r\n // save original content\r\n FOrigLines.Assign(Lines);\r\n FMaxLines := Value;\r\n if FMaxLines = 0 then\r\n // restore original content\r\n Lines.Assign(FOrigLines);\r\n Change;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomMemo.SetParentFlat(const Value: Boolean);\r\nbegin\r\n ParentCtl3D := Value;\r\nend;\r\n\r\nfunction TJvCustomMemo.GetLines: TStrings;\r\nbegin\r\n Result := inherited Lines;\r\nend;\r\n\r\nfunction TJvCustomMemo.GetParentFlat: Boolean;\r\nbegin\r\n Result := ParentCtl3D;\r\nend;\r\n\r\nprocedure TJvCustomMemo.SetLines(const Value: TStrings);\r\nbegin\r\n inherited SetLines(Value);\r\n if MaxLines > 0 then\r\n // save original content\r\n FOrigLines.Assign(Value);\r\n Change;\r\nend;\r\n\r\nprocedure TJvCustomMemo.SetHideCaret(const Value: Boolean);\r\nbegin\r\n if FHideCaret <> Value then\r\n begin\r\n FHideCaret := Value;\r\n if [csDesigning, csLoading] * ComponentState = [] then\r\n begin\r\n if Focused and FCaret.CaretCreated then\r\n begin\r\n if FHideCaret then\r\n Windows.HideCaret(Handle)\r\n else\r\n Windows.ShowCaret(Handle);\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomMemo.FocusKilled(NextWnd: THandle);\r\nbegin\r\n if FHideCaret then\r\n ShowCaret(Handle);\r\n FCaret.DestroyCaret;\r\n inherited FocusKilled(NextWnd);\r\nend;\r\n\r\nprocedure TJvCustomMemo.DefaultHandler(var Message);\r\n\r\n procedure Scroll(Msg, ScrollCode: Integer);\r\n begin\r\n Perform(Msg, ScrollCode, 0);\r\n Perform(Msg, SB_ENDSCROLL, 0);\r\n end;\r\n\r\nbegin\r\n if FHideCaret and not (csDesigning in ComponentState) then\r\n begin\r\n case TMessage(Message).Msg of\r\n WM_LBUTTONDOWN:\r\n begin\r\n if not Focused then\r\n SetFocus;\r\n TMessage(Message).Result := 0;\r\n end;\r\n\r\n WM_LBUTTONUP, WM_MOUSEMOVE, WM_LBUTTONDBLCLK, WM_CHAR, WM_KEYUP:\r\n TMessage(Message).Result := 0;\r\n\r\n WM_KEYDOWN:\r\n begin\r\n case TWMKeyDown(Message).CharCode of\r\n VK_DOWN:\r\n Scroll(WM_VSCROLL, SB_LINEDOWN);\r\n VK_UP:\r\n Scroll(WM_VSCROLL, SB_LINEUP);\r\n VK_LEFT:\r\n Scroll(WM_HSCROLL, SB_LINELEFT);\r\n VK_RIGHT:\r\n Scroll(WM_HSCROLL, SB_LINERIGHT);\r\n VK_NEXT:\r\n Scroll(WM_VSCROLL, SB_PAGEDOWN);\r\n VK_PRIOR:\r\n Scroll(WM_VSCROLL, SB_PAGEUP);\r\n VK_HOME:\r\n Scroll(WM_VSCROLL, SB_TOP);\r\n VK_END:\r\n Scroll(WM_VSCROLL, SB_BOTTOM);\r\n end;\r\n TMessage(Message).Result := 0;\r\n end;\r\n else\r\n inherited DefaultHandler(Message);\r\n end;\r\n end\r\n else\r\n inherited DefaultHandler(Message);\r\nend;\r\n\r\nprocedure TJvCustomMemo.ForceRefreshIfNeeded;\r\nbegin\r\n // Calling RecreateWnd is quite ugly but simply calling Repaint is not enough...\r\n if Transparent then\r\n RecreateWnd;\r\nend;\r\n\r\nprocedure TJvCustomMemo.WMPaint(var Msg: TWMPaint);\r\nvar\r\n DC: HDC;\r\nbegin\r\n DC := GetDC(Handle);\r\n try\r\n if Transparent then\r\n SetBkMode(DC, Windows.TRANSPARENT)\r\n else\r\n SetBkMode(DC, Windows.OPAQUE);\r\n finally\r\n ReleaseDC(Handle, DC);\r\n end;\r\n inherited;\r\nend;\r\n\r\nfunction TJvCustomMemo.DoEraseBackground(Canvas: TCanvas; Param: LPARAM): Boolean;\r\nbegin\r\n if not Transparent then\r\n Result := inherited DoEraseBackground(Canvas, Param)\r\n else\r\n Result := False;\r\nend;\r\n\r\nprocedure TJvCustomMemo.SetClipboardCommands(const Value: TJvClipboardCommands);\r\nbegin\r\n if ClipboardCommands <> Value then\r\n begin\r\n inherited SetClipboardCommands(Value);\r\n ReadOnly := ClipboardCommands <= [caCopy];\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomMemo.WMClear(var Msg: TMessage);\r\nbegin\r\n if not ReadOnly then\r\n inherited;\r\nend;\r\n\r\nprocedure TJvCustomMemo.WMUndo(var Msg: TMessage);\r\nbegin\r\n if not ReadOnly then\r\n inherited;\r\nend;\r\n\r\nprocedure TJvCustomMemo.WMCut(var Msg: TMessage);\r\nbegin\r\n if not ReadOnly then\r\n inherited;\r\nend;\r\n\r\nprocedure TJvCustomMemo.WMPaste(var Msg: TMessage);\r\nbegin\r\n if not ReadOnly then\r\n inherited;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvMemoryDataset.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvMemDS.PAS, released on 2002-07-04.\r\n\r\nThe Initial Developers of the Original Code are: Fedor Koshevnikov, Igor Pavluk and Serge Korolev\r\nCopyright (c) 1997, 1998 Fedor Koshevnikov, Igor Pavluk and Serge Korolev\r\nCopyright (c) 2001,2002 SGB Software\r\nAll Rights Reserved.\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n\r\n//********************** Added by Claudio F. Zwitkovits (CFZ) **************************\r\n Property DataSet <== Attach any bi-directional DataSet (TTable,TQuery,etc)\r\n Property DataSetClosed <== True/False If After Load Structure and/or Records, Close the attached DataSet\r\n Property KeyFieldNames <== String with the names of the fields from the primary key / Index key\r\n Property ApplyMode <== The mode do Apply the changes in original DataSet\r\n amNone = Not Apply\r\n amAppend = Allow ONLY insert records, and edit/delete this records inserted\r\n amMerge = Allow ALL (Insert,Edit,Delete) records\r\n Property ExactApply <== If True, the RowsAffected (Applied) EQUAL FRowsChanged\r\n If False, Apply Tolerance\r\n Property LoadStructure <== If True, is NOT needed define the fields in design time\r\n the JvMemoryData load the fields from the original dataset\r\n Property LoadRecords <== TRUE/FALSE Auto-load records from the original dataset.\r\n Property SaveLoadState <== Return if loading or saving from/to other dataset.\r\n Events BeforeApply, AfterApply <== in the calling to the ApplyChanges and SaveToDataset methods.\r\n BeforeApplyRecord, AfterApplyRecord <== in the calling to the ApplyChanges and SaveToDataset methods.\r\n Methods (Public) ApplyChanges and CancelChanges <== Save / Discard the changes into\r\n the original DataSet.\r\n Methods (Public) IsLoading <== True/False. If the JvMemData is loading data from external dataset\r\n (LoadFromDataSet or CopyFromDataSet)\r\n Methods (Public) IsSaving <== True/False If the JvMemData is saving data to external dataset\r\n (SaveToDataSet or ApplyChanges)\r\n Methods (Public) IsInserted, IsUpdated, IsOriginal, IsDeleted\r\n return the status from the current record\r\n Methods (Public) GetValues() <== Obtain the values from list of Fields or Key Fields\r\n IMPORTANT : This component, add a hidden field, in the last position ( in FieldDefs\r\n And Fields Lists ) and save the STATUS of the current record\r\n (rsOriginal, rsInserted, rsUpdated), in the hidden field.\r\n Likewise, have a private List (FDeletedValues) with the primary key values\r\n from the Deleted records (rsDeleted).\r\n//********************** Added by c.schiffler (CS) **************************\r\n Methods (protected) SetFilterText <== hook up expression parsing.\r\n Field FFilterParser - see unit JvExprParser.pas\r\n\r\nImplementation : 2004/03/03\r\nRevisions : 1st = 2004/09/19\r\n 2nd = 2004/10/19\r\n 3th = 2004/10/25\r\n 4th = 2005/01/05\r\n 5th = 2005/12/20\r\n 6th = 2006/03/24\r\n 7th = 2007/03/25\r\n 8th = 2007/06/20\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvMemoryDataset.pas 13416 2012-09-10 10:09:31Z obones $\r\n\r\nunit JvMemoryDataset;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n Windows, // to avoid warning under BDS2006, and in the interface section to allow compilation in RS2008\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n SysUtils, Classes, DB, Variants,\r\n JvDBUtils, JvExprParser, JvDBFilterExpr;\r\n\r\ntype\r\n TPVariant = ^Variant;\r\n TApplyMode = (amNone, amAppend, amMerge);\r\n TApplyEvent = procedure(Dataset: TDataset; Rows: Integer) of object;\r\n TRecordStatus = (rsOriginal, rsUpdated, rsInserted, rsDeleted);\r\n TApplyRecordEvent = procedure(Dataset: TDataset; RecStatus: TRecordStatus; FoundApply: Boolean) of object;\r\n TMemBlobData = string;\r\n TMemBlobArray = array[0..0] of TMemBlobData;\r\n PMemBlobArray = ^TMemBlobArray;\r\n TJvMemoryRecord = class;\r\n TLoadMode = (lmCopy, lmAppend);\r\n TSaveLoadState = (slsNone, slsLoading, slsSaving);\r\n TCompareRecords = function(Item1, Item2: TJvMemoryRecord): Integer of object;\r\n TWordArray = array of Word;\r\n {$IFDEF RTL240_UP}\r\n PJvMemBuffer = PByte;\r\n TJvBookmark = TBookmark;\r\n TJvValueBuffer = TValueBuffer;\r\n TJvRecordBuffer = TRecordBuffer;\r\n {$ELSE}\r\n {$IFDEF UNICODE}\r\n PJvMemBuffer = PByte;\r\n {$ELSE}\r\n PJvMemBuffer = PAnsiChar;\r\n {$ENDIF UNICODE}\r\n TJvBookmark = Pointer;\r\n TJvValueBuffer = Pointer;\r\n TJvRecordBuffer = Pointer;\r\n {$ENDIF RTL240_UP}\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvMemoryData = class(TDataSet)\r\n private\r\n FSaveLoadState: TSaveLoadState;\r\n FRecordPos: Integer;\r\n FRecordSize: Integer;\r\n FBookmarkOfs: Integer;\r\n FBlobOfs: Integer;\r\n FRecBufSize: Integer;\r\n FOffsets: TWordArray;\r\n FLastID: Integer;\r\n FAutoInc: Longint;\r\n FActive: Boolean;\r\n FRecords: TList;\r\n FIndexList: TList;\r\n FCaseInsensitiveSort: Boolean;\r\n FDescendingSort: Boolean;\r\n FAutoIncField: TField;\r\n FSrcAutoIncField: TField;\r\n FDataSet: TDataSet;\r\n FDataSetClosed: Boolean;\r\n FLoadStructure: Boolean;\r\n FLoadRecords: Boolean;\r\n FKeyFieldNames: string;\r\n FApplyMode: TApplyMode;\r\n FExactApply: Boolean;\r\n FAutoIncAsInteger: Boolean;\r\n FOneValueInArray: Boolean;\r\n FRowsOriginal: Integer;\r\n FRowsChanged: Integer;\r\n FRowsAffected: Integer;\r\n FDeletedValues: TList;\r\n FStatusName: string;\r\n FBeforeApply: TApplyEvent;\r\n FAfterApply: TApplyEvent;\r\n FBeforeApplyRecord: TApplyRecordEvent;\r\n FAfterApplyRecord: TApplyRecordEvent;\r\n FFilterParser: TExprParser; // CSchiffler. June 2009. See JvExprParser.pas\r\n FFilterExpression: TJvDBFilterExpression; // ahuser. Same filter expression parser that ClientDataSet uses\r\n FCopyFromDataSetFieldDefs: array of Integer; // only valid while CopyFromDataSet is executed\r\n FClearing: Boolean;\r\n FUseDataSetFilter: Boolean;\r\n FTrimEmptyString: Boolean;\r\n function AddRecord: TJvMemoryRecord;\r\n function InsertRecord(Index: Integer): TJvMemoryRecord;\r\n function FindRecordID(ID: Integer): TJvMemoryRecord;\r\n procedure CreateIndexList(const FieldNames: WideString);\r\n procedure FreeIndexList;\r\n procedure QuickSort(L, R: Integer; Compare: TCompareRecords);\r\n procedure Sort;\r\n function CalcRecordSize: Integer;\r\n function GetMemoryRecord(Index: Integer): TJvMemoryRecord;\r\n function GetCapacity: Integer;\r\n function RecordFilter: Boolean;\r\n procedure SetCapacity(Value: Integer);\r\n procedure ClearRecords;\r\n procedure InitBufferPointers(GetProps: Boolean);\r\n procedure FixReadOnlyFields(MakeReadOnly: Boolean);\r\n procedure SetDataSet(ADataSet: TDataSet);\r\n procedure CheckStructure(UseAutoIncAsInteger: Boolean = False);\r\n procedure AddStatusField;\r\n procedure HideStatusField;\r\n function CopyFromDataSet: Integer;\r\n procedure ClearChanges;\r\n procedure DoBeforeApply(ADataset: TDataset; RowsPending: Integer);\r\n procedure DoAfterApply(ADataset: TDataset; RowsApplied: Integer);\r\n procedure DoBeforeApplyRecord(ADataset: TDataset; RS: TRecordStatus; Found: Boolean);\r\n procedure DoAfterApplyRecord(ADataset: TDataset; RS: TRecordStatus; Apply: Boolean);\r\n procedure SetUseDataSetFilter(const Value: Boolean);\r\n protected\r\n function FindFieldData(Buffer: Pointer; Field: TField): Pointer;\r\n function CompareFields(Data1, Data2: Pointer; FieldType: TFieldType;\r\n CaseInsensitive: Boolean): Integer; virtual;\r\n {$IFNDEF COMPILER10_UP} // Delphi 2006+ has support for WideString\r\n procedure DataConvert(Field: TField; Source, Dest: Pointer; ToNative: Boolean); override;\r\n {$ENDIF ~COMPILER10_UP}\r\n procedure AssignMemoryRecord(Rec: TJvMemoryRecord; Buffer: PJvMemBuffer);\r\n function GetActiveRecBuf(var RecBuf: PJvMemBuffer): Boolean; virtual;\r\n procedure InitFieldDefsFromFields;\r\n procedure RecordToBuffer(Rec: TJvMemoryRecord; Buffer: PJvMemBuffer);\r\n procedure SetMemoryRecordData(Buffer: PJvMemBuffer; Pos: Integer); virtual;\r\n procedure SetAutoIncFields(Buffer: PJvMemBuffer); virtual;\r\n function CompareRecords(Item1, Item2: TJvMemoryRecord): Integer; virtual;\r\n function GetBlobData(Field: TField; Buffer: PJvMemBuffer): TMemBlobData;\r\n procedure SetBlobData(Field: TField; Buffer: PJvMemBuffer; Value: TMemBlobData);\r\n function AllocRecordBuffer: PJvMemBuffer; override;\r\n procedure FreeRecordBuffer(var Buffer: PJvMemBuffer); override;\r\n procedure InternalInitRecord(Buffer: PJvMemBuffer); override;\r\n procedure ClearCalcFields(Buffer: PJvMemBuffer); override;\r\n function GetRecord(Buffer: PJvMemBuffer; GetMode: TGetMode;\r\n DoCheck: Boolean): TGetResult; override;\r\n function GetRecordSize: Word; override;\r\n procedure SetFiltered(Value: Boolean); override;\r\n procedure SetOnFilterRecord(const Value: TFilterRecordEvent); override;\r\n procedure SetFieldData(Field: TField; Buffer: TJvValueBuffer); override;\r\n procedure CloseBlob(Field: TField); override;\r\n procedure GetBookmarkData(Buffer: PJvMemBuffer; Data: TJvBookmark); override;\r\n function GetBookmarkFlag(Buffer: PJvMemBuffer): TBookmarkFlag; override;\r\n procedure InternalGotoBookmark(Bookmark: TJvBookmark); override;\r\n procedure InternalSetToRecord(Buffer: PJvMemBuffer); override;\r\n procedure SetBookmarkFlag(Buffer: PJvMemBuffer; Value: TBookmarkFlag); override;\r\n procedure SetBookmarkData(Buffer: PJvMemBuffer; Data: TJvBookmark); override;\r\n function GetIsIndexField(Field: TField): Boolean; override;\r\n procedure InternalFirst; override;\r\n procedure InternalLast; override;\r\n procedure InitRecord(Buffer: PJvMemBuffer); override;\r\n procedure InternalAddRecord(Buffer: TJvRecordBuffer; Append: Boolean); override;\r\n procedure InternalDelete; override;\r\n procedure InternalPost; override;\r\n procedure InternalClose; override;\r\n procedure InternalHandleException; override;\r\n procedure InternalInitFieldDefs; override;\r\n procedure InternalOpen; override;\r\n procedure OpenCursor(InfoQuery: Boolean); override;\r\n function IsCursorOpen: Boolean; override;\r\n function GetRecordCount: Integer; override;\r\n function GetRecNo: Integer; override;\r\n procedure SetRecNo(Value: Integer); override;\r\n procedure DoAfterOpen; override;\r\n procedure SetFilterText(const Value: string); override;\r\n function ParserGetVariableValue(Sender: TObject; const VarName: string; var Value: Variant): Boolean; virtual;\r\n procedure Notification(AComponent: TComponent; Operation: TOperation); override;\r\n property Records[Index: Integer]: TJvMemoryRecord read GetMemoryRecord;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n function BookmarkValid(Bookmark: TBookmark): Boolean; override;\r\n function CompareBookmarks(Bookmark1, Bookmark2: TBookmark): Integer; override;\r\n function CreateBlobStream(Field: TField; Mode: TBlobStreamMode): TStream; override;\r\n function GetFieldData(Field: TField; Buffer: TJvValueBuffer): Boolean; override;\r\n function GetCurrentRecord(Buffer: PJvMemBuffer): Boolean; override;\r\n function IsSequenced: Boolean; override;\r\n function Locate(const KeyFields: string; const KeyValues: Variant;\r\n Options: TLocateOptions): Boolean; override;\r\n function Lookup(const KeyFields: string; const KeyValues: Variant;\r\n const ResultFields: string): Variant; override;\r\n procedure SortOnFields(const FieldNames: string = '';\r\n CaseInsensitive: Boolean = True; Descending: Boolean = False);\r\n procedure SwapRecords(Idx1: integer; Idx2: integer);\r\n procedure EmptyTable;\r\n procedure CopyStructure(Source: TDataSet; UseAutoIncAsInteger: Boolean = False);\r\n function LoadFromDataSet(Source: TDataSet; RecordCount: Integer;\r\n Mode: TLoadMode; DisableAllControls: Boolean = True): Integer;\r\n function SaveToDataSet(Dest: TDataSet; RecordCount: Integer; DisableAllControls: Boolean = True): Integer;\r\n property SaveLoadState: TSaveLoadState read FSaveLoadState;\r\n function GetValues(FldNames: string = ''): Variant;\r\n function FindDeleted(KeyValues: Variant): Integer;\r\n function IsDeleted(out Index: Integer): Boolean;\r\n function IsInserted: Boolean;\r\n function IsUpdated: Boolean;\r\n function IsOriginal: Boolean;\r\n procedure CancelChanges;\r\n function ApplyChanges: Boolean;\r\n function IsLoading: Boolean;\r\n function IsSaving: Boolean;\r\n property RowsOriginal: Integer read FRowsOriginal;\r\n property RowsChanged: Integer read FRowsChanged;\r\n property RowsAffected: Integer read FRowsAffected;\r\n published\r\n property Capacity: Integer read GetCapacity write SetCapacity default 0;\r\n property Active;\r\n property AutoCalcFields;\r\n property Filtered;\r\n property FilterOptions;\r\n property UseDataSetFilter: Boolean read FUseDataSetFilter write SetUseDataSetFilter default False;\r\n property FieldDefs;\r\n property ObjectView default False;\r\n property DataSet: TDataSet read FDataSet write SetDataSet;\r\n property DatasetClosed: Boolean read FDatasetClosed write FDatasetClosed default False;\r\n property KeyFieldNames: string read FKeyFieldNames write FKeyFieldNames;\r\n property LoadStructure: Boolean read FLoadStructure write FLoadStructure default False;\r\n property LoadRecords: Boolean read FLoadRecords write FLoadRecords default False;\r\n property ApplyMode: TApplyMode read FApplyMode write FApplyMode default amNone;\r\n property ExactApply: Boolean read FExactApply write FExactApply default False;\r\n property AutoIncAsInteger: Boolean read FAutoIncAsInteger write FAutoIncAsInteger default False;\r\n property OneValueInArray: Boolean read FOneValueInArray write FOneValueInArray default True;\r\n property TrimEmptyString: Boolean read FTrimEmptyString write FTrimEmptyString default True;\r\n property BeforeOpen;\r\n property AfterOpen;\r\n property BeforeClose;\r\n property AfterClose;\r\n property BeforeInsert;\r\n property AfterInsert;\r\n property BeforeEdit;\r\n property AfterEdit;\r\n property BeforePost;\r\n property AfterPost;\r\n property BeforeCancel;\r\n property AfterCancel;\r\n property BeforeDelete;\r\n property AfterDelete;\r\n property BeforeScroll;\r\n property AfterScroll;\r\n property OnCalcFields;\r\n property OnDeleteError;\r\n property OnEditError;\r\n property OnFilterRecord;\r\n property OnNewRecord;\r\n property OnPostError;\r\n property BeforeApply: TApplyEvent read FBeforeApply write FBeforeApply;\r\n property AfterApply: TApplyEvent read FAfterApply write FAfterApply;\r\n property BeforeApplyRecord: TApplyRecordEvent read FBeforeApplyRecord write FBeforeApplyRecord;\r\n property AfterApplyRecord: TApplyRecordEvent read FAfterApplyRecord write FAfterApplyRecord;\r\n end;\r\n\r\n TJvMemBlobStream = class(TStream)\r\n private\r\n FField: TBlobField;\r\n FDataSet: TJvMemoryData;\r\n FBuffer: PJvMemBuffer;\r\n FMode: TBlobStreamMode;\r\n FOpened: Boolean;\r\n FModified: Boolean;\r\n FPosition: Longint;\r\n FCached: Boolean;\r\n function GetBlobSize: Longint;\r\n function GetBlobFromRecord(Field: TField): TMemBlobData;\r\n public\r\n constructor Create(Field: TBlobField; Mode: TBlobStreamMode);\r\n destructor Destroy; override;\r\n function Read(var Buffer; Count: Longint): Longint; override;\r\n function Write(const Buffer; Count: Longint): Longint; override;\r\n function Seek(Offset: Longint; Origin: Word): Longint; override;\r\n procedure Truncate;\r\n end;\r\n\r\n TJvMemoryRecord = class(TPersistent)\r\n private\r\n FMemoryData: TJvMemoryData;\r\n FID: Integer;\r\n FData: Pointer;\r\n FBlobs: Pointer;\r\n function GetIndex: Integer;\r\n procedure SetMemoryData(Value: TJvMemoryData; UpdateParent: Boolean);\r\n protected\r\n procedure SetIndex(Value: Integer); virtual;\r\n public\r\n constructor Create(MemoryData: TJvMemoryData); virtual;\r\n constructor CreateEx(MemoryData: TJvMemoryData; UpdateParent: Boolean); virtual;\r\n destructor Destroy; override;\r\n property MemoryData: TJvMemoryData read FMemoryData;\r\n property ID: Integer read FID write FID;\r\n property Index: Integer read GetIndex write SetIndex;\r\n property Data: Pointer read FData;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvMemoryDataset.pas $';\r\n Revision: '$Revision: 13416 $';\r\n Date: '$Date: 2012-09-10 12:09:31 +0200 (lun. 10 sept. 2012) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n Types, DBConsts, Math,\r\n {$IFDEF RTL240_UP}\r\n System.Generics.Collections,\r\n {$ENDIF RTL240_UP}\r\n {$IFDEF HAS_UNIT_ANSISTRINGS}\r\n AnsiStrings,\r\n {$ENDIF HAS_UNIT_ANSISTRINGS}\r\n FMTBcd, SqlTimSt,\r\n {$IFNDEF UNICODE}\r\n JvJCLUtils,\r\n {$ENDIF ~UNICODE}\r\n JvJVCLUtils,\r\n JvResources, JclSysUtils;\r\n\r\nconst\r\n ftBlobTypes = [ftBlob, ftMemo, ftGraphic, ftFmtMemo, ftParadoxOle,\r\n ftDBaseOle, ftTypedBinary, ftOraBlob, ftOraClob\r\n {$IFDEF COMPILER10_UP}, ftWideMemo{$ENDIF COMPILER10_UP}];\r\n\r\n // If you add a new supported type you _must_ also update CalcFieldLen()\r\n ftSupported = [ftString, ftSmallint, ftInteger, ftWord, ftBoolean,\r\n ftFloat, ftCurrency, ftDate, ftTime, ftDateTime, ftAutoInc, ftBCD,\r\n ftFMTBCD, ftTimestamp,\r\n {$IFDEF COMPILER10_UP}\r\n ftOraTimestamp, ftFixedWideChar,\r\n {$ENDIF COMPILER10_UP}\r\n {$IFDEF COMPILER12_UP}\r\n ftLongWord, ftShortint, ftByte, ftExtended,\r\n {$ENDIF COMPILER12_UP}\r\n ftBytes, ftVarBytes, ftADT, ftFixedChar, ftWideString, ftLargeint,\r\n ftVariant, ftGuid] + ftBlobTypes;\r\n\r\n fkStoredFields = [fkData];\r\n\r\n GuidSize = 38;\r\n\r\n STATUSNAME = 'C67F70Z90'; (* Magic *)\r\n\r\ntype\r\n TBookmarkData = Integer;\r\n PMemBookmarkInfo = ^TMemBookmarkInfo;\r\n\r\n TMemBookmarkInfo = record\r\n BookmarkData: TBookmarkData;\r\n BookmarkFlag: TBookmarkFlag;\r\n end;\r\n\r\nprocedure AppHandleException(Sender: TObject);\r\nbegin\r\n if Assigned(ApplicationHandleException) then\r\n ApplicationHandleException(Sender);\r\nend;\r\n\r\nprocedure CopyFieldValue(DestField, SourceField: TField);\r\nbegin\r\n if SourceField.IsNull then\r\n DestField.Clear\r\n else if DestField.ClassType = SourceField.ClassType then\r\n begin\r\n case DestField.DataType of\r\n ftInteger, ftSmallint, ftWord:\r\n DestField.AsInteger := SourceField.AsInteger;\r\n ftBCD, ftCurrency:\r\n DestField.AsCurrency := SourceField.AsCurrency;\r\n ftFMTBcd:\r\n DestField.AsBCD := SourceField.AsBCD;\r\n ftString:\r\n DestField.AsString := SourceField.AsString;\r\n ftFloat:\r\n DestField.AsFloat := SourceField.AsFloat;\r\n ftDateTime:\r\n DestField.AsDateTime := SourceField.AsDateTime;\r\n else\r\n DestField.Assign(SourceField);\r\n end;\r\n end\r\n else\r\n DestField.Assign(SourceField);;\r\nend;\r\n\r\nfunction CalcFieldLen(FieldType: TFieldType; Size: Word): Word;\r\nbegin\r\n if not (FieldType in ftSupported) then\r\n Result := 0\r\n else\r\n if FieldType in ftBlobTypes then\r\n Result := SizeOf(Longint)\r\n else\r\n begin\r\n Result := Size;\r\n case FieldType of\r\n ftString:\r\n Inc(Result);\r\n ftSmallint:\r\n Result := SizeOf(Smallint);\r\n ftInteger:\r\n Result := SizeOf(Longint);\r\n ftWord:\r\n Result := SizeOf(Word);\r\n ftBoolean:\r\n Result := SizeOf(Wordbool);\r\n ftFloat:\r\n Result := SizeOf(Double);\r\n ftCurrency:\r\n Result := SizeOf(Double);\r\n ftDate, ftTime:\r\n Result := SizeOf(Longint);\r\n ftDateTime:\r\n Result := SizeOf(TDateTime);\r\n ftAutoInc:\r\n Result := SizeOf(Longint);\r\n ftBCD, ftFMTBCD:\r\n Result := SizeOf(TBcd);\r\n ftTimeStamp:\r\n Result := SizeOf(TSQLTimeStamp);\r\n {$IFDEF COMPILER10_UP}\r\n ftOraTimestamp:\r\n Result := SizeOf(TSQLTimeStamp);\r\n ftFixedWideChar:\r\n Result := (Result + 1) * SizeOf(WideChar);\r\n {$ENDIF COMPILER10_UP}\r\n {$IFDEF COMPILER12_UP}\r\n ftLongWord:\r\n Result := SizeOf(LongWord);\r\n ftShortint:\r\n Result := SizeOf(Shortint);\r\n ftByte:\r\n Result := SizeOf(Byte);\r\n ftExtended:\r\n Result := SizeOf(Extended);\r\n {$ENDIF COMPILER12_UP}\r\n ftBytes:\r\n Result := Size;\r\n ftVarBytes:\r\n Result := Size + 2;\r\n ftADT:\r\n Result := 0;\r\n ftFixedChar:\r\n Inc(Result);\r\n ftWideString:\r\n Result := (Result + 1) * SizeOf(WideChar);\r\n ftLargeint:\r\n Result := SizeOf(Int64);\r\n ftVariant:\r\n Result := SizeOf(Variant);\r\n ftGuid:\r\n Result := GuidSize + 1;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure CalcDataSize(FieldDef: TFieldDef; var DataSize: Integer);\r\nvar\r\n I: Integer;\r\nbegin\r\n if FieldDef.DataType in ftSupported - ftBlobTypes then\r\n Inc(DataSize, CalcFieldLen(FieldDef.DataType, FieldDef.Size) + 1);\r\n for I := 0 to FieldDef.ChildDefs.Count - 1 do\r\n CalcDataSize(FieldDef.ChildDefs[I], DataSize);\r\nend;\r\n\r\nprocedure Error(const Msg: string);\r\nbegin\r\n DatabaseError(Msg);\r\nend;\r\n\r\nprocedure ErrorFmt(const Msg: string; const Args: array of const);\r\nbegin\r\n DatabaseErrorFmt(Msg, Args);\r\nend;\r\n\r\n//=== { TJvMemoryRecord } ====================================================\r\n\r\nconstructor TJvMemoryRecord.Create(MemoryData: TJvMemoryData);\r\nbegin\r\n CreateEx(MemoryData, True);\r\nend;\r\n\r\nconstructor TJvMemoryRecord.CreateEx(MemoryData: TJvMemoryData; UpdateParent: Boolean);\r\nbegin\r\n inherited Create;\r\n SetMemoryData(MemoryData, UpdateParent);\r\nend;\r\n\r\ndestructor TJvMemoryRecord.Destroy;\r\nbegin\r\n SetMemoryData(nil, True);\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJvMemoryRecord.GetIndex: Integer;\r\nbegin\r\n if FMemoryData <> nil then\r\n Result := FMemoryData.FRecords.IndexOf(Self)\r\n else\r\n Result := -1;\r\nend;\r\n\r\nprocedure TJvMemoryRecord.SetMemoryData(Value: TJvMemoryData; UpdateParent: Boolean);\r\nvar\r\n I: Integer;\r\n DataSize: Integer;\r\nbegin\r\n if FMemoryData <> Value then\r\n begin\r\n if FMemoryData <> nil then\r\n begin\r\n if not FMemoryData.FClearing then\r\n FMemoryData.FRecords.Remove(Self);\r\n if FMemoryData.BlobFieldCount > 0 then\r\n Finalize(PMemBlobArray(FBlobs)[0], FMemoryData.BlobFieldCount);\r\n ReallocMem(FBlobs, 0);\r\n ReallocMem(FData, 0);\r\n FMemoryData := nil;\r\n end;\r\n if Value <> nil then\r\n begin\r\n if UpdateParent then\r\n begin\r\n Value.FRecords.Add(Self);\r\n Inc(Value.FLastID);\r\n FID := Value.FLastID;\r\n end;\r\n FMemoryData := Value;\r\n if Value.BlobFieldCount > 0 then\r\n begin\r\n ReallocMem(FBlobs, Value.BlobFieldCount * SizeOf(Pointer));\r\n Initialize(PMemBlobArray(FBlobs)[0], Value.BlobFieldCount);\r\n end;\r\n DataSize := 0;\r\n for I := 0 to Value.FieldDefs.Count - 1 do\r\n CalcDataSize(Value.FieldDefs[I], DataSize);\r\n ReallocMem(FData, DataSize);\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvMemoryRecord.SetIndex(Value: Integer);\r\nvar\r\n CurIndex: Integer;\r\nbegin\r\n CurIndex := GetIndex;\r\n if (CurIndex >= 0) and (CurIndex <> Value) then\r\n FMemoryData.FRecords.Move(CurIndex, Value);\r\nend;\r\n\r\n//=== { TJvMemoryData } ======================================================\r\n\r\nconstructor TJvMemoryData.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FRecordPos := -1;\r\n FLastID := Low(Integer);\r\n FAutoInc := 1;\r\n FRecords := TList.Create;\r\n FStatusName := STATUSNAME;\r\n FDeletedValues := TList.Create;\r\n FRowsOriginal := 0;\r\n FRowsChanged := 0;\r\n FRowsAffected := 0;\r\n FSaveLoadState := slsNone;\r\n FOneValueInArray := True;\r\n FDataSetClosed := False;\r\n FTrimEmptyString := True;\r\nend;\r\n\r\ndestructor TJvMemoryData.Destroy;\r\nvar\r\n I: Integer;\r\n PFValues: TPVariant;\r\nbegin\r\n if Active then\r\n Close;\r\n if FFilterParser <> nil then\r\n FreeAndNil(FFilterParser);\r\n if FFilterExpression <> nil then\r\n FreeAndNil(FFilterExpression);\r\n if Assigned(FDeletedValues) then\r\n begin\r\n if FDeletedValues.Count > 0 then\r\n for I := 0 to (FDeletedValues.Count - 1) do\r\n begin\r\n PFValues := FDeletedValues[I];\r\n if PFValues <> nil then\r\n Dispose(PFValues);\r\n FDeletedValues[I] := nil;\r\n end;\r\n FreeAndNil(FDeletedValues);\r\n end;\r\n FreeIndexList;\r\n ClearRecords;\r\n SetDataSet(nil);\r\n FRecords.Free;\r\n FOffsets := nil;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJvMemoryData.CompareFields(Data1, Data2: Pointer;\r\n FieldType: TFieldType; CaseInsensitive: Boolean): Integer;\r\nbegin\r\n Result := 0;\r\n case FieldType of\r\n ftString:\r\n if CaseInsensitive then\r\n Result := AnsiCompareText(PAnsiChar(Data1), PAnsiChar(Data2))\r\n else\r\n Result := AnsiCompareStr(PAnsiChar(Data1), PAnsiChar(Data2));\r\n ftSmallint:\r\n if Smallint(Data1^) > Smallint(Data2^) then\r\n Result := 1\r\n else\r\n if Smallint(Data1^) < Smallint(Data2^) then\r\n Result := -1;\r\n ftInteger, ftDate, ftTime, ftAutoInc:\r\n if Longint(Data1^) > Longint(Data2^) then\r\n Result := 1\r\n else\r\n if Longint(Data1^) < Longint(Data2^) then\r\n Result := -1;\r\n ftWord:\r\n if Word(Data1^) > Word(Data2^) then\r\n Result := 1\r\n else\r\n if Word(Data1^) < Word(Data2^) then\r\n Result := -1;\r\n ftBoolean:\r\n if Wordbool(Data1^) and not Wordbool(Data2^) then\r\n Result := 1\r\n else\r\n if not Wordbool(Data1^) and Wordbool(Data2^) then\r\n Result := -1;\r\n ftFloat, ftCurrency:\r\n if Double(Data1^) > Double(Data2^) then\r\n Result := 1\r\n else\r\n if Double(Data1^) < Double(Data2^) then\r\n Result := -1;\r\n ftFMTBcd, ftBcd:\r\n Result := BcdCompare(TBcd(Data1^), TBcd(Data2^));\r\n ftDateTime:\r\n if TDateTime(Data1^) > TDateTime(Data2^) then\r\n Result := 1\r\n else\r\n if TDateTime(Data1^) < TDateTime(Data2^) then\r\n Result := -1;\r\n ftFixedChar:\r\n if CaseInsensitive then\r\n Result := AnsiCompareText(PAnsiChar(Data1), PAnsiChar(Data2))\r\n else\r\n Result := AnsiCompareStr(PAnsiChar(Data1), PAnsiChar(Data2));\r\n ftWideString:\r\n if CaseInsensitive then\r\n Result := AnsiCompareText(WideCharToString(PWideChar(Data1)),\r\n WideCharToString(PWideChar(Data2)))\r\n else\r\n Result := AnsiCompareStr(WideCharToString(PWideChar(Data1)),\r\n WideCharToString(PWideChar(Data2)));\r\n ftLargeint:\r\n if Int64(Data1^) > Int64(Data2^) then\r\n Result := 1\r\n else\r\n if Int64(Data1^) < Int64(Data2^) then\r\n Result := -1;\r\n ftVariant:\r\n Result := 0;\r\n ftGuid:\r\n Result := CompareText(PAnsiChar(Data1), PAnsiChar(Data2));\r\n end;\r\nend;\r\n\r\nfunction TJvMemoryData.GetCapacity: Integer;\r\nbegin\r\n if FRecords <> nil then\r\n Result := FRecords.Capacity\r\n else\r\n Result := 0;\r\nend;\r\n\r\nprocedure TJvMemoryData.SetCapacity(Value: Integer);\r\nbegin\r\n if FRecords <> nil then\r\n FRecords.Capacity := Value;\r\nend;\r\n\r\nfunction TJvMemoryData.AddRecord: TJvMemoryRecord;\r\nbegin\r\n Result := TJvMemoryRecord.Create(Self);\r\nend;\r\n\r\nfunction TJvMemoryData.FindRecordID(ID: Integer): TJvMemoryRecord;\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := 0 to FRecords.Count - 1 do\r\n begin\r\n Result := TJvMemoryRecord(FRecords[I]);\r\n if Result.ID = ID then\r\n Exit;\r\n end;\r\n Result := nil;\r\nend;\r\n\r\nfunction TJvMemoryData.InsertRecord(Index: Integer): TJvMemoryRecord;\r\nbegin\r\n Result := AddRecord;\r\n Result.Index := Index;\r\nend;\r\n\r\nfunction TJvMemoryData.GetMemoryRecord(Index: Integer): TJvMemoryRecord;\r\nbegin\r\n Result := TJvMemoryRecord(FRecords[Index]);\r\nend;\r\n\r\nprocedure TJvMemoryData.InitFieldDefsFromFields;\r\nvar\r\n I: Integer;\r\n Offset: Word;\r\n Field: TField;\r\nbegin\r\n if FieldDefs.Count = 0 then\r\n begin\r\n for I := 0 to FieldCount - 1 do\r\n begin\r\n Field := Fields[I];\r\n if (Field.FieldKind in fkStoredFields) and not (Field.DataType in ftSupported) then\r\n ErrorFmt(SUnknownFieldType, [Field.DisplayName]);\r\n end;\r\n FreeIndexList;\r\n end;\r\n Offset := 0;\r\n inherited InitFieldDefsFromFields;\r\n { Calculate fields offsets }\r\n SetLength(FOffsets, FieldDefList.Count);\r\n for I := 0 to FieldDefList.Count - 1 do\r\n begin\r\n FOffsets[I] := Offset;\r\n if FieldDefList[I].DataType in ftSupported - ftBlobTypes then\r\n Inc(Offset, CalcFieldLen(FieldDefList[I].DataType, FieldDefList[I].Size) + 1);\r\n end;\r\nend;\r\n\r\nfunction TJvMemoryData.FindFieldData(Buffer: Pointer; Field: TField): Pointer;\r\nvar\r\n Index: Integer;\r\n DataType: TFieldType;\r\nbegin\r\n Result := nil;\r\n if Length(FCopyFromDataSetFieldDefs) > 0 then\r\n Index := FCopyFromDataSetFieldDefs[Field.Index]\r\n else\r\n Index := FieldDefList.IndexOf(Field.FullName);\r\n if (Index >= 0) and (Buffer <> nil) then\r\n begin\r\n DataType := FieldDefList[Index].DataType;\r\n if DataType in ftSupported then\r\n if DataType in ftBlobTypes then\r\n Result := Pointer(GetBlobData(Field, Buffer))\r\n else\r\n Result := (PJvMemBuffer(Buffer) + FOffsets[Index]);\r\n end;\r\nend;\r\n\r\nfunction TJvMemoryData.CalcRecordSize: Integer;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := 0;\r\n for I := 0 to FieldDefs.Count - 1 do\r\n CalcDataSize(FieldDefs[I], Result);\r\nend;\r\n\r\nprocedure TJvMemoryData.InitBufferPointers(GetProps: Boolean);\r\nbegin\r\n if GetProps then\r\n FRecordSize := CalcRecordSize;\r\n FBookmarkOfs := FRecordSize + CalcFieldsSize;\r\n FBlobOfs := FBookmarkOfs + SizeOf(TMemBookmarkInfo);\r\n FRecBufSize := FBlobOfs + BlobFieldCount * SizeOf(Pointer);\r\nend;\r\n\r\nprocedure TJvMemoryData.ClearRecords;\r\nvar\r\n I: Integer;\r\nbegin\r\n FClearing := True;\r\n try\r\n for I := FRecords.Count - 1 downto 0 do\r\n TJvMemoryRecord(FRecords[I]).Free;\r\n FRecords.Clear;\r\n finally\r\n FClearing := False;\r\n end;\r\n FLastID := Low(Integer);\r\n FRecordPos := -1;\r\nend;\r\n\r\nfunction TJvMemoryData.AllocRecordBuffer: PJvMemBuffer;\r\nbegin\r\n {$IFDEF COMPILER12_UP}\r\n GetMem(Result, FRecBufSize);\r\n {$ELSE}\r\n Result := StrAlloc(FRecBufSize);\r\n {$ENDIF COMPILER12_UP}\r\n if BlobFieldCount > 0 then\r\n Initialize(PMemBlobArray(Result + FBlobOfs)[0], BlobFieldCount);\r\nend;\r\n\r\nprocedure TJvMemoryData.FreeRecordBuffer(var Buffer: PJvMemBuffer);\r\nbegin\r\n if BlobFieldCount > 0 then\r\n Finalize(PMemBlobArray(Buffer + FBlobOfs)[0], BlobFieldCount);\r\n {$IFDEF COMPILER12_UP}\r\n FreeMem(Buffer);\r\n {$ELSE}\r\n StrDispose(Buffer);\r\n {$ENDIF COMPILER12_UP}\r\n Buffer := nil;\r\nend;\r\n\r\nprocedure TJvMemoryData.ClearCalcFields(Buffer: PJvMemBuffer);\r\nbegin\r\n FillChar(Buffer[FRecordSize], CalcFieldsSize, 0);\r\nend;\r\n\r\nprocedure TJvMemoryData.InternalInitRecord(Buffer: PJvMemBuffer);\r\nvar\r\n I: Integer;\r\nbegin\r\n FillChar(Buffer^, FBlobOfs, 0);\r\n for I := 0 to BlobFieldCount - 1 do\r\n PMemBlobArray(Buffer + FBlobOfs)[I] := '';\r\nend;\r\n\r\nprocedure TJvMemoryData.InitRecord(Buffer: PJvMemBuffer);\r\nbegin\r\n inherited InitRecord(Buffer);\r\n with PMemBookmarkInfo(Buffer + FBookmarkOfs)^ do\r\n begin\r\n BookmarkData := Low(Integer);\r\n BookmarkFlag := bfInserted;\r\n end;\r\nend;\r\n\r\nfunction TJvMemoryData.GetCurrentRecord(Buffer: PJvMemBuffer): Boolean;\r\nbegin\r\n Result := False;\r\n if not IsEmpty and (GetBookmarkFlag(ActiveBuffer) = bfCurrent) then\r\n begin\r\n UpdateCursorPos;\r\n if (FRecordPos >= 0) and (FRecordPos < RecordCount) then\r\n begin\r\n Move(Records[FRecordPos].Data^, Buffer^, FRecordSize);\r\n Result := True;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvMemoryData.RecordToBuffer(Rec: TJvMemoryRecord; Buffer: PJvMemBuffer);\r\nvar\r\n I: Integer;\r\nbegin\r\n Move(Rec.Data^, Buffer^, FRecordSize);\r\n with PMemBookmarkInfo(Buffer + FBookmarkOfs)^ do\r\n begin\r\n BookmarkData := Rec.ID;\r\n BookmarkFlag := bfCurrent;\r\n end;\r\n for I := 0 to BlobFieldCount - 1 do\r\n PMemBlobArray(Buffer + FBlobOfs)[I] := PMemBlobArray(Rec.FBlobs)[I];\r\n GetCalcFields(Buffer);\r\nend;\r\n\r\nfunction TJvMemoryData.GetRecord(Buffer: PJvMemBuffer; GetMode: TGetMode;\r\n DoCheck: Boolean): TGetResult;\r\nvar\r\n Accept: Boolean;\r\nbegin\r\n Result := grOk;\r\n Accept := True;\r\n case GetMode of\r\n gmPrior:\r\n if FRecordPos <= 0 then\r\n begin\r\n Result := grBOF;\r\n FRecordPos := -1;\r\n end\r\n else\r\n begin\r\n repeat\r\n Dec(FRecordPos);\r\n if Filtered then\r\n Accept := RecordFilter;\r\n until Accept or (FRecordPos < 0);\r\n if not Accept then\r\n begin\r\n Result := grBOF;\r\n FRecordPos := -1;\r\n end;\r\n end;\r\n gmCurrent:\r\n if (FRecordPos < 0) or (FRecordPos >= RecordCount) then\r\n Result := grError\r\n else\r\n if Filtered then\r\n if not RecordFilter then\r\n Result := grError;\r\n gmNext:\r\n if FRecordPos >= RecordCount - 1 then\r\n Result := grEOF\r\n else\r\n begin\r\n repeat\r\n Inc(FRecordPos);\r\n if Filtered then\r\n Accept := RecordFilter;\r\n until Accept or (FRecordPos > RecordCount - 1);\r\n if not Accept then\r\n begin\r\n Result := grEOF;\r\n FRecordPos := RecordCount - 1;\r\n end;\r\n end;\r\n end;\r\n if Result = grOk then\r\n RecordToBuffer(Records[FRecordPos], Buffer)\r\n else\r\n if (Result = grError) and DoCheck then\r\n Error(RsEMemNoRecords);\r\nend;\r\n\r\nfunction TJvMemoryData.GetRecordSize: Word;\r\nbegin\r\n Result := FRecordSize;\r\nend;\r\n\r\nfunction TJvMemoryData.GetActiveRecBuf(var RecBuf: PJvMemBuffer): Boolean;\r\nbegin\r\n case State of\r\n dsBrowse:\r\n if IsEmpty then\r\n RecBuf := nil\r\n else\r\n RecBuf := ActiveBuffer;\r\n dsEdit, dsInsert:\r\n RecBuf := ActiveBuffer;\r\n dsCalcFields:\r\n RecBuf := CalcBuffer;\r\n dsFilter:\r\n RecBuf := TempBuffer;\r\n else\r\n RecBuf := nil;\r\n end;\r\n Result := RecBuf <> nil;\r\nend;\r\n\r\nfunction TJvMemoryData.GetFieldData(Field: TField; Buffer: TJvValueBuffer): Boolean;\r\nvar\r\n RecBuf: PJvMemBuffer;\r\n Data: PByte;\r\n VarData: Variant;\r\nbegin\r\n Result := False;\r\n if not GetActiveRecBuf(RecBuf) then\r\n Exit;\r\n \r\n if Field.FieldNo > 0 then\r\n begin\r\n Data := FindFieldData(RecBuf, Field);\r\n if Data <> nil then\r\n begin\r\n if Field is TBlobField then\r\n Result := Data <> nil\r\n else\r\n Result := Data^ <> 0;\r\n Inc(Data);\r\n case Field.DataType of\r\n ftGuid:\r\n Result := Result and (StrLen(PAnsiChar(Data)) > 0);\r\n ftString, ftFixedChar:\r\n Result := Result and (not TrimEmptyString or (StrLen(PAnsiChar(Data)) > 0));\r\n ftWideString:\r\n {$IFDEF UNICODE}\r\n Result := Result and (not TrimEmptyString or (StrLen(PWideChar(Data)) > 0));\r\n {$ELSE}\r\n Result := Result and (not TrimEmptyString or (StrLenW(PWideChar(Data)) > 0));\r\n {$ENDIF UNICODE}\r\n end;\r\n if Result and (Buffer <> nil) then\r\n if Field.DataType = ftVariant then\r\n begin\r\n VarData := PVariant(Data)^;\r\n PVariant(Buffer)^ := VarData;\r\n end\r\n else\r\n Move(Data^, {$IFDEF RTL240_UP}PByte(@Buffer[0]){$ELSE}Buffer{$ENDIF RTL240_UP}^, CalcFieldLen(Field.DataType, Field.Size));\r\n end;\r\n end\r\n else\r\n if State in [dsBrowse, dsEdit, dsInsert, dsCalcFields] then\r\n begin\r\n Inc(RecBuf, FRecordSize + Field.Offset);\r\n Result := Byte(RecBuf[0]) <> 0;\r\n if Result and (Buffer <> nil) then\r\n Move(RecBuf[1], {$IFDEF RTL240_UP}PByte(@Buffer[0]){$ELSE}Buffer{$ENDIF RTL240_UP}^, Field.DataSize);\r\n end;\r\nend;\r\n\r\nprocedure TJvMemoryData.SetFieldData(Field: TField; Buffer: TJvValueBuffer);\r\nvar\r\n RecBuf: PJvMemBuffer;\r\n Data: PByte;\r\n VarData: Variant;\r\nbegin\r\n if not (State in dsWriteModes) then\r\n Error(SNotEditing);\r\n GetActiveRecBuf(RecBuf);\r\n if Field.FieldNo > 0 then\r\n begin\r\n if State in [dsCalcFields, dsFilter] then\r\n Error(SNotEditing);\r\n if Field.ReadOnly and not (State in [dsSetKey, dsFilter]) then\r\n ErrorFmt(SFieldReadOnly, [Field.DisplayName]);\r\n Field.Validate(Buffer);\r\n if Field.FieldKind <> fkInternalCalc then\r\n begin\r\n Data := FindFieldData(RecBuf, Field);\r\n if Data <> nil then\r\n begin\r\n if Field.DataType = ftVariant then\r\n begin\r\n if Buffer <> nil then\r\n VarData := PVariant(Buffer)^\r\n else\r\n VarData := EmptyParam;\r\n Data^ := Ord((Buffer <> nil) and not VarIsNullEmpty(VarData));\r\n if Data^ <> 0 then\r\n begin\r\n Inc(Data);\r\n PVariant(Data)^ := VarData;\r\n end\r\n else\r\n FillChar(Data^, CalcFieldLen(Field.DataType, Field.Size), 0);\r\n end\r\n else\r\n begin\r\n Data^ := Ord(Buffer <> nil);\r\n Inc(Data);\r\n if Buffer <> nil then\r\n Move({$IFDEF RTL240_UP}PByte(@Buffer[0]){$ELSE}Buffer{$ENDIF RTL240_UP}^, Data^, CalcFieldLen(Field.DataType, Field.Size))\r\n else\r\n FillChar(Data^, CalcFieldLen(Field.DataType, Field.Size), 0);\r\n end;\r\n end;\r\n end;\r\n end\r\n else {fkCalculated, fkLookup}\r\n begin\r\n Inc(RecBuf, FRecordSize + Field.Offset);\r\n Byte(RecBuf[0]) := Ord(Buffer <> nil);\r\n if Byte(RecBuf[0]) <> 0 then\r\n Move({$IFDEF RTL240_UP}PByte(@Buffer[0]){$ELSE}Buffer{$ENDIF RTL240_UP}^, RecBuf[1], Field.DataSize);\r\n end;\r\n if not (State in [dsCalcFields, dsFilter, dsNewValue]) then\r\n DataEvent(deFieldChange, NativeInt(Field));\r\nend;\r\n\r\nprocedure TJvMemoryData.SetFiltered(Value: Boolean);\r\nbegin\r\n if Active then\r\n begin\r\n CheckBrowseMode;\r\n if Filtered <> Value then\r\n inherited SetFiltered(Value);\r\n First;\r\n end\r\n else\r\n inherited SetFiltered(Value);\r\nend;\r\n\r\nprocedure TJvMemoryData.SetOnFilterRecord(const Value: TFilterRecordEvent);\r\nbegin\r\n if Active then\r\n begin\r\n CheckBrowseMode;\r\n inherited SetOnFilterRecord(Value);\r\n if Filtered then\r\n First;\r\n end\r\n else\r\n inherited SetOnFilterRecord(Value);\r\nend;\r\n\r\nfunction TJvMemoryData.RecordFilter: Boolean;\r\nvar\r\n SaveState: TDataSetState;\r\nbegin\r\n Result := True;\r\n if Assigned(OnFilterRecord) or (FFilterParser <> nil) or (FFilterExpression <> nil) then\r\n begin\r\n if (FRecordPos >= 0) and (FRecordPos < RecordCount) then\r\n begin\r\n SaveState := SetTempState(dsFilter);\r\n try\r\n RecordToBuffer(Records[FRecordPos], TempBuffer);\r\n if (FFilterParser <> nil) and FFilterParser.Eval() then\r\n begin\r\n FFilterParser.EnableWildcardMatching := not (foNoPartialCompare in FilterOptions);\r\n FFilterParser.CaseInsensitive := foCaseInsensitive in FilterOptions;\r\n Result := FFilterParser.Value;\r\n end\r\n else\r\n if FFilterExpression <> nil then\r\n Result := FFilterExpression.Evaluate();\r\n\r\n if Assigned(OnFilterRecord) then\r\n OnFilterRecord(Self, Result);\r\n except\r\n AppHandleException(Self);\r\n end;\r\n RestoreState(SaveState);\r\n end\r\n else\r\n Result := False;\r\n end;\r\nend;\r\n\r\nfunction TJvMemoryData.GetBlobData(Field: TField; Buffer: PJvMemBuffer): TMemBlobData;\r\nbegin\r\n Result := PMemBlobArray(Buffer + FBlobOfs)[Field.Offset];\r\nend;\r\n\r\nprocedure TJvMemoryData.SetBlobData(Field: TField; Buffer: PJvMemBuffer; Value: TMemBlobData);\r\nbegin\r\n if Buffer = ActiveBuffer then\r\n begin\r\n if State = dsFilter then\r\n Error(SNotEditing);\r\n PMemBlobArray(Buffer + FBlobOfs)[Field.Offset] := Value;\r\n end;\r\nend;\r\n\r\nprocedure TJvMemoryData.CloseBlob(Field: TField);\r\nbegin\r\n if (FRecordPos >= 0) and (FRecordPos < FRecords.Count) and (State = dsEdit) then\r\n PMemBlobArray(ActiveBuffer + FBlobOfs)[Field.Offset] :=\r\n PMemBlobArray(Records[FRecordPos].FBlobs)[Field.Offset]\r\n else\r\n PMemBlobArray(ActiveBuffer + FBlobOfs)[Field.Offset] := '';\r\nend;\r\n\r\nfunction TJvMemoryData.CreateBlobStream(Field: TField; Mode: TBlobStreamMode): TStream;\r\nbegin\r\n Result := TJvMemBlobStream.Create(Field as TBlobField, Mode);\r\nend;\r\n\r\nfunction TJvMemoryData.BookmarkValid(Bookmark: TBookmark): Boolean;\r\nbegin\r\n Result := (Bookmark <> nil) and FActive and\r\n (TBookmarkData({$IFDEF RTL200_UP}Pointer(@Bookmark[0]){$ELSE}Bookmark{$ENDIF RTL200_UP}^) > Low(Integer)) and\r\n (TBookmarkData({$IFDEF RTL200_UP}Pointer(@Bookmark[0]){$ELSE}Bookmark{$ENDIF RTL200_UP}^) <= FLastID);\r\nend;\r\n\r\nfunction TJvMemoryData.CompareBookmarks(Bookmark1, Bookmark2: TBookmark): Integer;\r\nbegin\r\n if (Bookmark1 = nil) and (Bookmark2 = nil) then\r\n Result := 0\r\n else\r\n if (Bookmark1 <> nil) and (Bookmark2 = nil) then\r\n Result := 1\r\n else\r\n if (Bookmark1 = nil) and (Bookmark2 <> nil) then\r\n Result := -1\r\n else\r\n if TBookmarkData({$IFDEF RTL200_UP}Pointer(@Bookmark1[0]){$ELSE}Bookmark1{$ENDIF RTL200_UP}^) >\r\n TBookmarkData({$IFDEF RTL200_UP}Pointer(@Bookmark2[0]){$ELSE}Bookmark2{$ENDIF RTL200_UP}^) then\r\n Result := 1\r\n else\r\n if TBookmarkData({$IFDEF RTL200_UP}Pointer(@Bookmark1[0]){$ELSE}Bookmark1{$ENDIF RTL200_UP}^) <\r\n TBookmarkData({$IFDEF RTL200_UP}Pointer(@Bookmark2[0]){$ELSE}Bookmark2{$ENDIF RTL200_UP}^) then\r\n Result := -1\r\n else\r\n Result := 0;\r\nend;\r\n\r\nprocedure TJvMemoryData.GetBookmarkData(Buffer: PJvMemBuffer; Data: TJvBookmark);\r\nbegin\r\n Move(PMemBookmarkInfo(Buffer + FBookmarkOfs)^.BookmarkData, {$IFDEF RTL240_UP}PByte(@Data[0]){$ELSE}Data{$ENDIF RTL240_UP}^, SizeOf(TBookmarkData));\r\nend;\r\n\r\nprocedure TJvMemoryData.SetBookmarkData(Buffer: PJvMemBuffer; Data: TJvBookmark);\r\nbegin\r\n Move({$IFDEF RTL240_UP}PByte(@Data[0]){$ELSE}Data{$ENDIF RTL240_UP}^, PMemBookmarkInfo(Buffer + FBookmarkOfs)^.BookmarkData, SizeOf(TBookmarkData));\r\nend;\r\n\r\nfunction TJvMemoryData.GetBookmarkFlag(Buffer: PJvMemBuffer): TBookmarkFlag;\r\nbegin\r\n Result := PMemBookmarkInfo(Buffer + FBookmarkOfs)^.BookmarkFlag;\r\nend;\r\n\r\nprocedure TJvMemoryData.SetBookmarkFlag(Buffer: PJvMemBuffer; Value: TBookmarkFlag);\r\nbegin\r\n PMemBookmarkInfo(Buffer + FBookmarkOfs)^.BookmarkFlag := Value;\r\nend;\r\n\r\nprocedure TJvMemoryData.InternalGotoBookmark(Bookmark: TJvBookmark);\r\nvar\r\n Rec: TJvMemoryRecord;\r\n SavePos: Integer;\r\n Accept: Boolean;\r\nbegin\r\n Rec := FindRecordID(TBookmarkData({$IFDEF RTL240_UP}PByte(@Bookmark[0]){$ELSE}Bookmark{$ENDIF RTL240_UP}^));\r\n if Rec <> nil then\r\n begin\r\n Accept := True;\r\n SavePos := FRecordPos;\r\n try\r\n FRecordPos := Rec.Index;\r\n if Filtered then\r\n Accept := RecordFilter;\r\n finally\r\n if not Accept then\r\n FRecordPos := SavePos;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvMemoryData.InternalSetToRecord(Buffer: PJvMemBuffer);\r\nbegin\r\n InternalGotoBookmark(@PMemBookmarkInfo(Buffer + FBookmarkOfs)^.BookmarkData);\r\nend;\r\n\r\nprocedure TJvMemoryData.InternalFirst;\r\nbegin\r\n FRecordPos := -1;\r\nend;\r\n\r\nprocedure TJvMemoryData.InternalLast;\r\nbegin\r\n FRecordPos := FRecords.Count;\r\nend;\r\n\r\n{$IFNDEF COMPILER10_UP} // Delphi 2006+ has support for WideString\r\nprocedure TJvMemoryData.DataConvert(Field: TField; Source, Dest: Pointer; ToNative: Boolean);\r\nbegin\r\n if Field.DataType = ftWideString then\r\n begin\r\n if ToNative then\r\n begin\r\n Word(Dest^) := Length(PWideString(Source)^) * SizeOf(WideChar);\r\n Move(PWideChar(Source^)^, (PWideChar(Dest) + 1)^, Word(Dest^));\r\n end\r\n else\r\n SetString(WideString(Dest^), PWideChar(PWideChar(Source) + 1), Word(Source^) div SizeOf(WideChar));\r\n end\r\n else\r\n inherited DataConvert(Field, Source, Dest, ToNative);\r\nend;\r\n{$ENDIF ~COMPILER10_UP}\r\n\r\nprocedure TJvMemoryData.AssignMemoryRecord(Rec: TJvMemoryRecord; Buffer: PJvMemBuffer);\r\nvar\r\n I: Integer;\r\nbegin\r\n Move(Buffer^, Rec.Data^, FRecordSize);\r\n for I := 0 to BlobFieldCount - 1 do\r\n PMemBlobArray(Rec.FBlobs)[I] := PMemBlobArray(Buffer + FBlobOfs)[I];\r\nend;\r\n\r\nprocedure TJvMemoryData.SetMemoryRecordData(Buffer: PJvMemBuffer; Pos: Integer);\r\nvar\r\n Rec: TJvMemoryRecord;\r\nbegin\r\n if State = dsFilter then\r\n Error(SNotEditing);\r\n Rec := Records[Pos];\r\n AssignMemoryRecord(Rec, Buffer);\r\nend;\r\n\r\nprocedure TJvMemoryData.SetAutoIncFields(Buffer: PJvMemBuffer);\r\nvar\r\n I, Count: Integer;\r\n Data: PByte;\r\nbegin\r\n Count := 0;\r\n for I := 0 to FieldCount - 1 do\r\n if (Fields[I].FieldKind in fkStoredFields) and\r\n (Fields[I].DataType = ftAutoInc) then\r\n begin\r\n Data := FindFieldData(Buffer, Fields[I]);\r\n if Data <> nil then\r\n begin\r\n Data^ := Ord(True);\r\n Inc(Data);\r\n Move(FAutoInc, Data^, SizeOf(Longint));\r\n Inc(Count);\r\n end;\r\n end;\r\n if Count > 0 then\r\n Inc(FAutoInc);\r\nend;\r\n\r\nprocedure TJvMemoryData.InternalAddRecord(Buffer: TJvRecordBuffer; Append: Boolean);\r\nvar\r\n RecPos: Integer;\r\n Rec: TJvMemoryRecord;\r\nbegin\r\n if Append then\r\n begin\r\n Rec := AddRecord;\r\n FRecordPos := FRecords.Count - 1;\r\n end\r\n else\r\n begin\r\n if FRecordPos = -1 then\r\n RecPos := 0\r\n else\r\n RecPos := FRecordPos;\r\n Rec := InsertRecord(RecPos);\r\n FRecordPos := RecPos;\r\n end;\r\n SetAutoIncFields(Buffer);\r\n SetMemoryRecordData(Buffer, Rec.Index);\r\nend;\r\n\r\nprocedure TJvMemoryData.InternalDelete;\r\nvar\r\n Accept: Boolean;\r\n Status: TRecordStatus;\r\n PFValues: TPVariant;\r\nbegin\r\n Status := rsOriginal; // Disable warnings\r\n PFValues := nil;\r\n if FApplyMode <> amNone then\r\n begin\r\n Status := TRecordStatus(FieldByName(FStatusName).AsInteger);\r\n if Status <> rsInserted then\r\n begin\r\n if FApplyMode = amAppend then\r\n begin\r\n Cancel;\r\n Exit;\r\n end\r\n else\r\n begin\r\n New(PFValues);\r\n PFValues^ := GetValues;\r\n end;\r\n end;\r\n end;\r\n\r\n Records[FRecordPos].Free;\r\n if FRecordPos >= FRecords.Count then\r\n Dec(FRecordPos);\r\n Accept := True;\r\n repeat\r\n if Filtered then\r\n Accept := RecordFilter;\r\n if not Accept then\r\n Dec(FRecordPos);\r\n until Accept or (FRecordPos < 0);\r\n if FRecords.Count = 0 then\r\n FLastID := Low(Integer);\r\n\r\n if FApplyMode <> amNone then\r\n begin\r\n if Status = rsInserted then\r\n Dec(FRowsChanged)\r\n else\r\n FDeletedValues.Add(PFValues);\r\n if Status = rsOriginal then\r\n Inc(FRowsChanged);\r\n end;\r\nend;\r\n\r\nprocedure TJvMemoryData.InternalPost;\r\nvar\r\n RecPos: Integer;\r\n Index: Integer;\r\n Status: TRecordStatus;\r\n NewChange: Boolean;\r\nbegin\r\n inherited InternalPost;\r\n\r\n NewChange := False;\r\n if (FApplyMode <> amNone) and not IsLoading then\r\n begin\r\n Status := TRecordStatus(FieldByName(FStatusName).AsInteger);\r\n (* if (State = dsEdit) and (Status In [rsInserted,rsUpdated]) then NewChange := False; *)\r\n if (State = dsEdit) and (Status = rsOriginal) then\r\n begin\r\n if FApplyMode = amAppend then\r\n begin\r\n Cancel;\r\n Exit;\r\n end\r\n else\r\n begin\r\n NewChange := True;\r\n FieldByName(FStatusName).AsInteger := Integer(rsUpdated);\r\n end;\r\n end;\r\n if State = dsInsert then\r\n begin\r\n if IsDeleted(Index) then\r\n begin\r\n FDeletedValues[Index] := nil;\r\n FDeletedValues.Delete(Index);\r\n if FApplyMode = amAppend then\r\n FieldByName(FStatusName).AsInteger := Integer(rsInserted)\r\n else\r\n FieldByName(FStatusName).AsInteger := Integer(rsUpdated);\r\n end\r\n else\r\n begin\r\n NewChange := True;\r\n FieldByName(FStatusName).AsInteger := Integer(rsInserted);\r\n end;\r\n end;\r\n end;\r\n\r\n if State = dsEdit then\r\n SetMemoryRecordData(ActiveBuffer, FRecordPos)\r\n else\r\n begin\r\n if State in [dsInsert] then\r\n SetAutoIncFields(ActiveBuffer);\r\n if FRecordPos >= FRecords.Count then\r\n begin\r\n SetMemoryRecordData(ActiveBuffer, AddRecord.Index);\r\n FRecordPos := FRecords.Count - 1;\r\n end\r\n else\r\n begin\r\n if FRecordPos = -1 then\r\n RecPos := 0\r\n else\r\n RecPos := FRecordPos;\r\n SetMemoryRecordData(ActiveBuffer, InsertRecord(RecPos).Index);\r\n FRecordPos := RecPos;\r\n end;\r\n end;\r\n\r\n if NewChange then\r\n Inc(FRowsChanged);\r\nend;\r\n\r\nprocedure TJvMemoryData.OpenCursor(InfoQuery: Boolean);\r\nbegin\r\n try\r\n if FDataSet <> nil then\r\n begin\r\n if FLoadStructure then\r\n CopyStructure(FDataSet, FAutoIncAsInteger)\r\n else\r\n if FApplyMode <> amNone then\r\n begin\r\n AddStatusField;\r\n HideStatusField;\r\n end;\r\n end;\r\n except\r\n SysUtils.Abort;\r\n Exit;\r\n end;\r\n\r\n if not InfoQuery then\r\n begin\r\n if FieldCount > 0 then\r\n FieldDefs.Clear;\r\n InitFieldDefsFromFields;\r\n end;\r\n FActive := True;\r\n inherited OpenCursor(InfoQuery);\r\nend;\r\n\r\nprocedure TJvMemoryData.InternalOpen;\r\nbegin\r\n BookmarkSize := SizeOf(TBookmarkData);\r\n if DefaultFields then\r\n CreateFields;\r\n BindFields(True);\r\n InitBufferPointers(True);\r\n InternalFirst;\r\nend;\r\n\r\nprocedure TJvMemoryData.DoAfterOpen;\r\nbegin\r\n if (FDataSet <> nil) and FLoadRecords then\r\n begin\r\n if not FDataSet.Active then\r\n FDataSet.Open;\r\n FRowsOriginal := CopyFromDataset;\r\n if FRowsOriginal > 0 then\r\n begin\r\n SortOnFields();\r\n if FApplyMode = amAppend then\r\n Last\r\n else\r\n First;\r\n end;\r\n if FDataset.Active and FDatasetClosed then\r\n FDataset.Close;\r\n end\r\n else\r\n if not IsEmpty then\r\n SortOnFields();\r\n inherited DoAfterOpen;\r\nEnd;\r\n\r\n// Filtering contribution June 2009 - C.Schiffler - MANTIS # 0004328\r\n// Uses expression parser.\r\nprocedure TJvMemoryData.SetFilterText(const Value: string);\r\n\r\n procedure UpdateFilter;\r\n begin\r\n FreeAndNil(FFilterParser);\r\n FreeAndNil(FFilterExpression);\r\n if Filter <> '' then\r\n begin\r\n if UseDataSetFilter then\r\n FFilterExpression := TJvDBFilterExpression.Create(Self, Value, FilterOptions)\r\n else\r\n begin\r\n FFilterParser := TExprParser.Create;\r\n FFilterParser.OnGetVariable := ParserGetVariableValue;\r\n if foCaseInsensitive in FilterOptions then\r\n FFilterParser.Expression := AnsiUpperCase(Filter)\r\n else\r\n FFilterParser.Expression := Filter;\r\n end;\r\n end;\r\n end;\r\n\r\nbegin\r\n if Active then\r\n begin\r\n CheckBrowseMode;\r\n inherited SetFilterText(Value);\r\n UpdateFilter;\r\n if Filtered then\r\n First;\r\n end\r\n else\r\n begin\r\n inherited SetFilterText(Value);\r\n UpdateFilter;\r\n end;\r\nend;\r\n\r\nfunction TJvMemoryData.ParserGetVariableValue(Sender: TObject; const VarName: string; var Value: Variant): Boolean;\r\nvar\r\n Field: TField;\r\nbegin\r\n Field := FieldByName(Varname);\r\n if Assigned(Field) then\r\n begin\r\n Value := Field.Value;\r\n Result := True;\r\n end\r\n else\r\n Result := False;\r\nend;\r\n\r\nprocedure TJvMemoryData.InternalClose;\r\nbegin\r\n ClearRecords;\r\n FAutoInc := 1;\r\n BindFields(False);\r\n if DefaultFields then\r\n DestroyFields;\r\n FreeIndexList;\r\n FActive := False;\r\nend;\r\n\r\nprocedure TJvMemoryData.InternalHandleException;\r\nbegin\r\n AppHandleException(Self);\r\nend;\r\n\r\nprocedure TJvMemoryData.InternalInitFieldDefs;\r\nbegin\r\n // InitFieldDefsFromFields\r\nend;\r\n\r\nfunction TJvMemoryData.IsCursorOpen: Boolean;\r\nbegin\r\n Result := FActive;\r\nend;\r\n\r\nfunction TJvMemoryData.GetRecordCount: Integer;\r\nbegin\r\n Result := FRecords.Count;\r\nend;\r\n\r\nfunction TJvMemoryData.GetRecNo: Integer;\r\nbegin\r\n CheckActive;\r\n UpdateCursorPos;\r\n if (FRecordPos = -1) and (RecordCount > 0) then\r\n Result := 1\r\n else\r\n Result := FRecordPos + 1;\r\nend;\r\n\r\nprocedure TJvMemoryData.SetRecNo(Value: Integer);\r\nbegin\r\n if (Value > 0) and (Value <= FRecords.Count) then\r\n begin\r\n DoBeforeScroll;\r\n FRecordPos := Value - 1;\r\n Resync([]);\r\n DoAfterScroll;\r\n end;\r\nend;\r\n\r\nprocedure TJvMemoryData.SetUseDataSetFilter(const Value: Boolean);\r\nbegin\r\n if Value <> FUseDataSetFilter then\r\n begin\r\n FUseDataSetFilter := Value;\r\n SetFilterText(Filter); // update the filter engine\r\n end;\r\nend;\r\n\r\nfunction TJvMemoryData.IsSequenced: Boolean;\r\nbegin\r\n Result := not Filtered;\r\nend;\r\n\r\nfunction TJvMemoryData.Locate(const KeyFields: string; const KeyValues: Variant;\r\n Options: TLocateOptions): Boolean;\r\nbegin\r\n DoBeforeScroll;\r\n Result := DataSetLocateThrough(Self, KeyFields, KeyValues, Options);\r\n if Result then\r\n begin\r\n DataEvent(deDataSetChange, 0);\r\n DoAfterScroll;\r\n end;\r\nend;\r\n\r\nfunction TJvMemoryData.Lookup(const KeyFields: string; const KeyValues: Variant;\r\n const ResultFields: string): Variant;\r\nvar\r\n FieldCount: Integer;\r\n Fields: TList{$IFDEF RTL240_UP}{$ENDIF RTL240_UP};\r\n Fld: TField; //else BAD mem leak on 'Field.asString'\r\n SaveState: TDataSetState;\r\n I: Integer;\r\n Matched: Boolean;\r\n\r\n function CompareField(var Field: TField; Value: Variant): Boolean; {BG}\r\n var\r\n S: string;\r\n begin\r\n if Field.DataType = ftString then\r\n begin\r\n if Value = Null then\r\n Result := Field.IsNull\r\n else\r\n begin\r\n S := Field.AsString;\r\n Result := AnsiSameStr(S, Value);\r\n end;\r\n end\r\n else\r\n Result := (Field.Value = Value);\r\n end;\r\n\r\n function CompareRecord: Boolean;\r\n var\r\n I: Integer;\r\n begin\r\n if FieldCount = 1 then\r\n begin\r\n Fld := TField(Fields.First);\r\n Result := CompareField(Fld, KeyValues);\r\n end\r\n else\r\n begin\r\n Result := True;\r\n for I := 0 to FieldCount - 1 do\r\n begin\r\n Fld := TField(Fields[I]);\r\n Result := Result and CompareField(Fld, KeyValues[I]);\r\n end;\r\n end;\r\n end;\r\n\r\nbegin\r\n Result := Null;\r\n CheckBrowseMode;\r\n if IsEmpty then\r\n Exit;\r\n\r\n Fields := TList{$IFDEF RTL240_UP}{$ENDIF RTL240_UP}.Create;\r\n try\r\n GetFieldList(Fields, KeyFields);\r\n FieldCount := Fields.Count;\r\n Matched := CompareRecord;\r\n if Matched then\r\n Result := FieldValues[ResultFields]\r\n else\r\n begin\r\n SaveState := SetTempState(dsCalcFields);\r\n try\r\n try\r\n for I := 0 to RecordCount - 1 do\r\n begin\r\n RecordToBuffer(Records[I], TempBuffer);\r\n CalculateFields(TempBuffer);\r\n Matched := CompareRecord;\r\n if Matched then\r\n Break;\r\n end;\r\n finally\r\n if Matched then\r\n Result := FieldValues[ResultFields];\r\n end;\r\n finally\r\n RestoreState(SaveState);\r\n end;\r\n end;\r\n finally\r\n Fields.Free;\r\n end;\r\nend;\r\n\r\nprocedure TJvMemoryData.Notification(AComponent: TComponent; Operation: TOperation);\r\nbegin\r\n inherited Notification(AComponent, Operation);\r\n if (Operation = opRemove) and (AComponent = DataSet) then\r\n SetDataSet(nil);\r\nend;\r\n\r\nprocedure TJvMemoryData.EmptyTable;\r\nbegin\r\n if Active then\r\n begin\r\n CheckBrowseMode;\r\n ClearRecords;\r\n ClearBuffers;\r\n DataEvent(deDataSetChange, 0);\r\n end;\r\nend;\r\n\r\nprocedure TJvMemoryData.AddStatusField;\r\nbegin\r\n // Check if FieldStatus not exists in FieldDefs\r\n if (FieldDefs.Count > 0) and not (FieldDefs[FieldDefs.Count - 1].Name =\r\n FStatusName) then\r\n FieldDefs.Add(FStatusName, ftSmallint);\r\nend;\r\n\r\nprocedure TJvMemoryData.HideStatusField;\r\nbegin\r\n // Check if FieldStatus already exists in FieldDefs\r\n if (FieldDefs.Count > 0) and (FieldDefs[FieldDefs.Count - 1].Name = FStatusName) then\r\n begin\r\n FieldDefs[FieldDefs.Count - 1].Attributes := [faHiddenCol]; // Hide in FieldDefs\r\n // Check if FieldStatus not exists in Fields\r\n if not (Fields[Fields.Count - 1].FieldName = FStatusName) then\r\n FieldDefs[FieldDefs.Count - 1].CreateField(Self);\r\n Fields[Fields.Count - 1].Visible := False; // Hide in Fields\r\n end;\r\nend;\r\n\r\nprocedure TJvMemoryData.CheckStructure(UseAutoIncAsInteger: Boolean);\r\n\r\n procedure CheckDataTypes(FieldDefs: TFieldDefs);\r\n var\r\n J: Integer;\r\n begin\r\n for J := FieldDefs.Count - 1 downto 0 do\r\n begin\r\n if (FieldDefs.Items[J].DataType = ftAutoInc) and UseAutoIncAsInteger then\r\n FieldDefs.Items[J].DataType := ftInteger;\r\n if not (FieldDefs.Items[J].DataType in ftSupported) then\r\n FieldDefs.Items[J].Free;\r\n end;\r\n end;\r\n\r\nvar\r\n I: Integer;\r\nbegin\r\n CheckDataTypes(FieldDefs);\r\n for I := 0 to FieldDefs.Count - 1 do\r\n if (csDesigning in ComponentState) and (Owner <> nil) then\r\n FieldDefs.Items[I].CreateField(Owner)\r\n else\r\n FieldDefs.Items[I].CreateField(Self);\r\nend;\r\n\r\nprocedure TJvMemoryData.SetDataSet(ADataSet: TDataSet);\r\nbegin\r\n if ADataSet <> Self then\r\n ReplaceComponentReference(Self, ADataSet, TComponent(FDataSet));\r\nend;\r\n\r\nprocedure TJvMemoryData.FixReadOnlyFields(MakeReadOnly: Boolean);\r\nvar\r\n I: Integer;\r\nbegin\r\n if MakeReadOnly then\r\n for I := 0 to FieldCount - 1 do\r\n Fields[I].ReadOnly := (Fields[I].Tag = 1)\r\n else\r\n for I := 0 to FieldCount - 1 do\r\n begin\r\n Fields[I].Tag := Ord(Fields[I].ReadOnly);\r\n Fields[I].ReadOnly := False;\r\n if Fields[I].DataType = ftAutoInc then\r\n FAutoIncField := Fields[I];\r\n end;\r\nend;\r\n\r\nprocedure TJvMemoryData.CopyStructure(Source: TDataSet; UseAutoIncAsInteger: Boolean);\r\nvar\r\n I: Integer;\r\nbegin\r\n if Source = nil then\r\n Exit;\r\n CheckInactive;\r\n for I := FieldCount - 1 downto 0 do\r\n Fields[I].Free;\r\n\r\n Source.FieldDefs.Update;\r\n FieldDefs := Source.FieldDefs;\r\n if FApplyMode <> amNone then\r\n AddStatusField;\r\n CheckStructure(UseAutoIncAsInteger);\r\n if FApplyMode <> amNone then\r\n HideStatusField;\r\nend;\r\n\r\nfunction TJvMemoryData.LoadFromDataSet(Source: TDataSet; RecordCount: Integer;\r\n Mode: TLoadMode; DisableAllControls: Boolean = True): Integer;\r\nvar\r\n MovedCount, I: Integer;\r\n SB, DB: TBookmark;\r\nbegin\r\n Result := 0;\r\n if Source = Self then\r\n Exit;\r\n FSaveLoadState := slsLoading;\r\n //********** Source *********\r\n if DisableAllControls then\r\n Source.DisableControls;\r\n if not Source.Active then\r\n Source.Open\r\n else\r\n Source.CheckBrowseMode;\r\n Source.UpdateCursorPos;\r\n SB := Source.GetBookmark;\r\n //*************************** \r\n try\r\n //********** Dest (self) ***********\r\n if DisableAllControls then\r\n DisableControls;\r\n Filtered := False;\r\n if Mode = lmCopy then\r\n begin\r\n Close;\r\n CopyStructure(Source, FAutoIncAsInteger);\r\n end;\r\n FreeIndexList;\r\n if not Active then\r\n Open\r\n else\r\n CheckBrowseMode;\r\n DB := GetBookmark;\r\n //**********************************\r\n try\r\n if RecordCount > 0 then\r\n MovedCount := RecordCount\r\n else\r\n begin\r\n Source.First;\r\n MovedCount := MaxInt;\r\n end;\r\n FAutoIncField := nil;\r\n // FixReadOnlyFields also sets FAutoIncField if there is any\r\n FixReadOnlyFields(False);\r\n // find first source autoinc field\r\n FSrcAutoIncField := nil;\r\n if Mode = lmCopy then\r\n for I := 0 to Source.FieldCount - 1 do\r\n if Source.Fields[I].DataType = ftAutoInc then\r\n begin\r\n FSrcAutoIncField := Source.Fields[I];\r\n Break;\r\n end;\r\n try\r\n while not Source.EOF do\r\n begin\r\n Append;\r\n AssignRecord(Source, Self, True);\r\n // assign AutoInc value manually (make user keep largest if source isn't sorted by autoinc field)\r\n if (FAutoIncField <> nil) and (FSrcAutoIncField <> nil) then\r\n FAutoInc := Max(FAutoInc, FSrcAutoIncField.AsInteger);\r\n if (Mode = lmCopy) and (FApplyMode <> amNone) then\r\n FieldByName(FStatusName).AsInteger := Integer(rsOriginal);\r\n Post;\r\n Inc(Result);\r\n if Result >= MovedCount then\r\n Break;\r\n Source.Next;\r\n end;\r\n finally\r\n if (Mode = lmCopy) and (FApplyMode <> amNone) then\r\n begin\r\n FRowsOriginal := Result;\r\n FRowsChanged := 0;\r\n FRowsAffected := 0;\r\n end;\r\n FixReadOnlyFields(True);\r\n FAutoIncField := nil;\r\n FSrcAutoIncField := nil;\r\n First;\r\n end;\r\n finally\r\n //********** Dest (self) ***********\r\n // move back to where we started from\r\n if (DB <> nil) and BookmarkValid(DB) then\r\n begin\r\n GotoBookmark(DB);\r\n FreeBookmark(DB);\r\n end;\r\n if DisableAllControls then\r\n EnableControls;\r\n //**********************************\r\n end;\r\n finally\r\n //************** Source **************\r\n // move back to where we started from\r\n if (SB <> nil) and Source.BookmarkValid(SB) and not Source.IsEmpty then\r\n begin\r\n Source.GotoBookmark(SB);\r\n Source.FreeBookmark(SB);\r\n end;\r\n if Source.Active and FDatasetClosed then\r\n Source.Close;\r\n if DisableAllControls then\r\n Source.EnableControls;\r\n //************************************\r\n FSaveLoadState := slsNone;\r\n end;\r\nend;\r\n\r\nfunction TJvMemoryData.SaveToDataSet(Dest: TDataSet; RecordCount: Integer;\r\n DisableAllControls: Boolean = True): Integer;\r\nvar\r\n MovedCount: Integer;\r\n SB, DB: TBookmark;\r\n Status: TRecordStatus;\r\nbegin\r\n Result := 0;\r\n FRowsAffected := Result;\r\n if Dest = Self then\r\n Exit;\r\n FSaveLoadState := slsSaving;\r\n //*********** Dest ************\r\n if DisableAllControls then\r\n Dest.DisableControls;\r\n if not Dest.Active then\r\n Dest.Open\r\n else\r\n Dest.CheckBrowseMode;\r\n Dest.UpdateCursorPos;\r\n DB := Dest.GetBookmark;\r\n SB := nil;\r\n //*****************************\r\n try\r\n //*********** Source (self) ************\r\n if DisableAllControls then\r\n DisableControls;\r\n CheckBrowseMode;\r\n if FApplyMode <> amNone then\r\n begin\r\n FRowsChanged := Self.RecordCount;\r\n DoBeforeApply(Dest, FRowsChanged);\r\n end\r\n else\r\n begin\r\n SB := GetBookmark;\r\n end;\r\n //**************************************\r\n try\r\n if RecordCount > 0 then\r\n MovedCount := RecordCount\r\n else\r\n begin\r\n First;\r\n MovedCount := MaxInt;\r\n end;\r\n Status := rsOriginal; // Disable warnings\r\n try\r\n while not EOF do\r\n begin\r\n if FApplyMode <> amNone then\r\n begin\r\n Status := TRecordStatus(FieldByName(FStatusName).AsInteger);\r\n DoBeforeApplyRecord(Dest, Status, True);\r\n end;\r\n Dest.Append;\r\n AssignRecord(Self, Dest, True);\r\n Dest.Post;\r\n Inc(Result);\r\n if FApplyMode <> amNone then\r\n DoAfterApplyRecord(Dest, Status, True);\r\n if Result >= MovedCount then\r\n Break;\r\n Next;\r\n end;\r\n finally\r\n if FApplyMode <> amNone then\r\n begin\r\n FRowsAffected := Result;\r\n DoAfterApply(Dest, FRowsAffected);\r\n if Result > 0 then\r\n ClearChanges;\r\n FRowsAffected := 0;\r\n FRowsChanged := 0;\r\n end\r\n end;\r\n finally\r\n //*********** Source (self) ************\r\n if (FApplyMode = amNone) and (SB <> nil) and BookmarkValid(SB) then\r\n begin\r\n GotoBookmark(SB);\r\n FreeBookmark(SB);\r\n end;\r\n if DisableAllControls then\r\n EnableControls;\r\n //**************************************\r\n end;\r\n finally\r\n //******************* Dest *******************\r\n // move back to where we started from\r\n if (DB <> nil) and Dest.BookmarkValid(DB) and not Dest.IsEmpty then\r\n begin\r\n Dest.GotoBookmark(DB);\r\n Dest.FreeBookmark(DB);\r\n end;\r\n if Dest.Active and FDatasetClosed then\r\n Dest.Close;\r\n if DisableAllControls then\r\n Dest.EnableControls;\r\n //********************************************\r\n FSaveLoadState := slsNone;\r\n end;\r\nend;\r\n\r\nprocedure TJvMemoryData.SortOnFields(const FieldNames: string = '';\r\n CaseInsensitive: Boolean = True; Descending: Boolean = False);\r\nbegin\r\n // Post the table before sorting\r\n if State in dsEditModes then\r\n Post;\r\n\r\n if FieldNames <> '' then\r\n CreateIndexList(FieldNames)\r\n else\r\n if FKeyFieldNames <> '' then\r\n CreateIndexList(FKeyFieldNames)\r\n else\r\n Exit;\r\n FCaseInsensitiveSort := CaseInsensitive;\r\n FDescendingSort := Descending;\r\n try\r\n Sort;\r\n except\r\n FreeIndexList;\r\n raise;\r\n end;\r\nend;\r\n\r\nprocedure TJvMemoryData.SwapRecords(Idx1, Idx2: integer);\r\nbegin\r\n FRecords.Exchange(Idx1, Idx2);\r\nend;\r\n\r\n\r\nprocedure TJvMemoryData.Sort;\r\nvar\r\n Pos: {$IFDEF COMPILER12_UP}DB.TBookmark{$ELSE}TBookmarkStr{$ENDIF COMPILER12_UP};\r\nbegin\r\n if Active and (FRecords <> nil) and (FRecords.Count > 0) then\r\n begin\r\n Pos := Bookmark;\r\n try\r\n QuickSort(0, FRecords.Count - 1, CompareRecords);\r\n SetBufListSize(0);\r\n InitBufferPointers(False);\r\n try\r\n SetBufListSize(BufferCount + 1);\r\n except\r\n SetState(dsInactive);\r\n CloseCursor;\r\n raise;\r\n end;\r\n finally\r\n Bookmark := Pos;\r\n end;\r\n Resync([]);\r\n end;\r\nend;\r\n\r\nprocedure TJvMemoryData.QuickSort(L, R: Integer; Compare: TCompareRecords);\r\nvar\r\n I, J: Integer;\r\n P: TJvMemoryRecord;\r\nbegin\r\n repeat\r\n I := L;\r\n J := R;\r\n P := Records[(L + R) shr 1];\r\n repeat\r\n while Compare(Records[I], P) < 0 do\r\n Inc(I);\r\n while Compare(Records[J], P) > 0 do\r\n Dec(J);\r\n if I <= J then\r\n begin\r\n FRecords.Exchange(I, J);\r\n Inc(I);\r\n Dec(J);\r\n end;\r\n until I > J;\r\n if L < J then\r\n QuickSort(L, J, Compare);\r\n L := I;\r\n until I >= R;\r\nend;\r\n\r\nfunction TJvMemoryData.CompareRecords(Item1, Item2: TJvMemoryRecord): Integer;\r\nvar\r\n Data1, Data2: PByte;\r\n CData1, CData2, Buffer1, Buffer2: array[0..dsMaxStringSize] of Byte;\r\n F: TField;\r\n I: Integer;\r\nbegin\r\n Result := 0;\r\n if FIndexList <> nil then\r\n begin\r\n for I := 0 to FIndexList.Count - 1 do\r\n begin\r\n F := TField(FIndexList[I]);\r\n if F.FieldKind = fkData then\r\n begin\r\n Data1 := FindFieldData(Item1.Data, F);\r\n if Data1 <> nil then\r\n begin\r\n Data2 := FindFieldData(Item2.Data, F);\r\n if Data2 <> nil then\r\n begin\r\n if Boolean(Data1^) and Boolean(Data2^) then\r\n begin\r\n Inc(Data1);\r\n Inc(Data2);\r\n Result := CompareFields(Data1, Data2, F.DataType, FCaseInsensitiveSort);\r\n end\r\n else if Boolean(Data1^) then\r\n Result := 1\r\n else if Boolean(Data2^) then\r\n Result := -1;\r\n if FDescendingSort then\r\n Result := -Result;\r\n end;\r\n end;\r\n if Result <> 0 then\r\n Exit;\r\n end\r\n else\r\n begin\r\n FillChar(Buffer1, dsMaxStringSize, 0);\r\n FillChar(Buffer2, dsMaxStringSize, 0);\r\n RecordToBuffer(Item1, @Buffer1[0]);\r\n RecordToBuffer(Item2, @Buffer2[0]);\r\n Move(Buffer1[1 + FRecordSize + F.Offset], CData1, F.DataSize);\r\n if CData1[0] <> 0 then\r\n begin\r\n Move(Buffer2[1 + FRecordSize + F.Offset], CData2, F.DataSize);\r\n if CData2[0] <> 0 then\r\n begin\r\n if Boolean(CData1[0]) and Boolean(CData2[0]) then\r\n Result := CompareFields(@CData1, @CData2, F.DataType, FCaseInsensitiveSort)\r\n else if Boolean(CData1[0]) then\r\n Result := 1\r\n else if Boolean(CData2[0]) then\r\n Result := -1;\r\n if FDescendingSort then\r\n Result := -Result;\r\n end;\r\n end;\r\n if Result <> 0 then\r\n Exit;\r\n end;\r\n end;\r\n end;\r\n if Result = 0 then\r\n begin\r\n if Item1.ID > Item2.ID then\r\n Result := 1\r\n else\r\n if Item1.ID < Item2.ID then\r\n Result := -1;\r\n if FDescendingSort then\r\n Result := -Result;\r\n end;\r\nend;\r\n\r\nfunction TJvMemoryData.GetIsIndexField(Field: TField): Boolean;\r\nbegin\r\n if FIndexList <> nil then\r\n Result := FIndexList.IndexOf(Field) >= 0\r\n else\r\n Result := False;\r\nend;\r\n\r\nprocedure TJvMemoryData.CreateIndexList(const FieldNames: WideString);\r\ntype\r\n TFieldTypeSet = set of TFieldType;\r\n\r\n function GetSetFieldNames(const FieldTypeSet: TFieldTypeSet): string;\r\n var\r\n FieldType: TFieldType;\r\n begin\r\n for FieldType := Low(TFieldType) to High(TFieldType) do\r\n if FieldType in FieldTypeSet then\r\n Result := Result + FieldTypeNames[FieldType] + ', ';\r\n Result := Copy(Result, 1, Length(Result) - 2);\r\n end;\r\n\r\nvar\r\n Pos: Integer;\r\n F: TField;\r\nbegin\r\n if FIndexList = nil then\r\n FIndexList := TList.Create\r\n else\r\n FIndexList.Clear;\r\n Pos := 1;\r\n while Pos <= Length(FieldNames) do\r\n begin\r\n F := FieldByName(ExtractFieldNameEx(FieldNames, Pos));\r\n if {(F.FieldKind = fkData) and }(F.DataType in ftSupported - ftBlobTypes) then\r\n FIndexList.Add(F)\r\n else\r\n ErrorFmt(SFieldTypeMismatch, [F.DisplayName, GetSetFieldNames(ftSupported - ftBlobTypes),\r\n FieldTypeNames[F.DataType]]);\r\n end;\r\nend;\r\n\r\nprocedure TJvMemoryData.FreeIndexList;\r\nbegin\r\n if FIndexList <> nil then\r\n begin\r\n FIndexList.Free;\r\n FIndexList := nil;\r\n end;\r\nend;\r\n\r\nfunction TJvMemoryData.GetValues(FldNames: string = ''): Variant;\r\nvar\r\n I: Integer;\r\n List: TList{$IFDEF RTL240_UP}{$ENDIF RTL240_UP};\r\nbegin\r\n Result := Null;\r\n if FldNames = '' then\r\n FldNames := FKeyFieldNames;\r\n if FldNames = '' then\r\n Exit;\r\n\r\n // Mantis 3610: If there is only one field in the dataset, return a\r\n // variant array with only one element. This seems to be required for\r\n // ADO, DBIsam, DBX and others to work.\r\n if Pos(';', FldNames) > 0 then\r\n begin\r\n List := TList{$IFDEF RTL240_UP}{$ENDIF RTL240_UP}.Create;\r\n GetFieldList(List, FldNames);\r\n Result := VarArrayCreate([0, List.Count - 1], varVariant);\r\n for I := 0 to List.Count - 1 do\r\n Result[I] := TField(List[I]).Value;\r\n FreeAndNil(List);\r\n end\r\n else\r\n if FOneValueInArray then\r\n begin\r\n Result := VarArrayCreate([0, 0], VarVariant);\r\n Result[0] := FieldByName(FldNames).Value;\r\n end\r\n else\r\n Result := FieldByName(FldNames).Value;\r\nend;\r\n\r\nfunction TJvMemoryData.CopyFromDataSet: Integer;\r\nvar\r\n I, Len: Integer;\r\n Original, StatusField: TField;\r\n OriginalFields: array of TField;\r\n FieldReadOnly: Boolean;\r\nbegin\r\n Result := 0;\r\n if FDataSet = nil then\r\n Exit;\r\n if FApplyMode <> amNone then\r\n Len := FieldDefs.Count - 1\r\n else\r\n Len := FieldDefs.Count;\r\n if Len < 2 then\r\n Exit;\r\n try\r\n if not FDataSet.Active then\r\n FDataSet.Open;\r\n except\r\n Exit;\r\n end;\r\n if FDataSet.IsEmpty then\r\n begin\r\n if FDataSet.Active and FDatasetClosed then\r\n FDataSet.Close;\r\n Exit;\r\n end;\r\n\r\n FDataSet.DisableControls;\r\n DisableControls;\r\n FSaveLoadState := slsLoading;\r\n try\r\n SetLength(OriginalFields, Fields.Count);\r\n SetLength(FCopyFromDataSetFieldDefs, Fields.Count);\r\n for I := 0 to Fields.Count - 1 do\r\n begin\r\n if Fields[I].FieldKind <> fkCalculated then\r\n begin\r\n OriginalFields[I] := FDataSet.FindField(Fields[I].FieldName);\r\n FCopyFromDataSetFieldDefs[I] := FieldDefList.IndexOf(Fields[I].FullName);\r\n end\r\n else\r\n FCopyFromDataSetFieldDefs[I] := -1;\r\n end;\r\n StatusField := nil;\r\n if FApplyMode <> amNone then\r\n StatusField := FieldByName(FStatusName);\r\n\r\n FAutoIncField := nil;\r\n // find first source autoinc field\r\n FSrcAutoIncField := nil;\r\n for I := 0 to FDataSet.FieldCount - 1 do\r\n if FDataSet.Fields[I].DataType = ftAutoInc then\r\n begin\r\n FSrcAutoIncField := FDataSet.Fields[I];\r\n Break;\r\n end;\r\n if FSrcAutoIncField <> nil then\r\n FAutoIncField := FindField(FSrcAutoIncField.FieldName);\r\n\r\n FDataSet.First;\r\n while not FDataSet.EOF do\r\n begin\r\n Append;\r\n for I := 0 to Fields.Count - 1 do\r\n begin\r\n if Fields[I].FieldKind <> fkCalculated then\r\n begin\r\n Original := OriginalFields[I];\r\n if Original <> nil then\r\n begin\r\n FieldReadOnly := Fields[I].ReadOnly;\r\n if FieldReadOnly then\r\n Fields[I].ReadOnly := False;\r\n try\r\n CopyFieldValue(Fields[I], Original);\r\n finally\r\n if FieldReadOnly then\r\n Fields[I].ReadOnly := True;\r\n end;\r\n end;\r\n end;\r\n end;\r\n // assign AutoInc value manually (make user keep largest if source isn't sorted by autoinc field)\r\n if (FAutoIncField <> nil) and (FSrcAutoIncField <> nil) then\r\n FAutoInc := Max(FAutoInc, FSrcAutoIncField.AsInteger);\r\n if FApplyMode <> amNone then\r\n StatusField.AsInteger := Integer(rsOriginal);\r\n Post;\r\n Inc(Result);\r\n FDataSet.Next;\r\n end;\r\n FRowsChanged := 0;\r\n FRowsAffected := 0;\r\n finally\r\n SetLength(FCopyFromDataSetFieldDefs, 0);\r\n FSaveLoadState := slsNone;\r\n EnableControls;\r\n FDataSet.EnableControls;\r\n if FDataSet.Active and FDatasetClosed then\r\n FDataSet.Close;\r\n end;\r\nend;\r\n\r\nprocedure TJvMemoryData.DoBeforeApply(ADataSet: TDataset; RowsPending: Integer);\r\nbegin\r\n if Assigned(FBeforeApply) then\r\n FBeforeApply(ADataset, RowsPending);\r\nend;\r\n\r\nprocedure TJvMemoryData.DoAfterApply(ADataSet: TDataset; RowsApplied: Integer);\r\nbegin\r\n if Assigned(FAfterApply) then\r\n FAfterApply(ADataset, RowsApplied);\r\nend;\r\n\r\nprocedure TJvMemoryData.DoBeforeApplyRecord(ADataset: TDataset;\r\n RS: TRecordStatus; Found: Boolean);\r\nbegin\r\n if Assigned(FBeforeApplyRecord) then\r\n FBeforeApplyRecord(ADataset, RS, Found);\r\nend;\r\n\r\nprocedure TJvMemoryData.DoAfterApplyRecord(ADataset: TDataset;\r\n RS: TRecordStatus; Apply: Boolean);\r\nbegin\r\n if Assigned(FAfterApplyRecord) then\r\n FAfterApplyRecord(ADataset, RS, Apply);\r\nend;\r\n\r\nprocedure TJvMemoryData.ClearChanges;\r\nvar\r\n I: Integer;\r\n PFValues: TPVariant;\r\nbegin\r\n if FDeletedValues.Count > 0 then\r\n begin\r\n for I := 0 to (FDeletedValues.Count - 1) do\r\n begin\r\n PFValues := FDeletedValues[I];\r\n if PFValues <> nil then\r\n Dispose(PFValues);\r\n FDeletedValues[I] := nil;\r\n end;\r\n FDeletedValues.Clear;\r\n end;\r\n\r\n EmptyTable;\r\n\r\n if FLoadRecords then\r\n begin\r\n FRowsOriginal := CopyFromDataSet;\r\n if FRowsOriginal > 0 then\r\n begin\r\n if FKeyFieldNames <> '' then\r\n SortOnFields();\r\n if FApplyMode = amAppend then\r\n Last\r\n else\r\n First;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvMemoryData.CancelChanges;\r\nbegin\r\n CheckBrowseMode;\r\n ClearChanges;\r\n FRowsChanged := 0;\r\n FRowsAffected := 0;\r\nend;\r\n\r\nfunction TJvMemoryData.ApplyChanges: Boolean;\r\nvar\r\n xKey: Variant;\r\n PxKey: TPVariant;\r\n Len, Row: Integer;\r\n Status: TRecordStatus;\r\n bFound, bApply: Boolean;\r\n FOriginal, FClient: TField;\r\n\r\n function WriteFields: Boolean;\r\n var\r\n J: Integer;\r\n begin\r\n try\r\n for J := 0 to Len do\r\n begin\r\n if (Fields[J].FieldKind = fkData) then\r\n begin\r\n FClient := Fields[J];\r\n FOriginal := FDataSet.FindField(FClient.FieldName);\r\n if (FOriginal <> nil) and (FClient <> nil) then\r\n begin\r\n if FClient.IsNull then\r\n FOriginal.Clear\r\n else\r\n FDataSet.FieldByName(FOriginal.FieldName).Value := FClient.Value;\r\n end;\r\n end;\r\n end;\r\n Result := True;\r\n except\r\n Result := False;\r\n end;\r\n end;\r\n\r\n function InsertRec: Boolean;\r\n begin\r\n try\r\n FDataSet.Append;\r\n WriteFields;\r\n FDataSet.Post;\r\n Result := True;\r\n except\r\n Result := False;\r\n end;\r\n end;\r\n\r\n function UpdateRec: Boolean;\r\n begin\r\n try\r\n FDataSet.Edit;\r\n WriteFields;\r\n FDataSet.Post;\r\n Result := True;\r\n except\r\n Result := False;\r\n end;\r\n end;\r\n\r\n function DeleteRec: Boolean;\r\n begin\r\n try\r\n FDataSet.Delete;\r\n Result := True;\r\n except\r\n Result := False;\r\n end;\r\n end;\r\n\r\n function SaveChanges: Integer;\r\n var\r\n I: Integer;\r\n begin\r\n Result := 0;\r\n FDataSet.DisableControls;\r\n DisableControls;\r\n Row := RecNo;\r\n FSaveLoadState := slsSaving;\r\n try\r\n if not IsEmpty then\r\n First;\r\n while not EOF do\r\n begin\r\n Status := TRecordStatus(FieldByName(FStatusName).AsInteger);\r\n if (Status <> rsOriginal) then\r\n begin\r\n xKey := GetValues;\r\n bFound := FDataSet.Locate(FKeyFieldNames, xKey, []);\r\n DoBeforeApplyRecord(FDataSet, Status, bFound);\r\n bApply := False;\r\n (********************* New Record ***********************)\r\n if IsInserted then\r\n begin\r\n if not bFound then // Not Exists in Original\r\n begin\r\n if InsertRec then\r\n begin\r\n Inc(Result);\r\n bApply := True;\r\n end\r\n else\r\n if FExactApply then\r\n begin\r\n Error(RsEInsertError);\r\n Break;\r\n end\r\n else\r\n if (FDataSet.State in dsEditModes) then\r\n FDataSet.Cancel;\r\n end\r\n else\r\n if FApplyMode = amMerge then // Exists in Original\r\n begin\r\n if UpdateRec then\r\n begin\r\n Inc(Result);\r\n bApply := True;\r\n end\r\n else\r\n if FExactApply then\r\n begin\r\n Error(RsEUpdateError);\r\n Break;\r\n end\r\n else\r\n if (FDataset.State in dsEditModes) then\r\n FDataset.Cancel;\r\n end\r\n else\r\n if FExactApply then\r\n begin\r\n Error(RsERecordDuplicate);\r\n Break;\r\n end;\r\n end;\r\n (*********************** Modified Record ************************)\r\n if IsUpdated then\r\n begin\r\n if bFound then // Exists in Original\r\n begin\r\n if UpdateRec then\r\n begin\r\n Inc(Result);\r\n bApply := True;\r\n end\r\n else\r\n if FExactApply then\r\n begin\r\n Error(RsEUpdateError);\r\n Break;\r\n end\r\n else\r\n if (FDataset.State in dsEditModes) then\r\n FDataset.Cancel;\r\n end\r\n else\r\n if FApplyMode = amMerge then // Not exists in Original\r\n begin\r\n if InsertRec then\r\n begin\r\n Inc(Result);\r\n bApply := True;\r\n end\r\n else\r\n if FExactApply then\r\n begin\r\n Error(RsEInsertError);\r\n Break;\r\n end\r\n else\r\n if FDataset.State in dsEditModes then\r\n FDataset.Cancel;\r\n end\r\n else\r\n if FExactApply then\r\n begin\r\n Error(RsERecordInexistent);\r\n Break;\r\n end;\r\n end;\r\n DoAfterApplyRecord(FDataset, Status, bApply);\r\n end;\r\n Next;\r\n end;\r\n (*********************** Deleted Records **************************)\r\n if (FApplyMode = amMerge) then\r\n begin\r\n for I := 0 to FDeletedValues.Count - 1 do\r\n begin\r\n Status := rsDeleted;\r\n PxKey := FDeletedValues[I];\r\n // Mantis #3974 : \"FDeletedValues\" is a List of Pointers, and each item have two\r\n // possible values... PxKey (a Variant) or NIL. The list counter is incremented\r\n // with the ADD() method and decremented with the DELETE() method\r\n if PxKey <> nil then // ONLY if FDeletedValues[I] have a value <> NIL\r\n begin\r\n xKey := PxKey^;\r\n bFound := FDataSet.Locate(FKeyFieldNames, xKey, []);\r\n DoBeforeApplyRecord(FDataSet, Status, bFound);\r\n bApply := False;\r\n if bFound then // Exists in Original\r\n begin\r\n if DeleteRec then\r\n begin\r\n Inc(Result);\r\n bApply := True;\r\n end\r\n else\r\n if FExactApply then\r\n begin\r\n Error(RsEDeleteError);\r\n Break;\r\n end;\r\n end\r\n else\r\n if FExactApply then // Not exists in Original\r\n begin\r\n Error(RsERecordInexistent);\r\n Break;\r\n end\r\n else\r\n begin\r\n Inc(Result);\r\n bApply := True;\r\n end;\r\n DoAfterApplyRecord(FDataSet, Status, bApply);\r\n end;\r\n end;\r\n end;\r\n finally\r\n FSaveLoadState := slsNone;\r\n RecNo := Row;\r\n EnableControls;\r\n FDataSet.EnableControls;\r\n end;\r\n end;\r\n\r\nbegin\r\n Result := False;\r\n\r\n if (FDataSet = nil) or (FApplyMode = amNone) then\r\n Exit;\r\n if (FApplyMode <> amNone) and (FKeyFieldNames = '') then\r\n Exit;\r\n Len := FieldDefs.Count - 2;\r\n if (Len < 1) then\r\n Exit;\r\n\r\n try\r\n if not FDataSet.Active then\r\n FDataSet.Open;\r\n except\r\n Exit;\r\n end;\r\n\r\n CheckBrowseMode;\r\n DoBeforeApply(FDataset, FRowsChanged);\r\n\r\n FSaveLoadState := slsSaving;\r\n if (FRowsChanged < 1) or (IsEmpty and (FDeletedValues.Count < 1)) then\r\n begin\r\n FRowsAffected := 0;\r\n Result := (FRowsAffected = FRowsChanged);\r\n end\r\n else\r\n begin\r\n FRowsAffected := SaveChanges;\r\n Result := (FRowsAffected = FRowsChanged) or\r\n ((FRowsAffected > 0) and (FRowsAffected < FRowsChanged) and not FExactApply);\r\n end;\r\n FSaveLoadState := slsNone;\r\n\r\n DoAfterApply(FDataset, FRowsAffected);\r\n if Result then\r\n ClearChanges;\r\n\r\n FRowsAffected := 0;\r\n FRowsChanged := 0;\r\n\r\n if FDataSet.Active and FDatasetClosed then\r\n FDataset.Close;\r\nend;\r\n\r\nfunction TJvMemoryData.FindDeleted(KeyValues: Variant): Integer;\r\nvar\r\n I, J, Len, Equals: Integer;\r\n PxKey: TPVariant;\r\n xKey, ValRow, ValDel: Variant;\r\nbegin\r\n Result := -1;\r\n if VarIsNull(KeyValues) then\r\n Exit;\r\n PxKey := nil;\r\n Len := VarArrayHighBound(KeyValues, 1);\r\n try\r\n for I := 0 to FDeletedValues.Count - 1 do\r\n begin\r\n PxKey := FDeletedValues[I];\r\n // Mantis #3974 : \"FDeletedValues\" is a List of Pointers, and each item have two\r\n // possible value... PxKey (a Variant) or NIL. The list counter is incremented\r\n // with the ADD() method and decremented with the DELETE() method\r\n if PxKey <> nil then // ONLY if FDeletedValues[I] have a value <> NIL\r\n begin\r\n xKey := PxKey^;\r\n Equals := -1;\r\n for J := 0 to Len - 1 do\r\n begin\r\n ValRow := KeyValues[J];\r\n ValDel := xKey[J];\r\n if VarCompareValue(ValRow, ValDel) = vrEqual then\r\n begin\r\n Inc(Equals);\r\n if Equals = (Len - 1) then\r\n Break;\r\n end;\r\n end;\r\n if Equals = (Len - 1) then\r\n begin\r\n Result := I;\r\n Break;\r\n end;\r\n end;\r\n end;\r\n finally\r\n if PxKey <> nil then\r\n Dispose(PxKey);\r\n end;\r\nend;\r\n\r\nfunction TJvMemoryData.IsDeleted(out Index: Integer): Boolean;\r\nbegin\r\n Index := FindDeleted(GetValues());\r\n Result := Index > -1;\r\nend;\r\n\r\nfunction TJvMemoryData.IsInserted: Boolean;\r\nbegin\r\n Result := TRecordStatus(FieldByName(FStatusName).AsInteger) = rsInserted;\r\nend;\r\n\r\nfunction TJvMemoryData.IsUpdated: Boolean;\r\nbegin\r\n Result := TRecordStatus(FieldByName(FStatusName).AsInteger) = rsUpdated;\r\nend;\r\n\r\nfunction TJvMemoryData.IsOriginal: Boolean;\r\nbegin\r\n Result := TRecordStatus(FieldByName(FStatusName).AsInteger) = rsOriginal;\r\nend;\r\n\r\nfunction TJvMemoryData.IsLoading: Boolean;\r\nbegin\r\n Result := FSaveLoadState = slsLoading;\r\nend;\r\n\r\nfunction TJvMemoryData.IsSaving: Boolean;\r\nbegin\r\n Result := FSaveLoadState = slsSaving;\r\nend;\r\n\r\n//=== { TJvMemBlobStream } ===================================================\r\n\r\nconstructor TJvMemBlobStream.Create(Field: TBlobField; Mode: TBlobStreamMode);\r\nbegin\r\n // (rom) added inherited Create;\r\n inherited Create;\r\n FMode := Mode;\r\n FField := Field;\r\n FDataSet := FField.DataSet as TJvMemoryData;\r\n if not FDataSet.GetActiveRecBuf(FBuffer) then\r\n Exit;\r\n if not FField.Modified and (Mode <> bmRead) then\r\n begin\r\n if FField.ReadOnly then\r\n ErrorFmt(SFieldReadOnly, [FField.DisplayName]);\r\n if not (FDataSet.State in [dsEdit, dsInsert]) then\r\n Error(SNotEditing);\r\n FCached := True;\r\n end\r\n else\r\n FCached := (FBuffer = FDataSet.ActiveBuffer);\r\n FOpened := True;\r\n if Mode = bmWrite then\r\n Truncate;\r\nend;\r\n\r\ndestructor TJvMemBlobStream.Destroy;\r\nbegin\r\n if FOpened and FModified then\r\n FField.Modified := True;\r\n if FModified then\r\n try\r\n FDataSet.DataEvent(deFieldChange, NativeInt(FField));\r\n except\r\n AppHandleException(Self);\r\n end;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJvMemBlobStream.GetBlobFromRecord(Field: TField): TMemBlobData;\r\nvar\r\n Rec: TJvMemoryRecord;\r\n Pos: Integer;\r\nbegin\r\n Result := '';\r\n Pos := FDataSet.FRecordPos;\r\n if (Pos < 0) and (FDataSet.RecordCount > 0) then\r\n Pos := 0\r\n else\r\n if Pos >= FDataSet.RecordCount then\r\n Pos := FDataSet.RecordCount - 1;\r\n if (Pos >= 0) and (Pos < FDataSet.RecordCount) then\r\n begin\r\n Rec := FDataSet.Records[Pos];\r\n if Rec <> nil then\r\n Result := PMemBlobArray(Rec.FBlobs)[FField.Offset];\r\n end;\r\nend;\r\n\r\nfunction TJvMemBlobStream.Read(var Buffer; Count: Longint): Longint;\r\nbegin\r\n Result := 0;\r\n if FOpened then\r\n begin\r\n if Count > Size - FPosition then\r\n Result := Size - FPosition\r\n else\r\n Result := Count;\r\n if Result > 0 then\r\n begin\r\n if FCached then\r\n begin\r\n Move(PJvMemBuffer(FDataSet.GetBlobData(FField, FBuffer))[FPosition], Buffer,\r\n Result);\r\n Inc(FPosition, Result);\r\n end\r\n else\r\n begin\r\n Move(PJvMemBuffer(GetBlobFromRecord(FField))[FPosition], Buffer, Result);\r\n Inc(FPosition, Result);\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJvMemBlobStream.Write(const Buffer; Count: Longint): Longint;\r\nvar\r\n Temp: TMemBlobData;\r\nbegin\r\n Result := 0;\r\n if FOpened and FCached and (FMode <> bmRead) then\r\n begin\r\n Temp := FDataSet.GetBlobData(FField, FBuffer);\r\n if Length(Temp) < FPosition + Count then\r\n SetLength(Temp, FPosition + Count);\r\n Move(Buffer, PJvMemBuffer(Temp)[FPosition], Count);\r\n FDataSet.SetBlobData(FField, FBuffer, Temp);\r\n Inc(FPosition, Count);\r\n Result := Count;\r\n FModified := True;\r\n end;\r\nend;\r\n\r\nfunction TJvMemBlobStream.Seek(Offset: Longint; Origin: Word): Longint;\r\nbegin\r\n case Origin of\r\n soFromBeginning:\r\n FPosition := Offset;\r\n soFromCurrent:\r\n Inc(FPosition, Offset);\r\n soFromEnd:\r\n FPosition := GetBlobSize + Offset;\r\n end;\r\n Result := FPosition;\r\nend;\r\n\r\nprocedure TJvMemBlobStream.Truncate;\r\nbegin\r\n if FOpened and FCached and (FMode <> bmRead) then\r\n begin\r\n FDataSet.SetBlobData(FField, FBuffer, '');\r\n FModified := True;\r\n end;\r\nend;\r\n\r\nfunction TJvMemBlobStream.GetBlobSize: Longint;\r\nbegin\r\n Result := 0;\r\n if FOpened then\r\n if FCached then\r\n Result := Length(FDataSet.GetBlobData(FField, FBuffer))\r\n else\r\n Result := Length(GetBlobFromRecord(FField));\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvMenus.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvMenus.PAS, released on 2002-07-04.\r\n\r\nThe Initial Developers of the Original Code are: Fedor Koshevnikov, Igor Pavluk and Serge Korolev\r\nCopyright (c) 1997, 1998 Fedor Koshevnikov, Igor Pavluk and Serge Korolev\r\nCopyright (c) 2001,2002 SGB Software\r\nAll Rights Reserved.\r\n\r\nContributors: Olivier Sannier [obones att altern dott org]\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvMenus.pas 13403 2012-08-19 17:56:34Z ahuser $\r\n\r\nunit JvMenus;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, Messages, SysUtils, Contnrs, Graphics, Controls, Forms, Classes,\r\n ExtCtrls, ImgList, Menus,\r\n JvWndProcHook, JVCLVer;\r\n\r\nconst\r\n // custom painter constants\r\n DefaultImageBackgroundColor = clBtnFace;\r\n DefaultMarginColor: TColor = clBlue;\r\n\r\n // xp painter constants\r\n DefaultXPImageBackgroundColor = TColor($D1D8D8);\r\n DefaultXPSeparatorColor = TColor($A6A6A6);\r\n DefaultXPSFBrushColor = TColor($D2BDB6);\r\n DefaultXPSFPenColor = TColor($6A240A);\r\n DefaultXPShadowColor = TColor($9D8D88);\r\n DefaultXPCheckedImageBackColorSelected = TColor($B59285);\r\n DefaultXPCheckedImageBackColor = TColor($D8D5D4);\r\n\r\ntype\r\n // early declarations\r\n TJvMainMenu = class;\r\n TJvPopupMenu = class;\r\n TJvCustomMenuItemPainter = class;\r\n\r\n { Generic types }\r\n\r\n // size of an image\r\n TJvMenuImageSize = class(TPersistent)\r\n private\r\n FHeight: Integer;\r\n FWidth: Integer;\r\n FOnChange: TNotifyEvent;\r\n procedure SetHeight(const Value: Integer);\r\n procedure SetWidth(const Value: Integer);\r\n public\r\n procedure Assign(Source: TPersistent); override;\r\n procedure DoChange;\r\n\r\n property OnChange: TNotifyEvent read FOnChange write FOnChange;\r\n published\r\n property Height: Integer read FHeight write SetHeight;\r\n property Width: Integer read FWidth write SetWidth;\r\n end;\r\n\r\n // margins around an image\r\n TJvImageMargin = class(TPersistent)\r\n private\r\n FTop: Integer;\r\n FLeft: Integer;\r\n FRight: Integer;\r\n FBottom: Integer;\r\n FOnChange: TNotifyEvent;\r\n procedure SetBottom(const Value: Integer);\r\n procedure SetLeft(const Value: Integer);\r\n procedure SetRight(const Value: Integer);\r\n procedure SetTop(const Value: Integer);\r\n public\r\n procedure Assign(Source: TPersistent); override;\r\n procedure DoChange;\r\n\r\n property OnChange: TNotifyEvent read FOnChange write FOnChange;\r\n published\r\n property Left: Integer read FLeft write SetLeft;\r\n property Top: Integer read FTop write SetTop;\r\n property Right: Integer read FRight write SetRight;\r\n property Bottom: Integer read FBottom write SetBottom;\r\n end;\r\n\r\n // the vertical aligment\r\n TJvVerticalAlignment = (vaTop, vaMiddle, vaBottom);\r\n\r\n { TJvMenuChangeLink}\r\n\r\n // This class should be used by any class that wishes to be notified\r\n // when the content of the menu has changed. Pass an instance of\r\n // TJvMenuChangeLink to a TJvMainMenu through RegisterChanges and\r\n // the OnChange event of your object will be fired whenever it is\r\n // required. This is done on the same principle as the TCustomImageList.\r\n // In the JVCL, TJvToolbar uses this principle to automatically\r\n // adjust its content (and size if autosize is true) when the\r\n // content of the menu it is linked to has changed.\r\n\r\n // This next type is the event triggered when the menu has changed\r\n // If Rebuild is true, the menu has had to be rebuilt because of a\r\n // change in its layout, not in the properties of one of its item.\r\n // Unfortunately, for a reason yet to be discovered, Rebuild is\r\n // always false, even when adding or removing items in the menu.\r\n // As a result any class using this feature should compute its\r\n // own value for Rebuild and decide upon it, rather than on the\r\n // original value of Rebuild\r\n TOnJvMenuChange = procedure(Sender: TJvMainMenu; Source: TMenuItem; Rebuild: Boolean) of object;\r\n\r\n TJvMenuChangeLink = class(TObject)\r\n private\r\n FOnChange: TOnJvMenuChange;\r\n protected\r\n // triggers the OnChange event.\r\n // this is protected as it cannot be accessed by any other class\r\n // except the TJvMainMenu which is located in the same unit\r\n // (scope only applies outside the unit)\r\n procedure Change(Sender: TJvMainMenu; Source: TMenuItem; Rebuild: Boolean); dynamic;\r\n public\r\n property OnChange: TOnJvMenuChange read FOnChange write FOnChange;\r\n end;\r\n\r\n { TJvMainMenu }\r\n\r\n // the different styles a menu can get\r\n TJvMenuStyle = (msStandard, // standard (no raising frames around images)\r\n msOwnerDraw, // drawn by owner\r\n msBtnLowered, // drawn as a lowered button\r\n msBtnRaised, // drawn as a raised button\r\n msOffice, // drawn as in MSOffice (raising frames around selected images)\r\n msXP, // drawn as in WinXP (white background, shadow below selected images)\r\n msItemPainter // drawn by the painter in ItemPainter property\r\n );\r\n\r\n // the state a menu item can get\r\n TMenuOwnerDrawState = set of (mdSelected, mdGrayed, mdDisabled, mdChecked,\r\n mdFocused, mdDefault, mdHotlight, mdInactive);\r\n\r\n // The event trigerred when an item is to be drawn by its owner\r\n TDrawMenuItemEvent = procedure(Sender: TMenu; Item: TMenuItem; Rect: TRect;\r\n State: TMenuOwnerDrawState) of object;\r\n\r\n // The event trigerred when the size of an item is required\r\n TMeasureMenuItemEvent = procedure(Sender: TMenu; Item: TMenuItem; var Width,\r\n Height: Integer) of object;\r\n\r\n // event trigerred when about to draw the menu item and a\r\n // glyph for it is required. If no handler is provided, the\r\n // image list will be asked and if not available, no image\r\n // will be drawn\r\n TItemParamsEvent = procedure(Sender: TMenu; Item: TMenuItem;\r\n State: TMenuOwnerDrawState; AFont: TFont; var Color: TColor;\r\n var Graphic: TGraphic; var NumGlyphs: Integer) of object;\r\n\r\n // event triggerred when asking for an image index\r\n // if no handler is provided, the value in the menu item will\r\n // be used\r\n TItemImageEvent = procedure(Sender: TMenu; Item: TMenuItem;\r\n State: TMenuOwnerDrawState; var ImageIndex: Integer) of object;\r\n\r\n // the main menu class\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvMainMenu = class(TMainMenu)\r\n private\r\n FAboutJVCL: TJVCLAboutInfo;\r\n FCursor: TCursor;\r\n FDisabledImages: TCustomImageList;\r\n FHotImages: TCustomImageList;\r\n FImageMargin: TJvImageMargin;\r\n FImages: TCustomImageList;\r\n FImageSize: TJvMenuImageSize;\r\n FShowCheckMarks: Boolean;\r\n FStyle: TJvMenuStyle;\r\n FTextMargin: Integer;\r\n FTextVAlignment: TJvVerticalAlignment;\r\n\r\n FOnDrawItem: TDrawMenuItemEvent;\r\n FOnMeasureItem: TMeasureMenuItemEvent;\r\n FOnGetItemParams: TItemParamsEvent;\r\n\r\n FImageChangeLink: TChangeLink;\r\n FOnGetImageIndex: TItemImageEvent;\r\n\r\n FDisabledImageChangeLink: TChangeLink;\r\n FOnGetDisabledImageIndex: TItemImageEvent;\r\n\r\n FHotImageChangeLink: TChangeLink;\r\n FOnGetHotImageIndex: TItemImageEvent;\r\n\r\n FChangeLinks: TObjectList;\r\n FCanvas: TControlCanvas;\r\n\r\n // This is one is used if Style is not msItemPainter\r\n FStyleItemPainter: TJvCustomMenuItemPainter;\r\n\r\n // This one is for the ItemPainter property\r\n FItemPainter: TJvCustomMenuItemPainter;\r\n function GetCanvas: TCanvas;\r\n procedure SetItemPainter(const Value: TJvCustomMenuItemPainter);\r\n function GetActiveItemPainter: TJvCustomMenuItemPainter;\r\n procedure SetStyle(Value: TJvMenuStyle);\r\n procedure SetDisabledImages(Value: TCustomImageList);\r\n procedure SetImages(Value: TCustomImageList);\r\n procedure SetHotImages(Value: TCustomImageList);\r\n protected\r\n procedure ImageListChange(Sender: TObject);\r\n procedure ImageSizeChange(Sender: TObject);\r\n procedure ImageMarginChange(Sender: TObject);\r\n procedure DisabledImageListChange(Sender: TObject);\r\n procedure HotImageListChange(Sender: TObject);\r\n function FindForm: TWinControl;\r\n function NewWndProc(var Msg: TMessage): Boolean;\r\n procedure CMMenuChanged(var Msg: TMessage); message CM_MENUCHANGED;\r\n procedure WMDrawItem(var Msg: TWMDrawItem); message WM_DRAWITEM;\r\n procedure WMMeasureItem(var Msg: TWMMeasureItem); message WM_MEASUREITEM;\r\n procedure WMMenuSelect(var Msg: TWMMenuSelect); message WM_MENUSELECT;\r\n\r\n procedure Loaded; override;\r\n procedure Notification(AComponent: TComponent; Operation: TOperation); override;\r\n procedure GetImageIndex(Item: TMenuItem; State: TMenuOwnerDrawState; var ImageIndex: Integer); dynamic;\r\n procedure DrawItem(Item: TMenuItem; Rect: TRect;\r\n State: TMenuOwnerDrawState); virtual;\r\n procedure GetItemParams(Item: TMenuItem; State: TMenuOwnerDrawState; AFont: TFont; var Color: TColor; var Graphic: TGraphic;\r\n var NumGlyphs: Integer); dynamic;\r\n procedure MeasureItem(Item: TMenuItem; var Width, Height: Integer); dynamic;\r\n procedure RefreshMenu(AOwnerDraw: Boolean); virtual;\r\n function IsOwnerDrawMenu: Boolean;\r\n\r\n // called when the menu has changed. If Rebuild is true, the menu\r\n // has had to be rebuilt because of a change in its layout, not in\r\n // the properties of one of its item. Unfortunately, for a reason\r\n // yet to be discovered, Rebuild is always false, even when adding\r\n // or removing items in the menu.\r\n procedure MenuChanged(Sender: TObject; Source: TMenuItem; Rebuild: Boolean); override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n procedure Refresh;\r\n procedure DefaultDrawItem(Item: TMenuItem; Rect: TRect;\r\n State: TMenuOwnerDrawState);\r\n procedure Rebuild(ForceIfLoading: Boolean = False);\r\n\r\n // change registering methods\r\n procedure RegisterChanges(ChangeLink: TJvMenuChangeLink);\r\n procedure UnregisterChanges(ChangeLink: TJvMenuChangeLink);\r\n\r\n // get the canvas of the menu\r\n property Canvas: TCanvas read GetCanvas;\r\n // get the currently used painter\r\n property ActiveItemPainter: TJvCustomMenuItemPainter read GetActiveItemPainter;\r\n published\r\n // Style MUST BE before ItemPainter for the properties of the\r\n // painter to be correctly read from the DFM file.\r\n property Style: TJvMenuStyle read FStyle write SetStyle default msStandard;\r\n property AboutJVCL: TJVCLAboutInfo read FAboutJVCL write FAboutJVCL stored False;\r\n property Cursor: TCursor read FCursor write FCursor default crDefault;\r\n property DisabledImages: TCustomImageList read FDisabledImages write SetDisabledImages;\r\n property HotImages: TCustomImageList read FHotImages write SetHotImages;\r\n property Images: TCustomImageList read FImages write SetImages;\r\n property ImageMargin: TJvImageMargin read FImageMargin write FImageMargin;\r\n property ImageSize: TJvMenuImageSize read FImageSize write FImageSize;\r\n property ItemPainter: TJvCustomMenuItemPainter read FItemPainter write SetItemPainter;\r\n property OwnerDraw stored False;\r\n property ShowCheckMarks: Boolean read FShowCheckMarks write FShowCheckMarks default False;\r\n property TextMargin: Integer read FTextMargin write FTextMargin default 0;\r\n property TextVAlignment: TJvVerticalAlignment read FTextVAlignment write FTextVAlignment default vaMiddle;\r\n\r\n property OnGetImageIndex: TItemImageEvent read FOnGetImageIndex write FOnGetImageIndex;\r\n property OnGetDisabledImageIndex: TItemImageEvent read FOnGetDisabledImageIndex write FOnGetDisabledImageIndex;\r\n property OnGetHotImageIndex: TItemImageEvent read FOnGetHotImageIndex write FOnGetHotImageIndex;\r\n property OnDrawItem: TDrawMenuItemEvent read FOnDrawItem write FOnDrawItem;\r\n property OnGetItemParams: TItemParamsEvent read FOnGetItemParams write FOnGetItemParams;\r\n property OnMeasureItem: TMeasureMenuItemEvent read FOnMeasureItem write FOnMeasureItem;\r\n end;\r\n\r\n { TJvPopupMenu }\r\n\r\n // The Popup counterpart of TJvMainMenu\r\n // does basically the same thing, but in a popup menu\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvPopupMenu = class(TPopupMenu)\r\n private\r\n FAboutJVCL: TJVCLAboutInfo;\r\n FCursor: TCursor;\r\n FDisabledImages: TCustomImageList;\r\n FHotImages: TCustomImageList;\r\n FImageMargin: TJvImageMargin;\r\n FImages: TCustomImageList;\r\n FImageSize: TJvMenuImageSize;\r\n FShowCheckMarks: Boolean;\r\n FStyle: TJvMenuStyle;\r\n FTextMargin: Integer;\r\n FTextVAlignment: TJvVerticalAlignment;\r\n\r\n FOnDrawItem: TDrawMenuItemEvent;\r\n FOnMeasureItem: TMeasureMenuItemEvent;\r\n FOnGetItemParams: TItemParamsEvent;\r\n\r\n FImageChangeLink: TChangeLink;\r\n FOnGetImageIndex: TItemImageEvent;\r\n\r\n FDisabledImageChangeLink: TChangeLink;\r\n FOnGetDisabledImageIndex: TItemImageEvent;\r\n\r\n FHotImageChangeLink: TChangeLink;\r\n FOnGetHotImageIndex: TItemImageEvent;\r\n\r\n FParentBiDiMode: Boolean;\r\n FCanvas: TControlCanvas;\r\n\r\n // This is one is used if Style is not msItemPainter\r\n FStyleItemPainter: TJvCustomMenuItemPainter;\r\n\r\n // This one is for the ItemPainter property\r\n FItemPainter: TJvCustomMenuItemPainter;\r\n function GetCanvas: TCanvas;\r\n procedure SetItemPainter(const Value: TJvCustomMenuItemPainter);\r\n function GetActiveItemPainter: TJvCustomMenuItemPainter;\r\n procedure SetDisabledImages(Value: TCustomImageList);\r\n procedure SetImages(Value: TCustomImageList);\r\n procedure SetHotImages(Value: TCustomImageList);\r\n procedure SetStyle(Value: TJvMenuStyle);\r\n protected\r\n procedure ImageListChange(Sender: TObject);\r\n procedure ImageSizeChange(Sender: TObject);\r\n procedure ImageMarginChange(Sender: TObject);\r\n procedure DisabledImageListChange(Sender: TObject);\r\n procedure HotImageListChange(Sender: TObject);\r\n procedure WndMessage(Sender: TObject; var AMsg: TMessage;\r\n var Handled: Boolean);\r\n procedure WMDrawItem(var Msg: TWMDrawItem); message WM_DRAWITEM;\r\n procedure WMMeasureItem(var Msg: TWMMeasureItem); message WM_MEASUREITEM;\r\n procedure SetBiDiModeFromPopupControl;\r\n {$IFNDEF COMPILER9_UP}\r\n procedure SetPopupPoint(const Pt: TPoint);\r\n {$ENDIF !COMPILER9_UP}\r\n\r\n procedure WriteState(Writer: TWriter); override;\r\n procedure ReadState(Reader: TReader); override;\r\n\r\n procedure Loaded; override;\r\n function UseRightToLeftAlignment: Boolean;\r\n procedure Notification(AComponent: TComponent; Operation: TOperation); override;\r\n procedure GetImageIndex(Item: TMenuItem; State: TMenuOwnerDrawState;\r\n var ImageIndex: Integer); dynamic;\r\n procedure DrawItem(Item: TMenuItem; Rect: TRect;\r\n State: TMenuOwnerDrawState); virtual;\r\n procedure GetItemParams(Item: TMenuItem; State: TMenuOwnerDrawState;\r\n AFont: TFont; var Color: TColor; var Graphic: TGraphic;\r\n var NumGlyphs: Integer); dynamic;\r\n procedure MeasureItem(Item: TMenuItem; var Width, Height: Integer); dynamic;\r\n procedure RefreshMenu(AOwnerDraw: Boolean); virtual;\r\n function IsOwnerDrawMenu: Boolean;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n\r\n procedure Assign(Source: TPersistent); override;\r\n procedure Refresh;\r\n procedure Popup(X, Y: Integer); override;\r\n procedure DefaultDrawItem(Item: TMenuItem; Rect: TRect;\r\n State: TMenuOwnerDrawState); deprecated {$IFDEF SUPPORTS_DEPRECATED_DETAILS}'DefaultDrawItem calls DrawItem that is also called by OnDrawItem. As such, it is useless and even dangerous if you call it from OnDrawItem handler.'{$ENDIF SUPPORTS_DEPRECATED_DETAILS};\r\n procedure Rebuild(ForceIfLoading: Boolean = False);\r\n\r\n property Canvas: TCanvas read GetCanvas;\r\n // get the currently used painter\r\n property ActiveItemPainter: TJvCustomMenuItemPainter read GetActiveItemPainter;\r\n published\r\n // Style MUST BE before ItemPainter for the properties of the\r\n // painter to be correctly read from the DFM file.\r\n property Style: TJvMenuStyle read FStyle write SetStyle default msStandard;\r\n property AboutJVCL: TJVCLAboutInfo read FAboutJVCL write FAboutJVCL stored False;\r\n property Cursor: TCursor read FCursor write FCursor default crDefault;\r\n property DisabledImages: TCustomImageList read FDisabledImages write SetDisabledImages;\r\n property HotImages: TCustomImageList read FHotImages write SetHotImages;\r\n property ImageMargin: TJvImageMargin read FImageMargin write FImageMargin;\r\n property Images: TCustomImageList read FImages write SetImages;\r\n property ImageSize: TJvMenuImageSize read FImageSize write FImageSize;\r\n property ItemPainter: TJvCustomMenuItemPainter read FItemPainter write SetItemPainter;\r\n property OwnerDraw stored False;\r\n property ShowCheckMarks: Boolean read FShowCheckMarks write FShowCheckMarks default False;\r\n property TextMargin: Integer read FTextMargin write FTextMargin default 0;\r\n property TextVAlignment: TJvVerticalAlignment read FTextVAlignment write FTextVAlignment default vaMiddle;\r\n\r\n property OnGetImageIndex: TItemImageEvent read FOnGetImageIndex write FOnGetImageIndex;\r\n property OnGetDisabledImageIndex: TItemImageEvent read FOnGetDisabledImageIndex write FOnGetDisabledImageIndex;\r\n property OnGetHotImageIndex: TItemImageEvent read FOnGetHotImageIndex write FOnGetHotImageIndex;\r\n property OnDrawItem: TDrawMenuItemEvent read FOnDrawItem write FOnDrawItem;\r\n property OnGetItemParams: TItemParamsEvent read FOnGetItemParams write FOnGetItemParams;\r\n property OnMeasureItem: TMeasureMenuItemEvent read FOnMeasureItem write FOnMeasureItem;\r\n end;\r\n\r\n // the event trigerred when the margin of a menu must be drawn\r\n TJvDrawLeftMarginEvent = procedure(Sender: TMenu; Rect: TRect) of object;\r\n\r\n { TJvCustomMenuItemPainter }\r\n\r\n // This class is the base class for all the menu item painters.\r\n // Each instance of TJvMainMenu and TJvPopupMenu will contain one\r\n // instance of one of the descendent which will be be in charge\r\n // of the painting of menu items. There is one descendent per\r\n // style in the TJvMenuStyle enumeration\r\n TJvCustomMenuItemPainter = class(TComponent)\r\n private\r\n // property fields\r\n FImageBackgroundColor: TColor;\r\n FLeftMargin: Cardinal;\r\n FOnDrawLeftMargin: TJvDrawLeftMarginEvent;\r\n\r\n // other usage fields\r\n FMainMenu: TJvMainMenu;\r\n FPopupMenu: TJvPopupMenu;\r\n FOnDrawItem: TDrawMenuItemEvent;\r\n FImageMargin: TJvImageMargin;\r\n FImageSize: TJvMenuImageSize;\r\n FMenuHeight: Integer;\r\n FOneItemChecked: Boolean;\r\n\r\n FItem: TMenuItem;\r\n FState: TMenuOwnerDrawState;\r\n\r\n FImageIndex: Integer;\r\n FGlyph: TBitmap;\r\n FNumGlyphs: Integer;\r\n FParentMenu: TMenu;\r\n procedure SetLeftMargin(const Value: Cardinal);\r\n procedure SetImageBackgroundColor(const Value: TColor);\r\n function GetMenu: TMenu;\r\n procedure SetMenu(const Value: TMenu);\r\n function GetCanvas: TCanvas;\r\n\r\n procedure EmptyDrawItem(Sender: TObject;ACanvas: TCanvas; ARect: TRect; Selected: Boolean);\r\n protected\r\n function GetTextWidth(Item: TMenuItem): Integer;\r\n function GetCheckMarkHeight: Integer; virtual;\r\n function GetCheckMarkWidth: Integer; virtual;\r\n function GetDisabledImages: TCustomImageList;\r\n function GetDrawHighlight: Boolean; virtual;\r\n function GetGrayColor: TColor; virtual;\r\n function GetHotImages: TCustomImageList;\r\n function GetImageHeight: Integer; virtual;\r\n function GetImageWidth: Integer; virtual;\r\n function GetImages: TCustomImageList;\r\n function GetIsRightToLeft: Boolean;\r\n function GetShowCheckMarks: Boolean;\r\n function GetTextMargin: Integer; virtual;\r\n function GetTextVAlignment: TJvVerticalAlignment;\r\n\r\n function UseImages: Boolean;\r\n function UseHotImages: Boolean;\r\n function UseDisabledImages: Boolean;\r\n function IsPopup(const Item: TMenuItem): Boolean;\r\n\r\n // Will force the menu to rebuild itself.\r\n procedure ForceMenuRebuild;\r\n\r\n // This procedure will update the fields that are\r\n // instances of objects derived from TPersistent. This\r\n // allows for modification in the painter without any impact\r\n // on the values in the user's object (in his menu)\r\n procedure UpdateFieldsFromMenu; virtual;\r\n\r\n // draws the background required for a checked item\r\n // doesn't draw the mark, simply the grey matrix that\r\n // is shown behind the mark or image\r\n procedure DrawGlyphCheck(ARect: TRect); virtual;\r\n\r\n // prepare the paint by assigning various fields\r\n procedure PreparePaint(Item: TMenuItem; ItemRect: TRect;\r\n State: TMenuOwnerDrawState; Measure: Boolean); virtual;\r\n\r\n // draws the item background\r\n // does nothing by default\r\n procedure DrawItemBackground(ARect: TRect); virtual;\r\n\r\n // draws the check mark background\r\n // does nothing by default\r\n procedure DrawCheckMarkBackground(ARect: TRect); virtual;\r\n\r\n // draws the image background\r\n // does nothing by default\r\n procedure DrawImageBackground(ARect: TRect); virtual;\r\n\r\n // draws the background of the text\r\n // does nothing by default\r\n procedure DrawTextBackground(ARect: TRect); virtual;\r\n\r\n // draws a frame for the menu item.\r\n // will only be called if the menu item is selected (mdSelected in State)\r\n // and does nothing by default\r\n procedure DrawSelectedFrame(ARect: TRect); virtual;\r\n\r\n // Draws a disabled bitmap at the given coordinates.\r\n // The disabled bitmap will be created from the given bitmap.\r\n // This is only called when the glyph property of the item index\r\n // is not empty or when the graphic set in the OnItemParams event\r\n // was a TBitmap or when no image is available for a checked item\r\n procedure DrawDisabledBitmap(X, Y: Integer; Bitmap: TBitmap); virtual;\r\n\r\n // Draws the menu bitmap at the given coordinates.\r\n // This is only called when the glyph property of the item index\r\n // is not empty or when the graphic set in the OnItemParams event\r\n // was a TBitmap or when no image is available for a checked item\r\n procedure DrawMenuBitmap(X, Y: Integer; Bitmap: TBitmap); virtual;\r\n\r\n // Draws a disabled image. This is called when the ImageList property\r\n // is not empty\r\n procedure DrawDisabledImage(X, Y: Integer); virtual;\r\n\r\n // Draws an enabled image. This is called when the ImageList property\r\n // is not empty\r\n procedure DrawEnabledImage(X, Y: Integer); virtual;\r\n\r\n // Draws a check image for the menu item\r\n // will only be called if the menu item is checked, the menu item is\r\n // a popup at the time of showing (being a popup meaning not being\r\n // a top level menu item in a main menu) and the parent menu asks\r\n // to show check marks or there are no image for the item\r\n procedure DrawCheckImage(ARect: TRect); virtual;\r\n\r\n // draws the back of an image for a checked menu item.\r\n // by default, does nothing\r\n procedure DrawCheckedImageBack(ARect: TRect); virtual;\r\n\r\n // draws the back of an image for a menu item.\r\n // by default, does nothing\r\n procedure DrawNotCheckedImageBack(ARect: TRect); virtual;\r\n\r\n // draws a separator\r\n procedure DrawSeparator(ARect: TRect); virtual;\r\n\r\n // draws the text at the given place.\r\n // This procedure CAN NOT be called DrawText because BCB users wouldn't be\r\n // able to override it in a component written in C++. The error would be\r\n // that the linker cannot find DrawTextA. This comes from windows. which\r\n // defines this:\r\n // #define DrawText DrawTextA\r\n // because of ANSI support (over Unicode). Not using the DrawText name\r\n // solves this problem.\r\n procedure DrawItemText(ARect: TRect; const Text: string; Flags: Longint); virtual;\r\n\r\n procedure DrawLeftMargin(ARect: TRect); virtual;\r\n procedure DefaultDrawLeftMargin(ARect: TRect; StartColor, EndColor: TColor);\r\n\r\n // NEVER STORE Canvas, this value is not to be trusted from the menu\r\n // it MUST be read everytime it is needed\r\n property Canvas: TCanvas read GetCanvas;\r\n\r\n // properties read or calculated from the properties of the\r\n // menu to which the painter is linked\r\n property CheckMarkHeight: Integer read GetCheckMarkHeight;\r\n property CheckMarkWidth: Integer read GetCheckMarkWidth;\r\n property DisabledImages: TCustomImageList read GetDisabledImages;\r\n property DrawHighlight: Boolean read GetDrawHighlight;\r\n property GrayColor: TColor read GetGrayColor;\r\n property HotImages: TCustomImageList read GetHotImages;\r\n property Images: TCustomImageList read GetImages;\r\n property ImageHeight: Integer read GetImageHeight;\r\n property ImageMargin: TJvImageMargin read FImageMargin;\r\n property ImageSize: TJvMenuImageSize read FImageSize;\r\n property ImageWidth: Integer read GetImageWidth;\r\n property IsRightToLeft: Boolean read GetIsRightToLeft;\r\n property ShowCheckMarks: Boolean read GetShowCheckMarks;\r\n property TextMargin: Integer read GetTextMargin;\r\n property TextVAlignment: TJvVerticalAlignment read GetTextVAlignment;\r\n\r\n // Left margin properties and events\r\n property LeftMargin: Cardinal read FLeftMargin write SetLeftMargin default 0;\r\n property OnDrawLeftMargin: TJvDrawLeftMarginEvent read FOnDrawLeftMargin write FOnDrawLeftMargin;\r\n property ImageBackgroundColor: TColor read FImageBackgroundColor write SetImageBackgroundColor default DefaultImageBackgroundColor;\r\n public\r\n // constructor, will create the objects derived from TPersistent\r\n // which are stored here (see UpdateFieldsFromMenu)\r\n constructor Create(AOwner: TComponent); override;\r\n\r\n // This is the menu to which the painter is linked. It MUST be\r\n // set BEFORE calling any painting function, but no check is made\r\n // to ensure that this is the case\r\n property Menu: TMenu read GetMenu write SetMenu;\r\n\r\n // destroys the objects created in create\r\n destructor Destroy; override;\r\n\r\n // indicates in Width and Height the size of the given menu item\r\n // if it was painted with this painter\r\n procedure Measure(Item: TMenuItem; var Width, Height: Integer); virtual;\r\n\r\n // will paint the given item in the given rectangle\r\n // will call the various virtual functions depending on the\r\n // state of the menu item\r\n procedure Paint(Item: TMenuItem; ItemRect: TRect;\r\n State: TMenuOwnerDrawState); virtual;\r\n end;\r\n\r\n { TJvOfficeMenuItemPainter }\r\n\r\n // This painter draws an item using the office style\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvOfficeMenuItemPainter = class(TJvCustomMenuItemPainter)\r\n private\r\n FCurrentItem: TMenuItem;\r\n FCurrentState: TMenuOwnerDrawState;\r\n protected\r\n procedure CleanupGlyph(BtnRect: TRect);\r\n procedure DrawFrame(BtnRect: TRect);\r\n function GetDrawHighlight: Boolean; override;\r\n procedure DrawSelectedFrame(ARect: TRect); override;\r\n procedure DrawCheckedImageBack(ARect: TRect); override;\r\n procedure DrawNotCheckedImageBack(ARect: TRect); override;\r\n procedure UpdateFieldsFromMenu; override;\r\n function GetTextMargin: Integer; override;\r\n procedure DrawCheckImage(ARect: TRect); override;\r\n procedure DrawItemText(ARect: TRect; const Text: string; Flags: Longint); override;\r\n procedure DrawItemBackground(ARect: TRect); override;\r\n procedure PreparePaint(Item: TMenuItem; ItemRect: TRect; State: TMenuOwnerDrawState; Measure: Boolean); override;\r\n public\r\n procedure Paint(Item: TMenuItem; ItemRect: TRect; State: TMenuOwnerDrawState); override;\r\n published\r\n property LeftMargin;\r\n property OnDrawLeftMargin;\r\n end;\r\n\r\n // this painter draws an item as a lowered or raised button\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvBtnMenuItemPainter = class(TJvCustomMenuItemPainter)\r\n private\r\n FLowered: Boolean;\r\n protected\r\n procedure DrawSelectedFrame(ARect: TRect); override;\r\n function GetDrawHighlight: Boolean; override;\r\n function GetGrayColor: TColor; override;\r\n procedure UpdateFieldsFromMenu; override;\r\n public\r\n constructor Create(AOwner: TComponent); overload; override;\r\n constructor Create(AOwner: TComponent; Lowered: Boolean); reintroduce; overload;\r\n published\r\n property Lowered: Boolean read FLowered write FLowered;\r\n property LeftMargin;\r\n property OnDrawLeftMargin;\r\n end;\r\n\r\n // this painter is the standard one and as such doesn't do anything\r\n // more than the ancestor class except publishing properties\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvStandardMenuItemPainter = class(TJvCustomMenuItemPainter)\r\n protected\r\n procedure DrawCheckedImageBack(ARect: TRect); override;\r\n procedure UpdateFieldsFromMenu; override;\r\n function GetTextMargin: Integer; override;\r\n function GetImageWidth: Integer; override;\r\n public\r\n procedure Paint(Item: TMenuItem; ItemRect: TRect; State: TMenuOwnerDrawState); override;\r\n published\r\n property LeftMargin;\r\n property OnDrawLeftMargin;\r\n end;\r\n\r\n // this painter calls the user supplied events to render the item\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvOwnerDrawMenuItemPainter = class(TJvCustomMenuItemPainter)\r\n public\r\n procedure Measure(Item: TMenuItem; var Width, Height: Integer); override;\r\n procedure Paint(Item: TMenuItem; ItemRect: TRect; State: TMenuOwnerDrawState); override;\r\n end;\r\n\r\n // this painter draws an item using the XP style (white menus,\r\n // shadows below images...)\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvXPMenuItemPainter = class(TJvCustomMenuItemPainter)\r\n private\r\n // property fields\r\n FSelectionFrameBrush: TBrush;\r\n FSelectionFramePen: TPen;\r\n FShadowColor: TColor;\r\n FSeparatorColor: TColor;\r\n FCheckedImageBackColorSelected: TColor;\r\n FCheckedImageBackColor: TColor;\r\n // other usage fields\r\n FSelRect: TRect;\r\n FCheckedPoint: TPoint;\r\n FBorderCanvas: TCanvas;\r\n procedure SetSelectionFrameBrush(const Value: TBrush);\r\n procedure SetSelectionFramePen(const Value: TPen);\r\n protected\r\n procedure DrawBitmapShadow(X, Y: Integer; B: TBitmap);\r\n procedure DrawImageBackground(ARect: TRect); override;\r\n procedure DrawCheckMarkBackground(ARect: TRect); override;\r\n procedure PreparePaint(Item: TMenuItem; Rect: TRect;\r\n State: TMenuOwnerDrawState; Measure: Boolean); override;\r\n procedure DrawCheckedImageBack(ARect: TRect); override;\r\n procedure DrawEnabledImage(X, Y: Integer); override;\r\n procedure DrawItemBackground(ARect: TRect); override;\r\n procedure DrawMenuBitmap(X, Y: Integer; Bitmap: TBitmap); override;\r\n procedure DrawDisabledImage(X, Y: Integer); override;\r\n procedure DrawSelectedFrame(ARect: TRect); override;\r\n procedure DrawSeparator(ARect: TRect); override;\r\n procedure DrawItemText(ARect: TRect; const Text: string; Flags: Longint); override;\r\n function GetDrawHighlight: Boolean; override;\r\n procedure UpdateFieldsFromMenu; override;\r\n function GetTextMargin: Integer; override;\r\n procedure DrawCheckImage(ARect: TRect); override;\r\n\r\n procedure DrawBorder(ACanvas: TCanvas; WRect: TRect);\r\n procedure DrawItemBorderParts(Item: TMenuItem; Canvas: TCanvas; WRect: TRect);\r\n function GetShowingItemsParent(WRect: TRect; StartingItem: TMenuItem): TMenuItem;\r\n function GetItemScreenRect(ParentItem: TMenuItem; Index: Integer): TRect;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n procedure Measure(Item: TMenuItem; var Width, Height: Integer); override;\r\n procedure Paint(Item: TMenuItem; ItemRect: TRect;\r\n State: TMenuOwnerDrawState); override;\r\n published\r\n property ImageBackgroundColor default DefaultXPImageBackgroundColor;\r\n property SelectionFrameBrush: TBrush read FSelectionFrameBrush write SetSelectionFrameBrush;\r\n property SelectionFramePen: TPen read FSelectionFramePen write SetSelectionFramePen;\r\n property SeparatorColor: TColor read FSeparatorColor write FSeparatorColor default DefaultXPSeparatorColor;\r\n property ShadowColor: TColor read FShadowColor write FShadowColor default DefaultXPShadowColor;\r\n property CheckedImageBackColor: TColor read FCheckedImageBackColor write FCheckedImageBackColor default DefaultXPCheckedImageBackColor;\r\n property CheckedImageBackColorSelected: TColor read FCheckedImageBackColorSelected write FCheckedImageBackColorSelected default DefaultXPCheckedImageBackColorSelected;\r\n end;\r\n\r\n{ Utility routines }\r\n\r\nprocedure SetDefaultMenuFont(AFont: TFont);\r\nfunction UseFlatMenubars: Boolean;\r\nfunction StripHotkeyPrefix(const Text: string): string; // MBCS\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvMenus.pas $';\r\n Revision: '$Revision: 13403 $';\r\n Date: '$Date: 2012-08-19 19:56:34 +0200 (dim. 19 août 2012) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n CommCtrl, Math, Types,\r\n {$IFNDEF COMPILER7_UP}\r\n JvWin32,\r\n {$ENDIF ~COMPILER7_UP}\r\n JclGraphUtils, JvConsts, JvJCLUtils, JvJVCLUtils, System.UITypes;\r\n\r\nconst\r\n Separator = '-';\r\n\r\n // The space between a menu item text and its shortcut\r\n ShortcutSpacing = ' ';\r\n\r\n// Variables usesd by the XP painter to hook into the window procedure\r\n// of the window used to render menus\r\nvar\r\n currentXPPainter : TJvXPMenuItemPainter;\r\n\r\nfunction StripHotkeyPrefix(const Text: string): string; // MBCS\r\nvar\r\n I: Integer;\r\nbegin\r\n if LeadBytes <> [] then\r\n begin\r\n Result := Text;\r\n I := 1;\r\n while I <= Length(Result) do\r\n begin\r\n {$IFNDEF UNICODE} // Utf16: cHotkeyPrefix=#38 is in the BMP => no LeadByte check necessary \r\n if Result[I] in LeadBytes then\r\n Inc(I)\r\n else\r\n {$ENDIF ~UNICODE}\r\n if Result[I] = cHotkeyPrefix then\r\n Delete(Result, I, 1);\r\n Inc(I);\r\n end;\r\n end\r\n else\r\n Result := StripHotkey(Text);\r\nend;\r\n\r\n\r\nfunction CreateMenuItemPainterFromStyle(Style: TJvMenuStyle; Menu: TMenu): TJvCustomMenuItemPainter;\r\nbegin\r\n case Style of\r\n msOwnerDraw:\r\n Result := TJvOwnerDrawMenuItemPainter.Create(Menu);\r\n msBtnLowered:\r\n Result := TJvBtnMenuItemPainter.Create(Menu, True);\r\n msBtnRaised:\r\n Result := TJvBtnMenuItemPainter.Create(Menu, False);\r\n msOffice:\r\n Result := TJvOfficeMenuItemPainter.Create(Menu);\r\n msXP:\r\n Result := TJvXPMenuItemPainter.Create(Menu);\r\n else\r\n Result := TJvStandardMenuItemPainter.Create(Menu);\r\n end;\r\n Result.Menu := Menu;\r\nend;\r\n\r\nfunction IsItemPopup(Item: TMenuItem): Boolean;\r\nbegin\r\n Result := (Item.Parent = nil) or (Item.Parent.Parent <> nil) or\r\n not (Item.Parent.Owner is TMainMenu);\r\nend;\r\n\r\nfunction IsWinXP_UP: Boolean;\r\nbegin\r\n Result := (Win32Platform = VER_PLATFORM_WIN32_NT) and CheckWin32Version(5, 1);\r\nend;\r\n\r\nfunction UseFlatMenubars: Boolean;\r\nvar\r\n B: BOOL;\r\nbegin\r\n Result := IsWinXP_UP and SystemParametersInfo(SPI_GETFLATMENU, 0, @B, 0) and B;\r\nend;\r\n\r\nprocedure MenuWndMessage(Menu: TMenu; var AMsg: TMessage; var Handled: Boolean);\r\nvar\r\n Mesg: TMessage;\r\n Item: Pointer;\r\nbegin\r\n with AMsg do\r\n case Msg of\r\n WM_MEASUREITEM:\r\n if (TWMMeasureItem(AMsg).MeasureItemStruct^.CtlType = ODT_MENU) then\r\n begin\r\n Item := Menu.FindItem(TWMMeasureItem(AMsg).MeasureItemStruct^.itemID, fkCommand);\r\n if Item <> nil then\r\n begin\r\n Mesg := AMsg;\r\n TWMMeasureItem(Mesg).MeasureItemStruct^.itemData := ULONG_PTR(Item);\r\n Menu.Dispatch(Mesg);\r\n Result := 1;\r\n Handled := True;\r\n end;\r\n end;\r\n WM_DRAWITEM:\r\n if (TWMDrawItem(AMsg).DrawItemStruct^.CtlType = ODT_MENU) then\r\n begin\r\n Item := Menu.FindItem(TWMDrawItem(AMsg).DrawItemStruct^.itemID, fkCommand);\r\n if Item <> nil then\r\n begin\r\n Mesg := AMsg;\r\n TWMDrawItem(Mesg).DrawItemStruct^.itemData := ULONG_PTR(Item);\r\n Menu.Dispatch(Msg);\r\n Result := 1;\r\n Handled := True;\r\n end;\r\n end;\r\n WM_MENUSELECT:\r\n Menu.Dispatch(AMsg);\r\n CM_MENUCHANGED:\r\n Menu.Dispatch(AMsg);\r\n WM_MENUCHAR:\r\n begin\r\n Menu.ProcessMenuChar(TWMMenuChar(AMsg));\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure SetDefaultMenuFont(AFont: TFont);\r\nvar\r\n NCMetrics: TNonCLientMetrics;\r\nbegin\r\n {$IFDEF RTL210_UP}\r\n NCMetrics.cbSize := TNonClientMetrics.SizeOf;\r\n {$ELSE}\r\n NCMetrics.cbSize := SizeOf(TNonCLientMetrics);\r\n {$ENDIF RTL210_UP}\r\n if SystemParametersInfo(SPI_GETNONCLIENTMETRICS, NCMetrics.cbSize, @NCMetrics, 0) then\r\n begin\r\n AFont.Handle := CreateFontIndirect(NCMetrics.lfMenuFont);\r\n Exit;\r\n end;\r\n with AFont do\r\n begin\r\n Name := 'MS Sans Serif';\r\n Size := 8;\r\n Color := clMenuText;\r\n Style := [];\r\n end;\r\n AFont.Color := clMenuText;\r\nend;\r\n\r\nprocedure MenuLine(Canvas: TCanvas; C: TColor; X1, Y1, X2, Y2: Integer);\r\nbegin\r\n with Canvas do\r\n begin\r\n Pen.Color := C;\r\n Pen.Style := psSolid;\r\n MoveTo(X1, Y1);\r\n LineTo(X2, Y2);\r\n end;\r\nend;\r\n\r\n//=== { TJvMenuChangeLink } ==================================================\r\n\r\nprocedure TJvMenuChangeLink.Change(Sender: TJvMainMenu; Source: TMenuItem; Rebuild: Boolean);\r\nbegin\r\n if Assigned(FOnChange) then\r\n FOnChange(Sender, Source, Rebuild);\r\nend;\r\n\r\n//=== { TJvMainMenu } ========================================================\r\n\r\nconstructor TJvMainMenu.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n inherited OwnerDraw := True;\r\n\r\n RegisterWndProcHook(FindForm, NewWndProc, hoAfterMsg);\r\n FStyle := msStandard;\r\n FStyleItemPainter := CreateMenuItemPainterFromStyle(FStyle, Self);\r\n FChangeLinks := TObjectList.Create(False);\r\n\r\n FImageMargin := TJvImageMargin.Create;\r\n FImageMargin.OnChange := ImageMarginChange;\r\n\r\n FImageSize := TJvMenuImageSize.Create;\r\n FImageSize.OnChange := ImageSizeChange;\r\n\r\n FImageChangeLink := TChangeLink.Create;\r\n FImageChangeLink.OnChange := ImageListChange;\r\n\r\n FDisabledImageChangeLink := TChangeLink.Create;\r\n FDisabledImageChangeLink.OnChange := DisabledImageListChange;\r\n\r\n FHotImageChangeLink := TChangeLink.Create;\r\n FHotImageChangeLink.OnChange := HotImageListChange;\r\n\r\n // set default values that are not 0\r\n FTextVAlignment := vaMiddle;\r\nend;\r\n\r\ndestructor TJvMainMenu.Destroy;\r\nbegin\r\n FImageChangeLink.Free;\r\n FHotImageChangeLink.Free;\r\n FDisabledImageChangeLink.Free;\r\n FStyleItemPainter.Free;\r\n FImageMargin.Free;\r\n FImageSize.Free;\r\n UnregisterWndProcHook(FindForm, NewWndProc, hoAfterMsg);\r\n inherited Destroy;\r\n\r\n // Mantis 4518: When removing the menu, the inherited Destroy will destroy\r\n // every item in turn. This will call MenuChanged which uses FChangeLinks,\r\n // hence the need to free it after the inherited destroy has run.\r\n // Note that testing csDestroying in ComponentState is not desirable as\r\n // the menu could be destroyed at design time and still should notify the\r\n // components that registered to be notified.\r\n FChangeLinks.Free;\r\nend;\r\n\r\nprocedure TJvMainMenu.Loaded;\r\nbegin\r\n inherited Loaded;\r\n if IsOwnerDrawMenu then\r\n RefreshMenu(True);\r\nend;\r\n\r\nfunction TJvMainMenu.GetCanvas: TCanvas;\r\nbegin\r\n Result := FCanvas;\r\nend;\r\n\r\nfunction TJvMainMenu.IsOwnerDrawMenu: Boolean;\r\nbegin\r\n Result := True; //(FStyle <> msStandard) or (Assigned(FImages) and (FImages.Count > 0));\r\nend;\r\n\r\nprocedure TJvMainMenu.MenuChanged(Sender: TObject; Source: TMenuItem; Rebuild: Boolean);\r\nvar\r\n I: Integer;\r\nbegin\r\n if csLoading in ComponentState then\r\n Exit;\r\n for I := 0 to FChangeLinks.Count - 1 do\r\n TJvMenuChangeLink(FChangeLinks[I]).Change(Self, Source, Rebuild);\r\n inherited MenuChanged(Sender, Source, Rebuild);\r\nend;\r\n\r\nprocedure TJvMainMenu.Notification(AComponent: TComponent; Operation: TOperation);\r\nbegin\r\n inherited Notification(AComponent, Operation);\r\n if Operation = opRemove then\r\n begin\r\n if AComponent = FImages then\r\n SetImages(nil);\r\n if AComponent = FDisabledImages then\r\n SetDisabledImages(nil);\r\n if AComponent = FHotImages then\r\n SetHotImages(nil);\r\n if AComponent = FItemPainter then\r\n ItemPainter := nil;\r\n end;\r\nend;\r\n\r\nprocedure TJvMainMenu.ImageListChange(Sender: TObject);\r\nbegin\r\n if Sender = FImages then\r\n RefreshMenu(IsOwnerDrawMenu);\r\nend;\r\n\r\nprocedure TJvMainMenu.ImageMarginChange(Sender: TObject);\r\nbegin\r\n Rebuild;\r\nend;\r\n\r\nprocedure TJvMainMenu.ImageSizeChange(Sender: TObject);\r\nbegin\r\n Rebuild;\r\nend;\r\n\r\nprocedure TJvMainMenu.SetImages(Value: TCustomImageList);\r\nvar\r\n OldOwnerDraw: Boolean;\r\nbegin\r\n OldOwnerDraw := IsOwnerDrawMenu;\r\n ReplaceImageListReference(Self, Value, FImages, FImageChangeLink);\r\n\r\n if IsOwnerDrawMenu <> OldOwnerDraw then\r\n RefreshMenu(not OldOwnerDraw);\r\n\r\n // To be used in a standard (non JV) toolbar and to have the editor show\r\n // the images in the ImageIndex property of the menu items\r\n inherited Images := Value;\r\nend;\r\n\r\nprocedure TJvMainMenu.DisabledImageListChange(Sender: TObject);\r\nbegin\r\n if Sender = FDisabledImages then\r\n RefreshMenu(IsOwnerDrawMenu);\r\nend;\r\n\r\nprocedure TJvMainMenu.SetDisabledImages(Value: TCustomImageList);\r\nvar\r\n OldOwnerDraw: Boolean;\r\nbegin\r\n OldOwnerDraw := IsOwnerDrawMenu;\r\n\r\n ReplaceImageListReference(Self, Value, FDisabledImages, FDisabledImageChangeLink);\r\n\r\n if IsOwnerDrawMenu <> OldOwnerDraw then\r\n RefreshMenu(not OldOwnerDraw);\r\nend;\r\n\r\nprocedure TJvMainMenu.HotImageListChange(Sender: TObject);\r\nbegin\r\n if Sender = FHotImages then\r\n RefreshMenu(IsOwnerDrawMenu);\r\nend;\r\n\r\nprocedure TJvMainMenu.SetHotImages(Value: TCustomImageList);\r\nvar\r\n OldOwnerDraw: Boolean;\r\nbegin\r\n OldOwnerDraw := IsOwnerDrawMenu;\r\n ReplaceImageListReference(Self, Value, FHotImages, FHotImageChangeLink);\r\n if IsOwnerDrawMenu <> OldOwnerDraw then\r\n RefreshMenu(not OldOwnerDraw);\r\nend;\r\n\r\nprocedure TJvMainMenu.SetStyle(Value: TJvMenuStyle);\r\nbegin\r\n if FStyle <> Value then\r\n begin\r\n // store the new style\r\n FStyle := Value;\r\n // delete the old painter and create a new internal painter\r\n // according to the style, but only if the style is not\r\n // msItemPainter\r\n if (Style <> msItemPainter) or (ItemPainter = nil) then\r\n begin\r\n ItemPainter := nil;\r\n FStyleItemPainter.Free;\r\n FStyleItemPainter := CreateMenuItemPainterFromStyle(Value, Self);\r\n end;\r\n // refresh\r\n RefreshMenu(IsOwnerDrawMenu);\r\n end;\r\nend;\r\n\r\nfunction TJvMainMenu.FindForm: TWinControl;\r\nbegin\r\n Result := FindControl(WindowHandle);\r\n if (Result = nil) and (Owner is TWinControl) then\r\n Result := TWinControl(Owner);\r\nend;\r\n\r\nprocedure TJvMainMenu.Rebuild(ForceIfLoading: Boolean);\r\nvar\r\n DummyItem: TMenuItem;\r\nbegin\r\n if not ForceIfLoading and (csLoading in ComponentState) then\r\n Exit;\r\n\r\n // Ideally, we would like to call RebuildHandle in TMenuItem but this\r\n // method is private. As a result, we add and immediately remove a fake\r\n // item. This in turn triggers the call to RebuildHandle.\r\n DummyItem := TMenuItem.Create(nil);\r\n try\r\n Items.Add(DummyItem);\r\n Items.Remove(DummyItem);\r\n finally\r\n DummyItem.Free;\r\n end;\r\nend;\r\n\r\nprocedure TJvMainMenu.Refresh;\r\nbegin\r\n RefreshMenu(IsOwnerDrawMenu);\r\nend;\r\n\r\nprocedure TJvMainMenu.RefreshMenu(AOwnerDraw: Boolean);\r\nbegin\r\n Self.OwnerDraw := AOwnerDraw and not (csDesigning in ComponentState);\r\nend;\r\n\r\nprocedure TJvMainMenu.DefaultDrawItem(Item: TMenuItem; Rect: TRect;\r\n State: TMenuOwnerDrawState);\r\nbegin\r\n if Canvas.Handle <> 0 then\r\n begin\r\n GetActiveItemPainter.Menu := Self;\r\n GetActiveItemPainter.Paint(Item, Rect, State);\r\n end;\r\nend;\r\n\r\nprocedure TJvMainMenu.DrawItem(Item: TMenuItem; Rect: TRect;\r\n State: TMenuOwnerDrawState);\r\nbegin\r\n if Canvas.Handle <> 0 then\r\n begin\r\n GetActiveItemPainter.Menu := Self;\r\n GetActiveItemPainter.Paint(Item, Rect, State);\r\n end;\r\nend;\r\n\r\nprocedure TJvMainMenu.RegisterChanges(ChangeLink: TJvMenuChangeLink);\r\nbegin\r\n FChangeLinks.Add(ChangeLink);\r\nend;\r\n\r\nprocedure TJvMainMenu.UnregisterChanges(ChangeLink: TJvMenuChangeLink);\r\nbegin\r\n FChangeLinks.Remove(ChangeLink);\r\nend;\r\n\r\nprocedure TJvMainMenu.MeasureItem(Item: TMenuItem; var Width, Height: Integer);\r\nbegin\r\n if Assigned(FOnMeasureItem) then\r\n FOnMeasureItem(Self, Item, Width, Height)\r\nend;\r\n\r\n{procedure TJvMainMenu.WndMessage(Sender: TObject; var AMsg: TMessage;\r\n var Handled: Boolean);\r\nbegin\r\n if IsOwnerDrawMenu then\r\n MenuWndMessage(Self, AMsg, Handled);\r\nend;}\r\n\r\nfunction TJvMainMenu.NewWndProc(var Msg: TMessage): Boolean;\r\nvar\r\n Handled: Boolean;\r\nbegin\r\n if IsOwnerDrawMenu then\r\n MenuWndMessage(Self, Msg, Handled);\r\n // let others listen in too...\r\n Result := False; //handled;\r\nend;\r\n\r\nprocedure TJvMainMenu.GetItemParams(Item: TMenuItem; State: TMenuOwnerDrawState;\r\n AFont: TFont; var Color: TColor; var Graphic: TGraphic; var NumGlyphs: Integer);\r\nbegin\r\n if Assigned(FOnGetItemParams) then\r\n FOnGetItemParams(Self, Item, State, AFont, Color, Graphic, NumGlyphs);\r\n if (Item <> nil) and (Item.Caption = Separator) then\r\n Graphic := nil;\r\nend;\r\n\r\nprocedure TJvMainMenu.GetImageIndex(Item: TMenuItem; State: TMenuOwnerDrawState;\r\n var ImageIndex: Integer);\r\nbegin\r\n if Assigned(FImages) and (Item <> nil) and (Item.Caption <> Separator) and\r\n Assigned(FOnGetImageIndex) then\r\n FOnGetImageIndex(Self, Item, State, ImageIndex);\r\nend;\r\n\r\nprocedure TJvMainMenu.CMMenuChanged(var Msg: TMessage);\r\nbegin\r\n inherited;\r\nend;\r\n\r\nprocedure TJvMainMenu.WMDrawItem(var Msg: TWMDrawItem);\r\nvar\r\n State: TMenuOwnerDrawState;\r\n SaveIndex: Integer;\r\n Item: TMenuItem;\r\nbegin\r\n with Msg.DrawItemStruct^ do\r\n begin\r\n State := TMenuOwnerDrawState(WordRec(LongRec(itemState).Lo).Lo);\r\n {if (mdDisabled in State) then\r\n State := State - [mdSelected];}\r\n Item := TMenuItem(Pointer(itemData));\r\n if Assigned(Item) and\r\n (FindItem(Item.Command, fkCommand) = Item) then\r\n begin\r\n FCanvas := TControlCanvas.Create;\r\n try\r\n SaveIndex := SaveDC(hDC);\r\n try\r\n Canvas.Handle := hDC;\r\n SetDefaultMenuFont(Canvas.Font);\r\n Canvas.Font.Color := clMenuText;\r\n Canvas.Brush.Color := clMenu;\r\n if mdDefault in State then\r\n Canvas.Font.Style := Canvas.Font.Style + [fsBold];\r\n if (mdSelected in State) and not\r\n (Style in [msBtnLowered, msBtnRaised]) then\r\n begin\r\n Canvas.Brush.Color := clHighlight;\r\n Canvas.Font.Color := clHighlightText;\r\n end;\r\n IntersectClipRect(Canvas.Handle, rcItem.Left, rcItem.Top, rcItem.Right, rcItem.Bottom);\r\n DrawItem(Item, rcItem, State);\r\n Canvas.Handle := 0;\r\n finally\r\n RestoreDC(hDC, SaveIndex);\r\n end;\r\n finally\r\n Canvas.Free;\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvMainMenu.WMMeasureItem(var Msg: TWMMeasureItem);\r\nvar\r\n Item: TMenuItem;\r\n SaveIndex: Integer;\r\n DC: HDC;\r\nbegin\r\n with Msg.MeasureItemStruct^ do\r\n begin\r\n Item := FindItem(itemID, fkCommand);\r\n if Assigned(Item) then\r\n begin\r\n DC := GetWindowDC(0);\r\n try\r\n FCanvas := TControlCanvas.Create;\r\n try\r\n SaveIndex := SaveDC(DC);\r\n try\r\n FCanvas.Handle := DC;\r\n FCanvas.Font := Screen.MenuFont;\r\n if Item.Default then\r\n Canvas.Font.Style := Canvas.Font.Style + [fsBold];\r\n GetActiveItemPainter.Menu := Self;\r\n GetActiveItemPainter.Measure(Item, Integer(itemWidth), Integer(itemHeight));\r\n //MeasureItem(Item, Integer(itemWidth), Integer(itemHeight));\r\n finally\r\n FCanvas.Handle := 0;\r\n RestoreDC(DC, SaveIndex);\r\n end;\r\n finally\r\n Canvas.Free;\r\n end;\r\n finally\r\n ReleaseDC(0, DC);\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvMainMenu.WMMenuSelect(var Msg: TWMMenuSelect);\r\nvar\r\n MenuItem: TMenuItem;\r\n FindKind: TFindItemKind;\r\n MenuID: Integer;\r\nbegin\r\n if FCursor <> crDefault then\r\n with Msg do\r\n begin\r\n FindKind := fkCommand;\r\n if MenuFlag and MF_POPUP <> 0 then\r\n begin\r\n FindKind := fkHandle;\r\n MenuID := GetSubMenu(Menu, IDItem);\r\n end\r\n else\r\n MenuID := IDItem;\r\n MenuItem := TMenuItem(FindItem(MenuID, FindKind));\r\n if (MenuItem <> nil) and (IsItemPopup(MenuItem) or (MenuItem.Count = 0)) and\r\n (MenuFlag and MF_HILITE <> 0) then\r\n SetCursor(Screen.Cursors[FCursor])\r\n else\r\n SetCursor(Screen.Cursors[crDefault]);\r\n end;\r\nend;\r\n\r\nprocedure TJvMainMenu.SetItemPainter(const Value: TJvCustomMenuItemPainter);\r\nbegin\r\n if Value <> FItemPainter then\r\n begin\r\n // Remove menu from current item painter\r\n if FItemPainter <> nil then\r\n begin\r\n FItemPainter.RemoveFreeNotification(Self);\r\n FItemPainter.Menu := nil;\r\n end;\r\n\r\n // set value and if not nil, setup the painter correctly\r\n FItemPainter := Value;\r\n if FItemPainter <> nil then\r\n begin\r\n Style := msItemPainter;\r\n FItemPainter.FreeNotification(Self);\r\n FItemPainter.Menu := Self;\r\n end\r\n else\r\n Style := msStandard;\r\n Refresh;\r\n end;\r\nend;\r\n\r\nfunction TJvMainMenu.GetActiveItemPainter: TJvCustomMenuItemPainter;\r\nbegin\r\n if (Style = msItemPainter) and (ItemPainter <> nil) then\r\n Result := ItemPainter\r\n else\r\n Result := FStyleItemPainter;\r\nend;\r\n\r\n//=== { TJvPopupList } =======================================================\r\n\r\ntype\r\n TJvPopupList = class(TList)\r\n private\r\n procedure WndProc(var Message: TMessage);\r\n public\r\n Window: HWND;\r\n procedure Add(Popup: TPopupMenu);\r\n procedure Remove(Popup: TPopupMenu);\r\n end;\r\n\r\nvar\r\n PopupList: TJvPopupList = nil;\r\n\r\nprocedure TJvPopupList.WndProc(var Message: TMessage);\r\nvar\r\n I: Integer;\r\n MenuItem: TMenuItem;\r\n FindKind: TFindItemKind;\r\n ContextID: Integer;\r\n Handled: Boolean;\r\nbegin\r\n try\r\n case Message.Msg of\r\n WM_MEASUREITEM, WM_DRAWITEM:\r\n for I := 0 to Count - 1 do\r\n begin\r\n Handled := False;\r\n TJvPopupMenu(Items[I]).WndMessage(nil, Message, Handled);\r\n if Handled then\r\n Exit;\r\n end;\r\n WM_COMMAND:\r\n for I := 0 to Count - 1 do\r\n if TJvPopupMenu(Items[I]).DispatchCommand(Message.WParam) then\r\n Exit;\r\n WM_INITMENUPOPUP:\r\n for I := 0 to Count - 1 do\r\n with TWMInitMenuPopup(Message) do\r\n if TJvPopupMenu(Items[I]).DispatchPopup(MenuPopup) then\r\n Exit;\r\n WM_MENUSELECT:\r\n with TWMMenuSelect(Message) do\r\n begin\r\n FindKind := fkCommand;\r\n if MenuFlag and MF_POPUP <> 0 then\r\n begin\r\n FindKind := fkHandle;\r\n ContextID := GetSubMenu(Menu, IDItem);\r\n end\r\n else\r\n ContextID := IDItem;\r\n for I := 0 to Count - 1 do\r\n begin\r\n MenuItem := TJvPopupMenu(Items[I]).FindItem(ContextID, FindKind);\r\n if MenuItem <> nil then\r\n begin\r\n Application.Hint := MenuItem.Hint;\r\n with TJvPopupMenu(Items[I]) do\r\n if FCursor <> crDefault then\r\n if (MenuFlag and MF_HILITE <> 0) then\r\n SetCursor(Screen.Cursors[FCursor])\r\n else\r\n SetCursor(Screen.Cursors[crDefault]);\r\n Exit;\r\n end;\r\n end;\r\n Application.Hint := '';\r\n end;\r\n WM_MENUCHAR:\r\n for I := 0 to Count - 1 do\r\n with TJvPopupMenu(Items[I]) do\r\n if (Handle = HMenu(Message.LParam)) or\r\n (FindItem(Message.LParam, fkHandle) <> nil) then\r\n begin\r\n ProcessMenuChar(TWMMenuChar(Message));\r\n Exit;\r\n end;\r\n WM_HELP:\r\n with PHelpInfo(Message.LParam)^ do\r\n begin\r\n for I := 0 to Count - 1 do\r\n if TJvPopupMenu(Items[I]).Handle = hItemHandle then\r\n begin\r\n ContextID := TMenu(Items[I]).GetHelpContext(iCtrlID, True);\r\n if ContextID = 0 then\r\n ContextID := TMenu(Items[I]).GetHelpContext(hItemHandle, False);\r\n if Screen.ActiveForm = nil then\r\n Exit;\r\n if (biHelp in Screen.ActiveForm.BorderIcons) then\r\n Application.HelpCommand(HELP_CONTEXTPOPUP, ContextID)\r\n else\r\n Application.HelpContext(ContextID);\r\n Exit;\r\n end;\r\n end;\r\n end;\r\n with Message do\r\n Result := DefWindowProc(Window, Msg, WParam, LParam);\r\n except\r\n Application.HandleException(Self);\r\n end;\r\nend;\r\n\r\nprocedure TJvPopupList.Add(Popup: TPopupMenu);\r\nbegin\r\n if Count = 0 then\r\n Window := AllocateHWnd(WndProc);\r\n inherited Add(Popup);\r\nend;\r\n\r\nprocedure TJvPopupList.Remove(Popup: TPopupMenu);\r\nbegin\r\n inherited Remove(Popup);\r\n if Count = 0 then\r\n DeallocateHWnd(Window);\r\nend;\r\n\r\n//=== { TJvPopupMenu } =======================================================\r\n\r\nconstructor TJvPopupMenu.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n if PopupList = nil then\r\n PopupList := TJvPopupList.Create;\r\n FStyle := msStandard;\r\n FStyleItemPainter := CreateMenuItemPainterFromStyle(FStyle, Self);\r\n FCursor := crDefault;\r\n FImageMargin := TJvImageMargin.Create;\r\n FImageMargin.OnChange := ImageMarginChange;\r\n\r\n FImageSize := TJvMenuImageSize.Create;\r\n FImageSize.OnChange := ImageSizeChange;\r\n\r\n PopupList.Add(Self);\r\n\r\n FImageChangeLink := TChangeLink.Create;\r\n FImageChangeLink.OnChange := ImageListChange;\r\n\r\n FDisabledImageChangeLink := TChangeLink.Create;\r\n FDisabledImageChangeLink.OnChange := DisabledImageListChange;\r\n\r\n FHotImageChangeLink := TChangeLink.Create;\r\n FHotImageChangeLink.OnChange := HotImageListChange;\r\n\r\n SetPopupPoint(Point(-1, -1));\r\n\r\n // Set default values that are not 0\r\n FTextVAlignment := vaMiddle;\r\nend;\r\n\r\ndestructor TJvPopupMenu.Destroy;\r\nbegin\r\n FImageChangeLink.Free;\r\n FDisabledImageChangeLink.Free;\r\n FHotImageChangeLink.Free;\r\n FImageMargin.Free;\r\n FImageSize.Free;\r\n FStyleItemPainter.Free;\r\n\r\n // This test is only False if finalization is called before destroy.\r\n // An example of this happening is when using TJvAppInstances\r\n if Assigned(PopupList) then\r\n PopupList.Remove(Self);\r\n\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvPopupMenu.Loaded;\r\nbegin\r\n inherited Loaded;\r\n if IsOwnerDrawMenu then\r\n RefreshMenu(True);\r\nend;\r\n\r\nfunction TJvPopupMenu.GetCanvas: TCanvas;\r\nbegin\r\n Result := FCanvas;\r\nend;\r\n\r\nprocedure TJvPopupMenu.Notification(AComponent: TComponent; Operation: TOperation);\r\nbegin\r\n inherited Notification(AComponent, Operation);\r\n if Operation = opRemove then\r\n begin\r\n if AComponent = FImages then\r\n SetImages(nil);\r\n if AComponent = FDisabledImages then\r\n SetDisabledImages(nil);\r\n if AComponent = FHotImages then\r\n SetHotImages(nil);\r\n if AComponent = FItemPainter then\r\n ItemPainter := nil;\r\n end;\r\nend;\r\n\r\nprocedure TJvPopupMenu.ImageListChange(Sender: TObject);\r\nbegin\r\n if Sender = FImages then\r\n RefreshMenu(IsOwnerDrawMenu);\r\nend;\r\n\r\nprocedure TJvPopupMenu.ImageMarginChange(Sender: TObject);\r\nbegin\r\n Rebuild;\r\nend;\r\n\r\nprocedure TJvPopupMenu.ImageSizeChange(Sender: TObject);\r\nbegin\r\n Rebuild;\r\nend;\r\n\r\nprocedure TJvPopupMenu.SetImages(Value: TCustomImageList);\r\nvar\r\n OldOwnerDraw: Boolean;\r\nbegin\r\n OldOwnerDraw := IsOwnerDrawMenu;\r\n ReplaceImageListReference(Self, Value, FImages, FImageChangeLink);\r\n if IsOwnerDrawMenu <> OldOwnerDraw then\r\n RefreshMenu(not OldOwnerDraw);\r\n\r\n // To have the editor show the images in the ImageIndex property of\r\n // the menu items\r\n inherited Images := Value;\r\nend;\r\n\r\nprocedure TJvPopupMenu.DisabledImageListChange(Sender: TObject);\r\nbegin\r\n if Sender = FDisabledImages then\r\n RefreshMenu(IsOwnerDrawMenu);\r\nend;\r\n\r\nprocedure TJvPopupMenu.SetDisabledImages(Value: TCustomImageList);\r\nvar\r\n OldOwnerDraw: Boolean;\r\nbegin\r\n OldOwnerDraw := IsOwnerDrawMenu;\r\n ReplaceImageListReference(Self, Value, FDisabledImages, FDisabledImageChangeLink);\r\n if IsOwnerDrawMenu <> OldOwnerDraw then\r\n RefreshMenu(not OldOwnerDraw);\r\nend;\r\n\r\nprocedure TJvPopupMenu.HotImageListChange(Sender: TObject);\r\nbegin\r\n if Sender = FHotImages then\r\n RefreshMenu(IsOwnerDrawMenu);\r\nend;\r\n\r\nprocedure TJvPopupMenu.SetHotImages(Value: TCustomImageList);\r\nvar\r\n OldOwnerDraw: Boolean;\r\nbegin\r\n OldOwnerDraw := IsOwnerDrawMenu;\r\n ReplaceImageListReference(Self, Value, FHotImages, FHotImageChangeLink);\r\n if IsOwnerDrawMenu <> OldOwnerDraw then\r\n RefreshMenu(not OldOwnerDraw);\r\nend;\r\n\r\nfunction FindPopupControl(const Pos: TPoint): TControl;\r\nvar\r\n Window: TWinControl;\r\nbegin\r\n Result := nil;\r\n Window := FindVCLWindow(Pos);\r\n if Window <> nil then\r\n begin\r\n Result := Window.ControlAtPos(Pos, False);\r\n if Result = nil then\r\n Result := Window;\r\n end;\r\nend;\r\n\r\n{$IFNDEF COMPILER9_UP}\r\ntype\r\n TPopupMenuPrivate = class(TMenu)\r\n public\r\n FPopupPoint: TPoint;\r\n end;\r\n\r\nprocedure TJvPopupMenu.SetPopupPoint(const Pt: TPoint);\r\nbegin\r\n TPopupMenuPrivate(Self).FPopupPoint := Pt;\r\nend;\r\n{$ENDIF !COMPILER9_UP}\r\n\r\nprocedure TJvPopupMenu.SetBiDiModeFromPopupControl;\r\nvar\r\n AControl: TControl;\r\nbegin\r\n if not SysLocale.MiddleEast then\r\n Exit;\r\n if FParentBiDiMode then\r\n begin\r\n AControl := FindPopupControl(PopupPoint);\r\n if AControl <> nil then\r\n BiDiMode := AControl.BiDiMode\r\n else\r\n BiDiMode := Application.BiDiMode;\r\n end;\r\nend;\r\n\r\nfunction TJvPopupMenu.UseRightToLeftAlignment: Boolean;\r\nvar\r\n AControl: TControl;\r\nbegin\r\n Result := False;\r\n if not SysLocale.MiddleEast then\r\n Exit;\r\n if FParentBiDiMode then\r\n begin\r\n AControl := FindPopupControl(PopupPoint);\r\n if AControl <> nil then\r\n Result := AControl.UseRightToLeftAlignment\r\n else\r\n Result := Application.UseRightToLeftAlignment;\r\n end\r\n else\r\n Result := (BiDiMode <> bdLeftToRight);\r\nend;\r\n\r\nprocedure TJvPopupMenu.Popup(X, Y: Integer);\r\nconst\r\n Flags: array[Boolean, TPopupAlignment] of Word =\r\n ((TPM_LEFTALIGN, TPM_RIGHTALIGN, TPM_CENTERALIGN),\r\n (TPM_RIGHTALIGN, TPM_LEFTALIGN, TPM_CENTERALIGN));\r\n Buttons: array[TTrackButton] of Word =\r\n (TPM_RIGHTBUTTON, TPM_LEFTBUTTON);\r\nbegin\r\n SetPopupPoint(Point(X, Y));\r\n FParentBiDiMode := ParentBiDiMode;\r\n try\r\n SetBiDiModeFromPopupControl;\r\n DoPopup(Self);\r\n if IsOwnerDrawMenu then\r\n RefreshMenu(True);\r\n\r\n // Those three lines are as close as we can get to the orignal source\r\n // code in the VCL. Note that for the \"Items.Handle\" line, it seems\r\n // it does nothing as it does not store the property value, but there is\r\n // a getter on that property and will eventually make a series of calls\r\n // that are close enough to RebuildHandle.\r\n // This is required to fix Mantis 3029, this bug having appeared following\r\n // the change of value of SysLocal.MiddleEast which is always True when\r\n // a program compiled in D2005 or upper is run on Windows XP or upper.\r\n Items.RethinkHotkeys;\r\n Items.RethinkLines;\r\n Items.Handle;\r\n\r\n AdjustBiDiBehavior;\r\n TrackPopupMenu(Items.Handle,\r\n Flags[UseRightToLeftAlignment, Alignment] or Buttons[TrackButton], X, Y,\r\n 0 { reserved }, PopupList.Window, nil);\r\n finally\r\n ParentBiDiMode := FParentBiDiMode;\r\n end;\r\nend;\r\n\r\nprocedure TJvPopupMenu.Refresh;\r\nbegin\r\n RefreshMenu(IsOwnerDrawMenu);\r\nend;\r\n\r\nfunction TJvPopupMenu.IsOwnerDrawMenu: Boolean;\r\nbegin\r\n Result := (FStyle <> msStandard) or (Assigned(FImages) and (FImages.Count > 0));\r\nend;\r\n\r\nprocedure TJvPopupMenu.RefreshMenu(AOwnerDraw: Boolean);\r\nbegin\r\n Self.OwnerDraw := AOwnerDraw and not (csDesigning in ComponentState);\r\nend;\r\n\r\nprocedure TJvPopupMenu.SetStyle(Value: TJvMenuStyle);\r\nbegin\r\n if FStyle <> Value then\r\n begin\r\n FStyle := Value;\r\n\r\n // delete the old painter and create a new internal painter\r\n // according to the style, but only if the style is not\r\n // msItemPainter\r\n if Style <> msItemPainter then\r\n begin\r\n ItemPainter := nil;\r\n FStyleItemPainter.Free;\r\n FStyleItemPainter := CreateMenuItemPainterFromStyle(Value, Self);\r\n end;\r\n\r\n RefreshMenu(IsOwnerDrawMenu);\r\n end;\r\nend;\r\n\r\n{$WARNINGS OFF} // prevent compiler from showing the deprecated warning in Delphi 6\r\nprocedure TJvPopupMenu.DefaultDrawItem(Item: TMenuItem; Rect: TRect;\r\n State: TMenuOwnerDrawState);\r\n{$WARNINGS ON}\r\nbegin\r\n DrawItem(Item, Rect, State)\r\nend;\r\n\r\nprocedure TJvPopupMenu.DrawItem(Item: TMenuItem; Rect: TRect;\r\n State: TMenuOwnerDrawState);\r\nbegin\r\n if Canvas.Handle <> 0 then\r\n begin\r\n GetActiveItemPainter.Menu := Self;\r\n GetActiveItemPainter.Paint(Item, Rect, State);\r\n end;\r\nend;\r\n\r\nprocedure TJvPopupMenu.MeasureItem(Item: TMenuItem; var Width, Height: Integer);\r\nbegin\r\n if Assigned(FOnMeasureItem) then\r\n FOnMeasureItem(Self, Item, Width, Height)\r\nend;\r\n\r\nprocedure TJvPopupMenu.WndMessage(Sender: TObject; var AMsg: TMessage;\r\n var Handled: Boolean);\r\nbegin\r\n if IsOwnerDrawMenu then\r\n MenuWndMessage(Self, AMsg, Handled);\r\nend;\r\n\r\nprocedure TJvPopupMenu.GetItemParams(Item: TMenuItem; State: TMenuOwnerDrawState;\r\n AFont: TFont; var Color: TColor; var Graphic: TGraphic; var NumGlyphs: Integer);\r\nbegin\r\n if Assigned(FOnGetItemParams) then\r\n FOnGetItemParams(Self, Item, State, AFont, Color, Graphic, NumGlyphs);\r\n if (Item <> nil) and (Item.Caption = Separator) then\r\n Graphic := nil;\r\nend;\r\n\r\nprocedure TJvPopupMenu.GetImageIndex(Item: TMenuItem; State: TMenuOwnerDrawState;\r\n var ImageIndex: Integer);\r\nbegin\r\n if Assigned(FImages) and (Item <> nil) and (Item.Caption <> Separator) and\r\n Assigned(FOnGetImageIndex) then\r\n FOnGetImageIndex(Self, Item, State, ImageIndex);\r\nend;\r\n\r\nprocedure TJvPopupMenu.WMDrawItem(var Msg: TWMDrawItem);\r\nvar\r\n State: TMenuOwnerDrawState;\r\n SaveIndex: Integer;\r\n Item: TMenuItem;\r\n // MarginRect: TRect;\r\nbegin\r\n with Msg.DrawItemStruct^ do\r\n begin\r\n State := TMenuOwnerDrawState(WordRec(LongRec(itemState).Lo).Lo);\r\n Item := TMenuItem(Pointer(itemData));\r\n if Assigned(Item) and\r\n (FindItem(Item.Command, fkCommand) = Item) then\r\n begin\r\n FCanvas := TControlCanvas.Create;\r\n try\r\n SaveIndex := SaveDC(hDC);\r\n try\r\n Canvas.Handle := hDC;\r\n SetDefaultMenuFont(Canvas.Font);\r\n Canvas.Font.Color := clMenuText;\r\n Canvas.Brush.Color := clMenu;\r\n if mdDefault in State then\r\n Canvas.Font.Style := Canvas.Font.Style + [fsBold];\r\n if (mdSelected in State) and\r\n not (Style in [msBtnLowered, msBtnRaised]) then\r\n begin\r\n Canvas.Brush.Color := clHighlight;\r\n Canvas.Font.Color := clHighlightText;\r\n end;\r\n IntersectClipRect(Canvas.Handle, rcItem.Left, rcItem.Top, rcItem.Right, rcItem.Bottom);\r\n DrawItem(Item, rcItem, State);\r\n Canvas.Handle := 0;\r\n finally\r\n RestoreDC(hDC, SaveIndex);\r\n end;\r\n finally\r\n Canvas.Free;\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvPopupMenu.WMMeasureItem(var Msg: TWMMeasureItem);\r\nvar\r\n Item: TMenuItem;\r\n SaveIndex: Integer;\r\n DC: HDC;\r\nbegin\r\n with Msg.MeasureItemStruct^ do\r\n begin\r\n Item := FindItem(itemID, fkCommand);\r\n if Assigned(Item) then\r\n begin\r\n DC := GetWindowDC(0);\r\n try\r\n FCanvas := TControlCanvas.Create;\r\n try\r\n SaveIndex := SaveDC(DC);\r\n try\r\n FCanvas.Handle := DC;\r\n FCanvas.Font := Screen.MenuFont;\r\n if Item.Default then\r\n Canvas.Font.Style := Canvas.Font.Style + [fsBold];\r\n GetActiveItemPainter.Menu := Self;\r\n GetActiveItemPainter.Measure(Item, Integer(itemWidth), Integer(itemHeight));\r\n //MeasureItem(Item, Integer(itemWidth), Integer(itemHeight));\r\n finally\r\n FCanvas.Handle := 0;\r\n RestoreDC(DC, SaveIndex);\r\n end;\r\n finally\r\n Canvas.Free;\r\n end;\r\n finally\r\n ReleaseDC(0, DC);\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvPopupMenu.Assign(Source: TPersistent);\r\nbegin\r\n if Source is TJvPopupMenu then\r\n begin\r\n AutoHotkeys := TJvPopupMenu(Source).AutoHotkeys;\r\n AutoLineReduction := TJvPopupMenu(Source).AutoLineReduction;\r\n BiDiMode := TJvPopupMenu(Source).BiDiMode;\r\n Cursor := TJvPopupMenu(Source).Cursor;\r\n DisabledImages := TJvPopupMenu(Source).DisabledImages;\r\n HotImages := TJvPopupMenu(Source).HotImages;\r\n ImageMargin.Assign(TJvPopupMenu(Source).ImageMargin);\r\n Images := TJvPopupMenu(Source).Images;\r\n ImageSize.Assign(TJvPopupMenu(Source).ImageSize);\r\n ParentBiDiMode := TJvPopupMenu(Source).ParentBiDiMode;\r\n ShowCheckMarks := TJvPopupMenu(Source).ShowCheckMarks;\r\n Style := TJvPopupMenu(Source).Style;\r\n Tag := TJvPopupMenu(Source).Tag;\r\n TextMargin := TJvPopupMenu(Source).TextMargin;\r\n TextVAlignment := TJvPopupMenu(Source).TextVAlignment;\r\n end\r\n else\r\n if Source is TJvMainMenu then\r\n begin\r\n AutoHotkeys := TJvMainMenu(Source).AutoHotkeys;\r\n AutoLineReduction := TJvMainMenu(Source).AutoLineReduction;\r\n BiDiMode := TJvMainMenu(Source).BiDiMode;\r\n Cursor := TJvMainMenu(Source).Cursor;\r\n DisabledImages := TJvMainMenu(Source).DisabledImages;\r\n HotImages := TJvMainMenu(Source).HotImages;\r\n ImageMargin.Assign(TJvMainMenu(Source).ImageMargin);\r\n Images := TJvMainMenu(Source).Images;\r\n ImageSize.Assign(TJvMainMenu(Source).ImageSize);\r\n ParentBiDiMode := TJvMainMenu(Source).ParentBiDiMode;\r\n ShowCheckMarks := TJvMainMenu(Source).ShowCheckMarks;\r\n Style := TJvMainMenu(Source).Style;\r\n Tag := TJvMainMenu(Source).Tag;\r\n TextMargin := TJvMainMenu(Source).TextMargin;\r\n TextVAlignment := TJvMainMenu(Source).TextVAlignment;\r\n end\r\n else\r\n inherited Assign(Source);\r\nend;\r\n\r\nprocedure TJvPopupMenu.ReadState(Reader: TReader);\r\nbegin\r\n // Reader.ReadComponent(FJvMenuItemPainter);\r\n inherited ReadState(Reader);\r\nend;\r\n\r\nprocedure TJvPopupMenu.Rebuild(ForceIfLoading: Boolean);\r\nvar\r\n DummyItem: TMenuItem;\r\nbegin\r\n if not ForceIfLoading and (csLoading in ComponentState) then\r\n Exit;\r\n\r\n // Ideally, we would like to call RebuildHandle in TMenuItem but this\r\n // method is private. As a result, we add and immediately remove a fake\r\n // item. This in turn triggers the call to RebuildHandle.\r\n DummyItem := TMenuItem.Create(nil);\r\n try\r\n Items.Add(DummyItem);\r\n Items.Remove(DummyItem);\r\n finally\r\n DummyItem.Free;\r\n end;\r\nend;\r\n\r\nprocedure TJvPopupMenu.WriteState(Writer: TWriter);\r\nbegin\r\n inherited WriteState(Writer);\r\n // Writer.WriteComponent(FJvMenuItemPainter);\r\nend;\r\n\r\nprocedure TJvPopupMenu.SetItemPainter(const Value: TJvCustomMenuItemPainter);\r\nbegin\r\n if Value <> FItemPainter then\r\n begin\r\n // Remove menu from current item painter\r\n if FItemPainter <> nil then\r\n FItemPainter.Menu := nil;\r\n\r\n ReplaceComponentReference(Self, Value, TComponent(FItemPainter));\r\n // set value and if not nil, setup the painter correctly\r\n if FItemPainter <> nil then\r\n begin\r\n Style := msItemPainter;\r\n FItemPainter.Menu := Self;\r\n end;\r\n Refresh;\r\n end;\r\nend;\r\n\r\nfunction TJvPopupMenu.GetActiveItemPainter: TJvCustomMenuItemPainter;\r\nbegin\r\n if (Style = msItemPainter) and (ItemPainter <> nil) then\r\n Result := ItemPainter\r\n else\r\n Result := FStyleItemPainter;\r\nend;\r\n\r\n//=== { TJvCustomMenuItemPainter } ===========================================\r\n\r\nconstructor TJvCustomMenuItemPainter.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n\r\n // affect default values that are not 0\r\n FImageBackgroundColor := DefaultImageBackgroundColor;\r\n\r\n FImageMargin := TJvImageMargin.Create;\r\n FImageSize := TJvMenuImageSize.Create;\r\n FGlyph := TBitmap.Create;\r\nend;\r\n\r\ndestructor TJvCustomMenuItemPainter.Destroy;\r\nbegin\r\n FGlyph.Free;\r\n FImageSize.Free;\r\n FImageMargin.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvCustomMenuItemPainter.DrawDisabledBitmap(X, Y: Integer; Bitmap: TBitmap);\r\nvar\r\n Bmp: TBitmap;\r\n GrayColor, SaveColor: TColor;\r\n IsHighlight: Boolean;\r\nbegin\r\n if (mdSelected in FState) then\r\n GrayColor := clGrayText\r\n else\r\n GrayColor := clBtnShadow;\r\n IsHighlight := (not (mdSelected in FState)) or\r\n (GetNearestColor(Canvas.Handle, ColorToRGB(clGrayText)) =\r\n GetNearestColor(Canvas.Handle, ColorToRGB(clHighlight)));\r\n if Bitmap.Monochrome then\r\n begin\r\n SaveColor := Canvas.Brush.Color;\r\n try\r\n if IsHighlight then\r\n begin\r\n Canvas.Brush.Color := clBtnHighlight;\r\n SetTextColor(Canvas.Handle, clWhite);\r\n SetBkColor(Canvas.Handle, clBlack);\r\n BitBlt(Canvas.Handle, X + 1, Y + 1, Bitmap.Width, Bitmap.Height,\r\n Bitmap.Canvas.Handle, 0, 0, ROP_DSPDxax);\r\n end;\r\n Canvas.Brush.Color := GrayColor;\r\n SetTextColor(Canvas.Handle, clWhite);\r\n SetBkColor(Canvas.Handle, clBlack);\r\n BitBlt(Canvas.Handle, X, Y, Bitmap.Width, Bitmap.Height,\r\n Bitmap.Canvas.Handle, 0, 0, ROP_DSPDxax);\r\n finally\r\n Canvas.Brush.Color := SaveColor;\r\n end;\r\n end\r\n else\r\n begin\r\n Bmp := CreateDisabledBitmapEx(Bitmap, clBlack, clMenu,\r\n clBtnHighlight, GrayColor, IsHighlight);\r\n try\r\n DrawBitmapTransparent(Canvas, X, Y, Bmp, clMenu);\r\n finally\r\n Bmp.Free;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomMenuItemPainter.DrawMenuBitmap(X, Y: Integer; Bitmap: TBitmap);\r\nbegin\r\n if (mdDisabled in FState) and (FNumGlyphs < 2) then\r\n DrawDisabledBitmap(X, Y, Bitmap)\r\n else\r\n begin\r\n if Bitmap.Monochrome and (not FItem.Checked or ShowCheckMarks) then\r\n BitBlt(Canvas.Handle, X, Y, Bitmap.Width, Bitmap.Height,\r\n Bitmap.Canvas.Handle, 0, 0, SRCCOPY)\r\n else\r\n DrawBitmapTransparent(Canvas, X, Y, Bitmap, Bitmap.TransparentColor and not PaletteMask);\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomMenuItemPainter.DrawCheckImage(ARect: TRect);\r\nvar\r\n Bmp: TBitmap;\r\nbegin\r\n Bmp := TBitmap.Create;\r\n try\r\n with Bmp do\r\n begin\r\n Width := GetSystemMetrics(SM_CXMENUCHECK);\r\n Height := GetSystemMetrics(SM_CYMENUCHECK);\r\n end;\r\n if FItem.RadioItem then\r\n with Bmp do\r\n begin\r\n DrawFrameControl(Canvas.Handle, Bounds(0, 0, Width, Height),\r\n DFC_MENU, DFCS_MENUBULLET);\r\n Monochrome := True;\r\n Inc(ARect.Top); // the bullet must be shifted one pixel towards the bottom\r\n end\r\n else\r\n with Bmp do\r\n begin\r\n DrawFrameControl(Canvas.Handle, Bounds(0, 0, Width, Height),\r\n DFC_MENU, DFCS_MENUCHECK);\r\n Monochrome := True;\r\n end;\r\n case TextVAlignment of\r\n vaMiddle:\r\n Inc(ARect.Top, ((ARect.Bottom - ARect.Top + 1) - Bmp.Height) div 2);\r\n vaBottom:\r\n ARect.Top := ARect.Bottom - Bmp.Height;\r\n end;\r\n // draw the check mark bitmap, always centered horizontally\r\n DrawMenuBitmap(ARect.Left + (ARect.Right - ARect.Left + 1 - Bmp.Width) div 2,\r\n ARect.Top, Bmp);\r\n finally\r\n Bmp.Free;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomMenuItemPainter.DrawGlyphCheck(ARect: TRect);\r\nvar\r\n SaveColor: TColor;\r\n Bmp: TBitmap;\r\nbegin\r\n InflateRect(ARect, -1, -1);\r\n SaveColor := Canvas.Brush.Color;\r\n try\r\n if not (mdSelected in FState) then\r\n Bmp := AllocPatternBitmap(clMenu, clBtnHighlight)\r\n else\r\n Bmp := nil;\r\n try\r\n if Bmp <> nil then\r\n Canvas.Brush.Bitmap := Bmp\r\n else\r\n Canvas.Brush.Color := clMenu;\r\n Canvas.FillRect(ARect);\r\n finally\r\n Canvas.Brush.Bitmap := nil;\r\n end;\r\n finally\r\n Canvas.Brush.Color := SaveColor;\r\n end;\r\n Frame3D(Canvas, ARect, GrayColor, clBtnHighlight, 1);\r\nend;\r\n\r\nfunction TJvCustomMenuItemPainter.GetDisabledImages: TCustomImageList;\r\nbegin\r\n if Assigned(FMainMenu) then\r\n Result := FMainMenu.DisabledImages\r\n else\r\n if Assigned(FPopupMenu) then\r\n Result := FPopupMenu.DisabledImages\r\n else\r\n Result := nil;\r\nend;\r\n\r\nfunction TJvCustomMenuItemPainter.GetHotImages: TCustomImageList;\r\nbegin\r\n if Assigned(FMainMenu) then\r\n Result := FMainMenu.HotImages\r\n else\r\n if Assigned(FPopupMenu) then\r\n Result := FPopupMenu.HotImages\r\n else\r\n Result := nil;\r\nend;\r\n\r\nfunction TJvCustomMenuItemPainter.GetImages: TCustomImageList;\r\nvar\r\n Item: TMenuItem;\r\nbegin\r\n Item := FItem.Parent;\r\n while Assigned(Item) and not Assigned(Item.SubMenuImages) do\r\n Item := Item.Parent;\r\n\r\n if Assigned(Item) and Assigned(Item.SubMenuImages) then\r\n Result := TCustomImageList(Item.SubMenuImages)\r\n else\r\n if Assigned(FMainMenu) then\r\n Result := FMainMenu.Images\r\n else\r\n if Assigned(FPopupMenu) then\r\n Result := FPopupMenu.Images\r\n else\r\n Result := nil;\r\nend;\r\n\r\nfunction TJvCustomMenuItemPainter.GetShowCheckMarks: Boolean;\r\nbegin\r\n if Assigned(FMainMenu) then\r\n Result := FMainMenu.ShowCheckMarks\r\n else\r\n if Assigned(FPopupMenu) then\r\n Result := FPopupMenu.ShowCheckMarks\r\n else\r\n Result := False;\r\nend;\r\n\r\nfunction TJvCustomMenuItemPainter.UseImages: Boolean;\r\nbegin\r\n Result := Assigned(Images) and (FImageIndex >= 0) and\r\n (FImageIndex < Images.Count) and Images.HandleAllocated;\r\nend;\r\n\r\nfunction TJvCustomMenuItemPainter.UseHotImages: Boolean;\r\nbegin\r\n Result := Assigned(HotImages) and (FImageIndex >= 0) and\r\n (FImageIndex < HotImages.Count) and HotImages.HandleAllocated;\r\nend;\r\n\r\nfunction TJvCustomMenuItemPainter.UseDisabledImages: Boolean;\r\nbegin\r\n Result := Assigned(DisabledImages) and (FImageIndex >= 0) and\r\n (FImageIndex < DisabledImages.Count) and DisabledImages.HandleAllocated;\r\nend;\r\n\r\nprocedure TJvCustomMenuItemPainter.DrawItemText(ARect: TRect; const Text: string; Flags: Longint);\r\nbegin\r\n if Length(Text) = 0 then\r\n Exit;\r\n if (FParentMenu <> nil) and (FParentMenu.IsRightToLeft) then\r\n begin\r\n if Flags and DT_LEFT = DT_LEFT then\r\n Flags := Flags and (not DT_LEFT) or DT_RIGHT\r\n else\r\n if Flags and DT_RIGHT = DT_RIGHT then\r\n Flags := Flags and (not DT_RIGHT) or DT_LEFT;\r\n Flags := Flags or DT_RTLREADING;\r\n end;\r\n\r\n case TextVAlignment of\r\n vaMiddle:\r\n Inc(ARect.Top, ((ARect.Bottom - ARect.Top + 1) - Canvas.TextHeight(StripHotkeyPrefix(Text))) div 2);\r\n vaBottom:\r\n ARect.Top := ARect.Bottom - Canvas.TextHeight(StripHotkeyPrefix(Text));\r\n end;\r\n\r\n // if a top level menu item then draw text centered horizontally\r\n if not IsPopup(FItem) then\r\n ARect.Left := ARect.Left + ((ARect.Right - ARect.Left) - Canvas.TextWidth(StripHotkeyPrefix(Text))) div 2;\r\n\r\n if mdDisabled in FState then\r\n begin\r\n if DrawHighlight then\r\n begin\r\n Canvas.Font.Color := clBtnHighlight;\r\n OffsetRect(ARect, 1, 1);\r\n Windows.DrawText(Canvas.Handle, PChar(Text), Length(Text), ARect, Flags);\r\n OffsetRect(ARect, -1, -1);\r\n end;\r\n Canvas.Font.Color := GrayColor;\r\n end;\r\n Windows.DrawText(Canvas.Handle, PChar(Text), Length(Text), ARect, Flags)\r\nend;\r\n\r\nprocedure TJvCustomMenuItemPainter.PreparePaint(Item: TMenuItem;\r\n ItemRect: TRect; State: TMenuOwnerDrawState; Measure: Boolean);\r\nvar\r\n BackColor: TColor;\r\n Graphic: TGraphic;\r\n Bmp: TBitmap;\r\nbegin\r\n UpdateFieldsFromMenu;\r\n\r\n FItem := Item;\r\n FState := State;\r\n FImageIndex := FItem.ImageIndex;\r\n\r\n FGlyph.Assign(Item.Bitmap);\r\n BackColor := Canvas.Brush.Color;\r\n FNumGlyphs := 1;\r\n Graphic := nil;\r\n if Assigned(FMainMenu) then\r\n FMainMenu.GetItemParams(FItem, FState, Canvas.Font, BackColor, Graphic, FNumGlyphs)\r\n else\r\n if Assigned(FPopupMenu) then\r\n FPopupMenu.GetItemParams(FItem, FState, Canvas.Font, BackColor, Graphic, FNumGlyphs);\r\n if Assigned(Graphic) then\r\n FGlyph.Assign(Graphic);\r\n\r\n // Force glyph to fit inside its allocated space, if it's not empty and it\r\n // does not fit into the glyph allocated space\r\n if not FGlyph.Empty and\r\n ((ImageWidth <> FGlyph.Width * FNumGlyphs) or (ImageHeight <> FGlyph.Height)) then\r\n begin\r\n Bmp := TBitmap.Create;\r\n try\r\n Bmp.Width := ImageWidth * FNumGlyphs;\r\n Bmp.Height := ImageHeight;\r\n Bmp.Canvas.StretchDraw(Rect(0, 0, Bmp.Width, Bmp.Height), FGlyph);\r\n FGlyph.Width := Bmp.Width;\r\n FGlyph.Height := Bmp.Height;\r\n FGlyph.Canvas.Draw(0, 0, Bmp);\r\n finally\r\n Bmp.Free;\r\n end;\r\n end;\r\n\r\n if not Measure then\r\n begin\r\n if (BackColor <> clNone) then\r\n begin\r\n Canvas.Brush.Color := BackColor;\r\n Canvas.FillRect(ItemRect);\r\n end;\r\n end;\r\n\r\n if Assigned(FMainMenu) then\r\n FMainMenu.GetImageIndex(FItem, FState, FImageIndex)\r\n else\r\n if Assigned(FPopupMenu) then\r\n FPopupMenu.GetImageIndex(FItem, FState, FImageIndex);\r\nend;\r\n\r\nprocedure TJvCustomMenuItemPainter.Paint(Item: TMenuItem; ItemRect: TRect;\r\n State: TMenuOwnerDrawState);\r\nvar\r\n MaxWidth, I: Integer;\r\n Bmp: TBitmap;\r\n\r\n // the rect that will contain the size of the menu item caption\r\n CaptionRect: TRect;\r\n\r\n // The rect in which to draw the check mark for the item\r\n CheckMarkRect: TRect;\r\n\r\n // The rect in which to draw the image, with or without the image margins\r\n ImageRect: TRect;\r\n ImageAndMarginRect: TRect;\r\n\r\n // The rect in which to draw the text, with or without the margins\r\n TextRect: TRect;\r\n TextAndMarginRect: TRect;\r\n\r\n // The rect where the Left margin has to be drawn (its height is the height of the entire menu, not just the item)\r\n LeftMarginRect: TRect;\r\n\r\n // The item rect, whithout the left margin\r\n ItemRectNoLeftMargin: TRect;\r\n\r\n TmpWidth, TmpHeight : Integer;\r\nbegin\r\n // We must do this to prevent the code in Menus.pas from drawing\r\n // the item before us, thus trigerring rendering glitches, especially\r\n // when a top menuitem that has an image index not equal to -1\r\n Item.OnDrawItem := EmptyDrawItem;\r\n\r\n // calculate areas for the different parts of the item to be drawn\r\n if IsPopup(Item) then\r\n begin\r\n // As the margin is to be drawn for the entire height of the menu,\r\n // we need to retrieve its height.\r\n // There are multiple ways to do this:\r\n // 1. Get the canvas' associated window and take its size.\r\n // This does not work well under XP with shade/slide effects on as the\r\n // call to WindowFromDC often returns 0 (Mantis 3197).\r\n // 2. Measure every item in the menu.\r\n // This is very \"tedious\" and as such is only done when drawing the first\r\n // element. Note that this does not mean only once as the first element\r\n // will be redrawn as soon as its status changes.\r\n //\r\n // Solution 2 is then used as it offers the biggest reliability to retrieve\r\n // the menus total height and also allows to store if there is at least one\r\n // item with a checkmark shown.\r\n if {(LeftMargin > 0) and }Assigned(Item.Parent) and (Item = Item.Parent.Items[0]) then\r\n begin\r\n FMenuHeight := 0;\r\n FOneItemChecked := False;\r\n for I := 0 to Item.Parent.Count-1 do\r\n begin\r\n Measure(Item.Parent.Items[i], TmpWidth, TmpHeight);\r\n Inc(FMenuHeight, tmpHeight);\r\n\r\n FOneItemChecked := FOneItemChecked or Item.Parent.Items[I].Checked;\r\n end;\r\n end;\r\n\r\n // Prepare the painting only now so as to not trigger Mantis 3636.\r\n // This is required because Measure will call PreparePaint which will\r\n // set values such as FItem, FState and FImageIndex.\r\n // Note that we cannot modify prepare paint to NOT set those values\r\n // when measuring because many of the \"width\" related functions do need\r\n // a valid FItem member.\r\n PreparePaint(Item, ItemRect, State, False);\r\n\r\n // different values depending on the reading convention\r\n if IsRightToLeft then\r\n begin\r\n CheckMarkRect := Rect(ItemRect.Right - CheckMarkWidth + 1, ItemRect.Top, ItemRect.Right, ItemRect.Bottom);\r\n ImageAndMarginRect := Rect(CheckMarkRect.Left - 1 - ImageMargin.Left - ImageWidth - ImageMargin.Right, ItemRect.Top, CheckMarkRect.Left - 1, ItemRect.Bottom);\r\n TextAndMarginRect := Rect(ItemRect.Left, ItemRect.Top, ImageAndMarginRect.Left - 1, ItemRect.Bottom);\r\n ItemRectNoLeftMargin := Rect(ItemRect.Left, ItemRect.Top, Cardinal(ItemRect.Right)-LeftMargin, ItemRect.Bottom);\r\n OffsetRect(CheckMarkRect, -LeftMargin, 0);\r\n OffsetRect(ImageAndMarginRect, -LeftMargin, 0);\r\n OffsetRect(TextAndMarginRect, -LeftMargin, 0);\r\n\r\n LeftMarginRect := Rect(ItemRect.Right, 0, Cardinal(ItemRect.Right) - LeftMargin, FMenuHeight);\r\n end\r\n else\r\n begin\r\n CheckMarkRect := Rect(ItemRect.Left, ItemRect.Top, ItemRect.Left + CheckMarkWidth - 1, ItemRect.Bottom);\r\n ImageAndMarginRect := Rect(CheckMarkRect.Right + 1, ItemRect.Top, CheckMarkRect.Right + 1 + ImageMargin.Left + ImageWidth + ImageMargin.Right - 1, ItemRect.Bottom);\r\n TextAndMarginRect := Rect(ImageAndMarginRect.Right + 1, ItemRect.Top, ItemRect.Right, ItemRect.Bottom);\r\n ItemRectNoLeftMargin := Rect(Cardinal(ItemRect.Left)+LeftMargin, ItemRect.Top, ItemRect.Right, ItemRect.Bottom);\r\n OffsetRect(CheckMarkRect, LeftMargin, 0);\r\n OffsetRect(ImageAndMarginRect, LeftMargin, 0);\r\n OffsetRect(TextAndMarginRect, LeftMargin, 0);\r\n\r\n LeftMarginRect := Rect(ItemRect.Left, 0, Cardinal(ItemRect.Left) + LeftMargin, FMenuHeight);\r\n end;\r\n ImageRect := Rect(ImageAndMarginRect.Left + ImageMargin.Left, ImageAndMarginRect.Top + ImageMargin.Top, ImageAndMarginRect.Right - ImageMargin.Right, ImageAndMarginRect.Bottom - ImageMargin.Bottom);\r\n TextRect := Rect(TextAndMarginRect.Left + TextMargin, TextAndMarginRect.Top, TextAndMarginRect.Right, TextAndMarginRect.Bottom);\r\n end\r\n else\r\n begin\r\n // prepare the painting (see above)\r\n PreparePaint(Item, ItemRect, State, False);\r\n\r\n TextAndMarginRect := ItemRect;\r\n ItemRectNoLeftMargin := ItemRect;\r\n TextRect := ItemRect;\r\n end;\r\n\r\n // first, draw the background of the entire item\r\n DrawItemBackground(ItemRect);\r\n\r\n // draw the margin, if any. Do it all the time to go against erasing\r\n // created by the operating system itself.\r\n if (LeftMargin > 0) then\r\n DrawLeftMargin(LeftMarginRect);\r\n\r\n // draw the background of each separate part\r\n if IsPopup(Item) then\r\n begin\r\n if ShowCheckMarks then\r\n DrawCheckMarkBackground(CheckMarkRect);\r\n DrawImageBackground(ImageAndMarginRect);\r\n end;\r\n DrawTextBackground(TextAndMarginRect);\r\n\r\n // if the item is selected, then draw the frame to represent that\r\n if mdSelected in State then\r\n DrawSelectedFrame(ItemRectNoLeftMargin);\r\n\r\n if Assigned(Item) then\r\n begin\r\n FParentMenu := Item.GetParentMenu;\r\n\r\n // if item is checked and if we show check marks and if\r\n // the item is a popup (ie, not a top item), then we draw\r\n // the check image\r\n if Item.Checked and ShowCheckMarks and IsPopup(Item) then\r\n DrawCheckImage(CheckMarkRect);\r\n\r\n // It is now time to draw the image. The image will not be\r\n // drawn for root menu items (non popup).\r\n if IsPopup(Item) then\r\n begin\r\n // if we have a valid image from the list to use for this item\r\n if UseImages then\r\n begin\r\n // Draw the corresponding back of an item\r\n // if the item is to be drawn checked or not\r\n if Item.Checked and not ShowCheckMarks then\r\n DrawCheckedImageBack(ImageAndMarginRect)\r\n else\r\n DrawNotCheckedImageBack(ImageAndMarginRect);\r\n\r\n // then, draw the correct image, according to the state\r\n // of the item\r\n if (mdDisabled in State) then\r\n DrawDisabledImage(ImageRect.Left, ImageRect.Top)\r\n else\r\n DrawEnabledImage(ImageRect.Left, ImageRect.Top)\r\n end\r\n // else, we may have a valid glyph, but we won't use it if\r\n // the item is a separator\r\n else\r\n if Assigned(FGlyph) and not FGlyph.Empty and\r\n (Item.Caption <> Separator) then\r\n begin\r\n // Draw the corresponding back of an item\r\n // if the item is to be drawn checked or not\r\n if Item.Checked and not ShowCheckMarks then\r\n DrawCheckedImageBack(ImageAndMarginRect)\r\n else\r\n DrawNotCheckedImageBack(ImageAndMarginRect);\r\n\r\n if FGlyph is TBitmap then\r\n begin\r\n // in the case of a bitmap, we may have more than one glyph\r\n // in the graphic. If so, we draw only the one that corresponds\r\n // to the current state of the item\r\n // if not, we simply draw the bitmap\r\n if FNumGlyphs in [2..5] then\r\n begin\r\n I := 0;\r\n if mdDisabled in State then\r\n I := 1\r\n else\r\n if mdChecked in State then\r\n I := 3\r\n else\r\n if mdSelected in State then\r\n I := 2;\r\n if I > FNumGlyphs - 1 then\r\n I := 0;\r\n Bmp := TBitmap.Create;\r\n try\r\n AssignBitmapCell(FGlyph, Bmp, FNumGlyphs, 1, I);\r\n DrawMenuBitmap(ImageRect.Left, ImageRect.Top, Bmp);\r\n finally\r\n Bmp.Free;\r\n end;\r\n end\r\n else\r\n DrawMenuBitmap(ImageRect.Left, ImageRect.Top, FGlyph);\r\n end\r\n else\r\n begin\r\n Canvas.Draw(ImageRect.Left, ImageRect.Top, FGlyph);\r\n end;\r\n end\r\n // at last, if there is no image given by the user, there may\r\n // be a check mark to draw instead\r\n else\r\n if Item.Checked and not ShowCheckMarks then\r\n begin\r\n DrawCheckedImageBack(ImageAndMarginRect);\r\n DrawCheckImage(ImageRect);\r\n end;\r\n end;\r\n\r\n // now that the image and check mark are drawn, we can\r\n // draw the text of the item (or a separator)\r\n\r\n if Item.Caption = Separator then\r\n begin\r\n DrawSeparator(ItemRectNoLeftMargin)\r\n end\r\n else\r\n begin\r\n // find the largest text element\r\n Windows.DrawText(Canvas.Handle,\r\n PChar(Item.Caption),\r\n Length(Item.Caption),\r\n CaptionRect,\r\n DT_CALCRECT or DT_EXPANDTABS or DT_LEFT or DT_SINGLELINE);\r\n MaxWidth := CaptionRect.Right - CaptionRect.Left;\r\n if (Item.Parent <> nil) and (Item.ShortCut <> scNone) then\r\n begin\r\n for I := 0 to Item.Parent.Count - 1 do\r\n begin\r\n Windows.DrawText(Canvas.Handle,\r\n PChar(Item.Parent.Items[I].Caption+ShortcutSpacing),\r\n Length(Item.Parent.Items[I].Caption+ShortcutSpacing),\r\n CaptionRect,\r\n DT_CALCRECT or DT_EXPANDTABS or DT_LEFT or DT_SINGLELINE);\r\n MaxWidth := Max(CaptionRect.Right - CaptionRect.Left, MaxWidth);\r\n end;\r\n end;\r\n\r\n // draw the text\r\n Canvas.Brush.Style := bsClear;\r\n DrawItemText(TextRect, Item.Caption, DT_EXPANDTABS or DT_LEFT or DT_SINGLELINE);\r\n if (Item.ShortCut <> scNone) and (Item.Count = 0) and IsPopup(Item) then\r\n begin\r\n // draw the shortcut\r\n DrawItemText(Rect(TextRect.Left + MaxWidth, TextRect.Top, TextRect.Right, TextRect.Bottom),\r\n ShortCutToText(Item.ShortCut), DT_EXPANDTABS or DT_LEFT or DT_SINGLELINE);\r\n end;\r\n end;\r\n end\r\n else\r\n begin\r\n JvMessageBox('!!! asked to draw nil item !!!'#13#10 +\r\n 'Please report this to the JVCL team, ' +\r\n 'detailing the precise conditions in ' +\r\n 'which this error occured.'#13#10 +\r\n 'Thank you for your cooperation.',\r\n 'error in menu painter',\r\n MB_ICONERROR);\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomMenuItemPainter.DrawSelectedFrame;\r\nbegin\r\n // Do nothing by default\r\nend;\r\n\r\nprocedure TJvCustomMenuItemPainter.DrawCheckedImageBack(ARect: TRect);\r\nbegin\r\n // do nothing by default\r\nend;\r\n\r\nprocedure TJvCustomMenuItemPainter.DrawNotCheckedImageBack(ARect: TRect);\r\nbegin\r\n // do nothing by default\r\nend;\r\n\r\nfunction TJvCustomMenuItemPainter.GetDrawHighlight: Boolean;\r\nbegin\r\n Result := not (mdSelected in FState) or\r\n (GetNearestColor(Canvas.Handle, ColorToRGB(clGrayText)) = GetNearestColor(Canvas.Handle, ColorToRGB(clHighlight)));\r\nend;\r\n\r\nfunction TJvCustomMenuItemPainter.GetGrayColor: TColor;\r\nbegin\r\n if mdSelected in FState then\r\n Result := clGrayText\r\n else\r\n Result := clBtnShadow;\r\nend;\r\n\r\nfunction TJvCustomMenuItemPainter.IsPopup(const Item: TMenuItem): Boolean;\r\nbegin\r\n Result := (Item.Parent = nil) or (Item.Parent.Parent <> nil) or\r\n not (Item.Parent.Owner is TMainMenu);\r\nend;\r\n\r\nfunction TJvCustomMenuItemPainter.GetTextWidth(Item: TMenuItem): Integer;\r\nvar\r\n I: Integer;\r\n MaxWidth: Integer;\r\n tmpWidth: Integer;\r\n ShortcutWidth: Integer;\r\n OneItemHasChildren: Boolean;\r\n CaptionRect: TRect;\r\nbegin\r\n if IsPopup(Item) then\r\n begin\r\n // The width of the text is splitted in three parts:\r\n // Text Shortcut SubMenuArrow.\r\n // with the two last ones being not compulsory\r\n\r\n CaptionRect := Rect(0, 0, 0, 0);\r\n Windows.DrawText(Canvas.Handle,\r\n PChar(Item.Caption),\r\n Length(Item.Caption),\r\n CaptionRect,\r\n DT_CALCRECT or DT_EXPANDTABS or DT_LEFT or DT_SINGLELINE);\r\n MaxWidth := CaptionRect.Right - CaptionRect.Left;\r\n\r\n ShortcutWidth := 0;\r\n OneItemHasChildren := False;\r\n // Find the widest item in the menu being displayed\r\n if Item.Parent <> nil then\r\n begin\r\n\r\n // If the current item is the first one and it's not\r\n // alone, then discard its width because for some reason\r\n // the canvas is never correct.\r\n {if Item = Item.Parent.Items[0] then\r\n begin\r\n if Item.Parent.Count > 1 then\r\n Result := 0\r\n else\r\n Result := MaxWidth;\r\n Exit;\r\n end;}\r\n\r\n for I := 0 to Item.Parent.Count - 1 do\r\n begin\r\n Windows.DrawText(Canvas.Handle,\r\n PChar(Item.Parent.Items[I].Caption),\r\n Length(Item.Parent.Items[I].Caption),\r\n CaptionRect,\r\n DT_CALCRECT or DT_EXPANDTABS or DT_LEFT or DT_SINGLELINE);\r\n tmpWidth := CaptionRect.Right - CaptionRect.Left;\r\n if tmpWidth > MaxWidth then\r\n MaxWidth := tmpWidth;\r\n\r\n // if the item has childs, then add the required\r\n // width for an arrow. It is considered to be the width of\r\n // two spaces.\r\n if Item.Parent.Items[I].Count > 0 then\r\n OneItemHasChildren := True;\r\n\r\n if Item.Parent.Items[I].ShortCut <> scNone then\r\n begin\r\n Windows.DrawText(Canvas.Handle,\r\n PChar(ShortCutToText(Item.Parent.Items[I].ShortCut)),\r\n Length(ShortCutToText(Item.Parent.Items[I].ShortCut)),\r\n CaptionRect,\r\n DT_CALCRECT or DT_EXPANDTABS or DT_LEFT or DT_SINGLELINE);\r\n tmpWidth := CaptionRect.Right - CaptionRect.Left;\r\n if tmpWidth > ShortcutWidth then\r\n ShortcutWidth := tmpWidth;\r\n end;\r\n end;\r\n end;\r\n Result := MaxWidth;\r\n\r\n // If there was a shortcut in any of the items,\r\n if ShortcutWidth <> 0 then\r\n begin\r\n // add its width to the current width, plus the spacing\r\n Inc(Result, ShortcutWidth);\r\n Inc(Result, Canvas.TextWidth(ShortcutSpacing));\r\n end\r\n else\r\n if OneItemHasChildren then\r\n Inc(Result, Canvas.TextWidth(' '));\r\n end\r\n else\r\n Result := Canvas.TextWidth(StripHotkeyPrefix(Item.Caption));\r\nend;\r\n\r\nprocedure TJvCustomMenuItemPainter.Measure(Item: TMenuItem;\r\n var Width, Height: Integer);\r\nvar\r\n SavedOneItemChecked: Boolean;\r\nbegin\r\n PreparePaint(Item, Rect(0, 0, 0, 0), [], True);\r\n\r\n if IsPopup(Item) then\r\n begin\r\n SavedOneItemChecked := FOneItemChecked;\r\n FOneItemChecked := Item.Checked;\r\n Width := LeftMargin + Cardinal(CheckMarkWidth + ImageMargin.Left + ImageWidth + ImageMargin.Right + TextMargin + GetTextWidth(Item));\r\n\r\n if Item.Caption = Separator then\r\n Height := Max(Canvas.TextHeight(Separator) div 2, 9)\r\n else\r\n begin\r\n Height := Max(GetSystemMetrics(SM_CYMENU), Canvas.TextHeight(Item.Caption));\r\n Height := Max(Height, CheckMarkHeight);\r\n Height := Max(Height, ImageMargin.Top + ImageHeight + ImageMargin.Bottom);\r\n end;\r\n FOneItemChecked := SavedOneItemChecked;\r\n end\r\n else\r\n begin\r\n Width := TextMargin + GetTextWidth(Item);\r\n Height := Max(GetSystemMetrics(SM_CYMENU), Canvas.TextHeight(Item.Caption));\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomMenuItemPainter.DrawItemBackground(ARect: TRect);\r\nbegin\r\n // do nothing\r\nend;\r\n\r\nprocedure TJvCustomMenuItemPainter.DrawDisabledImage(X, Y: Integer);\r\nbegin\r\n if UseDisabledImages then\r\n ImageList_Draw(DisabledImages.Handle, FImageIndex, Canvas.Handle,\r\n X, Y, ILD_NORMAL)\r\n else\r\n ImageListDrawDisabled(Images, Canvas, X, Y, FImageIndex, clBtnHighlight,\r\n GrayColor, DrawHighlight)\r\nend;\r\n\r\nprocedure TJvCustomMenuItemPainter.DrawEnabledImage(X, Y: Integer);\r\nbegin\r\n if UseHotImages and (mdSelected in FState) then\r\n ImageList_Draw(HotImages.Handle, FImageIndex, Canvas.Handle,\r\n X, Y, ILD_NORMAL)\r\n else\r\n ImageList_Draw(Images.Handle, FImageIndex, Canvas.Handle,\r\n X, Y, ILD_NORMAL);\r\nend;\r\n\r\n{function TJvCustomMenuItemPainter.GetShadowColor: TColor;\r\nbegin\r\n if Assigned(FMainMenu) then\r\n Result := FMainMenu.ShadowColor\r\n else\r\n if Assigned(FPopupMenu) then\r\n Result := FPopupMenu.ShadowColor;\r\nend;}\r\n\r\nprocedure TJvCustomMenuItemPainter.DrawSeparator(ARect: TRect);\r\nvar\r\n LineTop: Integer;\r\nbegin\r\n LineTop := (ARect.Top + ARect.Bottom) div 2 - 1;\r\n Canvas.Pen.Width := 1;\r\n MenuLine(Canvas, clBtnShadow, ARect.Left - 1, LineTop, ARect.Right, LineTop);\r\n MenuLine(Canvas, clBtnHighlight, ARect.Left, LineTop + 1, ARect.Right, LineTop + 1);\r\nend;\r\n\r\nprocedure TJvCustomMenuItemPainter.DrawImageBackground(ARect: TRect);\r\nbegin\r\n // do nothing by default\r\nend;\r\n\r\nfunction TJvCustomMenuItemPainter.GetIsRightToLeft: Boolean;\r\nbegin\r\n Result := (FItem.GetParentMenu <> nil) and\r\n (FItem.GetParentMenu.BiDiMode <> bdLeftToRight);\r\nend;\r\n\r\nfunction TJvCustomMenuItemPainter.GetCheckMarkHeight: Integer;\r\nbegin\r\n if ShowCheckMarks then\r\n Result := GetSystemMetrics(SM_CYMENUCHECK)\r\n else\r\n Result := 0;\r\nend;\r\n\r\nfunction TJvCustomMenuItemPainter.GetCheckMarkWidth: Integer;\r\nbegin\r\n if ShowCheckMarks then\r\n Result := GetSystemMetrics(SM_CXMENUCHECK)\r\n else\r\n Result := 0;\r\nend;\r\n\r\nfunction TJvCustomMenuItemPainter.GetImageHeight: Integer;\r\nbegin\r\n if Assigned(Images) then\r\n Result := Images.Height\r\n else\r\n begin\r\n Result := ImageSize.Height;\r\n if Result = 0 then\r\n begin\r\n if Assigned(FGlyph) and not FGlyph.Empty then\r\n Result := 16 // hard coded as in Borland's VCL\r\n else\r\n if FOneItemChecked then\r\n Result := GetSystemMetrics(SM_CYMENUCHECK);\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJvCustomMenuItemPainter.GetImageWidth: Integer;\r\nbegin\r\n if Assigned(Images) then\r\n Result := Images.Width\r\n else\r\n begin\r\n Result := ImageSize.Width;\r\n if Result = 0 then\r\n begin\r\n if Assigned(FGlyph) and not FGlyph.Empty then\r\n Result := 16 // hard coded as in Borland's VCL\r\n else\r\n if FOneItemChecked then\r\n Result := GetSystemMetrics(SM_CXMENUCHECK);\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJvCustomMenuItemPainter.GetTextMargin: Integer;\r\nbegin\r\n if Assigned(FMainMenu) then\r\n Result := FMainMenu.TextMargin\r\n else\r\n if Assigned(FPopupMenu) then\r\n Result := FPopupMenu.TextMargin\r\n else\r\n Result := 0;\r\nend;\r\n\r\nprocedure TJvCustomMenuItemPainter.DrawCheckMarkBackground(ARect: TRect);\r\nbegin\r\n // do nothing by default\r\nend;\r\n\r\nprocedure TJvCustomMenuItemPainter.DrawTextBackground(ARect: TRect);\r\nbegin\r\n // do nothing by default\r\nend;\r\n\r\nfunction TJvCustomMenuItemPainter.GetTextVAlignment: TJvVerticalAlignment;\r\nbegin\r\n if Assigned(FMainMenu) then\r\n Result := FMainMenu.TextVAlignment\r\n else\r\n if Assigned(FPopupMenu) then\r\n Result := FPopupMenu.TextVAlignment\r\n else\r\n Result := vaMiddle;\r\nend;\r\n\r\nprocedure TJvCustomMenuItemPainter.ForceMenuRebuild;\r\nbegin\r\n if csLoading in ComponentState then\r\n Exit;\r\n\r\n if Assigned(FMainMenu) then\r\n FMainMenu.Rebuild\r\n else\r\n if Assigned(FPopupMenu) then\r\n FPopupMenu.Rebuild;\r\nend;\r\n\r\nprocedure TJvCustomMenuItemPainter.UpdateFieldsFromMenu;\r\nbegin\r\n if Assigned(FMainMenu) then\r\n begin\r\n FOnDrawItem := FMainMenu.OnDrawItem;\r\n FImageMargin.Assign(FMainMenu.ImageMargin);\r\n FImageSize.Assign(FMainMenu.ImageSize);\r\n end\r\n else\r\n if Assigned(FPopupMenu) then\r\n begin\r\n FOnDrawItem := FPopupMenu.OnDrawItem;\r\n FImageMargin.Assign(FPopupMenu.ImageMargin);\r\n FImageSize.Assign(FPopupMenu.ImageSize);\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomMenuItemPainter.DefaultDrawLeftMargin(ARect: TRect;\r\n StartColor, EndColor: TColor);\r\nvar\r\n R: Integer;\r\nbegin\r\n R := ARect.Right - 3;\r\n\r\n // Draw the gradient\r\n GradientFillRect(Canvas, Rect(ARect.Left, ARect.Top, R, ARect.Bottom), StartColor,\r\n EndColor, fdTopToBottom, 32);\r\n\r\n // Draw the separating line\r\n MenuLine(Canvas, clBtnFace, ARect.Right - 3, ARect.Top, ARect.Right - 3, ARect.Bottom);\r\n MenuLine(Canvas, clBtnShadow, ARect.Right - 2, ARect.Top, ARect.Right - 2, ARect.Bottom);\r\n MenuLine(Canvas, clBtnHighlight, ARect.Right - 1, ARect.Top, ARect.Right - 1, ARect.Bottom);\r\nend;\r\n\r\nprocedure TJvCustomMenuItemPainter.DrawLeftMargin(ARect: TRect);\r\nbegin\r\n if Assigned(FOnDrawLeftMargin) then\r\n FOnDrawLeftMargin(Self.FParentMenu, ARect)\r\n else\r\n begin\r\n DefaultDrawLeftMargin(ARect, DefaultMarginColor, RGB(\r\n GetRValue(DefaultMarginColor) div 4,\r\n GetGValue(DefaultMarginColor) div 4,\r\n GetBValue(DefaultMarginColor) div 4));\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomMenuItemPainter.SetLeftMargin(const Value: Cardinal);\r\nbegin\r\n if FLeftMargin <> Value then\r\n begin\r\n FLeftMargin := Value;\r\n\r\n // Force a rebuild as the width of the items has changed\r\n ForceMenuRebuild;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomMenuItemPainter.SetImageBackgroundColor(const Value: TColor);\r\nbegin\r\n FImageBackgroundColor := Value;\r\nend;\r\n\r\nfunction TJvCustomMenuItemPainter.GetMenu: TMenu;\r\nbegin\r\n if Assigned(FMainMenu) then\r\n Result := FMainMenu\r\n else\r\n if Assigned(FPopupMenu) then\r\n Result := FPopupMenu\r\n else\r\n Result := nil;\r\nend;\r\n\r\nprocedure TJvCustomMenuItemPainter.SetMenu(const Value: TMenu);\r\nbegin\r\n // Note: One may be tempted to store the value of the Canvas\r\n // property. This is not a good idea as the Canvas may only be\r\n // created when the menu is about to be displayed, thus being\r\n // nil right now.\r\n\r\n if Value is TJvMainMenu then\r\n begin\r\n FMainMenu := TJvMainMenu(Value);\r\n FPopupMenu := nil;\r\n end\r\n else\r\n if Value is TJvPopupMenu then\r\n begin\r\n FMainMenu := nil;\r\n FPopupMenu := TJvPopupMenu(Value);\r\n end\r\n else\r\n begin\r\n FMainMenu := nil;\r\n FPopupMenu := nil;\r\n end;\r\nend;\r\n\r\nfunction TJvCustomMenuItemPainter.GetCanvas: TCanvas;\r\nbegin\r\n if Assigned(FMainMenu) then\r\n Result := FMainMenu.Canvas\r\n else\r\n if Assigned(FPopupMenu) then\r\n Result := FPopupMenu.Canvas\r\n else\r\n Result := nil;\r\nend;\r\n\r\nprocedure TJvCustomMenuItemPainter.EmptyDrawItem(Sender: TObject; ACanvas: TCanvas;\r\n ARect: TRect; Selected: Boolean);\r\nbegin\r\n// Do nothing, on purpose\r\nend;\r\n\r\n//=== { TJvBtnMenuItemPainter } ==============================================\r\n\r\nconstructor TJvBtnMenuItemPainter.Create(AOwner: TComponent; Lowered: Boolean);\r\nbegin\r\n inherited Create(AOwner);\r\n FLowered := Lowered;\r\nend;\r\n\r\nconstructor TJvBtnMenuItemPainter.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FLowered := True;\r\nend;\r\n\r\nprocedure TJvBtnMenuItemPainter.DrawSelectedFrame(ARect: TRect);\r\nbegin\r\n if FLowered then\r\n Frame3D(Canvas, ARect, clBtnShadow, clBtnHighlight, 1)\r\n else\r\n Frame3D(Canvas, ARect, clBtnHighlight, clBtnShadow, 1);\r\nend;\r\n\r\nfunction TJvBtnMenuItemPainter.GetDrawHighlight: Boolean;\r\nbegin\r\n Result := True;\r\nend;\r\n\r\nfunction TJvBtnMenuItemPainter.GetGrayColor: TColor;\r\nbegin\r\n Result := clBtnShadow;\r\nend;\r\n\r\nprocedure TJvBtnMenuItemPainter.UpdateFieldsFromMenu;\r\nbegin\r\n inherited UpdateFieldsFromMenu;\r\n FImageMargin.Top := FImageMargin.Top + 1;\r\n FImageMargin.Bottom := FImageMargin.Bottom + 1;\r\nend;\r\n\r\n//=== { TJvOfficeMenuItemPainter } ===========================================\r\n\r\nprocedure TJvOfficeMenuItemPainter.Paint(Item: TMenuItem; ItemRect: TRect; State: TMenuOwnerDrawState);\r\nbegin\r\n inherited Paint(Item, ItemRect, State);\r\nend;\r\n\r\nprocedure TJvOfficeMenuItemPainter.PreparePaint(Item: TMenuItem;\r\n ItemRect: TRect; State: TMenuOwnerDrawState; Measure: Boolean);\r\nbegin\r\n inherited PreparePaint(Item, ItemRect, State, Measure);\r\n\r\n FCurrentItem := Item;\r\n FCurrentState := State;\r\nend;\r\n\r\nprocedure TJvOfficeMenuItemPainter.CleanupGlyph(BtnRect: TRect);\r\nvar\r\n SaveBrush: TBrush; // to save brush\r\nbegin\r\n SaveBrush := Canvas.Brush;\r\n Canvas.Brush.Color := ImageBackgroundColor;\r\n Inc(BtnRect.Right);\r\n Dec(BtnRect.Left);\r\n Canvas.FillRect(BtnRect);\r\n Canvas.Brush := SaveBrush;\r\nend;\r\n\r\nprocedure TJvOfficeMenuItemPainter.DrawFrame(BtnRect: TRect);\r\nbegin\r\n CleanupGlyph(BtnRect);\r\n Frame3D(Canvas, BtnRect, clBtnHighlight, clBtnShadow, 1);\r\nend;\r\n\r\nprocedure TJvOfficeMenuItemPainter.DrawSelectedFrame(ARect: TRect);\r\nbegin\r\n if not IsPopup(FItem) then\r\n begin\r\n CleanupGlyph(ARect);\r\n Frame3D(Canvas, ARect, clBtnShadow, clBtnHighlight, 1);\r\n end;\r\nend;\r\n\r\nprocedure TJvOfficeMenuItemPainter.DrawCheckedImageBack(ARect: TRect);\r\nbegin\r\n CleanupGlyph(ARect);\r\n DrawGlyphCheck(ARect);\r\nend;\r\n\r\nprocedure TJvOfficeMenuItemPainter.DrawNotCheckedImageBack(ARect: TRect);\r\nbegin\r\n if (mdSelected in FState) and IsPopup(FItem) then\r\n DrawFrame(ARect);\r\nend;\r\n\r\nfunction TJvOfficeMenuItemPainter.GetDrawHighlight: Boolean;\r\nbegin\r\n Result := not (mdSelected in FState) or (not IsPopup(FItem)) or\r\n (GetNearestColor(Canvas.Handle, ColorToRGB(clGrayText)) = GetNearestColor(Canvas.Handle, ColorToRGB(clHighlight)));\r\nend;\r\n\r\nprocedure TJvOfficeMenuItemPainter.UpdateFieldsFromMenu;\r\nbegin\r\n inherited UpdateFieldsFromMenu;\r\n FImageMargin.Left := FImageMargin.Left + 2;\r\n FImageMargin.Top := FImageMargin.Top + 2;\r\n FImageMargin.Right := FImageMargin.Right + 3;\r\n FImageMargin.Bottom := FImageMargin.Bottom + 2;\r\nend;\r\n\r\nfunction TJvOfficeMenuItemPainter.GetTextMargin: Integer;\r\nbegin\r\n Result := inherited GetTextMargin + 3;\r\nend;\r\n\r\nprocedure TJvOfficeMenuItemPainter.DrawCheckImage(ARect: TRect);\r\nbegin\r\n inherited DrawCheckImage(Rect(ARect.Left + 2, ARect.Top, ARect.Right, ARect.Bottom - 1));\r\nend;\r\n\r\nprocedure TJvOfficeMenuItemPainter.DrawItemText(ARect: TRect;\r\n const Text: string; Flags: Integer);\r\nvar\r\n FlatMenus: LongBool;\r\nbegin\r\n if not IsPopup(FItem) then\r\n begin\r\n Canvas.Font.Color := clMenuText;\r\n \r\n if (FCurrentState * [mdSelected, mdFocused, mdHotlight] = []) then\r\n begin\r\n if SystemParametersInfo(SPI_GETFLATMENU, 0, @FlatMenus, 0) and FlatMenus then\r\n Canvas.Brush.Color := clMenuBar\r\n else\r\n Canvas.Brush.Color := clBtnFace;\r\n Canvas.FillRect(ARect);\r\n end;\r\n end;\r\n\r\n inherited DrawItemText(Rect(ARect.Left, ARect.Top, ARect.Right, ARect.Bottom - 1), Text, Flags);\r\nend;\r\n\r\nprocedure TJvOfficeMenuItemPainter.DrawItemBackground(ARect: TRect);\r\nbegin\r\n inherited DrawItemBackground(ARect);\r\n if not IsPopup(FItem) and (mdHotlight in FState) then\r\n DrawFrame(ARect);\r\nend;\r\n\r\n//=== { TJvXPMenuItemPainter } ===============================================\r\n\r\nconstructor TJvXPMenuItemPainter.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FSelectionFrameBrush := TBrush.Create;\r\n FSelectionFramePen := TPen.Create;\r\n\r\n FSelRect := Rect(0, 0, 0, 0);\r\n FCheckedPoint := Point(0, 0);\r\n\r\n // affect default values that are not 0\r\n FShadowColor := DefaultXPShadowColor;\r\n FImageBackgroundColor := DefaultXPImageBackgroundColor;\r\n FSelectionFrameBrush.Color := DefaultXPSFBrushColor;\r\n FSelectionFrameBrush.Style := bsSolid;\r\n FSelectionFramePen.Color := DefaultXPSFPenColor;\r\n FSelectionFramePen.Style := psSolid;\r\n FSeparatorColor := DefaultXPSeparatorColor;\r\n FCheckedImageBackColor := DefaultXPCheckedImageBackColor;\r\n FCheckedImageBackColorSelected := DefaultXPCheckedImageBackColorSelected;\r\nend;\r\n\r\ndestructor TJvXPMenuItemPainter.Destroy;\r\nbegin\r\n FBorderCanvas.Free;\r\n FSelectionFrameBrush.Free;\r\n FSelectionFramePen.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvXPMenuItemPainter.DrawCheckedImageBack(ARect: TRect);\r\nbegin\r\n with Canvas do\r\n begin\r\n Pen.Assign(SelectionFramePen);\r\n Brush.Style := bsSolid;\r\n if mdSelected in FState then\r\n Brush.Color := CheckedImageBackColorSelected //SRGB(133,146,181)\r\n else\r\n Brush.Color := CheckedImageBackColor; //RGB(212,213,216);\r\n Rectangle(ARect.Left, ARect.Top + 1, ARect.Right - 3, ARect.Bottom - 2);\r\n end;\r\nend;\r\n\r\nprocedure TJvXPMenuItemPainter.DrawBitmapShadow(X, Y: Integer; B: TBitmap);\r\nvar\r\n BX, BY: Integer;\r\n TransparentColor: TColor;\r\nbegin\r\n TransparentColor := B.Canvas.Pixels[0, B.Height - 1];\r\n for BY := 0 to B.Height - 1 do\r\n for BX := 0 to B.Width - 1 do\r\n if B.Canvas.Pixels[BX, BY] <> TransparentColor then\r\n Canvas.Pixels[X + BX, Y + BY] := ShadowColor;\r\nend;\r\n\r\nprocedure TJvXPMenuItemPainter.DrawBorder(ACanvas: TCanvas; WRect: TRect);\r\nvar\r\n RightToLeft: Boolean;\r\n I: Integer;\r\n ShowingItemsParent: TMenuItem;\r\n LocalWRect: TRect;\r\nbegin\r\n // Sometimes, for reasons yet to be understood, the Handle is not allocated and\r\n // allocating it would trigger an exception telling us the canvas is not ready.\r\n // So we simply ignore the issue and hope that another message will ask for\r\n // redrawing later on.\r\n if not ACanvas.HandleAllocated then\r\n Exit;\r\n\r\n // Local value, just in case FItem is nil, which could theoretically happen\r\n // as DrawBorder is called from the replacement window procedure.\r\n RightToLeft := Menu.BiDiMode <> bdLeftToRight;\r\n\r\n LocalWRect := WRect;\r\n OffsetRect(LocalWRect, -LocalWRect.Left, -LocalWRect.Top);\r\n with ACanvas do\r\n begin\r\n Brush.Color := RGB(0, 0, 0); // must set the color or the style might not be taken into account\r\n Brush.Style := bsClear;\r\n Pen.Color := RGB(102, 102, 102);\r\n Pen.Style := psSolid;\r\n\r\n // dark contour\r\n Rectangle(LocalWRect);\r\n\r\n // two white lines above bottom\r\n Pen.Color := clWhite;\r\n MoveTo(LocalWRect.Left + 1, LocalWRect.Bottom - 2);\r\n LineTo(LocalWRect.Right - 1, LocalWRect.Bottom - 2);\r\n MoveTo(LocalWRect.Left + 1, LocalWRect.Bottom - 3);\r\n LineTo(LocalWRect.Right - 1, LocalWRect.Bottom - 3);\r\n\r\n // two white lines below top\r\n MoveTo(LocalWRect.Left + 1, LocalWRect.Top + 1);\r\n LineTo(LocalWRect.Right - 1, LocalWRect.Top + 1);\r\n MoveTo(LocalWRect.Left + 1, LocalWRect.Top + 2);\r\n LineTo(LocalWRect.Right - 1, LocalWRect.Top + 2);\r\n\r\n // three lines before right\r\n if RightToLeft then\r\n Pen.Color := ImageBackgroundColor\r\n else\r\n Pen.Color := clWhite;\r\n MoveTo(LocalWRect.Right - 2, LocalWRect.Top + 3);\r\n LineTo(LocalWRect.Right - 2, LocalWRect.Bottom - 3);\r\n MoveTo(LocalWRect.Right - 3, LocalWRect.Top + 3);\r\n LineTo(LocalWRect.Right - 3, LocalWRect.Bottom - 3);\r\n\r\n // two lines after left\r\n if RightToLeft then\r\n Pen.Color := clWhite\r\n else\r\n Pen.Color := ImageBackgroundColor;\r\n MoveTo(LocalWRect.Left + 1, LocalWRect.Top + 3);\r\n LineTo(LocalWRect.Left + 1, LocalWRect.Bottom - 3);\r\n MoveTo(LocalWRect.Left + 2, LocalWRect.Top + 3);\r\n LineTo(LocalWRect.Left + 2, LocalWRect.Bottom - 3);\r\n\r\n\r\n // Try to find which (sub)items are showing in order to paint the\r\n // bits of items that are in the border (eg selected/checked).\r\n // To do that, we first find the parent, possibly recursively, and\r\n // once we get it, we loop on its children.\r\n ShowingItemsParent := GetShowingItemsParent(WRect, Menu.Items);\r\n if Assigned(ShowingItemsParent) then\r\n begin\r\n for I := 0 to ShowingItemsParent.Count - 1 do\r\n begin\r\n DrawItemBorderParts(ShowingItemsParent.Items[I], ACanvas, WRect);\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvXPMenuItemPainter.DrawDisabledImage(X, Y: Integer);\r\nbegin\r\n // to take the margin into account\r\n if IsRightToLeft then\r\n Inc(X, 3)\r\n else\r\n Dec(X, 3);\r\n\r\n if UseDisabledImages then\r\n ImageList_Draw(DisabledImages.Handle, FImageIndex, Canvas.Handle,\r\n X, Y, ILD_NORMAL)\r\n else\r\n //TODO: Change to draw greyscale image\r\n ImageListDrawDisabled(Images, Canvas, X, Y, FImageIndex, clBtnHighlight, GrayColor,\r\n DrawHighlight);\r\nend;\r\n\r\nprocedure TJvXPMenuItemPainter.DrawEnabledImage(X, Y: Integer);\r\nvar\r\n TmpBitmap: TBitmap;\r\nbegin\r\n // to take the margin into account\r\n if IsRightToLeft then\r\n Inc(X, 3)\r\n else\r\n Dec(X, 3);\r\n\r\n if (mdSelected in FState) then\r\n begin\r\n // draw shadow for selected and enbled item\r\n // first, create a bitmap from the correct image\r\n TmpBitmap := TBitmap.Create;\r\n if UseHotImages then\r\n begin\r\n TmpBitmap.Width := HotImages.Width;\r\n TmpBitmap.Height := HotImages.Height;\r\n TmpBitmap.Canvas.Brush.Color := Canvas.Brush.Color;\r\n TmpBitmap.Canvas.FillRect(Rect(0, 0, TmpBitmap.Width, TmpBitmap.Height));\r\n ImageList_DrawEx(HotImages.Handle, FImageIndex, TmpBitmap.Canvas.Handle,\r\n 0, 0, 0, 0, clNone, clNone, ILD_TRANSPARENT);\r\n end\r\n else\r\n begin\r\n TmpBitmap.Width := Images.Width;\r\n TmpBitmap.Height := Images.Height;\r\n TmpBitmap.Canvas.Brush.Color := Canvas.Brush.Color;\r\n TmpBitmap.Canvas.FillRect(Rect(0, 0, TmpBitmap.Width, TmpBitmap.Height));\r\n ImageList_DrawEx(Images.Handle, FImageIndex, TmpBitmap.Canvas.Handle,\r\n 0, 0, 0, 0, clNone, clNone, ILD_TRANSPARENT);\r\n end;\r\n\r\n // then effectively draw the shadow\r\n DrawBitmapShadow(X + 1, Y + 1, TmpBitmap);\r\n\r\n TmpBitmap.Free;\r\n\r\n // shift the image to the top and left\r\n Dec(X);\r\n Dec(Y);\r\n end;\r\n\r\n // and call inherited to draw the image\r\n inherited DrawEnabledImage(X, Y);\r\nend;\r\n\r\nprocedure TJvXPMenuItemPainter.DrawItemBackground(ARect: TRect);\r\nconst\r\n COLOR_MENUBAR = 30;\r\nbegin\r\n with Canvas do\r\n begin\r\n if IsPopup(FItem) then\r\n begin\r\n // popup items, always white background\r\n Brush.Color := clWhite;\r\n Brush.Style := bsSolid;\r\n FillRect(ARect);\r\n end\r\n else\r\n begin\r\n // top level items, depends on the Hotlight status\r\n if mdHotlight in FState then\r\n begin\r\n Brush.Assign(SelectionFrameBrush);\r\n Pen.Assign(SelectionFramePen);\r\n Rectangle(ARect);\r\n end\r\n else\r\n if UseFlatMenubars then\r\n begin\r\n Brush.Color := GetSysColor(COLOR_MENUBAR);\r\n Brush.Style := bsSolid;\r\n Pen.Style := psSolid;\r\n Pen.Color := Brush.Color;\r\n FillRect(ARect);\r\n end\r\n else\r\n begin\r\n Brush.Color := clBtnFace;\r\n Brush.Style := bsSolid;\r\n Pen.Style := psSolid;\r\n Pen.Color := Brush.Color;\r\n Rectangle(ARect);\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvXPMenuItemPainter.DrawItemBorderParts(Item: TMenuItem;\r\n Canvas: TCanvas; WRect: TRect);\r\nvar\r\n ItemInfo: MENUITEMINFO;\r\n ItemRect: TRect;\r\n LocalWRect: TRect;\r\nbegin\r\n ItemInfo.cbSize := sizeof(ItemInfo);\r\n ItemInfo.fMask := MIIM_STATE;\r\n if GetMenuItemInfo(Item.Parent.Handle, Item.MenuIndex, True, ItemInfo) then\r\n begin\r\n ItemRect := GetItemScreenRect(Item.Parent, Item.MenuIndex);\r\n OffsetRect(ItemRect, -ItemRect.Left, -WRect.Top);\r\n LocalWRect := WRect;\r\n OffsetRect(LocalWRect, -LocalWRect.Left, -LocalWRect.Top);\r\n with Canvas do\r\n begin\r\n // If the item is selected (Highlighted), then the closing borders\r\n // of the selection rectangle are in the border of the menu window.\r\n // Hence, we must draw them here.\r\n if (ItemInfo.fState and MFS_HILITE) = MFS_HILITE then\r\n begin\r\n Brush.Style := bsClear;\r\n Pen.Assign(SelectionFramePen);\r\n MoveTo(LocalWRect.Left + 2, ItemRect.Top + 0);\r\n LineTo(LocalWRect.Left + 2, ItemRect.Bottom - 1);\r\n MoveTo(LocalWRect.Right - 3, ItemRect.Top + 0);\r\n LineTo(LocalWRect.Right - 3, ItemRect.Bottom - 1);\r\n\r\n // change the pen for the next instructions to draw in\r\n // the correct color for a selected item.\r\n Pen.Style := psSolid;\r\n Pen.Color := SelectionFrameBrush.Color;\r\n\r\n if IsRightToLeft then\r\n begin\r\n MoveTo(LocalWRect.Right - 4, ItemRect.Top);\r\n LineTo(LocalWRect.Right - 4, ItemRect.Bottom - 1);\r\n Pixels[LocalWRect.Right - 4, ItemRect.Top] := SelectionFramePen.Color;\r\n Pixels[LocalWRect.Right - 4, ItemRect.Bottom - 2] := SelectionFramePen.Color;\r\n end\r\n else\r\n begin\r\n MoveTo(LocalWRect.Left + 3, ItemRect.Top);\r\n LineTo(LocalWRect.Left + 3, ItemRect.Bottom - 1);\r\n Pixels[LocalWRect.Left + 3, ItemRect.Top] := SelectionFramePen.Color;\r\n Pixels[LocalWRect.Left + 3, ItemRect.Bottom - 2] := SelectionFramePen.Color;\r\n end;\r\n end;\r\n\r\n // If the item is checked then the left closing border of the checkbox\r\n // rectangle is in the border of the menu window.\r\n // Hence, we must draw it here.\r\n if (ItemInfo.fState and MFS_CHECKED) = MFS_CHECKED then\r\n begin\r\n // change the pen for the next instructions to draw in\r\n // the correct color for a selected item.\r\n Pen.Assign(SelectionFramePen);\r\n\r\n if IsRightToLeft then\r\n begin\r\n MoveTo(LocalWRect.Right - 4, ItemRect.Top);\r\n LineTo(LocalWRect.Right - 4, ItemRect.Bottom - 1);\r\n end\r\n else\r\n begin\r\n MoveTo(LocalWRect.Left + 3, ItemRect.Top+1);\r\n LineTo(LocalWRect.Left + 3, ItemRect.Bottom - 2);\r\n end;\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvXPMenuItemPainter.DrawMenuBitmap(X, Y: Integer; Bitmap: TBitmap);\r\nbegin\r\n // to take the margin into account\r\n if IsRightToLeft then\r\n Inc(X, 3)\r\n else\r\n Dec(X, 3);\r\n\r\n if mdDisabled in FState then\r\n DrawDisabledBitmap(X, Y, Bitmap)\r\n else\r\n begin\r\n // if selected, then draw shadow and shift real image towards\r\n // top and left, but only if draw bitmap was called because\r\n // of a user supplied glyph\r\n if (mdSelected in FState) and Assigned(FGlyph) then\r\n begin\r\n DrawBitmapShadow(X + 1, Y + 1, Bitmap);\r\n Dec(X);\r\n Dec(Y);\r\n end;\r\n\r\n if Bitmap.Monochrome and (not FItem.Checked or ShowCheckMarks) then\r\n BitBlt(Canvas.Handle, X, Y, Bitmap.Width, Bitmap.Height,\r\n Bitmap.Canvas.Handle, 0, 0, SRCCOPY)\r\n else\r\n DrawBitmapTransparent(Canvas, X, Y, Bitmap, Bitmap.TransparentColor and not PaletteMask);\r\n end;\r\nend;\r\n\r\nprocedure TJvXPMenuItemPainter.DrawSelectedFrame(ARect: TRect);\r\nbegin\r\n with Canvas do\r\n begin\r\n Font.Color := clMenuText;\r\n if IsPopup(FItem) then\r\n begin\r\n Brush.Assign(SelectionFrameBrush);\r\n Pen.Style := psClear;\r\n Rectangle(0, ARect.Top, ARect.Right + 4, ARect.Bottom - 1);\r\n Pen.Assign(SelectionFramePen);\r\n Brush.Style := bsClear;\r\n MoveTo(0, ARect.Top);\r\n LineTo(ARect.Right + 4, ARect.Top);\r\n MoveTo(0, ARect.Bottom - 2);\r\n LineTo(ARect.Right + 4, ARect.Bottom - 2);\r\n end\r\n else\r\n begin\r\n Brush.Color := clSilver;\r\n Brush.Style := bsSolid;\r\n Pen.Color := clGray;\r\n Pen.Style := psSolid;\r\n Rectangle(ARect);\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvXPMenuItemPainter.Measure(Item: TMenuItem;\r\n var Width, Height: Integer);\r\nbegin\r\n inherited Measure(Item, Width, Height);\r\n if Item.Caption = Separator then\r\n Height := 3\r\n else\r\n Inc(Height, 2);\r\nend;\r\n\r\ntype\r\n TWindowList = class\r\n private\r\n FWindowList: TList;\r\n FPrevProcList: TList;\r\n public\r\n constructor Create;\r\n destructor Destroy; override;\r\n procedure RemoveHook(AHandle: THandle);\r\n procedure AddHook(AHandle: THandle; OldProc, NewProc: Pointer);\r\n function CallPrevWindowProc(hwnd: THandle; uMsg: UINT; wParam: WPARAM; lParam: LPARAM): LRESULT;\r\n end;\r\n\r\nvar\r\n GWindowList: TWindowList;\r\n\r\nfunction WindowList: TWindowList;\r\nbegin\r\n if GWindowList = nil then\r\n GWindowList := TWindowList.Create;\r\n Result := GWindowList;\r\nend;\r\n\r\n// This is the replacement Window Procedure for the window that is used\r\n// to render the menus. Basically, it calls DrawBorder when it receives\r\n// an WM_NCPAINT message so that it overrides the default behaviour of\r\n// the Win32 API.\r\n// Note: We use a global variable to keep track of the current XPPainter\r\n// and not the SetProp and GetProp APIs. This is because it turned out that\r\n// the value read by GetProp was correct but its cast back to the item\r\n// painter address was not. So we use the global variable approach, ensuring\r\n// it gets reinitialized whenever the window disappears;\r\nfunction XPMenuItemPainterWndProc(hwnd : THandle;\r\n uMsg : UINT;\r\n wParam : WPARAM;\r\n lParam : LPARAM): LRESULT; stdcall;\r\nvar\r\n WindowRect: TRect;\r\n DC: HDC;\r\n ACanvas: TCanvas;\r\n SaveIndex: Integer;\r\nbegin\r\n Result := WindowList.CallPrevWindowProc(hwnd, uMsg, wParam, lParam);\r\n case uMsg of\r\n WM_NCPAINT:\r\n begin\r\n if GetWindowRect(hwnd, WindowRect) and Assigned(currentXPPainter) then\r\n begin\r\n // Mantis #4146: Without DCX_CACHE GetDCEx returns 0..\r\n DC := GetDCEx(hwnd, wParam, DCX_CACHE or DCX_WINDOW or DCX_INTERSECTRGN);\r\n try\r\n ACanvas := TControlCanvas.Create;\r\n try\r\n SaveIndex := SaveDC(DC);\r\n try\r\n ACanvas.Handle := DC;\r\n currentXPPainter.DrawBorder(ACanvas, WindowRect);\r\n finally\r\n ACanvas.Handle := 0;\r\n RestoreDC(DC, SaveIndex);\r\n end;\r\n finally\r\n ACanvas.Free;\r\n end;\r\n finally\r\n ReleaseDC(hwnd, DC);\r\n end;\r\n end;\r\n end;\r\n WM_SHOWWINDOW:\r\n begin\r\n if wParam = 0 then\r\n begin\r\n WindowList.RemoveHook(hwnd);\r\n currentXPPainter := nil;\r\n end;\r\n end;\r\n WM_NCDESTROY:\r\n begin\r\n WindowList.RemoveHook(hwnd);\r\n currentXPPainter := nil;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvXPMenuItemPainter.Paint(Item: TMenuItem; ItemRect: TRect;\r\n State: TMenuOwnerDrawState);\r\nvar\r\n CanvasWindow: HWND;\r\n WRect: TRect;\r\n DefProc: Pointer;\r\n TmpDC: HDC;\r\nbegin\r\n FItem := Item;\r\n\r\n // draw the contour of the window\r\n if IsPopup(Item) and not (csDesigning in ComponentState) then\r\n begin\r\n CanvasWindow := WindowFromDC(Canvas.Handle);\r\n\r\n if not (Assigned(FMainMenu) and\r\n (FMainMenu.GetOwner <> nil) and\r\n (FMainMenu.GetOwner is TForm) and\r\n (TForm(FMainMenu.GetOwner).Handle = CanvasWindow)) then\r\n begin\r\n // If we have a window, that has a WndProc, which is different from our\r\n // replacement WndProc and we are not at design time, then install\r\n // our replacement WndProc.\r\n // Once this is done, we can draw the border in the appropriate rect.\r\n\r\n // Note that if the menu has sub-menus we can have multiple hooks; so we\r\n // use TWindowList\r\n if CanvasWindow <> 0 then\r\n begin\r\n GetWindowRect(CanvasWindow, WRect);\r\n\r\n DefProc := Pointer(GetWindowLongPtr(CanvasWindow, GWL_WNDPROC));\r\n if (DefProc <> nil) and\r\n (DefProc <> @XPMenuItemPainterWndProc) and\r\n not (csDesigning in Menu.ComponentState) then\r\n begin\r\n currentXPPainter := Self;\r\n WindowList.AddHook(CanvasWindow, DefProc, @XPMenuItemPainterWndProc);\r\n end;\r\n\r\n(* // Note: we draw the border here. But using the \"Canvas\" property is\r\n // not good enough as it does not take into account the borders of the\r\n // menu. So for version prior to Vista, be draw directly on the desktop\r\n // window canvas. However, with desktop composition under Vista, this\r\n // is awfully slow so we try to use the DISPLAY device context. Note\r\n // that the behaviour on Vista has not been tested as no JVCL developper\r\n // has access to a Vista system with the Aero them turned on.\r\n if JclSysInfo.GetWindowsVersion = wvWinVista then\r\n begin\r\n TmpDC := CreateDC('DISPLAY', nil, nil, nil);\r\n try\r\n if not Assigned(FBorderCanvas) then\r\n FBorderCanvas := TCanvas.Create;\r\n\r\n FBorderCanvas.Handle := TmpDC;\r\n DrawBorder(FBorderCanvas, WRect);\r\n finally\r\n DeleteDC(TmpDC);\r\n end;\r\n end\r\n else *)\r\n begin\r\n if not Assigned(FBorderCanvas) then\r\n FBorderCanvas := TCanvas.Create;\r\n\r\n TmpDC := GetWindowDC(CanvasWindow);\r\n try\r\n FBorderCanvas.Handle := TmpDC;\r\n DrawBorder(FBorderCanvas, WRect);\r\n finally\r\n FBorderCanvas.Handle := 0;\r\n ReleaseDC(CanvasWindow, TmpDC);\r\n end;\r\n end;\r\n end;\r\n end;\r\n end;\r\n\r\n // then draw the items\r\n inherited Paint(Item, ItemRect, State);\r\nend;\r\n\r\nprocedure TJvXPMenuItemPainter.PreparePaint(Item: TMenuItem;\r\n Rect: TRect; State: TMenuOwnerDrawState; Measure: Boolean);\r\nbegin\r\n // to prevent erasing when the item is selected\r\n Canvas.Brush.Color := clNone;\r\n inherited PreparePaint(Item, Rect, State, Measure);\r\nend;\r\n\r\nprocedure TJvXPMenuItemPainter.SetSelectionFrameBrush(const Value: TBrush);\r\nbegin\r\n FSelectionFrameBrush.Assign(Value);\r\nend;\r\n\r\nprocedure TJvXPMenuItemPainter.SetSelectionFramePen(const Value: TPen);\r\nbegin\r\n FSelectionFramePen.Assign(Value);\r\nend;\r\n\r\nprocedure TJvXPMenuItemPainter.DrawSeparator(ARect: TRect);\r\nbegin\r\n // draw the separating line\r\n if IsRightToLeft then\r\n MenuLine(Canvas, SeparatorColor, ARect.Left, ARect.Top + 1, ARect.Right - CheckMarkWidth - ImageMargin.Left - ImageWidth - ImageMargin.Right - TextMargin, ARect.Top + 1)\r\n else\r\n MenuLine(Canvas, SeparatorColor, ARect.Left + CheckMarkWidth + ImageMargin.Left + ImageWidth + ImageMargin.Right + TextMargin, ARect.Top + 1, ARect.Right, ARect.Top + 1);\r\nend;\r\n\r\nprocedure TJvXPMenuItemPainter.DrawImageBackground(ARect: TRect);\r\nbegin\r\n with Canvas do\r\n begin\r\n // draw the gray background in the area\r\n Brush.Color := ImageBackgroundColor;\r\n Brush.Style := bsSolid;\r\n Pen.Style := psClear;\r\n Rectangle(ARect.Left, ARect.Top, ARect.Right, ARect.Bottom + 1);\r\n end;\r\nend;\r\n\r\nprocedure TJvXPMenuItemPainter.DrawCheckMarkBackground(ARect: TRect);\r\nbegin\r\n DrawImageBackground(ARect);\r\nend;\r\n\r\nfunction TJvXPMenuItemPainter.GetDrawHighlight: Boolean;\r\nbegin\r\n Result := not (mdSelected in FState) or (not IsPopup(FItem)) or\r\n (GetNearestColor(Canvas.Handle, ColorToRGB(clGrayText)) = GetNearestColor(Canvas.Handle, ColorToRGB(clHighlight)));\r\nend;\r\n\r\nfunction TJvXPMenuItemPainter.GetItemScreenRect(ParentItem: TMenuItem;\r\n Index: Integer): TRect;\r\nbegin\r\n // Contrary to what the MSDN writes, the first parameter to this function\r\n // MUST be 0 even for top level menu items...\r\n GetMenuItemRect(0, ParentItem.Handle, Index, Result);\r\nend;\r\n\r\nfunction TJvXPMenuItemPainter.GetShowingItemsParent(WRect: TRect;\r\n StartingItem: TMenuItem): TMenuItem;\r\nvar\r\n ItemRect: TRect;\r\n I: Integer;\r\nbegin\r\n Result := nil;\r\n if StartingItem.Count = 0 then\r\n Exit;\r\n\r\n ItemRect := GetItemScreenRect(StartingItem, 0);\r\n if RectIncludesRect(ItemRect, WRect) then\r\n begin\r\n Result := StartingItem;\r\n end\r\n else\r\n begin\r\n I := 0;\r\n while not Assigned(Result) and (I < StartingItem.Count) do\r\n begin\r\n Result := GetShowingItemsParent(WRect, StartingItem[I]);\r\n Inc(I);\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvXPMenuItemPainter.UpdateFieldsFromMenu;\r\nbegin\r\n inherited UpdateFieldsFromMenu;\r\n FImageMargin.Left := FImageMargin.Left + 6;\r\n FImageMargin.Top := FImageMargin.Top + 4;\r\n FImageMargin.Right := FImageMargin.Right + 4;\r\n FImageMargin.Bottom := FImageMargin.Bottom + 4;\r\nend;\r\n\r\nprocedure TJvXPMenuItemPainter.DrawItemText(ARect: TRect; const Text: string;\r\n Flags: Integer);\r\nbegin\r\n inherited DrawItemText(Rect(ARect.Left, ARect.Top, ARect.Right, ARect.Bottom - 1), Text, Flags);\r\nend;\r\n\r\nfunction TJvXPMenuItemPainter.GetTextMargin: Integer;\r\nbegin\r\n Result := inherited GetTextMargin + 2;\r\nend;\r\n\r\nprocedure TJvXPMenuItemPainter.DrawCheckImage(ARect: TRect);\r\nbegin\r\n inherited DrawCheckImage(Rect(ARect.Left - 2, ARect.Top, ARect.Right - 2, ARect.Bottom - 1));\r\nend;\r\n\r\n//=== { TJvStandardMenuItemPainter } =========================================\r\n\r\nprocedure TJvStandardMenuItemPainter.DrawCheckedImageBack(ARect: TRect);\r\nbegin\r\n inherited DrawCheckedImageBack(ARect);\r\nend;\r\n\r\nprocedure TJvStandardMenuItemPainter.UpdateFieldsFromMenu;\r\nbegin\r\n inherited UpdateFieldsFromMenu;\r\nend;\r\n\r\nfunction TJvStandardMenuItemPainter.GetTextMargin: Integer;\r\nbegin\r\n Result := inherited GetTextMargin + 2;\r\nend;\r\n\r\nfunction TJvStandardMenuItemPainter.GetImageWidth: Integer;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := inherited GetImageWidth;\r\n\r\n // If any of the items has a checkmark then we need to\r\n // ensure the width of the \"image\" is enough to display a check\r\n // mark, and this for all items\r\n if FItem.Parent <> nil then\r\n for I := 0 to FItem.Parent.Count - 1 do\r\n if FItem.Parent.Items[I].Checked then\r\n begin\r\n Result := Max(Result, GetSystemMetrics(SM_CXMENUCHECK));\r\n Break;\r\n end;\r\nend;\r\n\r\nprocedure TJvStandardMenuItemPainter.Paint(Item: TMenuItem;\r\n ItemRect: TRect; State: TMenuOwnerDrawState);\r\nbegin\r\n inherited Paint(Item, ItemRect, State);\r\nend;\r\n\r\n//=== { TJvOwnerDrawMenuItemPainter } ========================================\r\n\r\nprocedure TJvOwnerDrawMenuItemPainter.Measure(Item: TMenuItem;\r\n var Width, Height: Integer);\r\nbegin\r\n if Assigned(FMainMenu) then\r\n begin\r\n if Assigned(FMainMenu.OnMeasureItem) then\r\n FMainMenu.OnMeasureItem(FMainMenu, Item, Width, Height);\r\n end\r\n else\r\n if Assigned(FPopupMenu) then\r\n begin\r\n if Assigned(FPopupMenu.OnMeasureItem) then\r\n FPopupMenu.OnMeasureItem(FPopupMenu, Item, Width, Height);\r\n end;\r\nend;\r\n\r\nprocedure TJvOwnerDrawMenuItemPainter.Paint(Item: TMenuItem; ItemRect: TRect;\r\n State: TMenuOwnerDrawState);\r\nbegin\r\n if Assigned(FMainMenu) then\r\n begin\r\n if Assigned(FMainMenu.OnDrawItem) then\r\n FMainMenu.OnDrawItem(FMainMenu, Item, ItemRect, State);\r\n end\r\n else\r\n if Assigned(FPopupMenu) then\r\n begin\r\n if Assigned(FPopupMenu.OnDrawItem) then\r\n FPopupMenu.OnDrawItem(FPopupMenu, Item, ItemRect, State);\r\n end;\r\nend;\r\n\r\n//=== { TJvImageMargin } =====================================================\r\n\r\nprocedure TJvImageMargin.Assign(Source: TPersistent);\r\nbegin\r\n if Source is TJvImageMargin then\r\n begin\r\n Left := TJvImageMargin(Source).Left;\r\n Right := TJvImageMargin(Source).Right;\r\n Top := TJvImageMargin(Source).Top;\r\n Bottom := TJvImageMargin(Source).Bottom;\r\n end\r\n else\r\n inherited Assign(Source);\r\nend;\r\n\r\nprocedure TJvImageMargin.DoChange;\r\nbegin\r\n if Assigned(OnChange) then\r\n OnChange(Self);\r\nend;\r\n\r\nprocedure TJvImageMargin.SetBottom(const Value: Integer);\r\nbegin\r\n if FBottom <> Value then\r\n begin\r\n FBottom := Value;\r\n DoChange;\r\n end;\r\nend;\r\n\r\nprocedure TJvImageMargin.SetLeft(const Value: Integer);\r\nbegin\r\n if FLeft <> Value then\r\n begin\r\n FLeft := Value;\r\n DoChange;\r\n end;\r\nend;\r\n\r\nprocedure TJvImageMargin.SetRight(const Value: Integer);\r\nbegin\r\n if FRight <> Value then\r\n begin\r\n FRight := Value;\r\n DoChange;\r\n end;\r\nend;\r\n\r\nprocedure TJvImageMargin.SetTop(const Value: Integer);\r\nbegin\r\n if FTop <> Value then\r\n begin\r\n FTop := Value;\r\n DoChange;\r\n end;\r\nend;\r\n\r\n//=== { TJvMenuImageSize } ===================================================\r\n\r\nprocedure TJvMenuImageSize.Assign(Source: TPersistent);\r\nbegin\r\n if Source is TJvMenuImageSize then\r\n begin\r\n Height := TJvMenuImageSize(Source).Height;\r\n Width := TJvMenuImageSize(Source).Width;\r\n end\r\n else\r\n inherited Assign(Source);\r\nend;\r\n\r\nprocedure TJvMenuImageSize.DoChange;\r\nbegin\r\n if Assigned(OnChange) then\r\n OnChange(Self);\r\nend;\r\n\r\nprocedure TJvMenuImageSize.SetHeight(const Value: Integer);\r\nbegin\r\n if FHeight <> Value then\r\n begin\r\n FHeight := Value;\r\n DoChange;\r\n end;\r\nend;\r\n\r\nprocedure TJvMenuImageSize.SetWidth(const Value: Integer);\r\nbegin\r\n if FWidth <> Value then\r\n begin\r\n FWidth := Value;\r\n DoChange;\r\n end;\r\nend;\r\n\r\n//=== { TWindowList } =======================================================\r\n\r\nprocedure TWindowList.AddHook(AHandle: THandle; OldProc, NewProc: Pointer);\r\nbegin\r\n FWindowList.Add(Pointer(AHandle));\r\n FPrevProcList.Add(OldProc);\r\n SetWindowLongPtr(AHandle, GWL_WNDPROC, LONG_PTR(NewProc));\r\nend;\r\n\r\nfunction TWindowList.CallPrevWindowProc(hwnd: THandle; uMsg: UINT;\r\n wParam: WPARAM; lParam: LPARAM): LRESULT;\r\nvar\r\n Index: Integer;\r\nbegin\r\n Index := FWindowList.IndexOf(Pointer(hwnd));\r\n if Index >= 0 then\r\n Result := CallWindowProc(FPrevProcList[Index], hwnd, uMsg, wParam, lParam)\r\n else\r\n Result := 0;\r\nend;\r\n\r\nconstructor TWindowList.Create;\r\nbegin\r\n inherited Create;\r\n FWindowList := TList.Create;\r\n FPrevProcList := TList.Create;\r\nend;\r\n\r\ndestructor TWindowList.Destroy;\r\nbegin\r\n FWindowList.Free;\r\n FPrevProcList.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TWindowList.RemoveHook(AHandle: THandle);\r\nvar\r\n Index: Integer;\r\nbegin\r\n Index := FWindowList.IndexOf(Pointer(AHandle));\r\n if Index >= 0 then\r\n begin\r\n {$IFDEF RTL230_UP}\r\n SetWindowLongPtr(AHandle, GWL_WNDPROC, LONG_PTR(FPrevProcList[Index]));\r\n {$ELSE}\r\n SetWindowLong(AHandle, GWL_WNDPROC, Integer(FPrevProcList[Index]));\r\n {$ENDIF RTL230_UP}\r\n\r\n FWindowList.Delete(Index);\r\n FPrevProcList.Delete(Index);\r\n end;\r\nend;\r\n\r\ninitialization\r\n {$IFDEF UNITVERSIONING}\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n {$ENDIF UNITVERSIONING}\r\n\r\nfinalization\r\n FreeAndNil(PopupList);\r\n FreeAndNil(GWindowList);\r\n {$IFDEF UNITVERSIONING}\r\n UnregisterUnitVersion(HInstance);\r\n {$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n\r\n\r\n" }, { "path": "External/Jedi/Jvcl/run/JvMergeManager.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvMrgMngr.PAS, released on 2002-07-04.\r\n\r\nThe Initial Developers of the Original Code are: Fedor Koshevnikov, Igor Pavluk and Serge Korolev\r\nCopyright (c) 1997, 1998 Fedor Koshevnikov, Igor Pavluk and Serge Korolev\r\nCopyright (c) 2001,2002 SGB Software\r\nAll Rights Reserved.\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvMergeManager.pas 13104 2011-09-07 06:50:43Z obones $\r\n\r\nunit JvMergeManager;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Classes, Controls, Forms,\r\n JvJVCLUtils, JvComponentBase;\r\n\r\ntype\r\n TFormRequestEvent = procedure(Sender: TObject; CurrentForm: TCustomForm;\r\n var NewForm: TCustomForm) of object;\r\n TFormReorderEvent = procedure(Sender: TObject;\r\n Activated, Deactivated: TCustomForm) of object;\r\n TJvFormHistory = class;\r\n TFormHistoryCommand = (hcNone, hcAdd, hcBack, hcForward, hcGoto);\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64 or pidOSX32)]\r\n {$ENDIF RTL230_UP}\r\n TJvMergeManager = class(TJvComponent)\r\n private\r\n FMergeFrame: TWinControl;\r\n FFormHistory: TJvFormHistory;\r\n FHistoryCommand: TFormHistoryCommand;\r\n FOnGetBackForm: TFormRequestEvent;\r\n FOnGetForwardForm: TFormRequestEvent;\r\n FOnChange: TNotifyEvent;\r\n FOnReorder: TFormReorderEvent;\r\n function IsForm: Boolean;\r\n function MergeFrameStored: Boolean;\r\n procedure ReadForm(Reader: TReader);\r\n procedure WriteForm(Writer: TWriter);\r\n procedure SetMergeFrame(Value: TWinControl);\r\n function GetActiveForm: TCustomForm;\r\n procedure SetActiveForm(Value: TCustomForm);\r\n protected\r\n procedure DefineProperties(Filer: TFiler); override;\r\n function GetBackForm: TCustomForm; virtual;\r\n function GetForwardForm: TCustomForm; virtual;\r\n procedure Notification(AComponent: TComponent;\r\n Operation: TOperation); override;\r\n procedure DoChange; dynamic;\r\n procedure DoReorder(Deactivated: TCustomForm); dynamic;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n procedure Merge(AForm: TCustomForm; Show: Boolean);\r\n procedure UnmergeMainMenu(AForm: TCustomForm);\r\n procedure MergeMainMenu(AForm: TCustomForm; Force: Boolean);\r\n function GotoForm(AForm: TCustomForm): Boolean;\r\n function GotoFormClass(AFormClass: TFormClass): Boolean;\r\n procedure GoBack;\r\n procedure GoForward;\r\n procedure GotoHistoryIndex(HistoryIndex: Integer);\r\n property FormHistory: TJvFormHistory read FFormHistory;\r\n property ActiveForm: TCustomForm read GetActiveForm write SetActiveForm;\r\n property HistoryCommand: TFormHistoryCommand read FHistoryCommand write FHistoryCommand;\r\n published\r\n property MergeFrame: TWinControl read FMergeFrame write SetMergeFrame stored MergeFrameStored;\r\n property OnGetBackForm: TFormRequestEvent read FOnGetBackForm write FOnGetBackForm;\r\n property OnGetForwardForm: TFormRequestEvent read FOnGetForwardForm write FOnGetForwardForm;\r\n property OnChange: TNotifyEvent read FOnChange write FOnChange;\r\n property OnReorder: TFormReorderEvent read FOnReorder write FOnReorder;\r\n end;\r\n\r\n TJvFormHistory = class(TList)\r\n private\r\n FCurrent: Integer;\r\n FHistoryCapacity: Integer;\r\n procedure SetCurrent(Value: Integer);\r\n procedure SetHistoryCapacity(Value: Integer);\r\n function GetForm(Index: Integer): TCustomForm;\r\n public\r\n constructor Create;\r\n procedure AddForm(AForm: TCustomForm);\r\n procedure DeleteHistoryItem(Index: Integer);\r\n function RemoveItem(Item: TComponent): Boolean;\r\n procedure ResetHistory;\r\n property Current: Integer read FCurrent write SetCurrent;\r\n property HistoryCapacity: Integer read FHistoryCapacity write SetHistoryCapacity;\r\n property Forms[Index: Integer]: TCustomForm read GetForm;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvMergeManager.pas $';\r\n Revision: '$Revision: 13104 $';\r\n Date: '$Date: 2011-09-07 08:50:43 +0200 (mer. 07 sept. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\n\r\n\r\n//=== { TJvMergeManager } ====================================================\r\n\r\nconstructor TJvMergeManager.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FFormHistory := TJvFormHistory.Create;\r\n FHistoryCommand := hcAdd;\r\nend;\r\n\r\ndestructor TJvMergeManager.Destroy;\r\nbegin\r\n inherited Destroy;\r\n // (ahuser) FFormHistory must be freed after inherited Destroy to avoid AVs\r\n // in design mode.\r\n FFormHistory.Free;\r\nend;\r\n\r\nfunction TJvMergeManager.MergeFrameStored: Boolean;\r\nbegin\r\n Result := (MergeFrame <> nil) and not (MergeFrame is TCustomForm);\r\nend;\r\n\r\nfunction TJvMergeManager.IsForm: Boolean;\r\nbegin\r\n Result := (MergeFrame <> nil) and ((MergeFrame = Owner) and (Owner is TCustomForm));\r\nend;\r\n\r\nprocedure TJvMergeManager.ReadForm(Reader: TReader);\r\nbegin\r\n if Reader.ReadBoolean then\r\n if Owner is TCustomForm then\r\n MergeFrame := TWinControl(Owner);\r\nend;\r\n\r\nprocedure TJvMergeManager.WriteForm(Writer: TWriter);\r\nbegin\r\n Writer.WriteBoolean(IsForm);\r\nend;\r\n\r\nprocedure TJvMergeManager.DefineProperties(Filer: TFiler);\r\n\r\n function DoWrite: Boolean;\r\n begin\r\n if Assigned(Filer.Ancestor) then\r\n Result := IsForm <> TJvMergeManager(Filer.Ancestor).IsForm\r\n else\r\n Result := IsForm;\r\n end;\r\n\r\nbegin\r\n inherited DefineProperties(Filer);\r\n Filer.DefineProperty('IsForm', ReadForm, WriteForm, DoWrite);\r\nend;\r\n\r\nprocedure TJvMergeManager.SetMergeFrame(Value: TWinControl);\r\nbegin\r\n if ReplaceComponentReference(Self, Value, TComponent(FMergeFrame)) then\r\n FFormHistory.ResetHistory;\r\nend;\r\n\r\nfunction TJvMergeManager.GetActiveForm: TCustomForm;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := nil;\r\n if (MergeFrame <> nil) and (MergeFrame.ControlCount > 0) then\r\n for I := MergeFrame.ControlCount - 1 downto 0 do\r\n begin\r\n if MergeFrame.Controls[I] is TCustomForm then\r\n begin\r\n Result := TCustomForm(MergeFrame.Controls[I]);\r\n Break;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvMergeManager.SetActiveForm(Value: TCustomForm);\r\nbegin\r\n GotoForm(Value);\r\nend;\r\n\r\nfunction TJvMergeManager.GetBackForm: TCustomForm;\r\nbegin\r\n if FormHistory.Current < 1 then\r\n Result := nil\r\n else\r\n Result := FormHistory.Forms[FormHistory.Current - 1];\r\n if Assigned(FOnGetBackForm) then\r\n FOnGetBackForm(Self, ActiveForm, Result);\r\nend;\r\n\r\nfunction TJvMergeManager.GetForwardForm: TCustomForm;\r\nbegin\r\n if FormHistory.Current >= FormHistory.Count - 1 then\r\n Result := nil\r\n else\r\n Result := FormHistory.Forms[FormHistory.Current + 1];\r\n if Assigned(FOnGetForwardForm) then\r\n FOnGetForwardForm(Self, ActiveForm, Result);\r\nend;\r\n\r\nprocedure TJvMergeManager.Notification(AComponent: TComponent;\r\n Operation: TOperation);\r\nbegin\r\n inherited Notification(AComponent, Operation);\r\n if Operation = opRemove then\r\n begin\r\n if AComponent = MergeFrame then\r\n MergeFrame := nil;\r\n if FormHistory.RemoveItem(AComponent) then\r\n DoChange;\r\n end;\r\nend;\r\n\r\nprocedure TJvMergeManager.DoChange;\r\nbegin\r\n if Assigned(FOnChange) then\r\n FOnChange(Self);\r\nend;\r\n\r\nprocedure TJvMergeManager.DoReorder(Deactivated: TCustomForm);\r\nbegin\r\n if Assigned(FOnReorder) then\r\n FOnReorder(Self, ActiveForm, Deactivated);\r\nend;\r\n\r\nprocedure TJvMergeManager.Merge(AForm: TCustomForm; Show: Boolean);\r\nbegin\r\n MergeForm(MergeFrame, TForm(AForm), alClient, Show);\r\n GotoForm(AForm);\r\nend;\r\n\r\nfunction TJvMergeManager.GotoForm(AForm: TCustomForm): Boolean;\r\nvar\r\n I: Integer;\r\n OldActiveForm: TCustomForm;\r\nbegin\r\n Result := False;\r\n OldActiveForm := ActiveForm;\r\n if MergeFrame = nil then\r\n Exit;\r\n UnmergeMainMenu(OldActiveForm);\r\n for I := 0 to MergeFrame.ControlCount - 1 do\r\n begin\r\n if MergeFrame.Controls[I] = AForm then\r\n begin\r\n AForm.BringToFront;\r\n MergeMainMenu(AForm, False);\r\n case HistoryCommand of\r\n hcNone:\r\n ;\r\n hcAdd:\r\n FormHistory.AddForm(AForm);\r\n hcBack:\r\n FormHistory.Current := FormHistory.Current - 1;\r\n hcForward:\r\n FormHistory.Current := FormHistory.Current + 1;\r\n hcGoto:\r\n ;\r\n end;\r\n HistoryCommand := hcAdd;\r\n DoReorder(OldActiveForm);\r\n\r\n DoChange;\r\n Result := True;\r\n Exit;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJvMergeManager.GotoFormClass(AFormClass: TFormClass): Boolean;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := False;\r\n if MergeFrame = nil then\r\n Exit;\r\n for I := 0 to MergeFrame.ControlCount - 1 do\r\n begin\r\n if MergeFrame.Controls[I] is AFormClass then\r\n begin\r\n Result := GotoForm(MergeFrame.Controls[I] as TCustomForm);\r\n Exit;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvMergeManager.GoBack;\r\nbegin\r\n HistoryCommand := hcBack;\r\n GotoForm(GetBackForm);\r\nend;\r\n\r\nprocedure TJvMergeManager.GoForward;\r\nbegin\r\n HistoryCommand := hcForward;\r\n GotoForm(GetForwardForm);\r\nend;\r\n\r\nprocedure TJvMergeManager.GotoHistoryIndex(HistoryIndex: Integer);\r\nvar\r\n SaveCurrent: Integer;\r\nbegin\r\n SaveCurrent := FormHistory.Current;\r\n FormHistory.Current := HistoryIndex;\r\n try\r\n HistoryCommand := hcGoto;\r\n GotoForm(FormHistory.Forms[HistoryIndex]);\r\n finally\r\n if ActiveForm <> FormHistory.Forms[HistoryIndex] then\r\n FormHistory.Current := SaveCurrent;\r\n end;\r\nend;\r\n\r\n//=== { TJvFormHistory } =====================================================\r\n\r\nconstructor TJvFormHistory.Create;\r\nbegin\r\n inherited Create;\r\n FCurrent := -1;\r\n FHistoryCapacity := 10;\r\nend;\r\n\r\nprocedure TJvFormHistory.SetCurrent(Value: Integer);\r\nbegin\r\n if Value < 0 then\r\n Value := -1;\r\n if Value > Count - 1 then\r\n Value := Count - 1;\r\n FCurrent := Value;\r\nend;\r\n\r\nprocedure TJvFormHistory.SetHistoryCapacity(Value: Integer);\r\nvar\r\n I: Integer;\r\nbegin\r\n if Value < FHistoryCapacity then\r\n for I := 0 to Count - Value do\r\n RemoveItem(Forms[0]);\r\n FHistoryCapacity := Value;\r\nend;\r\n\r\nfunction TJvFormHistory.GetForm(Index: Integer): TCustomForm;\r\nbegin\r\n Result := TCustomForm(Items[Index]);\r\nend;\r\n\r\nprocedure TJvFormHistory.AddForm(AForm: TCustomForm);\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := Count - 1 downto Current + 1 do\r\n DeleteHistoryItem(I);\r\n for I := 0 to Count - HistoryCapacity do\r\n DeleteHistoryItem(0);\r\n if Count < HistoryCapacity then\r\n Add(AForm);\r\n Current := Count - 1;\r\nend;\r\n\r\nprocedure TJvFormHistory.DeleteHistoryItem(Index: Integer);\r\nbegin\r\n if (Index >= 0) and (Index < Count) then\r\n begin\r\n Delete(Index);\r\n if Current > Count - 1 then\r\n Current := Count - 1;\r\n end;\r\nend;\r\n\r\nfunction TJvFormHistory.RemoveItem(Item: TComponent): Boolean;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := False;\r\n for I := Count - 1 downto 0 do\r\n if Items[I] = Item then\r\n begin\r\n DeleteHistoryItem(I);\r\n Result := True;\r\n end;\r\nend;\r\n\r\nprocedure TJvFormHistory.ResetHistory;\r\nbegin\r\n Clear;\r\n Current := -1;\r\nend;\r\n\r\nprocedure TJvMergeManager.MergeMainMenu(AForm: TCustomForm; Force: Boolean);\r\nvar\r\n F: TCustomForm;\r\nbegin\r\n F := GetParentForm(MergeFrame);\r\n if (F <> nil) and (F.Menu <> nil) and (AForm <> nil) and\r\n (AForm.Menu <> nil) and (Force or AForm.Menu.AutoMerge) then\r\n F.Menu.Merge(AForm.Menu);\r\nend;\r\n\r\nprocedure TJvMergeManager.UnmergeMainMenu(AForm: TCustomForm);\r\nvar\r\n F: TCustomForm;\r\nbegin\r\n F := GetParentForm(MergeFrame);\r\n if (F <> nil) and (F.Menu <> nil) and (AForm <> nil) and (AForm.Menu <> nil) then\r\n F.Menu.Unmerge(AForm.Menu);\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvMessageControl.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp:{www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvMessageControl.pas, released on 2004-10-10\r\n\r\nThe Initial Developer of the Original Code is Andr Snepvangers [ASnepvangers att users.sourceforge.net]\r\nPortions created by Andr Snepvangers are Copyright (C) 2004 Andr Snepvangers.\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http:{jvcl.sourceforge.net\r\n\r\nKnown Issues:\r\n It is still possible to move the component in IDE outside the parent.\r\n It could also be called as a feature. Object Treeview shows the\r\n correct parent.\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvMessageControl.pas 12337 2009-06-11 10:42:10Z ahuser $\r\n\r\nunit JvMessageControl;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n SysUtils, Classes, Windows, Messages, Controls, Forms,\r\n JvControlComponent;\r\n\r\ntype\r\n\r\n TJvMessageControl = class(TJvCustomControlComponent)\r\n private\r\n FSavedWinProc: TWndMethod;\r\n FOnMessage: TWndMethod;\r\n protected\r\n procedure SetParent(const Value: TWinControl); override;\r\n procedure ControlWinProc(var Message: TMessage);\r\n public\r\n destructor Destroy; override;\r\n published\r\n property Active;\r\n property OnMessage: TWndMethod read FOnMessage write FOnMessage;\r\n property Parent;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvMessageControl.pas $';\r\n Revision: '$Revision: 12337 $';\r\n Date: '$Date: 2009-06-11 12:42:10 +0200 (jeu. 11 juin 2009) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nprocedure TJvMessageControl.ControlWinProc(var Message: TMessage);\r\nbegin\r\n if Active and Assigned(FOnMessage) then { user message/event handler installed ? }\r\n FOnMessage(Message);\r\n if Message.Result = 0 then\r\n FSavedWinProc(Message); { do the original stuff }\r\nend;\r\n\r\nprocedure TJvMessageControl.SetParent(const Value: TWinControl);\r\nvar\r\n WasActive: Boolean;\r\nbegin\r\n if Value <> Parent then\r\n begin\r\n WasActive := Active;\r\n Active := False;\r\n if Assigned(Parent) then\r\n Parent.WindowProc := FSavedWinProc;\r\n inherited SetParent(Value);\r\n if Assigned(Parent) then\r\n begin\r\n FSavedWinProc := Parent.WindowProc;\r\n Parent.WindowProc := ControlWinProc; { intercept messages }\r\n end;\r\n Active := WasActive;\r\n end;\r\nend;\r\n\r\ndestructor TJvMessageControl.Destroy;\r\nbegin\r\n if Assigned(Parent) and not (csDestroying in Parent.ComponentState) then\r\n Parent.WindowProc := FSavedWinProc;\r\n inherited Destroy;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvMonthCalendar.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvMonthCalendar.PAS, released on 2001-02-28.\r\n\r\nThe Initial Developer of the Original Code is Sbastien Buysse [sbuysse att buypin dott com]\r\nPortions created by Sbastien Buysse are Copyright (C) 2001 Sbastien Buysse.\r\nAll Rights Reserved.\r\n\r\nContributor(s): Michael Beck [mbeck att bigfoot dott com].\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvMonthCalendar.pas 13155 2011-11-06 12:31:20Z ahuser $\r\n\r\nunit JvMonthCalendar;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n Classes,\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n JvExComCtrls;\r\n\r\ntype\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvMonthCalendar = class(TJvExMonthCalendar)\r\n published\r\n property HintColor;\r\n property OnMouseEnter;\r\n property OnMouseLeave;\r\n property OnParentColorChange;\r\n property OnMouseDown;\r\n property OnMouseUp;\r\n property OnMouseMove;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvMonthCalendar.pas $';\r\n Revision: '$Revision: 13155 $';\r\n Date: '$Date: 2011-11-06 13:31:20 +0100 (dim. 06 nov. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvMouseGesture.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvMouseGesture.PAS, released on 2003-07-10.\r\n\r\nThe Initial Developers of the Original Code are: Christian Vogt (christian att fam-vogt dott de)\r\nCopyright (c) 2003 by Christian Vogt\r\nAll Rights Reserved.\r\n\r\nPortions of code based on an idea of Mozilla browser mouse gesture addon\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nDescription:\r\n This unit implements mouse gestures. For this purpose\r\n actually two classes are available. one is the interpreter\r\n and can be used to enhance special components like a grid. In\r\n this case the programmer is responsible to fill matching\r\n OnMouseDown, OnMouseUp and OnMouseMove events of component.\r\n This works fine with MSWINDOWS and UNIX. The second component\r\n installs a hook for a specific application and fires an event\r\n after detecting a mouse gesture (Windows only in this version\r\n \\:-( ).\r\n\r\n Programmers will get a string with the detected gesture from\r\n following matrix:\r\n \r\n == === ==\r\n 7 U 9\r\n L \\* R\r\n 1 D 3\r\n
\r\n\r\n The asterix is the startpoint for the first vector. E.g. a\r\n gesture string \"LU\" means, user has first moved mouse to the\r\n left side and then up. There's no limit for complexity of a\r\n gesture ...\r\n\r\n Note\r\n See demo project for usage ...\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvMouseGesture.pas 13104 2011-09-07 06:50:43Z obones $\r\n\r\nunit JvMouseGesture;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n SysUtils, Classes, Controls, Windows, Messages,\r\n JvComponentBase;\r\n\r\ntype\r\n { Description\r\n Defines, whether or not the hook will be activated automatically or not.\r\n }\r\n TJvActivationMode = (amAppStart, amManual);\r\n\r\n { Description\r\n Defines a complex gesture (two or more letters event)\r\n\r\n }\r\n TOnMouseGestureCustomInterpretation = procedure(Sender: TObject; const AGesture: string) of object;\r\n\r\n { Description\r\n This class implements the basic interpreter. It can be used\r\n to enhance single components, too. E.g., if you want to\r\n enable a grid with gesture feature. For this purpose you have\r\n to do 4 steps:\r\n\r\n 1) Fill the \"OnMouseDown\" event with code like\r\n\r\n\r\n \r\n if Button = mbRight then\r\n JvMouseGesture1.StartMouseGesture(x,y);\r\n \r\n\r\n\r\n 2) Fill the OnMouseMove event with something like\r\n\r\n\r\n \r\n if JvMouseGesture1.TrailActive then\r\n JvMouseGesture1.TrailMouseGesture(x,y);\r\n \r\n\r\n\r\n 3) Now fill the OnMouseUp event\r\n\r\n\r\n \r\n if JvMouseGesture1.TrailActive then\r\n JvMouseGesture1.EndMouseGesture;\r\n \r\n\r\n\r\n 4) Last but not least fill components\r\n\r\n OnJvMouseGestureCustomInterpretation\r\n\r\n XOR\r\n\r\n OnJvMouseGesture\\\r\n\r\n event\r\n\r\n Note:\r\n\r\n\r\n If CustomInterpreation is filled the other events are not\r\n fired!\r\n\r\n See Also\r\n\r\n TJvMouseGestureHook\r\n }\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64 or pidOSX32)]\r\n {$ENDIF RTL230_UP}\r\n TJvMouseGesture = class(TJvComponent)\r\n private\r\n FActive: Boolean;\r\n FTrailX: Integer;\r\n FTrailY: Integer;\r\n FTrailLength: Integer;\r\n FTrailLimit: Integer;\r\n FTrailActive: Boolean;\r\n FTrailStartTime: TDateTime;\r\n FdTolerance: Integer;\r\n FDelay: Integer;\r\n FTrailInterval: Integer;\r\n FGrid: Integer; // tolerance for diagonal movement. See TrailMouseGesture\r\n FGridHalf: Integer; // half of grid, needed for performance\r\n FLastPushed: Char;\r\n FGesture: string;\r\n FGestureList: TStringList;\r\n\r\n FOnMouseGestureRight: TNotifyEvent;\r\n FOnMouseGestureLeft: TNotifyEvent;\r\n FOnMouseGestureUp: TNotifyEvent;\r\n FOnMouseGestureDown: TNotifyEvent;\r\n FOnMouseGestureLeftLowerEdge: TNotifyEvent;\r\n FOnMouseGestureRightUpperEdge: TNotifyEvent;\r\n FOnMouseGestureLeftUpperEdge: TNotifyEvent;\r\n FOnMouseGestureRightLowerEdge: TNotifyEvent;\r\n FOnMouseGestureCancelled: TNotifyEvent;\r\n FOnMouseGestureCustomInterpretation: TOnMouseGestureCustomInterpretation;\r\n { Description\r\n Adds a detected sub gesture to gesture string\r\n }\r\n procedure AddGestureChar(AChar: Char);\r\n procedure SetTrailLimit(const Value: Integer);\r\n procedure SetTrailInterval(const Value: Integer);\r\n procedure SetDelay(const Value: Integer);\r\n procedure SetGrid(const Value: Integer);\r\n { Description\r\n Loads the known gestures for matching events\r\n\r\n Note:\r\n In this version only evaluation of simple mouse gestures are implemented\r\n }\r\n procedure LoadGestureTable;\r\n { Description\r\n Standard setter method for Active\r\n }\r\n procedure SetActive(const Value: Boolean);\r\n protected\r\n procedure DoMouseGestureRight; virtual;\r\n procedure DoMouseGestureLeft; virtual;\r\n procedure DoMouseGestureUp; virtual;\r\n procedure DoMouseGestureDown; virtual;\r\n procedure DoMouseGestureLeftLowerEdge; virtual;\r\n procedure DoMouseGestureRightUpperEdge; virtual;\r\n procedure DoMouseGestureLeftUpperEdge; virtual;\r\n procedure DoMouseGestureRightLowerEdge; virtual;\r\n procedure DoMouseGestureCancelled; virtual;\r\n function DoMouseGestureCustomInterpretation(const AGesture: string): Boolean; virtual;\r\n public\r\n { Description\r\n Standard constructor\r\n }\r\n constructor Create(AOwner: TComponent); override;\r\n { Description\r\n Standard destructor\r\n }\r\n destructor Destroy; override;\r\n { Description\r\n Starts the mouse gesture interpretation\r\n\r\n Parameters:\r\n AMouseX: X coordinate of mouse cursor\r\n AMouseY: Y coordinate of mouse cursor\r\n }\r\n procedure StartMouseGesture(AMouseX, AMouseY: Integer);\r\n { Description\r\n Continues the mouse gesture interpretation during mouse move\r\n\r\n Parameters:\r\n AMouseX: X coordinate of mouse cursor\r\n AMouseY: Y coordinate of mouse cursor\r\n }\r\n procedure TrailMouseGesture(AMouseX, AMouseY: Integer);\r\n { Description\r\n Ends the mouse gesture interpretation and fires an event if a gesture\r\n was found\r\n }\r\n procedure EndMouseGesture;\r\n { Description\r\n The actual length of trail (not of gesture string!!!)\r\n }\r\n property TrailLength: Integer read FTrailLength;\r\n { Description\r\n TRUE, if in detection, otherwise FALSE\r\n }\r\n property TrailActive: Boolean read FTrailActive;\r\n { Description\r\n The gesture string. For string content see description of unit.\r\n }\r\n property Gesture: string read FGesture;\r\n published\r\n { Description\r\n The maximum length of trail (not of gesture string!!!)\r\n Normally never been changed\r\n }\r\n property TrailLimit: Integer read FTrailLimit write SetTrailLimit;\r\n { Description\r\n Trail interval\r\n Normally never been changed\r\n }\r\n property TrailInterval: Integer read FTrailInterval write SetTrailInterval;\r\n { Description\r\n Grid size for detection\r\n Normally never been changed\r\n }\r\n property Grid: Integer read FGrid write SetGrid;\r\n { Description\r\n The maximum delay before cancelling a gesture\r\n Normally never been changed\r\n }\r\n property Delay: Integer read FDelay write SetDelay;\r\n { Description\r\n TRUE if component is active, otherwise FALSE\r\n }\r\n property Active: Boolean read FActive write SetActive;\r\n { Description\r\n Event for own evaluation of detected gesture. If this event is used all\r\n others will be ignored!\r\n }\r\n property OnMouseGestureCustomInterpretation: TOnMouseGestureCustomInterpretation read\r\n FOnMouseGestureCustomInterpretation write FOnMouseGestureCustomInterpretation;\r\n { Description\r\n Event for a simple MOUSE UP gesture\r\n }\r\n property OnMouseGestureCancelled: TNotifyEvent read FOnMouseGestureCancelled write FOnMouseGestureCancelled;\r\n property OnMouseGestureUp: TNotifyEvent read FOnMouseGestureUp write FOnMouseGestureUp;\r\n { Description\r\n Event for a simple MOUSE DOWN gesture\r\n }\r\n property OnMouseGestureDown: TNotifyEvent read FOnMouseGestureDown write FOnMouseGestureDown;\r\n { Description\r\n Event for a simple MOUSE LEFT gesture\r\n }\r\n property OnMouseGestureLeft: TNotifyEvent read FOnMouseGestureLeft write FOnMouseGestureLeft;\r\n { Description\r\n Event for a simple MOUSE RIGHT gesture\r\n }\r\n property OnMouseGestureRight: TNotifyEvent read FOnMouseGestureRight write FOnMouseGestureRight;\r\n { Description\r\n Event for a simple diagonally MOUSE LEFT LOWER EDGE (point 1 in grid) gesture\r\n }\r\n property OnMouseGestureLeftLowerEdge: TNotifyEvent read FOnMouseGestureLeftLowerEdge write\r\n FOnMouseGestureLeftLowerEdge;\r\n { Description\r\n Event for a simple diagonally MOUSE RIGHT LOWER EDGE (point 3 in grid) gesture\r\n }\r\n property OnMouseGestureRightLowerEdge: TNotifyEvent read FOnMouseGestureRightLowerEdge write\r\n FOnMouseGestureRightLowerEdge;\r\n { Description\r\n Event for a simple diagonally MOUSE LEFT UPPER EDGE (point 7 in grid) gesture\r\n }\r\n property OnMouseGestureLeftUpperEdge: TNotifyEvent read FOnMouseGestureLeftUpperEdge write\r\n FOnMouseGestureLeftUpperEdge;\r\n { Description\r\n Event for a simple diagonally MOUSE RIGHT UPPER EDGE (point 9 in grid) gesture\r\n }\r\n property OnMouseGestureRightUpperEdge: TNotifyEvent read FOnMouseGestureRightUpperEdge write\r\n FOnMouseGestureRightUpperEdge;\r\n end;\r\n\r\n { Description\r\n This class implements a application wide mouse hook for mouse gestures.\r\n Programmers get only one event for a detected mouse gesture:\r\n\r\n OnMouseGestureCustomInterpretation\r\n\r\n See Also\r\n TJvMouseGesture\r\n }\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64 or pidOSX32)]\r\n {$ENDIF RTL230_UP}\r\n TJvMouseGestureHook = class(TJvComponent)\r\n private\r\n { Description\r\n True if a hook is installed\r\n }\r\n FHookInstalled: Boolean;\r\n { Description\r\n Field for hook handle\r\n }\r\n FCurrentHook: HHook;\r\n { Description\r\n Field for method pointer\r\n }\r\n FOnMouseGestureCustomInterpretation: TOnMouseGestureCustomInterpretation;\r\n { Description\r\n Field for active state of component\r\n }\r\n FActive: Boolean;\r\n { Description\r\n Field for mouse key\r\n }\r\n FMouseButton: TMouseButton;\r\n { Description\r\n Field for activation mode\r\n }\r\n FActivationMode: TJvActivationMode;\r\n { Description\r\n Standard setter method for evaluation of detected gesture\r\n }\r\n { Description\r\n Standard setter method for Active\r\n }\r\n procedure SetActive(const Value: Boolean);\r\n { Description\r\n Standard setter method for MouseButton\r\n }\r\n procedure SetMouseButton(const Value: TMouseButton);\r\n { Description\r\n Standard setter method for ActivationMode\r\n }\r\n procedure SetActivationMode(const Value: TJvActivationMode);\r\n procedure SetMouseGestureCustomInterpretation(const Value: TOnMouseGestureCustomInterpretation);\r\n function GetMouseGesture: TJvMouseGesture;\r\n protected\r\n { Description\r\n Create the hook. Maybe used in a later version as a new constructor\r\n to enable system wide hooks ...\r\n }\r\n procedure CreateForThreadOrSystem(AOwner: TComponent; ADwThreadID: Cardinal);\r\n function DoMouseGestureCustomInterpretation(const AGesture: string): Boolean; virtual;\r\n public\r\n { Description\r\n Standard constructor\r\n }\r\n constructor Create(AOwner: TComponent); override;\r\n { Description\r\n Standard destructor\r\n }\r\n destructor Destroy; override;\r\n { Description\r\n TRUE if hook was installed successfully\r\n }\r\n property HookInstalled: Boolean read FHookInstalled; //True if a hook is installed\r\n { Description\r\n handle of hook\r\n }\r\n property CurrentHook: HHook read FCurrentHook; //contains the handle of the currently installed hook\r\n property MouseGesture: TJvMouseGesture read GetMouseGesture;\r\n published\r\n { Description\r\n TRUE if component is active, otherwise FALSE. Can be changed during runtime\r\n }\r\n property Active: Boolean read FActive write SetActive;\r\n { Description\r\n If property is set to JvOnAppStart then component will be\r\n activated on start of application, with JvManually you\r\n have to activate detection on your own\r\n }\r\n property ActivationMode: TJvActivationMode read FActivationMode write SetActivationMode;\r\n { Description\r\n Set the mouse key to be used for start/stop gesture\r\n\r\n See Also\r\n TMouseButton\r\n }\r\n property MouseButton: TMouseButton read FMouseButton write SetMouseButton default mbRight;\r\n { Description\r\n Set the event to be executed if a gesture will be detected\r\n }\r\n property OnMouseGestureCustomInterpretation: TOnMouseGestureCustomInterpretation read FOnMouseGestureCustomInterpretation write SetMouseGestureCustomInterpretation;\r\n end;\r\n\r\n\r\n { Description\r\n Hook call back function.\r\n DO NOT USE EXTERN!\r\n }\r\nfunction JvMouseGestureHook(Code: Integer; wParam: Word; lParam: Longword): Longword; stdcall;\r\n\r\n\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvMouseGesture.pas $';\r\n Revision: '$Revision: 13104 $';\r\n Date: '$Date: 2011-09-07 08:50:43 +0200 (mer. 07 sept. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n JvResources, JvTypes;\r\n\r\nconst\r\n JVMG_LEFT = 0;\r\n JVMG_RIGHT = 1;\r\n JVMG_UP = 2;\r\n JVMG_DOWN = 3;\r\n JVMG_LEFTUPPER = 4;\r\n JVMG_RIGHTUPPER = 5;\r\n JVMG_LEFTLOWER = 6;\r\n JVMG_RIGHTLOWER = 7;\r\n\r\nvar\r\n { Description\r\n Object pointer to interpreter class used by hook\r\n }\r\n JvMouseGestureInterpreter: TJvMouseGesture;\r\n { Description\r\n Some global vars to be accessed by call back function ...\r\n }\r\n JvMouseGestureHookAlreadyInstalled: Boolean = False;\r\n //\r\n JvMouseGestureHookActive: Boolean = False;\r\n //\r\n JvMouseButtonDown: Cardinal = WM_RBUTTONDOWN;\r\n //\r\n JvMouseButtonUp: Cardinal = WM_RBUTTONUP;\r\n\r\n JvCurrentHook: HHook = 0; //contains the handle of the currently installed hook\r\n\r\n//=== { TJvMouseGesture } ====================================================\r\n\r\nconstructor TJvMouseGesture.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FGestureList := TStringList.Create;\r\n FGestureList.Sorted := True;\r\n\r\n FDelay := 500;\r\n FTrailLimit := 1000;\r\n FTrailInterval := 2;\r\n FGrid := 15;\r\n FGridHalf := FGrid div 2;\r\n FTrailActive := False;\r\n FdTolerance := 75; // tolerance for diagonal movement. see processCoordinates()\r\n LoadGestureTable;\r\n\r\n FActive := not (csDesigning in ComponentState);\r\nend;\r\n\r\ndestructor TJvMouseGesture.Destroy;\r\nbegin\r\n FTrailActive := False;\r\n FreeAndNil(FGestureList);\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvMouseGesture.LoadGestureTable;\r\nbegin\r\n with FGestureList do\r\n begin\r\n AddObject('L', TObject(JVMG_LEFT));\r\n AddObject('R', TObject(JVMG_RIGHT));\r\n AddObject('U', TObject(JVMG_UP));\r\n AddObject('D', TObject(JVMG_DOWN));\r\n AddObject('1', TObject(JVMG_LEFTLOWER));\r\n AddObject('3', TObject(JVMG_RIGHTLOWER));\r\n AddObject('7', TObject(JVMG_LEFTUPPER));\r\n AddObject('9', TObject(JVMG_RIGHTUPPER));\r\n end;\r\nend;\r\n\r\nprocedure TJvMouseGesture.SetActive(const Value: Boolean);\r\nbegin\r\n if csDesigning in ComponentState then\r\n FActive := False\r\n else\r\n FActive := Value;\r\nend;\r\n\r\nprocedure TJvMouseGesture.SetTrailLimit(const Value: Integer);\r\nbegin\r\n FTrailLimit := Value;\r\n if (FTrailLimit < 100) or (FTrailLimit > 10000) then\r\n FTrailLimit := 1000;\r\nend;\r\n\r\nprocedure TJvMouseGesture.SetTrailInterval(const Value: Integer);\r\nbegin\r\n FTrailInterval := Value;\r\n if (FTrailInterval < 1) or (FTrailInterval > 100) then\r\n FTrailInterval := 2;\r\nend;\r\n\r\nprocedure TJvMouseGesture.SetDelay(const Value: Integer);\r\nbegin\r\n FDelay := Value;\r\n if FDelay < 500 then\r\n FDelay := 500;\r\nend;\r\n\r\nprocedure TJvMouseGesture.SetGrid(const Value: Integer);\r\nbegin\r\n FGrid := Value;\r\n if (FGrid < 10) or (FGrid > 500) then\r\n FGrid := 15;\r\n\r\n FGridHalf := FGrid div 2;\r\nend;\r\n\r\nprocedure TJvMouseGesture.AddGestureChar(AChar: Char);\r\nbegin\r\n if AChar <> FLastPushed then\r\n begin\r\n FGesture := FGesture + AChar;\r\n FLastPushed := AChar;\r\n end;\r\nend;\r\n\r\nprocedure TJvMouseGesture.StartMouseGesture(AMouseX, AMouseY: Integer);\r\nbegin\r\n if not FActive then\r\n Exit;\r\n\r\n FLastPushed := #0;\r\n FGesture := '';\r\n FTrailActive := True;\r\n FTrailLength := 0;\r\n FTrailX := AMouseX;\r\n FTrailY := AMouseY;\r\n FTrailStartTime := now;\r\nend;\r\n\r\nprocedure TJvMouseGesture.TrailMouseGesture(AMouseX, AMouseY: Integer);\r\nvar\r\n locX: Integer;\r\n locY: Integer;\r\n x_dir: Integer;\r\n y_dir: Integer;\r\n tolerancePercent: Double;\r\n x_divide_y: Double;\r\n y_divide_x: Double;\r\n\r\n function InBetween(AValue, AMin, AMax: Double): Boolean;\r\n begin\r\n Result := (AValue >= AMin) and (AValue <= AMax);\r\n end;\r\n\r\nbegin\r\n if not FActive then\r\n Exit;\r\n\r\n if (not FTrailActive) or (FTrailLength > FTrailLimit) then\r\n begin\r\n FTrailActive := False;\r\n Exit;\r\n end;\r\n\r\n try\r\n x_dir := AMouseX - FTrailX;\r\n y_dir := AMouseY - FTrailY;\r\n locX := abs(x_dir);\r\n locY := abs(y_dir);\r\n\r\n // process each half-grid\r\n if (locX >= FGridHalf) or (locY >= FGridHalf) then\r\n begin\r\n // diagonal movement:\r\n // dTolerance = 75 means that a movement is recognized as diagonal when\r\n // x/y or y/x is between 0.25 and 1\r\n tolerancePercent := 1 - FdTolerance / 100;\r\n if locY <> 0 then\r\n x_divide_y := locX / locY\r\n else\r\n x_divide_y := 0;\r\n if locX <> 0 then\r\n y_divide_x := locY / locX\r\n else\r\n y_divide_x := 0;\r\n if (FdTolerance <> 0) and\r\n (InBetween(x_divide_y, tolerancePercent, 1) or\r\n InBetween(y_divide_x, tolerancePercent, 1)) then\r\n begin\r\n if (x_dir < 0) and (y_dir > 0) then\r\n begin\r\n AddGestureChar('1');\r\n end\r\n else\r\n begin\r\n if (x_dir > 0) and (y_dir > 0) then\r\n AddGestureChar('3')\r\n else\r\n begin\r\n if (x_dir < 0) and (y_dir < 0) then\r\n AddGestureChar('7')\r\n else\r\n begin\r\n if (x_dir > 0) and (y_dir < 0) then\r\n AddGestureChar('9');\r\n end;\r\n end;\r\n end;\r\n end // of diaognal\r\n else\r\n begin\r\n // horizontal movement:\r\n if locX > locY then\r\n begin\r\n if x_dir > 0 then\r\n AddGestureChar('R')\r\n else\r\n begin\r\n if x_dir < 0 then\r\n AddGestureChar('L');\r\n end;\r\n end\r\n else\r\n begin\r\n // vertical movement:\r\n if locX < locY then\r\n begin\r\n if y_dir > 0 then\r\n AddGestureChar('D')\r\n else\r\n begin\r\n if y_dir < 0 then\r\n AddGestureChar('U');\r\n end;\r\n end;\r\n end;\r\n end;\r\n end; // of half grid\r\n finally\r\n FTrailX := AMouseX;\r\n FTrailY := AMouseY;\r\n end;\r\nend;\r\n\r\nprocedure TJvMouseGesture.EndMouseGesture;\r\nvar\r\n Index: Integer;\r\nbegin\r\n if not FActive then\r\n Exit;\r\n\r\n FTrailActive := False;\r\n\r\n if FGesture = '' then\r\n begin\r\n DoMouseGestureCancelled;\r\n Exit;\r\n end;\r\n\r\n // check for custom interpretation first\r\n if DoMouseGestureCustomInterpretation(FGesture) then\r\n Exit;\r\n\r\n // if no custom interpretation is implemented we chaeck for known gestures\r\n // and matching events\r\n // CASE indexes are stored sequence independent. So we have to find gesture\r\n // first and get CASE INDEX stored as TObject in Object property. It's a\r\n // simple trick, but works fine ...\r\n Index := FGestureList.IndexOf(FGesture);\r\n if Index > -1 then\r\n Index := Integer(FGestureList.Objects[Index]);\r\n case Index of\r\n JVMG_LEFT:\r\n begin\r\n DoMouseGestureLeft;\r\n end;\r\n JVMG_RIGHT:\r\n begin\r\n DoMouseGestureRight;\r\n end;\r\n JVMG_UP:\r\n begin\r\n DoMouseGestureUp;\r\n end;\r\n JVMG_DOWN:\r\n begin\r\n DoMouseGestureDown;\r\n end;\r\n JVMG_LEFTLOWER:\r\n begin\r\n DoMouseGestureLeftLowerEdge;\r\n end;\r\n JVMG_RIGHTLOWER:\r\n begin\r\n DoMouseGestureRightLowerEdge;\r\n end;\r\n JVMG_LEFTUPPER:\r\n begin\r\n DoMouseGestureLeftUpperEdge;\r\n end;\r\n JVMG_RIGHTUPPER:\r\n begin\r\n DoMouseGestureRightUpperEdge;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvMouseGesture.DoMouseGestureCancelled;\r\nbegin\r\n if Assigned(FOnMouseGestureCancelled) then\r\n FOnMouseGestureCancelled(Self);\r\nend;\r\n\r\nfunction TJvMouseGesture.DoMouseGestureCustomInterpretation(const AGesture: string): Boolean;\r\nbegin\r\n Result := Assigned(FOnMouseGestureCustomInterpretation);\r\n if Result then\r\n FOnMouseGestureCustomInterpretation(Self, FGesture);\r\nend;\r\n\r\nprocedure TJvMouseGesture.DoMouseGestureDown;\r\nbegin\r\n if Assigned(FOnMouseGestureDown) then\r\n FOnMouseGestureDown(Self);\r\nend;\r\n\r\nprocedure TJvMouseGesture.DoMouseGestureLeft;\r\nbegin\r\n if Assigned(FOnMouseGestureLeft) then\r\n FOnMouseGestureLeft(Self);\r\nend;\r\n\r\nprocedure TJvMouseGesture.DoMouseGestureLeftLowerEdge;\r\nbegin\r\n if Assigned(FOnMouseGestureLeftLowerEdge) then\r\n FOnMouseGestureLeftLowerEdge(Self);\r\nend;\r\n\r\nprocedure TJvMouseGesture.DoMouseGestureLeftUpperEdge;\r\nbegin\r\n if Assigned(FOnMouseGestureLeftUpperEdge) then\r\n FOnMouseGestureLeftUpperEdge(Self);\r\nend;\r\n\r\nprocedure TJvMouseGesture.DoMouseGestureRight;\r\nbegin\r\n if Assigned(FOnMouseGestureRight) then\r\n FOnMouseGestureRight(Self);\r\nend;\r\n\r\nprocedure TJvMouseGesture.DoMouseGestureRightLowerEdge;\r\nbegin\r\n if Assigned(FOnMouseGestureRightLowerEdge) then\r\n FOnMouseGestureRightLowerEdge(Self);\r\nend;\r\n\r\nprocedure TJvMouseGesture.DoMouseGestureRightUpperEdge;\r\nbegin\r\n if Assigned(FOnMouseGestureRightUpperEdge) then\r\n FOnMouseGestureRightUpperEdge(Self);\r\nend;\r\n\r\nprocedure TJvMouseGesture.DoMouseGestureUp;\r\nbegin\r\n if Assigned(FOnMouseGestureUp) then\r\n FOnMouseGestureUp(Self);\r\nend;\r\n\r\n//=== { TJvMouseGestureHook } ================================================\r\n\r\nconstructor TJvMouseGestureHook.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n CreateForThreadOrSystem(AOwner, MainThreadID); // hook for complete application\r\nend;\r\n\r\ndestructor TJvMouseGestureHook.Destroy;\r\n\r\nbegin\r\n FreeAndNil(JvMouseGestureInterpreter);\r\n\r\n if JvMouseGestureHookAlreadyInstalled then\r\n JvMouseGestureHookAlreadyInstalled := UnhookWindowsHookEx(JvCurrentHook);\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvMouseGestureHook.CreateForThreadOrSystem(AOwner: TComponent; ADwThreadID: Cardinal);\r\n\r\nbegin\r\n if JvMouseGestureHookAlreadyInstalled then\r\n raise EJVCLException.CreateRes(@RsECannotHookTwice);\r\n\r\n JvMouseGestureInterpreter := TJvMouseGesture.Create(nil);\r\n FMouseButton := mbRight;\r\n if csDesigning in ComponentState then\r\n begin\r\n FActive := False;\r\n Exit;\r\n end;\r\n\r\n FActive := FActivationMode = amAppStart;\r\n\r\n //install hook\r\n FCurrentHook := SetWindowsHookEx(WH_MOUSE, @JvMouseGestureHook, 0, ADwThreadID);\r\n\r\n //return True if it worked (read only for user). User should never see a\r\n //global var like MouseGestureHookAlreadyInstalled\r\n FHookInstalled := FCurrentHook <> 0;\r\n\r\n // global remember, internal use only\r\n JvMouseGestureHookAlreadyInstalled := FHookInstalled;\r\n JvCurrentHook := FCurrentHook;\r\n\r\n // map event\r\n if Assigned(FOnMouseGestureCustomInterpretation) then\r\n JvMouseGestureInterpreter.OnMouseGestureCustomInterpretation :=\r\n FOnMouseGestureCustomInterpretation\r\n else\r\n JvMouseGestureInterpreter.OnMouseGestureCustomInterpretation := nil;\r\nend;\r\n\r\nfunction TJvMouseGestureHook.DoMouseGestureCustomInterpretation(const AGesture: string): Boolean;\r\nbegin\r\n Result := Assigned(FOnMouseGestureCustomInterpretation);\r\n if Result then\r\n FOnMouseGestureCustomInterpretation(Self, AGesture);\r\nend;\r\n\r\nprocedure TJvMouseGestureHook.SetActivationMode(const Value: TJvActivationMode);\r\nbegin\r\n FActivationMode := Value;\r\nend;\r\n\r\nprocedure TJvMouseGestureHook.SetActive(const Value: Boolean);\r\nbegin\r\n if csDesigning in ComponentState then\r\n FActive := False\r\n else\r\n FActive := Value;\r\n\r\n JvMouseGestureHookActive := FActive;\r\nend;\r\n\r\nprocedure TJvMouseGestureHook.SetMouseButton(const Value: TMouseButton);\r\nbegin\r\n FMouseButton := Value;\r\n case Value of\r\n mbLeft:\r\n begin\r\n JvMouseButtonDown := WM_LBUTTONDOWN;\r\n JvMouseButtonUp := WM_LBUTTONUP;\r\n end;\r\n mbMiddle:\r\n begin\r\n JvMouseButtonDown := WM_MBUTTONDOWN;\r\n JvMouseButtonUp := WM_MBUTTONUP;\r\n end;\r\n mbRight:\r\n begin\r\n JvMouseButtonDown := WM_RBUTTONDOWN;\r\n JvMouseButtonUp := WM_RBUTTONUP;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvMouseGestureHook.SetMouseGestureCustomInterpretation(\r\n const Value: TOnMouseGestureCustomInterpretation);\r\nbegin\r\n FOnMouseGestureCustomInterpretation := Value;\r\n if Assigned(JvMouseGestureInterpreter) then\r\n JvMouseGestureInterpreter.OnMouseGestureCustomInterpretation := Value;\r\nend;\r\n\r\nfunction TJvMouseGestureHook.GetMouseGesture: TJvMouseGesture;\r\nbegin\r\n Result := JvMouseGestureInterpreter;\r\nend;\r\n\r\n//============================================================================\r\n\r\n\r\nfunction JvMouseGestureHook(Code: Integer; wParam: Word; lParam: Longword): Longword; stdcall;\r\nvar\r\n locY: Integer;\r\n locX: Integer;\r\nbegin\r\n if (Code >= 0) and (JvMouseGestureHookActive) then\r\n begin\r\n with PMouseHookStruct(lParam)^ do\r\n begin\r\n locX := pt.X;\r\n locY := pt.Y;\r\n end;\r\n\r\n if wParam = WM_MOUSEMOVE then\r\n JvMouseGestureInterpreter.TrailMouseGesture(locX, locY);\r\n if wParam = JvMouseButtonDown then\r\n JvMouseGestureInterpreter.StartMouseGesture(locX, locY)\r\n else\r\n if wParam = JvMouseButtonUp then\r\n JvMouseGestureInterpreter.EndMouseGesture;\r\n end;\r\n Result := CallNextHookEx(JvCurrentHook, Code, wParam, lParam);\r\nend;\r\n\r\n\r\n\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvMouseTimer.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvMouseTimerU.PAS, released on 2000-11-22.\r\n\r\nThe Initial Developer of the Original Code is Peter Below <100113 dott 1101 att compuserve dott com>\r\nPortions created by Peter Below are Copyright (C) 2000 Peter Below.\r\nAll Rights Reserved.\r\n\r\nContributor(s): ______________________________________.\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nDescription:\r\n Returns interface to mousetimer singleton. This interface can be used\r\n by objects relying on CM_MOUSEENTER/CM_MOUSELEAVE messages to make sure\r\n they get a CM_MOUSELEAVE under all circumstances if the mouse leaves\r\n their area.\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvMouseTimer.pas 12845 2010-09-16 20:22:55Z jfudickar $\r\n\r\nunit JvMouseTimer;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, Controls, ExtCtrls,\r\n SysUtils, Classes;\r\n\r\ntype\r\n IMouseTimer = interface\r\n ['{94757B20-A74B-11D4-8CF8-CABD69ABF116}']\r\n procedure Attach(AControl: TControl);\r\n procedure Detach(AControl: TControl);\r\n end;\r\n\r\nfunction MouseTimer: IMouseTimer;\r\nfunction IsValidMouseTimer: Boolean;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvMouseTimer.pas $';\r\n Revision: '$Revision: 12845 $';\r\n Date: '$Date: 2010-09-16 22:22:55 +0200 (jeu. 16 sept. 2010) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\n\r\ntype\r\n TControlAccessProtected = class(TControl);\r\n\r\n TJvMouseTimerNotify = class(TComponent)\r\n protected\r\n procedure Notification(AComponent: TComponent; Operation: TOperation); override;\r\n end;\r\n\r\n TJvMouseTimer = class(TInterfacedObject, IMouseTimer)\r\n private\r\n FTimer: TTimer;\r\n FCurrentControl: TControlAccessProtected;\r\n FNotify: TJvMouseTimerNotify;\r\n procedure TimerTick(Sender: TObject);\r\n protected\r\n { Methods of the IMouseTimer interface }\r\n procedure Attach(AControl: TControl);\r\n procedure Detach(AControl: TControl);\r\n public\r\n constructor Create;\r\n destructor Destroy; override;\r\n end;\r\n\r\nvar\r\n InternalMouseTimer: IMouseTimer;\r\n\r\nfunction MouseTimer: IMouseTimer;\r\nbegin\r\n if not Assigned(InternalMouseTimer) then\r\n InternalMouseTimer := TJvMouseTimer.Create;\r\n { Note: object will be destroyed automatically during unit finalization\r\n through reference counting. }\r\n Result := InternalMouseTimer;\r\nend;\r\n\r\nfunction IsValidMouseTimer: Boolean;\r\nbegin\r\n Result := Assigned(InternalMouseTimer);\r\nend;\r\n\r\nprocedure TJvMouseTimerNotify.Notification(AComponent: TComponent; Operation: TOperation);\r\nbegin\r\n inherited Notification(AComponent, Operation);\r\n if IsValidMouseTimer and (Operation = opRemove) and (AComponent is TControl) then\r\n MouseTimer.Detach(TControl(AComponent));\r\nend;\r\n\r\n\r\nconstructor TJvMouseTimer.Create;\r\nbegin\r\n inherited Create;\r\n FTimer := TTimer.Create(nil);\r\n FTimer.Enabled := False;\r\n FTimer.Interval := 200;\r\n FTimer.OnTimer := TimerTick;\r\nend;\r\n\r\ndestructor TJvMouseTimer.Destroy;\r\nbegin\r\n FTimer.Free;\r\n FNotify.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvMouseTimer.Attach(AControl: TControl);\r\nbegin\r\n FTimer.Enabled := False;\r\n if FCurrentControl <> nil then\r\n try\r\n FCurrentControl.RemoveFreeNotification(FNotify);\r\n FCurrentControl.Perform(CM_MOUSELEAVE, 0, 0);\r\n except\r\n { Ignore exception in case control has been destroyed already }\r\n end;\r\n FCurrentControl := TControlAccessProtected(AControl);\r\n if FCurrentControl <> nil then\r\n begin\r\n if not Assigned(FNotify) then\r\n FNotify := TJvMouseTimerNotify.Create(nil);\r\n FCurrentControl.FreeNotification(FNotify);\r\n FTimer.Enabled := True;\r\n end;\r\nend;\r\n\r\nprocedure TJvMouseTimer.Detach(AControl: TControl);\r\nbegin\r\n if AControl = FCurrentControl then\r\n begin\r\n FTimer.Enabled := False;\r\n if Assigned(FNotify) and (FCurrentControl <> nil) then\r\n FCurrentControl.RemoveFreeNotification(FNotify);\r\n FCurrentControl := nil;\r\n end;\r\nend;\r\n\r\nprocedure TJvMouseTimer.TimerTick(Sender: TObject);\r\nvar\r\n Pt: TPoint;\r\n R: TRect;\r\nbegin\r\n try\r\n { control may have been destroyed, so operations on it may crash.\r\n trap that and detach the control on exception. }\r\n if FCurrentControl = nil then\r\n FTimer.Enabled := False // paranoia\r\n else\r\n begin\r\n GetCursorPos(Pt);\r\n R := FCurrentControl.BoundsRect;\r\n if Assigned(FCurrentControl.Parent) then\r\n MapWindowPoints(FCurrentControl.Parent.Handle, HWND_DESKTOP, R, 2);\r\n if not PtInRect(R, Pt) then\r\n FCurrentControl.Perform(CM_MOUSELEAVE, 0, 0);\r\n end;\r\n except\r\n Detach(FCurrentControl);\r\n end;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvMovableBevel.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvMovableBevel.PAS, released on 2002-07-03.\r\n\r\nThe Initial Developer of the Original Code is John Kozikopulos [Stdreamer att Excite dott com]\r\nPortions created by John Kozikopulos are Copyright (C) 2002 John Kozikopulos.\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvMovableBevel.pas 13104 2011-09-07 06:50:43Z obones $\r\n\r\nunit JvMovableBevel;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n SysUtils, Classes,\r\n Windows, Messages, Controls, Forms, ExtCtrls,\r\n JvExExtCtrls;\r\n\r\ntype\r\n TJvBevelScrollTextDirection = (tdNone, tdUpToDown, tdDownToUp, tdLeftToRight,\r\n tdRightToLeft, tdTopLeftToBottomRight, tdTopRightToBottomLeft,\r\n tdBottomLeftToTopRight, tdBottomRightToTopLeft);\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvMovableBevel = class(TJvExBevel)\r\n private\r\n FStartX: Integer;\r\n FStartY: Integer;\r\n FStartPoint: TPoint;\r\n FMinSize: Integer;\r\n FMoving: Boolean; // If True then we are moving the object around.\r\n FSizing: Boolean; // if True then we are sizing the object;\r\n FDirection: TJvBevelScrollTextDirection;\r\n FBorderSize: Byte;\r\n FOnMoving: TNotifyEvent;\r\n FOnMoved: TNotifyEvent;\r\n FOnSizing: TNotifyEvent;\r\n FOnSized: TNotifyEvent;\r\n protected\r\n procedure DoMove(Shift: TShiftState; DeltaX, DeltaY: Integer);\r\n procedure DoSize(Shift: TShiftState; DeltaX, DeltaY: Integer);\r\n procedure SelectCursor(X, Y: Integer);\r\n procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;\r\n procedure MouseDown(Button: TMouseButton; Shift: TShiftState;\r\n X, Y: Integer); override;\r\n procedure MouseUp(Button: TMouseButton; Shift: TShiftState;\r\n X, Y: Integer); override;\r\n procedure MouseEnter(Control: TControl); override;\r\n procedure MouseLeave(Control: TControl); override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n published\r\n property BorderSize: Byte read FBorderSize write FBorderSize default 4;\r\n property OnMoving: TNotifyEvent read FOnMoving write FOnMoving;\r\n property OnSizing: TNotifyEvent read FOnSizing write FOnSizing;\r\n property OnMoved: TNotifyEvent read FOnMoved write FOnMoved;\r\n property OnSized: TNotifyEvent read FOnSized write FOnSized;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvMovableBevel.pas $';\r\n Revision: '$Revision: 13104 $';\r\n Date: '$Date: 2011-09-07 08:50:43 +0200 (mer. 07 sept. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\n\r\nconstructor TJvMovableBevel.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n Shape := bsFrame;\r\n Style := bsRaised;\r\n FBorderSize := 4;\r\n FMinSize := 8;\r\nend;\r\n\r\nprocedure TJvMovableBevel.DoMove(Shift: TShiftState; DeltaX, DeltaY: Integer);\r\nbegin\r\n // Must work on it in order to make expand and shrink the way coreldraw does when\r\n // shift and ctrl keys are pressed.\r\n { If ssCtrl in shift then\r\n begin\r\n if Abs(FStartPoint.X - Left) < Abs(FStartPoint.Y - Top) then\r\n begin\r\n Top := Top + DeltaY;\r\n Left:=FStartX;\r\n end;\r\n if Abs(FStartPoint.X - Left) > Abs(FStartPoint.Y - Top) then\r\n begin\r\n Left := Left + DeltaX;\r\n Top := FStartY;\r\n end;\r\n if Abs(FStartPoint.X - Left) = Abs(FStartPoint.Y - Top) then\r\n begin\r\n Top := Top + DeltaY;\r\n Left := Left + DeltaX;\r\n end\r\n end\r\n else\r\n begin }\r\n Top := Top + DeltaY;\r\n Left := Left + DeltaX;\r\n // end\r\nend;\r\n\r\nprocedure TJvMovableBevel.DoSize(Shift: TShiftState; DeltaX, DeltaY: Integer);\r\nbegin\r\n case FDirection of\r\n tdUpToDown:\r\n begin\r\n Height := Height + DeltaY;\r\n Top := Top - DeltaY;\r\n end;\r\n tdDownToUp:\r\n Height := FStartY - DeltaY;\r\n tdLeftToRight:\r\n begin\r\n Width := Width + DeltaX;\r\n Left := Left - DeltaX;\r\n end;\r\n tdRightToLeft:\r\n Width := FStartX - DeltaX;\r\n tdTopLeftToBottomRight:\r\n begin\r\n Top := Top - DeltaY;\r\n Left := Left - DeltaX;\r\n Height := Height + DeltaY;\r\n Width := Width + DeltaX;\r\n end;\r\n tdTopRightToBottomLeft:\r\n begin\r\n Height := Height + DeltaY;\r\n Width := FStartX - DeltaX;\r\n Top := Top - DeltaY;\r\n end;\r\n tdBottomLeftToTopRight:\r\n begin\r\n Left := Left - DeltaX;\r\n Height := FStartY - DeltaY;\r\n Width := Width + DeltaX;\r\n end;\r\n tdBottomRightToTopLeft:\r\n begin\r\n Height := FStartY - DeltaY;\r\n Width := FStartX - DeltaX;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvMovableBevel.SelectCursor(X, Y: longint);\r\nbegin\r\n if (Y > 0) and (Y <= FBorderSize) then\r\n begin\r\n if (X > 0) and (X <= FBorderSize) then\r\n begin\r\n Screen.Cursor := crSizeNWSE;\r\n FDirection := tdTopLeftToBottomRight;\r\n end\r\n else\r\n if (X >= Width - FBorderSize) and (X < Width) then\r\n begin\r\n Screen.Cursor := crSizeNESW;\r\n FDirection := tdTopRightToBottomLeft;\r\n end\r\n else\r\n begin\r\n Screen.Cursor := crSizeNS;\r\n FDirection := tdUpToDown;\r\n end;\r\n end\r\n else\r\n if (Y >= Height - FBorderSize) and (Y < Height) then\r\n begin\r\n if (X > 0) and (X <= FBorderSize) then\r\n begin\r\n Screen.Cursor := crSizeNESW;\r\n FDirection := tdBottomLeftToTopRight;\r\n end\r\n else\r\n if (X >= Width - FBorderSize) and (X < Width) then\r\n begin\r\n Screen.Cursor := crSizeNWSE;\r\n FDirection := tdBottomRightToTopLeft;\r\n end\r\n else\r\n begin\r\n Screen.Cursor := crSizeNS;\r\n FDirection := tdDownToUp;\r\n end;\r\n end\r\n else\r\n if (X >= 1) and (X <= FBorderSize) then\r\n begin\r\n Screen.Cursor := crSizeWE;\r\n FDirection := tdLeftToRight;\r\n end\r\n else\r\n if (X >= Width - FBorderSize) and (X < Width) then\r\n begin\r\n Screen.Cursor := crSizeWE;\r\n FDirection := tdRightToLeft;\r\n end\r\n else\r\n begin\r\n Screen.Cursor := crDefault;\r\n FDirection := tdNone;\r\n end\r\nend;\r\n\r\nprocedure TJvMovableBevel.MouseMove(Shift: TShiftState; X, Y: Integer);\r\n//const\r\n// WM_MOVE = $0003;\r\nbegin\r\n if FMoving then\r\n DoMove(Shift, X - FStartX, Y - FStartY)\r\n else\r\n if FSizing then\r\n DoSize(Shift, FStartX - X, FStartY - Y)\r\n else\r\n SelectCursor(X, Y);\r\n inherited MouseMove(Shift, X, Y);\r\nend;\r\n\r\nprocedure TJvMovableBevel.MouseDown(Button: TMouseButton; Shift: TShiftState;\r\n X, Y: Integer);\r\nbegin\r\n if FDirection > tdNone then\r\n begin\r\n FSizing := True;\r\n if Assigned(FOnSizing) then\r\n FOnSizing(Self);\r\n end\r\n else\r\n begin\r\n FMoving := True;\r\n if Assigned(FOnMoving) then\r\n FOnMoving(Self);\r\n end;\r\n FStartPoint := Point(Left, Top);\r\n FStartX := X;\r\n FStartY := Y;\r\n inherited MouseDown(Button, Shift, X, Y);\r\nend;\r\n\r\n\r\nprocedure TJvMovableBevel.MouseUp(Button: TMouseButton; Shift: TShiftState;\r\nX, Y: Integer);\r\nbegin\r\n SelectCursor(X, Y);\r\n FStartX := 0;\r\n FStartY := 0;\r\n if Height < 0 then\r\n begin\r\n Top := Top + Height;\r\n Height := Abs(Height);\r\n end;\r\n if Width < 0 then\r\n begin\r\n Left := Left + Width;\r\n Width := Abs(Width);\r\n end;\r\n inherited MouseUp(Button, Shift, X, Y);\r\n if FMoving and Assigned(FOnMoved) then\r\n FOnMoved(Self);\r\n if FSizing and Assigned(FOnSized) then\r\n FOnSized(Self);\r\n FMoving := False;\r\n FSizing := False;\r\nend;\r\n\r\n\r\n//Procedure TJvMovableBevel.SelectCursor(X, Y: Longint);\r\n//begin\r\n// if Y in [0..FBorderSize] then\r\n// begin\r\n// If X in [0..FBorderSize] then\r\n// begin\r\n// Screen.Cursor:= crsizenwse;\r\n// FDirection := tdTopLeftToBottomRight;\r\n// end\r\n// else\r\n// if X in [Width-FBorderSize..Width] then\r\n// begin\r\n// Screen.Cursor := crsizenesw;\r\n// FDirection := tdTopRightToBottomLeft;\r\n// end\r\n// else\r\n// begin\r\n// Screen.Cursor := crsizens;\r\n// FDirection := tdUpToDown;\r\n// end;\r\n// end\r\n// else\r\n// if Y in [Height-FBorderSize..Height] then\r\n// begin\r\n// If X in [0..FBorderSize] then\r\n// begin\r\n// Screen.Cursor:= crsizenesw;\r\n// FDirection := tdBottomLeftToTopRight;\r\n// end\r\n// else\r\n// if X in [Width-FBorderSize..Width] then\r\n// begin\r\n// Screen.Cursor := crsizenwse;\r\n// FDirection := tdBottomRightToTopLeft;\r\n// end\r\n// else\r\n// begin\r\n// Screen.Cursor := crSizeNS;\r\n// FDirection := tdDownToUp;\r\n// end;\r\n// end\r\n// else\r\n// if (X in [1..FBorderSize]) then\r\n// begin\r\n// Screen.Cursor := crsizeWE;\r\n// FDirection := tdLeftToRight;\r\n// end\r\n// else\r\n// if (X in [Width-FBorderSize..Width]) then\r\n// begin\r\n// Screen.Cursor := crsizeWE;\r\n// FDirection := tdRightToLeft;\r\n// end\r\n// else\r\n// begin\r\n// Screen.Cursor := crdefault;\r\n// FDirection := tdNone;\r\n// end\r\n//end;{}\r\n\r\nprocedure TJvMovableBevel.MouseEnter(Control: TControl);\r\nvar\r\n Pos: TPoint;\r\nbegin\r\n if csDesigning in ComponentState then\r\n Exit;\r\n Pos := ScreenToClient(Mouse.CursorPos);\r\n SelectCursor(Pos.X, Pos.Y);\r\n inherited MouseEnter(Control);\r\nend;\r\n\r\nprocedure TJvMovableBevel.MouseLeave(Control: TControl);\r\nbegin\r\n if csDesigning in ComponentState then\r\n Exit;\r\n if (not FMoving) and (not FSizing) then\r\n begin\r\n Screen.Cursor := crDefault;\r\n FDirection := tdNone;\r\n end;\r\n inherited MouseLeave(Control);\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvNTEventLog.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not Use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvEventLog.PAS, released on 2002-09-02.\r\n\r\nThe Initial Developer of the Original Code is Fernando Silva [fernando dott silva att myrealbox dott com]\r\nPortions created by Fernando Silva are Copyright (C) 2002 Fernando Silva.\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvNTEventLog.pas 13104 2011-09-07 06:50:43Z obones $\r\n\r\nunit JvNTEventLog;\r\n\r\n{$I jvcl.inc}\r\n{$I windowsonly.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n {$IFDEF MSWINDOWS}\r\n Windows,\r\n {$ENDIF MSWINDOWS}\r\n Classes, SysUtils,\r\n JvComponentBase, JvTypes;\r\n\r\ntype\r\n TNotifyChangeEventLog = class;\r\n TJvNTEventLogRecord = class;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvNTEventLog = class(TJvComponent)\r\n private\r\n FLogHandle: THandle;\r\n FLog: string;\r\n FServer: string;\r\n FSource: string;\r\n FActive: Boolean;\r\n FLastError: Cardinal;\r\n FOnChange: TNotifyEvent;\r\n FNotifyThread: TNotifyChangeEventLog;\r\n FEventRecord: TJvNTEventLogRecord;\r\n procedure SetActive(Value: Boolean);\r\n procedure SetServer(const Value: string);\r\n procedure SetSource(const Value: string);\r\n procedure SetLog(const Value: string);\r\n function GetEventCount: Cardinal;\r\n procedure SeekRecord(N: Cardinal);\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n procedure Open;\r\n procedure Close;\r\n procedure First;\r\n procedure Last;\r\n function Eof: Boolean;\r\n procedure Next;\r\n procedure Seek(N: Cardinal);\r\n procedure ReadEventLogs(AStrings: TStrings);\r\n property EventCount: Cardinal read GetEventCount;\r\n property EventRecord: TJvNTEventLogRecord read FEventRecord;\r\n published\r\n property Server: string read FServer write SetServer;\r\n property Source: string read FSource write SetSource;\r\n property Log: string read FLog write SetLog;\r\n property Active: Boolean read FActive write SetActive;\r\n property OnChange: TNotifyEvent read FOnChange write FOnChange;\r\n end;\r\n\r\n TNotifyChangeEventLog = class(TJvCustomThread)\r\n private\r\n FEventLog: TJvNTEventLog;\r\n FEventHandle: THandle;\r\n procedure DoChange;\r\n protected\r\n procedure Execute; override;\r\n public\r\n constructor Create(AOwner: TComponent);\r\n end;\r\n\r\n TJvNTEventLogRecord = class(TObject)\r\n private\r\n FEventLog: TJvNTEventLog;\r\n FCurrentRecord: Pointer;\r\n FOwner: TComponent;\r\n function GetRecordNumber: Cardinal;\r\n function GetDateTime: TDateTime;\r\n function GetID: DWORD;\r\n function GetType: string;\r\n function GetStringCount: DWORD;\r\n function GetCategory: Cardinal;\r\n function GetSource: string;\r\n function GetComputer: string;\r\n function GetSID: PSID;\r\n function GetString(Index: Cardinal): string;\r\n function GetMessageText: string;\r\n function GetUsername: string;\r\n public\r\n constructor Create(AOwner: TComponent);\r\n property RecordNumber: Cardinal read GetRecordNumber;\r\n property DateTime: TDateTime read GetDateTime;\r\n property EventType: string read GetType;\r\n property Category: Cardinal read GetCategory;\r\n property Source: string read GetSource;\r\n property Computer: string read GetComputer;\r\n property ID: DWORD read GetID;\r\n property StringCount: DWORD read GetStringCount;\r\n property SID: PSID read GetSID;\r\n property EventString[Index: Cardinal]: string read GetString;\r\n property MessageText: string read GetMessageText;\r\n property UserName: string read GetUsername;\r\n property Owner: TComponent read FOwner;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvNTEventLog.pas $';\r\n Revision: '$Revision: 13104 $';\r\n Date: '$Date: 2011-09-07 08:50:43 +0200 (mer. 07 sept. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n Registry,\r\n JvResources;\r\n\r\nconst\r\n EVENTLOG_SEQUENTIAL_READ = $0001;\r\n EVENTLOG_SEEK_READ = $0002;\r\n EVENTLOG_FORWARDS_READ = $0004;\r\n EVENTLOG_BACKWARDS_READ = $0008;\r\n\r\n cEventLogBaseKey = 'SYSTEM\\CurrentControlSet\\Services\\EventLog';\r\n\r\ntype\r\n PEventLogRecord = ^TEventLogRecord;\r\n TEventLogRecord = record\r\n Length: DWORD; // Length of full record\r\n Reserved: DWORD; // Used by the service\r\n RecordNumber: DWORD; // Absolute record number\r\n TimeGenerated: DWORD; // Seconds since 1-1-1970\r\n TimeWritten: DWORD; // Seconds since 1-1-1970\r\n EventID: DWORD;\r\n EventType: WORD;\r\n NumStrings: WORD;\r\n EventCategory: WORD;\r\n ReservedFlags: WORD; // For Use with paired events (auditing)\r\n ClosingRecordNumber: DWORD; // For Use with paired events (auditing)\r\n StringOffset: DWORD; // Offset from beginning of record\r\n UserSidLength: DWORD;\r\n UserSidOffset: DWORD;\r\n DataLength: DWORD;\r\n DataOffset: DWORD; // Offset from beginning of record\r\n end;\r\n\r\n//=== { TJvNTEventLog } ======================================================\r\n\r\nconstructor TJvNTEventLog.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FLog := '';\r\n FSource := '';\r\n FOnChange := nil;\r\n FNotifyThread := nil;\r\n FEventRecord := TJvNTEventLogRecord.Create(Self);\r\nend;\r\n\r\ndestructor TJvNTEventLog.Destroy;\r\nbegin\r\n Close;\r\n FEventRecord.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvNTEventLog.SetActive(Value: Boolean);\r\nbegin\r\n if Value <> FActive then\r\n begin\r\n if csDesigning in ComponentState then\r\n FActive := Value\r\n else\r\n if Value then\r\n Open\r\n else\r\n Close;\r\n end;\r\nend;\r\n\r\nprocedure TJvNTEventLog.SetServer(const Value: string);\r\nvar\r\n OldActive: Boolean;\r\nbegin\r\n if FServer <> Value then\r\n begin\r\n OldActive := Active;\r\n Active := False;\r\n FServer := Value;\r\n Active := OldActive;\r\n end\r\nend;\r\n\r\nprocedure TJvNTEventLog.SetSource(const Value: string);\r\nvar\r\n OldActive: Boolean;\r\nbegin\r\n if FSource <> Value then\r\n begin\r\n OldActive := Active;\r\n Active := False;\r\n FSource := Value;\r\n Active := OldActive;\r\n end\r\nend;\r\n\r\nprocedure TJvNTEventLog.SetLog(const Value: string);\r\nvar\r\n OldActive: Boolean;\r\nbegin\r\n if FLog <> Value then\r\n begin\r\n OldActive := Active;\r\n Active := False;\r\n FLog := Value;\r\n Active := OldActive;\r\n end\r\nend;\r\n\r\nfunction TJvNTEventLog.GetEventCount: Cardinal;\r\nbegin\r\n if Active then\r\n GetNumberOfEventLogRecords(FLogHandle, Result)\r\n else\r\n Result := 0;\r\nend;\r\n\r\nprocedure TJvNTEventLog.Open;\r\nbegin\r\n if Source <> '' then\r\n begin\r\n Close;\r\n FLogHandle := OpenEventLog(PChar(Server), PChar(Source));\r\n if FLogHandle = 0 then\r\n RaiseLastOSError;\r\n FNotifyThread := TNotifyChangeEventLog.Create(Self);\r\n FActive := True;\r\n end;\r\nend;\r\n\r\nprocedure TJvNTEventLog.Close;\r\nbegin\r\n if FLogHandle <> 0 then\r\n begin\r\n if FNotifyThread <> nil then\r\n FNotifyThread.Terminate;\r\n CloseEventLog(FLogHandle);\r\n FLogHandle := 0;\r\n FreeAndNil(FNotifyThread);\r\n end;\r\n FreeMem(FEventRecord.FCurrentRecord);\r\n FEventRecord.FCurrentRecord := nil;\r\n FActive := False;\r\nend;\r\n\r\nprocedure TJvNTEventLog.First;\r\nbegin\r\n SeekRecord(0);\r\nend;\r\n\r\nprocedure TJvNTEventLog.Last;\r\nbegin\r\n SeekRecord(GetEventCount - 1);\r\nend;\r\n\r\nfunction TJvNTEventLog.Eof: Boolean;\r\nbegin\r\n Result := (EventRecord.FCurrentRecord = nil) or (EventRecord.RecordNumber = GetEventCount) or\r\n (FLastError = ERROR_HANDLE_EOF);\r\nend;\r\n\r\nprocedure TJvNTEventLog.Next;\r\nvar\r\n BytesRead, BytesNeeded, Flags: DWORD;\r\n Dummy: Char;\r\nbegin\r\n Flags := EVENTLOG_SEQUENTIAL_READ;\r\n Flags := Flags or EVENTLOG_FORWARDS_READ;\r\n\r\n ReadEventLog(FLogHandle, Flags, 0, @Dummy, 0, BytesRead, BytesNeeded);\r\n FLastError := GetLastError;\r\n if FLastError = ERROR_INSUFFICIENT_BUFFER then\r\n begin\r\n ReallocMem(FEventRecord.FCurrentRecord, BytesNeeded);\r\n if not ReadEventLog(FLogHandle, Flags, 0, FEventRecord.FCurrentRecord, BytesNeeded, BytesRead, BytesNeeded) then\r\n RaiseLastOSError;\r\n end\r\n else\r\n if FLastError <> ERROR_HANDLE_EOF then\r\n RaiseLastOSError;\r\nend;\r\n\r\nprocedure TJvNTEventLog.SeekRecord(N: Cardinal);\r\nvar\r\n Offset, Flags: DWORD;\r\n BytesRead, BytesNeeded: Cardinal;\r\n Dummy: Char;\r\n RecNo: Integer;\r\nbegin\r\n GetOldestEventLogRecord(FLogHandle, Offset);\r\n RecNo := N + Offset;\r\n\r\n Flags := EVENTLOG_SEEK_READ;\r\n Flags := Flags or EVENTLOG_FORWARDS_READ;\r\n\r\n ReadEventLog(FLogHandle, Flags, RecNo, @Dummy, 0, BytesRead, BytesNeeded);\r\n FLastError := GetLastError;\r\n if FLastError = ERROR_INSUFFICIENT_BUFFER then\r\n begin\r\n ReallocMem(FEventRecord.FCurrentRecord, BytesNeeded);\r\n if not ReadEventLog(FLogHandle, Flags, RecNo, FEventRecord.FCurrentRecord, BytesNeeded, BytesRead, BytesNeeded) then\r\n RaiseLastOSError;\r\n end\r\n else\r\n if FLastError <> ERROR_HANDLE_EOF then\r\n RaiseLastOSError;\r\nend;\r\n\r\nprocedure TJvNTEventLog.Seek(N: Cardinal);\r\nbegin\r\n if N <> FEventRecord.RecordNumber then\r\n SeekRecord(N);\r\nend;\r\n\r\nprocedure TJvNTEventLog.ReadEventLogs(AStrings: TStrings);\r\nbegin\r\n with TRegistry.Create do\r\n begin\r\n AStrings.BeginUpdate;\r\n try\r\n RootKey := HKEY_LOCAL_MACHINE;\r\n OpenKey(cEventLogBaseKey, False);\r\n GetKeyNames(AStrings);\r\n finally\r\n Free;\r\n AStrings.EndUpdate;\r\n end;\r\n end;\r\nend;\r\n\r\n//=== { TNotifyChangeEventLog } ==============================================\r\n\r\nconstructor TNotifyChangeEventLog.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(False);\r\n\r\n // initialize system events\r\n FEventLog := TJvNTEventLog(AOwner);\r\n FEventHandle := CreateEvent(nil, True, False, nil);\r\n NotifyChangeEventLog(FEventLog.FLogHandle, FEventHandle);\r\n ThreadName := Format('%s: %s',[ClassName, AOwner.Name]);\r\nend;\r\n\r\nprocedure TNotifyChangeEventLog.DoChange;\r\nbegin\r\n if Assigned(FEventLog.FOnChange) then\r\n FEventLog.FOnChange(FEventLog);\r\nend;\r\n\r\nprocedure TNotifyChangeEventLog.Execute;\r\nvar\r\n LResult: DWORD;\r\nbegin\r\n // (rom) secure thread against exceptions\r\n NameThread(ThreadName);\r\n LResult := WAIT_OBJECT_0;\r\n try\r\n while not Terminated do\r\n begin\r\n // reset event signal if we're here for any other reason than a\r\n // timeout, so we can get it again\r\n if LResult <> WAIT_TIMEOUT then\r\n ResetEvent(FEventHandle);\r\n // wait for event to happen\r\n LResult := WaitForSingleObject(FEventHandle, 100);\r\n if LResult = WAIT_OBJECT_0 then\r\n Synchronize(DoChange);\r\n end;\r\n except\r\n end;\r\nend;\r\n\r\n//=== { TJvNTEventLogRecord } ================================================\r\n\r\nconstructor TJvNTEventLogRecord.Create(AOwner: TComponent);\r\nbegin\r\n // (rom) added inherited Create\r\n inherited Create;\r\n FEventLog := TJvNTEventLog(AOwner);\r\n FCurrentRecord := nil;\r\n FOwner := AOwner;\r\nend;\r\n\r\nfunction TJvNTEventLogRecord.GetRecordNumber: Cardinal;\r\nbegin\r\n Result := PEventLogRecord(FCurrentRecord)^.RecordNumber;\r\nend;\r\n\r\nfunction TJvNTEventLogRecord.GetMessageText: string;\r\nvar\r\n MessagePath: string;\r\n Count, I: Integer;\r\n P: PChar;\r\n Args, PArgs: ^PChar;\r\n St: string;\r\n reg: TRegistry;\r\n\r\n function FormatMessageFrom(const DllName: string): Boolean;\r\n var\r\n DllModule: THandle;\r\n Buffer: array [0..2047] of Char;\r\n FullDLLName: array [0..MAX_PATH] of Char;\r\n begin\r\n Result := False;\r\n ExpandEnvironmentStrings(PChar(DllName), FullDLLName, MAX_PATH);\r\n DllModule := LoadLibraryEx(FullDLLName, 0, LOAD_LIBRARY_AS_DATAFILE);\r\n if DllModule <> 0 then\r\n try\r\n // (rom) memory leak fixed\r\n if FormatMessage(\r\n FORMAT_MESSAGE_FROM_HMODULE or FORMAT_MESSAGE_ARGUMENT_ARRAY,\r\n Pointer(DllModule), ID, 0, Buffer, SizeOf(Buffer), Args) > 0 then\r\n begin\r\n Buffer[StrLen(Buffer) - 2] := #0;\r\n St := Buffer;\r\n Result := True;\r\n end\r\n finally\r\n FreeLibrary(DllModule);\r\n end\r\n end;\r\n\r\nbegin\r\n St := '';\r\n Count := StringCount;\r\n GetMem(Args, Count * SizeOf(PChar));\r\n try\r\n PArgs := Args;\r\n P := PEventLogRecord(FCurrentRecord)^.StringOffset + PChar(FCurrentRecord);\r\n for I := 0 to Count - 1 do\r\n begin\r\n PArgs^ := P;\r\n Inc(P, lstrlen(P) + 1);\r\n Inc(PArgs);\r\n end;\r\n\r\n reg := TRegistry.Create;\r\n try\r\n reg.RootKey := HKEY_LOCAL_MACHINE;\r\n reg.OpenKey(Format('%s\\%s\\%s', [cEventLogBaseKey, FEventLog.Log, Source]), False); {rw}\r\n// OpenKey(Format('SYSTEM\\CurrentControlSet\\Services\\EventLog\\%s\\%s', [FEventLog.Log, FEventLog.Source]), False);\r\n MessagePath := reg.ReadString('EventMessageFile');\r\n finally\r\n reg.Free;\r\n end;\r\n\r\n repeat\r\n I := Pos(';', MessagePath);\r\n if I <> 0 then\r\n begin\r\n if FormatMessageFrom(Copy(MessagePath, 1, I - 1 )) then {rw}\r\n// if FormatMessageFrom(Copy(MessagePath, 1, I)) then\r\n Break;\r\n MessagePath := Copy(MessagePath, I + 1, MaxInt); {rw}\r\n// MessagePath := Copy(MessagePath, I, MaxInt);\r\n end\r\n else\r\n FormatMessageFrom(MessagePath);\r\n until I = 0;\r\n finally\r\n FreeMem(Args)\r\n end;\r\n Result := St;\r\nend;\r\n\r\nfunction TJvNTEventLogRecord.GetUsername: string;\r\nvar\r\n UserName: array [0..512] of Char;\r\n UserNameLen: Cardinal;\r\n DomainName: array [0..512] of Char;\r\n DomainNameLen: Cardinal;\r\n Use: SID_NAME_USE;\r\n UserSID: PSID;\r\n\r\nbegin\r\n Result := '';\r\n\r\n UserSID := SID;\r\n if Assigned(UserSID) then\r\n begin\r\n UserNameLen := SizeOf(UserName);\r\n DomainNameLen := SizeOf(DomainName);\r\n if LookupAccountSID(nil, UserSID, UserName, UserNameLen, DomainName, DomainNameLen, Use) then\r\n Result := string(DomainName) + '\\' + string(UserName);\r\n end\r\n else\r\n begin\r\n Result := RsLogUserSIDNotFound;\r\n end;\r\nend;\r\n\r\nfunction TJvNTEventLogRecord.GetType: string;\r\nbegin\r\n case PEventLogRecord(FCurrentRecord)^.EventType of\r\n EVENTLOG_ERROR_TYPE:\r\n Result := RsLogError;\r\n EVENTLOG_WARNING_TYPE:\r\n Result := RsLogWarning;\r\n EVENTLOG_INFORMATION_TYPE:\r\n Result := RsLogInformation;\r\n EVENTLOG_AUDIT_SUCCESS:\r\n Result := RsLogSuccessAudit;\r\n EVENTLOG_AUDIT_FAILURE:\r\n Result := RsLogFailureAudit;\r\n else\r\n Result := '';\r\n end;\r\nend;\r\n\r\nfunction TJvNTEventLogRecord.GetSource: string;\r\nbegin\r\n Result := PChar(FCurrentRecord) + SizeOf(TEventLogRecord);\r\nend;\r\n\r\nfunction TJvNTEventLogRecord.GetComputer: string;\r\nvar\r\n P: PChar;\r\nbegin\r\n P := PChar(FCurrentRecord) + SizeOf(TEventLogRecord);\r\n Result := P + StrLen(P) + 1;\r\nend;\r\n\r\nfunction TJvNTEventLogRecord.GetID: DWORD;\r\nbegin\r\n Result := PEventLogRecord(FCurrentRecord)^.EventID;\r\nend;\r\n\r\nfunction TJvNTEventLogRecord.GetStringCount: DWORD;\r\nbegin\r\n Result := PEventLogRecord(FCurrentRecord)^.NumStrings;\r\nend;\r\n\r\nfunction TJvNTEventLogRecord.GetCategory: Cardinal;\r\nbegin\r\n Result := PEventLogRecord(FCurrentRecord)^.EventCategory;\r\nend;\r\n\r\nfunction TJvNTEventLogRecord.GetSID: PSID;\r\nbegin\r\n Result := nil;\r\n if PEventLogRecord(FCurrentRecord)^.UserSidLength > 0 then\r\n Result := PSID(PChar(FCurrentRecord) + PEventLogRecord(FCurrentRecord)^.UserSidOffset);\r\nend;\r\n\r\nfunction TJvNTEventLogRecord.GetString(Index: Cardinal): string;\r\nvar\r\n P: PChar;\r\nbegin\r\n Result := '';\r\n if Index < StringCount then\r\n begin\r\n P := PChar(FCurrentRecord) + PEventLogRecord(FCurrentRecord)^.StringOffset;\r\n while Index > 0 do\r\n begin\r\n Inc(P, StrLen(P) + 1);\r\n Dec(Index);\r\n end;\r\n Result := StrPas(P);\r\n end;\r\nend;\r\n\r\nfunction TJvNTEventLogRecord.GetDateTime: TDateTime;\r\nconst\r\n StartPoint: TDateTime = 25569.0; // January 1, 1970 00:00:00\r\nbegin\r\n // Result := IncSecond(StartPoint, PEventLogRecord(FCurrentRecord)^.TimeGenerated);\r\n// Result := IncSecond(StartPoint, PEventLogRecord(FCurrentRecord)^.TimeWritten);\r\n Result := ((StartPoint * 86400.0) + PEventLogRecord(FCurrentRecord)^.TimeWritten) / 86400.0;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvNavigationPane.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvNavigationPane.PAS, released on 2004-03-28.\r\n\r\nThe Initial Developer of the Original Code is Peter Thornqvist \r\nPortions created by Peter Thornqvist are Copyright (C) 2004 Peter Thornqvist.\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvNavigationPane.pas 13415 2012-09-10 09:51:54Z obones $\r\n\r\nunit JvNavigationPane;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n SysUtils, Classes,\r\n Windows, Messages, Controls, Graphics, Menus, ExtCtrls, ImgList,\r\n {$IFDEF HAS_UNIT_SYSTEM_UITYPES}\r\n System.UITypes,\r\n {$ENDIF HAS_UNIT_SYSTEM_UITYPES}\r\n JvConsts, JvTypes, JvButton, JvPageList, JvComponentBase, JvComponent, JvExExtCtrls;\r\n\r\ntype\r\n TJvCustomNavigationPane = class;\r\n TJvNavIconButton = class;\r\n TJvNavStyleLink = class;\r\n TJvNavPaneStyleManager = class;\r\n TMsgStyleManagerChange = record\r\n Msg: Cardinal;\r\n Sender: TControl;\r\n StyleManager: TJvNavPaneStyleManager;\r\n Result: Longint;\r\n end;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvNavPanelHeader = class(TJvCustomControl)\r\n private\r\n FColorFrom: TColor;\r\n FColorTo: TColor;\r\n FImages: TCustomImageList;\r\n FImageIndex: TImageIndex;\r\n FChangeLink: TChangeLink;\r\n FStyleManager: TJvNavPaneStyleManager;\r\n FStyleLink: TJvNavStyleLink;\r\n FWordWrap: Boolean;\r\n FAlignment: TAlignment;\r\n FParentStyleManager: Boolean;\r\n procedure WMEraseBkgnd(var Msg: TWMEraseBkgnd); message WM_ERASEBKGND;\r\n procedure SetColorFrom(const Value: TColor);\r\n procedure SetColorTo(const Value: TColor);\r\n procedure SetImageIndex(const Value: TImageIndex);\r\n procedure SetImages(const Value: TCustomImageList);\r\n procedure DoImagesChange(Sender: TObject);\r\n procedure SetStyleManager(const Value: TJvNavPaneStyleManager);\r\n procedure DoStyleChange(Sender: TObject);\r\n procedure SetAlignment(const Value: TAlignment);\r\n procedure SetWordWrap(const Value: Boolean);\r\n procedure ParentStyleManagerChanged(var Msg: TMsgStyleManagerChange); message CM_PARENTSTYLEMANAGERCHANGED;\r\n procedure ParentStyleManagerChange(var Msg: TMessage); message CM_PARENTSTYLEMANAGERCHANGE;\r\n procedure CMControlChange(var Msg: TMessage); message CM_CONTROLCHANGE;\r\n procedure SetParentStyleManager(const Value: Boolean);\r\n protected\r\n procedure Notification(AComponent: TComponent; Operation: TOperation); override;\r\n procedure TextChanged; override;\r\n procedure Paint; override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n published\r\n property Align;\r\n property Alignment: TAlignment read FAlignment write SetAlignment default taLeftJustify;\r\n property Anchors;\r\n property Caption;\r\n property Constraints;\r\n property DragCursor;\r\n property DragKind;\r\n property DragMode;\r\n property OnStartDock;\r\n property OnEndDock;\r\n property OnUnDock;\r\n property Enabled;\r\n property Font;\r\n property ParentFont;\r\n property ParentShowHint;\r\n property PopupMenu;\r\n property ShowHint;\r\n property Visible;\r\n property WordWrap: Boolean read FWordWrap write SetWordWrap default False;\r\n\r\n property ColorFrom: TColor read FColorFrom write SetColorFrom default TColor($D0835C);\r\n property ColorTo: TColor read FColorTo write SetColorTo default TColor($903B09);\r\n property Images: TCustomImageList read FImages write SetImages;\r\n property ImageIndex: TImageIndex read FImageIndex write SetImageIndex default -1;\r\n property StyleManager: TJvNavPaneStyleManager read FStyleManager write SetStyleManager;\r\n // (p3) must be published after StyleManager\r\n property ParentStyleManager: Boolean read FParentStyleManager write SetParentStyleManager default True;\r\n property Height default 27;\r\n property Width default 225;\r\n\r\n property OnClick;\r\n property OnContextPopup;\r\n property OnDragDrop;\r\n property OnDragOver;\r\n property OnEndDrag;\r\n property OnMouseDown;\r\n property OnMouseMove;\r\n property OnMouseUp;\r\n property OnMouseEnter;\r\n property OnMouseLeave;\r\n property OnStartDrag;\r\n end;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvNavPanelDivider = class(TJvExSplitter)\r\n private\r\n FColorFrom: TColor;\r\n FColorTo: TColor;\r\n FFrameColor: TColor;\r\n FStyleManager: TJvNavPaneStyleManager;\r\n FStyleLink: TJvNavStyleLink;\r\n FAlignment: TAlignment;\r\n FParentStyleManager: Boolean;\r\n procedure SetColorFrom(const Value: TColor);\r\n procedure SetColorTo(const Value: TColor);\r\n procedure SetFrameColor(const Value: TColor);\r\n procedure SetStyleManager(const Value: TJvNavPaneStyleManager);\r\n procedure DoStyleChange(Sender: TObject);\r\n procedure SetAlignment(const Value: TAlignment);\r\n procedure ParentStyleManagerChanged(var Msg: TMsgStyleManagerChange); message CM_PARENTSTYLEMANAGERCHANGED;\r\n procedure SetParentStyleManager(const Value: Boolean);\r\n protected\r\n procedure Paint; override;\r\n procedure TextChanged; override;\r\n procedure Notification(AComponent: TComponent; Operation: TOperation); override;\r\n procedure RequestAlign; override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n published\r\n // NB! Color is published but not used\r\n property Alignment: TAlignment read FAlignment write SetAlignment default taLeftJustify;\r\n property Align default alNone;\r\n property Anchors;\r\n property AutoSnap default False;\r\n property Caption;\r\n property ColorFrom: TColor read FColorFrom write SetColorFrom default TColor($FFDBBC);\r\n property ColorTo: TColor read FColorTo write SetColorTo default TColor($F2C0A4);\r\n property Constraints;\r\n property Cursor default crSizeNS;\r\n property Enabled;\r\n property Font;\r\n property FrameColor: TColor read FFrameColor write SetFrameColor default TColor($6F2F0C);\r\n property Height default 19;\r\n property ResizeStyle default rsUpdate;\r\n property StyleManager: TJvNavPaneStyleManager read FStyleManager write SetStyleManager;\r\n // (p3) must be published after StyleManager\r\n property ParentStyleManager: Boolean read FParentStyleManager write SetParentStyleManager default True;\r\n property Width default 125;\r\n end;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvOutlookSplitter = class(TJvExSplitter)\r\n private\r\n FColorTo: TColor;\r\n FColorFrom: TColor;\r\n FStyleManager: TJvNavPaneStyleManager;\r\n FStyleLink: TJvNavStyleLink;\r\n FParentStyleManager: Boolean;\r\n FDragZone: Integer;\r\n FOldCursor: TCursor;\r\n procedure SetColorFrom(const Value: TColor);\r\n procedure SetColorTo(const Value: TColor);\r\n procedure SetStyleManager(const Value: TJvNavPaneStyleManager);\r\n procedure DoStyleChange(Sender: TObject);\r\n procedure ParentStyleManagerChanged(var Msg: TMsgStyleManagerChange); message CM_PARENTSTYLEMANAGERCHANGED;\r\n procedure SetParentStyleManager(const Value: Boolean);\r\n procedure SetCursor(const Value: TCursor);\r\n function GetDragZoneRect: TRect;\r\n function MouseInDragZone(X, Y: Integer): Boolean;\r\n protected\r\n procedure Paint; override;\r\n procedure EnabledChanged; override;\r\n procedure Notification(AComponent: TComponent; Operation: TOperation); override;\r\n procedure WMLButtonDown(var Msg: TWMLButtonDown); message WM_LBUTTONDOWN;\r\n procedure WMMouseMove(var Msg: TWMMouseMove); message WM_MOUSEMOVE;\r\n procedure RequestAlign; override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n published\r\n // NB! Color is published but not used\r\n property Align default alBottom;\r\n property AutoSnap default False;\r\n property Cursor write SetCursor default crSizeNS;\r\n // DragZone is the number of pixels in the center of the control that constitutes the draggable area.\r\n // For example, with a left/right aligned splitter and a DragZone of 100, 50 pixels above and 50 pixels below\r\n // the vertical midpoint can be clicked to start the sizing. Any clicks outside this area will not start a sizing operation\r\n // If DragZone <= 0, the entire control is a drag zone\r\n property DragZone: Integer read FDragZone write FDragZone default 0;\r\n property ResizeStyle default rsUpdate;\r\n property ColorFrom: TColor read FColorFrom write SetColorFrom default TColor($B78676);\r\n property ColorTo: TColor read FColorTo write SetColorTo default TColor($A03D09);\r\n property Height default 7;\r\n property Enabled;\r\n property StyleManager: TJvNavPaneStyleManager read FStyleManager write SetStyleManager;\r\n // (p3) must be published after StyleManager\r\n property ParentStyleManager: Boolean read FParentStyleManager write SetParentStyleManager default True;\r\n property OnClick;\r\n property OnMouseDown;\r\n property OnMouseEnter;\r\n property OnMouseLeave;\r\n property OnDblClick;\r\n property OnMouseUp;\r\n property OnMouseMove;\r\n end;\r\n\r\n TJvNavPanelColors = class(TPersistent)\r\n private\r\n FButtonColorTo: TColor;\r\n FButtonColorFrom: TColor;\r\n FFrameColor: TColor;\r\n FButtonHotColorFrom: TColor;\r\n FButtonHotColorTo: TColor;\r\n FButtonSelectedColorFrom: TColor;\r\n FButtonSelectedColorTo: TColor;\r\n FOnChange: TNotifyEvent;\r\n FSplitterColorFrom: TColor;\r\n FSplitterColorTo: TColor;\r\n FDividerColorTo: TColor;\r\n FDividerColorFrom: TColor;\r\n FHeaderColorFrom: TColor;\r\n FHeaderColorTo: TColor;\r\n FButtonSeparatorColor: TColor;\r\n FToolPanelColorFrom: TColor;\r\n FToolPanelColorTo: TColor;\r\n FToolPanelHeaderColorTo: TColor;\r\n FToolPanelHeaderColorFrom: TColor;\r\n procedure SetButtonColorFrom(const Value: TColor);\r\n procedure SetButtonColorTo(const Value: TColor);\r\n procedure SetFrameColor(const Value: TColor);\r\n procedure SetButtonHotColorFrom(const Value: TColor);\r\n procedure SetButtonHotColorTo(const Value: TColor);\r\n procedure SetButtonSelectedColorFrom(const Value: TColor);\r\n procedure SetButtonSelectedColorTo(const Value: TColor);\r\n procedure SetSplitterColorFrom(const Value: TColor);\r\n procedure SetSplitterColorTo(const Value: TColor);\r\n procedure SetDividerColorFrom(const Value: TColor);\r\n procedure SetDividerColorTo(const Value: TColor);\r\n procedure SetHeaderColorFrom(const Value: TColor);\r\n procedure SetHeaderColorTo(const Value: TColor);\r\n procedure SetButtonSeparatorColor(const Value: TColor);\r\n procedure SetToolPanelColorFrom(const Value: TColor);\r\n procedure SetToolPanelColorTo(const Value: TColor);\r\n procedure SetToolPanelHeaderColorFrom(const Value: TColor);\r\n procedure SetToolPanelHeaderColorTo(const Value: TColor);\r\n protected\r\n procedure Change;\r\n public\r\n constructor Create;\r\n procedure Assign(Source: TPersistent); override;\r\n published\r\n property ButtonColorFrom: TColor read FButtonColorFrom write SetButtonColorFrom default TColor($F7E2CD);\r\n property ButtonColorTo: TColor read FButtonColorTo write SetButtonColorTo default TColor($F3A080);\r\n property ButtonHotColorFrom: TColor read FButtonHotColorFrom write SetButtonHotColorFrom default TColor($DBFBFF);\r\n property ButtonHotColorTo: TColor read FButtonHotColorTo write SetButtonHotColorTo default TColor($5FC8FB);\r\n property ButtonSelectedColorFrom: TColor read FButtonSelectedColorFrom write SetButtonSelectedColorFrom default TColor($BBE2EA);\r\n property ButtonSelectedColorTo: TColor read FButtonSelectedColorTo write SetButtonSelectedColorTo default TColor($389FDD);\r\n property ButtonSeparatorColor: TColor read FButtonSeparatorColor write SetButtonSeparatorColor default clGray;\r\n property SplitterColorFrom: TColor read FSplitterColorFrom write SetSplitterColorFrom default TColor($B78676);\r\n property SplitterColorTo: TColor read FSplitterColorTo write SetSplitterColorTo default TColor($A03D09);\r\n property DividerColorFrom: TColor read FDividerColorFrom write SetDividerColorFrom default TColor($FFDBBC);\r\n property DividerColorTo: TColor read FDividerColorTo write SetDividerColorTo default TColor($F2C0A4);\r\n property HeaderColorFrom: TColor read FHeaderColorFrom write SetHeaderColorFrom default TColor($D0835C);\r\n property HeaderColorTo: TColor read FHeaderColorTo write SetHeaderColorTo default TColor($903B09);\r\n property FrameColor: TColor read FFrameColor write SetFrameColor default TColor($6F2F0C);\r\n property ToolPanelColorFrom: TColor read FToolPanelColorFrom write SetToolPanelColorFrom default clWindow;\r\n property ToolPanelColorTo: TColor read FToolPanelColorTo write SetToolPanelColorTo default clWindow;\r\n property ToolPanelHeaderColorFrom: TColor read FToolPanelHeaderColorFrom write SetToolPanelHeaderColorFrom default TColor($F7E2CD);\r\n property ToolPanelHeaderColorTo: TColor read FToolPanelHeaderColorTo write SetToolPanelHeaderColorTo default TColor($F3A080);\r\n property OnChange: TNotifyEvent read FOnChange write FOnChange;\r\n end;\r\n\r\n TJvNavPanelFonts = class(TPersistent)\r\n private\r\n FHeaderFont: TFont;\r\n FNavPanelFont: TFont;\r\n FDividerFont: TFont;\r\n FOnChange: TNotifyEvent;\r\n FNavPanelHotTrackFont: TFont;\r\n FNavPanelHotTrackFontOptions: TJvTrackFontOptions;\r\n procedure SetDividerFont(const Value: TFont);\r\n procedure SetHeaderFont(const Value: TFont);\r\n procedure SetNavPanelFont(const Value: TFont);\r\n procedure SetNavPanelHotTrackFont(const Value: TFont);\r\n procedure SetNavPanelHotTrackFontOptions(const Value: TJvTrackFontOptions);\r\n protected\r\n procedure Change;\r\n procedure DoFontChange(Sender: TObject);\r\n public\r\n procedure Assign(Source: TPersistent); override;\r\n constructor Create;\r\n destructor Destroy; override;\r\n published\r\n property NavPanelFont: TFont read FNavPanelFont write SetNavPanelFont;\r\n property NavPanelHotTrackFont: TFont read FNavPanelHotTrackFont write SetNavPanelHotTrackFont;\r\n property NavPanelHotTrackFontOptions: TJvTrackFontOptions read FNavPanelHotTrackFontOptions write SetNavPanelHotTrackFontOptions default DefaultTrackFontOptions;\r\n\r\n property DividerFont: TFont read FDividerFont write SetDividerFont;\r\n property HeaderFont: TFont read FHeaderFont write SetHeaderFont;\r\n property OnChange: TNotifyEvent read FOnChange write FOnChange;\r\n end;\r\n\r\n TJvIconPanel = class(TJvCustomControl)\r\n private\r\n FDropButton: TJvNavIconButton;\r\n FColors: TJvNavPanelColors;\r\n FStyleManager: TJvNavPaneStyleManager;\r\n FStyleLink: TJvNavStyleLink;\r\n FOnDropDownMenu: TContextPopupEvent;\r\n FParentStyleManager: Boolean;\r\n procedure SetDropDownMenu(const Value: TPopupMenu);\r\n function GetDropDownMenu: TPopupMenu;\r\n procedure SetColors(const Value: TJvNavPanelColors);\r\n procedure SetStyleManager(const Value: TJvNavPaneStyleManager);\r\n procedure DoStyleChange(Sender: TObject);\r\n procedure ParentStyleManagerChanged(var Msg: TMsgStyleManagerChange); message CM_PARENTSTYLEMANAGERCHANGED;\r\n procedure ParentStyleManagerChange(var Msg: TMessage); message CM_PARENTSTYLEMANAGERCHANGE;\r\n procedure CMControlChange(var Msg: TMessage); message CM_CONTROLCHANGE;\r\n procedure WMEraseBkgnd(var Msg: TWMEraseBkgnd); message WM_ERASEBKGND;\r\n procedure SetParentStyleManager(const Value: Boolean);\r\n protected\r\n procedure DoDropDownMenu(Sender: TObject; MousePos: TPoint; var Handled: Boolean);\r\n procedure DoColorsChange(Sender: TObject);\r\n procedure Paint; override;\r\n procedure Notification(AComponent: TComponent; Operation: TOperation); override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n property Colors: TJvNavPanelColors read FColors write SetColors;\r\n property StyleManager: TJvNavPaneStyleManager read FStyleManager write SetStyleManager;\r\n // (p3) must be published after StyleManager\r\n property ParentStyleManager: Boolean read FParentStyleManager write SetParentStyleManager default True;\r\n property DropDownMenu: TPopupMenu read GetDropDownMenu write SetDropDownMenu;\r\n property OnDropDownMenu: TContextPopupEvent read FOnDropDownMenu write FOnDropDownMenu;\r\n end;\r\n\r\n TJvNavIconButtonType = (nibDropDown, nibImage, nibDropArrow, nibClose);\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvNavIconButton = class(TJvCustomGraphicButton)\r\n private\r\n FChangeLink: TChangeLink;\r\n FImages: TCustomImageList;\r\n FImageIndex: TImageIndex;\r\n FButtonType: TJvNavIconButtonType;\r\n FColors: TJvNavPanelColors;\r\n FStyleManager: TJvNavPaneStyleManager;\r\n FStyleLink: TJvNavStyleLink;\r\n FParentStyleManager: Boolean;\r\n procedure SetImages(const Value: TCustomImageList);\r\n procedure SetImageIndex(const Value: TImageIndex);\r\n procedure DoImagesChange(Sender: TObject);\r\n procedure SetButtonType(const Value: TJvNavIconButtonType);\r\n procedure SetColors(const Value: TJvNavPanelColors);\r\n procedure DoColorsChange(Sender: TObject);\r\n procedure SetStyleManager(const Value: TJvNavPaneStyleManager);\r\n procedure DoStyleChange(Sender: TObject);\r\n procedure ParentStyleManagerChanged(var Msg: TMsgStyleManagerChange); message CM_PARENTSTYLEMANAGERCHANGED;\r\n procedure SetParentStyleManager(const Value: Boolean);\r\n function IsColorsStored: Boolean;\r\n protected\r\n procedure Notification(AComponent: TComponent; Operation: TOperation); override;\r\n procedure Paint; override;\r\n\r\n property OnDropDownMenu;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n published\r\n property Action;\r\n property Align;\r\n property AllowAllUp;\r\n property Anchors;\r\n // property Caption;\r\n property Constraints;\r\n property Down;\r\n property DragCursor;\r\n property DragKind;\r\n property OnEndDock;\r\n property OnStartDock;\r\n property DragMode;\r\n property DropDownMenu;\r\n property GroupIndex;\r\n property Enabled;\r\n property Font;\r\n property ParentFont;\r\n property ParentShowHint;\r\n property PopupMenu;\r\n property ShowHint;\r\n property Visible;\r\n\r\n property ButtonType: TJvNavIconButtonType read FButtonType write SetButtonType;\r\n property Colors: TJvNavPanelColors read FColors write SetColors stored IsColorsStored;\r\n property Images: TCustomImageList read FImages write SetImages;\r\n property ImageIndex: TImageIndex read FImageIndex write SetImageIndex;\r\n property StyleManager: TJvNavPaneStyleManager read FStyleManager write SetStyleManager;\r\n // (p3) must be published after StyleManager\r\n property ParentStyleManager: Boolean read FParentStyleManager write SetParentStyleManager default True;\r\n property Width default 22;\r\n property Height default 22;\r\n\r\n property OnClick;\r\n property OnContextPopup;\r\n property OnDragDrop;\r\n property OnDragOver;\r\n property OnEndDrag;\r\n property OnMouseDown;\r\n property OnMouseMove;\r\n property OnMouseUp;\r\n property OnMouseEnter;\r\n property OnMouseLeave;\r\n property OnStartDrag;\r\n end;\r\n\r\n TJvNavPanelToolButton = class(TJvCustomGraphicButton)\r\n private\r\n FChangeLink: TChangeLink;\r\n FImages: TCustomImageList;\r\n FImageIndex: TImageIndex;\r\n FButtonType: TJvNavIconButtonType;\r\n FDrawPartialMenuFrame: Boolean;\r\n FTransparentDown: Boolean;\r\n procedure DoImagesChange(Sender: TObject);\r\n procedure SetButtonType(const Value: TJvNavIconButtonType);\r\n procedure SetImageIndex(const Value: TImageIndex);\r\n procedure SetImages(const Value: TCustomImageList);\r\n protected\r\n procedure Notification(AComponent: TComponent; Operation: TOperation); override;\r\n procedure Paint; override;\r\n procedure ActionChange(Sender: TObject; CheckDefaults: Boolean); override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n property TransparentDown: Boolean read FTransparentDown write FTransparentDown default False;\r\n property DrawPartialMenuFrame: Boolean read FDrawPartialMenuFrame write FDrawPartialMenuFrame default False;\r\n property Images: TCustomImageList read FImages write SetImages;\r\n property ImageIndex: TImageIndex read FImageIndex write SetImageIndex;\r\n property ButtonType: TJvNavIconButtonType read FButtonType write SetButtonType;\r\n property Caption;\r\n end;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvNavPanelButton = class(TJvCustomGraphicButton)\r\n private\r\n FImageIndex: TImageIndex;\r\n FImages: TCustomImageList;\r\n FColors: TJvNavPanelColors;\r\n FStyleManager: TJvNavPaneStyleManager;\r\n FStyleLink: TJvNavStyleLink;\r\n FAlignment: TAlignment;\r\n FWordWrap: Boolean;\r\n FParentStyleManager: Boolean;\r\n procedure SetImageIndex(const Value: TImageIndex);\r\n procedure SetImages(const Value: TCustomImageList);\r\n procedure SetColors(const Value: TJvNavPanelColors);\r\n procedure DoColorsChange(Sender: TObject);\r\n procedure SetStyleManager(const Value: TJvNavPaneStyleManager);\r\n procedure DoStyleChange(Sender: TObject);\r\n procedure SetAlignment(const Value: TAlignment);\r\n procedure SetWordWrap(const Value: Boolean);\r\n procedure CMDialogChar(var Msg: TCMDialogChar); message CM_DIALOGCHAR;\r\n procedure ParentStyleManagerChanged(var Msg: TMsgStyleManagerChange); message CM_PARENTSTYLEMANAGERCHANGED;\r\n procedure SetParentStyleManager(const Value: Boolean);\r\n function IsColorsStored: Boolean;\r\n protected\r\n procedure TextChanged; override;\r\n procedure FontChanged; override;\r\n procedure ActionChange(Sender: TObject; CheckDefaults: Boolean); override;\r\n procedure Notification(AComponent: TComponent; Operation: TOperation); override;\r\n procedure PaintButton(Canvas: TCanvas); override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n published\r\n property Action;\r\n property Align;\r\n property Alignment: TAlignment read FAlignment write SetAlignment default taLeftJustify;\r\n property AllowAllUp;\r\n property Anchors;\r\n property Caption;\r\n property Constraints;\r\n property Down;\r\n property DropDownMenu;\r\n property DragCursor;\r\n property DragKind;\r\n property OnEndDock;\r\n property OnStartDock;\r\n property DragMode;\r\n property Enabled;\r\n property Font;\r\n property GroupIndex;\r\n\r\n property HotTrack default True;\r\n property HotTrackFont;\r\n property HotTrackFontOptions;\r\n property ParentFont;\r\n property ParentShowHint;\r\n property PopupMenu;\r\n property ShowHint;\r\n property Visible;\r\n property WordWrap: Boolean read FWordWrap write SetWordWrap default False;\r\n\r\n property Width default 125;\r\n property Height default 28;\r\n\r\n property Colors: TJvNavPanelColors read FColors write SetColors stored IsColorsStored;\r\n property StyleManager: TJvNavPaneStyleManager read FStyleManager write SetStyleManager;\r\n // (p3) must be published after StyleManager\r\n property ParentStyleManager: Boolean read FParentStyleManager write SetParentStyleManager default True;\r\n property ImageIndex: TImageIndex read FImageIndex write SetImageIndex;\r\n property Images: TCustomImageList read FImages write SetImages;\r\n property OnClick;\r\n property OnContextPopup;\r\n property OnDragDrop;\r\n property OnDragOver;\r\n property OnEndDrag;\r\n property OnMouseDown;\r\n property OnMouseMove;\r\n property OnMouseUp;\r\n property OnMouseEnter;\r\n property OnMouseLeave;\r\n property OnStartDrag;\r\n end;\r\n\r\n TJvNavPaneBackgroundImage = class(TPersistent)\r\n private\r\n FCenter: Boolean;\r\n FTile: Boolean;\r\n FTransparent: Boolean;\r\n FProportional: Boolean;\r\n FStretch: Boolean;\r\n FDrawing: Boolean;\r\n FPicture: TPicture;\r\n FOnChange: TNotifyEvent;\r\n procedure SetCenter(const Value: Boolean);\r\n procedure SetPicture(const Value: TPicture);\r\n procedure SetProportional(const Value: Boolean);\r\n procedure SetStretch(const Value: Boolean);\r\n procedure SetTile(const Value: Boolean);\r\n procedure SetTransparent(const Value: Boolean);\r\n procedure PictureChanged(Sender: TObject);\r\n protected\r\n procedure DrawImage(Canvas: TCanvas; ARect: TRect); virtual;\r\n procedure Change; virtual;\r\n function CalcRect(ADestRect: TRect): TRect;\r\n public\r\n constructor Create;\r\n destructor Destroy; override;\r\n function HasImage: Boolean;\r\n published\r\n property Picture: TPicture read FPicture write SetPicture;\r\n property Stretch: Boolean read FStretch write SetStretch;\r\n property Proportional: Boolean read FProportional write SetProportional;\r\n property Center: Boolean read FCenter write SetCenter;\r\n property Tile: Boolean read FTile write SetTile;\r\n property Transparent: Boolean read FTransparent write SetTransparent;\r\n property OnChange: TNotifyEvent read FOnChange write FOnChange;\r\n end;\r\n\r\n TJvNavPanelPage = class(TJvCustomPage)\r\n private\r\n FNavPanel: TJvNavPanelButton;\r\n FIconButton: TJvNavIconButton;\r\n FOnClick: TNotifyEvent;\r\n FIconPanel: TJvIconPanel;\r\n FStyleManager: TJvNavPaneStyleManager;\r\n FStyleLink: TJvNavStyleLink;\r\n FHeader: TJvNavPanelHeader;\r\n FImageIndex: TImageIndex;\r\n FParentStyleManager: Boolean;\r\n FBackground: TJvNavPaneBackgroundImage;\r\n procedure SetCaption(const Value: TCaption);\r\n procedure SetIconic(const Value: Boolean);\r\n procedure SetImageIndex(const Value: TImageIndex);\r\n function GetCaption: TCaption;\r\n function GetIconic: Boolean;\r\n function GetImageIndex: TImageIndex;\r\n procedure DoButtonClick(Sender: TObject);\r\n function GetHint: string;\r\n procedure SetHint(const Value: string);\r\n\r\n procedure SetIconPanel(const Value: TJvIconPanel);\r\n function GetColors: TJvNavPanelColors;\r\n procedure SetColors(const Value: TJvNavPanelColors);\r\n procedure SetStyleManager(const Value: TJvNavPaneStyleManager);\r\n procedure DoStyleChange(Sender: TObject);\r\n procedure SetAutoHeader(const Value: Boolean);\r\n function GetAutoHeader: Boolean;\r\n function GetAlignment: TAlignment;\r\n function GetWordWrap: Boolean;\r\n procedure SetAlignment(const Value: TAlignment);\r\n procedure SetWordWrap(const Value: Boolean);\r\n procedure ParentStyleManagerChanged(var Msg: TMsgStyleManagerChange); message CM_PARENTSTYLEMANAGERCHANGED;\r\n procedure ParentStyleManagerChange(var Msg: TMessage); message CM_PARENTSTYLEMANAGERCHANGE;\r\n procedure CMControlChange(var Msg: TMessage); message CM_CONTROLCHANGE;\r\n procedure SetParentStyleManager(const Value: Boolean);\r\n procedure SetAction(const Value: TBasicAction);\r\n procedure SetBackground(const Value: TJvNavPaneBackgroundImage);\r\n procedure DoBackgroundChange(Sender: TObject);\r\n protected\r\n procedure UpdatePageList;\r\n function GetAction: TBasicAction; override;\r\n procedure SetParent( AParent: TWinControl); override;\r\n procedure SetPageIndex(Value: Integer); override;\r\n procedure Notification(AComponent: TComponent; Operation: TOperation); override;\r\n property NavPanel: TJvNavPanelButton read FNavPanel;\r\n property IconButton: TJvNavIconButton read FIconButton;\r\n property IconPanel: TJvIconPanel read FIconPanel write SetIconPanel;\r\n property Colors: TJvNavPanelColors read GetColors write SetColors;\r\n property StyleManager: TJvNavPaneStyleManager read FStyleManager write SetStyleManager;\r\n // (p3) must be published after StyleManager\r\n property ParentStyleManager: Boolean read FParentStyleManager write SetParentStyleManager default True;\r\n property Header: TJvNavPanelHeader read FHeader;\r\n property Alignment: TAlignment read GetAlignment write SetAlignment;\r\n property WordWrap: Boolean read GetWordWrap write SetWordWrap;\r\n procedure ActionChange(Sender: TObject; CheckDefaults: Boolean); override;\r\n procedure Paint; override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n property AutoHeader: Boolean read GetAutoHeader write SetAutoHeader;\r\n published\r\n property Action: TBasicAction read GetAction write SetAction;\r\n property Background: TJvNavPaneBackgroundImage read FBackground write SetBackground;\r\n\r\n property Color default clWindow;\r\n property ParentColor default False;\r\n property Caption: TCaption read GetCaption write SetCaption;\r\n property DragCursor;\r\n property DragKind;\r\n property OnStartDock;\r\n property OnDockDrop;\r\n property OnDockOver;\r\n property OnUnDock;\r\n property OnEndDock;\r\n property DragMode;\r\n\r\n property Iconic: Boolean read GetIconic write SetIconic default False;\r\n property ImageIndex: TImageIndex read GetImageIndex write SetImageIndex default -1;\r\n property Hint: string read GetHint write SetHint;\r\n property OnClick: TNotifyEvent read FOnClick write FOnClick;\r\n property OnContextPopup;\r\n property OnDragDrop;\r\n property OnDragOver;\r\n property OnEndDrag;\r\n property OnEnter;\r\n property OnExit;\r\n property OnKeyDown;\r\n property OnKeyPress;\r\n property OnKeyUp;\r\n property OnMouseDown;\r\n property OnMouseEnter;\r\n property OnMouseLeave;\r\n property OnMouseMove;\r\n property OnMouseUp;\r\n property OnMouseWheel;\r\n property OnMouseWheelDown;\r\n property OnMouseWheelUp;\r\n property OnResize;\r\n property OnShow;\r\n property OnStartDrag;\r\n end;\r\n\r\n TJvCustomNavPaneToolPanel = class;\r\n\r\n TJvNavPaneToolButton = class(TCollectionItem)\r\n private\r\n FRealButton: TJvNavPanelToolButton;\r\n procedure SetImageIndex(const Value: TImageIndex);\r\n procedure SetEnabled(const Value: Boolean);\r\n procedure SetAction(const Value: TBasicAction);\r\n procedure SetHint(const Value: string);\r\n function GetAction: TBasicAction;\r\n function GetEnabled: Boolean;\r\n function GetHint: string;\r\n function GetImageIndex: TImageIndex;\r\n public\r\n procedure Assign(Source: TPersistent); override;\r\n constructor Create(Collection: Classes.TCollection); override;\r\n destructor Destroy; override;\r\n property Button: TJvNavPanelToolButton read FRealButton;\r\n published\r\n property Action: TBasicAction read GetAction write SetAction;\r\n property Hint: string read GetHint write SetHint;\r\n property ImageIndex: TImageIndex read GetImageIndex write SetImageIndex default -1;\r\n property Enabled: Boolean read GetEnabled write SetEnabled default True;\r\n end;\r\n\r\n TJvNavPaneToolButtons = class(TOwnedCollection)\r\n private\r\n FPanel: TJvCustomNavPaneToolPanel;\r\n function GetItem(Index: Integer): TJvNavPaneToolButton;\r\n procedure SetItem(Index: Integer; const Value: TJvNavPaneToolButton);\r\n protected\r\n procedure Update(Item: TCollectionItem); override;\r\n public\r\n constructor Create(AOwner: TJvCustomNavPaneToolPanel);\r\n function Add: TJvNavPaneToolButton;\r\n property Items[Index: Integer]: TJvNavPaneToolButton read GetItem write SetItem; default;\r\n end;\r\n\r\n TJvNavPaneToolButtonClick = procedure(Sender: TObject; Index: Integer) of object;\r\n TJvToolPanelHitTestInfo = (phtNowhere, phtAbove, phtBelow, phtToLeft, phtToRight, phtGrabber, phtHeader, phtClient);\r\n TJvToolPanelHitTestInfos = set of TJvToolPanelHitTestInfo;\r\n\r\n TJvCustomNavPaneToolPanel = class(TJvCustomControl)\r\n private\r\n FStyleLink: TJvNavStyleLink;\r\n FChangeLink: TChangeLink;\r\n FStyleManager: TJvNavPaneStyleManager;\r\n FButtonWidth: Integer;\r\n FHeaderHeight: Integer;\r\n FEdgeRounding: Integer;\r\n FButtonHeight: Integer;\r\n FImages: TCustomImageList;\r\n FButtons: TJvNavPaneToolButtons;\r\n FOnButtonClick: TJvNavPaneToolButtonClick;\r\n FDropDown: TJvNavPanelToolButton;\r\n FCloseButton: TJvNavPanelToolButton;\r\n FOnClose: TNotifyEvent;\r\n FShowGrabber: Boolean;\r\n FOnDropDownMenu: TContextPopupEvent;\r\n FParentStyleManager: Boolean;\r\n FBackground: TJvNavPaneBackgroundImage;\r\n FColors: TJvNavPanelColors;\r\n FHeaderVisible: Boolean;\r\n procedure DoStyleChange(Sender: TObject);\r\n procedure DoImagesChange(Sender: TObject);\r\n procedure ButtonsChanged;\r\n procedure SetStyleManager(const Value: TJvNavPaneStyleManager);\r\n procedure SetButtonHeight(const Value: Integer);\r\n procedure SetButtonWidth(const Value: Integer);\r\n procedure SetEdgeRounding(const Value: Integer);\r\n procedure SetHeaderHeight(const Value: Integer);\r\n procedure SetImages(const Value: TCustomImageList);\r\n procedure SetButtons(const Value: TJvNavPaneToolButtons);\r\n procedure InternalButtonClick(Sender: TObject);\r\n function GetCloseButton: Boolean;\r\n function GetDropDownMenu: TPopupMenu;\r\n procedure SetCloseButton(const Value: Boolean);\r\n procedure SetDropDownMenu(const Value: TPopupMenu);\r\n procedure DoCloseClick(Sender: TObject);\r\n procedure SetShowGrabber(const Value: Boolean);\r\n procedure ParentStyleManagerChanged(var Msg: TMsgStyleManagerChange); message CM_PARENTSTYLEMANAGERCHANGED;\r\n procedure ParentStyleManagerChange(var Msg: TMessage); message CM_PARENTSTYLEMANAGERCHANGE;\r\n procedure SetParentStyleManager(const Value: Boolean);\r\n function GetDrawPartialMenuFrame: Boolean;\r\n procedure SetDrawPartialMenuFrame(const Value: Boolean);\r\n procedure SetBackground(const Value: TJvNavPaneBackgroundImage);\r\n procedure SetColors(const Value: TJvNavPanelColors);\r\n procedure SetHeaderVisible(const Value: Boolean);\r\n function IsColorsStored: Boolean;\r\n procedure CMControlChange(var Msg: TMessage); message CM_CONTROLCHANGE;\r\n procedure WMEraseBkgnd(var Msg: TWMEraseBkgnd); message WM_ERASEBKGND;\r\n procedure WMNCPaint(var Msg: TWMNCPaint); message WM_NCPAINT;\r\n procedure AlignButtons;\r\n protected\r\n procedure Paint; override;\r\n procedure Notification(AComponent: TComponent; Operation: TOperation); override;\r\n procedure TextChanged; override;\r\n procedure FontChanged; override;\r\n procedure DoDropDownMenu(Sender: TObject; MousePos: TPoint; var Handled: Boolean);\r\n property EdgeRounding: Integer read FEdgeRounding write SetEdgeRounding default 9;\r\n procedure AdjustClientRect(var Rect: TRect); override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n function GetHitTestInfoAt(X, Y: Integer): TJvToolPanelHitTestInfos;\r\n procedure SetBounds(ALeft: Integer; ATop: Integer; AWidth: Integer; AHeight: Integer); override;\r\n protected\r\n property Background: TJvNavPaneBackgroundImage read FBackground write SetBackground;\r\n property DrawPartialMenuFrame: Boolean read GetDrawPartialMenuFrame write SetDrawPartialMenuFrame default False;\r\n property Buttons: TJvNavPaneToolButtons read FButtons write SetButtons;\r\n property ButtonWidth: Integer read FButtonWidth write SetButtonWidth default 25;\r\n property ButtonHeight: Integer read FButtonHeight write SetButtonHeight default 22;\r\n property CloseButton: Boolean read GetCloseButton write SetCloseButton default True;\r\n property Colors: TJvNavPanelColors read FColors write SetColors stored IsColorsStored;\r\n\r\n property DropDownMenu: TPopupMenu read GetDropDownMenu write SetDropDownMenu;\r\n property HeaderHeight: Integer read FHeaderHeight write SetHeaderHeight default 29;\r\n property HeaderVisible: Boolean read FHeaderVisible write SetHeaderVisible default True;\r\n property Images: TCustomImageList read FImages write SetImages;\r\n// property ParentColor default False;\r\n property ShowGrabber: Boolean read FShowGrabber write SetShowGrabber default True;\r\n property StyleManager: TJvNavPaneStyleManager read FStyleManager write SetStyleManager;\r\n property ParentStyleManager: Boolean read FParentStyleManager write SetParentStyleManager default True;\r\n property OnButtonClick: TJvNavPaneToolButtonClick read FOnButtonClick write FOnButtonClick;\r\n property OnClose: TNotifyEvent read FOnClose write FOnClose;\r\n property OnDropDownMenu: TContextPopupEvent read FOnDropDownMenu write FOnDropDownMenu;\r\n end;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvNavPaneToolPanel = class(TJvCustomNavPaneToolPanel)\r\n published\r\n property Align;\r\n property Anchors;\r\n property Caption;\r\n property Constraints;\r\n property BorderWidth;\r\n property DragCursor;\r\n property DragKind;\r\n property DragMode;\r\n\r\n property Background;\r\n property DrawPartialMenuFrame;\r\n property Buttons;\r\n property ButtonWidth;\r\n property ButtonHeight;\r\n property CloseButton;\r\n property Colors;\r\n property DropDownMenu;\r\n property HeaderHeight;\r\n property HeaderVisible;\r\n property Images;\r\n property ShowGrabber;\r\n property StyleManager;\r\n // (p3) must be published after StyleManager\r\n property ParentStyleManager;\r\n property OnButtonClick;\r\n property OnClose;\r\n property OnDropDownMenu;\r\n\r\n property Enabled;\r\n property Font;\r\n property ParentColor;\r\n property ParentFont;\r\n property ParentShowHint;\r\n property PopupMenu;\r\n property ShowHint;\r\n property Visible;\r\n property Width default 185;\r\n property Height default 41;\r\n property OnEndDock;\r\n property OnStartDock;\r\n property OnUnDock;\r\n property OnClick;\r\n property OnContextPopup;\r\n property OnDragDrop;\r\n property OnDragOver;\r\n property OnEndDrag;\r\n property OnMouseDown;\r\n property OnMouseMove;\r\n property OnMouseUp;\r\n property OnMouseEnter;\r\n property OnMouseLeave;\r\n property OnStartDrag;\r\n end;\r\n\r\n TJvCustomNavigationPane = class(TJvCustomPageList)\r\n private\r\n FIconPanel: TJvIconPanel;\r\n FSplitter: TJvOutlookSplitter;\r\n FLargeImages: TCustomImageList;\r\n FSmallImages: TCustomImageList;\r\n FColors: TJvNavPanelColors;\r\n FNavPanelFont: TFont;\r\n FResizable: Boolean;\r\n FButtonWidth: Integer;\r\n FButtonHeight: Integer;\r\n FStyleManager: TJvNavPaneStyleManager;\r\n FStyleLink: TJvNavStyleLink;\r\n FNavPanelHotTrackFont: TFont;\r\n FNavPanelHotTrackFontOptions: TJvTrackFontOptions;\r\n FAutoHeaders: Boolean;\r\n FWordWrap: Boolean;\r\n FAlignment: TAlignment;\r\n FOnDropDownMenu: TContextPopupEvent;\r\n FParentStyleManager: Boolean;\r\n FBackground: TJvNavPaneBackgroundImage;\r\n function GetDropDownMenu: TPopupMenu;\r\n function GetSmallImages: TCustomImageList;\r\n procedure SetDropDownMenu(const Value: TPopupMenu);\r\n procedure SetLargeImages(const Value: TCustomImageList);\r\n procedure SetSmallImages(const Value: TCustomImageList);\r\n function GetMaximizedCount: Integer;\r\n procedure SetMaximizedCount(Value: Integer);\r\n procedure HidePanel(Index: Integer);\r\n procedure ShowPanel(Index: Integer);\r\n procedure SetColors(const Value: TJvNavPanelColors);\r\n procedure SetResizable(const Value: Boolean);\r\n function GetNavPage(Index: Integer): TJvNavPanelPage;\r\n procedure DoSplitterCanResize(Sender: TObject; var NewSize: Integer; var Accept: Boolean);\r\n procedure DoColorsChange(Sender: TObject);\r\n procedure SetNavPanelFont(const Value: TFont);\r\n procedure SetNavPanelHotTrackFont(const Value: TFont);\r\n procedure SetNavPanelHotTrackFontOptions(const Value: TJvTrackFontOptions);\r\n\r\n procedure DoNavPanelFontChange(Sender: TObject);\r\n procedure SetButtonHeight(const Value: Integer);\r\n procedure SetButtonWidth(const Value: Integer);\r\n procedure SetSplitterHeight(const Value: Integer);\r\n function GetSplitterHeight: Integer;\r\n procedure SetStyleManager(const Value: TJvNavPaneStyleManager);\r\n procedure DoStyleChange(Sender: TObject);\r\n procedure SetAutoHeaders(const Value: Boolean);\r\n procedure SetAlignment(const Value: TAlignment);\r\n procedure SetWordWrap(const Value: Boolean);\r\n procedure ParentStyleManagerChanged(var Msg: TMsgStyleManagerChange); message CM_PARENTSTYLEMANAGERCHANGED;\r\n procedure ParentStyleManagerChange(var Msg: TMessage); message CM_PARENTSTYLEMANAGERCHANGE;\r\n procedure CMControlChange(var Msg: TMessage); message CM_CONTROLCHANGE;\r\n procedure WMNCPaint(var Msg: TWMNCPaint); message WM_NCPAINT;\r\n procedure WMEraseBkgnd(var Msg: TWMEraseBkgnd); message WM_ERASEBKGND;\r\n procedure SetParentStyleManager(const Value: Boolean);\r\n procedure SetBackground(const Value: TJvNavPaneBackgroundImage);\r\n function GetSplitterClick: TNotifyEvent;\r\n function GetSplitterDblClick: TNotifyEvent;\r\n function GetSplitterMouseDown: TMouseEvent;\r\n function GetSplitterMouseEnter: TNotifyEvent;\r\n function GetSplitterMouseLeave: TNotifyEvent;\r\n function GetSplitterMouseMove: TMouseMoveEvent;\r\n function GetSplitterMouseUp: TMouseEvent;\r\n procedure SetSplitterClick(const Value: TNotifyEvent);\r\n procedure SetSplitterDblClick(const Value: TNotifyEvent);\r\n procedure SetSplitterMouseDown(const Value: TMouseEvent);\r\n procedure SetSplitterMouseEnter(const Value: TNotifyEvent);\r\n procedure SetSplitterMouseLeave(const Value: TNotifyEvent);\r\n procedure SetSplitterMouseMove(const Value: TMouseMoveEvent);\r\n procedure SetSplitterMouseUp(const Value: TMouseEvent);\r\n function GetSplitterCanResize: TCanResizeEvent;\r\n function GetSplitterMoved: TNotifyEvent;\r\n function GetSplitterPaint: TNotifyEvent;\r\n procedure SetSplitterCanResize(const Value: TCanResizeEvent);\r\n procedure SetSplitterMoved(const Value: TNotifyEvent);\r\n procedure SetSplitterPaint(const Value: TNotifyEvent);\r\n protected\r\n function IsColorsStored: Boolean;\r\n function IsNavPanelFontStored: Boolean;\r\n function IsNavPanelFontHotTrackStored: Boolean;\r\n function IsNavPanelHotTrackFontOptionsStored: Boolean;\r\n procedure UpdatePages; virtual;\r\n procedure SetActivePage(Page: TJvCustomPage); override;\r\n procedure InsertPage(APage: TJvCustomPage); override;\r\n procedure RemovePage(APage: TJvCustomPage); override;\r\n\r\n procedure Notification(AComponent: TComponent; Operation: TOperation); override;\r\n procedure Loaded; override;\r\n procedure DoDropDownMenu(Sender: TObject; MousePos: TPoint; var Handled: Boolean);\r\n function InternalGetPageClass: TJvCustomPageClass; override;\r\n property NavPages[Index: Integer]: TJvNavPanelPage read GetNavPage;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n function HidePage(Page: TJvCustomPage): TJvCustomPage; override;\r\n function ShowPage(Page: TJvCustomPage; PageIndex: Integer = -1): TJvCustomPage; override;\r\n procedure UpdatePositions;\r\n protected\r\n property BorderWidth default 1;\r\n property AutoHeaders: Boolean read FAutoHeaders write SetAutoHeaders default False;\r\n property Alignment: TAlignment read FAlignment write SetAlignment default taLeftJustify;\r\n property Background: TJvNavPaneBackgroundImage read FBackground write SetBackground;\r\n property ButtonHeight: Integer read FButtonHeight write SetButtonHeight default 28;\r\n property ButtonWidth: Integer read FButtonWidth write SetButtonWidth default 22;\r\n property NavPanelFont: TFont read FNavPanelFont write SetNavPanelFont;\r\n property NavPanelHotTrackFont: TFont read FNavPanelHotTrackFont write SetNavPanelHotTrackFont;\r\n property NavPanelHotTrackFontOptions: TJvTrackFontOptions read FNavPanelHotTrackFontOptions write SetNavPanelHotTrackFontOptions;\r\n\r\n property Color default clWindow;\r\n property Colors: TJvNavPanelColors read FColors write SetColors;\r\n property StyleManager: TJvNavPaneStyleManager read FStyleManager write SetStyleManager;\r\n // (p3) must be published after StyleManager\r\n property ParentStyleManager: Boolean read FParentStyleManager write SetParentStyleManager default True;\r\n property DropDownMenu: TPopupMenu read GetDropDownMenu write SetDropDownMenu;\r\n property LargeImages: TCustomImageList read FLargeImages write SetLargeImages;\r\n property MaximizedCount: Integer read GetMaximizedCount write SetMaximizedCount;\r\n property ParentColor default False;\r\n property Resizable: Boolean read FResizable write SetResizable default True;\r\n property SmallImages: TCustomImageList read GetSmallImages write SetSmallImages;\r\n property SplitterHeight: Integer read GetSplitterHeight write SetSplitterHeight default 7;\r\n property WordWrap: Boolean read FWordWrap write SetWordWrap default False;\r\n property Splitter: TJvOutlookSplitter read FSplitter;\r\n property IconPanel: TJvIconPanel read FIconPanel;\r\n property OnDropDownMenu: TContextPopupEvent read FOnDropDownMenu write FOnDropDownMenu;\r\n\r\n property OnSplitterCanResize: TCanResizeEvent read GetSplitterCanResize write SetSplitterCanResize;\r\n property OnSplitterMoved: TNotifyEvent read GetSplitterMoved write SetSplitterMoved;\r\n property OnSplitterPaint: TNotifyEvent read GetSplitterPaint write SetSplitterPaint;\r\n property OnSplitterClick: TNotifyEvent read GetSplitterClick write SetSplitterClick;\r\n property OnSplitterMouseEnter: TNotifyEvent read GetSplitterMouseEnter write SetSplitterMouseEnter;\r\n property OnSplitterMouseLeave: TNotifyEvent read GetSplitterMouseLeave write SetSplitterMouseLeave;\r\n property OnSplitterDblClick: TNotifyEvent read GetSplitterDblClick write SetSplitterDblClick;\r\n property OnSplitterMouseDown: TMouseEvent read GetSplitterMouseDown write SetSplitterMouseDown;\r\n property OnSplitterMouseMove: TMouseMoveEvent read GetSplitterMouseMove write SetSplitterMouseMove;\r\n property OnSplitterMouseUp: TMouseEvent read GetSplitterMouseUp write SetSplitterMouseUp;\r\n end;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvNavigationPane = class(TJvCustomNavigationPane)\r\n public\r\n property NavPages;\r\n property Splitter;\r\n property IconPanel;\r\n published\r\n property ActivePage;\r\n // property Alignment;\r\n property Align;\r\n property Anchors;\r\n property AutoHeaders;\r\n property BorderWidth;\r\n property DragCursor;\r\n property DragKind;\r\n property OnStartDock;\r\n property OnDockDrop;\r\n property OnDockOver;\r\n property OnUnDock;\r\n property OnEndDock;\r\n property Background;\r\n property ButtonHeight;\r\n property ButtonWidth;\r\n property Caption;\r\n property Color;\r\n property Colors stored IsColorsStored;\r\n property StyleManager;\r\n // (p3) must be published after StyleManager\r\n property ParentStyleManager;\r\n property Constraints;\r\n\r\n property DragMode;\r\n property DropDownMenu;\r\n property Enabled;\r\n property Font;\r\n property ParentFont;\r\n property ParentShowHint;\r\n property PopupMenu;\r\n property ShowHint;\r\n property SplitterHeight;\r\n property Visible;\r\n\r\n property LargeImages;\r\n property MaximizedCount;\r\n property NavPanelFont stored IsNavPanelFontStored;\r\n property NavPanelHotTrackFont stored IsNavPanelFontHotTrackStored;\r\n property NavPanelHotTrackFontOptions stored IsNavPanelHotTrackFontOptionsStored;\r\n\r\n property Resizable;\r\n property SmallImages;\r\n // property WordWrap;\r\n property OnChange;\r\n property OnChanging;\r\n property OnDropDownMenu;\r\n property OnClick;\r\n property OnContextPopup;\r\n property OnDragDrop;\r\n property OnDragOver;\r\n property OnEndDrag;\r\n property OnStartDrag;\r\n property OnEnter;\r\n property OnExit;\r\n property OnKeyDown;\r\n property OnKeyPress;\r\n property OnKeyUp;\r\n property OnMouseDown;\r\n property OnMouseEnter;\r\n property OnMouseLeave;\r\n property OnMouseMove;\r\n property OnMouseUp;\r\n property OnMouseWheel;\r\n property OnMouseWheelDown;\r\n property OnMouseWheelUp;\r\n property OnResize;\r\n\r\n property OnSplitterCanResize;\r\n property OnSplitterMoved;\r\n property OnSplitterPaint;\r\n property OnSplitterClick;\r\n property OnSplitterMouseEnter;\r\n property OnSplitterMouseLeave;\r\n property OnSplitterDblClick;\r\n property OnSplitterMouseDown;\r\n property OnSplitterMouseMove;\r\n property OnSplitterMouseUp;\r\n end;\r\n\r\n TJvNavStyleLink = class(TObject)\r\n private\r\n FSender: TObject;\r\n FOnChange: TNotifyEvent;\r\n public\r\n destructor Destroy; override;\r\n procedure Change; dynamic;\r\n property OnChange: TNotifyEvent read FOnChange write FOnChange;\r\n property Sender: TObject read FSender write FSender;\r\n end;\r\n\r\n TJvNavPanelTheme = (nptStandard, nptXPBlue, nptXPSilver, nptXPOlive, nptCustom);\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvNavPaneStyleManager = class(TJvComponent)\r\n private\r\n FColors: TJvNavPanelColors;\r\n FTheme: TJvNavPanelTheme;\r\n FClients: TList;\r\n FFonts: TJvNavPanelFonts;\r\n FOnThemeChange: TNotifyEvent;\r\n procedure SetColors(const Value: TJvNavPanelColors);\r\n procedure SetTheme(const Value: TJvNavPanelTheme);\r\n procedure DoThemeChange(Sender: TObject);\r\n procedure SetFonts(const Value: TJvNavPanelFonts);\r\n function IsColorsStored: Boolean;\r\n function IsFontsStored: Boolean;\r\n protected\r\n procedure Change; virtual;\r\n procedure AssignTo(Dest: TPersistent); override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n procedure Assign(Source: TPersistent); override;\r\n procedure RegisterChanges(Value: TJvNavStyleLink);\r\n procedure UnregisterChanges(Value: TJvNavStyleLink);\r\n published\r\n property Colors: TJvNavPanelColors read FColors write SetColors stored IsColorsStored;\r\n property Fonts: TJvNavPanelFonts read FFonts write SetFonts stored IsFontsStored;\r\n property Theme: TJvNavPanelTheme read FTheme write SetTheme nodefault;\r\n property OnThemeChange: TNotifyEvent read FOnThemeChange write FOnThemeChange;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvNavigationPane.pas $';\r\n Revision: '$Revision: 13415 $';\r\n Date: '$Date: 2012-09-10 11:51:54 +0200 (lun. 10 sept. 2012) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n Types, Forms, ActnList,\r\n JvJVCLUtils, JvJCLUtils, JvResources;\r\n\r\nconst\r\n cNavPanelButtonGroupIndex = 113;\r\n cToolButtonHeight = 18;\r\n cToolButtonOffset = 14;\r\n cToolButtonWidth = 18;\r\n\r\nconst\r\n cAlignment: array[TAlignment] of DWORD = (DT_LEFT, DT_RIGHT, DT_CENTER);\r\n cWordWrap: array[Boolean] of DWORD = (DT_SINGLELINE, DT_WORDBREAK);\r\n\r\nprocedure InternalStyleManagerChanged(AControl: TWinControl; AStyleManager: TJvNavPaneStyleManager);\r\nvar\r\n Msg: TMsgStyleManagerChange;\r\nbegin\r\n Msg.Msg := CM_PARENTSTYLEMANAGERCHANGED;\r\n Msg.Sender := AControl;\r\n Msg.StyleManager := AStyleManager;\r\n Msg.Result := 0;\r\n AControl.Broadcast(Msg);\r\nend;\r\n\r\n//=== { TJvIconPanel } =======================================================\r\n\r\nconstructor TJvIconPanel.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n ControlStyle := ControlStyle - [csAcceptsControls];\r\n FStyleLink := TJvNavStyleLink.Create;\r\n FStyleLink.OnChange := DoStyleChange;\r\n ControlStyle := ControlStyle + [csOpaque, csAcceptsControls];\r\n Height := 28;\r\n FDropButton := TJvNavIconButton.Create(Self);\r\n FDropButton.Visible := False;\r\n FDropButton.ButtonType := nibDropDown;\r\n FDropButton.GroupIndex := 0;\r\n FDropButton.Width := 22;\r\n FDropButton.Left := Width + 10;\r\n FDropButton.Align := alRight;\r\n FDropButton.Parent := Self;\r\n FDropButton.OnDropDownMenu := DoDropDownMenu;\r\n FColors := TJvNavPanelColors.Create;\r\n FColors.OnChange := DoColorsChange;\r\n FParentStyleManager := True;\r\nend;\r\n\r\ndestructor TJvIconPanel.Destroy;\r\nbegin\r\n FStyleLink.Free;\r\n FColors.Free;\r\n // Don't free FDropButton: it is freed automatically\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvIconPanel.DoColorsChange(Sender: TObject);\r\nbegin\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvIconPanel.DoStyleChange(Sender: TObject);\r\nbegin\r\n Colors := (Sender as TJvNavPaneStyleManager).Colors;\r\n Font := (Sender as TJvNavPaneStyleManager).Fonts.NavPanelFont;\r\nend;\r\n\r\nfunction TJvIconPanel.GetDropDownMenu: TPopupMenu;\r\nbegin\r\n Result := FDropButton.DropDownMenu\r\nend;\r\n\r\nprocedure TJvIconPanel.Notification(AComponent: TComponent;\r\n Operation: TOperation);\r\nbegin\r\n inherited Notification(AComponent, Operation);\r\n if Operation = opRemove then\r\n begin\r\n if AComponent = StyleManager then\r\n StyleManager := nil;\r\n end;\r\nend;\r\n\r\nprocedure TJvIconPanel.Paint;\r\nbegin\r\n GradientFillRect(Canvas, ClientRect, Colors.ButtonColorFrom, Colors.ButtonColorTo, fdTopToBottom, 32);\r\n Canvas.Pen.Color := Colors.FrameColor;\r\n if Align = alBottom then\r\n begin\r\n Canvas.MoveTo(0, 0);\r\n Canvas.LineTo(Width + 1, 0);\r\n end\r\n else\r\n begin\r\n Canvas.MoveTo(0, ClientHeight - 1);\r\n Canvas.LineTo(Width + 1, ClientHeight - 1);\r\n end;\r\nend;\r\n\r\nprocedure TJvIconPanel.SetColors(const Value: TJvNavPanelColors);\r\nbegin\r\n FColors.Assign(Value);\r\n FDropButton.Colors := Value;\r\nend;\r\n\r\nprocedure TJvIconPanel.SetStyleManager(const Value: TJvNavPaneStyleManager);\r\nbegin\r\n if FStyleManager <> Value then\r\n begin\r\n ParentStyleManager := False;\r\n\r\n if FStyleManager <> nil then\r\n FStyleManager.UnregisterChanges(FStyleLink);\r\n ReplaceComponentReference(Self, Value, TComponent(FStyleManager));\r\n if FStyleManager <> nil then\r\n begin\r\n FStyleManager.RegisterChanges(FStyleLink);\r\n Colors := FStyleManager.Colors;\r\n end;\r\n end;\r\n // FDropButton.StyleManager := Value;\r\n InternalStyleManagerChanged(Self, Value);\r\nend;\r\n\r\nprocedure TJvIconPanel.SetDropDownMenu(const Value: TPopupMenu);\r\nbegin\r\n FDropButton.DropDownMenu := Value;\r\n FDropButton.Visible := Value <> nil;\r\nend;\r\n\r\nprocedure TJvIconPanel.DoDropDownMenu(Sender: TObject; MousePos: TPoint;\r\n var Handled: Boolean);\r\nbegin\r\n if Assigned(FOnDropDownMenu) then\r\n FOnDropDownMenu(Self, MousePos, Handled);\r\nend;\r\n\r\nprocedure TJvIconPanel.ParentStyleManagerChanged(var Msg: TMsgStyleManagerChange);\r\nbegin\r\n if (Msg.Sender <> Self) and ParentStyleManager then\r\n begin\r\n StyleManager := Msg.StyleManager;\r\n ParentStyleManager := True;\r\n InternalStyleManagerChanged(Self, Msg.StyleManager);\r\n end;\r\nend;\r\n\r\nprocedure TJvIconPanel.SetParentStyleManager(const Value: Boolean);\r\nbegin\r\n if FParentStyleManager <> Value then\r\n begin\r\n FParentStyleManager := Value;\r\n if FParentStyleManager and (Parent <> nil) then\r\n Parent.Perform(CM_PARENTSTYLEMANAGERCHANGE, 0, 0);\r\n end;\r\nend;\r\n\r\nprocedure TJvIconPanel.CMControlChange(var Msg: TMessage);\r\nbegin\r\n InternalStyleManagerChanged(Self, StyleManager);\r\nend;\r\n\r\nprocedure TJvIconPanel.WMEraseBkgnd(var Msg: TWMEraseBkgnd);\r\nbegin\r\n Msg.Result := 1;\r\nend;\r\n\r\nprocedure TJvIconPanel.ParentStyleManagerChange(var Msg: TMessage);\r\nbegin\r\n InternalStyleManagerChanged(Self, StyleManager);\r\nend;\r\n\r\n//=== { TJvCustomNavigationPane } ============================================\r\n\r\nvar\r\n GlobalNavPanelPageRegistered: Boolean = False;\r\n\r\nconstructor TJvCustomNavigationPane.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n if not GlobalNavPanelPageRegistered then\r\n begin\r\n GlobalNavPanelPageRegistered := True;\r\n RegisterClasses([TJvNavPanelPage]);\r\n end;\r\n\r\n FBackground := TJvNavPaneBackgroundImage.Create;\r\n FBackground.OnChange := DoColorsChange;\r\n ControlStyle := ControlStyle - [csAcceptsControls];\r\n FStyleLink := TJvNavStyleLink.Create;\r\n FStyleLink.OnChange := DoStyleChange;\r\n FButtonHeight := 28;\r\n FButtonWidth := 22;\r\n BorderWidth := 1;\r\n ParentColor := False;\r\n Color := clWindow;\r\n ControlStyle := ControlStyle + [csOpaque];\r\n FResizable := True;\r\n FColors := TJvNavPanelColors.Create;\r\n FColors.OnChange := DoColorsChange;\r\n FIconPanel := TJvIconPanel.Create(Self);\r\n FIconPanel.Parent := Self;\r\n FIconPanel.Align := alBottom;\r\n FIconPanel.OnDropDownMenu := DoDropDownMenu;\r\n\r\n FNavPanelFont := TFont.Create;\r\n FNavPanelHotTrackFont := TFont.Create;\r\n FNavPanelFont.Assign(Screen.IconFont);\r\n FNavPanelFont.Style := [fsBold];\r\n FNavPanelFont.OnChange := DoNavPanelFontChange;\r\n FNavPanelHotTrackFont.Assign(FNavPanelFont);\r\n FNavPanelHotTrackFont.OnChange := DoNavPanelFontChange;\r\n FNavPanelHotTrackFontOptions := DefaultTrackFontOptions;\r\n FSplitter := TJvOutlookSplitter.Create(Self);\r\n with FSplitter do\r\n begin\r\n ResizeStyle := rsNone;\r\n MinSize := 1;\r\n OnCanResize := DoSplitterCanResize;\r\n Parent := Self;\r\n end;\r\n FParentStyleManager := True;\r\n FIconPanel.SetSubComponent(True);\r\n FSplitter.SetSubComponent(True);\r\nend;\r\n\r\ndestructor TJvCustomNavigationPane.Destroy;\r\nbegin\r\n FStyleLink.Free;\r\n FColors.Free;\r\n FNavPanelFont.Free;\r\n FNavPanelHotTrackFont.Free;\r\n FBackground.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvCustomNavigationPane.DoSplitterCanResize(Sender: TObject;\r\n var NewSize: Integer; var Accept: Boolean);\r\nvar\r\n ACount: Integer;\r\nbegin\r\n ACount := MaximizedCount;\r\n if NewSize < ButtonHeight div 2 then\r\n MaximizedCount := ACount - 1\r\n else\r\n if NewSize > ButtonHeight + ButtonHeight div 2 then\r\n MaximizedCount := ACount + 1;\r\n NewSize := 0;\r\n Accept := False;\r\nend;\r\n\r\nfunction TJvCustomNavigationPane.GetDropDownMenu: TPopupMenu;\r\nbegin\r\n if FIconPanel <> nil then\r\n Result := FIconPanel.DropDownMenu\r\n else\r\n Result := nil;\r\nend;\r\n\r\nfunction TJvCustomNavigationPane.GetSmallImages: TCustomImageList;\r\nbegin\r\n Result := FSmallImages;\r\nend;\r\n\r\nfunction TJvCustomNavigationPane.GetMaximizedCount: Integer;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := 0;\r\n for I := 0 to PageCount - 1 do\r\n if not NavPages[I].Iconic then\r\n Inc(Result);\r\nend;\r\n\r\nfunction TJvCustomNavigationPane.HidePage(Page: TJvCustomPage): TJvCustomPage;\r\nbegin\r\n Result := inherited HidePage(Page);\r\n if Result <> nil then\r\n UpdatePositions;\r\nend;\r\n\r\nfunction TJvCustomNavigationPane.ShowPage(Page: TJvCustomPage; PageIndex: Integer): TJvCustomPage;\r\nbegin\r\n Result := inherited ShowPage(Page, PageIndex);\r\n if Result <> nil then\r\n UpdatePositions;\r\nend;\r\n\r\nprocedure TJvCustomNavigationPane.Notification(AComponent: TComponent;\r\n Operation: TOperation);\r\nbegin\r\n inherited Notification(AComponent, Operation);\r\n if Operation = opRemove then\r\n begin\r\n if AComponent = LargeImages then\r\n LargeImages := nil;\r\n if AComponent = SmallImages then\r\n SmallImages := nil;\r\n if AComponent = StyleManager then\r\n StyleManager := nil;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomNavigationPane.SetDropDownMenu(const Value: TPopupMenu);\r\nbegin\r\n if FIconPanel <> nil then\r\n FIconPanel.DropDownMenu := Value;\r\nend;\r\n\r\nprocedure TJvCustomNavigationPane.SetLargeImages(const Value: TCustomImageList);\r\nbegin\r\n if FLargeImages <> Value then\r\n begin\r\n FLargeImages := Value;\r\n UpdatePages;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomNavigationPane.SetSmallImages(const Value: TCustomImageList);\r\nbegin\r\n if FSmallImages <> Value then\r\n begin\r\n FSmallImages := Value;\r\n UpdatePages;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomNavigationPane.HidePanel(Index: Integer);\r\nbegin\r\n if (Index >= 0) and (Index < PageCount) then // don't hide the first panel\r\n NavPages[Index].Iconic := True;\r\nend;\r\n\r\nprocedure TJvCustomNavigationPane.ShowPanel(Index: Integer);\r\nbegin\r\n if (Index >= 0) and (Index < PageCount) then\r\n NavPages[Index].Iconic := False;\r\nend;\r\n\r\nprocedure TJvCustomNavigationPane.SetMaximizedCount(Value: Integer);\r\nvar\r\n I, ACount: Integer;\r\nbegin\r\n ACount := MaximizedCount;\r\n if Value < 0 then\r\n Value := 0;\r\n if Value > PageCount then\r\n Value := PageCount;\r\n if Value = MaximizedCount then\r\n Exit;\r\n while ACount > Value do\r\n begin\r\n HidePanel(ACount - 1);\r\n Dec(ACount);\r\n end;\r\n if Value > ACount then\r\n for I := Value downto ACount do\r\n ShowPanel(I - 1);\r\n UpdatePositions;\r\nend;\r\n\r\nprocedure TJvCustomNavigationPane.UpdatePositions;\r\nvar\r\n I, X, Y: Integer;\r\nbegin\r\n if (csDestroying in ComponentState) or (FIconPanel = nil) then\r\n Exit;\r\n DisableAlign;\r\n FIconPanel.DisableAlign;\r\n try\r\n Y := 0;\r\n X := 0;\r\n FSplitter.Top := Y;\r\n FIconPanel.FDropButton.Left := Width;\r\n FIconPanel.Top := Height - FIconPanel.Height;\r\n Inc(Y, FSplitter.Height);\r\n for I := 0 to PageCount - 1 do\r\n begin\r\n if (NavPages[I].NavPanel = nil) or (NavPages[I].IconButton = nil) then\r\n Exit;\r\n NavPages[I].IconButton.Left := X;\r\n Inc(X, NavPages[I].IconButton.Width);\r\n NavPages[I].NavPanel.Top := Y;\r\n Inc(Y, NavPages[I].NavPanel.Height);\r\n NavPages[I].Invalidate;\r\n end;\r\n finally\r\n EnableAlign;\r\n FIconPanel.EnableAlign;\r\n end;\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvCustomNavigationPane.SetColors(const Value: TJvNavPanelColors);\r\nbegin\r\n FColors.Assign(Value);\r\nend;\r\n\r\nprocedure TJvCustomNavigationPane.DoColorsChange(Sender: TObject);\r\nbegin\r\n if FIconPanel <> nil then\r\n TJvIconPanel(FIconPanel).Colors := Colors;\r\n UpdatePages;\r\n FSplitter.ColorFrom := Colors.SplitterColorFrom;\r\n FSplitter.ColorTo := Colors.SplitterColorTo;\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvCustomNavigationPane.Loaded;\r\nbegin\r\n inherited Loaded;\r\n UpdatePositions;\r\nend;\r\n\r\nprocedure TJvCustomNavigationPane.SetResizable(const Value: Boolean);\r\nbegin\r\n if FResizable <> Value then\r\n begin\r\n FResizable := Value;\r\n FSplitter.Enabled := FResizable;\r\n end;\r\nend;\r\n\r\nfunction TJvCustomNavigationPane.InternalGetPageClass: TJvCustomPageClass;\r\nbegin\r\n Result := TJvNavPanelPage;\r\nend;\r\n\r\nfunction TJvCustomNavigationPane.GetNavPage(Index: Integer): TJvNavPanelPage;\r\nbegin\r\n Result := TJvNavPanelPage(Pages[Index]);\r\nend;\r\n\r\nprocedure TJvCustomNavigationPane.InsertPage(APage: TJvCustomPage);\r\nbegin\r\n inherited InsertPage(APage);\r\n if APage <> nil then\r\n begin\r\n TJvNavPanelPage(APage).Top := FIconPanel.Top;\r\n if (ActivePage = nil) and not (csLoading in ComponentState) then\r\n ActivePage := APage;\r\n end;\r\n UpdatePositions;\r\nend;\r\n\r\nprocedure TJvCustomNavigationPane.SetActivePage(Page: TJvCustomPage);\r\nbegin\r\n inherited SetActivePage(Page);\r\n if ActivePage <> nil then\r\n begin\r\n TJvNavPanelPage(ActivePage).NavPanel.Down := True;\r\n TJvNavPanelPage(ActivePage).IconButton.Down := True;\r\n TJvNavPanelPage(ActivePage).NavPanel.Invalidate;\r\n TJvNavPanelPage(ActivePage).IconButton.Invalidate;\r\n ActivePage.Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomNavigationPane.SetBackground(const Value: TJvNavPaneBackgroundImage);\r\nbegin\r\n FBackground.Assign(Value);\r\nend;\r\n\r\nprocedure TJvCustomNavigationPane.SetNavPanelFont(const Value: TFont);\r\nbegin\r\n FNavPanelFont.Assign(Value);\r\nend;\r\n\r\nprocedure TJvCustomNavigationPane.SetNavPanelHotTrackFont(const Value: TFont);\r\nbegin\r\n FNavPanelHotTrackFont.Assign(Value);\r\nend;\r\n\r\nprocedure TJvCustomNavigationPane.SetNavPanelHotTrackFontOptions(const Value: TJvTrackFontOptions);\r\nbegin\r\n if FNavPanelHotTrackFontOptions <> Value then\r\n begin\r\n FNavPanelHotTrackFontOptions := Value;\r\n UpdatePages;\r\n end;\r\nend;\r\n\r\nfunction TJvCustomNavigationPane.IsNavPanelFontStored: Boolean;\r\nvar\r\n F: TFont;\r\nbegin\r\n F := Screen.IconFont;\r\n with FNavPanelFont do\r\n Result := ((StyleManager = nil) or (StyleManager.Theme = nptCustom)) and ((Name <> F.Name) or (Size <> F.Size) or (Style <> [fsBold]) or\r\n (Color <> F.Color) or (Pitch <> F.Pitch) or (Charset <> F.Charset));\r\nend;\r\n\r\nfunction TJvCustomNavigationPane.IsNavPanelFontHotTrackStored: Boolean;\r\nbegin\r\n Result := IsNavPanelHotTrackFontOptionsStored or IsNavPanelFontStored;\r\nend;\r\n\r\nfunction TJvCustomNavigationPane.IsNavPanelHotTrackFontOptionsStored: Boolean;\r\nbegin\r\n Result := not (hoFollowFont in NavPanelHotTrackFontOptions);\r\nend;\r\n\r\nprocedure TJvCustomNavigationPane.DoNavPanelFontChange(Sender: TObject);\r\nbegin\r\n UpdatePages;\r\nend;\r\n\r\nprocedure TJvCustomNavigationPane.RemovePage(APage: TJvCustomPage);\r\nbegin\r\n inherited RemovePage(APage);\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvCustomNavigationPane.SetButtonHeight(const Value: Integer);\r\nbegin\r\n if FButtonHeight <> Value then\r\n begin\r\n FButtonHeight := Value;\r\n UpdatePages;\r\n FIconPanel.Height := FButtonHeight;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomNavigationPane.SetButtonWidth(const Value: Integer);\r\nbegin\r\n if FButtonWidth <> Value then\r\n begin\r\n FButtonWidth := Value;\r\n UpdatePages;\r\n FIconPanel.FDropButton.Width := FButtonWidth;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomNavigationPane.SetSplitterHeight(const Value: Integer);\r\nbegin\r\n if FSplitter.Height <> Value then\r\n FSplitter.Height := Value;\r\nend;\r\n\r\nfunction TJvCustomNavigationPane.GetSplitterHeight: Integer;\r\nbegin\r\n Result := FSplitter.Height;\r\nend;\r\n\r\nprocedure TJvCustomNavigationPane.SetStyleManager(const Value: TJvNavPaneStyleManager);\r\nbegin\r\n if FStyleManager <> Value then\r\n begin\r\n ParentStyleManager := False;\r\n if FStyleManager <> nil then\r\n FStyleManager.UnregisterChanges(FStyleLink);\r\n ReplaceComponentReference(Self, Value, TComponent(FStyleManager));\r\n if FStyleManager <> nil then\r\n begin\r\n FStyleManager.RegisterChanges(FStyleLink);\r\n Colors := FStyleManager.Colors;\r\n NavPanelFont := FStyleManager.Fonts.FNavPanelFont;\r\n NavPanelHotTrackFont := FStyleManager.Fonts.FNavPanelHotTrackFont;\r\n NavPanelHotTrackFontOptions := FStyleManager.Fonts.FNavPanelHotTrackFontOptions;\r\n end;\r\n // FSplitter.StyleManager := Value;\r\n InternalStyleManagerChanged(Self, Value);\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomNavigationPane.DoStyleChange(Sender: TObject);\r\nbegin\r\n Colors := (Sender as TJvNavPaneStyleManager).Colors;\r\n NavPanelFont := (Sender as TJvNavPaneStyleManager).Fonts.NavPanelFont;\r\n NavPanelHotTrackFont := (Sender as TJvNavPaneStyleManager).Fonts.NavPanelHotTrackFont;\r\n NavPanelHotTrackFontOptions := (Sender as TJvNavPaneStyleManager).Fonts.NavPanelHotTrackFontOptions;\r\nend;\r\n\r\nprocedure TJvCustomNavigationPane.SetAutoHeaders(const Value: Boolean);\r\nbegin\r\n if FAutoHeaders <> Value then\r\n begin\r\n FAutoHeaders := Value;\r\n UpdatePages;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomNavigationPane.SetAlignment(const Value: TAlignment);\r\nbegin\r\n if FAlignment <> Value then\r\n begin\r\n FAlignment := Value;\r\n UpdatePages;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomNavigationPane.SetWordWrap(const Value: Boolean);\r\nbegin\r\n if FWordWrap <> Value then\r\n begin\r\n FWordWrap := Value;\r\n UpdatePages;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomNavigationPane.UpdatePages;\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := 0 to PageCount - 1 do\r\n begin\r\n NavPages[I].AutoHeader := AutoHeaders;\r\n NavPages[I].NavPanel.Height := ButtonHeight;\r\n NavPages[I].IconButton.Width := ButtonWidth;\r\n NavPages[I].NavPanel.Colors := Colors;\r\n NavPages[I].IconButton.Colors := Colors;\r\n NavPages[I].NavPanel.HotTrackFontOptions := NavPanelHotTrackFontOptions;\r\n NavPages[I].NavPanel.Font := FNavPanelFont;\r\n NavPages[I].NavPanel.HotTrackFont := FNavPanelHotTrackFont;\r\n\r\n NavPages[I].WordWrap := WordWrap;\r\n NavPages[I].Alignment := Alignment;\r\n NavPages[I].NavPanel.Images := LargeImages;\r\n if AutoHeaders then\r\n NavPages[I].Header.Images := LargeImages;\r\n NavPages[I].IconButton.Images := SmallImages;\r\n // NavPages[I].StyleManager := StyleManager;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomNavigationPane.DoDropDownMenu(Sender: TObject;\r\n MousePos: TPoint; var Handled: Boolean);\r\nbegin\r\n if Assigned(FOnDropDownMenu) then\r\n FOnDropDownMenu(Self, MousePos, Handled);\r\nend;\r\n\r\nprocedure TJvCustomNavigationPane.ParentStyleManagerChanged(\r\n var Msg: TMsgStyleManagerChange);\r\nbegin\r\n if (Msg.Sender <> Self) and ParentStyleManager then\r\n begin\r\n StyleManager := Msg.StyleManager;\r\n ParentStyleManager := True;\r\n InternalStyleManagerChanged(Self, Msg.StyleManager);\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomNavigationPane.SetParentStyleManager(const Value: Boolean);\r\nbegin\r\n if FParentStyleManager <> Value then\r\n begin\r\n FParentStyleManager := Value;\r\n if FParentStyleManager and (Parent <> nil) then\r\n Parent.Perform(CM_PARENTSTYLEMANAGERCHANGE, 0, 0);\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomNavigationPane.CMControlChange(var Msg: TMessage);\r\nbegin\r\n InternalStyleManagerChanged(Self, StyleManager);\r\nend;\r\n\r\nprocedure TJvCustomNavigationPane.WMNCPaint(var Msg: TWMNCPaint);\r\nvar\r\n AColor: TColor;\r\nbegin\r\n AColor := Color;\r\n try\r\n Color := Colors.FrameColor;\r\n inherited;\r\n finally\r\n Color := AColor;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomNavigationPane.WMEraseBkgnd(var Msg: TWMEraseBkgnd);\r\nbegin\r\n if ActivePage = nil then\r\n begin\r\n Canvas.Brush.Color := Color;\r\n Canvas.FillRect(ClientRect);\r\n FBackground.DrawImage(Canvas, ClientRect);\r\n end;\r\n Msg.Result := 1;\r\nend;\r\n\r\nprocedure TJvCustomNavigationPane.ParentStyleManagerChange(var Msg: TMessage);\r\nbegin\r\n InternalStyleManagerChanged(Self, StyleManager);\r\nend;\r\n\r\nfunction TJvCustomNavigationPane.IsColorsStored: Boolean;\r\nbegin\r\n Result := (StyleManager = nil) or (StyleManager.Theme = nptCustom);\r\nend;\r\n\r\nfunction TJvCustomNavigationPane.GetSplitterClick: TNotifyEvent;\r\nbegin\r\n if FSplitter <> nil then\r\n Result := FSplitter.OnClick\r\n else\r\n Result := nil;\r\nend;\r\n\r\nfunction TJvCustomNavigationPane.GetSplitterDblClick: TNotifyEvent;\r\nbegin\r\n if FSplitter <> nil then\r\n Result := FSplitter.OnDblClick\r\n else\r\n Result := nil;\r\nend;\r\n\r\nfunction TJvCustomNavigationPane.GetSplitterMouseDown: TMouseEvent;\r\nbegin\r\n if FSplitter <> nil then\r\n Result := FSplitter.OnMouseDown\r\n else\r\n Result := nil;\r\nend;\r\n\r\nfunction TJvCustomNavigationPane.GetSplitterMouseEnter: TNotifyEvent;\r\nbegin\r\n if FSplitter <> nil then\r\n Result := FSplitter.OnMouseEnter\r\n else\r\n Result := nil;\r\nend;\r\n\r\nfunction TJvCustomNavigationPane.GetSplitterMouseLeave: TNotifyEvent;\r\nbegin\r\n if FSplitter <> nil then\r\n Result := FSplitter.OnMouseLeave\r\n else\r\n Result := nil;\r\nend;\r\n\r\nfunction TJvCustomNavigationPane.GetSplitterMouseMove: TMouseMoveEvent;\r\nbegin\r\n if FSplitter <> nil then\r\n Result := FSplitter.OnMouseMove\r\n else\r\n Result := nil;\r\nend;\r\n\r\nfunction TJvCustomNavigationPane.GetSplitterMouseUp: TMouseEvent;\r\nbegin\r\n if FSplitter <> nil then\r\n Result := FSplitter.OnMouseUp\r\n else\r\n Result := nil;\r\nend;\r\n\r\nfunction TJvCustomNavigationPane.GetSplitterCanResize: TCanResizeEvent;\r\nbegin\r\n if FSplitter <> nil then\r\n Result := FSplitter.OnCanResize\r\n else\r\n Result := nil;\r\nend;\r\n\r\nfunction TJvCustomNavigationPane.GetSplitterMoved: TNotifyEvent;\r\nbegin\r\n if FSplitter <> nil then\r\n Result := FSplitter.OnMoved\r\n else\r\n Result := nil;\r\nend;\r\n\r\nfunction TJvCustomNavigationPane.GetSplitterPaint: TNotifyEvent;\r\nbegin\r\n if FSplitter <> nil then\r\n Result := FSplitter.OnPaint\r\n else\r\n Result := nil;\r\nend;\r\n\r\nprocedure TJvCustomNavigationPane.SetSplitterCanResize(const Value: TCanResizeEvent);\r\nbegin\r\n if FSplitter <> nil then\r\n FSplitter.OnCanResize := Value;\r\nend;\r\n\r\nprocedure TJvCustomNavigationPane.SetSplitterMoved(const Value: TNotifyEvent);\r\nbegin\r\n if FSplitter <> nil then\r\n FSplitter.OnMoved := Value;\r\nend;\r\n\r\nprocedure TJvCustomNavigationPane.SetSplitterPaint(const Value: TNotifyEvent);\r\nbegin\r\n if FSplitter <> nil then\r\n FSplitter.OnPaint := Value;\r\nend;\r\n\r\nprocedure TJvCustomNavigationPane.SetSplitterClick(const Value: TNotifyEvent);\r\nbegin\r\n if FSplitter <> nil then\r\n FSplitter.OnClick := Value;\r\nend;\r\n\r\nprocedure TJvCustomNavigationPane.SetSplitterDblClick(\r\n const Value: TNotifyEvent);\r\nbegin\r\n if FSplitter <> nil then\r\n FSplitter.OnDblClick := Value;\r\nend;\r\n\r\nprocedure TJvCustomNavigationPane.SetSplitterMouseDown(\r\n const Value: TMouseEvent);\r\nbegin\r\n if FSplitter <> nil then\r\n FSplitter.OnMouseDown := Value;\r\nend;\r\n\r\nprocedure TJvCustomNavigationPane.SetSplitterMouseEnter(\r\n const Value: TNotifyEvent);\r\nbegin\r\n if FSplitter <> nil then\r\n FSplitter.OnMouseEnter := Value;\r\nend;\r\n\r\nprocedure TJvCustomNavigationPane.SetSplitterMouseLeave(\r\n const Value: TNotifyEvent);\r\nbegin\r\n if FSplitter <> nil then\r\n FSplitter.OnMouseLeave := Value;\r\nend;\r\n\r\nprocedure TJvCustomNavigationPane.SetSplitterMouseMove(\r\n const Value: TMouseMoveEvent);\r\nbegin\r\n if FSplitter <> nil then\r\n FSplitter.OnMouseMove := Value;\r\nend;\r\n\r\nprocedure TJvCustomNavigationPane.SetSplitterMouseUp(\r\n const Value: TMouseEvent);\r\nbegin\r\n if FSplitter <> nil then\r\n FSplitter.OnMouseUp := Value;\r\nend;\r\n\r\n//=== { TJvNavIconButton } ===================================================\r\n\r\nconstructor TJvNavIconButton.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FStyleLink := TJvNavStyleLink.Create;\r\n FStyleLink.OnChange := DoStyleChange;\r\n FColors := TJvNavPanelColors.Create;\r\n FColors.OnChange := DoColorsChange;\r\n FChangeLink := TChangeLink.Create;\r\n FChangeLink.OnChange := DoImagesChange;\r\n Width := 22;\r\n Height := 22;\r\n Font := Screen.IconFont;\r\n Font.Style := [fsBold];\r\n FParentStyleManager := True;\r\nend;\r\n\r\ndestructor TJvNavIconButton.Destroy;\r\nbegin\r\n FStyleLink.Free;\r\n FChangeLink.Free;\r\n FColors.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvNavIconButton.DoColorsChange(Sender: TObject);\r\nbegin\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvNavIconButton.DoImagesChange(Sender: TObject);\r\nbegin\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvNavIconButton.Notification(AComponent: TComponent; Operation: TOperation);\r\nbegin\r\n inherited Notification(AComponent, Operation);\r\n if Operation = opRemove then\r\n if AComponent = Images then\r\n Images := nil\r\n else\r\n if AComponent = StyleManager then\r\n StyleManager := nil;\r\nend;\r\n\r\nprocedure TJvNavIconButton.Paint;\r\nvar\r\n Rect: TRect;\r\n P: TPoint;\r\n I: Integer;\r\nbegin\r\n with Canvas do\r\n begin\r\n Rect := ClientRect;\r\n Brush.Style := bsClear;\r\n InflateRect(Rect, 0, -1);\r\n if bsMouseInside in MouseStates then\r\n begin\r\n if bsMouseDown in MouseStates then\r\n GradientFillRect(Canvas, Rect, Colors.ButtonSelectedColorFrom, Colors.ButtonSelectedColorTo, fdTopToBottom, 32)\r\n else\r\n GradientFillRect(Canvas, Rect, Colors.ButtonHotColorFrom, Colors.ButtonHotColorTo, fdTopToBottom, 32)\r\n end\r\n else\r\n if Down then\r\n GradientFillRect(Canvas, Rect, Colors.ButtonSelectedColorFrom, Colors.ButtonSelectedColorTo, fdTopToBottom, 32);\r\n case ButtonType of\r\n nibDropDown:\r\n begin // area should be 7x12\r\n InflateRect(Rect, -((Rect.Right - Rect.Left) - 7) div 2, -((Rect.Bottom - Rect.Top) - 12) div 2);\r\n if bsMouseDown in MouseStates then\r\n OffsetRect(Rect, 1, 1);\r\n Canvas.Pen.Color := clBlack;\r\n P.X := Rect.Left;\r\n P.Y := Rect.Top;\r\n // chevron, upper\r\n for I := 0 to 2 do\r\n begin\r\n Canvas.MoveTo(P.X, P.Y);\r\n Canvas.LineTo(P.X + 2, P.Y);\r\n\r\n Canvas.MoveTo(P.X + 4, P.Y);\r\n Canvas.LineTo(P.X + 6, P.Y);\r\n Inc(P.X);\r\n Inc(P.Y);\r\n end;\r\n // chevron, lower\r\n Dec(P.X);\r\n Dec(P.Y);\r\n for I := 0 to 2 do\r\n begin\r\n Canvas.MoveTo(P.X, P.Y);\r\n Canvas.LineTo(P.X + 2, P.Y);\r\n\r\n Canvas.MoveTo(P.X + 4, P.Y);\r\n Canvas.LineTo(P.X + 6, P.Y);\r\n Dec(P.X);\r\n Inc(P.Y);\r\n end;\r\n\r\n // drop arrow\r\n Inc(P.X, 1);\r\n Inc(P.Y, 3);\r\n for I := 0 to 3 do\r\n begin\r\n Canvas.MoveTo(P.X + I, P.Y + I);\r\n Canvas.LineTo(P.X + 7 - I, P.Y + I);\r\n end;\r\n end;\r\n nibImage:\r\n begin\r\n if (Images <> nil) and (ImageIndex >= 0) and (ImageIndex < Images.Count) then\r\n // draw image only\r\n Images.Draw(Canvas,\r\n (Width - Images.Width) div 2 + Ord(bsMouseDown in MouseStates),\r\n (Height - Images.Height) div 2 + Ord(bsMouseDown in MouseStates),\r\n ImageIndex, Enabled);\r\n end;\r\n nibDropArrow:\r\n begin\r\n // area should be 9 x 5, centered\r\n P.X := Rect.Left + (RectWidth(Rect) - 9) div 2 + Ord(bsMouseDown in MouseStates);\r\n P.Y := Rect.Top + (RectHeight(Rect) - 5) div 2 + Ord(bsMouseDown in MouseStates);\r\n Canvas.Pen.Color := clBlack;\r\n for I := 0 to 4 do\r\n begin\r\n Canvas.MoveTo(P.X + I, P.Y + I);\r\n Canvas.LineTo(P.X + 9 - I, P.Y + I);\r\n end;\r\n end;\r\n nibClose:\r\n begin\r\n // area should be 8 x 8, centered\r\n P.X := (RectWidth(ClientRect) - 8) div 2 + Ord(bsMouseDown in MouseStates);\r\n P.Y := (RectHeight(ClientRect) - 8) div 2 + Ord(bsMouseDown in MouseStates);\r\n Canvas.Pen.Color := clBlack;\r\n for I := 0 to 7 do\r\n begin\r\n Canvas.MoveTo(P.X + I, P.Y + I);\r\n Canvas.LineTo(P.X + I + 2, P.Y + I);\r\n end;\r\n Inc(P.X, 7);\r\n for I := 0 to 7 do\r\n begin\r\n Canvas.MoveTo(P.X - I, P.Y + I);\r\n Canvas.LineTo(P.X - I + 2, P.Y + I);\r\n end;\r\n end;\r\n\r\n end;\r\n if csDesigning in ComponentState then\r\n begin\r\n Canvas.Pen.Color := clBlack;\r\n Canvas.Pen.Style := psDot;\r\n Canvas.Brush.Style := bsClear;\r\n Canvas.Rectangle(ClientRect);\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvNavIconButton.SetColors(const Value: TJvNavPanelColors);\r\nbegin\r\n FColors.Assign(Value);\r\nend;\r\n\r\nprocedure TJvNavIconButton.SetImageIndex(const Value: TImageIndex);\r\nbegin\r\n if FImageIndex <> Value then\r\n begin\r\n FImageIndex := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvNavIconButton.SetImages(const Value: TCustomImageList);\r\nbegin\r\n if ReplaceImageListReference(Self, Value, FImages, FChangeLink) then\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvNavIconButton.SetButtonType(const Value: TJvNavIconButtonType);\r\nbegin\r\n if FButtonType <> Value then\r\n begin\r\n FButtonType := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvNavIconButton.SetStyleManager(const Value: TJvNavPaneStyleManager);\r\nbegin\r\n if FStyleManager <> Value then\r\n begin\r\n ParentStyleManager := False;\r\n if FStyleManager <> nil then\r\n FStyleManager.UnregisterChanges(FStyleLink);\r\n ReplaceComponentReference(Self, Value, TComponent(FStyleManager));\r\n if FStyleManager <> nil then\r\n begin\r\n FStyleManager.RegisterChanges(FStyleLink);\r\n Colors := FStyleManager.Colors;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvNavIconButton.DoStyleChange(Sender: TObject);\r\nbegin\r\n Colors := (Sender as TJvNavPaneStyleManager).Colors;\r\n Font := (Sender as TJvNavPaneStyleManager).Fonts.DividerFont;\r\nend;\r\n\r\nprocedure TJvNavIconButton.ParentStyleManagerChanged(var Msg: TMsgStyleManagerChange);\r\nbegin\r\n if (Msg.Sender <> Self) and ParentStyleManager then\r\n begin\r\n StyleManager := Msg.StyleManager;\r\n ParentStyleManager := True;\r\n end;\r\nend;\r\n\r\nprocedure TJvNavIconButton.SetParentStyleManager(const Value: Boolean);\r\nbegin\r\n if FParentStyleManager <> Value then\r\n begin\r\n FParentStyleManager := Value;\r\n if FParentStyleManager and (Parent <> nil) then\r\n Parent.Perform(CM_PARENTSTYLEMANAGERCHANGE, 0, 0);\r\n end;\r\nend;\r\n\r\nfunction TJvNavIconButton.IsColorsStored: Boolean;\r\nbegin\r\n Result := (StyleManager = nil) or (StyleManager.Theme = nptCustom);\r\nend;\r\n\r\n//=== { TJvNavPanelButton } ==================================================\r\n\r\nconstructor TJvNavPanelButton.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FAlignment := taLeftJustify;\r\n\r\n FStyleLink := TJvNavStyleLink.Create;\r\n FStyleLink.OnChange := DoStyleChange;\r\n ControlStyle := ControlStyle + [csOpaque, csDisplayDragImage];\r\n Flat := True;\r\n HotTrack := True;\r\n Height := 28;\r\n FColors := TJvNavPanelColors.Create;\r\n FColors.OnChange := DoColorsChange;\r\n Font := Screen.IconFont;\r\n Font.Style := [fsBold];\r\n HotTrackFont := Font;\r\n HotTrackFont.Style := [fsBold];\r\n Width := 125;\r\n Height := 28;\r\n FParentStyleManager := True;\r\nend;\r\n\r\ndestructor TJvNavPanelButton.Destroy;\r\nbegin\r\n FStyleLink.Free;\r\n FColors.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvNavPanelButton.ActionChange(Sender: TObject;\r\n CheckDefaults: Boolean);\r\nbegin\r\n if Sender is TCustomAction then\r\n with TCustomAction(Sender) do\r\n begin\r\n if not CheckDefaults or (Self.Caption = '') or (Self.Caption = Self.Name) then\r\n Self.Caption := Caption;\r\n if not CheckDefaults or Self.Enabled then\r\n Self.Enabled := Enabled;\r\n if not CheckDefaults or (Self.Hint = '') then\r\n Self.Hint := Hint;\r\n if not CheckDefaults or (Self.ImageIndex = -1) then\r\n Self.ImageIndex := ImageIndex;\r\n if not CheckDefaults or Self.Visible then\r\n Self.Visible := Visible;\r\n if not CheckDefaults or not Assigned(Self.OnClick) then\r\n Self.OnClick := OnExecute;\r\n end;\r\nend;\r\n\r\nprocedure TJvNavPanelButton.DoColorsChange(Sender: TObject);\r\nbegin\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvNavPanelButton.DoStyleChange(Sender: TObject);\r\nbegin\r\n Colors := (Sender as TJvNavPaneStyleManager).Colors;\r\n Font := (Sender as TJvNavPaneStyleManager).Fonts.NavPanelFont;\r\n HotTrackFont := (Sender as TJvNavPaneStyleManager).Fonts.NavPanelHotTrackFont;\r\n HotTrackFontOptions := (Sender as TJvNavPaneStyleManager).Fonts.NavPanelHotTrackFontOptions;\r\nend;\r\n\r\nprocedure TJvNavPanelButton.FontChanged;\r\nbegin\r\n inherited FontChanged;\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvNavPanelButton.Notification(AComponent: TComponent;\r\n Operation: TOperation);\r\nbegin\r\n inherited Notification(AComponent, Operation);\r\n if Operation = opRemove then\r\n begin\r\n if AComponent = StyleManager then\r\n StyleManager := nil;\r\n end;\r\nend;\r\n\r\nprocedure TJvNavPanelButton.PaintButton(Canvas:TCanvas);\r\nvar\r\n R, TempRect: TRect;\r\n X, Y: Integer;\r\n\r\n function IsValidImage: Boolean;\r\n begin\r\n Result := Assigned(Images) and (ImageIndex >= 0);\r\n end;\r\n\r\nbegin\r\n R := ClientRect;\r\n if HotTrack and (bsMouseInside in MouseStates) then\r\n begin\r\n if bsMouseDown in MouseStates then\r\n GradientFillRect(Canvas, R, Colors.ButtonSelectedColorTo, Colors.ButtonSelectedColorFrom, fdTopToBottom, 32)\r\n else\r\n GradientFillRect(Canvas, R, Colors.ButtonHotColorFrom, Colors.ButtonHotColorTo, fdTopToBottom, 32);\r\n end\r\n else\r\n if Down then\r\n GradientFillRect(Canvas, R, Colors.ButtonSelectedColorFrom, Colors.ButtonSelectedColorTo, fdTopToBottom, 32)\r\n else\r\n if bsMouseDown in MouseStates then\r\n GradientFillRect(Canvas, R, Colors.ButtonSelectedColorTo, Colors.ButtonSelectedColorFrom, fdTopToBottom, 32)\r\n else\r\n GradientFillRect(Canvas, ClientRect, Colors.ButtonColorFrom, Colors.ButtonColorTo, fdTopToBottom, 32);\r\n InflateRect(R, -4, -4);\r\n if IsValidImage then\r\n begin\r\n Y := (Height - Images.Height) div 2;\r\n X := 4;\r\n Images.Draw(Canvas, X, Y, ImageIndex);\r\n Inc(R.Left, Images.Width + 4);\r\n end;\r\n if Caption <> '' then\r\n begin\r\n if HotTrack and (bsMouseInside in MouseStates) and not (bsMouseDown in MouseStates) then\r\n Canvas.Font := HotTrackFont\r\n else\r\n Canvas.Font := Font;\r\n SetBkMode(Canvas.Handle, TRANSPARENT);\r\n\r\n TempRect := R;\r\n DrawText(Canvas, Caption, Length(Caption), TempRect,\r\n DT_CALCRECT or cAlignment[Alignment] or cWordWrap[WordWrap] or DT_VCENTER);\r\n if WordWrap then\r\n OffsetRect(R, 0, ((R.Bottom - R.Top) - (TempRect.Bottom - TempRect.Top)) div 2);\r\n DrawText(Canvas, Caption, Length(Caption), R,\r\n cAlignment[Alignment] or cWordWrap[WordWrap] or DT_VCENTER);\r\n end;\r\n if Colors.ButtonSeparatorColor <> clNone then\r\n begin\r\n Canvas.Pen.Color := Colors.ButtonSeparatorColor;\r\n if Align = alBottom then\r\n begin\r\n Canvas.MoveTo(0, 0);\r\n Canvas.LineTo(Width + 1, 0);\r\n end\r\n else\r\n begin\r\n Canvas.MoveTo(0, ClientHeight - 1);\r\n Canvas.LineTo(Width + 1, ClientHeight - 1);\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvNavPanelButton.SetColors(const Value: TJvNavPanelColors);\r\nbegin\r\n FColors.Assign(Value);\r\nend;\r\n\r\nprocedure TJvNavPanelButton.SetStyleManager(const Value: TJvNavPaneStyleManager);\r\nbegin\r\n if FStyleManager <> Value then\r\n begin\r\n ParentStyleManager := False;\r\n if FStyleManager <> nil then\r\n FStyleManager.UnregisterChanges(FStyleLink);\r\n FStyleManager := Value;\r\n ReplaceComponentReference(Self, Value, TComponent(FStyleManager));\r\n if FStyleManager <> nil then\r\n begin\r\n FStyleManager.RegisterChanges(FStyleLink);\r\n Colors := FStyleManager.Colors;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvNavPanelButton.SetImageIndex(const Value: TImageIndex);\r\nbegin\r\n if FImageIndex <> Value then\r\n begin\r\n FImageIndex := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvNavPanelButton.SetImages(const Value: TCustomImageList);\r\nbegin\r\n if FImages <> Value then\r\n begin\r\n FImages := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvNavPanelButton.TextChanged;\r\nbegin\r\n inherited TextChanged;\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvNavPanelButton.SetAlignment(const Value: TAlignment);\r\nbegin\r\n if FAlignment <> Value then\r\n begin\r\n FAlignment := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvNavPanelButton.SetWordWrap(const Value: Boolean);\r\nbegin\r\n if FWordWrap <> Value then\r\n begin\r\n FWordWrap := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\n\r\nprocedure TJvNavPanelButton.CMDialogChar(var Msg: TCMDialogChar);\r\nbegin\r\n if IsAccel(Msg.CharCode, Caption) then\r\n begin\r\n Msg.Result := 1;\r\n Click;\r\n end\r\n else\r\n inherited;\r\nend;\r\n\r\nprocedure TJvNavPanelButton.ParentStyleManagerChanged(var Msg: TMsgStyleManagerChange);\r\nbegin\r\n if (Msg.Sender <> Self) and ParentStyleManager then\r\n begin\r\n StyleManager := Msg.StyleManager;\r\n ParentStyleManager := True;\r\n end;\r\nend;\r\n\r\nprocedure TJvNavPanelButton.SetParentStyleManager(const Value: Boolean);\r\nbegin\r\n if FParentStyleManager <> Value then\r\n begin\r\n FParentStyleManager := Value;\r\n if FParentStyleManager and (Parent <> nil) then\r\n Parent.Perform(CM_PARENTSTYLEMANAGERCHANGE, 0, 0);\r\n end;\r\nend;\r\n\r\nfunction TJvNavPanelButton.IsColorsStored: Boolean;\r\nbegin\r\n Result := (StyleManager = nil) or (StyleManager.Theme = nptCustom);\r\nend;\r\n\r\n//=== { TJvNavPanelColors } ==================================================\r\n\r\nconstructor TJvNavPanelColors.Create;\r\nbegin\r\n inherited Create;\r\n // use XPBlue as standard\r\n FButtonColorFrom := TColor($F7E2CD);\r\n FButtonColorTo := TColor($F3A080);\r\n FButtonSelectedColorFrom := TColor($BBE2EA);\r\n FButtonSelectedColorTo := TColor($389FDD);\r\n FFrameColor := TColor($6F2F0C);\r\n FButtonHotColorFrom := TColor($DBFBFF);\r\n FButtonHotColorTo := TColor($5FC8FB);\r\n FDividerColorFrom := TColor($FFDBBC);\r\n FDividerColorTo := TColor($F2C0A4);\r\n FHeaderColorFrom := TColor($D0835C);\r\n FHeaderColorTo := TColor($903B09);\r\n FSplitterColorFrom := TColor($B78676);\r\n FSplitterColorTo := TColor($A03D09);\r\n FButtonSeparatorColor := clGray;\r\n FToolPanelColorFrom := clWindow;\r\n FToolPanelColorTo := clWindow;\r\n FToolPanelHeaderColorFrom := TColor($F7E2CD);\r\n FToolPanelHeaderColorTo := TColor($F3A080);\r\nend;\r\n\r\nprocedure TJvNavPanelColors.Assign(Source: TPersistent);\r\nbegin\r\n if (Source is TJvNavPanelColors) then\r\n begin\r\n if (Source <> Self) then\r\n begin\r\n FButtonColorFrom := TJvNavPanelColors(Source).ButtonColorFrom;\r\n FButtonColorTo := TJvNavPanelColors(Source).ButtonColorTo;\r\n FButtonHotColorFrom := TJvNavPanelColors(Source).ButtonHotColorFrom;\r\n FButtonHotColorTo := TJvNavPanelColors(Source).ButtonHotColorTo;\r\n FButtonSelectedColorFrom := TJvNavPanelColors(Source).ButtonSelectedColorFrom;\r\n FButtonSelectedColorTo := TJvNavPanelColors(Source).ButtonSelectedColorTo;\r\n FFrameColor := TJvNavPanelColors(Source).FrameColor;\r\n FHeaderColorFrom := TJvNavPanelColors(Source).HeaderColorFrom;\r\n FHeaderColorTo := TJvNavPanelColors(Source).HeaderColorTo;\r\n FDividerColorFrom := TJvNavPanelColors(Source).DividerColorFrom;\r\n FDividerColorTo := TJvNavPanelColors(Source).DividerColorTo;\r\n FSplitterColorFrom := TJvNavPanelColors(Source).SplitterColorFrom;\r\n FSplitterColorTo := TJvNavPanelColors(Source).SplitterColorTo;\r\n FButtonSeparatorColor := TJvNavPanelColors(Source).ButtonSeparatorColor;\r\n FToolPanelColorFrom := TJvNavPanelColors(Source).ToolPanelColorFrom;\r\n FToolPanelColorTo := TJvNavPanelColors(Source).ToolPanelColorTo;\r\n FToolPanelHeaderColorFrom := TJvNavPanelColors(Source).ToolPanelHeaderColorFrom;\r\n FToolPanelHeaderColorTo := TJvNavPanelColors(Source).ToolPanelHeaderColorTo;\r\n Change;\r\n end;\r\n end\r\n else\r\n inherited Assign(Source);\r\nend;\r\n\r\nprocedure TJvNavPanelColors.Change;\r\nbegin\r\n if Assigned(FOnChange) then\r\n FOnChange(Self);\r\nend;\r\n\r\nprocedure TJvNavPanelColors.SetButtonColorFrom(const Value: TColor);\r\nbegin\r\n if FButtonColorFrom <> Value then\r\n begin\r\n FButtonColorFrom := Value;\r\n Change;\r\n end;\r\nend;\r\n\r\nprocedure TJvNavPanelColors.SetButtonColorTo(const Value: TColor);\r\nbegin\r\n if FButtonColorTo <> Value then\r\n begin\r\n FButtonColorTo := Value;\r\n Change;\r\n end;\r\nend;\r\n\r\nprocedure TJvNavPanelColors.SetDividerColorFrom(const Value: TColor);\r\nbegin\r\n if FDividerColorFrom <> Value then\r\n begin\r\n FDividerColorFrom := Value;\r\n Change;\r\n end;\r\nend;\r\n\r\nprocedure TJvNavPanelColors.SetDividerColorTo(const Value: TColor);\r\nbegin\r\n if FDividerColorTo <> Value then\r\n begin\r\n FDividerColorTo := Value;\r\n Change;\r\n end;\r\nend;\r\n\r\nprocedure TJvNavPanelColors.SetFrameColor(const Value: TColor);\r\nbegin\r\n if FFrameColor <> Value then\r\n begin\r\n FFrameColor := Value;\r\n Change;\r\n end;\r\nend;\r\n\r\nprocedure TJvNavPanelColors.SetHeaderColorFrom(const Value: TColor);\r\nbegin\r\n if FHeaderColorFrom <> Value then\r\n begin\r\n FHeaderColorFrom := Value;\r\n Change;\r\n end;\r\nend;\r\n\r\nprocedure TJvNavPanelColors.SetHeaderColorTo(const Value: TColor);\r\nbegin\r\n if FHeaderColorTo <> Value then\r\n begin\r\n FHeaderColorTo := Value;\r\n Change;\r\n end;\r\nend;\r\n\r\nprocedure TJvNavPanelColors.SetButtonHotColorFrom(const Value: TColor);\r\nbegin\r\n if FButtonHotColorFrom <> Value then\r\n begin\r\n FButtonHotColorFrom := Value;\r\n Change;\r\n end;\r\nend;\r\n\r\nprocedure TJvNavPanelColors.SetButtonHotColorTo(const Value: TColor);\r\nbegin\r\n if FButtonHotColorTo <> Value then\r\n begin\r\n FButtonHotColorTo := Value;\r\n Change;\r\n end;\r\nend;\r\n\r\nprocedure TJvNavPanelColors.SetButtonSelectedColorFrom(const Value: TColor);\r\nbegin\r\n if FButtonSelectedColorFrom <> Value then\r\n begin\r\n FButtonSelectedColorFrom := Value;\r\n Change;\r\n end;\r\nend;\r\n\r\nprocedure TJvNavPanelColors.SetButtonSelectedColorTo(const Value: TColor);\r\nbegin\r\n if FButtonSelectedColorTo <> Value then\r\n begin\r\n FButtonSelectedColorTo := Value;\r\n Change;\r\n end;\r\nend;\r\n\r\nprocedure TJvNavPanelColors.SetSplitterColorFrom(const Value: TColor);\r\nbegin\r\n if FSplitterColorFrom <> Value then\r\n begin\r\n FSplitterColorFrom := Value;\r\n Change;\r\n end;\r\nend;\r\n\r\nprocedure TJvNavPanelColors.SetSplitterColorTo(const Value: TColor);\r\nbegin\r\n if FSplitterColorTo <> Value then\r\n begin\r\n FSplitterColorTo := Value;\r\n Change;\r\n end;\r\nend;\r\n\r\nprocedure TJvNavPanelColors.SetButtonSeparatorColor(const Value: TColor);\r\nbegin\r\n if FButtonSeparatorColor <> Value then\r\n begin\r\n FButtonSeparatorColor := Value;\r\n Change;\r\n end;\r\nend;\r\n\r\nprocedure TJvNavPanelColors.SetToolPanelColorFrom(const Value: TColor);\r\nbegin\r\n if FToolPanelColorFrom <> Value then\r\n begin\r\n FToolPanelColorFrom := Value;\r\n Change;\r\n end;\r\nend;\r\n\r\nprocedure TJvNavPanelColors.SetToolPanelColorTo(const Value: TColor);\r\nbegin\r\n if FToolPanelColorTo <> Value then\r\n begin\r\n FToolPanelColorTo := Value;\r\n Change;\r\n end;\r\nend;\r\n\r\nprocedure TJvNavPanelColors.SetToolPanelHeaderColorFrom(\r\n const Value: TColor);\r\nbegin\r\n if FToolPanelHeaderColorFrom <> Value then\r\n begin\r\n FToolPanelHeaderColorFrom := Value;\r\n Change;\r\n end;\r\nend;\r\n\r\nprocedure TJvNavPanelColors.SetToolPanelHeaderColorTo(const Value: TColor);\r\nbegin\r\n if FToolPanelHeaderColorTo <> Value then\r\n begin\r\n FToolPanelHeaderColorTo := Value;\r\n Change;\r\n end;\r\nend;\r\n\r\n//=== { TJvNavPanelFonts } ===================================================\r\n\r\nconstructor TJvNavPanelFonts.Create;\r\nbegin\r\n inherited Create;\r\n FDividerFont := TFont.Create;\r\n FNavPanelFont := TFont.Create;\r\n FNavPanelHotTrackFont := TFont.Create;\r\n FHeaderFont := TFont.Create;\r\n FHeaderFont.Name := 'Arial';\r\n FHeaderFont.Size := 12;\r\n FHeaderFont.Style := [fsBold];\r\n FHeaderFont.Color := clWhite;\r\n FHeaderFont.OnChange := DoFontChange;\r\n\r\n FDividerFont.Assign(Screen.IconFont);\r\n FNavPanelFont.Assign(Screen.IconFont);\r\n FNavPanelFont.Style := [fsBold];\r\n FNavPanelHotTrackFont.Assign(FNavPanelFont);\r\n FNavPanelHotTrackFontOptions := DefaultTrackFontOptions;\r\n\r\n FDividerFont.OnChange := DoFontChange;\r\n FNavPanelFont.OnChange := DoFontChange;\r\n FNavPanelHotTrackFont.OnChange := DoFontChange;\r\nend;\r\n\r\ndestructor TJvNavPanelFonts.Destroy;\r\nbegin\r\n FDividerFont.Free;\r\n FHeaderFont.Free;\r\n FNavPanelFont.Free;\r\n FNavPanelHotTrackFont.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvNavPanelFonts.Assign(Source: TPersistent);\r\nbegin\r\n if Source is TJvNavPanelFonts then\r\n begin\r\n if Source <> Self then\r\n begin\r\n NavPanelFont := TJvNavPanelFonts(Source).NavPanelFont;\r\n DividerFont := TJvNavPanelFonts(Source).DividerFont;\r\n HeaderFont := TJvNavPanelFonts(Source).HeaderFont;\r\n end;\r\n end\r\n else\r\n inherited Assign(Source);\r\nend;\r\n\r\nprocedure TJvNavPanelFonts.Change;\r\nbegin\r\n if Assigned(FOnChange) then\r\n FOnChange(Self);\r\nend;\r\n\r\nprocedure TJvNavPanelFonts.DoFontChange(Sender: TObject);\r\nbegin\r\n Change;\r\nend;\r\n\r\nprocedure TJvNavPanelFonts.SetDividerFont(const Value: TFont);\r\nbegin\r\n FDividerFont.Assign(Value);\r\nend;\r\n\r\nprocedure TJvNavPanelFonts.SetHeaderFont(const Value: TFont);\r\nbegin\r\n FHeaderFont.Assign(Value);\r\nend;\r\n\r\nprocedure TJvNavPanelFonts.SetNavPanelFont(const Value: TFont);\r\nbegin\r\n FNavPanelFont.Assign(Value);\r\nend;\r\n\r\nprocedure TJvNavPanelFonts.SetNavPanelHotTrackFont(const Value: TFont);\r\nbegin\r\n FNavPanelHotTrackFont.Assign(Value);\r\nend;\r\n\r\nprocedure TJvNavPanelFonts.SetNavPanelHotTrackFontOptions(const Value: TJvTrackFontOptions);\r\nbegin\r\n if FNavPanelHotTrackFontOptions <> Value then\r\n begin\r\n FNavPanelHotTrackFontOptions := Value;\r\n Change;\r\n end;\r\nend;\r\n\r\n//=== { TJvNavPanelPage } ====================================================\r\n\r\nconstructor TJvNavPanelPage.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FBackground := TJvNavPaneBackgroundImage.Create;\r\n FBackground.OnChange := DoBackgroundChange;\r\n ParentColor := False;\r\n Color := clWindow;\r\n ControlStyle := ControlStyle + [csDisplayDragImage];\r\n FStyleLink := TJvNavStyleLink.Create;\r\n FStyleLink.OnChange := DoStyleChange;\r\n\r\n FNavPanel := TJvNavPanelButton.Create(Self);\r\n FNavPanel.Visible := True;\r\n FNavPanel.Align := alBottom;\r\n FNavPanel.GroupIndex := cNavPanelButtonGroupIndex; // use a silly number that no one else is probable to use\r\n FNavPanel.AllowAllUp := False;\r\n\r\n FIconButton := TJvNavIconButton.Create(Self);\r\n FIconButton.ButtonType := nibImage;\r\n FIconButton.Visible := False;\r\n FIconButton.Align := alRight;\r\n FIconButton.Width := 0;\r\n FIconButton.GroupIndex := cNavPanelButtonGroupIndex;\r\n FIconButton.AllowAllUp := False;\r\n\r\n FNavPanel.OnClick := DoButtonClick;\r\n FIconButton.OnClick := DoButtonClick;\r\n\r\n ImageIndex := -1;\r\n FParentStyleManager := True;\r\nend;\r\n\r\ndestructor TJvNavPanelPage.Destroy;\r\nbegin\r\n FStyleLink.Free;\r\n FBackground.Free;\r\n inherited Destroy;\r\nend;\r\n\r\ntype\r\n TJvCustomGraphicButtonAccess = class(TJvCustomGraphicButton)\r\n public\r\n property Down;\r\n end;\r\n\r\nprocedure TJvNavPanelPage.DoButtonClick(Sender: TObject);\r\nbegin\r\n { We cannot test for NavPanel.Down if the Sender is a icon button }\r\n if (Sender is TJvCustomGraphicButton) and TJvCustomGraphicButtonAccess(Sender).Down then\r\n begin\r\n if Parent <> nil then\r\n TJvCustomNavigationPane(Parent).ActivePage := Self; // this sets \"Down\" as well\r\n if Assigned(FOnClick) then\r\n FOnClick(Self);\r\n end;\r\nend;\r\n\r\nprocedure TJvNavPanelPage.DoStyleChange(Sender: TObject);\r\nbegin\r\n Colors := (Sender as TJvNavPaneStyleManager).Colors;\r\n NavPanel.Font := (Sender as TJvNavPaneStyleManager).Fonts.NavPanelFont;\r\n NavPanel.HotTrackFont := (Sender as TJvNavPaneStyleManager).Fonts.NavPanelHotTrackFont;\r\n NavPanel.HotTrackFontOptions := (Sender as TJvNavPaneStyleManager).Fonts.NavPanelHotTrackFontOptions;\r\nend;\r\n\r\nfunction TJvNavPanelPage.GetCaption: TCaption;\r\nbegin\r\n if NavPanel = nil then\r\n Result := ''\r\n else\r\n Result := NavPanel.Caption;\r\nend;\r\n\r\nfunction TJvNavPanelPage.GetColors: TJvNavPanelColors;\r\nbegin\r\n Result := NavPanel.Colors;\r\nend;\r\n\r\nfunction TJvNavPanelPage.GetHint: string;\r\nbegin\r\n if NavPanel = nil then\r\n Result := ''\r\n else\r\n Result := NavPanel.Hint;\r\nend;\r\n\r\nfunction TJvNavPanelPage.GetIconic: Boolean;\r\nbegin\r\n if NavPanel = nil then\r\n Result := False\r\n else\r\n Result := not NavPanel.Visible;\r\nend;\r\n\r\nfunction TJvNavPanelPage.GetImageIndex: TImageIndex;\r\nbegin\r\n if NavPanel = nil then\r\n Result := FImageIndex\r\n else\r\n Result := NavPanel.ImageIndex;\r\nend;\r\n\r\nprocedure TJvNavPanelPage.Notification(AComponent: TComponent;\r\n Operation: TOperation);\r\nbegin\r\n inherited Notification(AComponent, Operation);\r\n if Operation = opRemove then\r\n begin\r\n if AComponent = IconPanel then\r\n IconPanel := nil\r\n else\r\n if AComponent = StyleManager then\r\n StyleManager := nil;\r\n end;\r\nend;\r\n\r\nprocedure TJvNavPanelPage.SetCaption(const Value: TCaption);\r\nbegin\r\n if NavPanel <> nil then\r\n NavPanel.Caption := Value;\r\n if AutoHeader then\r\n Header.Caption := StripHotkey(Value);\r\nend;\r\n\r\nprocedure TJvNavPanelPage.SetColors(const Value: TJvNavPanelColors);\r\nbegin\r\n NavPanel.Colors := Value;\r\n IconButton.Colors := Value;\r\n if AutoHeader then\r\n begin\r\n Header.ColorFrom := Value.HeaderColorFrom;\r\n Header.ColorTo := Value.HeaderColorTo;\r\n end;\r\nend;\r\n\r\nprocedure TJvNavPanelPage.SetStyleManager(const Value: TJvNavPaneStyleManager);\r\nbegin\r\n if FStyleManager <> Value then\r\n begin\r\n ParentStyleManager := False;\r\n if FStyleManager <> nil then\r\n FStyleManager.UnregisterChanges(FStyleLink);\r\n FStyleManager := Value;\r\n ReplaceComponentReference(Self, Value, TComponent(FStyleManager));\r\n if FStyleManager <> nil then\r\n begin\r\n FStyleManager.RegisterChanges(FStyleLink);\r\n Colors := FStyleManager.Colors;\r\n end;\r\n end;\r\n // FNavPanel.StyleManager := Value;\r\n // FIconButton.StyleManager := Value;\r\n // if AutoHeader then\r\n // Header.StyleManager := Value;\r\nend;\r\n\r\nprocedure TJvNavPanelPage.SetHint(const Value: string);\r\nbegin\r\n NavPanel.Hint := Value;\r\n IconButton.Hint := Value;\r\nend;\r\n\r\nprocedure TJvNavPanelPage.SetIconic(const Value: Boolean);\r\nbegin\r\n NavPanel.Visible := not Value;\r\n IconButton.Visible := Value;\r\n NavPanel.Height := TJvCustomNavigationPane(Parent).ButtonHeight * Ord(NavPanel.Visible);\r\n IconButton.Width := TJvCustomNavigationPane(Parent).ButtonWidth * Ord(IconButton.Visible);\r\n UpdatePageList;\r\nend;\r\n\r\nprocedure TJvNavPanelPage.SetIconPanel(const Value: TJvIconPanel);\r\nbegin\r\n if (FIconPanel <> Value) and not (csDestroying in ComponentState) then\r\n begin\r\n ReplaceComponentReference(Self, Value, TComponent(FIconPanel));\r\n if IconButton <> nil then\r\n if FIconPanel <> nil then\r\n IconButton.Parent := FIconPanel\r\n else\r\n IconButton.Parent := nil;\r\n end;\r\nend;\r\n\r\nprocedure TJvNavPanelPage.SetImageIndex(const Value: TImageIndex);\r\nbegin\r\n FImageIndex := Value;\r\n NavPanel.ImageIndex := Value;\r\n IconButton.ImageIndex := Value;\r\n if AutoHeader then\r\n Header.ImageIndex := Value;\r\nend;\r\n\r\nprocedure TJvNavPanelPage.SetPageIndex(Value: Integer);\r\nbegin\r\n inherited SetPageIndex(Value);\r\n UpdatePageList;\r\nend;\r\n\r\nprocedure TJvNavPanelPage.SetParent( AParent: TWinControl);\r\nbegin\r\n inherited SetParent(AParent);\r\n if (FNavPanel = nil) or (FIconButton = nil) or (csDestroying in ComponentState) then\r\n Exit;\r\n NavPanel.Parent := AParent;\r\n if AParent is TJvCustomNavigationPane then\r\n begin\r\n IconPanel := TJvCustomNavigationPane(AParent).FIconPanel;\r\n // StyleManager := TJvCustomNavigationPane(AParent).StyleManager;\r\n\r\n NavPanel.Colors := TJvCustomNavigationPane(AParent).Colors;\r\n NavPanel.StyleManager := StyleManager;\r\n NavPanel.Height := TJvCustomNavigationPane(AParent).ButtonHeight;\r\n NavPanel.Images := TJvCustomNavigationPane(AParent).LargeImages;\r\n NavPanel.Font := TJvCustomNavigationPane(AParent).NavPanelFont;\r\n NavPanel.HotTrackFont := TJvCustomNavigationPane(AParent).NavPanelHotTrackFont;\r\n NavPanel.HotTrackFontOptions := TJvCustomNavigationPane(AParent).NavPanelHotTrackFontOptions;\r\n\r\n IconButton.Images := TJvCustomNavigationPane(AParent).SmallImages;\r\n IconButton.Width := TJvCustomNavigationPane(AParent).ButtonWidth;\r\n AutoHeader := TJvCustomNavigationPane(AParent).AutoHeaders;\r\n end\r\n else\r\n IconButton.Parent := nil;\r\nend;\r\n\r\nprocedure TJvNavPanelPage.UpdatePageList;\r\nbegin\r\n if PageList <> nil then\r\n TJvCustomNavigationPane(PageList).UpdatePositions;\r\nend;\r\n\r\nprocedure TJvNavPanelPage.SetAutoHeader(const Value: Boolean);\r\nbegin\r\n if AutoHeader <> Value then\r\n begin\r\n FreeAndNil(FHeader);\r\n if Value then\r\n begin\r\n FHeader := TJvNavPanelHeader.Create(nil);\r\n FHeader.ColorFrom := Colors.HeaderColorFrom;\r\n FHeader.ColorTo := Colors.HeaderColorTo;\r\n FHeader.Images := NavPanel.Images;\r\n FHeader.ImageIndex := ImageIndex;\r\n FHeader.Caption := StripHotkey(Caption);\r\n // make sure header is top-most\r\n FHeader.Top := -10;\r\n FHeader.Parent := Self;\r\n FHeader.Align := alTop;\r\n FHeader.Alignment := Alignment;\r\n FHeader.WordWrap := WordWrap;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJvNavPanelPage.GetAutoHeader: Boolean;\r\nbegin\r\n Result := FHeader <> nil;\r\nend;\r\n\r\nfunction TJvNavPanelPage.GetAlignment: TAlignment;\r\nbegin\r\n if NavPanel <> nil then\r\n Result := NavPanel.Alignment\r\n else\r\n Result := taLeftJustify;\r\nend;\r\n\r\nfunction TJvNavPanelPage.GetWordWrap: Boolean;\r\nbegin\r\n if NavPanel <> nil then\r\n Result := NavPanel.WordWrap\r\n else\r\n Result := False;\r\nend;\r\n\r\nprocedure TJvNavPanelPage.SetAlignment(const Value: TAlignment);\r\nbegin\r\n if NavPanel <> nil then\r\n NavPanel.Alignment := Value;\r\n if AutoHeader then\r\n Header.Alignment := Value;\r\nend;\r\n\r\nprocedure TJvNavPanelPage.SetWordWrap(const Value: Boolean);\r\nbegin\r\n if NavPanel <> nil then\r\n NavPanel.WordWrap := Value;\r\n if AutoHeader then\r\n Header.WordWrap := Value;\r\nend;\r\n\r\nprocedure TJvNavPanelPage.ParentStyleManagerChanged(var Msg: TMsgStyleManagerChange);\r\nbegin\r\n if (Msg.Sender <> Self) and ParentStyleManager then\r\n begin\r\n StyleManager := Msg.StyleManager;\r\n ParentStyleManager := True;\r\n InternalStyleManagerChanged(Self, Msg.StyleManager);\r\n end;\r\nend;\r\n\r\nprocedure TJvNavPanelPage.SetParentStyleManager(const Value: Boolean);\r\nbegin\r\n if FParentStyleManager <> Value then\r\n begin\r\n FParentStyleManager := Value;\r\n if FParentStyleManager and (Parent <> nil) then\r\n Parent.Perform(CM_PARENTSTYLEMANAGERCHANGE, 0, 0);\r\n end;\r\nend;\r\n\r\nprocedure TJvNavPanelPage.CMControlChange(var Msg: TMessage);\r\nbegin\r\n InternalStyleManagerChanged(Self, StyleManager);\r\nend;\r\n\r\nprocedure TJvNavPanelPage.ParentStyleManagerChange(var Msg: TMessage);\r\nbegin\r\n InternalStyleManagerChanged(Self, StyleManager);\r\nend;\r\n\r\nprocedure TJvNavPanelPage.SetBackground(const Value: TJvNavPaneBackgroundImage);\r\nbegin\r\n FBackground.Assign(Value);\r\nend;\r\n\r\nprocedure TJvNavPanelPage.DoBackgroundChange(Sender: TObject);\r\nbegin\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvNavPanelPage.Paint;\r\nbegin\r\n inherited Paint;\r\n if FBackground.HasImage then\r\n FBackground.DrawImage(Canvas, ClientRect)\r\n else\r\n if (Parent is TJvCustomNavigationPane) and TJvCustomNavigationPane(Parent).Background.HasImage then\r\n TJvCustomNavigationPane(Parent).Background.DrawImage(Canvas, ClientRect);\r\nend;\r\n\r\nfunction TJvNavPanelPage.GetAction: TBasicAction;\r\nbegin\r\n Result := inherited GetAction;\r\nend;\r\n\r\nprocedure TJvNavPanelPage.SetAction(const Value: TBasicAction);\r\nbegin\r\n inherited Action := Value;\r\n FNavPanel.Action := Value;\r\n FIconButton.Action := Value;\r\nend;\r\n\r\nprocedure TJvNavPanelPage.ActionChange(Sender: TObject;\r\n CheckDefaults: Boolean);\r\nbegin\r\n if Sender is TCustomAction then\r\n with TCustomAction(Sender) do\r\n begin\r\n if not CheckDefaults or (Self.Caption = '') or (Self.Caption = Self.Name) then\r\n Self.Caption := Caption;\r\n if not CheckDefaults or Self.Enabled then\r\n Self.Enabled := Enabled; // NB! This disables resizing if the top-most button is disabled (due to TSplitter.FindControl)\r\n if not CheckDefaults or (Self.Hint = '') then\r\n Self.Hint := Hint;\r\n if not CheckDefaults or (Self.ImageIndex = -1) then\r\n Self.ImageIndex := ImageIndex;\r\n if not CheckDefaults or Self.Visible then\r\n Self.Visible := Visible;\r\n if not CheckDefaults or not Assigned(Self.OnClick) then\r\n Self.OnClick := OnExecute;\r\n end;\r\nend;\r\n\r\n//=== { TJvOutlookSplitter } =================================================\r\n\r\nconstructor TJvOutlookSplitter.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n ControlStyle := ControlStyle + [csOpaque];\r\n FStyleLink := TJvNavStyleLink.Create;\r\n FStyleLink.OnChange := DoStyleChange;\r\n FColorFrom := TColor($B78676);\r\n FColorTo := TColor($A03D09);\r\n Align := alBottom;\r\n AutoSnap := False;\r\n ResizeStyle := rsUpdate;\r\n Height := 7;\r\n Cursor := crSizeNS;\r\n FParentStyleManager := True;\r\nend;\r\n\r\ndestructor TJvOutlookSplitter.Destroy;\r\nbegin\r\n FStyleLink.Free;\r\n FStyleLink := nil;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvOutlookSplitter.EnabledChanged;\r\nbegin\r\n inherited EnabledChanged;\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvOutlookSplitter.DoStyleChange(Sender: TObject);\r\nbegin\r\n with (Sender as TJvNavPaneStyleManager).Colors do\r\n begin\r\n FColorFrom := SplitterColorFrom;\r\n FColorTo := SplitterColorTo;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvOutlookSplitter.Notification(AComponent: TComponent;\r\n Operation: TOperation);\r\nbegin\r\n inherited Notification(AComponent, Operation);\r\n if Operation = opRemove then\r\n if AComponent = StyleManager then\r\n StyleManager := nil;\r\nend;\r\n\r\nprocedure TJvOutlookSplitter.Paint;\r\nvar\r\n I: Integer;\r\n R: TRect;\r\nbegin\r\n R := ClientRect;\r\n if Align in [alTop, alBottom] then\r\n begin\r\n GradientFillRect(Canvas, R, ColorFrom, ColorTo, fdTopToBottom, R.Bottom - R.Top);\r\n Inc(R.Left, (R.Right - R.Left) div 2 - 20);\r\n Inc(R.Top, (R.Bottom - R.Top) div 2 - 1);\r\n R.Right := R.Left + 2;\r\n R.Bottom := R.Top + 2;\r\n if Enabled then\r\n for I := 0 to 9 do // draw the dots\r\n begin\r\n Canvas.Brush.Color := cl3DDkShadow;\r\n Canvas.FillRect(R);\r\n OffsetRect(R, 1, 1);\r\n Canvas.Brush.Color := clWhite;\r\n Canvas.FillRect(R);\r\n Canvas.Brush.Color := ColorFrom; // (p3) this is probably not the right color, but it's close enough for me...\r\n Canvas.FillRect(Rect(R.Left, R.Top, R.Left + 1, R.Top + 1));\r\n OffsetRect(R, 3, -1);\r\n end;\r\n end\r\n else\r\n begin\r\n GradientFillRect(Canvas, R, ColorFrom, ColorTo, fdLeftToRight, R.Right - R.Left);\r\n Inc(R.Top, (R.Bottom - R.Top) div 2 - 20);\r\n Inc(R.Left, (R.Right - R.Left) div 2 - 1);\r\n R.Right := R.Left + 2;\r\n R.Bottom := R.Top + 2;\r\n if Enabled then\r\n for I := 0 to 9 do // draw the dots\r\n begin\r\n Canvas.Brush.Color := cl3DDkShadow;\r\n Canvas.FillRect(R);\r\n OffsetRect(R, 1, 1);\r\n Canvas.Brush.Color := clWhite;\r\n Canvas.FillRect(R);\r\n Canvas.Brush.Color := ColorFrom;\r\n Canvas.FillRect(Rect(R.Left, R.Top, R.Left + 1, R.Top + 1));\r\n OffsetRect(R, -1, 3);\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvOutlookSplitter.SetColorFrom(const Value: TColor);\r\nbegin\r\n if FColorFrom <> Value then\r\n begin\r\n FColorFrom := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvOutlookSplitter.SetStyleManager(const Value: TJvNavPaneStyleManager);\r\nbegin\r\n if FStyleManager <> Value then\r\n begin\r\n ParentStyleManager := False;\r\n if FStyleManager <> nil then\r\n FStyleManager.UnregisterChanges(FStyleLink);\r\n ReplaceComponentReference(Self, Value, tComponent(FStyleManager));\r\n FStyleManager := Value;\r\n if FStyleManager <> nil then\r\n begin\r\n FStyleManager.RegisterChanges(FStyleLink);\r\n ColorFrom := FStyleManager.Colors.SplitterColorFrom;\r\n ColorTo := FStyleManager.Colors.SplitterColorTo;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvOutlookSplitter.SetColorTo(const Value: TColor);\r\nbegin\r\n if FColorTo <> Value then\r\n begin\r\n FColorTo := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvOutlookSplitter.ParentStyleManagerChanged(var Msg: TMsgStyleManagerChange);\r\nbegin\r\n if (Msg.Sender <> Self) and ParentStyleManager then\r\n begin\r\n StyleManager := Msg.StyleManager;\r\n ParentStyleManager := True;\r\n end;\r\nend;\r\n\r\nprocedure TJvOutlookSplitter.SetParentStyleManager(const Value: Boolean);\r\nbegin\r\n if FParentStyleManager <> Value then\r\n begin\r\n FParentStyleManager := Value;\r\n if FParentStyleManager and (Parent <> nil) then\r\n Parent.Perform(CM_PARENTSTYLEMANAGERCHANGE, 0, 0);\r\n end;\r\nend;\r\n\r\nfunction TJvOutlookSplitter.GetDragZoneRect: TRect;\r\nbegin\r\n Result := ClientRect;\r\n if DragZone <> 0 then\r\n begin\r\n if Align in [alLeft, alRight] then\r\n begin\r\n if DragZone < RectHeight(Result) then\r\n begin\r\n Result.Top := (RectHeight(Result) - DragZone) div 2;\r\n Result.Bottom := Result.Top + DragZone;\r\n end;\r\n end\r\n else\r\n if Align in [alTop, alBottom] then\r\n begin\r\n if DragZone < RectWidth(Result) then\r\n begin\r\n Result.Left := (RectWidth(Result) - DragZone) div 2;\r\n Result.Right := Result.Left + DragZone;\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJvOutlookSplitter.MouseInDragZone(X, Y: Integer): Boolean;\r\nbegin\r\n Result := (DragZone <= 0) or PtInRect(GetDragZoneRect, Point(X, Y));\r\nend;\r\n\r\nprocedure TJvOutlookSplitter.WMLButtonDown(var Msg: TWMLButtonDown);\r\nbegin\r\n if MouseInDragZone(Msg.XPos, Msg.YPos) then\r\n inherited;\r\nend;\r\n\r\nprocedure TJvOutlookSplitter.WMMouseMove(var Msg: TWMMouseMove);\r\nbegin\r\n inherited;\r\n if MouseInDragZone(Msg.XPos, Msg.YPos) then\r\n begin\r\n if Cursor <> FOldCursor then\r\n inherited Cursor := FOldCursor;\r\n end\r\n else\r\n begin\r\n if Cursor <> crDefault then\r\n begin\r\n FOldCursor := Cursor;\r\n inherited Cursor := crDefault;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvOutlookSplitter.SetCursor(const Value: TCursor);\r\nbegin\r\n inherited Cursor := Value;\r\n FOldCursor := Value;\r\nend;\r\n\r\nprocedure TJvOutlookSplitter.RequestAlign;\r\nbegin\r\n if (Cursor = crSizeWE) or (Cursor = crSizeNS) then\r\n begin\r\n if Align in [alLeft, alRight] then\r\n Cursor := crSizeWE\r\n else\r\n Cursor := crSizeNS;\r\n end;\r\nend;\r\n\r\n//=== { TJvNavPanelHeader } ==================================================\r\n\r\nconstructor TJvNavPanelHeader.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FChangeLink := TChangeLink.Create;\r\n FChangeLink.OnChange := DoImagesChange;\r\n FStyleLink := TJvNavStyleLink.Create;\r\n FStyleLink.OnChange := DoStyleChange;\r\n ControlStyle := ControlStyle + [csOpaque, csAcceptsControls];\r\n FColorFrom := TColor($D0835C);\r\n FColorTo := TColor($903B09);\r\n Font.Name := 'Arial';\r\n Font.Size := 12;\r\n Font.Style := [fsBold];\r\n Font.Color := clWhite;\r\n Height := 27;\r\n Width := 225;\r\n FParentStyleManager := True;\r\nend;\r\n\r\ndestructor TJvNavPanelHeader.Destroy;\r\nbegin\r\n FChangeLink.Free;\r\n FStyleLink.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvNavPanelHeader.DoImagesChange(Sender: TObject);\r\nbegin\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvNavPanelHeader.DoStyleChange(Sender: TObject);\r\nbegin\r\n Font := (Sender as TJvNavPaneStyleManager).Fonts.HeaderFont;\r\n with (Sender as TJvNavPaneStyleManager).Colors do\r\n begin\r\n FColorFrom := HeaderColorFrom;\r\n FColorTo := HeaderColorTo;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvNavPanelHeader.Notification(AComponent: TComponent;\r\n Operation: TOperation);\r\nbegin\r\n inherited Notification(AComponent, Operation);\r\n if Operation = opRemove then\r\n if AComponent = Images then\r\n Images := nil\r\n else\r\n if AComponent = StyleManager then\r\n StyleManager := nil;\r\nend;\r\n\r\nprocedure TJvNavPanelHeader.Paint;\r\nvar\r\n R, TempRect: TRect;\r\n X, Y, H: Integer;\r\n\r\n function IsValidImage: Boolean;\r\n begin\r\n Result := (Images <> nil) and (ImageIndex >= 0) and (ImageIndex < Images.Count);\r\n end;\r\n\r\nbegin\r\n R := ClientRect;\r\n GradientFillRect(Canvas, R, ColorFrom, ColorTo, fdTopToBottom, 32);\r\n\r\n H := Canvas.TextHeight(Caption);\r\n if Caption <> '' then\r\n begin\r\n Canvas.Font := Font;\r\n InflateRect(R, -4, 0);\r\n SetBkMode(Canvas.Handle, TRANSPARENT);\r\n TempRect := R;\r\n DrawText(Canvas, Caption, Length(Caption), TempRect,\r\n DT_CALCRECT or cAlignment[Alignment] or cWordWrap[WordWrap] or DT_VCENTER or DT_NOPREFIX or DT_END_ELLIPSIS);\r\n if WordWrap then\r\n OffsetRect(R, 0, (Height - (TempRect.Bottom - TempRect.Top)) div 2);\r\n if IsValidImage and (Alignment = taCenter) then\r\n OffsetRect(R, 0, -Images.Height div 2);\r\n DrawText(Canvas, Caption, Length(Caption), R,\r\n cAlignment[Alignment] or cWordWrap[WordWrap] or DT_VCENTER or DT_NOPREFIX or DT_END_ELLIPSIS);\r\n end;\r\n if IsValidImage then\r\n begin\r\n Y := (Height - Images.Height) div 2;\r\n case Alignment of\r\n taLeftJustify:\r\n X := R.Right - Images.Width;\r\n taRightJustify:\r\n X := R.Left + 4;\r\n else // taCenter\r\n begin\r\n if Caption <> '' then\r\n begin\r\n if WordWrap then\r\n Y := R.Top + H + 4\r\n else\r\n Y := (Height + Canvas.TextHeight('Wq')) div 2 + 4;\r\n end;\r\n X := (Width - Images.Width) div 2;\r\n end;\r\n end;\r\n if Y > Height - Images.Height - 4 then\r\n Y := Height - Images.Height - 4;\r\n Images.Draw(Canvas, X, Y, ImageIndex, True);\r\n end;\r\nend;\r\n\r\nprocedure TJvNavPanelHeader.SetColorFrom(const Value: TColor);\r\nbegin\r\n if FColorFrom <> Value then\r\n begin\r\n FColorFrom := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvNavPanelHeader.SetStyleManager(const Value: TJvNavPaneStyleManager);\r\nbegin\r\n if FStyleManager <> Value then\r\n begin\r\n ParentStyleManager := False;\r\n if FStyleManager <> nil then\r\n FStyleManager.UnregisterChanges(FStyleLink);\r\n ReplaceComponentReference(Self, Value, tComponent(FStyleManager));\r\n if FStyleManager <> nil then\r\n begin\r\n FStyleManager.RegisterChanges(FStyleLink);\r\n FColorFrom := FStyleManager.Colors.HeaderColorFrom;\r\n FColorTo := FStyleManager.Colors.HeaderColorTo;\r\n Font := FStyleManager.Fonts.HeaderFont;\r\n Invalidate;\r\n end;\r\n InternalStyleManagerChanged(Self, Value);\r\n end;\r\nend;\r\n\r\nprocedure TJvNavPanelHeader.SetColorTo(const Value: TColor);\r\nbegin\r\n if FColorTo <> Value then\r\n begin\r\n FColorTo := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvNavPanelHeader.SetImageIndex(const Value: TImageIndex);\r\nbegin\r\n if FImageIndex <> Value then\r\n begin\r\n FImageIndex := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvNavPanelHeader.SetImages(const Value: TCustomImageList);\r\nbegin\r\n if ReplaceImageListReference(Self, Value, FImages, FChangeLink) then\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvNavPanelHeader.TextChanged;\r\nbegin\r\n inherited TextChanged;\r\n Invalidate;\r\nend;\r\n\r\n\r\nprocedure TJvNavPanelHeader.WMEraseBkgnd(var Msg: TWMEraseBkgnd);\r\nbegin\r\n Msg.Result := 1;\r\nend;\r\n\r\nprocedure TJvNavPanelHeader.SetAlignment(const Value: TAlignment);\r\nbegin\r\n if FAlignment <> Value then\r\n begin\r\n FAlignment := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvNavPanelHeader.SetWordWrap(const Value: Boolean);\r\nbegin\r\n if FWordWrap <> Value then\r\n begin\r\n FWordWrap := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvNavPanelHeader.ParentStyleManagerChanged(var Msg: TMsgStyleManagerChange);\r\nbegin\r\n if (Msg.Sender <> Self) and ParentStyleManager then\r\n begin\r\n StyleManager := Msg.StyleManager;\r\n ParentStyleManager := True;\r\n InternalStyleManagerChanged(Self, Msg.StyleManager);\r\n end;\r\nend;\r\n\r\nprocedure TJvNavPanelHeader.ParentStyleManagerChange(var Msg: TMessage);\r\nbegin\r\n InternalStyleManagerChanged(Self, StyleManager);\r\nend;\r\n\r\nprocedure TJvNavPanelHeader.SetParentStyleManager(const Value: Boolean);\r\nbegin\r\n if FParentStyleManager <> Value then\r\n begin\r\n FParentStyleManager := Value;\r\n if FParentStyleManager and (Parent <> nil) then\r\n Parent.Perform(CM_PARENTSTYLEMANAGERCHANGE, 0, 0);\r\n end;\r\nend;\r\n\r\nprocedure TJvNavPanelHeader.CMControlChange(var Msg: TMessage);\r\nbegin\r\n // a control was inserted or removed\r\n InternalStyleManagerChanged(Self, StyleManager);\r\nend;\r\n\r\n//=== { TJvNavPanelDivider } =================================================\r\n\r\nconstructor TJvNavPanelDivider.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FAlignment := taLeftJustify;\r\n FStyleLink := TJvNavStyleLink.Create;\r\n FStyleLink.OnChange := DoStyleChange;\r\n Align := alNone;\r\n AutoSnap := False;\r\n ResizeStyle := rsUpdate;\r\n ControlStyle := ControlStyle + [csOpaque];\r\n FColorFrom := TColor($FFDBBC);\r\n FColorTo := TColor($F2C0A4);\r\n FFrameColor := TColor($6F2F0C);\r\n Cursor := crSizeNS;\r\n Font := Screen.IconFont;\r\n Height := 19;\r\n Width := 125;\r\n FParentStyleManager := True;\r\nend;\r\n\r\ndestructor TJvNavPanelDivider.Destroy;\r\nbegin\r\n FStyleLink.Free;\r\n FStyleLink := nil;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvNavPanelDivider.TextChanged;\r\nbegin\r\n inherited TextChanged;\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvNavPanelDivider.DoStyleChange(Sender: TObject);\r\nbegin\r\n Font := (Sender as TJvNavPaneStyleManager).Fonts.DividerFont;\r\n with (Sender as TJvNavPaneStyleManager).Colors do\r\n begin\r\n FColorFrom := DividerColorFrom;\r\n FColorTo := DividerColorTo;\r\n Self.FFrameColor := FrameColor;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvNavPanelDivider.Notification(AComponent: TComponent;\r\n Operation: TOperation);\r\nbegin\r\n inherited Notification(AComponent, Operation);\r\n if Operation = opRemove then\r\n begin\r\n if AComponent = StyleManager then\r\n StyleManager := nil;\r\n end;\r\nend;\r\n\r\nprocedure TJvNavPanelDivider.Paint;\r\nconst\r\n cAlignment: array[TAlignment] of Cardinal = (DT_LEFT, DT_RIGHT, DT_CENTER);\r\nvar\r\n R: TRect;\r\nbegin\r\n R := ClientRect;\r\n GradientFillRect(Canvas, R, ColorFrom, ColorTo, fdTopToBottom, 32);\r\n if Caption <> '' then\r\n begin\r\n Canvas.Font := Font;\r\n case Alignment of\r\n taLeftJustify:\r\n Inc(R.Left, 7);\r\n taRightJustify:\r\n Dec(R.Right, 7);\r\n end;\r\n SetBkMode(Canvas.Handle, TRANSPARENT);\r\n DrawText(Canvas, Caption, Length(Caption), R,\r\n DT_SINGLELINE or DT_VCENTER or DT_NOPREFIX or DT_EDITCONTROL or cAlignment[Alignment]);\r\n end;\r\n Canvas.Pen.Color := FrameColor;\r\n Canvas.MoveTo(0, ClientHeight - 1);\r\n Canvas.LineTo(Width, ClientHeight - 1);\r\nend;\r\n\r\nprocedure TJvNavPanelDivider.SetColorFrom(const Value: TColor);\r\nbegin\r\n if FColorFrom <> Value then\r\n begin\r\n FColorFrom := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvNavPanelDivider.SetStyleManager(const Value: TJvNavPaneStyleManager);\r\nbegin\r\n if FStyleManager <> Value then\r\n begin\r\n ParentStyleManager := False;\r\n if FStyleManager <> nil then\r\n FStyleManager.UnregisterChanges(FStyleLink);\r\n ReplaceComponentReference(Self, Value, tComponent(FStyleManager));\r\n if FStyleManager <> nil then\r\n begin\r\n FStyleManager.RegisterChanges(FStyleLink);\r\n ColorFrom := FStyleManager.Colors.DividerColorFrom;\r\n ColorTo := FStyleManager.Colors.DividerColorTo;\r\n Font := FStyleManager.Fonts.DividerFont;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvNavPanelDivider.SetColorTo(const Value: TColor);\r\nbegin\r\n if FColorTo <> Value then\r\n begin\r\n FColorTo := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvNavPanelDivider.SetFrameColor(const Value: TColor);\r\nbegin\r\n if FFrameColor <> Value then\r\n begin\r\n FFrameColor := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvNavPanelDivider.SetAlignment(const Value: TAlignment);\r\nbegin\r\n if FAlignment <> Value then\r\n begin\r\n FAlignment := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvNavPanelDivider.ParentStyleManagerChanged(var Msg: TMsgStyleManagerChange);\r\nbegin\r\n if (Msg.Sender <> Self) and ParentStyleManager then\r\n begin\r\n StyleManager := Msg.StyleManager;\r\n ParentStyleManager := True;\r\n end;\r\nend;\r\n\r\nprocedure TJvNavPanelDivider.SetParentStyleManager(const Value: Boolean);\r\nbegin\r\n if FParentStyleManager <> Value then\r\n begin\r\n FParentStyleManager := Value;\r\n if FParentStyleManager and (Parent <> nil) then\r\n Parent.Perform(CM_PARENTSTYLEMANAGERCHANGE, 0, 0);\r\n end;\r\nend;\r\n\r\nprocedure TJvNavPanelDivider.RequestAlign;\r\nbegin\r\n if (Cursor = crSizeWE) or (Cursor = crSizeNS) then\r\n begin\r\n if Align in [alLeft, alRight] then\r\n Cursor := crSizeWE\r\n else\r\n Cursor := crSizeNS;\r\n end;\r\nend;\r\n\r\n//=== { TJvNavPaneStyleManager } =============================================\r\n\r\nconstructor TJvNavPaneStyleManager.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FClients := TList.Create;\r\n FColors := TJvNavPanelColors.Create;\r\n FFonts := TJvNavPanelFonts.Create;\r\n FColors.OnChange := DoThemeChange;\r\n FFonts.OnChange := DoThemeChange;\r\n FTheme := nptCustom; // (p3) required to trigger the change method\r\n Theme := nptStandard;\r\nend;\r\n\r\ndestructor TJvNavPaneStyleManager.Destroy;\r\nbegin\r\n while FClients.Count > 0 do\r\n UnregisterChanges(TJvNavStyleLink(FClients.Last));\r\n FClients.Free;\r\n FClients := nil;\r\n FColors.Free;\r\n FFonts.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvNavPaneStyleManager.Assign(Source: TPersistent);\r\nvar\r\n SourceColors: TJvNavPanelColors;\r\n SourceFonts: TJvNavPanelFonts;\r\nbegin\r\n SourceFonts := nil;\r\n if Source is TJvNavPaneStyleManager then\r\n begin\r\n Theme := TJvNavPaneStyleManager(Source).Theme;\r\n if Theme = nptCustom then\r\n begin\r\n SourceColors := TJvNavPaneStyleManager(Source).Colors;\r\n SourceFonts := TJvNavPaneStyleManager(Source).Fonts;\r\n end\r\n else\r\n Exit;\r\n end\r\n else\r\n if Source is TJvIconPanel then\r\n SourceColors := TJvIconPanel(Source).Colors\r\n else\r\n if Source is TJvNavIconButton then\r\n SourceColors := TJvNavIconButton(Source).Colors\r\n else\r\n if Source is TJvNavPanelButton then\r\n SourceColors := TJvNavPanelButton(Source).Colors\r\n else\r\n if Source is TJvNavPanelPage then\r\n SourceColors := TJvNavPanelPage(Source).Colors\r\n else\r\n if Source is TJvCustomNavigationPane then\r\n SourceColors := TJvCustomNavigationPane(Source).Colors\r\n else\r\n begin\r\n inherited Assign(Source);\r\n Exit;\r\n end;\r\n FColors.Assign(SourceColors);\r\n if SourceFonts <> nil then\r\n FFonts.Assign(SourceFonts);\r\nend;\r\n\r\nprocedure TJvNavPaneStyleManager.AssignTo(Dest: TPersistent);\r\nvar\r\n DestColors: TJvNavPanelColors;\r\n DestFonts: TJvNavPanelFonts;\r\nbegin\r\n DestFonts := nil;\r\n if Dest is TJvNavPaneStyleManager then\r\n begin\r\n TJvNavPaneStyleManager(Dest).Theme := Theme;\r\n if Theme = nptCustom then\r\n begin\r\n DestColors := TJvNavPaneStyleManager(Dest).Colors;\r\n DestFonts := TJvNavPaneStyleManager(Dest).Fonts;\r\n end\r\n else\r\n Exit;\r\n end\r\n else\r\n if Dest is TJvIconPanel then\r\n DestColors := TJvIconPanel(Dest).Colors\r\n else\r\n if Dest is TJvNavIconButton then\r\n DestColors := TJvNavIconButton(Dest).Colors\r\n else\r\n if Dest is TJvNavPanelButton then\r\n DestColors := TJvNavPanelButton(Dest).Colors\r\n else\r\n if Dest is TJvNavPanelPage then\r\n DestColors := TJvNavPanelPage(Dest).Colors\r\n else\r\n if Dest is TJvCustomNavigationPane then\r\n DestColors := TJvCustomNavigationPane(Dest).Colors\r\n else\r\n begin\r\n inherited AssignTo(Dest);\r\n Exit;\r\n end;\r\n DestColors.Assign(Colors);\r\n if DestFonts <> nil then\r\n DestFonts.Assign(Fonts);\r\nend;\r\n\r\nprocedure TJvNavPaneStyleManager.Change;\r\nvar\r\n I: Integer;\r\nbegin\r\n if FClients <> nil then\r\n for I := 0 to FClients.Count - 1 do\r\n TJvNavStyleLink(FClients[I]).Change;\r\n if Assigned(FOnThemeChange) then\r\n FOnThemeChange(Self);\r\nend;\r\n\r\nprocedure TJvNavPaneStyleManager.DoThemeChange(Sender: TObject);\r\nbegin\r\n Theme := nptCustom;\r\n Change;\r\nend;\r\n\r\nprocedure TJvNavPaneStyleManager.RegisterChanges(Value: TJvNavStyleLink);\r\nbegin\r\n Value.Sender := Self;\r\n if FClients <> nil then\r\n FClients.Add(Value);\r\nend;\r\n\r\nprocedure TJvNavPaneStyleManager.SetColors(const Value: TJvNavPanelColors);\r\nbegin\r\n FColors.Assign(Value);\r\nend;\r\n\r\nprocedure TJvNavPaneStyleManager.SetFonts(const Value: TJvNavPanelFonts);\r\nbegin\r\n FFonts.Assign(Value);\r\nend;\r\n\r\nprocedure TJvNavPaneStyleManager.SetTheme(const Value: TJvNavPanelTheme);\r\nbegin\r\n if FTheme <> Value then\r\n begin\r\n FColors.OnChange := nil;\r\n FFonts.OnChange := nil;\r\n try\r\n case Value of\r\n nptStandard:\r\n begin\r\n FColors.ButtonColorFrom := TColor($FFFFFF);\r\n FColors.ButtonColorTo := TColor($BDBEBD);\r\n FColors.ButtonSelectedColorFrom := TColor($DECFCE);\r\n FColors.ButtonSelectedColorTo := TColor($DECFCE);\r\n FColors.FrameColor := TColor($848484);\r\n FColors.ButtonHotColorFrom := TColor($C68284);\r\n FColors.ButtonHotColorTo := TColor($C68284);\r\n FColors.DividerColorFrom := TColor($EFF3EF);\r\n FColors.DividerColorTo := TColor($C6C3C6);\r\n FColors.HeaderColorFrom := TColor($848284);\r\n FColors.HeaderColorTo := TColor($848284);\r\n FColors.SplitterColorFrom := TColor($C6C3C6);\r\n FColors.SplitterColorTo := TColor($8C8E8C);\r\n FColors.ButtonSeparatorColor := clGray;\r\n FColors.ToolPanelColorFrom := clWindow;\r\n FColors.ToolPanelColorTo := clWindow;\r\n FColors.ToolPanelHeaderColorFrom := TColor($FFFFFF);\r\n FColors.ToolPanelHeaderColorTo := TColor($BDBEBD);\r\n\r\n FFonts.HeaderFont.Color := clWindow;\r\n FFonts.NavPanelFont.Color := clWindowText;\r\n FFonts.NavPanelHotTrackFont.Color := clWindow;\r\n FFonts.DividerFont.Color := clWindowText;\r\n end;\r\n nptXPBlue:\r\n begin\r\n FColors.ButtonColorFrom := TColor($F7E2CD);\r\n FColors.ButtonColorTo := TColor($F3A080);\r\n FColors.ButtonSelectedColorFrom := TColor($BBE2EA);\r\n FColors.ButtonSelectedColorTo := TColor($389FDD);\r\n FColors.FrameColor := TColor($6F2F0C);\r\n FColors.ButtonHotColorFrom := TColor($DBFBFF);\r\n FColors.ButtonHotColorTo := TColor($5FC8FB);\r\n FColors.DividerColorFrom := TColor($FFDBBC);\r\n FColors.DividerColorTo := TColor($F2C0A4);\r\n FColors.HeaderColorFrom := TColor($D0835C);\r\n FColors.HeaderColorTo := TColor($903B09);\r\n FColors.SplitterColorFrom := TColor($B78676);\r\n FColors.SplitterColorTo := TColor($A03D09);\r\n FColors.ButtonSeparatorColor := TColor($2D9600);\r\n\r\n FColors.ToolPanelColorFrom := clWindow;\r\n FColors.ToolPanelColorTo := clWindow;\r\n FColors.ToolPanelHeaderColorFrom := TColor($F7E2CD);\r\n FColors.ToolPanelHeaderColorTo := TColor($F3A080);\r\n\r\n FFonts.HeaderFont.Color := clWindow;\r\n FFonts.NavPanelFont.Color := clWindowText;\r\n FFonts.NavPanelHotTrackFont.Color := clWindowText;\r\n FFonts.DividerFont.Color := clWindowText;\r\n end;\r\n nptXPSilver:\r\n begin\r\n FColors.ButtonColorFrom := TColor($F4E2E1);\r\n FColors.ButtonColorTo := TColor($B09494);\r\n FColors.ButtonSelectedColorFrom := TColor($BBE2EA);\r\n FColors.ButtonSelectedColorTo := TColor($389FDD);\r\n FColors.FrameColor := TColor($527D92);\r\n FColors.ButtonHotColorFrom := TColor($DBFBFF);\r\n FColors.ButtonHotColorTo := TColor($5FC8FB);\r\n FColors.DividerColorFrom := TColor($F8F3F4);\r\n FColors.DividerColorTo := TColor($EADADB);\r\n FColors.HeaderColorFrom := TColor($BAA8BA);\r\n FColors.HeaderColorTo := TColor($917275);\r\n FColors.SplitterColorFrom := TColor($B8ABA9);\r\n FColors.SplitterColorTo := TColor($81767E);\r\n FColors.ButtonSeparatorColor := TColor($947C7C);\r\n FColors.ToolPanelColorFrom := clWindow;\r\n FColors.ToolPanelColorTo := clWindow;\r\n FColors.ToolPanelHeaderColorFrom := TColor($F4E2E1);\r\n FColors.ToolPanelHeaderColorTo := TColor($B09494);\r\n\r\n FFonts.HeaderFont.Color := clWindow;\r\n FFonts.NavPanelFont.Color := clWindowText;\r\n FFonts.NavPanelHotTrackFont.Color := clWindowText;\r\n FFonts.DividerFont.Color := clWindowText;\r\n end;\r\n nptXPOlive:\r\n begin\r\n FColors.ButtonColorFrom := TColor($D6F3E3);\r\n FColors.ButtonColorTo := TColor($93BFB2);\r\n FColors.ButtonSelectedColorFrom := TColor($BBE2EA);\r\n FColors.ButtonSelectedColorTo := TColor($389FDD);\r\n FColors.FrameColor := TColor($5A7972);\r\n FColors.ButtonHotColorFrom := TColor($DBFBFF);\r\n FColors.ButtonHotColorTo := TColor($5FC8FB);\r\n FColors.DividerColorFrom := TColor($D2F4EE);\r\n FColors.DividerColorTo := TColor($B5DFD8);\r\n FColors.HeaderColorFrom := TColor($94BFB4);\r\n FColors.HeaderColorTo := TColor($427665);\r\n FColors.SplitterColorFrom := TColor($758D81);\r\n FColors.SplitterColorTo := TColor($3A584D);\r\n FColors.ButtonSeparatorColor := TColor($588060);\r\n FColors.ToolPanelColorFrom := clWindow;\r\n FColors.ToolPanelColorTo := clWindow;\r\n FColors.ToolPanelHeaderColorFrom := TColor($D6F3E3);\r\n FColors.ToolPanelHeaderColorTo := TColor($93BFB2);\r\n\r\n FFonts.HeaderFont.Color := clWindow;\r\n FFonts.NavPanelFont.Color := clWindowText;\r\n FFonts.NavPanelHotTrackFont.Color := clWindowText;\r\n FFonts.DividerFont.Color := clWindowText;\r\n end;\r\n nptCustom:\r\n begin\r\n // do nothing\r\n end;\r\n end;\r\n FTheme := Value;\r\n Change;\r\n finally\r\n FColors.OnChange := DoThemeChange;\r\n FFonts.OnChange := DoThemeChange;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvNavPaneStyleManager.UnregisterChanges(Value: TJvNavStyleLink);\r\nvar\r\n I: Integer;\r\nbegin\r\n if FClients <> nil then\r\n for I := 0 to FClients.Count - 1 do\r\n if FClients[I] = Value then\r\n begin\r\n Value.Sender := nil;\r\n FClients.Delete(I);\r\n Break;\r\n end;\r\nend;\r\n\r\nfunction TJvNavPaneStyleManager.IsColorsStored: Boolean;\r\nbegin\r\n Result := Theme = nptCustom;\r\nend;\r\n\r\nfunction TJvNavPaneStyleManager.IsFontsStored: Boolean;\r\nbegin\r\n Result := Theme = nptCustom;\r\nend;\r\n\r\n//=== { TJvNavStyleLink } ====================================================\r\n\r\ndestructor TJvNavStyleLink.Destroy;\r\nbegin\r\n if Sender is TJvNavPaneStyleManager then\r\n TJvNavPaneStyleManager(Sender).UnregisterChanges(Self);\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvNavStyleLink.Change;\r\nbegin\r\n if Assigned(FOnChange) then\r\n FOnChange(Sender);\r\nend;\r\n\r\n//=== { TJvCustomNavPaneToolPanel } ==========================================\r\n\r\nconstructor TJvCustomNavPaneToolPanel.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FHeaderVisible := True;\r\n ParentColor := False;\r\n FColors := TJvNavPanelColors.Create;\r\n FColors.OnChange := DoImagesChange;\r\n FBackground := TJvNavPaneBackgroundImage.Create;\r\n FBackground.OnChange := DoImagesChange;\r\n\r\n ControlStyle := [csAcceptsControls, csCaptureMouse, csClickEvents,\r\n csOpaque, csDoubleClicks, csReplicatable];\r\n\r\n FButtons := TJvNavPaneToolButtons.Create(Self);\r\n FStyleLink := TJvNavStyleLink.Create;\r\n FStyleLink.OnChange := DoStyleChange;\r\n FChangeLink := TChangeLink.Create;\r\n FChangeLink.OnChange := DoImagesChange;\r\n {\r\n FColorFrom := TColor($F7E2CD);\r\n FColorTo := TColor($F3A080);\r\n FButtonColor := TColor($A03D09);\r\n }\r\n FButtonWidth := 25;\r\n FButtonHeight := 22;\r\n FHeaderHeight := 29;\r\n FEdgeRounding := 9;\r\n FShowGrabber := True;\r\n Font := Screen.IconFont;\r\n Font.Style := [fsBold];\r\n\r\n FCloseButton := TJvNavPanelToolButton.Create(Self);\r\n FCloseButton.ButtonType := nibClose;\r\n FCloseButton.Parent := Self;\r\n FCloseButton.Visible := True;\r\n FCloseButton.OnClick := DoCloseClick;\r\n\r\n FDropDown := TJvNavPanelToolButton.Create(Self);\r\n FDropDown.Visible := False;\r\n FDropDown.ButtonType := nibDropArrow;\r\n FDropDown.OnDropDownMenu := DoDropDownMenu;\r\n FDropDown.Parent := Self;\r\n\r\n Width := 185;\r\n Height := 41;\r\n FParentStyleManager := True;\r\nend;\r\n\r\ndestructor TJvCustomNavPaneToolPanel.Destroy;\r\nbegin\r\n FStyleLink.Free;\r\n FChangeLink.Free;\r\n FButtons.Free;\r\n FBackground.Free;\r\n FColors.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvCustomNavPaneToolPanel.ButtonsChanged;\r\nvar\r\n I: Integer;\r\n B: TJvNavPanelToolButton;\r\nbegin\r\n if HeaderVisible then\r\n for I := 0 to Buttons.Count - 1 do\r\n begin\r\n B := Buttons[I].Button;\r\n B.Visible := False;\r\n B.SetBounds(0, 0, ButtonWidth - 3, ButtonHeight - 2);\r\n B.Images := Images;\r\n if B.Action = nil then\r\n B.OnClick := InternalButtonClick;\r\n B.Tag := I;\r\n B.Parent := Self;\r\n end;\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvCustomNavPaneToolPanel.DoCloseClick(Sender: TObject);\r\nbegin\r\n if Assigned(FOnClose) then\r\n FOnClose(Self);\r\nend;\r\n\r\nprocedure TJvCustomNavPaneToolPanel.DoDropDownMenu(Sender: TObject;\r\n MousePos: TPoint; var Handled: Boolean);\r\nbegin\r\n if Assigned(FOnDropDownMenu) then\r\n FOnDropDownMenu(Self, MousePos, Handled);\r\nend;\r\n\r\nprocedure TJvCustomNavPaneToolPanel.DoImagesChange(Sender: TObject);\r\nbegin\r\n ButtonsChanged;\r\nend;\r\n\r\nprocedure TJvCustomNavPaneToolPanel.DoStyleChange(Sender: TObject);\r\nbegin\r\n Font := (Sender as TJvNavPaneStyleManager).Fonts.NavPanelFont;\r\n Colors := (Sender as TJvNavPaneStyleManager).Colors;\r\nend;\r\n\r\nprocedure TJvCustomNavPaneToolPanel.FontChanged;\r\nbegin\r\n inherited FontChanged;\r\n Invalidate;\r\nend;\r\n\r\nfunction TJvCustomNavPaneToolPanel.GetCloseButton: Boolean;\r\nbegin\r\n Result := FCloseButton.Visible; // and HeaderVisible;\r\nend;\r\n\r\nfunction TJvCustomNavPaneToolPanel.GetDropDownMenu: TPopupMenu;\r\nbegin\r\n if not (csDestroying in ComponentState) then\r\n Result := FDropDown.DropDownMenu\r\n else\r\n Result := nil;\r\nend;\r\n\r\nfunction TJvCustomNavPaneToolPanel.GetHitTestInfoAt(X, Y: Integer): TJvToolPanelHitTestInfos;\r\n\r\n function InRange(Value, Min, Max: Integer): Boolean;\r\n begin\r\n Result := (Value >= Min) and (Value <= Max);\r\n end;\r\n\r\nbegin\r\n if not Visible then\r\n begin\r\n Result := [phtNowhere];\r\n Exit;\r\n end;\r\n Result := [];\r\n if X < 0 then\r\n Include(Result, phtToLeft);\r\n if X > ClientWidth then\r\n Include(Result, phtToRight);\r\n if Y < 0 then\r\n Include(Result, phtAbove);\r\n if Y > ClientHeight then\r\n Include(Result, phtBelow);\r\n if InRange(Y, 0, HeaderHeight - EdgeRounding) then\r\n if InRange(X, 0, ClientWidth) then\r\n begin\r\n Include(Result, phtHeader);\r\n if (X <= 16) and ShowGrabber then\r\n Include(Result, phtGrabber);\r\n end;\r\n if InRange(X, 0, ClientWidth) and InRange(Y, HeaderHeight, ClientHeight) then\r\n Include(Result, phtClient);\r\nend;\r\n\r\nprocedure TJvCustomNavPaneToolPanel.InternalButtonClick(Sender: TObject);\r\nbegin\r\n if Assigned(FOnButtonClick) then\r\n FOnButtonClick(Self, TJvNavPanelToolButton(Sender).Tag);\r\nend;\r\n\r\nprocedure TJvCustomNavPaneToolPanel.Notification(AComponent: TComponent;\r\n Operation: TOperation);\r\nbegin\r\n inherited Notification(AComponent, Operation);\r\n if Operation = opRemove then\r\n begin\r\n if AComponent = Images then\r\n Images := nil\r\n else\r\n if AComponent = StyleManager then\r\n StyleManager := nil\r\n else\r\n if AComponent = DropDownMenu then\r\n DropDownMenu := nil;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomNavPaneToolPanel.Paint;\r\nvar\r\n R, R2: TRect;\r\n I, X, Y: Integer;\r\n B: TJvNavPanelToolButton;\r\nbegin\r\n // first, fill the background\r\n Canvas.Lock;\r\n try\r\n R := ClientRect;\r\n if HeaderVisible then\r\n Inc(R.Top, HeaderHeight);\r\n GradientFillRect(Canvas, R, Colors.ToolPanelColorFrom, Colors.ToolPanelColorTo, fdTopToBottom, 255);\r\n FBackground.DrawImage(Canvas, R);\r\n R := ClientRect;\r\n if HeaderVisible then\r\n begin\r\n R.Bottom := HeaderHeight - EdgeRounding;\r\n R.Bottom := R.Top + HeaderHeight;\r\n GradientFillRect(Canvas, R, Colors.ToolPanelHeaderColorFrom, Colors.ToolPanelHeaderColorTo, fdTopToBottom, 255);\r\n // draw the drag dots\r\n R2 := Rect(R.Left, R.Top + (HeaderHeight - cToolButtonHeight) div 2 + 2, R.Left + 2, R.Top + (HeaderHeight - cToolButtonHeight) div 2 + 4);\r\n OffsetRect(R2, 6, 0);\r\n if ShowGrabber then\r\n begin\r\n for I := 0 to 3 do\r\n begin\r\n Canvas.Brush.Color := clWhite;\r\n OffsetRect(R2, 1, 1);\r\n Canvas.FillRect(R2);\r\n Canvas.Brush.Color := Colors.FrameColor;\r\n OffsetRect(R2, -1, -1);\r\n Canvas.FillRect(R2);\r\n OffsetRect(R2, 0, 4);\r\n end;\r\n // draw the text\r\n Inc(R.Left, 16);\r\n end\r\n else\r\n Inc(R.Left, 12);\r\n Canvas.Font := Self.Font;\r\n if (DropDownMenu = nil) and not (csDesigning in ComponentState) then\r\n begin\r\n OffsetRect(R, 2, -1); // line up with where button caption should have been\r\n SetBkMode(Canvas.Handle, TRANSPARENT);\r\n if CloseButton then\r\n R := Rect(R.Left, R.Top, FCloseButton.Left, R.Bottom);\r\n DrawText(Canvas, Caption, Length(Caption), R, DT_SINGLELINE or DT_VCENTER or DT_LEFT or DT_END_ELLIPSIS);\r\n end;\r\n\r\n // draw the client areas top rounding, set pixels directly to avoid messing up any background image\r\n\r\n // just a simple \"arrow\" in each corner in the same color as the gradient\r\n // left corner\r\n Y := HeaderHeight;\r\n X := 0;\r\n for I := 0 to 3 do\r\n Canvas.Pixels[X, Y + I] := Colors.ToolPanelHeaderColorTo;\r\n Inc(X);\r\n for I := 0 to 2 do\r\n Canvas.Pixels[X, Y + I] := Colors.ToolPanelHeaderColorTo;\r\n Inc(X);\r\n for I := 0 to 1 do\r\n Canvas.Pixels[X, Y + I] := Colors.ToolPanelHeaderColorTo;\r\n Inc(X);\r\n Canvas.Pixels[X, Y] := Colors.ToolPanelHeaderColorTo;\r\n // Inc(X);\r\n // Canvas.Pixels[X, Y] := Colors.HeaderColorTo;\r\n\r\n // right corner\r\n Y := HeaderHeight;\r\n X := ClientWidth - 1;\r\n for I := 0 to 4 do\r\n Canvas.Pixels[X, Y + I] := Colors.ToolPanelHeaderColorTo;\r\n Dec(X);\r\n for I := 0 to 2 do\r\n Canvas.Pixels[X, Y + I] := Colors.ToolPanelHeaderColorTo;\r\n Dec(X);\r\n for I := 0 to 1 do\r\n Canvas.Pixels[X, Y + I] := Colors.ToolPanelHeaderColorTo;\r\n Dec(X);\r\n Canvas.Pixels[X, Y] := Colors.ToolPanelHeaderColorTo;\r\n Dec(X);\r\n Canvas.Pixels[X, Y] := Colors.HeaderColorTo;\r\n\r\n // draw the button area\r\n R := ClientRect;\r\n Inc(R.Top, HeaderHeight);\r\n Inc(R.Right);\r\n Canvas.Brush.Color := Colors.FrameColor;\r\n Canvas.Pen.Style := psClear;\r\n if Buttons.Count > 0 then\r\n begin\r\n R2 := Rect(R.Left, R.Top, R.Left + ButtonWidth * Buttons.Count - 1, R.Top + ButtonHeight);\r\n Canvas.RoundRect(R2.Left, R2.Top, R2.Right, R2.Bottom, EdgeRounding, EdgeRounding);\r\n // square two corners\r\n Canvas.FillRect(Rect(R2.Right - EdgeRounding, R2.Top, R2.Right - 1, R2.Top + EdgeRounding));\r\n Canvas.FillRect(Rect(R2.Left, R2.Bottom - EdgeRounding, R2.Left + EdgeRounding, R2.Bottom - 1));\r\n Canvas.Pen.Style := psSolid;\r\n Y := R2.Top;\r\n // adjust the buttons and draw the dividers\r\n for I := 0 to Buttons.Count - 1 do\r\n begin\r\n X := R2.Left + ButtonWidth * I;\r\n B := Buttons[I].Button;\r\n B.SetBounds(X + 3, Y + 2, ButtonWidth - 6, ButtonHeight - 4);\r\n B.Visible := True;\r\n if I > 0 then\r\n begin\r\n Canvas.Pen.Color := TColor($E7EBEF);\r\n Canvas.MoveTo(X, R2.Top + 2);\r\n Canvas.LineTo(X, R2.Bottom - 3);\r\n end;\r\n if I < Buttons.Count - 1 then\r\n begin\r\n Canvas.Pen.Color := TColor($CED3D6);\r\n Canvas.MoveTo(X + ButtonWidth - 1, R2.Top + 1);\r\n Canvas.LineTo(X + ButtonWidth - 1, R2.Bottom - 4);\r\n end;\r\n end;\r\n end;\r\n end;\r\n finally\r\n Canvas.Unlock;\r\n end;\r\nend;\r\n\r\n\r\n\r\nprocedure TJvCustomNavPaneToolPanel.AlignButtons;\r\nvar\r\n AOffset: Integer;\r\nbegin\r\n if HeaderVisible and ShowGrabber then\r\n AOffset := cToolButtonOffset\r\n else\r\n AOffset := 4;\r\n if (Parent <> nil) and (HeaderHeight > cToolButtonHeight) then\r\n begin\r\n FCloseButton.SetBounds(ClientWidth - cToolButtonWidth - 2, (HeaderHeight - cToolButtonHeight) div 2, cToolButtonWidth, cToolButtonHeight);\r\n if FCloseButton.Visible or (csDesigning in ComponentState) then\r\n FDropDown.SetBounds(AOffset, (HeaderHeight - cToolButtonHeight) div 2, ClientWidth - cToolButtonWidth - AOffset - 2, cToolButtonHeight)\r\n else\r\n FDropDown.SetBounds(AOffset, (HeaderHeight - cToolButtonHeight) div 2, ClientWidth - AOffset - 4, cToolButtonHeight);\r\n end\r\n else\r\n begin\r\n FCloseButton.SetBounds(0, 0, 0, 0);\r\n FDropDown.SetBounds(0, 0, 0, 0);\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomNavPaneToolPanel.SetBounds(ALeft, ATop, AWidth, AHeight: Integer);\r\nbegin\r\n inherited SetBounds(ALeft, ATop, AWidth, AHeight);\r\n AlignButtons;\r\nend;\r\n\r\nprocedure TJvCustomNavPaneToolPanel.SetButtonHeight(const Value: Integer);\r\nbegin\r\n if FButtonHeight <> Value then\r\n begin\r\n FButtonHeight := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomNavPaneToolPanel.SetButtons(const Value: TJvNavPaneToolButtons);\r\nbegin\r\n FButtons.Assign(Value);\r\nend;\r\n\r\nprocedure TJvCustomNavPaneToolPanel.SetButtonWidth(const Value: Integer);\r\nbegin\r\n if FButtonWidth <> Value then\r\n begin\r\n FButtonWidth := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomNavPaneToolPanel.SetCloseButton(const Value: Boolean);\r\nbegin\r\n if FCloseButton.Visible <> Value then\r\n begin\r\n FCloseButton.Visible := Value;\r\n SetBounds(Left, Top, Width, Height);\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomNavPaneToolPanel.SetDropDownMenu(const Value: TPopupMenu);\r\nbegin\r\n if FDropDown.DropDownMenu <> Value then\r\n begin\r\n FDropDown.DropDownMenu := Value;\r\n FDropDown.Visible := (Value <> nil); // and HeaderVisible;\r\n SetBounds(Left, Top, Width, Height);\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomNavPaneToolPanel.SetEdgeRounding(const Value: Integer);\r\nbegin\r\n if FEdgeRounding <> Value then\r\n begin\r\n FEdgeRounding := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomNavPaneToolPanel.SetHeaderHeight(const Value: Integer);\r\nbegin\r\n if FHeaderHeight <> Value then\r\n begin\r\n FHeaderHeight := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomNavPaneToolPanel.SetImages(const Value: TCustomImageList);\r\nvar\r\n I: Integer;\r\nbegin\r\n if ReplaceImageListReference(Self, Value, FImages, FChangeLink) then\r\n begin\r\n for I := 0 to Buttons.Count - 1 do\r\n Buttons[I].Button.Images := FImages;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomNavPaneToolPanel.SetShowGrabber(const Value: Boolean);\r\nbegin\r\n if FShowGrabber <> Value then\r\n begin\r\n FShowGrabber := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomNavPaneToolPanel.SetStyleManager(const Value: TJvNavPaneStyleManager);\r\nbegin\r\n if FStyleManager <> Value then\r\n begin\r\n ParentStyleManager := False;\r\n if FStyleManager <> nil then\r\n FStyleManager.UnregisterChanges(FStyleLink);\r\n ReplaceComponentReference(Self, Value, tComponent(FStyleManager));\r\n if FStyleManager <> nil then\r\n begin\r\n FStyleManager.RegisterChanges(FStyleLink);\r\n Colors := FStyleManager.Colors;\r\n Invalidate;\r\n end;\r\n InternalStyleManagerChanged(Self, StyleManager);\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomNavPaneToolPanel.ParentStyleManagerChanged(var Msg: TMsgStyleManagerChange);\r\nbegin\r\n if (Msg.Sender <> Self) and ParentStyleManager then\r\n begin\r\n StyleManager := Msg.StyleManager;\r\n ParentStyleManager := True;\r\n InternalStyleManagerChanged(Self, Msg.StyleManager);\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomNavPaneToolPanel.TextChanged;\r\nbegin\r\n inherited TextChanged;\r\n FDropDown.Caption := Caption;\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvCustomNavPaneToolPanel.SetParentStyleManager(const Value: Boolean);\r\nbegin\r\n if FParentStyleManager <> Value then\r\n begin\r\n FParentStyleManager := Value;\r\n if FParentStyleManager and (Parent <> nil) then\r\n Parent.Perform(CM_PARENTSTYLEMANAGERCHANGE, 0, 0);\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomNavPaneToolPanel.CMControlChange(var Msg: TMessage);\r\nbegin\r\n InternalStyleManagerChanged(Self, StyleManager);\r\nend;\r\n\r\nprocedure TJvCustomNavPaneToolPanel.WMEraseBkgnd(var Msg: TWMEraseBkgnd);\r\nbegin\r\n Msg.Result := 1;\r\nend;\r\n\r\nprocedure TJvCustomNavPaneToolPanel.WMNCPaint(var Msg: TWMNCPaint);\r\nvar\r\n AColor: TColor;\r\nbegin\r\n AColor := Color;\r\n Color := Colors.FrameColor;\r\n inherited;\r\n Color := AColor;\r\nend;\r\n\r\nprocedure TJvCustomNavPaneToolPanel.ParentStyleManagerChange(var Msg: TMessage);\r\nbegin\r\n InternalStyleManagerChanged(Self, StyleManager);\r\nend;\r\n\r\nfunction TJvCustomNavPaneToolPanel.GetDrawPartialMenuFrame: Boolean;\r\nbegin\r\n if FDropDown <> nil then\r\n Result := FDropDown.DrawPartialMenuFrame\r\n else\r\n Result := False;\r\nend;\r\n\r\nprocedure TJvCustomNavPaneToolPanel.SetDrawPartialMenuFrame(const Value: Boolean);\r\nbegin\r\n if FDropDown <> nil then\r\n FDropDown.DrawPartialMenuFrame := Value;\r\nend;\r\n\r\nprocedure TJvCustomNavPaneToolPanel.SetBackground(const Value: TJvNavPaneBackgroundImage);\r\nbegin\r\n FBackground.Assign(Value);\r\nend;\r\n\r\nprocedure TJvCustomNavPaneToolPanel.SetColors(const Value: TJvNavPanelColors);\r\nbegin\r\n FColors.Assign(Value);\r\nend;\r\n\r\nprocedure TJvCustomNavPaneToolPanel.SetHeaderVisible(const Value: Boolean);\r\nbegin\r\n if FHeaderVisible <> Value then\r\n begin\r\n FHeaderVisible := Value;\r\n FCloseButton.Visible := CloseButton;\r\n FDropDown.Visible := (FDropDown.DropDownMenu <> nil); // and Value;\r\n ButtonsChanged;\r\n end;\r\nend;\r\n\r\nfunction TJvCustomNavPaneToolPanel.IsColorsStored: Boolean;\r\nbegin\r\n Result := (StyleManager = nil) or (StyleManager.Theme = nptCustom);\r\nend;\r\n\r\n//=== { TJvNavPaneToolButton } ===============================================\r\n\r\nprocedure TJvNavPaneToolButton.Assign(Source: TPersistent);\r\nbegin\r\n if Source is TJvNavPaneToolButton then\r\n begin\r\n Action := TJvNavPaneToolButton(Source).Action;\r\n Hint := TJvNavPaneToolButton(Source).Hint;\r\n ImageIndex := TJvNavPaneToolButton(Source).ImageIndex;\r\n Enabled := TJvNavPaneToolButton(Source).Enabled\r\n end\r\n else\r\n inherited Assign(Source);\r\nend;\r\n\r\nconstructor TJvNavPaneToolButton.Create(Collection: Classes.TCollection);\r\nbegin\r\n FRealButton := TJvNavPanelToolButton.Create(nil);\r\n FRealButton.ButtonType := nibImage;\r\n FRealButton.ImageIndex := -1;\r\n inherited Create(Collection);\r\nend;\r\n\r\ndestructor TJvNavPaneToolButton.Destroy;\r\nbegin\r\n FRealButton.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJvNavPaneToolButton.GetAction: TBasicAction;\r\nbegin\r\n Result := FRealButton.Action;\r\nend;\r\n\r\nfunction TJvNavPaneToolButton.GetEnabled: Boolean;\r\nbegin\r\n Result := FRealButton.Enabled;\r\nend;\r\n\r\nfunction TJvNavPaneToolButton.GetHint: string;\r\nbegin\r\n Result := FRealButton.Hint;\r\nend;\r\n\r\nfunction TJvNavPaneToolButton.GetImageIndex: TImageIndex;\r\nbegin\r\n Result := FRealButton.ImageIndex;\r\nend;\r\n\r\nprocedure TJvNavPaneToolButton.SetAction(const Value: TBasicAction);\r\nbegin\r\n FRealButton.Action := Value;\r\n FRealButton.ActionChange(Value, False);\r\nend;\r\n\r\nprocedure TJvNavPaneToolButton.SetEnabled(const Value: Boolean);\r\nbegin\r\n FRealButton.Enabled := Value;\r\nend;\r\n\r\nprocedure TJvNavPaneToolButton.SetHint(const Value: string);\r\nbegin\r\n FRealButton.Hint := Value;\r\nend;\r\n\r\nprocedure TJvNavPaneToolButton.SetImageIndex(const Value: TImageIndex);\r\nbegin\r\n FRealButton.ImageIndex := Value;\r\nend;\r\n\r\n//=== { TJvNavPaneToolButtons } ==============================================\r\n\r\nconstructor TJvNavPaneToolButtons.Create(AOwner: TJvCustomNavPaneToolPanel);\r\nbegin\r\n inherited Create(AOwner, TJvNavPaneToolButton);\r\n FPanel := AOwner;\r\nend;\r\n\r\nfunction TJvNavPaneToolButtons.Add: TJvNavPaneToolButton;\r\nbegin\r\n Result := TJvNavPaneToolButton(inherited Add);\r\nend;\r\n\r\nfunction TJvNavPaneToolButtons.GetItem(Index: Integer): TJvNavPaneToolButton;\r\nbegin\r\n Result := TJvNavPaneToolButton(inherited Items[Index]);\r\nend;\r\n\r\nprocedure TJvNavPaneToolButtons.SetItem(Index: Integer;\r\n const Value: TJvNavPaneToolButton);\r\nbegin\r\n inherited Items[Index] := Value;\r\nend;\r\n\r\nprocedure TJvNavPaneToolButtons.Update(Item: TCollectionItem);\r\nbegin\r\n inherited Update(Item);\r\n if FPanel <> nil then\r\n FPanel.ButtonsChanged;\r\nend;\r\n\r\n//=== { TJvNavPanelToolButton } ==============================================\r\n\r\nconstructor TJvNavPanelToolButton.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FChangeLink := TChangeLink.Create;\r\n FChangeLink.OnChange := DoImagesChange;\r\n DrawPartialMenuFrame := False;\r\n TransparentDown := False;\r\n HotTrack := True;\r\nend;\r\n\r\ndestructor TJvNavPanelToolButton.Destroy;\r\nbegin\r\n FChangeLink.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvNavPanelToolButton.ActionChange(Sender: TObject; CheckDefaults: Boolean);\r\nbegin\r\n if Sender is TCustomAction then\r\n with TCustomAction(Sender) do\r\n begin\r\n if not CheckDefaults or Self.Enabled then\r\n Self.Enabled := Enabled;\r\n if not CheckDefaults or (Self.Hint = '') then\r\n Self.Hint := Hint;\r\n if not CheckDefaults or (Self.ImageIndex = -1) then\r\n Self.ImageIndex := ImageIndex;\r\n if not CheckDefaults or Self.Visible then\r\n Self.Visible := Visible;\r\n if not CheckDefaults or not Assigned(Self.OnClick) then\r\n Self.OnClick := OnExecute;\r\n end;\r\nend;\r\n\r\nprocedure TJvNavPanelToolButton.DoImagesChange(Sender: TObject);\r\nbegin\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvNavPanelToolButton.Notification(AComponent: TComponent;\r\n Operation: TOperation);\r\nbegin\r\n inherited Notification(AComponent, Operation);\r\n if (Operation = opRemove) and (AComponent = Images) then\r\n Images := nil;\r\nend;\r\n\r\nprocedure TJvNavPanelToolButton.Paint;\r\nlabel\r\n DrawButton;\r\nvar\r\n R: TRect;\r\n I: Integer;\r\nbegin\r\n // inherited Paint;\r\n if MouseStates <> [] then\r\n begin\r\n Canvas.Pen.Color := TColor($6B2408);\r\n if bsMouseInside in MouseStates then\r\n Canvas.Brush.Color := TColor($D6BEB5);\r\n if (bsMouseDown in MouseStates) or Down then\r\n begin\r\n if TransparentDown then\r\n Canvas.Brush.Style := bsClear; // (p3) don't draw background - looks better IMO\r\n if (ButtonType = nibDropArrow) and (DropDownMenu <> nil) then\r\n begin\r\n Canvas.Brush.Color := clWindow;\r\n Canvas.Pen.Color := cl3DDkShadow;\r\n if DrawPartialMenuFrame then\r\n begin\r\n Canvas.FillRect(ClientRect); // if Brush.Style = bsClear, this does nothing\r\n Canvas.MoveTo(0, Height);\r\n Canvas.LineTo(0, 0);\r\n Canvas.LineTo(Width - 1, 0);\r\n Canvas.LineTo(Width - 1, Height);\r\n // (p3) yucky! first goto in JVCL?!!!\r\n goto DrawButton;\r\n end;\r\n end\r\n else\r\n Canvas.Brush.Color := TColor($B59284);\r\n end;\r\n Canvas.Rectangle(ClientRect);\r\n end;\r\n\r\nDrawButton:\r\n\r\n case ButtonType of\r\n nibDropArrow: // dropdown arrow is 7x4, right-aligned\r\n begin\r\n R := ClientRect;\r\n if Caption <> '' then\r\n begin\r\n InflateRect(R, -2, -2);\r\n Canvas.Font := Font;\r\n SetBkMode(Canvas.Handle, TRANSPARENT);\r\n InflateRect(R, -2, 0);\r\n Dec(R.Right, 3 + 7);\r\n DrawText(Canvas, Caption, Length(Caption), R, DT_LEFT or DT_VCENTER or DT_NOPREFIX or DT_END_ELLIPSIS);\r\n Inc(R.Right, 3 + 7);\r\n InflateRect(R, 2, 0);\r\n end;\r\n R.Left := R.Right - 11;\r\n Dec(R.Right, 4);\r\n R.Top := (RectHeight(ClientRect) - 4) div 2;\r\n Canvas.Pen.Color := clWindowText;\r\n for I := 0 to 3 do\r\n begin\r\n Canvas.MoveTo(R.Left, R.Top);\r\n Canvas.LineTo(R.Right, R.Top);\r\n Dec(R.Right);\r\n Inc(R.Left);\r\n Inc(R.Top);\r\n end;\r\n end;\r\n nibClose:\r\n begin\r\n // close button is 8x8, centered\r\n if bsMouseDown in MouseStates then\r\n Canvas.Pen.Color := clHighlightText\r\n else\r\n Canvas.Pen.Color := clWindowText;\r\n R := ClientRect;\r\n InflateRect(R, -(RectWidth(R) div 2 - 4), -(RectHeight(R) div 2 - 4));\r\n if Odd(Height) or Odd(Width) then\r\n begin\r\n Inc(R.Right);\r\n Inc(R.Bottom);\r\n end;\r\n // (p3) this isn't exactly the same as MS's but good enough for me :)\r\n for I := 0 to 7 do\r\n begin\r\n Canvas.MoveTo(R.Left + I, R.Top + I);\r\n Canvas.LineTo(R.Left + I + 2, R.Top + I);\r\n end;\r\n for I := 0 to 7 do\r\n begin\r\n Canvas.MoveTo(R.Right - I, R.Top + I);\r\n Canvas.LineTo(R.Right - I - 2, R.Top + I);\r\n end;\r\n end;\r\n nibImage:\r\n if Assigned(Images) then\r\n Images.Draw(Canvas,\r\n (Width - Images.Width) div 2, (Height - Images.Height) div 2,\r\n ImageIndex, Enabled);\r\n else\r\n raise EJVCLException.CreateRes(@RsEUnsupportedButtonType);\r\n end;\r\nend;\r\n\r\nprocedure TJvNavPanelToolButton.SetButtonType(const Value: TJvNavIconButtonType);\r\nbegin\r\n if FButtonType <> Value then\r\n begin\r\n FButtonType := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvNavPanelToolButton.SetImageIndex(const Value: TImageIndex);\r\nbegin\r\n if FImageIndex <> Value then\r\n begin\r\n FImageIndex := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvNavPanelToolButton.SetImages(const Value: TCustomImageList);\r\nbegin\r\n if ReplaceImageListReference(Self, Value, FImages, FChangeLink) then\r\n Invalidate;\r\nend;\r\n\r\n//=== { TJvNavPaneBackgroundImage } ==========================================\r\n\r\nconstructor TJvNavPaneBackgroundImage.Create;\r\nbegin\r\n inherited Create;\r\n FPicture := TPicture.Create;\r\n FPicture.OnChange := PictureChanged;\r\nend;\r\n\r\ndestructor TJvNavPaneBackgroundImage.Destroy;\r\nbegin\r\n FPicture.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJvNavPaneBackgroundImage.CalcRect(ADestRect: TRect): TRect;\r\nvar\r\n W, H, CW, CH: Integer;\r\n XYAspect: Double;\r\nbegin\r\n W := Picture.Width;\r\n H := Picture.Height;\r\n CW := ADestRect.Right - ADestRect.Left;\r\n CH := ADestRect.Bottom - ADestRect.Top;\r\n if Stretch or (Proportional and ((W > CW) or (H > CH))) then\r\n begin\r\n if Proportional and (W > 0) and (H > 0) then\r\n begin\r\n XYAspect := W / H;\r\n if W > H then\r\n begin\r\n W := CW;\r\n H := Trunc(CW / XYAspect);\r\n if H > CH then // woops, too big\r\n begin\r\n H := CH;\r\n W := Trunc(CH * XYAspect);\r\n end;\r\n end\r\n else\r\n begin\r\n H := CH;\r\n W := Trunc(CH * XYAspect);\r\n if W > CW then // woops, too big\r\n begin\r\n W := CW;\r\n H := Trunc(CW / XYAspect);\r\n end;\r\n end;\r\n end\r\n else\r\n begin\r\n W := CW;\r\n H := CH;\r\n end;\r\n end;\r\n\r\n Result := Rect(ADestRect.Left, ADestRect.Top, ADestRect.Left + W, ADestRect.Top + H);\r\n if Center then\r\n OffsetRect(Result, (CW - W) div 2, (CH - H) div 2);\r\nend;\r\n\r\nprocedure TJvNavPaneBackgroundImage.Change;\r\nbegin\r\n FDrawing := True;\r\n if Assigned(FOnChange) then\r\n FOnChange(Self);\r\n FDrawing := False;\r\nend;\r\n\r\nprocedure TJvNavPaneBackgroundImage.DrawImage(Canvas: TCanvas; ARect: TRect);\r\n\r\n procedure TileImage;\r\n var\r\n X, Y: Integer;\r\n G: TGraphic;\r\n begin\r\n G := Picture.Graphic;\r\n X := ARect.Left;\r\n Y := ARect.Top;\r\n while Y < ARect.Bottom do\r\n begin\r\n Canvas.Draw(X, Y, G); // this doesn't clip on the right or bottom sides of ARect :(\r\n Inc(X, G.Width);\r\n if X > ARect.Right then\r\n begin\r\n X := ARect.Left;\r\n Inc(Y, G.Height);\r\n end;\r\n end;\r\n end;\r\n\r\nbegin\r\n if (Picture.Graphic = nil) or (Picture.Width = 0) or (Picture.Height = 0) then\r\n Exit;\r\n if Tile then\r\n TileImage\r\n else\r\n with Canvas do\r\n StretchDraw(CalcRect(ARect), Picture.Graphic);\r\nend;\r\n\r\nfunction TJvNavPaneBackgroundImage.HasImage: Boolean;\r\nbegin\r\n with Picture do\r\n Result := (Graphic <> nil) and (Width <> 0) and (Height <> 0);\r\nend;\r\n\r\nprocedure TJvNavPaneBackgroundImage.PictureChanged(Sender: TObject);\r\nvar\r\n G: TGraphic;\r\nbegin\r\n G := Picture.Graphic;\r\n if G <> nil then\r\n if not ( (G is TMetaFile) or (G is TIcon)) then\r\n G.Transparent := FTransparent;\r\n if not FDrawing then\r\n Change;\r\nend;\r\n\r\nprocedure TJvNavPaneBackgroundImage.SetCenter(const Value: Boolean);\r\nbegin\r\n if FCenter <> Value then\r\n begin\r\n FCenter := Value;\r\n PictureChanged(Self);\r\n end;\r\nend;\r\n\r\nprocedure TJvNavPaneBackgroundImage.SetPicture(const Value: TPicture);\r\nbegin\r\n FPicture.Assign(Value);\r\nend;\r\n\r\nprocedure TJvNavPaneBackgroundImage.SetProportional(const Value: Boolean);\r\nbegin\r\n if FProportional <> Value then\r\n begin\r\n FProportional := Value;\r\n PictureChanged(Self);\r\n end;\r\nend;\r\n\r\nprocedure TJvNavPaneBackgroundImage.SetStretch(const Value: Boolean);\r\nbegin\r\n if FStretch <> Value then\r\n begin\r\n FStretch := Value;\r\n PictureChanged(Self);\r\n end;\r\nend;\r\n\r\nprocedure TJvNavPaneBackgroundImage.SetTile(const Value: Boolean);\r\nbegin\r\n if FTile <> Value then\r\n begin\r\n FTile := Value;\r\n PictureChanged(Self);\r\n end;\r\nend;\r\n\r\nprocedure TJvNavPaneBackgroundImage.SetTransparent(const Value: Boolean);\r\nbegin\r\n if FTransparent <> Value then\r\n begin\r\n FTransparent := Value;\r\n PictureChanged(Self)\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomNavPaneToolPanel.AdjustClientRect(var Rect: TRect);\r\nbegin\r\n if HeaderVisible then\r\n begin\r\n Rect.Top := Rect.Top + HeaderHeight + EdgeRounding;\r\n if Buttons.Count > 0 then\r\n Rect.Top := Rect.Top + ButtonHeight - EdgeRounding;\r\n end;\r\n InflateRect(Rect, -2, -2);\r\n inherited AdjustClientRect(Rect);\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvNetscapeSplitter.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvSplitter.PAS, released on 2001-02-28.\r\n\r\nThe Initial Developer of the Original Code is Sbastien Buysse [sbuysse att buypin dott com]\r\nPortions created by Sbastien Buysse are Copyright (C) 2001 Sbastien Buysse.\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\nMichael Beck [mbeck att bigfoot dott com].\r\ndejoy(dejoy att ynl dott gov dott cn)\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvNetscapeSplitter.pas 13104 2011-09-07 06:50:43Z obones $\r\n\r\nunit JvNetscapeSplitter;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n SysUtils, Classes,\r\n Windows, Messages, Graphics, Forms, ExtCtrls, Controls,\r\n JvExExtCtrls;\r\n\r\nconst\r\n MOVEMENT_TOLERANCE = 5; // See WMLButtonUp message handler.\r\n JvDefaultButtonHighlightColor = TColor($00FFCFCF); // RGB(207,207,255)\r\n\r\ntype\r\n TJvButtonWidthKind = (btwPixels, btwPercentage);\r\n TJvButtonStyle = (bsNetscape, bsWindows);\r\n TJvWindowsButton = (wbMin, wbMax, wbClose);\r\n TJvWindowsButtons = set of TJvWindowsButton;\r\n\r\n TJvCustomNetscapeSplitter = class(TJvExSplitter)\r\n private\r\n FBusy: Boolean;\r\n FShowButton: Boolean;\r\n FButtonWidthKind: TJvButtonWidthKind;\r\n FButtonWidth: Integer;\r\n FOnMaximize: TNotifyEvent;\r\n FOnMinimize: TNotifyEvent;\r\n FOnRestore: TNotifyEvent;\r\n FMaximized: Boolean;\r\n FMinimized: Boolean;\r\n // Internal use for \"restoring\" from \"maximized\" state\r\n FRestorePos: Integer;\r\n // For internal use to avoid calling GetButtonRect when not necessary\r\n FLastKnownButtonRect: TRect;\r\n // Internal use to avoid unecessary painting\r\n FIsHighlighted: Boolean;\r\n // Internal for detecting real clicks\r\n FGotMouseDown: Boolean;\r\n FButtonColor: TColor;\r\n FButtonHighlightColor: TColor;\r\n FArrowColor: TColor;\r\n FTextureColor1: TColor;\r\n FTextureColor2: TColor;\r\n FAutoHighlightColor: Boolean;\r\n FAllowDrag: Boolean;\r\n FButtonStyle: TJvButtonStyle;\r\n FWindowsButtons: TJvWindowsButtons;\r\n FOnClose :TNotifyEvent;\r\n FOnButtonDblClick :TNotifyEvent;\r\n FOnLineDblClick :TNotifyEvent;\r\n FButtonCursor: TCursor;\r\n procedure SetShowButton(const Value: Boolean);\r\n procedure SetButtonWidthKind(const Value: TJvButtonWidthKind);\r\n procedure SetButtonWidth(const Value: Integer);\r\n function GetButtonRect: TRect;\r\n procedure SetMaximized(const Value: Boolean);\r\n procedure SetMinimized(const Value: Boolean);\r\n function GetAlign: TAlign;\r\n procedure SetAlign(Value: TAlign);\r\n procedure SetArrowColor(const Value: TColor);\r\n procedure SetButtonColor(const Value: TColor);\r\n procedure SetButtonHighlightColor(const Value: TColor);\r\n procedure SetButtonStyle(const Value: TJvButtonStyle);\r\n procedure SetTextureColor1(const Value: TColor);\r\n procedure SetTextureColor2(const Value: TColor);\r\n procedure SetAutoHighlightColor(const Value: Boolean);\r\n procedure SetAllowDrag(const Value: Boolean);\r\n procedure SetWindowsButtons(const Value: TJvWindowsButtons);\r\n procedure SetButtonCursor(const Value: TCursor);\r\n protected\r\n // Internal use for moving splitter position with FindControl and\r\n // UpdateControlSize\r\n FControl: TControl;\r\n FDownPos: TPoint;\r\n procedure MouseEnter(Control: TControl); override;\r\n procedure MouseLeave(Control: TControl); override;\r\n procedure Paint; override;\r\n procedure WMLButtonDown(var Msg: TWMLButtonDown); message WM_LBUTTONDOWN;\r\n procedure WMLButtonUp(var Msg: TWMLButtonUp); message WM_LBUTTONUP;\r\n procedure WMMouseMove(var Msg: TWMMouseMove); message WM_MOUSEMOVE;\r\n procedure WMDblClick (var Msg:TWMLButtonDBLCLK); message WM_LBUTTONDBLCLK;\r\n procedure LoadOtherProperties(Reader: TReader); dynamic;\r\n procedure StoreOtherProperties(Writer: TWriter); dynamic;\r\n procedure DefineProperties(Filer: TFiler); override;\r\n function DoCanResize(var NewSize: Integer): Boolean; override;\r\n procedure Loaded; override;\r\n procedure PaintButton(Highlight: Boolean); dynamic;\r\n function DrawArrow(ACanvas: TCanvas; AvailableRect: TRect; AOffset: Integer;\r\n ArrowSize: Integer; Color: TColor): Integer; dynamic;\r\n function WindowButtonHitTest(X, Y: Integer): TJvWindowsButton; dynamic;\r\n function ButtonHitTest(X, Y: Integer): Boolean; dynamic;\r\n procedure DoMaximize; dynamic;\r\n procedure DoMinimize; dynamic;\r\n procedure DoRestore; dynamic;\r\n procedure DoClose; dynamic;\r\n procedure FindControl; dynamic;\r\n procedure UpdateControlSize(NewSize: Integer); dynamic;\r\n function GrabBarColor: TColor;\r\n function VisibleWinButtons: Integer;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n procedure SetBounds(ALeft, ATop, AWidth, AHeight: Integer); override;\r\n property ButtonRect: TRect read GetButtonRect;\r\n property RestorePos: Integer read FRestorePos write FRestorePos;\r\n property Maximized: Boolean read FMaximized write SetMaximized;\r\n property Minimized: Boolean read FMinimized write SetMinimized;\r\n property AllowDrag: Boolean read FAllowDrag write SetAllowDrag default True;\r\n property ButtonCursor: TCursor read FButtonCursor write SetButtonCursor;\r\n property ButtonStyle: TJvButtonStyle read FButtonStyle write SetButtonStyle default bsNetscape;\r\n property WindowsButtons: TJvWindowsButtons read FWindowsButtons write SetWindowsButtons\r\n default [wbMin, wbMax, wbClose];\r\n property ButtonWidthKind: TJvButtonWidthKind read FButtonWidthKind write SetButtonWidthKind\r\n default btwPixels;\r\n property ButtonWidth: Integer read FButtonWidth write SetButtonWidth default 100;\r\n property ShowButton: Boolean read FShowButton write SetShowButton default True;\r\n property ButtonColor: TColor read FButtonColor write SetButtonColor default clBtnFace;\r\n property ArrowColor: TColor read FArrowColor write SetArrowColor default clNavy;\r\n property ButtonHighlightColor: TColor read FButtonHighlightColor write SetButtonHighlightColor\r\n default JvDefaultButtonHighlightColor;\r\n property AutoHighlightColor: Boolean read FAutoHighlightColor write SetAutoHighlightColor\r\n default False;\r\n property TextureColor1: TColor read FTextureColor1 write SetTextureColor1 default clWhite;\r\n property TextureColor2: TColor read FTextureColor2 write SetTextureColor2 default clNavy;\r\n property Align: TAlign read GetAlign write SetAlign; // Need to know when it changes to redraw arrows\r\n property Width default 10; // it looks best with 10\r\n property Beveled default False; // it looks best without the bevel\r\n property Enabled;\r\n property HintColor;\r\n property OnClose: TNotifyEvent read FOnClose write FOnClose;\r\n property OnMaximize: TNotifyEvent read FOnMaximize write FOnMaximize;\r\n property OnMinimize: TNotifyEvent read FOnMinimize write FOnMinimize;\r\n property OnRestore : TNotifyEvent read FOnRestore write FOnRestore;\r\n property OnButtonDblClick: TNotifyEvent read FOnButtonDblClick write FOnButtonDblClick;\r\n property OnLineDblClick : TNotifyEvent read FOnLineDblClick write FOnLineDblClick;\r\n property OnParentColorChange;\r\n end;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvNetscapeSplitter = class(TJvCustomNetscapeSplitter)\r\n published\r\n property Maximized;\r\n property Minimized;\r\n property AllowDrag;\r\n property ButtonCursor;\r\n property ButtonStyle;\r\n property WindowsButtons;\r\n property ButtonWidthKind;\r\n property ButtonWidth;\r\n property ShowButton;\r\n property ButtonColor;\r\n property ArrowColor;\r\n property ButtonHighlightColor;\r\n property AutoHighlightColor;\r\n property TextureColor1;\r\n property TextureColor2;\r\n property Align;\r\n property Width;\r\n property Beveled;\r\n property Enabled;\r\n property ShowHint;\r\n property HintColor;\r\n property OnClose;\r\n property OnMaximize;\r\n property OnMinimize;\r\n property OnRestore;\r\n property OnMouseEnter;\r\n property OnMouseLeave;\r\n property OnParentColorChange;\r\n property OnButtonDblClick;\r\n property OnLineDblClick;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvNetscapeSplitter.pas $';\r\n Revision: '$Revision: 13104 $';\r\n Date: '$Date: 2011-09-07 08:50:43 +0200 (mer. 07 sept. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n JvThemes;\r\n\r\nprocedure SetRectEmpty(var R: TRect);\r\nbegin\r\n FillChar(R, SizeOf(TRect), #0);\r\nend;\r\n\r\nconstructor TJvCustomNetscapeSplitter.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n IncludeThemeStyle(Self, [csParentBackground]);\r\n\r\n Beveled := False;\r\n FAllowDrag := True;\r\n FButtonStyle := bsNetscape;\r\n FWindowsButtons := [wbMin, wbMax, wbClose];\r\n FButtonWidthKind := btwPixels;\r\n FButtonWidth := 100;\r\n FShowButton := True;\r\n SetRectEmpty(FLastKnownButtonRect);\r\n FIsHighlighted := False;\r\n FGotMouseDown := False;\r\n FControl := nil;\r\n FDownPos := Point(0, 0);\r\n FMaximized := False;\r\n FMinimized := False;\r\n FRestorePos := -1;\r\n Width := 10;\r\n FButtonColor := clBtnFace;\r\n FArrowColor := clNavy;\r\n FButtonHighlightColor := JvDefaultButtonHighlightColor;\r\n FAutoHighlightColor := False;\r\n FTextureColor1 := clWhite;\r\n FTextureColor2 := clNavy;\r\nend;\r\n\r\n\r\n\r\nprocedure TJvCustomNetscapeSplitter.MouseEnter(Control: TControl);\r\nvar\r\n Pos: TPoint;\r\nbegin\r\n if csDesigning in ComponentState then\r\n Exit;\r\n\r\n if not MouseOver then\r\n begin\r\n inherited MouseEnter(Control);\r\n\r\n //from dfs\r\n GetCursorPos(Pos); // CM_MOUSEENTER doesn't send mouse pos.\r\n Pos := Self.ScreenToClient(Pos);\r\n // The order is important here. ButtonHitTest must be evaluated before\r\n // the ButtonStyle because it will change the cursor (over button or not).\r\n // If the order were reversed, the cursor would not get set for bsWindows\r\n // style since short-circuit Boolean eval would stop it from ever being\r\n // called in the first place.\r\n if ButtonHitTest(Pos.X, Pos.Y) and (ButtonStyle = bsNetscape) then\r\n begin\r\n if not FIsHighlighted then\r\n PaintButton(True)\r\n end\r\n else\r\n if FIsHighlighted then\r\n PaintButton(False);\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomNetscapeSplitter.MouseLeave(Control: TControl);\r\nbegin\r\n if MouseOver then\r\n begin\r\n inherited MouseLeave(Control);\r\n\r\n //from dfs\r\n if (ButtonStyle = bsNetscape) and FIsHighlighted then\r\n PaintButton(False);\r\n\r\n FGotMouseDown := False;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomNetscapeSplitter.Paint;\r\n{$IFDEF JVCLThemesEnabled}\r\nvar\r\n Bmp: TBitmap;\r\n DC: THandle;\r\n{$ENDIF JVCLThemesEnabled}\r\nbegin\r\n if FBusy then\r\n Exit;\r\n FBusy := True;\r\n try\r\n // Exclude button rect from update region here for less flicker.\r\n {$IFDEF JVCLThemesEnabled}\r\n if ThemeServices.{$IFDEF RTL230_UP}Enabled{$ELSE}ThemesEnabled{$ENDIF RTL230_UP} then\r\n begin\r\n // DrawThemedBackground(Self, Canvas, ClientRect, Parent.Brush.Color);\r\n DC := Canvas.Handle;\r\n Bmp := TBitmap.Create;\r\n try\r\n Bmp.Width := ClientWidth;\r\n Bmp.Height := ClientHeight;\r\n Canvas.Handle := Bmp.Canvas.Handle;\r\n try\r\n inherited Paint;\r\n finally\r\n Canvas.Handle := DC;\r\n end;\r\n Bmp.Transparent := True;\r\n Bmp.TransparentColor := Color;\r\n Canvas.Draw(0, 0, Bmp);\r\n finally\r\n Bmp.Free;\r\n end;\r\n end\r\n else\r\n inherited Paint;\r\n {$ELSE}\r\n inherited Paint;\r\n {$ENDIF JVCLThemesEnabled}\r\n\r\n // Don't paint while being moved unless ResizeStyle = rsUpdate!!!\r\n // Make rect smaller if Beveled is True.\r\n PaintButton(FIsHighlighted);\r\n finally\r\n FBusy := False;\r\n end;\r\nend;\r\n\r\n\r\n//dfs\r\n\r\nfunction TJvCustomNetscapeSplitter.ButtonHitTest(X, Y: Integer): Boolean;\r\nbegin\r\n // We use FLastKnownButtonRect here so that we don't have to recalculate the\r\n // button rect with GetButtonRect every time the mouse moved. That would be\r\n // EXTREMELY inefficient.\r\n Result := PtInRect(FLastKnownButtonRect, Point(X, Y));\r\n if Align in [alLeft, alRight] then\r\n begin\r\n if (not AllowDrag) or ((Y >= FLastKnownButtonRect.Top) and\r\n (Y <= FLastKnownButtonRect.Bottom)) then\r\n Windows.SetCursor(Screen.Cursors[ButtonCursor])\r\n else\r\n Windows.SetCursor(Screen.Cursors[Cursor]);\r\n end\r\n else\r\n begin\r\n if (not AllowDrag) or ((X >= FLastKnownButtonRect.Left) and\r\n (X <= FLastKnownButtonRect.Right)) then\r\n Windows.SetCursor(Screen.Cursors[ButtonCursor])\r\n else\r\n Windows.SetCursor(Screen.Cursors[Cursor]);\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomNetscapeSplitter.DefineProperties(Filer: TFiler);\r\nbegin\r\n inherited DefineProperties(Filer);\r\n Filer.DefineProperty('RestorePos', LoadOtherProperties, StoreOtherProperties,\r\n Minimized or Maximized);\r\nend;\r\n\r\nfunction TJvCustomNetscapeSplitter.DoCanResize(var NewSize: Integer): Boolean;\r\nbegin\r\n Result := inherited DoCanResize(NewSize);\r\n // D4 version has a bug that causes it to not honor MinSize, which causes a\r\n // really nasty problem.\r\n if Result and (NewSize < MinSize) then\r\n NewSize := MinSize;\r\nend;\r\n\r\nprocedure TJvCustomNetscapeSplitter.DoClose;\r\nbegin\r\n if Assigned(FOnClose) then\r\n FOnClose(Self);\r\nend;\r\n\r\nprocedure TJvCustomNetscapeSplitter.DoMaximize;\r\nbegin\r\n if Assigned(FOnMaximize) then\r\n FOnMaximize(Self);\r\nend;\r\n\r\nprocedure TJvCustomNetscapeSplitter.DoMinimize;\r\nbegin\r\n if Assigned(FOnMinimize) then\r\n FOnMinimize(Self);\r\nend;\r\n\r\nprocedure TJvCustomNetscapeSplitter.DoRestore;\r\nbegin\r\n if Assigned(FOnRestore) then\r\n FOnRestore(Self);\r\nend;\r\n\r\nfunction TJvCustomNetscapeSplitter.DrawArrow(ACanvas: TCanvas; AvailableRect: TRect;\r\n AOffset, ArrowSize: Integer; Color: TColor): Integer;\r\nvar\r\n X, Y, Q, I, J: Integer;\r\n ArrowAlign: TAlign;\r\nbegin\r\n // STB Nitro drivers have a LineTo bug, so I've opted to use the slower\r\n // SetPixel method to draw the arrows.\r\n\r\n if not Odd(ArrowSize) then\r\n Dec(ArrowSize);\r\n if ArrowSize < 1 then\r\n ArrowSize := 1;\r\n\r\n if FMaximized then\r\n begin\r\n case Align of\r\n alLeft:\r\n ArrowAlign := alRight;\r\n alRight:\r\n ArrowAlign := alLeft;\r\n alTop:\r\n ArrowAlign := alBottom;\r\n else //alBottom\r\n ArrowAlign := alTop;\r\n end;\r\n end\r\n else\r\n ArrowAlign := Align;\r\n Q := ArrowSize * 2 - 1;\r\n Result := Q;\r\n ACanvas.Pen.Color := Color;\r\n case ArrowAlign of\r\n alLeft:\r\n begin\r\n X := AvailableRect.Left + ((AvailableRect.Right - AvailableRect.Left - ArrowSize) div 2) + 1;\r\n if AOffset < 0 then\r\n Y := AvailableRect.Bottom + AOffset - Q\r\n else\r\n Y := AvailableRect.Top + AOffset;\r\n for J := X + ArrowSize - 1 downto X do\r\n begin\r\n for I := Y to Y + Q - 1 do\r\n ACanvas.Pixels[J, I] := Color;\r\n Inc(Y);\r\n Dec(Q, 2);\r\n end;\r\n end;\r\n alRight:\r\n begin\r\n X := AvailableRect.Left + ((AvailableRect.Right - AvailableRect.Left - ArrowSize) div 2) + 1;\r\n if AOffset < 0 then\r\n Y := AvailableRect.Bottom + AOffset - Q\r\n else\r\n Y := AvailableRect.Top + AOffset;\r\n for J := X to X + ArrowSize - 1 do\r\n begin\r\n for I := Y to Y + Q - 1 do\r\n ACanvas.Pixels[J, I] := Color;\r\n Inc(Y);\r\n Dec(Q, 2);\r\n end;\r\n end;\r\n alTop:\r\n begin\r\n if AOffset < 0 then\r\n X := AvailableRect.Right + AOffset - Q\r\n else\r\n X := AvailableRect.Left + AOffset;\r\n Y := AvailableRect.Top + ((AvailableRect.Bottom - AvailableRect.Top - ArrowSize) div 2) + 1;\r\n for I := Y + ArrowSize - 1 downto Y do\r\n begin\r\n for J := X to X + Q - 1 do\r\n ACanvas.Pixels[J, I] := Color;\r\n Inc(X);\r\n Dec(Q, 2);\r\n end;\r\n end;\r\n else // alBottom\r\n if AOffset < 0 then\r\n X := AvailableRect.Right + AOffset - Q\r\n else\r\n X := AvailableRect.Left + AOffset;\r\n Y := AvailableRect.Top + ((AvailableRect.Bottom - AvailableRect.Top - ArrowSize) div 2) + 1;\r\n for I := Y to Y + ArrowSize - 1 do\r\n begin\r\n for J := X to X + Q - 1 do\r\n ACanvas.Pixels[J, I] := Color;\r\n Inc(X);\r\n Dec(Q, 2);\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomNetscapeSplitter.FindControl;\r\nvar\r\n P: TPoint;\r\n I: Integer;\r\n R: TRect;\r\nbegin\r\n if Parent = nil then\r\n Exit;\r\n FControl := nil;\r\n P := Point(Left, Top);\r\n case Align of\r\n alLeft:\r\n Dec(P.X);\r\n alRight:\r\n Inc(P.X, Width);\r\n alTop:\r\n Dec(P.Y);\r\n alBottom:\r\n Inc(P.Y, Height);\r\n else\r\n Exit;\r\n end;\r\n for I := 0 to Parent.ControlCount - 1 do\r\n begin\r\n FControl := Parent.Controls[I];\r\n if FControl.Visible and FControl.Enabled then\r\n begin\r\n R := FControl.BoundsRect;\r\n if (R.Right - R.Left) = 0 then\r\n Dec(R.Left);\r\n if (R.Bottom - R.Top) = 0 then\r\n Dec(R.Top);\r\n if PtInRect(R, P) then\r\n Exit;\r\n end;\r\n end;\r\n FControl := nil;\r\nend;\r\n\r\nfunction TJvCustomNetscapeSplitter.GetAlign: TAlign;\r\nbegin\r\n Result := inherited Align;\r\nend;\r\n\r\nfunction TJvCustomNetscapeSplitter.GetButtonRect: TRect;\r\nvar\r\n BW: Integer;\r\nbegin\r\n if ButtonStyle = bsWindows then\r\n begin\r\n if Align in [alLeft, alRight] then\r\n BW := (ClientRect.Right - ClientRect.Left) * VisibleWinButtons\r\n else\r\n BW := (ClientRect.Bottom - ClientRect.Top) * VisibleWinButtons;\r\n if BW < 1 then\r\n SetRectEmpty(Result)\r\n else\r\n begin\r\n if Align in [alLeft, alRight] then\r\n Result := Rect(0, 0, ClientRect.Right - ClientRect.Left,\r\n BW - VisibleWinButtons)\r\n else\r\n Result := Rect(ClientRect.Right - BW + VisibleWinButtons, 0,\r\n ClientRect.Right, ClientRect.Bottom - ClientRect.Top);\r\n InflateRect(Result, -1, -1);\r\n end;\r\n end\r\n else\r\n begin\r\n // Calc the rectangle the button goes in\r\n if ButtonWidthKind = btwPercentage then\r\n begin\r\n if Align in [alLeft, alRight] then\r\n BW := ClientRect.Bottom - ClientRect.Top\r\n else\r\n BW := ClientRect.Right - ClientRect.Left;\r\n BW := MulDiv(BW, FButtonWidth, 100);\r\n end\r\n else\r\n BW := FButtonWidth;\r\n if BW < 1 then\r\n SetRectEmpty(Result)\r\n else\r\n begin\r\n Result := ClientRect;\r\n if Align in [alLeft, alRight] then\r\n begin\r\n Result.Top := (ClientRect.Bottom - ClientRect.Top - BW) div 2;\r\n Result.Bottom := Result.Top + BW;\r\n InflateRect(Result, -1, 0);\r\n end\r\n else\r\n begin\r\n Result.Left := (ClientRect.Right - ClientRect.Left - BW) div 2;\r\n Result.Right := Result.Left + BW;\r\n InflateRect(Result, 0, -1);\r\n end;\r\n end;\r\n end;\r\n if not IsRectEmpty(Result) then\r\n begin\r\n if Result.Top < 1 then\r\n Result.Top := 1;\r\n if Result.Left < 1 then\r\n Result.Left := 1;\r\n if Result.Bottom >= ClientRect.Bottom then\r\n Result.Bottom := ClientRect.Bottom - 1;\r\n if Result.Right >= ClientRect.Right then\r\n Result.Right := ClientRect.Right - 1;\r\n // Make smaller if it's beveled\r\n if Beveled then\r\n if Align in [alLeft, alRight] then\r\n InflateRect(Result, -3, 0)\r\n else\r\n InflateRect(Result, 0, -3);\r\n end;\r\n FLastKnownButtonRect := Result;\r\nend;\r\n\r\nfunction TJvCustomNetscapeSplitter.GrabBarColor: TColor;\r\nvar\r\n BeginRGB: array [0..2] of Byte;\r\n RGBDifference: array [0..2] of Integer;\r\n R, G, B: Byte;\r\n BeginColor, EndColor: TColor;\r\n NumberOfColors: Integer;\r\nbegin\r\n //Need to figure out how many colors available at runtime\r\n NumberOfColors := 256;\r\n\r\n BeginColor := clActiveCaption;\r\n EndColor := clBtnFace;\r\n\r\n BeginRGB[0] := GetRValue(ColorToRGB(BeginColor));\r\n BeginRGB[1] := GetGValue(ColorToRGB(BeginColor));\r\n BeginRGB[2] := GetBValue(ColorToRGB(BeginColor));\r\n\r\n RGBDifference[0] := GetRValue(ColorToRGB(EndColor)) - BeginRGB[0];\r\n RGBDifference[1] := GetGValue(ColorToRGB(EndColor)) - BeginRGB[1];\r\n RGBDifference[2] := GetBValue(ColorToRGB(EndColor)) - BeginRGB[2];\r\n\r\n R := BeginRGB[0] + MulDiv(180, RGBDifference[0], NumberOfColors - 1);\r\n G := BeginRGB[1] + MulDiv(180, RGBDifference[1], NumberOfColors - 1);\r\n B := BeginRGB[2] + MulDiv(180, RGBDifference[2], NumberOfColors - 1);\r\n\r\n Result := RGB(R, G, B);\r\nend;\r\n\r\nprocedure TJvCustomNetscapeSplitter.Loaded;\r\nbegin\r\n inherited Loaded;\r\n if FRestorePos = -1 then\r\n begin\r\n FindControl;\r\n if FControl <> nil then\r\n case Align of\r\n alLeft, alRight:\r\n FRestorePos := FControl.Width;\r\n alTop, alBottom:\r\n FRestorePos := FControl.Height;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomNetscapeSplitter.LoadOtherProperties(Reader: TReader);\r\nbegin\r\n RestorePos := Reader.ReadInteger;\r\nend;\r\n\r\nprocedure TJvCustomNetscapeSplitter.PaintButton(Highlight: Boolean);\r\nconst\r\n TEXTURE_SIZE = 3;\r\nvar\r\n BtnRect: TRect;\r\n CaptionBtnRect: TRect;\r\n BW: Integer;\r\n TextureBmp: TBitmap;\r\n X, Y: Integer;\r\n RW, RH: Integer;\r\n OffscreenBmp: TBitmap;\r\n WinButton: array [0..2] of TJvWindowsButton;\r\n B: TJvWindowsButton;\r\n BtnFlag: UINT;\r\nbegin\r\n if (not FShowButton) or (not Enabled) or (GetParentForm(Self) = nil) then\r\n Exit;\r\n\r\n if FAutoHighlightColor then\r\n FButtonHighlightColor := GrabBarColor;\r\n\r\n BtnRect := ButtonRect; // So we don't repeatedly call GetButtonRect\r\n if IsRectEmpty(BtnRect) then\r\n Exit; // nothing to draw\r\n\r\n OffscreenBmp := TBitmap.Create;\r\n try\r\n OffsetRect(BtnRect, -BtnRect.Left, -BtnRect.Top);\r\n OffscreenBmp.Width := BtnRect.Right;\r\n OffscreenBmp.Height := BtnRect.Bottom;\r\n\r\n if ButtonStyle = bsWindows then\r\n begin\r\n OffscreenBmp.Canvas.Brush.Color := Color;\r\n OffscreenBmp.Canvas.FillRect(BtnRect);\r\n if Align in [alLeft, alRight] then\r\n BW := BtnRect.Right\r\n else\r\n BW := BtnRect.Bottom;\r\n FillChar(WinButton, SizeOf(WinButton), 0);\r\n X := 0;\r\n if Align in [alLeft, alRight] then\r\n begin\r\n for B := High(TJvWindowsButton) downto Low(TJvWindowsButton) do\r\n if B in WindowsButtons then\r\n begin\r\n WinButton[X] := B;\r\n Inc(X);\r\n end;\r\n end\r\n else\r\n begin\r\n for B := Low(TJvWindowsButton) to High(TJvWindowsButton) do\r\n if B in WindowsButtons then\r\n begin\r\n WinButton[X] := B;\r\n Inc(X);\r\n end;\r\n end;\r\n for X := 0 to VisibleWinButtons - 1 do\r\n begin\r\n if Align in [alLeft, alRight] then\r\n CaptionBtnRect := Bounds(0, X * BW, BW, BW)\r\n else\r\n CaptionBtnRect := Bounds(X * BW, 0, BW, BW);\r\n BtnFlag := 0;\r\n case WinButton[X] of\r\n wbMin:\r\n if Minimized then\r\n BtnFlag := DFCS_CAPTIONRESTORE\r\n else\r\n BtnFlag := DFCS_CAPTIONMIN;\r\n wbMax:\r\n if Maximized then\r\n BtnFlag := DFCS_CAPTIONRESTORE\r\n else\r\n BtnFlag := DFCS_CAPTIONMAX;\r\n wbClose:\r\n BtnFlag := DFCS_CAPTIONCLOSE;\r\n end;\r\n DrawFrameControl(OffscreenBmp.Canvas.Handle,\r\n CaptionBtnRect, DFC_CAPTION, BtnFlag);\r\n end;\r\n end\r\n else\r\n begin\r\n // Draw basic button\r\n OffscreenBmp.Canvas.Brush.Color := clGray;\r\n OffscreenBmp.Canvas.FrameRect(BtnRect);\r\n InflateRect(BtnRect, -1, -1);\r\n\r\n OffscreenBmp.Canvas.Pen.Color := clWhite;\r\n // This is not going to work with the STB bug. Have to find workaround.\r\n OffscreenBmp.Canvas.MoveTo(BtnRect.Left, BtnRect.Bottom - 1);\r\n OffscreenBmp.Canvas.LineTo(BtnRect.Left, BtnRect.Top);\r\n OffscreenBmp.Canvas.LineTo(BtnRect.Right, BtnRect.Top);\r\n\r\n Inc(BtnRect.Left);\r\n Inc(BtnRect.Top);\r\n\r\n if Highlight then\r\n OffscreenBmp.Canvas.Brush.Color := ButtonHighlightColor\r\n else\r\n OffscreenBmp.Canvas.Brush.Color := ButtonColor;\r\n OffscreenBmp.Canvas.FillRect(BtnRect);\r\n FIsHighlighted := Highlight;\r\n Dec(BtnRect.Right);\r\n Dec(BtnRect.Bottom);\r\n\r\n // Draw the insides of the button\r\n // Draw the arrows\r\n if Align in [alLeft, alRight] then\r\n begin\r\n InflateRect(BtnRect, 0, -4);\r\n BW := BtnRect.Right - BtnRect.Left;\r\n DrawArrow(OffscreenBmp.Canvas, BtnRect, 1, BW, ArrowColor);\r\n BW := DrawArrow(OffscreenBmp.Canvas, BtnRect, -1, BW, ArrowColor);\r\n InflateRect(BtnRect, 0, -(BW + 4));\r\n end\r\n else\r\n begin\r\n InflateRect(BtnRect, -4, 0);\r\n BW := BtnRect.Bottom - BtnRect.Top;\r\n DrawArrow(OffscreenBmp.Canvas, BtnRect, 1, BW, ArrowColor);\r\n BW := DrawArrow(OffscreenBmp.Canvas, BtnRect, -1, BW, ArrowColor);\r\n InflateRect(BtnRect, -(BW + 4), 0);\r\n end;\r\n\r\n // Draw the texture\r\n // Note: This is so complex because I'm trying to make as much like the\r\n // Netscape splitter as possible. They use a 3x3 texture pattern, and\r\n // that's harder to tile. If the had used an 8x8 (or smaller\r\n // divisibly, i.e. 2x2 or 4x4), I could have used Brush.Bitmap and\r\n // FillRect and they whole thing would have been about half the size,\r\n // twice as fast, and 1/10th as complex.\r\n RW := BtnRect.Right - BtnRect.Left;\r\n RH := BtnRect.Bottom - BtnRect.Top;\r\n if (RW >= TEXTURE_SIZE) and (RH >= TEXTURE_SIZE) then\r\n begin\r\n TextureBmp := TBitmap.Create;\r\n try\r\n with TextureBmp do\r\n begin\r\n Width := RW;\r\n Height := RH;\r\n // Draw first square\r\n Canvas.Brush.Color := OffscreenBmp.Canvas.Brush.Color;\r\n Canvas.FillRect(Rect(0, 0, RW + 1, RH + 1));\r\n Canvas.Pixels[1, 1] := TextureColor1;\r\n Canvas.Pixels[2, 2] := TextureColor2;\r\n\r\n // Tile first square all the way across\r\n for X := 1 to ((RW div TEXTURE_SIZE) + ord(RW mod TEXTURE_SIZE > 0)) do\r\n Canvas.CopyRect(Bounds(X * TEXTURE_SIZE, 0, TEXTURE_SIZE,\r\n TEXTURE_SIZE), Canvas, Rect(0, 0, TEXTURE_SIZE, TEXTURE_SIZE));\r\n\r\n // Tile first row all the way down\r\n for Y := 1 to ((RH div TEXTURE_SIZE) + ord(RH mod TEXTURE_SIZE > 0)) do\r\n Canvas.CopyRect(Bounds(0, Y * TEXTURE_SIZE, RW, TEXTURE_SIZE),\r\n Canvas, Rect(0, 0, RW, TEXTURE_SIZE));\r\n\r\n // Above could be better if it reversed process when splitter was\r\n // taller than it was wider. Optimized only for horizontal right now.\r\n end;\r\n // Copy texture bitmap to the screen.\r\n OffscreenBmp.Canvas.CopyRect(BtnRect, TextureBmp.Canvas,\r\n Rect(0, 0, RW, RH));\r\n finally\r\n TextureBmp.Free;\r\n end;\r\n end;\r\n end;\r\n(**)\r\n Canvas.CopyRect(ButtonRect, OffscreenBmp.Canvas, Rect(0, 0,\r\n OffscreenBmp.Width, OffscreenBmp.Height));\r\n finally\r\n OffscreenBmp.Free;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomNetscapeSplitter.SetAlign(Value: TAlign);\r\nbegin\r\n if Align <> Value then\r\n begin\r\n inherited Align := Value;\r\n Invalidate; // Direction changing, redraw arrows.\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomNetscapeSplitter.SetAllowDrag(const Value: Boolean);\r\nvar\r\n Pt: TPoint;\r\nbegin\r\n if FAllowDrag <> Value then\r\n begin\r\n FAllowDrag := Value;\r\n // Have to reset cursor in case it's on the splitter at the moment\r\n GetCursorPos(Pt);\r\n Pt := ScreenToClient(Pt);\r\n ButtonHitTest(Pt.X, Pt.Y);\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomNetscapeSplitter.SetArrowColor(const Value: TColor);\r\nbegin\r\n if FArrowColor <> Value then\r\n begin\r\n FArrowColor := Value;\r\n if (ButtonStyle = bsNetscape) and ShowButton then\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomNetscapeSplitter.SetAutoHighlightColor(const Value: Boolean);\r\nbegin\r\n if FAutoHighlightColor <> Value then\r\n begin\r\n FAutoHighlightColor := Value;\r\n if FAutoHighlightColor then\r\n FButtonHighlightColor := GrabBarColor\r\n else\r\n FButtonHighlightColor := JvDefaultButtonHighlightColor;\r\n if (ButtonStyle = bsNetscape) and ShowButton then\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomNetscapeSplitter.SetButtonColor(const Value: TColor);\r\nbegin\r\n if FButtonColor <> Value then\r\n begin\r\n FButtonColor := Value;\r\n if (ButtonStyle = bsNetscape) and ShowButton then\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomNetscapeSplitter.SetButtonCursor(const Value: TCursor);\r\nbegin\r\n FButtonCursor := Value;\r\nend;\r\n\r\nprocedure TJvCustomNetscapeSplitter.SetButtonHighlightColor(const Value: TColor);\r\nbegin\r\n if FButtonHighlightColor <> Value then\r\n begin\r\n FButtonHighlightColor := Value;\r\n if (ButtonStyle = bsNetscape) and ShowButton then\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomNetscapeSplitter.SetButtonStyle(const Value: TJvButtonStyle);\r\nbegin\r\n FButtonStyle := Value;\r\n if ShowButton then\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvCustomNetscapeSplitter.SetButtonWidth(const Value: Integer);\r\nbegin\r\n if Value <> FButtonWidth then\r\n begin\r\n FButtonWidth := Value;\r\n if (ButtonWidthKind = btwPercentage) and (FButtonWidth > 100) then\r\n FButtonWidth := 100;\r\n if FButtonWidth < 0 then\r\n FButtonWidth := 0;\r\n if (ButtonStyle = bsNetscape) and ShowButton then\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomNetscapeSplitter.SetButtonWidthKind(const Value: TJvButtonWidthKind);\r\nbegin\r\n if Value <> FButtonWidthKind then\r\n begin\r\n FButtonWidthKind := Value;\r\n if (FButtonWidthKind = btwPercentage) and (ButtonWidth > 100) then\r\n FButtonWidth := 100;\r\n if (ButtonStyle = bsNetscape) and ShowButton then\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomNetscapeSplitter.SetMaximized(const Value: Boolean);\r\nbegin\r\n if Value <> FMaximized then\r\n begin\r\n if csLoading in ComponentState then\r\n begin\r\n FMaximized := Value;\r\n Exit;\r\n end;\r\n\r\n FindControl;\r\n if FControl = nil then\r\n Exit;\r\n\r\n if Value then\r\n begin\r\n if FMinimized then\r\n FMinimized := False\r\n else\r\n begin\r\n case Align of\r\n alLeft, alRight:\r\n FRestorePos := FControl.Width;\r\n alTop, alBottom:\r\n FRestorePos := FControl.Height;\r\n else\r\n Exit;\r\n end;\r\n end;\r\n if ButtonStyle = bsNetscape then\r\n UpdateControlSize(-3000)\r\n else\r\n case Align of\r\n alLeft, alBottom:\r\n UpdateControlSize(3000);\r\n alRight, alTop:\r\n UpdateControlSize(-3000);\r\n else\r\n Exit;\r\n end;\r\n FMaximized := Value;\r\n DoMaximize;\r\n end\r\n else\r\n begin\r\n UpdateControlSize(FRestorePos);\r\n FMaximized := Value;\r\n DoRestore;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomNetscapeSplitter.SetMinimized(const Value: Boolean);\r\nbegin\r\n if Value <> FMinimized then\r\n begin\r\n if csLoading in ComponentState then\r\n begin\r\n FMinimized := Value;\r\n Exit;\r\n end;\r\n\r\n FindControl;\r\n if FControl = nil then\r\n Exit;\r\n\r\n if Value then\r\n begin\r\n if FMaximized then\r\n FMaximized := False\r\n else\r\n begin\r\n case Align of\r\n alLeft, alRight:\r\n FRestorePos := FControl.Width;\r\n alTop, alBottom:\r\n FRestorePos := FControl.Height;\r\n else\r\n Exit;\r\n end;\r\n end;\r\n FMinimized := Value;\r\n // Just use something insanely large to get it to move to the other extreme\r\n case Align of\r\n alLeft, alBottom:\r\n UpdateControlSize(-3000);\r\n alRight, alTop:\r\n UpdateControlSize(3000);\r\n else\r\n Exit;\r\n end;\r\n DoMinimize;\r\n end\r\n else\r\n begin\r\n FMinimized := Value;\r\n UpdateControlSize(FRestorePos);\r\n DoRestore;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomNetscapeSplitter.SetShowButton(const Value: Boolean);\r\nbegin\r\n if Value <> FShowButton then\r\n begin\r\n FShowButton := Value;\r\n SetRectEmpty(FLastKnownButtonRect);\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomNetscapeSplitter.SetTextureColor1(const Value: TColor);\r\nbegin\r\n if FTextureColor1 <> Value then\r\n begin\r\n FTextureColor1 := Value;\r\n if (ButtonStyle = bsNetscape) and ShowButton then\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomNetscapeSplitter.SetTextureColor2(const Value: TColor);\r\nbegin\r\n if FTextureColor2 <> Value then\r\n begin\r\n FTextureColor2 := Value;\r\n if (ButtonStyle = bsNetscape) and ShowButton then\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomNetscapeSplitter.SetWindowsButtons(const Value: TJvWindowsButtons);\r\nbegin\r\n FWindowsButtons := Value;\r\n if (ButtonStyle = bsWindows) and ShowButton then\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvCustomNetscapeSplitter.StoreOtherProperties(Writer: TWriter);\r\nbegin\r\n Writer.WriteInteger(RestorePos);\r\nend;\r\n\r\nprocedure TJvCustomNetscapeSplitter.UpdateControlSize(NewSize: Integer);\r\n\r\n procedure MoveViaMouse(FromPos, ToPos: Integer; Horizontal: Boolean);\r\n begin\r\n if Horizontal then\r\n begin\r\n MouseDown(mbLeft, [ssLeft], FromPos, 0);\r\n MouseMove([ssLeft], ToPos, 0);\r\n MouseUp(mbLeft, [ssLeft], ToPos, 0);\r\n end\r\n else\r\n begin\r\n MouseDown(mbLeft, [ssLeft], 0, FromPos);\r\n MouseMove([ssLeft], 0, ToPos);\r\n MouseUp(mbLeft, [ssLeft], 0, ToPos);\r\n end;\r\n end;\r\n\r\nbegin\r\n if FControl <> nil then\r\n begin\r\n { You'd think that using FControl directly would be the way to change it's\r\n position (and thus the splitter's position), wouldn't you? But, TSplitter\r\n has this nutty idea that the only way a control's size will change is if\r\n the mouse moves the splitter. If you size the control manually, the\r\n splitter has an internal variable (FOldSize) that will not get updated.\r\n Because of this, if you try to then move the newly positioned splitter\r\n back to the old position, it won't go there (NewSize <> OldSize must be\r\n True). Now, what are the odds that the user will move the splitter back\r\n to the exact same pixel it used to be on? Normally, extremely low. But,\r\n if the splitter has been restored from it's minimized position, it then\r\n becomes quite likely: i.e. they drag it back all the way to the min\r\n position. What a pain. }\r\n case Align of\r\n alLeft:\r\n MoveViaMouse(Left, FControl.Left + NewSize, True);\r\n // alLeft: FControl.Width := NewSize;\r\n alTop:\r\n MoveViaMouse(Top, FControl.Top + NewSize, False);\r\n // FControl.Height := NewSize;\r\n alRight:\r\n MoveViaMouse(Left, (FControl.Left + FControl.Width - Width) - NewSize, True);\r\n {begin\r\n Parent.DisableAlign;\r\n try\r\n FControl.Left := FControl.Left + (FControl.Width - NewSize);\r\n FControl.Width := NewSize;\r\n finally\r\n Parent.EnableAlign;\r\n end;\r\n end;}\r\n alBottom:\r\n MoveViaMouse(Top, (FControl.Top + FControl.Height - Height) - NewSize, False);\r\n {begin\r\n Parent.DisableAlign;\r\n try\r\n FControl.Top := FControl.Top + (FControl.Height - NewSize);\r\n FControl.Height := NewSize;\r\n finally\r\n Parent.EnableAlign;\r\n end;\r\n end;}\r\n end;\r\n Update;\r\n end;\r\nend;\r\n\r\nfunction TJvCustomNetscapeSplitter.VisibleWinButtons: Integer;\r\nvar\r\n X: TJvWindowsButton;\r\nbegin\r\n Result := 0;\r\n for X := Low(TJvWindowsButton) to High(TJvWindowsButton) do\r\n if X in WindowsButtons then\r\n Inc(Result);\r\nend;\r\n\r\nfunction TJvCustomNetscapeSplitter.WindowButtonHitTest(X, Y: Integer): TJvWindowsButton;\r\nvar\r\n BtnRect: TRect;\r\n I: Integer;\r\n B: TJvWindowsButton;\r\n WinButton: array [0..2] of TJvWindowsButton;\r\n BW: Integer;\r\n BRs: array [0..2] of TRect;\r\nbegin\r\n Result := wbMin;\r\n // Figure out which one was hit. This function assumes ButtonHitTest has\r\n // been called and returned True.\r\n BtnRect := ButtonRect; // So we don't repeatedly call GetButtonRect\r\n I := 0;\r\n if Align in [alLeft, alRight] then\r\n begin\r\n for B := High(TJvWindowsButton) downto Low(TJvWindowsButton) do\r\n if B in WindowsButtons then\r\n begin\r\n WinButton[I] := B;\r\n Inc(I);\r\n end;\r\n end\r\n else\r\n for B := Low(TJvWindowsButton) to High(TJvWindowsButton) do\r\n if B in WindowsButtons then\r\n begin\r\n WinButton[I] := B;\r\n Inc(I);\r\n end;\r\n\r\n if Align in [alLeft, alRight] then\r\n BW := BtnRect.Right - BtnRect.Left\r\n else\r\n BW := BtnRect.Bottom - BtnRect.Top;\r\n FillChar(BRs, SizeOf(BRs), 0);\r\n for I := 0 to VisibleWinButtons - 1 do\r\n if ((Align in [alLeft, alRight]) and PtInRect(Bounds(BtnRect.Left,\r\n BtnRect.Top + (BW * I), BW, BW), Point(X, Y))) or ((Align in [alTop,\r\n alBottom]) and PtInRect(Bounds(BtnRect.Left + (BW * I), BtnRect.Top, BW,\r\n BW), Point(X, Y))) then\r\n begin\r\n Result := WinButton[I];\r\n break;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomNetscapeSplitter.SetBounds(ALeft, ATop, AWidth, AHeight: Integer);\r\nbegin\r\n inherited SetBounds(ALeft, ATop, AWidth, AHeight);\r\n if FRestorePos < 0 then\r\n begin\r\n FindControl;\r\n if FControl <> nil then\r\n case Align of\r\n alLeft, alRight:\r\n FRestorePos := FControl.Width;\r\n alTop, alBottom:\r\n FRestorePos := FControl.Height;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomNetscapeSplitter.WMLButtonDown(var Msg: TWMLButtonDown);\r\nbegin\r\n if Enabled then\r\n begin\r\n FGotMouseDown := ButtonHitTest(Msg.XPos, Msg.YPos);\r\n if FGotMouseDown then\r\n begin\r\n FindControl;\r\n FDownPos := ClientToScreen(Point(Msg.XPos, Msg.YPos));\r\n end;\r\n end;\r\n if AllowDrag then\r\n inherited // Let TSplitter have it.\r\n else\r\n // Bypass TSplitter and just let normal handling occur. Prevents drag painting.\r\n DefaultHandler(Msg);\r\nend;\r\n\r\nprocedure TJvCustomNetscapeSplitter.WMLButtonUp(var Msg: TWMLButtonUp);\r\nvar\r\n CurPos: TPoint;\r\n OldMax: Boolean;\r\nbegin\r\n inherited;\r\n\r\n if FGotMouseDown then\r\n begin\r\n if ButtonHitTest(Msg.XPos, Msg.YPos) then\r\n begin\r\n CurPos := ClientToScreen(Point(Msg.XPos, Msg.YPos));\r\n // More than a little movement is not a click, but a regular resize.\r\n if ((Align in [alLeft, alRight]) and\r\n (Abs(FDownPos.X - CurPos.X) <= MOVEMENT_TOLERANCE)) or\r\n ((Align in [alTop, alBottom]) and\r\n (Abs(FDownPos.Y - CurPos.Y) <= MOVEMENT_TOLERANCE)) then\r\n begin\r\n StopSizing;\r\n if ButtonStyle = bsNetscape then\r\n Maximized := not Maximized\r\n else\r\n case WindowButtonHitTest(Msg.XPos, Msg.YPos) of\r\n wbMin:\r\n Minimized := not Minimized;\r\n wbMax:\r\n Maximized := not Maximized;\r\n wbClose:\r\n DoClose;\r\n end;\r\n end;\r\n end;\r\n FGotMouseDown := False;\r\n end\r\n else\r\n if AllowDrag then\r\n begin\r\n FindControl;\r\n if FControl = nil then\r\n Exit;\r\n\r\n OldMax := FMaximized;\r\n case Align of\r\n alLeft, alRight:\r\n FMaximized := FControl.Width <= MinSize;\r\n alTop, alBottom:\r\n FMaximized := FControl.Height <= MinSize;\r\n end;\r\n if FMaximized then\r\n begin\r\n UpdateControlSize(MinSize);\r\n if not OldMax then\r\n DoMaximize;\r\n end\r\n else\r\n begin\r\n case Align of\r\n alLeft, alRight:\r\n FRestorePos := FControl.Width;\r\n alTop, alBottom:\r\n FRestorePos := FControl.Height;\r\n end;\r\n if OldMax then\r\n DoRestore;\r\n end;\r\n end;\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvCustomNetscapeSplitter.WMMouseMove(var Msg: TWMMouseMove);\r\nbegin\r\n if AllowDrag then\r\n begin\r\n inherited;\r\n end\r\n else\r\n begin\r\n DefaultHandler(Msg); // Bypass TSplitter and just let normal handling occur.\r\n end;\r\n\r\n // Mantis 3718: The button is always highlighted whatever value AllowDrag is.\r\n\r\n // The order is important here. ButtonHitTest must be evaluated before\r\n // the ButtonStyle because it will change the cursor (over button or not).\r\n // If the order were reversed, the cursor would not get set for bsWindows\r\n // style since short-circuit Boolean eval would stop it from ever being\r\n // called in the first place.\r\n if ButtonHitTest(Msg.XPos, Msg.YPos) and (ButtonStyle = bsNetscape) then\r\n begin\r\n if not FIsHighlighted then\r\n PaintButton(True)\r\n end\r\n else\r\n if FIsHighlighted then\r\n PaintButton(False);\r\nend;\r\n\r\nprocedure TJvCustomNetscapeSplitter.WMDblClick(var Msg: TWMLButtonDBLCLK);\r\nbegin\r\n if ButtonHitTest(Msg.XPos, Msg.YPos) and (ButtonStyle = bsNetscape) then\r\n begin //Double click in button\r\n if Assigned (FOnButtonDblClick) then\r\n FOnButtonDblClick(Self)\r\n else\r\n inherited;\r\n end\r\n else\r\n begin //Double on body splitter line\r\n if Assigned (FOnLineDblClick) then\r\n FOnLineDblClick(Self)\r\n else\r\n inherited;\r\n end;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvObjectPickerDialog.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvObjPickerComp.PAS, released on 2002-06-24.\r\n\r\nThe Initial Developer of the Original Code is Marcel van Brakel [brakelm att chello dott nl]\r\nPortions created by Marcel van Brakel are Copyright (C) 2002 Marcel van Brakel.\r\nAll Rights Reserved.\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n TODO OWNER\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvObjectPickerDialog.pas 13352 2012-06-14 09:21:26Z obones $\r\n\r\nunit JvObjectPickerDialog;\r\n\r\n{$I jvcl.inc}\r\n{$I windowsonly.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, ActiveX, ComObj, SysUtils, Classes,\r\n ObjSel,\r\n JvBaseDlg, JvTypes;\r\n\r\n// (rom) Jv the type names?\r\ntype\r\n // indicates the type of scope\r\n TScopeType = (\r\n stTargetComputer,\r\n stUpLevelJoinedDomain, // an uplevel domain joined by the target computer\r\n stDownLevelJoinedDomain, // a downlevel domain joined by the target computer\r\n stEnterpriseDomain, // all Windows 2000 domains of which the target computer is a member\r\n stGlobalCatalog, // all domains in the enterprise\r\n stExternalUpLevelDomain, // all trusted, uplevel domains external to the enterprise\r\n stExternalDownLevelDomain, // all trusted, downlevel domains external to the enterprise\r\n stWorkGroup, // a workgroup joined by the target computer\r\n stUserEnteredUpLevelScope, // enables the user to enter an up level scope\r\n stUserEnteredDownLevelScope); // enables the user to enter a down level scope\r\n TScopeTypes = set of TScopeType;\r\n\r\n TScopeFlag = (\r\n sfStartingScope, // scope should be initially selected (only one scope can have this flag set)\r\n sfProviderWinNT, // ADSPath is converted to use the WinNT provider\r\n sfProviderLDAP, // ADSPath is converted to use the LDAP provider\r\n sfProviderGC, // ADSPath is converted to use the GC provider\r\n sfSidPath, // ADSPath with an objectSID attribute are converted to the form LDAP://\r\n sfDownLevelBuiltInPath); // If not specified, ADSPath for downlevel, well-known objects are empty\r\n TScopeFlags = set of TScopeFlag;\r\n\r\n // up level filter flags. if a flag is set, the object picker includes the specified object when the scope is\r\n // selected. e.g. if ulUsers is included, users are displayed..\r\n\r\n TUpLevelFilter = (\r\n ulIncludeAdvancedView,\r\n ulUsers,\r\n ulBuiltInGroups,\r\n ulWellKnownPrincipals,\r\n ulUniversalDistributionListGroups,\r\n ulUniversalSecurityGroups,\r\n ulGlobalDistributionListGroups,\r\n ulGlobalSecurityGroups,\r\n ulDomainLocalDistributionListGroups,\r\n ulDomainLocalSecurityGroups,\r\n ulContacts,\r\n ulComputers);\r\n TUpLevelFilters = set of TUpLevelFilter;\r\n\r\n // down level filter flags. if a flag is set, the object picker includes the specified object when the scope is\r\n // selected. e.g. if ulUsers is included, users are displayed..\r\n\r\n TDownLevelFilter = (\r\n dlUsers,\r\n dlLocalGroups,\r\n dlGlobalGroups,\r\n dlComputers,\r\n dlWorld,\r\n dlAuthenticatedUser,\r\n dlAnonymous,\r\n dlBatch,\r\n dlCreatorOwner,\r\n dlCreatorGroup,\r\n dlDialUp,\r\n dlInteractive,\r\n dlNetwork,\r\n dlService,\r\n dlSystem,\r\n dlExcludeBuiltinGroups,\r\n dlTerminalServer,\r\n dlAllWellKnownSids,\r\n dlLocalService,\r\n dlNetworkService,\r\n dlRemoteLogon);\r\n TDownLevelFilters = set of TDownLevelFilter;\r\n\r\n // represents a single scope and it's associated filter\r\n\r\n TObjectPickerScope = class(TCollectionItem)\r\n private\r\n FDownLevelFilter: TDownLevelFilters;\r\n FDcName: string;\r\n FResult: HRESULT;\r\n FScopeTypes: TScopeTypes;\r\n FScopeFlags: TScopeFlags;\r\n FUpLevelFilterBoth: TUpLevelFilters;\r\n FUpLevelFilterNative: TUpLevelFilters;\r\n FUpLevelFilterMixed: TUpLevelFilters;\r\n public\r\n procedure Assign(Source: TPersistent); override;\r\n published\r\n // filter flags for down level scopes\r\n property DownLevelFilter: TDownLevelFilters read FDownLevelFilter write\r\n FDownLevelFilter default [];\r\n // name of a domain controller of the domain which the target computer is a member of, can be empty\r\n property DcName: string read FDcName write FDcName;\r\n // indicates whether this scope was succesfully initialized\r\n property Result: HRESULT read FResult default S_OK;\r\n // the type of scope (e.g. enterprise domain, global catalog or computer)\r\n property ScopeTypes: TScopeTypes read FScopeTypes write FScopeTypes default [];\r\n // flags that indicate the format of the returned ADSPath and whether this scope should be initially selected\r\n property ScopeFlags: TScopeFlags read FScopeFlags write FScopeFlags default [];\r\n // filter flags for up level scope in either mode (native or mixed)\r\n property UpLevelFilterBoth: TUpLevelFilters read FUpLevelFilterBoth write\r\n FUpLevelFilterBoth default [];\r\n // filter flags for up level scope in native mode\r\n property UpLevelFilterNative: TUpLevelFilters read FUpLevelFilterNative write\r\n FUpLevelFilterNative default [];\r\n // filter flags for up level scope in mixed mode\r\n property UpLevelFilterMixed: TUpLevelFilters read FUpLevelFilterMixed write\r\n FUpLevelFilterMixed default [];\r\n end;\r\n\r\n // list of scopes\r\n\r\n TObjectPickerScopes = class(TCollection)\r\n private\r\n //OWNER FOwner: TComponent;\r\n function GetItem(Index: Integer): TObjectPickerScope;\r\n procedure SetItem(Index: Integer; Value: TObjectPickerScope);\r\n protected\r\n procedure Initialize(var ScopesInitInfo: array of TDsOpScopeInitInfo);\r\n public\r\n constructor Create({OWNER AOwner: TComponent});\r\n // adds a scope\r\n function Add: TObjectPickerScope;\r\n // assigns a scope\r\n procedure Assign(Source: TPersistent); override;\r\n // the owner of this class\r\n //OWNER function Owner: TComponent;\r\n // list of scopes\r\n property Items[Index: Integer]: TObjectPickerScope read GetItem write SetItem; default;\r\n end;\r\n\r\n TObjectPickerSelection = class(TObject)\r\n private\r\n FAttributeCount: Integer;\r\n FSelection: PDsSelection;\r\n function GetAttribute(Index: Integer): OleVariant;\r\n function GetAdsPath: string;\r\n function GetName: string;\r\n function GetObjectClass: string;\r\n function GetScopeTypes: TScopeTypes;\r\n function GetUPN: string;\r\n public\r\n constructor Create(Selection: PDsSelection; const AttributeCount: Integer);\r\n // the Relative Distinquishged Name (RDN) of the object\r\n property Name: string read GetName;\r\n // the object's ADSPath. format depends on what flags you specified for the scope the object was selected from\r\n property AdsPath: string read GetAdsPath;\r\n // the class of the object (objectClass attribute)\r\n property ObjectClass: string read GetObjectClass;\r\n // the object's userPrincipalName attribute, or an empty string if it doesn't have a UPN attribute\r\n property UPN: string read GetUPN;\r\n // specifies the scope the object was selected from\r\n property ScopeType: TScopeTypes read GetScopeTypes;\r\n // the number of entrie sin the Attributes list\r\n property AttributeCount: Integer read FAttributeCount;\r\n // list of attribute values, one for each requested attribute (in the same order as requested). if an attribute\r\n // couldn't be retrieved the element contains an empty variant (use f.e. VarIsEmpty to test).\r\n property Attributes[Index: Integer]: OleVariant read GetAttribute;\r\n end;\r\n\r\n // class encapsulating the selection list. it contains the list of selected objects\r\n\r\n TObjectPickerSelections = class(TObject)\r\n private\r\n FItems: array of TObjectPickerSelection;\r\n FMedium: TStgMedium;\r\n FSelections: PDsSelectionList;\r\n function GetAttributeCount: Integer;\r\n function GetItem(Index: Integer): TObjectPickerSelection;\r\n function GetCount: Integer;\r\n protected\r\n procedure FreeSelection;\r\n procedure SetSelection(const DataObj: IDataObject);\r\n public\r\n destructor Destroy; override;\r\n // the number of attributes retrieved for each selected object (also avail. as TObjectPickerSelection.AttributeCount)\r\n property AttributeCount: Integer read GetAttributeCount;\r\n // the number of entries in the Items list\r\n property Count: Integer read GetCount;\r\n // list of objects, each represents a single selected object\r\n property Items[Index: Integer]: TObjectPickerSelection read GetItem;\r\n default;\r\n end;\r\n\r\n // Global Object Picker options\r\n\r\n TObjectPickerOption = (opAllowMultiSelect, // allow selection of multiple objects\r\n opSkipTargetComputerDCCheck); // skip DC check if target computer is a domain controller\r\n TObjectPickerOptions = set of TObjectPickerOption;\r\n\r\n // the Object Picker dialog component\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvObjectPickerDialog = class(TJvCommonDialog)\r\n private\r\n FAttributes: TStringList;\r\n FObjectPicker: IDsObjectPicker;\r\n FOptions: TObjectPickerOptions;\r\n FScopes: TObjectPickerScopes;\r\n FSelection: TObjectPickerSelections;\r\n FTargetComputer: string;\r\n function GetAttributes: TStrings;\r\n procedure SetAttributes(Value: TStrings);\r\n procedure SetScopes(Value: TObjectPickerScopes);\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n // executes (displays) the object picker dialog\r\n function Execute(ParentWnd: HWND): Boolean; overload; override;\r\n // resets the object picker. clears all options, scopes and attributes\r\n procedure Reset;\r\n // the list of selected objects is available through this class\r\n property Selection: TObjectPickerSelections read FSelection;\r\n published\r\n // list of additional attributes the Object Picker should retrieve for all selected objects\r\n property Attributes: TStrings read GetAttributes write SetAttributes;\r\n // global options, see TObjectPickerOptions\r\n property Options: TObjectPickerOptions read FOptions write FOptions default [];\r\n // the available scopes and their filters\r\n property Scopes: TObjectPickerScopes read FScopes write SetScopes;\r\n // the target computer the Object Picker uses to determine the joined domain and enterprise. the Object Picker\r\n // behaves as if it's running on the specified computer. leave empty for the local computer.\r\n property TargetComputer: string read FTargetComputer write FTargetComputer;\r\n end;\r\n\r\n // object picker exception class\r\n // just to be able to distinguish between exceptions raised by the Object Picker specifically and all others\r\n EObjectPickerError = class(EJVCLException);\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvObjectPickerDialog.pas $';\r\n Revision: '$Revision: 13352 $';\r\n Date: '$Date: 2012-06-14 11:21:26 +0200 (jeu. 14 juin 2012) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n Forms,\r\n JvResources;\r\n\r\nfunction ScopeTypesToOrdinal(const ScopeTypes: TScopeTypes): Cardinal;\r\nbegin\r\n Result := 0;\r\n if stTargetComputer in ScopeTypes then\r\n Result := Result or DSOP_SCOPE_TYPE_TARGET_COMPUTER;\r\n if stUpLevelJoinedDomain in ScopeTypes then\r\n Result := Result or DSOP_SCOPE_TYPE_UPLEVEL_JOINED_DOMAIN;\r\n if stDownLevelJoinedDomain in ScopeTypes then\r\n Result := Result or DSOP_SCOPE_TYPE_DOWNLEVEL_JOINED_DOMAIN;\r\n if stEnterpriseDomain in ScopeTypes then\r\n Result := Result or DSOP_SCOPE_TYPE_ENTERPRISE_DOMAIN;\r\n if stGlobalCatalog in ScopeTypes then\r\n Result := Result or DSOP_SCOPE_TYPE_GLOBAL_CATALOG;\r\n if stExternalUpLevelDomain in ScopeTypes then\r\n Result := Result or DSOP_SCOPE_TYPE_EXTERNAL_UPLEVEL_DOMAIN;\r\n if stExternalDownLevelDomain in ScopeTypes then\r\n Result := Result or DSOP_SCOPE_TYPE_EXTERNAL_DOWNLEVEL_DOMAIN;\r\n if stWorkGroup in ScopeTypes then\r\n Result := Result or DSOP_SCOPE_TYPE_WORKGROUP;\r\n if stUserEnteredUpLevelScope in ScopeTypes then\r\n Result := Result or DSOP_SCOPE_TYPE_USER_ENTERED_UPLEVEL_SCOPE;\r\n if stUserEnteredDownLevelScope in ScopeTypes then\r\n Result := Result or DSOP_SCOPE_TYPE_USER_ENTERED_DOWNLEVEL_SCOPE;\r\nend;\r\n\r\nfunction OrdinalToScopeTypes(const Ordinal: Cardinal): TScopeTypes;\r\nbegin\r\n Result := [];\r\n if (Ordinal and DSOP_SCOPE_TYPE_TARGET_COMPUTER) <> 0 then\r\n Include(Result, stTargetComputer);\r\n if (Ordinal and DSOP_SCOPE_TYPE_UPLEVEL_JOINED_DOMAIN) <> 0 then\r\n Include(Result, stUpLevelJoinedDomain);\r\n if (Ordinal and DSOP_SCOPE_TYPE_DOWNLEVEL_JOINED_DOMAIN) <> 0 then\r\n Include(Result, stDownLevelJoinedDomain);\r\n if (Ordinal and DSOP_SCOPE_TYPE_ENTERPRISE_DOMAIN) <> 0 then\r\n Include(Result, stEnterpriseDomain);\r\n if (Ordinal and DSOP_SCOPE_TYPE_GLOBAL_CATALOG) <> 0 then\r\n Include(Result, stGlobalCatalog);\r\n if (Ordinal and DSOP_SCOPE_TYPE_EXTERNAL_UPLEVEL_DOMAIN) <> 0 then\r\n Include(Result, stExternalUpLevelDomain);\r\n if (Ordinal and DSOP_SCOPE_TYPE_EXTERNAL_DOWNLEVEL_DOMAIN) <> 0 then\r\n Include(Result, stExternalDownLevelDomain);\r\n if (Ordinal and DSOP_SCOPE_TYPE_WORKGROUP) <> 0 then\r\n Include(Result, stWorkGroup);\r\n if (Ordinal and DSOP_SCOPE_TYPE_USER_ENTERED_UPLEVEL_SCOPE) <> 0 then\r\n Include(Result, stUserEnteredUpLevelScope);\r\n if (Ordinal and DSOP_SCOPE_TYPE_USER_ENTERED_DOWNLEVEL_SCOPE) <> 0 then\r\n Include(Result, stUserEnteredDownLevelScope);\r\nend;\r\n\r\nfunction ScopeFlagsToOrdinal(const ScopeFlags: TScopeFlags): Cardinal;\r\nbegin\r\n Result := 0;\r\n if sfStartingScope in ScopeFlags then\r\n Result := Result or DSOP_SCOPE_FLAG_STARTING_SCOPE;\r\n if sfProviderWinNT in ScopeFlags then\r\n Result := Result or DSOP_SCOPE_FLAG_WANT_PROVIDER_WINNT;\r\n if sfProviderLDAP in ScopeFlags then\r\n Result := Result or DSOP_SCOPE_FLAG_WANT_PROVIDER_LDAP;\r\n if sfProviderGC in ScopeFlags then\r\n Result := Result or DSOP_SCOPE_FLAG_WANT_PROVIDER_GC;\r\n if sfSidPath in ScopeFlags then\r\n Result := Result or DSOP_SCOPE_FLAG_WANT_SID_PATH;\r\n if sfDownLevelBuiltInPath in ScopeFlags then\r\n Result := Result or DSOP_SCOPE_FLAG_WANT_DOWNLEVEL_BUILTIN_PATH;\r\n //DSOP_SCOPE_FLAG_DEFAULT_FILTER_USERS = $00000040;\r\n //DSOP_SCOPE_FLAG_DEFAULT_FILTER_GROUPS = $00000080;\r\n //DSOP_SCOPE_FLAG_DEFAULT_FILTER_COMPUTERS = $00000100;\r\n //DSOP_SCOPE_FLAG_DEFAULT_FILTER_CONTACTS = $00000200;\r\nend;\r\n\r\nfunction UpLevelFilterToOrdinal(const Filter: TUpLevelFilters): Cardinal;\r\nbegin\r\n Result := 0;\r\n if ulIncludeAdvancedView in Filter then\r\n Result := Result or DSOP_FILTER_INCLUDE_ADVANCED_VIEW;\r\n if ulUsers in Filter then\r\n Result := Result or DSOP_FILTER_USERS;\r\n if ulBuiltInGroups in Filter then\r\n Result := Result or DSOP_FILTER_BUILTIN_GROUPS;\r\n if ulWellKnownPrincipals in Filter then\r\n Result := Result or DSOP_FILTER_WELL_KNOWN_PRINCIPALS;\r\n if ulUniversalDistributionListGroups in Filter then\r\n Result := Result or DSOP_FILTER_UNIVERSAL_GROUPS_DL;\r\n if ulUniversalSecurityGroups in Filter then\r\n Result := Result or DSOP_FILTER_UNIVERSAL_GROUPS_SE;\r\n if ulGlobalDistributionListGroups in Filter then\r\n Result := Result or DSOP_FILTER_GLOBAL_GROUPS_DL;\r\n if ulGlobalSecurityGroups in Filter then\r\n Result := Result or DSOP_FILTER_GLOBAL_GROUPS_SE;\r\n if ulDomainLocalDistributionListGroups in Filter then\r\n Result := Result or DSOP_FILTER_DOMAIN_LOCAL_GROUPS_DL;\r\n if ulDomainLocalSecurityGroups in Filter then\r\n Result := Result or DSOP_FILTER_DOMAIN_LOCAL_GROUPS_SE;\r\n if ulContacts in Filter then\r\n Result := Result or DSOP_FILTER_CONTACTS;\r\n if ulComputers in Filter then\r\n Result := Result or DSOP_FILTER_COMPUTERS;\r\nend;\r\n\r\nfunction DownLevelFilterToOrdinal(const Filter: TDownLevelFilters): Cardinal;\r\nbegin\r\n Result := 0;\r\n if dlUsers in Filter then\r\n Result := Result or DSOP_DOWNLEVEL_FILTER_USERS;\r\n if dlLocalGroups in Filter then\r\n Result := Result or DSOP_DOWNLEVEL_FILTER_LOCAL_GROUPS;\r\n if dlGlobalGroups in Filter then\r\n Result := Result or DSOP_DOWNLEVEL_FILTER_GLOBAL_GROUPS;\r\n if dlComputers in Filter then\r\n Result := Result or DSOP_DOWNLEVEL_FILTER_COMPUTERS;\r\n if dlWorld in Filter then\r\n Result := Result or DSOP_DOWNLEVEL_FILTER_WORLD;\r\n if dlAuthenticatedUser in Filter then\r\n Result := Result or DSOP_DOWNLEVEL_FILTER_AUTHENTICATED_USER;\r\n if dlAnonymous in Filter then\r\n Result := Result or DSOP_DOWNLEVEL_FILTER_ANONYMOUS;\r\n if dlBatch in Filter then\r\n Result := Result or DSOP_DOWNLEVEL_FILTER_BATCH;\r\n if dlCreatorOwner in Filter then\r\n Result := Result or DSOP_DOWNLEVEL_FILTER_CREATOR_OWNER;\r\n if dlCreatorGroup in Filter then\r\n Result := Result or DSOP_DOWNLEVEL_FILTER_CREATOR_GROUP;\r\n if dlDialUp in Filter then\r\n Result := Result or DSOP_DOWNLEVEL_FILTER_DIALUP;\r\n if dlInteractive in Filter then\r\n Result := Result or DSOP_DOWNLEVEL_FILTER_INTERACTIVE;\r\n if dlNetwork in Filter then\r\n Result := Result or DSOP_DOWNLEVEL_FILTER_NETWORK;\r\n if dlService in Filter then\r\n Result := Result or DSOP_DOWNLEVEL_FILTER_SERVICE;\r\n if dlSystem in Filter then\r\n Result := Result or DSOP_DOWNLEVEL_FILTER_SYSTEM;\r\n if dlExcludeBuiltinGroups in Filter then\r\n Result := Result or DSOP_DOWNLEVEL_FILTER_EXCLUDE_BUILTIN_GROUPS;\r\n if dlTerminalServer in Filter then\r\n Result := Result or DSOP_DOWNLEVEL_FILTER_TERMINAL_SERVER;\r\n if dlAllWellKnownSids in Filter then\r\n Result := Result or DSOP_DOWNLEVEL_FILTER_ALL_WELLKNOWN_SIDS;\r\n if dlLocalService in Filter then\r\n Result := Result or DSOP_DOWNLEVEL_FILTER_LOCAL_SERVICE;\r\n if dlNetworkService in Filter then\r\n Result := Result or DSOP_DOWNLEVEL_FILTER_NETWORK_SERVICE;\r\n if dlRemoteLogon in Filter then\r\n Result := Result or DSOP_DOWNLEVEL_FILTER_REMOTE_LOGON;\r\nend;\r\n\r\nfunction OptionsToOrdinal(const Options: TObjectPickerOptions): Cardinal;\r\nbegin\r\n Result := 0;\r\n if opAllowMultiSelect in Options then\r\n Result := Result or DSOP_FLAG_MULTISELECT;\r\n if opSkipTargetComputerDCCheck in Options then\r\n Result := Result or DSOP_FLAG_SKIP_TARGET_COMPUTER_DC_CHECK;\r\nend;\r\n\r\n//=== { TObjectPickerScope } =================================================\r\n\r\nprocedure TObjectPickerScope.Assign(Source: TPersistent);\r\nbegin\r\n if Source is TObjectPickerScope then\r\n begin\r\n FDownLevelFilter := TObjectPickerScope(Source).DownLevelFilter;\r\n FScopeTypes := TObjectPickerScope(Source).ScopeTypes;\r\n FScopeFlags := TObjectPickerScope(Source).ScopeFlags;\r\n FDcName := TObjectPickerScope(Source).DcName;\r\n FResult := TObjectPickerScope(Source).Result;\r\n FUpLevelFilterBoth := TObjectPickerScope(Source).UpLevelFilterBoth;\r\n FUpLevelFilterNative := TObjectPickerScope(Source).UpLevelFilterNative;\r\n FUpLevelFilterMixed := TObjectPickerScope(Source).UpLevelFilterMixed;\r\n end\r\n else\r\n inherited Assign(Source);\r\nend;\r\n\r\n//=== { TObjectPickerScopes } ================================================\r\n\r\nconstructor TObjectPickerScopes.Create({OWNER AOwner: TComponent});\r\nbegin\r\n inherited Create(TObjectPickerScope);\r\n //OWNER FOwner := AOwner;\r\nend;\r\n\r\nfunction TObjectPickerScopes.Add: TObjectPickerScope;\r\nbegin\r\n Result := TObjectPickerScope(inherited Add);\r\nend;\r\n\r\nprocedure TObjectPickerScopes.Assign(Source: TPersistent);\r\nvar\r\n I: Integer;\r\nbegin\r\n if Source is TObjectPickerScopes then\r\n for I := 0 to TCollection(Source).Count - 1 do\r\n Add.Assign(TCollection(Source).Items[I])\r\n else\r\n inherited Assign(Source);\r\nend;\r\n\r\nfunction TObjectPickerScopes.GetItem(Index: Integer): TObjectPickerScope;\r\nbegin\r\n Result := TObjectPickerScope(inherited Items[Index]);\r\nend;\r\n\r\nprocedure TObjectPickerScopes.Initialize(var ScopesInitInfo: array of TDsOpScopeInitInfo);\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := 0 to Count - 1 do\r\n begin\r\n FillChar(ScopesInitInfo[I], SizeOf(TDsOpScopeInitInfo), 0);\r\n ScopesInitInfo[I].cbSize := SizeOf(TDsOpScopeInitInfo);\r\n ScopesInitInfo[I].flType := ScopeTypesToOrdinal(Items[I].ScopeTypes);\r\n ScopesInitInfo[I].flScope := ScopeFlagsToOrdinal(Items[I].ScopeFlags);\r\n ScopesInitInfo[I].FilterFlags.Uplevel.flBothModes :=\r\n UpLevelFilterToOrdinal(Items[I].UpLevelFilterBoth);\r\n ScopesInitInfo[I].FilterFlags.Uplevel.flMixedModeOnly :=\r\n UpLevelFilterToOrdinal(Items[I].UpLevelFilterMixed);\r\n ScopesInitInfo[I].FilterFlags.Uplevel.flNativeModeOnly :=\r\n UpLevelFilterToOrdinal(Items[I].UpLevelFilterNative);\r\n ScopesInitInfo[I].FilterFlags.flDownlevel :=\r\n DownLevelFilterToOrdinal(Items[I].DownLevelFilter);\r\n ScopesInitInfo[I].pwzDcName := PWideChar(WideString(Items[I].DcName));\r\n ScopesInitInfo[I].pwzADsPath := nil;\r\n ScopesInitInfo[I].hr := S_OK;\r\n end;\r\nend;\r\n\r\n//OWNER function TObjectPickerScopes.Owner: TComponent;\r\n//OWNER begin\r\n//OWNER Result := FOwner;\r\n//OWNER end;\r\n\r\nprocedure TObjectPickerScopes.SetItem(Index: Integer;\r\n Value: TObjectPickerScope);\r\nbegin\r\n TObjectPickerScope(inherited Items[Index]).Assign(Value);\r\nend;\r\n\r\n//=== { TObjectPickerSelection } =============================================\r\n\r\nconstructor TObjectPickerSelection.Create(Selection: PDsSelection;\r\n const AttributeCount: Integer);\r\nbegin\r\n inherited Create;\r\n FAttributeCount := AttributeCount;\r\n FSelection := Selection;\r\nend;\r\n\r\nfunction TObjectPickerSelection.GetAdsPath: string;\r\nbegin\r\n Result := WideCharToString(FSelection^.pwzADsPath);\r\nend;\r\n\r\nfunction TObjectPickerSelection.GetAttribute(Index: Integer): OleVariant;\r\ntype\r\n TOleVariantArray = array [0..(MaxInt div SizeOf(OleVariant)) - 1] of OleVariant;\r\n POleVariantArray = ^TOleVariantArray;\r\nbegin\r\n if (Index < 0) or (Index >= AttributeCount) then\r\n raise EObjectPickerError.CreateResFmt(@RsEAttributeIndexOutOfBounds, [Index]);\r\n Result := POleVariantArray(FSelection^.pvarFetchedAttributes)^[Index];\r\nend;\r\n\r\nfunction TObjectPickerSelection.GetName: string;\r\nbegin\r\n Result := WideCharToString(FSelection^.pwzName);\r\nend;\r\n\r\nfunction TObjectPickerSelection.GetObjectClass: string;\r\nbegin\r\n Result := WideCharToString(FSelection^.pwzClass);\r\nend;\r\n\r\nfunction TObjectPickerSelection.GetScopeTypes: TScopeTypes;\r\nbegin\r\n Result := OrdinalToScopeTypes(FSelection^.flScopeType);\r\nend;\r\n\r\nfunction TObjectPickerSelection.GetUPN: string;\r\nbegin\r\n Result := WideCharToString(FSelection^.pwzUPN);\r\nend;\r\n\r\n//=== { TObjectPickerSelections } ============================================\r\n\r\ndestructor TObjectPickerSelections.Destroy;\r\nbegin\r\n FreeSelection;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TObjectPickerSelections.FreeSelection;\r\nvar\r\n I: Integer;\r\nbegin\r\n if FSelections <> nil then\r\n begin\r\n for I := 0 to Length(FItems) - 1 do\r\n FItems[I].Free;\r\n SetLength(FItems, 0);\r\n GlobalUnlock(FMedium.hGlobal);\r\n ReleaseStgMedium(FMedium);\r\n FSelections := nil;\r\n end;\r\nend;\r\n\r\nfunction TObjectPickerSelections.GetAttributeCount: Integer;\r\nbegin\r\n Result := -1;\r\n if FSelections <> nil then\r\n Result := FSelections^.cFetchedAttributes;\r\nend;\r\n\r\nfunction TObjectPickerSelections.GetCount: Integer;\r\nbegin\r\n Result := -1;\r\n if FSelections <> nil then\r\n Result := FSelections^.cItems;\r\nend;\r\n\r\nfunction TObjectPickerSelections.GetItem(Index: Integer): TObjectPickerSelection;\r\nbegin\r\n Result := nil;\r\n if FSelections <> nil then\r\n begin\r\n if (Index < 0) or (Index >= Count) then\r\n raise EObjectPickerError.CreateResFmt(@RsESelectionIndexOutOfBounds, [Index]);\r\n Result := FItems[Index];\r\n end;\r\nend;\r\n\r\nprocedure TObjectPickerSelections.SetSelection(const DataObj: IDataObject);\r\nvar\r\n Format: TFormatEtc;\r\n I: Integer;\r\n Selection: PDsSelection;\r\n HRes: HRESULT;\r\nbegin\r\n FreeSelection;\r\n Format.cfFormat := RegisterClipboardFormat(CFSTR_DSOP_DS_SELECTION_LIST);\r\n Format.ptd := nil;\r\n Format.dwAspect := DVASPECT_CONTENT;\r\n Format.lindex := -1;\r\n Format.tymed := TYMED_HGLOBAL;\r\n FillChar(FMedium, SizeOf(FMedium), 0);\r\n FMedium.tymed := TYMED_HGLOBAL;\r\n HRes := DataObj.GetData(Format, FMedium);\r\n if Succeeded(HRes) then\r\n begin\r\n FSelections := GlobalLock(FMedium.hGlobal);\r\n SetLength(FItems, FSelections^.cItems);\r\n for I := 0 to FSelections^.cItems - 1 do\r\n begin\r\n {$RANGECHECKS OFF}\r\n Selection := @FSelections^.aDsSelection[I];\r\n {$IFDEF RANGECHECKS_ON}\r\n {$RANGECHECKS ON}\r\n {$ENDIF RANGECHECKS_ON}\r\n FItems[I] := TObjectPickerSelection.Create(Selection,\r\n FSelections^.cFetchedAttributes);\r\n end;\r\n end\r\n else\r\n OleCheck(HRes);\r\nend;\r\n\r\n//=== { TJvObjectPickerDialog } ==============================================\r\n\r\nconstructor TJvObjectPickerDialog.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n// OleCheck(CoCreateInstance(CLSID_DsObjectPicker, nil, CLSCTX_INPROC_SERVER, IID_IDsObjectPicker, FObjectPicker));\r\n FAttributes := TStringList.Create;\r\n FOptions := [];\r\n FScopes := TObjectPickerScopes.Create({OWNER Self});\r\n FSelection := TObjectPickerSelections.Create;\r\n FTargetComputer := '';\r\nend;\r\n\r\ndestructor TJvObjectPickerDialog.Destroy;\r\nbegin\r\n FSelection.Free;\r\n FScopes.Free;\r\n FAttributes.Free;\r\n FObjectPicker := nil;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJvObjectPickerDialog.Execute(ParentWnd: HWND): Boolean;\r\nvar\r\n InitInfo: TDsOpInitInfo;\r\n ScopesInitInfo: array of TDsOpScopeInitInfo;\r\n Attrs: array of PWideChar;\r\n AttrStrs: array of WideString;\r\n HRes: HRESULT;\r\n DataObj: IDataObject;\r\n\r\n procedure InitializeAttributes;\r\n var\r\n I: Integer;\r\n begin\r\n InitInfo.cAttributesToFetch := Attributes.Count;\r\n if Attributes.Count = 0 then\r\n InitInfo.apwzAttributeNames := nil\r\n else\r\n begin\r\n SetLength(Attrs, Attributes.Count);\r\n SetLength(AttrStrs, Attributes.Count);\r\n for I := 0 to Attributes.Count - 1 do\r\n begin\r\n AttrStrs[I] := WideString(Attributes[I]);\r\n Attrs[I] := PWideChar(AttrStrs[I]);\r\n end;\r\n InitInfo.apwzAttributeNames := @Attrs[0];\r\n end;\r\n end;\r\n\r\n procedure PropogateInitResults;\r\n var\r\n I: Integer;\r\n begin\r\n for I := 0 to Scopes.Count - 1 do\r\n Scopes[I].FResult := ScopesInitInfo[I].hr;\r\n end;\r\n\r\nbegin\r\n Result := False;\r\n OleCheck(CoCreateInstance(CLSID_DsObjectPicker, nil, CLSCTX_INPROC_SERVER,\r\n IID_IDsObjectPicker, FObjectPicker));\r\n FillChar(InitInfo, SizeOf(InitInfo), 0);\r\n InitInfo.cbSize := SizeOf(InitInfo);\r\n InitInfo.flOptions := OptionsToOrdinal(FOptions);\r\n InitInfo.cDsScopeInfos := Scopes.Count;\r\n SetLength(ScopesInitInfo, Scopes.Count);\r\n InitInfo.aDsScopeInfos := @ScopesInitInfo[0];\r\n Scopes.Initialize(ScopesInitInfo);\r\n InitializeAttributes;\r\n Selection.FreeSelection;\r\n HRes := FObjectPicker.Initialize(@InitInfo);\r\n // (p3) this won't raise a second exception\r\n if not Succeeded(HRes) then\r\n Exit;\r\n PropogateInitResults;\r\n// OleCheck(HRes);\r\n HRes := FObjectPicker.InvokeDialog(Application.Handle, DataObj);\r\n case HRes of\r\n S_OK:\r\n begin\r\n Result := True;\r\n FSelection.SetSelection(DataObj);\r\n end;\r\n S_FALSE:\r\n Result := False;\r\n else\r\n Result := False;\r\n OleCheck(HRes);\r\n end;\r\nend;\r\n\r\nprocedure TJvObjectPickerDialog.Reset;\r\nbegin\r\n Attributes.Clear;\r\n Options := [];\r\n Scopes.Clear;\r\n Selection.FreeSelection;\r\nend;\r\n\r\nfunction TJvObjectPickerDialog.GetAttributes: TStrings;\r\nbegin\r\n Result := FAttributes;\r\nend;\r\n\r\nprocedure TJvObjectPickerDialog.SetAttributes(Value: TStrings);\r\nbegin\r\n FAttributes.Assign(Value);\r\nend;\r\n\r\nprocedure TJvObjectPickerDialog.SetScopes(Value: TObjectPickerScopes);\r\nbegin\r\n FScopes.Assign(Value);\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvOdacSmartQuery.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvOdacSmartQuery.PAS, released on 2002-05-26.\r\n\r\nThe Initial Developer of the Original Code is Jens Fudickar\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nDescription:\r\n Oracle Dataset with Threaded Functions\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvOdacSmartQuery.pas 13372 2012-06-24 21:56:00Z jfudickar $\r\n\r\nunit JvOdacSmartQuery;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\n{$IFDEF USE_3RDPARTY_DEVART_ODAC}\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n SysUtils, Classes, Forms, Controls, DB,\r\n OraSmart, Ora, DBaccess,\r\n JvBaseDBThreadedDataset;\r\n{$ENDIF USE_3RDPARTY_DEVART_ODAC}\r\n\r\n{$IFDEF USE_3RDPARTY_DEVART_ODAC}\r\ntype\r\n TJvOdacThreadedDatasetAllowedContinueRecordFetchOptions =\r\n class(TJvBaseThreadedDatasetAllowedContinueRecordFetchOptions)\r\n public\r\n constructor Create; override;\r\n published\r\n property All;\r\n End;\r\n\r\n TJvOdacThreadedDatasetEnhancedOptions = Class(TJvBaseThreadedDatasetEnhancedOptions)\r\n private\r\n function GetAllowedContinueRecordFetchOptions: TJvOdacThreadedDatasetAllowedContinueRecordFetchOptions;\r\n procedure SetAllowedContinueRecordFetchOptions(\r\n const Value: TJvOdacThreadedDatasetAllowedContinueRecordFetchOptions);\r\n protected\r\n function CreateAllowedContinueRecordFetchOptions: TJvBaseThreadedDatasetAllowedContinueRecordFetchOptions;\r\n override;\r\n published\r\n property AllowedContinueRecordFetchOptions: TJvOdacThreadedDatasetAllowedContinueRecordFetchOptions read\r\n GetAllowedContinueRecordFetchOptions write SetAllowedContinueRecordFetchOptions;\r\n end;\r\n\r\n TJvOdacDatasetThreadHandler = class(TJvBaseDatasetThreadHandler)\r\n private\r\n FRefreshKeyFields: string;\r\n FRefreshKeyValues: Variant;\r\n protected\r\n function CreateEnhancedOptions: TJvBaseThreadedDatasetEnhancedOptions; override;\r\n property RefreshKeyFields: string read FRefreshKeyFields write\r\n FRefreshKeyFields;\r\n property RefreshKeyValues: Variant read FRefreshKeyValues write\r\n FRefreshKeyValues;\r\n public\r\n constructor Create(AOwner: TComponent; ADataset: TDataSet); reintroduce;\r\n override;\r\n procedure AfterRefresh; override;\r\n procedure BeforeRefresh; override;\r\n procedure RestoreRefreshKeyFields;\r\n procedure SaveRefreshKeyFields;\r\n End;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvOdacSmartQuery = class(TSmartQuery, IJvThreadedDatasetInterface)\r\n procedure BreakExecution;\r\n procedure BringThreadDialogToFront;\r\n function DoGetInheritedNextRecord: Boolean;\r\n procedure DoInheritedAfterOpen;\r\n procedure DoInheritedAfterRefresh;\r\n procedure DoInheritedAfterScroll;\r\n procedure DoInheritedBeforeOpen;\r\n procedure DoInheritedBeforeRefresh;\r\n procedure DoInheritedInternalLast;\r\n procedure DoInheritedInternalRefresh;\r\n procedure DoInheritedSetActive(Active: Boolean);\r\n procedure DoInternalOpen;\r\n function GetDatasetFetchAllRecords: Boolean;\r\n function IsThreadAllowed: Boolean;\r\n procedure SetDatasetFetchAllRecords(const Value: Boolean);\r\n private\r\n FBeforeFetch: TBeforeFetchEvent;\r\n FThreadHandler: TJvBaseDatasetThreadHandler;\r\n function GetAfterOpenFetch: TDataSetNotifyEvent;\r\n function GetAfterThreadExecution: TJvThreadedDatasetThreadEvent;\r\n function GetBeforeThreadExecution: TJvThreadedDatasetThreadEvent;\r\n function GetDialogOptions: TJvThreadedDatasetDialogOptions;\r\n function GetEnhancedOptions: TJvOdacThreadedDatasetEnhancedOptions;\r\n function GetThreadOptions: TJvThreadedDatasetThreadOptions;\r\n procedure SetAfterOpenFetch(const Value: TDataSetNotifyEvent);\r\n procedure SetAfterThreadExecution(const Value: TJvThreadedDatasetThreadEvent);\r\n procedure SetBeforeThreadExecution(const Value: TJvThreadedDatasetThreadEvent);\r\n procedure SetDialogOptions(Value: TJvThreadedDatasetDialogOptions);\r\n procedure SetEnhancedOptions(const Value:\r\n TJvOdacThreadedDatasetEnhancedOptions);\r\n procedure SetThreadOptions(const Value: TJvThreadedDatasetThreadOptions);\r\n property ThreadHandler: TJvBaseDatasetThreadHandler read FThreadHandler;\r\n protected\r\n procedure DoAfterOpen; override;\r\n procedure DoAfterRefresh; override;\r\n procedure DoAfterScroll; override;\r\n procedure DoBeforeOpen; override;\r\n procedure DoBeforeRefresh; override;\r\n function GetNextRecord: Boolean; override;\r\n function GetOnThreadException: TJvThreadedDatasetThreadExceptionEvent;\r\n procedure InternalLast; override;\r\n procedure InternalRefresh; override;\r\n procedure ReplaceBeforeFetch(Dataset: TCustomDADataSet; var Cancel: Boolean);\r\n procedure SetActive(Value: Boolean); override;\r\n procedure SetOnThreadException(const Value:\r\n TJvThreadedDatasetThreadExceptionEvent);\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n function CurrentFetchDuration: TDateTime;\r\n function CurrentOpenDuration: TDateTime;\r\n function EofReached: Boolean;\r\n function ErrorException: Exception;\r\n function ErrorMessage: string;\r\n function ThreadIsActive: Boolean;\r\n published\r\n property AfterOpenFetch: TDataSetNotifyEvent read GetAfterOpenFetch write\r\n SetAfterOpenFetch;\r\n property AfterThreadExecution: TJvThreadedDatasetThreadEvent read\r\n GetAfterThreadExecution write SetAfterThreadExecution;\r\n property BeforeFetch: TBeforeFetchEvent read FBeforeFetch write FBeforeFetch;\r\n property BeforeThreadExecution: TJvThreadedDatasetThreadEvent read\r\n GetBeforeThreadExecution write SetBeforeThreadExecution;\r\n property DialogOptions: TJvThreadedDatasetDialogOptions read GetDialogOptions write SetDialogOptions;\r\n property EnhancedOptions: TJvOdacThreadedDatasetEnhancedOptions read GetEnhancedOptions write SetEnhancedOptions;\r\n property ThreadOptions: TJvThreadedDatasetThreadOptions read GetThreadOptions write SetThreadOptions;\r\n property OnThreadException: TJvThreadedDatasetThreadExceptionEvent read\r\n GetOnThreadException write SetOnThreadException;\r\n end;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvOdacOraQuery = class(TOraQuery, IJvThreadedDatasetInterface)\r\n procedure BreakExecution;\r\n procedure BringThreadDialogToFront;\r\n function DoGetInheritedNextRecord: Boolean;\r\n procedure DoInheritedAfterOpen;\r\n procedure DoInheritedAfterRefresh;\r\n procedure DoInheritedAfterScroll;\r\n procedure DoInheritedBeforeOpen;\r\n procedure DoInheritedBeforeRefresh;\r\n procedure DoInheritedInternalLast;\r\n procedure DoInheritedInternalRefresh;\r\n procedure DoInheritedSetActive(Active: Boolean);\r\n procedure DoInternalOpen;\r\n function GetDatasetFetchAllRecords: Boolean;\r\n function IsThreadAllowed: Boolean;\r\n procedure SetDatasetFetchAllRecords(const Value: Boolean);\r\n strict private\r\n private\r\n FBeforeFetch: TBeforeFetchEvent;\r\n FThreadHandler: TJvBaseDatasetThreadHandler;\r\n function GetAfterOpenFetch: TDataSetNotifyEvent;\r\n function GetAfterOpenFetch1: TDataSetNotifyEvent;\r\n function GetAfterThreadExecution: TJvThreadedDatasetThreadEvent;\r\n function GetBeforeThreadExecution: TJvThreadedDatasetThreadEvent;\r\n function GetDialogOptions: TJvThreadedDatasetDialogOptions;\r\n function GetEnhancedOptions: TJvOdacThreadedDatasetEnhancedOptions;\r\n function GetThreadOptions: TJvThreadedDatasetThreadOptions;\r\n procedure SetAfterOpenFetch(const Value: TDataSetNotifyEvent);\r\n procedure SetAfterOpenFetch1(const Value: TDataSetNotifyEvent);\r\n procedure SetAfterThreadExecution(const Value: TJvThreadedDatasetThreadEvent);\r\n procedure SetBeforeThreadExecution(const Value: TJvThreadedDatasetThreadEvent);\r\n procedure SetDialogOptions(Value: TJvThreadedDatasetDialogOptions);\r\n procedure SetEnhancedOptions(const Value:\r\n TJvOdacThreadedDatasetEnhancedOptions);\r\n procedure SetThreadOptions(const Value: TJvThreadedDatasetThreadOptions);\r\n property ThreadHandler: TJvBaseDatasetThreadHandler read FThreadHandler;\r\n protected\r\n procedure DoAfterOpen; override;\r\n procedure DoAfterRefresh; override;\r\n procedure DoAfterScroll; override;\r\n procedure DoBeforeOpen; override;\r\n procedure DoBeforeRefresh; override;\r\n function GetNextRecord: Boolean; override;\r\n function GetOnThreadException: TJvThreadedDatasetThreadExceptionEvent;\r\n procedure InternalLast; override;\r\n procedure InternalRefresh; override;\r\n procedure ReplaceBeforeFetch(Dataset: TCustomDADataSet; var Cancel: Boolean);\r\n procedure SetActive(Value: Boolean); override;\r\n procedure SetOnThreadException(const Value:\r\n TJvThreadedDatasetThreadExceptionEvent);\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n function CurrentFetchDuration: TDateTime;\r\n function CurrentOpenDuration: TDateTime;\r\n function EofReached: Boolean;\r\n function ErrorException: Exception;\r\n function ErrorMessage: string;\r\n function ThreadIsActive: Boolean;\r\n published\r\n property AfterOpenFetch: TDataSetNotifyEvent read GetAfterOpenFetch1 write\r\n SetAfterOpenFetch1;\r\n property AfterThreadExecution: TJvThreadedDatasetThreadEvent read\r\n GetAfterThreadExecution write SetAfterThreadExecution;\r\n property BeforeFetch: TBeforeFetchEvent read FBeforeFetch write FBeforeFetch;\r\n property BeforeThreadExecution: TJvThreadedDatasetThreadEvent read\r\n GetBeforeThreadExecution write SetBeforeThreadExecution;\r\n property DialogOptions: TJvThreadedDatasetDialogOptions read GetDialogOptions write SetDialogOptions;\r\n property EnhancedOptions: TJvOdacThreadedDatasetEnhancedOptions read GetEnhancedOptions write SetEnhancedOptions;\r\n property ThreadOptions: TJvThreadedDatasetThreadOptions read GetThreadOptions write SetThreadOptions;\r\n property OnThreadException: TJvThreadedDatasetThreadExceptionEvent read\r\n GetOnThreadException write SetOnThreadException;\r\n end;\r\n\r\ntype\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvOdacOraTable = class(TOraTable, IJvThreadedDatasetInterface)\r\n procedure BreakExecution;\r\n procedure BringThreadDialogToFront;\r\n function DoGetInheritedNextRecord: Boolean;\r\n procedure DoInheritedAfterOpen;\r\n procedure DoInheritedAfterRefresh;\r\n procedure DoInheritedAfterScroll;\r\n procedure DoInheritedBeforeOpen;\r\n procedure DoInheritedBeforeRefresh;\r\n procedure DoInheritedInternalLast;\r\n procedure DoInheritedInternalRefresh;\r\n procedure DoInheritedSetActive(Active: Boolean);\r\n procedure DoInternalOpen;\r\n function GetDatasetFetchAllRecords: Boolean;\r\n function IsThreadAllowed: Boolean;\r\n private\r\n FBeforeFetch: TBeforeFetchEvent;\r\n FThreadHandler: TJvBaseDatasetThreadHandler;\r\n function GetAfterOpenFetch: TDataSetNotifyEvent;\r\n function GetAfterThreadExecution: TJvThreadedDatasetThreadEvent;\r\n function GetBeforeThreadExecution: TJvThreadedDatasetThreadEvent;\r\n function GetDialogOptions: TJvThreadedDatasetDialogOptions;\r\n function GetEnhancedOptions: TJvOdacThreadedDatasetEnhancedOptions;\r\n function GetThreadOptions: TJvThreadedDatasetThreadOptions;\r\n procedure SetAfterOpenFetch(const Value: TDataSetNotifyEvent);\r\n procedure SetAfterThreadExecution(const Value: TJvThreadedDatasetThreadEvent);\r\n procedure SetBeforeThreadExecution(const Value: TJvThreadedDatasetThreadEvent);\r\n procedure SetDatasetFetchAllRecords(const Value: Boolean);\r\n procedure SetDialogOptions(Value: TJvThreadedDatasetDialogOptions);\r\n procedure SetEnhancedOptions(const Value:\r\n TJvOdacThreadedDatasetEnhancedOptions);\r\n procedure SetThreadOptions(const Value: TJvThreadedDatasetThreadOptions);\r\n property ThreadHandler: TJvBaseDatasetThreadHandler read FThreadHandler;\r\n protected\r\n procedure DoAfterOpen; override;\r\n procedure DoAfterRefresh; override;\r\n procedure DoAfterScroll; override;\r\n procedure DoBeforeOpen; override;\r\n procedure DoBeforeRefresh; override;\r\n function GetNextRecord: Boolean; override;\r\n function GetOnThreadException: TJvThreadedDatasetThreadExceptionEvent;\r\n procedure InternalLast; override;\r\n procedure InternalRefresh; override;\r\n procedure ReplaceBeforeFetch(Dataset: TCustomDADataSet; var Cancel: Boolean);\r\n procedure SetActive(Value: Boolean); override;\r\n procedure SetOnThreadException(const Value:\r\n TJvThreadedDatasetThreadExceptionEvent);\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n function CurrentFetchDuration: TDateTime;\r\n function CurrentOpenDuration: TDateTime;\r\n function EofReached: Boolean;\r\n function ErrorException: Exception;\r\n function ErrorMessage: string;\r\n function ThreadIsActive: Boolean;\r\n published\r\n property AfterOpenFetch: TDataSetNotifyEvent read GetAfterOpenFetch write\r\n SetAfterOpenFetch;\r\n property AfterThreadExecution: TJvThreadedDatasetThreadEvent read\r\n GetAfterThreadExecution write SetAfterThreadExecution;\r\n property BeforeFetch: TBeforeFetchEvent read FBeforeFetch write FBeforeFetch;\r\n property BeforeThreadExecution: TJvThreadedDatasetThreadEvent read\r\n GetBeforeThreadExecution write SetBeforeThreadExecution;\r\n property DialogOptions: TJvThreadedDatasetDialogOptions read GetDialogOptions write SetDialogOptions;\r\n property EnhancedOptions: TJvOdacThreadedDatasetEnhancedOptions read GetEnhancedOptions write SetEnhancedOptions;\r\n property ThreadOptions: TJvThreadedDatasetThreadOptions read GetThreadOptions write SetThreadOptions;\r\n property OnThreadException: TJvThreadedDatasetThreadExceptionEvent read\r\n GetOnThreadException write SetOnThreadException;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvOdacSmartQuery.pas $';\r\n Revision: '$Revision: 13372 $';\r\n Date: '$Date: 2012-06-24 23:56:00 +0200 (dim. 24 juin 2012) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n{$ENDIF USE_3RDPARTY_DEVART_ODAC}\r\n\r\nimplementation\r\n\r\n{$IFDEF USE_3RDPARTY_DEVART_ODAC}\r\nuses Variants, MemData;\r\n\r\n//=== { TJvOdacSmartQuery } ==================================================\r\n\r\nconstructor TJvOdacSmartQuery.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FThreadHandler := TJvOdacDatasetThreadHandler.Create(Self, Self);\r\n inherited BeforeFetch := ReplaceBeforeFetch;\r\nend;\r\n\r\ndestructor TJvOdacSmartQuery.Destroy;\r\nbegin\r\n FreeAndNil(FThreadHandler);\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvOdacSmartQuery.BreakExecution;\r\nbegin\r\n BreakExec;\r\nend;\r\n\r\nprocedure TJvOdacSmartQuery.BringThreadDialogToFront;\r\nbegin\r\n if Assigned(ThreadHandler) then\r\n ThreadHandler.BringDialogToFront;\r\nend;\r\n\r\nfunction TJvOdacSmartQuery.CurrentFetchDuration: TDateTime;\r\nbegin\r\n if Assigned(ThreadHandler) then\r\n Result := ThreadHandler.CurrentFetchDuration\r\n else\r\n Result := 0;\r\nend;\r\n\r\nfunction TJvOdacSmartQuery.CurrentOpenDuration: TDateTime;\r\nbegin\r\n if Assigned(ThreadHandler) then\r\n Result := ThreadHandler.CurrentOpenDuration\r\n else\r\n Result := 0;\r\nend;\r\n\r\nprocedure TJvOdacSmartQuery.DoAfterOpen;\r\nbegin\r\n ThreadHandler.AfterOpen;\r\nend;\r\n\r\nprocedure TJvOdacSmartQuery.DoAfterRefresh;\r\nbegin\r\n ThreadHandler.AfterRefresh;\r\nend;\r\n\r\nprocedure TJvOdacSmartQuery.DoAfterScroll;\r\nbegin\r\n ThreadHandler.AfterScroll;\r\nend;\r\n\r\nprocedure TJvOdacSmartQuery.DoBeforeOpen;\r\nbegin\r\n ThreadHandler.BeforeOpen;\r\nend;\r\n\r\nprocedure TJvOdacSmartQuery.DoBeforeRefresh;\r\nbegin\r\n ThreadHandler.BeforeRefresh;\r\nend;\r\n\r\nfunction TJvOdacSmartQuery.DoGetInheritedNextRecord: Boolean;\r\nbegin\r\n Result := Inherited GetNextRecord;\r\nend;\r\n\r\nprocedure TJvOdacSmartQuery.DoInheritedAfterOpen;\r\nbegin\r\n inherited DoAfterOpen;\r\nend;\r\n\r\nprocedure TJvOdacSmartQuery.DoInheritedAfterRefresh;\r\nbegin\r\n inherited DoAfterRefresh;\r\nend;\r\n\r\nprocedure TJvOdacSmartQuery.DoInheritedAfterScroll;\r\nbegin\r\n inherited DoAfterScroll;\r\nend;\r\n\r\nprocedure TJvOdacSmartQuery.DoInheritedBeforeOpen;\r\nbegin\r\n inherited DoBeforeOpen;\r\nend;\r\n\r\nprocedure TJvOdacSmartQuery.DoInheritedBeforeRefresh;\r\nbegin\r\n inherited DoBeforeRefresh;\r\nend;\r\n\r\nprocedure TJvOdacSmartQuery.DoInheritedInternalLast;\r\nbegin\r\n inherited InternalLast;\r\nend;\r\n\r\nprocedure TJvOdacSmartQuery.DoInheritedInternalRefresh;\r\nbegin\r\n inherited InternalRefresh;\r\nend;\r\n\r\nprocedure TJvOdacSmartQuery.DoInheritedSetActive(Active: Boolean);\r\nbegin\r\n inherited SetActive(Active);\r\nend;\r\n\r\nprocedure TJvOdacSmartQuery.DoInternalOpen;\r\nbegin\r\n InternalOpen;\r\nend;\r\n\r\nfunction TJvOdacSmartQuery.EofReached: Boolean;\r\nbegin\r\n if Assigned(ThreadHandler) then\r\n Result := ThreadHandler.EofReached\r\n else\r\n Result := False;\r\nend;\r\n\r\nfunction TJvOdacSmartQuery.ErrorException: Exception;\r\nbegin\r\n if Assigned(ThreadHandler) then\r\n Result := ThreadHandler.ErrorException\r\n else\r\n Result := Nil;\r\nend;\r\n\r\nfunction TJvOdacSmartQuery.ErrorMessage: string;\r\nbegin\r\n if Assigned(ThreadHandler) then\r\n Result := ThreadHandler.ErrorMessage\r\n else\r\n Result := '';\r\nend;\r\n\r\nfunction TJvOdacSmartQuery.GetAfterOpenFetch: TDataSetNotifyEvent;\r\nbegin\r\n if Assigned(ThreadHandler) then\r\n Result := ThreadHandler.AfterOpenFetch\r\n else\r\n Result := nil;\r\nend;\r\n\r\nfunction TJvOdacSmartQuery.GetAfterThreadExecution:\r\n TJvThreadedDatasetThreadEvent;\r\nbegin\r\n if Assigned(ThreadHandler) then\r\n Result := ThreadHandler.AfterThreadExecution\r\n else\r\n Result := nil;\r\nend;\r\n\r\nfunction TJvOdacSmartQuery.GetBeforeThreadExecution:\r\n TJvThreadedDatasetThreadEvent;\r\nbegin\r\n if Assigned(ThreadHandler) then\r\n Result := ThreadHandler.BeforeThreadExecution\r\n else\r\n Result := nil;\r\nend;\r\n\r\nfunction TJvOdacSmartQuery.GetDatasetFetchAllRecords: Boolean;\r\nbegin\r\n Result := FetchAll;\r\nend;\r\n\r\nfunction TJvOdacSmartQuery.GetDialogOptions: TJvThreadedDatasetDialogOptions;\r\nbegin\r\n if Assigned(ThreadHandler) then\r\n Result := ThreadHandler.DialogOptions\r\n else\r\n Result := nil;\r\nend;\r\n\r\nfunction TJvOdacSmartQuery.GetEnhancedOptions: TJvOdacThreadedDatasetEnhancedOptions;\r\nbegin\r\n if Assigned(ThreadHandler) then\r\n Result := TJvOdacThreadedDatasetEnhancedOptions(ThreadHandler.EnhancedOptions)\r\n else\r\n Result := nil;\r\nend;\r\n\r\nfunction TJvOdacSmartQuery.GetNextRecord: Boolean;\r\nbegin\r\n if Assigned(ThreadHandler) then\r\n Result := ThreadHandler.GetNextRecord\r\n else\r\n Result := inherited GetNextRecord;\r\nend;\r\n\r\nfunction TJvOdacSmartQuery.GetOnThreadException:\r\n TJvThreadedDatasetThreadExceptionEvent;\r\nbegin\r\n if Assigned(ThreadHandler) then\r\n Result := ThreadHandler.OnThreadException\r\n else\r\n Result := nil;\r\nend;\r\n\r\nfunction TJvOdacSmartQuery.GetThreadOptions: TJvThreadedDatasetThreadOptions;\r\nbegin\r\n if Assigned(ThreadHandler) then\r\n Result := ThreadHandler.ThreadOptions\r\n else\r\n Result := nil;\r\nend;\r\n\r\nprocedure TJvOdacSmartQuery.InternalLast;\r\nbegin\r\n if Assigned(ThreadHandler) then\r\n ThreadHandler.InternalLast;\r\nend;\r\n\r\nprocedure TJvOdacSmartQuery.InternalRefresh;\r\nbegin\r\n if Assigned(ThreadHandler) then\r\n ThreadHandler.InternalRefresh;\r\nend;\r\n\r\nfunction TJvOdacSmartQuery.IsThreadAllowed: Boolean;\r\nvar ThreadedDatasetInterface : IJvThreadedDatasetInterface;\r\nbegin\r\n if Assigned(MasterSource) and Assigned(MasterSource.Dataset)\r\n and Supports(MasterSource.DataSet, IJvThreadedDatasetInterface, ThreadedDatasetInterface) then\r\n Result := not ThreadedDatasetInterface.ThreadIsActive\r\n else\r\n Result := True;\r\nend;\r\n\r\nprocedure TJvOdacSmartQuery.ReplaceBeforeFetch(Dataset: TCustomDADataSet; var Cancel: Boolean);\r\nbegin\r\n if Assigned(ThreadHandler) then\r\n Cancel := ThreadHandler.CheckContinueRecordFetch <> tdccrContinue;\r\n if Assigned(BeforeFetch) and not Cancel then\r\n BeforeFetch(Dataset, Cancel);\r\nend;\r\n\r\nprocedure TJvOdacSmartQuery.SetActive(Value: Boolean);\r\nbegin\r\n if Assigned(ThreadHandler) then\r\n ThreadHandler.SetActive(Value);\r\nend;\r\n\r\nprocedure TJvOdacSmartQuery.SetAfterOpenFetch(const Value: TDataSetNotifyEvent);\r\nbegin\r\n if Assigned(ThreadHandler) then\r\n ThreadHandler.AfterOpenFetch := Value;\r\nend;\r\n\r\nprocedure TJvOdacSmartQuery.SetAfterThreadExecution(const Value:\r\n TJvThreadedDatasetThreadEvent);\r\nbegin\r\n if Assigned(ThreadHandler) then\r\n ThreadHandler.AfterThreadExecution := Value;\r\nend;\r\n\r\nprocedure TJvOdacSmartQuery.SetBeforeThreadExecution(const Value:\r\n TJvThreadedDatasetThreadEvent);\r\nbegin\r\n if Assigned(ThreadHandler) then\r\n ThreadHandler.BeforeThreadExecution := Value;\r\nend;\r\n\r\nprocedure TJvOdacSmartQuery.SetDatasetFetchAllRecords(const Value: Boolean);\r\nbegin\r\n FetchAll := Value;\r\nend;\r\n\r\nprocedure TJvOdacSmartQuery.SetDialogOptions(Value: TJvThreadedDatasetDialogOptions);\r\nbegin\r\n if Assigned(ThreadHandler) then\r\n ThreadHandler.DialogOptions.Assign(Value);\r\nend;\r\n\r\nprocedure TJvOdacSmartQuery.SetEnhancedOptions(const Value: TJvOdacThreadedDatasetEnhancedOptions);\r\nbegin\r\n if Assigned(ThreadHandler) then\r\n ThreadHandler.EnhancedOptions.Assign(Value);\r\nend;\r\n\r\nprocedure TJvOdacSmartQuery.SetOnThreadException(const Value:\r\n TJvThreadedDatasetThreadExceptionEvent);\r\nbegin\r\n if Assigned(ThreadHandler) then\r\n ThreadHandler.OnThreadException := Value;\r\nend;\r\n\r\nprocedure TJvOdacSmartQuery.SetThreadOptions(const Value: TJvThreadedDatasetThreadOptions);\r\nbegin\r\n if Assigned(ThreadHandler) then\r\n ThreadHandler.ThreadOptions.Assign(Value);\r\nend;\r\n\r\nfunction TJvOdacSmartQuery.ThreadIsActive: Boolean;\r\nbegin\r\n if Assigned(ThreadHandler) then\r\n Result := ThreadHandler.ThreadIsActive\r\n else\r\n Result := False;\r\nend;\r\n\r\nconstructor TJvOdacDatasetThreadHandler.Create(AOwner: TComponent; ADataset:\r\n TDataSet);\r\nbegin\r\n inherited Create(AOwner, ADataset);\r\nend;\r\n\r\nprocedure TJvOdacDatasetThreadHandler.AfterRefresh;\r\nbegin\r\n inherited AfterRefresh;\r\n if EnhancedOptions.RefreshLastPosition then\r\n RestoreRefreshKeyFields;\r\nend;\r\n\r\nprocedure TJvOdacDatasetThreadHandler.BeforeRefresh;\r\nbegin\r\n if EnhancedOptions.RefreshLastPosition then\r\n SaveRefreshKeyFields;\r\n inherited BeforeRefresh;\r\nend;\r\n\r\n//=== { TJvOdacDatasetThreadHandler } ========================================\r\n\r\nfunction TJvOdacDatasetThreadHandler.CreateEnhancedOptions: TJvBaseThreadedDatasetEnhancedOptions;\r\nbegin\r\n Result := TJvOdacThreadedDatasetEnhancedOptions.Create;\r\nend;\r\n\r\nprocedure TJvOdacDatasetThreadHandler.RestoreRefreshKeyFields;\r\nbegin\r\n if Not (Dataset.Active and (Dataset is TOraDataset) and\r\n (TOraDataset(Dataset).KeyFields <> '') and (RefreshKeyFields <> '')) then\r\n Exit;\r\n TOraDataset(Dataset).LocateEx(RefreshKeyFields, RefreshKeyValues, [lxNearest])\r\nend;\r\n\r\nprocedure TJvOdacDatasetThreadHandler.SaveRefreshKeyFields;\r\nvar KeyFields : String;\r\n Fields:TStringList;\r\n Key : string;\r\n p: Integer;\r\n Field: TField;\r\n i: Integer;\r\nbegin\r\n RefreshKeyFields := '';\r\n if Not (Dataset.Active and (Dataset is TOraDataset) and (TOraDataset(Dataset).KeyFields <> '')) then\r\n Exit;\r\n Fields := tStringList.create;\r\n try\r\n KeyFields := trim(TOraDataset(Dataset).KeyFields);\r\n while KeyFields <> '' do\r\n begin\r\n p := Pos(';', KeyFields);\r\n if p > 0 then\r\n begin\r\n key := trim(Copy (KeyFields, 1, p-1));\r\n KeyFields := trim(Copy(KeyFields, p+1, Length(KeyFields)-p));\r\n end\r\n else\r\n begin\r\n key := KeyFields;\r\n KeyFields := '';\r\n end;\r\n if (Key <> '') and Assigned(Dataset.FindField(Key)) then\r\n Fields.Add(Key);\r\n end;\r\n FRefreshKeyValues := VarArrayCreate([0,Fields.Count-1], varVariant );\r\n for i := 0 to Fields.Count - 1 do\r\n begin\r\n Field := Dataset.FindField(Fields[i]);\r\n if Assigned (Field) then\r\n begin\r\n RefreshKeyFields := RefreshKeyFields+Key+';';\r\n FRefreshKeyValues[i] := Field.AsVariant;\r\n end;\r\n end;\r\n finally\r\n Fields.Free;\r\n end;\r\nend;\r\n\r\n//=== { TJvOdacThreadedDatasetAllowedContinueRecordFetchOptions } ============\r\n\r\nconstructor TJvOdacThreadedDatasetAllowedContinueRecordFetchOptions.Create;\r\nbegin\r\n inherited Create;\r\n All := True;\r\nend;\r\n\r\nfunction\r\n TJvOdacThreadedDatasetEnhancedOptions.CreateAllowedContinueRecordFetchOptions:\r\n TJvBaseThreadedDatasetAllowedContinueRecordFetchOptions;\r\nbegin\r\n Result := TJvOdacThreadedDatasetAllowedContinueRecordFetchOptions.Create;\r\nend;\r\n\r\nfunction\r\n TJvOdacThreadedDatasetEnhancedOptions.GetAllowedContinueRecordFetchOptions:\r\n TJvOdacThreadedDatasetAllowedContinueRecordFetchOptions;\r\nbegin\r\n Result := TJvOdacThreadedDatasetAllowedContinueRecordFetchOptions(inherited AllowedContinueRecordFetchOptions);\r\nend;\r\n\r\nprocedure\r\n TJvOdacThreadedDatasetEnhancedOptions.SetAllowedContinueRecordFetchOptions(\r\n const Value: TJvOdacThreadedDatasetAllowedContinueRecordFetchOptions);\r\nbegin\r\n inherited AllowedContinueRecordFetchOptions := Value;\r\nend;\r\n\r\n//=== { TJvOdacSmartQuery } ==================================================\r\n\r\nconstructor TJvOdacOraQuery.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FThreadHandler := TJvOdacDatasetThreadHandler.Create(Self, Self);\r\n inherited BeforeFetch := ReplaceBeforeFetch;\r\nend;\r\n\r\ndestructor TJvOdacOraQuery.Destroy;\r\nbegin\r\n FreeAndNil(FThreadHandler);\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvOdacOraQuery.BreakExecution;\r\nbegin\r\n BreakExec;\r\nend;\r\n\r\nprocedure TJvOdacOraQuery.BringThreadDialogToFront;\r\nbegin\r\n if Assigned(ThreadHandler) then\r\n ThreadHandler.BringDialogToFront;\r\nend;\r\n\r\nfunction TJvOdacOraQuery.CurrentFetchDuration: TDateTime;\r\nbegin\r\n if Assigned(ThreadHandler) then\r\n Result := ThreadHandler.CurrentFetchDuration\r\n else\r\n Result := 0;\r\nend;\r\n\r\nfunction TJvOdacOraQuery.CurrentOpenDuration: TDateTime;\r\nbegin\r\n if Assigned(ThreadHandler) then\r\n Result := ThreadHandler.CurrentOpenDuration\r\n else\r\n Result := 0;\r\nend;\r\n\r\nprocedure TJvOdacOraQuery.DoAfterOpen;\r\nbegin\r\n ThreadHandler.AfterOpen;\r\nend;\r\n\r\nprocedure TJvOdacOraQuery.DoAfterRefresh;\r\nbegin\r\n ThreadHandler.AfterRefresh;\r\nend;\r\n\r\nprocedure TJvOdacOraQuery.DoAfterScroll;\r\nbegin\r\n ThreadHandler.AfterScroll;\r\nend;\r\n\r\nprocedure TJvOdacOraQuery.DoBeforeOpen;\r\nbegin\r\n ThreadHandler.BeforeOpen;\r\nend;\r\n\r\nprocedure TJvOdacOraQuery.DoBeforeRefresh;\r\nbegin\r\n ThreadHandler.BeforeRefresh;\r\nend;\r\n\r\nfunction TJvOdacOraQuery.DoGetInheritedNextRecord: Boolean;\r\nbegin\r\n Result := Inherited GetNextRecord;\r\nend;\r\n\r\nprocedure TJvOdacOraQuery.DoInheritedAfterOpen;\r\nbegin\r\n inherited DoAfterOpen;\r\nend;\r\n\r\nprocedure TJvOdacOraQuery.DoInheritedAfterRefresh;\r\nbegin\r\n inherited DoAfterRefresh;\r\nend;\r\n\r\nprocedure TJvOdacOraQuery.DoInheritedAfterScroll;\r\nbegin\r\n inherited DoAfterScroll;\r\nend;\r\n\r\nprocedure TJvOdacOraQuery.DoInheritedBeforeOpen;\r\nbegin\r\n inherited DoBeforeOpen;\r\nend;\r\n\r\nprocedure TJvOdacOraQuery.DoInheritedBeforeRefresh;\r\nbegin\r\n inherited DoBeforeRefresh;\r\nend;\r\n\r\nprocedure TJvOdacOraQuery.DoInheritedInternalLast;\r\nbegin\r\n inherited InternalLast;\r\nend;\r\n\r\nprocedure TJvOdacOraQuery.DoInheritedInternalRefresh;\r\nbegin\r\n inherited InternalRefresh;\r\nend;\r\n\r\nprocedure TJvOdacOraQuery.DoInheritedSetActive(Active: Boolean);\r\nbegin\r\n inherited SetActive(Active);\r\nend;\r\n\r\nprocedure TJvOdacOraQuery.DoInternalOpen;\r\nbegin\r\n InternalOpen;\r\nend;\r\n\r\nfunction TJvOdacOraQuery.EofReached: Boolean;\r\nbegin\r\n if Assigned(ThreadHandler) then\r\n Result := ThreadHandler.EofReached\r\n else\r\n Result := False;\r\nend;\r\n\r\nfunction TJvOdacOraQuery.ErrorException: Exception;\r\nbegin\r\n if Assigned(ThreadHandler) then\r\n Result := ThreadHandler.ErrorException\r\n else\r\n Result := Nil;\r\nend;\r\n\r\nfunction TJvOdacOraQuery.ErrorMessage: string;\r\nbegin\r\n if Assigned(ThreadHandler) then\r\n Result := ThreadHandler.ErrorMessage\r\n else\r\n Result := '';\r\nend;\r\n\r\nfunction TJvOdacOraQuery.GetAfterOpenFetch: TDataSetNotifyEvent;\r\nbegin\r\n if Assigned(ThreadHandler) then\r\n Result := ThreadHandler.AfterOpenFetch\r\n else\r\n Result := nil;\r\nend;\r\n\r\nfunction TJvOdacOraQuery.GetAfterOpenFetch1: TDataSetNotifyEvent;\r\nbegin\r\n if Assigned(ThreadHandler) then\r\n Result := ThreadHandler.AfterOpenFetch\r\n else\r\n Result := nil;\r\nend;\r\n\r\nfunction TJvOdacOraQuery.GetAfterThreadExecution:\r\n TJvThreadedDatasetThreadEvent;\r\nbegin\r\n if Assigned(ThreadHandler) then\r\n Result := ThreadHandler.AfterThreadExecution\r\n else\r\n Result := nil;\r\nend;\r\n\r\nfunction TJvOdacOraQuery.GetBeforeThreadExecution:\r\n TJvThreadedDatasetThreadEvent;\r\nbegin\r\n if Assigned(ThreadHandler) then\r\n Result := ThreadHandler.BeforeThreadExecution\r\n else\r\n Result := nil;\r\nend;\r\n\r\nfunction TJvOdacOraQuery.GetDatasetFetchAllRecords: Boolean;\r\nbegin\r\n Result := FetchAll;\r\nend;\r\n\r\nfunction TJvOdacOraQuery.GetDialogOptions: TJvThreadedDatasetDialogOptions;\r\nbegin\r\n if Assigned(ThreadHandler) then\r\n Result := ThreadHandler.DialogOptions\r\n else\r\n Result := nil;\r\nend;\r\n\r\nfunction TJvOdacOraQuery.GetEnhancedOptions:\r\n TJvOdacThreadedDatasetEnhancedOptions;\r\nbegin\r\n if Assigned(ThreadHandler) then\r\n Result := TJvOdacThreadedDatasetEnhancedOptions(ThreadHandler.EnhancedOptions)\r\n else\r\n Result := nil;\r\nend;\r\n\r\nfunction TJvOdacOraQuery.GetNextRecord: Boolean;\r\nbegin\r\n if Assigned(ThreadHandler) then\r\n Result := ThreadHandler.GetNextRecord\r\n else\r\n Result := inherited GetNextRecord;\r\nend;\r\n\r\nfunction TJvOdacOraQuery.GetOnThreadException:\r\n TJvThreadedDatasetThreadExceptionEvent;\r\nbegin\r\n if Assigned(ThreadHandler) then\r\n Result := ThreadHandler.OnThreadException\r\n else\r\n Result := nil;\r\nend;\r\n\r\nfunction TJvOdacOraQuery.GetThreadOptions: TJvThreadedDatasetThreadOptions;\r\nbegin\r\n if Assigned(ThreadHandler) then\r\n Result := ThreadHandler.ThreadOptions\r\n else\r\n Result := nil;\r\nend;\r\n\r\nprocedure TJvOdacOraQuery.InternalLast;\r\nbegin\r\n if Assigned(ThreadHandler) then\r\n ThreadHandler.InternalLast;\r\nend;\r\n\r\nprocedure TJvOdacOraQuery.InternalRefresh;\r\nbegin\r\n if Assigned(ThreadHandler) then\r\n ThreadHandler.InternalRefresh;\r\nend;\r\n\r\nfunction TJvOdacOraQuery.IsThreadAllowed: Boolean;\r\nvar ThreadedDatasetInterface : IJvThreadedDatasetInterface;\r\nbegin\r\n if Assigned(MasterSource) and Assigned(MasterSource.Dataset)\r\n and Supports(MasterSource.DataSet, IJvThreadedDatasetInterface, ThreadedDatasetInterface) then\r\n Result := not ThreadedDatasetInterface.ThreadIsActive\r\n else\r\n Result := True;\r\nend;\r\n\r\nprocedure TJvOdacOraQuery.ReplaceBeforeFetch(Dataset: TCustomDADataSet; var\r\n Cancel: Boolean);\r\nbegin\r\n if Assigned(ThreadHandler) then\r\n Cancel := ThreadHandler.CheckContinueRecordFetch <> tdccrContinue;\r\n if Assigned(BeforeFetch) and not Cancel then\r\n BeforeFetch(Dataset, Cancel);\r\nend;\r\n\r\nprocedure TJvOdacOraQuery.SetActive(Value: Boolean);\r\nbegin\r\n if Assigned(ThreadHandler) then\r\n ThreadHandler.SetActive(Value);\r\nend;\r\n\r\nprocedure TJvOdacOraQuery.SetAfterOpenFetch(const Value: TDataSetNotifyEvent);\r\nbegin\r\n if Assigned(ThreadHandler) then\r\n ThreadHandler.AfterOpenFetch := Value;\r\nend;\r\n\r\nprocedure TJvOdacOraQuery.SetAfterOpenFetch1(const Value: TDataSetNotifyEvent);\r\nbegin\r\n if Assigned(ThreadHandler) then\r\n ThreadHandler.AfterOpenFetch := Value;\r\nend;\r\n\r\nprocedure TJvOdacOraQuery.SetAfterThreadExecution(const Value:\r\n TJvThreadedDatasetThreadEvent);\r\nbegin\r\n if Assigned(ThreadHandler) then\r\n ThreadHandler.AfterThreadExecution := Value;\r\nend;\r\n\r\nprocedure TJvOdacOraQuery.SetBeforeThreadExecution(const Value:\r\n TJvThreadedDatasetThreadEvent);\r\nbegin\r\n if Assigned(ThreadHandler) then\r\n ThreadHandler.BeforeThreadExecution := Value;\r\nend;\r\n\r\nprocedure TJvOdacOraQuery.SetDatasetFetchAllRecords(const Value: Boolean);\r\nbegin\r\n FetchAll := Value;\r\nend;\r\n\r\nprocedure TJvOdacOraQuery.SetDialogOptions(Value:\r\n TJvThreadedDatasetDialogOptions);\r\nbegin\r\n if Assigned(ThreadHandler) then\r\n ThreadHandler.DialogOptions.Assign(Value);\r\nend;\r\n\r\nprocedure TJvOdacOraQuery.SetEnhancedOptions(const Value:\r\n TJvOdacThreadedDatasetEnhancedOptions);\r\nbegin\r\n if Assigned(ThreadHandler) then\r\n ThreadHandler.EnhancedOptions.Assign(Value);\r\nend;\r\n\r\nprocedure TJvOdacOraQuery.SetOnThreadException(const Value:\r\n TJvThreadedDatasetThreadExceptionEvent);\r\nbegin\r\n if Assigned(ThreadHandler) then\r\n ThreadHandler.OnThreadException := Value;\r\nend;\r\n\r\nprocedure TJvOdacOraQuery.SetThreadOptions(const Value:\r\n TJvThreadedDatasetThreadOptions);\r\nbegin\r\n if Assigned(ThreadHandler) then\r\n ThreadHandler.ThreadOptions.Assign(Value);\r\nend;\r\n\r\nfunction TJvOdacOraQuery.ThreadIsActive: Boolean;\r\nbegin\r\n if Assigned(ThreadHandler) then\r\n Result := ThreadHandler.ThreadIsActive\r\n else\r\n Result := False;\r\nend;\r\n\r\n//=== { TJvOdacSmartQuery } ==================================================\r\n\r\nconstructor TJvOdacOraTable.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FThreadHandler := TJvOdacDatasetThreadHandler.Create(Self, Self);\r\n inherited BeforeFetch := ReplaceBeforeFetch;\r\nend;\r\n\r\ndestructor TJvOdacOraTable.Destroy;\r\nbegin\r\n FreeAndNil(FThreadHandler);\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvOdacOraTable.BreakExecution;\r\nbegin\r\n BreakExec;\r\nend;\r\n\r\nprocedure TJvOdacOraTable.BringThreadDialogToFront;\r\nbegin\r\n if Assigned(ThreadHandler) then\r\n ThreadHandler.BringDialogToFront;\r\nend;\r\n\r\nfunction TJvOdacOraTable.CurrentFetchDuration: TDateTime;\r\nbegin\r\n if Assigned(ThreadHandler) then\r\n Result := ThreadHandler.CurrentFetchDuration\r\n else\r\n Result := 0;\r\nend;\r\n\r\nfunction TJvOdacOraTable.CurrentOpenDuration: TDateTime;\r\nbegin\r\n if Assigned(ThreadHandler) then\r\n Result := ThreadHandler.CurrentOpenDuration\r\n else\r\n Result := 0;\r\nend;\r\n\r\nprocedure TJvOdacOraTable.DoAfterOpen;\r\nbegin\r\n ThreadHandler.AfterOpen;\r\nend;\r\n\r\nprocedure TJvOdacOraTable.DoAfterRefresh;\r\nbegin\r\n ThreadHandler.AfterRefresh;\r\nend;\r\n\r\nprocedure TJvOdacOraTable.DoAfterScroll;\r\nbegin\r\n ThreadHandler.AfterScroll;\r\nend;\r\n\r\nprocedure TJvOdacOraTable.DoBeforeOpen;\r\nbegin\r\n ThreadHandler.BeforeOpen;\r\nend;\r\n\r\nprocedure TJvOdacOraTable.DoBeforeRefresh;\r\nbegin\r\n ThreadHandler.BeforeRefresh;\r\nend;\r\n\r\nfunction TJvOdacOraTable.DoGetInheritedNextRecord: Boolean;\r\nbegin\r\n Result := Inherited GetNextRecord;\r\nend;\r\n\r\nprocedure TJvOdacOraTable.DoInheritedAfterOpen;\r\nbegin\r\n inherited DoAfterOpen;\r\nend;\r\n\r\nprocedure TJvOdacOraTable.DoInheritedAfterRefresh;\r\nbegin\r\n inherited DoAfterRefresh;\r\nend;\r\n\r\nprocedure TJvOdacOraTable.DoInheritedAfterScroll;\r\nbegin\r\n inherited DoAfterScroll;\r\nend;\r\n\r\nprocedure TJvOdacOraTable.DoInheritedBeforeOpen;\r\nbegin\r\n inherited DoBeforeOpen;\r\nend;\r\n\r\nprocedure TJvOdacOraTable.DoInheritedBeforeRefresh;\r\nbegin\r\n inherited DoBeforeRefresh;\r\nend;\r\n\r\nprocedure TJvOdacOraTable.DoInheritedInternalLast;\r\nbegin\r\n inherited InternalLast;\r\nend;\r\n\r\nprocedure TJvOdacOraTable.DoInheritedInternalRefresh;\r\nbegin\r\n inherited InternalRefresh;\r\nend;\r\n\r\nprocedure TJvOdacOraTable.DoInheritedSetActive(Active: Boolean);\r\nbegin\r\n inherited SetActive(Active);\r\nend;\r\n\r\nprocedure TJvOdacOraTable.DoInternalOpen;\r\nbegin\r\n InternalOpen;\r\nend;\r\n\r\nfunction TJvOdacOraTable.EofReached: Boolean;\r\nbegin\r\n if Assigned(ThreadHandler) then\r\n Result := ThreadHandler.EofReached\r\n else\r\n Result := False;\r\nend;\r\n\r\nfunction TJvOdacOraTable.ErrorException: Exception;\r\nbegin\r\n if Assigned(ThreadHandler) then\r\n Result := ThreadHandler.ErrorException\r\n else\r\n Result := Nil;\r\nend;\r\n\r\nfunction TJvOdacOraTable.ErrorMessage: string;\r\nbegin\r\n if Assigned(ThreadHandler) then\r\n Result := ThreadHandler.ErrorMessage\r\n else\r\n Result := '';\r\nend;\r\n\r\nfunction TJvOdacOraTable.GetAfterOpenFetch: TDataSetNotifyEvent;\r\nbegin\r\n if Assigned(ThreadHandler) then\r\n Result := ThreadHandler.AfterOpenFetch\r\n else\r\n Result := nil;\r\nend;\r\n\r\nfunction TJvOdacOraTable.GetAfterThreadExecution:\r\n TJvThreadedDatasetThreadEvent;\r\nbegin\r\n if Assigned(ThreadHandler) then\r\n Result := ThreadHandler.AfterThreadExecution\r\n else\r\n Result := nil;\r\nend;\r\n\r\nfunction TJvOdacOraTable.GetBeforeThreadExecution:\r\n TJvThreadedDatasetThreadEvent;\r\nbegin\r\n if Assigned(ThreadHandler) then\r\n Result := ThreadHandler.BeforeThreadExecution\r\n else\r\n Result := nil;\r\nend;\r\n\r\nfunction TJvOdacOraTable.GetDatasetFetchAllRecords: Boolean;\r\nbegin\r\n Result := FetchAll;\r\nend;\r\n\r\nfunction TJvOdacOraTable.GetDialogOptions: TJvThreadedDatasetDialogOptions;\r\nbegin\r\n if Assigned(ThreadHandler) then\r\n Result := ThreadHandler.DialogOptions\r\n else\r\n Result := nil;\r\nend;\r\n\r\nfunction TJvOdacOraTable.GetEnhancedOptions:\r\n TJvOdacThreadedDatasetEnhancedOptions;\r\nbegin\r\n if Assigned(ThreadHandler) then\r\n Result := TJvOdacThreadedDatasetEnhancedOptions(ThreadHandler.EnhancedOptions)\r\n else\r\n Result := nil;\r\nend;\r\n\r\nfunction TJvOdacOraTable.GetNextRecord: Boolean;\r\nbegin\r\n if Assigned(ThreadHandler) then\r\n Result := ThreadHandler.GetNextRecord\r\n else\r\n Result := inherited GetNextRecord;\r\nend;\r\n\r\nfunction TJvOdacOraTable.GetOnThreadException:\r\n TJvThreadedDatasetThreadExceptionEvent;\r\nbegin\r\n if Assigned(ThreadHandler) then\r\n Result := ThreadHandler.OnThreadException\r\n else\r\n Result := nil;\r\nend;\r\n\r\nfunction TJvOdacOraTable.GetThreadOptions: TJvThreadedDatasetThreadOptions;\r\nbegin\r\n if Assigned(ThreadHandler) then\r\n Result := ThreadHandler.ThreadOptions\r\n else\r\n Result := nil;\r\nend;\r\n\r\nprocedure TJvOdacOraTable.InternalLast;\r\nbegin\r\n if Assigned(ThreadHandler) then\r\n ThreadHandler.InternalLast;\r\nend;\r\n\r\nprocedure TJvOdacOraTable.InternalRefresh;\r\nbegin\r\n if Assigned(ThreadHandler) then\r\n ThreadHandler.InternalRefresh;\r\nend;\r\n\r\nfunction TJvOdacOraTable.IsThreadAllowed: Boolean;\r\nvar ThreadedDatasetInterface : IJvThreadedDatasetInterface;\r\nbegin\r\n if Assigned(MasterSource) and Assigned(MasterSource.Dataset)\r\n and Supports(MasterSource.DataSet, IJvThreadedDatasetInterface, ThreadedDatasetInterface) then\r\n Result := not ThreadedDatasetInterface.ThreadIsActive\r\n else\r\n Result := True;\r\nend;\r\n\r\nprocedure TJvOdacOraTable.ReplaceBeforeFetch(Dataset: TCustomDADataSet; var\r\n Cancel: Boolean);\r\nbegin\r\n if Assigned(ThreadHandler) then\r\n Cancel := ThreadHandler.CheckContinueRecordFetch <> tdccrContinue;\r\n if Assigned(BeforeFetch) and not Cancel then\r\n BeforeFetch(Dataset, Cancel);\r\nend;\r\n\r\nprocedure TJvOdacOraTable.SetActive(Value: Boolean);\r\nbegin\r\n if Assigned(ThreadHandler) then\r\n ThreadHandler.SetActive(Value);\r\nend;\r\n\r\nprocedure TJvOdacOraTable.SetAfterOpenFetch(const Value: TDataSetNotifyEvent);\r\nbegin\r\n if Assigned(ThreadHandler) then\r\n ThreadHandler.AfterOpenFetch := Value;\r\nend;\r\n\r\nprocedure TJvOdacOraTable.SetAfterThreadExecution(const Value:\r\n TJvThreadedDatasetThreadEvent);\r\nbegin\r\n if Assigned(ThreadHandler) then\r\n ThreadHandler.AfterThreadExecution := Value;\r\nend;\r\n\r\nprocedure TJvOdacOraTable.SetBeforeThreadExecution(const Value:\r\n TJvThreadedDatasetThreadEvent);\r\nbegin\r\n if Assigned(ThreadHandler) then\r\n ThreadHandler.BeforeThreadExecution := Value;\r\nend;\r\n\r\nprocedure TJvOdacOraTable.SetDatasetFetchAllRecords(const Value: Boolean);\r\nbegin\r\n FetchAll := Value;\r\nend;\r\n\r\nprocedure TJvOdacOraTable.SetDialogOptions(Value:\r\n TJvThreadedDatasetDialogOptions);\r\nbegin\r\n if Assigned(ThreadHandler) then\r\n ThreadHandler.DialogOptions.Assign(Value);\r\nend;\r\n\r\nprocedure TJvOdacOraTable.SetEnhancedOptions(const Value:\r\n TJvOdacThreadedDatasetEnhancedOptions);\r\nbegin\r\n if Assigned(ThreadHandler) then\r\n ThreadHandler.EnhancedOptions.Assign(Value);\r\nend;\r\n\r\nprocedure TJvOdacOraTable.SetOnThreadException(const Value:\r\n TJvThreadedDatasetThreadExceptionEvent);\r\nbegin\r\n if Assigned(ThreadHandler) then\r\n ThreadHandler.OnThreadException := Value;\r\nend;\r\n\r\nprocedure TJvOdacOraTable.SetThreadOptions(const Value:\r\n TJvThreadedDatasetThreadOptions);\r\nbegin\r\n if Assigned(ThreadHandler) then\r\n ThreadHandler.ThreadOptions.Assign(Value);\r\nend;\r\n\r\nfunction TJvOdacOraTable.ThreadIsActive: Boolean;\r\nbegin\r\n if Assigned(ThreadHandler) then\r\n Result := ThreadHandler.ThreadIsActive\r\n else\r\n Result := False;\r\nend;\r\n\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n{$ENDIF USE_3RDPARTY_DEVART_ODAC}\r\nend.\r\n\r\n" }, { "path": "External/Jedi/Jvcl/run/JvOfficeColorButton.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvOfficeColorButton.PAS, released on 2004-02-26.\r\n\r\nThe Initial Developer of the Original Code is dejoy [dejoy att ynl dott gov dott cn]\r\nAll Rights Reserved.\r\n\r\nContributor(s):dejoy.\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nDescription:\r\n A office color selection button look like Microsoft office Color picker, make to customable Highly.\r\n\r\nKnown Issues:\r\n\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvOfficeColorButton.pas 13104 2011-09-07 06:50:43Z obones $\r\n\r\nunit JvOfficeColorButton;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n SysUtils, Classes,\r\n Windows, Messages, Graphics, Controls, Forms, Dialogs,\r\n JvConsts, JvTypes, JvExControls, JvExtComponent, JvSpeedButton,\r\n JvHotTrackPersistent,\r\n JvOfficeColorForm, JvOfficeColorPanel, JvOfficeDragBarForm;\r\n\r\nconst\r\n MinArrowWidth = 9 + 4;\r\n MinButtonHeight = 22;\r\n MinButtonWidth = 22;\r\n Tag_ArrowWidth = 11;\r\n\r\ntype\r\n TJvOfficeColorButtonProperties = class(TJvOfficeColorPanelProperties)\r\n private\r\n FShowDragBar: Boolean;\r\n FFloatWindowCaption: string;\r\n FEdgeWidth: Integer;\r\n FArrowWidth: Integer;\r\n FDragBarHeight: Integer;\r\n FDragBarSpace: Integer;\r\n FDragBarHint: string;\r\n FFilerTag:string;\r\n procedure SetShowDragBar(const Value: Boolean);\r\n procedure SetFloatWindowCaption(const Value: string);\r\n procedure SetArrowWidth(const Value: Integer);\r\n procedure SetEdgeWidth(const Value: Integer);\r\n procedure SetDragBarHeight(const Value: Integer);\r\n procedure SetDragBarSpace(const Value: Integer);\r\n procedure SetDragBarHint(const Value: string);\r\n procedure ReadData(Reader: TReader);\r\n protected\r\n procedure CreateDefaultText; override;\r\n procedure DefineProperties(Filer: TFiler); override;\r\n public\r\n constructor Create(AOwner: TPersistent); override;\r\n procedure Assign(Source: TPersistent); override;\r\n published\r\n property EdgeWidth: Integer read FEdgeWidth write SetEdgeWidth default 4;\r\n property ArrowWidth: Integer read FArrowWidth write SetArrowWidth default MinArrowWidth;\r\n property ShowDragBar: Boolean read FShowDragBar write SetShowDragBar default True;\r\n property FloatWindowCaption: string read FFloatWindowCaption write SetFloatWindowCaption;\r\n property DragBarHint: string read FDragBarHint write SetDragBarHint;\r\n property DragBarHeight: Integer read FDragBarHeight write SetDragBarHeight default MinDragBarHeight;\r\n property DragBarSpace: Integer read FDragBarSpace write SetDragBarSpace default MinDragBarSpace;\r\n end;\r\n\r\n TJvOfficeColorButtonHotTrackOptions = TJvHotTrackOptions;\r\n TJvCustomOfficeColorButton = class(TJvCustomPanel, IJvHotTrack)\r\n private\r\n FMainButton: TJvColorSpeedButton;\r\n FArrowButton: TJvSpeedButton;\r\n FColorsForm: TJvOfficeColorForm;\r\n FProperties: TJvOfficeColorButtonProperties;\r\n FFlat: Boolean;\r\n FColorFormDropDown: Boolean;\r\n FFloatingBgColor: TColor;\r\n FDropingBgColor: TColor;\r\n FInited: Boolean;\r\n FColorsListChanged:Boolean;\r\n FOnColorChange: TNotifyEvent;\r\n FOnHoldCustomColor: TJvHoldCustomColorEvent;\r\n FOnDropDown: TNotifyEvent;\r\n FOnColorButtonClick: TNotifyEvent;\r\n FOnShowOwnerColorDialog: TNotifyEvent;\r\n FOnArrowClick: TNotifyEvent;\r\n FHotTrack: Boolean;\r\n FHotTrackOptions: TJvOfficeColorButtonHotTrackOptions;\r\n procedure SetFlat(const Value: Boolean);\r\n // Set Control Color\r\n procedure SetControlBgColor(const Value: TColor);\r\n function GetControlBgColor: TColor;\r\n //Set DropDown form Bg Color\r\n function GetDropingBgColor: TColor;\r\n procedure SetDropingBgColor(const Value: TColor);\r\n //Set floating DropDown form Bg Color\r\n procedure SetFloatingBgColor(const Value: TColor);\r\n procedure SetSelectedColor(const Value: TColor);\r\n function GetSelectedColor: TColor;\r\n function GetColorDlgCustomColors: TStrings;\r\n procedure SetColorDlgCustomColors(const Value: TStrings);\r\n function GetGlyph: TBitmap;\r\n procedure SetGlyph(const Value: TBitmap);\r\n function GetProperties: TJvOfficeColorButtonProperties;\r\n procedure SetProperties(const Value: TJvOfficeColorButtonProperties);\r\n function GetColorDialogOptions: TColorDialogOptions;\r\n procedure SetColorDialogOptions(const Value: TColorDialogOptions);\r\n\r\n {IJvHotTrack}\r\n function GetHotTrack: Boolean;\r\n function GetHotTrackOptions: TJvOfficeColorButtonHotTrackOptions;\r\n function GetHotTrackFont: TFont;\r\n function GetHotTrackFontOptions: TJvTrackFontOptions;\r\n\r\n procedure SetHotTrack(Value: Boolean);\r\n procedure SetHotTrackFont( Value: TFont);\r\n procedure SetHotTrackFontOptions( Value: TJvTrackFontOptions);\r\n procedure SetHotTrackOptions(Value: TJvOfficeColorButtonHotTrackOptions);\r\n procedure IJvHotTrack_Assign(Source: IJvHotTrack);\r\n procedure IJvHotTrack.Assign = IJvHotTrack_Assign;\r\n\r\n function GetStandardColors: TStringList;\r\n function GetSystemColors: TStringList;\r\n function GetUserColors: TStringList;\r\n procedure SetStandardColors(const Value: TStringList);\r\n procedure SetSystemColors(const Value: TStringList);\r\n procedure SetUserColors(const Value: TStringList);\r\n function GetStandardColorDrawers: TList;\r\n function GetSystemColorDrawers: TList;\r\n function GetUserColorDrawers: TList;\r\n function GetColorPanel: TJvOfficeColorPanel;\r\n function GetButtonOfDefaultColor: TJvColorSpeedButton;\r\n function GetButtonOfNoneColor: TJvColorSpeedButton;\r\n function GetButtonOfCustomColor: TJvColorSpeedButton;\r\n function GetClickColorType: TJvClickColorType;\r\n procedure DoHotTrackOptionsChanged(Sender: TObject);\r\n procedure DoFormShowingChanged(Sender: TObject);\r\n// procedure DoFormKillFocus(Sender: TObject);\r\n procedure DoFormClose(Sender: TObject; var Action: TCloseAction);\r\n procedure DoFormWindowStyleChanged(Sender: TObject);\r\n procedure DoButtonMouseEnter(Sender: TObject);\r\n procedure DoButtonMouseLeave(Sender: TObject);\r\n procedure DoArrowButtonClick(Sender: TObject);\r\n procedure DoOnColorChange(Sender: TObject);\r\n procedure DoColorButtonClick(Sender: TObject);\r\n procedure DoClick(Sender: TObject);\r\n procedure DoColorsListChanged(Sender: TObject);\r\n procedure DoHoldedCustomColor(Sender: TObject;AColor: TColor);\r\n function GetAddInControls: TList;\r\n protected\r\n procedure CMPopupCloseUp(var Msg: TMessage); message CM_POPUPCLOSEUP;\r\n procedure CMCancelMode(var Msg: TCMCancelMode); message CM_CANCELMODE;\r\n procedure PopupCloseUp; virtual;\r\n procedure FocusKilled(NextWnd: THandle); override;\r\n\r\n procedure AdjustColorForm(X: Integer = 0; Y: Integer = 0); //Screen position\r\n procedure ShowColorForm(X: Integer = 0; Y: Integer = 0); virtual; //Screen position\r\n class function GetColorsPanelClass: TJvOfficeColorPanelClass;\r\n procedure CreateWnd; override;\r\n procedure Loaded; override;\r\n procedure SetEnabled( Value: Boolean); override;\r\n procedure FontChanged; override;\r\n\r\n function CreateStandardColors(ColorList: TStrings): Integer; virtual;\r\n function CreateSystemColors(ColorList: TStrings): Integer; virtual;\r\n //if you wnat to create published color list by default,override this procedure.\r\n function CreateUserColors(ColorList: TStrings): Integer; virtual;\r\n\r\n //Do't change the following list, The result might unpredictability.\r\n property StandardColorDrawers: TList read GetStandardColorDrawers;\r\n property SystemColorDrawers: TList read GetSystemColorDrawers;\r\n property UserColorDrawers: TList read GetUserColorDrawers;\r\n property AddInControls: TList read GetAddInControls;\r\n\r\n property ButtonNoneColor: TJvColorSpeedButton read GetButtonOfNoneColor;\r\n property ButtonDefaultColor: TJvColorSpeedButton read GetButtonOfDefaultColor;\r\n property ButtonCustomColor: TJvColorSpeedButton read GetButtonOfCustomColor;\r\n\r\n procedure DoPropertiesChanged(Sender: TObject; const PropName: string); virtual;\r\n property ColorPanel: TJvOfficeColorPanel read GetColorPanel;\r\n property ColorsForm: TJvOfficeColorForm read FColorsForm;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n\r\n procedure CreateStandardColorDrawers; virtual;\r\n procedure CreateSystemColorDrawers; virtual;\r\n procedure CreateUserColorDrawers; virtual;\r\n procedure RearrangeControls; virtual;\r\n procedure RefreshControls;\r\n\r\n procedure AdjustSize; override;\r\n property Flat: Boolean read FFlat write SetFlat default True;\r\n property Color: TColor read GetControlBgColor write SetControlBgColor default clBtnFace;\r\n property BackColor: TColor read GetControlBgColor write SetControlBgColor default clBtnFace;\r\n property DropingBgColor: TColor read GetDropingBgColor write SetDropingBgColor default clBtnFace;\r\n property FloatingBgColor: TColor read FFloatingBgColor write SetFloatingBgColor default clBtnFace;\r\n property SelectedColor: TColor read GetSelectedColor write SetSelectedColor default clBlack; // COLOR SELECTED IN THE BUTTON.\r\n property ColorDlgCustomColors: TStrings read GetColorDlgCustomColors write SetColorDlgCustomColors;\r\n property ClickColorType: TJvClickColorType read GetClickColorType ;\r\n property Properties: TJvOfficeColorButtonProperties read GetProperties write SetProperties;\r\n property ColorDialogOptions: TColorDialogOptions read GetColorDialogOptions write SetColorDialogOptions default [];\r\n property StandardColors: TStringList read GetStandardColors write SetStandardColors;\r\n property SystemColors: TStringList read GetSystemColors write SetSystemColors;\r\n property UserColors: TStringList read GetUserColors write SetUserColors;\r\n property Glyph: TBitmap read GetGlyph write SetGlyph;\r\n property HotTrack: Boolean read GetHotTrack write SetHotTrack default False;\r\n property HotTrackFont: TFont read GetHotTrackFont write SetHotTrackFont;\r\n property HotTrackFontOptions: TJvTrackFontOptions read GetHotTrackFontOptions write SetHotTrackFontOptions default\r\n DefaultTrackFontOptions;\r\n property HotTrackOptions: TJvOfficeColorButtonHotTrackOptions read GetHotTrackOptions write SetHotTrackOptions;\r\n property OnDropDown: TNotifyEvent read FOnDropDown write FOnDropDown;\r\n property OnColorChange: TNotifyEvent read FOnColorChange write FOnColorChange;\r\n property OnArrowClick: TNotifyEvent read FOnArrowClick write FOnArrowClick;\r\n property OnColorButtonClick: TNotifyEvent read FOnColorButtonClick write FOnColorButtonClick;\r\n property OnHoldCustomColor: TJvHoldCustomColorEvent read FOnHoldCustomColor write\r\n FOnHoldCustomColor;\r\n property OnShowOwnerColorDialog: TNotifyEvent read FOnShowOwnerColorDialog write FOnShowOwnerColorDialog;\r\n end;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvOfficeColorButton = class(TJvCustomOfficeColorButton)\r\n private\r\n FFilerTag: string;\r\n procedure ReadData(Reader: TReader);\r\n protected\r\n procedure DefineProperties(Filer: TFiler); override;\r\n published\r\n // UserColors must be load fist on read from the DFM file.\r\n property UserColors;\r\n property ColorDialogOptions;\r\n property BiDiMode;\r\n property DragCursor;\r\n property DragKind;\r\n property ParentBiDiMode;\r\n property OnCanResize;\r\n property Align;\r\n property Anchors;\r\n property Constraints;\r\n property DragMode;\r\n property Enabled;\r\n property Font;\r\n property ParentFont;\r\n property ParentShowHint;\r\n property PopupMenu;\r\n property ShowHint;\r\n property TabOrder;\r\n property TabStop default True;\r\n property Visible;\r\n property Flat;\r\n property BackColor; // basic Control bg color.\r\n property DropingBgColor;// DropDown Color panel bg Color.\r\n property FloatingBgColor; //floating DropDown Color panel bg Color.\r\n property SelectedColor;\r\n\r\n property HotTrack;\r\n property HotTrackFont;\r\n property HotTrackFontOptions;\r\n property HotTrackOptions;\r\n property ColorDlgCustomColors;\r\n property Glyph;\r\n property Properties;\r\n property OnConstrainedResize;\r\n property OnResize;\r\n property OnDropDown;\r\n property OnArrowClick;\r\n property OnColorChange;\r\n property OnColorButtonClick;\r\n\r\n//if OnShowOwnerColorDialog not nil,the default ColorDialog will not show,\r\n//so you can show coustom ColorDialog yourself.\r\n property OnShowOwnerColorDialog;\r\n property OnClick;\r\n\r\n property Action;\r\n property OnContextPopup;\r\n property OnDblClick;\r\n property OnDragDrop;\r\n property OnDragOver;\r\n property OnEndDock;\r\n property OnEndDrag;\r\n property OnEnter;\r\n property OnExit;\r\n property OnKeyDown;\r\n property OnKeyPress;\r\n property OnKeyUp;\r\n property OnMouseDown;\r\n property OnMouseEnter;\r\n property OnMouseLeave;\r\n property OnMouseMove;\r\n property OnMouseUp;\r\n property OnStartDock;\r\n property OnStartDrag;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvOfficeColorButton.pas $';\r\n Revision: '$Revision: 13104 $';\r\n Date: '$Date: 2011-09-07 08:50:43 +0200 (mer. 07 sept. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n JvResources, JvJVCLUtils, JvThemes, JvComponent;\r\n\r\nconst\r\n cArrowWidth = 'ArrowWidth';\r\n cDragBarHeight = 'DragBarHeight';\r\n cDragBarHint = 'DragBarHint';\r\n cDragBarSpace = 'DragBarSpace';\r\n cFloatWindowCaption = 'FloatWindowCaption';\r\n cEdgeWidth = 'EdgeWidth';\r\n cShowDragBar = 'ShowDragBar';\r\n\r\ntype\r\n TColorSpeedButtonAccessProtected = class(TJvColorSpeedButton);\r\n TJvOfficeColorFormAccessProtected = class(TJvOfficeColorForm);\r\n TJvOfficeColorPanelAccessProtected = class(TJvOfficeColorPanel);\r\n\r\n//=== { TJvColorArrowButton } ================================================\r\n\r\ntype\r\n TArrowColor = record\r\n Enabled: TColor;\r\n Disabled: TColor;\r\n end;\r\n\r\n TJvColorArrowButton = class(TJvSpeedButton)\r\n private\r\n FArrowColor: TArrowColor;\r\n FArrowDirection: TAnchorKind;\r\n procedure SetArrowColor(const Value: TArrowColor);\r\n procedure SetArrowDirection(const Value: TAnchorKind);\r\n protected\r\n procedure Paint; override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n property ArrowColor: TArrowColor read FArrowColor write SetArrowColor;\r\n property ArrowDirection: TAnchorKind read FArrowDirection write SetArrowDirection default akBottom;\r\n end;\r\n\r\nconstructor TJvColorArrowButton.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FArrowDirection := akBottom;\r\n FArrowColor.Enabled := clBlack;\r\n FArrowColor.Disabled := clBtnShadow;\r\nend;\r\n\r\nprocedure TJvColorArrowButton.SetArrowDirection(const Value: TAnchorKind);\r\nbegin\r\n if FArrowDirection <> Value then\r\n begin\r\n FArrowDirection := Value;\r\n Repaint;\r\n end;\r\nend;\r\n\r\nprocedure TJvColorArrowButton.SetArrowColor(const Value: TArrowColor);\r\nbegin\r\n if (FArrowColor.Enabled <> Value.Enabled) and (FArrowColor.Disabled <> Value.Disabled) then\r\n begin\r\n FArrowColor := Value;\r\n Repaint;\r\n end;\r\nend;\r\n\r\nprocedure TJvColorArrowButton.Paint;\r\nvar\r\n PaintRect: TRect;\r\nbegin\r\n inherited Paint;\r\n\r\n { calculate were to put arrow part }\r\n PaintRect := Rect(3, 0, Width - 3, Height);\r\n {$IFDEF JVCLThemesEnabled}\r\n if ThemeServices.{$IFDEF RTL230_UP}Enabled{$ELSE}ThemesEnabled{$ENDIF RTL230_UP} then\r\n Dec(PaintRect.Left);\r\n {$ENDIF JVCLThemesEnabled}\r\n\r\n { Draw arrow }\r\n if Enabled then\r\n DrawArrow(Canvas, PaintRect, ArrowColor.Enabled, ArrowDirection)\r\n else\r\n DrawArrow(Canvas, PaintRect, ArrowColor.Disabled, ArrowDirection);\r\nend;\r\n\r\n//=== { TJvColorMainButton } =================================================\r\n\r\ntype\r\n TJvColorMainButton = class(TJvColorSpeedButton)\r\n protected\r\n function GetEdgeWidth: Integer; override;\r\n end;\r\n\r\nfunction TJvColorMainButton.GetEdgeWidth: Integer;\r\nbegin\r\n Result := FEdgeWidth;\r\nend;\r\n\r\n//=== { TJvCustomOfficeColorButton } =========================================\r\n\r\nconstructor TJvCustomOfficeColorButton.Create(AOwner: TComponent);\r\nvar\r\n LArrowColor: TArrowColor;\r\n LOwner: TComponent;\r\n LColorsChanged: Boolean;\r\nbegin\r\n inherited Create(AOwner);\r\n FInited := False;\r\n FHotTrack := False;\r\n FFloatingBgColor := clBtnFace;\r\n FDropingBgColor := clBtnFace;\r\n TabStop := True;\r\n\r\n ControlStyle := ControlStyle - [csAcceptsControls, csSetCaption] + [csOpaque];\r\n BevelOuter := bvNone;\r\n Locked := True;\r\n Width := MinButtonWidth + MinArrowWidth;\r\n Height := MinButtonHeight;\r\n\r\n FHotTrackOptions := TJvOfficeColorButtonHotTrackOptions.Create(Self);\r\n FHotTrackOptions.OnChanged := DoHotTrackOptionsChanged;\r\n\r\n FMainButton := TJvColorMainButton.Create(Self);\r\n with FMainButton do\r\n begin\r\n Parent := Self;\r\n NumGlyphs := 2;\r\n DrawColor := clBlack;\r\n Tag := StandardColCount + 3;\r\n OnClick := DoClick;\r\n end;\r\n\r\n FArrowButton := TJvColorArrowButton.Create(Self);\r\n with TJvColorArrowButton(FArrowButton) do\r\n begin\r\n Parent := Self;\r\n GroupIndex := 2;\r\n AllowAllUp := True;\r\n Tag := StandardColCount + 4;\r\n ArrowDirection := akBottom;\r\n LArrowColor.Enabled := clBlack;\r\n LArrowColor.Disabled := clBtnShadow;\r\n ArrowColor := LArrowColor;\r\n OnClick := DoArrowButtonClick;\r\n end;\r\n\r\n FColorsForm := TJvOfficeColorForm.Create(Self, GetColorsPanelClass);\r\n with TJvOfficeColorFormAccessProtected(FColorsForm) do\r\n begin\r\n IsFocusable := False;\r\n FormStyle := fsStayOnTop;\r\n ToolWindowStyle := False;\r\n OnShowingChanged := DoFormShowingChanged;\r\n// OnKillFocus := DoFormKillFocus;\r\n OnClose := DoFormClose;\r\n OnWindowStyleChanged := DoFormWindowStyleChanged;\r\n\r\n ColorPanel.OnColorChange := DoOnColorChange;\r\n ColorPanel.OnColorButtonClick := DoColorButtonClick;\r\n ColorPanel.OnHoldCustomColor := DoHoldedCustomColor;\r\n end;\r\n\r\n FProperties := TJvOfficeColorButtonProperties.Create(Self);\r\n FProperties.Assign(ColorPanel.Properties);\r\n FProperties.OnChangedProperty := DoPropertiesChanged;\r\n\r\n FColorsListChanged:= False;\r\n StandardColors.BeginUpdate;\r\n StandardColors.OnChange := DoColorsListChanged;\r\n try\r\n CreateStandardColors(StandardColors);\r\n finally\r\n StandardColors.EndUpdate;\r\n StandardColors.OnChange := nil;\r\n end;\r\n if FColorsListChanged then // Changed the colors value, recreate buttons\r\n CreateStandardColorDrawers;\r\n LColorsChanged := FColorsListChanged;\r\n\r\n FColorsListChanged:= False;\r\n SystemColors.BeginUpdate;\r\n SystemColors.OnChange := DoColorsListChanged;\r\n try\r\n CreateSystemColors(SystemColors);\r\n finally\r\n SystemColors.EndUpdate;\r\n SystemColors.OnChange := nil;\r\n end;\r\n if FColorsListChanged then //Changed the colors value,recreate buttons\r\n CreateSystemColorDrawers;\r\n LColorsChanged := LColorsChanged or FColorsListChanged;\r\n\r\n LOwner := GetTopOwner(Self);\r\n // make sure that if this is not loading from DFM file or stream.\r\n if (LOwner <> nil) and (LOwner.ComponentState * [csReading, csLoading] = []) then\r\n begin\r\n FColorsListChanged := False;\r\n UserColors.BeginUpdate;\r\n UserColors.OnChange := DoColorsListChanged;\r\n UserColors.EndUpdate;\r\n\r\n CreateUserColors(UserColors);\r\n UserColors.OnChange := nil;\r\n if FColorsListChanged then // Changed the colors value, recreate buttons\r\n CreateUserColorDrawers;\r\n LColorsChanged := LColorsChanged or FColorsListChanged;\r\n FProperties.CreateDefaultText;\r\n end;\r\n FColorsListChanged := False;\r\n\r\n if LColorsChanged then //StandardColors or SystemColors Or userColors changed.\r\n RearrangeControls;\r\n\r\n //Font.Name := 'MS Shell Dlg 2';\r\n Flat := True;\r\n FMainButton.OnMouseEnter := DoButtonMouseEnter;\r\n FArrowButton.OnMouseEnter := DoButtonMouseEnter;\r\n FMainButton.OnMouseLeave := DoButtonMouseLeave;\r\n FArrowButton.OnMouseLeave := DoButtonMouseLeave;\r\n\r\n FInited := True;\r\nend;\r\n\r\ndestructor TJvCustomOfficeColorButton.Destroy;\r\nbegin\r\n if FColorsForm.Visible then\r\n begin\r\n with TJvOfficeColorFormAccessProtected(FColorsForm) do\r\n begin\r\n OnShowingChanged := nil;\r\n OnKillFocus := nil;\r\n OnClose := nil;\r\n OnWindowStyleChanged := nil;\r\n\r\n ColorPanel.OnColorChange := nil;\r\n ColorPanel.OnColorButtonClick := nil;\r\n Hide;\r\n end;\r\n end;\r\n FreeAndNil(FProperties);\r\n FHotTrackOptions.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvCustomOfficeColorButton.AdjustSize;\r\nbegin\r\n if FInited then\r\n with Properties do\r\n begin\r\n if ArrowWidth < MinArrowWidth then\r\n ArrowWidth := MinArrowWidth;\r\n if (Width - ArrowWidth) < MinButtonWidth then\r\n Width := MinButtonWidth + ArrowWidth;\r\n if Height < MinButtonHeight then\r\n Height := MinButtonHeight;\r\n\r\n FMainButton.SetBounds(0, 0, Width - FArrowWidth, Height);\r\n\r\n FArrowButton.SetBounds(FMainButton.Width, 0, ArrowWidth, Height);\r\n end;\r\n inherited AdjustSize;\r\nend;\r\n\r\nclass function TJvCustomOfficeColorButton.GetColorsPanelClass: TJvOfficeColorPanelClass;\r\nbegin\r\n Result := TJvOfficeColorPanel;\r\nend;\r\n\r\n\r\nprocedure TJvCustomOfficeColorButton.CreateWnd;\r\nbegin\r\n inherited CreateWnd;\r\n AdjustSize;\r\nend;\r\n\r\n\r\ntype\r\n TControlAccessProtected = class(TControl);\r\n\r\nprocedure TJvCustomOfficeColorButton.Loaded;\r\nbegin\r\n inherited Loaded;\r\n TControlAccessProtected(ColorsForm.ColorPanel).Loaded;\r\nend;\r\n\r\nprocedure TJvCustomOfficeColorButton.SetEnabled( Value: Boolean);\r\nbegin\r\n inherited SetEnabled(Value);\r\n FMainButton.Enabled := Value;\r\n FArrowButton.Enabled := Value;\r\n ColorPanel.Enabled := Value;\r\nend;\r\n\r\nprocedure TJvCustomOfficeColorButton.FontChanged;\r\nbegin\r\n inherited FontChanged;\r\n FColorsForm.Font.Assign(Font);\r\nend;\r\n\r\n\r\nfunction TJvCustomOfficeColorButton.CreateStandardColors(ColorList: TStrings): Integer;\r\nbegin\r\n Result := ColorList.Count;\r\n { Because in ColorPanel the same name function has inited, so do nothing here.\r\n If you want to change ColorList,make sure call Strings.BeginUpdate before change,\r\n and call Strings.EndUpdate after changed. }\r\nend;\r\n\r\nfunction TJvCustomOfficeColorButton.CreateSystemColors(ColorList: TStrings): Integer;\r\nbegin\r\n Result := ColorList.Count;\r\n { Because in ColorPanel the same name function has inited, so do nothing here.\r\n If you want to change ColorList, make sure call strings.BeginUpdate before change,\r\n and call Strings.EndUpdate after changed. }\r\nend;\r\n\r\nfunction TJvCustomOfficeColorButton.CreateUserColors(ColorList: TStrings): Integer;\r\nbegin\r\n Result := ColorList.Count;\r\n { Because in ColorPanel the same name function has inited, so do nothing here.\r\n If you want to change ColorList, make sure call strings.BeginUpdate before change,\r\n and call Strings.EndUpdate after changed. }\r\nend;\r\n\r\nprocedure TJvCustomOfficeColorButton.RearrangeControls;\r\nbegin\r\n ColorPanel.RearrangeControls;\r\n AdjustSize;\r\nend;\r\n\r\nprocedure TJvCustomOfficeColorButton.CreateStandardColorDrawers;\r\nbegin\r\n ColorPanel.CreateStandardColorDrawers;\r\nend;\r\n\r\nprocedure TJvCustomOfficeColorButton.CreateSystemColorDrawers;\r\nbegin\r\n ColorPanel.CreateSystemColorDrawers;\r\nend;\r\n\r\nprocedure TJvCustomOfficeColorButton.CreateUserColorDrawers;\r\nbegin\r\n ColorPanel.CreateUserColorDrawers;\r\nend;\r\n\r\nprocedure TJvCustomOfficeColorButton.RefreshControls;\r\nbegin\r\n if Properties.ShowStandardColors then\r\n CreateStandardColorDrawers;\r\n if Properties.ShowSystemColors then\r\n CreateSystemColorDrawers;\r\n if Properties.ShowUserColors then\r\n CreateUserColorDrawers;\r\n RearrangeControls;\r\nend;\r\n\r\nprocedure TJvCustomOfficeColorButton.DoArrowButtonClick(Sender: TObject);\r\nbegin\r\n SetFocus;\r\n if Sender = FArrowButton then\r\n begin\r\n if FColorsForm.Visible or FColorFormDropDown then\r\n PopupCloseUp\r\n else\r\n begin\r\n if Assigned(FOnDropDown) then\r\n FOnDropDown(Self);\r\n ShowColorForm;\r\n FColorFormDropDown := True;\r\n end\r\n end\r\n else\r\n begin\r\n TJvColorSpeedButton(Sender).Down := True;\r\n SetSelectedColor(TJvColorSpeedButton(Sender).DrawColor);\r\n end;\r\n if Assigned(FOnArrowClick) then\r\n FOnArrowClick(Self);\r\nend;\r\n\r\nprocedure TJvCustomOfficeColorButton.DoColorButtonClick(Sender: TObject);\r\nbegin\r\n if Assigned(FOnColorButtonClick) then\r\n FOnColorButtonClick(Sender);\r\n\r\n if (ColorPanel.ClickColorType = cctCustomColor) and\r\n Assigned(FOnShowOwnerColorDialog) then\r\n ColorPanel.OnShowOwnerColorDialog := FOnShowOwnerColorDialog\r\n else\r\n ColorPanel.OnShowOwnerColorDialog := nil;\r\n\r\n if not FColorsForm.ToolWindowStyle then\r\n begin\r\n FColorsForm.Hide; //Auto hide color form when form not floating\r\n FColorsForm.ToolWindowStyle := False;\r\n if FArrowButton.Down then\r\n FArrowButton.Down := False;\r\n FColorFormDropDown := False;\r\n end\r\n else\r\n if ColorPanel.ClickColorType = cctCustomColor then\r\n //set formStyle to fsNormal,or else the ColorFrom will stay on top of system select ColorDialog.\r\n FColorsForm.FormStyle := fsNormal;\r\nend;\r\n\r\nfunction TJvCustomOfficeColorButton.GetColorDlgCustomColors: TStrings;\r\nbegin\r\n Result := ColorPanel.ColorDlgCustomColors;\r\nend;\r\n\r\nfunction TJvCustomOfficeColorButton.GetSelectedColor: TColor;\r\nbegin\r\n Result := ColorPanel.SelectedColor;\r\nend;\r\n\r\nprocedure TJvCustomOfficeColorButton.DoHotTrackOptionsChanged(Sender: TObject);\r\nbegin\r\n FMainButton.HotTrackOptions := FHotTrackOptions;\r\n FArrowButton.HotTrackOptions := FHotTrackOptions;\r\n ColorPanel.HotTrackOptions := FHotTrackOptions;\r\nend;\r\n\r\nprocedure TJvCustomOfficeColorButton.DoOnColorChange(Sender: TObject);\r\nbegin\r\n FMainButton.DrawColor := SelectedColor;\r\n if FColorsForm.ToolWindowStyle and (FColorsForm.FormStyle <> fsStayOnTop) then\r\n FColorsForm.FormStyle := fsStayOnTop;\r\n if ColorPanel.ClickColorType = cctCustomColor then\r\n ColorPanel.OnShowOwnerColorDialog := nil;\r\n if Assigned(FOnColorChange) then\r\n FOnColorChange(Self);\r\nend;\r\n\r\nprocedure TJvCustomOfficeColorButton.SetColorDlgCustomColors(const Value: TStrings);\r\nbegin\r\n ColorPanel.ColorDlgCustomColors.Assign(Value);\r\nend;\r\n\r\nprocedure TJvCustomOfficeColorButton.SetFlat(const Value: Boolean);\r\nbegin\r\n if FFlat <> Value then\r\n begin\r\n FFlat := Value;\r\n FMainButton.Flat := Value;\r\n FArrowButton.Flat := Value;\r\n FColorsForm.Flat := Value;\r\n end;\r\nend;\r\n\r\n// NEW: Set Control Background Color\r\nprocedure TJvCustomOfficeColorButton.SetControlBgColor(const Value: TColor);\r\nbegin\r\n if Value <> FArrowButton.Color then\r\n begin\r\n inherited Color := Value;\r\n FMainButton.Color := Value;\r\n FArrowButton.Color := Value;\r\n end;\r\nend;\r\n\r\nfunction TJvCustomOfficeColorButton.GetControlBgColor: TColor;\r\nbegin\r\n Result := FArrowButton.Color;\r\nend;\r\n\r\nfunction TJvCustomOfficeColorButton.GetDropingBgColor: TColor;\r\nbegin\r\n Result := FDropingBgColor;\r\nend;\r\n\r\nprocedure TJvCustomOfficeColorButton.SetDropingBgColor(const Value: TColor);\r\nbegin\r\n if FDropingBgColor <> Value then\r\n begin\r\n FDropingBgColor := Value;\r\n if not ColorsForm.ToolWindowStyle then\r\n begin\r\n FColorsForm.Color := Value;\r\n ColorPanel.BackColor := Value;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomOfficeColorButton.SetFloatingBgColor(const Value: TColor);\r\nbegin\r\n if FFloatingBgColor <> Value then\r\n begin\r\n FFloatingBgColor := Value;\r\n if ColorsForm.ToolWindowStyle then\r\n begin\r\n FColorsForm.Color := FloatingBgColor;\r\n ColorPanel.BackColor := FloatingBgColor;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomOfficeColorButton.SetSelectedColor(const Value: TColor);\r\nbegin\r\n if ColorPanel.SelectedColor <> Value then\r\n ColorPanel.SelectedColor := Value;\r\nend;\r\n\r\nprocedure TJvCustomOfficeColorButton.AdjustColorForm(X: Integer; Y: Integer);\r\nvar\r\n Pt: TPoint;\r\nbegin\r\n if (X = 0) and (Y = 0) then\r\n Pt := ClientToScreen(Point(FMainButton.Left, FMainButton.Top))\r\n else\r\n Pt := Point(X, Y);\r\n\r\n FColorsForm.Left := Pt.X;\r\n if (FColorsForm.Left + FColorsForm.Width) > Screen.Width then\r\n FColorsForm.Left := Screen.Width - FColorsForm.Width;\r\n FColorsForm.Top := Pt.Y + Height;\r\n if (FColorsForm.Top + FColorsForm.Height) > Screen.Height then\r\n FColorsForm.Top := Pt.Y - FColorsForm.Height;\r\nend;\r\n\r\nprocedure TJvCustomOfficeColorButton.ShowColorForm(X: Integer; Y: Integer);\r\nbegin\r\n AdjustColorForm(X, Y);\r\n FColorsForm.ShowNoActivate(True);\r\n FColorFormDropDown := True;\r\nend;\r\n\r\nprocedure TJvCustomOfficeColorButton.CMCancelMode(var Msg: TCMCancelMode);\r\nbegin\r\n if (Msg.Sender <> Self) and (Msg.Sender <> FColorsForm) and\r\n Assigned(FColorsForm) and not FColorsForm.ContainsControl(Msg.Sender) then\r\n PopupCloseUp;\r\nend;\r\n\r\nprocedure TJvCustomOfficeColorButton.CMPopupCloseUp(var Msg: TMessage);\r\nbegin\r\n PopupCloseUp;\r\nend;\r\n\r\nprocedure TJvCustomOfficeColorButton.PopupCloseUp;\r\nbegin\r\n if Assigned(ColorsForm) and ColorsForm.Visible then\r\n FColorsForm.Hide;\r\n FColorFormDropDown := False;\r\n FArrowButton.Down := False;\r\nend;\r\n\r\nprocedure TJvCustomOfficeColorButton.DoFormShowingChanged(Sender: TObject);\r\nbegin\r\n if not FColorsForm.Visible and not (csDesigning in ComponentState) then\r\n begin\r\n FArrowButton.Down := False;\r\n TColorSpeedButtonAccessProtected(FArrowButton).MouseLeave(FArrowButton);\r\n TColorSpeedButtonAccessProtected(FMainButton).MouseLeave(FMainButton);\r\n end;\r\nend;\r\n\r\n{procedure TJvCustomOfficeColorButton.DoFormKillFocus(Sender: TObject);\r\nvar\r\n R: TRect;\r\n P: TPoint;\r\nbegin\r\n R := FArrowButton.ClientRect;\r\n GetCursorPos(P);\r\n P := FArrowButton.ScreenToClient(P);\r\n if (not FColorsForm.ToolWindowStyle) and (not PtInRect(R, P)) then //mouse in ArrowButton\r\n begin\r\n FColorsForm.Hide;\r\n FColorsForm.ToolWindowStyle := False;\r\n if FArrowButton.Down then\r\n FArrowButton.Down := False;\r\n FColorFormDropDown := False;\r\n end;\r\nend;}\r\n\r\nprocedure TJvCustomOfficeColorButton.FocusKilled(NextWnd: THandle);\r\nvar\r\n Sender: TWinControl;\r\n Focused: Boolean;\r\nbegin\r\n inherited FocusKilled(NextWnd);\r\n Focused := Screen.ActiveControl <> Self;\r\n if not Focused then\r\n begin\r\n Sender := FindControl(NextWnd);\r\n if (Sender <> Self) and (Sender <> FColorsForm) and\r\n Assigned(FColorsForm) and not FColorsForm.ContainsControl(Sender) then\r\n begin\r\n { MSDN : While processing this message (WM_KILLFOCUS), do not make any\r\n function calls that display or activate a window. }\r\n PostMessage(Handle, CM_POPUPCLOSEUP, 0, 0);\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomOfficeColorButton.DoFormClose(Sender: TObject; var Action: TCloseAction);\r\nbegin\r\n if FColorsForm.ToolWindowStyle then\r\n FColorFormDropDown := False;\r\n if csDestroying in ComponentState then\r\n Action := caFree\r\n else\r\n Action := caHide;\r\nend;\r\n\r\nprocedure TJvCustomOfficeColorButton.DoFormWindowStyleChanged(Sender: TObject);\r\nbegin\r\n if not (csDesigning in ComponentState) then\r\n if FColorsForm.ToolWindowStyle then\r\n begin\r\n FArrowButton.Down := False;\r\n ColorsForm.Color := FloatingBgColor;\r\n ColorPanel.BackColor := FloatingBgColor;\r\n TColorSpeedButtonAccessProtected(FArrowButton).MouseLeave(FArrowButton);\r\n TColorSpeedButtonAccessProtected(FMainButton).MouseLeave(FMainButton);\r\n end\r\n else\r\n begin\r\n ColorsForm.Color := DropingBgColor;\r\n ColorPanel.BackColor := DropingBgColor;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomOfficeColorButton.DoButtonMouseEnter(Sender: TObject);\r\nbegin\r\n if FFlat and Enabled and not (csDesigning in ComponentState) then\r\n begin\r\n TColorSpeedButtonAccessProtected(FMainButton).MouseEnter(FMainButton);\r\n TColorSpeedButtonAccessProtected(FArrowButton).MouseEnter(FArrowButton);\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomOfficeColorButton.DoButtonMouseLeave(Sender: TObject);\r\nbegin\r\n if FFlat and Enabled and not (csDesigning in ComponentState) then\r\n begin\r\n if Sender = FMainButton then\r\n begin\r\n if FColorsForm.Visible then\r\n TColorSpeedButtonAccessProtected(FMainButton).MouseEnter(FMainButton)\r\n else\r\n TColorSpeedButtonAccessProtected(FArrowButton).MouseLeave(FArrowButton);\r\n end\r\n else\r\n if Sender = FArrowButton then\r\n begin\r\n if not FColorsForm.Visible then\r\n TColorSpeedButtonAccessProtected(FMainButton).MouseLeave(FMainButton)\r\n else\r\n TColorSpeedButtonAccessProtected(FArrowButton).MouseEnter(FArrowButton);\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJvCustomOfficeColorButton.GetGlyph: TBitmap;\r\nbegin\r\n Result := FMainButton.Glyph;\r\nend;\r\n\r\nprocedure TJvCustomOfficeColorButton.SetGlyph(const Value: TBitmap);\r\nbegin\r\n if FMainButton.Glyph <> Value then\r\n FMainButton.Glyph := Value;\r\nend;\r\n\r\n\r\n\r\nfunction TJvCustomOfficeColorButton.GetColorDialogOptions: TColorDialogOptions;\r\nbegin\r\n Result := ColorPanel.ColorDialogOptions;\r\nend;\r\n\r\nprocedure TJvCustomOfficeColorButton.SetColorDialogOptions(const Value: TColorDialogOptions);\r\nbegin\r\n ColorPanel.ColorDialogOptions := Value;\r\nend;\r\n\r\n\r\n\r\nfunction TJvCustomOfficeColorButton.GetProperties: TJvOfficeColorButtonProperties;\r\nbegin\r\n Result := FProperties;\r\nend;\r\n\r\nprocedure TJvCustomOfficeColorButton.SetProperties(const Value: TJvOfficeColorButtonProperties);\r\nbegin\r\n if (FProperties <> Value) and (Value <> nil) then\r\n begin\r\n FProperties.Assign(Value);\r\n ColorPanel.Properties.Assign(Value);\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomOfficeColorButton.DoPropertiesChanged(Sender: TObject; const PropName: string);\r\nbegin\r\n if SameText(PropName, cShowDragBar) then\r\n begin\r\n if FColorsForm.ShowDragBar <> Properties.ShowDragBar then\r\n FColorsForm.ShowDragBar := Properties.ShowDragBar;\r\n if not Properties.ShowDragBar and\r\n TJvOfficeColorFormAccessProtected(FColorsForm).DropDownMoved then\r\n AdjustColorForm;\r\n end\r\n else\r\n if SameText(PropName, cFloatWindowCaption) then\r\n FColorsForm.Caption := Properties.FloatWindowCaption\r\n else\r\n if SameText(PropName, cDragBarHeight) then\r\n begin\r\n FColorsForm.DragBarHeight := Properties.DragBarHeight;\r\n AdjustColorForm;\r\n end\r\n else\r\n if SameText(PropName, cDragBarHint) then\r\n FColorsForm.DragBarHint := Properties.DragBarHint\r\n else\r\n if SameText(PropName, cDragBarSpace) then\r\n begin\r\n FColorsForm.DragBarSpace := Properties.DragBarSpace;\r\n AdjustColorForm;\r\n end\r\n else\r\n if SameText(PropName, cArrowWidth) then\r\n AdjustSize\r\n else\r\n if SameText(PropName, cEdgeWidth) then\r\n FMainButton.EdgeWidth := Properties.EdgeWidth\r\n else\r\n begin\r\n with ColorsForm.ColorPanel,Properties do\r\n begin\r\n Assign(Self.Properties);\r\n OnChangedProperty(Properties,PropName);\r\n end;\r\n\r\n TJvOfficeColorFormAccessProtected(FColorsForm).AdjustForm;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomOfficeColorButton.SetHotTrack( Value: Boolean);\r\nbegin\r\n if FHotTrack <> Value then\r\n begin\r\n FHotTrack := Value;\r\n FMainButton.HotTrack := Value;\r\n FArrowButton.HotTrack := Value;\r\n ColorPanel.HotTrack := Value;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomOfficeColorButton.SetHotTrackFont(Value: TFont);\r\nbegin\r\n ColorPanel.HotTrackFont := Value;\r\nend;\r\n\r\nfunction TJvCustomOfficeColorButton.GetHotTrackFont: TFont;\r\nbegin\r\n Result := ColorPanel.HotTrackFont;\r\nend;\r\n\r\nprocedure TJvCustomOfficeColorButton.SetHotTrackFontOptions(Value: TJvTrackFontOptions);\r\nbegin\r\n ColorPanel.HotTrackFontOptions := Value;\r\nend;\r\n\r\nprocedure TJvCustomOfficeColorButton.SetHotTrackOptions(Value: TJvOfficeColorButtonHotTrackOptions);\r\nbegin\r\n if FHotTrackOptions <> Value then\r\n begin\r\n FHotTrackOptions.Assign(Value);\r\n FMainButton.HotTrackOptions := Value;\r\n FArrowButton.HotTrackOptions := Value;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomOfficeColorButton.IJvHotTrack_Assign(\r\n Source: IJvHotTrack);\r\nbegin\r\n if (Source <> nil) and (IJvHotTrack(Self) <> Source) then\r\n begin\r\n HotTrack := Source.HotTrack;\r\n HotTrackFont :=Source.HotTrackFont;\r\n HotTrackFontOptions := Source.HotTrackFontOptions;\r\n HotTrackOptions := Source.HotTrackOptions;\r\n end;\r\nend;\r\n\r\nfunction TJvCustomOfficeColorButton.GetHotTrack: Boolean;\r\nbegin\r\n Result := FHotTrack;\r\nend;\r\n\r\nfunction TJvCustomOfficeColorButton.GetHotTrackOptions: TJvOfficeColorButtonHotTrackOptions;\r\nbegin\r\n Result := FHotTrackOptions;\r\nend;\r\n\r\nfunction TJvCustomOfficeColorButton.GetStandardColors: TStringList;\r\nbegin\r\n Result := ColorPanel.StandardColors;\r\nend;\r\n\r\nfunction TJvCustomOfficeColorButton.GetUserColors: TStringList;\r\nbegin\r\n Result := ColorPanel.UserColors;\r\nend;\r\n\r\nprocedure TJvCustomOfficeColorButton.SetStandardColors(const Value: TStringList);\r\nbegin\r\n ColorPanel.StandardColors := Value;\r\nend;\r\n\r\nprocedure TJvCustomOfficeColorButton.SetUserColors(const Value: TStringList);\r\nbegin\r\n ColorPanel.UserColors := Value;\r\nend;\r\n\r\nfunction TJvCustomOfficeColorButton.GetStandardColorDrawers: TList;\r\nbegin\r\n Result := TJvOfficeColorPanelAccessProtected(ColorPanel).StandardColorDrawers;\r\nend;\r\n\r\nfunction TJvCustomOfficeColorButton.GetSystemColorDrawers: TList;\r\nbegin\r\n Result := TJvOfficeColorPanelAccessProtected(ColorPanel).SystemColorDrawers;\r\nend;\r\n\r\nfunction TJvCustomOfficeColorButton.GetSystemColors: TStringList;\r\nbegin\r\n Result := ColorPanel.SystemColors;\r\nend;\r\n\r\nfunction TJvCustomOfficeColorButton.GetUserColorDrawers: TList;\r\nbegin\r\n Result := TJvOfficeColorPanelAccessProtected(ColorPanel).UserColorDrawers;\r\nend;\r\n\r\nfunction TJvCustomOfficeColorButton.GetAddInControls: TList;\r\nbegin\r\n Result := TJvOfficeColorPanelAccessProtected(ColorPanel).AddInControls;\r\nend;\r\n\r\nprocedure TJvCustomOfficeColorButton.SetSystemColors(const Value: TStringList);\r\nbegin\r\n ColorPanel.SystemColors := Value;\r\nend;\r\n\r\nfunction TJvCustomOfficeColorButton.GetHotTrackFontOptions: TJvTrackFontOptions;\r\nbegin\r\n Result := ColorPanel.HotTrackFontOptions;\r\nend;\r\n\r\nfunction TJvCustomOfficeColorButton.GetColorPanel: TJvOfficeColorPanel;\r\nbegin\r\n Result := TJvOfficeColorPanel(ColorsForm.ColorPanel);\r\nend;\r\n\r\nfunction TJvCustomOfficeColorButton.GetButtonOfDefaultColor: TJvColorSpeedButton;\r\nbegin\r\n Result := TJvOfficeColorPanelAccessProtected(ColorPanel).ButtonDefaultColor;\r\nend;\r\n\r\nfunction TJvCustomOfficeColorButton.GetButtonOfNoneColor: TJvColorSpeedButton;\r\nbegin\r\n Result := TJvOfficeColorPanelAccessProtected(ColorPanel).ButtonNoneColor;\r\nend;\r\n\r\nfunction TJvCustomOfficeColorButton.GetButtonOfCustomColor: TJvColorSpeedButton;\r\nbegin\r\n Result := TJvOfficeColorPanelAccessProtected(ColorPanel).ButtonCustomColor;\r\nend;\r\n\r\nfunction TJvCustomOfficeColorButton.GetClickColorType: TJvClickColorType;\r\nbegin\r\n Result := ColorPanel.ClickColorType;\r\nend;\r\n\r\nprocedure TJvCustomOfficeColorButton.DoClick(Sender: TObject);\r\nbegin\r\n if Assigned(OnClick) then\r\n OnClick(Self);\r\nend;\r\n\r\nprocedure TJvCustomOfficeColorButton.DoColorsListChanged(Sender: TObject);\r\nbegin\r\n FColorsListChanged := True;\r\nend;\r\n\r\nprocedure TJvCustomOfficeColorButton.DoHoldedCustomColor(Sender: TObject;AColor: TColor);\r\nbegin\r\n if Assigned(FOnHoldCustomColor) then\r\n FOnHoldCustomColor(Self, AColor);\r\n\r\n // after hold custom color, realign the form\r\n if Properties.HoldCustomColor and (ColorPanel.ClickColorType = cctCustomColor) then\r\n FColorsForm.AdjustForm;\r\nend;\r\n\r\n//=== { TJvOfficeColorButtonProperties } =====================================\r\n\r\nconstructor TJvOfficeColorButtonProperties.Create(AOwner: TPersistent);\r\nbegin\r\n inherited Create(AOwner);\r\n FShowDragBar := True;\r\n FEdgeWidth := 4;\r\n FArrowWidth := MinArrowWidth;\r\n FDragBarHeight := MinDragBarHeight;\r\n FDragBarSpace := MinDragBarSpace;\r\n FDragBarHint := RsDragToFloating;\r\nend;\r\n\r\nprocedure TJvOfficeColorButtonProperties.CreateDefaultText;\r\nbegin\r\n BeginUpdate;\r\n try\r\n inherited CreateDefaultText;\r\n DragBarHint := RsDragToFloat;\r\n FloatWindowCaption := RsColorWindow;\r\n finally\r\n EndUpdate;\r\n end;\r\nend;\r\n\r\nconst\r\n cDragCaption = 'DragCaption';\r\n\r\nprocedure TJvOfficeColorButtonProperties.DefineProperties(Filer: TFiler);\r\nbegin\r\n inherited DefineProperties(Filer);\r\n BeginUpdate;\r\n try\r\n FFilerTag := cDragCaption;\r\n Filer.DefineProperty(FFilerTag, ReadData, nil, False);\r\n finally\r\n EndUpdate;\r\n end;\r\nend;\r\n\r\nprocedure TJvOfficeColorButtonProperties.ReadData(Reader: TReader);\r\nbegin\r\n if SameText(FFilerTag,cDragCaption) then\r\n FloatWindowCaption:= Reader.ReadString;\r\nend;\r\n\r\nprocedure TJvOfficeColorButtonProperties.Assign(Source: TPersistent);\r\nbegin\r\n BeginUpdate;\r\n try\r\n inherited Assign(Source);\r\n if Source is TJvOfficeColorButtonProperties then\r\n with TJvOfficeColorButtonProperties(Source) do\r\n begin\r\n Self.ShowDragBar := ShowDragBar;\r\n Self.FloatWindowCaption := FloatWindowCaption;\r\n Self.EdgeWidth := EdgeWidth;\r\n Self.ArrowWidth := ArrowWidth;\r\n Self.DragBarHeight := DragBarHeight;\r\n Self.DragBarHint := DragBarHint;\r\n Self.DragBarSpace := DragBarSpace;\r\n end;\r\n finally\r\n EndUpdate;\r\n end;\r\nend;\r\n\r\nprocedure TJvOfficeColorButtonProperties.SetArrowWidth(const Value: Integer);\r\nbegin\r\n if FArrowWidth <> Value then\r\n begin\r\n Changing;\r\n ChangingProperty(cArrowWidth);\r\n FArrowWidth := Value;\r\n ChangedProperty(cArrowWidth);\r\n Changed;\r\n end;\r\nend;\r\n\r\nprocedure TJvOfficeColorButtonProperties.SetDragBarHeight(const Value: Integer);\r\nbegin\r\n if FDragBarHeight <> Value then\r\n begin\r\n Changing;\r\n ChangingProperty(cDragBarHeight);\r\n FDragBarHeight := Value;\r\n ChangedProperty(cDragBarHeight);\r\n Changed;\r\n end;\r\nend;\r\n\r\nprocedure TJvOfficeColorButtonProperties.SetDragBarSpace(const Value: Integer);\r\nbegin\r\n if FDragBarSpace <> Value then\r\n begin\r\n Changing;\r\n ChangingProperty(cDragBarSpace);\r\n FDragBarSpace := Value;\r\n ChangedProperty(cDragBarSpace);\r\n Changed;\r\n end;\r\nend;\r\n\r\nprocedure TJvOfficeColorButtonProperties.SetDragBarHint(const Value: string);\r\nbegin\r\n if FDragBarHint<>Value then\r\n begin\r\n Changing;\r\n ChangingProperty(cDragBarHint);\r\n FDragBarHint := Value;\r\n ChangedProperty(cDragBarHint);\r\n Changed;\r\n end;\r\nend;\r\n\r\nprocedure TJvOfficeColorButtonProperties.SetFloatWindowCaption(const Value: string);\r\nbegin\r\n if FFloatWindowCaption <> Value then\r\n begin\r\n Changing;\r\n ChangingProperty(cFloatWindowCaption);\r\n FFloatWindowCaption := Value;\r\n ChangedProperty(cFloatWindowCaption);\r\n Changed;\r\n end;\r\nend;\r\n\r\nprocedure TJvOfficeColorButtonProperties.SetEdgeWidth(const Value: Integer);\r\nbegin\r\n if FEdgeWidth <> Value then\r\n begin\r\n Changing;\r\n ChangingProperty(cEdgeWidth);\r\n FEdgeWidth := Value;\r\n ChangedProperty(cEdgeWidth);\r\n Changed;\r\n end;\r\nend;\r\n\r\nprocedure TJvOfficeColorButtonProperties.SetShowDragBar(const Value: Boolean);\r\nbegin\r\n if FShowDragBar <> Value then\r\n begin\r\n Changing;\r\n ChangingProperty(cShowDragBar);\r\n FShowDragBar := Value;\r\n ChangedProperty(cShowDragBar);\r\n Changed;\r\n end;\r\nend;\r\n\r\n//=== { TJvOfficeColorButton } ===============================================\r\n\r\nprocedure TJvOfficeColorButton.DefineProperties(Filer: TFiler);\r\nbegin\r\n inherited DefineProperties(Filer);\r\n { For backwards compatibility }\r\n FFilerTag := 'Color';\r\n Filer.DefineProperty(FFilerTag, ReadData, nil, False);\r\n FFilerTag := 'CustomColors';\r\n Filer.DefineProperty(FFilerTag, ReadData, nil, False);\r\n FFilerTag := 'Options';\r\n Filer.DefineProperty(FFilerTag, ReadData, nil, False);\r\nend;\r\n\r\nprocedure TJvOfficeColorButton.ReadData(Reader: TReader);\r\nbegin\r\n if SameText(FFilerTag,'Color') then\r\n BackColor := JvReaderReadColor(Reader)\r\n else\r\n if SameText(FFilerTag,'CustomColors') then\r\n JvReaderReadStrings(Reader,ColorDlgCustomColors)\r\n else\r\n if SameText(FFilerTag,'Options') then\r\n ColorDialogOptions := JvReaderReadColorDialogOptions(Reader)\r\n ;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n\r\n" }, { "path": "External/Jedi/Jvcl/run/JvOfficeColorForm.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvOfficeColorForm.PAS, released on 2004-02-26.\r\n\r\nThe Initial Developer of the Original Code is dejoy [dejoy att ynl dott gov dott cn]\r\nPortions created by Peter Thrnqvist are Copyright (C) 2004 Peter Thrnqvist.\r\nAll Rights Reserved.\r\n\r\nContributor(s):dejoy.\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nDescription:\r\n Color form for the @link(TJvOfficeColorButton) component\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvOfficeColorForm.pas 13138 2011-10-26 23:17:50Z jfudickar $\r\n\r\nunit JvOfficeColorForm;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n SysUtils, Classes,\r\n Windows, Messages, Graphics, Controls, Forms, ExtCtrls,\r\n JvComponent, JvOfficeColorPanel, JvOfficeDragBarForm;\r\n\r\n{------------------------------------------------------------------------------}\r\n\r\ntype\r\n TJvOfficeColorForm = class(TJvOfficeDragBarForm)\r\n private\r\n function GetColorPanel: TJvCustomOfficeColorPanel;\r\n public\r\n constructor Create(AOwner: TComponent; AOfficeColorPanelClass: TJvOfficeColorPanelClass); reintroduce; virtual;\r\n property ColorPanel: TJvCustomOfficeColorPanel read GetColorPanel;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvOfficeColorForm.pas $';\r\n Revision: '$Revision: 13138 $';\r\n Date: '$Date: 2011-10-27 01:17:50 +0200 (jeu. 27 oct. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\ntype\r\n TJvOfficeColorPanelAccessProtected = class(TJvOfficeColorPanel);\r\n\r\n//=== { TJvOfficeColorForm } =================================================\r\n\r\nconstructor TJvOfficeColorForm.Create(AOwner: TComponent;\r\n AOfficeColorPanelClass: TJvOfficeColorPanelClass);\r\nbegin\r\n inherited Create(AOwner);\r\n SetClient(AOfficeColorPanelClass.Create(Self));\r\n with TJvOfficeColorPanelAccessProtected(ColorPanel) do\r\n begin\r\n Parent := Self;\r\n FlatBorder := True;\r\n BorderWidth := 0;\r\n end;\r\nend;\r\n\r\nfunction TJvOfficeColorForm.GetColorPanel: TJvCustomOfficeColorPanel;\r\nbegin\r\n Result := TJvCustomOfficeColorPanel(Client);\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvOfficeColorPanel.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvOfficeColorPanel.PAS, released on 2004-02-26.\r\n\r\nThe Initial Developer of the Original Code is dejoy [dejoy att ynl dott gov dott cn]\r\nAll Rights Reserved.\r\n\r\nContributor(s): dejoy.\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nDescription:\r\n a Color panel look like Microsoft office Color picker,make to customable Highly.\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvOfficeColorPanel.pas 13104 2011-09-07 06:50:43Z obones $\r\n\r\nunit JvOfficeColorPanel;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n SysUtils, Classes,\r\n Windows, Graphics, Controls, Forms, Buttons, Dialogs,ExtCtrls,\r\n JvTypes, JvHotTrackPersistent, JvExControls, JvSpeedButton,\r\n JvPanel;\r\n\r\nconst\r\n Tag_DefaultColorCaption = 0;\r\n Tag_CustomColorCaption = 1;\r\n Tag_NoneColorCaption = 2;\r\n Tag_DefaultColorHint = 3;\r\n Tag_CustomColorHint = 4;\r\n Tag_NoneColorHint = 5;\r\n Tag_ShowColorsHint = 10;\r\n Tag_ShowAddInHint = 12;\r\n Tag_ShowStandardColors = 15;\r\n Tag_ShowSystemColors = 16;\r\n Tag_ShowUserColors = 17;\r\n Tag_HoldCustomColor = 18;\r\n\r\n Tag_ButtonHeight = 20;\r\n Tag_ButtonWidth = 21;\r\n Tag_ColorSize = 22;\r\n Tag_ColorSpace = 23;\r\n Tag_ColorSpaceTop = 24;\r\n Tag_ColorSpaceBottom = 25;\r\n Tag_TopMargin = 26;\r\n Tag_BottomMargin = 27;\r\n Tag_HorizontalMargin = 28;\r\n Tag_RightClickSelect = 29;\r\n Tag_SelectIfPopup = 30;\r\n\r\n MinColorSize = 18;\r\n MinColorSpace = 0;\r\n MinColorSpaceTop = 4;\r\n MinColorSpaceBottom = 4;\r\n MinTopMargin = 4;\r\n MinBottomMargin = 4;\r\n MinHorizontalMargin = 4;\r\n MinButtonHeight = MinColorSize + 7;\r\n MinButtonWidth = 23;\r\n\r\n PrimaryGroupIndex = 1;\r\n LineColorCount = 8;\r\n MaxLineRow = 8;\r\n MaxSectColorCount = LineColorCount * MaxLineRow;\r\n\r\ntype\r\n TJvOfficeColorPanelClass = class of TJvCustomOfficeColorPanel;\r\n\r\n TJvColorSpeedButton = class(TJvSpeedButton)\r\n private\r\n FDrawColor: TColor;\r\n FDisabledDrawColor: TColor;\r\n FCanDrawInnerFrame: Boolean;\r\n FCanDrawGlyph: Boolean;\r\n FCanDrawColorQuad: Boolean;\r\n FColorQuadLayOut: TJvColorQuadLayOut;\r\n FOnEnabledChagned: TNotifyEvent;\r\n procedure SetDrawColor(const Value: TColor);\r\n procedure SetDisabledDrawColor(const Value: TColor);\r\n procedure SetEdgeWidth(const Value: Integer);\r\n procedure SetFColorQuadLayOut(const Value: TJvColorQuadLayOut);\r\n procedure SetCanDrawInnerFrame(const Value: Boolean);\r\n procedure SetCanDrawGlyph(const Value: Boolean);\r\n procedure SetCanDrawColorQuad(const Value: Boolean);\r\n protected\r\n FEdgeWidth: Integer;\r\n procedure Paint; override;\r\n procedure EnabledChanged; override;\r\n function GetEdgeWidth: Integer; virtual;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n property Canvas;\r\n property CanDrawColorQuad: Boolean read FCanDrawColorQuad write SetCanDrawColorQuad default True;\r\n property CanDrawGlyph: Boolean read FCanDrawGlyph write SetCanDrawGlyph default True;\r\n property CanDrawInnerFrame: Boolean read FCanDrawInnerFrame write SetCanDrawInnerFrame default False;\r\n property ColorQuadLayOut: TJvColorQuadLayOut read FColorQuadLayOut write SetFColorQuadLayOut default cqlClient;\r\n property DrawColor: TColor read FDrawColor write SetDrawColor default clDefault;\r\n property DisabledDrawColor: TColor read FDisabledDrawColor write SetDisabledDrawColor default clGray;\r\n property EdgeWidth: Integer read GetEdgeWidth write SetEdgeWidth;\r\n property OnEnabledChagned: TNotifyEvent read FOnEnabledChagned write FOnEnabledChagned;\r\n end;\r\n\r\n TJvOfficeColorDrawer = class(TJvColorSpeedButton)\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n property CanDrawGlyph default False;\r\n end;\r\n\r\n // (ahuser) TJvColorDialog is not registered as component\r\n TJvOfficeColorDialog = class(TColorDialog)\r\n published\r\n property OnShow;\r\n property OnClose;\r\n end;\r\n\r\n TJvOfficeColorPanelProperties = class(TJvPersistentProperty)\r\n private\r\n FShowNoneColor: Boolean;\r\n FShowDefaultColor: Boolean;\r\n FShowCustomColor: Boolean;\r\n FDefaultColorColor: TColor;\r\n FNoneColorColor: TColor;\r\n FShowColorsHint: Boolean;\r\n FShowAddInHint: Boolean;\r\n\r\n FDefaultColorCaption: string;\r\n FCustomColorCaption: string;\r\n FNoneColorCaption: string;\r\n FDefaultColorHint: string;\r\n FCustomColorHint: string;\r\n FNoneColorHint: string;\r\n\r\n FTopMargin: Integer;\r\n FColorSpaceBottom: Integer;\r\n FHorizontalMargin: Integer;\r\n FColorSpace: Integer;\r\n FColorSpaceTop: Integer;\r\n FButtonHeight: Integer;\r\n FColorSize: Integer;\r\n FBottomMargin: Integer;\r\n\r\n FRightClickSelect: Boolean;\r\n FSelectIfPopup: Boolean;\r\n FCustomColorFont: TFont;\r\n FDefaultColorFont: TFont;\r\n FNoneColorFont: TFont;\r\n FShowStandardColors: Boolean;\r\n FShowSystemColors: Boolean;\r\n FShowUserColors: Boolean;\r\n FHoldCustomColor: Boolean;\r\n FFilerTag:string;\r\n procedure SetIntegerValue(const Index, Value: Integer);\r\n procedure SetStringValue(const Index: Integer; const Value: string);\r\n procedure SetBooleanValue(const Index: Integer; const Value: Boolean);\r\n procedure SetColorValue(const Index: Integer; const Value: TColor);\r\n procedure SetFontValue(const Index: Integer; const Value: TFont);\r\n procedure OnFontChange(Sender: TObject);\r\n procedure ReadData(Reader: TReader);\r\n protected\r\n procedure CreateDefaultText; virtual;\r\n procedure DefineProperties(Filer: TFiler); override;\r\n public\r\n constructor Create(AOwner: TPersistent); override;\r\n destructor Destroy; override;\r\n procedure Assign(Source: TPersistent); override;\r\n property ShowStandardColors: Boolean index Tag_ShowStandardColors read FShowStandardColors write SetBooleanValue default True;\r\n published\r\n property ShowNoneColor: Boolean index Tag_NoneColorCaption read FShowNoneColor write SetBooleanValue default False;\r\n property ShowDefaultColor: Boolean index Tag_DefaultColorCaption read FShowDefaultColor write SetBooleanValue default True;\r\n property ShowCustomColor: Boolean index Tag_CustomColorCaption read FShowCustomColor write SetBooleanValue default True;\r\n property ShowAddInHint: Boolean index Tag_ShowAddInHint read FShowAddInHint write SetBooleanValue default True;\r\n property ShowColorsHint: Boolean index Tag_ShowColorsHint read FShowColorsHint write SetBooleanValue default True;\r\n property ShowSystemColors: Boolean index Tag_ShowSystemColors read FShowSystemColors write SetBooleanValue default False;\r\n property ShowUserColors: Boolean index Tag_ShowUserColors read FShowUserColors write SetBooleanValue default False;\r\n property HoldCustomColor: Boolean index Tag_HoldCustomColor read FHoldCustomColor write SetBooleanValue default False;\r\n\r\n property NoneColorCaption: string index Tag_NoneColorCaption read FNoneColorCaption write SetStringValue;\r\n property DefaultColorCaption: string index Tag_DefaultColorCaption read FDefaultColorCaption write SetStringValue;\r\n property CustomColorCaption: string index Tag_CustomColorCaption read FCustomColorCaption write SetStringValue;\r\n property NoneColorHint: string index Tag_NoneColorHint read FNoneColorHint write SetStringValue;\r\n property DefaultColorHint: string index Tag_DefaultColorHint read FDefaultColorHint write SetStringValue;\r\n property CustomColorHint: string index Tag_CustomColorHint read FCustomColorHint write SetStringValue;\r\n property NoneColorColor: TColor index Tag_NoneColorCaption read FNoneColorColor write SetColorValue default clNone;\r\n property DefaultColorColor: TColor index Tag_DefaultColorCaption read FDefaultColorColor write SetColorValue default clDefault;\r\n\r\n property NoneColorFont: TFont index Tag_NoneColorCaption read FNoneColorFont write SetFontValue;\r\n property DefaultColorFont: TFont index Tag_DefaultColorCaption read FDefaultColorFont write SetFontValue;\r\n property CustomColorFont: TFont index Tag_CustomColorCaption read FCustomColorFont write SetFontValue;\r\n\r\n property TopMargin: Integer index Tag_TopMargin read FTopMargin write SetIntegerValue default MinTopMargin;\r\n property BottomMargin: Integer index Tag_BottomMargin read FBottomMargin write SetIntegerValue default MinBottomMargin;\r\n property HorizontalMargin: Integer index Tag_HorizontalMargin read FHorizontalMargin write SetIntegerValue default MinHorizontalMargin;\r\n property ColorSpace: Integer index Tag_ColorSpace read FColorSpace write SetIntegerValue default MinColorSpace;\r\n property ColorSpaceTop: Integer index Tag_ColorSpaceTop read FColorSpaceTop write SetIntegerValue default MinColorSpaceTop;\r\n property ColorSpaceBottom: Integer index Tag_ColorSpaceBottom read FColorSpaceBottom write SetIntegerValue default MinColorSpaceBottom;\r\n property ColorSize: Integer index Tag_ColorSize read FColorSize write SetIntegerValue default MinColorSize;\r\n property ButtonHeight: Integer index Tag_ButtonHeight read FButtonHeight write SetIntegerValue default MinButtonHeight;\r\n\r\n property RightClickSelect: Boolean index Tag_RightClickSelect read FRightClickSelect write SetBooleanValue default False;\r\n property SelectIfPopup: Boolean index Tag_SelectIfPopup read FSelectIfPopup write SetBooleanValue default False;\r\n end;\r\n\r\n TJvCustomOfficeColorPanel = class(TJvCustomArrangePanel, IJvHotTrack)\r\n private\r\n FStandardColors: TStringList;\r\n FSystemColors: TStringList;\r\n FUserColors: TStringList;\r\n FStandardColorDrawers: TList;\r\n FSystemColorDrawers: TList;\r\n FUserColorDrawers: TList;\r\n FAddInControls: TList;\r\n FButtonNoneColor: TJvColorSpeedButton;\r\n FButtonDefaultColor: TJvColorSpeedButton;\r\n FButtonCustomColor: TJvColorSpeedButton;\r\n FCustomColorDrawer: TJvOfficeColorDrawer;\r\n FPriorCheckedButton: TJvColorSpeedButton;\r\n FDividerLine1: TControl;\r\n FDividerLine2: TControl;\r\n FDividerLine3: TControl;\r\n FProperties: TJvOfficeColorPanelProperties;\r\n FColorDialog: TJvOfficeColorDialog;\r\n FSelectedColor: TColor;\r\n FBackgroundColor: TColor;\r\n FInited: Boolean;\r\n FNeedReDrawDownState: Boolean;\r\n //in SetSeletedColor,is need to refresh button down state.\r\n FInRearrangeControls: Boolean;\r\n FOnColorChange: TNotifyEvent;\r\n FOnHoldCustomColor: TJvHoldCustomColorEvent;\r\n FOnColorButtonClick: TNotifyEvent;\r\n FOnShowOwnerColorDialog: TNotifyEvent;\r\n FOnGetAddInControlSiteInfo: TJvGetAddInControlSiteInfoEvent;\r\n FClickColorType: TJvClickColorType;\r\n FHotTrackOptions: TJvHotTrackOptions;\r\n FHotTrack: Boolean;\r\n FHotTrackFont: TFont;\r\n FHotTrackFontOptions: TJvTrackFontOptions;\r\n FColorDialogOptions: TColorDialogOptions;\r\n procedure SetColorDialogOptions(const Value: TColorDialogOptions);\r\n procedure SetSelectedColor(const Value: TColor);\r\n function GetColorDlgCustomColors: TStrings;\r\n procedure SetColorDlgCustomColors(const Value: TStrings);\r\n procedure SetProperties(const Value: TJvOfficeColorPanelProperties);\r\n function GetControlBackgroundColor: TColor;\r\n procedure SetControlBackgroundColor(const Value: TColor);\r\n\r\n {IJvHotTrack}\r\n function GetHotTrack: Boolean;\r\n function GetHotTrackFont: TFont;\r\n function GetHotTrackFontOptions: TJvTrackFontOptions;\r\n function GetHotTrackOptions: TJvHotTrackOptions;\r\n procedure SetHotTrack(Value: Boolean);\r\n procedure SetHotTrackOptions(Value: TJvHotTrackOptions);\r\n procedure SetHotTrackFont(Value: TFont);\r\n procedure SetHotTrackFontOptions(Value: TJvTrackFontOptions);\r\n procedure IJvHotTrack_Assign(Source: IJvHotTrack);\r\n procedure IJvHotTrack.Assign = IJvHotTrack_Assign;\r\n\r\n procedure SetStandardColors(const Value: TStringList);\r\n procedure SetSystemColors(const Value: TStringList);\r\n procedure SetUserColors(const Value: TStringList);\r\n procedure RedirectToColorButtonClick(Sender: TObject; Button: TMouseButton;\r\n Shift: TShiftState; X, Y: Integer);\r\n\r\n procedure DoColorDrawersEnabledChange(Sender: TObject);\r\n procedure DoHotTrackOptionsChanged(Sender: TObject);\r\n procedure DoLoadedUserColors(Sender: TObject);\r\n procedure DoHoldedCustomColor(Sender: TObject;AColor: TColor);\r\n protected\r\n procedure DoColorButtonClick(Sender: TObject); virtual;\r\n procedure DoSelectedColorChange(Sender: TObject); virtual;\r\n procedure DoGetAddInControlSiteInfo(Sender: TControl; var ASiteInfo:\r\n TJvAddInControlSiteInfo); virtual;\r\n procedure DoPropertiesChanged(Sender: TObject; const PropName: string); virtual;\r\n procedure CreateWnd; override;\r\n procedure Loaded; override;\r\n procedure Resize; override;\r\n procedure ShowHintChanged; override;\r\n function CreateStandardColors(ColorList: TStrings): Integer; virtual;\r\n function CreateSystemColors(ColorList: TStrings): Integer; virtual;\r\n\r\n { If you wnat to create published color list by default,override this procedure.\r\n If you want to change ColorList,make sure call strings.beginupdate before change,\r\n and call strings.EndUpdate after changed. }\r\n function CreateUserColors(ColorList: TStrings): Integer; virtual;\r\n procedure CreateColorDrawersByColors(DrawersList: TList; ColorsList: TStringList; AVisible: Boolean);\r\n procedure SetEnabled( Value: Boolean); override;\r\n\r\n // Don't change the following list, the result might unpredictability.\r\n property StandardColorDrawers: TList read FStandardColorDrawers;\r\n property SystemColorDrawers: TList read FSystemColorDrawers;\r\n property UserColorDrawers: TList read FUserColorDrawers;\r\n property AddInControls: TList read FAddInControls;\r\n\r\n property ButtonNoneColor: TJvColorSpeedButton read FButtonNoneColor;\r\n property ButtonDefaultColor: TJvColorSpeedButton read FButtonDefaultColor;\r\n property ButtonCustomColor: TJvColorSpeedButton read FButtonCustomColor;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n\r\n procedure CreateStandardColorDrawers; virtual;\r\n procedure CreateSystemColorDrawers; virtual;\r\n procedure CreateUserColorDrawers; virtual;\r\n procedure RearrangeControls; virtual;\r\n procedure RefreshControls;\r\n\r\n property ColorDialog: TJvOfficeColorDialog read FColorDialog write FColorDialog;\r\n property SelectedColor: TColor read FSelectedColor write SetSelectedColor default clBlack;\r\n property BackColor: TColor read GetControlBackgroundColor write SetControlBackgroundColor default clBtnFace;\r\n\r\n //overried property\r\n property Color: TColor read GetControlBackgroundColor write SetControlBackgroundColor;\r\n\r\n property ClickColorType: TJvClickColorType read FClickColorType;\r\n\r\n { //Each custom color is represented as a string of the form ColorValue=ColorDescription.\r\n For example, the following string sets the custom color list.\r\n clBlack = Black\r\n $00003333 = Olive Green\r\n if set ColorDescription to cUseDefaultColorHint('($)'),the ColorDescription will be put to ColorToPrettyName(ColorValue) at runtime,\r\n such as:\r\n 'clBlack = ($)' will be put to 'clBlack = Black' at runtime;\r\n '$00113333 = ($)' will be put to '$00113333 = $00113333' at runtime;\r\n\r\n Up to MaxSectColorCount custom colors can be set.\r\n\r\n // If you changed Colors list manual,also you must call CreateXXXColorButtons and RearrangeControls to refresh manual,\r\n or call RefreshControls to refresh.\r\n // The StandardColors and SystemColors did't published by default,so it's not stroed in DFM, you just only change the value at runtime,\r\n if you want stroed StandardColors and SystemColors,create a new control descended from TJvOfficeColorPanel and\r\n put them to published section.\r\n\r\n //if you want to change ColorList,make sure call strings.beginupdate before change,\r\n //and call strings.EndUpdate after changed.\r\n }\r\n property StandardColors: TStringList read FStandardColors write SetStandardColors;\r\n property SystemColors: TStringList read FSystemColors write SetSystemColors;\r\n property UserColors: TStringList read FUserColors write SetUserColors;\r\n\r\n property HotTrack: Boolean read GetHotTrack write SetHotTrack default False;\r\n property HotTrackFont: TFont read GetHotTrackFont write SetHotTrackFont;\r\n property HotTrackFontOptions: TJvTrackFontOptions read GetHotTrackFontOptions write SetHotTrackFontOptions default DefaultTrackFontOptions;\r\n property HotTrackOptions: TJvHotTrackOptions read GetHotTrackOptions write SetHotTrackOptions;\r\n property Properties: TJvOfficeColorPanelProperties read FProperties write SetProperties;\r\n\r\n property ColorDlgCustomColors: TStrings read GetColorDlgCustomColors write SetColorDlgCustomColors;\r\n property ColorDialogOptions: TColorDialogOptions read FColorDialogOptions write SetColorDialogOptions default [];\r\n\r\n property OnColorChange: TNotifyEvent read FOnColorChange write FOnColorChange;\r\n property OnColorButtonClick: TNotifyEvent read FOnColorButtonClick write FOnColorButtonClick;\r\n property OnHoldCustomColor: TJvHoldCustomColorEvent read FOnHoldCustomColor write FOnHoldCustomColor;\r\n property OnShowOwnerColorDialog: TNotifyEvent read FOnShowOwnerColorDialog write FOnShowOwnerColorDialog;\r\n property OnGetAddInControlSiteInfo: TJvGetAddInControlSiteInfoEvent read FOnGetAddInControlSiteInfo write FOnGetAddInControlSiteInfo;\r\n end;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvOfficeColorPanel = class(TJvCustomOfficeColorPanel)\r\n private\r\n FFilerTag: string;\r\n procedure ReadData(Reader: TReader);\r\n protected\r\n procedure DefineProperties(Filer: TFiler); override;\r\n published\r\n // UserColors must be load fist on read from the DFM file.\r\n property UserColors;\r\n property BevelInner;\r\n property BevelOuter;\r\n property BevelWidth;\r\n property BorderWidth;\r\n property FlatBorder;\r\n property FlatBorderColor;\r\n property BackColor;\r\n property SelectedColor;\r\n property ColorDlgCustomColors;\r\n property HotTrack;\r\n property HotTrackFont;\r\n property HotTrackFontOptions;\r\n property HotTrackOptions;\r\n property ColorDialogOptions;\r\n property BiDiMode;\r\n property DragCursor;\r\n property DragKind;\r\n property ParentBiDiMode;\r\n property OnCanResize;\r\n property OnEndDock;\r\n property OnGetSiteInfo;\r\n\r\n property Align;\r\n property Anchors;\r\n property Constraints;\r\n property DragMode;\r\n property Enabled;\r\n property Font;\r\n property ParentFont;\r\n property ParentShowHint;\r\n property PopupMenu;\r\n property ShowHint;\r\n property TabOrder;\r\n property TabStop;\r\n property Visible;\r\n property OnConstrainedResize;\r\n property OnContextPopup;\r\n property OnDragDrop;\r\n property OnDragOver;\r\n property OnEndDrag;\r\n property OnEnter;\r\n property OnExit;\r\n property OnMouseDown;\r\n property OnMouseMove;\r\n property OnMouseUp;\r\n property OnMouseEnter;\r\n property OnMouseLeave;\r\n property OnResize;\r\n property OnStartDrag;\r\n\r\n property Properties;\r\n property OnColorChange;\r\n property OnColorButtonClick;\r\n\r\n { If OnShowOwnerColorDialog not nil,the default ColorDialog will not show,\r\n so you can show coustom ColorDialog yourself. }\r\n property OnShowOwnerColorDialog;\r\n property OnClick;\r\n end;\r\n\r\n TJvOfficePanelDividerLine = class(TBevel)\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n published\r\n property Shape default bsTopLine;\r\n end;\r\n\r\nvar\r\n JvDividerLineClass: TControlClass = TJvOfficePanelDividerLine;\r\n\r\nfunction GetTopOwner(AComponent: TComponent): TComponent;\r\nfunction JvReaderReadColor(Reader: TReader):TColor;\r\nfunction JvReaderReadColorDialogOptions(Reader: TReader):TColorDialogOptions;\r\nprocedure JvReaderReadStrings(Reader: TReader;Strings:TStrings);\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvOfficeColorPanel.pas $';\r\n Revision: '$Revision: 13104 $';\r\n Date: '$Date: 2011-09-07 08:50:43 +0200 (mer. 07 sept. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n JvJCLUtils, JvResources, Math;\r\n\r\nconst\r\n cNoneColorCaption = 'NoneColorCaption';\r\n cNoneColorColor = 'NoneColorColor';\r\n cNoneColorFont = 'NoneColorFont';\r\n cNoneColorHint = 'NoneColorHint';\r\n cDefaultColorCaption = 'DefaultColorCaption';\r\n cDefaultColorColor = 'DefaultColorColor';\r\n cDefaultColorFont = 'DefaultColorFont';\r\n cDefaultColorHint = 'DefaultColorHint';\r\n cCustomColorCaption = 'CustomColorCaption';\r\n cCustomColorFont = 'CustomColorFont';\r\n cCustomColorHint = 'CustomColorHint';\r\n cShowNoneColor = 'ShowNoneColor';\r\n cShowDefaultColor = 'ShowDefaultColor';\r\n cShowCustomColor = 'ShowCustomColor';\r\n cShowAddInHint = 'ShowAddInHint';\r\n cShowColorsHint = 'ShowColorsHint';\r\n cShowStandardColors = 'ShowStandardColors';\r\n cShowSystemColors = 'ShowSystemColors';\r\n cShowUserColors = 'ShowUserColors';\r\n cHoldCustomColor = 'HoldCustomColor';\r\n cRightClickSelect = 'RightClickSelect';\r\n cSelectIfPopup = 'SelectIfPopup';\r\n\r\n cUseDefaultColorHint = '($)';\r\n\r\ntype\r\n TControlAccessProtected = class(TControl);\r\n\r\n{ TJvOfficePanelDividerLine }\r\n\r\nconstructor TJvOfficePanelDividerLine.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n Shape := bsTopLine;\r\nend;\r\n\r\n//=== { TJvOfficeColorPanelProperties } ======================================\r\n\r\nconstructor TJvOfficeColorPanelProperties.Create(AOwner: TPersistent);\r\nbegin\r\n inherited Create(AOwner);\r\n FShowNoneColor := False;\r\n FShowDefaultColor := True;\r\n FShowCustomColor := True;\r\n FShowColorsHint := True;\r\n FShowAddInHint := True;\r\n FShowStandardColors := True;\r\n FShowSystemColors := False;\r\n FShowUserColors := False;\r\n FHoldCustomColor := False;\r\n FNoneColorColor := clNone;\r\n FDefaultColorColor := clDefault;\r\n\r\n FDefaultColorFont := TFont.Create;\r\n FDefaultColorFont.OnChange := OnFontChange;\r\n FNoneColorFont := TFont.Create;\r\n FNoneColorFont.OnChange := OnFontChange;\r\n FCustomColorFont := TFont.Create;\r\n FCustomColorFont.OnChange := OnFontChange;\r\n\r\n FHorizontalMargin := MinHorizontalMargin;\r\n FTopMargin := MinTopMargin;\r\n FBottomMargin := MinBottomMargin;\r\n FButtonHeight := MinButtonHeight;\r\n FColorSpace := MinColorSpace;\r\n FColorSpaceTop := MinColorSpaceTop;\r\n FColorSpaceBottom := MinColorSpaceBottom;\r\n FColorSize := MinColorSize;\r\n\r\n FRightClickSelect := False;\r\n FSelectIfPopup := False;\r\nend;\r\n\r\ndestructor TJvOfficeColorPanelProperties.Destroy;\r\nbegin\r\n FreeAndNil(FNoneColorFont);\r\n FreeAndNil(FDefaultColorFont);\r\n FreeAndNil(FCustomColorFont);\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvOfficeColorPanelProperties.Assign(Source: TPersistent);\r\nbegin\r\n if Source is TJvOfficeColorPanelProperties then\r\n begin\r\n BeginUpdate;\r\n try\r\n with TJvOfficeColorPanelProperties(Source) do\r\n begin\r\n Self.ShowNoneColor := ShowNoneColor;\r\n Self.ShowDefaultColor := ShowDefaultColor;\r\n Self.ShowCustomColor := ShowCustomColor;\r\n Self.ShowStandardColors := ShowStandardColors;\r\n Self.ShowSystemColors := ShowSystemColors;\r\n Self.ShowUserColors := ShowUserColors;\r\n Self.ShowAddInHint := ShowAddInHint;\r\n Self.ShowColorsHint := ShowColorsHint;\r\n Self.HoldCustomColor := HoldCustomColor;\r\n\r\n Self.TopMargin := TopMargin;\r\n Self.BottomMargin := BottomMargin;\r\n Self.HorizontalMargin := HorizontalMargin;\r\n Self.ButtonHeight := ButtonHeight;\r\n Self.ColorSpace := ColorSpace;\r\n Self.ColorSpaceTop := ColorSpaceTop;\r\n Self.ColorSpaceBottom := ColorSpaceBottom;\r\n Self.ColorSize := ColorSize;\r\n\r\n Self.NoneColorCaption := NoneColorCaption;\r\n Self.DefaultColorCaption := DefaultColorCaption;\r\n Self.CustomColorCaption := CustomColorCaption;\r\n Self.NoneColorHint := NoneColorHint;\r\n Self.DefaultColorHint := DefaultColorHint;\r\n Self.CustomColorHint := CustomColorHint;\r\n Self.NoneColorColor := NoneColorColor;\r\n Self.DefaultColorColor := DefaultColorColor;\r\n Self.NoneColorFont.Assign(NoneColorFont);\r\n Self.DefaultColorFont.Assign(DefaultColorFont);\r\n Self.CustomColorFont.Assign(CustomColorFont);\r\n\r\n Self.RightClickSelect := RightClickSelect;\r\n Self.SelectIfPopup := SelectIfPopup;\r\n end;\r\n finally\r\n EndUpdate;\r\n end;\r\n end\r\n else\r\n inherited Assign(Source);\r\nend;\r\n\r\nconst\r\n cShowAutoButton = 'ShowAutoButton';\r\n cShowOtherButton = 'ShowOtherButton';\r\n cShowColorHint ='ShowColorHint';\r\n cAutoCaption ='AutoCaption';\r\n cOtherCaption ='OtherCaption';\r\n cAutoHint ='AutoHint';\r\n cOtherHint = 'OtherHint';\r\n\r\nprocedure TJvOfficeColorPanelProperties.DefineProperties(Filer: TFiler);\r\nbegin\r\n inherited DefineProperties(Filer);;\r\n { For backwards compatibility }\r\n BeginUpdate;\r\n try\r\n FFilerTag := cShowAutoButton;\r\n Filer.DefineProperty(FFilerTag, ReadData, nil, False);\r\n FFilerTag := cShowOtherButton;\r\n Filer.DefineProperty(FFilerTag, ReadData, nil, False);\r\n FFilerTag := cShowColorHint;\r\n Filer.DefineProperty(FFilerTag, ReadData, nil, False);\r\n FFilerTag := cAutoCaption;\r\n Filer.DefineProperty(FFilerTag, ReadData, nil, False);\r\n FFilerTag := cOtherCaption;\r\n Filer.DefineProperty(FFilerTag, ReadData, nil, False);\r\n FFilerTag := cAutoHint;\r\n Filer.DefineProperty(FFilerTag, ReadData, nil, False);\r\n FFilerTag := cOtherHint;\r\n Filer.DefineProperty(FFilerTag, ReadData, nil, False);\r\n finally\r\n EndUpdate;\r\n end;\r\nend;\r\n\r\nprocedure TJvOfficeColorPanelProperties.ReadData(Reader: TReader);\r\nbegin\r\n if SameText(FFilerTag, cShowAutoButton) then\r\n ShowDefaultColor := Reader.ReadBoolean\r\n else\r\n if SameText(FFilerTag, cShowOtherButton) then\r\n ShowCustomColor := Reader.ReadBoolean\r\n else\r\n if SameText(FFilerTag, cShowColorHint) then\r\n ShowColorsHint := Reader.ReadBoolean\r\n else\r\n if SameText(FFilerTag, cAutoCaption) then\r\n DefaultColorCaption := Reader.ReadString\r\n else\r\n if SameText(FFilerTag, cOtherCaption) then\r\n CustomColorCaption := Reader.ReadString\r\n else\r\n if SameText(FFilerTag, cAutoHint) then\r\n DefaultColorHint := Reader.ReadString\r\n else\r\n if SameText(FFilerTag, cOtherHint) then\r\n CustomColorHint := Reader.ReadString;\r\nend;\r\n\r\nprocedure TJvOfficeColorPanelProperties.CreateDefaultText;\r\nbegin\r\n BeginUpdate;\r\n try\r\n NoneColorCaption := RsNoneColorCaption;\r\n DefaultColorCaption := RsDefaultColorCaption;\r\n CustomColorCaption := RsCustomColorCaption;\r\n DefaultColorHint := RsDefaultColorCaption;\r\n NoneColorHint := RsNoneColorCaption;\r\n CustomColorHint := RsCustomColorCaption;\r\n finally\r\n EndUpdate;\r\n end;\r\nend;\r\n\r\nprocedure TJvOfficeColorPanelProperties.SetIntegerValue(const Index, Value:\r\n Integer);\r\nvar\r\n MeasureItem: PInteger;\r\n MeasureConst: Integer;\r\n LName: string;\r\nbegin\r\n case Index of\r\n Tag_TopMargin:\r\n begin\r\n MeasureItem := @FTopMargin;\r\n MeasureConst := MinTopMargin;\r\n LName := 'TopMargin';\r\n end;\r\n Tag_BottomMargin:\r\n begin\r\n MeasureItem := @FBottomMargin;\r\n MeasureConst := MinBottomMargin;\r\n LName := 'BottomMargin';\r\n end;\r\n Tag_HorizontalMargin:\r\n begin\r\n MeasureItem := @FHorizontalMargin;\r\n MeasureConst := MinHorizontalMargin;\r\n LName := 'HorizontalMargin';\r\n end;\r\n Tag_ColorSpace:\r\n begin\r\n MeasureItem := @FColorSpace;\r\n MeasureConst := MinColorSpace;\r\n LName := 'ColorSpace';\r\n end;\r\n Tag_ColorSpaceTop:\r\n begin\r\n MeasureItem := @FColorSpaceTop;\r\n MeasureConst := MinColorSpaceTop;\r\n LName := 'ColorSpaceTop';\r\n end;\r\n Tag_ColorSpaceBottom:\r\n begin\r\n MeasureItem := @FColorSpaceBottom;\r\n MeasureConst := MinColorSpaceBottom;\r\n LName := 'ColorSpaceBottom';\r\n end;\r\n Tag_ColorSize:\r\n begin\r\n MeasureItem := @FColorSize;\r\n MeasureConst := MinColorSize;\r\n LName := 'ColorSize';\r\n end;\r\n Tag_ButtonHeight:\r\n begin\r\n MeasureItem := @FButtonHeight;\r\n MeasureConst := MinButtonHeight;\r\n LName := 'ButtonHeight';\r\n end;\r\n else\r\n Exit;\r\n end;\r\n if MeasureItem^ = Value then\r\n Exit;\r\n\r\n Changing;\r\n ChangingProperty(LName);\r\n MeasureItem^ := Value;\r\n if MeasureItem^ < MeasureConst then\r\n MeasureItem^ := MeasureConst;\r\n ChangedProperty(LName);\r\n Changed;\r\nend;\r\n\r\nprocedure TJvOfficeColorPanelProperties.SetStringValue(const Index: Integer;\r\n const Value: string);\r\nvar\r\n Prop: PString;\r\n Name: string;\r\nbegin\r\n case Index of\r\n Tag_NoneColorCaption:\r\n begin\r\n Prop := @FNoneColorCaption;\r\n Name := cNoneColorCaption;\r\n end;\r\n Tag_DefaultColorCaption:\r\n begin\r\n Prop := @FDefaultColorCaption;\r\n Name := cDefaultColorCaption;\r\n end;\r\n Tag_CustomColorCaption:\r\n begin\r\n Prop := @FCustomColorCaption;\r\n Name := cCustomColorCaption;\r\n end;\r\n Tag_NoneColorHint:\r\n begin\r\n Prop := @FNoneColorHint;\r\n Name := cNoneColorHint;\r\n end;\r\n Tag_DefaultColorHint:\r\n begin\r\n Prop := @FDefaultColorHint;\r\n Name := cDefaultColorHint;\r\n end;\r\n Tag_CustomColorHint:\r\n begin\r\n Prop := @FCustomColorHint;\r\n Name := cCustomColorHint;\r\n end;\r\n else\r\n Exit;\r\n end;\r\n\r\n if (Prop^ <> Value) then\r\n begin\r\n Changing;\r\n ChangingProperty(Name);\r\n Prop^ := Value;\r\n ChangedProperty(Name);\r\n Changed;\r\n end;\r\nend;\r\n\r\nprocedure TJvOfficeColorPanelProperties.SetBooleanValue(const Index: Integer;\r\n const Value: Boolean);\r\nvar\r\n Prop: PBoolean;\r\n Name: string;\r\nbegin\r\n case Index of\r\n Tag_NoneColorCaption:\r\n begin\r\n Prop := @FShowNoneColor;\r\n Name := cShowNoneColor;\r\n end;\r\n Tag_DefaultColorCaption:\r\n begin\r\n Prop := @FShowDefaultColor;\r\n Name := cShowDefaultColor;\r\n end;\r\n Tag_CustomColorCaption:\r\n begin\r\n Prop := @FShowCustomColor;\r\n Name := cShowCustomColor;\r\n end;\r\n Tag_ShowAddInHint:\r\n begin\r\n Prop := @FShowAddInHint;\r\n Name := cShowAddInHint;\r\n end;\r\n Tag_ShowColorsHint:\r\n begin\r\n Prop := @FShowColorsHint;\r\n Name := cShowColorsHint;\r\n end;\r\n Tag_ShowStandardColors:\r\n begin\r\n Prop := @FShowStandardColors;\r\n Name := cShowStandardColors;\r\n end;\r\n Tag_ShowSystemColors:\r\n begin\r\n Prop := @FShowSystemColors;\r\n Name := cShowSystemColors;\r\n end;\r\n Tag_ShowUserColors:\r\n begin\r\n Prop := @FShowUserColors;\r\n Name := cShowUserColors;\r\n end;\r\n Tag_RightClickSelect:\r\n begin\r\n Prop := @FRightClickSelect;\r\n Name := cRightClickSelect;\r\n end;\r\n Tag_SelectIfPopup:\r\n begin\r\n Prop := @FSelectIfPopup;\r\n Name := cSelectIfPopup;\r\n end;\r\n Tag_HoldCustomColor:\r\n begin\r\n Prop := @HoldCustomColor;\r\n Name := cHoldCustomColor;\r\n end;\r\n else\r\n Exit;\r\n end;\r\n\r\n if (Prop^ <> Value) then\r\n begin\r\n Changing;\r\n ChangingProperty(Name);\r\n Prop^ := Value;\r\n ChangedProperty(Name);\r\n Changed;\r\n end;\r\nend;\r\n\r\nprocedure TJvOfficeColorPanelProperties.SetColorValue(const Index: Integer;\r\n const Value: TColor);\r\nvar\r\n Prop: PColor;\r\n Name: string;\r\nbegin\r\n case Index of\r\n Tag_NoneColorCaption:\r\n begin\r\n Prop := @FNoneColorColor;\r\n Name := cNoneColorColor;\r\n end;\r\n Tag_DefaultColorCaption:\r\n begin\r\n Prop := @FDefaultColorColor;\r\n Name := cDefaultColorColor;\r\n end;\r\n else\r\n Exit;\r\n end;\r\n\r\n if (Prop^ <> Value) then\r\n begin\r\n Changing;\r\n ChangingProperty(Name);\r\n Prop^ := Value;\r\n ChangedProperty(Name);\r\n Changed;\r\n end;\r\nend;\r\n\r\nprocedure TJvOfficeColorPanelProperties.SetFontValue(const Index: Integer;\r\n const Value: TFont);\r\nvar\r\n Prop: TFont;\r\n Name: string;\r\nbegin\r\n case Index of\r\n Tag_NoneColorCaption:\r\n begin\r\n Prop := FNoneColorFont;\r\n Name := cNoneColorFont;\r\n end;\r\n Tag_DefaultColorCaption:\r\n begin\r\n Prop := FDefaultColorFont;\r\n Name := cDefaultColorFont;\r\n end;\r\n Tag_CustomColorCaption:\r\n begin\r\n Prop := FCustomColorFont;\r\n Name := cCustomColorFont;\r\n end;\r\n else\r\n Exit;\r\n end;\r\n\r\n if (Prop <> Value) then\r\n begin\r\n Changing;\r\n ChangingProperty(Name);\r\n Prop.Assign(Value);\r\n ChangedProperty(Name);\r\n Changed;\r\n end;\r\nend;\r\n\r\nprocedure TJvOfficeColorPanelProperties.OnFontChange(Sender: TObject);\r\nbegin\r\n if Sender = FNoneColorFont then\r\n ChangedProperty(cNoneColorFont)\r\n else\r\n if Sender = FDefaultColorFont then\r\n ChangedProperty(cDefaultColorFont)\r\n else\r\n if Sender = FCustomColorFont then\r\n ChangedProperty(cCustomColorFont);\r\nend;\r\n\r\n//=== { TJvColorSpeedButton } ================================================\r\n\r\nconstructor TJvColorSpeedButton.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FDrawColor := clDefault;\r\n FDisabledDrawColor := clGray;\r\n FEdgeWidth := 4;\r\n FColorQuadLayOut := cqlClient;\r\n FCanDrawColorQuad := True;\r\n FCanDrawGlyph := True;\r\n FCanDrawInnerFrame := False;\r\nend;\r\n\r\nfunction TJvColorSpeedButton.GetEdgeWidth: Integer;\r\nbegin\r\n Result := Height div 5;\r\nend;\r\n\r\nprocedure TJvColorSpeedButton.Paint;\r\nvar\r\n B, X, Y: Integer;\r\n PaintColor: TColor;\r\nbegin\r\n inherited Paint;\r\n\r\n if Enabled then\r\n PaintColor := DrawColor\r\n else\r\n PaintColor := DisabledDrawColor;\r\n if EdgeWidth >= 0 then\r\n B := EdgeWidth\r\n else\r\n B := Height div 5;\r\n with Canvas do\r\n begin\r\n if CanDrawGlyph and (not Glyph.Empty) then\r\n begin\r\n Glyph.Transparent := True;\r\n X := (Width div 2) - 9 + Integer(FState in [TJvButtonState(bsDown)]);\r\n Y := (Height div 2) + 4 + Integer(FState in [TJvButtonState(bsDown)]);\r\n if CanDrawColorQuad then\r\n begin\r\n Pen.Color := PaintColor;\r\n Brush.Color := PaintColor;\r\n Brush.Style := bsSolid;\r\n Rectangle(X, Y, X + 17, Y + 4);\r\n end;\r\n end\r\n else\r\n begin\r\n if CanDrawInnerFrame then\r\n begin\r\n Pen.Color := clGray;\r\n Brush.Style := bsClear;\r\n Rectangle(B - 1, B - 1, Width - (B - 2), Height - (B - 2));\r\n end;\r\n if CanDrawColorQuad then\r\n begin\r\n Pen.Color := clGray;\r\n Brush.Color := PaintColor;\r\n Brush.Style := bsSolid;\r\n case ColorQuadLayOut of\r\n cqlLeft:\r\n Rectangle(B + 1, B + 1, Height, Height - B);\r\n cqlRight:\r\n Rectangle(Width - Height + 1, B + 1, Width - B, Height - B);\r\n cqlClient:\r\n Rectangle(B, B, Width - B, Height - B);\r\n end;\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvColorSpeedButton.EnabledChanged;\r\nbegin\r\n inherited EnabledChanged;\r\n if Assigned(OnEnabledChagned) then\r\n OnEnabledChagned(Self);\r\nend;\r\n\r\nprocedure TJvColorSpeedButton.SetDrawColor(const Value: TColor);\r\nbegin\r\n if FDrawColor <> Value then\r\n begin\r\n FDrawColor := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvColorSpeedButton.SetDisabledDrawColor(const Value: TColor);\r\nbegin\r\n if FDisabledDrawColor <> Value then\r\n begin\r\n FDisabledDrawColor := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvColorSpeedButton.SetCanDrawColorQuad(const Value: Boolean);\r\nbegin\r\n if CanDrawColorQuad <> Value then\r\n begin\r\n FCanDrawColorQuad := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvColorSpeedButton.SetCanDrawGlyph(const Value: Boolean);\r\nbegin\r\n if FCanDrawGlyph <> Value then\r\n begin\r\n FCanDrawGlyph := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvColorSpeedButton.SetCanDrawInnerFrame(const Value: Boolean);\r\nbegin\r\n if FCanDrawInnerFrame <> Value then\r\n begin\r\n FCanDrawInnerFrame := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvColorSpeedButton.SetEdgeWidth(const Value: Integer);\r\nbegin\r\n if FEdgeWidth <> Value then\r\n begin\r\n FEdgeWidth := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvColorSpeedButton.SetFColorQuadLayOut(\r\n const Value: TJvColorQuadLayOut);\r\nbegin\r\n if FColorQuadLayOut <> Value then\r\n begin\r\n FColorQuadLayOut := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\n//if you directed set the Visible property,the control visible state never changed in design mode.\r\n//That can be hide control in design mode.\r\n\r\nprocedure SetControlVisible(Ctl: TControl; AVisible: Boolean);\r\nbegin\r\n if Ctl.Visible = AVisible then\r\n Exit;\r\n\r\n if csDesigning in Ctl.ComponentState then\r\n begin\r\n with Ctl do\r\n if AVisible then\r\n ControlStyle := ControlStyle - [csNoDesignVisible]\r\n else\r\n ControlStyle := ControlStyle + [csNoDesignVisible];\r\n end;\r\n\r\n Ctl.Visible := AVisible;\r\nend;\r\n\r\nfunction GetTopOwner(AComponent: TComponent): TComponent;\r\nbegin\r\n Result := AComponent;\r\n while (AComponent <> nil) and\r\n (AComponent.ComponentState * [csReading, csLoading] = []) do\r\n AComponent := AComponent.Owner;\r\n\r\n if AComponent <> nil then\r\n Result := AComponent;\r\nend;\r\n\r\nfunction JvReaderReadColor(Reader: TReader):TColor;\r\nbegin\r\n with Reader do\r\n begin\r\n if NextValue = vaIdent then\r\n Result := StringToColor(ReadIdent)\r\n else\r\n Result := ReadInteger;\r\n end;\r\nend;\r\n\r\n\r\nfunction JvReaderReadColorDialogOptions(Reader: TReader):TColorDialogOptions;\r\nvar\r\n EnumName: string;\r\n\r\n procedure SkipSetBody;\r\n begin\r\n while Reader.ReadStr <> '' do\r\n {nothing};\r\n end;\r\n\r\nbegin\r\n try\r\n if Reader.ReadValue <> vaSet then\r\n Exit;\r\n Result := [];\r\n while True do\r\n begin\r\n EnumName := Reader.ReadStr;\r\n if EnumName = '' then\r\n Break;\r\n if SameText(EnumName, 'cdFullOpen') then\r\n Include(Result, cdFullOpen)\r\n else\r\n if SameText(EnumName, 'cdPreventFullOpen') then\r\n Include(Result, cdPreventFullOpen)\r\n else\r\n if SameText(EnumName, 'cdShowHelp') then\r\n Include(Result, cdShowHelp)\r\n else\r\n if SameText(EnumName, 'cdSolidColor') then\r\n Include(Result, cdSolidColor)\r\n else\r\n if SameText(EnumName, 'cdAnyColor') then\r\n Include(Result, cdAnyColor);\r\n end;\r\n except\r\n SkipSetBody;\r\n end;\r\nend;\r\n\r\n\r\nprocedure JvReaderReadStrings(Reader: TReader;Strings:TStrings);\r\nbegin\r\n Reader.ReadListBegin;\r\n with Strings do\r\n begin\r\n BeginUpdate;\r\n try\r\n Clear;\r\n while not Reader.EndOfList do\r\n Add(Reader.ReadString);\r\n finally\r\n EndUpdate;\r\n end;\r\n end;\r\n Reader.ReadListEnd;\r\nend;\r\n\r\n//=== { TJvOfficeColorDrawer } ===============================================\r\n\r\nconstructor TJvOfficeColorDrawer.Create(AOwner: TComponent);\r\nbegin\r\n inherited;\r\n FCanDrawGlyph := True;\r\nend;\r\n\r\ntype\r\n TJvDefaultColorSpeendButton = class(TJvColorSpeedButton)\r\n public\r\n function HintShow(var HintInfo: THintInfo): Boolean; override;\r\n end;\r\n\r\n//=== { TJvDefaultColorSpeendButton } ========================================\r\n\r\nfunction TJvDefaultColorSpeendButton.HintShow(var HintInfo: THintInfo): Boolean;\r\nvar\r\n ColorQuadRect:TRect;\r\n B: Integer;\r\nbegin\r\n Result := inherited HintShow(HintInfo);\r\n if CanDrawColorQuad then\r\n begin\r\n if EdgeWidth >= 0 then\r\n B := EdgeWidth\r\n else\r\n B := Height div 5;\r\n case ColorQuadLayOut of\r\n cqlLeft:\r\n ColorQuadRect:= Rect(B + 1, B + 1, Height, Height - B);\r\n cqlRight:\r\n ColorQuadRect:= Rect(Width - Height + 1, B + 1, Width - B, Height - B);\r\n cqlClient:\r\n ColorQuadRect:= Rect(B, B, Width - B, Height - B);\r\n end;\r\n if PtInRect(ColorQuadRect,ScreenToClient(Mouse.CursorPos)) then\r\n HintInfo.HintStr := ColorToPrettyName(DrawColor);\r\n end;\r\nend;\r\n\r\n//=== { TJvCustomOfficeColorPanel } ==========================================\r\n\r\nconstructor TJvCustomOfficeColorPanel.Create(AOwner: TComponent);\r\nvar\r\n TopOwner: TComponent;\r\nbegin\r\n inherited Create(AOwner);\r\n ControlStyle := ControlStyle - [csAcceptsControls];\r\n FInited := False;\r\n FNeedReDrawDownState := True;\r\n FBackgroundColor := clBtnFace;\r\n FHotTrack := False;\r\n FHotTrackFont := TFont.Create;\r\n FHotTrackFontOptions := DefaultTrackFontOptions;\r\n FHotTrackOptions := TJvHotTrackOptions.Create(Self);\r\n FHotTrackOptions.OnChanged := DoHotTrackOptionsChanged;\r\n\r\n FStandardColors := TStringList.Create;\r\n FSystemColors := TStringList.Create;\r\n FUserColors := TStringList.Create;\r\n FStandardColorDrawers := TList.Create;\r\n FSystemColorDrawers := TList.Create;\r\n FUserColorDrawers := TList.Create;\r\n FAddInControls := TList.Create;\r\n\r\n FColorDialogOptions := [];\r\n FClickColorType := cctNone;\r\n\r\n FProperties := TJvOfficeColorPanelProperties.Create(Self);\r\n FProperties.OnChangedProperty := DoPropertiesChanged;\r\n FSelectedColor := FProperties.DefaultColorColor;\r\n\r\n FButtonNoneColor := TJvColorSpeedButton.Create(Self);\r\n with FButtonNoneColor do\r\n begin\r\n Parent := Self;\r\n GroupIndex := PrimaryGroupIndex;\r\n Tag := FStandardColors.Count + 1;\r\n DrawColor := FProperties.NoneColorColor;\r\n Flat := True;\r\n CanDrawColorQuad := False;\r\n CanDrawGlyph := False;\r\n CanDrawInnerFrame := False;\r\n OnClick := DoColorButtonClick;\r\n OnEnabledChagned := DoColorDrawersEnabledChange;\r\n end;\r\n FAddInControls.Add(FButtonNoneColor);\r\n\r\n FButtonDefaultColor := TJvDefaultColorSpeendButton.Create(Self);\r\n with FButtonDefaultColor do\r\n begin\r\n Parent := Self;\r\n GroupIndex := PrimaryGroupIndex;\r\n Tag := FButtonNoneColor.Tag + 1;\r\n Down := True;\r\n DrawColor := FProperties.DefaultColorColor;\r\n Flat := True;\r\n CanDrawColorQuad := True;\r\n CanDrawGlyph := False;\r\n CanDrawInnerFrame := True;\r\n ColorQuadLayOut := cqlLeft;\r\n OnClick := DoColorButtonClick;\r\n OnMouseUp := RedirectToColorButtonClick;\r\n OnEnabledChagned := DoColorDrawersEnabledChange;\r\n end;\r\n FAddInControls.Add(FButtonDefaultColor);\r\n FPriorCheckedButton := FButtonDefaultColor;\r\n\r\n FButtonCustomColor := TJvColorSpeedButton.Create(Self);\r\n with FButtonCustomColor do\r\n begin\r\n Parent := Self;\r\n GroupIndex := PrimaryGroupIndex;\r\n Tag := FButtonDefaultColor.Tag + 1;\r\n DrawColor := clDefault;\r\n Flat := True;\r\n CanDrawColorQuad := False;\r\n CanDrawGlyph := False;\r\n CanDrawInnerFrame := True;\r\n OnClick := DoColorButtonClick;\r\n OnMouseUp := RedirectToColorButtonClick;\r\n OnEnabledChagned := DoColorDrawersEnabledChange;\r\n end;\r\n FAddInControls.Add(FButtonCustomColor);\r\n\r\n FCustomColorDrawer := TJvOfficeColorDrawer.Create(Self);\r\n with FCustomColorDrawer do\r\n begin\r\n Parent := Self;\r\n GroupIndex := PrimaryGroupIndex;\r\n Tag := FButtonCustomColor.Tag + 1;\r\n Flat := True;\r\n DrawColor := clDefault;\r\n Hint := ColorToString(DrawColor);\r\n CanDrawColorQuad := True;\r\n CanDrawGlyph := False;\r\n CanDrawInnerFrame := False;\r\n ColorQuadLayOut := cqlClient;\r\n OnClick := DoColorButtonClick;\r\n OnMouseUp := RedirectToColorButtonClick;\r\n OnEnabledChagned := DoColorDrawersEnabledChange;\r\n end;\r\n FAddInControls.Add(FCustomColorDrawer);\r\n\r\n FDividerLine1 := JvDividerLineClass.Create(Self);\r\n with FDividerLine1 do\r\n begin\r\n Parent := Self;\r\n Visible := False;\r\n Height := 2;\r\n end;\r\n FDividerLine2 := JvDividerLineClass.Create(Self);\r\n with FDividerLine2 do\r\n begin\r\n Parent := Self;\r\n Visible := False;\r\n Height := 2;\r\n end;\r\n FDividerLine3 := JvDividerLineClass.Create(Self);\r\n with FDividerLine3 do\r\n begin\r\n Parent := Self;\r\n Visible := False;\r\n Height := 2;\r\n end;\r\n\r\n FColorDialog := TJvOfficeColorDialog.Create(Self);\r\n FColorDialog.Options := FColorDialogOptions;\r\n\r\n FStandardColors.BeginUpdate;\r\n try\r\n CreateStandardColors(FStandardColors);\r\n finally\r\n FStandardColors.EndUpdate;\r\n end;\r\n FSystemColors.BeginUpdate;\r\n try\r\n CreateSystemColors(FSystemColors);\r\n finally\r\n FSystemColors.EndUpdate;\r\n end;\r\n\r\n TopOwner := GetTopOwner(Self);\r\n // make sure that if this is not loading from DFM file or stream.\r\n if (TopOwner <> nil) and (TopOwner.ComponentState * [csReading, csLoading] = [])\r\n then\r\n begin\r\n FUserColors.BeginUpdate;\r\n try\r\n CreateUserColors(FUserColors);\r\n finally\r\n FUserColors.EndUpdate;\r\n end;\r\n\r\n CreateUserColorDrawers;\r\n FProperties.CreateDefaultText;\r\n end\r\n else //When loaded UserColors,Call CreateUserColorDrawers at once in DoLoadedUserColors\r\n FUserColors.OnChange := DoLoadedUserColors;\r\n\r\n CreateStandardColorDrawers;\r\n CreateSystemColorDrawers;\r\n\r\n FInited := True;\r\nend;\r\n\r\ndestructor TJvCustomOfficeColorPanel.Destroy;\r\nbegin\r\n FreeAndNil(FProperties);\r\n FreeAndNil(FHotTrackFont);\r\n FreeAndNil(FHotTrackOptions);\r\n FreeAndNil(FStandardColors);\r\n FreeAndNil(FSystemColors);\r\n FreeAndNil(FUserColors);\r\n FreeAndNil(FStandardColorDrawers);\r\n FreeAndNil(FSystemColorDrawers);\r\n FreeAndNil(FUserColorDrawers);\r\n FreeAndNil(FAddInControls);\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJvCustomOfficeColorPanel.CreateStandardColors(ColorList: TStrings): Integer;\r\nvar\r\n Index: Integer;\r\nbegin\r\n Result := 0;\r\n if ColorList <> nil then\r\n begin\r\n ColorList.BeginUpdate;\r\n ColorList.Clear;\r\n for Index := Low(StandardColorValues) to High(StandardColorValues) do\r\n ColorList.Values[\r\n ColorToString(StandardColorValues[Index].Value)] :=\r\n StandardColorValues[Index].Description;\r\n ColorList.EndUpdate;\r\n Result := ColorList.Count;\r\n end;\r\nend;\r\n\r\nfunction TJvCustomOfficeColorPanel.CreateSystemColors(ColorList: TStrings): Integer;\r\nvar\r\n Index: Integer;\r\nbegin\r\n Result := 0;\r\n if ColorList <> nil then\r\n begin\r\n ColorList.BeginUpdate;\r\n ColorList.Clear;\r\n for Index := Low(SysColorValues) to High(SysColorValues) do\r\n ColorList.Values[\r\n ColorToString(SysColorValues[Index].Value)] :=\r\n SysColorValues[Index].Description;\r\n Result := ColorList.Count;\r\n ColorList.EndUpdate;\r\n end;\r\nend;\r\n\r\nfunction TJvCustomOfficeColorPanel.CreateUserColors(ColorList: TStrings): Integer;\r\nbegin\r\n Result := 0;\r\nend;\r\n\r\nprocedure TJvCustomOfficeColorPanel.CreateColorDrawersByColors(DrawersList: TList;\r\n ColorsList: TStringList; AVisible: Boolean);\r\nvar\r\n I, ValidColCount: Integer;\r\n Drawer: TJvOfficeColorDrawer;\r\n Value, NewHint: string;\r\n ExceptionRaised: Boolean;\r\nbegin\r\n DeleteEmptyLines(ColorsList);\r\n if ColorsList.Count < 1 then\r\n Exit;\r\n\r\n //ignore the record that more then MaxSectColorCount .\r\n ValidColCount := Min(ColorsList.Count, MaxSectColorCount);\r\n if DrawersList.Count > ValidColCount then\r\n begin\r\n for I := ValidColCount to DrawersList.Count - 1 do\r\n SetControlVisible(TControl(DrawersList[I]), False);\r\n end\r\n else\r\n while DrawersList.Count < ValidColCount do\r\n begin\r\n Drawer := TJvOfficeColorDrawer.Create(Self);\r\n with Drawer do\r\n begin\r\n CanDrawColorQuad := True;\r\n CanDrawGlyph := False;\r\n CanDrawInnerFrame := False;\r\n ColorQuadLayOut := cqlClient;\r\n end;\r\n DrawersList.Add(Drawer);\r\n end;\r\n\r\n for I := 0 to ValidColCount - 1 do\r\n begin\r\n ExceptionRaised := False;\r\n Drawer := TJvOfficeColorDrawer(DrawersList[I]);\r\n with Drawer do\r\n begin\r\n Parent := Self;\r\n GroupIndex := PrimaryGroupIndex;\r\n Tag := I;\r\n Flat := True;\r\n try\r\n Value := Trim(ColorsList.Names[I]);\r\n DrawColor := StringToColor(Value);\r\n except\r\n on EConvertError do\r\n begin\r\n DrawColor := clDefault;\r\n DisabledDrawColor := Self.BackColor;\r\n ExceptionRaised := True;\r\n end;\r\n end;\r\n\r\n if ExceptionRaised then\r\n begin\r\n Drawer.Enabled := False;\r\n SetControlVisible(Drawer, False);\r\n end\r\n else\r\n SetControlVisible(Drawer, AVisible);\r\n {$IFDEF COMPILER7_UP}\r\n NewHint := ColorsList.ValueFromIndex[I];\r\n {$ELSE}\r\n NewHint := ColorsList.Values[ColorsList.Names[I]];\r\n {$ENDIF}\r\n if SameText(NewHint, cUseDefaultColorHint) then\r\n NewHint := ColorToPrettyName(DrawColor);\r\n Hint := NewHint;\r\n Transparent := False;\r\n Color := Self.BackColor;\r\n DisabledDrawColor := Self.BackColor;\r\n HotTrack := Self.HotTrack;\r\n HotTrackFont := Self.HotTrackFont;\r\n HotTrackFontOptions := Self.HotTrackFontOptions;\r\n HotTrackOptions := Self.HotTrackOptions;\r\n\r\n OnClick := DoColorButtonClick;\r\n OnEnabledChagned := DoColorDrawersEnabledChange;\r\n OnMouseUp := RedirectToColorButtonClick;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomOfficeColorPanel.CreateStandardColorDrawers;\r\nbegin\r\n CreateColorDrawersByColors(FStandardColorDrawers, FStandardColors, Properties.ShowStandardColors);\r\nend;\r\n\r\nprocedure TJvCustomOfficeColorPanel.CreateSystemColorDrawers;\r\nbegin\r\n CreateColorDrawersByColors(FSystemColorDrawers, FSystemColors, Properties.ShowSystemColors);\r\nend;\r\n\r\nprocedure TJvCustomOfficeColorPanel.CreateUserColorDrawers;\r\nbegin\r\n CreateColorDrawersByColors(FUserColorDrawers, FUserColors, Properties.ShowUserColors);\r\nend;\r\n\r\nprocedure TJvCustomOfficeColorPanel.RearrangeControls;\r\nvar\r\n I, CtrlHeight: Integer;\r\n ValidColCount: Integer;\r\n TempTopInc: Integer;\r\n StdColBtnsTop, StdColBtnsLeft: Integer;\r\n SysColBtnsTop, SysColBtnsLeft: Integer;\r\n UserColBtnsTop, UserColBtnsLeft: Integer;\r\n Control, BottomControl: TControl; // the bottom most Button\r\n CaclButtonWidth: Integer;\r\n HotTrackIntf: IJvHotTrack;\r\n R: TRect;\r\n lSiteInfo: TJvAddInControlSiteInfo;\r\nbegin\r\n if (not FInited) or (Parent = nil) or FInRearrangeControls then\r\n Exit;\r\n DisableAlign;\r\n BottomControl := nil;\r\n TempTopInc := 0;\r\n FInRearrangeControls := True;\r\n\r\n with Properties do\r\n begin\r\n CaclButtonWidth := LineColorCount * (ColorSize + ColorSpace) - ColorSpace;\r\n StdColBtnsTop := BorderWidth;\r\n StdColBtnsLeft :=BorderWidth + HorizontalMargin;\r\n\r\n //set None Color Button Bounds\r\n //do't direct set value to Visible property.\r\n SetControlVisible(FButtonNoneColor, ShowNoneColor);\r\n if FButtonNoneColor.Visible then\r\n begin\r\n FButtonNoneColor.Caption := NoneColorCaption;\r\n FButtonNoneColor.SetBounds(HorizontalMargin + BorderWidth,BorderWidth + TopMargin + TempTopInc,\r\n CaclButtonWidth, ButtonHeight);\r\n StdColBtnsTop := FButtonNoneColor.Top + FButtonNoneColor.Height;\r\n StdColBtnsLeft := FButtonNoneColor.Left;\r\n TempTopInc := BorderWidth + TopMargin + FButtonNoneColor.Height;\r\n BottomControl := FButtonNoneColor;\r\n end;\r\n\r\n //set Default Color Button Bounds\r\n SetControlVisible(FButtonDefaultColor, ShowDefaultColor);\r\n if FButtonDefaultColor.Visible then\r\n begin\r\n FButtonDefaultColor.Caption := DefaultColorCaption;\r\n FButtonDefaultColor.SetBounds(StdColBtnsLeft, TopMargin + TempTopInc,\r\n CaclButtonWidth, ButtonHeight);\r\n StdColBtnsTop := FButtonDefaultColor.Top + FButtonDefaultColor.Height;\r\n StdColBtnsLeft := FButtonDefaultColor.Left;\r\n BottomControl := FButtonDefaultColor;\r\n end;\r\n\r\n //set Standard Colors drawer position\r\n ValidColCount := Min(FStandardColors.Count, MaxSectColorCount);\r\n if FStandardColorDrawers.Count < ValidColCount then\r\n CreateStandardColorDrawers\r\n else\r\n if FStandardColorDrawers.Count > ValidColCount then\r\n for I := ValidColCount to FStandardColorDrawers.Count - 1 do\r\n SetControlVisible(TControl(FStandardColorDrawers[I]), False);\r\n\r\n for I := 0 to ValidColCount - 1 do\r\n begin\r\n Control := TJvColorSpeedButton(FStandardColorDrawers[I]);\r\n\r\n SetControlVisible(Control, ShowStandardColors);\r\n if Control.Visible then\r\n begin\r\n Control.SetBounds(StdColBtnsLeft + (I mod LineColorCount) * (ColorSpace\r\n + ColorSize),\r\n StdColBtnsTop + ColorSpaceTop + (I div LineColorCount) * (ColorSpace\r\n + ColorSize),\r\n ColorSize, ColorSize);\r\n BottomControl := Control;\r\n end;\r\n end;\r\n\r\n SysColBtnsLeft := StdColBtnsLeft;\r\n UserColBtnsLeft := StdColBtnsLeft;\r\n if not Properties.ShowStandardColors then\r\n SysColBtnsTop := StdColBtnsTop\r\n else\r\n SysColBtnsTop := BottomControl.Top + BottomControl.Height;\r\n\r\n //System colors\r\n\r\n ValidColCount := Min(FSystemColors.Count, MaxSectColorCount);\r\n if FSystemColorDrawers.Count < ValidColCount then\r\n CreateSystemColorDrawers\r\n else\r\n if FSystemColorDrawers.Count > ValidColCount then\r\n for I := ValidColCount to FSystemColorDrawers.Count - 1 do\r\n SetControlVisible(TControl(FSystemColorDrawers[I]), False);\r\n\r\n //set Divider Line position up System Colors\r\n SetControlVisible(FDividerLine1, (ShowSystemColors and (FSystemColorDrawers.Count > 0)) and\r\n ShowStandardColors);\r\n if FDividerLine1.Visible then\r\n with FDividerLine1 do\r\n begin\r\n SetBounds(StdColBtnsLeft, SysColBtnsTop + ColorSpaceBottom, CaclButtonWidth, Height);\r\n SysColBtnsTop := Top + Height;\r\n end;\r\n\r\n //set system Colors drawer position\r\n for I := 0 to ValidColCount - 1 do\r\n begin\r\n Control := TControl(FSystemColorDrawers[I]);\r\n\r\n SetControlVisible(Control, ShowSystemColors);\r\n if Control.Visible then\r\n begin\r\n Control.SetBounds(SysColBtnsLeft + (I mod LineColorCount) * (ColorSpace + ColorSize),\r\n SysColBtnsTop + ColorSpaceTop + (I div LineColorCount) * (ColorSpace + ColorSize),\r\n ColorSize, ColorSize);\r\n BottomControl := Control;\r\n end;\r\n end;\r\n\r\n if not Properties.ShowSystemColors then\r\n UserColBtnsTop := SysColBtnsTop\r\n else\r\n UserColBtnsTop := BottomControl.Top + BottomControl.Height;\r\n\r\n // User colors\r\n ValidColCount := Min(FUserColors.Count, MaxSectColorCount);\r\n if FUserColorDrawers.Count < ValidColCount then\r\n CreateUserColorDrawers\r\n else\r\n if FUserColorDrawers.Count > ValidColCount then\r\n for I := ValidColCount to FUserColorDrawers.Count - 1 do\r\n SetControlVisible(TControl(FUserColorDrawers[I]), False);\r\n\r\n // set Divider Line position up user Colors\r\n SetControlVisible(FDividerLine2,\r\n (ShowUserColors and (FUserColorDrawers.Count > 0)) and\r\n (ShowSystemColors or ShowStandardColors));\r\n if FDividerLine2.Visible then\r\n with FDividerLine2 do\r\n begin\r\n SetBounds(StdColBtnsLeft, UserColBtnsTop + ColorSpaceBottom,\r\n CaclButtonWidth, Height);\r\n UserColBtnsTop := Top + Height;\r\n end;\r\n\r\n // set User Colors drawer position\r\n for I := 0 to ValidColCount - 1 do\r\n begin\r\n Control := TControl(FUserColorDrawers[I]);\r\n\r\n SetControlVisible(Control, ShowUserColors);\r\n if Control.Visible then\r\n begin\r\n Control.SetBounds(UserColBtnsLeft + (I mod LineColorCount) *\r\n (ColorSpace + ColorSize),\r\n UserColBtnsTop + ColorSpaceTop + (I div LineColorCount) * (ColorSpace + ColorSize),\r\n ColorSize, ColorSize);\r\n BottomControl := Control;\r\n end;\r\n end;\r\n\r\n //set Divider Line position up custom color button\r\n if BottomControl = nil then\r\n TempTopInc := TopMargin\r\n else\r\n TempTopInc := BottomControl.Top + BottomControl.Height +\r\n ColorSpaceBottom;\r\n\r\n SetControlVisible(FDividerLine3,\r\n (ShowCustomColor and\r\n (ShowSystemColors or ShowStandardColors or ShowUserColors)) );\r\n if FDividerLine3.Visible then\r\n with FDividerLine3 do\r\n begin\r\n SetBounds(StdColBtnsLeft, TempTopInc, CaclButtonWidth, Height);\r\n BottomControl := FDividerLine3;\r\n end;\r\n\r\n //set Custom color button Bounds\r\n if BottomControl = nil then\r\n TempTopInc := TopMargin\r\n else\r\n TempTopInc := BottomControl.Top + BottomControl.Height +\r\n ColorSpaceBottom;\r\n\r\n SetControlVisible(FCustomColorDrawer, ShowCustomColor);\r\n SetControlVisible(FButtonCustomColor, ShowCustomColor);\r\n with FCustomColorDrawer do\r\n if Visible then\r\n begin\r\n CtrlHeight := ButtonHeight;\r\n SetBounds(StdColBtnsLeft + CaclButtonWidth - CtrlHeight, TempTopInc,\r\n CtrlHeight, CtrlHeight);\r\n BottomControl := FCustomColorDrawer;\r\n end;\r\n with FButtonCustomColor do\r\n if Visible then\r\n begin\r\n TJvSpeedButton(FButtonCustomColor).Caption := CustomColorCaption;\r\n CtrlHeight := ButtonHeight;\r\n SetBounds(StdColBtnsLeft, TempTopInc,\r\n CaclButtonWidth - FCustomColorDrawer.Width - ColorSpace, CtrlHeight);\r\n BottomControl := FButtonCustomColor;\r\n end;\r\n\r\n //set Other Add-in Controls Bounds\r\n for I := 0 to FAddInControls.Count - 1 do\r\n begin\r\n Control := FAddInControls[I];\r\n if (Control = FButtonNoneColor) or (Control = FButtonDefaultColor) or\r\n (Control = FButtonCustomColor) or (Control = FCustomColorDrawer) then\r\n Continue;\r\n\r\n if BottomControl = nil then\r\n TempTopInc := TopMargin\r\n else\r\n TempTopInc := BottomControl.Top + BottomControl.Height + ColorSpaceBottom;\r\n\r\n with Control do\r\n begin\r\n if Visible then\r\n begin\r\n Parent := Self;\r\n CtrlHeight := Height;\r\n if Control is TJvCustomSpeedButton then\r\n with TJvSpeedButton(Control) do\r\n begin\r\n Flat := True;\r\n Color := Self.BackColor;\r\n Enabled := Self.Enabled;\r\n end;\r\n\r\n if Supports(Control, IJvHotTrack, HotTrackIntf) then\r\n with HotTrackIntf do\r\n begin\r\n HotTrack := Self.HotTrack;\r\n HotTrackFont := Self.HotTrackFont;\r\n HotTrackFontOptions := Self.HotTrackFontOptions;\r\n HotTrackOptions := Self.HotTrackOptions;\r\n end;\r\n R := Rect(StdColBtnsLeft, TempTopInc,\r\n StdColBtnsLeft + CaclButtonWidth, TempTopInc + CtrlHeight);\r\n lSiteInfo.AddInControl:= Control;\r\n lSiteInfo.BoundsRect := R;\r\n DoGetAddInControlSiteInfo(Self, lSiteInfo);\r\n BoundsRect := lSiteInfo.BoundsRect;\r\n\r\n BottomControl := Control;\r\n end;\r\n end;\r\n end;\r\n\r\n //Set panel size\r\n Width := (HorizontalMargin + BorderWidth) * 2 + ColorSize * LineColorCount +\r\n ColorSpace * (LineColorCount - 1);\r\n if BottomControl = nil then\r\n Height := 0\r\n else\r\n Height := BottomControl.Top + BottomControl.Height + BottomMargin + BorderWidth;\r\n end;\r\n EnableAlign;\r\n\r\n FInRearrangeControls := False;\r\nend;\r\n\r\nprocedure TJvCustomOfficeColorPanel.RefreshControls;\r\nbegin\r\n if FInRearrangeControls then\r\n Exit;\r\n with Properties do\r\n begin\r\n if ShowStandardColors then\r\n CreateStandardColorDrawers;\r\n if ShowSystemColors then\r\n CreateSystemColorDrawers;\r\n if ShowUserColors then\r\n CreateUserColorDrawers;\r\n if ShowStandardColors or ShowSystemColors or ShowUserColors then\r\n RearrangeControls;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomOfficeColorPanel.DoColorButtonClick(Sender: TObject);\r\nvar\r\n LastColor: TColor;\r\n\r\n procedure HoldCustomColor(AColor: TColor);\r\n var\r\n StrColor: string;\r\n begin\r\n if ClickColorType = cctCustomColor then\r\n begin\r\n StrColor := ColorToString(AColor);\r\n if (FButtonCustomColor.DrawColor <> AColor) then\r\n begin //refresh CustomColorDrawer\r\n FButtonCustomColor.DrawColor := AColor;\r\n FCustomColorDrawer.DrawColor := AColor;\r\n FCustomColorDrawer.Hint := ColorToPrettyName(AColor);\r\n end;\r\n\r\n if Properties.HoldCustomColor and\r\n ((FButtonCustomColor.DrawColor <> AColor) or (UserColors.IndexOfName(StrColor) = -1)) then\r\n begin\r\n UserColors.BeginUpdate;\r\n try\r\n UserColors.Values[StrColor] := cUseDefaultColorHint;\r\n finally\r\n UserColors.EndUpdate;\r\n end;\r\n CreateUserColorDrawers;\r\n RearrangeControls;\r\n DoHoldedCustomColor(Self,AColor);\r\n end;\r\n end;\r\n end;\r\n\r\nbegin\r\n if Sender is TJvColorSpeedButton then\r\n begin\r\n if Sender = FButtonNoneColor then\r\n FClickColorType := cctNoneColor\r\n else\r\n if Sender = FButtonDefaultColor then\r\n FClickColorType := cctDefaultColor\r\n else\r\n if Sender = FButtonCustomColor then\r\n FClickColorType := cctCustomColor\r\n else\r\n if FAddInControls.IndexOf(Sender) <> -1 then\r\n FClickColorType := cctAddInControl\r\n else\r\n FClickColorType := cctColors;\r\n end\r\n else\r\n FClickColorType := cctNone;\r\n\r\n FNeedReDrawDownState := False;\r\n try\r\n if Assigned(FOnColorButtonClick) then\r\n FOnColorButtonClick(Sender);\r\n\r\n if FClickColorType <> cctNone then\r\n begin\r\n if (FClickColorType = cctCustomColor) then\r\n begin\r\n LastColor := SelectedColor;\r\n if Assigned(FOnShowOwnerColorDialog) then\r\n begin\r\n FOnShowOwnerColorDialog(Sender);\r\n if LastColor = SelectedColor then //never changed SelectedColor\r\n begin\r\n if (FPriorCheckedButton <> nil) then\r\n FPriorCheckedButton.Down := True;\r\n end\r\n else\r\n HoldCustomColor(SelectedColor);\r\n end\r\n else\r\n begin\r\n FColorDialog.Options := FColorDialogOptions;\r\n FColorDialog.Color := SelectedColor{FCustomColorDrawer.DrawColor};\r\n if FColorDialog.Execute then\r\n begin\r\n HoldCustomColor(FColorDialog.Color);\r\n SelectedColor := FColorDialog.Color;\r\n end\r\n else\r\n if FPriorCheckedButton <> nil then //cancel the color dialog selection, restore the Prior Checked Button down\r\n FPriorCheckedButton.Down := True;\r\n end;\r\n // the PriorCheckedButton have not been assign.\r\n if ((FPriorCheckedButton <> nil) and (not FPriorCheckedButton.Down)) or\r\n // if the PriorCheckedButton is ButtonCustom,Set CustomColorDrawer.Down to true for ever.\r\n (FPriorCheckedButton = FButtonCustomColor) then\r\n FCustomColorDrawer.Down := True;\r\n end\r\n else\r\n SelectedColor := TJvColorSpeedButton(Sender).DrawColor;\r\n end;\r\n finally\r\n FNeedReDrawDownState := True;\r\n end;\r\n if Sender is TJvCustomSpeedButton then\r\n // the PriorCheckedButton have not been assign.\r\n if (FPriorCheckedButton <> nil) and (not FPriorCheckedButton.Down) then\r\n FPriorCheckedButton := TJvColorSpeedButton(Sender);\r\n\r\n FClickColorType := cctNone;\r\nend;\r\n\r\nprocedure TJvCustomOfficeColorPanel.DoSelectedColorChange(Sender: TObject);\r\nbegin\r\n if Assigned(FOnColorChange) then\r\n FOnColorChange(Self);\r\nend;\r\n\r\nprocedure TJvCustomOfficeColorPanel.DoGetAddInControlSiteInfo(Sender: TControl;\r\n var ASiteInfo: TJvAddInControlSiteInfo);\r\nbegin\r\n if Assigned(FOnGetAddInControlSiteInfo) then\r\n FOnGetAddInControlSiteInfo(Sender, ASiteInfo);\r\nend;\r\n\r\nfunction TJvCustomOfficeColorPanel.GetControlBackgroundColor: TColor;\r\nbegin\r\n Result := FBackgroundColor;\r\nend;\r\n\r\nprocedure TJvCustomOfficeColorPanel.SetControlBackgroundColor(const Value: TColor);\r\nvar\r\n I: Integer;\r\nbegin\r\n if FBackgroundColor <> Value then\r\n begin\r\n inherited Color := Value;\r\n FBackgroundColor := Value;\r\n for I := 0 to FStandardColorDrawers.Count - 1 do\r\n with TJvColorSpeedButton(FStandardColorDrawers[I]) do\r\n begin\r\n Color := Value;\r\n DisabledDrawColor := Value;\r\n end;\r\n for I := 0 to FSystemColorDrawers.Count - 1 do\r\n with TJvColorSpeedButton(FSystemColorDrawers[I]) do\r\n begin\r\n Color := Value;\r\n DisabledDrawColor := Value;\r\n end;\r\n for I := 0 to FUserColorDrawers.Count - 1 do\r\n with TJvColorSpeedButton(FUserColorDrawers[I]) do\r\n begin\r\n Color := Value;\r\n DisabledDrawColor := Value;\r\n end;\r\n for I := 0 to FAddInControls.Count - 1 do\r\n begin\r\n TControlAccessProtected(FAddInControls[I]).Color := Value;\r\n if TObject(FAddInControls[I]) is TJvColorSpeedButton then\r\n TJvColorSpeedButton(FAddInControls[I]).DisabledDrawColor := Value;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomOfficeColorPanel.SetSelectedColor(const Value: TColor);\r\n\r\n function FindColorButton(Buttons: TList; ValidColCount: Integer): TJvColorSpeedButton;\r\n var\r\n I: Integer;\r\n begin\r\n for I := 0 to ValidColCount - 1 do\r\n begin\r\n Result := TJvColorSpeedButton(Buttons[I]);\r\n if Result.DrawColor = Value then\r\n Exit;\r\n end;\r\n Result := nil;\r\n end;\r\n\r\nvar\r\n Button: TJvColorSpeedButton;\r\nbegin\r\n if FSelectedColor <> Value then\r\n begin\r\n FSelectedColor := Value;\r\n if FNeedReDrawDownState then\r\n begin\r\n if FButtonDefaultColor.DrawColor = Value then\r\n begin\r\n FButtonDefaultColor.Down := True;\r\n if FPriorCheckedButton = nil then\r\n FPriorCheckedButton := FButtonDefaultColor;\r\n end\r\n else\r\n begin\r\n FButtonDefaultColor.Down := False;\r\n Button := FindColorButton(FStandardColorDrawers, Min(FStandardColorDrawers.Count, MaxSectColorCount));\r\n if Button <> nil then\r\n Button.Down := True // all other buttons automatically switch to False due to their GroupIndex\r\n else\r\n begin\r\n Button := FindColorButton(FSystemColorDrawers, Min(FSystemColorDrawers.Count, MaxSectColorCount));\r\n if Button <> nil then\r\n Button.Down := True // all other buttons automatically switch to False due to their GroupIndex\r\n else\r\n begin\r\n Button := FindColorButton(FUserColorDrawers, Min(FUserColorDrawers.Count, MaxSectColorCount));\r\n if Button <> nil then\r\n Button.Down := True // all other buttons automatically switch to False due to their GroupIndex\r\n end;\r\n end;\r\n if (FPriorCheckedButton = nil) and (Button <> nil) then\r\n FPriorCheckedButton := Button;\r\n end;\r\n end;\r\n\r\n DoSelectedColorChange(Self);\r\n end;\r\nend;\r\n\r\nfunction TJvCustomOfficeColorPanel.GetHotTrack: Boolean;\r\nbegin\r\n Result := FHotTrack;\r\nend;\r\n\r\nfunction TJvCustomOfficeColorPanel.GetHotTrackFont: TFont;\r\nbegin\r\n Result := FHotTrackFont;\r\nend;\r\n\r\nfunction TJvCustomOfficeColorPanel.GetHotTrackFontOptions: TJvTrackFontOptions;\r\nbegin\r\n Result := FHotTrackFontOptions;\r\nend;\r\n\r\nfunction TJvCustomOfficeColorPanel.GetHotTrackOptions: TJvHotTrackOptions;\r\nbegin\r\n Result := FHotTrackOptions;\r\nend;\r\n\r\nprocedure TJvCustomOfficeColorPanel.SetHotTrack(Value: Boolean);\r\nvar\r\n I: Integer;\r\n HotTrackIntf: IJvHotTrack;\r\nbegin\r\n if FHotTrack <> Value then\r\n begin\r\n FHotTrack := Value;\r\n for I := 0 to FStandardColorDrawers.Count - 1 do\r\n TJvColorSpeedButton(FStandardColorDrawers[I]).HotTrack := Value;\r\n for I := 0 to FSystemColorDrawers.Count - 1 do\r\n TJvColorSpeedButton(FSystemColorDrawers[I]).HotTrack := Value;\r\n for I := 0 to FUserColorDrawers.Count - 1 do\r\n TJvColorSpeedButton(FUserColorDrawers[I]).HotTrack := Value;\r\n for I := 0 to FAddInControls.Count - 1 do\r\n if Supports(TObject(FAddInControls[I]), IJvHotTrack, HotTrackIntf) then\r\n HotTrackIntf.HotTrack := Value;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomOfficeColorPanel.SetHotTrackFont(Value: TFont);\r\nvar\r\n I: Integer;\r\n HotTrackIntf: IJvHotTrack;\r\nbegin\r\n if (FHotTrackFont <> Value) and (Value <> nil) then\r\n begin\r\n FHotTrackFont.Assign(Value);\r\n for I := 0 to FStandardColorDrawers.Count - 1 do\r\n TJvColorSpeedButton(FStandardColorDrawers[I]).HotTrackFont := Value;\r\n for I := 0 to FSystemColorDrawers.Count - 1 do\r\n TJvColorSpeedButton(FSystemColorDrawers[I]).HotTrackFont := Value;\r\n for I := 0 to FAddInControls.Count - 1 do\r\n if Supports(TObject(FAddInControls[I]), IJvHotTrack, HotTrackIntf) then\r\n HotTrackIntf.HotTrackFont := Value;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomOfficeColorPanel.SetHotTrackFontOptions(Value: TJvTrackFontOptions);\r\nvar\r\n I: Integer;\r\n HotTrackIntf: IJvHotTrack;\r\nbegin\r\n if FHotTrackFontOptions <> Value then\r\n begin\r\n FHotTrackFontOptions := Value;\r\n for I := 0 to FStandardColorDrawers.Count - 1 do\r\n TJvColorSpeedButton(FStandardColorDrawers[I]).HotTrackFontOptions :=\r\n Value;\r\n for I := 0 to FSystemColorDrawers.Count - 1 do\r\n TJvColorSpeedButton(FSystemColorDrawers[I]).HotTrackFontOptions := Value;\r\n for I := 0 to FAddInControls.Count - 1 do\r\n if Supports(TObject(FAddInControls[I]), IJvHotTrack, HotTrackIntf) then\r\n HotTrackIntf.HotTrackFontOptions := Value;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomOfficeColorPanel.SetHotTrackOptions(Value: TJvHotTrackOptions);\r\nvar\r\n I: Integer;\r\n HotTrackIntf: IJvHotTrack;\r\nbegin\r\n if (FHotTrackOptions <> Value) and (Value <> nil) then\r\n begin\r\n FHotTrackOptions.Assign(Value);\r\n for I := 0 to FStandardColorDrawers.Count - 1 do\r\n TJvColorSpeedButton(FStandardColorDrawers[I]).HotTrackOptions := Value;\r\n for I := 0 to FSystemColorDrawers.Count - 1 do\r\n TJvColorSpeedButton(FSystemColorDrawers[I]).HotTrackOptions := Value;\r\n for I := 0 to FUserColorDrawers.Count - 1 do\r\n TJvColorSpeedButton(FUserColorDrawers[I]).HotTrackOptions := Value;\r\n\r\n for I := 0 to FAddInControls.Count - 1 do\r\n if Supports(TObject(FAddInControls[I]), IJvHotTrack, HotTrackIntf) then\r\n HotTrackIntf.HotTrackOptions := Value;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomOfficeColorPanel.IJvHotTrack_Assign(\r\n Source: IJvHotTrack);\r\nbegin\r\n if (Source <> nil) and (IJvHotTrack(Self) <> Source) then\r\n begin\r\n HotTrack := Source.HotTrack;\r\n HotTrackFont :=Source.HotTrackFont;\r\n HotTrackFontOptions := Source.HotTrackFontOptions;\r\n HotTrackOptions := Source.HotTrackOptions;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomOfficeColorPanel.DoHotTrackOptionsChanged(Sender: TObject);\r\nvar\r\n I: Integer;\r\n HotTrackIntf: IJvHotTrack;\r\n DrawInnerFrame: Boolean;\r\nbegin\r\n DrawInnerFrame := not HotTrackOptions.Enabled;\r\n FButtonDefaultColor.CanDrawInnerFrame := DrawInnerFrame;\r\n FButtonCustomColor.CanDrawInnerFrame := DrawInnerFrame;\r\n\r\n for I := 0 to FStandardColorDrawers.Count - 1 do\r\n TJvColorSpeedButton(FStandardColorDrawers[I]).HotTrackOptions :=\r\n FHotTrackOptions;\r\n for I := 0 to FSystemColorDrawers.Count - 1 do\r\n TJvColorSpeedButton(FSystemColorDrawers[I]).HotTrackOptions :=\r\n FHotTrackOptions;\r\n for I := 0 to FUserColorDrawers.Count - 1 do\r\n TJvColorSpeedButton(FUserColorDrawers[I]).HotTrackOptions :=\r\n FHotTrackOptions;\r\n for I := 0 to FAddInControls.Count - 1 do\r\n if Supports(TObject(FAddInControls[I]), IJvHotTrack, HotTrackIntf) then\r\n HotTrackIntf.HotTrackOptions := FHotTrackOptions;\r\nend;\r\n\r\nfunction TJvCustomOfficeColorPanel.GetColorDlgCustomColors: TStrings;\r\nbegin\r\n Result := FColorDialog.CustomColors;\r\nend;\r\n\r\nprocedure TJvCustomOfficeColorPanel.SetColorDlgCustomColors(const Value: TStrings);\r\nbegin\r\n FColorDialog.CustomColors.Assign(Value);\r\nend;\r\n\r\nprocedure TJvCustomOfficeColorPanel.SetStandardColors(const Value: TStringList);\r\nbegin\r\n if (FStandardColors <> Value) and (Value <> nil) then\r\n begin\r\n FStandardColors.Assign(Value);\r\n RefreshControls;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomOfficeColorPanel.SetSystemColors(const Value: TStringList);\r\nbegin\r\n if (FSystemColors <> Value) and (Value <> nil) then\r\n begin\r\n FSystemColors.Assign(Value);\r\n RefreshControls;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomOfficeColorPanel.SetUserColors(const Value: TStringList);\r\nbegin\r\n if (FUserColors <> Value) and (Value <> nil) then\r\n begin\r\n FUserColors.Assign(Value);\r\n RefreshControls;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomOfficeColorPanel.DoColorDrawersEnabledChange(Sender: TObject);\r\nbegin\r\n if Sender is TJvColorSpeedButton then\r\n TJvColorSpeedButton(Sender).DisabledDrawColor := BackColor;\r\nend;\r\n\r\nprocedure TJvCustomOfficeColorPanel.DoLoadedUserColors(Sender: TObject);\r\nbegin\r\n FUserColors.OnChange := nil; // Run once time only.\r\n CreateUserColorDrawers;\r\nend;\r\n\r\nprocedure TJvCustomOfficeColorPanel.DoHoldedCustomColor(Sender: TObject;AColor: TColor);\r\nbegin\r\n if Assigned(FOnHoldCustomColor) then\r\n FOnHoldCustomColor(Self,AColor);\r\nend;\r\n\r\nprocedure TJvCustomOfficeColorPanel.Loaded;\r\nbegin\r\n inherited Loaded;\r\n FUserColors.OnChange := nil;\r\nend;\r\n\r\nprocedure TJvCustomOfficeColorPanel.Resize;\r\nbegin\r\n inherited Resize;\r\n if not FInRearrangeControls then\r\n RearrangeControls;\r\nend;\r\n\r\nprocedure TJvCustomOfficeColorPanel.SetEnabled(Value: Boolean);\r\nvar\r\n I: Integer;\r\nbegin\r\n inherited SetEnabled(Value);\r\n for I := 0 to FStandardColorDrawers.Count - 1 do\r\n TControl(FStandardColorDrawers[I]).Enabled := Value;\r\n for I := 0 to FSystemColorDrawers.Count - 1 do\r\n TControl(FSystemColorDrawers[I]).Enabled := Value;\r\n for I := 0 to FUserColorDrawers.Count - 1 do\r\n TControl(FUserColorDrawers[I]).Enabled := Value;\r\n for I := 0 to FAddInControls.Count - 1 do\r\n TControl(FAddInControls[I]).Enabled := Value;\r\nend;\r\n\r\nprocedure TJvCustomOfficeColorPanel.ShowHintChanged;\r\nvar\r\n I: Integer;\r\nbegin\r\n inherited ShowHintChanged;\r\n for I := 0 to FStandardColorDrawers.Count - 1 do\r\n TControl(FStandardColorDrawers[I]).ShowHint := ShowHint;\r\n for I := 0 to FSystemColorDrawers.Count - 1 do\r\n TControl(FSystemColorDrawers[I]).ShowHint := ShowHint;\r\n for I := 0 to FUserColorDrawers.Count - 1 do\r\n TControl(FUserColorDrawers[I]).ShowHint := ShowHint;\r\n for I := 0 to FAddInControls.Count - 1 do\r\n TControl(FAddInControls[I]).ShowHint := ShowHint;\r\nend;\r\n\r\n\r\n\r\nprocedure TJvCustomOfficeColorPanel.SetColorDialogOptions(const Value: TColorDialogOptions);\r\nbegin\r\n FColorDialogOptions := Value;\r\nend;\r\n\r\nprocedure TJvCustomOfficeColorPanel.CreateWnd;\r\nbegin\r\n inherited CreateWnd;\r\n RearrangeControls;\r\nend;\r\n\r\n\r\n\r\n\r\n\r\nprocedure TJvCustomOfficeColorPanel.SetProperties(const Value: TJvOfficeColorPanelProperties);\r\nbegin\r\n if (FProperties <> Value) and (Value <> nil) then\r\n FProperties.Assign(Value);\r\nend;\r\n\r\nprocedure TJvCustomOfficeColorPanel.DoPropertiesChanged(Sender: TObject;\r\n const PropName: string);\r\nvar\r\n RealignFlag: Boolean;\r\n I: Integer;\r\nbegin\r\n { The initial value is do't Adjust size,if you wan't adjust size when a property changed,\r\n add a sentence like following to do nothing to skip notify. }\r\n RealignFlag := False;\r\n\r\n if SameText(PropName, cNoneColorCaption) then\r\n FButtonNoneColor.Caption := Properties.NoneColorCaption\r\n else\r\n if SameText(PropName, cDefaultColorCaption) then\r\n FButtonDefaultColor.Caption := Properties.DefaultColorCaption\r\n else\r\n if SameText(PropName, cCustomColorCaption) then\r\n FButtonCustomColor.Caption := Properties.CustomColorCaption\r\n else\r\n if SameText(PropName, cNoneColorHint) then\r\n FButtonNoneColor.Hint := Properties.NoneColorHint\r\n else\r\n if SameText(PropName, cDefaultColorHint) then\r\n FButtonDefaultColor.Hint := Properties.DefaultColorHint\r\n else\r\n if SameText(PropName, cCustomColorHint) then\r\n FButtonCustomColor.Hint := Properties.CustomColorHint\r\n else\r\n if SameText(PropName, cNoneColorColor) then\r\n FButtonNoneColor.DrawColor := Properties.NoneColorColor\r\n else\r\n if SameText(PropName, cDefaultColorColor) then\r\n FButtonDefaultColor.DrawColor := Properties.DefaultColorColor\r\n else\r\n if SameText(PropName, cNoneColorFont) then\r\n FButtonNoneColor.Font := Properties.NoneColorFont\r\n else\r\n if SameText(PropName, cDefaultColorFont) then\r\n FButtonDefaultColor.Font := Properties.DefaultColorFont\r\n else\r\n if SameText(PropName, cCustomColorFont) then\r\n FButtonCustomColor.Font := Properties.CustomColorFont\r\n else\r\n if SameText(PropName, cShowAddInHint) then\r\n begin\r\n FButtonNoneColor.ShowHint := Properties.ShowAddInHint;\r\n FButtonDefaultColor.ShowHint := Properties.ShowAddInHint;\r\n FButtonCustomColor.ShowHint := Properties.ShowAddInHint;\r\n end\r\n else\r\n if SameText(PropName, cShowColorsHint) then\r\n begin\r\n for I := 0 to FStandardColorDrawers.Count - 1 do\r\n TControl(FStandardColorDrawers[I]).ShowHint := Properties.ShowColorsHint;\r\n for I := 0 to FSystemColorDrawers.Count - 1 do\r\n TControl(FSystemColorDrawers[I]).ShowHint := Properties.ShowColorsHint;\r\n for I := 0 to FUserColorDrawers.Count - 1 do\r\n TControl(FUserColorDrawers[I]).ShowHint := Properties.ShowColorsHint;\r\n end\r\n else\r\n if SameText(PropName, cRightClickSelect) or\r\n SameText(PropName, cHoldCustomColor) or\r\n SameText(PropName, cRightClickSelect) then\r\n else // Other property change will adjust size by default.\r\n RealignFlag := True;\r\n\r\n if RealignFlag then\r\n RearrangeControls;\r\nend;\r\n\r\nprocedure TJvCustomOfficeColorPanel.RedirectToColorButtonClick(Sender: TObject;\r\n Button: TMouseButton; Shift: TShiftState; X, Y: Integer);\r\nvar\r\n Parent: TWinControl;\r\nbegin\r\n if Assigned(OnMouseUp) then\r\n OnMouseUp(Sender, Button, Shift, X, Y);\r\n\r\n // If any of the possible parents has a popup menu, we let it\r\n // run, and do not select the button (hence the exit), unless\r\n // the properties tell us to select anyway\r\n Parent := Self;\r\n while Assigned(Parent) do\r\n if Assigned(TControlAccessProtected(Parent).PopupMenu) then\r\n begin\r\n if not Properties.SelectIfPopup then\r\n Exit;\r\n end\r\n else\r\n Parent := Parent.Parent;\r\n\r\n // if the user asked not to right click select, we stop here\r\n if not Properties.RightClickSelect then\r\n Exit;\r\n\r\n if Button = mbRight then\r\n DoColorButtonClick(Sender);\r\nend;\r\n\r\n{ TJvOfficeColorPanel }\r\n\r\nprocedure TJvOfficeColorPanel.DefineProperties(Filer: TFiler);\r\nbegin\r\n inherited DefineProperties(Filer);\r\n { For backwards compatibility }\r\n FFilerTag := 'Color';\r\n Filer.DefineProperty(FFilerTag, ReadData, nil, False);\r\n FFilerTag := 'Flat';\r\n Filer.DefineProperty(FFilerTag, ReadData, nil, False);\r\n FFilerTag := 'CustomColors';\r\n Filer.DefineProperty(FFilerTag, ReadData, nil, False);\r\n FFilerTag := 'Options';\r\n Filer.DefineProperty(FFilerTag, ReadData, nil, False);\r\nend;\r\n\r\nprocedure TJvOfficeColorPanel.ReadData(Reader: TReader);\r\nbegin\r\n if SameText(FFilerTag, 'Color') then\r\n SelectedColor := JvReaderReadColor(Reader)\r\n else\r\n if SameText(FFilerTag, 'Flat') then\r\n FlatBorder := Reader.ReadBoolean\r\n else\r\n if SameText(FFilerTag, 'CustomColors') then\r\n JvReaderReadStrings(Reader,ColorDlgCustomColors)\r\n else\r\n if SameText(FFilerTag, 'Options') then\r\n ColorDialogOptions := JvReaderReadColorDialogOptions(Reader)\r\n ;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n\r\n" }, { "path": "External/Jedi/Jvcl/run/JvOfficeDragBarForm.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvOfficeColorForm.PAS, released on 2004-02-26.\r\n\r\nThe Initial Developer of the Original Code is dejoy [dejoy att ynl dott gov dott cn]\r\nPortions created by Peter Thrnqvist are Copyright (C) 2004 Peter Thrnqvist.\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\n dejoy,\r\n Andreas Hausladen\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvOfficeDragBarForm.pas 13145 2011-11-02 21:15:19Z ahuser $\r\n\r\nunit JvOfficeDragBarForm;\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n SysUtils, Classes,\r\n Windows, Messages, Graphics, Controls, Forms,\r\n JvComponent;\r\n\r\nconst\r\n MinDragBarHeight = 7;\r\n MinDragBarSpace = 3;\r\n\r\n Tag_DragBarHeight = 9;\r\n Tag_DragBarSpace = 10;\r\n\r\n JvDefaultSubDragBarActiveColor = clActiveCaption;\r\n JvDefaultSubDragBarInactiveColor = clInactiveCaption;\r\n\r\ntype\r\n TJvOfficeDragBarForm = class;\r\n\r\n { Internal class }\r\n TJvOfficePanelDragBar = class(TJvWinControl)\r\n private\r\n FOwnerForm: TJvOfficeDragBarForm;\r\n protected\r\n procedure MouseEnter(Control: TControl); override;\r\n procedure MouseLeave(Control: TControl); override;\r\n procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;\r\n procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;\r\n procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;\r\n end;\r\n\r\n TJvOfficeDragBarForm = class(TJvForm)\r\n private\r\n FBusy: Boolean;\r\n FInited: Boolean;\r\n FWordStyle: Boolean;\r\n FClient: TControl;\r\n FDragBar: TJvOfficePanelDragBar;\r\n FDragBarSpace: Integer;\r\n FDragBarHeight: Integer;\r\n FFlat: Boolean;\r\n FToolWindowStyle: Boolean;\r\n FOnShowingChanged: TNotifyEvent;\r\n FOnKillFocus: TNotifyEvent;\r\n FOnWindowStyleChanged: TNotifyEvent;\r\n FShowDragBar: Boolean;\r\n FDragBarHint: string;\r\n procedure FormDeactivate(Sender: TObject);\r\n procedure FormKeyUp(Sender: TObject; var Key: Word; Shift: TShiftState);\r\n procedure SetMeasure(const Index, Value: Integer);\r\n procedure SetFlat(const Value: Boolean);\r\n procedure SetWordStyle(const Value: Boolean);\r\n procedure SetToolWindowStyle(const Value: Boolean);\r\n procedure SetShowDragBar(const Value: Boolean);\r\n procedure SetDragBarHint(const Value: string);\r\n protected\r\n DropDownMoved: Boolean;\r\n DropDownMoving: Boolean;\r\n MoveEnd: Boolean;\r\n MoveStart: Boolean;\r\n procedure SetClient(AControl: TControl);\r\n procedure Resize; override;\r\n procedure VisibleChanged; override;\r\n procedure CreateParams(var Params: TCreateParams); override;\r\n procedure FocusKilled(NextWnd: THandle); override;\r\n procedure ShowingChanged; override;\r\n property OnShowingChanged: TNotifyEvent read FOnShowingChanged write FOnShowingChanged;\r\n property OnKillFocus: TNotifyEvent read FOnKillFocus write FOnKillFocus;\r\n property OnWindowStyleChanged: TNotifyEvent read FOnWindowStyleChanged write FOnWindowStyleChanged;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n procedure AdjustForm; virtual;\r\n property Client: TControl read FClient;\r\n property ShowDragBar: Boolean read FShowDragBar write SetShowDragBar default True;\r\n property DragBarHeight: Integer index Tag_DragBarHeight read FDragBarHeight write SetMeasure;\r\n property DragBarHint: string read FDragBarHint write SetDragBarHint;\r\n property DragBarSpace: Integer index Tag_DragBarSpace read FDragBarSpace write SetMeasure;\r\n property ToolWindowStyle: Boolean read FToolWindowStyle write SetToolWindowStyle default False;\r\n property Flat: Boolean read FFlat write SetFlat;\r\n procedure AfterConstruction; override;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvOfficeDragBarForm.pas $';\r\n Revision: '$Revision: 13145 $';\r\n Date: '$Date: 2011-11-02 22:15:19 +0100 (mer. 02 nov. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\n//=== { TJvOfficeDragBarForm } =================================================\r\n\r\nconstructor TJvOfficeDragBarForm.Create(AOwner: TComponent);\r\nvar\r\n ParentControl: TWinControl;\r\nbegin\r\n inherited CreateNew(AOwner);\r\n HintColor := Application.HintColor;\r\n FInited := False;\r\n FShowDragBar := True;\r\n// Scaled := False;\r\n AutoScroll := False;\r\n BorderIcons := [];\r\n BorderStyle := bsDialog;\r\n BorderWidth := 0;\r\n AutoSize := True;\r\n FormStyle := fsStayOnTop;\r\n\r\n FToolWindowStyle := False;\r\n ParentControl := Self;\r\n\r\n FDragBar := TJvOfficePanelDragBar.Create(Self);\r\n with FDragBar do\r\n begin\r\n Parent := ParentControl;\r\n FOwnerForm := Self;\r\n AutoSize := False;\r\n Caption := '';\r\n Color := JvDefaultSubDragBarActiveColor;\r\n Height := MinDragBarHeight;\r\n ShowHint := True;\r\n end;\r\n\r\n SetWordStyle(True);\r\n KeyPreview := True;\r\n OnDeactivate := FormDeactivate;\r\n OnKeyUp := FormKeyUp;\r\nend;\r\n\r\nprocedure TJvOfficeDragBarForm.AfterConstruction;\r\nbegin\r\n inherited AfterConstruction;\r\n FInited := True;\r\nend;\r\n\r\nprocedure TJvOfficeDragBarForm.SetClient(AControl: TControl);\r\nbegin\r\n if FClient <> nil then\r\n FClient.Parent := nil;\r\n FClient := AControl;\r\n if FClient <> nil then\r\n FClient.Parent := Self;\r\nend;\r\n\r\nprocedure TJvOfficeDragBarForm.CreateParams(var Params: TCreateParams);\r\nbegin\r\n inherited CreateParams(Params);\r\n with Params do\r\n Style := Style and not WS_CAPTION;\r\nend;\r\n\r\nprocedure TJvOfficeDragBarForm.FormKeyUp(Sender: TObject; var Key: Word;\r\n Shift: TShiftState);\r\nbegin\r\n if Key = VK_ESCAPE then\r\n begin\r\n Hide;\r\n ModalResult := mrCancel;\r\n end;\r\nend;\r\n\r\nprocedure TJvOfficeDragBarForm.AdjustForm;\r\nvar\r\n TempHeight: Integer;\r\n HasDragBar: Boolean;\r\n Offset: Integer;\r\nbegin\r\n if not FInited or FBusy then\r\n Exit;\r\n FBusy := True;\r\n\r\n DisableAlign;\r\n\r\n if ShowDragBar and not ToolWindowStyle then\r\n begin\r\n FDragBar.Visible := True;\r\n HasDragBar := FDragBar.Visible;\r\n FDragBar.Height := FDragBarHeight;\r\n end\r\n else\r\n begin\r\n HasDragBar := False;\r\n FDragBar.Visible := False;\r\n end;\r\n\r\n Offset := 0;\r\n\r\n if HasDragBar then\r\n TempHeight := FDragBarHeight + FDragBarSpace * 2\r\n else\r\n TempHeight := 0;\r\n\r\n ClientHeight := TempHeight + Client.ClientHeight + Offset * 2;\r\n\r\n Width := Client.Width + Offset * 2;\r\n\r\n\r\n if FDragBar.Visible then\r\n FDragBar.SetBounds(Offset, FDragBarSpace + Offset, Client.Width, FDragBarHeight);\r\n\r\n Client.SetBounds(Offset, TempHeight + 1, Client.Width, Client.Height);\r\n FBusy := False;\r\nend;\r\n\r\nprocedure TJvOfficeDragBarForm.SetMeasure(const Index, Value: Integer);\r\nvar\r\n MeasureItem: PInteger;\r\n MeasureConst: Integer;\r\nbegin\r\n case Index of\r\n Tag_DragBarHeight:\r\n begin\r\n MeasureItem := @FDragBarHeight;\r\n MeasureConst := MinDragBarHeight;\r\n end;\r\n Tag_DragBarSpace:\r\n begin\r\n MeasureItem := @FDragBarSpace;\r\n MeasureConst := MinDragBarSpace;\r\n end;\r\n else\r\n Exit;\r\n end;\r\n if MeasureItem^ = Value then\r\n Exit;\r\n\r\n MeasureItem^ := Value;\r\n FWordStyle := False;\r\n if MeasureItem^ < MeasureConst then\r\n MeasureItem^ := MeasureConst;\r\n AdjustForm;\r\nend;\r\n\r\nprocedure TJvOfficeDragBarForm.SetFlat(const Value: Boolean);\r\nbegin\r\n if FFlat <> Value then\r\n begin\r\n FFlat := Value;\r\n end;\r\nend;\r\n\r\nprocedure TJvOfficeDragBarForm.SetToolWindowStyle(const Value: Boolean);\r\nbegin\r\n if ShowDragBar then\r\n begin\r\n FToolWindowStyle := Value;\r\n if Value then\r\n begin\r\n BorderIcons := [biSystemMenu];\r\n BorderStyle := bsToolWindow;\r\n {$IFDEF COMPILER10_UP}\r\n if HandleAllocated then // BDS 2006 bug\r\n RecreateWnd;\r\n {$ENDIF COMPILER10_UP}\r\n FDragBar.Visible := False;\r\n end\r\n else\r\n begin\r\n BorderIcons := [];\r\n BorderStyle := bsDialog;\r\n {$IFDEF COMPILER10_UP}\r\n if HandleAllocated then // BDS 2006 bug\r\n RecreateWnd;\r\n {$ENDIF COMPILER10_UP}\r\n FDragBar.Visible := True;\r\n end;\r\n if not DropDownMoving then\r\n AdjustForm;\r\n if Assigned(FOnWindowStyleChanged) then\r\n FOnWindowStyleChanged(Self);\r\n end\r\n else\r\n begin\r\n FToolWindowStyle := False;\r\n BorderIcons := [];\r\n BorderStyle := bsDialog;\r\n {$IFDEF COMPILER10_UP}\r\n if HandleAllocated then // BDS 2006 bug\r\n RecreateWnd;\r\n {$ENDIF COMPILER10_UP}\r\n FDragBar.Visible := False;\r\n end;\r\nend;\r\n\r\nprocedure TJvOfficeDragBarForm.ShowingChanged;\r\nbegin\r\n inherited ShowingChanged;\r\n if Assigned(FOnShowingChanged) then\r\n FOnShowingChanged(ActiveControl);\r\nend;\r\n\r\nprocedure TJvOfficeDragBarForm.FocusKilled(NextWnd: THandle);\r\nbegin\r\n inherited FocusKilled(NextWnd);\r\n if Assigned(FOnKillFocus) and not DropDownMoving then\r\n FOnKillFocus(ActiveControl);\r\nend;\r\n\r\nprocedure TJvOfficeDragBarForm.FormDeactivate(Sender: TObject);\r\nbegin\r\n MoveStart := False;\r\n DropDownMoved := False;\r\nend;\r\n\r\nprocedure TJvOfficeDragBarForm.VisibleChanged;\r\nbegin\r\n inherited VisibleChanged;\r\n if not Visible then\r\n begin\r\n if ToolWindowStyle then\r\n ToolWindowStyle := False;\r\n\r\n DropDownMoving := False;\r\n MoveStart := False;\r\n DropDownMoved := False;\r\n end;\r\nend;\r\n\r\nprocedure TJvOfficeDragBarForm.SetDragBarHint(const Value: string);\r\nbegin\r\n if FDragBarHint<>Value then\r\n begin\r\n FDragBarHint := Value;\r\n FDragBar.Hint := Value;\r\n end;\r\nend;\r\n\r\n//=== { TJvOfficePanelDragBar } =========================================\r\n\r\nprocedure TJvOfficePanelDragBar.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);\r\nbegin\r\n inherited MouseDown(Button, Shift, X, Y);\r\n if Button = mbLeft then\r\n TJvOfficeDragBarForm(FOwnerForm).MoveStart := True;\r\nend;\r\n\r\nprocedure TJvOfficePanelDragBar.MouseEnter(Control: TControl);\r\nbegin\r\n inherited MouseEnter(Control);\r\n Color := JvDefaultSubDragBarActiveColor;\r\n Cursor := crSizeAll;\r\nend;\r\n\r\nprocedure TJvOfficePanelDragBar.MouseLeave(Control: TControl);\r\nbegin\r\n inherited MouseLeave(Control);\r\n Color := JvDefaultSubDragBarInactiveColor;\r\n Cursor := crDefault;\r\nend;\r\n\r\nprocedure TJvOfficeDragBarForm.Resize;\r\nbegin\r\n inherited Resize;\r\n if FInited then\r\n AdjustForm;\r\nend;\r\n\r\nprocedure TJvOfficeDragBarForm.SetWordStyle(const Value: Boolean);\r\nbegin\r\n if FWordStyle <> Value then\r\n begin\r\n FWordStyle := Value;\r\n if FWordStyle then\r\n begin\r\n FDragBarHeight := MinDragBarHeight;\r\n FDragBarSpace := MinDragBarSpace;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure DragControl(WinControl: TWinControl);\r\nconst\r\n SM = $F012;\r\nbegin\r\n ReleaseCapture;\r\n WinControl.Perform(WM_SYSCOMMAND, SM, 0);\r\nend;\r\n\r\nprocedure TJvOfficePanelDragBar.MouseMove(Shift: TShiftState; X, Y: Integer);\r\nvar\r\n lOwnerForm: TJvOfficeDragBarForm;\r\nbegin\r\n inherited MouseMove(Shift, X, Y);\r\n lOwnerForm := TJvOfficeDragBarForm(FOwnerForm);\r\n if lOwnerForm.MoveStart or lOwnerForm.DropDownMoving then\r\n begin\r\n if not lOwnerForm.DropDownMoved then\r\n lOwnerForm.DropDownMoved := True;\r\n if lOwnerForm.MoveStart and not lOwnerForm.ToolWindowStyle then\r\n begin\r\n lOwnerForm.ToolWindowStyle := True;\r\n lOwnerForm.AdjustForm;\r\n end;\r\n DragControl(lOwnerForm);\r\n\r\n lOwnerForm.DropDownMoving := True;\r\n lOwnerForm.MoveStart := False;\r\n end;\r\nend;\r\n\r\nprocedure TJvOfficePanelDragBar.MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);\r\nbegin\r\n inherited MouseUp(Button, Shift, X, Y);\r\n if Button = mbLeft then\r\n begin\r\n FOwnerForm.MoveStart := False;\r\n FOwnerForm.DropDownMoving := False;\r\n end;\r\nend;\r\n\r\nprocedure TJvOfficeDragBarForm.SetShowDragBar(const Value: Boolean);\r\nbegin\r\n FShowDragBar := Value;\r\n if Value then\r\n begin\r\n if not DropDownMoved then\r\n FDragBar.Visible := True;\r\n end\r\n else\r\n begin\r\n if DropDownMoved then\r\n SetToolWindowStyle(False);\r\n end;\r\n AdjustForm;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n " }, { "path": "External/Jedi/Jvcl/run/JvOracleDataSet.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvOdacSmartQuery.PAS, released on 2002-05-26.\r\n\r\nThe Initial Developer of the Original Code is Jens Fudickar\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nDescription:\r\n Oracle Dataset with Threaded Functions\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvOracleDataSet.pas 13104 2011-09-07 06:50:43Z obones $\r\n\r\nunit JvOracleDataSet;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n SysUtils, Classes, StdCtrls, ExtCtrls, Forms, Controls, DB,\r\n OracleData,\r\n JvThread, JvThreadDialog, JvDynControlEngine, JvBaseDBThreadedDataSet;\r\n\r\ntype\r\n TJvDoaThreadedDatasetAllowedContinueRecordFetchOptions =\r\n class(TJvBaseThreadedDatasetAllowedContinueRecordFetchOptions)\r\n public\r\n constructor Create; override;\r\n published\r\n property All;\r\n property Cancel;\r\n property Pause;\r\n end;\r\n\r\n TJvDoaThreadedDatasetEnhancedOptions = class(TJvBaseThreadedDatasetEnhancedOptions)\r\n private\r\n function GetAllowedContinueRecordFetchOptions: TJvDoaThreadedDatasetAllowedContinueRecordFetchOptions;\r\n procedure SetAllowedContinueRecordFetchOptions(const Value: TJvDoaThreadedDatasetAllowedContinueRecordFetchOptions);\r\n protected\r\n function CreateAllowedContinueRecordFetchOptions: TJvBaseThreadedDatasetAllowedContinueRecordFetchOptions; override;\r\n published\r\n property AllowedContinueRecordFetchOptions: TJvDoaThreadedDatasetAllowedContinueRecordFetchOptions read\r\n GetAllowedContinueRecordFetchOptions write SetAllowedContinueRecordFetchOptions;\r\n end;\r\n\r\n TJvOracleDatasetThreadHandler = class(TJvBaseDatasetThreadHandler)\r\n private\r\n function GetEnhancedOptions: TJvDoaThreadedDatasetEnhancedOptions;\r\n procedure SetEnhancedOptions(const Value: TJvDoaThreadedDatasetEnhancedOptions);\r\n protected\r\n function CreateEnhancedOptions: TJvBaseThreadedDatasetEnhancedOptions; override;\r\n published\r\n property EnhancedOptions: TJvDoaThreadedDatasetEnhancedOptions read GetEnhancedOptions write SetEnhancedOptions;\r\n end;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvOracleDataset = class(TOracleDataset, IJvThreadedDatasetInterface)\r\n procedure BreakExecution;\r\n procedure BringThreadDialogToFront;\r\n function DoGetInheritedNextRecord: Boolean;\r\n procedure DoInheritedAfterOpen;\r\n procedure DoInheritedAfterRefresh;\r\n procedure DoInheritedAfterScroll;\r\n procedure DoInheritedBeforeOpen;\r\n procedure DoInheritedBeforeRefresh;\r\n procedure DoInheritedInternalLast;\r\n procedure DoInheritedInternalRefresh;\r\n procedure DoInheritedSetActive(Active: Boolean);\r\n procedure DoInternalOpen;\r\n function GetDatasetFetchAllRecords: Boolean;\r\n function IsThreadAllowed: Boolean;\r\n procedure SetDatasetFetchAllRecords(const Value: Boolean);\r\n private\r\n FAfterFetchRecord: TAfterFetchRecordEvent;\r\n FThreadHandler: TJvBaseDatasetThreadHandler;\r\n function GetAfterOpenFetch: TDataSetNotifyEvent;\r\n function GetBeforeThreadExecution: TJvThreadedDatasetThreadEvent;\r\n function GetAfterThreadExecution: TJvThreadedDatasetThreadEvent;\r\n function GetDialogOptions: TJvThreadedDatasetDialogOptions;\r\n function GetEnhancedOptions: TJvDoaThreadedDatasetEnhancedOptions;\r\n function GetThreadOptions: TJvThreadedDatasetThreadOptions;\r\n procedure SetAfterOpenFetch(const Value: TDataSetNotifyEvent);\r\n procedure SetBeforeThreadExecution(const Value: TJvThreadedDatasetThreadEvent);\r\n procedure SetAfterThreadExecution(const Value: TJvThreadedDatasetThreadEvent);\r\n procedure SetDialogOptions(Value: TJvThreadedDatasetDialogOptions);\r\n procedure SetEnhancedOptions(const Value: TJvDoaThreadedDatasetEnhancedOptions);\r\n procedure SetThreadOptions(const Value: TJvThreadedDatasetThreadOptions);\r\n property ThreadHandler: TJvBaseDatasetThreadHandler read FThreadHandler;\r\n protected\r\n procedure DoAfterOpen; override;\r\n procedure DoAfterScroll; override;\r\n procedure DoAfterRefresh; override;\r\n procedure DoBeforeOpen; override;\r\n procedure DoBeforeRefresh; override;\r\n function GetNextRecord: Boolean; override;\r\n function GetOnThreadException: TJvThreadedDatasetThreadExceptionEvent;\r\n procedure InternalLast; override;\r\n procedure InternalRefresh; override;\r\n procedure ReplaceAfterFetchRecord(Sender: TOracleDataSet; FilterAccept: Boolean;\r\n var Action: TAfterFetchRecordAction);\r\n procedure SetActive(Value: Boolean); override;\r\n procedure SetOnThreadException(const Value:\r\n TJvThreadedDatasetThreadExceptionEvent);\r\n public\r\n constructor Create(AOwner : TComponent); override;\r\n destructor Destroy; override;\r\n function CurrentFetchDuration: TDateTime;\r\n function CurrentOpenDuration: TDateTime;\r\n function EofReached: Boolean;\r\n function ErrorException: Exception;\r\n function ErrorMessage: string;\r\n function ThreadIsActive: Boolean;\r\n published\r\n property BeforeThreadExecution: TJvThreadedDatasetThreadEvent read GetBeforeThreadExecution write\r\n SetBeforeThreadExecution;\r\n property DialogOptions: TJvThreadedDatasetDialogOptions read GetDialogOptions write SetDialogOptions;\r\n property EnhancedOptions: TJvDoaThreadedDatasetEnhancedOptions read GetEnhancedOptions write SetEnhancedOptions;\r\n property ThreadOptions: TJvThreadedDatasetThreadOptions read GetThreadOptions write SetThreadOptions;\r\n property AfterFetchRecord: TAfterFetchRecordEvent read FAfterFetchRecord write FAfterFetchRecord;\r\n property AfterOpenFetch: TDataSetNotifyEvent read GetAfterOpenFetch write\r\n SetAfterOpenFetch;\r\n property AfterThreadExecution: TJvThreadedDatasetThreadEvent read GetAfterThreadExecution write\r\n SetAfterThreadExecution;\r\n property OnThreadException: TJvThreadedDatasetThreadExceptionEvent read\r\n GetOnThreadException write SetOnThreadException;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvOracleDataSet.pas $';\r\n Revision: '$Revision: 13104 $';\r\n Date: '$Date: 2011-09-07 08:50:43 +0200 (mer. 07 sept. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nconstructor TJvOracleDataset.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FThreadHandler := TJvOracleDatasetThreadHandler.Create(Self, Self);\r\n inherited AfterFetchRecord := ReplaceAfterFetchRecord;\r\nend;\r\n\r\ndestructor TJvOracleDataset.Destroy;\r\nbegin\r\n FreeAndNil(FThreadHandler);\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvOracleDataset.BreakExecution;\r\nbegin\r\n if Assigned(Session) and Session.Connected then\r\n Session.BreakExecution;\r\nend;\r\n\r\nprocedure TJvOracleDataset.BringThreadDialogToFront;\r\nbegin\r\n if Assigned(ThreadHandler) then\r\n ThreadHandler.BringDialogToFront;\r\nend;\r\n\r\nfunction TJvOracleDataset.CurrentFetchDuration: TDateTime;\r\nbegin\r\n if Assigned(ThreadHandler) then\r\n Result := ThreadHandler.CurrentFetchDuration\r\n else\r\n Result := 0;\r\nend;\r\n\r\nfunction TJvOracleDataset.CurrentOpenDuration: TDateTime;\r\nbegin\r\n if Assigned(ThreadHandler) then\r\n Result := ThreadHandler.CurrentOpenDuration\r\n else\r\n Result := 0;\r\nend;\r\n\r\nprocedure TJvOracleDataset.InternalLast;\r\nbegin\r\n if Assigned(ThreadHandler) then\r\n ThreadHandler.InternalLast;\r\nend;\r\n\r\nprocedure TJvOracleDataset.InternalRefresh;\r\nbegin\r\n if Assigned(ThreadHandler) then\r\n ThreadHandler.InternalRefresh;\r\nend;\r\n\r\nprocedure TJvOracleDataset.SetActive(Value: Boolean);\r\nbegin\r\n if Assigned(ThreadHandler) then\r\n ThreadHandler.SetActive(Value);\r\nend;\r\n\r\n\r\nprocedure TJvOracleDataset.DoAfterOpen;\r\nbegin\r\n ThreadHandler.AfterOpen;\r\nend;\r\n\r\nprocedure TJvOracleDataset.DoAfterScroll;\r\nbegin\r\n ThreadHandler.AfterScroll;\r\nend;\r\n\r\nprocedure TJvOracleDataset.DoAfterRefresh;\r\nbegin\r\n ThreadHandler.AfterRefresh;\r\nend;\r\n\r\nprocedure TJvOracleDataset.DoBeforeOpen;\r\nbegin\r\n ThreadHandler.BeforeOpen;\r\nend;\r\n\r\nprocedure TJvOracleDataset.DoBeforeRefresh;\r\nbegin\r\n ThreadHandler.BeforeRefresh;\r\nend;\r\n\r\nfunction TJvOracleDataset.DoGetInheritedNextRecord: Boolean;\r\nbegin\r\n Result := Inherited GetNextRecord;\r\nend;\r\n\r\nprocedure TJvOracleDataset.DoInheritedAfterOpen;\r\nbegin\r\n inherited DoAfterOpen;\r\nend;\r\n\r\nprocedure TJvOracleDataset.DoInheritedAfterRefresh;\r\nbegin\r\n inherited DoAfterRefresh;\r\nend;\r\n\r\nprocedure TJvOracleDataset.DoInheritedAfterScroll;\r\nbegin\r\n inherited DoAfterScroll;\r\nend;\r\n\r\nprocedure TJvOracleDataset.DoInheritedBeforeOpen;\r\nbegin\r\n inherited DoBeforeOpen;\r\nend;\r\n\r\nprocedure TJvOracleDataset.DoInheritedBeforeRefresh;\r\nbegin\r\n inherited DoBeforeRefresh;\r\nend;\r\n\r\nprocedure TJvOracleDataset.DoInheritedInternalLast;\r\nbegin\r\n inherited InternalLast;\r\nend;\r\n\r\nprocedure TJvOracleDataset.DoInheritedInternalRefresh;\r\nbegin\r\n inherited InternalRefresh;\r\nend;\r\n\r\nprocedure TJvOracleDataset.DoInheritedSetActive(Active: Boolean);\r\nbegin\r\n inherited SetActive(Active);\r\nend;\r\n\r\nprocedure TJvOracleDataset.DoInternalOpen;\r\nbegin\r\n InternalOpen;\r\nend;\r\n\r\nfunction TJvOracleDataset.ErrorException: Exception;\r\nbegin\r\n if Assigned(ThreadHandler) then\r\n Result := ThreadHandler.ErrorException\r\n else\r\n Result := Nil;\r\nend;\r\n\r\nfunction TJvOracleDataset.ErrorMessage: string;\r\nbegin\r\n if Assigned(ThreadHandler) then\r\n Result := ThreadHandler.ErrorMessage\r\n else\r\n Result := '';\r\nend;\r\n\r\nfunction TJvOracleDataset.GetBeforeThreadExecution: TJvThreadedDatasetThreadEvent;\r\nbegin\r\n if Assigned(ThreadHandler) then\r\n Result := ThreadHandler.BeforeThreadExecution\r\n else\r\n Result := nil;\r\nend;\r\n\r\nfunction TJvOracleDataset.GetAfterThreadExecution: TJvThreadedDatasetThreadEvent;\r\nbegin\r\n if Assigned(ThreadHandler) then\r\n Result := ThreadHandler.AfterThreadExecution\r\n else\r\n Result := nil;\r\nend;\r\n\r\nfunction TJvOracleDataset.GetDatasetFetchAllRecords: Boolean;\r\nbegin\r\n Result := QueryAllRecords;\r\nend;\r\n\r\nfunction TJvOracleDataset.GetDialogOptions: TJvThreadedDatasetDialogOptions;\r\nbegin\r\n if Assigned(ThreadHandler) then\r\n Result := ThreadHandler.DialogOptions\r\n else\r\n Result := nil;\r\nend;\r\n\r\nfunction TJvOracleDataset.GetEnhancedOptions: TJvDoaThreadedDatasetEnhancedOptions;\r\nbegin\r\n if Assigned(ThreadHandler) then\r\n Result := TJvDoaThreadedDatasetEnhancedOptions(ThreadHandler.EnhancedOptions)\r\n else\r\n Result := nil;\r\nend;\r\n\r\nfunction TJvOracleDataset.EofReached: Boolean;\r\nbegin\r\n if Assigned(ThreadHandler) then\r\n Result := ThreadHandler.EofReached\r\n else\r\n Result := False;\r\nend;\r\n\r\nfunction TJvOracleDataset.GetAfterOpenFetch: TDataSetNotifyEvent;\r\nbegin\r\n if Assigned(ThreadHandler) then\r\n Result := ThreadHandler.AfterOpenFetch\r\n else\r\n Result := nil;\r\nend;\r\n\r\nfunction TJvOracleDataset.GetNextRecord: Boolean;\r\nbegin\r\n if Assigned(ThreadHandler) then\r\n Result := ThreadHandler.GetNextRecord\r\n else\r\n Result := inherited GetNextRecord;\r\nend;\r\n\r\nfunction TJvOracleDataset.GetOnThreadException:\r\n TJvThreadedDatasetThreadExceptionEvent;\r\nbegin\r\n if Assigned(ThreadHandler) then\r\n Result := ThreadHandler.OnThreadException\r\n else\r\n Result := nil;\r\nend;\r\n\r\nfunction TJvOracleDataset.GetThreadOptions: TJvThreadedDatasetThreadOptions;\r\nbegin\r\n if Assigned(ThreadHandler) then\r\n Result := ThreadHandler.ThreadOptions\r\n else\r\n Result := nil;\r\nend;\r\n\r\nfunction TJvOracleDataset.IsThreadAllowed: Boolean;\r\nbegin\r\n if Assigned(Master) and (Master is TJvOracleDataset) then\r\n Result := not TJvOracleDataset(Master).ThreadHandler.ThreadIsActive\r\n else\r\n Result := True;\r\nend;\r\n\r\nprocedure TJvOracleDataset.ReplaceAfterFetchRecord(Sender: TOracleDataSet;\r\n FilterAccept: Boolean; var Action: TAfterFetchRecordAction);\r\nbegin\r\n if Assigned(ThreadHandler) then\r\n case ThreadHandler.CheckContinueRecordFetch of\r\n tdccrContinue:\r\n Action := afContinue;\r\n tdccrAll:\r\n Action := afContinue;\r\n tdccrCancel:\r\n Action := afCancel;\r\n tdccrPause:\r\n Action := afPause;\r\n tdccrStop:\r\n Action := afStop;\r\n else\r\n Action := afStop;\r\n end;\r\n if Assigned(AfterFetchRecord) then\r\n AfterFetchRecord(Sender, FilterAccept, Action);\r\nend;\r\n\r\nprocedure TJvOracleDataset.SetAfterOpenFetch(const Value: TDataSetNotifyEvent);\r\nbegin\r\n if Assigned(ThreadHandler) then\r\n ThreadHandler.AfterOpenFetch := Value;\r\nend;\r\n\r\nprocedure TJvOracleDataset.SetBeforeThreadExecution(const Value: TJvThreadedDatasetThreadEvent);\r\nbegin\r\n if Assigned(ThreadHandler) then\r\n ThreadHandler.BeforeThreadExecution := Value;\r\nend;\r\n\r\nprocedure TJvOracleDataset.SetAfterThreadExecution(const Value: TJvThreadedDatasetThreadEvent);\r\nbegin\r\n if Assigned(ThreadHandler) then\r\n ThreadHandler.AfterThreadExecution := Value;\r\nend;\r\n\r\nprocedure TJvOracleDataset.SetDatasetFetchAllRecords(const Value: Boolean);\r\nbegin\r\n QueryAllRecords := Value;\r\nend;\r\n\r\nprocedure TJvOracleDataset.SetDialogOptions(Value: TJvThreadedDatasetDialogOptions);\r\nbegin\r\n if Assigned(ThreadHandler) then\r\n ThreadHandler.DialogOptions.Assign(Value);\r\nend;\r\n\r\nprocedure TJvOracleDataset.SetEnhancedOptions(const Value: TJvDoaThreadedDatasetEnhancedOptions);\r\nbegin\r\n if Assigned(ThreadHandler) then\r\n ThreadHandler.EnhancedOptions.Assign(Value);\r\nend;\r\n\r\nprocedure TJvOracleDataset.SetOnThreadException(const Value:\r\n TJvThreadedDatasetThreadExceptionEvent);\r\nbegin\r\n if Assigned(ThreadHandler) then\r\n ThreadHandler.OnThreadException := Value;\r\nend;\r\n\r\nprocedure TJvOracleDataset.SetThreadOptions(const Value: TJvThreadedDatasetThreadOptions);\r\nbegin\r\n if Assigned(ThreadHandler) then\r\n ThreadHandler.ThreadOptions.Assign(Value);\r\nend;\r\n\r\nfunction TJvOracleDataset.ThreadIsActive: Boolean;\r\nbegin\r\n if Assigned(ThreadHandler) then\r\n Result := ThreadHandler.ThreadIsActive\r\n else\r\n Result := False;\r\nend;\r\n\r\nfunction TJvOracleDatasetThreadHandler.CreateEnhancedOptions: TJvBaseThreadedDatasetEnhancedOptions;\r\nbegin\r\n Result := TJvDoaThreadedDatasetEnhancedOptions.Create;\r\nend;\r\n\r\nfunction TJvOracleDatasetThreadHandler.GetEnhancedOptions: TJvDoaThreadedDatasetEnhancedOptions;\r\nbegin\r\n Result := TJvDoaThreadedDatasetEnhancedOptions(inherited EnhancedOptions);\r\nend;\r\n\r\nprocedure TJvOracleDatasetThreadHandler.SetEnhancedOptions(const Value: TJvDoaThreadedDatasetEnhancedOptions);\r\nbegin\r\n inherited EnhancedOptions := Value;\r\nend;\r\n\r\nconstructor TJvDoaThreadedDatasetAllowedContinueRecordFetchOptions.Create;\r\nbegin\r\n inherited Create;\r\n All := True;\r\nend;\r\n\r\nfunction\r\n TJvDoaThreadedDatasetEnhancedOptions.CreateAllowedContinueRecordFetchOptions:\r\n TJvBaseThreadedDatasetAllowedContinueRecordFetchOptions;\r\nbegin\r\n Result := TJvDoaThreadedDatasetAllowedContinueRecordFetchOptions.Create;\r\nend;\r\n\r\nfunction\r\n TJvDoaThreadedDatasetEnhancedOptions.GetAllowedContinueRecordFetchOptions:\r\n TJvDoaThreadedDatasetAllowedContinueRecordFetchOptions;\r\nbegin\r\n Result := TJvDoaThreadedDatasetAllowedContinueRecordFetchOptions(inherited AllowedContinueRecordFetchOptions);\r\nend;\r\n\r\nprocedure\r\n TJvDoaThreadedDatasetEnhancedOptions.SetAllowedContinueRecordFetchOptions(\r\n const Value: TJvDoaThreadedDatasetAllowedContinueRecordFetchOptions);\r\nbegin\r\n inherited AllowedContinueRecordFetchOptions := Value;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n\r\n" }, { "path": "External/Jedi/Jvcl/run/JvOutlookBar.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvOLBar.PAS, released on 2002-05-26.\r\n\r\nThe Initial Developer of the Original Code is Peter Thrnqvist [peter3 at sourceforge dot net]\r\nPortions created by Peter Thrnqvist are Copyright (C) 2002 Peter Thrnqvist.\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nDescription:\r\n Outlook style control. Simpler than TJvLookout)\r\n Hierarchy:\r\n TJvCustomOutlookBar\r\n Pages: TJvOutlookBarPages\r\n Page: TJvOutlookBarPage\r\n Buttons: TJvOutlookBarButtons\r\n Button: TJvOutlookBarButton\r\n\r\nKnown Issues:\r\n VISTA/THEMING CHANGES: WARREN POSTMA, NOV 2007 :\r\n Vista paint fix, and support for completely user decided color\r\n schemes, such as white on black, for low-visibility-users\r\n (high contrast black on white) support.\r\n Outlook bar buttons now have color properties (instead of\r\n assuming we will use the clBtnFace type system colors)\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvOutlookBar.pas 13415 2012-09-10 09:51:54Z obones $\r\n\r\nunit JvOutlookBar;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n SysUtils, Classes, ActnList,\r\n Windows, Messages, Buttons, Controls, Graphics, ImgList, Forms, StdCtrls, ExtCtrls,\r\n {$IFDEF JVCLThemesEnabled}\r\n UxTheme,\r\n {$IFNDEF COMPILER7_UP}\r\n TmSchema,\r\n {$ENDIF !COMPILER7_UP}\r\n {$ENDIF JVCLThemesEnabled}\r\n {$IFDEF HAS_UNIT_SYSTEM_UITYPES}\r\n System.UITypes,\r\n {$ENDIF HAS_UNIT_SYSTEM_UITYPES}\r\n JvJCLUtils, JvThemes, JvComponent, JvExButtons;\r\n\r\nconst\r\n CM_CAPTION_EDITING = CM_BASE + 756;\r\n CM_CAPTION_EDIT_ACCEPT = CM_CAPTION_EDITING + 1;\r\n CM_CAPTION_EDIT_CANCEL = CM_CAPTION_EDITING + 2;\r\n\r\ntype\r\n TJvBarButtonSize = (olbsLarge, olbsSmall);\r\n TJvCustomOutlookBar = class;\r\n TJvOutlookBarButton = class;\r\n\r\n\r\n TJvOutlookBarButtonActionLink = class(TActionLink)\r\n private\r\n FClient: TJvOutlookBarButton;\r\n protected\r\n procedure AssignClient(AClient: TObject); override;\r\n function IsCaptionLinked: Boolean; override;\r\n function IsImageIndexLinked: Boolean; override;\r\n function IsOnExecuteLinked: Boolean; override;\r\n function IsEnabledLinked: Boolean;override;\r\n procedure SetCaption(const Value: string); override;\r\n procedure SetEnabled(Value: Boolean); override;\r\n procedure SetImageIndex(Value: Integer); override;\r\n procedure SetOnExecute(Value: TNotifyEvent); override;\r\n property Client: TJvOutlookBarButton read FClient write FClient;\r\n end;\r\n\r\n TJvOutlookBarButtonActionLinkClass = class of TJvOutlookBarButtonActionLink;\r\n TJvOutlookBarButton = class(TCollectionItem)\r\n private\r\n FActionLink: TJvOutlookBarButtonActionLink;\r\n FImageIndex: TImageIndex;\r\n FCaption: TCaption;\r\n FTag: NativeInt;\r\n FDown: Boolean;\r\n FEnabled: Boolean;\r\n FAutoToggle: Boolean;\r\n FOnClick: TNotifyEvent;\r\n FLinkedObject: TObject;\r\n procedure SetCaption(const Value: TCaption);\r\n procedure SetImageIndex(const Value: TImageIndex);\r\n procedure SetDown(const Value: Boolean);\r\n procedure Change;\r\n procedure SetEnabled(const Value: Boolean);\r\n procedure SetAction(Value: TBasicAction);\r\n function GetOutlookBar: TJvCustomOutlookBar;\r\n protected\r\n function GetDisplayName: string; override;\r\n function GetActionLinkClass: TJvOutlookBarButtonActionLinkClass; dynamic;\r\n function GetAction: TBasicAction; virtual;\r\n procedure DoActionChange(Sender: TObject);\r\n procedure ActionChange(Sender: TObject; CheckDefaults: Boolean); dynamic;\r\n public\r\n procedure Click; dynamic;\r\n constructor Create(Collection: Classes.TCollection); override;\r\n destructor Destroy; override;\r\n procedure Assign(Source: TPersistent); override;\r\n procedure EditCaption;\r\n\r\n // A property for user's usage, allowing to link an object to the button\r\n property LinkedObject: TObject read FLinkedObject write FLinkedObject;\r\n published\r\n property Action: TBasicAction read GetAction write SetAction;\r\n property Caption: TCaption read FCaption write SetCaption;\r\n property ImageIndex: TImageIndex read FImageIndex write SetImageIndex;\r\n property Tag: NativeInt read FTag write FTag;\r\n property Down: Boolean read FDown write SetDown default False;\r\n property AutoToggle: Boolean read FAutoToggle write FAutoToggle;\r\n property Enabled: Boolean read FEnabled write SetEnabled default True;\r\n property OnClick: TNotifyEvent read FOnClick write FOnClick;\r\n end;\r\n\r\n TJvOutlookBarButtons = class(TOwnedCollection)\r\n private\r\n function GetItem(Index: Integer): TJvOutlookBarButton;\r\n procedure SetItem(Index: Integer; const Value: TJvOutlookBarButton);\r\n protected\r\n procedure Update(Item: TCollectionItem); override;\r\n public\r\n constructor Create(AOwner: TPersistent);\r\n function Add: TJvOutlookBarButton;\r\n procedure Assign(Source: TPersistent); override;\r\n function Insert(Index: Integer): TJvOutlookBarButton;\r\n property Items[Index: Integer]: TJvOutlookBarButton read GetItem write SetItem; default;\r\n end;\r\n\r\n TJvOutlookBarPage = class(TCollectionItem)\r\n private\r\n FPicture: TPicture;\r\n FCaption: TCaption;\r\n FColor: TColor;\r\n FButtonSize: TJvBarButtonSize;\r\n FParentButtonSize: Boolean;\r\n FParentFont: Boolean;\r\n FParentColor: Boolean;\r\n FTopButtonIndex: Integer;\r\n FButtons: TJvOutlookBarButtons;\r\n FFont: TFont;\r\n FDownFont: TFont;\r\n FImageIndex: TImageIndex;\r\n FAlignment: TAlignment;\r\n FEnabled: Boolean;\r\n FLinkedObject: TObject;\r\n procedure SetButtonSize(const Value: TJvBarButtonSize);\r\n procedure SetCaption(const Value: TCaption);\r\n procedure SetColor(const Value: TColor);\r\n procedure SetPicture(const Value: TPicture);\r\n procedure Change;\r\n procedure SetParentButtonSize(const Value: Boolean);\r\n procedure SetParentColor(const Value: Boolean);\r\n procedure SetTopButtonIndex(const Value: Integer);\r\n procedure SetButtons(const Value: TJvOutlookBarButtons);\r\n procedure SetParentFont(const Value: Boolean);\r\n procedure SetFont(const Value: TFont);\r\n procedure SetImageIndex(const Value: TImageIndex);\r\n procedure SetAlignment(const Value: TAlignment);\r\n procedure DoFontChange(Sender: TObject);\r\n procedure SetDownFont(const Value: TFont);\r\n function GetDownButton: TJvOutlookBarButton;\r\n function GetDownIndex: Integer;\r\n procedure SetDownButton(Value: TJvOutlookBarButton);\r\n procedure SetDownIndex(Value: Integer);\r\n procedure SetEnabled(const Value: Boolean);\r\n protected\r\n procedure DoPictureChange(Sender: TObject);\r\n function GetDisplayName: string; override;\r\n function GetOutlookBar: TJvCustomOutlookBar;\r\n public\r\n constructor Create(Collection: Classes.TCollection); override;\r\n destructor Destroy; override;\r\n procedure Assign(Source: TPersistent); override;\r\n procedure EditCaption;\r\n property DownButton: TJvOutlookBarButton read GetDownButton write SetDownButton;\r\n property DownIndex: Integer read GetDownIndex write SetDownIndex;\r\n\r\n // A property for user's usage, allowing to link an objet to the page.\r\n property LinkedObject: TObject read FLinkedObject write FLinkedObject;\r\n published\r\n property Alignment: TAlignment read FAlignment write SetAlignment default taCenter;\r\n property Buttons: TJvOutlookBarButtons read FButtons write SetButtons;\r\n property ButtonSize: TJvBarButtonSize read FButtonSize write SetButtonSize;\r\n property Caption: TCaption read FCaption write SetCaption;\r\n property Color: TColor read FColor write SetColor default clDefault;\r\n property DownFont: TFont read FDownFont write SetDownFont;\r\n property ImageIndex: TImageIndex read FImageIndex write SetImageIndex default -1;\r\n property Font: TFont read FFont write SetFont;\r\n property Picture: TPicture read FPicture write SetPicture;\r\n property ParentButtonSize: Boolean read FParentButtonSize write SetParentButtonSize default True;\r\n property ParentFont: Boolean read FParentFont write SetParentFont default False;\r\n property ParentColor: Boolean read FParentColor write SetParentColor;\r\n property TopButtonIndex: Integer read FTopButtonIndex write SetTopButtonIndex;\r\n property Enabled: Boolean read FEnabled write SetEnabled default True;\r\n end;\r\n\r\n TJvOutlookBarPages = class(TOwnedCollection)\r\n private\r\n function GetItem(Index: Integer): TJvOutlookBarPage;\r\n procedure SetItem(Index: Integer; const Value: TJvOutlookBarPage);\r\n protected\r\n procedure Update(Item: TCollectionItem); override;\r\n public\r\n constructor Create(AOwner: TPersistent);\r\n function Add: TJvOutlookBarPage;\r\n function Insert(Index: Integer): TJvOutlookBarPage;\r\n procedure Assign(Source: TPersistent); override;\r\n property Items[Index: Integer]: TJvOutlookBarPage read GetItem write SetItem; default;\r\n end;\r\n\r\n TOutlookBarPageChanging = procedure(Sender: TObject; Index: Integer; var AllowChange: Boolean) of object;\r\n TOutlookBarPageChange = procedure(Sender: TObject; Index: Integer) of object;\r\n TOutlookBarButtonClick = procedure(Sender: TObject; Index: Integer) of object;\r\n TOutlookBarEditCaption = procedure(Sender: TObject; var NewText: string;\r\n Index: Integer; var Allow: Boolean) of object;\r\n\r\n TJvOutlookBarCustomDrawStage = (odsBackground, odsPageButton, odsPage, odsButton, odsButtonFrame);\r\n TJvOutlookBarCustomDrawEvent = procedure(Sender: TObject; ACanvas: TCanvas; ARect: TRect;\r\n AStage: TJvOutlookBarCustomDrawStage; AIndex: Integer; ADown, AInside: Boolean; var DefaultDraw: Boolean) of object;\r\n\r\n TJvPageBtnProps = class\r\n private\r\n FOwner : TJvCustomOutlookBar;\r\n FHighlight : TColor;\r\n FFace : TColor;\r\n FShadow : TColor;\r\n FDkShadow : TColor;\r\n\r\n FBorderWidth : INteger;\r\n\r\n procedure SetDkShadow(const Value: TColor);\r\n procedure SetFace(const Value: TColor);\r\n procedure SetHighlight(const Value: TColor);\r\n procedure SetShadow(const Value: TColor);\r\n procedure SetBorderWidth(const Value: INteger);\r\n public\r\n constructor Create(owner:TJvCustomOUtlookBar);\r\n public\r\n property Shadow:TColor read FShadow write SetShadow default clBtnShadow;\r\n property Highlight:TColor read FHighlight write SetHighlight default clBtnHighlight;\r\n property DkShadow:TColor read FDkShadow write SetDkShadow default cl3DDkShadow;\r\n property Face:TColor read FFace write SetFace default clBtnFace;\r\n \r\n property BorderWidth : INteger read FBorderWidth write SetBorderWidth default 1;\r\n end;\r\n\r\n TJvCustomOutlookBar = class(TJvCustomControl)\r\n private\r\n FPageBtnProps:TJvPageBtnProps;\r\n FTopButton: TSpeedButton;\r\n FBtmButton: TSpeedButton;\r\n FPages: TJvOutlookBarPages;\r\n FLargeChangeLink: TChangeLink;\r\n FSmallChangeLink: TChangeLink;\r\n FPageChangeLink: TChangeLink;\r\n FActivePageIndex: Integer;\r\n FButtonSize: TJvBarButtonSize;\r\n FSmallImages: TCustomImageList;\r\n FLargeImages: TCustomImageList;\r\n FPageButtonHeight: Integer;\r\n FBorderStyle: TBorderStyle;\r\n FNextActivePage: Integer;\r\n FPressedPageBtn: Integer;\r\n {$IFDEF JVCLThemesEnabled}\r\n FHotPageBtn: Integer;\r\n FThemedBackGround: Boolean;\r\n {$ENDIF JVCLThemesEnabled}\r\n FThemed:Boolean;\r\n FOnPageChange: TOutlookBarPageChange;\r\n FOnPageChanging: TOutlookBarPageChanging;\r\n FButtonRect: TRect;\r\n FLastButtonIndex: Integer;\r\n FPressedButtonIndex: Integer;\r\n FOnButtonClick: TOutlookBarButtonClick;\r\n FPopUpObject: TObject;\r\n FEdit: TCustomEdit;\r\n FOnEditButton: TOutlookBarEditCaption;\r\n FOnEditPage: TOutlookBarEditCaption;\r\n FOnCustomDraw: TJvOutlookBarCustomDrawEvent;\r\n FPageImages: TCustomImageList;\r\n FDisabledFontColor1:TColor; //clWhite;\r\n FDisabledFontColor2:TColor;\r\n\r\n procedure SetPages(const Value: TJvOutlookBarPages);\r\n procedure DoChangeLinkChange(Sender: TObject);\r\n procedure SetActivePageIndex(const Value: Integer);\r\n procedure SetButtonSize(const Value: TJvBarButtonSize);\r\n procedure SetLargeImages(const Value: TCustomImageList);\r\n procedure SetSmallImages(const Value: TCustomImageList);\r\n procedure SetPageImages(const Value: TCustomImageList);\r\n procedure SetPageButtonHeight(const Value: Integer);\r\n procedure SetBorderStyle(const Value: TBorderStyle);\r\n {$IFDEF JVCLThemesEnabled}\r\n procedure SetThemedBackground(const Value: Boolean);\r\n {$ENDIF JVCLThemesEnabled}\r\n function DrawTopPages: Integer;\r\n procedure DrawCurrentPage(PageIndex: Integer);\r\n procedure DrawPageButton(R: TRect; Index: Integer; Pressed: Boolean);\r\n procedure DrawBottomPages(StartIndex: Integer);\r\n procedure DrawButtons(Index: Integer);\r\n procedure DrawArrowButtons(Index: Integer);\r\n procedure DrawButtonFrame(PageIndex, ButtonIndex, PressedIndex: Integer);\r\n function DrawPicture(R: TRect; Picture: TPicture): Boolean;\r\n procedure DoDwnClick(Sender: TObject);\r\n procedure DoUpClick(Sender: TObject);\r\n procedure RedrawRect(R: TRect; Erase: Boolean = False);\r\n procedure CMCaptionEditing(var Msg: TMessage); message CM_CAPTION_EDITING;\r\n procedure CMCaptionEditAccept(var Msg: TMessage); message CM_CAPTION_EDIT_ACCEPT;\r\n procedure CMCaptionEditCancel(var Msg: TMessage); message CM_CAPTION_EDIT_CANCEL;\r\n procedure CMDialogChar(var Msg: TCMDialogChar); message CM_DIALOGCHAR;\r\n procedure DoButtonEdit(NewText: string; B: TJvOutlookBarButton);\r\n procedure DoPageEdit(NewText: string; P: TJvOutlookBarPage);\r\n function GetActivePage: TJvOutlookBarPage;\r\n function GetActivePageIndex: Integer;\r\n procedure SetDisabledFontColor1(const Value: TColor);\r\n procedure SetDisabledFontColor2(const Value: TColor);\r\n procedure SetThemed(const Value: Boolean);\r\n protected\r\n function DoEraseBackground(Canvas: TCanvas; Param: LPARAM): Boolean; override;\r\n procedure FontChanged; override;\r\n procedure CreateParams(var Params: TCreateParams); override;\r\n function GetButtonHeight(PageIndex: Integer): Integer;\r\n function GetButtonFrameRect(PageIndex, ButtonIndex: Integer): TRect;\r\n function GetButtonTextRect(PageIndex, ButtonIndex: Integer): TRect;\r\n function GetButtonRect(PageIndex, ButtonIndex: Integer): TRect;\r\n function GetPageButtonRect(Index: Integer): TRect;\r\n function GetPageTextRect(Index: Integer): TRect;\r\n function GetPageRect(Index: Integer): TRect;\r\n procedure Notification(AComponent: TComponent; Operation: TOperation); override;\r\n procedure Paint; override;\r\n procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;\r\n procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;\r\n procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;\r\n procedure MouseEnter(Control: TControl); override;\r\n procedure MouseLeave(Control: TControl); override;\r\n procedure ColorChanged; override;\r\n function DoPageChanging(Index: Integer): Boolean; virtual;\r\n procedure DoPageChange(Index: Integer); virtual;\r\n procedure DoButtonClick(Index: Integer); virtual;\r\n procedure DoContextPopup( MousePos: TPoint; var Handled: Boolean); override;\r\n function DoDrawBackGround: Boolean;\r\n function DoDrawPage(ARect: TRect; Index: Integer): Boolean;\r\n function DoDrawPageButton(ARect: TRect; Index: Integer; Down: Boolean): Boolean;\r\n function DoDrawButton(ARect: TRect; Index: Integer; Down, Inside: Boolean): Boolean;\r\n function DoDrawButtonFrame(ARect: TRect; Index: Integer; Down, Inside: Boolean): Boolean;\r\n function DoCustomDraw(ARect: TRect; Stage: TJvOutlookBarCustomDrawStage; Index: Integer; Down, Inside: Boolean): Boolean; virtual;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n procedure InitiateAction; override;\r\n function GetButtonAtPos(P: TPoint): TJvOutlookBarButton;\r\n function GetPageButtonAtPos(P: TPoint): TJvOutlookBarPage;\r\n protected\r\n property PopUpObject: TObject read FPopUpObject write FPopUpObject;\r\n property Width default 100;\r\n property Height default 220;\r\n property TopButton: TSpeedButton read FTopButton;\r\n property BtmButton: TSpeedButton read FBtmButton;\r\n property BorderStyle: TBorderStyle read FBorderStyle write SetBorderStyle default bsSingle;\r\n property Font;\r\n property Color default clBtnShadow;\r\n property Pages: TJvOutlookBarPages read FPages write SetPages;\r\n property LargeImages: TCustomImageList read FLargeImages write SetLargeImages;\r\n property SmallImages: TCustomImageList read FSmallImages write SetSmallImages;\r\n property PageImages: TCustomImageList read FPageImages write SetPageImages;\r\n property ButtonSize: TJvBarButtonSize read FButtonSize write SetButtonSize default olbsLarge;\r\n property PageButtonHeight: Integer read FPageButtonHeight write SetPageButtonHeight default 19;\r\n property ActivePageIndex: Integer read GetActivePageIndex write SetActivePageIndex default 0;\r\n {$IFDEF JVCLThemesEnabled}\r\n property ThemedBackground: Boolean read FThemedBackGround write SetThemedBackground default True;\r\n {$ENDIF JVCLThemesEnabled}\r\n property OnPageChanging: TOutlookBarPageChanging read FOnPageChanging write FOnPageChanging;\r\n property OnPageChange: TOutlookBarPageChange read FOnPageChange write FOnPageChange;\r\n property OnButtonClick: TOutlookBarButtonClick read FOnButtonClick write FOnButtonClick;\r\n property OnEditButton: TOutlookBarEditCaption read FOnEditButton write FOnEditButton;\r\n property OnEditPage: TOutlookBarEditCaption read FOnEditPage write FOnEditPage;\r\n property OnCustomDraw: TJvOutlookBarCustomDrawEvent read FOnCustomDraw write FOnCustomDraw;\r\n\r\n property Themed:Boolean read FThemed write SetThemed;\r\n property PageBtnProps:TJvPageBtnProps read FPageBtnProps;\r\n\r\n property DisabledFontColor1:TColor read FDisabledFontColor1 write SetDisabledFontColor1; //clWhite;\r\n property DisabledFontColor2:TColor read FDisabledFontColor2 write SetDisabledFontColor2; //clGrayText;\r\n\r\n public\r\n property ActivePage: TJvOutlookBarPage read GetActivePage;\r\n end;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvOutlookBar = class(TJvCustomOutlookBar)\r\n public\r\n property PopUpObject;\r\n\r\n property Themed;\r\n\r\n property DisabledFontColor1;\r\n property DisabledFontColor2;\r\n\r\n property PageBtnProps;\r\n\r\n published\r\n property Align;\r\n property Pages;\r\n property LargeImages;\r\n property SmallImages;\r\n property PageImages;\r\n property ButtonSize;\r\n property PageButtonHeight;\r\n property ActivePageIndex;\r\n {$IFDEF JVCLThemesEnabled}\r\n property ThemedBackground;\r\n {$ENDIF JVCLThemesEnabled}\r\n property OnButtonClick;\r\n property OnCustomDraw;\r\n property OnEditButton;\r\n property OnPageChange;\r\n property OnPageChanging;\r\n property OnEditPage;\r\n property Action;\r\n property Anchors;\r\n property BiDiMode;\r\n property ParentBiDiMode;\r\n property DragCursor;\r\n property DragKind;\r\n property BorderStyle;\r\n property Color;\r\n property Constraints;\r\n property Cursor;\r\n property DragMode;\r\n property Font;\r\n property Height;\r\n property HelpContext;\r\n property HelpKeyword;\r\n property HelpType;\r\n property Hint;\r\n property ParentFont;\r\n property ParentShowHint;\r\n property PopupMenu;\r\n property ShowHint;\r\n property TabOrder;\r\n property TabStop;\r\n property Visible;\r\n property Width;\r\n property OnClick;\r\n property OnDblClick;\r\n property OnContextPopup;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvOutlookBar.pas $';\r\n Revision: '$Revision: 13415 $';\r\n Date: '$Date: 2012-09-10 11:51:54 +0200 (lun. 10 sept. 2012) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n Types, Math,\r\n JvConsts, JvJVCLUtils;\r\n\r\n{$R JvOutlookBar.res}\r\n\r\nconst\r\n cButtonLeftOffset = 4;\r\n cButtonTopOffset = 2;\r\n cInitRepeatPause = 400;\r\n cRepeatPause = 100;\r\n\r\nfunction IsVista:Boolean;\r\nbegin\r\n Result := CheckWin32Version(6, 0);\r\nend;\r\n\r\nfunction MethodsEqual(const Method1, Method2: TMethod): Boolean;\r\nbegin\r\n Result := (Method1.Code = Method2.Code) and (Method1.Data = Method2.Data);\r\nend;\r\n\r\n//=== { TJvOutlookBarEdit } ==================================================\r\n\r\ntype\r\n TJvOutlookBarEdit = class(TCustomEdit)\r\n private\r\n FCanvas: TControlCanvas;\r\n procedure WMNCPaint(var Msg: TMessage); message WM_NCPAINT;\r\n procedure EditAccept;\r\n procedure EditCancel;\r\n function GetCanvas: TCanvas;\r\n protected\r\n procedure KeyDown(var Key: Word; Shift: TShiftState); override;\r\n procedure MouseDown(Button: TMouseButton; Shift: TShiftState;\r\n X, Y: Integer); override;\r\n procedure KeyPress(var Key: Char); override;\r\n public\r\n constructor CreateInternal(AOwner: TComponent; AParent: TWinControl; AObject: TObject);\r\n destructor Destroy; override;\r\n procedure ShowEdit(const AText: string; R: TRect);\r\n property Canvas: TCanvas read GetCanvas;\r\n end;\r\n\r\nconstructor TJvOutlookBarEdit.CreateInternal(AOwner: TComponent;\r\n AParent: TWinControl; AObject: TObject);\r\nbegin\r\n inherited Create(AOwner);\r\n FCanvas := TControlCanvas.Create;\r\n FCanvas.Control := Self;\r\n AutoSize := True;\r\n Visible := False;\r\n Parent := AParent;\r\n BorderStyle := bsNone;\r\n ParentFont := False;\r\n Tag := NativeInt(AObject);\r\nend;\r\n\r\ndestructor TJvOutlookBarEdit.Destroy;\r\nbegin\r\n inherited Destroy;\r\n // (rom) destroy Canvas AFTER inherited Destroy\r\n FCanvas.Free;\r\nend;\r\n\r\nprocedure TJvOutlookBarEdit.EditAccept;\r\nbegin\r\n Parent.Perform(CM_CAPTION_EDIT_ACCEPT, WPARAM(Self), LPARAM(Tag));\r\n Hide;\r\nend;\r\n\r\nprocedure TJvOutlookBarEdit.EditCancel;\r\nbegin\r\n Parent.Perform(CM_CAPTION_EDIT_CANCEL, WPARAM(Self), LPARAM(Tag));\r\n Hide;\r\nend;\r\n\r\nfunction TJvOutlookBarEdit.GetCanvas: TCanvas;\r\nbegin\r\n Result := FCanvas;\r\nend;\r\n\r\nprocedure TJvOutlookBarEdit.KeyDown(var Key: Word; Shift: TShiftState);\r\nbegin\r\n case Key of\r\n VK_RETURN:\r\n begin\r\n Key := 0;\r\n EditAccept;\r\n if Handle = GetCapture then\r\n ReleaseCapture;\r\n// Hide;\r\n// Free;\r\n// Screen.Cursor := crDefault;\r\n end;\r\n VK_ESCAPE:\r\n begin\r\n Key := 0;\r\n if Handle = GetCapture then\r\n ReleaseCapture;\r\n EditCancel;\r\n// Hide;\r\n// Free;\r\n// Screen.Cursor := crDefault;\r\n end;\r\n end;\r\n inherited KeyDown(Key, Shift);\r\nend;\r\n\r\nprocedure TJvOutlookBarEdit.KeyPress(var Key: Char);\r\nbegin\r\n if Key = Cr then\r\n Key := #0; // remove beep\r\n inherited KeyPress(Key);\r\nend;\r\n\r\nprocedure TJvOutlookBarEdit.MouseDown(Button: TMouseButton;\r\n Shift: TShiftState; X, Y: Integer);\r\nbegin\r\n inherited MouseDown(Button, Shift, X, Y);\r\n if not PtInRect(ClientRect, Point(X, Y)) or ((Button = mbRight) and Visible) then\r\n begin\r\n if Handle = GetCapture then\r\n ReleaseCapture;\r\n EditCancel;\r\n// Screen.Cursor := crDefault;\r\n// FEdit.Hide;\r\n// FEdit.Free;\r\n// FEdit := nil;\r\n end\r\n else\r\n begin\r\n ReleaseCapture;\r\n// Screen.Cursor := crIBeam;\r\n SetCapture(Handle);\r\n end;\r\nend;\r\n\r\nprocedure TJvOutlookBarEdit.ShowEdit(const AText: string; R: TRect);\r\nbegin\r\n Hide;\r\n Text := AText;\r\n SetBounds(R.Left, R.Top, R.Right - R.Left, R.Bottom - R.Top);\r\n Show;\r\n SetCapture(Handle);\r\n SelStart := 0;\r\n SelLength := Length(Text);\r\n SetFocus;\r\nend;\r\n\r\n\r\nprocedure TJvOutlookBarEdit.WMNCPaint(var Msg: TMessage);\r\nbegin\r\n if csDestroying in ComponentState then\r\n Exit;\r\n GetCanvas; // make Delphi 5 compiler happy // andreas\r\n inherited;\r\n(*\r\n DC := GetWindowDC(Handle);\r\n try\r\n FCanvas.Handle := DC;\r\n Windows.GetClientRect(Handle, RC);\r\n GetWindowRect(Handle, RW);\r\n MapWindowPoints(0, Handle, RW, 2);\r\n\r\n OffsetRect(RC, -RW.Left, -RW.Top);\r\n ExcludeClipRect(DC, RC.Left, RC.Top, RC.Right, RC.Bottom);\r\n OffsetRect(RW, -RW.Left, -RW.Top);\r\n\r\n FCanvas.Brush.Color := clBlack;\r\n Windows.FrameRect(DC,RW,FCanvas.Brush.Handle);\r\n InflateRect(RW,-1,-1);\r\n\r\n{ FCanvas.Brush.Color := clBlack;\r\n Windows.FrameRect(DC,RW,FCanvas.Brush.Handle);\r\n InflateRect(RW,-1,-1);\r\n\r\n FCanvas.Brush.Color := clBlack;\r\n Windows.FrameRect(DC,RW,FCanvas.Brush.Handle);\r\n InflateRect(RW,-1,-1); }\r\n\r\n { Erase parts not drawn }\r\n IntersectClipRect(DC, RW.Left, RW.Top, RW.Right, RW.Bottom);\r\n finally\r\n ReleaseDC(Handle, DC);\r\n end;\r\n *)\r\nend;\r\n\r\n\r\n//=== { TJvRepeatButton } ====================================================\r\n\r\ntype\r\n // auto-repeating button using a timer (stolen from Borland's Spin.pas sample component)\r\n TJvRepeatButton = class(TJvExSpeedButton)\r\n private\r\n FRepeatTimer: TTimer;\r\n procedure TimerExpired(Sender: TObject);\r\n protected\r\n procedure VisibleChanged; override;\r\n procedure MouseDown(Button: TMouseButton; Shift: TShiftState;\r\n X, Y: Integer); override;\r\n procedure MouseUp(Button: TMouseButton; Shift: TShiftState;\r\n X, Y: Integer); override;\r\n public\r\n destructor Destroy; override;\r\n end;\r\n\r\nprocedure TJvRepeatButton.VisibleChanged;\r\nbegin\r\n inherited VisibleChanged;\r\n if not Visible then\r\n FreeAndNil(FRepeatTimer);\r\nend;\r\n\r\ndestructor TJvRepeatButton.Destroy;\r\nbegin\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvRepeatButton.MouseDown(Button: TMouseButton;\r\n Shift: TShiftState; X, Y: Integer);\r\nbegin\r\n inherited MouseDown(Button, Shift, X, Y);\r\n if FRepeatTimer = nil then\r\n FRepeatTimer := TTimer.Create(Self);\r\n FRepeatTimer.OnTimer := TimerExpired;\r\n FRepeatTimer.Interval := cInitRepeatPause;\r\n FRepeatTimer.Enabled := True;\r\nend;\r\n\r\nprocedure TJvRepeatButton.MouseUp(Button: TMouseButton; Shift: TShiftState;\r\n X, Y: Integer);\r\nbegin\r\n inherited MouseUp(Button, Shift, X, Y);\r\n FreeAndNil(FRepeatTimer);\r\nend;\r\n\r\nprocedure TJvRepeatButton.TimerExpired(Sender: TObject);\r\nbegin\r\n FRepeatTimer.Interval := cRepeatPause;\r\n if (FState = bsDown) and MouseCapture then\r\n try\r\n Click;\r\n except\r\n FRepeatTimer.Enabled := False;\r\n raise;\r\n end;\r\nend;\r\n\r\n//=== { TJvOutlookBarButtonActionLink } ======================================\r\n\r\nprocedure TJvOutlookBarButtonActionLink.AssignClient(AClient: TObject);\r\nbegin\r\n Client := AClient as TJvOutlookBarButton;\r\nend;\r\n\r\nfunction TJvOutlookBarButtonActionLink.IsCaptionLinked: Boolean;\r\nbegin\r\n Result := inherited IsCaptionLinked and\r\n (Client.Caption = (Action as TCustomAction).Caption);\r\nend;\r\n\r\nfunction TJvOutlookBarButtonActionLink.IsEnabledLinked: Boolean;\r\nbegin\r\n Result := inherited IsEnabledLinked and\r\n (Client.Enabled = (Action as TCustomAction).Enabled);\r\nend;\r\n\r\nfunction TJvOutlookBarButtonActionLink.IsImageIndexLinked: Boolean;\r\nbegin\r\n Result := inherited IsImageIndexLinked and\r\n (Client.ImageIndex = (Action as TCustomAction).ImageIndex);\r\nend;\r\n\r\nfunction TJvOutlookBarButtonActionLink.IsOnExecuteLinked: Boolean;\r\nbegin\r\n Result := inherited IsOnExecuteLinked and\r\n MethodsEqual(TMethod(Client.OnClick), TMethod(Action.OnExecute));\r\nend;\r\n\r\n\r\nprocedure TJvOutlookBarButtonActionLink.SetCaption(const Value: string);\r\n\r\n\r\nbegin\r\n if IsCaptionLinked then\r\n Client.Caption := Value;\r\nend;\r\n\r\nprocedure TJvOutlookBarButtonActionLink.SetEnabled(Value: Boolean);\r\nbegin\r\n if IsEnabledLinked then\r\n Client.Enabled := Value;\r\nend;\r\n\r\nprocedure TJvOutlookBarButtonActionLink.SetImageIndex(Value: Integer);\r\nbegin\r\n if IsImageIndexLinked then\r\n Client.ImageIndex := Value;\r\nend;\r\n\r\nprocedure TJvOutlookBarButtonActionLink.SetOnExecute(Value: TNotifyEvent);\r\nbegin\r\n if IsOnExecuteLinked then\r\n Client.OnClick := Value;\r\nend;\r\n\r\n//=== { TJvOutlookBarButton } ================================================\r\n\r\nconstructor TJvOutlookBarButton.Create(Collection: Classes.TCollection);\r\nbegin\r\n inherited Create(Collection);\r\n FEnabled := True;\r\nend;\r\n\r\ndestructor TJvOutlookBarButton.Destroy;\r\nvar\r\n OBPage: TJvOutlookBarPage;\r\n OB: TJvOutlookBar;\r\nbegin\r\n OBPage := TJvOutlookBarPage(TJvOutlookBarButtons(Self.Collection).Owner);\r\n OB := TJvOutlookBar(TJvOutlookBarPages(OBPage.Collection).Owner);\r\n if Assigned(OB) then\r\n begin\r\n if OB.FPressedButtonIndex = Index then\r\n OB.FPressedButtonIndex := -1;\r\n if OB.FLastButtonIndex = Index then\r\n OB.FLastButtonIndex := -1;\r\n OB.Invalidate;\r\n end;\r\n\r\n // Mantis 3688\r\n FActionLink.Free;\r\n\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvOutlookBarButton.Assign(Source: TPersistent);\r\nbegin\r\n if Source is TJvOutlookBarButton then\r\n begin\r\n Caption := TJvOutlookBarButton(Source).Caption;\r\n ImageIndex := TJvOutlookBarButton(Source).ImageIndex;\r\n Down := TJvOutlookBarButton(Source).Down;\r\n AutoToggle := TJvOutlookBarButton(Source).AutoToggle;\r\n Tag := TJvOutlookBarButton(Source).Tag;\r\n Enabled := TJvOutlookBarButton(Source).Enabled;\r\n Change;\r\n end\r\n else\r\n inherited Assign(Source);\r\nend;\r\n\r\nprocedure TJvOutlookBarButton.Change;\r\nbegin\r\n if (Collection <> nil) and (TJvOutlookBarButtons(Collection).Owner <> nil) and\r\n (TCollectionItem(TJvOutlookBarButtons(Collection).Owner).Collection <> nil) and\r\n (TCustomControl(TJvOutlookBarPages(TCollectionItem(TJvOutlookBarButtons(Collection).Owner).Collection).Owner) <> nil) then\r\n TCustomControl(TJvOutlookBarPages(TCollectionItem(TJvOutlookBarButtons(Collection).Owner).Collection).Owner).Invalidate;\r\nend;\r\n\r\nprocedure TJvOutlookBarButton.EditCaption;\r\nbegin\r\n SendMessage(TCustomControl(TJvOutlookBarPages(TCollectionItem(TJvOutlookBarButtons(Collection).Owner).Collection).Owner).Handle,\r\n CM_CAPTION_EDITING, WPARAM(Self), 0);\r\nend;\r\n\r\nfunction TJvOutlookBarButton.GetDisplayName: string;\r\nbegin\r\n if Caption <> '' then\r\n Result := Caption\r\n else\r\n Result := inherited GetDisplayName;\r\nend;\r\n\r\nprocedure TJvOutlookBarButton.SetCaption(const Value: TCaption);\r\nbegin\r\n if FCaption <> Value then\r\n begin\r\n FCaption := Value;\r\n Change;\r\n end;\r\nend;\r\n\r\nprocedure TJvOutlookBarButton.SetImageIndex(const Value: TImageIndex);\r\nbegin\r\n if FImageIndex <> Value then\r\n begin\r\n FImageIndex := Value;\r\n Change;\r\n end;\r\nend;\r\n\r\nprocedure TJvOutlookBarButton.SetDown(const Value: Boolean);\r\nvar\r\n I: Integer;\r\nbegin\r\n if Value <> FDown then\r\n begin\r\n FDown := Value;\r\n if FDown then\r\n for I := 0 to TJvOutlookBarButtons(Collection).Count - 1 do\r\n if TJvOutlookBarButtons(Collection).Items[I] <> Self then\r\n TJvOutlookBarButtons(Collection).Items[I].Down := False;\r\n Change;\r\n end;\r\nend;\r\n\r\nprocedure TJvOutlookBarButton.SetEnabled(const Value: Boolean);\r\nbegin\r\n if FEnabled <> Value then\r\n begin\r\n FEnabled := Value;\r\n Change;\r\n end;\r\nend;\r\n\r\nprocedure TJvOutlookBarButton.Click;\r\nbegin\r\n // Mantis 3689\r\n { Call OnClick if assigned and not equal to associated action's OnExecute.\r\n If associated action's OnExecute assigned then call it, otherwise, call\r\n OnClick. }\r\n if Assigned(FOnClick) and Assigned(Action) and (@FOnClick <> @Action.OnExecute) then\r\n FOnClick(Self)\r\n else\r\n if (GetOutlookBar <> nil) and (FActionLink <> nil) and not (csDesigning in GetOutlookBar.ComponentState) then\r\n FActionLink.Execute(GetOutlookBar)\r\n else\r\n if Assigned(FOnClick) then\r\n FOnClick(Self);\r\nend;\r\n\r\nfunction TJvOutlookBarButton.GetAction: TBasicAction;\r\nbegin\r\n if FActionLink <> nil then\r\n Result := FActionLink.Action\r\n else\r\n Result := nil;\r\nend;\r\n\r\nfunction TJvOutlookBarButton.GetActionLinkClass: TJvOutlookBarButtonActionLinkClass;\r\nbegin\r\n Result := TJvOutlookBarButtonActionLink;\r\nend;\r\n\r\nprocedure TJvOutlookBarButton.ActionChange(Sender: TObject;\r\n CheckDefaults: Boolean);\r\nbegin\r\n if Sender is TCustomAction then\r\n with TCustomAction(Sender) do\r\n begin\r\n if not CheckDefaults or (Self.Caption = '') then\r\n Self.Caption := Caption;\r\n if not CheckDefaults or Self.Enabled then\r\n Self.Enabled := Enabled;\r\n if not CheckDefaults or (Self.ImageIndex = -1) then\r\n Self.ImageIndex := ImageIndex;\r\n if not CheckDefaults or not Assigned(Self.OnClick) then\r\n Self.OnClick := OnExecute;\r\n end;\r\nend;\r\n\r\nprocedure TJvOutlookBarButton.DoActionChange(Sender: TObject);\r\nbegin\r\n if Sender = Action then\r\n ActionChange(Sender, False);\r\nend;\r\n\r\ntype\r\n THackOwnedCollection = class(TOwnedCollection);\r\n\r\nprocedure TJvOutlookBarButton.SetAction(Value: TBasicAction);\r\nbegin\r\n if (FActionLink <> nil) and (FActionLink.Action <> nil) then\r\n FActionLink.Action.RemoveFreeNotification(GetOutlookBar);\r\n if Value = nil then\r\n begin\r\n FActionLink.Free;\r\n FActionLink := nil;\r\n end\r\n else\r\n begin\r\n if FActionLink = nil then\r\n FActionLink := GetActionLinkClass.Create(Self);\r\n FActionLink.Action := Value;\r\n FActionLink.OnChange := DoActionChange;\r\n ActionChange(Value, csLoading in Value.ComponentState);\r\n if GetOutlookBar <> nil then\r\n Value.FreeNotification(GetOutlookBar); // delegates notification to owner!\r\n end;\r\nend;\r\n\r\nfunction TJvOutlookBarButton.GetOutlookBar: TJvCustomOutlookBar;\r\nbegin\r\n if TJvOutlookBarButtons(Collection).Owner is TJvOutlookBarPage then\r\n Result := TJvOutlookBarPage(TJvOutlookBarButtons(Collection).Owner).GetOutlookBar\r\n else\r\n Result := nil;\r\nend;\r\n\r\n//=== { TJvOutlookBarButtons } ===============================================\r\n\r\nconstructor TJvOutlookBarButtons.Create(AOwner: TPersistent);\r\nbegin\r\n inherited Create(AOwner, TJvOutlookBarButton);\r\nend;\r\n\r\nfunction TJvOutlookBarButtons.Add: TJvOutlookBarButton;\r\nbegin\r\n Result := TJvOutlookBarButton(inherited Add);\r\nend;\r\n\r\nprocedure TJvOutlookBarButtons.Assign(Source: TPersistent);\r\nvar\r\n I: Integer;\r\nbegin\r\n if Source is TJvOutlookBarButtons then\r\n begin\r\n BeginUpdate;\r\n try\r\n Clear;\r\n for I := 0 to TJvOutlookBarButtons(Source).Count - 1 do\r\n Add.Assign(TJvOutlookBarButtons(Source)[I]);\r\n finally\r\n EndUpdate;\r\n end;\r\n end\r\n else\r\n inherited Assign(Source);\r\nend;\r\n\r\nfunction TJvOutlookBarButtons.GetItem(Index: Integer): TJvOutlookBarButton;\r\nbegin\r\n Result := TJvOutlookBarButton(inherited Items[Index]);\r\nend;\r\n\r\nfunction TJvOutlookBarButtons.Insert(Index: Integer): TJvOutlookBarButton;\r\nbegin\r\n Result := TJvOutlookBarButton(inherited Insert(Index));\r\nend;\r\n\r\nprocedure TJvOutlookBarButtons.SetItem(Index: Integer;\r\n const Value: TJvOutlookBarButton);\r\nbegin\r\n inherited Items[Index] := Value;\r\nend;\r\n\r\nprocedure TJvOutlookBarButtons.Update(Item: TCollectionItem);\r\nbegin\r\n inherited Update(Item);\r\n if Owner <> nil then\r\n TJvOutlookBarPage(Owner).Changed(False);\r\nend;\r\n\r\n//=== { TJvOutlookBarPage } ==================================================\r\n\r\nconstructor TJvOutlookBarPage.Create(Collection: Classes.TCollection);\r\nbegin\r\n inherited Create(Collection);\r\n FFont := TFont.Create;\r\n FFont.OnChange := DoFontChange;\r\n FDownFont := TFont.Create;\r\n FDownFont.OnChange := DoFontChange;\r\n FParentColor := True;\r\n FPicture := TPicture.Create;\r\n FPicture.OnChange := DoPictureChange;\r\n FAlignment := taCenter;\r\n FImageIndex := -1;\r\n FEnabled := True;\r\n FButtons := TJvOutlookBarButtons.Create(Self);\r\n if (Collection <> nil) and (TJvOutlookBarPages(Collection).Owner <> nil) then\r\n begin\r\n FButtonSize := TJvCustomOutlookBar(TJvOutlookBarPages(Collection).Owner).ButtonSize;\r\n// FColor := TJvCustomOutlookBar(TJvOutlookBarPages(Collection).Owner).Color;\r\n Font := TJvCustomOutlookBar(TJvOutlookBarPages(Collection).Owner).Font;\r\n DownFont := Font;\r\n end\r\n else\r\n begin\r\n FButtonSize := olbsLarge;\r\n end;\r\n FColor := clDefault;\r\n Font.Color := clWhite;\r\n FParentButtonSize := True;\r\nend;\r\n\r\ndestructor TJvOutlookBarPage.Destroy;\r\nbegin\r\n FButtons.Free;\r\n FPicture.Free;\r\n FFont.Free;\r\n FDownFont.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvOutlookBarPage.Assign(Source: TPersistent);\r\nvar\r\n I: Integer;\r\nbegin\r\n if Source is TJvOutlookBarPage then\r\n begin\r\n Caption := TJvOutlookBarPage(Source).Caption;\r\n Picture := TJvOutlookBarPage(Source).Picture;\r\n Color := TJvOutlookBarPage(Source).Color;\r\n DownFont.Assign(TJvOutlookBarPage(Source).DownFont);\r\n ButtonSize := TJvOutlookBarPage(Source).ButtonSize;\r\n ParentButtonSize := TJvOutlookBarPage(Source).ParentButtonSize;\r\n ParentColor := TJvOutlookBarPage(Source).ParentColor;\r\n Enabled := TJvOutlookBarPage(Source).Enabled;\r\n Buttons.Clear;\r\n for I := 0 to TJvOutlookBarPage(Source).Buttons.Count - 1 do\r\n Buttons.Add.Assign(TJvOutlookBarPage(Source).Buttons[I]);\r\n Change;\r\n end\r\n else\r\n inherited Assign(Source);\r\nend;\r\n\r\nprocedure TJvOutlookBarPage.Change;\r\nbegin\r\n if (Collection <> nil) and (TJvOutlookBarPages(Collection).UpdateCount = 0) then\r\n TJvOutlookBarPages(Collection).Update(Self);\r\nend;\r\n\r\nprocedure TJvOutlookBarPage.SetTopButtonIndex(const Value: Integer);\r\nbegin\r\n if (FTopButtonIndex <> Value) and (Value >= 0) and (Value < Buttons.Count) then\r\n begin\r\n FTopButtonIndex := Value;\r\n Change;\r\n end;\r\nend;\r\n\r\nprocedure TJvOutlookBarPage.SetButtons(const Value: TJvOutlookBarButtons);\r\nbegin\r\n FButtons.Assign(Value);\r\n Change;\r\nend;\r\n\r\nprocedure TJvOutlookBarPage.SetCaption(const Value: TCaption);\r\nbegin\r\n if FCaption <> Value then\r\n begin\r\n FCaption := Value;\r\n Change;\r\n end;\r\nend;\r\n\r\nprocedure TJvOutlookBarPage.SetButtonSize(const Value: TJvBarButtonSize);\r\nbegin\r\n if FButtonSize <> Value then\r\n begin\r\n FButtonSize := Value;\r\n if not (csReading in TComponent(TJvOutlookBarPages(Collection).Owner).ComponentState) then\r\n FParentButtonSize := False;\r\n Change;\r\n end;\r\nend;\r\n\r\nprocedure TJvOutlookBarPage.SetColor(const Value: TColor);\r\nbegin\r\n if FColor <> Value then\r\n begin\r\n FColor := Value;\r\n FParentColor := False;\r\n Change;\r\n end;\r\nend;\r\n\r\nprocedure TJvOutlookBarPage.SetFont(const Value: TFont);\r\nbegin\r\n FFont.Assign(Value);\r\n FParentFont := False;\r\nend;\r\n\r\nprocedure TJvOutlookBarPage.SetEnabled(const Value: Boolean);\r\nbegin\r\n if FEnabled <> Value then\r\n begin\r\n FEnabled := Value;\r\n Change;\r\n end;\r\nend;\r\n\r\nprocedure TJvOutlookBarPage.SetPicture(const Value: TPicture);\r\nbegin\r\n FPicture.Assign(Value);\r\nend;\r\n\r\nprocedure TJvOutlookBarPage.SetParentButtonSize(const Value: Boolean);\r\nbegin\r\n if FParentButtonSize <> Value then\r\n begin\r\n FParentButtonSize := Value;\r\n if Value then\r\n begin\r\n FButtonSize := (TJvOutlookBarPages(Collection).Owner as TJvCustomOutlookBar).ButtonSize;\r\n Change;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvOutlookBarPage.SetParentColor(const Value: Boolean);\r\nbegin\r\n if FParentColor <> Value then\r\n begin\r\n FParentColor := Value;\r\n if Value then\r\n begin\r\n FColor := (TJvOutlookBarPages(Collection).Owner as TJvCustomOutlookBar).Color;\r\n Change;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvOutlookBarPage.SetParentFont(const Value: Boolean);\r\nbegin\r\n if FParentFont <> Value then\r\n begin\r\n if Value then\r\n Font := (TJvOutlookBarPages(Collection).Owner as TJvCustomOutlookBar).Font;\r\n FParentFont := Value;\r\n end;\r\nend;\r\n\r\nprocedure TJvOutlookBarPage.EditCaption;\r\nbegin\r\n SendMessage(TCustomControl(TJvOutlookBarPages(Collection).Owner).Handle, CM_CAPTION_EDITING, WPARAM(Self), 1);\r\nend;\r\n\r\nfunction TJvOutlookBarPage.GetDisplayName: string;\r\nbegin\r\n if Caption <> '' then\r\n Result := Caption\r\n else\r\n Result := inherited GetDisplayName;\r\nend;\r\n\r\nfunction TJvOutlookBarPage.GetOutlookBar: TJvCustomOutlookBar;\r\nbegin\r\n if TJvOutlookBarPages(Collection).Owner is TJvCustomOutlookBar then\r\n Result := TJvCustomOutlookBar(TJvOutlookBarPages(Collection).Owner)\r\n else\r\n Result := nil;\r\nend;\r\n\r\nprocedure TJvOutlookBarPage.SetImageIndex(const Value: TImageIndex);\r\nbegin\r\n if FImageIndex <> Value then\r\n begin\r\n FImageIndex := Value;\r\n Change;\r\n end;\r\nend;\r\n\r\nprocedure TJvOutlookBarPage.SetAlignment(const Value: TAlignment);\r\nbegin\r\n if FAlignment <> Value then\r\n begin\r\n FAlignment := Value;\r\n Change;\r\n end;\r\nend;\r\n\r\nprocedure TJvOutlookBarPage.SetDownFont(const Value: TFont);\r\nbegin\r\n if Value <> FDownFont then\r\n FDownFont.Assign(Value);\r\nend;\r\n\r\nprocedure TJvOutlookBarPage.DoFontChange(Sender: TObject);\r\nbegin\r\n Change;\r\n if Sender <> FDownFont then\r\n FParentFont := False;\r\nend;\r\n\r\nfunction TJvOutlookBarPage.GetDownButton: TJvOutlookBarButton;\r\nvar\r\n Index: Integer;\r\nbegin\r\n Index := DownIndex;\r\n if Index <> -1 then\r\n Result := Buttons[Index]\r\n else\r\n Result := nil;\r\nend;\r\n\r\nprocedure TJvOutlookBarPage.SetDownButton(Value: TJvOutlookBarButton);\r\nbegin\r\n if Value = nil then\r\n DownIndex := -1\r\n else\r\n DownIndex := Value.Index;\r\nend;\r\n\r\nfunction TJvOutlookBarPage.GetDownIndex: Integer;\r\nbegin\r\n for Result := 0 to Buttons.Count - 1 do\r\n if Buttons[Result].Down then\r\n Exit;\r\n Result := -1;\r\nend;\r\n\r\nprocedure TJvOutlookBarPage.SetDownIndex(Value: Integer);\r\nbegin\r\n if (Value >= 0) and (Value < Buttons.Count) then\r\n Buttons[Value].Down := True;\r\nend;\r\n\r\n//=== { TJvOutlookBarPages } =================================================\r\n\r\nconstructor TJvOutlookBarPages.Create(AOwner: TPersistent);\r\nbegin\r\n inherited Create(AOwner, TJvOutlookBarPage);\r\nend;\r\n\r\nfunction TJvOutlookBarPages.Add: TJvOutlookBarPage;\r\nbegin\r\n Result := TJvOutlookBarPage(inherited Add);\r\nend;\r\n\r\nprocedure TJvOutlookBarPages.Assign(Source: TPersistent);\r\nvar\r\n I: Integer;\r\nbegin\r\n if Source is TJvOutlookBarPages then\r\n begin\r\n BeginUpdate;\r\n try\r\n Clear;\r\n for I := 0 to TJvOutlookBarPages(Source).Count - 1 do\r\n Add.Assign(TJvOutlookBarPages(Source)[I]);\r\n finally\r\n EndUpdate\r\n end;\r\n end\r\n else\r\n inherited Assign(Source);\r\nend;\r\n\r\nfunction TJvOutlookBarPages.GetItem(Index: Integer): TJvOutlookBarPage;\r\nbegin\r\n Result := TJvOutlookBarPage(inherited Items[Index]);\r\nend;\r\n\r\nfunction TJvOutlookBarPages.Insert(Index: Integer): TJvOutlookBarPage;\r\nbegin\r\n Result := TJvOutlookBarPage(inherited Insert(Index));\r\nend;\r\n\r\nprocedure TJvOutlookBarPages.SetItem(Index: Integer;\r\n const Value: TJvOutlookBarPage);\r\nbegin\r\n inherited Items[Index] := Value;\r\nend;\r\n\r\nprocedure TJvOutlookBarPages.Update(Item: TCollectionItem);\r\nbegin\r\n inherited Update(Item);\r\n if Owner <> nil then\r\n TJvCustomOutlookBar(Owner).Repaint;\r\nend;\r\n\r\n//=== { TJvThemedTopBottomButton } ===========================================\r\n\r\n{$IFDEF JVCLThemesEnabled}\r\n\r\ntype\r\n TJvThemedTopBottomButton = class(TJvRepeatButton)\r\n private\r\n FIsUpBtn: Boolean;\r\n protected\r\n procedure WMEraseBkgnd(var Msg: TWmEraseBkgnd); message WM_ERASEBKGND;\r\n procedure Paint; override;\r\n end;\r\n\r\nprocedure TJvThemedTopBottomButton.Paint;\r\nvar\r\n Button: TThemedScrollBar;\r\n Details: TThemedElementDetails;\r\nbegin\r\n if csDestroying in ComponentState then\r\n Exit;\r\n if {Themed}ThemeServices.{$IFDEF RTL230_UP}Enabled{$ELSE}ThemesEnabled{$ENDIF RTL230_UP} and (not Flat) then\r\n begin\r\n if not Enabled then\r\n Button := tsArrowBtnUpDisabled\r\n else\r\n if FState in [bsDown, bsExclusive] then\r\n Button := tsArrowBtnUpPressed\r\n else\r\n if MouseInControl then\r\n Button := tsArrowBtnUpHot\r\n else\r\n Button := tsArrowBtnUpNormal;\r\n\r\n if not FIsUpBtn then\r\n Button := TThemedScrollBar(Ord(tsArrowBtnDownNormal) + Ord(Button) - Ord(tsArrowBtnUpNormal));\r\n\r\n Details := ThemeServices.GetElementDetails(Button);\r\n\r\n ThemeServices.DrawElement(Canvas.Handle, Details, ClientRect, nil); //@ClipRect);\r\n end\r\n else\r\n inherited Paint;\r\nend;\r\n\r\nprocedure TJvThemedTopBottomButton.WMEraseBkgnd(var Msg: TWmEraseBkgnd);\r\nbegin\r\n Msg.Result := 1;\r\nend;\r\n\r\n{$ENDIF JVCLThemesEnabled}\r\n\r\n//=== { TJvCustomOutlookBar } ================================================\r\n\r\nconstructor TJvCustomOutlookBar.Create(AOwner: TComponent);\r\nvar\r\n Bmp: TBitmap;\r\nbegin\r\n inherited Create(AOwner);\r\n\r\n FPageBtnProps := TJvPageBtnProps.Create(self);\r\n DoubleBuffered := True;\r\n {$IFDEF JVCLThemesEnabled}\r\n FThemed := ThemeServices.{$IFDEF RTL230_UP}Enabled{$ELSE}ThemesEnabled{$ENDIF RTL230_UP};\r\n {$endif}\r\n\r\n ControlStyle := ControlStyle - [csAcceptsControls] + [csOpaque];\r\n IncludeThemeStyle(Self, [csNeedsBorderPaint]);\r\n Bmp := TBitmap.Create;\r\n FDisabledFontColor1 := clWhite;\r\n FDisabledFontColor2 := clGrayText;\r\n\r\n try\r\n {$IFDEF JVCLThemesEnabled}\r\n FTopButton := TJvThemedTopBottomButton.Create(Self);\r\n TJvThemedTopBottomButton(FTopButton).FIsUpBtn := True;\r\n {$ELSE}\r\n FTopButton := TJvRepeatButton.Create(Self);\r\n {$ENDIF JVCLThemesEnabled}\r\n with FTopButton do\r\n begin\r\n Parent := Self;\r\n Visible := False;\r\n Transparent := False;\r\n Bmp.LoadFromResourceName(HInstance, 'JvCustomOutlookBarUPARROW');\r\n Glyph := Bmp;\r\n OnClick := DoUpClick;\r\n if csDesigning in ComponentState then\r\n Top := -1000;\r\n end;\r\n\r\n {$IFDEF JVCLThemesEnabled}\r\n FBtmButton := TJvThemedTopBottomButton.Create(Self);\r\n TJvThemedTopBottomButton(FBtmButton).FIsUpBtn := False;\r\n {$ELSE}\r\n FBtmButton := TJvRepeatButton.Create(Self);\r\n {$ENDIF JVCLThemesEnabled}\r\n with FBtmButton do\r\n begin\r\n Parent := Self;\r\n Visible := False;\r\n Transparent := False;\r\n Bmp.Assign(nil); // fixes GDI resource leak\r\n Bmp.LoadFromResourceName(HInstance, 'JvCustomOutlookBarDOWNARROW');\r\n Glyph := Bmp;\r\n OnClick := DoDwnClick;\r\n if csDesigning in ComponentState then\r\n Top := -1000;\r\n end;\r\n finally\r\n Bmp.Free;\r\n end;\r\n\r\n FPages := TJvOutlookBarPages.Create(Self);\r\n FLargeChangeLink := TChangeLink.Create;\r\n FLargeChangeLink.OnChange := DoChangeLinkChange;\r\n FSmallChangeLink := TChangeLink.Create;\r\n FSmallChangeLink.OnChange := DoChangeLinkChange;\r\n FPageChangeLink := TChangeLink.Create;\r\n FPageChangeLink.OnChange := DoChangeLinkChange;\r\n FEdit := TJvOutlookBarEdit.CreateInternal(Self, Self, nil);\r\n FEdit.Top := -1000;\r\n // set up defaults\r\n Width := 100;\r\n Height := 220;\r\n Color := clBtnShadow;\r\n BorderStyle := bsSingle;\r\n ButtonSize := olbsLarge;\r\n PageButtonHeight := 19;\r\n\r\n FPressedPageBtn := -1;\r\n FNextActivePage := -1;\r\n FLastButtonIndex := -1;\r\n FPressedButtonIndex := -1;\r\n {$IFDEF JVCLThemesEnabled}\r\n FHotPageBtn := -1;\r\n FThemedBackGround := True;\r\n {$ENDIF JVCLThemesEnabled}\r\n ActivePageIndex := 0;\r\nend;\r\n\r\ndestructor TJvCustomOutlookBar.Destroy;\r\nbegin\r\n FEdit.Free;\r\n FLargeChangeLink.Free;\r\n FSmallChangeLink.Free;\r\n FPageChangeLink.Free;\r\n FPages.Free;\r\n FPageBtnProps.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvCustomOutlookBar.DoDwnClick(Sender: TObject);\r\nbegin\r\n if FBtmButton.Visible then\r\n with Pages[ActivePageIndex] do\r\n if TopButtonIndex < Buttons.Count then\r\n TopButtonIndex := TopButtonIndex + 1;\r\nend;\r\n\r\nprocedure TJvCustomOutlookBar.DoUpClick(Sender: TObject);\r\nbegin\r\n if FTopButton.Visible then\r\n with Pages[ActivePageIndex] do\r\n if TopButtonIndex > 0 then\r\n TopButtonIndex := TopButtonIndex - 1;\r\nend;\r\n\r\n\r\nprocedure TJvCustomOutlookBar.CreateParams(var Params: TCreateParams);\r\nconst\r\n BorderStyles: array [TBorderStyle] of DWORD = (0, WS_BORDER);\r\nbegin\r\n inherited CreateParams(Params);\r\n with Params do\r\n begin\r\n Style := Style or BorderStyles[FBorderStyle];\r\n if Ctl3D and (FBorderStyle = bsSingle) then\r\n begin\r\n Style := Style and not WS_BORDER;\r\n ExStyle := ExStyle or WS_EX_CLIENTEDGE;\r\n end;\r\n end;\r\nend;\r\n\r\n\r\nprocedure TJvCustomOutlookBar.DoChangeLinkChange(Sender: TObject);\r\nbegin\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvCustomOutlookBar.Notification(AComponent: TComponent;\r\n Operation: TOperation);\r\nvar\r\n I, J: Integer;\r\nbegin\r\n inherited Notification(AComponent, Operation);\r\n if Operation = opRemove then\r\n begin\r\n if AComponent = FLargeImages then\r\n LargeImages := nil\r\n else\r\n if AComponent = FSmallImages then\r\n SmallImages := nil\r\n else\r\n if AComponent = FPageImages then\r\n PageImages := nil;\r\n if (AComponent is TBasicAction) and not (csDestroying in ComponentState) then\r\n begin\r\n for I := 0 to Pages.Count - 1 do\r\n for J := 0 to Pages[I].Buttons.Count - 1 do\r\n if AComponent = Pages[I].Buttons[J].Action then\r\n Pages[I].Buttons[J].Action := nil;\r\n end;\r\n end;\r\nend;\r\n\r\n\r\n{ Warren modified this so you can have some weird page button colors that aren't standard windows colors } \r\nprocedure TJvCustomOutlookBar.DrawPageButton(R: TRect; Index: Integer; Pressed: Boolean);\r\nvar\r\n SavedDC, ATop: Integer;\r\n SavedColor: TColor;\r\n Flags: Cardinal;\r\n HasImage: Boolean;\r\nbegin\r\n Assert(Assigned(FPageBtnProps));\r\n ATop := R.Top + 1;\r\n if Pressed then\r\n begin\r\n if BorderStyle = bsNone then\r\n Frame3D(Canvas, R, FPageBtnProps.Shadow, FPageBtnProps.Highlight, FPageBtnProps.BorderWidth)\r\n else\r\n begin\r\n Frame3D(Canvas, R, FPageBtnProps.DkShadow, FPageBtnProps.Highlight, FPageBtnProps.BorderWidth);\r\n Frame3D(Canvas, R, FPageBtnProps.Shadow, FPageBtnProps.Face, FPageBtnProps.BorderWidth);\r\n end;\r\n end\r\n else\r\n begin\r\n if BorderStyle = bsNone then\r\n Frame3D(Canvas, R, FPageBtnProps.Highlight, FPageBtnProps.Shadow, FPageBtnProps.BorderWidth)\r\n else\r\n begin\r\n Frame3D(Canvas, R, FPageBtnProps.Highlight, FPageBtnProps.DkShadow, FPageBtnProps.BorderWidth);\r\n Frame3D(Canvas, R, FPageBtnProps.Face, FPageBtnProps.Shadow, FPageBtnProps.BorderWidth);\r\n end;\r\n end;\r\n Flags := DT_CENTER or DT_VCENTER or DT_SINGLELINE;\r\n HasImage := Assigned(PageImages) and (Pages[Index].ImageIndex >= 0) and (Pages[Index].ImageIndex < PageImages.Count);\r\n SavedDC := SaveDC(Canvas.Handle);\r\n try\r\n case Pages[Index].Alignment of\r\n taLeftJustify:\r\n begin\r\n if HasImage then\r\n begin\r\n PageImages.Draw(Canvas, 4, ATop, Pages[Index].ImageIndex,\r\n Pages[Index].Enabled);\r\n Inc(R.Left, PageImages.Width + 8);\r\n end\r\n else\r\n Inc(R.Left, 4);\r\n Flags := DT_LEFT or DT_VCENTER or DT_SINGLELINE;\r\n end;\r\n taCenter:\r\n if HasImage then\r\n begin\r\n PageImages.Draw(Canvas, 4, ATop, Pages[Index].ImageIndex,\r\n Pages[Index].Enabled);\r\n Inc(R.Left, PageImages.Width + 4);\r\n end;\r\n taRightJustify:\r\n begin\r\n if HasImage then\r\n begin\r\n PageImages.Draw(Canvas, 4, ATop, Pages[Index].ImageIndex,\r\n Pages[Index].Enabled);\r\n Inc(R.Left, PageImages.Width + 8);\r\n end;\r\n Dec(R.Right, 4);\r\n Flags := DT_RIGHT or DT_VCENTER or DT_SINGLELINE;\r\n end;\r\n end;\r\n finally\r\n RestoreDC(Canvas.Handle, SavedDC);\r\n end;\r\n SetBkMode(Canvas.Handle, TRANSPARENT);\r\n OffsetRect(R, 0, -1);\r\n SavedColor := Canvas.Font.Color;\r\n try\r\n if not Pages[Index].Enabled then\r\n begin\r\n OffsetRect(R, 1, 1);\r\n Canvas.Font.Color := FDisabledFontColor1; //clWhite;\r\n DrawText(Canvas, Pages[Index].Caption, -1, R, Flags or DT_END_ELLIPSIS);\r\n OffsetRect(R, -1, -1);\r\n Canvas.Font.Color := FDisabledFontColor2; //clGrayText;\r\n end;\r\n DrawText(Canvas, Pages[Index].Caption, -1, R, Flags or DT_END_ELLIPSIS);\r\n finally\r\n Canvas.Font.Color := SavedColor;\r\n end;\r\nend;\r\n\r\nfunction TJvCustomOutlookBar.DrawTopPages: Integer;\r\nvar\r\n R: TRect;\r\n I: Integer;\r\n {$IFDEF JVCLThemesEnabled}\r\n ToolBar: TThemedToolBar;\r\n Details: TThemedElementDetails;\r\n ClipRect: TRect;\r\n LColor: Cardinal;\r\n {$ENDIF JVCLThemesEnabled}\r\nbegin\r\n Result := -1;\r\n if csDestroying in ComponentState then\r\n Exit;\r\n R := GetPageButtonRect(0);\r\n\r\n for I := 0 to Pages.Count - 1 do\r\n begin\r\n if DoDrawPageButton(R, I, FPressedPageBtn = I) then\r\n begin\r\n {$IFDEF JVCLThemesEnabled}\r\n if Themed then // Warren changed.\r\n begin\r\n if (FPressedPageBtn = I) or (FHotPageBtn = I) then\r\n ToolBar := ttbButtonPressed\r\n else\r\n ToolBar := ttbButtonHot;\r\n Details := ThemeServices.GetElementDetails(ToolBar);\r\n\r\n if BorderStyle = bsNone then\r\n begin\r\n ClipRect := R;\r\n InflateRect(R, 1, 1);\r\n ThemeServices.DrawElement(Canvas.Handle, Details, R, @ClipRect);\r\n InflateRect(R, -1, -1);\r\n end\r\n else\r\n ThemeServices.DrawElement(Canvas.Handle, Details, R);\r\n\r\n { Determine text color }\r\n if FPressedPageBtn = I then\r\n ToolBar := ttbButtonPressed\r\n else\r\n if FHotPageBtn = I then\r\n ToolBar := ttbButtonHot\r\n else\r\n ToolBar := ttbButtonNormal;\r\n Details := ThemeServices.GetElementDetails(ToolBar);\r\n\r\n with Details do\r\n GetThemeColor(ThemeServices.Theme[Element], Part, State, TMT_TEXTCOLOR, LColor);\r\n Canvas.Font.Color := LColor;\r\n end\r\n else\r\n {$ENDIF JVCLThemesEnabled}\r\n begin\r\n Canvas.Brush.Color := PageBtnProps.Face;// clBtnFace;\r\n Canvas.FillRect(R);\r\n end;\r\n DrawPageButton(R, I, FPressedPageBtn = I);\r\n end;\r\n OffsetRect(R, 0, PageButtonHeight);\r\n if I >= ActivePageIndex then\r\n begin\r\n Result := I;\r\n Exit;\r\n end;\r\n end;\r\n Result := Pages.Count - 1;\r\nend;\r\n\r\nprocedure TJvCustomOutlookBar.DrawButtons(Index: Integer);\r\nvar\r\n I, H: Integer;\r\n R, R2, R3: TRect;\r\n C: TColor;\r\n SavedDC: Integer;\r\n SavedColor: TColor;\r\n {$IFDEF JVCLThemesEnabled}\r\n ThemedColor: Cardinal;\r\n Details: TThemedElementDetails;\r\n {$ENDIF JVCLThemesEnabled}\r\nbegin\r\n if csDestroying in ComponentState then\r\n Exit;\r\n if (Index < 0) or (Index >= Pages.Count) or (Pages[Index].Buttons = nil) or\r\n (Pages[Index].Buttons.Count <= 0) then\r\n Exit;\r\n R2 := GetPageRect(Index);\r\n R := GetButtonRect(Index, Pages[Index].TopButtonIndex);\r\n H := GetButtonHeight(Index);\r\n C := Canvas.Pen.Color;\r\n Canvas.Font := Pages[Index].Font;\r\n\r\n {$IFDEF JVCLThemesEnabled}\r\n if Themed then\r\n begin\r\n Details := ThemeServices.GetElementDetails(ttbButtonNormal);\r\n with Details do\r\n GetThemeColor(ThemeServices.Theme[Element], Part, State, TMT_TEXTCOLOR, ThemedColor);\r\n end;\r\n {$ENDIF JVCLThemesEnabled}\r\n try\r\n Canvas.Brush.Style := bsClear;\r\n for I := Pages[Index].TopButtonIndex to Pages[Index].Buttons.Count - 1 do\r\n begin\r\n Canvas.Font := Pages[Index].Font;\r\n// Canvas.Rectangle(R); // DEBUG\r\n {$IFDEF JVCLThemesEnabled}\r\n if Themed then\r\n Canvas.Font.Color := ThemedColor;\r\n {$ENDIF JVCLThemesEnabled}\r\n if Pages[Index].Buttons[I].Down then\r\n begin\r\n Canvas.Font := Pages[Index].DownFont;\r\n DrawButtonFrame(Index, I, I);\r\n end;\r\n if DoDrawButton(R, I, Pages[Index].Buttons[I].Down, I = FLastButtonIndex) then\r\n case Pages[Index].ButtonSize of\r\n olbsLarge:\r\n begin\r\n SavedColor := Canvas.Font.Color;\r\n try\r\n SavedDC := SaveDC(Canvas.Handle);\r\n try\r\n if LargeImages <> nil then\r\n LargeImages.Draw(Canvas, R.Left + ((R.Right - R.Left) - LargeImages.Width) div 2, R.Top + 4,\r\n Pages[Index].Buttons[I].ImageIndex,\r\n \r\n Pages[Index].Enabled and Pages[Index].Buttons[I].Enabled);\r\n finally\r\n RestoreDC(Canvas.Handle, SavedDC);\r\n end;\r\n R3 := GetButtonTextRect(ActivePageIndex, I);\r\n SetBkMode(Canvas.Handle, TRANSPARENT);\r\n if not Pages[Index].Enabled or not Pages[Index].Buttons[I].Enabled then\r\n begin\r\n if ColorToRGB(Pages[Index].Color) = ColorToRGB(clGrayText) then\r\n Canvas.Font.Color := PageBtnProps.Face//clBtnFace\r\n else\r\n Canvas.Font.Color := clGrayText;\r\n end;\r\n DrawText(Canvas.Handle, PChar(Pages[Index].Buttons[I].Caption), -1, R3,\r\n DT_EXPANDTABS or DT_SINGLELINE or DT_CENTER or DT_VCENTER);\r\n finally\r\n Canvas.Font.Color := SavedColor;\r\n end;\r\n end;\r\n olbsSmall:\r\n begin\r\n SavedColor := Canvas.Font.Color;\r\n try\r\n SavedDC := SaveDC(Canvas.Handle);\r\n try\r\n if SmallImages <> nil then\r\n SmallImages.Draw(Canvas, R.Left + 2, R.Top + 2,\r\n Pages[Index].Buttons[I].ImageIndex,\r\n Pages[Index].Enabled and Pages[Index].Buttons[I].Enabled);\r\n finally\r\n RestoreDC(Canvas.Handle, SavedDC);\r\n end;\r\n R3 := GetButtonTextRect(ActivePageIndex, I);\r\n SetBkMode(Canvas.Handle, TRANSPARENT);\r\n if not Pages[Index].Enabled or not Pages[Index].Buttons[I].Enabled then\r\n begin\r\n if ColorToRGB(Pages[Index].Color) = ColorToRGB(clGrayText) then\r\n Canvas.Font.Color := PageBtnProps.Face//clBtnFace\r\n else\r\n Canvas.Font.Color := clGrayText;\r\n end;\r\n InflateRect(R3, -4, 0);\r\n DrawText(Canvas.Handle, PChar(Pages[Index].Buttons[I].Caption), -1, R3,\r\n DT_EXPANDTABS or DT_SINGLELINE or DT_LEFT or DT_VCENTER or DT_NOCLIP or DT_EDITCONTROL);\r\n finally\r\n Canvas.Font.Color := SavedColor;\r\n end;\r\n end;\r\n end;\r\n OffsetRect(R, 0, H);\r\n if R.Top >= R2.Bottom then\r\n Break;\r\n end;\r\n finally\r\n Canvas.Font := Self.Font;\r\n Canvas.Pen.Color := C;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomOutlookBar.DrawArrowButtons(Index: Integer);\r\nvar\r\n R: TRect;\r\n H: Integer;\r\nbegin\r\n if csDestroying in ComponentState then\r\n Exit;\r\n if (Index < 0) or (Index >= Pages.Count) or (Pages[Index].Buttons = nil) or\r\n (Pages[Index].Buttons.Count <= 0) then\r\n begin\r\n TopButton.Visible := False;\r\n BtmButton.Visible := False;\r\n end\r\n else\r\n begin\r\n R := GetPageRect(Index);\r\n H := GetButtonHeight(Index);\r\n TopButton.Visible := (Pages.Count > 0) and (R.Top < R.Bottom - 20) and (Pages[Index].TopButtonIndex > 0);\r\n BtmButton.Visible := (Pages.Count > 0) and (R.Top < R.Bottom - 20) and\r\n (R.Bottom - R.Top < (Pages[Index].Buttons.Count - Pages[Index].TopButtonIndex) * H);\r\n // remove the last - H to show arrow\r\n // button when the bottom of the last button is beneath the edge\r\n end;\r\n if TopButton.Visible then\r\n TopButton.SetBounds(ClientWidth - 20, R.Top + 4, 16, 16)\r\n else\r\n if csDesigning in ComponentState then\r\n TopButton.Top := -1000;\r\n if BtmButton.Visible then\r\n BtmButton.SetBounds(ClientWidth - 20, R.Bottom - 20, 16, 16)\r\n else\r\n if csDesigning in ComponentState then\r\n BtmButton.Top := -1000;\r\n TopButton.Enabled := TopButton.Visible and Pages[Index].Enabled;\r\n BtmButton.Enabled := BtmButton.Visible and Pages[Index].Enabled;\r\nend;\r\n\r\nfunction TJvCustomOutlookBar.DrawPicture(R: TRect; Picture: TPicture): Boolean;\r\nvar\r\n Bmp: TBitmap;\r\nbegin\r\n Result := Assigned(Picture) and Assigned(Picture.Graphic) and not Picture.Graphic.Empty;\r\n if csDestroying in ComponentState then\r\n Exit;\r\n if Result then\r\n begin\r\n Bmp := TBitmap.Create;\r\n try\r\n Bmp.Assign(Picture.Graphic);\r\n Canvas.Brush.Bitmap := Bmp;\r\n Canvas.FillRect(R);\r\n Canvas.Brush.Bitmap := nil;\r\n finally\r\n Bmp.Free;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomOutlookBar.DrawCurrentPage(PageIndex: Integer);\r\nvar\r\n R: TRect;\r\n AColor: TColor;\r\n {$IFDEF JVCLThemesEnabled}\r\n Details: TThemedElementDetails;\r\n {$ENDIF JVCLThemesEnabled}\r\nbegin\r\n if csDestroying in ComponentState then\r\n Exit;\r\n if (PageIndex < 0) or (PageIndex >= Pages.Count) or (Pages[PageIndex].Buttons = nil) then\r\n Exit;\r\n R := GetPageRect(PageIndex);\r\n AColor := Canvas.Brush.Color;\r\n try\r\n Canvas.Brush.Color := Pages[PageIndex].Color;\r\n Canvas.Font := Self.Font;\r\n if DoDrawPage(R, PageIndex) then\r\n begin\r\n if not DrawPicture(R, Pages[PageIndex].Picture) then\r\n begin\r\n {$IFDEF JVCLThemesEnabled}\r\n if (Canvas.Brush.Color = clDefault) and ThemedBackground and Themed then\r\n begin\r\n Details := ThemeServices.GetElementDetails(tebHeaderBackgroundNormal);\r\n ThemeServices.DrawElement(Canvas.Handle, Details, R);\r\n end\r\n else\r\n {$ENDIF JVCLThemesEnabled}\r\n begin\r\n if Canvas.Brush.Color = clDefault then\r\n Canvas.Brush.Color := Self.Color;\r\n Canvas.FillRect(R);\r\n end;\r\n end;\r\n end;\r\n DrawButtonFrame(ActivePageIndex, FLastButtonIndex, FPressedButtonIndex);\r\n DrawButtons(PageIndex);\r\n finally\r\n Canvas.Brush.Color := AColor;\r\n Canvas.Brush.Style := bsClear;\r\n SetBkMode(Canvas.Handle, TRANSPARENT);\r\n end;\r\n DrawArrowButtons(PageIndex);\r\nend;\r\n\r\nprocedure TJvCustomOutlookBar.DrawBottomPages(StartIndex: Integer);\r\nvar\r\n R: TRect;\r\n I: Integer;\r\n {$IFDEF JVCLThemesEnabled}\r\n Details: TThemedElementDetails;\r\n ClipRect: TRect;\r\n ToolBar: TThemedToolBar;\r\n LColor: Cardinal;\r\n {$ENDIF JVCLThemesEnabled}\r\nbegin\r\n if csDestroying in ComponentState then\r\n Exit;\r\n R := GetPageButtonRect(Pages.Count - 1);\r\n for I := Pages.Count - 1 downto StartIndex do\r\n begin\r\n if DoDrawPageButton(R, I, FPressedPageBtn = I) then\r\n begin\r\n {$IFDEF JVCLThemesEnabled}\r\n if Themed then\r\n begin\r\n if (FPressedPageBtn = I) or (FHotPageBtn = I) then\r\n ToolBar := ttbButtonPressed\r\n else\r\n ToolBar := ttbButtonHot;\r\n Details := ThemeServices.GetElementDetails(ToolBar);\r\n\r\n if BorderStyle = bsNone then\r\n begin\r\n ClipRect := R;\r\n InflateRect(R, 1, 1);\r\n ThemeServices.DrawElement(Canvas.Handle, Details, R, @ClipRect);\r\n InflateRect(R, -1, -1);\r\n end\r\n else\r\n ThemeServices.DrawElement(Canvas.Handle, Details, R);\r\n\r\n { Determine text color }\r\n if FPressedPageBtn = I then\r\n ToolBar := ttbButtonPressed\r\n else\r\n if FHotPageBtn = I then\r\n ToolBar := ttbButtonHot\r\n else\r\n ToolBar := ttbButtonNormal;\r\n Details := ThemeServices.GetElementDetails(ToolBar);\r\n\r\n with Details do\r\n GetThemeColor(ThemeServices.Theme[Element], Part, State, TMT_TEXTCOLOR, LColor);\r\n Canvas.Font.Color := LColor;\r\n end\r\n else\r\n {$ENDIF JVCLThemesEnabled}\r\n begin\r\n Canvas.Brush.Color := PageBtnProps.Face;//clBtnFace;\r\n Canvas.FillRect(R);\r\n end;\r\n DrawPageButton(R, I, FPressedPageBtn = I);\r\n end;\r\n OffsetRect(R, 0, -PageButtonHeight);\r\n end;\r\nend;\r\n\r\nfunction TJvCustomOutlookBar.GetPageButtonAtPos(P: TPoint): TJvOutlookBarPage;\r\nvar\r\n I: Integer;\r\nbegin\r\n // TODO: rewrite more optimal (no loop)\r\n for I := 0 to Pages.Count - 1 do\r\n begin\r\n if PtInRect(GetPageButtonRect(I), P) then\r\n begin\r\n Result := Pages[I];\r\n Exit;\r\n end;\r\n end;\r\n Result := nil;\r\nend;\r\n\r\nfunction TJvCustomOutlookBar.GetPageButtonRect(Index: Integer): TRect;\r\nbegin\r\n Result := Rect(0, 0, 0, 0);\r\n if (Index < 0) or (Index >= Pages.Count) then\r\n Exit;\r\n Result := Rect(0, 0, ClientWidth, PageButtonHeight);\r\n if Index <= ActivePageIndex then\r\n OffsetRect(Result, 0, PageButtonHeight * Index)\r\n else\r\n OffsetRect(Result, 0, (ClientHeight - PageButtonHeight * (Pages.Count - Index)));\r\nend;\r\n\r\nfunction TJvCustomOutlookBar.GetPageTextRect(Index: Integer): TRect;\r\nbegin\r\n Result := GetPageButtonRect(Index);\r\n InflateRect(Result, -2, -2);\r\nend;\r\n\r\nfunction TJvCustomOutlookBar.GetPageRect(Index: Integer): TRect;\r\nbegin\r\n if (Index < 0) or (Index >= Pages.Count) then\r\n Result := Rect(0, 0, 0, 0)\r\n else\r\n Result := Rect(0, PageButtonHeight * Index + PageButtonHeight, ClientWidth, ClientHeight - (Pages.Count - Index) *\r\n PageButtonHeight + PageButtonHeight);\r\nend;\r\n\r\nfunction TJvCustomOutlookBar.GetButtonAtPos(P: TPoint): TJvOutlookBarButton;\r\nvar\r\n I, H: Integer;\r\n R, B: TRect;\r\nbegin\r\n // this always returns the button in the visible part of the active page (if any)\r\n Result := nil;\r\n if (ActivePageIndex < 0) or (ActivePageIndex >= Pages.Count) then\r\n Exit;\r\n B := GetButtonRect(ActivePageIndex, 0);\r\n H := GetButtonHeight(ActivePageIndex);\r\n R := GetPageRect(ActivePageIndex);\r\n for I := 0 to Pages[ActivePageIndex].Buttons.Count - 1 do\r\n begin\r\n if PtInRect(B, P) then\r\n begin\r\n Result := Pages[ActivePageIndex].Buttons[I];\r\n Exit;\r\n end;\r\n OffsetRect(B, 0, H);\r\n if B.Top >= R.Bottom then\r\n Break;\r\n end;\r\nend;\r\n\r\nfunction TJvCustomOutlookBar.GetButtonRect(PageIndex, ButtonIndex: Integer): TRect;\r\nvar\r\n H: Integer;\r\nbegin\r\n Result := Rect(0, 0, 0, 0);\r\n if (PageIndex < 0) or (PageIndex >= Pages.Count) or\r\n (ButtonIndex < 0) or (ButtonIndex >= Pages[PageIndex].Buttons.Count) then\r\n Exit;\r\n H := GetButtonHeight(PageIndex);\r\n case Pages[PageIndex].ButtonSize of\r\n olbsLarge:\r\n if LargeImages <> nil then\r\n begin\r\n Result := Rect(0, 0, Max(LargeImages.Width, Canvas.TextWidth(Pages[PageIndex].Buttons[ButtonIndex].Caption)) +\r\n 4, H);\r\n OffsetRect(Result, (ClientWidth - (Result.Right - Result.Left)) div 2, cButtonTopOffset);\r\n end\r\n else\r\n Result := Rect(0, 0, ClientWidth, cButtonTopOffset + H);\r\n olbsSmall:\r\n if SmallImages <> nil then\r\n begin\r\n Result := Rect(0, 0, SmallImages.Width + Canvas.TextWidth(Pages[PageIndex].Buttons[ButtonIndex].Caption) + 8,\r\n H);\r\n OffsetRect(Result, cButtonLeftOffset, cButtonTopOffset);\r\n end\r\n else\r\n Result := Rect(0, 0, ClientWidth, cButtonTopOffset + H);\r\n end;\r\n OffsetRect(Result, 0, (ButtonIndex - Pages[PageIndex].TopButtonIndex) * H + GetPageRect(PageIndex).Top);\r\nend;\r\n\r\nfunction TJvCustomOutlookBar.GetButtonFrameRect(PageIndex, ButtonIndex: Integer): TRect;\r\nvar\r\n H: Integer;\r\nbegin\r\n Result := Rect(0, 0, 0, 0);\r\n if (PageIndex < 0) or (PageIndex >= Pages.Count) or\r\n (ButtonIndex < 0) or (ButtonIndex >= Pages[PageIndex].Buttons.Count) then\r\n Exit;\r\n H := GetButtonHeight(PageIndex);\r\n case Pages[PageIndex].ButtonSize of\r\n olbsLarge:\r\n if LargeImages <> nil then\r\n begin\r\n Result := Rect(0, 0, LargeImages.Width + 6, LargeImages.Height + 6);\r\n OffsetRect(Result, (ClientWidth - (Result.Right - Result.Left)) div 2,\r\n cButtonTopOffset + (ButtonIndex - Pages[PageIndex].TopButtonIndex) * H + GetPageRect(PageIndex).Top + 1);\r\n end\r\n else\r\n begin\r\n Result := Rect(0, 0, ClientWidth, H);\r\n OffsetRect(Result, 0,\r\n cButtonTopOffset + (ButtonIndex - Pages[PageIndex].TopButtonIndex) * H + GetPageRect(PageIndex).Top + 1);\r\n end;\r\n olbsSmall:\r\n if SmallImages <> nil then\r\n begin\r\n Result := Rect(0, 0, SmallImages.Width + 4, SmallImages.Height + 4);\r\n OffsetRect(Result, cButtonLeftOffset, cButtonTopOffset + (ButtonIndex - Pages[PageIndex].TopButtonIndex) * H +\r\n GetPageRect(PageIndex).Top);\r\n end\r\n else\r\n begin\r\n Result := Rect(0, 0, ClientWidth, H);\r\n OffsetRect(Result, 0, cButtonTopOffset + (ButtonIndex - Pages[PageIndex].TopButtonIndex) * H +\r\n GetPageRect(PageIndex).Top);\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJvCustomOutlookBar.GetButtonTextRect(PageIndex,\r\n ButtonIndex: Integer): TRect;\r\nvar\r\n H: Integer;\r\nbegin\r\n Result := Rect(0, 0, 0, 0);\r\n if Pages[PageIndex].Buttons.Count <= ButtonIndex then\r\n Exit;\r\n Result := GetButtonRect(PageIndex, ButtonIndex);\r\n H := GetButtonHeight(PageIndex);\r\n case Pages[PageIndex].ButtonSize of\r\n olbsLarge:\r\n if LargeImages <> nil then\r\n begin\r\n Result.Top := Result.Bottom - Abs(Pages[PageIndex].Font.Height) - 2;\r\n OffsetRect(Result, 0, -4);\r\n end;\r\n olbsSmall:\r\n if SmallImages <> nil then\r\n begin\r\n Result.Left := SmallImages.Width + 10;\r\n Result.Top := Result.Top + (GetButtonHeight(PageIndex) - Abs(Pages[PageIndex].Font.Height)) div 2;\r\n Result.Bottom := Result.Top + Abs(Pages[PageIndex].Font.Height) + 2;\r\n Result.Right := Result.Left + Canvas.TextWidth(Pages[PageIndex].Buttons[ButtonIndex].Caption) + 4;\r\n OffsetRect(Result, 0, -(H - (Result.Bottom - Result.Top)) div 4);\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomOutlookBar.Paint;\r\nvar\r\n I: Integer;\r\n {$IFDEF JVCLThemesEnabled}\r\n Details: TThemedElementDetails;\r\n R, ClipRect: TRect;\r\n {$ENDIF JVCLThemesEnabled}\r\nbegin\r\n if csDestroying in ComponentState then\r\n Exit;\r\n Canvas.Font := Self.Font;\r\n Canvas.Brush.Color := Self.Color;\r\n if Pages.Count = 0 then // we only need to draw the background when there are no pages\r\n begin\r\n {$IFDEF JVCLThemesEnabled}\r\n if ThemedBackground and Themed then\r\n begin\r\n R := ClientRect;\r\n ClipRect := R;\r\n InflateRect(R, 1, 0);\r\n Details := ThemeServices.GetElementDetails(ttbButtonHot);\r\n ThemeServices.DrawElement(Canvas.Handle, Details, R, @ClipRect);\r\n end\r\n else\r\n {$ENDIF JVCLThemesEnabled}\r\n begin\r\n if DoDrawBackGround then\r\n Canvas.FillRect(ClientRect);\r\n end;\r\n end;\r\n\r\n if IsVista then { Warren Vista paint bug workaround }\r\n Canvas.FillRect(ClientRect);\r\n \r\n\r\n SetBkMode(Canvas.Handle, TRANSPARENT);\r\n I := DrawTopPages;\r\n if I >= 0 then\r\n DrawCurrentPage(I);\r\n DrawBottomPages(I + 1);\r\nend;\r\n\r\nfunction TJvCustomOutlookBar.DoPageChanging(Index: Integer): Boolean;\r\nbegin\r\n Result := True;\r\n if (Index > -1) and Assigned(FOnPageChanging) then\r\n FOnPageChanging(Self, Index, Result);\r\nend;\r\n\r\nprocedure TJvCustomOutlookBar.DoPageChange(Index: Integer);\r\nbegin\r\n if (Index > -1) and Assigned(FOnPageChange) then\r\n FOnPageChange(Self, Index);\r\nend;\r\n\r\nprocedure TJvCustomOutlookBar.DoButtonClick(Index: Integer);\r\nbegin\r\n if (Index > -1) then\r\n begin\r\n with ActivePage.Buttons[Index] do\r\n begin\r\n if AutoToggle then\r\n Down := not Down;\r\n Click;\r\n end;\r\n if Assigned(FOnButtonClick) then\r\n FOnButtonClick(Self, Index);\r\n\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomOutlookBar.SetActivePageIndex(const Value: Integer);\r\nbegin\r\n if (Value >= 0) and (Value < FPages.Count) then\r\n begin\r\n FPressedPageBtn := -1; // reset cache\r\n // remove old button info\r\n FLastButtonIndex := -1;\r\n FPressedButtonIndex := -1;\r\n FButtonRect := Rect(0, 0, 0, 0);\r\n if FActivePageIndex <> Value then\r\n begin\r\n if not DoPageChanging(Value) then\r\n Exit;\r\n FActivePageIndex := Value;\r\n DoPageChange(Value);\r\n end;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomOutlookBar.SetBorderStyle(const Value: TBorderStyle);\r\nbegin\r\n if FBorderStyle <> Value then\r\n begin\r\n FBorderStyle := Value;\r\n RecreateWnd;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomOutlookBar.SetButtonSize(const Value: TJvBarButtonSize);\r\nvar\r\n I: Integer;\r\nbegin\r\n FButtonSize := Value;\r\n Pages.BeginUpdate;\r\n try\r\n for I := 0 to Pages.Count - 1 do\r\n if Pages[I].ParentButtonSize then\r\n begin\r\n Pages[I].ParentButtonSize := False;\r\n Pages[I].ParentButtonSize := True; // reset flag\r\n end;\r\n finally\r\n Pages.EndUpdate; // calls invalidate\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomOutlookBar.SetDisabledFontColor1(const Value: TColor); {Warren add}\r\nbegin\r\n FDisabledFontColor1 := Value;\r\nend;\r\n\r\nprocedure TJvCustomOutlookBar.SetDisabledFontColor2(const Value: TColor); {Warren add}\r\nbegin\r\n FDisabledFontColor2 := Value;\r\nend;\r\n\r\nprocedure TJvCustomOutlookBar.SetLargeImages(const Value: TCustomImageList);\r\nbegin\r\n if ReplaceImageListReference(Self, Value, FLargeImages, FLargeChangeLink) then\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvCustomOutlookBar.SetPageButtonHeight(const Value: Integer);\r\nbegin\r\n if FPageButtonHeight <> Value then\r\n begin\r\n FPageButtonHeight := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomOutlookBar.SetPages(const Value: TJvOutlookBarPages);\r\nbegin\r\n FPages.Assign(Value); // Assign calls Invalidate\r\nend;\r\n\r\nprocedure TJvCustomOutlookBar.SetSmallImages(const Value: TCustomImageList);\r\nbegin\r\n if ReplaceImageListReference(Self, Value, FSmallImages, FSmallChangeLink) then\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvCustomOutlookBar.SetThemed(const Value: Boolean);\r\nbegin\r\n {$IFDEF JVCLThemesEnabled}\r\n if Value and (not ThemeServices.{$IFDEF RTL230_UP}Enabled{$ELSE}ThemesEnabled{$ENDIF RTL230_UP}) then { Warren added ability to theme/detheme this component for yourself instead of just checking if XP is themed.}\r\n exit;\r\n FThemed := Value;\r\n {$ELSE}\r\n FThemed := False;\r\n {$ENDIF JVCLThemesEnabled}\r\nend;\r\n\r\nprocedure TJvCustomOutlookBar.DrawButtonFrame(PageIndex, ButtonIndex, PressedIndex: Integer);\r\nvar\r\n R: TRect;\r\n {$IFDEF JVCLThemesEnabled}\r\n Details: TThemedElementDetails;\r\n {$ENDIF JVCLThemesEnabled}\r\nbegin\r\n if csDestroying in ComponentState then\r\n Exit;\r\n if (ButtonIndex < 0) or (PageIndex < 0) or (PageIndex >= Pages.Count) or\r\n (ButtonIndex < Pages[PageIndex].TopButtonIndex) then\r\n Exit;\r\n R := GetButtonFrameRect(PageIndex, ButtonIndex);\r\n if DoDrawButtonFrame(R, ButtonIndex, (PressedIndex = ButtonIndex) or Pages[PageIndex].Buttons[ButtonIndex].Down, True) then\r\n begin\r\n {$IFDEF JVCLThemesEnabled}\r\n if Themed then\r\n begin\r\n if (PressedIndex = ButtonIndex) or (Pages[PageIndex].Buttons[ButtonIndex].Down) then\r\n Details := ThemeServices.GetElementDetails(ttbButtonPressed)\r\n else\r\n Details := ThemeServices.GetElementDetails(ttbButtonHot);\r\n ThemeServices.DrawElement(Canvas.Handle, Details, R);\r\n end\r\n else\r\n {$ENDIF JVCLThemesEnabled}\r\n begin\r\n if (PressedIndex = ButtonIndex) or (Pages[PageIndex].Buttons[ButtonIndex].Down) then\r\n Frame3D(Canvas, R, clBlack, clWhite, 1)\r\n else\r\n Frame3D(Canvas, R, clWhite, clBlack, 1);\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomOutlookBar.MouseDown(Button: TMouseButton;\r\n Shift: TShiftState; X, Y: Integer);\r\nvar\r\n P: TJvOutlookBarPage;\r\n B: TJvOutlookBarButton;\r\nbegin\r\n inherited MouseDown(Button, Shift, X, Y);\r\n if Button = mbRight then\r\n Exit;\r\n P := GetPageButtonAtPos(Point(X, Y));\r\n if (P <> nil) and (P.Enabled) and (P.Index <> FNextActivePage) then\r\n begin\r\n FNextActivePage := P.Index;\r\n if FNextActivePage <> ActivePageIndex then\r\n begin // draw button pressed\r\n FPressedPageBtn := FNextActivePage;\r\n RedrawRect(GetPageButtonRect(FNextActivePage));\r\n end;\r\n Exit;\r\n end\r\n else\r\n begin\r\n if (FNextActivePage > -1) and Pages[FNextActivePage].Enabled then\r\n RedrawRect(GetPageButtonRect(FNextActivePage));\r\n FNextActivePage := -1;\r\n FPressedPageBtn := -1;\r\n end;\r\n B := GetButtonAtPos(Point(X, Y));\r\n if (B <> nil) and B.Enabled and (Pages[ActivePageIndex].Enabled) then\r\n begin\r\n FLastButtonIndex := B.Index;\r\n FPressedButtonIndex := B.Index;\r\n FButtonRect := GetButtonFrameRect(ActivePageIndex, B.Index);\r\n RedrawRect(FButtonRect);\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomOutlookBar.MouseMove(Shift: TShiftState; X, Y: Integer);\r\nvar\r\n P: TJvOutlookBarPage;\r\n B: TJvOutlookBarButton;\r\n R: TRect;\r\nbegin\r\n inherited MouseMove(Shift, X, Y);\r\n { TODO -oJv :\r\n 1. check whether the mouse is down on a page button and whether the mouse has moved from\r\n the currently pressed page button }\r\n P := GetPageButtonAtPos(Point(X, Y));\r\n {$IFDEF JVCLThemesEnabled}\r\n if Themed then\r\n begin\r\n if ((P = nil) and (FHotPageBtn >= 0)) or (Assigned(P) and (P.Index <> FHotPageBtn)) then\r\n begin\r\n if FHotPageBtn >= 0 then\r\n begin\r\n R := GetPageButtonRect(FHotPageBtn);\r\n RedrawRect(R);\r\n end;\r\n if Assigned(P) then\r\n FHotPageBtn := P.Index\r\n else\r\n FHotPageBtn := -1;\r\n if FHotPageBtn >= 0 then\r\n begin\r\n R := GetPageButtonRect(FHotPageBtn);\r\n RedrawRect(R);\r\n end;\r\n end;\r\n end;\r\n {$ENDIF JVCLThemesEnabled}\r\n\r\n if FPressedPageBtn > -1 then\r\n begin\r\n if (P = nil) or (P.Index <> FPressedPageBtn) then\r\n begin\r\n R := GetPageButtonRect(FPressedPageBtn);\r\n RedrawRect(R);\r\n FPressedPageBtn := -1;\r\n end;\r\n end\r\n else\r\n if (P <> nil) and (P.Index <> ActivePageIndex) and P.Enabled then\r\n begin\r\n if P.Index = FNextActivePage then\r\n begin\r\n FPressedPageBtn := FNextActivePage;\r\n RedrawRect(GetPageButtonRect(FPressedPageBtn));\r\n Exit;\r\n end;\r\n end;\r\n // TODO: check for button highlight\r\n B := GetButtonAtPos(Point(X, Y));\r\n if (B <> nil) and B.Enabled and (Pages[ActivePageIndex].Enabled) then\r\n begin\r\n if B.Index <> FLastButtonIndex then\r\n begin\r\n RedrawRect(FButtonRect, True);\r\n FButtonRect := GetButtonFrameRect(ActivePageIndex, B.Index);\r\n RedrawRect(FButtonRect);\r\n FLastButtonIndex := B.Index;\r\n end;\r\n end\r\n else\r\n begin\r\n if FLastButtonIndex > -1 then\r\n RedrawRect(FButtonRect);\r\n FLastButtonIndex := -1;\r\n FButtonRect := Rect(0, 0, 0, 0);\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomOutlookBar.MouseUp(Button: TMouseButton;\r\n Shift: TShiftState; X, Y: Integer);\r\nvar\r\n P: TJvOutlookBarPage;\r\n B: TJvOutlookBarButton;\r\nbegin\r\n inherited MouseUp(Button, Shift, X, Y);\r\n if Button = mbRight then\r\n Exit;\r\n if (FNextActivePage > -1) and (FNextActivePage <> ActivePageIndex) then\r\n begin\r\n P := GetPageButtonAtPos(Point(X, Y));\r\n if (P <> nil) and (P.Index = FNextActivePage) then\r\n ActivePageIndex := FNextActivePage;\r\n end;\r\n FNextActivePage := -1;\r\n\r\n B := GetButtonAtPos(Point(X, Y));\r\n if B <> nil then\r\n begin\r\n if B.Index = FPressedButtonIndex then\r\n DoButtonClick(FPressedButtonIndex);\r\n FLastButtonIndex := B.Index;\r\n FPressedButtonIndex := -1;\r\n FButtonRect := GetButtonFrameRect(ActivePageIndex, FLastButtonIndex);\r\n RedrawRect(FButtonRect);\r\n end\r\n else\r\n begin\r\n FButtonRect := GetButtonFrameRect(ActivePageIndex, FLastButtonIndex);\r\n FLastButtonIndex := -1;\r\n FPressedButtonIndex := -1;\r\n RedrawRect(FButtonRect);\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomOutlookBar.MouseEnter(Control: TControl);\r\nbegin\r\n if csDesigning in ComponentState then\r\n Exit;\r\n RedrawRect(FButtonRect);\r\n inherited MouseEnter(Control);\r\nend;\r\n\r\nprocedure TJvCustomOutlookBar.MouseLeave(Control: TControl);\r\n{$IFDEF JVCLThemesEnabled}\r\nvar\r\n R: TRect;\r\n{$ENDIF JVCLThemesEnabled}\r\nbegin\r\n if csDesigning in ComponentState then\r\n Exit;\r\n inherited MouseLeave(Control);\r\n RedrawRect(FButtonRect);\r\n FPressedPageBtn := -1;\r\n FLastButtonIndex := -1;\r\n {$IFDEF JVCLThemesEnabled}\r\n if Themed and (FHotPageBtn >= 0) then\r\n begin\r\n R := GetPageButtonRect(FHotPageBtn);\r\n RedrawRect(R);\r\n FHotPageBtn := -1;\r\n end;\r\n {$ENDIF JVCLThemesEnabled}\r\nend;\r\n\r\nfunction TJvCustomOutlookBar.GetButtonHeight(PageIndex: Integer): Integer;\r\nconst\r\n cLargeOffset = 8;\r\n cSmallOffset = 4;\r\nvar\r\n TM: TTextMetric;\r\nbegin\r\n GetTextMetrics(Canvas.Handle, TM);\r\n Result := TM.tmHeight + TM.tmExternalLeading;\r\n if (PageIndex >= 0) and (PageIndex < Pages.Count) then\r\n begin\r\n case Pages[PageIndex].ButtonSize of\r\n olbsLarge:\r\n if LargeImages <> nil then\r\n Result := Max(Result, LargeImages.Height + Abs(Pages[PageIndex].Font.Height) + cLargeOffset)\r\n else\r\n Result := Abs(Pages[PageIndex].Font.Height) + cLargeOffset;\r\n olbsSmall:\r\n if SmallImages <> nil then\r\n Result := Max(SmallImages.Height, Abs(Pages[PageIndex].Font.Height)) + cSmallOffset\r\n else\r\n Result := Abs(Pages[PageIndex].Font.Height) + cSmallOffset;\r\n end;\r\n end;\r\n Inc(Result, 4);\r\nend;\r\n\r\nfunction TJvCustomOutlookBar.DoEraseBackground(Canvas: TCanvas; Param: LPARAM): Boolean;\r\nbegin\r\n // don't redraw background: we always fill it anyway\r\n Result := True;\r\nend;\r\n\r\nprocedure TJvCustomOutlookBar.RedrawRect(R: TRect; Erase: Boolean = False);\r\nbegin\r\n Windows.InvalidateRect(Handle, @R, Erase);\r\nend;\r\n\r\nprocedure TJvCustomOutlookBar.CMCaptionEditing(var Msg: TMessage);\r\nvar\r\n R: TRect;\r\n B: TJvOutlookBarButton;\r\n P: TJvOutlookBarPage;\r\nbegin\r\n TJvOutlookBarEdit(FEdit).Tag := NativeInt(Msg.WParam);\r\n// TJvOutlookBarEdit(FEdit).Font.Name := Pages[ActivePageIndex].Font.Name;\r\n// TJvOutlookBarEdit(FEdit).Font.Size := Pages[ActivePageIndex].Font.Size;\r\n case Msg.LParam of\r\n 0: // button\r\n begin\r\n B := TJvOutlookBarButton(Msg.WParam);\r\n R := GetButtonTextRect(ActivePageIndex, B.Index);\r\n R.Left := Max(R.Left, 0);\r\n R.Right := Min(R.Right, ClientWidth);\r\n TJvOutlookBarEdit(FEdit).ShowEdit(B.Caption, R);\r\n end;\r\n 1: // page\r\n begin\r\n P := TJvOutlookBarPage(Msg.WParam);\r\n R := GetPageTextRect(P.Index);\r\n TJvOutlookBarEdit(FEdit).ShowEdit(P.Caption, R);\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomOutlookBar.DoContextPopup( MousePos: TPoint;\r\n var Handled: Boolean);\r\nvar\r\n P: TPersistent;\r\nbegin\r\n P := GetPageButtonAtPos(MousePos);\r\n if Assigned(P) then\r\n PopUpObject := P\r\n else\r\n begin\r\n P := GetButtonAtPos(MousePos);\r\n if Assigned(P) then\r\n PopUpObject := P;\r\n end;\r\n if P = nil then\r\n PopUpObject := Self;\r\n inherited DoContextPopup(MousePos, Handled);\r\nend;\r\n\r\nprocedure TJvCustomOutlookBar.DoButtonEdit(NewText: string; B: TJvOutlookBarButton);\r\nvar\r\n Allow: Boolean;\r\nbegin\r\n Allow := True;\r\n if Assigned(FOnEditButton) then\r\n FOnEditButton(Self, NewText, B.Index, Allow);\r\n if Allow then\r\n B.Caption := NewText;\r\nend;\r\n\r\nprocedure TJvCustomOutlookBar.DoPageEdit(NewText: string; P: TJvOutlookBarPage);\r\nvar\r\n Allow: Boolean;\r\nbegin\r\n Allow := True;\r\n if Assigned(FOnEditPage) then\r\n FOnEditPage(Self, NewText, P.Index, Allow);\r\n if Allow then\r\n P.Caption := NewText;\r\nend;\r\n\r\nprocedure TJvCustomOutlookBar.CMCaptionEditAccept(var Msg: TMessage);\r\nbegin\r\n with Msg do\r\n begin\r\n if TObject(LParam) is TJvOutlookBarButton then\r\n DoButtonEdit(TJvOutlookBarEdit(WParam).Text, TJvOutlookBarButton(LParam))\r\n else\r\n if TObject(LParam) is TJvOutlookBarPage then\r\n DoPageEdit(TJvOutlookBarEdit(WParam).Text, TJvOutlookBarPage(LParam));\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomOutlookBar.CMCaptionEditCancel(var Msg: TMessage);\r\nbegin\r\n{ with Msg do\r\n begin\r\n if TObject(LParam) is TJvOutlookBarButton then\r\n DoButtonEditCancel(TJvOutlookBarButton(LParam))\r\n else TObject(LParam) is TJvOutlookBarPage then\r\n DoPageEditCancel(TJvOutlookBarPage(LParam));\r\n end;\r\n }\r\nend;\r\n\r\nfunction TJvCustomOutlookBar.GetActivePage: TJvOutlookBarPage;\r\nbegin\r\n if (ActivePageIndex > -1) and (ActivePageIndex < Pages.Count) then\r\n Result := Pages[ActivePageIndex]\r\n else\r\n Result := nil;\r\nend;\r\n\r\nfunction TJvCustomOutlookBar.GetActivePageIndex: Integer;\r\nbegin\r\n if (FActivePageIndex < 0) or (FActivePageIndex >= FPages.Count) then\r\n FActivePageIndex := 0;\r\n Result := FActivePageIndex;\r\nend;\r\n\r\n{$IFDEF JVCLThemesEnabled}\r\nprocedure TJvCustomOutlookBar.SetThemedBackground(const Value: Boolean);\r\nbegin\r\n if Value <> FThemedBackGround then\r\n begin\r\n FThemedBackGround := Value;\r\n if ([csDesigning, csLoading] * ComponentState = []) and Themed then\r\n Repaint;\r\n end;\r\nend;\r\n{$ENDIF JVCLThemesEnabled}\r\n\r\nprocedure TJvCustomOutlookBar.ColorChanged;\r\nvar\r\n I: Integer;\r\nbegin\r\n inherited ColorChanged;\r\n for I := 0 to Pages.Count - 1 do\r\n if Pages[I].ParentColor then\r\n begin\r\n Pages[I].ParentColor := False;\r\n Pages[I].ParentColor := True; // reset flag\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomOutlookBar.FontChanged;\r\nvar\r\n I: Integer;\r\nbegin\r\n inherited FontChanged;\r\n for I := 0 to Pages.Count - 1 do\r\n if Pages[I].ParentFont then\r\n begin //set the font of the buttons as well\r\n Pages[I].ParentFont := False;\r\n Pages[I].Font := Self.Font;\r\n Pages[I].ParentFont := True; // reset flag\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomOutlookBar.CMDialogChar(var Msg: TCMDialogChar);\r\nvar\r\n I: Integer;\r\nbegin\r\n if CanFocus then\r\n begin\r\n // first check the buttons on the active page, then check the pages\r\n if (ActivePage <> nil) and (ActivePage.Enabled) then\r\n begin\r\n for I := 0 to ActivePage.Buttons.Count - 1 do\r\n if ActivePage.Buttons[I].Enabled and IsAccel(Msg.CharCode, ActivePage.Buttons[I].Caption) then\r\n begin\r\n Msg.Result := 1;\r\n DoButtonClick(I);\r\n Exit;\r\n end;\r\n end;\r\n\r\n for I := 0 to Pages.Count - 1 do\r\n if Pages[I].Enabled and IsAccel(Msg.CharCode, Pages[I].Caption) then\r\n begin\r\n Msg.Result := 1;\r\n ActivePageIndex := I;\r\n Exit;\r\n end;\r\n end;\r\n inherited;\r\nend;\r\n\r\nfunction TJvCustomOutlookBar.DoCustomDraw(ARect: TRect; Stage: TJvOutlookBarCustomDrawStage;\r\n Index: Integer; Down, Inside: Boolean): Boolean;\r\nbegin\r\n Result := True;\r\n if Assigned(FOnCustomDraw) then\r\n FOnCustomDraw(Self, Canvas, ARect, Stage, Index, Down, Inside, Result);\r\nend;\r\n\r\nfunction TJvCustomOutlookBar.DoDrawBackGround: Boolean;\r\nbegin\r\n Result := DoCustomDraw(ClientRect, odsBackground, -1, False, False);\r\nend;\r\n\r\nfunction TJvCustomOutlookBar.DoDrawButton(ARect: TRect; Index: Integer; Down, Inside: Boolean): Boolean;\r\nbegin\r\n Result := DoCustomDraw(ARect, odsButton, Index, Down, Inside);\r\nend;\r\n\r\nfunction TJvCustomOutlookBar.DoDrawButtonFrame(ARect: TRect; Index: Integer;\r\n Down, Inside: Boolean): Boolean;\r\nbegin\r\n Result := DoCustomDraw(ARect, odsButtonFrame, Index, Down, Inside);\r\nend;\r\n\r\nfunction TJvCustomOutlookBar.DoDrawPage(ARect: TRect; Index: Integer): Boolean;\r\nbegin\r\n Result := DoCustomDraw(ARect, odsPage, Index, False, Index = ActivePageIndex);\r\nend;\r\n\r\nfunction TJvCustomOutlookBar.DoDrawPageButton(ARect: TRect; Index: Integer; Down: Boolean): Boolean;\r\nbegin\r\n Result := DoCustomDraw(ARect, odsPageButton, Index, Down, Index = ActivePageIndex);\r\nend;\r\n\r\nprocedure TJvOutlookBarPage.DoPictureChange(Sender: TObject);\r\nbegin\r\n Change;\r\nend;\r\n\r\nprocedure TJvCustomOutlookBar.SetPageImages(const Value: TCustomImageList);\r\nbegin\r\n if ReplaceImageListReference(Self, Value, FPageImages, FPageChangeLink) then\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvCustomOutlookBar.InitiateAction;\r\nvar\r\n I, J: Integer;\r\nbegin\r\n inherited InitiateAction;\r\n for I := 0 to Pages.Count - 1 do\r\n for J := 0 to Pages[I].Buttons.Count - 1 do\r\n Pages[I].Buttons[J].ActionChange(Pages[I].Buttons[J].Action, csLoading in ComponentState);\r\nend;\r\n\r\n//---- Warren added page button properties Nov 2008\r\n\r\nconstructor TJvPageBtnProps.Create(owner: TJvCustomOUtlookBar);\r\nbegin\r\n Fowner := owner;\r\n FShadow := clBtnShadow;\r\n FHighlight := clBtnHighlight;\r\n FDkShadow := cl3DDkShadow;\r\n FFace := clBtnFace;\r\n\r\n FBorderWidth := 1;\r\nend;\r\n\r\nprocedure TJvPageBtnProps.SetBorderWidth(const Value: INteger);\r\nbegin\r\n FBorderWidth := Value;\r\nend;\r\n\r\nprocedure TJvPageBtnProps.SetDkShadow(const Value: TColor);\r\nbegin\r\n FDkShadow := Value;\r\nend;\r\n\r\nprocedure TJvPageBtnProps.SetFace(const Value: TColor);\r\nbegin\r\n FFace := Value;\r\nend;\r\n\r\nprocedure TJvPageBtnProps.SetHighlight(const Value: TColor);\r\nbegin\r\n FHighlight := Value;\r\nend;\r\n\r\nprocedure TJvPageBtnProps.SetShadow(const Value: TColor);\r\nbegin\r\n FShadow := Value;\r\nend;\r\n\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvOwnerDrawViewer.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvOwnerDrawViewer.PAS, released on 2003-12-01.\r\n\r\nThe Initial Developer of the Original Code is: Peter Thrnqvist\r\nAll Rights Reserved.\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvOwnerDrawViewer.pas 13138 2011-10-26 23:17:50Z jfudickar $\r\n\r\nunit JvOwnerDrawViewer;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Classes, Graphics,\r\n JvCustomItemViewer;\r\n\r\ntype\r\n TJvOwnerDrawViewerOptions = class(TJvCustomItemViewerOptions)\r\n published\r\n property Alignment;\r\n property AutoCenter;\r\n property BrushPattern;\r\n property DragAutoScroll;\r\n property Height;\r\n property HorzSpacing;\r\n property HotTrack;\r\n property Layout;\r\n property LazyRead;\r\n property MultiSelect;\r\n property RightClickSelect;\r\n property ScrollBar;\r\n property ShowCaptions;\r\n property Smooth;\r\n property Tracking;\r\n property VertSpacing;\r\n property Width;\r\n end;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvOwnerDrawViewer = class(TJvCustomItemViewer)\r\n private\r\n function GetOptions: TJvOwnerDrawViewerOptions;\r\n procedure SetOptions(const Value: TJvOwnerDrawViewerOptions);\r\n protected\r\n function GetOptionsClass: TJvItemViewerOptionsClass; override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n property Count;\r\n property Items;\r\n published\r\n property Options: TJvOwnerDrawViewerOptions read GetOptions write SetOptions;\r\n property SelectedIndex;\r\n property OnDrawItem;\r\n property OnOptionsChanged;\r\n property OnItemChanging;\r\n property OnItemChanged;\r\n property OnItemHint;\r\n\r\n property Align;\r\n property Anchors;\r\n // property BiDiMode;\r\n property Color;\r\n property Constraints;\r\n property DockSite;\r\n property DragCursor;\r\n property DragKind;\r\n property DragMode;\r\n property Enabled;\r\n property Font;\r\n // property ParentBiDiMode;\r\n property ParentColor;\r\n property ParentFont;\r\n property ParentShowHint;\r\n property PopupMenu;\r\n property ShowHint;\r\n property TabOrder;\r\n property TabStop;\r\n property Visible;\r\n property OnClick;\r\n property OnContextPopup;\r\n property OnDblClick;\r\n property OnDragDrop;\r\n property OnDockDrop;\r\n property OnDockOver;\r\n property OnDragOver;\r\n property OnEndDock;\r\n property OnEndDrag;\r\n property OnEnter;\r\n property OnExit;\r\n property OnGetSiteInfo;\r\n property OnMouseDown;\r\n property OnMouseMove;\r\n property OnMouseUp;\r\n property OnKeyDown;\r\n property OnKeyUp;\r\n property OnKeyPress;\r\n property OnStartDock;\r\n property OnStartDrag;\r\n property OnUnDock;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvOwnerDrawViewer.pas $';\r\n Revision: '$Revision: 13138 $';\r\n Date: '$Date: 2011-10-27 01:17:50 +0200 (jeu. 27 oct. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\n\r\nconstructor TJvOwnerDrawViewer.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n Color := clWindow;\r\nend;\r\n\r\nfunction TJvOwnerDrawViewer.GetOptions: TJvOwnerDrawViewerOptions;\r\nbegin\r\n Result := TJvOwnerDrawViewerOptions(inherited Options);\r\nend;\r\n\r\nfunction TJvOwnerDrawViewer.GetOptionsClass: TJvItemViewerOptionsClass;\r\nbegin\r\n Result := TJvOwnerDrawViewerOptions;\r\nend;\r\n\r\nprocedure TJvOwnerDrawViewer.SetOptions(const Value: TJvOwnerDrawViewerOptions);\r\nbegin\r\n inherited Options := Value;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvPageList.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvPageList.PAS, released on 2003-04-25.\r\n\r\nThe Initial Developer of the Original Code is Peter Thrnqvist [peter3 at sourceforge dot net] .\r\nPortions created by Peter Thrnqvist are Copyright (C) 2004 Peter Thrnqvist.\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvPageList.pas 13138 2011-10-26 23:17:50Z jfudickar $\r\n\r\nunit JvPageList;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, Messages, SysUtils, Classes, Graphics, Controls,\r\n {$IFDEF COMPILER9_UP}\r\n Types,\r\n {$ENDIF COMPILER9_UP}\r\n JvComponent, JvThemes;\r\n\r\ntype\r\n EPageListError = class(Exception);\r\n\r\n IPageList = interface\r\n ['{6BB90183-CFB1-4431-9CFD-E9A032E0C94C}']\r\n function CanChange(AIndex: Integer): Boolean;\r\n procedure SetActivePageIndex(AIndex: Integer);\r\n function GetPageCount: Integer;\r\n function GetPageCaption(AIndex: Integer): string;\r\n procedure AddPage(const ACaption: string);\r\n procedure DeletePage(Index: Integer);\r\n procedure MovePage(CurIndex, NewIndex: Integer);\r\n procedure PageCaptionChanged(Index: Integer; const NewCaption: string);\r\n end;\r\n\r\n TJvCustomPageList = class;\r\n\r\n TJvPagePaintEvent = procedure(Sender: TObject; ACanvas: TCanvas; ARect: TRect) of object;\r\n TJvPageCanPaintEvent = procedure(Sender: TObject; ACanvas: TCanvas; ARect: TRect; var DefaultDraw: Boolean) of object;\r\n\r\n { TJvCustomPage is the base class for pages in a TJvPageList and implements the basic behaviour of such\r\n a control. It has support for accepting components, propagating it's Enabled state, changing it's order in the\r\n page list and custom painting }\r\n TJvCustomPage = class(TJvCustomControl)\r\n private\r\n FPageList: TJvCustomPageList;\r\n FPageIndex: Integer;\r\n FOnBeforePaint: TJvPageCanPaintEvent;\r\n FOnPaint: TJvPagePaintEvent;\r\n FOnAfterPaint: TJvPagePaintEvent;\r\n FOnHide: TNotifyEvent;\r\n FOnShow: TNotifyEvent;\r\n FData: TObject;\r\n protected\r\n procedure CreateParams(var Params: TCreateParams); override;\r\n function DoEraseBackground(Canvas: TCanvas; Param: LPARAM): Boolean; override;\r\n procedure SetPageIndex(Value: Integer);virtual;\r\n function GetPageIndex: Integer;virtual;\r\n procedure SetPageList(Value: TJvCustomPageList);virtual;\r\n procedure TextChanged; override;\r\n procedure ShowingChanged; override;\r\n procedure Paint; override;\r\n procedure ReadState(Reader: TReader); override;\r\n function DoBeforePaint(ACanvas: TCanvas; ARect: TRect): Boolean; dynamic;\r\n procedure DoAfterPaint(ACanvas: TCanvas; ARect: TRect); dynamic;\r\n procedure DoPaint(ACanvas: TCanvas; ARect: TRect); virtual;\r\n procedure DoShow; virtual;\r\n procedure DoHide; virtual;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n property PageList: TJvCustomPageList read FPageList write SetPageList;\r\n protected\r\n property Left stored False;\r\n property Top stored False;\r\n property Width stored False;\r\n property Height stored False;\r\n property OnHide: TNotifyEvent read FOnHide write FOnHide;\r\n property OnShow: TNotifyEvent read FOnShow write FOnShow;\r\n property OnBeforePaint: TJvPageCanPaintEvent read FOnBeforePaint write FOnBeforePaint;\r\n property OnPaint: TJvPagePaintEvent read FOnPaint write FOnPaint;\r\n property OnAfterPaint: TJvPagePaintEvent read FOnAfterPaint write FOnAfterPaint;\r\n public\r\n property Data: TObject read FData write FData;\r\n property PageIndex: Integer read GetPageIndex write SetPageIndex stored False;\r\n end;\r\n\r\n TJvCustomPageClass = class of TJvCustomPage;\r\n TJvPageChangingEvent = procedure(Sender: TObject; PageIndex: Integer; var AllowChange: Boolean) of object;\r\n\r\n {\r\n TJvCustomPageList is a base class for components that implements the IPageList interface.\r\n It works like TPageControl but does not have any tabs\r\n }\r\n TJvShowDesignCaption = (\r\n sdcNone, sdcTopLeft, sdcTopCenter, sdcTopRight, sdcLeftCenter, sdcCenter,\r\n sdcRightCenter, sdcBottomLeft, sdcBottomCenter, sdcBottomRight, sdcRunTime\r\n );\r\n\r\n TJvCustomPageList = class(TJvCustomControl, IUnknown, IPageList)\r\n private\r\n FPages: TList;\r\n FActivePage: TJvCustomPage;\r\n FPropagateEnable: Boolean;\r\n FOnChange: TNotifyEvent;\r\n FOnChanging: TJvPageChangingEvent;\r\n FShowDesignCaption: TJvShowDesignCaption;\r\n FHiddenPages: TList;\r\n procedure CMDesignHitTest(var Msg: TCMDesignHitTest); message CM_DESIGNHITTEST;\r\n procedure UpdateEnabled;\r\n procedure SetPropagateEnable(const Value: Boolean);\r\n procedure SetShowDesignCaption(const Value: TJvShowDesignCaption);\r\n function GetPage(Index: Integer): TJvCustomPage;\r\n protected\r\n procedure EnabledChanged; override;\r\n { IPageList }\r\n procedure AddPage(const ACaption: string);\r\n procedure DeletePage(Index: Integer);\r\n procedure MovePage(CurIndex, NewIndex: Integer);\r\n function CanChange(AIndex: Integer): Boolean; virtual;\r\n function GetActivePageIndex: Integer; virtual;\r\n procedure SetActivePageIndex(AIndex: Integer); virtual;\r\n function GetPageFromIndex(AIndex: Integer): TJvCustomPage; virtual;\r\n function GetPageCount: Integer; virtual;\r\n function GetPageCaption(AIndex: Integer): string; virtual;\r\n procedure Paint; override;\r\n procedure PageCaptionChanged(Index: Integer; const NewCaption: string); virtual;\r\n\r\n procedure Change; dynamic;\r\n procedure Loaded; override;\r\n procedure ShowControl(AControl: TControl); override;\r\n function InternalGetPageClass: TJvCustomPageClass; virtual;\r\n\r\n procedure SetActivePage(Page: TJvCustomPage); virtual;\r\n procedure InsertPage(APage: TJvCustomPage); virtual;\r\n procedure RemovePage(APage: TJvCustomPage); virtual;\r\n property PageList: TList read FPages;\r\n property HiddenPageList: TList read FHiddenPages;\r\n property PropagateEnable: Boolean read FPropagateEnable write SetPropagateEnable;\r\n property ShowDesignCaption: TJvShowDesignCaption read FShowDesignCaption write SetShowDesignCaption default sdcCenter;\r\n\r\n property OnChange: TNotifyEvent read FOnChange write FOnChange;\r\n property OnChanging: TJvPageChangingEvent read FOnChanging write FOnChanging;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n\r\n procedure GetChildren(Proc: TGetChildProc; Root: TComponent); override; // public in D2009\r\n function FindNextPage(CurPage: TJvCustomPage; GoForward: Boolean; IncludeDisabled: Boolean): TJvCustomPage;\r\n procedure PrevPage;\r\n procedure NextPage;\r\n function HidePage(Page: TJvCustomPage): TJvCustomPage; virtual;\r\n function ShowPage(Page: TJvCustomPage; PageIndex: Integer = -1): TJvCustomPage; virtual;\r\n function GetPageClass: TJvCustomPageClass;\r\n function GetVisiblePageCount: Integer;\r\n property Height default 200;\r\n property Width default 300;\r\n\r\n property ActivePageIndex: Integer read GetActivePageIndex write SetActivePageIndex;\r\n property ActivePage: TJvCustomPage read FActivePage write SetActivePage;\r\n property Pages[Index: Integer]: TJvCustomPage read GetPage; default;\r\n property PageCount: Integer read GetPageCount;\r\n end;\r\n\r\n TJvStandardPage = class(TJvCustomPage)\r\n published\r\n property BorderWidth;\r\n property Caption;\r\n property Color;\r\n property DragMode;\r\n property Enabled;\r\n property Font;\r\n property Constraints;\r\n property ParentFont;\r\n property ParentShowHint;\r\n property PopupMenu;\r\n property ShowHint;\r\n property PageIndex;\r\n\r\n property OnContextPopup;\r\n property OnDragDrop;\r\n property OnDragOver;\r\n property OnEndDrag;\r\n property OnEnter;\r\n property OnExit;\r\n property OnHide;\r\n property OnMouseDown;\r\n property OnMouseMove;\r\n property OnMouseUp;\r\n property OnResize;\r\n property OnShow;\r\n property OnStartDrag;\r\n\r\n property OnBeforePaint;\r\n property OnPaint;\r\n property OnAfterPaint;\r\n property OnMouseEnter;\r\n property OnMouseLeave;\r\n property OnParentColorChange;\r\n {$IFDEF JVCLThemesEnabled}\r\n property ParentBackground default False;\r\n {$ENDIF JVCLThemesEnabled}\r\n end;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvPageList = class(TJvCustomPageList)\r\n protected\r\n function InternalGetPageClass: TJvCustomPageClass; override;\r\n public\r\n property PageCount;\r\n published\r\n property ActivePage;\r\n property PropagateEnable;\r\n property ShowDesignCaption;\r\n\r\n property Action;\r\n property Align;\r\n property Anchors;\r\n property BiDiMode;\r\n property BorderWidth;\r\n property DragCursor;\r\n property DragKind;\r\n property OnStartDock;\r\n property OnUnDock;\r\n property OnEndDock;\r\n property OnCanResize;\r\n property OnDockDrop;\r\n property OnDockOver;\r\n property OnGetSiteInfo;\r\n property Constraints;\r\n property DragMode;\r\n property Enabled;\r\n property PopupMenu;\r\n property ShowHint;\r\n property Visible;\r\n\r\n property OnMouseEnter;\r\n property OnMouseLeave;\r\n property OnParentColorChange;\r\n\r\n property OnChange;\r\n property OnChanging;\r\n property OnConstrainedResize;\r\n property OnContextPopup;\r\n property OnDblClick;\r\n property OnDragDrop;\r\n property OnDragOver;\r\n property OnEndDrag;\r\n property OnEnter;\r\n property OnExit;\r\n property OnMouseDown;\r\n property OnMouseMove;\r\n property OnMouseUp;\r\n property OnMouseWheel;\r\n property OnMouseWheelDown;\r\n property OnMouseWheelUp;\r\n property OnResize;\r\n property OnStartDrag;\r\n {$IFDEF JVCLThemesEnabled}\r\n property ParentBackground default False;\r\n {$ENDIF JVCLThemesEnabled}\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvPageList.pas $';\r\n Revision: '$Revision: 13138 $';\r\n Date: '$Date: 2011-10-27 01:17:50 +0200 (jeu. 27 oct. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n Forms;\r\n\r\nfunction GetUniqueName(AOwner: TComponent; const AClassName: string): string;\r\nvar\r\n I: Integer;\r\nbegin\r\n I := 0;\r\n if AOwner = nil then\r\n begin\r\n repeat\r\n Inc(I);\r\n Result := AClassName + IntToStr(I);\r\n until FindGlobalComponent(Result) = nil;\r\n end\r\n else\r\n repeat\r\n Inc(I);\r\n Result := AClassName + IntToStr(I);\r\n until AOwner.FindComponent(Result) = nil;\r\nend;\r\n\r\n//=== { TJvCustomPage } ======================================================\r\n\r\nconstructor TJvCustomPage.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FPageIndex := -1;\r\n Align := alClient;\r\n ControlStyle := ControlStyle + [csOpaque, csAcceptsControls, csNoDesignVisible];\r\n// IncludeThemeStyle(Self, [csParentBackground]);\r\n Visible := False;\r\n DoubleBuffered := True;\r\nend;\r\n\r\ndestructor TJvCustomPage.Destroy;\r\nbegin\r\n PageList := nil;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvCustomPage.CreateParams(var Params: TCreateParams);\r\nbegin\r\n inherited CreateParams(Params);\r\n with Params.WindowClass do\r\n Style := Style and not (CS_HREDRAW or CS_VREDRAW);\r\nend;\r\n\r\nprocedure TJvCustomPage.DoAfterPaint(ACanvas: TCanvas; ARect: TRect);\r\nbegin\r\n if Assigned(FOnAfterPaint) then\r\n FOnAfterPaint(Self, ACanvas, ARect);\r\nend;\r\n\r\nfunction TJvCustomPage.DoBeforePaint(ACanvas: TCanvas; ARect: TRect): Boolean;\r\nbegin\r\n Result := True;\r\n if Assigned(FOnBeforePaint) then\r\n FOnBeforePaint(Self, ACanvas, ARect, Result);\r\nend;\r\n\r\nfunction GetDesignCaptionFlags(Value: TJvShowDesignCaption): Cardinal;\r\nbegin\r\n case Value of\r\n sdcTopLeft:\r\n Result := DT_TOP or DT_LEFT;\r\n sdcTopCenter:\r\n Result := DT_TOP or DT_CENTER;\r\n sdcTopRight:\r\n Result := DT_TOP or DT_RIGHT;\r\n sdcLeftCenter:\r\n Result := DT_VCENTER or DT_LEFT;\r\n sdcCenter:\r\n Result := DT_VCENTER or DT_CENTER;\r\n sdcRightCenter:\r\n Result := DT_VCENTER or DT_RIGHT;\r\n sdcBottomLeft:\r\n Result := DT_BOTTOM or DT_LEFT;\r\n sdcBottomCenter:\r\n Result := DT_BOTTOM or DT_CENTER;\r\n sdcBottomRight:\r\n Result := DT_BOTTOM or DT_RIGHT;\r\n else\r\n Result := 0;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomPage.DoPaint(ACanvas: TCanvas; ARect: TRect);\r\nvar\r\n S: string;\r\nbegin\r\n with ACanvas do\r\n begin\r\n Font := Self.Font;\r\n Brush.Style := bsSolid;\r\n Brush.Color := Self.Color;\r\n DrawThemedBackground(Self, Canvas, ARect);\r\n if (csDesigning in ComponentState) then\r\n begin\r\n Pen.Style := psDot;\r\n Pen.Color := clBlack;\r\n Brush.Style := bsClear;\r\n Rectangle(ARect);\r\n Brush.Style := bsSolid;\r\n Brush.Color := Color;\r\n if (PageList <> nil) and (PageList.ShowDesignCaption <> sdcNone) then\r\n begin\r\n S := Caption;\r\n if S = '' then\r\n S := Name;\r\n // make some space around the edges\r\n InflateRect(ARect, -4, -4);\r\n if not Enabled then\r\n begin\r\n SetBkMode(Handle, Windows.TRANSPARENT);\r\n Canvas.Font.Color := clHighlightText;\r\n DrawText(Handle, PChar(S), Length(S), ARect, GetDesignCaptionFlags(PageList.ShowDesignCaption) or DT_SINGLELINE);\r\n OffsetRect(ARect, -1, -1);\r\n Canvas.Font.Color := clGrayText;\r\n end;\r\n DrawText(Handle, PChar(S), Length(S), ARect, GetDesignCaptionFlags(PageList.ShowDesignCaption) or DT_SINGLELINE);\r\n InflateRect(ARect, 4, 4);\r\n end;\r\n end;\r\n end;\r\n if Assigned(FOnPaint) then\r\n FOnPaint(Self, ACanvas, ARect);\r\nend;\r\n\r\nfunction TJvCustomPage.GetPageIndex: Integer;\r\nbegin\r\n if Assigned(FPageList) then\r\n Result := FPageList.PageList.IndexOf(Self)\r\n else\r\n Result := FPageIndex;\r\nend;\r\n\r\nprocedure TJvCustomPage.Paint;\r\nvar\r\n R: TRect;\r\nbegin\r\n R := ClientRect;\r\n if DoBeforePaint(Canvas, R) then\r\n DoPaint(Canvas, R);\r\n DoAfterPaint(Canvas, R);\r\nend;\r\n\r\nprocedure TJvCustomPage.ReadState(Reader: TReader);\r\nbegin\r\n if Reader.Parent is TJvCustomPageList then\r\n PageList := TJvCustomPageList(Reader.Parent);\r\n inherited ReadState(Reader);\r\nend;\r\n\r\nprocedure TJvCustomPage.SetPageList(Value: TJvCustomPageList);\r\nbegin\r\n if FPageList <> Value then\r\n begin\r\n if Assigned(FPageList) then\r\n FPageList.RemovePage(Self);\r\n FPageList := Value;\r\n Parent := FPageList;\r\n if FPageList <> nil then\r\n FPageList.InsertPage(Self);\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomPage.SetPageIndex(Value: Integer);\r\nvar\r\n OldIndex: Integer;\r\nbegin\r\n if (Value <> PageIndex) then\r\n begin\r\n OldIndex := PageIndex;\r\n if Assigned(FPageList) and (Value >= 0) and (Value < FPageList.PageCount) then\r\n FPageList.PageList.Move(OldIndex, Value);\r\n FPageIndex := Value;\r\n end;\r\nend;\r\n\r\nfunction TJvCustomPage.DoEraseBackground(Canvas: TCanvas; Param: LPARAM): Boolean;\r\nbegin\r\n if DoubleBuffered then\r\n Result := inherited DoEraseBackground(Canvas, Param)\r\n else\r\n begin\r\n {$IFDEF JVCLThemesEnabled}\r\n if ThemeServices.{$IFDEF RTL230_UP}Enabled{$ELSE}ThemesEnabled{$ENDIF RTL230_UP} then\r\n DrawThemedBackground(Self, Canvas, ClientRect, Color, ParentBackground);\r\n {$ENDIF JVCLThemesEnabled}\r\n Result := True;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomPage.TextChanged;\r\nbegin\r\n inherited TextChanged;\r\n if csDesigning in ComponentState then\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvCustomPage.DoHide;\r\nbegin\r\n if Assigned(FOnHide) then\r\n FOnHide(Self);\r\nend;\r\n\r\nprocedure TJvCustomPage.DoShow;\r\nbegin\r\n if Assigned(FOnShow) then\r\n FOnShow(Self);\r\nend;\r\n\r\nprocedure TJvCustomPage.ShowingChanged;\r\nbegin\r\n inherited ShowingChanged;\r\n try\r\n if Showing then\r\n DoShow\r\n else\r\n DoHide;\r\n except\r\n Application.HandleException(Self);\r\n end;\r\nend;\r\n\r\n//=== { TJvCustomPageList } ==================================================\r\n\r\nconstructor TJvCustomPageList.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n ControlStyle := ControlStyle + [csAcceptsControls];\r\n// IncludeThemeStyle(Self, [csParentBackground]);\r\n FPages := TList.Create;\r\n FHiddenPages := TList.Create;\r\n Height := 200;\r\n Width := 300;\r\n FShowDesignCaption := sdcCenter;\r\n ActivePageIndex := -1;\r\nend;\r\n\r\ndestructor TJvCustomPageList.Destroy;\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := FPages.Count - 1 downto 0 do\r\n TJvCustomPage(FPages[I]).FPageList := nil;\r\n FPages.Free;\r\n FHiddenPages.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJvCustomPageList.CanChange(AIndex: Integer): Boolean;\r\nbegin\r\n Result := (AIndex >= 0) and (AIndex < PageCount);\r\n if Result and Assigned(FOnChanging) then\r\n FOnChanging(Self, AIndex, Result);\r\nend;\r\n\r\nprocedure TJvCustomPageList.Change;\r\nbegin\r\n if Assigned(FOnChange) then\r\n FOnChange(Self);\r\nend;\r\n\r\nprocedure TJvCustomPageList.CMDesignHitTest(var Msg: TCMDesignHitTest);\r\nvar\r\n Pt: TPoint;\r\nbegin\r\n inherited;\r\n Pt := SmallPointToPoint(Msg.Pos);\r\n if Assigned(ActivePage) and PtInRect(ActivePage.BoundsRect, Pt) then\r\n Msg.Result := 1;\r\nend;\r\n\r\nprocedure TJvCustomPageList.GetChildren(Proc: TGetChildProc;\r\n Root: TComponent);\r\nvar\r\n I: Integer;\r\n Control: TControl;\r\nbegin\r\n for I := 0 to FPages.Count - 1 do\r\n Proc(TComponent(FPages[I]));\r\n for I := 0 to ControlCount - 1 do\r\n begin\r\n Control := Controls[I];\r\n if not (Control is TJvCustomPage) and (Control.Owner = Root) then\r\n Proc(Control);\r\n end;\r\nend;\r\n\r\nfunction TJvCustomPageList.GetPageCaption(AIndex: Integer): string;\r\nbegin\r\n if (AIndex >= 0) and (AIndex < PageCount) then\r\n Result := TJvCustomPage(FPages[AIndex]).Caption\r\n else\r\n Result := '';\r\nend;\r\n\r\nfunction TJvCustomPageList.InternalGetPageClass: TJvCustomPageClass;\r\nbegin\r\n Result := TJvCustomPage;\r\nend;\r\n\r\nfunction TJvCustomPageList.GetPageCount: Integer;\r\nbegin\r\n if FPages = nil then\r\n Result := 0\r\n else\r\n Result := FPages.Count;\r\nend;\r\n\r\nprocedure TJvCustomPageList.InsertPage(APage: TJvCustomPage);\r\nbegin\r\n if (APage <> nil) and (FPages.IndexOf(APage) = -1) then\r\n FPages.Add(APage);\r\nend;\r\n\r\nprocedure TJvCustomPageList.Loaded;\r\nbegin\r\n inherited Loaded;\r\n if (PageCount > 0) and (ActivePage = nil) then\r\n ActivePage := Pages[0];\r\nend;\r\n\r\nprocedure TJvCustomPageList.Paint;\r\nbegin\r\n if (csDesigning in ComponentState) and (PageCount = 0) then\r\n with Canvas do\r\n begin\r\n Pen.Color := clBlack;\r\n Pen.Style := psDot;\r\n Brush.Style := bsClear;\r\n Rectangle(ClientRect);\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomPageList.RemovePage(APage: TJvCustomPage);\r\nvar\r\n I: Integer;\r\n NextPage: TJvCustomPage;\r\nbegin\r\n NextPage := FindNextPage(APage, True, not (csDesigning in ComponentState));\r\n if NextPage = APage then\r\n NextPage := nil;\r\n { If the last page is removed, go back to the prior page }\r\n if (NextPage <> nil) and (NextPage.PageIndex = 0) and (APage.PageIndex > 0) then\r\n NextPage := Pages[APage.PageIndex - 1];\r\n\r\n APage.Visible := False;\r\n APage.FPageList := nil;\r\n FPages.Remove(APage);\r\n SetActivePage(NextPage);\r\n // (ahuser) In some cases SetActivePage does not change FActivePage\r\n // so we force FActivePage not to be \"APage\"\r\n if (FActivePage = APage) or (FActivePage = nil) then\r\n begin\r\n FActivePage := nil;\r\n for I := 0 to PageCount - 1 do\r\n if Pages[I] <> APage then\r\n begin\r\n FActivePage := Pages[I];\r\n Break;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJvCustomPageList.GetPageFromIndex(AIndex: Integer): TJvCustomPage;\r\nbegin\r\n if (AIndex >= 0) and (AIndex < PageCount) then\r\n Result := TJvCustomPage(Pages[AIndex])\r\n else\r\n Result := nil;\r\nend;\r\n\r\nfunction TJvCustomPageList.GetVisiblePageCount: Integer;\r\nvar\r\n i: Integer;\r\nbegin\r\n Result := 0;\r\n for i := 0 to PageCount - 1 do\r\n if Pages[i].Visible then\r\n Inc(Result);\r\nend;\r\n\r\nprocedure TJvCustomPageList.SetActivePageIndex(AIndex: Integer);\r\nbegin\r\n if (AIndex > -1) and (AIndex < PageCount) then\r\n ActivePage := Pages[AIndex]\r\n else\r\n ActivePage := nil;\r\nend;\r\n\r\nprocedure TJvCustomPageList.ShowControl(AControl: TControl);\r\nbegin\r\n if AControl is TJvCustomPage then\r\n if ActivePage <> AControl then\r\n ActivePage := TJvCustomPage(AControl);\r\n inherited ShowControl(AControl);\r\nend;\r\n\r\nfunction TJvCustomPageList.GetPageClass: TJvCustomPageClass;\r\nbegin\r\n Result := InternalGetPageClass;\r\nend;\r\n\r\nfunction TJvCustomPageList.HidePage(Page: TJvCustomPage): TJvCustomPage;\r\nvar\r\n I: Integer;\r\nbegin\r\n if (Page <> nil) and (Page.PageList = Self) then\r\n begin\r\n if ActivePage = Page then\r\n NextPage;\r\n if ActivePage = Page then\r\n ActivePage := nil;\r\n I := Page.PageIndex;\r\n Page.PageList := nil;\r\n Page.PageIndex := I;\r\n Result := Page;\r\n FHiddenPages.Add(Result);\r\n end\r\n else\r\n Result := nil;\r\nend;\r\n\r\nfunction TJvCustomPageList.ShowPage(Page: TJvCustomPage; PageIndex: Integer): TJvCustomPage;\r\nvar\r\n I: Integer;\r\nbegin\r\n if (Page <> nil) and (Page.PageList = nil) then\r\n begin\r\n I := Page.PageIndex;\r\n Page.PageList := Self;\r\n Page.Parent := Self;\r\n if PageIndex > -1 then\r\n Page.PageIndex := PageIndex\r\n else\r\n if I > -1 then\r\n Page.PageIndex := I;\r\n Result := Page;\r\n FHiddenPages.Remove(Result);\r\n end\r\n else\r\n Result := nil;\r\nend;\r\n\r\nprocedure TJvCustomPageList.SetActivePage(Page: TJvCustomPage);\r\nvar\r\n ParentForm: TCustomForm;\r\n {$IFDEF COMPILER9_UP}\r\n I: Integer;\r\n {$ENDIF COMPILER9_UP}\r\nbegin\r\n // Mantis 3227: Checking if the page can be changed has to be done at the\r\n // beginning or the page would change but not the index...\r\n if not (csLoading in ComponentState) and not CanChange(FPages.IndexOf(Page)) then\r\n Exit;\r\n\r\n if PageCount = 0 then\r\n FActivePage := nil;\r\n if (Page = nil) or (Page.PageList <> Self) then\r\n Exit\r\n else\r\n begin\r\n ParentForm := GetParentForm(Self);\r\n if (ParentForm <> nil) and (FActivePage <> nil) and\r\n FActivePage.ContainsControl(ParentForm.ActiveControl) then\r\n begin\r\n ParentForm.ActiveControl := FActivePage;\r\n if ParentForm.ActiveControl <> FActivePage then\r\n begin\r\n ActivePage := GetPageFromIndex(FActivePage.PageIndex);\r\n Exit;\r\n end;\r\n end;\r\n\r\n Page.BringToFront;\r\n Page.Visible := True;\r\n {$IFDEF COMPILER9_UP}\r\n for I := 0 to PageCount - 1 do\r\n if Pages[i] <> Page then\r\n Pages[i].Visible := False;\r\n {$ENDIF COMPILER9_UP}\r\n if (ParentForm <> nil) and (FActivePage <> nil) and (ParentForm.ActiveControl = FActivePage) then\r\n begin\r\n if Page.CanFocus then\r\n ParentForm.ActiveControl := Page\r\n else\r\n ParentForm.ActiveControl := Self;\r\n end;\r\n Page.Refresh;\r\n\r\n if (FActivePage <> nil) and (FActivePage <> Page) then\r\n FActivePage.Visible := False;\r\n if (FActivePage <> Page) then\r\n begin\r\n FActivePage := Page;\r\n if not (csLoading in ComponentState) then\r\n Change;\r\n end;\r\n if (ParentForm <> nil) and (FActivePage <> nil) and\r\n (ParentForm.ActiveControl = FActivePage) then\r\n begin\r\n FActivePage.SelectFirst;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJvCustomPageList.GetActivePageIndex: Integer;\r\nbegin\r\n if ActivePage <> nil then\r\n Result := ActivePage.PageIndex\r\n else\r\n Result := -1;\r\nend;\r\n\r\nprocedure TJvCustomPageList.NextPage;\r\nbegin\r\n if (ActivePageIndex < PageCount - 1) and (PageCount > 1) then\r\n ActivePageIndex := ActivePageIndex + 1\r\n else\r\n if PageCount > 0 then\r\n ActivePageIndex := 0\r\n else\r\n ActivePageIndex := -1;\r\nend;\r\n\r\nprocedure TJvCustomPageList.PrevPage;\r\nbegin\r\n if ActivePageIndex > 0 then\r\n ActivePageIndex := ActivePageIndex - 1\r\n else\r\n ActivePageIndex := PageCount - 1;\r\nend;\r\n\r\nprocedure TJvCustomPageList.SetPropagateEnable(const Value: Boolean);\r\nbegin\r\n if FPropagateEnable <> Value then\r\n begin\r\n FPropagateEnable := Value;\r\n UpdateEnabled;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomPageList.EnabledChanged;\r\nbegin\r\n inherited EnabledChanged;\r\n UpdateEnabled;\r\nend;\r\n\r\nfunction TJvCustomPageList.FindNextPage(CurPage: TJvCustomPage;\r\n GoForward, IncludeDisabled: Boolean): TJvCustomPage;\r\nvar\r\n I, StartIndex: Integer;\r\nbegin\r\n if PageCount <> 0 then\r\n begin\r\n StartIndex := FPages.IndexOf(CurPage);\r\n if StartIndex < 0 then\r\n if GoForward then\r\n StartIndex := FPages.Count - 1\r\n else\r\n StartIndex := 0;\r\n I := StartIndex;\r\n repeat\r\n if GoForward then\r\n begin\r\n Inc(I);\r\n if I >= FPages.Count then\r\n I := 0;\r\n end\r\n else\r\n begin\r\n if I <= 0 then\r\n I := FPages.Count - 1;\r\n Dec(I);\r\n end;\r\n Result := Pages[I];\r\n if IncludeDisabled or Result.Enabled then\r\n Exit;\r\n until I = StartIndex;\r\n end;\r\n Result := nil;\r\nend;\r\n\r\nprocedure TJvCustomPageList.SetShowDesignCaption(const Value: TJvShowDesignCaption);\r\nbegin\r\n if FShowDesignCaption <> Value then\r\n begin\r\n FShowDesignCaption := Value;\r\n if HandleAllocated and (csDesigning in ComponentState) then\r\n RedrawWindow(Handle, nil, 0, RDW_UPDATENOW or RDW_INVALIDATE or RDW_ALLCHILDREN);\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomPageList.UpdateEnabled;\r\n\r\n procedure InternalSetEnabled(AControl: TWinControl);\r\n var\r\n I: Integer;\r\n begin\r\n for I := 0 to AControl.ControlCount - 1 do\r\n begin\r\n AControl.Controls[I].Enabled := Self.Enabled;\r\n if AControl.Controls[I] is TWinControl then\r\n InternalSetEnabled(TWinControl(AControl.Controls[I]));\r\n end;\r\n end;\r\n\r\nbegin\r\n if PropagateEnable then\r\n InternalSetEnabled(Self);\r\nend;\r\n\r\nfunction TJvCustomPageList.GetPage(Index: Integer): TJvCustomPage;\r\nbegin\r\n if (Index >= 0) and (Index < FPages.Count) then\r\n Result := FPages[Index]\r\n else\r\n Result := nil;\r\nend;\r\n\r\n//===TJvPageList =============================================================\r\n\r\nfunction TJvPageList.InternalGetPageClass: TJvCustomPageClass;\r\nbegin\r\n Result := TJvStandardPage;\r\nend;\r\n\r\nprocedure TJvCustomPageList.DeletePage(Index: Integer);\r\nbegin\r\n if (Index >= 0) and (Index < PageCount) then\r\n Pages[Index].Free;\r\nend;\r\n\r\nprocedure TJvCustomPageList.AddPage(const ACaption: string);\r\nvar\r\n Page: TJvCustomPage;\r\nbegin\r\n Page := GetPageClass.Create(Owner);\r\n Page.Caption := ACaption;\r\n Page.Name := GetUniqueName(Owner, Copy(Page.ClassName, 2, MaxInt));\r\n Page.PageList := Self;\r\nend;\r\n\r\nprocedure TJvCustomPageList.MovePage(CurIndex, NewIndex: Integer);\r\nbegin\r\n FPages.Move(CurIndex, NewIndex);\r\nend;\r\n\r\nprocedure TJvCustomPageList.PageCaptionChanged(Index: Integer;\r\n const NewCaption: string);\r\nbegin\r\n if (Index >= 0) and (Index < PageCount) then\r\n Pages[Index].Caption := NewCaption;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend." }, { "path": "External/Jedi/Jvcl/run/JvPageListTreeView.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvPageListTreeView.PAS, released on 2003-01-22.\r\n\r\nThe Initial Developer of the Original Code is Peter Thrnqvist [peter3 at sourceforge dot net] .\r\nPortions created by Peter Thrnqvist are Copyright (C) 2003 Peter Thrnqvist.\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nChanges:\r\n2002-10-22:\r\n Changed TJvPageIndexNode.SetPageIndex to only set the parent PageIndex if the Treeview is a\r\n TJvCustomSettingsTreeView since this is the first class implementing this behaviour\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvPageListTreeView.pas 13415 2012-09-10 09:51:54Z obones $\r\n\r\nunit JvPageListTreeView;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n SysUtils, Classes,\r\n Windows, Messages, Graphics, Controls, ImgList, ComCtrls,\r\n {$IFDEF HAS_UNIT_SYSTEM_UITYPES}\r\n System.UITypes,\r\n {$ENDIF HAS_UNIT_SYSTEM_UITYPES}\r\n JvPageList, JvExComCtrls;\r\n\r\ntype\r\n TJvCustomPageListTreeView = class;\r\n\r\n TJvPageIndexNode = class(TTreeNode)\r\n private\r\n FPageIndex: Integer;\r\n procedure SetPageIndex(const Value: Integer);\r\n published\r\n procedure Assign(Source: TPersistent); override;\r\n property PageIndex: Integer read FPageIndex write SetPageIndex;\r\n end;\r\n\r\n TJvPageIndexNodes = class(TTreeNodes)\r\n private\r\n procedure ReadData(Stream: TStream);\r\n procedure WriteData(Stream: TStream);\r\n protected\r\n procedure DefineProperties(Filer: TFiler); override;\r\n end;\r\n\r\n // this is a \"fake\" class so we have something to anchor the design-time editor with\r\n TJvPageLinks = class(TPersistent)\r\n private\r\n FTreeView: TJvCustomPageListTreeView;\r\n public\r\n property TreeView: TJvCustomPageListTreeView read FTreeView;\r\n end;\r\n\r\n { TJvCustomPageListTreeView is a base treeview class that can be hooked up with an IPageList\r\n implementor. When the selected tree node is changed, the associated page in the IPageList is changed too as\r\n determined by the TJvPageIndexNode.PageIndex property\r\n Properties:\r\n * PageDefault is the default PageIndex to assign to new nodes\r\n * PageLinks is the property used att design time to set up a Nodes PageIndex. At run-time, use\r\n TJvPageIndexNode(Node).PageIndex := Value;\r\n * PageList is the IPageList implementor that is attached to this control\r\n * CanChange calls IPageList.CanChange method and Change calls IPageList.SetActivePageIndex\r\n * IPageList.getPageCaption is only used by the design-time editor for the PageLinks property\r\n }\r\n\r\n TJvCustomPageListTreeView = class(TJvExCustomTreeView)\r\n private\r\n FItems: TJvPageIndexNodes;\r\n FPageList: IPageList;\r\n FPageDefault: Integer;\r\n FLinks: TJvPageLinks;\r\n FMemStream: TMemoryStream;\r\n procedure SetPageDefault(const Value: Integer);\r\n procedure SetLinks(const Value: TJvPageLinks);\r\n procedure SetPageList(const Value: IPageList);\r\n function GetItems: TJvPageIndexNodes;\r\n procedure SetItems(const Value: TJvPageIndexNodes);\r\n protected\r\n procedure CreateWnd; override;\r\n procedure DestroyWnd; override;\r\n procedure Notification(AComponent: TComponent; Operation: TOperation); override;\r\n function CreateNode: TTreeNode; override;\r\n function CreateNodes: TTreeNodes; override; \r\n function CanChange(Node: TTreeNode): Boolean; override;\r\n procedure Change(Node: TTreeNode); override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n property PageDefault: Integer read FPageDefault write SetPageDefault;\r\n property PageLinks: TJvPageLinks read FLinks write SetLinks;\r\n property PageList: IPageList read FPageList write SetPageList;\r\n protected\r\n property AutoExpand default True;\r\n property ShowButtons default False;\r\n property ShowLines default False;\r\n property ReadOnly default True;\r\n property Items: TJvPageIndexNodes read GetItems write SetItems;\r\n end;\r\n\r\n { TJvSettingsTreeImages is a property class that describes the images used in a\r\n TJvCustomSettingsTreeView as the usage of images in this control differs from the normal\r\n TreeView\r\n }\r\n TJvSettingsTreeImages = class(TPersistent)\r\n private\r\n FSelectedIndex: TImageIndex;\r\n FCollapsedIndex: TImageIndex;\r\n FImageIndex: TImageIndex;\r\n FExpandedIndex: TImageIndex;\r\n FTreeView: TJvCustomPageListTreeView;\r\n public\r\n constructor Create;\r\n property TreeView: TJvCustomPageListTreeView read FTreeView write FTreeView;\r\n published\r\n property CollapsedIndex: TImageIndex read FCollapsedIndex write FCollapsedIndex default 0;\r\n property ExpandedIndex: TImageIndex read FExpandedIndex write FExpandedIndex default 1;\r\n property SelectedIndex: TImageIndex read FSelectedIndex write FSelectedIndex default 2;\r\n property ImageIndex: TImageIndex read FImageIndex write FImageIndex default -1;\r\n end;\r\n\r\n { TJvCustomSettingsTreeView is a base class for treeviews that behave like the\r\n treeview in the Settings Dialog in Visual Studio: When a node in the treeview\r\n is selected, a new page of settings is shown on a panel to the right.\r\n\r\n Specifically, the following is True:\r\n\r\n * The normal ImageIndex/SelectedIndex is ignored for nodes - use PageNodeImages instead. You still\r\n need to assign a TImageList to the Images property\r\n * When a node is expanded, it is assigned the expanded image until it is collapsed, regardless\r\n whether it's selected or not\r\n * When a parent folder is selected, the first non-folder child has it's\r\n normal image set as the selected image\r\n * By default, AutoExpand and ReadOnly is True, ShowButtons and ShowLines are False\r\n\r\n Other than that, it should work like a normal TreeView. Note that the treeview was designed with AutoExpand = True\r\n in mind but should work with AutoExpand = False\r\n\r\n To get the VS look , Images should contain:\r\n Image 0: Closed Folder\r\n Image 1: Open Folder\r\n Image 2: Right-pointing teal-colored arrow\r\n\r\n PageNodeImages should then be set to (the defaults):\r\n ClosedFolder = 0;\r\n ImageIndex = -1; (no image)\r\n OpenFolder = 1;\r\n SelectedIndex = 2;\r\n }\r\n\r\n TJvCustomSettingsTreeView = class(TJvCustomPageListTreeView)\r\n private\r\n FNodeImages: TJvSettingsTreeImages;\r\n FOnGetImageIndex: TTVExpandedEvent;\r\n FOnGetSelectedIndex: TTVExpandedEvent;\r\n procedure SetImageSelection(const Value: TJvSettingsTreeImages);\r\n protected\r\n FLastSelected: TTreeNode;\r\n procedure Delete(Node: TTreeNode); override;\r\n procedure DoGetImageIndex(Sender: TObject; Node: TTreeNode);\r\n procedure DoGetSelectedIndex(Sender: TObject; Node: TTreeNode);\r\n procedure GetSelectedIndex(Node: TTreeNode); override;\r\n procedure GetImageIndex(Node: TTreeNode); override;\r\n function CanChange(Node: TTreeNode): Boolean; override;\r\n procedure Change(Node: TTreeNode); override;\r\n procedure ResetPreviousNode(NewNode: TTreeNode); virtual;\r\n procedure SetPreviousNode(NewNode: TTreeNode); virtual;\r\n procedure Loaded; override;\r\n procedure Expand(Node: TTreeNode); override;\r\n procedure Collapse(Node: TTreeNode); override;\r\n property PageNodeImages: TJvSettingsTreeImages read FNodeImages write SetImageSelection;\r\n property OnGetImageIndex: TTVExpandedEvent read FOnGetImageIndex write FOnGetImageIndex;\r\n property OnGetSelectedIndex: TTVExpandedEvent read FOnGetSelectedIndex write FOnGetSelectedIndex;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n end;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvPageListTreeView = class(TJvCustomPageListTreeView)\r\n published\r\n property AutoExpand;\r\n property ShowButtons;\r\n property ShowLines;\r\n property ReadOnly;\r\n property PageDefault;\r\n property PageLinks;\r\n property PageList;\r\n property OnMouseEnter;\r\n property OnMouseLeave;\r\n property OnParentColorChange;\r\n property Align;\r\n property Anchors;\r\n property BevelEdges;\r\n property BevelInner;\r\n property BevelOuter;\r\n property BevelKind default bkNone;\r\n property BevelWidth;\r\n property BiDiMode;\r\n property DragKind;\r\n property DragCursor;\r\n property ParentBiDiMode;\r\n property OnEndDock;\r\n property OnStartDock;\r\n property BorderWidth;\r\n property ChangeDelay;\r\n property HideSelection;\r\n property HotTrack;\r\n property MultiSelect;\r\n property MultiSelectStyle;\r\n property StateImages;\r\n property ToolTips;\r\n property OnAdvancedCustomDraw;\r\n property OnAdvancedCustomDrawItem;\r\n property ShowRoot;\r\n property RightClickSelect;\r\n property BorderStyle;\r\n property Color;\r\n property Constraints;\r\n property DragMode;\r\n property Enabled;\r\n property Font;\r\n property Images;\r\n property Indent;\r\n property ParentColor default False;\r\n property ParentFont;\r\n property ParentShowHint;\r\n property PopupMenu;\r\n property RowSelect;\r\n property ShowHint;\r\n property SortType;\r\n property TabOrder;\r\n property TabStop default True;\r\n property Visible;\r\n property OnChange;\r\n property OnChanging;\r\n property OnClick;\r\n property OnCollapsed;\r\n property OnCollapsing;\r\n property OnContextPopup;\r\n property OnCompare;\r\n property OnAddition;\r\n property OnCreateNodeClass;\r\n property OnCustomDraw;\r\n property OnCustomDrawItem;\r\n property OnDblClick;\r\n property OnDeletion;\r\n property OnDragDrop;\r\n property OnDragOver;\r\n property OnEdited;\r\n property OnEditing;\r\n property OnEndDrag;\r\n property OnEnter;\r\n property OnExit;\r\n property OnExpanding;\r\n property OnExpanded;\r\n property OnGetImageIndex;\r\n property OnGetSelectedIndex;\r\n property OnKeyDown;\r\n property OnKeyPress;\r\n property OnKeyUp;\r\n property OnMouseDown;\r\n property OnMouseMove;\r\n property OnMouseUp;\r\n property OnStartDrag;\r\n property Items;\r\n end;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvSettingsTreeView = class(TJvCustomSettingsTreeView)\r\n published\r\n property AutoExpand;\r\n property ShowButtons;\r\n property ShowLines;\r\n property ReadOnly;\r\n property PageDefault;\r\n property PageNodeImages;\r\n property PageLinks;\r\n property PageList;\r\n\r\n property OnMouseEnter;\r\n property OnMouseLeave;\r\n property OnParentColorChange;\r\n\r\n property Align;\r\n property Anchors;\r\n property BevelEdges;\r\n property BevelInner;\r\n property BevelOuter;\r\n property BevelKind default bkNone;\r\n property BevelWidth;\r\n property BiDiMode;\r\n property BorderWidth;\r\n property ChangeDelay;\r\n property DragKind;\r\n property DragCursor;\r\n property HideSelection;\r\n property HotTrack;\r\n property ParentBiDiMode;\r\n property OnAddition;\r\n property OnCreateNodeClass;\r\n property OnCustomDraw;\r\n property OnEndDock;\r\n property OnStartDock;\r\n property OnAdvancedCustomDraw;\r\n property OnAdvancedCustomDrawItem;\r\n property OnCompare;\r\n property RightClickSelect;\r\n property ShowRoot;\r\n property StateImages;\r\n property ToolTips;\r\n property BorderStyle;\r\n property Color;\r\n property Constraints;\r\n property DragMode;\r\n property Enabled;\r\n property Font;\r\n property Images;\r\n property Indent;\r\n // don't use!\r\n// property MultiSelect;\r\n// property MultiSelectStyle;\r\n property ParentColor default False;\r\n property ParentFont;\r\n property ParentShowHint;\r\n property PopupMenu;\r\n property RowSelect;\r\n property ShowHint;\r\n property SortType;\r\n property TabOrder;\r\n property TabStop default True;\r\n property Visible;\r\n property OnChange;\r\n property OnChanging;\r\n property OnClick;\r\n property OnCollapsed;\r\n property OnCollapsing;\r\n property OnContextPopup;\r\n property OnCustomDrawItem;\r\n property OnDblClick;\r\n property OnDeletion;\r\n property OnDragDrop;\r\n property OnDragOver;\r\n property OnEdited;\r\n property OnEditing;\r\n property OnEndDrag;\r\n property OnEnter;\r\n property OnExit;\r\n property OnExpanding;\r\n property OnExpanded;\r\n property OnGetImageIndex;\r\n property OnGetSelectedIndex;\r\n property OnKeyDown;\r\n property OnKeyPress;\r\n property OnKeyUp;\r\n property OnMouseDown;\r\n property OnMouseMove;\r\n property OnMouseUp;\r\n property OnStartDrag;\r\n property Items;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvPageListTreeView.pas $';\r\n Revision: '$Revision: 13415 $';\r\n Date: '$Date: 2012-09-10 11:51:54 +0200 (lun. 10 sept. 2012) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n Forms;\r\n\r\nprocedure ResetSiblingFolders(Node: TTreeNode; ImageIndex, SelectedIndex: Integer; Recurse: Boolean = False);\r\nvar\r\n N: TTreeNode;\r\nbegin\r\n N := Node.getPrevSibling;\r\n while Assigned(N) do\r\n begin\r\n if N.HasChildren then\r\n begin\r\n N.ImageIndex := ImageIndex;\r\n N.SelectedIndex := SelectedIndex;\r\n if Recurse then\r\n ResetSiblingFolders(N.getFirstChild, ImageIndex, SelectedIndex, Recurse);\r\n end;\r\n N := N.getPrevSibling;\r\n end;\r\n N := Node.getNextSibling;\r\n while Assigned(N) do\r\n begin\r\n if N.HasChildren then\r\n begin\r\n N.ImageIndex := ImageIndex;\r\n N.SelectedIndex := SelectedIndex;\r\n if Recurse then\r\n ResetSiblingFolders(N.getFirstChild, ImageIndex, SelectedIndex, Recurse);\r\n end;\r\n N := N.getNextSibling;\r\n end;\r\nend;\r\n\r\n//=== { TJvCustomPageListTreeView } ==========================================\r\n\r\nconstructor TJvCustomPageListTreeView.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FLinks := TJvPageLinks.Create;\r\n FLinks.FTreeView := Self;\r\n ReadOnly := True;\r\n ShowLines := False;\r\n AutoExpand := True;\r\n ShowButtons := False;\r\nend;\r\n\r\ndestructor TJvCustomPageListTreeView.Destroy;\r\nbegin\r\n FLinks.Free;\r\n FMemStream.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJvCustomPageListTreeView.CanChange(Node: TTreeNode): Boolean;\r\nbegin\r\n Result := inherited CanChange(Node);\r\n if Result and Assigned(Node) and Assigned(FPageList) then\r\n Result := FPageList.CanChange(TJvPageIndexNode(Node).PageIndex);\r\nend;\r\n\r\nprocedure TJvCustomPageListTreeView.Change(Node: TTreeNode);\r\nvar\r\n I: Integer;\r\nbegin\r\n inherited Change(Node);\r\n if Assigned(FPageList) and Assigned(Node) then\r\n begin\r\n I := TJvPageIndexNode(Node).PageIndex;\r\n if (I >= 0) and (I < FPageList.GetPageCount) then\r\n FPageList.SetActivePageIndex(I)\r\n else\r\n if (PageDefault >= 0) and (PageDefault < FPageList.GetPageCount) then\r\n FPageList.SetActivePageIndex(PageDefault)\r\n else\r\n FPageList.SetActivePageIndex(-1);\r\n end;\r\nend;\r\n\r\nfunction TJvCustomPageListTreeView.CreateNode: TTreeNode;\r\nbegin\r\n Result := TJvPageIndexNode.Create(Items);\r\n TJvPageIndexNode(Result).PageIndex := PageDefault;\r\nend;\r\n\r\nfunction TJvCustomPageListTreeView.CreateNodes: TTreeNodes;\r\nbegin\r\n if (FItems = nil) and not (csDestroying in ComponentState) then\r\n FItems := TJvPageIndexNodes.Create(Self);\r\n Result := FItems;\r\nend;\r\n\r\nprocedure TJvCustomPageListTreeView.CreateWnd;\r\nbegin\r\n inherited CreateWnd;\r\n\r\n if FMemStream <> nil then\r\n begin\r\n Items.BeginUpdate;\r\n try\r\n Items.ReadData(FMemStream);\r\n FreeAndNil(FMemStream);\r\n finally\r\n Items.EndUpdate;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomPageListTreeView.DestroyWnd;\r\nbegin\r\n if CreateWndRestores and\r\n {$IFDEF COMPILER10_UP}\r\n (csRecreating in ControlState) and\r\n {$ENDIF COMPILER10_UP}\r\n (Items.Count > 0) then\r\n begin\r\n FMemStream := TMemoryStream.Create;\r\n Items.WriteData(FMemStream);\r\n FMemStream.Position := 0;\r\n end;\r\n\r\n inherited DestroyWnd;\r\nend;\r\n\r\nprocedure TJvCustomPageListTreeView.Notification(AComponent: TComponent;\r\n Operation: TOperation);\r\nbegin\r\n inherited Notification(AComponent, Operation);\r\n if (Operation = opRemove) then\r\n begin\r\n if AComponent.IsImplementorOf(PageList) then\r\n PageList := nil;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomPageListTreeView.SetPageDefault(const Value: Integer);\r\nvar\r\n N: TTreeNode;\r\nbegin\r\n if FPageDefault <> Value then\r\n begin\r\n N := Items.GetFirstNode;\r\n while Assigned(N) do\r\n begin\r\n if TJvPageIndexNode(N).PageIndex = FPageDefault then\r\n TJvPageIndexNode(N).PageIndex := Value;\r\n N := N.GetNext;\r\n end;\r\n FPageDefault := Value;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomPageListTreeView.SetLinks(const Value: TJvPageLinks);\r\nbegin\r\n FLinks.Assign(Value);\r\nend;\r\n\r\nprocedure TJvCustomPageListTreeView.SetPageList(const Value: IPageList);\r\nbegin\r\n if FPageList <> Value then\r\n begin\r\n ReferenceInterface(FPageList, opRemove);\r\n FPageList := Value;\r\n ReferenceInterface(FPageList, opInsert);\r\n end;\r\nend;\r\n\r\nfunction TJvCustomPageListTreeView.GetItems: TJvPageIndexNodes;\r\nbegin\r\n Result := TJvPageIndexNodes(CreateNodes);\r\nend;\r\n\r\nprocedure TJvCustomPageListTreeView.SetItems(const Value: TJvPageIndexNodes);\r\nbegin\r\n inherited Items := Value;\r\nend;\r\n\r\n//=== { TJvPageIndexNode } ===================================================\r\n\r\nprocedure TJvPageIndexNode.Assign(Source: TPersistent);\r\nbegin\r\n inherited Assign(Source);\r\n if Source is TJvPageIndexNode then\r\n PageIndex := TJvPageIndexNode(Source).PageIndex;\r\nend;\r\n\r\nprocedure TJvPageIndexNode.SetPageIndex(const Value: Integer);\r\nbegin\r\n if FPageIndex <> Value then\r\n begin\r\n FPageIndex := Value;\r\n if (TreeView is TJvCustomSettingsTreeView) and (Parent <> nil) and\r\n (Parent.getFirstChild = Self) and not HasChildren then\r\n TJvPageIndexNode(Parent).PageIndex := Value;\r\n end;\r\nend;\r\n\r\n//=== { TJvPageIndexNodes } ==================================================\r\n\r\nprocedure TJvPageIndexNodes.DefineProperties(Filer: TFiler);\r\nbegin\r\n inherited DefineProperties(Filer);\r\n Filer.DefineBinaryProperty('Links', ReadData, WriteData, True);\r\nend;\r\n\r\nprocedure TJvPageIndexNodes.ReadData(Stream: TStream);\r\nvar\r\n APageIndex, ACount: Integer;\r\n LNode: TTreeNode;\r\n LHandleAllocated: Boolean;\r\nbegin\r\n LHandleAllocated := Owner.HandleAllocated;\r\n if LHandleAllocated then\r\n BeginUpdate;\r\n try\r\n Stream.Read(ACount, SizeOf(ACount));\r\n if ACount > 0 then\r\n begin\r\n LNode := GetFirstNode;\r\n while Assigned(LNode) and (ACount > 0) do\r\n begin\r\n Stream.Read(APageIndex, SizeOf(APageIndex));\r\n TJvPageIndexNode(LNode).PageIndex := APageIndex;\r\n LNode := LNode.GetNext;\r\n Dec(ACount);\r\n end;\r\n // read any \"left-overs\" (should never happen)\r\n while ACount > 0 do\r\n begin\r\n Stream.Read(APageIndex, SizeOf(APageIndex));\r\n Dec(ACount);\r\n end;\r\n end;\r\n finally\r\n if LHandleAllocated then\r\n EndUpdate;\r\n end;\r\nend;\r\n\r\nprocedure TJvPageIndexNodes.WriteData(Stream: TStream);\r\nvar\r\n Node: TTreeNode;\r\n APageIndex: Integer;\r\n ACount: Integer;\r\nbegin\r\n ACount := Count;\r\n Stream.Write(ACount, SizeOf(Count));\r\n if ACount > 0 then\r\n begin\r\n Node := GetFirstNode;\r\n while (Node <> nil) do\r\n begin\r\n APageIndex := TJvPageIndexNode(Node).PageIndex;\r\n Stream.Write(APageIndex, SizeOf(APageIndex));\r\n Node := Node.GetNext;\r\n end;\r\n end;\r\nend;\r\n\r\n//=== { TJvSettingsTreeImages } ==============================================\r\n\r\nconstructor TJvSettingsTreeImages.Create;\r\nbegin\r\n inherited Create;\r\n FCollapsedIndex := 0;\r\n FExpandedIndex := 1;\r\n FSelectedIndex := 2;\r\n FImageIndex := -1;\r\nend;\r\n\r\n//=== { TJvCustomSettingsTreeView } ==========================================\r\n\r\nconstructor TJvCustomSettingsTreeView.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FNodeImages := TJvSettingsTreeImages.Create;\r\n FNodeImages.TreeView := Self;\r\n AutoExpand := True;\r\n ShowButtons := False;\r\n ReadOnly := True;\r\n ShowLines := False;\r\n // we need to assign to these since the TTreeView checks if they are assigned\r\n // and won't call GetImageIndex without them\r\n inherited OnGetImageIndex := DoGetImageIndex;\r\n inherited OnGetSelectedIndex := DoGetSelectedIndex;\r\nend;\r\n\r\ndestructor TJvCustomSettingsTreeView.Destroy;\r\nbegin\r\n FNodeImages.TreeView := nil;\r\n FNodeImages.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJvCustomSettingsTreeView.CanChange(Node: TTreeNode): Boolean;\r\nbegin\r\n Result := inherited CanChange(Node);\r\n if Result and (Selected <> nil) and not Selected.HasChildren then // Selected is the previous selected node\r\n begin\r\n Selected.ImageIndex := FNodeImages.ImageIndex;\r\n Selected.SelectedIndex := FNodeImages.ImageIndex;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomSettingsTreeView.Change(Node: TTreeNode);\r\nbegin\r\n inherited Change(Node);\r\n if not AutoExpand and Node.Expanded then\r\n Node.Expand(False); // refresh node and children\r\nend;\r\n\r\nprocedure TJvCustomSettingsTreeView.Collapse(Node: TTreeNode);\r\nbegin\r\n inherited Collapse(Node);\r\n if Node.HasChildren then\r\n begin\r\n Node.ImageIndex := FNodeImages.CollapsedIndex;\r\n Node.SelectedIndex := FNodeImages.CollapsedIndex;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomSettingsTreeView.Delete(Node: TTreeNode);\r\nbegin\r\n inherited Delete(Node);\r\n if Node = FLastSelected then\r\n FLastSelected := nil;\r\nend;\r\n\r\nprocedure TJvCustomSettingsTreeView.DoGetImageIndex(Sender: TObject;\r\n Node: TTreeNode);\r\nbegin\r\n if Assigned(FOnGetImageIndex) then\r\n FOnGetImageIndex(Sender, Node)\r\n else\r\n GetImageIndex(Node);\r\nend;\r\n\r\nprocedure TJvCustomSettingsTreeView.DoGetSelectedIndex(Sender: TObject;\r\n Node: TTreeNode);\r\nbegin\r\n if Assigned(FOnGetSelectedIndex) then\r\n FOnGetSelectedIndex(Sender, Node)\r\n else\r\n GetSelectedIndex(Node);\r\nend;\r\n\r\nprocedure TJvCustomSettingsTreeView.Expand(Node: TTreeNode);\r\nvar\r\n N: TTreeNode;\r\n R: TRect;\r\nbegin\r\n if Node.HasChildren then\r\n begin\r\n if AutoExpand then\r\n ResetSiblingFolders(Node, FNodeImages.CollapsedIndex, FNodeImages.CollapsedIndex, True);\r\n Node.ImageIndex := FNodeImages.ExpandedIndex;\r\n Node.SelectedIndex := FNodeImages.ExpandedIndex;\r\n N := Node.getFirstChild;\r\n if (N <> nil) and not N.HasChildren then\r\n begin\r\n ResetPreviousNode(N);\r\n N.ImageIndex := FNodeImages.SelectedIndex;\r\n N.SelectedIndex := FNodeImages.SelectedIndex;\r\n R := N.DisplayRect(False);\r\n Windows.InvalidateRect(Handle, @R, True);\r\n SetPreviousNode(N);\r\n end;\r\n end;\r\n inherited Expand(Node);\r\nend;\r\n\r\n\r\nprocedure TJvCustomSettingsTreeView.GetImageIndex(Node: TTreeNode);\r\nbegin\r\n if Node.HasChildren then\r\n begin\r\n if Node.Expanded then\r\n Node.ImageIndex := FNodeImages.ExpandedIndex\r\n else\r\n Node.ImageIndex := FNodeImages.CollapsedIndex;\r\n end\r\n else\r\n if Node.Selected or\r\n ((Node.Parent <> nil) and Node.Parent.Selected and\r\n (Node.Parent.getFirstChild = Node)) then\r\n begin\r\n ResetPreviousNode(Node);\r\n Node.ImageIndex := FNodeImages.SelectedIndex;\r\n SetPreviousNode(Node);\r\n end\r\n else\r\n Node.ImageIndex := FNodeImages.ImageIndex;\r\n Node.SelectedIndex := Node.ImageIndex;\r\nend;\r\n\r\nprocedure TJvCustomSettingsTreeView.GetSelectedIndex(Node: TTreeNode);\r\nbegin\r\n GetImageIndex(Node);\r\nend;\r\n\r\nprocedure TJvCustomSettingsTreeView.Loaded;\r\nbegin\r\n inherited Loaded;\r\n if Items.Count > 0 then\r\n begin\r\n ResetSiblingFolders(Items[0], FNodeImages.CollapsedIndex, FNodeImages.CollapsedIndex, True);\r\n Items[0].MakeVisible;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomSettingsTreeView.ResetPreviousNode(NewNode: TTreeNode);\r\nvar\r\n R: TRect;\r\nbegin\r\n if (FLastSelected <> nil) and (FLastSelected <> NewNode) and\r\n (NewNode <> nil) and not NewNode.HasChildren then\r\n begin\r\n FLastSelected.ImageIndex := FNodeImages.ImageIndex;\r\n FLastSelected.SelectedIndex := FNodeImages.ImageIndex;\r\n R := FLastSelected.DisplayRect(False);\r\n Windows.InvalidateRect(Handle, @R, True);\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomSettingsTreeView.SetImageSelection(const Value: TJvSettingsTreeImages);\r\nbegin\r\n // FNodeImages := Value;\r\nend;\r\n\r\nprocedure TJvCustomSettingsTreeView.SetPreviousNode(NewNode: TTreeNode);\r\nbegin\r\n FLastSelected := NewNode;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvPageManager.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvPageMngr.PAS, released on 2002-07-04.\r\n\r\nThe Initial Developers of the Original Code are: Fedor Koshevnikov, Igor Pavluk and Serge Korolev\r\nCopyright (c) 1997, 1998 Fedor Koshevnikov, Igor Pavluk and Serge Korolev\r\nCopyright (c) 2001,2002 SGB Software\r\nAll Rights Reserved.\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvPageManager.pas 13104 2011-09-07 06:50:43Z obones $\r\n\r\nunit JvPageManager;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Controls, Forms, StdCtrls, ExtCtrls, ActnList,\r\n SysUtils, Classes;\r\n\r\ntype\r\n TPageNotifyEvent = procedure(Next: Boolean) of object;\r\n TPageRequestEvent = procedure(CurrentPage: Integer;\r\n var NewPage: Integer) of object;\r\n\r\n TPageOwner = TNotebook;\r\n TPageItem = TPage;\r\n TJvPageProxy = class;\r\n TJvPageHistory = class;\r\n TJvPageHistoryItem = class;\r\n TJvPageHistoryCommand = (hcNone, hcAdd, hcBack, hcForward, hcGoto);\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64 or pidOSX32)]\r\n {$ENDIF RTL230_UP}\r\n TJvPageManager = class(TComponent)\r\n private\r\n FPageOwner: TPageOwner;\r\n FPageProxies: TList;\r\n FSetStartPage: Boolean;\r\n FDestroyHandles: Boolean;\r\n FButtons: array [Boolean] of TControl;\r\n FSaveBtnClick: array [Boolean] of TNotifyEvent;\r\n FChangeHelpContext: Boolean;\r\n FPageHistory: TJvPageHistory;\r\n FUseHistory: Boolean;\r\n FHistoryCommand: TJvPageHistoryCommand;\r\n FOnGetPriorPage: TPageRequestEvent;\r\n FOnGetNextPage: TPageRequestEvent;\r\n FOnCheckButtons: TNotifyEvent;\r\n FOnCheckProxy: TNotifyEvent;\r\n FOnPageChanged: TNotifyEvent;\r\n procedure SetPageOwner(Value: TPageOwner);\r\n function GetProxyIndex(const PageName: string): Integer;\r\n procedure AddProxy(Proxy: TJvPageProxy);\r\n procedure RemoveProxy(Proxy: TJvPageProxy);\r\n procedure DestroyProxies;\r\n procedure PageEnter(Page: Integer; Next: Boolean);\r\n procedure PageLeave(Page: Integer; Next: Boolean);\r\n procedure PageShow(Page: Integer; Next: Boolean);\r\n procedure PageHide(Page: Integer; Next: Boolean);\r\n procedure PageChanged;\r\n function GetNextEnabled: Boolean;\r\n function GetPriorEnabled: Boolean;\r\n function GetPageIndex: Integer;\r\n procedure SetPageIndex(Value: Integer);\r\n function GetPageCount: Integer;\r\n function GetPageName(Index: Integer): string;\r\n function FindFreePage: string;\r\n procedure SetPageProxies(Value: TList);\r\n function GetButton(Index: Integer): TControl;\r\n procedure SetButton(Index: Integer; Value: TControl);\r\n procedure SetDestroyHandles(Value: Boolean);\r\n procedure SyncBtnClick(Index: Integer; Sync: Boolean);\r\n procedure BtnClick(Sender: TObject);\r\n procedure DormantPages;\r\n protected\r\n procedure Loaded; override;\r\n procedure Notification(AComponent: TComponent; AOperation: TOperation); override;\r\n procedure GetChildren(Proc: TGetChildProc; Root: TComponent); override;\r\n procedure ChangePage(Next: Boolean); virtual;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n procedure CheckBtnEnabled;\r\n procedure Resync;\r\n function GetPriorPageIndex(Page: Integer): Integer; virtual;\r\n function GetNextPageIndex(Page: Integer): Integer; virtual;\r\n procedure NextPage;\r\n procedure PriorPage;\r\n procedure GotoHistoryPage(HistoryIndex: Integer);\r\n procedure SetPage(NewPageIndex: Integer; Next: Boolean);\r\n property PageNames[Index: Integer]: string read GetPageName;\r\n property PageCount: Integer read GetPageCount;\r\n property PageIndex: Integer read GetPageIndex;\r\n property NextEnabled: Boolean read GetNextEnabled;\r\n property PriorEnabled: Boolean read GetPriorEnabled;\r\n property PageHistory: TJvPageHistory read FPageHistory;\r\n property HistoryCommand: TJvPageHistoryCommand read FHistoryCommand write FHistoryCommand;\r\n property OnCheckProxy: TNotifyEvent read FOnCheckProxy write FOnCheckProxy; { for internal use only }\r\n published\r\n property PageOwner: TPageOwner read FPageOwner write SetPageOwner;\r\n property PageProxies: TList read FPageProxies write SetPageProxies;\r\n property NextBtn: TControl index 1 read GetButton write SetButton;\r\n property PriorBtn: TControl index 0 read GetButton write SetButton;\r\n property SetStartPage: Boolean read FSetStartPage write FSetStartPage default True;\r\n property DestroyHandles: Boolean read FDestroyHandles write SetDestroyHandles default False;\r\n property UseHistory: Boolean read FUseHistory write FUseHistory default False;\r\n property OnGetPriorPage: TPageRequestEvent read FOnGetPriorPage\r\n write FOnGetPriorPage;\r\n property OnGetNextPage: TPageRequestEvent read FOnGetNextPage write FOnGetNextPage;\r\n property OnCheckButtons: TNotifyEvent read FOnCheckButtons write FOnCheckButtons;\r\n property OnPageChanged: TNotifyEvent read FOnPageChanged write FOnPageChanged;\r\n end;\r\n\r\n TJvPageProxy = class(TComponent)\r\n private\r\n FPageManager: TJvPageManager;\r\n FPageName: string;\r\n FOnEnter: TPageNotifyEvent;\r\n FOnLeave: TPageNotifyEvent;\r\n FOnShow: TPageNotifyEvent;\r\n FOnHide: TPageNotifyEvent;\r\n function GetPageName: string;\r\n procedure SetPageName(const Value: string);\r\n procedure SetPageManager(Value: TJvPageManager);\r\n procedure PageEnter(Next: Boolean);\r\n procedure PageLeave(Next: Boolean);\r\n procedure PageShow(Next: Boolean);\r\n procedure PageHide(Next: Boolean);\r\n protected\r\n procedure SetParentComponent(Value: TComponent); override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n function HasParent: Boolean; override;\r\n function GetParentComponent: TComponent; override;\r\n property PageManager: TJvPageManager read FPageManager write SetPageManager;\r\n published\r\n property PageName: string read GetPageName write SetPageName;\r\n property OnEnter: TPageNotifyEvent read FOnEnter write FOnEnter;\r\n property OnLeave: TPageNotifyEvent read FOnLeave write FOnLeave;\r\n property OnShow: TPageNotifyEvent read FOnShow write FOnShow;\r\n property OnHide: TPageNotifyEvent read FOnHide write FOnHide;\r\n end;\r\n\r\n TJvPageHistoryItem = class(TObject)\r\n public\r\n Index: Integer;\r\n end;\r\n\r\n TJvPageHistory = class(TList)\r\n private\r\n FCurrent: Integer;\r\n FHistoryCapacity: Integer;\r\n procedure SetCurrent(Value: Integer);\r\n procedure SetHistoryCapacity(Value: Integer);\r\n function GetPageIndex(Index: Integer): Integer;\r\n public\r\n constructor Create;\r\n destructor Destroy; override;\r\n procedure AddPageIndex(PageIndex: Integer);\r\n procedure DeleteHistoryItem(Index: Integer);\r\n procedure ResetHistory;\r\n property Current: Integer read FCurrent write SetCurrent;\r\n property HistoryCapacity: Integer read FHistoryCapacity\r\n write SetHistoryCapacity;\r\n property PageIndexes[Index: Integer]: Integer read GetPageIndex;\r\n end;\r\n\r\nconst\r\n PageNull = -1;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvPageManager.pas $';\r\n Revision: '$Revision: 13104 $';\r\n Date: '$Date: 2011-09-07 08:50:43 +0200 (mer. 07 sept. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n JvJVCLUtils;\r\n\r\n\r\nvar\r\n Registered: Boolean = False;\r\n\r\n//=== { TJvPageProxy } =======================================================\r\n\r\nconstructor TJvPageProxy.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FPageName := '';\r\nend;\r\n\r\ndestructor TJvPageProxy.Destroy;\r\nbegin\r\n if FPageManager <> nil then\r\n FPageManager.RemoveProxy(Self);\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJvPageProxy.GetPageName: string;\r\nbegin\r\n Result := FPageName;\r\nend;\r\n\r\nprocedure TJvPageProxy.SetPageName(const Value: string);\r\nbegin\r\n if (FPageManager <> nil) and (FPageManager.PageOwner <> nil) then\r\n begin\r\n if (FPageManager.PageOwner.Pages.IndexOf(Value) >= 0) then\r\n FPageName := Value\r\n else\r\n FPageName := '';\r\n end\r\n else\r\n FPageName := Value;\r\nend;\r\n\r\nprocedure TJvPageProxy.SetPageManager(Value: TJvPageManager);\r\nbegin\r\n if FPageManager <> nil then\r\n FPageManager.RemoveProxy(Self);\r\n if Value <> nil then\r\n Value.AddProxy(Self);\r\nend;\r\n\r\nfunction TJvPageProxy.HasParent: Boolean;\r\nbegin\r\n Result := True;\r\nend;\r\n\r\nfunction TJvPageProxy.GetParentComponent: TComponent;\r\nbegin\r\n Result := FPageManager;\r\nend;\r\n\r\nprocedure TJvPageProxy.SetParentComponent(Value: TComponent);\r\nbegin\r\n if FPageManager <> nil then\r\n FPageManager.RemoveProxy(Self);\r\n if (Value <> nil) and (Value is TJvPageManager) then\r\n PageManager := TJvPageManager(Value);\r\nend;\r\n\r\nprocedure TJvPageProxy.PageEnter(Next: Boolean);\r\nbegin\r\n if Assigned(FOnEnter) then\r\n FOnEnter(Next);\r\nend;\r\n\r\nprocedure TJvPageProxy.PageLeave(Next: Boolean);\r\nbegin\r\n if Assigned(FOnLeave) then\r\n FOnLeave(Next);\r\nend;\r\n\r\nprocedure TJvPageProxy.PageShow(Next: Boolean);\r\nbegin\r\n if Assigned(FOnShow) then\r\n FOnShow(Next);\r\nend;\r\n\r\nprocedure TJvPageProxy.PageHide(Next: Boolean);\r\nbegin\r\n if Assigned(FOnHide) then\r\n FOnHide(Next);\r\nend;\r\n\r\n//=== { TJvPageManager } =====================================================\r\n\r\nconstructor TJvPageManager.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FPageProxies := TList.Create;\r\n FPageHistory := TJvPageHistory.Create;\r\n FHistoryCommand := hcAdd;\r\n FSetStartPage := True;\r\n FChangeHelpContext := True;\r\n FUseHistory := False;\r\n if not Registered then\r\n begin\r\n RegisterClasses([TJvPageProxy]);\r\n Registered := True;\r\n end;\r\nend;\r\n\r\ndestructor TJvPageManager.Destroy;\r\nbegin\r\n DestroyProxies;\r\n FPageProxies.Free;\r\n FPageHistory.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvPageManager.Loaded;\r\nvar\r\n Loading: Boolean;\r\nbegin\r\n Loading := csLoading in ComponentState;\r\n inherited Loaded;\r\n if not (csDesigning in ComponentState) and Loading then\r\n begin\r\n SyncBtnClick(0, True);\r\n SyncBtnClick(1, True);\r\n end;\r\n if FSetStartPage and not (csDesigning in ComponentState) and\r\n (FPageOwner <> nil) and (FPageProxies.Count > 0) then\r\n begin\r\n if (FPageProxies.Items[0] <> nil) and\r\n (TJvPageProxy(FPageProxies.Items[0]).PageName <> '') then\r\n begin\r\n FPageOwner.ActivePage := TJvPageProxy(FPageProxies.Items[0]).PageName;\r\n end;\r\n end;\r\n if DestroyHandles then\r\n DormantPages;\r\n if (FPageOwner <> nil) and (FPageHistory.Count = 0) then\r\n FPageHistory.AddPageIndex(FPageOwner.PageIndex);\r\n CheckBtnEnabled;\r\nend;\r\n\r\nprocedure TJvPageManager.Notification(AComponent: TComponent; AOperation: TOperation);\r\nbegin\r\n inherited Notification(AComponent, AOperation);\r\n if AOperation = opRemove then\r\n begin\r\n if AComponent = PageOwner then\r\n PageOwner := nil\r\n else\r\n if AComponent = FButtons[False] then\r\n FButtons[False] := nil\r\n else\r\n if AComponent = FButtons[True] then\r\n FButtons[True] := nil;\r\n end;\r\nend;\r\n\r\nfunction TJvPageManager.GetButton(Index: Integer): TControl;\r\nbegin\r\n Result := FButtons[Boolean(Index)];\r\nend;\r\n\r\nprocedure TJvPageManager.SetButton(Index: Integer; Value: TControl);\r\nbegin\r\n if GetButton(Index) <> Value then\r\n begin\r\n if not (csLoading in ComponentState) then\r\n SyncBtnClick(Index, False);\r\n ReplaceComponentReference(Self, Value, tComponent(FButtons[Boolean(Index)]));\r\n if not (csLoading in ComponentState) then\r\n SyncBtnClick(Index, True);\r\n end;\r\nend;\r\n\r\nprocedure TJvPageManager.SyncBtnClick(Index: Integer; Sync: Boolean);\r\nbegin\r\n if (GetButton(Index) <> nil) and not (csDesigning in ComponentState) then\r\n if Sync then\r\n begin\r\n FSaveBtnClick[Boolean(Index)] := TButton(GetButton(Index)).OnClick;\r\n TButton(GetButton(Index)).OnClick := BtnClick;\r\n end\r\n else\r\n begin\r\n TButton(GetButton(Index)).OnClick := FSaveBtnClick[Boolean(Index)];\r\n FSaveBtnClick[Boolean(Index)] := nil;\r\n end;\r\nend;\r\n\r\nprocedure TJvPageManager.BtnClick(Sender: TObject);\r\nvar\r\n Next: Boolean;\r\nbegin\r\n for Next := False to True do\r\n if Sender = FButtons[Next] then\r\n begin\r\n ChangePage(Next);\r\n if Assigned(FSaveBtnClick[Next]) then\r\n FSaveBtnClick[Next](Sender);\r\n end;\r\nend;\r\n\r\nprocedure TJvPageManager.CheckBtnEnabled;\r\nbegin\r\n if not (csDesigning in ComponentState) then\r\n begin\r\n if GetButton(0) <> nil then\r\n begin\r\n if GetButton(0).Action <> nil then\r\n TAction(GetButton(0).Action).Enabled := PriorEnabled\r\n else\r\n GetButton(0).Enabled := PriorEnabled;\r\n end;\r\n if GetButton(1) <> nil then\r\n begin\r\n if GetButton(1).Action <> nil then\r\n TAction(GetButton(1).Action).Enabled := NextEnabled\r\n else\r\n GetButton(1).Enabled := NextEnabled;\r\n end;\r\n if Assigned(FOnCheckButtons) then\r\n FOnCheckButtons(Self);\r\n end;\r\nend;\r\n\r\nprocedure TJvPageManager.GetChildren(Proc: TGetChildProc; Root: TComponent);\r\nvar\r\n I: Integer;\r\nbegin\r\n inherited GetChildren(Proc, Root);\r\n for I := 0 to FPageProxies.Count - 1 do\r\n Proc(TJvPageProxy(FPageProxies.Items[I]));\r\nend;\r\n\r\nprocedure TJvPageManager.SetDestroyHandles(Value: Boolean);\r\nbegin\r\n if Value <> FDestroyHandles then\r\n begin\r\n FDestroyHandles := Value;\r\n if not (csLoading in ComponentState) and FDestroyHandles then\r\n DormantPages;\r\n end;\r\nend;\r\n\r\nprocedure TJvPageManager.SetPageOwner(Value: TPageOwner);\r\nbegin\r\n if ReplaceComponentReference(Self, Value, tComponent(FPageOwner)) then\r\n begin\r\n if not (csLoading in ComponentState) then\r\n begin\r\n Resync;\r\n if FDestroyHandles then\r\n DormantPages;\r\n if (FPageOwner <> nil) and (FPageHistory.Count = 0) then\r\n begin\r\n FPageHistory.AddPageIndex(FPageOwner.PageIndex);\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvPageManager.SetPageProxies(Value: TList);\r\nbegin\r\n // without this method the ObjectInspector will not show the property\r\nend;\r\n\r\nfunction TJvPageManager.GetProxyIndex(const PageName: string): Integer;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := -1;\r\n for I := 0 to FPageProxies.Count - 1 do\r\n begin\r\n if TJvPageProxy(FPageProxies.Items[I]).PageName = PageName then\r\n begin\r\n Result := I;\r\n Exit;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvPageManager.Resync;\r\nvar\r\n I: Integer;\r\n Index: Integer;\r\n NewCount: Integer;\r\n NewProxy: TJvPageProxy;\r\nbegin\r\n if FPageOwner = nil then\r\n Exit;\r\n if PageCount > FPageProxies.Count then\r\n begin\r\n NewCount := PageCount - FPageProxies.Count;\r\n for I := 1 to NewCount do\r\n begin\r\n NewProxy := TJvPageProxy.Create(Owner);\r\n AddProxy(NewProxy);\r\n if Assigned(FOnCheckProxy) then\r\n FOnCheckProxy(NewProxy);\r\n {NewProxy.Name := GetUniqueName(NewProxy);}\r\n NewProxy.PageName := FindFreePage;\r\n end;\r\n end;\r\n for I := FPageProxies.Count - 1 downto 0 do\r\n begin\r\n if FPageProxies.Count > PageCount then\r\n begin\r\n if (TJvPageProxy(FPageProxies.Items[I]).PageName <> '') and\r\n (FPageOwner.Pages.IndexOf(TJvPageProxy(FPageProxies.Items[I]).PageName) = -1) then\r\n TJvPageProxy(FPageProxies.Items[I]).Free;\r\n end\r\n else\r\n Break;\r\n end;\r\n for I := 0 to FPageProxies.Count - 1 do\r\n if Assigned(FOnCheckProxy) then\r\n FOnCheckProxy(TObject(FPageProxies.Items[I]));\r\n for I := 0 to PageCount - 1 do\r\n begin\r\n Index := GetProxyIndex(PageNames[I]);\r\n if Index <> -1 then\r\n FPageProxies.Move(Index, I);\r\n end;\r\nend;\r\n\r\nprocedure TJvPageManager.AddProxy(Proxy: TJvPageProxy);\r\nbegin\r\n FPageProxies.Add(Proxy);\r\n Proxy.FPageManager := Self;\r\nend;\r\n\r\nprocedure TJvPageManager.RemoveProxy(Proxy: TJvPageProxy);\r\nbegin\r\n Proxy.FPageManager := nil;\r\n FPageProxies.Remove(Proxy);\r\nend;\r\n\r\nprocedure TJvPageManager.DestroyProxies;\r\nvar\r\n Proxy: TJvPageProxy;\r\nbegin\r\n while FPageProxies.Count > 0 do\r\n begin\r\n Proxy := TJvPageProxy(FPageProxies.Last);\r\n RemoveProxy(Proxy);\r\n Proxy.Free;\r\n end;\r\nend;\r\n\r\nfunction TJvPageManager.GetPageCount: Integer;\r\nbegin\r\n Result := 0;\r\n if FPageOwner <> nil then\r\n Result := FPageOwner.Pages.Count;\r\nend;\r\n\r\nfunction TJvPageManager.GetPageName(Index: Integer): string;\r\nbegin\r\n Result := '';\r\n if (FPageOwner <> nil) and (Index < PageCount) then\r\n Result := FPageOwner.Pages[Index];\r\nend;\r\n\r\nfunction TJvPageManager.FindFreePage: string;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := '';\r\n if PageOwner <> nil then\r\n for I := 0 to PageOwner.Pages.Count - 1 do\r\n if GetProxyIndex(PageOwner.Pages[I]) = -1 then\r\n begin\r\n Result := PageOwner.Pages[I];\r\n Exit;\r\n end;\r\nend;\r\n\r\nfunction TJvPageManager.GetPageIndex: Integer;\r\nbegin\r\n if PageOwner <> nil then\r\n Result := PageOwner.PageIndex\r\n else\r\n Result := PageNull;\r\nend;\r\n\r\nprocedure TJvPageManager.SetPageIndex(Value: Integer);\r\nvar\r\n Page: TPageItem;\r\n OldPageIndex: Integer;\r\nbegin\r\n if PageOwner <> nil then\r\n begin\r\n OldPageIndex := PageOwner.PageIndex;\r\n PageOwner.PageIndex := Value;\r\n if DestroyHandles then\r\n DormantPages;\r\n if OldPageIndex <> PageOwner.PageIndex then\r\n begin\r\n if not FUseHistory then\r\n begin\r\n PageHistory.AddPageIndex(PageOwner.PageIndex);\r\n end\r\n else\r\n begin\r\n case HistoryCommand of\r\n hcNone:\r\n ;\r\n hcAdd:\r\n PageHistory.AddPageIndex(PageOwner.PageIndex);\r\n hcBack:\r\n PageHistory.Current := PageHistory.Current - 1;\r\n hcForward:\r\n PageHistory.Current := PageHistory.Current + 1;\r\n hcGoto:\r\n ;\r\n end;\r\n end;\r\n end;\r\n HistoryCommand := hcAdd;\r\n CheckBtnEnabled;\r\n { update owner form help context }\r\n if FChangeHelpContext and (Owner <> nil) and (Owner is TForm) and\r\n ((Owner as TForm).HelpContext = 0) then\r\n begin\r\n Page := TPageItem(PageOwner.Pages.Objects[PageIndex]);\r\n if Page <> nil then\r\n (Owner as TForm).HelpContext := Page.HelpContext;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJvPageManager.GetNextEnabled: Boolean;\r\nbegin\r\n Result := GetNextPageIndex(PageIndex) >= 0;\r\nend;\r\n\r\nfunction TJvPageManager.GetPriorEnabled: Boolean;\r\nbegin\r\n Result := GetPriorPageIndex(PageIndex) >= 0;\r\nend;\r\n\r\nprocedure TJvPageManager.NextPage;\r\nbegin\r\n ChangePage(True);\r\nend;\r\n\r\nprocedure TJvPageManager.PriorPage;\r\nbegin\r\n ChangePage(False);\r\nend;\r\n\r\nprocedure TJvPageManager.GotoHistoryPage(HistoryIndex: Integer);\r\nvar\r\n SaveCurrent: Integer;\r\nbegin\r\n SaveCurrent := PageHistory.Current;\r\n HistoryCommand := hcGoto;\r\n PageHistory.Current := HistoryIndex;\r\n try\r\n SetPage(PageHistory.PageIndexes[HistoryIndex], False);\r\n finally\r\n if PageOwner.PageIndex <> PageHistory.PageIndexes[HistoryIndex] then\r\n PageHistory.Current := SaveCurrent;\r\n end;\r\nend;\r\n\r\nprocedure TJvPageManager.PageEnter(Page: Integer; Next: Boolean);\r\nvar\r\n ProxyIndex: Integer;\r\nbegin\r\n ProxyIndex := GetProxyIndex(PageOwner.Pages.Strings[Page]);\r\n if ProxyIndex <> PageNull then\r\n begin\r\n TJvPageProxy(FPageProxies.Items[ProxyIndex]).PageEnter(Next);\r\n end;\r\nend;\r\n\r\nprocedure TJvPageManager.PageLeave(Page: Integer; Next: Boolean);\r\nvar\r\n ProxyIndex: Integer;\r\nbegin\r\n ProxyIndex := GetProxyIndex(PageOwner.Pages.Strings[Page]);\r\n if ProxyIndex <> PageNull then\r\n TJvPageProxy(FPageProxies.Items[ProxyIndex]).PageLeave(Next);\r\nend;\r\n\r\nprocedure TJvPageManager.PageShow(Page: Integer; Next: Boolean);\r\nvar\r\n ProxyIndex: Integer;\r\nbegin\r\n ProxyIndex := GetProxyIndex(PageOwner.Pages.Strings[Page]);\r\n if ProxyIndex <> PageNull then\r\n TJvPageProxy(FPageProxies.Items[ProxyIndex]).PageShow(Next);\r\nend;\r\n\r\nprocedure TJvPageManager.PageHide(Page: Integer; Next: Boolean);\r\nvar\r\n ProxyIndex: Integer;\r\nbegin\r\n ProxyIndex := GetProxyIndex(PageOwner.Pages.Strings[Page]);\r\n if ProxyIndex <> PageNull then\r\n TJvPageProxy(FPageProxies.Items[ProxyIndex]).PageHide(Next);\r\nend;\r\n\r\nprocedure TJvPageManager.PageChanged;\r\nbegin\r\n if Assigned(FOnPageChanged) then\r\n FOnPageChanged(Self);\r\nend;\r\n\r\nfunction TJvPageManager.GetPriorPageIndex(Page: Integer): Integer;\r\nbegin\r\n if not FUseHistory then\r\n begin\r\n if Page < 1 then\r\n Result := PageNull\r\n else\r\n Result := Page - 1;\r\n end\r\n else\r\n begin\r\n if PageHistory.Current < 1 then\r\n Result := PageNull\r\n else\r\n Result := PageHistory.PageIndexes[PageHistory.Current - 1];\r\n end;\r\n if Assigned(FOnGetPriorPage) then\r\n FOnGetPriorPage(Page, Result);\r\nend;\r\n\r\nfunction TJvPageManager.GetNextPageIndex(Page: Integer): Integer;\r\nbegin\r\n if not FUseHistory then\r\n begin\r\n if Page >= PageCount - 1 then\r\n Result := PageNull\r\n else\r\n Result := Page + 1;\r\n end\r\n else\r\n begin\r\n if PageHistory.Current >= PageHistory.Count - 1 then\r\n Result := PageNull\r\n else\r\n Result := PageHistory.PageIndexes[PageHistory.Current + 1];\r\n end;\r\n if Assigned(FOnGetNextPage) then\r\n FOnGetNextPage(Page, Result);\r\nend;\r\n\r\nprocedure TJvPageManager.SetPage(NewPageIndex: Integer; Next: Boolean);\r\nvar\r\n OldPageIndex: Integer;\r\nbegin\r\n if (NewPageIndex >= 0) and (NewPageIndex < PageCount) then\r\n begin\r\n OldPageIndex := PageIndex;\r\n PageLeave(OldPageIndex, Next);\r\n PageEnter(NewPageIndex, Next);\r\n SetPageIndex(NewPageIndex);\r\n if NewPageIndex = PageIndex then\r\n begin\r\n PageHide(OldPageIndex, Next);\r\n PageShow(NewPageIndex, Next);\r\n PageChanged;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvPageManager.ChangePage(Next: Boolean);\r\nvar\r\n NewPageIndex: Integer;\r\nbegin\r\n if Next then\r\n begin\r\n NewPageIndex := GetNextPageIndex(PageIndex);\r\n HistoryCommand := hcForward;\r\n end\r\n else\r\n begin\r\n NewPageIndex := GetPriorPageIndex(PageIndex);\r\n HistoryCommand := hcBack;\r\n end;\r\n SetPage(NewPageIndex, Next);\r\nend;\r\n\r\ntype\r\n TWinControlAccessProtected = class(TWinControl);\r\n\r\nprocedure TJvPageManager.DormantPages;\r\nvar\r\n I: Integer;\r\nbegin\r\n if Assigned(FPageOwner) then\r\n with PageOwner do\r\n begin\r\n for I := 0 to Pages.Count - 1 do\r\n if PageIndex <> I then\r\n TWinControlAccessProtected(Pages.Objects[I]).DestroyHandle;\r\n end;\r\nend;\r\n\r\n//=== { TJvPageHistory } =====================================================\r\n\r\nconstructor TJvPageHistory.Create;\r\nbegin\r\n inherited Create;\r\n FCurrent := -1;\r\n FHistoryCapacity := 10;\r\nend;\r\n\r\ndestructor TJvPageHistory.Destroy;\r\nbegin\r\n ResetHistory;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvPageHistory.SetCurrent(Value: Integer);\r\nbegin\r\n if Value < 0 then\r\n Value := -1;\r\n if Value > Count - 1 then\r\n Value := Count - 1;\r\n FCurrent := Value;\r\nend;\r\n\r\nprocedure TJvPageHistory.SetHistoryCapacity(Value: Integer);\r\nvar\r\n I: Integer;\r\nbegin\r\n if Value < FHistoryCapacity then\r\n begin\r\n for I := 0 to Count - Value do\r\n DeleteHistoryItem(0);\r\n end;\r\n FHistoryCapacity := Value;\r\nend;\r\n\r\nfunction TJvPageHistory.GetPageIndex(Index: Integer): Integer;\r\nbegin\r\n Result := TJvPageHistoryItem(Items[Index]).Index;\r\nend;\r\n\r\nprocedure TJvPageHistory.AddPageIndex(PageIndex: Integer);\r\nvar\r\n I: Integer;\r\n Item: TJvPageHistoryItem;\r\nbegin\r\n for I := Count - 1 downto Current + 1 do\r\n DeleteHistoryItem(I);\r\n for I := 0 to Count - HistoryCapacity do\r\n DeleteHistoryItem(0);\r\n if Count < HistoryCapacity then\r\n begin\r\n Item := TJvPageHistoryItem.Create;\r\n Item.Index := PageIndex;\r\n Add(Item);\r\n end;\r\n Current := Count - 1;\r\nend;\r\n\r\nprocedure TJvPageHistory.DeleteHistoryItem(Index: Integer);\r\nvar\r\n Item: TJvPageHistoryItem;\r\nbegin\r\n if (Index >= 0) and (Index < Count) then\r\n begin\r\n Item := TJvPageHistoryItem(Items[Index]);\r\n Delete(Index);\r\n Item.Free;\r\n if Current > Count - 1 then\r\n Current := Count - 1;\r\n end;\r\nend;\r\n\r\nprocedure TJvPageHistory.ResetHistory;\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := Count - 1 downto 0 do\r\n DeleteHistoryItem(I);\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvPageScroller.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvPageScroller.PAS, released on 2001-02-28.\r\n\r\nThe Initial Developer of the Original Code is Sbastien Buysse [sbuysse att buypin dott com]\r\nPortions created by Sbastien Buysse are Copyright (C) 2001 Sbastien Buysse.\r\nAll Rights Reserved.\r\n\r\nContributor(s): Michael Beck [mbeck att bigfoot dott com].\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvPageScroller.pas 13104 2011-09-07 06:50:43Z obones $\r\n\r\nunit JvPageScroller;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, Messages, Graphics, Controls, Forms, ComCtrls,\r\n SysUtils, Classes,\r\n JvExComCtrls;\r\n\r\ntype\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvPageScroller = class(TJvExPageScroller)\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n published\r\n property HintColor;\r\n property OnMouseEnter;\r\n property OnMouseLeave;\r\n property OnParentColorChange;\r\n property OnMouseDown;\r\n property OnMouseMove;\r\n property OnMouseUp;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvPageScroller.pas $';\r\n Revision: '$Revision: 13104 $';\r\n Date: '$Date: 2011-09-07 08:50:43 +0200 (mer. 07 sept. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n JvThemes;\r\n\r\nconstructor TJvPageScroller.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n ControlStyle := ControlStyle + [csAcceptsControls];\r\n IncludeThemeStyle(Self, [csParentBackground]);\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvPageSetup.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvPageSetup.PAS, released on 2000-07-25.\r\n\r\nThe Initial Developer of the Original Code is Pasha Sivtsov [psivtsov att mail dott ru]\r\nPortions created by Pasha Sivtsov are Copyright (C) 2000 Pasha Sivtsov.\r\nAll Rights Reserved.\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvPageSetup.pas 13397 2012-08-16 17:23:19Z ahuser $\r\n\r\nunit JvPageSetup;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, Classes, Messages, Graphics, CommDlg, Dialogs,\r\n JclBase,\r\n JvBaseDlg;\r\n\r\nconst\r\n // Internal events\r\n CM_PAINTINIT = WM_USER + 10;\r\n CM_PAINTPAGE = WM_USER + 11;\r\n\r\n // masks for separation of parameters from TJvPSPaintEvent.aFlags\r\n PRINTER_MASK = $00000002;\r\n ORIENT_MASK = $00000004;\r\n PAPER_MASK = $00000008;\r\n\r\ntype\r\n // Available options\r\n TJvPageSetupFlags =\r\n (poDefaultMinMargins, poMargins, poMinMargins, poDisableMargins,\r\n poDisableOrientation, poDisablePagePainting, poDisablePaper, poDisablePrinter,\r\n poHundredthsOfMillimeters, poThousandthsOfInches, poNoWarning);\r\n TJvPageOptions = set of TJvPageSetupFlags;\r\n\r\n // Areas of drawing\r\n TJvPSPaintWhat =\r\n (pwFullPage, pwMinimumMargins,\r\n pwMargins, pwGreekText,\r\n pwEnvStamp, pwYAFullPage);\r\n\r\n TJvMarginSize = class(TPersistent)\r\n private\r\n FMargin: TRect;\r\n procedure AssignError;\r\n function GetValue(Index: Integer): Integer;\r\n procedure SetValue(Index: Integer; Value: Integer);\r\n procedure SetRect(const Value: TRect);\r\n protected\r\n procedure AssignTo(Dest: TPersistent); override;\r\n public\r\n function IsNull: Boolean;\r\n function MarginsEqu(AMargin: TJvMarginSize): Boolean;\r\n property AsRect: TRect read FMargin write SetRect;\r\n published\r\n property Left: Integer index 0 read GetValue write SetValue stored False;\r\n property Top: Integer index 1 read GetValue write SetValue stored False;\r\n property Right: Integer index 2 read GetValue write SetValue stored False;\r\n property Bottom: Integer index 3 read GetValue write SetValue stored False;\r\n end;\r\n\r\n TJvPageSetupDialog = class;\r\n\r\n TJvPSPaintEvent = procedure(Sender: TJvPageSetupDialog; Paper, Flags: Integer;\r\n PageSetupRec: TPageSetupDlg; PaintWhat: TJvPSPaintWhat; Canvas: TCanvas;\r\n Rect: TRect; var NoDefaultPaint: Boolean) of object;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvPageSetupDialog = class(TJvCommonDialog)\r\n private\r\n FOptions: TJvPageOptions;\r\n FFlags: DWORD;\r\n FMargin: TJvMarginSize;\r\n FMinMargin: TJvMarginSize;\r\n FPaperSize: TPoint;\r\n FOnPrinter: TNotifyEvent;\r\n FOnPaint: TJvPSPaintEvent;\r\n FInitPaper: Integer;\r\n FInitFlags: Integer;\r\n FPageSetupRec: TPageSetupDlg;\r\n FPaintWhat: TJvPSPaintWhat;\r\n procedure SetOptions(Value: TJvPageOptions);\r\n function DoExecute(ParentWnd: HWND; Show: Boolean): Boolean;\r\n procedure ReadMargin(AMargin: TJvMarginSize; Reader: TReader);\r\n procedure WriteMargin(AMargin: TJvMarginSize; Writer: TWriter);\r\n procedure ReadValues(AReader: TReader);\r\n procedure WriteValues(AWriter: TWriter);\r\n procedure ReadMinValues(AReader: TReader);\r\n procedure WriteMinValues(AWriter: TWriter);\r\n procedure WMHelp(var Msg: TWMHelp); message WM_HELP;\r\n procedure WMCommand(var Msg: TWMCommand); message WM_COMMAND;\r\n procedure WMPaintInit(var Msg: TMessage); message CM_PAINTINIT;\r\n procedure WMPaintPage(var Msg: TMessage); message CM_PAINTPAGE;\r\n protected\r\n procedure DefineProperties(AFiler: TFiler); override;\r\n function DoPrinter: Boolean; virtual;\r\n function DoPaint(InitPaper, InitFlags: Integer; PageSetupRec: TPageSetupDlg;\r\n PaintWhat: TJvPSPaintWhat; Canvas: TCanvas; Rect: TRect): Boolean; virtual;\r\n function TaskModalDialog(DialogFunc: Pointer; var DialogData): Bool; override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n function Execute(ParentWnd: HWND): Boolean; overload; override;\r\n procedure GetDefaults; virtual;\r\n property PaperSize: TPoint read FPaperSize;\r\n published\r\n property Margin: TJvMarginSize read FMargin;\r\n property MinMargin: TJvMarginSize read FMinMargin;\r\n property Options: TJvPageOptions read FOptions write SetOptions\r\n default [poDefaultMinMargins, poHundredthsOfMillimeters];\r\n property OnPaint: TJvPSPaintEvent read FOnPaint write FOnPaint;\r\n property OnPrinter: TNotifyEvent read FOnPrinter write FOnPrinter;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvPageSetup.pas $';\r\n Revision: '$Revision: 13397 $';\r\n Date: '$Date: 2012-08-16 19:23:19 +0200 (jeu. 16 août 2012) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n SysUtils, Controls, Forms, Printers,\r\n JvJCLUtils, JvResources;\r\n\r\n//=== { TJvMarginSize } ======================================================\r\n\r\nprocedure TJvMarginSize.AssignError;\r\nbegin\r\n raise ERangeError.CreateRes(@RsEInvalidValue);\r\nend;\r\n\r\nprocedure TJvMarginSize.AssignTo(Dest: TPersistent);\r\nbegin\r\n if Dest is TJvMarginSize then\r\n with Dest as TJvMarginSize do\r\n FMargin := Self.FMargin\r\n else\r\n inherited AssignTo(Dest);\r\nend;\r\n\r\nfunction TJvMarginSize.IsNull: Boolean;\r\nbegin\r\n with FMargin do\r\n Result := (Left = 0) and (Top = 0) and (Right = 0) and (Bottom = 0);\r\nend;\r\n\r\nfunction TJvMarginSize.MarginsEqu(AMargin: TJvMarginSize): Boolean;\r\nbegin\r\n Result := (FMargin.Left = AMargin.Left) and (FMargin.Top = AMargin.Top) and\r\n (FMargin.Right = AMargin.Right) and (FMargin.Bottom = AMargin.Bottom);\r\nend;\r\n\r\nfunction TJvMarginSize.GetValue(Index: Integer): Integer;\r\nbegin\r\n case Index of\r\n 0:\r\n Result := FMargin.Left;\r\n 1:\r\n Result := FMargin.Top;\r\n 2:\r\n Result := FMargin.Right;\r\n else\r\n Result := FMargin.Bottom;\r\n end;\r\nend;\r\n\r\nprocedure TJvMarginSize.SetValue(Index: Integer; Value: Integer);\r\nbegin\r\n if Value < 0 then\r\n AssignError;\r\n case Index of\r\n 0:\r\n FMargin.Left := Value;\r\n 1:\r\n FMargin.Top := Value;\r\n 2:\r\n FMargin.Right := Value;\r\n else\r\n FMargin.Bottom := Value;\r\n end;\r\nend;\r\n\r\nprocedure TJvMarginSize.SetRect(const Value: TRect);\r\nbegin\r\n if (Value.Left < 0) or (Value.Top < 0) or (Value.Right < 0) or (Value.Bottom < 0) then\r\n AssignError;\r\n FMargin := Value;\r\nend;\r\n\r\n{ Private globals - some routines copied from dialogs.pas }\r\n\r\ntype\r\n {$IFDEF COMPILER12_UP}\r\n THackCommonDialog = class(TComponent)\r\n public\r\n FCtl3D: Boolean;\r\n FHelpContext: THelpContext;\r\n FHandle: HWND;\r\n FRedirector: TWinControl;\r\n FTemplateModule: HINST;\r\n FOnClose: TNotifyEvent;\r\n FOnShow: TNotifyEvent;\r\n FDefWndProc: Pointer;\r\n FObjectInstance: Pointer;\r\n end;\r\n {$ELSE}\r\n THackCommonDialog = class(TComponent)\r\n public\r\n FCtl3D: Boolean;\r\n FDefWndProc: Pointer;\r\n FHelpContext: THelpContext;\r\n FHandle: HWND;\r\n {$IFDEF COMPILER9_UP} // Delphi 2005+\r\n FRedirector: TWinControl;\r\n {$ENDIF COMPILER9_UP}\r\n FObjectInstance: Pointer;\r\n end;\r\n {$ENDIF COMPILER12_UP}\r\n\r\nvar\r\n CreationControl: TCommonDialog = nil;\r\n PageSetupControl: TJvPageSetupDialog = nil;\r\n\r\n// Center the given window on the screen - D3/D4/D5\r\n\r\nprocedure CenterWindow(Wnd: HWND);\r\nvar\r\n Rect: TRect;\r\n Monitor: TMonitor;\r\nbegin\r\n GetWindowRect(Wnd, Rect);\r\n if Application.MainForm <> nil then\r\n Monitor := Application.MainForm.Monitor\r\n else\r\n Monitor := Screen.Monitors[0];\r\n SetWindowPos(Wnd, 0,\r\n Monitor.Left + ((Monitor.Width - Rect.Right + Rect.Left) div 2),\r\n Monitor.Top + ((Monitor.Height - Rect.Bottom + Rect.Top) div 3),\r\n 0, 0, SWP_NOACTIVATE or SWP_NOSIZE or SWP_NOZORDER);\r\nend;\r\n\r\n// Generic dialog hook. Centers the dialog on the screen in response to\r\n// the WM_INITDIALOG message\r\n\r\nfunction DialogHook(Wnd: HWND; Msg: UINT; AWParam: WPARAM; ALParam: LPARAM): UINT_PTR; stdcall;\r\nbegin\r\n Result := 0;\r\n if Msg = WM_INITDIALOG then\r\n begin\r\n CenterWindow(Wnd);\r\n THackCommonDialog(CreationControl).FHandle := Wnd;\r\n THackCommonDialog(CreationControl).FDefWndProc :=\r\n Pointer(SetWindowLongPtr(Wnd, GWL_WNDPROC, LONG_PTR(THackCommonDialog(CreationControl).FObjectInstance)));\r\n CallWindowProc(THackCommonDialog(CreationControl).FObjectInstance, Wnd, Msg, AWParam, ALParam);\r\n CreationControl := nil;\r\n end;\r\nend;\r\n\r\nfunction PageDrawHook(Wnd: HWND; Msg: UINT; AWParam: WPARAM; ALParam: LPARAM): UINT_PTR; stdcall;\r\nconst\r\n PagePaintWhat: array [WM_PSD_FULLPAGERECT..WM_PSD_YAFULLPAGERECT] of TJvPSPaintWhat =\r\n (pwFullPage, pwMinimumMargins, pwMargins,\r\n pwGreekText, pwEnvStamp, pwYAFullPage);\r\nbegin\r\n case Msg of\r\n WM_PSD_PAGESETUPDLG:\r\n Result := SendMessage(PageSetupControl.Handle, CM_PAINTINIT, AWParam, ALParam);\r\n WM_PSD_FULLPAGERECT, WM_PSD_MINMARGINRECT, WM_PSD_MARGINRECT,\r\n WM_PSD_GREEKTEXTRECT, WM_PSD_ENVSTAMPRECT, WM_PSD_YAFULLPAGERECT:\r\n begin\r\n PageSetupControl.FPaintWhat := PagePaintWhat[Msg];\r\n Result := SendMessage(PageSetupControl.Handle, CM_PAINTPAGE, AWParam, ALParam);\r\n end;\r\n else\r\n Result := 0;\r\n end;\r\nend;\r\n\r\n{ Printer dialog routines }\r\n\r\nprocedure GetPrinter(var DeviceMode, DeviceNames: THandle);\r\nvar\r\n Device, Driver, Port: array [0..79] of Char;\r\n DevNames: PDevNames;\r\n Offset: PChar;\r\nbegin\r\n Printer.GetPrinter(Device, Driver, Port, DeviceMode);\r\n if DeviceMode <> 0 then\r\n begin\r\n DeviceNames := GlobalAlloc(GHND, SizeOf(Char) * (SizeOf(TDevNames) +\r\n StrLen(Device) + StrLen(Driver) + StrLen(Port) + 3));\r\n DevNames := PDevNames(GlobalLock(DeviceNames));\r\n try\r\n Offset := PChar(DevNames) + SizeOf(TDevNames);\r\n with DevNames^ do\r\n begin\r\n wDriverOffset := LONG_PTR(Offset) - LONG_PTR(DevNames);\r\n Offset := StrECopy(Offset, Driver) + 1;\r\n wDeviceOffset := LONG_PTR(Offset) - LONG_PTR(DevNames);\r\n Offset := StrECopy(Offset, Device) + 1;\r\n wOutputOffset := LONG_PTR(Offset) - LONG_PTR(DevNames);\r\n StrCopy(Offset, Port);\r\n end;\r\n finally\r\n GlobalUnlock(DeviceNames);\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure SetPrinter(DeviceMode, DeviceNames: THandle);\r\nvar\r\n DevNames: PDevNames;\r\nbegin\r\n if DeviceNames = 0 then\r\n Exit;\r\n\r\n DevNames := PDevNames(GlobalLock(DeviceNames));\r\n try\r\n with DevNames^ do\r\n Printer.SetPrinter(PChar(DevNames) + wDeviceOffset,\r\n PChar(LONG_PTR(DevNames) + wDriverOffset),\r\n PChar(LONG_PTR(DevNames) + wOutputOffset), DeviceMode);\r\n finally\r\n GlobalUnlock(DeviceNames);\r\n GlobalFree(DeviceNames);\r\n end;\r\nend;\r\n\r\nfunction CopyData(Handle: THandle): THandle;\r\nvar\r\n Src, Dest: PByte;\r\n Size: Integer;\r\nbegin\r\n if Handle <> 0 then\r\n begin\r\n Size := GlobalSize(Handle);\r\n Result := GlobalAlloc(GHND, Size);\r\n if Result <> 0 then\r\n try\r\n Src := GlobalLock(Handle);\r\n Dest := GlobalLock(Result);\r\n if (Src <> nil) and (Dest <> nil) then\r\n Move(Src^, Dest^, Size);\r\n finally\r\n GlobalUnlock(Handle);\r\n GlobalUnlock(Result);\r\n end\r\n end\r\n else\r\n Result := 0;\r\nend;\r\n\r\n//=== { TJvPageSetupDialog } =================================================\r\n\r\nconstructor TJvPageSetupDialog.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FMargin := TJvMarginSize.Create;\r\n FMinMargin := TJvMarginSize.Create;\r\n Options := [poDefaultMinMargins, poHundredthsOfMillimeters];\r\nend;\r\n\r\ndestructor TJvPageSetupDialog.Destroy;\r\nbegin\r\n FMargin.Free;\r\n FMinMargin.Free;\r\n inherited Destroy;\r\nend;\r\n\r\n// Determination of streamed properties\r\n\r\nprocedure TJvPageSetupDialog.DefineProperties(AFiler: TFiler);\r\n\r\n // Rule 1\r\n function DoWriteMargin1: Boolean;\r\n begin\r\n if AFiler.Ancestor <> nil then\r\n Result := not TJvPageSetupDialog(AFiler.Ancestor).FMargin.MarginsEqu(FMargin)\r\n else\r\n Result := (FMargin <> nil) and (not FMargin.IsNull);\r\n end;\r\n\r\n // Rule 2\r\n function DoWriteMargin2: Boolean;\r\n begin\r\n if AFiler.Ancestor <> nil then\r\n Result := not TJvPageSetupDialog(AFiler.Ancestor).FMinMargin.MarginsEqu(FMinMargin)\r\n else\r\n Result := (FMinMargin <> nil) and (not FMinMargin.IsNull);\r\n end;\r\n\r\nbegin\r\n inherited DefineProperties(AFiler);\r\n with AFiler do\r\n begin\r\n DefineProperty('MarginData', ReadValues, WriteValues, DoWriteMargin1);\r\n DefineProperty('MinMarginData', ReadMinValues, WriteMinValues, DoWriteMargin2);\r\n end;\r\nend;\r\n\r\n// Reading from stream\r\n\r\nprocedure TJvPageSetupDialog.ReadMargin(AMargin: TJvMarginSize; Reader: TReader);\r\nbegin\r\n with AMargin, Reader do\r\n begin\r\n ReadListBegin;\r\n Left := ReadInteger;\r\n Top := ReadInteger;\r\n Right := ReadInteger;\r\n Bottom := ReadInteger;\r\n ReadListEnd;\r\n end;\r\nend;\r\n\r\n// Writing to stream\r\n\r\nprocedure TJvPageSetupDialog.WriteMargin(AMargin: TJvMarginSize; Writer: TWriter);\r\nbegin\r\n with AMargin, Writer do\r\n begin\r\n WriteListBegin;\r\n WriteInteger(Left);\r\n WriteInteger(Top);\r\n WriteInteger(Right);\r\n WriteInteger(Bottom);\r\n WriteListEnd;\r\n end;\r\nend;\r\n\r\nprocedure TJvPageSetupDialog.ReadValues(AReader: TReader);\r\nbegin\r\n ReadMargin(FMargin, AReader);\r\nend;\r\n\r\nprocedure TJvPageSetupDialog.WriteValues(AWriter: TWriter);\r\nbegin\r\n WriteMargin(FMargin, AWriter);\r\nend;\r\n\r\nprocedure TJvPageSetupDialog.ReadMinValues(AReader: TReader);\r\nbegin\r\n ReadMargin(FMinMargin, AReader);\r\nend;\r\n\r\nprocedure TJvPageSetupDialog.WriteMinValues(AWriter: TWriter);\r\nbegin\r\n WriteMargin(FMinMargin, AWriter);\r\nend;\r\n\r\n// Processing Help commands\r\n\r\nprocedure TJvPageSetupDialog.WMHelp(var Msg: TWMHelp);\r\nbegin\r\n if HelpContext <> 0 then\r\n Application.HelpContext(HelpContext)\r\n else\r\n inherited;\r\nend;\r\n\r\n// Processing button\r\n\r\nprocedure TJvPageSetupDialog.WMCommand(var Msg: TWMCommand);\r\nconst\r\n IDPRINTERBTN = $0402;\r\nbegin\r\n if not ((Msg.ItemID = IDPRINTERBTN) and (Msg.NotifyCode = BN_CLICKED) and DoPrinter) then\r\n inherited;\r\nend;\r\n\r\nprocedure TJvPageSetupDialog.WMPaintInit(var Msg: TMessage);\r\nbegin\r\n FInitPaper := LoWord(Msg.WParam);\r\n FInitFlags := HiWord(Msg.WParam);\r\n FPageSetupRec := PPageSetupDlg(Msg.LParam)^;\r\n Msg.Result := Ord(not Assigned(FOnPaint));\r\nend;\r\n\r\nprocedure TJvPageSetupDialog.WMPaintPage(var Msg: TMessage);\r\nvar\r\n PaintRect: TRect;\r\n Canvas: TCanvas;\r\nbegin\r\n if Msg.LParam <> 0 then\r\n PaintRect := PRect(Msg.LParam)^\r\n else\r\n PaintRect := Rect(0, 0, 0, 0);\r\n\r\n Canvas := TCanvas.Create;\r\n Canvas.Handle := HDC(Msg.WParam);\r\n try\r\n Msg.Result := Ord(DoPaint(FInitPaper, FInitFlags, FPageSetupRec,\r\n FPaintWhat, Canvas, PaintRect));\r\n finally\r\n Canvas.Free;\r\n end;\r\nend;\r\n\r\nfunction TJvPageSetupDialog.DoPrinter: Boolean;\r\nbegin\r\n Result := Assigned(FOnPrinter);\r\n if Result then\r\n FOnPrinter(Self);\r\nend;\r\n\r\nfunction TJvPageSetupDialog.DoPaint(InitPaper, InitFlags: Integer;\r\n PageSetupRec: TPageSetupDlg; PaintWhat: TJvPSPaintWhat; Canvas: TCanvas;\r\n Rect: TRect): Boolean;\r\nbegin\r\n Result := False;\r\n if Assigned(FOnPaint) then\r\n FOnPaint(Self, InitPaper, InitFlags, PageSetupRec, PaintWhat, Canvas, Rect, Result);\r\nend;\r\n\r\n// Show modal dialog\r\n\r\nfunction TJvPageSetupDialog.TaskModalDialog(DialogFunc: Pointer; var DialogData): Bool;\r\ntype\r\n TDialogFunc = function(var ADialogData): Bool; stdcall;\r\nvar\r\n ActiveWindow: HWND;\r\n WindowList: Pointer;\r\n {$IFDEF CPU86}\r\n FPUControlWord: Word;\r\n {$ENDIF CPU86}\r\nbegin\r\n ActiveWindow := GetActiveWindow;\r\n WindowList := DisableTaskWindows(0);\r\n try\r\n Application.HookMainWindow(MessageHook);\r\n {$IFDEF CPU86}\r\n asm\r\n // Avoid FPU control word change in NETRAP.dll, NETAPI32.dll, etc\r\n FNSTCW FPUControlWord\r\n end;\r\n {$ENDIF CPU86}\r\n try\r\n CreationControl := Self;\r\n PageSetupControl := Self;\r\n Result := TDialogFunc(DialogFunc)(DialogData);\r\n finally\r\n PageSetupControl := nil;\r\n {$IFDEF CPU86}\r\n asm\r\n FNCLEX\r\n FLDCW FPUControlWord\r\n end;\r\n {$ENDIF CPU86}\r\n Application.UnhookMainWindow(MessageHook);\r\n end;\r\n finally\r\n EnableTaskWindows(WindowList);\r\n SetActiveWindow(ActiveWindow);\r\n end;\r\nend;\r\n\r\nfunction TJvPageSetupDialog.DoExecute(ParentWnd: HWND; Show: Boolean): Boolean;\r\nvar\r\n PageDlgRec: TPageSetupDlg;\r\n DevHandle: THandle;\r\n Err: Integer;\r\nbegin\r\n // fill record\r\n FillChar(PageDlgRec, SizeOf(PageDlgRec), 0);\r\n with PageDlgRec do\r\n begin\r\n lStructSize := SizeOf(PageDlgRec);\r\n hwndOwner := ParentWnd;\r\n Flags := FFlags;\r\n rtMinMargin := Rect(FMinMargin.Left, FMinMargin.Top, FMinMargin.Right,\r\n FMinMargin.Bottom);\r\n rtMargin := Rect(FMargin.Left, FMargin.Top, FMargin.Right, FMargin.Bottom);\r\n hInstance := SysInit.HInstance;\r\n if Show then\r\n begin\r\n lpfnPageSetupHook := DialogHook;\r\n Flags := FFlags or PSD_ENABLEPAGESETUPHOOK;\r\n GetPrinter(DevHandle, hDevNames);\r\n hDevMode := CopyData(DevHandle);\r\n end\r\n else\r\n Flags := Flags or PSD_RETURNDEFAULT;\r\n if Template <> nil then\r\n begin\r\n Flags := Flags or PSD_ENABLEPAGESETUPTEMPLATE;\r\n lpPageSetupTemplateName := Template;\r\n end;\r\n if Assigned(FOnPaint) then\r\n begin\r\n Flags := Flags or PSD_ENABLEPAGEPAINTHOOK;\r\n lpfnPagePaintHook := PageDrawHook;\r\n end;\r\n\r\n if Show then\r\n Result := TaskModalDialog(@PageSetupDlg, PageDlgRec)\r\n else\r\n Result := PageSetupDlg(PageDlgRec);\r\n Err := CommDlgExtendedError;\r\n\r\n if Result then\r\n SetPrinter(hDevMode, hDevNames)\r\n else\r\n begin\r\n if hDevMode <> 0 then\r\n GlobalFree(hDevMode);\r\n if hDevNames <> 0 then\r\n GlobalFree(hDevNames);\r\n end;\r\n OSCheck(Err = 0);\r\n\r\n FMargin.AsRect := rtMargin;\r\n FPaperSize := ptPaperSize;\r\n end;\r\nend;\r\n\r\nfunction TJvPageSetupDialog.Execute(ParentWnd: HWND): Boolean;\r\nbegin\r\n Result := DoExecute(ParentWnd, True);\r\nend;\r\n\r\n// Get default margin values\r\n\r\nprocedure TJvPageSetupDialog.GetDefaults;\r\nbegin\r\n DoExecute(GetActiveWindow, False);\r\nend;\r\n\r\nprocedure TJvPageSetupDialog.SetOptions(Value: TJvPageOptions);\r\nconst\r\n WinFlags: array [TJvPageSetupFlags] of DWORD =\r\n (PSD_DEFAULTMINMARGINS, PSD_MARGINS, PSD_MINMARGINS,\r\n PSD_DISABLEMARGINS, PSD_DISABLEORIENTATION,\r\n PSD_DISABLEPAGEPAINTING, PSD_DISABLEPAPER, PSD_DISABLEPRINTER,\r\n PSD_INHUNDREDTHSOFMILLIMETERS, PSD_INTHOUSANDTHSOFINCHES,\r\n PSD_NOWARNING);\r\nvar\r\n I: TJvPageSetupFlags;\r\nbegin\r\n if (poDefaultMinMargins in Value) and not (poDefaultMinMargins in FOptions) then\r\n Value := Value - [poMinMargins];\r\n if (poMinMargins in Value) and not (poMinMargins in FOptions) then\r\n Value := Value - [poDefaultMinMargins];\r\n if (poHundredthsOfMillimeters in Value) and not (poHundredthsOfMillimeters in FOptions) then\r\n Value := Value - [poThousandthsOfInches];\r\n if (poThousandthsOfInches in Value) and not (poThousandthsOfInches in FOptions) then\r\n Value := Value - [poHundredthsOfMillimeters];\r\n FOptions := Value;\r\n\r\n // set flags\r\n FFlags := 0;\r\n for I := Low(TJvPageSetupFlags) to High(TJvPageSetupFlags) do\r\n if I in FOptions then\r\n FFlags := FFlags or WinFlags[I];\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvPageSetupTitled.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvPageSetupTitled.PAS, released on 2000-07-25.\r\n\r\nThe Initial Developer of the Original Code is Pasha Sivtsov [psivtsov att mail dott ru]\r\nPortions created by Pasha Sivtsov are Copyright (C) 2000 Pasha Sivtsov.\r\nAll Rights Reserved.\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvPageSetupTitled.pas 13155 2011-11-06 12:31:20Z ahuser $\r\n\r\nunit JvPageSetupTitled;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Classes, Messages, Types,\r\n JvPageSetup;\r\n\r\ntype\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvPageSetupTitledDialog = class(TJvPageSetupDialog)\r\n private\r\n FHeader: string;\r\n FFooter: string;\r\n FHelpHeader: Integer;\r\n FHelpFooter: Integer;\r\n procedure SetEditText(EditId: Integer; Text: string);\r\n function GetEditText(EditId: Integer): string;\r\n procedure WMHelp(var Msg: TWMHelp); message WM_HELP;\r\n protected\r\n procedure DoShow; override;\r\n procedure DoClose; override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n published\r\n property PageHeader: string read FHeader write FHeader;\r\n property PageFooter: string read FFooter write FFooter;\r\n property HelpContextHeader: Integer read FHelpHeader write FHelpHeader default 0;\r\n property HelpContextFooter: Integer read FHelpFooter write FHelpFooter default 0;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvPageSetupTitled.pas $';\r\n Revision: '$Revision: 13155 $';\r\n Date: '$Date: 2011-11-06 13:31:20 +0100 (dim. 06 nov. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\n{$R JvPageSetupTitled.res}\r\n\r\nuses\r\n Windows, Forms, SysUtils;\r\n\r\nconst\r\n // dialog controls\r\n DLGHEADER = 30;\r\n DLGFOOTER = 31;\r\n DLGHEADERLABEL = 32;\r\n DLGFOOTERLABEL = 33;\r\n\r\nconstructor TJvPageSetupTitledDialog.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n Template := MakeIntResource(14); // Template id\r\nend;\r\n\r\nprocedure TJvPageSetupTitledDialog.SetEditText(EditId: Integer; Text: string);\r\nbegin\r\n SetDlgItemText(Handle, EditId, PChar(Text));\r\nend;\r\n\r\nfunction TJvPageSetupTitledDialog.GetEditText(EditId: Integer): string;\r\nvar\r\n Len: Integer;\r\nbegin\r\n Len := SendDlgItemMessage(Handle, EditId, WM_GETTEXTLENGTH, 0, 0);\r\n SetLength(Result, Len);\r\n GetDlgItemText(Handle, EditId, PChar(Result), Len + 1);\r\nend;\r\n\r\nprocedure TJvPageSetupTitledDialog.DoShow;\r\nbegin\r\n SetEditText(DLGHEADER, FHeader);\r\n SetEditText(DLGFOOTER, FFooter);\r\n inherited DoShow;\r\nend;\r\n\r\nprocedure TJvPageSetupTitledDialog.DoClose;\r\nbegin\r\n FHeader := GetEditText(DLGHEADER);\r\n FFooter := GetEditText(DLGFOOTER);\r\n inherited DoClose;\r\nend;\r\n\r\nprocedure TJvPageSetupTitledDialog.WMHelp(var Msg: TWMHelp);\r\n\r\n procedure ShowHelp(ContextID: Integer);\r\n var\r\n Pt: TSmallPoint;\r\n begin\r\n Pt := PointToSmallPoint(Msg.HelpInfo^.MousePos);\r\n Application.HelpCommand(HELP_SETPOPUP_POS, Longint(Pt));\r\n Application.HelpCommand(HELP_CONTEXTPOPUP, ContextID);\r\n end;\r\n\r\nbegin\r\n case Msg.HelpInfo^.iCtrlId of\r\n DLGHEADER, DLGHEADERLABEL:\r\n if FHelpHeader <> 0 then\r\n ShowHelp(FHelpHeader)\r\n else\r\n inherited;\r\n DLGFOOTER, DLGFOOTERLABEL:\r\n if FHelpFooter <> 0 then\r\n ShowHelp(FHelpFooter)\r\n else\r\n inherited;\r\n else\r\n inherited;\r\n end;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvPaintFX.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvPaintFX.PAS, released on 2002-06-15.\r\n\r\nThe Initial Developer of the Original Code is Jan Verhoeven [jan1 dott verhoeven att wxs dott nl]\r\nPortions created by Jan Verhoeven are Copyright (C) 2002 Jan Verhoeven.\r\nAll Rights Reserved.\r\n\r\nContributor(s): Robert Love [rlove att slcdug dott org].\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvPaintFX.pas 13104 2011-09-07 06:50:43Z obones $\r\n\r\nunit JvPaintFX;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, Messages, Graphics, Controls, Forms,\r\n SysUtils, Classes;\r\n\r\ntype\r\n // Type of a filter for use with Stretch()\r\n TFilterProc = function(Value: Single): Single;\r\n TLightBrush = (lbBrightness, lbContrast, lbSaturation,\r\n lbFisheye, lbrotate, lbtwist, lbrimple,\r\n mbHor, mbTop, mbBottom, mbDiamond, mbWaste, mbRound,\r\n mbRound2, mbSplitRound, mbSplitWaste);\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvPaintFX = class(TComponent)\r\n public\r\n class procedure Solarize(const Src: TBitmap; var Dst: TBitmap; Amount: Integer);\r\n class procedure Posterize(const Src: TBitmap; var Dst: TBitmap; Amount: Integer);\r\n class procedure Blend(const Src1, Src2: TBitmap; var Dst: TBitmap; Amount: Single);\r\n class procedure Blend2(const Src1, Src2: TBitmap; var Dst: TBitmap; Amount: Single);\r\n class procedure ExtractColor(const Dst: TBitmap; AColor: TColor);\r\n class procedure ExcludeColor(const Dst: TBitmap; AColor: TColor);\r\n class procedure Turn(Src, Dst: TBitmap);\r\n class procedure TurnRight(Src, Dst: TBitmap);\r\n class procedure HeightMap(const Dst: TBitmap; Amount: Integer);\r\n class procedure TexturizeTile(const Dst: TBitmap; Amount: Integer);\r\n class procedure TexturizeOverlap(const Dst: TBitmap; Amount: Integer);\r\n class procedure RippleRandom(const Dst: TBitmap; Amount: Integer);\r\n class procedure RippleTooth(const Dst: TBitmap; Amount: Integer);\r\n class procedure RippleTriangle(const Dst: TBitmap; Amount: Integer);\r\n class procedure Triangles(const Dst: TBitmap; Amount: Integer);\r\n class procedure DrawMandelJulia(const Dst: TBitmap; x0, y0, x1, y1: Single;\r\n Niter: Integer; Mandel: Boolean);\r\n class procedure FilterXBlue(const Dst: TBitmap; Min, Max: Integer);\r\n class procedure FilterXGreen(const Dst: TBitmap; Min, Max: Integer);\r\n class procedure FilterXRed(const Dst: TBitmap; Min, Max: Integer);\r\n class procedure FilterBlue(const Dst: TBitmap; Min, Max: Integer);\r\n class procedure FilterGreen(const Dst: TBitmap; Min, Max: Integer);\r\n class procedure FilterRed(const Dst: TBitmap; Min, Max: Integer);\r\n class procedure Emboss(var Bmp: TBitmap);\r\n class procedure Plasma(Src1, Src2, Dst: TBitmap; Scale, Turbulence: Single);\r\n class procedure Shake(Src, Dst: TBitmap; Factor: Single);\r\n class procedure ShakeDown(Src, Dst: TBitmap; Factor: Single);\r\n class procedure KeepBlue(const Dst: TBitmap; Factor: Single);\r\n class procedure KeepGreen(const Dst: TBitmap; Factor: Single);\r\n class procedure KeepRed(const Dst: TBitmap; Factor: Single);\r\n class procedure Mandelbrot(const Dst: TBitmap; Factor: Integer);\r\n class procedure MaskMandelbrot(const Dst: TBitmap; Factor: Integer);\r\n class procedure FoldRight(Src1, Src2, Dst: TBitmap; Amount: Single);\r\n class procedure QuartoOpaque(Src, Dst: TBitmap);\r\n class procedure SemiOpaque(Src, Dst: TBitmap);\r\n class procedure ShadowDownLeft(const Dst: TBitmap);\r\n class procedure ShadowDownRight(const Dst: TBitmap);\r\n class procedure ShadowUpLeft(const Dst: TBitmap);\r\n class procedure ShadowUpRight(const Dst: TBitmap);\r\n class procedure Darkness(const Dst: TBitmap; Amount: Integer);\r\n class procedure Trace(const Dst: TBitmap; Intensity: Integer);\r\n class procedure FlipRight(const Dst: TBitmap);\r\n class procedure FlipDown(const Dst: TBitmap);\r\n class procedure SpotLight(const Dst: TBitmap; Amount: Integer; Spot: TRect);\r\n class procedure SplitLight(const Dst: TBitmap; Amount: Integer);\r\n class procedure MakeSeamlessClip(var Dst: TBitmap; Seam: Integer);\r\n class procedure Wave(const Dst: TBitmap; Amount, Inference, Style: Integer);\r\n class procedure Mosaic(const Bm: TBitmap; Size: Integer);\r\n class procedure SmoothRotate(var Src, Dst: TBitmap; CX, CY: Integer; Angle: Single);\r\n class procedure SmoothResize(var Src, Dst: TBitmap);\r\n class procedure Twist(var Bmp, Dst: TBitmap; Amount: Integer);\r\n class procedure SplitBlur(const Dst: TBitmap; Amount: Integer);\r\n class procedure GaussianBlur(const Dst: TBitmap; Amount: Integer);\r\n class procedure Smooth(const Dst: TBitmap; Weight: Integer);\r\n class procedure GrayScale(const Dst: TBitmap);\r\n class procedure AddColorNoise(const Dst: TBitmap; Amount: Integer);\r\n class procedure AddMonoNoise(const Dst: TBitmap; Amount: Integer);\r\n class procedure Contrast(const Dst: TBitmap; Amount: Integer);\r\n class procedure Lightness(const Dst: TBitmap; Amount: Integer);\r\n class procedure Saturation(const Dst: TBitmap; Amount: Integer);\r\n class procedure Spray(const Dst: TBitmap; Amount: Integer);\r\n class procedure AntiAlias(const Dst: TBitmap);\r\n class procedure AntiAliasRect(const Dst: TBitmap; XOrigin, YOrigin, XFinal, YFinal: Integer);\r\n class procedure SmoothPoint(const Dst: TBitmap; XK, YK: Integer);\r\n class procedure FishEye(var Bmp, Dst: TBitmap; Amount: Single);\r\n class procedure Marble(const Src: TBitmap; var Dst: TBitmap; Scale: Single; Turbulence: Integer);\r\n class procedure Marble2(const Src: TBitmap; var Dst: TBitmap; Scale: Single; Turbulence: Integer);\r\n class procedure Marble3(const Src: TBitmap; var Dst: TBitmap; Scale: Single; Turbulence: Integer);\r\n class procedure Marble4(const Src: TBitmap; var Dst: TBitmap; Scale: Single; Turbulence: Integer);\r\n class procedure Marble5(const Src: TBitmap; var Dst: TBitmap; Scale: Single; Turbulence: Integer);\r\n class procedure Marble6(const Src: TBitmap; var Dst: TBitmap; Scale: Single; Turbulence: Integer);\r\n class procedure Marble7(const Src: TBitmap; var Dst: TBitmap; Scale: Single; Turbulence: Integer);\r\n class procedure Marble8(const Src: TBitmap; var Dst: TBitmap; Scale: Single; Turbulence: Integer);\r\n class procedure SqueezeHor(Src, Dst: TBitmap; Amount: Integer; Style: TLightBrush);\r\n class procedure SplitRound(Src, Dst: TBitmap; Amount: Integer; Style: TLightBrush);\r\n class procedure Tile(Src, Dst: TBitmap; Amount: Integer);\r\n // Interpolator\r\n // Src: Source bitmap\r\n // Dst: Destination bitmap\r\n // Filter: Weight calculation filter\r\n // AWidth: Relative sample radius\r\n class procedure Stretch(Src, Dst: TBitmap; Filter: TFilterProc; AWidth: Single);\r\n class procedure Grow(Src1, Src2, Dst: TBitmap; Amount: Single; X, Y: Integer);\r\n class procedure Invert(Src: TBitmap);\r\n class procedure MirrorRight(Src: TBitmap);\r\n class procedure MirrorDown(Src: TBitmap);\r\n end;\r\n\r\n// Sample filters for use with Stretch()\r\nfunction SplineFilter(Value: Single): Single;\r\nfunction BellFilter(Value: Single): Single;\r\nfunction TriangleFilter(Value: Single): Single;\r\nfunction BoxFilter(Value: Single): Single;\r\nfunction HermiteFilter(Value: Single): Single;\r\nfunction Lanczos3Filter(Value: Single): Single;\r\nfunction MitchellFilter(Value: Single): Single;\r\n\r\nconst\r\n ResampleFilters: array [0..6] of record\r\n Name: string; // Filter name\r\n Filter: TFilterProc; // Filter implementation\r\n Width: Single; // Suggested sampling width/radius\r\n end = (\r\n (Name: 'Box'; Filter: BoxFilter; Width: 0.5),\r\n (Name: 'Triangle'; Filter: TriangleFilter; Width: 1.0),\r\n (Name: 'Hermite'; Filter: HermiteFilter; Width: 1.0),\r\n (Name: 'Bell'; Filter: BellFilter; Width: 1.5),\r\n (Name: 'B-Spline'; Filter: SplineFilter; Width: 2.0),\r\n (Name: 'Lanczos3'; Filter: Lanczos3Filter; Width: 3.0),\r\n (Name: 'Mitchell'; Filter: MitchellFilter; Width: 2.0)\r\n );\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvPaintFX.pas $';\r\n Revision: '$Revision: 13104 $';\r\n Date: '$Date: 2011-09-07 08:50:43 +0200 (mer. 07 sept. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n Math,\r\n JvJCLUtils, JvResources, JvTypes;\r\n\r\nconst\r\n // TJvRGBTriple = TRGBQuad for VisualCLX\r\n bpp = SizeOf(TJvRGBTriple);\r\n\r\nfunction TrimInt(N, Min, Max: Integer): Integer;\r\nbegin\r\n if N > Max then\r\n Result := Max\r\n else\r\n if N < Min then\r\n Result := Min\r\n else\r\n Result := N;\r\nend;\r\n\r\nfunction IntToByte(N: Integer): Byte;\r\nbegin\r\n if N > 255 then\r\n Result := 255\r\n else\r\n if N < 0 then\r\n Result := 0\r\n else\r\n Result := N;\r\nend;\r\n\r\n// Just a small function to map the numbers to colors\r\n\r\nfunction ConvertColor(Value: Integer): TColor;\r\nconst\r\n Colors: array [0..15] of TColor =\r\n (\r\n clBlack, clNavy, clGreen, clAqua, clRed, clPurple, clMaroon, clSilver,\r\n clGray, clBlue, clLime, clOlive, clFuchsia, clTeal, clYellow, clWhite\r\n );\r\nbegin\r\n if (Value < 0) or (Value > High(Colors)) then\r\n Result := clWhite\r\n else\r\n Result := Colors[Value];\r\nend;\r\n\r\nfunction BellFilter(Value: Single): Single;\r\nbegin\r\n if Value < 0.0 then\r\n Value := -Value;\r\n if Value < 0.5 then\r\n Result := 0.75 - Sqr(Value)\r\n else\r\n if Value < 1.5 then\r\n begin\r\n Value := Value - 1.5;\r\n Result := 0.5 * Sqr(Value);\r\n end\r\n else\r\n Result := 0.0;\r\nend;\r\n\r\n// a.k.a. \"Nearest Neighbour\" filter\r\n// anme: I have not been able to get acceptable\r\n// results with this filter for subsampling.\r\n\r\nfunction BoxFilter(Value: Single): Single;\r\nbegin\r\n if (Value > -0.5) and (Value <= 0.5) then\r\n Result := 1.0\r\n else\r\n Result := 0.0;\r\nend;\r\n\r\nfunction HermiteFilter(Value: Single): Single;\r\nbegin\r\n // f(t) = 2|t|^3 - 3|t|^2 + 1, -1 <= t <= 1\r\n if Value < 0.0 then\r\n Value := -Value;\r\n if Value < 1.0 then\r\n Result := (2.0 * Value - 3.0) * Sqr(Value) + 1.0\r\n else\r\n Result := 0.0;\r\nend;\r\n\r\nfunction Lanczos3Filter(Value: Single): Single;\r\n\r\n function SinC(Value: Single): Single;\r\n begin\r\n if Value <> 0.0 then\r\n begin\r\n Value := Value * Pi;\r\n Result := Sin(Value) / Value;\r\n end\r\n else\r\n Result := 1.0;\r\n end;\r\n\r\nbegin\r\n if Value < 0.0 then\r\n Value := -Value;\r\n if Value < 3.0 then\r\n Result := SinC(Value) * SinC(Value / 3.0)\r\n else\r\n Result := 0.0;\r\nend;\r\n\r\nfunction MitchellFilter(Value: Single): Single;\r\nconst\r\n B = 1.0 / 3.0;\r\n C = 1.0 / 3.0;\r\nvar\r\n T: Single;\r\nbegin\r\n if Value < 0.0 then\r\n Value := -Value;\r\n T := Sqr(Value);\r\n if Value < 1.0 then\r\n begin\r\n Value := (((12.0 - 9.0 * B - 6.0 * C) * (Value * T)) +\r\n ((-18.0 + 12.0 * B + 6.0 * C) * T) +\r\n (6.0 - 2 * B));\r\n Result := Value / 6.0;\r\n end\r\n else\r\n if Value < 2.0 then\r\n begin\r\n Value := (((-1.0 * B - 6.0 * C) * (Value * T)) +\r\n ((6.0 * B + 30.0 * C) * T) +\r\n ((-12.0 * B - 48.0 * C) * Value) +\r\n (8.0 * B + 24 * C));\r\n Result := Value / 6.0;\r\n end\r\n else\r\n Result := 0.0;\r\nend;\r\n\r\n// B-spline filter\r\n\r\nfunction SplineFilter(Value: Single): Single;\r\nvar\r\n T: Single;\r\nbegin\r\n if Value < 0.0 then\r\n Value := -Value;\r\n if Value < 1.0 then\r\n begin\r\n T := Sqr(Value);\r\n Result := 0.5 * T * Value - T + 2.0 / 3.0;\r\n end\r\n else\r\n if Value < 2.0 then\r\n begin\r\n Value := 2.0 - Value;\r\n Result := 1.0 / 6.0 * Sqr(Value) * Value;\r\n end\r\n else\r\n Result := 0.0;\r\nend;\r\n\r\n// Triangle filter\r\n// a.k.a. \"Linear\" or \"Bilinear\" filter\r\n\r\nfunction TriangleFilter(Value: Single): Single;\r\nbegin\r\n if Value < 0.0 then\r\n Value := -Value;\r\n if Value < 1.0 then\r\n Result := 1.0 - Value\r\n else\r\n Result := 0.0;\r\nend;\r\n\r\nclass procedure TJvPaintFX.AddColorNoise(const Dst: TBitmap; Amount: Integer);\r\nvar\r\n Line: PJvRGBArray;\r\n X, Y: Integer;\r\n OPF: TPixelFormat;\r\nbegin\r\n Randomize;\r\n OPF := Dst.PixelFormat;\r\n Dst.PixelFormat := pf24bit;\r\n for Y := 0 to Dst.Height - 1 do\r\n begin\r\n Line := Dst.ScanLine[Y];\r\n for X := 0 to Dst.Width - 1 do\r\n begin\r\n Line[X].rgbRed := IntToByte(Line[X].rgbRed + (Random(Amount) - (Amount shr 1)));\r\n Line[X].rgbGreen := IntToByte(Line[X].rgbGreen + (Random(Amount) - (Amount shr 1)));\r\n Line[X].rgbBlue := IntToByte(Line[X].rgbBlue + (Random(Amount) - (Amount shr 1)));\r\n end;\r\n end;\r\n Dst.PixelFormat := OPF;\r\nend;\r\n\r\nclass procedure TJvPaintFX.AddMonoNoise(const Dst: TBitmap; Amount: Integer);\r\nvar\r\n Line: PJvRGBArray;\r\n X, Y, A: Integer;\r\n OPF: TPixelFormat;\r\nbegin\r\n Randomize;\r\n OPF := Dst.PixelFormat;\r\n Dst.PixelFormat := pf24bit;\r\n for Y := 0 to Dst.Height - 1 do\r\n begin\r\n Line := Dst.ScanLine[Y];\r\n for X := 0 to Dst.Width - 1 do\r\n begin\r\n A := Random(Amount) - (Amount shr 1);\r\n Line[X].rgbRed := IntToByte(Line[X].rgbRed + A);\r\n Line[X].rgbGreen := IntToByte(Line[X].rgbGreen + A);\r\n Line[X].rgbBlue := IntToByte(Line[X].rgbBlue + A);\r\n end;\r\n end;\r\n Dst.PixelFormat := OPF;\r\nend;\r\n\r\nclass procedure TJvPaintFX.AntiAlias(const Dst: TBitmap);\r\nbegin\r\n JvJCLUtils.AntiAlias(Dst);\r\nend;\r\n\r\nclass procedure TJvPaintFX.AntiAliasRect(const Dst: TBitmap;\r\n XOrigin, YOrigin, XFinal, YFinal: Integer);\r\nbegin\r\n JvJCLUtils.AntiAliasRect(Dst, XOrigin, YOrigin, XFinal, YFinal);\r\nend;\r\n\r\nclass procedure TJvPaintFX.Contrast(const Dst: TBitmap; Amount: Integer);\r\nvar\r\n Line: PJvRGBArray;\r\n RG, GG, BG, R, G, B, X, Y: Integer;\r\n OPF: TPixelFormat;\r\nbegin\r\n OPF := Dst.PixelFormat;\r\n Dst.PixelFormat := pf24bit;\r\n for Y := 0 to Dst.Height - 1 do\r\n begin\r\n Line := Dst.ScanLine[Y];\r\n for X := 0 to Dst.Width - 1 do\r\n begin\r\n R := Line[X].rgbRed;\r\n G := Line[X].rgbGreen;\r\n B := Line[X].rgbBlue;\r\n RG := (Abs(127 - R) * Amount) div 255;\r\n GG := (Abs(127 - G) * Amount) div 255;\r\n BG := (Abs(127 - B) * Amount) div 255;\r\n if R > 127 then\r\n R := R + RG\r\n else\r\n R := R - RG;\r\n if G > 127 then\r\n G := G + GG\r\n else\r\n G := G - GG;\r\n if B > 127 then\r\n B := B + BG\r\n else\r\n B := B - BG;\r\n Line[X].rgbRed := IntToByte(R);\r\n Line[X].rgbGreen := IntToByte(G);\r\n Line[X].rgbBlue := IntToByte(B);\r\n end;\r\n end;\r\n Dst.PixelFormat := OPF;\r\nend;\r\n\r\nclass procedure TJvPaintFX.FishEye(var Bmp, Dst: TBitmap; Amount: Single);\r\nvar\r\n xmid, ymid: Single;\r\n fx, fy: Single;\r\n r1, r2: Single;\r\n ifx, ify: Integer;\r\n DX, DY: Single;\r\n rmax: Single;\r\n ty, tx: Integer;\r\n WeightX, WeightY: array [0..1] of Single;\r\n Weight: Single;\r\n new_red, new_green: Integer;\r\n new_blue: Integer;\r\n total_red, total_green: Single;\r\n total_blue: Single;\r\n ix, iy: Integer;\r\n sli, slo: PJvRGBArray;\r\nbegin\r\n xmid := Bmp.Width / 2;\r\n ymid := Bmp.Height / 2;\r\n rmax := Dst.Width * Amount;\r\n\r\n for ty := 0 to Dst.Height - 1 do\r\n begin\r\n for tx := 0 to Dst.Width - 1 do\r\n begin\r\n DX := tx - xmid;\r\n DY := ty - ymid;\r\n r1 := Sqrt(DX * DX + DY * DY);\r\n if r1 = 0 then\r\n begin\r\n fx := xmid;\r\n fy := ymid;\r\n end\r\n else\r\n begin\r\n r2 := rmax / 2 * (1 / (1 - r1 / rmax) - 1);\r\n fx := DX * r2 / r1 + xmid;\r\n fy := DY * r2 / r1 + ymid;\r\n end;\r\n ify := Trunc(fy);\r\n ifx := Trunc(fx);\r\n // Calculate the weights.\r\n if fy >= 0 then\r\n begin\r\n WeightY[1] := fy - ify;\r\n WeightY[0] := 1 - WeightY[1];\r\n end\r\n else\r\n begin\r\n WeightY[0] := -(fy - ify);\r\n WeightY[1] := 1 - WeightY[0];\r\n end;\r\n if fx >= 0 then\r\n begin\r\n WeightX[1] := fx - ifx;\r\n WeightX[0] := 1 - WeightX[1];\r\n end\r\n else\r\n begin\r\n WeightX[0] := -(fx - ifx);\r\n WeightX[1] := 1 - WeightX[0];\r\n end;\r\n\r\n if ifx < 0 then\r\n ifx := Bmp.Width - 1 - (-ifx mod Bmp.Width)\r\n else\r\n if ifx > Bmp.Width - 1 then\r\n ifx := ifx mod Bmp.Width;\r\n if ify < 0 then\r\n ify := Bmp.Height - 1 - (-ify mod Bmp.Height)\r\n else\r\n if ify > Bmp.Height - 1 then\r\n ify := ify mod Bmp.Height;\r\n\r\n total_red := 0.0;\r\n total_green := 0.0;\r\n total_blue := 0.0;\r\n for ix := 0 to 1 do\r\n begin\r\n for iy := 0 to 1 do\r\n begin\r\n if ify + iy < Bmp.Height then\r\n sli := Bmp.ScanLine[ify + iy]\r\n else\r\n sli := Bmp.ScanLine[Bmp.Height - ify - iy];\r\n if ifx + ix < Bmp.Width then\r\n begin\r\n new_red := sli[ifx + ix].rgbRed;\r\n new_green := sli[ifx + ix].rgbGreen;\r\n new_blue := sli[ifx + ix].rgbBlue;\r\n end\r\n else\r\n begin\r\n new_red := sli[Bmp.Width - ifx - ix].rgbRed;\r\n new_green := sli[Bmp.Width - ifx - ix].rgbGreen;\r\n new_blue := sli[Bmp.Width - ifx - ix].rgbBlue;\r\n end;\r\n Weight := WeightX[ix] * WeightY[iy];\r\n total_red := total_red + new_red * Weight;\r\n total_green := total_green + new_green * Weight;\r\n total_blue := total_blue + new_blue * Weight;\r\n end;\r\n end;\r\n slo := Dst.ScanLine[ty];\r\n slo[tx].rgbRed := Round(total_red);\r\n slo[tx].rgbGreen := Round(total_green);\r\n slo[tx].rgbBlue := Round(total_blue);\r\n end;\r\n end;\r\nend;\r\n\r\nclass procedure TJvPaintFX.GaussianBlur(const Dst: TBitmap; Amount: Integer);\r\nvar\r\n I: Integer;\r\n OPF: TPixelFormat;\r\nbegin\r\n OPF := Dst.PixelFormat;\r\n Dst.PixelFormat := pf24bit;\r\n for I := Amount downto 0 do\r\n SplitBlur(Dst, 3);\r\n Dst.PixelFormat := OPF;\r\nend;\r\n\r\nclass procedure TJvPaintFX.GrayScale(const Dst: TBitmap);\r\nvar\r\n Line: PJvRGBArray;\r\n Gray, X, Y: Integer;\r\n OPF: TPixelFormat;\r\nbegin\r\n OPF := Dst.PixelFormat;\r\n Dst.PixelFormat := pf24bit;\r\n for Y := 0 to Dst.Height - 1 do\r\n begin\r\n Line := Dst.ScanLine[Y];\r\n for X := 0 to Dst.Width - 1 do\r\n begin\r\n Gray := Round(Line[X].rgbRed * 0.3 + Line[X].rgbGreen * 0.59 + Line[X].rgbBlue * 0.11);\r\n Line[X].rgbRed := Gray;\r\n Line[X].rgbGreen := Gray;\r\n Line[X].rgbBlue := Gray;\r\n end;\r\n end;\r\n Dst.PixelFormat := OPF;\r\nend;\r\n\r\nclass procedure TJvPaintFX.Lightness(const Dst: TBitmap; Amount: Integer);\r\nvar\r\n Line: PJvRGBArray;\r\n R, G, B, X, Y: Integer;\r\n OPF: TPixelFormat;\r\nbegin\r\n OPF := Dst.PixelFormat;\r\n Dst.PixelFormat := pf24bit;\r\n for Y := 0 to Dst.Height - 1 do\r\n begin\r\n Line := Dst.ScanLine[Y];\r\n for X := 0 to Dst.Width - 1 do\r\n begin\r\n R := Line[X].rgbRed;\r\n G := Line[X].rgbGreen;\r\n B := Line[X].rgbBlue;\r\n Line[X].rgbRed := IntToByte(R + ((255 - R) * Amount) div 255);\r\n Line[X].rgbGreen := IntToByte(G + ((255 - G) * Amount) div 255);\r\n Line[X].rgbBlue := IntToByte(B + ((255 - B) * Amount) div 255);\r\n end;\r\n end;\r\n Dst.PixelFormat := OPF;\r\nend;\r\n\r\nclass procedure TJvPaintFX.Darkness(const Dst: TBitmap; Amount: Integer);\r\nvar\r\n Line: PJvRGBArray;\r\n R, G, B, X, Y: Integer;\r\n OPF: TPixelFormat;\r\nbegin\r\n OPF := Dst.PixelFormat;\r\n Dst.PixelFormat := pf24bit;\r\n for Y := 0 to Dst.Height - 1 do\r\n begin\r\n Line := Dst.ScanLine[Y];\r\n for X := 0 to Dst.Width - 1 do\r\n begin\r\n R := Line[X].rgbRed;\r\n G := Line[X].rgbGreen;\r\n B := Line[X].rgbBlue;\r\n Line[X].rgbRed := IntToByte(R - (R * Amount) div 255);\r\n Line[X].rgbGreen := IntToByte(G - (G * Amount) div 255);\r\n Line[X].rgbBlue := IntToByte(B - (B * Amount) div 255);\r\n end;\r\n end;\r\n Dst.PixelFormat := OPF;\r\nend;\r\n\r\nclass procedure TJvPaintFX.Marble(const Src: TBitmap; var Dst: TBitmap; Scale: Single;\r\n Turbulence: Integer);\r\nvar\r\n X, XM, Y, YM: Integer;\r\n XX, YY: Single;\r\n Line1, Line2: PJvRGBArray;\r\n W, H: Integer;\r\n Source: TBitmap;\r\nbegin\r\n if Src = nil then\r\n Exit;\r\n if Dst = nil then\r\n Dst := TBitmap.Create;\r\n Dst.Assign(Src);\r\n Source := TBitmap.Create;\r\n Source.Assign(Src);\r\n Dst.PixelFormat := pf24bit;\r\n Source.PixelFormat := pf24bit;\r\n H := Src.Height;\r\n W := Src.Width;\r\n for Y := 0 to H - 1 do\r\n begin\r\n YY := Scale * Cos((Y mod Turbulence) / Scale);\r\n Line1 := Source.ScanLine[Y];\r\n for X := 0 to W - 1 do\r\n begin\r\n XX := -Scale * Sin((X mod Turbulence) / Scale);\r\n XM := Round(Abs(X + XX + YY));\r\n YM := Round(Abs(Y + YY + XX));\r\n if (YM < H) and (XM < W) then\r\n begin\r\n Line2 := Dst.ScanLine[YM];\r\n Line2[XM] := Line1[X];\r\n end;\r\n end;\r\n end;\r\n Source.Free;\r\n Dst.PixelFormat := Src.PixelFormat;\r\nend;\r\n\r\nclass procedure TJvPaintFX.Marble2(const Src: TBitmap; var Dst: TBitmap; Scale: Single;\r\n Turbulence: Integer);\r\nvar\r\n X, XM, Y, YM: Integer;\r\n XX, YY: Single;\r\n Line1, Line2: PJvRGBArray;\r\n W, H: Integer;\r\n Source: TBitmap;\r\nbegin\r\n if Src = nil then\r\n Exit;\r\n if Dst = nil then\r\n Dst := TBitmap.Create;\r\n Dst.Assign(Src);\r\n Source := TBitmap.Create;\r\n Source.Assign(Src);\r\n Dst.PixelFormat := pf24bit;\r\n Source.PixelFormat := pf24bit;\r\n H := Src.Height;\r\n W := Src.Width;\r\n for Y := 0 to H - 1 do\r\n begin\r\n YY := Scale * Cos((Y mod Turbulence) / Scale);\r\n Line1 := Source.ScanLine[Y];\r\n for X := 0 to W - 1 do\r\n begin\r\n XX := -Scale * Sin((X mod Turbulence) / Scale);\r\n XM := Round(Abs(X + XX - YY));\r\n YM := Round(Abs(Y + YY - XX));\r\n if (YM < H) and (XM < W) then\r\n begin\r\n Line2 := Dst.ScanLine[YM];\r\n Line2[XM] := Line1[X];\r\n end;\r\n end;\r\n end;\r\n Source.Free;\r\n Dst.PixelFormat := Src.PixelFormat;\r\nend;\r\n\r\nclass procedure TJvPaintFX.Marble3(const Src: TBitmap; var Dst: TBitmap; Scale: Single;\r\n Turbulence: Integer);\r\nvar\r\n X, XM, Y, YM: Integer;\r\n XX, YY: Single;\r\n Line1, Line2: PJvRGBArray;\r\n W, H: Integer;\r\n Source: TBitmap;\r\nbegin\r\n if Src = nil then\r\n Exit;\r\n if Dst = nil then\r\n Dst := TBitmap.Create;\r\n Dst.Assign(Src);\r\n Source := TBitmap.Create;\r\n Source.Assign(Src);\r\n Dst.PixelFormat := pf24bit;\r\n Source.PixelFormat := pf24bit;\r\n H := Src.Height;\r\n W := Src.Width;\r\n for Y := 0 to H - 1 do\r\n begin\r\n YY := Scale * Cos((Y mod Turbulence) / Scale);\r\n Line1 := Source.ScanLine[Y];\r\n for X := 0 to W - 1 do\r\n begin\r\n XX := -Scale * Sin((X mod Turbulence) / Scale);\r\n XM := Round(Abs(X - XX + YY));\r\n YM := Round(Abs(Y - YY + XX));\r\n if (YM < H) and (XM < W) then\r\n begin\r\n Line2 := Dst.ScanLine[YM];\r\n Line2[XM] := Line1[X];\r\n end;\r\n end;\r\n end;\r\n Source.Free;\r\n Dst.PixelFormat := Src.PixelFormat;\r\nend;\r\n\r\nclass procedure TJvPaintFX.Marble4(const Src: TBitmap; var Dst: TBitmap; Scale: Single;\r\n Turbulence: Integer);\r\nvar\r\n X, XM, Y, YM: Integer;\r\n XX, YY: Single;\r\n Line1, Line2: PJvRGBArray;\r\n W, H: Integer;\r\n Source: TBitmap;\r\nbegin\r\n if Src = nil then\r\n Exit;\r\n if Dst = nil then\r\n Dst := TBitmap.Create;\r\n Dst.Assign(Src);\r\n Source := TBitmap.Create;\r\n Source.Assign(Src);\r\n Dst.PixelFormat := pf24bit;\r\n Source.PixelFormat := pf24bit;\r\n H := Src.Height;\r\n W := Src.Width;\r\n for Y := 0 to H - 1 do\r\n begin\r\n YY := Scale * Sin((Y mod Turbulence) / Scale);\r\n Line1 := Source.ScanLine[Y];\r\n for X := 0 to W - 1 do\r\n begin\r\n XX := -Scale * Cos((X mod Turbulence) / Scale);\r\n XM := Round(Abs(X + XX + YY));\r\n YM := Round(Abs(Y + YY + XX));\r\n if (YM < H) and (XM < W) then\r\n begin\r\n Line2 := Dst.ScanLine[YM];\r\n Line2[XM] := Line1[X];\r\n end;\r\n end;\r\n end;\r\n Source.Free;\r\n Dst.PixelFormat := Src.PixelFormat;\r\nend;\r\n\r\nclass procedure TJvPaintFX.Marble5(const Src: TBitmap; var Dst: TBitmap; Scale: Single;\r\n Turbulence: Integer);\r\nvar\r\n X, XM, Y, YM: Integer;\r\n XX, YY: Single;\r\n Line1, Line2: PJvRGBArray;\r\n W, H: Integer;\r\n Source: TBitmap;\r\nbegin\r\n if Src = nil then\r\n Exit;\r\n if Dst = nil then\r\n Dst := TBitmap.Create;\r\n Dst.Assign(Src);\r\n Source := TBitmap.Create;\r\n Source.Assign(Src);\r\n Dst.PixelFormat := pf24bit;\r\n Source.PixelFormat := pf24bit;\r\n H := Src.Height;\r\n W := Src.Width;\r\n for Y := H - 1 downto 0 do\r\n begin\r\n YY := Scale * Cos((Y mod Turbulence) / Scale);\r\n Line1 := Source.ScanLine[Y];\r\n for X := W - 1 downto 0 do\r\n begin\r\n XX := -Scale * Sin((X mod Turbulence) / Scale);\r\n XM := Round(Abs(X + XX + YY));\r\n YM := Round(Abs(Y + YY + XX));\r\n if (YM < H) and (XM < W) then\r\n begin\r\n Line2 := Dst.ScanLine[YM];\r\n Line2[XM] := Line1[X];\r\n end;\r\n end;\r\n end;\r\n Source.Free;\r\n Dst.PixelFormat := Src.PixelFormat;\r\nend;\r\n\r\nclass procedure TJvPaintFX.Marble6(const Src: TBitmap; var Dst: TBitmap; Scale: Single;\r\n Turbulence: Integer);\r\nvar\r\n X, XM, Y, YM: Integer;\r\n XX, YY: Single;\r\n Line1, Line2: PJvRGBArray;\r\n W, H: Integer;\r\n Source: TBitmap;\r\nbegin\r\n if Src = nil then\r\n Exit;\r\n if Dst = nil then\r\n Dst := TBitmap.Create;\r\n Dst.Assign(Src);\r\n Source := TBitmap.Create;\r\n Source.Assign(Src);\r\n Dst.PixelFormat := pf24bit;\r\n Source.PixelFormat := pf24bit;\r\n H := Src.Height;\r\n W := Src.Width;\r\n for Y := 0 to H - 1 do\r\n begin\r\n YY := Scale * Cos((Y mod Turbulence) / Scale);\r\n Line1 := Source.ScanLine[Y];\r\n for X := 0 to W - 1 do\r\n begin\r\n XX := -tan((X mod Turbulence) / Scale) / Scale;\r\n XM := Round(Abs(X + XX + YY));\r\n YM := Round(Abs(Y + YY + XX));\r\n if (YM < H) and (XM < W) then\r\n begin\r\n Line2 := Dst.ScanLine[YM];\r\n Line2[XM] := Line1[X];\r\n end;\r\n end;\r\n end;\r\n Source.Free;\r\n Dst.PixelFormat := Src.PixelFormat;\r\nend;\r\n\r\nclass procedure TJvPaintFX.Marble7(const Src: TBitmap; var Dst: TBitmap; Scale: Single;\r\n Turbulence: Integer);\r\nvar\r\n X, XM, Y, YM: Integer;\r\n XX, YY: Single;\r\n Line1, Line2: PJvRGBArray;\r\n W, H: Integer;\r\n Source: TBitmap;\r\nbegin\r\n if Src = nil then\r\n Exit;\r\n if Dst = nil then\r\n Dst := TBitmap.Create;\r\n Dst.Assign(Src);\r\n Source := TBitmap.Create;\r\n Source.Assign(Src);\r\n Dst.PixelFormat := pf24bit;\r\n Source.PixelFormat := pf24bit;\r\n H := Src.Height;\r\n W := Src.Width;\r\n for Y := 0 to H - 1 do\r\n begin\r\n YY := Scale * Sin((Y mod Turbulence) / Scale);\r\n Line1 := Source.ScanLine[Y];\r\n for X := 0 to W - 1 do\r\n begin\r\n XX := -tan((X mod Turbulence) / Scale) / (Scale * Scale);\r\n XM := Round(Abs(X + XX + YY));\r\n YM := Round(Abs(Y + YY + XX));\r\n if (YM < H) and (XM < W) then\r\n begin\r\n Line2 := Dst.ScanLine[YM];\r\n Line2[XM] := Line1[X];\r\n end;\r\n end;\r\n end;\r\n Source.Free;\r\n Dst.PixelFormat := Src.PixelFormat;\r\nend;\r\n\r\nclass procedure TJvPaintFX.Marble8(const Src: TBitmap; var Dst: TBitmap; Scale: Single;\r\n Turbulence: Integer);\r\nvar\r\n X, XM, Y, YM: Integer;\r\n XX, YY: Single;\r\n Line1, Line2: PJvRGBArray;\r\n W, H: Integer;\r\n ax: Single;\r\n Source: TBitmap;\r\nbegin\r\n if Src = nil then\r\n Exit;\r\n if Dst = nil then\r\n Dst := TBitmap.Create;\r\n Dst.Assign(Src);\r\n Source := TBitmap.Create;\r\n Source.Assign(Src);\r\n Dst.PixelFormat := pf24bit;\r\n Source.PixelFormat := pf24bit;\r\n H := Src.Height;\r\n W := Src.Width;\r\n for Y := 0 to H - 1 do\r\n begin\r\n ax := (Y mod Turbulence) / Scale;\r\n YY := Scale * Sin(ax) * Cos(1.5 * ax);\r\n Line1 := Source.ScanLine[Y];\r\n for X := 0 to W - 1 do\r\n begin\r\n ax := (X mod Turbulence) / Scale;\r\n XX := -Scale * Sin(2 * ax) * Cos(ax);\r\n XM := Round(Abs(X + XX + YY));\r\n YM := Round(Abs(Y + YY + XX));\r\n if (YM < H) and (XM < W) then\r\n begin\r\n Line2 := Dst.ScanLine[YM];\r\n Line2[XM] := Line1[X];\r\n end;\r\n end;\r\n end;\r\n Source.Free;\r\n Dst.PixelFormat := Src.PixelFormat;\r\nend;\r\n\r\nclass procedure TJvPaintFX.Saturation(const Dst: TBitmap; Amount: Integer);\r\nvar\r\n Line: PJvRGBArray;\r\n Gray, R, G, B, X, Y: Integer;\r\nbegin\r\n for Y := 0 to Dst.Height - 1 do\r\n begin\r\n Line := Dst.ScanLine[Y];\r\n for X := 0 to Dst.Width - 1 do\r\n begin\r\n R := Line[X].rgbRed;\r\n G := Line[X].rgbGreen;\r\n B := Line[X].rgbBlue;\r\n Gray := (R + G + B) div 3;\r\n Line[X].rgbRed := IntToByte(Gray + (((R - Gray) * Amount) div 255));\r\n Line[X].rgbGreen := IntToByte(Gray + (((G - Gray) * Amount) div 255));\r\n Line[X].rgbBlue := IntToByte(Gray + (((B - Gray) * Amount) div 255));\r\n end;\r\n end;\r\nend;\r\n\r\nclass procedure TJvPaintFX.Smooth(const Dst: TBitmap; Weight: Integer);\r\nvar\r\n Line, Line1, Line2, Line3: PJvRGBArray;\r\n W, H, X, Y: Integer;\r\n Src: TBitmap;\r\n OPF: TPixelFormat;\r\nbegin\r\n if (Dst.Height < 2) or (Dst.Width < 2) then\r\n Exit;\r\n W := Dst.Width;\r\n H := Dst.Height;\r\n Src := TBitmap.Create;\r\n Src.Assign(Dst);\r\n OPF := Dst.PixelFormat;\r\n Src.PixelFormat := pf24bit;\r\n Dst.PixelFormat := pf24bit;\r\n for Y := 1 to H - 2 do\r\n begin\r\n Line := Dst.ScanLine[Y];\r\n Line1 := Src.ScanLine[Y-1];\r\n Line2 := Src.ScanLine[Y];\r\n Line3 := Src.ScanLine[Y+1];\r\n Line[0].rgbRed := (Line2[0].rgbRed + Line2[1].rgbRed + Line1[0].rgbRed + Line3[0].rgbRed) div 4;\r\n Line[0].rgbGreen := (Line2[0].rgbGreen + Line2[1].rgbGreen + Line1[0].rgbGreen + Line3[0].rgbGreen) div 4;\r\n Line[0].rgbBlue := (Line2[0].rgbBlue + Line2[1].rgbBlue + Line1[0].rgbBlue + Line3[0].rgbBlue) div 4;\r\n Line[W-1].rgbRed := (Line2[W-2].rgbRed + Line2[W-1].rgbRed + Line1[W-1].rgbRed + Line3[W-1].rgbRed) div 4;\r\n Line[W-1].rgbGreen := (Line2[W-2].rgbGreen + Line2[W-1].rgbGreen + Line1[W-1].rgbGreen + Line3[W-1].rgbGreen) div 4;\r\n Line[W-1].rgbBlue := (Line2[W-2].rgbBlue + Line2[W-1].rgbBlue + Line1[W-1].rgbBlue + Line3[W-1].rgbBlue) div 4;\r\n for X := 1 to W - 2 do\r\n begin\r\n Line[X].rgbRed := (Line2[X-1].rgbRed + Line2[X+1].rgbRed + Line1[X].rgbRed + Line3[X].rgbRed) div 4;\r\n Line[X].rgbGreen := (Line2[X-1].rgbGreen + Line2[X+1].rgbGreen + Line1[X].rgbGreen + Line3[X].rgbGreen) div 4;\r\n Line[X].rgbBlue := (Line2[X-1].rgbBlue + Line2[X+1].rgbBlue + Line1[X].rgbBlue + Line3[X].rgbBlue) div 4;\r\n end;\r\n end;\r\n Line := Dst.ScanLine[0];\r\n Line1 := Src.ScanLine[0];\r\n Line2 := Src.ScanLine[0];\r\n Line3 := Src.ScanLine[1];\r\n for X := 1 to Dst.Width - 2 do\r\n begin\r\n Line[X].rgbRed := (Line2[X-1].rgbRed + Line2[X+1].rgbRed + Line1[X].rgbRed + Line3[X].rgbRed) div 4;\r\n Line[X].rgbGreen := (Line2[X-1].rgbGreen + Line2[X+1].rgbGreen + Line1[X].rgbGreen + Line3[X].rgbGreen) div 4;\r\n Line[X].rgbBlue := (Line2[X-1].rgbBlue + Line2[X+1].rgbBlue + Line1[X].rgbBlue + Line3[X].rgbBlue) div 4;\r\n end;\r\n Line := Dst.ScanLine[H-1];\r\n Line1 := Src.ScanLine[H-2];\r\n Line2 := Src.ScanLine[H-1];\r\n Line3 := Src.ScanLine[H-1];\r\n for X := 1 to Dst.Width - 2 do\r\n begin\r\n Line[X].rgbRed := (Line2[X-1].rgbRed + Line2[X+1].rgbRed + Line1[X].rgbRed + Line3[X].rgbRed) div 4;\r\n Line[X].rgbGreen := (Line2[X-1].rgbGreen + Line2[X+1].rgbGreen + Line1[X].rgbGreen + Line3[X].rgbGreen) div 4;\r\n Line[X].rgbBlue := (Line2[X-1].rgbBlue + Line2[X+1].rgbBlue + Line1[X].rgbBlue + Line3[X].rgbBlue) div 4;\r\n end;\r\n Src.Free;\r\n Dst.PixelFormat := OPF;\r\nend;\r\n\r\nclass procedure TJvPaintFX.SmoothPoint(const Dst: TBitmap; XK, YK: Integer);\r\nvar\r\n Pixel: TColor;\r\n B, G, R: Cardinal;\r\nbegin\r\n if (XK > 0) and (YK > 0) and (XK < Dst.Width - 1) and (YK < Dst.Height - 1) then\r\n with Dst.Canvas do\r\n begin\r\n Pixel := ColorToRGB(Pixels[XK, YK - 1]);\r\n R := GetRValue(Pixel);\r\n B := GetGValue(Pixel);\r\n G := GetBValue(Pixel);\r\n Pixel := ColorToRGB(Pixels[XK + 1, YK]);\r\n R := R + GetRValue(Pixel);\r\n G := G + GetGValue(Pixel);\r\n B := B + GetBValue(Pixel);\r\n Pixel := ColorToRGB(Pixels[XK, YK + 1]);\r\n R := R + GetRValue(Pixel);\r\n G := G + GetGValue(Pixel);\r\n B := B + GetBValue(Pixel);\r\n Pixel := ColorToRGB(Pixels[XK - 1, YK]);\r\n R := R + GetRValue(Pixel);\r\n G := G + GetGValue(Pixel);\r\n B := B + GetBValue(Pixel);\r\n Pixels[XK, YK] := RGB(R div 4, G div 4, B div 4);\r\n end;\r\nend;\r\n\r\nclass procedure TJvPaintFX.SmoothResize(var Src, Dst: TBitmap);\r\nvar\r\n X, Y, xP, yP, yP2, xP2: Integer;\r\n Read, Read2: PByteArray;\r\n T, z, z2, iz2: Integer;\r\n pc: PByteArray;\r\n w1, w2, w3, w4: Integer;\r\n Col1r, Col1g, Col1b, Col2r, Col2g, Col2b: Byte;\r\nbegin\r\n xP2 := ((Src.Width - 1) shl 15) div Dst.Width;\r\n yP2 := ((Src.Height - 1) shl 15) div Dst.Height;\r\n yP := 0;\r\n for Y := 0 to Dst.Height - 1 do\r\n begin\r\n xP := 0;\r\n Read := Src.ScanLine[yP shr 15];\r\n if yP shr 16 < Src.Height - 1 then\r\n Read2 := Src.ScanLine[yP shr 15 + 1]\r\n else\r\n Read2 := Src.ScanLine[yP shr 15];\r\n pc := Dst.ScanLine[Y];\r\n z2 := yP and $7FFF;\r\n iz2 := $8000 - z2;\r\n for X := 0 to Dst.Width - 1 do\r\n begin\r\n T := xP shr 15;\r\n Col1r := Read[T * bpp];\r\n Col1g := Read[T * bpp + 1];\r\n Col1b := Read[T * bpp + 2];\r\n Col2r := Read2[T * bpp];\r\n Col2g := Read2[T * bpp + 1];\r\n Col2b := Read2[T * bpp + 2];\r\n z := xP and $7FFF;\r\n w2 := (z * iz2) shr 15;\r\n w1 := iz2 - w2;\r\n w4 := (z * z2) shr 15;\r\n w3 := z2 - w4;\r\n pc[X * bpp + 2] :=\r\n (Col1b * w1 + Read[(T + 1) * bpp + 2] * w2 +\r\n Col2b * w3 + Read2[(T + 1) * bpp + 2] * w4) shr 15;\r\n pc[X * bpp + 1] :=\r\n (Col1g * w1 + Read[(T + 1) * bpp + 1] * w2 +\r\n Col2g * w3 + Read2[(T + 1) * bpp + 1] * w4) shr 15;\r\n pc[X * bpp] :=\r\n (Col1r * w1 + Read2[(T + 1) * bpp] * w2 +\r\n Col2r * w3 + Read2[(T + 1) * bpp] * w4) shr 15;\r\n Inc(xP, xP2);\r\n end;\r\n Inc(yP, yP2);\r\n end;\r\nend;\r\n\r\nclass procedure TJvPaintFX.SmoothRotate(var Src, Dst: TBitmap; CX, CY: Integer;\r\n Angle: Single);\r\ntype\r\n TFColor = record\r\n B, G, R: Byte\r\n end;\r\nvar\r\n Top,\r\n Bottom,\r\n// Left,\r\n// Right,\r\n eww, nsw,\r\n fx, fy,\r\n// wx, wy: Single;\r\n cAngle,\r\n sAngle: Double;\r\n xDiff,\r\n yDiff,\r\n ifx, ify,\r\n PX, PY,\r\n ix, iy,\r\n X, Y: Integer;\r\n nw, ne,\r\n sw, se: TFColor;\r\n P1, P2, P3: PByteArray;\r\nbegin\r\n Angle := Angle;\r\n Angle := -Angle * Pi / 180;\r\n sAngle := Sin(Angle);\r\n cAngle := Cos(Angle);\r\n xDiff := (Dst.Width - Src.Width) div 2;\r\n yDiff := (Dst.Height - Src.Height) div 2;\r\n for Y := 0 to Dst.Height - 1 do\r\n begin\r\n P3 := Dst.ScanLine[Y];\r\n PY := 2 * (Y - CY) + 1;\r\n for X := 0 to Dst.Width - 1 do\r\n begin\r\n PX := 2 * (X - CX) + 1;\r\n fx := (((PX * cAngle - PY * sAngle) - 1) / 2 + CX) - xDiff;\r\n fy := (((PX * sAngle + PY * cAngle) - 1) / 2 + CY) - yDiff;\r\n ifx := Round(fx);\r\n ify := Round(fy);\r\n\r\n if (ifx > -1) and (ifx < Src.Width) and (ify > -1) and (ify < Src.Height) then\r\n begin\r\n eww := fx - ifx;\r\n nsw := fy - ify;\r\n iy := TrimInt(ify + 1, 0, Src.Height - 1);\r\n ix := TrimInt(ifx + 1, 0, Src.Width - 1);\r\n P1 := Src.ScanLine[ify];\r\n P2 := Src.ScanLine[iy];\r\n nw.R := P1[ifx * bpp];\r\n nw.G := P1[ifx * bpp + 1];\r\n nw.B := P1[ifx * bpp + 2];\r\n ne.R := P1[ix * bpp];\r\n ne.G := P1[ix * bpp + 1];\r\n ne.B := P1[ix * bpp + 2];\r\n sw.R := P2[ifx * bpp];\r\n sw.G := P2[ifx * bpp + 1];\r\n sw.B := P2[ifx * bpp + 2];\r\n se.R := P2[ix * bpp];\r\n se.G := P2[ix * bpp + 1];\r\n se.B := P2[ix * bpp + 2];\r\n\r\n Top := nw.B + eww * (ne.B - nw.B);\r\n Bottom := sw.B + eww * (se.B - sw.B);\r\n P3[X * bpp + 2] := IntToByte(Round(Top + nsw * (Bottom - Top)));\r\n\r\n Top := nw.G + eww * (ne.G - nw.G);\r\n Bottom := sw.G + eww * (se.G - sw.G);\r\n P3[X * bpp + 1] := IntToByte(Round(Top + nsw * (Bottom - Top)));\r\n\r\n Top := nw.R + eww * (ne.R - nw.R);\r\n Bottom := sw.R + eww * (se.R - sw.R);\r\n P3[X * bpp] := IntToByte(Round(Top + nsw * (Bottom - Top)));\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\nclass procedure TJvPaintFX.SplitBlur(const Dst: TBitmap; Amount: Integer);\r\nvar\r\n p0, P1, P2: PByteArray;\r\n CX, X, Y: Integer;\r\n Buf: array [0..3, 0..2] of Byte;\r\nbegin\r\n if Amount = 0 then\r\n Exit;\r\n for Y := 0 to Dst.Height - 1 do\r\n begin\r\n p0 := Dst.ScanLine[Y];\r\n if Y - Amount < 0 then\r\n P1 := Dst.ScanLine[Y]\r\n else {Y-Amount>0}\r\n P1 := Dst.ScanLine[Y - Amount];\r\n if Y + Amount < Dst.Height then\r\n P2 := Dst.ScanLine[Y + Amount]\r\n else {Y+Amount>=Height}\r\n P2 := Dst.ScanLine[Dst.Height - Y];\r\n\r\n for X := 0 to Dst.Width - 1 do\r\n begin\r\n if X - Amount < 0 then\r\n CX := X\r\n else {X-Amount>0}\r\n CX := X - Amount;\r\n Buf[0, 0] := P1[CX * bpp];\r\n Buf[0, 1] := P1[CX * bpp + 1];\r\n Buf[0, 2] := P1[CX * bpp + 2];\r\n Buf[1, 0] := P2[CX * bpp];\r\n Buf[1, 1] := P2[CX * bpp + 1];\r\n Buf[1, 2] := P2[CX * bpp + 2];\r\n if X + Amount < Dst.Width then\r\n CX := X + Amount\r\n else {X+Amount>=Width}\r\n CX := Dst.Width - X;\r\n Buf[2, 0] := P1[CX * bpp];\r\n Buf[2, 1] := P1[CX * bpp + 1];\r\n Buf[2, 2] := P1[CX * bpp + 2];\r\n Buf[3, 0] := P2[CX * bpp];\r\n Buf[3, 1] := P2[CX * bpp + 1];\r\n Buf[3, 2] := P2[CX * bpp + 2];\r\n p0[X * bpp] := (Buf[0, 0] + Buf[1, 0] + Buf[2, 0] + Buf[3, 0]) shr 2;\r\n p0[X * bpp + 1] := (Buf[0, 1] + Buf[1, 1] + Buf[2, 1] + Buf[3, 1]) shr 2;\r\n p0[X * bpp + 2] := (Buf[0, 2] + Buf[1, 2] + Buf[2, 2] + Buf[3, 2]) shr 2;\r\n end;\r\n end;\r\nend;\r\n\r\nclass procedure TJvPaintFX.Spray(const Dst: TBitmap; Amount: Integer);\r\nvar\r\n I, J, X, Y, W, H, Val: Integer;\r\nbegin\r\n H := Dst.Height;\r\n W := Dst.Width;\r\n for I := 0 to W - 1 do\r\n for J := 0 to H - 1 do\r\n begin\r\n Val := Random(Amount);\r\n X := I + Val - Random(Val * 2);\r\n Y := J + Val - Random(Val * 2);\r\n if (X > -1) and (X < W) and (Y > -1) and (Y < H) then\r\n Dst.Canvas.Pixels[I, J] := Dst.Canvas.Pixels[X, Y];\r\n end;\r\nend;\r\n\r\nclass procedure TJvPaintFX.Mosaic(const Bm: TBitmap; Size: Integer);\r\nvar\r\n X, Y, I, J: Integer;\r\n P1, P2: PJvRGBArray;\r\n P1Val: TJvRGBTriple;\r\nbegin\r\n Y := 0;\r\n repeat\r\n P1 := Bm.ScanLine[Y];\r\n repeat\r\n J := 1;\r\n repeat\r\n P2 := Bm.ScanLine[Y];\r\n X := 0;\r\n repeat\r\n P1Val := P1[X];\r\n I := 1;\r\n repeat\r\n P2[X] := P1Val;\r\n Inc(X);\r\n Inc(I);\r\n until (I > Size) or (X >= Bm.Width);\r\n until X >= Bm.Width;\r\n Inc(J);\r\n Inc(Y);\r\n until (J > Size) or (Y >= Bm.Height);\r\n until (Y >= Bm.Height) or (X >= Bm.Width);\r\n until Y >= Bm.Height;\r\nend;\r\n\r\nclass procedure TJvPaintFX.Twist(var Bmp, Dst: TBitmap; Amount: Integer);\r\nvar\r\n fxmid, fymid: Single;\r\n txmid, tymid: Single;\r\n fx, fy: Single;\r\n tx2, ty2: Single;\r\n R: Single;\r\n theta: Single;\r\n ifx, ify: Integer;\r\n DX, DY: Single;\r\n OFFSET: Single;\r\n ty, tx: Integer;\r\n WeightX, WeightY: array [0..1] of Single;\r\n Weight: Single;\r\n new_red, new_green: Integer;\r\n new_blue: Integer;\r\n total_red, total_green: Single;\r\n total_blue: Single;\r\n ix, iy: Integer;\r\n sli, slo: PByteArray;\r\n\r\n function ArcTan2(xt, yt: Single): Single;\r\n begin\r\n if xt = 0 then\r\n if yt > 0 then\r\n Result := Pi / 2\r\n else\r\n Result := -(Pi / 2)\r\n else\r\n begin\r\n Result := ArcTan(yt / xt);\r\n if xt < 0 then\r\n Result := Pi + ArcTan(yt / xt);\r\n end;\r\n end;\r\n\r\nbegin\r\n OFFSET := -(Pi / 2);\r\n DX := Bmp.Width - 1;\r\n DY := Bmp.Height - 1;\r\n R := Sqrt(DX * DX + DY * DY);\r\n tx2 := R;\r\n ty2 := R;\r\n txmid := (Bmp.Width - 1) / 2; //Adjust these to move center of rotation\r\n tymid := (Bmp.Height - 1) / 2; //Adjust these to move ......\r\n fxmid := (Bmp.Width - 1) / 2;\r\n fymid := (Bmp.Height - 1) / 2;\r\n if tx2 >= Bmp.Width then\r\n tx2 := Bmp.Width - 1;\r\n if ty2 >= Bmp.Height then\r\n ty2 := Bmp.Height - 1;\r\n\r\n for ty := 0 to Round(ty2) do\r\n begin\r\n for tx := 0 to Round(tx2) do\r\n begin\r\n DX := tx - txmid;\r\n DY := ty - tymid;\r\n R := Sqrt(DX * DX + DY * DY);\r\n if R = 0 then\r\n begin\r\n fx := 0;\r\n fy := 0;\r\n end\r\n else\r\n begin\r\n theta := ArcTan2(DX, DY) - R / Amount - OFFSET;\r\n fx := R * Cos(theta);\r\n fy := R * Sin(theta);\r\n end;\r\n fx := fx + fxmid;\r\n fy := fy + fymid;\r\n\r\n ify := Trunc(fy);\r\n ifx := Trunc(fx);\r\n // Calculate the weights.\r\n if fy >= 0 then\r\n begin\r\n WeightY[1] := fy - ify;\r\n WeightY[0] := 1 - WeightY[1];\r\n end\r\n else\r\n begin\r\n WeightY[0] := -(fy - ify);\r\n WeightY[1] := 1 - WeightY[0];\r\n end;\r\n if fx >= 0 then\r\n begin\r\n WeightX[1] := fx - ifx;\r\n WeightX[0] := 1 - WeightX[1];\r\n end\r\n else\r\n begin\r\n WeightX[0] := -(fx - ifx);\r\n WeightX[1] := 1 - WeightX[0];\r\n end;\r\n\r\n if ifx < 0 then\r\n ifx := Bmp.Width - 1 - (-ifx mod Bmp.Width)\r\n else\r\n if ifx > Bmp.Width - 1 then\r\n ifx := ifx mod Bmp.Width;\r\n if ify < 0 then\r\n ify := Bmp.Height - 1 - (-ify mod Bmp.Height)\r\n else\r\n if ify > Bmp.Height - 1 then\r\n ify := ify mod Bmp.Height;\r\n\r\n total_red := 0.0;\r\n total_green := 0.0;\r\n total_blue := 0.0;\r\n for ix := 0 to 1 do\r\n begin\r\n for iy := 0 to 1 do\r\n begin\r\n if ify + iy < Bmp.Height then\r\n sli := Bmp.ScanLine[ify + iy]\r\n else\r\n sli := Bmp.ScanLine[Bmp.Height - ify - iy];\r\n if ifx + ix < Bmp.Width then\r\n begin\r\n new_red := sli[(ifx + ix) * bpp];\r\n new_green := sli[(ifx + ix) * bpp + 1];\r\n new_blue := sli[(ifx + ix) * bpp + 2];\r\n end\r\n else\r\n begin\r\n new_red := sli[(Bmp.Width - ifx - ix) * bpp];\r\n new_green := sli[(Bmp.Width - ifx - ix) * bpp + 1];\r\n new_blue := sli[(Bmp.Width - ifx - ix) * bpp + 2];\r\n end;\r\n Weight := WeightX[ix] * WeightY[iy];\r\n total_red := total_red + new_red * Weight;\r\n total_green := total_green + new_green * Weight;\r\n total_blue := total_blue + new_blue * Weight;\r\n end;\r\n end;\r\n slo := Dst.ScanLine[ty];\r\n slo[tx * bpp] := Round(total_red);\r\n slo[tx * bpp + 1] := Round(total_green);\r\n slo[tx * bpp + 2] := Round(total_blue);\r\n end;\r\n end;\r\nend;\r\n\r\nclass procedure TJvPaintFX.Wave(const Dst: TBitmap; Amount, Inference, Style: Integer);\r\nvar\r\n X, Y: Integer;\r\n Bitmap: TBitmap;\r\n P1, P2: PByteArray;\r\n B: Integer;\r\n Angle: Extended;\r\n wavex: Integer;\r\nbegin\r\n Bitmap := TBitmap.Create;\r\n Bitmap.Assign(Dst);\r\n wavex := Style;\r\n Angle := Pi / 2 / Amount;\r\n for Y := Bitmap.Height - 1 - (2 * Amount) downto Amount do\r\n begin\r\n P1 := Bitmap.ScanLine[Y];\r\n B := 0;\r\n for X := 0 to Bitmap.Width - 1 do\r\n begin\r\n P2 := Dst.ScanLine[Y + Amount + B];\r\n P2[X * bpp] := P1[X * bpp];\r\n P2[X * bpp + 1] := P1[X * bpp + 1];\r\n P2[X * bpp + 2] := P1[X * bpp + 2];\r\n case wavex of\r\n 0:\r\n B := Amount * Variant(Sin(Angle * X));\r\n 1:\r\n B := Amount * Variant(Sin(Angle * X) * Cos(Angle * X));\r\n 2:\r\n B := Amount * Variant(Sin(Angle * X) * Sin(Inference * Angle * X));\r\n end;\r\n end;\r\n end;\r\n Bitmap.Free;\r\nend;\r\n\r\nclass procedure TJvPaintFX.MakeSeamlessClip(var Dst: TBitmap; Seam: Integer);\r\nvar\r\n p0, P1, P2: PByteArray;\r\n H, W, I, J, sv, sh: Integer;\r\n f0, f1, f2: real;\r\nbegin\r\n H := Dst.Height;\r\n W := Dst.Width;\r\n sv := H div Seam;\r\n sh := W div Seam;\r\n P1 := Dst.ScanLine[0];\r\n P2 := Dst.ScanLine[H - 1];\r\n for I := 0 to W - 1 do\r\n begin\r\n P1[I * bpp] := P2[I * bpp];\r\n P1[I * bpp + 1] := P2[I * bpp + 1];\r\n P1[I * bpp + 2] := P2[I * bpp + 2];\r\n end;\r\n p0 := Dst.ScanLine[0];\r\n P2 := Dst.ScanLine[sv];\r\n for J := 1 to sv - 1 do\r\n begin\r\n P1 := Dst.ScanLine[J];\r\n for I := 0 to W - 1 do\r\n begin\r\n f0 := (P2[I * bpp] - p0[I * bpp]) / sv * J + p0[I * bpp];\r\n P1[I * bpp] := Round(f0);\r\n f1 := (P2[I * bpp + 1] - p0[I * bpp + 1]) / sv * J + p0[I * bpp + 1];\r\n P1[I * bpp + 1] := Round(f1);\r\n f2 := (P2[I * bpp + 2] - p0[I * bpp + 2]) / sv * J + p0[I * bpp + 2];\r\n P1[I * bpp + 2] := Round(f2);\r\n end;\r\n end;\r\n for J := 0 to H - 1 do\r\n begin\r\n P1 := Dst.ScanLine[J];\r\n P1[(W - 1) * bpp] := P1[0];\r\n P1[(W - 1) * bpp + 1] := P1[1];\r\n P1[(W - 1) * bpp + 2] := P1[2];\r\n for I := 1 to sh - 1 do\r\n begin\r\n f0 := (P1[(W - sh) * bpp] - P1[(W - 1) * bpp]) / sh * I + P1[(W - 1) * bpp];\r\n P1[(W - 1 - I) * bpp] := Round(f0);\r\n f1 := (P1[(W - sh) * bpp + 1] - P1[(W - 1) * bpp + 1]) / sh * I + P1[(W - 1) * bpp + 1];\r\n P1[(W - 1 - I) * bpp + 1] := Round(f1);\r\n f2 := (P1[(W - sh) * bpp + 2] - P1[(W - 1) * bpp + 2]) / sh * I + P1[(W - 1) * bpp + 2];\r\n P1[(W - 1 - I) * bpp + 2] := Round(f2);\r\n end;\r\n end;\r\nend;\r\n\r\nclass procedure TJvPaintFX.SplitLight(const Dst: TBitmap; Amount: Integer);\r\nvar\r\n X, Y, I: Integer;\r\n P: PJvRGBArray;\r\n OPF: TPixelFormat;\r\n\r\n function Sinus(A: Integer): Integer;\r\n begin\r\n Result := Round(Sin(A / 255 * Pi / 2) * 255);\r\n end;\r\n\r\nbegin\r\n OPF := Dst.PixelFormat;\r\n Dst.PixelFormat := pf24bit;\r\n for I := 1 to Amount do\r\n for Y := 0 to Dst.Height - 1 do\r\n begin\r\n P := Dst.ScanLine[Y];\r\n for X := 0 to Dst.Width - 1 do\r\n begin\r\n P[X].rgbBlue := Sinus(P[X].rgbBlue);\r\n P[X].rgbGreen := Sinus(P[X].rgbGreen);\r\n P[X].rgbRed := Sinus(P[X].rgbRed);\r\n end;\r\n end;\r\n Dst.PixelFormat := OPF;\r\nend;\r\n\r\nclass procedure TJvPaintFX.SqueezeHor(Src, Dst: TBitmap; Amount: Integer; Style: TLightBrush);\r\nvar\r\n DX, X, Y, C, CX: Integer;\r\n R: TRect;\r\n Bm: TBitmap;\r\n p0, P1: PByteArray;\r\nbegin\r\n if Amount > (Src.Width div 2) then\r\n Amount := Src.Width div 2;\r\n Bm := TBitmap.Create;\r\n Bm.PixelFormat := pf24bit;\r\n Bm.Height := 1;\r\n Bm.Width := Src.Width;\r\n CX := Src.Width div 2;\r\n p0 := Bm.ScanLine[0];\r\n for Y := 0 to Src.Height - 1 do\r\n begin\r\n P1 := Src.ScanLine[Y];\r\n for X := 0 to Src.Width - 1 do\r\n begin\r\n C := X * bpp;\r\n p0[C] := P1[C];\r\n p0[C + 1] := P1[C + 1];\r\n p0[C + 2] := P1[C + 2];\r\n end;\r\n case Style of\r\n mbHor:\r\n begin\r\n DX := Amount;\r\n R := Rect(DX, Y, Src.Width - DX, Y + 1);\r\n end;\r\n mbTop:\r\n begin\r\n DX := Round((Src.Height - 1 - Y) / Src.Height * Amount);\r\n R := Rect(DX, Y, Src.Width - DX, Y + 1);\r\n end;\r\n mbBottom:\r\n begin\r\n DX := Round(Y / Src.Height * Amount);\r\n R := Rect(DX, Y, Src.Width - DX, Y + 1);\r\n end;\r\n mbDiamond:\r\n begin\r\n DX := Round(Amount * Abs(Cos(Y / (Src.Height - 1) * Pi)));\r\n R := Rect(DX, Y, Src.Width - DX, Y + 1);\r\n end;\r\n mbWaste:\r\n begin\r\n DX := Round(Amount * Abs(Sin(Y / (Src.Height - 1) * Pi)));\r\n R := Rect(DX, Y, Src.Width - DX, Y + 1);\r\n end;\r\n mbRound:\r\n begin\r\n DX := Round(Amount * Abs(Sin(Y / (Src.Height - 1) * Pi)));\r\n R := Rect(CX - DX, Y, CX + DX, Y + 1);\r\n end;\r\n mbRound2:\r\n begin\r\n DX := Round(Amount * Abs(Sin(Y / (Src.Height - 1) * Pi * 2)));\r\n R := Rect(CX - DX, Y, CX + DX, Y + 1);\r\n end;\r\n end;\r\n Dst.Canvas.StretchDraw(R, Bm);\r\n end;\r\n Bm.Free;\r\nend;\r\n\r\nclass procedure TJvPaintFX.Tile(Src, Dst: TBitmap; Amount: Integer);\r\nvar\r\n w2, h2, I, J: Integer;\r\n Bmp: TBitmap;\r\nbegin\r\n Dst.Assign(Src);\r\n if (Amount <= 0) or ((Src.Width div Amount) < 5) or ((Src.Height div Amount) < 5) then\r\n Exit;\r\n h2 := Src.Width div Amount;\r\n w2 := Src.Height div Amount;\r\n Bmp := TBitmap.Create;\r\n Bmp.Width := w2;\r\n Bmp.Height := h2;\r\n Bmp.PixelFormat := pf24bit;\r\n SmoothResize(Src, Bmp);\r\n for J := 0 to Amount - 1 do\r\n for I := 0 to Amount - 1 do\r\n Dst.Canvas.Draw(I * w2, J * h2, Bmp);\r\n Bmp.Free;\r\nend;\r\n\r\n// ---------------------------------------------------------------------------\r\n// Interpolator\r\n// ---------------------------------------------------------------------------\r\ntype\r\n // Contributor for a pixel\r\n TContributor = record\r\n Pixel: Integer; // Source pixel\r\n Weight: Single; // Pixel Weight\r\n end;\r\n\r\n TContributorList = array [0..0] of TContributor;\r\n PContributorList = ^TContributorList;\r\n\r\n // List of source pixels contributing to a destination pixel\r\n TCList = record\r\n N: Integer;\r\n P: PContributorList;\r\n end;\r\n\r\n TCListList = array [0..0] of TCList;\r\n PCListList = ^TCListList;\r\n\r\n TRGB = packed record\r\n R: Single;\r\n G: Single;\r\n B: Single;\r\n end;\r\n\r\n // Physical bitmap pixel\r\n TColorRGB = packed record\r\n R: Byte;\r\n G: Byte;\r\n B: Byte;\r\n end;\r\n PColorRGB = ^TColorRGB;\r\n\r\n // Physical bitmap ScanLine (row)\r\n TRGBList = packed array [0..0] of TColorRGB;\r\n PRGBList = ^TRGBList;\r\n\r\nclass procedure TJvPaintFX.Stretch(Src, Dst: TBitmap; Filter: TFilterProc;\r\n AWidth: Single);\r\nvar\r\n xscale, yscale: Single; // Zoom Scale factors\r\n I, J, k: Integer; // Loop variables\r\n Center: Single; // Filter calculation variables\r\n Width, fscale, Weight: Single; // Filter calculation variables\r\n Left, Right: Integer; // Filter calculation variables\r\n N: Integer; // Pixel number\r\n Work: TBitmap;\r\n Contrib: PCListList;\r\n RGB: TRGB;\r\n Color: TColorRGB;\r\n SourceLine, DestLine: PRGBList;\r\n (*SourcePixel, *)DestPixel: PColorRGB;\r\n Delta, DestDelta: Integer;\r\n SrcWidth, SrcHeight, DstWidth, DstHeight: Integer;\r\n\r\n function Color2RGB(Color: TColor): TColorRGB;\r\n begin\r\n Result.R := Color and $000000FF;\r\n Result.G := (Color and $0000FF00) shr 8;\r\n Result.B := (Color and $00FF0000) shr 16;\r\n end;\r\n\r\n function RGB2Color(Color: TColorRGB): TColor;\r\n begin\r\n Result := Color.R or (Color.G shl 8) or (Color.B shl 16);\r\n end;\r\n\r\nbegin\r\n DstWidth := Dst.Width;\r\n DstHeight := Dst.Height;\r\n SrcWidth := Src.Width;\r\n SrcHeight := Src.Height;\r\n if (SrcWidth < 1) or (SrcHeight < 1) then\r\n raise Exception.CreateRes(@RsESourceBitmapTooSmall);\r\n\r\n // Create intermediate image to hold horizontal zoom\r\n Work := TBitmap.Create;\r\n try\r\n Work.Height := SrcHeight;\r\n Work.Width := DstWidth;\r\n // xscale := DstWidth / SrcWidth;\r\n // yscale := DstHeight / SrcHeight;\r\n // Improvement suggested by David Ullrich:\r\n if (SrcWidth = 1) then\r\n xscale := DstWidth / SrcWidth\r\n else\r\n xscale := (DstWidth - 1) / (SrcWidth - 1);\r\n if (SrcHeight = 1) then\r\n yscale := DstHeight / SrcHeight\r\n else\r\n yscale := (DstHeight - 1) / (SrcHeight - 1);\r\n // This implementation only works on 24-bit images because it uses\r\n // TBitmap.ScanLine\r\n Src.PixelFormat := pf24bit;\r\n Dst.PixelFormat := Src.PixelFormat;\r\n Work.PixelFormat := Src.PixelFormat;\r\n\r\n // --------------------------------------------\r\n // Pre-calculate filter contributions for a row\r\n // -----------------------------------------------\r\n GetMem(Contrib, DstWidth * SizeOf(TCList));\r\n // Horizontal sub-sampling\r\n // Scales from bigger to smaller Width\r\n if (xscale < 1.0) then\r\n begin\r\n Width := AWidth / xscale;\r\n fscale := 1.0 / xscale;\r\n for I := 0 to DstWidth - 1 do\r\n begin\r\n Contrib^[I].N := 0;\r\n GetMem(Contrib^[I].P, Trunc(Width * 2.0 + 1) * SizeOf(TContributor));\r\n Center := I / xscale;\r\n // Original code:\r\n // Left := Ceil(Center - Width);\r\n // Right := Floor(Center + Width);\r\n Left := Floor(Center - Width);\r\n Right := Ceil(Center + Width);\r\n for J := Left to Right do\r\n begin\r\n Weight := Filter((Center - J) / fscale) / fscale;\r\n if (Weight = 0.0) then\r\n Continue;\r\n if (J < 0) then\r\n N := -J\r\n else\r\n if (J >= SrcWidth) then\r\n N := SrcWidth - J + SrcWidth - 1\r\n else\r\n N := J;\r\n k := Contrib^[I].N;\r\n Contrib^[I].N := Contrib^[I].N + 1;\r\n Contrib^[I].P^[k].Pixel := N;\r\n Contrib^[I].P^[k].Weight := Weight;\r\n end;\r\n end;\r\n end\r\n else\r\n // Horizontal super-sampling\r\n // Scales from smaller to bigger Width\r\n begin\r\n for I := 0 to DstWidth - 1 do\r\n begin\r\n Contrib^[I].N := 0;\r\n GetMem(Contrib^[I].P, Trunc(AWidth * 2.0 + 1) * SizeOf(TContributor));\r\n Center := I / xscale;\r\n // Original code:\r\n // Left := Ceil(Center - AWidth);\r\n // Right := Floor(Center + AWidth);\r\n Left := Floor(Center - AWidth);\r\n Right := Ceil(Center + AWidth);\r\n for J := Left to Right do\r\n begin\r\n Weight := Filter(Center - J);\r\n if (Weight = 0.0) then\r\n Continue;\r\n if J < 0 then\r\n N := -J\r\n else\r\n if J >= SrcWidth then\r\n N := SrcWidth - J + SrcWidth - 1\r\n else\r\n N := J;\r\n\r\n if N < 0 then\r\n N := -N;\r\n\r\n k := Contrib^[I].N;\r\n Contrib^[I].N := Contrib^[I].N + 1;\r\n Contrib^[I].P^[k].Pixel := N;\r\n Contrib^[I].P^[k].Weight := Weight;\r\n end;\r\n end;\r\n end;\r\n\r\n // ----------------------------------------------------\r\n // Apply filter to sample horizontally from Src to Work\r\n // ----------------------------------------------------\r\n for k := 0 to SrcHeight - 1 do\r\n begin\r\n SourceLine := Src.ScanLine[k];\r\n DestPixel := Work.ScanLine[k];\r\n for I := 0 to DstWidth - 1 do\r\n begin\r\n RGB.R := 0.0;\r\n RGB.G := 0.0;\r\n RGB.B := 0.0;\r\n for J := 0 to Contrib^[I].N - 1 do\r\n begin\r\n Color := SourceLine^[Contrib^[I].P^[J].Pixel];\r\n Weight := Contrib^[I].P^[J].Weight;\r\n if (Weight = 0.0) then\r\n Continue;\r\n RGB.R := RGB.R + Color.R * Weight;\r\n RGB.G := RGB.G + Color.G * Weight;\r\n RGB.B := RGB.B + Color.B * Weight;\r\n end;\r\n if RGB.R > 255.0 then\r\n Color.R := 255\r\n else\r\n if RGB.R < 0.0 then\r\n Color.R := 0\r\n else\r\n Color.R := Round(RGB.R);\r\n if RGB.G > 255.0 then\r\n Color.G := 255\r\n else\r\n if RGB.G < 0.0 then\r\n Color.G := 0\r\n else\r\n Color.G := Round(RGB.G);\r\n if RGB.B > 255.0 then\r\n Color.B := 255\r\n else\r\n if RGB.B < 0.0 then\r\n Color.B := 0\r\n else\r\n Color.B := Round(RGB.B);\r\n // Set new Pixel value\r\n DestPixel^ := Color;\r\n // Move on to next column\r\n Inc(DestPixel);\r\n end;\r\n end;\r\n\r\n // Free the memory allocated for horizontal filter weights\r\n for I := 0 to DstWidth - 1 do\r\n FreeMem(Contrib^[I].P);\r\n\r\n FreeMem(Contrib);\r\n\r\n // -----------------------------------------------\r\n // Pre-calculate filter contributions for a column\r\n // -----------------------------------------------\r\n GetMem(Contrib, DstHeight * SizeOf(TCList));\r\n // Vertical sub-sampling\r\n // Scales from bigger to smaller Height\r\n if (yscale < 1.0) then\r\n begin\r\n Width := AWidth / yscale;\r\n fscale := 1.0 / yscale;\r\n for I := 0 to DstHeight - 1 do\r\n begin\r\n Contrib^[I].N := 0;\r\n GetMem(Contrib^[I].P, Trunc(Width * 2.0 + 1) * SizeOf(TContributor));\r\n Center := I / yscale;\r\n // Original code:\r\n // Left := Ceil(Center - Width);\r\n // Right := Floor(Center + Width);\r\n Left := Floor(Center - Width);\r\n Right := Ceil(Center + Width);\r\n for J := Left to Right do\r\n begin\r\n Weight := Filter((Center - J) / fscale) / fscale;\r\n if Weight = 0.0 then\r\n Continue;\r\n if J < 0 then\r\n N := -J\r\n else\r\n if J >= SrcHeight then\r\n N := SrcHeight - J + SrcHeight - 1\r\n else\r\n N := J;\r\n k := Contrib^[I].N;\r\n Contrib^[I].N := Contrib^[I].N + 1;\r\n Contrib^[I].P^[k].Pixel := N;\r\n Contrib^[I].P^[k].Weight := Weight;\r\n end;\r\n end\r\n end\r\n else\r\n // Vertical super-sampling\r\n // Scales from smaller to bigger Height\r\n begin\r\n for I := 0 to DstHeight - 1 do\r\n begin\r\n Contrib^[I].N := 0;\r\n GetMem(Contrib^[I].P, Trunc(AWidth * 2.0 + 1) * SizeOf(TContributor));\r\n Center := I / yscale;\r\n // Original code:\r\n // Left := Ceil(Center - AWidth);\r\n // Right := Floor(Center + AWidth);\r\n Left := Floor(Center - AWidth);\r\n Right := Ceil(Center + AWidth);\r\n for J := Left to Right do\r\n begin\r\n Weight := Filter(Center - J);\r\n if Weight = 0.0 then\r\n Continue;\r\n if J < 0 then\r\n N := -J\r\n else\r\n if J >= SrcHeight then\r\n N := SrcHeight - J + SrcHeight - 1\r\n else\r\n N := J;\r\n k := Contrib^[I].N;\r\n Contrib^[I].N := Contrib^[I].N + 1;\r\n Contrib^[I].P^[k].Pixel := N;\r\n Contrib^[I].P^[k].Weight := Weight;\r\n end;\r\n end;\r\n end;\r\n\r\n // --------------------------------------------------\r\n // Apply filter to sample vertically from Work to Dst\r\n // --------------------------------------------------\r\n SourceLine := Work.ScanLine[0];\r\n if Work.Height > 1 then\r\n Delta := Integer(Work.ScanLine[1]) - Integer(SourceLine)\r\n else\r\n Delta := 0;\r\n DestLine := Dst.ScanLine[0];\r\n if Dst.Height > 1 then\r\n DestDelta := Integer(Dst.ScanLine[1]) - Integer(DestLine)\r\n else\r\n DestDelta := 0;\r\n for k := 0 to DstWidth - 1 do\r\n begin\r\n DestPixel := pointer(DestLine);\r\n for I := 0 to DstHeight - 1 do\r\n begin\r\n RGB.R := 0;\r\n RGB.G := 0;\r\n RGB.B := 0;\r\n // Weight := 0.0;\r\n for J := 0 to Contrib^[I].N - 1 do\r\n begin\r\n Color := PColorRGB(Integer(SourceLine) + Contrib^[I].P^[J].Pixel * Delta)^;\r\n Weight := Contrib^[I].P^[J].Weight;\r\n if (Weight = 0.0) then\r\n Continue;\r\n RGB.R := RGB.R + Color.R * Weight;\r\n RGB.G := RGB.G + Color.G * Weight;\r\n RGB.B := RGB.B + Color.B * Weight;\r\n end;\r\n if RGB.R > 255.0 then\r\n Color.R := 255\r\n else\r\n if RGB.R < 0.0 then\r\n Color.R := 0\r\n else\r\n Color.R := Round(RGB.R);\r\n if RGB.G > 255.0 then\r\n Color.G := 255\r\n else\r\n if RGB.G < 0.0 then\r\n Color.G := 0\r\n else\r\n Color.G := Round(RGB.G);\r\n if RGB.B > 255.0 then\r\n Color.B := 255\r\n else\r\n if RGB.B < 0.0 then\r\n Color.B := 0\r\n else\r\n Color.B := Round(RGB.B);\r\n DestPixel^ := Color;\r\n Inc({$IFDEF RTL230_UP}INT_PTR{$ELSE}Integer{$ENDIF RTL230_UP}(DestPixel), DestDelta);\r\n end;\r\n Inc(SourceLine, 1);\r\n Inc(DestLine, 1);\r\n end;\r\n\r\n // Free the memory allocated for vertical filter weights\r\n for I := 0 to DstHeight - 1 do\r\n FreeMem(Contrib^[I].P);\r\n\r\n FreeMem(Contrib);\r\n finally\r\n Work.Free;\r\n end;\r\nend;\r\n\r\nclass procedure TJvPaintFX.Grow(Src1, Src2, Dst: TBitmap; Amount: Single; X, Y: Integer);\r\nvar\r\n Bmp: TBitmap;\r\nbegin\r\n Dst.Assign(Src1);\r\n Bmp := TBitmap.Create;\r\n Bmp.Width := Round(Amount * Src1.Width);\r\n Bmp.Height := Round(Amount * Src1.Height);\r\n Stretch(Src2, Bmp, ResampleFilters[4].Filter, ResampleFilters[4].Width);\r\n Dst.Canvas.Draw(X, Y, Bmp);\r\n Bmp.Free;\r\nend;\r\n\r\nclass procedure TJvPaintFX.SpotLight(const Dst: TBitmap; Amount: Integer; Spot: TRect);\r\nvar\r\n Bmp: TBitmap;\r\nbegin\r\n Darkness(Dst, Amount);\r\n Bmp := TBitmap.Create;\r\n Bmp.Width := Dst.Width;\r\n Bmp.Height := Dst.Height;\r\n Bmp.Canvas.Brush.Color := clBlack;\r\n Bmp.Canvas.FillRect(Rect(0, 0, Dst.Width, Dst.Height));\r\n Bmp.Canvas.Brush.Color := clWhite;\r\n Bmp.Canvas.Ellipse(Spot.Left, Spot.Top, Spot.Right, Spot.Bottom);\r\n Bmp.Transparent := True;\r\n Bmp.TransparentColor := clWhite;\r\n Dst.Canvas.Draw(0, 0, Bmp);\r\n Bmp.Free;\r\nend;\r\n\r\nclass procedure TJvPaintFX.FlipDown(const Dst: TBitmap);\r\nvar\r\n Bmp: TBitmap;\r\n W, H, X, Y: Integer;\r\n PD, PS: PByteArray;\r\nbegin\r\n W := Dst.Width;\r\n H := Dst.Height;\r\n Bmp := TBitmap.Create;\r\n Bmp.Width := W;\r\n Bmp.Height := H;\r\n Bmp.PixelFormat := pf24bit;\r\n Dst.PixelFormat := pf24bit;\r\n for Y := 0 to H - 1 do\r\n begin\r\n PD := Bmp.ScanLine[Y];\r\n PS := Dst.ScanLine[H - 1 - Y];\r\n for X := 0 to W - 1 do\r\n begin\r\n PD[X * bpp] := PS[X * bpp];\r\n PD[X * bpp + 1] := PS[X * bpp + 1];\r\n PD[X * bpp + 2] := PS[X * bpp + 2];\r\n end;\r\n end;\r\n Dst.Assign(Bmp);\r\n Bmp.Free;\r\nend;\r\n\r\nclass procedure TJvPaintFX.FlipRight(const Dst: TBitmap);\r\nvar\r\n dest: TBitmap;\r\n W, H, X, Y: Integer;\r\n PD, PS: PByteArray;\r\nbegin\r\n W := Dst.Width;\r\n H := Dst.Height;\r\n dest := TBitmap.Create;\r\n dest.Width := W;\r\n dest.Height := H;\r\n dest.PixelFormat := pf24bit;\r\n Dst.PixelFormat := pf24bit;\r\n for Y := 0 to H - 1 do\r\n begin\r\n PD := dest.ScanLine[Y];\r\n PS := Dst.ScanLine[Y];\r\n for X := 0 to W - 1 do\r\n begin\r\n PD[X * bpp] := PS[(W - 1 - X) * bpp];\r\n PD[X * bpp + 1] := PS[(W - 1 - X) * bpp + 1];\r\n PD[X * bpp + 2] := PS[(W - 1 - X) * bpp + 2];\r\n end;\r\n end;\r\n Dst.Assign(dest);\r\n dest.Free;\r\nend;\r\n\r\nclass procedure TJvPaintFX.Trace(const Dst: TBitmap; Intensity: Integer);\r\nvar\r\n X, Y, I: Integer;\r\n P1, P2, P3, P4: PByteArray;\r\n tb, TraceB: Byte;\r\n hasb: Boolean;\r\n Bitmap: TBitmap;\r\nbegin\r\n Bitmap := TBitmap.Create;\r\n Bitmap.Width := Dst.Width;\r\n Bitmap.Height := Dst.Height;\r\n Bitmap.Canvas.Draw(0, 0, Dst);\r\n Bitmap.PixelFormat := pf8bit;\r\n Dst.PixelFormat := pf24bit;\r\n hasb := False;\r\n TraceB := $00;\r\n tb := 0;\r\n for I := 1 to Intensity do\r\n begin\r\n for Y := 0 to Bitmap.Height - 2 do\r\n begin\r\n P1 := Bitmap.ScanLine[Y];\r\n P2 := Bitmap.ScanLine[Y + 1];\r\n P3 := Dst.ScanLine[Y];\r\n P4 := Dst.ScanLine[Y + 1];\r\n X := 0;\r\n repeat\r\n if P1[X] <> P1[X + 1] then\r\n begin\r\n if not hasb then\r\n begin\r\n tb := P1[X + 1];\r\n hasb := True;\r\n P3[X * bpp] := TraceB;\r\n P3[X * bpp + 1] := TraceB;\r\n P3[X * bpp + 2] := TraceB;\r\n end\r\n else\r\n begin\r\n if P1[X] <> tb then\r\n begin\r\n P3[X * bpp] := TraceB;\r\n P3[X * bpp + 1] := TraceB;\r\n P3[X * bpp + 2] := TraceB;\r\n end\r\n else\r\n begin\r\n P3[(X + 1) * bpp] := TraceB;\r\n P3[(X + 1) * bpp + 1] := TraceB;\r\n P3[(X + 1) * bpp + 1] := TraceB;\r\n end;\r\n end;\r\n end;\r\n if P1[X] <> P2[X] then\r\n begin\r\n if not hasb then\r\n begin\r\n tb := P2[X];\r\n hasb := True;\r\n P3[X * bpp] := TraceB;\r\n P3[X * bpp + 1] := TraceB;\r\n P3[X * bpp + 2] := TraceB;\r\n end\r\n else\r\n begin\r\n if P1[X] <> tb then\r\n begin\r\n P3[X * bpp] := TraceB;\r\n P3[X * bpp + 1] := TraceB;\r\n P3[X * bpp + 2] := TraceB;\r\n end\r\n else\r\n begin\r\n P4[X * bpp] := TraceB;\r\n P4[X * bpp + 1] := TraceB;\r\n P4[X * bpp + 2] := TraceB;\r\n end;\r\n end;\r\n end;\r\n Inc(X);\r\n until X >= (Bitmap.Width - 2);\r\n end;\r\n // do the same in the opposite direction\r\n // only when Intensity > 1\r\n if I > 1 then\r\n for Y := Bitmap.Height - 1 downto 1 do\r\n begin\r\n P1 := Bitmap.ScanLine[Y];\r\n P2 := Bitmap.ScanLine[Y - 1];\r\n P3 := Dst.ScanLine[Y];\r\n P4 := Dst.ScanLine[Y - 1];\r\n X := Bitmap.Width - 1;\r\n repeat\r\n if P1[X] <> P1[X - 1] then\r\n begin\r\n if not hasb then\r\n begin\r\n tb := P1[X - 1];\r\n hasb := True;\r\n P3[X * bpp] := TraceB;\r\n P3[X * bpp + 1] := TraceB;\r\n P3[X * bpp + 2] := TraceB;\r\n end\r\n else\r\n begin\r\n if P1[X] <> tb then\r\n begin\r\n P3[X * bpp] := TraceB;\r\n P3[X * bpp + 1] := TraceB;\r\n P3[X * bpp + 2] := TraceB;\r\n end\r\n else\r\n begin\r\n P3[(X - 1) * bpp] := TraceB;\r\n P3[(X - 1) * bpp + 1] := TraceB;\r\n P3[(X - 1) * bpp + 2] := TraceB;\r\n end;\r\n end;\r\n end;\r\n if P1[X] <> P2[X] then\r\n begin\r\n if not hasb then\r\n begin\r\n tb := P2[X];\r\n hasb := True;\r\n P3[X * bpp] := TraceB;\r\n P3[X * bpp + 1] := TraceB;\r\n P3[X * bpp + 2] := TraceB;\r\n end\r\n else\r\n begin\r\n if P1[X] <> tb then\r\n begin\r\n P3[X * bpp] := TraceB;\r\n P3[X * bpp + 1] := TraceB;\r\n P3[X * bpp + 2] := TraceB;\r\n end\r\n else\r\n begin\r\n P4[X * bpp] := TraceB;\r\n P4[X * bpp + 1] := TraceB;\r\n P4[X * bpp + 2] := TraceB;\r\n end;\r\n end;\r\n end;\r\n Dec(X);\r\n until X <= 1;\r\n end;\r\n end;\r\n Bitmap.Free;\r\nend;\r\n\r\nclass procedure TJvPaintFX.ShadowUpLeft(const Dst: TBitmap);\r\nvar\r\n X, Y: Integer;\r\n Bitmap: TBitmap;\r\n P1, P2: PByteArray;\r\nbegin\r\n Bitmap := TBitmap.Create;\r\n Bitmap.Width := Dst.Width;\r\n Bitmap.Height := Dst.Height;\r\n Bitmap.PixelFormat := pf24bit;\r\n Bitmap.Canvas.Draw(0, 0, Dst);\r\n for Y := 0 to Bitmap.Height - 5 do\r\n begin\r\n P1 := Bitmap.ScanLine[Y];\r\n P2 := Bitmap.ScanLine[Y + 4];\r\n for X := 0 to Bitmap.Width - 5 do\r\n if P1[X * bpp] > P2[(X + 4) * bpp] then\r\n begin\r\n P1[X * bpp] := P2[(X + 4) * bpp] + 1;\r\n P1[X * bpp + 1] := P2[(X + 4) * bpp + 1] + 1;\r\n P1[X * bpp + 2] := P2[(X + 4) * bpp + 2] + 1;\r\n end;\r\n end;\r\n Dst.Assign(Bitmap);\r\n Bitmap.Free;\r\nend;\r\n\r\nclass procedure TJvPaintFX.ShadowUpRight(const Dst: TBitmap);\r\nvar\r\n X, Y: Integer;\r\n Bitmap: TBitmap;\r\n P1, P2: PByteArray;\r\nbegin\r\n Bitmap := TBitmap.Create;\r\n Bitmap.Width := Dst.Width;\r\n Bitmap.Height := Dst.Height;\r\n Bitmap.PixelFormat := pf24bit;\r\n Bitmap.Canvas.Draw(0, 0, Dst);\r\n for Y := 0 to Bitmap.Height - 5 do\r\n begin\r\n P1 := Bitmap.ScanLine[Y];\r\n P2 := Bitmap.ScanLine[Y + 4];\r\n for X := Bitmap.Width - 1 downto 4 do\r\n if P1[X * bpp] > P2[(X - 4) * bpp] then\r\n begin\r\n P1[X * bpp] := P2[(X - 4) * bpp] + 1;\r\n P1[X * bpp + 1] := P2[(X - 4) * bpp + 1] + 1;\r\n P1[X * bpp + 2] := P2[(X - 4) * bpp + 2] + 1;\r\n end;\r\n end;\r\n Dst.Assign(Bitmap);\r\n Bitmap.Free;\r\nend;\r\n\r\nclass procedure TJvPaintFX.ShadowDownLeft(const Dst: TBitmap);\r\nvar\r\n X, Y: Integer;\r\n Bitmap: TBitmap;\r\n P1, P2: PByteArray;\r\nbegin\r\n Bitmap := TBitmap.Create;\r\n Bitmap.Width := Dst.Width;\r\n Bitmap.Height := Dst.Height;\r\n Bitmap.PixelFormat := pf24bit;\r\n Bitmap.Canvas.Draw(0, 0, Dst);\r\n for Y := Bitmap.Height - 1 downto 4 do\r\n begin\r\n P1 := Bitmap.ScanLine[Y];\r\n P2 := Bitmap.ScanLine[Y - 4];\r\n for X := 0 to Bitmap.Width - 5 do\r\n if P1[X * bpp] > P2[(X + 4) * bpp] then\r\n begin\r\n P1[X * bpp] := P2[(X + 4) * bpp] + 1;\r\n P1[X * bpp + 1] := P2[(X + 4) * bpp + 1] + 1;\r\n P1[X * bpp + 2] := P2[(X + 4) * bpp + 2] + 1;\r\n end;\r\n end;\r\n Dst.Assign(Bitmap);\r\n Bitmap.Free;\r\nend;\r\n\r\nclass procedure TJvPaintFX.ShadowDownRight(const Dst: TBitmap);\r\nvar\r\n X, Y: Integer;\r\n Bitmap: TBitmap;\r\n P1, P2: PByteArray;\r\nbegin\r\n Bitmap := TBitmap.Create;\r\n Bitmap.Width := Dst.Width;\r\n Bitmap.Height := Dst.Height;\r\n Bitmap.PixelFormat := pf24bit;\r\n Bitmap.Canvas.Draw(0, 0, Dst);\r\n for Y := Bitmap.Height - 1 downto 4 do\r\n begin\r\n P1 := Bitmap.ScanLine[Y];\r\n P2 := Bitmap.ScanLine[Y - 4];\r\n for X := Bitmap.Width - 1 downto 4 do\r\n if P1[X * bpp] > P2[(X - 4) * bpp] then\r\n begin\r\n P1[X * bpp] := P2[(X - 4) * bpp] + 1;\r\n P1[X * bpp + 1] := P2[(X - 4) * bpp + 1] + 1;\r\n P1[X * bpp + 2] := P2[(X - 4) * bpp + 2] + 1;\r\n end;\r\n end;\r\n Dst.Assign(Bitmap);\r\n Bitmap.Free;\r\nend;\r\n\r\nclass procedure TJvPaintFX.SemiOpaque(Src, Dst: TBitmap);\r\nvar\r\n B: TBitmap;\r\n P: PByteArray;\r\n X, Y: Integer;\r\nbegin\r\n B := TBitmap.Create;\r\n B.Width := Src.Width;\r\n B.Height := Src.Height;\r\n B.PixelFormat := pf24bit;\r\n B.Canvas.Draw(0, 0, Src);\r\n for Y := 0 to B.Height - 1 do\r\n begin\r\n P := B.ScanLine[Y];\r\n if (Y mod 2) = 0 then\r\n begin\r\n for X := 0 to B.Width - 1 do\r\n if (X mod 2) = 0 then\r\n begin\r\n P[X * bpp] := $FF;\r\n P[X * bpp + 1] := $FF;\r\n P[X * bpp + 2] := $FF;\r\n end;\r\n end\r\n else\r\n begin\r\n for X := 0 to B.Width - 1 do\r\n if ((X + 1) mod 2) = 0 then\r\n begin\r\n P[X * bpp] := $FF;\r\n P[X * bpp + 1] := $FF;\r\n P[X * bpp + 2] := $FF;\r\n end;\r\n end;\r\n end;\r\n B.Transparent := True;\r\n B.TransparentColor := clWhite;\r\n Dst.Canvas.Draw(0, 0, B);\r\n B.Free;\r\n\r\nend;\r\n\r\nclass procedure TJvPaintFX.QuartoOpaque(Src, Dst: TBitmap);\r\nvar\r\n B: TBitmap;\r\n P: PByteArray;\r\n X, Y: Integer;\r\nbegin\r\n B := TBitmap.Create;\r\n B.Width := Src.Width;\r\n B.Height := Src.Height;\r\n B.PixelFormat := pf24bit;\r\n B.Canvas.Draw(0, 0, Src);\r\n for Y := 0 to B.Height - 1 do\r\n begin\r\n P := B.ScanLine[Y];\r\n if (Y mod 2) = 0 then\r\n begin\r\n for X := 0 to B.Width - 1 do\r\n if (X mod 2) = 0 then\r\n begin\r\n P[X * bpp] := $FF;\r\n P[X * bpp + 1] := $FF;\r\n P[X * bpp + 2] := $FF;\r\n end;\r\n end\r\n else\r\n begin\r\n for X := 0 to B.Width - 1 do\r\n begin\r\n P[X * bpp] := $FF;\r\n P[X * bpp + 1] := $FF;\r\n P[X * bpp + 2] := $FF;\r\n end;\r\n\r\n end;\r\n end;\r\n B.Transparent := True;\r\n B.TransparentColor := clWhite;\r\n Dst.Canvas.Draw(0, 0, B);\r\n B.Free;\r\nend;\r\n\r\nclass procedure TJvPaintFX.FoldRight(Src1, Src2, Dst: TBitmap; Amount: Single);\r\nvar\r\n W, H, X, Y, xf, xf0: Integer;\r\n PS1, PS2, PD: PByteArray;\r\nbegin\r\n Src1.PixelFormat := pf24bit;\r\n Src2.PixelFormat := pf24bit;\r\n W := Src1.Width;\r\n H := Src2.Height;\r\n Dst.Width := W;\r\n Dst.Height := H;\r\n Dst.PixelFormat := pf24bit;\r\n xf := Round(Amount * W);\r\n for Y := 0 to H - 1 do\r\n begin\r\n PS1 := Src1.ScanLine[Y];\r\n PS2 := Src2.ScanLine[Y];\r\n PD := Dst.ScanLine[Y];\r\n for X := 0 to xf do\r\n begin\r\n xf0 := xf + (xf - X);\r\n if xf0 < W then\r\n begin\r\n PD[xf0 * bpp] := PS1[X * bpp];\r\n PD[xf0 * bpp + 1] := PS1[X * bpp + 1];\r\n PD[xf0 * bpp + 2] := PS1[X * bpp + 2];\r\n PD[X * bpp] := PS2[X * bpp];\r\n PD[X * bpp + 1] := PS2[X * bpp + 1];\r\n PD[X * bpp + 2] := PS2[X * bpp + 2];\r\n end;\r\n end;\r\n if (2 * xf) < W - 1 then\r\n for X := 2 * xf + 1 to W - 1 do\r\n begin\r\n PD[X * bpp] := PS1[X * bpp];\r\n PD[X * bpp + 1] := PS1[X * bpp + 1];\r\n PD[X * bpp + 2] := PS1[X * bpp + 2];\r\n end;\r\n end;\r\nend;\r\n\r\nclass procedure TJvPaintFX.Mandelbrot(const Dst: TBitmap; Factor: Integer);\r\nconst\r\n MaxX = 1.25;\r\n MinX = -2;\r\n MaxY = 1.25;\r\n MinY = -1.25;\r\nvar\r\n W, H, X, Y: Integer;\r\n DX, DY: Extended;\r\n Line: PByteArray;\r\n Color: Integer;\r\n\r\n function IsMandel(CA, CBi: Extended): Integer;\r\n const\r\n MAX_ITERATION = 64;\r\n var\r\n OldA: Extended; {just a variable to keep 'a' from being destroyed}\r\n A, B: Extended; {function Z divided in real and imaginary parts}\r\n LengthZ: Extended; {length of Z, sqrt(length_z)>2 => Z->infinity}\r\n Iteration: Integer;\r\n begin\r\n A := 0; {initialize Z(0) = 0}\r\n B := 0;\r\n Iteration := 0; {initialize Iteration}\r\n repeat\r\n OldA := A; {saves the 'a' (Will be destroyed in next line}\r\n A := A * A - B * B + CA;\r\n B := 2 * OldA * B + CBi;\r\n Iteration := Iteration + 1;\r\n LengthZ := A * A + B * B;\r\n until (LengthZ >= 4) or (Iteration > MAX_ITERATION);\r\n Result := Iteration;\r\n end;\r\n\r\nbegin\r\n W := Dst.Width;\r\n H := Dst.Height;\r\n Dst.PixelFormat := pf24bit;\r\n DX := (MaxX - MinX) / W;\r\n DY := (MaxY - MinY) / H;\r\n for Y := 0 to H - 1 do\r\n begin\r\n Line := Dst.ScanLine[Y];\r\n for X := 0 to W - 1 do\r\n begin\r\n Color := IsMandel(MinX + X * DX, MinY + Y * DY);\r\n if Color > Factor then\r\n Color := $FF\r\n else\r\n Color := $00;\r\n Line[X * bpp] := Color;\r\n Line[X * bpp + 1] := Color;\r\n Line[X * bpp + 2] := Color;\r\n end;\r\n end;\r\nend;\r\n\r\nclass procedure TJvPaintFX.MaskMandelbrot(const Dst: TBitmap; Factor: Integer);\r\nvar\r\n Bm: TBitmap;\r\nbegin\r\n Bm := TBitmap.Create;\r\n Bm.Width := Dst.Width;\r\n Bm.Height := Dst.Height;\r\n Mandelbrot(Bm, Factor);\r\n Bm.Transparent := True;\r\n Bm.TransparentColor := clWhite;\r\n Dst.Canvas.Draw(0, 0, Bm);\r\n Bm.Free;\r\nend;\r\n\r\nclass procedure TJvPaintFX.KeepBlue(const Dst: TBitmap; Factor: Single);\r\nvar\r\n X, Y, W, H: Integer;\r\n Line: PByteArray;\r\nbegin\r\n Dst.PixelFormat := pf24bit;\r\n W := Dst.Width;\r\n H := Dst.Height;\r\n for Y := 0 to H - 1 do\r\n begin\r\n Line := Dst.ScanLine[Y];\r\n for X := 0 to W - 1 do\r\n begin\r\n Line[X * bpp] := Round(Factor * Line[X * bpp]);\r\n Line[X * bpp + 1] := 0;\r\n Line[X * bpp + 2] := 0;\r\n end;\r\n end;\r\nend;\r\n\r\nclass procedure TJvPaintFX.KeepGreen(const Dst: TBitmap; Factor: Single);\r\nvar\r\n X, Y, W, H: Integer;\r\n Line: PByteArray;\r\nbegin\r\n Dst.PixelFormat := pf24bit;\r\n W := Dst.Width;\r\n H := Dst.Height;\r\n for Y := 0 to H - 1 do\r\n begin\r\n Line := Dst.ScanLine[Y];\r\n for X := 0 to W - 1 do\r\n begin\r\n Line[X * bpp + 1] := Round(Factor * Line[X * bpp + 1]);\r\n Line[X * bpp] := 0;\r\n Line[X * bpp + 2] := 0;\r\n end;\r\n end;\r\nend;\r\n\r\nclass procedure TJvPaintFX.KeepRed(const Dst: TBitmap; Factor: Single);\r\nvar\r\n X, Y, W, H: Integer;\r\n Line: PByteArray;\r\nbegin\r\n Dst.PixelFormat := pf24bit;\r\n W := Dst.Width;\r\n H := Dst.Height;\r\n for Y := 0 to H - 1 do\r\n begin\r\n Line := Dst.ScanLine[Y];\r\n for X := 0 to W - 1 do\r\n begin\r\n Line[X * bpp + 2] := Round(Factor * Line[X * bpp + 2]);\r\n Line[X * bpp + 1] := 0;\r\n Line[X * bpp] := 0;\r\n end;\r\n end;\r\nend;\r\n\r\nclass procedure TJvPaintFX.Shake(Src, Dst: TBitmap; Factor: Single);\r\nvar\r\n X, Y, H, W, DX: Integer;\r\n P: PByteArray;\r\nbegin\r\n Dst.Canvas.Draw(0, 0, Src);\r\n Dst.PixelFormat := pf24bit;\r\n W := Dst.Width;\r\n H := Dst.Height;\r\n DX := Round(Factor * W);\r\n if DX = 0 then\r\n Exit;\r\n if DX > (W div 2) then\r\n Exit;\r\n\r\n for Y := 0 to H - 1 do\r\n begin\r\n P := Dst.ScanLine[Y];\r\n if (Y mod 2) = 0 then\r\n for X := DX to W - 1 do\r\n begin\r\n P[(X - DX) * bpp] := P[X * bpp];\r\n P[(X - DX) * bpp + 1] := P[X * bpp + 1];\r\n P[(X - DX) * bpp + 2] := P[X * bpp + 2];\r\n end\r\n else\r\n for X := W - 1 downto DX do\r\n begin\r\n P[X * bpp] := P[(X - DX) * bpp];\r\n P[X * bpp + 1] := P[(X - DX) * bpp + 1];\r\n P[X * bpp + 2] := P[(X - DX) * bpp + 2];\r\n end;\r\n end;\r\n\r\nend;\r\n\r\nclass procedure TJvPaintFX.ShakeDown(Src, Dst: TBitmap; Factor: Single);\r\nvar\r\n X, Y, H, W, DY: Integer;\r\n P, P2, P3: PByteArray;\r\nbegin\r\n Dst.Canvas.Draw(0, 0, Src);\r\n Dst.PixelFormat := pf24bit;\r\n W := Dst.Width;\r\n H := Dst.Height;\r\n DY := Round(Factor * H);\r\n if DY = 0 then\r\n Exit;\r\n if DY > (H div 2) then\r\n Exit;\r\n\r\n for Y := DY to H - 1 do\r\n begin\r\n P := Dst.ScanLine[Y];\r\n P2 := Dst.ScanLine[Y - DY];\r\n for X := 0 to W - 1 do\r\n if (X mod 2) = 0 then\r\n begin\r\n P2[X * bpp] := P[X * bpp];\r\n P2[X * bpp + 1] := P[X * bpp + 1];\r\n P2[X * bpp + 2] := P[X * bpp + 2];\r\n end;\r\n end;\r\n for Y := H - 1 - DY downto 0 do\r\n begin\r\n P := Dst.ScanLine[Y];\r\n P3 := Dst.ScanLine[Y + DY];\r\n for X := 0 to W - 1 do\r\n if (X mod 2) <> 0 then\r\n begin\r\n P3[X * bpp] := P[X * bpp];\r\n P3[X * bpp + 1] := P[X * bpp + 1];\r\n P3[X * bpp + 2] := P[X * bpp + 2];\r\n end;\r\n end;\r\nend;\r\n\r\nclass procedure TJvPaintFX.Plasma(Src1, Src2, Dst: TBitmap; Scale, Turbulence: Single);\r\nvar\r\n cval, sval: array [0..255] of Integer;\r\n I, X, Y, W, H, XX, YY: Integer;\r\n Asin, Acos: Extended;\r\n PS1, PS2, PD: PByteArray;\r\nbegin\r\n W := Src1.Width;\r\n H := Src1.Height;\r\n if Turbulence < 10 then\r\n Turbulence := 10;\r\n if Scale < 5 then\r\n Scale := 5;\r\n for I := 0 to 255 do\r\n begin\r\n sincos(I / Turbulence, Asin, Acos);\r\n sval[I] := Round(-Scale * Asin);\r\n cval[I] := Round(Scale * Acos);\r\n end;\r\n for Y := 0 to H - 1 do\r\n begin\r\n PD := Dst.ScanLine[Y];\r\n PS2 := Src2.ScanLine[Y];\r\n for X := 0 to W - 1 do\r\n begin\r\n XX := X + sval[PS2[X * bpp]];\r\n YY := Y + cval[PS2[X * bpp]];\r\n if (XX >= 0) and (XX < W) and (YY >= 0) and (YY < H) then\r\n begin\r\n PS1 := Src1.ScanLine[YY];\r\n PD[X * bpp] := PS1[XX * bpp];\r\n PD[X * bpp + 1] := PS1[XX * bpp + 1];\r\n PD[X * bpp + 2] := PS1[XX * bpp + 2];\r\n end;\r\n end;\r\n end;\r\n ;\r\nend;\r\n\r\nclass procedure TJvPaintFX.SplitRound(Src, Dst: TBitmap; Amount: Integer; Style: TLightBrush);\r\nvar\r\n X, Y, W, C, c00, DX, CX: Integer;\r\n R, R00: TRect;\r\n Bm, bm2: TBitmap;\r\n p0, p00, P1: PByteArray;\r\nbegin\r\n if Amount = 0 then\r\n begin\r\n Dst.Canvas.Draw(0, 0, Src);\r\n Exit;\r\n end;\r\n CX := Src.Width div 2;\r\n if Amount > CX then\r\n Amount := CX;\r\n W := Src.Width;\r\n Bm := TBitmap.Create;\r\n Bm.PixelFormat := pf24bit;\r\n Bm.Height := 1;\r\n Bm.Width := CX;\r\n bm2 := TBitmap.Create;\r\n bm2.PixelFormat := pf24bit;\r\n bm2.Height := 1;\r\n bm2.Width := CX;\r\n p0 := Bm.ScanLine[0];\r\n p00 := bm2.ScanLine[0];\r\n DX := 0;\r\n for Y := 0 to Src.Height - 1 do\r\n begin\r\n P1 := Src.ScanLine[Y];\r\n for X := 0 to CX - 1 do\r\n begin\r\n C := X * bpp;\r\n c00 := (CX + X) * bpp;\r\n p0[C] := P1[C];\r\n p0[C + 1] := P1[C + 1];\r\n p0[C + 2] := P1[C + 2];\r\n p00[C] := P1[c00];\r\n p00[C + 1] := P1[c00 + 1];\r\n p00[C + 2] := P1[c00 + 2];\r\n end;\r\n case Style of\r\n mbSplitRound:\r\n DX := Round(Amount * Abs(Sin(Y / (Src.Height - 1) * Pi)));\r\n mbSplitWaste:\r\n DX := Round(Amount * Abs(Cos(Y / (Src.Height - 1) * Pi)));\r\n end;\r\n R := Rect(0, Y, DX, Y + 1);\r\n Dst.Canvas.StretchDraw(R, Bm);\r\n R00 := Rect(W - 1 - DX, Y, W - 1, Y + 1);\r\n Dst.Canvas.StretchDraw(R00, bm2);\r\n end;\r\n Bm.Free;\r\n bm2.Free;\r\nend;\r\n\r\nclass procedure TJvPaintFX.Emboss(var Bmp: TBitmap);\r\nvar\r\n X, Y: Integer;\r\n P1, P2: PByteArray;\r\nbegin\r\n for Y := 0 to Bmp.Height - 2 do\r\n begin\r\n P1 := Bmp.ScanLine[Y];\r\n P2 := Bmp.ScanLine[Y + 1];\r\n for X := 0 to Bmp.Width - 4 do\r\n begin\r\n P1[X * bpp] := (P1[X * bpp] + (P2[(X + bpp) * bpp] xor $FF)) shr 1;\r\n P1[X * bpp + 1] := (P1[X * bpp + 1] + (P2[(X + bpp) * bpp + 1] xor $FF)) shr 1;\r\n P1[X * bpp + 2] := (P1[X * bpp + 2] + (P2[(X + bpp) * bpp + 2] xor $FF)) shr 1;\r\n end;\r\n end;\r\n\r\nend;\r\n\r\nclass procedure TJvPaintFX.FilterRed(const Dst: TBitmap; Min, Max: Integer);\r\nvar\r\n C, X, Y: Integer;\r\n P1: PByteArray;\r\nbegin\r\n for Y := 0 to Dst.Height - 1 do\r\n begin\r\n P1 := Dst.ScanLine[Y];\r\n for X := 0 to Dst.Width - 1 do\r\n begin\r\n C := X * bpp;\r\n if (P1[C + 2] > Min) and (P1[C + 2] < Max) then\r\n P1[C + 2] := $FF\r\n else\r\n P1[C + 2] := 0;\r\n P1[C] := 0;\r\n P1[C + 1] := 0;\r\n end;\r\n end;\r\nend;\r\n\r\nclass procedure TJvPaintFX.FilterGreen(const Dst: TBitmap; Min, Max: Integer);\r\nvar\r\n C, X, Y: Integer;\r\n P1: PByteArray;\r\nbegin\r\n for Y := 0 to Dst.Height - 1 do\r\n begin\r\n P1 := Dst.ScanLine[Y];\r\n for X := 0 to Dst.Width - 1 do\r\n begin\r\n C := X * bpp;\r\n if (P1[C + 1] > Min) and (P1[C + 1] < Max) then\r\n P1[C + 1] := $FF\r\n else\r\n P1[C + 1] := 0;\r\n P1[C] := 0;\r\n P1[C + 2] := 0;\r\n end;\r\n end;\r\nend;\r\n\r\nclass procedure TJvPaintFX.FilterBlue(const Dst: TBitmap; Min, Max: Integer);\r\nvar\r\n C, X, Y: Integer;\r\n P1: PByteArray;\r\nbegin\r\n for Y := 0 to Dst.Height - 1 do\r\n begin\r\n P1 := Dst.ScanLine[Y];\r\n for X := 0 to Dst.Width - 1 do\r\n begin\r\n C := X * bpp;\r\n if (P1[C] > Min) and (P1[C] < Max) then\r\n P1[C] := $FF\r\n else\r\n P1[C] := 0;\r\n P1[C + 1] := 0;\r\n P1[C + 2] := 0;\r\n end;\r\n end;\r\nend;\r\n\r\nclass procedure TJvPaintFX.FilterXRed(const Dst: TBitmap; Min, Max: Integer);\r\nvar\r\n C, X, Y: Integer;\r\n P1: PByteArray;\r\nbegin\r\n for Y := 0 to Dst.Height - 1 do\r\n begin\r\n P1 := Dst.ScanLine[Y];\r\n for X := 0 to Dst.Width - 1 do\r\n begin\r\n C := X * bpp;\r\n if (P1[C + 2] > Min) and (P1[C + 2] < Max) then\r\n P1[C + 2] := $FF\r\n else\r\n P1[C + 2] := 0;\r\n end;\r\n end;\r\nend;\r\n\r\nclass procedure TJvPaintFX.FilterXGreen(const Dst: TBitmap; Min, Max: Integer);\r\nvar\r\n C, X, Y: Integer;\r\n P1: PByteArray;\r\nbegin\r\n for Y := 0 to Dst.Height - 1 do\r\n begin\r\n P1 := Dst.ScanLine[Y];\r\n for X := 0 to Dst.Width - 1 do\r\n begin\r\n C := X * bpp;\r\n if (P1[C + 1] > Min) and (P1[C + 1] < Max) then\r\n P1[C + 1] := $FF\r\n else\r\n P1[C + 1] := 0;\r\n end;\r\n end;\r\nend;\r\n\r\nclass procedure TJvPaintFX.FilterXBlue(const Dst: TBitmap; Min, Max: Integer);\r\nvar\r\n C, X, Y: Integer;\r\n P1: PByteArray;\r\nbegin\r\n for Y := 0 to Dst.Height - 1 do\r\n begin\r\n P1 := Dst.ScanLine[Y];\r\n for X := 0 to Dst.Width - 1 do\r\n begin\r\n C := X * bpp;\r\n if (P1[C] > Min) and (P1[C] < Max) then\r\n P1[C] := $FF\r\n else\r\n P1[C] := 0;\r\n end;\r\n end;\r\nend;\r\n\r\nclass procedure TJvPaintFX.DrawMandelJulia(const Dst: TBitmap; x0, y0, x1, y1: Single; Niter: Integer; Mandel: Boolean);\r\nconst\r\n //Number if colors. If this is changed, the number of mapped colors must also be changed\r\n nc = 16;\r\ntype\r\n TJvRGBTriplet = record\r\n R: Byte;\r\n G: Byte;\r\n B: Byte;\r\n end;\r\nvar\r\n X, XX, Y, YY, CX, CY, DX, DY, XSquared, YSquared: Double;\r\n NX, NY, PY, PX, I: Integer;\r\n Line: PByteArray;\r\n cc: array [0..15] of TJvRGBTriplet;\r\n AColor: TColor;\r\nbegin\r\n Dst.PixelFormat := pf24bit;\r\n for I := 0 to 15 do\r\n begin\r\n AColor := ConvertColor(I);\r\n cc[I].B := GetBValue(ColorToRGB(AColor));\r\n cc[I].G := GetGValue(ColorToRGB(AColor));\r\n cc[I].R := GetRValue(ColorToRGB(AColor));\r\n end;\r\n if Niter < nc then\r\n Niter := nc;\r\n try\r\n NX := Dst.Width;\r\n NY := Dst.Height;\r\n CX := 0;\r\n CY := 1;\r\n DX := (x1 - x0) / NX;\r\n DY := (y1 - y0) / NY;\r\n PY := 0;\r\n while PY < NY do\r\n begin\r\n Line := Dst.ScanLine[PY];\r\n PX := 0;\r\n while (PX < NX) do\r\n begin\r\n X := x0 + PX * DX;\r\n Y := y0 + PY * DY;\r\n if Mandel then\r\n begin\r\n CX := X;\r\n CY := Y;\r\n X := 0;\r\n Y := 0;\r\n end;\r\n XSquared := 0;\r\n YSquared := 0;\r\n I := 0;\r\n while (I <= Niter) and (XSquared + YSquared < (4)) do\r\n begin\r\n XSquared := X * X;\r\n YSquared := Y * Y;\r\n XX := XSquared - YSquared + CX;\r\n YY := (2 * X * Y) + CY;\r\n X := XX;\r\n Y := YY;\r\n I := I + 1;\r\n end;\r\n I := I - 1;\r\n if (I = Niter) then\r\n I := 0\r\n else\r\n I := Round(I / (Niter / nc));\r\n // Canvas.Pixels[PX,PY] := ConvertColor(I);\r\n Line[PX * 3] := cc[I].B;\r\n Line[PX * 3 + 1] := cc[I].G;\r\n Line[PX * 3 + 2] := cc[I].R;\r\n PX := PX + 1;\r\n end;\r\n PY := PY + 1;\r\n end;\r\n finally\r\n end;\r\nend;\r\n\r\nclass procedure TJvPaintFX.Invert(Src: TBitmap);\r\nvar\r\n W, H, X, Y: Integer;\r\n P: PByteArray;\r\nbegin\r\n W := Src.Width;\r\n H := Src.Height;\r\n Src.PixelFormat := pf24bit;\r\n for Y := 0 to H - 1 do\r\n begin\r\n P := Src.ScanLine[Y];\r\n for X := 0 to W - 1 do\r\n begin\r\n P[X * bpp] := not P[X * bpp];\r\n P[X * bpp + 1] := not P[X * bpp + 1];\r\n P[X * bpp + 2] := not P[X * bpp + 2];\r\n end;\r\n end;\r\nend;\r\n\r\nclass procedure TJvPaintFX.MirrorRight(Src: TBitmap);\r\nvar\r\n W, H, X, Y: Integer;\r\n P: PByteArray;\r\nbegin\r\n W := Src.Width;\r\n H := Src.Height;\r\n Src.PixelFormat := pf24bit;\r\n for Y := 0 to H - 1 do\r\n begin\r\n P := Src.ScanLine[Y];\r\n for X := 0 to W div 2 do\r\n begin\r\n P[(W - 1 - X) * bpp] := P[X * bpp];\r\n P[(W - 1 - X) * bpp + 1] := P[X * bpp + 1];\r\n P[(W - 1 - X) * bpp + 2] := P[X * bpp + 2];\r\n end;\r\n end;\r\nend;\r\n\r\nclass procedure TJvPaintFX.MirrorDown(Src: TBitmap);\r\nvar\r\n W, H, X, Y: Integer;\r\n P1, P2: PByteArray;\r\nbegin\r\n W := Src.Width;\r\n H := Src.Height;\r\n Src.PixelFormat := pf24bit;\r\n for Y := 0 to H div 2 do\r\n begin\r\n P1 := Src.ScanLine[Y];\r\n P2 := Src.ScanLine[H - 1 - Y];\r\n for X := 0 to W - 1 do\r\n begin\r\n P2[X * bpp] := P1[X * bpp];\r\n P2[X * bpp + 1] := P1[X * bpp + 1];\r\n P2[X * bpp + 2] := P1[X * bpp + 2];\r\n end;\r\n end;\r\nend;\r\n\r\n// resample image as triangles\r\n\r\nclass procedure TJvPaintFX.Triangles(const Dst: TBitmap; Amount: Integer);\r\ntype\r\n TTriplet = record\r\n R: Byte;\r\n G: Byte;\r\n B: Byte;\r\n end;\r\nvar\r\n W, H, X, Y, tb, tm, te: Integer;\r\n PS: PByteArray;\r\n T: TTriplet;\r\nbegin\r\n W := Dst.Width;\r\n H := Dst.Height;\r\n Dst.PixelFormat := pf24bit;\r\n if Amount < 5 then\r\n Amount := 5;\r\n Amount := (Amount div 2) * 2 + 1;\r\n tm := Amount div 2;\r\n for Y := 0 to H - 1 do\r\n begin\r\n PS := Dst.ScanLine[Y];\r\n T.R := PS[0];\r\n T.G := PS[1];\r\n T.B := PS[2];\r\n tb := Y mod (Amount - 1);\r\n if tb > tm then\r\n tb := 2 * tm - tb;\r\n if tb = 0 then\r\n tb := Amount;\r\n te := tm + Abs(tm - (Y mod Amount));\r\n for X := 0 to W - 1 do\r\n begin\r\n if (X mod tb) = 0 then\r\n begin\r\n T.R := PS[X * bpp];\r\n T.G := PS[X * bpp + 1];\r\n T.B := PS[X * bpp + 2];\r\n end;\r\n if ((X mod te) = 1) and (tb <> 0) then\r\n begin\r\n T.R := PS[X * bpp];\r\n T.G := PS[X * bpp + 1];\r\n T.B := PS[X * bpp + 2];\r\n end;\r\n PS[X * bpp] := T.R;\r\n PS[X * bpp + 1] := T.G;\r\n PS[X * bpp + 2] := T.B;\r\n end;\r\n end;\r\nend;\r\n\r\nclass procedure TJvPaintFX.RippleTooth(const Dst: TBitmap; Amount: Integer);\r\nvar\r\n X, Y: Integer;\r\n P1, P2: PByteArray;\r\n B: Byte;\r\nbegin\r\n Dst.PixelFormat := pf24bit;\r\n Amount := Min(Dst.Height div 2, Amount);\r\n for Y := Dst.Height - 1 - Amount downto 0 do\r\n begin\r\n P1 := Dst.ScanLine[Y];\r\n B := 0;\r\n for X := 0 to Dst.Width - 1 do\r\n begin\r\n P2 := Dst.ScanLine[Y + B];\r\n P2[X * bpp] := P1[X * bpp];\r\n P2[X * bpp + 1] := P1[X * bpp + 1];\r\n P2[X * bpp + 2] := P1[X * bpp + 2];\r\n Inc(B);\r\n if B > Amount then\r\n B := 0;\r\n end;\r\n end;\r\nend;\r\n\r\nclass procedure TJvPaintFX.RippleTriangle(const Dst: TBitmap; Amount: Integer);\r\nvar\r\n X, Y: Integer;\r\n P1, P2: PByteArray;\r\n B: Byte;\r\n doinc: Boolean;\r\nbegin\r\n Amount := Min(Dst.Height div 2, Amount);\r\n for Y := Dst.Height - 1 - Amount downto 0 do\r\n begin\r\n P1 := Dst.ScanLine[Y];\r\n B := 0;\r\n doinc := True;\r\n for X := 0 to Dst.Width - 1 do\r\n begin\r\n P2 := Dst.ScanLine[Y + B];\r\n P2[X * bpp] := P1[X * bpp];\r\n P2[X * bpp + 1] := P1[X * bpp + 1];\r\n P2[X * bpp + 2] := P1[X * bpp + 2];\r\n if doinc then\r\n begin\r\n Inc(B);\r\n if B > Amount then\r\n begin\r\n doinc := False;\r\n B := Amount - 1;\r\n end;\r\n end\r\n else\r\n begin\r\n if B = 0 then\r\n begin\r\n doinc := True;\r\n B := 2;\r\n end;\r\n Dec(B);\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\nclass procedure TJvPaintFX.RippleRandom(const Dst: TBitmap; Amount: Integer);\r\nvar\r\n X, Y: Integer;\r\n P1, P2: PByteArray;\r\n B: Byte;\r\nbegin\r\n Amount := Min(Dst.Height div 2, Amount);\r\n Dst.PixelFormat := pf24bit;\r\n Randomize;\r\n for Y := Dst.Height - 1 - Amount downto 0 do\r\n begin\r\n P1 := Dst.ScanLine[Y];\r\n B := 0;\r\n for X := 0 to Dst.Width - 1 do\r\n begin\r\n P2 := Dst.ScanLine[Y + B];\r\n P2[X * bpp] := P1[X * bpp];\r\n P2[X * bpp + 1] := P1[X * bpp + 1];\r\n P2[X * bpp + 2] := P1[X * bpp + 2];\r\n B := Random(Amount);\r\n end;\r\n end;\r\nend;\r\n\r\nclass procedure TJvPaintFX.TexturizeOverlap(const Dst: TBitmap; Amount: Integer);\r\nvar\r\n W, H, X, Y, xo: Integer;\r\n Bm: TBitmap;\r\n ARect: TRect;\r\nbegin\r\n Bm := TBitmap.Create;\r\n Amount := Min(Dst.Width div 2, Amount);\r\n Amount := Min(Dst.Height div 2, Amount);\r\n xo := Round(Amount * 2 / 3);\r\n Bm.Width := Amount;\r\n Bm.Height := Amount;\r\n W := Dst.Width;\r\n H := Dst.Height;\r\n ARect := Rect(0, 0, Amount, Amount);\r\n Bm.Canvas.StretchDraw(ARect, Dst);\r\n Y := 0;\r\n repeat\r\n X := 0;\r\n repeat\r\n Dst.Canvas.Draw(X, Y, Bm);\r\n X := X + xo;\r\n until X >= W;\r\n Y := Y + xo;\r\n until Y >= H;\r\n Bm.Free;\r\nend;\r\n\r\nclass procedure TJvPaintFX.TexturizeTile(const Dst: TBitmap; Amount: Integer);\r\nvar\r\n W, H, X, Y: Integer;\r\n Bm: TBitmap;\r\n ARect: TRect;\r\nbegin\r\n Bm := TBitmap.Create;\r\n Amount := Min(Dst.Width div 2, Amount);\r\n Amount := Min(Dst.Height div 2, Amount);\r\n Bm.Width := Amount;\r\n Bm.Height := Amount;\r\n W := Dst.Width;\r\n H := Dst.Height;\r\n ARect := Rect(0, 0, Amount, Amount);\r\n Bm.Canvas.StretchDraw(ARect, Dst);\r\n Y := 0;\r\n repeat\r\n X := 0;\r\n repeat\r\n Dst.Canvas.Draw(X, Y, Bm);\r\n X := X + Bm.Width;\r\n until X >= W;\r\n Y := Y + Bm.Height;\r\n until Y >= H;\r\n Bm.Free;\r\nend;\r\n\r\nclass procedure TJvPaintFX.HeightMap(const Dst: TBitmap; Amount: Integer);\r\nvar\r\n Bm: TBitmap;\r\n W, H, X, Y: Integer;\r\n pb, PS: PByteArray;\r\n C: Integer;\r\nbegin\r\n H := Dst.Height;\r\n W := Dst.Width;\r\n Bm := TBitmap.Create;\r\n Bm.Width := W;\r\n Bm.Height := H;\r\n Bm.PixelFormat := pf24bit;\r\n Dst.PixelFormat := pf24bit;\r\n Bm.Canvas.Draw(0, 0, Dst);\r\n for Y := 0 to H - 1 do\r\n begin\r\n pb := Bm.ScanLine[Y];\r\n for X := 0 to W - 1 do\r\n begin\r\n C := Round((pb[X * bpp] + pb[X * bpp + 1] + pb[X * bpp + 2]) / 3 / 255 * Amount);\r\n if (Y - C) >= 0 then\r\n begin\r\n PS := Dst.ScanLine[Y - C];\r\n PS[X * bpp] := pb[X * bpp];\r\n PS[X * bpp + 1] := pb[X * bpp + 1];\r\n PS[X * bpp + 2] := pb[X * bpp + 2];\r\n end;\r\n end;\r\n end;\r\n Bm.Free;\r\nend;\r\n\r\nclass procedure TJvPaintFX.Turn(Src, Dst: TBitmap);\r\nvar\r\n W, H, X, Y: Integer;\r\n PS, PD: PByteArray;\r\nbegin\r\n H := Src.Height;\r\n W := Src.Width;\r\n Src.PixelFormat := pf24bit;\r\n Dst.PixelFormat := pf24bit;\r\n Dst.Height := W;\r\n Dst.Width := H;\r\n for Y := 0 to H - 1 do\r\n begin\r\n PS := Src.ScanLine[Y];\r\n for X := 0 to W - 1 do\r\n begin\r\n PD := Dst.ScanLine[W - 1 - X];\r\n PD[Y * bpp] := PS[X * bpp];\r\n PD[Y * bpp + 1] := PS[X * bpp + 1];\r\n PD[Y * bpp + 2] := PS[X * bpp + 2];\r\n end;\r\n end;\r\nend;\r\n\r\nclass procedure TJvPaintFX.TurnRight(Src, Dst: TBitmap);\r\nvar\r\n W, H, X, Y: Integer;\r\n PS, PD: PByteArray;\r\nbegin\r\n H := Src.Height;\r\n W := Src.Width;\r\n Src.PixelFormat := pf24bit;\r\n Dst.PixelFormat := pf24bit;\r\n Dst.Height := W;\r\n Dst.Width := H;\r\n for Y := 0 to H - 1 do\r\n begin\r\n PS := Src.ScanLine[Y];\r\n for X := 0 to W - 1 do\r\n begin\r\n PD := Dst.ScanLine[X];\r\n PD[(H - 1 - Y) * bpp] := PS[X * bpp];\r\n PD[(H - 1 - Y) * bpp + 1] := PS[X * bpp + 1];\r\n PD[(H - 1 - Y) * bpp + 2] := PS[X * bpp + 2];\r\n end;\r\n end;\r\nend;\r\n\r\nclass procedure TJvPaintFX.ExtractColor(const Dst: TBitmap; AColor: TColor);\r\nvar\r\n X, Y: Integer;\r\n P: PJvRGBArray;\r\n EColor: TColor;\r\n R, G, B: Byte;\r\n OPF: TPixelFormat;\r\n Val: Byte;\r\nbegin\r\n EColor := ColorToRGB(AColor);\r\n R := GetRValue(EColor);\r\n G := GetGValue(EColor);\r\n B := GetBValue(EColor);\r\n OPF := Dst.PixelFormat;\r\n Dst.PixelFormat := pf24bit;\r\n if EColor = 0 then\r\n Val := $FF\r\n else\r\n Val := 0;\r\n for Y := 0 to Dst.Height - 1 do\r\n begin\r\n P := Dst.ScanLine[Y];\r\n for X := 0 to Dst.Width - 1 do\r\n begin\r\n if ((P[X].rgbBlue <> B) or (P[X].rgbGreen <> G) or (P[X].rgbRed <> R)) then\r\n begin\r\n P[X].rgbBlue := Val;\r\n P[X].rgbGreen := Val;\r\n P[X].rgbRed := Val;\r\n end;\r\n end\r\n end;\r\n if AColor = clBlack then\r\n Dst.TransparentColor := clWhite\r\n else\r\n Dst.TransparentColor := clBlack;\r\n Dst.Transparent := True;\r\n Dst.PixelFormat := OPF;\r\nend;\r\n\r\nclass procedure TJvPaintFX.ExcludeColor(const Dst: TBitmap; AColor: TColor);\r\nbegin\r\n Dst.TransparentColor := AColor;\r\n Dst.Transparent := True;\r\nend;\r\n\r\nclass procedure TJvPaintFX.Blend(const Src1, Src2: TBitmap; var Dst: TBitmap; Amount: Single);\r\nvar\r\n W, H, X, Y: Integer;\r\n PS1, PS2, PD: PByteArray;\r\nbegin\r\n W := Src1.Width;\r\n H := Src1.Height;\r\n Dst.Width := W;\r\n Dst.Height := H;\r\n Src1.PixelFormat := pf24bit;\r\n Src2.PixelFormat := pf24bit;\r\n Dst.PixelFormat := pf24bit;\r\n for Y := 0 to H - 1 do\r\n begin\r\n PS1 := Src1.ScanLine[Y];\r\n PS2 := Src2.ScanLine[Y];\r\n PD := Dst.ScanLine[Y];\r\n for X := 0 to W - 1 do\r\n begin\r\n PD[X * bpp] := Round((1 - Amount) * PS1[X * bpp] + Amount * PS2[X * bpp]);\r\n PD[X * bpp + 1] := Round((1 - Amount) * PS1[X * bpp + 1] + Amount * PS2[X * bpp + 1]);\r\n PD[X * bpp + 2] := Round((1 - Amount) * PS1[X * bpp + 2] + Amount * PS2[X * bpp + 2]);\r\n end;\r\n end;\r\nend;\r\n\r\nclass procedure TJvPaintFX.Blend2(const Src1, Src2: TBitmap; var Dst: TBitmap; Amount: Single);\r\nvar\r\n W, H, X, Y: Integer;\r\n PS1, PS2, PD: PByteArray;\r\nbegin\r\n W := Src1.Width;\r\n H := Src1.Height;\r\n Dst.Width := W;\r\n Dst.Height := H;\r\n Src1.PixelFormat := pf24bit;\r\n Src2.PixelFormat := pf24bit;\r\n Dst.PixelFormat := pf24bit;\r\n for Y := 0 to H - 1 do\r\n begin\r\n PS1 := Src1.ScanLine[Y];\r\n PS2 := Src2.ScanLine[Y];\r\n PD := Dst.ScanLine[Y];\r\n for X := 0 to W - 1 do\r\n if ((PS2[X * bpp] = $FF) and (PS2[X * bpp + 1] = $FF) and (PS2[X * bpp + 2] = $FF)) then\r\n begin\r\n PD[X * bpp] := $FF;\r\n PD[X * bpp + 2] := $FF;\r\n PD[X * bpp + 2] := $FF;\r\n end\r\n else\r\n begin\r\n PD[X * bpp] := Round((1 - Amount) * PS1[X * bpp] + Amount * PS2[X * bpp]);\r\n PD[X * bpp + 1] := Round((1 - Amount) * PS1[X * bpp + 1] + Amount * PS2[X * bpp + 1]);\r\n PD[X * bpp + 2] := Round((1 - Amount) * PS1[X * bpp + 2] + Amount * PS2[X * bpp + 2]);\r\n end;\r\n end;\r\nend;\r\n\r\nclass procedure TJvPaintFX.Solarize(const Src: TBitmap; var Dst: TBitmap; Amount: Integer);\r\nvar\r\n X, Y: Integer;\r\n P: PJvRGBArray;\r\n C: Integer;\r\nbegin\r\n if Dst = nil then\r\n Dst := TBitmap.Create;\r\n Dst.Assign(Src);\r\n Dst.PixelFormat := pf24bit;\r\n for Y := 0 to Dst.Height - 1 do\r\n begin\r\n P := Dst.ScanLine[Y];\r\n for X := 0 to Dst.Width - 1 do\r\n begin\r\n C := (P[X].rgbBlue + P[X].rgbGreen + P[X].rgbRed) div 3;\r\n if C > Amount then\r\n begin\r\n P[X].rgbBlue := 255 - P[X].rgbBlue;\r\n P[X].rgbGreen := 255 - P[X].rgbGreen;\r\n P[X].rgbRed := 255 - P[X].rgbRed;\r\n end;\r\n end;\r\n end;\r\n Dst.PixelFormat := Src.PixelFormat;\r\nend;\r\n\r\nclass procedure TJvPaintFX.Posterize(const Src: TBitmap; var Dst: TBitmap; Amount: Integer);\r\nvar\r\n X, Y: Integer;\r\n PD: PJvRGBArray;\r\nbegin\r\n if Dst = nil then\r\n Dst := TBitmap.Create;\r\n Dst.Assign(Src);\r\n Dst.PixelFormat := pf24bit;\r\n for Y := 0 to Dst.Height - 1 do\r\n begin\r\n PD := Dst.ScanLine[Y];\r\n for X := 0 to Dst.Width - 1 do\r\n begin\r\n PD[X].rgbBlue := Round(PD[X].rgbBlue / Amount) * Amount;\r\n PD[X].rgbGreen := Round(PD[X].rgbGreen / Amount) * Amount;\r\n PD[X].rgbRed := Round(PD[X].rgbRed / Amount) * Amount;\r\n end;\r\n end;\r\n Dst.PixelFormat := Src.PixelFormat;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend." }, { "path": "External/Jedi/Jvcl/run/JvPainterEffectsForm.dfm", "content": "object PainterEffectsForm: TPainterEffectsForm\r\n Left = 480\r\n Top = 153\r\n BorderStyle = bsToolWindow\r\n Caption = 'Painter Effects'\r\n ClientHeight = 303\r\n ClientWidth = 180\r\n Color = clBtnFace\r\n Font.Charset = DEFAULT_CHARSET\r\n Font.Color = clWindowText\r\n Font.Height = -11\r\n Font.Name = 'MS Sans Serif'\r\n Font.Style = []\r\n FormStyle = fsStayOnTop\r\n OldCreateOrder = False\r\n PixelsPerInch = 96\r\n TextHeight = 13\r\n object EffectsPanel: TPanel\r\n Left = 0\r\n Top = 0\r\n Width = 180\r\n Height = 303\r\n Align = alClient\r\n TabOrder = 0\r\n object Label1: TLabel\r\n Left = 137\r\n Top = 267\r\n Width = 26\r\n Height = 13\r\n Caption = 'rot cx'\r\n end\r\n object Label2: TLabel\r\n Left = 137\r\n Top = 284\r\n Width = 26\r\n Height = 13\r\n Caption = 'rot cy'\r\n end\r\n object Label3: TLabel\r\n Left = 137\r\n Top = 247\r\n Width = 18\r\n Height = 13\r\n Caption = 'turb'\r\n end\r\n object EBar: TScrollBar\r\n Left = 152\r\n Top = 7\r\n Width = 16\r\n Height = 176\r\n Kind = sbVertical\r\n \r\n TabOrder = 0\r\n OnChange = EBarChange\r\n end\r\n object ExtraBar: TScrollBar\r\n Left = 13\r\n Top = 247\r\n Width = 118\r\n Height = 12\r\n Max = 300\r\n Min = 1\r\n \r\n Position = 1\r\n TabOrder = 1\r\n OnChange = EBarChange\r\n end\r\n object ETree: TTreeView\r\n Left = 13\r\n Top = 7\r\n Width = 131\r\n Height = 228\r\n Color = clBlack\r\n Font.Charset = DEFAULT_CHARSET\r\n Font.Color = clYellow\r\n Font.Height = -11\r\n Font.Name = 'MS Sans Serif'\r\n Font.Style = []\r\n HideSelection = False\r\n HotTrack = True\r\n Indent = 19\r\n ParentFont = False\r\n TabOrder = 2\r\n OnClick = ETreeClick\r\n Items.Data = {\r\n 1D000000210000000000000000000000FFFFFFFFFFFFFFFF0000000000000000\r\n 08436F6E7472617374230000000100000000000000FFFFFFFFFFFFFFFF000000\r\n 00000000000A53617475726174696F6E230000000200000000000000FFFFFFFF\r\n FFFFFFFF00000000000000000A4272696768746E6573731D000000FFFFFFFF00\r\n 000000FFFFFFFFFFFFFFFF000000000200000004426C75722600000003000000\r\n 00000000FFFFFFFFFFFFFFFF00000000000000000D476175737369616E20426C\r\n 7572230000000400000000000000FFFFFFFFFFFFFFFF00000000000000000A53\r\n 706C697420426C75721E000000FFFFFFFF00000000FFFFFFFFFFFFFFFF000000\r\n 0002000000054E6F6973651E0000000500000000000000FFFFFFFFFFFFFFFF00\r\n 0000000000000005436F6C6F721D0000000600000000000000FFFFFFFFFFFFFF\r\n FF0000000000000000044D6F6E6F1F0000000700000000000000FFFFFFFFFFFF\r\n FFFF000000000000000006536D6F6F7468210000000800000000000000FFFFFF\r\n FFFFFFFFFF0000000000000000085365616D6C6573731F000000090000000000\r\n 0000FFFFFFFFFFFFFFFF0000000000000000064D6F736169631E0000000A0000\r\n 0000000000FFFFFFFFFFFFFFFF0000000000000000055477697374200000000B\r\n 00000000000000FFFFFFFFFFFFFFFF000000000000000007466973686579651D\r\n 000000FFFFFFFF00000000FFFFFFFFFFFFFFFF00000000030000000457617665\r\n 1F0000000C00000000000000FFFFFFFFFFFFFFFF0000000000000000064E6F72\r\n 6D616C1E0000000D00000000000000FFFFFFFFFFFFFFFF000000000000000005\r\n 4578747261220000000E00000000000000FFFFFFFFFFFFFFFF00000000000000\r\n 0009496E666572656E63651F0000000F00000000000000FFFFFFFFFFFFFFFF00\r\n 0000000000000006526F74617465240000001000000000000000FFFFFFFFFFFF\r\n FFFF00000000000000000B53706C6974204C696768741E000000FFFFFFFF0000\r\n 0000FFFFFFFFFFFFFFFF00000000080000000557696E67731D00000011000000\r\n 00000000FFFFFFFFFFFFFFFF000000000000000004446565701D000000120000\r\n 0000000000FFFFFFFFFFFFFFFF000000000000000004446F776E1B0000001300\r\n 000000000000FFFFFFFFFFFFFFFF00000000000000000255701D000000140000\r\n 0000000000FFFFFFFFFFFFFFFF000000000000000004466F6C641F0000001500\r\n 000000000000FFFFFFFFFFFFFFFF000000000000000006546F756368651E0000\r\n 001600000000000000FFFFFFFFFFFFFFFF000000000000000005466C79657221\r\n 0000001700000000000000FFFFFFFFFFFFFFFF000000000000000008466C6970\r\n 6F7665721D0000001800000000000000FFFFFFFFFFFFFFFF0000000000000000\r\n 04576176791F0000001900000000000000FFFFFFFFFFFFFFFF00000000000000\r\n 0006456D626F73731F000000FFFFFFFF00000000FFFFFFFFFFFFFFFF00000000\r\n 0600000006436F6C6F72731C0000001A00000000000000FFFFFFFFFFFFFFFF00\r\n 00000000000000035265641E0000001B00000000000000FFFFFFFFFFFFFFFF00\r\n 0000000000000005477265656E1D0000001C00000000000000FFFFFFFFFFFFFF\r\n FF000000000000000004426C75651D0000001D00000000000000FFFFFFFFFFFF\r\n FFFF000000000000000004585265641F0000001E00000000000000FFFFFFFFFF\r\n FFFFFF00000000000000000658477265656E1E0000001F00000000000000FFFF\r\n FFFFFFFFFFFF00000000000000000558426C756520000000FFFFFFFF00000000\r\n FFFFFFFFFFFFFFFF00000000070000000753717565657A652300000020000000\r\n 00000000FFFFFFFFFFFFFFFF00000000000000000A486F72697A6F6E74616C1C\r\n 0000002100000000000000FFFFFFFFFFFFFFFF000000000000000003546F701F\r\n 0000002200000000000000FFFFFFFFFFFFFFFF000000000000000006426F7474\r\n 6F6D200000002300000000000000FFFFFFFFFFFFFFFF00000000000000000744\r\n 69616D6F6E641E0000002400000000000000FFFFFFFFFFFFFFFF000000000000\r\n 00000557617374651E0000002500000000000000FFFFFFFFFFFFFFFF00000000\r\n 0000000005526F756E64250000002600000000000000FFFFFFFFFFFFFFFF0000\r\n 0000000000000C446F75626C6520526F756E641E000000FFFFFFFF00000000FF\r\n FFFFFFFFFFFFFF00000000020000000553706C69741E00000027000000000000\r\n 00FFFFFFFFFFFFFFFF000000000000000005526F756E641E0000002800000000\r\n 000000FFFFFFFFFFFFFFFF00000000000000000557617374651E000000290000\r\n 0000000000FFFFFFFFFFFFFFFF00000000000000000553686561721F0000002A\r\n 00000000000000FFFFFFFFFFFFFFFF000000000000000006506C61736D612300\r\n 00002B00000000000000FFFFFFFFFFFFFFFF00000000000000000A4D616E6465\r\n 6C42726F741E0000002C00000000000000FFFFFFFFFFFFFFFF00000000000000\r\n 00054A756C6961220000002D00000000000000FFFFFFFFFFFFFFFF0000000000\r\n 00000009547269616E676C65731F0000000000000000000000FFFFFFFFFFFFFF\r\n FF000000000300000006526970706C651E0000002E00000000000000FFFFFFFF\r\n FFFFFFFF000000000000000005546F6F7468210000002F00000000000000FFFF\r\n FFFFFFFFFFFF000000000000000008547269616E676C651F0000003000000000\r\n 000000FFFFFFFFFFFFFFFF00000000000000000652616E646F6D220000000000\r\n 000000000000FFFFFFFFFFFFFFFF000000000200000009546578747572697A65\r\n 1D0000003100000000000000FFFFFFFFFFFFFFFF00000000000000000454696C\r\n 65200000003200000000000000FFFFFFFFFFFFFFFF0000000000000000074F76\r\n 65726C61701C0000003300000000000000FFFFFFFFFFFFFFFF00000000000000\r\n 00034D61701E0000003400000000000000FFFFFFFFFFFFFFFF00000000000000\r\n 0005426C656E64210000003500000000000000FFFFFFFFFFFFFFFF0000000000\r\n 00000008536F6C6172697A65220000003600000000000000FFFFFFFFFFFFFFFF\r\n 000000000000000009506F73746572697A65}\r\n end\r\n object CXBar: TScrollBar\r\n Left = 13\r\n Top = 267\r\n Width = 118\r\n Height = 12\r\n \r\n TabOrder = 3\r\n OnChange = EBarChange\r\n end\r\n object CYBar: TScrollBar\r\n Left = 13\r\n Top = 284\r\n Width = 118\r\n Height = 13\r\n \r\n TabOrder = 4\r\n OnChange = EBarChange\r\n end\r\n end\r\nend\r\n" }, { "path": "External/Jedi/Jvcl/run/JvPainterEffectsForm.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvPainterEffectsU.PAS, released on 2002-06-15.\r\n\r\nThe Initial Developer of the Original Code is Jan Verhoeven [jan1 dott verhoeven att wxs dott nl]\r\nPortions created by Jan Verhoeven are Copyright (C) 2002 Jan Verhoeven.\r\nAll Rights Reserved.\r\n\r\nContributor(s): Robert Love [rlove att slcdug dott org].\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvPainterEffectsForm.pas 12461 2009-08-14 17:21:33Z obones $\r\n\r\nunit JvPainterEffectsForm;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n SysUtils, Classes, Windows, Messages, Graphics, Controls, Forms, Dialogs,\r\n StdCtrls, ExtCtrls, ComCtrls,\r\n JvDrawImage, JvComponent;\r\n\r\ntype\r\n TPainterEffectsForm = class(TJvForm)\r\n EffectsPanel: TPanel;\r\n EBar: TScrollBar;\r\n ExtraBar: TScrollBar;\r\n ETree: TTreeView;\r\n CXBar: TScrollBar;\r\n CYBar: TScrollBar;\r\n Label1: TLabel;\r\n Label2: TLabel;\r\n Label3: TLabel;\r\n procedure ETreeClick(Sender: TObject);\r\n procedure EBarChange(Sender: TObject);\r\n private\r\n FPainterForm: TJvDrawImage;\r\n procedure Bar(AMax, AMin, APos: Integer);\r\n public\r\n procedure SetDrawImage(ADrawImage: TJvDrawImage);\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvPainterEffectsForm.pas $';\r\n Revision: '$Revision: 12461 $';\r\n Date: '$Date: 2009-08-14 19:21:33 +0200 (ven. 14 août 2009) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\n\r\n{$R *.dfm}\r\n\r\nprocedure TPainterEffectsForm.Bar(AMax, AMin, APos: Integer);\r\nbegin\r\n EBar.Max := AMax;\r\n EBar.Min := AMin;\r\n EBar.Position := APos;\r\nend;\r\n\r\nprocedure TPainterEffectsForm.ETreeClick(Sender: TObject);\r\ntype\r\n TBarParams = record\r\n Max: Integer;\r\n Min: Integer;\r\n Pos: Integer;\r\n end;\r\nconst\r\n cEffects: array [0..54] of TBarParams =\r\n (\r\n (Max: 100; Min: 0; Pos: 0), // contrast\r\n (Max: 255; Min: 0; Pos: 0), // saturation\r\n (Max: 100; Min: 0; Pos: 0), // brightness\r\n (Max: 20; Min: 0; Pos: 0), // gaussian blur\r\n (Max: 30; Min: 0; Pos: 0), // split blur\r\n (Max: 200; Min: 0; Pos: 0), // color noise\r\n (Max: 200; Min: 0; Pos: 0), // mono noise\r\n (Max: 20; Min: 0; Pos: 0), // smooth\r\n (Max: 15; Min: 3; Pos: 5), // seamless\r\n (Max: 30; Min: 2; Pos: 15), // mosaic\r\n (Max: 50; Min: 1; Pos: 10), // twist\r\n (Max: 100; Min: 55; Pos: 60), // fisheye\r\n (Max: 200; Min: 1; Pos: 15), // wave\r\n (Max: 200; Min: 1; Pos: 15), // wave extra\r\n (Max: 10; Min: 1; Pos: 1), // wave inference\r\n (Max: 360; Min: 0; Pos: 0), // smooth rotate\r\n (Max: 10; Min: 1; Pos: 1), // split light\r\n (Max: 400; Min: 1; Pos: 1), // wings\r\n (Max: 400; Min: 1; Pos: 1), // wings down\r\n (Max: 400; Min: 1; Pos: 1), // wings up\r\n (Max: 400; Min: 1; Pos: 1), // wings fold\r\n (Max: 400; Min: 1; Pos: 1), // wings touche\r\n (Max: 400; Min: 1; Pos: 1), // wings flyer\r\n (Max: 400; Min: 1; Pos: 1), // wings flipover\r\n (Max: 400; Min: 1; Pos: 1), // wings wavy\r\n (Max: 100; Min: 0; Pos: 0), // emboss\r\n (Max: 255; Min: 0; Pos: 128), // filter red\r\n (Max: 255; Min: 0; Pos: 128), // filter green\r\n (Max: 255; Min: 0; Pos: 128), // filter blue\r\n (Max: 255; Min: 0; Pos: 128), // filter Xred\r\n (Max: 255; Min: 0; Pos: 128), // filter Xgreen\r\n (Max: 255; Min: 0; Pos: 128), // filter xblue\r\n (Max: 255; Min: 0; Pos: 0), // squeezehor\r\n (Max: 255; Min: 0; Pos: 0), // squeezetop\r\n (Max: 255; Min: 0; Pos: 0), // squeezebottom\r\n (Max: 255; Min: 0; Pos: 0), // squeezediamond\r\n (Max: 255; Min: 0; Pos: 0), // squeezewaste\r\n (Max: 255; Min: 0; Pos: 0), // squeezeround\r\n (Max: 255; Min: 0; Pos: 0), // squeezeround2\r\n (Max: 255; Min: 0; Pos: 0), // splitround\r\n (Max: 255; Min: 0; Pos: 0), // splitwaste\r\n (Max: 100; Min: 0; Pos: 0), // shear\r\n (Max: 100; Min: 1; Pos: 1), // plasma\r\n (Max: 100; Min: 0; Pos: 0), // mandelbrot\r\n (Max: 100; Min: 0; Pos: 0), // julia\r\n (Max: 127; Min: 5; Pos: 19), // triangles\r\n (Max: 100; Min: 3; Pos: 3), // ripple tooth\r\n (Max: 100; Min: 3; Pos: 3), // ripple triangle\r\n (Max: 100; Min: 3; Pos: 3), // ripple random\r\n (Max: 100; Min: 3; Pos: 3), // texturize tile\r\n (Max: 100; Min: 3; Pos: 3), // texturize overlap\r\n (Max: 100; Min: 1; Pos: 1), // map\r\n (Max: 100; Min: 0; Pos: 0), // blend;\r\n (Max: 255; Min: 0; Pos: 1), // solarize\r\n (Max: 255; Min: 1; Pos: 1) // posterize\r\n );\r\nvar\r\n N: Integer;\r\nbegin\r\n if ETree.Selected <> nil then\r\n begin\r\n N := ETree.Selected.ImageIndex;\r\n if (N >= Low(cEffects)) and (N >= Low(cEffects)) then\r\n Bar(cEffects[N].Max, cEffects[N].Min, cEffects[N].Pos);\r\n end;\r\nend;\r\n\r\nprocedure TPainterEffectsForm.EBarChange(Sender: TObject);\r\nbegin\r\n if ETree.Selected <> nil then\r\n with FPainterForm do\r\n case ETree.Selected.ImageIndex of\r\n 0:\r\n ContrastBarChange(Sender);\r\n 1:\r\n SaturationBarChange(Sender);\r\n 2:\r\n lightnessBarChange(Sender);\r\n 3:\r\n BlurBarChange(Sender);\r\n 4:\r\n SplitBlurBarChange(Sender);\r\n 5:\r\n ColorNoiseBarChange(Sender);\r\n 6:\r\n MonoNoiseBarChange(Sender);\r\n 7:\r\n SmoothBarChange(Sender);\r\n 8:\r\n SeamBarChange;\r\n 9:\r\n MosaicBarChange;\r\n 10:\r\n TwistBarChange;\r\n 11:\r\n FisheyeBarChange;\r\n 12:\r\n WaveBarChange;\r\n 13:\r\n WaveExtraChange;\r\n 14:\r\n WaveInfChange;\r\n 15:\r\n RotateBar;\r\n 16:\r\n XFormABarChange;\r\n 17:\r\n MarbleBarChange;\r\n 18:\r\n Marble2BarChange;\r\n 19:\r\n Marble3BarChange;\r\n 20:\r\n Marble4BarChange;\r\n 21:\r\n Marble5BarChange;\r\n 22:\r\n Marble6BarChange;\r\n 23:\r\n Marble7BarChange;\r\n 24:\r\n Marble8BarChange;\r\n 25:\r\n EmbossBarChange;\r\n 26:\r\n FilterRedBarChange;\r\n 27:\r\n FilterGreenBarChange;\r\n 28:\r\n FilterBlueBarChange;\r\n 29:\r\n FilterXRedBarChange;\r\n 30:\r\n FilterXGreenBarChange;\r\n 31:\r\n FilterXBlueBarChange;\r\n 32:\r\n SqueezeHorBarChange;\r\n 33:\r\n SqueezeTopBarChange;\r\n 34:\r\n SqueezeBotBarChange;\r\n 35:\r\n SqueezeDiamondBarChange;\r\n 36:\r\n SqueezeWasteBarChange;\r\n 37:\r\n SqueezeRoundBarChange;\r\n 38:\r\n SqueezeRound2BarChange;\r\n 39:\r\n SplitRoundBarChange;\r\n 40:\r\n SplitWasteBarChange;\r\n 41:\r\n ShearBarChange;\r\n 42:\r\n PlasmaBarChange;\r\n 43:\r\n DrawMandelJulia(True);\r\n 44:\r\n DrawMandelJulia(False);\r\n 45:\r\n DrawTriangles;\r\n 46:\r\n RippleTooth;\r\n 47:\r\n RippleTriangle;\r\n 48:\r\n RippleRandom;\r\n 49:\r\n TexturizeTile;\r\n 50:\r\n TexturizeOverlap;\r\n 51:\r\n DrawMap;\r\n 52:\r\n DrawBlend;\r\n 53:\r\n DrawSolarize;\r\n 54:\r\n Posterize;\r\n end;\r\nend;\r\n\r\nprocedure TPainterEffectsForm.SetDrawImage(ADrawImage: TJvDrawImage);\r\nbegin\r\n FPainterForm := ADrawImage;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend." }, { "path": "External/Jedi/Jvcl/run/JvPainterQBForm.dfm", "content": "object PainterQBForm: TPainterQBForm\r\n Left = 443\r\n Top = 124\r\n BorderStyle = bsToolWindow\r\n Caption = 'QuickBack'\r\n ClientHeight = 292\r\n ClientWidth = 176\r\n Color = clBtnFace\r\n Font.Charset = DEFAULT_CHARSET\r\n Font.Color = clWindowText\r\n Font.Height = -11\r\n Font.Name = 'MS Sans Serif'\r\n Font.Style = []\r\n FormStyle = fsStayOnTop\r\n OldCreateOrder = False\r\n OnCreate = FormCreate\r\n OnShow = FormShow\r\n PixelsPerInch = 96\r\n TextHeight = 13\r\n object Bevel1: TBevel\r\n Left = 0\r\n Top = 0\r\n Width = 176\r\n Height = 92\r\n Align = alTop\r\n end\r\n object qbpresets: TComboBox\r\n Left = 7\r\n Top = 61\r\n Width = 163\r\n Height = 22\r\n Style = csOwnerDrawFixed\r\n ItemHeight = 16\r\n PopupMenu = presetspop\r\n Sorted = True\r\n TabOrder = 0\r\n OnClick = qbpresetsClick\r\n OnDrawItem = qbpresetsDrawItem\r\n end\r\n object Panel1: TPanel\r\n Left = 0\r\n Top = 92\r\n Width = 176\r\n Height = 200\r\n Align = alClient\r\n BevelOuter = bvNone\r\n TabOrder = 1\r\n object Shape1: TShape\r\n Left = 85\r\n Top = 10\r\n Width = 20\r\n Height = 12\r\n Brush.Color = clRed\r\n Pen.Style = psClear\r\n Shape = stCircle\r\n end\r\n object Shape2: TShape\r\n Left = 104\r\n Top = 10\r\n Width = 20\r\n Height = 12\r\n Brush.Color = clGreen\r\n Pen.Style = psClear\r\n Shape = stCircle\r\n end\r\n object Shape3: TShape\r\n Left = 124\r\n Top = 10\r\n Width = 20\r\n Height = 12\r\n Brush.Color = clBlue\r\n Pen.Style = psClear\r\n Shape = stCircle\r\n end\r\n object QBList: TListBox\r\n Left = 0\r\n Top = 0\r\n Width = 79\r\n Height = 200\r\n Align = alLeft\r\n ItemHeight = 13\r\n Items.Strings = (\r\n 'Prod'\r\n 'Sum'\r\n 'Sub'\r\n 'Xor'\r\n 'And'\r\n 'OutAnd'\r\n 'InAnd'\r\n 'OutXor'\r\n 'InXor'\r\n 'OutMod'\r\n 'InMod'\r\n 'ProdXor'\r\n 'SumXor'\r\n 'SubXor'\r\n 'ProdAnd'\r\n 'SumAnd'\r\n 'SubAnd'\r\n 'Inner'\r\n 'Outer'\r\n 'OutRed'\r\n 'InRed'\r\n 'OutGreen'\r\n 'InGreen'\r\n 'Outblue'\r\n 'InBlue'\r\n 'InModOut'\r\n 'OutModIn'\r\n 'OutModIn2'\r\n 'ModMod'\r\n 'ModModXor'\r\n 'Mod3'\r\n 'ModModSub'\r\n 'ModModAdd'\r\n 'ModModAnd'\r\n 'ModModOr'\r\n 'Xor3'\r\n 'XOr3Mod'\r\n 'SubXorSum'\r\n 'SubProdSum'\r\n 'ProdProdSum'\r\n 'DrawXor')\r\n TabOrder = 0\r\n OnClick = QBListClick\r\n end\r\n object trkred: TScrollBar\r\n Left = 87\r\n Top = 26\r\n Width = 16\r\n Height = 170\r\n Kind = sbVertical\r\n Max = 255\r\n \r\n TabOrder = 1\r\n OnChange = trkRedChange\r\n end\r\n object trkgreen: TScrollBar\r\n Left = 107\r\n Top = 26\r\n Width = 16\r\n Height = 170\r\n Kind = sbVertical\r\n Max = 255\r\n \r\n TabOrder = 2\r\n OnChange = trkGreenChange\r\n end\r\n object trkblue: TScrollBar\r\n Left = 126\r\n Top = 26\r\n Width = 16\r\n Height = 170\r\n Kind = sbVertical\r\n Max = 255\r\n \r\n TabOrder = 3\r\n OnChange = trkBlueChange\r\n end\r\n object trkfactor: TScrollBar\r\n Left = 152\r\n Top = 26\r\n Width = 16\r\n Height = 170\r\n Kind = sbVertical\r\n Max = 255\r\n Min = 16\r\n \r\n Position = 255\r\n TabOrder = 4\r\n OnChange = trkFactorChange\r\n end\r\n end\r\n object redradio: TRadioButton\r\n Left = 7\r\n Top = 7\r\n Width = 98\r\n Height = 13\r\n Caption = 'Prod'\r\n Font.Charset = DEFAULT_CHARSET\r\n Font.Color = clRed\r\n Font.Height = -11\r\n Font.Name = 'MS Sans Serif'\r\n Font.Style = []\r\n ParentFont = False\r\n TabOrder = 2\r\n OnClick = redradioClick\r\n end\r\n object greenradio: TRadioButton\r\n Left = 7\r\n Top = 23\r\n Width = 98\r\n Height = 14\r\n Caption = 'Prod'\r\n Font.Charset = DEFAULT_CHARSET\r\n Font.Color = clGreen\r\n Font.Height = -11\r\n Font.Name = 'MS Sans Serif'\r\n Font.Style = []\r\n ParentFont = False\r\n TabOrder = 3\r\n OnClick = greenradioClick\r\n end\r\n object blueradio: TRadioButton\r\n Left = 7\r\n Top = 39\r\n Width = 98\r\n Height = 14\r\n Caption = 'Prod'\r\n Font.Charset = DEFAULT_CHARSET\r\n Font.Color = clBlue\r\n Font.Height = -11\r\n Font.Name = 'MS Sans Serif'\r\n Font.Style = []\r\n ParentFont = False\r\n TabOrder = 4\r\n OnClick = blueradioClick\r\n end\r\n object presetspop: TPopupMenu\r\n Left = 136\r\n Top = 72\r\n object AddBackdrop1: TMenuItem\r\n Caption = '&Add Backdrop'\r\n OnClick = AddBackdrop1Click\r\n end\r\n object DeleteBackdrop1: TMenuItem\r\n Caption = '&Delete Backdrop'\r\n OnClick = DeleteBackdrop1Click\r\n end\r\n object UpdateBackdrop1: TMenuItem\r\n Caption = '&Update Backdrop'\r\n OnClick = UpdateBackdrop1Click\r\n end\r\n end\r\nend\r\n" }, { "path": "External/Jedi/Jvcl/run/JvPainterQBForm.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a Copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvPainterQBU.PAS, released on 2002-06-15.\r\n\r\nThe Initial Developer of the Original Code is Jan Verhoeven [jan1 dott verhoeven att wxs dott nl]\r\nPortions created by Jan Verhoeven are Copyright (C) 2002 Jan Verhoeven.\r\nAll Rights Reserved.\r\n\r\nContributor(s): Robert Love [rlove att slcdug dott org].\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvPainterQBForm.pas 12461 2009-08-14 17:21:33Z obones $\r\n\r\nunit JvPainterQBForm;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n SysUtils, Classes, Windows, Messages, Graphics, Controls,\r\n Forms, Dialogs, StdCtrls, ExtCtrls, Menus, ComCtrls,\r\n JvDrawImage, JvComponent;\r\n\r\ntype\r\n TPainterQBForm = class(TJvForm)\r\n Bevel1: TBevel;\r\n qbpresets: TComboBox;\r\n presetspop: TPopupMenu;\r\n AddBackdrop1: TMenuItem;\r\n DeleteBackdrop1: TMenuItem;\r\n Panel1: TPanel;\r\n QBList: TListBox;\r\n UpdateBackdrop1: TMenuItem;\r\n redradio: TRadioButton;\r\n greenradio: TRadioButton;\r\n blueradio: TRadioButton;\r\n trkred: TScrollBar;\r\n trkgreen: TScrollBar;\r\n trkblue: TScrollBar;\r\n trkfactor: TScrollBar;\r\n Shape1: TShape;\r\n Shape2: TShape;\r\n Shape3: TShape;\r\n procedure QBListClick(Sender: TObject);\r\n procedure FormShow(Sender: TObject);\r\n procedure qbpresetsDrawItem(Control: TWinControl; Index: Integer;\r\n Rect: TRect; State: TOwnerDrawState);\r\n procedure qbpresetsClick(Sender: TObject);\r\n procedure SetLabels;\r\n procedure AddBackdrop1Click(Sender: TObject);\r\n procedure DeleteBackdrop1Click(Sender: TObject);\r\n procedure FormCreate(Sender: TObject);\r\n procedure trkRedChange(Sender: TObject);\r\n procedure trkGreenChange(Sender: TObject);\r\n procedure trkBlueChange(Sender: TObject);\r\n procedure trkFactorChange(Sender: TObject);\r\n procedure UpdateBackdrop1Click(Sender: TObject);\r\n procedure redradioClick(Sender: TObject);\r\n procedure greenradioClick(Sender: TObject);\r\n procedure blueradioClick(Sender: TObject);\r\n procedure QuickBack;\r\n private\r\n FPainterForm: TJvDrawImage;\r\n public\r\n function StrToQuickBack(S: string): Boolean;\r\n procedure SetDrawImage(ADrawImage: TJvDrawImage);\r\n end;\r\n\r\nvar\r\n QBFile: string;\r\n QBDRed, QBDBlue, QBDGreen: Byte;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvPainterQBForm.pas $';\r\n Revision: '$Revision: 12461 $';\r\n Date: '$Date: 2009-08-14 19:21:33 +0200 (ven. 14 août 2009) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n JvConsts, JvResources, JvTypes;\r\n\r\n{$R *.dfm}\r\n\r\ntype\r\n TColorProc = function(OutLoop, InLoop: Integer): Integer;\r\n\r\nvar\r\n RedBack, GreenBack, BlueBack: TColorProc;\r\n QBFuncs: array [0..50] of TColorProc;\r\n ImgDrawFactor: Byte;\r\n QBRedFn, QBGreenFn, QBBlueFn: Integer;\r\n ApplDir: string;\r\n\r\nfunction BGProd(Inner, Outer: Integer): Integer;\r\nbegin\r\n Result := Outer * Inner mod ImgDrawFactor;\r\nend;\r\n\r\nfunction BGSum(Inner, Outer: Integer): Integer;\r\nbegin\r\n Result := (Outer + Inner) mod ImgDrawFactor;\r\nend;\r\n\r\nfunction BGSub(Inner, Outer: Integer): Integer;\r\nbegin\r\n Result := (Outer - Inner) mod ImgDrawFactor;\r\nend;\r\n\r\nfunction BGXor(Inner, Outer: Integer): Integer;\r\nbegin\r\n Result := (Outer xor Inner) mod ImgDrawFactor;\r\nend;\r\n\r\nfunction BGAnd(Inner, Outer: Integer): Integer;\r\nbegin\r\n Result := (Outer and Inner) mod ImgDrawFactor;\r\nend;\r\n\r\nfunction BGOutXor(Inner, Outer: Integer): Integer;\r\nbegin\r\n Result := Outer xor ImgDrawFactor;\r\nend;\r\n\r\nfunction BGInXor(Inner, Outer: Integer): Integer;\r\nbegin\r\n Result := Inner xor ImgDrawFactor;\r\nend;\r\n\r\nfunction BGOutAnd(Inner, Outer: Integer): Integer;\r\nbegin\r\n Result := Outer and ImgDrawFactor;\r\nend;\r\n\r\nfunction BGInAnd(Inner, Outer: Integer): Integer;\r\nbegin\r\n Result := Inner and ImgDrawFactor;\r\nend;\r\n\r\nfunction BGOutMod(Inner, Outer: Integer): Integer;\r\nbegin\r\n Result := Outer mod ImgDrawFactor;\r\nend;\r\n\r\nfunction BGInMod(Inner, Outer: Integer): Integer;\r\nbegin\r\n Result := Inner mod ImgDrawFactor;\r\nend;\r\n\r\nfunction BGProdXor(Inner, Outer: Integer): Integer;\r\nbegin\r\n Result := (Outer * Inner) xor ImgDrawFactor;\r\nend;\r\n\r\nfunction BGSumXor(Inner, Outer: Integer): Integer;\r\nbegin\r\n Result := (Outer + Inner) xor ImgDrawFactor;\r\nend;\r\n\r\nfunction BGSubXor(Inner, Outer: Integer): Integer;\r\nbegin\r\n Result := (Outer - Inner) xor ImgDrawFactor;\r\nend;\r\n\r\nfunction BGProdAnd(Inner, Outer: Integer): Integer;\r\nbegin\r\n Result := (Outer * Inner) and ImgDrawFactor;\r\nend;\r\n\r\nfunction BGSumAnd(Inner, Outer: Integer): Integer;\r\nbegin\r\n Result := (Outer + Inner) and ImgDrawFactor;\r\nend;\r\n\r\nfunction BGSubAnd(Inner, Outer: Integer): Integer;\r\nbegin\r\n Result := (Outer - Inner) and ImgDrawFactor;\r\nend;\r\n\r\nfunction BGInner(Inner, Outer: Integer): Integer;\r\nbegin\r\n Result := Inner;\r\nend;\r\n\r\nfunction BGOuter(Inner, Outer: Integer): Integer;\r\nbegin\r\n Result := Outer;\r\nend;\r\n\r\nfunction BGOutRed(Inner, Outer: Integer): Integer;\r\nbegin\r\n Result := QBDRed * Outer;\r\nend;\r\n\r\nfunction BGInRed(Inner, Outer: Integer): Integer;\r\nbegin\r\n Result := QBDRed * Inner;\r\nend;\r\n\r\nfunction BGOutGreen(Inner, Outer: Integer): Integer;\r\nbegin\r\n Result := QBDGreen * Outer;\r\nend;\r\n\r\nfunction BGInGreen(Inner, Outer: Integer): Integer;\r\nbegin\r\n Result := QBDGreen * Inner;\r\nend;\r\n\r\nfunction BGOutBlue(Inner, Outer: Integer): Integer;\r\nbegin\r\n Result := QBDBlue * Outer;\r\nend;\r\n\r\nfunction BGInBlue(Inner, Outer: Integer): Integer;\r\nbegin\r\n Result := QBDBlue * Inner;\r\nend;\r\n\r\nfunction BGInModOut(Inner, Outer: Integer): Integer;\r\nbegin\r\n if Outer < ImgDrawFactor then\r\n Outer := ImgDrawFactor;\r\n Result := Inner mod Outer;\r\nend;\r\n\r\nfunction BGOutModIn(Inner, Outer: Integer): Integer;\r\nbegin\r\n if Inner < ImgDrawFactor then\r\n Inner := ImgDrawFactor;\r\n Result := Outer mod Inner;\r\nend;\r\n\r\nfunction BGOutModIn2(Inner, Outer: Integer): Integer;\r\nbegin\r\n Result := Outer mod (2 + Inner) mod (2 + Outer + Inner);\r\nend;\r\n\r\nfunction BGModMod(Inner, Outer: Integer): Integer;\r\nbegin\r\n Result := (Outer mod ImgDrawFactor) * (Inner mod ImgDrawFactor);\r\nend;\r\n\r\nfunction BGModModXor(Inner, Outer: Integer): Integer;\r\nbegin\r\n Result := (Outer mod ImgDrawFactor) xor (Inner mod ImgDrawFactor);\r\nend;\r\n\r\nfunction BGMod3(Inner, Outer: Integer): Integer;\r\nbegin\r\n Result := (Outer mod ImgDrawFactor) mod ((Inner mod ImgDrawFactor) + 1);\r\nend;\r\n\r\nfunction BGModModSub(Inner, Outer: Integer): Integer;\r\nbegin\r\n Result := (Outer mod ImgDrawFactor) - (Inner mod ImgDrawFactor);\r\nend;\r\n\r\nfunction BGModModAdd(Inner, Outer: Integer): Integer;\r\nbegin\r\n Result := (Outer mod ImgDrawFactor) + (Inner mod ImgDrawFactor);\r\nend;\r\n\r\nfunction BGModModAnd(Inner, Outer: Integer): Integer;\r\nbegin\r\n Result := (Outer mod ImgDrawFactor) and (Inner mod ImgDrawFactor);\r\nend;\r\n\r\nfunction BGModModOr(Inner, Outer: Integer): Integer;\r\nbegin\r\n Result := (Outer mod ImgDrawFactor) or (Inner mod ImgDrawFactor);\r\nend;\r\n\r\nfunction BGXOr3(Inner, Outer: Integer): Integer;\r\nbegin\r\n Result := Outer xor ImgDrawFactor xor Inner;\r\nend;\r\n\r\nfunction BGXOr3Mod(Inner, Outer: Integer): Integer;\r\nbegin\r\n Result := (Outer xor Inner mod ImgDrawFactor) xor (Inner mod ImgDrawFactor);\r\nend;\r\n\r\nfunction BGSubXorSum(Inner, Outer: Integer): Integer;\r\nbegin\r\n Result := (Outer - Inner) xor (Outer + Inner);\r\nend;\r\n\r\nfunction BGSubProdSum(Inner, Outer: Integer): Integer;\r\nbegin\r\n Result := (Outer - Inner) * (Outer + Inner);\r\nend;\r\n\r\nfunction BGProdProdSum(Inner, Outer: Integer): Integer;\r\nbegin\r\n Result := (Outer * Inner) * (Outer + Inner);\r\nend;\r\n\r\nfunction BGDrawXor(Inner, Outer: Integer): Integer;\r\nbegin\r\n Result := (Outer - ImgDrawFactor) xor (ImgDrawFactor + Inner);\r\nend;\r\n\r\n// end of functions used in Quick Background\r\n\r\nprocedure SetQBFuncs;\r\nbegin\r\n QBFuncs[0] := BGProd;\r\n QBFuncs[1] := BGSum;\r\n QBFuncs[2] := BGSub;\r\n QBFuncs[3] := BGXor;\r\n QBFuncs[4] := BGAnd;\r\n QBFuncs[5] := BGOutAnd;\r\n QBFuncs[6] := BGInAnd;\r\n QBFuncs[7] := BGOutXor;\r\n QBFuncs[8] := BGInXor;\r\n QBFuncs[9] := BGOutMod;\r\n QBFuncs[10] := BGInMod;\r\n QBFuncs[11] := BGProdXor;\r\n QBFuncs[12] := BGSumXor;\r\n QBFuncs[13] := BGSubXor;\r\n QBFuncs[14] := BGProdAnd;\r\n QBFuncs[15] := BGSumAnd;\r\n QBFuncs[16] := BGSubAnd;\r\n QBFuncs[17] := BGInner;\r\n QBFuncs[18] := BGOuter;\r\n QBFuncs[19] := BGOutRed;\r\n QBFuncs[20] := BGInRed;\r\n QBFuncs[21] := BGOutGreen;\r\n QBFuncs[22] := BGInGreen;\r\n QBFuncs[23] := BGOutBlue;\r\n QBFuncs[24] := BGInBlue;\r\n QBFuncs[25] := BGInModOut;\r\n QBFuncs[26] := BGOutModIn;\r\n QBFuncs[27] := BGOutModIn2;\r\n QBFuncs[28] := BGModMod;\r\n QBFuncs[29] := BGModModXor;\r\n QBFuncs[30] := BGMod3;\r\n QBFuncs[31] := BGModModSub;\r\n QBFuncs[32] := BGModModAdd;\r\n QBFuncs[33] := BGModModAnd;\r\n QBFuncs[34] := BGModModOr;\r\n QBFuncs[35] := BGXOr3;\r\n QBFuncs[36] := BGXOr3Mod;\r\n QBFuncs[37] := BGSubXorSum;\r\n QBFuncs[38] := BGSubProdSum;\r\n QBFuncs[39] := BGProdProdSum;\r\n QBFuncs[40] := BGDrawXor;\r\nend;\r\n\r\nprocedure TPainterQBForm.QuickBack;\r\nvar\r\n Bmp: TBitmap;\r\n I, J: Integer;\r\n Line: PJvRGBArray;\r\nbegin\r\n RedBack := QBFuncs[QBRedFn];\r\n GreenBack := QBFuncs[QBGreenFn];\r\n BlueBack := QBFuncs[QBBlueFn];\r\n Bmp := TBitmap.Create;\r\n try\r\n Bmp.Assign(FPainterForm.Picture.Bitmap);\r\n Bmp.PixelFormat := pf24bit;\r\n for I := 0 to Bmp.Height - 1 do\r\n begin\r\n Line := Bmp.ScanLine[I];\r\n for J := 0 to Bmp.Width - 1 do\r\n begin\r\n Line[J].rgbRed := QBDRed + RedBack(I, J);\r\n Line[J].rgbGreen := QBDGreen + GreenBack(I, J);\r\n Line[J].rgbBlue := QBDBlue + BlueBack(I, J);\r\n end;\r\n end;\r\n FPainterForm.Preview(Bmp);\r\n finally\r\n Bmp.Free;\r\n end;\r\nend;\r\n\r\nprocedure TPainterQBForm.QBListClick(Sender: TObject);\r\nvar\r\n Index: Integer;\r\nbegin\r\n Index := QBList.ItemIndex;\r\n if redradio.Checked then\r\n QBRedFn := Index;\r\n if greenradio.Checked then\r\n QBGreenFn := Index;\r\n if blueradio.Checked then\r\n QBBlueFn := Index;\r\n SetLabels;\r\n QuickBack;\r\nend;\r\n\r\nprocedure TPainterQBForm.FormShow(Sender: TObject);\r\nbegin\r\n SetLabels;\r\nend;\r\n\r\n\r\nprocedure TPainterQBForm.qbpresetsDrawItem(Control: TWinControl;\r\n Index: Integer; Rect: TRect; State: TOwnerDrawState);\r\n\r\n\r\nvar\r\n S: string;\r\n P: Integer;\r\nbegin\r\n S := qbpresets.Items[Index];\r\n P := Pos('=', S);\r\n S := Copy(S, 1, P - 1);\r\n qbpresets.Canvas.TextRect(Rect, Rect.Left, Rect.Top, S);\r\nend;\r\n\r\nprocedure TPainterQBForm.qbpresetsClick(Sender: TObject);\r\nbegin\r\n if qbpresets.ItemIndex >= 0 then\r\n StrToQuickBack(qbpresets.Items[qbpresets.ItemIndex]);\r\nend;\r\n\r\nprocedure TPainterQBForm.SetLabels;\r\nbegin\r\n redradio.Caption := QBList.Items[QBRedFn];\r\n greenradio.Caption := QBList.Items[QBGreenFn];\r\n blueradio.Caption := QBList.Items[QBBlueFn];\r\nend;\r\n\r\nprocedure TPainterQBForm.AddBackdrop1Click(Sender: TObject);\r\nvar\r\n S: string;\r\nbegin\r\n S := InputBox(RsPainterQuickBackdrops, RsEnterName, '');\r\n if S = '' then\r\n Exit;\r\n S := S + '=' +\r\n IntToStr(QBRedFn) + ',' +\r\n IntToStr(QBGreenFn) + ',' +\r\n IntToStr(QBBlueFn) + ',' +\r\n IntToStr(QBDRed) + ',' +\r\n IntToStr(QBDGreen) + ',' +\r\n IntToStr(QBDBlue) + ',' +\r\n IntToStr(ImgDrawFactor);\r\n qbpresets.Items.Append(S);\r\n qbpresets.Items.SaveToFile(QBFile);\r\nend;\r\n\r\nprocedure TPainterQBForm.DeleteBackdrop1Click(Sender: TObject);\r\nbegin\r\n if qbpresets.ItemIndex >= 0 then\r\n begin\r\n qbpresets.Items.Delete(qbpresets.ItemIndex);\r\n qbpresets.Items.SaveToFile(QBFile);\r\n end;\r\nend;\r\n\r\nprocedure TPainterQBForm.FormCreate(Sender: TObject);\r\nbegin\r\n ImgDrawFactor := 255;\r\n QBDRed := 0;\r\n QBDBlue := 0;\r\n QBDGreen := 0;\r\n QBRedFn := 0;\r\n QBGreenFn := 0;\r\n QBBlueFn := 0;\r\n SetQBFuncs;\r\n QBFile := ApplDir + 'PainterQB.txt';\r\n if FileExists(QBFile) then\r\n qbpresets.Items.LoadFromFile(QBFile);\r\nend;\r\n\r\nprocedure TPainterQBForm.trkRedChange(Sender: TObject);\r\nbegin\r\n QBDRed := trkred.Position;\r\n QuickBack;\r\nend;\r\n\r\nprocedure TPainterQBForm.trkGreenChange(Sender: TObject);\r\nbegin\r\n QBDGreen := trkgreen.Position;\r\n QuickBack;\r\nend;\r\n\r\nprocedure TPainterQBForm.trkBlueChange(Sender: TObject);\r\nbegin\r\n QBDBlue := trkblue.Position;\r\n QuickBack;\r\nend;\r\n\r\nprocedure TPainterQBForm.trkFactorChange(Sender: TObject);\r\nbegin\r\n ImgDrawFactor := trkfactor.Position;\r\n QuickBack;\r\nend;\r\n\r\nprocedure TPainterQBForm.UpdateBackdrop1Click(Sender: TObject);\r\nvar\r\n S: string;\r\n P: Integer;\r\nbegin\r\n if qbpresets.ItemIndex < 0 then\r\n begin\r\n ShowMessage(RsNoItemSelected);\r\n Exit;\r\n end;\r\n S := qbpresets.Items[qbpresets.ItemIndex];\r\n P := Pos('=', S);\r\n S := Copy(S, 1, P - 1);\r\n S := InputBox(RsPainterQuickBackdrops, RsEnterName, S);\r\n if S = '' then\r\n Exit;\r\n S := S + '=' +\r\n IntToStr(QBRedFn) + ',' +\r\n IntToStr(QBGreenFn) + ',' +\r\n IntToStr(QBBlueFn) + ',' +\r\n IntToStr(QBDRed) + ',' +\r\n IntToStr(QBDGreen) + ',' +\r\n IntToStr(QBDBlue) + ',' +\r\n IntToStr(ImgDrawFactor);\r\n qbpresets.Items[qbpresets.ItemIndex] := S;\r\n qbpresets.Items.SaveToFile(QBFile);\r\nend;\r\n\r\nfunction TPainterQBForm.StrToQuickBack(S: string): Boolean;\r\nvar\r\n P: Integer;\r\n List: TStringList;\r\nbegin\r\n Result := False;\r\n P := Pos('=', S);\r\n if P = 0 then\r\n Exit;\r\n S := Copy(S, P + 1, Length(S));\r\n List := TStringList.Create;\r\n try\r\n try\r\n List.CommaText := S;\r\n QBRedFn := StrToInt(List[0]);\r\n QBGreenFn := StrToInt(List[1]);\r\n QBBlueFn := StrToInt(List[2]);\r\n QBDRed := StrToInt(List[3]);\r\n trkred.Position := QBDRed;\r\n QBDGreen := StrToInt(List[4]);\r\n trkgreen.Position := QBDGreen;\r\n QBDBlue := StrToInt(List[5]);\r\n trkblue.Position := QBDBlue;\r\n ImgDrawFactor := StrToInt(List[6]);\r\n trkfactor.Position := ImgDrawFactor;\r\n SetLabels;\r\n QuickBack;\r\n Result := True;\r\n except\r\n ShowMessage(RsErrorInPresets);\r\n Result := False;\r\n end;\r\n finally\r\n List.Free;\r\n end;\r\nend;\r\n\r\nprocedure TPainterQBForm.redradioClick(Sender: TObject);\r\nbegin\r\n QBList.ItemIndex := QBRedFn;\r\nend;\r\n\r\nprocedure TPainterQBForm.greenradioClick(Sender: TObject);\r\nbegin\r\n QBList.ItemIndex := QBGreenFn;\r\nend;\r\n\r\nprocedure TPainterQBForm.blueradioClick(Sender: TObject);\r\nbegin\r\n QBList.ItemIndex := QBBlueFn;\r\nend;\r\n\r\nprocedure TPainterQBForm.SetDrawImage(ADrawImage: TJvDrawImage);\r\nbegin\r\n FPainterForm := ADrawImage;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend." }, { "path": "External/Jedi/Jvcl/run/JvPanel.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvPanel.pas, released on 2001-02-28.\r\n\r\nThe Initial Developer of the Original Code is Sbastien Buysse [sbuysse att buypin dott com]\r\nPortions created by Sbastien Buysse are Copyright (C) 2001 Sbastien Buysse.\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\nMichael Beck [mbeck att bigfoot dott com].\r\npongtawat\r\nPeter Thornqvist [peter3 at sourceforge dot net]\r\nJens Fudickar [jens dott fudickar att oratool dott de]\r\ndejoy den [dejoy att ynl dott gov dott cn]\r\n\r\nChanges:\r\n\r\n>> dejoy --2005-04-28\r\n - Change TJvArrangeSettings to inherited from TJvPersistentProperty.\r\n - TJvCustomArrangePanel implemented interface of IJvHotTrack.\r\n - Renamed HotColor property to HotTrackOptions.Color.\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvPanel.pas 13415 2012-09-10 09:51:54Z obones $\r\n\r\nunit JvPanel;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, Messages,\r\n SysUtils, Classes, Graphics, Controls, Forms, ExtCtrls,\r\n JvTypes, JvThemes, JvExtComponent, JvExControls,\r\n JvHotTrackPersistent;\r\n\r\ntype\r\n TJvPanelResizeParentEvent = procedure(Sender: TObject; nLeft, nTop, nWidth, nHeight: Integer) of object;\r\n TJvPanelChangedSizeEvent = procedure(Sender: TObject; ChangedSize: Integer) of object;\r\n TJvAutoSizePanel = (asNone, asWidth, asHeight, asBoth);\r\n TJvArrangeSettingsVAlignment = (asTop, asVCenter, asBottom);\r\n TJvArrangeSettingsHAlignment = (asLeft, asCenter, asRight);\r\n\r\n TJvArrangeSettings = class(TJvPersistentProperty)\r\n private\r\n FAutoArrange: Boolean;\r\n FAutoSize: TJvAutoSizePanel;\r\n FWrapControls: Boolean;\r\n FBorderLeft: Integer;\r\n FBorderTop: Integer;\r\n FDistanceVertical: Integer;\r\n FDistanceHorizontal: Integer;\r\n FShowNotVisibleAtDesignTime: Boolean;\r\n FMaxWidth: Integer;\r\n FVerticalAlignment: TJvArrangeSettingsVAlignment;\r\n FHorizontalAlignment: TJvArrangeSettingsHAlignment;\r\n FMaxControlsPerLine: Integer;\r\n FHorizontalAlignLines: Boolean;\r\n procedure SetWrapControls(Value: Boolean);\r\n procedure SetAutoArrange(Value: Boolean);\r\n procedure SetAutoSize(Value: TJvAutoSizePanel);\r\n procedure SetBorderLeft(Value: Integer);\r\n procedure SetBorderTop(Value: Integer);\r\n procedure SetDistanceVertical(Value: Integer);\r\n procedure SetDistanceHorizontal(Value: Integer);\r\n procedure SetMaxWidth(Value: Integer);\r\n procedure SetHorizontalAlignment(const Value: TJvArrangeSettingsHAlignment);\r\n procedure SetVerticalAlignment(const Value: TJvArrangeSettingsVAlignment);\r\n procedure SetMaxControlsPerLine(const Value: Integer);\r\n procedure SetHorizontalAlignLines(const Value: Boolean);\r\n public\r\n constructor Create(AOwner: TPersistent); override;\r\n destructor Destroy; override;\r\n procedure Assign(Source: TPersistent); override;\r\n published\r\n property WrapControls: Boolean read FWrapControls write SetWrapControls default True;\r\n property BorderLeft: Integer read FBorderLeft write SetBorderLeft default 0;\r\n property BorderTop: Integer read FBorderTop write SetBorderTop default 0;\r\n property DistanceVertical: Integer read FDistanceVertical write SetDistanceVertical default 0;\r\n property DistanceHorizontal: Integer read FDistanceHorizontal write SetDistanceHorizontal default 0;\r\n property ShowNotVisibleAtDesignTime: Boolean read FShowNotVisibleAtDesignTime write FShowNotVisibleAtDesignTime default True;\r\n property AutoSize: TJvAutoSizePanel read FAutoSize write SetAutoSize default asNone;\r\n property AutoArrange: Boolean read FAutoArrange write SetAutoArrange default False;\r\n property MaxWidth: Integer read FMaxWidth write SetMaxWidth default 0;\r\n { MaxControlsPerLine specifies the max. number of controls that fit into a line. The following\r\n controls are moved to the next line. A value of zero means no limit. WrapControls is still\r\n considered. }\r\n property MaxControlsPerLine: Integer read FMaxControlsPerLine write SetMaxControlsPerLine default 0;\r\n { VerticalAlignment aligns the arranged control-block. in the panel unless AutoSize is asBoth or asHeight. }\r\n property VerticalAlignment: TJvArrangeSettingsVAlignment read FVerticalAlignment write SetVerticalAlignment default asTop;\r\n { HorizontalAlignment aligns the arranged control-block in the panel unless AutoSize is asBoth or asWidth. }\r\n property HorizontalAlignment: TJvArrangeSettingsHAlignment read FHorizontalAlignment write SetHorizontalAlignment default asLeft;\r\n { HorizontalAlignLines aligns the control-lines. This only works if WrapControls or MaxControlsPerLine is enabled }\r\n property HorizontalAlignLines: Boolean read FHorizontalAlignLines write SetHorizontalAlignLines default False;\r\n end;\r\n\r\n IJvArrangePanel = interface\r\n ['{8EE63749-CDDC-4436-9067-4EF0434B43C2}']\r\n procedure ArrangeControls;\r\n procedure DisableArrange;\r\n procedure EnableArrange;\r\n function GetArrangeSettings: TJvArrangeSettings;\r\n procedure SetArrangeSettings(const Value: TJvArrangeSettings);\r\n property ArrangeSettings: TJvArrangeSettings read GetArrangeSettings write SetArrangeSettings;\r\n end;\r\n\r\n TJvPanelHotTrackOptions = class(TJvHotTrackOptions)\r\n public\r\n constructor Create(AOwner: TPersistent); override;\r\n published\r\n property Color default clBtnFace;\r\n end;\r\n\r\n TJvPanelMoveEvent = procedure(Sender: TObject; X, Y: Integer; var Allow: Boolean) of object;\r\n\r\n TJvCustomArrangePanel = class(TJvCustomPanel, IJvDenySubClassing, IJvHotTrack, IJvArrangePanel)\r\n private\r\n FTransparent: Boolean;\r\n FFlatBorder: Boolean;\r\n FFlatBorderColor: TColor;\r\n FMultiLine: Boolean;\r\n FSizeable: Boolean;\r\n FDragging: Boolean;\r\n FLastPos: TPoint;\r\n FEnableArrangeCount: Integer;\r\n FArrangeControlActive: Boolean;\r\n FArrangeWidth: Integer;\r\n FArrangeHeight: Integer;\r\n FArrangeSettings: TJvArrangeSettings;\r\n FOnResizeParent: TJvPanelResizeParentEvent;\r\n FOnChangedWidth: TJvPanelChangedSizeEvent;\r\n FOnChangedHeight: TJvPanelChangedSizeEvent;\r\n FOnPaint: TNotifyEvent;\r\n FMovable: Boolean;\r\n FWasMoved: Boolean;\r\n FOnAfterMove: TNotifyEvent;\r\n FOnBeforeMove: TJvPanelMoveEvent;\r\n FHotTrack: Boolean;\r\n FHotTrackFont: TFont;\r\n FHotTrackFontOptions: TJvTrackFontOptions;\r\n FHotTrackOptions: TJvHotTrackOptions;\r\n FLastScreenCursor: TCursor;\r\n FPainting: Boolean;\r\n FRedrawingChildren: Boolean;\r\n function GetArrangeSettings: TJvArrangeSettings;\r\n function GetHeight: Integer;\r\n procedure SetHeight(Value: Integer);\r\n function GetWidth: Integer;\r\n procedure SetWidth(Value: Integer);\r\n procedure SetArrangeSettings(const Value: TJvArrangeSettings);\r\n procedure SetTransparent(const Value: Boolean);\r\n procedure SetFlatBorder(const Value: Boolean);\r\n procedure SetFlatBorderColor(const Value: TColor);\r\n procedure SetMultiLine(const Value: Boolean);\r\n procedure SetSizeable(const Value: Boolean);\r\n\r\n {IJvHotTrack} //added by dejoy 2005-04-28\r\n function GetHotTrack: Boolean;\r\n function GetHotTrackFont: TFont;\r\n function GetHotTrackFontOptions: TJvTrackFontOptions;\r\n function GetHotTrackOptions: TJvHotTrackOptions;\r\n procedure SetHotTrack(Value: Boolean);\r\n procedure SetHotTrackFont(Value: TFont);\r\n procedure SetHotTrackFontOptions(Value: TJvTrackFontOptions);\r\n procedure SetHotTrackOptions(Value: TJvHotTrackOptions);\r\n procedure IJvHotTrack_Assign(Source: IJvHotTrack);\r\n procedure IJvHotTrack.Assign = IJvHotTrack_Assign;\r\n protected\r\n procedure DrawCaption; dynamic;\r\n procedure DrawCaptionTo(ACanvas: TCanvas ); dynamic;\r\n procedure DrawBorders; dynamic;\r\n\r\n procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;\r\n procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;\r\n procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;\r\n procedure MouseEnter(Control: TControl); override;\r\n procedure MouseLeave(Control: TControl); override;\r\n procedure ParentColorChanged; override;\r\n procedure TextChanged; override;\r\n procedure Paint; override;\r\n function DoEraseBackground(Canvas: TCanvas; Param: LPARAM): Boolean; override;\r\n procedure CreateParams(var Params: TCreateParams); override;\r\n procedure WMNCHitTest(var Msg: TWMNCHitTest); message WM_NCHITTEST;\r\n procedure WMExitSizeMove(var Msg: TMessage); message WM_EXITSIZEMOVE;\r\n function DoBeforeMove(X, Y: Integer): Boolean; dynamic;\r\n procedure DoAfterMove; dynamic;\r\n procedure Loaded; override;\r\n procedure Resize; override;\r\n procedure Rearrange;\r\n procedure DoArrangeSettingsPropertyChanged(Sender: TObject; const PropName: string); virtual;\r\n procedure AlignControls(AControl: TControl; var Rect: TRect); override;\r\n function GetNextControlByTabOrder(ATabOrder: Integer): TWinControl;\r\n procedure SetSizeableCursor;\r\n procedure RestoreSizeableCursor;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n procedure SetBounds(ALeft, ATop, AWidth, AHeight: Integer); override;\r\n procedure ArrangeControls;\r\n procedure EnableArrange;\r\n procedure DisableArrange;\r\n function ArrangeEnabled: Boolean;\r\n property ArrangeWidth: Integer read FArrangeWidth;\r\n property ArrangeHeight: Integer read FArrangeHeight;\r\n property DockManager;\r\n property Canvas;\r\n\r\n property HotTrack: Boolean read GetHotTrack write SetHotTrack default False;\r\n property HotTrackFont: TFont read GetHotTrackFont write SetHotTrackFont;\r\n property HotTrackFontOptions: TJvTrackFontOptions read GetHotTrackFontOptions write SetHotTrackFontOptions default\r\n DefaultTrackFontOptions;\r\n property HotTrackOptions: TJvHotTrackOptions read GetHotTrackOptions write SetHotTrackOptions;\r\n\r\n property Movable: Boolean read FMovable write FMovable default False;\r\n property Sizeable: Boolean read FSizeable write SetSizeable default False;\r\n property Transparent: Boolean read FTransparent write SetTransparent default False;\r\n property MultiLine: Boolean read FMultiLine write SetMultiLine default False;\r\n //FlatBorder used the BorderWidth to draw the border\r\n property FlatBorder: Boolean read FFlatBorder write SetFlatBorder default False;\r\n property FlatBorderColor: TColor read FFlatBorderColor write SetFlatBorderColor default clBtnShadow;\r\n property OnBeforeMove: TJvPanelMoveEvent read FOnBeforeMove write FOnBeforeMove;\r\n property OnAfterMove: TNotifyEvent Read FOnAfterMove write FOnAfterMove;\r\n property OnPaint: TNotifyEvent read FOnPaint write FOnPaint;\r\n\r\n property ArrangeSettings: TJvArrangeSettings read GetArrangeSettings write SetArrangeSettings;\r\n property Width: Integer read GetWidth write SetWidth;\r\n property Height: Integer read GetHeight write SetHeight;\r\n property OnResizeParent: TJvPanelResizeParentEvent read FOnResizeParent write FOnResizeParent;\r\n property OnChangedWidth: TJvPanelChangedSizeEvent read FOnChangedWidth write FOnChangedWidth;\r\n property OnChangedHeight: TJvPanelChangedSizeEvent read FOnChangedHeight write FOnChangedHeight;\r\n end;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvPanel = class(TJvCustomArrangePanel)\r\n private\r\n FFilerTag: string;\r\n procedure ReadData(Reader: TReader);\r\n protected\r\n procedure DefineProperties(Filer: TFiler); override;\r\n published\r\n property HotTrack;\r\n property HotTrackFont;\r\n property HotTrackFontOptions;\r\n property HotTrackOptions;\r\n\r\n property Movable;\r\n property Sizeable;\r\n property HintColor;\r\n property Transparent;\r\n property MultiLine;\r\n property FlatBorder;\r\n property FlatBorderColor;\r\n property OnMouseEnter;\r\n property OnMouseLeave;\r\n property OnBeforeMove;\r\n property OnAfterMove;\r\n property OnParentColorChange;\r\n property OnPaint;\r\n\r\n property ArrangeSettings;\r\n property Width;\r\n property Height;\r\n property OnResizeParent;\r\n property OnChangedWidth;\r\n property OnChangedHeight;\r\n\r\n property Align;\r\n property Alignment;\r\n property Anchors;\r\n property AutoSize;\r\n property BiDiMode;\r\n property UseDockManager default True;\r\n property DockSite;\r\n property DragCursor;\r\n property DragKind;\r\n property FullRepaint;\r\n property Locked;\r\n property ParentBiDiMode;\r\n property OnCanResize;\r\n property OnDockDrop;\r\n property OnDockOver;\r\n property OnEndDock;\r\n property OnGetSiteInfo;\r\n property OnStartDock;\r\n property OnUnDock;\r\n property BevelEdges;\r\n property BevelInner;\r\n property BevelOuter;\r\n property BevelWidth;\r\n property BorderWidth;\r\n property BorderStyle;\r\n property Caption;\r\n property Color;\r\n property Constraints;\r\n {$IFDEF DELPHI2009_UP}\r\n property DoubleBuffered;\r\n {$ENDIF DELPHI2009_UP}\r\n property DragMode;\r\n property Enabled;\r\n property Font;\r\n {$IFDEF DELPHI2006_UP}\r\n property Padding;\r\n {$ENDIF DELPHI2006_UP}\r\n {$IFDEF JVCLThemesEnabled}\r\n property ParentBackground default True;\r\n {$ENDIF JVCLThemesEnabled}\r\n property ParentColor;\r\n property ParentFont;\r\n property ParentShowHint;\r\n property PopupMenu;\r\n property ShowHint;\r\n property TabOrder;\r\n property TabStop;\r\n {$IFDEF DELPHI2010_UP}\r\n property Touch;\r\n {$ENDIF DELPHI2010_UP}\r\n property Visible;\r\n property OnClick;\r\n property OnConstrainedResize;\r\n property OnContextPopup;\r\n property OnDblClick;\r\n property OnDragDrop;\r\n property OnDragOver;\r\n property OnEndDrag;\r\n property OnEnter;\r\n property OnExit;\r\n property OnMouseDown;\r\n property OnMouseMove;\r\n property OnMouseUp;\r\n property OnResize;\r\n property OnStartDrag;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvPanel.pas $';\r\n Revision: '$Revision: 13415 $';\r\n Date: '$Date: 2012-09-10 11:51:54 +0200 (lun. 10 sept. 2012) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n {$IFDEF HAS_UNIT_SYSTEM_UITYPES}\r\n System.UITypes,\r\n {$ENDIF}\r\n Types, {$IFDEF COMPILER7_UP}Themes,{$ENDIF}\r\n JvJCLUtils, JvJVCLUtils, JvResources;\r\n\r\nconst\r\n BkModeTransparent = TRANSPARENT;\r\n\r\n//=== { TJvArrangeSettings } =================================================\r\n\r\nconstructor TJvArrangeSettings.Create(AOwner: TPersistent);\r\nbegin\r\n inherited Create(AOwner);\r\n FMaxWidth := 0;\r\n FBorderLeft := 0;\r\n FBorderTop := 0;\r\n FDistanceVertical := 0;\r\n FDistanceHorizontal := 0;\r\n FMaxControlsPerLine := 0;\r\n FWrapControls := True;\r\n FShowNotVisibleAtDesignTime := True;\r\n FAutoSize := asNone;\r\n AutoArrange := False;\r\nend;\r\n\r\ndestructor TJvArrangeSettings.Destroy;\r\nbegin\r\n if (Owner is TJvPanel) and not (csDestroying in TJvPanel(Owner).ComponentState) then\r\n begin\r\n // User code tried to destroy the TJvPanel.ArrangeSettings\r\n // objects leaving the panel in a broken state. Please fix your code by adding\r\n //\r\n // if not ((Components[I] is TJvArrangeSettings) or\r\n // (Components[I] is TJvPanelHotTrackOptions)) then\r\n //\r\n // or by using the Controls[] array property if possible.\r\n\r\n raise EJVCLException.CreateRes(@RsDestroyingArrangeSettingsNotAllowed);\r\n end;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvArrangeSettings.SetWrapControls(Value: Boolean);\r\nbegin\r\n if Value <> FWrapControls then\r\n begin\r\n Changing;\r\n ChangingProperty('WrapControls');\r\n FWrapControls := Value;\r\n ChangedProperty('WrapControls');\r\n Changed;\r\n end;\r\nend;\r\n\r\nprocedure TJvArrangeSettings.SetAutoArrange(Value: Boolean);\r\nbegin\r\n if Value <> FAutoArrange then\r\n begin\r\n Changing;\r\n ChangingProperty('AutoArrange');\r\n FAutoArrange := Value;\r\n ChangedProperty('AutoArrange');\r\n Changed;\r\n end;\r\nend;\r\n\r\nprocedure TJvArrangeSettings.SetAutoSize(Value: TJvAutoSizePanel);\r\nbegin\r\n if Value <> FAutoSize then\r\n begin\r\n Changing;\r\n ChangingProperty('AutoSize');\r\n FAutoSize := Value;\r\n ChangedProperty('AutoSize');\r\n Changed;\r\n end;\r\nend;\r\n\r\nprocedure TJvArrangeSettings.SetBorderLeft(Value: Integer);\r\nbegin\r\n if Value <> FBorderLeft then\r\n begin\r\n Changing;\r\n ChangingProperty('BorderLeft');\r\n FBorderLeft := Value;\r\n ChangedProperty('BorderLeft');\r\n Changed;\r\n end;\r\nend;\r\n\r\nprocedure TJvArrangeSettings.SetBorderTop(Value: Integer);\r\nbegin\r\n if Value <> FBorderTop then\r\n begin\r\n Changing;\r\n ChangingProperty('BorderTop');\r\n FBorderTop := Value;\r\n ChangedProperty('BorderTop');\r\n Changed;\r\n end;\r\nend;\r\n\r\nprocedure TJvArrangeSettings.SetMaxControlsPerLine(const Value: Integer);\r\nbegin\r\n if Value <> FMaxControlsPerLine then\r\n begin\r\n Changing;\r\n ChangingProperty('MaxControlsPerLine');\r\n FMaxControlsPerLine := Value;\r\n ChangedProperty('MaxControlsPerLine');\r\n Changed;\r\n end;\r\nend;\r\n\r\nprocedure TJvArrangeSettings.SetDistanceVertical(Value: Integer);\r\nbegin\r\n if Value <> FDistanceVertical then\r\n begin\r\n Changing;\r\n ChangingProperty('DistanceVertical');\r\n FDistanceVertical := Value;\r\n ChangedProperty('DistanceVertical');\r\n Changed;\r\n end;\r\nend;\r\n\r\nprocedure TJvArrangeSettings.SetHorizontalAlignment(const Value: TJvArrangeSettingsHAlignment);\r\nbegin\r\n if Value <> FHorizontalAlignment then\r\n begin\r\n Changing;\r\n ChangingProperty('HorizontalAlignment');\r\n FHorizontalAlignment := Value;\r\n ChangedProperty('HorizontalAlignment');\r\n Changed;\r\n end;\r\nend;\r\n\r\nprocedure TJvArrangeSettings.SetDistanceHorizontal(Value: Integer);\r\nbegin\r\n if Value <> FDistanceHorizontal then\r\n begin\r\n Changing;\r\n ChangingProperty('DistanceHorizontal');\r\n FDistanceHorizontal := Value;\r\n ChangedProperty('DistanceHorizontal');\r\n Changed;\r\n end;\r\nend;\r\n\r\nprocedure TJvArrangeSettings.SetMaxWidth(Value: Integer);\r\nbegin\r\n if Value <> FMaxWidth then\r\n begin\r\n Changing;\r\n ChangingProperty('MaxWidth');\r\n FMaxWidth := Value;\r\n ChangedProperty('MaxWidth');\r\n Changed;\r\n end;\r\nend;\r\n\r\nprocedure TJvArrangeSettings.SetHorizontalAlignLines(const Value: Boolean);\r\nbegin\r\n if Value <> FHorizontalAlignLines then\r\n begin\r\n Changing;\r\n ChangingProperty('HorizontalAlignLines');\r\n FHorizontalAlignLines := Value;\r\n ChangedProperty('HorizontalAlignLines');\r\n Changed;\r\n end;\r\nend;\r\n\r\nprocedure TJvArrangeSettings.SetVerticalAlignment(const Value: TJvArrangeSettingsVAlignment);\r\nbegin\r\n if Value <> FVerticalAlignment then\r\n begin\r\n Changing;\r\n ChangingProperty('VerticalAlignment');\r\n FVerticalAlignment := Value;\r\n ChangedProperty('VerticalAlignment');\r\n Changed;\r\n end;\r\nend;\r\n\r\nprocedure TJvArrangeSettings.Assign(Source: TPersistent);\r\nvar\r\n A: TJvArrangeSettings;\r\nbegin\r\n if Source is TJvArrangeSettings then\r\n begin\r\n BeginUpdate;\r\n try\r\n A := TJvArrangeSettings(Source);\r\n AutoArrange := A.AutoArrange;\r\n AutoSize := A.AutoSize;\r\n WrapControls := A.WrapControls;\r\n BorderLeft := A.BorderLeft;\r\n BorderTop := A.BorderTop;\r\n DistanceVertical := A.DistanceVertical;\r\n DistanceHorizontal := A.DistanceHorizontal;\r\n ShowNotVisibleAtDesignTime := A.ShowNotVisibleAtDesignTime;\r\n MaxWidth := A.MaxWidth;\r\n MaxControlsPerLine := A.MaxControlsPerLine;\r\n VerticalAlignment := A.VerticalAlignment;\r\n HorizontalAlignment := A.HorizontalAlignment;\r\n HorizontalAlignLines := A.HorizontalAlignLines;\r\n finally\r\n EndUpdate;\r\n end;\r\n end\r\n else\r\n inherited Assign(Source);\r\nend;\r\n\r\n//=== { TJvPanelHotTrackOptions } ============================================\r\n\r\nconstructor TJvPanelHotTrackOptions.Create(AOwner: TPersistent);\r\nbegin\r\n inherited;\r\n Color := clBtnFace;\r\nend;\r\n\r\n//=== { TJvCustomArrangePanel } ==============================================\r\n\r\nconstructor TJvCustomArrangePanel.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n IncludeThemeStyle(Self, [csNeedsBorderPaint, csParentBackground]);\r\n FMultiLine := False;\r\n FTransparent := False;\r\n FFlatBorder := False;\r\n FFlatBorderColor := clBtnShadow;\r\n FHotTrack := False;\r\n FHotTrackFont := TFont.Create;\r\n FHotTrackFontOptions := DefaultTrackFontOptions;\r\n FHotTrackOptions := TJvPanelHotTrackOptions.Create(Self);\r\n FArrangeSettings := TJvArrangeSettings.Create(Self); // \"Self\" is a must, otherwise the ObjectInspector has problems\r\n FArrangeSettings.OnChangedProperty := DoArrangeSettingsPropertyChanged;\r\nend;\r\n\r\ndestructor TJvCustomArrangePanel.Destroy;\r\nbegin\r\n inherited Destroy;\r\n FreeAndNil(FHotTrackFont);\r\nend;\r\n\r\nprocedure TJvCustomArrangePanel.CreateParams(var Params: TCreateParams);\r\nbegin\r\n inherited CreateParams(Params);\r\n if Transparent then\r\n begin\r\n Params.ExStyle := Params.ExStyle or WS_EX_TRANSPARENT;\r\n ControlStyle := ControlStyle - [csOpaque];\r\n end\r\n else\r\n begin\r\n Params.ExStyle := Params.ExStyle and not WS_EX_TRANSPARENT;\r\n ControlStyle := ControlStyle + [csOpaque];\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomArrangePanel.WMNCHitTest(var Msg: TWMNCHitTest);\r\nvar\r\n P: TPoint;\r\nbegin\r\n inherited;\r\n if not (csDesigning in ComponentState) and Movable then\r\n begin\r\n P := ScreenToClient(SmallPointToPoint(Msg.Pos));\r\n if (P.X > 5) and (P.Y > 5) and (P.X < Width - 5) and (P.Y < Height - 5) and DoBeforeMove(P.X,P.Y) then\r\n begin\r\n Msg.Result := HTCAPTION;\r\n FWasMoved := True;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomArrangePanel.WMExitSizeMove(var Msg: TMessage);\r\nbegin\r\n inherited;\r\n if not (csDesigning in ComponentState) then\r\n begin\r\n if FWasMoved then\r\n DoAfterMove;\r\n FWasMoved := False;\r\n end;\r\nend;\r\n\r\nfunction TJvCustomArrangePanel.DoBeforeMove(X,Y: Integer): Boolean;\r\nbegin\r\n Result := True;\r\n if Assigned(FOnBeforeMove) then\r\n FOnBeforeMove(Self, X, Y, Result);\r\nend;\r\n\r\nprocedure TJvCustomArrangePanel.DoAfterMove;\r\nbegin\r\n if Assigned(FOnAfterMove) then\r\n FOnAfterMove(Self);\r\nend;\r\n\r\nprocedure TJvCustomArrangePanel.Paint;\r\nvar\r\n X, Y: Integer;\r\n R: TRect;\r\n OldPenColor:TColor;\r\n OldPenWidth: Integer;\r\n ControlIndex: Integer;\r\n CurControl: TControl;\r\nbegin\r\n if Assigned(FOnPaint) then\r\n begin\r\n FOnPaint(Self);\r\n Exit;\r\n end;\r\n\r\n // must force child controls to redraw completely, even their non client areas (Mantis 4406)\r\n if Transparent and not FPainting and not FRedrawingChildren then\r\n begin\r\n FRedrawingChildren := True;\r\n try\r\n for ControlIndex := 0 to ControlCount - 1 do\r\n begin\r\n CurControl := Controls[ControlIndex];\r\n CurControl.Invalidate;\r\n if CurControl is TWinControl then\r\n RedrawWindow(TWinControl(CurControl).Handle, nil, 0, RDW_FRAME or RDW_INVALIDATE);\r\n\r\n // Must update here so that the invalidate message is processed immediately\r\n // If not, there is a very strong risk of creating a refresh loop\r\n CurControl.Update;\r\n end;\r\n finally\r\n FRedrawingChildren := False;\r\n end;\r\n end;\r\n\r\n FPainting := True;\r\n try\r\n if MouseOver and HotTrack then\r\n begin\r\n Canvas.Font := Self.HotTrackFont;\r\n if HotTrackOptions.Enabled then\r\n begin\r\n Canvas.Brush.Color := HotTrackOptions.Color;\r\n if HotTrackOptions.FrameVisible then\r\n begin\r\n Canvas.Brush.Style := bsSolid;\r\n OldPenColor := Canvas.Pen.Color;\r\n Canvas.Pen.Color := HotTrackOptions.FrameColor;\r\n Canvas.Rectangle(0, 0, Width, Height);\r\n Canvas.Pen.Color := OldPenColor;\r\n end\r\n else\r\n begin\r\n R := ClientRect;\r\n InflateRect(R, -BevelWidth, -BevelWidth);\r\n Canvas.FillRect(R);\r\n end;\r\n end;\r\n end\r\n else\r\n begin\r\n Canvas.Font := Self.Font;\r\n Canvas.Brush.Color := Color;\r\n if not Transparent then\r\n DrawThemedBackground(Self, Canvas, ClientRect)\r\n else\r\n Canvas.Brush.Style := bsClear;\r\n if FFlatBorder then\r\n begin\r\n if BorderWidth > 0 then\r\n begin\r\n OldPenWidth:= Canvas.Pen.Width;\r\n OldPenColor := Canvas.Pen.Color;\r\n Canvas.Pen.Width := BorderWidth;\r\n Canvas.Pen.Color := FFlatBorderColor;\r\n Canvas.Brush.Style := bsClear;\r\n\r\n R := ClientRect;\r\n X := (BorderWidth div 2);\r\n if Odd(BorderWidth) then\r\n Y := X\r\n else\r\n Y := X -1;\r\n\r\n Inc(R.Left,X);\r\n Inc(R.Top,X);\r\n Dec(R.Bottom,Y);\r\n Dec(R.Right,Y);\r\n\r\n Canvas.Rectangle(R);\r\n\r\n Canvas.Pen.Width := OldPenWidth;\r\n Canvas.Pen.Color := OldPenColor;\r\n end;\r\n end\r\n else\r\n DrawBorders;\r\n end;\r\n\r\n DrawCaption;\r\n if Sizeable then\r\n begin\r\n {$IFDEF JVCLThemesEnabled}\r\n if {$IFDEF RTL230_UP}StyleServices{$ELSE}ThemeServices{$ENDIF RTL230_UP}.{$IFDEF RTL230_UP}Enabled{$ELSE}ThemesEnabled{$ENDIF RTL230_UP} then\r\n {$IFDEF RTL230_UP}StyleServices{$ELSE}ThemeServices{$ENDIF RTL230_UP}.DrawElement(Canvas.Handle, {$IFDEF RTL230_UP}StyleServices{$ELSE}ThemeServices{$ENDIF RTL230_UP}.GetElementDetails(tsGripper),\r\n Rect(ClientWidth - GetSystemMetrics(SM_CXVSCROLL) - BevelWidth - 2,\r\n ClientHeight - GetSystemMetrics(SM_CYHSCROLL) - BevelWidth - 2,\r\n ClientWidth - BevelWidth - 2, ClientHeight - BevelWidth - 2))\r\n else\r\n {$ENDIF JVCLThemesEnabled}\r\n begin\r\n Canvas.Font.Name := 'Marlett';\r\n Canvas.Font.Charset := DEFAULT_CHARSET;\r\n Canvas.Font.Size := 12;\r\n Canvas.Font.Style := [];\r\n Canvas.Brush.Style := bsClear;\r\n X := ClientWidth - GetSystemMetrics(SM_CXVSCROLL) - BevelWidth - 2;\r\n Y := ClientHeight - GetSystemMetrics(SM_CYHSCROLL) - BevelWidth - 2;\r\n // (rom) bsClear takes care of that already\r\n //if Transparent then\r\n // SetBkMode(Handle, BkModeTransparent);\r\n Canvas.Font.Color := clBtnHighlight;\r\n Canvas.TextOut(X, Y, 'o');\r\n Canvas.Font.Color := clBtnShadow;\r\n Canvas.TextOut(X, Y, 'p');\r\n end;\r\n end;\r\n finally\r\n FPainting := False;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomArrangePanel.DrawBorders;\r\nvar\r\n Rect: TRect;\r\n TopColor, BottomColor: TColor;\r\n\r\n procedure AdjustColors(Bevel: TPanelBevel);\r\n begin\r\n TopColor := clBtnHighlight;\r\n if Bevel = bvLowered then\r\n TopColor := clBtnShadow;\r\n BottomColor := clBtnShadow;\r\n if Bevel = bvLowered then\r\n BottomColor := clBtnHighlight;\r\n end;\r\n\r\nbegin\r\n Rect := ClientRect;\r\n if BevelOuter <> bvNone then\r\n begin\r\n AdjustColors(BevelOuter);\r\n Frame3D(Canvas, Rect, TopColor, BottomColor, BevelWidth);\r\n end;\r\n Frame3D(Canvas, Rect, Color, Color, BorderWidth);\r\n if BevelInner <> bvNone then\r\n begin\r\n AdjustColors(BevelInner);\r\n Frame3D(Canvas, Rect, TopColor, BottomColor, BevelWidth);\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomArrangePanel.DrawCaption;\r\nbegin\r\n DrawCaptionTo(Self.Canvas);\r\nend;\r\n\r\nprocedure TJvCustomArrangePanel.DrawCaptionTo(ACanvas: TCanvas );\r\nconst\r\n Alignments: array [TAlignment] of Longint = (DT_LEFT, DT_RIGHT, DT_CENTER);\r\n WordWrap: array [Boolean] of Longint = (DT_SINGLELINE, DT_WORDBREAK);\r\nvar\r\n ATextRect: TRect;\r\n BevelSize: Integer;\r\n Flags: Longint;\r\nbegin\r\n with ACanvas do\r\n begin\r\n if Caption <> '' then\r\n begin\r\n if (MouseOver or FDragging) and HotTrack then\r\n ACanvas.Font := Self.HotTrackFont\r\n else\r\n ACanvas.Font := Self.Font;\r\n\r\n SetBkMode(Handle, BkModeTransparent);\r\n Font := Self.Font;\r\n ATextRect := GetClientRect;\r\n InflateRect(ATextRect, -BorderWidth, -BorderWidth);\r\n BevelSize := 0;\r\n if BevelOuter <> bvNone then\r\n Inc(BevelSize, BevelWidth);\r\n if BevelInner <> bvNone then\r\n Inc(BevelSize, BevelWidth);\r\n InflateRect(ATextRect, -BevelSize, -BevelSize);\r\n Flags := DT_EXPANDTABS or WordWrap[MultiLine] or Alignments[Alignment];\r\n Flags := DrawTextBiDiModeFlags(Flags);\r\n //calculate required rectangle size\r\n DrawText(ACanvas.Handle, Caption, -1, ATextRect, Flags or DT_CALCRECT);\r\n // adjust the rectangle placement\r\n OffsetRect(ATextRect, 0, -ATextRect.Top + (Height - (ATextRect.Bottom - ATextRect.Top)) div 2);\r\n case Alignment of\r\n taRightJustify:\r\n OffsetRect(ATextRect, -ATextRect.Left + (Width - (ATextRect.Right - ATextRect.Left) - BorderWidth -\r\n BevelSize), 0);\r\n taCenter:\r\n OffsetRect(ATextRect, -ATextRect.Left + (Width - (ATextRect.Right - ATextRect.Left)) div 2, 0);\r\n end;\r\n if not Enabled then\r\n Font.Color := clGrayText;\r\n //draw text\r\n if Transparent then\r\n SetBkMode(ACanvas.Handle, BkModeTransparent);\r\n DrawText(ACanvas.Handle, Caption, -1, ATextRect, Flags);\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomArrangePanel.ParentColorChanged;\r\nbegin\r\n Invalidate;\r\n inherited ParentColorChanged;\r\nend;\r\n\r\nprocedure TJvCustomArrangePanel.MouseEnter(Control: TControl);\r\nvar\r\n NeedRepaint: Boolean;\r\n OtherDragging:Boolean;\r\nbegin\r\n if csDesigning in ComponentState then\r\n Exit;\r\n\r\n if not MouseOver and Enabled and (Control = nil) then\r\n begin\r\n OtherDragging := Mouse.IsDragging;\r\n NeedRepaint := not Transparent and\r\n ((FHotTrack and Enabled and not FDragging and not OtherDragging));\r\n inherited MouseEnter(Control); // set MouseOver\r\n if NeedRepaint then\r\n Repaint;\r\n end\r\n else\r\n inherited MouseEnter(Control);\r\nend;\r\n\r\nprocedure TJvCustomArrangePanel.MouseLeave(Control: TControl);\r\nvar\r\n NeedRepaint: Boolean;\r\n OtherDragging:Boolean;\r\nbegin\r\n if csDesigning in ComponentState then\r\n Exit;\r\n OtherDragging := Mouse.IsDragging;\r\n if MouseOver and Enabled and (Control = nil) then\r\n begin\r\n NeedRepaint := not Transparent and\r\n ((FHotTrack and (FDragging or (Enabled and not OtherDragging))));\r\n inherited MouseLeave(Control); // set MouseOver\r\n\r\n if Sizeable then\r\n RestoreSizeableCursor;;\r\n\r\n if NeedRepaint then\r\n Repaint;\r\n end\r\n else\r\n inherited MouseLeave(Control);\r\nend;\r\n\r\nprocedure TJvCustomArrangePanel.SetSizeableCursor;\r\nbegin\r\n if Screen.Cursor <> crSizeNWSE then\r\n begin\r\n FLastScreenCursor := Screen.Cursor;\r\n Screen.Cursor := crSizeNWSE;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomArrangePanel.RestoreSizeableCursor;\r\nbegin\r\n if Screen.Cursor = crSizeNWSE then\r\n Screen.Cursor := FLastScreenCursor;\r\nend;\r\n\r\nprocedure TJvCustomArrangePanel.SetTransparent(const Value: Boolean);\r\nbegin\r\n if Value <> FTransparent then\r\n begin\r\n FTransparent := Value;\r\n RecreateWnd;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomArrangePanel.SetFlatBorder(const Value: Boolean);\r\nbegin\r\n if Value <> FFlatBorder then\r\n begin\r\n FFlatBorder := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomArrangePanel.SetFlatBorderColor(const Value: TColor);\r\nbegin\r\n if Value <> FFlatBorderColor then\r\n begin\r\n FFlatBorderColor := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nfunction TJvCustomArrangePanel.DoEraseBackground(Canvas: TCanvas; Param: LPARAM): Boolean;\r\nbegin\r\n // Mantis 3624: Draw our parent's image first if we are transparent.\r\n // This might not seem useful at first as we have removed the csOpaque\r\n // from our style and the API is doing the drawing just fine. But this\r\n // is required for other transparent controls placed on us. This way,\r\n // they call us with their own canvas into which we draw what we are\r\n // placed on. This way, there is an automatic chain of transparency up\r\n // to the controls at the bottom that are not transparent.\r\n if Transparent then\r\n begin\r\n CopyParentImage(Self, Canvas);\r\n Result := True;\r\n end\r\n else\r\n Result := inherited DoEraseBackground(Canvas, Param);\r\nend;\r\n\r\nprocedure TJvCustomArrangePanel.SetMultiLine(const Value: Boolean);\r\nbegin\r\n if FMultiLine <> Value then\r\n begin\r\n FMultiLine := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomArrangePanel.TextChanged;\r\nbegin\r\n inherited TextChanged;\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvCustomArrangePanel.SetSizeable(const Value: Boolean);\r\nbegin\r\n if FSizeable <> Value then\r\n begin\r\n FSizeable := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomArrangePanel.MouseDown(Button: TMouseButton; Shift: TShiftState;\r\n X, Y: Integer);\r\nbegin\r\n if Sizeable and (Button = mbLeft) and ((Width - X) < 12) and ((Height - Y) < 12) then\r\n begin\r\n FDragging := True;\r\n FLastPos := Point(X, Y);\r\n MouseCapture := True;\r\n SetSizeableCursor;\r\n end\r\n else\r\n inherited MouseDown(Button, Shift, X, Y);\r\nend;\r\n\r\nprocedure TJvCustomArrangePanel.MouseMove(Shift: TShiftState; X, Y: Integer);\r\nvar\r\n R: TRect;\r\n X1, Y1: Integer;\r\n Changed : Boolean;\r\nbegin\r\n if FDragging and Sizeable then\r\n begin\r\n R := BoundsRect;\r\n X1 := R.Right - R.Left + X - FLastPos.X;\r\n Y1 := R.Bottom - R.Top + Y - FLastPos.Y;\r\n if (X1 > 1) and (Y1 > 1) then\r\n begin\r\n if (Constraints.MinWidth > 0) and (X1 < Constraints.MinWidth) then\r\n X1 := Constraints.MinWidth;\r\n if (Constraints.MinHeight > 0) and (Y1 < Constraints.MinHeight) then\r\n Y1 := Constraints.MinHeight;\r\n if (Constraints.MaxWidth > 0) and (X1 > Constraints.MaxWidth) then\r\n X1 := Constraints.MaxWidth;\r\n if (Constraints.MaxHeight > 0) and (Y1 > Constraints.MaxHeight) then\r\n Y1 := Constraints.MaxHeight;\r\n Changed := False;\r\n if (X1 >= 0) and (X1 <> Width) then\r\n begin\r\n FLastPos.X := X;\r\n Changed:= True;\r\n end;\r\n if (Y1 >= 0) and (Y1 <> Height) then\r\n begin\r\n FLastPos.Y := Y;\r\n Changed := True;\r\n end;\r\n if Changed then\r\n begin\r\n SetBounds(Left, Top, X1, Y1);\r\n Refresh;\r\n end;\r\n end;\r\n end\r\n else\r\n inherited MouseMove(Shift, X, Y);\r\n if Sizeable then\r\n begin\r\n if ((Width - X) < 12) and ((Height - Y) < 12) then\r\n SetSizeableCursor\r\n else\r\n RestoreSizeableCursor;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomArrangePanel.MouseUp(Button: TMouseButton; Shift: TShiftState;\r\n X, Y: Integer);\r\nbegin\r\n if FDragging and Sizeable then\r\n begin\r\n FDragging := False;\r\n MouseCapture := False;\r\n RestoreSizeableCursor;\r\n Refresh;\r\n end\r\n else\r\n inherited MouseUp(Button, Shift, X, Y);\r\nend;\r\n\r\nprocedure TJvCustomArrangePanel.SetBounds(ALeft, ATop, AWidth, AHeight: Integer);\r\nbegin\r\n inherited SetBounds(ALeft, ATop, AWidth, AHeight);\r\n if Transparent then\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvCustomArrangePanel.Resize;\r\nbegin\r\n if Assigned(FArrangeSettings) then // (asn)\r\n if FArrangeSettings.AutoArrange then\r\n ArrangeControls;\r\n inherited Resize;\r\nend;\r\n\r\nprocedure TJvCustomArrangePanel.EnableArrange;\r\nbegin\r\n EnableAlign;\r\n if FEnableArrangeCount > 0 then\r\n Dec(FEnableArrangeCount);\r\nend;\r\n\r\nprocedure TJvCustomArrangePanel.DisableArrange;\r\nbegin\r\n Inc(FEnableArrangeCount);\r\n DisableAlign;\r\nend;\r\n\r\nfunction TJvCustomArrangePanel.ArrangeEnabled: Boolean;\r\nbegin\r\n Result := FEnableArrangeCount <= 0;\r\nend;\r\n\r\nprocedure TJvCustomArrangePanel.Loaded;\r\nbegin\r\n inherited Loaded;\r\n if FArrangeSettings.AutoArrange then\r\n ArrangeControls;\r\nend;\r\n\r\nprocedure TJvCustomArrangePanel.AlignControls(AControl: TControl; var Rect: TRect);\r\nbegin\r\n inherited AlignControls(AControl, Rect);\r\n if FArrangeSettings.AutoArrange then\r\n ArrangeControls;\r\nend;\r\n\r\nfunction TJvCustomArrangePanel.GetNextControlByTabOrder(ATabOrder: Integer): TWinControl;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := nil;\r\n for I := 0 to ControlCount - 1 do\r\n if Controls[I] is TWinControl then\r\n if TWinControl(Controls[I]).TabOrder = ATabOrder then\r\n begin\r\n Result := TWinControl(Controls[I]);\r\n Break;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomArrangePanel.ArrangeControls;\r\ntype\r\n TControlRect = record\r\n Control: TControl;\r\n BoundsRect: TRect;\r\n LineBreak: Boolean;\r\n end;\r\nvar\r\n AktX, AktY, NewX, NewY, MaxY, NewMaxX: Integer;\r\n ControlMaxX, ControlMaxY: Integer;\r\n TmpWidth, TmpHeight: Integer;\r\n LastTabOrder: Integer;\r\n CurrControl: TWinControl;\r\n I: Integer;\r\n OldHeight, OldWidth: Integer;\r\n OffsetX, OffsetY: Integer;\r\n NumControlsPerLine: Integer;\r\n ControlRects: array of TControlRect;\r\n LineOffsets: array of Integer;\r\n LineCount, Len: Integer;\r\n ArrS: TJvArrangeSettings;\r\nbegin\r\n if not ArrangeEnabled or FArrangeControlActive or (ControlCount = 0) or\r\n ([csLoading, csReading] * ComponentState <> []) then\r\n Exit;\r\n FArrangeWidth := 0;\r\n FArrangeHeight := 0;\r\n FArrangeControlActive := True;\r\n ArrS := FArrangeSettings;\r\n try\r\n OldHeight := Height;\r\n OldWidth := Width;\r\n TmpHeight := Height;\r\n TmpWidth := Width;\r\n AktY := ArrS.BorderTop;\r\n AktX := ArrS.BorderLeft;\r\n LastTabOrder := -1;\r\n MaxY := -1;\r\n if (ArrS.AutoSize in [asWidth, asBoth]) then\r\n ControlMaxX := TmpWidth - 2 * ArrS.BorderLeft\r\n else\r\n ControlMaxX := -1;\r\n if (ArrS.AutoSize in [asHeight, asBoth]) then\r\n ControlMaxY := TmpHeight - 2 * ArrS.BorderTop\r\n else\r\n ControlMaxY := -1;\r\n\r\n SetLength(ControlRects, ControlCount);\r\n for I := 0 to ControlCount - 1 do\r\n if Controls[I] is TWinControl then\r\n begin\r\n if Controls[I] is TJvCustomArrangePanel then\r\n TJvCustomArrangePanel(Controls[I]).Rearrange;\r\n if (Controls[I].Width + 2 * ArrS.BorderLeft > TmpWidth) then\r\n TmpWidth := Controls[I].Width + 2 * ArrS.BorderLeft;\r\n end;\r\n\r\n if (TmpWidth > ArrS.MaxWidth) and (ArrS.MaxWidth > 0) then\r\n TmpWidth := ArrS.MaxWidth;\r\n CurrControl := GetNextControlByTabOrder(LastTabOrder + 1);\r\n I := 0;\r\n NumControlsPerLine := 0;\r\n LineCount := 0;\r\n while Assigned(CurrControl) do\r\n begin\r\n LastTabOrder := CurrControl.TabOrder;\r\n ControlRects[I].Control := nil;\r\n ControlRects[I].LineBreak := False;\r\n if CurrControl.Visible or\r\n ((csDesigning in ComponentState) and ArrS.ShowNotVisibleAtDesignTime) then\r\n begin\r\n NewMaxX := AktX + CurrControl.Width + ArrS.DistanceHorizontal + ArrS.BorderLeft;\r\n if ((ArrS.MaxControlsPerLine > 0) and (NumControlsPerLine >= ArrS.MaxControlsPerLine)) or\r\n ((((NewMaxX > TmpWidth) and not (ArrS.AutoSize in [asWidth, asBoth])) or\r\n ((NewMaxX > ArrS.MaxWidth) and (ArrS.MaxWidth > 0))) and\r\n (AktX > ArrS.BorderLeft) and // Only Valid if there is one control in the current line\r\n ArrS.WrapControls) then\r\n begin\r\n AktX := ArrS.BorderLeft;\r\n AktY := AktY + MaxY + ArrS.DistanceVertical;\r\n MaxY := -1;\r\n NewX := AktX;\r\n NewY := AktY;\r\n NumControlsPerLine := 1;\r\n ControlRects[I].LineBreak := True;\r\n Inc(LineCount);\r\n end\r\n else\r\n begin\r\n NewX := AktX;\r\n NewY := AktY;\r\n Inc(NumControlsPerLine);\r\n end;\r\n AktX := AktX + CurrControl.Width;\r\n if AktX > ControlMaxX then\r\n ControlMaxX := AktX;\r\n AktX := AktX + ArrS.DistanceHorizontal;\r\n ControlRects[I].Control := CurrControl;\r\n ControlRects[I].BoundsRect := Rect(NewX, NewY, NewX + CurrControl.Width, NewY + CurrControl.Height);\r\n if CurrControl.Height > MaxY then\r\n MaxY := CurrControl.Height;\r\n ControlMaxY := AktY + MaxY;\r\n end;\r\n CurrControl := GetNextControlByTabOrder(LastTabOrder + 1);\r\n Inc(I);\r\n end;\r\n if (Length(ControlRects) > 0) and not ControlRects[High(ControlRects)].LineBreak then\r\n Inc(LineCount);\r\n\r\n { Vertical/Horizontal alignment }\r\n OffsetX := 0;\r\n OffsetY := 0;\r\n if not (ArrS.AutoSize in [asBoth, asHeight]) then\r\n case ArrS.VerticalAlignment of\r\n asVCenter:\r\n OffsetY := (ClientHeight - ControlMaxY) div 2;\r\n asBottom:\r\n OffsetY := ClientHeight - ControlMaxY;\r\n end;\r\n if not (ArrS.AutoSize in [asBoth, asWidth]) then\r\n case ArrS.HorizontalAlignment of\r\n asCenter:\r\n OffsetX := (ClientWidth - ControlMaxX) div 2;\r\n asRight:\r\n OffsetX := ClientWidth - ControlMaxX;\r\n end;\r\n\r\n { Calculate the horizontal line alignment }\r\n if Arrs.HorizontalAlignLines then\r\n begin\r\n SetLength(LineOffsets, LineCount);\r\n Len := Length(ControlRects);\r\n I := 0;\r\n LineCount := 0;\r\n while I < Len do\r\n begin\r\n { Skip unused slots }\r\n while (I < Len) and (ControlRects[I].Control = nil) do\r\n Inc(I);\r\n if I < Len then\r\n begin\r\n LineOffsets[LineCount] := ControlRects[I].BoundsRect.Left;\r\n { Find last control in the line }\r\n while (I + 1 < Len) and not ControlRects[I + 1].LineBreak do\r\n Inc(I);\r\n LineOffsets[LineCount] := (ControlMaxX - (ControlRects[I].BoundsRect.Right - LineOffsets[LineCount])) div 2;\r\n Inc(LineCount);\r\n end;\r\n Inc(I);\r\n end;\r\n end;\r\n\r\n { Apply the new BoundRects to the controls }\r\n LineCount := 0;\r\n for I := 0 to High(ControlRects) do\r\n begin\r\n if ControlRects[I].Control <> nil then\r\n begin\r\n OffsetRect(ControlRects[I].BoundsRect, OffsetX, OffsetY);\r\n if ArrS.HorizontalAlignLines then\r\n begin\r\n if ControlRects[I].LineBreak then\r\n Inc(LineCount);\r\n OffsetRect(ControlRects[I].BoundsRect, LineOffsets[LineCount], 0);\r\n end;\r\n ControlRects[I].Control.BoundsRect := ControlRects[I].BoundsRect;\r\n end;\r\n end;\r\n\r\n { Adjust panel bounds }\r\n if not (csLoading in ComponentState) then\r\n begin\r\n if ArrS.AutoSize in [asWidth, asBoth] then\r\n if ControlMaxX >= 0 then\r\n if (ArrS.MaxWidth > 0) and (ControlMaxX >= ArrS.MaxWidth) then\r\n TmpWidth := ArrS.MaxWidth\r\n else\r\n TmpWidth := ControlMaxX + ArrS.BorderLeft\r\n else\r\n TmpWidth := 0;\r\n if ArrS.AutoSize in [asHeight, asBoth] then\r\n if ControlMaxY >= 0 then\r\n TmpHeight := ControlMaxY + ArrS.BorderTop\r\n else\r\n TmpHeight := 0;\r\n Width := TmpWidth;\r\n Height := TmpHeight;\r\n end;\r\n FArrangeWidth := ControlMaxX + 2 * ArrS.BorderLeft;\r\n FArrangeHeight := ControlMaxY + 2 * ArrS.BorderTop;\r\n if (OldWidth <> TmpWidth) or (OldHeight <> Height) then\r\n UpdateWindow(GetFocus); //SendMessage(GetFocus, WM_PAINT, 0, 0);\r\n finally\r\n FArrangeControlActive := False;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomArrangePanel.SetWidth(Value: Integer);\r\nvar\r\n Changed: Boolean;\r\nbegin\r\n Changed := inherited Width <> Value;\r\n inherited Width := Value;\r\n if Changed then\r\n begin\r\n if Assigned(FOnChangedWidth) then\r\n FOnChangedWidth (Self, Value);\r\n if Assigned(FOnResizeParent) then\r\n FOnResizeParent(Self, Left, Top, Value, Height)\r\n else\r\n if Parent is TJvCustomArrangePanel then\r\n TJvCustomArrangePanel(Parent).Rearrange;\r\n end;\r\nend;\r\n\r\nfunction TJvCustomArrangePanel.GetWidth: Integer;\r\nbegin\r\n Result := inherited Width;\r\nend;\r\n\r\nprocedure TJvCustomArrangePanel.SetHeight(Value: Integer);\r\nvar\r\n Changed: Boolean;\r\nbegin\r\n Changed := inherited Height <> Value;\r\n inherited Height := Value;\r\n if Changed then\r\n begin\r\n if Assigned(FOnChangedHeight) then\r\n FOnChangedHeight (Self, Value);\r\n if Assigned(FOnResizeParent) then\r\n FOnResizeParent(Self, Left, Top, Width, Value)\r\n else\r\n if Parent is TJvCustomArrangePanel then\r\n TJvCustomArrangePanel(Parent).Rearrange;\r\n end;\r\nend;\r\n\r\nfunction TJvCustomArrangePanel.GetHeight: Integer;\r\nbegin\r\n Result := inherited Height;\r\nend;\r\n\r\nprocedure TJvCustomArrangePanel.SetArrangeSettings(const Value:\r\n TJvArrangeSettings);\r\nbegin\r\n if (Value <> nil) and (Value <> FArrangeSettings) then\r\n FArrangeSettings.Assign(Value);\r\nend;\r\n\r\nfunction TJvCustomArrangePanel.GetHotTrack: Boolean;\r\nbegin\r\n Result := FHotTrack;\r\nend;\r\n\r\nfunction TJvCustomArrangePanel.GetHotTrackFont: TFont;\r\nbegin\r\n Result := FHotTrackFont;\r\nend;\r\n\r\nfunction TJvCustomArrangePanel.GetHotTrackFontOptions: TJvTrackFontOptions;\r\nbegin\r\n Result := FHotTrackFontOptions;\r\nend;\r\n\r\nfunction TJvCustomArrangePanel.GetHotTrackOptions: TJvHotTrackOptions;\r\nbegin\r\n Result := FHotTrackOptions;\r\nend;\r\n\r\nprocedure TJvCustomArrangePanel.SetHotTrack(Value: Boolean);\r\nbegin\r\n FHotTrack := Value;\r\nend;\r\n\r\nprocedure TJvCustomArrangePanel.SetHotTrackFont(Value: TFont);\r\nbegin\r\n if (FHotTrackFont<>Value) and (Value <> nil) then\r\n FHotTrackFont.Assign(Value);\r\nend;\r\n\r\nprocedure TJvCustomArrangePanel.SetHotTrackFontOptions(Value: TJvTrackFontOptions);\r\nbegin\r\n if FHotTrackFontOptions <> Value then\r\n begin\r\n FHotTrackFontOptions := Value;\r\n UpdateTrackFont(HotTrackFont, Font, FHotTrackFontOptions);\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomArrangePanel.SetHotTrackOptions(Value: TJvHotTrackOptions);\r\nbegin\r\n if (FHotTrackOptions <> Value) and (Value <> nil) then\r\n FHotTrackOptions.Assign(Value);\r\nend;\r\n\r\nprocedure TJvCustomArrangePanel.IJvHotTrack_Assign(\r\n Source: IJvHotTrack);\r\nbegin\r\n if (Source <> nil) and (IJvHotTrack(Self) <> Source) then\r\n begin\r\n HotTrack := Source.HotTrack;\r\n HotTrackFont :=Source.HotTrackFont;\r\n HotTrackFontOptions := Source.HotTrackFontOptions;\r\n HotTrackOptions := Source.HotTrackOptions;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomArrangePanel.Rearrange;\r\nbegin\r\n if FArrangeSettings.AutoArrange and not (csLoading in ComponentState) then\r\n ArrangeControls;\r\nend;\r\n\r\nprocedure TJvCustomArrangePanel.DoArrangeSettingsPropertyChanged(Sender: TObject;\r\n const PropName: string);\r\nbegin\r\n if SameText(PropName, 'AutoArrange') then\r\n begin\r\n if ArrangeSettings.AutoArrange then\r\n Rearrange;\r\n end\r\n else\r\n if SameText(PropName, 'AutoSize') then\r\n begin\r\n if ArrangeSettings.AutoSize <> asNone then\r\n Rearrange;\r\n end\r\n else //otherwise call Rearrange\r\n Rearrange;\r\nend;\r\n\r\nfunction TJvCustomArrangePanel.GetArrangeSettings: TJvArrangeSettings;\r\nbegin\r\n Result := fArrangeSettings;\r\nend;\r\n\r\n{ TJvPanel }\r\n\r\nprocedure TJvPanel.DefineProperties(Filer: TFiler);\r\nbegin\r\n inherited DefineProperties(Filer);\r\n { For backward compatibility }\r\n FFilerTag := 'HotColor';\r\n Filer.DefineProperty(FFilerTag, ReadData, nil, False);\r\nend;\r\n\r\nprocedure TJvPanel.ReadData(Reader: TReader);\r\nvar\r\n C: Integer;\r\nbegin\r\n if SameText(FFilerTag, 'HotColor') then\r\n begin\r\n if Reader.NextValue = vaIdent then\r\n begin\r\n if IdentToColor(Reader.ReadIdent, C) then\r\n HotTrackOptions.Color := C;\r\n end\r\n else\r\n HotTrackOptions.Color := Reader.ReadInteger;\r\n end;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n\r\n" }, { "path": "External/Jedi/Jvcl/run/JvParameterList.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Initial Developer of the Original Code is Jens Fudickar [jens dott fudickar att oratool dott de]\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\nJens Fudickar [jens dott fudickar att oratool dott de]\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvParameterList.pas 13415 2012-09-10 09:51:54Z obones $\r\n\r\nunit JvParameterList;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Classes, SysUtils, Windows, Messages,\r\n StdCtrls, ExtCtrls, Graphics, Forms, Controls, Dialogs,\r\n Variants,\r\n JvConsts, JvTypes, JvDynControlEngine, JvDynControlEngineIntf,\r\n JvComponentBase, JvPanel, JvPropertyStore, JvAppStorage, JvAppStorageSelectList;\r\n\r\ntype\r\n TJvParameterList = class;\r\n TJvParameterListPropertyStore = class;\r\n TJvParameterPropertyValues = class;\r\n TJvParameterListSelectList = class;\r\n TJvBaseParameter = class;\r\n\r\n TJvBaseParameterClass = class of TJvBaseParameter;\r\n TJvParameterListClass = class of TJvParameterList;\r\n\r\n TJvParameterListEvent = procedure(const ParameterList: TJvParameterList; const Parameter: TJvBaseParameter) of object;\r\n TJvParameterListAfterParameterWincontrolPropertiesChangedEvent = procedure(const Parameter: TJvBaseParameter; const WinControl:\r\n TWinControl) of object;\r\n\r\n TJvParameterOnValidateData = procedure (const Data : Variant; var Msg : String; var Valid : Boolean) of Object;\r\n\r\n TJvParameterListEnableDisableReason = class(TPersistent)\r\n private\r\n FRemoteParameterName: string;\r\n FValue: Variant;\r\n FIsEmpty: Boolean;\r\n FIsNotEmpty: Boolean;\r\n protected\r\n procedure SetAsString(Value: string);\r\n function GetAsString: string;\r\n procedure SetAsDouble(Value: Double);\r\n function GetAsDouble: Double;\r\n procedure SetAsInteger(Value: Integer);\r\n function GetAsInteger: Integer;\r\n procedure SetAsBoolean(Value: Boolean);\r\n function GetAsBoolean: Boolean;\r\n procedure SetAsDate(Value: TDateTime);\r\n function GetAsDate: TDateTime;\r\n procedure SetAsVariant(Value: Variant);\r\n function GetAsVariant: Variant;\r\n procedure SetIsEmpty(Value: Boolean);\r\n procedure SetIsNotEmpty(Value: Boolean);\r\n public\r\n procedure Assign(Source: TPersistent); override;\r\n property AsString: string read GetAsString write SetAsString;\r\n property AsDouble: Double read GetAsDouble write SetAsDouble;\r\n property AsInteger: Integer read GetAsInteger write SetAsInteger;\r\n property AsBoolean: Boolean read GetAsBoolean write SetAsBoolean;\r\n property AsDate: TDateTime read GetAsDate write SetAsDate;\r\n property AsVariant: Variant read GetAsVariant write SetAsVariant;\r\n property IsEmpty: Boolean read FIsEmpty write SetIsEmpty;\r\n property IsNotEmpty: Boolean read FIsNotEmpty write SetIsNotEmpty;\r\n property RemoteParameterName: string read FRemoteParameterName write FRemoteParameterName;\r\n end;\r\n\r\n TJvParameterListEnableDisableReasonList = class(TStringList)\r\n public\r\n destructor Destroy; override;\r\n procedure Clear; override;\r\n procedure Delete(Index: Integer); override;\r\n procedure AddReasonVariant(const RemoteParameterName: string; Value: Variant);\r\n procedure AddReason(const RemoteParameterName: string; Value: Boolean); overload;\r\n procedure AddReason(const RemoteParameterName: string; Value: Integer); overload;\r\n procedure AddReason(const RemoteParameterName: string; Value: Double); overload;\r\n procedure AddReason(const RemoteParameterName: string; const Value: string); overload;\r\n procedure AddReason(const RemoteParameterName: string; Value: TDateTime); overload;\r\n procedure AddReasonIsEmpty(const RemoteParameterName: string);\r\n procedure AddReasonIsNotEmpty(const RemoteParameterName: string);\r\n end;\r\n\r\n TJvParameterPropertyValue = class(TPersistent)\r\n private\r\n FPropertyName: string;\r\n FPropertyValue: Variant;\r\n public\r\n property PropertyName: string read FPropertyName write FPropertyName;\r\n property PropertyValue: Variant read FPropertyValue write FPropertyValue;\r\n end;\r\n\r\n TJvParameterPropertyValues = class(TStringList)\r\n public\r\n constructor Create;\r\n destructor Destroy; override;\r\n procedure Clear; override;\r\n procedure Delete(Index: Integer); override;\r\n procedure AddValue(const AName: string; AValue: Variant);\r\n end;\r\n\r\n TJvBaseParameter = class(TJvComponent)\r\n private\r\n FCaption: string;\r\n FValue: Variant;\r\n FWidth: Integer;\r\n FHeight: Integer;\r\n FSearchName: string;\r\n FReadOnly: Boolean;\r\n FStoreValueToAppStorage: Boolean;\r\n FStoreValueCrypted: Boolean;\r\n FParentParameterName: string;\r\n FTabOrder: Integer;\r\n FParameterList: TJvParameterList;\r\n FWinControl: TWinControl;\r\n FJvDynControl: IJvDynControl;\r\n FJvDynControlData: IJvDynControlData;\r\n FHint: string;\r\n FTag: Integer;\r\n FColor: TColor;\r\n FAdditionalData: Pointer;\r\n FAfterWincontrolPropertiesChanged: TJvParameterListAfterParameterWincontrolPropertiesChangedEvent;\r\n FAfterWincontrolPropertiesChangedDisabledCnt: Integer;\r\n FEnabled: Boolean;\r\n FHelpContext: THelpContext;\r\n FDisableReasons: TJvParameterListEnableDisableReasonList;\r\n FEnableReasons: TJvParameterListEnableDisableReasonList;\r\n FJvDynControlReadOnly: IJvDynControlReadOnly;\r\n FJvDynControlCaption: IJvDynControlCaption;\r\n FVisible: Boolean;\r\n FOnEnterParameter: TJvParameterListEvent;\r\n FOnExitParameter: TJvParameterListEvent;\r\n FOnValidateData: TJvParameterOnValidateData;\r\n FRequired: Boolean;\r\n procedure DisableAfterWincontrolPropertiesChanged;\r\n procedure EnableAfterWincontrolPropertiesChanged;\r\n procedure HandleAfterWincontrolPropertiesChanged;\r\n function IsAfterWincontrolPropertiesChangedDisabled: Boolean;\r\n procedure SetAfterWincontrolPropertiesChangedDisabled(Updating: Boolean);\r\n procedure SetCaption(const Value: string);\r\n procedure SetParameterList(const Value: TJvParameterList);\r\n protected\r\n procedure SetAsString(const Value: string); virtual;\r\n function GetAsString: string; virtual;\r\n procedure SetAsDouble(Value: Double); virtual;\r\n function GetAsDouble: Double; virtual;\r\n procedure SetAsInteger(Value: Integer); virtual;\r\n function GetAsInteger: Integer; virtual;\r\n procedure SetAsBoolean(Value: Boolean); virtual;\r\n function GetAsBoolean: Boolean; virtual;\r\n procedure SetAsDate(Value: TDateTime); virtual;\r\n function GetAsDate: TDateTime; virtual;\r\n procedure SetAsVariant(Value: Variant); virtual;\r\n function GetAsVariant: Variant; virtual;\r\n function GetParameterNameExt: string; virtual;\r\n function GetParameterNameBase: string;\r\n function GetParameterName: string;\r\n procedure SetWinControl(const Value: TWinControl);\r\n function GetWinControlData: Variant; virtual;\r\n procedure SetWinControlData(Value: Variant); virtual;\r\n procedure SetSearchName(Value: string);\r\n\r\n procedure SetEnabled(Value: Boolean); virtual;\r\n procedure SetVisible(Value: Boolean); virtual;\r\n function GetHeight: Integer; virtual;\r\n procedure SetHeight(Value: Integer); virtual;\r\n procedure SetReadOnly(const Value: Boolean);\r\n function GetWidth: Integer; virtual;\r\n procedure SetWidth(Value: Integer); virtual;\r\n procedure SetTabOrder(Value: Integer); virtual;\r\n\r\n procedure Notification(AComponent: TComponent; Operation: TOperation); override;\r\n\r\n function GetDynControlEngine: TJvDynControlEngine;\r\n property Color: TColor read FColor write FColor;\r\n property JvDynControl: IJvDynControl read FJvDynControl;\r\n property JvDynControlCaption: IJvDynControlCaption read FJvDynControlCaption;\r\n property JvDynControlData: IJvDynControlData read FJvDynControlData;\r\n property JvDynControlReadOnly: IJvDynControlReadOnly read FJvDynControlReadOnly;\r\n property Value: Variant read FValue write FValue;\r\n function IsDataValid(const AData: Variant; var vMsg: String): Boolean; virtual;\r\n procedure SetWinControlProperties; virtual;\r\n public\r\n constructor Create(AParameterList: TJvParameterList); reintroduce; virtual;\r\n destructor Destroy; override;\r\n procedure Assign(Source: TPersistent); override;\r\n function Validate(var AData: Variant): Boolean; virtual;\r\n procedure CreateWinControlOnParent(ParameterParent: TWinControl); virtual; abstract;\r\n property WinControlData: Variant read GetWinControlData write SetWinControlData;\r\n //1 Creates a new instance of the same objecttype and assigns the property contents to the new instance\r\n function Clone(AOwner: TJvParameterlist): TJvBaseParameter;\r\n procedure GetData; virtual;\r\n function IsValid(const AData: Variant): Boolean; virtual;\r\n procedure SetData; virtual;\r\n property AdditionalData: Pointer read FAdditionalData write FAdditionalData;\r\n property ParameterList: TJvParameterList read FParameterList write SetParameterList;\r\n property DynControlEngine: TJvDynControlEngine read GetDynControlEngine;\r\n property WinControl: TWinControl read FWinControl;\r\n published\r\n {the next properties implements the possibilities to read and write the AdditionalData }\r\n property AsString: string read GetAsString write SetAsString;\r\n property AsDouble: Double read GetAsDouble write SetAsDouble;\r\n property AsInteger: Integer read GetAsInteger write SetAsInteger;\r\n property AsBoolean: Boolean read GetAsBoolean write SetAsBoolean;\r\n property AsDate: TDateTime read GetAsDate write SetAsDate;\r\n property AsVariant: Variant read GetAsVariant write SetAsVariant;\r\n {this name is used to identify the parameter in the parameterlist,\r\n this value must be defined before inserting into the parameterlist }\r\n property SearchName: string read FSearchName write SetSearchName;\r\n {should this value be saved by the parameterlist }\r\n property StoreValueToAppStorage: Boolean read FStoreValueToAppStorage write FStoreValueToAppStorage;\r\n {should this value be crypted before save }\r\n property StoreValueCrypted: Boolean read FStoreValueCrypted write FStoreValueCrypted;\r\n {the searchname of the parentparameter. The parentparameter must be a\r\n descent of TJvGroupBoxParameter, TJvPanelParameter or TJvPageControlParameter. If the\r\n parent parameter is a TJvPageControlParameter, then the ParentParameterName must be\r\n \"searchname.tabname\" of the TJvPageControlParameter}\r\n property ParentParameterName: string read FParentParameterName write FParentParameterName;\r\n {Is the value required, will be checked in the validate function}\r\n property Required: Boolean read FRequired write FRequired;\r\n property ReadOnly: Boolean read FReadOnly write SetReadOnly;\r\n property Enabled: Boolean read FEnabled write SetEnabled;\r\n property Visible: Boolean read FVisible write SetVisible;\r\n {the next properties find their expressions in the same properties of TWinControl }\r\n property Caption: string read FCaption write SetCaption;\r\n property Width: Integer read GetWidth write SetWidth;\r\n property Height: Integer read GetHeight write SetHeight;\r\n property Hint: string read FHint write FHint;\r\n property Tag: Integer read FTag write FTag;\r\n property HelpContext: THelpContext read FHelpContext write FHelpContext;\r\n property TabOrder: Integer read FTabOrder write SetTabOrder;\r\n property DisableReasons: TJvParameterListEnableDisableReasonList read FDisableReasons;\r\n property EnableReasons: TJvParameterListEnableDisableReasonList read FEnableReasons;\r\n property AfterWincontrolPropertiesChanged: TJvParameterListAfterParameterWincontrolPropertiesChangedEvent read\r\n FAfterWincontrolPropertiesChanged write FAfterWincontrolPropertiesChanged;\r\n /// Use this event to implement a custom logic to validate the parameter contents\r\n property OnValidateData: TJvParameterOnValidateData read FOnValidateData write FOnValidateData;\r\n property OnEnterParameter: TJvParameterListEvent read FOnEnterParameter write FOnEnterParameter;\r\n property OnExitParameter: TJvParameterListEvent read FOnExitParameter write FOnExitParameter;\r\n end;\r\n\r\n TJvParameterListMessages = class(TPersistent)\r\n private\r\n FCaption: string;\r\n FOkButton: string;\r\n FCancelButton: string;\r\n FHistoryLoadButton: string;\r\n FHistorySaveButton: string;\r\n FHistoryClearButton: string;\r\n FHistoryLoadCaption: string;\r\n FHistorySaveCaption: string;\r\n FHistoryClearCaption: string;\r\n public\r\n constructor Create;\r\n procedure Assign(Source: TPersistent); override;\r\n published\r\n property Caption: string read FCaption write FCaption;\r\n property OkButton: string read FOkButton write FOkButton;\r\n property CancelButton: string read FCancelButton write FCancelButton;\r\n property HistoryLoadButton: string read FHistoryLoadButton write FHistoryLoadButton;\r\n property HistorySaveButton: string read FHistorySaveButton write FHistorySaveButton;\r\n property HistoryClearButton: string read FHistoryClearButton write FHistoryClearButton;\r\n property HistoryLoadCaption: string read FHistoryLoadCaption write FHistoryLoadCaption;\r\n property HistorySaveCaption: string read FHistorySaveCaption write FHistorySaveCaption;\r\n property HistoryClearCaption: string read FHistoryClearCaption write FHistoryClearCaption;\r\n end;\r\n\r\n TJvParameterList = class(TJvComponent)\r\n private\r\n FMessages: TJvParameterListMessages;\r\n FIntParameterList: TStringList;\r\n FArrangeSettings: TJvArrangeSettings;\r\n FDynControlEngine: TJvDynControlEngine;\r\n FParameterDialog: TCustomForm;\r\n FWidth: Integer;\r\n FHeight: Integer;\r\n FMaxWidth: Integer;\r\n FMaxHeight: Integer;\r\n FDefaultParameterHeight: Integer;\r\n FDefaultParameterWidth: Integer;\r\n FDefaultParameterLabelWidth: Integer;\r\n FOkButtonVisible: Boolean;\r\n FCancelButtonVisible: Boolean;\r\n FParameterListPropertyStore: TJvParameterListPropertyStore;\r\n FHistoryEnabled: Boolean;\r\n FLastHistoryName: string;\r\n FParameterListSelectList: TJvParameterListSelectList;\r\n FOkButtonDisableReasons: TJvParameterListEnableDisableReasonList;\r\n FOkButtonEnableReasons: TJvParameterListEnableDisableReasonList;\r\n FOnChangeParameter: TNotifyEvent;\r\n FOnEnterParameter: TNotifyEvent;\r\n FOnExitParameter: TNotifyEvent;\r\n FShowParameterValidState: Boolean;\r\n function GetIntParameterList: TStrings;\r\n function AddObject(const S: string; AObject: TObject): Integer;\r\n function GetVisibleCount: Integer;\r\n procedure OnOkButtonClick(Sender: TObject);\r\n procedure OnCancelButtonClick(Sender: TObject);\r\n procedure ShowParameterDialogThread;\r\n protected\r\n OkButton: TButton;\r\n ArrangePanel: TJvPanel;\r\n ScrollBox: TScrollBox;\r\n RightPanel: TJvPanel;\r\n MainPanel: TWinControl;\r\n HistoryPanel: TWinControl;\r\n BottomPanel: TWinControl;\r\n ButtonPanel: TWinControl;\r\n OrgButtonPanelWidth: Integer;\r\n OrgHistoryPanelWidth: Integer;\r\n procedure SetArrangeSettings(Value: TJvArrangeSettings);\r\n procedure SetAppStoragePath(const Value: string);\r\n function GetAppStoragePath: string;\r\n function GetAppStorage: TJvCustomAppStorage;\r\n procedure SetAppStorage(Value: TJvCustomAppStorage);\r\n\r\n procedure ResizeDialogAfterArrange(Sender: TObject; nLeft, nTop, nWidth, nHeight: Integer);\r\n\r\n procedure Notification(AComponent: TComponent; Operation: TOperation); override;\r\n\r\n function GetParentByName(MainParent: TWinControl; const ASearchName: string): TWinControl;\r\n function GetCount: Integer;\r\n\r\n procedure SetParameters(Index: Integer; const Value: TJvBaseParameter);\r\n function GetParameters(Index: Integer): TJvBaseParameter;\r\n\r\n function GetCurrentWidth: Integer;\r\n function GetCurrentHeight: Integer;\r\n\r\n procedure HistoryLoadClick(Sender: TObject);\r\n procedure HistorySaveClick(Sender: TObject);\r\n procedure HistoryClearClick(Sender: TObject);\r\n function GetEnableDisableReasonState(ADisableReasons: TJvParameterListEnableDisableReasonList; AEnableReasons:\r\n TJvParameterListEnableDisableReasonList): Integer;\r\n procedure DialogShow(Sender: TObject);\r\n {this procedure checks the autoscroll-property of the internal\r\n scrollbox. This function should only be called, after the size of\r\n the parent-panel has changed}\r\n procedure CheckScrollBoxAutoScroll;\r\n property IntParameterList: TStrings read GetIntParameterList;\r\n property ParameterDialog: TCustomForm read FParameterDialog;\r\n property ParameterListSelectList: TJvParameterListSelectList read FParameterListSelectList;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n procedure Assign(Source: TPersistent); override;\r\n { Saves the data of all allowed parameters to the AppStorage }\r\n procedure StoreData;\r\n {Adds a new Parameter to the parameterlist }\r\n procedure AddParameter(AParameter: TJvBaseParameter);\r\n {returns the parameter identified by the Searchname}\r\n function ParameterByName(const ASearchName: string): TJvBaseParameter;\r\n {returns True id the parameter identified by the Searchname exists}\r\n function ExistsParameter(const ASearchName: string): Boolean;\r\n {returns the parameter identified by index-position}\r\n function ParameterByIndex(AIndex: Integer): TJvBaseParameter;\r\n {executes a dialog to enter all Parameter-Data,\r\n returns True when ok-button pressed}\r\n function ShowParameterDialog: Boolean; overload;\r\n {executes a dialog to enter all Parameter-Data,\r\n returns True when ok-button pressed\r\n This function can be called inside a running thread. It will synchromized\r\n with the main thread using SynchronizeThread.Synchronize}\r\n function ShowParameterDialog(SynchronizeThread: TThread): Boolean; overload;\r\n { Creates the ParameterDialog }\r\n procedure CreateParameterDialog;\r\n { Checks the Disable/Enable-Reason of all Parameters }\r\n procedure HandleEnableDisable;\r\n {creates the components of all parameters on any WinControl}\r\n procedure CreateWinControlsOnParent(ParameterParent: TWinControl);\r\n {Destroy the WinControls of all parameters}\r\n procedure DestroyWinControls;\r\n { reads the data of all parameters from the WinControls}\r\n procedure GetDataFromWinControls;\r\n procedure SetDataToWinControls;\r\n { validates the data of all parameters without filling the data into\r\n the parameters }\r\n function ValidateDataAtWinControls: Boolean;\r\n {deletes all Parameters from the ParameterList}\r\n procedure Clear;\r\n { count of parameters }\r\n property Count: Integer read GetCount;\r\n {returns the current height of the created main-parameter-panel}\r\n property CurrentWidth: Integer read GetCurrentWidth;\r\n {returns the current height of the created main-parameter-panel}\r\n property CurrentHeight: Integer read GetCurrentHeight;\r\n property DynControlEngine: TJvDynControlEngine read FDynControlEngine write FDynControlEngine;\r\n { Property to get access to the parameters }\r\n property Parameters[Index: Integer]: TJvBaseParameter read GetParameters write SetParameters; default;\r\n // Enable/DisableReason for the OkButton\r\n property OkButtonDisableReasons: TJvParameterListEnableDisableReasonList\r\n read FOkButtonDisableReasons write FOkButtonDisableReasons;\r\n property OkButtonEnableReasons: TJvParameterListEnableDisableReasonList\r\n read FOkButtonEnableReasons write FOkButtonEnableReasons;\r\n //1 Number of visible parameters\r\n property VisibleCount: Integer read GetVisibleCount;\r\n procedure AssignValues(iSourceList: TJvParameterList);\r\n procedure AssignValuesTo(iDestinationList: TJvParameterList);\r\n //1 Creates a new instance of the same objecttype and assigns the property contents to the new instance\r\n function Clone(AOwner: TComponent): TJvParameterList;\r\n {creates the components of all parameters on any TWInControl}\r\n procedure CreateWinControlsOnWinControl(ParameterParent: TWinControl);\r\n {\r\n Checks the IsDataValid of each Parameter, When the ShowParameterValidStatus is\r\n activated the labels invalid parameters will be shown italic\r\n }\r\n procedure HandleShowValidState;\r\n function IndexOfParameter(AParameter: TJvBaseParameter): Integer;\r\n { load the data of all allowed parameters from the AppStorage }\r\n procedure LoadData;\r\n { load the data of all allowed parameters from the AppStorage }\r\n procedure LoadDataFrom(const iTempAppStoragePath: string);\r\n procedure OnEnterParameterControl(Sender: TObject);\r\n procedure OnExitParameterControl(Sender: TObject);\r\n procedure OnChangeParameterControl(Sender: TObject);\r\n { Saves the data of all allowed parameters to the AppStorage }\r\n procedure StoreDataTo(const iTempAppStoragePath: string);\r\n published\r\n property ArrangeSettings: TJvArrangeSettings read FArrangeSettings write SetArrangeSettings;\r\n property Messages: TJvParameterListMessages read FMessages;\r\n {AppStoragePath for the Parameter-Storage using AppStorage}\r\n property AppStoragePath: string read GetAppStoragePath write SetAppStoragePath;\r\n {Width of the dialog. When width = 0, then the width will be calculated }\r\n property Width: Integer read FWidth write FWidth;\r\n {Height of the dialog. When height = 0, then the Height will be calculated }\r\n property Height: Integer read FHeight write FHeight;\r\n {Maximum ClientWidth of the Dialog}\r\n property MaxWidth: Integer read FMaxWidth write FMaxWidth default 400;\r\n {Maximum ClientHeight of the Dialog}\r\n property MaxHeight: Integer read FMaxHeight write FMaxHeight default 600;\r\n property DefaultParameterHeight: Integer read FDefaultParameterHeight write FDefaultParameterHeight default 0;\r\n property DefaultParameterWidth: Integer read FDefaultParameterWidth write FDefaultParameterWidth default 0;\r\n property DefaultParameterLabelWidth: Integer read FDefaultParameterLabelWidth write FDefaultParameterLabelWidth default\r\n 0;\r\n property OkButtonVisible: Boolean read FOkButtonVisible write FOkButtonVisible;\r\n property CancelButtonVisible: Boolean read FCancelButtonVisible write FCancelButtonVisible;\r\n property HistoryEnabled: Boolean read FHistoryEnabled write FHistoryEnabled;\r\n property LastHistoryName: string read FLastHistoryName write FLastHistoryName;\r\n property AppStorage: TJvCustomAppStorage read GetAppStorage write SetAppStorage;\r\n /// Show the state of each invalid parameter by drawing the label italic\r\n property ShowParameterValidState: Boolean read FShowParameterValidState write FShowParameterValidState default False;\r\n property OnChangeParameter: TNotifyEvent read FOnChangeParameter write FOnChangeParameter;\r\n property OnEnterParameter: TNotifyEvent read FOnEnterParameter write FOnEnterParameter;\r\n property OnExitParameter: TNotifyEvent read FOnExitParameter write FOnExitParameter;\r\n end;\r\n\r\n TJvParameterListSelectList = class(TJvBaseAppStorageSelectList)\r\n private\r\n FParameterList: TJvParameterList;\r\n protected\r\n function CreateSelectListDialogInstance(AOwner: TComponent;AOperation: TJvAppStorageSelectListOperation; ACaption:\r\n string = ''): TJvBaseAppStorageSelectListDialogInstance; override;\r\n procedure SetParameterList(Value: TJvParameterList); virtual;\r\n function GetAppStorage: TJvCustomAppStorage; override;\r\n function GetStoragePath: string; override;\r\n procedure SetAppStorage(Value: TJvCustomAppStorage); override;\r\n public\r\n procedure Notification(AComponent: TComponent; Operation: TOperation); override;\r\n procedure RestoreParameterList(const ACaption: string = '');\r\n procedure SaveParameterList(const ACaption: string = '');\r\n published\r\n property CheckEntries;\r\n property ParameterList: TJvParameterList read FParameterList write SetParameterList;\r\n property SelectListDialog;\r\n property SelectPath;\r\n end;\r\n\r\n TJvParameterListPropertyStore = class(TJvCustomPropertyStore)\r\n private\r\n FParameterList: TJvParameterList;\r\n procedure SetParameterList(const Value: TJvParameterList);\r\n protected\r\n procedure LoadData; override;\r\n procedure StoreData; override;\r\n public\r\n procedure Notification(AComponent: TComponent; Operation: TOperation); override;\r\n property ParameterList: TJvParameterList read FParameterList write SetParameterList;\r\n end;\r\n\r\n {$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile:\r\n '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvParameterList.pas $';\r\n Revision: '$Revision: 13415 $';\r\n Date: '$Date: 2012-09-10 11:51:54 +0200 (lun. 10 sept. 2012) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n {$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n {$IFDEF HAS_UNIT_SYSTEM_UITYPES}\r\n System.UITypes,\r\n {$ENDIF}\r\n JclStrings,\r\n JvParameterListParameter, JvResources, JvJVCLUtils, JclSysUtils;\r\n\r\nconst\r\n cFalse = 'FALSE';\r\n cTrue = 'TRUE';\r\n cAllowedChars: array [0..62] of Char =\r\n ('A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'J', 'K', 'L', 'M',\r\n 'N', 'O', 'P', 'Q', 'R', 'S', 'T', 'U', 'V', 'W', 'X', 'Y', 'Z',\r\n 'a', 'b', 'c', 'd', 'e', 'f', 'g', 'h', 'i', 'j', 'k', 'l', 'm',\r\n 'n', 'o', 'p', 'q', 'r', 's', 't', 'u', 'v', 'w', 'x', 'y', 'z',\r\n '0', '1', '2', '3', '4', '5', '6', '7', '8', '9', '_');\r\n\r\n//=== { TJvParameterListMessages } ===========================================\r\n\r\nconstructor TJvParameterListMessages.Create;\r\nbegin\r\n inherited Create;\r\n Caption := RsDialogCaption;\r\n OkButton := RsButtonOKCaption;\r\n CancelButton := RsCancelButton;\r\n HistoryLoadButton := RsHistoryLoadButton;\r\n HistorySaveButton := RsHistorySaveButton;\r\n HistoryClearButton := RsHistoryClearButton;\r\n HistoryLoadCaption := RsHistoryLoadCaption;\r\n HistorySaveCaption := RsHistorySaveCaption;\r\n HistoryClearCaption := RsHistoryClearCaption;\r\nend;\r\n\r\nprocedure TJvParameterListMessages.Assign(Source: TPersistent);\r\nbegin\r\n if Source is TJvParameterListMessages then\r\n begin\r\n Caption := TJvParameterListMessages(Source).Caption;\r\n OkButton := TJvParameterListMessages(Source).OkButton;\r\n CancelButton := TJvParameterListMessages(Source).CancelButton;\r\n HistoryLoadButton := TJvParameterListMessages(Source).HistoryLoadButton;\r\n HistorySaveButton := TJvParameterListMessages(Source).HistorySaveButton;\r\n HistoryClearButton := TJvParameterListMessages(Source).HistoryClearButton;\r\n HistoryLoadCaption := TJvParameterListMessages(Source).HistoryLoadCaption;\r\n HistorySaveCaption := TJvParameterListMessages(Source).HistorySaveCaption;\r\n HistoryClearCaption := TJvParameterListMessages(Source).HistoryClearCaption;\r\n end\r\n else\r\n inherited Assign(Source);\r\nend;\r\n\r\n//=== { TJvParameterListEnableDisableReason } ================================\r\n\r\nprocedure TJvParameterListEnableDisableReason.SetAsString(Value: string);\r\nbegin\r\n AsVariant := Value;\r\nend;\r\n\r\nfunction TJvParameterListEnableDisableReason.GetAsString: string;\r\nbegin\r\n Result := FValue;\r\nend;\r\n\r\nprocedure TJvParameterListEnableDisableReason.SetAsDouble(Value: Double);\r\nbegin\r\n AsVariant := Value;\r\nend;\r\n\r\nfunction TJvParameterListEnableDisableReason.GetAsDouble: Double;\r\nbegin\r\n Result := FValue;\r\nend;\r\n\r\nprocedure TJvParameterListEnableDisableReason.SetAsInteger(Value: Integer);\r\nbegin\r\n AsVariant := Value;\r\nend;\r\n\r\nfunction TJvParameterListEnableDisableReason.GetAsInteger: Integer;\r\nbegin\r\n Result := FValue;\r\nend;\r\n\r\nprocedure TJvParameterListEnableDisableReason.SetAsBoolean(Value: Boolean);\r\nbegin\r\n if Value then\r\n AsVariant := cTrue\r\n else\r\n AsVariant := cFalse;\r\nend;\r\n\r\nfunction TJvParameterListEnableDisableReason.GetAsBoolean: Boolean;\r\nvar\r\n S: string;\r\nbegin\r\n S := FValue;\r\n Result := S = cTrue;\r\nend;\r\n\r\nprocedure TJvParameterListEnableDisableReason.SetAsDate(Value: TDateTime);\r\nbegin\r\n AsVariant := VarFromDateTime(Value);\r\nend;\r\n\r\nfunction TJvParameterListEnableDisableReason.GetAsDate: TDateTime;\r\nbegin\r\n Result := VarToDateTime(FValue);\r\nend;\r\n\r\nprocedure TJvParameterListEnableDisableReason.SetAsVariant(Value: Variant);\r\nbegin\r\n FValue := Value;\r\nend;\r\n\r\nfunction TJvParameterListEnableDisableReason.GetAsVariant: Variant;\r\nbegin\r\n Result := FValue;\r\nend;\r\n\r\nprocedure TJvParameterListEnableDisableReason.SetIsEmpty(Value: Boolean);\r\nbegin\r\n // IsEmpty and NotIsEmtpy can both be False, in this case the Reason looks\r\n // for the value to activate/deactivate\r\n FIsEmpty := Value;\r\n if Value then\r\n IsNotEmpty := False;\r\nend;\r\n\r\nprocedure TJvParameterListEnableDisableReason.SetIsNotEmpty(Value: Boolean);\r\nbegin\r\n // IsEmpty and NotIsEmtpy can both be False, in this case the Reason looks\r\n // for the value to activate/deactivate\r\n FIsNotEmpty := Value;\r\n if Value then\r\n IsEmpty := False;\r\nend;\r\n\r\nprocedure TJvParameterListEnableDisableReason.Assign(Source: TPersistent);\r\nbegin\r\n if Source is TJvParameterListEnableDisableReason then\r\n begin\r\n AsVariant := TJvParameterListEnableDisableReason(Source).AsVariant;\r\n IsEmpty := TJvParameterListEnableDisableReason(Source).IsEmpty;\r\n IsNotEmpty := TJvParameterListEnableDisableReason(Source).IsNotEmpty;\r\n RemoteParameterName := TJvParameterListEnableDisableReason(Source).RemoteParameterName;\r\n end\r\n else\r\n inherited Assign(Source);\r\nend;\r\n\r\n//=== { TJvParameterListEnableDisableReasonList } ============================\r\n\r\ndestructor TJvParameterListEnableDisableReasonList.Destroy;\r\nbegin\r\n Clear;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvParameterListEnableDisableReasonList.Delete(Index: Integer);\r\nbegin\r\n Objects[Index].Free;\r\n inherited Delete(Index);\r\nend;\r\n\r\nprocedure TJvParameterListEnableDisableReasonList.Clear;\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := 0 to Count - 1 do\r\n Objects[I].Free;\r\n inherited Clear;\r\nend;\r\n\r\nprocedure TJvParameterListEnableDisableReasonList.AddReasonVariant(const RemoteParameterName: string; Value: Variant);\r\nvar\r\n Reason: TJvParameterListEnableDisableReason;\r\nbegin\r\n Reason := TJvParameterListEnableDisableReason.Create;\r\n Reason.RemoteParameterName := RemoteParameterName;\r\n Reason.AsVariant := Value;\r\n AddObject(RemoteParameterName, Reason);\r\nend;\r\n\r\nprocedure TJvParameterListEnableDisableReasonList.AddReason(const RemoteParameterName: string; Value: Boolean);\r\nvar\r\n Reason: TJvParameterListEnableDisableReason;\r\nbegin\r\n Reason := TJvParameterListEnableDisableReason.Create;\r\n Reason.RemoteParameterName := RemoteParameterName;\r\n Reason.AsBoolean := Value;\r\n AddObject(RemoteParameterName, Reason);\r\nend;\r\n\r\nprocedure TJvParameterListEnableDisableReasonList.AddReason(const RemoteParameterName: string; Value: Integer);\r\nvar\r\n Reason: TJvParameterListEnableDisableReason;\r\nbegin\r\n Reason := TJvParameterListEnableDisableReason.Create;\r\n Reason.RemoteParameterName := RemoteParameterName;\r\n Reason.AsInteger := Value;\r\n AddObject(RemoteParameterName, Reason);\r\nend;\r\n\r\nprocedure TJvParameterListEnableDisableReasonList.AddReason(const RemoteParameterName: string; Value: Double);\r\nvar\r\n Reason: TJvParameterListEnableDisableReason;\r\nbegin\r\n Reason := TJvParameterListEnableDisableReason.Create;\r\n Reason.RemoteParameterName := RemoteParameterName;\r\n Reason.AsDouble := Value;\r\n AddObject(RemoteParameterName, Reason);\r\nend;\r\n\r\nprocedure TJvParameterListEnableDisableReasonList.AddReason(const RemoteParameterName: string; const Value: string);\r\nvar\r\n Reason: TJvParameterListEnableDisableReason;\r\nbegin\r\n Reason := TJvParameterListEnableDisableReason.Create;\r\n Reason.RemoteParameterName := RemoteParameterName;\r\n Reason.AsString := Value;\r\n AddObject(RemoteParameterName, Reason);\r\nend;\r\n\r\nprocedure TJvParameterListEnableDisableReasonList.AddReason(const RemoteParameterName: string; Value: TDateTime);\r\nvar\r\n Reason: TJvParameterListEnableDisableReason;\r\nbegin\r\n Reason := TJvParameterListEnableDisableReason.Create;\r\n Reason.RemoteParameterName := RemoteParameterName;\r\n Reason.AsDate := Value;\r\n AddObject(RemoteParameterName, Reason);\r\nend;\r\n\r\nprocedure TJvParameterListEnableDisableReasonList.AddReasonIsEmpty(const RemoteParameterName: string);\r\nvar\r\n Reason: TJvParameterListEnableDisableReason;\r\nbegin\r\n Reason := TJvParameterListEnableDisableReason.Create;\r\n Reason.RemoteParameterName := RemoteParameterName;\r\n Reason.IsEmpty := True;\r\n AddObject(RemoteParameterName, Reason);\r\nend;\r\n\r\nprocedure TJvParameterListEnableDisableReasonList.AddReasonIsNotEmpty(const RemoteParameterName: string);\r\nvar\r\n Reason: TJvParameterListEnableDisableReason;\r\nbegin\r\n Reason := TJvParameterListEnableDisableReason.Create;\r\n Reason.RemoteParameterName := RemoteParameterName;\r\n Reason.IsNotEmpty := True;\r\n AddObject(RemoteParameterName, Reason);\r\nend;\r\n\r\n//=== { TJvParameterPropertyValues } =========================================\r\n\r\nconstructor TJvParameterPropertyValues.Create;\r\nbegin\r\n inherited Create;\r\n Sorted := True;\r\n Duplicates := dupIgnore;\r\nend;\r\n\r\ndestructor TJvParameterPropertyValues.Destroy;\r\nbegin\r\n Clear;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvParameterPropertyValues.Clear;\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := 0 to Count - 1 do\r\n Objects[I].Free;\r\n inherited Clear;\r\nend;\r\n\r\nprocedure TJvParameterPropertyValues.Delete(Index: Integer);\r\nbegin\r\n Objects[Index].Free;\r\n inherited Delete(Index);\r\nend;\r\n\r\nprocedure TJvParameterPropertyValues.AddValue(const AName: string; AValue: Variant);\r\nvar\r\n Value: TJvParameterPropertyValue;\r\nbegin\r\n Value := TJvParameterPropertyValue.Create;\r\n Value.PropertyName := AName;\r\n Value.PropertyValue := AValue;\r\n AddObject(AName, Value);\r\nend;\r\n\r\n//=== { TJvBaseParameter } ===================================================\r\n\r\nconstructor TJvBaseParameter.Create(AParameterList: TJvParameterList);\r\nbegin\r\n inherited Create(AParameterList);\r\n FStoreValueToAppStorage := True;\r\n FStoreValueCrypted := False;\r\n FTabOrder := -1;\r\n SetParameterList (AParameterList);\r\n FWinControl := nil;\r\n FJvDynControl := nil;\r\n FJvDynControlCaption := nil;\r\n FJvDynControlData := nil;\r\n FJvDynControlReadOnly := nil;\r\n Color := clBtnFace;\r\n FEnabled := True;\r\n FVisible := True;\r\n FEnableReasons := TJvParameterListEnableDisableReasonList.Create;\r\n FDisableReasons := TJvParameterListEnableDisableReasonList.Create;\r\n FValue := null;\r\nend;\r\n\r\ndestructor TJvBaseParameter.Destroy;\r\nbegin\r\n FreeAndNil(FEnableReasons);\r\n FreeAndNil(FDisableReasons);\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvBaseParameter.SetAsString(const Value: string);\r\nbegin\r\n AsVariant := Value;\r\nend;\r\n\r\nfunction TJvBaseParameter.GetAsString: string;\r\nbegin\r\n if VarIsNullEmpty(AsVariant) then\r\n Result := ''\r\n else\r\n Result := AsVariant;\r\nend;\r\n\r\nprocedure TJvBaseParameter.SetAsDouble(Value: Double);\r\nbegin\r\n AsVariant := Value;\r\nend;\r\n\r\nfunction TJvBaseParameter.GetAsDouble: Double;\r\nbegin\r\n if AsString = '' then\r\n Result := 0\r\n else\r\n Result := AsVariant;\r\nend;\r\n\r\nprocedure TJvBaseParameter.SetAsInteger(Value: Integer);\r\nbegin\r\n AsVariant := Value;\r\nend;\r\n\r\nfunction TJvBaseParameter.GetAsInteger: Integer;\r\nbegin\r\n if VarIsNullEmpty(AsVariant) then\r\n Result := 0\r\n else\r\n Result := AsVariant;\r\nend;\r\n\r\nprocedure TJvBaseParameter.SetAsBoolean(Value: Boolean);\r\nbegin\r\n if Value then\r\n AsVariant := cTrue\r\n else\r\n AsVariant := cFalse;\r\nend;\r\n\r\nfunction TJvBaseParameter.GetAsBoolean: Boolean;\r\nvar\r\n S: string;\r\nbegin\r\n if VarIsNullEmpty(FValue) then\r\n Result := False\r\n else\r\n begin\r\n S := AsVariant;\r\n Result := UpperCase(S) = cTrue;\r\n end;\r\nend;\r\n\r\nprocedure TJvBaseParameter.SetAsDate(Value: TDateTime);\r\nbegin\r\n AsVariant := VarFromDateTime(Value);\r\nend;\r\n\r\nfunction TJvBaseParameter.GetAsDate: TDateTime;\r\nbegin\r\n if VarIsNullEmpty(FValue) then\r\n Result := 0\r\n else\r\n Result := VarToDateTime(FValue);\r\nend;\r\n\r\nprocedure TJvBaseParameter.SetAsVariant(Value: Variant);\r\nbegin\r\n FValue := Value;\r\nend;\r\n\r\nfunction TJvBaseParameter.GetAsVariant: Variant;\r\nbegin\r\n Result := FValue;\r\nend;\r\n\r\nprocedure TJvBaseParameter.Notification(AComponent: TComponent; Operation: TOperation);\r\nbegin\r\n inherited Notification(AComponent, Operation);\r\n if (Operation = opRemove) then\r\n if (AComponent = FWinControl) then\r\n begin\r\n FWinControl := nil;\r\n FJvDynControl := nil;\r\n FJvDynControlCaption := nil;\r\n FJvDynControlData := nil;\r\n FJvDynControlReadOnly := nil;\r\n end\r\n else if (AComponent = FParameterList) then\r\n fParameterList := nil;\r\nend;\r\n\r\nfunction TJvBaseParameter.GetWinControlData: Variant;\r\nbegin\r\n if Assigned(JvDynControlData) then\r\n Result := JvDynControlData.ControlValue\r\n else\r\n Result := Null;\r\nend;\r\n\r\nprocedure TJvBaseParameter.SetWinControlData(Value: Variant);\r\nbegin\r\n if Assigned(JvDynControlData) then\r\n try\r\n JvDynControlData.ControlValue := Value;\r\n except\r\n on E: EConvertError do\r\n ;\r\n on E: EVariantTypeCastError do\r\n ;\r\n end;\r\nend;\r\n\r\nprocedure TJvBaseParameter.SetSearchName(Value: string);\r\nbegin\r\n FSearchName := Trim(Value);\r\nend;\r\n\r\nfunction TJvBaseParameter.GetDynControlEngine: TJvDynControlEngine;\r\nbegin\r\n Result := nil;\r\n if Assigned(ParameterList) then\r\n Result := ParameterList.DynControlEngine;\r\nend;\r\n\r\n//type\r\n// TWinControlAccessProtected = class(TWinControl);\r\n\r\nprocedure TJvBaseParameter.SetWinControl(const Value: TWinControl);\r\nbegin\r\n FJvDynControl := nil;\r\n FJvDynControlCaption := nil;\r\n FJvDynControlData := nil;\r\n FJvDynControlReadOnly := nil;\r\n ReplaceComponentReference(Self, Value, TComponent(FWinControl));\r\n if not Assigned(Value) then\r\n Exit;\r\n Supports(FWinControl, IJvDynControl, FJvDynControl);\r\n Supports(FWinControl, IJvDynControlCaption, FJvDynControlCaption);\r\n Supports(FWinControl, IJvDynControlData, FJvDynControlData);\r\n Supports(FWinControl, IJvDynControlReadOnly, FJvDynControlReadOnly);\r\n\r\n DisableAfterWincontrolPropertiesChanged;\r\n try\r\n SetWinControlProperties;\r\n finally\r\n EnableAfterWincontrolPropertiesChanged;\r\n end;\r\n HandleAfterWincontrolPropertiesChanged;\r\nend;\r\n\r\nprocedure TJvBaseParameter.SetWinControlProperties;\r\nbegin\r\n if Assigned(WinControl) then\r\n begin\r\n SetCaption(Caption);\r\n if Assigned(JvDynControlReadOnly) then\r\n begin\r\n JvDynControlReadOnly.ControlSetReadOnly(ReadOnly);\r\n SetEnabled(FEnabled);\r\n end\r\n else\r\n SetEnabled(FEnabled and not ReadOnly);\r\n SetVisible(FVisible);\r\n if FTabOrder >= 0 then\r\n SetTabOrder(FTabOrder);\r\n if FWidth > 0 then\r\n SetWidth(FWidth);\r\n if FHeight > 0 then\r\n SetHeight(FHeight);\r\n WinControl.Hint := Hint;\r\n WinControl.Tag := Tag;\r\n WinControl.HelpContext := HelpContext;\r\n if Assigned(JvDynControl) then\r\n begin\r\n JvDynControl.ControlSetOnEnter(ParameterList.OnEnterParameterControl);\r\n JvDynControl.ControlSetOnExit(ParameterList.OnExitParameterControl);\r\n end;\r\n if Assigned(JvDynControlData) then\r\n JvDynControlData.ControlSetOnChange(ParameterList.OnChangeParameterControl);\r\n end;\r\nend;\r\n\r\nprocedure TJvBaseParameter.SetEnabled(Value: Boolean);\r\nbegin\r\n FEnabled := Value;\r\n if Assigned(WinControl) then\r\n WinControl.Enabled := Value;\r\n HandleAfterWincontrolPropertiesChanged;\r\nend;\r\n\r\nprocedure TJvBaseParameter.SetVisible(Value: Boolean);\r\nbegin\r\n FVisible := Value;\r\n if Assigned(WinControl) then\r\n WinControl.Visible := Value;\r\n HandleAfterWincontrolPropertiesChanged;\r\nend;\r\n\r\nfunction TJvBaseParameter.GetHeight: Integer;\r\nbegin\r\n if Assigned(ParameterList) and (FHeight <= 0) then\r\n Result := ParameterList.DefaultParameterHeight\r\n else\r\n Result := FHeight;\r\nend;\r\n\r\nprocedure TJvBaseParameter.SetHeight(Value: Integer);\r\nbegin\r\n FHeight := Value;\r\n if Assigned(WinControl) then\r\n WinControl.Height := Value;\r\nend;\r\n\r\nfunction TJvBaseParameter.GetWidth: Integer;\r\nbegin\r\n if Assigned(ParameterList) and (FWidth <= 0) then\r\n Result := ParameterList.DefaultParameterWidth\r\n else\r\n Result := FWidth;\r\nend;\r\n\r\nprocedure TJvBaseParameter.SetWidth(Value: Integer);\r\nbegin\r\n FWidth := Value;\r\n if Assigned(WinControl) then\r\n WinControl.Width := Value;\r\n HandleAfterWincontrolPropertiesChanged;\r\nend;\r\n\r\nprocedure TJvBaseParameter.SetTabOrder(Value: Integer);\r\nbegin\r\n FTabOrder := Value;\r\n if Assigned(WinControl) then\r\n WinControl.TabOrder := Value;\r\n HandleAfterWincontrolPropertiesChanged;\r\nend;\r\n\r\nprocedure TJvBaseParameter.GetData;\r\nbegin\r\n if Assigned(WinControl) then\r\n AsVariant := WinControlData;\r\nend;\r\n\r\nprocedure TJvBaseParameter.SetData;\r\nbegin\r\n if Assigned(WinControl) then\r\n WinControlData := AsVariant;\r\nend;\r\n\r\nprocedure TJvBaseParameter.Assign(Source: TPersistent);\r\nbegin\r\n if Source is TJvBaseParameter then\r\n begin\r\n DisableAfterWincontrolPropertiesChanged;\r\n try\r\n AsVariant := TJvBaseParameter(Source).AsVariant;\r\n Caption := TJvBaseParameter(Source).Caption;\r\n SearchName := TJvBaseParameter(Source).SearchName;\r\n Width := TJvBaseParameter(Source).Width;\r\n Height := TJvBaseParameter(Source).Height;\r\n Required := TJvBaseParameter(Source).Required;\r\n ParentParameterName := TJvBaseParameter(Source).ParentParameterName;\r\n StoreValueToAppStorage := TJvBaseParameter(Source).StoreValueToAppStorage;\r\n StoreValueCrypted := TJvBaseParameter(Source).StoreValueCrypted;\r\n TabOrder := TJvBaseParameter(Source).TabOrder;\r\n FParameterList := TJvBaseParameter(Source).ParameterList;\r\n Color := TJvBaseParameter(Source).Color;\r\n ReadOnly := TJvBaseParameter(Source).ReadOnly;\r\n Enabled := TJvBaseParameter(Source).Enabled;\r\n FEnableReasons.Assign(TJvBaseParameter(Source).FEnableReasons);\r\n FDisableReasons.Assign(TJvBaseParameter(Source).FDisableReasons);\r\n finally\r\n EnableAfterWincontrolPropertiesChanged;\r\n HandleAfterWincontrolPropertiesChanged;\r\n end;\r\n end\r\n else\r\n inherited Assign(Source);\r\nend;\r\n\r\nfunction TJvBaseParameter.Clone(AOwner: TJvParameterlist): TJvBaseParameter;\r\nbegin\r\n Result := TJvBaseParameterClass(ClassType).Create(AOwner);\r\n Result.Assign(Self);\r\nend;\r\n\r\nprocedure TJvBaseParameter.DisableAfterWincontrolPropertiesChanged;\r\nbegin\r\n Dec(FAfterWincontrolPropertiesChangedDisabledCnt);\r\n if FAfterWincontrolPropertiesChangedDisabledCnt = 0 then SetAfterWincontrolPropertiesChangedDisabled(False);\r\nend;\r\n\r\nprocedure TJvBaseParameter.EnableAfterWincontrolPropertiesChanged;\r\nbegin\r\n Inc(FAfterWincontrolPropertiesChangedDisabledCnt);\r\n if FAfterWincontrolPropertiesChangedDisabledCnt = 1 then SetAfterWincontrolPropertiesChangedDisabled(True);\r\nend;\r\n\r\nfunction TJvBaseParameter.Validate(var AData: Variant): Boolean;\r\nvar Msg : String;\r\nbegin\r\n Result := IsDataValid(AData, Msg);\r\n if not Result then\r\n DSADialogsMessageDlg(Msg, mtError, [mbOK], 0);\r\nend;\r\n\r\nfunction TJvBaseParameter.GetParameterNameExt: string;\r\nbegin\r\n Result := '';\r\nend;\r\n\r\nfunction TJvBaseParameter.GetParameterNameBase: string;\r\nbegin\r\n Result := 'ParameterItem' + StrReplaceButChars(SearchName, cAllowedChars, '_');\r\nend;\r\n\r\nfunction TJvBaseParameter.GetParameterName: string;\r\nbegin\r\n Result := GetParameterNameBase + GetParameterNameExt;\r\nend;\r\n\r\nprocedure TJvBaseParameter.HandleAfterWincontrolPropertiesChanged;\r\nbegin\r\n if Assigned(FAfterWincontrolPropertiesChanged) and not IsAfterWincontrolPropertiesChangedDisabled then\r\n AfterWincontrolPropertiesChanged(Self, WinControl);\r\nend;\r\n\r\nfunction TJvBaseParameter.IsAfterWincontrolPropertiesChangedDisabled: Boolean;\r\nbegin\r\n Result := FAfterWincontrolPropertiesChangedDisabledCnt > 0;\r\nend;\r\n\r\nfunction TJvBaseParameter.IsValid(const AData: Variant): Boolean;\r\nvar Msg : String;\r\nbegin\r\n if Assigned(OnValidateData) then\r\n OnValidateData(AData, Msg, Result)\r\n else\r\n Result := IsDataValid(AData, Msg);\r\nend;\r\n\r\nfunction TJvBaseParameter.IsDataValid(const AData: Variant; var vMsg: String): Boolean;\r\nbegin\r\n if not Required or not Enabled then\r\n Result := True\r\n else\r\n Result := VarToStr(AData) <> '';\r\n if not Result then\r\n vMsg := Format(RsErrParameterMustBeEntered, [Caption]);\r\nend;\r\n\r\nprocedure TJvBaseParameter.SetAfterWincontrolPropertiesChangedDisabled(Updating: Boolean);\r\nbegin\r\nend;\r\n\r\nprocedure TJvBaseParameter.SetCaption(const Value: string);\r\nbegin\r\n FCaption := Value;\r\n if Assigned(JvDynControlCaption) then\r\n JvDynControlCaption.ControlSetCaption(FCaption);\r\n HandleAfterWincontrolPropertiesChanged;\r\nend;\r\n\r\nprocedure TJvBaseParameter.SetParameterList(const Value: TJvParameterList);\r\nbegin\r\n ReplaceComponentReference(Self, Value, TComponent(FParameterList));\r\nend;\r\n\r\nprocedure TJvBaseParameter.SetReadOnly(const Value: Boolean);\r\nbegin\r\n FReadOnly := Value;\r\n if Assigned(WinControl) then\r\n if Assigned(JvDynControlReadOnly) then\r\n JvDynControlReadOnly.ControlSetReadOnly(ReadOnly)\r\n else\r\n SetEnabled(FEnabled and not ReadOnly);\r\n HandleAfterWincontrolPropertiesChanged;\r\nend;\r\n\r\n//=== { TJvParameterList } ===================================================\r\n\r\nconstructor TJvParameterList.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FMessages := TJvParameterListMessages.Create;\r\n FParameterListPropertyStore := TJvParameterListPropertyStore.Create(nil);\r\n FParameterListPropertyStore.ParameterList := Self;\r\n FIntParameterList := TStringList.Create;\r\n FDynControlEngine := DefaultDynControlEngine;\r\n FArrangeSettings := TJvArrangeSettings.Create(Self);\r\n FArrangeSettings.AutoArrange := True;\r\n FArrangeSettings.WrapControls := True;\r\n FArrangeSettings.AutoSize := asBoth;\r\n FArrangeSettings.DistanceVertical := 3;\r\n FArrangeSettings.DistanceHorizontal := 3;\r\n FArrangeSettings.BorderLeft := 5;\r\n FArrangeSettings.BorderTop := 5;\r\n ScrollBox := nil;\r\n RightPanel := nil;\r\n ArrangePanel := nil;\r\n FMaxWidth := 600;\r\n FMaxHeight := 400;\r\n FDefaultParameterHeight := 0;\r\n FDefaultParameterWidth := 0;\r\n FDefaultParameterLabelWidth := 0;\r\n FOkButtonVisible := True;\r\n FCancelButtonVisible := True;\r\n FHistoryEnabled := False;\r\n FLastHistoryName := '';\r\n FParameterListSelectList := TJvParameterListSelectList.Create(Self);\r\n FParameterListSelectList.ParameterList := Self;\r\n FOkButtonDisableReasons := TJvParameterListEnableDisableReasonList.Create;\r\n FOkButtonEnableReasons := TJvParameterListEnableDisableReasonList.Create;\r\n FShowParameterValidState := False;\r\nend;\r\n\r\ndestructor TJvParameterList.Destroy;\r\nbegin\r\n DestroyWinControls;\r\n FreeAndNil(FParameterListSelectList);\r\n FreeAndNil(FIntParameterList);\r\n FreeAndNil(FParameterListPropertyStore);\r\n FreeAndNil(FArrangeSettings);\r\n FreeAndNil(FMessages);\r\n FreeAndNil(FOkButtonDisableReasons);\r\n FreeAndNil(FOkButtonEnableReasons);\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJvParameterList.GetIntParameterList: TStrings;\r\nbegin\r\n Result := FIntParameterList;\r\nend;\r\n\r\nprocedure TJvParameterList.AddParameter(AParameter: TJvBaseParameter);\r\nbegin\r\n AddObject(AParameter.SearchName, AParameter);\r\nend;\r\n\r\nfunction TJvParameterList.ExistsParameter(const ASearchName: string): Boolean;\r\nbegin\r\n Result := Assigned(ParameterByName(ASearchName));\r\nend;\r\n\r\nfunction TJvParameterList.ParameterByName(const ASearchName: string): TJvBaseParameter;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := nil;\r\n for I := 0 to Count - 1 do\r\n if UpperCase(Parameters[I].SearchName) = UpperCase(Trim(ASearchName)) then\r\n begin\r\n Result := Parameters[I];\r\n Break;\r\n end;\r\nend;\r\n\r\nfunction TJvParameterList.ParameterByIndex(AIndex: Integer): TJvBaseParameter;\r\nbegin\r\n Result := Parameters[AIndex];\r\nend;\r\n\r\nprocedure TJvParameterList.Assign(Source: TPersistent);\r\nbegin\r\n if Source is TJvParameterList then\r\n begin\r\n Messages.Assign(TJvParameterList(Source).Messages);\r\n ArrangeSettings := TJvParameterList(Source).ArrangeSettings;\r\n AppStorage := TJvParameterList(Source).AppStorage;\r\n Width := TJvParameterList(Source).Width;\r\n Height := TJvParameterList(Source).Height;\r\n MaxWidth := TJvParameterList(Source).MaxWidth;\r\n MaxHeight := TJvParameterList(Source).MaxHeight;\r\n OkButtonVisible := TJvParameterList(Source).OkButtonVisible;\r\n CancelButtonVisible := TJvParameterList(Source).CancelButtonVisible;\r\n FIntParameterList.Assign(TJvParameterList(Source).IntParameterList);\r\n HistoryEnabled := TJvParameterList(Source).HistoryEnabled;\r\n AppStoragePath := TJvParameterList(Source).AppStoragePath;\r\n ShowParameterValidState := TJvParameterList(Source).ShowParameterValidState;\r\n end\r\n else\r\n inherited Assign(Source);\r\nend;\r\n\r\nprocedure TJvParameterList.SetAppStoragePath(const Value: string);\r\nbegin\r\n FParameterListPropertyStore.AppStoragePath := Value;\r\n if Assigned(AppStorage) then\r\n FParameterListSelectList.SelectPath := AppStorage.ConcatPaths([Value, RsHistorySelectPath])\r\nend;\r\n\r\nfunction TJvParameterList.GetAppStoragePath: string;\r\nbegin\r\n Result := FParameterListPropertyStore.AppStoragePath;\r\nend;\r\n\r\nfunction TJvParameterList.GetAppStorage: TJvCustomAppStorage;\r\nbegin\r\n Result := FParameterListPropertyStore.AppStorage;\r\nend;\r\n\r\nprocedure TJvParameterList.SetAppStorage(Value: TJvCustomAppStorage);\r\nbegin\r\n FParameterListPropertyStore.AppStorage := Value;\r\n if Assigned(Value) then\r\n FParameterListSelectList.SelectPath :=\r\n Value.ConcatPaths([FParameterListPropertyStore.AppStoragePath, RsHistorySelectPath])\r\nend;\r\n\r\nprocedure TJvParameterList.Notification(AComponent: TComponent; Operation: TOperation);\r\nbegin\r\n inherited Notification(AComponent, Operation);\r\n if Operation = opRemove then\r\n begin\r\n if AComponent = ScrollBox then\r\n ScrollBox := nil;\r\n if AComponent = RightPanel then\r\n RightPanel := nil;\r\n if AComponent = ArrangePanel then\r\n ArrangePanel := nil;\r\n if AComponent = FParameterListPropertyStore then\r\n FParameterListPropertyStore := nil;\r\n if AComponent = OkButton then\r\n OkButton := nil;\r\n end;\r\nend;\r\n\r\nprocedure TJvParameterList.LoadData;\r\nbegin\r\n if (AppStoragePath <> '') and Assigned(AppStorage) then\r\n FParameterListPropertyStore.LoadData;\r\nend;\r\n\r\nprocedure TJvParameterList.LoadDataFrom(const iTempAppStoragePath: string);\r\nvar SaveAppStoragePath : string;\r\nbegin\r\n if (iTempAppStoragePath <> '') and Assigned(AppStorage) then\r\n begin\r\n try\r\n SaveAppStoragePath := AppStoragePath;\r\n AppStoragePath := iTempAppStoragePath;\r\n FParameterListPropertyStore.LoadData;\r\n finally\r\n AppStoragePath := SaveAppStoragePath;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvParameterList.StoreData;\r\nbegin\r\n if (AppStoragePath <> '') and Assigned(AppStorage) then\r\n FParameterListPropertyStore.StoreData;\r\nend;\r\n\r\nprocedure TJvParameterList.StoreDataTo(const iTempAppStoragePath: string);\r\nvar SaveAppStoragePath : string;\r\nbegin\r\n if (iTempAppStoragePath <> '') and Assigned(AppStorage) then\r\n begin\r\n try\r\n SaveAppStoragePath := AppStoragePath;\r\n AppStoragePath := iTempAppStoragePath;\r\n FParameterListPropertyStore.StoreData;\r\n finally\r\n AppStoragePath := SaveAppStoragePath;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvParameterList.OnOkButtonClick(Sender: TObject);\r\nbegin\r\n if ValidateDataAtWinControls then\r\n ParameterDialog.ModalResult := mrOk;\r\nend;\r\n\r\nprocedure TJvParameterList.OnCancelButtonClick(Sender: TObject);\r\nbegin\r\n ParameterDialog.ModalResult := mrCancel;\r\nend;\r\n\r\nprocedure TJvParameterList.OnEnterParameterControl(Sender: TObject);\r\nvar\r\n I: Integer;\r\nbegin\r\n if csDestroying in ComponentState then\r\n Exit;\r\n if Assigned(Sender) then\r\n for I := 0 to Count - 1 do\r\n if Parameters[I].WinControl = Sender then\r\n begin\r\n if Assigned(Parameters[I].OnEnterParameter) then\r\n Parameters[I].OnEnterParameter(Self, Parameters[I]);\r\n if Assigned(OnEnterParameter) then\r\n OnEnterParameter(Parameters[I]);\r\n Break;\r\n end;\r\nend;\r\n\r\nprocedure TJvParameterList.OnExitParameterControl(Sender: TObject);\r\nvar\r\n I: Integer;\r\nbegin\r\n if csDestroying in ComponentState then\r\n Exit;\r\n if Assigned(Sender) then\r\n for I := 0 to Count - 1 do\r\n if Parameters[I].WinControl = Sender then\r\n begin\r\n if Assigned(Parameters[I].OnExitParameter) then\r\n Parameters[I].OnExitParameter(Self, Parameters[I]);\r\n if Assigned(OnExitParameter) then\r\n OnExitParameter(Parameters[I]);\r\n Break;\r\n end;\r\n HandleEnableDisable;\r\n HandleShowValidState;\r\nend;\r\n\r\nprocedure TJvParameterList.OnChangeParameterControl(Sender: TObject);\r\nvar\r\n I: Integer;\r\nbegin\r\n if csDestroying in ComponentState then\r\n Exit;\r\n if Assigned(Sender) then\r\n for I := 0 to Count - 1 do\r\n if Parameters[I].WinControl = Sender then\r\n begin\r\n if Assigned(OnChangeParameter) then\r\n OnChangeParameter(Parameters[I]);\r\n Break;\r\n end;\r\n HandleEnableDisable;\r\n HandleShowValidState;\r\nend;\r\n\r\ntype\r\n TCustomControlAccessProtected = class(TCustomControl);\r\n\r\nprocedure TJvParameterList.CreateParameterDialog;\r\nvar\r\n CancelButton: TWinControl;\r\n LoadButton, SaveButton, ClearButton: TWinControl;\r\n ButtonLeft: Integer;\r\n ITmpPanel: IJvDynControlPanel;\r\nbegin\r\n FreeAndNil(FParameterDialog);\r\n\r\n FParameterDialog := DynControlEngine.CreateForm(Messages.Caption, '');\r\n\r\n TForm(ParameterDialog).BorderIcons := [];\r\n TForm(ParameterDialog).DefaultMonitor := dmActiveForm;\r\n TForm(ParameterDialog).BorderStyle := bsDialog;\r\n TForm(ParameterDialog).FormStyle := fsNormal;\r\n TForm(ParameterDialog).Position := poScreenCenter;\r\n TForm(ParameterDialog).ShowHint := True;\r\n TForm(ParameterDialog).OnShow := DialogShow;\r\n\r\n if Height > 0 then\r\n ParameterDialog.Height := Height;\r\n if Width > 0 then\r\n ParameterDialog.Width := Width;\r\n\r\n BottomPanel := DynControlEngine.CreatePanelControl(Self, ParameterDialog, 'BottomPanel', '', alBottom);\r\n if not Supports(BottomPanel, IJvDynControlPanel, ITmpPanel) then\r\n raise EIntfCastError.CreateRes(@RsEIntfCastError);\r\n ITmpPanel.ControlSetBorder(bvNone, bvRaised, 1, bsNone, 0);\r\n\r\n MainPanel := DynControlEngine.CreatePanelControl(Self, ParameterDialog, 'MainPanel', '', alClient);\r\n if not Supports(MainPanel, IJvDynControlPanel, ITmpPanel) then\r\n raise EIntfCastError.CreateRes(@RsEIntfCastError);\r\n ITmpPanel.ControlSetBorder(bvNone, bvRaised, 1, bsNone, 3);\r\n\r\n ButtonPanel := DynControlEngine.CreatePanelControl(Self, BottomPanel, 'BottonPanel', '',\r\n alRight);\r\n if not Supports(ButtonPanel, IJvDynControlPanel, ITmpPanel) then\r\n raise EIntfCastError.CreateRes(@RsEIntfCastError);\r\n ITmpPanel.ControlSetBorder(bvNone, bvNone, 0, bsNone, 0);\r\n\r\n OkButton := DynControlEngine.CreateButton(Self, ButtonPanel, 'OkButton', Messages.OkButton, '',\r\n OnOkButtonClick, True, False);\r\n CancelButton := DynControlEngine.CreateButton(Self, ButtonPanel, 'CancelButton',\r\n Messages.CancelButton, '',\r\n OnCancelButtonClick, False, True);\r\n\r\n BottomPanel.Height := OkButton.Height + 6 + 2;\r\n\r\n OkButton.Top := 3;\r\n OkButton.Left := 3;\r\n OkButton.Visible := OkButtonVisible;\r\n OkButton.Enabled := OkButtonVisible;\r\n if OkButton.Visible then\r\n ButtonLeft := OkButton.Left + OkButton.Width + 3\r\n else\r\n ButtonLeft := 0;\r\n\r\n CancelButton.Top := 3;\r\n CancelButton.Left := ButtonLeft + 3;\r\n CancelButton.Visible := CancelButtonVisible;\r\n CancelButton.Enabled := CancelButtonVisible;\r\n if CancelButton.Visible then\r\n ButtonLeft := ButtonLeft + 3 + CancelButton.Width + 3;\r\n\r\n ButtonPanel.Width := ButtonLeft + 3;\r\n OrgButtonPanelWidth := ButtonLeft + 3;\r\n\r\n OkButton.Anchors := [akTop, akRight];\r\n CancelButton.Anchors := [akTop, akRight];\r\n\r\n if HistoryEnabled and (AppStoragePath <> '') then\r\n begin\r\n HistoryPanel := DynControlEngine.CreatePanelControl(Self, BottomPanel, 'HistoryPanel', '',\r\n alLeft);\r\n if not Supports(HistoryPanel, IJvDynControlPanel, ITmpPanel) then\r\n raise EIntfCastError.CreateRes(@RsEIntfCastError);\r\n ITmpPanel.ControlSetBorder(bvNone, bvNone, 0, bsNone, 0);\r\n HistoryPanel.Height := 25;\r\n LoadButton := DynControlEngine.CreateButton(Self, HistoryPanel, 'LoadButton',\r\n Messages.HistoryLoadButton, '',\r\n HistoryLoadClick, False, False);\r\n LoadButton.Left := 6;\r\n LoadButton.Top := 5;\r\n LoadButton.Height := 20;\r\n LoadButton.Width :=\r\n TCustomControlAccessProtected(HistoryPanel).Canvas.TextWidth(Messages.HistoryLoadButton) + 5;\r\n ButtonLeft := LoadButton.Left + LoadButton.Width + 5;\r\n SaveButton := DynControlEngine.CreateButton(Self, HistoryPanel, 'SaveButton',\r\n Messages.HistorySaveButton, '',\r\n HistorySaveClick, False, False);\r\n SaveButton.Left := ButtonLeft;\r\n SaveButton.Top := 5;\r\n SaveButton.Height := 20;\r\n SaveButton.Width :=\r\n TCustomControlAccessProtected(HistoryPanel).Canvas.TextWidth(Messages.HistorySaveButton) + 5;\r\n ButtonLeft := SaveButton.Left + SaveButton.Width + 5;\r\n ClearButton := DynControlEngine.CreateButton(Self, HistoryPanel, 'ClearButton',\r\n Messages.HistoryClearButton, '',\r\n HistoryClearClick, False, False);\r\n ClearButton.Left := ButtonLeft;\r\n ClearButton.Top := 5;\r\n ClearButton.Height := 20;\r\n ClearButton.Width :=\r\n TCustomControlAccessProtected(HistoryPanel).Canvas.TextWidth(Messages.HistoryClearButton) +\r\n 5;\r\n ButtonLeft := ClearButton.Left + ClearButton.Width + 5;\r\n HistoryPanel.Width := ButtonLeft;\r\n OrgHistoryPanelWidth := ButtonLeft;\r\n end\r\n else\r\n HistoryPanel := nil;\r\n\r\n CreateWinControlsOnParent(MainPanel);\r\n\r\n ResizeDialogAfterArrange(nil, MainPanel.Left, MainPanel.Top, MainPanel.Width, MainPanel.Height);\r\nend;\r\n\r\nprocedure TJvParameterList.ResizeDialogAfterArrange(Sender: TObject; nLeft, nTop, nWidth, nHeight: Integer);\r\nbegin\r\n if Assigned(ParameterDialog) then\r\n begin\r\n if (Width <= 0) or (ArrangeSettings.AutoSize in [asWidth, asBoth]) then\r\n if ArrangePanel.Width > TForm(ParameterDialog).ClientWidth then\r\n if ArrangePanel.Width > MaxWidth then\r\n TForm(ParameterDialog).ClientWidth := MaxWidth\r\n else\r\n TForm(ParameterDialog).ClientWidth := ArrangePanel.Width + 5\r\n else\r\n TForm(ParameterDialog).ClientWidth := ArrangePanel.Width + 5;\r\n if Assigned(HistoryPanel) and\r\n (TForm(ParameterDialog).ClientWidth < HistoryPanel.Width) then\r\n TForm(ParameterDialog).ClientWidth := HistoryPanel.Width\r\n else if TForm(ParameterDialog).ClientWidth < ButtonPanel.Width then\r\n TForm(ParameterDialog).ClientWidth := ButtonPanel.Width;\r\n if (Height <= 0) or (ArrangeSettings.AutoSize in [asHeight, asBoth]) then\r\n if ArrangePanel.Height + BottomPanel.Height > TForm(ParameterDialog).ClientHeight then\r\n if ArrangePanel.Height + BottomPanel.Height > MaxHeight then\r\n TForm(ParameterDialog).ClientHeight := MaxHeight + 10\r\n else\r\n TForm(ParameterDialog).ClientHeight := ArrangePanel.Height + BottomPanel.Height + 10\r\n else\r\n TForm(ParameterDialog).ClientHeight := ArrangePanel.Height + BottomPanel.Height + 10;\r\n end;\r\n\r\n if Assigned(HistoryPanel) then\r\n if (OrgButtonPanelWidth + OrgHistoryPanelWidth) > BottomPanel.Width then\r\n begin\r\n ButtonPanel.Align := alBottom;\r\n ButtonPanel.Height := OkButton.Height + 6 + 2;\r\n BottomPanel.Height := ButtonPanel.Height * 2 + 1;\r\n HistoryPanel.Align := alClient;\r\n end\r\n else\r\n begin\r\n ButtonPanel.Align := alRight;\r\n ButtonPanel.Width := OrgButtonPanelWidth;\r\n HistoryPanel.Align := alLeft;\r\n HistoryPanel.Width := OrgHistoryPanelWidth;\r\n BottomPanel.Height := OkButton.Height + 6 + 2;\r\n end;\r\n CheckScrollBoxAutoScroll;\r\nend;\r\n\r\nprocedure TJvParameterList.CheckScrollBoxAutoScroll;\r\nbegin\r\n if not Assigned(ScrollBox) then\r\n Exit;\r\n if not Assigned(ArrangePanel) then\r\n Exit;\r\n RightPanel.Visible := False;\r\n ScrollBox.AutoScroll := False;\r\n if Assigned(ParameterDialog) then\r\n if (ArrangePanel.Width >= (TForm(ParameterDialog).ClientWidth)) or\r\n (ArrangePanel.Height > (TForm(ParameterDialog).ClientHeight - BottomPanel.Height)) then\r\n begin\r\n RightPanel.Visible := True;\r\n TForm(ParameterDialog).ClientWidth := TForm(ParameterDialog).ClientWidth + RightPanel.Width +\r\n 4;\r\n ScrollBox.AutoScroll := True;\r\n end;\r\nend;\r\n\r\nfunction TJvParameterList.ShowParameterDialog: Boolean;\r\nbegin\r\n if Count = 0 then\r\n EJVCLException.CreateRes(@RsENoParametersDefined);\r\n CreateParameterDialog;\r\n try\r\n SetDataToWinControls;\r\n ParameterDialog.ShowModal;\r\n Result := ParameterDialog.ModalResult = mrOk;\r\n if Result then\r\n GetDataFromWinControls;\r\n finally\r\n FreeAndNil(FParameterDialog);\r\n end;\r\nend;\r\n\r\nprocedure TJvParameterList.ShowParameterDialogThread;\r\nbegin\r\n ParameterDialog.ShowModal;\r\nend;\r\n\r\ntype\r\n TAccessThread = class(TThread);\r\n\r\nfunction TJvParameterList.ShowParameterDialog(SynchronizeThread: TThread): Boolean;\r\nbegin\r\n if Count = 0 then\r\n EJVCLException.CreateRes(@RsENoParametersDefined);\r\n CreateParameterDialog;\r\n try\r\n SetDataToWinControls;\r\n if Assigned(SynchronizeThread) then\r\n TAccessThread(SynchronizeThread).Synchronize(ShowParameterDialogThread)\r\n else\r\n ParameterDialog.ShowModal;\r\n Result := ParameterDialog.ModalResult = mrOk;\r\n if Result then\r\n GetDataFromWinControls;\r\n finally\r\n FreeAndNil(FParameterDialog);\r\n end;\r\nend;\r\n\r\nfunction TJvParameterList.GetParentByName(MainParent: TWinControl; const ASearchName: string): TWinControl;\r\nvar\r\n Parameter: TJvBaseParameter;\r\n I: Integer;\r\n J: Integer;\r\nbegin\r\n Result := MainParent;\r\n if (Trim(ASearchName) = '') or not Assigned(MainParent) then\r\n Exit;\r\n for I := 0 to Count - 1 do\r\n if Parameters[I].Visible then\r\n if UpperCase(Parameters[I].SearchName) = UpperCase(Trim(ASearchName)) then\r\n begin\r\n Parameter := Parameters[I];\r\n if Parameter is TJvArrangeParameter then\r\n begin\r\n Result := TJvArrangeParameter(Parameter).ParentControl;\r\n Break;\r\n end;\r\n end\r\n else\r\n if Parameters[I] is TJvPageControlParameter then\r\n for J := 0 to TJvPageControlParameter(Parameters[I]).Pages.Count - 1 do\r\n if Uppercase(Parameters[I].SearchName + '.' + TJvPageControlParameter(Parameters[I]).Pages[J]) = UpperCase(Trim(ASearchName)) then\r\n begin\r\n Result := TJvPageControlParameter(Parameters[I]).PageWinControl(J);\r\n break;\r\n end\r\nend;\r\n\r\nprocedure TJvParameterList.HistoryLoadClick(Sender: TObject);\r\nbegin\r\n ParameterListSelectList.RestoreParameterList(Messages.HistoryLoadCaption);\r\nend;\r\n\r\nprocedure TJvParameterList.HistorySaveClick(Sender: TObject);\r\nbegin\r\n ParameterListSelectList.SaveParameterList(Messages.HistorySaveCaption);\r\nend;\r\n\r\nprocedure TJvParameterList.HistoryClearClick(Sender: TObject);\r\nbegin\r\n ParameterListSelectList.ManageSelectList(Messages.HistoryClearCaption);\r\nend;\r\n\r\nprocedure TJvParameterList.DialogShow(Sender: TObject);\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := 0 to Count - 1 do\r\n if Parameters[I].Visible then\r\n if Assigned(Parameters[I].WinControl) then\r\n if not Parameters[i].ReadOnly and\r\n Parameters[I].WinControl.CanFocus then\r\n begin\r\n Parameters[I].WinControl.SetFocus;\r\n Break;\r\n end;\r\nend;\r\n\r\nfunction TJvParameterList.GetEnableDisableReasonState(ADisableReasons: TJvParameterListEnableDisableReasonList;\r\n AEnableReasons: TJvParameterListEnableDisableReasonList): Integer;\r\nvar\r\n J: Integer;\r\n IEnable: Integer;\r\n Reason: TJvParameterListEnableDisableReason;\r\n SearchParameter: TJvBaseParameter;\r\n Data: Variant;\r\nbegin\r\n IEnable := 0;\r\n if AEnableReasons.Count > 0 then\r\n begin\r\n for J := 0 to AEnableReasons.Count - 1 do\r\n begin\r\n Reason := TJvParameterListEnableDisableReason(AEnableReasons.Objects[J]);\r\n if not Assigned(Reason) then\r\n Continue;\r\n if VarIsNullEmpty(Reason.AsVariant) then\r\n Continue;\r\n SearchParameter := ParameterByName(Reason.RemoteParameterName);\r\n if not Assigned(SearchParameter) then\r\n Continue;\r\n if not Assigned(SearchParameter.WinControl) then\r\n Continue;\r\n Data := SearchParameter.GetWinControlData;\r\n if VarIsEmpty(Data) and Reason.IsEmpty and (IEnable <> -1) then\r\n IEnable := 1;\r\n if (not VarIsEmpty(Data)) and Reason.IsNotEmpty and (IEnable <> -1) then\r\n IEnable := 1;\r\n try\r\n if (VarCompareValue(Reason.AsVariant, Data) = vrEqual) and (IEnable <> -1) then\r\n IEnable := 1;\r\n except\r\n end;\r\n end;\r\n if IEnable = 0 then\r\n IEnable := -1;\r\n end;\r\n if ADisableReasons.Count > 0 then\r\n begin\r\n for J := 0 to ADisableReasons.Count - 1 do\r\n begin\r\n Reason := TJvParameterListEnableDisableReason(ADisableReasons.Objects[J]);\r\n if not Assigned(Reason) then\r\n Continue;\r\n if VarIsNullEmpty(Reason.AsVariant) then\r\n Continue;\r\n SearchParameter := ParameterByName(Reason.RemoteParameterName);\r\n if not Assigned(SearchParameter) then\r\n Continue;\r\n if not Assigned(SearchParameter.WinControl) then\r\n Continue;\r\n Data := SearchParameter.GetWinControlData;\r\n if VarIsNullEmptyBlank(Data) and Reason.IsEmpty then\r\n IEnable := -1;\r\n if not VarIsNullEmptyBlank(Data) and Reason.IsNotEmpty then\r\n IEnable := -1;\r\n try\r\n if VarCompareValue(Reason.AsVariant, Data) = vrEqual then\r\n IEnable := -1;\r\n except\r\n end;\r\n end;\r\n if IEnable = 0 then\r\n IEnable := 1;\r\n end;\r\n Result := IEnable;\r\nend;\r\n\r\nprocedure TJvParameterList.HandleEnableDisable;\r\nvar\r\n I: Integer;\r\n Parameter: TJvBaseParameter;\r\n IEnable: Integer;\r\nbegin\r\n for I := 0 to Count - 1 do\r\n if Assigned(ParameterByIndex(I).WinControl) then\r\n begin\r\n Parameter := ParameterByIndex(I);\r\n IEnable := GetEnableDisableReasonState(Parameter.DisableReasons, Parameter.EnableReasons);\r\n case IEnable of\r\n -1:\r\n Parameter.Enabled := False;\r\n 1:\r\n Parameter.Enabled := True;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvParameterList.CreateWinControlsOnParent(ParameterParent: TWinControl);\r\nbegin\r\n FreeAndNil(ScrollBox);\r\n ScrollBox := TScrollBox.Create(Self);\r\n ScrollBox.Parent := ParameterParent;\r\n ScrollBox.AutoScroll := False;\r\n ScrollBox.BorderStyle := bsNone;\r\n {$IFDEF COMPILER10_UP}\r\n ScrollBox.ParentBackground := True;\r\n {$ENDIF COMPILER10_UP}\r\n ScrollBox.BevelInner := bvNone;\r\n ScrollBox.BevelOuter := bvNone;\r\n ScrollBox.Align := alClient;\r\n ScrollBox.Width := ParameterParent.Width;\r\n RightPanel := TJvPanel.Create(Self);\r\n RightPanel.Parent := ScrollBox;\r\n RightPanel.Align := alRight;\r\n RightPanel.BorderStyle := bsNone;\r\n RightPanel.BevelInner := bvNone;\r\n RightPanel.BevelOuter := bvNone;\r\n RightPanel.Width := 22; // asn: need to check this\r\n RightPanel.Visible := False;\r\n FreeAndNil(ArrangePanel);\r\n ArrangePanel := TJvPanel.Create(Self);\r\n ArrangePanel.Parent := ScrollBox;\r\n ArrangePanel.Name := 'MainArrangePanel';\r\n ArrangePanel.Align := alNone;\r\n ArrangePanel.BorderStyle := bsNone;\r\n ArrangePanel.BevelInner := bvNone;\r\n ArrangePanel.BevelOuter := bvNone;\r\n ArrangePanel.Caption := '';\r\n ArrangePanel.Left := 0;\r\n ArrangePanel.Top := 0;\r\n ArrangePanel.OnResizeParent := ResizeDialogAfterArrange;\r\n ArrangePanel.ArrangeSettings := ArrangeSettings;\r\n case ArrangePanel.ArrangeSettings.AutoSize of\r\n asNone:\r\n ArrangePanel.ArrangeSettings.AutoSize := asHeight;\r\n asWidth:\r\n ArrangePanel.ArrangeSettings.AutoSize := asBoth;\r\n end;\r\n if (Width > 0) and (ArrangePanel.ArrangeSettings.AutoSize = asHeight) then\r\n ArrangePanel.Width := ScrollBox.Width - RightPanel.Width;\r\n if MaxWidth > 0 then\r\n ArrangePanel.ArrangeSettings.MaxWidth := MaxWidth - RightPanel.Width - 2;\r\n CreateWinControlsOnWinControl(ArrangePanel);\r\nend;\r\n\r\nprocedure TJvParameterList.CreateWinControlsOnWinControl(ParameterParent: TWinControl);\r\nvar\r\n I: Integer;\r\n BeforeAfterParameterNames : TStringList;\r\nbegin\r\n BeforeAfterParameterNames := TStringList.Create;\r\n BeforeAfterParameterNames.Sorted := True;\r\n BeforeAfterParameterNames.Duplicates := dupError;\r\n try\r\n for I := 0 to Count - 1 do\r\n if (Parameters[I] is TJvBasePanelEditParameter) then\r\n begin\r\n try\r\n if TJvBasePanelEditParameter(Parameters[I]).BeforeParameterName <> '' then\r\n BeforeAfterParameterNames.Add(TJvBasePanelEditParameter(Parameters[I]).BeforeParameterName);\r\n except\r\n on e:exception do\r\n raise Exception.CreateResFmt(@RsECreateWinControlsOnWinControlDuplicateBeforeAfterNotAllowed, ['BeforeParameterName', TJvBasePanelEditParameter(Parameters[I]).BeforeParameterName]);\r\n end;\r\n try\r\n if TJvBasePanelEditParameter(Parameters[I]).AfterParameterName <> '' then\r\n BeforeAfterParameterNames.Add(TJvBasePanelEditParameter(Parameters[I]).AfterParameterName);\r\n except\r\n on e:exception do\r\n raise Exception.CreateResFmt(@RsECreateWinControlsOnWinControlDuplicateBeforeAfterNotAllowed, ['AfterParameterName', TJvBasePanelEditParameter(Parameters[I]).AfterParameterName]);\r\n end;\r\n end;\r\n if ParameterParent is TJvCustomArrangePanel then\r\n TJvCustomArrangePanel(ParameterParent).DisableArrange;\r\n for I := 0 to Count - 1 do\r\n if (BeforeAfterParameterNames.IndexOf(Parameters[I].SearchName) < 0)then\r\n begin\r\n Parameters[I].CreateWinControlOnParent(\r\n GetParentByName(ParameterParent, Parameters[I].ParentParameterName));\r\n if (Parameters[I] is TJvArrangeParameter) then\r\n TJvArrangeParameter(Parameters[I]).DisableArrange;\r\n end;\r\n\r\n // Splitted in a Separate Loop because the order could be changed when Before/AfterParameterName is Used\r\n for I := 0 to Count - 1 do\r\n if Assigned(Parameters[I].WinControl) then\r\n Parameters[I].WinControlData := Parameters[I].AsVariant;\r\n\r\n for I := 0 to Count - 1 do\r\n if (Parameters[I] is TJvArrangeParameter) and Assigned(Parameters[I].WinControl) then\r\n begin\r\n TJvArrangeParameter(Parameters[I]).EnableArrange;\r\n TJvArrangeParameter(Parameters[I]).ArrangeControls;\r\n end;\r\n HandleEnableDisable;\r\n HandleShowValidState;\r\n finally\r\n if ParameterParent is TJvCustomArrangePanel then\r\n TJvCustomArrangePanel(ParameterParent).EnableArrange;\r\n BeforeAfterParameterNames.Free;\r\n end;\r\n if ParameterParent is TJvCustomArrangePanel then\r\n TJvCustomArrangePanel(ParameterParent).ArrangeControls;\r\nend;\r\n\r\n\r\n\r\nprocedure TJvParameterList.DestroyWinControls;\r\nbegin\r\n FreeAndNil(ArrangePanel);\r\n FreeAndNil(ScrollBox);\r\nend;\r\n\r\nprocedure TJvParameterList.GetDataFromWinControls;\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := 0 to Count - 1 do\r\n Parameters[I].GetData;\r\nend;\r\n\r\nprocedure TJvParameterList.SetDataToWinControls;\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := 0 to Count - 1 do\r\n Parameters[I].SetData;\r\nend;\r\n\r\nfunction TJvParameterList.ValidateDataAtWinControls: Boolean;\r\nvar\r\n I: Integer;\r\n V: Variant;\r\n B: Boolean;\r\nbegin\r\n Result := False;\r\n for I := 0 to Count - 1 do\r\n if Parameters[I].Visible and Parameters[I].Enabled then\r\n begin\r\n V := Parameters[I].WinControlData;\r\n B := Parameters[I].Validate(V);\r\n Parameters[I].WinControlData := V;\r\n if not B then\r\n begin\r\n if Assigned(Parameters[I].WinControl) then\r\n Parameters[I].WinControl.SetFocus;\r\n Exit;\r\n end;\r\n end;\r\n Result := True;\r\nend;\r\n\r\nfunction TJvParameterList.GetCount: Integer;\r\nbegin\r\n Result := IntParameterList.Count;\r\nend;\r\n\r\nfunction TJvParameterList.AddObject(const S: string; AObject: TObject): Integer;\r\nbegin\r\n if not (AObject is TJvBaseParameter) then\r\n raise EJVCLException.CreateRes(@RsEAddObjectWrongObjectType);\r\n if TJvBaseParameter(AObject).SearchName = '' then\r\n raise EJVCLException.CreateRes(@RsEAddObjectSearchNameNotDefined);\r\n if IntParameterList.IndexOf(S) >= 0 then\r\n raise Exception.CreateResFmt(@RsEAddObjectDuplicateSearchNamesNotAllowed, [S]);\r\n TJvBaseParameter(AObject).ParameterList := Self;\r\n Result := IntParameterList.AddObject(S, AObject);\r\nend;\r\n\r\nprocedure TJvParameterList.AssignValues(iSourceList: TJvParameterList);\r\nvar\r\n i: Integer;\r\n SourceParam : TJvBaseParameter;\r\nbegin\r\n if not assigned(iSourceList) then\r\n Exit;\r\n for i := 0 to Count - 1 do\r\n begin\r\n SourceParam := iSourceList.ParameterByName(Parameters[i].SearchName);\r\n if Assigned(SourceParam) then\r\n Parameters[i].AsVariant := SourceParam.AsVariant\r\n else\r\n Parameters[i].AsVariant := null;\r\n end;\r\nend;\r\n\r\nprocedure TJvParameterList.AssignValuesTo(iDestinationList: TJvParameterList);\r\nbegin\r\n if not assigned(iDestinationList) then\r\n Exit;\r\n iDestinationList.AssignValues(Self);\r\nend;\r\n\r\nprocedure TJvParameterList.SetArrangeSettings(Value: TJvArrangeSettings);\r\nbegin\r\n FArrangeSettings.Assign(Value);\r\n if Assigned(ArrangePanel) then\r\n ArrangePanel.ArrangeSettings := ArrangeSettings;\r\nend;\r\n\r\nprocedure TJvParameterList.SetParameters(Index: Integer; const Value: TJvBaseParameter);\r\nbegin\r\n if (Index >= 0) and (Index < IntParameterList.Count) then\r\n IntParameterList.Objects[Index] := Value;\r\nend;\r\n\r\nfunction TJvParameterList.GetParameters(Index: Integer): TJvBaseParameter;\r\nbegin\r\n if (Index >= 0) and (Index < IntParameterList.Count) then\r\n Result := TJvBaseParameter(IntParameterList.Objects[Index])\r\n else\r\n Result := nil;\r\nend;\r\n\r\nfunction TJvParameterList.GetCurrentWidth: Integer;\r\nbegin\r\n if Width > 0 then\r\n Result := Width\r\n else if Assigned(ArrangePanel) then\r\n if ArrangePanel.Align in [alTop, alBottom, alClient] then\r\n Result := ArrangePanel.ArrangeWidth\r\n else\r\n Result := ArrangePanel.Width\r\n else\r\n Result := 0;\r\n if Result > MaxWidth then\r\n Result := MaxWidth;\r\nend;\r\n\r\nfunction TJvParameterList.GetCurrentHeight: Integer;\r\nbegin\r\n if Height > 0 then\r\n Result := Height\r\n else if Assigned(ArrangePanel) then\r\n begin\r\n if ArrangePanel.Align in [alLeft, alRight, alClient] then\r\n Result := ArrangePanel.ArrangeHeight\r\n else\r\n Result := ArrangePanel.Height;\r\n end\r\n else\r\n Result := 0;\r\n if Result > MaxHeight then\r\n Result := MaxHeight;\r\nend;\r\n\r\nprocedure TJvParameterList.Clear;\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := 0 to IntParameterList.Count - 1 do\r\n IntParameterList.Objects[I].Free;\r\n IntParameterList.Clear;\r\nend;\r\n\r\nfunction TJvParameterList.Clone(AOwner: TComponent): TJvParameterList;\r\nvar\r\n i: Integer;\r\n List : TJvParameterList;\r\nbegin\r\n List := TJvParameterListClass(ClassType).Create(AOwner);\r\n List.Assign(Self);\r\n while List.IntParameterList.Count > 0 do\r\n List.IntParameterList.Delete(0);\r\n for i := 0 to Count - 1 do\r\n List.AddParameter(Parameters[i].Clone(List));\r\n Result := List;\r\nend;\r\n\r\nfunction TJvParameterList.GetVisibleCount: Integer;\r\nvar\r\n i: Integer;\r\nbegin\r\n Result := 0;\r\n for i := 0 to Count - 1 do\r\n if Parameters[i].Visible then\r\n Inc(Result);\r\nend;\r\n\r\ntype\r\n TAccessControl = class(TControl);\r\n\r\nprocedure TJvParameterList.HandleShowValidState;\r\nvar\r\n I: Integer;\r\n Parameter: TJvBaseParameter;\r\n Control : TControl;\r\n Valid: Boolean;\r\n ParValid: Boolean;\r\n IEnable: Integer;\r\n\r\n procedure SetControlFont(AControl: TControl; AValid: Boolean);\r\n begin\r\n if Assigned(AControl) then\r\n begin\r\n if AValid then\r\n TAccessControl(AControl).Font.Style := tAccessControl(AControl).Font.Style - [fsItalic]\r\n else\r\n TAccessControl(AControl).Font.Style := tAccessControl(AControl).Font.Style + [fsItalic];\r\n end;\r\n end;\r\n\r\nbegin\r\n Valid := True;\r\n if ShowParameterValidState then\r\n for I := 0 to Count - 1 do\r\n begin\r\n Parameter := ParameterByIndex(I);\r\n if Parameter is TJvBasePanelEditParameter then\r\n if Assigned(TJvBasePanelEditParameter(Parameter).LabelControl) then\r\n Control := TJvBasePanelEditParameter(Parameter).LabelControl\r\n else\r\n Control := TJvBasePanelEditParameter(Parameter).WinControl\r\n else if Parameter is TJvCheckBoxParameter then\r\n Control := TJvCheckBoxParameter(Parameter).WinControl\r\n else\r\n Control := nil;\r\n ParValid := Parameter.IsValid(Parameter.GetWinControlData);\r\n Valid := Valid And ParValid;\r\n SetControlFont (Control, ParValid);\r\n end;\r\n if Assigned(OkButton) then\r\n begin\r\n IEnable := GetEnableDisableReasonState(OkButtonDisableReasons, OkButtonEnableReasons);\r\n if IEnable = -1 then\r\n OkButton.Enabled := False\r\n else\r\n OkButton.Enabled := Valid;\r\n end;\r\nend;\r\n\r\nfunction TJvParameterList.IndexOfParameter(AParameter: TJvBaseParameter): Integer;\r\nbegin\r\n Result := IntParameterList.IndexOfObject(AParameter);\r\nend;\r\n\r\n//=== { TJvParameterListPropertyStore } ======================================\r\n\r\nprocedure TJvParameterListPropertyStore.LoadData;\r\nvar\r\n I: Integer;\r\nbegin\r\n if Assigned(AppStorage) And Assigned(ParameterList) then\r\n begin\r\n AppStorage.BeginUpdate;\r\n try\r\n for I := 0 to ParameterList.Count - 1 do\r\n if not (ParameterList.Parameters[I] is TJvNoDataParameter) then\r\n if ParameterList.Parameters[I].StoreValueToAppStorage then\r\n begin\r\n if ParameterList.Parameters[I].StoreValueCrypted then\r\n AppStorage.EnablePropertyValueCrypt;\r\n if (ParameterList.Parameters[I] is TJvListParameter)\r\n and (TJvListParameter(ParameterList.Parameters[I]).VariantAsItemIndex) then\r\n TJvListParameter(ParameterList.Parameters[I]).ItemIndex :=\r\n AppStorage.ReadInteger(AppStorage.ConcatPaths([AppStoragePath,\r\n ParameterList.Parameters[I].SearchName]),\r\n TJvListParameter(ParameterList.Parameters[I]).ItemIndex)\r\n else\r\n ParameterList.Parameters[I].AsString := AppStorage.ReadString(AppStorage.ConcatPaths([AppStoragePath,\r\n ParameterList.Parameters[I].SearchName]),\r\n ParameterList.Parameters[I].AsString);\r\n if ParameterList.Parameters[I].StoreValueCrypted then\r\n AppStorage.DisablePropertyValueCrypt;\r\n end;\r\n finally\r\n AppStorage.EndUpdate;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvParameterListPropertyStore.Notification(AComponent: TComponent; Operation: TOperation);\r\nbegin\r\n inherited Notification(AComponent, Operation);\r\n if (Operation = opRemove) and (AComponent = FParameterList) then\r\n FParameterList := nil;\r\nend;\r\n\r\nprocedure TJvParameterListPropertyStore.SetParameterList(const Value: TJvParameterList);\r\nbegin\r\n ReplaceComponentReference(Self, Value, TComponent(FParameterList));\r\nend;\r\n\r\nprocedure TJvParameterListPropertyStore.StoreData;\r\nvar\r\n I: Integer;\r\nbegin\r\n if Assigned(AppStorage) And Assigned(ParameterList) then\r\n begin\r\n AppStorage.BeginUpdate;\r\n try\r\n for I := 0 to ParameterList.Count - 1 do\r\n if not (ParameterList.Parameters[I] is TJvNoDataParameter) then\r\n if ParameterList.Parameters[I].StoreValueToAppStorage then\r\n begin\r\n if ParameterList.Parameters[I].StoreValueCrypted then\r\n AppStorage.EnablePropertyValueCrypt;\r\n if (ParameterList.Parameters[I] is TJvListParameter)\r\n and (TJvListParameter(ParameterList.Parameters[I]).VariantAsItemIndex) then\r\n AppStorage.WriteInteger(AppStorage.ConcatPaths([AppStoragePath, ParameterList.Parameters[I].SearchName]),\r\n TJvListParameter(ParameterList.Parameters[I]).ItemIndex)\r\n else\r\n AppStorage.WriteString(AppStorage.ConcatPaths([AppStoragePath, ParameterList.Parameters[I].SearchName]),\r\n ParameterList.Parameters[I].AsString);\r\n if ParameterList.Parameters[I].StoreValueCrypted then\r\n AppStorage.DisablePropertyValueCrypt;\r\n end;\r\n finally\r\n AppStorage.EndUpdate;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJvParameterListSelectList.CreateSelectListDialogInstance(AOwner: TComponent;AOperation:\r\n TJvAppStorageSelectListOperation; ACaption: string = ''): TJvBaseAppStorageSelectListDialogInstance;\r\nbegin\r\n Result := inherited CreateSelectListDialogInstance(AOwner, AOperation, ACaption);\r\n if not Assigned(SelectListDialog) then\r\n Result.DynControlEngine := FParameterList.DynControlEngine;\r\nend;\r\n\r\nprocedure TJvParameterListSelectList.SetParameterList(Value: TJvParameterList);\r\nbegin\r\n ReplaceComponentReference(Self, Value, TComponent(FParameterList));\r\nend;\r\n\r\nfunction TJvParameterListSelectList.GetAppStorage: TJvCustomAppStorage;\r\nbegin\r\n if Assigned(FParameterList) then\r\n Result := FParameterList.AppStorage\r\n else\r\n Result := nil;\r\nend;\r\n\r\nfunction TJvParameterListSelectList.GetStoragePath: string;\r\nbegin\r\n if Assigned(AppStorage) then\r\n Result := AppStorage.ConcatPaths([ParameterList.AppStoragePath, SelectPath])\r\n else\r\n Result := ParameterList.AppStoragePath + PathDelim + SelectPath;\r\nend;\r\n\r\nprocedure TJvParameterListSelectList.SetAppStorage(Value: TJvCustomAppStorage);\r\nbegin\r\n if Assigned(FParameterList) then\r\n FParameterList.AppStorage := Value;\r\nend;\r\n\r\nprocedure TJvParameterListSelectList.Notification(AComponent: TComponent; Operation: TOperation);\r\nbegin\r\n inherited Notification(AComponent, Operation);\r\n if (Operation = opRemove) and (AComponent = FParameterList) then\r\n FParameterList := nil;\r\nend;\r\n\r\nprocedure TJvParameterListSelectList.RestoreParameterList(const ACaption: string = '');\r\nvar\r\n SelectPath: string;\r\nbegin\r\n if not Assigned(ParameterList) then\r\n Exit;\r\n SelectPath := GetSelectListPath(sloStore, ACaption);\r\n if SelectPath <> '' then\r\n begin\r\n ParameterList.LoadDataFrom(SelectPath);\r\n ParameterList.SetDataToWinControls;\r\n end;\r\nend;\r\n\r\nprocedure TJvParameterListSelectList.SaveParameterList(const ACaption: string = '');\r\nvar\r\n SelectPath: string;\r\nbegin\r\n if not Assigned(ParameterList) then\r\n Exit;\r\n SelectPath := GetSelectListPath(sloStore, ACaption);\r\n if SelectPath <> '' then\r\n begin\r\n ParameterList.GetDataFromWinControls;\r\n ParameterList.StoreDataTo(SelectPath);\r\n end;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n {$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n\r\n" }, { "path": "External/Jedi/Jvcl/run/JvParameterListParameter.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Initial Developer of the Original Code is Jens Fudickar [jens dott fudickar att oratool dott de]\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\nJens Fudickar [jens dott fudickar att oratool dott de]\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvParameterListParameter.pas 13415 2012-09-10 09:51:54Z obones $\r\n\r\nunit JvParameterListParameter;\r\n\r\n{$I jvcl.inc}\r\n{$I crossplatform.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Classes, SysUtils, StdCtrls, ExtCtrls, Graphics, Forms,\r\n Controls, FileCtrl, Dialogs, ComCtrls, Buttons, Variants,\r\n {$IFDEF HAS_UNIT_SYSTEM_UITYPES}\r\n System.UITypes,\r\n {$ENDIF HAS_UNIT_SYSTEM_UITYPES}\r\n JvPanel, JvParameterList, JvDynControlEngine, JvDSADialogs,\r\n JvDynControlEngineIntf, ActnList;\r\n\r\ntype\r\n TJvNoDataParameter = class(TJvBaseParameter)\r\n protected\r\n function IsDataValid(const AData: Variant; var vMsg: String): Boolean; override;\r\n property AsString;\r\n property AsDouble;\r\n property AsInteger;\r\n property AsBoolean;\r\n property AsDate;\r\n property Required;\r\n property StoreValueToAppStorage;\r\n property ReadOnly;\r\n public\r\n constructor Create(AParameterList: TJvParameterList); override;\r\n end;\r\n\r\n TJvButtonParameter = class(TJvNoDataParameter)\r\n private\r\n FAction: TCustomAction;\r\n FGlyph: TBitmap;\r\n FNumGlyphs: Integer;\r\n FLayout: TButtonLayout;\r\n FOnClick: TJvParameterListEvent;\r\n protected\r\n procedure SetGlyph(Value: TBitmap);\r\n function GetParameterNameExt: string; override;\r\n procedure Click(Sender: TObject);\r\n procedure SetWinControlProperties; override;\r\n public\r\n constructor Create(AParameterList: TJvParameterList); override;\r\n destructor Destroy; override;\r\n procedure Assign(Source: TPersistent); override;\r\n procedure CreateWinControlOnParent(ParameterParent: TWinControl); override;\r\n published\r\n property Action: TCustomAction read FAction write FAction;\r\n property Glyph: TBitmap read FGlyph write SetGlyph;\r\n property NumGlyphs: Integer read FNumGlyphs write FNumGlyphs;\r\n property Layout: TButtonLayout read FLayout write FLayout;\r\n property OnClick: TJvParameterListEvent read FOnClick write FOnClick;\r\n end;\r\n\r\n TJvRadioButtonParameter = class(TJvNoDataParameter)\r\n private\r\n FOnClick: TJvParameterListEvent;\r\n protected\r\n function GetParameterNameExt: string; override;\r\n procedure Click(Sender: TObject);\r\n procedure SetWinControlProperties; override;\r\n public\r\n procedure Assign(Source: TPersistent); override;\r\n procedure CreateWinControlOnParent(ParameterParent: TWinControl); override;\r\n published\r\n property OnClick: TJvParameterListEvent read FOnClick write FOnClick;\r\n end;\r\n\r\n TJvParameterLabelArrangeMode = (lamBefore, lamAbove, lamGroupBox, lamNone);\r\n\r\n TJvBasePanelEditParameter = class(TJvBaseParameter)\r\n private\r\n FAfterParameterControl: TControl;\r\n FAfterParameterName: string;\r\n FArrangeLabelAndWinControlDisabled: Boolean;\r\n FBeforeParameterControl: TControl;\r\n FBeforeParameterName: string;\r\n FEditWidth: Integer;\r\n FFrameControl: TWinControl;\r\n FLabelArrangeMode: TJvParameterLabelArrangeMode;\r\n FLabelControl: TControl;\r\n FLabelWidth: Integer;\r\n FOrgWinControlHeight: Integer;\r\n FOrgWinControlWidth: Integer;\r\n procedure ArrangeLabelAndWinControlOnPanelAbove;\r\n procedure ArrangeLabelAndWinControlOnPanelBefore;\r\n procedure ArrangeLabelAndWinControlOnPanelGroupBox;\r\n procedure ArrangeLabelAndWinControlOnPanelNone;\r\n procedure ArrangeWinControlsonPanel(iLeft, iTop: Integer; var iWidth: Integer;\r\n iHeight: Integer);\r\n protected\r\n procedure ArrangeLabelAndWinControlOnPanel; virtual;\r\n procedure CreateAfterParameterControl(AParameterParent: TWinControl); virtual;\r\n procedure CreateBeforeParameterControl(AParameterParent: TWinControl); virtual;\r\n procedure CreateFramePanel(AParameterParent: TWinControl); virtual;\r\n procedure CreateLabelControl(AParameterParent: TWinControl); virtual;\r\n procedure CreateWinControl(AParameterParent: TWinControl); virtual; abstract;\r\n function GetLabelWidth: Integer; virtual;\r\n procedure Notification(AComponent: TComponent; Operation: TOperation); override;\r\n procedure SetLabelWidth(Value: Integer); virtual;\r\n procedure SetWinControlProperties; override;\r\n public\r\n constructor Create(AParameterList: TJvParameterList); override;\r\n procedure Assign(Source: TPersistent); override;\r\n procedure CreateWinControlOnParent(ParameterParent: TWinControl); override;\r\n procedure SetEnabled(Value: Boolean); override;\r\n procedure SetHeight(Value: Integer); override;\r\n procedure SetLabelArrangeMode(Value: TJvParameterLabelArrangeMode); virtual;\r\n procedure SetTabOrder(Value: Integer); override;\r\n procedure SetVisible(Value: Boolean); override;\r\n procedure SetWidth(Value: Integer); override;\r\n property FrameControl: TWinControl read FFrameControl;\r\n property LabelControl: TControl read FLabelControl;\r\n published\r\n /// The searchname of the afterparameter.\r\n /// The afterparameter will positioned behind the edit control.\r\n property AfterParameterName: string read FAfterParameterName write FAfterParameterName;\r\n /// The searchname of the beforeparameter.\r\n /// The beforeparameter will positioned before the edit control.\r\n property BeforeParameterName: string read FBeforeParameterName write FBeforeParameterName;\r\n /// Width of the edit control\r\n property EditWidth: Integer read FEditWidth write FEditWidth;\r\n /// Mode how the label and the edit control will be arranged :\r\n /// - lamBefire : The label is before the edit control\r\n /// - lamAbove : The label is positioned on top of the edit control\r\n /// - lamGroupBox : A Groupbox is created arround the edit control\r\n /// - lamNone : No Label is shown\r\n property LabelArrangeMode: TJvParameterLabelArrangeMode read FLabelArrangeMode\r\n write SetLabelArrangeMode;\r\n /// Width of the label, only valid when LabelArrangeMode = lamBefore\r\n property LabelWidth: Integer read GetLabelWidth write SetLabelWidth;\r\n end;\r\n\r\n TJvArrangeParameter = class(TJvNoDataParameter)\r\n private\r\n FArrangeSettings: TJvArrangeSettings;\r\n FParentControl: TWinControl;\r\n procedure SetParentControl(const Value: TWinControl);\r\n protected\r\n procedure Notification(AComponent: TComponent; Operation: TOperation); override;\r\n procedure SetArrangeSettings(Value: TJvArrangeSettings);\r\n function GetParentControl: TWinControl;\r\n public\r\n constructor Create(AParameterList: TJvParameterList); override;\r\n destructor Destroy; override;\r\n procedure ArrangeControls; virtual;\r\n procedure DisableArrange; virtual;\r\n procedure EnableArrange; virtual;\r\n property ParentControl: TWinControl read GetParentControl write SetParentControl;\r\n published\r\n property ArrangeSettings: TJvArrangeSettings read FArrangeSettings write SetArrangeSettings;\r\n property Color;\r\n end;\r\n\r\n TJvPanelParameter = class(TJvArrangeParameter)\r\n private\r\n FBevelInner: TPanelBevel;\r\n FBevelOuter: TPanelBevel;\r\n FBevelWidth: Integer;\r\n FBorderStyle: TBorderStyle;\r\n FBorderWidth: Integer;\r\n protected\r\n function GetParameterNameExt: string; override;\r\n procedure SetWinControlProperties; override;\r\n public\r\n constructor Create(AParameterList: TJvParameterList); override;\r\n procedure Assign(Source: TPersistent); override;\r\n procedure CreateWinControlOnParent(ParameterParent: TWinControl); override;\r\n published\r\n property BevelInner: TPanelBevel read FBevelInner write FBevelInner;\r\n property BevelOuter: TPanelBevel read FBevelOuter write FBevelOuter;\r\n property BevelWidth: Integer read FBevelWidth write FBevelWidth;\r\n property BorderStyle: TBorderStyle read FBorderStyle write FBorderStyle;\r\n property BorderWidth: Integer read FBorderWidth write FBorderWidth;\r\n end;\r\n\r\n TJvGroupBoxParameter = class(TJvArrangeParameter)\r\n protected\r\n function GetParameterNameExt: string; override;\r\n procedure ReArrangeGroupbox(Sender: TObject; nLeft, nTop, nWidth, nHeight: Integer);\r\n procedure SetWinControlProperties; override;\r\n public\r\n constructor Create(AParameterList: TJvParameterList); override;\r\n procedure CreateWinControlOnParent(ParameterParent: TWinControl); override;\r\n end;\r\n\r\n TJvImageParameter = class(TJvBasePanelEditParameter)\r\n private\r\n FAutoSize: Boolean;\r\n FCenter: Boolean;\r\n FIncrementalDisplay: Boolean;\r\n FTransparent: Boolean;\r\n FStretch: Boolean;\r\n FPicture: TPicture;\r\n protected\r\n procedure SetPicture(Value: TPicture);\r\n procedure SetAutoSize(Value: Boolean); virtual;\r\n function GetParameterNameExt: string; override;\r\n procedure CreateWinControl(AParameterParent: TWinControl); override;\r\n public\r\n constructor Create(AParameterList: TJvParameterList); override;\r\n destructor Destroy; override;\r\n procedure Assign(Source: TPersistent); override;\r\n published\r\n // property AutoSize: Boolean read FAutoSize write SetAutoSize;\r\n property Center: Boolean read FCenter write FCenter;\r\n property IncrementalDisplay: Boolean read FIncrementalDisplay write FIncrementalDisplay;\r\n property Transparent: Boolean read FTransparent write FTransparent;\r\n property Stretch: Boolean read FStretch write FStretch;\r\n property Picture: TPicture read FPicture write SetPicture;\r\n end;\r\n\r\n TJvLabelParameter = class(TJvNoDataParameter)\r\n public\r\n procedure CreateWinControlOnParent(ParameterParent: TWinControl); override;\r\n end;\r\n\r\n TJvCheckBoxParameter = class(TJvBaseParameter)\r\n private\r\n FOnChange: TNotifyEvent;\r\n public\r\n procedure Assign(Source: TPersistent); override;\r\n procedure CreateWinControlOnParent(ParameterParent: TWinControl); override;\r\n published\r\n property OnChange: TNotifyEvent read FOnChange write FOnChange;\r\n end;\r\n\r\n TJvEditParameter = class(TJvBasePanelEditParameter)\r\n private\r\n FEditMask: string;\r\n FPasswordChar: Char;\r\n protected\r\n function GetParameterNameExt: string; override;\r\n procedure CreateWinControl(AParameterParent: TWinControl); override;\r\n public\r\n constructor Create(AParameterList: TJvParameterList); override;\r\n procedure Assign(Source: TPersistent); override;\r\n published\r\n property EditMask: string read FEditMask write FEditMask;\r\n property PasswordChar: Char read FPasswordChar write FPasswordChar;\r\n end;\r\n\r\n TJvButtonEditParameter = class(TJvEditParameter)\r\n private\r\n FOnClick: TNotifyEvent;\r\n protected\r\n function GetParameterNameExt: string; override;\r\n procedure CreateWinControl(AParameterParent: TWinControl); override;\r\n public\r\n procedure Assign(Source: TPersistent); override;\r\n published\r\n property OnClick: TNotifyEvent read FOnClick write FOnClick;\r\n end;\r\n\r\n TJvNumberEditorType = (netEdit, netSpin, netCalculate);\r\n\r\n TJvNumberEditParameter = class(TJvEditParameter)\r\n private\r\n FEditorType: TJvNumberEditorType;\r\n public\r\n procedure Assign(Source: TPersistent); override;\r\n published\r\n property EditorType: TJvNumberEditorType read FEditorType write FEditorType;\r\n end;\r\n\r\n TJvIntegerEditParameter = class(TJvNumberEditParameter)\r\n private\r\n FMinValue: Integer;\r\n FMaxValue: Integer;\r\n FIncrement: Integer;\r\n protected\r\n procedure CreateWinControl(AParameterParent: TWinControl); override;\r\n function IsDataValid(const AData: Variant; var vMsg: String): Boolean; override;\r\n procedure SetWinControlProperties; override;\r\n public\r\n constructor Create(AParameterList: TJvParameterList); override;\r\n procedure Assign(Source: TPersistent); override;\r\n published\r\n property Increment: Integer read FIncrement write FIncrement;\r\n property MinValue: Integer read FMinValue write FMinValue;\r\n property MaxValue: Integer read FMaxValue write FMaxValue;\r\n end;\r\n\r\n TJvDoubleEditParameter = class(TJvNumberEditParameter)\r\n private\r\n FMinValue: Double;\r\n FMaxValue: Double;\r\n FIncrement: Integer;\r\n protected\r\n procedure CreateWinControl(AParameterParent: TWinControl); override;\r\n function IsDataValid(const AData: Variant; var vMsg: String): Boolean; override;\r\n procedure SetWinControlProperties; override;\r\n public\r\n constructor Create(AParameterList: TJvParameterList); override;\r\n procedure Assign(Source: TPersistent); override;\r\n published\r\n property Increment: Integer read FIncrement write FIncrement;\r\n property MinValue: Double read FMinValue write FMinValue;\r\n property MaxValue: Double read FMaxValue write FMaxValue;\r\n end;\r\n\r\n TJvFileNameParameter = class(TJvBasePanelEditParameter)\r\n private\r\n FDefaultExt: string;\r\n FFilter: string;\r\n FFilterIndex: Integer;\r\n FInitialDir: string;\r\n FDialogOptions: TOpenOptions;\r\n FDialogTitle: string;\r\n FDialogKind: TJvDynControlFileNameDialogKind;\r\n protected\r\n function GetParameterNameExt: string; override;\r\n procedure CreateWinControl(AParameterParent: TWinControl); override;\r\n function IsDataValid(const AData: Variant; var vMsg: String): Boolean; override;\r\n procedure SetWinControlProperties; override;\r\n public\r\n constructor Create(AParameterList: TJvParameterList); override;\r\n procedure Assign(Source: TPersistent); override;\r\n function Validate(var AData: Variant): Boolean; override;\r\n published\r\n property FileName: string read GetAsString write SetAsString;\r\n property DefaultExt: string read FDefaultExt write FDefaultExt;\r\n property Filter: string read FFilter write FFilter;\r\n property FilterIndex: Integer read FFilterIndex write FFilterIndex;\r\n property InitialDir: string read FInitialDir write FInitialDir;\r\n property DialogOptions: TOpenOptions read FDialogOptions write FDialogOptions;\r\n property DialogTitle: string read FDialogTitle write FDialogTitle;\r\n property DialogKind: TJvDynControlFileNameDialogKind read FDialogKind write FDialogKind;\r\n end;\r\n\r\n TJvDirectoryParameter = class(TJvBasePanelEditParameter)\r\n private\r\n FInitialDir: string;\r\n FDialogTitle: string;\r\n FDialogOptions: TSelectDirOpts;\r\n protected\r\n function GetParameterNameExt: string; override;\r\n procedure CreateWinControl(AParameterParent: TWinControl); override;\r\n function IsDataValid(const AData: Variant; var vMsg: String): Boolean; override;\r\n procedure SetWinControlProperties; override;\r\n public\r\n constructor Create(AParameterList: TJvParameterList); override;\r\n procedure Assign(Source: TPersistent); override;\r\n published\r\n property Directory: string read GetAsString write SetAsString;\r\n property InitialDir: string read FInitialDir write FInitialDir;\r\n property DialogTitle: string read FDialogTitle write FDialogTitle;\r\n property DialogOptions: TSelectDirOpts read FDialogOptions write FDialogOptions;\r\n end;\r\n\r\n TJvListParameter = class(TJvBasePanelEditParameter)\r\n private\r\n FItemList: TStringList;\r\n FItemIndex: Integer;\r\n FSorted: Boolean;\r\n FVariantAsItemIndex: Boolean;\r\n protected\r\n function GetItemList: TStringList; virtual;\r\n procedure SetItemList(Value: TStringList); virtual;\r\n procedure SetItemIndex(Value: Integer); virtual;\r\n procedure SetAsString(const Value: string); override;\r\n function GetAsString: string; override;\r\n procedure SetAsInteger(Value: Integer); override;\r\n function GetAsInteger: Integer; override;\r\n procedure SetAsVariant(Value: Variant); override;\r\n function GetAsVariant: Variant; override;\r\n function GetWinControlData: Variant; override;\r\n procedure SetWinControlData(Value: Variant); override;\r\n procedure SetWinControlProperties; override;\r\n public\r\n constructor Create(AParameterList: TJvParameterList); override;\r\n destructor Destroy; override;\r\n procedure Assign(Source: TPersistent); override;\r\n procedure SearchItemIndex(const Search: string);\r\n published\r\n property ItemList: TStringList read GetItemList write SetItemList;\r\n property ItemIndex: Integer read FItemIndex write SetItemIndex;\r\n property Sorted: Boolean read FSorted write FSorted;\r\n property VariantAsItemIndex: Boolean read FVariantAsItemIndex write FVariantAsItemIndex default False;\r\n end;\r\n\r\n TJvRadioGroupParameter = class(TJvListParameter)\r\n private\r\n FColumns: Integer;\r\n protected\r\n procedure SetWinControlProperties; override;\r\n public\r\n procedure Assign(Source: TPersistent); override;\r\n procedure CreateWinControlOnParent(ParameterParent: TWinControl); override;\r\n procedure CreateWinControl(AParameterParent: TWinControl); override;\r\n published\r\n property Columns: Integer read FColumns write FColumns;\r\n end;\r\n\r\n TJvComboBoxParameterStyle = (cpsListEdit, cpsListFixed);\r\n\r\n TJvComboBoxParameter = class(TJvListParameter)\r\n private\r\n FSorted: Boolean;\r\n FNewEntriesAllowed: Boolean;\r\n protected\r\n function GetParameterNameExt: string; override;\r\n procedure CreateWinControl(AParameterParent: TWinControl); override;\r\n procedure SetWinControlProperties; override;\r\n function GetWinControlData: Variant; override;\r\n procedure SetWinControlData(Value: Variant); override;\r\n public\r\n constructor Create(AParameterList: TJvParameterList); override;\r\n procedure GetData; override;\r\n procedure SetData; override;\r\n procedure Assign(Source: TPersistent); override;\r\n published\r\n property Sorted: Boolean read FSorted write FSorted;\r\n property NewEntriesAllowed: Boolean read FNewEntriesAllowed write FNewEntriesAllowed;\r\n end;\r\n\r\n TJvListBoxParameter = class(TJvListParameter)\r\n protected\r\n function GetParameterNameExt: string; override;\r\n procedure CreateWinControl(AParameterParent: TWinControl); override;\r\n procedure SetWinControlProperties; override;\r\n public\r\n procedure Assign(Source: TPersistent); override;\r\n end;\r\n\r\n TJvCheckListItemDataWrapper = class(TObject)\r\n private\r\n FState: TCheckBoxState;\r\n FItemEnabled: Boolean;\r\n FHeader: Boolean;\r\n procedure SetChecked(Check: Boolean);\r\n function GetChecked: Boolean;\r\n public\r\n property Checked: Boolean read GetChecked write SetChecked;\r\n property State: TCheckBoxState read FState write FState;\r\n property ItemEnabled: Boolean read FItemEnabled write FItemEnabled;\r\n property Header: Boolean read FHeader write FHeader;\r\n end;\r\n\r\n TJvCheckListBoxParameter = class(TJvListParameter)\r\n private\r\n FAllowGrayed: Boolean;\r\n protected\r\n function GetParameterNameExt: string; override;\r\n procedure CreateWinControl(AParameterParent: TWinControl); override;\r\n procedure SetWinControlProperties; override;\r\n function GetItemData(Index: Integer): TJvCheckListItemDataWrapper;\r\n procedure SetItemData(Index: Integer; Value: TJvCheckListItemDataWrapper);\r\n procedure SetItemList(Value: TStringList); override;\r\n public\r\n constructor Create(AParameterList: TJvParameterList); override;\r\n destructor Destroy; override;\r\n procedure Assign(Source: TPersistent); override;\r\n procedure GetData; override;\r\n procedure SetData; override;\r\n procedure AddCheckListBoxItem(const AText: string; AState: TCheckBoxState = cbChecked;\r\n AItemEnabled: Boolean = True; AHeader: Boolean = False);\r\n property ItemData[Index: Integer]: TJvCheckListItemDataWrapper read GetItemData write SetItemData;\r\n published\r\n property AllowGrayed: Boolean read FAllowGrayed write FAllowGrayed;\r\n end;\r\n\r\n TJvTimeParameter = class(TJvBasePanelEditParameter)\r\n private\r\n FFormat: string;\r\n protected\r\n function GetParameterNameExt: string; override;\r\n procedure CreateWinControl(AParameterParent: TWinControl); override;\r\n procedure SetWinControlProperties; override;\r\n public\r\n constructor Create(AParameterList: TJvParameterList); override;\r\n procedure Assign(Source: TPersistent); override;\r\n published\r\n property Format: string read FFormat write FFormat;\r\n end;\r\n\r\n TJvDateTimeParameter = class(TJvBasePanelEditParameter)\r\n private\r\n FFormat: string;\r\n FMaxDate: TDate;\r\n FMinDate: TDate;\r\n protected\r\n function GetParameterNameExt: string; override;\r\n procedure CreateWinControl(AParameterParent: TWinControl); override;\r\n procedure SetWinControlProperties; override;\r\n public\r\n constructor Create(AParameterList: TJvParameterList); override;\r\n procedure Assign(Source: TPersistent); override;\r\n published\r\n property Format: string read FFormat write FFormat;\r\n property MaxDate: TDate read FMaxDate write FMaxDate;\r\n property MinDate: TDate read FMinDate write FMinDate;\r\n end;\r\n\r\n TJvDateParameter = class(TJvBasePanelEditParameter)\r\n private\r\n FFormat: string;\r\n FMaxDate: TDate;\r\n FMinDate: TDate;\r\n protected\r\n function GetParameterNameExt: string; override;\r\n procedure CreateWinControl(AParameterParent: TWinControl); override;\r\n procedure SetWinControlProperties; override;\r\n public\r\n constructor Create(AParameterList: TJvParameterList); override;\r\n procedure Assign(Source: TPersistent); override;\r\n published\r\n property Format: string read FFormat write FFormat;\r\n property MaxDate: TDate read FMaxDate write FMaxDate;\r\n property MinDate: TDate read FMinDate write FMinDate;\r\n end;\r\n\r\n TJvMemoParameter = class(TJvBasePanelEditParameter)\r\n private\r\n FWordWrap: Boolean;\r\n FWantTabs: Boolean;\r\n FWantReturns: Boolean;\r\n FScrollBars: TScrollStyle;\r\n FFontName: string;\r\n procedure SetFontName(const Value: string);\r\n procedure SetScrollBars(const Value: TScrollStyle);\r\n procedure SetWantReturns(const Value: Boolean);\r\n procedure SetWantTabs(const Value: Boolean);\r\n procedure SetWordWrap(const Value: Boolean);\r\n protected\r\n function GetParameterNameExt: string; override;\r\n procedure CreateWinControl(AParameterParent: TWinControl); override;\r\n procedure SetWinControlProperties; override;\r\n public\r\n constructor Create(AParameterList: TJvParameterList); override;\r\n published\r\n property WordWrap: Boolean read FWordWrap write SetWordWrap;\r\n property WantTabs: Boolean read FWantTabs write SetWantTabs;\r\n property WantReturns: Boolean read FWantReturns write SetWantReturns;\r\n property ScrollBars: TScrollStyle read FScrollBars write SetScrollBars;\r\n property FontName: string read FFontName write SetFontName;\r\n end;\r\n\r\n TJvRichEditParameter = class(TJvBasePanelEditParameter)\r\n private\r\n FWordWrap: Boolean;\r\n FWantTabs: Boolean;\r\n FWantReturns: Boolean;\r\n FScrollBars: TScrollStyle;\r\n FFontName: string;\r\n protected\r\n function GetParameterNameExt: string; override;\r\n procedure CreateWinControl(AParameterParent: TWinControl); override;\r\n procedure SetWinControlProperties; override;\r\n public\r\n constructor Create(AParameterList: TJvParameterList); override;\r\n published\r\n property WordWrap: Boolean read FWordWrap write FWordWrap;\r\n property WantTabs: Boolean read FWantTabs write FWantTabs;\r\n property WantReturns: Boolean read FWantReturns write FWantReturns;\r\n property ScrollBars: TScrollStyle read FScrollBars write FScrollBars;\r\n property FontName: string read FFontName write FFontName;\r\n end;\r\n\r\n TJvPageControlParameter = class(TJvArrangeParameter)\r\n private\r\n fHotTrack: Boolean;\r\n fMultiline: Boolean;\r\n fScrollOpposite: Boolean;\r\n fTabIndex: Integer;\r\n fTabPosition: TTabPosition;\r\n FPages: TStringList;\r\n FRaggedRight: Boolean;\r\n protected\r\n function GetParameterNameExt: string; override;\r\n procedure RearrangePageControl(Sender: TObject; nLeft, nTop, nWidth, nHeight:\r\n Integer);\r\n procedure SetPages(Value: TStringList);\r\n procedure SetWinControlProperties; override;\r\n public\r\n constructor Create(AParameterList: TJvParameterList); override;\r\n destructor Destroy; override;\r\n procedure ArrangeControls; override;\r\n procedure Assign(Source: TPersistent); override;\r\n procedure CreateWinControlOnParent(ParameterParent: TWinControl); override;\r\n procedure DisableArrange; override;\r\n procedure EnableArrange; override;\r\n function PageWinControl(Index: Integer): TWinControl;\r\n published\r\n property HotTrack: Boolean read fHotTrack write fHotTrack;\r\n property Multiline: Boolean read fMultiline write fMultiline;\r\n property ScrollOpposite: Boolean read fScrollOpposite write fScrollOpposite;\r\n property TabIndex: Integer read fTabIndex write fTabIndex;\r\n property TabPosition: TTabPosition read fTabPosition write fTabPosition;\r\n property Pages: TStringList read FPages write SetPages;\r\n property RaggedRight: Boolean read FRaggedRight write FRaggedRight;\r\n end;\r\n\r\n TJvCheckComboBoxParameter = class(TJvListParameter)\r\n private\r\n FDelimiter: string;\r\n FSorted: Boolean;\r\n protected\r\n function GetParameterNameExt: string; override;\r\n procedure CreateWinControl(AParameterParent: TWinControl); override;\r\n procedure SetWinControlProperties; override;\r\n function GetWinControlData: Variant; override;\r\n procedure SetWinControlData(Value: Variant); override;\r\n public\r\n constructor Create(AParameterList: TJvParameterList); override;\r\n procedure GetData; override;\r\n procedure SetData; override;\r\n procedure Assign(Source: TPersistent); override;\r\n published\r\n property Delimiter: string read FDelimiter write FDelimiter;\r\n property Sorted: Boolean read FSorted write FSorted;\r\n end;\r\n\r\nfunction DSADialogsMessageDlg(const Msg: string; const DlgType: TMsgDlgType; const Buttons: TMsgDlgButtons;\r\n const HelpCtx: Longint; const Center: TDlgCenterKind = dckScreen; const Timeout: Integer = 0;\r\n const DefaultButton: TMsgDlgBtn = mbDefault; const CancelButton: TMsgDlgBtn = mbDefault;\r\n const HelpButton: TMsgDlgBtn = mbHelp;\r\n const ADynControlEngine: TJvDynControlEngine = nil): TModalResult;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvParameterListParameter.pas $';\r\n Revision: '$Revision: 13415 $';\r\n Date: '$Date: 2012-09-10 11:51:54 +0200 (lun. 10 sept. 2012) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n {$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n JvResources, JvJVCLUtils, JclSysUtils;\r\n\r\nfunction DSADialogsMessageDlg(const Msg: string; const DlgType: TMsgDlgType; const Buttons: TMsgDlgButtons;\r\n const HelpCtx: Longint; const Center: TDlgCenterKind = dckScreen; const Timeout: Integer = 0;\r\n const DefaultButton: TMsgDlgBtn = mbDefault; const CancelButton: TMsgDlgBtn = mbDefault;\r\n const HelpButton: TMsgDlgBtn = mbHelp;\r\n const ADynControlEngine: TJvDynControlEngine = nil): TModalResult;\r\nbegin\r\n Result := JvDSADialogs.MessageDlg(Msg, DlgType, Buttons, HelpCtx, Center, Timeout, DefaultButton,\r\n CancelButton, HelpButton, ADynControlEngine);\r\nend;\r\n\r\n//=== { TJvNoDataParameter } =================================================\r\n\r\nconstructor TJvNoDataParameter.Create(AParameterList: TJvParameterList);\r\nbegin\r\n inherited Create(AParameterList);\r\n StoreValueToAppStorage := False;\r\nend;\r\n\r\nfunction TJvNoDataParameter.IsDataValid(const AData: Variant; var vMsg:\r\n String): Boolean;\r\nbegin\r\n Result := True;\r\nend;\r\n\r\n//=== { TJvButtonParameter } =================================================\r\n\r\nfunction TJvButtonParameter.GetParameterNameExt: string;\r\nbegin\r\n Result := 'Button';\r\nend;\r\n\r\nprocedure TJvButtonParameter.Click(Sender: TObject);\r\nbegin\r\n if Assigned(OnClick) then\r\n OnClick(ParameterList, Self);\r\nend;\r\n\r\nprocedure TJvButtonParameter.SetGlyph(Value: TBitmap);\r\nbegin\r\n FGlyph.Assign(Value);\r\nend;\r\n\r\nprocedure TJvButtonParameter.Assign(Source: TPersistent);\r\nbegin\r\n inherited Assign(Source);\r\n if Source is TJvButtonParameter then\r\n begin\r\n Glyph := TJvButtonParameter(Source).Glyph;\r\n Layout := TJvButtonParameter(Source).Layout;\r\n NumGlyphs := TJvButtonParameter(Source).NumGlyphs;\r\n OnClick := TJvButtonParameter(Source).OnClick;\r\n Action := TJvButtonParameter(Source).Action;\r\n end;\r\nend;\r\n\r\nconstructor TJvButtonParameter.Create(AParameterList: TJvParameterList);\r\nbegin\r\n inherited Create(AParameterList);\r\n FGlyph := TBitmap.Create;\r\nend;\r\n\r\nprocedure TJvButtonParameter.CreateWinControlOnParent(ParameterParent: TWinControl);\r\nvar\r\n Button: TButton;\r\nbegin\r\n Button := DynControlEngine.CreateButton(Self, ParameterParent,\r\n GetParameterName, Caption, Hint, Click, False, False);\r\n Button.Action := Action;\r\n SetWinControl (Button);\r\n if Height > 0 then\r\n WinControl.Height := Height;\r\n if Width > 0 then\r\n WinControl.Width := Width;\r\nend;\r\n\r\ndestructor TJvButtonParameter.Destroy;\r\nbegin\r\n FGlyph.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvButtonParameter.SetWinControlProperties;\r\nvar\r\n IJvButton: IJvDynControlButton;\r\nbegin\r\n inherited SetWinControlProperties;\r\n if Supports(WinControl, IJvDynControlButton, IJvButton) then\r\n begin\r\n IJvButton.ControlSetGlyph(Glyph);\r\n IJvButton.ControlSetNumGlyphs(NumGlyphs);\r\n IJvButton.ControlSetLayout(Layout);\r\n end;\r\nend;\r\n\r\n//=== { TJvRadioButtonParameter } ============================================\r\n\r\nfunction TJvRadioButtonParameter.GetParameterNameExt: string;\r\nbegin\r\n Result := 'RadioButton';\r\nend;\r\n\r\nprocedure TJvRadioButtonParameter.Click(Sender: TObject);\r\nbegin\r\n if Assigned(FOnClick) then\r\n FOnClick(ParameterList, Self);\r\nend;\r\n\r\nprocedure TJvRadioButtonParameter.Assign(Source: TPersistent);\r\nbegin\r\n inherited Assign(Source);\r\nend;\r\n\r\nprocedure TJvRadioButtonParameter.CreateWinControlOnParent(ParameterParent: TWinControl);\r\nbegin\r\n SetWinControl (DynControlEngine.CreateRadioButton(Self, ParameterParent,\r\n GetParameterName, Caption));\r\n WinControl.Hint := Hint;\r\n if Height > 0 then\r\n WinControl.Height := Height;\r\n if Width > 0 then\r\n WinControl.Width := Width;\r\nend;\r\n\r\nprocedure TJvRadioButtonParameter.SetWinControlProperties;\r\nbegin\r\n inherited SetWinControlProperties;\r\nend;\r\n\r\n//=== { TJvBasePanelEditParameter } ==========================================\r\n\r\nconstructor TJvBasePanelEditParameter.Create(AParameterList: TJvParameterList);\r\nbegin\r\n inherited Create(AParameterList);\r\n FLabelArrangeMode := lamAbove;\r\n FLabelWidth := 0;\r\n FEditWidth := 0;\r\n FArrangeLabelAndWinControlDisabled := False;\r\nend;\r\n\r\nprocedure TJvBasePanelEditParameter.ArrangeLabelAndWinControlOnPanel;\r\nvar\r\n TmpLabelArrangeMode: TJvParameterLabelArrangeMode;\r\nbegin\r\n if not Assigned(FrameControl) or not Assigned(WinControl) or FArrangeLabelAndWinControlDisabled then\r\n Exit;\r\n if not Assigned(LabelControl) and (LabelArrangeMode in [lamBefore, lamAbove]) then\r\n TmpLabelArrangeMode := lamNone\r\n else\r\n TmpLabelArrangeMode := LabelArrangeMode;\r\n\r\n case TmpLabelArrangeMode of\r\n lamBefore:\r\n ArrangeLabelAndWinControlOnPanelBefore;\r\n lamAbove:\r\n ArrangeLabelAndWinControlOnPanelAbove;\r\n lamNone:\r\n ArrangeLabelAndWinControlOnPanelNone;\r\n lamGroupBox:\r\n ArrangeLabelAndWinControlOnPanelGroupBox;\r\n end;\r\nend;\r\n\r\nprocedure TJvBasePanelEditParameter.ArrangeLabelAndWinControlOnPanelAbove;\r\nvar\r\n l, t, w, h: Integer;\r\nbegin\r\n t := LabelControl.Height;\r\n l := 0;\r\n\r\n if Height > 0 then\r\n h := Height - t\r\n else\r\n h := fOrgWinControlHeight;\r\n\r\n if EditWidth > 0 then\r\n w := EditWidth\r\n else if Width > 0 then\r\n w := Width\r\n else\r\n w := 0;\r\n\r\n ArrangeWinControlsonPanel(l, t, w, h);\r\n\r\n FrameControl.Height := t + h;\r\n FrameControl.Width := l + w;\r\nend;\r\n\r\nprocedure TJvBasePanelEditParameter.ArrangeLabelAndWinControlOnPanelBefore;\r\nvar\r\n DynCtrlFont: IJvDynControlFont;\r\n l, t, w, h: Integer;\r\nbegin\r\n if LabelWidth > 0 then\r\n LabelControl.Width := LabelWidth\r\n else\r\n if Supports(LabelControl, IJvDynControlFont, DynCtrlFont) then\r\n LabelControl.Width :=\r\n DynControlEngine.GetControlTextWidth(LabelControl,\r\n DynCtrlFont.ControlFont, Caption+'X');\r\n\r\n t := LabelControl.Top;\r\n l := LabelControl.Left + LabelControl.Width + 4;\r\n\r\n if Height > 0 then\r\n h := Height\r\n else\r\n h := fOrgWinControlHeight;\r\n\r\n if EditWidth > 0 then\r\n w := EditWidth\r\n else if Width > 0 then\r\n w := Width - l\r\n else\r\n w := 0;\r\n\r\n ArrangeWinControlsonPanel(l, t, w, h);\r\n\r\n LabelControl.Top := t + Round((h - LabelControl.Height) / 2);\r\n\r\n FrameControl.Height := t + h;\r\n FrameControl.Width := l + w;\r\n\r\nend;\r\n\r\nprocedure TJvBasePanelEditParameter.ArrangeLabelAndWinControlOnPanelGroupBox;\r\nvar\r\n l, t, w, h: Integer;\r\nbegin\r\n t := 16;\r\n l := 5;\r\n\r\n if Height > 0 then\r\n h := Height - 20\r\n else\r\n h := fOrgWinControlHeight;\r\n\r\n if EditWidth > 0 then\r\n w := EditWidth\r\n else if Width > 0 then\r\n w := Width - 9\r\n else\r\n w := 0;\r\n\r\n ArrangeWinControlsonPanel(l, t, w, h);\r\n\r\n FrameControl.Height := h + 20;\r\n FrameControl.Width := w + 9;\r\nend;\r\n\r\nprocedure TJvBasePanelEditParameter.ArrangeLabelAndWinControlOnPanelNone;\r\nvar\r\n l, t, w, h: Integer;\r\nbegin\r\n t := 0;\r\n l := 0;\r\n\r\n if Height > 0 then\r\n h := Height\r\n else\r\n h := fOrgWinControlHeight;\r\n\r\n if EditWidth > 0 then\r\n w := EditWidth\r\n else if Width > 0 then\r\n w := Width\r\n else\r\n w := 0;\r\n\r\n ArrangeWinControlsonPanel(l, t, w, h);\r\n\r\n FrameControl.Height := h;\r\n FrameControl.Width := w;\r\nend;\r\n\r\nprocedure TJvBasePanelEditParameter.ArrangeWinControlsonPanel(iLeft, iTop:\r\n Integer; var iWidth: Integer; iHeight: Integer);\r\nconst\r\n Space = 2;\r\nvar\r\n l, w: Integer;\r\nbegin\r\n l := iLeft;\r\n w := 0;\r\n if Assigned(FBeforeParameterControl) then\r\n begin\r\n FBeforeParameterControl.Left := l;\r\n FBeforeParameterControl.Top := iTop;\r\n FBeforeParameterControl.Height := iHeight;\r\n l := FBeforeParameterControl.Left + FBeforeParameterControl.Width+ Space;\r\n w := w + FBeforeParameterControl.Width+ Space;\r\n end;\r\n WinControl.Left := l;\r\n WinControl.Top := iTop;\r\n WinControl.Height := iHeight;\r\n if iWidth > 0 then\r\n begin\r\n WinControl.Width := iWidth-l+iLeft;\r\n if Assigned (FAfterParameterControl) then\r\n WinControl.Width := WinControl.Width - (FAfterParameterControl.Width + Space);\r\n end\r\n else\r\n WinControl.Width := FOrgWinControlWidth;\r\n w := w + WinControl.Width;\r\n if Assigned(FAfterParameterControl) then\r\n begin\r\n l := WinControl.Left + WinControl.Width + Space;\r\n FAfterParameterControl.Left := l;\r\n FAfterParameterControl.Top := iTop;\r\n FAfterParameterControl.Height := iHeight;\r\n w := w + FAfterParameterControl.Width+ Space;\r\n end;\r\n iWidth := w;\r\nend;\r\n\r\nprocedure TJvBasePanelEditParameter.Assign(Source: TPersistent);\r\nbegin\r\n inherited Assign(Source);\r\n if Source is TJvBasePanelEditParameter then\r\n begin\r\n LabelArrangeMode := TJvBasePanelEditParameter(Source).LabelArrangeMode;\r\n LabelWidth := TJvBasePanelEditParameter(Source).LabelWidth;\r\n EditWidth := TJvBasePanelEditParameter(Source).EditWidth;\r\n AfterParameterName := TJvBasePanelEditParameter(Source).AfterParameterName ;\r\n BeforeParameterName := TJvBasePanelEditParameter(Source).BeforeParameterName ;\r\n end;\r\nend;\r\n\r\nprocedure TJvBasePanelEditParameter.CreateAfterParameterControl(\r\n AParameterParent: TWinControl);\r\nvar\r\n AfterParameter: TJvBaseParameter;\r\nbegin\r\n AfterParameter := ParameterList.ParameterByName(AfterParameterName);\r\n if Assigned(AfterParameter) and AfterParameter.Visible then\r\n begin\r\n AfterParameter.CreateWinControlOnParent(AParameterParent);\r\n if AfterParameter is TJvBasePanelEditParameter then\r\n FAfterParameterControl := TJvBasePanelEditParameter(AfterParameter).FrameControl\r\n else\r\n FAfterParameterControl := AfterParameter.WinControl;\r\n FAfterParameterControl.Parent := AParameterParent;\r\n end\r\n else\r\n FAfterParameterControl := nil;\r\nend;\r\n\r\nprocedure TJvBasePanelEditParameter.CreateBeforeParameterControl(AParameterParent: TWinControl);\r\nvar\r\n BeforeParameter: TJvBaseParameter;\r\nbegin\r\n BeforeParameter := ParameterList.ParameterByName(BeforeParameterName);\r\n if Assigned(BeforeParameter) and BeforeParameter.Visible then\r\n begin\r\n BeforeParameter.CreateWinControlOnParent(AParameterParent);\r\n if BeforeParameter is TJvBasePanelEditParameter then\r\n FBeforeParameterControl := TJvBasePanelEditParameter(BeforeParameter).FrameControl\r\n else\r\n FBeforeParameterControl := BeforeParameter.WinControl;\r\n FBeforeParameterControl.Parent := AParameterParent;\r\n end\r\n else\r\n FBeforeParameterControl := nil;\r\nend;\r\n\r\nprocedure TJvBasePanelEditParameter.CreateFramePanel(AParameterParent: TWinControl);\r\nvar\r\n DynBevel: IJvDynControlBevelBorder;\r\nbegin\r\n if LabelArrangeMode = lamGroupBox then\r\n FFrameControl := DynControlEngine.CreateGroupBoxControl(Self, AParameterParent,\r\n GetParameterName + 'GroupBox', Caption)\r\n else\r\n FFrameControl := DynControlEngine.CreatePanelControl(Self, AParameterParent,\r\n GetParameterName + 'Panel', '', alNone);\r\n FrameControl.Height := Height;\r\n FrameControl.Width := Width;\r\n if Supports(FrameControl, IJvDynControlBevelBorder, DynBevel) then\r\n begin\r\n DynBevel.ControlSetBevelInner(bvNone);\r\n DynBevel.ControlSetBevelOuter(bvNone);\r\n end\r\n else if FrameControl is TPanel then\r\n begin\r\n TPanel(FrameControl).BevelInner := bvNone;\r\n TPanel(FrameControl).BevelOuter := bvNone;\r\n end;\r\nend;\r\n\r\nprocedure TJvBasePanelEditParameter.CreateLabelControl(AParameterParent: TWinControl);\r\nvar\r\n IDynAutoSize: IJvDynControlAutoSize;\r\nbegin\r\n if (Caption = '') or (LabelArrangeMode in [lamGroupBox, lamNone]) then\r\n Exit;\r\n fLabelControl := DynControlEngine.CreateLabelControl(Self, AParameterParent,\r\n GetParameterName + 'Label', Caption, WinControl);\r\n LabelControl.Visible := True;\r\n LabelControl.Enabled := Enabled;\r\n LabelControl.Parent := AParameterParent;\r\n if Supports (LabelControl, IJvDynControlAutoSize, IDynAutoSize) then\r\n begin\r\n IDynAutoSize.ControlSetAutosize(True);\r\n IDynAutoSize.ControlSetAutosize(False);\r\n end\r\n else\r\n LabelControl.Height := 16;\r\n\r\nend;\r\n\r\nprocedure TJvBasePanelEditParameter.CreateWinControlOnParent(ParameterParent: TWinControl);\r\nbegin\r\n CreateFramePanel(ParameterParent);\r\n CreateBeforeParameterControl(FrameControl);\r\n CreateWinControl(FrameControl);\r\n CreateAfterParameterControl(FrameControl);\r\n CreateLabelControl(FrameControl);\r\n fOrgWinControlHeight := WinControl.Height;\r\n fOrgWinControlWidth := WinControl.Width;\r\n ArrangeLabelAndWinControlOnPanel;\r\nend;\r\n\r\nfunction TJvBasePanelEditParameter.GetLabelWidth: Integer;\r\nbegin\r\n if Assigned(ParameterList) and (FLabelWidth <= 0) then\r\n Result := ParameterList.DefaultParameterLabelWidth\r\n else\r\n Result := FLabelWidth;\r\nend;\r\n\r\nprocedure TJvBasePanelEditParameter.Notification(AComponent: TComponent; Operation: TOperation);\r\nbegin\r\n inherited Notification(AComponent, Operation);\r\n if (Operation = opRemove) then\r\n begin\r\n if (AComponent = FFrameControl) then\r\n FFrameControl := nil;\r\n if (AComponent = FLabelControl) then\r\n FLabelControl := nil;\r\n if (AComponent = FAfterParameterControl) then\r\n FAfterParameterControl := nil;\r\n if (AComponent = FBeforeParameterControl) then\r\n FBeforeParameterControl := nil;\r\n end;\r\nend;\r\n\r\nprocedure TJvBasePanelEditParameter.SetEnabled(Value: Boolean);\r\nbegin\r\n inherited SetEnabled(Value);\r\n if Assigned(FrameControl) then\r\n FrameControl.Enabled := Value;\r\n if Assigned(LabelControl) then\r\n LabelControl.Enabled := Value;\r\n if Assigned(FAfterParameterControl) then\r\n FAfterParameterControl.Enabled := Value;\r\n if Assigned(FBeforeParameterControl) then\r\n FBeforeParameterControl.Enabled := Value;\r\nend;\r\n\r\nprocedure TJvBasePanelEditParameter.SetHeight(Value: Integer);\r\nbegin\r\n inherited SetHeight(Value);\r\n ArrangeLabelAndWinControlOnPanel;\r\nend;\r\n\r\nprocedure TJvBasePanelEditParameter.SetLabelArrangeMode(Value:\r\n TJvParameterLabelArrangeMode);\r\nbegin\r\n FLabelArrangeMode := Value;\r\n ArrangeLabelAndWinControlOnPanel;\r\nend;\r\n\r\nprocedure TJvBasePanelEditParameter.SetLabelWidth(Value: Integer);\r\nbegin\r\n FLabelWidth := Value;\r\n if Assigned(WinControl) then\r\n ArrangeLabelAndWinControlOnPanel;\r\nend;\r\n\r\nprocedure TJvBasePanelEditParameter.SetTabOrder(Value: Integer);\r\nbegin\r\n if Assigned(FrameControl) then\r\n FrameControl.TabOrder := Value;\r\nend;\r\n\r\nprocedure TJvBasePanelEditParameter.SetVisible(Value: Boolean);\r\nbegin\r\n inherited SetVisible(Value);\r\n if Assigned(FrameControl) then\r\n FrameControl.Visible := Value;\r\nend;\r\n\r\nprocedure TJvBasePanelEditParameter.SetWidth(Value: Integer);\r\nbegin\r\n inherited SetWidth(Value);\r\n ArrangeLabelAndWinControlOnPanel;\r\nend;\r\n\r\nprocedure TJvBasePanelEditParameter.SetWinControlProperties;\r\nbegin\r\n try\r\n FArrangeLabelAndWinControlDisabled := True;\r\n inherited SetWinControlProperties;\r\n finally\r\n FArrangeLabelAndWinControlDisabled := False;\r\n end;\r\nend;\r\n\r\ntype\r\n TAccessCustomControl = class(TCustomControl);\r\n\r\n //=== { TJvLabelParameter } ==================================================\r\n\r\nprocedure TJvLabelParameter.CreateWinControlOnParent(ParameterParent: TWinControl);\r\nbegin\r\n SetWinControl (DynControlEngine.CreateStaticTextControl(Self, ParameterParent,\r\n GetParameterName, Caption));\r\nend;\r\n\r\n//=== { TJvImageParameter } ==================================================\r\n\r\nconstructor TJvImageParameter.Create(AParameterList: TJvParameterList);\r\nbegin\r\n inherited Create(AParameterList);\r\n FPicture := TPicture.Create;\r\n FAutoSize := False;\r\n FCenter := False;\r\n FIncrementalDisplay := False;\r\n FStretch := False;\r\n FTransparent := False;\r\nend;\r\n\r\ndestructor TJvImageParameter.Destroy;\r\nbegin\r\n FPicture.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvImageParameter.SetPicture(Value: TPicture);\r\nbegin\r\n FPicture.Assign(Value);\r\nend;\r\n\r\nprocedure TJvImageParameter.SetAutoSize(Value: Boolean);\r\nbegin\r\n if Value <> FAutoSize then\r\n begin\r\n FAutoSize := Value;\r\n end;\r\nend;\r\n\r\nprocedure TJvImageParameter.Assign(Source: TPersistent);\r\nbegin\r\n inherited Assign(Source);\r\n if Source is TJvImageParameter then\r\n begin\r\n Picture := TJvImageParameter(Source).Picture;\r\n // AutoSize := TJvImageParameter(Source).AutoSize;\r\n Center := TJvImageParameter(Source).Center;\r\n IncrementalDisplay := TJvImageParameter(Source).IncrementalDisplay;\r\n Stretch := TJvImageParameter(Source).Stretch;\r\n Transparent := TJvImageParameter(Source).Transparent;\r\n end;\r\nend;\r\n\r\nfunction TJvImageParameter.GetParameterNameExt: string;\r\nbegin\r\n Result := 'Image';\r\nend;\r\n\r\nprocedure TJvImageParameter.CreateWinControl(AParameterParent: TWinControl);\r\nvar\r\n ITmpImage: IJvDynControlImage;\r\nbegin\r\n SetWinControl (DynControlEngine.CreateImageControl(Self, AParameterParent, GetParameterName));\r\n if Supports(WinControl, IJvDynControlImage, ITmpImage) then\r\n begin\r\n ITmpImage.ControlSetPicture(Picture);\r\n // ITmpImage.ControlSetAutoSize(AutoSize);\r\n ITmpImage.ControlSetIncrementalDisplay(IncrementalDisplay);\r\n ITmpImage.ControlSetCenter(Center);\r\n ITmpImage.ControlSetStretch(Stretch);\r\n ITmpImage.ControlSetTransparent(Transparent);\r\n end;\r\nend;\r\n\r\n//=== { TJvArrangeParameter } ================================================\r\n\r\nconstructor TJvArrangeParameter.Create(AParameterList: TJvParameterList);\r\nbegin\r\n inherited Create(AParameterList);\r\n FArrangeSettings := TJvArrangeSettings.Create(Self);\r\n FArrangeSettings.BorderLeft := 2;\r\n FArrangeSettings.BorderTop := 2;\r\n FArrangeSettings.DistanceVertical := 2;\r\n FArrangeSettings.DistanceHorizontal := 2;\r\n FArrangeSettings.AutoArrange := True;\r\nend;\r\n\r\ndestructor TJvArrangeParameter.Destroy;\r\nbegin\r\n FArrangeSettings.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvArrangeParameter.ArrangeControls;\r\nbegin\r\n if FParentControl is TJvPanel then\r\n TJvPanel(FParentControl).ArrangeControls;\r\nend;\r\n\r\nprocedure TJvArrangeParameter.DisableArrange;\r\nbegin\r\n if FParentControl is TJvPanel then\r\n TJvPanel(FParentControl).DisableArrange;\r\nend;\r\n\r\nprocedure TJvArrangeParameter.EnableArrange;\r\nbegin\r\n if FParentControl is TJvPanel then\r\n TJvPanel(FParentControl).EnableArrange;\r\nend;\r\n\r\nprocedure TJvArrangeParameter.SetArrangeSettings(Value: TJvArrangeSettings);\r\nbegin\r\n FArrangeSettings.Assign(Value);\r\nend;\r\n\r\nprocedure TJvArrangeParameter.Notification(AComponent: TComponent; Operation: TOperation);\r\nbegin\r\n inherited Notification(AComponent, Operation);\r\n if (AComponent = FParentControl) and (Operation = opRemove) then\r\n FParentControl := nil;\r\nend;\r\n\r\nfunction TJvArrangeParameter.GetParentControl: TWinControl;\r\nbegin\r\n if Assigned(FParentControl) then\r\n Result := FParentControl\r\n else\r\n Result := WinControl;\r\nend;\r\n\r\nprocedure TJvArrangeParameter.SetParentControl(const Value: TWinControl);\r\nbegin\r\n ReplaceComponentReference(Self, Value, TComponent(FParentControl));\r\nend;\r\n\r\n//=== { TJvPanelParameter } ==================================================\r\n\r\nconstructor TJvPanelParameter.Create(AParameterList: TJvParameterList);\r\nbegin\r\n inherited Create(AParameterList);\r\n BevelInner := bvNone;\r\n BevelOuter := bvNone;\r\n BevelWidth := 1;\r\n BorderStyle := bsNone;\r\n BorderWidth := 0;\r\nend;\r\n\r\nprocedure TJvPanelParameter.Assign(Source: TPersistent);\r\nbegin\r\n inherited Assign(Source);\r\n if Source is TJvPanelParameter then\r\n begin\r\n BevelInner := TJvPanelParameter(Source).BevelInner;\r\n BevelOuter := TJvPanelParameter(Source).BevelOuter;\r\n end;\r\nend;\r\n\r\nfunction TJvPanelParameter.GetParameterNameExt: string;\r\nbegin\r\n Result := 'Panel';\r\nend;\r\n\r\nprocedure TJvPanelParameter.CreateWinControlOnParent(ParameterParent: TWinControl);\r\nbegin\r\n SetWinControl (DynControlEngine.CreatePanelControl(Self, ParameterParent,\r\n GetParameterName, Caption, alNone));\r\n ParentControl := WinControl;\r\n if Height > 0 then\r\n WinControl.Height := Height;\r\n if Width > 0 then\r\n WinControl.Width := Width;\r\nend;\r\n\r\nprocedure TJvPanelParameter.SetWinControlProperties;\r\nvar\r\n ITmpPanel: IJvDynControlPanel;\r\n ITmpArrangePanel: IJvArrangePanel;\r\nbegin\r\n inherited SetWinControlProperties;\r\n if Supports(WinControl, IJvDynControlPanel, ITmpPanel) then\r\n ITmpPanel.ControlSetBorder(BevelInner, BevelOuter, BevelWidth, BorderStyle, BorderWidth);\r\n if Supports(WinControl, IJvArrangePanel, ITmpArrangePanel) then\r\n ITmpArrangePanel.ArrangeSettings := ArrangeSettings;\r\nend;\r\n\r\n//=== { TJvGroupBoxParameter } ===============================================\r\n\r\nconstructor TJvGroupBoxParameter.Create(AParameterList: TJvParameterList);\r\nbegin\r\n inherited Create(AParameterList);\r\n ArrangeSettings.AutoSize := asHeight;\r\nend;\r\n\r\nfunction TJvGroupBoxParameter.GetParameterNameExt: string;\r\nbegin\r\n Result := 'GroupBoxPanel';\r\nend;\r\n\r\nprocedure TJvGroupBoxParameter.CreateWinControlOnParent(ParameterParent: TWinControl);\r\nvar\r\n Panel: TJvPanel;\r\nbegin\r\n SetWinControl (DynControlEngine.CreateGroupBoxControl(Self, ParameterParent,\r\n GetParameterName, Caption));\r\n Panel := TJvPanel.Create(ParameterParent.Owner);\r\n ParentControl := Panel;\r\n Panel.Name := GetParameterName;\r\n Panel.ArrangeSettings := ArrangeSettings;\r\n Panel.BevelInner := bvNone;\r\n Panel.BevelOuter := bvNone;\r\n Panel.Parent := WinControl;\r\n Panel.Align := alClient;\r\n Panel.Visible := True;\r\n Panel.Caption := '';\r\n Panel.Color := Color;\r\n Panel.OnResizeParent := ReArrangeGroupbox;\r\n // Panel.Transparent := True;\r\nend;\r\n\r\nprocedure TJvGroupBoxParameter.ReArrangeGroupbox(Sender: TObject; nLeft, nTop, nWidth, nHeight: Integer);\r\nbegin\r\n if ArrangeSettings.AutoSize in [asWidth, asBoth] then\r\n WinControl.Width := nWidth + 5;\r\n if ArrangeSettings.AutoSize in [asHeight, asBoth] then\r\n WinControl.Height := nHeight + 22;\r\nend;\r\n\r\nprocedure TJvGroupBoxParameter.SetWinControlProperties;\r\nvar\r\n ITmpArrangePanel: IJvArrangePanel;\r\nbegin\r\n inherited SetWinControlProperties;\r\n if Supports(ParentControl, IJvArrangePanel, ITmpArrangePanel) then\r\n ITmpArrangePanel.ArrangeSettings := ArrangeSettings;\r\nend;\r\n\r\n//=== { TJvListParameter } ===================================================\r\n\r\nconstructor TJvListParameter.Create(AParameterList: TJvParameterList);\r\nbegin\r\n inherited Create(AParameterList);\r\n FItemList := TStringList.Create;\r\n Sorted := False;\r\n FItemIndex := -1;\r\n FVariantAsItemIndex := False;\r\nend;\r\n\r\ndestructor TJvListParameter.Destroy;\r\nbegin\r\n FItemList.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvListParameter.SetAsString(const Value: string);\r\nvar\r\n I: Integer;\r\nbegin\r\n I := ItemList.IndexOf(VarToStr(Value));\r\n if (I >= 0) and (I < ItemList.Count) then\r\n ItemIndex := I\r\n else\r\n ItemIndex := -1;\r\n if not VariantAsItemIndex then\r\n inherited SetAsVariant(Value);\r\nend;\r\n\r\nfunction TJvListParameter.GetAsString: string;\r\nbegin\r\n if VariantAsItemIndex then\r\n if (ItemIndex >= 0) and (ItemIndex < ItemList.Count) then\r\n Result := ItemList[ItemIndex]\r\n else\r\n Result := ''\r\n else\r\n Result := inherited GetAsString;\r\nend;\r\n\r\nprocedure TJvListParameter.SetAsInteger(Value: Integer);\r\nbegin\r\n ItemIndex := Value\r\nend;\r\n\r\nfunction TJvListParameter.GetAsInteger: Integer;\r\nbegin\r\n Result := ItemIndex;\r\nend;\r\n\r\nprocedure TJvListParameter.SetAsVariant(Value: Variant);\r\nbegin\r\n if VarIsNullEmpty(Value) then\r\n ItemIndex := -1\r\n else if VariantAsItemIndex then\r\n if VarType(Value) in [varSmallInt, varInteger, varByte, varShortInt, varWord, varLongWord] then\r\n ItemIndex := Value\r\n else\r\n SetAsString(Value)\r\n else\r\n SetAsString(Value);\r\nend;\r\n\r\nfunction TJvListParameter.GetAsVariant: Variant;\r\nbegin\r\n Result := inherited GetAsVariant;\r\n if VariantAsItemIndex then\r\n if VarToStr(Result) = '-1' then\r\n Result := Null;\r\nend;\r\n\r\nfunction TJvListParameter.GetItemList: TStringList;\r\nbegin\r\n Result := FItemList;\r\nend;\r\n\r\nprocedure TJvListParameter.SetItemList(Value: TStringList);\r\nbegin\r\n FItemList.Assign(Value);\r\n if Assigned(Value) then\r\n SetItemIndex(FItemIndex);\r\n if Assigned(WinControl) then\r\n SetWinControlProperties;\r\nend;\r\n\r\nprocedure TJvListParameter.SetItemIndex(Value: Integer);\r\nbegin\r\n if Assigned(ItemList) then\r\n begin\r\n if Value >= ItemList.Count then\r\n FItemIndex := ItemList.Count - 1\r\n else\r\n FItemIndex := Value;\r\n if VariantAsItemIndex then\r\n inherited SetAsVariant(FItemIndex)\r\n else if (FItemIndex >= 0) and (FItemIndex < ItemList.Count) then\r\n inherited SetAsVariant(ItemList[FItemIndex])\r\n else\r\n inherited SetAsVariant('');\r\n end\r\n else\r\n begin\r\n FItemIndex := -1;\r\n if VariantAsItemIndex then\r\n inherited SetAsVariant(FItemIndex)\r\n else\r\n inherited SetAsVariant('');\r\n end;\r\nend;\r\n\r\nfunction TJvListParameter.GetWinControlData: Variant;\r\nvar\r\n Index: Integer;\r\nbegin\r\n if Assigned(JvDynControlData) then\r\n Index := JvDynControlData.ControlValue\r\n else\r\n Index := -1;\r\n if VariantAsItemIndex then\r\n Result := Index\r\n else if (Index >= 0) and (Index < ItemList.Count) then\r\n Result := ItemList[Index]\r\n else\r\n Result := JvDynControlData.ControlValue;\r\nend;\r\n\r\nprocedure TJvListParameter.SetWinControlData(Value: Variant);\r\nvar\r\n Index: Integer;\r\nbegin\r\n if Assigned(JvDynControlData) then\r\n if VariantAsItemIndex then\r\n JvDynControlData.ControlValue := Value\r\n else\r\n begin\r\n Index := ItemList.IndexOf(VarToStr(Value));\r\n if (Index >= 0) and (Index < ItemList.Count) then\r\n JvDynControlData.ControlValue := ItemList[Index]\r\n else\r\n JvDynControlData.ControlValue := '';\r\n end;\r\nend;\r\n\r\nprocedure TJvListParameter.Assign(Source: TPersistent);\r\nbegin\r\n inherited Assign(Source);\r\n if Source is TJvListParameter then\r\n begin\r\n ItemList.Assign(TJvListParameter(Source).ItemList);\r\n ItemIndex := TJvListParameter(Source).ItemIndex;\r\n Sorted := TJvListParameter(Source).Sorted;\r\n end;\r\nend;\r\n\r\nprocedure TJvListParameter.SearchItemIndex(const Search: string);\r\nvar\r\n I: Integer;\r\nbegin\r\n FItemIndex := -1;\r\n for I := 0 to ItemList.Count - 1 do\r\n if Search = ItemList.Strings[I] then\r\n begin\r\n FItemIndex := I;\r\n Break;\r\n end;\r\nend;\r\n\r\nprocedure TJvListParameter.SetWinControlProperties;\r\nvar\r\n ITmpItems: IJvDynControlItems;\r\nbegin\r\n inherited SetWinControlProperties;\r\n if Supports(WinControl, IJvDynControlItems, ITmpItems) then\r\n ITmpItems.ControlItems := ItemList;\r\nend;\r\n\r\n//=== { TJvRadioGroupParameter } =============================================\r\n\r\nprocedure TJvRadioGroupParameter.Assign(Source: TPersistent);\r\nbegin\r\n inherited Assign(Source);\r\n if Source is TJvRadioGroupParameter then\r\n Columns := TJvRadioGroupParameter(Source).Columns;\r\nend;\r\n\r\nprocedure TJvRadioGroupParameter.CreateWinControlOnParent(ParameterParent: TWinControl);\r\nbegin\r\n SetWinControl (DynControlEngine.CreateRadioGroupControl(Self, ParameterParent,\r\n GetParameterName, Caption, ItemList));\r\n if Height > 0 then\r\n WinControl.Height := Height;\r\n if Width > 0 then\r\n WinControl.Width := Width;\r\nend;\r\n\r\nprocedure TJvRadioGroupParameter.CreateWinControl(AParameterParent: TWinControl);\r\nbegin\r\nend;\r\n\r\nprocedure TJvRadioGroupParameter.SetWinControlProperties;\r\nvar\r\n ITmpRadioGroup: IJvDynControlRadioGroup;\r\nbegin\r\n inherited SetWinControlProperties;\r\n if Supports(WinControl, IJvDynControlRadioGroup, ITmpRadioGroup) then\r\n ITmpRadioGroup.ControlSetColumns(Columns);\r\nend;\r\n\r\nprocedure TJvCheckBoxParameter.Assign(Source: TPersistent);\r\nbegin\r\n inherited Assign(Source);\r\n if Source is TJvCheckBoxParameter then\r\n OnChange := TJvCheckBoxParameter(Source).OnChange;\r\nend;\r\n\r\n//=== { TJvCheckBoxParameter } ===============================================\r\n\r\nprocedure TJvCheckBoxParameter.CreateWinControlOnParent(ParameterParent: TWinControl);\r\nvar\r\n DynCtrlData: IJvDynControlData;\r\nbegin\r\n SetWinControl (DynControlEngine.CreateCheckBoxControl(Self, ParameterParent,\r\n GetParameterName, Caption));\r\n if Height > 0 then\r\n WinControl.Height := Height;\r\n if Width > 0 then\r\n WinControl.Width := Width;\r\n if Supports(WinControl, IJvDynControlData, DynCtrlData) and Assigned(OnChange) then\r\n DynCtrlData.ControlSetOnChange(OnChange);\r\nend;\r\n\r\n//=== { TJvComboBoxParameter } ===============================================\r\n\r\nconstructor TJvComboBoxParameter.Create(AParameterList: TJvParameterList);\r\nbegin\r\n inherited Create(AParameterList);\r\n LabelArrangeMode := lamBefore;\r\n FSorted := False;\r\n FNewEntriesAllowed := False;\r\nend;\r\n\r\nprocedure TJvComboBoxParameter.Assign(Source: TPersistent);\r\nbegin\r\n inherited Assign(Source);\r\n if Source is TJvComboBoxParameter then\r\n begin\r\n Sorted := TJvComboBoxParameter(Source).Sorted;\r\n NewEntriesAllowed := TJvComboBoxParameter(Source).NewEntriesAllowed;\r\n end;\r\nend;\r\n\r\nfunction TJvComboBoxParameter.GetParameterNameExt: string;\r\nbegin\r\n Result := 'ComboBox';\r\nend;\r\n\r\nprocedure TJvComboBoxParameter.GetData;\r\nbegin\r\n if Assigned(WinControl) then\r\n Value := WinControlData;\r\nend;\r\n\r\nprocedure TJvComboBoxParameter.SetData;\r\nbegin\r\n if Assigned(WinControl) then\r\n WinControlData := Value;\r\nend;\r\n\r\nprocedure TJvComboBoxParameter.CreateWinControl(AParameterParent: TWinControl);\r\nbegin\r\n SetWinControl (DynControlEngine.CreateComboBoxControl(Self, AParameterParent,\r\n GetParameterName, ItemList));\r\nend;\r\n\r\nprocedure TJvComboBoxParameter.SetWinControlProperties;\r\nvar\r\n ITmpComboBox: IJvDynControlComboBox;\r\n ITmpItems: IJvDynControlItems;\r\nbegin\r\n inherited SetWinControlProperties;\r\n if Supports(WinControl, IJvDynControlComboBox, ITmpComboBox) then\r\n ITmpComboBox.ControlSetNewEntriesAllowed(NewEntriesAllowed);\r\n if Supports(WinControl, IJvDynControlItems, ITmpItems) then\r\n ITmpItems.ControlSetSorted(Sorted);\r\nend;\r\n\r\nfunction TJvComboBoxParameter.GetWinControlData: Variant;\r\nvar\r\n Index: Integer;\r\nbegin\r\n if Assigned(JvDynControlData) then\r\n begin\r\n Index := ItemList.IndexOf(JvDynControlData.ControlValue);\r\n if VariantAsItemIndex then\r\n Result := Index\r\n else if (Index >= 0) and (Index < ItemList.Count) then\r\n Result := ItemList[Index]\r\n else\r\n Result := JvDynControlData.ControlValue;\r\n end\r\n else\r\n if VariantAsItemIndex then\r\n Result := -1\r\n else\r\n Result := null;\r\nend;\r\n\r\nprocedure TJvComboBoxParameter.SetWinControlData(Value: Variant);\r\nbegin\r\n if Assigned(JvDynControlData) then\r\n if VariantAsItemIndex then\r\n JvDynControlData.ControlValue := ItemList[Value]\r\n else\r\n JvDynControlData.ControlValue := Value;\r\nend;\r\n\r\n//=== { TJvListBoxParameter } ================================================\r\n\r\nprocedure TJvListBoxParameter.Assign(Source: TPersistent);\r\nbegin\r\n inherited Assign(Source);\r\n if Source is TJvListBoxParameter then\r\n Sorted := TJvListBoxParameter(Source).Sorted;\r\nend;\r\n\r\nfunction TJvListBoxParameter.GetParameterNameExt: string;\r\nbegin\r\n Result := 'ListBox';\r\nend;\r\n\r\nprocedure TJvListBoxParameter.CreateWinControl(AParameterParent: TWinControl);\r\nvar\r\n ITmpItems: IJvDynControlItems;\r\nbegin\r\n SetWinControl (DynControlEngine.CreateListBoxControl(Self, AParameterParent,\r\n GetParameterName, ItemList));\r\n if Supports(WinControl, IJvDynControlItems, ITmpItems) then\r\n ITmpItems.ControlSetSorted(Sorted);\r\n if Height > 0 then\r\n WinControl.Height := Height;\r\n if Width > 0 then\r\n WinControl.Width := Width;\r\nend;\r\n\r\nprocedure TJvListBoxParameter.SetWinControlProperties;\r\nvar\r\n ITmpItems: IJvDynControlItems;\r\nbegin\r\n inherited SetWinControlProperties;\r\n if Supports(WinControl, IJvDynControlItems, ITmpItems) then\r\n ITmpItems.ControlSetSorted(Sorted);\r\nend;\r\n\r\n//==== TJvCheckListItemDataWrapper ===========================================\r\n\r\nprocedure TJvCheckListItemDataWrapper.SetChecked(Check: Boolean);\r\nbegin\r\n if Check then\r\n FState := cbChecked\r\n else\r\n FState := cbUnchecked;\r\nend;\r\n\r\nfunction TJvCheckListItemDataWrapper.GetChecked: Boolean;\r\nbegin\r\n Result := FState = cbChecked;\r\nend;\r\n\r\n//=== { TJvCheckListBoxParameter } ===========================================\r\n\r\nconstructor TJvCheckListBoxParameter.Create(AParameterList: TJvParameterList);\r\nbegin\r\n inherited Create(AParameterList);\r\n FSorted := False;\r\n FAllowGrayed := False;\r\nend;\r\n\r\ndestructor TJvCheckListBoxParameter.Destroy;\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := 0 to ItemList.Count - 1 do\r\n ItemList.Objects[I].Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvCheckListBoxParameter.Assign(Source: TPersistent);\r\nvar\r\n I: Integer;\r\nbegin\r\n inherited Assign(Source);\r\n if Source is TJvCheckListBoxParameter then\r\n begin\r\n Sorted := TJvCheckListBoxParameter(Source).Sorted;\r\n AllowGrayed := TJvCheckListBoxParameter(Source).AllowGrayed;\r\n for I := 0 to ItemList.Count do\r\n ItemData[I] := TJvCheckListBoxParameter(Source).ItemData[I];\r\n end;\r\nend;\r\n\r\nprocedure TJvCheckListBoxParameter.GetData;\r\nvar\r\n ITmpCheckListBox: IJvDynControlCheckListBox;\r\n I: Integer;\r\nbegin\r\n inherited GetData;\r\n if Supports(WinControl, IJvDynControlCheckListBox, ITmpCheckListBox) then\r\n for I := 0 to ItemList.Count - 1 do\r\n begin\r\n ItemData[I].ItemEnabled := ITmpCheckListBox.ControlGetItemEnabled(I);\r\n ItemData[I].State := ITmpCheckListBox.ControlGetState(I);\r\n ItemData[I].Header := ITmpCheckListBox.ControlGetHeader(I);\r\n end;\r\nend;\r\n\r\nprocedure TJvCheckListBoxParameter.SetData;\r\nvar\r\n ITmpCheckListBox: IJvDynControlCheckListBox;\r\n I: Integer;\r\nbegin\r\n inherited SetData;\r\n if Supports(WinControl, IJvDynControlCheckListBox, ITmpCheckListBox) then\r\n for I := 0 to ItemList.Count - 1 do\r\n begin\r\n ITmpCheckListBox.ControlSetItemEnabled(I, ItemData[I].ItemEnabled);\r\n ITmpCheckListBox.ControlSetState(I, ItemData[I].State);\r\n ITmpCheckListBox.ControlSetHeader(I, ItemData[I].Header);\r\n end;\r\nend;\r\n\r\nprocedure TJvCheckListBoxParameter.AddCheckListBoxItem(const AText: string;\r\n AState: TCheckBoxState = cbChecked; AItemEnabled: Boolean = True;\r\n AHeader: Boolean = False);\r\nbegin\r\n ItemList.Add(AText);\r\n ItemData[ItemList.Count - 1].Header := AHeader;\r\n ItemData[ItemList.Count - 1].State := AState;\r\n ItemData[ItemList.Count - 1].ItemEnabled := AItemEnabled;\r\nend;\r\n\r\nfunction TJvCheckListBoxParameter.GetParameterNameExt: string;\r\nbegin\r\n Result := 'CheckListBox';\r\nend;\r\n\r\nprocedure TJvCheckListBoxParameter.CreateWinControl(AParameterParent: TWinControl);\r\nvar\r\n ITmpItems: IJvDynControlItems;\r\nbegin\r\n SetWinControl (DynControlEngine.CreateCheckListBoxControl(Self, AParameterParent,\r\n GetParameterName, ItemList));\r\n if Supports(WinControl, IJvDynControlItems, ITmpItems) then\r\n ITmpItems.ControlSetSorted(Sorted);\r\n if Height > 0 then\r\n WinControl.Height := Height;\r\n if Width > 0 then\r\n WinControl.Width := Width;\r\nend;\r\n\r\nprocedure TJvCheckListBoxParameter.SetWinControlProperties;\r\nvar\r\n ITmpItems: IJvDynControlItems;\r\n ITmpCheckListBox: IJvDynControlCheckListBox;\r\nbegin\r\n inherited SetWinControlProperties;\r\n if Supports(WinControl, IJvDynControlItems, ITmpItems) then\r\n ITmpItems.ControlSetSorted(Sorted);\r\n if Supports(WinControl, IJvDynControlCheckListBox, ITmpCheckListBox) then\r\n ITmpCheckListBox.ControlSetAllowGrayed(AllowGrayed);\r\nend;\r\n\r\nfunction TJvCheckListBoxParameter.GetItemData(Index: Integer): TJvCheckListItemDataWrapper;\r\nbegin\r\n if (Index >= 0) and (Index < ItemList.Count) then\r\n begin\r\n if not Assigned(ItemList.Objects[Index]) then\r\n begin\r\n ItemList.Objects[Index] := TJvCheckListItemDataWrapper.Create;\r\n TJvCheckListItemDataWrapper(ItemList.Objects[Index]).State := cbChecked;\r\n TJvCheckListItemDataWrapper(ItemList.Objects[Index]).Header := False;\r\n TJvCheckListItemDataWrapper(ItemList.Objects[Index]).ItemEnabled := True;\r\n end;\r\n Result := TJvCheckListItemDataWrapper(ItemList.Objects[Index]);\r\n end\r\n else\r\n Result := nil;\r\nend;\r\n\r\nprocedure TJvCheckListBoxParameter.SetItemData(Index: Integer; Value: TJvCheckListItemDataWrapper);\r\nvar\r\n Data: TJvCheckListItemDataWrapper;\r\nbegin\r\n Data := GetItemData(Index);\r\n if Assigned(Data) then\r\n begin\r\n Data.State := Value.State;\r\n Data.ItemEnabled := Value.ItemEnabled;\r\n Data.Header := Value.Header;\r\n end;\r\nend;\r\n\r\nprocedure TJvCheckListBoxParameter.SetItemList(Value: TStringList);\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := 0 to ItemList.Count - 1 do\r\n if Assigned(ItemList.Objects[I]) then\r\n ItemList.Objects[I].Free;\r\n inherited SetItemList(Value);\r\nend;\r\n\r\n//=== { TJvTimeParameter } ===================================================\r\n\r\nconstructor TJvTimeParameter.Create(AParameterList: TJvParameterList);\r\nbegin\r\n inherited Create(AParameterList);\r\n LabelArrangeMode := lamBefore;\r\nend;\r\n\r\nprocedure TJvTimeParameter.Assign(Source: TPersistent);\r\nbegin\r\n inherited Assign(Source);\r\n if Source is TJvTimeParameter then\r\n Format := TJvTimeParameter(Source).Format;\r\nend;\r\n\r\nfunction TJvTimeParameter.GetParameterNameExt: string;\r\nbegin\r\n Result := 'Time';\r\nend;\r\n\r\nprocedure TJvTimeParameter.CreateWinControl(AParameterParent: TWinControl);\r\nbegin\r\n SetWinControl (DynControlEngine.CreateTimeControl(Self, AParameterParent, GetParameterName));\r\nend;\r\n\r\nprocedure TJvTimeParameter.SetWinControlProperties;\r\nvar\r\n DynControlTime: IJvDynControlTime;\r\nbegin\r\n inherited SetWinControlProperties;\r\n if Supports(WinControl, IJvDynControlTime, DynControlTime) then\r\n DynControlTime.ControlSetFormat(Format);\r\nend;\r\n\r\n//=== { TJvDateTimeParameter } ===============================================\r\n\r\nconstructor TJvDateTimeParameter.Create(AParameterList: TJvParameterList);\r\nbegin\r\n inherited Create(AParameterList);\r\n LabelArrangeMode := lamBefore;\r\nend;\r\n\r\nprocedure TJvDateTimeParameter.Assign(Source: TPersistent);\r\nbegin\r\n inherited Assign(Source);\r\n if Source is TJvDateTimeParameter then\r\n begin\r\n Format := TJvDateTimeParameter(Source).Format;\r\n MaxDate := TJvDateTimeParameter(Source).MaxDate;\r\n MinDate := TJvDateTimeParameter(Source).MinDate;\r\n end;\r\nend;\r\n\r\nfunction TJvDateTimeParameter.GetParameterNameExt: string;\r\nbegin\r\n Result := 'DateTime';\r\nend;\r\n\r\nprocedure TJvDateTimeParameter.CreateWinControl(AParameterParent: TWinControl);\r\nbegin\r\n SetWinControl (DynControlEngine.CreateDateTimeControl(Self, AParameterParent, GetParameterName));\r\nend;\r\n\r\nprocedure TJvDateTimeParameter.SetWinControlProperties;\r\nvar\r\n DynControlDate: IJvDynControlDate;\r\nbegin\r\n inherited SetWinControlProperties;\r\n if Supports(WinControl, IJvDynControlDate, DynControlDate) then\r\n begin\r\n DynControlDate.ControlSetFormat(Format);\r\n DynControlDate.ControlSetMinDate(MinDate);\r\n DynControlDate.ControlSetMaxDate(MaxDate);\r\n end;\r\nend;\r\n\r\n//=== { TJvDateParameter } ===================================================\r\n\r\nconstructor TJvDateParameter.Create(AParameterList: TJvParameterList);\r\nbegin\r\n inherited Create(AParameterList);\r\n LabelArrangeMode := lamBefore;\r\nend;\r\n\r\nprocedure TJvDateParameter.Assign(Source: TPersistent);\r\nbegin\r\n inherited Assign(Source);\r\n if Source is TJvDateParameter then\r\n begin\r\n Format := TJvDateParameter(Source).Format;\r\n MinDate := TJvDateParameter(Source).MinDate;\r\n MaxDate := TJvDateParameter(Source).MaxDate;\r\n end;\r\nend;\r\n\r\nfunction TJvDateParameter.GetParameterNameExt: string;\r\nbegin\r\n Result := 'Date';\r\nend;\r\n\r\nprocedure TJvDateParameter.CreateWinControl(AParameterParent: TWinControl);\r\nbegin\r\n SetWinControl (DynControlEngine.CreateDateControl(Self, AParameterParent, GetParameterName));\r\nend;\r\n\r\nprocedure TJvDateParameter.SetWinControlProperties;\r\nvar\r\n DynControlDate: IJvDynControlDate;\r\nbegin\r\n inherited SetWinControlProperties;\r\n if Supports(WinControl, IJvDynControlDate, DynControlDate) then\r\n begin\r\n DynControlDate.ControlSetFormat(Format);\r\n DynControlDate.ControlSetMinDate(MinDate);\r\n DynControlDate.ControlSetMaxDate(MaxDate);\r\n end;\r\nend;\r\n\r\n//=== { TJvEditParameter } ===================================================\r\n\r\nconstructor TJvEditParameter.Create(AParameterList: TJvParameterList);\r\nbegin\r\n inherited Create(AParameterList);\r\n FPasswordChar := #0;\r\n FEditMask := '';\r\n FLabelWidth := 0;\r\n FEditWidth := 0;\r\n LabelArrangeMode := lamBefore;\r\nend;\r\n\r\nprocedure TJvEditParameter.Assign(Source: TPersistent);\r\nbegin\r\n inherited Assign(Source);\r\n if Source is TJvEditParameter then\r\n begin\r\n EditMask := TJvEditParameter(Source).EditMask;\r\n PasswordChar := TJvEditParameter(Source).PasswordChar;\r\n end;\r\nend;\r\n\r\nfunction TJvEditParameter.GetParameterNameExt: string;\r\nbegin\r\n Result := 'MaskEdit';\r\nend;\r\n\r\nprocedure TJvEditParameter.CreateWinControl(AParameterParent: TWinControl);\r\nvar\r\n DynCtrlEdit: IJvDynControlEdit;\r\nbegin\r\n SetWinControl (DynControlEngine.CreateEditControl(Self, AParameterParent, GetParameterName));\r\n if Supports(WinControl, IJvDynControlEdit, DynCtrlEdit) then\r\n begin\r\n DynCtrlEdit.ControlSetPasswordChar(PasswordChar);\r\n DynCtrlEdit.ControlSetEditMask(EditMask);\r\n end;\r\nend;\r\n\r\n//=== { TJvButtonEditParameter } =============================================\r\n\r\nfunction TJvButtonEditParameter.GetParameterNameExt: string;\r\nbegin\r\n Result := 'ButtonEdit';\r\nend;\r\n\r\nprocedure TJvButtonEditParameter.CreateWinControl(AParameterParent: TWinControl);\r\nvar\r\n DynCtrlEdit: IJvDynControlEdit;\r\nbegin\r\n SetWinControl (DynControlEngine.CreateButtonEditControl(Self, AParameterParent, GetParameterName, FOnClick));\r\n if Supports(WinControl, IJvDynControlEdit, DynCtrlEdit) then\r\n begin\r\n DynCtrlEdit.ControlSetPasswordChar(PasswordChar);\r\n DynCtrlEdit.ControlSetEditMask(EditMask);\r\n end;\r\nend;\r\n\r\nprocedure TJvButtonEditParameter.Assign(Source: TPersistent);\r\nbegin\r\n inherited Assign(Source);\r\n if Source is TJvButtonEditParameter then\r\n OnClick := TJvButtonEditParameter(Source).OnClick;\r\nend;\r\n\r\n//=== { TJvNumberEditParameter } =============================================\r\n\r\nprocedure TJvNumberEditParameter.Assign(Source: TPersistent);\r\nbegin\r\n inherited Assign(Source);\r\n if Source is TJvNumberEditParameter then\r\n EditorType := TJvNumberEditParameter(Source).EditorType;\r\nend;\r\n\r\n//=== { TJvIntegerEditParameter } ============================================\r\n\r\nconstructor TJvIntegerEditParameter.Create(AParameterList: TJvParameterList);\r\nbegin\r\n inherited Create(AParameterList);\r\n Required := True;\r\n MinValue := Low(Integer);\r\n MaxValue := High(Integer);\r\n Increment := 10;\r\nend;\r\n\r\nprocedure TJvIntegerEditParameter.CreateWinControl(AParameterParent: TWinControl);\r\nvar\r\n DynCtrlEdit: IJvDynControlEdit;\r\nbegin\r\n if (EditorType = netCalculate) and DynControlEngine.IsControlTypeRegistered(jctCalculateEdit) then\r\n SetWinControl (DynControlEngine.CreateCalculateControl(Self, AParameterParent, GetParameterName))\r\n else if (EditorType = netSpin) and DynControlEngine.IsControlTypeRegistered(jctSpinEdit) then\r\n SetWinControl (DynControlEngine.CreateSpinControl(Self, AParameterParent, GetParameterName))\r\n else\r\n SetWinControl (DynControlEngine.CreateEditControl(Self, AParameterParent, GetParameterName));\r\n if Supports(WinControl, IJvDynControlEdit, DynCtrlEdit) then\r\n begin\r\n DynCtrlEdit.ControlSetPasswordChar(PasswordChar);\r\n DynCtrlEdit.ControlSetEditMask(EditMask);\r\n end;\r\nend;\r\n\r\nprocedure TJvIntegerEditParameter.SetWinControlProperties;\r\nvar\r\n ITmpSpin: IJvDynControlSpin;\r\nbegin\r\n inherited SetWinControlProperties;\r\n if Supports(WinControl, IJvDynControlSpin, ITmpSpin) then\r\n begin\r\n ITmpSpin.ControlSetIncrement(Increment);\r\n ITmpSpin.ControlSetMinValue(MinValue);\r\n ITmpSpin.ControlSetMaxValue(MaxValue);\r\n ITmpSpin.ControlSetUseForInteger(True);\r\n end;\r\nend;\r\n\r\nprocedure TJvIntegerEditParameter.Assign(Source: TPersistent);\r\nbegin\r\n inherited Assign(Source);\r\n if Source is TJvIntegerEditParameter then\r\n begin\r\n MinValue := TJvIntegerEditParameter(Source).MinValue;\r\n MaxValue := TJvIntegerEditParameter(Source).MaxValue;\r\n end;\r\nend;\r\n\r\nfunction TJvIntegerEditParameter.IsDataValid(const AData: Variant; var vMsg:\r\n String): Boolean;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := Inherited IsDataValid(AData, vMsg);\r\n if Result and (VarToStr(AData) <> '') then\r\n begin\r\n try\r\n I := AData;\r\n if (I < MinValue) or (I > MaxValue) then\r\n begin\r\n vMsg:= Format(RsErrParameterMustBeBetween, [Caption, AData, IntToStr(MinValue), IntToStr(MaxValue)]);\r\n Result := False;\r\n end;\r\n except\r\n Result := False;\r\n vMsg := Format(RsErrParameterIsNotAValidNumber, [Caption, AData]);\r\n end;\r\n end;\r\nend;\r\n\r\n//=== { TJvDoubleEditParameter } =============================================\r\n\r\nconstructor TJvDoubleEditParameter.Create(AParameterList: TJvParameterList);\r\nbegin\r\n inherited Create(AParameterList);\r\n Required := True;\r\n // (rom) please use better values here (see JclMath)\r\n MinValue := -1E38;\r\n MaxValue := 1E38;\r\n Increment := 100;\r\nend;\r\n\r\nprocedure TJvDoubleEditParameter.CreateWinControl(AParameterParent: TWinControl);\r\nvar\r\n DynCtrlEdit: IJvDynControlEdit;\r\nbegin\r\n if (EditorType = netCalculate) and DynControlEngine.IsControlTypeRegistered(jctCalculateEdit) then\r\n SetWinControl (DynControlEngine.CreateCalculateControl(Self, AParameterParent, GetParameterName))\r\n else if (EditorType = netSpin) and DynControlEngine.IsControlTypeRegistered(jctSpinEdit) then\r\n SetWinControl (DynControlEngine.CreateSpinControl(Self, AParameterParent, GetParameterName))\r\n else\r\n SetWinControl (DynControlEngine.CreateEditControl(Self, AParameterParent, GetParameterName));\r\n if Supports(WinControl, IJvDynControlEdit, DynCtrlEdit) then\r\n begin\r\n DynCtrlEdit.ControlSetPasswordChar(PasswordChar);\r\n DynCtrlEdit.ControlSetEditMask(EditMask);\r\n end;\r\nend;\r\n\r\nprocedure TJvDoubleEditParameter.SetWinControlProperties;\r\nvar\r\n ITmpSpin: IJvDynControlSpin;\r\nbegin\r\n inherited SetWinControlProperties;\r\n if Supports(WinControl, IJvDynControlSpin, ITmpSpin) then\r\n begin\r\n ITmpSpin.ControlSetIncrement(Increment);\r\n ITmpSpin.ControlSetMinValue(MinValue);\r\n ITmpSpin.ControlSetMaxValue(MaxValue);\r\n ITmpSpin.ControlSetUseForInteger(True);\r\n end;\r\nend;\r\n\r\nprocedure TJvDoubleEditParameter.Assign(Source: TPersistent);\r\nbegin\r\n inherited Assign(Source);\r\n if Source is TJvDoubleEditParameter then\r\n begin\r\n MinValue := TJvDoubleEditParameter(Source).MinValue;\r\n MaxValue := TJvDoubleEditParameter(Source).MaxValue;\r\n end;\r\nend;\r\n\r\nfunction TJvDoubleEditParameter.IsDataValid(const AData: Variant; var vMsg:\r\n String): Boolean;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := Inherited IsDataValid(AData, vMsg);\r\n if Result and (VarToStr(AData) <> '') then\r\n begin\r\n try\r\n I := AData;\r\n if (I < MinValue) or (I > MaxValue) then\r\n begin\r\n vMsg:= Format(RsErrParameterMustBeBetween,\r\n [Caption, AData, FloatToStr(MinValue), FloatToStr(MaxValue)]);\r\n Result := False;\r\n end;\r\n except\r\n Result := False;\r\n vMsg := Format(RsErrParameterIsNotAValidNumber, [Caption, AData]);\r\n end;\r\n end;\r\nend;\r\n\r\n//=== { TJvFileNameParameter } ===============================================\r\n\r\nconstructor TJvFileNameParameter.Create(AParameterList: TJvParameterList);\r\nbegin\r\n inherited Create(AParameterList);\r\n LabelArrangeMode := lamBefore;\r\n FDialogOptions := [ofHideReadOnly, ofEnableSizing];\r\nend;\r\n\r\nprocedure TJvFileNameParameter.Assign(Source: TPersistent);\r\nbegin\r\n inherited Assign(Source);\r\n if Source is TJvFileNameParameter then\r\n begin\r\n DialogKind := TJvFileNameParameter(Source).DialogKind;\r\n DefaultExt := TJvFileNameParameter(Source).DefaultExt;\r\n Filter := TJvFileNameParameter(Source).Filter;\r\n FilterIndex := TJvFileNameParameter(Source).FilterIndex;\r\n InitialDir := TJvFileNameParameter(Source).InitialDir;\r\n DialogOptions := TJvFileNameParameter(Source).DialogOptions;\r\n DialogTitle := TJvFileNameParameter(Source).DialogTitle;\r\n end;\r\nend;\r\n\r\nfunction TJvFileNameParameter.GetParameterNameExt: string;\r\nbegin\r\n Result := 'FileNameEdit';\r\nend;\r\n\r\nprocedure TJvFileNameParameter.CreateWinControl(AParameterParent: TWinControl);\r\nbegin\r\n SetWinControl (DynControlEngine.CreateFileNameControl(Self, AParameterParent, GetParameterName));\r\nend;\r\n\r\nfunction TJvFileNameParameter.IsDataValid(const AData: Variant; var vMsg:\r\n String): Boolean;\r\nvar\r\n Data : Variant;\r\nbegin\r\n Data := Trim(AData);\r\n if Data = DefaultExt then\r\n Data := '';\r\n Result := Inherited IsDataValid(Data, vMsg);\r\n if Result then\r\n begin\r\n if Data <> '' then\r\n if ExtractFileExt(Data) = '' then\r\n if DefaultExt <> '' then\r\n if DefaultExt[1] = '.' then\r\n Data := Data + DefaultExt\r\n else\r\n Data := Data + '.' + DefaultExt;\r\n if (ofFileMustExist in DialogOptions) and not FileExists(Data) then\r\n begin\r\n vMsg := Format(RsErrParameterFileDoesNotExist, [Caption, Data]);\r\n Result := False;\r\n end\r\n else if (ofPathMustExist in DialogOptions) and\r\n (ExtractFilePath(Data) <> '') and\r\n not {$IFDEF RTL220_UP}SysUtils.{$ENDIF RTL220_UP}DirectoryExists(ExtractFilePath(Data)) then\r\n begin\r\n vMsg := Format(RsErrParameterDirectoryNotExist, [Caption, ExtractFilePath(Data)]);\r\n Result:= False;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvFileNameParameter.SetWinControlProperties;\r\nvar\r\n ITmpControlFileName: IJvDynControlFileName;\r\nbegin\r\n inherited SetWinControlProperties;\r\n if Supports(WinControl, IJvDynControlFileName, ITmpControlFileName) then\r\n begin\r\n ITmpControlFileName.ControlSetDialogKind(DialogKind);\r\n ITmpControlFileName.ControlSetDefaultExt(DefaultExt);\r\n ITmpControlFileName.ControlSetFilter(Filter);\r\n ITmpControlFileName.ControlSetFilterIndex(FilterIndex);\r\n ITmpControlFileName.ControlSetInitialDir(InitialDir);\r\n ITmpControlFileName.ControlSetDialogOptions(DialogOptions);\r\n ITmpControlFileName.ControlSetDialogTitle(DialogTitle);\r\n end;\r\nend;\r\n\r\nfunction TJvFileNameParameter.Validate(var AData: Variant): Boolean;\r\nbegin\r\n Result := Inherited Validate(AData);\r\n if Result then\r\n if (ofOverwritePrompt in DialogOptions) and FileExists(AData) then\r\n if DSADialogsMessageDlg(Format(RsErrParameterFileExistOverwrite, [Caption, AData]), mtConfirmation, [mbYes,\r\n mbNo], 0) = mrNo then\r\n Result := False;\r\nend;\r\n\r\n//=== { TJvDirectoryParameter } ==============================================\r\n\r\nconstructor TJvDirectoryParameter.Create(AParameterList: TJvParameterList);\r\nbegin\r\n inherited Create(AParameterList);\r\n LabelArrangeMode := lamBefore;\r\nend;\r\n\r\nprocedure TJvDirectoryParameter.Assign(Source: TPersistent);\r\nbegin\r\n inherited Assign(Source);\r\n if Source is TJvDirectoryParameter then\r\n begin\r\n InitialDir := TJvDirectoryParameter(Source).InitialDir;\r\n DialogOptions := TJvDirectoryParameter(Source).DialogOptions;\r\n DialogTitle := TJvDirectoryParameter(Source).DialogTitle;\r\n end;\r\nend;\r\n\r\nfunction TJvDirectoryParameter.GetParameterNameExt: string;\r\nbegin\r\n Result := 'DirectoryEdit';\r\nend;\r\n\r\nprocedure TJvDirectoryParameter.CreateWinControl(AParameterParent: TWinControl);\r\nbegin\r\n SetWinControl (DynControlEngine.CreateDirectoryControl(Self, AParameterParent, GetParameterName));\r\nend;\r\n\r\nfunction TJvDirectoryParameter.IsDataValid(const AData: Variant; var vMsg:\r\n String): Boolean;\r\nvar\r\n Data : Variant;\r\nbegin\r\n Data := Trim(AData);\r\n Result := Inherited IsDataValid(Data, vMsg);\r\n if Result then\r\n if not {$IFDEF RTL220_UP}SysUtils.{$ENDIF RTL220_UP}DirectoryExists(AData) and not (sdAllowCreate in DialogOptions) then\r\n begin\r\n vMsg := Format(RsErrParameterDirectoryNotExist, [Caption, AData]);\r\n Result := False;\r\n end;\r\nend;\r\n\r\nprocedure TJvDirectoryParameter.SetWinControlProperties;\r\nvar\r\n ITmpControlDirectory: IJvDynControlDirectory;\r\nbegin\r\n inherited SetWinControlProperties;\r\n if Supports(WinControl, IJvDynControlDirectory, ITmpControlDirectory) then\r\n begin\r\n ITmpControlDirectory.ControlSetDialogTitle(DialogTitle);\r\n ITmpControlDirectory.ControlSetDialogOptions(DialogOptions);\r\n ITmpControlDirectory.ControlSetInitialDir(InitialDir);\r\n end;\r\nend;\r\n\r\n///=== { TJvMemoParameter } ==================================================\r\n\r\nconstructor TJvMemoParameter.Create(AParameterList: TJvParameterList);\r\nbegin\r\n inherited Create(AParameterList);\r\n ScrollBars := ssNone;\r\n WantTabs := False;\r\n WantReturns := True;\r\n WordWrap := False;\r\nend;\r\n\r\nfunction TJvMemoParameter.GetParameterNameExt: string;\r\nbegin\r\n Result := 'Memo';\r\nend;\r\n\r\nprocedure TJvMemoParameter.CreateWinControl(AParameterParent: TWinControl);\r\nbegin\r\n SetWinControl (DynControlEngine.CreateMemoControl(Self, AParameterParent, GetParameterName));\r\nend;\r\n\r\nprocedure TJvMemoParameter.SetFontName(const Value: string);\r\nbegin\r\n if FFontName <> Value then\r\n begin\r\n FFontName := Value;\r\n SetWinControlProperties;\r\n end;\r\nend;\r\n\r\nprocedure TJvMemoParameter.SetScrollBars(const Value: TScrollStyle);\r\nbegin\r\n if FScrollBars <> Value then\r\n begin\r\n FScrollBars := Value;\r\n SetWinControlProperties;\r\n end;\r\nend;\r\n\r\nprocedure TJvMemoParameter.SetWantReturns(const Value: Boolean);\r\nbegin\r\n if FWantReturns <> Value then\r\n begin\r\n FWantReturns := Value;\r\n SetWinControlProperties;\r\n end;\r\nend;\r\n\r\nprocedure TJvMemoParameter.SetWantTabs(const Value: Boolean);\r\nbegin\r\n if FWantTabs <> Value then\r\n begin\r\n FWantTabs := Value;\r\n SetWinControlProperties;\r\n end;\r\nend;\r\n\r\nprocedure TJvMemoParameter.SetWinControlProperties;\r\nvar\r\n ITmpMemo: IJvDynControlMemo;\r\n ITmpFont: IJvDynControlFont;\r\nbegin\r\n inherited SetWinControlProperties;\r\n if FontName <> '' then\r\n if Supports(WinControl, IJvDynControlFont, ITmpFont) then\r\n ITmpFont.ControlFont.Name := FontName;\r\n if Supports(WinControl, IJvDynControlMemo, ITmpMemo) then\r\n begin\r\n ITmpMemo.ControlSetWantTabs(WantTabs);\r\n ITmpMemo.ControlSetWantReturns(WantReturns);\r\n ITmpMemo.ControlSetWordWrap(WordWrap);\r\n ITmpMemo.ControlSetScrollbars(ScrollBars);\r\n end;\r\nend;\r\n\r\nprocedure TJvMemoParameter.SetWordWrap(const Value: Boolean);\r\nbegin\r\n if FWordWrap <> Value then\r\n begin\r\n FWordWrap := Value;\r\n SetWinControlProperties;\r\n end;\r\nend;\r\n\r\n///=== { TJvRichEditParameter } ==============================================\r\n\r\nconstructor TJvRichEditParameter.Create(AParameterList: TJvParameterList);\r\nbegin\r\n inherited Create(AParameterList);\r\n ScrollBars := ssNone;\r\n WantTabs := False;\r\n WantReturns := True;\r\n WordWrap := False;\r\nend;\r\n\r\nfunction TJvRichEditParameter.GetParameterNameExt: string;\r\nbegin\r\n Result := 'RichEdit';\r\nend;\r\n\r\nprocedure TJvRichEditParameter.CreateWinControl(AParameterParent: TWinControl);\r\nbegin\r\n SetWinControl (DynControlEngine.CreateRichEditControl(Self, AParameterParent, GetParameterName));\r\nend;\r\n\r\nprocedure TJvRichEditParameter.SetWinControlProperties;\r\nvar\r\n ITmpMemo: IJvDynControlMemo;\r\n ITmpFont: IJvDynControlFont;\r\nbegin\r\n inherited SetWinControlProperties;\r\n if FontName <> '' then\r\n if Supports(WinControl, IJvDynControlFont, ITmpFont) then\r\n ITmpFont.ControlFont.Name := FontName;\r\n if Supports(WinControl, IJvDynControlMemo, ITmpMemo) then\r\n begin\r\n ITmpMemo.ControlSetWantTabs(WantTabs);\r\n ITmpMemo.ControlSetWantReturns(WantReturns);\r\n ITmpMemo.ControlSetWordWrap(WordWrap);\r\n ITmpMemo.ControlSetScrollbars(ScrollBars);\r\n end;\r\nend;\r\n\r\n///=== { TJvPageControlParameter } ==============================================\r\n\r\nconstructor TJvPageControlParameter.Create(AParameterList: TJvParameterList);\r\nbegin\r\n inherited Create(AParameterList);\r\n fHotTrack := True;\r\n fMultiline := True;\r\n fScrollOpposite := True;\r\n fTabIndex := 0;\r\n FRaggedRight := False;\r\n FPages := TStringList.Create;\r\nend;\r\n\r\ndestructor TJvPageControlParameter.Destroy;\r\nbegin\r\n FreeAndNil(FPages);\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvPageControlParameter.ArrangeControls;\r\nvar\r\n i: Integer;\r\n ITmpArrangePanel: IJvArrangePanel;\r\n w, h: Integer;\r\n c: TWinControl;\r\nbegin\r\n w := 0;\r\n h := 0;\r\n for i := 0 to Pages.Count - 1 do\r\n begin\r\n c := PageWinControl(i);\r\n if Supports(c, IJvArrangePanel, ITmpArrangePanel) then\r\n ITmpArrangePanel.ArrangeControls;\r\n if (ArrangeSettings.AutoSize in [asWidth, asBoth]) then\r\n if c.Width > w then\r\n w := c.Width;\r\n if (ArrangeSettings.AutoSize in [asHeight, asBoth]) then\r\n if c.Height > h then\r\n h := c.Height;\r\n end;\r\n if (ArrangeSettings.AutoSize in [asWidth, asBoth])\r\n and (w <> WinControl.Width) then\r\n WinControl.Width := w;\r\n if (ArrangeSettings.AutoSize in [asHeight, asBoth])\r\n and (h <> WinControl.Height) then\r\n WinControl.Height := h;\r\nend;\r\n\r\nprocedure TJvPageControlParameter.Assign(Source: TPersistent);\r\nbegin\r\n inherited Assign(Source);\r\n if Source is TJvPageControlParameter then\r\n begin\r\n HotTrack := TJvPageControlParameter(Source).HotTrack;\r\n Multiline := TJvPageControlParameter(Source).Multiline;\r\n ScrollOpposite := TJvPageControlParameter(Source).Scrollopposite;\r\n TabIndex := TJvPageControlParameter(Source).TabIndex;\r\n RaggedRight := TJvPageControlParameter(Source).RaggedRight;\r\n Pages.Assign(TJvPageControlParameter(Source).Pages);\r\n end;\r\nend;\r\n\r\nprocedure TJvPageControlParameter.CreateWinControlOnParent(ParameterParent:\r\n TWinControl);\r\nvar\r\n i: Integer;\r\n ITmpPageControl: IJvDynControlPageControl;\r\n Scrollbox: TScrollBox;\r\n Panel: TJvPanel;\r\nbegin\r\n SetWinControl (DynControlEngine.CreatePageControlControl(Self, ParameterParent,\r\n GetParameterName, Pages));\r\n if Height > 0 then\r\n WinControl.Height := Height;\r\n if Width > 0 then\r\n WinControl.Width := Width;\r\n Supports(WinControl, IJvDynControlPageControl, ITmpPageControl);\r\n for i := 0 to Pages.Count - 1 do\r\n begin\r\n Scrollbox := TScrollbox.Create(ParameterParent.Owner);\r\n Scrollbox.Parent := ITmpPageControl.ControlGetPage(Pages[i]);\r\n Scrollbox.Align := alClient;\r\n ScrollBox.AutoScroll := False;\r\n ScrollBox.BorderStyle := bsNone;\r\n {$IFDEF COMPILER10_UP}\r\n ScrollBox.ParentBackground := True;\r\n {$ENDIF COMPILER10_UP}\r\n Panel := TJvPanel.Create(ParameterParent.Owner);\r\n Panel.Name := GenerateUniqueComponentName(ParameterParent.Owner, Panel, GetParameterName + '_' + Pages[i]);\r\n Panel.ArrangeSettings := ArrangeSettings;\r\n Panel.BevelInner := bvNone;\r\n Panel.BevelOuter := bvNone;\r\n Panel.Parent := Scrollbox;\r\n Panel.Align := alTop;\r\n Panel.Visible := True;\r\n Panel.Caption := '';\r\n Panel.Color := Color;\r\n Panel.OnResizeParent := RearrangePageControl;\r\n Panel.Parent := Scrollbox;\r\n Pages.Objects[i] := Panel;\r\n end;\r\nend;\r\n\r\nprocedure TJvPageControlParameter.DisableArrange;\r\nvar\r\n i: Integer;\r\n ITmpArrangePanel: IJvArrangePanel;\r\nbegin\r\n for i := 0 to Pages.Count - 1 do\r\n if Supports(PageWinControl(i), IJvArrangePanel, ITmpArrangePanel) then\r\n ITmpArrangePanel.DisableArrange;\r\nend;\r\n\r\nprocedure TJvPageControlParameter.EnableArrange;\r\nvar\r\n i: Integer;\r\n ITmpArrangePanel: IJvArrangePanel;\r\nbegin\r\n for i := 0 to Pages.Count - 1 do\r\n if Supports(PageWinControl(i), IJvArrangePanel, ITmpArrangePanel) then\r\n ITmpArrangePanel.EnableArrange;\r\nend;\r\n\r\nfunction TJvPageControlParameter.GetParameterNameExt: string;\r\nbegin\r\n Result := 'PageControl';\r\nend;\r\n\r\nfunction TJvPageControlParameter.PageWinControl(Index: Integer): TWinControl;\r\nbegin\r\n if Assigned(Pages.Objects[Index]) and (Pages.Objects[Index] is TWinControl) then\r\n Result := TWinControl(Pages.Objects[Index])\r\n else\r\n Result := nil;\r\nend;\r\n\r\nprocedure TJvPageControlParameter.RearrangePageControl(Sender: TObject; nLeft,\r\n nTop, nWidth, nHeight: Integer);\r\nbegin\r\n if Assigned(Sender) and (Sender is TWinControl) then\r\n begin\r\n if (ArrangeSettings.AutoSize in [asWidth, asBoth])\r\n and (TWinControl(Sender).Width <> nWidth + 5) then\r\n TWinControl(Sender).Width := nWidth + 5;\r\n if (ArrangeSettings.AutoSize in [asHeight, asBoth])\r\n and (TWinControl(Sender).Height <> nHeight + 45) then\r\n TWinControl(Sender).Height := nHeight + 45;\r\n end;\r\nend;\r\n\r\nprocedure TJvPageControlParameter.SetPages(Value: TStringList);\r\nbegin\r\n FPages.Assign(Value);\r\nend;\r\n\r\nprocedure TJvPageControlParameter.SetWinControlProperties;\r\nvar\r\n ITmpTabControl: IJvDynControlTabControl;\r\n ITmpArrangePanel: IJvArrangePanel;\r\n i: Integer;\r\nbegin\r\n inherited SetWinControlProperties;\r\n if Supports(WinControl, IJvDynControlTabControl, ITmpTabControl) then\r\n begin\r\n ITmpTabControl.ControlSetRaggedRight(RaggedRight);\r\n ITmpTabControl.ControlSetMultiline(Multiline);\r\n ITmpTabControl.ControlSetScrollOpposite(ScrollOpposite);\r\n ITmpTabControl.ControlSetHotTrack(HotTrack);\r\n end;\r\n for i := 0 to Pages.Count - 1 do\r\n if Supports(PageWinControl(i), IJvArrangePanel, ITmpArrangePanel) then\r\n ITmpArrangePanel.ArrangeSettings := ArrangeSettings;\r\nend;\r\n\r\n//=== { TJvCheckComboBoxParameter } ===============================================\r\n\r\nconstructor TJvCheckComboBoxParameter.Create(AParameterList: TJvParameterList);\r\nbegin\r\n inherited Create(AParameterList);\r\n LabelArrangeMode := lamBefore;\r\n FSorted := False;\r\n FDelimiter := ';';\r\nend;\r\n\r\nprocedure TJvCheckComboBoxParameter.Assign(Source: TPersistent);\r\nbegin\r\n inherited Assign(Source);\r\n if Source is TJvCheckComboBoxParameter then\r\n begin\r\n Sorted := TJvCheckComboBoxParameter(Source).Sorted;\r\n Delimiter := TJvCheckComboBoxParameter(Source).Delimiter;\r\n end;\r\nend;\r\n\r\nfunction TJvCheckComboBoxParameter.GetParameterNameExt: string;\r\nbegin\r\n Result := 'CheckComboBox';\r\nend;\r\n\r\nprocedure TJvCheckComboBoxParameter.GetData;\r\nbegin\r\n if Assigned(WinControl) then\r\n Value := WinControlData;\r\nend;\r\n\r\nprocedure TJvCheckComboBoxParameter.SetData;\r\nbegin\r\n if Assigned(WinControl) then\r\n WinControlData := Value;\r\nend;\r\n\r\nprocedure TJvCheckComboBoxParameter.CreateWinControl(AParameterParent: TWinControl);\r\nbegin\r\n SetWinControl (DynControlEngine.CreateCheckComboBoxControl(Self, AParameterParent,\r\n GetParameterName, ItemList, Delimiter));\r\nend;\r\n\r\nprocedure TJvCheckComboBoxParameter.SetWinControlProperties;\r\nvar\r\n ITmpItems: IJvDynControlItems;\r\n ITmpCheckComboBox: IJvDynControlCheckComboBox;\r\nbegin\r\n inherited SetWinControlProperties;\r\n if Supports(WinControl, IJvDynControlItems, ITmpItems) then\r\n ITmpItems.ControlSetSorted(Sorted);\r\n if Supports(WinControl, IJvDynControlCheckComboBox, ITmpCheckComboBox) then\r\n ITmpCheckComboBox.ControlSetDelimiter(Delimiter);\r\nend;\r\n\r\nfunction TJvCheckComboBoxParameter.GetWinControlData: Variant;\r\nbegin\r\n if Assigned(JvDynControlData) then\r\n Result := JvDynControlData.ControlValue\r\n else\r\n Result := null;\r\nend;\r\n\r\nprocedure TJvCheckComboBoxParameter.SetWinControlData(Value: Variant);\r\nbegin\r\n if Assigned(JvDynControlData) then\r\n JvDynControlData.ControlValue := Value;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n {$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvParameterListTools.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nwithOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Initial Developer of the Original Code is Jens Fudickar [jens dott fudickar att oratool dott de]\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\nJens Fudickar [jens dott fudickar att oratool dott de]\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvParameterListTools.pas 12461 2009-08-14 17:21:33Z obones $\r\n\r\nunit JvParameterListTools;\r\n\r\n{$I jvcl.inc}\r\n{$I crossplatform.inc}\r\n\r\ninterface\r\n\r\n{$IFDEF UNITVERSIONING}\r\nuses\r\n JclUnitVersioning;\r\n{$ENDIF UNITVERSIONING}\r\n\r\nfunction ParameterListRadioGroupBox(SelectList: string;\r\n Caption: string = ''; Default: Integer = 0): string;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvParameterListTools.pas $';\r\n Revision: '$Revision: 12461 $';\r\n Date: '$Date: 2009-08-14 19:21:33 +0200 (ven. 14 août 2009) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n Classes, SysUtils,\r\n JvParameterList, JvParameterListParameter, JvResources;\r\n\r\nfunction ParameterListRadioGroupBox(SelectList: string;\r\n Caption: string = ''; Default: Integer = 0): string;\r\nconst\r\n cSelectionType = 'SelectionType';\r\nvar\r\n ParameterList: TJvParameterList;\r\n Parameter: TJvRadioGroupParameter;\r\n S: TStringList;\r\n I: Integer;\r\n\r\n procedure InsertParameter(ItemText: string);\r\n begin\r\n if Trim(ItemText) = '' then\r\n Exit;\r\n Parameter.ItemList.Add(ItemText);\r\n Parameter.Height := Parameter.Height + 15;\r\n end;\r\n\r\nbegin\r\n Result := '';\r\n if SelectList = '' then\r\n Exit;\r\n ParameterList := TJvParameterList.Create(nil);\r\n S := TStringList.Create;\r\n try\r\n ParameterList.Messages.Caption := RsSelectCaption;\r\n S.Text := SelectList;\r\n if S.Count = 1 then\r\n begin\r\n Result := S[0];\r\n Exit;\r\n end;\r\n Parameter := TJvRadioGroupParameter.Create(ParameterList);\r\n Parameter.SearchName := cSelectionType;\r\n Parameter.Caption := Caption;\r\n Parameter.ItemIndex := 0;\r\n Parameter.Width := 200;\r\n Parameter.Height := 30;\r\n for I := 0 to S.Count - 1 do\r\n InsertParameter(S[I]);\r\n Parameter.ItemIndex := Default;\r\n ParameterList.AddParameter(Parameter);\r\n if (Parameter.ItemIndex < 0) or\r\n (Parameter.ItemIndex >= Parameter.ItemList.Count) then\r\n Parameter.ItemIndex := 0;\r\n if Parameter.ItemList.Count = 1 then\r\n Result := Parameter.ItemList[0]\r\n else\r\n if ParameterList.ShowParameterDialog then\r\n Result :=\r\n TJvRadioGroupParameter(ParameterList.ParameterbyName(cSelectionType)).AsString;\r\n finally\r\n ParameterList.Free;\r\n S.Free;\r\n end;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvParserForm.dfm", "content": "object JvHTMLParserForm: TJvHTMLParserForm\r\n Tag = 1\r\n Left = 437\r\n Top = 279\r\n BorderIcons = [biSystemMenu]\r\n BorderStyle = bsSingle\r\n Caption = 'Parser - Edit '\r\n ClientHeight = 242\r\n ClientWidth = 423\r\n Color = clBtnFace\r\n Font.Charset = DEFAULT_CHARSET\r\n Font.Color = clWindowText\r\n Font.Height = -11\r\n Font.Name = 'MS Sans Serif'\r\n Font.Style = []\r\n Icon.Data = {\r\n 0000010001001010100001001000280100001600000028000000100000002000\r\n 00000100040000000000C0000000000000000000000000000000000000000000\r\n 0000000080000080000000808000800000008000800080800000C0C0C0008080\r\n 80000000FF0000FF000000FFFF00FF000000FF00FF00FFFF0000FFFFFF000000\r\n 00000000000000000BBBB0000000000BB000BB000000000BB0000B000000000B\r\n BB000BB00000000BBB000BB00000000000000BB00000000000000BB000000000\r\n 00000BB00000000000000BB00000000000000BB00000000000000BB000000000\r\n 00000BB0000000000000BBBB00000000000BBBBBB0000000000000000000FFFF\r\n 0000F87F0000E73F0000E7BF0000E39F0000E39F0000FF9F0000FF9F0000FF9F\r\n 0000FF9F0000FF9F0000FF9F0000FF9F0000FF0F0000FE070000FFFF0000}\r\n OldCreateOrder = False\r\n Position = poScreenCenter\r\n ShowHint = True\r\n PixelsPerInch = 96\r\n TextHeight = 13\r\n object ListBox1: TListBox\r\n Left = 8\r\n Top = 120\r\n Width = 321\r\n Height = 117\r\n ItemHeight = 13\r\n TabOrder = 4\r\n OnClick = ListBox1Click\r\n end\r\n object GroupBox1: TGroupBox\r\n Left = 8\r\n Top = 10\r\n Width = 407\r\n Height = 107\r\n Caption = ' Properties '\r\n Enabled = False\r\n ParentShowHint = False\r\n ShowHint = True\r\n TabOrder = 5\r\n object Label1: TLabel\r\n Left = 14\r\n Top = 26\r\n Width = 41\r\n Height = 13\r\n Caption = 'Keyword'\r\n end\r\n object Label2: TLabel\r\n Left = 12\r\n Top = 51\r\n Width = 44\r\n Height = 13\r\n Caption = 'Start Tag'\r\n end\r\n object Label3: TLabel\r\n Left = 204\r\n Top = 26\r\n Width = 41\r\n Height = 13\r\n Caption = 'End Tag'\r\n end\r\n object Label4: TLabel\r\n Left = 204\r\n Top = 51\r\n Width = 41\r\n Height = 13\r\n Hint = 'Where the start text must be'\r\n Caption = 'Must be '\r\n end\r\n object Label5: TLabel\r\n Left = 12\r\n Top = 78\r\n Width = 45\r\n Height = 13\r\n Caption = 'Take text'\r\n end\r\n object edKeyword: TEdit\r\n Left = 66\r\n Top = 22\r\n Width = 115\r\n Height = 21\r\n Hint = \r\n 'Put here the keyword'#13#10'you want the component to send'#13#10'when he ha' +\r\n 's found this item'\r\n TabOrder = 0\r\n OnChange = edKeywordChange\r\n end\r\n object edStartTag: TEdit\r\n Left = 66\r\n Top = 47\r\n Width = 115\r\n Height = 21\r\n Hint = 'Put here the string that'#13#10'is just before the part'#13#10'you want'\r\n TabOrder = 1\r\n OnChange = edStartTagChange\r\n end\r\n object edEndTag: TEdit\r\n Left = 256\r\n Top = 22\r\n Width = 115\r\n Height = 21\r\n Hint = 'Put here the tag you want to find '#13#10'to end the tag'\r\n TabOrder = 2\r\n OnChange = edEndTagChange\r\n end\r\n object cbTakeText: TComboBox\r\n Left = 66\r\n Top = 74\r\n Width = 305\r\n Height = 21\r\n Hint = 'Tell the component'#13#10'which part you want of the string'\r\n TabOrder = 4\r\n Text = 'Between limits'\r\n OnChange = cbTakeTextChange\r\n Items.Strings = (\r\n 'Between limits'\r\n 'All before start tag'\r\n 'All after start tag'\r\n 'The whole line if respecting the condition')\r\n end\r\n object edMustBe: TEdit\r\n Left = 256\r\n Top = 46\r\n Width = 115\r\n Height = 21\r\n Hint = \r\n 'Put here the position of the start tag'#13#10#13#10'1 if you don'#39't care, '#13 +\r\n #10'0 if it can'#39't be in the string, '#13#10'1 if you want it in the first' +\r\n ' position'#13#10'2 if you want it in the second position'#13#10'....'\r\n TabOrder = 3\r\n Text = '-1'\r\n OnChange = edMustBeChange\r\n end\r\n end\r\n object btnAdd: TButton\r\n Left = 339\r\n Top = 120\r\n Width = 75\r\n Height = 25\r\n Hint = 'Add an item to the list'\r\n Caption = '&Add'\r\n TabOrder = 3\r\n OnClick = Button1Click\r\n end\r\n object btnRemove: TButton\r\n Left = 339\r\n Top = 152\r\n Width = 75\r\n Height = 25\r\n Hint = 'Delete the selected item '#13#10'from the list'\r\n Caption = '&Remove'\r\n TabOrder = 2\r\n OnClick = Button2Click\r\n end\r\n object OkBtn: TButton\r\n Left = 339\r\n Top = 184\r\n Width = 75\r\n Height = 25\r\n Hint = 'Apply changes'\r\n Caption = '&OK'\r\n Default = True\r\n ModalResult = 1\r\n TabOrder = 0\r\n OnClick = OkBtnClick\r\n end\r\n object CancelBtn: TButton\r\n Left = 339\r\n Top = 216\r\n Width = 75\r\n Height = 25\r\n Hint = 'Cancel Changes'\r\n Cancel = True\r\n Caption = '&Cancel'\r\n ModalResult = 2\r\n TabOrder = 1\r\n OnClick = CancelBtnClick\r\n end\r\nend\r\n" }, { "path": "External/Jedi/Jvcl/run/JvParserForm.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvParserForm.PAS, released on 2001-02-28.\r\n\r\nThe Initial Developer of the Original Code is Sbastien Buysse [sbuysse att buypin dott com]\r\nPortions created by Sbastien Buysse are Copyright (C) 2001 Sbastien Buysse.\r\nAll Rights Reserved.\r\n\r\nContributor(s): Michael Beck [mbeck att bigfoot dott com].\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvParserForm.pas 13104 2011-09-07 06:50:43Z obones $\r\n\r\nunit JvParserForm;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, // inline\r\n SysUtils, Classes, Controls, Forms, StdCtrls,\r\n JvTypes, JvComponent;\r\n\r\ntype\r\n TJvHTMLParserForm = class(TJvForm)\r\n ListBox1: TListBox;\r\n GroupBox1: TGroupBox;\r\n edKeyword: TEdit;\r\n Label1: TLabel;\r\n edStartTag: TEdit;\r\n Label2: TLabel;\r\n edEndTag: TEdit;\r\n Label3: TLabel;\r\n Label4: TLabel;\r\n Label5: TLabel;\r\n cbTakeText: TComboBox;\r\n edMustBe: TEdit;\r\n btnAdd: TButton;\r\n btnRemove: TButton;\r\n OkBtn: TButton;\r\n CancelBtn: TButton;\r\n procedure edKeywordChange(Sender: TObject);\r\n procedure Button1Click(Sender: TObject);\r\n procedure ListBox1Click(Sender: TObject);\r\n procedure Button2Click(Sender: TObject);\r\n procedure edStartTagChange(Sender: TObject);\r\n procedure edEndTagChange(Sender: TObject);\r\n procedure cbTakeTextChange(Sender: TObject);\r\n procedure edMustBeChange(Sender: TObject);\r\n procedure OkBtnClick(Sender: TObject);\r\n procedure CancelBtnClick(Sender: TObject);\r\n public\r\n procedure LoadFromStr(Value: TStrings);\r\n procedure SaveToStr(Value: TStrings);\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvParserForm.pas $';\r\n Revision: '$Revision: 13104 $';\r\n Date: '$Date: 2011-09-07 08:50:43 +0200 (mer. 07 sept. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n Dialogs, JvHtmlParser, JvResources;\r\n\r\n{$R *.dfm}\r\n\r\nprocedure TJvHTMLParserForm.edKeywordChange(Sender: TObject);\r\nbegin\r\n if ListBox1.ItemIndex <> -1 then\r\n ListBox1.Items[ListBox1.ItemIndex] := (Sender as TEdit).Text;\r\nend;\r\n\r\nprocedure TJvHTMLParserForm.Button1Click(Sender: TObject);\r\nvar\r\n Ob: TJvParserInfo;\r\nbegin\r\n Ob := TJvParserInfo.Create;\r\n Ob.StartTag := '';\r\n Ob.EndTag := '';\r\n Ob.MustBe := -1;\r\n Ob.TakeText := 0;\r\n ListBox1.ItemIndex := ListBox1.Items.AddObject(RsNewObject, TObject(Ob));\r\n ListBox1Click(Sender);\r\n edKeyword.SetFocus;\r\n edKeyword.SelectAll;\r\nend;\r\n\r\nprocedure TJvHTMLParserForm.ListBox1Click(Sender: TObject);\r\nvar\r\n Ob: TJvParserInfo;\r\nbegin\r\n GroupBox1.Enabled := True;\r\n Ob := TJvParserInfo(ListBox1.Items.Objects[ListBox1.ItemIndex]);\r\n edKeyword.Text := ListBox1.Items[ListBox1.ItemIndex];\r\n edStartTag.Text := Ob.StartTag;\r\n edEndTag.Text := Ob.EndTag;\r\n edMustBe.Text := IntToStr(Ob.MustBe);\r\n cbTakeText.ItemIndex := Ob.TakeText;\r\nend;\r\n\r\nprocedure TJvHTMLParserForm.Button2Click(Sender: TObject);\r\nvar\r\n I: Integer;\r\nbegin\r\n if ListBox1.ItemIndex <> -1 then\r\n begin\r\n I := ListBox1.ItemIndex;\r\n ListBox1.Items.Delete(I);\r\n if ListBox1.Items.Count >= I then\r\n Dec(I);\r\n if I >= 0 then\r\n begin\r\n ListBox1.ItemIndex := I;\r\n ListBox1Click(Sender);\r\n edKeyword.SetFocus;\r\n edKeyword.SelectAll;\r\n end\r\n else\r\n GroupBox1.Enabled := False;\r\n end;\r\nend;\r\n\r\nprocedure TJvHTMLParserForm.edStartTagChange(Sender: TObject);\r\nbegin\r\n if ListBox1.ItemIndex <> -1 then\r\n TJvParserInfo(ListBox1.Items.Objects[ListBox1.ItemIndex]).StartTag := (Sender as TEdit).Text;\r\nend;\r\n\r\nprocedure TJvHTMLParserForm.edEndTagChange(Sender: TObject);\r\nbegin\r\n if ListBox1.ItemIndex <> -1 then\r\n TJvParserInfo(ListBox1.Items.Objects[ListBox1.ItemIndex]).EndTag := (Sender as TEdit).Text;\r\nend;\r\n\r\nprocedure TJvHTMLParserForm.LoadFromStr(Value: TStrings);\r\nvar\r\n I: Integer;\r\n Ob: TJvParserInfo;\r\n Cap: string;\r\nbegin\r\n I := 0;\r\n while I < Value.Count do\r\n begin\r\n Ob := TJvParserInfo.Create;\r\n try\r\n Cap := Value[I];\r\n Inc(I);\r\n Ob.StartTag := Value[I];\r\n Inc(I);\r\n Ob.EndTag := Value[I];\r\n Inc(I);\r\n Ob.MustBe := StrToInt(Value[I]);\r\n Inc(I);\r\n Ob.TakeText := StrToInt(Value[I]);\r\n Inc(I);\r\n finally\r\n ListBox1.Items.AddObject(Cap, TObject(Ob));\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvHTMLParserForm.cbTakeTextChange(Sender: TObject);\r\nbegin\r\n if ListBox1.ItemIndex <> -1 then\r\n TJvParserInfo(ListBox1.Items.Objects[ListBox1.ItemIndex]).TakeText := (Sender as TComboBox).ItemIndex;\r\nend;\r\n\r\nprocedure TJvHTMLParserForm.edMustBeChange(Sender: TObject);\r\nvar\r\n I: Integer;\r\nbegin\r\n I := 0;\r\n try\r\n I := StrToInt((Sender as TEdit).Text);\r\n except\r\n Beep;\r\n end;\r\n if ListBox1.ItemIndex <> -1 then\r\n TJvParserInfo(ListBox1.Items.Objects[ListBox1.ItemIndex]).MustBe := I;\r\nend;\r\n\r\nprocedure TJvHTMLParserForm.OkBtnClick(Sender: TObject);\r\nbegin\r\n Tag := 0;\r\n ModalResult := mrOK;\r\n Close;\r\nend;\r\n\r\nprocedure TJvHTMLParserForm.CancelBtnClick(Sender: TObject);\r\nbegin\r\n Tag := 1;\r\n ModalResult := mrCancel;\r\n Close;\r\nend;\r\n\r\nprocedure TJvHTMLParserForm.SaveToStr(Value: TStrings);\r\nvar\r\n I: Integer;\r\nbegin\r\n// ShowMessage('TFormParsers.SaveToStr');\r\n Value.Clear;\r\n for I := 0 to ListBox1.Items.Count - 1 do\r\n begin\r\n Value.Add(ListBox1.Items[I]);\r\n Value.Add(TJvParserInfo(ListBox1.Items.Objects[I]).StartTag);\r\n Value.Add(TJvParserInfo(ListBox1.Items.Objects[I]).EndTag);\r\n Value.Add(IntToStr(TJvParserInfo(ListBox1.Items.Objects[I]).MustBe));\r\n Value.Add(IntToStr(TJvParserInfo(ListBox1.Items.Objects[I]).TakeText));\r\n end;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvPatchFile.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvPatchFile.PAS, released on 2001-02-28.\r\n\r\nThe Initial Developer of the Original Code is Sbastien Buysse [sbuysse att buypin dott com]\r\nPortions created by Sbastien Buysse are Copyright (C) 2001 Sbastien Buysse.\r\nAll Rights Reserved.\r\n\r\nContributor(s): Michael Beck [mbeck att bigfoot dott com].\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvPatchFile.pas 13104 2011-09-07 06:50:43Z obones $\r\n\r\nunit JvPatchFile;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n SysUtils, Classes,\r\n JvTypes, JvComponentBase;\r\n\r\ntype\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64 or pidOSX32)]\r\n {$ENDIF RTL230_UP}\r\n TJvPatchFile = class(TJvComponent)\r\n private\r\n FEndFile: TFileName;\r\n FStartFile: TFileName;\r\n FDifferences: TStringList;\r\n FChangeInFile: Boolean;\r\n FPos: Integer;\r\n FPass: string;\r\n function Decrypt(Value: Byte): Byte;\r\n function GetDifferences: TStrings;\r\n procedure SetDifferences(Value: TStrings);\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n published\r\n function Patch(const Password: string = ''): Boolean;\r\n function IsPatched(const FileName: string): Boolean;\r\n function IsPatchable(const FileName: string): Boolean;\r\n property StartFile: TFileName read FStartFile write FStartFile;\r\n property EndFile: TFileName read FEndFile write FEndFile;\r\n property ChangeInFile: Boolean read FChangeInFile write FChangeInFile default True;\r\n property Differences: TStrings read GetDifferences write SetDifferences;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvPatchFile.pas $';\r\n Revision: '$Revision: 13104 $';\r\n Date: '$Date: 2011-09-07 08:50:43 +0200 (mer. 07 sept. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\n\r\nconstructor TJvPatchFile.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FDifferences := TStringList.Create;\r\n FChangeInFile := True;\r\nend;\r\n\r\ndestructor TJvPatchFile.Destroy;\r\nbegin\r\n FDifferences.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJvPatchFile.Decrypt(Value: Byte): Byte;\r\nbegin\r\n if FPass = '' then\r\n Result := Value\r\n else\r\n begin\r\n FPos := (FPos + 1) mod Length(FPass);\r\n Result := Value xor Byte(FPass[FPos + 1]);\r\n end;\r\nend;\r\n\r\nfunction TJvPatchFile.GetDifferences: TStrings;\r\nbegin\r\n Result := FDifferences;\r\nend;\r\n\r\nprocedure TJvPatchFile.SetDifferences(Value: TStrings);\r\nbegin\r\n FDifferences.Assign(Value);\r\nend;\r\n\r\nfunction TJvPatchFile.IsPatchable(const FileName: string): Boolean;\r\nvar\r\n F: file of Byte;\r\nbegin\r\n Result := False;\r\n if FileExists(FileName) then\r\n begin\r\n AssignFile(F, FileName);\r\n Reset(F);\r\n Result := (FDifferences.Count > 3) and (FileSize(F) = StrToInt(FDifferences[2]));\r\n CloseFile(F);\r\n end;\r\nend;\r\n\r\nfunction TJvPatchFile.IsPatched(const FileName: string): Boolean;\r\nvar\r\n F: file of Byte;\r\nbegin\r\n Result := False;\r\n if FileExists(FileName) then\r\n begin\r\n AssignFile(F, FileName);\r\n Reset(F);\r\n Result := (FDifferences.Count > 3) and (FileSize(F) = StrToInt(FDifferences[3]));\r\n CloseFile(F);\r\n end;\r\nend;\r\n\r\nfunction TJvPatchFile.Patch(const Password: string): Boolean;\r\nvar\r\n I: Integer;\r\n Ind, Tmp: Longint;\r\n C: Byte;\r\n Bytes: array [0..65000] of Byte;\r\n T, EndT: TFileStream;\r\n T2: TMemoryStream;\r\nbegin\r\n FPos := -1;\r\n FPass := Password;\r\n\r\n //patch it !:)\r\n Result := False;\r\n if (FDifferences.Count = 0) or (FStartFile = '') or not FileExists(FStartFile) then\r\n Exit;\r\n\r\n T := TFileStream.Create(FStartFile, fmOpenRead or fmShareDenyWrite);\r\n T2 := TMemoryStream.Create;\r\n\r\n if (FDifferences.Count > 3) and (T.Size = StrToInt(FDifferences[2])) then\r\n begin\r\n Result := True;\r\n I := 4;\r\n while I < FDifferences.Count do\r\n begin\r\n if (Length(FDifferences[I]) > 2) and (Pos('|', FDifferences[I]) <> 0) then\r\n begin\r\n Ind := StrToInt(Copy(FDifferences[I], 1, Pos('|', FDifferences[I]) - 1));\r\n while Ind > 65000 do\r\n begin\r\n T.Read(Bytes, 60000);\r\n T2.Write(Bytes, 60000);\r\n Dec(Ind, 60000);\r\n end;\r\n T.Read(Bytes, Ind - 1);\r\n T.Read(C, 1);\r\n T2.Write(Bytes, Ind - 1);\r\n C := Byte(FDifferences[I][Pos('|', FDifferences[I]) + 1]);\r\n C := Decrypt(C);\r\n T2.Write(C, 1);\r\n end\r\n else\r\n if Length(FDifferences[I]) = 1 then\r\n begin\r\n //File is greater\r\n T.Position := T2.Position;\r\n while T.Position < T.Size do\r\n begin\r\n Ind := T.Read(Bytes, 10000);\r\n T2.Write(Bytes, Ind);\r\n end;\r\n C := Byte(FDifferences[I][1]);\r\n C := Decrypt(C);\r\n T2.Write(C, 1);\r\n end\r\n else\r\n if Pos('%', FDifferences[I]) = 4 then\r\n begin\r\n //File is smaller\r\n Ind := StrToInt(Copy(FDifferences[I], Pos('%', FDifferences[I]) + 1, Length(FDifferences[I])));\r\n while T.Position < Ind do\r\n begin\r\n Tmp := T.Read(Bytes, 10000);\r\n if Tmp + T.Position > Ind then\r\n T2.Write(Bytes, T2.Position - Ind)\r\n else\r\n T2.Write(Bytes, Tmp);\r\n end;\r\n end;\r\n Inc(I);\r\n end;\r\n T.Free;\r\n if FChangeInFile then\r\n EndT := TFileStream.Create(FStartFile, fmCreate or fmShareExclusive)\r\n else\r\n EndT := TFileStream.Create(FEndFile, fmCreate or fmShareExclusive);\r\n T2.Position := 0;\r\n EndT.CopyFrom(T2, T2.Size);\r\n EndT.Free;\r\n end\r\n else\r\n T.Free;\r\n T2.Free;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvPatchForm.dfm", "content": "object PatchFrm: TPatchFrm\r\n Left = 419\r\n Top = 183\r\n BorderStyle = bsDialog\r\n Caption = 'Patcher Editor'\r\n ClientHeight = 144\r\n ClientWidth = 401\r\n Color = clBtnFace\r\n Font.Charset = DEFAULT_CHARSET\r\n Font.Color = clWindowText\r\n Font.Height = -11\r\n Font.Name = 'MS Sans Serif'\r\n Font.Style = []\r\n OldCreateOrder = False\r\n OnCreate = FormCreate\r\n OnDestroy = FormDestroy\r\n PixelsPerInch = 96\r\n TextHeight = 13\r\n object GroupBox1: TGroupBox\r\n Left = 4\r\n Top = 2\r\n Width = 392\r\n Height = 97\r\n Anchors = [akLeft, akTop, akRight, akBottom]\r\n TabOrder = 0\r\n object Label1: TLabel\r\n Left = 9\r\n Top = 18\r\n Width = 37\r\n Height = 13\r\n Caption = '&Source:'\r\n FocusControl = edSource\r\n end\r\n object Label2: TLabel\r\n Left = 9\r\n Top = 44\r\n Width = 56\r\n Height = 13\r\n Caption = '&Destination:'\r\n FocusControl = edDest\r\n end\r\n object Label3: TLabel\r\n Left = 9\r\n Top = 70\r\n Width = 49\r\n Height = 13\r\n Caption = '&Password:'\r\n FocusControl = edPassword\r\n end\r\n object edPassword: TEdit\r\n Left = 68\r\n Top = 66\r\n Width = 315\r\n Height = 21\r\n Anchors = [akLeft, akTop, akRight]\r\n TabOrder = 4\r\n end\r\n object edSource: TEdit\r\n Left = 68\r\n Top = 14\r\n Width = 285\r\n Height = 21\r\n Anchors = [akLeft, akTop, akRight]\r\n TabOrder = 0\r\n end\r\n object edDest: TEdit\r\n Left = 68\r\n Top = 40\r\n Width = 285\r\n Height = 21\r\n Anchors = [akLeft, akTop, akRight]\r\n TabOrder = 2\r\n end\r\n object btnSrc: TButton\r\n Left = 360\r\n Top = 16\r\n Width = 21\r\n Height = 21\r\n Anchors = [akLeft, akTop, akRight]\r\n Caption = '...'\r\n TabOrder = 1\r\n OnClick = btnSrcClick\r\n end\r\n object btnDest: TButton\r\n Left = 360\r\n Top = 40\r\n Width = 21\r\n Height = 21\r\n Anchors = [akLeft, akTop, akRight]\r\n Caption = '...'\r\n TabOrder = 3\r\n OnClick = btnDestClick\r\n end\r\n end\r\n object OkBtn: TButton\r\n Left = 223\r\n Top = 110\r\n Width = 75\r\n Height = 25\r\n Anchors = [akRight, akBottom]\r\n Caption = 'OK'\r\n Default = True\r\n ModalResult = 1\r\n TabOrder = 2\r\n OnClick = OkBtnClick\r\n end\r\n object CancelBtn: TButton\r\n Left = 307\r\n Top = 110\r\n Width = 75\r\n Height = 25\r\n Anchors = [akRight, akBottom]\r\n Cancel = True\r\n Caption = 'Cancel'\r\n ModalResult = 2\r\n TabOrder = 3\r\n end\r\n object ClearBtn: TButton\r\n Left = 16\r\n Top = 112\r\n Width = 75\r\n Height = 25\r\n Caption = '&Clear'\r\n ModalResult = 1\r\n TabOrder = 1\r\n OnClick = ClearBtnClick\r\n end\r\nend\r\n" }, { "path": "External/Jedi/Jvcl/run/JvPatchForm.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvPatchForm.PAS, released on 2001-02-28.\r\n\r\nThe Initial Developer of the Original Code is Sbastien Buysse [sbuysse att buypin dott com]\r\nPortions created by Sbastien Buysse are Copyright (C) 2001 Sbastien Buysse.\r\nAll Rights Reserved.\r\n\r\nContributor(s): Michael Beck [mbeck att bigfoot dott com].\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvPatchForm.pas 12461 2009-08-14 17:21:33Z obones $\r\n\r\nunit JvPatchForm;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n SysUtils, Classes,\r\n Controls, Forms, StdCtrls,\r\n JvComponent;\r\n\r\ntype\r\n TPatchFrm = class(TJvForm)\r\n GroupBox1: TGroupBox;\r\n Label1: TLabel;\r\n Label2: TLabel;\r\n Label3: TLabel;\r\n edPassword: TEdit;\r\n edSource: TEdit;\r\n edDest: TEdit;\r\n OkBtn: TButton;\r\n CancelBtn: TButton;\r\n ClearBtn: TButton;\r\n btnSrc: TButton;\r\n btnDest: TButton;\r\n procedure OkBtnClick(Sender: TObject);\r\n procedure FormCreate(Sender: TObject);\r\n procedure FormDestroy(Sender: TObject);\r\n procedure ClearBtnClick(Sender: TObject);\r\n procedure btnSrcClick(Sender: TObject);\r\n procedure btnDestClick(Sender: TObject);\r\n private\r\n FPos: Integer;\r\n FPatch: TStringList;\r\n function Crypt(Value: Byte): Byte;\r\n public\r\n procedure LoadFromStr(Value: TStrings);\r\n function SetFromStr: TStrings;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvPatchForm.pas $';\r\n Revision: '$Revision: 12461 $';\r\n Date: '$Date: 2009-08-14 19:21:33 +0200 (ven. 14 août 2009) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n Dialogs,\r\n JvConsts, JvResources;\r\n\r\n{$R *.dfm}\r\n\r\nprocedure TPatchFrm.LoadFromStr(Value: TStrings);\r\nbegin\r\n if Value.Count > 2 then\r\n begin\r\n edSource.Text := Value[0];\r\n edDest.Text := Value[1];\r\n end;\r\nend;\r\n\r\nfunction TPatchFrm.SetFromStr: TStrings;\r\nbegin\r\n Result := FPatch;\r\nend;\r\n\r\nfunction TPatchFrm.Crypt(Value: Byte): Byte;\r\nbegin\r\n if edPassword.Text = '' then\r\n Result := Value\r\n else\r\n begin\r\n FPos := (FPos + 1) mod Length(edPassword.Text);\r\n Result := Value xor (Byte(edPassword.Text[FPos + 1]));\r\n end;\r\nend;\r\n\r\n// (rom) needs modernizing\r\n\r\nprocedure TPatchFrm.OkBtnClick(Sender: TObject);\r\nvar\r\n Src, Dest: TFileStream;\r\n buf1, buf2: array [0..1023] of Byte;\r\n i, j: Integer;\r\n res1, res2: Integer;\r\n iCount, LastCount: Integer;\r\nbegin\r\n if not FileExists(edSource.Text) or not FileExists(edDest.Text) then\r\n begin\r\n ModalResult := mrNone;\r\n MessageDlg(RsErrJvPatcherEditorInvalidFilename, mtError, [mbOK], 0);\r\n Exit;\r\n end;\r\n Src := TFileStream.Create(edSource.Text, fmOpenRead or fmShareDenyNone);\r\n Dest := TFileStream.Create(edDest.Text, fmOpenRead or fmShareDenyNone);\r\n try\r\n res1 := 0;\r\n res2 := 0;\r\n FPos := -1;\r\n Tag := 0;\r\n\r\n FPatch.Clear;\r\n FPatch.Add(edSource.Text);\r\n FPatch.Add(edDest.Text);\r\n Caption := Format(RsJvPatcherEditorComparingFilesd, [0]);\r\n Repaint;\r\n j := FPatch.Add(IntToStr(Src.Size));\r\n FPatch.Add(IntToStr(Dest.Size));\r\n iCount := 0;\r\n LastCount := 0;\r\n while (Src.Position < Src.Size) and (Dest.Position < Dest.Size) do\r\n begin\r\n Caption := Format(RsJvPatcherEditorComparingFilesd, [iCount div j]);\r\n Application.ProcessMessages;\r\n res1 := Src.Read(buf1, sizeof(buf1)); // original file\r\n res2 := Dest.Read(buf2, sizeof(buf2)); // patched file\r\n if res1 = res2 then\r\n begin\r\n for i := 0 to res1 - 1 do\r\n begin\r\n Inc(iCount);\r\n if buf1[i] <> buf2[i] then\r\n begin\r\n FPatch.Add(IntToStr(iCount - LastCount) + '|' + Char(Crypt(buf2[i])));\r\n LastCount := iCount;\r\n end;\r\n end;\r\n end;\r\n end;\r\n\r\n Caption := RsJvPatcherEditorEndStep;\r\n Repaint;\r\n if res1 > res2 then\r\n begin\r\n //f>g original>patched\r\n for i := 0 to res2 - 1 do\r\n begin\r\n Inc(iCount);\r\n if buf1[i] <> buf2[i] then\r\n begin\r\n FPatch.Add(IntToStr(iCount - LastCount) + '|' + Char(Crypt(buf2[i])));\r\n LastCount := iCount;\r\n end;\r\n end;\r\n\r\n //telling it's the end ...\r\n FPatch.Add('end%' + IntToStr(iCount));\r\n end\r\n else\r\n if res2 > res1 then\r\n begin\r\n //g>f patched>original\r\n\r\n //comparing last bytes\r\n for i := 0 to res1 - 1 do\r\n begin\r\n Inc(iCount);\r\n if buf1[i] <> buf2[i] then\r\n begin\r\n FPatch.Add(IntToStr(iCount - LastCount) + '|' + Char(Crypt(buf2[i])));\r\n LastCount := iCount;\r\n end;\r\n end;\r\n\r\n //adding the rest\r\n for i := res1 to res2 - 1 do\r\n FPatch.Add(Char(Crypt(buf2[i])));\r\n\r\n //adding the rest of the file\r\n while Dest.Position < Dest.Size do\r\n begin\r\n res2 := Dest.Read(buf2, sizeof(buf2));\r\n for i := 0 to res2 - 1 do\r\n FPatch.Add(Char(Crypt(buf2[i])));\r\n end;\r\n end;\r\n finally\r\n Src.Free;\r\n Dest.Free;\r\n end;\r\n // Close;\r\nend;\r\n\r\nprocedure TPatchFrm.FormCreate(Sender: TObject);\r\nbegin\r\n FPatch := TStringList.Create;\r\nend;\r\n\r\nprocedure TPatchFrm.FormDestroy(Sender: TObject);\r\nbegin\r\n FPatch.Free;\r\nend;\r\n\r\nprocedure TPatchFrm.ClearBtnClick(Sender: TObject);\r\nbegin\r\n FPatch.Clear;\r\nend;\r\n\r\nprocedure TPatchFrm.btnSrcClick(Sender: TObject);\r\nbegin\r\n with TOpenDialog.Create(nil) do\r\n try\r\n Filename := edSource.Text;\r\n if Execute then\r\n edSource.Text := Filename;\r\n finally\r\n Free;\r\n end;\r\nend;\r\n\r\nprocedure TPatchFrm.btnDestClick(Sender: TObject);\r\nbegin\r\n with TOpenDialog.Create(nil) do\r\n try\r\n Filename := edDest.Text;\r\n if Execute then\r\n edDest.Text := Filename;\r\n finally\r\n Free;\r\n end;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvPcx.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvPcx.PAS, released on 2001-02-28.\r\n\r\nThe Initial Developer of the Original Code is Sbastien Buysse [sbuysse att buypin dott com]\r\nPortions created by Sbastien Buysse are Copyright (C) 2001 Sbastien Buysse.\r\nAll Rights Reserved.\r\n\r\nContributor(s): Michael Beck [mbeck att bigfoot dott com].\r\n Andreas Hausladen [Andreas dott Hausladen att gmx dott de] (complete rewrite)\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvPcx.pas 12461 2009-08-14 17:21:33Z obones $\r\n\r\nunit JvPcx;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n {$IFDEF MSWINDOWS}\r\n Windows,\r\n {$ENDIF MSWINDOWS}\r\n {$IFDEF UNIX}\r\n QWindows,\r\n {$ENDIF UNIX}\r\n Graphics, Controls, Forms,\r\n SysUtils, Classes,\r\n JvTypes, JvJCLUtils;\r\n\r\ntype\r\n EPcxError = class(EJVCLException);\r\n\r\n TJvPcx = class(TBitmap)\r\n public\r\n procedure LoadFromResourceName(Instance: THandle; const ResName: string; ResType: PChar);\r\n {$IFDEF MSWINDOWS}\r\n procedure LoadFromResourceID(Instance: THandle; ResID: Integer; ResType: PChar);\r\n {$ENDIF MSWINDOWS}\r\n procedure LoadFromStream(Stream: TStream); override;\r\n procedure SaveToStream(Stream: TStream); override;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvPcx.pas $';\r\n Revision: '$Revision: 12461 $';\r\n Date: '$Date: 2009-08-14 19:21:33 +0200 (ven. 14 août 2009) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n JvResources;\r\n\r\nprocedure TJvPcx.LoadFromResourceName(Instance: THandle;\r\n const ResName: string; ResType: PChar);\r\nvar\r\n Stream: TStream;\r\nbegin\r\n Assign(nil); // fixes GDI resource leak\r\n if ResType = RT_BITMAP then\r\n inherited LoadFromResourceName(Instance, ResName)\r\n else\r\n begin\r\n Stream := TResourceStream.Create(Instance, ResName, ResType);\r\n try\r\n LoadFromStream(Stream);\r\n finally\r\n Stream.Free;\r\n end;\r\n end;\r\nend;\r\n\r\n{$IFDEF MSWINDOWS}\r\nprocedure TJvPcx.LoadFromResourceID(Instance: THandle; ResID: Integer;\r\n ResType: PChar);\r\nvar\r\n Stream: TStream;\r\nbegin\r\n Assign(nil); // fixes GDI resource leak\r\n if ResType = RT_BITMAP then\r\n inherited LoadFromResourceID(Instance, ResID)\r\n else\r\n begin\r\n Stream := TResourceStream.CreateFromID(Instance, ResID, ResType);\r\n try\r\n LoadFromStream(Stream);\r\n finally\r\n Stream.Free;\r\n end;\r\n end;\r\nend;\r\n{$ENDIF MSWINDOWS}\r\n\r\ntype\r\n PPcxPalette = ^TPcxPalette;\r\n TPcxPalette = packed record\r\n Red: Byte;\r\n Green: Byte;\r\n Blue: Byte;\r\n end;\r\n PPcxPaletteArray = ^TPcxPaletteArray;\r\n TPcxPaletteArray = array [0..255] of TPcxPalette;\r\n\r\n TPcxPalette256 = packed record\r\n Id: Byte; // $0C\r\n Items: array [0..255] of TPcxPalette;\r\n end;\r\n\r\n TPcxHeader = packed record\r\n Id: Byte; // $0A\r\n Version: Byte; // 5 = 3.0\r\n Compressed: Boolean;\r\n Bpp: Byte;\r\n x0, y0: Word;\r\n x1, y1: Word;\r\n dpiX: Word;\r\n dpiY: Word;\r\n Palette16: array [0..15] of TPcxPalette;\r\n Reserved1: Byte;\r\n Planes: Byte;\r\n BytesPerLine: Word;\r\n PaletteType: Word; // 1: color or s/w 2: grayscaled\r\n ScreenWidth: Word; // 0\r\n ScreenHeight: Word; // 0\r\n Reserved2: array [0..53] of Byte;\r\n end;\r\n\r\n\r\n\r\nprocedure ReadPalette(Bitmap: TJvPcx; ColorNum: Integer; PcxPalette: PPcxPalette);\r\nvar\r\n I: Integer;\r\n P: PPcxPaletteArray;\r\n RPal: TMaxLogPalette;\r\nbegin\r\n P := PPcxPaletteArray(PcxPalette);\r\n RPal.palVersion := $300;\r\n RPal.palNumEntries := ColorNum;\r\n for I := 0 to ColorNum - 1 do\r\n begin\r\n RPal.palPalEntry[I].peRed := P[I].Red;\r\n RPal.palPalEntry[I].peGreen := P[I].Green;\r\n RPal.palPalEntry[I].peBlue := P[I].Blue;\r\n RPal.palPalEntry[I].peFlags := 0;\r\n end;\r\n Bitmap.Palette := CreatePalette(PLogPalette(@RPal)^);\r\n Bitmap.PaletteModified := True;\r\nend;\r\n\r\nprocedure WritePalette(Bitmap: TJvPcx; ColorNum: Integer; PcxPalette: PPcxPalette);\r\nvar\r\n I: Integer;\r\n P: PPcxPaletteArray;\r\n RPal: array [0..256] of TPaletteEntry;\r\nbegin\r\n P := PPcxPaletteArray(PcxPalette);\r\n FillChar(P[0], ColorNum * SizeOf(TPcxPalette), 0);\r\n if Bitmap.Palette <> 0 then\r\n begin\r\n GetPaletteEntries(Bitmap.Palette, 0, ColorNum, RPal);\r\n for I := 0 to ColorNum - 1 do\r\n begin\r\n P[I].Red := RPal[I].peRed;\r\n P[I].Green := RPal[I].peGreen;\r\n P[I].Blue := RPal[I].peBlue;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvPcx.LoadFromStream(Stream: TStream);\r\nvar\r\n Header: TPcxHeader;\r\n BytesRead, BytesPerRasterLine: Integer;\r\n Decompressed: TMemoryStream;\r\n ByteLine: PByteArray;\r\n Line: PJvRGBArray;\r\n Palette256: TPcxPalette256;\r\n Buffer: array [0..MaxPixelCount] of Byte;\r\n Buffer2, Buffer3, Buffer4: PByteArray; // position in Buffer\r\n B: Byte;\r\n ByteNum, BitNum: Integer;\r\n X, Y: Integer;\r\nbegin\r\n Width := 0;\r\n Height := 0;\r\n Palette := 0;\r\n IgnorePalette := False;\r\n Monochrome := False;\r\n\r\n BytesRead := Stream.Read(Header, SizeOf(Header));\r\n // is it a valid header\r\n if (BytesRead <> SizeOf(Header)) or (Header.Id <> $0A) or\r\n (Header.BytesPerLine mod 2 = 1) then // BytesPerLine must be even\r\n raise EPcxError.CreateRes(@RsEPcxInvalid);\r\n\r\n // set pixel format before resizing the bitmap to reduce bitmap reallocations\r\n case Header.Bpp of\r\n 1:\r\n case Header.Planes of\r\n 1:\r\n begin\r\n PixelFormat := pf1bit;\r\n Monochrome := True;\r\n IgnorePalette := True;\r\n end;\r\n 4:\r\n PixelFormat := pf4bit; // VisualCLX: redirected const\r\n else\r\n raise EPcxError.CreateRes(@RsEPcxUnknownFormat);\r\n end;\r\n 8:\r\n case Header.Planes of\r\n 1:\r\n PixelFormat := pf8bit;\r\n 3:\r\n begin\r\n PixelFormat := pf24bit; // VisualCLX: redirected const\r\n IgnorePalette := True;\r\n end;\r\n else\r\n raise EPcxError.CreateRes(@RsEPcxUnknownFormat);\r\n end;\r\n end;\r\n\r\n Width := Header.x1 - Header.x0 + 1;\r\n Height := Header.y1 - Header.y0 + 1;\r\n if (Width = 0) or (Height = 0) then\r\n Exit; // nothing to do\r\n BytesPerRasterLine := Header.BytesPerLine * Header.Planes;\r\n\r\n Decompressed := TMemoryStream.Create;\r\n try\r\n if (Header.Bpp = 8) and (Header.Planes = 1) then\r\n // do not uncompress the appended (uncompressed) palette\r\n Decompressed.CopyFrom(Stream, Stream.Size - Stream.Position - SizeOf(TPcxPalette256))\r\n else\r\n Decompressed.CopyFrom(Stream, Stream.Size - Stream.Position);\r\n // decompress data stream\r\n if Header.Compressed then\r\n RleDecompress(Decompressed);\r\n if (Header.Bpp = 8) and (Header.Planes = 1) then\r\n // append the uncompressed palette\r\n Decompressed.CopyFrom(Stream, SizeOf(TPcxPalette256));\r\n\r\n // create palette (if necessary)\r\n if (Header.Bpp = 1) and (Header.Planes = 4) then\r\n begin\r\n ReadPalette(Self, 16, @Header.Palette16[0]);\r\n end\r\n else\r\n if (Header.Bpp = 8) and (Header.Planes = 1) then\r\n begin\r\n Decompressed.Seek(-SizeOf(TPcxPalette256), soFromEnd);\r\n if Decompressed.Read(Palette256, SizeOf(TPcxPalette256)) <> SizeOf(TPcxPalette256) then\r\n raise EPcxError.CreateRes(@RsEPcxPaletteProblem);\r\n if Palette256.Id = $0C then\r\n ReadPalette(Self, 256, @Palette256.Items[0])\r\n else\r\n raise EPcxError.CreateRes(@RsEPcxPaletteProblem);\r\n end;\r\n\r\n Decompressed.Position := 0;\r\n\r\n // read data\r\n for Y := 0 to Height - 1 do\r\n begin\r\n ByteLine := ScanLine[Y];\r\n if Decompressed.Read(Buffer, BytesPerRasterLine) <> BytesPerRasterLine then\r\n raise EPcxError.CreateRes(@RsEPcxUnknownFormat);\r\n\r\n // write data to the ScanLine\r\n if ((Header.Bpp = 1) and (Header.Planes = 1)) or // 1bit\r\n ((Header.Bpp = 8) and (Header.Planes = 1)) then // 8bit\r\n // just copy the data\r\n Move(Buffer[0], ByteLine[0], Header.BytesPerLine)\r\n else\r\n if (Header.Bpp = 8) and (Header.Planes = 3) then // 24bit\r\n begin\r\n Line := Pointer(ByteLine);\r\n Buffer2 := @Buffer[Header.BytesPerLine];\r\n Buffer3 := @Buffer[Header.BytesPerLine * 2];\r\n for X := 0 to Width - 1 do\r\n with Line[X] do\r\n begin\r\n rgbRed := Buffer[X];\r\n rgbGreen := Buffer2[X];\r\n rgbBlue := Buffer3[X];\r\n end;\r\n end\r\n else\r\n if (Header.Bpp = 1) and (Header.Planes = 4) then // 4bit\r\n begin\r\n Buffer2 := @Buffer[Header.BytesPerLine];\r\n Buffer3 := @Buffer[Header.BytesPerLine * 2];\r\n Buffer4 := @Buffer[Header.BytesPerLine * 3];\r\n FillChar(ByteLine[0], BytesPerRasterLine, 0);\r\n for X := 0 to Width - 1 do\r\n begin\r\n B := 0;\r\n ByteNum := X div 8;\r\n BitNum := 7 - (X mod 8);\r\n if (Buffer[ByteNum] shr BitNum) and $1 <> 0 then\r\n B := B or $01;\r\n if (Buffer2[ByteNum] shr BitNum) and $1 <> 0 then\r\n B := B or $02;\r\n if (Buffer3[ByteNum] shr BitNum) and $1 <> 0 then\r\n B := B or $04;\r\n if (Buffer4[ByteNum] shr BitNum) and $1 <> 0 then\r\n B := B or $08;\r\n\r\n if X mod 2 = 0 then // BIG ENDIAN\r\n B := B shl 4;\r\n ByteLine[X div 2] := ByteLine[X div 2] or B;\r\n end;\r\n end;\r\n end;\r\n finally\r\n Decompressed.Free;\r\n end;\r\n PaletteModified := True;\r\n Changed(Self);\r\nend;\r\n\r\nprocedure TJvPcx.SaveToStream(Stream: TStream);\r\nvar\r\n CompressStream: TMemoryStream;\r\n Header: TPcxHeader;\r\n X, Y: Integer;\r\n ByteLine: PByteArray;\r\n Line: PJvRGBArray;\r\n Buffer: array [0..MaxPixelCount] of Byte;\r\n Buffer2, Buffer3, Buffer4: PByteArray; // position in Buffer\r\n Palette256: TPcxPalette256;\r\n BytesPerRasterLine: Integer;\r\n B: Byte;\r\n ByteNum, BitNum: Integer;\r\nbegin\r\n if PixelFormat in [pfDevice, pfCustom, pf15bit, pf16bit] then\r\n PixelFormat := pf24bit;\r\n\r\n FillChar(Header, SizeOf(Header), 0);\r\n Header.Id := $0A;\r\n Header.Version := 5; // = 3.0\r\n Header.Compressed := True;\r\n Header.dpiX := 72;\r\n Header.dpiY := 72;\r\n Header.x1 := Width - 1;\r\n Header.y1 := Height - 1;\r\n Header.PaletteType := 1;\r\n\r\n CompressStream := TMemoryStream.Create;\r\n try\r\n // complete header\r\n case PixelFormat of\r\n pf1bit:\r\n begin\r\n Header.Bpp := 1;\r\n Header.Planes := 1;\r\n Header.BytesPerLine := (Width + 7) div 8;\r\n Header.Palette16[1].Red := 255;\r\n Header.Palette16[1].Green := 255;\r\n Header.Palette16[1].Blue := 255;\r\n end;\r\n pf4bit:\r\n begin\r\n Header.Bpp := 1;\r\n Header.Planes := 4;\r\n Header.BytesPerLine := (Width + 1) div 2;\r\n end;\r\n pf8bit:\r\n begin\r\n begin\r\n Header.Bpp := 8;\r\n Header.Planes := 1;\r\n Header.BytesPerLine := Width;\r\n end;\r\n end;\r\n pf24bit:\r\n begin\r\n Header.Bpp := 8;\r\n Header.Planes := 3;\r\n Header.BytesPerLine := Width;\r\n end;\r\n end;\r\n\r\n // round BytesPerPixel to even\r\n BytesPerRasterLine := Header.BytesPerLine; // save it\r\n if Header.BytesPerLine mod 2 = 1 then\r\n Inc(Header.BytesPerLine);\r\n\r\n if (PixelFormat = pf8bit) or (PixelFormat = pf4bit) then\r\n // copy first 16 palette entries into the header (also for pf8bit)\r\n WritePalette(Self, 16, @Header.Palette16[0]);\r\n // write header\r\n Stream.Write(Header, SizeOf(Header));\r\n\r\n // compress data\r\n for Y := 0 to Height - 1 do\r\n begin\r\n ByteLine := ScanLine[Y];\r\n\r\n case Header.Planes * Header.Bpp of // reduces VisualCLX IFDEFs\r\n 1, 8:\r\n begin\r\n if Header.BytesPerLine <> BytesPerRasterLine then\r\n begin\r\n Move(ByteLine[0], Buffer, BytesPerRasterLine);\r\n Buffer[BytesPerRasterLine] := 0;\r\n ByteLine := @Buffer[0];\r\n end;\r\n CompressStream.Write(ByteLine[0], Header.BytesPerLine);\r\n end;\r\n 4:\r\n begin\r\n BytesPerRasterLine := Header.BytesPerLine * 4;\r\n Buffer2 := @Buffer[Header.BytesPerLine];\r\n Buffer3 := @Buffer[Header.BytesPerLine * 2];\r\n Buffer4 := @Buffer[Header.BytesPerLine * 3];\r\n FillChar(Buffer[0], BytesPerRasterLine, 0);\r\n for X := 0 to Width - 1 do\r\n begin\r\n B := ByteLine[X div 2];\r\n if X mod 2 = 0 then // BIG ENDIAN\r\n B := B shr 4\r\n else\r\n B := B and $0F;\r\n\r\n ByteNum := X div 8;\r\n BitNum := 7 - (X mod 8);\r\n if B and $01 <> 0 then\r\n Buffer[ByteNum] := Buffer[ByteNum] or (1 shl BitNum);\r\n if B and $02 <> 0 then\r\n Buffer2[ByteNum] := Buffer2[ByteNum] or (1 shl BitNum);\r\n if B and $04 <> 0 then\r\n Buffer3[ByteNum] := Buffer3[ByteNum] or (1 shl BitNum);\r\n if B and $08 <> 0 then\r\n Buffer4[ByteNum] := Buffer4[ByteNum] or (1 shl BitNum);\r\n end;\r\n CompressStream.Write(Buffer, BytesPerRasterLine);\r\n end;\r\n 24:\r\n begin\r\n Line := ScanLine[Y];\r\n Buffer2 := @Buffer[Header.BytesPerLine];\r\n Buffer3 := @Buffer[Header.BytesPerLine * 2];\r\n for X := 0 to Width - 1 do\r\n begin\r\n with Line[X] do\r\n begin\r\n Buffer[X] := rgbRed;\r\n Buffer2[X] := rgbGreen;\r\n Buffer3[X] := rgbBlue;\r\n end;\r\n end;\r\n CompressStream.Write(Buffer, Header.BytesPerLine * 3);\r\n end;\r\n end;\r\n RleCompressTo(CompressStream, Stream);\r\n CompressStream.Size := 0;\r\n end;\r\n\r\n // write palette\r\n if PixelFormat = pf8bit then\r\n begin\r\n Palette256.Id := $0C;\r\n WritePalette(Self, 256, @Palette256.Items[0]);\r\n Stream.Write(Palette256, SizeOf(Palette256));\r\n end;\r\n finally\r\n CompressStream.Free;\r\n end;\r\nend;\r\n\r\n\r\ninitialization\r\n {$IFDEF UNITVERSIONING}\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n {$ENDIF UNITVERSIONING}\r\n {$IFDEF COMPILER7_UP}\r\n GroupDescendentsWith(TJvPcx, TControl);\r\n {$ENDIF COMPILER7_UP}\r\n RegisterClass(TJvPcx);\r\n TPicture.RegisterFileFormat(RsPcxExtension, RsPcxFilterName, TJvPcx);\r\n\r\nfinalization\r\n TPicture.UnregisterGraphicClass(TJvPcx);\r\n {$IFDEF UNITVERSIONING}\r\n UnregisterUnitVersion(HInstance);\r\n {$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvPerfMon95.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvPerfMon95.PAS, released Dec 26, 1999.\r\n\r\nThe Initial Developer of the Original Code is Petr Vones (petr dott v att mujmail dott cz)\r\nPortions created by Petr Vones are Copyright (C) 1999 Petr Vones.\r\nPortions created by Microsoft are Copyright (C) 1998, 1999 Microsoft Corp.\r\nAll Rights Reserved.\r\n\r\nContributor(s): ______________________________________.\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvPerfMon95.pas 13138 2011-10-26 23:17:50Z jfudickar $\r\n\r\nunit JvPerfMon95;\r\n\r\n{$I jvcl.inc}\r\n{$I windowsonly.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n SysUtils, Registry, Classes, Contnrs,\r\n Windows, Forms,\r\n JvComponentBase, JvTypes;\r\n\r\ntype\r\n EJvPerfStatException = class(EJVCLException);\r\n\r\n TJvPerfStat95 = class;\r\n\r\n PJvPerfStatCategory = ^TJvPerfStatCategory;\r\n TJvPerfStatCategory = record\r\n Category: string; // MBCS\r\n Name: string; // MBCS\r\n end;\r\n\r\n TJvPerfStatActiveItem = class(TObject)\r\n private\r\n FCategoryIndex: Integer;\r\n FDescription: string;\r\n FDifferentiate: Boolean;\r\n FKey: string; // MBCS\r\n FLastPerfData: Longword;\r\n FLastTime: Longword;\r\n FName: string;\r\n FOwner: TJvPerfStat95;\r\n FStarted: Boolean;\r\n function GetCategory: TJvPerfStatCategory;\r\n function GetPerfData: Longword;\r\n function GetPerfDataStr: string;\r\n function GetKey: string;\r\n protected\r\n function InternalStartStop(Start: Boolean): Boolean;\r\n public\r\n constructor Create(AOwner: TJvPerfStat95; const AKey: string;\r\n ACategoryIndex: Integer);\r\n procedure Start(NoCheckState: Boolean = False);\r\n procedure Stop(NoCheckState: Boolean = False);\r\n property Category: TJvPerfStatCategory read GetCategory;\r\n property Description: string read FDescription;\r\n property Differentiate: Boolean read FDifferentiate;\r\n property Key: string read GetKey;\r\n property Name: string read FName;\r\n property PerfData: Longword read GetPerfData;\r\n property PerfDataStr: string read GetPerfDataStr;\r\n property Started: Boolean read FStarted;\r\n end;\r\n\r\n TJvPerfStatItem = class(TCollectionItem)\r\n private\r\n FActiveItem: TJvPerfStatActiveItem;\r\n FPerfStatKey: string;\r\n procedure SetPerfStatKey(const Value: string);\r\n function GetActiveItem: TJvPerfStatActiveItem;\r\n function GetExist: Boolean;\r\n protected\r\n function GetDisplayName: string; override;\r\n public\r\n property ActiveItem: TJvPerfStatActiveItem read GetActiveItem;\r\n property Exist: Boolean read GetExist;\r\n published\r\n property PerfStatKey: string read FPerfStatKey write SetPerfStatKey;\r\n end;\r\n\r\n TJvPerfStatItems = class(TCollection)\r\n private\r\n FOwner: TJvPerfStat95;\r\n function GetItem(Index: Integer): TJvPerfStatItem;\r\n procedure SetItem(Index: Integer; const Value: TJvPerfStatItem);\r\n protected\r\n function GetOwner: TPersistent; override;\r\n procedure Update(Item: TCollectionItem); override;\r\n public\r\n constructor Create(AOwner: TJvPerfStat95);\r\n function Add: TJvPerfStatItem;\r\n property Items[Index: Integer]: TJvPerfStatItem read GetItem write SetItem; default;\r\n end;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvPerfStat95 = class(TJvComponent)\r\n private\r\n FCategories: array of TJvPerfStatCategory;\r\n FActiveObjectsList: TObjectList;\r\n FItems: TJvPerfStatItems;\r\n FWarnIfWrongOS: Boolean;\r\n function GetActiveObjects(Index: Integer): TJvPerfStatActiveItem;\r\n function GetActiveObjectCount: Integer;\r\n function GetCategories(Index: Integer): TJvPerfStatCategory;\r\n function GetCategoryCount: Integer;\r\n function GetKeys(const Name: string): TJvPerfStatActiveItem;\r\n procedure SetItems(const Value: TJvPerfStatItems);\r\n protected\r\n Reg: TRegistry;\r\n procedure Loaded; override;\r\n procedure ReadActiveObjects;\r\n function ReadMBStringValue(const Name: string): string;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n procedure StopAll;\r\n property ActiveObjects[Index: Integer]: TJvPerfStatActiveItem read GetActiveObjects; default;\r\n property ActiveObjectCount: Integer read GetActiveObjectCount;\r\n property Categories[Index: Integer]: TJvPerfStatCategory read GetCategories;\r\n property CategoryCount: Integer read GetCategoryCount;\r\n property Keys[const Name: string]: TJvPerfStatActiveItem read GetKeys;\r\n published\r\n property Items: TJvPerfStatItems read FItems write SetItems;\r\n property WarnIfWrongOS: Boolean read FWarnIfWrongOS write FWarnIfWrongOS default True;\r\n end;\r\n\r\nfunction JvGetPerfStatItems(List: TStrings): Boolean;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvPerfMon95.pas $';\r\n Revision: '$Revision: 13138 $';\r\n Date: '$Date: 2011-10-27 01:17:50 +0200 (jeu. 27 oct. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n RTLConsts,\r\n JvJCLUtils, JvResources;\r\n\r\nconst\r\n PerfEnumKey = 'System\\CurrentControlSet\\Control\\PerfStats\\Enum';\r\n StartDataKey = 'PerfStats\\StartStat';\r\n StopDataKey = 'PerfStats\\StopStat';\r\n StatDataKey = 'PerfStats\\StatData';\r\n\r\nvar\r\n WrongOSWarningShown: Boolean = False;\r\n\r\nfunction MultiByteStringToString(const S: string): string;\r\n{$IFDEF SUPPORTS_UNICODE}\r\nbegin\r\n Result := S;\r\nend;\r\n{$ELSE}\r\nvar\r\n W: array [0..MAX_PATH] of WideChar;\r\nbegin\r\n OSCheck(MultiByteToWideChar(CP_OEMCP, 0, PAnsiChar(S), -1, W, MAX_PATH) <> 0);\r\n Result := W;\r\nend;\r\n{$ENDIF SUPPORTS_UNICODE}\r\n\r\nfunction StringToMultiByteString(const S: string): string;\r\n{$IFDEF SUPPORTS_UNICODE}\r\nbegin\r\n Result := S;\r\nend;\r\n{$ELSE}\r\nvar\r\n W: WideString;\r\n C: array [0..MAX_PATH] of AnsiChar;\r\nbegin\r\n W := S;\r\n OSCheck(WideCharToMultiByte(CP_OEMCP, 0, PWideChar(W), -1, C, MAX_PATH, nil, nil) <> 0);\r\n Result := C;\r\nend;\r\n{$ENDIF SUPPORTS_UNICODE}\r\n\r\nfunction JvGetPerfStatItems(List: TStrings): Boolean;\r\nvar\r\n List1, List2: TStringList;\r\n Reg: TRegistry;\r\n I1, I2: Integer;\r\nbegin\r\n Result := True;\r\n Reg := TRegistry.Create;\r\n List1 := TStringList.Create;\r\n List2 := TStringList.Create;\r\n List.BeginUpdate;\r\n try\r\n Reg.RootKey := HKEY_LOCAL_MACHINE;\r\n if Reg.OpenKeyReadOnly(PerfEnumKey) then\r\n begin\r\n Reg.GetKeyNames(List1);\r\n Reg.CloseKey;\r\n List1.Sort;\r\n for I1 := 0 to List1.Count - 1 do\r\n if Reg.OpenKeyReadOnly(PerfEnumKey + '\\' + List1[I1]) then\r\n begin\r\n Reg.GetKeyNames(List2);\r\n Reg.CloseKey;\r\n for I2 := 0 to List2.Count - 1 do\r\n List.Add(MultiByteStringToString(Format('%s\\%s', [List1[I1], List2[I2]])));\r\n end;\r\n end\r\n else\r\n Result := False;\r\n finally\r\n Reg.Free;\r\n List2.Free;\r\n List1.Free;\r\n List.EndUpdate;\r\n end;\r\nend;\r\n\r\nprocedure ShowWrongOSWarning;\r\nbegin\r\n if WrongOSWarningShown or (Win32Platform = VER_PLATFORM_WIN32_WINDOWS) then\r\n Exit;\r\n with Application do\r\n MessageBox(PChar(RsWrongOS), PChar(Title), MB_ICONWARNING);\r\n WrongOSWarningShown := True;\r\nend;\r\n\r\n//=== { TJvPerfStatActiveItem } ==============================================\r\n\r\nconstructor TJvPerfStatActiveItem.Create(AOwner: TJvPerfStat95;\r\n const AKey: string; ACategoryIndex: Integer);\r\nbegin\r\n inherited Create;\r\n FOwner := AOwner;\r\n FKey := AKey;\r\n FCategoryIndex := ACategoryIndex;\r\n with FOwner do\r\n if Reg.OpenKeyReadOnly(PerfEnumKey + '\\' + FKey) then\r\n try\r\n FDifferentiate := (ReadMBStringValue('Differentiate') = 'TRUE');\r\n FDescription := ReadMBStringValue('Description');\r\n FName := ReadMBStringValue('Name');\r\n finally\r\n Reg.CloseKey;\r\n end;\r\nend;\r\n\r\nfunction TJvPerfStatActiveItem.GetCategory: TJvPerfStatCategory;\r\nbegin\r\n Result := FOwner.GetCategories(FCategoryIndex);\r\nend;\r\n\r\nfunction TJvPerfStatActiveItem.GetKey: string;\r\nbegin\r\n Result := MultiByteStringToString(FKey);\r\nend;\r\n\r\nfunction TJvPerfStatActiveItem.GetPerfData: Longword;\r\nvar\r\n Size: Integer;\r\n Value: Longword;\r\n CurrentTickCount: DWORD;\r\nbegin\r\n with FOwner.Reg do\r\n begin\r\n RootKey := HKEY_DYN_DATA;\r\n if OpenKeyReadOnly(StatDataKey) then\r\n begin\r\n Size := GetDataSize(FKey);\r\n if Size = SizeOf(Value) then\r\n ReadBinaryData(FKey, Value, Size);\r\n CloseKey;\r\n end;\r\n end;\r\n if FDifferentiate then\r\n begin\r\n CurrentTickCount := GetTickCount;\r\n if (FLastTime = 0) or (CurrentTickCount = FLastTime) then\r\n Result := 0\r\n else\r\n Result := Trunc((Value - FLastPerfData) * 1000 / (CurrentTickCount - FLastTime));\r\n FLastTime := CurrentTickCount;\r\n FLastPerfData := Value;\r\n end\r\n else\r\n Result := Value;\r\nend;\r\n\r\nfunction TJvPerfStatActiveItem.GetPerfDataStr: string;\r\nvar\r\n E: Extended;\r\nbegin\r\n E := GetPerfData;\r\n Result := Format('%.n', [E]);\r\nend;\r\n\r\nfunction TJvPerfStatActiveItem.InternalStartStop(Start: Boolean): Boolean;\r\nconst\r\n StartStopKeys: array [Boolean] of string = (StopDataKey, StartDataKey);\r\nvar\r\n Size, Dummy: Integer;\r\nbegin\r\n Result := False;\r\n with FOwner.Reg do\r\n begin\r\n RootKey := HKEY_DYN_DATA;\r\n if OpenKeyReadOnly(StartStopKeys[Start]) then\r\n begin\r\n Size := GetDataSize(FKey);\r\n if Size = SizeOf(Dummy) then\r\n begin\r\n ReadBinaryData(FKey, Dummy, Size);\r\n Result := True;\r\n end;\r\n CloseKey;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvPerfStatActiveItem.Start(NoCheckState: Boolean);\r\nbegin\r\n if not NoCheckState and FStarted then\r\n Exit;\r\n if not InternalStartStop(True) then\r\n raise EJvPerfStatException.CreateResFmt(@RsECantStart, [Key]);\r\n FStarted := True;\r\nend;\r\n\r\nprocedure TJvPerfStatActiveItem.Stop(NoCheckState: Boolean);\r\nbegin\r\n if not NoCheckState and not FStarted then\r\n Exit;\r\n if not InternalStartStop(False) then\r\n raise EJvPerfStatException.CreateResFmt(@RsECantStop, [Key]);\r\n FStarted := False;\r\nend;\r\n\r\n//=== { TJvPerfStatItem } ====================================================\r\n\r\nfunction TJvPerfStatItem.GetActiveItem: TJvPerfStatActiveItem;\r\nbegin\r\n Result := FActiveItem;\r\n if Result = nil then\r\n raise EJvPerfStatException.CreateResFmt(@RsEKeyNotExist, [FPerfStatKey]);\r\n Result.Start;\r\nend;\r\n\r\nfunction TJvPerfStatItem.GetDisplayName: string;\r\nbegin\r\n Result := FPerfStatKey;\r\n if Result = '' then\r\n Result := inherited GetDisplayName;\r\nend;\r\n\r\nfunction TJvPerfStatItem.GetExist: Boolean;\r\nbegin\r\n Result := (FActiveItem <> nil);\r\nend;\r\n\r\nprocedure TJvPerfStatItem.SetPerfStatKey(const Value: string);\r\nbegin\r\n if FPerfStatKey <> Value then\r\n begin\r\n FPerfStatKey := Value;\r\n Changed(False);\r\n end;\r\nend;\r\n\r\n//=== { TJvPerfStatItems } ===================================================\r\n\r\nconstructor TJvPerfStatItems.Create(AOwner: TJvPerfStat95);\r\nbegin\r\n inherited Create(TJvPerfStatItem);\r\n FOwner := AOwner;\r\nend;\r\n\r\nfunction TJvPerfStatItems.Add: TJvPerfStatItem;\r\nbegin\r\n Result := TJvPerfStatItem(inherited Add);\r\nend;\r\n\r\nfunction TJvPerfStatItems.GetItem(Index: Integer): TJvPerfStatItem;\r\nbegin\r\n Result := TJvPerfStatItem(inherited GetItem(Index));\r\nend;\r\n\r\nfunction TJvPerfStatItems.GetOwner: TPersistent;\r\nbegin\r\n Result := FOwner;\r\nend;\r\n\r\nprocedure TJvPerfStatItems.SetItem(Index: Integer; const Value: TJvPerfStatItem);\r\nbegin\r\n inherited SetItem(Index, Value);\r\nend;\r\n\r\nprocedure TJvPerfStatItems.Update(Item: TCollectionItem);\r\nvar\r\n I: Integer;\r\n\r\n procedure BindItem(Item: TCollectionItem);\r\n begin\r\n with TJvPerfStatItem(Item) do\r\n FActiveItem := FOwner.Keys[PerfStatKey];\r\n end;\r\n\r\nbegin\r\n if csDesigning in FOwner.ComponentState then\r\n Exit;\r\n if Item = nil then\r\n for I := 0 to Count - 1 do\r\n BindItem(Items[I])\r\n else\r\n BindItem(Item);\r\nend;\r\n\r\n//=== { TJvPerfStat95 } ======================================================\r\n\r\nconstructor TJvPerfStat95.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FItems := TJvPerfStatItems.Create(Self);\r\n FWarnIfWrongOS := True;\r\n if not (csDesigning in ComponentState) then\r\n begin\r\n FActiveObjectsList := TObjectList.Create(True);\r\n Reg := TRegistry.Create;\r\n ReadActiveObjects;\r\n end;\r\nend;\r\n\r\ndestructor TJvPerfStat95.Destroy;\r\nbegin\r\n if not (csDesigning in ComponentState) then\r\n begin\r\n StopAll;\r\n FreeAndNil(FActiveObjectsList);\r\n FreeAndNil(Reg);\r\n end;\r\n FreeAndNil(FItems);\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJvPerfStat95.GetActiveObjectCount: Integer;\r\nbegin\r\n Result := FActiveObjectsList.Count;\r\nend;\r\n\r\nfunction TJvPerfStat95.GetActiveObjects(Index: Integer): TJvPerfStatActiveItem;\r\nbegin\r\n Result := TJvPerfStatActiveItem(FActiveObjectsList.Items[Index]);\r\nend;\r\n\r\nfunction TJvPerfStat95.GetCategories(Index: Integer): TJvPerfStatCategory;\r\nbegin\r\n if (Index < 0) or (Index > GetCategoryCount - 1) then\r\n raise EJvPerfStatException.CreateResFmt(@SListIndexError, [Index]);\r\n Result := FCategories[Index];\r\n with Result do\r\n begin\r\n Category := MultiByteStringToString(Category);\r\n Name := MultiByteStringToString(Name);\r\n end;\r\nend;\r\n\r\nfunction TJvPerfStat95.GetCategoryCount: Integer;\r\nbegin\r\n Result := Length(FCategories);\r\nend;\r\n\r\nfunction TJvPerfStat95.GetKeys(const Name: string): TJvPerfStatActiveItem;\r\nvar\r\n I: Integer;\r\n FindKey: string;\r\nbegin\r\n FindKey := StringToMultiByteString(Name);\r\n Result := nil;\r\n for I := 0 to FActiveObjectsList.Count - 1 do\r\n if ActiveObjects[I].FKey = FindKey then\r\n begin\r\n Result := ActiveObjects[I];\r\n Break;\r\n end;\r\nend;\r\n\r\nprocedure TJvPerfStat95.Loaded;\r\nbegin\r\n inherited Loaded;\r\n if FWarnIfWrongOS and not (csDesigning in ComponentState) then\r\n ShowWrongOSWarning;\r\nend;\r\n\r\nprocedure TJvPerfStat95.ReadActiveObjects;\r\nvar\r\n List1, List2: TStringList;\r\n I1, I2: Integer;\r\nbegin\r\n List1 := TStringList.Create;\r\n List2 := TStringList.Create;\r\n try\r\n FActiveObjectsList.Clear;\r\n Reg.RootKey := HKEY_LOCAL_MACHINE;\r\n if Reg.OpenKeyReadOnly(PerfEnumKey) then\r\n begin\r\n Reg.GetKeyNames(List1);\r\n Reg.CloseKey;\r\n List1.Sort;\r\n SetLength(FCategories, List1.Count);\r\n for I1 := 0 to List1.Count - 1 do\r\n if Reg.OpenKeyReadOnly(PerfEnumKey + '\\' + List1[I1]) then\r\n begin\r\n Reg.GetKeyNames(List2);\r\n FCategories[I1].Category := List1[I1];\r\n FCategories[I1].Name := Reg.ReadString('Name');\r\n Reg.CloseKey;\r\n for I2 := 0 to List2.Count - 1 do\r\n FActiveObjectsList.Add(TJvPerfStatActiveItem.Create(Self,\r\n Format('%s\\%s', [List1[I1], List2[I2]]), I1));\r\n end;\r\n end\r\n else\r\n raise EJvPerfStatException.CreateRes(@RsECantOpenPerfKey);\r\n finally\r\n List2.Free;\r\n List1.Free;\r\n end;\r\nend;\r\n\r\nfunction TJvPerfStat95.ReadMBStringValue(const Name: string): string;\r\nbegin\r\n Result := MultiByteStringToString(Reg.ReadString(Name));\r\nend;\r\n\r\nprocedure TJvPerfStat95.SetItems(const Value: TJvPerfStatItems);\r\nbegin\r\n FItems.Assign(Value);\r\nend;\r\n\r\nprocedure TJvPerfStat95.StopAll;\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := 0 to FActiveObjectsList.Count - 1 do\r\n ActiveObjects[I].Stop;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvPicClip.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvPicClip.PAS, released on 2002-07-04.\r\n\r\nThe Initial Developers of the Original Code are: Fedor Koshevnikov, Igor Pavluk and Serge Korolev\r\nCopyright (c) 1997, 1998 Fedor Koshevnikov, Igor Pavluk and Serge Korolev\r\nCopyright (c) 2001,2002 SGB Software\r\nAll Rights Reserved.\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvPicClip.pas 13104 2011-09-07 06:50:43Z obones $\r\n\r\nunit JvPicClip;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Classes, Windows, Graphics, Controls, RTLConsts,\r\n JvComponentBase;\r\n\r\ntype\r\n TJvCellRange = 1..MaxInt;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvPicClip = class(TJvComponent)\r\n private\r\n FPicture: TPicture;\r\n FRows: TJvCellRange;\r\n FCols: TJvCellRange;\r\n FBitmap: TBitmap;\r\n FMasked: Boolean;\r\n FMaskColor: TColor;\r\n FOnChange: TNotifyEvent;\r\n procedure CheckIndex(Index: Integer);\r\n function GetCell(Col, Row: Cardinal): TBitmap;\r\n function GetGraphicCell(Index: Integer): TBitmap;\r\n function GetDefaultMaskColor: TColor;\r\n function GetIsEmpty: Boolean;\r\n function GetCount: Integer;\r\n function GetHeight: Integer;\r\n function GetWidth: Integer;\r\n function IsMaskStored: Boolean;\r\n procedure PictureChanged(Sender: TObject);\r\n procedure SetHeight(Value: Integer);\r\n procedure SetPicture(Value: TPicture);\r\n procedure SetWidth(Value: Integer);\r\n procedure SetMaskColor(Value: TColor);\r\n protected\r\n procedure AssignTo(Dest: TPersistent); override;\r\n procedure Changed; dynamic;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n procedure Assign(Source: TPersistent); override;\r\n function GetIndex(Col, Row: Cardinal): Integer;\r\n procedure Draw(Canvas: TCanvas; X, Y, Index: Integer);\r\n procedure DrawCenter(Canvas: TCanvas; Rect: TRect; Index: Integer);\r\n procedure LoadBitmapRes(Instance: THandle; ResID: PChar);\r\n property Cells[Col, Row: Cardinal]: TBitmap read GetCell;\r\n property GraphicCell[Index: Integer]: TBitmap read GetGraphicCell;\r\n property IsEmpty: Boolean read GetIsEmpty;\r\n property Count: Integer read GetCount;\r\n published\r\n property Cols: TJvCellRange read FCols write FCols default 1;\r\n property Height: Integer read GetHeight write SetHeight stored False;\r\n property Masked: Boolean read FMasked write FMasked default True;\r\n property Rows: TJvCellRange read FRows write FRows default 1;\r\n property Picture: TPicture read FPicture write SetPicture;\r\n property MaskColor: TColor read FMaskColor write SetMaskColor stored IsMaskStored;\r\n property Width: Integer read GetWidth write SetWidth stored False;\r\n property OnChange: TNotifyEvent read FOnChange write FOnChange;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvPicClip.pas $';\r\n Revision: '$Revision: 13104 $';\r\n Date: '$Date: 2011-09-07 08:50:43 +0200 (mer. 07 sept. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n SysUtils,\r\n Consts,\r\n JvJVCLUtils, JvConsts;\r\n\r\nconstructor TJvPicClip.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FPicture := TPicture.Create;\r\n FPicture.OnChange := PictureChanged;\r\n FBitmap := TBitmap.Create;\r\n FRows := 1;\r\n FCols := 1;\r\n FMaskColor := GetDefaultMaskColor;\r\n FMasked := True;\r\nend;\r\n\r\ndestructor TJvPicClip.Destroy;\r\nbegin\r\n FOnChange := nil;\r\n FPicture.OnChange := nil;\r\n FBitmap.Free;\r\n FPicture.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvPicClip.Assign(Source: TPersistent);\r\nbegin\r\n if Source is TJvPicClip then\r\n begin\r\n with TJvPicClip(Source) do\r\n begin\r\n Self.FRows := Rows;\r\n Self.FCols := Cols;\r\n Self.FMasked := Masked;\r\n Self.FMaskColor := MaskColor;\r\n Self.FPicture.Assign(FPicture);\r\n end;\r\n end\r\n else\r\n if (Source is TPicture) or (Source is TGraphic) then\r\n FPicture.Assign(Source)\r\n else\r\n inherited Assign(Source);\r\nend;\r\n\r\ntype\r\n TImageListAccessProtected = class(TImageList);\r\n\r\nprocedure TJvPicClip.AssignTo(Dest: TPersistent);\r\nvar\r\n I: Integer;\r\n SaveChange: TNotifyEvent;\r\nbegin\r\n if Dest is TPicture then\r\n Dest.Assign(FPicture)\r\n else\r\n if (Dest is TGraphic) and (FPicture.Graphic <> nil) and\r\n (FPicture.Graphic is TGraphic(Dest).ClassType) then\r\n Dest.Assign(FPicture.Graphic)\r\n else\r\n if (Dest is TImageList) and not IsEmpty then\r\n begin\r\n with TImageList(Dest) do\r\n begin\r\n SaveChange := OnChange;\r\n try\r\n OnChange := nil;\r\n Clear;\r\n Width := Self.Width;\r\n Height := Self.Height;\r\n for I := 0 to Self.Count - 1 do\r\n if Self.Masked and (MaskColor <> clNone) then\r\n TImageList(Dest).AddMasked(GraphicCell[I], MaskColor)\r\n else\r\n TImageList(Dest).Add(GraphicCell[I], nil);\r\n Masked := Self.Masked;\r\n finally\r\n OnChange := SaveChange;\r\n end;\r\n TImageListAccessProtected(Dest).Change;\r\n end;\r\n end\r\n else\r\n inherited AssignTo(Dest);\r\nend;\r\n\r\nprocedure TJvPicClip.Changed;\r\nbegin\r\n if Assigned(FOnChange) then\r\n FOnChange(Self);\r\nend;\r\n\r\nfunction TJvPicClip.GetIsEmpty: Boolean;\r\nbegin\r\n Result := (Picture.Graphic = nil) or Picture.Graphic.Empty;\r\nend;\r\n\r\nfunction TJvPicClip.GetCount: Integer;\r\nbegin\r\n if IsEmpty then\r\n Result := 0\r\n else\r\n Result := Cols * Rows;\r\nend;\r\n\r\nprocedure TJvPicClip.Draw(Canvas: TCanvas; X, Y, Index: Integer);\r\nvar\r\n Image: TGraphic;\r\nbegin\r\n if Index < 0 then\r\n Image := Picture.Graphic\r\n else\r\n Image := GraphicCell[Index];\r\n if (Image <> nil) and not Image.Empty then\r\n if FMasked and (FMaskColor <> clNone) and\r\n (Picture.Graphic is TBitmap) then\r\n DrawBitmapTransparent(Canvas, X, Y, TBitmap(Image), FMaskColor)\r\n else\r\n Canvas.Draw(X, Y, Image);\r\nend;\r\n\r\nprocedure TJvPicClip.DrawCenter(Canvas: TCanvas; Rect: TRect; Index: Integer);\r\nvar\r\n X, Y: Integer;\r\nbegin\r\n X := (Rect.Left + Rect.Right - Width) div 2;\r\n Y := (Rect.Bottom + Rect.Top - Height) div 2;\r\n Draw(Canvas, X, Y, Index);\r\nend;\r\n\r\nprocedure TJvPicClip.LoadBitmapRes(Instance: THandle; ResID: PChar);\r\nvar\r\n Bmp: TBitmap;\r\nbegin\r\n Bmp := MakeModuleBitmap(Instance, ResID);\r\n try\r\n Picture.Assign(Bmp);\r\n finally\r\n Bmp.Free;\r\n end;\r\nend;\r\n\r\nprocedure TJvPicClip.CheckIndex(Index: Integer);\r\nbegin\r\n if (Index >= Cols * Rows) or (Index < 0) then\r\n raise EListError.CreateResFmt(@SListIndexError, [Index]);\r\nend;\r\n\r\nfunction TJvPicClip.GetIndex(Col, Row: Cardinal): Integer;\r\nbegin\r\n Result := Col + (Row * Cols);\r\n if (Result >= Cols * Rows) or IsEmpty then\r\n Result := -1;\r\nend;\r\n\r\nfunction TJvPicClip.GetCell(Col, Row: Cardinal): TBitmap;\r\nbegin\r\n Result := GetGraphicCell(GetIndex(Col, Row));\r\nend;\r\n\r\nfunction TJvPicClip.GetGraphicCell(Index: Integer): TBitmap;\r\nbegin\r\n CheckIndex(Index);\r\n AssignBitmapCell(Picture.Graphic, FBitmap, Cols, Rows, Index);\r\n if Picture.Graphic is TBitmap then\r\n if FBitmap.PixelFormat <> pfDevice then\r\n FBitmap.PixelFormat := TBitmap(Picture.Graphic).PixelFormat;\r\n FBitmap.TransparentColor := FMaskColor or PaletteMask;\r\n FBitmap.Transparent := (FMaskColor <> clNone) and Masked;\r\n Result := FBitmap;\r\nend;\r\n\r\nfunction TJvPicClip.GetDefaultMaskColor: TColor;\r\nbegin\r\n Result := clOlive;\r\n if (Picture.Graphic <> nil) and (Picture.Graphic is TBitmap) then\r\n Result := TBitmap(Picture.Graphic).TransparentColor and not PaletteMask;\r\nend;\r\n\r\nfunction TJvPicClip.GetHeight: Integer;\r\nbegin\r\n Result := Picture.Height div FRows;\r\nend;\r\n\r\nfunction TJvPicClip.GetWidth: Integer;\r\nbegin\r\n Result := Picture.Width div FCols;\r\nend;\r\n\r\nfunction TJvPicClip.IsMaskStored: Boolean;\r\nbegin\r\n Result := MaskColor <> GetDefaultMaskColor;\r\nend;\r\n\r\nprocedure TJvPicClip.SetMaskColor(Value: TColor);\r\nbegin\r\n if Value <> FMaskColor then\r\n begin\r\n FMaskColor := Value;\r\n Changed;\r\n end;\r\nend;\r\n\r\nprocedure TJvPicClip.PictureChanged(Sender: TObject);\r\nbegin\r\n FMaskColor := GetDefaultMaskColor;\r\n if not (csReading in ComponentState) then\r\n Changed;\r\nend;\r\n\r\nprocedure TJvPicClip.SetHeight(Value: Integer);\r\nbegin\r\n if (Value > 0) and (Picture.Height div Value > 0) then\r\n Rows := Picture.Height div Value;\r\nend;\r\n\r\nprocedure TJvPicClip.SetWidth(Value: Integer);\r\nbegin\r\n if (Value > 0) and (Picture.Width div Value > 0) then\r\n Cols := Picture.Width div Value;\r\nend;\r\n\r\nprocedure TJvPicClip.SetPicture(Value: TPicture);\r\nbegin\r\n FPicture.Assign(Value);\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvPickDate.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvPickDate.PAS, released on 2002-07-04.\r\n\r\nThe Initial Developers of the Original Code are: Fedor Koshevnikov, Igor Pavluk and Serge Korolev\r\nCopyright (c) 1997, 1998 Fedor Koshevnikov, Igor Pavluk and Serge Korolev\r\nCopyright (c) 2001,2002 SGB Software\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\n Polaris Software\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvPickDate.pas 13145 2011-11-02 21:15:19Z ahuser $\r\n\r\nunit JvPickDate;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Variants, Windows, Messages,\r\n Controls, Graphics, Forms, Buttons, StdCtrls, Grids, ExtCtrls,\r\n SysUtils, Classes,\r\n JvTypes, JvExGrids;\r\n\r\ntype\r\n TDayOfWeek = 0..6;\r\n\r\n TJvCalendar = class(TJvExCustomGrid)\r\n private\r\n FMinDate: TDateTime; // Polaris\r\n FMaxDate: TDateTime; // Polaris\r\n FDate: TDateTime;\r\n FMonthOffset: Integer;\r\n FOnChange: TNotifyEvent;\r\n FReadOnly: Boolean;\r\n FStartOfWeek: TDayOfWeekName;\r\n FUpdating: Boolean;\r\n FUseCurrentDate: Boolean;\r\n FWeekends: TDaysOfWeek;\r\n FWeekendColor: TColor;\r\n function GetCellText(ACol, ARow: Integer): string;\r\n function GetDateElement(Index: Integer): Integer;\r\n procedure SetCalendarDate(Value: TDateTime);\r\n procedure SetDateElement(Index: Integer; Value: Integer);\r\n procedure SetStartOfWeek(Value: TDayOfWeekName);\r\n procedure SetUseCurrentDate(Value: Boolean);\r\n procedure SetWeekendColor(Value: TColor);\r\n procedure SetWeekends(Value: TDaysOfWeek);\r\n function IsWeekend(ACol, ARow: Integer): Boolean;\r\n procedure CalendarUpdate(DayOnly: Boolean);\r\n function StoreCalendarDate: Boolean;\r\n //>Polaris\r\n procedure SetMinDate(Value: TDateTime);\r\n procedure SetMaxDate(Value: TDateTime);\r\n //Polaris\r\n function GetCellDate(ACol, ARow: Integer): TDateTime;\r\n function CellInRange(ACol, ARow: Integer): Boolean;\r\n function DateInRange(ADate: TDateTime): Boolean;\r\n //Polaris\r\n FMinDate := NullDate;\r\n FMaxDate := NullDate;\r\n // '' then\r\n Day := StrToInt(TheCellText);\r\nend;\r\n\r\nfunction TJvCalendar.DaysThisMonth: Integer;\r\nbegin\r\n Result := DaysPerMonth(Year, Month);\r\nend;\r\n\r\nprocedure TJvCalendar.DrawCell(ACol, ARow: Longint; ARect: TRect; AState: TGridDrawState);\r\nvar\r\n TheText: string;\r\n\r\n //>Polaris\r\n procedure DefaultDraw;\r\n begin\r\n if TheText <> '' then\r\n begin\r\n Canvas.Brush.Style := bsClear;\r\n Canvas.TextRect(ARect, ARect.Left + (ARect.Right - ARect.Left - TextWidth(TheText)) div 2,\r\n ARect.Top + (ARect.Bottom - ARect.Top - TextHeight(TheText)) div 2, TheText);\r\n end;\r\n end;\r\n\r\n procedure PoleDraw;\r\n begin\r\n if (ARow > 0) and ((FMinDate <> NullDate) or (FMaxDate <> NullDate)) then\r\n if not CellInRange(ACol, ARow) then\r\n if TheText <> '' then\r\n begin\r\n Canvas.Font.Color := clBtnFace;\r\n if Color = clBtnFace then\r\n begin\r\n Canvas.Font.Color := clBtnHighlight;\r\n Canvas.TextRect(ARect, ARect.Left + (ARect.Right - ARect.Left - TextWidth(TheText)) div 2 + 1,\r\n ARect.Top + (ARect.Bottom - ARect.Top - TextHeight(TheText)) div 2 + 1, TheText);\r\n Canvas.Font.Color := clBtnShadow;\r\n end;\r\n end;\r\n DefaultDraw;\r\n end;\r\n // DaysThisMonth) then\r\n Result := ''\r\n else\r\n Result := IntToStr(DayNum);\r\n end;\r\nend;\r\n\r\n//>Polaris\r\n\r\nprocedure TJvCalendar.SetMinDate(Value: TDateTime);\r\nbegin\r\n if FMinDate <> Value then\r\n begin\r\n FMinDate := Value;\r\n if FDate < FMinDate then\r\n SetCalendarDate(FMinDate);\r\n // else\r\n UpdateCalendar;\r\n end;\r\nend;\r\n\r\nprocedure TJvCalendar.SetMaxDate(Value: TDateTime);\r\nbegin\r\n if FMaxDate <> Value then\r\n begin\r\n FMaxDate := Value;\r\n if FDate > FMaxDate then\r\n SetCalendarDate(FMaxDate);\r\n // else\r\n UpdateCalendar;\r\n end;\r\nend;\r\n\r\nfunction TJvCalendar.GetCellDate(ACol, ARow: Integer): TDateTime;\r\nvar\r\n DayNum: Integer;\r\nbegin\r\n Result := NullDate;\r\n if (ARow > 0) and (GetCellText(ACol, ARow) <> '') then\r\n begin\r\n DayNum := FMonthOffset + ACol + (ARow - 1) * 7;\r\n if (DayNum < 1) or (DayNum > DaysThisMonth) then\r\n Result := NullDate\r\n else\r\n Result := EncodeDate(GetDateElement(1), GetDateElement(2), DayNum);\r\n end;\r\nend;\r\n\r\nfunction TJvCalendar.CellInRange(ACol, ARow: Integer): Boolean;\r\nbegin\r\n if (Row < 1) {or ((FMinDate = NullDate) and (FMaxDate = NullDate))} then\r\n Result := True\r\n else\r\n Result := DateInRange(GetCellDate(ACol, ARow));\r\nend;\r\n\r\nfunction TJvCalendar.DateInRange(ADate: TDateTime): Boolean;\r\nbegin\r\n if ((FMinDate = NullDate) and (FMaxDate = NullDate)) or (ADate = NullDate) then\r\n Result := True\r\n else\r\n begin\r\n Result := False;\r\n if ADate = NullDate then\r\n Result := True\r\n else\r\n if (FMinDate <> NullDate) and (FMaxDate <> NullDate) then\r\n Result := (ADate >= FMinDate) and (ADate <= FMaxDate)\r\n else\r\n if FMinDate <> NullDate then\r\n Result := ADate >= FMinDate\r\n else\r\n if FMaxDate <> NullDate then\r\n Result := ADate <= FMaxDate\r\n end;\r\nend;\r\n//Polaris\r\nvar\r\n OldDay: Integer;\r\n// 1 then\r\n Day := Day - 1\r\n else\r\n CalendarDate := CalendarDate - 1;\r\n if not DateInRange(FDate) then\r\n Day := OldDay;\r\n Exit;\r\n end;\r\n VK_RIGHT, VK_ADD:\r\n begin\r\n if Day < DaysThisMonth then\r\n Day := Day + 1\r\n else\r\n CalendarDate := CalendarDate + 1;\r\n if not DateInRange(FDate) then\r\n Day := OldDay;\r\n Exit;\r\n end;\r\n end;\r\n inherited KeyDown(Key, Shift);\r\nend;\r\n\r\nprocedure TJvCalendar.KeyPress(var Key: Char);\r\nbegin\r\n if (Key = 'T') or (Key = 't') then\r\n begin\r\n CalendarDate := Trunc(Now);\r\n Key := #0;\r\n end;\r\n inherited KeyPress(Key);\r\nend;\r\n\r\nfunction TJvCalendar.SelectCell(ACol, ARow: Longint): Boolean;\r\nbegin\r\n if ((not FUpdating) and FReadOnly) or (CellText[ACol, ARow] = '') or\r\n //>Polaris\r\n not CellInRange(ACol, ARow) then {// Value then\r\n //begin\r\n if (FMinDate <> NullDate) and (Value < FMinDate) then\r\n Value := FMinDate\r\n else\r\n if (FMaxDate <> NullDate) and (Value > FMaxDate) then\r\n Value := FMaxDate;\r\n FDate := Value;\r\n UpdateCalendar;\r\n Change;\r\n //end;\r\nend;\r\n\r\nfunction TJvCalendar.StoreCalendarDate: Boolean;\r\nbegin\r\n Result := not FUseCurrentDate;\r\nend;\r\n\r\nfunction TJvCalendar.GetDateElement(Index: Integer): Integer;\r\nvar\r\n AYear, AMonth, ADay: Word;\r\nbegin\r\n DecodeDate(FDate, AYear, AMonth, ADay);\r\n case Index of\r\n 1:\r\n Result := AYear;\r\n 2:\r\n Result := AMonth;\r\n 3:\r\n Result := ADay;\r\n else\r\n Result := -1;\r\n end;\r\nend;\r\n\r\nprocedure TJvCalendar.SetDateElement(Index: Integer; Value: Integer);\r\nvar\r\n iValue: Word;\r\n TYear, TMonth, TDay: Word;\r\n AYear, AMonth, ADay: Word;\r\n //>Polaris\r\n TmpDate: TDateTime;\r\n // 0 then\r\n begin\r\n DecodeDate(FDate, AYear, AMonth, ADay);\r\n iValue := Value;\r\n case Index of\r\n 1:\r\n begin\r\n //>Polaris\r\n if FMinDate <> NullDate then\r\n begin\r\n DecodeDate(FMinDate, TYear, TMonth, TDay);\r\n if Value < TYear then\r\n Value := TYear;\r\n if (Value = TYear) and (AMonth < TMonth) then\r\n AMonth := TMonth;\r\n if (Value = TYear) and (AMonth = TMonth) and (ADay < TDay) then\r\n ADay := TDay;\r\n end;\r\n if FMaxDate <> NullDate then\r\n begin\r\n DecodeDate(FMaxDate, TYear, TMonth, TDay);\r\n if Value > TYear then\r\n Value := TYear;\r\n if (Value = TYear) and (AMonth > TMonth) then\r\n AMonth := TMonth;\r\n if (Value = TYear) and (AMonth = TMonth) and (ADay > TDay) then\r\n ADay := TDay;\r\n end;\r\n // Value then\r\n AYear := Value\r\n else\r\n Exit;\r\n end;\r\n 2:\r\n if (Value <= 12) and (Value <> AMonth) then\r\n begin\r\n //>Polaris\r\n if FMinDate <> NullDate then\r\n begin\r\n DecodeDate(FMinDate, TYear, TMonth, TDay);\r\n if (AYear = TYear) and (Value < TMonth) then\r\n Value := TMonth;\r\n if (Value = TYear) and (AMonth = TMonth) and (ADay < TDay) then\r\n ADay := TDay;\r\n end;\r\n if FMaxDate <> NullDate then\r\n begin\r\n DecodeDate(FMaxDate, TYear, TMonth, TDay);\r\n if (AYear = TYear) and (Value > TMonth) then\r\n Value := TMonth;\r\n if (Value = TYear) and (AMonth = TMonth) and (ADay > TDay) then\r\n ADay := TDay;\r\n end;\r\n // DaysPerMonth(Year, Value) then\r\n ADay := DaysPerMonth(Year, Value);\r\n //>Polaris\r\n {\r\n TmpDate := EncodeDate(AYear, AMonth, ADay);\r\n if (FMinDate <> NullDate) and (TmpDate < FMinDate) then DecodeDate(FMinDate, TYear, TMonth, ADay);\r\n if (FMaxDate <> NullDate) and (TmpDate > FMaxDate) then DecodeDate(FMaxDate, TYear, TMonth, ADay)\r\n }\r\n // ADay) then\r\n begin\r\n //>Polaris\r\n TmpDate := EncodeDate(AYear, AMonth, Value);\r\n if (FMinDate <> NullDate) and (TmpDate < FMinDate) then\r\n DecodeDate(FMinDate, TYear, TMonth, iValue);\r\n if (FMaxDate <> NullDate) and (TmpDate > FMaxDate) then\r\n DecodeDate(FMaxDate, TYear, TMonth, iValue);\r\n // FWeekendColor then\r\n begin\r\n FWeekendColor := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvCalendar.SetWeekends(Value: TDaysOfWeek);\r\nbegin\r\n if Value <> FWeekends then\r\n begin\r\n FWeekends := Value;\r\n UpdateCalendar;\r\n end;\r\nend;\r\n\r\nfunction TJvCalendar.IsWeekend(ACol, ARow: Integer): Boolean;\r\nbegin\r\n Result := TDayOfWeekName((Integer(StartOfWeek) + ACol) mod 7) in FWeekends;\r\nend;\r\n\r\nprocedure TJvCalendar.SetStartOfWeek(Value: TDayOfWeekName);\r\nbegin\r\n if Value <> FStartOfWeek then\r\n begin\r\n FStartOfWeek := Value;\r\n UpdateCalendar;\r\n end;\r\nend;\r\n\r\nprocedure TJvCalendar.SetUseCurrentDate(Value: Boolean);\r\nbegin\r\n if Value <> FUseCurrentDate then\r\n begin\r\n FUseCurrentDate := Value;\r\n if Value then\r\n begin\r\n FDate := Date; { use the current date, then }\r\n UpdateCalendar;\r\n end;\r\n end;\r\nend;\r\n\r\n{ Given a value of 1 or -1, moves to Next or Prev month accordingly }\r\n\r\nprocedure TJvCalendar.ChangeMonth(Delta: Integer);\r\nvar\r\n AYear, AMonth, ADay: Word;\r\n NewDate: TDateTime;\r\n CurDay: Integer;\r\nbegin\r\n DecodeDate(FDate, AYear, AMonth, ADay);\r\n CurDay := ADay;\r\n if Delta > 0 then\r\n ADay := DaysPerMonth(AYear, AMonth)\r\n else\r\n ADay := 1;\r\n NewDate := EncodeDate(AYear, AMonth, ADay);\r\n NewDate := NewDate + Delta;\r\n DecodeDate(NewDate, AYear, AMonth, ADay);\r\n if DaysPerMonth(AYear, AMonth) > CurDay then\r\n ADay := CurDay\r\n else\r\n ADay := DaysPerMonth(AYear, AMonth);\r\n CalendarDate := EncodeDate(AYear, AMonth, ADay);\r\nend;\r\n\r\nprocedure TJvCalendar.PrevMonth;\r\nbegin\r\n ChangeMonth(-1);\r\nend;\r\n\r\nprocedure TJvCalendar.NextMonth;\r\nbegin\r\n ChangeMonth(1);\r\nend;\r\n\r\nprocedure TJvCalendar.NextYear;\r\nbegin\r\n if IsLeapYear(Year) and (Month = 2) and (Day = 29) then\r\n Day := 28;\r\n Year := Year + 1;\r\nend;\r\n\r\nprocedure TJvCalendar.PrevYear;\r\nbegin\r\n if IsLeapYear(Year) and (Month = 2) and (Day = 29) then\r\n Day := 28;\r\n Year := Year - 1;\r\nend;\r\n\r\nprocedure TJvCalendar.CalendarUpdate(DayOnly: Boolean);\r\nvar\r\n AYear, AMonth, ADay: Word;\r\n FirstDate: TDateTime;\r\nbegin\r\n FUpdating := True;\r\n try\r\n DecodeDate(FDate, AYear, AMonth, ADay);\r\n FirstDate := EncodeDate(AYear, AMonth, 1);\r\n FMonthOffset := 2 - ((DayOfWeek(FirstDate) - Ord(StartOfWeek) + 7) mod 7);\r\n { day of week for 1st of month }\r\n if FMonthOffset = 2 then\r\n FMonthOffset := -5;\r\n MoveColRow((ADay - FMonthOffset) mod 7, (ADay - FMonthOffset) div 7 + 1, False, False);\r\n if DayOnly then\r\n Update\r\n else\r\n Invalidate;\r\n finally\r\n FUpdating := False;\r\n end;\r\nend;\r\n\r\nprocedure TJvCalendar.UpdateCalendar;\r\nbegin\r\n CalendarUpdate(False);\r\nend;\r\n\r\nprocedure TJvCalendar.BoundsChanged;\r\nvar\r\n GridLinesH, GridLinesW: Integer;\r\nbegin\r\n GridLinesH := 6 * GridLineWidth;\r\n if (goVertLine in Options) or (goFixedVertLine in Options) then\r\n GridLinesW := 6 * GridLineWidth\r\n else\r\n GridLinesW := 0;\r\n DefaultColWidth := (ClientWidth - GridLinesW) div 7;\r\n DefaultRowHeight := (ClientHeight - GridLinesH) div 7;\r\n inherited BoundsChanged;\r\nend;\r\n\r\n//=== { TJvLocCalendar } =====================================================\r\n\r\ntype\r\n TJvLocCalendar = class(TJvCalendar)\r\n protected\r\n procedure EnabledChanged; override;\r\n procedure ParentColorChanged; override;\r\n procedure CreateParams(var Params: TCreateParams); override;\r\n procedure DrawCell(ACol, ARow: Longint; ARect: TRect; AState: TGridDrawState); override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n procedure MouseToCell(X, Y: Integer; var ACol, ARow: Longint);\r\n property GridLineWidth;\r\n property DefaultColWidth;\r\n property DefaultRowHeight;\r\n end;\r\n\r\nconstructor TJvLocCalendar.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n ControlStyle := [csCaptureMouse, csClickEvents, csDoubleClicks];\r\n ControlStyle := ControlStyle + [csReplicatable];\r\n Ctl3D := False;\r\n Enabled := False;\r\n BorderStyle := bsNone;\r\n ParentColor := True;\r\n CalendarDate := Trunc(Now);\r\n UseCurrentDate := False;\r\n FixedColor := Self.Color;\r\n Options := [goFixedHorzLine];\r\n TabStop := False;\r\nend;\r\n\r\nprocedure TJvLocCalendar.ParentColorChanged;\r\nbegin\r\n inherited ParentColorChanged;\r\n if ParentColor then\r\n FixedColor := Self.Color;\r\nend;\r\n\r\nprocedure TJvLocCalendar.EnabledChanged;\r\nbegin\r\n inherited EnabledChanged;\r\n if HandleAllocated and not (csDesigning in ComponentState) then\r\n EnableWindow(Handle, True);\r\nend;\r\n\r\n\r\nprocedure TJvLocCalendar.CreateParams(var Params: TCreateParams);\r\nbegin\r\n inherited CreateParams(Params);\r\n with Params do\r\n Style := Style and not (WS_BORDER or WS_TABSTOP or WS_DISABLED);\r\nend;\r\n\r\n\r\nprocedure TJvLocCalendar.MouseToCell(X, Y: Integer; var ACol, ARow: Longint);\r\nvar\r\n Coord: TGridCoord;\r\nbegin\r\n Coord := MouseCoord(X, Y);\r\n ACol := Coord.X;\r\n ARow := Coord.Y;\r\nend;\r\n\r\nprocedure TJvLocCalendar.DrawCell(ACol, ARow: Longint; ARect: TRect;\r\n AState: TGridDrawState);\r\nvar\r\n D, M, Y: Word;\r\nbegin\r\n inherited DrawCell(ACol, ARow, ARect, AState);\r\n DecodeDate(CalendarDate, Y, M, D);\r\n D := StrToIntDef(CellText[ACol, ARow], 0);\r\n if (D > 0) and (D <= DaysPerMonth(Y, M)) then\r\n if EncodeDate(Y, M, D) = SysUtils.Date then\r\n Frame3D(Canvas, ARect, clBtnShadow, clBtnHighlight, 1);\r\nend;\r\n\r\n//=== { TJvPopupCalendar } ===================================================\r\n\r\ntype\r\n TJvPopupCalendar = class(TJvPopupWindow)\r\n private\r\n FCalendar: TJvCalendar;\r\n FTitleLabel: TLabel;\r\n FFourDigitYear: Boolean;\r\n FBtns: array [0..3] of TJvSpeedButton;\r\n procedure CalendarMouseUp(Sender: TObject; Button: TMouseButton;\r\n Shift: TShiftState; X, Y: Integer);\r\n procedure PrevMonthBtnClick(Sender: TObject);\r\n procedure NextMonthBtnClick(Sender: TObject);\r\n procedure PrevYearBtnClick(Sender: TObject);\r\n procedure NextYearBtnClick(Sender: TObject);\r\n procedure CalendarChange(Sender: TObject);\r\n procedure TopPanelDblClick(Sender: TObject);\r\n //>Polaris\r\n // function GetDate(Index: Integer): TDate;\r\n procedure SetDate(Index: Integer; Value: TDateTime);\r\n //Polaris\r\n procedure CheckButton;\r\n //Polaris\r\n procedure Invalidate; override;\r\n procedure Update; override;\r\n property MinDate: TDateTime index 0 {read GetDate} write SetDate;\r\n property MaxDate: TDateTime index 1 {read GetDate} write SetDate;\r\n // nil) and not (csDesigning in AOwner.ComponentState) and\r\n (Screen.PixelsPerInch <> 96) then\r\n begin { scale to screen res }\r\n Result.ScaleBy(Screen.PixelsPerInch, 96);\r\n { The ScaleBy method does not scale the font well, so set the\r\n font back to the original info. }\r\n TJvPopupCalendar(Result).FCalendar.ParentFont := True;\r\n TJvPopupCalendar(Result).FCalendar.MinDate := MinDate;\r\n TJvPopupCalendar(Result).FCalendar.MaxDate := MaxDate;\r\n FontSetDefault(TJvPopupCalendar(Result).Font);\r\n {$IFDEF VCL}\r\n Result.BiDiMode := ABiDiMode;\r\n {$ENDIF VCL}\r\n end;\r\n*)\r\nend;\r\n\r\nprocedure SetupPopupCalendar(PopupCalendar: TWinControl;\r\n AStartOfWeek: TDayOfWeekName; AWeekends: TDaysOfWeek;\r\n AWeekendColor: TColor; BtnHints: TStrings; FourDigitYear: Boolean;\r\n MinDate: TDateTime; MaxDate: TDateTime);\r\nvar\r\n I: Integer;\r\nbegin\r\n if (PopupCalendar = nil) or not (PopupCalendar is TJvPopupCalendar) then\r\n Exit;\r\n // Polaris\r\n if not (csDesigning in PopupCalendar.Owner.ComponentState) then\r\n begin\r\n TJvPopupCalendar(PopupCalendar).SetDate(0, MinDate);\r\n TJvPopupCalendar(PopupCalendar).SetDate(1, MaxDate);\r\n end;\r\n // Polaris\r\n // TJvPopupCalendar(PopupCalendar).MaxDate := MaxDate;\r\n\r\n TJvPopupCalendar(PopupCalendar).FFourDigitYear := FourDigitYear;\r\n if TJvPopupCalendar(PopupCalendar).FCalendar <> nil then\r\n begin\r\n with TJvPopupCalendar(PopupCalendar).FCalendar do\r\n begin\r\n StartOfWeek := AStartOfWeek;\r\n WeekendColor := AWeekendColor;\r\n Weekends := AWeekends;\r\n end;\r\n if BtnHints <> nil then\r\n for I := 0 to Min(BtnHints.Count - 1, 3) do\r\n if BtnHints[I] <> '' then\r\n TJvPopupCalendar(PopupCalendar).FBtns[I].Hint := BtnHints[I];\r\n end;\r\nend;\r\n\r\nconstructor TJvPopupCalendar.Create(AOwner: TComponent);\r\n{$IFDEF JVCLThemesEnabled}\r\nvar\r\n BtnSide: Integer;\r\n VertOffset: Integer;\r\n HorzOffset: Integer;\r\n Control, BackPanel: TWinControl;\r\n{$ELSE}\r\nconst\r\n BtnSide = 14;\r\n VertOffset = -1;\r\n HorzOffset = 1;\r\nvar\r\n Control, BackPanel: TWinControl;\r\n{$ENDIF JVCLThemesEnabled}\r\nbegin\r\n inherited Create(AOwner);\r\n FFourDigitYear := IsFourDigitYear;\r\n Height := Max(PopupCalendarSize.Y, 120);\r\n Width := Max(PopupCalendarSize.X, 180);\r\n\r\n Color := clBtnFace;\r\n FontSetDefault(Font);\r\n if AOwner is TControl then\r\n ShowHint := TControl(AOwner).ShowHint\r\n else\r\n ShowHint := True;\r\n if csDesigning in ComponentState then\r\n Exit;\r\n\r\n {$IFDEF JVCLThemesEnabled}\r\n if ThemeServices.{$IFDEF RTL230_UP}Enabled{$ELSE}ThemesEnabled{$ENDIF RTL230_UP} then\r\n begin\r\n VertOffset := 0;\r\n HorzOffset := 0;\r\n BtnSide := 16\r\n end\r\n else\r\n begin\r\n VertOffset := -1;\r\n HorzOffset := 1;\r\n BtnSide := 14;\r\n end;\r\n {$ENDIF JVCLThemesEnabled}\r\n\r\n BackPanel := TPanel.Create(Self);\r\n with BackPanel as TPanel do\r\n begin\r\n Parent := Self;\r\n Align := alClient;\r\n ParentColor := True;\r\n ControlStyle := ControlStyle + [csReplicatable];\r\n BevelOuter := bvNone;\r\n BevelInner := bvNone;\r\n end;\r\n\r\n Control := TPanel.Create(Self);\r\n with Control as TPanel do\r\n begin\r\n Parent := BackPanel;\r\n Align := alTop;\r\n Width := Self.Width - 4;\r\n Height := 18;\r\n BevelOuter := bvNone;\r\n ParentColor := True;\r\n ControlStyle := ControlStyle + [csReplicatable];\r\n end;\r\n\r\n FCalendar := TJvLocCalendar.Create(Self);\r\n with TJvLocCalendar(FCalendar) do\r\n begin\r\n Parent := BackPanel;\r\n Align := alClient;\r\n OnChange := CalendarChange;\r\n OnMouseUp := CalendarMouseUp;\r\n end;\r\n\r\n FBtns[0] := TJvTimerSpeedButton.Create(Self);\r\n with FBtns[0] do\r\n begin\r\n Parent := Control;\r\n SetBounds(0 - HorzOffset, VertOffset, BtnSide, BtnSide);\r\n CreateButtonGlyph(Glyph, 0);\r\n OnClick := PrevYearBtnClick;\r\n Hint := RsPrevYearHint;\r\n end;\r\n\r\n FBtns[1] := TJvTimerSpeedButton.Create(Self);\r\n with FBtns[1] do\r\n begin\r\n Parent := Control;\r\n SetBounds(BtnSide - 1 - HorzOffset, VertOffset, BtnSide, BtnSide);\r\n CreateButtonGlyph(Glyph, 1);\r\n OnClick := PrevMonthBtnClick;\r\n Hint := RsPrevMonthHint;\r\n end;\r\n\r\n FTitleLabel := TLabel.Create(Self);\r\n with FTitleLabel do\r\n begin\r\n Parent := Control;\r\n AutoSize := False;\r\n Alignment := taCenter;\r\n SetBounds(BtnSide * 2 + 1, 1, Control.Width - 4 * BtnSide - 2, 14);\r\n Transparent := True;\r\n OnDblClick := TopPanelDblClick;\r\n ControlStyle := ControlStyle + [csReplicatable];\r\n end;\r\n\r\n FBtns[2] := TJvTimerSpeedButton.Create(Self);\r\n with FBtns[2] do\r\n begin\r\n Parent := Control;\r\n SetBounds(Control.Width - 2 * BtnSide + 1 + HorzOffset, VertOffset, BtnSide, BtnSide);\r\n CreateButtonGlyph(Glyph, 2);\r\n OnClick := NextMonthBtnClick;\r\n Hint := RsNextMonthHint;\r\n end;\r\n\r\n FBtns[3] := TJvTimerSpeedButton.Create(Self);\r\n with FBtns[3] do\r\n begin\r\n Parent := Control;\r\n SetBounds(Control.Width - BtnSide + HorzOffset, VertOffset, BtnSide, BtnSide);\r\n CreateButtonGlyph(Glyph, 3);\r\n OnClick := NextYearBtnClick;\r\n Hint := RsNextYearHint;\r\n end;\r\n //Polaris\r\n CheckButton;\r\nend;\r\n\r\n//>Polaris\r\n\r\nprocedure TJvPopupCalendar.CheckButton;\r\nvar\r\n // CurDate: TDate;\r\n AYear, AMonth, ADay: Word;\r\nbegin\r\n if not Assigned(FCalendar) then\r\n Exit;\r\n // CurDate := TJvLocCalendar(FCalendar).CalendarDate;\r\n if TJvLocCalendar(FCalendar).MinDate = NullDate then\r\n for AYear := 0 to 1 do\r\n FBtns[AYear].Enabled := True\r\n else\r\n begin\r\n DecodeDate(TJvLocCalendar(FCalendar).MinDate, AYear, AMonth, ADay);\r\n FBtns[0].Enabled := TJvLocCalendar(FCalendar).Year > AYear;\r\n FBtns[1].Enabled := (TJvLocCalendar(FCalendar).Year > AYear) or ((TJvLocCalendar(FCalendar).Year = AYear) and\r\n (TJvLocCalendar(FCalendar).Month > AMonth));\r\n end;\r\n if TJvLocCalendar(FCalendar).MaxDate = NullDate then\r\n for AYear := 2 to 3 do\r\n FBtns[AYear].Enabled := True\r\n else\r\n begin\r\n DecodeDate(TJvLocCalendar(FCalendar).MaxDate, AYear, AMonth, ADay);\r\n FBtns[2].Enabled := (TJvLocCalendar(FCalendar).Year < AYear) or ((TJvLocCalendar(FCalendar).Year = AYear) and\r\n (TJvLocCalendar(FCalendar).Month < AMonth));\r\n FBtns[3].Enabled := TJvLocCalendar(FCalendar).Year < AYear;\r\n end;\r\nend;\r\n\r\nprocedure TJvPopupCalendar.Invalidate;\r\nbegin\r\n CheckButton;\r\n inherited Invalidate;\r\nend;\r\n\r\nprocedure TJvPopupCalendar.Update;\r\nbegin\r\n CheckButton;\r\n inherited Update;\r\nend;\r\n\r\n{\r\nfunction TJvPopupCalendar.GetDate(Index: Integer): TDateTime;\r\nbegin\r\n FCalendar.Min\r\n case Index of\r\n 0:\r\n Result := TJvLocCalendar(FCalendar).FMinDate;\r\n 1:\r\n Result := TJvLocCalendar(FCalendar).FMaxDate;\r\n else\r\n Result := NullDate;\r\n end;\r\nend;\r\n}\r\n\r\nprocedure TJvPopupCalendar.SetDate(Index: Integer; Value: TDateTime);\r\nbegin\r\n case Index of\r\n 0:\r\n TJvLocCalendar(FCalendar).FMinDate := Value;\r\n 1:\r\n TJvLocCalendar(FCalendar).FMaxDate := Value;\r\n end;\r\nend;\r\n\r\n// 0) and (FCalendar.CellText[Col, Row] <> '') then\r\n CloseUp(True);\r\n end;\r\nend;\r\n\r\nprocedure TJvPopupCalendar.TopPanelDblClick(Sender: TObject);\r\nbegin\r\n FCalendar.CalendarDate := Trunc(Now);\r\nend;\r\n\r\nprocedure TJvPopupCalendar.KeyDown(var Key: Word; Shift: TShiftState);\r\nbegin\r\n inherited KeyDown(Key, Shift);\r\n if FCalendar <> nil then\r\n case Key of\r\n VK_NEXT:\r\n if ssCtrl in Shift then\r\n FCalendar.NextYear\r\n else\r\n FCalendar.NextMonth;\r\n VK_PRIOR:\r\n if ssCtrl in Shift then\r\n FCalendar.PrevYear\r\n else\r\n FCalendar.PrevMonth;\r\n VK_RETURN:\r\n Click;\r\n else\r\n TJvLocCalendar(FCalendar).KeyDown(Key, Shift);\r\n end;\r\nend;\r\n\r\nprocedure TJvPopupCalendar.KeyPress(var Key: Char);\r\nbegin\r\n inherited KeyPress(Key);\r\n if (FCalendar <> nil) and (Key <> #0) then\r\n FCalendar.KeyPress(Key);\r\nend;\r\n\r\nfunction TJvPopupCalendar.GetValue: Variant;\r\nbegin\r\n if csDesigning in ComponentState then\r\n Result := VarFromDateTime(SysUtils.Date)\r\n else\r\n Result := VarFromDateTime(FCalendar.CalendarDate);\r\nend;\r\n\r\nprocedure TJvPopupCalendar.SetValue(const Value: Variant);\r\nbegin\r\n if not (csDesigning in ComponentState) then\r\n begin\r\n try\r\n if (Trim(ReplaceStr(VarToStr(Value), JclFormatSettings.DateSeparator, '')) = '') or\r\n VarIsNullEmpty(Value) then\r\n FCalendar.CalendarDate := VarToDateTime(SysUtils.Date)\r\n else\r\n FCalendar.CalendarDate := VarToDateTime(Value);\r\n CalendarChange(nil);\r\n except\r\n FCalendar.CalendarDate := VarToDateTime(SysUtils.Date);\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvPopupCalendar.PrevYearBtnClick(Sender: TObject);\r\nbegin\r\n FCalendar.PrevYear;\r\nend;\r\n\r\nprocedure TJvPopupCalendar.NextYearBtnClick(Sender: TObject);\r\nbegin\r\n FCalendar.NextYear;\r\nend;\r\n\r\nprocedure TJvPopupCalendar.PrevMonthBtnClick(Sender: TObject);\r\nbegin\r\n FCalendar.PrevMonth;\r\nend;\r\n\r\nprocedure TJvPopupCalendar.NextMonthBtnClick(Sender: TObject);\r\nbegin\r\n FCalendar.NextMonth;\r\nend;\r\n\r\nprocedure TJvPopupCalendar.CalendarChange(Sender: TObject);\r\nbegin\r\n FTitleLabel.Caption := FormatDateTime('MMMM, YYYY', FCalendar.CalendarDate);\r\n CheckButton; // Polaris\r\nend;\r\n\r\n//=== { TJvSelectDateDlg } ===================================================\r\n\r\ntype\r\n TJvSelectDateDlg = class(TJvForm)\r\n Calendar: TJvCalendar;\r\n TitleLabel: TLabel;\r\n procedure PrevMonthBtnClick(Sender: TObject);\r\n procedure NextMonthBtnClick(Sender: TObject);\r\n procedure PrevYearBtnClick(Sender: TObject);\r\n procedure NextYearBtnClick(Sender: TObject);\r\n procedure CalendarChange(Sender: TObject);\r\n procedure CalendarDblClick(Sender: TObject);\r\n procedure TopPanelDblClick(Sender: TObject);\r\n procedure FormKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);\r\n private\r\n FBtns: array [0..3] of TJvSpeedButton;\r\n procedure SetDate(Date: TDateTime);\r\n procedure CheckButton; // Polaris\r\n function GetDate: TDateTime;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n property Date: TDateTime read GetDate write SetDate;\r\n end;\r\n\r\nconstructor TJvSelectDateDlg.Create(AOwner: TComponent);\r\nvar\r\n Control: TWinControl;\r\nbegin\r\n inherited CreateNew(AOwner, 0); // BCB compatible\r\n Caption := RsDateDlgCaption;\r\n BorderStyle := bsToolWindow;\r\n Color := clBtnFace;\r\n BorderIcons := [biSystemMenu];\r\n ClientHeight := 158; // Polaris\r\n ClientWidth := 222;\r\n FontSetDefault(Font);\r\n Position := poScreenCenter;\r\n ShowHint := True;\r\n KeyPreview := True;\r\n\r\n Control := TPanel.Create(Self);\r\n with Control as TPanel do\r\n begin\r\n Parent := Self;\r\n SetBounds(0, 0, 222, 22);\r\n Align := alTop;\r\n BevelOuter := bvNone;\r\n BevelInner := bvNone;\r\n ParentColor := True;\r\n ParentFont := True;\r\n end;\r\n\r\n TitleLabel := TLabel.Create(Self);\r\n with TitleLabel do\r\n begin\r\n Parent := Control;\r\n SetBounds(35, 4, 152, 14);\r\n Alignment := taCenter;\r\n AutoSize := False;\r\n Caption := '';\r\n ParentFont := True;\r\n Font.Color := clNavy;\r\n Font.Style := [fsBold];\r\n Transparent := True;\r\n OnDblClick := TopPanelDblClick;\r\n end;\r\n\r\n FBtns[0] := TJvTimerSpeedButton.Create(Self);\r\n with FBtns[0] do\r\n begin\r\n Parent := Control;\r\n SetBounds(3, 3, 16, 16);\r\n CreateButtonGlyph(Glyph, 0);\r\n OnClick := PrevYearBtnClick;\r\n Flat := True;\r\n Hint := RsPrevYearHint;\r\n end;\r\n\r\n FBtns[1] := TJvTimerSpeedButton.Create(Self);\r\n with FBtns[1] do\r\n begin\r\n Parent := Control;\r\n SetBounds(19, 3, 16, 16);\r\n CreateButtonGlyph(Glyph, 1);\r\n OnClick := PrevMonthBtnClick;\r\n Flat := True;\r\n Hint := RsPrevMonthHint;\r\n end;\r\n\r\n FBtns[2] := TJvTimerSpeedButton.Create(Self);\r\n with FBtns[2] do\r\n begin\r\n Parent := Control;\r\n SetBounds(188, 3, 16, 16);\r\n CreateButtonGlyph(Glyph, 2);\r\n OnClick := NextMonthBtnClick;\r\n Flat := True;\r\n Hint := RsNextMonthHint;\r\n end;\r\n\r\n FBtns[3] := TJvTimerSpeedButton.Create(Self);\r\n with FBtns[3] do\r\n begin\r\n Parent := Control;\r\n SetBounds(204, 3, 16, 16);\r\n CreateButtonGlyph(Glyph, 3);\r\n OnClick := NextYearBtnClick;\r\n Flat := True;\r\n Hint := RsNextYearHint;\r\n end;\r\n\r\n Control := TPanel.Create(Self);\r\n with Control as TPanel do\r\n begin\r\n Parent := Self;\r\n SetBounds(0, 133, 222, 25); // Polaris\r\n Align := alBottom;\r\n BevelInner := bvNone;\r\n BevelOuter := bvNone;\r\n ParentFont := True;\r\n ParentColor := True;\r\n end;\r\n\r\n { with TButton.Create(Self) do\r\n begin\r\n Parent := Control;\r\n SetBounds(0, 0, 112, 21);\r\n Caption := ResStr(SOKButton);\r\n ModalResult := mrOk;\r\n end;\r\n\r\n with TButton.Create(Self) do\r\n begin\r\n Parent := Control;\r\n SetBounds(111, 0, 111, 21);\r\n Caption := ResStr(SCancelButton);\r\n ModalResult := mrCancel;\r\n Cancel := True;\r\n end; }// Polaris\r\n\r\n with TButton.Create(Self) do\r\n begin // Polaris\r\n Parent := Control;\r\n SetBounds(0, 0, 111, 25);\r\n Default := True;\r\n ModalResult := mrOk;\r\n Caption := RsButtonOKCaption;\r\n// Kind := bkOk;\r\n end;\r\n\r\n with TButton.Create(Self) do\r\n begin // Polaris\r\n Parent := Control;\r\n SetBounds(111, 0, 111, 25);\r\n Cancel := True;\r\n ModalResult := mrCancel;\r\n Caption := RsButtonCancelCaption;\r\n// Kind := bkCancel;\r\n end;\r\n\r\n Control := TPanel.Create(Self);\r\n with Control as TPanel do\r\n begin\r\n Parent := Self;\r\n SetBounds(0, 22, 222, 111);\r\n Align := alClient;\r\n BevelInner := bvLowered;\r\n ParentFont := True;\r\n ParentColor := True;\r\n end;\r\n\r\n Calendar := TJvCalendar.Create(Self);\r\n with Calendar do\r\n begin\r\n Parent := Control;\r\n Align := alClient;\r\n ParentFont := True;\r\n SetBounds(2, 2, 218, 113);\r\n Color := clWhite;\r\n TabOrder := 0;\r\n UseCurrentDate := False;\r\n Options := Options - [goFixedVertLine, goFixedHorzLine, goVertLine, goHorzLine];\r\n OnChange := CalendarChange;\r\n OnDblClick := CalendarDblClick;\r\n end;\r\n\r\n OnKeyDown := FormKeyDown;\r\n Calendar.CalendarDate := Trunc(Now);\r\n ActiveControl := Calendar;\r\nend;\r\n\r\n\r\n\r\nprocedure TJvSelectDateDlg.SetDate(Date: TDateTime);\r\nbegin\r\n if Date = NullDate then\r\n Date := SysUtils.Date;\r\n try\r\n Calendar.CalendarDate := Date;\r\n CalendarChange(nil);\r\n except\r\n Calendar.CalendarDate := SysUtils.Date;\r\n end;\r\nend;\r\n\r\nfunction TJvSelectDateDlg.GetDate: TDateTime;\r\nbegin\r\n Result := Calendar.CalendarDate;\r\nend;\r\n\r\nprocedure TJvSelectDateDlg.TopPanelDblClick(Sender: TObject);\r\nbegin\r\n SetDate(Trunc(Now));\r\nend;\r\n\r\nprocedure TJvSelectDateDlg.PrevYearBtnClick(Sender: TObject);\r\nbegin\r\n Calendar.PrevYear;\r\nend;\r\n\r\nprocedure TJvSelectDateDlg.NextYearBtnClick(Sender: TObject);\r\nbegin\r\n Calendar.NextYear;\r\nend;\r\n\r\nprocedure TJvSelectDateDlg.PrevMonthBtnClick(Sender: TObject);\r\nbegin\r\n Calendar.PrevMonth;\r\nend;\r\n\r\nprocedure TJvSelectDateDlg.NextMonthBtnClick(Sender: TObject);\r\nbegin\r\n Calendar.NextMonth;\r\nend;\r\n\r\n//>Polaris\r\n\r\nprocedure TJvSelectDateDlg.CheckButton;\r\nvar\r\n // CurDate: TDate;\r\n AYear, AMonth, ADay: Word;\r\nbegin\r\n if not Assigned(Calendar) then\r\n Exit;\r\n // CurDate := Calendar.CalendarDate;\r\n if Calendar.MinDate = NullDate then\r\n for AYear := 0 to 1 do\r\n FBtns[AYear].Enabled := True\r\n else\r\n begin\r\n DecodeDate(Calendar.MinDate, AYear, AMonth, ADay);\r\n FBtns[0].Enabled := Calendar.Year > AYear;\r\n FBtns[1].Enabled := (Calendar.Year > AYear) or ((Calendar.Year = AYear) and (Calendar.Month > AMonth));\r\n end;\r\n if Calendar.MaxDate = NullDate then\r\n for AYear := 2 to 3 do\r\n FBtns[AYear].Enabled := True\r\n else\r\n begin\r\n DecodeDate(Calendar.MaxDate, AYear, AMonth, ADay);\r\n FBtns[2].Enabled := (Calendar.Year < AYear) or ((Calendar.Year = AYear) and (Calendar.Month < AMonth));\r\n FBtns[3].Enabled := Calendar.Year < AYear;\r\n end;\r\nend;\r\n// '' then\r\n Result.Caption := DlgCaption;\r\n Result.Calendar.MinDate := MinDate; // Polaris\r\n Result.Calendar.MaxDate := MaxDate; // Polaris\r\n if Screen.PixelsPerInch <> 96 then\r\n begin { scale to screen res }\r\n Result.ScaleBy(Screen.PixelsPerInch, 96);\r\n { The ScaleBy method does not scale the font well, so set the\r\n font back to the original info. }\r\n Result.Calendar.ParentFont := True;\r\n FontSetDefault(Result.Font);\r\n Result.Left := (Screen.Width div 2) - (Result.Width div 2);\r\n Result.Top := (Screen.Height div 2) - (Result.Height div 2);\r\n end;\r\n except\r\n Result.Free;\r\n raise;\r\n end;\r\nend;\r\n\r\nfunction PopupDate(var Date: TDateTime; Edit: TWinControl;\r\n MinDate: TDateTime; MaxDate: TDateTime): Boolean;\r\nvar\r\n D: TJvSelectDateDlg;\r\n P: TPoint;\r\n W, H, X, Y: Integer;\r\nbegin\r\n Result := False;\r\n D := CreateDateDialog('', MinDate, MaxDate);\r\n try\r\n D.BorderIcons := [];\r\n D.HandleNeeded;\r\n D.Position := poDesigned;\r\n W := D.Width;\r\n H := D.Height;\r\n P := (Edit.ClientOrigin);\r\n Y := P.Y + Edit.Height - 1;\r\n if (Y + H) > Screen.Height then\r\n Y := P.Y - H + 1;\r\n if Y < 0 then\r\n Y := P.Y + Edit.Height - 1;\r\n X := (P.X + Edit.Width) - W;\r\n if X < 0 then\r\n X := P.X;\r\n D.Left := X;\r\n D.Top := Y;\r\n D.Date := Date;\r\n if D.ShowModal = mrOk then\r\n begin\r\n Date := D.Date;\r\n Result := True;\r\n end;\r\n finally\r\n D.Free;\r\n end;\r\nend;\r\n\r\nfunction SelectDate(Sender: TWinControl; var Date: TDateTime; const DlgCaption: TCaption;\r\n AStartOfWeek: TDayOfWeekName; AWeekends: TDaysOfWeek;\r\n AWeekendColor: TColor; BtnHints: TStrings;\r\n MinDate: TDateTime; MaxDate: TDateTime): Boolean;\r\nvar\r\n D: TJvSelectDateDlg;\r\n I: Integer;\r\n P: TPoint;\r\n Rect: TRect;\r\n Monitor: TMonitor;\r\nbegin\r\n Result := False;\r\n D := CreateDateDialog(DlgCaption, MinDate, MaxDate);\r\n try\r\n // for popup position\r\n if Assigned(Sender) then\r\n begin\r\n D.Position := poDesigned;\r\n P := Sender.ClientOrigin;\r\n D.Top := P.Y + Sender.Height - 1;\r\n\r\n Monitor := FindMonitor(MonitorFromWindow(Sender.Handle, MONITOR_DEFAULTTONEAREST));\r\n Rect := GetWorkAreaRect(Monitor);\r\n\r\n if (D.Top + D.Height) > Rect.Bottom then\r\n D.Top := P.Y - D.Height + 1;\r\n if D.Top < 0 then\r\n D.Top := P.Y + Sender.Height - 1;\r\n D.Left := (P.X + Sender.Width) - D.Width;\r\n if (D.Left + D.Width) > Rect.Right then\r\n D.Left := Rect.Right - D.Width;\r\n if D.Left < 0 then\r\n D.Left := Max(P.X, 0);\r\n end;\r\n\r\n D.Date := Date;\r\n with D.Calendar do\r\n begin\r\n StartOfWeek := AStartOfWeek;\r\n Weekends := AWeekends;\r\n WeekendColor := AWeekendColor;\r\n end;\r\n if BtnHints <> nil then\r\n for I := 0 to Min(BtnHints.Count - 1, 3) do\r\n begin\r\n if BtnHints[I] <> '' then\r\n D.FBtns[I].Hint := BtnHints[I];\r\n end;\r\n if D.ShowModal = mrOk then\r\n begin\r\n Date := D.Date;\r\n Result := True;\r\n end;\r\n finally\r\n D.Free;\r\n end;\r\nend;\r\n\r\nfunction SelectDateStr(Sender: TWinControl; var StrDate: string; const DlgCaption: TCaption;\r\n AStartOfWeek: TDayOfWeekName; AWeekends: TDaysOfWeek;\r\n AWeekendColor: TColor; BtnHints: TStrings;\r\n MinDate: TDateTime; MaxDate: TDateTime): Boolean;\r\nvar\r\n DateValue: TDateTime;\r\nbegin\r\n if StrDate <> '' then\r\n begin\r\n try\r\n DateValue := StrToDateFmt(JclFormatSettings.ShortDateFormat, StrDate);\r\n except\r\n DateValue := Date;\r\n end;\r\n end\r\n else\r\n DateValue := Date;\r\n Result := SelectDate(Sender, DateValue, DlgCaption, AStartOfWeek, AWeekends,\r\n AWeekendColor, BtnHints, MinDate, MaxDate); // Polaris\r\n if Result then\r\n StrDate := FormatDateTime(JclFormatSettings.ShortDateFormat, DateValue);\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvPlaylist.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvPlaylist.PAS, released on 2001-02-28.\r\n\r\nThe Initial Developer of the Original Code is Sbastien Buysse [sbuysse att buypin dott com]\r\nPortions created by Sbastien Buysse are Copyright (C) 2001 Sbastien Buysse.\r\nAll Rights Reserved.\r\n\r\nContributor(s): Michael Beck [mbeck att bigfoot dott com].\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvPlaylist.pas 13138 2011-10-26 23:17:50Z jfudickar $\r\n\r\nunit JvPlaylist;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n SysUtils, Classes, Messages, Controls, StdCtrls,\r\n JvListBox;\r\n\r\ntype\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvPlaylist = class(TJvListBox)\r\n private\r\n FShowNumbers: Boolean;\r\n FItems: TStringList;\r\n FShowExtension: Boolean;\r\n FRefresh: Boolean;\r\n FShowDrive: Boolean;\r\n function GetItems: TStrings;\r\n procedure SetShowNumbers(const Value: Boolean);\r\n procedure SetItems(const Value: TStrings);\r\n procedure SetShowExtension(const Value: Boolean);\r\n procedure SetShowDrive(const Value: Boolean);\r\n protected\r\n procedure LBDeleteString(var Msg: TMessage); message LB_DELETESTRING;\r\n procedure Changed; override;\r\n function GetPath(Value: string; Position: Integer): string;\r\n procedure Refresh;\r\n procedure ItemsChanged(Sender: TObject);\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n procedure AddItem(Item: string; AObject: TObject); override;\r\n procedure AddItems(Value: TStrings);\r\n function GetItem(Index: Integer): string;\r\n procedure DeleteDeadFiles;\r\n procedure SortBySongName;\r\n procedure SortByPath;\r\n procedure SortByPathInverted;\r\n procedure SortBySongNameInverted;\r\n procedure ReverseOrder;\r\n procedure RandomOrder;\r\n procedure MoveSelectedUp; override;\r\n procedure MoveSelectedDown; override;\r\n procedure SavePlaylist(FileName: string);\r\n procedure LoadPlaylist(FileName: string);\r\n published\r\n property ShowDrive: Boolean read FShowDrive write SetShowDrive default True;\r\n property ShowNumbers: Boolean read FShowNumbers write SetShowNumbers default False;\r\n property ShowExtension: Boolean read FShowExtension write SetShowExtension default False;\r\n property Items: TStrings read GetItems write SetItems;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvPlaylist.pas $';\r\n Revision: '$Revision: 13138 $';\r\n Date: '$Date: 2011-10-27 01:17:50 +0200 (jeu. 27 oct. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\n\r\n// (rom) better simplify by eliminating FItems altogether\r\n\r\nconstructor TJvPlaylist.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FShowDrive := True;\r\n FShowNumbers := False;\r\n FShowExtension := False;\r\n FRefresh := False;\r\n FItems := TStringList.Create;\r\n FItems.OnChange := ItemsChanged;\r\nend;\r\n\r\ndestructor TJvPlaylist.Destroy;\r\nbegin\r\n FItems.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJvPlaylist.GetPath(Value: string; Position: Integer): string;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := Value;\r\n if not ShowDrive then\r\n begin\r\n I := Pos(':', Result);\r\n if I > 0 then\r\n Result := Copy(Result, I + 1, Length(Result));\r\n end;\r\n if not ShowExtension then\r\n Result := ChangeFileExt(Result, '');\r\n if ShowNumbers then\r\n Result := IntToStr(Position + 1) + '. ' + Result;\r\nend;\r\n\r\nprocedure TJvPlaylist.AddItem(Item: string; AObject: TObject);\r\nbegin\r\n Items.AddObject(Item, AObject);\r\nend;\r\n\r\nprocedure TJvPlaylist.AddItems(Value: TStrings);\r\nbegin\r\n Items.AddStrings(Value);\r\nend;\r\n\r\nfunction TJvPlaylist.GetItem(Index: Integer): string;\r\nbegin\r\n Result := Items[Index];\r\nend;\r\n\r\nprocedure TJvPlaylist.DeleteDeadFiles;\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := Items.Count - 1 downto 0 do\r\n if not FileExists(Items[I]) then\r\n Items.Delete(I);\r\nend;\r\n\r\nprocedure TJvPlaylist.SortBySongName;\r\nvar\r\n A, B, C: Integer;\r\nbegin\r\n FRefresh := True;\r\n for A := 0 to Items.Count - 1 do\r\n begin\r\n C := A;\r\n for B := A to Items.Count - 1 do\r\n if ExtractFileName(Items[B]) < ExtractFileName(Items[C]) then\r\n C := B;\r\n Items.Exchange(A, C);\r\n end;\r\n FRefresh := False;\r\n Refresh;\r\nend;\r\n\r\nprocedure TJvPlaylist.SortByPath;\r\nbegin\r\n FItems.Sort;\r\nend;\r\n\r\nprocedure TJvPlaylist.SortByPathInverted;\r\nbegin\r\n FItems.Sort;\r\n ReverseOrder;\r\nend;\r\n\r\nprocedure TJvPlaylist.SortBySongNameInverted;\r\nbegin\r\n SortBySongName;\r\n ReverseOrder;\r\nend;\r\n\r\nprocedure TJvPlaylist.ReverseOrder;\r\nvar\r\n I, J: Integer;\r\nbegin\r\n J := FItems.Count - 1;\r\n for I := 0 to FItems.Count div 2 - 1 do\r\n FItems.Exchange(I, J - I);\r\nend;\r\n\r\nprocedure TJvPlaylist.RandomOrder;\r\nvar\r\n I, J, K: Integer;\r\nbegin\r\n Randomize;\r\n for I := 0 to FItems.Count div 2 do\r\n begin\r\n J := Random(FItems.Count);\r\n K := Random(FItems.Count);\r\n FItems.Exchange(J, K);\r\n end;\r\nend;\r\n\r\nprocedure TJvPlaylist.SavePlaylist(FileName: string);\r\nbegin\r\n FItems.SaveToFile(FileName);\r\nend;\r\n\r\nprocedure TJvPlaylist.LoadPlaylist(FileName: string);\r\n{var\r\n St, St2: string;\r\n I: Integer;}\r\nbegin\r\n FItems.LoadFromFile(FileName);\r\n{\r\n FItems.Clear;\r\n with TStringList.Create do\r\n begin\r\n LoadFromFile(FileName);\r\n for I := 0 to Count - 1 do\r\n begin\r\n St := Strings[I];\r\n if Length(St) > 0 then\r\n if St[1] <> '#' then\r\n begin\r\n St2 := ExtractFilePath(FileName);\r\n if St2[Length(St2)] <> '\\' then\r\n St2 := St2 + '\\';\r\n if (not FileExists(St)) or (Pos('\\', St) = 0) then\r\n if FileExists(St2 + St) then\r\n St := St2 + St;\r\n FItems.Add(St);\r\n end;\r\n end;\r\n Free;\r\n end;\r\n }\r\nend;\r\n\r\nprocedure TJvPlaylist.Refresh;\r\nvar\r\n I: Integer;\r\nbegin\r\n FRefresh := True;\r\n inherited Items.BeginUpdate;\r\n if Items.Count <> inherited Items.Count then\r\n begin\r\n inherited Items.Clear;\r\n for I := 0 to Items.Count - 1 do\r\n inherited Items.Add(GetPath(Items[I], I));\r\n end\r\n else\r\n for I := 0 to Items.Count - 1 do\r\n inherited Items[I] := GetPath(Items[I], I);\r\n inherited Items.EndUpdate;\r\n FRefresh := False;\r\nend;\r\n\r\nprocedure TJvPlaylist.SetShowNumbers(const Value: Boolean);\r\nbegin\r\n if Value <> FShowNumbers then\r\n begin\r\n FShowNumbers := Value;\r\n Refresh;\r\n end;\r\nend;\r\n\r\nfunction TJvPlaylist.GetItems: TStrings;\r\nbegin\r\n Result := FItems;\r\nend;\r\n\r\nprocedure TJvPlaylist.SetItems(const Value: TStrings);\r\nbegin\r\n FItems.Assign(Value);\r\n Refresh;\r\nend;\r\n\r\nprocedure TJvPlaylist.SetShowExtension(const Value: Boolean);\r\nbegin\r\n if Value <> FShowExtension then\r\n begin\r\n FShowExtension := Value;\r\n Refresh;\r\n end;\r\nend;\r\n\r\nprocedure TJvPlaylist.ItemsChanged(Sender: TObject);\r\nbegin\r\n Refresh;\r\nend;\r\n\r\n\r\nprocedure TJvPlaylist.LBDeleteString(var Msg: TMessage);\r\nbegin\r\n inherited;\r\n if not FRefresh then\r\n begin\r\n FItems.OnChange := nil;\r\n Items.Delete(Longint(Msg.WParam));\r\n FItems.OnChange := ItemsChanged;\r\n end;\r\nend;\r\n\r\n\r\nprocedure TJvPlaylist.Changed;\r\nbegin\r\n Refresh;\r\nend;\r\n\r\nprocedure TJvPlaylist.MoveSelectedDown;\r\nvar\r\n I: Integer;\r\nbegin\r\n if MultiSelect = False then\r\n begin\r\n if (ItemIndex <> -1) and (ItemIndex < Items.Count - 1) then\r\n begin\r\n Items.Exchange(ItemIndex, ItemIndex + 1);\r\n ItemIndex := ItemIndex + 1;\r\n end;\r\n Exit;\r\n end;\r\n FItems.OnChange := nil;\r\n FRefresh := True;\r\n if (Items.Count > 0) and (SelCount > 0) and not Selected[Items.Count - 1] then\r\n begin\r\n I := Items.Count - 2;\r\n while I >= 0 do\r\n begin\r\n if Selected[I] then\r\n begin\r\n Items.Exchange(I, I + 1);\r\n Selected[I + 1] := True;\r\n end;\r\n Dec(I);\r\n end;\r\n end;\r\n FRefresh := False;\r\n FItems.OnChange := ItemsChanged;\r\n Refresh;\r\nend;\r\n\r\nprocedure TJvPlaylist.MoveSelectedUp;\r\nvar\r\n I: Integer;\r\nbegin\r\n if MultiSelect = False then\r\n begin\r\n if ItemIndex > 1 then\r\n begin\r\n Items.Exchange(ItemIndex, ItemIndex - 1);\r\n ItemIndex := ItemIndex - 1;\r\n end;\r\n Exit;\r\n end;\r\n FItems.OnChange := nil;\r\n FRefresh := True;\r\n if (Items.Count > 0) and (SelCount > 0) and not Selected[0] then\r\n begin\r\n I := 1;\r\n while I < Items.Count do\r\n begin\r\n if Selected[I] then\r\n begin\r\n Items.Exchange(I, I - 1);\r\n Selected[I - 1] := True;\r\n end;\r\n Inc(I);\r\n end;\r\n end;\r\n FRefresh := False;\r\n FItems.OnChange := ItemsChanged;\r\n Refresh;\r\nend;\r\n\r\nprocedure TJvPlaylist.SetShowDrive(const Value: Boolean);\r\nbegin\r\n if FShowDrive <> Value then\r\n begin\r\n FShowDrive := Value;\r\n Refresh;\r\n end;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvPlugin.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: uilPlugin.PAS, released on 1999-09-06.\r\n\r\nThe Initial Developer of the Original Code is Tim Sullivan [tim att uil dott net]\r\nPortions created by Tim Sullivan are Copyright (C) 1999 Tim Sullivan.\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\nRalf Steinhaeusser [ralfiii att gmx dott net].\r\nGustavo Bianconi\r\nSteefan Lesage - converted to use new OTA\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n\r\nTodo : Why the \"stdcall\" definitions ? (routines Configure, Initialize...)\r\n Why the TriggerConfigureEvent (and similar) procedures ? necessary ?\r\n What for the GlobalNameSpace.BeginWrite ?\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvPlugin.pas 13249 2012-02-27 15:47:36Z obones $\r\n\r\nunit JvPlugin;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Types, SysUtils, Classes, Forms, Graphics;\r\n\r\ntype\r\n // For legacy reasons, the first one still exists but you are encouraged to use the second\r\n TPluginMessageEvent = procedure(Sender: TObject; APluginMessage: Longint; AMessageText: string) of object;\r\n TPluginMessageObjEvent = procedure(Sender: TObject; APluginMessage: Longint; AMessageText: string; AObj:TObject) of object;\r\n TPluginInitializeEvent = procedure(Sender: TObject; var AllowLoad: Boolean) of object;\r\n TJvPluginCommand = class;\r\n TJvPluginCommands = class;\r\n\r\n TJvPlugIn = class(TDataModule)\r\n private\r\n FPluginID: string;\r\n FAuthor: string;\r\n FCopyright: string;\r\n FDescription: string;\r\n FFileName: TFileName;\r\n FCommands: TJvPluginCommands;\r\n FHostApplication: TApplication;\r\n FManager: TComponent;\r\n FInstanceCount: Integer;\r\n FOnPluginMessage: TPluginMessageEvent;\r\n FOnBroadcastToAllMessage: TPluginMessageEvent;\r\n FOnPluginMessageObj: TPluginMessageObjEvent;\r\n FOnBroadcastToAllMessageObj: TPluginMessageObjEvent;\r\n FOnInitialize: TPluginInitializeEvent;\r\n FOnConfigure: TNotifyEvent;\r\n FPluginVersion: string;\r\n// function GetVersion: string;\r\n// procedure SetVersion(newValue: string);\r\n protected\r\n procedure SetCommands(NewValue: TJvPluginCommands); virtual;\r\n procedure TriggerPluginMessageEvent(APluginMessage: Longint; AMessageText: string); virtual;\r\n procedure TriggerInitializeEvent(var AllowLoad: Boolean); virtual;\r\n procedure TriggerConfigureEvent; virtual;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n\r\n procedure Configure; virtual; stdcall;\r\n function Initialize(Manager: TComponent; HostApplication: TApplication;\r\n FileName: string): Boolean; virtual; stdcall;\r\n procedure SendPluginMessage(APluginMessage: Longint; AMessageText: string);\r\n procedure BroadcastMsgToALL(APluginMessage: Longint; AMessageText: string); virtual; stdcall;\r\n procedure BroadcastMsgToALLObj(APluginMessage: Longint; AMessageText: string; AObj:TObject);\r\n // Only reason I can think of that would require BroadcastMsgToALL to be exported is when the plugin needs to\r\n // send a message to other modules in order to function properly. In such a case the host\r\n // would need to implement a rebroadcast method. In Delphi this is done by the Plugin Manager,\r\n // other languages, implementation of rebroadcast. Leaving the obj ver alone for now.\r\n\r\n property HostApplication: TApplication read FHostApplication;\r\n property Manager: TComponent read FManager;\r\n property FileName: TFileName read FFileName;\r\n\r\n // Host uses this Event property (not the plugin component through the object inspector) so it is not published.\r\n property OnPluginBroadcast: TPluginMessageEvent read FOnBroadcastToAllMessage write FOnBroadcastToAllMessage;\r\n property OnPluginBroadcastObj: TPluginMessageObjEvent read FOnBroadcastToAllMessageObj write FOnBroadcastToAllMessageObj;\r\n published\r\n property Author: string read FAuthor write FAuthor;\r\n property Commands: TJvPluginCommands read FCommands write SetCommands;\r\n property Description: string read FDescription write FDescription;\r\n property Copyright: string read FCopyright write FCopyright;\r\n property InstanceCount: Integer read FInstanceCount write FInstanceCount default 1;\r\n property PluginID: string read FPluginID write FPluginID;\r\n// property Version: string read GetVersion write SetVersion;\r\n property PluginVersion: string read FPluginVersion write FPluginVersion;\r\n property OnPluginMessage: TPluginMessageEvent read FOnPluginMessage write FOnPluginMessage;\r\n property OnPluginMessageWithObj: TPluginMessageObjEvent read FOnPluginMessageObj write FOnPluginMessageObj;\r\n property OnInitialize: TPluginInitializeEvent read FOnInitialize write FOnInitialize;\r\n property OnConfigure: TNotifyEvent read FOnConfigure write FOnConfigure;\r\n end;\r\n\r\n TJvPluginCommand = class(TCollectionItem)\r\n private\r\n FName: string;\r\n FCaption: string;\r\n FHint: string;\r\n FData: string;\r\n FShortCut: TShortCut;\r\n FBitmap: TBitmap;\r\n FOnExecute: TNotifyEvent;\r\n procedure SetBitmap(Value: TBitmap);\r\n protected\r\n function GetDisplayName: string; override;\r\n published\r\n constructor Create(Collection: TCollection); override;\r\n destructor Destroy; override;\r\n property Bitmap: TBitmap read FBitmap write SetBitmap;\r\n property Caption: string read FCaption write FCaption;\r\n property Hint: string read FHint write FHint;\r\n property Data: string read FData write FData;\r\n property Name: string read FName write FName;\r\n property ShortCut: TShortCut read FShortCut write FShortCut;\r\n property OnExecute: TNotifyEvent read FOnExecute write FOnExecute;\r\n end;\r\n\r\n TJvPluginCommands = class(TCollection)\r\n private\r\n FPlugin: TJvPlugIn;\r\n protected\r\n function GetOwner: TPersistent; override;\r\n procedure SetItemName(AItem: TCollectionItem); override;\r\n public\r\n constructor Create(APlugIn: TJvPlugIn);\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvPlugin.pas $';\r\n Revision: '$Revision: 13249 $';\r\n Date: '$Date: 2012-02-27 16:47:36 +0100 (lun. 27 févr. 2012) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n JvResources;\r\n\r\n//=== { TJvPlugin } ==========================================================\r\n\r\nconstructor TJvPlugIn.Create(AOwner: TComponent);\r\nbegin\r\n // Create datamodule\r\n CreateNew(AOwner);\r\n DesignSize := Point(100, 100);\r\n\r\n // Create commands-collection\r\n FCommands := TJvPluginCommands.Create(Self);\r\n\r\n FInstanceCount := 1;\r\n if (ClassType <> TJvPlugIn) and not (csDesigning in ComponentState) then\r\n begin\r\n if not InitInheritedComponent(Self, TJvPlugIn) then\r\n raise EResNotFound.CreateResFmt(@RsEFmtResNotFound, [ClassName]);\r\n\r\n if OldCreateOrder then\r\n DoCreate;\r\n end;\r\nend;\r\n\r\ndestructor TJvPlugIn.Destroy;\r\nbegin\r\n Commands.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvPlugIn.SetCommands(NewValue: TJvPluginCommands);\r\nbegin\r\n FCommands.Assign(NewValue);\r\nend;\r\n\r\n// Show Versionsstring defined in JvPlugCommon\r\n\r\n{function TJvPlugin.GetVersion: string;\r\nbegin\r\n Result := C_VersionString;\r\nend;\r\n\r\nprocedure TJvPlugin.SetVersion(newValue: string);\r\nbegin\r\nend;}\r\n\r\n// Here the plugin should verify if it CAN be loaded (e.g. Main application implements correct interface,\r\n// Dongle is there....)\r\n\r\nfunction TJvPlugIn.Initialize(Manager: TComponent; HostApplication: TApplication; FileName: string): Boolean;\r\nbegin\r\n Result := True;\r\n FHostApplication := HostApplication;\r\n FFileName := FileName;\r\n FManager := Manager;\r\n TriggerInitializeEvent(Result);\r\nend;\r\n\r\nprocedure TJvPlugIn.Configure;\r\nbegin\r\n TriggerConfigureEvent;\r\nend;\r\n\r\nprocedure TJvPlugIn.TriggerPluginMessageEvent(APluginMessage: Longint; AMessageText: string);\r\nbegin\r\n if Assigned(FOnPluginMessage) then\r\n FOnPluginMessage(Self, APluginMessage, AMessageText);\r\nend;\r\n\r\nprocedure TJvPlugIn.TriggerInitializeEvent(var AllowLoad: Boolean);\r\nbegin\r\n if Assigned(FOnInitialize) then\r\n FOnInitialize(Self, AllowLoad);\r\nend;\r\n\r\nprocedure TJvPlugIn.TriggerConfigureEvent;\r\nbegin\r\n if Assigned(FOnConfigure) then\r\n FOnConfigure(Self);\r\nend;\r\n\r\nprocedure TJvPlugIn.SendPluginMessage(APluginMessage: Integer; AMessageText: string);\r\nbegin\r\n TriggerPluginMessageEvent(APluginMessage, AMessageText);\r\nend;\r\n\r\nprocedure TJvPlugIn.BroadcastMsgToALL(APluginMessage: Integer; AMessageText: string);\r\nbegin\r\n // Remember, when called, this method will trigger assigned method within host, not within the plugin component.\r\n if Assigned(FOnBroadcastToAllMessage) then\r\n FOnBroadcastToAllMessage(Self, APluginMessage, AMessageText);\r\nend;\r\n\r\nprocedure TJvPlugIn.BroadcastMsgToALLObj(APluginMessage: Integer; AMessageText: string; AObj: TObject);\r\nbegin\r\n // Remember, when called, this method will trigger assigned method within host, not within the plugin component.\r\n if Assigned(FOnBroadcastToAllMessageObj) then\r\n FOnBroadcastToAllMessageObj(Self, APluginMessage, AMessageText, AObj);\r\nend;\r\n\r\n//=== { TJvPluginCommand } ===================================================\r\n\r\nconstructor TJvPluginCommand.Create(Collection: TCollection);\r\nbegin\r\n inherited Create(Collection);\r\n FBitmap := TBitmap.Create;\r\n FShortCut := 0;\r\nend;\r\n\r\ndestructor TJvPluginCommand.Destroy;\r\nbegin\r\n FBitmap.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJvPluginCommand.GetDisplayName: string;\r\nbegin\r\n Result := Name;\r\n if Result = '' then\r\n Result := inherited GetDisplayName;\r\nend;\r\n\r\nprocedure TJvPluginCommand.SetBitmap(Value: TBitmap);\r\nbegin\r\n FBitmap.Assign(Value)\r\nend;\r\n\r\n//=== { TJvPluginCommands } ==================================================\r\n\r\nconstructor TJvPluginCommands.Create(APlugIn: TJvPlugIn);\r\nbegin\r\n inherited Create(TJvPluginCommand);\r\n FPlugin := APlugIn;\r\nend;\r\n\r\nfunction TJvPluginCommands.GetOwner: TPersistent;\r\nbegin\r\n Result := FPlugin;\r\nend;\r\n\r\nprocedure TJvPluginCommands.SetItemName(AItem: TCollectionItem);\r\nvar\r\n I: Integer;\r\n J: Integer;\r\n\r\n function NameUsed: Boolean;\r\n var\r\n AName: string;\r\n begin\r\n AName := Format('Command%d', [I]);\r\n J := AItem.Collection.Count - 1;\r\n while (J > -1) and not AnsiSameText(TJvPluginCommand(AItem.Collection.Items[J]).Name, AName) do\r\n Dec(J);\r\n Result := J > -1;\r\n end;\r\n\r\n procedure FindCmdIdx;\r\n begin\r\n I := 1;\r\n while (I < MaxInt) and NameUsed do\r\n Inc(I);\r\n end;\r\n\r\nbegin\r\n with TJvPluginCommand(AItem) do\r\n if Name = '' then\r\n begin\r\n FindCmdIdx;\r\n Name := Format('Command%d', [I]);\r\n end;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvPluginManager.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: uilPluginMan.PAS, released on 1999-09-06.\r\n\r\nThe Initial Developer of the Original Code is Tim Sullivan [tim att uil dott net]\r\nPortions created by Tim Sullivan are Copyright (C) 1999 Tim Sullivan.\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\nRalf Steinhaeusser [ralfiii att gmx dott net].\r\nGustavo Bianconi\r\nSteefan Lesage - converted to use new OTA\r\n\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n\r\n PluginManager loads Plugins\r\n\r\n changed 26.7.2001, by Ralf Steinhaeusser, Changes marked with !\r\n\r\n Events :\r\n When loading plugins (LoadPlugins) the events are called in the following order:\r\n FOnBeforeLoad(Sender, Name, CanLoad)\r\n Plugin -> Register\r\n Plugin.Initialize\r\n FOnNewCommand (times Nr. of commands)\r\n FOnAfterLoad\r\n\r\nVersionhistory:\r\n\r\n BaseVersion 5 :\r\n V 11 : When loading packages -> except instead of finally -> //!11\r\n New event : OnErrorLoading\r\n V 10 : Now handles custom Plugins (only their destructors are called when unloading)\r\n V 09 : Pluginmanager : Extension automatically follows plugintype\r\n First version to share with \"rest of the world\"\r\n V 08 : Problems with $ImplicitBuild\r\n V 07 : fixed file-creation bug: linebreaks were done with #10#13 instead of\r\n the other way round, what caused the IDE-navigation do show\r\n erroneous behaviour\r\n V 06 : fixed Memory leak when loading of not supported DLL's is skipped\r\n inserted credits to About-box\r\n V 05 : started adding Package-functionality\r\n PluginManager : Loined 2 TLists to one,\r\n Record with info on Plugins introduced\r\n fixed buggy Instance-count check\r\n Added PluginKind-Property\r\n changed : PluginName also contains path\r\n V 04 : cleaned Plugin-Manager :\r\n Removed OnBefore- and OnAfterLoading (REALLY unnecessary - OnBeforeLoad,\r\n and OnAfterLoad are still here !)\r\n Removed Trigger-routines. Were only called once -> moved into code\r\n V 03 : removed unecessary Set/Get-routines for most properties\r\n V 02 : new about-dialog, removed unnecessary CDK-auto-generated comments\r\n stupid fPluginHandles from TStringList -> TList\r\n V 01 : renamed objects, files, ressources\r\n fixed several Memory-leaks, fixed unload-bug, minimized uses-list\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvPluginManager.pas 13249 2012-02-27 15:47:36Z obones $\r\n\r\nunit JvPluginManager;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n {$IFDEF MSWINDOWS}\r\n Windows,\r\n {$ENDIF MSWINDOWS}\r\n Graphics, Forms,\r\n SysUtils, Classes,\r\n JvComponentBase, JvPlugin, JvJVCLUtils;\r\n\r\n{const\r\n C_VersionString = '5.10';}\r\n\r\ntype\r\n TNewCommandEvent = procedure(Sender: TObject; ACaption, AHint, AData: string;\r\n AShortCut: TShortCut; ABitmap: TJvBitmap;\r\n AEvent: TNotifyEvent) of object;\r\n\r\n TJvBeforeLoadEvent = procedure(Sender: TObject; FileName: string; var AllowLoad: Boolean) of object;\r\n TJvAfterLoadEvent = procedure(Sender: TObject; FileName: string;\r\n const ALibHandle: THandle; var AllowLoad: Boolean) of object;\r\n TJvBeforeUnloadEvent = procedure(Sender: TObject; FileName: string;\r\n const ALibHandle: THandle) of object;\r\n TJvAfterUnloadEvent = procedure(Sender: TObject; FileName: string) of object;\r\n TJvBeforeCommandsEvent = procedure(Sender: TObject; APlugIn: TJvPlugIn) of object;\r\n TJvAfterCommandsEvent = procedure(Sender: TObject; APlugIn: TJvPlugIn) of object;\r\n TJvPlgInErrorEvent = procedure(Sender: TObject; AError: Exception) of object;\r\n // End of Bianconi\r\n\r\n EJvPlugInError = class(Exception);\r\n EJvLoadPluginError = class(EJvPlugInError);\r\n // Bianconi\r\n EJvExtensionPlugInError = class(EJvPlugInError);\r\n EJvInitializationPlugInError = class(EJvPlugInError);\r\n EJvInitializationCustomPlugInError = class(EJvPlugInError);\r\n EJvCantRegisterPlugInError = class(EJvPlugInError);\r\n // End of Bianconi\r\n\r\n TPluginKind = (plgDLL, plgPackage, plgCustom);\r\n\r\n TPluginInfo = class(TObject)\r\n public\r\n PluginKind: TPluginKind;\r\n Handle: HINST;\r\n PlugIn: TJvPlugIn;\r\n end;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvPluginManager = class(TJvComponent)\r\n private\r\n FExtension: string;\r\n FPluginFolder: string;\r\n FPluginKind: TPluginKind;\r\n FPluginInfos: TList;\r\n FOnBeforeLoad: TJvBeforeLoadEvent;\r\n FOnAfterLoad: TJvAfterLoadEvent;\r\n FOnBeforeUnload: TJvBeforeUnloadEvent;\r\n FOnAfterUnload: TJvAfterUnloadEvent;\r\n FOnNewCommand: TNewCommandEvent;\r\n FPluginHostMessage: TPluginMessageObjEvent; // uses the the object version of TPluginMessageEvent\r\n FOnBeforeNewCommand: TJvBeforeCommandsEvent;\r\n FOnAfterNewCommand: TJvAfterCommandsEvent;\r\n FOnPlugInError: TJvPlgInErrorEvent;\r\n FShowLoadPluginErrors: Boolean;\r\n procedure SetPluginKind(const Value: TPluginKind);\r\n procedure UnloadLibrary(Kind: TPluginKind; LibHandle: Integer);\r\n protected\r\n procedure SetExtension(const NewValue: string);\r\n function GetPlugin(Index: Integer): TJvPlugIn;\r\n function GetPluginCount: Integer;\r\n function DoBeforeLoad(const FileName: string): Boolean; virtual;\r\n function DoAfterLoad(const FileName: string; LibHandle: THandle): Boolean; virtual;\r\n procedure ReBroadcastMessages(Sender: TObject; PluginMessage: Longint; PluginParams: string);\r\n procedure ReBroadcastMessagesObj(Sender: TObject; PluginMessage: Longint; PluginParams: string; AObj:TObject);\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n procedure LoadPlugin(FileName: string; PlgKind: TPluginKind);\r\n procedure LoadPlugins;\r\n procedure UnloadPlugin(Index: Integer);\r\n procedure GetLoadedPlugins(PlugInList: TStrings);\r\n property Plugins[Index: Integer]: TJvPlugIn read GetPlugin;\r\n property PluginCount: Integer read GetPluginCount;\r\n procedure SendMessage(PluginMessage: Longint; PluginParams: string); deprecated;\r\n procedure BroadcastMessage(PluginMessage: Longint; PluginParams: string);\r\n function AddCustomPlugin(PlugIn: TJvPlugIn; const FileName: string = ''): Boolean;\r\n published\r\n property PluginFolder: string read FPluginFolder write FPluginFolder;\r\n property Extension: string read FExtension write SetExtension;\r\n property PluginKind: TPluginKind read FPluginKind write SetPluginKind;\r\n property ShowLoadPluginErrors: Boolean read FShowLoadPluginErrors write FShowLoadPluginErrors default False;\r\n property OnBeforeLoad: TJvBeforeLoadEvent read FOnBeforeLoad write FOnBeforeLoad;\r\n property OnNewCommand: TNewCommandEvent read FOnNewCommand write FOnNewCommand;\r\n property OnAfterLoad: TJvAfterLoadEvent read FOnAfterLoad write FOnAfterLoad;\r\n property OnBeforeUnload: TJvBeforeUnloadEvent read FOnBeforeUnload write FOnBeforeUnload;\r\n property OnAfterUnload: TJvAfterUnloadEvent read FOnAfterUnload write FOnAfterUnload;\r\n property OnBeforeNewCommand: TJvBeforeCommandsEvent read FOnBeforeNewCommand write FOnBeforeNewCommand;\r\n property OnAfterNewCommand: TJvAfterCommandsEvent read FOnAfterNewCommand write FOnAfterNewCommand;\r\n property OnPlugInError: TJvPlgInErrorEvent read FOnPlugInError write FOnPlugInError;\r\n property OnPluginHostMessage: TPluginMessageObjEvent read FPluginHostMessage write FPluginHostMessage;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvPluginManager.pas $';\r\n Revision: '$Revision: 13249 $';\r\n Date: '$Date: 2012-02-27 16:47:36 +0100 (lun. 27 févr. 2012) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n JvResources;\r\n\r\nconst\r\n C_REGISTER_PLUGIN = 'RegisterPlugin';\r\n C_Extensions: array [plgDLL..plgCustom] of PChar = ('dll', 'bpl','xxx');\r\n\r\n\r\n// Originating from Host\r\nprocedure TJvPluginManager.BroadcastMessage(PluginMessage: Integer; \r\n PluginParams: string);\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := 0 to FPluginInfos.Count - 1 do\r\n Plugins[I].OnPluginMessage(Self, PluginMessage, PluginParams);\r\nend;\r\n\r\n\r\n// Originating from Plugins\r\nprocedure TJvPluginManager.ReBroadcastMessages(Sender: TObject; PluginMessage: Integer; PluginParams: string);\r\nvar\r\n I: Integer;\r\nbegin\r\n // First trigger Host message event\r\n if Assigned(FPluginHostMessage) then\r\n FPluginHostMessage(Self, PluginMessage, PluginParams, Nil);\r\n\r\n // Cant call orginal BroadcastMessage becasue we need to test for origonating sender plugin.\r\n // Host never recieves messages it sends because bit of code above is missing in origonal BroadcastMessage.\r\n\r\n // Next rebroadcast message to loaded plugins skipping plugin that sent message.\r\n for I := 0 to FPluginInfos.Count - 1 do\r\n begin\r\n If (Plugins[I]<>Sender) then\r\n Plugins[I].OnPluginMessage(Sender,PluginMessage,PluginParams);\r\n end;\r\nend;\r\n\r\n// Originating from Plugins with object (overloaded above version)\r\nprocedure TJvPluginManager.ReBroadcastMessagesObj(Sender: TObject; PluginMessage: Integer; PluginParams: string; AObj: TObject);\r\nvar\r\n I: Integer;\r\nbegin\r\n // First trigger Host message event\r\n if Assigned(FPluginHostMessage) then\r\n FPluginHostMessage(Self, PluginMessage, PluginParams, AObj);\r\n\r\n // Cant call orginal BroadcastMessage becasue we need to test for origonating sender plugin.\r\n // Host never recieves messages it sends because bit of code above is missing in origonal BroadcastMessage.\r\n\r\n // Next rebroadcast message to loaded plugins skipping plugin that sent message.\r\n for I := 0 to FPluginInfos.Count - 1 do\r\n begin\r\n If (Plugins[I]<>Sender) then\r\n Plugins[I].OnPluginMessageWithObj(Sender,PluginMessage,PluginParams,AObj);\r\n end;\r\nend;\r\n\r\nconstructor TJvPluginManager.Create(AOwner: TComponent);\r\nbegin\r\n try\r\n inherited Create(AOwner);\r\n FPluginInfos := TList.Create;\r\n FPluginKind := plgDLL;\r\n FExtension := C_Extensions[FPluginKind];\r\n except\r\n on E: Exception do\r\n begin\r\n if not (csDesigning in ComponentState) and Assigned(FOnPlugInError) then\r\n FOnPlugInError(Self, E)\r\n else\r\n raise;\r\n end;\r\n end;\r\nend;\r\n\r\ndestructor TJvPluginManager.Destroy;\r\nbegin\r\n // Free the loaded plugins\r\n while FPluginInfos.Count > 0 do\r\n UnloadPlugin(0);\r\n FPluginInfos.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJvPluginManager.DoAfterLoad(const FileName: string; LibHandle: THandle): Boolean;\r\nbegin\r\n Result := True;\r\n if Assigned(FOnAfterLoad) then\r\n FOnAfterLoad(Self, FileName, LibHandle, Result);\r\nend;\r\n\r\nfunction TJvPluginManager.DoBeforeLoad(const FileName: string): Boolean;\r\nbegin\r\n Result := True;\r\n if Assigned(FOnBeforeLoad) then\r\n FOnBeforeLoad(Self, FileName, Result);\r\nend;\r\n\r\nprocedure TJvPluginManager.SetExtension(const NewValue: string);\r\nbegin\r\n try\r\n if FExtension <> NewValue then\r\n begin\r\n // (rb) No reason to block this\r\n if {(Length(NewValue) > 3) or} Length(NewValue) < 1 then\r\n raise EJvPlugInError.CreateRes(@RsEErrEmptyExt)\r\n else\r\n FExtension := NewValue;\r\n end;\r\n except\r\n on E: Exception do\r\n begin\r\n if not (csDesigning in ComponentState) and Assigned(FOnPlugInError) then\r\n FOnPlugInError(Self, E)\r\n else\r\n raise;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvPluginManager.SetPluginKind(const Value: TPluginKind);\r\nbegin\r\n if FPluginKind <> Value then\r\n begin\r\n if FExtension = C_Extensions[FPluginKind] then\r\n FExtension := C_Extensions[Value];\r\n FPluginKind := Value;\r\n end;\r\nend;\r\n\r\nfunction TJvPluginManager.GetPluginCount: Integer;\r\nbegin\r\n Result := FPluginInfos.Count;\r\nend;\r\n\r\nfunction TJvPluginManager.GetPlugin(Index: Integer): TJvPlugIn;\r\nvar\r\n PlgI: TPluginInfo;\r\nbegin\r\n PlgI := FPluginInfos.Items[Index];\r\n Result := PlgI.PlugIn;\r\nend;\r\n\r\nprocedure TJvPluginManager.GetLoadedPlugins(PlugInList: TStrings);\r\nvar\r\n I: Integer;\r\nbegin\r\n PlugInList.BeginUpdate;\r\n try\r\n PlugInList.Clear;\r\n for I := 0 to FPluginInfos.Count - 1 do\r\n PlugInList.Add(Plugins[I].Name);\r\n finally\r\n PlugInList.EndUpdate;\r\n end;\r\nend;\r\n\r\n// Create and add plugin - if error occurs, the Plugin is not added to list\r\n\r\nfunction TJvPluginManager.AddCustomPlugin(PlugIn: TJvPlugIn; const FileName: string = ''): Boolean;\r\nvar\r\n PlgInfo: TPluginInfo;\r\n Counter: Integer;\r\nbegin\r\n Result := False;\r\n try\r\n if Length(FileName) = 0 then\r\n Result := PlugIn.Initialize(Self, Application, 'CustomPlugin')\r\n else\r\n Result := PlugIn.Initialize(Self, Application, FileName);\r\n\r\n if not Result then\r\n Exit;\r\n\r\n PlgInfo := TPluginInfo.Create;\r\n PlgInfo.PluginKind := plgCustom;\r\n PlgInfo.PlugIn := PlugIn;\r\n\r\n FPluginInfos.Add(PlgInfo);\r\n\r\n try\r\n if Assigned(FOnBeforeNewCommand) then\r\n FOnBeforeNewCommand(Self, PlugIn);\r\n\r\n // Events for all new commands\r\n if Assigned(FOnNewCommand) then\r\n for Counter := 0 to PlugIn.Commands.Count - 1 do\r\n with TJvPluginCommand(PlugIn.Commands.Items[Counter]) do\r\n FOnNewCommand(Self, Caption, Hint, Data, ShortCut, TJvBitmap(Bitmap), OnExecute);\r\n finally\r\n if Assigned(FOnAfterNewCommand) then\r\n FOnAfterNewCommand(Self, PlugIn);\r\n end;\r\n except\r\n on E: Exception do\r\n begin\r\n if not (csDesigning in ComponentState) and Assigned(FOnPlugInError) then\r\n FOnPlugInError(Self, E)\r\n else\r\n raise;\r\n end;\r\n end;\r\nend;\r\n\r\n// Load a Plugin - either DLL or package\r\n\r\nprocedure TJvPluginManager.LoadPlugin(FileName: string; PlgKind: TPluginKind);\r\ntype\r\n TSxRegisterPlugin = function: TJvPlugIn; stdcall;\r\nvar\r\n Counter: Integer;\r\n LibHandle: Integer;\r\n RegisterProc: TSxRegisterPlugin;\r\n PlugIn: TJvPlugIn;\r\n NumCopies: Integer;\r\n PlgInfo: TPluginInfo;\r\nbegin\r\n if DoBeforeLoad(FileName) then\r\n begin\r\n LibHandle := 0;\r\n PlgInfo := nil;\r\n PlugIn := nil;\r\n try\r\n case PlgKind of\r\n plgDLL:\r\n LibHandle := SafeLoadLibrary(FileName);\r\n plgPackage:\r\n LibHandle := LoadPackage(FileName);\r\n end;\r\n\r\n if LibHandle = 0 then\r\n raise EJvLoadPluginError.CreateResFmt(@RsEPluginPackageNotFound, [FileName]);\r\n\r\n // Load the registration procedure\r\n RegisterProc := GetProcAddress(LibHandle, C_REGISTER_PLUGIN);\r\n if not Assigned(RegisterProc) then\r\n raise EJvLoadPluginError.CreateResFmt(@RsERegisterPluginNotFound, [C_REGISTER_PLUGIN, FileName]);\r\n\r\n // register the plugin\r\n PlugIn := RegisterProc;\r\n if PlugIn = nil then\r\n raise EJvCantRegisterPlugInError.CreateResFmt(@RsERegisterPluginFailed, [C_REGISTER_PLUGIN, FileName]);\r\n\r\n // make sure we don't load more copies of the plugin than allowed\r\n if PlugIn.InstanceCount > 0 then // 0 = unlimited\r\n begin\r\n NumCopies := 0;\r\n for Counter := 0 to FPluginInfos.Count - 1 do\r\n if Plugins[Counter].PluginID = PlugIn.PluginID then\r\n Inc(NumCopies);\r\n\r\n if NumCopies >= PlugIn.InstanceCount then\r\n begin\r\n PlugIn.Free;\r\n Exit; // Todo : Don't know what Skipload does here\r\n end;\r\n end; // if Plugin.InstanceCount > 0\r\n\r\n // initialize the plugin and add to list\r\n if AddCustomPlugin(PlugIn, FileName) then\r\n begin\r\n PlgInfo := FPluginInfos.Last;\r\n PlgInfo.PluginKind := PlgKind;\r\n PlgInfo.Handle := LibHandle;\r\n // Assign (hook) our new Host's plugin compatible broadcasting method to our newly loaded plugin 's broadcast event.\r\n PlgInfo.PlugIn.OnPluginBroadcast :=ReBroadcastMessages;\r\n PlgInfo.PlugIn.OnPluginBroadcastObj:=ReBroadcastMessagesObj;\r\n end;\r\n\r\n if not DoAfterLoad(FileName, LibHandle) then\r\n UnloadPlugin(FPluginInfos.IndexOf(PlgInfo));\r\n except\r\n //!11 if - for whatever reason - an exception has occurred\r\n // free Plugin and library\r\n // (rom) statements used twice could be wrapped in method\r\n on E: Exception do\r\n begin\r\n if PlgInfo <> nil then\r\n UnloadPlugin(FPluginInfos.IndexOf(PlgInfo))\r\n else\r\n begin\r\n FreeAndNil(PlugIn);\r\n if LibHandle <> 0 then\r\n UnloadLibrary(PlgKind, LibHandle);\r\n end;\r\n if not (csDesigning in ComponentState) and Assigned(FOnPlugInError) then\r\n FOnPlugInError(Self, E)\r\n else\r\n raise;\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\n// Load all plugins in the plugin-folder\r\n// exceptions can only be seen through the OnErrorLoading-Event\r\n\r\nprocedure TJvPluginManager.LoadPlugins;\r\nvar\r\n FileName: string;\r\n Found: Integer;\r\n Path: string;\r\n Sr: TSearchRec;\r\nbegin\r\n // if the PluginPath is blank, we load from the app's folder.\r\n if FPluginFolder = '' then\r\n Path := ExtractFilePath(Application.ExeName)\r\n else\r\n Path := FPluginFolder;\r\n Path := IncludeTrailingPathDelimiter(Path);\r\n\r\n Found := FindFirst(Path + '*.' + FExtension, 0, Sr);\r\n try\r\n while Found = 0 do\r\n begin\r\n FileName := Sr.Name;\r\n //! If one plugin made problems -> no other plugins where loaded\r\n //! To avoid that the try-except block was wrapped around here...\r\n try\r\n LoadPlugin(Path + FileName, PluginKind);\r\n except\r\n // OnPluginError is already triggered in LoadPlugin if available\r\n {if not (csDesigning in ComponentState) and Assigned(FOnPlugInError) then\r\n FOnPlugInError(Self, E)\r\n else}\r\n if ShowLoadPluginErrors then\r\n Application.HandleException(Self);\r\n end;\r\n Found := FindNext(Sr);\r\n end;\r\n finally\r\n FindClose(Sr);\r\n end;\r\nend;\r\n\r\nprocedure TJvPluginManager.UnloadPlugin(Index: Integer);\r\nvar\r\n PlgI: TPluginInfo;\r\n name: string;\r\nbegin\r\n PlgI := FPluginInfos.Items[Index];\r\n name := PlgI.PlugIn.FileName;\r\n if assigned(FOnBeforeUnload) then\r\n FOnBeforeUnload(self, name, PlgI.Handle);\r\n PlgI.PlugIn.Free;\r\n UnloadLibrary(PlgI.PluginKind, PlgI.Handle);\r\n PlgI.Free;\r\n FPluginInfos.Delete(Index);\r\n if assigned(FOnAfterUnload) then\r\n FOnAfterUnload(self, name);\r\nend;\r\n\r\n{$WARN SYMBOL_DEPRECATED OFF}\r\nprocedure TJvPluginManager.SendMessage(PluginMessage: Longint; PluginParams: string);\r\nbegin\r\n BroadcastMessage(PluginMessage, PluginParams);\r\nend;\r\n{$WARN SYMBOL_DEPRECATED ON}\r\n\r\nprocedure TJvPluginManager.UnloadLibrary(Kind: TPluginKind; LibHandle: Integer);\r\nbegin\r\n case Kind of\r\n plgDLL:\r\n FreeLibrary(LibHandle);\r\n plgPackage:\r\n UnloadPackage(LibHandle);\r\n end;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvPoweredBy.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvLED.pas, released on 2005-03-30.\r\n\r\nThe Initial Developer of the Original Code is Robert Marquardt (robert_marquardt att gmx dott de)\r\nPortions created by Robert Marquardt are Copyright (C) 2005 Robert Marquardt.\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\n- Marc Geldon\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvPoweredBy.pas 13104 2011-09-07 06:50:43Z obones $\r\n\r\nunit JvPoweredBy;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, Classes, Graphics, Controls,\r\n JvComponent;\r\n\r\ntype\r\n TJvPoweredBy = class(TJvGraphicControl)\r\n private\r\n FResourceName: string;\r\n FImage: TBitmap;\r\n FURLActive: Boolean;\r\n FURL: string;\r\n procedure SetURL(const Value: string);\r\n procedure SetURLActive(const Value: Boolean);\r\n protected\r\n procedure Paint; override;\r\n procedure Click; override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n procedure SetBounds(ALeft, ATop, AWidth, AHeight: Integer); override;\r\n property URLActive: Boolean read FURLActive write SetURLActive stored True default True;\r\n property URL: string read FURL write SetURL stored True;\r\n property Image: TBitmap read FImage;\r\n end;\r\n\r\n // In a sense this component is silly :-). By using it the JVCL gets used.\r\n // Therefore it gets an exception from the MPL rule of mentioning the JVCL if using a JVCL component.\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64 or pidOSX32)]\r\n {$ENDIF RTL230_UP}\r\n TJvPoweredByJCL = class(TJvPoweredBy)\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n published\r\n property Align;\r\n property Anchors;\r\n property AutoSize;\r\n property DragCursor;\r\n property DragKind;\r\n property OnEndDock;\r\n property OnStartDock;\r\n property Constraints;\r\n property Cursor default crHandPoint;\r\n property DragMode;\r\n property Height default 31;\r\n property ParentShowHint;\r\n property PopupMenu;\r\n property ShowHint;\r\n property Visible;\r\n property Width default 195;\r\n property URLActive;\r\n property URL;\r\n property OnClick;\r\n property OnContextPopup;\r\n property OnDblClick;\r\n property OnDragDrop;\r\n property OnDragOver;\r\n property OnEndDrag;\r\n property OnMouseDown;\r\n property OnMouseMove;\r\n property OnMouseUp;\r\n property OnStartDrag;\r\n end;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64 or pidOSX32)]\r\n {$ENDIF RTL230_UP}\r\n TJvPoweredByJVCL = class(TJvPoweredBy)\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n published\r\n property Align;\r\n property Anchors;\r\n property AutoSize;\r\n property DragCursor;\r\n property DragKind;\r\n property OnEndDock;\r\n property OnStartDock;\r\n property Constraints;\r\n property Cursor default crHandPoint;\r\n property DragMode;\r\n property Height default 31;\r\n property ParentShowHint;\r\n property PopupMenu;\r\n property ShowHint;\r\n property URLActive;\r\n property URL;\r\n property Visible;\r\n property Width default 209;\r\n property OnClick;\r\n property OnContextPopup;\r\n property OnDblClick;\r\n property OnDragDrop;\r\n property OnDragOver;\r\n property OnEndDrag;\r\n property OnMouseDown;\r\n property OnMouseMove;\r\n property OnMouseUp;\r\n property OnStartDrag;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvPoweredBy.pas $';\r\n Revision: '$Revision: 13104 $';\r\n Date: '$Date: 2011-09-07 08:50:43 +0200 (mer. 07 sept. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n JvJCLUtils, JvResources;\r\n\r\n{$R JvPoweredBy.res}\r\n\r\nconst\r\n cPoweredByJCL = 'JvPoweredByJCL';\r\n cPoweredByJVCL = 'JvPoweredByJVCL';\r\n\r\n//=== { TJvPoweredBy } =======================================================\r\n\r\nconstructor TJvPoweredBy.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n Cursor := crHandPoint;\r\n FImage := TBitmap.Create;\r\n FImage.LoadFromResourceName(HInstance, FResourceName);\r\n Width := FImage.Width;\r\n Height := FImage.Height;\r\nend;\r\n\r\ndestructor TJvPoweredBy.Destroy;\r\nbegin\r\n FImage.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvPoweredBy.SetURL(const Value: string);\r\nbegin\r\n if Value <> FURL then\r\n begin\r\n FURL := Value;\r\n if FURL = '' then\r\n begin\r\n FURLActive := False;\r\n Cursor := crDefault;\r\n end\r\n else\r\n begin\r\n FURLActive := True;\r\n Cursor := crHandPoint;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvPoweredBy.SetURLActive(const Value: Boolean);\r\nbegin\r\n if Value <> FURLActive then\r\n begin\r\n if Value then\r\n begin\r\n FURLActive := True;\r\n Cursor := crHandPoint;\r\n end\r\n else\r\n begin\r\n FURLActive := False;\r\n Cursor := crDefault;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvPoweredBy.Paint;\r\nvar\r\n DestRect, SrcRect: TRect;\r\nbegin\r\n if csDesigning in ComponentState then\r\n begin\r\n Canvas.Pen.Style := psDash;\r\n Canvas.Brush.Style := bsClear;\r\n Canvas.Rectangle(ClientRect);\r\n end;\r\n SrcRect := Rect(0, 0, FImage.Width, FImage.Height);\r\n DestRect := SrcRect;\r\n OffsetRect(DestRect, (ClientWidth - FImage.Width) div 2, (ClientHeight - FImage.Height) div 2);\r\n with Canvas do\r\n begin\r\n CopyMode := cmSrcCopy;\r\n CopyRect( DestRect, FImage.Canvas, SrcRect);\r\n end;\r\nend;\r\n\r\nprocedure TJvPoweredBy.Click;\r\nbegin\r\n if not Assigned(OnClick) and (URL <> '') and (URLActive) then\r\n OpenObject(URL)\r\n else\r\n inherited Click;\r\nend;\r\n\r\nprocedure TJvPoweredBy.SetBounds(ALeft, ATop, AWidth, AHeight: Integer);\r\nbegin\r\n if AutoSize and (Align in [alNone, alCustom]) then\r\n inherited SetBounds(ALeft, ATop, FImage.Width, FImage.Height)\r\n else\r\n inherited SetBounds(ALeft, ATop, AWidth, AHeight);\r\nend;\r\n\r\n\r\n\r\n//=== { TJvPoweredByJCL } ====================================================\r\n\r\nconstructor TJvPoweredByJCL.Create(AOwner: TComponent);\r\nbegin\r\n FResourceName := cPoweredByJCL;\r\n // simple trick with inherited\r\n inherited Create(AOwner);\r\n FURLActive := True;\r\n FURL := RsURLPoweredByJCL;\r\nend;\r\n\r\n//=== { TJvPoweredByJVCL } ===================================================\r\n\r\nconstructor TJvPoweredByJVCL.Create(AOwner: TComponent);\r\nbegin\r\n FResourceName := cPoweredByJVCL;\r\n inherited Create(AOwner);\r\n FURLActive := True;\r\n FURL := RsURLPoweredByJVCL;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvPrint.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvPrint.PAS, released on 2001-02-28.\r\n\r\nThe Initial Developer of the Original Code is Sbastien Buysse [sbuysse att buypin dott com]\r\nPortions created by Sbastien Buysse are Copyright (C) 2001 Sbastien Buysse.\r\nAll Rights Reserved.\r\n\r\nContributor(s): Michael Beck [mbeck att bigfoot dott com].\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvPrint.pas 13104 2011-09-07 06:50:43Z obones $\r\n\r\nunit JvPrint;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, SysUtils, Classes, Graphics, Printers,\r\n JvTypes, JvComponentBase;\r\n\r\ntype\r\n TJvPrintMeasureItemEvent = procedure(Sender: TObject; ACanvas: TCanvas;\r\n AIndex: Integer; const AItem: string; var AHeight:Integer) of object;\r\n TJvPrintDrawItemEvent = procedure(Sender: TObject; ACanvas: TCanvas;\r\n ARect: TRect; AIndex: Integer; const AItem: string) of object;\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64 or pidOSX32)]\r\n {$ENDIF RTL230_UP}\r\n TJvPrint = class(TJvComponent)\r\n private\r\n FOnBeginPrint: TNotifyEvent;\r\n FOnFinishedPrint: TNotifyEvent;\r\n FOnProgress: TJvProgressEvent;\r\n FOnNextPage: TJvNextPageEvent;\r\n FOwnerDraw: Boolean;\r\n FOnMeasureItem: TJvPrintMeasureItemEvent;\r\n FOnDrawItem: TJvPrintDrawItemEvent;\r\n protected\r\n function MeasureItem(ACanvas: TCanvas; AIndex: Integer; AItem: string): Integer; virtual;\r\n procedure DrawItem(ACanvas: TCanvas; ARect: TRect; AIndex: Integer; const AItem: string); virtual;\r\n public\r\n function GetScaleX:Integer;\r\n function GetScaleY: Integer;\r\n published\r\n procedure Print(Value: TStringList);\r\n procedure PrintHTML(Value: TStrings);\r\n procedure PrintImage(Value: TBitmap; Style: TJvBitmapStyle);\r\n procedure Abort;\r\n property OwnerDraw: Boolean read FOwnerDraw write FOwnerDraw default False;\r\n property OnBeginPrint: TNotifyEvent read FOnBeginPrint write FOnBeginPrint;\r\n property OnFinishedPrint: TNotifyEvent read FOnFinishedPrint write FOnFinishedPrint;\r\n property OnProgress: TJvProgressEvent read FOnProgress write FOnProgress;\r\n property OnNextPage: TJvNextPageEvent read FOnNextPage write FOnNextPage;\r\n property OnMeasureItem: TJvPrintMeasureItemEvent read FOnMeasureItem write FOnMeasureItem;\r\n property OnDrawItem: TJvPrintDrawItemEvent read FOnDrawItem write FOnDrawItem;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvPrint.pas $';\r\n Revision: '$Revision: 13104 $';\r\n Date: '$Date: 2011-09-07 08:50:43 +0200 (mer. 07 sept. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n JvJCLUtils, JvJVCLUtils;\r\n\r\nprocedure TJvPrint.Abort;\r\nbegin\r\n Printer.Abort;\r\nend;\r\n\r\nprocedure TJvPrint.Print(Value: TStringList);\r\nvar\r\n I, LineTop, LineHeight, PageNum: Integer;\r\n ARect: TRect;\r\nbegin\r\n //let's print\r\n if Assigned(FOnBeginPrint) then\r\n FOnBeginPrint(Self);\r\n LineTop := 0;\r\n Printer.BeginDoc;\r\n PageNum := 1;\r\n for I := 0 to Value.Count - 1 do\r\n begin\r\n if Assigned(FOnProgress) then\r\n FOnProgress(Self, I + 1, Value.Count);\r\n LineHeight := MeasureItem(Printer.Canvas, I, Value[I]);\r\n // JvHtControls:\r\n // AHeight := ItemHTHeight(ACanvas, AItem, GetScaleX)+1;\r\n if LineTop + LineHeight > Printer.PageHeight then\r\n begin\r\n LineTop := 0;\r\n Printer.NewPage;\r\n Inc(PageNum);\r\n if Assigned(FOnNextPage) then\r\n FOnNextPage(Self, PageNum);\r\n end;\r\n ARect := Rect(0, LineTop, Printer.PageWidth, LineTop + LineHeight);\r\n DrawItem(Printer.Canvas, ARect, I, Value[I]);\r\n LineTop := LineTop + LineHeight;\r\n // JvHTControls:\r\n // ARect.Bottom := ARect.Bottom - ARect.Top;\r\n // ItemHTDraw(ACanvas,ARect,[odReserved1],AItem, GetScaleX);\r\n end;\r\n Printer.EndDoc;\r\n if Assigned(FOnFinishedPrint) then\r\n FOnFinishedPrint(Self);\r\nend;\r\n\r\nprocedure TJvPrint.PrintHTML(Value: TStrings);\r\nvar\r\n I, Line, PageNum: Integer;\r\n LHeight: Integer;\r\n LRect: TRect;\r\n LPixels: Integer;\r\nbegin\r\n //let's print\r\n if Assigned(FOnBeginPrint) then\r\n FOnBeginPrint(Self);\r\n Line := 0;\r\n Printer.BeginDoc;\r\n PageNum := 1;\r\n LPixels := GetScaleX;\r\n for I := 0 to Value.Count - 1 do\r\n begin\r\n if Assigned(FOnProgress) then\r\n FOnProgress(Self, I + 1, Value.Count);\r\n LHeight := HTMLTextHeight(Printer.Canvas, Value[I], LPixels) + 1;\r\n\r\n if Line + LHeight > Printer.PageHeight then\r\n begin\r\n Line := 0;\r\n Printer.NewPage;\r\n Inc(PageNum);\r\n if Assigned(FOnNextPage) then\r\n FOnNextPage(Self, PageNum);\r\n end;\r\n LRect := Rect(0,Line, Printer.PageWidth , LHeight);\r\n HTMLDrawText(Printer.Canvas,LRect,[odReserved1], Value[I], LPixels);\r\n Line := Line + LHeight;\r\n end;\r\n Printer.EndDoc;\r\n if Assigned(FOnFinishedPrint) then\r\n FOnFinishedPrint(Self);\r\nend;\r\n\r\nprocedure TJvPrint.PrintImage(Value: TBitmap; Style: TJvBitmapStyle);\r\nbegin\r\n //let's print too :)\r\n if Assigned(FOnBeginPrint) then\r\n FOnBeginPrint(Self);\r\n case Style of\r\n bsNormal:\r\n with Printer do\r\n begin\r\n BeginDoc;\r\n Canvas.Draw(0, 0, Value);\r\n EndDoc;\r\n end;\r\n bsCentered:\r\n with Printer do\r\n begin\r\n BeginDoc;\r\n Canvas.Draw((PageWidth - Value.Width) div 2, (PageHeight - Value.Height) div 2, Value);\r\n EndDoc;\r\n end;\r\n bsStretched:\r\n with Printer do\r\n begin\r\n BeginDoc;\r\n CopyRectDIBits(Canvas, Rect(0, 0, PageWidth, PageHeight),\r\n Value, Rect(0, 0, Value.Width, Value.Height));\r\n EndDoc;\r\n end;\r\n end;\r\n if Assigned(FOnFinishedPrint) then\r\n FOnFinishedPrint(Self);\r\nend;\r\n\r\nfunction TJvPrint.GetScaleX: Integer;\r\nbegin\r\n Result := GetDeviceCaps(Printer.Handle, LogPixelsX);\r\nend;\r\n\r\nfunction TJvPrint.GetScaleY: Integer;\r\nbegin\r\n Result := GetDeviceCaps(Printer.Handle, LogPixelsY);\r\nend;\r\n\r\nfunction TJvPrint.MeasureItem(ACanvas: TCanvas; AIndex: Integer;\r\n AItem: string): Integer;\r\nbegin\r\n if OwnerDraw and Assigned(FOnMeasureItem) then\r\n FOnMeasureItem(Self, ACanvas, AIndex, AItem, Result)\r\n else\r\n Result := ACanvas.TextHeight(AItem);\r\nend;\r\n\r\nprocedure TJvPrint.DrawItem(ACanvas: TCanvas; ARect: TRect;\r\n AIndex: Integer; const AItem: string);\r\nbegin\r\n if OwnerDraw and Assigned(FOnDrawItem) then\r\n FOnDrawItem(Self, ACanvas, ARect, AIndex, AItem)\r\n else\r\n ACanvas.TextOut(ARect.Left, ARect.Top, AItem);\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvProfilerForm.dfm", "content": "object ProfReport: TProfReport\r\n Left = 200\r\n Top = 114\r\n ActiveControl = lvReport\r\n BorderIcons = [biSystemMenu]\r\n Caption = 'Profiler Report'\r\n ClientHeight = 264\r\n ClientWidth = 445\r\n Color = clBtnFace\r\n Font.Charset = DEFAULT_CHARSET\r\n Font.Color = clBlack\r\n Font.Height = -11\r\n Font.Name = 'MS Sans Serif'\r\n Font.Style = []\r\n Icon.Data = {\r\n 0000010001002020040000000000E80200001600000028000000200000004000\r\n 0000010004000000000000020000000000000000000000000000000000000000\r\n 000000008000008000000080800080000000800080008080000080808000C0C0\r\n C0000000FF0000FF000000FFFF00FF000000FF00FF00FFFF0000FFFFFF000000\r\n 0777777777777777777777777700000077777777777777777777777777700030\r\n 000000000000000000000007777703BBBBBBBBBBBBBBBBBBBBBBBB8077773BBB\r\n BBBBBBBBBBBBBBBBBBBBBBB807773BBBBBBBBBBBBBBBBBBBBBBBBBBB07773BBB\r\n BBBBBBBBB8008BBBBBBBBBBB07703BBBBBBBBBBBB0000BBBBBBBBBB8077003BB\r\n BBBBBBBBB0000BBBBBBBBBB0770003BBBBBBBBBBB8008BBBBBBBBB807700003B\r\n BBBBBBBBBBBBBBBBBBBBBB077000003BBBBBBBBBBB0BBBBBBBBBB80770000003\r\n BBBBBBBBB808BBBBBBBBB07700000003BBBBBBBBB303BBBBBBBB807700000000\r\n 3BBBBBBBB000BBBBBBBB0770000000003BBBBBBB80008BBBBBB8077000000000\r\n 03BBBBBB30003BBBBBB077000000000003BBBBBB00000BBBBB80770000000000\r\n 003BBBBB00000BBBBB07700000000000003BBBBB00000BBBB807700000000000\r\n 0003BBBB00000BBBB0770000000000000003BBBB00000BBB8077000000000000\r\n 00003BBB80008BBB077000000000000000003BBBBBBBBBB80770000000000000\r\n 000003BBBBBBBBB07700000000000000000003BBBBBBBB807700000000000000\r\n 0000003BBBBBBB0770000000000000000000003BBBBBB8077000000000000000\r\n 00000003BBBBB077000000000000000000000003BBBB80700000000000000000\r\n 000000003BB8000000000000000000000000000003330000000000000000F800\r\n 0003F0000001C000000080000000000000000000000000000001000000018000\r\n 000380000003C0000007C0000007E000000FE000000FF000001FF000001FF800\r\n 003FF800003FFC00007FFC00007FFE0000FFFE0000FFFF0001FFFF0001FFFF80\r\n 03FFFF8003FFFFC007FFFFC007FFFFE00FFFFFE01FFFFFF07FFFFFF8FFFF}\r\n OldCreateOrder = True\r\n Position = poScreenCenter\r\n ShowHint = True\r\n OnShow = FormShow\r\n PixelsPerInch = 96\r\n TextHeight = 13\r\n object Panel1: TPanel\r\n Left = 0\r\n Top = 231\r\n Width = 445\r\n Height = 33\r\n Align = alBottom\r\n BevelOuter = bvNone\r\n TabOrder = 0\r\n ExplicitTop = 233\r\n DesignSize = (\r\n 445\r\n 33)\r\n object SaveBtn: TButton\r\n Left = 8\r\n Top = 5\r\n Width = 75\r\n Height = 25\r\n Hint = 'Save report to a file (compatible with Excel)'\r\n Anchors = [akLeft, akBottom]\r\n Caption = '&Save...'\r\n TabOrder = 0\r\n OnClick = SaveBtnClick\r\n end\r\n object Panel2: TPanel\r\n Left = 270\r\n Top = 0\r\n Width = 175\r\n Height = 33\r\n Align = alRight\r\n BevelOuter = bvNone\r\n TabOrder = 1\r\n DesignSize = (\r\n 175\r\n 33)\r\n object OKBtn: TButton\r\n Left = 60\r\n Top = 6\r\n Width = 75\r\n Height = 25\r\n Hint = 'Close report window'\r\n Anchors = [akRight, akBottom]\r\n Cancel = True\r\n Caption = '&Close'\r\n Default = True\r\n ModalResult = 1\r\n TabOrder = 0\r\n OnClick = OKBtnClick\r\n end\r\n end\r\n object TrimBtn: TButton\r\n Left = 96\r\n Top = 5\r\n Width = 75\r\n Height = 25\r\n Hint = 'Remove unused calls from the list'\r\n Anchors = [akLeft, akBottom]\r\n Caption = '&Trim'\r\n TabOrder = 2\r\n OnClick = TrimBtnClick\r\n end\r\n end\r\n object lvReport: TListView\r\n Left = 0\r\n Top = 0\r\n Width = 445\r\n Height = 231\r\n Hint = 'Click the top column to sort the items'\r\n Align = alClient\r\n BorderStyle = bsNone\r\n Columns = <\r\n item\r\n Caption = 'Function / Procedure '\r\n Width = 160\r\n end\r\n item\r\n Alignment = taRightJustify\r\n Caption = 'Total time (ms)'\r\n Width = 80\r\n end\r\n item\r\n Alignment = taRightJustify\r\n Caption = 'Calls'\r\n Width = 35\r\n end\r\n item\r\n Alignment = taRightJustify\r\n Caption = 'Average time (ms)'\r\n Width = 100\r\n end\r\n item\r\n Alignment = taRightJustify\r\n Caption = 'Percent (%)'\r\n Width = 70\r\n end>\r\n GridLines = True\r\n MultiSelect = True\r\n RowSelect = True\r\n TabOrder = 1\r\n ViewStyle = vsReport\r\n OnColumnClick = lvReportColumnClick\r\n ExplicitHeight = 233\r\n end\r\nend\r\n" }, { "path": "External/Jedi/Jvcl/run/JvProfilerForm.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvProfilerForm.PAS, released on 2002-05-26.\r\n\r\nThe Initial Developer of the Original Code is Certified Software Corp. [certsoft att quest-net dott com]\r\nPortions created by Peter Thrnqvist are Copyright (C) 1996 Certified Software Corp.\r\nAll Rights Reserved.\r\n\r\nContributor(s): Peter Thrnqvist [peter3 at sourceforge dot net]\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n Use QueryPerformanceCounter / Frequency instead of GetTickCount (the high resolution timer)\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvProfilerForm.pas 13104 2011-09-07 06:50:43Z obones $\r\n\r\nunit JvProfilerForm;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Classes, Windows, Dialogs, ComCtrls, StdCtrls, Controls, ExtCtrls, Forms,\r\n JvComponentBase, JvComponent;\r\n\r\nconst\r\n MaxProfEntries = 1024; { maximum number of \"blocks\" to profile }\r\n MaxStackSize = 1024; { maximum nesting of blocks at any one time }\r\n\r\nvar\r\n OddClick: Boolean = True;\r\n\r\ntype\r\n TJvProfileInfo = array [0..MaxProfEntries - 1] of record\r\n InOutTime: Longint;\r\n TimeSpent: Longint;\r\n Calls: Longint;\r\n StringID: string;\r\n end;\r\n\r\n TProcStack = array [1..MaxStackSize] of record\r\n CallerID: Integer;\r\n EntryTime: Longint;\r\n end;\r\n\r\n TProfReport = class(TJvForm)\r\n Panel1: TPanel;\r\n SaveBtn: TButton;\r\n lvReport: TListView;\r\n Panel2: TPanel;\r\n OKBtn: TButton;\r\n TrimBtn: TButton;\r\n procedure FormShow(Sender: TObject);\r\n procedure lvReportColumnClick(Sender: TObject; Column: TListColumn);\r\n procedure SaveBtnClick(Sender: TObject);\r\n procedure OKBtnClick(Sender: TObject);\r\n procedure TrimBtnClick(Sender: TObject);\r\n public\r\n StartTime: Integer;\r\n EndTime: Integer;\r\n LastProc: Integer;\r\n ProfileInfo: TJvProfileInfo;\r\n end;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64 or pidOSX32)]\r\n {$ENDIF RTL230_UP}\r\n TJvProfiler = class(TJvComponent)\r\n private\r\n FProfileInfo: TJvProfileInfo;\r\n FNames: TStringList;\r\n FStack: TProcStack;\r\n FStartTime: Longint;\r\n FEndTime: Longint;\r\n FLastProc: Integer;\r\n FStackSize: Integer;\r\n FEnabled: Boolean;\r\n FStarted: Boolean;\r\n FSorted: Boolean;\r\n FOnStart: TNotifyEvent;\r\n FOnStop: TNotifyEvent;\r\n function GetNames: TStrings;\r\n procedure SetNames(Value: TStrings);\r\n procedure SetEnabled(Value: Boolean);\r\n procedure SetSorted(Value: Boolean);\r\n protected\r\n procedure DoStart; virtual;\r\n procedure DoStop; virtual;\r\n procedure Initialize; virtual;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n procedure Start;\r\n procedure EnterID(ID: Integer);\r\n procedure EnterName(const Name: string);\r\n procedure ExitName(const Name: string);\r\n procedure ExitID(ID: Integer);\r\n procedure Stop;\r\n procedure ShowReport;\r\n published\r\n property Enabled: Boolean read FEnabled write SetEnabled default False;\r\n property Names: TStrings read GetNames write SetNames;\r\n property Sorted: Boolean read FSorted write SetSorted default False;\r\n property OnStart: TNotifyEvent read FOnStart write FOnStart;\r\n property OnStop: TNotifyEvent read FOnStop write FOnStop;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvProfilerForm.pas $';\r\n Revision: '$Revision: 13104 $';\r\n Date: '$Date: 2011-09-07 08:50:43 +0200 (mer. 07 sept. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n SysUtils,\r\n CommCtrl,\r\n JvConsts, JvTypes, JvResources;\r\n\r\n{$R *.dfm}\r\n\r\nconst\r\n EmptyLine = '0.00';\r\n DefHeader2 =\r\n 'Profiler 32 - (C) 1996 Certified Software Corp, portions Copyright (C) 1997 by Peter Thrnqvist; all rights reserved.';\r\n\r\ntype\r\n PProfType = ^TProfType;\r\n TProfType = record\r\n InOutTime: Integer;\r\n TimeSpent: Integer;\r\n Calls: Integer;\r\n StringID: string;\r\n end;\r\n\r\n PStackType = ^TStackType;\r\n TStackType = record\r\n CallerID: Integer;\r\n EntryTime: Integer;\r\n end;\r\n\r\nfunction GetUserNamePas: string;\r\nvar\r\n Buff: array [0..255] of Char;\r\n I: Cardinal;\r\nbegin\r\n I := 255;\r\n GetUserName(Buff, I);\r\n Result := Buff;\r\nend;\r\n\r\nfunction GetComputerNamePas: string;\r\nvar\r\n Buff: array [0..255] of Char;\r\n I: Cardinal;\r\nbegin\r\n I := 255;\r\n GetComputerName(Buff, I);\r\n Result := Buff;\r\nend;\r\n\r\n//=== { TJvProfiler } ========================================================\r\n\r\nconstructor TJvProfiler.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FNames := TStringList.Create;\r\nend;\r\n\r\ndestructor TJvProfiler.Destroy;\r\nbegin\r\n Stop;\r\n FNames.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvProfiler.Initialize;\r\nvar\r\n I: Integer;\r\nbegin\r\n FEnabled := False;\r\n FStarted := False;\r\n FStartTime := 0;\r\n FEndTime := 0;\r\n FStackSize := 0;\r\n FLastProc := -1;\r\n { build ID list }\r\n for I := 0 to FNames.Count - 1 do\r\n begin\r\n if Length(Trim(FNames[I])) < 1 then\r\n Continue; { skip empty ID's }\r\n if FLastProc > MaxProfEntries then\r\n raise EJVCLException.CreateResFmt(@RsEMaxNumberOfIDsExceededd, [MaxProfEntries - 1]);\r\n Inc(FLastProc);\r\n with FProfileInfo[FLastProc] do\r\n begin\r\n TimeSpent := 0;\r\n Calls := 0;\r\n StringID := FNames[I];\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvProfiler.EnterID(ID: Integer);\r\nvar\r\n Snap: Integer;\r\nbegin\r\n if FEnabled then\r\n begin\r\n Snap := GetTickCount;\r\n if FStackSize > MaxStackSize then\r\n raise EJVCLException.CreateResFmt(@RsEMaxStackSizeExceededd, [MaxStackSize]);\r\n Inc(FStackSize);\r\n\r\n with FStack[FStackSize] do\r\n begin\r\n EntryTime := Snap;\r\n CallerID := ID\r\n end;\r\n\r\n with FProfileInfo[ID] do\r\n begin\r\n Inc(Calls);\r\n InOutTime := Snap;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvProfiler.EnterName(const Name: string);\r\nbegin\r\n EnterID(FNames.IndexOf(Name));\r\nend;\r\n\r\nprocedure TJvProfiler.ExitName(const Name: string);\r\nbegin\r\n ExitID(FNames.IndexOf(Name));\r\nend;\r\n\r\nprocedure TJvProfiler.ExitID(ID: Integer);\r\nvar\r\n Snap, Elapsed: Integer;\r\nbegin\r\n if Enabled then\r\n begin\r\n Snap := GetTickCount;\r\n with FProfileInfo[ID] do\r\n begin\r\n Elapsed := Snap - InOutTime;\r\n TimeSpent := TimeSpent + Elapsed;\r\n end;\r\n if FStackSize > 0 then\r\n Dec(FStackSize);\r\n if FStackSize > 0 then\r\n with FProfileInfo[FStack[FStackSize].CallerID] do\r\n TimeSpent := TimeSpent - Elapsed;\r\n end;\r\nend;\r\n\r\nprocedure TJvProfiler.DoStart;\r\nbegin\r\n if Assigned(FOnStart) then\r\n FOnStart(Self);\r\nend;\r\n\r\nprocedure TJvProfiler.DoStop;\r\nbegin\r\n if Assigned(FOnStop) then\r\n FOnStop(Self);\r\nend;\r\n\r\nprocedure TJvProfiler.Start;\r\nbegin\r\n if FEnabled and not FStarted then\r\n begin\r\n // Initialize;\r\n DoStart;\r\n FStartTime := GetTickCount;\r\n FStarted := True;\r\n end;\r\nend;\r\n\r\nprocedure TJvProfiler.Stop;\r\nbegin\r\n if FEnabled and FStarted then\r\n begin\r\n FEndTime := GetTickCount;\r\n DoStop;\r\n FStarted := False;\r\n end;\r\nend;\r\n\r\nfunction TJvProfiler.GetNames: TStrings;\r\nbegin\r\n Result := FNames;\r\nend;\r\n\r\nprocedure TJvProfiler.SetNames(Value: TStrings);\r\nbegin\r\n FNames.Assign(Value);\r\n Initialize;\r\nend;\r\n\r\nprocedure TJvProfiler.SetEnabled(Value: Boolean);\r\nbegin\r\n if FEnabled <> Value then\r\n FEnabled := Value;\r\nend;\r\n\r\nprocedure TJvProfiler.SetSorted(Value: Boolean);\r\nbegin\r\n if FSorted <> Value then\r\n begin\r\n FSorted := Value;\r\n FNames.Sorted := FSorted;\r\n Initialize;\r\n end;\r\nend;\r\n\r\nprocedure TJvProfiler.ShowReport;\r\nbegin\r\n if FEnabled then\r\n begin\r\n if FStarted then\r\n Stop;\r\n with TProfReport.Create(nil) do\r\n begin\r\n EndTime := FEndTime;\r\n StartTime := FStartTime;\r\n LastProc := FLastProc;\r\n ProfileInfo := FProfileInfo;\r\n ShowModal;\r\n Free;\r\n end;\r\n end;\r\nend;\r\n\r\n//=== { TProfReport } ========================================================\r\n\r\nprocedure TProfReport.FormShow(Sender: TObject);\r\nconst\r\n NumberFormat = '%4.2f';\r\nvar\r\n ThisProc: Integer;\r\n TotalSum: Integer;\r\n LItem: TListItem;\r\nbegin\r\n OddClick := True;\r\n TotalSum := (EndTime - StartTime);\r\n if TotalSum = 0 then\r\n Exit;\r\n lvReport.Items.BeginUpdate;\r\n lvReport.Items.Clear;\r\n for ThisProc := 0 to LastProc do\r\n with ProfileInfo[ThisProc] do\r\n begin\r\n LItem := lvReport.Items.Add;\r\n LItem.Caption := StringID; { function ID }\r\n if Calls <> 0 then\r\n begin\r\n LItem.SubItems.Add(Format(NumberFormat, [TimeSpent * 1.0])); { Total time spent here }\r\n LItem.SubItems.Add(IntToStr(Calls)); { Total number of calls }\r\n LItem.SubItems.Add(Format(NumberFormat, [TimeSpent / Calls])); { average time }\r\n LItem.SubItems.Add(Format(NumberFormat, [TimeSpent / TotalSum * 100.0])); { percentage }\r\n end\r\n else\r\n begin\r\n LItem.SubItems.Add(EmptyLine);\r\n LItem.SubItems.Add('0');\r\n LItem.SubItems.Add(EmptyLine);\r\n LItem.SubItems.Add(EmptyLine);\r\n end;\r\n end;\r\n Caption := Format(RsTotalElapsedTimedms, [RsDefCaption, TotalSum]);\r\n lvReport.Items.EndUpdate;\r\nend;\r\n\r\nfunction IsFloat(S: string): Boolean;\r\nbegin\r\n Result := True;\r\n try\r\n StrToFloat(S);\r\n except\r\n Result := False;\r\n end;\r\nend;\r\n\r\nfunction DefSort(lParam1, lParam2: TListItem; lParamSort: Integer): Integer; stdcall;\r\nvar\r\n l1, l2: Extended;\r\nbegin\r\n if lParamSort = 0 then\r\n Result := AnsiCompareText(lParam1.Caption, lParam2.Caption)\r\n else\r\n begin\r\n if not IsFloat(lParam1.SubItems[lParamSort - 1]) then\r\n l1 := -1.0\r\n else\r\n l1 := StrToFloat(lParam1.SubItems[lParamSort - 1]);\r\n if not IsFloat(lParam2.SubItems[lParamSort - 1]) then\r\n l2 := -1.0\r\n else\r\n l2 := StrToFloat(lParam2.SubItems[lParamSort - 1]);\r\n Result := Round((l1 * 1000) - (l2 * 1000));\r\n end;\r\n if OddClick then\r\n Result := -Result;\r\nend;\r\n\r\nprocedure TProfReport.lvReportColumnClick(Sender: TObject; Column: TListColumn);\r\nbegin\r\n // lvReport.Items.BeginUpdate;\r\n lvReport.CustomSort(TLVCompare(@DefSort), Column.Index);\r\n OddClick := not OddClick;\r\n // lvReport.Items.EndUpdate;\r\nend;\r\n\r\nprocedure TProfReport.SaveBtnClick(Sender: TObject);\r\nvar\r\n OutList: TStringList;\r\n S: string;\r\n I, J: Integer;\r\nbegin\r\n with TSaveDialog.Create(nil) do\r\n begin\r\n Filter := RsTextFormatsasctxtinfdocAllFiles;\r\n if Execute then\r\n begin\r\n OutList := TStringList.Create;\r\n OutList.Add(Format(RsDefHeader, [DateToStr(Now), GetUserNamePas,\r\n GetComputerNamePas]));\r\n OutList.Add(DefHeader2);\r\n S := '';\r\n for I := 0 to lvReport.Columns.Count - 1 do\r\n S := S + lvReport.Columns[I].Caption + Tab;\r\n OutList.Add(S);\r\n S := '';\r\n with lvReport do\r\n for I := 0 to Items.Count - 1 do\r\n begin\r\n with Items[I] do\r\n begin\r\n S := S + Caption + Tab;\r\n for J := 0 to SubItems.Count - 1 do\r\n S := S + SubItems[J] + Tab;\r\n OutList.Add(S);\r\n end;\r\n S := '';\r\n end;\r\n OutList.SaveToFile(Filename);\r\n OutList.Free;\r\n end;\r\n Free;\r\n end;\r\nend;\r\n\r\nprocedure TProfReport.OKBtnClick(Sender: TObject);\r\nbegin\r\n Close;\r\nend;\r\n\r\nprocedure TProfReport.TrimBtnClick(Sender: TObject);\r\nvar\r\n I: Integer;\r\nbegin\r\n lvReport.Items.BeginUpdate;\r\n for I := lvReport.Items.Count - 1 downto 0 do\r\n { no calls = not used }\r\n if lvReport.Items[I].SubItems[1] = '0' then\r\n lvReport.Items.Delete(I);\r\n lvReport.Items.EndUpdate;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvProgramVersionCheck.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvProgramVersionCheck.PAS, released on 2004-12-16.\r\n\r\nThe Initial Developer of the Original Code is Jens Fudickar [jens dott fudickar att oratool dott com]\r\nContributor : Ed Blanchard\r\nAll Rights Reserved.\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvProgramVersionCheck.pas 13240 2012-02-27 11:05:59Z obones $\r\n\r\nunit JvProgramVersionCheck;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Classes,\r\n {$IFDEF USE_3RDPARTY_INDY}\r\n IdHTTP, IdFTP,\r\n {$ENDIF USE_3RDPARTY_INDY}\r\n {$IFDEF USE_3RDPARTY_ICS}\r\n {$IFDEF DELPHI7_UP}\r\n OverbyteIcsHttpProt, OverbyteIcsFtpCli,\r\n {$ELSE}\r\n HttpProt, FtpCli,\r\n {$ENDIF DELPHI7_UP}\r\n {$ENDIF USE_3RDPARTY_ICS}\r\n JvPropertyStore, JvAppStorage, JvAppIniStorage, JvAppXMLStorage,\r\n JvParameterList, JvThread, JvThreadDialog, SysUtils;\r\n\r\ntype\r\n { Type of release of a Program Version }\r\n TJvProgramReleaseType = (prtProduction, prtBeta, prtAlpha);\r\n\r\n TJvRemoteVersionOperation = (rvoIgnore, rvoCopy, rvoCopyInstall);\r\n\r\n { List class to collect and sort version infos }\r\n TJvProgramVersionsStringList = class(TStringList)\r\n public\r\n procedure Sort; override;\r\n end;\r\n\r\n { Class to collect all informations about a program version\r\n These informations will be stored in the ini-file on the remote site}\r\n TJvProgramVersionInfo = class(TJvCustomPropertyStore)\r\n private\r\n FDownloadPasswordRequired: Boolean;\r\n FLocalInstallerParams: string;\r\n FVersionDescription: TStringList;\r\n FProgramSize: Integer;\r\n FProgramVersion: string;\r\n FProgramLocationPath: string;\r\n FProgramLocationFileName: string;\r\n FProgramReleaseType: TJvProgramReleaseType;\r\n FProgramReleaseDate: TDateTime;\r\n function GetVersionDescription: TStrings;\r\n procedure SetVersionDescription(Value: TStrings);\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n procedure Assign(Source: TPersistent); override;\r\n procedure Clear; override;\r\n function EditIntf_GetObjectHint: string; override;\r\n function EditIntf_GetPropertyHint(const PropertyName: string): string; override;\r\n //IJvPropertyEditorHandler = interface\r\n function EditIntf_GetVisibleObjectName: string; override;\r\n { Combination of ProgramVersion and ReleaseType }\r\n function ProgramVersionReleaseType: string;\r\n function ProgramSizeString: string;\r\n function ProgramVersionInfo: string;\r\n published\r\n //1 Flag to define whether a password is required for the download or not\r\n property DownloadPasswordRequired: Boolean read FDownloadPasswordRequired write FDownloadPasswordRequired default False;\r\n { List of parameters for the execution of the installer file }\r\n property LocalInstallerParams: string read FLocalInstallerParams write FLocalInstallerParams;\r\n { Path where the installer of the version could be found. This could be\r\n a absolute path or a relative path to the location of the version list file }\r\n property ProgramLocationPath: string read FProgramLocationPath write FProgramLocationPath;\r\n { File name of the installer file }\r\n property ProgramLocationFileName: string read FProgramLocationFileName write FProgramLocationFileName;\r\n { Program version in the format

...\r\n This property is compared with the fileversion properties of the current\r\n application. }\r\n property ProgramVersion: string read FProgramVersion write FProgramVersion;\r\n { This is a description field which could be shown in the update dialog via\r\n the version info button }\r\n property VersionDescription: TStrings read GetVersionDescription write SetVersionDescription;\r\n { Release type of the version.\r\n In the update dialog there are only the highest version numbers for each type\r\n visible. The type must be higher then AllowedReleaseType property of the\r\n TJvProgramVersionCheck component }\r\n property ProgramReleaseType: TJvProgramReleaseType read FProgramReleaseType write FProgramReleaseType;\r\n { Size of the installer in bytes }\r\n property ProgramSize: Integer read FProgramSize write FProgramSize;\r\n { Date of Release }\r\n property ProgramReleaseDate: TDateTime read FProgramReleaseDate write FProgramReleaseDate;\r\n end;\r\n\r\n TJvProgramVersionInfoReleaseArray = array[TJvProgramReleaseType] of TJvProgramVersionInfo;\r\n\r\n { List of all Program version stored in a remote file via TJvAppStorage }\r\n TJvProgramVersionHistory = class(TJvCustomPropertyListStore)\r\n private\r\n FCurrentProductionVersion: string;\r\n FCurrentBetaVersion: string;\r\n FCurrentAlphaVersion: string;\r\n FCurrentProgramVersion: TJvProgramVersionInfoReleaseArray;\r\n protected\r\n function CreateObject: TPersistent; override;\r\n function CreateItemList: TStringList; override;\r\n function GetProgramVersion(Index: Integer): TJvProgramVersionInfo;\r\n function GetCurrentProgramVersion(Index: TJvProgramReleaseType): TJvProgramVersionInfo;\r\n function SearchCurrentProgramVersion(AProgramReleaseType: TJvProgramReleaseType): TJvProgramVersionInfo;\r\n function GetCurrentProductionProgramVersion: string;\r\n function GetCurrentBetaProgramVersion: string;\r\n function GetCurrentAlphaProgramVersion: string;\r\n property ProgramVersion[Index: Integer]: TJvProgramVersionInfo read GetProgramVersion;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n procedure LoadData; override;\r\n procedure RecalculateCurrentProgramVersions;\r\n function AllowedCurrentProgramVersion(AAllowedReleaseType: TJvProgramReleaseType): TJvProgramVersionInfo;\r\n procedure Assign(Source: TPersistent); override;\r\n function EditIntf_GetObjectHint: string; override;\r\n function EditIntf_GetPropertyHint(const PropertyName: string): string; override;\r\n function EditIntf_GetVisibleObjectName: string; override;\r\n function GetVersionsDescription(const AFromVersion, AToVersion: string): string;\r\n property CurrentProgramVersion[Index: TJvProgramReleaseType]: TJvProgramVersionInfo read GetCurrentProgramVersion;\r\n published\r\n //1 Auto calculated version number of the highest production version\r\n property CurrentProductionProgramVersion: string read GetCurrentProductionProgramVersion write FCurrentProductionVersion;\r\n //1 Auto calculated version number of the highest beta version\r\n property CurrentBetaProgramVersion: string read GetCurrentBetaProgramVersion write FCurrentBetaVersion;\r\n //1 Auto calculated version number of the highest alpha version\r\n property CurrentAlphaProgramVersion: string read GetCurrentAlphaProgramVersion write FCurrentAlphaVersion;\r\n end;\r\n\r\n { Base class for all location\r\n A Location is the class which defines where the remote files could be found and\r\n manages all communications to these files. }\r\n TJvCustomProgramVersionLocation = class(TJvCustomPropertyStore)\r\n private\r\n FDownloadError: string;\r\n FDownloadStatus: string;\r\n FDownloadThreaded: Boolean;\r\n protected\r\n function LoadFileFromRemoteInt(const ARemotePath, ARemoteFileName, ALocalPath, ALocalFileName: string;\r\n ABaseThread: TJvBaseThread): string; virtual;\r\n procedure SetDownloadError(const Value: string); virtual;\r\n property DownloadStatus: string read FDownloadStatus write FDownloadStatus;\r\n property DownloadThreaded: Boolean read FDownloadThreaded write FDownloadThreaded default False;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n function LoadFileFromRemote(const ARemotePath, ARemoteFileName, ALocalPath, ALocalFileName: string;\r\n ABaseThread: TJvBaseThread): string; virtual;\r\n function LoadInstallerFileFromRemote(const ARemotePath, ARemoteFileName, ALocalPath, ALocalFileName: string;\r\n ABaseThread: TJvBaseThread): string; virtual;\r\n function LoadVersionInfoFromRemote(const ALocalDirectory, ALocalVersionInfoFileName: string;\r\n ABaseThread: TJvBaseThread): string; virtual;\r\n property DownloadError: string read FDownloadError write SetDownloadError;\r\n end;\r\n\r\n { Base class for all file based Locations like Network, FTP and HTTP }\r\n TJvCustomProgramVersionFileBasedLocation = class(TJvCustomProgramVersionLocation)\r\n private\r\n FVersionInfoLocationPathList: TStringList;\r\n FVersionInfoFileName: string;\r\n FValidLocationPath: string;\r\n function GetVersionInfoLocationPathList: TStrings;\r\n procedure SetVersionInfoLocationPathList(Value: TStrings);\r\n { If the location has a list of possible pathes, this property contains\r\n the path where the last valid download has happend}\r\n property ValidLocationPath: string read FValidLocationPath;\r\n { List of locations-path where the remote files could be found\r\n The application loops throuh all path from the top }\r\n property VersionInfoLocationPathList: TStrings read GetVersionInfoLocationPathList\r\n write SetVersionInfoLocationPathList;\r\n { Name of the VersionInfofile at the remote location }\r\n property VersionInfoFileName: string read FVersionInfoFileName write FVersionInfoFileName;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n function LoadVersionInfoFromRemote(const ALocalDirectory,\r\n ALocalVersionInfoFileName: string; ABaseThread: TJvBaseThread): string; override;\r\n function LoadInstallerFileFromRemote(const ARemotePath, ARemoteFileName,\r\n ALocalPath, ALocalFileName: string; ABaseThread: TJvBaseThread): string; override;\r\n end;\r\n\r\n { Location Class for Local Network Location }\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvProgramVersionNetworkLocation = class(TJvCustomProgramVersionFileBasedLocation)\r\n protected\r\n function LoadFileFromRemoteInt(const ARemotePath, ARemoteFileName, ALocalPath, ALocalFileName: string;\r\n ABaseThread: TJvBaseThread): string; override;\r\n published\r\n property VersionInfoLocationPathList;\r\n property VersionInfoFileName;\r\n end;\r\n\r\n { Class for Proxy Settings for FTP and HTTP locations }\r\n TJvProgramVersionProxySettings = class(TPersistent)\r\n private\r\n FServer: string;\r\n FPort: Integer;\r\n FUserName: string;\r\n FPassword: string;\r\n public\r\n constructor Create;\r\n published\r\n property Server: string read FServer write FServer;\r\n property Port: Integer read FPort write FPort default 80;\r\n property UserName: string read FUserName write FUserName;\r\n property Password: string read FPassword write FPassword;\r\n end;\r\n\r\n { Base class for all Internet locations }\r\n TJvCustomProgramVersionInternetLocation = class(TJvCustomProgramVersionFileBasedLocation)\r\n private\r\n FProxySettings: TJvProgramVersionProxySettings;\r\n FPasswordRequired: Boolean;\r\n FUserName: string;\r\n FPassword: string;\r\n FPort: Integer;\r\n protected\r\n property ProxySettings: TJvProgramVersionProxySettings read FProxySettings;\r\n property UserName: string read FUserName write FUserName;\r\n property Password: string read FPassword write FPassword;\r\n property PasswordRequired: Boolean read FPasswordRequired write FPasswordRequired default False;\r\n property Port: Integer read FPort write FPort default 80;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n end;\r\n\r\n TJvProgramVersionHTTPLocation = class;\r\n TJvLoadFileFromRemoteHTTPEvent = function(AProgramVersionLocation: TJvProgramVersionHTTPLocation;\r\n const ARemotePath, ARemoteFileName, ALocalPath, ALocalFileName: string): string of object;\r\n\r\n { Simple HTTP location class with no http logic.\r\n The logic must be implemented manually in the OnLoadFileFromRemote event }\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvProgramVersionHTTPLocation = class(TJvCustomProgramVersionInternetLocation)\r\n private\r\n FOnLoadFileFromRemote: TJvLoadFileFromRemoteHTTPEvent;\r\n protected\r\n function LoadFileFromRemoteInt(const ARemotePath, ARemoteFileName, ALocalPath, ALocalFileName: string;\r\n ABaseThread: TJvBaseThread): string; override;\r\n published\r\n property OnLoadFileFromRemote: TJvLoadFileFromRemoteHTTPEvent read FOnLoadFileFromRemote write FOnLoadFileFromRemote;\r\n property ProxySettings;\r\n property UserName;\r\n property Password;\r\n property PasswordRequired;\r\n property Port;\r\n property VersionInfoLocationPathList;\r\n property VersionInfoFileName;\r\n end;\r\n\r\n {$IFDEF USE_3RDPARTY_INDY}\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvProgramVersionHTTPLocationIndy = class(TJvProgramVersionHTTPLocation)\r\n private\r\n FIdHttp: TIdHttp;\r\n protected\r\n function LoadFileFromRemoteInt(const ARemotePath, ARemoteFileName, ALocalPath, ALocalFileName: string;\r\n ABaseThread: TJvBaseThread): string; override;\r\n function LoadFileFromRemoteIndy(const ARemotePath, ARemoteFileName, ALocalPath, ALocalFileName: string;\r\n ABaseThread: TJvBaseThread): string;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n published\r\n property ProxySettings;\r\n property UserName;\r\n property Password;\r\n property PasswordRequired;\r\n property Port;\r\n property VersionInfoLocationPathList;\r\n property VersionInfoFileName;\r\n end;\r\n {$ENDIF USE_3RDPARTY_INDY}\r\n\r\n {$IFDEF USE_3RDPARTY_ICS}\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvProgramVersionHTTPLocationICS = class(TJvProgramVersionHTTPLocation)\r\n private\r\n FHttpCli: THttpCli;\r\n protected\r\n function LoadFileFromRemoteInt(const ARemotePath, ARemoteFileName, ALocalPath, ALocalFileName: string;\r\n ABaseThread: TJvBaseThread): string; override;\r\n function LoadFileFromRemoteIcs(const ARemotePath, ARemoteFileName, ALocalPath, ALocalFileName: string;\r\n ABaseThread: TJvBaseThread): string;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n published\r\n property ProxySettings;\r\n property UserName;\r\n property Password;\r\n property PasswordRequired;\r\n property Port;\r\n property VersionInfoLocationPathList;\r\n property VersionInfoFileName;\r\n end;\r\n {$ENDIF USE_3RDPARTY_ICS}\r\n\r\n TJvProgramVersionFTPLocation = class;\r\n TJvLoadFileFromRemoteFTPEvent = function(AProgramVersionLocation: TJvProgramVersionFTPLocation;\r\n const ARemotePath, ARemoteFileName, ALocalPath, ALocalFileName: string): string of object;\r\n\r\n { Simple FTP location class with no http logic.\r\n The logic must be implemented manually in the OnLoadFileFromRemote event }\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvProgramVersionFTPLocation = class(TJvCustomProgramVersionInternetLocation)\r\n private\r\n FOnLoadFileFromRemote: TJvLoadFileFromRemoteFTPEvent;\r\n protected\r\n function LoadFileFromRemoteInt(const ARemotePath, ARemoteFileName, ALocalPath, ALocalFileName: string;\r\n ABaseThread: TJvBaseThread): string; override;\r\n published\r\n property OnLoadFileFromRemote: TJvLoadFileFromRemoteFTPEvent read FOnLoadFileFromRemote write FOnLoadFileFromRemote;\r\n property ProxySettings;\r\n end;\r\n\r\n {$IFDEF USE_3RDPARTY_INDY}\r\n TJvProgramVersionFTPLocationIndy = class(TJvProgramVersionFTPLocation)\r\n private\r\n FIdFtp: TIdFtp;\r\n protected\r\n function LoadFileFromRemoteInt(const ARemotePath, ARemoteFileName, ALocalPath, ALocalFileName: string;\r\n ABaseThread: TJvBaseThread): string; override;\r\n function LoadFileFromRemoteIndy(const ARemotePath, ARemoteFileName, ALocalPath, ALocalFileName: string;\r\n ABaseThread: TJvBaseThread): string;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n published\r\n property ProxySettings;\r\n property UserName;\r\n property Password;\r\n property PasswordRequired;\r\n property Port;\r\n property VersionInfoLocationPathList;\r\n property VersionInfoFileName;\r\n end;\r\n {$ENDIF USE_3RDPARTY_INDY}\r\n\r\n {$IFDEF USE_3RDPARTY_ICS}\r\n TJvProgramVersionFTPLocationICS = class(TJvProgramVersionFTPLocation)\r\n private\r\n FFtpClient: TFtpClient;\r\n protected\r\n function LoadFileFromRemoteInt(const ARemotePath, ARemoteFileName, ALocalPath, ALocalFileName: string;\r\n ABaseThread: TJvBaseThread): string; override;\r\n function LoadFileFromRemoteIcs(const ARemotePath, ARemoteFileName, ALocalPath, ALocalFileName: string;\r\n ABaseThread: TJvBaseThread): string;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n published\r\n property ProxySettings;\r\n property UserName;\r\n property Password;\r\n property PasswordRequired;\r\n property Port;\r\n property VersionInfoLocationPathList;\r\n property VersionInfoFileName;\r\n end;\r\n {$ENDIF USE_3RDPARTY_ICS}\r\n\r\n TJvProgramVersionDatabaseLocation = class;\r\n TJvLoadFileFromRemoteDatabaseEvent = function(AProgramVersionLocation: TJvProgramVersionDatabaseLocation;\r\n const ARemotePath, ARemoteFileName, ALocalPath, ALocalFileName: string): string of object;\r\n\r\n { Simple Database location class with no http logic.\r\n The logic must be implemented manually in the OnLoadFileFromRemote event }\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvProgramVersionDatabaseLocation = class(TJvCustomProgramVersionLocation)\r\n private\r\n FServerName: string;\r\n FUserName: string;\r\n FPassword: string;\r\n FSelectStatementVersion: string;\r\n FOnLoadFileFromRemote: TJvLoadFileFromRemoteDatabaseEvent;\r\n protected\r\n function LoadFileFromRemoteInt(const ARemotePath, ARemoteFileName, ALocalPath, ALocalFileName: string;\r\n ABaseThread: TJvBaseThread): string; override;\r\n public\r\n function LoadVersionInfoFromRemote(const ALocalDirectory, ALocalVersionInfoFileName: string;\r\n ABaseThread: TJvBaseThread): string; override;\r\n published\r\n property ServerName: string read FServerName write FServerName;\r\n property UserName: string read FUserName write FUserName;\r\n property Password: string read FPassword write FPassword;\r\n property SelectStatementVersion: string read FSelectStatementVersion write FSelectStatementVersion;\r\n property OnLoadFileFromRemote: TJvLoadFileFromRemoteDatabaseEvent read FOnLoadFileFromRemote write FOnLoadFileFromRemote;\r\n end;\r\n\r\n { Location Type for the TJvProgramVersionCheck class}\r\n TJvProgramVersionLocationType = (pvltNetwork, pvltDatabase, pvltFTP, pvltHTTP);\r\n {Set of TJvProgramVersionLocationTypes}\r\n TJvProgramVersionLocationTypes = set of TJvProgramVersionLocationType;\r\n\r\n { Type for User Customizing options to the JvProgramVersionCheck\r\n The settings of the Programversioncheck are stored via JvAppStorage. With\r\n these types could be defined which settings are stored and restored and so\r\n customisable by the end user}\r\n TJvProgramVersionUserOption = (uoCheckFrequency, uoLocalDirectory,\r\n uoAllowedReleaseType, uoLocationType, uoLocationNetwork,\r\n uoLocationHTTP, uoLocationFTP, uoLocationDatabase);\r\n { set of TJvProgramVersionUserOption }\r\n TJvProgramVersionUserOptions = set of TJvProgramVersionUserOption;\r\n\r\n TjvProgramVersionHistoryFileFormat = (hffIni, hffXML);\r\n\r\n TJvProgramVersionHistoryAppStorageOptions = class(TPersistent)\r\n private\r\n FFileFormat: TjvProgramVersionHistoryFileFormat;\r\n FINIOptions: TJvAppIniStorageOptions;\r\n FXMLOptions: TJvAppXMLStorageOptions;\r\n procedure SetINIOptions(const Value: TJvAppIniStorageOptions);\r\n procedure SetXMLOptions(const Value: TJvAppXMLStorageOptions);\r\n public\r\n constructor Create;\r\n destructor Destroy; override;\r\n published\r\n property FileFormat: TjvProgramVersionHistoryFileFormat read FFileFormat write FFileFormat default hffIni;\r\n property INIOptions: TJvAppIniStorageOptions read FINIOptions write SetINIOptions;\r\n property XMLOptions: TJvAppXMLStorageOptions read FXMLOptions write SetXMLOptions;\r\n end;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvProgramVersionCheck = class(TJvCustomPropertyStore)\r\n private\r\n FAllowedReleaseType: TJvProgramReleaseType;\r\n FCheckFrequency: Integer;\r\n FExecuteDownloadInstallFileName: string;\r\n FExecuteOperation: TJvRemoteVersionOperation;\r\n FExecuteVersionInfo: TJvProgramVersionInfo;\r\n FLastCheck: TDateTime;\r\n FLocalDirectory: string;\r\n FLocalInstallerFileName: string;\r\n FLocalVersionInfoFileName: string;\r\n FLocationDatabase: TJvProgramVersionDatabaseLocation;\r\n FLocationFTP: TJvProgramVersionFTPLocation;\r\n FLocationHTTP: TJvProgramVersionHTTPLocation;\r\n FLocationNetwork: TJvProgramVersionNetworkLocation;\r\n FLocationType: TJvProgramVersionLocationType;\r\n FRemoteProgramVersionHistory: TJvProgramVersionHistory;\r\n FThread: TJvThread;\r\n FThreadDialog: TJvThreadAnimateDialog;\r\n FThreadExceptionMessage : String;\r\n FThreadExceptionClass: ExceptClass;\r\n FThreadExceptionAddr: Pointer;\r\n FUserOptions: TJvProgramVersionUserOptions;\r\n FVersionHistoryFileOptions: TJvProgramVersionHistoryAppStorageOptions;\r\n function CreateVersionHistoryAppstorage(aFileFormat: TjvProgramVersionHistoryFileFormat): TJvCustomAppMemoryFileStorage;\r\n function GetDownloadError: string;\r\n function GetSelectedLocation: TJvCustomProgramVersionLocation;\r\n procedure SetLocationDatabase(const Value: TJvProgramVersionDatabaseLocation);\r\n procedure SetLocationFTP(const Value: TJvProgramVersionFTPLocation);\r\n procedure SetLocationHTTP(const Value: TJvProgramVersionHTTPLocation);\r\n procedure SetLocationNetwork(const Value: TJvProgramVersionNetworkLocation);\r\n procedure SetVersionHistoryFileOptions(const Value: TJvProgramVersionHistoryAppStorageOptions);\r\n protected\r\n procedure CheckLocalDirectory;\r\n function CurrentApplicationName: string;\r\n function CurrentFileVersion: string;\r\n procedure DownloadThreadOnException(Sender: TObject; E: Exception; EAddr: Pointer);\r\n procedure DownloadThreadOnExecute(Sender: TObject; Params: Pointer);\r\n procedure DownloadThreadOnFinishAll(Sender: TObject);\r\n function GetAllowedRemoteProgramVersion: string;\r\n function GetAllowedRemoteProgramVersionReleaseType: string;\r\n function GetLocationTypesSupported: TJvProgramVersionLocationTypes;\r\n function IsRemoteProgramVersionReleaseTypeNewer(AReleaseType: TJvProgramReleaseType): Boolean;\r\n procedure LoadData; override;\r\n function LoadRemoteInstallerFile(const ALocalDirectory, ALocalInstallerFileName: string;\r\n AProgramVersionInfo: TJvProgramVersionInfo; ABaseThread: TJvBaseThread): string;\r\n function LoadRemoteVersionInfoFile(const ALocalDirectory: string; const ALocalVersionInfoFileName: string): string;\r\n procedure Notification(AComponent: TComponent; Operation: TOperation); override;\r\n procedure SetThreadInfo(const Info: string);\r\n procedure SetUserOptions(Value: TJvProgramVersionUserOptions);\r\n procedure StoreData; override;\r\n procedure VersionInfoButtonClick(const ParameterList: TJvParameterList; const Parameter: TJvBaseParameter);\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n procedure DownloadInstallerFromRemote;\r\n procedure Execute;\r\n function GetRemoteVersionOperation(var ReleaseType: TJvProgramReleaseType): TJvRemoteVersionOperation;\r\n function IsRemoteProgramVersionNewer: Boolean;\r\n function LoadRemoteVersionHistoryFromFile(aFileFormat: TjvProgramVersionHistoryFileFormat; const aFileName: string): Boolean;\r\n procedure ShowProgramVersionsDescription(const AFromVersion, AToVersion: string);\r\n function StoreRemoteVersionHistoryToFile(aFileFormat: TjvProgramVersionHistoryFileFormat; const aFilename: string): Boolean;\r\n property DownloadError: string read GetDownloadError;\r\n property LastCheck: TDateTime read FLastCheck write FLastCheck;\r\n property LocationTypesSupported: TJvProgramVersionLocationTypes read GetLocationTypesSupported;\r\n property RemoteProgramVersionHistory: TJvProgramVersionHistory read FRemoteProgramVersionHistory write FRemoteProgramVersionHistory;\r\n property SelectedLocation: TJvCustomProgramVersionLocation read GetSelectedLocation;\r\n property Thread: TJvThread read FThread;\r\n property ThreadDialog: TJvThreadAnimateDialog read FThreadDialog;\r\n published\r\n { Defines which release types will be shown in the update dialog }\r\n property AllowedReleaseType: TJvProgramReleaseType read FAllowedReleaseType write FAllowedReleaseType default prtProduction;\r\n property AppStorage;\r\n property AppStoragePath;\r\n { Defines how often the check for a new version is executed (in days) }\r\n property CheckFrequency: Integer read FCheckFrequency write FCheckFrequency;\r\n { Defines the local directory where the remote files where stored }\r\n property LocalDirectory: string read FLocalDirectory write FLocalDirectory;\r\n { Defines the local name of the program installer. If it is empty the name\r\n of the remote file is used }\r\n property LocalInstallerFileName: string read FLocalInstallerFileName write FLocalInstallerFileName;\r\n { Defines the name of the local version info file. If it is empty the name\r\n of the remote file is used }\r\n property LocalVersionInfoFileName: string read FLocalVersionInfoFileName write FLocalVersionInfoFileName;\r\n { Database Location }\r\n property LocationDatabase: TJvProgramVersionDatabaseLocation read FLocationDatabase write SetLocationDatabase;\r\n { FTP Location }\r\n property LocationFTP: TJvProgramVersionFTPLocation read FLocationFTP write SetLocationFTP;\r\n { HTTP Location }\r\n property LocationHTTP: TJvProgramVersionHTTPLocation read FLocationHTTP write SetLocationHTTP;\r\n { Network Location }\r\n property LocationNetwork: TJvProgramVersionNetworkLocation read FLocationNetwork write SetLocationNetwork;\r\n { Defines location which is used for the version check,\r\n only assigned locations are supported }\r\n property LocationType: TJvProgramVersionLocationType read FLocationType write FLocationType;\r\n {Defines which options of the component are stored/restored via AppStorage }\r\n property UserOptions: TJvProgramVersionUserOptions read FUserOptions write SetUserOptions\r\n default [uoCheckFrequency, uoLocalDirectory, uoAllowedReleaseType,\r\n uoLocationType, uoLocationNetwork, uoLocationHTTP, uoLocationFTP, uoLocationDatabase];\r\n property VersionHistoryFileOptions: TJvProgramVersionHistoryAppStorageOptions\r\n read FVersionHistoryFileOptions write SetVersionHistoryFileOptions;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvProgramVersionCheck.pas $';\r\n Revision: '$Revision: 13240 $';\r\n Date: '$Date: 2012-02-27 12:05:59 +0100 (lun. 27 févr. 2012) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n Dialogs, Controls, ComCtrls, StdCtrls, Forms,\r\n {$IFDEF USE_3RDPARTY_INDY}\r\n IdURI,\r\n {$ENDIF USE_3RDPARTY_INDY}\r\n JclBase, JclFileUtils, JclShell,\r\n JvDSADialogs, JvParameterListParameter, JvResources, Windows, Messages, JvJVCLUtils;\r\n\r\nconst\r\n SParamNameVersionButtonInfo = 'VersionButtonInfo';\r\n SParamNameMemo = 'Memo';\r\n SParamNameNewVersionLabel = 'New Version Label';\r\n SParamNameGroupBox = 'GroupBox';\r\n SParamNameOperation = 'Operation';\r\n SParamNameRadioButton = 'RadioButton';\r\n SAppStorageDefaultSection = 'Version';\r\n SProgramVersion = 'Program Version ';\r\n SLastCheck = 'LastCheck';\r\n\r\n//=== Common Functions =======================================================\r\n\r\nfunction CompareVersionNumbers(AVersion1, AVersion2: string): Integer;\r\nvar\r\n N1, N2: Integer;\r\n\r\n function GetNextNumber(var Version: string): Integer;\r\n var\r\n P: Integer;\r\n S: string;\r\n begin\r\n P := Pos('.', Version);\r\n if P > 0 then\r\n begin\r\n S := Copy(Version, 1, P - 1);\r\n Version := Copy(Version, P + 1, Length(Version) - P);\r\n end\r\n else\r\n begin\r\n S := Version;\r\n Version := '';\r\n end;\r\n if S = '' then\r\n Result := -1\r\n else\r\n try\r\n Result := StrToInt(S);\r\n except\r\n Result := -1;\r\n end;\r\n end;\r\n\r\nbegin\r\n Result := 0;\r\n repeat\r\n N1 := GetNextNumber(AVersion1);\r\n N2 := GetNextNumber(AVersion2);\r\n if N2 > N1 then\r\n begin\r\n Result := 1;\r\n Exit;\r\n end\r\n else\r\n if N2 < N1 then\r\n begin\r\n Result := -1;\r\n Exit;\r\n end\r\n until (AVersion1 = '') and (AVersion2 = '');\r\nend;\r\n\r\n//=== { TJvProgramVersionsStringList } =======================================\r\n\r\nfunction VersionNumberSortCompare(List: TStringList; Index1, Index2: Integer): Integer;\r\nvar\r\n Info1, Info2: TJvProgramVersionInfo;\r\nbegin\r\n Info1 := TJvProgramVersionInfo(List.Objects[Index1]);\r\n Info2 := TJvProgramVersionInfo(List.Objects[Index2]);\r\n Result := CompareVersionNumbers(Info1.ProgramVersion, Info2.ProgramVersion);\r\nend;\r\n\r\nprocedure TJvProgramVersionsStringList.Sort;\r\nbegin\r\n CustomSort(VersionNumberSortCompare);\r\nend;\r\n\r\nfunction TJvProgramVersionCheck.CreateVersionHistoryAppstorage(aFileFormat: TjvProgramVersionHistoryFileFormat):\r\n TJvCustomAppMemoryFileStorage;\r\nbegin\r\n if aFileFormat = hffIni then\r\n begin\r\n Result := TJvCustomAppMemoryFileStorage(TJvAppIniFileStorage.Create(Self));\r\n TJvAppIniFileStorage(Result).DefaultSection := SAppStorageDefaultSection;\r\n Result.StorageOptions.Assign(VersionHistoryFileOptions.INIOptions);\r\n end\r\n else\r\n begin\r\n Result := TJvCustomAppMemoryFileStorage(TJvAppXMLFileStorage.Create(Self));\r\n Result.StorageOptions.Assign(VersionHistoryFileOptions.XMLOptions);\r\n end;\r\n Result.Location := flCustom;\r\n Result.ReadOnly := True;\r\n Result.AutoReload := True;\r\nend;\r\n\r\n//=== { TJvProgramVersionInfo } ==============================================\r\n\r\nconstructor TJvProgramVersionInfo.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FVersionDescription := TStringList.Create;\r\n IgnoreLastLoadTime := True;\r\n FDownloadPasswordRequired := False;\r\nend;\r\n\r\ndestructor TJvProgramVersionInfo.Destroy;\r\nbegin\r\n FreeAndNil(FVersionDescription);\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvProgramVersionInfo.Assign(Source: TPersistent);\r\nbegin\r\n if (Source = Self) then\r\n Exit;\r\n if Source is TJvProgramVersionInfo then\r\n begin\r\n DownloadPasswordRequired := TJvProgramVersionInfo (Source).DownloadPasswordRequired;\r\n LocalInstallerParams := TJvProgramVersionInfo (Source).LocalInstallerParams;\r\n VersionDescription := TJvProgramVersionInfo (Source).VersionDescription;\r\n ProgramSize := TJvProgramVersionInfo (Source).ProgramSize;\r\n ProgramVersion := TJvProgramVersionInfo (Source).ProgramVersion;\r\n ProgramLocationPath := TJvProgramVersionInfo (Source).ProgramLocationPath;\r\n ProgramLocationFileName := TJvProgramVersionInfo (Source).ProgramLocationFileName;\r\n ProgramReleaseType := TJvProgramVersionInfo (Source).ProgramReleaseType;\r\n ProgramReleaseDate := TJvProgramVersionInfo (Source).ProgramReleaseDate;\r\n end\r\n else\r\n inherited assign(Source);\r\nend;\r\n\r\nfunction TJvProgramVersionInfo.GetVersionDescription: TStrings;\r\nbegin\r\n Result := FVersionDescription;\r\nend;\r\n\r\nprocedure TJvProgramVersionInfo.SetVersionDescription(Value: TStrings);\r\nbegin\r\n FVersionDescription.Assign(Value);\r\nend;\r\n\r\nprocedure TJvProgramVersionInfo.Clear;\r\nbegin\r\n if Assigned(FVersionDescription) then\r\n FVersionDescription.Clear;\r\n FProgramVersion := '';\r\n FProgramReleaseType := prtProduction;\r\nend;\r\n\r\nfunction TJvProgramVersionInfo.EditIntf_GetObjectHint: string;\r\nbegin\r\n Result := RSProgramVersionInfo_ObjectHint;\r\nend;\r\n\r\nfunction TJvProgramVersionInfo.EditIntf_GetPropertyHint(const PropertyName:\r\n string): string;\r\nbegin\r\n Result := '';\r\n if PropertyName = 'DownloadPasswordRequired' then\r\n Result := RSProgramVersionInfo_PropertyHint_DownloadPassword\r\n else if PropertyName = 'LocalInstallerParams' then\r\n Result := RSProgramVersionInfo_PropertyHint_LocalInstallerParams\r\n else if PropertyName = 'ProgramLocationPath' then\r\n Result := RSProgramVersionInfo_PropertyHint_ProgramLocationPath\r\n else if PropertyName = 'ProgramLocationFileName' then\r\n Result := RSProgramVersionInfo_PropertyHint_ProgramLocationFileName\r\n else if PropertyName = 'ProgramVersion' then\r\n Result := RSProgramVersionInfo_PropertyHint_ProgramVersion\r\n else if PropertyName = 'VersionDescription' then\r\n Result := RSProgramVersionInfo_PropertyHint_VersionDescription\r\n else if PropertyName = 'ProgramReleaseType' then\r\n Result := RSProgramVersionInfo_PropertyHint_ProgramReleaseType\r\n else if PropertyName = 'ProgramSize' then\r\n Result := RSProgramVersionInfo_PropertyHint_ProgramSize\r\n else if PropertyName = 'ProgramReleaseDate' then\r\n Result := RSProgramVersionInfo_PropertyHint_ProgramReleaseDate\r\n else\r\n Result := '';\r\nend;\r\n\r\nfunction TJvProgramVersionInfo.EditIntf_GetVisibleObjectName: string;\r\nbegin\r\n Result := ProgramVersionInfo;\r\nend;\r\n\r\nfunction TJvProgramVersionInfo.ProgramVersionReleaseType: string;\r\nbegin\r\n case ProgramReleaseType of\r\n prtBeta:\r\n Result := Trim(ProgramVersion + ' ' + RsPVCReleaseTypeBeta);\r\n prtAlpha:\r\n Result := Trim(ProgramVersion + ' ' + RsPVCReleaseTypeAlpha);\r\n else\r\n Result := Trim(ProgramVersion + ' ' + RsPVCReleaseTypeProduction);\r\n end;\r\nend;\r\n\r\nfunction TJvProgramVersionInfo.ProgramSizeString: string;\r\nbegin\r\n if ProgramSize <= 0 then\r\n Result := ''\r\n else\r\n if ProgramSize >= 1024 * 1024 * 1024 then\r\n Result := Format(RsPVSiceGB, [ProgramSize / 1024 / 1024 / 1024])\r\n else\r\n if ProgramSize >= 1024 * 1024 then\r\n Result := Format(RsPVSiceMB, [ProgramSize / 1024 / 1024])\r\n else\r\n if ProgramSize >= 1024 then\r\n Result := Format(RsPVSiceKB, [ProgramSize / 1024])\r\n else\r\n Result := Format(RsPVSiceB, [ProgramSize])\r\nend;\r\n\r\nfunction TJvProgramVersionInfo.ProgramVersionInfo: string;\r\nbegin\r\n Result := ProgramVersionReleaseType;\r\n if ProgramSize > 0 then\r\n Result := Result + ' (' + ProgramSizeString + ')';\r\nend;\r\n\r\n//=== { TJvProgramVersionHistory } ===========================================\r\n\r\nconstructor TJvProgramVersionHistory.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n DeleteBeforeStore := True;\r\n ItemName := SProgramVersion;\r\n IgnoreLastLoadTime := True;\r\n IgnoreProperties.Add('Duplicates');\r\n IgnoreProperties.Add('Sorted');\r\nend;\r\n\r\nprocedure TJvProgramVersionHistory.RecalculateCurrentProgramVersions;\r\nvar\r\n I: TJvProgramReleaseType;\r\nbegin\r\n Items.Sort;\r\n for I := Low(TJvProgramReleaseType) to High(TJvProgramReleaseType) do\r\n FCurrentProgramVersion[I] := SearchCurrentProgramVersion(I);\r\nend;\r\n\r\nprocedure TJvProgramVersionHistory.LoadData;\r\nbegin\r\n inherited LoadData;\r\n RecalculateCurrentProgramVersions;\r\nend;\r\n\r\nfunction TJvProgramVersionHistory.AllowedCurrentProgramVersion(\r\n AAllowedReleaseType: TJvProgramReleaseType): TJvProgramVersionInfo;\r\nvar\r\n I: TJvProgramReleaseType;\r\nbegin\r\n Result := nil;\r\n I := Low(TJvProgramReleaseType);\r\n while I <= AAllowedReleaseType do\r\n begin\r\n if Result = nil then\r\n Result := CurrentProgramVersion[I]\r\n else\r\n if Assigned(CurrentProgramVersion[I]) and\r\n (CompareVersionNumbers(Result.ProgramVersion, CurrentProgramVersion[I].ProgramVersion) > 0) then\r\n Result := CurrentProgramVersion[I];\r\n Inc(I);\r\n end;\r\nend;\r\n\r\nprocedure TJvProgramVersionHistory.Assign(Source: TPersistent);\r\nvar\r\n i: Integer;\r\n VersionInfo: TJvProgramVersionInfo;\r\nbegin\r\n if (Source = Self) then\r\n Exit;\r\n if Source is TJvProgramVersionHistory then\r\n begin\r\n clear;\r\n CurrentBetaProgramVersion := TJvProgramVersionHistory(Source).CurrentBetaProgramVersion;\r\n CurrentAlphaProgramVersion := TJvProgramVersionHistory(Source).CurrentAlphaProgramVersion;\r\n for i := 0 to TJvProgramVersionHistory(Source).count - 1 do\r\n begin\r\n VersionInfo := TJvProgramVersionInfo(TJvProgramVersionInfo(TJvProgramVersionHistory(Source).Items.Objects[i]).Clone(Owner));\r\n Items.AddObject(VersionInfo.ProgramVersion, VersionInfo);\r\n end;\r\n Items.Sort;\r\n end\r\n else\r\n inherited assign(Source);\r\nend;\r\n\r\nfunction TJvProgramVersionHistory.GetProgramVersion(Index: Integer): TJvProgramVersionInfo;\r\nbegin\r\n if Assigned(Objects[Index]) and (Objects[Index] is TJvProgramVersionInfo) then\r\n Result := TJvProgramVersionInfo(Objects[Index])\r\n else\r\n Result := nil;\r\nend;\r\n\r\nfunction TJvProgramVersionHistory.SearchCurrentProgramVersion(\r\n AProgramReleaseType: TJvProgramReleaseType): TJvProgramVersionInfo;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := nil;\r\n for I := 0 to Count - 1 do\r\n if Assigned(ProgramVersion[I]) then\r\n if ProgramVersion[I].ProgramReleaseType = AProgramReleaseType then\r\n if Result = nil then\r\n Result := ProgramVersion[I]\r\n else\r\n if CompareVersionNumbers(Result.ProgramVersion, ProgramVersion[I].ProgramVersion) = 1 then\r\n Result := ProgramVersion[I];\r\nend;\r\n\r\nfunction TJvProgramVersionHistory.GetCurrentProgramVersion(Index: TJvProgramReleaseType): TJvProgramVersionInfo;\r\nbegin\r\n Result := FCurrentProgramVersion[Index];\r\nend;\r\n\r\nfunction TJvProgramVersionHistory.CreateObject: TPersistent;\r\nbegin\r\n Result := TJvProgramVersionInfo.Create(Self);\r\nend;\r\n\r\nfunction TJvProgramVersionHistory.CreateItemList: TStringList;\r\nbegin\r\n Result := TJvProgramVersionsStringList.Create;\r\nend;\r\n\r\nfunction TJvProgramVersionHistory.EditIntf_GetObjectHint: string;\r\nbegin\r\n Result := RSProgramVersionHistory_ObjectHint;\r\nend;\r\n\r\nfunction TJvProgramVersionHistory.EditIntf_GetPropertyHint(const PropertyName:\r\n string): string;\r\nbegin\r\n Result := '';\r\n if PropertyName = 'CurrentProductionProgramVersion' then\r\n Result := RSProgramVersionHistory_PropertyHint_Production\r\n else if PropertyName = 'CurrentBetaProgramVersion' then\r\n Result := RSProgramVersionHistory_PropertyHint_beta\r\n else if PropertyName = 'CurrentAlphaProgramVersion' then\r\n Result := RSProgramVersionHistory_PropertyHint_alpha\r\n else\r\n Result := Inherited EditIntf_GetPropertyHint(PropertyName);\r\nend;\r\n\r\nfunction TJvProgramVersionHistory.EditIntf_GetVisibleObjectName: string;\r\nbegin\r\n Result := RSProgramVersionHistory;\r\nend;\r\n\r\nfunction TJvProgramVersionHistory.GetCurrentProductionProgramVersion: string;\r\nbegin\r\n if Assigned(CurrentProgramVersion[prtProduction]) then\r\n Result := CurrentProgramVersion[prtProduction].ProgramVersion\r\n else\r\n Result := '';\r\nend;\r\n\r\nfunction TJvProgramVersionHistory.GetCurrentBetaProgramVersion: string;\r\nbegin\r\n if Assigned(CurrentProgramVersion[prtBeta]) then\r\n Result := CurrentProgramVersion[prtBeta].ProgramVersion\r\n else\r\n Result := '';\r\nend;\r\n\r\nfunction TJvProgramVersionHistory.GetCurrentAlphaProgramVersion: string;\r\nbegin\r\n if Assigned(CurrentProgramVersion[prtAlpha]) then\r\n Result := CurrentProgramVersion[prtAlpha].ProgramVersion\r\n else\r\n Result := '';\r\nend;\r\n\r\nfunction TJvProgramVersionHistory.GetVersionsDescription(const AFromVersion, AToVersion: string): string;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := '';\r\n for I := 0 to Count - 1 do\r\n if (CompareVersionNumbers(AFromVersion, ProgramVersion[I].ProgramVersion) >= 0) and\r\n (CompareVersionNumbers(AToVersion, ProgramVersion[I].ProgramVersion) <= 0) then\r\n begin\r\n Result := Result + ProgramVersion[I].ProgramVersionReleaseType;\r\n if ProgramVersion[I].ProgramReleaseDate > 0 then\r\n Result := Result + ' - ' + DateTimeToStr(ProgramVersion[I].ProgramReleaseDate);\r\n if ProgramVersion[I].VersionDescription.Count > 0 then\r\n Result := Result + NativeLineBreak + ProgramVersion[I].VersionDescription.Text;\r\n Result := Result + NativeLineBreak + NativeLineBreak;\r\n end;\r\nend;\r\n\r\n//=== { TJvProgramVersionCustomLocation } ====================================\r\n\r\nconstructor TJvCustomProgramVersionLocation.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FDownloadThreaded := False;\r\n FDownloadStatus := '';\r\n IgnoreLastLoadTime := True;\r\n IgnoreProperties.Add('DownloadThreaded');\r\nend;\r\n\r\nfunction TJvCustomProgramVersionLocation.LoadFileFromRemoteInt(\r\n const ARemotePath, ARemoteFileName, ALocalPath, ALocalFileName: string;\r\n ABaseThread: TJvBaseThread): string;\r\nbegin\r\nend;\r\n\r\nfunction TJvCustomProgramVersionLocation.LoadFileFromRemote(\r\n const ARemotePath, ARemoteFileName, ALocalPath, ALocalFileName: string;\r\n ABaseThread: TJvBaseThread): string;\r\nvar\r\n TemporaryLocalFileName: string;\r\n LocalFileName: string;\r\n TemporaryLocalFileName2: string;\r\nbegin\r\n DownloadStatus := RsPVCDownloading;\r\n DownloadError := '';\r\n if ALocalFileName = '' then\r\n LocalFileName := ARemoteFileName\r\n else\r\n LocalFileName := ALocalFileName;\r\n TemporaryLocalFileName := LocalFileName + RsPVTempFileNameExtension;\r\n if FileExists(PathAppend(ALocalPath, TemporaryLocalFileName)) then\r\n SysUtils.DeleteFile(PathAppend(ALocalPath, TemporaryLocalFileName));\r\n Result := LoadFileFromRemoteInt(ARemotePath, ARemoteFileName,\r\n ALocalPath, TemporaryLocalFileName, ABaseThread);\r\n if FileExists(Result) then // if we successfully copied the remote file to .temp\r\n begin\r\n if FileExists(PathAppend(ALocalPath, LocalFileName)) then\r\n begin // if exists\r\n if SysUtils.DeleteFile(PathAppend(ALocalPath, LocalFileName)) then\r\n begin // if we deleted \r\n if RenameFile(Result, PathAppend(ALocalPath, LocalFileName)) then // if we renamed .temp to \r\n Result := PathAppend(ALocalPath, LocalFileName) // we can return \r\n else\r\n Result := ''; // failed rename, return blank\r\n end // try to delete \r\n else\r\n begin // so, we failed delete try renaming \r\n TemporaryLocalFileName2 := LocalFileName + RsPVTempFileNameExtension + '.bak'; // .temp.bak\r\n if FileExists(PathAppend(ALocalPath, TemporaryLocalFileName2)) then // if .temp.bak exists\r\n SysUtils.DeleteFile(PathAppend(ALocalPath, TemporaryLocalFileName2)); // get rid of it\r\n\r\n // rename to .temp.bak (you can't delete live file, but CAN rename in recent Win OS)\r\n if RenameFile(PathAppend(ALocalPath, LocalFileName), PathAppend(ALocalPath, TemporaryLocalFileName2)) then\r\n begin\r\n // try to rename .temp to \r\n if RenameFile(Result, PathAppend(ALocalPath, LocalFileName)) then\r\n begin\r\n // if rename .temp to successful set as return\r\n Result := PathAppend(ALocalPath, LocalFileName);\r\n // delete .temp.bak if possible - we don't care if fails -\r\n // leaving a backup of live exe is a \"feature\" anyway \r\n if FileExists(PathAppend(ALocalPath, TemporaryLocalFileName2)) then\r\n SysUtils.DeleteFile(PathAppend(ALocalPath, TemporaryLocalFileName2));\r\n end // rename .temp to \r\n else\r\n Result := ''; // rename of .temp to failed, return blank\r\n end // try to rename to .temp.bak\r\n else\r\n Result := ''; // rename of to .temp.bak failed, return blank\r\n end; // try renaming \r\n end // file exists\r\n else\r\n begin\r\n // if doesn't exist, just rename .temp to \r\n if RenameFile(Result, PathAppend(ALocalPath, LocalFileName)) then\r\n Result := PathAppend(ALocalPath, LocalFileName)\r\n else\r\n Result := ''; // if rename failed return blank...\r\n end; // doesn't exist\r\n end // .temp\r\n else\r\n Result := ''; // if we did not copy remote file to .tempreturn blank\r\nend;\r\n\r\nfunction TJvCustomProgramVersionLocation.LoadInstallerFileFromRemote(\r\n const ARemotePath, ARemoteFileName, ALocalPath, ALocalFileName: string;\r\n ABaseThread: TJvBaseThread): string;\r\nbegin\r\n Result := LoadFileFromRemote(ARemotePath, ARemoteFileName,\r\n ALocalPath, ALocalFileName, ABaseThread);\r\nend;\r\n\r\nfunction TJvCustomProgramVersionLocation.LoadVersionInfoFromRemote(\r\n const ALocalDirectory, ALocalVersionInfoFileName: string;\r\n ABaseThread: TJvBaseThread): string;\r\nbegin\r\nend;\r\n\r\nprocedure TJvCustomProgramVersionLocation.SetDownloadError(const Value: string);\r\nbegin\r\n FDownloadError := Value;\r\nend;\r\n\r\n//=== { TJvProgramVersionCustomFileBasedLocation } ===========================\r\n\r\nconstructor TJvCustomProgramVersionFileBasedLocation.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FVersionInfoLocationPathList := TStringList.Create;\r\nend;\r\n\r\ndestructor TJvCustomProgramVersionFileBasedLocation.Destroy;\r\nbegin\r\n FreeAndNil(FVersionInfoLocationPathList);\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJvCustomProgramVersionFileBasedLocation.GetVersionInfoLocationPathList: TStrings;\r\nbegin\r\n Result := FVersionInfoLocationPathList;\r\nend;\r\n\r\nprocedure TJvCustomProgramVersionFileBasedLocation.SetVersionInfoLocationPathList(Value: TStrings);\r\nbegin\r\n FVersionInfoLocationPathList.Assign(Value);\r\nend;\r\n\r\nfunction TJvCustomProgramVersionFileBasedLocation.LoadVersionInfoFromRemote(\r\n const ALocalDirectory, ALocalVersionInfoFileName: string;\r\n ABaseThread: TJvBaseThread): string;\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := 0 to VersionInfoLocationPathList.Count - 1 do\r\n begin\r\n Result := LoadFileFromRemote(VersionInfoLocationPathList[I], VersionInfoFileName,\r\n ALocalDirectory, ALocalVersionInfoFileName, ABaseThread);\r\n if Result <> '' then\r\n begin\r\n FValidLocationPath := VersionInfoLocationPathList[I];\r\n Exit;\r\n end;\r\n end;\r\n if Result = '' then\r\n begin\r\n Result := LoadFileFromRemote('', VersionInfoFileName,\r\n ALocalDirectory, ALocalVersionInfoFileName, ABaseThread);\r\n if Result <> '' then\r\n FValidLocationPath := '';\r\n end;\r\nend;\r\n\r\nfunction TJvCustomProgramVersionFileBasedLocation.LoadInstallerFileFromRemote(\r\n const ARemotePath, ARemoteFileName, ALocalPath, ALocalFileName: string;\r\n ABaseThread: TJvBaseThread): string;\r\nbegin\r\n Result := LoadFileFromRemote(ARemotePath, ARemoteFileName,\r\n ALocalPath, ALocalFileName, ABaseThread);\r\n if Result = '' then\r\n Result := LoadFileFromRemote(ValidLocationPath + ARemotePath, ARemoteFileName,\r\n ALocalPath, ALocalFileName, ABaseThread);\r\nend;\r\n\r\n//=== { TJvProgramVersionNetworkLocation } ===================================\r\n\r\nfunction TJvProgramVersionNetworkLocation.LoadFileFromRemoteInt(\r\n const ARemotePath, ARemoteFileName, ALocalPath, ALocalFileName: string;\r\n ABaseThread: TJvBaseThread): string;\r\n\r\n function FileExistsNoDir(AFileName: string): Boolean;\r\n begin\r\n Result := FileExists(AFileName) and not DirectoryExists(AFileName);\r\n end;\r\n\r\nbegin\r\n Result := '';\r\n if (DirectoryExists(ALocalPath) or (ALocalPath = '')) and\r\n (DirectoryExists(ARemotePath) or (ARemotePath = '')) then\r\n if FileExistsNoDir(PathAppend(ARemotePath, ARemoteFileName)) then\r\n if (ARemotePath = ALocalPath) and (ARemoteFileName = ALocalFileName) then\r\n Result := PathAppend(ARemotePath, ARemoteFileName)\r\n else\r\n if FileCopy(PathAppend(ARemotePath, ARemoteFileName), PathAppend(ALocalPath, ALocalFileName), True) then\r\n if FileExistsNoDir(PathAppend(ALocalPath, ALocalFileName)) then\r\n Result := PathAppend(ALocalPath, ALocalFileName)\r\n else\r\n if FileExistsNoDir(PathAppend(ALocalPath, ARemoteFileName)) then\r\n Result := PathAppend(ALocalPath, ARemoteFileName)\r\n else\r\n if FileExistsNoDir(PathAppend(ALocalPath, ExtractFileName(ARemotePath))) then\r\n Result := PathAppend(ALocalPath, ExtractFileName(ARemotePath));\r\nend;\r\n\r\n//=== { TJvProgramVersionInternetLocation } ==================================\r\n\r\nconstructor TJvCustomProgramVersionInternetLocation.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FProxySettings := TJvProgramVersionProxySettings.Create;\r\n FPasswordRequired := False;\r\n FPort := 80;\r\nend;\r\n\r\ndestructor TJvCustomProgramVersionInternetLocation.Destroy;\r\nbegin\r\n FreeAndNil(FProxySettings);\r\n inherited Destroy;\r\nend;\r\n\r\n//=== { TJvProgramVersionHTTPLocation } ======================================\r\n\r\nfunction TJvProgramVersionHTTPLocation.LoadFileFromRemoteInt(\r\n const ARemotePath, ARemoteFileName, ALocalPath, ALocalFileName: string;\r\n ABaseThread: TJvBaseThread): string;\r\nbegin\r\n Result := '';\r\n if Assigned(FOnLoadFileFromRemote) then\r\n Result := FOnLoadFileFromRemote(Self, ARemotePath, ARemoteFileName,\r\n ALocalPath, ALocalFileName);\r\nend;\r\n\r\n//=== { TJvProgramVersionFTPLocation } =======================================\r\n\r\nfunction TJvProgramVersionFTPLocation.LoadFileFromRemoteInt(\r\n const ARemotePath, ARemoteFileName, ALocalPath, ALocalFileName: string;\r\n ABaseThread: TJvBaseThread): string;\r\nbegin\r\n Result := '';\r\n if Assigned(FOnLoadFileFromRemote) then\r\n Result := FOnLoadFileFromRemote(Self, ARemotePath, ARemoteFileName,\r\n ALocalPath, ALocalFileName);\r\nend;\r\n\r\n//=== { TJvProgramVersionDatabaseLocation } ==================================\r\n\r\nfunction TJvProgramVersionDatabaseLocation.LoadFileFromRemoteInt(\r\n const ARemotePath, ARemoteFileName, ALocalPath, ALocalFileName: string;\r\n ABaseThread: TJvBaseThread): string;\r\nbegin\r\n Result := '';\r\n if Assigned(FOnLoadFileFromRemote) then\r\n Result := FOnLoadFileFromRemote(Self, ARemotePath, ARemoteFileName,\r\n ALocalPath, ALocalFileName);\r\nend;\r\n\r\nfunction TJvProgramVersionDatabaseLocation.LoadVersionInfoFromRemote(\r\n const ALocalDirectory, ALocalVersionInfoFileName: string;\r\n ABaseThread: TJvBaseThread): string;\r\nbegin\r\n Result := LoadFileFromRemote(SelectStatementVersion, '', ALocalDirectory,\r\n ALocalVersionInfoFileName, ABaseThread);\r\nend;\r\n\r\n//=== { TJvProgramVersionCheck } =============================================\r\n\r\nconstructor TJvProgramVersionCheck.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FRemoteProgramVersionHistory := TJvProgramVersionHistory.Create(Self);\r\n FRemoteProgramVersionHistory.IgnoreLastLoadTime := True;\r\n FVersionHistoryFileOptions := TJvProgramVersionHistoryAppStorageOptions.Create;\r\n FThread := TJvThread.Create(Self);\r\n FThread.ThreadName := Format('%s: %s',[ClassName, Name]);\r\n FThread.Exclusive := True;\r\n FThread.RunOnCreate := True;\r\n FThread.FreeOnTerminate := True;\r\n FThreadDialog := TJvThreadAnimateDialog.Create(Self);\r\n FThreadDialog.DialogOptions.ShowDialog := True;\r\n FThreadDialog.DialogOptions.ShowCancelButton := True;\r\n FThreadDialog.DialogOptions.ShowElapsedTime := True;\r\n TJvThreadAnimateDialogOptions(FThreadDialog.DialogOptions).CommonAvi := aviCopyFile;\r\n FThread.ThreadDialog := FThreadDialog;\r\n\r\n DeleteBeforeStore := True;\r\n IgnoreLastLoadTime := True;\r\n IgnoreProperties.Add('LocalInstallerFileName');\r\n IgnoreProperties.Add('LocalVersionInfoFileName');\r\n IgnoreProperties.Add('VersionHistoryAppStorage');\r\n IgnoreProperties.Add('UserOptions');\r\n IgnoreProperties.Add('VersionHistoryFileOptions');\r\n\r\n FUserOptions := [uoCheckFrequency, uoLocalDirectory,\r\n uoAllowedReleaseType, uoLocationType, uoLocationNetwork,\r\n uoLocationHTTP, uoLocationFTP, uoLocationDatabase];\r\n\r\n FAllowedReleaseType := prtProduction;\r\n FLocalInstallerFileName := '';\r\n FLocalVersionInfoFileName := RsPVDefaultVersioninfoFileName;\r\n FLocationType := pvltNetWork;\r\nend;\r\n\r\ndestructor TJvProgramVersionCheck.Destroy;\r\nbegin\r\n FreeAndNil(FVersionHistoryFileOptions);\r\n FreeAndNil(FRemoteProgramVersionHistory);\r\n FreeAndNil(FThreadDialog);\r\n FreeAndNil(FThread);\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvProgramVersionCheck.CheckLocalDirectory;\r\nbegin\r\n LocalDirectory := Trim(LocalDirectory);\r\n if LocalDirectory <> '' then\r\n if not DirectoryExists(LocalDirectory) then\r\n if not ForceDirectories(LocalDirectory) then\r\n LocalDirectory := '';\r\nend;\r\n\r\nfunction TJvProgramVersionCheck.CurrentApplicationName: string;\r\nvar\r\n FileVersionInfo: TJclFileVersionInfo;\r\nbegin\r\n FileVersionInfo := TJclFileVersionInfo.Create(ParamStr(0));\r\n try\r\n try\r\n Result := FileVersionInfo.ProductName;\r\n except\r\n Result := '';\r\n end;\r\n if Result = '' then\r\n Result := PathExtractFileNameNoExt(ParamStr(0));\r\n finally\r\n FileVersionInfo.Free;\r\n end;\r\nend;\r\n\r\nfunction TJvProgramVersionCheck.CurrentFileVersion: string;\r\nvar\r\n FileVersionInfo: TJclFileVersionInfo;\r\nbegin\r\n FileVersionInfo := TJclFileVersionInfo.Create(ParamStr(0));\r\n try\r\n try\r\n Result := FileVersionInfo.FileVersion;\r\n except\r\n Result := '';\r\n end;\r\n finally\r\n FileVersionInfo.Free;\r\n end;\r\nend;\r\n\r\nprocedure TJvProgramVersionCheck.DownloadInstallerFromRemote;\r\nbegin\r\n if Assigned(FExecuteVersionInfo) then\r\n begin\r\n FThreadExceptionClass := niL;\r\n FThreadExceptionAddr := nil;\r\n FThread.OnException := DownloadThreadOnException;\r\n FThread.OnExecute := DownloadThreadOnExecute;\r\n FThread.OnFinishAll := DownloadThreadOnFinishAll;\r\n FThread.ExecuteAndWait(self);\r\n if Assigned(FThreadExceptionClass) then\r\n raise FThreadExceptionClass.Create(FThreadExceptionMessage);\r\n end;\r\nend;\r\n\r\nprocedure TJvProgramVersionCheck.DownloadThreadOnException(Sender: TObject; E: Exception; EAddr: Pointer);\r\nbegin\r\n FThreadExceptionClass := ExceptClass(E.ClassType);\r\n FThreadExceptionMessage := E.Message;\r\n FThreadExceptionAddr := EAddr;\r\nend;\r\n\r\nprocedure TJvProgramVersionCheck.DownloadThreadOnExecute(Sender: TObject; Params: Pointer);\r\nbegin\r\n if Assigned(FExecuteVersionInfo) then\r\n begin\r\n FExecuteDownloadInstallFileName :=\r\n LoadRemoteInstallerFile(LocalDirectory, LocalInstallerFileName,\r\n FExecuteVersionInfo, FThread.LastThread);\r\n if (FExecuteDownloadInstallFileName <> '') and\r\n not FileExists(FExecuteDownloadInstallFileName) then\r\n FExecuteDownloadInstallFileName := '';\r\n end;\r\nend;\r\n\r\nprocedure TJvProgramVersionCheck.DownloadThreadOnFinishAll(Sender: TObject);\r\nbegin\r\n if Assigned(FThreadExceptionClass) then\r\n exit;\r\n if DownloadError <> '' then\r\n JvDSADialogs.MessageDlg(DownloadError, mtError, [mbOK], 0)\r\n else\r\n if FExecuteDownloadInstallFileName = '' then\r\n JvDSADialogs.MessageDlg(RsPVCFileDownloadNotSuccessful, mtError, [mbOK], 0)\r\n else\r\n if FExecuteOperation = rvoCopy then\r\n JvDSADialogs.MessageDlg(Format(RsPVCDownloadSuccessfulInstallManually,\r\n [FExecuteDownloadInstallFileName]), mtInformation, [mbOK], 0)\r\n else\r\n if JvDSADialogs.MessageDlg(RsPVCDownloadSuccessfullInstallNow,\r\n mtWarning, [mbYes, mbNo], 0) = mrYes then\r\n if ShellExecEx(FExecuteDownloadInstallFileName, FExecuteVersionInfo.LocalInstallerParams) then\r\n PostMessage(Application.Handle, WM_CLOSE, 0, 0)\r\n else\r\n JvDSADialogs.MessageDlg(RsPVCErrorStartingSetup, mtError, [mbOK], 0);\r\nend;\r\n\r\nprocedure TJvProgramVersionCheck.Execute;\r\nvar\r\n ReleaseType: TJvProgramReleaseType;\r\nbegin\r\n FExecuteVersionInfo := nil;\r\n if Assigned(Appstorage) and not Appstorage.PathExists(AppStoragePath) then\r\n StoreProperties;\r\n LoadProperties;\r\n if (LastCheck < Now - CheckFrequency) and (LocationTypesSupported <> []) then\r\n begin\r\n LastCheck := Now;\r\n if not DirectoryExists(LocalDirectory) then\r\n if (LocalDirectory <> '') and not ForceDirectories(LocalDirectory) then\r\n LocalDirectory := '';\r\n if LoadRemoteVersionHistoryFromFile(VersionHistoryFileOptions.FileFormat,\r\n LoadRemoteVersionInfoFile(LocalDirectory, LocalVersionInfoFileName)) then\r\n begin\r\n StoreProperties;\r\n StoreRemoteVersionHistoryToFile (VersionHistoryFileOptions.FileFormat,\r\n LoadRemoteVersionInfoFile(LocalDirectory, LocalVersionInfoFileName));\r\n if IsRemoteProgramVersionNewer then\r\n begin\r\n FExecuteOperation := GetRemoteVersionOperation(ReleaseType);\r\n FExecuteVersionInfo :=\r\n RemoteProgramVersionHistory.CurrentProgramVersion[ReleaseType];\r\n if FExecuteOperation in [rvoCopy, rvoCopyInstall] then\r\n DownloadInstallerFromRemote;\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJvProgramVersionCheck.GetAllowedRemoteProgramVersion: string;\r\nbegin\r\n if Assigned(RemoteProgramVersionHistory.AllowedCurrentProgramVersion(AllowedReleaseType)) then\r\n Result := RemoteProgramVersionHistory.AllowedCurrentProgramVersion(AllowedReleaseType).ProgramVersion\r\n else\r\n Result := '';\r\nend;\r\n\r\nfunction TJvProgramVersionCheck.GetAllowedRemoteProgramVersionReleaseType: string;\r\nbegin\r\n if Assigned(RemoteProgramVersionHistory.AllowedCurrentProgramVersion(AllowedReleaseType)) then\r\n Result := RemoteProgramVersionHistory.AllowedCurrentProgramVersion(AllowedReleaseType).ProgramVersionReleaseType\r\n else\r\n Result := '';\r\nend;\r\n\r\nfunction TJvProgramVersionCheck.GetDownloadError: string;\r\nbegin\r\n if Assigned(SelectedLocation) then\r\n Result := SelectedLocation.DownloadError\r\n else\r\n Result := '';\r\nend;\r\n\r\nfunction TJvProgramVersionCheck.GetLocationTypesSupported: TJvProgramVersionLocationTypes;\r\nbegin\r\n Result := [];\r\n if Assigned(FLocationNetwork) then\r\n Result := Result + [pvltNetWork];\r\n if Assigned(FLocationDatabase) then\r\n Result := Result + [pvltDatabase];\r\n if Assigned(FLocationHTTP) then\r\n Result := Result + [pvltHTTP];\r\n if Assigned(FLocationFTP) then\r\n Result := Result + [pvltFTP];\r\nend;\r\n\r\nfunction TJvProgramVersionCheck.GetRemoteVersionOperation(\r\n var ReleaseType: TJvProgramReleaseType): TJvRemoteVersionOperation;\r\nvar\r\n ParameterList: TJvParameterList;\r\n GroupParameter: TJvGroupBoxParameter;\r\n Parameter: TJvBaseParameter;\r\n I: TJvProgramReleaseType;\r\nbegin\r\n Result := rvoIgnore;\r\n ParameterList := TJvParameterList.Create(Self);\r\n try\r\n ParameterList.MaxWidth := 460;\r\n ParameterList.Messages.Caption :=\r\n Format(RsPVCDialogCaption, [CurrentApplicationName]);\r\n ParameterList.Messages.OkButton := RsPVCDialogExecuteButton;\r\n\r\n Parameter := TJvBaseParameter(TJvLabelParameter.Create(ParameterList));\r\n Parameter.SearchName := SParamNameNewVersionLabel;\r\n Parameter.Caption := Format(RsPVCNewVersionAvailable,\r\n [GetAllowedRemoteProgramVersionReleaseType, CurrentApplicationName]);\r\n Parameter.Width := 350;\r\n Parameter.Height := 45;\r\n ParameterList.AddParameter(Parameter);\r\n\r\n GroupParameter := TJvGroupBoxParameter.Create(ParameterList);\r\n GroupParameter.SearchName := SParamNameGroupBox;\r\n GroupParameter.Caption := RsPVCChooseWhichVersion;\r\n GroupParameter.Width := 350;\r\n GroupParameter.Height := 10;\r\n ParameterList.AddParameter(GroupParameter);\r\n\r\n for I := High(I) downto Low(I) do\r\n if (I <= AllowedReleaseType) and\r\n Assigned(RemoteProgramVersionHistory.CurrentProgramVersion[I]) then\r\n if CompareVersionNumbers(CurrentFileVersion,\r\n RemoteProgramVersionHistory.CurrentProgramVersion[I].ProgramVersion) > 0 then\r\n begin\r\n Parameter := TJvBaseParameter(TJvRadioButtonParameter.Create(ParameterList));\r\n Parameter.ParentParameterName := SParamNameGroupBox;\r\n Parameter.SearchName := SParamNameRadioButton + IntToStr(Ord(I));\r\n Parameter.Caption := RemoteProgramVersionHistory.CurrentProgramVersion[I].ProgramVersionInfo;\r\n Parameter.Width := 250;\r\n Parameter.AsBoolean := GroupParameter.Height <= 10;\r\n ParameterList.AddParameter(Parameter);\r\n\r\n Parameter := TJvBaseParameter(TJvButtonParameter.Create(ParameterList));\r\n Parameter.ParentParameterName := SParamNameGroupBox;\r\n Parameter.SearchName := SParamNameVersionButtonInfo + IntToStr(Ord(I));\r\n Parameter.Caption := RsPVInfoButtonCaption;\r\n Parameter.Width := 80;\r\n Parameter.Tag := Ord(I);\r\n TJvButtonParameter(Parameter).OnClick := VersionInfoButtonClick;\r\n ParameterList.AddParameter(Parameter);\r\n\r\n GroupParameter.Height := GroupParameter.Height + 25;\r\n end;\r\n Parameter := TJvBaseParameter(TJvRadioGroupParameter.Create(ParameterList));\r\n Parameter.SearchName := SParamNameOperation;\r\n Parameter.Caption := RsPVCChooseOperation;\r\n TJvRadioGroupParameter(Parameter).ItemList.Add(RsPVCOperationIgnore);\r\n TJvRadioGroupParameter(Parameter).ItemList.Add(RsPVCOperationDownloadOnly);\r\n TJvRadioGroupParameter(Parameter).ItemList.Add(RsPVCOperationDownloadInstall);\r\n TJvRadioGroupParameter(Parameter).ItemIndex := 2;\r\n Parameter.Width := 350;\r\n Parameter.Height := 79;\r\n ParameterList.AddParameter(Parameter);\r\n\r\n if ParameterList.ShowParameterDialog then\r\n begin\r\n case TJvRadioGroupParameter(ParameterList.ParameterByName(SParamNameOperation)).ItemIndex of\r\n 0:\r\n Result := rvoIgnore;\r\n 1:\r\n Result := rvoCopy;\r\n 2:\r\n Result := rvoCopyInstall;\r\n end;\r\n ReleaseType := prtProduction;\r\n for I := High(I) downto Low(I) do\r\n if IsRemoteProgramVersionReleaseTypeNewer(I) then\r\n begin\r\n Parameter := ParameterList.ParameterByName(SParamNameRadioButton + IntToStr(Ord(I)));\r\n if Assigned(Parameter) then\r\n if Parameter.AsBoolean then\r\n begin\r\n ReleaseType := I;\r\n Break;\r\n end;\r\n end;\r\n end;\r\n finally\r\n ParameterList.Free;\r\n end;\r\nend;\r\n\r\nfunction TJvProgramVersionCheck.IsRemoteProgramVersionNewer: Boolean;\r\nbegin\r\n Result := CompareVersionNumbers(CurrentFileVersion, GetAllowedRemoteProgramVersion) = 1;\r\nend;\r\n\r\nfunction TJvProgramVersionCheck.IsRemoteProgramVersionReleaseTypeNewer(AReleaseType: TJvProgramReleaseType): Boolean;\r\nbegin\r\n if Assigned(RemoteProgramVersionHistory.CurrentProgramVersion[AReleaseType]) then\r\n Result := CompareVersionNumbers(CurrentFileVersion,\r\n RemoteProgramVersionHistory.CurrentProgramVersion[AReleaseType].ProgramVersion) = 1\r\n else\r\n Result := False;\r\nend;\r\n\r\nprocedure TJvProgramVersionCheck.LoadData;\r\nbegin\r\n inherited LoadData;\r\n try\r\n LastCheck := AppStorage.ReadDateTime(AppStorage.ConcatPaths([AppStoragePath, SLastCheck]), LastCheck);\r\n except\r\n on e:EConvertError do\r\n LastCheck := 0;\r\n end;\r\nend;\r\n\r\nfunction TJvProgramVersionCheck.LoadRemoteInstallerFile(const ALocalDirectory, ALocalInstallerFileName: string;\r\n AProgramVersionInfo: TJvProgramVersionInfo; ABaseThread: TJvBaseThread): string;\r\nbegin\r\n if Assigned(AProgramVersionInfo) and (SelectedLocation <> nil) then\r\n begin\r\n Result := SelectedLocation.LoadInstallerFileFromRemote(AProgramVersionInfo.ProgramLocationPath,\r\n AProgramVersionInfo.ProgramLocationFileName, ALocalDirectory, ALocalInstallerFileName, ABaseThread);\r\n end\r\n else\r\n Result := '';\r\nend;\r\n\r\nfunction TJvProgramVersionCheck.LoadRemoteVersionInfoFile(const ALocalDirectory: string;\r\n const ALocalVersionInfoFileName: string): string;\r\nbegin\r\n if SelectedLocation <> nil then\r\n Result := SelectedLocation.LoadVersionInfoFromRemote(ALocalDirectory, ALocalVersionInfoFileName, nil)\r\n else\r\n Result := '';\r\nend;\r\n\r\nprocedure TJvProgramVersionCheck.Notification(AComponent: TComponent;\r\n Operation: TOperation);\r\nbegin\r\n inherited Notification(AComponent, Operation);\r\n\r\n if Operation = opRemove then\r\n if AComponent = FLocationNetwork then\r\n FLocationNetwork := nil\r\n else\r\n if AComponent = FLocationDatabase then\r\n FLocationDatabase := nil\r\n else\r\n if AComponent = FLocationHTTP then\r\n FLocationHTTP := nil\r\n else\r\n if AComponent = FLocationFTP then\r\n FLocationFTP := nil\r\nend;\r\n\r\nfunction TJvProgramVersionCheck.GetSelectedLocation: TJvCustomProgramVersionLocation;\r\nbegin\r\n case LocationType of\r\n pvltDatabase:\r\n Result := LocationDatabase;\r\n pvltHTTP:\r\n Result := LocationHTTP;\r\n pvltFTP:\r\n Result := LocationFTP;\r\n pvltNetwork:\r\n Result := LocationNetwork;\r\n else\r\n Result := nil;\r\n end\r\nend;\r\n\r\nprocedure TJvProgramVersionCheck.SetThreadInfo(const Info: string);\r\nbegin\r\n if Assigned(FThreadDialog) then\r\n FThreadDialog.DialogOptions.InfoText := Info;\r\nend;\r\n\r\nprocedure TJvProgramVersionCheck.SetUserOptions(Value: TJvProgramVersionUserOptions);\r\nbegin\r\n FUserOptions := Value;\r\n IgnoreProperties.AddDelete('CheckFrequency', (uoCheckFrequency in Value));\r\n IgnoreProperties.AddDelete('LocalDirectory', (uoLocalDirectory in Value));\r\n IgnoreProperties.AddDelete('AllowedReleaseType', (uoAllowedReleaseType in Value));\r\n IgnoreProperties.AddDelete('LocationType', (uoLocationType in Value));\r\n IgnoreProperties.AddDelete('LocationNetwork', (uoLocationNetwork in Value));\r\n IgnoreProperties.AddDelete('LocationHTTP', (uoLocationHTTP in Value));\r\n IgnoreProperties.AddDelete('LocationFTP', (uoLocationFTP in Value));\r\n IgnoreProperties.AddDelete('LocationDatabase', (uoLocationDatabase in Value));\r\nend;\r\n\r\nprocedure TJvProgramVersionCheck.SetVersionHistoryFileOptions(const Value: TJvProgramVersionHistoryAppStorageOptions);\r\nbegin\r\n FVersionHistoryFileOptions.Assign(Value);\r\nend;\r\n\r\nprocedure TJvProgramVersionCheck.ShowProgramVersionsDescription(const AFromVersion, AToVersion: string);\r\nvar\r\n ParameterList: TJvParameterList;\r\n Parameter: TJvMemoParameter;\r\nbegin\r\n ParameterList := TJvParameterList.Create(Self);\r\n try\r\n ParameterList.Messages.Caption := Format(RsPVCWhatNewInS, [CurrentApplicationName]);\r\n ParameterList.CancelButtonVisible := False;\r\n Parameter := TJvMemoParameter.Create(ParameterList);\r\n Parameter.SearchName := SParamNameMemo;\r\n Parameter.Caption := Format(RsPVCChangesBetween, [AFromVersion, AToVersion]);\r\n Parameter.Width := 340;\r\n Parameter.Height := 200;\r\n Parameter.AsString := RemoteProgramVersionHistory.GetVersionsDescription(AFromVersion, AToVersion);\r\n Parameter.Scrollbars := ssBoth;\r\n Parameter.ReadOnly := True;\r\n ParameterList.AddParameter(Parameter);\r\n ParameterList.ShowParameterDialog\r\n finally\r\n ParameterList.Free;\r\n end;\r\nend;\r\n\r\nprocedure TJvProgramVersionCheck.StoreData;\r\nbegin\r\n inherited StoreData;\r\n AppStorage.WriteDateTime(AppStorage.ConcatPaths([AppStoragePath, SLastCheck]), LastCheck);\r\nend;\r\n\r\nfunction TJvProgramVersionCheck.StoreRemoteVersionHistoryToFile(aFileFormat: TjvProgramVersionHistoryFileFormat; const\r\n aFilename: string): Boolean;\r\nvar\r\n VersionHistoryAppStorage: TJvCustomAppMemoryFileStorage;\r\nbegin\r\n Result := false;\r\n VersionHistoryAppStorage := CreateVersionHistoryAppstorage (aFileFormat);\r\n try\r\n RemoteProgramVersionHistory.AppStorage := VersionHistoryAppStorage;\r\n VersionHistoryAppStorage.FileName := aFileName;\r\n if VersionHistoryAppStorage.FileName <> '' then\r\n begin\r\n VersionHistoryAppStorage.ReadOnly := False;\r\n RemoteProgramVersionHistory.StoreProperties;\r\n VersionHistoryAppStorage.Flush;\r\n end;\r\n finally\r\n RemoteProgramVersionHistory.AppStorage := nil;\r\n VersionHistoryAppStorage.Free;\r\n end;\r\nend;\r\n\r\nfunction TJvProgramVersionCheck.LoadRemoteVersionHistoryFromFile(aFileFormat: TjvProgramVersionHistoryFileFormat; const\r\n aFileName: string): Boolean;\r\nvar\r\n VersionHistoryAppStorage: TJvCustomAppMemoryFileStorage;\r\nbegin\r\n VersionHistoryAppStorage := CreateVersionHistoryAppstorage (aFileFormat);\r\n try\r\n RemoteProgramVersionHistory.AppStorage := VersionHistoryAppStorage;\r\n VersionHistoryAppStorage.FileName := aFileName;\r\n if VersionHistoryAppStorage.FileName <> '' then\r\n begin\r\n RemoteProgramVersionHistory.LoadProperties;\r\n Result := true;\r\n end\r\n else\r\n Result := false;\r\n finally\r\n RemoteProgramVersionHistory.AppStorage := nil;\r\n VersionHistoryAppStorage.Free;\r\n end;\r\nend;\r\n\r\nprocedure TJvProgramVersionCheck.SetLocationDatabase(const Value: TJvProgramVersionDatabaseLocation);\r\nbegin\r\n ReplaceComponentReference(Self, Value, TComponent(FLocationDatabase));\r\nend;\r\n\r\nprocedure TJvProgramVersionCheck.SetLocationFTP(const Value: TJvProgramVersionFTPLocation);\r\nbegin\r\n ReplaceComponentReference(Self, Value, TComponent(FLocationFTP));\r\nend;\r\n\r\nprocedure TJvProgramVersionCheck.SetLocationHTTP(const Value: TJvProgramVersionHTTPLocation);\r\nbegin\r\n ReplaceComponentReference(Self, Value, TComponent(FLocationHTTP));\r\nend;\r\n\r\nprocedure TJvProgramVersionCheck.SetLocationNetwork(const Value: TJvProgramVersionNetworkLocation);\r\nbegin\r\n ReplaceComponentReference(Self, Value, TComponent(FLocationNetwork));\r\nend;\r\n\r\n\r\nprocedure TJvProgramVersionCheck.VersionInfoButtonClick(const ParameterList: TJvParameterList; const Parameter:\r\n TJvBaseParameter);\r\nvar\r\n I: TJvProgramReleaseType;\r\nbegin\r\n I := Low(I);\r\n Inc(I, Parameter.Tag);\r\n if Assigned(RemoteProgramVersionHistory.CurrentProgramVersion[I]) then\r\n ShowProgramVersionsDescription(CurrentFileVersion, RemoteProgramVersionHistory.CurrentProgramVersion[I].ProgramVersion);\r\nend;\r\n\r\n{$IFDEF USE_3RDPARTY_INDY}\r\n\r\n//=== { TJvProgramVersionHTTPLocationIndy } ==================================\r\n\r\nconstructor TJvProgramVersionHTTPLocationIndy.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FIdHTTP := TIdHTTP.Create(Self);\r\nend;\r\n\r\ndestructor TJvProgramVersionHTTPLocationIndy.Destroy;\r\nbegin\r\n FIdHttp.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJvProgramVersionHTTPLocationIndy.LoadFileFromRemoteInt(\r\n const ARemotePath, ARemoteFileName, ALocalPath, ALocalFileName: string;\r\n ABaseThread: TJvBaseThread): string;\r\nbegin\r\n Result := '';\r\n if Assigned(FOnLoadFileFromRemote) then\r\n Result := FOnLoadFileFromRemote(Self, ARemotePath, ARemoteFileName,\r\n ALocalPath, ALocalFileName)\r\n else\r\n Result := LoadFileFromRemoteIndy(ARemotePath, ARemoteFileName, ALocalPath,\r\n ALocalFileName, ABaseThread);\r\nend;\r\n\r\nfunction TJvProgramVersionHTTPLocationIndy.LoadFileFromRemoteIndy(\r\n const ARemotePath, ARemoteFileName, ALocalPath, ALocalFileName: string;\r\n ABaseThread: TJvBaseThread): string;\r\nvar\r\n ResultStream: TFileStream;\r\n ResultName: string;\r\n RemoteURL: string;\r\nbegin\r\n Result := '';\r\n if (DirectoryExists(ALocalPath) or (ALocalPath = '')) then\r\n if ALocalFileName = '' then\r\n ResultName := PathAppend(ALocalPath, ARemoteFileName)\r\n else\r\n ResultName := PathAppend(ALocalPath, ALocalFileName)\r\n else\r\n Exit;\r\n\r\n if (ARemotePath <> '') and (ARemotePath[Length(ARemotePath)] <> '/') then\r\n RemoteURL := ARemotePath + '/' + ARemoteFileName\r\n else\r\n RemoteURL := ARemotePath + ARemoteFileName;\r\n\r\n ResultStream := TFileStream.Create(ResultName, fmCreate);\r\n try\r\n {$IFDEF USE_3RDPARTY_INDY10}\r\n FIdHTTP.URL.URI := RemoteURL;\r\n if (FIdHTTP.URL.Port = '') and (Port <> 0) then\r\n begin\r\n FIdHTTP.URL.Port := IntToStr(Port);\r\n RemoteURL := FIdHTTP.URL.URI;\r\n end;\r\n {$ELSE}\r\n FIdHTTP.Port := Port;\r\n {$ENDIF USE_3RDPARTY_INDY10}\r\n FIdHTTP.ProxyParams.ProxyPort := ProxySettings.Port;\r\n FIdHTTP.ProxyParams.ProxyServer := ProxySettings.Server;\r\n FIdHTTP.ProxyParams.ProxyUsername := ProxySettings.UserName;\r\n FIdHTTP.ProxyParams.ProxyPassword := ProxySettings.Password;\r\n if UserName <> '' then\r\n FIdHTTP.Request.UserName := UserName;\r\n if Password <> '' then\r\n FIdHTTP.Request.Password := Password;\r\n FIdHTTP.Request.BasicAuthentication := PasswordRequired;\r\n try\r\n FIdHTTP.Get(RemoteURL, ResultStream)\r\n except\r\n on E: Exception do\r\n DownloadError := E.Message;\r\n end;\r\n finally\r\n ResultStream.Free;\r\n end;\r\n if FileExists(ResultName) and (DownloadError = '') then\r\n Result := ResultName;\r\nend;\r\n\r\n//=== { TJvProgramVersionFTPLocationIndy } ===================================\r\n\r\nconstructor TJvProgramVersionFTPLocationIndy.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FIdFTP := TIdFTP.Create(Self);\r\nend;\r\n\r\ndestructor TJvProgramVersionFTPLocationIndy.Destroy;\r\nbegin\r\n FIdFtp.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJvProgramVersionFTPLocationIndy.LoadFileFromRemoteInt(\r\n const ARemotePath, ARemoteFileName, ALocalPath, ALocalFileName: string;\r\n ABaseThread: TJvBaseThread): string;\r\nbegin\r\n Result := '';\r\n if Assigned(FOnLoadFileFromRemote) then\r\n Result := FOnLoadFileFromRemote(Self, ARemotePath, ARemoteFileName,\r\n ALocalPath, ALocalFileName)\r\n else\r\n Result := LoadFileFromRemoteIndy(ARemotePath, ARemoteFileName, ALocalPath,\r\n ALocalFileName, ABaseThread);\r\nend;\r\n\r\nfunction TJvProgramVersionFTPLocationIndy.LoadFileFromRemoteIndy(\r\n const ARemotePath, ARemoteFileName, ALocalPath, ALocalFileName: string;\r\n ABaseThread: TJvBaseThread): string;\r\nvar\r\n ResultStream: TFileStream;\r\n ResultName: string;\r\nbegin\r\n Result := '';\r\n if (DirectoryExists(ALocalPath) or (ALocalPath = '')) then\r\n if ALocalFileName = '' then\r\n ResultName := PathAppend(ALocalPath, ARemoteFileName)\r\n else\r\n ResultName := PathAppend(ALocalPath, ALocalFileName)\r\n else\r\n Exit;\r\n\r\n ResultStream := TFileStream.Create(ResultName, fmCreate);\r\n try\r\n FIdFTP.Port := Port;\r\n FIdFTP.ProxySettings.Port := ProxySettings.Port;\r\n FIdFTP.ProxySettings.Host := ProxySettings.Server;\r\n FIdFTP.ProxySettings.UserName := ProxySettings.UserName;\r\n FIdFTP.ProxySettings.Password := ProxySettings.Password;\r\n try\r\n if Copy(ARemotePath, Length(ARemotePath), 1) <> '/' then\r\n FIdFTP.Get(ARemotePath + '/' + ARemoteFileName, ResultStream)\r\n else\r\n FIdFTP.Get(ARemotePath + ARemoteFileName, ResultStream);\r\n except\r\n on E: Exception do\r\n DownloadError := E.Message;\r\n end;\r\n finally\r\n ResultStream.Free;\r\n end;\r\n if FileExists(ResultName) and (DownloadError = '') then\r\n Result := ResultName;\r\nend;\r\n\r\n{$ENDIF USE_3RDPARTY_INDY}\r\n\r\n{$IFDEF USE_3RDPARTY_ICS}\r\n\r\n//=== { TJvProgramVersionHTTPLocationIcs } ===================================\r\n\r\nconstructor TJvProgramVersionHTTPLocationIcs.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FHttpCli := THttpCli.Create(Self);\r\nend;\r\n\r\ndestructor TJvProgramVersionHTTPLocationIcs.Destroy;\r\nbegin\r\n FHttpCli.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJvProgramVersionHTTPLocationIcs.LoadFileFromRemoteInt(\r\n const ARemotePath, ARemoteFileName, ALocalPath, ALocalFileName: string;\r\n ABaseThread: TJvBaseThread): string;\r\nbegin\r\n Result := '';\r\n if Assigned(FOnLoadFileFromRemote) then\r\n Result := FOnLoadFileFromRemote(Self, ARemotePath, ARemoteFileName,\r\n ALocalPath, ALocalFileName)\r\n else\r\n Result := LoadFileFromRemoteIcs(ARemotePath, ARemoteFileName, ALocalPath,\r\n ALocalFileName, ABaseThread);\r\nend;\r\n\r\nfunction TJvProgramVersionHTTPLocationIcs.LoadFileFromRemoteIcs(\r\n const ARemotePath, ARemoteFileName, ALocalPath, ALocalFileName: string;\r\n ABaseThread: TJvBaseThread): string;\r\nvar\r\n ResultStream: TFileStream;\r\n ResultName: string;\r\nbegin\r\n Result := '';\r\n if (DirectoryExists(ALocalPath) or (ALocalPath = '')) then\r\n if ALocalFileName = '' then\r\n ResultName := PathAppend(ALocalPath, ARemoteFileName)\r\n else\r\n ResultName := PathAppend(ALocalPath, ALocalFileName)\r\n else\r\n Exit;\r\n\r\n ResultStream := TFileStream.Create(ResultName, fmCreate);\r\n try\r\n //FHttpCli.Port := Port;\r\n with FHttpCli do\r\n begin\r\n MultiThreaded := False;\r\n ProxyPort := inttostr(ProxySettings.Port);\r\n Proxy := ProxySettings.Server;\r\n ProxyUsername := ProxySettings.UserName;\r\n ProxyPassword := ProxySettings.Password;\r\n RcvdStream := ResultStream;\r\n if Copy(ARemotePath, Length(ARemotePath), 1) <> '/' then\r\n Url := ARemotePath + '/' + ARemoteFileName\r\n else\r\n Url := ARemotePath + ARemoteFileName;\r\n try\r\n Get\r\n except\r\n on E: EHttpException do\r\n DownloadError := Format(RsPVDownloadFailed, [IntToStr(StatusCode) + ' ' + ReasonPhrase]);\r\n else\r\n raise;\r\n end;\r\n end;\r\n finally\r\n ResultStream.Free;\r\n end;\r\n if FileExists(ResultName) and (DownloadError = '') then\r\n Result := ResultName;\r\nend;\r\n\r\n//=== { TJvProgramVersionFTPLocationIcs } ====================================\r\n\r\nconstructor TJvProgramVersionFTPLocationIcs.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FFtpClient := TFtpClient.Create(Self);\r\nend;\r\n\r\ndestructor TJvProgramVersionFTPLocationIcs.Destroy;\r\nbegin\r\n FFtpClient.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJvProgramVersionFTPLocationIcs.LoadFileFromRemoteInt(\r\n const ARemotePath, ARemoteFileName, ALocalPath, ALocalFileName: string;\r\n ABaseThread: TJvBaseThread): string;\r\nbegin\r\n Result := '';\r\n if Assigned(FOnLoadFileFromRemote) then\r\n Result := FOnLoadFileFromRemote(Self, ARemotePath, ARemoteFileName,\r\n ALocalPath, ALocalFileName)\r\n else\r\n Result := LoadFileFromRemoteIcs(ARemotePath, ARemoteFileName, ALocalPath,\r\n ALocalFileName, ABaseThread);\r\nend;\r\n\r\nfunction TJvProgramVersionFTPLocationIcs.LoadFileFromRemoteIcs(\r\n const ARemotePath, ARemoteFileName, ALocalPath, ALocalFileName: string;\r\n ABaseThread: TJvBaseThread): string;\r\nvar\r\n ResultStream: TFileStream;\r\n ResultName: string;\r\n P: Integer;\r\nbegin\r\n Result := '';\r\n if (DirectoryExists(ALocalPath) or (ALocalPath = '')) then\r\n if ALocalFileName = '' then\r\n ResultName := PathAppend(ALocalPath, ARemoteFileName)\r\n else\r\n ResultName := PathAppend(ALocalPath, ALocalFileName)\r\n else\r\n Exit;\r\n\r\n ResultStream := TFileStream.Create(ResultName, fmCreate);\r\n try\r\n // FFtpClient.Port := inttostr(Port);\r\n FFtpClient.DataPortRangeStart := Port;\r\n FFtpClient.DataPortRangeEnd := Port;\r\n FFtpClient.UserName := UserName;\r\n FFtpClient.Password := Password;\r\n with FFtpClient do\r\n begin\r\n // FtpClient1.HostName := HostNameEdit.Text;\r\n // FtpClient1.Port := PortEdit.Text;\r\n // FtpClient1.DataPortRangeStart := StrToInt(Trim(DataPortRangeStartEdit.Text));\r\n // FtpClient1.DataPortRangeEnd := Port;\r\n // FtpClient1.UserName := UserNameEdit.Text;\r\n // FtpClient1.Password := PasswordEdit.Text;\r\n // FtpClient1.Account := AccountEdit.Text;\r\n // FtpClient1.HostDirName := HostDirEdit.Text;\r\n // FtpClient1.HostFileName := HostFileEdit.Text;\r\n // FtpClient1.LocalFileName := LocalFileEdit.Text;\r\n // FtpClient1.Passive := PassiveCheckBox.Checked;\r\n // FtpClient1.Binary := BinaryCheckBox.Checked;\r\n MultiThreaded := False;\r\n Binary := True;\r\n ProxyPort := IntToStr(ProxySettings.Port);\r\n ProxyServer := ProxySettings.Server;\r\n // ProxyUsername := ProxySettings.UserName;\r\n // ProxyPassword := ProxySettings.Password;\r\n // Port := 'ftp';\r\n // RcvdStream := ResultStream;\r\n LocalFileName := ResultName;\r\n P := Pos('://', ARemotePath);\r\n if P > 0 then\r\n begin\r\n HostName := Copy(ARemotePath, P + 3, Length(ARemotePath) - P - 2);\r\n P := Pos('/', HostName);\r\n HostDirName := Copy(HostName, P + 1, Length(HostName) - P);\r\n HostName := Copy(HostName, 1, P - 1);\r\n end\r\n else\r\n begin\r\n P := Pos('/', ARemotePath);\r\n HostName := Copy(ARemotePath, 1, P - 1);\r\n HostDirName := Copy(ARemotePath, P + 1, Length(ARemotePath) - P);\r\n end;\r\n if Copy(HostDirName, Length(HostDirName), 1) = '/' then\r\n HostDirName := Copy(HostDirName, 1, Length(HostDirName) - 1);\r\n if HostDirName = '' then\r\n HostDirName := '/';\r\n if Copy(HostDirName, 1, 1) <> '/' then\r\n HostDirName := '/' + HostDirName;\r\n HostFileName := ARemoteFileName;\r\n try\r\n try\r\n if not Open then\r\n begin\r\n DownloadError := Format(RsPVFailedUnableToConnectTo, [HostName]);\r\n Exit;\r\n end;\r\n if not Get then\r\n begin\r\n DownloadError := Format(RsPVFailedUnableToGet, [HostDirName + '/' + HostFileName]);\r\n Exit;\r\n end;\r\n except\r\n on E: Exception do\r\n DownloadError := Format(RsPVDownloadFailed, [E.Message]);\r\n else\r\n raise;\r\n end;\r\n finally\r\n if Connected then\r\n Quit;\r\n end;\r\n end;\r\n finally\r\n ResultStream.Free;\r\n end;\r\n if FileExists(ResultName) and (DownloadError = '') then\r\n Result := ResultName;\r\nend;\r\n\r\n{$ENDIF USE_3RDPARTY_ICS}\r\n\r\n//=== { TJvProgramVersionProxySettings } =====================================\r\n\r\nconstructor TJvProgramVersionProxySettings.Create;\r\nbegin\r\n inherited Create;\r\n FPort := 80;\r\nend;\r\n\r\nconstructor TJvProgramVersionHistoryAppStorageOptions.Create;\r\nbegin\r\n inherited Create;\r\n FXMLOptions := TJvAppXMLStorageOptions.Create;\r\n FXMLOptions.WhiteSpaceReplacement := '_';\r\n FXMLOptions.UseOldItemNameFormat := False;\r\n FXMLOptions.SetAsString := True;\r\n FXMLOptions.FloatAsString := True;\r\n FXMLOptions.DefaultIfReadConvertError := True;\r\n FXMLOptions.DateTimeAsString := True;\r\n FINIOptions := TJvAppIniStorageOptions.Create;\r\n FINIOptions.SetAsString := True;\r\n FINIOptions.FloatAsString := True;\r\n FINIOptions.DefaultIfReadConvertError := True;\r\n FINIOptions.DateTimeAsString := True;\r\n FFileFormat := hffIni;\r\nend;\r\n\r\ndestructor TJvProgramVersionHistoryAppStorageOptions.Destroy;\r\nbegin\r\n FreeAndNil(FINIOptions);\r\n FreeAndNil(FXMLOptions);\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvProgramVersionHistoryAppStorageOptions.SetINIOptions(const Value: TJvAppIniStorageOptions);\r\nbegin\r\n INIOptions.Assign(Value);\r\nend;\r\n\r\nprocedure TJvProgramVersionHistoryAppStorageOptions.SetXMLOptions(const Value: TJvAppXMLStorageOptions);\r\nbegin\r\n FXMLOptions.Assign(Value);\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvProgressBar.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvProgressBar.PAS, released on 2001-02-28.\r\n\r\nThe Initial Developer of the Original Code is Sbastien Buysse [sbuysse att buypin dott com]\r\nPortions created by Sbastien Buysse are Copyright (C) 2001 Sbastien Buysse.\r\nAll Rights Reserved.\r\n\r\nContributor(s): Michael Beck [mbeck att bigfoot dott com]\r\n Michiel Koot [makoot att gmx dott net] (inverted property)\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvProgressBar.pas 13337 2012-06-13 08:07:01Z obones $\r\n\r\nunit JvProgressBar;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, Messages,\r\n CommCtrl,\r\n {$IFDEF RTL210_UP}\r\n ShlObj,\r\n {$ENDIF RTL210_UP}\r\n SysUtils, Classes, Graphics, Controls, Forms, ComCtrls,\r\n JvExComCtrls;\r\n\r\n{$IFNDEF RTL210_UP}\r\nconst\r\n SID_ITaskbarList = '{56FDF342-FD6D-11D0-958A-006097C9A090}';\r\n SID_ITaskbarList2 = '{602D4995-B13A-429B-A66E-1935E44F4317}';\r\n SID_ITaskbarList3 = '{EA1AFB91-9E28-4B86-90E9-9E9F8A5EEFAF}';\r\n SID_ITaskbarList4 = '{C43DC798-95D1-4BEA-9030-BB99E2983A1A}';\r\n\r\n CLSID_TaskbarList: TGUID = '{56FDF344-FD6D-11d0-958A-006097C9A090}';\r\n\r\ntype\r\n {$IFNDEF RTL185_UP}\r\n {$IFNDEF RTL150_UP}\r\n UInt64 = Int64; // kludge, use with caution\r\n {$ENDIF RTL150_UP}\r\n DWORDLONG = UInt64;\r\n {$EXTERNALSYM DWORDLONG}\r\n ULONGLONG = UInt64;\r\n {$EXTERNALSYM ULONGLONG}\r\n PULONGLONG = ^UInt64;\r\n {$EXTERNALSYM PULONGLONG}\r\n {$ENDIF RTL185_UP}\r\n\r\n ITaskbarList = interface(IUnknown)\r\n [SID_ITaskbarList]\r\n function HrInit: HRESULT; stdcall;\r\n function AddTab(hwnd: HWND): HRESULT; stdcall;\r\n function DeleteTab(hwnd: HWND): HRESULT; stdcall;\r\n function ActivateTab(hwnd: HWND): HRESULT; stdcall;\r\n function SetActiveAlt(hwnd: HWND): HRESULT; stdcall;\r\n end;\r\n \r\n ITaskbarList2 = interface(ITaskbarList)\r\n [SID_ITaskbarList2]\r\n function MarkFullscreenWindow(hwnd: HWND; fFullscreen: BOOL): HRESULT; stdcall;\r\n end;\r\n \r\ntype\r\n THUMBBUTTON = record \r\n dwMask: DWORD;\r\n iId: UINT;\r\n iBitmap: UINT;\r\n hIcon: HICON;\r\n szTip: packed array[0..259] of WCHAR;\r\n dwFlags: DWORD;\r\n end;\r\n tagTHUMBBUTTON = THUMBBUTTON;\r\n TThumbButton = THUMBBUTTON;\r\n PThumbButton = ^TThumbButton;\r\n\r\n// THUMBBUTTON flags\r\nconst\r\n THBF_ENABLED = $0000;\r\n THBF_DISABLED = $0001;\r\n THBF_DISMISSONCLICK = $0002;\r\n THBF_NOBACKGROUND = $0004;\r\n THBF_HIDDEN = $0008;\r\n THBF_NONINTERACTIVE = $10; \r\n// THUMBBUTTON mask\r\n THB_BITMAP = $0001;\r\n THB_ICON = $0002;\r\n THB_TOOLTIP = $0004;\r\n THB_FLAGS = $0008;\r\n THBN_CLICKED = $1800;\r\n\r\nconst\r\n TBPF_NOPROGRESS = 0; \r\n TBPF_INDETERMINATE = $1; \r\n TBPF_NORMAL = $2; \r\n TBPF_ERROR = $4; \r\n TBPF_PAUSED = $8; \r\n \r\n TBATF_USEMDITHUMBNAIL = $1; \r\n TBATF_USEMDILIVEPREVIEW = $2; \r\n \r\ntype\r\n ITaskbarList3 = interface(ITaskbarList2)\r\n [SID_ITaskbarList3]\r\n function SetProgressValue(hwnd: HWND; ullCompleted: ULONGLONG; \r\n ullTotal: ULONGLONG): HRESULT; stdcall;\r\n function SetProgressState(hwnd: HWND; tbpFlags: Integer): HRESULT; stdcall;\r\n function RegisterTab(hwndTab: HWND; hwndMDI: HWND): HRESULT; stdcall;\r\n function UnregisterTab(hwndTab: HWND): HRESULT; stdcall;\r\n function SetTabOrder(hwndTab: HWND; hwndInsertBefore: HWND): HRESULT; stdcall;\r\n function SetTabActive(hwndTab: HWND; hwndMDI: HWND; \r\n tbatFlags: Integer): HRESULT; stdcall;\r\n function ThumbBarAddButtons(hwnd: HWND; cButtons: UINT;\r\n pButton: PThumbButton): HRESULT; stdcall;\r\n function ThumbBarUpdateButtons(hwnd: HWND; cButtons: UINT;\r\n pButton: PThumbButton): HRESULT; stdcall;\r\n function ThumbBarSetImageList(hwnd: HWND; himl: HIMAGELIST): HRESULT; stdcall;\r\n function SetOverlayIcon(hwnd: HWND; hIcon: HICON;\r\n pszDescription: LPCWSTR): HRESULT; stdcall;\r\n function SetThumbnailTooltip(hwnd: HWND; pszTip: LPCWSTR): HRESULT; stdcall;\r\n function SetThumbnailClip(hwnd: HWND; var prcClip: TRect): HRESULT; stdcall;\r\n end;\r\n {$ENDIF !RTL210_UP}\r\n\r\ntype\r\n TJvTaskBarProgressState = (tpsNormal, tpsNoProgress, tpsIndeterminate, tpsError, tpsPaused);\r\n\r\n TJvBaseProgressBar = class(TGraphicControl)\r\n private\r\n FBlockSize: Integer;\r\n FSmooth: Boolean;\r\n FPosition: Integer;\r\n FMin: Integer;\r\n FMax: Integer;\r\n FOrientation: TProgressBarOrientation;\r\n FBarColor: TColor;\r\n FSteps: Integer;\r\n FOnChange: TNotifyEvent;\r\n FTaskBar: ITaskBarList3;\r\n FTaskBarTested: Boolean;\r\n FDisplayOnTaskbar: Boolean;\r\n FTaskbarState: TJvTaskBarProgressState;\r\n FParentForm: TCustomForm;\r\n\r\n procedure SetMax(Value: Integer);\r\n procedure SetMin(Value: Integer);\r\n procedure SetOrientation(Value: TProgressBarOrientation);\r\n procedure SetPosition(Value: Integer);\r\n procedure SetSmooth(const Value: Boolean);\r\n procedure SetBlockSize(const Value: Integer);\r\n procedure SetBarColor(const Value: TColor);\r\n procedure SetSteps(const Value: Integer);\r\n procedure SetDisplayOnTaskbar(const Value: Boolean);\r\n procedure SetTaskbarState(const Value: TJvTaskBarProgressState);\r\n protected\r\n // BarSize is the upper limit of the area covered by the progress bar\r\n // Derived classes should override this method to provide their own drawing\r\n // routine. The base class enmulates the look of the standard TProgressBar\r\n procedure DrawBar(ACanvas: TCanvas; BarSize: Integer); virtual;\r\n // GetMaxBarSize returns the maximum size of the bar in pixels.\r\n // For example, if the control has a 2 pixel border, when at Max,\r\n // GetMaxBarSize should return Self.Width - 4 when horizontal\r\n // and Self.Height - 4 when vertical. The default implementation returns\r\n // Self.Width when horizontal and Self.Height when vertical.\r\n function GetMaxBarSize: Integer; virtual;\r\n procedure Paint; override;\r\n procedure Change; virtual;\r\n procedure WndProc(var Message: TMessage); override;\r\n procedure SetParent(AParent: TWinControl); override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n procedure StepIt; virtual;\r\n procedure StepBy(Delta: Integer); virtual;\r\n public\r\n property Steps: Integer read FSteps write SetSteps default 10;\r\n property BarColor: TColor read FBarColor write SetBarColor default clHighlight;\r\n property BlockSize: Integer read FBlockSize write SetBlockSize default 10;\r\n property Max: Integer read FMax write SetMax default 100;\r\n property Min: Integer read FMin write SetMin default 0;\r\n property Orientation: TProgressBarOrientation read FOrientation write SetOrientation default pbHorizontal;\r\n property Position: Integer read FPosition write SetPosition default 0;\r\n property Smooth: Boolean read FSmooth write SetSmooth default False;\r\n property OnChange: TNotifyEvent read FOnChange write FOnChange;\r\n\r\n { For Windows >= 7 }\r\n property DisplayOnTaskbar: Boolean read FDisplayOnTaskbar write SetDisplayOnTaskbar default False;\r\n property TaskbarState: TJvTaskBarProgressState read FTaskbarState write SetTaskbarState default tpsNormal;\r\n published\r\n property Width default 150;\r\n end;\r\n\r\n { For Windows >= Vista }\r\n TJvProgressBarState = (pbsNormal, pbsError, pbsPaused);\r\n\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvProgressBar = class(TJvExProgressBar)\r\n private\r\n FFillColor: TColor;\r\n FMarquee: Boolean;\r\n FMarqueePaused: Boolean;\r\n FMarqueeDelay: Integer;\r\n FSmoothReverse: Boolean;\r\n FState: TJvProgressBarState;\r\n FDisplayOnTaskbar: Boolean;\r\n FTaskBar: ITaskBarList3;\r\n FTaskbarState: TJvTaskBarProgressState;\r\n FParentForm: TCustomForm;\r\n\r\n procedure SetFillColor(const Value: TColor);\r\n procedure SetMarquee(Value: Boolean);\r\n procedure SetMarqueePaused(Value: Boolean);\r\n procedure SetMarqueeDelay(Value: Integer);\r\n procedure SetSmoothReverse(Value: Boolean);\r\n procedure SetState(Value: TJvProgressBarState);\r\n procedure SetDisplayOnTaskbar(Value: Boolean);\r\n procedure SetTaskbarState(const Value: TJvTaskBarProgressState);\r\n procedure SetTaskbarPosition(Value: Integer);\r\n protected\r\n procedure CreateParams(var Params: TCreateParams); override;\r\n procedure CreateWnd; override;\r\n procedure WMEraseBkgnd(var Message: TWMEraseBkgnd); message WM_ERASEBKGND;\r\n procedure PbmSetPos(var Msg: TMessage); message PBM_SETPOS;\r\n procedure PbmStepIp(var Msg: TMessage); message PBM_STEPIT;\r\n procedure SetParent(AParent: TWinControl); override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n published\r\n property FillColor: TColor read FFillColor write SetFillColor default clHighlight;\r\n\r\n { For Windows >= XP }\r\n property Marquee: Boolean read FMarquee write SetMarquee default False;\r\n property MarqueePaused: Boolean read FMarqueePaused write SetMarqueePaused default False;\r\n property MarqueeDelay: Integer read FMarqueeDelay write SetMarqueeDelay default 25;\r\n { For Windows >= Vista }\r\n property SmoothReverse: Boolean read FSmoothReverse write SetSmoothReverse default False;\r\n property State: TJvProgressBarState read FState write SetState default pbsNormal;\r\n { For Windows >= 7 }\r\n property DisplayOnTaskbar: Boolean read FDisplayOnTaskbar write SetDisplayOnTaskbar default False;\r\n property TaskbarState: TJvTaskBarProgressState read FTaskbarState write SetTaskbarState default tpsNormal;\r\n\r\n property HintColor;\r\n property OnMouseEnter;\r\n property OnMouseLeave;\r\n property OnParentColorChange;\r\n property Color;\r\n property OnMouseDown;\r\n property OnMouseMove;\r\n property OnMouseUp;\r\n end;\r\n\r\n TJvBaseGradientProgressBar = class(TJvBaseProgressBar)\r\n private\r\n FBarColorFrom: TColor;\r\n FBarColorTo: TColor;\r\n FInverted: Boolean;\r\n procedure SetBarColorFrom(Value: TColor);\r\n procedure SetBarColorTo(const Value: TColor);\r\n procedure SetInverted(const Value: Boolean);\r\n public\r\n property BarColorFrom: TColor read FBarColorFrom write SetBarColorFrom;\r\n property BarColorTo: TColor read FBarColorTo write SetBarColorTo;\r\n property Inverted: Boolean read FInverted write SetInverted default False; // Michiel Koot: enabling inverted drawing behaviour.\r\n end;\r\n\r\n TJvCustomGradientProgressBar = class(TJvBaseGradientProgressBar)\r\n protected\r\n procedure DrawBar(ACanvas: TCanvas; BarSize: Integer); override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n end;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvGradientProgressBar = class(TJvCustomGradientProgressBar)\r\n published\r\n property BarColorFrom default clWhite;\r\n property BarColorTo default clBlack;\r\n property Max;\r\n property Min;\r\n property Orientation;\r\n property Position;\r\n property Smooth;\r\n property Inverted;\r\n\r\n property Align;\r\n property Anchors;\r\n property Color default clWindow;\r\n property Constraints;\r\n property DragKind;\r\n property DragCursor;\r\n property OnEndDock;\r\n property OnStartDock;\r\n property OnCanResize;\r\n property DragMode;\r\n property Hint;\r\n property ParentColor default False;\r\n property PopupMenu;\r\n property ParentShowHint;\r\n property ShowHint;\r\n\r\n property OnClick;\r\n property OnConstrainedResize;\r\n property OnContextPopup;\r\n property OnDblClick;\r\n property OnDragDrop;\r\n property OnDragOver;\r\n property OnEndDrag;\r\n property OnMouseDown;\r\n property OnMouseMove;\r\n property OnMouseUp;\r\n property OnMouseWheel;\r\n property OnMouseWheelDown;\r\n property OnMouseWheelUp;\r\n property OnStartDrag;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvProgressBar.pas $';\r\n Revision: '$Revision: 13337 $';\r\n Date: '$Date: 2012-06-13 10:07:01 +0200 (mer. 13 juin 2012) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n ComObj,\r\n JclSysInfo,\r\n JvJCLUtils, JvJVCLUtils;\r\n\r\nconst\r\n { For Windows >= XP }\r\n {$EXTERNALSYM PBS_MARQUEE}\r\n PBS_MARQUEE = $08;\r\n {$EXTERNALSYM PBM_SETMARQUEE}\r\n PBM_SETMARQUEE = WM_USER+10;\r\n\r\n { For Windows >= Vista }\r\n {$EXTERNALSYM PBS_SMOOTHREVERSE}\r\n PBS_SMOOTHREVERSE = $10;\r\n\r\n { For Windows >= Vista }\r\n {$EXTERNALSYM PBM_GETSTEP}\r\n PBM_GETSTEP = WM_USER+13;\r\n {$EXTERNALSYM PBM_GETBKCOLOR}\r\n PBM_GETBKCOLOR = WM_USER+14;\r\n {$EXTERNALSYM PBM_GETBARCOLOR}\r\n PBM_GETBARCOLOR = WM_USER+15;\r\n {$EXTERNALSYM PBM_SETSTATE}\r\n PBM_SETSTATE = WM_USER+16; { wParam = PBST_[State] (NORMAL, ERROR, PAUSED) }\r\n {$EXTERNALSYM PBM_GETSTATE}\r\n PBM_GETSTATE = WM_USER+17;\r\n\r\n { For Windows >= Vista }\r\n {$EXTERNALSYM PBST_NORMAL}\r\n PBST_NORMAL = $0001;\r\n {$EXTERNALSYM PBST_ERROR}\r\n PBST_ERROR = $0002;\r\n {$EXTERNALSYM PBST_PAUSED}\r\n PBST_PAUSED = $0003;\r\n\r\n cProgressStates: array[TJvProgressBarState] of Cardinal = (PBST_NORMAL, PBST_ERROR, PBST_PAUSED);\r\n\r\n cTBPFFlags: array[TJvTaskBarProgressState] of Integer = (TBPF_NORMAL, TBPF_NOPROGRESS, TBPF_INDETERMINATE, TBPF_ERROR, TBPF_PAUSED);\r\n\r\n//=== { TJvBaseProgressBar } =================================================\r\n\r\nconstructor TJvBaseProgressBar.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n ControlStyle := ControlStyle + [csOpaque];\r\n FMin := 0;\r\n FMax := 100;\r\n FOrientation := pbHorizontal;\r\n FBlockSize := 10;\r\n FBarColor := clHighlight;\r\n FSteps := 10;\r\n Width := 150;\r\n Height := GetSystemMetrics(SM_CYVSCROLL);\r\nend;\r\n\r\nprocedure TJvBaseProgressBar.Paint;\r\nvar\r\n ASize, APos: Integer;\r\nbegin\r\n if (Max - Min <= 0) or (Width <= 0) or (Height <= 0) then\r\n Exit;\r\n // calculate the size of the bar based on Min, Max, Position and Width or Height\r\n APos := Position;\r\n ASize := MulDiv(GetMaxBarSize, (APos - Min), (Max - Min));\r\n DrawBar(Canvas, ASize);\r\nend;\r\n\r\nprocedure TJvBaseProgressBar.SetMax(Value: Integer);\r\nbegin\r\n if Value < FMin then\r\n Value := FMin;\r\n if FPosition > Value then\r\n FPosition := Value;\r\n if FMax <> Value then\r\n begin\r\n FMax := Value;\r\n Change;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvBaseProgressBar.SetMin(Value: Integer);\r\nbegin\r\n if Value > FMax then\r\n Value := FMax;\r\n if FPosition < FMin then\r\n FPosition := FMin;\r\n if FMin <> Value then\r\n begin\r\n FMin := Value;\r\n Change;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvBaseProgressBar.SetOrientation(Value: TProgressBarOrientation);\r\nbegin\r\n if FOrientation <> Value then\r\n begin\r\n FOrientation := Value;\r\n if not (csLoading in ComponentState) then // fixes property load order\r\n SetBounds(Left, Top, Height, Width);\r\n end;\r\nend;\r\n\r\nprocedure TJvBaseProgressBar.SetParent(AParent: TWinControl);\r\nvar\r\n CurParent: TControl;\r\nbegin\r\n inherited SetParent(AParent);\r\n\r\n FParentForm := nil;\r\n CurParent := AParent;\r\n\r\n while not Assigned(FParentForm) and Assigned(CurParent) do\r\n begin\r\n if CurParent is TCustomForm then\r\n FParentForm := TCustomForm(CurParent); \r\n\r\n CurParent := CurParent.Parent;\r\n end; \r\nend;\r\n\r\nprocedure TJvBaseProgressBar.SetPosition(Value: Integer);\r\nbegin\r\n if Value > FMax then\r\n Value := FMax;\r\n if Value < FMin then\r\n Value := FMin;\r\n if FPosition <> Value then\r\n begin\r\n FPosition := Value;\r\n Change;\r\n Invalidate;\r\n\r\n if not (TaskbarState in [tpsNormal, tpsError, tpsPaused]) then\r\n TaskbarState := tpsNormal;\r\n\r\n if DisplayOnTaskbar and Assigned(FTaskbar) then\r\n begin\r\n {$IFDEF RTL185_UP}\r\n if Application.MainFormOnTaskbar then\r\n begin\r\n if Assigned(FParentForm) then\r\n FTaskBar.SetProgressValue(FParentForm.Handle, Value, Max);\r\n end\r\n else\r\n {$ENDIF RTL185_UP}\r\n begin\r\n FTaskBar.SetProgressValue(Application.Handle, Value, Max);\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvBaseProgressBar.SetSmooth(const Value: Boolean);\r\nbegin\r\n if FSmooth <> Value then\r\n begin\r\n FSmooth := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvBaseProgressBar.DrawBar(ACanvas: TCanvas; BarSize: Integer);\r\nvar\r\n R: TRect;\r\nbegin\r\n R := ClientRect;\r\n ACanvas.Brush.Color := Color;\r\n ACanvas.FillRect(R);\r\n DrawEdge(ACanvas.Handle, R, BDR_SUNKENOUTER, BF_ADJUST or BF_RECT);\r\n if BarSize = 0 then\r\n Exit;\r\n ACanvas.Brush.Color := BarColor;\r\n if Orientation = pbHorizontal then\r\n begin\r\n if Smooth then\r\n begin\r\n R.Right := R.Left + BarSize;\r\n InflateRect(R, -1, -1);\r\n if R.Right > Width - 2 then\r\n R.Right := Width - 2;\r\n if R.Right > R.Left then\r\n ACanvas.FillRect(R);\r\n end\r\n else\r\n begin\r\n R.Right := R.Left + Steps;\r\n InflateRect(R, -1, -1);\r\n while BarSize > 0 do\r\n begin\r\n if R.Right > Width - 3 then\r\n R.Right := Width - 3;\r\n if R.Left >= R.Right then\r\n Exit;\r\n ACanvas.FillRect(R);\r\n OffsetRect(R, RectWidth(R) + 2, 0);\r\n Dec(BarSize, RectWidth(R) + 2);\r\n end;\r\n end;\r\n end\r\n else\r\n begin\r\n if Smooth then\r\n begin\r\n R.Top := R.Bottom - BarSize;\r\n if R.Top < 2 then\r\n R.Top := 2;\r\n InflateRect(R, -1, -1);\r\n ACanvas.FillRect(R);\r\n end\r\n else\r\n begin\r\n OffsetRect(R, 0, Height - Steps - 2);\r\n R.Bottom := R.Top + Steps;\r\n InflateRect(R, -1, -1);\r\n while BarSize > 0 do\r\n begin\r\n if R.Top < 3 then\r\n R.Top := 3;\r\n ACanvas.FillRect(R);\r\n OffsetRect(R, 0, -Steps);\r\n Dec(BarSize, Steps);\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJvBaseProgressBar.GetMaxBarSize: Integer;\r\nbegin\r\n if Orientation = pbHorizontal then\r\n Result := Width\r\n else\r\n Result := Height;\r\nend;\r\n\r\nprocedure TJvBaseProgressBar.SetSteps(const Value: Integer);\r\nbegin\r\n if FSteps <> Value then\r\n begin\r\n FSteps := Value;\r\n if FSteps < 1 then\r\n FSteps := 1;\r\n end;\r\nend;\r\n\r\nprocedure TJvBaseProgressBar.SetTaskbarState(\r\n const Value: TJvTaskBarProgressState);\r\nbegin\r\n FTaskbarState := Value;\r\n\r\n if DisplayOnTaskbar and Assigned(FTaskbar) then\r\n begin\r\n {$IFDEF RTL185_UP}\r\n if Application.MainFormOnTaskbar then\r\n begin\r\n if Assigned(FParentForm) then\r\n FTaskbar.SetProgressState(FParentForm.Handle, cTBPFFlags[TaskbarState]);\r\n end\r\n else\r\n {$ENDIF RTL185_UP}\r\n begin\r\n FTaskbar.SetProgressState(Application.Handle, cTBPFFlags[TaskbarState]);\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvBaseProgressBar.StepIt;\r\nbegin\r\n StepBy(Steps);\r\nend;\r\n\r\nprocedure TJvBaseProgressBar.WndProc(var Message: TMessage);\r\nvar\r\n TaskBarList: IInterface;\r\nbegin\r\n if not (FTaskBarTested) and not Assigned(FTaskBar) then\r\n begin\r\n TaskBarList := CreateComObject(CLSID_TaskbarList);\r\n TaskBarList.QueryInterface(ITaskBarList3, FTaskBar);\r\n FTaskBarTested := True;\r\n end;\r\n\r\n inherited WndProc(Message);\r\nend;\r\n\r\nprocedure TJvBaseProgressBar.Change;\r\nbegin\r\n if Assigned(FOnChange) then\r\n FOnChange(Self);\r\nend;\r\n\r\nprocedure TJvBaseProgressBar.StepBy(Delta: Integer);\r\nbegin\r\n if Position + Delta > Max then\r\n Position := Max\r\n else\r\n if Position + Delta < Min then\r\n Position := Min\r\n else\r\n Position := Position + Delta;\r\nend;\r\n\r\nprocedure TJvBaseProgressBar.SetBlockSize(const Value: Integer);\r\nbegin\r\n if FBlockSize <> Value then\r\n begin\r\n FBlockSize := Value;\r\n if FBlockSize <= 0 then\r\n FBlockSize := 1;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvBaseProgressBar.SetDisplayOnTaskbar(const Value: Boolean);\r\nbegin\r\n FDisplayOnTaskbar := Value;\r\nend;\r\n\r\nprocedure TJvBaseProgressBar.SetBarColor(const Value: TColor);\r\nbegin\r\n if FBarColor <> Value then\r\n begin\r\n FBarColor := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\n//=== { TJvProgressBar } =====================================================\r\n\r\nconstructor TJvProgressBar.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FillColor := clHighlight;\r\n FMarqueeDelay := 25;\r\nend;\r\n\r\nprocedure TJvProgressBar.CreateParams(var Params: TCreateParams);\r\nbegin\r\n inherited CreateParams(Params);\r\n if Marquee and not (csDesigning in ComponentState) then\r\n Params.Style := Params.Style or PBS_MARQUEE;\r\n if SmoothReverse then\r\n Params.Style := Params.Style or PBS_SMOOTHREVERSE;\r\nend;\r\n\r\nprocedure TJvProgressBar.CreateWnd;\r\nvar\r\n TaskBarList: IInterface;\r\nbegin\r\n inherited CreateWnd;\r\n SendMessage(Handle, PBM_SETBARCOLOR, 0, ColorToRGB(FFillColor));\r\n if Marquee then\r\n SendMessage(Handle, PBM_SETMARQUEE, Ord(not MarqueePaused), LPARAM(MarqueeDelay));\r\n if State <> pbsNormal then\r\n SendMessage(Handle, PBM_SETSTATE, cProgressStates[State], 0);\r\n\r\n TaskBarList := CreateComObject(CLSID_TaskbarList);\r\n TaskBarList.QueryInterface(ITaskBarList3, FTaskBar);\r\nend;\r\n\r\nprocedure TJvProgressBar.PbmSetPos(var Msg: TMessage);\r\nbegin\r\n inherited;\r\n\r\n SetTaskbarPosition(Msg.WParam);\r\nend;\r\n\r\nprocedure TJvProgressBar.PbmStepIp(var Msg: TMessage);\r\nbegin\r\n inherited;\r\n\r\n SetTaskbarPosition(Position);\r\nend;\r\n\r\nprocedure TJvProgressBar.WMEraseBkgnd(var Message: TWMEraseBkgnd);\r\nbegin\r\n // Reduce flicker\r\n DefaultHandler(Message);\r\nend;\r\n\r\nprocedure TJvProgressBar.SetDisplayOnTaskbar(Value: Boolean);\r\nbegin\r\n FDisplayOnTaskbar := Value;\r\nend;\r\n\r\nprocedure TJvProgressBar.SetFillColor(const Value: TColor);\r\nbegin\r\n if FFillColor <> Value then\r\n begin\r\n FFillColor := Value;\r\n if HandleAllocated then\r\n begin\r\n SendMessage(Handle, PBM_SETBARCOLOR, 0, ColorToRGB(FFillColor));\r\n // (rom) Invalidate is not good enough\r\n Repaint;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvProgressBar.SetMarquee(Value: Boolean);\r\nbegin\r\n if Value <> FMarquee then\r\n begin\r\n FMarquee := Value;\r\n if HandleAllocated and not (csDesigning in ComponentState) then\r\n RecreateWnd;\r\n end;\r\nend;\r\n\r\nprocedure TJvProgressBar.SetMarqueePaused(Value: Boolean);\r\nbegin\r\n if Value <> FMarqueePaused then\r\n begin\r\n FMarqueePaused := Value;\r\n if Marquee and HandleAllocated and not (csDesigning in ComponentState) then\r\n SendMessage(Handle, PBM_SETMARQUEE, Ord(not MarqueePaused), LPARAM(MarqueeDelay));\r\n end;\r\nend;\r\n\r\nprocedure TJvProgressBar.SetParent(AParent: TWinControl);\r\nvar\r\n CurParent: TControl;\r\nbegin\r\n inherited SetParent(AParent);\r\n\r\n FParentForm := nil;\r\n CurParent := AParent;\r\n\r\n while not Assigned(FParentForm) and Assigned(CurParent) do\r\n begin\r\n if CurParent is TCustomForm then\r\n FParentForm := TCustomForm(CurParent); \r\n\r\n CurParent := CurParent.Parent;\r\n end; \r\nend;\r\n\r\nprocedure TJvProgressBar.SetMarqueeDelay(Value: Integer);\r\nbegin\r\n if Value < 0 then\r\n Value := 0;\r\n if Value <> FMarqueeDelay then\r\n begin\r\n FMarqueeDelay := Value;\r\n if Marquee and HandleAllocated and not (csDesigning in ComponentState) then\r\n SendMessage(Handle, PBM_SETMARQUEE, Ord(not MarqueePaused), LPARAM(MarqueeDelay));\r\n end;\r\nend;\r\n\r\nprocedure TJvProgressBar.SetSmoothReverse(Value: Boolean);\r\nbegin\r\n if Value <> FSmoothReverse then\r\n begin\r\n FSmoothReverse := Value;\r\n if HandleAllocated then\r\n RecreateWnd;\r\n end;\r\nend;\r\n\r\nprocedure TJvProgressBar.SetState(Value: TJvProgressBarState);\r\nbegin\r\n if Value <> FState then\r\n begin\r\n FState := Value;\r\n if HandleAllocated then\r\n SendMessage(Handle, PBM_SETSTATE, cProgressStates[State], 0);\r\n end;\r\nend;\r\n\r\nprocedure TJvProgressBar.SetTaskbarPosition(Value: Integer);\r\nbegin\r\n if not (TaskbarState in [tpsNormal, tpsError, tpsPaused]) then\r\n TaskbarState := tpsNormal;\r\n\r\n if DisplayOnTaskbar and Assigned(FTaskbar) then\r\n begin\r\n {$IFDEF RTL185_UP}\r\n if Application.MainFormOnTaskbar then\r\n begin\r\n if Assigned(FParentForm) then\r\n FTaskBar.SetProgressValue(FParentForm.Handle, Value, Max);\r\n end\r\n else\r\n {$ENDIF RTL185_UP}\r\n begin\r\n FTaskBar.SetProgressValue(Application.Handle, Value, Max);\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvProgressBar.SetTaskbarState(const Value: TJvTaskBarProgressState);\r\nbegin\r\n FTaskbarState := Value;\r\n\r\n if DisplayOnTaskbar and Assigned(FTaskbar) then\r\n begin\r\n {$IFDEF RTL185_UP}\r\n if Application.MainFormOnTaskbar then\r\n begin\r\n if Assigned(FParentForm) then\r\n FTaskbar.SetProgressState(FParentForm.Handle, cTBPFFlags[TaskbarState]);\r\n end\r\n else\r\n {$ENDIF RTL185_UP}\r\n begin\r\n FTaskbar.SetProgressState(Application.Handle, cTBPFFlags[TaskbarState]);\r\n end;\r\n end;\r\nend;\r\n\r\n//=== { TJvBaseGradientProgressBar } =========================================\r\n\r\nprocedure TJvBaseGradientProgressBar.SetBarColorFrom(Value: TColor);\r\nbegin\r\n if FBarColorFrom <> Value then\r\n begin\r\n FBarColorFrom := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvBaseGradientProgressBar.SetBarColorTo(const Value: TColor);\r\nbegin\r\n if FBarColorTo <> Value then\r\n begin\r\n FBarColorTo := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvBaseGradientProgressBar.SetInverted(const Value: Boolean);\r\nbegin\r\n if FInverted <> Value then\r\n begin\r\n FInverted := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\n//=== { TJvGradientProgressBar } =============================================\r\n\r\nconstructor TJvCustomGradientProgressBar.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FBarColorFrom := clWhite;\r\n FBarColorTo := clBlack;\r\n BlockSize := 6;\r\nend;\r\n\r\nprocedure TJvCustomGradientProgressBar.DrawBar(ACanvas: TCanvas; BarSize: Integer);\r\nvar\r\n R: TRect;\r\n LBlockSize: Double;\r\n I: Integer;\r\nbegin\r\n R := ClientRect;\r\n ACanvas.Brush.Color := Color;\r\n ACanvas.FillRect(R);\r\n DrawEdge(ACanvas.Handle, R, BDR_SUNKENOUTER, BF_ADJUST or BF_RECT);\r\n InflateRect(R, -1, -1);\r\n if Orientation = pbHorizontal then\r\n begin\r\n if not FInverted then\r\n R.Right := BarSize\r\n else\r\n R.Left := R.Right - BarSize;\r\n if R.Right > ClientWidth - 2 then\r\n R.Right := ClientWidth - 2;\r\n GradientFillRect(ACanvas, R, BarColorFrom, BarColorTo, fdLeftToRight, 255);\r\n end\r\n else\r\n begin\r\n if not FInverted then\r\n R.Top := R.Bottom - BarSize\r\n else\r\n R.Bottom := R.Top + BarSize;\r\n if R.Top < 2 then\r\n R.Top := 2;\r\n GradientFillRect(ACanvas, R, BarColorFrom, BarColorTo, fdBottomToTop, 255);\r\n end;\r\n if not Smooth then\r\n begin\r\n ACanvas.Pen.Color := Color;\r\n if Position > 0 then\r\n LBlockSize := (GetMaxBarSize * BlockSize - 4.0) / 100.0\r\n else\r\n LBlockSize := 0;\r\n I := 0;\r\n if Orientation = pbHorizontal then\r\n begin\r\n R := ClientRect;\r\n if not FInverted then\r\n begin\r\n InflateRect(R, -2, -2);\r\n R.Right := R.Left + Round(LBlockSize);\r\n while R.Left <= BarSize do\r\n begin\r\n ACanvas.MoveTo(R.Left, R.Top);\r\n ACanvas.LineTo(R.Left, R.Bottom);\r\n Inc(I);\r\n R := ClientRect;\r\n InflateRect(R, -2, -2);\r\n R.Right := R.Left + Round(LBlockSize);\r\n OffsetRect(R, Round(I * LBlockSize), 0);\r\n end;\r\n end\r\n else // Inverted horizontal\r\n begin\r\n InflateRect(R, 2, 2);\r\n R.Left := R.Right - Round(LBlockSize);\r\n while (BarSize <> 0) and (R.Left >= (GetMaxBarSize - BarSize)) do\r\n begin\r\n ACanvas.MoveTo(R.Right, R.Top);\r\n ACanvas.LineTo(R.Right, R.Bottom);\r\n Inc(I);\r\n R := ClientRect;\r\n InflateRect(R, 2, 2);\r\n R.Left := R.Right - Round(LBlockSize);\r\n OffsetRect(R, -Round(I * LBlockSize), 0);\r\n end;\r\n end;\r\n end\r\n else\r\n begin\r\n R := ClientRect;\r\n if not FInverted then\r\n begin\r\n InflateRect(R, -2, -2);\r\n R.Top := R.Bottom - Round(LBlockSize);\r\n while R.Bottom >= GetMaxBarSize - BarSize do\r\n begin\r\n ACanvas.MoveTo(R.Left, R.Bottom);\r\n ACanvas.LineTo(R.Right, R.Bottom);\r\n Inc(I);\r\n R := ClientRect;\r\n InflateRect(R, -2, -2);\r\n R.Top := R.Bottom - Round(LBlockSize);\r\n OffsetRect(R, 0, -Round(I * LBlockSize));\r\n end;\r\n end\r\n else // Inverted vertical\r\n begin\r\n InflateRect(R, 2, 2);\r\n R.Bottom := R.Top + Round(LBlockSize);\r\n while (BarSize <> 0) and (R.Top <= BarSize) do\r\n begin\r\n ACanvas.MoveTo(R.Left, R.Top);\r\n ACanvas.LineTo(R.Right, R.Top);\r\n Inc(I);\r\n R := ClientRect;\r\n InflateRect(R, 2, 2);\r\n R.Bottom := R.Top + Round(LBlockSize);\r\n OffsetRect(R, 0, Round(I * LBlockSize));\r\n end;\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvProgressComponent.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvDlg.PAS, released on 2002-07-04.\r\n\r\nThe Initial Developers of the Original Code are: Andrei Prygounkov \r\nCopyright (c) 1999, 2002 Andrei Prygounkov\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\nZinvob\r\nboerema\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\ncomponents : TProgressForm\r\ndescription : dialog components\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvProgressComponent.pas 13397 2012-08-16 17:23:19Z ahuser $\r\n\r\nunit JvProgressComponent;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, Messages, Controls, Forms, StdCtrls, ComCtrls,\r\n SysUtils, Classes,\r\n JvComponentBase;\r\n\r\ntype\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvProgressComponent = class(TJvComponent)\r\n private\r\n FForm: TForm;\r\n FProgressBar: TProgressBar;\r\n FLabel1: TLabel;\r\n FCaption: TCaption;\r\n FInfoLabel: TCaption;\r\n FOnShow: TNotifyEvent;\r\n FCancel: Boolean;\r\n FProgressMin: Integer;\r\n FProgressMax: Integer;\r\n FProgressStep: Integer;\r\n FProgressPosition: Integer;\r\n FException: Exception;\r\n FOnClose: TNotifyEvent;\r\n procedure SetCaption(ACaption: TCaption);\r\n procedure SetInfoLabel(ACaption: TCaption);\r\n procedure FormOnShow(Sender: TObject);\r\n procedure FormOnClose(Sender: TObject; var CloseAction: TCloseAction);\r\n procedure FormOnCancel(Sender: TObject);\r\n procedure SetProgressMax(const Value: Integer);\r\n procedure SetProgressMin(const Value: Integer);\r\n procedure SetProgressPosition(const Value: Integer);\r\n procedure SetProgressStep(const Value: Integer);\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n procedure Execute;\r\n procedure Hide;\r\n procedure ProgressStepIt;\r\n property Cancel: Boolean read FCancel;\r\n published\r\n property Caption: TCaption read FCaption write SetCaption;\r\n property InfoLabel: TCaption read FInfoLabel write SetInfoLabel;\r\n property ProgressMin: Integer read FProgressMin write SetProgressMin default 0;\r\n property ProgressMax: Integer read FProgressMax write SetProgressMax default 100;\r\n property ProgressStep: Integer read FProgressStep write SetProgressStep default 1;\r\n property ProgressPosition: Integer read FProgressPosition write SetProgressPosition default 0;\r\n property OnShow: TNotifyEvent read FOnShow write FOnShow;\r\n property OnClose: TNotifyEvent read FOnClose write FOnClose;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvProgressComponent.pas $';\r\n Revision: '$Revision: 13397 $';\r\n Date: '$Date: 2012-08-16 19:23:19 +0200 (jeu. 16 août 2012) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n JvConsts, JvResources, JvJCLUtils, JvComponent;\r\n\r\ntype\r\n TCMShowEvent = record\r\n Msg: Cardinal;\r\n {$IFDEF COMPILER16_UP}\r\n\tMsgFiller: TDWordFiller;\r\n {$ENDIF COMPILER16_UP}\r\n Unused: WPARAM;\r\n Instance: TJvProgressComponent;\r\n Result: LRESULT;\r\n end;\r\n\r\n TJvProgressForm = class(TJvForm)\r\n private\r\n procedure CMShowEvent(var Msg: TCMShowEvent); message CM_SHOWEVENT;\r\n end;\r\n\r\n//=== { TJvProgressComponent } ===============================================\r\n\r\nconstructor TJvProgressComponent.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FProgressMin := 0;\r\n FProgressMax := 100;\r\n FProgressStep := 1;\r\n FProgressPosition := 0;\r\nend;\r\n\r\ndestructor TJvProgressComponent.Destroy;\r\nbegin\r\n FForm.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvProgressComponent.Hide;\r\nbegin\r\n FForm.Free;\r\n FForm := nil;\r\nend;\r\n\r\nprocedure TJvProgressComponent.Execute;\r\nbegin\r\n if not Assigned(FForm) then\r\n begin\r\n // Use CreateNew in its BCB compatible version. And if we are\r\n // in design mode, the owner cannot be Self or the form would simply\r\n // not show up. Using Application as the owner solves this.\r\n if csDesigning in ComponentState then\r\n FForm := TJvProgressForm.CreateNew(Application, 1)\r\n else\r\n FForm := TJvProgressForm.CreateNew(Self, 1);\r\n end;\r\n try\r\n FForm.Caption := Caption;\r\n with FForm do\r\n begin\r\n ClientWidth := 307;\r\n ClientHeight := 98;\r\n BorderStyle := bsDialog;\r\n Position := poMainFormCenter;\r\n FormStyle := fsStayOnTop;\r\n Scaled := False;\r\n\r\n FProgressBar := TProgressBar.Create(FForm);\r\n end;\r\n with FProgressBar do\r\n begin\r\n Parent := FForm;\r\n if FProgressMin > Max then\r\n begin\r\n Max := FProgressMax;\r\n Min := FProgressMin;\r\n end\r\n else\r\n begin\r\n Min := FProgressMin;\r\n Max := FProgressMax;\r\n end;\r\n SetBounds(8, 38, 292, 18);\r\n if FProgressStep = 0 then\r\n FProgressStep := 1;\r\n Step := FProgressStep;\r\n Position := FProgressPosition;\r\n end;\r\n FLabel1 := TLabel.Create(FForm);\r\n with FLabel1 do\r\n begin\r\n Parent := FForm;\r\n Caption := InfoLabel;\r\n AutoSize := False;\r\n SetBounds(8, 8, 293, FForm.Canvas.TextHeight('Wq'));\r\n end;\r\n with TButton.Create(FForm) do\r\n begin\r\n Parent := FForm;\r\n Caption := RsButtonCancelCaption;\r\n SetBounds(116, 67, 75, 23);\r\n OnClick := FormOnCancel;\r\n end;\r\n FCancel := False;\r\n\r\n FForm.OnClose := FormOnClose;\r\n\r\n // Mantis 3430: In design mode, there is no main form, hence show\r\n // at the center, and in modal state to prevent the form from being\r\n // lost in the background.\r\n if csDesigning in ComponentState then\r\n begin\r\n FForm.Position := poScreenCenter;\r\n FForm.ShowModal;\r\n end\r\n else\r\n begin\r\n if Assigned(FOnShow) then\r\n begin\r\n FForm.OnShow := FormOnShow;\r\n FException := nil;\r\n FForm.ShowModal;\r\n if FException <> nil then\r\n raise FException;\r\n end\r\n else\r\n FForm.Show;\r\n end;\r\n finally\r\n // Force recreating the window every time it is shown at design time.\r\n if Assigned(FOnShow) or (csDesigning in ComponentState) then\r\n FreeAndNil(FForm);\r\n end;\r\nend;\r\n\r\nprocedure TJvProgressComponent.FormOnShow(Sender: TObject);\r\nbegin\r\n PostMessage(FForm.Handle, CM_SHOWEVENT, 0, LPARAM(Self));\r\nend;\r\n\r\nprocedure TJvProgressComponent.FormOnClose(Sender: TObject; var CloseAction: TCloseAction);\r\nbegin\r\n if Assigned(FOnClose) then\r\n FOnClose(Self);\r\nend;\r\n\r\nprocedure TJvProgressComponent.FormOnCancel(Sender: TObject);\r\nbegin\r\n FCancel := True;\r\n\r\n // Mantis 3430: In design mode, automatically hide the form upon cancellation\r\n if (csDesigning in ComponentState) and Assigned(FForm) then\r\n FForm.ModalResult := mrCancel;\r\nend;\r\n\r\nprocedure TJvProgressForm.CMShowEvent(var Msg: TCMShowEvent);\r\nbegin\r\n Application.ProcessMessages;\r\n try\r\n try\r\n Msg.Instance.FOnShow(Self);\r\n// (Owner as TJvProgressComponent).FOnShow(Self);\r\n except\r\n on E: Exception do\r\n (Owner as TJvProgressComponent).FException := AcquireExceptionObject;\r\n end;\r\n finally\r\n ModalResult := mrOk;\r\n end;\r\nend;\r\n\r\nprocedure TJvProgressComponent.SetCaption(ACaption: TCaption);\r\nbegin\r\n FCaption := ACaption;\r\n if FForm <> nil then\r\n FForm.Caption := FCaption;\r\nend;\r\n\r\nprocedure TJvProgressComponent.SetInfoLabel(ACaption: TCaption);\r\nbegin\r\n FInfoLabel := ACaption;\r\n if FForm <> nil then\r\n FLabel1.Caption := ACaption;\r\nend;\r\n\r\nprocedure TJvProgressComponent.SetProgressMax(const Value: Integer);\r\nbegin\r\n FProgressMax := Value;\r\n if FForm <> nil then\r\n FProgressBar.Max := FProgressMax;\r\nend;\r\n\r\nprocedure TJvProgressComponent.SetProgressMin(const Value: Integer);\r\nbegin\r\n FProgressMin := Value;\r\n if FForm <> nil then\r\n FProgressBar.Min := FProgressMin;\r\nend;\r\n\r\nprocedure TJvProgressComponent.SetProgressPosition(const Value: Integer);\r\nbegin\r\n FProgressPosition := Value;\r\n if FForm <> nil then\r\n FProgressBar.Position := FProgressPosition;\r\nend;\r\n\r\nprocedure TJvProgressComponent.SetProgressStep(const Value: Integer);\r\nbegin\r\n FProgressStep := Value;\r\n if FForm <> nil then\r\n FProgressBar.Step := FProgressStep;\r\nend;\r\n\r\nprocedure TJvProgressComponent.ProgressStepIt;\r\nbegin\r\n if FForm <> nil then\r\n begin\r\n Inc(FProgressPosition, ProgressStep);\r\n if ProgressPosition > ProgressMax then\r\n FProgressPosition := ProgressMax\r\n else\r\n if ProgressPosition < ProgressMin then\r\n FProgressPosition := ProgressMin\r\n else\r\n FProgressBar.StepIt;\r\n end;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvProgressDialog.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvProgressDialog.PAS, released on 2003-03-31.\r\n\r\nThe Initial Developer of the Original Code is Peter Thrnqvist.\r\nPortions created by Peter Thrnqvist are Copyright (c) 2003 Peter Thrnqvist.\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\n Ralf Kaiser - ScreenPosition property\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n- OnCancel is executed before the progress dialog is closed.\r\n\r\nDescription:\r\nA configurable progress dialog with optional image, optional cancel button,\r\nlabel and progressbar. Driven by a timer and an event on modal mode and by any\r\nuser loop in non-modal mode.\r\n\r\nHow it works:\r\nThis component is driven by the Interval property and the OnProgress event. You use Interval to set\r\nthe time interval between calls to OnProgress and you use OnProgress to update the\r\ndisplay of the dialog. You can set the properties of the component within OnProgress to\r\nchange the display except for Transparent. Since this component relies on the fact that you have\r\na class that can handle the OnProgress event, there are times when you can't use it easily\r\n(f ex displaying a progress dialog on program startup). Try TJvProgressComponent instead since it\r\nhas methods and properties you can call directly (ProgressStepIt is the most important) to update the dialog.\r\n\r\nMethods:\r\nExecute: Boolean - shows the dialog modally and returns true if the user did not cancel it. The user\r\n can cancel the dialog only when the Cancel button is visible by clicking it or hitting Esc key\r\nShowModal: Integer - same as Execute but returns mrCancel on cancel and mrOK otherwise\r\nShow - shows the dialog non-modally\r\nHide - hides (closes) the dialog if it is visible\r\n\r\nProperties:\r\nCancelled - returns true if the user has cancelled the dialog. Only used in non-modal mode\r\nMin - min value of progressbar at startup\r\nMax - max value of progressbar at startup\r\nPosition - position of progressbar at startup\r\nInterval - the number of miliseconds between calls to OnProgress. If Interval <= 0,\r\n OnProgress is called once. If Interval is still <= 0, the dialog is closed.\r\nCaption - caption of dialog. If caption is empty, the entire caption area is removed\r\nText - text of label above progressbar\r\nShowCancel - shows or hides the Cancel button. Note that the Cancel button is always visible when previewing in design mode:\r\n you wouldn't be able to close the dialog otherwise...\r\nImage - (optional) image to display in dialog. The image can be any size as the dialog\r\n auto-adjusts to it's size but you should keep them fairly small (say, less than 160x100 something)\r\n as large images doesn't look too good (IMO)\r\nTransparent - set to true if Image should be rendered transparently (this value cannot be changed in OnProgress)\r\nScreenPosition - Position of the dialog form (is now initially set to poScreenCenter), added 07/01/2009\r\n\r\nEvents:\r\nOnProgress: TJvProgressDialogEvent = procedure(Sender: TObject; var AContinue: Boolean) of object;\r\n - called every Interval so you can update the values of the component.\r\n To change the values in the dialog, assign new values to the properties of the component.\r\n You can change the values Min, Max, Position, Interval, Image, Caption and Text.\r\n Set AContinue to False to close the dialog.\r\nOnShow: TNotifyEvent = procedure(Sender: TObject) of object;\r\n - called just before the dialog is shown on screen\r\nOnClose: TNotifyEvent = procedure(Sender: TObject) of object;\r\n - called just after the dialog is closed\r\nOnCancel: TNotifyEvent = procedure(Sender: TObject) of object;\r\n - called if the user clicks the Cancel button. NB that this event is called *before* the dialog is closed\r\n\r\nNB!\r\n During execution of the dialog, the component properties reflect the\r\n *current* values in the dialog (as changed in OnProgress). After execution, the\r\n properties are reset to their original (\"start\") values.\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvProgressDialog.pas 13352 2012-06-14 09:21:26Z obones $\r\n\r\nunit JvProgressDialog;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, Classes, SysUtils, Graphics, Forms,\r\n JvBaseDlg;\r\n\r\ntype\r\n TJvProgressDialogEvent = procedure(Sender: TObject; var AContinue: Boolean) of object;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvProgressDialog = class(TJvCommonDialog)\r\n private\r\n FIMin: Integer;\r\n FIMax: Integer;\r\n FIPosition: Integer;\r\n FIInterval: Integer;\r\n FICaption: string;\r\n FIText: string;\r\n FIImage: TPicture;\r\n FMin: Integer;\r\n FMax: Integer;\r\n FPosition: Integer;\r\n FInterval: Integer;\r\n FCaption: string;\r\n FText: string;\r\n FShowCancel: Boolean;\r\n FTransparent: Boolean;\r\n FForm: TForm;\r\n FOnProgress: TJvProgressDialogEvent;\r\n FOnCancel: TNotifyEvent;\r\n FImage: TPicture;\r\n FOnClose: TNotifyEvent;\r\n FOnShow: TNotifyEvent;\r\n FCancelled: Boolean;\r\n FSmooth: Boolean;\r\n FScreenPosition: TPosition;\r\n procedure SetPicture(const Value: TPicture);\r\n procedure SetCaption(const Value: string);\r\n procedure SetInterval(const Value: Integer);\r\n procedure SetMax(const Value: Integer);\r\n procedure SetMin(const Value: Integer);\r\n procedure SetPosition(const Value: Integer);\r\n procedure SetShowCancel(const Value: Boolean);\r\n procedure SetText(const Value: string);\r\n protected\r\n procedure InternalDoClose(Sender: TObject; var Action: TCloseAction);\r\n procedure InternalDoProgress(Sender: TObject; var AMin, AMax, APosition,\r\n AInterval: Integer; var ACaption, ALabel: string; AnImage: TPicture;\r\n var AContinue: Boolean);\r\n procedure InternalDoCancel(Sender: TObject);\r\n procedure DoShow; override;\r\n procedure DoClose; override;\r\n procedure StoreValues;\r\n procedure RestoreValues;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n procedure InitValues(AMin, AMax, AInterval, APosition: Integer; const ACaption, AText: string);\r\n\r\n function Execute(ParentWnd: HWND): Boolean; overload; override;\r\n function ShowModal: Integer;\r\n\r\n // (p3) Show, Hide and Cancelled are used in non-modal mode)\r\n procedure Show;\r\n procedure Hide;\r\n // set most values at once\r\n property Cancelled: Boolean read FCancelled;\r\n property Form: TForm read FForm;\r\n published\r\n property Caption: string read FCaption write SetCaption;\r\n property Image: TPicture read FImage write SetPicture;\r\n property Interval: Integer read FInterval write SetInterval default 200;\r\n property Min: Integer read FMin write SetMin default 0;\r\n property Max: Integer read FMax write SetMax default 100;\r\n property Position: Integer read FPosition write SetPosition default 0;\r\n property ShowCancel: Boolean read FShowCancel write SetShowCancel default True;\r\n property Smooth: Boolean read FSmooth write FSmooth default False;\r\n property Text: string read FText write SetText;\r\n property Transparent: Boolean read FTransparent write FTransparent default False;\r\n property ScreenPosition: TPosition read FScreenPosition write FScreenPosition default poScreenCenter;\r\n property OnCancel: TNotifyEvent read FOnCancel write FOnCancel;\r\n property OnClose: TNotifyEvent read FOnClose write FOnClose;\r\n property OnProgress: TJvProgressDialogEvent read FOnProgress write FOnProgress;\r\n property OnShow: TNotifyEvent read FOnShow write FOnShow;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvProgressDialog.pas $';\r\n Revision: '$Revision: 13352 $';\r\n Date: '$Date: 2012-06-14 11:21:26 +0200 (jeu. 14 juin 2012) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n Controls,\r\n JvProgressForm, JvJVCLUtils;\r\n\r\nconstructor TJvProgressDialog.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FImage := TPicture.Create;\r\n FMin := 0;\r\n FMax := 100;\r\n FPosition := 0;\r\n FInterval := 200;\r\n FTransparent := False;\r\n FShowCancel := True;\r\n FScreenPosition := poScreenCenter;\r\nend;\r\n\r\ndestructor TJvProgressDialog.Destroy;\r\nbegin\r\n if Assigned(FForm) then\r\n FForm.Close; // OnClose sets CloseAction:=caFree and FForm = nil\r\n FreeAndNil(FImage);\r\n FreeAndNil(FIImage);\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvProgressDialog.InternalDoCancel(Sender: TObject);\r\nbegin\r\n if Assigned(FOnCancel) then\r\n FOnCancel(Self);\r\n FCancelled := True;\r\nend;\r\n\r\nprocedure TJvProgressDialog.InternalDoProgress(Sender: TObject; var AMin, AMax,\r\n APosition, AInterval: Integer; var ACaption, ALabel: string;\r\n AnImage: TPicture; var AContinue: Boolean);\r\nbegin\r\n if Assigned(FOnProgress) then\r\n begin\r\n // set new values\r\n SetPicture(AnImage);\r\n Min := AMin;\r\n Max := AMax;\r\n Interval := AInterval;\r\n Position := APosition;\r\n Caption := ACaption;\r\n Text := ALabel;\r\n // this is were the user gets a chance to alter any property values\r\n FOnProgress(Self, AContinue);\r\n // send back new values\r\n if AnImage <> nil then\r\n AnImage.Assign(Image);\r\n AMin := Min;\r\n AMax := Max;\r\n AInterval := Interval;\r\n APosition := Position;\r\n ACaption := Caption;\r\n ALabel := Text;\r\n end;\r\nend;\r\n\r\nfunction TJvProgressDialog.Execute(ParentWnd: HWND): Boolean;\r\nbegin\r\n Result := JvJVCLUtils.IsPositiveResult(ShowModal);\r\nend;\r\n\r\nprocedure TJvProgressDialog.SetPicture(const Value: TPicture);\r\nbegin\r\n if FImage <> nil then\r\n FImage.Assign(Value);\r\nend;\r\n\r\nprocedure TJvProgressDialog.DoClose;\r\nbegin\r\n if Assigned(FOnClose) then\r\n FOnClose(Self);\r\nend;\r\n\r\nprocedure TJvProgressDialog.DoShow;\r\nbegin\r\n if Assigned(FOnShow) then\r\n FOnShow(Self);\r\nend;\r\n\r\nfunction TJvProgressDialog.ShowModal: Integer;\r\nbegin\r\n Result := mrCancel;\r\n FCancelled := False;\r\n FreeAndNil(FForm);\r\n FForm := TfrmProgress.Create(nil);\r\n try\r\n FForm.Position := FScreenPosition;\r\n TfrmProgress(FForm).Init(Caption, Text, Image, Transparent, Min, Max, Position, Interval,\r\n ShowCancel or (csDesigning in ComponentState), Smooth, InternalDoProgress, InternalDoCancel);\r\n\r\n DoShow;\r\n StoreValues;\r\n try\r\n if FForm.ShowModal <> mrCancel then\r\n Result := mrOK;\r\n finally\r\n RestoreValues;\r\n DoClose;\r\n end;\r\n finally\r\n FreeAndNil(FForm);\r\n end;\r\nend;\r\n\r\nprocedure TJvProgressDialog.Hide;\r\nbegin\r\n if FForm <> nil then\r\n begin\r\n FForm.Close;\r\n Application.ProcessMessages;\r\n end;\r\nend;\r\n\r\nprocedure TJvProgressDialog.Show;\r\nbegin\r\n if FForm <> nil then\r\n begin\r\n FForm.Release;\r\n FForm := nil;\r\n end;\r\n FForm := TfrmProgress.Create(nil);\r\n FForm.OnClose := InternalDoClose;\r\n FForm.Position := FScreenPosition;\r\n FCancelled := False;\r\n TfrmProgress(FForm).Init(Caption, Text, Image, Transparent, Min, Max, Position,\r\n Interval, ShowCancel, Smooth, InternalDoProgress, InternalDoCancel);\r\n DoShow;\r\n StoreValues;\r\n FForm.Show;\r\nend;\r\n\r\nprocedure TJvProgressDialog.InternalDoClose(Sender: TObject;\r\n var Action: TCloseAction);\r\nbegin\r\n FForm := nil;\r\n Action := caFree;\r\n RestoreValues;\r\n DoClose;\r\nend;\r\n\r\nprocedure TJvProgressDialog.SetCaption(const Value: string);\r\nbegin\r\n if FForm <> nil then\r\n begin\r\n TfrmProgress(FForm).Caption := Value;\r\n TfrmProgress(FForm).Update;\r\n end;\r\n FCaption := Value;\r\nend;\r\n\r\nprocedure TJvProgressDialog.SetInterval(const Value: Integer);\r\nbegin\r\n if FForm <> nil then\r\n begin\r\n TfrmProgress(FForm).tmProgress.Interval := Value;\r\n TfrmProgress(FForm).Update;\r\n end;\r\n FInterval := Value;\r\nend;\r\n\r\nprocedure TJvProgressDialog.SetMax(const Value: Integer);\r\nbegin\r\n if FForm <> nil then\r\n begin\r\n TfrmProgress(FForm).pbProgress.Max := Value;\r\n TfrmProgress(FForm).Update;\r\n end;\r\n FMax := Value;\r\nend;\r\n\r\nprocedure TJvProgressDialog.SetMin(const Value: Integer);\r\nbegin\r\n if FForm <> nil then\r\n begin\r\n TfrmProgress(FForm).pbProgress.Min := Value;\r\n TfrmProgress(FForm).Update;\r\n end;\r\n FMin := Value;\r\nend;\r\n\r\nprocedure TJvProgressDialog.SetPosition(const Value: Integer);\r\nbegin\r\n if FForm <> nil then\r\n begin\r\n TfrmProgress(FForm).pbProgress.Position := Value;\r\n TfrmProgress(FForm).Update;\r\n end;\r\n FPosition := Value;\r\nend;\r\n\r\nprocedure TJvProgressDialog.SetShowCancel(const Value: Boolean);\r\nbegin\r\n if FForm <> nil then\r\n begin\r\n TfrmProgress(FForm).btnCancel.Visible := Value;\r\n TfrmProgress(FForm).Update;\r\n end;\r\n FShowCancel := Value;\r\nend;\r\n\r\nprocedure TJvProgressDialog.SetText(const Value: string);\r\nbegin\r\n if FForm <> nil then\r\n begin\r\n TfrmProgress(FForm).lblStatus.Caption := Value;\r\n TfrmProgress(FForm).Update;\r\n end;\r\n FText := Value;\r\nend;\r\n\r\nprocedure TJvProgressDialog.RestoreValues;\r\nbegin\r\n // reset values to original values\r\n SetPicture(FIImage);\r\n Min := FIMin;\r\n Max := FIMax;\r\n Interval := FIInterval;\r\n Position := FIPosition;\r\n Caption := FICaption;\r\n Text := FIText;\r\n FreeAndNil(FIImage);\r\nend;\r\n\r\nprocedure TJvProgressDialog.StoreValues;\r\nbegin\r\n // store original values\r\n FreeAndNil(FIImage);\r\n FIImage := TPicture.Create;\r\n FIImage.Assign(Image);\r\n FIMin := Min;\r\n FIMax := Max;\r\n FIInterval := Interval;\r\n FIPosition := Position;\r\n FICaption := Caption;\r\n FIText := Text;\r\nend;\r\n\r\nprocedure TJvProgressDialog.InitValues(AMin, AMax, AInterval, APosition: Integer;\r\n const ACaption, AText: string);\r\nbegin\r\n Min := AMin;\r\n Max := AMax;\r\n Position := APosition;\r\n Text := AText;\r\n Caption := ACaption;\r\n StoreValues;\r\nend;\r\n\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvProgressForm.dfm", "content": "object frmProgress: TfrmProgress\r\n Left = 411\r\n Top = 226\r\n BorderIcons = []\r\n BorderStyle = bsToolWindow\r\n Caption = 'Caption'\r\n ClientHeight = 165\r\n ClientWidth = 316\r\n Color = clBtnFace\r\n Font.Charset = DEFAULT_CHARSET\r\n Font.Color = clWindowText\r\n Font.Height = -11\r\n Font.Name = 'MS Sans Serif'\r\n Font.Style = []\r\n OldCreateOrder = False\r\n Position = poScreenCenter\r\n OnPaint = FormPaint\r\n DesignSize = (\r\n 316\r\n 165)\r\n PixelsPerInch = 96\r\n TextHeight = 13\r\n object imProgress: TImage\r\n Left = 16\r\n Top = 12\r\n Width = 48\r\n Height = 48\r\n AutoSize = True\r\n Enabled = False\r\n IncrementalDisplay = True\r\n Visible = False\r\n end\r\n object lblStatus: TLabel\r\n Left = 16\r\n Top = 70\r\n Width = 26\r\n Height = 13\r\n Caption = 'Label'\r\n end\r\n object pbProgress: TProgressBar\r\n Left = 16\r\n Top = 88\r\n Width = 284\r\n Height = 16\r\n Anchors = [akLeft, akTop, akRight]\r\n TabOrder = 0\r\n end\r\n object btnCancel: TButton\r\n Left = 224\r\n Top = 124\r\n Width = 75\r\n Height = 25\r\n Anchors = [akTop, akRight]\r\n Cancel = True\r\n Caption = 'Cancel'\r\n ModalResult = 2\r\n TabOrder = 1\r\n OnClick = btnCancelClick\r\n end\r\n object tmProgress: TTimer\r\n Enabled = False\r\n OnTimer = tmProgressTimer\r\n Left = 102\r\n Top = 18\r\n end\r\n object ActionList1: TActionList\r\n Left = 160\r\n Top = 24\r\n object Action1: TAction\r\n Caption = 'Action1'\r\n ShortCut = 32883\r\n OnExecute = Action1Execute\r\n end\r\n end\r\nend\r\n" }, { "path": "External/Jedi/Jvcl/run/JvProgressForm.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvProgressComponent.PAS, released on 2003-03-31.\r\n\r\nThe Initial Developer of the Original Code is Peter Thrnqvist.\r\nPortions created by Peter Thrnqvist are Copyright (c) 2003 Peter Thrnqvist.\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n\r\nDescription:\r\n- This form is used by JvProgressDialog.pas\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvProgressForm.pas 13138 2011-10-26 23:17:50Z jfudickar $\r\n\r\nunit JvProgressForm;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n SysUtils, Classes,\r\n Windows, Graphics, Controls, Forms, StdCtrls, ExtCtrls, ComCtrls, ActnList,\r\n JvComponent;\r\n\r\ntype\r\n TJvPrivateProgressUpdate = procedure(Sender: TObject;\r\n var AMin, AMax, APosition, AInterval: Integer;\r\n var ACaption, ALabel: string; AnImage: TPicture;\r\n var AContinue: Boolean) of object;\r\n\r\n TfrmProgress = class(TJvForm)\r\n pbProgress: TProgressBar;\r\n imProgress: TImage;\r\n lblStatus: TLabel;\r\n btnCancel: TButton;\r\n tmProgress: TTimer;\r\n ActionList1: TActionList;\r\n Action1: TAction;\r\n procedure tmProgressTimer(Sender: TObject);\r\n procedure btnCancelClick(Sender: TObject);\r\n procedure FormPaint(Sender: TObject);\r\n procedure Action1Execute(Sender: TObject);\r\n private\r\n FOnProgress: TJvPrivateProgressUpdate;\r\n FOnCancel: TNotifyEvent;\r\n FCancelled, FCanClose: Boolean;\r\n function DoProgress: Boolean;\r\n procedure DoCancel;\r\n procedure AdjustComponents;\r\n procedure RemoveCaption;\r\n procedure AddCaption;\r\n public\r\n class function Execute(const ACaption, ALabel: string;\r\n AImage: TPicture = nil; ATransparent: Boolean = False;\r\n AMin: Integer = 0; AMax: Integer = 100; APosition: Integer = 0;\r\n AInterval: Integer = 200; ShowCancel: Boolean = False; Smooth: Boolean = False;\r\n AOnProgress: TJvPrivateProgressUpdate = nil;\r\n AOnCancel: TNotifyEvent = nil): Boolean; overload;\r\n\r\n class function Execute(Frm: TfrmProgress; const ACaption, ALabel: string;\r\n AImage: TPicture = nil; ATransparent: Boolean = False;\r\n AMin: Integer = 0; AMax: Integer = 100; APosition: Integer = 0;\r\n AInterval: Integer = 200; ShowCancel: Boolean = False; Smooth: Boolean = False;\r\n AOnProgress: TJvPrivateProgressUpdate = nil;\r\n AOnCancel: TNotifyEvent = nil): Boolean; overload;\r\n {$IFDEF SUPPORTS_DEPRECATED}\r\n deprecated {$IFDEF SUPPORTS_DEPRECATED_DETAILS}'Use Execute(ACaption...) instead'{$ENDIF};\r\n {$ENDIF SUPPORTS_DEPRECATED}\r\n\r\n procedure Init(const ACaption, ALabel: string;\r\n AImage: TPicture = nil; ATransparent: Boolean = False;\r\n AMin: Integer = 0; AMax: Integer = 100; APosition: Integer = 0;\r\n AInterval: Integer = 200; ShowCancel: Boolean = False; Smooth: Boolean = False;\r\n AOnProgress: TJvPrivateProgressUpdate = nil;\r\n AOnCancel: TNotifyEvent = nil);\r\n\r\n function ShowModal: Integer; override;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvProgressForm.pas $';\r\n Revision: '$Revision: 13138 $';\r\n Date: '$Date: 2011-10-27 01:17:50 +0200 (jeu. 27 oct. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n Consts;\r\n\r\n{$R *.dfm}\r\n\r\nclass function TfrmProgress.Execute(const ACaption, ALabel: string;\r\n AImage: TPicture; ATransparent: Boolean; AMin, AMax, APosition, AInterval: Integer;\r\n ShowCancel, Smooth: Boolean; AOnProgress: TJvPrivateProgressUpdate; AOnCancel: TNotifyEvent): Boolean;\r\nvar\r\n Frm: TfrmProgress;\r\nbegin\r\n Frm := Self.Create(nil);\r\n try\r\n Frm.Init(ACaption, ALabel, AImage, ATransparent, AMin, AMax, APosition, AInterval,\r\n ShowCancel, Smooth, AOnProgress, AOnCancel);\r\n Result := Frm.ShowModal <> mrCancel\r\n finally\r\n Frm.Free;\r\n end;\r\nend;\r\n\r\nclass function TfrmProgress.Execute(Frm: TfrmProgress; const ACaption, ALabel: string;\r\n AImage: TPicture; ATransparent: Boolean; AMin, AMax, APosition, AInterval: Integer;\r\n ShowCancel, Smooth: Boolean; AOnProgress: TJvPrivateProgressUpdate; AOnCancel: TNotifyEvent): Boolean;\r\nvar\r\n DoModal: Boolean;\r\nbegin\r\n if Frm = nil then\r\n begin\r\n Frm := Self.Create(nil);\r\n DoModal := True;\r\n end\r\n else\r\n DoModal := False;\r\n try\r\n Frm.Init(ACaption, ALabel, AImage, ATransparent, AMin, AMax, APosition, AInterval,\r\n ShowCancel, Smooth, AOnProgress, AOnCancel);\r\n\r\n if DoModal then\r\n Result := Frm.ShowModal <> mrCancel\r\n else\r\n begin\r\n Result := False;\r\n Frm.Show;\r\n end;\r\n finally\r\n if DoModal then\r\n Frm.Free;\r\n end;\r\nend;\r\n\r\nprocedure TfrmProgress.Init(const ACaption, ALabel: string;\r\n AImage: TPicture; ATransparent: Boolean; AMin, AMax, APosition, AInterval: Integer;\r\n ShowCancel, Smooth: Boolean; AOnProgress: TJvPrivateProgressUpdate; AOnCancel: TNotifyEvent);\r\nbegin\r\n Caption := ACaption;\r\n lblStatus.Caption := ALabel;\r\n pbProgress.Min := AMin;\r\n pbProgress.Max := AMax;\r\n pbProgress.Position := APosition;\r\n pbProgress.Smooth := Smooth;\r\n FOnProgress := AOnProgress;\r\n imProgress.Picture := AImage;\r\n imProgress.Transparent := ATransparent;\r\n tmProgress.Interval := AInterval;\r\n tmProgress.Enabled := AInterval > 0;\r\n btnCancel.Visible := ShowCancel;\r\n FCanClose := ShowCancel;\r\n btnCancel.Caption := SCancelButton;\r\n FOnCancel := AOnCancel;\r\n AdjustComponents;\r\nend;\r\n\r\nfunction TfrmProgress.DoProgress: Boolean;\r\nvar\r\n AMin, AMax, APosition, AInterval: Integer;\r\n ACaption, ALabel: string;\r\nbegin\r\n Result := False;\r\n if FCancelled then\r\n Exit;\r\n Result := True;\r\n tmProgress.Enabled := False;\r\n if Assigned(FOnProgress) then\r\n begin\r\n AMin := pbProgress.Min;\r\n AMax := pbProgress.Max;\r\n APosition := pbProgress.Position;\r\n AInterval := tmProgress.Interval;\r\n ACaption := Caption;\r\n ALabel := lblStatus.Caption;\r\n FOnProgress(Self, AMin, AMax, APosition, AInterval, ACaption, ALabel, imProgress.Picture, Result);\r\n pbProgress.Min := AMin;\r\n pbProgress.Max := AMax;\r\n pbProgress.Position := APosition;\r\n tmProgress.Interval := AInterval;\r\n tmProgress.Enabled := AInterval > 0;\r\n Caption := ACaption;\r\n lblStatus.Caption := ALabel;\r\n AdjustComponents;\r\n Update;\r\n end;\r\n if not tmProgress.Enabled or not Result then\r\n begin\r\n ModalResult := mrCancel;\r\n Close;\r\n end;\r\nend;\r\n\r\nprocedure TfrmProgress.AddCaption;\r\nvar\r\n WindowLong: Cardinal;\r\nbegin\r\n WindowLong := GetWindowLong(Handle, GWL_STYLE);\r\n if WindowLong and WS_CAPTION = 0 then\r\n begin\r\n SetWindowLong(Handle, GWL_STYLE, WindowLong or WS_CAPTION);\r\n BorderStyle := bsToolWindow;\r\n Height := Height + GetSystemMetrics(SM_CYCAPTION);\r\n Top := Top + GetSystemMetrics(SM_CYCAPTION);\r\n Update;\r\n end;\r\nend;\r\n\r\nprocedure TfrmProgress.RemoveCaption;\r\nvar\r\n WindowLong: Cardinal;\r\nbegin\r\n WindowLong := GetWindowLong(Handle, GWL_STYLE);\r\n if WindowLong and WS_CAPTION = WS_CAPTION then\r\n begin\r\n BorderStyle := bsDialog;\r\n SetWindowLong(Handle, GWL_STYLE, WindowLong and not WS_CAPTION);\r\n Height := Height - GetSystemMetrics(SM_CYCAPTION);\r\n Top := Top - GetSystemMetrics(SM_CYCAPTION);\r\n Update;\r\n end;\r\nend;\r\n\r\nfunction TfrmProgress.ShowModal: Integer;\r\nbegin\r\n // (p3) put topmost but only if not debugging\r\n {$WARNINGS OFF}\r\n if DebugHook = 0 then\r\n {$WARNINGS ON}\r\n SetWindowPos(Handle, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOMOVE or SWP_NOSIZE);\r\n if not tmProgress.Enabled then\r\n DoProgress; // call at least once\r\n Result := inherited ShowModal;\r\nend;\r\n\r\nprocedure TfrmProgress.tmProgressTimer(Sender: TObject);\r\nbegin\r\n if not FCancelled and not DoProgress or not tmProgress.Enabled then\r\n begin\r\n ModalResult := mrOk;\r\n Close;\r\n end;\r\nend;\r\n\r\nprocedure TfrmProgress.btnCancelClick(Sender: TObject);\r\nbegin\r\n FCancelled := True;\r\n DoCancel;\r\nend;\r\n\r\nprocedure TfrmProgress.AdjustComponents;\r\nvar\r\n Offset: Integer;\r\nbegin\r\n if Caption = '' then\r\n RemoveCaption\r\n else\r\n AddCaption;\r\n if (imProgress.Picture = nil) or (imProgress.Picture.Graphic = nil) or\r\n imProgress.Picture.Graphic.Empty then\r\n Offset := 12\r\n else\r\n begin\r\n Offset := imProgress.Top + imProgress.Height + 12;\r\n if ClientWidth - imProgress.Left * 2 < imProgress.Width then\r\n ClientWidth := imProgress.Width + imProgress.Left * 2;\r\n end;\r\n lblStatus.Top := Offset;\r\n Offset := lblStatus.Top + lblStatus.Height + 8;\r\n pbProgress.Top := Offset;\r\n Offset := pbProgress.Top + pbProgress.Height + 16;\r\n if btnCancel.Visible then\r\n begin\r\n btnCancel.Top := pbProgress.Top + pbProgress.Height + 16;\r\n Offset := btnCancel.Top + btnCancel.Height + 16;\r\n end;\r\n ClientHeight := Offset;\r\nend;\r\n\r\nprocedure TfrmProgress.DoCancel;\r\nbegin\r\n if Assigned(FOnCancel) then\r\n FOnCancel(Self);\r\n ModalResult := mrCancel;\r\n Close;\r\nend;\r\n\r\nprocedure TfrmProgress.FormPaint(Sender: TObject);\r\nbegin\r\n if (imProgress.Picture.Graphic <> nil) and not imProgress.Picture.Graphic.Empty then\r\n Canvas.Draw(imProgress.Left, imProgress.Top, imProgress.Picture.Graphic);\r\nend;\r\n\r\nprocedure TfrmProgress.Action1Execute(Sender: TObject);\r\nbegin\r\n if FCanClose then\r\n DoCancel;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvProgressUtils.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvPrgrss.PAS, released on 2002-07-04.\r\n\r\nThe Initial Developers of the Original Code are: Fedor Koshevnikov, Igor Pavluk and Serge Korolev\r\nCopyright (c) 1997, 1998 Fedor Koshevnikov, Igor Pavluk and Serge Korolev\r\nCopyright (c) 2001,2002 SGB Software\r\nAll Rights Reserved.\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvProgressUtils.pas 12461 2009-08-14 17:21:33Z obones $\r\n\r\nunit JvProgressUtils;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Controls, ComCtrls, SysUtils, Classes;\r\n\r\n\r\n\r\nprocedure RegisterProgressControl(AClass: TControlClass;\r\n const MaxPropName, MinPropName, ProgressPropName: string);\r\nprocedure UnRegisterProgressControl(AClass: TControlClass);\r\nfunction SupportsProgressControl(Control: TControl): Boolean;\r\n\r\nprocedure SetProgressMax(Control: TControl; MaxValue: Longint);\r\nprocedure SetProgressMin(Control: TControl; MinValue: Longint);\r\nprocedure SetProgressValue(Control: TControl; ProgressValue: Longint);\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvProgressUtils.pas $';\r\n Revision: '$Revision: 12461 $';\r\n Date: '$Date: 2009-08-14 19:21:33 +0200 (ven. 14 août 2009) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n TypInfo;\r\n\r\ntype\r\n TProgressProp = (ppMax, ppMin, ppProgress);\r\n\r\n PProgressData = ^TProgressData;\r\n TProgressData = record\r\n ControlClass: TControlClass;\r\n MaxProperty: string{$IFNDEF RTL200_UP}[63]{$ENDIF ~RTL200_UP};\r\n MinProperty: string{$IFNDEF RTL200_UP}[63]{$ENDIF ~RTL200_UP};\r\n ProgressProperty: string{$IFNDEF RTL200_UP}[63]{$ENDIF ~RTL200_UP};\r\n end;\r\n\r\n TJvProgressList = class(TList)\r\n public\r\n constructor Create;\r\n destructor Destroy; override;\r\n procedure Add(AClass: TControlClass;\r\n const MaxPropName, MinPropName, ProgressPropName: string);\r\n function FindClass(AClass: TControlClass): Integer;\r\n procedure Remove(AClass: TControlClass);\r\n function SetControlProperty(Control: TControl; Prop: TProgressProp;\r\n Value: Longint): Boolean;\r\n end;\r\n\r\nconstructor TJvProgressList.Create;\r\nbegin\r\n inherited Create;\r\n Add(TProgressBar, 'Max', 'Min', 'Position');\r\nend;\r\n\r\ndestructor TJvProgressList.Destroy;\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := 0 to Count - 1 do\r\n Dispose(PProgressData(Items[I]));\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvProgressList.Add(AClass: TControlClass;\r\n const MaxPropName, MinPropName, ProgressPropName: string);\r\nvar\r\n NewRec: PProgressData;\r\nbegin\r\n New(NewRec);\r\n with NewRec^ do\r\n begin\r\n ControlClass := AClass;\r\n MaxProperty := MaxPropName;\r\n MinProperty := MinPropName;\r\n ProgressProperty := ProgressPropName;\r\n end;\r\n inherited Add(NewRec);\r\nend;\r\n\r\nfunction TJvProgressList.FindClass(AClass: TControlClass): Integer;\r\nvar\r\n P: PProgressData;\r\nbegin\r\n for Result := Count - 1 downto 0 do\r\n begin\r\n P := PProgressData(Items[Result]);\r\n if AClass.InheritsFrom(P.ControlClass) then\r\n Exit;\r\n end;\r\n Result := -1;\r\nend;\r\n\r\nprocedure TJvProgressList.Remove(AClass: TControlClass);\r\nvar\r\n I: Integer;\r\n P: PProgressData;\r\nbegin\r\n for I := Count - 1 downto 0 do\r\n begin\r\n P := PProgressData(Items[I]);\r\n if P.ControlClass.InheritsFrom(AClass) then\r\n begin\r\n Dispose(P);\r\n Delete(I);\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJvProgressList.SetControlProperty(Control: TControl;\r\n Prop: TProgressProp; Value: Longint): Boolean;\r\nvar\r\n PropInfo: PPropInfo;\r\n I: Integer;\r\n PropName: string;\r\nbegin\r\n Result := False;\r\n if Control <> nil then\r\n begin\r\n I := FindClass(TControlClass(Control.ClassType));\r\n if I >= 0 then\r\n begin\r\n case Prop of\r\n ppMax:\r\n PropName := PProgressData(Items[I]).MaxProperty;\r\n ppMin:\r\n PropName := PProgressData(Items[I]).MinProperty;\r\n else {ppProgress}\r\n PropName := PProgressData(Items[I]).ProgressProperty;\r\n end;\r\n PropInfo := GetPropInfo(Control.ClassInfo, PropName);\r\n if (PropInfo <> nil) and\r\n (PropInfo^.PropType^.Kind\r\n in [tkInteger, tkFloat, tkVariant]) then\r\n begin\r\n SetOrdProp(Control, PropInfo, Value);\r\n Result := True;\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\nvar\r\n ProgressList: TJvProgressList = nil;\r\n\r\nfunction GetProgressList: TJvProgressList;\r\nbegin\r\n if ProgressList = nil then\r\n ProgressList := TJvProgressList.Create;\r\n Result := ProgressList;\r\nend;\r\n\r\nfunction SupportsProgressControl(Control: TControl): Boolean;\r\nbegin\r\n if Control <> nil then\r\n Result := GetProgressList.FindClass(TControlClass(Control.ClassType)) >= 0\r\n else\r\n Result := False;\r\nend;\r\n\r\nprocedure RegisterProgressControl(AClass: TControlClass;\r\n const MaxPropName, MinPropName, ProgressPropName: string);\r\nbegin\r\n GetProgressList.Add(AClass, MaxPropName, MinPropName, ProgressPropName);\r\nend;\r\n\r\nprocedure UnRegisterProgressControl(AClass: TControlClass);\r\nbegin\r\n GetProgressList.Remove(AClass);\r\nend;\r\n\r\nprocedure SetProgressMax(Control: TControl; MaxValue: Longint);\r\nbegin\r\n GetProgressList.SetControlProperty(Control, ppMax, MaxValue);\r\nend;\r\n\r\nprocedure SetProgressMin(Control: TControl; MinValue: Longint);\r\nbegin\r\n GetProgressList.SetControlProperty(Control, ppMin, MinValue);\r\nend;\r\n\r\nprocedure SetProgressValue(Control: TControl; ProgressValue: Longint);\r\nbegin\r\n GetProgressList.SetControlProperty(Control, ppProgress, ProgressValue);\r\nend;\r\n\r\ninitialization\r\n {$IFDEF UNITVERSIONING}\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n {$ENDIF UNITVERSIONING}\r\n\r\nfinalization\r\n FreeAndNil(ProgressList);\r\n {$IFDEF UNITVERSIONING}\r\n UnregisterUnitVersion(HInstance);\r\n {$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvPropertyStorage.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvProps.PAS, released on 2002-07-04.\r\n\r\nThe Initial Developers of the Original Code are: Fedor Koshevnikov, Igor Pavluk and Serge Korolev\r\nCopyright (c) 1997, 1998 Fedor Koshevnikov, Igor Pavluk and Serge Korolev\r\nCopyright (c) 2001,2002 SGB Software\r\nAll Rights Reserved.\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvPropertyStorage.pas 13138 2011-10-26 23:17:50Z jfudickar $\r\n\r\nunit JvPropertyStorage;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n SysUtils, Classes,\r\n Forms,\r\n TypInfo,\r\n JvAppStorage;\r\n\r\ntype\r\n TJvPropInfoList = class(TObject)\r\n private\r\n FList: PPropList;\r\n FCount: Integer;\r\n FSize: Integer;\r\n function Get(Index: Integer): PPropInfo;\r\n public\r\n constructor Create(AObject: TObject; Filter: TTypeKinds);\r\n destructor Destroy; override;\r\n function Contains(P: PPropInfo): Boolean;\r\n function Find(const AName: {$IFDEF RTL200_UP}ShortString{$ELSE}string{$ENDIF RTL200_UP}): PPropInfo;\r\n procedure Delete(Index: Integer);\r\n procedure Intersect(List: TJvPropInfoList);\r\n property Count: Integer read FCount;\r\n property Items[Index: Integer]: PPropInfo read Get; default;\r\n end;\r\n\r\n TJvPropertyStorage = class(TObject)\r\n private\r\n FObject: TObject;\r\n FOwner: TComponent;\r\n FPrefix: string;\r\n FAppStorage: TJvCustomAppStorage;\r\n FAppStoragePath: string;\r\n function CreateInfoList(AComponent: TComponent; StoredList: TStrings): TStrings;\r\n procedure FreeInfoLists(Info: TStrings);\r\n protected\r\n function ReadString(const APath, Item, Default: string): string; virtual;\r\n procedure WriteString(const APath, Item, Value: string); virtual;\r\n\r\n procedure ReadProperty(const APath, AStorageName: string; const PersObj: TPersistent; const PropName: {$IFDEF RTL200_UP}ShortString{$ELSE}string{$ENDIF RTL200_UP});\r\n procedure WriteProperty(const APath, AStorageName: string; const PersObj: TPersistent; const PropName: {$IFDEF RTL200_UP}ShortString{$ELSE}string{$ENDIF RTL200_UP});\r\n\r\n procedure EraseSection(const APath: string); virtual;\r\n function GetItemName(const APropName: {$IFDEF RTL200_UP}ShortString{$ELSE}string{$ENDIF RTL200_UP}): string; virtual;\r\n function CreateStorage: TJvPropertyStorage; virtual;\r\n public\r\n procedure StoreAnyProperty(PropInfo: PPropInfo);\r\n procedure LoadAnyProperty(PropInfo: PPropInfo);\r\n procedure StoreProperties(PropList: TStrings);\r\n procedure LoadProperties(PropList: TStrings);\r\n procedure LoadObjectsProps(AComponent: TComponent; StoredList: TStrings);\r\n procedure StoreObjectsProps(AComponent: TComponent; StoredList: TStrings);\r\n property AObject: TObject read FObject write FObject;\r\n property Prefix: string read FPrefix write FPrefix;\r\n property AppStorage: TJvCustomAppStorage read FAppStorage write FAppStorage;\r\n property AppStoragePath: string read FAppStoragePath write FAppStoragePath;\r\n end;\r\n\r\n{ Utility routines }\r\n\r\nprocedure UpdateStoredList(AComponent: TComponent; AStoredList: TStrings; FromForm: Boolean);\r\nfunction CreateStoredItem(const CompName, PropName: string): string;\r\nfunction ParseStoredItem(const Item: string; var CompName, PropName: string): Boolean;\r\n\r\nvar\r\n sPropNameDelimiter: string = '_';\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvPropertyStorage.pas $';\r\n Revision: '$Revision: 13138 $';\r\n Date: '$Date: 2011-10-27 01:17:50 +0200 (jeu. 27 oct. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\n{$IFDEF RTL200_UP}\r\nuses\r\n AnsiStrings;\r\n{$ENDIF RTL200_UP}\r\n\r\n//=== { TJvPropInfoList } ====================================================\r\n\r\nconstructor TJvPropInfoList.Create(AObject: TObject; Filter: TTypeKinds);\r\nbegin\r\n inherited Create;\r\n if AObject <> nil then\r\n begin\r\n FCount := GetPropList(AObject.ClassInfo, Filter, nil);\r\n FSize := FCount * SizeOf(Pointer);\r\n GetMem(FList, FSize);\r\n GetPropList(AObject.ClassInfo, Filter, FList);\r\n end\r\n else\r\n begin\r\n FCount := 0;\r\n FList := nil;\r\n end;\r\nend;\r\n\r\ndestructor TJvPropInfoList.Destroy;\r\nbegin\r\n if FList <> nil then\r\n FreeMem(FList, FSize);\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJvPropInfoList.Contains(P: PPropInfo): Boolean;\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := 0 to FCount - 1 do\r\n with FList[I]^ do\r\n if (PropType = P.PropType) and ({$IFDEF RTL200_UP}AnsiStrings.{$ENDIF RTL200_UP}CompareText(Name, P.Name) = 0) then\r\n begin\r\n Result := True;\r\n Exit;\r\n end;\r\n Result := False;\r\nend;\r\n\r\nfunction TJvPropInfoList.Find(const AName: {$IFDEF RTL200_UP}ShortString{$ELSE}string{$ENDIF RTL200_UP}): PPropInfo;\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := 0 to FCount - 1 do\r\n with FList[I]^ do\r\n if {$IFDEF RTL200_UP}AnsiStrings.{$ENDIF RTL200_UP}CompareText(Name, AName) = 0 then\r\n begin\r\n Result := FList[I];\r\n Exit;\r\n end;\r\n Result := nil;\r\nend;\r\n\r\nprocedure TJvPropInfoList.Delete(Index: Integer);\r\nbegin\r\n Dec(FCount);\r\n if Index < FCount then\r\n Move(FList[Index + 1], FList[Index], (FCount - Index) * SizeOf(Pointer));\r\nend;\r\n\r\nfunction TJvPropInfoList.Get(Index: Integer): PPropInfo;\r\nbegin\r\n Result := FList[Index];\r\nend;\r\n\r\nprocedure TJvPropInfoList.Intersect(List: TJvPropInfoList);\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := FCount - 1 downto 0 do\r\n if not List.Contains(FList[I]) then\r\n Delete(I);\r\nend;\r\n\r\n{ Utility routines }\r\n\r\nfunction CreateStoredItem(const CompName, PropName: string): string;\r\nbegin\r\n Result := '';\r\n if (CompName <> '') and (PropName <> '') then\r\n Result := CompName + '.' + PropName;\r\nend;\r\n\r\nfunction ParseStoredItem(const Item: string; var CompName, PropName: string): Boolean;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := False;\r\n if Item = '' then\r\n Exit;\r\n I := Pos('.', Item);\r\n if I > 0 then\r\n begin\r\n CompName := Trim(Copy(Item, 1, I - 1));\r\n PropName := Trim(Copy(Item, I + 1, MaxInt));\r\n Result := (CompName <> '') and (PropName <> '');\r\n end;\r\nend;\r\n\r\nfunction ReplaceComponentName(const Item, CompName: string): string;\r\nvar\r\n ACompName, APropName: string;\r\nbegin\r\n Result := '';\r\n if ParseStoredItem(Item, ACompName, APropName) then\r\n Result := CreateStoredItem(CompName, APropName);\r\nend;\r\n\r\nprocedure UpdateStoredList(AComponent: TComponent; AStoredList: TStrings; FromForm: Boolean);\r\nvar\r\n I: Integer;\r\n Component: TComponent;\r\n CompName, PropName: string;\r\nbegin\r\n if (AStoredList = nil) or (AComponent = nil) then\r\n Exit;\r\n for I := AStoredList.Count - 1 downto 0 do\r\n begin\r\n if ParseStoredItem(AStoredList[I], CompName, PropName) then\r\n begin\r\n if FromForm then\r\n begin\r\n Component := AComponent.FindComponent(CompName);\r\n if Component = nil then\r\n AStoredList.Delete(I)\r\n else\r\n AStoredList.Objects[I] := Component;\r\n end\r\n else\r\n begin\r\n Component := TComponent(AStoredList.Objects[I]);\r\n if Component <> nil then\r\n AStoredList[I] := ReplaceComponentName(AStoredList[I], Component.Name)\r\n else\r\n AStoredList.Delete(I);\r\n end;\r\n end\r\n else\r\n AStoredList.Delete(I);\r\n end;\r\nend;\r\n\r\n//=== { TJvPropertyStorage } =================================================\r\n\r\nfunction TJvPropertyStorage.GetItemName(const APropName: {$IFDEF RTL200_UP}ShortString{$ELSE}string{$ENDIF RTL200_UP}): string;\r\nbegin\r\n Result := Prefix + string(APropName);\r\nend;\r\n\r\nprocedure TJvPropertyStorage.LoadAnyProperty(PropInfo: PPropInfo);\r\nbegin\r\n try\r\n if PropInfo <> nil then\r\n ReadProperty (AppStoragePath, GetItemName(PropInfo.Name), TPersistent(FObject), PropInfo.Name);\r\n except\r\n { ignore any exception }\r\n end;\r\nend;\r\n\r\nprocedure TJvPropertyStorage.StoreAnyProperty(PropInfo: PPropInfo);\r\nbegin\r\n if PropInfo <> nil then\r\n WriteProperty (AppStoragePath, GetItemName(PropInfo.Name), TPersistent(FObject), PropInfo.Name);\r\nend;\r\n\r\n\r\nprocedure TJvPropertyStorage.StoreProperties(PropList: TStrings);\r\nvar\r\n I: Integer;\r\n Props: TJvPropInfoList;\r\nbegin\r\n Props := TJvPropInfoList.Create(AObject, tkProperties);\r\n try\r\n for I := 0 to PropList.Count - 1 do\r\n StoreAnyProperty(Props.Find({$IFDEF SUPPORTS_UNICODE}UTF8Encode{$ENDIF SUPPORTS_UNICODE}(PropList[I])));\r\n finally\r\n Props.Free;\r\n end;\r\nend;\r\n\r\nprocedure TJvPropertyStorage.LoadProperties(PropList: TStrings);\r\nvar\r\n I: Integer;\r\n Props: TJvPropInfoList;\r\nbegin\r\n Props := TJvPropInfoList.Create(AObject, tkProperties);\r\n try\r\n for I := 0 to PropList.Count - 1 do\r\n LoadAnyProperty(Props.Find({$IFDEF SUPPORTS_UNICODE}UTF8Encode{$ENDIF SUPPORTS_UNICODE}(PropList[I])));\r\n finally\r\n Props.Free;\r\n end;\r\nend;\r\n\r\nfunction TJvPropertyStorage.CreateInfoList(AComponent: TComponent; StoredList: TStrings): TStrings;\r\nvar\r\n I: Integer;\r\n Obj: TComponent;\r\n Props: TJvPropInfoList;\r\nbegin\r\n UpdateStoredList(AComponent, StoredList, False);\r\n Result := TStringList.Create;\r\n try\r\n TStringList(Result).Sorted := True;\r\n for I := 0 to StoredList.Count - 1 do\r\n begin\r\n Obj := TComponent(StoredList.Objects[I]);\r\n if Result.IndexOf(Obj.Name) < 0 then\r\n begin\r\n Props := TJvPropInfoList.Create(Obj, tkProperties);\r\n try\r\n Result.AddObject(Obj.Name, Props);\r\n except\r\n Props.Free;\r\n raise;\r\n end;\r\n end;\r\n end;\r\n except\r\n Result.Free;\r\n Result := nil;\r\n end;\r\nend;\r\n\r\nprocedure TJvPropertyStorage.FreeInfoLists(Info: TStrings);\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := Info.Count - 1 downto 0 do\r\n Info.Objects[I].Free;\r\n Info.Free;\r\nend;\r\n\r\nprocedure TJvPropertyStorage.LoadObjectsProps(AComponent: TComponent; StoredList: TStrings);\r\nvar\r\n Info: TStrings;\r\n I, Idx: Integer;\r\n Props: TJvPropInfoList;\r\n CompName, PropName: string;\r\nbegin\r\n Info := CreateInfoList(AComponent, StoredList);\r\n if Info <> nil then\r\n try\r\n FOwner := AComponent;\r\n for I := 0 to StoredList.Count - 1 do\r\n begin\r\n if ParseStoredItem(StoredList[I], CompName, PropName) then\r\n begin\r\n AObject := StoredList.Objects[I];\r\n Prefix := TComponent(AObject).Name;\r\n Idx := Info.IndexOf(Prefix);\r\n if Idx >= 0 then\r\n begin\r\n Prefix := Prefix + sPropNameDelimiter;\r\n Props := TJvPropInfoList(Info.Objects[Idx]);\r\n if Props <> nil then\r\n LoadAnyProperty(Props.Find({$IFDEF SUPPORTS_UNICODE}UTF8Encode{$ENDIF SUPPORTS_UNICODE}(PropName)));\r\n end;\r\n end;\r\n end;\r\n finally\r\n FOwner := nil;\r\n FreeInfoLists(Info);\r\n end;\r\nend;\r\n\r\nprocedure TJvPropertyStorage.StoreObjectsProps(AComponent: TComponent; StoredList: TStrings);\r\nvar\r\n Info: TStrings;\r\n I, Idx: Integer;\r\n Props: TJvPropInfoList;\r\n CompName, PropName: string;\r\nbegin\r\n Info := CreateInfoList(AComponent, StoredList);\r\n if Info <> nil then\r\n try\r\n FOwner := AComponent;\r\n for I := 0 to StoredList.Count - 1 do\r\n begin\r\n if ParseStoredItem(StoredList[I], CompName, PropName) then\r\n begin\r\n AObject := StoredList.Objects[I];\r\n Prefix := TComponent(AObject).Name;\r\n Idx := Info.IndexOf(Prefix);\r\n if Idx >= 0 then\r\n begin\r\n Prefix := Prefix + sPropNameDelimiter;\r\n Props := TJvPropInfoList(Info.Objects[Idx]);\r\n if Props <> nil then\r\n StoreAnyProperty(Props.Find({$IFDEF SUPPORTS_UNICODE}UTF8Encode{$ENDIF SUPPORTS_UNICODE}(PropName)));\r\n end;\r\n end;\r\n end;\r\n finally\r\n FOwner := nil;\r\n FreeInfoLists(Info);\r\n end;\r\nend;\r\n\r\nfunction TJvPropertyStorage.CreateStorage: TJvPropertyStorage;\r\nbegin\r\n Result := TJvPropertyStorage.Create;\r\n Result.AppStorage := AppStorage;\r\nend;\r\n\r\nfunction TJvPropertyStorage.ReadString(const APath, Item, Default: string): string;\r\nbegin\r\n if Assigned(AppStorage) then\r\n Result := AppStorage.ReadString(AppStorage.ConcatPaths([APath, AppStorage.TranslatePropertyName(Nil, Item, True)]), Default)\r\n else\r\n Result := Default;\r\nend;\r\n\r\nprocedure TJvPropertyStorage.WriteString(const APath, Item, Value: string);\r\nbegin\r\n if Assigned(AppStorage) then\r\n AppStorage.WriteString(AppStorage.ConcatPaths([APath, AppStorage.TranslatePropertyName(Nil, Item, False)]), Value);\r\nend;\r\n\r\nprocedure TJvPropertyStorage.EraseSection(const APath: string);\r\nbegin\r\n if Assigned(AppStorage) then\r\n AppStorage.DeleteSubTree(APath);\r\nend;\r\n\r\nprocedure TJvPropertyStorage.ReadProperty(const APath, AStorageName: string; const PersObj: TPersistent; const PropName: {$IFDEF RTL200_UP}ShortString{$ELSE}string{$ENDIF RTL200_UP});\r\nvar\r\n NPath: string;\r\n SearchCompName : string;\r\n SearchOwner : TComponent;\r\n i : Integer;\r\nbegin\r\n if Assigned(AppStorage) then\r\n begin\r\n if (PropType(PersObj, {$IFDEF RTL200_UP}string{$ENDIF RTL200_UP}(PropName)) = tkClass) and (GetObjectProp(PersObj, {$IFDEF RTL200_UP}string{$ENDIF RTL200_UP}(PropName)) is TComponent) then\r\n begin\r\n SearchCompName := AppStorage.ReadString(AppStorage.ConcatPaths([APath, AppStorage.TranslatePropertyName(PersObj, AStorageName, False)]));\r\n SearchOwner := fOwner;\r\n while Assigned(SearchOwner) do\r\n begin\r\n for I := 0 to SearchOwner.ComponentCount - 1 do\r\n if SearchOwner.Components[i].Name = SearchCompName then\r\n begin\r\n SetObjectProp(PersObj, {$IFDEF RTL200_UP}string{$ENDIF RTL200_UP}(PropName), SearchOwner.Components[i]);\r\n Exit;\r\n end;\r\n SearchOwner := SearchOwner.Owner;\r\n end;\r\n end\r\n else\r\n begin\r\n NPath := AppStorage.ConcatPaths([APath, AppStorage.TranslatePropertyName(PersObj, AStorageName, True)]);\r\n if AppStorage.ValueStored(NPath) or AppStorage.IsFolder(NPath, False) then\r\n AppStorage.ReadProperty(NPath, PersObj, {$IFDEF RTL200_UP}string{$ENDIF RTL200_UP}(PropName), True, True);\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvPropertyStorage.WriteProperty(const APath, AStorageName: string; const PersObj: TPersistent; const PropName: {$IFDEF RTL200_UP}ShortString{$ELSE}string{$ENDIF RTL200_UP});\r\nbegin\r\n if Assigned(AppStorage) then\r\n if (PropType(PersObj, {$IFDEF RTL200_UP}string{$ENDIF RTL200_UP}(PropName)) = tkClass) and (GetObjectProp(PersObj, {$IFDEF RTL200_UP}string{$ENDIF RTL200_UP}(PropName)) is TComponent) then\r\n AppStorage.WriteString(AppStorage.ConcatPaths([APath, AppStorage.TranslatePropertyName(PersObj, AStorageName, False)]), TComponent(GetObjectProp(PersObj, {$IFDEF RTL200_UP}string{$ENDIF RTL200_UP}(PropName))).Name)\r\n else\r\n AppStorage.WriteProperty(AppStorage.ConcatPaths([APath, AppStorage.TranslatePropertyName(PersObj, AStorageName, False)]), PersObj, {$IFDEF RTL200_UP}string{$ENDIF RTL200_UP}(PropName), True);\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvPropertyStore.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvPropertyStore.pas, released on 2003-11-13.\r\n\r\nThe Initial Developer of the Original Code is Jens Fudickar\r\nPortions created by Marcel Bestebroer are Copyright (C) 2003 Jens Fudickar\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\n Marcel Bestebroer\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvPropertyStore.pas 13138 2011-10-26 23:17:50Z jfudickar $\r\n\r\nunit JvPropertyStore;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n{$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n{$ENDIF UNITVERSIONING}\r\n Classes,\r\n JvAppStorage, JvComponentBase, JvPropertyStoreEditorIntf;\r\n\r\ntype\r\n TJvIgnorePropertiesStringList = class(TStringList)\r\n public\r\n constructor Create;\r\n procedure AddDelete(AItem: string; ADelete: Boolean);\r\n end;\r\n\r\n TJvCustomPropertyStoreClass = class of TJvCustomPropertyStore;\r\n\r\n TJvCustomPropertyStore = class(TJvComponent, IJvPropertyEditorHandler)\r\n private\r\n FAppStoragePath: string;\r\n FAppStorage: TJvCustomAppStorage;\r\n FEnabled: Boolean;\r\n FReadOnly: Boolean;\r\n FDeleteBeforeStore: Boolean;\r\n FClearBeforeLoad: Boolean;\r\n FIntIgnoreProperties: TStringList;\r\n FIgnoreProperties: TJvIgnorePropertiesStringList;\r\n FAutoLoad: Boolean;\r\n FLastLoadTime: TDateTime;\r\n FIgnoreLastLoadTime: Boolean;\r\n FCombinedIgnoreProperties: TStringList;\r\n FOnBeforeLoadProperties: TNotifyEvent;\r\n FOnAfterLoadProperties: TNotifyEvent;\r\n FOnBeforeStoreProperties: TNotifyEvent;\r\n FOnAfterStoreProperties: TNotifyEvent;\r\n FSynchronizeStoreProperties: Boolean;\r\n FSynchronizeLoadProperties: Boolean;\r\n procedure SetAutoLoad(Value: Boolean);\r\n function GetIgnoreProperties: TJvIgnorePropertiesStringList;\r\n procedure SetIgnoreProperties(Value: TJvIgnorePropertiesStringList);\r\n function GetLastSaveTime: TDateTime;\r\n function GetPropCount(Instance: TPersistent): Integer;\r\n function GetPropName(Instance: TPersistent; Index: Integer): string;\r\n protected\r\n procedure CloneClassProperties(Src, Dest: TPersistent); virtual;\r\n procedure UpdateChildPaths(OldPath: string = ''); virtual;\r\n procedure SetAppStoragePath(Value: string); virtual;\r\n procedure SetAppStorage(Value: TJvCustomAppStorage); virtual;\r\n procedure Loaded; override;\r\n procedure DisableAutoLoadDown;\r\n procedure LoadData; virtual;\r\n procedure StoreData; virtual;\r\n procedure Notification(AComponent: TComponent; Operation: TOperation); override;\r\n function GetCombinedIgnoreProperties: TStringList;\r\n function GetPropertyCount: Integer;\r\n function GetPropertyName(Index: Integer): string;\r\n //1 Returns the given property as TJvCustomPropertyStore or returns nil\r\n function GetPropertyJvCustomPropertyStore(PropName: string): TJvCustomPropertyStore;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n procedure StoreProperties; virtual;\r\n procedure LoadProperties; virtual;\r\n procedure Assign(Source: TPersistent); override;\r\n procedure Clear; virtual;\r\n function IgnoreProperty(const PropertyName: string): Boolean;\r\n //1 // This function defines, if the properties should be stored in this moment\r\n function StorePropertiesNow: Boolean; virtual;\r\n function TranslatePropertyName(AName: string): string; virtual;\r\n property AppStorage: TJvCustomAppStorage read FAppStorage write SetAppStorage;\r\n property CombinedIgnoreProperties: TStringList read GetCombinedIgnoreProperties;\r\n property IgnoreProperties: TJvIgnorePropertiesStringList read GetIgnoreProperties write SetIgnoreProperties;\r\n property AutoLoad: Boolean read FAutoLoad write SetAutoLoad;\r\n property AppStoragePath: string read FAppStoragePath write SetAppStoragePath;\r\n property Enabled: Boolean read FEnabled write FEnabled default True;\r\n property ReadOnly: Boolean read FReadOnly write FReadOnly default False;\r\n property DeleteBeforeStore: Boolean read FDeleteBeforeStore write FDeleteBeforeStore default False;\r\n property ClearBeforeLoad: Boolean read FClearBeforeLoad write FClearBeforeLoad default False;\r\n property IgnoreLastLoadTime: Boolean read FIgnoreLastLoadTime write FIgnoreLastLoadTime default False;\r\n property OnBeforeLoadProperties: TNotifyEvent read FOnBeforeLoadProperties write FOnBeforeLoadProperties;\r\n property OnAfterLoadProperties: TNotifyEvent read FOnAfterLoadProperties write FOnAfterLoadProperties;\r\n property OnBeforeStoreProperties: TNotifyEvent read FOnBeforeStoreProperties write FOnBeforeStoreProperties;\r\n property OnAfterStoreProperties: TNotifyEvent read FOnAfterStoreProperties write FOnAfterStoreProperties;\r\n property PropertyCount: Integer read GetPropertyCount;\r\n property PropertyName[Index: Integer]: string read GetPropertyName;\r\n //1 Synchronize the StoreProperties procedure\r\n /// Defines if the execution of the StoreProperties procedure for the current\r\n /// AppStoragePath should be synchronized via a global mutex\r\n /// When the SynchronizeLoadProperties is also definde the load and store\r\n /// procedures will be synched with the same mutex.\r\n property SynchronizeStoreProperties: Boolean read FSynchronizeStoreProperties write FSynchronizeStoreProperties default False;\r\n //1 Synchronize the LoadProperties procedure\r\n /// Defines if the execution of the LoadProperties procedure for the current\r\n /// AppStoragePath should be synchronized via a global mutex.\r\n /// When the SynchronizeStoreProperties is also definde the load and store\r\n /// procedures will be synched with the same mutex.\r\n property SynchronizeLoadProperties: Boolean read FSynchronizeLoadProperties write FSynchronizeLoadProperties default False;\r\n property Tag;\r\n\r\n //1 Creates a new instance of the same objecttype and assigns the property contents to the new instance\r\n function Clone(AOwner: TComponent): TJvCustomPropertyStore; virtual;\r\n //IJvPropertyEditorHandler = interface\r\n function EditIntf_GetVisibleObjectName: string; virtual;\r\n function EditIntf_TranslatePropertyName(const PropertyName: string): string; virtual;\r\n function EditIntf_DisplayProperty(const PropertyName: string): Boolean; virtual;\r\n function EditIntf_GetObjectHint: string; virtual;\r\n function EditIntf_GetPropertyHint(const PropertyName: string): string; virtual;\r\n function EditIntf_IsPropertySimple(const PropertyName: string): Boolean; virtual;\r\n function ValidateData: Boolean; virtual;\r\n end;\r\n\r\n TJvCustomPropertyListStore = class(TJvCustomPropertyStore, IJvPropertyListEditorHandler)\r\n private\r\n FItems: TStringList;\r\n FFreeObjects: Boolean;\r\n FCreateListEntries: Boolean;\r\n FItemName: string;\r\n FItemsObjectName: string;\r\n function GetItems: TStringList;\r\n //IJvPropertyListEditorHandler = interface\r\n function ListEditIntf_ObjectCount: integer;\r\n function ListEditIntf_GetObject(Index: integer): TPersistent;\r\n procedure ListEditIntf_MoveObjectPosition(CurIndex, NewIndex: Integer);\r\n procedure ListEditIntf_SortObjects(iAscending : Boolean);\r\n function ListEditIntf_CloneNewObject(Index: integer): TPersistent;\r\n procedure ListEditIntf_DeleteObject(Index: integer);\r\n function ListEditIntf_IndexOfObject(AObject : TPersistent): Integer;\r\n protected\r\n function GetString(Index: Integer): string;\r\n function GetObject(Index: Integer): TObject;\r\n procedure SetString(Index: Integer; Value: string);\r\n procedure SetObject(Index: Integer; Value: TObject);\r\n function GetCount: Integer;\r\n procedure ReadSLOItem(Sender: TJvCustomAppStorage; const Path: string;\r\n const List: TObject; const Index: Integer; const ItemName: string);\r\n procedure WriteSLOItem(Sender: TJvCustomAppStorage; const Path: string;\r\n const List: TObject; const Index: Integer; const ItemName: string);\r\n procedure DeleteSLOItems(Sender: TJvCustomAppStorage; const Path: string;\r\n const List: TObject; const First, Last: Integer; const ItemName: string);\r\n function CreateItemList: TStringList; virtual;\r\n function CreateObject: TPersistent; virtual; abstract;\r\n function GetSorted: Boolean;\r\n procedure SetSorted(Value: Boolean);\r\n function GetDuplicates: TDuplicates;\r\n function ListEditIntf_CreateNewObject: TPersistent; virtual;\r\n procedure SetDuplicates(Value: TDuplicates);\r\n procedure StoreData; override;\r\n procedure LoadData; override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n procedure Clear; override;\r\n function IndexOf(const s: string): Integer;\r\n function IndexOfObject(AObject: TObject): Integer;\r\n property Strings[Index: Integer]: string read GetString write SetString;\r\n property Objects[Index: Integer]: TObject read GetObject write SetObject;\r\n property Items: TStringList read GetItems;\r\n property Count: Integer read GetCount;\r\n { Defines if the Items.Objects- Objects will be freed inside the clear procedure }\r\n property FreeObjects: Boolean read FFreeObjects write FFreeObjects default True;\r\n { Defines if new List entries will be created if there are stored entries, which\r\n are not in the current object }\r\n property CreateListEntries: Boolean read FCreateListEntries write FCreateListEntries default True;\r\n property ItemName: string read FItemName write FItemName;\r\n //1 Name to read the value of the object from the appstorage path\r\n /// Using this path addition the internal name of the object is read from\r\n /// the appstorage.\r\n /// This property is necessary only for the xml appstorage.\r\n /// When in this case the property is not defined the internal items string\r\n /// value couldn't be recovered from the appstorage (out of xml\r\n /// restrictions with array elements)\r\n property ItemsObjectName: string read FItemsObjectName write FItemsObjectName;\r\n property Sorted: Boolean read GetSorted write SetSorted;\r\n function CreateAddObject(const aObjectName: String): TPersistent;\r\n function ValidateData: Boolean; override;\r\n end;\r\n\r\nprocedure StorePropertyStorageToAppStorage(iPropertyStore: TJvCustomPropertyStore; iAppStorage: TJvCustomAppStorage; const\r\n iAppStoragePath: string);\r\n\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile:\r\n '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvPropertyStore.pas $';\r\n Revision: '$Revision: 13138 $';\r\n Date: '$Date: 2011-10-27 01:17:50 +0200 (jeu. 27 oct. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n RTLConsts, SysUtils, TypInfo,\r\n JclSynch,\r\n JvStrings, JvResources, JvJVCLUtils;\r\n\r\nconst\r\n cLastSaveTime = 'LastSaveTime';\r\n cObject = 'Object';\r\n cItem = 'Item';\r\n\r\n //=== { TCombinedStrings } ===================================================\r\n\r\ntype\r\n // Read-only TStrings combining multiple TStrings instances in a single list\r\n TCombinedStrings = class(TStringList)\r\n private\r\n FList: TList;\r\n protected\r\n function Get(Index: Integer): string; override;\r\n function GetObject(Index: Integer): TObject; override;\r\n function GetCount: Integer; override;\r\n public\r\n constructor Create;\r\n destructor Destroy; override;\r\n procedure AddStrings(Strings: TStrings); override;\r\n // procedure DeleteStrings(Strings: TStrings);\r\n procedure Clear; override;\r\n procedure Delete(Index: Integer); override;\r\n procedure Insert(Index: Integer; const S: string); override;\r\n end;\r\n\r\nconstructor TCombinedStrings.Create;\r\nbegin\r\n inherited Create;\r\n Sorted := True;\r\n FList := TList.Create;\r\nend;\r\n\r\ndestructor TCombinedStrings.Destroy;\r\nbegin\r\n FreeAndNil(FList);\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TCombinedStrings.Get(Index: Integer): string;\r\nvar\r\n OrgIndex: Integer;\r\n I: Integer;\r\nbegin\r\n OrgIndex := Index;\r\n I := 0;\r\n if Index < 0 then\r\n Error(SListIndexError, Index);\r\n while (I < FList.Count) and (Index >= TStrings(FList[I]).Count) do\r\n begin\r\n Dec(Index, TStrings(FList[I]).Count);\r\n Inc(I);\r\n end;\r\n if I >= FList.Count then\r\n Error(SListIndexError, OrgIndex);\r\n Result := TStrings(FList[I])[Index];\r\nend;\r\n\r\nfunction TCombinedStrings.GetObject(Index: Integer): TObject;\r\nvar\r\n OrgIndex: Integer;\r\n I: Integer;\r\nbegin\r\n OrgIndex := Index;\r\n I := 0;\r\n if Index < 0 then\r\n Error(SListIndexError, Index);\r\n while (Index < TStrings(FList[I]).Count) and (I < FList.Count) do\r\n begin\r\n Dec(Index, TStrings(FList[I]).Count);\r\n Inc(I);\r\n end;\r\n if I >= FList.Count then\r\n Error(SListIndexError, OrgIndex);\r\n Result := TStrings(FList[I]).Objects[Index];\r\nend;\r\n\r\nfunction TCombinedStrings.GetCount: Integer;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := 0;\r\n for I := 0 to FList.Count - 1 do\r\n Inc(Result, TStrings(FList[I]).Count);\r\nend;\r\n\r\nprocedure TCombinedStrings.AddStrings(Strings: TStrings);\r\nbegin\r\n if FList.IndexOf(Strings) = -1 then\r\n FList.Add(Strings);\r\nend;\r\n\r\n(*\r\nprocedure TCombinedStrings.DeleteStrings(Strings: TStrings);\r\nbegin\r\n FList.Remove(Strings);\r\nend;\r\n*)\r\n\r\nprocedure TCombinedStrings.Clear;\r\nbegin\r\n FList.Clear;\r\nend;\r\n\r\nprocedure TCombinedStrings.Delete(Index: Integer);\r\nbegin\r\nend;\r\n\r\nprocedure TCombinedStrings.Insert(Index: Integer; const S: string);\r\nbegin\r\nend;\r\n\r\nconstructor TJvIgnorePropertiesStringList.Create;\r\nbegin\r\n inherited Create;\r\n Sorted := True;\r\nend;\r\n\r\n//=== { TJvIgnorePropertiesStringList } ======================================\r\n\r\nprocedure TJvIgnorePropertiesStringList.AddDelete(AItem: string; ADelete:\r\n Boolean);\r\nbegin\r\n if ADelete then\r\n begin\r\n if IndexOf(AItem) >= 0 then\r\n Delete(IndexOf(AItem));\r\n end\r\n else\r\n begin\r\n if IndexOf(AItem) < 0 then\r\n Add(AItem);\r\n end;\r\nend;\r\n\r\n//=== { TJvCustomPropertyStore } =============================================\r\n\r\nconstructor TJvCustomPropertyStore.Create(AOwner: TComponent);\r\nconst\r\n IgnorePropertyList: array[1..18] of string =\r\n (\r\n 'AboutJVCL',\r\n 'AppStorage',\r\n 'AppStoragePath',\r\n 'AutoLoad',\r\n 'ClearBeforeLoad',\r\n 'Name',\r\n 'Tag',\r\n 'Enabled',\r\n 'ReadOnly',\r\n 'DeleteBeforeStore',\r\n 'IgnoreLastLoadTime',\r\n 'IgnoreProperties',\r\n 'OnBeforeLoadProperties',\r\n 'OnAfterLoadProperties',\r\n 'OnBeforeStoreProperties',\r\n 'OnAfterStoreProperties',\r\n 'SynchronizeLoadProperties',\r\n 'SynchronizeStoreProperties'\r\n );\r\nvar\r\n I: Integer;\r\nbegin\r\n inherited Create(AOwner);\r\n FLastLoadTime := Now;\r\n FAppStorage := nil;\r\n FEnabled := True;\r\n FReadOnly := False;\r\n FDeleteBeforeStore := False;\r\n FAutoLoad := False;\r\n FIntIgnoreProperties := TStringList.Create;\r\n FIntIgnoreProperties.Sorted := True;\r\n FIntIgnoreProperties.Duplicates := dupIgnore;\r\n FIgnoreProperties := TJvIgnorePropertiesStringList.Create;\r\n FIgnoreProperties.Sorted := True;\r\n FIgnoreProperties.Duplicates := dupIgnore;\r\n FIgnoreLastLoadTime := False;\r\n FCombinedIgnoreProperties := TCombinedStrings.Create;\r\n FCombinedIgnoreProperties.Sorted := True;\r\n FCombinedIgnoreProperties.Duplicates := dupIgnore;\r\n for I := Low(IgnorePropertyList) to High(IgnorePropertyList) do\r\n FIntIgnoreProperties.Add(IgnorePropertyList[I]);\r\n FSynchronizeStoreProperties := False;\r\n FSynchronizeLoadProperties := False;\r\nend;\r\n\r\ndestructor TJvCustomPropertyStore.Destroy;\r\nbegin\r\n if not (csDesigning in ComponentState) then\r\n if AutoLoad then\r\n StoreProperties;\r\n FreeAndNil(FCombinedIgnoreProperties);\r\n FreeAndNil(FIntIgnoreProperties);\r\n FreeAndNil(FIgnoreProperties);\r\n Clear;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvCustomPropertyStore.Notification(AComponent: TComponent; Operation: TOperation);\r\nbegin\r\n inherited Notification(AComponent, Operation);\r\n if (Operation = opRemove) and (AComponent = FAppStorage) then\r\n FAppStorage := nil;\r\nend;\r\n\r\nfunction TJvCustomPropertyStore.GetCombinedIgnoreProperties: TStringList;\r\nvar\r\n I: Integer;\r\nbegin\r\n FCombinedIgnoreProperties.clear;\r\n for I := 0 to FIntIgnoreProperties.Count - 1 do\r\n FCombinedIgnoreProperties.Add(FIntIgnoreProperties[i]);\r\n for I := 0 to FIgnoreProperties.Count - 1 do\r\n FCombinedIgnoreProperties.Add(FIgnoreProperties[i]);\r\n Result := FCombinedIgnoreProperties;\r\nend;\r\n\r\nfunction TJvCustomPropertyStore.GetPropCount(Instance: TPersistent): Integer;\r\nvar\r\n Data: PTypeData;\r\nbegin\r\n Data := GetTypeData(Instance.ClassInfo);\r\n Result := Data.PropCount;\r\nend;\r\n\r\nfunction TJvCustomPropertyStore.GetPropName(Instance: TPersistent; Index: Integer): string;\r\nvar\r\n PropList: PPropList;\r\n PropInfo: PPropInfo;\r\n Data: PTypeData;\r\nbegin\r\n Result := '';\r\n Data := GetTypeData(Instance.ClassInfo);\r\n GetMem(PropList, Data^.PropCount * SizeOf(PPropInfo));\r\n try\r\n GetPropInfos(Instance.ClassInfo, PropList);\r\n PropInfo := PropList^[Index];\r\n Result := {$IFDEF SUPPORTS_UNICODE}UTF8ToString{$ENDIF SUPPORTS_UNICODE}(PropInfo^.Name);\r\n finally\r\n FreeMem(PropList, Data^.PropCount * SizeOf(PPropInfo));\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomPropertyStore.CloneClassProperties(Src, Dest: TPersistent);\r\nvar\r\n Index: Integer;\r\n SrcPropInfo: PPropInfo;\r\n DestPropInfo: PPropInfo;\r\n PropName : String;\r\n\r\n function GetPropKind(PropInfo: PPropInfo): TTypeKind;\r\n begin\r\n Result := PropInfo.PropType^.Kind;\r\n end;\r\n\r\nbegin\r\n for Index := 0 to GetPropCount(Src) - 1 do\r\n begin\r\n PropName := GetPropName(Src, Index);\r\n if CompareText(PropName, 'Name') <> 0 then\r\n begin\r\n SrcPropInfo := GetPropInfo(Src.ClassInfo, PropName);\r\n DestPropInfo := GetPropInfo(Dest.ClassInfo, PropName);\r\n if (DestPropInfo <> nil) and (GetPropKind(DestPropInfo) = GetPropKind(SrcPropInfo)) then\r\n case GetPropKind(DestPropInfo) of\r\n {$IFDEF UNICODE} tkUString, {$ENDIF}\r\n tkLString, tkString:\r\n SetStrProp(Dest, DestPropInfo, GetStrProp(Src, SrcPropInfo));\r\n tkInteger, tkChar, tkEnumeration, tkSet:\r\n SetOrdProp(Dest, DestPropInfo, GetOrdProp(Src, SrcPropInfo));\r\n tkFloat:\r\n SetFloatProp(Dest, DestPropInfo, GetFloatProp(Src, SrcPropInfo));\r\n tkVariant:\r\n SetVariantProp(Dest, DestPropInfo, GetVariantProp(Src, SrcPropInfo));\r\n tkClass:\r\n if GetObjectProp(Src, SrcPropInfo) is TPersistent then\r\n TPersistent(GetObjectProp(Dest,\r\n DestPropInfo)).Assign(TPersistent(GetObjectProp(Src, SrcPropInfo)));\r\n tkMethod:\r\n SetMethodProp(Dest, DestPropInfo, GetMethodProp(Src, SrcPropInfo));\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomPropertyStore.Loaded;\r\nbegin\r\n inherited Loaded;\r\n if not (csDesigning in ComponentState) then\r\n if AutoLoad then\r\n LoadProperties;\r\nend;\r\n\r\nprocedure TJvCustomPropertyStore.Assign(Source: TPersistent);\r\nbegin\r\n if Source is Self.ClassType then\r\n CloneClassProperties(Source, Self)\r\n else\r\n inherited Assign(Source);\r\nend;\r\n\r\nprocedure TJvCustomPropertyStore.Clear;\r\nbegin\r\nend;\r\n\r\nfunction TJvCustomPropertyStore.Clone(AOwner: TComponent):\r\n TJvCustomPropertyStore;\r\nbegin\r\n Result := TJvCustomPropertyStoreClass(ClassType).Create(AOwner);\r\n Result.Assign(Self);\r\nend;\r\n\r\nfunction TJvCustomPropertyStore.TranslatePropertyName(AName: string): string;\r\nbegin\r\n Result := AName;\r\nend;\r\n\r\nprocedure TJvCustomPropertyStore.SetAutoLoad(Value: Boolean);\r\nbegin\r\n if not Assigned(Owner) then\r\n Exit;\r\n if Owner is TJvCustomPropertyStore then\r\n FAutoLoad := False\r\n else if Value <> AutoLoad then\r\n FAutoLoad := Value;\r\nend;\r\n\r\nprocedure TJvCustomPropertyStore.DisableAutoLoadDown;\r\nvar\r\n Index: Integer;\r\n PropName: string;\r\n PropertyStore: TJvCustomPropertyStore;\r\nbegin\r\n for Index := 0 to GetPropCount(Self) - 1 do\r\n begin\r\n PropName := GetPropName(Self, Index);\r\n if not IgnoreProperty(PropName) then\r\n begin\r\n PropertyStore := GetPropertyJvCustomPropertyStore(PropName);\r\n if Assigned(PropertyStore) then\r\n PropertyStore.AutoLoad := False;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJvCustomPropertyStore.EditIntf_DisplayProperty(const PropertyName: string): Boolean;\r\nbegin\r\n Result := not (IgnoreProperty(PropertyName));\r\nend;\r\n\r\nfunction TJvCustomPropertyStore.EditIntf_GetObjectHint: string;\r\nbegin\r\n Result := '';\r\nend;\r\n\r\nfunction TJvCustomPropertyStore.EditIntf_GetPropertyHint(const PropertyName: string): string;\r\nbegin\r\n Result := '';\r\nend;\r\n\r\nfunction TJvCustomPropertyStore.EditIntf_GetVisibleObjectName: string;\r\nbegin\r\n Result := '';\r\nend;\r\n\r\nfunction TJvCustomPropertyStore.EditIntf_IsPropertySimple(const PropertyName: string): Boolean;\r\nvar\r\n I: Integer;\r\n PropertyStore :TJvCustomPropertyStore;\r\nbegin\r\n if PropertyName = '' then\r\n begin\r\n Result := true;\r\n for I := 0 to GetPropCount(Self) - 1 do\r\n if EditIntf_DisplayProperty(GetPropName(Self, I)) then\r\n begin\r\n Result := EditIntf_IsPropertySimple(GetPropName(Self, I));\r\n if not Result then\r\n Exit;\r\n end;\r\n end\r\n else if IsPublishedProp(Self, PropertyName) then\r\n begin\r\n PropertyStore := GetPropertyJvCustomPropertyStore(PropertyName);\r\n if Assigned(PropertyStore) then\r\n if PropertyStore is TJvCustomPropertyListStore then\r\n Result := False\r\n else\r\n Result := PropertyStore.EditIntf_IsPropertySimple('')\r\n else\r\n Result := True\r\n end\r\n else\r\n Result := True;\r\nend;\r\n\r\nfunction TJvCustomPropertyStore.EditIntf_TranslatePropertyName(const PropertyName: string): string;\r\nvar\r\n s: string;\r\n I: Integer;\r\n c: string;\r\n lastLower: Boolean;\r\n LastBlank: Boolean;\r\nbegin\r\n s := '';\r\n LastLower := False;\r\n LastBlank := False;\r\n for I := 1 to Length(PropertyName) do\r\n begin\r\n c := Copy(PropertyName, i, 1);\r\n if (c = '_') or (c = '.') or (c = ' ') then\r\n begin\r\n s := s + ' ';\r\n LastBlank := True;\r\n LastLower := False;\r\n end\r\n else if (c = Uppercase(c)) then\r\n begin\r\n if LastLower and not LastBlank then\r\n begin\r\n s := s + ' ' + c;\r\n LastBlank := True;\r\n end\r\n else\r\n begin\r\n s := s + c;\r\n LastBlank := False;\r\n end;\r\n LastLower := False;\r\n end\r\n else\r\n begin\r\n s := s + c;\r\n LastLower := true;\r\n LastBlank := False;\r\n end\r\n end;\r\n Result := s;\r\nend;\r\n\r\nprocedure TJvCustomPropertyStore.UpdateChildPaths(OldPath: string);\r\nvar\r\n Index: Integer;\r\n VisPropName: string;\r\n PropName: string;\r\n PropertyStore: TJvCustomPropertyStore;\r\nbegin\r\n if Assigned(AppStorage) then\r\n begin\r\n if OldPath = '' then\r\n OldPath := AppStoragePath;\r\n for Index := 0 to GetPropCount(Self) - 1 do\r\n begin\r\n PropName := GetPropName(Self, Index);\r\n if not IgnoreProperty(PropName) then\r\n begin\r\n PropertyStore := GetPropertyJvCustomPropertyStore (PropName);\r\n if Assigned(PropertyStore) then\r\n begin\r\n VisPropName := AppStorage.TranslatePropertyName(Self, PropName, False);\r\n if (PropertyStore.AppStoragePath = AppStorage.ConcatPaths([OldPath,\r\n VisPropName])) or (PropertyStore.AppStoragePath = '') then\r\n PropertyStore.AppStoragePath :=\r\n AppStorage.ConcatPaths([AppStoragePath, VisPropName]);\r\n end;\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomPropertyStore.SetAppStoragePath(Value: string);\r\nvar\r\n OldPath: string;\r\nbegin\r\n OldPath := FAppStoragePath;\r\n if Value <> AppStoragePath then\r\n FAppStoragePath := Value;\r\n UpdateChildPaths(OldPath);\r\nend;\r\n\r\nprocedure TJvCustomPropertyStore.SetAppStorage(Value: TJvCustomAppStorage);\r\nvar\r\n Index: Integer;\r\n PropName: string;\r\n PropertyStore: TJvCustomPropertyStore;\r\nbegin\r\n if ReplaceComponentReference(Self, Value, tComponent(FAppStorage)) then\r\n begin\r\n for Index := 0 to GetPropCount(Self) - 1 do\r\n begin\r\n PropName := GetPropName(Self, Index);\r\n if not IgnoreProperty(PropName) then\r\n begin\r\n PropertyStore := GetPropertyJvCustomPropertyStore(PropName);\r\n if Assigned(PropertyStore) then\r\n PropertyStore.AppStorage := Value;\r\n end;\r\n end;\r\n UpdateChildPaths;\r\n end;\r\nend;\r\n\r\nfunction TJvCustomPropertyStore.GetIgnoreProperties: TJvIgnorePropertiesStringList;\r\nbegin\r\n Result := FIgnoreProperties;\r\nend;\r\n\r\nprocedure TJvCustomPropertyStore.SetIgnoreProperties(Value: TJvIgnorePropertiesStringList);\r\nbegin\r\n FIgnoreProperties.Assign(Value);\r\nend;\r\n\r\nfunction TJvCustomPropertyStore.GetLastSaveTime: TDateTime;\r\nbegin\r\n Result := 0;\r\n if not Enabled then\r\n Exit;\r\n if AppStoragePath = '' then\r\n Exit;\r\n try\r\n if AppStorage.ValueStored(AppStorage.ConcatPaths([AppStoragePath,\r\n cLastSaveTime])) then\r\n Result := AppStorage.ReadDateTime(AppStorage.ConcatPaths([AppStoragePath,\r\n cLastSaveTime]));\r\n except\r\n Result := 0;\r\n end;\r\nend;\r\n\r\nfunction TJvCustomPropertyStore.GetPropertyCount: Integer;\r\nbegin\r\n Result := GetPropCount(self);\r\nend;\r\n\r\nfunction TJvCustomPropertyStore.GetPropertyJvCustomPropertyStore(PropName: string): TJvCustomPropertyStore;\r\nbegin\r\n if (PropType(Self, PropName) = tkClass) and\r\n (TPersistent(GetObjectProp(Self, PropName)) is TJvCustomPropertyStore) then\r\n Result := TJvCustomPropertyStore(TPersistent(GetObjectProp(Self, PropName)))\r\n else\r\n Result := nil;\r\nend;\r\n\r\nfunction TJvCustomPropertyStore.GetPropertyName(Index: Integer): string;\r\nbegin\r\n Result := GetPropName(Self, Index);\r\nend;\r\n\r\nfunction TJvCustomPropertyStore.IgnoreProperty(const PropertyName: string):\r\n Boolean;\r\nbegin\r\n Result := (FIntIgnoreProperties.IndexOf(PropertyName) >= 0) or\r\n (IgnoreProperties.IndexOf(PropertyName) >= 0);\r\nend;\r\n\r\nprocedure TJvCustomPropertyStore.LoadProperties;\r\nvar\r\n Mutex: TJclMutex;\r\n\r\n procedure ExecuteLoadProperties;\r\n begin\r\n AppStorage.BeginUpdate;\r\n try\r\n UpdateChildPaths;\r\n FLastLoadTime := Now;\r\n if ClearBeforeLoad then\r\n Clear;\r\n if Assigned(FOnBeforeLoadProperties) then\r\n FOnBeforeLoadProperties(Self);\r\n LoadData;\r\n AppStorage.ReadPersistent(AppStoragePath, Self, True, True,\r\n CombinedIgnoreProperties);\r\n if Assigned(FOnAfterLoadProperties) then\r\n FOnAfterLoadProperties(Self);\r\n finally\r\n AppStorage.EndUpdate;\r\n end;\r\n end;\r\n\r\nbegin\r\n if not Enabled then\r\n Exit;\r\n if not Assigned(AppStorage) then\r\n Exit;\r\n\r\n if SynchronizeLoadProperties then\r\n begin\r\n if SynchronizeStoreProperties then\r\n Mutex := TJclMutex.Create(nil, False,\r\n string(B64Encode(AnsiString(RsJvPropertyStoreMutexLoadStorePropertiesProcedureName +\r\n AppStoragePath))))\r\n else\r\n Mutex := TJclMutex.Create(nil, False,\r\n string(B64Encode(AnsiString(RsJvPropertyStoreMutexLoadPropertiesProcedureName +\r\n AppStoragePath))));\r\n try\r\n if Mutex.WaitForever = wrSignaled then\r\n try\r\n ExecuteLoadProperties;\r\n finally\r\n Mutex.Release;\r\n end\r\n else\r\n raise\r\n Exception.CreateResFmt(@RsJvPropertyStoreEnterMutexTimeout, [RsJvPropertyStoreMutexStorePropertiesProcedureName]);\r\n finally\r\n FreeAndNil(Mutex);\r\n end;\r\n end\r\n else\r\n ExecuteLoadProperties;\r\nend;\r\n\r\nprocedure TJvCustomPropertyStore.StoreProperties;\r\nvar\r\n SaveProperties: Boolean;\r\n Mutex: TJclMutex;\r\n\r\n procedure ExecuteStoreProperties;\r\n begin\r\n AppStorage.BeginUpdate;\r\n try\r\n UpdateChildPaths;\r\n DisableAutoLoadDown;\r\n SaveProperties := IgnoreLastLoadTime or (GetLastSaveTime < FLastLoadTime);\r\n if SaveProperties then\r\n begin\r\n if DeleteBeforeStore then\r\n AppStorage.DeleteSubTree(AppStoragePath);\r\n if StorePropertiesNow then\r\n begin\r\n if not IgnoreLastLoadTime then\r\n AppStorage.WriteString(AppStorage.ConcatPaths([AppStoragePath,\r\n cLastSaveTime]), DateTimeToStr(Now));\r\n if Assigned(FOnBeforeStoreProperties) then\r\n FOnBeforeStoreProperties(Self);\r\n if SaveProperties then\r\n StoreData;\r\n AppStorage.WritePersistent(AppStoragePath, Self, True,\r\n CombinedIgnoreProperties);\r\n if Assigned(FOnAfterStoreProperties) then\r\n FOnAfterStoreProperties(Self);\r\n end;\r\n end;\r\n finally\r\n AppStorage.EndUpdate;\r\n end;\r\n end;\r\n\r\nbegin\r\n if not Enabled then\r\n Exit;\r\n if ReadOnly then\r\n Exit;\r\n if not Assigned(AppStorage) then\r\n Exit;\r\n\r\n if SynchronizeStoreProperties then\r\n begin\r\n if SynchronizeLoadProperties then\r\n Mutex := TJclMutex.Create(nil, False,\r\n string(B64Encode(AnsiString(RsJvPropertyStoreMutexLoadStorePropertiesProcedureName +\r\n AppStoragePath))))\r\n else\r\n Mutex := TJclMutex.Create(nil, False,\r\n string(B64Encode(AnsiString(RsJvPropertyStoreMutexStorePropertiesProcedureName +\r\n AppStoragePath))));\r\n try\r\n if Mutex.WaitForever = wrSignaled then\r\n try\r\n ExecuteStoreProperties;\r\n finally\r\n Mutex.Release;\r\n end\r\n else\r\n raise\r\n Exception.CreateResFmt(@RsJvPropertyStoreEnterMutexTimeout, [RsJvPropertyStoreMutexStorePropertiesProcedureName]);\r\n finally\r\n FreeAndNil(Mutex);\r\n end;\r\n end\r\n else\r\n ExecuteStoreProperties;\r\nend;\r\n\r\nprocedure TJvCustomPropertyStore.LoadData;\r\nbegin\r\nend;\r\n\r\nprocedure TJvCustomPropertyStore.StoreData;\r\nbegin\r\nend;\r\n\r\nfunction TJvCustomPropertyStore.StorePropertiesNow: Boolean;\r\nbegin\r\n Result := True;\r\nend;\r\n\r\nfunction TJvCustomPropertyStore.ValidateData: Boolean;\r\nvar\r\n PropName: string;\r\n PropertyStore: TJvCustomPropertyStore;\r\n Index: Integer;\r\nbegin\r\n Result := True;\r\n for Index := 0 to GetPropertyCount - 1 do\r\n begin\r\n PropName := GetPropertyName(Index);\r\n if not IgnoreProperty(PropName) then\r\n begin\r\n PropertyStore := GetPropertyJvCustomPropertyStore(PropName);\r\n if Assigned(PropertyStore) then\r\n Result := Result and PropertyStore.ValidateData;\r\n end;\r\n end;\r\nend;\r\n\r\n//=== { TJvCustomPropertyListStore } =========================================\r\n\r\nconstructor TJvCustomPropertyListStore.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FItems := CreateItemList;\r\n CreateListEntries := True;\r\n FreeObjects := True;\r\n FItemName := cItem;\r\n FIntIgnoreProperties.Add('ItemName');\r\n FIntIgnoreProperties.Add('FreeObjects');\r\n FIntIgnoreProperties.Add('CreateListEntries');\r\n FItemsObjectName := 'ItemName';\r\nend;\r\n\r\ndestructor TJvCustomPropertyListStore.Destroy;\r\nbegin\r\n Clear;\r\n FreeAndNil(FItems);\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJvCustomPropertyListStore.CreateAddObject(const aObjectName: String):\r\n TPersistent;\r\nbegin\r\n Result := CreateObject;\r\n Items.AddObject(aObjectName, Result);\r\nend;\r\n\r\nfunction TJvCustomPropertyListStore.GetItems: TStringList;\r\nbegin\r\n Result := FItems;\r\nend;\r\n\r\nprocedure TJvCustomPropertyListStore.StoreData;\r\nbegin\r\n inherited StoreData;\r\n AppStorage.WriteList(AppStoragePath, nil, Count, WriteSLOItem, DeleteSLOItems, ItemName);\r\nend;\r\n\r\nprocedure TJvCustomPropertyListStore.LoadData;\r\nbegin\r\n inherited LoadData;\r\n AppStorage.ReadList(AppStoragePath, nil, ReadSLOItem, ItemName);\r\nend;\r\n\r\nprocedure TJvCustomPropertyListStore.Clear;\r\nvar\r\n I: Integer;\r\n obj : TObject;\r\nbegin\r\n if Assigned(Items) then\r\n begin\r\n if FreeObjects then\r\n for I := Count - 1 downto 0 do\r\n if Assigned(Objects[I]) then\r\n begin\r\n obj := Objects[I];\r\n Objects[I] := nil;\r\n obj.Free;\r\n end;\r\n Items.Clear;\r\n end;\r\n inherited Clear;\r\nend;\r\n\r\nfunction TJvCustomPropertyListStore.CreateItemList: TStringList;\r\nbegin\r\n Result := TStringList.Create;\r\nend;\r\n\r\nfunction TJvCustomPropertyListStore.GetString(Index: Integer): string;\r\nbegin\r\n Result := Items.Strings[Index];\r\nend;\r\n\r\nfunction TJvCustomPropertyListStore.GetObject(Index: Integer): TObject;\r\nbegin\r\n Result := Items.Objects[Index];\r\nend;\r\n\r\nprocedure TJvCustomPropertyListStore.SetString(Index: Integer; Value: string);\r\nbegin\r\n Items.Strings[Index] := Value;\r\nend;\r\n\r\nprocedure TJvCustomPropertyListStore.SetObject(Index: Integer; Value: TObject);\r\nbegin\r\n Items.Objects[Index] := Value;\r\nend;\r\n\r\nfunction TJvCustomPropertyListStore.GetCount: Integer;\r\nbegin\r\n if Assigned(Items) then\r\n Result := Items.Count\r\n else\r\n Result := -1;\r\nend;\r\n\r\nfunction TJvCustomPropertyListStore.GetSorted: Boolean;\r\nbegin\r\n Result := FItems.Sorted;\r\nend;\r\n\r\nprocedure TJvCustomPropertyListStore.SetSorted(Value: Boolean);\r\nbegin\r\n FItems.Sorted := Value;\r\nend;\r\n\r\nfunction TJvCustomPropertyListStore.GetDuplicates: TDuplicates;\r\nbegin\r\n Result := FItems.Duplicates;\r\nend;\r\n\r\nprocedure TJvCustomPropertyListStore.SetDuplicates(Value: TDuplicates);\r\nbegin\r\n FItems.Duplicates := Value;\r\nend;\r\n\r\nprocedure TJvCustomPropertyListStore.ReadSLOItem(Sender: TJvCustomAppStorage;\r\n const Path: string; const List: TObject; const Index: Integer; const ItemName:\r\n string);\r\nvar\r\n NewObject: TObject;\r\n NewObjectName: string;\r\n Obj: TObject;\r\nbegin\r\n if Index >= Count then\r\n begin\r\n if not CreateListEntries then\r\n Exit;\r\n NewObject := CreateObject;\r\n if Assigned(NewObject) then\r\n begin\r\n if NewObject is TJvCustomPropertyStore then\r\n begin\r\n TJvCustomPropertyStore(NewObject).AppStoragePath :=\r\n Sender.ConcatPaths([Path, Sender.ItemNameIndexPath(ItemName, Index)]);\r\n TJvCustomPropertyStore(NewObject).AppStorage := Sender;\r\n TJvCustomPropertyStore(NewObject).LoadProperties;\r\n end\r\n else if NewObject is TPersistent then\r\n Sender.ReadPersistent(Sender.ConcatPaths([Path,\r\n Sender.ItemNameIndexPath(ItemName, Index)]),\r\n TPersistent(NewObject), True, True, CombinedIgnoreProperties);\r\n if Sender.ValueStored(Sender.ConcatPaths([Path,\r\n Sender.ItemNameIndexPath(ItemName, Index), ItemsObjectName])) then\r\n NewObjectName := Sender.ReadString(Sender.ConcatPaths([Path,\r\n Sender.ItemNameIndexPath(ItemName, Index), ItemsObjectName]))\r\n else\r\n NewObjectName := '';\r\n Items.AddObject(NewObjectName, NewObject);\r\n end\r\n else\r\n Items.Add(Sender.ReadString(Sender.ConcatPaths([Path,\r\n Sender.ItemNameIndexPath(ItemName, Index)])))\r\n end\r\n else if Assigned(Objects[Index]) then\r\n begin\r\n Obj := Objects[Index];\r\n if Obj is TJvCustomPropertyStore then\r\n begin\r\n TJvCustomPropertyStore(Obj).AppStoragePath :=\r\n Sender.ConcatPaths([Path, Sender.ItemNameIndexPath(ItemName, Index)]);\r\n TJvCustomPropertyStore(Obj).AppStorage := Sender;\r\n TJvCustomPropertyStore(Obj).LoadProperties;\r\n end\r\n else if Obj is TPersistent then\r\n Sender.ReadPersistent(Sender.ConcatPaths([Path,\r\n Sender.ItemNameIndexPath(ItemName, Index)]),\r\n TPersistent(Obj), True, True, CombinedIgnoreProperties);\r\n if Sender.ValueStored(Sender.ConcatPaths([Path,\r\n Sender.ItemNameIndexPath(ItemName, Index), ItemsObjectName])) then\r\n Strings[Index] := Sender.ReadString(Sender.ConcatPaths([Path,\r\n Sender.ItemNameIndexPath(ItemName, Index), ItemsObjectName]))\r\n else\r\n Strings[Index] := '';\r\n end\r\n else\r\n Strings[Index] := Sender.ReadString(Sender.ConcatPaths([Path,\r\n Sender.ItemNameIndexPath(ItemName, Index)]));\r\nend;\r\n\r\nprocedure TJvCustomPropertyListStore.WriteSLOItem(Sender: TJvCustomAppStorage;\r\n const Path: string; const List: TObject; const Index: Integer; const ItemName:\r\n string);\r\nvar\r\n Obj : TObject;\r\nbegin\r\n Obj := Objects[Index];\r\n if Assigned(Obj) then\r\n begin\r\n if Obj is TJvCustomPropertyStore then\r\n begin\r\n TJvCustomPropertyStore(Obj).AppStoragePath :=\r\n Sender.ConcatPaths([Path, Sender.ItemNameIndexPath(ItemName, Index)]);\r\n TJvCustomPropertyStore(Obj).AppStorage := Sender;\r\n TJvCustomPropertyStore(Obj).StoreProperties;\r\n end\r\n else if Obj is TPersistent then\r\n Sender.WritePersistent(Sender.ConcatPaths([Path,\r\n Sender.ItemNameIndexPath(ItemName, Index)]),\r\n TPersistent(Obj), True, CombinedIgnoreProperties);\r\n if Strings[Index] <> '' then\r\n Sender.WriteString(Sender.ConcatPaths([Path,\r\n Sender.ItemNameIndexPath(ItemName, Index), ItemsObjectName]), Strings[Index]);\r\n end\r\n else\r\n Sender.WriteString(Sender.ConcatPaths([Path,\r\n Sender.ItemNameIndexPath(ItemName, Index)]), Strings[Index]);\r\nend;\r\n\r\nprocedure TJvCustomPropertyListStore.DeleteSLOItems(Sender: TJvCustomAppStorage;\r\n const Path: string; const List: TObject; const First, Last: Integer; const\r\n ItemName: string);\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := Last downto first do\r\n Sender.DeleteValue(Sender.ConcatPaths([Path,\r\n Sender.ItemNameIndexPath(ItemName, i)]));\r\nend;\r\n\r\nfunction TJvCustomPropertyListStore.IndexOf(const s: string): Integer;\r\nbegin\r\n Result := FItems.IndexOf(s);\r\nend;\r\n\r\nfunction TJvCustomPropertyListStore.IndexOfObject(AObject: TObject): Integer;\r\nbegin\r\n Result := FItems.IndexOfObject(AObject);\r\nend;\r\n\r\nprocedure TJvCustomPropertyListStore.ListEditIntf_MoveObjectPosition(CurIndex,\r\n NewIndex: Integer);\r\nbegin\r\n if (CurIndex >= 0) and (CurIndex < Count) and\r\n (NewIndex >= 0) and (NewIndex < Count) then\r\n Items.Move(CurIndex, NewIndex);\r\nend;\r\n\r\nfunction TJvCustomPropertyListStore.ListEditIntf_CloneNewObject(Index:\r\n integer): TPersistent;\r\nvar\r\n Obj: TObject;\r\nbegin\r\n if (Index >= 0) and (Index < Count) and Assigned(Objects[Index]) then\r\n begin\r\n Obj := Objects[Index];\r\n if (Obj is TJvCustomPropertyStore) then\r\n begin\r\n Result := TPersistent(TJvCustomPropertyStore(Obj).Clone(self));\r\n Items.AddObject ('New '+ItemName, Result);\r\n end\r\n else\r\n begin\r\n Result := ListEditIntf_CreateNewObject;\r\n if (Obj is TPersistent)then\r\n TPersistent(Result).Assign(TPersistent(Obj));\r\n end\r\n end\r\n else\r\n Result := nil;\r\nend;\r\n\r\nfunction TJvCustomPropertyListStore.ListEditIntf_CreateNewObject: TPersistent;\r\nbegin\r\n Result := CreateObject;\r\n Items.AddObject ('New '+ItemName, Result);\r\nend;\r\n\r\nprocedure TJvCustomPropertyListStore.ListEditIntf_DeleteObject(Index: integer);\r\nvar obj : TObject;\r\nbegin\r\n if (Index >= 0) and (Index < Count) then\r\n begin\r\n if Assigned(Objects[Index]) then\r\n begin\r\n obj := Objects[Index];\r\n Items.Objects[Index] := nil;\r\n obj.Free;\r\n end;\r\n Items.Delete(Index);\r\n end;\r\nend;\r\n\r\nfunction TJvCustomPropertyListStore.ListEditIntf_GetObject(Index: integer):\r\n TPersistent;\r\nbegin\r\n if (Index >= 0) and (Index < Count) and (Objects[Index] is TPersistent) then\r\n Result := TPersistent(Objects[Index])\r\n else\r\n Result := nil;\r\n ;\r\nend;\r\n\r\nfunction TJvCustomPropertyListStore.ListEditIntf_ObjectCount: integer;\r\nbegin\r\n Result := Count;\r\nend;\r\n\r\nfunction StringListSortCompareDesc(List: TStringList; Index1, Index2: Integer): Integer;\r\nbegin\r\n if List[Index1] = List[Index2] then\r\n Result := 0\r\n else if List[Index1] < List[Index2] then\r\n Result := 1\r\n else\r\n Result := -1;\r\nend;\r\n\r\nprocedure StorePropertyStorageToAppStorage(iPropertyStore: TJvCustomPropertyStore; iAppStorage: TJvCustomAppStorage; const\r\n iAppStoragePath: string);\r\nvar OldAppStorage : TJvCustomAppStorage;\r\n OldAppStoragePath : String;\r\nbegin\r\n if not Assigned(iPropertyStore) or not Assigned(iAppStorage) then\r\n Exit;\r\n OldAppStoragePath := iPropertyStore.AppStoragePath;\r\n OldAppStorage := iPropertyStore.AppStorage;\r\n try\r\n iPropertyStore.AppStoragePath := iAppStoragePath;\r\n iPropertyStore.AppStorage := iAppStorage;\r\n iPropertyStore.AppStorage.Reload;\r\n iPropertyStore.StoreProperties;\r\n iPropertyStore.AppStorage.Flush;\r\n finally\r\n iPropertyStore.AppStoragePath := OldAppStoragePath;\r\n iPropertyStore.AppStorage := OldAppStorage;\r\n end;\r\nend;\r\n\r\nfunction TJvCustomPropertyListStore.ListEditIntf_IndexOfObject(AObject : TPersistent): Integer;\r\nbegin\r\n Result := Items.IndexOfObject(AObject);\r\nend;\r\n\r\nprocedure TJvCustomPropertyListStore.ListEditIntf_SortObjects(iAscending :\r\n Boolean);\r\nbegin\r\n if iAscending then\r\n FItems.Sort\r\n else\r\n FItems.CustomSort(StringListSortCompareDesc);\r\nend;\r\n\r\nfunction TJvCustomPropertyListStore.ValidateData: Boolean;\r\nvar\r\n Index: Integer;\r\nbegin\r\n Result := True;\r\n for Index := 0 to Count - 1 do\r\n if Assigned(Objects[Index]) and (Objects[Index] is TJvCustomPropertyStore) then\r\n Result := Result and TJvCustomPropertyStore(Objects[Index]).ValidateData;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvPropertyStoreEditor.dfm", "content": "object JvPropertyStoreEditorForm: TJvPropertyStoreEditorForm\r\n Left = 0\r\n Top = 0\r\n BorderIcons = []\r\n ClientHeight = 541\r\n ClientWidth = 751\r\n Color = clBtnFace\r\n Font.Charset = DEFAULT_CHARSET\r\n Font.Color = clWindowText\r\n Font.Height = -11\r\n Font.Name = 'Tahoma'\r\n Font.Style = []\r\n OldCreateOrder = False\r\n Position = poScreenCenter\r\n OnCreate = FormCreate\r\n OnDestroy = FormDestroy\r\n PixelsPerInch = 96\r\n TextHeight = 13\r\nend\r\n" }, { "path": "External/Jedi/Jvcl/run/JvPropertyStoreEditor.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvPropertyStoreEditor.pas, released on 2008-01-01.\r\n\r\nThe Initial Developer of the Original Code is Jens Fudickar\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\n Jens Fudickar [jens dott fudickar att oratool dott de]\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvPropertyStoreEditor.pas 13173 2011-11-19 12:43:58Z ahuser $\r\nunit JvPropertyStoreEditor;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Variants,\r\n Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,\r\n Dialogs, ComCtrls,\r\n JvComponent, ExtCtrls, JvExControls,\r\n JvInspector, StdCtrls, JvPropertyStore,\r\n JvPropertyStoreEditorIntf, JvDynControlEngineIntf, ActnList, Menus;\r\n\r\ntype\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvPropertyStoreEditorControl = class(TJvCustomControl)\r\n procedure JvInspectorAfterItemCreate(Sender: TObject; Item:\r\n TJvCustomInspectorItem);\r\n procedure JvInspectorBeforeItemCreate(Sender: TObject; Data:\r\n TJvCustomInspectorData; var ItemClass: TJvInspectorItemClass);\r\n procedure ListBoxOnClick(Sender: TObject);\r\n procedure ListBoxOnEnter(Sender: TObject);\r\n procedure ListBoxOnKeyPress(Sender: TObject; var Key: Char);\r\n procedure ListBoxOnMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);\r\n procedure ListCopyActionExecute(Sender: TObject);\r\n procedure ListDeleteActionExecute(Sender: TObject);\r\n procedure ListDownActionExecute(Sender: TObject);\r\n procedure ListEditActionExecute(Sender: TObject);\r\n procedure ListInsertActionExecute(Sender: TObject);\r\n procedure ListSortDownActionExecute(Sender: TObject);\r\n procedure ListSortUpActionExecute(Sender: TObject);\r\n procedure ListUpActionExecute(Sender: TObject);\r\n procedure ParentListCopyActionExecute(Sender: TObject);\r\n procedure ParentListDeleteActionExecute(Sender: TObject);\r\n procedure ParentListDownActionExecute(Sender: TObject);\r\n procedure ParentListInsertActionExecute(Sender: TObject);\r\n procedure ParentListSortDownActionExecute(Sender: TObject);\r\n procedure ParentListSortUpActionExecute(Sender: TObject);\r\n procedure ParentListUpActionExecute(Sender: TObject);\r\n procedure PropertyStoreTreeViewChange(Sender: TObject; Node: TTreeNode);\r\n procedure PropertyStoreTreeViewChanging(Sender: TObject; Node: TTreeNode; var\r\n AllowChange: Boolean);\r\n procedure PropertyStoreTreeViewEnter(Sender: TObject);\r\n procedure RTTIInspectorEnter(Sender: TObject);\r\n private\r\n FInspectedObject: TPersistent;\r\n FInspectedObjectEditorHandlerIntf: IJvPropertyEditorHandler;\r\n FInspectedObjectListEditorHandlerIntf: IJvPropertyListEditorHandler;\r\n FInspectedObjectListItemIndex: Integer;\r\n FInspectedParentObject: TPersistent;\r\n FInspectedParentObjectListEditorHandlerIntf: IJvPropertyListEditorHandler;\r\n FPropertyStore: TComponent;\r\n InfoGroupBoxDynControlCaptionIntf: IJvDynControlCaption;\r\n InfoMemo: TWinControl;\r\n InfoMemoDynControlDataIntf: IJvDynControlData;\r\n InfoPanel: TWinControl;\r\n Inspector: TWinControl;\r\n InspectorPanel: TWinControl;\r\n ListBoxControlItemIndexIntf: IJvDynControlItemIndex;\r\n ListBoxControlItemsIntf: IJvDynControlItems;\r\n ListButtonPanel: TWinControl;\r\n ListCopyAction: TAction;\r\n ListCopyMenu: TMenuItem;\r\n ListDeleteAction: TAction;\r\n ListDeleteMenu: TMenuItem;\r\n ListDownAction: TAction;\r\n ListDownMenu: TMenuItem;\r\n ListEditAction: TAction;\r\n ListInsertAction: TAction;\r\n ListInsertMenu: TMenuItem;\r\n ListInspectorPanel: TWinControl;\r\n ListLineMenu: TMenuItem;\r\n ListPanel: TWinControl;\r\n ListPopupMenu: TPopupMenu;\r\n ListSortDownAction: TAction;\r\n ListSortDownMenu: TMenuItem;\r\n ListSortUpAction: TAction;\r\n ListSortUpMenu: TMenuItem;\r\n ListSplitter: TSplitter;\r\n ListUpAction: TAction;\r\n ListUpMenu: TMenuItem;\r\n ParentListButtonPanel: TWinControl;\r\n ParentListCopyAction: TAction;\r\n ParentListDeleteAction: TAction;\r\n ParentListDownAction: TAction;\r\n ParentListInsertAction: TAction;\r\n ParentListSortDownAction: TAction;\r\n ParentListSortUpAction: TAction;\r\n ParentListUpAction: TAction;\r\n PropertyStoreTreeViewIntf: IJvDynControlTreeView;\r\n RTTIInspectorControlIntf: IJvDynControlRTTIInspectorControl;\r\n TreePanel: TWinControl;\r\n TreeSplitter: TSplitter;\r\n procedure ChangeInspectedObjectListEditorHandlerIntf(iObject: TObject);\r\n procedure ChangeInspectedParentObjectListEditorHandlerIntf(iObject: TObject);\r\n procedure FillListBox;\r\n function GetPropCount(Instance: TPersistent): Integer;\r\n function GetPropName(Instance: TPersistent; Index: Integer): string;\r\n procedure RTTIInspectorOnCanResize(Sender: TObject; var NewWidth, NewHeight: Integer; var Resize: Boolean);\r\n procedure SetActionsEnabled;\r\n procedure SetInspectedObject(const Value: TPersistent);\r\n procedure SetInspectedObjectListEditorHandlerIntf(const Value: IJvPropertyListEditorHandler);\r\n procedure SetInspectedObjectListItemIndex(const Value: Integer);\r\n procedure SetInspectedParentObject(const Value: TPersistent);\r\n procedure SetInspectedParentObjectListEditorHandlerIntf(const Value: IJvPropertyListEditorHandler);\r\n procedure SetPropertyStore(const Value: TComponent);\r\n function ShowPropertyInTreeView(PropObject: TObject; const PropertyName: string): Boolean;\r\n property InspectedObject: TPersistent read FInspectedObject write SetInspectedObject;\r\n property InspectedObjectEditorHandlerIntf: IJvPropertyEditorHandler read FInspectedObjectEditorHandlerIntf;\r\n property InspectedObjectListEditorHandlerIntf: IJvPropertyListEditorHandler read FInspectedObjectListEditorHandlerIntf\r\n write SetInspectedObjectListEditorHandlerIntf;\r\n property InspectedObjectListItemIndex: Integer read FInspectedObjectListItemIndex write SetInspectedObjectListItemIndex;\r\n property InspectedParentObject: TPersistent read FInspectedParentObject write SetInspectedParentObject;\r\n property InspectedParentObjectListEditorHandlerIntf: IJvPropertyListEditorHandler read\r\n FInspectedParentObjectListEditorHandlerIntf write SetInspectedParentObjectListEditorHandlerIntf;\r\n protected\r\n procedure CreateControls;\r\n procedure DestroyControls;\r\n procedure FillTreeView(GotoNodeObject: TPersistent = nil);\r\n procedure FillTreeViewByComponent(TreeNodes: TTreeNodes; Parent: TTreeNode; aPropertyStore: TPersistent);\r\n procedure Notification(AComponent: TComponent; Operation: TOperation); override;\r\n function OnDisplayProperty(const aPropertyName : String): Boolean;\r\n function OnInspectorTranslatePropertyName(const aPropertyName : String): string;\r\n procedure OnPropertyChange(var OldPropertyName, NewPropertyName : string);\r\n function OnTranslatePropertyName(const aPropertyName : String): string;\r\n procedure SetInformation(const iCaption, iInfo: string);\r\n public\r\n destructor Destroy; override;\r\n procedure GotoEditObject(EditObject: TPersistent);\r\n published\r\n property Align;\r\n property Anchors;\r\n property AutoSize;\r\n property BevelInner;\r\n property BevelOuter;\r\n property BevelWidth;\r\n property BiDiMode;\r\n property BorderWidth;\r\n property Color;\r\n property Constraints;\r\n property DockSite;\r\n property DragCursor;\r\n property DragKind;\r\n property Enabled;\r\n property Font;\r\n property OnCanResize;\r\n property OnDockDrop;\r\n property OnDockOver;\r\n property OnEndDock;\r\n property OnEnter;\r\n property OnExit;\r\n property OnGetSiteInfo;\r\n property OnResize;\r\n property OnStartDock;\r\n property OnUnDock;\r\n {$IFDEF COMPILER7_UP}\r\n property ParentBackground default True;\r\n {$ENDIF COMPILER7_UP}\r\n property ParentBiDiMode;\r\n property ParentColor;\r\n property ParentFont;\r\n property ParentShowHint;\r\n property PropertyStore: TComponent read FPropertyStore write SetPropertyStore;\r\n property ShowHint;\r\n property TabOrder;\r\n property TabStop;\r\n property UseDockManager default True;\r\n property Visible;\r\n end;\r\n\r\ntype\r\n TJvPropertyStoreEditorForm = class(TJvForm)\r\n procedure FormCreate(Sender: TObject);\r\n procedure FormDestroy(Sender: TObject);\r\n private\r\n FPropertyStore: TComponent;\r\n FPropertyStoreEditorControl: TJvPropertyStoreEditorControl;\r\n procedure CancelButtonClick(Sender: TObject);\r\n procedure IntOnShow(Sender: TObject);\r\n procedure OkButtonClick(Sender: TObject);\r\n procedure SetPropertyStore(const Value: TComponent);\r\n protected\r\n procedure CreateFormControls;\r\n procedure DestroyFormControls;\r\n public\r\n property PropertyStore: TComponent read FPropertyStore write SetPropertyStore;\r\n end;\r\n\r\nfunction EditPropertyStore(PropertyStore: TJvCustomPropertyStore): Boolean;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvPropertyStoreEditor.pas $';\r\n Revision: '$Revision: 13173 $';\r\n Date: '$Date: 2011-11-19 13:43:58 +0100 (sam. 19 nov. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n JvResources,\r\n TypInfo, JvDynControlEngine, JvJVCLUtils;\r\n\r\n{$R *.dfm}\r\n\r\ntype tAccessControl = class(TControl);\r\n\r\n\r\nfunction EditPropertyStore(PropertyStore: TJvCustomPropertyStore): Boolean;\r\nvar\r\n JvPropertyStoreEditorForm: TJvPropertyStoreEditorForm;\r\n SavePropertyStore : TJvCustomPropertyStore;\r\nbegin\r\n Result := false;\r\n if not Assigned(PropertyStore) then\r\n Exit;\r\n SavePropertyStore := PropertyStore.Clone(nil);\r\n JvPropertyStoreEditorForm := TJvPropertyStoreEditorForm.Create(Application);\r\n try\r\n JvPropertyStoreEditorForm.PropertyStore := SavePropertyStore;\r\n Result := JvPropertyStoreEditorForm.ShowModal = mrOk;\r\n if Result then\r\n PropertyStore.Assign(SavePropertyStore);\r\n finally\r\n SavePropertyStore.Free;\r\n JvPropertyStoreEditorForm.Free;\r\n end;\r\nend;\r\n\r\nprocedure TJvPropertyStoreEditorForm.CancelButtonClick(Sender: TObject);\r\nbegin\r\n // Do Not Remove\r\nend;\r\n\r\nprocedure TJvPropertyStoreEditorForm.CreateFormControls;\r\nvar BottomPanel: TWinControl;\r\n Button: TButton;\r\n ITmpBevelBorder: IJvDynControlBevelBorder;\r\nbegin\r\n BottomPanel := DefaultDynControlEngine.CreatePanelControl(Self, Self, 'BottomPanel', '', alBottom);\r\n if Supports(BottomPanel, IJvDynControlBevelBorder, ITmpBevelBorder) then\r\n ITmpBevelBorder.ControlSetBevelOuter(bvNone);\r\n BottomPanel.TabOrder := 0;\r\n Button := DefaultDynControlEngine.CreateButton(Self, BottomPanel, 'OKButton', RSPropertyStoreEditorDialogButtonOk, '', OkButtonClick);\r\n Button.Top := 3;\r\n Button.Width := 75;\r\n Button.Height := 25;\r\n Button.Left := BottomPanel.Width-2*Button.Width-10;\r\n Button.Anchors := [akTop, akRight];\r\n Button.ModalResult := mrOk;\r\n Button := DefaultDynControlEngine.CreateButton(Self, BottomPanel, 'CancelButton', RSPropertyStoreEditorDialogButtonCancel, '', CancelButtonClick);\r\n Button.Top := 3;\r\n Button.Width := 75;\r\n Button.Height := 25;\r\n Button.Left := BottomPanel.Width-Button.Width-5;\r\n Button.Anchors := [akTop, akRight];\r\n Button.ModalResult := mrCancel;\r\n BottomPanel.Height := 2*Button.Top+Button.Height+1;\r\n\r\n FPropertyStoreEditorControl:= TJvPropertyStoreEditorControl.Create(self);\r\n FPropertyStoreEditorControl.Parent := Self;\r\n FPropertyStoreEditorControl.Align := alClient;\r\n\r\n Caption := RSPropertyStoreEditorDialogCaptionEditProperties;\r\n\r\nend;\r\n\r\nprocedure TJvPropertyStoreEditorForm.DestroyFormControls;\r\nbegin\r\n FreeAndNil(FPropertyStoreEditorControl);\r\nend;\r\n\r\nprocedure TJvPropertyStoreEditorForm.FormCreate(Sender: TObject);\r\nbegin\r\n CreateFormControls;\r\n OnShow := IntOnShow;\r\nend;\r\n\r\nprocedure TJvPropertyStoreEditorForm.FormDestroy(Sender: TObject);\r\nbegin\r\n DestroyFormControls;\r\nend;\r\n\r\nprocedure TJvPropertyStoreEditorForm.IntOnShow(Sender: TObject);\r\nbegin\r\n if Assigned(FPropertyStoreEditorControl) then\r\n begin\r\n FPropertyStoreEditorControl.PropertyStore := PropertyStore;\r\n end;\r\nend;\r\n\r\nprocedure TJvPropertyStoreEditorForm.OkButtonClick(Sender: TObject);\r\nbegin\r\n // Do Not Remove\r\nend;\r\n\r\nprocedure TJvPropertyStoreEditorForm.SetPropertyStore(const Value: TComponent);\r\nbegin\r\n FPropertyStore := Value;\r\n if Assigned(FPropertyStoreEditorControl) then\r\n FPropertyStoreEditorControl.PropertyStore := PropertyStore;\r\nend;\r\n\r\ntype tAccessCustomPanel = class(tCustomPanel);\r\n\r\n\r\ndestructor TJvPropertyStoreEditorControl.Destroy;\r\nbegin\r\n DestroyControls;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvPropertyStoreEditorControl.ChangeInspectedObjectListEditorHandlerIntf(iObject: TObject);\r\nbegin\r\n Supports(iObject, IJvPropertyListEditorHandler, FInspectedObjectListEditorHandlerIntf);\r\n InspectedObjectListEditorHandlerIntf := FInspectedObjectListEditorHandlerIntf; // Wegen dem Set-Aufruf\r\nend;\r\n\r\nprocedure TJvPropertyStoreEditorControl.ChangeInspectedParentObjectListEditorHandlerIntf(iObject: TObject);\r\nbegin\r\n Supports(iObject, IJvPropertyListEditorHandler, FInspectedParentObjectListEditorHandlerIntf);\r\n InspectedParentObjectListEditorHandlerIntf := FInspectedParentObjectListEditorHandlerIntf; // Wegen dem Set-Aufruf\r\nend;\r\n\r\nprocedure TJvPropertyStoreEditorControl.CreateControls;\r\nvar\r\n TreeView: TWinControl;\r\n EditPanel: TWinControl;\r\n DynControlDblClick : IJvDynControlDblClick;\r\n ListBox: TWinControl;\r\n InfoGroupBox: TWinControl;\r\n InfoMemoPanel: TWinControl;\r\n DynControlMemo: IJvDynControlMemo;\r\n DynControlReadOnly: IJvDynControlReadOnly;\r\n DynControlKey: IJvDynControlKey;\r\n DynControlMouse: IJvDynControlMouse;\r\n DynControl: IJvDynControl;\r\n BtnLeft : Integer;\r\n\r\n function CreateBtn(AOwner: TComponent; AParentControl: TWinControl; const AButtonName, ACaption, AHint: string; AOnClick:\r\n TNotifyEvent; AAction : TAction;var ALeft : Integer; AWidth:Integer): TButton;\r\n begin\r\n Result := DefaultDynControlEngine.CreateButton(AOwner, AParentControl, AButtonName, ACaption, AHint, AOnClick);\r\n Result.Action := aAction;\r\n Result.Left := aLeft;\r\n Result.Width := aWidth;\r\n aLeft := aLeft + aWidth;\r\n end;\r\n\r\nbegin\r\n TreePanel := DefaultDynControlEngine.CreatePanelControl(Self, Self, 'TreePanel', '', alLeft);\r\n TreePanel.Width := 250;\r\n if TreePanel is TCustomPanel then\r\n begin\r\n tAccessCustomPanel(TreePanel).BevelOuter := bvNone;\r\n tAccessCustomPanel(TreePanel).BorderWidth := 3;\r\n end;\r\n\r\n TreeView := DefaultDynControlEngine.CreateTreeViewControl(Self, TreePanel, 'PropertyStoreTreeViewIntf');\r\n Supports(TreeView, IJvDynControlTreeView, PropertyStoreTreeViewIntf);\r\n TreeView.Align := alClient;\r\n PropertyStoreTreeViewIntf.ControlSetReadOnly (True);\r\n PropertyStoreTreeViewIntf.ControlSetHotTrack (True);\r\n PropertyStoreTreeViewIntf.ControlSetOnChange (PropertyStoreTreeViewChange);\r\n PropertyStoreTreeViewIntf.ControlSetOnChanging (PropertyStoreTreeViewChanging);\r\n PropertyStoreTreeViewIntf.ControlSetSortType(stNone);\r\n Supports(TreeView, IJvDynControl, DynControl);\r\n DynControl.ControlSetOnEnter(PropertyStoreTreeViewEnter);\r\n if Supports(TreeView, IJvDynControlMouse, DynControlMouse) then\r\n DynControlMouse.ControlSetOnMouseDown(ListBoxOnMouseDown);\r\n\r\n TreeSplitter := TSplitter.Create(Self);\r\n TreeSplitter.Align := alLeft;\r\n TreeSplitter.Parent := Self;\r\n TreeSplitter.Left := TreePanel.Left+TreePanel.Width+1;\r\n EditPanel := DefaultDynControlEngine.CreatePanelControl(Self, Self, 'EditPanel', '', alClient);\r\n if EditPanel is TPanel then\r\n begin\r\n TPanel(EditPanel).BevelOuter := bvNone;\r\n TPanel(EditPanel).BorderWidth := 3;\r\n end;\r\n InfoPanel := DefaultDynControlEngine.CreatePanelControl(Self, Self, 'InfoPanel', '', alBottom);\r\n if InfoPanel is TCustomPanel then\r\n begin\r\n tAccessCustomPanel(InfoPanel).BevelOuter := bvNone;\r\n end;\r\n InfoPanel.Height := 100;\r\n InfoGroupBox := DefaultDynControlEngine.CreateGroupBoxControl(Self, InfoPanel, 'InfoGroupBox', 'Info');\r\n InfoGroupBox.Align := alClient;\r\n Supports(InfoGroupBox, IJvDynControlCaption, InfoGroupBoxDynControlCaptionIntf);\r\n InfoMemoPanel := DefaultDynControlEngine.CreatePanelControl(Self, InfoGroupBox, 'InfoMemoPanel', '', alClient);\r\n if InfoMemoPanel is TCustomPanel then\r\n begin\r\n tAccessCustomPanel(InfoMemoPanel).BevelOuter := bvNone;\r\n tAccessCustomPanel(InfoMemoPanel).BorderWidth := 3;\r\n end;\r\n InfoMemo := DefaultDynControlEngine.CreateMemoControl(Self, InfoGroupbox, 'InfoMemo');\r\n InfoMemo.Align := alClient;\r\n if Supports(InfoMemo, IJvDynControlMemo, DynControlMemo) then\r\n begin\r\n DynControlMemo.ControlSetWordWrap(True);\r\n DynControlMemo.ControlSetScrollbars(ssVertical);\r\n end;\r\n if Supports(InfoMemo, IJvDynControlReadOnly, DynControlReadOnly) then\r\n DynControlReadOnly.ControlSetReadOnly(True);\r\n Supports(InfoMemo, IJvDynControlData, InfoMemoDynControlDataIntf);\r\n\r\n ListInsertAction := TAction.Create(Self);\r\n ListInsertAction.Caption := RSPropertyStoreEditorListButtonInsert;\r\n ListInsertAction.OnExecute := ListInsertActionExecute;\r\n ListCopyAction := TAction.Create(Self);\r\n ListCopyAction.Caption := RSPropertyStoreEditorListButtonCopy;\r\n ListCopyAction.OnExecute := ListCopyActionExecute;\r\n ListEditAction := TAction.Create(Self);\r\n ListEditAction.Caption := RSPropertyStoreEditorListButtonEdit;\r\n ListEditAction.OnExecute := ListEditActionExecute;\r\n ListDeleteAction := TAction.Create(Self);\r\n ListDeleteAction.Caption := RSPropertyStoreEditorListButtonDelete;\r\n ListDeleteAction.OnExecute := ListDeleteActionExecute;\r\n ListUpAction := TAction.Create(Self);\r\n ListUpAction.Caption := RSPropertyStoreEditorListButtonUp;\r\n ListUpAction.OnExecute := ListUpActionExecute;\r\n ListDownAction := TAction.Create(Self);\r\n ListDownAction.Caption := RSPropertyStoreEditorListButtonDown;\r\n ListDownAction.OnExecute := ListDownActionExecute;\r\n ListSortUpAction := TAction.Create(Self);\r\n ListSortUpAction.Caption := RSPropertyStoreEditorListButtonSortUp;\r\n ListSortUpAction.OnExecute := ListSortUpActionExecute;\r\n ListSortDownAction := TAction.Create(Self);\r\n ListSortDownAction.Caption := RSPropertyStoreEditorListButtonSortDown;\r\n ListSortDownAction.OnExecute := ListSortDownActionExecute;\r\n\r\n ListPopupMenu := TPopupMenu.Create(Self);\r\n ListInsertMenu := TMenuItem.Create(Self);\r\n ListInsertMenu.Action := ListInsertAction;\r\n ListPopupMenu.Items.Add(ListInsertMenu);\r\n ListCopyMenu := TMenuItem.Create(Self);\r\n ListCopyMenu.Action := ListCopyAction;\r\n ListPopupMenu.Items.Add(ListCopyMenu);\r\n ListDeleteMenu := TMenuItem.Create(Self);\r\n ListDeleteMenu.Action := ListDeleteAction;\r\n// ListPopupMenu.Items.Add(ListDeleteMenu);\r\n ListLineMenu := NewLine;\r\n ListPopupMenu.Items.Add(ListLineMenu);\r\n ListUpMenu := TMenuItem.Create(Self);\r\n ListUpMenu.Action := ListUpAction;\r\n ListPopupMenu.Items.Add(ListUpMenu);\r\n ListDownMenu := TMenuItem.Create(Self);\r\n ListDownMenu.Action := ListDownAction;\r\n ListPopupMenu.Items.Add(ListDownMenu);\r\n ListSortUpMenu := TMenuItem.Create(Self);\r\n ListSortUpMenu.Action := ListSortUpAction;\r\n ListPopupMenu.Items.Add(ListSortUpMenu);\r\n ListSortDownMenu := TMenuItem.Create(Self);\r\n ListSortDownMenu.Action := ListSortDownAction;\r\n ListPopupMenu.Items.Add(ListSortDownMenu);\r\n\r\n ListPanel := DefaultDynControlEngine.CreatePanelControl(Self, EditPanel, 'ListPanel', '', alClient);\r\n if ListPanel is TPanel then\r\n TPanel(ListPanel).BevelOuter := bvNone;\r\n ListInspectorPanel := DefaultDynControlEngine.CreatePanelControl(Self, ListPanel, 'ListInspectorPanel', '', alTop);\r\n if ListInspectorPanel is TPanel then\r\n TPanel(ListInspectorPanel).BevelOuter := bvNone;\r\n ListInspectorPanel.Height := 141;\r\n ListSplitter := TSplitter.Create (Self);\r\n ListSplitter.Parent := ListPanel;\r\n ListSplitter.Align := alTop;\r\n ListSplitter.Cursor := crVSplit;\r\n ListButtonPanel := DefaultDynControlEngine.CreatePanelControl(Self, ListPanel, 'ListButtonPanel', '', alTop);\r\n ListButtonPanel.Height := 25;\r\n if ListButtonPanel is TPanel then\r\n TPanel(ListButtonPanel).BevelOuter := bvNone;\r\n BtnLeft := 0;\r\n CreateBtn(Self, ListButtonPanel, 'ListInsertButton', RSPropertyStoreEditorListButtonInsert, '', ListInsertActionExecute, ListInsertAction, BtnLeft, 40);\r\n CreateBtn(Self, ListButtonPanel, 'ListCopyButton', RSPropertyStoreEditorListButtonCopy, '', ListCopyActionExecute, ListCopyAction, BtnLeft, 40);\r\n CreateBtn(Self, ListButtonPanel, 'ListEditButton', RSPropertyStoreEditorListButtonEdit, '', ListEditActionExecute, ListEditAction, BtnLeft, 40);\r\n CreateBtn(Self, ListButtonPanel, 'ListDeleteButton', RSPropertyStoreEditorListButtonDelete, '', ListDeleteActionExecute, ListDeleteAction, BtnLeft, 40);\r\n btnLeft := btnLeft + 5;\r\n CreateBtn(Self, ListButtonPanel, 'ListUpButton', RSPropertyStoreEditorListButtonUp, '', ListUpActionExecute, ListUpAction, BtnLeft, 40);\r\n CreateBtn(Self, ListButtonPanel, 'ListDownButton', RSPropertyStoreEditorListButtonDown, '', ListDownActionExecute, ListDownAction, BtnLeft, 40);\r\n CreateBtn(Self, ListButtonPanel, 'ListSortUpButton', RSPropertyStoreEditorListButtonSortUp, '', ListSortUpActionExecute, ListSortUpAction, BtnLeft, 50);\r\n CreateBtn(Self, ListButtonPanel, 'ListSortDownButton', RSPropertyStoreEditorListButtonSortDown, '', ListSortDownActionExecute, ListSortDownAction, BtnLeft, 60);\r\n ListBox := DefaultDynControlEngine.CreateListBoxControl(Self, ListPanel, 'ListBox', Nil);\r\n ListBox.Align := alClient;\r\n Supports (ListBox, IJvDynControlItems, ListBoxControlItemsIntf);\r\n Supports (ListBox, IJvDynControlItemIndex, ListBoxControlItemIndexIntf);\r\n if Supports(ListBox, IJvDynControlDblClick, DynControlDblClick) then\r\n DynControlDblClick.ControlSetOnDblClick(ListEditActionExecute);\r\n if Supports(ListBox, IJvDynControl, DynControl) then\r\n DynControl.ControlSetOnEnter(ListBoxOnEnter);\r\n if Supports(ListBox, IJvDynControl, DynControl) then\r\n DynControl.ControlSetOnClick(ListBoxOnClick);\r\n if Supports(ListBox, IJvDynControlKey, DynControlKey) then\r\n DynControlKey.ControlSetOnKeyPress(ListBoxOnKeyPress);\r\n if Supports(ListBox, IJvDynControlMouse, DynControlMouse) then\r\n DynControlMouse.ControlSetOnMouseDown(ListBoxOnMouseDown);\r\n\r\n ParentListInsertAction := TAction.Create(Self);\r\n ParentListInsertAction.Caption := RSPropertyStoreEditorListButtonInsert;\r\n ParentListInsertAction.OnExecute := ParentListInsertActionExecute;\r\n ParentListCopyAction := TAction.Create(Self);\r\n ParentListCopyAction.Caption := RSPropertyStoreEditorListButtonCopy;\r\n ParentListCopyAction.OnExecute := ParentListCopyActionExecute;\r\n ParentListDeleteAction := TAction.Create(Self);\r\n ParentListDeleteAction.Caption := RSPropertyStoreEditorListButtonDelete;\r\n ParentListDeleteAction.OnExecute := ParentListDeleteActionExecute;\r\n ParentListUpAction := TAction.Create(Self);\r\n ParentListUpAction.Caption := RSPropertyStoreEditorListButtonUp;\r\n ParentListUpAction.OnExecute := ParentListUpActionExecute;\r\n ParentListDownAction := TAction.Create(Self);\r\n ParentListDownAction.Caption := RSPropertyStoreEditorListButtonDown;\r\n ParentListDownAction.OnExecute := ParentListDownActionExecute;\r\n ParentListSortUpAction := TAction.Create(Self);\r\n ParentListSortUpAction.Caption := RSPropertyStoreEditorListButtonSortUp;\r\n ParentListSortUpAction.OnExecute := ParentListSortUpActionExecute;\r\n ParentListSortDownAction := TAction.Create(Self);\r\n ParentListSortDownAction.Caption := RSPropertyStoreEditorListButtonSortDown;\r\n ParentListSortDownAction.OnExecute := ParentListSortDownActionExecute;\r\n\r\n ParentListButtonPanel := DefaultDynControlEngine.CreatePanelControl(Self, EditPanel, 'ParentListButtonPanel', '', alTop);\r\n ParentListButtonPanel.Height := 25;\r\n if ParentListButtonPanel is TPanel then\r\n TPanel(ParentListButtonPanel).BevelOuter := bvNone;\r\n ParentListButtonPanel.Visible := False;\r\n BtnLeft := 0;\r\n CreateBtn(Self, ParentListButtonPanel, 'ParentListInsertButton', RSPropertyStoreEditorListButtonInsert, '', ParentListInsertActionExecute, ParentListInsertAction, BtnLeft, 40);\r\n CreateBtn(Self, ParentListButtonPanel, 'ParentListCopyButton', RSPropertyStoreEditorListButtonCopy, '', ParentListCopyActionExecute, ParentListCopyAction, BtnLeft, 40);\r\n// CreateBtn(Self, ParentListButtonPanel, 'ParentListDeleteButton', RSPropertyStoreEditorListButtonDelete, '', ParentListDeleteActionExecute, ParentListDeleteAction, BtnLeft, 40);\r\n btnLeft := btnLeft + 5;\r\n CreateBtn(Self, ParentListButtonPanel, 'ParentListUpButton', RSPropertyStoreEditorListButtonUp, '', ParentListUpActionExecute, ParentListUpAction, BtnLeft, 40);\r\n CreateBtn(Self, ParentListButtonPanel, 'ParentListDownButton', RSPropertyStoreEditorListButtonDown, '', ParentListDownActionExecute, ParentListDownAction, BtnLeft, 40);\r\n CreateBtn(Self, ParentListButtonPanel, 'ParentListSortUpButton', RSPropertyStoreEditorListButtonSortUp, '', ParentListSortUpActionExecute, ParentListSortUpAction, BtnLeft, 50);\r\n CreateBtn(Self, ParentListButtonPanel, 'ParentListSortDownButton', RSPropertyStoreEditorListButtonSortDown, '', ParentListSortDownActionExecute, ParentListSortDownAction, BtnLeft, 60);\r\n\r\n InspectorPanel := DefaultDynControlEngine.CreatePanelControl(Self, EditPanel, 'InspectorPanel', '', alClient);\r\n if InspectorPanel is TCustomPanel then\r\n tAccessCustomPanel(InspectorPanel).BevelOuter := bvNone;\r\n\r\n Inspector := DefaultDynControlEngine.CreateRTTIInspectorControl(self, InspectorPanel,\r\n 'Inspector', OnDisplayProperty, OnTranslatePropertyName);\r\n Supports (Inspector, IJvDynControlRTTIInspectorControl, RTTIInspectorControlIntf);\r\n RTTIInspectorControlIntf.ControlOnPropertyChange := OnPropertyChange;\r\n RTTIInspectorControlIntf.ControlOnTranslatePropertyName := OnInspectorTranslatePropertyName;\r\n Inspector.Align := alClient;\r\n tAccessControl(Inspector).OnCanResize := RTTIInspectorOnCanResize;\r\n Supports(RTTIInspectorControlIntf, IJvDynControl, DynControl);\r\n RTTIInspectorControlIntf.ControlDividerWidth := 200;\r\n\r\n DynControl.ControlSetOnEnter(RTTIInspectorEnter);\r\n\r\n Caption := RSPropertyStoreEditorDialogCaptionEditProperties;\r\n\r\n SetInformation('', '');\r\nend;\r\n\r\nprocedure TJvPropertyStoreEditorControl.DestroyControls;\r\nbegin\r\n FreeAndNil(ListCopyAction);\r\n FreeAndNil(ListCopyMenu);\r\n FreeAndNil(ListDeleteAction);\r\n FreeAndNil(ListDeleteMenu);\r\n FreeAndNil(ListDownAction);\r\n FreeAndNil(ListDownMenu);\r\n FreeAndNil(ListEditAction);\r\n FreeAndNil(ListInsertAction);\r\n FreeAndNil(ListInsertMenu);\r\n FreeAndNil(ListSortUpAction);\r\n FreeAndNil(ListSortUpMenu);\r\n FreeAndNil(ListSortDownAction);\r\n FreeAndNil(ListSortDownMenu);\r\n FreeAndNil(ListUpAction);\r\n FreeAndNil(ListUpMenu);\r\n FreeAndNil(ListLineMenu);\r\n FreeAndNil(ParentListCopyAction);\r\n FreeAndNil(ParentListDeleteAction);\r\n FreeAndNil(ParentListDownAction);\r\n FreeAndNil(ParentListInsertAction);\r\n FreeAndNil(ParentListSortUpAction);\r\n FreeAndNil(ParentListSortDownAction);\r\n FreeAndNil(ParentListUpAction);\r\n PropertyStore := nil;\r\n InspectedObject := nil;\r\n FInspectedObjectEditorHandlerIntf := nil;\r\n FInspectedObjectListEditorHandlerIntf := nil;\r\n InfoGroupBoxDynControlCaptionIntf := nil;\r\n InfoMemoDynControlDataIntf := nil;\r\n ListBoxControlItemsIntf := nil;\r\n ListBoxControlItemIndexIntf := nil;\r\n PropertyStoreTreeViewIntf := nil;\r\n RTTIInspectorControlIntf := nil;\r\n FreeAndNil(TreePanel);\r\n FreeAndNil(InfoMemo);\r\n FreeAndNil(InfoPanel);\r\n FreeAndNil(Inspector);\r\n FreeAndNil(ListPanel);\r\n FreeAndNil(InspectorPanel);\r\nend;\r\n\r\nprocedure TJvPropertyStoreEditorControl.FillListBox;\r\nvar\r\n DetailObjectEditorHandler: IJvPropertyEditorHandler;\r\n i: Integer;\r\n SubObj: TObject;\r\nbegin\r\n if csDestroying in Componentstate then\r\n Exit;\r\n ListBoxControlItemsIntf.ControlItems.Clear;\r\n for i := 0 to InspectedObjectListEditorHandlerIntf.ListEditIntf_ObjectCount - 1 do\r\n begin\r\n SubObj := InspectedObjectListEditorHandlerIntf.ListEditIntf_GetObject(i);\r\n if Supports(SubObj, IJvPropertyEditorHandler, DetailObjectEditorHandler) then\r\n begin\r\n ListBoxControlItemsIntf.ControlItems.AddObject(DetailObjectEditorHandler.EditIntf_GetVisibleObjectName + ' - ' + ' [' + inttostr(i + 1) + '] ', SubObj);\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvPropertyStoreEditorControl.FillTreeView(GotoNodeObject: TPersistent =\r\n nil);\r\nbegin\r\n if (csDestroying in Componentstate) then\r\n Exit;\r\n if not Assigned(PropertyStoreTreeViewIntf) then\r\n CreateControls;\r\n PropertyStoreTreeViewIntf.ControlItems.BeginUpdate;\r\n try\r\n PropertyStoreTreeViewIntf.ControlItems.Clear;\r\n FillTreeViewByComponent(PropertyStoreTreeViewIntf.ControlItems, nil, PropertyStore);\r\n finally\r\n PropertyStoreTreeViewIntf.ControlItems.EndUpdate;\r\n end;\r\n if not Assigned(GotoNodeObject ) then\r\n if PropertyStoreTreeViewIntf.ControlItems.Count > 0 then\r\n GotoEditObject(PropertyStoreTreeViewIntf.ControlItems[0].Data)\r\n else\r\n GotoEditObject(nil)\r\n else\r\n GotoEditObject(GotoNodeObject);\r\nend;\r\n\r\nprocedure TJvPropertyStoreEditorControl.FillTreeViewByComponent(TreeNodes: TTreeNodes; Parent: TTreeNode; aPropertyStore:\r\n TPersistent);\r\nvar\r\n I: Integer;\r\n SubObj: TObject;\r\n Node: TTreeNode;\r\n PropName: string;\r\n PropertyEditorHandler: IJvPropertyEditorHandler;\r\n DetailPropertyEditorHandler: IJvPropertyEditorHandler;\r\n PropertyListEditorHandler: IJvPropertyListEditorHandler;\r\n\r\nbegin\r\n if not assigned(aPropertyStore) or\r\n not Supports(aPropertyStore, IJvPropertyEditorHandler, PropertyEditorHandler) then\r\n Exit;\r\n if not Assigned(Parent) then\r\n begin\r\n Node := TreeNodes.AddChildObject(Parent, PropertyEditorHandler.EditIntf_GetVisibleObjectName,\r\n aPropertyStore);\r\n FillTreeViewByComponent(TreeNodes, Node,\r\n aPropertyStore);\r\n end\r\n else\r\n begin\r\n RTTIInspectorControlIntf.ControlInspectedObject := aPropertyStore;\r\n for I := 0 to GetPropCount(aPropertyStore) - 1 do\r\n begin\r\n PropName := GetPropName(aPropertyStore,I);\r\n if PropIsType(aPropertyStore, PropName, tkClass) then\r\n begin\r\n SubObj := GetObjectProp(aPropertyStore, PropName);\r\n if PropertyEditorHandler.EditIntf_DisplayProperty(PropName) then\r\n if ShowPropertyInTreeView (aPropertyStore, PropName) then\r\n if Supports(SubObj, IJvPropertyEditorHandler, DetailPropertyEditorHandler) then\r\n if (SubObj is TPersistent)then\r\n begin\r\n Node := TreeNodes.AddChildObject(Parent,\r\n DetailPropertyEditorHandler.EditIntf_TranslatePropertyName(PropName),\r\n SubObj);\r\n FillTreeViewByComponent(TreeNodes, Node, TPersistent(SubObj));\r\n end;\r\n end;\r\n end;\r\n if Supports (aPropertyStore, IJvPropertyListEditorHandler, PropertyListEditorHandler) then\r\n for i := 0 to PropertyListEditorHandler.ListEditIntf_ObjectCount - 1 do\r\n begin\r\n SubObj := PropertyListEditorHandler.ListEditIntf_GetObject(i);\r\n if Supports(SubObj, IJvPropertyEditorHandler, DetailPropertyEditorHandler) and\r\n (SubObj is TPersistent) then\r\n begin\r\n Node := TreeNodes.AddChildObject(Parent,\r\n DetailPropertyEditorHandler.EditIntf_GetVisibleObjectName, SubObj);\r\n FillTreeViewByComponent(TreeNodes, Node, TPersistent(SubObj));\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJvPropertyStoreEditorControl.GetPropCount(Instance: TPersistent):\r\n Integer;\r\nvar\r\n Data: PTypeData;\r\nbegin\r\n Data := GetTypeData(Instance.ClassInfo);\r\n Result := Data.PropCount;\r\nend;\r\n\r\nfunction TJvPropertyStoreEditorControl.GetPropName(Instance: TPersistent; Index:\r\n Integer): string;\r\nvar\r\n PropList: PPropList;\r\n PropInfo: PPropInfo;\r\n Data: PTypeData;\r\nbegin\r\n Result := '';\r\n Data := GetTypeData(Instance.ClassInfo);\r\n GetMem(PropList, Data^.PropCount * SizeOf(PPropInfo));\r\n try\r\n GetPropInfos(Instance.ClassInfo, PropList);\r\n PropInfo := PropList^[Index];\r\n Result := {$IFDEF SUPPORTS_UNICODE}UTF8ToString{$ENDIF SUPPORTS_UNICODE}(PropInfo^.Name);\r\n finally\r\n FreeMem(PropList, Data^.PropCount * SizeOf(PPropInfo));\r\n end;\r\nend;\r\n\r\nprocedure TJvPropertyStoreEditorControl.GotoEditObject(EditObject: TPersistent);\r\nvar\r\n TreeNode: TTreeNode;\r\n i: Integer;\r\nbegin\r\n if csDestroying in Componentstate then\r\n Exit;\r\n if not Assigned(EditObject) then\r\n begin\r\n PropertyStoreTreeViewChange(nil, PropertyStoreTreeViewIntf.ControlSelected);\r\n Exit;\r\n end;\r\n for i := 0 to PropertyStoreTreeViewIntf.ControlItems.Count - 1 do\r\n begin\r\n TreeNode := PropertyStoreTreeViewIntf.ControlItems[i];\r\n if Assigned(TreeNode.Data) and (TreeNode.Data = EditObject) then\r\n begin\r\n TreeNode.Expand(false);\r\n PropertyStoreTreeViewIntf.ControlSelected := TreeNode;\r\n Exit;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvPropertyStoreEditorControl.JvInspectorAfterItemCreate(Sender:\r\n TObject; Item: TJvCustomInspectorItem);\r\nbegin\r\n if Assigned(Item) and Assigned(InspectedObjectEditorHandlerIntf) then\r\n Item.DisplayName := InspectedObjectEditorHandlerIntf.EditIntf_TranslatePropertyName(Item.Name);\r\nend;\r\n\r\nprocedure TJvPropertyStoreEditorControl.JvInspectorBeforeItemCreate(Sender:\r\n TObject; Data: TJvCustomInspectorData; var ItemClass:\r\n TJvInspectorItemClass);\r\nvar\r\n PropertyEditorHandler: IJvPropertyEditorHandler;\r\nbegin\r\n if Assigned(Data) and\r\n (Data is TJvInspectorPropData) and\r\n Assigned(TJvInspectorPropData(Data).Instance) then\r\n begin\r\n if Supports(TJvInspectorPropData(Data).Instance, IJvPropertyEditorHandler, PropertyEditorHandler) then\r\n if not PropertyEditorHandler.EditIntf_DisplayProperty(Data.Name) then\r\n ItemClass := nil\r\n else if ShowPropertyInTreeView(TJvInspectorPropData(Data).Instance, Data.Name) then\r\n ItemClass := nil;\r\n end;\r\nend;\r\n\r\nprocedure TJvPropertyStoreEditorControl.ListBoxOnClick(Sender: TObject);\r\nbegin\r\n if Assigned(ListBoxControlItemIndexIntf) then\r\n InspectedObjectListItemIndex := ListBoxControlItemIndexIntf.ControlItemIndex\r\n else\r\n InspectedObjectListItemIndex := -1;\r\nend;\r\n\r\nprocedure TJvPropertyStoreEditorControl.ListBoxOnEnter(Sender: TObject);\r\nbegin\r\n if Assigned(ListBoxControlItemIndexIntf) then\r\n InspectedObjectListItemIndex := ListBoxControlItemIndexIntf.ControlItemIndex\r\n else\r\n InspectedObjectListItemIndex := -1;\r\nend;\r\n\r\nprocedure TJvPropertyStoreEditorControl.ListBoxOnKeyPress(Sender: TObject; var Key: Char);\r\nbegin\r\n if Assigned(ListBoxControlItemIndexIntf) then\r\n InspectedObjectListItemIndex := ListBoxControlItemIndexIntf.ControlItemIndex\r\n else\r\n InspectedObjectListItemIndex := -1;\r\nend;\r\n\r\nprocedure TJvPropertyStoreEditorControl.ListBoxOnMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState;\r\n X, Y: Integer);\r\nvar aPos:TPoint;\r\nbegin\r\n if (Button = mbRight) and Assigned(InspectedObjectListEditorHandlerIntf) and\r\n Assigned(Sender) and (Sender is TWinControl) then\r\n begin\r\n aPos := TWinControl(Sender).ClientToScreen(Point(X, Y));\r\n ListPopupMenu.Popup(aPos.x,aPos.y);\r\n end;\r\nend;\r\n\r\nprocedure TJvPropertyStoreEditorControl.ListCopyActionExecute(Sender: TObject);\r\nvar\r\n NewObject: TPersistent;\r\nbegin\r\n if Assigned(InspectedObjectListEditorHandlerIntf) then\r\n begin\r\n NewObject := InspectedObjectListEditorHandlerIntf.ListEditIntf_CloneNewObject(InspectedObjectListItemIndex);\r\n if Assigned(NewObject) then\r\n begin\r\n FillTreeView (NewObject);\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvPropertyStoreEditorControl.ListDeleteActionExecute(Sender: TObject);\r\nvar\r\n EditObject: TPersistent;\r\nbegin\r\n if Assigned(InspectedObjectListEditorHandlerIntf) then\r\n if (MessageDlg(RSPropertyStoreEditorDeleteEntry, mtConfirmation, [mbYes, mbNo], 0) = mrYes) then\r\n begin\r\n EditObject := TPersistent(PropertyStoreTreeViewIntf.ControlSelected.Data);\r\n if EditObject = InspectedObjectListEditorHandlerIntf.ListEditIntf_GetObject (InspectedObjectListItemIndex) then\r\n if (InspectedObjectListItemIndex < InspectedObjectListEditorHandlerIntf.ListEditIntf_ObjectCount-1)\r\n and (InspectedObjectListItemIndex > 0) then\r\n EditObject := InspectedObjectListEditorHandlerIntf.ListEditIntf_GetObject (InspectedObjectListItemIndex)\r\n else if InspectedObjectListEditorHandlerIntf.ListEditIntf_ObjectCount-1 > 0 then\r\n EditObject := InspectedObjectListEditorHandlerIntf.ListEditIntf_GetObject (0)\r\n else\r\n EditObject := TPersistent(PropertyStoreTreeViewIntf.ControlSelected.Parent.Data);\r\n InspectedObjectListEditorHandlerIntf.ListEditIntf_DeleteObject(InspectedObjectListItemIndex);\r\n FillTreeView (EditObject);\r\n end;\r\nend;\r\n\r\nprocedure TJvPropertyStoreEditorControl.ListDownActionExecute(Sender: TObject);\r\nvar\r\n EditObject: TPersistent;\r\n Ind : Integer;\r\nbegin\r\n if Assigned(InspectedObjectListEditorHandlerIntf) and (InspectedObjectListItemIndex < ListBoxControlItemsIntf.ControlItems.Count) then\r\n begin\r\n EditObject := TPersistent(PropertyStoreTreeViewIntf.ControlSelected.Data);\r\n Ind := InspectedObjectListItemIndex;\r\n InspectedObjectListEditorHandlerIntf.ListEditIntf_MoveObjectPosition(InspectedObjectListItemIndex, InspectedObjectListItemIndex+1);\r\n FillTreeView (EditObject);\r\n InspectedObjectListItemIndex := Ind +1;\r\n end;\r\nend;\r\n\r\nprocedure TJvPropertyStoreEditorControl.ListEditActionExecute(Sender: TObject);\r\nvar\r\n EditObject: TPersistent;\r\nbegin\r\n if Assigned(InspectedObjectListEditorHandlerIntf) then\r\n begin\r\n EditObject := InspectedObjectListEditorHandlerIntf.ListEditIntf_GetObject(InspectedObjectListItemIndex);\r\n if Assigned(EditObject) then\r\n GotoEditObject (EditObject);\r\n end;\r\nend;\r\n\r\nprocedure TJvPropertyStoreEditorControl.ListInsertActionExecute(Sender: TObject);\r\nvar\r\n newObject: TPersistent;\r\nbegin\r\n if Assigned(InspectedObjectListEditorHandlerIntf) then\r\n begin\r\n NewObject := InspectedObjectListEditorHandlerIntf.ListEditIntf_CreateNewObject;\r\n FillTreeView (NewObject);\r\n end;\r\nend;\r\n\r\nprocedure TJvPropertyStoreEditorControl.ListSortDownActionExecute(Sender:\r\n TObject);\r\nvar\r\n EditObject: TPersistent;\r\nbegin\r\n if Assigned(InspectedObjectListEditorHandlerIntf) and (ListBoxControlItemsIntf.ControlItems.Count > 0) then\r\n begin\r\n EditObject := TPersistent(PropertyStoreTreeViewIntf.ControlSelected.Data);\r\n InspectedObjectListEditorHandlerIntf.ListEditIntf_SortObjects(False);\r\n FillTreeView (EditObject);\r\n InspectedObjectListItemIndex := 0;\r\n end;\r\nend;\r\n\r\nprocedure TJvPropertyStoreEditorControl.ListSortUpActionExecute(Sender: TObject);\r\nvar\r\n EditObject: TPersistent;\r\nbegin\r\n if Assigned(InspectedObjectListEditorHandlerIntf) and (ListBoxControlItemsIntf.ControlItems.Count > 0) then\r\n begin\r\n EditObject := TPersistent(PropertyStoreTreeViewIntf.ControlSelected.Data);\r\n InspectedObjectListEditorHandlerIntf.ListEditIntf_SortObjects(True);\r\n FillTreeView (EditObject);\r\n InspectedObjectListItemIndex := 0;\r\n end;\r\nend;\r\n\r\nprocedure TJvPropertyStoreEditorControl.ListUpActionExecute(Sender: TObject);\r\nvar\r\n EditObject: TPersistent;\r\n Ind : Integer;\r\nbegin\r\n if Assigned(InspectedObjectListEditorHandlerIntf) and (InspectedObjectListItemIndex > 0) then\r\n begin\r\n EditObject := TPersistent(PropertyStoreTreeViewIntf.ControlSelected.Data);\r\n Ind := InspectedObjectListItemIndex;\r\n InspectedObjectListEditorHandlerIntf.ListEditIntf_MoveObjectPosition(InspectedObjectListItemIndex, InspectedObjectListItemIndex-1);\r\n FillTreeView (EditObject);\r\n InspectedObjectListItemIndex := Ind -1;\r\n end;\r\nend;\r\n\r\nprocedure TJvPropertyStoreEditorControl.Notification(AComponent: TComponent;\r\n Operation: TOperation);\r\nbegin\r\n inherited Notification(AComponent, Operation);\r\n if (Operation = opRemove) and (AComponent = FPropertyStore) then\r\n begin\r\n PropertyStore := nil;\r\n InspectedObject := nil;\r\n end;\r\nend;\r\n\r\nfunction TJvPropertyStoreEditorControl.OnDisplayProperty(const aPropertyName :\r\n String): Boolean;\r\nbegin\r\n if Assigned(InspectedObjectEditorHandlerIntf) then\r\n Result := InspectedObjectEditorHandlerIntf.EditIntf_DisplayProperty(aPropertyName)\r\n and InspectedObjectEditorHandlerIntf.EditIntf_IsPropertySimple(aPropertyName)\r\n else\r\n Result := False;\r\nend;\r\n\r\nfunction TJvPropertyStoreEditorControl.OnInspectorTranslatePropertyName(const\r\n aPropertyName : String): string;\r\nbegin\r\n if Assigned(InspectedObjectEditorHandlerIntf) then\r\n Result := InspectedObjectEditorHandlerIntf.EditIntf_TranslatePropertyName(aPropertyName)\r\n else\r\n Result := aPropertyName;\r\nend;\r\n\r\nprocedure TJvPropertyStoreEditorControl.OnPropertyChange(var OldPropertyName,\r\n NewPropertyName : string);\r\nbegin\r\n if Assigned(InspectedObjectEditorHandlerIntf) then\r\n SetInformation (InspectedObjectEditorHandlerIntf.EditIntf_TranslatePropertyName(NewPropertyName),\r\n InspectedObjectEditorHandlerIntf.EditIntf_GetPropertyHint(NewPropertyName));\r\nend;\r\n\r\nfunction TJvPropertyStoreEditorControl.OnTranslatePropertyName(const aPropertyName :\r\n String): string;\r\nbegin\r\n Result := aPropertyName;\r\nend;\r\n\r\nprocedure TJvPropertyStoreEditorControl.ParentListCopyActionExecute(Sender: TObject);\r\nvar\r\n NewObject: TPersistent;\r\n Index : Integer;\r\nbegin\r\n if Assigned(InspectedParentObjectListEditorHandlerIntf) and Assigned(InspectedObject) then\r\n begin\r\n Index := InspectedParentObjectListEditorHandlerIntf.ListEditIntf_IndexOfObject(InspectedObject);\r\n NewObject := InspectedParentObjectListEditorHandlerIntf.ListEditIntf_CloneNewObject(Index);\r\n if Assigned(NewObject) then\r\n begin\r\n FillTreeView (NewObject);\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvPropertyStoreEditorControl.ParentListDeleteActionExecute(Sender: TObject);\r\n//var\r\n// EditObject: TPersistent;\r\n// Index : Integer;\r\nbegin\r\n// if Assigned(InspectedParentObjectListEditorHandlerIntf) and Assigned(InspectedObject) then\r\n// if (MessageDlg(RSPropertyStoreEditorDeleteEntry, mtConfirmation, [mbYes, mbNo], 0) = mrYes) then\r\n// begin\r\n// Index := InspectedParentObjectListEditorHandlerIntf.ListEditIntf_IndexOfObject(InspectedObject);\r\n// if (Index < InspectedParentObjectListEditorHandlerIntf.ListEditIntf_ObjectCount-1) and (Index > 0) then\r\n// EditObject := InspectedParentObjectListEditorHandlerIntf.ListEditIntf_GetObject (Index-1)\r\n// else if InspectedParentObjectListEditorHandlerIntf.ListEditIntf_ObjectCount-1 > 0 then\r\n// EditObject := InspectedParentObjectListEditorHandlerIntf.ListEditIntf_GetObject (0)\r\n// else\r\n// EditObject := InspectedParentObject;\r\n// InspectedParentObjectListEditorHandlerIntf.ListEditIntf_DeleteObject(Index);\r\n// FillTreeView (InspectedParentObject);\r\n// end;\r\nend;\r\n\r\nprocedure TJvPropertyStoreEditorControl.ParentListDownActionExecute(Sender: TObject);\r\nvar\r\n EditObject: TPersistent;\r\n Ind : Integer;\r\nbegin\r\n if Assigned(InspectedParentObjectListEditorHandlerIntf) then\r\n begin\r\n EditObject := TPersistent(PropertyStoreTreeViewIntf.ControlSelected.Data);\r\n Ind := InspectedParentObjectListEditorHandlerIntf.ListEditIntf_IndexOfObject(EditObject);\r\n if Ind < InspectedParentObjectListEditorHandlerIntf.ListEditIntf_ObjectCount-1 then\r\n begin\r\n InspectedParentObjectListEditorHandlerIntf.ListEditIntf_MoveObjectPosition(Ind, Ind+1);\r\n FillTreeView (EditObject);\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvPropertyStoreEditorControl.ParentListInsertActionExecute(Sender: TObject);\r\nvar\r\n newObject: TPersistent;\r\nbegin\r\n if Assigned(InspectedParentObjectListEditorHandlerIntf) then\r\n begin\r\n NewObject := InspectedParentObjectListEditorHandlerIntf.ListEditIntf_CreateNewObject;\r\n FillTreeView (NewObject);\r\n end;\r\nend;\r\n\r\nprocedure TJvPropertyStoreEditorControl.ParentListSortDownActionExecute(Sender: TObject);\r\nvar\r\n EditObject: TPersistent;\r\nbegin\r\n if Assigned(InspectedParentObjectListEditorHandlerIntf) and (InspectedParentObjectListEditorHandlerIntf.ListEditIntf_ObjectCount > 0) then\r\n begin\r\n EditObject := InspectedObject;\r\n InspectedParentObjectListEditorHandlerIntf.ListEditIntf_SortObjects(False);\r\n FillTreeView (EditObject);\r\n end;\r\nend;\r\n\r\nprocedure TJvPropertyStoreEditorControl.ParentListSortUpActionExecute(Sender: TObject);\r\nvar\r\n EditObject: TPersistent;\r\nbegin\r\n if Assigned(InspectedParentObjectListEditorHandlerIntf) and (InspectedParentObjectListEditorHandlerIntf.ListEditIntf_ObjectCount > 0) then\r\n begin\r\n EditObject := InspectedObject;\r\n InspectedParentObjectListEditorHandlerIntf.ListEditIntf_SortObjects(True);\r\n FillTreeView (EditObject);\r\n end;\r\nend;\r\n\r\nprocedure TJvPropertyStoreEditorControl.ParentListUpActionExecute(Sender: TObject);\r\nvar\r\n EditObject: TPersistent;\r\n Ind : Integer;\r\nbegin\r\n if Assigned(InspectedParentObjectListEditorHandlerIntf) then\r\n begin\r\n EditObject := TPersistent(PropertyStoreTreeViewIntf.ControlSelected.Data);\r\n Ind := InspectedParentObjectListEditorHandlerIntf.ListEditIntf_IndexOfObject(EditObject);\r\n if Ind > 0 then\r\n begin\r\n InspectedParentObjectListEditorHandlerIntf.ListEditIntf_MoveObjectPosition(Ind, Ind-1);\r\n FillTreeView (EditObject);\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvPropertyStoreEditorControl.PropertyStoreTreeViewChange(Sender:\r\n TObject; Node: TTreeNode);\r\nbegin\r\n if csDestroying in Componentstate then\r\n Exit;\r\n if not Assigned(Node) or\r\n not Assigned(Node.Data) or\r\n not (TObject(Node.Data) is TPersistent) or\r\n not (Supports(TObject(Node.Data), IJvPropertyEditorHandler)) then\r\n InspectedObject := nil\r\n else\r\n begin\r\n InspectedObject := TPersistent(Node.Data);\r\n if Assigned(Node.Parent) and Assigned(Node.Parent.Data)\r\n and (TObject(Node.Parent.Data) is TPersistent)\r\n and (Supports(TObject(Node.Parent.Data), IJvPropertyListEditorHandler)) then\r\n begin\r\n InspectedParentObject := TPersistent(Node.Parent.Data);\r\n ChangeInspectedObjectListEditorHandlerIntf(TObject(Node.Parent.Data));\r\n if Assigned(InspectedObjectListEditorHandlerIntf) then\r\n InspectedObjectListItemIndex := InspectedObjectListEditorHandlerIntf.ListEditIntf_IndexOfObject(InspectedObject);\r\n end\r\n else\r\n InspectedParentObject := nil;\r\n end;\r\nend;\r\n\r\nprocedure TJvPropertyStoreEditorControl.PropertyStoreTreeViewChanging(Sender:\r\n TObject; Node: TTreeNode; var AllowChange: Boolean);\r\nvar JvPropertyEditorHandler : IJvPropertyEditorHandler;\r\nbegin\r\n if csDestroying in Componentstate then\r\n Exit;\r\n RTTIInspectorControlIntf.ControlSaveEditorValues;\r\n if Assigned(PropertyStoreTreeViewIntf.ControlSelected) and\r\n Assigned(PropertyStoreTreeViewIntf.ControlSelected.Data) and\r\n (TObject(PropertyStoreTreeViewIntf.ControlSelected.Data) is TPersistent) then\r\n if Supports(TObject(PropertyStoreTreeViewIntf.ControlSelected.Data),\r\n IJvPropertyEditorHandler, JvPropertyEditorHandler) then\r\n if (JvPropertyEditorHandler.EditIntf_GetVisibleObjectName <> '') then\r\n PropertyStoreTreeViewIntf.ControlSelected.Text := JvPropertyEditorHandler.EditIntf_GetVisibleObjectName;\r\nend;\r\n\r\nprocedure TJvPropertyStoreEditorControl.PropertyStoreTreeViewEnter(Sender: TObject);\r\nbegin\r\n if Assigned(InspectedObjectEditorHandlerIntf) then\r\n SetInformation (InspectedObjectEditorHandlerIntf.EditIntf_GetVisibleObjectName, InspectedObjectEditorHandlerIntf.EditIntf_GetObjectHint);\r\nend;\r\n\r\nprocedure TJvPropertyStoreEditorControl.RTTIInspectorEnter(Sender:\r\n TObject);\r\nbegin\r\n if csDestroying in Componentstate then\r\n Exit;\r\n if Assigned(InspectedObjectEditorHandlerIntf) and Assigned(RTTIInspectorControlIntf) then\r\n SetInformation (InspectedObjectEditorHandlerIntf.EditIntf_TranslatePropertyName(RTTIInspectorControlIntf.ControlGetCurrentPropertyName),\r\n InspectedObjectEditorHandlerIntf.EditIntf_GetPropertyHint(RTTIInspectorControlIntf.ControlGetCurrentPropertyName));\r\nend;\r\n\r\nprocedure TJvPropertyStoreEditorControl.RTTIInspectorOnCanResize(Sender: TObject; var NewWidth, NewHeight: Integer; var Resize:\r\n Boolean);\r\nvar\r\n Ratio: Double;\r\nbegin\r\n if not Assigned(RTTIInspectorControlIntf) then\r\n Exit;\r\n Ratio := Inspector.Width / RTTIInspectorControlIntf.ControlDividerWidth;\r\n RTTIInspectorControlIntf.ControlDividerWidth := Round(NewWidth/Ratio);\r\nend;\r\n\r\nprocedure TJvPropertyStoreEditorControl.SetActionsEnabled;\r\nbegin\r\n ListInsertAction.Enabled := Assigned(FInspectedObjectListEditorHandlerIntf);\r\n ListCopyAction.Enabled := ListInsertAction.Enabled and (InspectedObjectListItemIndex >= 0);\r\n ListDownAction.Enabled := ListCopyAction.Enabled and (InspectedObjectListItemIndex < InspectedObjectListEditorHandlerIntf.ListEditIntf_ObjectCount-1);\r\n ListUpAction.Enabled := ListCopyAction.Enabled and (InspectedObjectListItemIndex > 0);\r\n ListDeleteAction.Enabled := ListCopyAction.Enabled;\r\n ListEditAction.Enabled := ListCopyAction.Enabled;\r\n ListSortUpAction.Enabled := ListInsertAction.Enabled and (InspectedObjectListEditorHandlerIntf.ListEditIntf_ObjectCount > 0);\r\n ListSortDownAction.Enabled := ListSortUpAction.Enabled ;\r\nend;\r\n\r\nprocedure TJvPropertyStoreEditorControl.SetInformation(const iCaption, iInfo:\r\n string);\r\nbegin\r\n if csDestroying in Componentstate then\r\n Exit;\r\n InfoMemoDynControlDataIntf.ControlValue := iInfo;\r\n InfoGroupBoxDynControlCaptionIntf.ControlSetCaption(iCaption);\r\n InfoPanel.Visible := iInfo <> '';\r\nend;\r\n\r\nprocedure TJvPropertyStoreEditorControl.SetInspectedObject(const Value: TPersistent);\r\nbegin\r\n if csDestroying in Componentstate then\r\n begin\r\n FInspectedObject := nil;\r\n FInspectedParentObject := nil;\r\n FInspectedObjectEditorHandlerIntf := nil;\r\n FInspectedObjectListEditorHandlerIntf := nil;\r\n if Assigned(RTTIInspectorControlIntf) then\r\n RTTIInspectorControlIntf.ControlInspectedObject := Value;\r\n Exit;\r\n end;\r\n if Value = nil then\r\n InspectedParentObject := nil;\r\n FInspectedObject := Value;\r\n Supports(InspectedObject, IJvPropertyEditorHandler, FInspectedObjectEditorHandlerIntf);\r\n ChangeInspectedObjectListEditorHandlerIntf(InspectedObject);\r\n RTTIInspectorControlIntf.ControlSaveEditorValues;\r\n RTTIInspectorControlIntf.ControlInspectedObject := Value;\r\n if Assigned(InspectedObjectListEditorHandlerIntf) then\r\n begin\r\n ListPanel.visible := True;\r\n Inspector.Parent := ListInspectorPanel;\r\n InspectorPanel.visible := False;\r\n ListInspectorPanel.visible := RTTIInspectorControlIntf.ControlGetVisibleItemsCount > 0;\r\n ListSplitter.visible := ListInspectorPanel.visible;\r\n ListButtonPanel.Top := ListInspectorPanel.Top+ListInspectorPanel.Height+1;\r\n ListSplitter.Top := ListButtonPanel.Top-1;\r\n FillListBox;\r\n end\r\n else\r\n begin\r\n InspectorPanel.visible := True;\r\n ListPanel.visible := False;\r\n Inspector.Parent := InspectorPanel;\r\n end;\r\n if Assigned(InspectedObjectEditorHandlerIntf) then\r\n SetInformation (InspectedObjectEditorHandlerIntf.EditIntf_GetVisibleObjectName, InspectedObjectEditorHandlerIntf.EditIntf_GetObjectHint);\r\nend;\r\n\r\nprocedure TJvPropertyStoreEditorControl.SetInspectedObjectListEditorHandlerIntf(const Value:\r\n IJvPropertyListEditorHandler);\r\nbegin\r\n FInspectedObjectListEditorHandlerIntf := Value;\r\n InspectedObjectListItemIndex := -1;\r\nend;\r\n\r\nprocedure TJvPropertyStoreEditorControl.SetInspectedObjectListItemIndex(const Value: Integer);\r\nbegin\r\n FInspectedObjectListItemIndex := Value;\r\n SetActionsEnabled;\r\nend;\r\n\r\nprocedure TJvPropertyStoreEditorControl.SetInspectedParentObject(const Value: TPersistent);\r\nbegin\r\n if csDestroying in Componentstate then\r\n begin\r\n FInspectedParentObject := nil;\r\n Exit;\r\n end;\r\n FInspectedParentObject := Value;\r\n ChangeInspectedParentObjectListEditorHandlerIntf(InspectedParentObject);\r\n if Assigned(InspectedParentObjectListEditorHandlerIntf) then\r\n ParentListButtonPanel.Visible := True\r\n else\r\n ParentListButtonPanel.Visible := False;\r\nend;\r\n\r\nprocedure TJvPropertyStoreEditorControl.SetInspectedParentObjectListEditorHandlerIntf(const Value: IJvPropertyListEditorHandler);\r\nbegin\r\n FInspectedParentObjectListEditorHandlerIntf := Value;\r\nend;\r\n\r\nprocedure TJvPropertyStoreEditorControl.SetPropertyStore(const Value: TComponent);\r\nbegin\r\n if csDestroying in Componentstate then\r\n Exit;\r\n if Assigned(Value) and not Supports(Value, IJvPropertyEditorHandler) then\r\n Raise Exception.Create ('TJvPropertyStoreEditorControl.SetPropertyStore : PropertyStore must support IJvPropertyEditorHandler');\r\n ReplaceComponentReference(Self, Value, TComponent(FPropertyStore));\r\n FillTreeView(Value);\r\nend;\r\n\r\nfunction TJvPropertyStoreEditorControl.ShowPropertyInTreeView(PropObject: TObject; const PropertyName: string): Boolean;\r\nvar\r\n PropertyEditorHandler: IJvPropertyEditorHandler;\r\nbegin\r\n Result := True;\r\n if csDestroying in Componentstate then\r\n Exit;\r\n if not Assigned(PropObject) then\r\n Result := False\r\n else\r\n if Supports(PropObject, IJvPropertyEditorHandler, PropertyEditorHandler) then\r\n begin\r\n Result := (not PropertyEditorHandler.EditIntf_IsPropertySimple(PropertyName));\r\n Result := Result or (not RTTIInspectorControlIntf.ControlIsPropertySupported(PropertyName))\r\n end\r\n else\r\n Result := not RTTIInspectorControlIntf.ControlIsPropertySupported(PropertyName);\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend." }, { "path": "External/Jedi/Jvcl/run/JvPropertyStoreEditorIntf.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvPropertyStoreEditorIntf.pas, released on 2008-01-01.\r\n\r\nThe Initial Developer of the Original Code is Jens Fudickar\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\n Jens Fudickar [jens dott fudickar att oratool dott de]\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvPropertyStoreEditorIntf.pas 12694 2010-02-08 23:11:12Z jfudickar $\r\nunit JvPropertyStoreEditorIntf;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Classes;\r\n\r\ntype\r\n IJvPropertyEditorHandler = interface\r\n ['{7DD4CC1F-335E-44F7-AE90-9DB630BF5B31}']\r\n function EditIntf_GetVisibleObjectName : string;\r\n function EditIntf_TranslatePropertyName (const PropertyName : string) : string;\r\n function EditIntf_GetObjectHint : string;\r\n function EditIntf_GetPropertyHint(const PropertyName : string) : string;\r\n function EditIntf_DisplayProperty (const PropertyName : string) : Boolean;\r\n function EditIntf_IsPropertySimple (const PropertyName : string) : Boolean;\r\n end;\r\n\r\n IJvPropertyListEditorHandler = interface\r\n ['{BC1F664F-867F-4041-B718-0FD76A0CA3E8}']\r\n function ListEditIntf_ObjectCount : integer;\r\n function ListEditIntf_GetObject(Index : integer): TPersistent;\r\n function ListEditIntf_IndexOfObject(AObject : TPersistent) : Integer;\r\n procedure ListEditIntf_MoveObjectPosition (Index : Integer; PosDelta : Integer);\r\n procedure ListEditIntf_SortObjects (iAscending : Boolean);\r\n function ListEditIntf_CreateNewObject: TPersistent;\r\n function ListEditIntf_CloneNewObject(Index : integer): TPersistent;\r\n procedure ListEditIntf_DeleteObject (Index : integer);\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvPropertyStoreEditorIntf.pas $';\r\n Revision: '$Revision: 12694 $';\r\n Date: '$Date: 2010-02-09 00:11:12 +0100 (mar. 09 févr. 2010) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\n\r\nend." }, { "path": "External/Jedi/Jvcl/run/JvPrvwDoc.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvPrvwDoc.pas, released on 2003-01-01.\r\n\r\nThe Initial Developer of the Original Code is Peter Thrnqvist.\r\nPortions created by Peter Thrnqvist are Copyright (c) 2003 by Peter Thrnqvist.\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nTODO :\r\n * Adjust zoom when Cols or Rows change - DONE\r\n * Adjust Cols and/or Rows when Zoom changes - DONE\r\n * Center pages in view - DONE\r\n * Only show horizontal scroll when page is too large (1 page), otherwise size Cols to fit - DONE\r\n + Draw to offscreen bitmap - DONE\r\n * Handle wheel scroll (scroll: up-down / shift+scroll: left-right) - DONE\r\n * Implement TopRow, First, Next, Prior, Last - DONE\r\n * Page Number Hints when thumb scrolling - DONE\r\n * User configurable margins (could use DeviceInfo.OffsetLeft etc but needs to\r\n be available in inch/mm as well) - DONE\r\n\r\n * Handle getting/setting SelectedPage (click on page -> select it)\r\n * Draw \"fake\" text when page is small (like Word does)?\r\n * Handle Home, End, PgUp, PgDn (w. Ctrl?)\r\n\r\nKNOWN ISSUES:\r\n * smScale doesn't work in all cases\r\n * centering doesn't always work\r\n * scrolling down and then changing properties (like Cols or Scale) doesn't always reposition the\r\n view and the scrollbars correctly\r\n * sometimes displays more pages (rows) than requested\r\n\r\nScrolling rules:\r\n * if showing 1 page (page >= clientrect), show horz scrollbar, set scroll size ~ 1 line\r\n * if showing more than one col/row, hide horz scroll and scale pages to fit\r\n (i.e if Cols = 3, Rows = 2 -> scale to show 3x2 pages)\r\n and scroll Rows pages on each click (i.e if Rows = 4 -> scroll 4 pages)\r\n * if scaling would make pages too small, show as many pages as possible\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvPrvwDoc.pas 13415 2012-09-10 09:51:54Z obones $\r\n\r\nunit JvPrvwDoc;\r\n\r\n{$I jvcl.inc}\r\n{$I windowsonly.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, Messages, SysUtils, Classes, Graphics, Controls, StdCtrls,\r\n Forms, Dialogs,\r\n {$IFDEF HAS_UNIT_SYSTEM_UITYPES}\r\n System.UITypes,\r\n {$ENDIF HAS_UNIT_SYSTEM_UITYPES}\r\n JvComponent, JvExControls, JvTypes;\r\n\r\ntype\r\n TJvPreviewScaleMode = (\r\n smFullPage, // always show 1 full page\r\n smPageWidth, // always show max page width\r\n smScale, // always use scale, don't change cols and rows\r\n smAutoScale, // always use scale, change cols and rows to fit\r\n smColsRows); // use cols and rows\r\n\r\n TJvDrawPreviewEvent = procedure(Sender: TObject; PageIndex: Integer; Canvas: TCanvas;\r\n PageRect, PrintRect: TRect) of object;\r\n TJvDrawPageEvent = procedure(Sender: TObject; PageIndex: Integer; Canvas: TCanvas;\r\n PageRect, PrintRect: TRect; var NeedMorePages: Boolean) of object;\r\n TJvScrollHintEvent = procedure(Sender: TObject; AScrollPos: Integer; var AHint: string) of object;\r\n TJvCustomPreviewControl = class;\r\n\r\n IJvPrinter = interface\r\n ['{FDCCB7CD-8DF7-48B9-9924-CE439AE97999}']\r\n procedure SetTitle(const Value: string);\r\n function GetTitle: string;\r\n procedure BeginDoc;\r\n procedure EndDoc;\r\n procedure NewPage;\r\n procedure Abort;\r\n function GetAborted: Boolean;\r\n function GetCanvas: TCanvas;\r\n function GetPageWidth: Integer;\r\n function GetPageHeight: Integer;\r\n function GetPrinting: Boolean;\r\n function GetHandle: HDC;\r\n end;\r\n\r\n TJvDeviceInfo = class(TPersistent)\r\n private\r\n FPageHeight: Cardinal;\r\n FOffsetTop: Cardinal;\r\n FOffsetLeft: Cardinal;\r\n FOffsetBottom: Cardinal;\r\n FOffsetRight: Cardinal;\r\n FLogPixelsY: Cardinal;\r\n FPageWidth: Cardinal;\r\n FLogPixelsX: Cardinal;\r\n FOnChange: TNotifyEvent;\r\n FScreenDC: Longword;\r\n FReferenceHandle: Longword;\r\n FPhysicalHeight: Cardinal;\r\n FPhysicalWidth: Cardinal;\r\n procedure SetLogPixelsY(const Value: Cardinal);\r\n procedure SetLogPixesX(const Value: Cardinal);\r\n procedure SetOffsetX(const Value: Cardinal);\r\n procedure SetOffsetY(const Value: Cardinal);\r\n procedure SetPageHeight(const Value: Cardinal);\r\n procedure SetPageWidth(const Value: Cardinal);\r\n procedure DefaultDeviceInfo;\r\n procedure SetReferenceHandle(const Value: Longword);\r\n procedure SetPhysicalHeight(const Value: Cardinal);\r\n procedure SetPhysicalWidth(const Value: Cardinal);\r\n procedure SetOffsetBottom(const Value: Cardinal);\r\n procedure SetOffsetRight(const Value: Cardinal);\r\n protected\r\n function GetScreenDC: Longword;\r\n procedure Change;\r\n public\r\n constructor Create;\r\n destructor Destroy; override;\r\n function XPxToInch(Pixels: Integer): Single;\r\n function YPxToInch(Pixels: Integer): Single;\r\n function XPxToMM(Pixels: Integer): Single;\r\n function YPxToMM(Pixels: Integer): Single;\r\n function InchToXPx(Inch: Single): Integer;\r\n function InchToYPx(Inch: Single): Integer;\r\n function MMToXPx(MM: Single): Integer;\r\n function MMToYPx(MM: Single): Integer;\r\n property OnChange: TNotifyEvent read FOnChange write FOnChange;\r\n published\r\n property ReferenceHandle: Longword read FReferenceHandle write SetReferenceHandle;\r\n property LogPixelsX: Cardinal read FLogPixelsX write SetLogPixesX;\r\n property LogPixelsY: Cardinal read FLogPixelsY write SetLogPixelsY;\r\n property PhysicalWidth: Cardinal read FPhysicalWidth write SetPhysicalWidth;\r\n property PhysicalHeight: Cardinal read FPhysicalHeight write SetPhysicalHeight;\r\n property PageWidth: Cardinal read FPageWidth write SetPageWidth;\r\n property PageHeight: Cardinal read FPageHeight write SetPageHeight;\r\n property OffsetLeft: Cardinal read FOffsetLeft write SetOffsetX;\r\n property OffsetTop: Cardinal read FOffsetTop write SetOffsetY;\r\n property OffsetRight: Cardinal read FOffsetRight write SetOffsetRight;\r\n property OffsetBottom: Cardinal read FOffsetBottom write SetOffsetBottom;\r\n end;\r\n\r\n TJvPageShadow = class(TPersistent)\r\n private\r\n FOffset: Integer;\r\n FColor: TColor;\r\n FOnChange: TNotifyEvent;\r\n procedure SetColor(const Value: TColor);\r\n procedure SetOffset(const Value: Integer);\r\n procedure Change;\r\n public\r\n constructor Create;\r\n property OnChange: TNotifyEvent read FOnChange write FOnChange;\r\n published\r\n property Color: TColor read FColor write SetColor default clBlack;\r\n property Offset: Integer read FOffset write SetOffset default 4;\r\n end;\r\n\r\n TJvPreviewPageOptions = class(TPersistent)\r\n private\r\n FVertSpacing: Cardinal;\r\n FHorzSpacing: Cardinal;\r\n FColor: TColor;\r\n FShadow: TJvPageShadow;\r\n FOnChange: TNotifyEvent;\r\n FDrawMargins: Boolean;\r\n FCols: Cardinal;\r\n FScale: Cardinal;\r\n FRows: Cardinal;\r\n FScaleMode: TJvPreviewScaleMode;\r\n FOnScaleModeChange: TNotifyEvent;\r\n procedure SetColor(const Value: TColor);\r\n procedure SetHorzSpacing(const Value: Cardinal);\r\n procedure SetVertSpacing(const Value: Cardinal);\r\n procedure DoShadowChange(Sender: TObject);\r\n procedure SetDrawMargins(const Value: Boolean);\r\n procedure SetCols(const Value: Cardinal);\r\n procedure SetShadow(const Value: TJvPageShadow);\r\n procedure SetScale(const Value: Cardinal);\r\n procedure SetRows(const Value: Cardinal);\r\n procedure SetScaleMode(const Value: TJvPreviewScaleMode);\r\n procedure Change;\r\n procedure ScaleModeChange;\r\n function GetCols: Cardinal;\r\n function GetRows: Cardinal;\r\n function GetHorzSpacing: Cardinal;\r\n function GetVertSpacing: Cardinal;\r\n public\r\n constructor Create;\r\n destructor Destroy; override;\r\n property OnChange: TNotifyEvent read FOnChange write FOnChange;\r\n property OnScaleModeChange: TNotifyEvent read FOnScaleModeChange write FOnScaleModeChange;\r\n published\r\n property Color: TColor read FColor write SetColor default clWhite;\r\n property Cols: Cardinal read GetCols write SetCols default 1;\r\n property DrawMargins: Boolean read FDrawMargins write SetDrawMargins default True;\r\n property HorzSpacing: Cardinal read GetHorzSpacing write SetHorzSpacing default 8;\r\n property Rows: Cardinal read GetRows write SetRows;\r\n property Shadow: TJvPageShadow read FShadow write SetShadow;\r\n property VertSpacing: Cardinal read GetVertSpacing write SetVertSpacing default 8;\r\n property Scale: Cardinal read FScale write SetScale default 100;\r\n property ScaleMode: TJvPreviewScaleMode read FScaleMode write SetScaleMode default smFullPage;\r\n end;\r\n\r\n // properties for the SelectedPage property\r\n TJvPreviewSelection = class(TPersistent)\r\n private\r\n FVisible: Boolean;\r\n FWidth: Integer;\r\n FColor: TColor;\r\n FOnChange: TNotifyEvent;\r\n procedure SetColor(const Value: TColor);\r\n procedure SetWidth(const Value: Integer);\r\n procedure SetVisible(const Value: Boolean);\r\n protected\r\n procedure Change; virtual;\r\n property OnChange: TNotifyEvent read FOnChange write FOnChange;\r\n public\r\n constructor Create;\r\n procedure Assign(Source: TPersistent); override;\r\n published\r\n // frame color\r\n property Color: TColor read FColor write SetColor default clNavy;\r\n // frame width\r\n property Width: Integer read FWidth write SetWidth default 4;\r\n // frame visibility\r\n property Visible: Boolean read FVisible write SetVisible default True;\r\n end;\r\n\r\n TJvCustomPreviewControlDeactivateHintThread = class(TJvCustomThread)\r\n private\r\n FOwner: TJvCustomPreviewControl;\r\n FDelay: Integer;\r\n\r\n procedure HideHintWindow;\r\n protected\r\n procedure Execute; override;\r\n public\r\n constructor Create(AOwner: TJvCustomPreviewControl);\r\n procedure Start(Delay: Integer = 0);\r\n end;\r\n\r\n TJvCustomPreviewControl = class(TJvCustomControl)\r\n private\r\n FBuffer: TBitmap;\r\n FOptions: TJvPreviewPageOptions;\r\n FPages: TList;\r\n FScrollPos: TPoint;\r\n FOnDrawPreviewPage: TJvDrawPreviewEvent;\r\n FBorderStyle: TBorderStyle;\r\n FDeviceInfo: TJvDeviceInfo;\r\n FOnAddPage: TJvDrawPageEvent;\r\n FSelectedPage: Integer;\r\n FOnChange: TNotifyEvent;\r\n FUpdateCount: Integer;\r\n FPreviewRect: TRect;\r\n FPrintRect: TRect;\r\n FPageWidth: Integer;\r\n FPageHeight: Integer;\r\n FMaxHeight: Integer;\r\n FMaxWidth: Integer;\r\n FOffsetLeft: Integer;\r\n FOffsetTop: Integer;\r\n FOffsetRight: Integer;\r\n FOffsetBottom: Integer;\r\n FTotalCols: Integer;\r\n FTotalRows: Integer;\r\n FVisibleRows: Integer;\r\n FOnHorzScroll: TScrollEvent;\r\n FOnVertScroll: TScrollEvent;\r\n FOnAfterScroll: TNotifyEvent;\r\n FScrollBars: TScrollStyle;\r\n FHideScrollBars: Boolean;\r\n FOnDeviceInfoChange: TNotifyEvent;\r\n FOnScaleModeChange: TNotifyEvent;\r\n FOnOptionsChange: TNotifyEvent;\r\n FOnScrollHint: TJvScrollHintEvent;\r\n FSelection: TJvPreviewSelection;\r\n FHintWindow: THintWindow;\r\n FDeactivateHintThread: TJvCustomPreviewControlDeactivateHintThread;\r\n\r\n procedure DoOptionsChange(Sender: TObject);\r\n procedure DoDeviceInfoChange(Sender: TObject);\r\n procedure DoScaleModeChange(Sender: TObject);\r\n procedure DrawPreview(PageIndex: Integer; APageRect, APrintRect: TRect);\r\n procedure SetBorderStyle(const Value: TBorderStyle);\r\n function GetPage(Index: Integer): TMetafile;\r\n function GetPageCount: Integer;\r\n procedure SetDeviceInfo(const Value: TJvDeviceInfo);\r\n procedure SetOptions(const Value: TJvPreviewPageOptions);\r\n procedure SetSelectedPage(const Value: Integer);\r\n procedure SetTopRow(Value: Integer);\r\n procedure CMCtl3DChanged(var Msg: TMessage); message CM_CTL3DCHANGED;\r\n procedure WMHScroll(var Msg: TWMHScroll); message WM_HSCROLL;\r\n procedure WMVScroll(var Msg: TWMVScroll); message WM_VSCROLL;\r\n procedure CalcScrollRange;\r\n // returns the optimal scale value using current cols and rows\r\n function GetOptimalScale: Cardinal;\r\n function GetLesserScale(AHeight, AWidth: Cardinal): Cardinal;\r\n procedure UpdateSizes;\r\n procedure UpdateScale;\r\n function GetTopRow: Integer;\r\n procedure SetScrollBars(const Value: TScrollStyle);\r\n procedure SetHideScrollBars(const Value: Boolean);\r\n function IsPageMode: Boolean;\r\n procedure SetSelection(const Value: TJvPreviewSelection);\r\n protected\r\n procedure Change; dynamic;\r\n procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;\r\n procedure BoundsChanged; override;\r\n procedure GetDlgCode(var Code: TDlgCodes); override;\r\n function DoEraseBackground(Canvas: TCanvas; Param: LPARAM): Boolean; override;\r\n function DoMouseWheel(Shift: TShiftState; WheelDelta: Integer; MousePos: TPoint): Boolean; override;\r\n procedure DoScrollHint(NewPos: Integer);\r\n procedure CreateParams(var Params: TCreateParams); override;\r\n procedure DrawPages(ACanvas: TCanvas; Offset: TPoint);\r\n procedure DrawShadow(ACanvas: TCanvas; APageRect: TRect);\r\n procedure Paint; override;\r\n procedure DoDrawPreviewPage(PageIndex: Integer; Canvas: TCanvas;\r\n PageRect, PrintRect: TRect); dynamic;\r\n function DoAddPage(AMetaFile: TMetafile; PageIndex: Integer): Boolean; dynamic;\r\n property TopRow: Integer read GetTopRow write SetTopRow;\r\n property SelectedPage: Integer read FSelectedPage write SetSelectedPage;\r\n property BorderStyle: TBorderStyle read FBorderStyle write SetBorderStyle default bsSingle;\r\n property Color default clAppWorkSpace;\r\n property DeviceInfo: TJvDeviceInfo read FDeviceInfo write SetDeviceInfo;\r\n property ScrollBars: TScrollStyle read FScrollBars write SetScrollBars default ssBoth;\r\n property HideScrollBars: Boolean read FHideScrollBars write SetHideScrollBars default False;\r\n property Selection: TJvPreviewSelection read FSelection write SetSelection;\r\n property Options: TJvPreviewPageOptions read FOptions write SetOptions;\r\n property OnAddPage: TJvDrawPageEvent read FOnAddPage write FOnAddPage;\r\n property OnVertScroll: TScrollEvent read FOnVertScroll write FOnVertScroll;\r\n property OnHorzScroll: TScrollEvent read FOnHorzScroll write FOnHorzScroll;\r\n property OnAfterScroll: TNotifyEvent read FOnAfterScroll write FOnAfterScroll;\r\n property OnScrollHint: TJvScrollHintEvent read FOnScrollHint write FOnScrollHint;\r\n property OnDrawPreviewPage: TJvDrawPreviewEvent read FOnDrawPreviewPage write FOnDrawPreviewPage;\r\n property OnChange: TNotifyEvent read FOnChange write FOnChange;\r\n property OnDeviceInfoChange: TNotifyEvent read FOnDeviceInfoChange write FOnDeviceInfoChange;\r\n property OnOptionsChange: TNotifyEvent read FOnOptionsChange write FOnOptionsChange;\r\n property OnScaleModeChange: TNotifyEvent read FOnScaleModeChange write FOnScaleModeChange;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n // if Existing is False, returns the page that should have been at Pos\r\n function ItemAtPos(Pos: TPoint; Existing: Boolean): Integer;\r\n procedure BeginUpdate;\r\n procedure EndUpdate;\r\n function IsUpdating: Boolean;\r\n function Add: TMetafile;\r\n procedure Delete(Index: Integer);\r\n procedure Clear;\r\n procedure PrintRange(const APrinter: IJvPrinter;\r\n StartPage, EndPage, Copies: Integer; Collate: Boolean);\r\n procedure First;\r\n procedure Last;\r\n procedure Next;\r\n procedure Prior;\r\n property TotalCols: Integer read FTotalCols;\r\n property TotalRows: Integer read FTotalRows;\r\n property VisibleRows: Integer read FVisibleRows;\r\n property Pages[Index: Integer]: TMetafile read GetPage;\r\n property PageCount: Integer read GetPageCount;\r\n end;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvPreviewControl = class(TJvCustomPreviewControl)\r\n published\r\n property TopRow;\r\n property ScrollBars;\r\n property HideScrollBars;\r\n property SelectedPage;\r\n property BorderStyle;\r\n property Color default clAppWorkSpace;\r\n property DeviceInfo;\r\n property Options;\r\n property Selection;\r\n property OnChange;\r\n property OnDeviceInfoChange;\r\n property OnOptionsChange;\r\n property OnScaleModeChange;\r\n property OnVertScroll;\r\n property OnHorzScroll;\r\n property OnAfterScroll;\r\n property OnScrollHint;\r\n property OnAddPage;\r\n property OnDrawPreviewPage;\r\n\r\n property Align;\r\n property Anchors;\r\n property AutoSize;\r\n property BevelEdges;\r\n property BevelInner;\r\n property BevelOuter;\r\n property BevelKind;\r\n property BevelWidth;\r\n property BiDiMode;\r\n property Constraints;\r\n property DockSite;\r\n property DragCursor;\r\n property DragKind;\r\n property DragMode;\r\n property Enabled;\r\n property Font;\r\n property ParentBiDiMode;\r\n property ParentColor;\r\n property ParentFont;\r\n property ParentShowHint;\r\n property PopupMenu;\r\n property ShowHint;\r\n property TabOrder;\r\n property TabStop default True;\r\n property Visible;\r\n property OnCanResize;\r\n property OnClick;\r\n property OnConstrainedResize;\r\n property OnContextPopup;\r\n property OnDblClick;\r\n property OnDockDrop;\r\n property OnDockOver;\r\n property OnDragDrop;\r\n property OnDragOver;\r\n property OnEndDock;\r\n property OnEndDrag;\r\n property OnEnter;\r\n property OnExit;\r\n property OnGetSiteInfo;\r\n property OnMouseDown;\r\n property OnMouseMove;\r\n property OnMouseUp;\r\n property OnMouseWheel;\r\n property OnMouseWheelDown;\r\n property OnMouseWheelUp;\r\n property OnResize;\r\n property OnStartDock;\r\n property OnStartDrag;\r\n property OnUnDock;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvPrvwDoc.pas $';\r\n Revision: '$Revision: 13415 $';\r\n Date: '$Date: 2012-09-10 11:51:54 +0200 (lun. 10 sept. 2012) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n Types, Math,\r\n JvThemes;\r\n\r\n // returns True if Inner is completely within Outer\r\n\r\nfunction RectInRect(Inner, Outer: TRect): Boolean;\r\n\r\n function InRange(const AValue, AMin, AMax: Integer): Boolean;\r\n begin\r\n Result := (AValue >= AMin) and (AValue <= AMax);\r\n end;\r\n\r\nbegin\r\n Result :=\r\n InRange(Inner.Left, Outer.Left, Outer.Right) and\r\n InRange(Inner.Top, Outer.Top, Outer.Bottom) and\r\n InRange(Inner.Right, Outer.Left, Outer.Right) and\r\n InRange(Inner.Bottom, Outer.Top, Outer.Bottom);\r\nend;\r\n\r\n// returns True if any part of Inner is \"visible\" inside Outer\r\n// (any edge of Inner within Outer or Outer within Inner)\r\n\r\nfunction PartialInRect(Inner, Outer: TRect): Boolean;\r\nbegin\r\n Result :=\r\n (Inner.Left < Outer.Right) and\r\n (Inner.Top < Outer.Bottom) and\r\n (Inner.Right > Outer.Left) and\r\n (Inner.Bottom > Outer.Top);\r\nend;\r\n\r\n//=== { TJvPreviewPageOptions } ==============================================\r\n\r\nconstructor TJvPreviewPageOptions.Create;\r\nbegin\r\n inherited Create;\r\n FShadow := TJvPageShadow.Create;\r\n FShadow.OnChange := DoShadowChange;\r\n FCols := 1;\r\n FRows := 1;\r\n FScale := 100;\r\n FScaleMode := smFullPage;\r\n FColor := clWhite;\r\n FVertSpacing := 8;\r\n FHorzSpacing := 8;\r\n FDrawMargins := True;\r\nend;\r\n\r\ndestructor TJvPreviewPageOptions.Destroy;\r\nbegin\r\n FShadow.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvPreviewPageOptions.Change;\r\nbegin\r\n if Assigned(FOnChange) then\r\n FOnChange(Self);\r\nend;\r\n\r\nprocedure TJvPreviewPageOptions.DoShadowChange(Sender: TObject);\r\nbegin\r\n Change;\r\nend;\r\n\r\nfunction TJvPreviewPageOptions.GetCols: Cardinal;\r\nbegin\r\n Result := Max(FCols, 1);\r\nend;\r\n\r\nfunction TJvPreviewPageOptions.GetHorzSpacing: Cardinal;\r\nbegin\r\n Result := Max(FHorzSpacing, Abs(Shadow.Offset));\r\nend;\r\n\r\nfunction TJvPreviewPageOptions.GetRows: Cardinal;\r\nbegin\r\n Result := Max(FRows, 1);\r\nend;\r\n\r\nfunction TJvPreviewPageOptions.GetVertSpacing: Cardinal;\r\nbegin\r\n Result := Max(FVertSpacing, Abs(Shadow.Offset));\r\nend;\r\n\r\nprocedure TJvPreviewPageOptions.SetColor(const Value: TColor);\r\nbegin\r\n if FColor <> Value then\r\n begin\r\n FColor := Value;\r\n Change;\r\n end;\r\nend;\r\n\r\nprocedure TJvPreviewPageOptions.SetCols(const Value: Cardinal);\r\nbegin\r\n if FCols <> Value then\r\n begin\r\n FCols := Value;\r\n if FCols < 1 then\r\n FCols := 1;\r\n Change;\r\n end;\r\nend;\r\n\r\nprocedure TJvPreviewPageOptions.SetDrawMargins(const Value: Boolean);\r\nbegin\r\n if FDrawMargins <> Value then\r\n begin\r\n FDrawMargins := Value;\r\n Change;\r\n end;\r\nend;\r\n\r\nprocedure TJvPreviewPageOptions.SetHorzSpacing(const Value: Cardinal);\r\nbegin\r\n if FHorzSpacing <> Value then\r\n begin\r\n FHorzSpacing := Value;\r\n Change;\r\n end;\r\nend;\r\n\r\nprocedure TJvPreviewPageOptions.SetRows(const Value: Cardinal);\r\nbegin\r\n if FRows <> Value then\r\n begin\r\n FRows := Value;\r\n Change;\r\n end;\r\nend;\r\n\r\nprocedure TJvPreviewPageOptions.SetShadow(const Value: TJvPageShadow);\r\nbegin\r\n FShadow.Assign(Value);\r\nend;\r\n\r\nprocedure TJvPreviewPageOptions.SetVertSpacing(const Value: Cardinal);\r\nbegin\r\n if FVertSpacing <> Value then\r\n begin\r\n FVertSpacing := Value;\r\n Change;\r\n end;\r\nend;\r\n\r\nprocedure TJvPreviewPageOptions.SetScale(const Value: Cardinal);\r\nbegin\r\n if FScale <> Value then\r\n begin\r\n FScale := Max(Value, 1);\r\n Change;\r\n end;\r\nend;\r\n\r\nprocedure TJvPreviewPageOptions.SetScaleMode(\r\n const Value: TJvPreviewScaleMode);\r\nbegin\r\n if FScaleMode <> Value then\r\n begin\r\n FScaleMode := Value;\r\n ScaleModeChange;\r\n end;\r\nend;\r\n\r\nprocedure TJvPreviewPageOptions.ScaleModeChange;\r\nbegin\r\n if Assigned(FOnScaleModeChange) then\r\n FOnScaleModeChange(Self)\r\n else\r\n Change;\r\nend;\r\n\r\n//=== { TJvPageShadow } ======================================================\r\n\r\nconstructor TJvPageShadow.Create;\r\nbegin\r\n inherited Create;\r\n FColor := clBlack;\r\n FOffset := 4;\r\nend;\r\n\r\nprocedure TJvPageShadow.Change;\r\nbegin\r\n if Assigned(FOnChange) then\r\n FOnChange(Self);\r\nend;\r\n\r\nprocedure TJvPageShadow.SetColor(const Value: TColor);\r\nbegin\r\n if FColor <> Value then\r\n begin\r\n FColor := Value;\r\n Change;\r\n end;\r\nend;\r\n\r\nprocedure TJvPageShadow.SetOffset(const Value: Integer);\r\nbegin\r\n if FOffset <> Value then\r\n begin\r\n FOffset := Value;\r\n Change;\r\n end;\r\nend;\r\n\r\n//=== { TJvDeviceInfo } ======================================================\r\n\r\nconstructor TJvDeviceInfo.Create;\r\nbegin\r\n inherited Create;\r\n DefaultDeviceInfo;\r\nend;\r\n\r\ndestructor TJvDeviceInfo.Destroy;\r\nbegin\r\n if FScreenDC <> 0 then\r\n ReleaseDC(HWND_DESKTOP, FScreenDC);\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvDeviceInfo.Change;\r\nbegin\r\n if Assigned(FOnChange) then\r\n FOnChange(Self);\r\nend;\r\n\r\nfunction TJvDeviceInfo.GetScreenDC: Longword;\r\nbegin\r\n if FScreenDC <> 0 then\r\n ReleaseDC(HWND_DESKTOP, FScreenDC);\r\n FScreenDC := GetDC(HWND_DESKTOP);\r\n Result := FScreenDC;\r\nend;\r\n\r\nfunction TJvDeviceInfo.InchToXPx(Inch: Single): Integer;\r\nbegin\r\n Result := Round(Inch * LogPixelsX);\r\nend;\r\n\r\nfunction TJvDeviceInfo.InchToYPx(Inch: Single): Integer;\r\nbegin\r\n Result := Round(Inch * LogPixelsY);\r\nend;\r\n\r\nfunction TJvDeviceInfo.MMToXPx(MM: Single): Integer;\r\nbegin\r\n Result := InchToXPx(MM / 25.4);\r\nend;\r\n\r\nfunction TJvDeviceInfo.MMToYPx(MM: Single): Integer;\r\nbegin\r\n Result := InchToYPx(MM / 25.4);\r\nend;\r\n\r\nprocedure TJvDeviceInfo.SetLogPixelsY(const Value: Cardinal);\r\nbegin\r\n if FLogPixelsY <> Value then\r\n begin\r\n FLogPixelsY := Value;\r\n Change;\r\n end;\r\nend;\r\n\r\nprocedure TJvDeviceInfo.SetLogPixesX(const Value: Cardinal);\r\nbegin\r\n if FLogPixelsX <> Value then\r\n begin\r\n FLogPixelsX := Value;\r\n Change;\r\n end;\r\nend;\r\n\r\nprocedure TJvDeviceInfo.SetOffsetBottom(const Value: Cardinal);\r\nbegin\r\n if FOffsetBottom <> Value then\r\n begin\r\n FOffsetBottom := Value;\r\n Change;\r\n end;\r\nend;\r\n\r\nprocedure TJvDeviceInfo.SetOffsetRight(const Value: Cardinal);\r\nbegin\r\n if FOffsetRight <> Value then\r\n begin\r\n FOffsetRight := Value;\r\n Change;\r\n end;\r\nend;\r\n\r\nprocedure TJvDeviceInfo.SetOffsetX(const Value: Cardinal);\r\nbegin\r\n if FOffsetLeft <> Value then\r\n begin\r\n FOffsetLeft := Value;\r\n Change;\r\n end;\r\nend;\r\n\r\nprocedure TJvDeviceInfo.SetOffsetY(const Value: Cardinal);\r\nbegin\r\n if FOffsetTop <> Value then\r\n begin\r\n FOffsetTop := Value;\r\n Change;\r\n end;\r\nend;\r\n\r\nprocedure TJvDeviceInfo.SetPageHeight(const Value: Cardinal);\r\nbegin\r\n if FPageHeight <> Value then\r\n begin\r\n FPageHeight := Value;\r\n Change;\r\n end;\r\nend;\r\n\r\nprocedure TJvDeviceInfo.SetPageWidth(const Value: Cardinal);\r\nbegin\r\n if FPageWidth <> Value then\r\n begin\r\n FPageWidth := Value;\r\n Change;\r\n end;\r\nend;\r\n\r\nprocedure TJvDeviceInfo.SetPhysicalHeight(const Value: Cardinal);\r\nbegin\r\n if FPhysicalHeight <> Value then\r\n begin\r\n FPhysicalHeight := Value;\r\n Change;\r\n end;\r\nend;\r\n\r\nprocedure TJvDeviceInfo.SetPhysicalWidth(const Value: Cardinal);\r\nbegin\r\n if FPhysicalWidth <> Value then\r\n begin\r\n FPhysicalWidth := Value;\r\n Change;\r\n end;\r\nend;\r\n\r\nprocedure TJvDeviceInfo.SetReferenceHandle(const Value: Longword);\r\nbegin\r\n FReferenceHandle := Value;\r\n if FReferenceHandle = 0 then\r\n begin\r\n DefaultDeviceInfo;\r\n Exit;\r\n end;\r\n FLogPixelsX := GetDeviceCaps(FReferenceHandle, Windows.LOGPIXELSX);\r\n FLogPixelsY := GetDeviceCaps(FReferenceHandle, Windows.LOGPIXELSY);\r\n FPageWidth := GetDeviceCaps(FReferenceHandle, HORZRES);\r\n FPageHeight := GetDeviceCaps(FReferenceHandle, VERTRES);\r\n FPhysicalWidth := Max(GetDeviceCaps(FReferenceHandle, Windows.PHYSICALWIDTH), FPageWidth);\r\n FPhysicalHeight := Max(GetDeviceCaps(FReferenceHandle, Windows.PHYSICALHEIGHT), FPageHeight);\r\n\r\n FOffsetLeft := GetDeviceCaps(FReferenceHandle, PHYSICALOFFSETX);\r\n FOffsetTop := GetDeviceCaps(FReferenceHandle, PHYSICALOFFSETY);\r\n if FPhysicalWidth <> FPageWidth then\r\n FOffsetRight := Max(FPhysicalWidth - FPageWidth - FOffsetLeft, 0)\r\n else\r\n FOffsetRight := FOffsetLeft;\r\n if FPhysicalHeight <> FPageHeight then\r\n FOffsetBottom := Max(FPhysicalHeight - FPageHeight - FOffsetTop, 0)\r\n else\r\n FOffsetBottom := FOffsetTop;\r\n Change;\r\nend;\r\n\r\nprocedure TJvDeviceInfo.DefaultDeviceInfo;\r\nbegin\r\n // default sizes using my current printer (HP DeskJet 690C)\r\n FReferenceHandle := 0;\r\n FLogPixelsX := 300;\r\n FLogPixelsY := 300;\r\n FPhysicalWidth := 2480;\r\n FPhysicalHeight := 3507;\r\n FPageWidth := 2400;\r\n FPageHeight := 3281;\r\n\r\n FOffsetLeft := 40;\r\n FOffsetTop := 40;\r\n FOffsetRight := 40;\r\n FOffsetBottom := 40;\r\n Change;\r\nend;\r\n\r\nfunction TJvDeviceInfo.XPxToInch(Pixels: Integer): Single;\r\nbegin\r\n Result := Pixels / LogPixelsX;\r\nend;\r\n\r\nfunction TJvDeviceInfo.XPxToMM(Pixels: Integer): Single;\r\nbegin\r\n Result := XPxToInch(Pixels) * 25.4;\r\nend;\r\n\r\nfunction TJvDeviceInfo.YPxToInch(Pixels: Integer): Single;\r\nbegin\r\n Result := Pixels / LogPixelsY;\r\nend;\r\n\r\nfunction TJvDeviceInfo.YPxToMM(Pixels: Integer): Single;\r\nbegin\r\n Result := YPxToInch(Pixels) * 25.4;\r\nend;\r\n\r\n//=== { TJvCustomPreviewControl } ============================================\r\n\r\nconstructor TJvCustomPreviewControl.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FSelectedPage := -1;\r\n FPages := TList.Create;\r\n FPages.Capacity := 64;\r\n FBuffer := TBitmap.Create;\r\n\r\n FOptions := TJvPreviewPageOptions.Create;\r\n FOptions.OnChange := DoOptionsChange;\r\n FOptions.OnScaleModeChange := DoScaleModeChange;\r\n\r\n FDeviceInfo := TJvDeviceInfo.Create;\r\n FDeviceInfo.OnChange := DoDeviceInfoChange;\r\n\r\n FSelection := TJvPreviewSelection.Create;\r\n FSelection.OnChange := DoOptionsChange;\r\n\r\n Color := clAppWorkSpace;\r\n ControlStyle := [csOpaque, csAcceptsControls, csCaptureMouse, csClickEvents, csDoubleClicks];\r\n IncludeThemeStyle(Self, [csNeedsBorderPaint]);\r\n Width := 150;\r\n Height := 250;\r\n FBorderStyle := bsSingle;\r\n FScrollBars := ssBoth;\r\n FHideScrollBars := False;\r\n TabStop := True;\r\n\r\n FDeactivateHintThread := TJvCustomPreviewControlDeactivateHintThread.Create(Self);\r\nend;\r\n\r\ndestructor TJvCustomPreviewControl.Destroy;\r\nbegin\r\n Clear;\r\n FDeviceInfo.Free;\r\n FSelection.Free;\r\n FOptions.Free;\r\n FPages.Free;\r\n FBuffer.Free;\r\n FDeactivateHintThread.Free;\r\n FHintWindow.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJvCustomPreviewControl.Add: TMetafile;\r\nbegin\r\n repeat\r\n Result := TMetafile.Create;\r\n Result.Width := DeviceInfo.PhysicalWidth;\r\n Result.Height := DeviceInfo.PhysicalHeight;\r\n // keep adding pages until user says stop\r\n until not DoAddPage(Result, FPages.Add(Result));\r\n Change;\r\nend;\r\n\r\nprocedure TJvCustomPreviewControl.CalcScrollRange;\r\nvar\r\n SI: TScrollInfo;\r\nbegin\r\n // HORIZONTAL SCROLLBAR\r\n FillChar(SI, SizeOf(TScrollInfo), 0);\r\n SI.cbSize := SizeOf(TScrollInfo);\r\n SI.fMask := SIF_ALL;\r\n if not HideScrollBars then\r\n Inc(SI.fMask, SIF_DISABLENOSCROLL);\r\n GetScrollInfo(Handle, SB_HORZ, SI);\r\n\r\n SI.nMax := FMaxWidth - ClientWidth;\r\n SI.nPage := 0;\r\n ShowScrollBar(Handle, SB_HORZ, not HideScrollBars and (ScrollBars in [ssHorizontal, ssBoth]));\r\n SetScrollInfo(Handle, SB_HORZ, SI, True);\r\n // update scroll pos if it has changed\r\n GetScrollInfo(Handle, SB_HORZ, SI);\r\n if SI.nPos <> FScrollPos.X then\r\n begin\r\n ScrollBy(-FScrollPos.X + SI.nPos, 0);\r\n FScrollPos.X := SI.nPos;\r\n end;\r\n\r\n // VERTICAL SCROLLBAR\r\n FillChar(SI, SizeOf(TScrollInfo), 0);\r\n SI.cbSize := SizeOf(TScrollInfo);\r\n SI.fMask := SIF_ALL;\r\n if not HideScrollBars then\r\n Inc(SI.fMask, SIF_DISABLENOSCROLL);\r\n GetScrollInfo(Handle, SB_VERT, SI);\r\n if PageCount = 0 then\r\n begin\r\n SI.nMax := 0;\r\n SI.nPage := 0;\r\n end\r\n else\r\n begin\r\n SI.nMax := FMaxHeight - ClientHeight;\r\n SI.nPage := 0; // FMaxHeight div TotalRows;\r\n end;\r\n ShowScrollBar(Handle, SB_VERT, not HideScrollBars and (ScrollBars in [ssVertical, ssBoth]));\r\n SetScrollInfo(Handle, SB_VERT, SI, True);\r\n // update scroll pos if it has changed\r\n GetScrollInfo(Handle, SB_VERT, SI);\r\n if SI.nPos <> FScrollPos.Y then\r\n begin\r\n ScrollBy(0, -FScrollPos.Y + SI.nPos);\r\n FScrollPos.Y := SI.nPos;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomPreviewControl.Clear;\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := 0 to FPages.Count - 1 do\r\n TMetafile(FPages[I]).Free;\r\n FPages.Count := 0;\r\n if not (csDestroying in ComponentState) then\r\n Change;\r\nend;\r\n\r\nprocedure TJvCustomPreviewControl.CMCtl3DChanged(var Msg: TMessage);\r\nbegin\r\n if FBorderStyle = bsSingle then\r\n RecreateWnd;\r\n inherited;\r\nend;\r\n\r\nprocedure TJvCustomPreviewControl.CreateParams(var Params: TCreateParams);\r\nconst\r\n BorderStyles: array[TBorderStyle] of DWORD = (0, WS_BORDER);\r\nbegin\r\n inherited CreateParams(Params);\r\n with Params do\r\n begin\r\n Style := Style or BorderStyles[FBorderStyle];\r\n if Ctl3D and (FBorderStyle = bsSingle) then\r\n begin\r\n Style := Style and not WS_BORDER;\r\n ExStyle := ExStyle or WS_EX_CLIENTEDGE;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomPreviewControl.Delete(Index: Integer);\r\nbegin\r\n TMetafile(FPages[Index]).Free;\r\n FPages.Delete(Index);\r\n Change;\r\nend;\r\n\r\nfunction TJvCustomPreviewControl.DoAddPage(AMetaFile: TMetafile; PageIndex: Integer): Boolean;\r\nvar\r\n ACanvas: TMetaFileCanvas;\r\n APageRect, APrintRect: TRect;\r\n I: Integer;\r\nbegin\r\n Result := False;\r\n ACanvas := TMetaFileCanvas.Create(AMetaFile, DeviceInfo.ReferenceHandle);\r\n try\r\n SetMapMode(ACanvas.Handle, MM_ANISOTROPIC);\r\n with DeviceInfo do\r\n begin\r\n SetWindowOrgEx(ACanvas.Handle, 0, 0, nil);\r\n SetWindowExtEx(ACanvas.Handle, PhysicalWidth, PhysicalHeight, nil);\r\n SetViewportExtEx(ACanvas.Handle, PhysicalWidth, PhysicalHeight, nil);\r\n end;\r\n // NB! Font.Size is changed when PPI is changed, so store and reset\r\n I := ACanvas.Font.Size;\r\n ACanvas.Font.PixelsPerInch := DeviceInfo.LogPixelsY;\r\n ACanvas.Font.Size := I;\r\n\r\n if Assigned(FOnAddPage) then\r\n with DeviceInfo do\r\n begin\r\n APageRect := Rect(0, 0, PhysicalWidth, PhysicalHeight);\r\n APrintRect := APageRect;\r\n\r\n Inc(APrintRect.Left, OffsetLeft);\r\n Inc(APrintRect.Top, OffsetTop);\r\n Dec(APrintRect.Right, OffsetRight);\r\n Dec(APrintRect.Bottom, OffsetBottom);\r\n\r\n FOnAddPage(Self, PageIndex, ACanvas, APageRect, APrintRect, Result);\r\n end;\r\n finally\r\n // spool canvas to metafile\r\n ACanvas.Free;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomPreviewControl.DoDrawPreviewPage(PageIndex: Integer;\r\n Canvas: TCanvas; PageRect, PrintRect: TRect);\r\nbegin\r\n if Assigned(FOnDrawPreviewPage) then\r\n FOnDrawPreviewPage(Self, PageIndex, Canvas, PageRect, PrintRect);\r\nend;\r\n\r\nprocedure TJvCustomPreviewControl.DoOptionsChange(Sender: TObject);\r\nbegin\r\n Change;\r\n if Assigned(FOnOptionsChange) then\r\n FOnOptionsChange(Self);\r\nend;\r\n\r\nprocedure TJvCustomPreviewControl.DoScaleModeChange(Sender: TObject);\r\nbegin\r\n Change;\r\n if Assigned(FOnScaleModeChange) then\r\n FOnScaleModeChange(Self);\r\nend;\r\n\r\nprocedure TJvCustomPreviewControl.DoDeviceInfoChange(Sender: TObject);\r\nbegin\r\n Change;\r\n if Assigned(FOnDeviceInfoChange) then\r\n FOnDeviceInfoChange(Self);\r\nend;\r\n\r\nprocedure TJvCustomPreviewControl.DrawPages(ACanvas: TCanvas; Offset: TPoint);\r\nvar\r\n I, J, K, M, AOffsetX, AOffsetY, APageIndex: Integer;\r\n APageRect, APrintRect: TRect;\r\n // SI: TScrollInfo;\r\n Tmp: Boolean;\r\n\r\n function CanDrawPage(APageIndex: Integer; APageRect: TRect): Boolean;\r\n begin\r\n Result := (APageIndex < PageCount) or (PageCount = 0);\r\n if not Result then\r\n Exit;\r\n Result := not IsPageMode;\r\n if not Result then\r\n Result := RectInRect(APageRect, ClientRect)\r\n else\r\n Result := PartialInRect(APageRect, ClientRect);\r\n end;\r\n\r\nbegin\r\n APageRect := FPreviewRect;\r\n APrintRect := FPrintRect;\r\n\r\n // initial top/left offset\r\n AOffsetX := -Offset.X + Max((ClientWidth - ((FPageWidth + Integer(Options.HorzSpacing)) * TotalCols)) div 2,\r\n FOptions.HorzSpacing);\r\n if IsPageMode then\r\n AOffsetY := -Offset.Y + Max((ClientHeight - ((FPageHeight + Integer(Options.VertSpacing)) * VisibleRows)) div 2,\r\n FOptions.VertSpacing)\r\n else\r\n AOffsetY := -Offset.Y + Integer(Options.VertSpacing);\r\n K := 0;\r\n with ACanvas do\r\n begin\r\n Brush.Color := Color;\r\n FillRect(ClipRect);\r\n Pen.Color := clBlack;\r\n Pen.Style := psDot;\r\n { (rom) disabled\r\n // $IFDEF DEBUG\r\n Polyline([\r\n Point(AOffsetX, AOffsetY),\r\n Point(AOffsetX, AOffsetY + FMaxHeight),\r\n Point(AOffsetX + FMaxWidth, AOffsetY + FMaxHeight),\r\n Point(AOffsetX + FMaxWidth, AOffsetY),\r\n Point(AOffsetX, AOffsetY)\r\n ]);\r\n // $ENDIF DEBUG\r\n }\r\n Pen.Style := psSolid;\r\n APageIndex := K * TotalCols;\r\n M := Max(0, PageCount - 1);\r\n // if not IsPageMode and (K > 0) then\r\n // Dec(K);\r\n for I := K to M do\r\n begin\r\n APrintRect := FPrintRect;\r\n APageRect := FPreviewRect;\r\n OffsetRect(APrintRect, AOffsetX, AOffsetY + (FPageHeight + Integer(Options.VertSpacing)) * I);\r\n OffsetRect(APageRect, AOffsetX, AOffsetY + (FPageHeight + Integer(Options.VertSpacing)) * I);\r\n for J := 0 to TotalCols - 1 do\r\n begin\r\n // avoid drawing partial pages when previewrect < clientrect\r\n Tmp := CanDrawPage(APageIndex, APageRect);\r\n if Tmp then\r\n begin\r\n DrawShadow(ACanvas, APageRect);\r\n // draw background\r\n Brush.Color := Options.Color;\r\n FillRect(APageRect);\r\n // draw preview content\r\n if APageIndex < PageCount then\r\n DrawPreview(APageIndex, APageRect, APrintRect);\r\n // draw frame\r\n Brush.Style := bsClear;\r\n Pen.Color := clWindowText;\r\n Rectangle(APageRect);\r\n if (APageIndex = FSelectedPage) and Selection.Visible then\r\n begin\r\n Pen.Color := Selection.Color;\r\n Pen.Width := Selection.Width;\r\n Rectangle(APageRect);\r\n Pen.Color := clWindowText;\r\n Pen.Width := 1;\r\n end;\r\n // draw margins\r\n if Options.DrawMargins and not EqualRect(APageRect, APrintRect) then\r\n begin\r\n Pen.Style := psDot;\r\n Rectangle(APrintRect);\r\n Pen.Style := psSolid;\r\n end;\r\n Brush.Style := bsSolid;\r\n if PageCount = 0 then\r\n Exit; // we've drawn one empty page, so let's skip the rest\r\n end;\r\n OffsetRect(APrintRect, FPageWidth + Integer(Options.HorzSpacing), 0);\r\n OffsetRect(APageRect, FPageWidth + Integer(Options.HorzSpacing), 0);\r\n Inc(APageIndex);\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomPreviewControl.DrawPreview(PageIndex: Integer;\r\n APageRect, APrintRect: TRect);\r\nvar\r\n SaveIndex: Integer;\r\nbegin\r\n // prevent painting outside page\r\n SaveIndex := SaveDC(FBuffer.Canvas.Handle);\r\n IntersectClipRect(FBuffer.Canvas.Handle, APageRect.Left, APageRect.Top, APageRect.Right, APageRect.Bottom);\r\n FBuffer.Canvas.StretchDraw(APageRect, Pages[PageIndex]);\r\n DoDrawPreviewPage(PageIndex, FBuffer.Canvas, APageRect, APrintRect);\r\n RestoreDC(FBuffer.Canvas.Handle, SaveIndex);\r\nend;\r\n\r\nfunction TJvCustomPreviewControl.GetPage(Index: Integer): TMetafile;\r\nbegin\r\n Result := TMetafile(FPages[Index]);\r\nend;\r\n\r\nfunction TJvCustomPreviewControl.GetPageCount: Integer;\r\nbegin\r\n Result := FPages.Count;\r\nend;\r\n\r\nprocedure TJvCustomPreviewControl.Paint;\r\nbegin\r\n if IsUpdating then\r\n Exit;\r\n FBuffer.Width := ClientWidth;\r\n FBuffer.Height := ClientHeight;\r\n // Canvas.Brush.Color := Color;\r\n // Canvas.FillRect(ClientRect);\r\n DrawPages(FBuffer.Canvas, Point(FScrollPos.X, FScrollPos.Y));\r\n BitBlt(Canvas.Handle, 0, 0, FBuffer.Width, FBuffer.Height, FBuffer.Canvas.Handle,\r\n 0, 0, SRCCOPY);\r\nend;\r\n\r\nprocedure TJvCustomPreviewControl.SetBorderStyle(const Value: TBorderStyle);\r\nbegin\r\n if FBorderStyle <> Value then\r\n begin\r\n FBorderStyle := Value;\r\n RecreateWnd;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomPreviewControl.SetSelectedPage(const Value: Integer);\r\nbegin\r\n if FSelectedPage <> Value then\r\n begin\r\n FSelectedPage := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomPreviewControl.SetDeviceInfo(const Value: TJvDeviceInfo);\r\nbegin\r\n FDeviceInfo.Assign(Value);\r\nend;\r\n\r\nprocedure TJvCustomPreviewControl.SetOptions(const Value: TJvPreviewPageOptions);\r\nbegin\r\n FOptions.Assign(Value);\r\nend;\r\n\r\nfunction TJvCustomPreviewControl.DoEraseBackground(Canvas: TCanvas; Param: LPARAM): Boolean;\r\nbegin\r\n // inherited DoEraseBackground(Canvas, Param);\r\n Result := True;\r\nend;\r\n\r\nprocedure TJvCustomPreviewControl.BoundsChanged;\r\nvar\r\n TmpRow: Integer;\r\nbegin\r\n inherited BoundsChanged;\r\n TmpRow := TopRow; // workaround...\r\n Change;\r\n if IsPageMode then\r\n TopRow := TmpRow; // workaround...\r\nend;\r\n\r\nprocedure TJvCustomPreviewControl.WMHScroll(var Msg: TWMHScroll);\r\nvar\r\n SI: TScrollInfo;\r\n NewPos, Increment: Integer;\r\nbegin\r\n if IsPageMode then\r\n Exit;\r\n Increment := FPageWidth div 3;\r\n FillChar(SI, SizeOf(TScrollInfo), 0);\r\n SI.cbSize := SizeOf(TScrollInfo);\r\n SI.fMask := SIF_ALL;\r\n GetScrollInfo(Handle, SB_HORZ, SI);\r\n case Msg.ScrollCode of\r\n SB_TOP:\r\n NewPos := 0;\r\n SB_BOTTOM:\r\n NewPos := FMaxWidth;\r\n SB_LINEDOWN, SB_PAGEDOWN:\r\n NewPos := FScrollPos.X + Increment;\r\n SB_LINEUP, SB_PAGEUP:\r\n NewPos := FScrollPos.X - Increment;\r\n SB_THUMBPOSITION, SB_THUMBTRACK:\r\n begin\r\n NewPos := SI.nTrackPos;\r\n if NewPos = FScrollPos.X then\r\n Exit;\r\n end;\r\n SB_ENDSCROLL:\r\n Exit;\r\n end;\r\n NewPos := EnsureRange(NewPos, SI.nMin, SI.nMax);\r\n if Assigned(FOnHorzScroll) then\r\n FOnHorzScroll(Self, TScrollCode(Msg.ScrollCode), NewPos);\r\n NewPos := EnsureRange(NewPos, SI.nMin, SI.nMax);\r\n ScrollBy(-FScrollPos.X + NewPos, 0);\r\n FScrollPos.X := NewPos;\r\n SI.nPos := NewPos;\r\n SetScrollInfo(Handle, SB_HORZ, SI, True);\r\n if Assigned(FOnAfterScroll) then\r\n FOnAfterScroll(Self);\r\n Refresh;\r\nend;\r\n\r\nprocedure TJvCustomPreviewControl.WMVScroll(var Msg: TWMVScroll);\r\nvar\r\n SI: TScrollInfo;\r\n NewPos, Increment: Integer;\r\nbegin\r\n Increment := FPageHeight + Integer(Options.VertSpacing);\r\n if not IsPageMode then\r\n Increment := Increment div 3;\r\n if Increment < 1 then\r\n Increment := 1;\r\n\r\n FillChar(SI, SizeOf(TScrollInfo), 0);\r\n SI.cbSize := SizeOf(TScrollInfo);\r\n SI.fMask := SIF_ALL;\r\n GetScrollInfo(Handle, SB_VERT, SI);\r\n case Msg.ScrollCode of\r\n SB_TOP:\r\n NewPos := 0;\r\n SB_BOTTOM:\r\n NewPos := FMaxHeight;\r\n SB_LINEDOWN, SB_PAGEDOWN:\r\n NewPos := FScrollPos.Y + Increment;\r\n SB_LINEUP, SB_PAGEUP:\r\n NewPos := FScrollPos.Y - Increment;\r\n SB_THUMBPOSITION, SB_THUMBTRACK:\r\n begin\r\n NewPos := SI.nTrackPos;\r\n if IsPageMode then\r\n NewPos := NewPos - SI.nTrackPos mod Increment;\r\n if NewPos = FScrollPos.Y then\r\n Exit;\r\n end;\r\n SB_ENDSCROLL:\r\n begin\r\n FDeactivateHintThread.Start;\r\n Exit;\r\n end;\r\n end;\r\n NewPos := EnsureRange(NewPos, SI.nMin, SI.nMax);\r\n if Assigned(FOnVertScroll) then\r\n FOnVertScroll(Self, TScrollCode(Msg.ScrollCode), NewPos);\r\n NewPos := EnsureRange(NewPos, SI.nMin, SI.nMax);\r\n ScrollBy(0, -FScrollPos.Y + NewPos);\r\n FScrollPos.Y := NewPos;\r\n SI.nPos := NewPos;\r\n SetScrollInfo(Handle, SB_VERT, SI, True);\r\n DoScrollHint(NewPos);\r\n if Assigned(FOnAfterScroll) then\r\n FOnAfterScroll(Self);\r\n Refresh;\r\nend;\r\n\r\nprocedure TJvCustomPreviewControl.GetDlgCode(var Code: TDlgCodes);\r\nbegin\r\n Code := [dcWantAllKeys];\r\nend;\r\n\r\nprocedure TJvCustomPreviewControl.PrintRange(const APrinter: IJvPrinter;\r\n StartPage, EndPage, Copies: Integer; Collate: Boolean);\r\nvar\r\n I, J: Integer;\r\n PrinterPhysicalOffsetX, PrinterPhysicalOffsetY: cardinal;\r\nbegin\r\n if (APrinter = nil) or APrinter.GetPrinting then\r\n Exit;\r\n\r\n PrinterPhysicalOffsetX := GetDeviceCaps(APrinter.GetHandle, PHYSICALOFFSETX);\r\n PrinterPhysicalOffsetY := GetDeviceCaps(APrinter.GetHandle, PHYSICALOFFSETY);\r\n\r\n if StartPage < 0 then\r\n StartPage := PageCount - 1;\r\n if StartPage >= PageCount then\r\n StartPage := PageCount - 1;\r\n if EndPage < 0 then\r\n EndPage := PageCount - 1;\r\n if EndPage >= PageCount then\r\n EndPage := PageCount - 1;\r\n if Copies < 1 then\r\n Copies := 1;\r\n if (StartPage < 0) or (EndPage < 0) then\r\n Exit;\r\n if Collate then // Range * Copies\r\n begin\r\n if StartPage > EndPage then\r\n begin\r\n // print backwards\r\n for I := 0 to Copies - 1 do\r\n for J := StartPage downto EndPage do\r\n begin\r\n if APrinter.GetAborted then\r\n begin\r\n if APrinter.GetPrinting then\r\n APrinter.EndDoc;\r\n Exit;\r\n end;\r\n if (J = StartPage) and (I = 0) then\r\n APrinter.BeginDoc\r\n else\r\n APrinter.NewPage;\r\n APrinter.GetCanvas.Draw(-PrinterPhysicalOffsetX, -PrinterPhysicalOffsetY, Pages[J]);\r\n end;\r\n end\r\n else\r\n begin\r\n for I := 0 to Copies - 1 do\r\n for J := StartPage to EndPage do\r\n begin\r\n if APrinter.GetAborted then\r\n begin\r\n if APrinter.GetPrinting then\r\n APrinter.EndDoc;\r\n Exit;\r\n end;\r\n if (J = StartPage) and (I = 0) then\r\n APrinter.BeginDoc\r\n else\r\n APrinter.NewPage;\r\n APrinter.GetCanvas.Draw(-PrinterPhysicalOffsetX, -PrinterPhysicalOffsetY, Pages[J]);\r\n end;\r\n end;\r\n end\r\n else // Page * Copies\r\n begin\r\n if StartPage > EndPage then\r\n begin\r\n // print backwards\r\n for J := StartPage downto EndPage do\r\n for I := 0 to Copies - 1 do\r\n begin\r\n if APrinter.GetAborted then\r\n begin\r\n if APrinter.GetPrinting then\r\n APrinter.EndDoc;\r\n Exit;\r\n end;\r\n if (J = StartPage) and (I = 0) then\r\n APrinter.BeginDoc\r\n else\r\n APrinter.NewPage;\r\n APrinter.GetCanvas.Draw(-PrinterPhysicalOffsetX, -PrinterPhysicalOffsetY, Pages[J]);\r\n end;\r\n end\r\n else\r\n begin\r\n for J := StartPage to EndPage do\r\n for I := 0 to Copies - 1 do\r\n begin\r\n if APrinter.GetAborted then\r\n begin\r\n if APrinter.GetPrinting then\r\n APrinter.EndDoc;\r\n Exit;\r\n end;\r\n if (J = StartPage) and (I = 0) then\r\n APrinter.BeginDoc\r\n else\r\n APrinter.NewPage;\r\n APrinter.GetCanvas.Draw(-PrinterPhysicalOffsetX, -PrinterPhysicalOffsetY, Pages[J]);\r\n end;\r\n end;\r\n end;\r\n if APrinter.GetPrinting then\r\n APrinter.EndDoc;\r\nend;\r\n\r\nfunction TJvCustomPreviewControl.GetOptimalScale: Cardinal;\r\nvar\r\n Val1, Val2: Integer;\r\nbegin\r\n Val1 := (ClientHeight - Integer(Options.VertSpacing)) div VisibleRows - Integer(Options.VertSpacing) * 2;\r\n Val2 := (ClientWidth - Integer(Options.HorzSpacing)) div TotalCols - Integer(Options.HorzSpacing) * 2;\r\n Result := GetLesserScale(Val1, Val2);\r\nend;\r\n\r\nprocedure TJvCustomPreviewControl.Change;\r\nbegin\r\n // TopRow := 0; // DONE: make this unnecessary...\r\n UpdateSizes;\r\n UpdateScale;\r\n // call again since some values might have changed (like scale):\r\n UpdateSizes;\r\n CalcScrollRange;\r\n if Assigned(FOnChange) then\r\n FOnChange(Self);\r\n Refresh;\r\nend;\r\n\r\nprocedure TJvCustomPreviewControl.BeginUpdate;\r\nbegin\r\n Inc(FUpdateCount);\r\nend;\r\n\r\nprocedure TJvCustomPreviewControl.EndUpdate;\r\nbegin\r\n Dec(FUpdateCount);\r\n if FUpdateCount = 0 then\r\n Change;\r\n if FUpdateCount < 0 then\r\n FUpdateCount := 0;\r\nend;\r\n\r\nfunction TJvCustomPreviewControl.GetLesserScale(AHeight, AWidth: Cardinal): Cardinal;\r\nvar\r\n DC: HDC;\r\nbegin\r\n // determine scale factor for both sides, choose lesser\r\n // this is the opposite of setting FPageWidth/FPageHeight\r\n DC := GetDC(HWND_DESKTOP);\r\n try\r\n if AWidth > 0 then\r\n AWidth := AWidth * Int64(100) div\r\n MulDiv(DeviceInfo.PhysicalWidth, GetDeviceCaps(DC, LOGPIXELSX), DeviceInfo.LogPixelsX);\r\n if AHeight > 0 then\r\n AHeight := AHeight * Int64(100) div\r\n MulDiv(DeviceInfo.PhysicalHeight, GetDeviceCaps(DC, LOGPIXELSY), DeviceInfo.LogPixelsY);\r\n if (AHeight > 0) and (AWidth > 0) then\r\n Result := Min(AWidth, AHeight)\r\n else\r\n if AHeight > 0 then\r\n Result := AHeight\r\n else\r\n Result := AWidth;\r\n finally\r\n ReleaseDC(HWND_DESKTOP, DC);\r\n end;\r\nend;\r\n\r\nfunction TJvCustomPreviewControl.IsUpdating: Boolean;\r\nbegin\r\n Result := FUpdateCount <> 0;\r\nend;\r\n\r\nprocedure TJvCustomPreviewControl.SetTopRow(Value: Integer);\r\nvar\r\n ARow, Tmp: Integer;\r\n // SI: TScrollInfo;\r\nbegin\r\n ARow := Max(Min(Value, TotalRows - 1), 0);\r\n Tmp := (FPageHeight + Integer(Options.VertSpacing)) * ARow;\r\n ScrollBy(0, -FScrollPos.Y + Tmp);\r\n FScrollPos.Y := Tmp;\r\n SetScrollPos(Handle, SB_VERT, FScrollPos.Y, True);\r\n Refresh;\r\nend;\r\n\r\nprocedure TJvCustomPreviewControl.UpdateSizes;\r\nvar\r\n DC: HDC;\r\nbegin\r\n // precalc as much as possible to speed up rendering\r\n DC := GetDC(HWND_DESKTOP);\r\n try\r\n FPageWidth := MulDiv(MulDiv(DeviceInfo.PhysicalWidth, GetDeviceCaps(DC, LOGPIXELSX),\r\n DeviceInfo.LogPixelsX), Options.Scale, 100);\r\n FPageHeight := MulDiv(MulDiv(DeviceInfo.PhysicalHeight, GetDeviceCaps(DC, LOGPIXELSY),\r\n DeviceInfo.LogPixelsY), Options.Scale, 100);\r\n\r\n FOffsetLeft := MulDiv(MulDiv(DeviceInfo.OffsetLeft, GetDeviceCaps(DC, LOGPIXELSX),\r\n DeviceInfo.LogPixelsX), Options.Scale, 100);\r\n FOffsetTop := MulDiv(MulDiv(DeviceInfo.OffsetTop, GetDeviceCaps(DC, LOGPIXELSY),\r\n DeviceInfo.LogPixelsY), Options.Scale, 100);\r\n FOffsetRight := MulDiv(MulDiv(DeviceInfo.OffsetRight, GetDeviceCaps(DC, LOGPIXELSX),\r\n DeviceInfo.LogPixelsX), Options.Scale, 100);\r\n FOffsetBottom := MulDiv(MulDiv(DeviceInfo.OffsetBottom, GetDeviceCaps(DC, LOGPIXELSY),\r\n DeviceInfo.LogPixelsY), Options.Scale, 100);\r\n\r\n FPreviewRect := Rect(0, 0, FPageWidth, FPageHeight);\r\n FPrintRect := FPreviewRect;\r\n Inc(FPrintRect.Left, FOffsetLeft);\r\n Inc(FPrintRect.Top, FOffsetTop);\r\n Dec(FPrintRect.Right, FOffsetRight);\r\n Dec(FPrintRect.Bottom, FOffsetBottom);\r\n\r\n if (Options.ScaleMode in [smFullPage, smPageWidth]) or\r\n (FPageWidth >= ClientWidth) or (FPageHeight >= ClientHeight) and\r\n not (Options.ScaleMode in [smScale, smAutoScale]) then\r\n begin\r\n FTotalCols := 1;\r\n FVisibleRows := 1;\r\n end\r\n else\r\n case Options.ScaleMode of\r\n smAutoScale:\r\n begin\r\n FTotalCols := Max(Min(PageCount, Max((ClientWidth - Integer(Options.HorzSpacing)) div (FPageWidth +\r\n Integer(Options.HorzSpacing)), 1)), 1);\r\n FVisibleRows := Min(Max((ClientHeight - Integer(Options.VertSpacing)) div (FPageHeight +\r\n Integer(Options.VertSpacing)), 1), TotalRows);\r\n if (VisibleRows > 1) and (VisibleRows * TotalCols > PageCount) then\r\n FVisibleRows := Min((PageCount div TotalCols) + Ord(PageCount mod TotalCols <> 0), TotalRows);\r\n if (FPageWidth + Integer(Options.HorzSpacing) * 2 >= ClientWidth) or\r\n (FPageHeight + Integer(Options.VertSpacing) * 2 >= ClientHeight) then\r\n begin\r\n FTotalCols := 1;\r\n FVisibleRows := 1;\r\n Options.FScale := GetOptimalScale;\r\n end;\r\n end\r\n else\r\n begin\r\n FTotalCols := Max(Min(PageCount, Options.Cols), 1);\r\n FVisibleRows := Max(Min(PageCount div Integer(Options.Cols) + Ord(PageCount mod Integer(Options.Cols) <> 0),\r\n Options.Rows), 1);\r\n end;\r\n end;\r\n\r\n FTotalRows := Max((PageCount div TotalCols) + Ord(PageCount mod TotalCols <> 0), 1);\r\n\r\n FMaxHeight := TotalRows * (FPageHeight + Integer(Options.VertSpacing));\r\n if IsPageMode then\r\n FMaxHeight := FMaxHeight + Max((ClientHeight - ((FPageHeight + Integer(Options.VertSpacing)) * VisibleRows)) div 2, FOptions.VertSpacing) * 2\r\n else\r\n FMaxHeight := FMaxHeight + Integer(Options.VertSpacing) * 2;\r\n\r\n FMaxWidth := TotalCols * (FPageWidth + Integer(Options.HorzSpacing));\r\n FMaxWidth := FMaxWidth + Max((ClientWidth - ((FPageWidth + Integer(Options.HorzSpacing)) * TotalCols)) div 2, Integer(Options.HorzSpacing));\r\n finally\r\n ReleaseDC(HWND_DESKTOP, DC);\r\n end;\r\nend;\r\n\r\nfunction TJvCustomPreviewControl.GetTopRow: Integer;\r\nbegin\r\n Result := FScrollPos.Y div (FPageHeight + Integer(Options.VertSpacing));\r\n Inc(Result, Ord(FScrollPos.Y mod (FPageHeight + Integer(Options.VertSpacing)) <> 0));\r\n Result := Min(Result, TotalRows - 1);\r\nend;\r\n\r\nprocedure TJvCustomPreviewControl.First;\r\nbegin\r\n TopRow := 0;\r\nend;\r\n\r\nprocedure TJvCustomPreviewControl.Last;\r\nbegin\r\n TopRow := TotalRows;\r\nend;\r\n\r\nprocedure TJvCustomPreviewControl.Next;\r\nbegin\r\n TopRow := TopRow + 1;\r\nend;\r\n\r\nprocedure TJvCustomPreviewControl.Prior;\r\nbegin\r\n TopRow := TopRow - 1;\r\nend;\r\n\r\nfunction TJvCustomPreviewControl.ItemAtPos(Pos: TPoint; Existing: Boolean): Integer;\r\nvar\r\n APageRect: TRect;\r\n ARow, ACol, AOffsetX, AOffsetY: Integer;\r\nbegin\r\n Result := -1;\r\n // initial top/left offset\r\n AOffsetX := -FScrollPos.X + Max((ClientWidth - ((FPageWidth + Integer(Options.HorzSpacing)) * TotalCols)) div 2, FOptions.HorzSpacing);\r\n if IsPageMode then\r\n AOffsetY := -FScrollPos.Y + Max((ClientHeight - ((FPageHeight + Integer(Options.VertSpacing)) * VisibleRows)) div 2,\r\n FOptions.VertSpacing)\r\n else\r\n AOffsetY := -FScrollPos.Y + Integer(Options.VertSpacing);\r\n ARow := 0;\r\n // walk the pages, comparing as we go along\r\n while True do\r\n begin\r\n APageRect := FPreviewRect;\r\n OffsetRect(APageRect, AOffsetX, AOffsetY + (FPageHeight + Integer(Options.VertSpacing)) * ARow);\r\n for ACol := 0 to TotalCols - 1 do\r\n begin\r\n if PtInRect(APageRect, Pos) then\r\n begin\r\n Result := ARow * TotalCols + ACol;\r\n if Existing and (Result >= PageCount) then\r\n Result := -1;\r\n Exit;\r\n end;\r\n OffsetRect(APageRect, FPageWidth + Integer(Options.HorzSpacing), 0);\r\n end;\r\n Inc(ARow);\r\n if (APageRect.Left > ClientWidth) or (APageRect.Top > ClientHeight) then\r\n Exit;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomPreviewControl.SetScrollBars(const Value: TScrollStyle);\r\nbegin\r\n if FScrollBars <> Value then\r\n begin\r\n FScrollBars := Value;\r\n Change;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomPreviewControl.SetHideScrollBars(const Value: Boolean);\r\nbegin\r\n if FHideScrollBars <> Value then\r\n begin\r\n FHideScrollBars := Value;\r\n Change;\r\n end;\r\nend;\r\n\r\nfunction TJvCustomPreviewControl.DoMouseWheel(Shift: TShiftState;\r\n WheelDelta: Integer; MousePos: TPoint): Boolean;\r\nvar\r\n Msg: TWMScroll;\r\n SI: TScrollInfo;\r\nbegin\r\n Result := inherited DoMouseWheel(Shift, WheelDelta, MousePos);\r\n if not Result then\r\n begin\r\n FillChar(SI, SizeOf(TScrollInfo), 0);\r\n SI.cbSize := SizeOf(TScrollInfo);\r\n SI.fMask := SIF_ALL;\r\n GetScrollInfo(Handle, SB_VERT, SI);\r\n if SI.nMax = 0 then\r\n Exit;\r\n Msg.Msg := WM_VSCROLL;\r\n if WheelDelta > 0 then\r\n Msg.ScrollCode := SB_PAGEUP\r\n else\r\n Msg.ScrollCode := SB_PAGEDOWN;\r\n Msg.Pos := FScrollPos.Y;\r\n Msg.Result := 0;\r\n WMVScroll(Msg);\r\n Refresh;\r\n FDeactivateHintThread.Start;\r\n Result := True;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomPreviewControl.MouseDown(Button: TMouseButton;\r\n Shift: TShiftState; X, Y: Integer);\r\nvar\r\n I: Integer;\r\nbegin\r\n inherited MouseDown(Button, Shift, X, Y);\r\n if CanFocus then\r\n SetFocus;\r\n I := ItemAtPos(Point(X, Y), True);\r\n if I >= 0 then\r\n SelectedPage := I;\r\nend;\r\n\r\nfunction TJvCustomPreviewControl.IsPageMode: Boolean;\r\nbegin\r\n Result := (Options.ScaleMode in [smFullPage, smAutoScale, smColsRows]) or\r\n ((Options.ScaleMode = smScale) and (FPageHeight + Integer(Options.VertSpacing) * 2 <= ClientHeight));\r\nend;\r\n\r\nprocedure TJvCustomPreviewControl.UpdateScale;\r\nbegin\r\n case Options.ScaleMode of\r\n smFullPage:\r\n begin\r\n Options.FCols := 1;\r\n Options.FRows := 1;\r\n FTotalRows := PageCount - 1;\r\n Options.FScale := GetOptimalScale;\r\n end;\r\n smPageWidth:\r\n begin\r\n Options.FCols := 1;\r\n Options.FRows := 1;\r\n FTotalRows := PageCount - 1;\r\n Options.FScale := GetLesserScale(0, ClientWidth - Integer(Options.HorzSpacing) * 2 -\r\n GetSystemMetrics(SM_CYHSCROLL));\r\n end;\r\n smScale:\r\n begin\r\n FTotalCols := Min(Options.Cols, TotalCols);\r\n FVisibleRows := Min(Options.Rows, VisibleRows);\r\n // Options.FScale := GetOptimalScale;\r\n end;\r\n smAutoScale:\r\n begin\r\n Options.FCols := TotalCols;\r\n Options.FRows := VisibleRows;\r\n FTotalRows := Max((PageCount div TotalCols) + Ord(PageCount mod TotalCols <> 0), 1);\r\n end;\r\n smColsRows:\r\n Options.FScale := GetOptimalScale;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomPreviewControl.DoScrollHint(NewPos: Integer);\r\nvar\r\n S: string;\r\n Pt: TPoint;\r\n R: TRect;\r\nbegin\r\n // stolen from SynEdit, thanks guys!\r\n if Assigned(FOnScrollHint) then\r\n begin\r\n S := '';\r\n FOnScrollHint(Self, NewPos, S);\r\n if S <> '' then\r\n begin\r\n if not Assigned(FHintWindow) then\r\n begin\r\n if Assigned(HintWindowClass) then\r\n FHintWindow := HintWindowClass.Create(Self)\r\n else\r\n FHintWindow := Forms.HintWindowClass.Create(Self);\r\n \r\n FHintWindow.Visible := False;\r\n end;\r\n\r\n if not FHintWindow.Visible then\r\n begin\r\n FHintWindow.Color := Application.HintColor;\r\n FHintWindow.Visible := True;\r\n end;\r\n R := Rect(0, 0, FHintWindow.Canvas.TextWidth(S) + 6,\r\n FHintWindow.Canvas.TextHeight(S) + 4);\r\n GetCursorPos(Pt);\r\n Pt := ScreenToClient(Pt);\r\n Pt.X := ClientWidth - FHintWindow.Canvas.TextWidth(S) - 12;\r\n Pt := ClientToScreen(Pt);\r\n OffsetRect(R, Pt.X, Pt.Y - 4);\r\n FHintWindow.ActivateHint(R, S);\r\n FHintWindow.Invalidate;\r\n FHintWindow.Update;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomPreviewControl.DrawShadow(ACanvas: TCanvas; APageRect: TRect);\r\nvar\r\n TmpRect: TRect;\r\n TmpColor: TColor;\r\nbegin\r\n TmpColor := ACanvas.Brush.Color;\r\n try\r\n ACanvas.Brush.Color := Options.Shadow.Color;\r\n if Options.Shadow.Offset <> 0 then\r\n begin\r\n // draw full background shadow if necessary\r\n if (Abs(Options.Shadow.Offset) >= (APageRect.Left - APageRect.Right)) or\r\n (Abs(Options.Shadow.Offset) >= (APageRect.Bottom - APageRect.Top)) then\r\n begin\r\n TmpRect := APageRect;\r\n OffsetRect(TmpRect, Options.Shadow.Offset, Options.Shadow.Offset);\r\n ACanvas.FillRect(TmpRect);\r\n end\r\n // draw two smaller rects (does this *really* reduce flicker?)\r\n else\r\n if Options.Shadow.Offset < 0 then\r\n begin\r\n // left side\r\n TmpRect := APageRect;\r\n TmpRect.Right := TmpRect.Left - Options.Shadow.Offset;\r\n OffsetRect(TmpRect, Options.Shadow.Offset, Options.Shadow.Offset);\r\n ACanvas.FillRect(TmpRect);\r\n // top side\r\n TmpRect := APageRect;\r\n TmpRect.Bottom := TmpRect.Top - Options.Shadow.Offset;\r\n OffsetRect(TmpRect, Options.Shadow.Offset, Options.Shadow.Offset);\r\n ACanvas.FillRect(TmpRect);\r\n end\r\n else\r\n begin\r\n // right side\r\n TmpRect := APageRect;\r\n TmpRect.Left := TmpRect.Right - Options.Shadow.Offset;\r\n OffsetRect(TmpRect, Options.Shadow.Offset, Options.Shadow.Offset);\r\n ACanvas.FillRect(TmpRect);\r\n // bottom side\r\n TmpRect := APageRect;\r\n TmpRect.Top := TmpRect.Bottom - Options.Shadow.Offset;\r\n OffsetRect(TmpRect, Options.Shadow.Offset, Options.Shadow.Offset);\r\n ACanvas.FillRect(TmpRect);\r\n end;\r\n end;\r\n finally\r\n ACanvas.Brush.Color := TmpColor;\r\n end;\r\nend;\r\n\r\n//=== { TDeactiveHintThread } ================================================\r\n\r\nconstructor TJvCustomPreviewControlDeactivateHintThread.Create(AOwner: TJvCustomPreviewControl);\r\nbegin\r\n inherited Create(False);\r\n FreeOnTerminate := False;\r\n FOwner := AOwner;\r\n FDelay := -1;\r\nend;\r\n\r\nprocedure TJvCustomPreviewControlDeactivateHintThread.Execute;\r\nconst\r\n Step = 10;\r\nvar\r\n Elapsed: Integer;\r\nbegin\r\n NameThread(ThreadName);\r\n Elapsed := 0;\r\n\r\n while not Terminated do\r\n begin\r\n if FDelay >= 0 then\r\n begin\r\n if FDelay = 0 then\r\n FDelay := Application.HintHidePause;\r\n \r\n Inc(Elapsed, Step);\r\n\r\n if Elapsed > FDelay then\r\n begin\r\n Synchronize(HideHintWindow);\r\n Elapsed := 0;\r\n FDelay := -1;\r\n end;\r\n end;\r\n\r\n Sleep(Step);\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomPreviewControlDeactivateHintThread.HideHintWindow;\r\nbegin\r\n if Assigned(FOwner.FHintWindow) then\r\n begin\r\n FOwner.FHintWindow.Visible := False;\r\n FOwner.FHintWindow.ActivateHint(Rect(0, 0, 0, 0), '');\r\n FOwner.FHintWindow.ReleaseHandle;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomPreviewControlDeactivateHintThread.Start(Delay: Integer);\r\nbegin\r\n FDelay := Delay;\r\nend;\r\n\r\nprocedure TJvCustomPreviewControl.SetSelection(const Value: TJvPreviewSelection);\r\nbegin\r\n FSelection.Assign(Value);\r\nend;\r\n\r\n//=== { TJvPreviewSelection } ================================================\r\n\r\nconstructor TJvPreviewSelection.Create;\r\nbegin\r\n inherited Create;\r\n FColor := clNavy;\r\n FWidth := 4;\r\n FVisible := True;\r\nend;\r\n\r\nprocedure TJvPreviewSelection.Assign(Source: TPersistent);\r\nbegin\r\n if Source is TJvPreviewSelection then\r\n begin\r\n if Source = Self then\r\n Exit;\r\n FColor := TJvPreviewSelection(Source).Color;\r\n FWidth := TJvPreviewSelection(Source).Width;\r\n FVisible := TJvPreviewSelection(Source).Visible;\r\n Change;\r\n end\r\n else\r\n inherited Assign(Source);\r\nend;\r\n\r\nprocedure TJvPreviewSelection.Change;\r\nbegin\r\n if Assigned(FOnChange) then\r\n FOnChange(Self);\r\nend;\r\n\r\nprocedure TJvPreviewSelection.SetColor(const Value: TColor);\r\nbegin\r\n if FColor <> Value then\r\n begin\r\n FColor := Value;\r\n Change;\r\n end;\r\nend;\r\n\r\nprocedure TJvPreviewSelection.SetWidth(const Value: Integer);\r\nbegin\r\n if FWidth <> Value then\r\n begin\r\n FWidth := Value;\r\n Change;\r\n end;\r\nend;\r\n\r\nprocedure TJvPreviewSelection.SetVisible(const Value: Boolean);\r\nbegin\r\n if FVisible <> Value then\r\n begin\r\n FVisible := Value;\r\n Change;\r\n end;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n {$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvPrvwRender.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvPrvwRender.pas, released on 2003-01-01.\r\n\r\nThe Initial Developer of the Original Code is Peter Thrnqvist.\r\nPortions created by Peter Thrnqvist are Copyright (c) 2003 by Peter Thrnqvist.\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n* setting Stretch to false for graphic items, renders them at the wrong scale\r\n* the TStrings previewer has a *very* simple word-wrap feature - use the RTF variant if possible\r\n\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvPrvwRender.pas 13104 2011-09-07 06:50:43Z obones $\r\n\r\nunit JvPrvwRender;\r\n\r\n{$I jvcl.inc}\r\n{$I windowsonly.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, SysUtils, Messages, Classes, Controls, Graphics,\r\n Dialogs, ComCtrls, RichEdit, Printers,\r\n JvComponentBase, JvPrvwDoc, JvRichEdit;\r\n\r\ntype\r\n EPrintPreviewError = Exception;\r\n TJvCustomPreviewRenderer = class(TJvComponent)\r\n private\r\n FPrintPreview: TJvCustomPreviewControl;\r\n FOldAddPage: TJvDrawPageEvent;\r\n procedure SetPrintPreview(const Value: TJvCustomPreviewControl);\r\n procedure InternalDoAddPage(Sender: TObject; PageIndex: Integer; Canvas: TCanvas;\r\n PageRect, PrintRect: TRect; var NeedMorePages: Boolean);\r\n protected\r\n procedure DoAddPage(Sender: TObject; PageIndex: Integer; Canvas: TCanvas;\r\n PageRect, PrintRect: TRect; var NeedMorePages: Boolean); virtual; abstract;\r\n procedure Notification(AComponent: TComponent; Operation: TOperation); override;\r\n property PrintPreview: TJvCustomPreviewControl read FPrintPreview write SetPrintPreview;\r\n public\r\n function CreatePreview(Append: Boolean): Boolean; virtual;\r\n end;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvPreviewRenderRichEdit = class(TJvCustomPreviewRenderer)\r\n private\r\n FFinished: Boolean;\r\n FLastChar: Integer;\r\n FRichEdit: TCustomRichEdit;\r\n procedure SetRichEdit(const Value: TCustomRichEdit);\r\n protected\r\n procedure DoAddPage(Sender: TObject; PageIndex: Integer; Canvas: TCanvas;\r\n PageRect, PrintRect: TRect; var NeedMorePages: Boolean); override;\r\n procedure Notification(AComponent: TComponent; Operation: TOperation); override;\r\n public\r\n function CreatePreview(Append: Boolean): Boolean; override;\r\n published\r\n property PrintPreview;\r\n property RichEdit: TCustomRichEdit read FRichEdit write SetRichEdit;\r\n end;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvPreviewRenderJvRichEdit = class(TJvCustomPreviewRenderer)\r\n private\r\n FFinished: Boolean;\r\n FLastChar: Integer;\r\n FRichEdit: TJvCustomRichEdit;\r\n procedure SetRichEdit(const Value: TJvCustomRichEdit);\r\n protected\r\n procedure DoAddPage(Sender: TObject; PageIndex: Integer; Canvas: TCanvas;\r\n PageRect, PrintRect: TRect; var NeedMorePages: Boolean); override;\r\n procedure Notification(AComponent: TComponent; Operation: TOperation); override;\r\n public\r\n function CreatePreview(Append: Boolean): Boolean; override;\r\n published\r\n property PrintPreview;\r\n property RichEdit: TJvCustomRichEdit read FRichEdit write SetRichEdit;\r\n end;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvPreviewRenderStrings = class(TJvCustomPreviewRenderer)\r\n private\r\n FFinished: Boolean;\r\n FCurrentRow: Integer;\r\n FStrings: TStringList;\r\n FFont: TFont;\r\n procedure SetStrings(const Value: TStrings);\r\n procedure SetFont(const Value: TFont);\r\n function GetStrings: TStrings;\r\n protected\r\n procedure DoAddPage(Sender: TObject; PageIndex: Integer; Canvas: TCanvas;\r\n PageRect, PrintRect: TRect; var NeedMorePages: Boolean); override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n function CreatePreview(Append: Boolean): Boolean; override;\r\n published\r\n property PrintPreview;\r\n property Strings: TStrings read GetStrings write SetStrings;\r\n property Font: TFont read FFont write SetFont;\r\n end;\r\n\r\n TJvPreviewGraphicItem = class(TCollectionItem)\r\n private\r\n FPicture: TPicture;\r\n FTransparent: Boolean;\r\n FCenter: Boolean;\r\n FStretch: Boolean;\r\n FProportional: Boolean;\r\n procedure SetPicture(const Value: TPicture);\r\n public\r\n constructor Create(Collection: TCollection); override;\r\n destructor Destroy; override;\r\n procedure Assign(Source: TPersistent); override;\r\n function DestRect(RefRect: TRect; DestDC: HDC): TRect;\r\n procedure UpdateGraphic;\r\n published\r\n property Picture: TPicture read FPicture write SetPicture;\r\n property Center: Boolean read FCenter write FCenter default True;\r\n property Proportional: Boolean read FProportional write FProportional default True;\r\n property Stretch: Boolean read FStretch write FStretch default True;\r\n property Transparent: Boolean read FTransparent write FTransparent default False;\r\n end;\r\n\r\n TJvPreviewGraphicItems = class(TOwnedCollection)\r\n private\r\n function GetItems(Index: Integer): TJvPreviewGraphicItem;\r\n procedure SetItems(Index: Integer; const Value: TJvPreviewGraphicItem);\r\n public\r\n constructor Create(AOwner: TPersistent);\r\n function Add: TJvPreviewGraphicItem;\r\n property Items[Index: Integer]: TJvPreviewGraphicItem read GetItems write SetItems; default;\r\n end;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvPreviewRenderGraphics = class(TJvCustomPreviewRenderer)\r\n private\r\n FImages: TJvPreviewGraphicItems;\r\n procedure SetImages(const Value: TJvPreviewGraphicItems);\r\n protected\r\n function GetPPX(ADC: HDC): Integer;\r\n function GetPPY(ADC: HDC): Integer;\r\n procedure DoAddPage(Sender: TObject; PageIndex: Integer; Canvas: TCanvas;\r\n PageRect, PrintRect: TRect; var NeedMorePages: Boolean); override;\r\n public\r\n function CreatePreview(Append: Boolean): Boolean; override;\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n published\r\n property PrintPreview;\r\n property Images: TJvPreviewGraphicItems read FImages write SetImages;\r\n end;\r\n\r\n // preview a TControl descendant\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvPreviewRenderControl = class(TJvCustomPreviewRenderer)\r\n private\r\n FControl: TControl;\r\n FProportional: Boolean;\r\n FCenter: Boolean;\r\n FStretch: Boolean;\r\n procedure SetControl(const Value: TControl);\r\n protected\r\n procedure Notification(AComponent: TComponent; Operation: TOperation);\r\n override;\r\n procedure DoAddPage(Sender: TObject; PageIndex: Integer; Canvas: TCanvas;\r\n PageRect: TRect; PrintRect: TRect; var NeedMorePages: Boolean); override;\r\n procedure DrawControl(ACanvas: TCanvas; AWidth, AHeight: Integer);\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n published\r\n property PrintPreview;\r\n property Control: TControl read FControl write SetControl;\r\n function CreatePreview(Append: Boolean): Boolean; override;\r\n property Center: Boolean read FCenter write FCenter default True;\r\n property Proportional: Boolean read FProportional write FProportional default True;\r\n property Stretch: Boolean read FStretch write FStretch default True;\r\n end;\r\n\r\n TJvNewPageEvent = procedure(Sender: TObject; PageIndex: Integer) of object;\r\n\r\n // a class that implements the IJvPrinter interface\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvPreviewPrinter = class(TJvComponent, IUnknown, IJvPrinter)\r\n private\r\n FPrinter: TPrinter;\r\n FPrintPreview: TJvCustomPreviewControl;\r\n FCollate: Boolean;\r\n FToPage: Integer;\r\n FFromPage: Integer;\r\n FCopies: Integer;\r\n FPageIndex: Integer;\r\n FOptions: TPrintDialogOptions;\r\n FPrintRange: TPrintRange;\r\n FOnEndDoc: TNotifyEvent;\r\n FOnNewPage: TJvNewPageEvent;\r\n FOnBeginDoc: TNotifyEvent;\r\n FOnAbort: TNotifyEvent;\r\n procedure SetPrinterProperty(const Value: TPrinter); // Not called SetPrinter for BCB compatibility\r\n procedure CheckPrinter;\r\n procedure CheckActive;\r\n procedure SetPrintPreview(const Value: TJvCustomPreviewControl);\r\n procedure SetNumCopies(const Value: Integer);\r\n protected\r\n procedure Notification(AComponent: TComponent; Operation: TOperation); override;\r\n { IJvPrinter }\r\n procedure BeginDoc;\r\n procedure EndDoc;\r\n function GetAborted: Boolean;\r\n function GetCanvas: TCanvas;\r\n function GetPageHeight: Integer;\r\n function GetPageWidth: Integer;\r\n function GetPrinting: Boolean;\r\n function GetHandle: HDC;\r\n procedure NewPage;\r\n procedure Abort;\r\n function GetTitle: string;\r\n procedure SetTitle(const Value: string);\r\n public\r\n procedure Print;\r\n procedure Assign(Source: TPersistent); override;\r\n property Title: string read GetTitle write SetTitle;\r\n property Printer: TPrinter read FPrinter write SetPrinterProperty;\r\n published\r\n property Collate: Boolean read FCollate write FCollate default False;\r\n property Copies: Integer read FCopies write SetNumCopies default 0;\r\n property FromPage: Integer read FFromPage write FFromPage default 0;\r\n property Options: TPrintDialogOptions read FOptions write FOptions default [];\r\n property PrintRange: TPrintRange read FPrintRange write FPrintRange default prAllPages;\r\n property ToPage: Integer read FToPage write FToPage default 0;\r\n\r\n property PrintPreview: TJvCustomPreviewControl read FPrintPreview write SetPrintPreview;\r\n property OnBeginDoc: TNotifyEvent read FOnBeginDoc write FOnBeginDoc;\r\n property OnNewPage: TJvNewPageEvent read FOnNewPage write FOnNewPage;\r\n property OnEndDoc: TNotifyEvent read FOnEndDoc write FOnEndDoc;\r\n property OnAbort: TNotifyEvent read FOnAbort write FOnAbort;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvPrvwRender.pas $';\r\n Revision: '$Revision: 13104 $';\r\n Date: '$Date: 2011-09-07 08:50:43 +0200 (mer. 07 sept. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n Forms,\r\n JvJVCLUtils, JvJCLUtils, JvConsts, JvResources;\r\n\r\nconst\r\n cTwipsPerInch = 1440;\r\n\r\ntype\r\n TJvCustomPreviewAccessProtected = class(TJvCustomPreviewControl);\r\n\r\nprocedure StretchDrawBitmap(Canvas: TCanvas; const ARect: TRect; Bitmap: TBitmap);\r\nbegin\r\n if (Canvas = Printer.Canvas) or\r\n (Printer.Printing and (Canvas.Handle = Printer.Canvas.Handle)) then\r\n CopyRectDIBits(Canvas, ARect, Bitmap, Rect(0, 0, Bitmap.Width, Bitmap.Height))\r\n else\r\n Canvas.StretchDraw(ARect, Bitmap);\r\nend;\r\n\r\nfunction CalcDestRect(AWidth, AHeight: Integer; DstRect: TRect; Stretch, Proportional, Center: Boolean): TRect;\r\nvar\r\n w, h, cw, ch: Integer;\r\n xyaspect: Double;\r\nbegin\r\n w := AWidth;\r\n h := AHeight;\r\n cw := DstRect.Right - DstRect.Left;\r\n ch := DstRect.Bottom - DstRect.Top;\r\n if Stretch or (Proportional and ((w > cw) or (h > ch))) then\r\n begin\r\n if Proportional and (w > 0) and (h > 0) then\r\n begin\r\n xyaspect := w / h;\r\n if w > h then\r\n begin\r\n w := cw;\r\n h := Trunc(cw / xyaspect);\r\n if h > ch then // woops, too big\r\n begin\r\n h := ch;\r\n w := Trunc(ch * xyaspect);\r\n end;\r\n end\r\n else\r\n begin\r\n h := ch;\r\n w := Trunc(ch * xyaspect);\r\n if w > cw then // woops, too big\r\n begin\r\n w := cw;\r\n h := Trunc(cw / xyaspect);\r\n end;\r\n end;\r\n end\r\n else\r\n begin\r\n w := cw;\r\n h := ch;\r\n end;\r\n end;\r\n\r\n Result := Rect(0, 0, w, h);\r\n if Center then\r\n OffsetRect(Result, (cw - w) div 2, (ch - h) div 2);\r\n OffsetRect(Result, DstRect.Left, DstRect.Top);\r\nend;\r\n\r\n//=== { TJvCustomPreviewRenderer } ===========================================\r\n\r\nfunction TJvCustomPreviewRenderer.CreatePreview(Append: Boolean): Boolean;\r\nbegin\r\n Result := False;\r\n if PrintPreview = nil then\r\n raise EPrintPreviewError.CreateRes(@RsEAPrintPreviewComponentMustBeAssigne);\r\n if not Append then\r\n PrintPreview.Clear;\r\n FOldAddPage := TJvCustomPreviewAccessProtected(PrintPreview).OnAddPage;\r\n try\r\n TJvCustomPreviewAccessProtected(PrintPreview).OnAddPage := InternalDoAddPage;\r\n PrintPreview.Add;\r\n finally\r\n TJvCustomPreviewAccessProtected(PrintPreview).OnAddPage := FOldAddPage;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomPreviewRenderer.InternalDoAddPage(Sender: TObject; PageIndex: Integer;\r\n Canvas: TCanvas; PageRect, PrintRect: TRect; var NeedMorePages: Boolean);\r\nbegin\r\n DoAddPage(Sender, PageIndex, Canvas, PageRect, PrintRect, NeedMorePages);\r\n if Assigned(FOldAddPage) then\r\n FOldAddPage(Sender, PageIndex, Canvas, PageRect, PrintRect, NeedMorePages);\r\nend;\r\n\r\nprocedure TJvCustomPreviewRenderer.Notification(AComponent: TComponent; Operation: TOperation);\r\nbegin\r\n inherited Notification(AComponent, Operation);\r\n if (Operation = opRemove) and (AComponent = PrintPreview) then\r\n PrintPreview := nil;\r\nend;\r\n\r\nprocedure TJvCustomPreviewRenderer.SetPrintPreview(\r\n const Value: TJvCustomPreviewControl);\r\nbegin\r\n ReplaceComponentReference(Self, Value, tComponent(FPrintPreview));\r\nend;\r\n\r\n//=== { TJvPreviewRenderRichEdit } ===========================================\r\n\r\nfunction TJvPreviewRenderRichEdit.CreatePreview(Append: Boolean): Boolean;\r\nbegin\r\n if RichEdit = nil then\r\n raise EPrintPreviewError.CreateRes(@RsEARichEditComponentMustBeAssignedInC);\r\n Result := RichEdit.Lines.Count > 0;\r\n FFinished := not Result;\r\n FLastChar := 0;\r\n if Result then\r\n Result := inherited CreatePreview(Append);\r\nend;\r\n\r\nprocedure TJvPreviewRenderRichEdit.DoAddPage(Sender: TObject; PageIndex: Integer;\r\n Canvas: TCanvas; PageRect, PrintRect: TRect; var NeedMorePages: Boolean);\r\nvar\r\n Range: TFormatRange;\r\n OutDC: HDC;\r\n MaxLen, LogX, LogY, OldMap: Integer;\r\nbegin\r\n FFinished := (RichEdit = nil) or (PrintPreview = nil);\r\n if not FFinished then\r\n begin\r\n FillChar(Range, SizeOf(TFormatRange), 0);\r\n OutDC := Canvas.Handle;\r\n Range.hdc := OutDC;\r\n Range.hdcTarget := OutDC;\r\n LogX := GetDeviceCaps(OutDC, LOGPIXELSX);\r\n LogY := GetDeviceCaps(OutDC, LOGPIXELSY);\r\n if IsRectEmpty(RichEdit.PageRect) then\r\n begin\r\n Range.rc.Left := PrintRect.Left * cTwipsPerInch div LogX;\r\n Range.rc.Top := PrintRect.Top * cTwipsPerInch div LogY;\r\n Range.rc.Right := PrintRect.Right * cTwipsPerInch div LogX;\r\n Range.rc.Bottom := PrintRect.Bottom * cTwipsPerInch div LogY;\r\n end\r\n else\r\n begin\r\n Range.rc.Left := RichEdit.PageRect.Left * cTwipsPerInch div LogX;\r\n Range.rc.Top := RichEdit.PageRect.Top * cTwipsPerInch div LogY;\r\n Range.rc.Right := RichEdit.PageRect.Right * cTwipsPerInch div LogX;\r\n Range.rc.Bottom := RichEdit.PageRect.Bottom * cTwipsPerInch div LogY;\r\n end;\r\n Range.rcPage := Range.rc;\r\n\r\n MaxLen := RichEdit.GetTextLen;\r\n\r\n Range.chrg.cpMax := -1;\r\n\r\n // ensure the output DC is in text map mode\r\n OldMap := SetMapMode(Range.hdc, MM_TEXT);\r\n try\r\n SendMessage(RichEdit.Handle, EM_FORMATRANGE, 0, 0); // flush buffer\r\n Range.chrg.cpMin := FLastChar;\r\n FLastChar := SendMessage(RichEdit.Handle, EM_FORMATRANGE, 1, LPARAM(@Range));\r\n FFinished := (FLastChar >= MaxLen) or (FLastChar = -1);\r\n NeedMorePages := not FFinished;\r\n SendMessage(RichEdit.Handle, EM_FORMATRANGE, 0, 0); // flush buffer\r\n finally\r\n SetMapMode(OutDC, OldMap);\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvPreviewRenderRichEdit.Notification(AComponent: TComponent; Operation: TOperation);\r\nbegin\r\n inherited Notification(AComponent, Operation);\r\n if (Operation = opRemove) and (AComponent = RichEdit) then\r\n RichEdit := nil;\r\nend;\r\n\r\nprocedure TJvPreviewRenderRichEdit.SetRichEdit(\r\n const Value: TCustomRichEdit);\r\nbegin\r\n ReplaceComponentReference(Self, Value, tComponent(FRichEdit));\r\nend;\r\n\r\n//=== { TJvPreviewRenderJvRichEdit } =========================================\r\n\r\nfunction TJvPreviewRenderJvRichEdit.CreatePreview(Append: Boolean): Boolean;\r\nbegin\r\n if RichEdit = nil then\r\n raise EPrintPreviewError.CreateRes(@RsEARichEditComponentMustBeAssignedInC);\r\n Result := RichEdit.Lines.Count > 0;\r\n FFinished := not Result;\r\n FLastChar := 0;\r\n if Result then\r\n Result := inherited CreatePreview(Append);\r\nend;\r\n\r\nprocedure TJvPreviewRenderJvRichEdit.DoAddPage(Sender: TObject;\r\n PageIndex: Integer; Canvas: TCanvas; PageRect, PrintRect: TRect;\r\n var NeedMorePages: Boolean);\r\nvar\r\n Range: TFormatRange;\r\n OutDC: HDC;\r\n ALastChar, MaxLen, LogX, LogY, OldMap: Integer;\r\n TextLenEx: TGetTextLengthEx;\r\nbegin\r\n FFinished := (RichEdit = nil) or (PrintPreview = nil);\r\n if not FFinished then\r\n begin\r\n FillChar(Range, SizeOf(TFormatRange), 0);\r\n OutDC := Canvas.Handle;\r\n Range.hdc := OutDC;\r\n Range.hdcTarget := OutDC;\r\n LogX := GetDeviceCaps(OutDC, LOGPIXELSX);\r\n LogY := GetDeviceCaps(OutDC, LOGPIXELSY);\r\n if IsRectEmpty(RichEdit.PageRect) then\r\n begin\r\n Range.rc.Left := PrintRect.Left * cTwipsPerInch div LogX;\r\n Range.rc.Top := PrintRect.Top * cTwipsPerInch div LogY;\r\n Range.rc.Right := PrintRect.Right * cTwipsPerInch div LogX;\r\n Range.rc.Bottom := PrintRect.Bottom * cTwipsPerInch div LogY;\r\n end\r\n else\r\n begin\r\n Range.rc.Left := RichEdit.PageRect.Left * cTwipsPerInch div LogX;\r\n Range.rc.Top := RichEdit.PageRect.Top * cTwipsPerInch div LogY;\r\n Range.rc.Right := RichEdit.PageRect.Right * cTwipsPerInch div LogX;\r\n Range.rc.Bottom := RichEdit.PageRect.Bottom * cTwipsPerInch div LogY;\r\n end;\r\n Range.rcPage := Range.rc;\r\n if RichEditVersion >= 2 then\r\n begin\r\n with TextLenEx do\r\n begin\r\n Flags := GTL_DEFAULT;\r\n codepage := CP_ACP;\r\n end;\r\n MaxLen := RichEdit.Perform(EM_GETTEXTLENGTHEX, WPARAM(@TextLenEx), 0);\r\n end\r\n else\r\n MaxLen := RichEdit.GetTextLen;\r\n\r\n Range.chrg.cpMax := -1;\r\n\r\n // ensure the output DC is in text map mode\r\n OldMap := SetMapMode(Range.hdc, MM_TEXT);\r\n try\r\n SendMessage(RichEdit.Handle, EM_FORMATRANGE, 0, 0); // flush buffer\r\n Range.chrg.cpMin := FLastChar;\r\n ALastChar := SendMessage(RichEdit.Handle, EM_FORMATRANGE, 1, LPARAM(@Range));\r\n FFinished := (ALastChar >= MaxLen) or (ALastChar = -1) or (ALastChar <= FLastChar);\r\n FLastChar := ALastChar;\r\n NeedMorePages := not FFinished;\r\n if FFinished then\r\n SendMessage(RichEdit.Handle, EM_FORMATRANGE, 0, 0); // flush buffer\r\n finally\r\n SetMapMode(OutDC, OldMap);\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvPreviewRenderJvRichEdit.Notification(AComponent: TComponent; Operation: TOperation);\r\nbegin\r\n inherited Notification(AComponent, Operation);\r\n if (Operation = opRemove) and (AComponent = RichEdit) then\r\n RichEdit := nil;\r\nend;\r\n\r\nprocedure TJvPreviewRenderJvRichEdit.SetRichEdit(const Value: TJvCustomRichEdit);\r\nbegin\r\n ReplaceComponentReference(Self, Value, tComponent(FRichEdit));\r\nend;\r\n\r\n//=== { TJvPreviewRenderStrings } ============================================\r\n\r\nconstructor TJvPreviewRenderStrings.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FStrings := TStringList.Create;\r\n FFont := TFont.Create;\r\nend;\r\n\r\nfunction TJvPreviewRenderStrings.CreatePreview(Append: Boolean): Boolean;\r\nbegin\r\n Result := Strings.Count > 0;\r\n FFinished := not Result;\r\n FCurrentRow := 0;\r\n if Result then\r\n Result := inherited CreatePreview(Append);\r\nend;\r\n\r\ndestructor TJvPreviewRenderStrings.Destroy;\r\nbegin\r\n FStrings.Free;\r\n FFont.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvPreviewRenderStrings.DoAddPage(Sender: TObject;\r\n PageIndex: Integer; Canvas: TCanvas; PageRect, PrintRect: TRect;\r\n var NeedMorePages: Boolean);\r\nvar\r\n i, IncValue: Integer;\r\n ARect: TRect;\r\n tm: TTextMetric;\r\n S: string;\r\nbegin\r\n if not FFinished then\r\n begin\r\n Canvas.Font := Font;\r\n ARect := PrintRect;\r\n\r\n GetTextMetrics(Canvas.Handle, tm);\r\n IncValue := CanvasMaxTextHeight(Canvas) + tm.tmInternalLeading + tm.tmExternalLeading;\r\n ARect.Bottom := ARect.Top + IncValue;\r\n for i := FCurrentRow to Strings.Count - 1 do\r\n begin\r\n ARect.Right := PrintRect.Right;\r\n S := Strings[i];\r\n IncValue := DrawText(Canvas, PChar(S), Length(S), ARect,\r\n DT_CALCRECT or DT_NOPREFIX or DT_EXPANDTABS or DT_WORDBREAK or DT_LEFT or DT_TOP);\r\n if ARect.Right > PrintRect.Right then\r\n begin\r\n ARect.Right := PrintRect.Right; // reset and just force a line break in the middle (not fail proof!)\r\n S := Copy(S, 1, Length(S) div 2) + CrLf +\r\n Copy(S, Length(S) div 2 + 1, Length(S));\r\n IncValue := DrawText(Canvas, PChar(S), Length(S), ARect,\r\n DT_CALCRECT or DT_NOPREFIX or DT_EXPANDTABS or DT_WORDBREAK or DT_LEFT or DT_TOP);\r\n end;\r\n if ARect.Bottom > PrintRect.Bottom then\r\n begin\r\n FCurrentRow := i;\r\n NeedMorePages := True;\r\n Exit;\r\n end;\r\n DrawText(Canvas, PChar(S), Length(S), ARect,\r\n DT_NOPREFIX or DT_EXPANDTABS or DT_WORDBREAK or DT_LEFT or DT_TOP);\r\n OffsetRect(ARect, 0, IncValue);\r\n end;\r\n end;\r\n FFinished := True;\r\nend;\r\n\r\nfunction TJvPreviewRenderStrings.GetStrings: TStrings;\r\nbegin\r\n Result := FStrings;\r\nend;\r\n\r\nprocedure TJvPreviewRenderStrings.SetFont(const Value: TFont);\r\nbegin\r\n if Value <> FFont then\r\n FFont.Assign(Value);\r\nend;\r\n\r\nprocedure TJvPreviewRenderStrings.SetStrings(const Value: TStrings);\r\nbegin\r\n if Value <> FStrings then\r\n FStrings.Assign(Value);\r\nend;\r\n\r\n//=== { TJvPreviewRenderControl } ============================================\r\n\r\nfunction TJvPreviewRenderControl.CreatePreview(Append: Boolean): Boolean;\r\nbegin\r\n Result := Control <> nil;\r\n if Result then\r\n Result := inherited CreatePreview(Append);\r\nend;\r\n\r\nprocedure TJvPreviewRenderControl.DoAddPage(Sender: TObject;\r\n PageIndex: Integer; Canvas: TCanvas; PageRect, PrintRect: TRect;\r\n var NeedMorePages: Boolean);\r\nvar\r\n Bitmap: TBitmap;\r\n ARect: TRect;\r\nbegin\r\n NeedMorePages := False;\r\n Bitmap := TBitmap.Create;\r\n try\r\n Bitmap.PixelFormat := pf32bit;\r\n Bitmap.HandleType := bmDIB;\r\n if Control is TCustomForm then\r\n begin\r\n Bitmap.Width := Control.ClientWidth;\r\n Bitmap.Height := Control.ClientHeight;\r\n end\r\n else\r\n begin\r\n Bitmap.Width := Control.Width;\r\n Bitmap.Height := Control.Height;\r\n end;\r\n Bitmap.Canvas.FillRect(Bitmap.Canvas.ClipRect);\r\n DrawControl(Bitmap.Canvas, Bitmap.Width, Bitmap.Height);\r\n if (Bitmap.Width > 0) and (Bitmap.Height > 0) then\r\n begin\r\n ARect := CalcDestRect(Bitmap.Width, Bitmap.Height, PrintRect, Stretch,\r\n Proportional, Center);\r\n StretchDrawBitmap(Canvas, ARect, Bitmap);\r\n end;\r\n finally\r\n Bitmap.Free;\r\n end;\r\nend;\r\n\r\nprocedure TJvPreviewRenderControl.Notification(AComponent: TComponent; Operation: TOperation);\r\nbegin\r\n inherited Notification(AComponent, Operation);\r\n if (Operation = opRemove) and (AComponent = Control) then\r\n Control := nil;\r\nend;\r\n\r\nprocedure TJvPreviewRenderControl.SetControl(const Value: TControl);\r\nbegin\r\n ReplaceComponentReference(Self, Value, tComponent(FControl));\r\nend;\r\n\r\nprocedure TJvPreviewRenderControl.DrawControl(ACanvas: TCanvas; AWidth, AHeight: Integer);\r\nvar\r\n SaveIndex: Integer;\r\n ADC: HDC;\r\nbegin\r\n ACanvas.Lock;\r\n try\r\n ADC := ACanvas.Handle;\r\n if Control is TWinControl then\r\n TWinControl(Control).PaintTo(ADC, 0, 0)\r\n else\r\n if Control <> nil then\r\n begin\r\n SaveIndex := SaveDC(ADC);\r\n try\r\n Control.ControlState := Control.ControlState + [csPaintCopy];\r\n MoveWindowOrg(ADC, 0, 0);\r\n IntersectClipRect(ADC, 0, 0, Control.Width, Control.Height);\r\n Control.Perform(WM_ERASEBKGND, ADC, 0);\r\n Control.Perform(WM_PAINT, ADC, 0);\r\n finally\r\n RestoreDC(ADC, SaveIndex);\r\n Control.ControlState := Control.ControlState - [csPaintCopy];\r\n end;\r\n end\r\n finally\r\n ACanvas.Unlock;\r\n end;\r\nend;\r\n\r\nconstructor TJvPreviewRenderControl.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FStretch := True;\r\n FProportional := True;\r\n FCenter := True;\r\nend;\r\n\r\n//=== { TJvPreviewGraphicItems } =============================================\r\n\r\nfunction TJvPreviewGraphicItems.Add: TJvPreviewGraphicItem;\r\nbegin\r\n Result := TJvPreviewGraphicItem(inherited Add);\r\nend;\r\n\r\nconstructor TJvPreviewGraphicItems.Create(AOwner: TPersistent);\r\nbegin\r\n inherited Create(AOwner, TJvPreviewGraphicItem);\r\nend;\r\n\r\nfunction TJvPreviewGraphicItems.GetItems(Index: Integer): TJvPreviewGraphicItem;\r\nbegin\r\n Result := TJvPreviewGraphicItem(inherited Items[Index]);\r\nend;\r\n\r\nprocedure TJvPreviewGraphicItems.SetItems(Index: Integer; const Value: TJvPreviewGraphicItem);\r\nbegin\r\n inherited Items[Index] := Value;\r\nend;\r\n\r\n//=== { TJvPreviewGraphicItem } ==============================================\r\n\r\nprocedure TJvPreviewGraphicItem.Assign(Source: TPersistent);\r\nvar\r\n Src: TJvPreviewGraphicItem;\r\nbegin\r\n if Source is TJvPreviewGraphicItem then\r\n begin\r\n Src := TJvPreviewGraphicItem(Source);\r\n FPicture.Assign(Src.FPicture);\r\n FCenter := Src.FCenter;\r\n FProportional := Src.FProportional;\r\n FStretch := Src.FStretch;\r\n FTransparent := Src.FTransparent;\r\n end\r\n else\r\n inherited Assign(Source);\r\nend;\r\n\r\nconstructor TJvPreviewGraphicItem.Create(Collection: TCollection);\r\nbegin\r\n inherited Create(Collection);\r\n FPicture := TPicture.Create;\r\n FCenter := True;\r\n FProportional := True;\r\n FStretch := True;\r\nend;\r\n\r\nfunction TJvPreviewGraphicItem.DestRect(RefRect: TRect; DestDC: HDC): TRect;\r\nbegin\r\n UpdateGraphic;\r\n Result := CalcDestRect(Picture.Width, Picture.Height, RefRect, Stretch, Proportional, Center);\r\nend;\r\n\r\ndestructor TJvPreviewGraphicItem.Destroy;\r\nbegin\r\n FPicture.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvPreviewGraphicItem.SetPicture(const Value: TPicture);\r\nbegin\r\n if Value <> FPicture then\r\n FPicture.Assign(Value);\r\nend;\r\n\r\nprocedure TJvPreviewGraphicItem.UpdateGraphic;\r\nvar\r\n G: TGraphic;\r\nbegin\r\n if (Picture.Width > 0) and (Picture.Height > 0) then\r\n begin\r\n G := Picture.Graphic;\r\n if (G <> nil) and not ((G is TMetaFile) or (G is TIcon)) then\r\n G.Transparent := Transparent;\r\n end;\r\nend;\r\n\r\n//=== { TJvPreviewRenderGraphics } ===========================================\r\n\r\nconstructor TJvPreviewRenderGraphics.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FImages := TJvPreviewGraphicItems.Create(Self);\r\nend;\r\n\r\nfunction TJvPreviewRenderGraphics.CreatePreview(Append: Boolean): Boolean;\r\nbegin\r\n Result := FImages.Count > 0;\r\n if Result then\r\n Result := inherited CreatePreview(Append);\r\nend;\r\n\r\ndestructor TJvPreviewRenderGraphics.Destroy;\r\nbegin\r\n FImages.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvPreviewRenderGraphics.DoAddPage(Sender: TObject;\r\n PageIndex: Integer; Canvas: TCanvas; PageRect, PrintRect: TRect;\r\n var NeedMorePages: Boolean);\r\nvar\r\n Img: TImageList;\r\nbegin\r\n if PageIndex < Images.Count then\r\n with Images[PageIndex] do\r\n if (Picture.Height > 0) and (Picture.Width > 0) and\r\n (Picture.Graphic <> nil) and not Picture.Graphic.Empty then\r\n begin\r\n if Picture.Graphic is TIcon then\r\n begin\r\n Img := TImageList.CreateSize(Picture.Width, Picture.Height);\r\n try\r\n Img.AddIcon(Picture.Icon);\r\n Img.GetBitmap(0, Picture.Bitmap);\r\n finally\r\n Img.Free;\r\n end;\r\n end;\r\n if Picture.Graphic is TBitmap then\r\n StretchDrawBitmap(Canvas, DestRect(PrintRect, Canvas.Handle), Picture.Bitmap)\r\n else\r\n Canvas.StretchDraw(DestRect(PrintRect, Canvas.Handle), Picture.Graphic);\r\n end;\r\n NeedMorePages := PageIndex < Images.Count - 1;\r\nend;\r\n\r\nfunction TJvPreviewRenderGraphics.GetPPX(ADC: HDC): Integer;\r\nbegin\r\n Result := GetDeviceCaps(ADC, LOGPIXELSX);\r\nend;\r\n\r\nfunction TJvPreviewRenderGraphics.GetPPY(ADC: HDC): Integer;\r\nbegin\r\n Result := GetDeviceCaps(ADC, LOGPIXELSY);\r\nend;\r\n\r\nprocedure TJvPreviewRenderGraphics.SetImages(const Value: TJvPreviewGraphicItems);\r\nbegin\r\n if Value <> FImages then\r\n FImages.Assign(Value);\r\nend;\r\n\r\n//=== { TJvPreviewPrinter } ==================================================\r\n\r\nprocedure TJvPreviewPrinter.Abort;\r\nbegin\r\n CheckPrinter;\r\n if GetPrinting then\r\n FPrinter.Abort;\r\n if Assigned(FOnAbort) then\r\n FOnAbort(Self);\r\nend;\r\n\r\nprocedure TJvPreviewPrinter.Assign(Source: TPersistent);\r\nbegin\r\n CheckActive;\r\n if Source is TJvPreviewPrinter then\r\n begin\r\n Collate := TJvPreviewPrinter(Source).Collate;\r\n Copies := TJvPreviewPrinter(Source).Copies;\r\n FromPage := TJvPreviewPrinter(Source).FromPage;\r\n Options := TJvPreviewPrinter(Source).Options;\r\n PrintRange := TJvPreviewPrinter(Source).PrintRange;\r\n ToPage := TJvPreviewPrinter(Source).ToPage;\r\n Title := TJvPreviewPrinter(Source).Title;\r\n end\r\n else\r\n if Source is TPrintDialog then\r\n begin\r\n Collate := TPrintDialog(Source).Collate;\r\n Copies := TPrintDialog(Source).Copies;\r\n FromPage := TPrintDialog(Source).FromPage;\r\n Options := TPrintDialog(Source).Options;\r\n PrintRange := TPrintDialog(Source).PrintRange;\r\n ToPage := TPrintDialog(Source).ToPage;\r\n end\r\n else\r\n inherited Assign(Source);\r\nend;\r\n\r\nprocedure TJvPreviewPrinter.BeginDoc;\r\nbegin\r\n CheckPrinter;\r\n FPrinter.BeginDoc;\r\n if Assigned(FOnBeginDoc) then\r\n FOnBeginDoc(Self);\r\n FPageIndex := 0;\r\nend;\r\n\r\nprocedure TJvPreviewPrinter.CheckActive;\r\nbegin\r\n if (Printer <> nil) and GetPrinting then\r\n raise EPrintPreviewError.CreateRes(@RsECannotPerfromThisOperationWhilePrin);\r\nend;\r\n\r\nprocedure TJvPreviewPrinter.CheckPrinter;\r\nbegin\r\n if Printer = nil then\r\n raise EPrintPreviewError.CreateRes(@RsEPrinterNotAssigned);\r\nend;\r\n\r\nprocedure TJvPreviewPrinter.EndDoc;\r\nbegin\r\n CheckPrinter;\r\n FPrinter.EndDoc;\r\n if Assigned(FOnEndDoc) then\r\n FOnEndDoc(Self);\r\nend;\r\n\r\nfunction TJvPreviewPrinter.GetAborted: Boolean;\r\nbegin\r\n CheckPrinter;\r\n Result := FPrinter.Aborted;\r\nend;\r\n\r\nfunction TJvPreviewPrinter.GetCanvas: TCanvas;\r\nbegin\r\n CheckPrinter;\r\n Result := FPrinter.Canvas;\r\nend;\r\n\r\nfunction TJvPreviewPrinter.GetHandle: HDC;\r\nbegin\r\n CheckPrinter;\r\n Result := FPrinter.Handle;\r\nend;\r\n\r\nfunction TJvPreviewPrinter.GetPageHeight: Integer;\r\nbegin\r\n CheckPrinter;\r\n Result := FPrinter.PageHeight;\r\nend;\r\n\r\nfunction TJvPreviewPrinter.GetPageWidth: Integer;\r\nbegin\r\n CheckPrinter;\r\n Result := FPrinter.PageWidth;\r\nend;\r\n\r\nfunction TJvPreviewPrinter.GetPrinting: Boolean;\r\nbegin\r\n CheckPrinter;\r\n Result := FPrinter.Printing;\r\nend;\r\n\r\nfunction TJvPreviewPrinter.GetTitle: string;\r\nbegin\r\n CheckPrinter;\r\n Result := FPrinter.Title;\r\nend;\r\n\r\nprocedure TJvPreviewPrinter.NewPage;\r\nbegin\r\n CheckPrinter;\r\n FPrinter.NewPage;\r\n if Assigned(FOnNewPage) then\r\n FOnNewPage(Self, FPageIndex);\r\n Inc(FPageIndex);\r\nend;\r\n\r\nprocedure TJvPreviewPrinter.Notification(AComponent: TComponent; Operation: TOperation);\r\nbegin\r\n inherited Notification(AComponent, Operation);\r\n if (Operation = opRemove) and (AComponent = PrintPreview) then\r\n PrintPreview := nil;\r\nend;\r\n\r\nprocedure TJvPreviewPrinter.Print;\r\nvar\r\n AMin, AMax: Integer;\r\nbegin\r\n if PrintPreview = nil then\r\n raise EPrintPreviewError.CreateRes(@RsENoPrintPreviewAssigned);\r\n if PrintRange = prAllPages then\r\n begin\r\n AMin := 0;\r\n AMax := PrintPreview.PageCount - 1;\r\n end\r\n else\r\n begin\r\n AMin := FromPage - 1;\r\n AMax := ToPage - 1;\r\n end;\r\n PrintPreview.PrintRange(Self, AMin, AMax, Copies, Collate);\r\nend;\r\n\r\nprocedure TJvPreviewPrinter.SetNumCopies(const Value: Integer);\r\nbegin\r\n FCopies := Value;\r\n if FCopies < 1 then\r\n FCopies := 1;\r\nend;\r\n\r\nprocedure TJvPreviewPrinter.SetPrinterProperty(const Value: TPrinter);\r\nbegin\r\n CheckActive;\r\n FPrinter := Value;\r\nend;\r\n\r\nprocedure TJvPreviewPrinter.SetPrintPreview(const Value: TJvCustomPreviewControl);\r\nbegin\r\n CheckActive;\r\n ReplaceComponentReference(Self, Value, tComponent(FPrintPreview));\r\nend;\r\n\r\nprocedure TJvPreviewPrinter.SetTitle(const Value: string);\r\nbegin\r\n CheckPrinter;\r\n FPrinter.Title := Value;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n {$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvQuickPreviewForm.dfm", "content": "object QuickPreviewForm: TQuickPreviewForm\r\n Left = 123\r\n Top = 127\r\n ClientWidth = 304\r\n ClientHeight = 320\r\n BorderStyle = bsSizeToolWin\r\n Caption = 'Painter Preview'\r\n Color = clBtnFace\r\n Font.Charset = DEFAULT_CHARSET\r\n Font.Color = clWindowText\r\n Font.Height = -11\r\n Font.Name = 'MS Sans Serif'\r\n Font.Style = []\r\n FormStyle = fsStayOnTop\r\n OldCreateOrder = False\r\n PixelsPerInch = 96\r\n TextHeight = 13\r\n object ScrollBox1: TScrollBox\r\n Left = 0\r\n Top = 0\r\n Width = 304\r\n Height = 295\r\n Align = alClient\r\n TabOrder = 0\r\n object PreviewImage: TImage\r\n Left = 0\r\n Top = 0\r\n Width = 208\r\n Height = 208\r\n AutoSize = True\r\n end\r\n end\r\n object Panel1: TPanel\r\n Left = 0\r\n Top = 295\r\n Width = 304\r\n Height = 22\r\n Align = alBottom\r\n BevelOuter = bvNone\r\n TabOrder = 1\r\n object BtnUse: TSpeedButton\r\n Left = 13\r\n Top = 3\r\n Width = 33\r\n Height = 18\r\n Caption = 'Use'\r\n Flat = True\r\n OnClick = BtnUseClick\r\n end\r\n end\r\nend\r\n" }, { "path": "External/Jedi/Jvcl/run/JvQuickPreviewForm.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvQuickPreviewU.PAS, released on 2002-06-15.\r\n\r\nThe Initial Developer of the Original Code is Jan Verhoeven [jan1 dott verhoeven att wxs dott nl]\r\nPortions created by Jan Verhoeven are Copyright (C) 2002 Jan Verhoeven.\r\nAll Rights Reserved.\r\n\r\nContributor(s): Robert Love [rlove att slcdug dott org].\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvQuickPreviewForm.pas 12461 2009-08-14 17:21:33Z obones $\r\n\r\nunit JvQuickPreviewForm;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n SysUtils, Classes, Windows, Controls, Forms, Dialogs, Buttons, ExtCtrls, StdCtrls,\r\n JvDrawImage, JvComponent;\r\n\r\ntype\r\n TQuickPreviewForm = class(TJvForm)\r\n ScrollBox1: TScrollBox;\r\n PreviewImage: TImage;\r\n Panel1: TPanel;\r\n BtnUse: TSpeedButton;\r\n procedure BtnUseClick(Sender: TObject);\r\n private\r\n FDrawImage: TJvDrawImage;\r\n public\r\n procedure SetDrawImage(ADrawImage: TJvDrawImage);\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvQuickPreviewForm.pas $';\r\n Revision: '$Revision: 12461 $';\r\n Date: '$Date: 2009-08-14 19:21:33 +0200 (ven. 14 août 2009) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\n\r\n{$R *.dfm}\r\n\r\nprocedure TQuickPreviewForm.BtnUseClick(Sender: TObject);\r\n\r\nbegin\r\n if Assigned(FDrawImage) then\r\n FDrawImage.Canvas.Draw(0, 0, PreviewImage.Picture.Bitmap);\r\n Close;\r\nend;\r\n\r\nprocedure TQuickPreviewForm.SetDrawImage(ADrawImage: TJvDrawImage);\r\nbegin\r\n FDrawImage := ADrawImage;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend." }, { "path": "External/Jedi/Jvcl/run/JvRadioButton.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvRadioButton.PAS, released on 2001-02-28.\r\n\r\nThe Initial Developer of the Original Code is Sbastien Buysse [sbuysse att buypin dott com]\r\nPortions created by Sbastien Buysse are Copyright (C) 2001 Sbastien Buysse.\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\nMichael Beck [mbeck att bigfoot dott com].\r\nRobert Marquardt copied implementation of TJvCheckBox\r\nPeter Thrnqvist- added LinkedControls property\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvRadioButton.pas 13104 2011-09-07 06:50:43Z obones $\r\n\r\nunit JvRadioButton;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, Messages,\r\n SysUtils, Classes, Graphics, Controls, Forms, StdCtrls,\r\n JvTypes, JvExStdCtrls, JvLinkedControls;\r\n\r\ntype\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvRadioButton = class(TJvExRadioButton)\r\n private\r\n FHotTrack: Boolean;\r\n FHotTrackFont: TFont;\r\n FFontSave: TFont;\r\n FHotTrackFontOptions: TJvTrackFontOptions;\r\n FAutoSize: Boolean;\r\n FCanvas: TControlCanvas;\r\n FWordWrap: Boolean;\r\n FAlignment: TAlignment;\r\n FLayout: TTextLayout;\r\n FLeftText: Boolean;\r\n FLinkedControls: TJvLinkedControls;\r\n FCheckingLinkedControls: Boolean;\r\n function GetCanvas: TCanvas;\r\n function GetReadOnly: Boolean;\r\n procedure SetHotTrackFont(const Value: TFont);\r\n procedure SetHotTrackFontOptions(const Value: TJvTrackFontOptions);\r\n procedure SetWordWrap(const Value: Boolean);\r\n procedure SetAlignment(const Value: TAlignment);\r\n procedure SetLayout(const Value: TTextLayout);\r\n procedure SetReadOnly(const Value: Boolean);\r\n procedure SetLeftText(const Value: Boolean);\r\n procedure SetLinkedControls(const Value: TJvLinkedControls);\r\n procedure BMSetCheck(var Msg: TMessage); message BM_SETCHECK;\r\n protected\r\n procedure Notification(AComponent: TComponent; Operation: TOperation);override;\r\n procedure MouseEnter(AControl: TControl); override;\r\n procedure MouseLeave(AControl: TControl); override;\r\n procedure TextChanged; override;\r\n procedure FontChanged; override;\r\n procedure EnabledChanged;override;\r\n procedure SetAutoSize(Value: Boolean); override;\r\n procedure CreateParams(var Params: TCreateParams); override;\r\n procedure CalcAutoSize; virtual;\r\n procedure Loaded; override;\r\n\r\n procedure LinkedControlsChange(Sender: TObject);\r\n procedure CheckLinkedControls; virtual;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n\r\n procedure SetFocus; override;\r\n\r\n property Canvas: TCanvas read GetCanvas;\r\n published\r\n property Alignment: TAlignment read FAlignment write SetAlignment;\r\n property AutoSize: Boolean read FAutoSize write SetAutoSize default True;\r\n property HintColor;\r\n property HotTrack: Boolean read FHotTrack write FHotTrack default False;\r\n property HotTrackFont: TFont read FHotTrackFont write SetHotTrackFont;\r\n property HotTrackFontOptions: TJvTrackFontOptions read FHotTrackFontOptions write SetHotTrackFontOptions\r\n default DefaultTrackFontOptions;\r\n property Layout: TTextLayout read FLayout write SetLayout default tlCenter;\r\n // show text to the left of the radio bullet\r\n property LeftText: Boolean read FLeftText write SetLeftText default False;\r\n // link the enabled state of other controls to the checked and/or enabled state of this control\r\n property LinkedControls: TJvLinkedControls read FLinkedControls write SetLinkedControls;\r\n property ReadOnly: Boolean read GetReadOnly write SetReadOnly default False;\r\n property WordWrap: Boolean read FWordWrap write SetWordWrap default False;\r\n property OnMouseEnter;\r\n property OnMouseLeave;\r\n property OnParentColorChange;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvRadioButton.pas $';\r\n Revision: '$Revision: 13104 $';\r\n Date: '$Date: 2011-09-07 08:50:43 +0200 (mer. 07 sept. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n JvJVCLUtils;\r\n\r\n//=== { TJvRadioButton } =====================================================\r\n\r\nconstructor TJvRadioButton.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FCanvas := TControlCanvas.Create;\r\n FCanvas.Control := Self;\r\n FHotTrack := False;\r\n FHotTrackFont := TFont.Create;\r\n FFontSave := TFont.Create;\r\n FHotTrackFontOptions := DefaultTrackFontOptions;\r\n FAutoSize := True;\r\n FWordWrap := False;\r\n FAlignment := taLeftJustify;\r\n FLeftText := False;\r\n FLayout := tlCenter;\r\n FLinkedControls := TJvLinkedControls.Create(Self);\r\n FLinkedControls.OnChange := LinkedControlsChange;\r\nend;\r\n\r\ndestructor TJvRadioButton.Destroy;\r\nbegin\r\n FHotTrackFont.Free;\r\n FFontSave.Free;\r\n FreeAndNil(FLinkedControls);\r\n inherited Destroy;\r\n // (rom) destroy Canvas AFTER inherited Destroy\r\n FCanvas.Free;\r\nend;\r\n\r\nprocedure TJvRadioButton.Loaded;\r\nbegin\r\n inherited Loaded;\r\n CheckLinkedControls;\r\n CalcAutoSize;\r\nend;\r\n\r\nprocedure TJvRadioButton.CreateParams(var Params: TCreateParams);\r\nconst\r\n cAlign: array [TAlignment] of Word = (BS_LEFT, BS_RIGHT, BS_CENTER);\r\n cLeftText: array [Boolean] of Word = (0, BS_RIGHTBUTTON);\r\n cLayout: array [TTextLayout] of Word = (BS_TOP, BS_VCENTER, BS_BOTTOM);\r\n cWordWrap: array [Boolean] of Word = (0, BS_MULTILINE);\r\nbegin\r\n inherited CreateParams(Params);\r\n with Params do\r\n Style := Style or cAlign[Alignment] or cLayout[Layout] or\r\n cLeftText[LeftText] or cWordWrap[WordWrap];\r\nend;\r\n\r\nprocedure TJvRadioButton.MouseEnter(AControl: TControl);\r\nbegin\r\n if csDesigning in ComponentState then\r\n Exit;\r\n if not MouseOver then\r\n begin\r\n if FHotTrack then\r\n begin\r\n FFontSave.Assign(Font);\r\n Font.Assign(FHotTrackFont);\r\n end;\r\n inherited MouseEnter(AControl);\r\n end;\r\nend;\r\n\r\nprocedure TJvRadioButton.MouseLeave(AControl: TControl);\r\nbegin\r\n if MouseOver then\r\n begin\r\n if FHotTrack then\r\n Font.Assign(FFontSave);\r\n inherited MouseLeave(AControl);\r\n end;\r\nend;\r\n\r\nprocedure TJvRadioButton.FontChanged;\r\nbegin\r\n inherited FontChanged;\r\n CalcAutoSize;\r\n UpdateTrackFont(HotTrackFont, Font, HotTrackFontOptions);\r\nend;\r\n\r\nprocedure TJvRadioButton.TextChanged;\r\nbegin\r\n inherited TextChanged;\r\n CalcAutoSize;\r\nend;\r\n\r\nprocedure TJvRadioButton.CalcAutoSize;\r\nconst\r\n Flags: array [Boolean] of Cardinal = (DT_SINGLELINE, DT_WORDBREAK);\r\nvar\r\n AWidth, AHeight: Integer;\r\n ASize: TSize;\r\n R: TRect;\r\nbegin\r\n if (Parent = nil) or not AutoSize or (csDestroying in ComponentState) or\r\n (csLoading in ComponentState) then\r\n Exit;\r\n ASize := GetDefaultCheckBoxSize;\r\n // add some spacing\r\n Inc(ASize.cy, 4);\r\n FCanvas.Font := Font;\r\n R := Rect(0, 0, ClientWidth, ClientHeight);\r\n // This is slower than GetTextExtentPoint but it does consider hotkeys\r\n if Caption <> '' then\r\n begin\r\n DrawText(FCanvas.Handle, PChar(Caption), Length(Caption), R,\r\n Flags[WordWrap] or DT_LEFT or DT_NOCLIP or DT_CALCRECT);\r\n AWidth := (R.Right - R.Left) + ASize.cx + 8;\r\n AHeight := R.Bottom - R.Top;\r\n end\r\n else\r\n begin\r\n AWidth := ASize.cx;\r\n AHeight := ASize.cy;\r\n end;\r\n if AWidth < ASize.cx then\r\n AWidth := ASize.cx;\r\n if AHeight < ASize.cy then\r\n AHeight := ASize.cy;\r\n ClientWidth := AWidth;\r\n ClientHeight := AHeight;\r\nend;\r\n\r\nprocedure TJvRadioButton.SetHotTrackFont(const Value: TFont);\r\nbegin\r\n FHotTrackFont.Assign(Value);\r\nend;\r\n\r\nprocedure TJvRadioButton.SetAutoSize(Value: Boolean);\r\nbegin\r\n if FAutoSize <> Value then\r\n begin\r\n // inherited SetAutoSize(Value);\r\n FAutoSize := Value;\r\n if Value then\r\n WordWrap := False;\r\n CalcAutoSize;\r\n end;\r\nend;\r\n\r\nprocedure TJvRadioButton.SetFocus;\r\nvar\r\n I: Integer;\r\n FocusLinkedControl: TControl;\r\nbegin\r\n inherited SetFocus;\r\n\r\n FocusLinkedControl := nil;\r\n I := 0;\r\n while (I < LinkedControls.Count) and not Assigned(FocusLinkedControl) do\r\n begin\r\n if (loForceFocus in LinkedControls[I].Options) and (LinkedControls[I].Control is TWinControl) then\r\n FocusLinkedControl := LinkedControls[I].Control;\r\n\r\n Inc(I);\r\n end;\r\n if Assigned(FocusLinkedControl) then\r\n TWinControl(FocusLinkedControl).SetFocus;\r\nend;\r\n\r\nfunction TJvRadioButton.GetCanvas: TCanvas;\r\nbegin\r\n Result := FCanvas;\r\nend;\r\n\r\nprocedure TJvRadioButton.SetHotTrackFontOptions(const Value: TJvTrackFontOptions);\r\nbegin\r\n if FHotTrackFontOptions <> Value then\r\n begin\r\n FHotTrackFontOptions := Value;\r\n UpdateTrackFont(HotTrackFont, Font, FHotTrackFontOptions);\r\n end;\r\nend;\r\n\r\nprocedure TJvRadioButton.SetWordWrap(const Value: Boolean);\r\nbegin\r\n if FWordWrap <> Value then\r\n begin\r\n FWordWrap := Value;\r\n if Value then\r\n AutoSize := False;\r\n RecreateWnd;\r\n end;\r\nend;\r\n\r\nprocedure TJvRadioButton.SetAlignment(const Value: TAlignment);\r\nbegin\r\n if FAlignment <> Value then\r\n begin\r\n FAlignment := Value;\r\n RecreateWnd;\r\n end;\r\nend;\r\n\r\nprocedure TJvRadioButton.SetLayout(const Value: TTextLayout);\r\nbegin\r\n if FLayout <> Value then\r\n begin\r\n FLayout := Value;\r\n RecreateWnd;\r\n end;\r\nend;\r\n\r\nprocedure TJvRadioButton.SetReadOnly(const Value: Boolean);\r\nbegin\r\n ClicksDisabled := Value;\r\nend;\r\n\r\nprocedure TJvRadioButton.SetLeftText(const Value: Boolean);\r\nbegin\r\n if FLeftText <> Value then\r\n begin\r\n FLeftText := Value;\r\n RecreateWnd;\r\n end;\r\nend;\r\n\r\nfunction TJvRadioButton.GetReadOnly: Boolean;\r\nbegin\r\n Result := ClicksDisabled;\r\nend;\r\n\r\nprocedure TJvRadioButton.CheckLinkedControls;\r\nvar\r\n I: Integer;\r\nbegin\r\n if not FCheckingLinkedControls then // prevent an infinite recursion\r\n begin\r\n FCheckingLinkedControls := True;\r\n try\r\n if LinkedControls <> nil then\r\n for I := 0 to LinkedControls.Count - 1 do\r\n with LinkedControls[I] do\r\n if Control <> nil then\r\n Control.Enabled := CheckLinkControlEnabled(Self.Enabled, Self. Checked, Options);\r\n finally\r\n FCheckingLinkedControls := False;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvRadioButton.LinkedControlsChange(Sender: TObject);\r\nbegin\r\n CheckLinkedControls;\r\nend;\r\n\r\nprocedure TJvRadioButton.SetLinkedControls(const Value: TJvLinkedControls);\r\nbegin\r\n FLinkedControls.Assign(Value);\r\nend;\r\n\r\nprocedure TJvRadioButton.BMSetCheck(var Msg: TMessage);\r\nbegin\r\n inherited;\r\n CheckLinkedControls;\r\nend;\r\n\r\nprocedure TJvRadioButton.EnabledChanged;\r\nbegin\r\n inherited EnabledChanged;\r\n CheckLinkedControls;\r\nend;\r\n\r\nprocedure TJvRadioButton.Notification(AComponent: TComponent; Operation: TOperation);\r\nbegin\r\n inherited Notification(AComponent, Operation);\r\n if Assigned(FLinkedControls) then\r\n LinkedControls.Notification(AComponent, Operation);\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvRadioGroup.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvRadioGroup.PAS, released on 2001-02-28.\r\n\r\nThe Initial Developer of the Original Code is Sbastien Buysse [sbuysse att buypin dott com]\r\nPortions created by Sbastien Buysse are Copyright (C) 2001 Sbastien Buysse.\r\nAll Rights Reserved.\r\n\r\nContributor(s): Michael Beck [mbeck att bigfoot dott com].\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvRadioGroup.pas 13104 2011-09-07 06:50:43Z obones $\r\n\r\nunit JvRadioGroup;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, Messages,\r\n SysUtils, Classes, Graphics, Controls, Forms, StdCtrls, ExtCtrls, ToolWin,\r\n JvJCLUtils, JvThemes, JvExControls, JvExExtCtrls;\r\n\r\ntype\r\n TJvRadioGroupHintEvent = procedure(Sender: TObject; Index: Integer;\r\n var AHint: TCaption) of object;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvRadioGroup = class(TJvExRadioGroup, IJvDenySubClassing)\r\n private\r\n FReadOnly: Boolean;\r\n FEdgeBorders: TEdgeBorders;\r\n FEdgeInner: TEdgeStyle;\r\n FEdgeOuter: TEdgeStyle;\r\n FCaptionVisible: Boolean;\r\n FOnItemHint: TJvRadioGroupHintEvent;\r\n procedure SetEdgeBorders(const Value: TEdgeBorders);\r\n procedure SetEdgeInner(const Value: TEdgeStyle);\r\n procedure SetEdgeOuter(const Value: TEdgeStyle);\r\n procedure SetCaptionVisible(Value: Boolean);\r\n protected\r\n procedure Paint; override;\r\n function CanModify: Boolean; override;\r\n procedure GetItemHint(Index: Integer; var AHint: TCaption); virtual;\r\n function HintShow(var HintInfo: {$IFDEF RTL200_UP}Controls.{$ENDIF RTL200_UP}THintInfo): Boolean; override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n published\r\n property CaptionVisible: Boolean read FCaptionVisible write SetCaptionVisible;\r\n property EdgeBorders: TEdgeBorders read FEdgeBorders write SetEdgeBorders default [ebLeft, ebTop, ebRight, ebBottom];\r\n property EdgeInner: TEdgeStyle read FEdgeInner write SetEdgeInner default esRaised;\r\n property EdgeOuter: TEdgeStyle read FEdgeOuter write SetEdgeOuter default esLowered;\r\n property HintColor;\r\n {$IFDEF JVCLThemesEnabledD6}\r\n property ParentBackground default True;\r\n {$ENDIF JVCLThemesEnabledD6}\r\n property ReadOnly: Boolean read FReadOnly write FReadOnly default False;\r\n property OnMouseEnter;\r\n property OnMouseLeave;\r\n property OnItemHint: TJvRadioGroupHintEvent read FOnItemHint write FOnItemHint;\r\n property OnParentColorChange;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvRadioGroup.pas $';\r\n Revision: '$Revision: 13104 $';\r\n Date: '$Date: 2011-09-07 08:50:43 +0200 (mer. 07 sept. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n Math;\r\n\r\nconstructor TJvRadioGroup.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FEdgeBorders := [ebLeft, ebTop, ebRight, ebBottom];\r\n FEdgeInner := esRaised;\r\n FEdgeOuter := esLowered;\r\n FCaptionVisible := True;\r\n {$IFDEF JVCLThemesEnabledD6}\r\n IncludeThemeStyle(Self, [csParentBackground]);\r\n {$ENDIF JVCLThemesEnabledD6}\r\nend;\r\n\r\nprocedure TJvRadioGroup.Paint;\r\nconst\r\n InnerStyles: array [TEdgeStyle] of Integer =\r\n (0, BDR_RAISEDINNER, BDR_SUNKENINNER);\r\n OuterStyles: array [TEdgeStyle] of Integer =\r\n (0, BDR_RAISEDOUTER, BDR_SUNKENOUTER);\r\n Ctl3DStyles: array [Boolean] of Integer =\r\n (BF_MONO, 0);\r\nvar\r\n H: Integer;\r\n R: TRect;\r\n Flags: Longint;\r\n {$IFDEF JVCLThemesEnabled}\r\n Details: TThemedElementDetails;\r\n ClipRect, CaptionRect: TRect;\r\n {$ENDIF JVCLThemesEnabled}\r\nbegin\r\n {$IFDEF JVCLThemesEnabled}\r\n if ThemeServices.{$IFDEF RTL230_UP}Enabled{$ELSE}ThemesEnabled{$ENDIF RTL230_UP} then\r\n begin\r\n if Enabled then\r\n Details := ThemeServices.GetElementDetails(tbGroupBoxNormal)\r\n else\r\n Details := ThemeServices.GetElementDetails(tbGroupBoxDisabled);\r\n R := ClientRect;\r\n Inc(R.Top, Canvas.TextHeight('0') div 2);\r\n\r\n if EdgeBorders <> [] then\r\n begin\r\n ClipRect := R;\r\n if EdgeBorders <> [ebLeft, ebTop, ebRight, ebBottom] then\r\n begin\r\n //ClipRect := R;\r\n if not (ebLeft in EdgeBorders) then\r\n Inc(ClipRect.Left, 3);\r\n if not (ebRight in EdgeBorders) then\r\n Dec(ClipRect.Right, 3);\r\n if not (ebTop in EdgeBorders) then\r\n Inc(ClipRect.Top, 3);\r\n if not (ebBottom in EdgeBorders) then\r\n Dec(ClipRect.Bottom, 3);\r\n end;\r\n ThemeServices.DrawElement(Canvas.Handle, Details, R, @ClipRect);\r\n end;\r\n if CaptionVisible then\r\n begin\r\n CaptionRect := Rect(8, 0, Min(Canvas.TextWidth(Caption) + 8, ClientWidth - 8), Canvas.TextHeight(Caption));\r\n\r\n if ParentBackground then\r\n DrawThemedBackground(Self, Canvas.Handle, CaptionRect, Parent.Brush.Handle, True)\r\n else\r\n begin\r\n Canvas.Brush.Color := Self.Color;\r\n DrawThemedBackground(Self, Canvas, CaptionRect, False);\r\n end;\r\n\r\n { Theme functions may delete the font, so need to refresh\r\n (see also remark at TCustomActionControl.Paint) }\r\n Canvas.Font.Assign(Font);\r\n Canvas.Refresh;\r\n\r\n {$IFDEF COMPILER16_UP}\r\n ThemeServices.DrawText(Canvas.Handle, Details, Caption, CaptionRect, [tfLeft]);\r\n {$ELSE}\r\n ThemeServices.DrawText(Canvas.Handle, Details, Caption, CaptionRect, DT_LEFT, 0);\r\n {$ENDIF COMPILER16_UP}\r\n end;\r\n Exit;\r\n end;\r\n {$ENDIF JVCLThemesEnabled}\r\n with Canvas do\r\n begin\r\n Font := Self.Font;\r\n H := TextHeight('0');\r\n R := Rect(0, H div 2 - 1, Width, Height);\r\n Windows.DrawEdge(Handle, R, InnerStyles[FEdgeInner] or OuterStyles[FEdgeOuter],\r\n Byte(FEdgeBorders) or Ctl3DStyles[Ctl3D] or BF_ADJUST);\r\n if (Text <> '') and CaptionVisible then\r\n begin\r\n if not UseRightToLeftAlignment then\r\n R := Rect(8, 0, 0, H)\r\n else\r\n R := Rect(R.Right - Canvas.TextWidth(Text) - 8, 0, 0, H);\r\n Flags := DrawTextBiDiModeFlags(DT_SINGLELINE);\r\n\r\n // (rom) unified VCL/VisualCLX version\r\n DrawText(Canvas, Text, Length(Text), R, Flags or DT_CALCRECT);\r\n Brush.Color := Color;\r\n SetBkMode(Handle, OPAQUE);\r\n DrawText(Canvas, Text, Length(Text), R, Flags);\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJvRadioGroup.CanModify: Boolean;\r\nbegin\r\n if FReadOnly then\r\n Result := False\r\n else\r\n Result := inherited CanModify;\r\nend;\r\n\r\nprocedure TJvRadioGroup.SetEdgeBorders(const Value: TEdgeBorders);\r\nbegin\r\n if FEdgeBorders <> Value then\r\n begin\r\n FEdgeBorders := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvRadioGroup.SetEdgeInner(const Value: TEdgeStyle);\r\nbegin\r\n if FEdgeInner <> Value then\r\n begin\r\n FEdgeInner := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvRadioGroup.SetEdgeOuter(const Value: TEdgeStyle);\r\nbegin\r\n if FEdgeOuter <> Value then\r\n begin\r\n FEdgeOuter := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvRadioGroup.SetCaptionVisible(Value: Boolean);\r\nbegin\r\n if FCaptionVisible <> Value then\r\n begin\r\n FCaptionVisible := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvRadioGroup.GetItemHint(Index: Integer; var AHint: TCaption);\r\nbegin\r\n if Assigned(FOnItemHint) then\r\n FOnItemHint(Self, Index, AHint);\r\nend;\r\n\r\nfunction TJvRadioGroup.HintShow(var HintInfo: {$IFDEF RTL200_UP}Controls.{$ENDIF RTL200_UP}THintInfo): Boolean;\r\nvar\r\n AItemX, AItemY,\r\n AHeight, AWidth, VertCount: Integer;\r\n ARect: TRect;\r\nbegin\r\n Result := False;\r\n with HintInfo do\r\n begin\r\n ARect := ClientRect;\r\n HintStr := Hint; // set default\r\n if Items.Count > 0 then\r\n begin\r\n VertCount := (Items.Count div Columns) + Ord(Items.Count mod Columns <> 0);\r\n AHeight := Height div VertCount;\r\n AWidth := Width div Columns;\r\n if (AHeight > 0) then\r\n begin\r\n AItemX := CursorPos.X div AWidth;\r\n AItemY := CursorPos.Y div AHeight;\r\n if AItemY + AItemX * VertCount< Items.Count then\r\n begin\r\n GetItemHint(AItemY + AItemX * VertCount, TCaption(HintStr));\r\n ARect := Rect(AItemX * AWidth, AHeight * AItemY,\r\n AItemX * AWidth + AWidth, AHeight * AItemY + AHeight);\r\n end;\r\n end;\r\n CursorRect := ARect;\r\n end;\r\n end;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvRas32.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvRas32.PAS, released on 2001-02-28.\r\n\r\nThe Initial Developer of the Original Code is Sbastien Buysse [sbuysse att buypin dott com]\r\nPortions created by Sbastien Buysse are Copyright (C) 2001 Sbastien Buysse.\r\nAll Rights Reserved.\r\n\r\nContributor(s): Michael Beck [mbeck att bigfoot dott com].\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvRas32.pas 13104 2011-09-07 06:50:43Z obones $\r\n\r\nunit JvRas32;\r\n\r\n{$I jvcl.inc}\r\n{$I windowsonly.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n SysUtils, Classes, Controls, Forms,\r\n Ras32,\r\n Windows, Messages,\r\n // Messages must be after QControls\r\n JvComponentBase, JvTypes;\r\n\r\ntype\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvRas32 = class(TJvComponent)\r\n private\r\n FPhoneBookPath: TFileName;\r\n FPassword: string;\r\n FDeviceName: string;\r\n FUsername: string;\r\n FEntry: string;\r\n FDeviceType: string;\r\n FPhoneNumber: string;\r\n FCallBackNumber: string;\r\n FDomain: string;\r\n FConnection: DWORD;\r\n FHandle: THandle;\r\n FPHandle: THandle;\r\n RASEvent: Word;\r\n FEntryIndex: Integer;\r\n FDummyConnected: Boolean;\r\n FPhoneBook: TStringList;\r\n FOnAuthProject: TNotifyEvent;\r\n FOnAuthChangePassword: TNotifyEvent;\r\n FOnAuthLinkSpeed: TNotifyEvent;\r\n FOnDisconnected: TNotifyEvent;\r\n FOnAuthNotify: TNotifyEvent;\r\n FOnDeviceConnected: TNotifyEvent;\r\n FOnReAuthenticate: TNotifyEvent;\r\n FOnAuthAck: TNotifyEvent;\r\n FOnConnectDevice: TNotifyEvent;\r\n FOnAuthRetry: TNotifyEvent;\r\n FOnAuthenticate: TNotifyEvent;\r\n FOnWaitForModemReset: TNotifyEvent;\r\n FOnOpenPort: TNotifyEvent;\r\n FOnAuthCallback: TNotifyEvent;\r\n FOnRetryAuthentication: TNotifyEvent;\r\n FOnPortOpened: TNotifyEvent;\r\n FOnWaitForCallBack: TNotifyEvent;\r\n FOnPrepareForCallback: TNotifyEvent;\r\n FOnPasswordExpired: TNotifyEvent;\r\n FOnInteractive: TNotifyEvent;\r\n FOnConnected: TNotifyEvent;\r\n FOnAuthenticated: TNotifyEvent;\r\n FOnAllDevicesConnected: TNotifyEvent;\r\n FDll: THandle;\r\n FRasDial: TRasDial;\r\n FRasEnumConnections: TRasEnumConnections;\r\n FRasEnumEntries: TRasEnumEntries;\r\n FRasGetConnectStatus: TRasGetConnectStatus;\r\n FRasGetErrorstring: TRasGetErrorstring;\r\n FRasHangUp: TRasHangUp;\r\n FRasGetEntryDialParams: TRasGetEntryDialParams;\r\n FRasValidateEntryName: TRasValidateEntryName;\r\n FRasCreatePhonebookEntry: TRasCreatePhonebookEntry;\r\n FRasEditPhonebookEntry: TRasEditPhonebookEntry;\r\n FKeepConnected: Boolean;\r\n FAvailable: Boolean;\r\n // function GetPhoneBook: TStringList;\r\n procedure WndProc(var Msg: TMessage);\r\n procedure SetEntryIndex(const Value: Integer);\r\n function GetConnected: Boolean;\r\n function GetPhoneBook: TStrings;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n procedure RefreshPhoneBook;\r\n function Dial(Index: Integer): Boolean;\r\n function HangUp: Boolean;\r\n function CreateNewConnection: Boolean;\r\n function EditConnection(Index: Integer): Boolean;\r\n function GetActiveConnection: string;\r\n property CallBackNumber: string read FCallBackNumber write FCallBackNumber;\r\n property DeviceType: string read FDeviceType;\r\n property DeviceName: string read FDeviceName;\r\n property PhoneNumber: string read FPhoneNumber write FPhoneNumber;\r\n property Domain: string read FDomain write FDomain;\r\n property PhoneBook: TStrings read GetPhoneBook;\r\n property RasAvailable: Boolean read FAvailable;\r\n published\r\n property KeepConnected: Boolean read FKeepConnected write FKeepConnected default False;\r\n // property PhoneBook: TStringList read GetPhoneBook;\r\n property EntryIndex: Integer read FEntryIndex write SetEntryIndex default -1;\r\n property PhoneBookPath: TFileName read FPhoneBookPath write FPhoneBookPath;\r\n property Entry: string read FEntry write FEntry;\r\n property Username: string read FUsername write FUsername;\r\n property Password: string read FPassword write FPassword;\r\n property Connected: Boolean read GetConnected write FDummyConnected stored False;\r\n property OnOpenPort: TNotifyEvent read FOnOpenPort write FOnOpenPort;\r\n property OnPortOpened: TNotifyEvent read FOnPortOpened write FOnPortOpened;\r\n property OnConnectDevice: TNotifyEvent read FOnConnectDevice write FOnConnectDevice;\r\n property OnDeviceConnected: TNotifyEvent read FOnDeviceConnected write FOnDeviceConnected;\r\n property OnAllDevicesConnected: TNotifyEvent read FOnAllDevicesConnected write FOnAllDevicesConnected;\r\n property OnAuthenticate: TNotifyEvent read FOnAuthenticate write FOnAuthenticate;\r\n property OnAuthNotify: TNotifyEvent read FOnAuthNotify write FOnAuthNotify;\r\n property OnAuthRetry: TNotifyEvent read FOnAuthRetry write FOnAuthRetry;\r\n property OnAuthCallback: TNotifyEvent read FOnAuthCallback write FOnAuthCallback;\r\n property OnAuthChangePassword: TNotifyEvent read FOnAuthChangePassword write FOnAuthChangePassword;\r\n property OnAuthProject: TNotifyEvent read FOnAuthProject write FOnAuthProject;\r\n property OnAuthLinkSpeed: TNotifyEvent read FOnAuthLinkSpeed write FOnAuthLinkSpeed;\r\n property OnAuthAck: TNotifyEvent read FOnAuthAck write FOnAuthAck;\r\n property OnReAuthenticate: TNotifyEvent read FOnReAuthenticate write FOnReAuthenticate;\r\n property OnAuthenticated: TNotifyEvent read FOnAuthenticated write FOnAuthenticated;\r\n property OnPrepareForCallback: TNotifyEvent read FOnPrepareForCallback write FOnPrepareForCallback;\r\n property OnWaitForModemReset: TNotifyEvent read FOnWaitForModemReset write FOnWaitForModemReset;\r\n property OnInteractive: TNotifyEvent read FOnInteractive write FOnInteractive;\r\n property OnRetryAuthentication: TNotifyEvent read FOnRetryAuthentication write FOnRetryAuthentication;\r\n property OnPasswordExpired: TNotifyEvent read FOnPasswordExpired write FOnPasswordExpired;\r\n property OnConnected: TNotifyEvent read FOnConnected write FOnConnected;\r\n property OnDisconnected: TNotifyEvent read FOnDisconnected write FOnDisconnected;\r\n property OnWaitForCallBack: TNotifyEvent read FOnWaitForCallBack write FOnWaitForCallBack;\r\n end;\r\n\r\n // (rom) renamed\r\n EJvRasError = class(EJVCLException);\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvRas32.pas $';\r\n Revision: '$Revision: 13104 $';\r\n Date: '$Date: 2011-09-07 08:50:43 +0200 (mer. 07 sept. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n JvJVCLUtils, JvResources;\r\n\r\nconstructor TJvRas32.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FKeepConnected := False;\r\n FPhoneBookPath := '';\r\n FPassword := '';\r\n FDeviceName := '';\r\n FUsername := '';\r\n FEntry := '';\r\n FDeviceType := '';\r\n FPhoneNumber := '';\r\n FCallBackNumber := '';\r\n FDomain := '';\r\n FConnection := 0;\r\n if AOwner is TWinControl then\r\n FPHandle := (AOwner as TWinControl).Handle\r\n else\r\n // (rom) is this safe?\r\n FPHandle := GetForegroundWindow;\r\n FEntryIndex := -1;\r\n\r\n FDll := SafeLoadLibrary(RsRasDllName);\r\n if FDll <> 0 then\r\n begin\r\n FRasDial := GetProcAddress(FDll, {$IFDEF UNICODE}'RasDialW'{$ELSE}'RasDialA'{$ENDIF UNICODE});\r\n FRasEnumConnections := GetProcAddress(FDll, {$IFDEF UNICODE}'RasEnumConnectionsW'{$ELSE}'RasEnumConnectionsA'{$ENDIF UNICODE});\r\n FRasEnumEntries := GetProcAddress(FDll, {$IFDEF UNICODE}'RasEnumEntriesW'{$ELSE}'RasEnumEntriesA'{$ENDIF UNICODE});\r\n FRasGetConnectStatus := GetProcAddress(FDll, {$IFDEF UNICODE}'RasGetConnectStatusW'{$ELSE}'RasGetConnectStatusA'{$ENDIF UNICODE});\r\n FRasGetErrorstring := GetProcAddress(FDll, {$IFDEF UNICODE}'RasGetErrorstringW'{$ELSE}'RasGetErrorstringA'{$ENDIF UNICODE});\r\n FRasHangUp := GetProcAddress(FDll, {$IFDEF UNICODE}'RasHangUpW'{$ELSE}'RasHangUpA'{$ENDIF UNICODE});\r\n FRasGetEntryDialParams := GetProcAddress(FDll, {$IFDEF UNICODE}'RasGetEntryDialParamsW'{$ELSE}'RasGetEntryDialParamsA'{$ENDIF UNICODE});\r\n FRasValidateEntryName := GetProcAddress(FDll, {$IFDEF UNICODE}'RasValidateEntryNameW'{$ELSE}'RasValidateEntryNameA'{$ENDIF UNICODE});\r\n FRasCreatePhonebookEntry := GetProcAddress(FDll, {$IFDEF UNICODE}'RasCreatePhonebookEntryW'{$ELSE}'RasCreatePhonebookEntryA'{$ENDIF UNICODE});\r\n FRasEditPhonebookEntry := GetProcAddress(FDll, {$IFDEF UNICODE}'RasEditPhonebookEntryW'{$ELSE}'RasEditPhonebookEntryA'{$ENDIF UNICODE});\r\n FHandle := AllocateHWndEx(WndProc);\r\n RASEvent := RegisterWindowMessage(RASDialEvent);\r\n if RASEvent = 0 then\r\n RASEvent := WM_RASDialEvent;\r\n end;\r\n FAvailable := (FDll <> 0) and Assigned(FRasDial);\r\nend;\r\n\r\ndestructor TJvRas32.Destroy;\r\nbegin\r\n FPhoneBook.Free;\r\n if RasAvailable then\r\n begin\r\n try\r\n if not KeepConnected then\r\n HangUp;\r\n except\r\n end;\r\n FreeLibrary(FDll);\r\n DeallocateHWndEx(FHandle);\r\n end;\r\n FDll := 0;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJvRas32.GetActiveConnection: string;\r\nvar\r\n Ret: Longint;\r\n nCB: DWORD;\r\n RasConn: array of TRASCONN;\r\n nRasConnCount: DWORD;\r\n I: Integer;\r\nbegin\r\n Result := '';\r\n\r\n if RasAvailable then\r\n begin\r\n // We enumerate the RAS connections in a loop which allows us to use\r\n // a dynamic array rather than a static one that may not be big\r\n // enough to contain all the connections (Mantis 5079).\r\n // We start with 64 which should be fine on most systems\r\n repeat\r\n SetLength(RasConn, Length(RasConn) + 64);\r\n RasConn[0].dwSize := SizeOf(RasConn[0]);\r\n nCB := Length(RasConn) * SizeOf(RasConn[0]);\r\n \r\n Ret := FRasEnumConnections(@RasConn[0], nCB, nRasConnCount);\r\n until Ret <> ERROR_BUFFER_TOO_SMALL;\r\n\r\n if Ret <> ERROR_SUCCESS then\r\n raise Exception.CreateFmt('Unable to enumerate RAS connections, Error code is %d', [Ret]);\r\n \r\n if nRasConnCount = 0 then\r\n Exit;\r\n\r\n if not Assigned(FPhoneBook) then\r\n RefreshPhoneBook;\r\n for I := 0 to FPhoneBook.Count - 1 do\r\n if FPhoneBook[I] = RasConn[0].szEntryName then\r\n begin\r\n FConnection := RasConn[0].rasConn;\r\n Result := FPhoneBook[I];\r\n Break;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJvRas32.CreateNewConnection: Boolean;\r\nbegin\r\n if RasAvailable then\r\n Result := FRasCreatePhonebookEntry(FPHandle, nil) = 0\r\n else\r\n Result := False;\r\nend;\r\n\r\nfunction TJvRas32.Dial(Index: Integer): Boolean;\r\nvar\r\n RASDialParams: TRASDialParams;\r\n R: DWORD;\r\n X: Integer;\r\nbegin\r\n if not RasAvailable or (FConnection <> 0) then\r\n Result := False\r\n else\r\n begin\r\n FillChar(RASDialParams, SizeOf(RASDialParams), #0);\r\n FConnection := 0;\r\n with RASDialParams do\r\n begin\r\n dwSize := SizeOf(TRASDialParams);\r\n StrLCopy(szEntryName, PChar(PhoneBook[Index]), RAS_MAXENTRYNAME);\r\n X := Self.EntryIndex;\r\n Self.EntryIndex := Index;\r\n StrLCopy(szUserName, PChar(FUsername), RAS_MAXENTRYNAME);\r\n StrLCopy(szPassword, PChar(FPassword), RAS_MAXENTRYNAME);\r\n Self.EntryIndex := X;\r\n szDomain := AnsiString('*');\r\n szCallbackNumber := AnsiString('*');\r\n szPhoneNumber := '';\r\n end;\r\n if Assigned(FRasDial) then\r\n begin\r\n if FPhoneBookPath <> '' then\r\n R := FRasDial(nil, PChar(FPhoneBookPath), @RASDialParams, $FFFFFFFF, FHandle, FConnection)\r\n else\r\n R := FRasDial(nil, nil, @RASDialParams, $FFFFFFFF, FHandle, FConnection);\r\n Result := R = 0;\r\n end\r\n else\r\n Result := False;\r\n end;\r\nend;\r\n\r\nfunction TJvRas32.EditConnection(Index: Integer): Boolean;\r\nbegin\r\n Result := False;\r\n if RasAvailable then\r\n begin\r\n RefreshPhoneBook;\r\n if Index < PhoneBook.Count then\r\n Result := FRasEditPhonebookEntry(FPHandle, nil, PChar(PhoneBook[Index])) = 0;\r\n end;\r\nend;\r\n\r\nfunction TJvRas32.GetConnected: Boolean;\r\nvar\r\n Status: TRASConnStatus;\r\nbegin\r\n if RasAvailable and (FConnection <> 0) then\r\n begin\r\n Status.dwSize := SizeOf(TRASConnStatus);\r\n FRasGetConnectStatus(FConnection, @Status);\r\n Result := Status.rasConnstate = RASCS_Connected;\r\n end\r\n else\r\n Result := False;\r\nend;\r\n\r\nprocedure TJvRas32.RefreshPhoneBook;\r\nvar\r\n RASEntryName: array of TRasEntryName;\r\n Ret, I, BufSize, Entries: DWORD;\r\nbegin\r\n { Build internal copy. }\r\n if FPhoneBook = nil then\r\n FPhoneBook := TStringList.Create;\r\n if RasAvailable then\r\n begin\r\n FPhoneBook.BeginUpdate;\r\n try\r\n FPhoneBook.Clear;\r\n\r\n if Assigned(FRasEnumEntries) then\r\n begin\r\n // We enumerate the RAS entries in a loop which allows us to use\r\n // a dynamic array rather than a static one that may not be big\r\n // enough to contain all the entries (Mantis 5079).\r\n // We start with 50 which should be fine on most systems\r\n repeat\r\n SetLength(RASEntryName, Length(RASEntryName) + 50);\r\n BufSize := Length(RASEntryName) * SizeOf(RASEntryName[0]);\r\n RASEntryName[0].dwSize := SizeOf(RASEntryName[0]);\r\n if FPhoneBookPath <> '' then\r\n Ret := FRasEnumEntries(nil, PChar(FPhoneBookPath), @RASEntryName[0], BufSize, Entries)\r\n else\r\n Ret := FRasEnumEntries(nil, nil, @RASEntryName[0], BufSize, Entries);\r\n until Ret <> ERROR_BUFFER_TOO_SMALL;\r\n\r\n if Ret <> ERROR_SUCCESS then\r\n raise Exception.CreateFmt('Unable to enumerate RAS entries, Error code is %d', [Ret]);\r\n\r\n I := 0;\r\n while I < Entries do\r\n begin\r\n if (RASEntryName[I].szEntryName[0] <> #0) then\r\n FPhoneBook.Add(StrPas(RASEntryName[I].szEntryName));\r\n Inc(I);\r\n end;\r\n end;\r\n finally\r\n FPhoneBook.EndUpdate;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJvRas32.HangUp: Boolean;\r\nvar\r\n Rc: Longint;\r\n I: Integer;\r\n RasConnStatus: TRASConnStatus;\r\nbegin\r\n Result := False;\r\n if RasAvailable and (FConnection <> 0) then\r\n begin\r\n Rc := FRasHangUp(FConnection);\r\n if Rc <> 0 then\r\n begin\r\n RasConnStatus.dwSize := SizeOf(TRASConnStatus);\r\n I := 0;\r\n while True do\r\n begin\r\n Rc := FRasGetConnectStatus(FConnection, @RasConnStatus);\r\n if Rc = ERROR_INVALID_HANDLE then\r\n begin\r\n Rc := 0;\r\n Break;\r\n end;\r\n Sleep(10);\r\n Inc(I);\r\n if I > 9 then\r\n Break; // don't want an infinite loop...\r\n end;\r\n end;\r\n Result := Rc = 0;\r\n FConnection := 0;\r\n end;\r\nend;\r\n\r\nprocedure TJvRas32.SetEntryIndex(const Value: Integer);\r\nvar\r\n RasDial: TRASDialParams;\r\n Res: LongBool;\r\nbegin\r\n if RasAvailable then\r\n begin\r\n FEntryIndex := Value;\r\n\r\n FEntry := '';\r\n FUsername := '';\r\n FPhoneNumber := '';\r\n FDomain := '';\r\n FCallBackNumber := '';\r\n FPassword := '';\r\n\r\n if FEntryIndex >= PhoneBook.Count then\r\n begin\r\n if PhoneBook.Count > 0 then\r\n FEntryIndex := 0\r\n else\r\n FEntryIndex := -1;\r\n end;\r\n\r\n if FEntryIndex <> -1 then\r\n begin\r\n FEntry := PhoneBook[FEntryIndex];\r\n\r\n FillChar(RasDial, SizeOf(TRASDialParams), #0);\r\n StrLCopy(RasDial.szEntryName, PChar(PhoneBook[FEntryIndex]), RAS_MAXENTRYNAME);\r\n RasDial.dwSize := SizeOf(TRASDialParams);\r\n\r\n if Assigned(FRasGetEntryDialParams) then\r\n if FRasGetEntryDialParams(nil, RasDial, Res) = 0 then\r\n with RasDial do\r\n begin\r\n FUsername := StrPas(szUserName);\r\n FPassword := StrPas(szPassword);\r\n FDomain := StrPas(szDomain);\r\n FCallBackNumber := StrPas(szCallbackNumber);\r\n FPhoneNumber := StrPas(szPhoneNumber);\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvRas32.WndProc(var Msg: TMessage);\r\nbegin\r\n if (Msg.Msg = RASEvent) and (FConnection <> 0) then\r\n begin\r\n case Msg.WParam of\r\n RASCS_OpenPort:\r\n if Assigned(FOnOpenPort) then\r\n FOnOpenPort(Self);\r\n RASCS_PortOpened:\r\n if Assigned(FOnPortOpened) then\r\n FOnPortOpened(Self);\r\n RASCS_ConnectDevice:\r\n if Assigned(FOnConnectDevice) then\r\n FOnConnectDevice(Self);\r\n RASCS_DeviceConnected:\r\n if Assigned(FOnDeviceConnected) then\r\n FOnDeviceConnected(Self);\r\n RASCS_AllDevicesConnected:\r\n if Assigned(FOnAllDevicesConnected) then\r\n FOnAllDevicesConnected(Self);\r\n RASCS_Authenticate:\r\n if Assigned(FOnAuthenticate) then\r\n FOnAuthenticate(Self);\r\n RASCS_AuthNotify:\r\n if Assigned(FOnAuthNotify) then\r\n FOnAuthNotify(Self);\r\n RASCS_AuthRetry:\r\n if Assigned(FOnAuthRetry) then\r\n FOnAuthRetry(Self);\r\n RASCS_AuthCallback:\r\n if Assigned(FOnAuthCallback) then\r\n FOnAuthCallback(Self);\r\n RASCS_AuthChangePassword:\r\n if Assigned(FOnAuthChangePassword) then\r\n FOnAuthChangePassword(Self);\r\n RASCS_AuthProject:\r\n if Assigned(FOnAuthProject) then\r\n FOnAuthProject(Self);\r\n RASCS_AuthLinkSpeed:\r\n if Assigned(FOnAuthLinkSpeed) then\r\n FOnAuthLinkSpeed(Self);\r\n RASCS_AuthAck:\r\n if Assigned(FOnAuthAck) then\r\n FOnAuthAck(Self);\r\n RASCS_ReAuthenticate:\r\n if Assigned(FOnReAuthenticate) then\r\n FOnReAuthenticate(Self);\r\n RASCS_Authenticated:\r\n if Assigned(FOnAuthenticated) then\r\n FOnAuthenticated(Self);\r\n RASCS_PrepareForCallback:\r\n if Assigned(FOnPrepareForCallback) then\r\n FOnPrepareForCallback(Self);\r\n RASCS_WaitForModemReset:\r\n if Assigned(FOnWaitForModemReset) then\r\n FOnWaitForModemReset(Self);\r\n RASCS_Interactive:\r\n if Assigned(FOnInteractive) then\r\n FOnInteractive(Self);\r\n RASCS_RetryAuthentication:\r\n if Assigned(FOnRetryAuthentication) then\r\n FOnRetryAuthentication(Self);\r\n RASCS_PasswordExpired:\r\n if Assigned(FOnPasswordExpired) then\r\n FOnPasswordExpired(Self);\r\n RASCS_Connected:\r\n if Assigned(FOnConnected) then\r\n FOnConnected(Self);\r\n RASCS_DisConnected:\r\n if Assigned(FOnDisconnected) then\r\n FOnDisconnected(Self);\r\n RASCS_WaitForCallBack:\r\n if Assigned(FOnWaitForCallBack) then\r\n FOnWaitForCallBack(Self);\r\n end;\r\n end\r\n else\r\n Msg.Result := DefWindowProc(FHandle, Msg.Msg, Msg.WParam, Msg.LParam);\r\nend;\r\n\r\nfunction TJvRas32.GetPhoneBook: TStrings;\r\nbegin\r\n if FPhoneBook = nil then\r\n FPhoneBook := TStringList.Create;\r\n if FPhoneBook.Count = 0 then\r\n RefreshPhoneBook;\r\n Result := FPhoneBook;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvRecentMenuButton.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvRecentMenuBtn.PAS, released on 2001-02-28.\r\n\r\nThe Initial Developer of the Original Code is Sbastien Buysse [sbuysse att buypin dott com]\r\nPortions created by Sbastien Buysse are Copyright (C) 2001 Sbastien Buysse.\r\nAll Rights Reserved.\r\n\r\nContributor(s): Michael Beck [mbeck att bigfoot dott com].\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvRecentMenuButton.pas 13173 2011-11-19 12:43:58Z ahuser $\r\n\r\nunit JvRecentMenuButton;\r\n\r\n{$I jvcl.inc}\r\n{$I windowsonly.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, ShellAPI, SysUtils, Classes, Graphics, Controls, StdCtrls, Menus,\r\n JvButton, JvComputerInfoEx, JvTypes, JvJVCLUtils;\r\n\r\n// (rom) best separate out a TJvRecentPopupMenu\r\n\r\ntype\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvRecentMenuButton = class(TJvCustomButton)\r\n private\r\n FPopup: TPopupMenu;\r\n FDirs: TJvSystemFolders;\r\n FOnLinkClick: TJvLinkClickEvent;\r\n FOnPopup: TNotifyEvent;\r\n procedure UrlClick(Sender: TObject);\r\n procedure InternalFileFind(const Path, FileMask: string; Strings: TStringList);\r\n protected\r\n procedure CreatePopup(Sender: TObject);\r\n procedure DynBuild(Item: TMenuItem; Directory: string);\r\n procedure DeleteItem(Item: TMenuItem; LookTag: Boolean = False);\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n procedure Click; override;\r\n published\r\n property OnLinkClick: TJvLinkClickEvent read FOnLinkClick write FOnLinkClick;\r\n property OnPopup: TNotifyEvent read FOnPopup write FOnPopup;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvRecentMenuButton.pas $';\r\n Revision: '$Revision: 13173 $';\r\n Date: '$Date: 2011-11-19 13:43:58 +0100 (sam. 19 nov. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n ShlObj, ActiveX, Math,\r\n JclDateTime,\r\n JvResources;\r\n\r\nconst\r\n cMaxItems = 15;\r\n\r\nconstructor TJvRecentMenuButton.Create(AOwner: TComponent);\r\nvar\r\n MenuItem: TMenuItem;\r\nbegin\r\n inherited Create(AOwner);\r\n FDirs := TJvSystemFolders.Create;\r\n\r\n //Create Popup\r\n FPopup := TPopupMenu.Create(Self);\r\n MenuItem := TMenuItem.Create(FPopup);\r\n MenuItem.Enabled := False;\r\n MenuItem.Caption := RsEmptyItem;\r\n MenuItem.Tag := 1;\r\n FPopup.Items.Add(MenuItem);\r\n FPopup.OnPopup := CreatePopup;\r\nend;\r\n\r\ndestructor TJvRecentMenuButton.Destroy;\r\nbegin\r\n FDirs.Free;\r\n DeleteItem(FPopup.Items);\r\n FPopup.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvRecentMenuButton.Click;\r\nvar\r\n P: TPoint;\r\nbegin\r\n inherited Click;\r\n P.X := 0;\r\n P.Y := Height;\r\n P := ClientToScreen(P);\r\n FPopup.Popup(P.X, P.Y);\r\n if Assigned(FOnPopup) then\r\n FOnPopup(Self);\r\nend;\r\n\r\nprocedure TJvRecentMenuButton.UrlClick(Sender: TObject);\r\nbegin\r\n if Assigned(FOnLinkClick) then\r\n FOnLinkClick(Self, (Sender as TMenuItem).Hint);\r\nend;\r\n\r\nprocedure TJvRecentMenuButton.CreatePopup(Sender: TObject);\r\nbegin\r\n DynBuild(FPopup.Items, FDirs.Recent);\r\nend;\r\n\r\nfunction GetAssociatedIcon(const FileName: string; SmallIcon: Boolean): HICON;\r\nconst\r\n cSmall: array [Boolean] of Cardinal = (SHGFI_LARGEICON, SHGFI_SMALLICON);\r\nvar\r\n pfsi: TShFileInfo;\r\n hLarge: HICON;\r\n w: Word;\r\nbegin\r\n FillChar(pfsi, SizeOf(pfsi), 0);\r\n ShGetFileInfo(PChar(FileName), 0, pfsi, SizeOf(pfsi),\r\n SHGFI_ICONLOCATION or SHGFI_ATTRIBUTES or SHGFI_ICON or cSmall[SmallIcon] or SHGFI_USEFILEATTRIBUTES);\r\n Result := pfsi.hIcon;\r\n if Result = 0 then\r\n ExtractIconEx(pfsi.szDisplayName, pfsi.iIcon, hLarge, Result, 1);\r\n if not SmallIcon then\r\n Result := hLarge;\r\n if Result = 0 then\r\n ExtractAssociatedIcon(GetForegroundWindow, PChar(FileName), w);\r\nend;\r\n\r\n(* make Delphi 5 compiler happy // andreas\r\nfunction SortByName(List: TStringList; Index1, Index2: Integer): Integer;\r\nbegin\r\n Result := AnsiCompareText(ExtractFileName(List[Index2]), ExtractFileName(List[Index2]));\r\nend;\r\n*)\r\n\r\nfunction SortByObject(List: TStringList; Index1, Index2: Integer): Integer;\r\nbegin\r\n // note: higher values sorted at the top (Objects[] contains the DosDateTime\r\n Result := Integer(List.Objects[Index2]) - Integer(List.Objects[Index1]);\r\nend;\r\n\r\nconst\r\n IID_IShellLink: TGUID = { IID_IShellLinkA }\r\n (D1: $000214EE; D2: $0000; D3: $0000; D4: ($C0, $00, $00, $00, $00, $00, $00, $46));\r\n\r\ntype\r\n TUnicodePath = array [0..MAX_PATH - 1] of WideChar;\r\n\r\nfunction ShellLinkResolve(const FileName: string): string;\r\nvar\r\n ShellLink: IShellLink;\r\n PersistFile: IPersistFile;\r\n LinkName: TUnicodePath;\r\n Buffer: string;\r\n Win32FindData: TWin32FindData;\r\n FullPath: string;\r\nbegin\r\n Result := '';\r\n if Succeeded(CoCreateInstance(CLSID_ShellLink, nil, CLSCTX_INPROC_SERVER,\r\n IID_IShellLink, ShellLink)) then\r\n begin\r\n PersistFile := ShellLink as IPersistFile;\r\n // PersistFile.Load fails if the filename is not fully qualified\r\n FullPath := ExpandFileName(FileName);\r\n {$IFDEF SUPPORTS_UNICODE}\r\n StrPCopy(LinkName, FullPath);\r\n {$ELSE}\r\n MultiByteToWideChar(CP_ACP, MB_PRECOMPOSED, PAnsiChar(FullPath), -1, LinkName, MAX_PATH);\r\n {$ENDIF SUPPORTS_UNICODE}\r\n if Succeeded(PersistFile.Load(LinkName, STGM_READ)) then\r\n begin\r\n // Result := ShellLink.Resolve(0, SLR_ANY_MATCH or SLR_NO_UI);\r\n SetLength(Buffer, MAX_PATH);\r\n ShellLink.GetPath(PChar(Buffer), MAX_PATH, Win32FindData, SLGP_RAWPATH);\r\n Result := PChar(Buffer);\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvRecentMenuButton.InternalFileFind(const Path, FileMask: string; Strings: TStringList);\r\nvar\r\n H: THandle;\r\n Sr: TSearchRec;\r\n Tmp: string;\r\nbegin\r\n Strings.BeginUpdate;\r\n try\r\n Strings.Clear;\r\n H := FindFirst(Path + FileMask, faAnyFile, Sr);\r\n try\r\n while H = 0 do\r\n begin\r\n if Sr.FindData.cFileName[0] <> '.' then\r\n begin\r\n Tmp := ShellLinkResolve(Path + Sr.FindData.cFileName);\r\n if (Tmp <> '') and (ExtractFileExt(Tmp) <> '') then\r\n Strings.AddObject(Tmp, TObject(FileTimeToDosDateTime(Sr.FindData.ftLastWriteTime)));\r\n end;\r\n H := FindNext(Sr);\r\n end;\r\n finally\r\n FindClose(Sr);\r\n end;\r\n Strings.CustomSort(SortByObject);\r\n while Strings.Count > cMaxItems do // delete any older files\r\n Strings.Delete(Strings.Count - 1);\r\n Strings.Sort; // CustomSort(SortByName); // sort by name instead\r\n finally\r\n Strings.EndUpdate;\r\n end;\r\nend;\r\n\r\nprocedure TJvRecentMenuButton.DynBuild(Item: TMenuItem; Directory: string);\r\nvar\r\n It: TMenuItem;\r\n Bmp: TBitmap;\r\n S: TStringList;\r\n I: Integer;\r\nbegin\r\n DeleteItem(Item, True);\r\n if (Directory <> '') and (Directory[Length(Directory)] <> '\\') then\r\n Directory := Directory + '\\';\r\n S := TStringList.Create;\r\n try\r\n InternalFileFind(Directory, '*.*', S);\r\n for I := 0 to Min(S.Count - 1, cMaxItems - 1) do\r\n begin\r\n It := TMenuItem.Create(Item);\r\n It.Caption := ExtractFilename(S[I]);\r\n It.OnClick := UrlClick;\r\n It.Hint := S[I];\r\n Bmp := IconToBitmap2(GetAssociatedIcon(S[I], True), 16, clMenu);\r\n It.Bitmap.Assign(Bmp);\r\n Bmp.Free;\r\n Item.Add(It);\r\n end;\r\n finally\r\n S.Free;\r\n end;\r\n Item.Items[0].Visible := (Item.Count = 1);\r\nend;\r\n\r\nprocedure TJvRecentMenuButton.DeleteItem(Item: TMenuItem; LookTag: Boolean);\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := Item.Count - 1 downto 0 do\r\n if (not LookTag) or (Item[I].Tag = 0) then\r\n begin\r\n DeleteItem(Item[I]);\r\n Item[I].Free;\r\n end;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvRegistryTreeview.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvRegistryTreeView.PAS, released on 2002-05-26.\r\n\r\nThe Initial Developer of the Original Code is Peter Thrnqvist [peter3 at sourceforge dot net]\r\nPortions created by Peter Thrnqvist are Copyright (C) 2002 Peter Thrnqvist.\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nDescription:\r\n A treeview that displays the keys from the registry\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvRegistryTreeview.pas 13173 2011-11-19 12:43:58Z ahuser $\r\n\r\nunit JvRegistryTreeview;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, SysUtils, Classes, Graphics, Controls, Forms,\r\n ComCtrls, Registry, ImgList,\r\n JvExtComponent, JvTypes;\r\n\r\ntype\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvRegistryTreeView = class(TJvCustomTreeView)\r\n private\r\n FRegistryKeys: TJvRegKeys;\r\n FInternalImages: TImageList;\r\n FListView: TCustomListView;\r\n FRootCaption: string;\r\n FDefaultCaption: string;\r\n FDefaultNoValue: string;\r\n FReg: TRegistry;\r\n procedure SetDefaultCaption(Value: string);\r\n procedure SetDefaultNoValue(Value: string);\r\n procedure SetRootCaption(Value: string);\r\n procedure SetRegistryKeys(Value: TJvRegKeys);\r\n procedure BuildTree;\r\n function FillListView(Node: TTreeNode): Boolean;\r\n procedure SetDefaultImages;\r\n function GetCurrentPath: string;\r\n function GetShortPath: string;\r\n function GetCurrentKey: HKEY;\r\n function GetShowHint: Boolean;\r\n procedure SetShowHint(Value: Boolean);\r\n procedure OpenRegistry(Node: TTreeNode);\r\n procedure CloseRegistry;\r\n function FindChildNode(ParentNode: TTreeNode;\r\n const Name: string): TTreeNode;\r\n procedure SetListView(const Value: TCustomListView);\r\n protected\r\n procedure RefreshSubTrees(ANode: TTreeNode; Key, OldKey: string; Level: Integer); virtual;\r\n function CanCollapse(Node: TTreeNode): Boolean; override;\r\n function CanExpand(Node: TTreeNode): Boolean; override;\r\n procedure Change(Node: TTreeNode); override;\r\n procedure CreateParams(var Params: TCreateParams); override;\r\n procedure CreateWnd; override;\r\n procedure Notification(AComponent: TComponent; Operation: TOperation); override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n function SaveKey(const Filename: string): Boolean;\r\n function LoadKey(const Filename: string): Boolean;\r\n procedure RefreshNode(Node: TTreeNode);\r\n function AddKey(ParentNode: TTreeNode; const KeyName: string): TTreeNode;\r\n function AddStringValue(ParentNode: TTreeNode; const Name, Value: string): TTreeNode;\r\n function AddBinaryValue(ParentNode: TTreeNode; const Name: string; var Buf; BufSize: Integer): TTreeNode;\r\n function AddDWORDValue(ParentNode: TTreeNode; const Name: string; Value: DWORD): TTreeNode;\r\n property CurrentPath: string read GetCurrentPath;\r\n property ShortPath: string read GetShortPath;\r\n property CurrentKey: HKEY read GetCurrentKey;\r\n property Items stored False;\r\n published\r\n property Align;\r\n property Color;\r\n property BorderStyle;\r\n property Font;\r\n property ParentFont;\r\n property ParentShowHint;\r\n property ShowButtons;\r\n property ShowHint: Boolean read GetShowHint write SetShowHint;\r\n property ShowLines;\r\n property ShowRoot;\r\n property ReadOnly default True;\r\n property RightClickSelect;\r\n property Indent;\r\n property HideSelection;\r\n property RegistryKeys: TJvRegKeys read FRegistryKeys write SetRegistryKeys default\r\n [hkCurrentUser, hkLocalMachine];\r\n property ListView: TCustomListView read FListView write SetListView;\r\n property RootCaption: string read FRootCaption write SetRootCaption;\r\n property DefaultCaption: string read FDefaultCaption write SetDefaultCaption;\r\n property DefaultNoValueCaption: string read FDefaultNoValue write SetDefaultNoValue;\r\n property OnClick;\r\n property OnDblClick;\r\n property OnMouseDown;\r\n property OnMouseUp;\r\n property OnMouseMove;\r\n property OnKeyDown;\r\n property OnKeyPress;\r\n property OnKeyUp;\r\n property OnDragOver;\r\n property OnStartDrag;\r\n property OnEndDrag;\r\n property OnDragDrop;\r\n property OnStartDock;\r\n property OnEndDock;\r\n property OnDockDrop;\r\n property OnEditing;\r\n property OnEdited;\r\n property OnExpanding;\r\n property OnExpanded;\r\n property OnCollapsing;\r\n property OnCollapsed;\r\n property OnChanging;\r\n property OnChange;\r\n property OnCompare;\r\n property OnAddition;\r\n property OnDeletion;\r\n property OnGetImageIndex;\r\n property OnGetSelectedIndex;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvRegistryTreeview.pas $';\r\n Revision: '$Revision: 13173 $';\r\n Date: '$Date: 2011-11-19 13:43:58 +0100 (sam. 19 nov. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n {$IFNDEF COMPILER12_UP}\r\n JvJCLUtils, // NativeInt\r\n {$ENDIF ~COMPILER12_UP}\r\n JvResources, JvJVCLUtils;\r\n\r\n{$R JvRegistryTreeView.res}\r\n\r\nconst\r\n imMyPC = 0;\r\n imClosed = 1;\r\n imOpen = 2;\r\n imText = 3;\r\n imBin = 4;\r\n\r\ntype\r\n TRegistryAccessProtected = class(TRegistry);\r\n TListViewAccessProtected = class(TCustomListView);\r\n\r\nfunction SetRootKey(Reg: TRegistry; Node: TTreeNode): Boolean;\r\nvar\r\n TmpNode: TTreeNode;\r\nbegin\r\n Result := False;\r\n if Node <> nil then\r\n begin\r\n TmpNode := Node;\r\n while TmpNode <> nil do\r\n begin\r\n if NativeInt(HKEY(TmpNode.Data)) < 0 then\r\n begin\r\n Reg.RootKey := HKEY(TmpNode.Data);\r\n Result := True;\r\n Break;\r\n end;\r\n TmpNode := TmpNode.Parent;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction FixupPath(Key: string): string;\r\nbegin\r\n if Key = '' then\r\n Result := '\\'\r\n else\r\n if {$IFDEF COMPILER12_UP}Key[Length(Key)]{$ELSE}AnsiLastChar(Key){$ENDIF COMPILER12_UP} <> '\\' then\r\n Result := Key + '\\'\r\n else\r\n Result := Key;\r\n if Length(Result) > 1 then\r\n if (Result[1] = '\\') and (Result[2] = '\\') then\r\n Result := Copy(Result, 2, Length(Result));\r\nend;\r\n\r\nfunction GetFullPath(ANode: TTreeNode): string;\r\nvar\r\n TmpNode: TTreeNode;\r\nbegin\r\n Result := '';\r\n if ANode = nil then\r\n Exit;\r\n TmpNode := ANode;\r\n while TmpNode <> nil do\r\n begin\r\n Result := TmpNode.Text + '\\' + Result;\r\n TmpNode := TmpNode.Parent;\r\n end;\r\n if (Result <> '') and ({$IFDEF COMPILER12_UP}Result[Length(Result)]{$ELSE}AnsiLastChar(Result){$ENDIF COMPILER12_UP} = '\\') then\r\n SetLength(Result, Length(Result) - 1);\r\nend;\r\n\r\nfunction GetKeyPath(ANode: TTreeNode): string;\r\nvar\r\n TmpNode: TTreeNode;\r\nbegin\r\n Result := '';\r\n if ANode = nil then\r\n Exit;\r\n TmpNode := ANode;\r\n while (TmpNode.Parent <> nil) and (TmpNode.Parent.Parent <> nil) do\r\n begin\r\n Result := TmpNode.Text + '\\' + Result;\r\n TmpNode := TmpNode.Parent;\r\n end;\r\n if (Length(Result) > 0) and (Result[1] <> '\\') then\r\n Result := '\\' + Result;\r\nend;\r\n\r\n{\r\nfunction GetPreviousKey(Key: string): string;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := Key;\r\n if (Result = '') or (Result = '\\') then Exit;\r\n for I := Length(Result) - 1 downto 1 do\r\n if Result[I] = '\\' then\r\n begin\r\n Result := Copy(Result,1,I - 1);\r\n Exit;\r\n end;\r\nend;\r\n\r\nfunction StripChars(Str: string; Ch: Char): string;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := '';\r\n for I := 1 to Length(Str) do\r\n begin\r\n if Str[I] = Ch then Continue;\r\n AppendStr(Result,str[I]);\r\n end;\r\nend;\r\n}\r\n\r\nfunction BufToStr(Buffer: array of Byte; BufSize: Integer): string;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := '';\r\n for I := 0 to BufSize - 1 do\r\n Result := Result + ' ' + IntToHex(Buffer[I], 2);\r\nend;\r\n\r\nfunction RegTypes(AType: Integer): string;\r\nconst\r\n StrTypes: array [0..10] of PChar =\r\n ('REG_NONE', 'REG_SZ', 'REG_EXPAND_SZ', 'REG_BINARY', 'REG_DWORD',\r\n 'REG_DWORD_BIG_ENDIAN', 'REG_LINK', 'REG_MULTI_SZ', 'REG_RESOURCE_LIST',\r\n 'REG_FULL_RESOURCE_DESCRIPTOR', 'REG_RESOURCE_REQUIREMENTS_LIST');\r\nbegin\r\n if (AType >= 0) and (AType <= High(StrTypes)) then\r\n Result := StrTypes[AType]\r\n else\r\n Result := 'UNKNOWN';\r\nend;\r\n\r\n//=== { TJvRegistryTreeView } ================================================\r\n\r\nconstructor TJvRegistryTreeView.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FRegistryKeys := [hkCurrentUser, hkLocalMachine];\r\n FRootCaption := RsMyComputer;\r\n FDefaultCaption := RsDefaultCaption;\r\n FDefaultNoValue := RsDefaultNoValue;\r\n SetDefaultImages;\r\nend;\r\n\r\ndestructor TJvRegistryTreeView.Destroy;\r\nbegin\r\n if Assigned(FListView) and (TListViewAccessProtected(FListView).SmallImages = FInternalImages) then\r\n TListViewAccessProtected(FListView).SmallImages := nil;\r\n if Assigned(FInternalImages) then\r\n FInternalImages.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJvRegistryTreeView.GetCurrentPath: string;\r\nbegin\r\n Result := GetFullPath(Selected);\r\nend;\r\n\r\nfunction TJvRegistryTreeView.GetShortPath: string;\r\nbegin\r\n Result := GetKeyPath(Selected);\r\nend;\r\n\r\nfunction TJvRegistryTreeView.GetCurrentKey: HKEY;\r\nbegin\r\n OpenRegistry(Selected);\r\n Result := TRegistryAccessProtected(FReg).GetKey(ShortPath);\r\n CloseRegistry;\r\nend;\r\n\r\nfunction TJvRegistryTreeView.GetShowHint: Boolean;\r\nbegin\r\n Result := inherited ShowHint;\r\nend;\r\n\r\nprocedure TJvRegistryTreeView.SetShowHint(Value: Boolean);\r\nbegin\r\n if inherited ShowHint <> Value then\r\n begin\r\n inherited ShowHint := Value;\r\n Items.Clear; // AV's in ComCtrl32.dll without this\r\n RecreateWnd;\r\n end;\r\nend;\r\n\r\nprocedure TJvRegistryTreeView.SetDefaultImages;\r\nbegin\r\n if not Assigned(FInternalImages) then\r\n FInternalImages := TImageList.CreateSize(16, 16);\r\n if FInternalImages.Count = 0 then\r\n begin\r\n FInternalImages.GetInstRes(HInstance, rtBitmap, 'JvRegistryTreeViewMYCOMPUTER', 16, [], clFuchsia);\r\n FInternalImages.GetInstRes(HInstance, rtBitmap, 'JvRegistryTreeViewCLOSEDFOLDER', 16, [], clFuchsia);\r\n FInternalImages.GetInstRes(HInstance, rtBitmap, 'JvRegistryTreeViewOPENFOLDER', 16, [], clFuchsia);\r\n FInternalImages.GetInstRes(HInstance, rtBitmap, 'JvRegistryTreeViewTEXTIMAGE', 16, [], clFuchsia);\r\n FInternalImages.GetInstRes(HInstance, rtBitmap, 'JvRegistryTreeViewBINIMAGE', 16, [], clFuchsia);\r\n end;\r\n Images := FInternalImages;\r\nend;\r\n\r\nprocedure TJvRegistryTreeView.RefreshSubTrees(ANode: TTreeNode; Key, OldKey: string; Level: Integer);\r\nvar\r\n AStrings: TStringList;\r\n I: Integer;\r\n NewNode: TTreeNode;\r\n AKey: string;\r\nbegin\r\n AKey := FixupPath(OldKey);\r\n if FReg.OpenKeyReadOnly(Key) and FReg.HasSubKeys then\r\n begin\r\n ANode.HasChildren := True;\r\n Dec(Level);\r\n if Level = 1 then\r\n begin\r\n AStrings := TStringList.Create;\r\n try\r\n FReg.GetKeyNames(AStrings);\r\n for I := 0 to AStrings.Count - 1 do\r\n begin\r\n if AStrings[I] = '' then\r\n AStrings[I] := Format('%.04d', [I]);\r\n NewNode := Items.AddChild(ANode, AStrings[I]);\r\n NewNode.ImageIndex := imClosed;\r\n NewNode.SelectedIndex := imOpen;\r\n RefreshSubTrees(NewNode, AStrings[I], AKey + Key, Level);\r\n end;\r\n finally\r\n AStrings.Free;\r\n end;\r\n end;\r\n end;\r\n FReg.OpenKeyReadOnly(AKey);\r\nend;\r\n\r\nfunction TJvRegistryTreeView.FillListView(Node: TTreeNode): Boolean;\r\nvar\r\n I, J: Integer;\r\n TmpItem: TListItem;\r\n S, T: string;\r\n DefaultSet: Boolean;\r\n Info: TRegKeyInfo;\r\n D: array of Byte;\r\n DataType: Cardinal;\r\n Len, Len1: Cardinal;\r\n AListView: TListViewAccessProtected;\r\nbegin\r\n Result := False;\r\n if not Assigned(FListView) then\r\n Exit;\r\n OpenRegistry(Node);\r\n AListView := TListViewAccessProtected(FListView);\r\n AListView.Items.BeginUpdate;\r\n try\r\n AListView.Items.Clear;\r\n if AListView.SmallImages = nil then\r\n AListView.SmallImages := Images;\r\n if (Node = nil) or (Node = Items.GetFirstNode) then\r\n Exit;\r\n { set current root }\r\n DefaultSet := False;\r\n if FReg.OpenKeyReadOnly(GetKeyPath(Node)) then\r\n begin\r\n if FReg.GetKeyInfo(Info) then\r\n begin\r\n for I := 0 to Info.NumValues - 1 do\r\n begin\r\n Len := Info.MaxValueLen + 1;\r\n Len1 := Info.MaxDataLen + 1;\r\n SetLength(S, Len);\r\n SetLength(D, Len1);\r\n DataType := 0;\r\n RegEnumValue(FReg.CurrentKey, I, PChar(S), Len, nil, @DataType, @D[0], @Len1);\r\n SetLength(S,Len);\r\n { set default item }\r\n if (S = '') and not DefaultSet then\r\n begin\r\n TmpItem := AListView.Items.Insert(0);\r\n TmpItem.Caption := FDefaultCaption;\r\n DefaultSet := True;\r\n end\r\n else\r\n begin\r\n TmpItem := AListView.Items.Add;\r\n TmpItem.Caption := S;\r\n end;\r\n case DataType of\r\n REG_SZ, REG_EXPAND_SZ,REG_MULTI_SZ:\r\n begin\r\n if DataType = REG_MULTI_SZ then\r\n for J := 0 to Pred(Len1) do\r\n if D[J] = 0 then\r\n D[J] := Ord(' ');\r\n T := string(PChar(D));\r\n if (T = '') and AnsiSameText(TmpItem.Caption, FDefaultCaption) then\r\n T := FDefaultNoValue;\r\n TmpItem.ImageIndex := imText;\r\n TmpItem.SubItems.Add(T);\r\n end;\r\n REG_DWORD:\r\n begin\r\n TmpItem.ImageIndex := imBin;\r\n TmpItem.SubItems.Add(Format('0x%.8x (%d)', [Cardinal(Pointer(D)^),Cardinal(Pointer(D)^)]));\r\n end;\r\n REG_NONE:\r\n begin\r\n TmpItem.ImageIndex := imText;\r\n TmpItem.SubItems.Add(RsUnknownCaption);\r\n end;\r\n else\r\n begin\r\n TmpItem.ImageIndex := imBin;\r\n TmpItem.SubItems.Add(BufToStr(D, Len1));\r\n end;\r\n end;\r\n TmpItem.SubItems.Add(RegTypes(DataType));\r\n end;\r\n end;\r\n Result := True;\r\n end;\r\n { set default item }\r\n if (Node.Parent <> nil) and not DefaultSet then\r\n begin\r\n TmpItem := AListView.Items.Insert(0);\r\n TmpItem.ImageIndex := imText;\r\n TmpItem.Caption := FDefaultCaption;\r\n TmpItem.SubItems.Add(FDefaultNoValue);\r\n TmpItem.SubItems.Add('REG_SZ');\r\n end;\r\n finally\r\n AListView.Items.EndUpdate;\r\n CloseRegistry;\r\n end;\r\nend;\r\n\r\nprocedure TJvRegistryTreeView.SetDefaultCaption(Value: string);\r\nbegin\r\n FDefaultCaption := Value;\r\n FillListView(Selected);\r\nend;\r\n\r\nprocedure TJvRegistryTreeView.SetDefaultNoValue(Value: string);\r\nbegin\r\n FDefaultNoValue := Value;\r\n FillListView(Selected);\r\nend;\r\n\r\nprocedure TJvRegistryTreeView.SetRootCaption(Value: string);\r\nbegin\r\n FRootCaption := Value;\r\n BuildTree;\r\nend;\r\n\r\nprocedure TJvRegistryTreeView.SetRegistryKeys(Value: TJvRegKeys);\r\nbegin\r\n if FRegistryKeys <> Value then\r\n FRegistryKeys := Value;\r\n BuildTree;\r\nend;\r\n\r\nprocedure TJvRegistryTreeView.BuildTree;\r\nvar\r\n NewNode, ANode: TTreeNode;\r\nbegin\r\n OpenRegistry(nil);\r\n Items.BeginUpdate;\r\n try\r\n Items.Clear;\r\n ANode := Items.Add(nil, FRootCaption);\r\n ANode.ImageIndex := imMyPC;\r\n ANode.SelectedIndex := imMyPC;\r\n if hkClassesRoot in FRegistryKeys then\r\n begin\r\n FReg.RootKey := HKEY_CLASSES_ROOT;\r\n NewNode := Items.AddChild(ANode, 'HKEY_CLASSES_ROOT');\r\n NewNode.ImageIndex := imClosed;\r\n NewNode.SelectedIndex := imOpen;\r\n NewNode.Data := Pointer(FReg.RootKey);\r\n if not (csDesigning in ComponentState) then\r\n RefreshSubTrees(NewNode, '\\', '', 1);\r\n end;\r\n\r\n if hkCurrentUser in FRegistryKeys then\r\n begin\r\n FReg.RootKey := HKEY_CURRENT_USER;\r\n NewNode := Items.AddChild(ANode, 'HKEY_CURRENT_USER');\r\n NewNode.ImageIndex := imClosed;\r\n NewNode.SelectedIndex := imOpen;\r\n NewNode.Data := Pointer(FReg.RootKey);\r\n if not (csDesigning in ComponentState) then\r\n RefreshSubTrees(NewNode, '\\', '', 1);\r\n end;\r\n\r\n if hkLocalMachine in FRegistryKeys then\r\n begin\r\n FReg.RootKey := HKEY_LOCAL_MACHINE;\r\n NewNode := Items.AddChild(ANode, 'HKEY_LOCAL_MACHINE');\r\n NewNode.ImageIndex := imClosed;\r\n NewNode.SelectedIndex := imOpen;\r\n NewNode.Data := Pointer(FReg.RootKey);\r\n if not (csDesigning in ComponentState) then\r\n RefreshSubTrees(NewNode, '\\', '', 1);\r\n end;\r\n\r\n if hkUsers in FRegistryKeys then\r\n begin\r\n FReg.RootKey := HKEY_USERS;\r\n NewNode := Items.AddChild(ANode, 'HKEY_USERS');\r\n NewNode.ImageIndex := imClosed;\r\n NewNode.SelectedIndex := imOpen;\r\n NewNode.Data := Pointer(FReg.RootKey);\r\n if not (csDesigning in ComponentState) then\r\n RefreshSubTrees(NewNode, '\\', '', 1);\r\n end;\r\n\r\n if hkPerformanceData in FRegistryKeys then\r\n begin\r\n FReg.RootKey := HKEY_PERFORMANCE_DATA;\r\n NewNode := Items.AddChild(ANode, 'HKEY_PERFORMANCE_DATA');\r\n NewNode.ImageIndex := imClosed;\r\n NewNode.SelectedIndex := imOpen;\r\n NewNode.Data := Pointer(FReg.RootKey);\r\n if not (csDesigning in ComponentState) then\r\n RefreshSubTrees(NewNode, '\\', '', 1);\r\n end;\r\n\r\n if hkCurrentConfig in FRegistryKeys then\r\n begin\r\n FReg.RootKey := HKEY_CURRENT_CONFIG;\r\n NewNode := Items.AddChild(ANode, 'HKEY_CURRENT_CONFIG');\r\n NewNode.ImageIndex := imClosed;\r\n NewNode.SelectedIndex := imOpen;\r\n NewNode.Data := Pointer(FReg.RootKey);\r\n if not (csDesigning in ComponentState) then\r\n RefreshSubTrees(NewNode, '\\', '', 1);\r\n end;\r\n if hkDynData in FRegistryKeys then\r\n begin\r\n FReg.RootKey := HKEY_DYN_DATA;\r\n NewNode := Items.AddChild(ANode, 'HKEY_DYN_DATA');\r\n NewNode.ImageIndex := imClosed;\r\n NewNode.SelectedIndex := imOpen;\r\n NewNode.Data := Pointer(FReg.RootKey);\r\n if not (csDesigning in ComponentState) then\r\n RefreshSubTrees(NewNode, '\\', '', 1);\r\n end;\r\n ANode.Expand(False);\r\n ANode.Selected := True;\r\n finally\r\n CloseRegistry;\r\n Items.EndUpdate;\r\n end;\r\nend;\r\n\r\nfunction TJvRegistryTreeView.CanCollapse(Node: TTreeNode): Boolean;\r\nbegin\r\n Result := inherited CanCollapse(Node);\r\n { if Result then\r\n Node.ImageIndex := imClosed;}\r\nend;\r\n\r\nfunction TJvRegistryTreeView.CanExpand(Node: TTreeNode): Boolean;\r\nbegin\r\n Result := inherited CanExpand(Node);\r\n if not Result or (Node.Parent = nil) then\r\n Exit;\r\n OpenRegistry(Node);\r\n try\r\n // Node.ImageIndex := imOpen;\r\n // Node.DeleteChildren;\r\n SetRootKey(FReg, Node);\r\n if not (csDesigning in ComponentState) and (Node.Count = 0) then\r\n RefreshSubTrees(Node, FixupPath(GetKeyPath(Node)), '', 2);\r\n finally\r\n CloseRegistry;\r\n end;\r\nend;\r\n\r\nprocedure TJvRegistryTreeView.Change(Node: TTreeNode);\r\nbegin\r\n FillListView(Node);\r\n inherited Change(Node);\r\nend;\r\n\r\nprocedure TJvRegistryTreeView.CreateParams(var Params: TCreateParams);\r\nconst\r\n TVS_NOTOOLTIPS = $0080;\r\nbegin\r\n inherited CreateParams(Params);\r\n if not ShowHint then\r\n Params.Style := Params.Style or TVS_NOTOOLTIPS;\r\nend;\r\n\r\nprocedure TJvRegistryTreeView.CreateWnd;\r\nbegin\r\n inherited CreateWnd;\r\n SetDefaultImages;\r\n BuildTree;\r\nend;\r\n\r\nprocedure TJvRegistryTreeView.Notification(AComponent: TComponent;\r\n Operation: TOperation);\r\nbegin\r\n inherited Notification(AComponent, Operation);\r\n if (Operation = opRemove) then\r\n if (AComponent = FListView) then\r\n begin\r\n if TListViewAccessProtected(FListView).SmallImages = FInternalImages then\r\n TListViewAccessProtected(FListView).SmallImages := nil;\r\n FListView := nil;\r\n end\r\n else if (AComponent = Images) then\r\n SetDefaultImages;\r\nend;\r\n\r\nprocedure TJvRegistryTreeView.RefreshNode(Node: TTreeNode);\r\nvar\r\n B: Boolean;\r\nbegin\r\n Items.BeginUpdate;\r\n try\r\n B := False;\r\n if Node <> nil then\r\n B := Node.Expanded;\r\n OpenRegistry(Node);\r\n try\r\n if Node <> nil then\r\n Node.DeleteChildren;\r\n if (Node = nil) or (Node = Items.GetFirstNode) then\r\n BuildTree\r\n else\r\n begin\r\n SetRootKey(FReg, Node);\r\n RefreshSubTrees(Node, FixupPath(GetKeyPath(Node)), '', 2);\r\n end;\r\n finally\r\n if Node <> nil then\r\n Node.Expanded := B;\r\n CloseRegistry;\r\n end;\r\n finally\r\n Items.EndUpdate;\r\n end;\r\nend;\r\n\r\nfunction TJvRegistryTreeView.FindChildNode(ParentNode: TTreeNode; const Name: string): TTreeNode;\r\nvar\r\n N: TTreeNode;\r\nbegin\r\n Result := nil;\r\n if ParentNode = nil then\r\n Exit;\r\n N := ParentNode.getFirstChild;\r\n while Assigned(N) do\r\n begin\r\n if AnsiSameText(N.Text, Name) then\r\n begin\r\n Result := N;\r\n Exit;\r\n end;\r\n N := N.getNextSibling;\r\n end;\r\nend;\r\n\r\nfunction TJvRegistryTreeView.AddBinaryValue(ParentNode: TTreeNode;\r\n const Name: string; var Buf; BufSize: Integer): TTreeNode;\r\nbegin\r\n Result := nil;\r\n if ParentNode = nil then\r\n Exit;\r\n OpenRegistry(ParentNode);\r\n FReg.WriteBinaryData(FixupPath(GetKeyPath(ParentNode)) + Name,\r\n Buf, BufSize);\r\n CloseRegistry;\r\n RefreshNode(ParentNode);\r\n Result := FindChildNode(ParentNode, Name);\r\nend;\r\n\r\nfunction TJvRegistryTreeView.AddDWORDValue(ParentNode: TTreeNode;\r\n const Name: string; Value: DWORD): TTreeNode;\r\nbegin\r\n Result := nil;\r\n if ParentNode = nil then\r\n Exit;\r\n OpenRegistry(ParentNode);\r\n FReg.WriteInteger(FixupPath(GetKeyPath(ParentNode)) + Name, Value);\r\n CloseRegistry;\r\n RefreshNode(ParentNode);\r\n Result := FindChildNode(ParentNode, Name);\r\nend;\r\n\r\nfunction TJvRegistryTreeView.AddKey(ParentNode: TTreeNode;\r\n const KeyName: string): TTreeNode;\r\nbegin\r\n Result := nil;\r\n if ParentNode = nil then\r\n Exit;\r\n OpenRegistry(ParentNode);\r\n FReg.OpenKey(FixupPath(GetKeyPath(ParentNode)) + KeyName, True);\r\n CloseRegistry;\r\n RefreshNode(ParentNode);\r\n Result := FindChildNode(ParentNode, KeyName);\r\nend;\r\n\r\nfunction TJvRegistryTreeView.AddStringValue(ParentNode: TTreeNode;\r\n const Name, Value: string): TTreeNode;\r\nbegin\r\n Result := nil;\r\n if ParentNode = nil then\r\n Exit;\r\n OpenRegistry(ParentNode);\r\n FReg.WriteString(FixupPath(GetKeyPath(ParentNode)) + Name, Value);\r\n CloseRegistry;\r\n RefreshNode(ParentNode);\r\n Result := FindChildNode(ParentNode, Name);\r\nend;\r\n\r\nprocedure TJvRegistryTreeView.CloseRegistry;\r\nbegin\r\n FReg.Free;\r\n FReg := nil;\r\nend;\r\n\r\nprocedure TJvRegistryTreeView.OpenRegistry(Node: TTreeNode);\r\nbegin\r\n if FReg = nil then\r\n FReg := TRegistry.Create;\r\n SetRootKey(FReg, Node);\r\nend;\r\n\r\nfunction TJvRegistryTreeView.LoadKey(const Filename: string): Boolean;\r\nbegin\r\n OpenRegistry(Selected);\r\n Result := FReg.LoadKey(ShortPath, ChangeFileExt(Filename, ''));\r\n CloseRegistry;\r\nend;\r\n\r\nfunction TJvRegistryTreeView.SaveKey(const Filename: string): Boolean;\r\nbegin\r\n OpenRegistry(Selected);\r\n Result := FReg.SaveKey(ShortPath, Filename);\r\n CloseRegistry;\r\nend;\r\n\r\nprocedure TJvRegistryTreeView.SetListView(const Value: TCustomListView);\r\nbegin\r\n ReplaceComponentReference(Self, Value, TComponent(FListView));\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvRenameError.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvRenameError.PAS, released on 2001-02-28.\r\n\r\nThe Initial Developer of the Original Code is Sbastien Buysse [sbuysse att buypin dott com]\r\nPortions created by Sbastien Buysse are Copyright (C) 2001 Sbastien Buysse.\r\nAll Rights Reserved.\r\n\r\nContributor(s): Michael Beck [mbeck att bigfoot dott com].\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvRenameError.pas 13351 2012-06-13 15:16:00Z obones $\r\n\r\nunit JvRenameError;\r\n\r\n{$I jvcl.inc}\r\n{$I windowsonly.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, SysUtils, Classes,\r\n JvCustomFileMessageDialog, JvTypes;\r\n\r\ntype\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvRenameError = class(TJvCustomFileMessageDialog)\r\n private\r\n FWin32ErrorCode: Integer;\r\n FStyle: TJvDeleteStyles;\r\n FDestFile: string;\r\n FSourceFile: string;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n published\r\n property SourceFile: string read FSourceFile write FSourceFile;\r\n property DestFile: string read FDestFile write FDestFile;\r\n property Win32ErrorCode: Integer read FWin32ErrorCode write FWin32ErrorCode default 0;\r\n property Style: TJvDeleteStyles read FStyle write FStyle default [];\r\n function Execute: TJvDiskRes; override;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvRenameError.pas $';\r\n Revision: '$Revision: 13351 $';\r\n Date: '$Date: 2012-06-13 17:16:00 +0200 (mer. 13 juin 2012) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n JvSetupApi,\r\n JclSysUtils;\r\n\r\nconstructor TJvRenameError.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FStyle := [];\r\n FWin32ErrorCode := 0;\r\n FDestFile := '';\r\n FSourceFile := '';\r\nend;\r\n\r\nfunction TJvRenameError.Execute: TJvDiskRes;\r\nvar\r\n Sty: DWORD;\r\nbegin\r\n Sty := 0;\r\n if idNoBeep in Style then\r\n Sty := Sty or IDF_NOBEEP;\r\n if idNoForeground in Style then\r\n Sty := Sty or IDF_NOFOREGROUND;\r\n\r\n case SetupRenameError(OwnerWindow, PCharOrNil(Title), PChar(FSourceFile),\r\n PChar(FDestFile), FWin32ErrorCode, Sty) of\r\n DPROMPT_SUCCESS:\r\n Result := dsSuccess;\r\n DPROMPT_CANCEL:\r\n Result := dsCancel;\r\n DPROMPT_SKIPFILE:\r\n Result := dsSkipfile;\r\n else\r\n Result := dsError;\r\n end;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvResample.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvResample.PAS released on 1998-03-15\r\n\r\nThe Initial Developer of the Original Code is Sbastien Buysse [sbuysse att buypin dott com]\r\nPortions created by Anders Melander are Copyright (C) 1998 Anders Melander.\r\nAll Rights Reserved.\r\n\r\nContributor(s): -\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvResample.pas 13173 2011-11-19 12:43:58Z ahuser $\r\n\r\n// -----------------------------------------------------------------------------\r\n// Project: bitmap resampler\r\n// Module: resample\r\n// Description: Interpolated Bitmap Resampling using filters.\r\n// Version: 01.02\r\n// Release: 3\r\n// Date: 15-MAR-1998\r\n// Target: Win32, Delphi 2 & 3\r\n// Author(s): anme: Anders Melander, anders att melander dott dk\r\n// Copyright (c) 1997,98 by Anders Melander\r\n// Formatting: 2 space indent, no tabs, 80 columns.\r\n// -----------------------------------------------------------------------------\r\n// This software is copyrighted as noted above. It may be freely copied,\r\n// modified, and redistributed, provided that the copyright notice(s) is\r\n// preserved on all copies.\r\n//\r\n// There is no warranty or other guarantee of fitness for this software,\r\n// it is provided solely \"as is\". Bug reports or fixes may be sent\r\n// to the author, who may or may not act on them as he desires.\r\n//\r\n// You may not include this software in a program or other software product\r\n// without supplying the source, or without informing the end-user that the\r\n// source is available for no extra charge.\r\n//\r\n// If you modify this software, you should include a notice in the \"Revision\r\n// history\" section giving the name of the person performing the modification,\r\n// the date of modification, and the reason for such modification.\r\n// -----------------------------------------------------------------------------\r\n// Here's some additional copyrights for you:\r\n//\r\n// From filter.c:\r\n// The authors and the publisher hold no copyright restrictions\r\n// on any of these files; this source code is public domain, and\r\n// is freely available to the entire computer graphics community\r\n// for study, use, and modification. We do request that the\r\n// comment at the top of each file, identifying the original\r\n// author and its original publication in the book Graphics\r\n// Gems, be retained in all programs that use these files.\r\n//\r\n// -----------------------------------------------------------------------------\r\n// Revision history:\r\n//\r\n// 0100 110997 anme - Adapted from fzoom v0.20 by Dale Schumacher.\r\n//\r\n// 0101 110198 anme - Added Lanczos3 and Mitchell filters.\r\n// - Fixed range bug.\r\n// Min value was not checked on conversion from Single to\r\n// byte.\r\n// - Numerous optimizations.\r\n// - Added TImage stretch on form resize.\r\n// - Added support for Delphi 2 via TCanvas.Pixels.\r\n// - Renamed module from stretch to resample.\r\n// - Moved demo code to separate module.\r\n//\r\n// 0102 150398 anme - Fixed a problem that caused all pixels to be shifted\r\n// 1/2 pixel down and to the right (in source\r\n// coordinates). Thanks to David Ullrich for the\r\n// solution.\r\n// -----------------------------------------------------------------------------\r\n// Credits:\r\n// The algorithms and methods used in this library are based on the article\r\n// \"General Filtered Image Rescaling\" by Dale Schumacher which appeared in the\r\n// book Graphics Gems III, published by Academic Press, Inc.\r\n//\r\n// The edge offset problem was fixed by:\r\n// * David Ullrich \r\n// -----------------------------------------------------------------------------\r\n// To do (in rough order of priority):\r\n// * Implement Dale Schumacher's \"Optimized Bitmap Scaling Routines\".\r\n// * Fix BoxFilter.\r\n// * Optimize to use integer math instead of floating point where possible.\r\n// -----------------------------------------------------------------------------\r\n\r\nunit JvResample;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, Graphics, SysUtils, Classes;\r\n\r\ntype\r\n // Type of a filter for use with Stretch()\r\n TFilterProc = function(Value: Single): Single;\r\n\r\n// Sample filters for use with Stretch()\r\nfunction SplineFilter(Value: Single): Single;\r\nfunction BellFilter(Value: Single): Single;\r\nfunction TriangleFilter(Value: Single): Single;\r\nfunction BoxFilter(Value: Single): Single;\r\nfunction HermiteFilter(Value: Single): Single;\r\nfunction Lanczos3Filter(Value: Single): Single;\r\nfunction MitchellFilter(Value: Single): Single;\r\n\r\n// Interpolator\r\n// Src: Source bitmap\r\n// Dst: Destination bitmap\r\n// filter: weight calculation filter\r\n// AWidth: Relative sample radius\r\nprocedure ImgStretch(Src, Dst: TBitmap; Filter: TFilterProc; AWidth: Single);\r\n\r\n//----------------------------------------------------------------------------\r\n// List of Filters\r\n//----------------------------------------------------------------------------\r\n\r\nconst\r\n ResampleFilters: array [0..6] of record\r\n Name: string; // Filter name\r\n Filter: TFilterProc; // Filter implementation\r\n Width: Single; // Suggested sampling width/radius\r\n end = (\r\n (Name: 'Box'; Filter: BoxFilter; Width: 0.5),\r\n (Name: 'Triangle'; Filter: TriangleFilter; Width: 1.0),\r\n (Name: 'Hermite'; Filter: HermiteFilter; Width: 1.0),\r\n (Name: 'Bell'; Filter: BellFilter; Width: 1.5),\r\n (Name: 'B-Spline'; Filter: SplineFilter; Width: 2.0),\r\n (Name: 'Lanczos3'; Filter: Lanczos3Filter; Width: 3.0),\r\n (Name: 'Mitchell'; Filter: MitchellFilter; Width: 2.0)\r\n );\r\n\r\n\r\n\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvResample.pas $';\r\n Revision: '$Revision: 13173 $';\r\n Date: '$Date: 2011-11-19 13:43:58 +0100 (sam. 19 nov. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n Math,\r\n JvTypes, JvResources;\r\n\r\n//----------------------------------------------------------------------------\r\n// Filter functions\r\n//----------------------------------------------------------------------------\r\n\r\n// Hermite filter\r\n\r\nfunction HermiteFilter(Value: Single): Single;\r\nbegin\r\n // f(t) = 2|t|^3 - 3|t|^2 + 1, -1 <= t <= 1\r\n if Value < 0.0 then\r\n Value := -Value;\r\n if Value < 1.0 then\r\n Result := (2.0 * Value - 3.0) * Sqr(Value) + 1.0\r\n else\r\n Result := 0.0;\r\nend;\r\n\r\n// Box filter\r\n// a.k.a. \"Nearest Neighbour\" filter\r\n// anme: I have not been able to get acceptable\r\n// results with this filter for subsampling.\r\n\r\nfunction BoxFilter(Value: Single): Single;\r\nbegin\r\n if (Value > -0.5) and (Value <= 0.5) then\r\n Result := 1.0\r\n else\r\n Result := 0.0;\r\nend;\r\n\r\n// Triangle filter\r\n// a.k.a. \"Linear\" or \"Bilinear\" filter\r\n\r\nfunction TriangleFilter(Value: Single): Single;\r\nbegin\r\n if Value < 0.0 then\r\n Value := -Value;\r\n if Value < 1.0 then\r\n Result := 1.0 - Value\r\n else\r\n Result := 0.0;\r\nend;\r\n\r\n// Bell filter\r\n\r\nfunction BellFilter(Value: Single): Single;\r\nbegin\r\n if Value < 0.0 then\r\n Value := -Value;\r\n if Value < 0.5 then\r\n Result := 0.75 - Sqr(Value)\r\n else\r\n if Value < 1.5 then\r\n begin\r\n Value := Value - 1.5;\r\n Result := 0.5 * Sqr(Value);\r\n end\r\n else\r\n Result := 0.0;\r\nend;\r\n\r\n// B-spline filter\r\n\r\nfunction SplineFilter(Value: Single): Single;\r\nvar\r\n TT: Single;\r\nbegin\r\n if Value < 0.0 then\r\n Value := -Value;\r\n if Value < 1.0 then\r\n begin\r\n TT := Sqr(Value);\r\n Result := 0.5 * TT * Value - TT + 2.0 / 3.0;\r\n end\r\n else\r\n if Value < 2.0 then\r\n begin\r\n Value := 2.0 - Value;\r\n Result := 1.0 / 6.0 * Sqr(Value) * Value;\r\n end\r\n else\r\n Result := 0.0;\r\nend;\r\n\r\n// Lanczos3 filter\r\n\r\nfunction Lanczos3Filter(Value: Single): Single;\r\n\r\n function SinC(Value: Single): Single;\r\n begin\r\n if Value <> 0.0 then\r\n begin\r\n Value := Value * Pi;\r\n Result := Sin(Value) / Value\r\n end\r\n else\r\n Result := 1.0;\r\n end;\r\n\r\nbegin\r\n if Value < 0.0 then\r\n Value := -Value;\r\n if Value < 3.0 then\r\n Result := SinC(Value) * SinC(Value / 3.0)\r\n else\r\n Result := 0.0;\r\nend;\r\n\r\nfunction MitchellFilter(Value: Single): Single;\r\nconst\r\n B = 1.0 / 3.0;\r\n C = 1.0 / 3.0;\r\nvar\r\n TT: Single;\r\nbegin\r\n if Value < 0.0 then\r\n Value := -Value;\r\n TT := Sqr(Value);\r\n if Value < 1.0 then\r\n begin\r\n Value := (((12.0 - 9.0 * B - 6.0 * C) * (Value * TT)) +\r\n ((-18.0 + 12.0 * B + 6.0 * C) * TT) +\r\n (6.0 - 2 * B));\r\n Result := Value / 6.0;\r\n end\r\n else\r\n if Value < 2.0 then\r\n begin\r\n Value := (((-1.0 * B - 6.0 * C) * (Value * TT)) +\r\n ((6.0 * B + 30.0 * C) * TT) +\r\n ((-12.0 * B - 48.0 * C) * Value) +\r\n (8.0 * B + 24 * C));\r\n Result := Value / 6.0;\r\n end\r\n else\r\n Result := 0.0;\r\nend;\r\n\r\n//----------------------------------------------------------------------------\r\n// Interpolator\r\n//----------------------------------------------------------------------------\r\n\r\ntype\r\n // Contributor for a pixel\r\n TContributor = record\r\n Pixel: Integer; // Source pixel\r\n Weight: Single; // Pixel Weight\r\n end;\r\n\r\n TContributorList = array [0..0] of TContributor;\r\n PContributorList = ^TContributorList;\r\n\r\n // List of source pixels contributing to a destination pixel\r\n TCList = record\r\n N: Integer;\r\n P: PContributorList;\r\n end;\r\n\r\n TCListList = array [0..0] of TCList;\r\n PCListList = ^TCListList;\r\n\r\n TRGB = packed record\r\n R: Single;\r\n G: Single;\r\n B: Single;\r\n end;\r\n\r\n // Physical bitmap pixel\r\n TColorRGB = packed record\r\n R: Byte;\r\n G: Byte;\r\n B: Byte;\r\n end;\r\n PColorRGB = ^TColorRGB;\r\n\r\n // Physical bitmap scanline (row)\r\n TRGBList = packed array [0..0] of TColorRGB;\r\n PRGBList = ^TRGBList;\r\n\r\nprocedure ImgStretch(Src, Dst: TBitmap; Filter: TFilterProc; AWidth: Single);\r\nvar\r\n XScale, YScale: Single; // Zoom scale factors\r\n I, J, K: Integer; // Loop variables\r\n Center: Single; // Filter calculation variables\r\n Width, FScale, Weight: Single; // Filter calculation variables\r\n Left, Right: Integer; // Filter calculation variables\r\n N: Integer; // Pixel number\r\n Work: TBitmap;\r\n Contrib: PCListList;\r\n Rgb: TRGB;\r\n Color: TColorRGB;\r\n SourceLine, DestLine: PRGBList;\r\n (*SourcePixel, *)DestPixel: PColorRGB;\r\n Delta, DestDelta: Integer;\r\n SrcWidth, SrcHeight, DstWidth, DstHeight: Integer;\r\n\r\n function Color2RGB(Color: TColor): TColorRGB;\r\n begin\r\n Result.R := Color and $000000FF;\r\n Result.G := (Color and $0000FF00) shr 8;\r\n Result.B := (Color and $00FF0000) shr 16;\r\n end;\r\n\r\n function RGB2Color(Color: TColorRGB): TColor;\r\n begin\r\n Result := Color.R or (Color.G shl 8) or (Color.B shl 16);\r\n end;\r\n\r\nbegin\r\n DstWidth := Dst.Width;\r\n DstHeight := Dst.Height;\r\n SrcWidth := Src.Width;\r\n SrcHeight := Src.Height;\r\n if (SrcWidth < 1) or (SrcHeight < 1) then\r\n raise EJVCLException.CreateRes(@RsESourceBitmapTooSmall);\r\n\r\n // Create intermediate image to hold horizontal zoom\r\n Work := TBitmap.Create;\r\n try\r\n Work.Height := SrcHeight;\r\n Work.Width := DstWidth;\r\n // XScale := DstWidth / SrcWidth;\r\n // YScale := DstHeight / SrcHeight;\r\n // Improvement suggested by David Ullrich:\r\n if SrcWidth = 1 then\r\n XScale := DstWidth / SrcWidth\r\n else\r\n XScale := (DstWidth - 1) / (SrcWidth - 1);\r\n if SrcHeight = 1 then\r\n YScale := DstHeight / SrcHeight\r\n else\r\n YScale := (DstHeight - 1) / (SrcHeight - 1);\r\n // This implementation only works on 24-bit images because it uses\r\n // TBitmap.Scanline\r\n Src.PixelFormat := pf24bit;\r\n Dst.PixelFormat := Src.PixelFormat;\r\n Work.PixelFormat := Src.PixelFormat;\r\n\r\n // --------------------------------------------\r\n // Pre-calculate filter contributions for a row\r\n // -----------------------------------------------\r\n GetMem(Contrib, DstWidth * SizeOf(TCList));\r\n // Horizontal sub-sampling\r\n // Scales from bigger to smaller Width\r\n if XScale < 1.0 then\r\n begin\r\n Width := AWidth / XScale;\r\n FScale := 1.0 / XScale;\r\n for I := 0 to DstWidth - 1 do\r\n begin\r\n Contrib^[I].N := 0;\r\n GetMem(Contrib^[I].P, Trunc(Width * 2.0 + 1) * SizeOf(TContributor));\r\n Center := I / XScale;\r\n // Original code:\r\n // Left := Ceil(Center - Width);\r\n // Right := Floor(Center + Width);\r\n Left := Floor(Center - Width);\r\n Right := Ceil(Center + Width);\r\n for J := Left to Right do\r\n begin\r\n Weight := Filter((Center - J) / FScale) / FScale;\r\n if Weight = 0.0 then\r\n Continue;\r\n if J < 0 then\r\n N := -J\r\n else\r\n if J >= SrcWidth then\r\n N := SrcWidth - J + SrcWidth - 1\r\n else\r\n N := J;\r\n K := Contrib^[I].N;\r\n Contrib^[I].N := Contrib^[I].N + 1;\r\n Contrib^[I].P^[K].Pixel := N;\r\n Contrib^[I].P^[K].Weight := Weight;\r\n end;\r\n end;\r\n end\r\n else\r\n // Horizontal super-sampling\r\n // Scales from smaller to bigger Width\r\n begin\r\n for I := 0 to DstWidth - 1 do\r\n begin\r\n Contrib^[I].N := 0;\r\n GetMem(Contrib^[I].P, Trunc(AWidth * 2.0 + 1) * SizeOf(TContributor));\r\n Center := I / XScale;\r\n // Original code:\r\n // Left := Ceil(Center - AWidth);\r\n // Right := Floor(Center + AWidth);\r\n Left := Floor(Center - AWidth);\r\n Right := Ceil(Center + AWidth);\r\n for J := Left to Right do\r\n begin\r\n Weight := Filter(Center - J);\r\n if Weight = 0.0 then\r\n Continue;\r\n if J < 0 then\r\n N := -J\r\n else\r\n if J >= SrcWidth then\r\n N := SrcWidth - J + SrcWidth - 1\r\n else\r\n N := J;\r\n K := Contrib^[I].N;\r\n Contrib^[I].N := Contrib^[I].N + 1;\r\n Contrib^[I].P^[K].Pixel := N;\r\n Contrib^[I].P^[K].Weight := Weight;\r\n end;\r\n end;\r\n end;\r\n\r\n // ----------------------------------------------------\r\n // Apply filter to sample horizontally from Src to Work\r\n // ----------------------------------------------------\r\n for K := 0 to SrcHeight - 1 do\r\n begin\r\n SourceLine := Src.ScanLine[K];\r\n DestPixel := Work.ScanLine[K];\r\n for I := 0 to DstWidth - 1 do\r\n begin\r\n Rgb.R := 0.0;\r\n Rgb.G := 0.0;\r\n Rgb.B := 0.0;\r\n for J := 0 to Contrib^[I].N - 1 do\r\n begin\r\n Color := SourceLine^[Contrib^[I].P^[J].Pixel];\r\n Weight := Contrib^[I].P^[J].Weight;\r\n if Weight = 0.0 then\r\n Continue;\r\n Rgb.R := Rgb.R + Color.R * Weight;\r\n Rgb.G := Rgb.G + Color.G * Weight;\r\n Rgb.B := Rgb.B + Color.B * Weight;\r\n end;\r\n if Rgb.R > 255.0 then\r\n Color.R := 255\r\n else\r\n if Rgb.R < 0.0 then\r\n Color.R := 0\r\n else\r\n Color.R := Round(Rgb.R);\r\n if Rgb.G > 255.0 then\r\n Color.G := 255\r\n else\r\n if Rgb.G < 0.0 then\r\n Color.G := 0\r\n else\r\n Color.G := Round(Rgb.G);\r\n if Rgb.B > 255.0 then\r\n Color.B := 255\r\n else\r\n if Rgb.B < 0.0 then\r\n Color.B := 0\r\n else\r\n Color.B := Round(Rgb.B);\r\n // Set new Pixel value\r\n DestPixel^ := Color;\r\n // Move on to next column\r\n Inc(DestPixel);\r\n end;\r\n end;\r\n\r\n // Free the memory allocated for horizontal filter weights\r\n for I := 0 to DstWidth - 1 do\r\n FreeMem(Contrib^[I].P);\r\n\r\n FreeMem(Contrib);\r\n\r\n // -----------------------------------------------\r\n // Pre-calculate filter contributions for a column\r\n // -----------------------------------------------\r\n GetMem(Contrib, DstHeight * SizeOf(TCList));\r\n // Vertical sub-sampling\r\n // Scales from bigger to smaller height\r\n if YScale < 1.0 then\r\n begin\r\n Width := AWidth / YScale;\r\n FScale := 1.0 / YScale;\r\n for I := 0 to DstHeight - 1 do\r\n begin\r\n Contrib^[I].N := 0;\r\n GetMem(Contrib^[I].P, Trunc(Width * 2.0 + 1) * SizeOf(TContributor));\r\n Center := I / YScale;\r\n // Original code:\r\n // Left := Ceil(Center - Width);\r\n // Right := Floor(Center + Width);\r\n Left := Floor(Center - Width);\r\n Right := Ceil(Center + Width);\r\n for J := Left to Right do\r\n begin\r\n Weight := Filter((Center - J) / FScale) / FScale;\r\n if Weight = 0.0 then\r\n Continue;\r\n if J < 0 then\r\n N := -J\r\n else\r\n if J >= SrcHeight then\r\n N := SrcHeight - J + SrcHeight - 1\r\n else\r\n N := J;\r\n K := Contrib^[I].N;\r\n Contrib^[I].N := Contrib^[I].N + 1;\r\n Contrib^[I].P^[K].Pixel := N;\r\n Contrib^[I].P^[K].Weight := Weight;\r\n end;\r\n end\r\n end\r\n else\r\n // Vertical super-sampling\r\n // Scales from smaller to bigger height\r\n begin\r\n for I := 0 to DstHeight - 1 do\r\n begin\r\n Contrib^[I].N := 0;\r\n GetMem(Contrib^[I].P, Trunc(AWidth * 2.0 + 1) * SizeOf(TContributor));\r\n Center := I / YScale;\r\n // Original code:\r\n // Left := Ceil(Center - AWidth);\r\n // Right := Floor(Center + AWidth);\r\n Left := Floor(Center - AWidth);\r\n Right := Ceil(Center + AWidth);\r\n for J := Left to Right do\r\n begin\r\n Weight := Filter(Center - J);\r\n if Weight = 0.0 then\r\n Continue;\r\n if J < 0 then\r\n N := -J\r\n else\r\n if J >= SrcHeight then\r\n N := SrcHeight - J + SrcHeight - 1\r\n else\r\n N := J;\r\n K := Contrib^[I].N;\r\n Contrib^[I].N := Contrib^[I].N + 1;\r\n Contrib^[I].P^[K].Pixel := N;\r\n Contrib^[I].P^[K].Weight := Weight;\r\n end;\r\n end;\r\n end;\r\n\r\n // --------------------------------------------------\r\n // Apply filter to sample vertically from Work to Dst\r\n // --------------------------------------------------\r\n SourceLine := Work.ScanLine[0];\r\n Delta := PAnsiChar(Work.ScanLine[1]) - PAnsiChar(SourceLine);\r\n DestLine := Dst.ScanLine[0];\r\n DestDelta := PAnsiChar(Dst.ScanLine[1]) - PAnsiChar(DestLine);\r\n for K := 0 to DstWidth - 1 do\r\n begin\r\n DestPixel := Pointer(DestLine);\r\n for I := 0 to DstHeight - 1 do\r\n begin\r\n Rgb.R := 0;\r\n Rgb.G := 0;\r\n Rgb.B := 0;\r\n // Weight := 0.0;\r\n for J := 0 to Contrib^[I].N - 1 do\r\n begin\r\n Color := PColorRGB(PAnsiChar(SourceLine) + Contrib^[I].P^[J].Pixel * Delta)^;\r\n Weight := Contrib^[I].P^[J].Weight;\r\n if Weight = 0.0 then\r\n Continue;\r\n Rgb.R := Rgb.R + Color.R * Weight;\r\n Rgb.G := Rgb.G + Color.G * Weight;\r\n Rgb.B := Rgb.B + Color.B * Weight;\r\n end;\r\n if Rgb.R > 255.0 then\r\n Color.R := 255\r\n else\r\n if Rgb.R < 0.0 then\r\n Color.R := 0\r\n else\r\n Color.R := Round(Rgb.R);\r\n if Rgb.G > 255.0 then\r\n Color.G := 255\r\n else\r\n if Rgb.G < 0.0 then\r\n Color.G := 0\r\n else\r\n Color.G := Round(Rgb.G);\r\n if Rgb.B > 255.0 then\r\n Color.B := 255\r\n else\r\n if Rgb.B < 0.0 then\r\n Color.B := 0\r\n else\r\n Color.B := Round(Rgb.B);\r\n DestPixel^ := Color;\r\n Inc(PAnsiChar(DestPixel), DestDelta);\r\n end;\r\n Inc(SourceLine, 1);\r\n Inc(DestLine, 1);\r\n end;\r\n\r\n // Free the memory allocated for vertical filter weights\r\n for I := 0 to DstHeight - 1 do\r\n FreeMem(Contrib^[I].P);\r\n\r\n FreeMem(Contrib);\r\n finally\r\n Work.Free;\r\n end;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend." }, { "path": "External/Jedi/Jvcl/run/JvResources.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvResources.PAS, released on 2003-12-10.\r\n\r\nThe Initial Developer of the Original Code is: Robert Marquardt (robert_marquardt att gmx dott de)\r\nCopyright (c) 2003 Robert Marquardt\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nDescription:\r\n unit to centralize all resourcestrings of the JVCL for easier translation\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvResources.pas 13379 2012-07-08 20:33:32Z jfudickar $\r\n\r\nunit JvResources;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\n {$IFDEF UNITVERSIONING}\r\nuses\r\n JclUnitVersioning;\r\n {$ENDIF UNITVERSIONING}\r\n\r\n//=== used in several files ==================================================\r\nresourcestring\r\n RsButtonOKCaption = '&OK';\r\n RsButtonCancelCaption = 'Cancel';\r\n RsBackButtonCaption = '< &Back';\r\n RsPrevButtonCaption = '< &Prev';\r\n RsNextButtonCaption = '&Next >';\r\n RsDateDlgCaption = 'Select a Date';\r\n RsDetailsLeftCaption = '<< &Details';\r\n RsDetailsRightCaption = '&Details >>';\r\n\r\n RsUndoItem = '&Undo';\r\n RsCutItem = 'Cu&t';\r\n RsCopyItem = '&Copy';\r\n RsPasteItem = '&Paste';\r\n RsDeleteItem = '&Delete';\r\n RsSelectAllItem = 'Select &All';\r\n {\r\n SWEDISH:\r\n RsUndoItem = '&ngra';\r\n RsCutItem = '&Klipp ut';\r\n RsCopyItem = 'K&opiera';\r\n RsPasteItem = 'Kl&istra in';\r\n RsDeleteItem = '&Ta bort';\r\n RsSelectAllItem = '&Markera allt';\r\n\r\n GERMAN:\r\n RsUndoItem = '&Rckgngig';\r\n RsCutItem = '&Ausschneiden';\r\n RsCopyItem = '&Kopieren';\r\n RsPasteItem = 'E&infgen';\r\n RsDeleteItem = '&Lschen';\r\n RsSelectAllItem = 'Alles &markieren';\r\n\r\n DUTCH:\r\n RsUndoItem = '&Ongedaan maken';\r\n RsCutItem = 'K&nippen';\r\n RsCopyItem = '&Kopiren';\r\n RsPasteItem = '&Plakken';\r\n RsDeleteItem = '&Wissen';\r\n RsSelectAllItem = '&Alles selecteren';\r\n }\r\n\r\n RsEmptyItem = '';\r\n RsNoName = '(unnamed)';\r\n\r\n RsDatabaseName = 'Database name: %s';\r\n RsDataItemRenderHasNoText = '(item does not support the IJvDataItemText interface)';\r\n RsError = 'Error';\r\n RsFalse = 'False';\r\n RsTrue = 'True';\r\n\r\n RsEErrorSetupDll = 'SetupApi.dll not found';\r\n RsEInternalError = 'internal error';\r\n RsEUnterminatedStringNears = 'unterminated string near %s';\r\n RsEStackOverflow = 'stack overflow';\r\n RsEStackUnderflow = 'stack underflow';\r\n RsEReturnStackUnderflow = 'return stack underflow';\r\n RsENotImplemented = 'not implemented';\r\n RsEDelSubTreeNotImplemented = 'DeleteSubTreeInt has not been implemented yet';\r\n { Polaris patch }\r\n RsEDateOutOfRange = '%0:s - Enter a date between \"%1:s\" and \"%2:s\"';\r\n RsEDateOutOfMin = '%0:s - Enter a date after \"%1:s\"';\r\n RsEDateOutOfMax = '%0:s - Enter a date before \"%1:s\"';\r\n RsEID3NoController = 'No controller specified';\r\n RsEReturnStackOverflow = 'return stack overflow';\r\n RsESorryForOneDimensionalArraysOnly = 'Sorry, for one-dimensional arrays only';\r\n RsELocalDatabase = 'Cannot perform this operation on a local database';\r\n\r\n RsEInterfaceNotSupported = '%0:s does not support the %1:s interface';\r\n RsECircularReference = 'Circular reference not allowed';\r\n\r\n RsESourceBitmapTooSmall = 'Source bitmap too small';\r\n\r\n//=== JvAni.pas ==============================================================\r\nresourcestring\r\n RsAniExtension = 'ani';\r\n RsAniFilterName = 'ANI Image';\r\n RsAniCurFilter = 'Animated Cursors (*.ani)|*.ani|Any files (*.*)|*.*';\r\n\r\n RsEInvalidAnimatedIconImage = 'Invalid animated icon image';\r\n\r\n//=== JvAppDBStorage.pas =====================================================\r\nresourcestring\r\n RsENotSupported = 'Method not supported';\r\n RsEBufTooSmallFmt = 'Buffer too small (%d bytes required)';\r\n\r\n//=== JvAppIniStorage.pas ====================================================\r\nresourcestring\r\n RsEReadValueFailed = 'TJvAppIniFileStorage.ReadValue: Section undefined';\r\n RsEWriteValueFailed = 'TJvAppIniFileStorage.WriteValue: Section undefined';\r\n\r\n//=== JvAppRegistryStorage.pas ===============================================\r\nresourcestring\r\n RsRootValueReplaceFmt =\r\n 'The Default Root Value \"%0:s\" has been replaced with \"%1:s\".' + sLineBreak +\r\n 'Please change the value in the FileVersionInfo Project Properties.';\r\n\r\n RsEUnableToCreateKey = 'Unable to create key ''%s''';\r\n RsEEnumeratingRegistry = 'Error enumerating registry';\r\n\r\n//=== JvAppStorage.pas =======================================================\r\nresourcestring\r\n RsEInvalidType = 'Invalid type';\r\n RsEUnknownBaseType = 'Unknown base type for given set';\r\n RsEInvalidPath = 'Invalid path';\r\n RsENotAUniqueRootPath = '''%s'' is not a unique root path';\r\n RsECircularReferenceOfStorages = 'Circular reference of storages';\r\n RsJvAppStorageSynchronizeTimeout = '%s: Mutex Timeout';\r\n RsJvAppStorageSynchronizeProcedureName = 'TJvCustomAppStorage.Synchronize:';\r\n\r\n//=== JvAppStorageSelectList.pas =============================================\r\nresourcestring\r\n RsLoadSettings = 'Load Settings';\r\n RsSaveSettings = 'Save Settings';\r\n RsDeleteSettings = 'Delete Settings';\r\n RsLoadCaption = '&Load';\r\n RsSaveCaption = '&Save';\r\n RsDeleteCaption = '&Delete';\r\n\r\n RsEDynControlEngineNotDefined = 'TJvAppStorageSelectList.CreateDialog: DynControlEngine not defined!';\r\n RsEDynAppStorageNotDefined = 'TJvAppStorageSelectList.GetSelectListPath: No AppStorage assigned';\r\n\r\n//=== JvAppXMLStorage.pas ====================================================\r\nresourcestring\r\n RsENodeCannotBeEmpty = 'The node must be given a name';\r\n RsEPathDoesntExists = 'Path ''%s'' does not exists';\r\n RsENotABooleanValue = '''%s'' is not a valid boolean value';\r\n RsENodeNameCannotContainSpaces =\r\n 'XML Node names cannot contain white space and the WhiteSpaceReplacement property is empty. Please set the WhiteSpaceReplacementProperty to a non empty value.';\r\n RsEWhiteSpaceReplacementCannotContainSpaces =\r\n 'The WhiteSpaceReplacement property cannot contain any white spaces.';\r\n RsENodeNameCannotInvalidChars =\r\n 'XML Node names cannot contain invalid chars (\"%s\") and the InvalidCharReplacement property is empty. Please set the InvalidCharReplacement to a non empty value.';\r\n RsENotAllowedCharacterForProperty = '\"%0:s\" is not an allowed character for the %1:s property.';\r\n\r\n//=== JvAVICapture.pas =======================================================\r\nresourcestring\r\n RsNotConnected = 'Not connected';\r\n RsErrorMessagePrefix = 'Error #';\r\n\r\n RsEInvalidDriverIndex =\r\n '%0:d is an invalid driver index. The maximum value is %1:d' + sLineBreak +\r\n 'This may also happen if the device could not be initialized properly.';\r\n\r\n//=== JvBackgrounds.pas ======================================================\r\nresourcestring\r\n SChainError =\r\n 'Message from %0:s.%1:s:' + sLineBreak + sLineBreak +\r\n 'Oops... Messing up %2:s''s window procedure chain.%3:s';\r\n SWorkaround = sLineBreak + sLineBreak +\r\n 'To avoid this, $DEFINE the NO_DESIGNHOOK conditional compilation symbol and rebuild.';\r\n\r\n//=== JvBalloonHint.pas ======================================================\r\nresourcestring\r\n RsEParentRequired = 'Control ''%s'' has no parent window';\r\n RsEParentGivenNotAParent = 'Parent given is not a parent of ''%s''';\r\n\r\n//=== JvBaseEdits.pas ========================================================\r\nresourcestring\r\n RsEOutOfRangeXFloat = 'Value must be between %.*f and %.*f';\r\n\r\n//=== JvBDECheckPasswordForm.pas+JvBaseDBPasswordDialog ======================\r\nresourcestring\r\n RsChangePassword = 'Change password';\r\n RsOldPasswordLabel = '&Old password:';\r\n RsNewPasswordLabel = '&New password:';\r\n RsConfirmPasswordLabel = '&Confirm password:';\r\n RsPasswordChanged = 'Password has been changed';\r\n RsPasswordNotChanged = 'Password has not been changed';\r\n RsPasswordsMismatch = 'The new and confirmed passwords do not match';\r\n\r\n//=== JvBaseDBPasswordDialog.pas ============================================\r\nresourcestring\r\n RsOldPasswordsMismatch = 'The current and old passwords do not match';\r\n RsChangeButtonCaption = 'Change';\r\n RsPasswordLengthToShort = 'Password length must be greater or equal %d';\r\n RsPasswordNotAllowedCharacters = 'Password contains not allowed characters';\r\n\r\n//=== JvDBLogonDialogDoa.pas + JvDBLogonDialogOdac.pas ======================\r\nresourcestring\r\n RsDoYouWantToChangePassword = 'Do you want to change the password?';\r\n\r\n//=== JvBaseDBLogonDialog.pas ===============================================\r\nresourcestring\r\n RsLogonToDatabase = 'Logon to Database';\r\n RsBtnConnect = 'Connect';\r\n RsBtnAdditional = 'Additional';\r\n RsBtnHintAddDefinitionToList = 'Add Definition to List';\r\n RsBtnHintSelectDefinitionFromList = 'Select Definition from List';\r\n RsBtnHintDeleteDefinitionFromList = 'Delete Definition from List';\r\n RsPageByUser = 'By User';\r\n RsPageByDatabase = 'By Database';\r\n RsPageByGroup = 'By Group';\r\n RsPageDefaultList = 'Default List';\r\n RsUsername = '&Username';\r\n RsPassword = '&Password';\r\n RsDatabase = '&Database';\r\n RsAlias= 'Al&ias';\r\n RsShortcut = '&Shortcut';\r\n RsConnectGroup = '&Connect Group';\r\n RsConnectAs = 'Connect-&As';\r\n\r\n RsImportConnectionList = 'Import Connection List';\r\n RsExportConnectionList = 'Export Connection List';\r\n RsConnectionListImportOverwrite = 'Overwrite';\r\n RsConnectionListImportAppend = 'Append';\r\n RsConnectionListImportAppendOverwriteExistingEntries = 'Append/Overwrite existing entries?';\r\n RsNoConnectionEntriesFound = 'No Connection Entries found!';\r\n RsConnectionListExportImportFilter = 'XML-Files (*.xml)|*.xml|INI-Files (*.ini)|*.ini|All Files (*.*)|*.*';\r\n RsConnectionListItemName = 'Connection';\r\n RsGroupNameUndefined = 'Undefined';\r\n RsCheckboxSavePasswords = '&Save Passwords';\r\n RsCheckBoxGroupByUser = 'Group By User';\r\n RsCheckBoxGroupByDatabase = 'Group By Database';\r\n\r\n//=== JvDBLogonDialogOdac.pas ===============================================\r\nresourcestring\r\n RsOracleHome = 'Oracle Home';\r\n RsUseNetOptionForDirectConnect = 'Use Net-Option for direct connect';\r\n RsNetOptionCheckBoxHint =\r\n 'If this option is activated the connecting passed sql*net'#13#10+\r\n 'and tries to connect to the server direct via tcpip.'#13#10+\r\n 'The database name must contain Server name, Oracle service name,'#13#10+\r\n 'and port in the following format:'#13#10+\r\n ' Host:Port:SID'#13#10+\r\n ' Where'#13#10+\r\n ' Host is the address of server;'#13#10+\r\n ' Port is the number of port that server listens to;'#13#10+\r\n ' SID is system identifier that specifies Global Database Name.';\r\n RsNetOptionConnectionList = 'NET Option';\r\n\r\n//=== JvDBLogonDialogUnidac.pas ===============================================\r\nresourcestring\r\n RsServer= 'Ser&ver';\r\n RsPort= 'Port';\r\n RsProvider='&Provider';\r\n RsDirectConnect='&Direct Connect';\r\n\r\n//=== JvBDEExceptionForm.pas =================================================\r\nresourcestring\r\n RsDBExceptCaption = 'Database Engine Error';\r\n RsBDEErrorLabel = 'BDE Error';\r\n RsServerErrorLabel = 'Server Error';\r\n RsErrorMsgLabel = 'Error message';\r\n\r\n//=== JvBDEFilter.pas ========================================================\r\nresourcestring\r\n RsECaptureFilter = 'Cannot perform this operation when controls are captured';\r\n RsENotCaptureFilter = 'Cannot perform this operation when controls are not captured';\r\n\r\n//=== JvBDELoginDialog.pas ===================================================\r\nresourcestring\r\n RsEInvalidUserName = 'Invalid user name or password';\r\n RsLastLoginUserName = 'Last Login User'; // Also used by JvLoginForm\r\n RsSelectDatabase = 'SelectDatabase'; { dialog never writes this value }\r\n RsLastAliasName = 'LastAlias'; { used if SelectDatabase = True }\r\n\r\n//=== JvBDEMove.pas ==========================================================\r\nresourcestring\r\n RsEInvalidReferenceDescriptor = 'Invalid reference descriptor';\r\n\r\n//=== JvBdeUtils.pas =========================================================\r\nresourcestring\r\n RsRetryLogin = 'Do you wish to retry the connect to database?';\r\n\r\n RsETableNotInExclusiveMode = 'Table must be opened in exclusive mode to add passwords';\r\n RsETableNotOpen = 'Table must be opened to pack';\r\n RsETableNotOpenExclusively = 'Table must be opened exclusively to pack';\r\n RsENoParadoxDBaseTable = 'Table must be either of Paradox or dBASE type to pack';\r\n\r\n//=== JvBehaviorLabel.pas ====================================================\r\nresourcestring\r\n RsENeedBehaviorLabel = 'Cannot call %s.Create with ALabel = nil';\r\n RsENoOwnerLabelParent = 'OwnerLabel.Parent is nil in %s.Start';\r\n\r\n//=== JvBevel.pas ============================================================\r\nresourcestring\r\n RsEGradientDeprecated = 'Gradient is no longer available, use a TJvGradient component instead';\r\n\r\n//=== JvBrowseFolder.pas =====================================================\r\nresourcestring\r\n RsEShellNotCompatible = 'Shell not compatible with BrowseForFolder';\r\n\r\n//=== JvButtons.pas ==========================================================\r\nresourcestring\r\n RsEOwnerMustBeForm = '%s owner must be a TForm';\r\n\r\n//=== JvCalc.pas =============================================================\r\nresourcestring\r\n RsCalculatorCaption = 'Calculator';\r\n\r\n//=== JvCalendar.pas =========================================================\r\nresourcestring\r\n RsEInvalidDateStr = 'Invalid date specification to TMonthCalStrings (%s)';\r\n RsECannotAssign = 'Cannot assign %0:s to a %1:s';\r\n RsEInvalidArgumentToSetDayStates = 'Invalid argument to SetDayStates';\r\n RsEInvalidAppearance = 'TJvCustomMonthCalendar.CreateWithAppearance: cannot be created without valid Appearance';\r\n\r\n//=== JvCaptionButton.pas ====================================================\r\nresourcestring\r\n RsEOwnerMustBeTCustomForm = 'TJvCaptionButton owner must be a TCustomForm';\r\n\r\n//=== JvCaret.pas ============================================================\r\nresourcestring\r\n RsEInvalidCaretOwner = '%s: cannot be created without a valid Owner';\r\n\r\n//=== JvChangeNotify.pas =====================================================\r\nresourcestring\r\n RsFileNameChange = 'Filename Change';\r\n RsDirectoryNameChange = 'Directory Name Change';\r\n RsAttributesChange = 'Attributes Change';\r\n RsSizeChange = 'Size Change';\r\n RsWriteChange = 'Write Change';\r\n RsSecurityChange = 'Security Change';\r\n\r\n RsEFmtCannotChangeName = 'Cannot change %s when active';\r\n RsEFmtInvalidPath = 'Invalid or empty path (%s)';\r\n RsEFmtMaxCountExceeded = 'Maximum of %d items exceeded';\r\n RsEFmtInvalidPathAtIndex = 'Invalid or empty path (\"%0:s\") at index %1:d';\r\n RsENotifyErrorFmt = '%0:s:' + sLineBreak + '%1:s';\r\n\r\n//=== JvChart.pas ============================================================\r\nresourcestring\r\n RsChartDesigntimeLabel = ': JEDI JVCL Charting Component';\r\n RsNoData = 'No data. (Data.ValueCount=0)';\r\n RsGraphHeader = 'Graph Header';\r\n RsCurrentHeaders = 'Current Header: %s';\r\n RsXAxisHeaders = 'X Axis Header: %s';\r\n RsGraphScale = 'Graph Scale';\r\n RsYAxisScales = 'Y Axis Scale: %s';\r\n RsNoValuesHere = 'No values here!';\r\n RsNA = ' n/a ';\r\n\r\n RsEDataIndexCannotBeNegative = 'Data: index cannot be negative';\r\n RsEPenIndexInvalid = 'Data: pen index invalid/out of range.';\r\n RsEDataIndexTooLargeProbablyAnInternal = 'Data: index too large. Probably an internal error';\r\n RsEGetAverageValueIndexNegative = 'GetAverageValue: Index negative';\r\n RsESetAverageValueIndexNegative = 'SetAverageValue: Index negative';\r\n RsEChartOptionsPenCountPenCountOutOf = 'JvChart.Options.PenCount - PenCount out of range';\r\n RsEChartOptionsXStartOffsetValueOutO = 'JvChart.Options.XStartOffset - value out of range';\r\n RsEUnableToGetCanvas = 'Unable to get canvas';\r\n\r\n//=== JvCheckedMaskEdit.pas ==================================================\r\nresourcestring\r\n RsEBeginUnsupportedNestedCall = 'TJvCustomCheckedMaskEdit.BeginInternalChange: Unsupported nested call!';\r\n RsEEndUnsupportedNestedCall = 'TJvCustomCheckedMaskEdit.EndInternalChange: Unsupported nested call!';\r\n\r\n//=== JvClipboardViewer.pas ==================================================\r\n RsClipboardUnknown = 'Cannot display. Data in Clipboard is in an unknown format.';\r\n RsClipboardEmpty = 'Clipboard is empty';\r\n\r\n//=== JvClipbrd.pas ==========================================================\r\nresourcestring\r\n RsENoRenderFormatEventGiven = 'No OnRenderFormat was given';\r\n\r\n//=== JvColorButton.pas ======================================================\r\nresourcestring\r\n RsOtherCaption = '&Other...';\r\n\r\n//=== JvColorCombo.pas =======================================================\r\nresourcestring\r\n RsCustomCaption = 'Custom...';\r\n RsNewColorPrefix = 'Custom';\r\n\r\n//=== JvColorProvider.pas ====================================================\r\nresourcestring\r\n RsDelphiConstantNames = 'Delphi constant names';\r\n RsEnglishNames = 'English names';\r\n RsCustomColors = 'Custom colors';\r\n RsStandardColors = 'Standard colors';\r\n RsSystemColors = 'System colors';\r\n RsNoSettings = '(no settings)';\r\n\r\n RsESpecifiedMappingError = 'Specified mapping does not belong to the current provider';\r\n RsEAlreadyRegistered = '''%s'' is already registered';\r\n RsENoICR = 'Component does not support IInterfaceComponentReference';\r\n RsENoColProv = 'Component does not support IJvColorProvider';\r\n RsEMappingCollectionExpected = 'Mapping collection expected';\r\n RsEExpectedMappingName = 'Expected mapping name';\r\n RsEExpectedNameMappings = 'Expected name mappings';\r\n RsEInvalidNameMappingSpecification = 'Invalid name mapping specification';\r\n RsEUnknownColor = 'Unknown color ''%s''';\r\n RsEInvalidColor = 'Invalid color (%d)';\r\n RsEItemNotForList = 'Item does not belong to this list';\r\n\r\n//=== JvCombobox.pas =========================================================\r\nresourcestring\r\n RsCapSelAll = '&Select all';\r\n RsCapDeselAll = '&Deselect all';\r\n RsCapInvertAll = '&Invert all';\r\n RsENoMoreLength = 'Too many items selected';\r\n\r\n//=== JvComputerInfoEx.pas ===================================================\r\nresourcestring\r\n RsEReadOnlyProperty = 'This value is read-only and cannot be changed.';\r\n RsFileTypeString = '%s file';\r\n RsAttrArchiveShortString = 'A';\r\n RsAttrCompressedShortString = 'C';\r\n RsAttrDirectoryShortString = 'D';\r\n RsAttrReadOnlyShortString = 'R';\r\n RsAttrHiddenShortString = 'H';\r\n RsAttrSystemShortString = 'S';\r\n\r\n//=== JvContextProvider.pas ==================================================\r\nresourcestring\r\n RsContextItemEmptyCaption = '(no context assigned to this item)';\r\n RsENoContextAssigned = 'No context has been assigned to this item';\r\n\r\n RsENoContextItem = 'Specified item is not a context item';\r\n RsENotSupportedIInterfaceComponentReference = 'Component does not support IInterfaceComponentReference';\r\n RsENotSupportedIJvDataProvider = 'Component does not support IJvDataProvider';\r\n\r\n//=== JvCreateProcess.pas ====================================================\r\nresourcestring\r\n RsIdle = 'Idle';\r\n RsNormal = 'Normal';\r\n RsHigh = 'High';\r\n RsRealTime = 'RealTime';\r\n RsBelowNormal = 'Below normal';\r\n RsAboveNormal = 'Above normal';\r\n\r\n RsEProcessIsRunning = 'Cannot perform this operation when process is running';\r\n RsEProcessNotRunning = 'Process is not running';\r\n\r\n//=== JvCSVBaseControls.pas ==================================================\r\nresourcestring\r\n RsReplaceExistingDatabase = 'Replace existing database?';\r\n RsCVSDatabase = 'CSV Database';\r\n RsFindText = 'Find Text:';\r\n RsFirstHint = 'First';\r\n RsPreviousHint = 'Previous';\r\n RsFindHint = 'Find';\r\n RsNextHint = 'Next';\r\n RsLastHint = 'Last';\r\n RsAddHint = 'Add';\r\n RsDeleteHint = 'Delete';\r\n RsPostHint = 'Post';\r\n RsRefreshHint = 'Refresh';\r\n RsENoFieldsDefined = 'No fields defined';\r\n\r\n//=== JvCsvData.pas ==========================================================\r\nresourcestring\r\n RsErrorRowItem = '';\r\n RsECsvErrFormat = '%0:s: %1:s';\r\n RsECsvErrFormat2 = '%0:s: %1:s (%2:d)';\r\n RsECsvInvalidSeparatorFmt = 'Invalid separator character (%s)';\r\n RsEProblemReadingRow = 'Problem reading row %d';\r\n RsENoRecord = 'No records';\r\n RsENoFieldNamesMatch = 'No field names match in these datasets. CopyFromDataset failed.';\r\n RsETimeTConvError = 'SetFieldData Error - TimeT-to-DateTime conversion error';\r\n RsEFieldTypeNotHandled = 'SetFieldData Error - Field type not handled';\r\n RsEUnableToLocateCSVFileInfo = 'Unable to locate CSV file information for field %s';\r\n RsEPhysicalLocationOfCSVField = 'Physical location of CSV field %s unknown';\r\n RsEInvalidFieldTypeCharacter = 'Invalid field type character: %s';\r\n RsECsvNoRecord = 'No database record';\r\n RsEUnexpectedError = 'Unexpected error parsing CSV Field Definitions';\r\n RsEFieldDefinitionError = 'Field Definition Error. CsvFieldDef, FieldDefs, and file contents must match';\r\n RsEInvalidCsvKeyDef = 'Invalid CsvKeyDef property. InternalInitFieldDefs failed';\r\n RsEInternalErrorParsingCsvKeyDef = 'Internal Error parsing CsvKeyDef. InternalInitFieldDefs failed';\r\n RsEContainsField = 'CsvKeyDef contains field ''%s'' which is not defined. InternalInitFieldDefs failed';\r\n RsEInsertBlocked = 'InternalAddRecord cannot Add. Insert blocked';\r\n RsEPostingHasBeenBlocked = 'Posting to this database has been blocked';\r\n RsEKeyNotUnique = '%s - Key is not unique ';\r\n RsECannotInsertNewRow = 'Cannot insert new row. Insert blocked';\r\n RsECannotPost = 'Cannot post. Not in dsEdit or dsInsert mode';\r\n RsESortFailedCommaSeparated = 'Sort failed. You must give a comma separated list of field names';\r\n RsESortFailedFieldNames = 'Sort failed. Unable to parse field names. ';\r\n RsESortFailedInvalidFieldNameInList = 'Sort failed. Invalid field name in list: %s';\r\n RsEDataSetNotOpen = 'AppendRowString: DataSet is not open (active not set to true)';\r\n RsEErrorProcessingFirstLine = 'Error processing first line of CSV file';\r\n RsEFieldInFileButNotInDefinition = 'ProcessCsvHeaderRow: Field %s found in file, but not in field definitions';\r\n RsECsvFieldLocationError = 'CSV field location error: %s';\r\n RsEFieldNotFound = 'Field %s not found in the data file';\r\n RsECsvStringTooLong = 'CSV string is too long: %s...';\r\n RsECannotReadCsvFile = 'Can''t read CSV file %s';\r\n RsEInternalLimit = 'JvCsvData - Internal Limit of MAXCOLUMNS (%d) reached. CSV Data has too many columns';\r\n RsETableNameNotSet = 'TableName not specified';\r\n RsEGetMode = 'Invalid option to GetMode';\r\n RsENoTableName = 'TableName not specified';\r\n RsETableNameRequired = 'LoadFromFile = True, so a TableName is required';\r\n RsEInternalCompare = 'InternalCompare. Nil value detected';\r\n RsEInvalidTableName = 'TJvCustomCsvDataSet.GetFileName - TableName property is not set';\r\n\r\n//=== JvCsvParse.pas =========================================================\r\nresourcestring\r\n RsEInvalidHexLiteral = 'HexStrToInt: Invalid hex literal';\r\n\r\n//=== JvCursor.pas ===========================================================\r\nresourcestring\r\n RsCurExtension = 'cur';\r\n RsCurDescription = 'Cursor files';\r\n RsCursor = 'Cursor';\r\n\r\n RsECursorLoadFromStream = 'LoadFromStream not supported';\r\n RsECursorSaveToStream = 'SaveToStream not supported';\r\n\r\n//=== JvDataProvider.pas =====================================================\r\nresourcestring\r\n RsEItemsMayNotBeMovedInTheMainTree = 'Items may not be moved in the main tree';\r\n RsEInvalidIndex = 'Invalid index';\r\n RsEItemCanNotBeDeleted = 'Item cannot be deleted';\r\n RsEContextNameExpected = 'Context name expected';\r\n RsEConsumerStackIsEmpty = 'Consumer stack is empty';\r\n RsEContextStackIsEmpty = 'Context stack is empty';\r\n RsEAContextWithThatNameAlreadyExists = 'A context with that name already exists';\r\n RsECannotCreateAContextWithoutAContext = 'Cannot create a context without a context list owner';\r\n RsEComponentDoesNotSupportTheIJvDataPr = 'Component does not support the IJvDataProvider interface';\r\n RsEComponentDoesNotSupportTheIInterfac = 'Component does not support the IInterfaceComponentReference interface';\r\n RsEYouMustSpecifyAProviderBeforeSettin = 'You must specify a provider before setting the context';\r\n RsEProviderHasNoContextNameds = 'Provider has no context named \"%s\"';\r\n RsEProviderDoesNotSupportContexts = 'Provider does not support contexts';\r\n RsETheSpecifiedContextIsNotPartOfTheSa = 'The specified context is not part of the same provider';\r\n RsEYouMustSpecifyAProviderBeforeSettin_ = 'You must specify a provider before setting the item';\r\n RsEItemNotFoundInTheSelectedContext = 'Item not found in the selected context';\r\n RsEViewListOutOfSync = 'ViewList out of sync';\r\n\r\n RsEProviderIsNoIJvDataConsumer = 'Provider property of ''%s'' does not point to a IJvDataConsumer';\r\n RsEComponentIsNotDataConsumer = 'Component ''%s'' is not a data consumer';\r\n RsECannotAddNil = 'Cannot add a nil pointer';\r\n RsEConsumerNoSupportIJvDataConsumerClientNotify =\r\n 'Consumer does not support the ''IJvDataConsumerClientNotify'' interface';\r\n RsENotifierNoSupprtIJvDataConsumer = 'Notifier does not support the ''IJvDataConsumer'' interface';\r\n\r\n RsEExtensibleIntObjDuplicateClass = 'Implementation of that class already exists';\r\n RsEExtensibleIntObjCollectionExpected = 'Expected collection';\r\n RsEExtensibleIntObjClassNameExpected = 'Missing ClassName property';\r\n RsEExtensibleIntObjInvalidClass = 'Invalid class type';\r\n RsEDataProviderNeedsItemsImpl = 'Cannot create a data provider without an IJvDataItems implementation';\r\n\r\n//=== JvDatePickerEdit.pas ===================================================\r\nresourcestring\r\n RsDefaultNoDateShortcut = 'Alt+Del';\r\n\r\n RsEMustHaveADate = '%s must have a date!';\r\n\r\n//=== JvDateTimePicker.pas ===================================================\r\nresourcestring\r\n RsNoneCaption = '(none)';\r\n\r\n//=== JvDBActions.pas, JvDynControlEngineDBTools.pas =========================\r\nresourcestring\r\n RsDBPosDialogCaption = 'Change Current Record Position';\r\n RsDBPosCurrentPosition = 'Current Position';\r\n RsDBPosNewPosition = 'New Position';\r\n RsDBPosMovementType = 'Movement Type';\r\n RsDBPosAbsolute = 'Absolute';\r\n RsDBPosBackward = 'Backward';\r\n RsDBPosForward = 'Forward';\r\n RsDBPosPercental = 'Percental';\r\n RsSRWPostButtonCaption = '&Post';\r\n RsSRWCancelButtonCaption = '&Cancel';\r\n RsSRWCloseButtonCaption = 'C&lose';\r\n\r\n//=== JvDBActions.pas, =======================================================\r\nresourcestring\r\n SModifyAllOkButton = 'Modify';\r\n SModifyAllCaption = 'Modify All Records';\r\n SModifyAllModifyField = 'Modify Field';\r\n SModifyAllOnlyIfNull = 'Only If Null';\r\n SModifyAllChangeTo = 'Change To';\r\n SModifyAllClearFieldValues = 'Clear Field Values';\r\n SShowSQLStatementCaption = 'Show Current SQL Statement';\r\n SSQLStatementClipboardButton = '&Clipboard';\r\n SSQLStatementWordWrapped = '&Word Wrapped';\r\n\r\n\r\n//=== JvDBControls.pas =======================================================\r\nresourcestring\r\n RsInactiveData = 'Closed';\r\n RsBrowseData = 'Browse';\r\n RsEditData = 'Edit';\r\n RsInsertData = 'Insert';\r\n RsSetKeyData = 'Search';\r\n RsCalcFieldsData = 'Calculate';\r\n\r\n//=== JvDBGrid.pas ===========================================================\r\nresourcestring\r\n RsJvDBGridSelectTitle = 'Select columns';\r\n //RsJvDBGridSelectOption = '[With the real field name]';\r\n RsJvDBGridSelectWarning = 'At least one column must be visible!';\r\n RsEJvDBGridControlPropertyNotAssigned = 'JvDBGrid.EditControls: property Control not assigned';\r\n\r\n//=== JvDBUltimGrid.pas ======================================================\r\nresourcestring\r\n RsEJvDBGridBadFieldKind = 'Cannot sort a binary or special field';\r\n RsEJvDBGridIndexPropertyMissing = 'Cannot sort. An index property is missing';\r\n RsEJvDBGridIndexMissing = 'Cannot sort. The corresponding index is missing';\r\n RsEJvDBGridUserSortNotAssigned = 'Cannot sort. OnUserSort is not assigned';\r\n\r\n//=== JvDBGridExport.pas =====================================================\r\nresourcestring\r\n RsHTMLExportDocTitle = 'Grid to HTML Export';\r\n RsExportWord = 'Exporting to MS Word...';\r\n RsExportExcel = 'Exporting to MS Excel...';\r\n RsExportHTML = 'Exporting to HTML...';\r\n RsExportFile = 'Exporting to CSV/Text...';\r\n RsExportClipboard = 'Exporting to Clipboard...';\r\n RsEDataSetDataSourceIsUnassigned = 'Dataset or DataSource unassigned';\r\n RsEGridIsUnassigned = 'No grid assigned';\r\n\r\n//=== JvDBLookup.pas =========================================================\r\nresourcestring\r\n RsEInvalidFormatNotAllowed = 'Invalid format: % not allowed';\r\n RsEInvalidFormatsNotAllowed = 'Invalid format: %s not allowed';\r\n\r\n//=== JvDBQueryParamsForm.pas ================================================\r\nresourcestring\r\n // (p3) copied from bdeconst so we don't have to include the entire BDE for three strings...\r\n RsDataTypes =\r\n ';String;SmallInt;Integer;Word;Boolean;Float;Currency;BCD;Date;Time;DateTime;;;;Blob;Memo;Graphic;;;;;Cursor;';\r\n RsParamEditor = '%0:s%1:s%2:s Parameters';\r\n\r\n RsEInvalidParamFieldType = 'Must have a valid field type selected';\r\n\r\n//=== JvDBTreeView.pas =======================================================\r\nresourcestring\r\n RsDeleteNode = 'Delete %s ?';\r\n RsDeleteNode2 = 'Delete %s (with all children) ?';\r\n RsMasterFieldError = '\"MasterField\" must be integer type';\r\n RsDetailFieldError = '\"DetailField\" must be integer type';\r\n RsItemFieldError = '\"ItemField\" must be string, date or integer type';\r\n RsIconFieldError = '\"IconField\" must be integer type';\r\n RsMasterFieldEmpty = '\"MasterField\" property must be filled';\r\n RsDetailFieldEmpty = '\"DetailField\" property must be filled';\r\n RsItemFieldEmpty = '\"ItemField\" property must be filled';\r\n\r\n RsEMoveToModeError = 'Invalid move mode for JvDBTreeNode';\r\n RsMasterDetailFieldError = '\"MasterField\" and \"DetailField\" must be of same type';\r\n RsEDataSetNotActive = 'DataSet not active';\r\n RsEErrorValueForDetailValue = 'error value for DetailValue';\r\n\r\n//=== JvDBUtils.pas ==========================================================\r\nresourcestring\r\n RsConfirmSave = 'The data has changed. Save it?';\r\n\r\n//=== JvDdeCmd.pas ===========================================================\r\nresourcestring\r\n RsEErrorCommandStart = 'Invalid command start format';\r\n RsEErrorCommandFormat = 'Invalid command format: %s';\r\n\r\n//=== JvDesignImp.pas ========================================================\r\nresourcestring\r\n RsEDesignCannotSelect = 'Cannot add a nil selection.';\r\n RsEOldestFmt = '%0:s: Oldest ancestor of Container must be a form.';\r\n\r\n//=== JvDesignSurface.pas ====================================================\r\nresourcestring\r\n RsEDesignNilFmt = '%0:s: %1:s is nil';\r\n\r\n//=== JvDesktopAlertForm.pas =================================================\r\nresourcestring\r\n RsClose = 'Close';\r\n\r\n//=== JvDrawImage.pas ========================================================\r\nresourcestring\r\n RsImageMustBeSquare = 'image must be square for Spirographs';\r\n RsSumOfRadiTolarge = 'sum of radi too large';\r\n RsBothRadiMustBeGr = 'both radi must be >%d';\r\n\r\n//=== JvDropDownForm.pas =====================================================\r\nresourcestring\r\n RsETJvCustomDropDownFormCreateOwnerMus = 'TJvCustomDropDownForm.Create: Owner must be a TCustomEdit';\r\n\r\n//=== JvDSADialogs.pas =======================================================\r\nresourcestring\r\n RsInTheCurrentQueue = 'in the current queue';\r\n\r\n RsDSActkShowText = 'Do not show this dialog again';\r\n RsDSActkAskText = 'Do not ask me again';\r\n RsDSActkWarnText = 'Do not warn me again';\r\n\r\n RsCntdownText = 'This dialog is closing in %s.';\r\n\r\n RsCntdownMinText = 'minute';\r\n RsCntdownMinsText = 'minutes';\r\n RsCntdownSecText = 'second';\r\n RsCntdownSecsText = 'seconds';\r\n\r\n RsECannotEndCustomReadIfNotInCustomRea = 'Cannot end custom read if not in custom read mode';\r\n RsECannotEndCustomWriteIfNotInCustomWr = 'Cannot end custom write if not in custom write mode';\r\n RsECannotEndReadIfNotInReadMode = 'Cannot end read if not in read mode';\r\n RsECannotEndWriteIfNotInWriteMode = 'Cannot end write if not in write mode';\r\n RsEJvDSADialogPatchErrorJvDSADialogCom = 'JvDSADialog patch error: JvDSADialog component not found';\r\n\r\n RsEDSARegKeyCreateError = 'Unable to create key %s';\r\n RsEDSADuplicateID = 'DSA dialog with ID ''%d'' is already assigned to another dialog name';\r\n RsEDSADuplicateName = 'DSA dialog named ''%s'' is already assigned to another dialog ID';\r\n RsEDSADialogIDNotFound = 'DSA dialog %d does not exist';\r\n RsEDSADuplicateCTK_ID = 'CheckMarkText ID %d already registered';\r\n RsEDSADialogIDNotStored = 'DSA dialog %d has not been stored';\r\n RsEDSAKeyNotFound = 'Key %s does not exist';\r\n RsEDSAKeyNoAccessAs = 'Key %0:s cannot be accessed as %1:s';\r\n\r\n RsECtrlHasNoCheckedProp = 'The specified control has no \"Checked\" property';\r\n RsECtrlHasNoCaptionProp = 'The specified control has no \"Caption\" property';\r\n RsEDialogIDChangeOnlyInDesign = 'The dialog ID can only be changed at design time';\r\n RsEOnlyAllowedOnForms = 'TJvDSADialog is only allowed on forms';\r\n RsEAlreadyDSADialog = 'The form already has a TJvDSADialog component';\r\n\r\n RsEDSAAccessBool = 'Boolean';\r\n RsEDSAAccessFloat = 'Float';\r\n RsEDSAAccessInt64 = 'Int64';\r\n RsEDSAAccessInt = 'Integer';\r\n RsEDSAAccessString = 'string';\r\n\r\n//=== JvDualList.pas =========================================================\r\nresourcestring\r\n RsDualListSrcCaption = '&Source';\r\n RsDualListDestCaption = '&Destination';\r\n\r\n//=== JvDynControlEngine.pas =================================================\r\nresourcestring\r\n RsEIntfCastError = 'component does not support interface';\r\n RsEUnsupportedControlClass = 'TJvDynControlEngine.RegisterControl: Unsupported ControlClass \"%s\"';\r\n RsENoRegisteredControlClass = 'TJvDynControlEngine.CreateControl: No Registered ControlClass \"%s\"';\r\n RsENoFocusControl = 'TJvDynControlEngine.CreateLabelControlPanel: AFocusControl must be assigned';\r\n\r\n//=== JvDynControlEngineDB.pas ===============================================\r\nresourcestring\r\n RsEUnassignedField = 'TJvDynControlEngineDB.GetFieldControlType: AField must be assigned';\r\n RsEUnassignedMultiple = 'TJvDynControlEngineDB.CreateControlsFromDatasourceOnControl: ADataSource, ADataSource.Dataset and AControl must be assigned';\r\n RsEUnassignedDataSet = 'TJvDynControlEngineDB.CreateControlsFromDatasourceOnControl: ADataSource.Dataset must be active';\r\n\r\n//=== JvEDIDBBuffering.pas ===================================================\r\nresourcestring\r\n RsENoProfileDatasets = 'Not all profile datasets have been assigned.';\r\n\r\n//=== JvEditor.pas, JvUnicodeEditor.pas ======================================\r\nresourcestring\r\n RsERedoNotYetImplemented = 'Redo not yet implemented';\r\n RsEInvalidCompletionMode = 'Invalid JvEditor Completion Mode';\r\n\r\n//=== JvEmbeddedForms.pas ====================================================\r\nresourcestring\r\n RsEFormLinkSingleInstanceOnly = 'You only need one form link per form.';\r\n RsELinkCircularRef = 'Circular references not allowed.';\r\n\r\n//=== JvErrorIndicator.pas ===================================================\r\nresourcestring\r\n RsEControlNotFoundInGetError = 'Control not found in GetError';\r\n RsEControlNotFoundInGetImageAlignment = 'Control not found in GetImageAlignment';\r\n RsEControlNotFoundInGetImagePadding = 'Control not found in GetImagePadding';\r\n RsEUnableToAddControlInSetError = 'Unable to add control in SetError';\r\n RsEUnableToAddControlInSetImageAlignme = 'Unable to add control in SetImageAlignment';\r\n RsEUnableToAddControlInSetImagePadding = 'Unable to add control in SetImagePadding';\r\n\r\n//=== JvExceptionForm.pas ====================================================\r\nresourcestring\r\n RsCodeError = '%0:s.' + sLineBreak + 'Error Code: %1:.8x (%1:d).';\r\n RsModuleError = 'Exception in module %0:s.' + sLineBreak + '%1:s';\r\n\r\n//=== JvFindReplace.pas ======================================================\r\nresourcestring\r\n RsNotFound = 'Search string ''%s'' not found';\r\n RsXOccurencesReplaced = '%0:d occurence(s) of ''%1:s'' were replaced';\r\n RsReplaceCaption = 'Replace';\r\n RsFindCaption = 'Find';\r\n\r\n RsENoEditAssigned = 'No edit control assigned!';\r\n\r\n//=== JvFooter.pas ===========================================================\r\nresourcestring\r\n RsETJvFooterBtnCanOnlyBePlacedOnATJvFo = 'TJvFooterBtn can only be placed on a TJvFooter';\r\n\r\n//=== JvForth.pas ============================================================\r\nresourcestring\r\n RsEInvalidNumbers = 'invalid number %s';\r\n RsEUnrecognizedDataTypeInSetOperation = 'unrecognized data type in set operation';\r\n RsEUnterminatedBlockNear = 'unterminated block near ';\r\n RsEParserTimedOutAfterdSecondsYouMayHa = 'parser timed out after %d seconds; you may have circular includes';\r\n RsEUnterminatedIncludeNears = 'unterminated include near %s';\r\n RsEIllegalSpaceCharacterInTheIncludeFi = 'illegal space character in the include file: %s';\r\n RsECanNotFindIncludeFiles = 'Can not find include file: %s';\r\n RsEOnIncludeHandlerNotAssignedCanNotHa = 'OnInclude handler not assigned, can not handle include file: %s';\r\n RsEMissingCommentTerminatorNears = 'missing \"}\" comment terminator near %s';\r\n RsEMissingXmlMethodSpecifierNears = 'missing XML method specifier near %s';\r\n RsEMissingDataSourceMethodSpecifierNea = 'missing data source method specifier near %s';\r\n RsEMissingSystemMethodSpecifierNears = 'missing system method specifier near %s';\r\n RsEMissingExternalVariableMethodSpecif = 'missing external variable method specifier near %s';\r\n RsEMissingInternalVariableMethodSpecif = 'missing internal variable method specifier near %s';\r\n RsEUndefinedWordsNears = 'undefined word \"%0:s\" near %1:s';\r\n RsEScriptTimedOutAfterdSeconds = 'Script timed out after %d seconds';\r\n RsECanNotAssignVariables = 'can not assign variable %s';\r\n RsEVariablesNotDefined = 'Variable %s not defined';\r\n RsEProceduresNotDefined = 'procedure %s not defined';\r\n RsEVariablesNotDefined_ = 'variable %s not defined';\r\n RsESystemsNotDefined = 'System %s not defined';\r\n RsECanNotAssignSystems = 'can not assign System %s';\r\n RsEUnrecognizedExternalVariableMethodss = 'unrecognized external variable method %0:s.%1:s';\r\n RsEUnrecognizedInternalVariableMethodss = 'unrecognized internal variable method %0:s.%1:s';\r\n RsEUnrecognizedSystemMethodss = 'unrecognized system method %0:s.%1:s';\r\n RsEFilesDoesNotExist = 'File %s does not exist';\r\n RsECanNotSaveToFiles = 'Can not save to file %s';\r\n RsEXMLSelectionIsEmpty = 'XML selection is empty';\r\n RsENoXMLSelectionSelected = 'no XML selection selected';\r\n RsEXMLSelectionOutOfRange = 'XML selection out of range';\r\n RsEInvalidXmlMethodSpecifiers = 'invalid XML method specifier %s';\r\n RsEIncrementIndexExpectedIns = 'Increment Index: \"[\" expected in %s';\r\n RsEIncrementIndexExpectedIns_ = 'Increment Index: \"]\" expected in %s';\r\n RsEIncrementIndexExpectedIntegerBetwee = 'Increment Index: expected integer between \"[..]\" in %s';\r\n RsEDSOIndexOutOfRanged = 'DSO index out of range %d';\r\n RsEDSOUnknownKeys = 'DSO unknown key %s';\r\n\r\n//=== JvFullColorCtrls.pas ===================================================\r\nresourcestring\r\n RsColorHintFmt1 = 'FullColor: %0:.8x' + sLineBreak +\r\n 'ColorSpace: %1:s (%2:d)' + sLineBreak +\r\n 'Name: %3:s' + sLineBreak +\r\n 'Pretty name: %4:s';\r\n RsColorHintFmt2 = 'FullColor: %0:.8x, ColorSpace: %1:s (%2:d)' + sLineBreak +\r\n 'Axis %3:s = %4:d' + sLineBreak +\r\n 'Axis %5:s = %6:d' + sLineBreak +\r\n 'Axis %7:s = %8:d';\r\n\r\n RsEDuplicateTrackBar = 'TrackBar already used by component \"%s\"';\r\n RsEUnsupportedColorSpace = 'Unsupported color space \"%d\"';\r\n\r\n//=== JvFullColorDialogs.pas =================================================\r\nresourcestring\r\n RsExpandedCaption = '<< &Hide';\r\n RsCollapsedCaption = '&Panels >>';\r\n\r\n//=== JvFullColorSpaces.pas ==================================================\r\nresourcestring\r\n RsENoTypeInfo = 'The class %s contains no run time type info' + sLineBreak +\r\n '\"Class in module\" test cannot be executed';\r\n RsEUnnamedAxis = 'Unnamed Color Axis';\r\n RsEUnnamedSpace = 'Unnamed Color Space';\r\n RsEUCS = 'UCS';\r\n RsENoName = 'No Name';\r\n RsECSNotFound = 'Color Space not found: %d';\r\n RsEIllegalID = 'Color Space ID %d is illegal';\r\n RsECSAlreadyExists = 'Color Space Already exists [ID: %0:d, Name: %1:s]';\r\n RsEInconvertibleColor = 'TColor value $%.8X cannot be converted to TJvFullColor';\r\n\r\n RsRGB_Red = 'Red';\r\n RsRGB_Green = 'Green';\r\n RsRGB_Blue = 'Blue';\r\n RsRGB_FullName = 'True Color';\r\n RsRGB_ShortName = 'RGB';\r\n\r\n RsHLS_Hue = 'Hue';\r\n RsHLS_Lightness = 'Lightness';\r\n RsHLS_Saturation = 'Saturation';\r\n RsHLS_FullName = 'Chromatic Vision';\r\n RsHLS_ShortName = 'HLS';\r\n\r\n RsCMY_Cyan = 'Cyan';\r\n RsCMY_Magenta = 'Magenta';\r\n RsCMY_Yellow = 'Yellow';\r\n RsCMY_FullName = 'Substractive Vision';\r\n RsCMY_ShortName = 'CMY';\r\n\r\n RsYUV_Y = 'Y Value';\r\n RsYUV_U = 'U Value';\r\n RsYUV_V = 'V Value';\r\n RsYUV_FullName = 'PC Video';\r\n RsYUV_ShortName = 'YUV';\r\n\r\n RsHSV_Hue = 'Hue';\r\n RsHSV_Saturation = 'Saturation';\r\n RsHSV_Value = 'Value';\r\n RsHSV_FullName = 'Rotation Vision';\r\n RsHSV_ShortName = 'HSV';\r\n\r\n RsYIQ_Y = 'Y';\r\n RsYIQ_I = 'I';\r\n RsYIQ_Q = 'Q';\r\n RsYIQ_FullName = 'NTSC US television standard';\r\n RsYIQ_ShortName = 'YIQ';\r\n\r\n RsYCC_Y = 'Y';\r\n RsYCC_Cr = 'Cr';\r\n RsYCC_Cb = 'Cb';\r\n RsYCC_FullName = 'YCrCb';\r\n RsYCC_ShortName = 'YCC';\r\n\r\n RsXYZ_X = 'X';\r\n RsXYZ_Y = 'Y';\r\n RsXYZ_Z = 'Z';\r\n RsXYZ_FullName = 'CIE XYZ';\r\n RsXYZ_ShortName = 'XYZ';\r\n\r\n RsLAB_L = 'L';\r\n RsLAB_A = 'A';\r\n RsLAB_B = 'B';\r\n RsLAB_FullName = 'CIE LAB';\r\n RsLAB_ShortName = 'LAB';\r\n\r\n RsDEF_FullName = 'Delphi predefined colors';\r\n RsDEF_ShortName = 'DEF';\r\n\r\n//=== Jvg3DColors.pas ========================================================\r\nresourcestring\r\n RsEOnlyOneInstanceOfTJvg3DLocalColors = 'Cannot create more than one instance of TJvg3DLocalColors component';\r\n\r\n//=== JvGammaPanel.pas =======================================================\r\nresourcestring\r\n RsRedFormat = 'R : %3D';\r\n RsGreenFormat = 'G : %3D';\r\n RsBlueFormat = 'B : %3D';\r\n\r\n RsHint1 = 'Background Color';\r\n RsHint2 = 'Foreground Color';\r\n RsXCaption = 'X';\r\n RsLabelHint = 'Exchange colors';\r\n\r\n RsDefaultB = 'B : ---';\r\n RsDefaultG = 'G : ---';\r\n RsDefaultR = 'R : ---';\r\n\r\n//=== JvgAskListBox.pas ======================================================\r\nresourcestring\r\n RsYes = 'yes';\r\n RsNo = 'no';\r\n\r\n//=== JvgButton.pas ==========================================================\r\nresourcestring\r\n RsEErrorDuringAccessGlyphsListOrGlyphP = 'Error during access GlyphsList or Glyph property';\r\n\r\n//=== JvgCaption.pas =========================================================\r\nresourcestring\r\n RsEOnlyOneInstanceOfTJvgCaption = 'Cannot create more than one instance of TJvgCaption component';\r\n\r\n//=== JvgCheckVersionInfoForm.pas ============================================\r\nresourcestring\r\n RsNoNewerVersionOfProgramAvailable = 'No newer version of program available';\r\n\r\n//=== JvGenetic.pas ==========================================================\r\nresourcestring\r\n RsENoTest = 'TJvGenetic: OnTestMember must be assigned';\r\n\r\n//=== JvgExportComponents.pas ================================================\r\nresourcestring\r\n RsEDataSetIsUnassigned = 'DataSet is unassigned';\r\n RsESaveToFileNamePropertyIsEmpty = 'SaveToFileName property is empty';\r\n RsEExcelNotAvailable = 'Excel not available';\r\n\r\n//=== JvgHelpPanel.pas =======================================================\r\nresourcestring\r\n RsHelp = ' help ';\r\n RsOpenContextMenuToLoadRTFTextControl = 'Open context menu to load RTF text. Control shows text at runtime only.';\r\n\r\n//=== JvgHint.pas ============================================================\r\nresourcestring\r\n RsEOnlyOneInstanceOfTJvgHint = 'Cannot create more than one instance of TJvgHint component';\r\n\r\n//=== JvgHTTPVersionInfo.pas =================================================\r\nresourcestring\r\n RsEUnknownURLPropertyVersionDataURLIs = 'Unknown URL: property VersionDataURL is empty';\r\n\r\n//=== JvGIF.pas ==============================================================\r\nresourcestring\r\n RsGIFImage = 'CompuServe GIF Image';\r\n\r\n RsEChangeGIFSize = 'Cannot change the Size of a GIF image';\r\n RsENoGIFData = 'No GIF Data to write';\r\n RsEUnrecognizedGIFExt = 'Unrecognized extension block: %.2x';\r\n RsEWrongGIFColors = 'Wrong number of colors; must be a power of 2';\r\n RsEBadGIFCodeSize = 'GIF code size not in range 2 to 9';\r\n RsEGIFDecodeError = 'GIF encoded data is corrupt';\r\n RsEGIFEncodeError = 'GIF image encoding error';\r\n RsEGIFVersion = 'Unknown GIF version';\r\n\r\n//=== JvgLogics.pas ==========================================================\r\nresourcestring\r\n RsEqualTo = 'equal to';\r\n RsStartingWith = 'starting with';\r\n RsEndsWith = 'ends with';\r\n RsContains = 'contains';\r\n RsIsContainedWithin = 'is contained within';\r\n RsNotEmpty = 'not empty';\r\n RsStep = 'Step ';\r\n RsComments = 'Comments';\r\n\r\n//=== JvgMailSlots.pas =======================================================\r\nresourcestring\r\n RsJvMailSlotServerErrorCreatingChan = 'Mailslot-Server: Error creating channel!';\r\n RsJvMailSlotServerErrorGatheringInf = 'Mailslot-Server: Error gathering information!';\r\n RsJvMailSlotServerErrorReadingMessa = 'Mailslot-Server: Error reading message!';\r\n\r\n//=== JvgProgress.pas ========================================================\r\nresourcestring\r\n RsProgressCaption = 'Progress...[%d%%]';\r\n\r\n//=== JvgQPrintPreviewForm.pas ===============================================\r\nresourcestring\r\n RsPageOfPages = 'Page %0:d of %1:d';\r\n\r\n//=== JvGradientHeaderPanel.pas ==============================================\r\nresourcestring\r\n RsYourTextHereCaption = 'Put your text here ...';\r\n\r\n//=== JvgReport.pas ==========================================================\r\nresourcestring\r\n RsOLELinkedObjectNotFound = 'OLE: Linked object not found.';\r\n RsErrorText = 'Error';\r\n RsErrorReadingComponent = 'Error reading component';\r\n\r\n//=== JvGridPreviewForm.pas ==================================================\r\nresourcestring\r\n RsOfd = 'of %d';\r\n RsPaged = 'Page %d';\r\n RsNoPrinterIsInstalled = 'No Printer is installed';\r\n\r\n//=== JvGridPrinter.pas ======================================================\r\nresourcestring\r\n RsPrintOptionsPageFooter = 'date|time|page';\r\n RsPrintOptionsDateFormat = 'd-mmm-yyyy';\r\n RsPrintOptionsTimeFormat = 'h:nn am/pm';\r\n\r\n//=== JvgSingleInstance.pas ==================================================\r\nresourcestring\r\n RsOneInstanceOfThisProgramIsAlreadyRu =\r\n 'One instance of this program is already running. A second instance launch is not allowed.';\r\n RsSecondInstanceLaunchOfs = 'Second instance launch of %s';\r\n\r\n//=== JvgSmallFontsDefense.pas ===============================================\r\nresourcestring\r\n RsTJvgSmallFontsDefenseCannotBeUsedWi = 'TJvgSmallFontsDefense cannot be used with large fonts.';\r\n\r\n//=== JvgUtils.pas ===========================================================\r\nresourcestring\r\n RsERightBracketsNotFound = 'Right brackets not found';\r\n RsERightBracketHavntALeftOnePosd = 'Right bracket does not have a left one. Pos: %d';\r\n RsEDivideBy = 'Divide by 0';\r\n RsEDuplicateSignsAtPos = 'Duplicate signs at Pos: %d';\r\n RsEExpressionStringIsEmpty = 'Expression string is empty';\r\n {$IFDEF glDEBUG}\r\n RsEObjectMemoryLeak = 'object memory leak';\r\n {$ENDIF glDEBUG}\r\n\r\n//=== JvgXMLSerializer.pas ===================================================\r\nresourcestring\r\n { RUSSIAN\r\n RsOpenXMLTagNotFound = ' : <%s>';\r\n RsCloseXMLTagNotFound = ' : ';\r\n RsUncknownProperty = 'Uncknown property: %s'\r\n }\r\n RsOpenXMLTagNotFound = 'Open tag not found: <%s>';\r\n RsCloseXMLTagNotFound = 'Close tag not found: ';\r\n RsUnknownProperty = 'Unknown property: %s';\r\n\r\n//=== JvHidControllerClass.pas ===============================================\r\nresourcestring\r\n RsUnknownLocaleIDFmt = 'Unknown Locale ID $%.4x';\r\n RsHIDP_STATUS_NULL = 'Device not plugged in';\r\n RsHIDP_STATUS_INVALID_PREPARSED_DATA = 'Invalid preparsed data';\r\n RsHIDP_STATUS_INVALID_REPORT_TYPE = 'Invalid report type';\r\n RsHIDP_STATUS_INVALID_REPORT_LENGTH = 'Invalid report length';\r\n RsHIDP_STATUS_USAGE_NOT_FOUND = 'Usage not found';\r\n RsHIDP_STATUS_VALUE_OUT_OF_RANGE = 'Value out of range';\r\n RsHIDP_STATUS_BAD_LOG_PHY_VALUES = 'Bad logical or physical values';\r\n RsHIDP_STATUS_BUFFER_TOO_SMALL = 'Buffer too small';\r\n RsHIDP_STATUS_INTERNAL_ERROR = 'Internal error';\r\n RsHIDP_STATUS_I8042_TRANS_UNKNOWN = '8042 key translation impossible';\r\n RsHIDP_STATUS_INCOMPATIBLE_REPORT_ID = 'Incompatible report ID';\r\n RsHIDP_STATUS_NOT_VALUE_ARRAY = 'Not a value array';\r\n RsHIDP_STATUS_IS_VALUE_ARRAY = 'Is a value array';\r\n RsHIDP_STATUS_DATA_INDEX_NOT_FOUND = 'Data index not found';\r\n RsHIDP_STATUS_DATA_INDEX_OUT_OF_RANGE = 'Data index out of range';\r\n RsHIDP_STATUS_BUTTON_NOT_PRESSED = 'Button not pressed';\r\n RsHIDP_STATUS_REPORT_DOES_NOT_EXIST = 'Report does not exist';\r\n RsHIDP_STATUS_NOT_IMPLEMENTED = 'Not implemented';\r\n RsUnknownHIDFmt = 'Unknown HID error %x';\r\n RsHIDErrorPrefix = 'HID Error: ';\r\n\r\n RsEDirectThreadCreationNotAllowed = 'Direct creation of a TJvDeviceReadThread object is not allowed';\r\n RsEDirectHidDeviceCreationNotAllowed = 'Direct creation of a TJvHidDevice object is not allowed';\r\n RsEDeviceCannotBeIdentified = 'Device cannot be identified';\r\n RsEDeviceCannotBeOpened = 'Device cannot be opened';\r\n RsEOnlyOneControllerPerProgram = 'Only one TJvHidDeviceController allowed per program';\r\n RsEHIDBooleanError = 'HID Error: a boolean function failed';\r\n\r\n//=== JvHint.pas =============================================================\r\nresourcestring\r\n RsHintCaption = 'Hint';\r\n\r\n//=== JvHLEditorPropertyForm.pas =============================================\r\nresourcestring\r\n RsHLEdPropDlg_Caption = 'Editor Properties';\r\n RsHLEdPropDlg_tsEditor = 'Editor';\r\n RsHLEdPropDlg_tsColors = 'Colors';\r\n RsHLEdPropDlg_lblEditorSpeedSettings = 'Editor SpeedSettings';\r\n RsHLEdPropDlg_cbKeyboardLayoutDefault = 'Default keymapping';\r\n RsHLEdPropDlg_gbEditor = 'Editor options:';\r\n RsHLEdPropDlg_cbAutoIndent = '&Auto indent mode';\r\n RsHLEdPropDlg_cbSmartTab = 'S&mart tab';\r\n RsHLEdPropDlg_cbBackspaceUnindents = 'Backspace &unindents';\r\n RsHLEdPropDlg_cbGroupUndo = '&Group undo';\r\n RsHLEdPropDlg_cbCursorBeyondEOF = 'Cursor beyond &EOF';\r\n RsHLEdPropDlg_cbCursorBeyondEOL = 'Cursor beyond end of &line';\r\n RsHLEdPropDlg_cbUndoAfterSave = '&Undo after sa&ve';\r\n RsHLEdPropDlg_cbKeepTrailingBlanks = '&Keep trailing blanks';\r\n RsHLEdPropDlg_cbDoubleClickLine = '&Double click line';\r\n RsHLEdPropDlg_cbSytaxHighlighting = 'Use &syntax highlight';\r\n RsHLEdPropDlg_lblTabStops = '&Tab stops:';\r\n RsHLEdPropDlg_lblColorSpeedSettingsFor = 'Color SpeedSettings for';\r\n RsHLEdPropDlg_lblElement = '&Element:';\r\n RsHLEdPropDlg_lblColor = '&Color:';\r\n RsHLEdPropDlg_gbTextAttributes = 'Text attributes:';\r\n RsHLEdPropDlg_gbUseDefaultsFor = 'Use defaults for:';\r\n RsHLEdPropDlg_cbBold = '&Bold';\r\n RsHLEdPropDlg_cbItalic = '&Italic';\r\n RsHLEdPropDlg_cbUnderline = '&Underline';\r\n RsHLEdPropDlg_cbDefForeground = '&Foreground';\r\n RsHLEdPropDlg_cbDefBackground = '&Background';\r\n RsHLEdPropDlg_OptionCantBeChanged = 'This option cannot be changed. Sorry.';\r\n\r\n RsEHLEdPropDlg_RAHLEditorNotAssigned = 'JvHLEditor property is not assigned';\r\n RsEHLEdPropDlg_RegAutoNotAssigned = 'RegAuto property is not assigned';\r\n RsEHLEdPropDlg_GridCellNotFound = 'Grid cell not found';\r\n\r\n//=== JvHTTPGrabber.pas ======================================================\r\nresourcestring\r\n RsAgent = 'TJvHTTPGrabber Delphi Component';\r\n\r\n//=== JvId3v1.pas ============================================================\r\nresourcestring\r\n RsENotActive = 'Not active';\r\n\r\n//=== JvID3v2Base.pas ========================================================\r\nresourcestring\r\n RsENameMsgFormat = '%0:s: %1:s';\r\n RsEAllowedEncodingsIsEmpty = 'FAllowedEncodings is empty';\r\n RsEAlreadyReadingWriting = 'Already reading or writing';\r\n RsEAlreadyReadingWritingFrame = 'Already reading/writing frame';\r\n RsEAlreadyUsingTempStream = 'Already using temp stream';\r\n RsECannotCallCanRead = 'Cannot call CanRead while writing';\r\n RsEControllerDoesNotSupportCompression = 'Controller does not support compression';\r\n RsEControllerDoesNotSupportCRC = 'Controller does not support CRC';\r\n RsEControllerDoesNotSupportEncryption = 'Controller does not support encryption';\r\n RsEControllerDoesNotSupportFooter = 'Controller does not support footer';\r\n RsECouldNotFindAllowableEncoding = 'Could not find allowable encoding';\r\n RsECouldNotReadData = 'Could not read data from stream';\r\n RsEErrorInFrame = 'Error in frame %0:s (%1:s), %2:s';\r\n RsEFrameSizeDiffers = 'Frame size differs from actually amount of data written';\r\n RsEFrameSizeTooBig = 'Frame size is too big';\r\n RsELanguageNotOfLength3 = 'Language is not of length 3';\r\n RsENoTempStream = 'No temp stream';\r\n RsENotReadingFrame = 'Not reading frame';\r\n RsENotUsingTempStream = 'Not using temp stream';\r\n RsENotWriting = 'Not writing';\r\n RsENotWritingFrame = 'Not writing frame';\r\n RsETagTooBig = 'Tag is too big';\r\n RsEValueTooBig = 'Cannot write value in v2.2; too big';\r\n RsENotReading = 'Not reading';\r\n\r\n RsEID3FrameNotFound = 'Frame not found';\r\n RsEID3UnknownEncoding = 'Unknown encoding';\r\n RsEID3UnknownVersion = 'Unknown version';\r\n RsEID3DuplicateFrame = 'Frame is a duplicate of another frame in the tag';\r\n RsEID3AlreadyContainsFrame = 'Tag already contains a ''%s'' frame';\r\n RsEID3ControllerNotActive = 'Controller is not active';\r\n RsEID3EncodingNotSupported = 'Encoding not supported in this version';\r\n RsEID3VersionNotSupported = 'Version not supported';\r\n RsEID3InvalidLanguageValue = '''%s'' is an invalid language value';\r\n RsEID3InvalidPartInSetValue = '''%s'' is an invalid ''part in set'' value';\r\n RsEID3InvalidTimeValue = '''%s'' is an invalid time value.' + sLineBreak + 'Value must be of format ''HHMM''';\r\n RsEID3InvalidDateValue = '''%s'' is an invalid date value.' + sLineBreak + 'Value must be of format ''DDMM''';\r\n RsEID3ValueTooBig = '''%d'' is an invalid value. Value is too big';\r\n RsEID3StringTooLong = '''%s'' is an invalid value. String is too long';\r\n RsEID3InvalidCharinList = 'Invalid char ''%0:s'' in string ''%1:s'' in list';\r\n RsEID3InvalidFrameClass = 'Frame class ''%0:s'' cannot be used to represent frame ID ''%1:s''';\r\n RsEID3FrameIDNotSupported = 'Frame ID ''%s'' not supported by this frame';\r\n RsEID3FrameIDStrNotSupported = 'Frame ID string ''%s'' not supported by this frame';\r\n\r\n//=== JvId3v2Types.pas =======================================================\r\nresourcestring\r\n RsEFrameIDSizeCanOnlyBe34 = 'Frame ID size can only be 3 or 4';\r\n\r\n//=== JvImageDlg.pas =========================================================\r\nresourcestring\r\n RsImageTitle = 'Image Viewer';\r\n\r\n//=== JvImageList.pas ========================================================\r\nresourcestring\r\n RsResource = 'Resource %s';\r\n RsMappedResource = 'Mapped Resource %s';\r\n RsBitmap = 'Bitmap %s';\r\n RsEWrongImageListMode = 'Wrong image list mode. For this function the mode must be %s';\r\n\r\n//=== JvImageWindow.pas ======================================================\r\nresourcestring\r\n RsEImagesNotAssigned = 'Images not Assigned!';\r\n\r\n//=== JvInspector.pas ========================================================\r\nresourcestring\r\n RsJvInspItemValueException = 'Exception ';\r\n RsJvInspItemUnInitialized = '(uninitialized)';\r\n RsJvInspItemUnassigned = '(unassigned)';\r\n RsJvInspItemNoValue = '(no value)';\r\n\r\n RsStringListEditorCaption = 'String list editor';\r\n RsXLinesCaption = ' lines';\r\n RsOneLineCaption = '1 line';\r\n\r\n RsEJvInspItemHasParent = 'Item already assigned to another parent';\r\n RsEJvInspItemNotAChild = 'Specified Item is not a child of this item';\r\n RsEJvInspItemColNotFound = 'Specified column does not belong to this compound item';\r\n RsEJvInspItemItemIsNotCol = 'Specified item is not a column of this compound item';\r\n RsEJvInspItemInvalidPropValue = 'Invalid property value %s';\r\n RsEJvInspDataNoAccessAs = 'Data cannot be accessed as %s';\r\n RsEJvInspDataNotInit = 'Data not initialized';\r\n RsEJvInspDataNotAssigned = 'Data not assigned';\r\n RsEJvInspDataNoValue = 'Data has no value';\r\n RsEJvInspDataStrTooLong = 'String too long';\r\n RsEJvInspRegNoCompare = 'Cannot compare %0:s to %1:s';\r\n RsEJvInspNoGenReg = 'Unable to create generic item registration list';\r\n RsEJvInspPaintNotActive = 'Painter is not the active painter of the specified inspector';\r\n RsEJvInspPaintOnlyUsedOnce = 'Inspector painter can only be linked to one inspector';\r\n\r\n RsEInspectorInternalError = 'Internal error: two data instances pointing to the same data are registered';\r\n RsESpecifierBeforeSeparator = 'A specifier should be placed before and after a separator';\r\n RsEDOrDDOnlyOnce = '''d'' or ''dd'' should appear only once';\r\n RsEMOrMMOnlyOnce = '''m'' or ''mm'' should appear only once';\r\n RsEYYOrYYYYOnlyOnce = '''yy'' or ''yyyy'' should appear only once';\r\n RsEOnlyDOrDDAllowed = 'Only ''d'' or ''dd'' are allowed';\r\n RsEOnlyMOrMMAllowed = 'Only ''m'' or ''mm'' are allowed';\r\n RsEOnlyYYOrYYYYAllowed = 'Only ''yy'' or ''yyyy'' are allowed';\r\n RsEOnlyTwoSeparators = 'Only two separators are allowed';\r\n RsEOnlyDMYSAllowed = 'Only ''d'', ''m'', ''y'' and ''%s'' are allowed';\r\n RsEDOrDDRequired = '''d'' or ''dd'' are required';\r\n RsEMOrMMRequired = '''m'' or ''mm'' are required';\r\n RsEYYOrYYYYRequired = '''yy'' or ''yyyy'' are required';\r\n RsEInstanceAlreadyExists = 'Instance already exists with another name';\r\n RsENameAlreadyExistsForInstance = 'Name already exists for another instance';\r\n RsEInstanceNonexistent = 'Instance does not exist';\r\n RsEMethodAlreadyExists = 'Method already exists with another name';\r\n RsENameAlreadyExistsForMethod = 'Name already exists for another method';\r\n RsENamedInstanceNonexistent = 'Instance named ''%s'' does not exist';\r\n RsEMethodNonexistent = 'Method does not exist';\r\n RsENamedMethodNonexistent = 'Method named ''%s'' does not exist';\r\n RsENotSeparately = '%s cannot be created separately';\r\n RsENoNewInstance = '%s does not allow a new instance to be created';\r\n\r\n // (rom) converted assertions\r\n RsEJvAssertSetTopIndex = 'TJvCustomInspector.SetTopIndex: unexpected MaxIdx <= -1';\r\n RsEJvAssertInspectorPainter = 'TJvInspectorCustomCompoundItem.DivideRect: unexpected Inspector.Painter = nil';\r\n RsEJvAssertDataParent = 'TJvInspectorSetMemberData.New: unexpected ADataParent = nil';\r\n RsEJvAssertParent = 'TJvInspectorSetMemberData.New: unexpected AParent = nil';\r\n RsEJvAssertPropInfo = 'TJvInspectorPropData.New: unexpected PropInfo = nil';\r\n RsEJvAssertClassInfo = 'TJvInspectorPropData.New: unexpected ClassInfo = nil';\r\n RsEJvAssertINIFile = 'TJvInspectorINIFileData.New: unexpected AINIFile = nil';\r\n\r\n//=== JvInspXVCL.pas =========================================================\r\nresourcestring\r\n RsENoNodeSpecified = 'TJvInspectorxNodeData.New: No node specified';\r\n\r\n//=== JvInstallLabel.pas =====================================================\r\nresourcestring\r\n RsEListOutOfBounds = 'List index out of bounds (%d)';\r\n\r\n//=== JvInterpreter.pas ======================================================\r\nresourcestring\r\n RsNotImplemented = 'Function not yet implemented';\r\n RsOleAutomationCall = 'Ole automation call';\r\n\r\n RsESorryDynamicArraysSupportIsMadeForO = 'Sorry. Dynamic arrays support is made for one-dimensional arrays only';\r\n RsEUnknownRecordType = 'Unknown RecordType';\r\n RsERangeCheckError = 'Range check error';\r\n RsArrayToArrayAssignment = 'Array to array assignment';\r\n\r\n//=== JvInterpreter_Quickrpt.pas =============================================\r\nresourcestring\r\n RsENoQuickReportFound = 'TQuickRep component not found on the form';\r\n\r\n//=== JvInterpreter_System.pas ===============================================\r\nresourcestring\r\n RsESizeMustBeEven = 'The size of bounds array must be even!';\r\n\r\n//=== JvInterpreterConst.pas =================================================\r\nresourcestring\r\n RsEInterpreter0 = 'Ok';\r\n RsEInterpreter1 = 'Unknown error';\r\n RsEInterpreter2 = 'Internal interpreter error: %s';\r\n RsEInterpreter3 = 'User break';\r\n RsEInterpreter4 = 'Re-raising an exception only allowed in exception handler';\r\n RsEInterpreter5 = 'Error in unit ''%0:s'' on line %1:d : %2:s';\r\n RsEInterpreter6 = 'External error in unit ''%0:s'' on line %1:d : %2:s';\r\n RsEInterpreter7 = 'Access denied to ''%s''';\r\n RsEInterpreter8 = 'Expression is too complex - overflow';\r\n RsEInterpreter31 = 'Record ''%s'' not defined';\r\n\r\n RsEInterpreter52 = 'Stack overflow';\r\n RsEInterpreter53 = 'Type mismatch';\r\n RsEInterpreter55 = 'Function ''main'' undefined';\r\n RsEInterpreter56 = 'Unit ''%s'' not found';\r\n RsEInterpreter57 = 'Event ''%s'' not registered';\r\n RsEInterpreter58 = 'DFM ''%s'' not found';\r\n\r\n RsEInterpreter101 = 'Error in remark'; // (rom) in comment?\r\n RsEInterpreter103 = '%0:s expected but %1:s found';\r\n RsEInterpreter104 = 'Undeclared Identifier ''%s''';\r\n RsEInterpreter105 = 'Type of expression must be boolean';\r\n RsEInterpreter106 = 'Class type required';\r\n RsEInterpreter107 = ' not allowed before else';\r\n RsEInterpreter108 = 'Type of expression must be integer';\r\n RsEInterpreter109 = 'Record, object or class type required';\r\n RsEInterpreter110 = 'Missing operator or semicolon';\r\n RsEInterpreter111 = 'Identifier redeclared: ''%s''';\r\n\r\n RsEInterpreter171 = 'Array index out of bounds';\r\n RsEInterpreter172 = 'Too many array bounds';\r\n RsEInterpreter173 = 'Not enough array bounds';\r\n RsEInterpreter174 = 'Invalid array dimension';\r\n RsEInterpreter175 = 'Invalid array range';\r\n RsEInterpreter176 = 'Array type required';\r\n\r\n RsEInterpreter181 = 'Too many actual parameters';\r\n RsEInterpreter182 = 'Not enough parameters';\r\n RsEInterpreter183 = 'Incompatible types: ''%0:s'' and ''%1:s''';\r\n RsEInterpreter184 = 'Error loading library ''%s''';\r\n RsEInterpreter185 = 'Invalid type of argument in call to function ''%s''';\r\n RsEInterpreter186 = 'Invalid type of result in call to function ''%s''';\r\n RsEInterpreter187 = 'Can''t get proc address for function ''%s''';\r\n RsEInterpreter188 = 'Invalid type of argument in call to function ''%s''';\r\n RsEInterpreter189 = 'Invalid type of result in call to function ''%s''';\r\n RsEInterpreter190 = 'Invalid calling convention for function ''%s''';\r\n\r\n RsEInterpreter201 = 'Calling ''%0:s'' failed: ''%1:s''';\r\n\r\n RsEInterpreter301 = 'Expression';\r\n RsEInterpreter302 = 'Identifier';\r\n RsEInterpreter303 = 'Declaration';\r\n RsEInterpreter304 = 'End of File';\r\n RsEInterpreter305 = 'Class Declaration';\r\n RsEInterpreter306 = 'Integer Constant''';\r\n RsEInterpreter307 = 'Integer Value';\r\n RsEInterpreter308 = 'String Constant';\r\n RsEInterpreter309 = 'Statement';\r\n\r\n RsEInterpreter401 = 'Implementation of unit not found';\r\n RsEInterpreter402 = 'Array and Record types are not allowed as procedure/function parameter';\r\n\r\n RsEXOrX = ''' or ''';\r\n\r\n//=== JvInterpreterFm.pas ====================================================\r\nresourcestring\r\n RsENoReportProc = 'Procedure \"JvInterpreterRunReportPreview\" not found';\r\n RsENoReportProc2 = 'Procedure \"JvInterpreterRunReportPreview2\" not found';\r\n\r\n//=== JvJanTreeView.pas ======================================================\r\nresourcestring\r\n RsSaveCurrentTree = 'Save Current Tree';\r\n RsSearch = 'Search';\r\n RsSearchFor = 'Search for:';\r\n RsNoMoresFound = 'No more %s found';\r\n\r\n RsEInvalidReduction = 'Invalid reduction';\r\n RsEBadTokenState = 'Bad token state';\r\n RsTreeViewFiles = 'TreeView Files';\r\n RsNewNode = 'new node';\r\n RsNew = 'new';\r\n RsRecalculateErr = 'Error in: %s';\r\n\r\n//=== JvJoystick.pas =========================================================\r\nresourcestring\r\n RsNoJoystickDriver = 'The joystick driver is not present.';\r\n RsCannotCaptureJoystick = 'Cannot capture the joystick';\r\n RsJoystickUnplugged = 'The specified joystick is not connected to the system.';\r\n RsJoystickErrorParam = 'The specified joystick device identifier is invalid.';\r\n\r\n RsEJoystickError = 'Unable to initialize joystick driver';\r\n\r\n//=== JvJVCLUtils.pas ========================================================\r\nresourcestring\r\n RsENotForMdi = 'MDI forms are not allowed';\r\n RsEPixelFormatNotImplemented = 'BitmapToMemoryStream: pixel format not implemented';\r\n RsEBitCountNotImplemented = 'BitmapToMemoryStream: bit count not implemented';\r\n RsECantGetShortCut = 'Target FileName for ShortCut %s not available';\r\n RsEBadGraphicSignature = 'Bad Graphic Signature';\r\n RsEChildControlMissing = 'Child control is nil';\r\n\r\n//=== JvLinkedControls.pas ===================================================\r\nresourcestring\r\n RsEOwnerLinkError = 'Cannot link to owner control';\r\n\r\n//=== JvLinkLabel.pas ========================================================\r\nresourcestring\r\n RsEUnableToLocateMode = 'Unable to locate specified node';\r\n RsETagNotFound = 'TJvCustomLinkLabel.UpdateDynamicTag: Tag not found';\r\n\r\n//=== JvLinkLabelParser.pas ==================================================\r\nresourcestring\r\n RsENoMoreElementsToReturn = 'TElementEnumerator.GetNextElement: No more elements to return';\r\n RsEUnsupportedState = 'TDefaultParser.ParseNode: Unsupported state';\r\n\r\n//=== JvLinkLabelTextHandler.pas =============================================\r\nresourcestring\r\n RsENoMoreWords = 'TWordEnumerator.GetNext: No more words to return';\r\n RsEUnsupported = 'TTextHandler.EmptyBuffer: Unsupported TParentTextElement descendant encountered';\r\n\r\n//=== JvLinkLabelTools.pas ===================================================\r\nresourcestring\r\n RsECannotBeInstantiated = 'This class cannot be instantiated';\r\n\r\n//=== JvLinkLabelTree.pas ====================================================\r\nresourcestring\r\n RsETNodeGetNodeTypeUnknownClass = 'TNode.GetNodeType: Unknown class';\r\n RsENoMoreNodesToReturn = 'No more nodes to return';\r\n RsENoMoreRecordsToReturn = 'No more records to return';\r\n RsEWordInfoIndexOutOfBounds = 'TStringNode.GetWordInfo: Index out of bounds';\r\n\r\n//=== JvListView.pas =========================================================\r\nresourcestring\r\n RsETooManyColumns = 'TJvListView.GetColumnsOrder: too many columns';\r\n\r\n//=== JvLoginForm.pas ========================================================\r\nresourcestring\r\n RsRegistrationCaption = 'Registration';\r\n RsAppTitleLabel = 'Application \"%s\"';\r\n RsHintLabel = 'Type your user name and password to enter the application';\r\n RsUserNameLabel = '&User name:';\r\n RsPasswordLabel = '&Password:';\r\n RsUnlockCaption = 'Unlock application';\r\n RsUnlockHint = 'Type your password to unlock the application';\r\n\r\n//=== JvMail.pas =============================================================\r\nresourcestring\r\n RsAttachmentNotFound = 'Attached file \"%s\" not found';\r\n RsRecipNotValid = 'Recipient %s has invalid address';\r\n RsNoClientInstalled = 'There is no MAPI-enabled client on the machine';\r\n RsNoUserLogged = 'There must be a user logged before call this function';\r\n\r\n//=== JvMemoryDataset.pas ====================================================\r\nresourcestring\r\n RsEMemNoRecords = 'No data found';\r\n // 'Registro ya existente.';\r\n RsERecordDuplicate = 'Record already exists.';\r\n // 'Registro no encontrado.';\r\n RsERecordInexistent = 'Record not found.';\r\n // 'No se pudo agregar el registro.';\r\n RsEInsertError = 'Unable to append the record.';\r\n // 'No se pudo modificar el registro.';\r\n RsEUpdateError = 'Unable to modify the record.';\r\n // 'No se pudo eliminar el registro.';\r\n RsEDeleteError = 'Unable to erase the record.';\r\n\r\n//=== JvMouseGesture.pas =====================================================\r\nresourcestring\r\n RsECannotHookTwice = 'JvMouseGesture Fatal: You cannot hook this event twice';\r\n\r\n//=== JvMRUList.pas ==========================================================\r\nresourcestring\r\n RsEErrorMruCreating = 'Unable to create MRU';\r\n RsEErrorMruUnicode = 'Windows NT required for Unicode in MRU';\r\n\r\n//=== JvMRUManager.pas =======================================================\r\nresourcestring\r\n RsEDuplicatesNotAllowedInMRUList = 'Duplicates not allowed in MRU list';\r\n\r\n//=== JvMTComponents.pas =====================================================\r\nresourcestring\r\n RsENoThreadManager = 'No ThreadManager specified';\r\n RsEOperatorNotAvailable = 'Operation not available while thread is active';\r\n RsECannotChangePropertySection = 'Cannot change property of active section';\r\n RsECannotChangePropertyBuffer = 'Cannot change property of active buffer';\r\n\r\n//=== JvMTData.pas ===========================================================\r\nresourcestring\r\n RsEMethodOnlyForMainThread = '%s method can only be used by the main VCL thread';\r\n\r\n//=== JvMTSync.pas ===========================================================\r\nresourcestring\r\n RsESemaphoreFailure = 'Semaphore failure (%d)';\r\n RsESemaphoreAbandoned = 'Semaphore was abandoned';\r\n RsEThreadAbandoned = 'Thread was abandoned';\r\n\r\n//=== JvMTThreading.pas ======================================================\r\nresourcestring\r\n RsECurThreadIsPartOfManager = 'Current MTThread is part of the MTManager';\r\n RsECheckTerminateCalledByWrongThread = 'CheckTerminate can only be called by the same thread';\r\n RsEThreadNotInitializedOrWaiting = 'Cannot run: thread is not Initializing or Waiting';\r\n RsECannotChangeNameOfOtherActiveThread = 'Cannot change name of other active thread';\r\n RsEReleaseOfUnusedTicket = 'Release of unused ticket';\r\n\r\n//=== JvMultiHttpGrabber.pas =================================================\r\nresourcestring\r\n RsErrorConnection = 'Unable to connect';\r\n RsMultiAgent = 'TJvMultiHTTPGrabber Delphi Component';\r\n\r\n//=== JvNavigationPane.pas ===================================================\r\nresourcestring\r\n RsEUnsupportedButtonType = 'ButtonType not supported';\r\n\r\n//=== JvNTEventLog.pas =======================================================\r\nresourcestring\r\n RsLogError = 'Error';\r\n RsLogWarning = 'Warning';\r\n RsLogInformation = 'Information';\r\n RsLogSuccessAudit = 'Success Audit';\r\n RsLogFailureAudit = 'Failure Audit';\r\n RsLogUserSIDNotFound = 'User SID not found';\r\n\r\n//=== JvObjectPickerDialog.pas ===============================================\r\nresourcestring\r\n RsEAttributeIndexOutOfBounds = '%d is not a valid attribute index';\r\n RsESelectionIndexOutOfBounds = '%d is not a valid selection index';\r\n\r\n//=== JvOfficeColorButton.pas ================================================\r\nresourcestring\r\n RsDragToFloating = 'Drag to floating';\r\n\r\n//=== JvOfficeColorForm.pas ==================================================\r\nresourcestring\r\n RsColorWindow = 'Color Window';\r\n // (rom) probably the same as RsDragToFloating\r\n RsDragToFloat = 'Drag to float';\r\n\r\n//=== JvOfficeColorPanel.pas =================================================\r\nresourcestring\r\n RsNoneColorCaption = 'No Color';\r\n RsDefaultColorCaption = 'Automatic';\r\n RsCustomColorCaption = 'Other Colors...';\r\n\r\n//=== JvOracleDataset.pas ====================================================\r\nresourcestring\r\n RsODSOpenFetch = 'Open / Fetch : ';\r\n RsODSCurrentRecord = 'Current Record : ';\r\n RsODSRowsFetchedContinue = '%d rows fetched. Continue ? ';\r\n RsODSContinueYes = '&Yes';\r\n RsODSContinuePause = '&Pause';\r\n RsODSContinueNo = '&No';\r\n RsODSContinueClose = '&Close';\r\n RsODSContinueAll = '&All';\r\n RsODSGotoLastFetchRecords = 'Goto Last - Fetch Records';\r\n RsODSFetchRecords = 'Fetch Records';\r\n RsODSOpenQueryFetchRecords = 'Open Query - Fetch Records';\r\n RsODSFetchRecordsCancel = 'Fetch Records - Cancel';\r\n RsODSOpenQuery = 'Open Query';\r\n RsODSOpenQueryCancel = 'Open Query - Cancel' ;\r\n RsODSRefreshQueryFetchRecords = 'Refresh Query - Fetch Records';\r\n RsODSRefreshQuery = 'Refresh Query';\r\n RsODSRefreshQueryCancel = 'Refresh Query - Cancel';\r\n\r\n//=== JvPageSetup.pas ========================================================\r\nresourcestring\r\n RsEInvalidValue = 'Value must be greater than zero';\r\n\r\n//=== JvPainterQBForm.pas ====================================================\r\nresourcestring\r\n RsPainterQuickBackdrops = 'Painter Quick Backdrops';\r\n RsEnterName = 'Enter Name:';\r\n RsNoItemSelected = 'No item selected!';\r\n RsErrorInPresets = 'Error in Presets';\r\n\r\n//=== JvParameterList.pas ====================================================\r\nresourcestring\r\n RsErrParameterMustBeEntered = 'Parameter \"%s\" must be entered!';\r\n\r\n RsHistorySelectPath = 'History';\r\n\r\n RsDialogCaption = '';\r\n RsCancelButton = '&Cancel';\r\n RsHistoryLoadButton = '&Load';\r\n RsHistorySaveButton = '&Save';\r\n RsHistoryClearButton = 'Cl&ear';\r\n RsHistoryLoadCaption = 'Load Parameter Settings';\r\n RsHistorySaveCaption = 'Save Parameter Settings';\r\n RsHistoryClearCaption = 'Manage Parameter Settings';\r\n\r\n RsENoParametersDefined = 'TJvParameterList.ShowParameterDialog: No Parameters defined';\r\n RsEAddObjectWrongObjectType = 'TJvParameterList.AddObject: Wrong object type';\r\n RsEAddObjectSearchNameNotDefined = 'TJvParameterList.AddObject: SearchName not defined';\r\n RsEAddObjectDuplicateSearchNamesNotAllowed = 'TJvParameterList.AddObject: Duplicate SearchNames (\"%s\") not allowed';\r\n RsECreateWinControlsOnWinControlDuplicateBeforeAfterNotAllowed = 'TJvParameterList.CreateWinControlsOnWinControl: %s \"%s\" already used';\r\n\r\n//=== JvParameterListParameter.pas ===========================================\r\nresourcestring\r\n // RsErrParameterMustBeEntered = 'Parameter %s must be entered!';\r\n RsErrParameterIsNotAValidNumber = 'Parameter %0:s: %1:s is not a valid number value!';\r\n RsErrParameterMustBeBetween = 'Parameter %0:s: %1:s must be between %2:s and %3:s!';\r\n RsErrParameterFileDoesNotExist = 'Parameter %0:s: The file \"%1:s\" does not exist!';\r\n RsErrParameterFileExistOverwrite = 'Parameter %0:s: The file \"%1:s\" exists! Overwrite?';\r\n RsErrParameterDirectoryNotExist = 'Parameter %0:s: The directory \"%1:s\" does not exist!';\r\n\r\n//=== JvParameterListTools.pas ===============================================\r\nresourcestring\r\n RsSelectCaption = 'Select...';\r\n\r\n//=== JvParserForm.pas =======================================================\r\nresourcestring\r\n RsNewObject = 'New';\r\n\r\n//=== JvPatchForm.pas ========================================================\r\nresourcestring\r\n RsJvPatcherEditorComparingFilesd = 'Jv - Patcher Editor: Comparing files %d%%';\r\n RsJvPatcherEditorEndStep = 'Jv - Patcher Editor: end step ...';\r\n RsErrJvPatcherEditorInvalidFilename = 'Invalid filename(s). Please specify valid filenames for both source and destination and try again.';\r\n\r\n//=== JvPcx.pas ==============================================================\r\nresourcestring\r\n RsPcxExtension = 'pcx';\r\n RsPcxFilterName = 'PCX Image';\r\n\r\n RsEPcxUnknownFormat = 'PCX: Unknown format';\r\n RsEPcxPaletteProblem = 'PCX: Unable to retrieve palette';\r\n RsEPcxInvalid = 'PCX: Invalid PCX file';\r\n\r\n//=== JvPerfMon95.pas ========================================================\r\nresourcestring\r\n RsWrongOS = 'TJvPerfMon95 component is intended for Win95/98 only';\r\n\r\n RsECantOpenPerfKey = 'Performance registry key not found';\r\n RsECantStart = 'Cannot start performance statistics (%s)';\r\n RsECantStop = 'Cannot stop performance statistics (%s)';\r\n RsEKeyNotExist = 'Specified key \"%s\" does not exist';\r\n\r\n//=== JvPickDate.pas =========================================================\r\nresourcestring\r\n RsNextYearHint = 'Next Year|';\r\n RsNextMonthHint = 'Next Month|';\r\n RsPrevYearHint = 'Previous Year|';\r\n RsPrevMonthHint = 'Previous Month|';\r\n\r\n//=== JvPlugin.pas ===========================================================\r\nresourcestring\r\n RsEFmtResNotFound = 'Resource not found: %s';\r\n\r\n//=== JvPluginManager.pas ====================================================\r\nresourcestring\r\n RsEErrEmptyExt = 'Extension may not be empty';\r\n RsEPluginPackageNotFound = 'Plugin package not found: %s';\r\n RsERegisterPluginNotFound = 'Plugin function %0:s not found in %1:s';\r\n RsERegisterPluginFailed = 'Calling %0:s in %1:s failed';\r\n\r\n//=== JvPoweredBy.pas ========================================================\r\nresourcestring\r\n RsURLPoweredByJCL = 'http://jcl.delphi-jedi.org/';\r\n RsURLPoweredByJVCL = 'http://jvcl.delphi-jedi.org/';\r\n\r\n//=== JvProfilerForm.pas =====================================================\r\nresourcestring\r\n RsTotalElapsedTimedms = '%0:s - total elapsed time: %1:d (ms)';\r\n RsTextFormatsasctxtinfdocAllFiles = 'Text formats|*.asc;*.txt;*.inf;*.doc|All files|*.*';\r\n RsDefCaption = 'Profiler 32 Report';\r\n RsDefHeader = 'Profiler 32 run %0:s by \"%1:s\" (machine %2:s).';\r\n\r\n RsEMaxNumberOfIDsExceededd = 'Max number of ID''s exceeded (%d)';\r\n RsEMaxStackSizeExceededd = 'Max stack size exceeded (%d)';\r\n\r\n//=== JvProgramVersionCheck.pas ==============================================\r\nresourcestring\r\n RsPVFailedUnableToConnectTo = 'Failed: Unable to connect to %s';\r\n RsPVFailedUnableToGet = 'Failed: Unable to get %s';\r\n RsPVDownloadFailed = 'Failed: %s';\r\n RsPVDefaultVersioninfoFileName = 'versioninfo.ini';\r\n RsPVTempFileNameExtension = '.temp';\r\n RsPVSiceB = '%6f B';\r\n RsPVSiceKB = '%6.2f KB';\r\n RsPVSiceMB = '%6.2f MB';\r\n RsPVSiceGB = '%6.2f GB';\r\n RsPVCReleaseTypeAlpha = 'Alpha';\r\n RsPVCReleaseTypeBeta = 'Beta';\r\n RsPVCReleaseTypeProduction = 'Production';\r\n\r\n RsPVCDownloading = 'Downloading ...';\r\n RsPVCDialogCaption = '%s Upgrade Check';\r\n RsPVCDialogExecuteButton = '&Execute';\r\n RsPVCNewVersionAvailable = 'A new version (%0:s) of %1:s is available!';\r\n RsPVCChooseWhichVersion = 'Which &version do you want to install?';\r\n RsPVCChooseOperation = '&Choose Operation';\r\n RsPVCOperationIgnore = 'I&gnore';\r\n RsPVCOperationDownloadOnly = 'Download/Copy &Only';\r\n RsPVCOperationDownloadInstall = 'Download/Copy and &Install';\r\n RsPVCWhatNewInS = 'What''s new in %s';\r\n RsPVCChangesBetween = 'Changes between %0:s and %1:s';\r\n RsPVCFileDownloadNotSuccessful =\r\n 'The file download was not successful!' + sLineBreak + 'Please try again manually.';\r\n RsPVCDownloadSuccessfulInstallManually =\r\n 'The file download was successful.' + sLineBreak + 'Install manually from: %s';\r\n RsPVCErrorStartingSetup = 'Error starting the setup process.';\r\n RsPVCDownloadSuccessfullInstallNow =\r\n 'The file download was successful.' + sLineBreak +\r\n 'Do you want to close and install?';\r\n RsPVInfoButtonCaption = 'Info';\r\n RSProgramVersionInfo_PropertyHint_ProgramReleaseDate = 'Date of Release ';\r\n RSProgramVersionInfo_PropertyHint_ProgramSize = 'Size of the installer in bytes ';\r\n RSProgramVersionInfo_PropertyHint_ProgramReleaseType = 'Release type of the version.'#13#10+\r\n 'In the update dialog there are only the highest version numbers for each type visible.'#13#10+\r\n 'The type must be higher then AllowedReleaseType property of the TJvProgramVersionCheck component';\r\n RSProgramVersionInfo_PropertyHint_VersionDescription = 'This is a description field which could be shown in the update dialog via the version info button.';\r\n RSProgramVersionInfo_PropertyHint_ProgramVersion = 'Program version in the format
... This property is compared with the fileversion properties of the current application.';\r\n RSProgramVersionInfo_PropertyHint_ProgramLocationFileName = 'File name of the installer file ';\r\n RSProgramVersionInfo_PropertyHint_ProgramLocationPath = 'Path where the installer of the version could be found. This could be a absolute path or a relative path to the location of the version list';\r\n RSProgramVersionInfo_PropertyHint_LocalInstallerParams = 'List of parameters for the execution of the installer file';\r\n RSProgramVersionInfo_PropertyHint_DownloadPassword = 'Flag to define whether a password is required for the download or not';\r\n RSProgramVersionInfo_ObjectHint = 'Class to collect all informations about a program version'#13#10+\r\n 'These informations will be stored in a file on the remote site';\r\n RSProgramVersionHistory_PropertyHint_alpha = 'Auto calculated version number of the highest alpha version';\r\n RSProgramVersionHistory_PropertyHint_beta = 'Auto calculated version number of the highest beta version';\r\n RSProgramVersionHistory_PropertyHint_Production = 'Auto calculated version number of the highest production version';\r\n RSProgramVersionHistory_ObjectHint = 'Class to define a list of program version informations. This class is used '+\r\n 'to detect which versions are available. Allso the informations will be used '+\r\n 'in the version info dialog';\r\n RSProgramVersionHistory = 'Program Version History';\r\n\r\n//=== JvPropertyStore.pas ====================================================\r\nresourcestring\r\n RsJvPropertyStoreMutexStorePropertiesProcedureName = 'TJvCustomPropertyStore.StoreProperties:';\r\n RsJvPropertyStoreMutexLoadPropertiesProcedureName = 'TJvCustomPropertyStore.LoadProperties:';\r\n RsJvPropertyStoreMutexLoadStorePropertiesProcedureName = 'TJvCustomPropertyStore.LoadStoreProperties:';\r\n RsJvPropertyStoreEnterMutexTimeout = '%s: Mutex Timeout';\r\n\r\n//=== JvPropertyStoreEditor.pas ====================================================\r\nresourcestring\r\n RSPropertyStoreEditorDialogButtonOk = '&Ok';\r\n RSPropertyStoreEditorDialogButtonCancel = '&Cancel';\r\n RSPropertyStoreEditorListButtonInsert = '&Insert';\r\n RSPropertyStoreEditorListButtonCopy = '&Copy';\r\n RSPropertyStoreEditorListButtonEdit = '&Edit';\r\n RSPropertyStoreEditorListButtonDelete = '&Delete';\r\n RSPropertyStoreEditorListButtonUp = '&Up';\r\n RSPropertyStoreEditorListButtonDown = 'Do&wn';\r\n RSPropertyStoreEditorListButtonSortUp = 'Sort &Asc';\r\n RSPropertyStoreEditorListButtonSortDown = 'Sort Desc';\r\n RSPropertyStoreEditorDialogCaptionEditProperties = 'Edit Properties';\r\n RSPropertyStoreEditorDeleteEntry = 'Delete Entry?';\r\n\r\n//=== JvPrvwRender.pas =======================================================\r\nresourcestring\r\n RsEAPrintPreviewComponentMustBeAssigne = 'A PrintPreview component must be assigned in CreatePreview!';\r\n RsEARichEditComponentMustBeAssignedInC = 'A RichEdit component must be assigned in CreatePreview!';\r\n RsECannotPerfromThisOperationWhilePrin = 'Cannot perfrom this operation while printing!';\r\n RsEPrinterNotAssigned = 'Printer not assigned!';\r\n RsENoPrintPreviewAssigned = 'No PrintPreview assigned!';\r\n\r\n//=== JvRas32.pas ============================================================\r\nresourcestring\r\n RsRasDllName = 'RASAPI32.DLL';\r\n\r\n RsERasError = 'RAS: Unable to find RasApi32.dll';\r\n\r\n//=== JvRegistryTreeview.pas =================================================\r\nresourcestring\r\n RsDefaultCaption = '(Default)';\r\n RsMyComputer = 'My Computer';\r\n RsDefaultNoValue = '(value not set)';\r\n RsUnknownCaption = '(Unknown)';\r\n\r\n//=== JvRichEdit.pas =========================================================\r\nresourcestring\r\n RsRTFFilter = 'Rich Text Format (*.rtf)|*.rtf';\r\n RsTextFilter = 'Plain text (*.txt)|*.txt';\r\n\r\n RsEConversionError = 'Conversion error %.8x';\r\n RsEConversionBusy = 'Cannot execute multiple conversions';\r\n RsECouldNotInitConverter = 'Could not initialize converter';\r\n RsEDiskFull = 'Out of space on output';\r\n RsEDocTooLarge = 'Conversion document too large for target';\r\n RsEInvalidDoc = 'Invalid document';\r\n RsEInvalidFile = 'Invalid data in conversion file';\r\n RsENoMemory = 'Out of memory';\r\n RsEOpenConvErr = 'Error opening conversion file';\r\n RsEOpenExceptErr = 'Error opening exception file';\r\n RsEOpenInFileErr = 'Could not open input file';\r\n RsEOpenOutFileErr = 'Could not open output file';\r\n RsEReadErr = 'Error during read';\r\n RsEUserCancel = 'Conversion cancelled by user';\r\n RsEWriteErr = 'Error during write';\r\n RsEWriteExceptErr = 'Error writing exception file';\r\n RsEWrongFileType = 'Wrong file type for this converter';\r\n\r\n//=== JvSAL.pas ==============================================================\r\nresourcestring\r\n RsEBooleanStackOverflow = 'Boolean stack overflow';\r\n RsEBooleanStackUnderflow = 'Boolean stack underflow';\r\n RsEProgramStopped = 'Program stopped';\r\n RsEUnterminatedIncludeDirectiveNears = 'Unterminated include directive near %s';\r\n RsEOngetUnitEventHandlerIsNotAssigned = 'OngetUnit event handler is not assigned';\r\n RsECouldNotIncludeUnits = 'Could not include unit %s';\r\n RsEUnterminatedCommentNears = 'Unterminated comment near %s';\r\n RsEUnterminatedProcedureNears = 'Unterminated procedure near %s';\r\n RsEVariablesAllreadyDefineds = 'Variable %0:s already defined;%1:s';\r\n RsEVariablesIsNotYetDefineds = 'Variable %0:s is not yet defined;%1:s';\r\n RsEProceduresNears = 'Procedure %0:s near %1:s';\r\n RsEUndefinedProcedures = 'Undefined procedure %s';\r\n RsECouldNotFindEndOfProcedure = 'Could not find end of procedure';\r\n\r\n//=== JvSALCore.pas ==========================================================\r\nresourcestring\r\n RsEVariablesIsNotInitialized = 'Variable %s is not initialized';\r\n RsEDivisionByZeroError = 'Division by zero error';\r\n RsEMissingendselect = 'Missing \"endselect\"';\r\n\r\n//=== JvSchedEvtStore.pas ====================================================\r\nresourcestring\r\n RsEStructureStackIsEmpty = 'Structure stack is empty';\r\n RsEScheduleIsActiveReadingANewSchedule =\r\n 'Schedule is active. Reading a new schedule can only be done on inactive schedules';\r\n RsEScheduleIsActiveStoringOfAScheduleC =\r\n 'Schedule is active. Storing of a schedule can only be done on inactive schedules';\r\n RsENotImplemented_ = 'not implemented';\r\n RsENotASchedule = 'Not a schedule';\r\n RsEUnknownScheduleVersions = 'Unknown schedule version ($%s)';\r\n RsEUnexpectedStructure = 'Unexpected structure';\r\n RsEIncorrectIdentifierFound = 'Incorrect identifier found';\r\n RsEIncorrectStructure = 'Incorrect structure found';\r\n\r\n//=== JvScheduledEvents.pas ==================================================\r\nresourcestring\r\n RsECannotRestart = 'Cannot restart: Event is being triggered or is executing';\r\n\r\n//=== JvScrollMax.pas ========================================================\r\nresourcestring\r\n RsRightClickAndChooseAddBand = 'Right click and choose \"Add band\"';\r\n\r\n { (rom) deactivated see DefineCursor in JvScrollMax.pas\r\n RsECannotLoadCursorResource = 'Cannot load cursor resource';\r\n RsETooManyUserdefinedCursors = 'Too many user-defined cursors';\r\n }\r\n RsETJvScrollMaxBandCanBePutOnlyIntoTJv = 'TJvScrollMaxBand can be put only into TJvScrollMax component';\r\n RsETJvScrollMaxCanContainOnlyTJvScroll = 'TJvScrollMax can contain only TJvScrollMaxBand components';\r\n RsEControlsNotAChildOfs = 'Control %0:s not a child of %1:s';\r\n\r\n//=== JvSegmentedLEDDisplay.pas ==============================================\r\nresourcestring\r\n RsEInvalidClass = 'Invalid class';\r\n RsEInvalidMappingFile = 'Invalid mapping file';\r\n RsEDuplicateDigitClass = 'Duplicate DigitClass registered';\r\n\r\n//=== JvSegmentedLEDDisplayMapperFrame.pas ===================================\r\nresourcestring\r\n RsTheCurrentCharacterHasBeenModifiedA = 'The current character has been modified. Apply changes?';\r\n RsTheCurrentMappingHasBeenModifiedSav = 'The current mapping has been modified. Save changes to file?';\r\n RsSegmentedLEDDisplayMappingFilessdms = 'Segmented LED display mapping files (*.sdm)|*.sdm|All files (*.*)|*.*';\r\n RsSelectCharacter = 'Select character...';\r\n RsSpecifyANewCharacter = 'Specify a new character';\r\n\r\n//=== JvSHFileOperation.pas ==================================================\r\nresourcestring\r\n RsENoFilesSpecifiedToTJvSHFileOperatio = 'No files specified to TJvSHFileOperation Execute function';\r\n\r\n//=== JvSpeedbar.pas =========================================================\r\nresourcestring\r\n RsEAutoSpeedbarMode = 'Cannot set this property value while Position is bpAuto';\r\n\r\n//=== JvSpeedbarSetupForm.pas ================================================\r\nresourcestring\r\n RsCustomizeSpeedbar = 'Customize Speedbar';\r\n RsAvailButtons = '&Available buttons:';\r\n RsSpeedbarCategories = '&Categories:';\r\n RsSpeedbarEditHint = 'To add command buttons, drag and drop buttons onto the SpeedBar.' +\r\n ' To remove command buttons, drag them off the SpeedBar.';\r\n\r\n//=== JvSpellChecker.pas =====================================================\r\nresourcestring\r\n RsENoSpellCheckerAvailable = 'No IJvSpellChecker implementation available!';\r\n\r\n//=== JvSpellerForm.pas ======================================================\r\nresourcestring\r\n RsENoDictionaryLoaded = 'No dictionary loaded';\r\n\r\n//=== JvSpin.pas =============================================================\r\nresourcestring\r\n RsEOutOfRangeFloat = 'Value must be between %0:g and %1:g';\r\n\r\n//=== JvStatusBar.pas ========================================================\r\nresourcestring\r\n RsEInvalidControlSelection = 'Invalid control selection';\r\n\r\n//=== JvSticker.pas ==========================================================\r\nresourcestring\r\n RsEditStickerCaption = 'Edit sticker';\r\n\r\n//=== JvStringHolder.pas =====================================================\r\nresourcestring\r\n RsENoItemFoundWithName = 'No item found with name \"%s\"';\r\n\r\n//=== JvStrings.pas ==========================================================\r\nresourcestring\r\n RsECannotLoadResource = 'Cannot load resource: %s';\r\n RsEIncorrectStringFormat = 'Base64: Incorrect string format';\r\n\r\n//=== JvSyncSplitter.pas =====================================================\r\nresourcestring\r\n RsEInvalidPartner = 'TJvSyncSplitter.SetPartner: cannot set Partner to Self!';\r\n\r\n//=== JvSysRequirements.pas ==================================================\r\nresourcestring\r\n RsSysRequirementsCaption = 'System Requirements for %s';\r\n RsMinColorDepthReq = 'The color depth must be at least %1:d bits per pixel, but is only %0:d bits per pixel.';\r\n RsMaxColorDepthReq = 'The color depth cannot be more than %1:d bits per pixel, but is %0:d bits per pixel.';\r\n RsBetweenColorDepthReq = 'The color depth must be between %1:d and %2:d bits per pixel, but is %0:d bits per pixel.';\r\n RsMinScreenXReq = 'The horizontal screen resolution must be at least %1:d pixels, but is only %0:d pixels.';\r\n RsMaxScreenXReq = 'The horizontal screen resolution cannot be more than %1:d pixels, but is %0:d pixel.';\r\n RsBetweenScreenXReq = 'The horizontal screen resolution must be between %1:d and %2:d pixels, but is %0:d pixel.';\r\n RsMinScreenYReq = 'The vertical screen resolution must be at least %1:d pixels, but is only %0:d pixels.';\r\n RsMaxScreenYReq = 'The vertical screen resolution cannot be more than %1:d pixels, but is %0:d pixel.';\r\n RsBetweenScreenYReq = 'The vertical screen resolution must be between %1:d and %2:d pixels, but is %0:d pixel.';\r\n RsMinRefreshReq = 'The video refresh rate must be at least %1:d Hertz, but is only %0:d Hertz.';\r\n RsMaxRefreshReq = 'The video refresh rate cannot be more than %1:d Hertz, but is %0:d Hertz.';\r\n RsBetweenRefreshReq = 'The video refresh rate must be between %1:d and %2:d Hertz, but is %0:d Hertz.';\r\n RsWindowsVersionReq = 'This version of Windows is not supported.';\r\n RsSystemFontSmallReq = 'The system does not use small fonts.';\r\n RsSystemFontBigReq = 'The system does not use big fonts.';\r\n\r\n//=== JvSystemPopup.pas ======================================================\r\nresourcestring\r\n RsEAlreadyHooked = 'TJvSystemPopup.Hook: already hooked';\r\n\r\n//=== JvTFDays.pas ===========================================================\r\nresourcestring\r\n RsEInvalidPrimeTimeStartTime = 'Invalid PrimeTime StartTime';\r\n RsEInvalidPrimeTimeEndTime = 'Invalid PrimeTime EndTime';\r\n RsEColumnIndexOutOfBounds = 'Column index out of bounds';\r\n RsERowIndexOutOfBounds = 'Row index out of bounds';\r\n RsEMapColNotFoundForAppointment = 'Map column not found for appointment';\r\n RsECorruptAppointmentMap = 'Corrupt appointment map';\r\n RsEGridGranularityCannotBeGreater = 'Grid granularity cannot be greater ' +\r\n 'than the time block granularity';\r\n RsETimeBlockGranularityMustBeEvenly = 'Time block granularity must be evenly ' +\r\n 'divisible by the grid granularity';\r\n RsETimeBlocksMustBeginExactlyOn = 'Time blocks must begin exactly on ' +\r\n 'a grid time division';\r\n RsEGridEndTimeCannotBePriorToGridStart = 'GridEndTime cannot be prior to GridStartTime';\r\n RsEGridStartTimeCannotBeAfterGridEndTi = 'GridStartTime cannot be after GridEndTime';\r\n RsEInvalidRowd = 'Invalid row (%d)';\r\n RsEThereIsNoDataToPrint = 'There is no data to print';\r\n RsENoPageInfoExists = 'No page info exists. ' +\r\n 'Document must be prepared';\r\n RsEATimeBlockNameCannotBeNull = 'A time block name cannot be null';\r\n RsEAnotherTimeBlockWithTheName = 'Another time block with the name \"%s\" already exists';\r\n RsEATimeBlockWithTheNamesDoesNotExist = 'A time block with the name \"%s\" does not exist';\r\n\r\n//=== JvTFGantt.pas ==========================================================\r\nresourcestring\r\n RsThisIsTheMajorScale = 'This is the Major Scale';\r\n RsThisIsTheMinorScale = 'This is the Minor Scale';\r\n\r\n//=== JvTFGlance.pas =========================================================\r\nresourcestring\r\n RsECellDatesCannotBeChanged = 'Cell Dates cannot be changed';\r\n RsECellMapHasBeenCorrupteds = 'Cell map has been corrupted %s';\r\n RsECellObjectNotAssigned = 'Cell object not assigned';\r\n RsEInvalidColIndexd = 'Invalid col index (%d)';\r\n RsEInvalidRowIndexd = 'Invalid row index (%d)';\r\n RsEApptIndexOutOfBoundsd = 'Appt index out of bounds (%d)';\r\n RsECellCannotBeSplit = 'Cell cannot be split';\r\n RsEASubcellCannotBeSplit = 'A subcell cannot be split';\r\n RsGlanceMainTitle = '(Title)';\r\n\r\n//=== JvTFGlanceTextViewer.pas ===============================================\r\nresourcestring\r\n RsEGlanceControlNotAssigned = 'GlanceControl not assigned';\r\n\r\n//=== JvTFManager.pas ========================================================\r\nresourcestring\r\n RsECouldNotCreateCustomImageMap = 'Could not create CustomImageMap. ' +\r\n 'Appointment not assigned';\r\n RsECouldNotCreateAppointmentObject = 'Could not create Appointment object. ' +\r\n 'ScheduleManager not assigned';\r\n RsEScheduleManagerNotificationFailedSc = 'ScheduleManager notification failed. ScheduleManager not assigned';\r\n RsEScheduleNotificationFailed = 'Schedule notification failed. ' +\r\n 'Schedule not assigned';\r\n RsEInvalidStartAndEndTimes = 'Invalid start and end times';\r\n RsEInvalidStartAndEndDates = 'Invalid start and end dates';\r\n RsEAppointmentNotificationFailed = 'Appointment notification failed. ' +\r\n 'Appointment not assigned';\r\n RsECouldNotCreateNewAppointment = 'Could not create new appointment. ' +\r\n 'Appointment with given ID already exists';\r\n RsEInvalidTriggerForRefreshControls = 'Invalid Trigger for RefreshControls';\r\n RsEInvalidScopeInReconcileRefresh = 'Invalid Scope in ReconcileRefresh';\r\n RsECouldNotRetrieveSchedule = 'Could not retrieve schedule. ' +\r\n 'ScheduleManager not assigned';\r\n RsECouldNotReleaseSchedule = 'Could not release schedule. ' +\r\n 'ScheduleManager not assigned';\r\n RsECouldNotCreateADocumentBecauseA = 'Could not create a document because a ' +\r\n 'document already exists';\r\n RsECouldNotFinishDocumentBecauseNo = 'Could not finish document because no ' +\r\n 'document has been created';\r\n RsEDocumentDoesNotExist = 'Document does not exist';\r\n RsEDocumentPagesCannotBeAccessedIf = 'Document pages cannot be accessed if ' +\r\n 'printing directly to the printer';\r\n RsEDocumentPagesAreInaccessibleUntil = 'Document pages are inaccessible until ' +\r\n 'the document has been finished';\r\n RsECouldNotRetrievePageCount = 'Could not retrieve page count ' +\r\n 'because document does not exist';\r\n RsEOnlyAFinishedDocumentCanBePrinted = 'Only a finished document can be printed';\r\n RsEThereAreNoPagesToPrint = 'There are no pages to print';\r\n RsEDocumentMustBeFinishedToSaveToFile = 'Document must be Finished to save to file';\r\n RsEThisPropertyCannotBeChangedIfA = 'This property cannot be changed if a ' +\r\n 'document exists';\r\n RsECouldNotCreateTJvTFPrinterPageLayou = 'Could not create TJvTFPrinterPageLayout ' +\r\n 'because aPrinter must be assigned';\r\n RsEInvalidFooterHeightd = 'Invalid Footer Height (%d)';\r\n RsEInvalidHeaderHeightd = 'Invalid Header Height (%d)';\r\n\r\n//=== JvTFSparseMatrix.pas ===================================================\r\nresourcestring\r\n RsEMatrixMustBeEmpty = 'Matrix must be empty before setting null value';\r\n\r\n//=== JvTFUtils.pas ==========================================================\r\nresourcestring\r\n RsEResultDoesNotFallInMonth = 'Result does not fall in given month';\r\n RsEInvalidMonthValue = 'Invalid Month Value (%d)';\r\n RsEInvalidDayOfWeekValue = 'Invalid value for day of week (%d)';\r\n\r\n//=== JvTFWeeks.pas ==========================================================\r\nresourcestring\r\n RsWeekOf = 'Week of %s';\r\n\r\n//=== JvThreadDialog.pas =====================================================\r\nresourcestring\r\n RsENotATJvThread = 'TJvCustomThreadDialogForm.SetConnectedThread: A thread must be a TJvThread-Component';\r\n\r\n//=== JvThumbImage.pas =======================================================\r\nresourcestring\r\n RsEUnknownFileExtension = 'Unknown file extension %s';\r\n RsFileFilters = '|PCX Files(*.pcx)|*.pcx|Targa Files(*.tga)|*.tga';\r\n RsPcxTga = '*.pcx;*.tga;';\r\n\r\n//=== JvThumbnails.pas =======================================================\r\nresourcestring\r\n RsUnknown = 'Unknown';\r\n\r\n//=== JvTimer.pas ============================================================\r\nresourcestring\r\n RsCannotChangeInTimerEvent = 'Cannot change %s in the timer event';\r\n\r\n//=== JvTimeLimit.pas ========================================================\r\nresourcestring\r\n RsExpired = 'The test period has expired, please register this application';\r\n\r\n//=== JvTimeList.pas =========================================================\r\nresourcestring\r\n RsEOwnerMustBeTJvTimerList = 'Owner of TJvTimerEvents must be a TJvTimerList';\r\n\r\n//=== JvTipOfDay.pas =========================================================\r\nresourcestring\r\n RsCloseCaption = '&Close';\r\n RsNextCaption = '&Next Tip';\r\n RsTipsTitle = 'Tips and Tricks';\r\n RsTipsHeaderText = 'Did you know...';\r\n RsTipsCheckBoxText = '&Show Tips on Startup';\r\n RsStoreShowOnStartUp = 'Show_On_Startup'; // (p3) Spaces in XML node names is not valid XML...\r\n\r\n//=== JvToolEdit.pas =========================================================\r\nresourcestring\r\n RsBrowseCaption = 'Browse';\r\n {$IFDEF MSWINDOWS}\r\n RsDefaultFilter = 'All files (*.*)|*.*';\r\n {$ENDIF MSWINDOWS}\r\n {$IFDEF UNIX}\r\n RsDefaultFilter = 'All files (*)|*';\r\n {$ENDIF UNIX}\r\n\r\n { Polaris patch }\r\n RsEDateMinLimit = 'Enter a date before \"%s\"';\r\n RsEDateMaxLimit = 'Enter a date after \"%s\"';\r\n\r\n//=== JvTurtle.pas ===========================================================\r\nresourcestring\r\n RsErrorCanvasNotAssigned = 'Canvas not assigned';\r\n RsEmptyScript = 'Empty script';\r\n RsInvalidIntegerIns = 'Invalid integer in %s';\r\n RsInvalidColorIns = 'Invalid color in %s';\r\n RsInvalidCopyMode = 'Invalid copy mode';\r\n RsInvalidPenMode = 'Invalid pen mode';\r\n RsInvalidTextIns = 'Invalid text in %s';\r\n RsMissingFontname = 'Missing fontname';\r\n RsNumberExpectedIns = 'Number expected in %s';\r\n RsNumberStackUnderflow = 'Number stack underflow';\r\n RsNumberStackOverflow = 'Number stack overflow';\r\n RsMissingAfterComment = 'Missing \"}\" after comment';\r\n RsErrorIns = 'Error in %s';\r\n RsDivisionByZero = 'Division by zero';\r\n RsInvalidParameterIns = 'Invalid parameter in %s';\r\n RsSymbolsIsNotDefined = 'Symbol %s is not defined';\r\n RsMissingAfterBlock = 'Missing \"]\" after block';\r\n RsStackUnderflowIns = 'Stack underflow in %s';\r\n RsSymbolExpectedAfterIf = 'Symbol expected after if';\r\n RsCanNotTakeSqrtOf = 'Can not take sqrt of 0';\r\n RsNotAllowedIns = '0 not allowed in %s';\r\n RsNeedMinimumOfSidesIns = 'Need minimum of 3 sides in %s';\r\n RsMaximumSidesExceededIns = 'Maximum 12 sides exceeded in %s';\r\n RsTokenExpected = 'Token expected';\r\n RssDoesNotExist = '%s does not exist';\r\n RsDivisionByZeroNotAllowedInIn = 'Division by zero not allowed in in-';\r\n RsStackOverflow = 'Stack overflow';\r\n RsStackUnderflow = 'Stack underflow';\r\n\r\n//=== JvTypes.pas ============================================================\r\nresourcestring\r\n RsClBlack = 'Black';\r\n RsClMaroon = 'Maroon';\r\n RsClGreen = 'Green';\r\n RsClOlive = 'Olive green';\r\n RsClNavy = 'Navy blue';\r\n RsClPurple = 'Purple';\r\n RsClTeal = 'Teal';\r\n RsClGray = 'Gray';\r\n RsClSilver = 'Silver';\r\n RsClRed = 'Red';\r\n RsClLime = 'Lime';\r\n RsClYellow = 'Yellow';\r\n RsClBlue = 'Blue';\r\n RsClFuchsia = 'Fuchsia';\r\n RsClAqua = 'Aqua';\r\n RsClWhite = 'White';\r\n RsClMoneyGreen = 'Money green';\r\n RsClSkyBlue = 'Sky blue';\r\n RsClCream = 'Cream';\r\n RsClMedGray = 'Medium gray';\r\n\r\n //Standrad colors\r\n RsClBrown = 'Brown';\r\n RsClOliveGreen = 'Olive Green';\r\n RsClDarkGreen = 'Dark Green';\r\n RsClDarkTeal = 'Dark Teal';\r\n RsClDarkBlue = 'Dark Blue';\r\n RsClIndigo = 'Indigo';\r\n RsClGray80 = 'Gray 80%';\r\n\r\n RsClDarkRed = 'Dark Red';\r\n RsClOrange = 'Orange';\r\n RsClDarkYellow = 'Dark Yellow';\r\n RsClBlueGray = 'Blue Gray';\r\n RsClGray50 = 'Gray 50%';\r\n\r\n RsClLightOrange = 'Light Orange';\r\n RsClSeaGreen = 'Sea Green';\r\n RsClLightBlue = 'Light Blue';\r\n RsClViolet = 'Violet';\r\n RsClGray40 = 'Gray 40%';\r\n\r\n RsClPink = 'Pink';\r\n RsClGold = 'Gold';\r\n RsClBrightGreen = 'Bright Green';\r\n RsClTurquoise = 'Turquoise';\r\n RsClPlum = 'Plum';\r\n RsClGray25 = 'Gray 25%';\r\n\r\n RsClRose = 'Rose';\r\n RsClTan = 'Tan';\r\n RsClLightYellow = 'Light Yellow';\r\n RsClLightGreen = 'Light Green';\r\n RsClLightTurquoise = 'Light Turquoise';\r\n RsClPaleBlue = 'Pale Blue';\r\n RsClLavender = 'Lavender';\r\n\r\n // windows system colors\r\n RsClScrollBar = 'Scrollbar';\r\n RsClBackground = 'Desktop background';\r\n RsClActiveCaption = 'Active window title bar';\r\n RsClInactiveCaption = 'Inactive window title bar';\r\n RsClMenu = 'Menu background';\r\n RsClWindow = 'Window background';\r\n RsClWindowFrame = 'Window frame';\r\n RsClMenuText = 'Menu text';\r\n RsClWindowText = 'Window text';\r\n RsClCaptionText = 'Active window title bar text';\r\n RsClActiveBorder = 'Active window border';\r\n RsClInactiveBorder = 'Inactive window border';\r\n RsClAppWorkSpace = 'Application workspace';\r\n RsClHighlight = 'Selection background';\r\n RsClHighlightText = 'Selection text';\r\n RsClBtnFace = 'Button face';\r\n RsClBtnShadow = 'Button shadow';\r\n RsClGrayText = 'Dimmed text';\r\n RsClBtnText = 'Button text';\r\n RsClInactiveCaptionText = 'Inactive window title bar text';\r\n RsClBtnHighlight = 'Button highlight';\r\n RsCl3DDkShadow = 'Dark shadow 3D elements';\r\n RsCl3DLight = 'Highlight 3D elements';\r\n RsClInfoText = 'Tooltip text';\r\n RsClInfoBk = 'Tooltip background';\r\n RsGradientActiveCaption ='Gradient Active Caption';\r\n RsGradientInactiveCaption ='Gradient Inactive Caption';\r\n RsHotLight ='Hot Light';\r\n RsMenuBar ='Menu Bar';\r\n RsMenuHighlight ='Menu Highlight';\r\n\r\n\r\n//=== JvUrlGrabbers.pas ======================================================\r\nresourcestring\r\n RsFileNotFoundFmt = 'File \"%s\" not found';\r\n\r\n//=== JvUrlListGrabber.pas ===================================================\r\nresourcestring\r\n RsENoGrabberForUrl = 'There is no grabber capable of handling URL: %s';\r\n RsEAtLeastOneGrabberRunning = 'There is at least one grabber running, you cannot change the URLs.';\r\n RsEGrabberNotStopped = 'The grabber is not stopped, you cannot change its URL.';\r\n\r\n RsJediAgent = 'JEDI-VCL';\r\n RsDefaultOutputFileName = 'output.txt';\r\n\r\n//=== JvValidateEdit.pas =====================================================\r\nresourcestring\r\n RsEBaseTooBig = 'Base > 36 not supported';\r\n RsEBaseTooSmall = 'Base must be greater than 1';\r\n\r\n//=== JvValidators.pas =======================================================\r\nresourcestring\r\n RsEInsertNilValidator = 'Cannot insert nil validator';\r\n RsERemoveNilValidator = 'Cannot remove nil validator';\r\n RsEValidatorNotChild = 'Validator is not owned by this component';\r\n RsEInvalidIndexd = 'Invalid index (%d)';\r\n\r\n//=== JvVirtualKeySelectionFrame.pas =========================================\r\nresourcestring\r\n RsNoValidKeyCode = 'This is not a valid key code';\r\n RsInvalidKeyCode = 'Invalid key code';\r\n\r\n//=== JvWinampLabel.pas ======================================================\r\nresourcestring\r\n RsEInvalidSkin = 'Invalid skin';\r\n\r\n//=== JvWinDialogs.pas =======================================================\r\nresourcestring\r\n //SDiskFullError =\r\n // 'TJvDiskFullDialog does not support removable media or network drives.';\r\n RsEFunctionNotSupported = 'This function is not supported by your version of Windows';\r\n RsEInvalidDriveChar = 'Invalid drive (%s)';\r\n { make Delphi 5 compiler happy // andreas\r\n RsEUnsupportedDisk = 'Unsupported drive (%s): JvDiskFullDialog only supports fixed drives';}\r\n\r\n//=== JvWinHelp.pas ==========================================================\r\nresourcestring\r\n RsEOwnerForm = 'Owner must be of type TCustomForm';\r\n\r\n//=== JvWizard.pas ===========================================================\r\nresourcestring\r\n RsFirstButtonCaption = 'To &Start Page';\r\n RsLastButtonCaption = 'To &Last Page';\r\n RsFinishButtonCaption = '&Finish';\r\n RsWelcome = 'Welcome';\r\n RsTitle = 'Title';\r\n RsSubtitle = 'Subtitle';\r\n\r\n RsEInvalidParentControl = 'The Parent should be TJvWizard or a descendant';\r\n RsEInvalidWizardPage = 'The pages belong to another wizard';\r\n\r\n//=== JvWizardCommon.pas =====================================================\r\nresourcestring\r\n RsETilingError = 'Tiling only works on images with dimensions > 0';\r\n\r\n//=== JvWizardRouteMapSteps.pas ==============================================\r\nresourcestring\r\n RsActiveStepFormat = 'Step %0:d of %1:d';\r\n RsBackTo = 'Back to';\r\n RsNextStep = 'Next Step';\r\n\r\n//=== JvXmlDatabase.pas ======================================================\r\nresourcestring\r\n RsEUnknownInstruction = 'Unknown Instruction %s';\r\n RsEUnexpectedEndOfQuery = 'Unexpected end of query';\r\n RsEUnexpectedStatement = 'Unexpected statement %s';\r\n\r\n//=== JvXPBar.pas ============================================================\r\nresourcestring\r\n RsUntitled = 'untitled';\r\n RsUntitledFmt = '(%0:s %1:d)';\r\n RsHintShortcutFmt = '%0:s (%1:s)';\r\n\r\n//=== JvXPCore.pas ===========================================================\r\nresourcestring\r\n RsCopyright = 'Design eXperience. (c) 2002 M. Hoffmann Version ';\r\n RsCopyright2 = 'Design eXperience II - (c) 2002 M. Hoffmann Version ';\r\n RsVersion = '2.0.1'; // always increase version number on new releases!\r\n\r\n//=== JvYearGrid.pas =========================================================\r\nresourcestring\r\n RsYearGrid = 'YearGrid';\r\n RsEnterYear = 'Enter year (1999-2050):';\r\n RsInvalidYear = 'invalid year';\r\n RsYear = '&Year...';\r\n RsEdit = '&Edit';\r\n RsColor = '&Color...';\r\n RsNoColor = '&No Color';\r\n RsSaveAllInfo = '&Save All Info';\r\n RsSaveFoundInfo = 'Save Found Info';\r\n RsBorderColor = '&Border Color...';\r\n RsBookMarkColor = 'Book&Mark Color...';\r\n RsFindItem = '&Find...';\r\n RsClearFind = 'Clear Find';\r\n RsYearGridFind = 'YearGrid Find';\r\n RsEnterSeachText = 'Enter seach text:';\r\n RsFounds = 'Found %s';\r\n RsToday = 'Today ';\r\n\r\n//=== JvDBFilterExpr =========================================================\r\nresourcestring\r\n RsInvalidFilterNodeKind = 'Invalid filter node kind';\r\n RsUnknownFilterOperation = 'Unknown filter operator';\r\n RsUnknownFilterFunction = 'Unknown filter function \"%s\"';\r\n RsMissingFilterFunctionParameters = 'Missing filter function parameters for \"%s\"';\r\n\r\n//=== JvPanel ================================================================\r\nresourcestring\r\n RsDestroyingArrangeSettingsNotAllowed = 'Your code tried to destroy the TJvPanel.ArrangeSettings ' +\r\n 'objects leaving the panel in a broken state. Please fix your code by adding'#13#10#13#10 +\r\n ' if not ((Components[I] is TJvArrangeSettings) or'#13#10 +\r\n ' (Components[I] is TJvPanelHotTrackOptions)) then'#13#10#13#10 +\r\n 'or by using the Controls[] array property if possible.';\r\n\r\n//=== not taken into JVCL ====================================================\r\n{\r\nresourcestring\r\n // MathParser\r\n SParseSyntaxError = 'Syntax error';\r\n SParseNotCramp = 'Invalid condition (no cramp)';\r\n SParseDivideByZero = 'Divide by zero';\r\n SParseSqrError = 'Invalid floating operation';\r\n SParseLogError = 'Invalid floating operation';\r\n SParseInvalidFloatOperation = 'Invalid floating operation';\r\n // JvDBFilter\r\n SExprNotBoolean = 'Field ''%s'' is not of type Boolean';\r\n SExprBadNullTest = 'NULL only allowed with ''='' and ''<>''';\r\n SExprBadField = 'Field ''%s'' cannot be used in a filter expression';\r\n // JvDBFilter expression parser\r\n SExprIncorrect = 'Incorrectly formed filter expression';\r\n SExprTermination = 'Filter expression incorrectly terminated';\r\n SExprNameError = 'Unterminated field name';\r\n SExprStringError = 'Unterminated string constant';\r\n SExprInvalidChar = 'Invalid filter expression character: ''%s''';\r\n SExprNoRParen = ''')'' expected but %s found';\r\n SExprExpected = 'Expression expected but %s found';\r\n SExprBadCompare = 'Relational operators require a field and a constant';\r\n}\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvResources.pas $';\r\n Revision: '$Revision: 13379 $';\r\n Date: '$Date: 2012-07-08 22:33:32 +0200 (dim. 08 juil. 2012) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvRgbToHtml.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvRgbToHtml.PAS, released on 2001-02-28.\r\n\r\nThe Initial Developer of the Original Code is Sbastien Buysse [sbuysse att buypin dott com]\r\nPortions created by Sbastien Buysse are Copyright (C) 2001 Sbastien Buysse.\r\nAll Rights Reserved.\r\n\r\nContributor(s): Michael Beck [mbeck att bigfoot dott com].\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvRgbToHtml.pas 13104 2011-09-07 06:50:43Z obones $\r\n\r\nunit JvRgbToHtml;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n SysUtils, Classes, Windows, Graphics,\r\n JvComponentBase;\r\n\r\ntype\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64 or pidOSX32)]\r\n {$ENDIF RTL230_UP}\r\n TJvRGBToHTML = class(TJvComponent)\r\n private\r\n FHTMLColor: string;\r\n FRGBColor: TColor;\r\n procedure SetRGBColor(const Value: TColor);\r\n procedure SetHTMLColor(const Value: string);\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n published\r\n property RGBColor: TColor read FRGBColor write SetRGBColor default clBlack;\r\n property HTMLColor: string read FHTMLColor write SetHTMLColor;\r\n end;\r\n\r\nfunction RgbToHtml(Value: TColor): string;\r\nfunction HtmlToRgb(const Value: string): TColor;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvRgbToHtml.pas $';\r\n Revision: '$Revision: 13104 $';\r\n Date: '$Date: 2011-09-07 08:50:43 +0200 (mer. 07 sept. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\n\r\nfunction RgbToHtml(Value: TColor): string;\r\nbegin\r\n with TJvRGBToHTML.Create(nil) do\r\n try\r\n RGBColor := Value;\r\n Result := HTMLColor;\r\n finally\r\n Free;\r\n end;\r\nend;\r\n\r\nfunction HtmlToRgb(const Value: string): TColor;\r\nbegin\r\n with TJvRGBToHTML.Create(nil) do\r\n try\r\n HTMLColor := Value;\r\n Result := RGBColor;\r\n finally\r\n Free;\r\n end;\r\nend;\r\n\r\nconstructor TJvRGBToHTML.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n RGBColor := clBlack;\r\nend;\r\n\r\nprocedure TJvRGBToHTML.SetRGBColor(const Value: TColor);\r\nvar\r\n Clr: TColor;\r\nbegin\r\n FRGBColor := Value;\r\n Clr := ColorToRGB(Value);\r\n FHTMLColor := IntToHex(GetRValue(Clr), 2) + IntToHex(GetGValue(Clr), 2) + IntToHex(GetBValue(Clr), 2);\r\nend;\r\n\r\nprocedure TJvRGBToHTML.SetHTMLColor(const Value: string);\r\nvar\r\n C: TColor;\r\n R, G, B: Byte;\r\nbegin\r\n try\r\n if Length(Value) = 6 then\r\n begin\r\n R := StrToInt('$' + Copy(Value, 1, 2));\r\n G := StrToInt('$' + Copy(Value, 3, 2));\r\n B := StrToInt('$' + Copy(Value, 5, 2));\r\n C := RGB(R, G, B);\r\n FRGBColor := C;\r\n FHTMLColor := Value;\r\n end;\r\n except\r\n end;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvRichEdit.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvRichEd.PAS, released on 2002-07-04.\r\n\r\nThe Initial Developers of the Original Code are: Fedor Koshevnikov, Igor Pavluk and Serge Korolev\r\nCopyright (c) 1997, 1998 Fedor Koshevnikov, Igor Pavluk and Serge Korolev\r\nCopyright (c) 2001,2002 SGB Software\r\nPortions created by Sbastien Buysse are Copyright (C) 2001 Sbastien Buysse.\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\n Polaris Software\r\n Sbastien Buysse [sbuysse att buypin dott com] (original code in JvRichEdit.pas)\r\n Michael Beck [mbeck att bigfoot dott com] (contributor to JvRichEdit.pas)\r\n Roman Kovbasiouk [roko att users dott sourceforge dott net] (merging JvRichEdit.pas)\r\n Remko Bonte [remkobonte att myrealbox dott com] (insert image procedures, MS Text converters)\r\n Jacob Boerema [jgboerema att hotmail dott com] (indentation style, zoom, tab styles)\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvRichEdit.pas 13415 2012-09-10 09:51:54Z obones $\r\n\r\nunit JvRichEdit;\r\n\r\n{$I jvcl.inc}\r\n{$I windowsonly.inc}\r\n\r\n{$RANGECHECKS OFF}\r\n\r\ninterface\r\n\r\n{$HPPEMIT '#define CHARFORMAT2A Richedit::CHARFORMAT2A'}\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, ActiveX, ComObj, CommCtrl, Messages, SysUtils, Classes, Controls,\r\n OleCtnrs,\r\n Forms, Graphics, StdCtrls, Dialogs, RichEdit, Menus, ComCtrls, SyncObjs,\r\n JvExStdCtrls, JvTypes;\r\n\r\ntype\r\n TJvCustomRichEdit = class;\r\n\r\n TJvAttributeType = (atDefaultText, atSelected, atWord);\r\n TJvConsistentAttribute = (caBold, caColor, caFace, caItalic, caSize,\r\n caStrikeOut, caUnderline, caProtected, caOffset, caHidden, caCharset,\r\n caLink, caBackColor, caDisabled, caWeight, caSubscript, caRevAuthor);\r\n TJvConsistentAttributes = set of TJvConsistentAttribute;\r\n TSubscriptStyle = (ssNone, ssSubscript, ssSuperscript);\r\n TUnderlineType = (utNone, utSolid, utWord, utDouble, utDotted, utDash,\r\n utDashDot, utDashDotDot, utWave, utThick);\r\n TUnderlineColor = (ucBlack, ucBlue, ucAqua, ucLime, ucFuchsia, ucRed,\r\n ucYellow, ucWhite, ucNavy, ucTeal, ucGreen, ucPurple, ucMaroon, ucOlive,\r\n ucGray, ucSilver);\r\n\r\n TJvTextAttributes = class(TPersistent)\r\n private\r\n FRichEdit: TJvCustomRichEdit;\r\n FType: TJvAttributeType;\r\n procedure AssignFont(Font: TFont);\r\n procedure GetAttributes(var Format: TCharFormat2);\r\n procedure SetAttributes(var Format: RichEdit.TCharFormat2);\r\n function GetAttribute(const Flag: Integer): Boolean;\r\n function GetBackColor: TColor;\r\n function GetCharset: TFontCharset;\r\n function GetColor: TColor;\r\n function GetConsistentAttributes: TJvConsistentAttributes;\r\n function GetDisabled: Boolean;\r\n function GetHeight: Integer;\r\n function GetHidden: Boolean;\r\n function GetLink: Boolean;\r\n function GetName: TFontName;\r\n function GetOffset: Integer;\r\n function GetPitch: TFontPitch;\r\n function GetProtected: Boolean;\r\n function GetRevAuthorIndex: Byte;\r\n function GetSize: Integer;\r\n function GetStyle: TFontStyles;\r\n function GetSubscriptStyle: TSubscriptStyle;\r\n function GetUnderlineColor: TUnderlineColor;\r\n function GetUnderlineType: TUnderlineType;\r\n procedure SetAttribute(const Flag: Integer; const Value: Boolean);\r\n procedure SetBackColor(Value: TColor);\r\n procedure SetCharset(Value: TFontCharset);\r\n procedure SetColor(Value: TColor);\r\n procedure SetDisabled(Value: Boolean);\r\n procedure SetHeight(Value: Integer);\r\n procedure SetHidden(Value: Boolean);\r\n procedure SetLink(Value: Boolean);\r\n procedure SetName(Value: TFontName);\r\n procedure SetOffset(Value: Integer);\r\n procedure SetPitch(Value: TFontPitch);\r\n procedure SetProtected(Value: Boolean);\r\n procedure SetRevAuthorIndex(Value: Byte);\r\n procedure SetSize(Value: Integer);\r\n procedure SetStyle(Value: TFontStyles);\r\n procedure SetSubscriptStyle(Value: TSubscriptStyle);\r\n procedure SetUnderlineColor(const Value: TUnderlineColor);\r\n procedure SetUnderlineType(Value: TUnderlineType);\r\n protected\r\n procedure InitFormat(var Format: RichEdit.TCharFormat2);\r\n procedure AssignTo(Dest: TPersistent); override;\r\n public\r\n constructor Create(AOwner: TJvCustomRichEdit; AttributeType: TJvAttributeType);\r\n procedure Assign(Source: TPersistent); override;\r\n property BackColor: TColor read GetBackColor write SetBackColor;\r\n property Charset: TFontCharset read GetCharset write SetCharset;\r\n property Color: TColor read GetColor write SetColor;\r\n property ConsistentAttributes: TJvConsistentAttributes read GetConsistentAttributes;\r\n property Disabled: Boolean read GetDisabled write SetDisabled;\r\n property Height: Integer read GetHeight write SetHeight;\r\n property Hidden: Boolean read GetHidden write SetHidden;\r\n property Link: Boolean read GetLink write SetLink;\r\n property Name: TFontName read GetName write SetName;\r\n property Offset: Integer read GetOffset write SetOffset;\r\n property Pitch: TFontPitch read GetPitch write SetPitch;\r\n property Protected: Boolean read GetProtected write SetProtected;\r\n property RevAuthorIndex: Byte read GetRevAuthorIndex write SetRevAuthorIndex;\r\n property Size: Integer read GetSize write SetSize;\r\n property Style: TFontStyles read GetStyle write SetStyle;\r\n property SubscriptStyle: TSubscriptStyle read GetSubscriptStyle write SetSubscriptStyle;\r\n property UnderlineColor: TUnderlineColor read GetUnderlineColor write SetUnderlineColor;\r\n property UnderlineType: TUnderlineType read GetUnderlineType write SetUnderlineType;\r\n property Bold: Boolean index CFE_BOLD read GetAttribute write SetAttribute;\r\n property Italic: Boolean index CFE_ITALIC read GetAttribute write SetAttribute;\r\n property Underline: Boolean index CFE_UNDERLINE read GetAttribute write SetAttribute;\r\n property StrikeOut: Boolean index CFE_STRIKEOUT read GetAttribute write SetAttribute;\r\n end;\r\n\r\n TJvNumbering = (nsNone, nsBullet, nsArabicNumbers, nsLoCaseLetter,\r\n nsUpCaseLetter, nsLoCaseRoman, nsUpCaseRoman);\r\n TJvNumberingStyle = (nsParenthesis, nsPeriod, nsEnclosed, nsSimple);\r\n TParaAlignment = (paLeftJustify, paRightJustify, paCenter, paJustify);\r\n TLineSpacingRule = (lsSingle, lsOneAndHalf, lsDouble, lsSpecifiedOrMore,\r\n lsSpecified, lsMultiple);\r\n THeadingStyle = 0..9;\r\n TParaTableStyle = (tsNone, tsTableRow, tsTableCellEnd, tsTableCell);\r\n\r\n TJvIndentationStyle = (isRichEdit, isOffice); // added by J.G. Boerema\r\n // TJvIndentationStyle: default is isRichEdit\r\n // - isRichEdit: LefIndent relative to FirstIndent\r\n // - isOffice: FirstIndent relative to LeftIndent (like MsWord and WordPad)\r\n // For example when FirstIndent=2 and LeftIndent=1 the effect is:\r\n // isRichEdit: first line starts at 2 and following lines at 3\r\n // isOffice: first line starts at 3 and following lines at 1\r\n\r\n // From Msdn PARAFORMAT info:\r\n{\r\n Rich Edit 2.0: For compatibility with TOM interfaces, you can use the eight\r\n high-order bits to store additional information about each tab stop.\r\n\r\n Bits 24-27 can specify one of the following values to indicate the tab alignment.\r\n These bits do not affect the rich edit control display for versions earlier\r\n than Rich Edit 3.0. [Note J.G.Boerema: This information is incorrect! At\r\n least, my version of Rich Edit 3 shows all tabs as ordinary tabs.]\r\n 0 Ordinary tab\r\n 1 Center tab\r\n 2 Right-aligned tab\r\n 3 Decimal tab\r\n 4 Word bar tab (vertical bar)\r\n\r\n Bits 28-31 can specify one of the following values to indicate the type of tab leader.\r\n These bits do not affect the rich edit control display.\r\n 0 No leader\r\n 1 Dotted leader\r\n 2 Dashed leader\r\n 3 Underlined leader\r\n 4 Thick line leader\r\n 5 Double line leader\r\n}\r\n\r\n TJvTabAlignment =\r\n (taOrdinary, taCenter, taRight, taDecimal, taVertical); // added by J.G. Boerema\r\n // Note: if taVertical then tableader should be disabled according to Word\r\n TJvTabLeader =\r\n (tlNone, tlDotted, tlDashed, tlUnderlined, tlThick, tlDouble); // added by J.G. Boerema\r\n\r\n TJvParaAttributes = class(TPersistent)\r\n private\r\n FRichEdit: TJvCustomRichEdit;\r\n FIndentationStyle: TJvIndentationStyle; // added by J.G. Boerema\r\n procedure GetAttributes(var Paragraph: TParaFormat2);\r\n function GetAlignment: TParaAlignment;\r\n function GetFirstIndent: Longint;\r\n function GetHeadingStyle: THeadingStyle;\r\n function GetLeftIndent: Longint;\r\n function GetLineSpacing: Longint;\r\n function GetLineSpacingRule: TLineSpacingRule;\r\n function GetNumbering: TJvNumbering;\r\n function GetNumberingStart: Integer;\r\n function GetNumberingStyle: TJvNumberingStyle;\r\n function GetNumberingTab: Word;\r\n function GetRightIndent: Longint;\r\n function GetSpaceAfter: Longint;\r\n function GetSpaceBefore: Longint;\r\n function GetTab(Index: Byte): Longint;\r\n function GetTabCount: Integer;\r\n function GetTableStyle: TParaTableStyle;\r\n function GetTabAlignment(Index: Byte): TJvTabAlignment;\r\n function GetTabLeader(Index: Byte): TJvTabLeader;\r\n procedure SetAlignment(Value: TParaAlignment);\r\n procedure SetAttributes(var Paragraph: TParaFormat2);\r\n procedure SetFirstIndent(Value: Longint);\r\n procedure SetHeadingStyle(Value: THeadingStyle);\r\n procedure SetLeftIndent(Value: Longint);\r\n procedure SetLineSpacing(Value: Longint);\r\n procedure SetLineSpacingRule(Value: TLineSpacingRule);\r\n procedure SetNumbering(Value: TJvNumbering);\r\n procedure SetNumberingStart(const Value: Integer);\r\n procedure SetNumberingStyle(Value: TJvNumberingStyle);\r\n procedure SetNumberingTab(Value: Word);\r\n procedure SetRightIndent(Value: Longint);\r\n procedure SetSpaceAfter(Value: Longint);\r\n procedure SetSpaceBefore(Value: Longint);\r\n procedure SetTab(Index: Byte; Value: Longint);\r\n procedure SetTabCount(Value: Integer);\r\n procedure SetTableStyle(Value: TParaTableStyle);\r\n procedure SetTabAlignment(Index: Byte; Value: TJvTabAlignment);\r\n procedure SetTabLeader(Index: Byte; Value: TJvTabLeader);\r\n protected\r\n procedure InitPara(var Paragraph: TParaFormat2);\r\n procedure AssignTo(Dest: TPersistent); override;\r\n public\r\n constructor Create(AOwner: TJvCustomRichEdit);\r\n procedure Assign(Source: TPersistent); override;\r\n property Alignment: TParaAlignment read GetAlignment write SetAlignment;\r\n property FirstIndent: Longint read GetFirstIndent write SetFirstIndent;\r\n property HeadingStyle: THeadingStyle read GetHeadingStyle write SetHeadingStyle;\r\n property IndentationStyle: TJvIndentationStyle read FIndentationStyle write FIndentationStyle;\r\n property LeftIndent: Longint read GetLeftIndent write SetLeftIndent;\r\n property LineSpacing: Longint read GetLineSpacing write SetLineSpacing;\r\n property LineSpacingRule: TLineSpacingRule read GetLineSpacingRule write SetLineSpacingRule;\r\n property Numbering: TJvNumbering read GetNumbering write SetNumbering;\r\n property NumberingStart: Integer read GetNumberingStart write SetNumberingStart;\r\n property NumberingStyle: TJvNumberingStyle read GetNumberingStyle write SetNumberingStyle;\r\n property NumberingTab: Word read GetNumberingTab write SetNumberingTab;\r\n property RightIndent: Longint read GetRightIndent write SetRightIndent;\r\n property SpaceAfter: Longint read GetSpaceAfter write SetSpaceAfter;\r\n property SpaceBefore: Longint read GetSpaceBefore write SetSpaceBefore;\r\n property Tab[Index: Byte]: Longint read GetTab write SetTab;\r\n property TabCount: Integer read GetTabCount write SetTabCount;\r\n property TableStyle: TParaTableStyle read GetTableStyle write SetTableStyle;\r\n property TabAlignment[Index: Byte]: TJvTabAlignment read GetTabAlignment write SetTabAlignment;\r\n property TabLeader[Index: Byte]: TJvTabLeader read GetTabLeader write SetTabLeader;\r\n end;\r\n\r\n TJvConversionKind = (ckImport, ckExport);\r\n TJvConversionTextKind = (ctkText, ctkRTF, ctkBothPreferText, ctkBothPreferRTF);\r\n\r\n { (rb) Name TJvConverter is already taken, thus: }\r\n TJvConversion = class(TObject)\r\n private\r\n FOnProgress: TNotifyEvent;\r\n FParentWindow: THandle;\r\n protected\r\n FPercentDone: Integer;\r\n procedure DoProgress(APercentDone: Integer);\r\n public\r\n function CanHandle(const AExtension: string; const AKind: TJvConversionKind): Boolean; overload; virtual;\r\n function CanHandle(const AKind: TJvConversionKind): Boolean; overload; virtual;\r\n function Filter: string; virtual;\r\n function TextKind: TJvConversionTextKind; virtual;\r\n function IsFormatCorrect(const AFileName: string): Boolean; overload; virtual;\r\n function IsFormatCorrect(AStream: TStream): Boolean; overload; virtual;\r\n\r\n function Open(const AFileName: string; const AKind: TJvConversionKind): Boolean; overload; virtual;\r\n function Open(Stream: TStream; const AKind: TJvConversionKind): Boolean; overload; virtual;\r\n procedure Init(AParentWindow: THandle); virtual;\r\n procedure Done; virtual;\r\n function Retry: Boolean; virtual;\r\n\r\n function ConvertRead(Buffer: {$IFDEF COMPILER12_UP}PByte{$ELSE}PAnsiChar{$ENDIF COMPILER12_UP}; BufSize: Integer): Integer; virtual;\r\n function ConvertWrite(Buffer: {$IFDEF COMPILER12_UP}PByte{$ELSE}PAnsiChar{$ENDIF COMPILER12_UP}; BufSize: Integer): Integer; virtual;\r\n\r\n function UserCancel: Boolean; virtual;\r\n function Error: Boolean; virtual;\r\n function ErrorStr: string; virtual;\r\n\r\n property OnProgress: TNotifyEvent read FOnProgress write FOnProgress;\r\n property PercentDone: Integer read FPercentDone;\r\n property ParentWindow: THandle read FParentWindow;\r\n end;\r\n\r\n TJvStreamConversion = class(TJvConversion)\r\n private\r\n FStream: TStream;\r\n FSavedPosition: Int64;\r\n FStreamSize: Integer;\r\n FFreeStream: Boolean;\r\n FBytesConverted: Integer;\r\n public\r\n function Open(const AFileName: string; const AKind: TJvConversionKind): Boolean; override;\r\n function Open(Stream: TStream; const AKind: TJvConversionKind): Boolean; override;\r\n procedure Done; override;\r\n function Retry: Boolean; override;\r\n function ConvertRead(Buffer: {$IFDEF COMPILER12_UP}PByte{$ELSE}PAnsiChar{$ENDIF COMPILER12_UP}; BufSize: Integer): Integer; override;\r\n function ConvertWrite(Buffer: {$IFDEF COMPILER12_UP}PByte{$ELSE}PAnsiChar{$ENDIF COMPILER12_UP}; BufSize: Integer): Integer; override;\r\n property Stream: TStream read FStream;\r\n end;\r\n\r\n TJvTextConversion = class(TJvStreamConversion)\r\n public\r\n function CanHandle(const AExtension: string; const AKind: TJvConversionKind): Boolean; override;\r\n function Filter: string; override;\r\n function TextKind: TJvConversionTextKind; override;\r\n end;\r\n\r\n TJvRTFConversion = class(TJvStreamConversion)\r\n public\r\n function CanHandle(const AExtension: string; const AKind: TJvConversionKind): Boolean; override;\r\n function Filter: string; override;\r\n function TextKind: TJvConversionTextKind; override;\r\n function IsFormatCorrect(const AFileName: string): Boolean; override;\r\n function IsFormatCorrect(AStream: TStream): Boolean; override;\r\n end;\r\n\r\n TJvOEMConversion = class(TJvStreamConversion)\r\n public\r\n function ConvertRead(Buffer: {$IFDEF COMPILER12_UP}PByte{$ELSE}PAnsiChar{$ENDIF COMPILER12_UP}; BufSize: Integer): Integer; override;\r\n function ConvertWrite(Buffer: {$IFDEF COMPILER12_UP}PByte{$ELSE}PAnsiChar{$ENDIF COMPILER12_UP}; BufSize: Integer): Integer; override;\r\n function TextKind: TJvConversionTextKind; override;\r\n end;\r\n\r\n FCE = Smallint; // File Conversion Error\r\n\r\n { typedef long (PASCAL *PFN_RTF)(long, long); }\r\n PFN_RTF = function(I1, I2: Longint): Longint; stdcall;\r\n { long PASCAL InitConverter32(HANDLE hWnd, char *szModule); }\r\n TInitConverter32 = function(hWnd: THandle; szModule: PAnsiChar): LongBool; stdcall;\r\n { void PASCAL UninitConverter(void); }\r\n TUninitConverter = procedure; stdcall;\r\n { void PASCAL GetReadNames(HANDLE haszClass, HANDLE haszDescrip, HANDLE haszExt); }\r\n TGetReadNames = procedure(haszClass, haszDescrip, haszExt: THandle); stdcall;\r\n { void PASCAL GetWriteNames(HANDLE haszClass, HANDLE haszDescrip, HANDLE haszExt); }\r\n TGetWriteNames = procedure(haszClass, haszDescrip, haszExt: THandle); stdcall;\r\n { HGLOBAL PASCAL RegisterApp(unsigned long lFlags, void FAR *lpFuture); }\r\n TRegisterApp = function(lFlags: DWORD; lpFuture: Pointer): HGLOBAL; stdcall;\r\n { FCE PASCAL IsFormatCorrect32(HANDLE ghszFile, HANDLE ghszClass); }\r\n TIsFormatCorrect32 = function(ghszFile, ghszClass: THandle): FCE; stdcall;\r\n { FCE PASCAL ForeignToRtf32(HANDLE ghszFile, void *pstgForeign, HANDLE ghBuff, HANDLE ghszClass, HANDLE ghszSubset, PFN_RTF lpfnOut); }\r\n TForeignToRtf32 = function(ghszFile: THandle; pstgForeign: Pointer; ghBuff, ghszClass, ghszSubset: THandle;\r\n lpfnOut: PFN_RTF): FCE; stdcall;\r\n { FCE PASCAL RtfToForeign32(HANDLE ghszFile, void *pstgForeign, HANDLE ghBuff, HANDLE ghshClass, PFN_RTF lpfnIn); }\r\n TRtfToForeign32 = function(ghszFile: THandle; pstgForeign: Pointer; ghBuff, ghshClass: THandle;\r\n lpfnIn: PFN_RTF): FCE; stdcall;\r\n { long PASCAL CchFetchLpszError(long fce, char FAR *lpszError, long cb); }\r\n TCchFetchLpszError = function(fce: Longint; lpszError: PAnsiChar; cb: Longint): Longint; stdcall;\r\n { long PASCAL FRegisterConverter(HANDLE hkeyRoot); }\r\n TFRegisterConverter = function(hkeyRoot: THandle): Longint; stdcall;\r\n\r\n TJvMSTextConversion = class(TJvConversion)\r\n private\r\n FConverterFileName: string;\r\n FExtensions: TStringList;\r\n FDescription: string;\r\n FConverterKind: TJvConversionKind;\r\n\r\n FConverter: HMODULE;\r\n FInitConverter32: TInitConverter32;\r\n FUninitConverter: TUninitConverter;\r\n FIsFormatCorrect32: TIsFormatCorrect32;\r\n FForeignToRtf32: TForeignToRtf32;\r\n FRtfToForeign32: TRtfToForeign32;\r\n FCchFetchLpszError: TCchFetchLpszError;\r\n\r\n { Indicates whether the thread is done }\r\n FThreadDone: Boolean;\r\n { Indicates whether the conversion process has been cancelled by the\r\n main thread }\r\n FCancel: Boolean;\r\n\r\n FBytesAvailable: Integer;\r\n { Buffer accessable by the converter dll }\r\n FBuffer: HGLOBAL;\r\n FBufferPtr: PAnsiChar;\r\n FTempProgress: Integer;\r\n\r\n { Thread synchronization based on the source of Wordpad, see\r\n http://cvs.wndtabs.com/cgi-bin/viewcvs/viewcvs.cgi/BCG/WordPad/\r\n\r\n Import works as follows\r\n\r\n Thread RichEdit\r\n ------ --------\r\n loop: loop:\r\n @@ Converter converts buffer1 @@ Copy buffer1 to buffer2\r\n richedit processes buffer2\r\n\r\n The @@ parts may not happen simultaneously, thus this is converted to:\r\n\r\n Thread RichEdit\r\n ------ --------\r\n loop: loop:\r\n @@ Converter converts buffer1 [wait until thread ready]\r\n [thread ready] @@ Copy buffer1 to buffer2\r\n [wait until richedit ready] [richedit ready]\r\n richedit retrieves data from buffer2\r\n\r\n Export works as follows:\r\n\r\n Thread RichEdit\r\n ------ --------\r\n loop: loop:\r\n @@ Converter converts buffer1 richedit puts data in buffer2\r\n @@ Copy buffer2 to buffer1\r\n\r\n The @@ parts may not happen simultaneously, thus this is converted to:\r\n\r\n Thread RichEdit\r\n ------ --------\r\n loop: loop:\r\n [thread ready] richedit puts data in buffer2\r\n [wait until richedit ready] [wait until thread ready]\r\n @@ Converter converts buffer1 @@ Copy buffer2 to buffer1\r\n [richedit ready]\r\n\r\n - buffer1 is FBuffer\r\n - buffer2 is the Buffer param from ConvertRead or ConvertWrite\r\n\r\n }\r\n\r\n FRichEditReady: TEvent;\r\n FThreadReady: TEvent;\r\n FConversionError: FCE;\r\n FFileName: HMODULE;\r\n FInitDone: Boolean;\r\n protected\r\n procedure LoadConverter;\r\n procedure FreeConverter;\r\n procedure Check(Result: FCE);\r\n procedure DoError(ErrorCode: FCE);\r\n\r\n { Handled in the context of the thread: }\r\n procedure DoConversion;\r\n function HandleExportCallback(cchBuff, nPercent: Longint): Longint;\r\n function HandleImportCallback(cchBuff, nPercent: Longint): Longint;\r\n procedure WaitUntilThreadReady;\r\n procedure WaitUntilRichEditReady;\r\n\r\n procedure Lock;\r\n procedure Unlock;\r\n\r\n procedure InitConverter;\r\n public\r\n constructor Create(const AConverterFileName, AExtensions, ADescription: string;\r\n const AKind: TJvConversionKind); virtual;\r\n destructor Destroy; override;\r\n\r\n function CanHandle(const AExtension: string; const AKind: TJvConversionKind): Boolean; override;\r\n function CanHandle(const AKind: TJvConversionKind): Boolean; override;\r\n\r\n function Open(const AFileName: string; const AKind: TJvConversionKind): Boolean; override;\r\n\r\n procedure Done; override;\r\n\r\n function TextKind: TJvConversionTextKind; override;\r\n function Filter: string; override;\r\n function IsFormatCorrect(const AFileName: string): Boolean; override;\r\n function TranslateError(ErrorCode: FCE): string;\r\n\r\n function ConvertRead(Buffer: {$IFDEF COMPILER12_UP}PByte{$ELSE}PAnsiChar{$ENDIF COMPILER12_UP}; BufSize: Integer): Integer; override;\r\n function ConvertWrite(Buffer: {$IFDEF COMPILER12_UP}PByte{$ELSE}PAnsiChar{$ENDIF COMPILER12_UP}; BufSize: Integer): Integer; override;\r\n\r\n function UserCancel: Boolean; override;\r\n function Error: Boolean; override;\r\n function ErrorStr: string; override;\r\n end;\r\n\r\n TUndoName = (unUnknown, unTyping, unDelete, unDragDrop, unCut, unPaste);\r\n TRichSearchType = (stWholeWord, stMatchCase, stBackward, stSetSelection);\r\n TRichSearchTypes = set of TRichSearchType;\r\n TRichSelection = (stText, stObject, stMultiChar, stMultiObject);\r\n TRichSelectionType = set of TRichSelection;\r\n TRichLangOption = (rlAutoKeyboard, rlAutoFont, rlImeCancelComplete, rlImeAlwaysSendNotify);\r\n TRichLangOptions = set of TRichLangOption;\r\n TRichStreamFormat = (sfDefault, sfRichText, sfPlainText);\r\n TRichStreamMode = (smSelection, smPlainRtf, smNoObjects, smUnicode);\r\n TRichStreamModes = set of TRichStreamMode;\r\n TRichDropEffect = (rdeCopy, rdeMove, rdeLink, rdeScroll);\r\n TRichDropEffects = set of TRichDropEffect;\r\n TRichEditURLClickEvent = procedure(Sender: TObject; const URLText: string;\r\n Button: TMouseButton) of object;\r\n TRichEditURLHoverEvent = procedure(Sender: TObject; const URLText: string) of object;\r\n TRichEditProtectChangeEx = procedure(Sender: TObject; const Msg: TMessage;\r\n StartPos, EndPos: Integer; var AllowChange: Boolean) of object;\r\n TRichEditFindErrorEvent = procedure(Sender: TObject; const FindText: string) of object;\r\n TRichEditFindCloseEvent = procedure(Sender: TObject; Dialog: TFindDialog) of object;\r\n TRichEditProgressEvent = procedure(Sender: TObject; PercentDone: Integer) of object;\r\n TRichEditDragAllowedEvent = procedure(Sender: TObject; ShiftState: TShiftState;\r\n var AllowedEffects: TRichDropEffects; var Handled: Boolean) of object;\r\n TRichEditGetDragDropEffectEvent = procedure(Sender: TObject; ShiftState: TShiftState;\r\n var AllowedEffects: TRichDropEffects; var Handled: Boolean) of object;\r\n TRichEditQueryAcceptData = procedure(Sender: TObject; const ADataObject: IDataObject;\r\n var AFormat: TClipFormat; ClipboardOperationKind: Cardinal; Really: Boolean;\r\n IconMetaPict: HGLOBAL; var Handled: Boolean) of object;\r\n\r\n TJvCustomRichEdit = class(TJvExCustomMemo)\r\n private\r\n FHideScrollBars: Boolean;\r\n FSelectionBar: Boolean;\r\n FAutoURLDetect: Boolean;\r\n FWordSelection: Boolean;\r\n FPlainText: Boolean;\r\n FSelAttributes: TJvTextAttributes;\r\n FDefAttributes: TJvTextAttributes;\r\n FWordAttributes: TJvTextAttributes;\r\n FParagraph: TJvParaAttributes;\r\n FOldParaAlignment: TParaAlignment;\r\n FScreenLogPixels: Integer;\r\n FUndoLimit: Integer;\r\n FLines: TStrings;\r\n FState: TObject;\r\n FHideSelection: Boolean;\r\n FLangOptions: TRichLangOptions;\r\n FLinesUpdating: Boolean;\r\n FPageRect: TRect;\r\n FClickRange: TCharRange;\r\n FClickBtn: TMouseButton;\r\n FFindDialog: TFindDialog;\r\n FReplaceDialog: TReplaceDialog;\r\n FLastFind: TFindDialog;\r\n FAllowObjects: Boolean;\r\n FCallback: TObject;\r\n FRichEditOle: IUnknown;\r\n FPopupVerbMenu: TPopupMenu;\r\n FTitle: string;\r\n FAutoVerbMenu: Boolean;\r\n FAllowInPlace: Boolean;\r\n FDefaultConverter: TJvConversion;\r\n FImageRect: TRect;\r\n FAutoAdvancedTypography: Boolean;\r\n FAdvancedTypography: Boolean;\r\n FOLEDragDrop: Boolean;\r\n FOnSelChange: TNotifyEvent;\r\n FOnResizeRequest: TRichEditResizeEvent;\r\n FOnProtectChange: TRichEditProtectChange;\r\n FOnProtectChangeEx: TRichEditProtectChangeEx;\r\n FOnSaveClipboard: TRichEditSaveClipboard;\r\n FOnURLClick: TRichEditURLClickEvent;\r\n FOnURLHover: TRichEditURLHoverEvent;\r\n FOnTextNotFound: TRichEditFindErrorEvent;\r\n FOnCloseFindDialog: TRichEditFindCloseEvent;\r\n // From JvRichEdit.pas by Sbastien Buysse\r\n FOnHorizontalScroll: TNotifyEvent;\r\n FOnVerticalScroll: TNotifyEvent;\r\n FOnConversionProgress: TRichEditProgressEvent;\r\n FForceUndo: Boolean;\r\n FUseFixedPopup: Boolean;\r\n // From CCR\r\n FOnInPlaceActivate: TNotifyEvent;\r\n FOnInPlaceDeactivate: TNotifyEvent;\r\n FOnDragAllowed: TRichEditDragAllowedEvent;\r\n FOnGetDragDropEffect: TRichEditGetDragDropEffectEvent;\r\n FOnQueryAcceptData: TRichEditQueryAcceptData;\r\n\r\n function GetAdvancedTypography: Boolean;\r\n function GetAutoURLDetect: Boolean;\r\n function GetWordSelection: Boolean;\r\n function GetLangOptions: TRichLangOptions;\r\n function GetCanRedo: Boolean;\r\n function GetCanPaste: Boolean;\r\n function GetRedoName: TUndoName;\r\n function GetUndoName: TUndoName;\r\n function GetStreamFormat: TRichStreamFormat;\r\n function GetStreamMode: TRichStreamModes;\r\n function GetSelectionType: TRichSelectionType;\r\n function GetZoom: Integer; // Added by J.G. Boerema\r\n function IsAdvancedTypographyStored: Boolean;\r\n procedure PopupVerbClick(Sender: TObject);\r\n procedure ObjectPropsClick(Sender: TObject);\r\n procedure CloseObjects;\r\n procedure UpdateHostNames;\r\n procedure SetAdvancedTypography(const Value: Boolean);\r\n procedure SetAllowObjects(Value: Boolean);\r\n procedure SetStreamFormat(Value: TRichStreamFormat);\r\n procedure SetStreamMode(Value: TRichStreamModes);\r\n procedure SetAutoURLDetect(Value: Boolean);\r\n procedure SetWordSelection(Value: Boolean);\r\n procedure SetHideScrollBars(Value: Boolean);\r\n procedure SetHideSelection(Value: Boolean);\r\n procedure SetTitle(const Value: string);\r\n procedure SetLangOptions(Value: TRichLangOptions);\r\n procedure SetRichEditStrings(Value: TStrings);\r\n procedure SetDefAttributes(Value: TJvTextAttributes);\r\n procedure SetSelAttributes(Value: TJvTextAttributes);\r\n procedure SetWordAttributes(Value: TJvTextAttributes);\r\n procedure SetSelectionBar(Value: Boolean);\r\n procedure SetOLEDragDrop(const Value: Boolean);\r\n procedure SetUndoLimit(Value: Integer);\r\n procedure SetZoom(Value: Integer); // Added by J.G. Boerema\r\n procedure UpdateTextModes(Plain: Boolean);\r\n procedure UpdateTypographyOptions(const Advanced: Boolean);\r\n procedure AdjustFindDialogPosition(Dialog: TFindDialog);\r\n procedure SetupFindDialog(Dialog: TFindDialog; const SearchStr, ReplaceStr: string);\r\n function FindEditText(Dialog: TFindDialog; AdjustPos, Events: Boolean): Boolean;\r\n function GetCanFindNext: Boolean;\r\n procedure FindDialogFind(Sender: TObject);\r\n procedure NeedAdvancedTypography;\r\n procedure ReplaceDialogReplace(Sender: TObject);\r\n procedure SetSelText(const Value: string);\r\n procedure FindDialogClose(Sender: TObject);\r\n procedure SetUIActive(Active: Boolean);\r\n procedure CMBiDiModeChanged(var Msg: TMessage); message CM_BIDIMODECHANGED;\r\n procedure CMDocWindowActivate(var Msg: TMessage); message CM_DOCWINDOWACTIVATE;\r\n procedure CMUIDeactivate(var Msg: TMessage); message CM_UIDEACTIVATE;\r\n procedure CNNotify(var Msg: TWMNotify); message CN_NOTIFY;\r\n procedure EMReplaceSel(var Msg: TMessage); message EM_REPLACESEL;\r\n procedure WMDestroy(var Msg: TWMDestroy); message WM_DESTROY;\r\n procedure WMMouseMove(var Msg: TMessage); message WM_MOUSEMOVE;\r\n procedure WMPaint(var Msg: TWMPaint); message WM_PAINT;\r\n procedure WMRButtonUp(var Msg: TMessage); message WM_RBUTTONUP;\r\n procedure WMSetCursor(var Msg: TWMSetCursor); message WM_SETCURSOR;\r\n procedure WMSetFont(var Msg: TWMSetFont); message WM_SETFONT;\r\n procedure WMSetText(var Msg: TMessage); message WM_SETTEXT;\r\n // From JvRichEdit.pas by Sbastien Buysse\r\n procedure WMHScroll(var Msg: TWMHScroll); message WM_HSCROLL;\r\n procedure WMVScroll(var Msg: TWMVScroll); message WM_VSCROLL;\r\n function GetFlat: Boolean;\r\n procedure SetFlat(const Value: Boolean);\r\n function GetParentFlat: Boolean;\r\n procedure SetParentFlat(const Value: Boolean);\r\n protected\r\n procedure ColorChanged; override;\r\n procedure FontChanged; override;\r\n\r\n function GetConverter(const AFileName: string; const Kind: TJvConversionKind): TJvConversion; overload;\r\n function GetConverter(AStream: TStream; const Kind: TJvConversionKind): TJvConversion; overload;\r\n\r\n procedure CreateParams(var Params: TCreateParams); override;\r\n procedure CreateWindowHandle(const Params: TCreateParams); override;\r\n procedure CreateWnd; override;\r\n procedure DestroyWnd; override;\r\n function GetPopupMenu: TPopupMenu; override;\r\n {$IFDEF RTL220_UP}\r\n procedure DoContextPopup(MousePos: TPoint; var Handled: Boolean); override;\r\n {$ENDIF RTL220_UP}\r\n procedure TextNotFound(Dialog: TFindDialog); virtual;\r\n procedure RequestSize(const Rect: TRect); virtual;\r\n procedure SelectionChange; dynamic;\r\n function ProtectChange(const Msg: TMessage; StartPos, EndPos: Integer): Boolean; dynamic;\r\n function SaveClipboard(NumObj, NumChars: Integer): Boolean; dynamic;\r\n procedure URLClick(const URLText: string; Button: TMouseButton); dynamic;\r\n procedure URLHover(const URLText: string); dynamic;\r\n function DoDragAllowed(const ShiftState: TShiftState; var AllowedEffects: TRichDropEffects): Boolean; dynamic;\r\n function DoGetDragDropEffect(const ShiftState: TShiftState; var Effects: TRichDropEffects): Boolean; dynamic;\r\n function DoQueryAcceptData(const ADataObject: IDataObject; var AFormat: TClipFormat;\r\n ClipboardOperationKind: Cardinal; Really: Boolean; IconMetaPict: HGLOBAL): Boolean; dynamic;\r\n procedure SetPlainText(Value: Boolean); virtual;\r\n procedure CloseFindDialog(Dialog: TFindDialog); virtual;\r\n procedure DoSetMaxLength(Value: Integer); override;\r\n procedure DoConversionProgress(const AProgress: Integer);\r\n function GetSelLength: Integer; override;\r\n function GetSelStart: Integer; override;\r\n function GetSelText: string; override;\r\n procedure SetSelLength(Value: Integer); override;\r\n procedure SetSelStart(Value: Integer); override;\r\n property AllowInPlace: Boolean read FAllowInPlace write FAllowInPlace default True;\r\n property AutoAdvancedTypography: Boolean read FAutoAdvancedTypography write FAutoAdvancedTypography default True;\r\n property AdvancedTypography: Boolean read GetAdvancedTypography write SetAdvancedTypography stored\r\n IsAdvancedTypographyStored;\r\n property AllowObjects: Boolean read FAllowObjects write SetAllowObjects default True;\r\n property AutoURLDetect: Boolean read GetAutoURLDetect write SetAutoURLDetect default True;\r\n property AutoVerbMenu: Boolean read FAutoVerbMenu write FAutoVerbMenu default True;\r\n property HideSelection: Boolean read FHideSelection write SetHideSelection default True;\r\n property HideScrollBars: Boolean read FHideScrollBars write SetHideScrollBars default True;\r\n property Title: string read FTitle write SetTitle;\r\n property LangOptions: TRichLangOptions read GetLangOptions write SetLangOptions default [rlAutoFont];\r\n property Lines: TStrings read FLines write SetRichEditStrings;\r\n property OLEDragDrop: Boolean read FOLEDragDrop write SetOLEDragDrop default True;\r\n property PlainText: Boolean read FPlainText write SetPlainText default False;\r\n property SelectionBar: Boolean read FSelectionBar write SetSelectionBar default True;\r\n property StreamFormat: TRichStreamFormat read GetStreamFormat write SetStreamFormat default sfDefault;\r\n property StreamMode: TRichStreamModes read GetStreamMode write SetStreamMode default [];\r\n property UndoLimit: Integer read FUndoLimit write SetUndoLimit default 100;\r\n property WordSelection: Boolean read GetWordSelection write SetWordSelection default True;\r\n property ScrollBars default ssBoth;\r\n property TabStop default True;\r\n property SelText: string read GetSelText write SetSelText;\r\n // Zoom: zoom in/out percentage (100=normal) note: no need to set default (100) in constructor.\r\n property Zoom: Integer read GetZoom write SetZoom default 100;\r\n property OnSaveClipboard: TRichEditSaveClipboard read FOnSaveClipboard\r\n write FOnSaveClipboard;\r\n property OnSelectionChange: TNotifyEvent read FOnSelChange write FOnSelChange;\r\n property OnProtectChange: TRichEditProtectChange read FOnProtectChange\r\n write FOnProtectChange; { obsolete }\r\n property OnProtectChangeEx: TRichEditProtectChangeEx read FOnProtectChangeEx\r\n write FOnProtectChangeEx;\r\n property OnResizeRequest: TRichEditResizeEvent read FOnResizeRequest\r\n write FOnResizeRequest;\r\n property OnURLClick: TRichEditURLClickEvent read FOnURLClick write FOnURLClick;\r\n\r\n // This event this is called as long as the Mouse moves over a link.\r\n // To handle the first call only, check the current cursor handle.\r\n // The RichEdit control 2.0 or higher sets the cursor to \"HandPoint\" when\r\n // the Mouse is over a link and resets the cursor handle to the previous\r\n // cursor on exit.\r\n // so basically, you do this in your event handler:\r\n //\r\n // if HandpointCursorHandle = 0 then\r\n // begin\r\n // // Remember the handle of the \"HandPoint\" cursor (set by RichEdit 2.0 or higher)\r\n // // Must be reset to 0 in JvRichEdit1MouseMove() after handle has changed.\r\n // HandpointCursorHandle := Windows.GetCursor;\r\n //\r\n // // Do what you need when Mouse is the first time over a link\r\n // end;\r\n //\r\n // then in OnMouseMove you do this to reset the global variable\r\n // \r\n // // \"URLHover\" event has been called then this value is <> 0\r\n // if HandpointCursorHandle <> 0 then\r\n // begin\r\n // // Mouse is not over a link anymore than the cursor handle has changed\r\n // if Windows.GetCursor <> HandpointCursorHandle then\r\n // begin\r\n // // Reset the cursor handle\r\n // HandpointCursorHandle := 0;\r\n //\r\n // // Do what you need when Mouse is not over the link anymore\r\n // end;\r\n // end;\r\n //\r\n property OnURLHover: TRichEditURLHoverEvent read FOnURLHover write FOnURLHover;\r\n \r\n property OnTextNotFound: TRichEditFindErrorEvent read FOnTextNotFound write FOnTextNotFound;\r\n property OnCloseFindDialog: TRichEditFindCloseEvent read FOnCloseFindDialog\r\n write FOnCloseFindDialog;\r\n property OnConversionProgress: TRichEditProgressEvent read FOnConversionProgress write FOnConversionProgress;\r\n // From JvRichEdit.pas by Sbastien Buysse\r\n property OnVerticalScroll: TNotifyEvent read FOnVerticalScroll write FOnVerticalScroll;\r\n property OnHorizontalScroll: TNotifyEvent read FOnHorizontalScroll write FOnHorizontalScroll;\r\n property OnDragAllowed: TRichEditDragAllowedEvent read FOnDragAllowed write FOnDragAllowed;\r\n property OnGetDragDropEffect: TRichEditGetDragDropEffectEvent read FOnGetDragDropEffect write FOnGetDragDropEffect;\r\n property OnQueryAcceptData: TRichEditQueryAcceptData read FOnQueryAcceptData write FOnQueryAcceptData;\r\n property ForceUndo: Boolean read FForceUndo write FForceUndo default True;\r\n property UseFixedPopup: Boolean read FUseFixedPopup write FUseFixedPopup default True;\r\n // from CCR\r\n property OnInPlaceActivate: TNotifyEvent read FOnInPlaceActivate write FOnInPlaceActivate;\r\n property OnInPlaceDeactivate: TNotifyEvent read FOnInPlaceDeactivate write FOnInPlaceDeactivate;\r\n property Flat: Boolean read GetFlat write SetFlat default False;\r\n property ParentFlat: Boolean read GetParentFlat write SetParentFlat default True;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n procedure Clear; override;\r\n procedure SaveToImage(Picture: TPicture);\r\n\r\n procedure InsertGraphic(AGraphic: TGraphic; const Sizeable: Boolean);\r\n { Same interface as TOleContainer }\r\n procedure InsertLinkToFile(const FileName: string; Iconic: Boolean);\r\n procedure InsertObject(const OleClassName: string; Iconic: Boolean);\r\n procedure InsertObjectFromFile(const FileName: string; Iconic: Boolean);\r\n procedure InsertObjectFromInfo(const Info: TCreateInfo);\r\n // InsertFormatText inserts formatted text at the cursor position given by Index.\r\n // If Index < 0, the text is inserted at the current SelStart position.\r\n // S is the string to insert\r\n // AFont is the font to use. If AFont = nil, then the current attributes at the insertion point are used.\r\n // NOTE: this procedure does not reset the attributes after the call, i.e if you change the text color\r\n // it will remain that color until you change it again.\r\n procedure InsertFormatText(Index: Integer; const S: string; const AFont: TFont = nil); overload;\r\n procedure InsertFormatText(Index: Integer; const S: string;\r\n FontStyle: TFontStyles; const FontName: string = ''; const FontColor: TColor = clDefault; FontHeight: Integer = 0); overload;\r\n\r\n // AddFormatText works just like InsertFormatText but always moves the insertion\r\n // point to the end of the available text\r\n procedure AddFormatText(const S: string; const AFont: TFont = nil); overload;\r\n procedure AddFormatText(const S: string; FontStyle: TFontStyles; const FontName: string = ''; const FontColor: TColor = clDefault; FontHeight: Integer = 0); overload;\r\n\r\n procedure SetSelection(StartPos, EndPos: Longint; ScrollCaret: Boolean);\r\n function GetSelection: TCharRange;\r\n function GetTextRange(StartPos, EndPos: Longint): string;\r\n // GetTextLenEx is to be used when printing the RichEdit using EM_FORMATRANGE\r\n // because GetTextLen is unreliable in this case.\r\n // See Mantis 4782 and http://edn.embarcadero.com/article/26772 for details\r\n function GetTextLenEx: Integer;\r\n function CharFromPos(X, Y: Integer): Integer;\r\n function LineFromChar(CharIndex: Integer): Integer;\r\n function GetLineIndex(LineNo: Integer): Integer;\r\n function GetLineLength(CharIndex: Integer): Integer;\r\n function WordAtCursor: string;\r\n function FindText(const SearchStr: string;\r\n StartPos, Length: Integer; Options: TRichSearchTypes): Integer;\r\n function GetSelTextBuf(Buffer: PChar; BufSize: Integer): Integer; override;\r\n function GetCaretPos: TPoint; override;\r\n function GetCharPos(CharIndex: Integer): TPoint;\r\n function InsertObjectDialog: Boolean;\r\n function ObjectPropertiesDialog: Boolean;\r\n function PasteSpecialDialog: Boolean;\r\n function FindDialog(const SearchStr: string): TFindDialog;\r\n function ReplaceDialog(const SearchStr, ReplaceStr: string): TReplaceDialog;\r\n function FindNext: Boolean;\r\n procedure Print(const Caption: string); virtual;\r\n class procedure RegisterConversionFormat(AConverter: TJvConversion);\r\n class procedure RegisterMSTextConverters;\r\n class function Filter(const AKind: TJvConversionKind): string;\r\n procedure ClearUndo;\r\n procedure Redo;\r\n procedure StopGroupTyping;\r\n procedure CloseActiveObject; // from CCR\r\n\r\n procedure SetSelectionLink;\r\n\r\n property CanFindNext: Boolean read GetCanFindNext;\r\n property CanRedo: Boolean read GetCanRedo;\r\n property CanPaste: Boolean read GetCanPaste;\r\n property RedoName: TUndoName read GetRedoName;\r\n property UndoName: TUndoName read GetUndoName;\r\n property DefaultConverter: TJvConversion read FDefaultConverter write FDefaultConverter;\r\n property DefAttributes: TJvTextAttributes read FDefAttributes write SetDefAttributes;\r\n property SelAttributes: TJvTextAttributes read FSelAttributes write SetSelAttributes;\r\n property WordAttributes: TJvTextAttributes read FWordAttributes write SetWordAttributes;\r\n property PageRect: TRect read FPageRect write FPageRect;\r\n property Paragraph: TJvParaAttributes read FParagraph;\r\n property SelectionType: TRichSelectionType read GetSelectionType;\r\n end;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvRichEdit = class(TJvCustomRichEdit)\r\n published\r\n property AdvancedTypography;\r\n property Align;\r\n property Alignment;\r\n property AutoAdvancedTypography;\r\n property AutoSize default False;\r\n property AutoURLDetect;\r\n property AutoVerbMenu;\r\n property AllowObjects;\r\n property AllowInPlace;\r\n property Anchors;\r\n property BevelEdges;\r\n property BevelInner;\r\n property BevelKind default bkNone;\r\n property BevelOuter;\r\n property BiDiMode;\r\n property BorderWidth;\r\n property DragKind;\r\n property BorderStyle;\r\n property ClipboardCommands;\r\n property Color;\r\n property DragCursor;\r\n property DragMode;\r\n property Enabled;\r\n property Flat;\r\n property Font;\r\n property ForceUndo;\r\n property HideSelection;\r\n property HideScrollBars;\r\n property HintColor;\r\n property Title;\r\n property ImeMode;\r\n property ImeName;\r\n property Constraints;\r\n property ParentBiDiMode;\r\n property LangOptions;\r\n property Lines;\r\n property MaxLength;\r\n property OLEDragDrop;\r\n property ParentColor;\r\n property ParentFlat;\r\n property ParentFont;\r\n property ParentShowHint;\r\n property PlainText;\r\n property PopupMenu;\r\n property ReadOnly;\r\n property ScrollBars;\r\n property SelectionBar;\r\n property SelText;\r\n property ShowHint;\r\n property StreamFormat;\r\n property StreamMode;\r\n property TabOrder;\r\n property TabStop;\r\n property UndoLimit;\r\n property UseFixedPopup;\r\n property Visible;\r\n property WantTabs;\r\n property WantReturns;\r\n property WordSelection;\r\n property WordWrap;\r\n property Zoom; // added by J.G. Boerema\r\n property OnChange;\r\n property OnClick;\r\n property OnDblClick;\r\n property OnDragDrop;\r\n property OnDragOver;\r\n property OnContextPopup;\r\n property OnConversionProgress;\r\n property OnEndDock;\r\n property OnStartDock;\r\n property OnEndDrag;\r\n property OnEnter;\r\n property OnExit;\r\n property OnKeyDown;\r\n property OnKeyPress;\r\n property OnKeyUp;\r\n property OnMouseDown;\r\n property OnMouseMove;\r\n property OnMouseUp;\r\n property OnMouseWheel;\r\n property OnMouseWheelDown;\r\n property OnMouseWheelUp;\r\n property OnProtectChange; { obsolete }\r\n property OnProtectChangeEx;\r\n property OnResizeRequest;\r\n property OnSaveClipboard;\r\n property OnSelectionChange;\r\n property OnStartDrag;\r\n property OnTextNotFound;\r\n property OnCloseFindDialog;\r\n property OnDragAllowed;\r\n property OnGetDragDropEffect;\r\n property OnQueryAcceptData;\r\n property OnURLClick;\r\n property OnURLHover;\r\n property OnMouseEnter;\r\n property OnMouseLeave;\r\n property OnParentColorChange;\r\n property OnVerticalScroll;\r\n property OnHorizontalScroll;\r\n // From CCR\r\n property OnInPlaceActivate;\r\n property OnInPlaceDeactivate;\r\n end;\r\n\r\nvar\r\n RichEditVersion: Integer;\r\n\r\n { Two procedures to construct RTF from a bitmap. You can use this to\r\n insert bitmaps in the rich edit control, for example:\r\n\r\n Stream := TMemoryStream.Create;\r\n try\r\n BitmapToRTF(SomeBitmap, Stream);\r\n Stream.Position := 0;\r\n\r\n JvRichEdit1.StreamFormat := sfRichText;\r\n JvRichEdit1.StreamMode := [smSelection, smPlainRtf];\r\n JvRichEdit1.Lines.LoadFromStream(Stream);\r\n finally\r\n Stream.Free;\r\n end;\r\n\r\n But:\r\n\r\n * if you stream out the RTF content of the rich edit control, the bitmaps\r\n are *not* included. Use TJvRichEdit.InsertGraphic if you want the bitmaps\r\n to be included in the RTF.\r\n * TJvRichEdit.AllowObjects must be set to True.\r\n * BitmapToRTF is the fastest, TJvRichEdit.InsertGraphic the slowest.\r\n }\r\n\r\n{ uses the \\dibitmap identifier }\r\nprocedure BitmapToRTF(ABitmap: TBitmap; AStream: TStream);\r\n{ uses the \\wmetafile identifier }\r\nfunction BitmapToRTF2(ABitmap: TBitmap; AStream: TStream): Boolean;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvRichEdit.pas $';\r\n Revision: '$Revision: 13415 $';\r\n Date: '$Date: 2012-09-10 11:51:54 +0200 (lun. 10 sept. 2012) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n {$IFDEF HAS_UNIT_SYSTEM_UITYPES}\r\n System.UITypes,\r\n {$ENDIF HAS_UNIT_SYSTEM_UITYPES}\r\n Types,\r\n Printers, ComStrs, OleConst, OleDlg, Math, Registry, Contnrs,\r\n {$IFDEF RTL200_UP}\r\n CommDlg,\r\n {$ENDIF RTL200_UP}\r\n JvThemes, JvConsts, JvResources, JvFixedEditPopUp;\r\n\r\ntype\r\n PENLink = ^TENLink;\r\n PENOleOpFailed = ^TENOleOpFailed;\r\n {$IFDEF SUPPORTS_UNICODE}\r\n TFindTextEx = TFindTextExW;\r\n {$ELSE}\r\n TFindTextEx = TFindTextExA;\r\n {$ENDIF SUPPORTS_UNICODE}\r\n TTextRangeA = record\r\n chrg: TCharRange;\r\n lpstrText: PAnsiChar;\r\n end;\r\n\r\n TTextRangeW = record\r\n chrg: TCharRange;\r\n lpstrText: PWideChar;\r\n end;\r\n\r\n {$IFDEF SUPPORTS_UNICODE}\r\n TTextRange = TTextRangeW;\r\n {$ELSE}\r\n TTextRange = TTextRangeA;\r\n {$ENDIF SUPPORTS_UNICODE}\r\n\r\n { OLE Extensions to the Rich Text Editor }\r\n { Converted from RICHOLE.H }\r\n { Structure passed to GetObject and InsertObject }\r\n\r\n _ReObject = record\r\n cbStruct: DWORD; { Size of structure }\r\n cp: ULONG; { Character position of object }\r\n clsid: TCLSID; { Class ID of object }\r\n poleobj: IOleObject; { OLE object interface }\r\n pstg: IStorage; { Associated storage interface }\r\n polesite: IOleClientSite; { Associated client site interface }\r\n sizel: TSize; { Size of object (may be 0,0) }\r\n dvAspect: Longint; { Display aspect to use }\r\n dwFlags: DWORD; { Object status flags }\r\n dwUser: DWORD; { DWORD for user's use }\r\n end;\r\n TReObject = _ReObject;\r\n\r\n EMSTextConversionError = class(Exception)\r\n private\r\n FErrorCode: FCE;\r\n public\r\n constructor Create(const Msg: string; AErrorCode: FCE = 0);\r\n property ErrorCode: FCE read FErrorCode write FErrorCode;\r\n end;\r\n\r\n (* make Delphi 5 compiler happy // andreas\r\n { RichEdit GUIDs }\r\n IID_IRichEditOle: TGUID = (\r\n D1: $00020D00; D2: $0000; D3: $0000; D4: ($C0, $00, $00, $00, $00, $00, $00, $46));\r\n IID_IRichEditOleCallback: TGUID = (\r\n D1: $00020D03; D2: $0000; D3: $0000; D4: ($C0, $00, $00, $00, $00, $00, $00, $46));\r\n *)\r\n\r\n {\r\n * IRichEditOle\r\n *\r\n * Purpose:\r\n * Interface used by the client of RichEdit to perform OLE-related\r\n * operations.\r\n *\r\n * The methods herein may just want to be regular Windows messages.\r\n }\r\n\r\n IRichEditOle = interface(IUnknown)\r\n ['{00020d00-0000-0000-c000-000000000046}']\r\n function GetClientSite(out clientSite: IOleClientSite): HRESULT; stdcall;\r\n function GetObjectCount: HRESULT; stdcall;\r\n function GetLinkCount: HRESULT; stdcall;\r\n function GetObject(iob: Longint; out ReObject: TReObject;\r\n dwFlags: DWORD): HRESULT; stdcall;\r\n function InsertObject(var ReObject: TReObject): HRESULT; stdcall;\r\n function ConvertObject(iob: Longint; rclsidNew: TIID;\r\n lpstrUserTypeNew: LPCSTR): HRESULT; stdcall;\r\n function ActivateAs(rclsid: TIID; rclsidAs: TIID): HRESULT; stdcall;\r\n function SetHostNames(lpstrContainerApp: LPCSTR;\r\n lpstrContainerObj: LPCSTR): HRESULT; stdcall;\r\n function SetLinkAvailable(iob: Longint; fAvailable: BOOL): HRESULT; stdcall;\r\n function SetDvaspect(iob: Longint; dvAspect: DWORD): HRESULT; stdcall;\r\n function HandsOffStorage(iob: Longint): HRESULT; stdcall;\r\n function SaveCompleted(iob: Longint; const stg: IStorage): HRESULT; stdcall;\r\n function InPlaceDeactivate: HRESULT; stdcall;\r\n function ContextSensitiveHelp(fEnterMode: BOOL): HRESULT; stdcall;\r\n function GetClipboardData(var chrg: TCharRange; reco: DWORD;\r\n out dataObj: IDataObject): HRESULT; stdcall;\r\n function ImportDataObject(dataObj: IDataObject; cf: TClipFormat;\r\n hMetaPict: HGLOBAL): HRESULT; stdcall;\r\n end;\r\n\r\n {\r\n * IRichEditOleCallback\r\n *\r\n * Purpose:\r\n * Interface used by the RichEdit to get OLE-related stuff from the\r\n * application using RichEdit.\r\n }\r\n\r\n IRichEditOleCallback = interface(IUnknown)\r\n ['{00020d03-0000-0000-c000-000000000046}']\r\n function GetNewStorage(out stg: IStorage): HRESULT; stdcall;\r\n function GetInPlaceContext(out Frame: IOleInPlaceFrame;\r\n out Doc: IOleInPlaceUIWindow;\r\n lpFrameInfo: POleInPlaceFrameInfo): HRESULT; stdcall;\r\n function ShowContainerUI(fShow: BOOL): HRESULT; stdcall;\r\n function QueryInsertObject(const clsid: TCLSID; const stg: IStorage;\r\n cp: Longint): HRESULT; stdcall;\r\n function DeleteObject(const oleobj: IOleObject): HRESULT; stdcall;\r\n function QueryAcceptData(const dataObj: IDataObject;\r\n var cfFormat: TClipFormat; reco: DWORD; fReally: BOOL;\r\n hMetaPict: HGLOBAL): HRESULT; stdcall;\r\n function ContextSensitiveHelp(fEnterMode: BOOL): HRESULT; stdcall;\r\n function GetClipboardData(const chrg: TCharRange; reco: DWORD;\r\n out dataObj: IDataObject): HRESULT; stdcall;\r\n function GetDragDropEffect(fDrag: BOOL; grfKeyState: DWORD;\r\n var dwEffect: DWORD): HRESULT; stdcall;\r\n function GetContextMenu(seltype: Word; const oleobj: IOleObject;\r\n const chrg: TCharRange; out Menu: HMENU): HRESULT; stdcall;\r\n end;\r\n\r\n TConversionFormatList = class(TObjectList)\r\n private\r\n FRTFConvIndex: Integer;\r\n FTextConvIndex: Integer;\r\n function GetItem(Index: Integer): TJvConversion;\r\n public\r\n constructor Create; virtual;\r\n { GetConverter implicitly calls Result.Init, thus caller must call Result.Done }\r\n function GetConverter(AParentWindow: THandle; const AFileName: string;\r\n const Kind: TJvConversionKind): TJvConversion; overload;\r\n function GetConverter(AParentWindow: THandle; AStream: TStream;\r\n const Kind: TJvConversionKind): TJvConversion; overload;\r\n function GetFilter(const AKind: TJvConversionKind): string;\r\n function DefaultConverter: TJvConversion;\r\n property Items[Index: Integer]: TJvConversion read GetItem {write SetItem}; default;\r\n end;\r\n\r\n TImageDataObject = class(TInterfacedObject, IDataObject)\r\n private\r\n FGraphic: TGraphic;\r\n public\r\n constructor Create(AGraphic: TGraphic); virtual;\r\n { IDataObject }\r\n function GetData(const FormatEtcIn: TFormatEtc; out Medium: TStgMedium):\r\n HRESULT; stdcall;\r\n function GetDataHere(const FormatEtc: TFormatEtc; out Medium: TStgMedium):\r\n HRESULT; stdcall;\r\n function QueryGetData(const FormatEtc: TFormatEtc): HRESULT;\r\n stdcall;\r\n function GetCanonicalFormatEtc(const FormatEtc: TFormatEtc;\r\n out FormatEtcOut: TFormatEtc): HRESULT; stdcall;\r\n function SetData(const FormatEtc: TFormatEtc; var Medium: TStgMedium;\r\n fRelease: BOOL): HRESULT; stdcall;\r\n function EnumFormatEtc(dwDirection: Longint; out EnumFormatEtc:\r\n IEnumFormatEtc): HRESULT; stdcall;\r\n function DAdvise(const FormatEtc: TFormatEtc; advf: Longint;\r\n const advSink: IAdviseSink; out dwConnection: Longint): HRESULT; stdcall;\r\n function DUnadvise(dwConnection: Longint): HRESULT; stdcall;\r\n function EnumDAdvise(out enumAdvise: IEnumStatData): HRESULT;\r\n stdcall;\r\n end;\r\n\r\n TJvRichEditState = class(TObject)\r\n private\r\n FOrigFormat: TRichStreamFormat;\r\n FOrigMode: TRichStreamModes;\r\n FStreamFormat: TRichStreamFormat;\r\n FStreamMode: TRichStreamModes;\r\n FSelStart: Integer;\r\n FSelLength: Integer;\r\n FModified: Boolean;\r\n FForcePlainText: Boolean;\r\n FStream: TMemoryStream;\r\n public\r\n constructor Create;\r\n destructor Destroy; override;\r\n procedure Store(RichEdit: TJvCustomRichEdit);\r\n procedure Restore(RichEdit: TJvCustomRichEdit);\r\n property ForcePlainText: Boolean read FForcePlainText write FForcePlainText;\r\n end;\r\n\r\n TJvRichEditStrings = class(TStrings)\r\n private\r\n FRichEdit: TJvCustomRichEdit;\r\n FFormat: TRichStreamFormat;\r\n FMode: TRichStreamModes;\r\n procedure EnableChange(const Value: Boolean);\r\n protected\r\n procedure ProgressCallback(Sender: TObject);\r\n function Get(Index: Integer): string; override;\r\n function GetCount: Integer; override;\r\n procedure Put(Index: Integer; const S: string); override;\r\n procedure SetUpdateState(Updating: Boolean); override;\r\n procedure SetTextStr(const Value: string); override;\r\n\r\n procedure DoImport(AConverter: TJvConversion);\r\n procedure DoExport(AConverter: TJvConversion);\r\n public\r\n procedure Clear; override;\r\n procedure AddStrings(Strings: TStrings); override;\r\n procedure Delete(Index: Integer); override;\r\n procedure Insert(Index: Integer; const S: string); override;\r\n procedure LoadFromFile(const FileName: string); override;\r\n procedure LoadFromStream(Stream: TStream); override;\r\n procedure SaveToFile(const FileName: string); override;\r\n procedure SaveToStream(Stream: TStream); override;\r\n property Format: TRichStreamFormat read FFormat write FFormat;\r\n property Mode: TRichStreamModes read FMode write FMode;\r\n end;\r\n\r\n TMSTextConversionThread = class(TJvCustomThread)\r\n protected\r\n procedure Execute; override;\r\n public\r\n constructor Create; virtual;\r\n end;\r\n\r\n { TOleUILinkInfo - helper interface for Object Properties dialog }\r\n\r\n TOleUILinkInfo = class(TInterfacedObject, IOleUILinkInfo)\r\n private\r\n FReObject: TReObject;\r\n FRichEdit: TJvCustomRichEdit;\r\n FOleLink: IOleLink;\r\n public\r\n constructor Create(ARichEdit: TJvCustomRichEdit; ReObject: TReObject);\r\n function GetNextLink(dwLink: Longint): Longint; stdcall;\r\n function SetLinkUpdateOptions(dwLink: Longint;\r\n dwUpdateOpt: Longint): HRESULT; stdcall;\r\n function GetLinkUpdateOptions(dwLink: Longint;\r\n var dwUpdateOpt: Longint): HRESULT; stdcall;\r\n function SetLinkSource(dwLink: Longint; pszDisplayName: PChar;\r\n lenFileName: Longint; var chEaten: Longint;\r\n fValidateSource: BOOL): HRESULT; stdcall;\r\n function GetLinkSource(dwLink: Longint; var pszDisplayName: PChar;\r\n var lenFileName: Longint; var pszFullLinkType: PChar;\r\n var pszShortLinkType: PChar; var fSourceAvailable: BOOL;\r\n var fIsSelected: BOOL): HRESULT; stdcall;\r\n function OpenLinkSource(dwLink: Longint): HRESULT; stdcall;\r\n function UpdateLink(dwLink: Longint; fErrorMessage: BOOL;\r\n fErrorAction: BOOL): HRESULT; stdcall;\r\n function CancelLink(dwLink: Longint): HRESULT; stdcall;\r\n function GetLastUpdate(dwLink: Longint;\r\n var LastUpdate: TFileTime): HRESULT; stdcall;\r\n end;\r\n\r\n { TOleUIObjInfo - helper interface for Object Properties dialog }\r\n\r\n TOleUIObjInfo = class(TInterfacedObject, IOleUIObjInfo)\r\n private\r\n FRichEdit: TJvCustomRichEdit;\r\n FReObject: TReObject;\r\n public\r\n constructor Create(ARichEdit: TJvCustomRichEdit; ReObject: TReObject);\r\n function GetObjectInfo(dwObject: Longint;\r\n var dwObjSize: Longint; var lpszLabel: PChar;\r\n var lpszType: PChar; var lpszShortType: PChar;\r\n var lpszLocation: PChar): HRESULT; stdcall;\r\n function GetConvertInfo(dwObject: Longint; var ClassID: TCLSID;\r\n var wFormat: Word; var ConvertDefaultClassID: TCLSID;\r\n var lpClsidExclude: PCLSID; var cClsidExclude: Longint): HRESULT; stdcall;\r\n function ConvertObject(dwObject: Longint;\r\n const clsidNew: TCLSID): HRESULT; stdcall;\r\n function GetViewInfo(dwObject: Longint; var hMetaPict: HGLOBAL;\r\n var dvAspect: Longint; var nCurrentScale: Integer): HRESULT; stdcall;\r\n function SetViewInfo(dwObject: Longint; hMetaPict: HGLOBAL;\r\n dvAspect: Longint; nCurrentScale: Integer;\r\n bRelativeToOrig: BOOL): HRESULT; stdcall;\r\n end;\r\n\r\n TRichEditOleCallback = class(TObject, IUnknown, IRichEditOleCallback)\r\n private\r\n FDocForm: IVCLFrameForm;\r\n FFrameForm: IVCLFrameForm;\r\n FAccelTable: HACCEL;\r\n FAccelCount: Integer;\r\n FAutoScroll: Boolean;\r\n procedure CreateAccelTable;\r\n procedure DestroyAccelTable;\r\n procedure AssignFrame;\r\n private\r\n FRefCount: Longint;\r\n FRichEdit: TJvCustomRichEdit;\r\n public\r\n constructor Create(ARichEdit: TJvCustomRichEdit);\r\n destructor Destroy; override;\r\n function QueryInterface(const iid: TGUID; out Obj): HRESULT; stdcall;\r\n function _AddRef: Longint; stdcall;\r\n function _Release: Longint; stdcall;\r\n function GetNewStorage(out stg: IStorage): HRESULT; stdcall;\r\n function GetInPlaceContext(out Frame: IOleInPlaceFrame;\r\n out Doc: IOleInPlaceUIWindow;\r\n lpFrameInfo: POleInPlaceFrameInfo): HRESULT; stdcall;\r\n function GetClipboardData(const chrg: TCharRange; reco: DWORD;\r\n out dataObj: IDataObject): HRESULT; stdcall;\r\n function GetContextMenu(seltype: Word; const oleobj: IOleObject;\r\n const chrg: TCharRange; out Menu: HMENU): HRESULT; stdcall;\r\n function ShowContainerUI(fShow: BOOL): HRESULT; stdcall;\r\n function QueryInsertObject(const clsid: TCLSID; const stg: IStorage;\r\n cp: Longint): HRESULT; stdcall;\r\n function DeleteObject(const oleobj: IOleObject): HRESULT; stdcall;\r\n function QueryAcceptData(const dataObj: IDataObject; var cfFormat: TClipFormat;\r\n reco: DWORD; fReally: BOOL; hMetaPict: HGLOBAL): HRESULT; stdcall;\r\n function ContextSensitiveHelp(fEnterMode: BOOL): HRESULT; stdcall;\r\n function GetDragDropEffect(fDrag: BOOL; grfKeyState: DWORD;\r\n var dwEffect: DWORD): HRESULT; stdcall;\r\n end;\r\n\r\n TBiDiOptions = record\r\n cbSize: UINT;\r\n wMask: WORD;\r\n wEffects: WORD;\r\n end;\r\n\r\nconst\r\n { File Conversion Errors }\r\n fceTrue = FCE(1); // IsFormatCorrect32: recognized the input file.\r\n fceNoErr = FCE(0); // IsFormatCorrect32: Did not recognize the input file.\r\n // Operation completed successfully for other APIs\r\n fceOpenInFileErr = FCE(-1); // could not open input file\r\n fceReadErr = FCE(-2); // error during read\r\n fceOpenConvErr = FCE(-3); // error opening conversion file (obsolete)\r\n fceWriteErr = FCE(-4); // error during write\r\n fceInvalidFile = FCE(-5); // invalid data in conversion file\r\n fceOpenExceptErr = FCE(-6); // error opening exception file (obsolete)\r\n fceWriteExceptErr = FCE(-7); // error writing exception file (obsolete)\r\n fceNoMemory = FCE(-8); // out of memory\r\n fceInvalidDoc = FCE(-9); // invalid document (obsolete)\r\n fceDiskFull = FCE(-10); // out of space on output (obsolete)\r\n fceDocTooLarge = FCE(-11); // conversion document too large for target (obsolete)\r\n fceOpenOutFileErr = FCE(-12); // could not open output file\r\n fceUserCancel = FCE(-13); // conversion cancelled by user\r\n fceWrongFileType = FCE(-14); // wrong file type for this converter\r\n\r\n CTwipsPerInch = 1440;\r\n CTwipsPerPoint = 20;\r\n CHundredthMMPerInch = 2540;\r\n CPointsPerInch = 72;\r\n\r\n RichEdit10ModuleName = 'RICHED32.DLL';\r\n RichEdit20ModuleName = 'RICHED20.DLL';\r\n\r\n FT_DOWN = 1;\r\n\r\n // PARAFORMAT2 wNumberingStyle options\r\n PFNS_PAREN = $0000; // default, e.g., 1)\r\n PFNS_PARENS = $0100; // tomListParentheses/256, e.g., (1)\r\n PFNS_PERIOD = $0200; // tomListPeriod/256, e.g., 1.\r\n PFNS_PLAIN = $0300; // tomListPlain/256, e.g., 1\r\n PFNS_NONUMBER = $0400; // Used for continuation w/o number\r\n PFNS_NEWNUMBER = $8000; // Start new number with wNumberingStart\r\n\r\n // (can be combined with other PFNS_xxx)\r\n\r\n EM_GETBIDIOPTIONS = (WM_USER + 200);\r\n EM_SETBIDIOPTIONS = (WM_USER + 201);\r\n EM_SETTYPOGRAPHYOPTIONS = (WM_USER + 202);\r\n EM_GETTYPOGRAPHYOPTIONS = (WM_USER + 203);\r\n\r\n // Options for EM_SETTYPOGRAPHYOPTIONS\r\n\r\n TO_ADVANCEDTYPOGRAPHY = 1;\r\n TO_SIMPLELINEBREAK = 2;\r\n TO_DISABLECUSTOMTEXTOUT = 4;\r\n TO_ADVANCEDLAYOUT = 8;\r\n\r\n // Options for EM_GET/EM_SET TYPOGRAPHYOPTIONS\r\n BOM_DEFPARADIR = $0001; // Default paragraph direction (implies alignment) (obsolete)\r\n BOM_PLAINTEXT = $0002; // Use plain text layout (obsolete)\r\n BOM_NEUTRALOVERRIDE = $0004; // Override neutral layout (obsolete)\r\n BOM_CONTEXTREADING = $0008; // Context reading order\r\n BOM_CONTEXTALIGNMENT = $0010; // Context alignment\r\n\r\n BOE_RTLDIR = $0001; // Default paragraph direction (implies alignment) (obsolete)\r\n BOE_PLAINTEXT = $0002; // Use plain text layout (obsolete)\r\n BOE_NEUTRALOVERRIDE = $0004; // Override neutral layout (obsolete)\r\n BOE_CONTEXTREADING = $0008; // Context reading order\r\n BOE_CONTEXTALIGNMENT = $0010; // Context alignment\r\n\r\n\r\n\r\n // Underline types. RE 1.0 displays only CFU_UNDERLINE\r\n CFU_CF1UNDERLINE = $FF; // Map charformat's bit underline to CF2\r\n CFU_INVERT = $FE; // For IME composition fake a selection\r\n CFU_UNDERLINETHICKLONGDASH = 18; // (*) display as dash\r\n CFU_UNDERLINETHICKDOTTED = 17; // (*) display as dot\r\n CFU_UNDERLINETHICKDASHDOTDOT = 16; // (*) display as dash dot dot\r\n CFU_UNDERLINETHICKDASHDOT = 15; // (*) display as dash dot\r\n CFU_UNDERLINETHICKDASH = 14; // (*) display as dash\r\n CFU_UNDERLINELONGDASH = 13; // (*) display as dash\r\n CFU_UNDERLINEHEAVYWAVE = 12; // (*) display as wave\r\n CFU_UNDERLINEDOUBLEWAVE = 11; // (*) display as wave\r\n CFU_UNDERLINEHAIRLINE = 10; // (*) display as single\r\n CFU_UNDERLINETHICK = 9;\r\n CFU_UNDERLINEWAVE = 8;\r\n CFU_UNDERLINEDASHDOTDOT = 7;\r\n CFU_UNDERLINEDASHDOT = 6;\r\n CFU_UNDERLINEDASH = 5;\r\n CFU_UNDERLINEDOTTED = 4;\r\n CFU_UNDERLINEDOUBLE = 3; // (*) display as single\r\n CFU_UNDERLINEWORD = 2; // (*) display as single\r\n CFU_UNDERLINE = 1;\r\n CFU_UNDERLINENONE = 0;\r\n\r\n AttrFlags: array[TJvAttributeType] of Word =\r\n (0, SCF_SELECTION, SCF_WORD or SCF_SELECTION);\r\n\r\n CF_EMBEDDEDOBJECT = 'Embedded Object';\r\n CF_LINKSOURCE = 'Link Source';\r\n\r\n EM_GETZOOM = (WM_USER + 224);\r\n EM_SETZOOM = (WM_USER + 225);\r\n\r\n // Some masks for tab alignment and leader handling\r\n // Note: not the official names which I don't know\r\n\r\n TA_ALIGNMENT = $0F000000; // Bits 24-27\r\n TA_LEADER = $F0000000; // Bits 28-31\r\n //TA_ALL = $FF000000; // Bits 24-31\r\n TA_TAB = $00FFFFFF; // Tab: bits 0-23\r\n TA_TAB_LEADER = (TA_TAB or TA_LEADER);\r\n TA_TAB_ALIGNMENT = (TA_TAB or TA_ALIGNMENT);\r\n\r\n { Flags to specify which interfaces should be returned in the structure above }\r\n\r\n REO_GETOBJ_NO_INTERFACES = $00000000;\r\n REO_GETOBJ_POLEOBJ = $00000001;\r\n REO_GETOBJ_PSTG = $00000002;\r\n REO_GETOBJ_POLESITE = $00000004;\r\n REO_GETOBJ_ALL_INTERFACES = $00000007;\r\n\r\n { Place object at selection }\r\n\r\n REO_CP_SELECTION = ULONG(-1);\r\n\r\n { Use character position to specify object instead of index }\r\n\r\n REO_IOB_SELECTION = ULONG(-1);\r\n REO_IOB_USE_CP = ULONG(-2);\r\n\r\n { Object flags }\r\n\r\n REO_NULL = $00000000; { No flags }\r\n REO_READWRITEMASK = $0000003F; { Mask out RO bits }\r\n REO_DONTNEEDPALETTE = $00000020; { Object doesn't need palette }\r\n REO_BLANK = $00000010; { Object is blank }\r\n REO_DYNAMICSIZE = $00000008; { Object defines size always }\r\n REO_INVERTEDSELECT = $00000004; { Object drawn all inverted if sel }\r\n REO_BELOWBASELINE = $00000002; { Object sits below the baseline }\r\n REO_RESIZABLE = $00000001; { Object may be resized }\r\n REO_LINK = $80000000; { Object is a link (RO) }\r\n REO_STATIC = $40000000; { Object is static (RO) }\r\n REO_SELECTED = $08000000; { Object selected (RO) }\r\n REO_OPEN = $04000000; { Object open in its server (RO) }\r\n REO_INPLACEACTIVE = $02000000; { Object in place active (RO) }\r\n REO_HILITED = $01000000; { Object is to be hilited (RO) }\r\n REO_LINKAVAILABLE = $00800000; { Link believed available (RO) }\r\n REO_GETMETAFILE = $00400000; { Object requires metafile (RO) }\r\n\r\n { Flags for IRichEditOle.GetClipboardData, }\r\n { IRichEditOleCallback.GetClipboardData and }\r\n { IRichEditOleCallback.QueryAcceptData }\r\n\r\n RECO_PASTE = $00000000; { paste from clipboard }\r\n RECO_DROP = $00000001; { drop }\r\n RECO_COPY = $00000002; { copy to the clipboard }\r\n RECO_CUT = $00000003; { cut to the clipboard }\r\n RECO_DRAG = $00000004; { drag }\r\n\r\n ReadError = $0001;\r\n WriteError = $0002;\r\n NoError = $0000;\r\n\r\n RichLangOptions: array[TRichLangOption] of DWORD = (IMF_AUTOKEYBOARD,\r\n IMF_AUTOFONT, IMF_IMECANCELCOMPLETE, IMF_IMEALWAYSSENDNOTIFY);\r\n\r\n CHex: array[0..$F] of AnsiChar =\r\n ('0', '1', '2', '3', '4', '5', '6', '7', '8', '9',\r\n 'A', 'B', 'C', 'D', 'E', 'F');\r\n\r\n { Converter API names }\r\n\r\n ForeignToRtf32Name = 'ForeignToRtf32';\r\n InitConverter32Name = 'InitConverter32';\r\n IsFormatCorrect32Name = 'IsFormatCorrect32';\r\n RtfToForeign32Name = 'RtfToForeign32';\r\n UninitConverterName = 'UninitConverter';\r\n CchFetchLpszErrorName = 'CchFetchLpszError';\r\n\r\n CConvertBufferSize = $1004;\r\n\r\nvar\r\n { Clipboard formats }\r\n CFEmbeddedObject: Integer;\r\n CFLinkSource: Integer;\r\n CFRtf: Integer;\r\n CFRtfNoObjs: Integer;\r\n\r\n { Global converter vars }\r\n GlobalConversionFormatList: TConversionFormatList = nil;\r\n GCurrentConverter: TJvMSTextConversion = nil;\r\n GMSTextConvertersRegistered: Boolean;\r\n\r\n Painting: Boolean = False;\r\n\r\n//=== Local procedures =======================================================\r\n\r\nfunction GConversionFormatList: TConversionFormatList;\r\nbegin\r\n if not Assigned(GlobalConversionFormatList) then\r\n GlobalConversionFormatList := TConversionFormatList.Create;\r\n Result := GlobalConversionFormatList;\r\nend;\r\n\r\nfunction GetParentWindow(Control: TControl): THandle;\r\nbegin\r\n if Control <> nil then\r\n Control := GetParentForm(Control);\r\n\r\n if Control is TWinControl then\r\n Result := TWinControl(Control).Handle\r\n else\r\n Result := Application.Handle;\r\nend;\r\n\r\n{ OLE utility routines }\r\n\r\nfunction WStrLen(Str: PWideChar): Integer;\r\nbegin\r\n Result := 0;\r\n while Str[Result] <> #0 do\r\n Inc(Result);\r\nend;\r\n\r\nprocedure ReleaseObject(var Obj);\r\nbegin\r\n if IUnknown(Obj) <> nil then\r\n begin\r\n IUnknown(Obj) := nil;\r\n end;\r\nend;\r\n\r\nprocedure CreateStorage(var Storage: IStorage);\r\nvar\r\n LockBytes: ILockBytes;\r\nbegin\r\n OleCheck(CreateILockBytesOnHGlobal(0, True, LockBytes));\r\n try\r\n OleCheck(StgCreateDocfileOnILockBytes(LockBytes,\r\n STGM_READWRITE or STGM_SHARE_EXCLUSIVE or STGM_CREATE, 0, Storage));\r\n finally\r\n ReleaseObject(LockBytes);\r\n end;\r\nend;\r\n\r\nprocedure DestroyMetaPict(MetaPict: HGLOBAL);\r\nbegin\r\n if MetaPict <> 0 then\r\n begin\r\n DeleteMetaFile(PMetafilePict(GlobalLock(MetaPict))^.hMF);\r\n GlobalUnlock(MetaPict);\r\n GlobalFree(MetaPict);\r\n end;\r\nend;\r\n\r\nfunction OleSetDrawAspect(OleObject: IOleObject; Iconic: Boolean;\r\n IconMetaPict: HGLOBAL; var DrawAspect: Longint): HRESULT;\r\nvar\r\n OleCache: IOleCache;\r\n EnumStatData: IEnumStatData;\r\n OldAspect, AdviseFlags, Connection: Longint;\r\n TempMetaPict: HGLOBAL;\r\n FormatEtc: TFormatEtc;\r\n Medium: TStgMedium;\r\n ClassID: TCLSID;\r\n StatData: TStatData;\r\nbegin\r\n Result := S_OK;\r\n OldAspect := DrawAspect;\r\n if Iconic then\r\n begin\r\n DrawAspect := DVASPECT_ICON;\r\n AdviseFlags := ADVF_NODATA;\r\n end\r\n else\r\n begin\r\n DrawAspect := DVASPECT_CONTENT;\r\n AdviseFlags := ADVF_PRIMEFIRST;\r\n end;\r\n if (DrawAspect <> OldAspect) or (DrawAspect = DVASPECT_ICON) then\r\n begin\r\n Result := OleObject.QueryInterface(IOleCache, OleCache);\r\n if Succeeded(Result) then\r\n try\r\n if DrawAspect <> OldAspect then\r\n begin\r\n { Setup new cache with the new aspect }\r\n FillChar(FormatEtc, SizeOf(FormatEtc), 0);\r\n FormatEtc.dwAspect := DrawAspect;\r\n FormatEtc.lindex := -1;\r\n Result := OleCache.Cache(FormatEtc, AdviseFlags, Connection);\r\n end;\r\n if Succeeded(Result) and (DrawAspect = DVASPECT_ICON) then\r\n begin\r\n TempMetaPict := 0;\r\n if IconMetaPict = 0 then\r\n begin\r\n if Succeeded(OleObject.GetUserClassID(ClassID)) then\r\n begin\r\n TempMetaPict := OleGetIconOfClass(ClassID, nil, True);\r\n IconMetaPict := TempMetaPict;\r\n end;\r\n end;\r\n try\r\n FormatEtc.cfFormat := CF_METAFILEPICT;\r\n FormatEtc.ptd := nil;\r\n FormatEtc.dwAspect := DVASPECT_ICON;\r\n FormatEtc.lindex := -1;\r\n FormatEtc.tymed := TYMED_MFPICT;\r\n Medium.tymed := TYMED_MFPICT;\r\n Medium.hMetaFilePict := IconMetaPict;\r\n Medium.unkForRelease := nil;\r\n Result := OleCache.SetData(FormatEtc, Medium, False);\r\n finally\r\n DestroyMetaPict(TempMetaPict);\r\n end;\r\n end;\r\n if Succeeded(Result) and (DrawAspect <> OldAspect) then\r\n begin\r\n { remove any existing caches that are set up for the old display aspect }\r\n OleCache.EnumCache(EnumStatData);\r\n if EnumStatData <> nil then\r\n try\r\n while EnumStatData.Next(1, StatData, nil) = 0 do\r\n if StatData.FormatEtc.dwAspect = OldAspect then\r\n OleCache.Uncache(StatData.dwConnection);\r\n finally\r\n ReleaseObject(EnumStatData);\r\n end;\r\n end;\r\n finally\r\n ReleaseObject(OleCache);\r\n end;\r\n if Succeeded(Result) and (DrawAspect <> DVASPECT_ICON) then\r\n OleObject.Update;\r\n end;\r\nend;\r\n\r\nfunction GetIconMetaPict(OleObject: IOleObject; DrawAspect: Longint): HGLOBAL;\r\nvar\r\n DataObject: IDataObject;\r\n FormatEtc: TFormatEtc;\r\n Medium: TStgMedium;\r\n ClassID: TCLSID;\r\nbegin\r\n Result := 0;\r\n if DrawAspect = DVASPECT_ICON then\r\n begin\r\n OleObject.QueryInterface(IDataObject, DataObject);\r\n if DataObject <> nil then\r\n begin\r\n FormatEtc.cfFormat := CF_METAFILEPICT;\r\n FormatEtc.ptd := nil;\r\n FormatEtc.dwAspect := DVASPECT_ICON;\r\n FormatEtc.lindex := -1;\r\n FormatEtc.tymed := TYMED_MFPICT;\r\n if Succeeded(DataObject.GetData(FormatEtc, Medium)) then\r\n Result := Medium.hMetaFilePict;\r\n ReleaseObject(DataObject);\r\n end;\r\n end;\r\n if Result = 0 then\r\n begin\r\n OleCheck(OleObject.GetUserClassID(ClassID));\r\n Result := OleGetIconOfClass(ClassID, nil, True);\r\n end;\r\nend;\r\n\r\n{ Return the first piece of a moniker }\r\n\r\nfunction OleStdGetFirstMoniker(Moniker: IMoniker): IMoniker;\r\nvar\r\n Mksys: Longint;\r\n EnumMoniker: IEnumMoniker;\r\nbegin\r\n Result := nil;\r\n if Moniker <> nil then\r\n begin\r\n if (Moniker.IsSystemMoniker(Mksys) = 0) and\r\n (Mksys = MKSYS_GENERICCOMPOSITE) then\r\n begin\r\n if Moniker.Enum(True, EnumMoniker) <> 0 then\r\n Exit;\r\n EnumMoniker.Next(1, Result, nil);\r\n ReleaseObject(EnumMoniker);\r\n end\r\n else\r\n begin\r\n Result := Moniker;\r\n end;\r\n end;\r\nend;\r\n\r\n{ Return length of file moniker piece of the given moniker }\r\n\r\nfunction OleStdGetLenFilePrefixOfMoniker(Moniker: IMoniker): Integer;\r\nvar\r\n MkFirst: IMoniker;\r\n BindCtx: IBindCtx;\r\n Mksys: Longint;\r\n P: PWideChar;\r\nbegin\r\n Result := 0;\r\n if Moniker <> nil then\r\n begin\r\n MkFirst := OleStdGetFirstMoniker(Moniker);\r\n if MkFirst <> nil then\r\n begin\r\n if (MkFirst.IsSystemMoniker(Mksys) = 0) and\r\n (Mksys = MKSYS_FILEMONIKER) then\r\n begin\r\n if CreateBindCtx(0, BindCtx) = 0 then\r\n begin\r\n if (MkFirst.GetDisplayName(BindCtx, nil, P) = 0) and (P <> nil) then\r\n begin\r\n Result := WStrLen(P);\r\n CoTaskMemFree(P);\r\n end;\r\n ReleaseObject(BindCtx);\r\n end;\r\n end;\r\n ReleaseObject(MkFirst);\r\n end;\r\n end;\r\nend;\r\n\r\nfunction CoAllocCStr(const S: string): PChar;\r\nbegin\r\n Result := StrCopy(CoTaskMemAlloc(Length(S) * SizeOf(Char) + 1), PChar(S));\r\nend;\r\n\r\nfunction WStrToString(P: PWideChar): string;\r\nbegin\r\n Result := '';\r\n if P <> nil then\r\n begin\r\n Result := WideCharToString(P);\r\n CoTaskMemFree(P);\r\n end;\r\nend;\r\n\r\nfunction GetFullNameStr(OleObject: IOleObject): string;\r\nvar\r\n P: PWideChar;\r\nbegin\r\n OleObject.GetUserType(USERCLASSTYPE_FULL, P);\r\n Result := WStrToString(P);\r\nend;\r\n\r\nfunction GetShortNameStr(OleObject: IOleObject): string;\r\nvar\r\n P: PWideChar;\r\nbegin\r\n OleObject.GetUserType(USERCLASSTYPE_SHORT, P);\r\n Result := WStrToString(P);\r\nend;\r\n\r\nfunction GetDisplayNameStr(OleLink: IOleLink): string;\r\nvar\r\n P: PWideChar;\r\nbegin\r\n OleLink.GetSourceDisplayName(P);\r\n Result := WStrToString(P);\r\nend;\r\n\r\nfunction GetVCLFrameForm(Form: TCustomForm): IVCLFrameForm;\r\nbegin\r\n if Form.OleFormObject = nil then\r\n TOleForm.Create(Form);\r\n Result := Form.OleFormObject as IVCLFrameForm;\r\nend;\r\n\r\nfunction IsFormMDIChild(Form: TCustomForm): Boolean;\r\nbegin\r\n Result := (Form is TForm) and (TForm(Form).FormStyle = fsMDIChild);\r\nend;\r\n\r\nprocedure LinkError(const Ident: string);\r\nbegin\r\n Application.MessageBox(PChar(Ident), PChar(SLinkProperties),\r\n MB_OK or MB_ICONSTOP);\r\nend;\r\n\r\n{ Get RichEdit OLE interface }\r\n\r\nfunction GetRichEditOle(Wnd: HWND; var RichEditOle): Boolean;\r\nbegin\r\n Result := SendMessage(Wnd, EM_GETOLEINTERFACE, 0, LPARAM(@RichEditOle)) <> 0;\r\nend;\r\n\r\nfunction StreamSave(dwCookie: Longint; pbBuff: PByte;\r\n cb: Longint; var pcb: Longint): Longint; stdcall;\r\nvar\r\n Converter: TJvConversion;\r\nbegin\r\n Result := NoError;\r\n Converter := TJvConversion(dwCookie);\r\n try\r\n pcb := 0;\r\n if Converter <> nil then\r\n pcb := Converter.ConvertWrite({$IFNDEF COMPILER12_UP}PAnsiChar{$ENDIF !COMPILER12_UP}(pbBuff), cb);\r\n except\r\n Result := WriteError;\r\n end;\r\nend;\r\n\r\ntype\r\n TCookie = class\r\n private\r\n FConverter: TJvConversion;\r\n FSkipLf, FSkipCr: Boolean;\r\n // SourceLength is number of characters\r\n function AdjustLineBreaks(Dest, Source: PAnsiChar; SourceLength: Integer): Integer;\r\n function AdjustLineBreaksW(Dest, Source: PWideChar; SourceLength: Integer): Integer;\r\n public\r\n constructor Create(AConverter: TJvConversion);\r\n // BufferSize is the size of the Buffer in bytes\r\n function Load(Buffer: PByte; BufferSize: Longint): Longint;\r\n function LoadW(Buffer: PByte; BufferSize: Longint): Longint;\r\n property Converter: TJvConversion read FConverter;\r\n end;\r\n\r\n{ AdjustLineBreaks adjusts all line breaks in the given string S to be true\r\n #13/#10 sequences. The function changes any #13 characters not followed by a #10\r\n and any #10 characters not preceded by a #13 into #13/#10 pairs. It also\r\n converts #10/#13 pairs to #13/#10 pairs. The #10/#13 pair is common in Unix text\r\n files. (SysUtils)\r\n}\r\n\r\nfunction TCookie.AdjustLineBreaks(Dest, Source: PAnsiChar; SourceLength: Integer): Integer;\r\nvar\r\n SourceEnd: PAnsiChar;\r\n DestStart: PAnsiChar;\r\nbegin\r\n SourceEnd := Source + SourceLength;\r\n DestStart := Dest;\r\n while Source < SourceEnd do\r\n begin\r\n case Source^ of\r\n Lf:\r\n if FSkipLf then\r\n FSkipLf := False\r\n else\r\n begin\r\n Dest^ := Cr;\r\n Inc(Dest);\r\n Dest^ := Lf;\r\n Inc(Dest);\r\n FSkipCr := True;\r\n end;\r\n Cr:\r\n if FSkipCr then\r\n FSkipCr := False\r\n else\r\n begin\r\n Dest^ := Cr;\r\n Inc(Dest);\r\n Dest^ := Lf;\r\n Inc(Dest);\r\n FSkipLf := True;\r\n end;\r\n else\r\n FSkipCr := False;\r\n FSkipLf := False;\r\n Dest^ := Source^;\r\n Inc(Dest);\r\n end;\r\n Inc(Source);\r\n end;\r\n Result := Dest - DestStart;\r\nend;\r\n\r\nfunction TCookie.AdjustLineBreaksW(Dest, Source: PWideChar;\r\n SourceLength: Integer): Integer;\r\nvar\r\n SourceEnd: PWideChar;\r\n DestStart: PWideChar;\r\nbegin\r\n SourceEnd := Source + SourceLength;\r\n DestStart := Dest;\r\n while Source < SourceEnd do\r\n begin\r\n case Source^ of\r\n #10:\r\n if FSkipLf then\r\n FSkipLf := False\r\n else\r\n begin\r\n Dest^ := #13;\r\n Inc(Dest);\r\n Dest^ := #10;\r\n Inc(Dest);\r\n FSkipCr := True;\r\n end;\r\n #13:\r\n if FSkipCr then\r\n FSkipCr := False\r\n else\r\n begin\r\n Dest^ := #13;\r\n Inc(Dest);\r\n Dest^ := #10;\r\n Inc(Dest);\r\n FSkipLf := True;\r\n end;\r\n else\r\n FSkipCr := False;\r\n FSkipLf := False;\r\n Dest^ := Source^;\r\n Inc(Dest);\r\n end;\r\n Inc(Source);\r\n end;\r\n Result := Dest - DestStart;\r\nend;\r\n\r\nconstructor TCookie.Create(AConverter: TJvConversion);\r\nbegin\r\n inherited Create;\r\n FConverter := AConverter;\r\nend;\r\n\r\nfunction TCookie.Load(Buffer: PByte; BufferSize: Longint): Longint;\r\nvar\r\n pBuff: {$IFDEF COMPILER12_UP}PByte{$ELSE}PAnsiChar{$ENDIF COMPILER12_UP};\r\nbegin\r\n BufferSize := BufferSize div 2;\r\n Result := 0;\r\n pBuff := {$IFNDEF COMPILER12_UP}PAnsiChar{$ENDIF !COMPILER12_UP}(Buffer) + BufferSize;\r\n if Converter <> nil then\r\n Result := Converter.ConvertRead(pBuff, BufferSize);\r\n if Result > 0 then\r\n Result := AdjustLineBreaks(PAnsiChar(Buffer), PAnsiChar(pBuff), Result);\r\nend;\r\n\r\nfunction TCookie.LoadW(Buffer: PByte; BufferSize: Integer): Longint;\r\nvar\r\n pBuff: PWideChar;\r\nbegin\r\n // AdjustLineBreaksW can double the needed buffer size; so tell the converter\r\n // to use only half the buffer and (Mantis #4129) ensure BufferSize is even.\r\n BufferSize := (BufferSize div 4) * 2;\r\n Result := 0;\r\n pBuff := PWideChar(Buffer) + BufferSize div 2;\r\n if Converter <> nil then\r\n Result := Converter.ConvertRead({$IFDEF COMPILER12_UP}PByte{$ELSE}PAnsiChar{$ENDIF COMPILER12_UP}(pBuff), BufferSize);\r\n if Result > 0 then\r\n Result := 2 * AdjustLineBreaksW(PWideChar(Buffer), PWideChar(pBuff), Result div 2);\r\nend;\r\n\r\nfunction StreamLoad(dwCookie: Longint; pbBuff: PByte;\r\n cb: Longint; var pcb: Longint): Longint; stdcall;\r\nbegin\r\n Result := NoError;\r\n try\r\n pcb := TCookie(dwCookie).Load(pbBuff, cb);\r\n except\r\n Result := ReadError;\r\n end;\r\nend;\r\n\r\nfunction StreamLoadW(dwCookie: Longint; pbBuff: PByte;\r\n cb: Longint; var pcb: Longint): Longint; stdcall;\r\nbegin\r\n Result := NoError;\r\n try\r\n pcb := TCookie(dwCookie).LoadW(pbBuff, cb);\r\n except\r\n Result := ReadError;\r\n end;\r\nend;\r\n\r\nfunction FileNameToHGLOBAL(const AFileName: AnsiString): HGLOBAL;\r\nvar\r\n DataPtr: Pointer;\r\n Buffer: array[0..MAX_PATH] of AnsiChar;\r\nbegin\r\n // DOC : Each entry point that accepts file names should expect all file name\r\n // arguments from Word to be in the OEM character set (unless the character\r\n // set is explicitly negotiated using RegisterApp).\r\n //\r\n // For example: CharToOem will translate the copyright (c) symbol (=1 char)\r\n // to C (or something). Not doing so will result in errors.\r\n\r\n StrCopy(Buffer, PAnsiChar(AFileName));\r\n CharToOemA(Buffer, Buffer);\r\n\r\n Result := GlobalAlloc(GHND, StrLen(Buffer) + 1); // with last #0, thus + 1\r\n try\r\n DataPtr := GlobalLock(Result);\r\n try\r\n StrCopy(DataPtr, Buffer);\r\n finally\r\n GlobalUnlock(Result);\r\n end;\r\n except\r\n GlobalFree(Result);\r\n raise;\r\n end;\r\nend;\r\n\r\nfunction AnsiStringToHGLOBAL(const S: AnsiString): HGLOBAL;\r\nvar\r\n DataPtr: Pointer;\r\nbegin\r\n Result := GlobalAlloc(GHND, Length(S) + 1); // with last #0, thus + 1\r\n try\r\n DataPtr := GlobalLock(Result);\r\n try\r\n Move(PAnsiChar(S)^, DataPtr^, Length(S) + 1);\r\n finally\r\n GlobalUnlock(Result);\r\n end;\r\n except\r\n GlobalFree(Result);\r\n raise;\r\n end;\r\nend;\r\n\r\nfunction ExportCallback(cchBuff, nPercent: Longint): Longint; stdcall;\r\nbegin\r\n Result := GCurrentConverter.HandleExportCallback(cchBuff, nPercent);\r\nend;\r\n\r\nfunction ImportCallback(cchBuff, nPercent: Longint): Longint; stdcall;\r\nbegin\r\n Result := GCurrentConverter.HandleImportCallback(cchBuff, nPercent);\r\nend;\r\n\r\nfunction FCEToString(AErrorCode: FCE): string;\r\nbegin\r\n case AErrorCode of\r\n fceOpenInFileErr: Result := RsEOpenInFileErr;\r\n fceReadErr: Result := RsEReadErr;\r\n fceOpenConvErr: Result := RsEOpenConvErr;\r\n fceWriteErr: Result := RsEWriteErr;\r\n fceInvalidFile: Result := RsEInvalidFile;\r\n fceOpenExceptErr: Result := RsEOpenExceptErr;\r\n fceWriteExceptErr: Result := RsEWriteExceptErr;\r\n fceNoMemory: Result := RsENoMemory;\r\n fceInvalidDoc: Result := RsEInvalidDoc;\r\n fceDiskFull: Result := RsEDiskFull;\r\n fceDocTooLarge: Result := RsEDocTooLarge;\r\n fceOpenOutFileErr: Result := RsEOpenOutFileErr;\r\n fceUserCancel: Result := RsEUserCancel;\r\n fceWrongFileType: Result := RsEWrongFileType;\r\n else\r\n Result := '';\r\n end;\r\nend;\r\n\r\n//=== Global procedures ======================================================\r\n\r\nprocedure BitmapToRTF(ABitmap: TBitmap; AStream: TStream);\r\nconst\r\n CPrefix = '{\\rtf1 {\\pict\\picw%d\\pich%d\\dibitmap0 ';\r\n CPostfix = AnsiString(' }}');\r\nvar\r\n Header, Bits: PAnsiChar;\r\n HeaderSize, BitsSize: DWORD;\r\n P, Q: PAnsiChar;\r\n S: AnsiString;\r\nbegin\r\n GetDIBSizes(ABitmap.Handle, HeaderSize, BitsSize);\r\n GetMem(Header, 2 * (HeaderSize + BitsSize));\r\n try\r\n Bits := Header + HeaderSize;\r\n GetDIB(ABitmap.Handle, ABitmap.Palette, Header^, Bits^);\r\n\r\n { Example :\r\n\r\n HeaderSize = 2, BitsSize = 2\r\n\r\n Header = $AB, $00, $DE, $F8, ?? , ?? , ?? , ??\r\n ->\r\n Header = 'A', 'B', '0', '0', 'D', 'E', 'F', '8'\r\n }\r\n Q := Header + HeaderSize + BitsSize - 1;\r\n //P := Header + 2 * (HeaderSize + BitsSize) - 1;\r\n P := Q + HeaderSize + BitsSize;\r\n while Q >= Header do\r\n begin\r\n P^ := CHex[Byte(Q^) mod 16];\r\n Dec(P);\r\n P^ := CHex[Byte(Q^) div 16];\r\n Dec(P);\r\n Dec(Q);\r\n end;\r\n S := AnsiString(Format(CPrefix, [ABitmap.Width, ABitmap.Height]));\r\n AStream.Write(PAnsiChar(S)^, Length(S));\r\n AStream.Write(Header^, (HeaderSize + BitsSize) * 2);\r\n AStream.Write(CPostfix, Length(CPostfix));\r\n finally\r\n FreeMem(Header);\r\n end;\r\nend;\r\n\r\nfunction BitmapToRTF2(ABitmap: TBitmap; AStream: TStream): Boolean;\r\n\r\n{\r\n\r\n \\wmetafileN - Source of the picture is a Windows metafile. The N argument\r\n identifies the metafile type (the default type is 1).\r\n \\picwN - xExt field if the picture is a Windows metafile; picture\r\n width in pixels if the picture is a bitmap or from QuickDraw.\r\n The N argument is a long integer.\r\n \\pichN - yExt field if the picture is a Windows metafile; picture\r\n height in pixels if the picture is a bitmap or from QuickDraw.\r\n The N argument is a long integer.\r\n \\picwgoalN - Desired width of the picture in twips. The N argument is a\r\n long integer.\r\n \\pichgoalN - Desired height of the picture in twips. The N argument is a\r\n long integer.\r\n}\r\n\r\nconst\r\n CPrefix = '{\\rtf1 {\\pict\\wmetafile8\\picw%d\\pich%d\\picwgoal%d\\pichgoal%d ';\r\n CPostfix = AnsiString(' }}');\r\nvar\r\n P, Q: PAnsiChar;\r\n S: AnsiString;\r\n DC: HDC;\r\n MetafileHandle: HMETAFILE;\r\n Size: TPoint;\r\n BitsLength: UINT;\r\n Bits: PAnsiChar;\r\nbegin\r\n Result := False;\r\n\r\n // Retrieve Extent\r\n Size.X := MulDiv(ABitmap.Width, CHundredthMMPerInch, Screen.PixelsPerInch);\r\n Size.Y := MulDiv(ABitmap.Height, CHundredthMMPerInch, Screen.PixelsPerInch);\r\n\r\n // Create Metafile DC and set it up\r\n DC := CreateMetafile(nil);\r\n\r\n SetWindowOrgEx(DC, 0, 0, nil);\r\n SetWindowExtEx(DC, Size.X, Size.Y, nil);\r\n\r\n StretchBlt(DC, 0, 0, Size.X, Size.Y,\r\n ABitmap.Canvas.Handle, 0, 0, ABitmap.Width, ABitmap.Height, SRCCOPY);\r\n\r\n MetafileHandle := CloseMetaFile(DC);\r\n\r\n if MetafileHandle = 0 then\r\n Exit;\r\n\r\n try\r\n BitsLength := GetMetaFileBitsEx(MetafileHandle, 0, nil);\r\n GetMem(Bits, BitsLength * 2);\r\n try\r\n if GetMetaFileBitsEx(MetafileHandle, BitsLength, Bits) < BitsLength then\r\n Exit;\r\n\r\n Q := Bits + BitsLength - 1;\r\n //P := Bits + 2 * BitsLength - 1;\r\n P := Q + BitsLength;\r\n while Q >= Bits do\r\n begin\r\n P^ := CHex[Byte(Q^) mod 16];\r\n Dec(P);\r\n P^ := CHex[Byte(Q^) div 16];\r\n Dec(P);\r\n Dec(Q);\r\n end;\r\n\r\n S := AnsiString(Format(CPrefix, [Size.X, Size.Y,\r\n MulDiv(ABitmap.Width, CTwipsPerInch, Screen.PixelsPerInch),\r\n MulDiv(ABitmap.Height, CTwipsPerInch, Screen.PixelsPerInch)]));\r\n AStream.Write(PAnsiChar(S)^, Length(S));\r\n AStream.Write(Bits^, BitsLength * 2);\r\n AStream.Write(CPostfix, Length(CPostfix));\r\n\r\n Result := True;\r\n finally\r\n FreeMem(Bits, BitsLength * 2);\r\n end;\r\n finally\r\n DeleteMetaFile(MetafileHandle);\r\n end;\r\nend;\r\n\r\n//=== { EMSTextConversionError } =============================================\r\n\r\nconstructor EMSTextConversionError.Create(const Msg: string; AErrorCode: FCE);\r\nvar\r\n S: string;\r\nbegin\r\n S := Msg;\r\n if S = '' then\r\n begin\r\n S := FCEToString(AErrorCode);\r\n if S = '' then\r\n S := Format(RsEConversionError, [AErrorCode]);\r\n end;\r\n inherited Create(S);\r\n FErrorCode := AErrorCode;\r\nend;\r\n\r\n//=== { TConversionFormatList } ==============================================\r\n\r\nconstructor TConversionFormatList.Create;\r\nbegin\r\n inherited Create;\r\n FRTFConvIndex := Add(TJvRTFConversion.Create);\r\n FTextConvIndex := Add(TJvTextConversion.Create);\r\nend;\r\n\r\nfunction TConversionFormatList.DefaultConverter: TJvConversion;\r\nbegin\r\n Result := Items[FRTFConvIndex];\r\nend;\r\n\r\nfunction TConversionFormatList.GetConverter(\r\n AParentWindow: THandle; AStream: TStream;\r\n const Kind: TJvConversionKind): TJvConversion;\r\nbegin\r\n { Return either the RTF converter or the text converter }\r\n Result := Items[FRTFConvIndex];\r\n Result.Init(AParentWindow);\r\n if Result.CanHandle(Kind) and\r\n ((Kind <> ckImport) or Result.IsFormatCorrect(AStream)) then\r\n { Caller must call Done }\r\n Exit;\r\n Result.Done;\r\n\r\n Result := Items[FTextConvIndex];\r\n Result.Init(AParentWindow);\r\nend;\r\n\r\nfunction TConversionFormatList.GetConverter(AParentWindow: THandle;\r\n const AFileName: string; const Kind: TJvConversionKind): TJvConversion;\r\nvar\r\n Ext: string;\r\n I: Integer;\r\nbegin\r\n Ext := AnsiLowerCase(ExtractFileExt(AFileName));\r\n System.Delete(Ext, 1, 1);\r\n\r\n for I := 0 to Count - 1 do\r\n begin\r\n Result := Items[I];\r\n Result.Init(AParentWindow);\r\n if Result.CanHandle(Ext, Kind) and\r\n ((Kind <> ckImport) or Result.IsFormatCorrect(AFileName)) then\r\n { Caller must call Done }\r\n Exit;\r\n Result.Done;\r\n end;\r\n Result := nil;\r\nend;\r\n\r\nfunction TConversionFormatList.GetFilter(const AKind: TJvConversionKind): string;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := '';\r\n\r\n for I := 0 to Count - 1 do\r\n if Items[I].CanHandle(AKind) then\r\n Result := Result + Items[I].Filter + '|';\r\n\r\n if Result > '' then\r\n System.Delete(Result, Length(Result), 1);\r\nend;\r\n\r\nfunction TConversionFormatList.GetItem(Index: Integer): TJvConversion;\r\nbegin\r\n Result := inherited Items[Index] as TJvConversion;\r\nend;\r\n\r\n//=== { TImageDataObject } ===================================================\r\n\r\nconstructor TImageDataObject.Create(AGraphic: TGraphic);\r\nbegin\r\n inherited Create;\r\n FGraphic := AGraphic;\r\nend;\r\n\r\nfunction TImageDataObject.DAdvise(const FormatEtc: TFormatEtc;\r\n advf: Integer; const advSink: IAdviseSink;\r\n out dwConnection: Integer): HRESULT;\r\nbegin\r\n Result := OLE_E_ADVISENOTSUPPORTED;\r\nend;\r\n\r\nfunction TImageDataObject.DUnadvise(dwConnection: Integer): HRESULT;\r\nbegin\r\n Result := OLE_E_ADVISENOTSUPPORTED;\r\nend;\r\n\r\nfunction TImageDataObject.EnumDAdvise(\r\n out enumAdvise: IEnumStatData): HRESULT;\r\nbegin\r\n Result := OLE_E_ADVISENOTSUPPORTED;\r\nend;\r\n\r\nfunction TImageDataObject.EnumFormatEtc(dwDirection: Integer;\r\n out EnumFormatEtc: IEnumFormatEtc): HRESULT;\r\nbegin\r\n EnumFormatEtc := nil;\r\n Result := E_NOTIMPL;\r\nend;\r\n\r\nfunction TImageDataObject.GetCanonicalFormatEtc(const FormatEtc: TFormatEtc;\r\n out FormatEtcOut: TFormatEtc): HRESULT;\r\nbegin\r\n FormatEtcOut.ptd := nil;\r\n Result := E_NOTIMPL;\r\nend;\r\n\r\nfunction TImageDataObject.GetData(const FormatEtcIn: TFormatEtc;\r\n out Medium: TStgMedium): HRESULT;\r\nvar\r\n SizeMetric: TPoint;\r\n Buffer: Pointer;\r\n Length: UINT;\r\n DC: HDC;\r\n hMF: HMETAFILE;\r\n hMem: THandle;\r\n pMFP: PMetafilePict;\r\nbegin\r\n // Handle only MetaFile\r\n if (FormatEtcIn.tymed and TYMED_MFPICT) = 0 then\r\n begin\r\n Result := DV_E_FORMATETC;\r\n Exit;\r\n end;\r\n if FGraphic is TMetafile then //Get a Win3x-style HMETAFILE handle\r\n with TMetafile(FGraphic) do //from a HENHMETAFILE one.\r\n begin\r\n SizeMetric.X := MMWidth;\r\n SizeMetric.Y := MMHeight;\r\n Buffer := nil;\r\n Length := 0;\r\n DC := GetDC(0);\r\n try\r\n Length := GetWinMetaFileBits(Handle, 0, nil, MM_ANISOTROPIC, DC);\r\n GetMem(Buffer, Length);\r\n if GetWinMetaFileBits(Handle, Length, Buffer,\r\n MM_ANISOTROPIC, DC) = Length then\r\n hMF := SetMetaFileBitsEx(Length, Buffer)\r\n else\r\n hMF := 0;\r\n finally\r\n if Buffer <> nil then\r\n FreeMem(Buffer, Length);\r\n ReleaseDC(0, DC);\r\n end;\r\n end\r\n else\r\n begin\r\n // convert pixels to mm\r\n SizeMetric.X := MulDiv(FGraphic.Width,\r\n cHundredthMMPerInch, Screen.PixelsPerInch);\r\n SizeMetric.Y := MulDiv(FGraphic.Height,\r\n cHundredthMMPerInch, Screen.PixelsPerInch);\r\n // Create Metafile DC and set it up\r\n DC := CreateMetafile(nil);\r\n SetWindowOrgEx(DC, 0, 0, nil);\r\n SetWindowExtEx(DC, SizeMetric.X, SizeMetric.Y, nil);\r\n\r\n if FGraphic.ClassType = TIcon then\r\n DrawIconEx(DC, 0, 0, TIcon(FGraphic).Handle, SizeMetric.X, SizeMetric.Y,\r\n 0, 0, DI_NORMAL)\r\n else\r\n with TCanvas.Create do\r\n try\r\n Handle := DC;\r\n StretchDraw(Rect(0, 0, SizeMetric.X, SizeMetric.Y), FGraphic);\r\n finally\r\n Free;\r\n end;\r\n hMF := CloseMetaFile(DC);\r\n end;\r\n if hMF = 0 then\r\n begin\r\n Result := E_UNEXPECTED;\r\n Exit;\r\n end;\r\n\r\n // Get memory handle\r\n hMem := GlobalAlloc(GMEM_SHARE or GMEM_MOVEABLE, SizeOf(METAFILEPICT));\r\n if hMem = 0 then\r\n begin\r\n DeleteMetaFile(hMF);\r\n Result := STG_E_MEDIUMFULL;\r\n Exit;\r\n end;\r\n pMFP := PMetafilePict(GlobalLock(hMem));\r\n pMFP^.hMF := hMF;\r\n pMFP^.mm := MM_ANISOTROPIC;\r\n pMFP^.xExt := SizeMetric.X;\r\n pMFP^.yExt := SizeMetric.Y;\r\n GlobalUnlock(hMem);\r\n\r\n Medium.tymed := TYMED_MFPICT;\r\n Medium.hGlobal := hMem;\r\n Medium.unkForRelease := nil;\r\n\r\n Result := S_OK;\r\nend;\r\n\r\nfunction TImageDataObject.GetDataHere(const FormatEtc: TFormatEtc;\r\n out Medium: TStgMedium): HRESULT;\r\nbegin\r\n Result := E_NOTIMPL;\r\nend;\r\n\r\nfunction TImageDataObject.QueryGetData(const FormatEtc: TFormatEtc): HRESULT;\r\nbegin\r\n Result := E_NOTIMPL;\r\nend;\r\n\r\nfunction TImageDataObject.SetData(const FormatEtc: TFormatEtc;\r\n var Medium: TStgMedium; fRelease: BOOL): HRESULT;\r\nbegin\r\n Result := E_NOTIMPL;\r\nend;\r\n\r\n//=== { TJvConversion } ======================================================\r\n\r\nfunction TJvConversion.CanHandle(const AKind: TJvConversionKind): Boolean;\r\nbegin\r\n Result := True;\r\nend;\r\n\r\nfunction TJvConversion.CanHandle(const AExtension: string;\r\n const AKind: TJvConversionKind): Boolean;\r\nbegin\r\n Result := True;\r\nend;\r\n\r\nfunction TJvConversion.ConvertRead(Buffer: {$IFDEF COMPILER12_UP}PByte{$ELSE}PAnsiChar{$ENDIF COMPILER12_UP};\r\n BufSize: Integer): Integer;\r\nbegin\r\n Result := -1;\r\nend;\r\n\r\nfunction TJvConversion.ConvertWrite(Buffer: {$IFDEF COMPILER12_UP}PByte{$ELSE}PAnsiChar{$ENDIF COMPILER12_UP};\r\n BufSize: Integer): Integer;\r\nbegin\r\n Result := -1;\r\nend;\r\n\r\nprocedure TJvConversion.Done;\r\nbegin\r\n FParentWindow := 0;\r\nend;\r\n\r\nprocedure TJvConversion.DoProgress(APercentDone: Integer);\r\nbegin\r\n if APercentDone < 0 then\r\n APercentDone := 0\r\n else\r\n if APercentDone > 100 then\r\n APercentDone := 100;\r\n if APercentDone <> FPercentDone then\r\n begin\r\n FPercentDone := APercentDone;\r\n if Assigned(FOnProgress) then\r\n FOnProgress(Self);\r\n end;\r\nend;\r\n\r\nfunction TJvConversion.Error: Boolean;\r\nbegin\r\n Result := False;\r\nend;\r\n\r\nfunction TJvConversion.ErrorStr: string;\r\nbegin\r\n Result := '';\r\nend;\r\n\r\nfunction TJvConversion.Filter: string;\r\nbegin\r\n Result := '';\r\nend;\r\n\r\nprocedure TJvConversion.Init(AParentWindow: THandle);\r\nbegin\r\n FParentWindow := AParentWindow;\r\nend;\r\n\r\nfunction TJvConversion.IsFormatCorrect(const AFileName: string): Boolean;\r\nbegin\r\n Result := True;\r\nend;\r\n\r\nfunction TJvConversion.IsFormatCorrect(AStream: TStream): Boolean;\r\nbegin\r\n Result := True;\r\nend;\r\n\r\nfunction TJvConversion.Open(const AFileName: string;\r\n const AKind: TJvConversionKind): Boolean;\r\nbegin\r\n Result := False;\r\nend;\r\n\r\nfunction TJvConversion.Open(Stream: TStream;\r\n const AKind: TJvConversionKind): Boolean;\r\nbegin\r\n Result := False;\r\nend;\r\n\r\nfunction TJvConversion.Retry: Boolean;\r\nbegin\r\n Result := False;\r\nend;\r\n\r\nfunction TJvConversion.TextKind: TJvConversionTextKind;\r\nbegin\r\n Result := ctkRTF;\r\nend;\r\n\r\nfunction TJvConversion.UserCancel: Boolean;\r\nbegin\r\n Result := False;\r\nend;\r\n\r\n//=== { TJvCustomRichEdit } ==================================================\r\n\r\nconstructor TJvCustomRichEdit.Create(AOwner: TComponent);\r\nvar\r\n DC: HDC;\r\nbegin\r\n inherited Create(AOwner);\r\n { If you create a TJvRichEdit control at design-time the Text of the control\r\n will NOT be set to its Name because csSetCaption is excluded }\r\n // ControlStyle := ControlStyle + [csAcceptsControls] - [csSetCaption];\r\n ControlStyle := ControlStyle - [csSetCaption];\r\n IncludeThemeStyle(Self, [csNeedsBorderPaint]);\r\n FSelAttributes := TJvTextAttributes.Create(Self, atSelected);\r\n FDefAttributes := TJvTextAttributes.Create(Self, atDefaultText);\r\n FWordAttributes := TJvTextAttributes.Create(Self, atWord);\r\n FParagraph := TJvParaAttributes.Create(Self);\r\n FLines := TJvRichEditStrings.Create;\r\n TJvRichEditStrings(FLines).FRichEdit := Self;\r\n TabStop := True;\r\n Width := 185;\r\n Height := 89;\r\n AutoSize := False;\r\n DoubleBuffered := False;\r\n {$IFDEF COMPILER12_UP}\r\n ParentDoubleBuffered := False;\r\n {$ENDIF COMPILER12_UP}\r\n FAllowObjects := True;\r\n FAllowInPlace := True;\r\n FAutoVerbMenu := True;\r\n FHideSelection := True;\r\n FHideScrollBars := True;\r\n ScrollBars := ssBoth;\r\n FSelectionBar := True;\r\n FAutoAdvancedTypography := True;\r\n FOLEDragDrop := True;\r\n FLangOptions := [rlAutoFont];\r\n DC := GetDC(HWND_DESKTOP);\r\n FScreenLogPixels := GetDeviceCaps(DC, LOGPIXELSY);\r\n ReleaseDC(HWND_DESKTOP, DC);\r\n DefaultConverter := nil;\r\n FOldParaAlignment := TParaAlignment(Alignment);\r\n FUndoLimit := 100;\r\n FAutoURLDetect := True;\r\n FWordSelection := True;\r\n with FClickRange do\r\n begin\r\n cpMin := -1;\r\n cpMax := -1;\r\n end;\r\n FForceUndo := True;\r\n FCallback := TRichEditOleCallback.Create(Self);\r\n FUseFixedPopup := True;\r\n Perform(CM_PARENTBIDIMODECHANGED, 0, 0);\r\nend;\r\n\r\ndestructor TJvCustomRichEdit.Destroy;\r\nbegin\r\n FLastFind := nil;\r\n FSelAttributes.Free;\r\n FDefAttributes.Free;\r\n FWordAttributes.Free;\r\n FParagraph.Free;\r\n FLines.Free;\r\n FState.Free;\r\n FPopupVerbMenu.Free;\r\n FFindDialog.Free;\r\n FReplaceDialog.Free;\r\n inherited Destroy;\r\n { be sure that callback object is destroyed after inherited Destroy }\r\n TRichEditOleCallback(FCallback).Free;\r\nend;\r\n\r\nprocedure TJvCustomRichEdit.AddFormatText(const S: string; const AFont: TFont);\r\nbegin\r\n InsertFormatText(GetTextLen, S, AFont);\r\nend;\r\n\r\nprocedure TJvCustomRichEdit.AddFormatText(const S: string;\r\n FontStyle: TFontStyles; const FontName: string; const FontColor: TColor;\r\n FontHeight: Integer);\r\nbegin\r\n InsertFormatText(GetTextLen, S, FontStyle, FontName, FontColor, FontHeight);\r\nend;\r\n\r\nprocedure TJvCustomRichEdit.AdjustFindDialogPosition(Dialog: TFindDialog);\r\nvar\r\n TextRect, R: TRect;\r\nbegin\r\n if Dialog.Handle = 0 then\r\n Exit;\r\n TextRect.TopLeft := ClientToScreen(GetCharPos(SelStart));\r\n TextRect.BottomRight := ClientToScreen(GetCharPos(SelStart + SelLength));\r\n Inc(TextRect.Bottom, 20);\r\n with Dialog do\r\n begin\r\n GetWindowRect(Handle, R);\r\n if PtInRect(R, TextRect.TopLeft) or PtInRect(R, TextRect.BottomRight) then\r\n begin\r\n if TextRect.Top > R.Bottom - R.Top + 20 then\r\n OffsetRect(R, 0, TextRect.Top - R.Bottom - 20)\r\n else\r\n begin\r\n if TextRect.Top + R.Bottom - R.Top < GetSystemMetrics(SM_CYSCREEN) then\r\n OffsetRect(R, 0, 40 + TextRect.Top - R.Top);\r\n end;\r\n Position := R.TopLeft;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomRichEdit.Clear;\r\nbegin\r\n CloseObjects;\r\n inherited Clear;\r\n Modified := False;\r\nend;\r\n\r\nprocedure TJvCustomRichEdit.ClearUndo;\r\nbegin\r\n SendMessage(Handle, EM_EMPTYUNDOBUFFER, 0, 0);\r\nend;\r\n\r\nprocedure TJvCustomRichEdit.CloseActiveObject;\r\nbegin\r\n if FRichEditOle <> nil then\r\n IRichEditOle(FRichEditOle).InPlaceDeactivate;\r\nend;\r\n\r\nprocedure TJvCustomRichEdit.CloseFindDialog(Dialog: TFindDialog);\r\nbegin\r\n if Assigned(FOnCloseFindDialog) then\r\n FOnCloseFindDialog(Self, Dialog);\r\nend;\r\n\r\nprocedure TJvCustomRichEdit.CloseObjects;\r\nvar\r\n I: Integer;\r\n ReObject: TReObject;\r\nbegin\r\n if Assigned(FRichEditOle) then\r\n begin\r\n FillChar(ReObject, SizeOf(ReObject), 0);\r\n ReObject.cbStruct := SizeOf(ReObject);\r\n with IRichEditOle(FRichEditOle) do\r\n begin\r\n for I := GetObjectCount - 1 downto 0 do\r\n if Succeeded(GetObject(I, ReObject, REO_GETOBJ_POLEOBJ)) then\r\n begin\r\n if ReObject.dwFlags and REO_INPLACEACTIVE <> 0 then\r\n IRichEditOle(FRichEditOle).InPlaceDeactivate;\r\n ReObject.poleobj.Close(OLECLOSE_NOSAVE);\r\n ReleaseObject(ReObject.poleobj);\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomRichEdit.CMBiDiModeChanged(var Msg: TMessage);\r\nvar\r\n AParagraph: TParaFormat2;\r\n BiDiOptions: TBiDiOptions;\r\nbegin\r\n HandleNeeded; { we REALLY need the handle for BiDi }\r\n inherited;\r\n\r\n BiDiOptions.cbSize := sizeof(BiDiOptions);\r\n BiDiOptions.wMask := BOM_NEUTRALOVERRIDE or BOM_CONTEXTREADING or BOM_CONTEXTALIGNMENT;\r\n BiDiOptions.wEffects := BOE_NEUTRALOVERRIDE or BOE_CONTEXTREADING or BOE_CONTEXTALIGNMENT;\r\n SendMessage(Handle, EM_SETBIDIOPTIONS, 0, LPARAM(@BiDiOptions));\r\n\r\n Paragraph.GetAttributes(AParagraph);\r\n AParagraph.dwMask := PFM_ALIGNMENT;\r\n AParagraph.wAlignment := Ord(Alignment) + 1;\r\n Paragraph.SetAttributes(AParagraph);\r\nend;\r\n\r\n// From JvRichEdit.pas by Sbastien Buysse\r\n\r\nprocedure TJvCustomRichEdit.CMDocWindowActivate(var Msg: TMessage);\r\nbegin\r\n if Assigned(FCallback) then\r\n with TRichEditOleCallback(FCallback) do\r\n if Assigned(FDocForm) and IsFormMDIChild(FDocForm.Form) then\r\n begin\r\n if Msg.WParam = 0 then\r\n begin\r\n FFrameForm.SetMenu(0, 0, 0);\r\n FFrameForm.ClearBorderSpace;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomRichEdit.CMUIDeactivate(var Msg: TMessage);\r\nbegin\r\n if (GetParentForm(Self) <> nil) and Assigned(FRichEditOle) and\r\n (GetParentForm(Self).ActiveOleControl = Self) then\r\n {IRichEditOle(FRichEditOle).InPlaceDeactivate};\r\nend;\r\n\r\nprocedure TJvCustomRichEdit.CNNotify(var Msg: TWMNotify);\r\nvar\r\n AMsg: TMessage;\r\nbegin\r\n with Msg do\r\n case NMHdr^.code of\r\n EN_SELCHANGE:\r\n SelectionChange;\r\n EN_REQUESTRESIZE:\r\n RequestSize(PReqSize(NMHdr)^.rc);\r\n EN_SAVECLIPBOARD:\r\n with PENSaveClipboard(NMHdr)^ do\r\n if not SaveClipboard(cObjectCount, cch) then\r\n Result := 1;\r\n EN_PROTECTED:\r\n with PENProtected(NMHdr)^ do\r\n begin\r\n AMsg.Msg := Msg;\r\n AMsg.WParam := WParam;\r\n AMsg.LParam := LParam;\r\n AMsg.Result := 0;\r\n if not ProtectChange(AMsg, chrg.cpMin, chrg.cpMax) then\r\n Result := 1;\r\n end;\r\n EN_LINK:\r\n with PENLink(NMHdr)^ do\r\n begin\r\n case Msg of\r\n WM_MOUSEMOVE:\r\n begin\r\n URLHover(GetTextRange(chrg.cpMin, chrg.cpMax));\r\n end;\r\n WM_RBUTTONDOWN:\r\n begin\r\n FClickRange := chrg;\r\n FClickBtn := mbRight;\r\n end;\r\n WM_RBUTTONUP:\r\n begin\r\n if (FClickBtn = mbRight) and (FClickRange.cpMin = chrg.cpMin) and\r\n (FClickRange.cpMax = chrg.cpMax) then\r\n URLClick(GetTextRange(chrg.cpMin, chrg.cpMax), mbRight);\r\n with FClickRange do\r\n begin\r\n cpMin := -1;\r\n cpMax := -1;\r\n end;\r\n end;\r\n WM_LBUTTONDOWN:\r\n begin\r\n FClickRange := chrg;\r\n FClickBtn := mbLeft;\r\n end;\r\n WM_LBUTTONUP:\r\n begin\r\n if (FClickBtn = mbLeft) and (FClickRange.cpMin = chrg.cpMin) and\r\n (FClickRange.cpMax = chrg.cpMax) then\r\n URLClick(GetTextRange(chrg.cpMin, chrg.cpMax), mbLeft);\r\n with FClickRange do\r\n begin\r\n cpMin := -1;\r\n cpMax := -1;\r\n end;\r\n end;\r\n end;\r\n end;\r\n EN_STOPNOUNDO:\r\n begin\r\n { cannot allocate enough memory to maintain the undo state }\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomRichEdit.ColorChanged;\r\nbegin\r\n inherited ColorChanged;\r\n SendMessage(Handle, EM_SETBKGNDCOLOR, 0, ColorToRGB(Color))\r\nend;\r\n\r\nprocedure TJvCustomRichEdit.CreateParams(var Params: TCreateParams);\r\nconst\r\n HideScrollBars: array[Boolean] of DWORD = (ES_DISABLENOSCROLL, 0);\r\n HideSelections: array[Boolean] of DWORD = (ES_NOHIDESEL, 0);\r\n WordWraps: array[Boolean] of DWORD = (0, ES_AUTOHSCROLL);\r\n SelectionBars: array[Boolean] of DWORD = (0, ES_SELECTIONBAR);\r\n OLEDragDrops: array[Boolean] of DWORD = (ES_NOOLEDRAGDROP, 0);\r\nbegin\r\n inherited CreateParams(Params);\r\n case RichEditVersion of\r\n 1:\r\n CreateSubClass(Params, RICHEDIT_CLASS10A);\r\n else\r\n CreateSubClass(Params, RICHEDIT_CLASS);\r\n end;\r\n with Params do\r\n begin\r\n Style := (Style and not (WS_HSCROLL or WS_VSCROLL)) or ES_SAVESEL or\r\n (WS_CLIPSIBLINGS or WS_CLIPCHILDREN);\r\n { NOTE: WS_CLIPCHILDREN and WS_CLIPSIBLINGS are essential otherwise }\r\n { once the object is inserted you see some painting problems. }\r\n Style := Style and not (WS_HSCROLL or WS_VSCROLL);\r\n if ScrollBars in [ssVertical, ssBoth] then\r\n Style := Style or WS_VSCROLL;\r\n if (ScrollBars in [ssHorizontal, ssBoth]) and not WordWrap then\r\n Style := Style or WS_HSCROLL;\r\n Style := Style or OLEDragDrops[FOLEDragDrop] or HideScrollBars[FHideScrollBars] or\r\n SelectionBars[FSelectionBar] or HideSelections[FHideSelection] and\r\n not WordWraps[WordWrap];\r\n WindowClass.Style := WindowClass.Style and not (CS_HREDRAW or CS_VREDRAW);\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomRichEdit.CreateWindowHandle(const Params: TCreateParams);\r\nvar\r\n Bounds: TRect;\r\nbegin\r\n Bounds := BoundsRect;\r\n inherited CreateWindowHandle(Params);\r\n if HandleAllocated then\r\n BoundsRect := Bounds;\r\nend;\r\n\r\nprocedure TJvCustomRichEdit.CreateWnd;\r\nvar\r\n SavedAdvancedTypography: Boolean;\r\n SavedModified: Boolean;\r\n Mask: Longint;\r\nbegin\r\n SavedAdvancedTypography := AdvancedTypography;\r\n inherited CreateWnd;\r\n if (SysLocale.FarEast) and not (SysLocale.PriLangID = LANG_JAPANESE) then\r\n Font.Charset := GetDefFontCharSet;\r\n Mask := ENM_CHANGE or ENM_SELCHANGE or ENM_REQUESTRESIZE or ENM_PROTECTED;\r\n if RichEditVersion >= 2 then\r\n Mask := Mask or ENM_LINK;\r\n SendMessage(Handle, EM_SETEVENTMASK, 0, Mask);\r\n SendMessage(Handle, EM_SETBKGNDCOLOR, 0, ColorToRGB(Color));\r\n DoSetMaxLength(MaxLength);\r\n SetWordSelection(FWordSelection);\r\n if RichEditVersion >= 2 then\r\n begin\r\n SendMessage(Handle, EM_AUTOURLDETECT, WPARAM(FAutoURLDetect), 0);\r\n FUndoLimit := SendMessage(Handle, EM_SETUNDOLIMIT, FUndoLimit, 0);\r\n UpdateTextModes(PlainText);\r\n // GetAdvancedTypography returns now always false, because the handle\r\n // is recreated, so can't use property AdvancedTypography\r\n FAdvancedTypography := SavedAdvancedTypography;\r\n UpdateTypographyOptions(FAdvancedTypography);\r\n SetLangOptions(FLangOptions);\r\n end;\r\n if FAllowObjects then\r\n begin\r\n SendMessage(Handle, EM_SETOLECALLBACK, 0,\r\n LParam(TRichEditOleCallback(FCallback) as IRichEditOleCallback));\r\n GetRichEditOle(Handle, FRichEditOle);\r\n UpdateHostNames;\r\n end;\r\n\r\n if FState is TJvRichEditState then\r\n TJvRichEditState(FState).Restore(Self);\r\n FState.Free;\r\n FState := nil;\r\n if RichEditVersion < 2 then\r\n begin\r\n { (rb) This code is probably unnecessary; it only assigns Font to\r\n FDefAttributes, see WM_SETFONT handler; but that is also done in\r\n TWinControl.CreateWnd }\r\n SavedModified := Modified;\r\n { This changes the Modified property }\r\n SendMessage(Handle, WM_SETFONT, 0, 0);\r\n Modified := SavedModified;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomRichEdit.DestroyWnd;\r\nbegin\r\n {$IFDEF DELPHI10_UP}\r\n if csRecreating in ControlState then\r\n begin\r\n {$ENDIF DELPHI10_UP}\r\n FState := TJvRichEditState.Create;\r\n TJvRichEditState(FState).ForcePlainText := csDesigning in ComponentState;\r\n TJvRichEditState(FState).Store(Self);\r\n {$IFDEF DELPHI10_UP}\r\n end;\r\n {$ENDIF DELPHI10_UP}\r\n inherited DestroyWnd;\r\nend;\r\n\r\nprocedure TJvCustomRichEdit.DoConversionProgress(const AProgress: Integer);\r\nbegin\r\n if Assigned(FOnConversionProgress) then\r\n FOnConversionProgress(Self, AProgress);\r\nend;\r\n\r\nprocedure TJvCustomRichEdit.DoSetMaxLength(Value: Integer);\r\nbegin\r\n { The rich edit control's default maximum amount of text is 32K }\r\n { Let's set it at 16M by default }\r\n if Value = 0 then\r\n Value := $FFFFFF;\r\n SendMessage(Handle, EM_EXLIMITTEXT, 0, Value);\r\nend;\r\n\r\nfunction TJvCustomRichEdit.DoQueryAcceptData(const ADataObject: IDataObject;\r\n var AFormat: TClipFormat; ClipboardOperationKind: Cardinal; Really: Boolean;\r\n IconMetaPict: HGLOBAL): Boolean;\r\nbegin\r\n Result := False;\r\n // ClipboardOperationKind is either RECO_DROP or RECO_PASTE\r\n case ClipboardOperationKind of\r\n RECO_PASTE: if not (caPaste in ClipboardCommands) then Result := True;\r\n RECO_DROP: ;\r\n end;\r\n\r\n if Assigned(FOnQueryAcceptData) then\r\n FOnQueryAcceptData(Self, ADataObject, AFormat, ClipboardOperationKind, Really, IconMetaPict, Result);\r\nend;\r\n\r\nfunction TJvCustomRichEdit.DoDragAllowed(const ShiftState: TShiftState;\r\n var AllowedEffects: TRichDropEffects): Boolean;\r\nbegin\r\n Result := False;\r\n // if ReadOnly then\r\n // begin\r\n // Result := True;\r\n // AllowedEffects := [];\r\n // end\r\n // else\r\n if Assigned(FOnDragAllowed) then\r\n FOnDragAllowed(Self, ShiftState, AllowedEffects, Result);\r\nend;\r\n\r\nfunction TJvCustomRichEdit.DoGetDragDropEffect(\r\n const ShiftState: TShiftState; var Effects: TRichDropEffects): Boolean;\r\nbegin\r\n Result := False;\r\n if Assigned(FOnGetDragDropEffect) then\r\n FOnGetDragDropEffect(Self, ShiftState, Effects, Result);\r\nend;\r\n\r\nprocedure TJvCustomRichEdit.EMReplaceSel(var Msg: TMessage);\r\nvar\r\n CharRange: TCharRange;\r\nbegin\r\n Perform(EM_EXGETSEL, 0, LPARAM(@CharRange));\r\n with CharRange do\r\n cpMax := cpMin + Integer(StrLen(PChar(Msg.LParam)));\r\n if (FUndoLimit > 1) and (RichEditVersion >= 2) and (not FLinesUpdating or ForceUndo) then\r\n Msg.WParam := 1; { allow Undo }\r\n inherited;\r\n if FLinesUpdating then\r\n CharRange.cpMin := CharRange.cpMax;\r\n Perform(EM_EXSETSEL, 0, LPARAM(@CharRange));\r\n Perform(Messages.EM_SCROLLCARET, 0, 0);\r\nend;\r\n\r\nclass function TJvCustomRichEdit.Filter(\r\n const AKind: TJvConversionKind): string;\r\nbegin\r\n Result := GConversionFormatList.GetFilter(AKind);\r\nend;\r\n\r\nfunction TJvCustomRichEdit.FindDialog(const SearchStr: string): TFindDialog;\r\nbegin\r\n if FFindDialog = nil then\r\n begin\r\n FFindDialog := TFindDialog.Create(Self);\r\n if FReplaceDialog <> nil then\r\n FFindDialog.FindText := FReplaceDialog.FindText;\r\n end;\r\n Result := FFindDialog;\r\n SetupFindDialog(FFindDialog, SearchStr, '');\r\n FFindDialog.Execute;\r\nend;\r\n\r\nprocedure TJvCustomRichEdit.FindDialogClose(Sender: TObject);\r\nbegin\r\n CloseFindDialog(Sender as TFindDialog);\r\nend;\r\n\r\nprocedure TJvCustomRichEdit.FindDialogFind(Sender: TObject);\r\nbegin\r\n FindEditText(TFindDialog(Sender), True, True);\r\nend;\r\n\r\nfunction TJvCustomRichEdit.FindEditText(Dialog: TFindDialog; AdjustPos, Events: Boolean): Boolean;\r\nvar\r\n Length, StartPos: Integer;\r\n SrchOptions: TRichSearchTypes;\r\nbegin\r\n with TFindDialog(Dialog) do\r\n begin\r\n SrchOptions := [stSetSelection];\r\n if frDown in Options then\r\n begin\r\n StartPos := Max(SelStart, SelStart + SelLength);\r\n Length := System.Length(Text) - StartPos + 1;\r\n end\r\n else\r\n begin\r\n SrchOptions := SrchOptions + [stBackward];\r\n StartPos := Min(SelStart, SelStart + SelLength);\r\n Length := StartPos + 1;\r\n end;\r\n if frMatchCase in Options then\r\n SrchOptions := SrchOptions + [stMatchCase];\r\n if frWholeWord in Options then\r\n SrchOptions := SrchOptions + [stWholeWord];\r\n Result := Self.FindText(FindText, StartPos, Length, SrchOptions) >= 0;\r\n if FindText <> '' then\r\n FLastFind := Dialog;\r\n if Result then\r\n begin\r\n if AdjustPos then\r\n AdjustFindDialogPosition(Dialog);\r\n end\r\n else\r\n if Events then\r\n TextNotFound(Dialog);\r\n end;\r\nend;\r\n\r\nfunction TJvCustomRichEdit.FindNext: Boolean;\r\nbegin\r\n if CanFindNext then\r\n Result := FindEditText(FLastFind, False, True)\r\n else\r\n Result := False;\r\nend;\r\n\r\nfunction TJvCustomRichEdit.FindText(const SearchStr: string;\r\n StartPos, Length: Integer; Options: TRichSearchTypes): Integer;\r\nvar\r\n Find: TFindTextEx;\r\n Flags: Integer;\r\nbegin\r\n with Find.chrg do\r\n begin\r\n cpMin := StartPos;\r\n cpMax := cpMin + Abs(Length);\r\n end;\r\n if RichEditVersion >= 2 then\r\n begin\r\n if not (stBackward in Options) then\r\n Flags := FT_DOWN\r\n else\r\n Flags := 0;\r\n end\r\n else\r\n begin\r\n Options := Options - [stBackward];\r\n Flags := 0;\r\n end;\r\n if stWholeWord in Options then\r\n Flags := Flags or {$IFDEF RTL200_UP}FR_WHOLEWORD{$ELSE}FT_WHOLEWORD{$ENDIF RTL200_UP};\r\n if stMatchCase in Options then\r\n Flags := Flags or {$IFDEF RTL200_UP}FR_MATCHCASE{$ELSE}FT_MATCHCASE{$ENDIF RTL200_UP};\r\n Find.lpstrText := PChar(SearchStr);\r\n Result := SendMessage(Handle, EM_FINDTEXTEX, Flags, LPARAM(@Find));\r\n if (Result >= 0) and (stSetSelection in Options) then\r\n begin\r\n SendMessage(Handle, EM_EXSETSEL, 0, LPARAM(@Find.chrgText));\r\n SendMessage(Handle, Messages.EM_SCROLLCARET, 0, 0);\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomRichEdit.FontChanged;\r\nbegin\r\n inherited FontChanged;\r\n FDefAttributes.Assign(Font);\r\nend;\r\n\r\nfunction TJvCustomRichEdit.GetAdvancedTypography: Boolean;\r\nbegin\r\n // Advanced and normal line breaking may also be turned on automatically by\r\n // the rich edit control if it is needed for certain languages. So don't\r\n // rely on FAdvancedTypography alone.\r\n if HandleAllocated and not (csDesigning in ComponentState) then\r\n begin\r\n if RichEditVersion >= 3 then\r\n FAdvancedTypography := SendMessage(Handle, EM_GETTYPOGRAPHYOPTIONS, 0, 0) and TO_ADVANCEDTYPOGRAPHY =\r\n TO_ADVANCEDTYPOGRAPHY;\r\n end;\r\n Result := FAdvancedTypography;\r\nend;\r\n\r\nfunction TJvCustomRichEdit.GetAutoURLDetect: Boolean;\r\nbegin\r\n Result := FAutoURLDetect;\r\n if HandleAllocated and not (csDesigning in ComponentState) then\r\n begin\r\n if RichEditVersion >= 2 then\r\n Result := Boolean(SendMessage(Handle, EM_GETAUTOURLDETECT, 0, 0));\r\n end;\r\nend;\r\n\r\nfunction TJvCustomRichEdit.GetCanFindNext: Boolean;\r\nbegin\r\n Result := HandleAllocated and (FLastFind <> nil) and\r\n (FLastFind.FindText <> '');\r\nend;\r\n\r\nfunction TJvCustomRichEdit.GetCanPaste: Boolean;\r\nbegin\r\n Result := False;\r\n if HandleAllocated then\r\n Result := SendMessage(Handle, EM_CANPASTE, 0, 0) <> 0;\r\nend;\r\n\r\nfunction TJvCustomRichEdit.GetCanRedo: Boolean;\r\nbegin\r\n Result := False;\r\n if HandleAllocated and (RichEditVersion >= 2) then\r\n Result := SendMessage(Handle, EM_CANREDO, 0, 0) <> 0;\r\nend;\r\n\r\nfunction TJvCustomRichEdit.GetCaretPos: TPoint;\r\nvar\r\n CharRange: TCharRange;\r\nbegin\r\n SendMessage(Handle, EM_EXGETSEL, 0, LPARAM(@CharRange));\r\n Result.X := CharRange.cpMax;\r\n Result.Y := LineFromChar(Result.X);\r\n Dec(Result.X, GetLineIndex(-1));\r\nend;\r\n\r\nfunction TJvCustomRichEdit.GetCharPos(CharIndex: Integer): TPoint;\r\nvar\r\n Res: Longint;\r\nbegin\r\n Result.X := 0;\r\n Result.Y := 0;\r\n // FillChar(Result, SizeOf(Result), 0);\r\n if HandleAllocated then\r\n begin\r\n if RichEditVersion = 2 then\r\n begin\r\n Res := SendMessage(Handle, EM_POSFROMCHAR, CharIndex, 0);\r\n Result.X := LoWord(Res);\r\n Result.Y := HiWord(Res);\r\n end\r\n else { RichEdit 1.0 and 3.0 }\r\n SendMessage(Handle, EM_POSFROMCHAR, WPARAM(@Result), CharIndex);\r\n end;\r\nend;\r\n\r\nfunction TJvCustomRichEdit.GetConverter(AStream: TStream;\r\n const Kind: TJvConversionKind): TJvConversion;\r\nbegin\r\n Result := DefaultConverter;\r\n if Result = nil then\r\n Result := GConversionFormatList.GetConverter(\r\n GetParentWindow(Self), AStream, Kind)\r\n else\r\n Result.Init(GetParentWindow(Self));\r\nend;\r\n\r\nfunction TJvCustomRichEdit.GetConverter(const AFileName: string;\r\n const Kind: TJvConversionKind): TJvConversion;\r\nbegin\r\n { Note: First AFileName determines the converter, if not found then we pick\r\n the default converter. Same behaviour as TRichEdit }\r\n Result := GConversionFormatList.GetConverter(\r\n GetParentWindow(Self), AFileName, Kind);\r\n if Result = nil then\r\n begin\r\n Result := DefaultConverter;\r\n if Result = nil then\r\n Result := GConversionFormatList.DefaultConverter;\r\n Result.Init(GetParentWindow(Self));\r\n end;\r\nend;\r\n\r\nfunction TJvCustomRichEdit.GetFlat: Boolean;\r\nbegin\r\n Result := not Ctl3D;\r\nend;\r\n\r\nfunction TJvCustomRichEdit.GetLangOptions: TRichLangOptions;\r\nvar\r\n Flags: Longint;\r\n I: TRichLangOption;\r\nbegin\r\n Result := FLangOptions;\r\n if HandleAllocated and not (csDesigning in ComponentState) and\r\n (RichEditVersion >= 2) then\r\n begin\r\n Result := [];\r\n Flags := SendMessage(Handle, EM_GETLANGOPTIONS, 0, 0);\r\n for I := Low(TRichLangOption) to High(TRichLangOption) do\r\n if Flags and RichLangOptions[I] <> 0 then\r\n Include(Result, I);\r\n end;\r\nend;\r\n\r\nfunction TJvCustomRichEdit.GetLineIndex(LineNo: Integer): Integer;\r\nbegin\r\n Result := SendMessage(Handle, EM_LINEINDEX, LineNo, 0);\r\nend;\r\n\r\nfunction TJvCustomRichEdit.GetLineLength(CharIndex: Integer): Integer;\r\nbegin\r\n Result := SendMessage(Handle, EM_LINELENGTH, CharIndex, 0);\r\nend;\r\n\r\nfunction TJvCustomRichEdit.GetParentFlat: Boolean;\r\nbegin\r\n Result := ParentCtl3D;\r\nend;\r\n\r\nfunction TJvCustomRichEdit.GetPopupMenu: TPopupMenu;\r\nvar\r\n EnumOleVerb: IEnumOleVerb;\r\n OleVerb: TOleVerb;\r\n Item: TMenuItem;\r\n ReObject: TReObject;\r\nbegin\r\n FPopupVerbMenu.Free;\r\n FPopupVerbMenu := nil;\r\n Result := inherited GetPopupMenu;\r\n if FAutoVerbMenu and (SelectionType = [stObject]) and\r\n Assigned(FRichEditOle) then\r\n begin\r\n FillChar(ReObject, SizeOf(ReObject), 0);\r\n ReObject.cbStruct := SizeOf(ReObject);\r\n if Succeeded(IRichEditOle(FRichEditOle).GetObject(\r\n Longint(REO_IOB_SELECTION), ReObject, REO_GETOBJ_POLEOBJ)) then\r\n try\r\n if Assigned(ReObject.poleobj) and\r\n (ReObject.dwFlags and REO_INPLACEACTIVE = 0) then\r\n begin\r\n FPopupVerbMenu := TPopupMenu.Create(Self);\r\n if ReObject.poleobj.EnumVerbs(EnumOleVerb) = 0 then\r\n try\r\n while (EnumOleVerb.Next(1, OleVerb, nil) = 0) and\r\n (OleVerb.lVerb >= 0) and\r\n (OleVerb.grfAttribs and OLEVERBATTRIB_ONCONTAINERMENU <> 0) do\r\n begin\r\n Item := TMenuItem.Create(FPopupVerbMenu);\r\n Item.Caption := WideCharToString(OleVerb.lpszVerbName);\r\n Item.Tag := OleVerb.lVerb;\r\n Item.Default := (OleVerb.lVerb = OLEIVERB_PRIMARY);\r\n Item.OnClick := PopupVerbClick;\r\n FPopupVerbMenu.Items.Add(Item);\r\n end;\r\n finally\r\n ReleaseObject(EnumOleVerb);\r\n end;\r\n if (Result <> nil) and (Result.Items.Count > 0) then\r\n begin\r\n Item := TMenuItem.Create(FPopupVerbMenu);\r\n Item.Caption := '-';\r\n Result.Items.Add(Item);\r\n Item := TMenuItem.Create(FPopupVerbMenu);\r\n Item.Caption := Format(SPropDlgCaption, [GetFullNameStr(ReObject.poleobj)]);\r\n Item.OnClick := ObjectPropsClick;\r\n Result.Items.Add(Item);\r\n if FPopupVerbMenu.Items.Count > 0 then\r\n begin\r\n FPopupVerbMenu.Items.Caption := GetFullNameStr(ReObject.poleobj);\r\n Result.Items.Add(FPopupVerbMenu.Items);\r\n end;\r\n end\r\n else\r\n if FPopupVerbMenu.Items.Count > 0 then\r\n begin\r\n Item := TMenuItem.Create(FPopupVerbMenu);\r\n Item.Caption := Format(SPropDlgCaption, [GetFullNameStr(ReObject.poleobj)]);\r\n Item.OnClick := ObjectPropsClick;\r\n FPopupVerbMenu.Items.Insert(0, Item);\r\n Result := FPopupVerbMenu;\r\n end;\r\n end;\r\n finally\r\n ReleaseObject(ReObject.poleobj);\r\n end;\r\n end\r\n else\r\n if (Result = nil) and UseFixedPopup then\r\n Result := FixedDefaultEditPopUp(Self);\r\nend;\r\n\r\n{$IFDEF RTL220_UP}\r\nprocedure TJvCustomRichEdit.DoContextPopup(MousePos: TPoint; var Handled: Boolean);\r\nbegin\r\n if not Assigned(PopupMenu) then\r\n begin\r\n MousePos := ClientToScreen(MousePos);\r\n FixedDefaultEditPopUp(Self).Popup(MousePos.X, MousePos.Y);\r\n Handled := True;\r\n end;\r\nend;\r\n{$ENDIF RTL220_UP}\r\n\r\nfunction TJvCustomRichEdit.GetRedoName: TUndoName;\r\nbegin\r\n Result := unUnknown;\r\n if (RichEditVersion >= 2) and HandleAllocated then\r\n Result := TUndoName(SendMessage(Handle, EM_GETREDONAME, 0, 0));\r\nend;\r\n\r\nfunction TJvCustomRichEdit.GetSelection: TCharRange;\r\nbegin\r\n SendMessage(Handle, EM_EXGETSEL, 0, LPARAM(@Result));\r\nend;\r\n\r\nfunction TJvCustomRichEdit.GetSelectionType: TRichSelectionType;\r\nconst\r\n SelTypes: array[TRichSelection] of Integer =\r\n (SEL_TEXT, SEL_OBJECT, SEL_MULTICHAR, SEL_MULTIOBJECT);\r\nvar\r\n Selection: Integer;\r\n I: TRichSelection;\r\nbegin\r\n Result := [];\r\n if HandleAllocated then\r\n begin\r\n Selection := SendMessage(Handle, EM_SELECTIONTYPE, 0, 0);\r\n for I := Low(TRichSelection) to High(TRichSelection) do\r\n if SelTypes[I] and Selection <> 0 then\r\n Include(Result, I);\r\n end;\r\nend;\r\n\r\nfunction TJvCustomRichEdit.GetSelLength: Integer;\r\nbegin\r\n with GetSelection do\r\n Result := cpMax - cpMin;\r\nend;\r\n\r\nfunction TJvCustomRichEdit.GetSelStart: Integer;\r\nbegin\r\n Result := GetSelection.cpMin;\r\nend;\r\n\r\nfunction TJvCustomRichEdit.GetSelText: string;\r\nbegin\r\n with GetSelection do\r\n Result := GetTextRange(cpMin, cpMax);\r\nend;\r\n\r\nfunction TJvCustomRichEdit.GetSelTextBuf(Buffer: PChar; BufSize: Integer): Integer;\r\nvar\r\n S: string;\r\nbegin\r\n S := SelText;\r\n Result := Length(S);\r\n if BufSize < Length(S) then\r\n Result := BufSize;\r\n StrPLCopy(Buffer, S, Result);\r\nend;\r\n\r\nfunction TJvCustomRichEdit.GetStreamFormat: TRichStreamFormat;\r\nbegin\r\n Result := TJvRichEditStrings(Lines).Format;\r\nend;\r\n\r\nfunction TJvCustomRichEdit.GetStreamMode: TRichStreamModes;\r\nbegin\r\n Result := TJvRichEditStrings(Lines).Mode;\r\nend;\r\n\r\nfunction TJvCustomRichEdit.GetTextLenEx: Integer;\r\nvar\r\n TextLenEx: TGetTextLengthEx;\r\nbegin\r\n if RichEditVersion >= 2 then\r\n begin\r\n with TextLenEx do\r\n begin\r\n Flags := GTL_DEFAULT;\r\n codepage := CP_ACP;\r\n end;\r\n Result := Perform(EM_GETTEXTLENGTHEX, WPARAM(@TextLenEx), 0);\r\n end\r\n else\r\n Result := GetTextLen;\r\nend;\r\n\r\nfunction TJvCustomRichEdit.GetTextRange(StartPos, EndPos: Longint): string;\r\nvar\r\n TextRange: TTextRange;\r\nbegin\r\n SetLength(Result, EndPos - StartPos + 1);\r\n TextRange.chrg.cpMin := StartPos;\r\n TextRange.chrg.cpMax := EndPos;\r\n TextRange.lpstrText := PChar(Result);\r\n SetLength(Result, SendMessage(Handle, EM_GETTEXTRANGE, 0, LPARAM(@TextRange)));\r\nend;\r\n\r\nfunction TJvCustomRichEdit.GetUndoName: TUndoName;\r\nbegin\r\n Result := unUnknown;\r\n if (RichEditVersion >= 2) and HandleAllocated then\r\n Result := TUndoName(SendMessage(Handle, EM_GETUNDONAME, 0, 0));\r\nend;\r\n\r\nfunction TJvCustomRichEdit.GetWordSelection: Boolean;\r\nbegin\r\n Result := FWordSelection;\r\n if HandleAllocated then\r\n Result := (SendMessage(Handle, EM_GETOPTIONS, 0, 0) and\r\n ECO_AUTOWORDSELECTION) <> 0;\r\nend;\r\n\r\nfunction TJvCustomRichEdit.GetZoom: Integer; // Added by J.G. Boerema\r\nvar\r\n WP, LP: Integer;\r\nbegin\r\n Result := 100;\r\n if (RichEditVersion >= 3) and HandleAllocated then\r\n begin\r\n SendMessage(Handle, EM_GETZOOM, WPARAM(@WP), LPARAM(@LP));\r\n if (LP > 0) then\r\n Result := MulDiv(100, WP, LP);\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomRichEdit.InsertGraphic(AGraphic: TGraphic; const Sizeable: Boolean);\r\nvar\r\n OleClientSite: IOleClientSite;\r\n Storage: IStorage;\r\n OleObject: IOleObject;\r\n ReObject: TReObject;\r\n DataObject: IDataObject;\r\n Selection: TCharRange;\r\n FormatEtc: TFormatEtc;\r\nbegin\r\n if HandleAllocated and Assigned(FRichEditOle) then\r\n begin\r\n DataObject := TImageDataObject.Create(AGraphic);\r\n\r\n FillChar(ReObject, SizeOf(TReObject), 0);\r\n IRichEditOle(FRichEditOle).GetClientSite(OleClientSite);\r\n Storage := nil;\r\n OleObject := nil;\r\n try\r\n CreateStorage(Storage);\r\n\r\n FormatEtc.cfFormat := CF_METAFILEPICT;\r\n FormatEtc.ptd := nil;\r\n FormatEtc.dwAspect := DVASPECT_CONTENT;\r\n FormatEtc.lindex := -1;\r\n FormatEtc.tymed := TYMED_MFPICT;\r\n\r\n OleCheck(OleCreateStaticFromData(DataObject, IOleObject, OLERENDER_FORMAT,\r\n @FormatEtc, OleClientSite, Storage, OleObject));\r\n OleSetContainedObject(OleObject, True);\r\n try\r\n FillChar(ReObject, SizeOf(TReObject), #0);\r\n with ReObject do\r\n begin\r\n cbStruct := SizeOf(TReObject);\r\n cp := REO_CP_SELECTION;\r\n poleobj := OleObject;\r\n OleObject.GetUserClassID(clsid);\r\n pstg := Storage;\r\n polesite := OleClientSite;\r\n dvAspect := DVASPECT_CONTENT;\r\n if Sizeable then\r\n dwFlags := REO_RESIZABLE;\r\n //OleCheck(OleSetDrawAspect(OleObject,\r\n // Data.dwFlags and PSF_CHECKDISPLAYASICON <> 0,\r\n // Data.hMetaPict, dvAspect));\r\n end;\r\n SendMessage(Handle, EM_EXGETSEL, 0, LPARAM(@Selection));\r\n Selection.cpMax := Selection.cpMin + 1;\r\n OleCheck(IRichEditOle(FRichEditOle).InsertObject(ReObject));\r\n SendMessage(Handle, EM_EXSETSEL, 0, LPARAM(@Selection));\r\n IRichEditOle(FRichEditOle).SetDvaspect(\r\n Longint(REO_IOB_SELECTION), ReObject.dvAspect);\r\n finally\r\n ReleaseObject(OleObject);\r\n end;\r\n finally\r\n ReleaseObject(OleClientSite);\r\n ReleaseObject(Storage);\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomRichEdit.InsertFormatText(Index: Integer; const S: string; FontStyle: TFontStyles;\r\n const FontName: string; const FontColor: TColor; FontHeight: Integer);\r\nvar\r\n AFont: TFont;\r\nbegin\r\n if S = '' then\r\n Exit;\r\n AFont := TFont.Create;\r\n try\r\n AFont.Assign(SelAttributes);\r\n AFont.Style := FontStyle;\r\n if FontName <> '' then\r\n AFont.Name := FontName;\r\n if FontColor <> clDefault then\r\n AFont.Color := FontColor;\r\n if FontHeight <> 0 then\r\n AFont.Height := FontHeight;\r\n InsertFormatText(Index, S, AFont);\r\n\r\n finally\r\n AFont.Free;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomRichEdit.InsertFormatText(Index: Integer; const S: string; const AFont: TFont = nil);\r\nvar\r\n ASelStart, ASelLength: Integer;\r\nbegin\r\n if S = '' then\r\n Exit;\r\n ASelStart := SelStart;\r\n ASelLength := SelLength;\r\n try\r\n if Index > -1 then\r\n SelStart := Index;\r\n SelLength := 0;\r\n if AFont <> nil then\r\n SelAttributes.Assign(AFont);\r\n SelText := S;\r\n finally\r\n SelStart := ASelStart;\r\n SelLength := ASelLength;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomRichEdit.InsertLinkToFile(const FileName: string;\r\n Iconic: Boolean);\r\nvar\r\n Info: TCreateInfo;\r\nbegin\r\n Info.CreateType := ctLinkToFile;\r\n Info.ShowAsIcon := Iconic;\r\n Info.IconMetaPict := 0;\r\n Info.FileName := FileName;\r\n InsertObjectFromInfo(Info);\r\nend;\r\n\r\nprocedure TJvCustomRichEdit.InsertObject(const OleClassName: string;\r\n Iconic: Boolean);\r\nvar\r\n Info: TCreateInfo;\r\nbegin\r\n Info.CreateType := ctNewObject;\r\n Info.ShowAsIcon := Iconic;\r\n Info.IconMetaPict := 0;\r\n Info.ClassID := ProgIDToClassID(OleClassName);\r\n InsertObjectFromInfo(Info);\r\nend;\r\n\r\nfunction TJvCustomRichEdit.InsertObjectDialog: Boolean;\r\nvar\r\n Data: TOleUIInsertObject;\r\n {$IFDEF UNICODE}\r\n { Mantis #4738: OleUIInsertObjectW() returns with OLEUI_IOERR_LPCLSIDEXCLUDEINVALID }\r\n { Probably windows error; cchFile must be exactly MAXPATH }\r\n NameBuffer: array[0..MAX_PATH div SizeOf(Char) - 1] of Char;\r\n {$ELSE}\r\n NameBuffer: array[0..255] of Char;\r\n {$ENDIF UNICODE}\r\n OleClientSite: IOleClientSite;\r\n Storage: IStorage;\r\n OleObject: IOleObject;\r\n ReObject: TReObject;\r\n IsNewObject: Boolean;\r\n Selection: TCharRange;\r\nbegin\r\n FillChar(Data, SizeOf(Data), 0);\r\n FillChar(NameBuffer, SizeOf(NameBuffer), 0);\r\n FillChar(ReObject, SizeOf(TReObject), 0);\r\n if Assigned(FRichEditOle) then\r\n begin\r\n IRichEditOle(FRichEditOle).GetClientSite(OleClientSite);\r\n Storage := nil;\r\n try\r\n CreateStorage(Storage);\r\n with Data do\r\n begin\r\n cbStruct := SizeOf(Data);\r\n dwFlags := IOF_SELECTCREATENEW or IOF_VERIFYSERVERSEXIST or\r\n IOF_CREATENEWOBJECT or IOF_CREATEFILEOBJECT or IOF_CREATELINKOBJECT;\r\n hWndOwner := Handle;\r\n lpszFile := NameBuffer;\r\n cchFile := SizeOf(NameBuffer);\r\n iid := IOleObject;\r\n oleRender := OLERENDER_DRAW;\r\n lpIOleClientSite := OleClientSite;\r\n lpIStorage := Storage;\r\n ppvObj := @OleObject;\r\n end;\r\n try\r\n Result := OleUIInsertObject(Data) = OLEUI_OK;\r\n if Result then\r\n try\r\n IsNewObject := Data.dwFlags and IOF_SELECTCREATENEW = IOF_SELECTCREATENEW;\r\n with ReObject do\r\n begin\r\n cbStruct := SizeOf(TReObject);\r\n cp := REO_CP_SELECTION;\r\n clsid := Data.clsid;\r\n poleobj := OleObject;\r\n pstg := Storage;\r\n polesite := OleClientSite;\r\n dvAspect := DVASPECT_CONTENT;\r\n dwFlags := REO_RESIZABLE;\r\n if IsNewObject then\r\n dwFlags := dwFlags or REO_BLANK;\r\n end;\r\n OleCheck(OleSetDrawAspect(OleObject,\r\n Data.dwFlags and IOF_CHECKDISPLAYASICON <> 0,\r\n Data.hMetaPict, ReObject.dvAspect));\r\n SendMessage(Handle, EM_EXGETSEL, 0, LPARAM(@Selection));\r\n Selection.cpMax := Selection.cpMin + 1;\r\n OleCheck(IRichEditOle(FRichEditOle).InsertObject(ReObject));\r\n SendMessage(Handle, EM_EXSETSEL, 0, LPARAM(@Selection));\r\n SendMessage(Handle, Messages.EM_SCROLLCARET, 0, 0);\r\n IRichEditOle(FRichEditOle).SetDvaspect(\r\n Longint(REO_IOB_SELECTION), ReObject.dvAspect);\r\n if IsNewObject then\r\n OleObject.DoVerb(OLEIVERB_SHOW, nil,\r\n OleClientSite, 0, Handle, ClientRect);\r\n finally\r\n ReleaseObject(OleObject);\r\n end;\r\n finally\r\n DestroyMetaPict(Data.hMetaPict);\r\n end;\r\n finally\r\n ReleaseObject(OleClientSite);\r\n ReleaseObject(Storage);\r\n end;\r\n end\r\n else\r\n Result := False;\r\nend;\r\n\r\nprocedure TJvCustomRichEdit.InsertObjectFromFile(const FileName: string; Iconic: Boolean);\r\nvar\r\n Info: TCreateInfo;\r\nbegin\r\n Info.CreateType := ctFromFile;\r\n Info.ShowAsIcon := Iconic;\r\n Info.IconMetaPict := 0;\r\n Info.FileName := FileName;\r\n InsertObjectFromInfo(Info);\r\nend;\r\n\r\nprocedure TJvCustomRichEdit.InsertObjectFromInfo(const Info: TCreateInfo);\r\nvar\r\n OleClientSite: IOleClientSite;\r\n Storage: IStorage;\r\n OleObject: IOleObject;\r\n ReObject: TReObject;\r\n Selection: TCharRange;\r\nbegin\r\n if not Assigned(FRichEditOle) then\r\n Exit;\r\n\r\n IRichEditOle(FRichEditOle).GetClientSite(OleClientSite);\r\n Storage := nil;\r\n OleObject := nil;\r\n try\r\n CreateStorage(Storage);\r\n with Info do\r\n begin\r\n case CreateType of\r\n ctNewObject:\r\n OleCheck(OleCreate(ClassID, IOleObject, OLERENDER_DRAW, nil,\r\n OleClientSite, Storage, OleObject));\r\n ctFromFile:\r\n OleCheck(OleCreateFromFile(GUID_NULL, PWideChar(FileName), IOleObject,\r\n OLERENDER_DRAW, nil, OleClientSite, Storage, OleObject));\r\n ctLinkToFile:\r\n OleCheck(OleCreateLinkToFile(PWideChar(FileName), IOleObject,\r\n OLERENDER_DRAW, nil, OleClientSite, Storage, OleObject));\r\n ctFromData:\r\n OleCheck(OleCreateFromData(DataObject, IOleObject,\r\n OLERENDER_DRAW, nil, OleClientSite, Storage, OleObject));\r\n ctLinkFromData:\r\n OleCheck(OleCreateLinkFromData(DataObject, IOleObject,\r\n OLERENDER_DRAW, nil, OleClientSite, Storage, OleObject));\r\n end;\r\n try\r\n if CreateType = ctNewObject then\r\n OleSetContainedObject(OleObject, True);\r\n FillChar(ReObject, SizeOf(TReObject), 0);\r\n with ReObject do\r\n begin\r\n cbStruct := SizeOf(TReObject);\r\n cp := REO_CP_SELECTION;\r\n poleobj := OleObject;\r\n OleObject.GetUserClassID(clsid);\r\n pstg := Storage;\r\n polesite := OleClientSite;\r\n dvAspect := DVASPECT_CONTENT;\r\n dwFlags := REO_RESIZABLE;\r\n if CreateType = ctNewObject then\r\n dwFlags := dwFlags or REO_BLANK;\r\n end;\r\n OleCheck(OleSetDrawAspect(OleObject, ShowAsIcon,\r\n IconMetaPict, ReObject.dvAspect));\r\n SendMessage(Handle, EM_EXGETSEL, 0, LPARAM(@Selection));\r\n Selection.cpMax := Selection.cpMin + 1;\r\n OleCheck(IRichEditOle(FRichEditOle).InsertObject(ReObject));\r\n SendMessage(Handle, EM_EXSETSEL, 0, LPARAM(@Selection));\r\n SendMessage(Handle, Messages.EM_SCROLLCARET, 0, 0);\r\n IRichEditOle(FRichEditOle).SetDvaspect(\r\n Longint(REO_IOB_SELECTION), ReObject.dvAspect);\r\n if CreateType = ctNewObject then\r\n OleObject.DoVerb(OLEIVERB_SHOW, nil,\r\n OleClientSite, 0, Handle, ClientRect);\r\n finally\r\n ReleaseObject(OleObject);\r\n end;\r\n end;\r\n finally\r\n ReleaseObject(OleClientSite);\r\n ReleaseObject(Storage);\r\n end;\r\nend;\r\n\r\nfunction TJvCustomRichEdit.IsAdvancedTypographyStored: Boolean;\r\nbegin\r\n Result := not AutoAdvancedTypography;\r\nend;\r\n\r\nfunction TJvCustomRichEdit.CharFromPos(X, Y: Integer): Integer;\r\nvar\r\n Pt: TPoint;\r\nbegin\r\n Pt := Point(X, Y);\r\n Result := SendMessage(Handle, EM_CHARFROMPOS, 0, LPARAM(@Pt));\r\nend;\r\n\r\nfunction TJvCustomRichEdit.LineFromChar(CharIndex: Integer): Integer;\r\nbegin\r\n Result := SendMessage(Handle, EM_EXLINEFROMCHAR, 0, CharIndex);\r\nend;\r\n\r\nprocedure TJvCustomRichEdit.NeedAdvancedTypography;\r\nbegin\r\n if AutoAdvancedTypography and (RichEditVersion >= 3) then\r\n begin\r\n HandleNeeded;\r\n AdvancedTypography := True;\r\n // setting AdvancedTypography will set AutoAdvancedTypography to False, so:\r\n AutoAdvancedTypography := True;\r\n end;\r\nend;\r\n\r\nfunction TJvCustomRichEdit.ObjectPropertiesDialog: Boolean;\r\nvar\r\n ObjectProps: TOleUIObjectProps;\r\n PropSheet: TPropSheetHeader;\r\n GeneralProps: TOleUIGnrlProps;\r\n ViewProps: TOleUIViewProps;\r\n LinkProps: TOleUILinkProps;\r\n DialogCaption: string;\r\n ReObject: TReObject;\r\nbegin\r\n Result := False;\r\n if not Assigned(FRichEditOle) or (SelectionType <> [stObject]) then\r\n Exit;\r\n FillChar(ObjectProps, SizeOf(ObjectProps), 0);\r\n FillChar(PropSheet, SizeOf(PropSheet), 0);\r\n FillChar(GeneralProps, SizeOf(GeneralProps), 0);\r\n FillChar(ViewProps, SizeOf(ViewProps), 0);\r\n FillChar(LinkProps, SizeOf(LinkProps), 0);\r\n FillChar(ReObject, SizeOf(ReObject), 0);\r\n ReObject.cbStruct := SizeOf(ReObject);\r\n if Succeeded(IRichEditOle(FRichEditOle).GetObject(Longint(REO_IOB_SELECTION),\r\n ReObject, REO_GETOBJ_POLEOBJ or REO_GETOBJ_POLESITE)) then\r\n if ReObject.dwFlags and REO_INPLACEACTIVE = 0 then\r\n begin\r\n ObjectProps.cbStruct := SizeOf(ObjectProps);\r\n ObjectProps.dwFlags := OPF_DISABLECONVERT;\r\n ObjectProps.lpPS := @PropSheet;\r\n ObjectProps.lpObjInfo := TOleUIObjInfo.Create(Self, ReObject);\r\n if (ReObject.dwFlags and REO_LINK) <> 0 then\r\n begin\r\n ObjectProps.dwFlags := ObjectProps.dwFlags or OPF_OBJECTISLINK;\r\n ObjectProps.lpLinkInfo := TOleUILinkInfo.Create(Self, ReObject);\r\n end;\r\n ObjectProps.lpGP := @GeneralProps;\r\n ObjectProps.lpVP := @ViewProps;\r\n ObjectProps.lpLP := @LinkProps;\r\n PropSheet.dwSize := SizeOf(PropSheet);\r\n PropSheet.hWndParent := Handle;\r\n PropSheet.HInstance := MainInstance;\r\n DialogCaption := Format(SPropDlgCaption, [GetFullNameStr(ReObject.poleobj)]);\r\n PropSheet.pszCaption := PChar(DialogCaption);\r\n GeneralProps.cbStruct := SizeOf(GeneralProps);\r\n ViewProps.cbStruct := SizeOf(ViewProps);\r\n ViewProps.dwFlags := VPF_DISABLESCALE;\r\n LinkProps.cbStruct := SizeOf(LinkProps);\r\n LinkProps.dwFlags := ELF_DISABLECANCELLINK;\r\n Result := OleUIObjectProperties(ObjectProps) = OLEUI_OK;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomRichEdit.ObjectPropsClick(Sender: TObject);\r\nbegin\r\n ObjectPropertiesDialog;\r\nend;\r\n\r\nfunction TJvCustomRichEdit.PasteSpecialDialog: Boolean;\r\n\r\n procedure SetPasteEntry(var Entry: TOleUIPasteEntry; Format: TClipFormat;\r\n tymed: DWORD; const FormatName, ResultText: string; Flags: DWORD);\r\n begin\r\n with Entry do\r\n begin\r\n fmtetc.cfFormat := Format;\r\n fmtetc.dwAspect := DVASPECT_CONTENT;\r\n fmtetc.lindex := -1;\r\n fmtetc.tymed := tymed;\r\n if FormatName <> '' then\r\n lpstrFormatName := PChar(FormatName)\r\n else\r\n lpstrFormatName := '%s';\r\n if ResultText <> '' then\r\n lpstrResultText := PChar(ResultText)\r\n else\r\n lpstrResultText := '%s';\r\n dwFlags := Flags;\r\n end;\r\n end;\r\n\r\nconst\r\n PasteFormatCount = 6;\r\nvar\r\n Data: TOleUIPasteSpecial;\r\n PasteFormats: array[0..PasteFormatCount - 1] of TOleUIPasteEntry;\r\n Format: Integer;\r\n Info: TCreateInfo;\r\nbegin\r\n Result := False;\r\n if not CanPaste or not Assigned(FRichEditOle) then\r\n Exit;\r\n FillChar(Data, SizeOf(Data), 0);\r\n FillChar(PasteFormats, SizeOf(PasteFormats), 0);\r\n with Data do\r\n begin\r\n cbStruct := SizeOf(Data);\r\n hWndOwner := Handle;\r\n arrPasteEntries := @PasteFormats[0];\r\n cPasteEntries := PasteFormatCount;\r\n arrLinkTypes := @CFLinkSource;\r\n cLinkTypes := 1;\r\n dwFlags := PSF_SELECTPASTE;\r\n end;\r\n SetPasteEntry(PasteFormats[0], CFEmbeddedObject, TYMED_ISTORAGE, '', '',\r\n OLEUIPASTE_PASTE or OLEUIPASTE_ENABLEICON);\r\n SetPasteEntry(PasteFormats[1], CFLinkSource, TYMED_ISTREAM, '', '',\r\n OLEUIPASTE_LINKTYPE1 or OLEUIPASTE_ENABLEICON);\r\n SetPasteEntry(PasteFormats[2], CFRtf, TYMED_ISTORAGE,\r\n CF_RTF, CF_RTF, OLEUIPASTE_PASTE);\r\n SetPasteEntry(PasteFormats[3], CFRtfNoObjs, TYMED_ISTORAGE,\r\n CF_RTFNOOBJS, CF_RTFNOOBJS, OLEUIPASTE_PASTE);\r\n SetPasteEntry(PasteFormats[4], CF_TEXT, TYMED_HGLOBAL,\r\n 'Unformatted text', 'text without any formatting', OLEUIPASTE_PASTE);\r\n SetPasteEntry(PasteFormats[5], CF_BITMAP, TYMED_GDI,\r\n 'Windows Bitmap', 'bitmap image', OLEUIPASTE_PASTE);\r\n try\r\n if OleUIPasteSpecial(Data) = OLEUI_OK then\r\n begin\r\n Result := True;\r\n if Data.nSelectedIndex in [0, 1] then\r\n begin\r\n case Data.nSelectedIndex of\r\n 0: Info.CreateType := ctFromData;\r\n 1: Info.CreateType := ctLinkFromData;\r\n end;\r\n Info.DataObject := Data.lpSrcDataObj;\r\n Info.ShowAsIcon := Data.dwFlags and PSF_CHECKDISPLAYASICON <> 0;\r\n Info.IconMetaPict := Data.hMetaPict;\r\n\r\n InsertObjectFromInfo(Info);\r\n end\r\n else\r\n begin\r\n Format := PasteFormats[Data.nSelectedIndex].fmtetc.cfFormat;\r\n OleCheck(IRichEditOle(FRichEditOle).ImportDataObject(\r\n Data.lpSrcDataObj, Format, Data.hMetaPict));\r\n SendMessage(Handle, Messages.EM_SCROLLCARET, 0, 0);\r\n end;\r\n end;\r\n finally\r\n DestroyMetaPict(Data.hMetaPict);\r\n ReleaseObject(Data.lpSrcDataObj);\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomRichEdit.PopupVerbClick(Sender: TObject);\r\nvar\r\n ReObject: TReObject;\r\nbegin\r\n if Assigned(FRichEditOle) then\r\n begin\r\n FillChar(ReObject, SizeOf(ReObject), 0);\r\n ReObject.cbStruct := SizeOf(ReObject);\r\n if Succeeded(IRichEditOle(FRichEditOle).GetObject(\r\n Longint(REO_IOB_SELECTION), ReObject, REO_GETOBJ_POLEOBJ or\r\n REO_GETOBJ_POLESITE)) then\r\n try\r\n if ReObject.dwFlags and REO_INPLACEACTIVE = 0 then\r\n OleCheck(ReObject.poleobj.DoVerb((Sender as TMenuItem).Tag, nil,\r\n ReObject.polesite, 0, Handle, ClientRect));\r\n finally\r\n ReleaseObject(ReObject.polesite);\r\n ReleaseObject(ReObject.poleobj);\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomRichEdit.Print(const Caption: string);\r\nvar\r\n Range: TFormatRange;\r\n LastChar, MaxLen, LogX, LogY, OldMap: Integer;\r\n SaveRect: TRect;\r\nbegin\r\n FillChar(Range, SizeOf(TFormatRange), 0);\r\n with Printer, Range do\r\n begin\r\n Title := Caption;\r\n BeginDoc;\r\n HDC := Handle;\r\n hdcTarget := HDC;\r\n LogX := GetDeviceCaps(Handle, LOGPIXELSX);\r\n LogY := GetDeviceCaps(Handle, LOGPIXELSY);\r\n if IsRectEmpty(PageRect) then\r\n begin\r\n rc.Right := PageWidth * CTwipsPerInch div LogX;\r\n rc.Bottom := PageHeight * CTwipsPerInch div LogY;\r\n end\r\n else\r\n begin\r\n rc.Left := PageRect.Left * CTwipsPerInch div LogX;\r\n rc.Top := PageRect.Top * CTwipsPerInch div LogY;\r\n rc.Right := PageRect.Right * CTwipsPerInch div LogX;\r\n rc.Bottom := PageRect.Bottom * CTwipsPerInch div LogY;\r\n end;\r\n rcPage := rc;\r\n SaveRect := rc;\r\n LastChar := 0;\r\n MaxLen := GetTextLenEx;\r\n chrg.cpMax := -1;\r\n { ensure printer DC is in text map mode }\r\n OldMap := SetMapMode(HDC, MM_TEXT);\r\n SendMessage(Self.Handle, EM_FORMATRANGE, 0, 0); { flush buffer }\r\n try\r\n repeat\r\n rc := SaveRect;\r\n chrg.cpMin := LastChar;\r\n LastChar := SendMessage(Self.Handle, EM_FORMATRANGE, 1, LPARAM(@Range));\r\n if (LastChar < MaxLen) and (LastChar <> -1) then\r\n NewPage;\r\n until (LastChar >= MaxLen) or (LastChar = -1);\r\n EndDoc;\r\n finally\r\n SendMessage(Self.Handle, EM_FORMATRANGE, 0, 0); { flush buffer }\r\n SetMapMode(HDC, OldMap); { restore previous map mode }\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJvCustomRichEdit.ProtectChange(const Msg: TMessage;\r\n StartPos, EndPos: Integer): Boolean;\r\nbegin\r\n Result := False;\r\n if Assigned(OnProtectChangeEx) then\r\n OnProtectChangeEx(Self, Msg, StartPos, EndPos, Result)\r\n else\r\n if Assigned(OnProtectChange) then\r\n OnProtectChange(Self, StartPos, EndPos, Result);\r\nend;\r\n\r\nprocedure TJvCustomRichEdit.Redo;\r\nbegin\r\n SendMessage(Handle, EM_REDO, 0, 0);\r\nend;\r\n\r\nclass procedure TJvCustomRichEdit.RegisterConversionFormat(AConverter: TJvConversion);\r\nbegin\r\n if Assigned(AConverter) then\r\n GConversionFormatList.Add(AConverter);\r\nend;\r\n\r\nclass procedure TJvCustomRichEdit.RegisterMSTextConverters;\r\n{ http://support.microsoft.com/support/kb/articles/q212/2/65.asp\r\n http://www.microsoft.com/office/ork/2003/tools/BoxA07.htm\r\n}\r\nconst\r\n SKey = '\\Software\\Microsoft\\Shared Tools\\Text Converters\\';\r\n SImportExportKey: array[TJvConversionKind] of string = ('Import\\', 'Export\\');\r\nvar\r\n KeyNames: TStringList;\r\n Registry: TRegistry;\r\n\r\n procedure RegisterConverters(const AKind: TJvConversionKind);\r\n var\r\n I: Integer;\r\n begin\r\n with Registry do\r\n begin\r\n if not OpenKey(SKey + SImportExportKey[AKind], False) then\r\n Exit;\r\n\r\n GetKeyNames(KeyNames);\r\n for I := 0 to KeyNames.Count - 1 do\r\n if OpenKey(SKey + SImportExportKey[AKind] + KeyNames[I], False) then\r\n begin\r\n RegisterConversionFormat(TJvMSTextConversion.Create(\r\n ReadString('Path'),\r\n ReadString('Extensions'),\r\n ReadString('Name'),\r\n AKind\r\n ));\r\n end;\r\n end;\r\n end;\r\n\r\nbegin\r\n if GMSTextConvertersRegistered then\r\n Exit;\r\n GMSTextConvertersRegistered := True;\r\n\r\n Registry := TRegistry.Create(KEY_READ);\r\n try\r\n Registry.RootKey := HKEY_LOCAL_MACHINE;\r\n\r\n KeyNames := TStringList.Create;\r\n try\r\n RegisterConverters(ckImport);\r\n RegisterConverters(ckExport);\r\n finally\r\n KeyNames.Free;\r\n end;\r\n finally\r\n Registry.Free;\r\n end;\r\nend;\r\n\r\nfunction TJvCustomRichEdit.ReplaceDialog(const SearchStr, ReplaceStr: string): TReplaceDialog;\r\nbegin\r\n if FReplaceDialog = nil then\r\n begin\r\n FReplaceDialog := TReplaceDialog.Create(Self);\r\n if FFindDialog <> nil then\r\n FReplaceDialog.FindText := FFindDialog.FindText;\r\n end;\r\n Result := FReplaceDialog;\r\n SetupFindDialog(FReplaceDialog, SearchStr, ReplaceStr);\r\n FReplaceDialog.Execute;\r\nend;\r\n\r\nprocedure TJvCustomRichEdit.ReplaceDialogReplace(Sender: TObject);\r\nvar\r\n Cnt: Integer;\r\n SaveSelChange: TNotifyEvent;\r\n\r\n function MatchesText(const FindText, FoundText: string; Options: TFindOptions): Boolean;\r\n begin\r\n if frWholeWord in Options then\r\n begin\r\n if frMatchCase in Options then\r\n Result := AnsiSameStr(FindText, FoundText)\r\n else\r\n Result := AnsiSameText(FindText, FoundText);\r\n end\r\n else\r\n begin\r\n if frMatchCase in Options then\r\n Result := Pos(FoundText, FindText) > 0\r\n else\r\n Result := Pos(AnsiLowerCase(FindText), AnsiLowerCase(FoundText)) > 0;\r\n end;\r\n end;\r\nbegin\r\n with TReplaceDialog(Sender) do\r\n begin\r\n if frReplaceAll in Options then\r\n begin\r\n Cnt := 0;\r\n SaveSelChange := FOnSelChange;\r\n TJvRichEditStrings(Lines).EnableChange(False);\r\n try\r\n FOnSelChange := nil;\r\n while FindEditText(TFindDialog(Sender), False, False) do\r\n begin\r\n SelText := ReplaceText;\r\n Inc(Cnt);\r\n end;\r\n if Cnt = 0 then\r\n TextNotFound(TFindDialog(Sender))\r\n else\r\n AdjustFindDialogPosition(TFindDialog(Sender));\r\n finally\r\n TJvRichEditStrings(Lines).EnableChange(True);\r\n FOnSelChange := SaveSelChange;\r\n if Cnt > 0 then\r\n begin\r\n Change;\r\n SelectionChange;\r\n end;\r\n end;\r\n end\r\n else\r\n if frReplace in Options then\r\n begin\r\n if MatchesText(SelText, FindText, Options) then\r\n SelText := ReplaceText;\r\n FindEditText(TFindDialog(Sender), True, True);\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomRichEdit.RequestSize(const Rect: TRect);\r\nbegin\r\n if Assigned(OnResizeRequest) then\r\n OnResizeRequest(Self, Rect);\r\n FImageRect := Rect;\r\nend;\r\n\r\nfunction TJvCustomRichEdit.SaveClipboard(NumObj, NumChars: Integer): Boolean;\r\nbegin\r\n Result := True;\r\n if Assigned(OnSaveClipboard) then\r\n OnSaveClipboard(Self, NumObj, NumChars, Result);\r\nend;\r\n\r\nprocedure TJvCustomRichEdit.SaveToImage(Picture: TPicture);\r\nconst\r\n cSelectionBarWidth = 9;\r\nvar\r\n ABmp: TBitmap;\r\n Range: TFormatRange;\r\n R: TRect;\r\nbegin\r\n if (Picture = nil) or (ClientWidth = 0) or (ClientHeight = 0) or not HandleAllocated then\r\n Exit;\r\n ABmp := TBitmap.Create;\r\n try\r\n if IsRectEmpty(FImageRect) then\r\n begin\r\n FImageRect.Right := ClientWidth;\r\n FImageRect.Bottom := ClientHeight;\r\n end;\r\n // Determine draw width (\"formatting rectangle\"), FImageRect is control width\r\n SendMessage(Handle, EM_GETRECT, 0, LPARAM(@R));\r\n // According to MSDN the selection bar is not included in the formatting\r\n // rectangle, but this seems to be NOT true\r\n if SelectionBar then\r\n Dec(R.Right, cSelectionBarWidth);\r\n ABmp.Width := R.Right - R.Left;\r\n ABmp.Height := FImageRect.Bottom;\r\n R.Top := 0;\r\n R.Left := 0;\r\n // R must be in twips:\r\n // pixels * (twips/inch) / (pixels/inch) = twips\r\n R.Right := MulDiv(ABmp.Width, cTwipsPerInch, Screen.PixelsPerInch);\r\n R.Bottom := MulDiv(ABmp.Height, cTwipsPerInch, Screen.PixelsPerInch);\r\n Range.hdc := ABmp.Canvas.Handle;\r\n Range.hdcTarget := ABmp.Canvas.Handle;\r\n Range.rc := R;\r\n Range.rcPage := R;\r\n Range.chrg.cpMin := 0;\r\n Range.chrg.cpMax := -1;\r\n SendMessage(Handle, EM_FORMATRANGE, 1, LPARAM(@Range));\r\n SendMessage(Handle, EM_FORMATRANGE, 0, 0); { flush buffer }\r\n Picture.Assign(ABmp);\r\n finally\r\n ABmp.Free;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomRichEdit.SelectionChange;\r\nbegin\r\n if Assigned(OnSelectionChange) then\r\n OnSelectionChange(Self);\r\nend;\r\n\r\nprocedure TJvCustomRichEdit.SetAdvancedTypography(const Value: Boolean);\r\nbegin\r\n FAdvancedTypography := Value;\r\n if FAdvancedTypography then\r\n AutoAdvancedTypography := False;\r\n UpdateTypographyOptions(FAdvancedTypography);\r\nend;\r\n\r\nprocedure TJvCustomRichEdit.SetAllowObjects(Value: Boolean);\r\nbegin\r\n if FAllowObjects <> Value then\r\n begin\r\n FAllowObjects := Value;\r\n RecreateWnd;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomRichEdit.SetAutoURLDetect(Value: Boolean);\r\nbegin\r\n if Value <> FAutoURLDetect then\r\n begin\r\n FAutoURLDetect := Value;\r\n if HandleAllocated and (RichEditVersion >= 2) then\r\n SendMessage(Handle, EM_AUTOURLDETECT, WPARAM(FAutoURLDetect), 0);\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomRichEdit.SetDefAttributes(Value: TJvTextAttributes);\r\nbegin\r\n FDefAttributes.Assign(Value);\r\nend;\r\n\r\nprocedure TJvCustomRichEdit.SetFlat(const Value: Boolean);\r\nbegin\r\n Ctl3D := not Value;\r\nend;\r\n\r\nprocedure TJvCustomRichEdit.SetHideScrollBars(Value: Boolean);\r\nbegin\r\n if HideScrollBars <> Value then\r\n begin\r\n FHideScrollBars := Value;\r\n RecreateWnd;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomRichEdit.SetHideSelection(Value: Boolean);\r\nbegin\r\n if HideSelection <> Value then\r\n begin\r\n FHideSelection := Value;\r\n SendMessage(Handle, EM_HIDESELECTION, Ord(HideSelection), LPARAM(True));\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomRichEdit.SetLangOptions(Value: TRichLangOptions);\r\nvar\r\n Flags: DWORD;\r\n I: TRichLangOption;\r\nbegin\r\n FLangOptions := Value;\r\n if HandleAllocated and (RichEditVersion >= 2) then\r\n begin\r\n Flags := 0;\r\n for I := Low(TRichLangOption) to High(TRichLangOption) do\r\n if I in Value then\r\n Flags := Flags or RichLangOptions[I];\r\n SendMessage(Handle, EM_SETLANGOPTIONS, 0, LPARAM(Flags));\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomRichEdit.SetOLEDragDrop(const Value: Boolean);\r\nbegin\r\n if FOLEDragDrop <> Value then\r\n begin\r\n FOLEDragDrop := Value;\r\n RecreateWnd;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomRichEdit.SetParentFlat(const Value: Boolean);\r\nbegin\r\n ParentCtl3D := Value;\r\nend;\r\n\r\nprocedure TJvCustomRichEdit.SetPlainText(Value: Boolean);\r\nvar\r\n State: TJvRichEditState;\r\nbegin\r\n if PlainText <> Value then\r\n begin\r\n if HandleAllocated and (RichEditVersion >= 2) then\r\n begin\r\n State := TJvRichEditState.Create;\r\n try\r\n State.ForcePlainText := (csDesigning in ComponentState) or Value;\r\n State.Store(Self);\r\n\r\n TJvRichEditStrings(Lines).EnableChange(False);\r\n try\r\n SendMessage(Handle, WM_SETTEXT, 0, 0);\r\n UpdateTextModes(Value);\r\n FPlainText := Value;\r\n finally\r\n TJvRichEditStrings(Lines).EnableChange(True);\r\n end;\r\n\r\n State.Restore(Self);\r\n finally\r\n State.Free;\r\n end;\r\n end;\r\n FPlainText := Value;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomRichEdit.SetRichEditStrings(Value: TStrings);\r\nbegin\r\n FLines.Assign(Value);\r\nend;\r\n\r\nprocedure TJvCustomRichEdit.SetSelAttributes(Value: TJvTextAttributes);\r\nbegin\r\n FSelAttributes.Assign(Value);\r\nend;\r\n\r\nprocedure TJvCustomRichEdit.SetSelection(StartPos, EndPos: Longint;\r\n ScrollCaret: Boolean);\r\nvar\r\n CharRange: TCharRange;\r\nbegin\r\n with CharRange do\r\n begin\r\n cpMin := StartPos;\r\n cpMax := EndPos;\r\n end;\r\n SendMessage(Handle, EM_EXSETSEL, 0, LPARAM(@CharRange));\r\n if ScrollCaret then\r\n SendMessage(Handle, Messages.EM_SCROLLCARET, 0, 0);\r\nend;\r\n\r\nprocedure TJvCustomRichEdit.SetSelectionBar(Value: Boolean);\r\nbegin\r\n if FSelectionBar <> Value then\r\n begin\r\n FSelectionBar := Value;\r\n RecreateWnd;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomRichEdit.SetSelectionLink;\r\nvar\r\n CharFormat: TCharFormat;\r\nbegin\r\n FillChar(CharFormat, SizeOf(CharFormat), 0);\r\n CharFormat.cbSize := SizeOf(CharFormat);\r\n CharFormat.dwMask := CFM_LINK;\r\n CharFormat.dwEffects := CFE_LINK;\r\n SendMessage(Handle, EM_SETCHARFORMAT, SCF_SELECTION, LPARAM(@CharFormat));\r\nend;\r\n\r\nprocedure TJvCustomRichEdit.SetSelLength(Value: Integer);\r\nbegin\r\n with GetSelection do\r\n SetSelection(cpMin, cpMin + Value, True);\r\nend;\r\n\r\nprocedure TJvCustomRichEdit.SetSelStart(Value: Integer);\r\nbegin\r\n SetSelection(Value, Value, False);\r\nend;\r\n\r\nprocedure TJvCustomRichEdit.SetSelText(const Value: string);\r\nbegin\r\n FLinesUpdating := True;\r\n inherited SelText := Value;\r\n FLinesUpdating := False;\r\nend;\r\n\r\nprocedure TJvCustomRichEdit.SetStreamFormat(Value: TRichStreamFormat);\r\nbegin\r\n TJvRichEditStrings(Lines).Format := Value;\r\nend;\r\n\r\nprocedure TJvCustomRichEdit.SetStreamMode(Value: TRichStreamModes);\r\nbegin\r\n TJvRichEditStrings(Lines).Mode := Value;\r\nend;\r\n\r\nprocedure TJvCustomRichEdit.SetTitle(const Value: string);\r\nbegin\r\n if FTitle <> Value then\r\n begin\r\n FTitle := Value;\r\n UpdateHostNames;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomRichEdit.SetUIActive(Active: Boolean);\r\nvar\r\n Form: TCustomForm;\r\nbegin\r\n try\r\n Form := GetParentForm(Self);\r\n if Form <> nil then\r\n if Active then\r\n begin\r\n if (Form.ActiveOleControl <> nil) and\r\n (Form.ActiveOleControl <> Self) then\r\n Form.ActiveOleControl.Perform(CM_UIDEACTIVATE, 0, 0);\r\n Form.ActiveOleControl := Self;\r\n if AllowInPlace and CanFocus then\r\n SetFocus;\r\n if Assigned(FOnInPlaceActivate) then\r\n FOnInPlaceActivate(Self); // CCR\r\n end\r\n else\r\n begin\r\n if Form.ActiveOleControl = Self then\r\n Form.ActiveOleControl := nil;\r\n if (Form.ActiveControl = Self) and AllowInPlace then\r\n begin\r\n Windows.SetFocus(Handle);\r\n SelectionChange;\r\n end;\r\n if Assigned(FOnInPlaceDeactivate) then\r\n FOnInPlaceDeactivate(Self); // CCR\r\n end;\r\n except\r\n Application.HandleException(Self);\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomRichEdit.SetUndoLimit(Value: Integer);\r\nbegin\r\n if Value <> FUndoLimit then\r\n begin\r\n FUndoLimit := Value;\r\n if (RichEditVersion >= 2) and HandleAllocated then\r\n FUndoLimit := SendMessage(Handle, EM_SETUNDOLIMIT, Value, 0);\r\n end;\r\nend;\r\n\r\n{ Find & Replace Dialogs }\r\n\r\nprocedure TJvCustomRichEdit.SetupFindDialog(Dialog: TFindDialog;\r\n const SearchStr, ReplaceStr: string);\r\nbegin\r\n with Dialog do\r\n begin\r\n if SearchStr <> '' then\r\n FindText := SearchStr;\r\n if RichEditVersion = 1 then\r\n Options := Options + [frHideUpDown, frDown];\r\n OnFind := FindDialogFind;\r\n OnClose := FindDialogClose;\r\n end;\r\n if Dialog is TReplaceDialog then\r\n with TReplaceDialog(Dialog) do\r\n begin\r\n if ReplaceStr <> '' then\r\n ReplaceText := ReplaceStr;\r\n OnReplace := ReplaceDialogReplace;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomRichEdit.SetWordAttributes(Value: TJvTextAttributes);\r\nbegin\r\n FWordAttributes.Assign(Value);\r\nend;\r\n\r\nprocedure TJvCustomRichEdit.SetWordSelection(Value: Boolean);\r\nvar\r\n Options: LPARAM;\r\nbegin\r\n FWordSelection := Value;\r\n if HandleAllocated then\r\n begin\r\n Options := SendMessage(Handle, EM_GETOPTIONS, 0, 0);\r\n if Value then\r\n Options := Options or ECO_AUTOWORDSELECTION\r\n else\r\n Options := Options and not ECO_AUTOWORDSELECTION;\r\n SendMessage(Handle, EM_SETOPTIONS, ECOOP_SET, Options);\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomRichEdit.SetZoom(Value: Integer);\r\nbegin\r\n if (RichEditVersion >= 3) and HandleAllocated then\r\n if Value = 0 then\r\n SendMessage(Handle, EM_SETZOOM, 0, 0)\r\n else\r\n SendMessage(Handle, EM_SETZOOM, Value, 100);\r\nend;\r\n\r\nprocedure TJvCustomRichEdit.StopGroupTyping;\r\nbegin\r\n if (RichEditVersion >= 2) and HandleAllocated then\r\n SendMessage(Handle, EM_STOPGROUPTYPING, 0, 0);\r\nend;\r\n\r\nprocedure TJvCustomRichEdit.TextNotFound(Dialog: TFindDialog);\r\nbegin\r\n with Dialog do\r\n if Assigned(FOnTextNotFound) then\r\n FOnTextNotFound(Self, FindText);\r\nend;\r\n\r\nprocedure TJvCustomRichEdit.UpdateHostNames;\r\nvar\r\n AppName: string;\r\nbegin\r\n if HandleAllocated and Assigned(FRichEditOle) then\r\n begin\r\n AppName := Application.Title;\r\n if Trim(AppName) = '' then\r\n AppName := ExtractFileName(Application.ExeName);\r\n if Trim(Title) = '' then\r\n IRichEditOle(FRichEditOle).SetHostNames(PAnsiChar({$IFDEF SUPPORTS_UNICODE}UTF8Encode{$ENDIF SUPPORTS_UNICODE}(AppName)),\r\n PAnsiChar({$IFDEF SUPPORTS_UNICODE}UTF8Encode{$ENDIF SUPPORTS_UNICODE}(AppName)))\r\n else\r\n IRichEditOle(FRichEditOle).SetHostNames(PAnsiChar({$IFDEF SUPPORTS_UNICODE}UTF8Encode{$ENDIF SUPPORTS_UNICODE}(AppName)),\r\n PAnsiChar({$IFDEF SUPPORTS_UNICODE}UTF8Encode{$ENDIF SUPPORTS_UNICODE}(Title)));\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomRichEdit.UpdateTextModes(Plain: Boolean);\r\nconst\r\n TextModes: array[Boolean] of DWORD = (TM_RICHTEXT, TM_PLAINTEXT);\r\n UndoModes: array[Boolean] of DWORD = (TM_SINGLELEVELUNDO, TM_MULTILEVELUNDO);\r\nbegin\r\n if (RichEditVersion >= 2) and HandleAllocated then\r\n SendMessage(Handle, EM_SETTEXTMODE, WPARAM(TextModes[Plain] or UndoModes[FUndoLimit > 1]), 0);\r\nend;\r\n\r\nprocedure TJvCustomRichEdit.UpdateTypographyOptions(const Advanced: Boolean);\r\nconst\r\n AdvancedModes: array[Boolean] of DWORD = (0, TO_ADVANCEDTYPOGRAPHY);\r\nbegin\r\n if HandleAllocated and (RichEditVersion >= 3) then\r\n SendMessage(Handle, EM_SETTYPOGRAPHYOPTIONS, WPARAM(AdvancedModes[Advanced]), TO_ADVANCEDTYPOGRAPHY);\r\nend;\r\n\r\nprocedure TJvCustomRichEdit.URLClick(const URLText: string; Button: TMouseButton);\r\nbegin\r\n if Assigned(OnURLClick) then\r\n OnURLClick(Self, URLText, Button);\r\nend;\r\n\r\nprocedure TJvCustomRichEdit.URLHover(const URLText: string);\r\nbegin\r\n if Assigned(OnURLHover) then\r\n OnURLHover(Self, URLText);\r\nend;\r\n\r\nprocedure TJvCustomRichEdit.WMDestroy(var Msg: TWMDestroy);\r\nbegin\r\n CloseObjects;\r\n ReleaseObject(FRichEditOle);\r\n inherited;\r\nend;\r\n\r\nprocedure TJvCustomRichEdit.WMHScroll(var Msg: TWMHScroll);\r\nbegin\r\n inherited;\r\n if Assigned(FOnHorizontalScroll) then\r\n FOnHorizontalScroll(Self);\r\nend;\r\n\r\nprocedure TJvCustomRichEdit.WMMouseMove(var Msg: TMessage);\r\nbegin\r\n inherited;\r\nend;\r\n\r\nprocedure TJvCustomRichEdit.WMPaint(var Msg: TWMPaint);\r\nvar\r\n R, R1: TRect;\r\nbegin\r\n if RichEditVersion >= 2 then\r\n inherited\r\n else\r\n begin\r\n if GetUpdateRect(Handle, R, True) then\r\n begin\r\n R1 := ClientRect;\r\n R1.Left := R.Right - 3;\r\n if IntersectRect(R, R, R1) then\r\n InvalidateRect(Handle, @R1, True);\r\n end;\r\n if Painting then\r\n Invalidate\r\n else\r\n begin\r\n Painting := True;\r\n try\r\n inherited;\r\n finally\r\n Painting := False;\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomRichEdit.WMRButtonUp(var Msg: TMessage);\r\nbegin\r\n { RichEd20 does not pass the WM_RBUTTONUP message to defwndproc, }\r\n { so we get no WM_CONTEXTMENU message. Simulate message here. }\r\n if ((RichEditVersion <> 1) or not CheckWin32Version(5, 0)) and AllowObjects then\r\n Perform(WM_CONTEXTMENU, Handle, {$IFDEF RTL230_UP}PointToLParam{$ELSE}LPARAM{$ENDIF RTL230_UP}(PointToSmallPoint(\r\n ClientToScreen(SmallPointToPoint(TWMMouse(Msg).Pos)))));\r\n inherited;\r\nend;\r\n\r\nprocedure TJvCustomRichEdit.WMSetCursor(var Msg: TWMSetCursor);\r\nbegin\r\n inherited;\r\nend;\r\n\r\nprocedure TJvCustomRichEdit.WMSetFont(var Msg: TWMSetFont);\r\nbegin\r\n FDefAttributes.Assign(Font);\r\nend;\r\n\r\nprocedure TJvCustomRichEdit.WMSetText(var Msg: TMessage);\r\nbegin\r\n // if auto URL detection is active, then the handle must have been\r\n // created before setting the text so that the appropriate flag is\r\n // set on the underlying control.\r\n // This way the URL detection mechanism can work (Mantis 5792)\r\n if AutoURLDetect then\r\n HandleNeeded;\r\n\r\n inherited;\r\nend;\r\n\r\nprocedure TJvCustomRichEdit.WMVScroll(var Msg: TWMVScroll);\r\nbegin\r\n inherited;\r\n if Assigned(FOnVerticalScroll) then\r\n FOnVerticalScroll(Self);\r\nend;\r\n\r\nfunction TJvCustomRichEdit.WordAtCursor: string;\r\nvar\r\n Range: TCharRange;\r\nbegin\r\n Result := '';\r\n if HandleAllocated then\r\n begin\r\n Range.cpMax := SelStart;\r\n if Range.cpMax = 0 then\r\n Range.cpMin := 0\r\n else\r\n if SendMessage(Handle, EM_FINDWORDBREAK, WB_ISDELIMITER, Range.cpMax) <> 0 then\r\n Range.cpMin := SendMessage(Handle, EM_FINDWORDBREAK, WB_MOVEWORDLEFT, Range.cpMax)\r\n else\r\n Range.cpMin := SendMessage(Handle, EM_FINDWORDBREAK, WB_LEFT, Range.cpMax);\r\n while SendMessage(Handle, EM_FINDWORDBREAK, WB_ISDELIMITER, Range.cpMin) <> 0 do\r\n Inc(Range.cpMin);\r\n Range.cpMax := SendMessage(Handle, EM_FINDWORDBREAK, WB_RIGHTBREAK, Range.cpMax);\r\n Result := Trim(GetTextRange(Range.cpMin, Range.cpMax));\r\n end;\r\nend;\r\n\r\n//=== { TJvMSTextConversion } ================================================\r\n\r\nconstructor TJvMSTextConversion.Create(const AConverterFileName, AExtensions,\r\n ADescription: string; const AKind: TJvConversionKind);\r\nbegin\r\n inherited Create;\r\n FExtensions := TStringList.Create;\r\n FExtensions.Delimiter := ' ';\r\n FExtensions.DelimitedText := AExtensions;\r\n FConverterFileName := AConverterFileName;\r\n FDescription := ADescription;\r\n FConverterKind := AKind;\r\n FThreadDone := True;\r\n FCancel := False;\r\nend;\r\n\r\ndestructor TJvMSTextConversion.Destroy;\r\nbegin\r\n Done;\r\n FExtensions.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJvMSTextConversion.CanHandle(const AExtension: string;\r\n const AKind: TJvConversionKind): Boolean;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := CanHandle(AKind);\r\n if not Result then\r\n Exit;\r\n\r\n for I := 0 to FExtensions.Count - 1 do\r\n if (FExtensions[I] = '*') or (FExtensions[I] = AExtension) then\r\n begin\r\n Result := True;\r\n Exit;\r\n end;\r\n\r\n Result := False;\r\nend;\r\n\r\nfunction TJvMSTextConversion.CanHandle(\r\n const AKind: TJvConversionKind): Boolean;\r\nbegin\r\n Result := AKind = FConverterKind;\r\nend;\r\n\r\nprocedure TJvMSTextConversion.Check(Result: FCE);\r\nbegin\r\n if Result <> fceNoErr then\r\n DoError(Result);\r\nend;\r\n\r\nfunction TJvMSTextConversion.ConvertRead(Buffer: {$IFDEF COMPILER12_UP}PByte{$ELSE}PAnsiChar{$ENDIF COMPILER12_UP};\r\n BufSize: Integer): Integer;\r\nvar\r\n AvailableBufferSize: Integer;\r\n DestBufferPtr: {$IFDEF COMPILER12_UP}PByte{$ELSE}PAnsiChar{$ENDIF COMPILER12_UP};\r\n ByteCount: Integer;\r\nbegin\r\n { Fill Buffer with BufSize bytes data from FBuffer }\r\n\r\n if not Assigned(FForeignToRtf32) then\r\n DoError(fceReadErr);\r\n\r\n AvailableBufferSize := BufSize;\r\n DestBufferPtr := Buffer;\r\n\r\n repeat\r\n if FBytesAvailable = 0 then\r\n begin\r\n Unlock;\r\n FRichEditReady.SetEvent;\r\n\r\n WaitUntilThreadReady;\r\n FThreadReady.ResetEvent;\r\n { Thread can have set FConversionError & FThreadDone so check those: }\r\n\r\n if FConversionError <> fceNoErr then\r\n DoError(FConversionError);\r\n\r\n if FThreadDone then\r\n begin\r\n Result := BufSize - AvailableBufferSize;\r\n Exit;\r\n end;\r\n end;\r\n\r\n Lock;\r\n\r\n ByteCount := Min(AvailableBufferSize, FBytesAvailable);\r\n Move(FBufferPtr^, DestBufferPtr^, ByteCount);\r\n Inc(DestBufferPtr, ByteCount);\r\n Inc(FBufferPtr, ByteCount);\r\n Dec(FBytesAvailable, ByteCount);\r\n Dec(AvailableBufferSize, ByteCount);\r\n\r\n DoProgress(FTempProgress);\r\n until AvailableBufferSize = 0;\r\n\r\n Result := BufSize;\r\nend;\r\n\r\nfunction TJvMSTextConversion.ConvertWrite(Buffer: {$IFDEF COMPILER12_UP}PByte{$ELSE}PAnsiChar{$ENDIF COMPILER12_UP};\r\n BufSize: Integer): Integer;\r\nvar\r\n DestBufferPtr: PAnsiChar;\r\nbegin\r\n if not Assigned(FForeignToRtf32) then\r\n DoError(fceWriteErr);\r\n\r\n { Result = bytes actually written }\r\n Result := BufSize;\r\n\r\n while BufSize <> 0 do\r\n begin\r\n { wait until thread is ready to export more data.. }\r\n WaitUntilThreadReady;\r\n FThreadReady.ResetEvent;\r\n\r\n if FConversionError <> fceNoErr then\r\n DoError(FConversionError);\r\n\r\n { FBytesAvailable indicates here how many bytes of data are available for\r\n the converter dll to convert. }\r\n FBytesAvailable := Min(BufSize, CConvertBufferSize);\r\n Dec(BufSize, FBytesAvailable);\r\n\r\n DestBufferPtr := GlobalLock(FBuffer);\r\n if not Assigned(DestBufferPtr) then\r\n DoError(fceNoMemory);\r\n Move(Buffer^, DestBufferPtr^, FBytesAvailable);\r\n GlobalUnlock(FBuffer);\r\n\r\n DoProgress(FTempProgress);\r\n\r\n { Signal that data is ready to be exported }\r\n FRichEditReady.SetEvent;\r\n end;\r\nend;\r\n\r\nprocedure TJvMSTextConversion.DoConversion;\r\n{ This procedure is called in the context of the thread }\r\nvar\r\n hDesc: HGLOBAL;\r\n hSubset: HGLOBAL;\r\n LConversionError: FCE;\r\nbegin\r\n { insanity check }\r\n if (FBuffer = 0) or (GCurrentConverter <> Self) then\r\n begin\r\n FConversionError := fceNoMemory;\r\n FThreadDone := True;\r\n FThreadReady.SetEvent;\r\n\r\n Exit;\r\n end;\r\n\r\n hDesc := AnsiStringToHGLOBAL('');\r\n hSubset := AnsiStringToHGLOBAL('');\r\n\r\n if FConverterKind = ckImport then\r\n begin\r\n WaitUntilRichEditReady;\r\n FRichEditReady.ResetEvent;\r\n\r\n LConversionError := FForeignToRtf32(FFileName, nil, FBuffer,\r\n hDesc, hSubset, ImportCallback);\r\n\r\n { This ensures that the ConvertRead picks up the last bytes before FThreadDone is set }\r\n FThreadReady.SetEvent;\r\n WaitUntilRichEditReady;\r\n end\r\n else\r\n LConversionError := FRtfToForeign32(FFileName, nil, FBuffer,\r\n hDesc, ExportCallback);\r\n\r\n GlobalFree(hDesc);\r\n GlobalFree(hSubset);\r\n\r\n if (FConversionError = fceNoErr) and not FCancel then\r\n FConversionError := LConversionError;\r\n\r\n FThreadDone := True;\r\n FThreadReady.SetEvent;\r\nend;\r\n\r\nprocedure TJvMSTextConversion.DoError(ErrorCode: FCE);\r\nbegin\r\n FConversionError := ErrorCode;\r\n raise EMSTextConversionError.Create(TranslateError(ErrorCode), ErrorCode);\r\nend;\r\n\r\nprocedure TJvMSTextConversion.Done;\r\nbegin\r\n if Error then\r\n FCancel := True;\r\n\r\n while not FThreadDone do\r\n begin\r\n FRichEditReady.SetEvent;\r\n WaitUntilThreadReady;\r\n\r\n FBytesAvailable := 0;\r\n\r\n FThreadReady.ResetEvent;\r\n end;\r\n\r\n Unlock;\r\n if FBuffer <> 0 then\r\n GlobalFree(FBuffer);\r\n FBuffer := 0;\r\n\r\n FreeAndNil(FThreadReady);\r\n FreeAndNil(FRichEditReady);\r\n\r\n if Assigned(FUninitConverter) then\r\n FUninitConverter;\r\n\r\n FreeConverter;\r\n\r\n if FFileName <> 0 then\r\n GlobalFree(FFileName);\r\n FFileName := 0;\r\n\r\n if GCurrentConverter = Self then\r\n GCurrentConverter := nil;\r\n FInitDone := False;\r\n\r\n inherited Done;\r\nend;\r\n\r\nfunction TJvMSTextConversion.Error: Boolean;\r\nbegin\r\n Result := (FConversionError <> fceNoErr) and\r\n (FConversionError <> fceUserCancel);\r\nend;\r\n\r\nfunction TJvMSTextConversion.ErrorStr: string;\r\nbegin\r\n if not Error then\r\n begin\r\n Result := '';\r\n Exit;\r\n end;\r\n\r\n Result := TranslateError(FConversionError);\r\n if Result = '' then\r\n begin\r\n Result := FCEToString(FConversionError);\r\n if Result = '' then\r\n Result := Format(RsEConversionError, [FConversionError]);\r\n end;\r\nend;\r\n\r\nfunction TJvMSTextConversion.Filter: string;\r\nvar\r\n I: Integer;\r\n LFilter: string;\r\nbegin\r\n //'Text files (*.txt)|*.TXT'\r\n //'Description (*.htm; *.html)|*.HTM;*.HTML'\r\n\r\n LFilter := '';\r\n Result := '';\r\n for I := 0 to FExtensions.Count - 1 do\r\n begin\r\n Result := Result + '*.' + FExtensions[I] + '; ';\r\n LFilter := LFilter + '*.' + FExtensions[I] + ';';\r\n end;\r\n if Result > '' then\r\n Delete(Result, Length(Result) - 1, 2);\r\n if LFilter > '' then\r\n Delete(LFilter, Length(LFilter), 1);\r\n if Result > '' then\r\n Result := FDescription + ' (' + Result + ')|' + LFilter\r\n else\r\n Result := FDescription;\r\nend;\r\n\r\nprocedure TJvMSTextConversion.FreeConverter;\r\nbegin\r\n if FConverter <> 0 then\r\n FreeLibrary(FConverter);\r\n\r\n FConverter := 0;\r\n\r\n FInitConverter32 := nil;\r\n FIsFormatCorrect32 := nil;\r\n FForeignToRtf32 := nil;\r\n FRtfToForeign32 := nil;\r\n FUninitConverter := nil;\r\n FCchFetchLpszError := nil;\r\nend;\r\n\r\nfunction TJvMSTextConversion.HandleExportCallback(cchBuff, nPercent: Integer): Longint;\r\nbegin\r\n if FBuffer = 0 then\r\n begin\r\n Result := fceNoMemory;\r\n Exit;\r\n end;\r\n\r\n FTempProgress := nPercent;\r\n\r\n { Signal that we're ready to convert data.. }\r\n FThreadReady.SetEvent;\r\n { ..and wait until the richedit has data available to convert }\r\n WaitUntilRichEditReady;\r\n FRichEditReady.ResetEvent;\r\n\r\n { Result = 0 indicates that we're done\r\n Result < 0 indicates error or user cancel\r\n Result > 0 indicates # of bytes put in FBuffer\r\n }\r\n if FCancel then\r\n Result := fceUserCancel\r\n else\r\n Result := FBytesAvailable;\r\nend;\r\n\r\nfunction TJvMSTextConversion.HandleImportCallback(cchBuff, nPercent: Integer): Longint;\r\nbegin\r\n // cchBuff = a count of the bytes of RTF data that the converter has placed in\r\n // ghBuff.\r\n // nPercent can range between 0 and 100, representing the estimate made by\r\n // the converter of how much of the conversion process has been completed.\r\n\r\n if FBuffer = 0 then\r\n begin\r\n Result := fceNoMemory;\r\n Exit;\r\n end;\r\n\r\n FTempProgress := nPercent;\r\n FBytesAvailable := cchBuff;\r\n\r\n { Signal that data is ready.. }\r\n FThreadReady.SetEvent;\r\n { ..and wait until additional data is wanted }\r\n WaitUntilRichEditReady;\r\n FRichEditReady.ResetEvent;\r\n\r\n { Result = 0 indicates that we're done\r\n Result < 0 indicates error or user cancel\r\n Result > 0 indicates # of bytes put in FBuffer\r\n }\r\n\r\n if FCancel then\r\n Result := fceUserCancel\r\n else\r\n { FBytesAvailable should be 0 by now }\r\n Result := FBytesAvailable;\r\nend;\r\n\r\nprocedure TJvMSTextConversion.InitConverter;\r\nbegin\r\n if FInitDone then\r\n Exit;\r\n FInitDone := True;\r\n\r\n LoadConverter;\r\n if not Assigned(FInitConverter32) or\r\n not FInitConverter32(ParentWindow, PAnsiChar(AnsiString(AnsiUpperCase(Application.ExeName)))) then\r\n\r\n raise EMSTextConversionError.CreateRes(@RsECouldNotInitConverter);\r\nend;\r\n\r\nfunction TJvMSTextConversion.IsFormatCorrect(\r\n const AFileName: string): Boolean;\r\nvar\r\n hFile: THandle;\r\n hClass: THandle;\r\nbegin\r\n InitConverter;\r\n\r\n Result := Assigned(FIsFormatCorrect32);\r\n if not Result then\r\n Exit;\r\n\r\n hFile := FileNameToHGLOBAL({$IFDEF SUPPORTS_UNICODE}UTF8Encode{$ENDIF SUPPORTS_UNICODE}(AFileName));\r\n hClass := AnsiStringToHGLOBAL('');\r\n try\r\n Result := FIsFormatCorrect32(hFile, hClass) = fceTrue;\r\n finally\r\n GlobalFree(hClass);\r\n GlobalFree(hFile);\r\n end;\r\nend;\r\n\r\nprocedure TJvMSTextConversion.LoadConverter;\r\nbegin\r\n if FConverter <> 0 then\r\n Exit;\r\n\r\n FConverter := SafeLoadLibrary(FConverterFileName);\r\n if FConverter <> 0 then\r\n begin\r\n @FInitConverter32 := GetProcAddress(FConverter, InitConverter32Name);\r\n @FIsFormatCorrect32 := GetProcAddress(FConverter, IsFormatCorrect32Name);\r\n @FForeignToRtf32 := GetProcAddress(FConverter, ForeignToRtf32Name);\r\n @FRtfToForeign32 := GetProcAddress(FConverter, RtfToForeign32Name);\r\n @FUninitConverter := GetProcAddress(FConverter, UninitConverterName);\r\n @FCchFetchLpszError := GetProcAddress(FConverter, CchFetchLpszErrorName);\r\n end;\r\nend;\r\n\r\nprocedure TJvMSTextConversion.Lock;\r\nbegin\r\n if FBufferPtr = nil then\r\n FBufferPtr := GlobalLock(FBuffer);\r\n\r\n if FBufferPtr = nil then\r\n DoError(fceNoMemory);\r\nend;\r\n\r\nfunction TJvMSTextConversion.Open(const AFileName: string;\r\n const AKind: TJvConversionKind): Boolean;\r\nvar\r\n Sa: TSecurityAttributes;\r\nbegin\r\n { Note: cleanup is done in method Done; method Done is always called\r\n after Open is called }\r\n\r\n Result := (AKind <> ckImport) or FileExists(AFileName);\r\n if not Result then\r\n Exit;\r\n\r\n if GCurrentConverter <> nil then\r\n raise EMSTextConversionError.CreateRes(@RsEConversionBusy);\r\n GCurrentConverter := Self;\r\n\r\n InitConverter;\r\n\r\n FFileName := FileNameToHGLOBAL({$IFDEF SUPPORTS_UNICODE}UTF8Encode{$ENDIF SUPPORTS_UNICODE}(AFileName));\r\n if FFileName = 0 then\r\n DoError(fceNoMemory);\r\n\r\n FBuffer := GlobalAlloc(GHND, CConvertBufferSize);\r\n if FBuffer = 0 then\r\n DoError(fceNoMemory);\r\n\r\n Sa.nLength := SizeOf(TSecurityAttributes);\r\n Sa.lpSecurityDescriptor := nil;\r\n Sa.bInheritHandle := True;\r\n\r\n FThreadReady := TEvent.Create(@Sa, True, False, '');\r\n FRichEditReady := TEvent.Create(@Sa, True, False, '');\r\n\r\n FConversionError := fceNoErr;\r\n FThreadDone := False;\r\n FCancel := False;\r\n FBufferPtr := nil;\r\n\r\n FPercentDone := -1;\r\n DoProgress(0);\r\n\r\n TMSTextConversionThread.Create;\r\n\r\n Result := True;\r\nend;\r\n\r\nfunction TJvMSTextConversion.TextKind: TJvConversionTextKind;\r\nbegin\r\n Result := ctkRTF;\r\nend;\r\n\r\nfunction TJvMSTextConversion.TranslateError(ErrorCode: FCE): string;\r\nconst\r\n CMaxErrorStrSize = 1024; { arbitrary value }\r\nvar\r\n Data: THandle;\r\n DataPtr: PAnsiChar;\r\n Size: Longint;\r\nbegin\r\n InitConverter;\r\n\r\n if not Assigned(FCchFetchLpszError) then\r\n begin\r\n Result := FCEToString(ErrorCode);\r\n Exit;\r\n end;\r\n\r\n Data := GlobalAlloc(GHND, CMaxErrorStrSize + 1); // with last #0, thus + 1\r\n try\r\n DataPtr := GlobalLock(Data);\r\n try\r\n Size := FCchFetchLpszError(ErrorCode, DataPtr, CMaxErrorStrSize);\r\n if Size > 0 then\r\n SetString(Result, DataPtr, Size)\r\n else\r\n Result := '';\r\n finally\r\n GlobalUnlock(Data);\r\n end;\r\n finally\r\n GlobalFree(Data);\r\n end;\r\nend;\r\n\r\nprocedure TJvMSTextConversion.Unlock;\r\nbegin\r\n if FBufferPtr <> nil then\r\n GlobalUnlock(FBuffer);\r\n FBufferPtr := nil;\r\nend;\r\n\r\nfunction TJvMSTextConversion.UserCancel: Boolean;\r\nbegin\r\n Result := FConversionError = fceUserCancel;\r\nend;\r\n\r\nprocedure TJvMSTextConversion.WaitUntilRichEditReady;\r\nvar\r\n Msg: TMsg;\r\n H: THandle;\r\nbegin\r\n H := FRichEditReady.Handle;\r\n\r\n while MsgWaitForMultipleObjects(1, H, False, INFINITE, QS_SENDMESSAGE) <> WAIT_OBJECT_0 do\r\n begin\r\n PeekMessage(Msg, 0, 0, 0, PM_NOREMOVE);\r\n end;\r\nend;\r\n\r\nprocedure TJvMSTextConversion.WaitUntilThreadReady;\r\nvar\r\n Msg: TMsg;\r\n H: THandle;\r\nbegin\r\n H := FThreadReady.Handle;\r\n\r\n while MsgWaitForMultipleObjects(1, H, False, INFINITE, QS_SENDMESSAGE) <> WAIT_OBJECT_0 do\r\n begin\r\n if PeekMessage(Msg, 0, 0, 0, PM_NOREMOVE) then\r\n Application.HandleMessage;\r\n end;\r\nend;\r\n\r\n//=== { TJvOEMConversion } ===================================================\r\n\r\nfunction TJvOEMConversion.ConvertRead(Buffer: {$IFDEF COMPILER12_UP}PByte{$ELSE}PAnsiChar{$ENDIF COMPILER12_UP};\r\n BufSize: Integer): Integer;\r\nvar\r\n Mem: TMemoryStream;\r\nbegin\r\n Mem := TMemoryStream.Create;\r\n try\r\n Mem.SetSize(BufSize);\r\n Result := inherited ConvertRead({$IFDEF COMPILER12_UP}PByte{$ELSE}PAnsiChar{$ENDIF COMPILER12_UP}(Mem.Memory), BufSize);\r\n OemToCharBuffA(PAnsiChar(Mem.Memory), PAnsiChar(Buffer), Result);\r\n finally\r\n Mem.Free;\r\n end;\r\nend;\r\n\r\nfunction TJvOEMConversion.ConvertWrite(Buffer: {$IFDEF COMPILER12_UP}PByte{$ELSE}PAnsiChar{$ENDIF COMPILER12_UP};\r\n BufSize: Integer): Integer;\r\nvar\r\n Mem: TMemoryStream;\r\nbegin\r\n Mem := TMemoryStream.Create;\r\n try\r\n Mem.SetSize(BufSize);\r\n CharToOemBuffA(PAnsiChar(Buffer), PAnsiChar(Mem.Memory), BufSize);\r\n Result := inherited ConvertWrite({$IFDEF COMPILER12_UP}PByte{$ELSE}PAnsiChar{$ENDIF COMPILER12_UP}(Mem.Memory), BufSize);\r\n finally\r\n Mem.Free;\r\n end;\r\nend;\r\n\r\nfunction TJvOEMConversion.TextKind: TJvConversionTextKind;\r\nbegin\r\n Result := ctkBothPreferRTF;\r\nend;\r\n\r\n//=== { TJvParaAttributes } ==================================================\r\n\r\nconstructor TJvParaAttributes.Create(AOwner: TJvCustomRichEdit);\r\nbegin\r\n inherited Create;\r\n FRichEdit := AOwner;\r\n // FIndentationStyle := isRichEdit; // = 0 so not needed; added by J.G. Boerema\r\nend;\r\n\r\nprocedure TJvParaAttributes.Assign(Source: TPersistent);\r\nvar\r\n I: Integer;\r\n Paragraph: TParaFormat2;\r\nbegin\r\n if Source is TParaAttributes then\r\n begin\r\n Alignment := TParaAlignment(TParaAttributes(Source).Alignment);\r\n FirstIndent := TParaAttributes(Source).FirstIndent;\r\n LeftIndent := TParaAttributes(Source).LeftIndent;\r\n RightIndent := TParaAttributes(Source).RightIndent;\r\n Numbering := TJvNumbering(TParaAttributes(Source).Numbering);\r\n for I := 0 to MAX_TAB_STOPS - 1 do\r\n Tab[I] := TParaAttributes(Source).Tab[I];\r\n end\r\n else\r\n if Source is TJvParaAttributes then\r\n begin\r\n TJvParaAttributes(Source).GetAttributes(Paragraph);\r\n SetAttributes(Paragraph);\r\n end\r\n else\r\n inherited Assign(Source);\r\nend;\r\n\r\nprocedure TJvParaAttributes.AssignTo(Dest: TPersistent);\r\nvar\r\n I: Integer;\r\nbegin\r\n if Dest is TParaAttributes then\r\n begin\r\n with TParaAttributes(Dest) do\r\n begin\r\n if Self.Alignment = paJustify then\r\n Alignment := taLeftJustify\r\n else\r\n Alignment := TAlignment(Self.Alignment);\r\n FirstIndent := Self.FirstIndent;\r\n LeftIndent := Self.LeftIndent;\r\n RightIndent := Self.RightIndent;\r\n if Self.Numbering <> nsNone then\r\n Numbering := TNumberingStyle(nsBullet)\r\n else\r\n Numbering := TNumberingStyle(nsNone);\r\n for I := 0 to MAX_TAB_STOPS - 1 do\r\n Tab[I] := Self.Tab[I];\r\n end;\r\n end\r\n else\r\n inherited AssignTo(Dest);\r\nend;\r\n\r\nfunction TJvParaAttributes.GetAlignment: TParaAlignment;\r\nvar\r\n Paragraph: TParaFormat2;\r\nbegin\r\n GetAttributes(Paragraph);\r\n Result := TParaAlignment(Paragraph.wAlignment - 1);\r\nend;\r\n\r\nprocedure TJvParaAttributes.GetAttributes(var Paragraph: TParaFormat2);\r\nbegin\r\n InitPara(Paragraph);\r\n if FRichEdit.HandleAllocated then\r\n SendMessage(FRichEdit.Handle, EM_GETPARAFORMAT, 0, LPARAM(@Paragraph));\r\nend;\r\n\r\nfunction TJvParaAttributes.GetFirstIndent: Longint;\r\nvar\r\n Paragraph: TParaFormat2;\r\nbegin\r\n GetAttributes(Paragraph);\r\n if IndentationStyle = isRichEdit then\r\n Result := Paragraph.dxStartIndent div CTwipsPerPoint\r\n else // isOffice\r\n Result := -Paragraph.dxOffset div CTwipsPerPoint;\r\nend;\r\n\r\nfunction TJvParaAttributes.GetHeadingStyle: THeadingStyle;\r\nvar\r\n Paragraph: TParaFormat2;\r\nbegin\r\n if RichEditVersion < 3 then\r\n Result := 0\r\n else\r\n begin\r\n { See MSDN, ITextPara.GetStyle documentation:\r\n\r\n -1 : StyleNormal\r\n -2 : StyleHeading1\r\n -3 : StyleHeading2\r\n ..\r\n -10 : StyleHeading9\r\n\r\n }\r\n GetAttributes(Paragraph);\r\n Paragraph.sStyle := -(Paragraph.sStyle + 1);\r\n if (Paragraph.sStyle >= Low(THeadingStyle)) and (Paragraph.sStyle <= High(THeadingStyle)) then\r\n Result := THeadingStyle(Paragraph.sStyle)\r\n else\r\n Result := 0;\r\n end;\r\nend;\r\n\r\nfunction TJvParaAttributes.GetLeftIndent: Longint;\r\nvar\r\n Paragraph: TParaFormat2;\r\nbegin\r\n GetAttributes(Paragraph);\r\n if IndentationStyle = isRichEdit then\r\n Result := Paragraph.dxOffset div CTwipsPerPoint\r\n else // isOffice\r\n Result := (Paragraph.dxStartIndent + Paragraph.dxOffset) div CTwipsPerPoint;\r\nend;\r\n\r\nfunction TJvParaAttributes.GetLineSpacing: Longint;\r\nvar\r\n Paragraph: TParaFormat2;\r\nbegin\r\n GetAttributes(Paragraph);\r\n Result := Paragraph.dyLineSpacing div CTwipsPerPoint;\r\nend;\r\n\r\nfunction TJvParaAttributes.GetLineSpacingRule: TLineSpacingRule;\r\nvar\r\n Paragraph: TParaFormat2;\r\nbegin\r\n GetAttributes(Paragraph);\r\n Result := TLineSpacingRule(Paragraph.bLineSpacingRule);\r\nend;\r\n\r\nfunction TJvParaAttributes.GetNumbering: TJvNumbering;\r\nvar\r\n Paragraph: TParaFormat2;\r\nbegin\r\n GetAttributes(Paragraph);\r\n Result := TJvNumbering(Paragraph.wNumbering);\r\n if RichEditVersion = 1 then\r\n if Result <> nsNone then\r\n Result := nsBullet;\r\nend;\r\n\r\nfunction TJvParaAttributes.GetNumberingStart: Integer;\r\nvar\r\n Paragraph: TParaFormat2;\r\nbegin\r\n GetAttributes(Paragraph);\r\n Result := Paragraph.wNumberingStart;\r\nend;\r\n\r\nfunction TJvParaAttributes.GetNumberingStyle: TJvNumberingStyle;\r\nvar\r\n Paragraph: TParaFormat2;\r\nbegin\r\n if RichEditVersion < 2 then\r\n Result := nsSimple\r\n else\r\n begin\r\n GetAttributes(Paragraph);\r\n case Paragraph.wNumberingStyle of\r\n PFNS_PERIOD: Result := nsPeriod;\r\n PFNS_PARENS: Result := nsEnclosed;\r\n PFNS_PLAIN: Result := nsSimple;\r\n else\r\n Result := nsParenthesis;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJvParaAttributes.GetNumberingTab: Word;\r\nvar\r\n Paragraph: TParaFormat2;\r\nbegin\r\n GetAttributes(Paragraph);\r\n Result := Paragraph.wNumberingTab div CTwipsPerPoint;\r\nend;\r\n\r\nfunction TJvParaAttributes.GetRightIndent: Longint;\r\nvar\r\n Paragraph: TParaFormat2;\r\nbegin\r\n GetAttributes(Paragraph);\r\n Result := Paragraph.dxRightIndent div CTwipsPerPoint;\r\nend;\r\n\r\nfunction TJvParaAttributes.GetSpaceAfter: Longint;\r\nvar\r\n Paragraph: TParaFormat2;\r\nbegin\r\n GetAttributes(Paragraph);\r\n Result := Paragraph.dySpaceAfter div CTwipsPerPoint;\r\nend;\r\n\r\nfunction TJvParaAttributes.GetSpaceBefore: Longint;\r\nvar\r\n Paragraph: TParaFormat2;\r\nbegin\r\n GetAttributes(Paragraph);\r\n Result := Paragraph.dySpaceBefore div CTwipsPerPoint;\r\nend;\r\n\r\nfunction TJvParaAttributes.GetTab(Index: Byte): Longint;\r\nvar\r\n Paragraph: TParaFormat2;\r\nbegin\r\n GetAttributes(Paragraph);\r\n Result := (Paragraph.rgxTabs[Index] and TA_TAB) div CTwipsPerPoint;\r\nend;\r\n\r\nfunction TJvParaAttributes.GetTabAlignment(Index: Byte): TJvTabAlignment;\r\nvar\r\n Paragraph: TParaFormat2;\r\n Temp: Integer;\r\nbegin\r\n if Index >= MAX_TAB_STOPS - 1 then\r\n begin\r\n Result := TJvTabAlignment(0);\r\n Exit;\r\n end;\r\n GetAttributes(Paragraph);\r\n {Result := TJvTabAlignment((Paragraph.rgxTabs[Index] and TA_ALIGNMENT) shr 24);}\r\n // D6 doesnt want to do it in one step so:\r\n Temp := (Paragraph.rgxTabs[Index] and TA_ALIGNMENT) shr 24;\r\n Result := TJvTabAlignment(Temp);\r\nend;\r\n\r\nfunction TJvParaAttributes.GetTabCount: Integer;\r\nvar\r\n Paragraph: TParaFormat2;\r\nbegin\r\n GetAttributes(Paragraph);\r\n Result := Paragraph.cTabCount;\r\nend;\r\n\r\nfunction TJvParaAttributes.GetTabLeader(Index: Byte): TJvTabLeader;\r\nvar\r\n Paragraph: TParaFormat2;\r\n Temp: Integer;\r\nbegin\r\n if Index >= MAX_TAB_STOPS - 1 then\r\n begin\r\n Result := TJvTabLeader(0);\r\n Exit;\r\n end;\r\n GetAttributes(Paragraph);\r\n {Result := TJvTabAlignment((Paragraph.rgxTabs[Index] and TA_LEADER) shr 28);}\r\n // D6 doesnt want to do it in one step so:\r\n // Note: and TA_LEADER not necessary: those bits get shifted out anyway\r\n Temp := (Paragraph.rgxTabs[Index] {and TA_LEADER}) shr 28;\r\n Result := TJvTabLeader(Temp);\r\nend;\r\n\r\nfunction TJvParaAttributes.GetTableStyle: TParaTableStyle;\r\nvar\r\n Paragraph: TParaFormat2;\r\nbegin\r\n Result := tsNone;\r\n if RichEditVersion < 2 then\r\n Exit;\r\n GetAttributes(Paragraph);\r\n with Paragraph do\r\n begin\r\n if (wReserved and PFE_TABLEROW) <> 0 then\r\n Result := tsTableRow\r\n else\r\n if (wReserved and PFE_TABLECELLEND) <> 0 then\r\n Result := tsTableCellEnd\r\n else\r\n if (wReserved and PFE_TABLECELL) <> 0 then\r\n Result := tsTableCell;\r\n end;\r\nend;\r\n\r\nprocedure TJvParaAttributes.InitPara(var Paragraph: TParaFormat2);\r\nbegin\r\n FillChar(Paragraph, SizeOf(Paragraph), 0);\r\n if RichEditVersion >= 2 then\r\n Paragraph.cbSize := SizeOf(Paragraph)\r\n else\r\n Paragraph.cbSize := SizeOf(TParaFormat);\r\nend;\r\n\r\nprocedure TJvParaAttributes.SetAlignment(Value: TParaAlignment);\r\nvar\r\n Paragraph: TParaFormat2;\r\nbegin\r\n InitPara(Paragraph);\r\n if Value = paJustify then\r\n FRichEdit.NeedAdvancedTypography;\r\n with Paragraph do\r\n begin\r\n dwMask := PFM_ALIGNMENT;\r\n wAlignment := Ord(Value) + 1;\r\n end;\r\n SetAttributes(Paragraph);\r\nend;\r\n\r\nprocedure TJvParaAttributes.SetAttributes(var Paragraph: TParaFormat2);\r\nbegin\r\n FRichEdit.HandleNeeded; { we REALLY need the handle for BiDi }\r\n if FRichEdit.HandleAllocated then\r\n begin\r\n if FRichEdit.UseRightToLeftAlignment then\r\n if Paragraph.wAlignment = PFA_LEFT then\r\n Paragraph.wAlignment := PFA_RIGHT\r\n else\r\n if Paragraph.wAlignment = PFA_RIGHT then\r\n Paragraph.wAlignment := PFA_LEFT;\r\n SendMessage(FRichEdit.Handle, EM_SETPARAFORMAT, 0, LPARAM(@Paragraph));\r\n end;\r\nend;\r\n\r\nprocedure TJvParaAttributes.SetFirstIndent(Value: Longint);\r\nvar\r\n Paragraph: TParaFormat2;\r\nbegin\r\n InitPara(Paragraph);\r\n with Paragraph do\r\n begin\r\n if IndentationStyle = isRichEdit then\r\n begin\r\n dwMask := PFM_STARTINDENT;\r\n dxStartIndent := Value * CTwipsPerPoint;\r\n end\r\n else // isOffice\r\n begin\r\n dwMask := PFM_STARTINDENT + PFM_OFFSET;\r\n dxStartIndent := (Value + LeftIndent) * CTwipsPerPoint;\r\n dxOffset := (LeftIndent * CTwipsPerPoint) - dxStartIndent;\r\n end;\r\n end;\r\n SetAttributes(Paragraph);\r\nend;\r\n\r\nprocedure TJvParaAttributes.SetHeadingStyle(Value: THeadingStyle);\r\nvar\r\n Paragraph: TParaFormat2;\r\nbegin\r\n if RichEditVersion < 3 then\r\n Exit;\r\n InitPara(Paragraph);\r\n with Paragraph do\r\n begin\r\n dwMask := PFM_STYLE;\r\n sStyle := -Value - 1;\r\n end;\r\n SetAttributes(Paragraph);\r\nend;\r\n\r\nprocedure TJvParaAttributes.SetLeftIndent(Value: Longint);\r\nvar\r\n Paragraph: TParaFormat2;\r\nbegin\r\n InitPara(Paragraph);\r\n with Paragraph do\r\n begin\r\n if IndentationStyle = isRichEdit then\r\n begin\r\n dwMask := PFM_OFFSET;\r\n dxOffset := Value * CTwipsPerPoint;\r\n end\r\n else // isOffice\r\n begin\r\n dwMask := PFM_STARTINDENT + PFM_OFFSET;\r\n dxStartIndent := (FirstIndent + Value) * CTwipsPerPoint;\r\n dxOffset := (Value * CTwipsPerPoint) - dxStartIndent;\r\n end;\r\n end;\r\n SetAttributes(Paragraph);\r\nend;\r\n\r\nprocedure TJvParaAttributes.SetLineSpacing(Value: Longint);\r\nvar\r\n Paragraph: TParaFormat2;\r\nbegin\r\n if RichEditVersion < 2 then\r\n Exit;\r\n GetAttributes(Paragraph);\r\n with Paragraph do\r\n begin\r\n dwMask := PFM_LINESPACING;\r\n dyLineSpacing := Value * CTwipsPerPoint;\r\n end;\r\n SetAttributes(Paragraph);\r\nend;\r\n\r\nprocedure TJvParaAttributes.SetLineSpacingRule(Value: TLineSpacingRule);\r\nvar\r\n Paragraph: TParaFormat2;\r\nbegin\r\n if RichEditVersion < 2 then\r\n Exit;\r\n GetAttributes(Paragraph);\r\n with Paragraph do\r\n begin\r\n dwMask := PFM_LINESPACING;\r\n bLineSpacingRule := Ord(Value);\r\n end;\r\n SetAttributes(Paragraph);\r\nend;\r\n\r\nprocedure TJvParaAttributes.SetNumbering(Value: TJvNumbering);\r\nvar\r\n Paragraph: TParaFormat2;\r\nbegin\r\n if RichEditVersion = 1 then\r\n if Value <> nsNone then\r\n Value := TJvNumbering(PFN_BULLET);\r\n case Value of\r\n nsNone:\r\n LeftIndent := 0;\r\n else\r\n if LeftIndent < 10 then\r\n LeftIndent := 10;\r\n end;\r\n InitPara(Paragraph);\r\n with Paragraph do\r\n begin\r\n dwMask := PFM_NUMBERING;\r\n wNumbering := Ord(Value);\r\n end;\r\n SetAttributes(Paragraph);\r\nend;\r\n\r\nprocedure TJvParaAttributes.SetNumberingStart(const Value: Integer);\r\nvar\r\n Paragraph: TParaFormat2;\r\nbegin\r\n InitPara(Paragraph);\r\n with Paragraph do\r\n begin\r\n dwMask := PFM_NUMBERINGSTART;\r\n wNumberingStart := Value\r\n end;\r\n SetAttributes(Paragraph);\r\nend;\r\n\r\nprocedure TJvParaAttributes.SetNumberingStyle(Value: TJvNumberingStyle);\r\nconst\r\n CNumberingStyle: array[TJvNumberingStyle] of Word = (PFNS_PAREN, PFNS_PERIOD, PFNS_PARENS, PFNS_PLAIN);\r\nvar\r\n Paragraph: TParaFormat2;\r\nbegin\r\n if RichEditVersion < 2 then\r\n Exit;\r\n InitPara(Paragraph);\r\n with Paragraph do\r\n begin\r\n dwMask := PFM_NUMBERINGSTYLE;\r\n wNumberingStyle := CNumberingStyle[Value];\r\n end;\r\n SetAttributes(Paragraph);\r\nend;\r\n\r\nprocedure TJvParaAttributes.SetNumberingTab(Value: Word);\r\nvar\r\n Paragraph: TParaFormat2;\r\nbegin\r\n if RichEditVersion < 2 then\r\n Exit;\r\n InitPara(Paragraph);\r\n with Paragraph do\r\n begin\r\n dwMask := PFM_NUMBERINGTAB;\r\n wNumberingTab := Value * CTwipsPerPoint;\r\n end;\r\n SetAttributes(Paragraph);\r\nend;\r\n\r\nprocedure TJvParaAttributes.SetRightIndent(Value: Longint);\r\nvar\r\n Paragraph: TParaFormat2;\r\nbegin\r\n InitPara(Paragraph);\r\n with Paragraph do\r\n begin\r\n dwMask := PFM_RIGHTINDENT;\r\n dxRightIndent := Value * CTwipsPerPoint;\r\n end;\r\n SetAttributes(Paragraph);\r\nend;\r\n\r\nprocedure TJvParaAttributes.SetSpaceAfter(Value: Longint);\r\nvar\r\n Paragraph: TParaFormat2;\r\nbegin\r\n if RichEditVersion < 2 then\r\n Exit;\r\n InitPara(Paragraph);\r\n with Paragraph do\r\n begin\r\n dwMask := PFM_SPACEAFTER;\r\n dySpaceAfter := Value * CTwipsPerPoint;\r\n end;\r\n SetAttributes(Paragraph);\r\nend;\r\n\r\nprocedure TJvParaAttributes.SetSpaceBefore(Value: Longint);\r\nvar\r\n Paragraph: TParaFormat2;\r\nbegin\r\n if RichEditVersion < 2 then\r\n Exit;\r\n InitPara(Paragraph);\r\n with Paragraph do\r\n begin\r\n dwMask := PFM_SPACEBEFORE;\r\n dySpaceBefore := Value * CTwipsPerPoint;\r\n end;\r\n SetAttributes(Paragraph);\r\nend;\r\n\r\nprocedure TJvParaAttributes.SetTab(Index: Byte; Value: Longint);\r\nvar\r\n Paragraph: TParaFormat2;\r\nbegin\r\n // Added a check for max tab (J.G. Boerema)\r\n if Index >= MAX_TAB_STOPS - 1 then\r\n Exit;\r\n GetAttributes(Paragraph);\r\n with Paragraph do\r\n begin\r\n // Note: the first part is a bugfix\r\n if cTabCount <= Index then\r\n begin\r\n cTabCount := Index + 1;\r\n rgxTabs[Index] := 0; // is this necessary?\r\n end;\r\n // Replace the TAB value with the new one but\r\n // remember the alignment and leader values\r\n rgxTabs[Index] := (rgxTabs[Index] and\r\n Longint(TA_ALIGNMENT or TA_LEADER)) or (Value * CTwipsPerPoint);\r\n dwMask := PFM_TABSTOPS;\r\n SetAttributes(Paragraph);\r\n end;\r\nend;\r\n\r\nprocedure TJvParaAttributes.SetTabAlignment(Index: Byte; Value: TJvTabAlignment);\r\nvar\r\n Paragraph: TParaFormat2;\r\nbegin\r\n if RichEditVersion < 2 then\r\n Exit;\r\n if Index >= MAX_TAB_STOPS - 1 then\r\n Exit;\r\n if Value <> taOrdinary then\r\n FRichEdit.NeedAdvancedTypography;\r\n\r\n GetAttributes(Paragraph);\r\n with Paragraph do\r\n begin\r\n if cTabCount <= Index then\r\n begin\r\n cTabCount := Index + 1;\r\n rgxTabs[Index] := 0; // is this necessary?\r\n end;\r\n // Replace the old alignment value with the new one but\r\n // remember the tab and leader values\r\n rgxTabs[Index] := Longint(rgxTabs[Index] and TA_TAB_LEADER) or (Ord(Value) shl 24);\r\n dwMask := PFM_TABSTOPS;\r\n SetAttributes(Paragraph);\r\n end;\r\nend;\r\n\r\nprocedure TJvParaAttributes.SetTabCount(Value: Integer);\r\nvar\r\n Paragraph: TParaFormat2;\r\nbegin\r\n GetAttributes(Paragraph);\r\n with Paragraph do\r\n begin\r\n dwMask := PFM_TABSTOPS;\r\n cTabCount := Value;\r\n SetAttributes(Paragraph);\r\n end;\r\nend;\r\n\r\nprocedure TJvParaAttributes.SetTabLeader(Index: Byte; Value: TJvTabLeader);\r\nvar\r\n Paragraph: TParaFormat2;\r\nbegin\r\n if RichEditVersion < 2 then\r\n Exit;\r\n if Index >= MAX_TAB_STOPS - 1 then\r\n Exit;\r\n if Value <> tlNone then\r\n FRichEdit.NeedAdvancedTypography;\r\n\r\n GetAttributes(Paragraph);\r\n with Paragraph do\r\n begin\r\n if cTabCount <= Index then\r\n begin\r\n cTabCount := Index + 1;\r\n rgxTabs[Index] := 0; // is this necessary?\r\n end;\r\n // Replace the old leader value with the new one but\r\n // remember the tab and alignment values\r\n rgxTabs[Index] := (rgxTabs[Index] and TA_TAB_ALIGNMENT) or (Ord(Value) shl 28);\r\n dwMask := PFM_TABSTOPS;\r\n SetAttributes(Paragraph);\r\n end;\r\nend;\r\n\r\nprocedure TJvParaAttributes.SetTableStyle(Value: TParaTableStyle);\r\nvar\r\n Paragraph: TParaFormat2;\r\nbegin\r\n if RichEditVersion < 2 then\r\n Exit;\r\n InitPara(Paragraph);\r\n with Paragraph do\r\n begin\r\n dwMask := PFM_TABLE;\r\n case Value of\r\n tsTableRow:\r\n wReserved := PFE_TABLEROW;\r\n tsTableCellEnd:\r\n wReserved := PFE_TABLECELLEND;\r\n tsTableCell:\r\n wReserved := PFE_TABLECELL;\r\n end;\r\n end;\r\n SetAttributes(Paragraph);\r\nend;\r\n\r\n//=== { TJvRichEditState } ===================================================\r\n\r\nconstructor TJvRichEditState.Create;\r\nbegin\r\n inherited Create;\r\n FStream := TMemoryStream.Create;\r\nend;\r\n\r\ndestructor TJvRichEditState.Destroy;\r\nbegin\r\n FStream.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvRichEditState.Restore(RichEdit: TJvCustomRichEdit);\r\nbegin\r\n TJvRichEditStrings(RichEdit.Lines).Format := FStreamFormat;\r\n TJvRichEditStrings(RichEdit.Lines).Mode := FStreamMode;\r\n\r\n FStream.Position := 0;\r\n RichEdit.Lines.LoadFromStream(FStream);\r\n\r\n TJvRichEditStrings(RichEdit.Lines).Format := FOrigFormat;\r\n TJvRichEditStrings(RichEdit.Lines).Mode := FOrigMode;\r\n\r\n RichEdit.SelStart := FSelStart;\r\n RichEdit.SelLength := FSelLength;\r\n RichEdit.Modified := FModified;\r\nend;\r\n\r\nprocedure TJvRichEditState.Store(RichEdit: TJvCustomRichEdit);\r\nbegin\r\n FModified := RichEdit.Modified;\r\n\r\n FSelStart := RichEdit.SelStart;\r\n FSelLength := RichEdit.SelLength;\r\n\r\n FOrigFormat := TJvRichEditStrings(RichEdit.Lines).Format;\r\n FOrigMode := TJvRichEditStrings(RichEdit.Lines).Mode;\r\n\r\n if RichEdit.PlainText or ForcePlainText then\r\n TJvRichEditStrings(RichEdit.Lines).Format := sfPlainText\r\n else\r\n TJvRichEditStrings(RichEdit.Lines).Format := sfRichText;\r\n TJvRichEditStrings(RichEdit.Lines).Mode := [smUnicode];\r\n\r\n FStreamFormat := TJvRichEditStrings(RichEdit.Lines).Format;\r\n FStreamMode := TJvRichEditStrings(RichEdit.Lines).Mode;\r\n\r\n RichEdit.Lines.SaveToStream(FStream);\r\n\r\n TJvRichEditStrings(RichEdit.Lines).Format := FOrigFormat;\r\n TJvRichEditStrings(RichEdit.Lines).Mode := FOrigMode;\r\nend;\r\n\r\n//=== { TJvRichEditStrings } =================================================\r\n\r\nprocedure TJvRichEditStrings.AddStrings(Strings: TStrings);\r\nvar\r\n SelChange: TNotifyEvent;\r\nbegin\r\n SelChange := FRichEdit.OnSelectionChange;\r\n FRichEdit.OnSelectionChange := nil;\r\n try\r\n inherited AddStrings(Strings);\r\n finally\r\n FRichEdit.OnSelectionChange := SelChange;\r\n end;\r\nend;\r\n\r\nprocedure TJvRichEditStrings.Clear;\r\nbegin\r\n FRichEdit.Clear;\r\nend;\r\n\r\nprocedure TJvRichEditStrings.Delete(Index: Integer);\r\nconst\r\n Empty: PChar = '';\r\nvar\r\n Selection: TCharRange;\r\nbegin\r\n if Index < 0 then\r\n Exit;\r\n Selection.cpMin := FRichEdit.GetLineIndex(Index);\r\n if Selection.cpMin <> -1 then\r\n begin\r\n Selection.cpMax := FRichEdit.GetLineIndex(Index + 1);\r\n if Selection.cpMax = -1 then\r\n Selection.cpMax := Selection.cpMin +\r\n FRichEdit.GetLineLength(Selection.cpMin);\r\n SendMessage(FRichEdit.Handle, EM_EXSETSEL, 0, LPARAM(@Selection));\r\n FRichEdit.FLinesUpdating := True;\r\n try\r\n SendMessage(FRichEdit.Handle, EM_REPLACESEL, 0, LPARAM(Empty));\r\n finally\r\n FRichEdit.FLinesUpdating := False;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvRichEditStrings.DoExport(AConverter: TJvConversion);\r\nvar\r\n EditStream: TEditStream;\r\n TextType: Longint;\r\nbegin\r\n with EditStream do\r\n begin\r\n dwCookie := Longint(AConverter);\r\n pfnCallBack := StreamSave;\r\n dwError := 0;\r\n end;\r\n case FFormat of\r\n sfDefault:\r\n if FRichEdit.PlainText then\r\n TextType := SF_TEXT\r\n else\r\n TextType := SF_RTF;\r\n sfRichText:\r\n TextType := SF_RTF;\r\n else {sfPlainText}\r\n TextType := SF_TEXT;\r\n end;\r\n if TextType = SF_RTF then\r\n begin\r\n if smNoObjects in Mode then\r\n TextType := SF_RTFNOOBJS;\r\n if smPlainRtf in Mode then\r\n TextType := TextType or SFF_PLAINRTF;\r\n end\r\n else\r\n if TextType = SF_TEXT then\r\n begin\r\n if (smUnicode in Mode) and (RichEditVersion > 1) then\r\n TextType := TextType or SF_UNICODE;\r\n end;\r\n if smSelection in Mode then\r\n TextType := TextType or SFF_SELECTION;\r\n SendMessage(FRichEdit.Handle, EM_STREAMOUT, TextType, LPARAM(@EditStream));\r\n\r\n if not AConverter.UserCancel then\r\n begin\r\n if AConverter.Error then\r\n raise EOutOfResources.Create(AConverter.ErrorStr)\r\n else\r\n if EditStream.dwError <> 0 then\r\n raise EOutOfResources.CreateRes(@sRichEditSaveFail);\r\n end;\r\nend;\r\n\r\nprocedure TJvRichEditStrings.DoImport(AConverter: TJvConversion);\r\nvar\r\n EditStream: TEditStream;\r\n TextType: Longint;\r\n Cookie: TCookie;\r\nbegin\r\n Cookie := TCookie.Create(AConverter);\r\n try\r\n with EditStream do\r\n begin\r\n dwCookie := Longint(Cookie);\r\n pfnCallBack := StreamLoad;\r\n dwError := 0;\r\n end;\r\n case FFormat of\r\n sfDefault:\r\n if FRichEdit.PlainText then\r\n TextType := SF_TEXT\r\n else\r\n TextType := SF_RTF;\r\n sfRichText:\r\n TextType := SF_RTF;\r\n else {sfPlainText}\r\n TextType := SF_TEXT;\r\n end;\r\n if TextType = SF_RTF then\r\n begin\r\n if smPlainRtf in Mode then\r\n TextType := TextType or SFF_PLAINRTF;\r\n end;\r\n if TextType = SF_TEXT then\r\n begin\r\n if (smUnicode in Mode) and (RichEditVersion > 1) then\r\n begin\r\n TextType := TextType or SF_UNICODE;\r\n EditStream.pfnCallback := StreamLoadW;\r\n end;\r\n end;\r\n if smSelection in Mode then\r\n TextType := TextType or SFF_SELECTION;\r\n SendMessage(FRichEdit.Handle, EM_STREAMIN, TextType, LPARAM(@EditStream));\r\n\r\n if not AConverter.UserCancel then\r\n begin\r\n if (EditStream.dwError <> 0) and AConverter.Retry then\r\n begin\r\n if (TextType and SF_RTF) = SF_RTF then\r\n begin\r\n TextType := SF_TEXT;\r\n if (smUnicode in Mode) and (RichEditVersion > 1) then\r\n begin\r\n TextType := TextType or SF_UNICODE;\r\n EditStream.pfnCallback := StreamLoadW;\r\n end;\r\n end\r\n else\r\n begin\r\n TextType := SF_RTF;\r\n if smPlainRtf in Mode then\r\n TextType := TextType or SFF_PLAINRTF;\r\n EditStream.pfnCallback := StreamLoad;\r\n end;\r\n SendMessage(FRichEdit.Handle, EM_STREAMIN, TextType, LPARAM(@EditStream));\r\n end;\r\n\r\n if AConverter.Error then\r\n raise EOutOfResources.Create(AConverter.ErrorStr)\r\n else\r\n if EditStream.dwError <> 0 then\r\n raise EOutOfResources.CreateRes(@sRichEditLoadFail);\r\n end;\r\n\r\n if not (smSelection in Mode) then // Mantis 2591: do not change the selection if there is one\r\n FRichEdit.SetSelection(0, 0, True);\r\n finally\r\n Cookie.Free;\r\n end;\r\nend;\r\n\r\nprocedure TJvRichEditStrings.EnableChange(const Value: Boolean);\r\nvar\r\n EventMask: LPARAM;\r\nbegin\r\n with FRichEdit do\r\n begin\r\n EventMask := SendMessage(Handle, EM_GETEVENTMASK, 0, 0);\r\n if Value then\r\n EventMask := EventMask or ENM_CHANGE\r\n else\r\n EventMask := EventMask and not ENM_CHANGE;\r\n SendMessage(Handle, EM_SETEVENTMASK, 0, EventMask);\r\n end;\r\nend;\r\n\r\nfunction TJvRichEditStrings.Get(Index: Integer): string;\r\nvar\r\n L: Integer;\r\nbegin\r\n L := FRichEdit.GetLineLength(FRichEdit.GetLineIndex(Index));\r\n SetLength(Result, L);\r\n if L > 0 then\r\n begin\r\n PWord(Pointer(Result))^ := L;\r\n L := SendMessage(FRichEdit.Handle, EM_GETLINE, Index, LPARAM(Pointer(Result)));\r\n if (Result[L - 2] = Cr) and (Result[L - 1] = Lf) then\r\n SetLength(Result, L - 2)\r\n else\r\n if (RichEditVersion >= 2) and (Result[L - 1] = Cr) then\r\n SetLength(Result, L - 1);\r\n end;\r\nend;\r\n\r\nfunction TJvRichEditStrings.GetCount: Integer;\r\nbegin\r\n with FRichEdit do\r\n begin\r\n Result := SendMessage(Handle, EM_GETLINECOUNT, 0, 0);\r\n if GetLineLength(GetLineIndex(Result - 1)) = 0 then\r\n Dec(Result);\r\n end;\r\nend;\r\n\r\nprocedure TJvRichEditStrings.Insert(Index: Integer; const S: string);\r\nvar\r\n L: Integer;\r\n Selection: TCharRange;\r\n Fmt: PChar;\r\n Str: string;\r\nbegin\r\n if Index >= 0 then\r\n begin\r\n Selection.cpMin := FRichEdit.GetLineIndex(Index);\r\n if Selection.cpMin >= 0 then\r\n begin\r\n if RichEditVersion = 1 then\r\n Fmt := '%s' + sLineBreak\r\n else\r\n Fmt := '%s' + Cr;\r\n end\r\n else\r\n begin\r\n Selection.cpMin := FRichEdit.GetLineIndex(Index - 1);\r\n if Selection.cpMin < 0 then\r\n begin\r\n Selection.cpMin :=\r\n SendMessage(FRichEdit.Handle, EM_LINEINDEX, Index - 1, 0);\r\n if Selection.cpMin < 0 then\r\n Exit;\r\n L := SendMessage(FRichEdit.Handle, EM_LINELENGTH, Selection.cpMin, 0);\r\n if L = 0 then\r\n Exit;\r\n Inc(Selection.cpMin, L);\r\n if RichEditVersion = 1 then\r\n Fmt := sLineBreak + '%s'\r\n else\r\n Fmt := Cr + '%s';\r\n end\r\n else\r\n begin\r\n L := FRichEdit.GetLineLength(Selection.cpMin);\r\n if L = 0 then\r\n Exit;\r\n Inc(Selection.cpMin, L);\r\n if RichEditVersion = 1 then\r\n Fmt := '%s' + sLineBreak\r\n else\r\n Fmt := '%s' + Cr;\r\n end;\r\n end;\r\n Selection.cpMax := Selection.cpMin;\r\n SendMessage(FRichEdit.Handle, EM_EXSETSEL, 0, LPARAM(@Selection));\r\n Str := SysUtils.Format(Fmt, [S]);\r\n FRichEdit.FLinesUpdating := True;\r\n try\r\n SendMessage(FRichEdit.Handle, EM_REPLACESEL, 0, LPARAM(PChar(Str)));\r\n finally\r\n FRichEdit.FLinesUpdating := False;\r\n end;\r\n if RichEditVersion = 1 then\r\n if FRichEdit.SelStart <> (Selection.cpMax + Length(Str)) then\r\n raise EOutOfResources.CreateRes(@sRichEditInsertError);\r\n end;\r\nend;\r\n\r\nprocedure TJvRichEditStrings.LoadFromFile(const FileName: string);\r\nvar\r\n SaveFormat: TRichStreamFormat;\r\n Converter: TJvConversion;\r\nbegin\r\n Converter := FRichEdit.GetConverter(FileName, ckImport);\r\n try\r\n Converter.OnProgress := ProgressCallback;\r\n SaveFormat := Format;\r\n try\r\n if FRichEdit.PlainText then\r\n { When PlainText is set, the control does not accept RTF }\r\n FFormat := sfPlainText\r\n else\r\n if FFormat = sfDefault then\r\n case Converter.TextKind of\r\n ctkText, ctkBothPreferText:\r\n FFormat := sfPlainText;\r\n ctkRTF, ctkBothPreferRTF:\r\n FFormat := sfRichText;\r\n end;\r\n\r\n if not Converter.Open(FileName, ckImport) then\r\n raise EOutOfResources.CreateRes(@sRichEditLoadFail);\r\n\r\n DoImport(Converter);\r\n finally\r\n FFormat := SaveFormat;\r\n end;\r\n finally\r\n Converter.Done;\r\n Converter.OnProgress := nil;\r\n end;\r\nend;\r\n\r\nprocedure TJvRichEditStrings.LoadFromStream(Stream: TStream);\r\nvar\r\n SaveFormat: TRichStreamFormat;\r\n Converter: TJvConversion;\r\nbegin\r\n FRichEdit.HandleNeeded;\r\n // HandleNeeded raises an error if unsuccessful, so no if HandleAllocated\r\n // check needed..\r\n Converter := FRichEdit.GetConverter(Stream, ckImport);\r\n try\r\n Converter.OnProgress := ProgressCallback;\r\n SaveFormat := Format;\r\n try\r\n if FRichEdit.PlainText then\r\n { When PlainText is set, the control does not accept RTF }\r\n FFormat := sfPlainText\r\n else\r\n if FFormat = sfDefault then\r\n case Converter.TextKind of\r\n ctkText, ctkBothPreferText:\r\n FFormat := sfPlainText;\r\n ctkRTF, ctkBothPreferRTF:\r\n FFormat := sfRichText;\r\n end;\r\n\r\n if not Converter.Open(Stream, ckImport) then\r\n raise EOutOfResources.CreateRes(@sRichEditLoadFail);\r\n\r\n DoImport(Converter)\r\n finally\r\n FFormat := SaveFormat;\r\n end;\r\n finally\r\n Converter.Done;\r\n Converter.OnProgress := nil;\r\n end;\r\nend;\r\n\r\nprocedure TJvRichEditStrings.ProgressCallback(Sender: TObject);\r\nbegin\r\n if Sender is TJvConversion then\r\n FRichEdit.DoConversionProgress(TJvConversion(Sender).PercentDone);\r\nend;\r\n\r\nprocedure TJvRichEditStrings.Put(Index: Integer; const S: string);\r\nvar\r\n Selection: TCharRange;\r\nbegin\r\n if Index >= 0 then\r\n begin\r\n Selection.cpMin := FRichEdit.GetLineIndex(Index);\r\n if Selection.cpMin <> -1 then\r\n begin\r\n Selection.cpMax := Selection.cpMin +\r\n FRichEdit.GetLineLength(Selection.cpMin);\r\n SendMessage(FRichEdit.Handle, EM_EXSETSEL, 0, LPARAM(@Selection));\r\n FRichEdit.FLinesUpdating := True;\r\n try\r\n SendMessage(FRichEdit.Handle, EM_REPLACESEL, 0, LPARAM(PChar(S)));\r\n finally\r\n FRichEdit.FLinesUpdating := False;\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvRichEditStrings.SaveToFile(const FileName: string);\r\nvar\r\n SaveFormat: TRichStreamFormat;\r\n Converter: TJvConversion;\r\nbegin\r\n FRichEdit.HandleNeeded;\r\n Converter := FRichEdit.GetConverter(FileName, ckExport);\r\n try\r\n Converter.OnProgress := ProgressCallback;\r\n SaveFormat := Format;\r\n try\r\n if FRichEdit.PlainText then\r\n { When PlainText is set, the control does not accept RTF }\r\n FFormat := sfPlainText\r\n else\r\n if FFormat = sfDefault then\r\n case Converter.TextKind of\r\n ctkText, ctkBothPreferText:\r\n FFormat := sfPlainText;\r\n ctkRTF, ctkBothPreferRTF:\r\n FFormat := sfRichText;\r\n end;\r\n\r\n if not Converter.Open(FileName, ckExport) then\r\n raise EOutOfResources.CreateRes(@sRichEditSaveFail);\r\n\r\n DoExport(Converter)\r\n finally\r\n FFormat := SaveFormat;\r\n end;\r\n finally\r\n Converter.Done;\r\n Converter.OnProgress := nil;\r\n end;\r\nend;\r\n\r\nprocedure TJvRichEditStrings.SaveToStream(Stream: TStream);\r\nvar\r\n SaveFormat: TRichStreamFormat;\r\n Converter: TJvConversion;\r\nbegin\r\n FRichEdit.HandleNeeded;\r\n Converter := FRichEdit.GetConverter(Stream, ckExport);\r\n try\r\n Converter.OnProgress := ProgressCallback;\r\n SaveFormat := Format;\r\n try\r\n if FRichEdit.PlainText then\r\n { When PlainText is set, the control does not accept RTF }\r\n FFormat := sfPlainText\r\n else\r\n if FFormat = sfDefault then\r\n case Converter.TextKind of\r\n ctkText, ctkBothPreferText:\r\n FFormat := sfPlainText;\r\n ctkRTF, ctkBothPreferRTF:\r\n FFormat := sfRichText;\r\n end;\r\n\r\n if not Converter.Open(Stream, ckExport) then\r\n raise EOutOfResources.CreateRes(@sRichEditSaveFail);\r\n\r\n DoExport(Converter)\r\n finally\r\n FFormat := SaveFormat;\r\n end;\r\n finally\r\n Converter.Done;\r\n Converter.OnProgress := nil;\r\n end;\r\nend;\r\n\r\nprocedure TJvRichEditStrings.SetTextStr(const Value: string);\r\nbegin\r\n EnableChange(False);\r\n try\r\n inherited SetTextStr(Value);\r\n finally\r\n EnableChange(True);\r\n end;\r\nend;\r\n\r\nprocedure TJvRichEditStrings.SetUpdateState(Updating: Boolean);\r\nbegin\r\n if FRichEdit.Showing then\r\n SendMessage(FRichEdit.Handle, WM_SETREDRAW, Ord(not Updating), 0);\r\n if not Updating then\r\n begin\r\n FRichEdit.Refresh;\r\n FRichEdit.Perform(CM_TEXTCHANGED, 0, 0);\r\n end;\r\nend;\r\n\r\n//=== { TJvRTFConversion } ===================================================\r\n\r\nfunction TJvRTFConversion.CanHandle(const AExtension: string;\r\n const AKind: TJvConversionKind): Boolean;\r\nbegin\r\n Result := AExtension = 'rtf';\r\nend;\r\n\r\nfunction TJvRTFConversion.Filter: string;\r\nbegin\r\n Result := RsRTFFilter;\r\nend;\r\n\r\nfunction TJvRTFConversion.IsFormatCorrect(AStream: TStream): Boolean;\r\nconst\r\n CRTFHeader = AnsiString('{\\rtf');\r\n CRTFHeaderSize = Length(CRTFHeader);\r\nvar\r\n SavedPosition: Int64;\r\n Buffer: array[0..CRTFHeaderSize] of AnsiChar; // + #0\r\nbegin\r\n SavedPosition := AStream.Position;\r\n try\r\n Buffer[CRTFHeaderSize] := #0;\r\n\r\n Result :=\r\n (AStream.Read(Buffer, CRTFHeaderSize) = CRTFHeaderSize) and\r\n (StrIComp(PAnsiChar(CRTFHeader), Buffer) = 0);\r\n finally\r\n AStream.Position := SavedPosition;\r\n end;\r\nend;\r\n\r\nfunction TJvRTFConversion.IsFormatCorrect(const AFileName: string): Boolean;\r\nvar\r\n LStream: TStream;\r\nbegin\r\n Result := FileExists(AFileName);\r\n if not Result then\r\n Exit;\r\n\r\n LStream := TFileStream.Create(AFileName, fmOpenRead or fmShareDenyWrite);\r\n try\r\n Result := IsFormatCorrect(LStream);\r\n finally\r\n LStream.Free;\r\n end;\r\nend;\r\n\r\nfunction TJvRTFConversion.TextKind: TJvConversionTextKind;\r\nbegin\r\n Result := ctkBothPreferRTF;\r\nend;\r\n\r\n//=== { TJvStreamConversion } ================================================\r\n\r\nfunction TJvStreamConversion.ConvertRead(Buffer: {$IFDEF COMPILER12_UP}PByte{$ELSE}PAnsiChar{$ENDIF COMPILER12_UP};\r\n BufSize: Integer): Integer;\r\nbegin\r\n Result := FStream.Read(Buffer^, BufSize);\r\n if FStreamSize > 0 then\r\n begin\r\n Inc(FBytesConverted, Result);\r\n DoProgress((FBytesConverted * 100 + FStreamSize div 2) div FStreamSize);\r\n end;\r\nend;\r\n\r\nfunction TJvStreamConversion.ConvertWrite(Buffer: {$IFDEF COMPILER12_UP}PByte{$ELSE}PAnsiChar{$ENDIF COMPILER12_UP};\r\n BufSize: Integer): Integer;\r\nbegin\r\n Result := FStream.Write(Buffer^, BufSize);\r\n if FStreamSize > 0 then\r\n begin\r\n Inc(FBytesConverted, Result);\r\n DoProgress((FBytesConverted * 100 + FStreamSize div 2) div FStreamSize);\r\n end;\r\nend;\r\n\r\nprocedure TJvStreamConversion.Done;\r\nbegin\r\n if FFreeStream then\r\n FStream.Free;\r\n FStream := nil;\r\n inherited Done;\r\nend;\r\n\r\nfunction TJvStreamConversion.Open(Stream: TStream; const AKind: TJvConversionKind): Boolean;\r\nbegin\r\n FFreeStream := False;\r\n FStream := Stream;\r\n\r\n FSavedPosition := FStream.Seek(0, soFromCurrent);\r\n FStreamSize := FStream.Seek(0, soFromEnd);\r\n FStream.Seek(FSavedPosition, soFromBeginning);\r\n FBytesConverted := 0;\r\n\r\n Result := True;\r\nend;\r\n\r\nfunction TJvStreamConversion.Open(const AFileName: string;\r\n const AKind: TJvConversionKind): Boolean;\r\nbegin\r\n FFreeStream := True;\r\n if AKind = ckImport then\r\n FStream := TFileStream.Create(AFileName, fmOpenRead or fmShareDenyWrite)\r\n else\r\n FStream := TFileStream.Create(AFileName, fmCreate);\r\n\r\n FSavedPosition := 0;\r\n FStreamSize := FStream.Size;\r\n FBytesConverted := 0;\r\n\r\n Result := True;\r\nend;\r\n\r\nfunction TJvStreamConversion.Retry: Boolean;\r\nbegin\r\n Result := TextKind in [ctkBothPreferText, ctkBothPreferRTF];\r\n if Result then\r\n begin\r\n FStream.Position := FSavedPosition;\r\n FBytesConverted := 0;\r\n end;\r\nend;\r\n\r\n//=== { TJvTextAttributes } ==================================================\r\n\r\nconstructor TJvTextAttributes.Create(AOwner: TJvCustomRichEdit;\r\n AttributeType: TJvAttributeType);\r\nbegin\r\n inherited Create;\r\n FRichEdit := AOwner;\r\n FType := AttributeType;\r\nend;\r\n\r\nprocedure TJvTextAttributes.Assign(Source: TPersistent);\r\nvar\r\n Format: TCharFormat2;\r\nbegin\r\n if Source is TFont then\r\n AssignFont(TFont(Source))\r\n else\r\n if Source is TTextAttributes then\r\n begin\r\n Name := TTextAttributes(Source).Name;\r\n Charset := TTextAttributes(Source).Charset;\r\n Style := TTextAttributes(Source).Style;\r\n Pitch := TTextAttributes(Source).Pitch;\r\n Color := TTextAttributes(Source).Color;\r\n end\r\n else\r\n if Source is TJvTextAttributes then\r\n begin\r\n TJvTextAttributes(Source).GetAttributes(Format);\r\n SetAttributes(Format);\r\n end\r\n else\r\n inherited Assign(Source);\r\nend;\r\n\r\nprocedure TJvTextAttributes.AssignFont(Font: TFont);\r\nvar\r\n LogFont: TLogFont;\r\n Format: TCharFormat2;\r\nbegin\r\n InitFormat(Format);\r\n with Format do\r\n begin\r\n case Font.Pitch of\r\n fpVariable:\r\n bPitchAndFamily := VARIABLE_PITCH;\r\n fpFixed:\r\n bPitchAndFamily := FIXED_PITCH;\r\n else\r\n bPitchAndFamily := DEFAULT_PITCH;\r\n end;\r\n dwMask := dwMask or CFM_SIZE or CFM_BOLD or CFM_ITALIC or\r\n CFM_UNDERLINE or CFM_STRIKEOUT or CFM_FACE or CFM_COLOR;\r\n { Font.Size is in points; yHeight is in twips }\r\n yHeight := Font.Size * CTwipsPerPoint;\r\n if (Font.Color = clWindowText) or (Font.Color = clDefault) then\r\n dwEffects := dwEffects or CFE_AUTOCOLOR\r\n else\r\n crTextColor := ColorToRGB(Font.Color);\r\n if fsBold in Font.Style then\r\n dwEffects := dwEffects or CFE_BOLD;\r\n if fsItalic in Font.Style then\r\n dwEffects := dwEffects or CFE_ITALIC;\r\n if fsUnderline in Font.Style then\r\n dwEffects := dwEffects or CFE_UNDERLINE;\r\n if fsStrikeOut in Font.Style then\r\n dwEffects := dwEffects or CFE_STRIKEOUT;\r\n StrPLCopy(szFaceName, Font.Name, SizeOf(szFaceName));\r\n dwMask := dwMask or CFM_CHARSET;\r\n bCharSet := Font.Charset;\r\n if GetObject(Font.Handle, SizeOf(LogFont), @LogFont) <> 0 then\r\n begin\r\n dwMask := dwMask or DWORD(CFM_WEIGHT);\r\n wWeight := Word(LogFont.lfWeight);\r\n end;\r\n end;\r\n SetAttributes(Format);\r\nend;\r\n\r\nprocedure TJvTextAttributes.AssignTo(Dest: TPersistent);\r\nbegin\r\n if Dest is TFont then\r\n begin\r\n TFont(Dest).Color := Color;\r\n TFont(Dest).Name := Name;\r\n TFont(Dest).Charset := Charset;\r\n TFont(Dest).Style := Style;\r\n TFont(Dest).Size := Size;\r\n TFont(Dest).Pitch := Pitch;\r\n end\r\n else\r\n if Dest is TTextAttributes then\r\n begin\r\n TTextAttributes(Dest).Color := Color;\r\n TTextAttributes(Dest).Name := Name;\r\n TTextAttributes(Dest).Charset := Charset;\r\n TTextAttributes(Dest).Style := Style;\r\n TTextAttributes(Dest).Pitch := Pitch;\r\n end\r\n else\r\n inherited AssignTo(Dest);\r\nend;\r\n\r\nfunction TJvTextAttributes.GetAttribute(const Flag: Integer): Boolean;\r\nvar\r\n Format: TCharFormat2;\r\nbegin\r\n GetAttributes(Format);\r\n Result := Format.dwEffects and Flag <> 0;\r\nend;\r\n\r\nprocedure TJvTextAttributes.GetAttributes(var Format: TCharFormat2);\r\nbegin\r\n InitFormat(Format);\r\n if FRichEdit.HandleAllocated then\r\n SendMessage(FRichEdit.Handle, EM_GETCHARFORMAT, AttrFlags[FType], LPARAM(@Format));\r\nend;\r\n\r\nfunction TJvTextAttributes.GetBackColor: TColor;\r\nvar\r\n Format: TCharFormat2;\r\nbegin\r\n if RichEditVersion < 2 then\r\n begin\r\n Result := clWindow;\r\n Exit;\r\n end;\r\n GetAttributes(Format);\r\n with Format do\r\n if (dwEffects and CFE_AUTOBACKCOLOR) <> 0 then\r\n Result := clWindow\r\n else\r\n Result := crBackColor;\r\nend;\r\n\r\nfunction TJvTextAttributes.GetCharset: TFontCharset;\r\nvar\r\n Format: TCharFormat2;\r\nbegin\r\n GetAttributes(Format);\r\n Result := Format.bCharSet;\r\nend;\r\n\r\nfunction TJvTextAttributes.GetColor: TColor;\r\nvar\r\n Format: TCharFormat2;\r\nbegin\r\n GetAttributes(Format);\r\n with Format do\r\n if (dwEffects and CFE_AUTOCOLOR) <> 0 then\r\n Result := clWindowText\r\n else\r\n Result := crTextColor;\r\nend;\r\n\r\nfunction TJvTextAttributes.GetConsistentAttributes: TJvConsistentAttributes;\r\nvar\r\n Format: TCharFormat2;\r\nbegin\r\n Result := [];\r\n if FRichEdit.HandleAllocated and (FType <> atDefaultText) then\r\n begin\r\n InitFormat(Format);\r\n SendMessage(FRichEdit.Handle, EM_GETCHARFORMAT,\r\n AttrFlags[FType], LParam(@Format));\r\n with Format do\r\n begin\r\n if (dwMask and CFM_BOLD) <> 0 then\r\n Include(Result, caBold);\r\n if (dwMask and CFM_COLOR) <> 0 then\r\n Include(Result, caColor);\r\n if (dwMask and CFM_FACE) <> 0 then\r\n Include(Result, caFace);\r\n if (dwMask and CFM_ITALIC) <> 0 then\r\n Include(Result, caItalic);\r\n if (dwMask and CFM_SIZE) <> 0 then\r\n Include(Result, caSize);\r\n if (dwMask and CFM_STRIKEOUT) <> 0 then\r\n Include(Result, caStrikeOut);\r\n if (dwMask and CFM_UNDERLINE) <> 0 then\r\n Include(Result, caUnderline);\r\n if (dwMask and CFM_PROTECTED) <> 0 then\r\n Include(Result, caProtected);\r\n if (dwMask and CFM_OFFSET) <> 0 then\r\n Include(Result, caOffset);\r\n if (dwMask and CFM_HIDDEN) <> 0 then\r\n Include(Result, caHidden);\r\n if (dwMask and CFM_CHARSET) <> 0 then\r\n Include(Result, caCharset);\r\n if RichEditVersion >= 2 then\r\n begin\r\n if (dwMask and CFM_LINK) <> 0 then\r\n Include(Result, caLink);\r\n if (dwMask and CFM_BACKCOLOR) <> 0 then\r\n Include(Result, caBackColor);\r\n if (dwMask and CFM_DISABLED) <> 0 then\r\n Include(Result, caDisabled);\r\n if (dwMask and CFM_WEIGHT) <> 0 then\r\n Include(Result, caWeight);\r\n if (dwMask and CFM_SUBSCRIPT) <> 0 then\r\n Include(Result, caSubscript);\r\n if (dwMask and CFM_REVAUTHOR) <> 0 then\r\n Include(Result, caRevAuthor);\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJvTextAttributes.GetDisabled: Boolean;\r\nvar\r\n Format: TCharFormat2;\r\nbegin\r\n Result := False;\r\n if RichEditVersion < 2 then\r\n Exit;\r\n GetAttributes(Format);\r\n Result := Format.dwEffects and CFE_DISABLED <> 0;\r\nend;\r\n\r\nfunction TJvTextAttributes.GetHeight: Integer;\r\nbegin\r\n { Points -> Logical pixels }\r\n Result := MulDiv(Size, FRichEdit.FScreenLogPixels, CPointsPerInch);\r\nend;\r\n\r\nfunction TJvTextAttributes.GetHidden: Boolean;\r\nvar\r\n Format: TCharFormat2;\r\nbegin\r\n Result := False;\r\n if RichEditVersion < 2 then\r\n Exit;\r\n GetAttributes(Format);\r\n Result := Format.dwEffects and CFE_HIDDEN <> 0;\r\nend;\r\n\r\nfunction TJvTextAttributes.GetLink: Boolean;\r\nvar\r\n Format: TCharFormat2;\r\nbegin\r\n Result := False;\r\n if RichEditVersion < 2 then\r\n Exit;\r\n GetAttributes(Format);\r\n with Format do\r\n Result := (dwEffects and CFE_LINK) <> 0;\r\nend;\r\n\r\nfunction TJvTextAttributes.GetName: TFontName;\r\nvar\r\n Format: TCharFormat2;\r\nbegin\r\n GetAttributes(Format);\r\n Result := Format.szFaceName;\r\nend;\r\n\r\nfunction TJvTextAttributes.GetOffset: Integer;\r\nvar\r\n Format: TCharFormat2;\r\nbegin\r\n GetAttributes(Format);\r\n Result := Format.yOffset div CTwipsPerPoint;\r\nend;\r\n\r\nfunction TJvTextAttributes.GetPitch: TFontPitch;\r\nvar\r\n Format: TCharFormat2;\r\nbegin\r\n GetAttributes(Format);\r\n case Format.bPitchAndFamily and $03 of\r\n DEFAULT_PITCH:\r\n Result := fpDefault;\r\n VARIABLE_PITCH:\r\n Result := fpVariable;\r\n FIXED_PITCH:\r\n Result := fpFixed;\r\n else\r\n Result := fpDefault;\r\n end;\r\nend;\r\n\r\nfunction TJvTextAttributes.GetProtected: Boolean;\r\nvar\r\n Format: TCharFormat2;\r\nbegin\r\n GetAttributes(Format);\r\n with Format do\r\n Result := (dwEffects and CFE_PROTECTED) <> 0;\r\nend;\r\n\r\nfunction TJvTextAttributes.GetRevAuthorIndex: Byte;\r\nvar\r\n Format: TCharFormat2;\r\nbegin\r\n GetAttributes(Format);\r\n Result := Format.bRevAuthor;\r\nend;\r\n\r\nfunction TJvTextAttributes.GetSize: Integer;\r\nvar\r\n Format: TCharFormat2;\r\nbegin\r\n GetAttributes(Format);\r\n Result := Format.yHeight div CTwipsPerPoint;\r\nend;\r\n\r\nfunction TJvTextAttributes.GetStyle: TFontStyles;\r\nvar\r\n Format: TCharFormat2;\r\nbegin\r\n Result := [];\r\n GetAttributes(Format);\r\n with Format do\r\n begin\r\n if (dwEffects and CFE_BOLD) <> 0 then\r\n Include(Result, fsBold);\r\n if (dwEffects and CFE_ITALIC) <> 0 then\r\n Include(Result, fsItalic);\r\n if (dwEffects and CFE_UNDERLINE) <> 0 then\r\n Include(Result, fsUnderline);\r\n if (dwEffects and CFE_STRIKEOUT) <> 0 then\r\n Include(Result, fsStrikeOut);\r\n end;\r\nend;\r\n\r\nfunction TJvTextAttributes.GetSubscriptStyle: TSubscriptStyle;\r\nvar\r\n Format: TCharFormat2;\r\nbegin\r\n Result := ssNone;\r\n if RichEditVersion < 2 then\r\n Exit;\r\n GetAttributes(Format);\r\n with Format do\r\n begin\r\n if (dwEffects and CFE_SUBSCRIPT) <> 0 then\r\n Result := ssSubscript\r\n else\r\n if (dwEffects and CFE_SUPERSCRIPT) <> 0 then\r\n Result := ssSuperscript;\r\n end;\r\nend;\r\n\r\nfunction TJvTextAttributes.GetUnderlineColor: TUnderlineColor;\r\nvar\r\n Format: TCharFormat2;\r\nbegin\r\n Result := ucBlack;\r\n if RichEditVersion < 3 then\r\n Exit;\r\n GetAttributes(Format);\r\n with Format do\r\n begin\r\n if (dwEffects and CFE_UNDERLINE <> 0) and\r\n (dwMask and CFM_UNDERLINETYPE = CFM_UNDERLINETYPE) then\r\n Result := TUnderlineColor(bUnderlineType div $10);\r\n end;\r\nend;\r\n\r\nfunction TJvTextAttributes.GetUnderlineType: TUnderlineType;\r\nvar\r\n Format: TCharFormat2;\r\nbegin\r\n Result := utNone;\r\n if RichEditVersion < 2 then\r\n Exit;\r\n GetAttributes(Format);\r\n with Format do\r\n begin\r\n if (dwEffects and CFE_UNDERLINE <> 0) and\r\n (dwMask and CFM_UNDERLINETYPE = CFM_UNDERLINETYPE) then\r\n Result := TUnderlineType(bUnderlineType mod $10);\r\n end;\r\nend;\r\n\r\nprocedure TJvTextAttributes.InitFormat(var Format: TCharFormat2);\r\nbegin\r\n FillChar(Format, SizeOf(Format), 0);\r\n if RichEditVersion >= 2 then\r\n Format.cbSize := SizeOf(Format)\r\n else\r\n Format.cbSize := SizeOf(TCharFormat);\r\nend;\r\n\r\nprocedure TJvTextAttributes.SetAttribute(const Flag: Integer; const Value: Boolean);\r\nvar\r\n Format: TCharFormat2;\r\nbegin\r\n InitFormat(Format);\r\n { Assume Mask value is same as Flag, this is correct for CFE_BOLD, CFE_ITALIC,\r\n CFE_UNDERLINE and CFE_STRIKEOUT }\r\n Format.dwMask := Flag;\r\n if Value then\r\n Format.dwEffects := Flag;\r\n SetAttributes(Format);\r\nend;\r\n\r\nprocedure TJvTextAttributes.SetAttributes(var Format: TCharFormat2);\r\nbegin\r\n if FRichEdit.HandleAllocated then\r\n SendMessage(FRichEdit.Handle, EM_SETCHARFORMAT, AttrFlags[FType], LPARAM(@Format));\r\nend;\r\n\r\nprocedure TJvTextAttributes.SetBackColor(Value: TColor);\r\nvar\r\n Format: TCharFormat2;\r\nbegin\r\n if RichEditVersion < 2 then\r\n Exit;\r\n InitFormat(Format);\r\n with Format do\r\n begin\r\n dwMask := CFM_BACKCOLOR;\r\n if (Value = clWindow) or (Value = clDefault) then\r\n dwEffects := CFE_AUTOBACKCOLOR\r\n else\r\n crBackColor := ColorToRGB(Value);\r\n end;\r\n SetAttributes(Format);\r\nend;\r\n\r\nprocedure TJvTextAttributes.SetCharset(Value: TFontCharset);\r\nvar\r\n Format: TCharFormat2;\r\nbegin\r\n InitFormat(Format);\r\n with Format do\r\n begin\r\n dwMask := CFM_CHARSET;\r\n bCharSet := Value;\r\n end;\r\n SetAttributes(Format);\r\nend;\r\n\r\nprocedure TJvTextAttributes.SetColor(Value: TColor);\r\nvar\r\n Format: TCharFormat2;\r\nbegin\r\n InitFormat(Format);\r\n with Format do\r\n begin\r\n dwMask := CFM_COLOR;\r\n if (Value = clWindowText) or (Value = clDefault) then\r\n dwEffects := CFE_AUTOCOLOR\r\n else\r\n crTextColor := ColorToRGB(Value);\r\n end;\r\n SetAttributes(Format);\r\nend;\r\n\r\nprocedure TJvTextAttributes.SetDisabled(Value: Boolean);\r\nvar\r\n Format: TCharFormat2;\r\nbegin\r\n if RichEditVersion < 2 then\r\n Exit;\r\n InitFormat(Format);\r\n with Format do\r\n begin\r\n dwMask := CFM_DISABLED;\r\n if Value then\r\n dwEffects := CFE_DISABLED;\r\n end;\r\n SetAttributes(Format);\r\nend;\r\n\r\nprocedure TJvTextAttributes.SetHeight(Value: Integer);\r\nbegin\r\n { Logical pixels -> Points }\r\n Size := MulDiv(Value, CPointsPerInch, FRichEdit.FScreenLogPixels);\r\nend;\r\n\r\nprocedure TJvTextAttributes.SetHidden(Value: Boolean);\r\nvar\r\n Format: TCharFormat2;\r\nbegin\r\n if RichEditVersion < 2 then\r\n Exit;\r\n InitFormat(Format);\r\n with Format do\r\n begin\r\n dwMask := CFM_HIDDEN;\r\n if Value then\r\n dwEffects := CFE_HIDDEN;\r\n end;\r\n SetAttributes(Format);\r\nend;\r\n\r\nprocedure TJvTextAttributes.SetLink(Value: Boolean);\r\nvar\r\n Format: TCharFormat2;\r\nbegin\r\n if RichEditVersion < 2 then\r\n Exit;\r\n InitFormat(Format);\r\n with Format do\r\n begin\r\n dwMask := CFM_LINK;\r\n if Value then\r\n dwEffects := CFE_LINK;\r\n end;\r\n SetAttributes(Format);\r\nend;\r\n\r\nprocedure TJvTextAttributes.SetName(Value: TFontName);\r\nvar\r\n Format: TCharFormat2;\r\nbegin\r\n InitFormat(Format);\r\n with Format do\r\n begin\r\n dwMask := CFM_FACE;\r\n StrPLCopy(szFaceName, Value, SizeOf(szFaceName));\r\n end;\r\n SetAttributes(Format);\r\nend;\r\n\r\nprocedure TJvTextAttributes.SetOffset(Value: Integer);\r\nvar\r\n Format: TCharFormat2;\r\nbegin\r\n InitFormat(Format);\r\n with Format do\r\n begin\r\n dwMask := DWORD(CFM_OFFSET);\r\n yOffset := Value * CTwipsPerPoint;\r\n end;\r\n SetAttributes(Format);\r\nend;\r\n\r\nprocedure TJvTextAttributes.SetPitch(Value: TFontPitch);\r\nvar\r\n Format: TCharFormat2;\r\nbegin\r\n InitFormat(Format);\r\n with Format do\r\n begin\r\n case Value of\r\n fpVariable:\r\n bPitchAndFamily := VARIABLE_PITCH;\r\n fpFixed:\r\n bPitchAndFamily := FIXED_PITCH;\r\n else\r\n bPitchAndFamily := DEFAULT_PITCH;\r\n end;\r\n end;\r\n SetAttributes(Format);\r\nend;\r\n\r\nprocedure TJvTextAttributes.SetProtected(Value: Boolean);\r\nvar\r\n Format: TCharFormat2;\r\nbegin\r\n InitFormat(Format);\r\n with Format do\r\n begin\r\n dwMask := CFM_PROTECTED;\r\n if Value then\r\n dwEffects := CFE_PROTECTED;\r\n end;\r\n SetAttributes(Format);\r\nend;\r\n\r\nprocedure TJvTextAttributes.SetRevAuthorIndex(Value: Byte);\r\nvar\r\n Format: TCharFormat2;\r\nbegin\r\n if RichEditVersion < 2 then\r\n Exit;\r\n InitFormat(Format);\r\n with Format do\r\n begin\r\n dwMask := CFM_REVAUTHOR;\r\n bRevAuthor := Value;\r\n end;\r\n SetAttributes(Format);\r\nend;\r\n\r\nprocedure TJvTextAttributes.SetSize(Value: Integer);\r\nvar\r\n Format: TCharFormat2;\r\nbegin\r\n InitFormat(Format);\r\n with Format do\r\n begin\r\n dwMask := DWORD(CFM_SIZE);\r\n yHeight := Value * CTwipsPerPoint;\r\n end;\r\n SetAttributes(Format);\r\nend;\r\n\r\nprocedure TJvTextAttributes.SetStyle(Value: TFontStyles);\r\nvar\r\n Format: TCharFormat2;\r\nbegin\r\n InitFormat(Format);\r\n with Format do\r\n begin\r\n dwMask := CFM_BOLD or CFM_ITALIC or CFM_UNDERLINE or CFM_STRIKEOUT;\r\n if fsBold in Value then\r\n dwEffects := dwEffects or CFE_BOLD;\r\n if fsItalic in Value then\r\n dwEffects := dwEffects or CFE_ITALIC;\r\n if fsUnderline in Value then\r\n dwEffects := dwEffects or CFE_UNDERLINE;\r\n if fsStrikeOut in Value then\r\n dwEffects := dwEffects or CFE_STRIKEOUT;\r\n end;\r\n SetAttributes(Format);\r\nend;\r\n\r\nprocedure TJvTextAttributes.SetSubscriptStyle(Value: TSubscriptStyle);\r\nvar\r\n Format: TCharFormat2;\r\nbegin\r\n if RichEditVersion < 2 then\r\n Exit;\r\n InitFormat(Format);\r\n with Format do\r\n begin\r\n dwMask := DWORD(CFM_SUBSCRIPT);\r\n case Value of\r\n ssSubscript:\r\n dwEffects := CFE_SUBSCRIPT;\r\n ssSuperscript:\r\n dwEffects := CFE_SUPERSCRIPT;\r\n end;\r\n end;\r\n SetAttributes(Format);\r\nend;\r\n\r\nprocedure TJvTextAttributes.SetUnderlineColor(const Value: TUnderlineColor);\r\nvar\r\n Format: TCharFormat2;\r\n LUnderlineType: TUnderlineType;\r\nbegin\r\n if RichEditVersion < 3 then\r\n Exit;\r\n\r\n LUnderlineType := UnderlineType;\r\n if LUnderlineType = utNone then\r\n Exit;\r\n\r\n InitFormat(Format);\r\n with Format do\r\n begin\r\n dwMask := CFM_UNDERLINETYPE or CFM_UNDERLINE;\r\n bUnderlineType := Ord(LUnderlineType) + $10 * Ord(Value);\r\n dwEffects := dwEffects or CFE_UNDERLINE;\r\n end;\r\n SetAttributes(Format);\r\nend;\r\n\r\nprocedure TJvTextAttributes.SetUnderlineType(Value: TUnderlineType);\r\nvar\r\n Format: TCharFormat2;\r\nbegin\r\n if RichEditVersion < 2 then\r\n Exit;\r\n InitFormat(Format);\r\n with Format do\r\n begin\r\n dwMask := CFM_UNDERLINETYPE or CFM_UNDERLINE;\r\n bUnderlineType := Ord(Value);\r\n if Value <> utNone then\r\n begin\r\n Inc(bUnderlineType, $10 * Ord(UnderlineColor));\r\n dwEffects := dwEffects or CFE_UNDERLINE;\r\n end;\r\n end;\r\n SetAttributes(Format);\r\nend;\r\n\r\n//=== { TJvTextConversion } ==================================================\r\n\r\nfunction TJvTextConversion.CanHandle(const AExtension: string;\r\n const AKind: TJvConversionKind): Boolean;\r\nbegin\r\n Result := AExtension = 'txt';\r\nend;\r\n\r\nfunction TJvTextConversion.Filter: string;\r\nbegin\r\n Result := RsTextFilter;\r\nend;\r\n\r\nfunction TJvTextConversion.TextKind: TJvConversionTextKind;\r\nbegin\r\n Result := ctkBothPreferText;\r\nend;\r\n\r\n//=== { TMSTextConversionThread } ============================================\r\n\r\nconstructor TMSTextConversionThread.Create;\r\nbegin\r\n FreeOnTerminate := True;\r\n inherited Create(False);\r\nend;\r\n\r\nprocedure TMSTextConversionThread.Execute;\r\nbegin\r\n NameThread(ThreadName);\r\n if GCurrentConverter <> nil then\r\n GCurrentConverter.DoConversion;\r\nend;\r\n\r\n//=== { TOleUILinkInfo } =====================================================\r\n\r\nconstructor TOleUILinkInfo.Create(ARichEdit: TJvCustomRichEdit;\r\n ReObject: TReObject);\r\nbegin\r\n inherited Create;\r\n FReObject := ReObject;\r\n FRichEdit := ARichEdit;\r\n OleCheck(FReObject.poleobj.QueryInterface(IOleLink, FOleLink));\r\nend;\r\n\r\nfunction TOleUILinkInfo.CancelLink(dwLink: Longint): HRESULT;\r\nbegin\r\n LinkError(SCannotBreakLink);\r\n Result := E_NOTIMPL;\r\nend;\r\n\r\nfunction TOleUILinkInfo.GetLastUpdate(dwLink: Longint;\r\n var LastUpdate: TFileTime): HRESULT;\r\nbegin\r\n Result := S_OK;\r\nend;\r\n\r\nfunction TOleUILinkInfo.GetLinkSource(dwLink: Longint; var pszDisplayName: PChar;\r\n var lenFileName: Longint; var pszFullLinkType: PChar;\r\n var pszShortLinkType: PChar; var fSourceAvailable: BOOL;\r\n var fIsSelected: BOOL): HRESULT;\r\nvar\r\n Moniker: IMoniker;\r\nbegin\r\n if @pszDisplayName <> nil then\r\n pszDisplayName := CoAllocCStr(GetDisplayNameStr(FOleLink));\r\n if @lenFileName <> nil then\r\n begin\r\n lenFileName := 0;\r\n FOleLink.GetSourceMoniker(Moniker);\r\n if Moniker <> nil then\r\n begin\r\n lenFileName := OleStdGetLenFilePrefixOfMoniker(Moniker);\r\n ReleaseObject(Moniker);\r\n end;\r\n end;\r\n if @pszFullLinkType <> nil then\r\n pszFullLinkType := CoAllocCStr(GetFullNameStr(FReObject.poleobj));\r\n if @pszShortLinkType <> nil then\r\n pszShortLinkType := CoAllocCStr(GetShortNameStr(FReObject.poleobj));\r\n Result := S_OK;\r\nend;\r\n\r\nfunction TOleUILinkInfo.GetLinkUpdateOptions(dwLink: Longint;\r\n var dwUpdateOpt: Longint): HRESULT;\r\nbegin\r\n Result := FOleLink.GetUpdateOptions(dwUpdateOpt);\r\nend;\r\n\r\nfunction TOleUILinkInfo.GetNextLink(dwLink: Longint): Longint;\r\nbegin\r\n if dwLink = 0 then\r\n Result := Longint(FRichEdit)\r\n else\r\n Result := 0;\r\nend;\r\n\r\nfunction TOleUILinkInfo.OpenLinkSource(dwLink: Longint): HRESULT;\r\nbegin\r\n try\r\n OleCheck(FReObject.poleobj.DoVerb(OLEIVERB_SHOW, nil, FReObject.polesite,\r\n 0, FRichEdit.Handle, FRichEdit.ClientRect));\r\n except\r\n Application.HandleException(FRichEdit);\r\n end;\r\n Result := S_OK;\r\nend;\r\n\r\nfunction TOleUILinkInfo.SetLinkSource(dwLink: Longint; pszDisplayName: PChar;\r\n lenFileName: Longint; var chEaten: Longint;\r\n fValidateSource: BOOL): HRESULT;\r\nvar\r\n DisplayName: string;\r\n Buffer: array[0..255] of WideChar;\r\nbegin\r\n Result := E_FAIL;\r\n if fValidateSource then\r\n begin\r\n DisplayName := pszDisplayName;\r\n if Succeeded(FOleLink.SetSourceDisplayName(StringToWideChar(DisplayName,\r\n Buffer, SizeOf(Buffer) div 2))) then\r\n begin\r\n chEaten := Length(DisplayName);\r\n try\r\n OleCheck(FReObject.poleobj.Update);\r\n except\r\n Application.HandleException(FRichEdit);\r\n end;\r\n Result := S_OK;\r\n end;\r\n end\r\n else\r\n LinkError(SInvalidLinkSource);\r\nend;\r\n\r\nfunction TOleUILinkInfo.SetLinkUpdateOptions(dwLink: Longint;\r\n dwUpdateOpt: Longint): HRESULT;\r\nbegin\r\n Result := FOleLink.SetUpdateOptions(dwUpdateOpt);\r\n if Succeeded(Result) then\r\n FRichEdit.Modified := True;\r\nend;\r\n\r\nfunction TOleUILinkInfo.UpdateLink(dwLink: Longint; fErrorMessage: BOOL;\r\n fErrorAction: BOOL): HRESULT;\r\nbegin\r\n try\r\n OleCheck(FReObject.poleobj.Update);\r\n except\r\n Application.HandleException(FRichEdit);\r\n end;\r\n Result := S_OK;\r\nend;\r\n\r\n//=== { TOleUIObjInfo } ======================================================\r\n\r\nconstructor TOleUIObjInfo.Create(ARichEdit: TJvCustomRichEdit;\r\n ReObject: TReObject);\r\nbegin\r\n inherited Create;\r\n FRichEdit := ARichEdit;\r\n FReObject := ReObject;\r\nend;\r\n\r\nfunction TOleUIObjInfo.ConvertObject(dwObject: Longint;\r\n const clsidNew: TCLSID): HRESULT;\r\nbegin\r\n Result := E_NOTIMPL;\r\nend;\r\n\r\nfunction TOleUIObjInfo.GetConvertInfo(dwObject: Longint; var ClassID: TCLSID;\r\n var wFormat: Word; var ConvertDefaultClassID: TCLSID;\r\n var lpClsidExclude: PCLSID; var cClsidExclude: Longint): HRESULT;\r\nbegin\r\n FReObject.poleobj.GetUserClassID(ClassID);\r\n Result := S_OK;\r\nend;\r\n\r\nfunction TOleUIObjInfo.GetObjectInfo(dwObject: Longint;\r\n var dwObjSize: Longint; var lpszLabel: PChar;\r\n var lpszType: PChar; var lpszShortType: PChar;\r\n var lpszLocation: PChar): HRESULT;\r\nbegin\r\n if @dwObjSize <> nil then\r\n dwObjSize := -1; { Unknown size }\r\n if @lpszLabel <> nil then\r\n lpszLabel := CoAllocCStr(GetFullNameStr(FReObject.poleobj));\r\n if @lpszType <> nil then\r\n lpszType := CoAllocCStr(GetFullNameStr(FReObject.poleobj));\r\n if @lpszShortType <> nil then\r\n lpszShortType := CoAllocCStr(GetShortNameStr(FReObject.poleobj));\r\n if @lpszLocation <> nil then\r\n begin\r\n if Trim(FRichEdit.Title) <> '' then\r\n lpszLocation := CoAllocCStr(Format('%s - %s', [FRichEdit.Title, Application.Title]))\r\n else\r\n lpszLocation := CoAllocCStr(Application.Title);\r\n end;\r\n Result := S_OK;\r\nend;\r\n\r\nfunction TOleUIObjInfo.GetViewInfo(dwObject: Longint; var hMetaPict: HGLOBAL;\r\n var dvAspect: Longint; var nCurrentScale: Integer): HRESULT;\r\nbegin\r\n if @hMetaPict <> nil then\r\n hMetaPict := GetIconMetaPict(FReObject.poleobj, FReObject.dvAspect);\r\n if @dvAspect <> nil then\r\n dvAspect := FReObject.dvAspect;\r\n if @nCurrentScale <> nil then\r\n nCurrentScale := 0;\r\n Result := S_OK;\r\nend;\r\n\r\nfunction TOleUIObjInfo.SetViewInfo(dwObject: Longint; hMetaPict: HGLOBAL;\r\n dvAspect: Longint; nCurrentScale: Integer;\r\n bRelativeToOrig: BOOL): HRESULT;\r\nvar\r\n Iconic: Boolean;\r\nbegin\r\n if Assigned(FRichEdit.FRichEditOle) then\r\n begin\r\n case dvAspect of\r\n DVASPECT_CONTENT:\r\n Iconic := False;\r\n DVASPECT_ICON:\r\n Iconic := True;\r\n else\r\n Iconic := FReObject.dvAspect = DVASPECT_ICON;\r\n end;\r\n IRichEditOle(FRichEdit.FRichEditOle).InPlaceDeactivate;\r\n Result := OleSetDrawAspect(FReObject.poleobj, Iconic, hMetaPict,\r\n FReObject.dvAspect);\r\n if Succeeded(Result) then\r\n IRichEditOle(FRichEdit.FRichEditOle).SetDvaspect(\r\n Longint(REO_IOB_SELECTION), FReObject.dvAspect);\r\n end\r\n else\r\n Result := E_NOTIMPL;\r\nend;\r\n\r\n//=== { TRichEditOleCallback } ===============================================\r\n\r\nconstructor TRichEditOleCallback.Create(ARichEdit: TJvCustomRichEdit);\r\nbegin\r\n inherited Create;\r\n FRichEdit := ARichEdit;\r\nend;\r\n\r\ndestructor TRichEditOleCallback.Destroy;\r\nbegin\r\n DestroyAccelTable;\r\n FFrameForm := nil;\r\n FDocForm := nil;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TRichEditOleCallback.AssignFrame;\r\nbegin\r\n if (GetParentForm(FRichEdit) <> nil) and not Assigned(FFrameForm) and\r\n FRichEdit.AllowInPlace then\r\n begin\r\n FDocForm := GetVCLFrameForm(ValidParentForm(FRichEdit));\r\n FFrameForm := FDocForm;\r\n if IsFormMDIChild(FDocForm.Form) then\r\n FFrameForm := GetVCLFrameForm(Application.MainForm);\r\n end;\r\nend;\r\n\r\nfunction TRichEditOleCallback.ContextSensitiveHelp(fEnterMode: BOOL): HRESULT;\r\nbegin\r\n Result := NoError;\r\nend;\r\n\r\nprocedure TRichEditOleCallback.CreateAccelTable;\r\nvar\r\n Menu: TMainMenu;\r\nbegin\r\n if (FAccelTable = 0) and Assigned(FFrameForm) then\r\n begin\r\n Menu := FFrameForm.Form.Menu;\r\n if Menu <> nil then\r\n Menu.GetOle2AcceleratorTable(FAccelTable, FAccelCount, [0, 2, 4]);\r\n end;\r\nend;\r\n\r\nfunction TRichEditOleCallback.DeleteObject(const oleobj: IOleObject): HRESULT;\r\nbegin\r\n if Assigned(oleobj) then\r\n oleobj.Close(OLECLOSE_NOSAVE);\r\n Result := NoError;\r\nend;\r\n\r\nprocedure TRichEditOleCallback.DestroyAccelTable;\r\nbegin\r\n if FAccelTable <> 0 then\r\n begin\r\n DestroyAcceleratorTable(FAccelTable);\r\n FAccelTable := 0;\r\n FAccelCount := 0;\r\n end;\r\nend;\r\n\r\nfunction TRichEditOleCallback.GetClipboardData(const chrg: TCharRange; reco: DWORD;\r\n out dataObj: IDataObject): HRESULT;\r\nbegin\r\n // MSDN documentation: \"If the SCODE of the return value is a failure other than\r\n // E_NOTIMPL, the operation fails.\" This seems to be incorrect: returning S_OK\r\n // otoh works, ie fails the operation.\r\n\r\n // cut commands are done as 'copy; delete'\r\n\r\n dataObj := nil;\r\n Result := E_NOTIMPL;\r\n case reco of\r\n RECO_COPY: if not (caCopy in FRichEdit.ClipboardCommands) then Result := S_OK;\r\n RECO_CUT: if not (caCut in FRichEdit.ClipboardCommands) then Result := S_OK;\r\n RECO_DRAG: ;\r\n RECO_DROP: ;\r\n RECO_PASTE: if not (caPaste in FRichEdit.ClipboardCommands) then Result := S_OK;\r\n end;\r\nend;\r\n\r\nfunction TRichEditOleCallback.GetContextMenu(seltype: Word;\r\n const oleobj: IOleObject; const chrg: TCharRange; out Menu: HMENU): HRESULT;\r\nbegin\r\n Result := E_NOTIMPL;\r\nend;\r\n\r\nfunction EffectsToDropEffects(const dwEffect: Longint): TRichDropEffects;\r\nbegin\r\n Result := [];\r\n if dwEffect and DROPEFFECT_COPY > 0 then Include(Result, rdeCopy);\r\n if dwEffect and DROPEFFECT_MOVE > 0 then Include(Result, rdeMove);\r\n if dwEffect and DROPEFFECT_LINK > 0 then Include(Result, rdeLink);\r\n if dwEffect and DROPEFFECT_SCROLL > 0 then Include(Result, rdeScroll);\r\nend;\r\n\r\nfunction DropEffectsToEffects(const Effects: TRichDropEffects): Longint;\r\nbegin\r\n Result := 0;\r\n if rdeCopy in Effects then Inc(Result, DROPEFFECT_COPY);\r\n if rdeMove in Effects then Inc(Result, DROPEFFECT_MOVE);\r\n if rdeLink in Effects then Inc(Result, DROPEFFECT_LINK);\r\n if rdeScroll in Effects then Inc(Result, DROPEFFECT_SCROLL);\r\nend;\r\n\r\nfunction TRichEditOleCallback.GetDragDropEffect(fDrag: BOOL; grfKeyState: DWORD;\r\n var dwEffect: DWORD): HRESULT;\r\nvar\r\n ShiftState: TShiftState;\r\n DropEffects: TRichDropEffects;\r\n Handled: Boolean;\r\nbegin\r\n try\r\n ShiftState := KeysToShiftState(grfKeyState);\r\n DropEffects := EffectsToDropEffects(dwEffect);\r\n\r\n if fDrag then\r\n // dwEffect: its content is set to the effect allowable by the rich edit control.\r\n Handled := FRichEdit.DoDragAllowed(ShiftState, DropEffects)\r\n else\r\n // dwEffect: the variable is set to the effect to use.\r\n Handled := FRichEdit.DoGetDragDropEffect(ShiftState, DropEffects);\r\n\r\n if Handled then\r\n begin\r\n Result := S_OK;\r\n dwEffect := DropEffectsToEffects(DropEffects);\r\n end\r\n else\r\n // let the rich edit control specify the effects of a drop operation.\r\n Result := E_NOTIMPL;\r\n except\r\n Result := E_UNEXPECTED;\r\n end;\r\nend;\r\n\r\nfunction TRichEditOleCallback.GetInPlaceContext(out Frame: IOleInPlaceFrame; out Doc: IOleInPlaceUIWindow;\r\n lpFrameInfo: POleInPlaceFrameInfo): HRESULT;\r\nbegin\r\n AssignFrame;\r\n if Assigned(FFrameForm) and FRichEdit.AllowInPlace then\r\n begin\r\n Frame := FFrameForm;\r\n Doc := FDocForm;\r\n CreateAccelTable;\r\n with lpFrameInfo^ do\r\n begin\r\n fMDIApp := False;\r\n FFrameForm.GetWindow(hwndFrame);\r\n haccel := FAccelTable;\r\n cAccelEntries := FAccelCount;\r\n end;\r\n Result := S_OK;\r\n end\r\n else\r\n Result := E_NOTIMPL;\r\nend;\r\n\r\nfunction TRichEditOleCallback.GetNewStorage(out stg: IStorage): HRESULT;\r\nbegin\r\n try\r\n CreateStorage(stg);\r\n Result := S_OK;\r\n except\r\n Result := E_OUTOFMEMORY;\r\n end;\r\nend;\r\n\r\nfunction TRichEditOleCallback.QueryAcceptData(const dataObj: IDataObject;\r\n var cfFormat: TClipFormat; reco: DWORD; fReally: BOOL;\r\n hMetaPict: HGLOBAL): HRESULT;\r\nvar\r\n Handled: Boolean;\r\nbegin\r\n try\r\n Handled := FRichEdit.DoQueryAcceptData(dataObj, cfFormat, reco, fReally, hMetaPict);\r\n\r\n if Handled then\r\n // Callback imported the data itself\r\n Result := S_FALSE\r\n else\r\n // Let the rich edit control check the data itself for acceptable formats.\r\n Result := S_OK;\r\n except\r\n Result := E_UNEXPECTED;\r\n end;\r\nend;\r\n\r\nfunction TRichEditOleCallback.QueryInsertObject(const clsid: TCLSID; const stg: IStorage;\r\n cp: Longint): HRESULT;\r\nbegin\r\n Result := NoError;\r\nend;\r\n\r\nfunction TRichEditOleCallback.QueryInterface(const iid: TGUID; out Obj): HRESULT;\r\nbegin\r\n if GetInterface(iid, Obj) then\r\n Result := S_OK\r\n else\r\n Result := E_NOINTERFACE;\r\nend;\r\n\r\nfunction TRichEditOleCallback.ShowContainerUI(fShow: BOOL): HRESULT;\r\nbegin\r\n if not fShow then\r\n AssignFrame;\r\n if Assigned(FFrameForm) then\r\n begin\r\n if fShow then\r\n begin\r\n FFrameForm.SetMenu(0, 0, 0);\r\n FFrameForm.ClearBorderSpace;\r\n FRichEdit.SetUIActive(False);\r\n DestroyAccelTable;\r\n TForm(FFrameForm.Form).AutoScroll := FAutoScroll;\r\n FFrameForm := nil;\r\n FDocForm := nil;\r\n end\r\n else\r\n begin\r\n FAutoScroll := TForm(FFrameForm.Form).AutoScroll;\r\n TForm(FFrameForm.Form).AutoScroll := False;\r\n FRichEdit.SetUIActive(True);\r\n end;\r\n Result := S_OK;\r\n end\r\n else\r\n Result := E_NOTIMPL;\r\nend;\r\n\r\nfunction TRichEditOleCallback._AddRef: Longint;\r\nbegin\r\n Inc(FRefCount);\r\n Result := FRefCount;\r\nend;\r\n\r\nfunction TRichEditOleCallback._Release: Longint;\r\nbegin\r\n Dec(FRefCount);\r\n Result := FRefCount;\r\nend;\r\n\r\n{ Initialization part }\r\n\r\nvar\r\n GLibHandle: THandle = 0;\r\n\r\nprocedure InitRichEditDll;\r\nvar\r\n FileName: string;\r\n InfoSize, Wnd: DWORD;\r\n VerBuf: Pointer;\r\n FI: PVSFixedFileInfo;\r\n VerSize: DWORD;\r\nbegin\r\n RichEditVersion := 1;\r\n GLibHandle := SafeLoadLibrary(RichEdit20ModuleName);\r\n if (GLibHandle > 0) and (GLibHandle < HINSTANCE_ERROR) then\r\n GLibHandle := 0;\r\n if GLibHandle = 0 then\r\n begin\r\n GLibHandle := SafeLoadLibrary(RichEdit10ModuleName);\r\n if (GLibHandle > 0) and (GLibHandle < HINSTANCE_ERROR) then\r\n GLibHandle := 0;\r\n end\r\n else\r\n begin\r\n RichEditVersion := 2;\r\n\r\n FileName := GetModuleName(GLibHandle);\r\n InfoSize := GetFileVersionInfoSize(PChar(FileName), Wnd);\r\n if InfoSize <> 0 then\r\n begin\r\n GetMem(VerBuf, InfoSize);\r\n try\r\n if GetFileVersionInfo(PChar(FileName), Wnd, InfoSize, VerBuf) then\r\n if VerQueryValue(VerBuf, '\\', Pointer(FI), VerSize) then\r\n begin\r\n if FI.dwFileVersionMS and $FFFF0000 = $00050000 then\r\n RichEditVersion := (FI.dwFileVersionMS and $FFFF) div 10\r\n else\r\n if FI.dwFileVersionMS and $FFFF0000 = $000C0000 then\r\n RichEditVersion := 6;\r\n if RichEditVersion = 0 then\r\n RichEditVersion := 2;\r\n end;\r\n finally\r\n FreeMem(VerBuf);\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure FinalRichEditDll;\r\nbegin\r\n if GLibHandle > 0 then\r\n begin\r\n FreeLibrary(GLibHandle);\r\n GLibHandle := 0;\r\n end;\r\nend;\r\n\r\ninitialization\r\n {$IFDEF UNITVERSIONING}\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n {$ENDIF UNITVERSIONING}\r\n InitRichEditDll;\r\n CFEmbeddedObject := RegisterClipboardFormat(CF_EMBEDDEDOBJECT);\r\n CFLinkSource := RegisterClipboardFormat(CF_LINKSOURCE);\r\n CFRtf := RegisterClipboardFormat(CF_RTF);\r\n CFRtfNoObjs := RegisterClipboardFormat(CF_RTFNOOBJS);\r\n\r\nfinalization\r\n FreeAndNil(GlobalConversionFormatList);\r\n FinalRichEditDll;\r\n {$IFDEF UNITVERSIONING}\r\n UnregisterUnitVersion(HInstance);\r\n {$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvRichEditToHtml.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvRichEditToHtml.PAS, released on 2001-02-28.\r\n\r\nThe Initial Developer of the Original Code is Sbastien Buysse [sbuysse att buypin dott com]\r\nPortions created by Sbastien Buysse are Copyright (C) 2001 Sbastien Buysse.\r\nAll Rights Reserved.\r\n\r\nContributor(s): Michael Beck [mbeck att bigfoot dott com],\r\n Andreas Hausladen [Andreas dott Hausladen att gmx dott de].\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvRichEditToHtml.pas 13211 2012-02-23 11:26:29Z obones $\r\n\r\nunit JvRichEditToHtml;\r\n\r\n{$I jvcl.inc}\r\n{$I windowsonly.inc}\r\n\r\ninterface\r\n\r\nuses\r\n Windows,\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n {$IFDEF HAS_UNIT_CHARACTER}\r\n Character, // inline\r\n {$ENDIF HAS_UNIT_CHARACTER}\r\n {$IFDEF HAS_UNIT_SYSTEM_UITYPES}\r\n System.UITypes,\r\n {$ENDIF HAS_UNIT_SYSTEM_UITYPES}\r\n SysUtils, Classes, Graphics, Forms, ComCtrls,\r\n JvRgbToHtml, JvStrToHtml, JvRichEdit, JvComponentBase, JclStrings;\r\n\r\ntype\r\n TJvParaAttributesRec = record\r\n Alignment: TAlignment;\r\n Numbering: TNumberingStyle;\r\n end;\r\n\r\n TJvRichEditParaAttributesRec = record\r\n Alignment: TParaAlignment;\r\n Numbering: TJvNumbering;\r\n end;\r\n\r\n TFontInfo = class(TPersistent)\r\n private\r\n FFontData: TFontData;\r\n FColor: TColor;\r\n FPixelsPerInch: Integer;\r\n FLink: Boolean;\r\n function GetSize: Integer;\r\n procedure SetSize(const Value: Integer);\r\n public\r\n constructor Create(APixelsPerInch: Integer);\r\n procedure Assign(Source: TPersistent); override;\r\n property Color: TColor read FColor write FColor;\r\n property Link: Boolean read FLink write FLink;\r\n\r\n property Size: Integer read GetSize write SetSize;\r\n property Height: Integer read FFontData.Height write FFontData.Height;\r\n property Pitch: TFontPitch read FFontData.Pitch write FFontData.Pitch;\r\n property Style: TFontStylesBase read FFontData.Style write FFontData.Style;\r\n property Charset: TFontCharset read FFontData.Charset write FFontData.Charset;\r\n property Name: TFontDataName read FFontData.Name write FFontData.Name;\r\n end;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64 or pidOSX32)]\r\n {$ENDIF RTL230_UP}\r\n TJvRichEditToHtml = class(TJvComponent)\r\n private\r\n FCToH: TJvRgbToHtml;\r\n FCharToH: TJvStrToHtml;\r\n FEndSection: string;\r\n FEndPara: string;\r\n FTitle: string;\r\n FFooter: TStrings;\r\n FHeader: TStrings;\r\n function AttToHtml(Value: TFontInfo): string;\r\n function ParaToHtml(Value: TJvParaAttributesRec): string; overload;\r\n function ParaToHtml(Value: TJvRichEditParaAttributesRec): string; overload;\r\n procedure SetFooter(const Value: TStrings);\r\n procedure SetHeader(const Value: TStrings);\r\n function IsFooterStored: Boolean;\r\n function IsHeaderStored: Boolean;\r\n procedure WriteEmptyStrings(Writer: TWriter);\r\n protected\r\n procedure DefineProperties(Filer: TFiler); override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n procedure ConvertToHtml(Value: TRichEdit; const FileName: string); overload;\r\n procedure ConvertToHtml(Value: TJvRichEdit; const FileName: string); overload;\r\n procedure ConvertToHtmlStrings(Value: TRichEdit; Strings: TStrings); overload;\r\n procedure ConvertToHtmlStrings(Value: TJvRichEdit; Strings: TStrings); overload;\r\n published\r\n property Title: string read FTitle write FTitle;\r\n property Header: TStrings read FHeader write SetHeader stored IsHeaderStored;\r\n property Footer: TStrings read FFooter write SetFooter stored IsFooterStored;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvRichEditToHtml.pas $';\r\n Revision: '$Revision: 13211 $';\r\n Date: '$Date: 2012-02-23 12:26:29 +0100 (jeu. 23 févr. 2012) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\n{$IFNDEF COMPILER12_UP}\r\nuses\r\n JvJCLUtils;\r\n{$ENDIF ~COMPILER12_UP}\r\n\r\nconst\r\n // (rom) needs renaming?\r\n// cHTMLHeadBegin = '';\r\n// cHTMLBodyBegin = '';\r\n// cHTMLBodyEnd = '';\r\n// cHTMLEnd = '';\r\n// cHTMLTitleFmt = '%s';\r\n\r\n cHTMLBR = '
';\r\n// cHTMLFontColorBegin = '',\r\n ' ',\r\n ' <#TITLE>',\r\n ' ',\r\n ' '\r\n );\r\n cDefaultFooter: array[0..1] of string = (\r\n ' ',\r\n ''\r\n );\r\n\r\n//=== { TFontInfo } ==========================================================\r\n\r\nconstructor TFontInfo.Create(APixelsPerInch: Integer);\r\nbegin\r\n inherited Create;\r\n FPixelsPerInch := APixelsPerInch;\r\nend;\r\n\r\nprocedure TFontInfo.Assign(Source: TPersistent);\r\nbegin\r\n if Source is TTextAttributes then\r\n begin\r\n FFontData.Name := TFontDataName(TTextAttributes(Source).Name);\r\n FFontData.Height := TTextAttributes(Source).Height;\r\n FFontData.Pitch := TTextAttributes(Source).Pitch;\r\n FFontData.Style := TTextAttributes(Source).Style;\r\n FFontData.Charset := TTextAttributes(Source).Charset;\r\n FColor := TTextAttributes(Source).Color;\r\n FLink := False;\r\n end\r\n else\r\n if Source is TJvTextAttributes then\r\n begin\r\n FFontData.Name := TFontDataName(TJvTextAttributes(Source).Name);\r\n FFontData.Height := TJvTextAttributes(Source).Height;\r\n FFontData.Pitch := TJvTextAttributes(Source).Pitch;\r\n FFontData.Style := TJvTextAttributes(Source).Style;\r\n FFontData.Charset := TJvTextAttributes(Source).Charset;\r\n FColor := TJvTextAttributes(Source).Color;\r\n FLink := TJvTextAttributes(Source).Link;\r\n end\r\n else\r\n if Source is TFontInfo then\r\n begin\r\n FFontData := TFontInfo(Source).FFontData;\r\n FColor := TFontInfo(Source).FColor;\r\n FLink := TFontInfo(Source).FLink;\r\n end\r\n else\r\n inherited Assign(Source);\r\nend;\r\n\r\nfunction TFontInfo.GetSize: Integer;\r\nbegin\r\n Result := -MulDiv(Height, 72, FPixelsPerInch);\r\nend;\r\n\r\nprocedure TFontInfo.SetSize(const Value: Integer);\r\nbegin\r\n FFontData.Height := -MulDiv(Value, FPixelsPerInch, 72);\r\nend;\r\n\r\n//=== { TJvRichEditToHtml } ==================================================\r\n\r\nconstructor TJvRichEditToHtml.Create(AOwner: TComponent);\r\nvar\r\n I: Integer;\r\nbegin\r\n inherited Create(AOwner);\r\n FCToH := TJvRgbToHtml.Create(Self);\r\n FCharToH := TJvStrToHtml.Create(Self);\r\n FHeader := TStringList.Create;\r\n for I := 0 to High(cDefaultHeader) do\r\n FHeader.Add(cDefaultHeader[I]);\r\n FFooter := TStringList.Create;\r\n for I := 0 to High(cDefaultFooter) do\r\n FFooter.Add(cDefaultFooter[I]);\r\nend;\r\n\r\ndestructor TJvRichEditToHtml.Destroy;\r\nbegin\r\n FCToH.Free;\r\n FCharToH.Free;\r\n FHeader.Free;\r\n FFooter.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvRichEditToHtml.ConvertToHtml(Value: TRichEdit; const FileName: string);\r\nvar\r\n S: TStringList;\r\nbegin\r\n S := TStringList.Create;\r\n try\r\n ConvertToHtmlStrings(Value, S);\r\n S.SaveToFile(FileName);\r\n finally\r\n S.Free;\r\n end;\r\nend;\r\n\r\nfunction TJvRichEditToHtml.AttToHtml(Value: TFontInfo): string;\r\nvar\r\n Size: Integer;\r\nbegin\r\n FEndSection := cHTMLFontEnd;\r\n FCToH.RgbColor := Value.Color;\r\n\r\n Size := Abs(Value.Size);\r\n if Size = 0 then\r\n Size := 8;\r\n Result := Format('',\r\n [FCToH.HtmlColor, Size, Value.Name]);\r\n if fsBold in Value.Style then\r\n begin\r\n FEndSection := cHTMLBoldEnd + FEndSection;\r\n Result := Result + cHTMLBoldBegin;\r\n end;\r\n if fsItalic in Value.Style then\r\n begin\r\n FEndSection := cHTMLItalicEnd + FEndSection;\r\n Result := Result + cHTMLItalicBegin;\r\n end;\r\n if fsStrikeout in Value.Style then\r\n begin\r\n FEndSection := cHTMLStrikeoutEnd + FEndSection;\r\n Result := Result + cHTMLStrikeoutBegin;\r\n end;\r\n if fsUnderline in Value.Style then\r\n begin\r\n FEndSection := cHTMLUnderlineEnd + FEndSection;\r\n Result := Result + cHTMLUnderlineBegin;\r\n end;\r\n\r\n// if Value.Link then\r\n// begin\r\n// FEndSection := '' + FEndSection;\r\n// Result := Result + '';\r\n// end;\r\nend;\r\n\r\nfunction Diff(One, Two: TFontInfo): Boolean;\r\nbegin\r\n Result := (One.Color <> Two.Color) or (One.Style <> Two.Style) or\r\n (One.Name <> Two.Name) or (One.Size <> Two.Size) or\r\n (One.Link <> Two.Link);\r\nend;\r\n\r\nfunction DiffPara(One, Two: TJvParaAttributesRec): Boolean;overload;\r\nbegin\r\n Result := (One.Alignment <> Two.Alignment) or (One.Numbering <> Two.Numbering);\r\nend;\r\n\r\nfunction DiffPara(One, Two: TJvRichEditParaAttributesRec): Boolean;overload;\r\nbegin\r\n Result := (One.Alignment <> Two.Alignment) or (One.Numbering <> Two.Numbering);\r\nend;\r\n\r\nprocedure TJvRichEditToHtml.ConvertToHtml(Value: TJvRichEdit; const FileName: string);\r\nvar\r\n S: TStringList;\r\nbegin\r\n S := TStringList.Create;\r\n try\r\n ConvertToHtmlStrings(Value, S);\r\n S.SaveToFile(FileName);\r\n finally\r\n S.Free;\r\n end;\r\nend;\r\n\r\nprocedure TJvRichEditToHtml.ConvertToHtmlStrings(Value: TRichEdit; Strings: TStrings);\r\nvar\r\n I, J: Integer;\r\n Datt, Att, CurrAt: TFontInfo;\r\n DPara, Para, CurrPara: TJvParaAttributesRec;\r\n St: TStringBuilder;\r\n FEnd: string;\r\n LOnChange: TNotifyEvent;\r\n LOnSelectionChange: TNotifyEvent;\r\n Text: string;\r\n Len: Integer;\r\n PreviousChar: Char;\r\nbegin\r\n LOnChange := Value.OnChange;\r\n LOnSelectionChange := Value.OnSelectionChange;\r\n Strings.BeginUpdate;\r\n Value.Lines.BeginUpdate;\r\n try\r\n Value.OnChange := nil;\r\n Value.OnSelectionChange := nil;\r\n\r\n Strings.Clear;\r\n if Header.Count > 0 then\r\n Strings.Add(StringReplace(Header.Text, '<#TITLE>', Title, [rfReplaceAll]));\r\n Datt := TFontInfo.Create(Value.Font.PixelsPerInch);\r\n Att := TFontInfo.Create(Value.Font.PixelsPerInch);\r\n CurrAt := TFontInfo.Create(Value.Font.PixelsPerInch);\r\n\r\n DPara.Alignment := taLeftJustify;\r\n DPara.Numbering := ComCtrls.nsNone;\r\n CurrPara.Alignment := DPara.Alignment;\r\n CurrPara.Numbering := DPara.Numbering;\r\n Strings.Add(ParaToHtml(Para));\r\n\r\n Datt.Assign(Value.DefAttributes);\r\n Strings.Add(AttToHtml(Datt));\r\n\r\n CurrAt.Assign(Datt);\r\n Value.SelStart := 0;\r\n Value.SelectAll;\r\n Text := Value.SelText;\r\n Len := Length(Text);\r\n St := TStringBuilder.Create;\r\n try\r\n I := 1;\r\n Value.SelLength := 1;\r\n while I <= Len do\r\n begin\r\n // new line\r\n Value.SelStart := I - 1;\r\n Att.Assign(Value.SelAttributes);\r\n Para.Alignment := Value.Paragraph.Alignment;\r\n Para.Numbering := Value.Paragraph.Numbering;\r\n\r\n St.Length := 0;\r\n if DiffPara(Para, CurrPara) or (Para.Numbering = ComCtrls.nsBullet) then\r\n begin\r\n St.Append(FEndSection).Append(FEndPara);\r\n CurrPara.Alignment := Para.Alignment;\r\n CurrPara.Numbering := Para.Numbering;\r\n CurrAt.Assign(Att);\r\n St.Append(ParaToHtml(Para)).Append(AttToHtml(Att));\r\n end;\r\n\r\n J := I;\r\n PreviousChar := #0;\r\n while (J <= Len) and not CharInSet(Text[J], [#$A, #$B, #$D]) do { RICHEDIT uses #$B also for line breaking }\r\n begin\r\n Att.Assign(Value.SelAttributes);\r\n if Diff(Att, CurrAt) then\r\n begin\r\n St.Append(FEndSection);\r\n CurrAt.Assign(Att);\r\n St.Append(AttToHtml(Att));\r\n Value.SelStart := J;\r\n end\r\n else\r\n begin\r\n if (Text[J] = ' ') and (PreviousChar = ' ') then\r\n St.Append(' ')\r\n else\r\n St.Append(CharToHtml(Text[J]));\r\n PreviousChar := Text[J];\r\n Inc(J);\r\n Value.SelStart := J;\r\n end;\r\n end;\r\n if I = 1 then\r\n Strings.Add(St.ToString())\r\n else\r\n Strings.Add(cHTMLBR + St.ToString());\r\n I := J + 1;\r\n end;\r\n finally\r\n St.Free;\r\n end;\r\n Strings.Add(FEndSection);\r\n Strings.Add(FEndPara);\r\n\r\n Datt.Free;\r\n Att.Free;\r\n CurrAt.Free;\r\n\r\n Strings.Add(FEnd);\r\n Strings.AddStrings(Footer);\r\n finally\r\n Value.OnChange := LOnChange;\r\n Value.OnSelectionChange := LOnSelectionChange;\r\n Strings.EndUpdate;\r\n Value.Lines.EndUpdate;\r\n end;\r\nend;\r\n\r\nprocedure TJvRichEditToHtml.ConvertToHtmlStrings(Value: TJvRichEdit; Strings: TStrings);\r\nvar\r\n I, J: Integer;\r\n Datt, Att, CurrAt: TFontInfo;\r\n DPara, Para, CurrPara: TJvRichEditParaAttributesRec;\r\n St: TStringBuilder;\r\n FEnd: string;\r\n LOnChange: TNotifyEvent;\r\n LOnSelectionChange: TNotifyEvent;\r\n Text: string;\r\n Len: Integer;\r\n PreviousChar: Char;\r\nbegin\r\n LOnChange := Value.OnChange;\r\n LOnSelectionChange := Value.OnSelectionChange;\r\n Strings.BeginUpdate;\r\n Value.Lines.BeginUpdate;\r\n try\r\n Value.OnChange := nil;\r\n Value.OnSelectionChange := nil;\r\n\r\n Strings.Clear;\r\n if Header.Count > 0 then\r\n Strings.Add(StringReplace(Header.Text, '<#TITLE>', Title, [rfReplaceAll]));\r\n Datt := TFontInfo.Create(Value.Font.PixelsPerInch);\r\n Att := TFontInfo.Create(Value.Font.PixelsPerInch);\r\n CurrAt := TFontInfo.Create(Value.Font.PixelsPerInch);\r\n\r\n DPara.Alignment := paLeftJustify;\r\n DPara.Numbering := nsNone;\r\n CurrPara.Alignment := DPara.Alignment;\r\n CurrPara.Numbering := DPara.Numbering;\r\n Strings.Add(ParaToHtml(Para));\r\n\r\n Datt.Assign(Value.DefAttributes);\r\n Strings.Add(AttToHtml(Datt));\r\n\r\n CurrAt.Assign(Datt);\r\n Value.SelStart := 0;\r\n Value.SelectAll;\r\n Text := Value.SelText;\r\n Len := Length(Text);\r\n St := TStringBuilder.Create;\r\n try\r\n I := 1;\r\n Value.SelLength := 1;\r\n while I <= Len do\r\n begin\r\n // new line\r\n Value.SelStart := I - 1;\r\n Att.Assign(Value.SelAttributes);\r\n Para.Alignment := Value.Paragraph.Alignment;\r\n Para.Numbering := Value.Paragraph.Numbering;\r\n\r\n St.Length := 0;\r\n if DiffPara(Para, CurrPara) or (Para.Numbering = nsBullet) then\r\n begin\r\n St.Append(FEndSection).Append(FEndPara);\r\n CurrPara.Alignment := Para.Alignment;\r\n CurrPara.Numbering := Para.Numbering;\r\n CurrAt.Assign(Att);\r\n St.Append(ParaToHtml(Para)).Append(AttToHtml(Att));\r\n end;\r\n\r\n J := I;\r\n PreviousChar := #0;\r\n while (J <= Len) and not CharInSet(Text[J], [#$A, #$B, #$D]) do { RICHEDIT uses #$B also for line breaking }\r\n begin\r\n Att.Assign(Value.SelAttributes);\r\n if Diff(Att, CurrAt) then\r\n begin\r\n St.Append(FEndSection);\r\n CurrAt.Assign(Att);\r\n St.Append(AttToHtml(Att));\r\n Value.SelStart := J;\r\n end\r\n else\r\n begin\r\n if (Text[J] = ' ') and (PreviousChar = ' ') then\r\n St.Append(' ')\r\n else\r\n St.Append(CharToHtml(Text[J]));\r\n PreviousChar := Text[J];\r\n Inc(J);\r\n Value.SelStart := J;\r\n end;\r\n end;\r\n if I = 1 then\r\n Strings.Add(St.ToString())\r\n else\r\n Strings.Add(cHTMLBR + St.ToString());\r\n I := J + 1;\r\n end;\r\n finally\r\n St.Free;\r\n end;\r\n Strings.Add(FEndSection);\r\n Strings.Add(FEndPara);\r\n\r\n Datt.Free;\r\n Att.Free;\r\n CurrAt.Free;\r\n\r\n Strings.Add(FEnd);\r\n Strings.AddStrings(Footer);\r\n finally\r\n Value.OnChange := LOnChange;\r\n Value.OnSelectionChange := LOnSelectionChange;\r\n Strings.EndUpdate;\r\n Value.Lines.EndUpdate;\r\n end;\r\nend;\r\n\r\nfunction TJvRichEditToHtml.ParaToHtml(Value: TJvRichEditParaAttributesRec): string;\r\nbegin\r\n case Value.Alignment of\r\n paLeftJustify:\r\n Result := 'STYLE=\"text-align: left;\"';\r\n paRightJustify:\r\n Result := 'STYLE=\"text-align: right;\"';\r\n paCenter:\r\n Result := 'STYLE=\"text-align: center;\"';\r\n end;\r\n if Value.Numbering = nsBullet then\r\n begin\r\n Result := '
  • ';\r\n FEndPara := '
    • ';\r\n end\r\n else\r\n begin\r\n Result := '

    ';\r\n FEndPara := '

    ';\r\n end\r\nend;\r\n\r\nfunction TJvRichEditToHtml.ParaToHtml(Value: TJvParaAttributesRec): string;\r\nbegin\r\n case Value.Alignment of\r\n Classes.taLeftJustify:\r\n Result := 'STYLE=\"text-align: left;\"';\r\n Classes.taRightJustify:\r\n Result := 'STYLE=\"text-align: right;\"';\r\n Classes.taCenter:\r\n Result := 'STYLE=\"text-align: center;\"';\r\n end;\r\n if Value.Numbering = ComCtrls.nsBullet then\r\n begin\r\n Result := '
  • ';\r\n FEndPara := '
    • ';\r\n end\r\n else\r\n begin\r\n Result := '

    ';\r\n FEndPara := '

    ';\r\n end\r\nend;\r\n\r\nprocedure TJvRichEditToHtml.SetFooter(const Value: TStrings);\r\nbegin\r\n if Value <> FFooter then\r\n FFooter.Assign(Value);\r\nend;\r\n\r\nprocedure TJvRichEditToHtml.SetHeader(const Value: TStrings);\r\nbegin\r\n if Value <> FHeader then\r\n FHeader.Assign(Value);\r\nend;\r\n\r\nfunction TJvRichEditToHtml.IsFooterStored: Boolean;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := Footer.Count <> Length(cDefaultFooter);\r\n if not Result then\r\n begin\r\n Result := True;\r\n for I := 0 to High(cDefaultFooter) do\r\n if Footer[I] <> cDefaultFooter[I] then\r\n Exit;\r\n Result := False;\r\n end;\r\nend;\r\n\r\nfunction TJvRichEditToHtml.IsHeaderStored: Boolean;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := Header.Count <> Length(cDefaultHeader);\r\n if not Result then\r\n begin\r\n Result := True;\r\n for I := 0 to High(cDefaultHeader) do\r\n if Header[I] <> cDefaultHeader[I] then\r\n Exit;\r\n Result := False;\r\n end;\r\nend;\r\n\r\nprocedure TJvRichEditToHtml.WriteEmptyStrings(Writer: TWriter);\r\nbegin\r\n Writer.WriteListBegin;\r\n Writer.WriteListEnd;\r\nend;\r\n\r\nprocedure TJvRichEditToHtml.DefineProperties(Filer: TFiler);\r\n\r\n function DoWriteHeader: Boolean;\r\n begin\r\n Result := Header.Count = 0;\r\n if Result and (Filer.Ancestor <> nil) then\r\n begin\r\n Result := True;\r\n if Filer.Ancestor is TJvRichEditToHtml then\r\n Result := not Header.Equals(TJvRichEditToHtml(Filer.Ancestor).Header)\r\n end;\r\n end;\r\n\r\n function DoWriteFooter: Boolean;\r\n begin\r\n Result := Footer.Count = 0;\r\n if Result and (Filer.Ancestor <> nil) then\r\n begin\r\n Result := True;\r\n if Filer.Ancestor is TJvRichEditToHtml then\r\n Result := not Footer.Equals(TJvRichEditToHtml(Filer.Ancestor).Footer)\r\n end;\r\n end;\r\n\r\nbegin\r\n inherited DefineProperties(Filer);\r\n { Write empty Header/Footer to DFM because the default value differs from '' }\r\n if Filer is TWriter then\r\n begin\r\n Filer.DefineProperty('Header.Strings', nil, WriteEmptyStrings, DoWriteHeader);\r\n Filer.DefineProperty('Footer.Strings', nil, WriteEmptyStrings, DoWriteFooter);\r\n end;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvRollOut.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvRollOut.PAS, released on 2002-05-26.\r\n\r\nThe Initial Developer of the Original Code is Peter Thrnqvist [peter3 at sourceforge dot net]\r\nPortions created by Peter Thrnqvist are Copyright (C) 2002 Peter Thrnqvist.\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nDescription:\r\n TJvRollOut is an autoexpanding / collapsing panel.\r\n\r\nKnown Issues:\r\n Doesn't draw an underline for speed-keys (the '&' character ) if\r\n Placement = plLeft. Something with DrawText ?\r\n\r\nChanges 2003-03-23:\r\n * Several properties have changed and been put into nested sub-properties.\r\n To update current usage do the following:\r\n - Color: change to Colors.Color\r\n - ButtonColor: change to Colors.ButtonColor\r\n - ButtonColTop: change to Colors.ButtonTop\r\n - ButtonColBtm: change to Colors.ButtonBottom\r\n - ColHiText: change to Colors.HotTrackText\r\n - FrameColTop: change to Colors.FrameTop\r\n - FrameColBtm: change to Colors.FrameBottom\r\n - ImageExpanded: change to ImageOptions.IndexExpanded\r\n - ImageCollapsed: change to ImageOptions.IndexCollapsed\r\n - ImageList: change to ImageOptions.Images\r\n - ImageOffset: change to ImageOptions.Offset // peter3\r\n\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvRollOut.pas 13415 2012-09-10 09:51:54Z obones $\r\n\r\nunit JvRollOut;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n SysUtils, Classes,\r\n Windows, Forms, Messages, Controls, Graphics, ImgList, ExtCtrls, ActnList,\r\n {$IFDEF HAS_UNIT_SYSTEM_UITYPES}\r\n System.UITypes,\r\n {$ENDIF HAS_UNIT_SYSTEM_UITYPES}\r\n JvExtComponent, JvThemes;\r\n\r\nconst\r\n CM_EXPANDED = WM_USER + 155;\r\n DefaultButtonColor = clBtnFace;\r\n DefaultHotTextColor = clWindowText;\r\n\r\ntype\r\n TJvPlacement = (plTop, plLeft);\r\n\r\n TJvRollOutColors = class(TPersistent)\r\n private\r\n FFrameBottom: TColor;\r\n FHotTrackText: TColor;\r\n FFrameTop: TColor;\r\n FColor: TColor;\r\n FButtonTop: TColor;\r\n FButtonBottom: TColor;\r\n FOnChange: TNotifyEvent;\r\n FButtonColor: TColor;\r\n procedure SetButtonBottom(const Value: TColor);\r\n procedure SetButtonTop(const Value: TColor);\r\n procedure SetColor(const Value: TColor);\r\n procedure SetFrameBottom(const Value: TColor);\r\n procedure SetFrameTop(const Value: TColor);\r\n procedure SetHotTrackText(const Value: TColor);\r\n procedure SetButtonColor(const Value: TColor);\r\n protected\r\n procedure Change;\r\n public\r\n constructor Create;\r\n published\r\n property ButtonBottom: TColor read FButtonBottom write SetButtonBottom default clBtnShadow;\r\n property ButtonTop: TColor read FButtonTop write SetButtonTop default clBtnHighlight;\r\n property ButtonColor: TColor read FButtonColor write SetButtonColor default DefaultButtonColor;\r\n property HotTrackText: TColor read FHotTrackText write SetHotTrackText default DefaultHotTextColor;\r\n property Color: TColor read FColor write SetColor default clBtnFace;\r\n property FrameBottom: TColor read FFrameBottom write SetFrameBottom default clBtnHighlight;\r\n property FrameTop: TColor read FFrameTop write SetFrameTop default clBtnShadow;\r\n property OnChange: TNotifyEvent read FOnChange write FOnChange;\r\n end;\r\n\r\n TJvRollOutImageOptions = class(TPersistent)\r\n private\r\n FOffset: Integer;\r\n FImages: TCustomImageList;\r\n FIndexCollapsed: TImageIndex;\r\n FIndexExpanded: TImageIndex;\r\n FOnChange: TNotifyEvent;\r\n FChangeLink: TChangeLink;\r\n FOwner: TComponent;\r\n procedure SetImages(const Value: TCustomImageList);\r\n procedure SetIndexCollapsed(const Value: TImageIndex);\r\n procedure SetIndexExpanded(const Value: TImageIndex);\r\n procedure SetOffset(const Value: Integer);\r\n protected\r\n procedure Change;\r\n procedure DoChangeLink(Sender: TObject);\r\n public\r\n constructor Create;\r\n destructor Destroy; override;\r\n published\r\n property IndexCollapsed: TImageIndex read FIndexCollapsed write SetIndexCollapsed default 1;\r\n property IndexExpanded: TImageIndex read FIndexExpanded write SetIndexExpanded default 0;\r\n property Images: TCustomImageList read FImages write SetImages;\r\n property Offset: Integer read FOffset write SetOffset default 5;\r\n property OnChange: TNotifyEvent read FOnChange write FOnChange;\r\n end;\r\n\r\n TJvCustomRollOut = class(TJvCustomPanel)\r\n private\r\n FGroupIndex: Integer;\r\n FButtonRect: TRect;\r\n FPlacement: TJvPlacement;\r\n FCollapsed: Boolean;\r\n FMouseDown: Boolean;\r\n FInsideButton: Boolean;\r\n FCWidth: Integer;\r\n FCHeight: Integer;\r\n FAWidth: Integer;\r\n FAHeight: Integer;\r\n FButtonHeight: Integer;\r\n FChildOffset: Integer;\r\n FOnExpand: TNotifyEvent;\r\n FOnCollapse: TNotifyEvent;\r\n FColors: TJvRollOutColors;\r\n FImageOptions: TJvRollOutImageOptions;\r\n FToggleAnywhere: Boolean;\r\n FShowFocus: Boolean;\r\n FChildControlVisibility: TStringList;\r\n\r\n FButtonFont: TFont;\r\n FCollapsedList: array of Boolean;\r\n FSmartExpand: Boolean;\r\n FSmartShow: Boolean;\r\n FTopForm: TForm;\r\n FOldParent: TControl;\r\n FOldPos: TPoint;\r\n FOldWidthHeight: TPoint;\r\n FOldAlign: TAlign;\r\n\r\n procedure SetGroupIndex(Value: Integer);\r\n procedure SetPlacement(Value: TJvPlacement);\r\n\r\n procedure WriteAWidth(Writer: TWriter);\r\n procedure WriteAHeight(Writer: TWriter);\r\n procedure WriteCWidth(Writer: TWriter);\r\n procedure WriteCHeight(Writer: TWriter);\r\n procedure ReadAWidth(Reader: TReader);\r\n procedure ReadAHeight(Reader: TReader);\r\n procedure ReadCWidth(Reader: TReader);\r\n procedure ReadCHeight(Reader: TReader);\r\n\r\n procedure SetCollapsed(Value: Boolean);\r\n procedure SetButtonHeight(Value: Integer);\r\n procedure SetChildOffset(Value: Integer);\r\n procedure RedrawControl(DrawAll: Boolean);\r\n procedure DrawButtonFrame;\r\n procedure UpdateGroup;\r\n procedure SetExpandedSize(const Value: Integer);\r\n procedure CMExpanded(var Msg: TMessage); message CM_EXPANDED;\r\n procedure ChangeHeight(NewHeight: Integer);\r\n procedure ChangeWidth(NewWidth: Integer);\r\n procedure SetShowFocus(const Value: Boolean);\r\n procedure SetButtonFont(const Value: TFont);\r\n\r\n procedure SetSmartExpand(const Value: Boolean);\r\n procedure OnTopDeactivate(Sender : TObject);\r\n procedure RestoreFromTopForm;\r\n procedure PutOnForm;\r\n function IsButtonFontStored: Boolean;\r\n protected\r\n // When the rollout-panel is collaped all contained controls are hidden\r\n // to avoid tabbing into the child when the child is not visible or the\r\n // rollout-caption-button being hidden by a contained control that is\r\n // aligned tot he bottom\r\n // The original visiblility of each control is restored then the rollout\r\n // is expanded again\r\n procedure CheckChildVisibility;\r\n\r\n procedure FocusKilled(NextWnd: THandle); override;\r\n procedure FocusSet(PrevWnd: THandle); override;\r\n function DoEraseBackground(Canvas: TCanvas; Param: LPARAM): Boolean; override;\r\n procedure MouseEnter(Control: TControl); override;\r\n procedure MouseLeave(Control: TControl); override;\r\n function WantKey(Key: Integer; Shift: TShiftState): Boolean; override;\r\n procedure ParentColorChanged; override;\r\n procedure CreateWnd; override;\r\n procedure Notification(AComponent: TComponent; Operation: TOperation); override;\r\n procedure AlignControls(AControl: TControl; var Rect: TRect); override;\r\n procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;\r\n procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;\r\n procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;\r\n procedure DefineProperties(Filer: TFiler); override;\r\n procedure DoExpand; dynamic;\r\n procedure DoCollapse; dynamic;\r\n procedure Paint; override;\r\n procedure Click; override;\r\n procedure DoImageOptionsChange(Sender: TObject);\r\n procedure DoColorsChange(Sender: TObject);\r\n procedure DoButtonFontChange(Sender: TObject);\r\n property ButtonFont: TFont read FButtonFont write SetButtonFont stored IsButtonFontStored;\r\n property ButtonHeight: Integer read FButtonHeight write SetButtonHeight default 20;\r\n property ChildOffset: Integer read FChildOffset write SetChildOffset default 0;\r\n property Collapsed: Boolean read FCollapsed write SetCollapsed default False;\r\n property Colors: TJvRollOutColors read FColors write FColors;\r\n property GroupIndex: Integer read FGroupIndex write SetGroupIndex default 0;\r\n property ImageOptions: TJvRollOutImageOptions read FImageOptions write FImageOptions;\r\n property Placement: TJvPlacement read FPlacement write SetPlacement default plTop;\r\n property ShowFocus: Boolean read FShowFocus write SetShowFocus default True;\r\n property ToggleAnywhere: Boolean read FToggleAnywhere write FToggleAnywhere default True;\r\n property SmartExpand: Boolean read FSmartExpand write SetSmartExpand default True;\r\n property SmartShow: Boolean read FSmartShow write FSmartShow default True;\r\n\r\n property OnCollapse: TNotifyEvent read FOnCollapse write FOnCollapse;\r\n property OnExpand: TNotifyEvent read FOnExpand write FOnExpand;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n function MouseIsOnButton: Boolean;\r\n procedure SetBounds(ALeft, ATop, AWidth, AHeight: Integer); override;\r\n procedure Collapse; virtual;\r\n procedure Expand; virtual;\r\n\r\n property ExpandedSize: Integer write SetExpandedSize stored False;\r\n end;\r\n\r\n TJvRollOutAction = class(TAction)\r\n private\r\n FRollOut: TJvCustomRollOut;\r\n FLinkCheckedToCollapsed: Boolean;\r\n procedure SetRollOut(const Value: TJvCustomRollOut);\r\n procedure SetLinkCheckedToCollapsed(const Value: Boolean);\r\n protected\r\n procedure Notification(AComponent: TComponent; Operation: TOperation); override;\r\n public\r\n procedure ExecuteTarget(Target: TObject); override;\r\n procedure UpdateTarget(Target: TObject); override;\r\n function HandlesTarget(Target: TObject): Boolean; override;\r\n function Execute: Boolean; override;\r\n destructor Destroy; override;\r\n published\r\n property RollOut: TJvCustomRollOut read FRollOut write SetRollOut;\r\n property LinkCheckedToCollapsed: Boolean read FLinkCheckedToCollapsed write SetLinkCheckedToCollapsed;\r\n end;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvRollOut = class(TJvCustomRollOut)\r\n published\r\n property Action;\r\n property Align;\r\n property BevelWidth;\r\n property BorderWidth;\r\n property ButtonFont;\r\n property ButtonHeight;\r\n property Caption;\r\n property ChildOffset;\r\n property Placement;\r\n property Collapsed;\r\n property Colors;\r\n property DragCursor;\r\n property DragMode;\r\n property Enabled;\r\n property Font;\r\n property GroupIndex;\r\n property ImageOptions;\r\n {$IFDEF JVCLThemesEnabled}\r\n property ParentBackground default True;\r\n {$ENDIF JVCLThemesEnabled}\r\n property ParentColor;\r\n property ParentFont;\r\n property ParentShowHint;\r\n property PopupMenu;\r\n property ShowFocus;\r\n property ShowHint;\r\n property SmartExpand;\r\n property SmartShow;\r\n property TabOrder;\r\n property TabStop;\r\n property ToggleAnywhere;\r\n property Visible;\r\n property OnClick;\r\n property OnDragDrop;\r\n property OnDragOver;\r\n property OnEndDrag;\r\n property OnEnter;\r\n property OnExit;\r\n property OnMouseDown;\r\n property OnMouseMove;\r\n property OnMouseUp;\r\n property OnStartDrag;\r\n property OnExpand;\r\n property OnCollapse;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvRollOut.pas $';\r\n Revision: '$Revision: 13415 $';\r\n Date: '$Date: 2012-09-10 11:51:54 +0200 (lun. 10 sept. 2012) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n Types,\r\n JvJVCLUtils; // for IsAccel()\r\n\r\n\r\n// (p3) not used\r\n// const\r\n// cIncrement = 24;\r\n// cSmooth = False;\r\n\r\n\r\nprocedure SetTextAngle(Cnv: TCanvas; Angle: Integer);\r\nvar\r\n FntLogRec: TLogFont;\r\nbegin\r\n GetObject(Cnv.Font.Handle, SizeOf(FntLogRec), Addr(FntLogRec));\r\n FntLogRec.lfEscapement := Angle * 10;\r\n FntLogRec.lfOutPrecision := OUT_TT_ONLY_PRECIS;\r\n Cnv.Font.Handle := CreateFontIndirect(FntLogRec);\r\nend;\r\n\r\n\r\nprocedure InternalFrame3D(Canvas: TCanvas; var Rect: TRect; TopColor, BottomColor: TColor; Width: Integer);\r\n\r\n procedure DoRect;\r\n var\r\n TopRight, BottomLeft: TPoint;\r\n begin\r\n TopRight.X := Rect.Right;\r\n TopRight.Y := Rect.Top;\r\n BottomLeft.X := Rect.Left;\r\n BottomLeft.Y := Rect.Bottom;\r\n if TopColor <> clNone then\r\n begin\r\n Canvas.Pen.Color := TopColor;\r\n Canvas.PolyLine([BottomLeft, Rect.TopLeft, TopRight]);\r\n end;\r\n if BottomColor <> clNone then\r\n begin\r\n Canvas.Pen.Color := BottomColor;\r\n Dec(BottomLeft.X);\r\n Canvas.PolyLine([TopRight, Rect.BottomRight, BottomLeft]);\r\n end;\r\n end;\r\n\r\nbegin\r\n Canvas.Pen.Width := 1;\r\n Dec(Rect.Bottom);\r\n Dec(Rect.Right);\r\n while Width > 0 do\r\n begin\r\n Dec(Width);\r\n DoRect;\r\n InflateRect(Rect, -1, -1);\r\n end;\r\n Inc(Rect.Bottom);\r\n Inc(Rect.Right);\r\nend;\r\n\r\n//=== { TJvRollOutImageOptions } =============================================\r\n\r\nconstructor TJvRollOutImageOptions.Create;\r\nbegin\r\n inherited Create;\r\n FChangeLink := TChangeLink.Create;\r\n FChangeLink.OnChange := DoChangeLink;\r\n FIndexCollapsed := 1;\r\n FIndexExpanded := 0;\r\n FOffset := 5;\r\nend;\r\n\r\ndestructor TJvRollOutImageOptions.Destroy;\r\nbegin\r\n FChangeLink.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvRollOutImageOptions.Change;\r\nbegin\r\n if Assigned(FOnChange) then\r\n FOnChange(Self);\r\nend;\r\n\r\nprocedure TJvRollOutImageOptions.DoChangeLink(Sender: TObject);\r\nbegin\r\n Change;\r\nend;\r\n\r\nprocedure TJvRollOutImageOptions.SetImages(const Value: TCustomImageList);\r\nbegin\r\n ReplaceImageListReference(FOwner, Value, FImages, FChangeLink);\r\n Change;\r\nend;\r\n\r\nprocedure TJvRollOutImageOptions.SetIndexCollapsed(const Value: TImageIndex);\r\nbegin\r\n if FIndexCollapsed <> Value then\r\n begin\r\n FIndexCollapsed := Value;\r\n Change;\r\n end;\r\nend;\r\n\r\nprocedure TJvRollOutImageOptions.SetIndexExpanded(const Value: TImageIndex);\r\nbegin\r\n if FIndexExpanded <> Value then\r\n begin\r\n FIndexExpanded := Value;\r\n Change;\r\n end;\r\nend;\r\n\r\nprocedure TJvRollOutImageOptions.SetOffset(const Value: Integer);\r\nbegin\r\n if FOffset <> Value then\r\n begin\r\n FOffset := Value;\r\n Change;\r\n end;\r\nend;\r\n\r\n//=== { TJvRollOutColors } ===================================================\r\n\r\nconstructor TJvRollOutColors.Create;\r\nbegin\r\n inherited Create;\r\n FButtonBottom := clBtnShadow;\r\n FButtonTop := clBtnHighlight;\r\n FButtonColor := DefaultButtonColor;\r\n FHotTrackText := DefaultHotTextColor;\r\n FColor := clBtnFace;\r\n FFrameBottom := clBtnHighlight;\r\n FFrameTop := clBtnShadow;\r\nend;\r\n\r\nprocedure TJvRollOutColors.Change;\r\nbegin\r\n if Assigned(FOnChange) then\r\n FOnChange(Self);\r\nend;\r\n\r\nprocedure TJvRollOutColors.SetButtonBottom(const Value: TColor);\r\nbegin\r\n if FButtonBottom <> Value then\r\n begin\r\n FButtonBottom := Value;\r\n Change;\r\n end;\r\nend;\r\n\r\nprocedure TJvRollOutColors.SetButtonColor(const Value: TColor);\r\nbegin\r\n if FButtonColor <> Value then\r\n begin\r\n FButtonColor := Value;\r\n Change;\r\n end;\r\nend;\r\n\r\nprocedure TJvRollOutColors.SetButtonTop(const Value: TColor);\r\nbegin\r\n if FButtonTop <> Value then\r\n begin\r\n FButtonTop := Value;\r\n Change;\r\n end;\r\nend;\r\n\r\nprocedure TJvRollOutColors.SetColor(const Value: TColor);\r\nbegin\r\n if FColor <> Value then\r\n begin\r\n FColor := Value;\r\n Change;\r\n end;\r\nend;\r\n\r\nprocedure TJvRollOutColors.SetFrameBottom(const Value: TColor);\r\nbegin\r\n if FFrameBottom <> Value then\r\n begin\r\n FFrameBottom := Value;\r\n Change;\r\n end;\r\nend;\r\n\r\nprocedure TJvRollOutColors.SetFrameTop(const Value: TColor);\r\nbegin\r\n if FFrameTop <> Value then\r\n begin\r\n FFrameTop := Value;\r\n Change;\r\n end;\r\nend;\r\n\r\nprocedure TJvRollOutColors.SetHotTrackText(const Value: TColor);\r\nbegin\r\n if FHotTrackText <> Value then\r\n begin\r\n FHotTrackText := Value;\r\n Change;\r\n end;\r\nend;\r\n\r\n//=== { TJvCustomRollOut } ===================================================\r\n\r\nconstructor TJvCustomRollOut.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n IncludeThemeStyle(Self, [csNeedsBorderPaint, csParentBackground]);\r\n FImageOptions := TJvRollOutImageOptions.Create;\r\n FImageOptions.FOwner := Self;\r\n FImageOptions.OnChange := DoImageOptionsChange;\r\n\r\n FColors := TJvRollOutColors.Create;\r\n FColors.OnChange := DoColorsChange;\r\n FToggleAnywhere := True;\r\n FGroupIndex := 0;\r\n FCollapsed := False;\r\n FMouseDown := False;\r\n FInsideButton := False;\r\n FChildOffset := 0;\r\n FButtonHeight := 20;\r\n FPlacement := plTop;\r\n SetBounds(0, 0, 145, 170);\r\n FAWidth := 145;\r\n FAHeight := 170;\r\n FCWidth := 22;\r\n FCHeight := 22;\r\n FShowFocus := True;\r\n\r\n FButtonFont := TFont.Create;\r\n FButtonFont.Name := 'Verdana';\r\n FButtonFont.Size := 7;\r\n FButtonFont.Style := [fsBold];\r\n FButtonFont.Color := clWindowText;\r\n FButtonFont.OnChange := DoButtonFontChange;\r\n\r\n // SmartExpand / SmartShow\r\n FSmartExpand := True;\r\n FSmartShow := True;\r\n\r\n FTopForm := TForm.Create(self);\r\n with FTopForm do\r\n begin\r\n BorderStyle := bsNone;\r\n FormStyle := fsStayOnTop;\r\n OnDeactivate := OnTopDeactivate;\r\n Position := poDesigned;\r\n end;\r\n FOldParent := nil;\r\n\r\n ControlStyle := ControlStyle - [csDoubleClicks]; // Doubleclicks are converted into single clicks\r\nend;\r\n\r\ndestructor TJvCustomRollOut.Destroy;\r\nbegin\r\n FreeAndNil(FButtonFont);\r\n FreeAndNil(FImageOptions);\r\n FreeAndNil(FChildControlVisibility);\r\n FreeAndNil(FColors);\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvCustomRollOut.Click;\r\nbegin\r\n if (Action = nil) and (MouseIsOnButton or ToggleAnywhere) then\r\n Collapsed := not FCollapsed;\r\n inherited Click;\r\n RedrawControl(False);\r\nend;\r\n\r\nprocedure TJvCustomRollOut.CreateWnd;\r\nbegin\r\n inherited CreateWnd;\r\n if not Collapsed then\r\n UpdateGroup;\r\nend;\r\n\r\nprocedure TJvCustomRollOut.AlignControls(AControl: TControl; var Rect: TRect);\r\nbegin\r\n Rect.Left := Rect.Left + ChildOffset;\r\n if FPlacement = plTop then\r\n Rect.Top := Rect.Top + FButtonHeight\r\n else\r\n Rect.Left := Rect.Left + FButtonHeight;\r\n inherited AlignControls(AControl, Rect);\r\nend;\r\n\r\nprocedure TJvCustomRollOut.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);\r\nbegin\r\n inherited MouseDown(Button, Shift, X, Y);\r\n if not FMouseDown then\r\n begin\r\n FMouseDown := True;\r\n RedrawControl(False);\r\n if CanFocus {and not (csDesigning in ComponentState)} then\r\n SetFocus;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomRollOut.MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);\r\nbegin\r\n inherited MouseUp(Button, Shift, X, Y);\r\n if FMouseDown then\r\n begin\r\n FMouseDown := False;\r\n RedrawControl(False);\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomRollOut.MouseMove(Shift: TShiftState; X, Y: Integer);\r\nvar\r\n B: Boolean;\r\nbegin\r\n B := FInsideButton;\r\n inherited MouseMove(Shift, X, Y);\r\n FInsideButton := PtInRect(FButtonRect, Point(X, Y));\r\n if FInsideButton <> B then\r\n RedrawControl(False);\r\nend;\r\n\r\nprocedure TJvCustomRollOut.RedrawControl(DrawAll: Boolean);\r\nbegin\r\n if DrawAll then\r\n Invalidate\r\n else\r\n DrawButtonFrame;\r\nend;\r\n\r\nprocedure TJvCustomRollOut.SetGroupIndex(Value: Integer);\r\nbegin\r\n if FGroupIndex <> Value then\r\n begin\r\n FGroupIndex := Value;\r\n if not Collapsed then\r\n UpdateGroup;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomRollOut.SetPlacement(Value: TJvPlacement);\r\nbegin\r\n if FPlacement <> Value then\r\n begin\r\n FPlacement := Value;\r\n if Collapsed then\r\n begin\r\n if FPlacement = plTop then\r\n Height := FCHeight\r\n else\r\n Width := FCWidth;\r\n end\r\n else\r\n begin\r\n if FPlacement = plTop then\r\n Height := FAHeight\r\n else\r\n Width := FAWidth;\r\n end;\r\n if FPlacement = plTop then\r\n FButtonRect := Rect(1, 1, Width - 1, FButtonHeight - 1)\r\n else\r\n FButtonRect := Rect(1, 1, FButtonHeight - 1, Height - 1);\r\n Realign;\r\n RedrawControl(True);\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomRollOut.SetCollapsed(Value: Boolean);\r\nbegin\r\n if FCollapsed <> Value then\r\n begin\r\n FCollapsed := Value;\r\n if FCollapsed then\r\n begin\r\n // If Rollout panel was floating (= mapped onto a special form)\r\n // -> restore old state\r\n if FSmartShow and (FOldParent <> nil) then\r\n RestoreFromTopForm;\r\n\r\n if Placement = plTop then\r\n ChangeHeight(FCHeight)\r\n else\r\n ChangeWidth(FCWidth);\r\n DoCollapse;\r\n end\r\n else\r\n begin\r\n if Placement = plTop then\r\n ChangeHeight(FAHeight)\r\n else\r\n ChangeWidth(FAWidth);\r\n DoExpand;\r\n UpdateGroup;\r\n end;\r\n CheckChildVisibility;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomRollOut.ChangeHeight(NewHeight: Integer);\r\nvar\r\n OldHeight: Integer;\r\nbegin\r\n OldHeight := Height;\r\n Parent.DisableAlign;\r\n DisableAlign;\r\n try\r\n Height := NewHeight;\r\n if Align = alBottom then\r\n Top := Top + (OldHeight - NewHeight);\r\n finally\r\n EnableAlign;\r\n Parent.EnableAlign;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomRollOut.ChangeWidth(NewWidth: Integer);\r\nvar\r\n OldWidth: Integer;\r\nbegin\r\n Parent.DisableAlign;\r\n DisableAlign;\r\n try\r\n OldWidth := Width;\r\n Width := NewWidth;\r\n if Align = alRight then\r\n Left := Left + (OldWidth - NewWidth);\r\n finally\r\n EnableAlign;\r\n Parent.EnableAlign;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomRollOut.DoExpand;\r\nvar \r\n I: Integer;\r\n OldSmartExpand: Boolean;\r\nbegin\r\n // Smart-Expand: If there's not enough space to expand the rollup-panel\r\n // then collapse the other rollout-panels\r\n if FSmartExpand then\r\n begin\r\n // Todo: SmartExpand was only made for panels that are bottom-aligned\r\n\r\n // Remember Collapsed status of all other TJvCustomRollOut components:\r\n SetLength(FCollapsedList, 0);\r\n if Assigned(Parent) and (Top + Height > Parent.Height) then\r\n begin\r\n for I := 0 to Parent.ControlCount-1 do\r\n begin\r\n if (Parent.Controls[I] is TJvCustomRollOut) and (Parent.Controls[I] <> Self) then\r\n begin\r\n SetLength(FCollapsedList, Length(FCollapsedList) + 1);\r\n FCollapsedList[Length(FCollapsedList) - 1] := (Parent.Controls[I] as TJvCustomRollOut).Collapsed;\r\n\r\n // Disable SmartExpand because it may cause troubles!!\r\n // especially when there is less space and another panel would be\r\n // shown obove the window (smartshow)\r\n OldSmartExpand := (Parent.Controls[I] as TJvCustomRollOut).SmartExpand;\r\n (Parent.Controls[I] as TJvCustomRollOut).SmartExpand := False;\r\n (Parent.Controls[I] as TJvCustomRollOut).Collapsed := True;\r\n\r\n (Parent.Controls[I] as TJvCustomRollOut).SmartExpand := OldSmartExpand;\r\n end;\r\n end;\r\n end;\r\n end;\r\n\r\n if FSmartShow then\r\n PutOnForm;\r\n\r\n if Assigned(FOnExpand) then\r\n FOnExpand(Self);\r\nend;\r\n\r\nprocedure TJvCustomRollOut.DoCollapse;\r\nvar\r\n ColIndex: Integer;\r\n I : integer;\r\n DoRestore: Boolean;\r\nbegin\r\n // Smart-Expand: If other rollouts where collapsed automatically when this rollout\r\n // expanded, then their old collapsed-state is now restored\r\n if FSmartExpand then\r\n begin\r\n DoRestore := Length(FCollapsedList)<>0;\r\n\r\n // Check if one of the auto-collapsed rollouts wad expanded manually\r\n // In this case we do not restore the old collapsed-states\r\n for I := 0 to Parent.ControlCount-1 do\r\n begin\r\n if (Parent.Controls[I] is TJvCustomRollOut) and\r\n (Parent.Controls[I] <> Self) then\r\n begin\r\n if (Parent.Controls[I] as TJvCustomRollOut).Collapsed = False then\r\n begin\r\n DoRestore := False;\r\n Break;\r\n end;\r\n end;\r\n end;\r\n\r\n if DoRestore then\r\n begin\r\n // Restore other rollouts\r\n ColIndex := 0;\r\n for I := 0 to Parent.ControlCount - 1 do\r\n begin\r\n if (Parent.Controls[I] is TJvCustomRollOut) and (Parent.Controls[I] <> Self) then\r\n begin\r\n (Parent.Controls[I] as TJvCustomRollOut).Collapsed := FCollapsedList[ColIndex];\r\n Inc(ColIndex);\r\n\r\n if ColIndex > Length(FCollapsedList) then\r\n Break;\r\n end;\r\n end;\r\n end;\r\n SetLength(FCollapsedList, 0);\r\n end;\r\n\r\n if Assigned(FOnCollapse) then\r\n FOnCollapse(Self);\r\nend;\r\n\r\nprocedure TJvCustomRollOut.SetBounds(ALeft, ATop, AWidth, AHeight: Integer);\r\nbegin\r\n if FCollapsed then\r\n begin\r\n if Placement = plTop then\r\n FCHeight := AHeight\r\n else\r\n FCWidth := AWidth;\r\n end\r\n else\r\n begin\r\n if Placement = plTop then\r\n FAHeight := AHeight\r\n else\r\n FAWidth := AWidth;\r\n end;\r\n inherited SetBounds(ALeft, ATop, AWidth, AHeight);\r\n if not Collapsed then\r\n UpdateGroup;\r\nend;\r\n\r\nprocedure TJvCustomRollOut.DefineProperties(Filer: TFiler);\r\nbegin\r\n inherited DefineProperties(Filer);\r\n Filer.DefineProperty('FAWidth', ReadAWidth, WriteAWidth, True);\r\n Filer.DefineProperty('FAHeight', ReadAHeight, WriteAHeight, True);\r\n Filer.DefineProperty('FCWidth', ReadCWidth, WriteCWidth, True);\r\n Filer.DefineProperty('FCHeight', ReadCHeight, WriteCHeight, True);\r\nend;\r\n\r\nprocedure TJvCustomRollOut.WriteAWidth(Writer: TWriter);\r\nbegin\r\n Writer.WriteInteger(FAWidth);\r\nend;\r\n\r\nprocedure TJvCustomRollOut.WriteAHeight(Writer: TWriter);\r\nbegin\r\n Writer.WriteInteger(FAHeight);\r\nend;\r\n\r\nprocedure TJvCustomRollOut.WriteCWidth(Writer: TWriter);\r\nbegin\r\n Writer.WriteInteger(FCWidth);\r\nend;\r\n\r\nprocedure TJvCustomRollOut.WriteCHeight(Writer: TWriter);\r\nbegin\r\n Writer.WriteInteger(FCHeight);\r\nend;\r\n\r\nprocedure TJvCustomRollOut.ReadAWidth(Reader: TReader);\r\nbegin\r\n FAWidth := Reader.ReadInteger;\r\n if not Collapsed and (Placement = plLeft) then\r\n SetBounds(Left, Top, FAWidth, Height);\r\nend;\r\n\r\nprocedure TJvCustomRollOut.ReadAHeight(Reader: TReader);\r\nbegin\r\n FAHeight := Reader.ReadInteger;\r\n if not Collapsed and (Placement = plTop) then\r\n SetBounds(Left, Top, Width, FAHeight);\r\nend;\r\n\r\nprocedure TJvCustomRollOut.ReadCWidth(Reader: TReader);\r\nbegin\r\n FCWidth := Reader.ReadInteger;\r\n if Collapsed and (Placement = plLeft) then\r\n SetBounds(Left, Top, FCWidth, Height);\r\nend;\r\n\r\nprocedure TJvCustomRollOut.ReadCHeight(Reader: TReader);\r\nbegin\r\n FCHeight := Reader.ReadInteger;\r\n if Collapsed and (Placement = plTop) then\r\n SetBounds(Left, Top, Width, FCHeight);\r\nend;\r\n\r\nprocedure TJvCustomRollOut.SetButtonHeight(Value: Integer);\r\nbegin\r\n if FButtonHeight <> Value then\r\n begin\r\n FButtonHeight := Value;\r\n FCHeight := Value + 2;\r\n if FPlacement = plTop then\r\n FButtonRect := Rect(BevelWidth, BevelWidth, Width - BevelWidth, FButtonHeight + BevelWidth)\r\n else\r\n FButtonRect := Rect(BevelWidth, BevelWidth, FButtonHeight + BevelWidth, Height - BevelWidth);\r\n Realign;\r\n RedrawControl(True);\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomRollOut.SetChildOffset(Value: Integer);\r\nbegin\r\n if FChildOffset <> Value then\r\n begin\r\n FChildOffset := Value;\r\n Realign;\r\n // R := ClientRect;\r\n // AlignControls(nil,R);\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomRollOut.SetSmartExpand(const Value: boolean);\r\nbegin\r\n FSmartExpand := Value;\r\n SetLength(FCollapsedList, 0);\r\nend;\r\n\r\n// To make Setting of expanded size possible, even if panel is collapsed\r\nprocedure TJvCustomRollOut.SetExpandedSize(const Value: integer);\r\nbegin\r\n if ((FPlacement = plTop) and (FAHeight = Value)) or\r\n ((FPlacement = plLeft) and (FAWidth = Value)) then\r\n Exit;\r\n\r\n if FPlacement = plTop then\r\n FAHeight := Value\r\n else\r\n FAWidth := Value;\r\n\r\n if not FCollapsed then\r\n begin\r\n // The top form is assigned so set the width and height of this form\r\n if Parent = FTopForm then\r\n begin\r\n FTopForm.DisableAlign;\r\n if FPlacement = plTop then\r\n begin\r\n FTopForm.Height := FAHeight;\r\n FOldWidthHeight.Y := FAHeight;\r\n end\r\n else\r\n begin\r\n FTopForm.Width := FAWidth;\r\n FOldWidthHeight.X := FAWidth;\r\n end;\r\n FTopForm.EnableAlign;\r\n end;\r\n\r\n if FPlacement = plTop then\r\n ChangeHeight(FAHeight)\r\n else\r\n ChangeWidth(FAWidth);\r\n\r\n if (Parent = FTopForm) and (FOldPos.Y + Height < FOldParent.Height) then\r\n RestoreFromTopForm\r\n else\r\n PutOnForm;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomRollOut.SetButtonFont(const Value: TFont);\r\nbegin\r\n if Value <> FButtonFont then\r\n FButtonFont.Assign(Value);\r\nend;\r\n\r\n// Only store button font if not default value\r\nfunction TJvCustomRollOut.IsButtonFontStored: Boolean;\r\nbegin\r\n Result := (FButtonFont.Name <> 'Verdana') or\r\n (FButtonFont.Size <> 7) or\r\n (FButtonFont.Style <> [fsBold]) or\r\n (FButtonFont.Color <> clWindowText);\r\nend;\r\n\r\nprocedure TJvCustomRollOut.MouseEnter(Control: TControl);\r\nbegin\r\n inherited MouseEnter(Control);\r\n if csDesigning in ComponentState then\r\n Exit;\r\n RedrawControl(False);\r\nend;\r\n\r\nprocedure TJvCustomRollOut.MouseLeave(Control: TControl);\r\nbegin\r\n inherited MouseLeave(Control);\r\n if csDesigning in ComponentState then\r\n Exit;\r\n if FInsideButton then\r\n begin\r\n FInsideButton := False;\r\n FMouseDown := False;\r\n end;\r\n RedrawControl(False);\r\nend;\r\n\r\nfunction TJvCustomRollOut.DoEraseBackground(Canvas: TCanvas; Param: LPARAM): Boolean;\r\nbegin\r\n // inherited DoEraseBackground(Canvas, Param);\r\n Result := False;\r\nend;\r\n\r\nprocedure TJvCustomRollOut.DrawButtonFrame;\r\nvar\r\n R: TRect;\r\n TopC, BottomC: TColor;\r\n FIndex: Integer;\r\nbegin\r\n if FPlacement = plTop then\r\n FButtonRect := Rect(BevelWidth, BevelWidth, Width - BevelWidth, FButtonHeight + BevelWidth)\r\n else\r\n FButtonRect := Rect(BevelWidth, BevelWidth, FButtonHeight + BevelWidth, Height - BevelWidth);\r\n\r\n R := FButtonRect;\r\n Canvas.Brush.Color := Colors.ButtonColor;\r\n if Canvas.Brush.Color <> clNone then\r\n Canvas.FillRect(R);\r\n\r\n if FMouseDown and FInsideButton then\r\n begin\r\n TopC := Colors.ButtonBottom;\r\n BottomC := Colors.ButtonTop;\r\n end\r\n else\r\n if FInsideButton then\r\n begin\r\n TopC := Colors.ButtonTop;\r\n BottomC := Colors.ButtonBottom;\r\n end\r\n{ else\r\n if Focused then\r\n begin\r\n TopC := clHighlight;\r\n BottomC := clHighlight;\r\n end}\r\n else\r\n begin\r\n TopC := Colors.Color;\r\n BottomC := Colors.Color;\r\n end;\r\n// if not (csDesigning in ComponentState) then\r\n InternalFrame3D(Canvas, R, TopC, BottomC, 1);\r\n if Collapsed then\r\n FIndex := ImageOptions.IndexCollapsed\r\n else\r\n FIndex := ImageOptions.IndexExpanded;\r\n\r\n Canvas.Font.Assign(FButtonFont);\r\n R := FButtonRect;\r\n if FPlacement = plTop then\r\n begin\r\n if Assigned(ImageOptions.Images) then\r\n begin\r\n ImageOptions.Images.Draw(Canvas, ImageOptions.Offset + BevelWidth,\r\n BevelWidth + (FButtonHeight - ImageOptions.Images.Height) div 2, FIndex);\r\n R.Left := ImageOptions.Images.Width + ImageOptions.Offset * 2 + BevelWidth;\r\n end\r\n else\r\n R.Left := ImageOptions.Offset * 2 + BevelWidth;\r\n R.Top := R.Top - (Canvas.TextHeight(Caption) - (FButtonRect.Bottom - FButtonRect.Top)) div 2 + BevelWidth div 2;\r\n end\r\n else\r\n begin\r\n if Assigned(ImageOptions.Images) then\r\n begin\r\n ImageOptions.Images.Draw(Canvas, BevelWidth + (FButtonHeight - ImageOptions.Images.Width) div 2,\r\n ImageOptions.Offset + BevelWidth, FIndex);\r\n R.Top := ImageOptions.Images.Height + ImageOptions.Offset * 2 + BevelWidth;\r\n end\r\n else\r\n R.Top := ImageOptions.Offset * 2 + BevelWidth;\r\n R.Left := R.Left + (Canvas.TextHeight(Caption) + (FButtonRect.Right - FButtonRect.Left)) div 2 + BevelWidth div 2;\r\n end;\r\n if FInsideButton then\r\n Canvas.Font.Color := Colors.HotTrackText;\r\n\r\n if Length(Caption) > 0 then\r\n begin\r\n SetBkMode(Canvas.Handle, Transparent);\r\n if FMouseDown and FInsideButton then\r\n OffsetRect(R, 1, 1);\r\n if Placement = plLeft then\r\n SetTextAngle(Canvas, 270);\r\n DrawText(Canvas.Handle, PChar(Caption), -1, R, DT_NOCLIP);\r\n if Placement = plLeft then\r\n SetTextAngle(Canvas, 0);\r\n end;\r\n if ShowFocus and Focused then\r\n begin\r\n R := FButtonRect;\r\n InflateRect(R, -2, -2);\r\n Canvas.DrawFocusRect(R);\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomRollOut.Paint;\r\nvar\r\n R: TRect;\r\nbegin\r\n R := ClientRect;\r\n if Colors.Color <> clNone then\r\n begin\r\n Canvas.Brush.Color := Colors.Color;\r\n DrawThemedBackground(Self, Canvas, R);\r\n end;\r\n InternalFrame3D(Canvas, R, Colors.FrameTop, Colors.FrameBottom, BevelWidth);\r\n if Colors.FrameTop = clNone then\r\n begin\r\n Dec(R.Left);\r\n Dec(R.Top);\r\n end;\r\n if Colors.FrameBottom = clNone then\r\n begin\r\n Inc(R.Right);\r\n Inc(R.Bottom);\r\n end;\r\n DrawButtonFrame;\r\nend;\r\n\r\nprocedure TJvCustomRollOut.Collapse;\r\nbegin\r\n SetCollapsed(True);\r\nend;\r\n\r\nprocedure TJvCustomRollOut.Expand;\r\nbegin\r\n SetCollapsed(False);\r\nend;\r\n\r\nprocedure TJvCustomRollOut.UpdateGroup;\r\nvar\r\n Msg: TMessage;\r\nbegin\r\n if (FGroupIndex <> 0) and (Parent <> nil) then\r\n begin\r\n Msg.Msg := CM_EXPANDED;\r\n Msg.WParam := FGroupIndex;\r\n Msg.LParam := LPARAM(Self);\r\n Msg.Result := 0;\r\n Parent.Broadcast(Msg);\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomRollOut.CMExpanded(var Msg: TMessage);\r\nvar\r\n Sender: TJvCustomRollOut;\r\nbegin\r\n if Msg.WParam = WPARAM(FGroupIndex) then\r\n begin\r\n Sender := TJvCustomRollOut(Msg.LParam);\r\n if (Sender <> Self) then\r\n begin\r\n SetCollapsed(True);\r\n CheckChildVisibility;\r\n Invalidate;\r\n end;\r\n end;\r\nend;\r\n\r\n(*\r\nfunction IsAccel(VK: Word; const Str: string): Boolean;\r\nvar\r\n P: Integer;\r\nbegin\r\n P := Pos('&', Str);\r\n Result := (P <> 0) and (P < Length(Str)) and\r\n (AnsiCompareText(Str[P + 1], Char(VK)) = 0);\r\nend;\r\n*)\r\n\r\nfunction TJvCustomRollOut.WantKey(Key: Integer; Shift: TShiftState): Boolean;\r\nbegin\r\n Result := Enabled and (IsAccel(Key, Caption) and (ssAlt in Shift)) or ((Key = VK_SPACE) and Focused);\r\n if Result then\r\n begin\r\n SetCollapsed(not FCollapsed);\r\n if CanFocus then\r\n SetFocus;\r\n end\r\n else\r\n Result := inherited WantKey(Key, Shift);\r\nend;\r\n\r\nprocedure TJvCustomRollOut.DoColorsChange(Sender: TObject);\r\nbegin\r\n RedrawControl(True);\r\nend;\r\n\r\nprocedure TJvCustomRollOut.DoImageOptionsChange(Sender: TObject);\r\nbegin\r\n RedrawControl(True);\r\nend;\r\n\r\nprocedure TJvCustomRollOut.DoButtonFontChange(Sender: TObject);\r\nbegin\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvCustomRollOut.Notification(AComponent: TComponent;\r\n Operation: TOperation);\r\nbegin\r\n inherited Notification(AComponent, Operation);\r\n if (Operation = opRemove) and (ImageOptions <> nil) and (AComponent = ImageOptions.Images) then\r\n ImageOptions.Images := nil;\r\nend;\r\n\r\nprocedure TJvCustomRollOut.ParentColorChanged;\r\nbegin\r\n inherited ParentColorChanged;\r\n if ParentColor then\r\n Colors.Color := Color;\r\nend;\r\n\r\nfunction TJvCustomRollOut.MouseIsOnButton: Boolean;\r\nvar\r\n P: TPoint;\r\n R: TRect;\r\nbegin\r\n GetCursorPos(P);\r\n P := ScreenToClient(P);\r\n R := FButtonRect;\r\n // (p3) include edges in hit test\r\n InflateRect(R, 1, 1);\r\n Result := PtInRect(R, P);\r\nend;\r\n\r\nprocedure TJvCustomRollOut.FocusKilled(NextWnd: THandle);\r\nbegin\r\n CheckChildVisibility;\r\n inherited FocusKilled(NextWnd);\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvCustomRollOut.FocusSet(PrevWnd: THandle);\r\nbegin\r\n CheckChildVisibility;\r\n inherited FocusSet(PrevWnd);\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvCustomRollOut.SetShowFocus(const Value: Boolean);\r\nbegin\r\n if FShowFocus <> Value then\r\n begin\r\n FShowFocus := Value;\r\n if Focused then\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomRollOut.CheckChildVisibility;\r\n procedure GetChildVisibility;\r\n var\r\n I: Integer;\r\n begin\r\n if FChildControlVisibility = nil then\r\n begin\r\n FChildControlVisibility := TStringList.Create;\r\n FChildControlVisibility.Sorted := True;\r\n end;\r\n\r\n for I := 0 to ControlCount - 1 do\r\n if (Controls[I] is TWinControl) and (TWinControl(Controls[I]).Visible) then\r\n begin\r\n FChildControlVisibility.AddObject(Controls[I].Name, Controls[I]);\r\n TWinControl(Controls[I]).Visible := False;\r\n end;\r\n end;\r\n\r\n procedure SetChildVisibility;\r\n var\r\n I: Integer;\r\n begin\r\n if FChildControlVisibility <> nil then\r\n begin\r\n for I := 0 to FChildControlVisibility.Count - 1 do\r\n if FindChildControl(FChildControlVisibility[I]) <> nil then\r\n TWinControl(FChildControlVisibility.Objects[I]).Visible := True;\r\n FreeAndNil(FChildControlVisibility);\r\n end;\r\n end;\r\nbegin\r\n if csDesigning in ComponentState then\r\n Exit;\r\n\r\n if Collapsed then\r\n GetChildVisibility\r\n else\r\n SetChildVisibility;\r\nend;\r\n\r\n// Event handler called by the \"TopWindow\" when the window-rolloutpanel loses focus\r\n// to automatically collapse panel again\r\nprocedure TJvCustomRollOut.OnTopDeactivate(Sender: TObject);\r\nbegin\r\n if not FCollapsed then\r\n RestoreFromTopForm;\r\n// Collapse; // Use this line instead of the previous one if you want the rollout\r\n // to collapse after the \"topForm\" lost focus\r\nend;\r\n\r\nprocedure TJvCustomRollOut.RestoreFromTopForm;\r\nvar\r\n OldCollapsed: Boolean;\r\nbegin\r\n if not FSmartShow then\r\n Exit;\r\n\r\n // Rollout panel was mapped onto a special form (TopForm)\r\n // -> restore old state\r\n if Parent = FTopForm then\r\n begin\r\n FTopForm.OnDeactivate := nil; // Deactivate the Event to prevent\r\n // calling this method a second time\r\n FTopForm.Hide;\r\n\r\n OldCollapsed := FCollapsed;\r\n FCollapsed := False; // Set control to expanded, so that SetBounds stores expanded dimesions\r\n\r\n // Set the control back to it's old position!!\r\n Parent := FOldParent as TWinControl;\r\n Align := FOldAlign;\r\n SetBounds(FOldPos.X, FOldPos.Y, FOldWidthHeight.X, FOldWidthHeight.Y);\r\n FOldParent := nil;\r\n\r\n FCollapsed := OldCollapsed;\r\n FTopForm.OnDeactivate := OnTopDeactivate; // restore Event handling\r\n end;\r\nend;\r\n\r\n// If expanded panel doesn't fit on parent form -> create a separate form\r\n// so panel can be shown in it's full size:\r\nprocedure TJvCustomRollOut.PutOnForm;\r\nvar\r\n ScrPos : TPoint;\r\nbegin\r\n // Remember old pos\r\n if FSmartShow and not Assigned(FOldParent) then\r\n begin\r\n // Don't Smart-Expand if parent form not visible\r\n // (e.g. Collapsed-property is set from outside)\r\n if (Owner is TForm) and not (Owner as TForm).Visible then\r\n Exit;\r\n\r\n FOldPos := Point( Left, Top );\r\n FOldAlign := Align;\r\n\r\n if Top + Height > Parent.Height then\r\n begin\r\n // Save old size and position to be able to restore it\r\n FOldParent:=Parent;\r\n FOldWidthHeight:=Point(Width, Height);\r\n\r\n // set size of the special form\r\n FTopForm.Width := Width;\r\n FTopForm.Height := Height;\r\n ScrPos := Parent.ClientToScreen(Point(Left, Top));\r\n FTopForm.Left := ScrPos.X;\r\n FTopForm.Top := ScrPos.Y;\r\n\r\n Parent := FTopForm;\r\n Align := alClient;\r\n FTopForm.Show;\r\n end;\r\n end;\r\nend;\r\n\r\n//=== { TJvRollOutAction } ===================================================\r\n\r\ndestructor TJvRollOutAction.Destroy;\r\nbegin\r\n if RollOut <> nil then\r\n RollOut.RemoveFreeNotification(Self);\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJvRollOutAction.Execute: Boolean;\r\nbegin\r\n Result := inherited Execute;\r\n if Result then\r\n begin\r\n if ActionComponent is TJvCustomRollOut then\r\n begin\r\n if LinkCheckedToCollapsed then\r\n TJvCustomRollOut(ActionComponent).Collapsed := not Checked\r\n else\r\n TJvCustomRollOut(ActionComponent).Collapsed := not TJvCustomRollOut(ActionComponent).Collapsed;\r\n end\r\n else\r\n if RollOut <> nil then\r\n begin\r\n if LinkCheckedToCollapsed then\r\n RollOut.Collapsed := not Checked\r\n else\r\n RollOut.Collapsed := not RollOut.Collapsed;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvRollOutAction.ExecuteTarget(Target: TObject);\r\nbegin\r\n inherited ExecuteTarget(Target);\r\n if Target is TJvCustomRollOut then\r\n begin\r\n if LinkCheckedToCollapsed then\r\n TJvCustomRollOut(Target).Collapsed := not Checked\r\n else\r\n TJvCustomRollOut(Target).Collapsed := not TJvCustomRollOut(Target).Collapsed;\r\n end\r\n else\r\n if RollOut <> nil then\r\n begin\r\n if LinkCheckedToCollapsed then\r\n RollOut.Collapsed := not Checked\r\n else\r\n RollOut.Collapsed := not RollOut.Collapsed;\r\n end;\r\nend;\r\n\r\nfunction TJvRollOutAction.HandlesTarget(Target: TObject): Boolean;\r\nbegin\r\n Result := ((RollOut <> nil) and (Target = RollOut) or\r\n (RollOut = nil) and (Target is TJvCustomRollOut)) and TJvCustomRollOut(Target).Enabled;\r\nend;\r\n\r\nprocedure TJvRollOutAction.Notification(AComponent: TComponent;\r\n Operation: TOperation);\r\nbegin\r\n inherited Notification(AComponent, Operation);\r\n if AComponent = RollOut then\r\n RollOut := nil;\r\nend;\r\n\r\nprocedure TJvRollOutAction.SetLinkCheckedToCollapsed(const Value: Boolean);\r\nbegin\r\n if FLinkCheckedToCollapsed <> Value then\r\n begin\r\n FLinkCheckedToCollapsed := Value;\r\n if FLinkCheckedToCollapsed then\r\n begin\r\n if RollOut <> nil then\r\n RollOut.Collapsed := not Checked\r\n else\r\n if ActionComponent is TJvCustomRollOut then\r\n TJvCustomRollOut(ActionComponent).Collapsed := not Checked;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvRollOutAction.SetRollOut(const Value: TJvCustomRollOut);\r\nbegin\r\n ReplaceComponentReference(Self, Value, TComponent(FRollOut));\r\nend;\r\n\r\nprocedure TJvRollOutAction.UpdateTarget(Target: TObject);\r\nbegin\r\n if LinkCheckedToCollapsed then\r\n Checked := not (Target as TJvCustomRollOut).Collapsed;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvRuler.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvgRuler.PAS, released on 2003-01-15.\r\n\r\nThe Initial Developer of the Original Code is Andrey V. Chudin, [chudin att yandex dott ru]\r\nPortions created by Andrey V. Chudin are Copyright (C) 2003 Andrey V. Chudin.\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\nMichael Beck [mbeck att bigfoot dott com].\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvRuler.pas 13104 2011-09-07 06:50:43Z obones $\r\n\r\nunit JvRuler;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, Classes, SysUtils,\r\n JvComponent;\r\n\r\ntype\r\n TJvRulerUnit = (ruCentimeters, ruInches, ruPixels);\r\n TJvRulerOrientation = (roHorizontal, roVertical);\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvRuler = class(TJvGraphicControl)\r\n private\r\n FUseUnit: TJvRulerUnit;\r\n FOrientation: TJvRulerOrientation;\r\n FPosition: Double;\r\n procedure SetPosition(const Value: Double);\r\n procedure SetOrientation(Value: TJvRulerOrientation);\r\n procedure SetUseUnit(Value: TJvRulerUnit);\r\n protected\r\n procedure Paint; override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n published\r\n property Align;\r\n property Font;\r\n property Height default 25;\r\n property Width default 300;\r\n property Orientation: TJvRulerOrientation read FOrientation write SetOrientation default roHorizontal;\r\n property Position: Double read FPosition write SetPosition;\r\n property UseUnit: TJvRulerUnit read FUseUnit write SetUseUnit default ruCentimeters;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvRuler.pas $';\r\n Revision: '$Revision: 13104 $';\r\n Date: '$Date: 2011-09-07 08:50:43 +0200 (mer. 07 sept. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nconst\r\n LogPixels: array [Boolean] of Integer = (LOGPIXELSY, LOGPIXELSX);\r\n\r\nfunction InchesToPixels(DC: HDC; Value: Double; IsHorizontal: Boolean): Integer;\r\nbegin\r\n Result := Round(Value * GetDeviceCaps(DC, LogPixels[IsHorizontal]));\r\nend;\r\n\r\nfunction CentimetersToPixels(DC: HDC; Value: Double; IsHorizontal: Boolean): Integer;\r\nbegin\r\n Result := Round(Value * GetDeviceCaps(DC, LogPixels[IsHorizontal]) / 2.54);\r\nend;\r\n\r\n//=== { TJvRuler } ===========================================================\r\n\r\nconstructor TJvRuler.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FOrientation := roHorizontal;\r\n FUseUnit := ruCentimeters;\r\n Height := 25;\r\n Width := 300;\r\nend;\r\n\r\nprocedure TJvRuler.Paint;\r\nconst\r\n Offset: array [Boolean] of Integer = (8, 3);\r\nvar\r\n X, Y: Double;\r\n PX, PY, Pos: Integer;\r\n S: string;\r\n R: TRect;\r\nbegin\r\n Canvas.Font := Font;\r\n X := 0;\r\n Y := 0;\r\n repeat\r\n X := X + 0.5;\r\n Y := Y + 0.5;\r\n case FUseUnit of\r\n ruInches:\r\n begin\r\n PX := InchesToPixels(Canvas.Handle, X, True);\r\n PY := InchesToPixels(Canvas.Handle, Y, False);\r\n Pos := InchesToPixels(Canvas.Handle, Position, Orientation = roHorizontal);\r\n end;\r\n ruCentimeters:\r\n begin\r\n PX := CentimetersToPixels(Canvas.Handle, X, True);\r\n PY := CentimetersToPixels(Canvas.Handle, Y, False);\r\n Pos := CentimetersToPixels(Canvas.Handle, Position, Orientation = roHorizontal);\r\n end;\r\n else // ruPixels\r\n PX := Round(X * 50);\r\n PY := Round(Y * 50);\r\n Pos := Round(Position);\r\n end;\r\n\r\n SetBkMode(Canvas.Handle, TRANSPARENT);\r\n if (PX < Width) or (PY < Height) then\r\n with Canvas do\r\n if Orientation = roHorizontal then\r\n begin\r\n if X = Trunc(X) then\r\n begin\r\n R := Rect(PX - 10, 0, PX + 10, Height);\r\n if UseUnit = ruPixels then\r\n S := IntToStr(PX)\r\n else\r\n S := IntToStr(Trunc(X));\r\n R := Rect(PX - TextWidth(S), 0, PX + TextWidth(S), Height);\r\n Windows.DrawText(Handle, PChar(S), Length(S), R, DT_SINGLELINE or DT_CENTER);\r\n end;\r\n MoveTo(PX, Height - Offset[X = Trunc(X)]);\r\n LineTo(PX, Height);\r\n end\r\n else\r\n begin\r\n if Y = Trunc(Y) then\r\n begin\r\n if UseUnit = ruPixels then\r\n S := IntToStr(PY)\r\n else\r\n S := IntToStr(Trunc(Y));\r\n R := Rect(0, PY - TextHeight(S), Width, PY + TextHeight(S));\r\n Windows.DrawText(Handle, PChar(S), Length(S), R, DT_SINGLELINE or DT_VCENTER);\r\n end;\r\n MoveTo(Width - Offset[Y = Trunc(Y)], PY);\r\n LineTo(Width, PY);\r\n end;\r\n until ((Orientation = roHorizontal) and (PX > Width)) or\r\n ((Orientation = roVertical) and (PY > Height));\r\n\r\n if Position > 0.0 then\r\n with Canvas do\r\n if Orientation = roHorizontal then\r\n begin\r\n MoveTo(Pos - 2, Height - 4);\r\n LineTo(Pos + 2, Height - 4);\r\n LineTo(Pos, Height);\r\n LineTo(Pos - 2, Height - 4);\r\n end\r\n else\r\n begin\r\n MoveTo(Width - 4, Pos - 2);\r\n LineTo(Width - 4, Pos + 2);\r\n LineTo(Width, Pos);\r\n LineTo(Width - 4, Pos - 2);\r\n end;\r\nend;\r\n\r\nprocedure TJvRuler.SetPosition(const Value: Double);\r\nbegin\r\n if FPosition <> Value then\r\n begin\r\n FPosition := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvRuler.SetOrientation(Value: TJvRulerOrientation);\r\nbegin\r\n if FOrientation <> Value then\r\n begin\r\n FOrientation := Value;\r\n if csDesigning in ComponentState then\r\n SetBounds(Left, Top, Height, Width);\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvRuler.SetUseUnit(Value: TJvRulerUnit);\r\nbegin\r\n if FUseUnit <> Value then\r\n begin\r\n FUseUnit := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvSAL.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvSAL.PAS, released on 2002-06-15.\r\n\r\nThe Initial Developer of the Original Code is Jan Verhoeven [jan1 dott verhoeven att wxs dott nl]\r\nPortions created by Jan Verhoeven are Copyright (C) 2002 Jan Verhoeven.\r\nAll Rights Reserved.\r\n\r\nContributor(s): Robert Love [rlove att slcdug dott org].\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvSAL.pas 13104 2011-09-07 06:50:43Z obones $\r\n\r\nunit JvSAL;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n SysUtils, Classes, Windows, Messages, Graphics, Controls, Forms, Dialogs,\r\n JvSALHashList, JvStrings, JvComponentBase;\r\n\r\nconst\r\n StackLimit = 256;\r\n // message are processed every 250 milliseconds\r\n // use the stop procedure to stop a locked script\r\n TimeOut = 250;\r\n\r\ntype\r\n TOnGetUnitEvent = procedure(Sender: TObject; AUnit: string;\r\n var AValue: string; var Handled: Boolean) of object;\r\n\r\n TJvAtom = class(TObject)\r\n private\r\n FValue: Variant;\r\n FActor: TJvSALProc;\r\n procedure SetActor(const Value: TJvSALProc);\r\n procedure SetValue(const AValue: Variant);\r\n public\r\n property Value: Variant read FValue write SetValue;\r\n property Actor: TJvSALProc read FActor write SetActor;\r\n end;\r\n\r\n TJvSALProcAtom = class(TObject)\r\n private\r\n FParser: TJvSALProc;\r\n FActor: TJvSALProc;\r\n procedure SetActor(const Value: TJvSALProc);\r\n procedure SetParser(const Value: TJvSALProc);\r\n public\r\n property Actor: TJvSALProc read FActor write SetActor;\r\n property Parser: TJvSALProc read FParser write SetParser;\r\n end;\r\n\r\n TJvAtoms = class(TStringList)\r\n public\r\n procedure ClearAll;\r\n destructor Destroy; override;\r\n end;\r\n\r\n TStack = array [0..StackLimit] of Variant;\r\n TBStack = array [0..StackLimit] of Boolean;\r\n TRStack = array [0..StackLimit] of Integer;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvSAL = class(TJvComponent)\r\n private\r\n FStop: Boolean;\r\n FCaption: string;\r\n FSP: Integer;\r\n FRSP: Integer;\r\n FBSP: Integer;\r\n FStack: TStack;\r\n FBStack: TBStack;\r\n FRStack: TRStack;\r\n FProcs: TJvSALHashList;\r\n FScript: string;\r\n FUnits: TStringList;\r\n FTicks: cardinal;\r\n FOnGetUnit: TOnGetUnitEvent;\r\n FVariableName: string;\r\n FVariable: TJvAtom;\r\n FSelection: Variant;\r\n FUseDirective: string;\r\n FBeginOfComment: string;\r\n FEndOfComment: string;\r\n FStringDelimiter: string;\r\n FPC: Integer;\r\n FAtoms: TJvAtoms;\r\n FPCProc: Integer;\r\n FToken: string;\r\n procedure SetScript(const Value: string);\r\n procedure SetGetUnit(const Value: TOnGetUnitEvent);\r\n procedure SetVariable(const Value: TJvAtom);\r\n procedure SetVariableName(const Value: string);\r\n procedure SetSelection(const Value: Variant);\r\n procedure SetUseDirective(const Value: string);\r\n procedure SetBeginOfComment(const Value: string);\r\n procedure SetEndOfComment(const Value: string);\r\n procedure SetStringDelimiter(const Value: string);\r\n procedure SetPC(const Value: Integer);\r\n procedure SetToken(const Value: string);\r\n procedure SetCaption(const Value: string);\r\n protected\r\n procedure ParseScript;\r\n // return FStack methods\r\n // SAL language\r\n procedure xBoSub;\r\n procedure xEoSub;\r\n procedure xValue;\r\n procedure xDefVariable;\r\n procedure xVariable;\r\n procedure xProc;\r\n procedure xNoParser;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n procedure ClearProcedures;\r\n procedure AddProcedure(AName: string; AProcedure, AParser: TJvSALProc);\r\n function APO(Op: string; AProc: TJvSALProc): Integer;\r\n procedure Push(AValue: Variant);\r\n function Pop: Variant;\r\n procedure RPush(AValue: Integer);\r\n function RPop: Integer;\r\n procedure BoolPush(AValue: Boolean);\r\n function BoolPop: Boolean;\r\n procedure LoadFromFile(FileName: string);\r\n procedure Execute;\r\n procedure Stop;\r\n property PC: Integer read FPC write SetPC;\r\n property Atoms: TJvAtoms read FAtoms;\r\n property PCProc: Integer read FPCProc;\r\n property Token: string read FToken write SetToken;\r\n property Script: string read FScript write SetScript;\r\n property Caption: string read FCaption write SetCaption;\r\n property Variable: TJvAtom read FVariable write SetVariable;\r\n property VariableName: string read FVariableName write SetVariableName;\r\n property TheSelect: Variant read FSelection write SetSelection;\r\n property UseDirective: string read FUseDirective write SetUseDirective;\r\n property BeginOfComment: string read FBeginOfComment write SetBeginOfComment;\r\n property EndOfComment: string read FEndOfComment write SetEndOfComment;\r\n property StringDelim: string read FStringDelimiter write SetStringDelimiter;\r\n published\r\n property OnGetUnit: TOnGetUnitEvent read FOnGetUnit write SetGetUnit;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvSAL.pas $';\r\n Revision: '$Revision: 13104 $';\r\n Date: '$Date: 2011-09-07 08:50:43 +0200 (mer. 07 sept. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n JvConsts, JvResources, JvTypes;\r\n\r\nconst\r\n // do not localize these strings\r\n cSAL = 'SAL';\r\n cUse = 'use::';\r\n cLiteral = 'literal';\r\n cProc = 'proc-';\r\n cEndProc = 'end-proc';\r\n cVar = 'var-';\r\n\r\n//=== { TJvSAL } =============================================================\r\n\r\nconstructor TJvSAL.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FAtoms := TJvAtoms.Create;\r\n FProcs := TJvSALHashList.Create(ITinyHash, HashSecondaryOne, SameText);\r\n FUnits := TStringList.Create;\r\n FCaption := cSAL;\r\n FUseDirective := cUse;\r\n FBeginOfComment := '{';\r\n FEndOfComment := '}';\r\n FStringDelimiter := '\"';\r\nend;\r\n\r\ndestructor TJvSAL.Destroy;\r\nbegin\r\n FAtoms.Free;\r\n FProcs.Free;\r\n FUnits.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJvSAL.BoolPop: Boolean;\r\nbegin\r\n Dec(FBSP);\r\n if FBSP < 0 then\r\n raise EJVCLException.CreateRes(@RsEBooleanStackUnderflow);\r\n Result := FBStack[FBSP];\r\nend;\r\n\r\nprocedure TJvSAL.BoolPush(AValue: Boolean);\r\nbegin\r\n FBStack[FBSP] := AValue;\r\n Inc(FBSP);\r\n if FBSP > StackLimit then\r\n raise EJVCLException.CreateRes(@RsEBooleanStackOverflow);\r\nend;\r\n\r\nprocedure TJvSAL.Execute;\r\nvar\r\n A: TJvAtom;\r\n C: Integer;\r\nbegin\r\n PC := 0;\r\n FSP := 0;\r\n FRSP := 0;\r\n FBSP := 0;\r\n C := Atoms.Count;\r\n FStop := False;\r\n FTicks := GetTickCount;\r\n if C = 0 then\r\n Exit;\r\n repeat\r\n A := TJvAtom(Atoms.Objects[PC]);\r\n FPCProc := PC;\r\n Inc(FPC);\r\n A.Actor;\r\n if (GetTickCount - FTicks) > TimeOut then\r\n begin\r\n FTicks := GetTickCount;\r\n Application.ProcessMessages;\r\n end;\r\n if FStop then\r\n raise EJVCLException.CreateRes(@RsEProgramStopped);\r\n until PC >= C;\r\nend;\r\n\r\nprocedure TJvSAL.ParseScript;\r\nvar\r\n S: string;\r\n // iprocs: Integer;\r\n haveproc: Boolean;\r\n AActor: TJvSALProc;\r\n AParser: TJvSALProc;\r\n I, P, P2: Integer;\r\n fv: Double;\r\n A: TJvAtom;\r\n fn, TheUnit: string;\r\n Handled: Boolean;\r\n\r\n function CharFrom(From: Integer; AChar: Char; AText: string): Integer;\r\n var\r\n C: Integer;\r\n begin\r\n Result := 0;\r\n C := Length(AText);\r\n repeat\r\n if AText[From] = AChar then\r\n begin\r\n Result := From;\r\n Exit;\r\n end;\r\n Inc(From);\r\n until From > C;\r\n end;\r\n\r\nbegin\r\n PC := 1;\r\n S := FScript;\r\n FUnits.Clear;\r\n // process any includes\r\n repeat\r\n P := Pos(FUseDirective, S); // default use::\r\n if P > 0 then\r\n begin\r\n P2 := CharFrom(P, ' ', S);\r\n if P2 = 0 then\r\n raise EJVCLException.CreateResFmt(@RsEUnterminatedIncludeDirectiveNears, [Copy(S, P, 50)]);\r\n fn := Trim(Copy(S, P + Length(FUseDirective), P2 - P - Length(FUseDirective)));\r\n if not Assigned(FOnGetUnit) then\r\n raise EJVCLException.CreateRes(@RsEOngetUnitEventHandlerIsNotAssigned);\r\n Handled := False;\r\n fn := LowerCase(fn);\r\n if FUnits.IndexOf(fn) = -1 then\r\n begin\r\n OnGetUnit(Self, fn, TheUnit, Handled);\r\n if not Handled then\r\n raise EJVCLException.CreateResFmt(@RsECouldNotIncludeUnits, [fn]);\r\n TheUnit := StringReplace(TheUnit, Cr, ' ', [rfReplaceAll]);\r\n Delete(S, P, P2 - P);\r\n Insert(TheUnit, S, P);\r\n FUnits.Append(fn);\r\n end;\r\n end;\r\n until P = 0;\r\n\r\n while S <> '' do\r\n begin\r\n if Pos(FBeginOfComment, S) = 1 then\r\n begin // default= {\r\n P := Pos(FEndOfComment, S); // default= }\r\n if P = 0 then\r\n raise EJVCLException.CreateResFmt(@RsEUnterminatedCommentNears, [S]);\r\n Delete(S, 1, P + Length(FEndOfComment) - 1);\r\n S := Trim(S);\r\n end\r\n else\r\n if Pos(FStringDelimiter, S) = 1 then\r\n begin // default = \"\r\n Delete(S, 1, Length(FStringDelimiter));\r\n P := Pos(FStringDelimiter, S);\r\n if P = 0 then\r\n raise EJVCLException.CreateResFmt(@RsEUnterminatedStringNears, [S]);\r\n Token := Copy(S, 1, P - 1);\r\n Delete(S, 1, P + Length(FStringDelimiter) - 1);\r\n S := Trim(S);\r\n A := TJvAtom.Create;\r\n A.Value := Token;\r\n A.Actor := xValue;\r\n Atoms.AddObject(cLiteral, A);\r\n end\r\n else\r\n begin\r\n P := Pos(' ', S);\r\n if P = 0 then\r\n begin\r\n Token := S;\r\n S := '';\r\n end\r\n else\r\n begin\r\n Token := Copy(S, 1, P - 1);\r\n Delete(S, 1, P);\r\n S := Trim(S);\r\n end;\r\n // take care of aliases\r\n if Token = '.' then\r\n Token := '+=';\r\n // check for user procs\r\n haveproc := FProcs.Hash(Token, AActor, AParser);\r\n try // float\r\n fv := StrToFloat(Token);\r\n A := TJvAtom.Create;\r\n A.Value := fv;\r\n A.Actor := xValue;\r\n Atoms.AddObject(cLiteral, A);\r\n except\r\n if Pos(cProc, Token) = 1 then\r\n begin // begin of procedure\r\n if Pos(cEndProc, S) = 0 then\r\n raise EJVCLException.CreateResFmt(@RsEUnterminatedProcedureNears, [S]);\r\n APO(Token, xBoSub);\r\n end\r\n else\r\n if Token = cEndProc then\r\n APO(Token, xEoSub)\r\n else\r\n if Copy(Token, Length(Token) - 1, 2) = '()' then\r\n APO(Token, xProc) // proc call\r\n else\r\n if Pos(cVar, Token) = 1 then\r\n begin // define variable\r\n if Atoms.IndexOf(Token) <> -1 then\r\n raise EJVCLException.CreateResFmt(@RsEVariablesAllreadyDefineds, [Token, S]);\r\n A := TJvAtom.Create;\r\n A.Actor := xDefVariable;\r\n Atoms.AddObject(Token, A);\r\n end\r\n else\r\n if Token[1] = '$' then\r\n begin // variable value\r\n // find address\r\n I := Atoms.IndexOf(cVar + Copy(Token, 2, MaxInt));\r\n if I = -1 then\r\n raise EJVCLException.CreateResFmt(@RsEVariablesIsNotYetDefineds, [Token, S]);\r\n A := TJvAtom.Create;\r\n A.Value := I;\r\n A.Actor := xVariable;\r\n Atoms.AddObject(Token, A);\r\n end\r\n else\r\n if haveproc then\r\n begin\r\n if Assigned(AParser) then\r\n AParser\r\n else\r\n APO(Token, AActor);\r\n end\r\n else\r\n raise EJVCLException.CreateResFmt(@RsEProceduresNears, [Token, S]);\r\n end\r\n end\r\n end;\r\n\r\n // now resolve procs()\r\n if Atoms.Count = 0 then\r\n Exit;\r\n for I := 0 to Atoms.Count - 1 do\r\n begin\r\n S := Atoms[I];\r\n if Copy(S, Length(S) - 1, 2) = '()' then\r\n begin\r\n S := cProc + Copy(S, 1, Length(S) - 2);\r\n P := Atoms.IndexOf(S);\r\n if P = -1 then\r\n raise EJVCLException.CreateResFmt(@RsEUndefinedProcedures, [S]);\r\n TJvAtom(Atoms.Objects[I]).Value := P;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJvSAL.Pop: Variant;\r\nbegin\r\n Dec(FSP);\r\n if FSP < 0 then\r\n raise EJVCLException.CreateRes(@RsEStackUnderflow);\r\n Result := FStack[FSP];\r\nend;\r\n\r\nprocedure TJvSAL.Push(AValue: Variant);\r\nbegin\r\n FStack[FSP] := AValue;\r\n Inc(FSP);\r\n if FSP > StackLimit then\r\n raise EJVCLException.CreateRes(@RsEStackOverflow);\r\nend;\r\n\r\nprocedure TJvSAL.SetScript(const Value: string);\r\nbegin\r\n FScript := Trim(StringReplace(Value, Cr, ' ', [rfReplaceAll]));\r\n Atoms.ClearAll;\r\n ParseScript;\r\nend;\r\n\r\nprocedure TJvSAL.xDefVariable;\r\nvar\r\n A: TJvAtom;\r\nbegin\r\n A := TJvAtom(Atoms.Objects[PCProc]);\r\n FVariableName := Atoms[PCProc];\r\n FVariableName := '$' + Copy(FVariableName, 5, MaxInt);\r\n FVariable := A;\r\nend;\r\n\r\nprocedure TJvSAL.xValue;\r\nbegin\r\n Push(TJvAtom(Atoms.Objects[PCProc]).Value);\r\nend;\r\n\r\nprocedure TJvSAL.xVariable;\r\nvar\r\n Index: Integer;\r\n A: TJvAtom;\r\nbegin\r\n A := TJvAtom(Atoms.Objects[PCProc]);\r\n VariableName := Atoms[PCProc];\r\n Index := A.Value;\r\n Variable := TJvAtom(Atoms.Objects[Index]);\r\nend;\r\n\r\nprocedure TJvSAL.Stop;\r\nbegin\r\n FStop := True;\r\nend;\r\n\r\nprocedure TJvSAL.LoadFromFile(FileName: string);\r\nbegin\r\n Script := Loadstring(FileName);\r\nend;\r\n\r\nprocedure TJvSAL.ClearProcedures;\r\nbegin\r\n // FProcs.ClearAll;\r\n FProcs.Clear;\r\nend;\r\n\r\nprocedure TJvSAL.AddProcedure(AName: string; AProcedure, AParser: TJvSALProc);\r\n//var\r\n// A: TJvSALProcAtom;\r\nbegin\r\n // A:=TJvSALProcAtom.Create;\r\n // A.Actor:=AProcedure;\r\n // A.Parser:=AParser;\r\n // FProcs.AddObject(AName,A);\r\n FProcs.AddString(AName, AProcedure, AParser);\r\nend;\r\n\r\nfunction TJvSAL.RPop: Integer;\r\nbegin\r\n Dec(FRSP);\r\n if FRSP < 0 then\r\n raise EJVCLException.CreateRes(@RsEReturnStackUnderflow);\r\n Result := FRStack[FRSP];\r\nend;\r\n\r\nprocedure TJvSAL.RPush(AValue: Integer);\r\nbegin\r\n FRStack[FRSP] := AValue;\r\n Inc(FRSP);\r\n if FRSP > StackLimit then\r\n raise EJVCLException.CreateRes(@RsEReturnStackOverflow);\r\nend;\r\n\r\n// end of subroutine, marked with end-proc\r\n\r\nprocedure TJvSAL.xEoSub;\r\nbegin\r\n PC := RPop;\r\nend;\r\n\r\n// begin of subroutine, marked with [\r\n// loop to ]\r\n\r\nprocedure TJvSAL.xBoSub;\r\nvar\r\n Op: string;\r\n C: Integer;\r\nbegin\r\n C := Atoms.Count;\r\n repeat\r\n Op := Atoms[PC];\r\n Inc(FPC);\r\n if Op = cEndProc then\r\n Exit;\r\n until PC >= C;\r\n raise EJVCLException.CreateRes(@RsECouldNotFindEndOfProcedure);\r\nend;\r\n\r\nprocedure TJvSAL.SetGetUnit(const Value: TOnGetUnitEvent);\r\nbegin\r\n FOnGetUnit := Value;\r\nend;\r\n\r\n// function call\r\n\r\nprocedure TJvSAL.xProc;\r\nvar\r\n Index: Integer;\r\nbegin\r\n Index := TJvAtom(Atoms.Objects[PCProc]).Value;\r\n RPush(PC);\r\n PC := Index + 1;\r\nend;\r\n\r\nprocedure TJvSAL.SetVariable(const Value: TJvAtom);\r\nbegin\r\n FVariable := Value;\r\nend;\r\n\r\nprocedure TJvSAL.SetVariableName(const Value: string);\r\nbegin\r\n FVariableName := Value;\r\nend;\r\n\r\nprocedure TJvSAL.SetSelection(const Value: Variant);\r\nbegin\r\n FSelection := Value;\r\nend;\r\n\r\nprocedure TJvSAL.SetUseDirective(const Value: string);\r\nbegin\r\n FUseDirective := Value;\r\nend;\r\n\r\nprocedure TJvSAL.SetBeginOfComment(const Value: string);\r\nbegin\r\n FBeginOfComment := Value;\r\nend;\r\n\r\nprocedure TJvSAL.SetEndOfComment(const Value: string);\r\nbegin\r\n FEndOfComment := Value;\r\nend;\r\n\r\nprocedure TJvSAL.SetStringDelimiter(const Value: string);\r\nbegin\r\n FStringDelimiter := Value;\r\nend;\r\n\r\nprocedure TJvSAL.SetPC(const Value: Integer);\r\nbegin\r\n FPC := Value;\r\nend;\r\n\r\nfunction TJvSAL.APO(Op: string; AProc: TJvSALProc): Integer;\r\nvar\r\n A: TJvAtom;\r\nbegin\r\n A := TJvAtom.Create;\r\n A.Actor := AProc;\r\n Result := Atoms.AddObject(Op, A);\r\nend;\r\n\r\nprocedure TJvSAL.SetToken(const Value: string);\r\nbegin\r\n FToken := Value;\r\nend;\r\n\r\nprocedure TJvSAL.SetCaption(const Value: string);\r\nbegin\r\n FCaption := Value;\r\nend;\r\n\r\nprocedure TJvSAL.xNoParser;\r\nbegin\r\n // do nothing\r\nend;\r\n\r\n//=== { TJvAtom } ============================================================\r\n\r\nprocedure TJvAtom.SetActor(const Value: TJvSALProc);\r\nbegin\r\n FActor := Value;\r\nend;\r\n\r\nprocedure TJvAtom.SetValue(const AValue: Variant);\r\nbegin\r\n FValue := AValue;\r\nend;\r\n\r\n//=== { TJvAtoms } ===========================================================\r\n\r\ndestructor TJvAtoms.Destroy;\r\nbegin\r\n ClearAll;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvAtoms.ClearAll;\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := 0 to Count - 1 do\r\n TJvAtom(Objects[I]).Free;\r\n Clear;\r\nend;\r\n\r\n//=== { TJvSALProcAtom } =====================================================\r\n\r\nprocedure TJvSALProcAtom.SetActor(const Value: TJvSALProc);\r\nbegin\r\n FActor := Value;\r\nend;\r\n\r\nprocedure TJvSALProcAtom.SetParser(const Value: TJvSALProc);\r\nbegin\r\n FParser := Value;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvSALCore.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: jvSALCore.PAS, released on 2002-06-15.\r\n\r\nThe Initial Developer of the Original Code is Jan Verhoeven [jan1 dott verhoeven att wxs dott nl]\r\nPortions created by Jan Verhoeven are Copyright (C) 2002 Jan Verhoeven.\r\nAll Rights Reserved.\r\n\r\nContributor(s): Robert Love [rlove att slcdug dott org].\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvSALCore.pas 13104 2011-09-07 06:50:43Z obones $\r\n\r\nunit JvSALCore;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n SysUtils, Classes, Windows, Messages, Graphics, Controls, Forms, Dialogs,\r\n Variants,\r\n JvSAL, JvTypes;\r\n\r\ntype\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvSALCore = class(TComponent)\r\n private\r\n FSal: TJvSAL;\r\n public\r\n procedure AddProcedures(ASal: TJvSAL);\r\n // SAL language\r\n procedure xIf;\r\n procedure xpIf;\r\n procedure xIfNot;\r\n procedure xpIfNot;\r\n procedure xElse;\r\n procedure xpElse;\r\n procedure xEndIf;\r\n procedure xpEndIf;\r\n procedure xRepeat;\r\n procedure xpRepeat;\r\n procedure xUntil;\r\n procedure xpUntil;\r\n procedure xSelect;\r\n procedure xCase;\r\n procedure xpCase;\r\n procedure xEndCase;\r\n procedure xpEndCase;\r\n procedure xEndSelect;\r\n procedure xExit;\r\n procedure xSet;\r\n procedure xGet;\r\n procedure xAsk;\r\n procedure xSay;\r\n procedure xTrue;\r\n procedure xFalse;\r\n procedure xAnd;\r\n procedure x_Or;\r\n procedure xXor;\r\n procedure xNot;\r\n procedure xEq;\r\n procedure xNe;\r\n procedure xGe;\r\n procedure xLe;\r\n procedure xGt;\r\n procedure xLt;\r\n procedure xNeg;\r\n procedure xAbs;\r\n procedure xAdd;\r\n procedure xSub;\r\n procedure xMul;\r\n procedure xDiv;\r\n procedure xvAdd; // directly add to Variable\r\n procedure xvSub;\r\n procedure xvMul;\r\n procedure xvDiv;\r\n procedure xDec;\r\n procedure xInc;\r\n procedure xDecZero;\r\n procedure xCr;\r\n procedure xDup;\r\n procedure xDrop;\r\n procedure xSwap;\r\n procedure xCap;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvSALCore.pas $';\r\n Revision: '$Revision: 13104 $';\r\n Date: '$Date: 2011-09-07 08:50:43 +0200 (mer. 07 sept. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n Math,\r\n JvConsts, JvResources;\r\n\r\nprocedure TJvSALCore.AddProcedures(ASal: TJvSAL);\r\nbegin\r\n FSal := ASal;\r\n with FSal do\r\n begin\r\n // do not localize\r\n AddProcedure('if', xIf, xpIf);\r\n AddProcedure('ifnot', xIfNot, xpIfNot);\r\n AddProcedure('else', xElse, xpElse);\r\n AddProcedure('endif', xEndIf, xpEndIf);\r\n AddProcedure('repeat', xRepeat, xpRepeat);\r\n AddProcedure('until', xUntil, xpUntil);\r\n AddProcedure('select', xSelect, nil);\r\n AddProcedure('endselect', xEndSelect, nil);\r\n AddProcedure('case', xCase, xpCase);\r\n AddProcedure('endcase', xEndCase, xpEndCase);\r\n AddProcedure('exit', xExit, nil);\r\n AddProcedure('get', xGet, nil);\r\n AddProcedure('set', xSet, nil);\r\n AddProcedure('ask', xAsk, nil);\r\n AddProcedure('say', xSay, nil);\r\n AddProcedure('true', xTrue, nil);\r\n AddProcedure('false', xFalse, nil);\r\n AddProcedure('and', xAnd, nil);\r\n AddProcedure('or', x_Or, nil);\r\n AddProcedure('xor', xXor, nil);\r\n AddProcedure('not', xNot, nil);\r\n AddProcedure('=', xEq, nil);\r\n AddProcedure('<>', xNe, nil);\r\n AddProcedure('>=', xGe, nil);\r\n AddProcedure('<=', xLe, nil);\r\n AddProcedure('>', xGt, nil);\r\n AddProcedure('<', xLt, nil);\r\n AddProcedure('neg', xNeg, nil);\r\n AddProcedure('abs', xAbs, nil);\r\n AddProcedure('+', xAdd, nil);\r\n AddProcedure('-', xSub, nil);\r\n AddProcedure('*', xMul, nil);\r\n AddProcedure('/', xDiv, nil);\r\n AddProcedure('+=', xvAdd, nil);\r\n AddProcedure('-=', xvSub, nil);\r\n AddProcedure('*=', xvMul, nil);\r\n AddProcedure('/=', xvDiv, nil);\r\n AddProcedure('dec', xDec, nil);\r\n AddProcedure('inc', xInc, nil);\r\n AddProcedure('dec?', xDecZero, nil);\r\n AddProcedure('cr', xCr, nil);\r\n AddProcedure('dup', xDup, nil);\r\n AddProcedure('drop', xDrop, nil);\r\n AddProcedure('swap', xSwap, nil);\r\n AddProcedure('cap', xCap, nil);\r\n end;\r\nend;\r\n\r\nprocedure TJvSALCore.x_Or;\r\nbegin\r\n FSal.BoolPush(FSal.BoolPop or FSal.BoolPop);\r\nend;\r\n\r\nprocedure TJvSALCore.xAbs;\r\nbegin\r\n FSal.Push(Abs(FSal.Pop));\r\nend;\r\n\r\nprocedure TJvSALCore.xAdd;\r\nvar\r\n V1, V2: Variant;\r\nbegin\r\n V2 := FSal.Pop;\r\n V1 := FSal.Pop;\r\n FSal.Push(V1 + V2);\r\nend;\r\n\r\nprocedure TJvSALCore.xAnd;\r\nbegin\r\n FSal.BoolPush(FSal.BoolPop and FSal.BoolPop);\r\nend;\r\n\r\nprocedure TJvSALCore.xAsk;\r\nvar\r\n S: string;\r\n V: Variant;\r\nbegin\r\n S := FSal.Pop;\r\n V := InputBox(FSal.Caption, S, '');\r\n if V <> '' then\r\n FSal.Push(V);\r\nend;\r\n\r\nprocedure TJvSALCore.xCap;\r\nbegin\r\n FSal.Caption := FSal.Pop;\r\nend;\r\n\r\nprocedure TJvSALCore.xCase;\r\nvar\r\n V1: Variant;\r\nbegin\r\n V1 := FSal.Pop;\r\n if V1 = FSal.TheSelect then\r\n begin\r\n end\r\n else\r\n FSal.PC := TJvAtom(FSal.Atoms.Objects[FSal.PcProc]).Value + 1;\r\nend;\r\n\r\nprocedure TJvSALCore.xCr;\r\nbegin\r\n FSal.Push(Cr);\r\nend;\r\n\r\nprocedure TJvSALCore.xDec;\r\nbegin\r\n if VarIsEmpty(FSal.Variable.Value) then\r\n raise EJVCLException.CreateResFmt(@RsEVariablesIsNotInitialized, [FSal.VariableName]);\r\n FSal.Variable.Value := FSal.Variable.Value - 1;\r\nend;\r\n\r\nprocedure TJvSALCore.xDecZero; // dec? decrements a Variable and test for zero\r\nbegin\r\n if VarIsEmpty(FSal.Variable.Value) then\r\n raise EJVCLException.CreateResFmt(@RsEVariablesIsNotInitialized, [FSal.VariableName]);\r\n FSal.Variable.Value := FSal.Variable.Value - 1;\r\n FSal.BoolPush(FSal.Variable.Value = 0);\r\nend;\r\n\r\nprocedure TJvSALCore.xDiv;\r\nvar\r\n V1, V2: Double;\r\nbegin\r\n V2 := FSal.Pop;\r\n if V2 = 0.0 then\r\n raise EJVCLException.CreateRes(@RsEDivisionByZeroError);\r\n V1 := FSal.Pop;\r\n FSal.Push(V1 / V2);\r\nend;\r\n\r\nprocedure TJvSALCore.xDrop;\r\nbegin\r\n FSal.Pop;\r\nend;\r\n\r\nprocedure TJvSALCore.xDup;\r\nvar\r\n V1: Variant;\r\nbegin\r\n V1 := FSal.Pop;\r\n FSal.Push(V1);\r\n FSal.Push(V1);\r\nend;\r\n\r\nprocedure TJvSALCore.xElse;\r\nbegin\r\n FSal.PC := TJvAtom(FSal.Atoms.Objects[FSal.PcProc]).Value + 1;\r\nend;\r\n\r\nprocedure TJvSALCore.xEndCase;\r\n// Removed Hint\r\n//var\r\n// c: Integer;\r\nbegin\r\n // c:=FSal.Atoms.Count;\r\n while FSal.PC < FSal.Atoms.Count do\r\n begin\r\n if FSal.Atoms[FSal.PC] = 'endselect' then // do not localize\r\n begin\r\n FSal.PC := FSal.PC + 1;\r\n Exit;\r\n end;\r\n FSal.PC := FSal.PC + 1;\r\n end;\r\n raise EJVCLException.CreateRes(@RsEMissingendselect);\r\nend;\r\n\r\nprocedure TJvSALCore.xEndIf;\r\nbegin\r\n // do nothing\r\nend;\r\n\r\nprocedure TJvSALCore.xEndSelect;\r\nbegin\r\n // do nothing\r\nend;\r\n\r\nprocedure TJvSALCore.xEq;\r\nbegin\r\n FSal.BoolPush(FSal.Pop = FSal.Pop);\r\nend;\r\n\r\nprocedure TJvSALCore.xExit;\r\nbegin\r\n FSal.PC := FSal.Atoms.Count;\r\nend;\r\n\r\nprocedure TJvSALCore.xFalse;\r\nbegin\r\n FSal.BoolPush(False);\r\nend;\r\n\r\nprocedure TJvSALCore.xGe;\r\nbegin\r\n FSal.BoolPush(FSal.Pop >= FSal.Pop);\r\nend;\r\n\r\nprocedure TJvSALCore.xGet;\r\nbegin\r\n FSal.Push(FSal.Variable.Value);\r\nend;\r\n\r\nprocedure TJvSALCore.xGt;\r\nbegin\r\n FSal.BoolPush(FSal.Pop > FSal.Pop);\r\nend;\r\n\r\nprocedure TJvSALCore.xIf;\r\nbegin\r\n if not FSal.BoolPop then\r\n FSal.PC := TJvAtom(FSal.Atoms.Objects[FSal.PcProc]).Value + 1;\r\nend;\r\n\r\nprocedure TJvSALCore.xIfNot;\r\nbegin\r\n if FSal.BoolPop then\r\n FSal.PC := TJvAtom(FSal.Atoms.Objects[FSal.PcProc]).Value + 1;\r\nend;\r\n\r\nprocedure TJvSALCore.xInc;\r\nbegin\r\n if VarIsEmpty(FSal.Variable.Value) then\r\n raise EJVCLException.CreateResFmt(@RsEVariablesIsNotInitialized, [FSal.VariableName]);\r\n FSal.Variable.Value := FSal.Variable.Value + 1;\r\nend;\r\n\r\nprocedure TJvSALCore.xLe;\r\nbegin\r\n FSal.BoolPush(FSal.Pop <= FSal.Pop);\r\nend;\r\n\r\nprocedure TJvSALCore.xLt;\r\nbegin\r\n FSal.BoolPush(FSal.Pop < FSal.Pop);\r\nend;\r\n\r\nprocedure TJvSALCore.xMul;\r\nvar\r\n V1, V2: Double;\r\nbegin\r\n V2 := FSal.Pop;\r\n V1 := FSal.Pop;\r\n FSal.Push(V1 * V2);\r\nend;\r\n\r\nprocedure TJvSALCore.xNe;\r\nbegin\r\n FSal.BoolPush(FSal.Pop <> FSal.Pop);\r\nend;\r\n\r\nprocedure TJvSALCore.xNeg;\r\nbegin\r\n FSal.Push(0 - FSal.Pop);\r\nend;\r\n\r\nprocedure TJvSALCore.xNot;\r\nbegin\r\n FSal.BoolPush(not FSal.BoolPop);\r\nend;\r\n\r\nprocedure TJvSALCore.xRepeat;\r\nbegin\r\n // do nothing\r\nend;\r\n\r\nprocedure TJvSALCore.xSay;\r\nbegin\r\n ShowMessage(FSal.Pop);\r\nend;\r\n\r\nprocedure TJvSALCore.xSelect;\r\nbegin\r\n FSal.TheSelect := FSal.Pop;\r\nend;\r\n\r\nprocedure TJvSALCore.xSet;\r\nbegin\r\n FSal.Variable.Value := FSal.Pop;\r\nend;\r\n\r\nprocedure TJvSALCore.xSub;\r\nvar\r\n V1, V2: Double;\r\nbegin\r\n V2 := FSal.Pop;\r\n V1 := FSal.Pop;\r\n FSal.Push(V1 - V2);\r\nend;\r\n\r\nprocedure TJvSALCore.xSwap;\r\nvar\r\n V1, V2: Variant;\r\nbegin\r\n V2 := FSal.Pop;\r\n V1 := FSal.Pop;\r\n FSal.Push(V2);\r\n FSal.Push(V1);\r\nend;\r\n\r\nprocedure TJvSALCore.xTrue;\r\nbegin\r\n FSal.BoolPush(True);\r\nend;\r\n\r\nprocedure TJvSALCore.xUntil;\r\nbegin\r\n if not FSal.BoolPop then\r\n FSal.PC := TJvAtom(FSal.Atoms.Objects[FSal.PcProc]).Value;\r\nend;\r\n\r\nprocedure TJvSALCore.xvAdd; // +=\r\nbegin\r\n if VarIsEmpty(FSal.Variable.Value) then\r\n FSal.Variable.Value := FSal.Pop\r\n else\r\n FSal.Variable.Value := FSal.Variable.Value + FSal.Pop;\r\nend;\r\n\r\nprocedure TJvSALCore.xvDiv; // /=\r\nvar\r\n V1: Variant;\r\nbegin\r\n if VarIsEmpty(FSal.Variable.Value) then\r\n raise EJVCLException.CreateResFmt(@RsEVariablesIsNotInitialized, [FSal.VariableName]);\r\n V1 := FSal.Pop;\r\n if V1 = 0 then\r\n raise EJVCLException.CreateRes(@RsEDivisionByZeroError);\r\n FSal.Variable.Value := FSal.Variable.Value / V1;\r\nend;\r\n\r\nprocedure TJvSALCore.xvMul; // *=\r\nbegin\r\n if VarIsEmpty(FSal.Variable.Value) then\r\n raise EJVCLException.CreateResFmt(@RsEVariablesIsNotInitialized, [FSal.VariableName]);\r\n FSal.Variable.Value := FSal.Variable.Value * FSal.Pop;\r\nend;\r\n\r\nprocedure TJvSALCore.xvSub; // -=\r\nbegin\r\n if VarIsEmpty(FSal.Variable.Value) then\r\n raise EJVCLException.CreateResFmt(@RsEVariablesIsNotInitialized, [FSal.VariableName]);\r\n FSal.Variable.Value := FSal.Variable.Value - FSal.Pop;\r\nend;\r\n\r\nprocedure TJvSALCore.xXor;\r\nbegin\r\n FSal.BoolPush(FSal.BoolPop xor FSal.BoolPop);\r\nend;\r\n\r\nprocedure TJvSALCore.xpIf;\r\nbegin\r\n FSal.rPush(FSal.APO(FSal.Token, xIf))\r\nend;\r\n\r\nprocedure TJvSALCore.xpEndCase;\r\nbegin\r\n TJvAtom(FSal.Atoms.Objects[FSal.rPop]).Value := FSal.APO(FSal.Token, xEndCase);\r\nend;\r\n\r\nprocedure TJvSALCore.xpIfNot;\r\nbegin\r\n FSal.rPush(FSal.APO(FSal.Token, xIfNot));\r\nend;\r\n\r\nprocedure TJvSALCore.xpEndIf;\r\nbegin\r\n TJvAtom(FSal.Atoms.Objects[FSal.rPop]).Value := FSal.APO(FSal.Token, xEndIf);\r\nend;\r\n\r\nprocedure TJvSALCore.xpElse;\r\nvar\r\n I: Integer;\r\nbegin\r\n I := FSal.APO(FSal.Token, xElse);\r\n TJvAtom(FSal.Atoms.Objects[FSal.rPop]).Value := I;\r\n FSal.rPush(I);\r\nend;\r\n\r\nprocedure TJvSALCore.xpCase;\r\nbegin\r\n FSal.rPush(FSal.APO(FSal.Token, xCase));\r\nend;\r\n\r\nprocedure TJvSALCore.xpRepeat;\r\nbegin\r\n FSal.rPush(FSal.APO(FSal.Token, xRepeat))\r\nend;\r\n\r\nprocedure TJvSALCore.xpUntil;\r\nbegin\r\n TJvAtom(FSal.Atoms.Objects[FSal.APO(FSal.Token, xUntil)]).Value := FSal.rPop;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend." }, { "path": "External/Jedi/Jvcl/run/JvSALHashList.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvSALHashList.PAS, released on 2002-06-15.\r\n\r\nThe Initial Developer of the Original Code is Jan Verhoeven [jan1 dott verhoeven att wxs dott nl]\r\nPortions created by Jan Verhoeven are Copyright (C) 2002 Jan Verhoeven.\r\nAll Rights Reserved.\r\n\r\nContributor(s): Robert Love [rlove att slcdug dott org].\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvSALHashList.pas 12461 2009-08-14 17:21:33Z obones $\r\n\r\nunit JvSALHashList;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n {$IFDEF MSWINDOWS}\r\n Windows,\r\n {$ENDIF MSWINDOWS}\r\n {$IFDEF HAS_UNIT_LIBC}\r\n Libc,\r\n {$ENDIF HAS_UNIT_LIBC}\r\n Classes, SysUtils;\r\n\r\ntype\r\n TJvSALProc = procedure of object;\r\n TJvSALHash = function(const AString: string): Integer;\r\n TJvSALHashCompare = function(const Str1: string; const Str2: string): Boolean;\r\n\r\n PHashPointerList = ^THashPointerList;\r\n THashPointerList = array[1..1] of TObject;\r\n\r\n TJvBaseStringHashList = class(TObject)\r\n FList: PHashPointerList;\r\n FCapacity: Integer;\r\n FHash: TJvSALHash;\r\n protected\r\n function Get(Index: Integer): Pointer;\r\n procedure Put(Index: Integer; Item: Pointer);\r\n procedure SetCapacity(NewCapacity: Integer);\r\n public\r\n destructor Destroy; override;\r\n procedure Clear;\r\n property Capacity: Integer read FCapacity;\r\n property Items[Index: Integer]: Pointer read Get write Put; default;\r\n end;\r\n\r\n TJvHashStrings = class(TJvBaseStringHashList)\r\n public\r\n procedure AddString(AString: string; AId, AExId: TJvSALProc);\r\n end;\r\n\r\n TJvHashItems = class(TJvBaseStringHashList)\r\n public\r\n constructor Create(AHash: TJvSALHash);\r\n procedure AddString(AString: string; AId, AExId: TJvSALProc);\r\n end;\r\n\r\n TJvSALHashList = class(TJvBaseStringHashList)\r\n private\r\n FSecondaryHash: TJvSALHash;\r\n FCompare: TJvSALHashCompare;\r\n public\r\n constructor Create(Primary, Secondary: TJvSALHash; ACompare: TJvSALHashCompare);\r\n procedure AddString(AString: string; AId, AExId: TJvSALProc);\r\n function Hash(const S: string; var AId: TJvSALProc; var AExId: TJvSALProc): Boolean;\r\n function HashEx(const S: string; var AId: TJvSALProc; var AExId: TJvSALProc; HashValue: Integer): Boolean;\r\n end;\r\n\r\nfunction CrcHash(const AString: string): Integer;\r\nfunction ICrcHash(const AString: string): Integer;\r\nfunction SmallCrcHash(const AString: string): Integer;\r\nfunction ISmallCrcHash(const AString: string): Integer;\r\nfunction TinyHash(const AString: string): Integer;\r\nfunction ITinyHash(const AString: string): Integer;\r\nfunction HashCompare(const Str1: string; const Str2: string): Boolean;\r\nfunction IHashCompare(const Str1: string; const Str2: string): Boolean;\r\n\r\nfunction HashSecondaryOne(const AString: string): Integer;\r\nfunction HashSecondaryTwo(const AString: string): Integer;\r\n\r\nprocedure InitTables;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvSALHashList.pas $';\r\n Revision: '$Revision: 12461 $';\r\n Date: '$Date: 2009-08-14 19:21:33 +0200 (ven. 14 août 2009) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\n\r\ntype\r\n TJvHashWord = class(TObject)\r\n S: string;\r\n Id: TJvSALProc;\r\n ExID: TJvSALProc;\r\n constructor Create(AString: string; AId, AExId: TJvSALProc);\r\n end;\r\n\r\nvar\r\n GlobalHashTable: array [#0..#255] of Byte;\r\n GlobalInsensitiveHashTable: array [#0..#255] of Byte;\r\n\r\nprocedure InitTables;\r\nvar\r\n I, K: Char;\r\n Temp: Byte;\r\nbegin\r\n for I := #0 to #255 do\r\n GlobalHashTable[I] := Ord(I);\r\n RandSeed := 255;\r\n for I := #1 to #255 do\r\n begin\r\n repeat\r\n K := Char(Random(255));\r\n until K <> #0;\r\n Temp := GlobalHashTable[I];\r\n GlobalHashTable[I] := GlobalHashTable[K];\r\n GlobalHashTable[K] := Temp;\r\n end;\r\n for I := #0 to #255 do\r\n GlobalInsensitiveHashTable[I] := GlobalHashTable[AnsiLowerCase(string(I))[1]];\r\nend;\r\n\r\n{ based on a Hash function by Cyrille de Brebisson }\r\n\r\nfunction CrcHash(const AString: string): Integer;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := 0;\r\n for I := 1 to Length(AString) do\r\n begin\r\n Result := (Result shr 4) xor (((Result xor GlobalHashTable[AString[I]]) and $F) * $1000);\r\n Result := (Result shr 4) xor (((Result xor (Ord(GlobalHashTable[AString[I]]) shr 4)) and $F) * $1000);\r\n end;\r\n if Result = 0 then\r\n Result := Length(AString) mod 8 + 1;\r\nend;\r\n\r\nfunction ICrcHash(const AString: string): Integer;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := 0;\r\n for I := 1 to Length(AString) do\r\n begin\r\n Result := (Result shr 4) xor (((Result xor GlobalInsensitiveHashTable[AString[I]]) and $F) * $1000);\r\n Result := (Result shr 4) xor (((Result xor (Ord(GlobalInsensitiveHashTable[AString[I]]) shr 4)) and $F) * $1000);\r\n end;\r\n if Result = 0 then\r\n Result := Length(AString) mod 8 + 1;\r\nend;\r\n\r\nfunction SmallCrcHash(const AString: string): Integer;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := 0;\r\n for I := 1 to Length(AString) do\r\n begin\r\n Result := (Result shr 4) xor (((Result xor GlobalHashTable[AString[I]]) and $F) * $80);\r\n Result := (Result shr 4) xor (((Result xor (Ord(GlobalHashTable[AString[I]]) shr 4)) and $F) * $80);\r\n if I = 3 then\r\n Break;\r\n end;\r\n if Result = 0 then\r\n Result := Length(AString) mod 8 + 1;\r\nend;\r\n\r\nfunction ISmallCrcHash(const AString: string): Integer;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := 0;\r\n for I := 1 to Length(AString) do\r\n begin\r\n Result := (Result shr 4) xor (((Result xor GlobalInsensitiveHashTable[AString[I]]) and $F) * $80);\r\n Result := (Result shr 4) xor (((Result xor (Ord(GlobalInsensitiveHashTable[AString[I]]) shr 4)) and $F) * $80);\r\n if I = 3 then\r\n Break;\r\n end;\r\n if Result = 0 then\r\n Result := Length(AString) mod 8 + 1;\r\nend;\r\n\r\nfunction TinyHash(const AString: string): Integer;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := Length(AString);\r\n for I := 1 to Length(AString) do\r\n begin\r\n Inc(Result, GlobalHashTable[AString[I]]);\r\n Result := Result mod 128 + 1;\r\n if I = 2 then\r\n Break;\r\n end;\r\nend;\r\n\r\nfunction ITinyHash(const AString: string): Integer;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := Length(AString);\r\n for I := 1 to Length(AString) do\r\n begin\r\n Inc(Result, GlobalInsensitiveHashTable[AString[I]]);\r\n Result := Result mod 128 + 1;\r\n if I = 2 then\r\n Break;\r\n end;\r\nend;\r\n\r\nfunction HashCompare(const Str1: string; const Str2: string): Boolean;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := Length(Str1) = Length(Str2);\r\n if not Result then\r\n Exit;\r\n for I := 1 to Length(Str1) do\r\n if Str1[I] <> Str2[I] then\r\n begin\r\n Result := False;\r\n Break;\r\n end;\r\nend;\r\n\r\nfunction IHashCompare(const Str1: string; const Str2: string): Boolean;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := Length(Str1) = Length(Str2);\r\n if not Result then\r\n Exit;\r\n for I := 1 to Length(Str1) do\r\n if GlobalInsensitiveHashTable[Str1[I]] <> GlobalInsensitiveHashTable[Str2[I]] then\r\n begin\r\n Result := False;\r\n Break;\r\n end;\r\nend;\r\n\r\nfunction HashSecondaryOne(const AString: string): Integer;\r\nbegin\r\n Result := Length(AString);\r\n Inc(Result, GlobalInsensitiveHashTable[AString[Length(AString)]]);\r\n Result := Result mod 16 + 1;\r\n Inc(Result, GlobalInsensitiveHashTable[AString[1]]);\r\n Result := Result mod 16 + 1;\r\nend;\r\n\r\nfunction HashSecondaryTwo(const AString: string): Integer;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := Length(AString);\r\n for I := Length(AString) downto 1 do\r\n begin\r\n Inc(Result, GlobalInsensitiveHashTable[AString[I]]);\r\n Result := Result mod 32 + 1;\r\n end;\r\nend;\r\n\r\n//=== { TJvHashString } ======================================================\r\n\r\nconstructor TJvHashWord.Create(AString: string; AId, AExId: TJvSALProc);\r\nbegin\r\n inherited Create;\r\n S := AString;\r\n Id := AId;\r\n ExID := AExId;\r\nend;\r\n\r\n//=== { TJvBaseStringHashList } ==============================================\r\n\r\nprocedure TJvBaseStringHashList.Clear;\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := 1 to FCapacity do\r\n FList[I].Free;\r\n ReallocMem(FList, 0);\r\n FCapacity := 0;\r\nend;\r\n\r\ndestructor TJvBaseStringHashList.Destroy;\r\nbegin\r\n Clear;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJvBaseStringHashList.Get(Index: Integer): Pointer;\r\nbegin\r\n Result := nil;\r\n if (Index > 0) and (Index <= FCapacity) then\r\n Result := FList[Index];\r\nend;\r\n\r\nprocedure TJvBaseStringHashList.Put(Index: Integer; Item: Pointer);\r\nbegin\r\n if (Index > 0) and (Index <= FCapacity) then\r\n FList[Index] := Item;\r\nend;\r\n\r\nprocedure TJvBaseStringHashList.SetCapacity(NewCapacity: Integer);\r\nvar\r\n I, OldCapacity: Integer;\r\nbegin\r\n if NewCapacity > FCapacity then\r\n begin\r\n ReallocMem(FList, (NewCapacity) * SizeOf(Pointer));\r\n OldCapacity := FCapacity;\r\n FCapacity := NewCapacity;\r\n for I := OldCapacity + 1 to NewCapacity do\r\n Items[I] := nil;\r\n end;\r\nend;\r\n\r\n//=== { TJvHashStrings } =====================================================\r\n\r\nprocedure TJvHashStrings.AddString(AString: string; AId, AExId: TJvSALProc);\r\nbegin\r\n SetCapacity(Capacity + 1);\r\n FList[Capacity] := TJvHashWord.Create(AString, AId, AExId);\r\nend;\r\n\r\n//=== { TJvHashItems } =======================================================\r\n\r\nconstructor TJvHashItems.Create(AHash: TJvSALHash);\r\nbegin\r\n inherited Create;\r\n FHash := AHash;\r\nend;\r\n\r\nprocedure TJvHashItems.AddString(AString: string; AId, AExId: TJvSALProc);\r\nvar\r\n HashWord: TJvHashWord;\r\n HashStrings: TJvHashStrings;\r\n HashVal: Integer;\r\nbegin\r\n HashVal := FHash(AString);\r\n SetCapacity(HashVal);\r\n if Items[HashVal] = nil then\r\n Items[HashVal] := TJvHashWord.Create(AString, AId, AExId)\r\n else\r\n if FList[HashVal] is TJvHashStrings then\r\n TJvHashStrings(Items[HashVal]).AddString(AString, AId, AExId)\r\n else\r\n begin\r\n HashWord := Items[HashVal];\r\n HashStrings := TJvHashStrings.Create;\r\n Items[HashVal] := HashStrings;\r\n HashStrings.AddString(HashWord.S, HashWord.Id, HashWord.ExID);\r\n HashWord.Free;\r\n HashStrings.AddString(AString, AId, AExId)\r\n end;\r\nend;\r\n\r\n//=== { TJvSALHashList } =====================================================\r\n\r\nconstructor TJvSALHashList.Create(Primary, Secondary: TJvSALHash; ACompare: TJvSALHashCompare);\r\nbegin\r\n inherited Create;\r\n FHash := Primary;\r\n FSecondaryHash := Secondary;\r\n FCompare := ACompare;\r\nend;\r\n\r\nprocedure TJvSALHashList.AddString(AString: string; AId, AExId: TJvSALProc);\r\nvar\r\n HashWord: TJvHashWord;\r\n HashValue: Integer;\r\n HashItems: TJvHashItems;\r\nbegin\r\n HashValue := FHash(AString);\r\n if HashValue >= FCapacity then\r\n SetCapacity(HashValue);\r\n if Items[HashValue] = nil then\r\n Items[HashValue] := TJvHashWord.Create(AString, AId, AExId)\r\n else\r\n if FList[HashValue] is TJvHashItems then\r\n TJvHashItems(Items[HashValue]).AddString(AString, AId, AExId)\r\n else\r\n begin\r\n HashWord := Items[HashValue];\r\n HashItems := TJvHashItems.Create(FSecondaryHash);\r\n Items[HashValue] := HashItems;\r\n HashItems.AddString(HashWord.S, HashWord.Id, HashWord.ExID);\r\n HashWord.Free;\r\n HashItems.AddString(AString, AId, AExId);\r\n end;\r\nend;\r\n\r\nfunction TJvSALHashList.Hash(const S: string; var AId: TJvSALProc;\r\n var AExId: TJvSALProc): Boolean;\r\nbegin\r\n Result := HashEx(S, AId, AExId, FHash(S));\r\nend;\r\n\r\nfunction TJvSALHashList.HashEx(const S: string; var AId: TJvSALProc;\r\n var AExId: TJvSALProc; HashValue: Integer): Boolean;\r\nvar\r\n Temp: TObject;\r\n HashWord: TJvHashWord;\r\n HashItems: TJvHashItems;\r\n I, ItemHash: Integer;\r\nbegin\r\n Result := False;\r\n AId := nil;\r\n AExId := nil;\r\n if (HashValue < 1) or (HashValue > Capacity) then\r\n Exit;\r\n if Items[HashValue] <> nil then\r\n begin\r\n if FList[HashValue] is TJvHashWord then\r\n begin\r\n HashWord := Items[HashValue];\r\n Result := FCompare(HashWord.S, S);\r\n if Result then\r\n begin\r\n AId := HashWord.Id;\r\n AExId := HashWord.ExID;\r\n end;\r\n end\r\n else\r\n begin\r\n HashItems := Items[HashValue];\r\n ItemHash := HashItems.FHash(S);\r\n if ItemHash > HashItems.Capacity then\r\n Exit;\r\n Temp := HashItems[ItemHash];\r\n if Temp <> nil then\r\n if Temp is TJvHashWord then\r\n begin\r\n Result := FCompare(TJvHashWord(Temp).S, S);\r\n if Result then\r\n begin\r\n AId := TJvHashWord(Temp).Id;\r\n AExId := TJvHashWord(Temp).ExID;\r\n end;\r\n end\r\n else\r\n for I := 1 to TJvHashStrings(Temp).Capacity do\r\n begin\r\n HashWord := TJvHashStrings(Temp)[I];\r\n Result := FCompare(HashWord.S, S);\r\n if Result then\r\n begin\r\n AId := HashWord.Id;\r\n AExId := HashWord.ExID;\r\n Exit;\r\n end;\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\ninitialization\r\n {$IFDEF UNITVERSIONING}\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n {$ENDIF UNITVERSIONING}\r\n InitTables;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvSALMath.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvSAL.PAS, released on 2002-06-15.\r\n\r\nThe Initial Developer of the Original Code is Jan Verhoeven [jan1 dott verhoeven att wxs dott nl]\r\nPortions created by Jan Verhoeven are Copyright (C) 2002 Jan Verhoeven.\r\nAll Rights Reserved.\r\n\r\nContributor(s): Robert Love [rlove att slcdug dott org].\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvSALMath.pas 13104 2011-09-07 06:50:43Z obones $\r\n\r\nunit JvSALMath;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n SysUtils, Classes, Math,\r\n JvSAL, JvTypes;\r\n\r\ntype\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvSALMath = class(TComponent)\r\n private\r\n FSal: TJvSAL;\r\n public\r\n procedure AddProcedures(ASal: TJvSAL);\r\n procedure XSin;\r\n procedure XArcSin;\r\n procedure XCos;\r\n procedure XArcCos;\r\n procedure XTan;\r\n procedure XArcTan;\r\n procedure XPi;\r\n procedure XExp;\r\n procedure XLn;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvSALMath.pas $';\r\n Revision: '$Revision: 13104 $';\r\n Date: '$Date: 2011-09-07 08:50:43 +0200 (mer. 07 sept. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\n\r\nprocedure TJvSALMath.AddProcedures(ASal: TJvSAL);\r\nbegin\r\n FSal := ASal;\r\n FSal.AddProcedure('sin', XSin, nil);\r\n FSal.AddProcedure('cos', XCos, nil);\r\n FSal.AddProcedure('tan', XTan, nil);\r\n // (rom) using XSin, XCos, XTan looks suspicious. Incomplete?\r\n FSal.AddProcedure('arcsin', XSin, nil);\r\n FSal.AddProcedure('arccos', XCos, nil);\r\n FSal.AddProcedure('arctan', XTan, nil);\r\n FSal.AddProcedure('pi', XPi, nil);\r\n // (rom) using XPi looks suspicious. Incomplete?\r\n FSal.AddProcedure('exp', XPi, nil);\r\n FSal.AddProcedure('ln', XPi, nil);\r\nend;\r\n\r\nprocedure TJvSALMath.XSin;\r\nvar\r\n V1: Variant;\r\nbegin\r\n V1 := FSal.Pop;\r\n V1 := Sin(V1);\r\n FSal.Push(V1);\r\nend;\r\n\r\nprocedure TJvSALMath.XCos;\r\nvar\r\n V1: Variant;\r\nbegin\r\n V1 := FSal.Pop;\r\n V1 := Cos(V1);\r\n FSal.Push(V1);\r\nend;\r\n\r\nprocedure TJvSALMath.XTan;\r\nvar\r\n V1: Variant;\r\nbegin\r\n V1 := FSal.Pop;\r\n V1 := Tan(V1);\r\n FSal.Push(V1);\r\nend;\r\n\r\nprocedure TJvSALMath.XPi;\r\nbegin\r\n FSal.Push(Pi);\r\nend;\r\n\r\nprocedure TJvSALMath.XArcCos;\r\nbegin\r\n FSal.Push(ArcCos(FSal.Pop));\r\nend;\r\n\r\nprocedure TJvSALMath.XArcSin;\r\nbegin\r\n FSal.Push(ArcSin(FSal.Pop));\r\nend;\r\n\r\nprocedure TJvSALMath.XArcTan;\r\nbegin\r\n FSal.Push(ArcTan(FSal.Pop));\r\nend;\r\n\r\nprocedure TJvSALMath.XExp;\r\nbegin\r\n FSal.Push(Exp(FSal.Pop));\r\nend;\r\n\r\nprocedure TJvSALMath.XLn;\r\nbegin\r\n FSal.Push(Ln(FSal.Pop));\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend." }, { "path": "External/Jedi/Jvcl/run/JvSHFileOperation.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvSHFileOp.PAS, released on 2002-05-26.\r\n\r\nThe Initial Developer of the Original Code is Peter Thrnqvist [peter3 at sourceforge dot net]\r\nPortions created by Peter Thrnqvist are Copyright (C) 2002 Peter Thrnqvist.\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nDescription:\r\n A wrapper component for the SHFileOperation function\r\n\r\nKnown Issues:\r\n fofConfirmMouse does nothing\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvSHFileOperation.pas 13352 2012-06-14 09:21:26Z obones $\r\n\r\nunit JvSHFileOperation;\r\n\r\n{$I jvcl.inc}\r\n{$I windowsonly.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n {$IFDEF MSWINDOWS}\r\n Windows, ShellAPI,\r\n {$ENDIF MSWINDOWS}\r\n SysUtils, Classes, Controls,\r\n JvBaseDlg, JvWin32;\r\n\r\ntype\r\n // type of operation to perform\r\n TJvShFileMappingEvent = procedure(Sender: TObject; const OldFileName, NewFileName: string) of object;\r\n TJvSHFileOpType = (foCopy, foDelete, foMove, foRename);\r\n\r\n TJvSHFileOption = (fofAllowUndo, fofConfirmMouse, fofFilesOnly, fofMultiDestFiles,\r\n fofNoConfirmation, fofNoConfirmMkDir, fofRenameOnCollision, fofSilent,\r\n fofSimpleProgress, fofWantMappingHandle, fofNoErrorUI, fofNoCopySecurityAttributes,\r\n fofNoRecursion, fofNoConnectedElements, fofNoRecurseParse, fofWantNukeWarning);\r\n TJvSHFileOptions = set of TJvSHFileOption;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvSHFileOperation = class(TJvCommonDialog)\r\n private\r\n FSourceFiles: TStringList;\r\n FDestFiles: TStringList;\r\n FOperation: TJvSHFileOpType;\r\n FOptions: TJvSHFileOptions;\r\n FTitle: string;\r\n FLastErrorMsg: string;\r\n FOnFileMapping: TJvShFileMappingEvent;\r\n function GetSourceFiles: TStrings;\r\n function GetDestFiles: TStrings;\r\n procedure SetSourceFiles(Value: TStrings);\r\n procedure SetDestFiles(Value: TStrings);\r\n protected\r\n procedure DoFileMapping(const OldFileName, NewFileName: string); virtual;\r\n public\r\n // performs the Operation and returns True if no errors occurred\r\n function Execute(ParentWnd: HWND): Boolean; overload; override;\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n\r\n // Returns the last error message when Execute has failed\r\n property LastErrorMsg: string read FLastErrorMsg;\r\n published\r\n // the files to perform the operation on (one file on each row).\r\n // Filenames can contain wildcards\r\n property SourceFiles: TStrings read GetSourceFiles write SetSourceFiles;\r\n // A list of destination filenames. If this is a folder, only need to add folder once\r\n // Otherwise, destfiles should match sourcefiles exactly\r\n property DestFiles: TStrings read GetDestFiles write SetDestFiles;\r\n // the operation to perform when Execute is called\r\n property Operation: TJvSHFileOpType read FOperation write FOperation default foCopy;\r\n /// Options for the Operation\r\n property Options: TJvSHFileOptions read FOptions write FOptions default [fofAllowUndo, fofFilesOnly];\r\n // Title of the progress dialog\r\n property Title: string read FTitle write FTitle;\r\n // Called when a file was renamed (but only if fofRenameOnCollision and fofWantMappingHandle are both True)\r\n property OnFileMapping: TJvShFileMappingEvent read FOnFileMapping write FOnFileMapping;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvSHFileOperation.pas $';\r\n Revision: '$Revision: 13352 $';\r\n Date: '$Date: 2012-06-14 11:21:26 +0200 (jeu. 14 juin 2012) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n JvResources, JvTypes;\r\n\r\ntype\r\n // helper object for file mappings\r\n PShHandleToMappings = ^TShHandleToMappings;\r\n TShHandleToMappings = packed record // \"hNameMappings points to an int followed by an array of Ansi/Unicode SHNAMEMAPPING structures\"\r\n Count: UINT;\r\n PNameMappings: PSHNameMapping;\r\n end;\r\n\r\nconstructor TJvSHFileOperation.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FSourceFiles := TStringList.Create;\r\n FDestFiles := TStringList.Create;\r\n FOperation := foCopy;\r\n FOptions := [fofAllowUndo, fofFilesOnly];\r\nend;\r\n\r\ndestructor TJvSHFileOperation.Destroy;\r\nbegin\r\n FSourceFiles.Free;\r\n FDestFiles.Free;\r\n inherited Destroy;\r\nend;\r\n\r\n{** returns True if no error occurred and user didn't abort }\r\n\r\nfunction TJvSHFileOperation.Execute(ParentWnd: HWND): Boolean;\r\nconst\r\n AOperation: array [TJvSHFileOpType] of UINT =\r\n (FO_COPY, FO_DELETE, FO_MOVE, FO_RENAME);\r\n AOption: array [TJvSHFileOption] of Word =\r\n (FOF_ALLOWUNDO, FOF_CONFIRMMOUSE, FOF_FILESONLY, FOF_MULTIDESTFILES,\r\n FOF_NOCONFIRMATION, FOF_NOCONFIRMMKDIR, FOF_RENAMEONCOLLISION,\r\n FOF_SILENT, FOF_SIMPLEPROGRESS, FOF_WANTMAPPINGHANDLE, FOF_NOERRORUI,\r\n FOF_NOCOPYSECURITYATTRIBS, FOF_NORECURSION, FOF_NO_CONNECTED_ELEMENTS,\r\n FOF_NORECURSEREPARSE, FOF_WANTNUKEWARNING);\r\nvar\r\n SFOS: TShFileOpStruct;\r\n I: TJvSHFileOption;\r\n J: Integer;\r\n ppFrom, ppTo: string;\r\n PNameMapping: PSHNameMapping;\r\n PNameCount: UINT;\r\n S, D: string;\r\nbegin\r\n if Length(FSourceFiles.Text) = 0 then\r\n EJVCLException.CreateRes(@RsENoFilesSpecifiedToTJvSHFileOperatio);\r\n\r\n FillChar(SFOS, SizeOf(TShFileOpStruct), #0);\r\n\r\n with SFOS do\r\n begin\r\n fAnyOperationsAborted := False;\r\n fFlags := 0;\r\n for I := Low(TJvSHFileOption) to High(TJvSHFileOption) do // Iterate\r\n if I in FOptions then\r\n fFlags := fFlags or AOption[I];\r\n hNameMappings := nil; // this is never used ???\r\n lpszProgressTitle := PChar(FTitle);\r\n ppFrom := '';\r\n ppTo := '';\r\n for J := 0 to FSourceFiles.Count - 1 do\r\n ppFrom := ppFrom + ExpandUNCFilename(FSourceFiles[J]) + #0;\r\n ppFrom := ppFrom + #0;\r\n pFrom := PChar(ppFrom);\r\n\r\n for J := 0 to FDestFiles.Count - 1 do\r\n ppTo := ppTo + ExpandUNCFilename(FDestFiles[J]) + #0;\r\n ppTo := ppTo + #0;\r\n pTo := PChar(ppTo);\r\n\r\n wFunc := AOperation[FOperation];\r\n Wnd := ParentWnd; // (Owner as TForm).Handle;\r\n end;\r\n FLastErrorMsg := EmptyStr;\r\n Result := SHFileOperation(SFOS) = 0;\r\n\r\n // If SHFileOperation fails save error message\r\n if not Result then\r\n FLastErrorMsg := SysErrorMessage(GetLastError);\r\n\r\n Result := Result and not SFOS.fAnyOperationsAborted;\r\n\r\n PNameMapping := Pointer(SFOS.hNameMappings);\r\n if PNameMapping <> nil then\r\n begin\r\n PNameCount := PShHandleToMappings(PNameMapping)^.Count;\r\n PNameMapping := PShHandleToMappings(PNameMapping)^.PNameMappings;\r\n while PNameCount > 0 do\r\n begin\r\n if (PNameMapping.cchOldPath > 0) and (PNameMapping.cchNewPath > 0) then\r\n begin\r\n if Win32Platform = VER_PLATFORM_WIN32_NT then\r\n SetLength(S, PNameMapping.cchOldPath * 2)\r\n else\r\n SetLength(S, PNameMapping.cchOldPath);\r\n Move(PNameMapping.pszOldPath[0], S[1], Length(S) * SizeOf(Char));\r\n if Win32Platform = VER_PLATFORM_WIN32_NT then\r\n SetLength(D, PNameMapping.cchNewPath * 2)\r\n else\r\n SetLength(D, PNameMapping.cchNewPath);\r\n Move(PNameMapping.pszNewPath[0], D[1], Length(D) * SizeOf(Char));\r\n if Win32Platform = VER_PLATFORM_WIN32_NT then\r\n begin\r\n // (p3) ShFileOp returns widechars on NT platforms\r\n {$WARNINGS OFF}\r\n S := WideCharToString(PWideChar(S + #0));\r\n D := WideCharToString(PWideChar(D + #0));\r\n {$WARNINGS ON}\r\n end;\r\n DoFileMapping(S, D);\r\n end;\r\n Inc(PNameMapping);\r\n Dec(PNameCount);\r\n end;\r\n ShFreeNameMappings(Cardinal(SFOS.hNameMappings));\r\n end;\r\nend;\r\n\r\nfunction TJvSHFileOperation.GetSourceFiles: TStrings;\r\nbegin\r\n Result := FSourceFiles;\r\nend;\r\n\r\nfunction TJvSHFileOperation.GetDestFiles: TStrings;\r\nbegin\r\n Result := FDestFiles;\r\nend;\r\n\r\nprocedure TJvSHFileOperation.SetSourceFiles(Value: TStrings);\r\nbegin\r\n FSourceFiles.Assign(Value);\r\nend;\r\n\r\nprocedure TJvSHFileOperation.SetDestFiles(Value: TStrings);\r\nbegin\r\n FDestFiles.Assign(Value);\r\nend;\r\n\r\nprocedure TJvSHFileOperation.DoFileMapping(const OldFileName, NewFileName: string);\r\nbegin\r\n if Assigned(FOnFileMapping) then\r\n FOnFileMapping(Self, OldFileName, NewFileName);\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvSLDMappingEditorDialog.dfm", "content": "object frmSLDMappingEditorDialog: TfrmSLDMappingEditorDialog\r\n Left = 296\r\n Top = 191\r\n BorderStyle = bsDialog\r\n Caption = 'Mapping Editor...'\r\n ClientHeight = 175\r\n ClientWidth = 410\r\n Color = clBtnFace\r\n Constraints.MaxHeight = 224\r\n Constraints.MinHeight = 221\r\n Font.Charset = DEFAULT_CHARSET\r\n Font.Color = clWindowText\r\n Font.Height = -11\r\n Font.Name = 'MS Sans Serif'\r\n Font.Style = []\r\n Menu = EditorFrame.mnuCharMapEdit\r\n OldCreateOrder = False\r\n OnCloseQuery = FormCloseQuery\r\n DesignSize = (\r\n 410\r\n 175)\r\n PixelsPerInch = 96\r\n TextHeight = 13\r\n object lblDigitClassCaption: TLabel\r\n Left = 120\r\n Top = 15\r\n Width = 51\r\n Height = 13\r\n Caption = 'Digit class:'\r\n end\r\n object lblSegmentCountCaption: TLabel\r\n Left = 120\r\n Top = 40\r\n Width = 70\r\n Height = 13\r\n Caption = '# of segments:'\r\n end\r\n object lblCharCaption: TLabel\r\n Left = 120\r\n Top = 65\r\n Width = 49\r\n Height = 13\r\n Caption = 'Character:'\r\n end\r\n object lblMapperValueCaption: TLabel\r\n Left = 120\r\n Top = 90\r\n Width = 73\r\n Height = 13\r\n Caption = 'Mapping value:'\r\n end\r\n object lblSegmentsCaption: TLabel\r\n Left = 120\r\n Top = 115\r\n Width = 50\r\n Height = 13\r\n Caption = 'Segments:'\r\n end\r\n object lblDigitClass: TLabel\r\n Left = 205\r\n Top = 15\r\n Width = 200\r\n Height = 13\r\n Anchors = [akLeft, akTop, akRight]\r\n AutoSize = False\r\n Font.Charset = DEFAULT_CHARSET\r\n Font.Color = clNavy\r\n Font.Height = -11\r\n Font.Name = 'MS Sans Serif'\r\n Font.Style = []\r\n ParentFont = False\r\n end\r\n object lblSegmentCount: TLabel\r\n Left = 205\r\n Top = 40\r\n Width = 200\r\n Height = 13\r\n Anchors = [akLeft, akTop, akRight]\r\n AutoSize = False\r\n Font.Charset = DEFAULT_CHARSET\r\n Font.Color = clNavy\r\n Font.Height = -11\r\n Font.Name = 'MS Sans Serif'\r\n Font.Style = []\r\n ParentFont = False\r\n end\r\n object lblChar: TLabel\r\n Left = 205\r\n Top = 65\r\n Width = 200\r\n Height = 13\r\n Anchors = [akLeft, akTop, akRight]\r\n AutoSize = False\r\n Font.Charset = DEFAULT_CHARSET\r\n Font.Color = clNavy\r\n Font.Height = -11\r\n Font.Name = 'MS Sans Serif'\r\n Font.Style = []\r\n ParentFont = False\r\n end\r\n object lblMapperValue: TLabel\r\n Left = 205\r\n Top = 90\r\n Width = 200\r\n Height = 13\r\n Anchors = [akLeft, akTop, akRight]\r\n AutoSize = False\r\n Font.Charset = DEFAULT_CHARSET\r\n Font.Color = clNavy\r\n Font.Height = -11\r\n Font.Name = 'MS Sans Serif'\r\n Font.Style = []\r\n ParentFont = False\r\n end\r\n object lblSegments: TLabel\r\n Left = 205\r\n Top = 115\r\n Width = 200\r\n Height = 13\r\n Anchors = [akLeft, akTop, akRight]\r\n AutoSize = False\r\n Font.Charset = DEFAULT_CHARSET\r\n Font.Color = clNavy\r\n Font.Height = -11\r\n Font.Name = 'MS Sans Serif'\r\n Font.Style = []\r\n ParentFont = False\r\n end\r\n inline EditorFrame: TfmeJvSegmentedLEDDisplayMapper\r\n Left = 5\r\n Top = 5\r\n Width = 128\r\n Height = 135\r\n Color = clBlack\r\n ParentColor = False\r\n PopupMenu = EditorFrame.pmDigit\r\n TabOrder = 0\r\n object sldEdit: TJvSegmentedLEDDisplay\r\n Left = 5\r\n Top = 5\r\n Width = 95\r\n Height = 125\r\n AutoSize = False\r\n DigitClassName = 'TJv7SegmentedLEDDigit'\r\n DigitHeight = 90\r\n Digits = <>\r\n DigitWidth = 60\r\n DotSize = 12\r\n PopupMenu = EditorFrame.pmDigit\r\n SegmentLitColor = clRed\r\n SegmentSpacing = 4\r\n SegmentThickness = 8\r\n SegmentUnlitColor = clMaroon\r\n Slant = 10\r\n end\r\n object pmDigit: TPopupMenu\r\n Left = 5\r\n Top = 55\r\n object miSetStates: TMenuItem\r\n Action = EditorFrame.aiEditSetAll\r\n end\r\n object miClearStates: TMenuItem\r\n Action = EditorFrame.aiEditClear\r\n end\r\n object miInvertStates: TMenuItem\r\n Action = EditorFrame.aiEditInvert\r\n end\r\n end\r\n object mnuCharMapEdit: TMainMenu\r\n Left = 5\r\n Top = 10\r\n object File1: TMenuItem\r\n Caption = '&File'\r\n object Open1: TMenuItem\r\n Action = EditorFrame.aiFileOpen\r\n end\r\n object Save1: TMenuItem\r\n Action = EditorFrame.aiFileSave\r\n end\r\n object N1: TMenuItem\r\n Caption = '-'\r\n end\r\n object Default1: TMenuItem\r\n Action = EditorFrame.aiFileLoadDefault\r\n end\r\n object N2: TMenuItem\r\n Caption = '-'\r\n end\r\n object Close1: TMenuItem\r\n Action = EditorFrame.aiFileClose\r\n end\r\n end\r\n object Edit1: TMenuItem\r\n Caption = '&Edit'\r\n object Copy1: TMenuItem\r\n Action = EditorFrame.aiEditCopy\r\n end\r\n object Paste1: TMenuItem\r\n Action = EditorFrame.aiEditPaste\r\n end\r\n object N3: TMenuItem\r\n Caption = '-'\r\n end\r\n object Selectchar1: TMenuItem\r\n Action = EditorFrame.aiEditSelectChar\r\n end\r\n object Apply1: TMenuItem\r\n Action = EditorFrame.aiEditApply\r\n end\r\n object Revert1: TMenuItem\r\n Action = EditorFrame.aiEditRevert\r\n end\r\n object N4: TMenuItem\r\n Caption = '-'\r\n end\r\n object Setallsegments1: TMenuItem\r\n Action = EditorFrame.aiEditSetAll\r\n end\r\n object Emptysegments1: TMenuItem\r\n Action = EditorFrame.aiEditClear\r\n end\r\n object Invertsegments1: TMenuItem\r\n Action = EditorFrame.aiEditInvert\r\n end\r\n end\r\n end\r\n object alCharMapEditor: TActionList\r\n Left = 5\r\n Top = 100\r\n object aiFileOpen: TAction\r\n Caption = '&Open...'\r\n ShortCut = 16463\r\n end\r\n object aiFileSave: TAction\r\n Caption = '&Save...'\r\n ShortCut = 16467\r\n end\r\n object aiFileLoadDefault: TAction\r\n Caption = '&Default'\r\n end\r\n object aiFileClose: TAction\r\n Caption = '&Close'\r\n ShortCut = 32883\r\n end\r\n object aiEditCopy: TAction\r\n Caption = '&Copy'\r\n ShortCut = 16451\r\n end\r\n object aiEditPaste: TAction\r\n Caption = '&Paste'\r\n ShortCut = 16470\r\n end\r\n object aiEditClear: TAction\r\n Caption = '&Empty segments'\r\n end\r\n object aiEditSetAll: TAction\r\n Caption = '&Set all segments'\r\n end\r\n object aiEditInvert: TAction\r\n Caption = '&Invert segments'\r\n end\r\n object aiEditSelectChar: TAction\r\n Caption = 'Select c&har...'\r\n end\r\n object aiEditRevert: TAction\r\n Caption = '&Revert'\r\n end\r\n object aiEditApply: TAction\r\n Caption = '&Apply'\r\n end\r\n end\r\n end\r\n object btnOK: TButton\r\n Left = 330\r\n Top = 145\r\n Width = 75\r\n Height = 25\r\n Anchors = [akRight, akBottom]\r\n Caption = 'OK'\r\n Default = True\r\n TabOrder = 1\r\n end\r\n object pmDigit: TPopupMenu\r\n Left = 5\r\n Top = 55\r\n object miSetStates: TMenuItem\r\n Action = EditorFrame.aiEditSetAll\r\n end\r\n object miClearStates: TMenuItem\r\n Action = EditorFrame.aiEditClear\r\n end\r\n object miInvertStates: TMenuItem\r\n Action = EditorFrame.aiEditInvert\r\n end\r\n end\r\n object mnuCharMapEdit: TMainMenu\r\n Left = 5\r\n Top = 10\r\n object File1: TMenuItem\r\n Caption = '&File'\r\n object Open1: TMenuItem\r\n Action = EditorFrame.aiFileOpen\r\n end\r\n object Save1: TMenuItem\r\n Action = EditorFrame.aiFileSave\r\n end\r\n object N1: TMenuItem\r\n Caption = '-'\r\n end\r\n object Default1: TMenuItem\r\n Action = EditorFrame.aiFileLoadDefault\r\n end\r\n object N2: TMenuItem\r\n Caption = '-'\r\n end\r\n object Close1: TMenuItem\r\n Action = EditorFrame.aiFileClose\r\n end\r\n end\r\n object Edit1: TMenuItem\r\n Caption = '&Edit'\r\n object Copy1: TMenuItem\r\n Action = EditorFrame.aiEditCopy\r\n end\r\n object Paste1: TMenuItem\r\n Action = EditorFrame.aiEditPaste\r\n end\r\n object N3: TMenuItem\r\n Caption = '-'\r\n end\r\n object Selectchar1: TMenuItem\r\n Action = EditorFrame.aiEditSelectChar\r\n end\r\n object Apply1: TMenuItem\r\n Action = EditorFrame.aiEditApply\r\n end\r\n object Revert1: TMenuItem\r\n Action = EditorFrame.aiEditRevert\r\n end\r\n object N4: TMenuItem\r\n Caption = '-'\r\n end\r\n object Setallsegments1: TMenuItem\r\n Action = EditorFrame.aiEditSetAll\r\n end\r\n object Emptysegments1: TMenuItem\r\n Action = EditorFrame.aiEditClear\r\n end\r\n object Invertsegments1: TMenuItem\r\n Action = EditorFrame.aiEditInvert\r\n end\r\n end\r\n end\r\n object alCharMapEditor: TActionList\r\n Left = 5\r\n Top = 100\r\n object aiFileOpen: TAction\r\n Caption = '&Open...'\r\n ShortCut = 16463\r\n end\r\n object aiFileSave: TAction\r\n Caption = '&Save...'\r\n ShortCut = 16467\r\n end\r\n object aiFileLoadDefault: TAction\r\n Caption = '&Default'\r\n end\r\n object aiFileClose: TAction\r\n Caption = '&Close'\r\n ShortCut = 32883\r\n end\r\n object aiEditCopy: TAction\r\n Caption = '&Copy'\r\n ShortCut = 16451\r\n end\r\n object aiEditPaste: TAction\r\n Caption = '&Paste'\r\n ShortCut = 16470\r\n end\r\n object aiEditClear: TAction\r\n Caption = '&Empty segments'\r\n end\r\n object aiEditSetAll: TAction\r\n Caption = '&Set all segments'\r\n end\r\n object aiEditInvert: TAction\r\n Caption = '&Invert segments'\r\n end\r\n object aiEditSelectChar: TAction\r\n Caption = 'Select c&har...'\r\n end\r\n object aiEditRevert: TAction\r\n Caption = '&Revert'\r\n end\r\n object aiEditApply: TAction\r\n Caption = '&Apply'\r\n end\r\n end\r\nend\r\n" }, { "path": "External/Jedi/Jvcl/run/JvSLDMappingEditorDialog.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvSLDMappingEditorDialog.pas, released on 2003-07-18.\r\n\r\nThe Initial Developer of the Original Code is Marcel Bestebroer\r\nPortions created by Marcel Bestebroer are Copyright (C) 2002 - 2003 Marcel\r\nBestebroer\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\n\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvSLDMappingEditorDialog.pas 13138 2011-10-26 23:17:50Z jfudickar $\r\n\r\nunit JvSLDMappingEditorDialog;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, Messages, SysUtils, Classes, Graphics, Controls,\r\n Forms, Dialogs, StdCtrls,\r\n JvSegmentedLEDDisplay, JvSegmentedLEDDisplayMapperFrame,\r\n JvComponent;\r\n\r\ntype\r\n TfrmSLDMappingEditorDialog = class(TJvForm)\r\n EditorFrame: TfmeJvSegmentedLEDDisplayMapper;\r\n lblDigitClassCaption: TLabel;\r\n lblSegmentCountCaption: TLabel;\r\n lblCharCaption: TLabel;\r\n lblMapperValueCaption: TLabel;\r\n lblSegmentsCaption: TLabel;\r\n lblDigitClass: TLabel;\r\n lblSegmentCount: TLabel;\r\n lblChar: TLabel;\r\n lblMapperValue: TLabel;\r\n lblSegments: TLabel;\r\n btnOK: TButton;\r\n procedure FormCloseQuery(Sender: TObject; var CanClose: Boolean);\r\n protected\r\n procedure Loaded; override;\r\n procedure UpdateDigitClass(Sender: TObject);\r\n procedure UpdateInfo(Sender: TObject);\r\n end;\r\n\r\nprocedure SegmentedLEDDisplayMappingEditor(ADisplay: TJvCustomSegmentedLEDDisplay;\r\n var OpenFolder, SaveFolder: string);\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvSLDMappingEditorDialog.pas $';\r\n Revision: '$Revision: 13138 $';\r\n Date: '$Date: 2011-10-27 01:17:50 +0200 (jeu. 27 oct. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\n{$IFNDEF COMPILER12_UP}\r\nuses\r\n JvJCLUtils;\r\n{$ENDIF ~COMPILER12_UP}\r\n\r\n{$R *.dfm}\r\n\r\nprocedure SegmentedLEDDisplayMappingEditor(ADisplay: TJvCustomSegmentedLEDDisplay;\r\n var OpenFolder, SaveFolder: string);\r\nbegin\r\n with TfrmSLDMappingEditorDialog.Create(Application) do\r\n try\r\n EditorFrame.Display := ADisplay;\r\n EditorFrame.LastOpenFolder := OpenFolder;\r\n EditorFrame.LastSaveFolder := SaveFolder;\r\n ShowModal;\r\n OpenFolder := EditorFrame.LastOpenFolder;\r\n SaveFolder := EditorFrame.LastSaveFolder;\r\n finally\r\n Free;\r\n end;\r\nend;\r\n\r\n//=== { TfrmSLDMappingEditorDialog } =========================================\r\n\r\nprocedure TfrmSLDMappingEditorDialog.Loaded;\r\nbegin\r\n inherited Loaded;\r\n EditorFrame.OnDisplayChanged := UpdateDigitClass;\r\n EditorFrame.OnInfoUpdate := UpdateInfo;\r\nend;\r\n\r\nprocedure TfrmSLDMappingEditorDialog.UpdateDigitClass(Sender: TObject);\r\nbegin\r\n if EditorFrame.Display <> nil then\r\n begin\r\n lblDigitClass.Caption := EditorFrame.DigitClass.ClassName;\r\n lblSegmentCount.Caption := IntToStr(EditorFrame.DigitClass.SegmentCount);\r\n end\r\n else\r\n begin\r\n lblDigitClass.Caption := '';\r\n lblSegmentCount.Caption := '';\r\n end;\r\nend;\r\n\r\nprocedure TfrmSLDMappingEditorDialog.UpdateInfo(Sender: TObject);\r\nbegin\r\n with EditorFrame do\r\n begin\r\n if CharSelected then\r\n begin\r\n if CharInSet(CurChar, ['!' .. 'z']) then\r\n lblChar.Caption := CurChar + ' (#' + IntToStr(Ord(CurChar)) + ')'\r\n else\r\n lblChar.Caption := '#' + IntToStr(Ord(CurChar));\r\n end\r\n else\r\n lblChar.Caption := '';\r\n if Display <> nil then\r\n begin\r\n lblMapperValue.Caption := IntToStr(sldEdit.Digits[0].GetSegmentStates);\r\n lblSegments.Caption := sldEdit.Digits[0].GetSegmentString;\r\n end\r\n else\r\n begin\r\n lblMapperValue.Caption := '';\r\n lblSegments.Caption := '';\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TfrmSLDMappingEditorDialog.FormCloseQuery(Sender: TObject;\r\n var CanClose: Boolean);\r\nbegin\r\n CanClose := EditorFrame.CanClose;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend." }, { "path": "External/Jedi/Jvcl/run/JvSchedEvtStore.pas", "content": "{-----------------------------------------------------------------------------\r\n\r\n Project JEDI Visible Component Library (J-VCL)\r\n\r\n The contents of this file are subject to the Mozilla Public License Version\r\n 1.1 (the \"License\"); you may not use this file except in compliance with the\r\n License. You may obtain a copy of the License at http://www.mozilla.org/MPL/\r\n\r\n Software distributed under the License is distributed on an \"AS IS\" basis,\r\n WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for\r\n the specific language governing rights and limitations under the License.\r\n\r\n The Initial Developer of the Original Code is Marcel Bestebroer\r\n .\r\n Portions created by Marcel Bestebroer are Copyright (C) 2000 - 2002 mbeSoft.\r\n All Rights Reserved.\r\n\r\n ******************************************************************************\r\n\r\n Persistency layer for JvScheduledEvents\r\n\r\n You may retrieve the latest version of this file at the Project JEDI home\r\n page, located at http://www.delphi-jedi.org\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvSchedEvtStore.pas 12252 2009-03-21 22:18:25Z ahuser $\r\n\r\nunit JvSchedEvtStore;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Classes,\r\n JvScheduledEvents;\r\n\r\ntype\r\n TSchedEvtStoreAttribute = (sesaStructured, sesaIdentifiers);\r\n TSchedEvtStoreAttributes = set of TSchedEvtStoreAttribute;\r\n\r\n TSchedEvtStructKind =\r\n (seskState, seskEvent, seskSchedule, seskScheduleRecurInfo,\r\n seskScheduleEndInfo, seskScheduleDayFreq, seskScheduleDaily,\r\n seskScheduleWeekly, seskScheduleMonthly, seskScheduleMonthlyIndex,\r\n seskScheduleYearly, seskScheduleYearlyIndex);\r\n\r\n TSchedEvtItemKind =\r\n (seikUnknown, seikScheduleStart, seikScheduleRecurType,\r\n seikScheduleEndType, seikScheduleEndCount, seikScheduleEndDate,\r\n seikFreqStart, seikFreqEnd, seikFreqInterval, seikScheduleDailyWeekdays,\r\n seikScheduleDailyInterval, seikScheduleWeeklyDays,\r\n seikScheduleWeeklyInterval, seikScheduleMonthlyDay,\r\n seikScheduleMonthlyIndexType, seikScheduleMonthlyIndex,\r\n seikScheduleMonthlyInterval, seikScheduleYearlyDay,\r\n seikScheduleYearlyMonth, seikScheduleYearlyIndexType,\r\n seikScheduleYearlyIndex, seikScheduleYearlyInterval);\r\n\r\n IJvScheduledEventsStore = interface\r\n ['{FD6437D8-B951-4C72-AA5F-B96911D51B65}']\r\n procedure LoadState(const Event: TJvEventCollectionItem);\r\n procedure SaveState(const Event: TJvEventCollectionItem);\r\n\r\n procedure LoadSchedule(const Event: TJvEventCollectionItem);\r\n procedure SaveSchedule(const Event: TJvEventCollectionItem);\r\n\r\n procedure LoadEventSettings(const Event: TJvEventCollectionItem);\r\n procedure SaveEventSettings(const Event: TJvEventCollectionItem);\r\n end;\r\n\r\n TJvSchedEvtStore = class(TInterfacedObject, IJvScheduledEventsStore)\r\n private\r\n FEvent: TJvEventCollectionItem;\r\n FStructStack: array of TSchedEvtStructKind;\r\n protected\r\n // Structure stack managment: low level\r\n procedure PushStruct(const StructType: TSchedEvtStructKind);\r\n function PeekStruct: TSchedEvtStructKind;\r\n function PopStruct: TSchedEvtStructKind;\r\n // property access methods\r\n function GetEvent: TJvEventCollectionItem;\r\n // Retrieving items: Schedule\r\n procedure CheckSignature; virtual; abstract;\r\n procedure CheckVersion; virtual; abstract;\r\n function NextItemKind: TSchedEvtItemKind; virtual;\r\n procedure RestoreScheduleStart; virtual; abstract;\r\n procedure RestoreScheduleRecurType; virtual; abstract;\r\n procedure RestoreScheduleEndType; virtual; abstract;\r\n procedure RestoreScheduleEndCount; virtual; abstract;\r\n procedure RestoreScheduleEndDate; virtual; abstract;\r\n procedure RestoreFreqStart; virtual; abstract;\r\n procedure RestoreFreqEnd; virtual; abstract;\r\n procedure RestoreFreqInterval; virtual; abstract;\r\n procedure RestoreScheduleDailyWeekdays; virtual; abstract;\r\n procedure RestoreScheduleDailyInterval; virtual; abstract;\r\n procedure RestoreScheduleWeeklyDays; virtual; abstract;\r\n procedure RestoreScheduleWeeklyInterval; virtual; abstract;\r\n procedure RestoreScheduleMonthlyDay; virtual; abstract;\r\n procedure RestoreScheduleMonthlyIndexType; virtual; abstract;\r\n procedure RestoreScheduleMonthlyIndex; virtual; abstract;\r\n procedure RestoreScheduleMonthlyInterval; virtual; abstract;\r\n procedure RestoreScheduleYearlyDay; virtual; abstract;\r\n procedure RestoreScheduleYearlyMonth; virtual; abstract;\r\n procedure RestoreScheduleYearlyIndexType; virtual; abstract;\r\n procedure RestoreScheduleYearlyIndex; virtual; abstract;\r\n procedure RestoreScheduleYearlyInterval; virtual; abstract;\r\n // Storing items: signature (only for unstructured storages) and versioning\r\n procedure StoreSignature; virtual;\r\n procedure StoreVersion; virtual; abstract;\r\n // Storing items: Schedule\r\n procedure StoreScheduleStart; virtual; abstract;\r\n procedure StoreScheduleRecurType; virtual; abstract;\r\n procedure StoreScheduleEndType; virtual; abstract;\r\n procedure StoreScheduleEndCount; virtual; abstract;\r\n procedure StoreScheduleEndDate; virtual; abstract;\r\n procedure StoreFreqStart; virtual; abstract;\r\n procedure StoreFreqEnd; virtual; abstract;\r\n procedure StoreFreqInterval; virtual; abstract;\r\n procedure StoreScheduleDailyWeekdays; virtual; abstract;\r\n procedure StoreScheduleDailyInterval; virtual; abstract;\r\n procedure StoreScheduleWeeklyDays; virtual; abstract;\r\n procedure StoreScheduleWeeklyInterval; virtual; abstract;\r\n procedure StoreScheduleMonthlyDay; virtual; abstract;\r\n procedure StoreScheduleMonthlyIndexType; virtual; abstract;\r\n procedure StoreScheduleMonthlyIndex; virtual; abstract;\r\n procedure StoreScheduleMonthlyInterval; virtual; abstract;\r\n procedure StoreScheduleYearlyDay; virtual; abstract;\r\n procedure StoreScheduleYearlyMonth; virtual; abstract;\r\n procedure StoreScheduleYearlyIndexType; virtual; abstract;\r\n procedure StoreScheduleYearlyIndex; virtual; abstract;\r\n procedure StoreScheduleYearlyInterval; virtual; abstract;\r\n // Structure stack managment: high level\r\n procedure BeginStruct(const StructType: TSchedEvtStructKind); virtual;\r\n procedure EndStruct; virtual;\r\n procedure CheckBeginStruct(const StructType: TSchedEvtStructKind); virtual;\r\n procedure CheckEndStruct; virtual;\r\n property Event: TJvEventCollectionItem read GetEvent;\r\n public\r\n function IsStructured: Boolean;\r\n function UsesIdentifiers: Boolean;\r\n function GetAttributes: TSchedEvtStoreAttributes; virtual;\r\n procedure LoadState(const Event: TJvEventCollectionItem);\r\n procedure SaveState(const Event: TJvEventCollectionItem);\r\n procedure LoadSchedule(const Event: TJvEventCollectionItem);\r\n procedure SaveSchedule(const Event: TJvEventCollectionItem);\r\n procedure LoadEventSettings(const Event: TJvEventCollectionItem);\r\n procedure SaveEventSettings(const Event: TJvEventCollectionItem);\r\n end;\r\n\r\nfunction ScheduledEventStore_Stream(const Stream: TStream; const Binary: Boolean = False;\r\n const OwnsStream: Boolean = True): IJvScheduledEventsStore;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvSchedEvtStore.pas $';\r\n Revision: '$Revision: 12252 $';\r\n Date: '$Date: 2009-03-21 23:18:25 +0100 (sam. 21 mars 2009) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n SysUtils, TypInfo,\r\n {$IFDEF SUPPORTS_INLINE}\r\n Windows,\r\n {$ENDIF SUPPORTS_INLINE}\r\n JclRTTI, JclSchedule,\r\n {$IFNDEF COMPILER12_UP}\r\n JvJCLUtils,\r\n {$ENDIF ~COMPILER12_UP}\r\n JvConsts, JvTypes, JvResources;\r\n\r\n//=== { TJvSchedEvtStore } ===================================================\r\n\r\nprocedure TJvSchedEvtStore.PushStruct(const StructType: TSchedEvtStructKind);\r\nbegin\r\n SetLength(FStructStack, Length(FStructStack) + 1);\r\n FStructStack[High(FStructStack)] := StructType;\r\nend;\r\n\r\nfunction TJvSchedEvtStore.PeekStruct: TSchedEvtStructKind;\r\nbegin\r\n if Length(FStructStack) = 0 then\r\n raise EJVCLException.CreateRes(@RsEStructureStackIsEmpty);\r\n Result := FStructStack[High(FStructStack)];\r\nend;\r\n\r\nfunction TJvSchedEvtStore.PopStruct: TSchedEvtStructKind;\r\nbegin\r\n Result := PeekStruct;\r\n SetLength(FStructStack, High(FStructStack));\r\nend;\r\n\r\nfunction TJvSchedEvtStore.GetEvent: TJvEventCollectionItem;\r\nbegin\r\n Result := FEvent;\r\nend;\r\n\r\nfunction TJvSchedEvtStore.NextItemKind: TSchedEvtItemKind;\r\nbegin\r\n Result := seikUnknown;\r\nend;\r\n\r\nprocedure TJvSchedEvtStore.StoreSignature;\r\nbegin\r\n // override for non-structured storages to store an identification of the stream if needed.\r\n TProcedure(AbstractErrorProc);\r\nend;\r\n\r\nprocedure TJvSchedEvtStore.BeginStruct(const StructType: TSchedEvtStructKind);\r\nbegin\r\n { override to take additional steps when a new structure is to be written. Either call inherited\r\n or use PushStruct to store the current structure information on the stack. }\r\n PushStruct(StructType);\r\nend;\r\n\r\nprocedure TJvSchedEvtStore.EndStruct;\r\nbegin\r\n { override to take additional steps when a structure is to be terminated. Either call inherited\r\n or use PopStruct to retrieve the structure information from the stack. }\r\n PopStruct;\r\nend;\r\n\r\nprocedure TJvSchedEvtStore.CheckBeginStruct(const StructType: TSchedEvtStructKind);\r\nbegin\r\n { override to check if the next structure is the one specified and raise an exception if it isn't.\r\n Either call inherited or use PushStruct to store the current structure information on the\r\n stack. }\r\n PushStruct(StructType);\r\nend;\r\n\r\nprocedure TJvSchedEvtStore.CheckEndStruct;\r\nbegin\r\n { override to check if the next item marks the end of the structure as specified on the current\r\n stack (use PopStruct to retrieve the structure information from the stack). Raise an exception\r\n if the next item does not mark the end of the currently active structure. }\r\n PopStruct;\r\nend;\r\n\r\nfunction TJvSchedEvtStore.IsStructured: Boolean;\r\nbegin\r\n Result := sesaStructured in GetAttributes;\r\nend;\r\n\r\nfunction TJvSchedEvtStore.UsesIdentifiers: Boolean;\r\nbegin\r\n Result := sesaIdentifiers in GetAttributes;\r\nend;\r\n\r\nfunction TJvSchedEvtStore.GetAttributes: TSchedEvtStoreAttributes;\r\nbegin\r\n Result := [];\r\nend;\r\n\r\nprocedure TJvSchedEvtStore.LoadState(const Event: TJvEventCollectionItem);\r\nbegin\r\n raise EJVCLException.CreateRes(@RsENotImplemented);\r\nend;\r\n\r\nprocedure TJvSchedEvtStore.SaveState(const Event: TJvEventCollectionItem);\r\nbegin\r\n raise EJVCLException.CreateRes(@RsENotImplemented);\r\nend;\r\n\r\nprocedure TJvSchedEvtStore.LoadSchedule(const Event: TJvEventCollectionItem);\r\nvar\r\n OrgSchedule: IJclSchedule;\r\nbegin\r\n // Clear the structure stack\r\n SetLength(FStructStack, 0);\r\n FEvent := Event;\r\n with Event do\r\n begin\r\n if not (State in [sesNotInitialized, sesEnded]) then\r\n raise EJVCLException.CreateRes(@RsEScheduleIsActiveReadingANewSchedule);\r\n OrgSchedule := Schedule;\r\n try\r\n Schedule := CreateSchedule;\r\n // Begin of actual reading\r\n if not IsStructured then\r\n CheckSignature;\r\n CheckBeginStruct(seskSchedule);\r\n CheckVersion;\r\n // Generic schedule info\r\n RestoreScheduleStart;\r\n CheckBeginStruct(seskScheduleRecurInfo);\r\n RestoreScheduleRecurType;\r\n if Schedule.RecurringType <> srkOneShot then\r\n begin\r\n CheckBeginStruct(seskScheduleEndInfo);\r\n RestoreScheduleEndType;\r\n if Schedule.EndType = sekDate then\r\n RestoreScheduleEndDate\r\n else\r\n if Schedule.EndType in [sekTriggerCount, sekDayCount] then\r\n RestoreScheduleEndCount;\r\n CheckEndStruct; {seskScheduleEndInfo}\r\n\r\n CheckBeginStruct(seskScheduleDayFreq);\r\n RestoreFreqStart;\r\n if not UsesIdentifiers or (NextItemKind = seikFreqEnd) then\r\n begin\r\n RestoreFreqEnd;\r\n RestoreFreqInterval;\r\n end;\r\n CheckEndStruct; {seskScheduleDayFreq}\r\n\r\n case Schedule.RecurringType of\r\n srkDaily:\r\n begin\r\n CheckBeginStruct(seskScheduleDaily);\r\n if not UsesIdentifiers or (NextItemKind = seikScheduleDailyWeekdays) then\r\n RestoreScheduleDailyWeekdays;\r\n if not UsesIdentifiers or (NextItemKind = seikScheduleDailyInterval) then\r\n RestoreScheduleDailyInterval;\r\n CheckEndStruct; {seskScheduleDaily}\r\n end;\r\n srkWeekly:\r\n begin\r\n CheckBeginStruct(seskScheduleWeekly);\r\n RestoreScheduleWeeklyDays;\r\n RestoreScheduleWeeklyInterval;\r\n CheckEndStruct; {seskScheduleWeekly}\r\n end;\r\n srkMonthly:\r\n begin\r\n CheckBeginStruct(seskScheduleMonthly);\r\n CheckBeginStruct(seskScheduleMonthlyIndex);\r\n RestoreScheduleMonthlyIndexType;\r\n if (Schedule as IJclMonthlySchedule).IndexKind <> sikNone then\r\n RestoreScheduleMonthlyIndex;\r\n CheckEndStruct; {seskScheduleMonthlyIndex}\r\n if (Schedule as IJclMonthlySchedule).IndexKind = sikNone then\r\n RestoreScheduleMonthlyDay;\r\n RestoreScheduleMonthlyInterval;\r\n CheckEndStruct; {seskScheduleMonthly}\r\n end;\r\n srkYearly:\r\n begin\r\n CheckBeginStruct(seskScheduleYearly);\r\n CheckBeginStruct(seskScheduleYearlyIndex);\r\n RestoreScheduleYearlyIndexType;\r\n if (Schedule as IJclYearlySchedule).IndexKind <> sikNone then\r\n RestoreScheduleYearlyIndex;\r\n CheckEndStruct; {seskScheduleYearlyIndex}\r\n if (Schedule as IJclYearlySchedule).IndexKind = sikNone then\r\n RestoreScheduleYearlyDay;\r\n RestoreScheduleYearlyMonth;\r\n RestoreScheduleYearlyInterval;\r\n CheckEndStruct; {seskScheduleYearly}\r\n end;\r\n end;\r\n end;\r\n CheckEndStruct; {seskScheduleRecurInfo}\r\n CheckEndStruct; {seskSchedule}\r\n // we succeeded in reading in the schedule.\r\n except\r\n { uh-oh! reading of the schedule failed. Better restore the original\r\n schedule so the end user won't miss it ;) }\r\n Schedule := OrgSchedule;\r\n raise;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvSchedEvtStore.SaveSchedule(const Event: TJvEventCollectionItem);\r\nbegin\r\n // Clear the structure stack\r\n SetLength(FStructStack, 0);\r\n FEvent := Event;\r\n with Event do\r\n begin\r\n if not (State in [sesNotInitialized, sesEnded, sesPaused]) then\r\n raise EJVCLException.CreateRes(@RsEScheduleIsActiveStoringOfAScheduleC);\r\n if not IsStructured then\r\n StoreSignature;\r\n BeginStruct(seskSchedule);\r\n StoreVersion;\r\n // Generic schedule info\r\n StoreScheduleStart;\r\n BeginStruct(seskScheduleRecurInfo);\r\n StoreScheduleRecurType;\r\n if Schedule.RecurringType <> srkOneShot then\r\n begin\r\n BeginStruct(seskScheduleEndInfo);\r\n StoreScheduleEndType;\r\n if Schedule.EndType = sekDate then\r\n StoreScheduleEndDate\r\n else\r\n if Schedule.EndType in [sekTriggerCount, sekDayCount] then\r\n StoreScheduleEndCount;\r\n EndStruct; {seskScheduleEndInfo}\r\n\r\n BeginStruct(seskScheduleDayFreq);\r\n StoreFreqStart;\r\n if not UsesIdentifiers or ((Schedule as IJclScheduleDayFrequency).Interval <> 0) then\r\n begin\r\n StoreFreqEnd;\r\n StoreFreqInterval;\r\n end;\r\n EndStruct; {seskScheduleDayFreq}\r\n\r\n case Schedule.RecurringType of\r\n srkDaily:\r\n begin\r\n BeginStruct(seskScheduleDaily);\r\n if not UsesIdentifiers or (Schedule as IJclDailySchedule).EveryWeekDay then\r\n StoreScheduleDailyWeekdays;\r\n if not UsesIdentifiers or not (Schedule as IJclDailySchedule).EveryWeekDay then\r\n StoreScheduleDailyInterval;\r\n EndStruct; {seskScheduleDaily}\r\n end;\r\n srkWeekly:\r\n begin\r\n BeginStruct(seskScheduleWeekly);\r\n StoreScheduleWeeklyDays;\r\n StoreScheduleWeeklyInterval;\r\n EndStruct; {seskScheduleWeekly}\r\n end;\r\n srkMonthly:\r\n begin\r\n BeginStruct(seskScheduleMonthly);\r\n BeginStruct(seskScheduleMonthlyIndex);\r\n StoreScheduleMonthlyIndexType;\r\n if (Schedule as IJclMonthlySchedule).IndexKind <> sikNone then\r\n StoreScheduleMonthlyIndex;\r\n EndStruct; {seskScheduleMonthlyIndex}\r\n if (Schedule as IJclMonthlySchedule).IndexKind = sikNone then\r\n StoreScheduleMonthlyDay;\r\n StoreScheduleMonthlyInterval;\r\n EndStruct; {seskScheduleMonthly}\r\n end;\r\n srkYearly:\r\n begin\r\n BeginStruct(seskScheduleYearly);\r\n BeginStruct(seskScheduleYearlyIndex);\r\n StoreScheduleYearlyIndexType;\r\n if (Schedule as IJclYearlySchedule).IndexKind <> sikNone then\r\n StoreScheduleYearlyIndex;\r\n EndStruct; {seskScheduleYearlyIndex}\r\n if (Schedule as IJclYearlySchedule).IndexKind = sikNone then\r\n StoreScheduleYearlyDay;\r\n StoreScheduleYearlyMonth;\r\n StoreScheduleYearlyInterval;\r\n EndStruct; {seskScheduleYearly}\r\n end;\r\n end;\r\n end;\r\n EndStruct; {seskScheduleRecurInfo}\r\n EndStruct; {seskSchedule}\r\n end;\r\nend;\r\n\r\nprocedure TJvSchedEvtStore.LoadEventSettings(const Event: TJvEventCollectionItem);\r\nbegin\r\n raise EJVCLException.CreateRes(@RsENotImplemented_);\r\nend;\r\n\r\nprocedure TJvSchedEvtStore.SaveEventSettings(const Event: TJvEventCollectionItem);\r\nbegin\r\n raise EJVCLException.CreateRes(@RsENotImplemented_);\r\nend;\r\n\r\n//=== { TBinStore } ==========================================================\r\n\r\nconst\r\n BinStreamID = 'JVSE';\r\n BinStreamVer = Word($0001);\r\n\r\ntype\r\n TBinStore = class(TJvSchedEvtStore)\r\n private\r\n FStream: TStream;\r\n FOwnsStream: Boolean;\r\n FStreamVersion: Word; // Only used for reading\r\n protected\r\n // Retrieving items: Schedule\r\n procedure CheckSignature; override;\r\n procedure CheckVersion; override;\r\n procedure RestoreScheduleStart; override;\r\n procedure RestoreScheduleRecurType; override;\r\n procedure RestoreScheduleEndType; override;\r\n procedure RestoreScheduleEndCount; override;\r\n procedure RestoreScheduleEndDate; override;\r\n procedure RestoreFreqStart; override;\r\n procedure RestoreFreqEnd; override;\r\n procedure RestoreFreqInterval; override;\r\n procedure RestoreScheduleDailyWeekdays; override;\r\n procedure RestoreScheduleDailyInterval; override;\r\n procedure RestoreScheduleWeeklyDays; override;\r\n procedure RestoreScheduleWeeklyInterval; override;\r\n procedure RestoreScheduleMonthlyDay; override;\r\n procedure RestoreScheduleMonthlyIndexType; override;\r\n procedure RestoreScheduleMonthlyIndex; override;\r\n procedure RestoreScheduleMonthlyInterval; override;\r\n procedure RestoreScheduleYearlyDay; override;\r\n procedure RestoreScheduleYearlyMonth; override;\r\n procedure RestoreScheduleYearlyIndexType; override;\r\n procedure RestoreScheduleYearlyIndex; override;\r\n procedure RestoreScheduleYearlyInterval; override;\r\n // Storing items: signature (only for unstructured storages) and versioning\r\n procedure StoreSignature; override;\r\n procedure StoreVersion; override;\r\n // Storing items: Schedule\r\n procedure StoreScheduleStart; override;\r\n procedure StoreScheduleRecurType; override;\r\n procedure StoreScheduleEndType; override;\r\n procedure StoreScheduleEndCount; override;\r\n procedure StoreScheduleEndDate; override;\r\n procedure StoreFreqStart; override;\r\n procedure StoreFreqEnd; override;\r\n procedure StoreFreqInterval; override;\r\n procedure StoreScheduleDailyWeekdays; override;\r\n procedure StoreScheduleDailyInterval; override;\r\n procedure StoreScheduleWeeklyDays; override;\r\n procedure StoreScheduleWeeklyInterval; override;\r\n procedure StoreScheduleMonthlyDay; override;\r\n procedure StoreScheduleMonthlyIndexType; override;\r\n procedure StoreScheduleMonthlyIndex; override;\r\n procedure StoreScheduleMonthlyInterval; override;\r\n procedure StoreScheduleYearlyDay; override;\r\n procedure StoreScheduleYearlyMonth; override;\r\n procedure StoreScheduleYearlyIndexType; override;\r\n procedure StoreScheduleYearlyIndex; override;\r\n procedure StoreScheduleYearlyInterval; override;\r\n public\r\n constructor Create(const AStream: TStream; const AOwnsStream: Boolean = True);\r\n destructor Destroy; override;\r\n end;\r\n\r\nconstructor TBinStore.Create(const AStream: TStream; const AOwnsStream: Boolean);\r\nbegin\r\n inherited Create;\r\n FStream := AStream;\r\n FOwnsStream := AOwnsStream;\r\nend;\r\n\r\ndestructor TBinStore.Destroy;\r\nbegin\r\n if FOwnsStream then\r\n FreeAndNil(FStream);\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TBinStore.CheckSignature;\r\nvar\r\n S: AnsiString;\r\nbegin\r\n SetLength(S, Length(BinStreamID));\r\n FStream.ReadBuffer(S[1], Length(BinStreamID));\r\n if S <> BinStreamID then\r\n raise EJVCLException.CreateRes(@RsENotASchedule);\r\nend;\r\n\r\nprocedure TBinStore.CheckVersion;\r\nbegin\r\n FStream.ReadBuffer(FStreamVersion, SizeOf(FStreamVersion));\r\n if FStreamVersion > BinStreamVer then\r\n raise EJVCLException.CreateResFmt(@RsEUnknownScheduleVersions, [IntToHex(FStreamVersion, 4)]);\r\nend;\r\n\r\nprocedure TBinStore.RestoreScheduleStart;\r\nvar\r\n I: TTimeStamp;\r\nbegin\r\n FStream.ReadBuffer(I, SizeOf(I));\r\n Event.Schedule.StartDate := I;\r\nend;\r\n\r\nprocedure TBinStore.RestoreScheduleRecurType;\r\nvar\r\n I: TScheduleRecurringKind;\r\nbegin\r\n FStream.ReadBuffer(I, SizeOf(I));\r\n Event.Schedule.RecurringType := I;\r\nend;\r\n\r\nprocedure TBinStore.RestoreScheduleEndType;\r\nvar\r\n I: TScheduleEndKind;\r\nbegin\r\n FStream.ReadBuffer(I, SizeOf(I));\r\n Event.Schedule.EndType := I;\r\nend;\r\n\r\nprocedure TBinStore.RestoreScheduleEndCount;\r\nvar\r\n I: Cardinal;\r\nbegin\r\n FStream.ReadBuffer(I, SizeOf(I));\r\n Event.Schedule.EndCount := I;\r\nend;\r\n\r\nprocedure TBinStore.RestoreScheduleEndDate;\r\nvar\r\n I: TTimeStamp;\r\nbegin\r\n FStream.ReadBuffer(I, SizeOf(I));\r\n Event.Schedule.EndDate := I;\r\nend;\r\n\r\nprocedure TBinStore.RestoreFreqStart;\r\nvar\r\n I: Cardinal;\r\nbegin\r\n FStream.ReadBuffer(I, SizeOf(I));\r\n (Event.Schedule as IJclScheduleDayFrequency).StartTime := I;\r\nend;\r\n\r\nprocedure TBinStore.RestoreFreqEnd;\r\nvar\r\n I: Cardinal;\r\nbegin\r\n FStream.ReadBuffer(I, SizeOf(I));\r\n (Event.Schedule as IJclScheduleDayFrequency).EndTime := I;\r\nend;\r\n\r\nprocedure TBinStore.RestoreFreqInterval;\r\nvar\r\n I: Cardinal;\r\nbegin\r\n FStream.ReadBuffer(I, SizeOf(I));\r\n (Event.Schedule as IJclScheduleDayFrequency).Interval := I;\r\nend;\r\n\r\nprocedure TBinStore.RestoreScheduleDailyWeekdays;\r\nvar\r\n I: Boolean;\r\nbegin\r\n FStream.ReadBuffer(I, SizeOf(I));\r\n (Event.Schedule as IJclDailySchedule).EveryWeekDay := I;\r\nend;\r\n\r\nprocedure TBinStore.RestoreScheduleDailyInterval;\r\nvar\r\n I: Cardinal;\r\nbegin\r\n FStream.ReadBuffer(I, SizeOf(I));\r\n (Event.Schedule as IJclDailySchedule).Interval := I;\r\nend;\r\n\r\nprocedure TBinStore.RestoreScheduleWeeklyDays;\r\nvar\r\n I: TScheduleWeekDays;\r\nbegin\r\n FStream.ReadBuffer(I, SizeOf(I));\r\n (Event.Schedule as IJclWeeklySchedule).DaysOfWeek := I;\r\nend;\r\n\r\nprocedure TBinStore.RestoreScheduleWeeklyInterval;\r\nvar\r\n I: Cardinal;\r\nbegin\r\n FStream.ReadBuffer(I, SizeOf(I));\r\n (Event.Schedule as IJclWeeklySchedule).Interval := I;\r\nend;\r\n\r\nprocedure TBinStore.RestoreScheduleMonthlyDay;\r\nvar\r\n I: Cardinal;\r\nbegin\r\n FStream.ReadBuffer(I, SizeOf(I));\r\n (Event.Schedule as IJclMonthlySchedule).Day := I;\r\nend;\r\n\r\nprocedure TBinStore.RestoreScheduleMonthlyIndexType;\r\nvar\r\n I: TScheduleIndexKind;\r\nbegin\r\n FStream.ReadBuffer(I, SizeOf(I));\r\n (Event.Schedule as IJclMonthlySchedule).IndexKind := I;\r\nend;\r\n\r\nprocedure TBinStore.RestoreScheduleMonthlyIndex;\r\nvar\r\n I: Integer;\r\nbegin\r\n FStream.ReadBuffer(I, SizeOf(I));\r\n (Event.Schedule as IJclMonthlySchedule).IndexValue := I;\r\nend;\r\n\r\nprocedure TBinStore.RestoreScheduleMonthlyInterval;\r\nvar\r\n I: Cardinal;\r\nbegin\r\n FStream.ReadBuffer(I, SizeOf(I));\r\n (Event.Schedule as IJclMonthlySchedule).Interval := I;\r\nend;\r\n\r\nprocedure TBinStore.RestoreScheduleYearlyDay;\r\nvar\r\n I: Cardinal;\r\nbegin\r\n FStream.ReadBuffer(I, SizeOf(I));\r\n (Event.Schedule as IJclYearlySchedule).Day := I;\r\nend;\r\n\r\nprocedure TBinStore.RestoreScheduleYearlyMonth;\r\nvar\r\n I: Cardinal;\r\nbegin\r\n FStream.ReadBuffer(I, SizeOf(I));\r\n (Event.Schedule as IJclYearlySchedule).Month := I;\r\nend;\r\n\r\nprocedure TBinStore.RestoreScheduleYearlyIndexType;\r\nvar\r\n I: TScheduleIndexKind;\r\nbegin\r\n FStream.ReadBuffer(I, SizeOf(I));\r\n (Event.Schedule as IJclYearlySchedule).IndexKind := I;\r\nend;\r\n\r\nprocedure TBinStore.RestoreScheduleYearlyIndex;\r\nvar\r\n I: Integer;\r\nbegin\r\n FStream.ReadBuffer(I, SizeOf(I));\r\n (Event.Schedule as IJclYearlySchedule).IndexValue := I;\r\nend;\r\n\r\nprocedure TBinStore.RestoreScheduleYearlyInterval;\r\nvar\r\n I: Cardinal;\r\nbegin\r\n FStream.ReadBuffer(I, SizeOf(I));\r\n (Event.Schedule as IJclYearlySchedule).Interval := I;\r\nend;\r\n\r\nprocedure TBinStore.StoreSignature;\r\nvar\r\n S: AnsiString;\r\nbegin\r\n S := BinStreamID;\r\n FStream.WriteBuffer(S[1], Length(S));\r\nend;\r\n\r\nprocedure TBinStore.StoreVersion;\r\nvar\r\n W: Word;\r\nbegin\r\n W := BinStreamVer;\r\n FStream.WriteBuffer(W, SizeOf(W));\r\nend;\r\n\r\nprocedure TBinStore.StoreScheduleStart;\r\nvar\r\n Stamp: TTimeStamp;\r\nbegin\r\n Stamp := Event.Schedule.StartDate;\r\n FStream.WriteBuffer(Stamp, SizeOf(Stamp));\r\nend;\r\n\r\nprocedure TBinStore.StoreScheduleRecurType;\r\nvar\r\n RT: TScheduleRecurringKind;\r\nbegin\r\n RT := Event.Schedule.RecurringType;\r\n FStream.WriteBuffer(RT, SizeOf(RT));\r\nend;\r\n\r\nprocedure TBinStore.StoreScheduleEndType;\r\nvar\r\n ET: TScheduleEndKind;\r\nbegin\r\n ET := Event.Schedule.EndType;\r\n FStream.WriteBuffer(ET, SizeOf(ET));\r\nend;\r\n\r\nprocedure TBinStore.StoreScheduleEndCount;\r\nvar\r\n I: Cardinal;\r\nbegin\r\n I := Event.Schedule.EndCount;\r\n FStream.WriteBuffer(I, SizeOf(I));\r\nend;\r\n\r\nprocedure TBinStore.StoreScheduleEndDate;\r\nvar\r\n Stamp: TTimeStamp;\r\nbegin\r\n Stamp := Event.Schedule.EndDate;\r\n FStream.WriteBuffer(Stamp, SizeOf(Stamp));\r\nend;\r\n\r\nprocedure TBinStore.StoreFreqStart;\r\nvar\r\n I: Cardinal;\r\nbegin\r\n I := (Event.Schedule as IJclScheduleDayFrequency).StartTime;\r\n FStream.WriteBuffer(I, SizeOf(I));\r\nend;\r\n\r\nprocedure TBinStore.StoreFreqEnd;\r\nvar\r\n I: Cardinal;\r\nbegin\r\n I := (Event.Schedule as IJclScheduleDayFrequency).EndTime;\r\n FStream.WriteBuffer(I, SizeOf(I));\r\nend;\r\n\r\nprocedure TBinStore.StoreFreqInterval;\r\nvar\r\n I: Cardinal;\r\nbegin\r\n I := (Event.Schedule as IJclScheduleDayFrequency).Interval;\r\n FStream.WriteBuffer(I, SizeOf(I));\r\nend;\r\n\r\nprocedure TBinStore.StoreScheduleDailyWeekdays;\r\nvar\r\n EWD: Boolean;\r\nbegin\r\n EWD := (Event.Schedule as IJclDailySchedule).EveryWeekDay;\r\n FStream.WriteBuffer(EWD, SizeOf(EWD));\r\nend;\r\n\r\nprocedure TBinStore.StoreScheduleDailyInterval;\r\nvar\r\n I: Cardinal;\r\nbegin\r\n I := (Event.Schedule as IJclDailySchedule).Interval;\r\n FStream.WriteBuffer(I, SizeOf(I));\r\nend;\r\n\r\nprocedure TBinStore.StoreScheduleWeeklyDays;\r\nvar\r\n WD: TScheduleWeekDays;\r\nbegin\r\n WD := (Event.Schedule as IJclWeeklySchedule).DaysOfWeek;\r\n FStream.WriteBuffer(WD, SizeOf(WD));\r\nend;\r\n\r\nprocedure TBinStore.StoreScheduleWeeklyInterval;\r\nvar\r\n I: Cardinal;\r\nbegin\r\n I := (Event.Schedule as IJclWeeklySchedule).Interval;\r\n FStream.WriteBuffer(I, SizeOf(I));\r\nend;\r\n\r\nprocedure TBinStore.StoreScheduleMonthlyDay;\r\nvar\r\n I: Cardinal;\r\nbegin\r\n I := (Event.Schedule as IJclMonthlySchedule).Day;\r\n FStream.WriteBuffer(I, SizeOf(I));\r\nend;\r\n\r\nprocedure TBinStore.StoreScheduleMonthlyIndexType;\r\nvar\r\n I: TScheduleIndexKind;\r\nbegin\r\n I := (Event.Schedule as IJclMonthlySchedule).IndexKind;\r\n FStream.WriteBuffer(I, SizeOf(I));\r\nend;\r\n\r\nprocedure TBinStore.StoreScheduleMonthlyIndex;\r\nvar\r\n I: Integer;\r\nbegin\r\n I := (Event.Schedule as IJclMonthlySchedule).IndexValue;\r\n FStream.WriteBuffer(I, SizeOf(I));\r\nend;\r\n\r\nprocedure TBinStore.StoreScheduleMonthlyInterval;\r\nvar\r\n I: Cardinal;\r\nbegin\r\n I := (Event.Schedule as IJclMonthlySchedule).Interval;\r\n FStream.WriteBuffer(I, SizeOf(I));\r\nend;\r\n\r\nprocedure TBinStore.StoreScheduleYearlyDay;\r\nvar\r\n I: Cardinal;\r\nbegin\r\n I := (Event.Schedule as IJclYearlySchedule).Day;\r\n FStream.WriteBuffer(I, SizeOf(I));\r\nend;\r\n\r\nprocedure TBinStore.StoreScheduleYearlyMonth;\r\nvar\r\n I: Cardinal;\r\nbegin\r\n I := (Event.Schedule as IJclYearlySchedule).Month;\r\n FStream.WriteBuffer(I, SizeOf(I));\r\nend;\r\n\r\nprocedure TBinStore.StoreScheduleYearlyIndexType;\r\nvar\r\n I: TScheduleIndexKind;\r\nbegin\r\n I := (Event.Schedule as IJclYearlySchedule).IndexKind;\r\n FStream.WriteBuffer(I, SizeOf(I));\r\nend;\r\n\r\nprocedure TBinStore.StoreScheduleYearlyIndex;\r\nvar\r\n I: Integer;\r\nbegin\r\n I := (Event.Schedule as IJclYearlySchedule).IndexValue;\r\n FStream.WriteBuffer(I, SizeOf(I));\r\nend;\r\n\r\nprocedure TBinStore.StoreScheduleYearlyInterval;\r\nvar\r\n I: Integer;\r\nbegin\r\n I := (Event.Schedule as IJclYearlySchedule).Interval;\r\n FStream.WriteBuffer(I, SizeOf(I));\r\nend;\r\n\r\n//=== { TTxtStore } ==========================================================\r\n\r\nconst\r\n TxtIdentifiers: array [TSchedEvtItemKind] of PChar =\r\n ('', {seikUnknown}\r\n 'Start', {seikScheduleStart}\r\n 'Recur type', {seikScheduleRecurType}\r\n 'End type', {seikScheduleEndType}\r\n 'End count', {seikScheduleEndCount}\r\n 'End', {seikScheduleEndDate}\r\n 'Frequency start', {seikFreqStart}\r\n 'Frequency end', {seikFreqEnd}\r\n 'Frequency interval', {seikFreqInterval}\r\n 'Daily every weekday', {seikScheduleDailyWeekdays}\r\n 'Daily interval', {seikScheduleDailyInterval}\r\n 'Weekly days', {seikScheduleWeeklyDays}\r\n 'Weekly interval', {seikScheduleWeeklyInterval}\r\n 'Monthly day', {seikScheduleMonthlyDay}\r\n 'Monthly index type', {seikScheduleMonthlyIndexType}\r\n 'Monthly index', {seikScheduleMonthlyIndex}\r\n 'Monthly interval', {seikScheduleMonthlyInterval}\r\n 'Yearly day', {seikScheduleYearlyDay}\r\n 'Yearly month', {seikScheduleYearlyMonth}\r\n 'Yearly index type', {seikScheduleYearlyIndexType}\r\n 'Yearly index', {seikScheduleYearlyIndex}\r\n 'Yearly interval'); {seikScheduleYearlyInterval}\r\n\r\n sTXTID_SchedGeneric = '# Schedule: Generic';\r\n sTXTID_SchedRecur = '# Schedule: Recurring info';\r\n sTXTID_SchedEnd = '# Schedule: End info';\r\n sTXTID_SchedFreq = '# Schedule: Day frequency';\r\n sTXTID_SchedDaily = '# Schedule: Daily info';\r\n sTXTID_SchedWeekly = '# Schedule: Weekly info';\r\n sTXTID_SchedMonthly = '# Schedule: Monthly info';\r\n sTXTID_SchedYearly = '# Schedule: Yearly info';\r\n\r\ntype\r\n TTxtStore = class(TJvSchedEvtStore)\r\n private\r\n FStream: TStream;\r\n FOwnsStream: Boolean;\r\n protected\r\n // Retrieving items: Schedule\r\n procedure CheckSignature; override;\r\n procedure CheckVersion; override;\r\n function NextItemKind: TSchedEvtItemKind; override;\r\n procedure RestoreScheduleStart; override;\r\n procedure RestoreScheduleRecurType; override;\r\n procedure RestoreScheduleEndType; override;\r\n procedure RestoreScheduleEndCount; override;\r\n procedure RestoreScheduleEndDate; override;\r\n procedure RestoreFreqStart; override;\r\n procedure RestoreFreqEnd; override;\r\n procedure RestoreFreqInterval; override;\r\n procedure RestoreScheduleDailyWeekdays; override;\r\n procedure RestoreScheduleDailyInterval; override;\r\n procedure RestoreScheduleWeeklyDays; override;\r\n procedure RestoreScheduleWeeklyInterval; override;\r\n procedure RestoreScheduleMonthlyDay; override;\r\n procedure RestoreScheduleMonthlyIndexType; override;\r\n procedure RestoreScheduleMonthlyIndex; override;\r\n procedure RestoreScheduleMonthlyInterval; override;\r\n procedure RestoreScheduleYearlyDay; override;\r\n procedure RestoreScheduleYearlyMonth; override;\r\n procedure RestoreScheduleYearlyIndexType; override;\r\n procedure RestoreScheduleYearlyIndex; override;\r\n procedure RestoreScheduleYearlyInterval; override;\r\n // Storing items: signature (only for unstructured storages) and versioning\r\n procedure StoreSignature; override;\r\n procedure StoreVersion; override;\r\n // Storing items: Schedule\r\n procedure StoreScheduleStart; override;\r\n procedure StoreScheduleRecurType; override;\r\n procedure StoreScheduleEndType; override;\r\n procedure StoreScheduleEndCount; override;\r\n procedure StoreScheduleEndDate; override;\r\n procedure StoreFreqStart; override;\r\n procedure StoreFreqEnd; override;\r\n procedure StoreFreqInterval; override;\r\n procedure StoreScheduleDailyWeekdays; override;\r\n procedure StoreScheduleDailyInterval; override;\r\n procedure StoreScheduleWeeklyDays; override;\r\n procedure StoreScheduleWeeklyInterval; override;\r\n procedure StoreScheduleMonthlyDay; override;\r\n procedure StoreScheduleMonthlyIndexType; override;\r\n procedure StoreScheduleMonthlyIndex; override;\r\n procedure StoreScheduleMonthlyInterval; override;\r\n procedure StoreScheduleYearlyDay; override;\r\n procedure StoreScheduleYearlyMonth; override;\r\n procedure StoreScheduleYearlyIndexType; override;\r\n procedure StoreScheduleYearlyIndex; override;\r\n procedure StoreScheduleYearlyInterval; override;\r\n procedure BeginStruct(const StructType: TSchedEvtStructKind); override;\r\n procedure EndStruct; override;\r\n procedure CheckBeginStruct(const StructType: TSchedEvtStructKind); override;\r\n procedure CheckEndStruct; override;\r\n function ReadLn: string;\r\n function ReadNextLine: string;\r\n function ReadItem(out AName: string): string;\r\n procedure WriteLn(const S: string);\r\n function ReadEnum(const AName: string; TypeInfo: PTypeInfo): Integer;\r\n function ReadInt(const AName: string): Int64;\r\n procedure ReadSet(const AName: string; out Value; TypeInfo: PTypeInfo);\r\n function ReadStamp(const AName: string): TTimeStamp;\r\n function ReadStampDate(const AName: string): Integer;\r\n function ReadStampTime(const AName: string): Integer;\r\n procedure WriteEnum(const AName: string; const Ordinal: Integer; TypeInfo: PTypeInfo);\r\n procedure WriteInt(const AName: string; const Value: Int64);\r\n procedure WriteSet(const AName: string; const Value; TypeInfo: PTypeInfo);\r\n procedure WriteStamp(const AName: string; const Stamp: TTimeStamp);\r\n procedure WriteStampDate(const AName: string; const Date: Integer);\r\n procedure WriteStampTime(const AName: string; const Time: Integer);\r\n public\r\n function GetAttributes: TSchedEvtStoreAttributes; override;\r\n constructor Create(const AStream: TStream; const AOwnsStream: Boolean = True);\r\n destructor Destroy; override;\r\n end;\r\n\r\nconstructor TTxtStore.Create(const AStream: TStream; const AOwnsStream: Boolean);\r\nbegin\r\n inherited Create;\r\n FStream := AStream;\r\n FOwnsStream := AOwnsStream;\r\nend;\r\n\r\ndestructor TTxtStore.Destroy;\r\nbegin\r\n if FOwnsStream then\r\n FreeAndNil(FStream);\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TTxtStore.CheckSignature;\r\nbegin\r\nend;\r\n\r\nprocedure TTxtStore.CheckVersion;\r\nbegin\r\nend;\r\n\r\nfunction TTxtStore.NextItemKind: TSchedEvtItemKind;\r\nvar\r\n SPos: Integer;\r\n ItemName: string;\r\n I: Integer;\r\nbegin\r\n SPos := FStream.Position;\r\n try\r\n ReadItem(ItemName);\r\n I := Pos('.', ItemName);\r\n if I > 0 then\r\n ItemName := Copy(ItemName, 1, I - 1);\r\n Result := High(TSchedEvtItemKind);\r\n while (Result > Low(TSchedEvtItemKind)) and\r\n not AnsiSameText(ItemName, TxtIdentifiers[Result]) do\r\n Dec(Result);\r\n finally\r\n FStream.Position := SPos;\r\n end;\r\nend;\r\n\r\nprocedure TTxtStore.RestoreScheduleStart;\r\nbegin\r\n Event.Schedule.StartDate := ReadStamp(TxtIdentifiers[seikScheduleStart]);\r\nend;\r\n\r\nprocedure TTxtStore.RestoreScheduleRecurType;\r\nbegin\r\n Event.Schedule.RecurringType := TScheduleRecurringKind(ReadEnum(\r\n TxtIdentifiers[seikScheduleRecurType], TypeInfo(TScheduleRecurringKind)));\r\nend;\r\n\r\nprocedure TTxtStore.RestoreScheduleEndType;\r\nbegin\r\n Event.Schedule.EndType := TScheduleEndKind(ReadEnum(\r\n TxtIdentifiers[seikScheduleEndType], TypeInfo(TScheduleEndKind)));\r\nend;\r\n\r\nprocedure TTxtStore.RestoreScheduleEndCount;\r\nbegin\r\n Event.Schedule.EndCount := ReadInt(TxtIdentifiers[seikScheduleEndCount]);\r\nend;\r\n\r\nprocedure TTxtStore.RestoreScheduleEndDate;\r\nbegin\r\n Event.Schedule.EndDate := ReadStamp(TxtIdentifiers[seikScheduleEndDate]);\r\nend;\r\n\r\nprocedure TTxtStore.RestoreFreqStart;\r\nbegin\r\n (Event.Schedule as IJclScheduleDayFrequency).StartTime := ReadStampTime(TxtIdentifiers[seikFreqStart]);\r\nend;\r\n\r\nprocedure TTxtStore.RestoreFreqEnd;\r\nbegin\r\n (Event.Schedule as IJclScheduleDayFrequency).EndTime := ReadStampTime(TxtIdentifiers[seikFreqEnd]);\r\nend;\r\n\r\nprocedure TTxtStore.RestoreFreqInterval;\r\nbegin\r\n (Event.Schedule as IJclScheduleDayFrequency).Interval := ReadStampTime(TxtIdentifiers[seikFreqInterval]);\r\nend;\r\n\r\nprocedure TTxtStore.RestoreScheduleDailyWeekdays;\r\nbegin\r\n (Event.Schedule as IJclDailySchedule).EveryWeekDay := Boolean(ReadEnum(TxtIdentifiers[seikScheduleDailyWeekdays],\r\n TypeInfo(Boolean)));\r\nend;\r\n\r\nprocedure TTxtStore.RestoreScheduleDailyInterval;\r\nbegin\r\n (Event.Schedule as IJclDailySchedule).Interval := ReadInt(TxtIdentifiers[seikScheduleDailyInterval]);\r\nend;\r\n\r\nprocedure TTxtStore.RestoreScheduleWeeklyDays;\r\nvar\r\n I: TScheduleWeekDays;\r\nbegin\r\n ReadSet(TxtIdentifiers[seikScheduleWeeklyDays], I, TypeInfo(TScheduleWeekDays));\r\n (Event.Schedule as IJclWeeklySchedule).DaysOfWeek := I;\r\nend;\r\n\r\nprocedure TTxtStore.RestoreScheduleWeeklyInterval;\r\nbegin\r\n (Event.Schedule as IJclWeeklySchedule).Interval := ReadInt(TxtIdentifiers[seikScheduleWeeklyInterval]);\r\nend;\r\n\r\nprocedure TTxtStore.RestoreScheduleMonthlyDay;\r\nbegin\r\n (Event.Schedule as IJclMonthlySchedule).Day := ReadInt(TxtIdentifiers[seikScheduleMonthlyDay]);\r\nend;\r\n\r\nprocedure TTxtStore.RestoreScheduleMonthlyIndexType;\r\nbegin\r\n (Event.Schedule as IJclMonthlySchedule).IndexKind :=\r\n TScheduleIndexKind(ReadEnum(TxtIdentifiers[seikScheduleMonthlyIndexType], TypeInfo(TScheduleIndexKind)));\r\nend;\r\n\r\nprocedure TTxtStore.RestoreScheduleMonthlyIndex;\r\nbegin\r\n (Event.Schedule as IJclMonthlySchedule).IndexValue := ReadInt(TxtIdentifiers[seikScheduleMonthlyIndex]);\r\nend;\r\n\r\nprocedure TTxtStore.RestoreScheduleMonthlyInterval;\r\nbegin\r\n (Event.Schedule as IJclMonthlySchedule).Interval := ReadInt(TxtIdentifiers[seikScheduleMonthlyInterval]);\r\nend;\r\n\r\nprocedure TTxtStore.RestoreScheduleYearlyDay;\r\nbegin\r\n (Event.Schedule as IJclYearlySchedule).Day := ReadInt(TxtIdentifiers[seikScheduleYearlyDay]);\r\nend;\r\n\r\nprocedure TTxtStore.RestoreScheduleYearlyMonth;\r\nbegin\r\n (Event.Schedule as IJclYearlySchedule).Month := ReadInt(TxtIdentifiers[seikScheduleYearlyMonth]);\r\nend;\r\n\r\nprocedure TTxtStore.RestoreScheduleYearlyIndexType;\r\nbegin\r\n (Event.Schedule as IJclYearlySchedule).IndexKind :=\r\n TScheduleIndexKind(ReadEnum(TxtIdentifiers[seikScheduleYearlyIndexType], TypeInfo(TScheduleIndexKind)));\r\nend;\r\n\r\nprocedure TTxtStore.RestoreScheduleYearlyIndex;\r\nbegin\r\n (Event.Schedule as IJclYearlySchedule).IndexValue := ReadInt(TxtIdentifiers[seikScheduleYearlyIndex]);\r\nend;\r\n\r\nprocedure TTxtStore.RestoreScheduleYearlyInterval;\r\nbegin\r\n (Event.Schedule as IJclYearlySchedule).Interval := ReadInt(TxtIdentifiers[seikScheduleYearlyInterval]);\r\nend;\r\n\r\nprocedure TTxtStore.StoreSignature;\r\nbegin\r\nend;\r\n\r\nprocedure TTxtStore.StoreVersion;\r\nbegin\r\nend;\r\n\r\nprocedure TTxtStore.StoreScheduleStart;\r\nbegin\r\n WriteStamp(TxtIdentifiers[seikScheduleStart], Event.Schedule.StartDate);\r\nend;\r\n\r\nprocedure TTxtStore.StoreScheduleRecurType;\r\nbegin\r\n WriteEnum(TxtIdentifiers[seikScheduleRecurType], Ord(Event.Schedule.RecurringType), TypeInfo(TScheduleRecurringKind));\r\nend;\r\n\r\nprocedure TTxtStore.StoreScheduleEndType;\r\nbegin\r\n WriteEnum(TxtIdentifiers[seikScheduleEndType], Ord(Event.Schedule.EndType), TypeInfo(TScheduleEndKind));\r\nend;\r\n\r\nprocedure TTxtStore.StoreScheduleEndCount;\r\nbegin\r\n WriteInt(TxtIdentifiers[seikScheduleEndCount], Event.Schedule.EndCount);\r\nend;\r\n\r\nprocedure TTxtStore.StoreScheduleEndDate;\r\nbegin\r\n WriteStamp(TxtIdentifiers[seikScheduleEndDate], Event.Schedule.EndDate);\r\nend;\r\n\r\nprocedure TTxtStore.StoreFreqStart;\r\nbegin\r\n WriteStampTime(TxtIdentifiers[seikFreqStart], (Event.Schedule as IJclScheduleDayFrequency).StartTime);\r\nend;\r\n\r\nprocedure TTxtStore.StoreFreqEnd;\r\nbegin\r\n WriteStampTime(TxtIdentifiers[seikFreqEnd], (Event.Schedule as IJclScheduleDayFrequency).EndTime);\r\nend;\r\n\r\nprocedure TTxtStore.StoreFreqInterval;\r\nbegin\r\n WriteStampTime(TxtIdentifiers[seikFreqInterval], (Event.Schedule as IJclScheduleDayFrequency).Interval);\r\nend;\r\n\r\nprocedure TTxtStore.StoreScheduleDailyWeekdays;\r\nbegin\r\n WriteEnum(TxtIdentifiers[seikScheduleDailyWeekdays], Ord((Event.Schedule as IJclDailySchedule).EveryWeekDay),\r\n TypeInfo(Boolean));\r\nend;\r\n\r\nprocedure TTxtStore.StoreScheduleDailyInterval;\r\nbegin\r\n WriteInt(TxtIdentifiers[seikScheduleDailyInterval], (Event.Schedule as IJclDailySchedule).Interval);\r\nend;\r\n\r\nprocedure TTxtStore.StoreScheduleWeeklyDays;\r\nvar\r\n WD: TScheduleWeekDays;\r\nbegin\r\n WD := (Event.Schedule as IJclWeeklySchedule).DaysOfWeek;\r\n WriteSet(TxtIdentifiers[seikScheduleWeeklyDays], WD, TypeInfo(TScheduleWeekDays));\r\nend;\r\n\r\nprocedure TTxtStore.StoreScheduleWeeklyInterval;\r\nbegin\r\n WriteInt(TxtIdentifiers[seikScheduleWeeklyInterval], (Event.Schedule as IJclWeeklySchedule).Interval);\r\nend;\r\n\r\nprocedure TTxtStore.StoreScheduleMonthlyDay;\r\nbegin\r\n WriteInt(TxtIdentifiers[seikScheduleMonthlyDay], (Event.Schedule as IJclMonthlySchedule).Day);\r\nend;\r\n\r\nprocedure TTxtStore.StoreScheduleMonthlyIndexType;\r\nbegin\r\n WriteEnum(TxtIdentifiers[seikScheduleMonthlyIndexType], Ord((Event.Schedule as IJclMonthlySchedule).IndexKind),\r\n TypeInfo(TScheduleIndexKind));\r\nend;\r\n\r\nprocedure TTxtStore.StoreScheduleMonthlyIndex;\r\nbegin\r\n WriteInt(TxtIdentifiers[seikScheduleMonthlyIndex], (Event.Schedule as IJclMonthlySchedule).IndexValue);\r\nend;\r\n\r\nprocedure TTxtStore.StoreScheduleMonthlyInterval;\r\nbegin\r\n WriteInt(TxtIdentifiers[seikScheduleMonthlyInterval], (Event.Schedule as IJclMonthlySchedule).Interval);\r\nend;\r\n\r\nprocedure TTxtStore.StoreScheduleYearlyDay;\r\nbegin\r\n WriteInt(TxtIdentifiers[seikScheduleYearlyDay], (Event.Schedule as IJclYearlySchedule).Day);\r\nend;\r\n\r\nprocedure TTxtStore.StoreScheduleYearlyMonth;\r\nbegin\r\n WriteInt(TxtIdentifiers[seikScheduleYearlyMonth], (Event.Schedule as IJclYearlySchedule).Month);\r\nend;\r\n\r\nprocedure TTxtStore.StoreScheduleYearlyIndexType;\r\nbegin\r\n WriteEnum(TxtIdentifiers[seikScheduleYearlyIndexType], Ord((Event.Schedule as IJclYearlySchedule).IndexKind),\r\n TypeInfo(TScheduleIndexKind));\r\nend;\r\n\r\nprocedure TTxtStore.StoreScheduleYearlyIndex;\r\nbegin\r\n WriteInt(TxtIdentifiers[seikScheduleYearlyIndex], (Event.Schedule as IJclYearlySchedule).IndexValue);\r\nend;\r\n\r\nprocedure TTxtStore.StoreScheduleYearlyInterval;\r\nbegin\r\n WriteInt(TxtIdentifiers[seikScheduleYearlyInterval], (Event.Schedule as IJclYearlySchedule).Interval);\r\nend;\r\n\r\nprocedure TTxtStore.BeginStruct(const StructType: TSchedEvtStructKind);\r\nbegin\r\n PushStruct(StructType);\r\n case StructType of\r\n seskSchedule:\r\n WriteLn(sTXTID_SchedGeneric);\r\n seskScheduleRecurInfo:\r\n WriteLn(sTXTID_SchedRecur);\r\n seskScheduleEndInfo:\r\n WriteLn(sTXTID_SchedEnd);\r\n seskScheduleDayFreq:\r\n WriteLn(sTXTID_SchedFreq);\r\n seskScheduleDaily:\r\n WriteLn(sTXTID_SchedDaily);\r\n seskScheduleWeekly:\r\n WriteLn(sTXTID_SchedWeekly);\r\n seskScheduleMonthly:\r\n WriteLn(sTXTID_SchedMonthly);\r\n seskScheduleYearly:\r\n WriteLn(sTXTID_SchedYearly);\r\n else\r\n raise EJVCLException.CreateRes(@RsEUnexpectedStructure);\r\n end;\r\nend;\r\n\r\nprocedure TTxtStore.EndStruct;\r\nbegin\r\n PopStruct;\r\nend;\r\n\r\nprocedure TTxtStore.CheckBeginStruct(const StructType: TSchedEvtStructKind);\r\nvar\r\n S: string;\r\nbegin\r\n PushStruct(StructType);\r\n S := ReadNextLine;\r\n case StructType of\r\n seskSchedule:\r\n if not AnsiSameText(S, sTXTID_SchedGeneric) then\r\n raise EJVCLException.CreateRes(@RsEIncorrectStructure);\r\n seskScheduleRecurInfo:\r\n if not AnsiSameText(S, sTXTID_SchedRecur) then\r\n raise EJVCLException.CreateRes(@RsEIncorrectStructure);\r\n seskScheduleEndInfo:\r\n if not AnsiSameText(S, sTXTID_SchedEnd) then\r\n raise EJVCLException.CreateRes(@RsEIncorrectStructure);\r\n seskScheduleDayFreq:\r\n if not AnsiSameText(S, sTXTID_SchedFreq) then\r\n raise EJVCLException.CreateRes(@RsEIncorrectStructure);\r\n seskScheduleDaily:\r\n if not AnsiSameText(S, sTXTID_SchedDaily) then\r\n raise EJVCLException.CreateRes(@RsEIncorrectStructure);\r\n seskScheduleWeekly:\r\n if not AnsiSameText(S, sTXTID_SchedWeekly) then\r\n raise EJVCLException.CreateRes(@RsEIncorrectStructure);\r\n seskScheduleMonthly:\r\n if not AnsiSameText(S, sTXTID_SchedMonthly) then\r\n raise EJVCLException.CreateRes(@RsEIncorrectStructure);\r\n seskScheduleYearly:\r\n if not AnsiSameText(S, sTXTID_SchedYearly) then\r\n raise EJVCLException.CreateRes(@RsEIncorrectStructure);\r\n else\r\n raise EJVCLException.CreateRes(@RsEUnexpectedStructure);\r\n end;\r\nend;\r\n\r\nprocedure TTxtStore.CheckEndStruct;\r\nbegin\r\n PopStruct;\r\nend;\r\n\r\nfunction TTxtStore.ReadLn: string;\r\nvar\r\n OrgPos: Integer;\r\n SIdx: Integer;\r\n Done: Boolean;\r\n AnsiStr: AnsiString;\r\nbegin\r\n OrgPos := FStream.Position;\r\n AnsiStr := '';\r\n SIdx := 0;\r\n repeat\r\n Inc(SIdx);\r\n SetLength(AnsiStr, Length(AnsiStr) + 255);\r\n SetLength(AnsiStr, SIdx + FStream.Read(AnsiStr[SIdx], 255));\r\n Done := SIdx = Length(AnsiStr);\r\n if not Done then\r\n begin\r\n while (SIdx < Length(AnsiStr)) and (Copy(AnsiStr, SIdx, Length(sLineBreak)) <> sLineBreak) do\r\n Inc(SIdx);\r\n Done := Copy(AnsiStr, SIdx, Length(sLineBreak)) = sLineBreak;\r\n if Done then\r\n SetLength(AnsiStr, SIdx + 1);\r\n end;\r\n until Done;\r\n FStream.Position := OrgPos + Length(AnsiStr);\r\n if Copy(AnsiStr, Length(AnsiStr) - 1, Length(sLineBreak)) = sLineBreak then\r\n SetLength(AnsiStr, Length(AnsiStr) - Length(sLineBreak));\r\n Result := string(AnsiStr);\r\nend;\r\n\r\nfunction TTxtStore.ReadNextLine: string;\r\nbegin\r\n repeat\r\n Result := ReadLn;\r\n until (Trim(Result) <> '') or (FStream.Position = FStream.Size);\r\n Result := Trim(Result);\r\nend;\r\n\r\nfunction TTxtStore.ReadItem(out AName: string): string;\r\nvar\r\n I: Integer;\r\nbegin\r\n AName := '';\r\n Result := ReadNextLine;\r\n if Result <> '' then\r\n begin\r\n I := Pos('=', Result);\r\n if I > 0 then\r\n begin\r\n AName := Trim(Copy(Result, 1, I - 1));\r\n Result := Trim(Copy(Result, I + 1, Length(Result) - I));\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TTxtStore.WriteLn(const S: string);\r\nvar\r\n S2: AnsiString;\r\nbegin\r\n S2 := AnsiString(S + sLineBreak);\r\n if S2 <> '' then\r\n FStream.WriteBuffer(S2[1], Length(S2));\r\nend;\r\n\r\nfunction TTxtStore.ReadEnum(const AName: string; TypeInfo: PTypeInfo): Integer;\r\nvar\r\n ItemName: string;\r\n Value: string;\r\nbegin\r\n Value := ReadItem(ItemName);\r\n if not AnsiSameText(AName, ItemName) then\r\n raise EJVCLException.CreateRes(@RsEIncorrectIdentifierFound);\r\n Result := GetEnumValue(TypeInfo, Value);\r\nend;\r\n\r\nfunction TTxtStore.ReadInt(const AName: string): Int64;\r\nvar\r\n ItemName: string;\r\n Value: string;\r\nbegin\r\n Value := ReadItem(ItemName);\r\n if not AnsiSameText(AName, ItemName) then\r\n raise EJVCLException.CreateRes(@RsEIncorrectIdentifierFound);\r\n Result := StrToInt64(Value);\r\nend;\r\n\r\nprocedure TTxtStore.ReadSet(const AName: string; out Value; TypeInfo: PTypeInfo);\r\nvar\r\n ItemName: string;\r\n StrValue: string;\r\nbegin\r\n StrValue := ReadItem(ItemName);\r\n if not AnsiSameText(AName, ItemName) then\r\n raise EJVCLException.CreateRes(@RsEIncorrectIdentifierFound);\r\n JclStrToSet(TypeInfo, Value, StrValue);\r\nend;\r\n\r\nfunction TTxtStore.ReadStamp(const AName: string): TTimeStamp;\r\nbegin\r\n Result.Date := ReadStampDate(AName + '.Date');\r\n Result.Time := ReadStampTime(AName + '.Time');\r\nend;\r\n\r\nfunction TTxtStore.ReadStampDate(const AName: string): Integer;\r\nvar\r\n ItemName: string;\r\n Value: string;\r\n Y: Word;\r\n M: Word;\r\n D: Word;\r\nbegin\r\n Value := ReadItem(ItemName);\r\n if not AnsiSameText(AName, ItemName) then\r\n raise EJVCLException.CreateRes(@RsEIncorrectIdentifierFound);\r\n Y := StrToInt(Copy(Value, 1, 4));\r\n M := StrToInt(Copy(Value, 6, 2));\r\n D := StrToInt(Copy(Value, 9, 2));\r\n Result := DateTimeToTimeStamp(EncodeDate(Y, M, D)).Date;\r\nend;\r\n\r\nfunction TTxtStore.ReadStampTime(const AName: string): Integer;\r\nvar\r\n ItemName: string;\r\n Value: string;\r\n H: Word;\r\n Min: Word;\r\n MSecs: Integer;\r\nbegin\r\n Value := ReadItem(ItemName);\r\n if not AnsiSameText(AName, ItemName) then\r\n raise EJVCLException.CreateRes(@RsEIncorrectIdentifierFound);\r\n if (Length(Value) < 3) or CharInSet(Value[3], DigitChars) then\r\n Result := StrToInt(Value)\r\n else\r\n begin\r\n H := StrToInt(Copy(Value, 1, 2));\r\n Min := StrToInt(Copy(Value, 4, 2));\r\n MSecs := StrToInt(Copy(Value, 7, 2)) * 1000 + StrToInt(Copy(Value, 10, 3));\r\n Result := H * 3600000 + Min * 60000 + MSecs;\r\n end;\r\nend;\r\n\r\nprocedure TTxtStore.WriteEnum(const AName: string; const Ordinal: Integer; TypeInfo: PTypeInfo);\r\nbegin\r\n WriteLn(AName + ' = ' + GetEnumName(TypeInfo, Ordinal));\r\nend;\r\n\r\nprocedure TTxtStore.WriteInt(const AName: string; const Value: Int64);\r\nbegin\r\n WriteLn(AName + ' = ' + IntToStr(Value));\r\nend;\r\n\r\nprocedure TTxtStore.WriteSet(const AName: string; const Value; TypeInfo: PTypeInfo);\r\nbegin\r\n WriteLn(AName + ' = ' + JclSetToStr(TypeInfo, Value));\r\nend;\r\n\r\nprocedure TTxtStore.WriteStamp(const AName: string; const Stamp: TTimeStamp);\r\nbegin\r\n WriteStampDate(AName + '.Date', Stamp.Date);\r\n WriteStampTime(AName + '.Time', Stamp.Time);\r\nend;\r\n\r\nprocedure TTxtStore.WriteStampDate(const AName: string; const Date: Integer);\r\nvar\r\n TmpStamp: TTimeStamp;\r\n TmpDate: TDateTime;\r\n Y: Word;\r\n M: Word;\r\n D: Word;\r\nbegin\r\n TmpStamp.Date := Date;\r\n TmpStamp.Time := 0;\r\n TmpDate := TimeStampToDateTime(TmpStamp);\r\n DecodeDate(TmpDate, Y, M, D);\r\n WriteLn(AName + ' = ' + Format('%.4d/%.2d/%.2d', [Y, M, D]));\r\nend;\r\n\r\nprocedure TTxtStore.WriteStampTime(const AName: string; const Time: Integer);\r\nbegin\r\n WriteLn(AName + ' = ' + Format(\r\n '%.2d:%.2d:%.2d.%.3d',\r\n [(Time div 3600000) mod 24,\r\n (Time div 60000) mod 60,\r\n (Time div 1000) mod 60,\r\n Time mod 1000]));\r\nend;\r\n\r\nfunction TTxtStore.GetAttributes: TSchedEvtStoreAttributes;\r\nbegin\r\n Result := [sesaStructured, sesaIdentifiers];\r\nend;\r\n\r\n{ schedule persistency factories }\r\n\r\nfunction ScheduledEventStore_Stream(const Stream: TStream;\r\n const Binary, OwnsStream: Boolean): IJvScheduledEventsStore;\r\nbegin\r\n if Binary then\r\n Result := TBinStore.Create(Stream, OwnsStream)\r\n else\r\n Result := TTxtStore.Create(Stream, OwnsStream);\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n\r\n" }, { "path": "External/Jedi/Jvcl/run/JvScheduledEvents.pas", "content": "{-----------------------------------------------------------------------------\r\n\r\n Project JEDI Visible Component Library (J-VCL)\r\n\r\n The contents of this file are subject to the Mozilla Public License Version\r\n 1.1 (the \"License\"); you may not use this file except in compliance with the\r\n License. You may obtain a copy of the License at http://www.mozilla.org/MPL/\r\n\r\n Software distributed under the License is distributed on an \"AS IS\" basis,\r\n WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for\r\n the specific language governing rights and limitations under the License.\r\n\r\n The Initial Developer of the Original Code is Marcel Bestebroer\r\n .\r\n Portions created by Marcel Bestebroer are Copyright (C) 2000 - 2002 mbeSoft.\r\n All Rights Reserved.\r\n\r\n ******************************************************************************\r\n\r\n Event scheduling component. Allows to schedule execution of events, with\r\n optional recurring schedule options.\r\n\r\n You may retrieve the latest version of this file at the Project JEDI home\r\n page, located at http://www.delphi-jedi.org\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvScheduledEvents.pas 13356 2012-06-15 08:24:05Z ahuser $\r\n\r\nunit JvScheduledEvents;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n SysUtils, Classes, Contnrs, SyncObjs,\r\n {$IFDEF MSWINDOWS}\r\n Windows,\r\n {$ENDIF MSWINDOWS}\r\n Messages, Forms,\r\n JclSchedule,\r\n JvAppStorage;\r\n\r\nconst\r\n CM_EXECEVENT = WM_USER + $1000;\r\n\r\ntype\r\n TJvCustomScheduledEvents = class;\r\n TJvEventCollection = class;\r\n TJvEventCollectionItem = class;\r\n\r\n TScheduledEventState =\r\n (sesNotInitialized, sesWaiting, sesTriggered, sesExecuting, sesPaused, sesEnded);\r\n\r\n TScheduledEventStateInfo = record\r\n {Common}\r\n ARecurringType: TScheduleRecurringKind;\r\n AStartDate: TTimeStamp;\r\n AEndType: TScheduleEndKind;\r\n AEndDate: TTimeStamp;\r\n AEndCount: Cardinal;\r\n ALastTriggered: TTimeStamp;\r\n {DayFrequency}\r\n DayFrequence: record\r\n ADayFrequencyStartTime: Cardinal;\r\n ADayFrequencyEndTime: Cardinal;\r\n ADayFrequencyInterval: Cardinal;\r\n end;\r\n {Daily}\r\n Daily: record\r\n ADayEveryWeekDay: Boolean;\r\n ADayInterval: Cardinal;\r\n end;\r\n {Weekly}\r\n Weekly: record\r\n AWeekInterval: Cardinal;\r\n AWeekDaysOfWeek: TScheduleWeekDays;\r\n end;\r\n {Monthly}\r\n Monthly: record\r\n AMonthIndexKind: TScheduleIndexKind;\r\n AMonthIndexValue: Cardinal;\r\n AMonthDay: Cardinal;\r\n AMonthInterval: Cardinal;\r\n end;\r\n {Yearly}\r\n Yearly: record\r\n AYearIndexKind: TScheduleIndexKind;\r\n AYearIndexValue: Cardinal;\r\n AYearDay: Cardinal;\r\n AYearMonth: Cardinal;\r\n AYearInterval: Cardinal;\r\n end;\r\n end;\r\n\r\n TScheduledEventExecute = procedure(Sender: TJvEventCollectionItem; const IsSnoozeEvent: Boolean) of object;\r\n\r\n TJvCustomScheduledEvents = class(TComponent)\r\n private\r\n FAppStorage: TJvCustomAppStorage;\r\n FAppStoragePath: string;\r\n FAutoSave: Boolean;\r\n FEvents: TJvEventCollection;\r\n FPostedEvents: TList;\r\n FEventsPosted: Boolean;\r\n FOnStartEvent: TNotifyEvent;\r\n FOnEndEvent: TNotifyEvent;\r\n FWnd: THandle;\r\n protected\r\n procedure Notification(AComponent: TComponent; Operation: TOperation); override;\r\n procedure DoEndEvent(const Event: TJvEventCollectionItem);\r\n procedure DoStartEvent(const Event: TJvEventCollectionItem);\r\n procedure SetAppStorage(Value: TJvCustomAppStorage);\r\n function GetEvents: TJvEventCollection;\r\n procedure PostEvent(Event: TJvEventCollectionItem);\r\n procedure RemovePostedEvent(Event: TJvEventCollectionItem);\r\n procedure InitEvents;\r\n procedure Loaded; override;\r\n procedure LoadSingleEvent(Sender: TJvCustomAppStorage;\r\n const Path: string; const List: TObject; const Index: Integer; const ItemName: string);\r\n procedure SaveSingleEvent(Sender: TJvCustomAppStorage;\r\n const Path: string; const List: TObject; const Index: Integer; const ItemName: string);\r\n procedure DeleteSingleEvent(Sender: TJvCustomAppStorage; const Path: string;\r\n const List: TObject; const First, Last: Integer; const ItemName: string);\r\n procedure SetEvents(Value: TJvEventCollection);\r\n procedure WndProc(var Msg: TMessage); virtual;\r\n procedure CMExecEvent(var Msg: TMessage); message CM_EXECEVENT;\r\n property AutoSave: Boolean read FAutoSave write FAutoSave;\r\n property OnStartEvent: TNotifyEvent read FOnStartEvent write FOnStartEvent;\r\n property OnEndEvent: TNotifyEvent read FOnEndEvent write FOnEndEvent;\r\n property AppStorage: TJvCustomAppStorage read FAppStorage write SetAppStorage;\r\n property AppStoragePath: string read FAppStoragePath write FAppStoragePath;\r\n public\r\n {$IFDEF SUPPORTS_CLASS_CTORDTORS}\r\n class destructor Destroy;\r\n {$ENDIF SUPPORTS_CLASS_CTORDTORS}\r\n\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n property Handle: THandle read FWnd;\r\n property Events: TJvEventCollection read GetEvents write SetEvents;\r\n procedure LoadEventStates(const ClearBefore: Boolean = True);\r\n procedure SaveEventStates;\r\n procedure StartAll;\r\n procedure StopAll;\r\n procedure PauseAll;\r\n end;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvScheduledEvents = class(TJvCustomScheduledEvents)\r\n published\r\n property AppStorage;\r\n property AppStoragePath;\r\n property AutoSave;\r\n property Events;\r\n property OnStartEvent;\r\n property OnEndEvent;\r\n end;\r\n\r\n TJvEventCollection = class(TOwnedCollection)\r\n protected\r\n function GetItem(Index: Integer): TJvEventCollectionItem;\r\n procedure SetItem(Index: Integer; Value: TJvEventCollectionItem);\r\n procedure Notify(Item: TCollectionItem; Action: TCollectionNotification); override;\r\n public\r\n constructor Create(AOwner: TPersistent);\r\n function Add: TJvEventCollectionItem;\r\n function Insert(Index: Integer): TJvEventCollectionItem;\r\n property Items[Index: Integer]: TJvEventCollectionItem read GetItem write SetItem; default;\r\n end;\r\n\r\n TJvEventCollectionItem = class(TCollectionItem)\r\n private\r\n FCountMissedEvents: Boolean;\r\n FName: string;\r\n FState: TScheduledEventState;\r\n FData: Pointer;\r\n FOnExecute: TScheduledEventExecute;\r\n FSchedule: IJclSchedule;\r\n FLastSnoozeInterval: TSystemTime;\r\n FScheduleFire: TTimeStamp;\r\n FSnoozeFire: TTimeStamp;\r\n FReqTriggerTime: TTimeStamp;\r\n FActualTriggerTime: TTimeStamp;\r\n procedure Triggered;\r\n protected\r\n procedure DefineProperties(Filer: TFiler); override;\r\n procedure DoExecute(const IsSnoozeFire: Boolean);\r\n function GetDisplayName: string; override;\r\n function GetNextFire: TTimeStamp;\r\n procedure Execute; virtual;\r\n // schedule property readers/writers\r\n procedure PropDateRead(Reader: TReader; var Stamp: TTimeStamp);\r\n procedure PropDateWrite(Writer: TWriter; const Stamp: TTimeStamp);\r\n procedure PropDailyEveryWeekDayRead(Reader: TReader);\r\n procedure PropDailyEveryWeekDayWrite(Writer: TWriter);\r\n procedure PropDailyIntervalRead(Reader: TReader);\r\n procedure PropDailyIntervalWrite(Writer: TWriter);\r\n procedure PropEndCountRead(Reader: TReader);\r\n procedure PropEndCountWrite(Writer: TWriter);\r\n procedure PropEndDateRead(Reader: TReader);\r\n procedure PropEndDateWrite(Writer: TWriter);\r\n procedure PropEndTypeRead(Reader: TReader);\r\n procedure PropEndTypeWrite(Writer: TWriter);\r\n procedure PropFreqEndTimeRead(Reader: TReader);\r\n procedure PropFreqEndTimeWrite(Writer: TWriter);\r\n procedure PropFreqIntervalRead(Reader: TReader);\r\n procedure PropFreqIntervalWrite(Writer: TWriter);\r\n procedure PropFreqStartTimeRead(Reader: TReader);\r\n procedure PropFreqStartTimeWrite(Writer: TWriter);\r\n procedure PropMonthlyDayRead(Reader: TReader);\r\n procedure PropMonthlyDayWrite(Writer: TWriter);\r\n procedure PropMonthlyIndexKindRead(Reader: TReader);\r\n procedure PropMonthlyIndexKindWrite(Writer: TWriter);\r\n procedure PropMonthlyIndexValueRead(Reader: TReader);\r\n procedure PropMonthlyIndexValueWrite(Writer: TWriter);\r\n procedure PropMonthlyIntervalRead(Reader: TReader);\r\n procedure PropMonthlyIntervalWrite(Writer: TWriter);\r\n procedure PropRecurringTypeRead(Reader: TReader);\r\n procedure PropRecurringTypeWrite(Writer: TWriter);\r\n procedure PropStartDateRead(Reader: TReader);\r\n procedure PropStartDateWrite(Writer: TWriter);\r\n procedure PropWeeklyDaysOfWeekRead(Reader: TReader);\r\n procedure PropWeeklyDaysOfWeekWrite(Writer: TWriter);\r\n procedure PropWeeklyIntervalRead(Reader: TReader);\r\n procedure PropWeeklyIntervalWrite(Writer: TWriter);\r\n procedure PropYearlyDayRead(Reader: TReader);\r\n procedure PropYearlyDayWrite(Writer: TWriter);\r\n procedure PropYearlyIndexKindRead(Reader: TReader);\r\n procedure PropYearlyIndexKindWrite(Writer: TWriter);\r\n procedure PropYearlyIndexValueRead(Reader: TReader);\r\n procedure PropYearlyIndexValueWrite(Writer: TWriter);\r\n procedure PropYearlyIntervalRead(Reader: TReader);\r\n procedure PropYearlyIntervalWrite(Writer: TWriter);\r\n procedure PropYearlyMonthRead(Reader: TReader);\r\n procedure PropYearlyMonthWrite(Writer: TWriter);\r\n procedure SetName(Value: string);\r\n public\r\n constructor Create(Collection: TCollection); override;\r\n destructor Destroy; override;\r\n procedure Assign(Source: TPersistent); override;\r\n procedure LoadState(const TriggerStamp: TTimeStamp; const TriggerCount, DayCount: Integer;\r\n const SnoozeStamp: TTimeStamp; const ALastSnoozeInterval: TSystemTime;\r\n const AEventInfo: TScheduledEventStateInfo); virtual;\r\n procedure Pause;\r\n procedure SaveState(out TriggerStamp: TTimeStamp; out TriggerCount, DayCount: Integer;\r\n out SnoozeStamp: TTimeStamp; out ALastSnoozeInterval: TSystemTime;\r\n out AEventInfo: TScheduledEventStateInfo); virtual;\r\n procedure Snooze(const MSecs: Word; const Secs: Word = 0; const Mins: Word = 0;\r\n const Hrs: Word = 0; const Days: Word = 0);\r\n procedure Start;\r\n procedure Stop;\r\n property Data: Pointer read FData write FData;\r\n property LastSnoozeInterval: TSystemTime read FLastSnoozeInterval;\r\n property NextFire: TTimeStamp read GetNextFire;\r\n property State: TScheduledEventState read FState;\r\n property NextScheduleFire: TTimeStamp read FScheduleFire;\r\n property RequestedTriggerTime: TTimeStamp read FReqTriggerTime;\r\n property ActualTriggerTime: TTimeStamp read FActualTriggerTime;\r\n published\r\n property CountMissedEvents: Boolean read FCountMissedEvents write FCountMissedEvents default False;\r\n property Name: string read FName write SetName;\r\n property Schedule: IJclSchedule read FSchedule write FSchedule stored False;\r\n property OnExecute: TScheduledEventExecute read FOnExecute write FOnExecute;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvScheduledEvents.pas $';\r\n Revision: '$Revision: 13356 $';\r\n Date: '$Date: 2012-06-15 10:24:05 +0200 (ven. 15 juin 2012) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n TypInfo,\r\n JclDateTime, JclRTTI,\r\n JvJVCLUtils, JvResources, JvTypes;\r\n\r\nconst\r\n cEventPrefix = 'Event ';\r\n\r\n//=== { TScheduleThread } ====================================================\r\n\r\ntype\r\n TScheduleThread = class(TJvCustomThread)\r\n private\r\n FCritSect: TCriticalSection;\r\n FEnded: Boolean;\r\n FEventComponents: TComponentList;\r\n FEventIdx: Integer;\r\n protected\r\n procedure Execute; override;\r\n public\r\n constructor Create;\r\n destructor Destroy; override;\r\n procedure BeforeDestruction; override;\r\n procedure AddEventComponent(const AComp: TJvCustomScheduledEvents);\r\n procedure RemoveEventComponent(const AComp: TJvCustomScheduledEvents);\r\n procedure Lock;\r\n procedure Unlock;\r\n property Ended: Boolean read FEnded;\r\n end;\r\n\r\nconstructor TScheduleThread.Create;\r\nbegin\r\n inherited Create(True);\r\n FCritSect := TCriticalSection.Create;\r\n FEventComponents := TComponentList.Create(False);\r\nend;\r\n\r\ndestructor TScheduleThread.Destroy;\r\nbegin\r\n inherited Destroy;\r\n FreeAndNil(FCritSect);\r\nend;\r\n\r\nprocedure TScheduleThread.Execute;\r\nvar\r\n TskColl: TJvEventCollection;\r\n I: Integer;\r\n SysTime: TSystemTime;\r\n NowStamp: TTimeStamp;\r\n SchedEvents: TJvCustomScheduledEvents;\r\nbegin\r\n NameThread(ThreadName);\r\n try\r\n FEnded := False;\r\n while not Terminated do\r\n begin\r\n if (FCritSect <> nil) and (FEventComponents <> nil) then\r\n begin\r\n FCritSect.Enter;\r\n try\r\n FEventIdx := FEventComponents.Count - 1;\r\n while (FEventIdx > -1) and not Terminated do\r\n begin\r\n GetLocalTime(SysTime);\r\n NowStamp := DateTimeToTimeStamp(Now);\r\n NowStamp.Time := SysTime.wHour * 3600000 + SysTime.wMinute * 60000 +\r\n SysTime.wSecond * 1000 + SysTime.wMilliseconds;\r\n SchedEvents := TJvCustomScheduledEvents(FEventComponents[FEventIdx]);\r\n TskColl := SchedEvents.Events;\r\n I := 0;\r\n while (I < TskColl.Count) and not Terminated do\r\n begin\r\n if (TskColl[I].State = sesWaiting) and\r\n (CompareTimeStamps(NowStamp, TskColl[I].NextFire) >= 0) then\r\n begin\r\n TskColl[I].Triggered;\r\n SchedEvents.PostEvent(TskColl[I]);\r\n end;\r\n Inc(I);\r\n end;\r\n Dec(FEventIdx);\r\n end;\r\n finally\r\n FCritSect.Leave;\r\n end;\r\n end;\r\n if not Terminated then\r\n Sleep(1);\r\n end;\r\n except\r\n end;\r\n FEnded := True;\r\nend;\r\n\r\nprocedure TScheduleThread.BeforeDestruction;\r\nbegin\r\n if (FCritSect = nil) or (FEventComponents = nil) then\r\n Exit;\r\n FCritSect.Enter;\r\n try\r\n FreeAndNil(FEventComponents);\r\n finally\r\n FCritSect.Leave;\r\n end;\r\n inherited BeforeDestruction;\r\nend;\r\n\r\nprocedure TScheduleThread.AddEventComponent(const AComp: TJvCustomScheduledEvents);\r\nbegin\r\n if (FCritSect = nil) or (FEventComponents = nil) then\r\n Exit;\r\n FCritSect.Enter;\r\n try\r\n if FEventComponents.IndexOf(AComp) = -1 then\r\n begin\r\n FEventComponents.Add(AComp);\r\n if Suspended then\r\n Suspended := False;\r\n end;\r\n finally\r\n FCritSect.Leave;\r\n end;\r\nend;\r\n\r\nprocedure TScheduleThread.RemoveEventComponent(const AComp: TJvCustomScheduledEvents);\r\nbegin\r\n if (FCritSect = nil) or (FEventComponents = nil) then\r\n Exit;\r\n FCritSect.Enter;\r\n try\r\n FEventComponents.Remove(AComp);\r\n finally\r\n FCritSect.Leave;\r\n end;\r\nend;\r\n\r\nprocedure TScheduleThread.Lock;\r\nbegin\r\n FCritSect.Enter;\r\nend;\r\n\r\nprocedure TScheduleThread.Unlock;\r\nbegin\r\n FCritSect.Leave;\r\nend;\r\n\r\n{ TScheduleThread instance }\r\n\r\nvar\r\n GScheduleThread: TScheduleThread = nil;\r\n\r\nprocedure FinalizeScheduleThread;\r\nbegin\r\n if GScheduleThread <> nil then\r\n begin\r\n if GScheduleThread.Suspended then\r\n begin\r\n GScheduleThread.Suspended := False;\r\n // In order for the thread to actually start (and respond to Terminate)\r\n // we must indicate to the system that we want to be paused. This way\r\n // the thread can start and will start working.\r\n // If we don't do this, the threadproc in classes.pas will directly see\r\n // that Terminated is set to True and never call Execute\r\n SleepEx(10, True);\r\n end;\r\n GScheduleThread.FreeOnTerminate := False;\r\n GScheduleThread.Terminate;\r\n while not GScheduleThread.Ended do\r\n begin\r\n SleepEx(10, True);\r\n Application.ProcessMessages;\r\n end;\r\n FreeAndNil(GScheduleThread);\r\n end;\r\nend;\r\n\r\nfunction ScheduleThread: TScheduleThread;\r\nbegin\r\n if GScheduleThread = nil then\r\n GScheduleThread := TScheduleThread.Create;\r\n Result := GScheduleThread;\r\nend;\r\n\r\n//=== { THackWriter } ========================================================\r\n\r\ntype\r\n TReaderAccessProtected = class(TReader);\r\n\r\ntype\r\n THackWriter = class(TWriter)\r\n protected\r\n procedure WriteSet(SetType: Pointer; Value: Integer);\r\n end;\r\n\r\n// Copied from D5 Classes.pas and modified a bit.\r\n\r\nprocedure THackWriter.WriteSet(SetType: Pointer; Value: Integer);\r\nvar\r\n I: Integer;\r\n BaseType: PTypeInfo;\r\nbegin\r\n BaseType := GetTypeData(SetType)^.CompType^;\r\n WriteValue(vaSet);\r\n for I := 0 to SizeOf(TIntegerSet) * 8 - 1 do\r\n if I in TIntegerSet(Value) then\r\n {$IFDEF RTL200_UP}WriteUTF8Str{$ELSE}WriteStr{$ENDIF RTL200_UP}(GetEnumName(BaseType, I));\r\n WriteStr('');\r\nend;\r\n\r\n//=== { TJvCustomScheduledEvents } ===========================================\r\n\r\n{$IFDEF SUPPORTS_CLASS_CTORDTORS}\r\nclass destructor TJvCustomScheduledEvents.Destroy;\r\nbegin\r\n FinalizeScheduleThread;\r\nend;\r\n{$ENDIF SUPPORTS_CLASS_CTORDTORS}\r\n\r\nconstructor TJvCustomScheduledEvents.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FPostedEvents := TList.Create;\r\n FEvents := TJvEventCollection.Create(Self);\r\n\r\n FWnd := AllocateHWndEx(WndProc);\r\n if not (csDesigning in ComponentState) and not (csLoading in ComponentState) then\r\n begin\r\n if AutoSave then\r\n LoadEventStates;\r\n InitEvents;\r\n end;\r\n ScheduleThread.AddEventComponent(Self);\r\nend;\r\n\r\ndestructor TJvCustomScheduledEvents.Destroy;\r\nbegin\r\n if not (csDesigning in ComponentState) then\r\n begin\r\n ScheduleThread.RemoveEventComponent(Self);\r\n if AutoSave then\r\n SaveEventStates;\r\n if FWnd <> 0 then\r\n DeallocateHWndEx(FWnd);\r\n end;\r\n FEvents.Free;\r\n FPostedEvents.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvCustomScheduledEvents.SetAppStorage(Value: TJvCustomAppStorage);\r\nbegin\r\n ReplaceComponentReference(Self, Value, TComponent(FAppStorage));\r\nend;\r\n\r\nprocedure TJvCustomScheduledEvents.Notification(AComponent: TComponent; Operation: TOperation);\r\nbegin\r\n inherited Notification(AComponent, Operation);\r\n if (AComponent = AppStorage) and (Operation = opRemove) then\r\n AppStorage := nil;\r\nend;\r\n\r\nprocedure TJvCustomScheduledEvents.DoEndEvent(const Event: TJvEventCollectionItem);\r\nbegin\r\n if Assigned(FOnEndEvent) then\r\n FOnEndEvent(Event);\r\nend;\r\n\r\nprocedure TJvCustomScheduledEvents.DoStartEvent(const Event: TJvEventCollectionItem);\r\nbegin\r\n if Assigned(FOnStartEvent) then\r\n FOnStartEvent(Event);\r\nend;\r\n\r\nfunction TJvCustomScheduledEvents.GetEvents: TJvEventCollection;\r\nbegin\r\n Result := FEvents;\r\nend;\r\n\r\nprocedure TJvCustomScheduledEvents.InitEvents;\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := 0 to FEvents.Count - 1 do\r\n if FEvents[I].State = sesNotInitialized then\r\n FEvents[I].Start;\r\nend;\r\n\r\nprocedure TJvCustomScheduledEvents.Loaded;\r\nbegin\r\n if not (csDesigning in ComponentState) then\r\n begin\r\n if AutoSave then\r\n LoadEventStates;\r\n InitEvents;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomScheduledEvents.LoadSingleEvent(Sender: TJvCustomAppStorage;\r\n const Path: string; const List: TObject; const Index: Integer; const ItemName: string);\r\nvar\r\n Stamp: TTimeStamp;\r\n TriggerCount: Integer;\r\n DayCount: Integer;\r\n Snooze: TTimeStamp;\r\n SnoozeInterval: TSystemTime;\r\n EventName: string;\r\n Event: TJvEventCollectionItem;\r\n\r\n AInt: Cardinal;\r\n EventInfo: TScheduledEventStateInfo;\r\nbegin\r\n EventName := Sender.ReadString(Sender.ConcatPaths([Path, ItemName + IntToStr(Index), 'Eventname']));\r\n if EventName <> '' then\r\n begin\r\n Stamp.Date := Sender.ReadInteger(Sender.ConcatPaths([Path, ItemName + IntToStr(Index), 'Stamp.Date']));\r\n Stamp.Time := Sender.ReadInteger(Sender.ConcatPaths([Path, ItemName + IntToStr(Index), 'Stamp.Time']));\r\n TriggerCount := Sender.ReadInteger(Sender.ConcatPaths([Path, ItemName + IntToStr(Index), 'TriggerCount']));\r\n DayCount := Sender.ReadInteger(Sender.ConcatPaths([Path, ItemName + IntToStr(Index), 'DayCount']));\r\n Snooze.Date := Sender.ReadInteger(Sender.ConcatPaths([Path, ItemName + IntToStr(Index), 'Snooze.Date']));\r\n Snooze.Time := Sender.ReadInteger(Sender.ConcatPaths([Path, ItemName + IntToStr(Index), 'Snooze.Time']));\r\n SnoozeInterval.wYear := Sender.ReadInteger(Sender.ConcatPaths([Path, ItemName + IntToStr(Index), 'SnoozeInterval.wYear']));\r\n SnoozeInterval.wMonth := Sender.ReadInteger(Sender.ConcatPaths([Path, ItemName + IntToStr(Index), 'SnoozeInterval.wMonth']));\r\n SnoozeInterval.wDay := Sender.ReadInteger(Sender.ConcatPaths([Path, ItemName + IntToStr(Index), 'SnoozeInterval.wDay']));\r\n SnoozeInterval.wHour := Sender.ReadInteger(Sender.ConcatPaths([Path, ItemName + IntToStr(Index), 'SnoozeInterval.wHour']));\r\n SnoozeInterval.wMinute := Sender.ReadInteger(Sender.ConcatPaths([Path, ItemName + IntToStr(Index), 'SnoozeInterval.wMinute']));\r\n SnoozeInterval.wSecond := Sender.ReadInteger(Sender.ConcatPaths([Path, ItemName + IntToStr(Index), 'SnoozeInterval.wSecond']));\r\n SnoozeInterval.wMilliseconds := Sender.ReadInteger(Sender.ConcatPaths([Path, ItemName + IntToStr(Index), 'SnoozeInterval.wMilliseconds']));\r\n {Common}\r\n with EventInfo do\r\n begin\r\n AInt := Sender.ReadInteger(Sender.ConcatPaths([Path, ItemName + IntToStr(Index), 'RecurringType']));\r\n ARecurringType := TScheduleRecurringKind(AInt);\r\n AStartDate.Time := Sender.ReadInteger(Sender.ConcatPaths([Path, ItemName + IntToStr(Index), 'StartDate_time']));\r\n AStartDate.Date := Sender.ReadInteger(Sender.ConcatPaths([Path, ItemName + IntToStr(Index), 'StartDate_date']));\r\n AInt := Sender.ReadInteger(Sender.ConcatPaths([Path, ItemName + IntToStr(Index), 'EndType']));\r\n AEndType := TScheduleEndKind(AInt);\r\n AEndDate.Time := Sender.ReadInteger(Sender.ConcatPaths([Path, ItemName + IntToStr(Index), 'EndDate_time']));\r\n AEndDate.Date := Sender.readInteger(Sender.ConcatPaths([Path, ItemName + IntToStr(Index), 'EndDate_date']));\r\n AEndCount := Sender.ReadInteger(Sender.ConcatPaths([Path, ItemName + IntToStr(Index), 'EndCount']));\r\n ALastTriggered.Time := Sender.ReadInteger(Sender.ConcatPaths([Path, ItemName + IntToStr(Index), 'LastTriggered_time']));\r\n ALastTriggered.Date := Sender.ReadInteger(Sender.ConcatPaths([Path, ItemName + IntToStr(Index), 'LastTriggered_date']));\r\n end;\r\n {DayFrequency}\r\n with EventInfo.DayFrequence do\r\n begin\r\n ADayFrequencyStartTime := Sender.ReadInteger(Sender.ConcatPaths([Path, ItemName + IntToStr(Index), 'DayFrequencyStartTime']));\r\n ADayFrequencyEndTime := Sender.ReadInteger(Sender.ConcatPaths([Path, ItemName + IntToStr(Index), 'DayFrequencyEndTime']));\r\n ADayFrequencyInterval := Sender.ReadInteger(Sender.ConcatPaths([Path, ItemName + IntToStr(Index), 'DayFrequencyInterval']));\r\n end;\r\n {Daily}\r\n with EventInfo.Daily do\r\n begin\r\n ADayEveryWeekDay := Sender.ReadBoolean(Sender.ConcatPaths([Path, ItemName + IntToStr(Index), 'DayEveryWeekDay']));\r\n ADayInterval := Sender.ReadInteger(Sender.ConcatPaths([Path, ItemName + IntToStr(Index), 'DayInterval']));\r\n end;\r\n {Weekly}\r\n with EventInfo.Weekly do\r\n begin\r\n AWeekInterval := Sender.ReadInteger(Sender.ConcatPaths([Path, ItemName + IntToStr(Index), 'WeekInterval']));\r\n AppStorage.ReadSet(Sender.ConcatPaths([Path, ItemName + IntToStr(Index),'WeekDaysOfWeek']), TypeInfo(TScheduleWeekDays), [], AWeekDaysOfWeek);\r\n end;\r\n {Monthly}\r\n with EventInfo.Monthly do\r\n begin\r\n AInt := Sender.ReadInteger(Sender.ConcatPaths([Path, ItemName + IntToStr(Index), 'MothIndexKind']));\r\n AMonthIndexKind := TScheduleIndexKind(AInt);\r\n AMonthIndexValue := Sender.ReadInteger(Sender.ConcatPaths([Path, ItemName + IntToStr(Index), 'MonthIndexValue']));\r\n AMonthDay := Sender.ReadInteger(Sender.ConcatPaths([Path, ItemName + IntToStr(Index), 'MonthDay']));\r\n AMonthInterval := Sender.ReadInteger(Sender.ConcatPaths([Path, ItemName + IntToStr(Index), 'MonthInterval']));\r\n end;\r\n {Yearly}\r\n with EventInfo.Yearly do\r\n begin\r\n AInt := Sender.ReadInteger(Sender.ConcatPaths([Path, ItemName + IntToStr(Index), 'YearIndexKind']));\r\n AYearIndexKind := TScheduleIndexKind(AInt);\r\n AYearIndexValue := Sender.ReadInteger(Sender.ConcatPaths([Path, ItemName + IntToStr(Index), 'YearIndexValue']));\r\n AYearDay := Sender.ReadInteger(Sender.ConcatPaths([Path, ItemName + IntToStr(Index), 'YearDay']));\r\n AYearMonth := Sender.ReadInteger(Sender.ConcatPaths([Path, ItemName + IntToStr(Index), 'YearMonth']));\r\n AYearInterval := Sender.ReadInteger(Sender.ConcatPaths([Path, ItemName + IntToStr(Index), 'YearInterval']));\r\n end;\r\n Event := TJvEventCollection(List).Add;\r\n Event.Name := EventName;\r\n Event.LoadState(Stamp, TriggerCount, DayCount, Snooze, SnoozeInterval, EventInfo);\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomScheduledEvents.LoadEventStates(const ClearBefore: Boolean = True);\r\nbegin\r\n if ClearBefore then\r\n FEvents.Clear;\r\n if Assigned(AppStorage) then\r\n if AppStorage.PathExists(AppStoragePath) then\r\n AppStorage.ReadList(AppStoragePath, FEvents, LoadSingleEvent, cEventPrefix);\r\nend;\r\n\r\nprocedure TJvCustomScheduledEvents.SaveSingleEvent(Sender: TJvCustomAppStorage;\r\n const Path: string; const List: TObject; const Index: Integer; const ItemName: string);\r\nvar\r\n Stamp: TTimeStamp;\r\n TriggerCount: Integer;\r\n DayCount: Integer;\r\n StampDate: Integer;\r\n StampTime: Integer;\r\n SnoozeStamp: TTimeStamp;\r\n SnoozeInterval: TSystemTime;\r\n SnoozeDate: Integer;\r\n SnoozeTime: Integer;\r\n EventInfo: TScheduledEventStateInfo;\r\nbegin\r\n TJvEventCollection(List)[Index].SaveState(Stamp, TriggerCount, DayCount, SnoozeStamp, SnoozeInterval, EventInfo);\r\n StampDate := Stamp.Date;\r\n StampTime := Stamp.Time;\r\n SnoozeDate := SnoozeStamp.Date;\r\n SnoozeTime := SnoozeStamp.Time;\r\n AppStorage.WriteString(AppStorage.ConcatPaths([Path, ItemName + IntToStr(Index), 'Eventname']), FEvents[Index].Name);\r\n AppStorage.WriteInteger(AppStorage.ConcatPaths([Path, ItemName + IntToStr(Index), 'Stamp.Date']), StampDate);\r\n AppStorage.WriteInteger(AppStorage.ConcatPaths([Path, ItemName + IntToStr(Index), 'Stamp.Time']), StampTime);\r\n AppStorage.WriteInteger(AppStorage.ConcatPaths([Path, ItemName + IntToStr(Index), 'TriggerCount']), TriggerCount);\r\n AppStorage.WriteInteger(AppStorage.ConcatPaths([Path, ItemName + IntToStr(Index), 'DayCount']), DayCount);\r\n AppStorage.WriteInteger(AppStorage.ConcatPaths([Path, ItemName + IntToStr(Index), 'Snooze.Date']), SnoozeDate);\r\n AppStorage.WriteInteger(AppStorage.ConcatPaths([Path, ItemName + IntToStr(Index), 'Snooze.Time']), SnoozeTime);\r\n AppStorage.WriteInteger(AppStorage.ConcatPaths([Path, ItemName + IntToStr(Index), 'SnoozeInterval.wYear']), SnoozeInterval.wYear);\r\n AppStorage.WriteInteger(AppStorage.ConcatPaths([Path, ItemName + IntToStr(Index), 'SnoozeInterval.wMonth']), SnoozeInterval.wMonth);\r\n AppStorage.WriteInteger(AppStorage.ConcatPaths([Path, ItemName + IntToStr(Index), 'SnoozeInterval.wDay']), SnoozeInterval.wDay);\r\n AppStorage.WriteInteger(AppStorage.ConcatPaths([Path, ItemName + IntToStr(Index), 'SnoozeInterval.wHour']), SnoozeInterval.wHour);\r\n AppStorage.WriteInteger(AppStorage.ConcatPaths([Path, ItemName + IntToStr(Index), 'SnoozeInterval.wMinute']), SnoozeInterval.wMinute);\r\n AppStorage.WriteInteger(AppStorage.ConcatPaths([Path, ItemName + IntToStr(Index), 'SnoozeInterval.wSecond']), SnoozeInterval.wSecond);\r\n AppStorage.WriteInteger(AppStorage.ConcatPaths([Path, ItemName + IntToStr(Index), 'SnoozeInterval.wMilliseconds']), SnoozeInterval.wMilliseconds);\r\n {Common}\r\n with EventInfo do\r\n begin\r\n AppStorage.WriteInteger(AppStorage.ConcatPaths([Path, ItemName + IntToStr(Index), 'RecurringType']), Integer(ARecurringType));\r\n AppStorage.WriteInteger(AppStorage.ConcatPaths([Path, ItemName + IntToStr(Index), 'StartDate_time']), AStartDate.Time);\r\n AppStorage.WriteInteger(AppStorage.ConcatPaths([Path, ItemName + IntToStr(Index), 'StartDate_date']), AStartDate.Date);\r\n AppStorage.WriteInteger(AppStorage.ConcatPaths([Path, ItemName + IntToStr(Index), 'EndType']), Integer(AEndType));\r\n AppStorage.WriteInteger(AppStorage.ConcatPaths([Path, ItemName + IntToStr(Index), 'EndDate_time']), AEndDate.Time);\r\n AppStorage.WriteInteger(AppStorage.ConcatPaths([Path, ItemName + IntToStr(Index), 'EndDate_date']), AEndDate.Date);\r\n AppStorage.WriteInteger(AppStorage.ConcatPaths([Path, ItemName + IntToStr(Index), 'EndCount']), AEndCount);\r\n AppStorage.WriteInteger(AppStorage.ConcatPaths([Path, ItemName + IntToStr(Index), 'LastTriggered_time']), ALastTriggered.Time);\r\n AppStorage.WriteInteger(AppStorage.ConcatPaths([Path, ItemName + IntToStr(Index), 'LastTriggered_date']), ALastTriggered.Date);\r\n end;\r\n {DayFrequency}\r\n with EventInfo.DayFrequence do\r\n begin\r\n AppStorage.WriteInteger(AppStorage.ConcatPaths([Path, ItemName + IntToStr(Index), 'DayFrequencyStartTime']), ADayFrequencyStartTime);\r\n AppStorage.WriteInteger(AppStorage.ConcatPaths([Path, ItemName + IntToStr(Index), 'DayFrequencyEndTime']), ADayFrequencyEndTime);\r\n AppStorage.WriteInteger(AppStorage.ConcatPaths([Path, ItemName + IntToStr(Index), 'DayFrequencyInterval']), ADayFrequencyInterval);\r\n end;\r\n {Daily}\r\n with EventInfo.Daily do\r\n begin\r\n AppStorage.WriteBoolean(AppStorage.ConcatPaths([Path, ItemName + IntToStr(Index), 'DayEveryWeekDay']), ADayEveryWeekDay);\r\n AppStorage.WriteInteger(AppStorage.ConcatPaths([Path, ItemName + IntToStr(Index), 'DayInterval']), ADayInterval);\r\n end;\r\n {Weekly}\r\n with EventInfo.Weekly do\r\n begin\r\n AppStorage.WriteInteger(AppStorage.ConcatPaths([Path, ItemName + IntToStr(Index), 'WeekInterval']), AWeekInterval);\r\n AppStorage.WriteSet(AppStorage.ConcatPaths([Path, ItemName + IntToStr(Index), 'WeekDaysOfWeek']), TypeInfo(TScheduleWeekDays), AWeekDaysOfWeek);\r\n end;\r\n {Monthly}\r\n with EventInfo.Monthly do\r\n begin\r\n AppStorage.WriteInteger(AppStorage.ConcatPaths([Path, ItemName + IntToStr(Index), 'MothIndexKind']), Integer(AMonthIndexKind));\r\n AppStorage.WriteInteger(AppStorage.ConcatPaths([Path, ItemName + IntToStr(Index), 'MonthIndexValue']), AMonthIndexValue);\r\n AppStorage.WriteInteger(AppStorage.ConcatPaths([Path, ItemName + IntToStr(Index), 'MonthDay']), AMonthDay);\r\n AppStorage.WriteInteger(AppStorage.ConcatPaths([Path, ItemName + IntToStr(Index), 'MonthInterval']), AMonthInterval);\r\n end;\r\n {Yearly}\r\n with EventInfo.Yearly do\r\n begin\r\n AppStorage.WriteInteger(AppStorage.ConcatPaths([Path, ItemName + IntToStr(Index), 'YearIndexKind']), Integer(AYearIndexKind));\r\n AppStorage.WriteInteger(AppStorage.ConcatPaths([Path, ItemName + IntToStr(Index), 'YearIndexValue']), AYearIndexValue);\r\n AppStorage.WriteInteger(AppStorage.ConcatPaths([Path, ItemName + IntToStr(Index), 'YearDay']), AYearDay);\r\n AppStorage.WriteInteger(AppStorage.ConcatPaths([Path, ItemName + IntToStr(Index), 'YearMonth']), AYearMonth);\r\n AppStorage.WriteInteger(AppStorage.ConcatPaths([Path, ItemName + IntToStr(Index), 'YearInterval']), AYearInterval);\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomScheduledEvents.DeleteSingleEvent(Sender: TJvCustomAppStorage; const Path: string;\r\n const List: TObject; const First, Last: Integer; const ItemName: string);\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := First to Last do\r\n Sender.DeleteSubTree(Sender.ConcatPaths([Path, ItemName + IntToStr(I)]));\r\nend;\r\n\r\nprocedure TJvCustomScheduledEvents.SaveEventStates;\r\nbegin\r\n if Assigned(AppStorage) then\r\n AppStorage.WriteList(AppStoragePath, FEvents, FEvents.Count, SaveSingleEvent, DeleteSingleEvent, cEventPrefix);\r\nend;\r\n\r\nprocedure TJvCustomScheduledEvents.StartAll;\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := 0 to FEvents.Count - 1 do\r\n if FEvents[I].State in [sesPaused, sesNotInitialized] then\r\n FEvents[I].Start;\r\nend;\r\n\r\nprocedure TJvCustomScheduledEvents.StopAll;\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := 0 to FEvents.Count - 1 do\r\n FEvents[I].Stop;\r\nend;\r\n\r\nprocedure TJvCustomScheduledEvents.PauseAll;\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := 0 to FEvents.Count - 1 do\r\n FEvents[I].Pause;\r\nend;\r\n\r\nprocedure TJvCustomScheduledEvents.SetEvents(Value: TJvEventCollection);\r\nbegin\r\n FEvents.Assign(Value);\r\nend;\r\n\r\nprocedure TJvCustomScheduledEvents.WndProc(var Msg: TMessage);\r\nvar\r\n List: TList;\r\n I: Integer;\r\nbegin\r\n with Msg do\r\n case Msg of\r\n CM_EXECEVENT:\r\n Dispatch(Msg);\r\n WM_TIMECHANGE:\r\n begin\r\n // Mantis 3355: Time has changed, mark all running schedules as\r\n // \"to be restarted\", stop and then restart them.\r\n List := TList.Create;\r\n try\r\n ScheduleThread.Lock;\r\n try\r\n for I := 0 to FEvents.Count - 1 do\r\n begin\r\n if FEvents[I].State in [sesTriggered, sesExecuting, sesPaused] then\r\n begin\r\n List.Add(FEvents[I]);\r\n FEvents[I].Stop;\r\n end;\r\n end;\r\n for I := 0 to List.Count - 1 do\r\n TJvEventCollectionItem(List[I]).Start;\r\n finally\r\n ScheduleThread.Unlock;\r\n end;\r\n finally\r\n List.Free;\r\n end;\r\n end;\r\n else\r\n Result := DefWindowProc(Handle, Msg, WParam, LParam);\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomScheduledEvents.PostEvent(Event: TJvEventCollectionItem);\r\nbegin\r\n ScheduleThread.Lock;\r\n try\r\n FPostedEvents.Add(Event);\r\n if not FEventsPosted then\r\n begin\r\n // Post one message for all posted events\r\n FEventsPosted := True;\r\n PostMessage(Handle, CM_EXECEVENT, 0, 0);\r\n end;\r\n finally\r\n ScheduleThread.Unlock;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomScheduledEvents.RemovePostedEvent(Event: TJvEventCollectionItem);\r\nbegin\r\n if not (csDestroying in ComponentState) and (GScheduleThread <> nil) then\r\n begin\r\n ScheduleThread.Lock;\r\n try\r\n Event.FState := sesEnded;\r\n while FPostedEvents.Remove(Event) <> -1 do\r\n ;\r\n finally\r\n ScheduleThread.Unlock;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomScheduledEvents.CMExecEvent(var Msg: TMessage);\r\nvar\r\n Event: TJvEventCollectionItem;\r\nbegin\r\n try\r\n ScheduleThread.Lock;\r\n try\r\n while FPostedEvents.Count > 0 do\r\n begin\r\n Event := FPostedEvents[0];\r\n FPostedEvents.Delete(0);\r\n\r\n ScheduleThread.Unlock; // the user code must not be protected by the critical section\r\n try\r\n try\r\n DoStartEvent(Event);\r\n Event.Execute;\r\n DoEndEvent(Event);\r\n except\r\n // proceed with the next event as if it were 2 messages\r\n if Assigned(ApplicationHandleException) then\r\n ApplicationHandleException(Self);\r\n end;\r\n finally\r\n ScheduleThread.Lock;\r\n end;\r\n end;\r\n finally\r\n FEventsPosted := False;\r\n ScheduleThread.Unlock;\r\n end;\r\n except\r\n if Assigned(ApplicationHandleException) then // don't let exceptions escape\r\n ApplicationHandleException(Self);\r\n end;\r\n Msg.Result := 1;\r\nend;\r\n\r\n//=== { TJvEventCollection } =================================================\r\n\r\nconstructor TJvEventCollection.Create(AOwner: TPersistent);\r\nbegin\r\n inherited Create(AOwner, TJvEventCollectionItem);\r\nend;\r\n\r\nfunction TJvEventCollection.GetItem(Index: Integer): TJvEventCollectionItem;\r\nbegin\r\n Result := TJvEventCollectionItem(inherited Items[Index]);\r\nend;\r\n\r\nprocedure TJvEventCollection.SetItem(Index: Integer; Value: TJvEventCollectionItem);\r\nbegin\r\n inherited Items[Index] := Value;\r\nend;\r\n\r\nfunction TJvEventCollection.Add: TJvEventCollectionItem;\r\nbegin\r\n Result := TJvEventCollectionItem(inherited Add);\r\nend;\r\n\r\nfunction TJvEventCollection.Insert(Index: Integer): TJvEventCollectionItem;\r\nbegin\r\n Result := TJvEventCollectionItem(inherited Insert(Index));\r\nend;\r\n\r\nprocedure TJvEventCollection.Notify(Item: TCollectionItem; Action: TCollectionNotification);\r\nbegin\r\n inherited Notify(Item, Action);\r\n if Action in [cnExtracting, cnDeleting] then\r\n (Owner as TJvCustomScheduledEvents).RemovePostedEvent(Item as TJvEventCollectionItem);\r\nend;\r\n\r\n//=== { TJvEventCollectionItem } =============================================\r\n\r\nconstructor TJvEventCollectionItem.Create(Collection: TCollection);\r\nvar\r\n NewName: string;\r\n I: Integer;\r\n J: Integer;\r\n\r\n function NewNameIsUnique: Boolean;\r\n begin\r\n with TJvEventCollection(Collection) do\r\n begin\r\n J := Count - 1;\r\n while (J >= 0) and not AnsiSameText(Items[J].Name, NewName + IntToStr(I)) do\r\n Dec(J);\r\n Result := J < 0;\r\n end;\r\n end;\r\n\r\n procedure CreateNewName;\r\n begin\r\n NewName := 'Event';\r\n I := 0;\r\n repeat\r\n Inc(I);\r\n until NewNameIsUnique;\r\n end;\r\n\r\nbegin\r\n ScheduleThread.Lock;\r\n try\r\n if csDesigning in TComponent(TJvEventCollection(Collection).GetOwner).ComponentState then\r\n CreateNewName\r\n else\r\n NewName := '';\r\n inherited Create(Collection);\r\n FSchedule := CreateSchedule;\r\n FSnoozeFire := NullStamp;\r\n FScheduleFire := NullStamp;\r\n if NewName <> '' then\r\n Name := NewName + IntToStr(I);\r\n finally\r\n ScheduleThread.Unlock;\r\n end;\r\nend;\r\n\r\ndestructor TJvEventCollectionItem.Destroy;\r\nbegin\r\n ScheduleThread.Lock;\r\n try\r\n Stop;\r\n inherited Destroy;\r\n finally\r\n ScheduleThread.Unlock;\r\n end;\r\nend;\r\n\r\nprocedure TJvEventCollectionItem.Assign(Source: TPersistent);\r\nbegin\r\n if Source is TJvEventCollectionItem then\r\n begin\r\n Name := TJvEventCollectionItem(Source).Name;\r\n CountMissedEvents := TJvEventCollectionItem(Source).CountMissedEvents;\r\n Schedule := TJvEventCollectionItem(Source).Schedule;\r\n OnExecute := TJvEventCollectionItem(Source).OnExecute;\r\n end\r\n else\r\n inherited Assign(Source);\r\nend;\r\n\r\nprocedure TJvEventCollectionItem.Triggered;\r\nbegin\r\n FState := sesTriggered;\r\nend;\r\n\r\nprocedure TJvEventCollectionItem.DefineProperties(Filer: TFiler);\r\nvar\r\n SingleShot: Boolean;\r\n DailySched: Boolean;\r\n WeeklySched: Boolean;\r\n MonthlySched: Boolean;\r\n YearlySched: Boolean;\r\n MIK: TScheduleIndexKind;\r\n YIK: TScheduleIndexKind;\r\nbegin\r\n // Determine settings to determine writing properties.\r\n SingleShot := Schedule.RecurringType = srkOneShot;\r\n DailySched := Schedule.RecurringType = srkDaily;\r\n WeeklySched := Schedule.RecurringType = srkWeekly;\r\n MonthlySched := Schedule.RecurringType = srkMonthly;\r\n YearlySched := Schedule.RecurringType = srkYearly;\r\n if MonthlySched then\r\n MIK := (Schedule as IJclMonthlySchedule).IndexKind\r\n else\r\n MIK := sikNone;\r\n if YearlySched then\r\n YIK := (Schedule as IJclYearlySchedule).IndexKind\r\n else\r\n YIK := sikNone;\r\n\r\n // Standard properties\r\n Filer.DefineProperty('StartDate', PropStartDateRead, PropStartDateWrite, True);\r\n Filer.DefineProperty('RecurringType', PropRecurringTypeRead, PropRecurringTypeWrite, not SingleShot);\r\n Filer.DefineProperty('EndType', PropEndTypeRead, PropEndTypeWrite, not SingleShot);\r\n Filer.DefineProperty('EndDate', PropEndDateRead, PropEndDateWrite, not SingleShot and\r\n (Schedule.EndType = sekDate));\r\n Filer.DefineProperty('EndCount', PropEndCountRead, PropEndCountWrite, not SingleShot and\r\n (Schedule.EndType in [sekTriggerCount, sekDayCount]));\r\n\r\n // Daily frequency properties\r\n Filer.DefineProperty('Freq_StartTime', PropFreqStartTimeRead, PropFreqStartTimeWrite,\r\n not SingleShot);\r\n Filer.DefineProperty('Freq_EndTime', PropFreqEndTimeRead, PropFreqEndTimeWrite, not SingleShot);\r\n Filer.DefineProperty('Freq_Interval', PropFreqIntervalRead, PropFreqIntervalWrite,\r\n not SingleShot);\r\n\r\n // Daily schedule properties\r\n Filer.DefineProperty('Daily_EveryWeekDay', PropDailyEveryWeekDayRead, PropDailyEveryWeekDayWrite,\r\n DailySched);\r\n Filer.DefineProperty('Daily_Interval', PropDailyIntervalRead, PropDailyIntervalWrite,\r\n DailySched and not (Schedule as IJclDailySchedule).EveryWeekDay);\r\n\r\n // Weekly schedule properties\r\n Filer.DefineProperty('Weekly_DaysOfWeek', PropWeeklyDaysOfWeekRead, PropWeeklyDaysOfWeekWrite,\r\n WeeklySched);\r\n Filer.DefineProperty('Weekly_Interval', PropWeeklyIntervalRead, PropWeeklyIntervalWrite,\r\n WeeklySched);\r\n\r\n // Monthly schedule properties\r\n Filer.DefineProperty('Monthly_IndexKind', PropMonthlyIndexKindRead, PropMonthlyIndexKindWrite,\r\n MonthlySched);\r\n Filer.DefineProperty('Monthly_IndexValue', PropMonthlyIndexValueRead, PropMonthlyIndexValueWrite,\r\n MonthlySched and (MIK in [sikDay..sikSunday]));\r\n Filer.DefineProperty('Monthly_Day', PropMonthlyDayRead, PropMonthlyDayWrite, MonthlySched and\r\n (MIK in [sikNone]));\r\n Filer.DefineProperty('Monthly_Interval', PropMonthlyIntervalRead, PropMonthlyIntervalWrite,\r\n MonthlySched);\r\n\r\n // Yearly schedule properties\r\n Filer.DefineProperty('Yearly_IndexKind', PropYearlyIndexKindRead, PropYearlyIndexKindWrite,\r\n YearlySched);\r\n Filer.DefineProperty('Yearly_IndexValue', PropYearlyIndexValueRead, PropYearlyIndexValueWrite,\r\n YearlySched and (YIK in [sikDay..sikSunday]));\r\n Filer.DefineProperty('Yearly_Day', PropYearlyDayRead, PropYearlyDayWrite, YearlySched and\r\n (YIK in [sikNone, sikDay]));\r\n Filer.DefineProperty('Yearly_Month', PropYearlyMonthRead, PropYearlyMonthWrite, YearlySched);\r\n Filer.DefineProperty('Yearly_Interval', PropYearlyIntervalRead, PropYearlyIntervalWrite,\r\n YearlySched);\r\nend;\r\n\r\nprocedure TJvEventCollectionItem.DoExecute(const IsSnoozeFire: Boolean);\r\nbegin\r\n if Assigned(FOnExecute) then\r\n FOnExecute(Self, IsSnoozeFire);\r\nend;\r\n\r\nfunction TJvEventCollectionItem.GetDisplayName: string;\r\nbegin\r\n Result := Name;\r\nend;\r\n\r\nfunction TJvEventCollectionItem.GetNextFire: TTimeStamp;\r\nbegin\r\n if IsNullTimeStamp(FSnoozeFire) or\r\n (not IsNullTimeStamp(FScheduleFire) and (CompareTimeStamps(FSnoozeFire, FScheduleFire) > 0)) then\r\n Result := FScheduleFire\r\n else\r\n Result := FSnoozeFire;\r\nend;\r\n\r\nprocedure TJvEventCollectionItem.Execute;\r\nvar\r\n IsSnoozeFire: Boolean;\r\nbegin\r\n if State <> sesTriggered then\r\n Exit; // Ignore this message, something is wrong.\r\n FActualTriggerTime := DateTimeToTimeStamp(Now);\r\n IsSnoozeFire := not IsNullTimeStamp(FSnoozeFire) and (CompareTimeStamps(FActualTriggerTime, FSnoozeFire) >= 0);\r\n if IsSnoozeFire and not IsNullTimeStamp(FScheduleFire) and (CompareTimeStamps(FActualTriggerTime, FScheduleFire) >= 0) then\r\n begin\r\n { We can't have both, the schedule will win (other possibility: generate two succesive events\r\n from this method, one as a snooze, the other as a schedule) }\r\n FSnoozeFire := NullStamp;\r\n IsSnoozeFire := False;\r\n end;\r\n FState := sesExecuting;\r\n try\r\n FReqTriggerTime := NextFire;\r\n if not IsSnoozeFire then\r\n FScheduleFire := Schedule.NextEventFromNow(CountMissedEvents);\r\n FSnoozeFire := NullStamp;\r\n DoExecute(IsSnoozeFire);\r\n finally\r\n if IsNullTimeStamp(NextFire) then\r\n FState := sesEnded\r\n else\r\n FState := sesWaiting;\r\n end;\r\nend;\r\n\r\nprocedure TJvEventCollectionItem.PropDateRead(Reader: TReader; var Stamp: TTimeStamp);\r\nvar\r\n Str: string;\r\n Y: Integer;\r\n M: Integer;\r\n D: Integer;\r\n H: Integer;\r\n Min: Integer;\r\n MSecs: Integer;\r\nbegin\r\n Str := Reader.ReadString;\r\n Y := StrToInt(Copy(Str, 1, 4));\r\n M := StrToInt(Copy(Str, 6, 2));\r\n D := StrToInt(Copy(Str, 9, 2));\r\n H := StrToInt(Copy(Str, 12, 2));\r\n Min := StrToInt(Copy(Str, 15, 2));\r\n MSecs := StrToInt(Copy(Str, 18, 2)) * 1000 + StrToInt(Copy(Str, 21, 3));\r\n\r\n Stamp := DateTimeToTimeStamp(EncodeDate(Y, M, D));\r\n Stamp.Time := H * 3600000 + Min * 60000 + MSecs;\r\nend;\r\n\r\nprocedure TJvEventCollectionItem.PropDateWrite(Writer: TWriter; const Stamp: TTimeStamp);\r\nvar\r\n TmpDate: TDateTime;\r\n Y: Word;\r\n M: Word;\r\n D: Word;\r\n MSecs: Integer;\r\nbegin\r\n TmpDate := TimeStampToDateTime(Stamp);\r\n DecodeDate(TmpDate, Y, M, D);\r\n MSecs := Stamp.Time;\r\n Writer.WriteString(Format('%.4d/%.2d/%.2d %.2d:%.2d:%.2d.%.3d',\r\n [Y, M, D, (MSecs div 3600000) mod 24, (MSecs div 60000) mod 60,\r\n (MSecs div 1000) mod 60, MSecs mod 1000]));\r\nend;\r\n\r\nprocedure TJvEventCollectionItem.PropDailyEveryWeekDayRead(Reader: TReader);\r\nbegin\r\n (Schedule as IJclDailySchedule).EveryWeekDay := Reader.ReadBoolean;\r\nend;\r\n\r\nprocedure TJvEventCollectionItem.PropDailyEveryWeekDayWrite(Writer: TWriter);\r\nbegin\r\n Writer.WriteBoolean((Schedule as IJclDailySchedule).EveryWeekDay);\r\nend;\r\n\r\nprocedure TJvEventCollectionItem.PropDailyIntervalRead(Reader: TReader);\r\nbegin\r\n (Schedule as IJclDailySchedule).Interval := Reader.ReadInteger;\r\nend;\r\n\r\nprocedure TJvEventCollectionItem.PropDailyIntervalWrite(Writer: TWriter);\r\nbegin\r\n Writer.WriteInteger((Schedule as IJclDailySchedule).Interval);\r\nend;\r\n\r\nprocedure TJvEventCollectionItem.PropEndCountRead(Reader: TReader);\r\nbegin\r\n Schedule.EndCount := Reader.ReadInteger;\r\nend;\r\n\r\nprocedure TJvEventCollectionItem.PropEndCountWrite(Writer: TWriter);\r\nbegin\r\n Writer.WriteInteger(Schedule.EndCount);\r\nend;\r\n\r\nprocedure TJvEventCollectionItem.PropEndDateRead(Reader: TReader);\r\nvar\r\n TmpStamp: TTimeStamp;\r\nbegin\r\n PropDateRead(Reader, TmpStamp);\r\n Schedule.EndDate := TmpStamp;\r\nend;\r\n\r\nprocedure TJvEventCollectionItem.PropEndDateWrite(Writer: TWriter);\r\nbegin\r\n PropDateWrite(Writer, Schedule.EndDate);\r\nend;\r\n\r\nprocedure TJvEventCollectionItem.PropEndTypeRead(Reader: TReader);\r\nbegin\r\n Schedule.EndType := TScheduleEndKind(GetEnumValue(TypeInfo(TScheduleEndKind), Reader.ReadIdent));\r\nend;\r\n\r\nprocedure TJvEventCollectionItem.PropEndTypeWrite(Writer: TWriter);\r\nbegin\r\n Writer.WriteIdent(GetEnumName(TypeInfo(TScheduleEndKind), Ord(Schedule.EndType)));\r\nend;\r\n\r\nprocedure TJvEventCollectionItem.PropFreqEndTimeRead(Reader: TReader);\r\nbegin\r\n (Schedule as IJclScheduleDayFrequency).EndTime := Reader.ReadInteger;\r\nend;\r\n\r\nprocedure TJvEventCollectionItem.PropFreqEndTimeWrite(Writer: TWriter);\r\nbegin\r\n Writer.WriteInteger((Schedule as IJclScheduleDayFrequency).EndTime);\r\nend;\r\n\r\nprocedure TJvEventCollectionItem.PropFreqIntervalRead(Reader: TReader);\r\nbegin\r\n (Schedule as IJclScheduleDayFrequency).Interval := Reader.ReadInteger;\r\nend;\r\n\r\nprocedure TJvEventCollectionItem.PropFreqIntervalWrite(Writer: TWriter);\r\nbegin\r\n Writer.WriteInteger((Schedule as IJclScheduleDayFrequency).Interval);\r\nend;\r\n\r\nprocedure TJvEventCollectionItem.PropFreqStartTimeRead(Reader: TReader);\r\nbegin\r\n (Schedule as IJclScheduleDayFrequency).StartTime := Reader.ReadInteger;\r\nend;\r\n\r\nprocedure TJvEventCollectionItem.PropFreqStartTimeWrite(Writer: TWriter);\r\nbegin\r\n Writer.WriteInteger((Schedule as IJclScheduleDayFrequency).StartTime);\r\nend;\r\n\r\nprocedure TJvEventCollectionItem.PropMonthlyDayRead(Reader: TReader);\r\nbegin\r\n (Schedule as IJclMonthlySchedule).Day := Reader.ReadInteger;\r\nend;\r\n\r\nprocedure TJvEventCollectionItem.PropMonthlyDayWrite(Writer: TWriter);\r\nbegin\r\n Writer.WriteInteger((Schedule as IJclMonthlySchedule).Day);\r\nend;\r\n\r\nprocedure TJvEventCollectionItem.PropMonthlyIndexKindRead(Reader: TReader);\r\nbegin\r\n (Schedule as IJclMonthlySchedule).IndexKind :=\r\n TScheduleIndexKind(GetEnumValue(TypeInfo(TScheduleIndexKind), Reader.ReadIdent));\r\nend;\r\n\r\nprocedure TJvEventCollectionItem.PropMonthlyIndexKindWrite(Writer: TWriter);\r\nbegin\r\n Writer.WriteIdent(GetEnumName(TypeInfo(TScheduleIndexKind),\r\n Ord((Schedule as IJclMonthlySchedule).IndexKind)));\r\nend;\r\n\r\nprocedure TJvEventCollectionItem.PropMonthlyIndexValueRead(Reader: TReader);\r\nbegin\r\n (Schedule as IJclMonthlySchedule).IndexValue := Reader.ReadInteger;\r\nend;\r\n\r\nprocedure TJvEventCollectionItem.PropMonthlyIndexValueWrite(Writer: TWriter);\r\nbegin\r\n Writer.WriteInteger((Schedule as IJclMonthlySchedule).IndexValue);\r\nend;\r\n\r\nprocedure TJvEventCollectionItem.PropMonthlyIntervalRead(Reader: TReader);\r\nbegin\r\n (Schedule as IJclMonthlySchedule).Interval := Reader.ReadInteger;\r\nend;\r\n\r\nprocedure TJvEventCollectionItem.PropMonthlyIntervalWrite(Writer: TWriter);\r\nbegin\r\n Writer.WriteInteger((Schedule as IJclMonthlySchedule).Interval);\r\nend;\r\n\r\nprocedure TJvEventCollectionItem.PropRecurringTypeRead(Reader: TReader);\r\nbegin\r\n Schedule.RecurringType :=\r\n TScheduleRecurringKind(GetEnumValue(TypeInfo(TScheduleRecurringKind), Reader.ReadIdent));\r\nend;\r\n\r\nprocedure TJvEventCollectionItem.PropRecurringTypeWrite(Writer: TWriter);\r\nbegin\r\n Writer.WriteIdent(GetEnumName(TypeInfo(TScheduleRecurringKind), Ord(Schedule.RecurringType)));\r\nend;\r\n\r\nprocedure TJvEventCollectionItem.PropStartDateRead(Reader: TReader);\r\nvar\r\n TmpStamp: TTimeStamp;\r\nbegin\r\n PropDateRead(Reader, TmpStamp);\r\n Schedule.StartDate := TmpStamp;\r\nend;\r\n\r\nprocedure TJvEventCollectionItem.PropStartDateWrite(Writer: TWriter);\r\nbegin\r\n PropDateWrite(Writer, Schedule.StartDate);\r\nend;\r\n\r\nprocedure TJvEventCollectionItem.PropWeeklyDaysOfWeekRead(Reader: TReader);\r\nvar\r\n TempVal: TScheduleWeekDays;\r\nbegin\r\n JclIntToSet(TypeInfo(TScheduleWeekDays), TempVal,\r\n TReaderAccessProtected(Reader).ReadSet(TypeInfo(TScheduleWeekDays)));\r\n (Schedule as IJclWeeklySchedule).DaysOfWeek := TempVal;\r\nend;\r\n\r\nprocedure TJvEventCollectionItem.PropWeeklyDaysOfWeekWrite(Writer: TWriter);\r\nvar\r\n TempVar: TScheduleWeekDays;\r\nbegin\r\n TempVar := (Schedule as IJclWeeklySchedule).DaysOfWeek;\r\n THackWriter(Writer).WriteSet(TypeInfo(TScheduleWeekDays),\r\n JclSetToInt(TypeInfo(TScheduleWeekDays), TempVar));\r\nend;\r\n\r\nprocedure TJvEventCollectionItem.PropWeeklyIntervalRead(Reader: TReader);\r\nbegin\r\n (Schedule as IJclWeeklySchedule).Interval := Reader.ReadInteger;\r\nend;\r\n\r\nprocedure TJvEventCollectionItem.PropWeeklyIntervalWrite(Writer: TWriter);\r\nbegin\r\n Writer.WriteInteger((Schedule as IJclWeeklySchedule).Interval);\r\nend;\r\n\r\nprocedure TJvEventCollectionItem.PropYearlyDayRead(Reader: TReader);\r\nbegin\r\n (Schedule as IJclYearlySchedule).Day := Reader.ReadInteger;\r\nend;\r\n\r\nprocedure TJvEventCollectionItem.PropYearlyDayWrite(Writer: TWriter);\r\nbegin\r\n Writer.WriteInteger((Schedule as IJclYearlySchedule).Day);\r\nend;\r\n\r\nprocedure TJvEventCollectionItem.PropYearlyIndexKindRead(Reader: TReader);\r\nbegin\r\n (Schedule as IJclYearlySchedule).IndexKind :=\r\n TScheduleIndexKind(GetEnumValue(TypeInfo(TScheduleIndexKind), Reader.ReadIdent));\r\nend;\r\n\r\nprocedure TJvEventCollectionItem.PropYearlyIndexKindWrite(Writer: TWriter);\r\nbegin\r\n Writer.WriteIdent(GetEnumName(TypeInfo(TScheduleIndexKind),\r\n Ord((Schedule as IJclYearlySchedule).IndexKind)));\r\nend;\r\n\r\nprocedure TJvEventCollectionItem.PropYearlyIndexValueRead(Reader: TReader);\r\nbegin\r\n (Schedule as IJclYearlySchedule).IndexValue := Reader.ReadInteger;\r\nend;\r\n\r\nprocedure TJvEventCollectionItem.PropYearlyIndexValueWrite(Writer: TWriter);\r\nbegin\r\n Writer.WriteInteger((Schedule as IJclYearlySchedule).IndexValue);\r\nend;\r\n\r\nprocedure TJvEventCollectionItem.PropYearlyIntervalRead(Reader: TReader);\r\nbegin\r\n (Schedule as IJclYearlySchedule).Interval := Reader.ReadInteger;\r\nend;\r\n\r\nprocedure TJvEventCollectionItem.PropYearlyIntervalWrite(Writer: TWriter);\r\nbegin\r\n Writer.WriteInteger((Schedule as IJclYearlySchedule).Interval);\r\nend;\r\n\r\nprocedure TJvEventCollectionItem.PropYearlyMonthRead(Reader: TReader);\r\nbegin\r\n (Schedule as IJclYearlySchedule).Month := Reader.ReadInteger;\r\nend;\r\n\r\nprocedure TJvEventCollectionItem.PropYearlyMonthWrite(Writer: TWriter);\r\nbegin\r\n Writer.WriteInteger((Schedule as IJclYearlySchedule).Month);\r\nend;\r\n\r\nprocedure TJvEventCollectionItem.SetName(Value: string);\r\nbegin\r\n if FName <> Value then\r\n begin\r\n FName := Value;\r\n Changed(False);\r\n end;\r\nend;\r\n\r\nprocedure TJvEventCollectionItem.LoadState(const TriggerStamp: TTimeStamp; const TriggerCount, DayCount: Integer;\r\n const SnoozeStamp: TTimeStamp; const ALastSnoozeInterval: TSystemTime; const AEventInfo: TScheduledEventStateInfo);\r\nvar\r\n IDayFrequency: IJclScheduleDayFrequency;\r\n IDay: IJclDailySchedule;\r\n IWeek: IJclWeeklySchedule;\r\n IMonth: IJclMonthlySchedule;\r\n IYear: IJclYearlySchedule;\r\nbegin\r\n with AEventInfo do\r\n begin\r\n Schedule.RecurringType:=ARecurringType;\r\n if ARecurringType<>srkOneShot then\r\n begin\r\n IDayFrequency := Schedule as IJclScheduleDayFrequency;\r\n with AEventInfo.DayFrequence do\r\n begin\r\n IDayFrequency.StartTime :=ADayFrequencyStartTime;\r\n IDayFrequency.EndTime := ADayFrequencyEndTime;\r\n IDayFrequency.Interval := ADayFrequencyInterval;\r\n end;\r\n end;\r\n case ARecurringType of\r\n srkOneShot:\r\n begin\r\n end;\r\n srkDaily:\r\n begin\r\n {IJclDailySchedule}\r\n IDay := Schedule as IJclDailySchedule;\r\n with AEventInfo.Daily do\r\n begin\r\n IDay.EveryWeekDay := ADayEveryWeekDay;\r\n if not ADayEveryWeekDay then\r\n IDay.Interval := ADayInterval;\r\n end;\r\n end;\r\n srkWeekly:\r\n begin\r\n {IJclWeeklySchedule}\r\n IWeek := Schedule as IJclWeeklySchedule;\r\n with AEventInfo.Weekly do\r\n begin\r\n IWeek.DaysOfWeek := AWeekDaysOfWeek;\r\n IWeek.Interval := AWeekInterval;\r\n end;\r\n end;\r\n srkMonthly:\r\n begin\r\n {IJclMonthlySchedule}\r\n IMonth := Schedule as IJclMonthlySchedule;\r\n with AEventInfo.Monthly do\r\n begin\r\n IMonth.IndexKind := AMonthIndexKind;\r\n if AMonthIndexKind <> sikNone then\r\n IMonth.IndexValue := AMonthIndexValue;\r\n if AMonthIndexKind = sikNone then\r\n IMonth.Day := AMonthDay;\r\n IMonth.Interval := AMonthInterval;\r\n end;\r\n end;\r\n srkYearly:\r\n begin\r\n {IJclYearlySchedule}\r\n IYear := Schedule as IJclYearlySchedule;\r\n with AEventInfo.Yearly do\r\n begin\r\n IYear.IndexKind := AYearIndexKind;\r\n if AYearIndexKind <> sikNone then\r\n IYear.IndexValue := AYearIndexValue\r\n else\r\n IYear.Day := AYearDay;\r\n IYear.Month := AYearMonth;\r\n IYear.Interval := AYearInterval;\r\n end;\r\n end;\r\n end;\r\n Schedule.InitToSavedState(TriggerStamp, TriggerCount, DayCount);\r\n FScheduleFire := TriggerStamp;\r\n FSnoozeFire := SnoozeStamp;\r\n FLastSnoozeInterval := ALastSnoozeInterval;\r\n if IsNullTimeStamp(NextFire) or\r\n (CompareTimeStamps(NextFire, DateTimeToTimeStamp(Now)) < 0) then\r\n Schedule.NextEventFromNow(CountMissedEvents);\r\n if IsNullTimeStamp(NextFire) then\r\n FState := sesEnded\r\n else\r\n FState := sesWaiting;\r\n end;\r\nend;\r\n\r\nprocedure TJvEventCollectionItem.Pause;\r\nbegin\r\n if FState = sesWaiting then\r\n FState := sesPaused;\r\nend;\r\n\r\nprocedure TJvEventCollectionItem.SaveState(out TriggerStamp: TTimeStamp; out TriggerCount, DayCount: Integer;\r\n out SnoozeStamp: TTimeStamp; out ALastSnoozeInterval: TSystemTime;\r\n out AEventInfo: TScheduledEventStateInfo);\r\nvar\r\n IDayFrequency: IJclScheduleDayFrequency;\r\n IDay: IJclDailySchedule;\r\n IWeek: IJclWeeklySchedule;\r\n IMonth: IJclMonthlySchedule;\r\n IYear: IJclYearlySchedule;\r\nbegin\r\n {Common properties}\r\n with AEventInfo do\r\n begin\r\n AEndType := FSchedule.EndType;\r\n AEndDate := FSchedule.EndDate;\r\n AEndCount := FSchedule.EndCount;\r\n ALastTriggered := Fschedule.LastTriggered;\r\n AStartDate := FSchedule.StartDate;\r\n ARecurringType := FSchedule.RecurringType;\r\n {IJclScheduleDayFrequency}\r\n if ARecurringType<>srkOneShot then\r\n begin\r\n IDayFrequency := FSchedule as IJclScheduleDayFrequency;\r\n with AEventInfo.DayFrequence do\r\n begin\r\n ADayFrequencyStartTime := IDayFrequency.StartTime;\r\n ADayFrequencyEndTime := IDayFrequency.EndTime;\r\n ADayFrequencyInterval := IDayFrequency.Interval;\r\n end;\r\n end;\r\n case ARecurringType of\r\n srkOneShot:\r\n begin\r\n end;\r\n srkDaily:\r\n begin\r\n {IJclDailySchedule}\r\n IDay := FSchedule as IJclDailySchedule;\r\n with AEventInfo.Daily do\r\n begin\r\n ADayInterval := IDay.Interval;\r\n ADayEveryWeekDay := IDay.EveryWeekDay;\r\n end;\r\n end;\r\n srkWeekly:\r\n begin\r\n {IJclWeeklySchedule}\r\n IWeek := FSchedule as IJclWeeklySchedule;\r\n with AEventInfo.Weekly do\r\n begin\r\n AWeekInterval := IWeek.Interval;\r\n AWeekDaysOfWeek := IWeek.DaysOfWeek;\r\n end;\r\n end;\r\n srkMonthly:\r\n begin\r\n {IJclMonthlySchedule}\r\n IMonth := FSchedule as IJclMonthlySchedule;\r\n with AEventInfo.Monthly do\r\n begin\r\n AMonthIndexKind := IMonth.IndexKind;\r\n if AMonthIndexKind <> sikNone then\r\n AMonthIndexValue := IMonth.IndexValue;\r\n AMonthDay := IMonth.Day;\r\n AMonthInterval := IMonth.Interval;\r\n end;\r\n end;\r\n srkYearly:\r\n begin\r\n {IJclYearlySchedule}\r\n IYear := FSchedule as IJclYearlySchedule;\r\n with AEventInfo.Yearly do\r\n begin\r\n AYearIndexKind := IYear.IndexKind;\r\n if AYearIndexKind <> sikNone then\r\n AYearIndexValue := IYear.IndexValue;\r\n AYearDay := IYear.Day;\r\n AYearMonth := IYear.Month;\r\n AYearInterval := IYear.Interval;\r\n end;\r\n end;\r\n end;\r\n {Old part}\r\n TriggerStamp := FScheduleFire;\r\n TriggerCount := Schedule.TriggerCount;\r\n DayCount := Schedule.DayCount;\r\n SnoozeStamp := FSnoozeFire;\r\n ALastSnoozeInterval := LastSnoozeInterval;\r\n end;\r\nend;\r\n\r\nprocedure TJvEventCollectionItem.Snooze(const MSecs: Word; const Secs: Word = 0;\r\n const Mins: Word = 0; const Hrs: Word = 0; const Days: Word = 0);\r\nvar\r\n IntervalMSecs: Integer;\r\n SnoozeStamp: TTimeStamp;\r\nbegin\r\n // Update last snooze interval\r\n FLastSnoozeInterval.wDay := Days;\r\n FLastSnoozeInterval.wHour := Hrs;\r\n FLastSnoozeInterval.wMinute := Mins;\r\n FLastSnoozeInterval.wSecond := Secs;\r\n FLastSnoozeInterval.wMilliseconds := MSecs;\r\n // Calculate next event\r\n IntervalMSecs := MSecs + 1000 * (Secs + 60 * Mins + 1440 * Hrs);\r\n SnoozeStamp := DateTimeToTimeStamp(Now);\r\n SnoozeStamp.Time := SnoozeStamp.Time + IntervalMSecs;\r\n if SnoozeStamp.Time >= HoursToMSecs(24) then\r\n begin\r\n SnoozeStamp.Date := SnoozeStamp.Date + (SnoozeStamp.Time div HoursToMSecs(24));\r\n SnoozeStamp.Time := SnoozeStamp.Time mod HoursToMSecs(24);\r\n end;\r\n Inc(SnoozeStamp.Date, Days);\r\n FSnoozeFire := SnoozeStamp;\r\nend;\r\n\r\nprocedure TJvEventCollectionItem.Start;\r\nbegin\r\n if FState in [sesTriggered, sesExecuting] then\r\n raise EJVCLException.CreateRes(@RsECannotRestart);\r\n if State = sesPaused then\r\n begin\r\n FScheduleFire := Schedule.NextEventFromNow(CountMissedEvents);\r\n if IsNullTimeStamp(NextFire) then\r\n FState := sesEnded\r\n else\r\n FState := sesWaiting;\r\n end\r\n else\r\n begin\r\n FState := sesNotInitialized;\r\n Schedule.Reset;\r\n FScheduleFire := Schedule.NextEventFromNow(CountMissedEvents);\r\n if IsNullTimeStamp(NextFire) then\r\n FState := sesEnded\r\n else\r\n FState := sesWaiting;\r\n end;\r\nend;\r\n\r\nprocedure TJvEventCollectionItem.Stop;\r\nbegin\r\n if State <> sesNotInitialized then\r\n FState := sesNotInitialized;\r\nend;\r\n\r\n(*\r\nprocedure TJvEventCollectionItem.LoadFromStreamBin(const S: TStream);\r\nbegin\r\n ScheduledEventStore_Stream(S, True, False).LoadSchedule(Self);\r\nend;\r\n\r\nprocedure TJvEventCollectionItem.SaveToStreamBin(const S: TStream);\r\nbegin\r\n ScheduledEventStore_Stream(S, True, False).SaveSchedule(Self);\r\nend;\r\n*)\r\n\r\ninitialization\r\n {$IFDEF UNITVERSIONING}\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n {$ENDIF UNITVERSIONING}\r\n\r\nfinalization\r\n {$IFNDEF SUPPORTS_CLASS_CTORDTORS}\r\n FinalizeScheduleThread;\r\n {$ENDIF ~SUPPORTS_CLASS_CTORDTORS}\r\n {$IFDEF UNITVERSIONING}\r\n UnregisterUnitVersion(HInstance);\r\n {$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n\r\n" }, { "path": "External/Jedi/Jvcl/run/JvScreenResolution.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvScreenResolution.PAS, released on 2001-02-28.\r\n\r\nThe Initial Developer of the Original Code is Sbastien Buysse [sbuysse att buypin dott com]\r\nPortions created by Sbastien Buysse are Copyright (C) 2001 Sbastien Buysse.\r\nAll Rights Reserved.\r\n\r\nContributor(s): Michael Beck [mbeck att bigfoot dott com].\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvScreenResolution.pas 12461 2009-08-14 17:21:33Z obones $\r\n\r\nunit JvScreenResolution;\r\n\r\n{$I jvcl.inc}\r\n{$I windowsonly.inc}\r\n\r\ninterface\r\n\r\n// (rom) definitely JCL or Archive\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n {$IFDEF MSWINDOWS}\r\n Windows,\r\n {$ENDIF MSWINDOWS}\r\n SysUtils;\r\n\r\ntype\r\n TJvScreenResolution = class(TObject)\r\n private\r\n FCount: Integer;\r\n function GetCount: Integer;\r\n function GetMode(Index: Integer): TDevMode;\r\n public\r\n procedure GetSupportedModes(var Modes: array of TDevMode; var Count: Integer);\r\n function SetMode(Value: TDevMode): Boolean;\r\n // simpler access to DevModes\r\n property Modes[Index: Integer]: TDevMode read GetMode;\r\n property Count: Integer read GetCount;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvScreenResolution.pas $';\r\n Revision: '$Revision: 12461 $';\r\n Date: '$Date: 2009-08-14 19:21:33 +0200 (ven. 14 août 2009) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n RTLConsts,\r\n JvTypes;\r\n\r\nfunction TJvScreenResolution.GetCount: Integer;\r\nvar\r\n DevMode: TDevMode;\r\nbegin\r\n if FCount = 0 then\r\n while EnumDisplaySettings(nil, FCount, DevMode) do\r\n Inc(FCount);\r\n Result := FCount;\r\nend;\r\n\r\nfunction TJvScreenResolution.GetMode(Index: Integer): TDevMode;\r\nbegin\r\n if (Index < 0) or (Index >= Count) then\r\n raise EJVCLException.CreateResFmt(@SListIndexError, [Index]);\r\n EnumDisplaySettings(nil, Index, Result);\r\nend;\r\n\r\nprocedure TJvScreenResolution.GetSupportedModes(var Modes: array of TDevMode;\r\n var Count: Integer);\r\nvar\r\n I: Integer;\r\n DevMode: TDevMode;\r\nbegin\r\n I := 0;\r\n while EnumDisplaySettings(nil, I, DevMode) do\r\n Inc(I);\r\n Count := I;\r\n for I := 0 to Count - 1 do\r\n EnumDisplaySettings(nil, I, Modes[I]);\r\nend;\r\n\r\nfunction TJvScreenResolution.SetMode(Value: TDevMode): Boolean;\r\nbegin\r\n Value.dmFields := DM_BITSPERPEL or DM_PELSWIDTH or DM_PELSHEIGHT or DM_DISPLAYFLAGS;\r\n Result := ChangeDisplaySettings(Value, 0) = DISP_CHANGE_SUCCESSFUL;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvScreenSaveSuppress.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvAppCommand.PAS, released on 2005-09-02.\r\n\r\nThe Initial Developer of the Original Code is Robert Marquardt [robert_marquardt att dmx dott de]\r\nPortions created by Robert Marquardt are Copyright (C) 2001 Robert Marquardt.\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvScreenSaveSuppress.pas 13104 2011-09-07 06:50:43Z obones $\r\n\r\nunit JvScreenSaveSuppress;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, Messages, SysUtils, Classes, Controls, Forms,\r\n JvComponentBase;\r\n\r\nconst\r\n // from JwaWinUser.pas\r\n SC_SCREENSAVE = $F140;\r\n {$EXTERNALSYM SC_SCREENSAVE}\r\n\r\ntype\r\n TJvScreenSaveEvent = procedure(var Handled: Boolean) of object;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvScreenSaveSuppressor = class(TJvComponent)\r\n private\r\n FActive: Boolean;\r\n FOnScreenSave: TJvScreenSaveEvent;\r\n FForm: TCustomForm;\r\n function NewWndProc(var Msg: TMessage): Boolean;\r\n procedure SetActive(Value: Boolean);\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n published\r\n property Active: Boolean read FActive write SetActive default True;\r\n property OnScreenSave: TJvScreenSaveEvent read FOnScreenSave write FOnScreenSave;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvScreenSaveSuppress.pas $';\r\n Revision: '$Revision: 13104 $';\r\n Date: '$Date: 2011-09-07 08:50:43 +0200 (mer. 07 sept. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n JvWndProcHook;\r\n\r\nconstructor TJvScreenSaveSuppressor.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FForm := GetParentForm(TControl(AOwner));\r\n Active := True;\r\nend;\r\n\r\ndestructor TJvScreenSaveSuppressor.Destroy;\r\nbegin\r\n Active := False;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvScreenSaveSuppressor.SetActive(Value: Boolean);\r\nbegin\r\n if FActive <> Value then\r\n begin\r\n FActive := Value;\r\n if (FForm <> nil) and not (csDesigning in ComponentState) then\r\n if Value then\r\n RegisterWndProcHook(FForm, NewWndProc, hoBeforeMsg)\r\n else\r\n UnregisterWndProcHook(FForm, NewWndProc, hoBeforeMsg);\r\n end;\r\nend;\r\n\r\nfunction TJvScreenSaveSuppressor.NewWndProc(var Msg: TMessage): Boolean;\r\nbegin\r\n Result := False;\r\n if (Msg.Msg = WM_SYSCOMMAND) and (Msg.WParam = SC_SCREENSAVE) and Active then\r\n begin\r\n Result := True;\r\n if Assigned(FOnScreenSave) then\r\n FOnScreenSave(Result);\r\n Msg.Result := Ord(Result);\r\n end;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvScreenSaver.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvScreenSaver.PAS, released on 2001-02-28.\r\n\r\nThe Initial Developer of the Original Code is Sbastien Buysse [sbuysse att buypin dott com]\r\nPortions created by Sbastien Buysse are Copyright (C) 2001 Sbastien Buysse.\r\nAll Rights Reserved.\r\n\r\nContributor(s): Michael Beck [mbeck att bigfoot dott com].\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvScreenSaver.pas 13104 2011-09-07 06:50:43Z obones $\r\n\r\nunit JvScreenSaver;\r\n\r\n{$I jvcl.inc}\r\n{$I windowsonly.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, SysUtils, Classes,\r\n JvTypes, JvComponentBase;\r\n\r\ntype\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvScreenSaver = class(TJvComponent)\r\n private\r\n FOnStart: TNotifyEvent;\r\n FOnConfigure: TNotifyEvent;\r\n FOnPreview: TJvParentEvent;\r\n FOnPasswordChange: TJvParentEvent;\r\n public\r\n procedure Loaded; override;\r\n published\r\n property OnConfigure: TNotifyEvent read FOnConfigure write FOnConfigure;\r\n property OnPreview: TJvParentEvent read FOnPreview write FOnPreview;\r\n property OnStart: TNotifyEvent read FOnStart write FOnStart;\r\n property OnPasswordChange: TJvParentEvent read FOnPasswordChange write FOnPasswordChange;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvScreenSaver.pas $';\r\n Revision: '$Revision: 13104 $';\r\n Date: '$Date: 2011-09-07 08:50:43 +0200 (mer. 07 sept. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nprocedure TJvScreenSaver.Loaded;\r\ntype\r\n TScreenSaverStyle = (ssConfigure, ssPassword, ssPreview, ssStart);\r\nvar\r\n S: string;\r\n Style: TScreenSaverStyle;\r\n H: THandle;\r\nbegin\r\n inherited Loaded;\r\n Style := ssConfigure;\r\n if ParamCount <> 0 then\r\n begin\r\n S := UpperCase(ParamStr(1));\r\n if S = 'C' then\r\n Style := ssConfigure\r\n else\r\n if S = 'A' then\r\n Style := ssPassword\r\n else\r\n if S = 'P' then\r\n Style := ssPreview\r\n else\r\n Style := ssStart;\r\n end;\r\n\r\n if Style in [ssPassword, ssPreview] then\r\n H := StrToInt(ParamStr(2))\r\n else\r\n H := 0;\r\n case Style of\r\n ssConfigure:\r\n if Assigned(FOnConfigure) then\r\n FOnConfigure(Self);\r\n ssPassword:\r\n if Assigned(FOnPasswordChange) then\r\n FOnPasswordChange(Self, H);\r\n ssPreview:\r\n if Assigned(FOnPreview) then\r\n FOnPreview(Self, H);\r\n ssStart:\r\n if Assigned(FOnStart) then\r\n FOnStart(Self);\r\n end;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvScrollBar.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvScrollBar.PAS, released on 2001-02-28.\r\n\r\nThe Initial Developer of the Original Code is Sbastien Buysse [sbuysse att buypin dott com]\r\nPortions created by Sbastien Buysse are Copyright (C) 2001 Sbastien Buysse.\r\nAll Rights Reserved.\r\n\r\nContributor(s): Michael Beck [mbeck att bigfoot dott com].\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvScrollBar.pas 13104 2011-09-07 06:50:43Z obones $\r\n\r\nunit JvScrollBar;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n SysUtils, Classes, Graphics, Controls, Forms, StdCtrls,\r\n JvExStdCtrls;\r\n\r\ntype\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvScrollBar = class(TJvExScrollBar)\r\n private\r\n FHotTrack: Boolean;\r\n procedure SetHotTrack(Value: Boolean);\r\n protected\r\n procedure MouseEnter(Control: TControl); override;\r\n procedure MouseLeave(Control: TControl); override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n published\r\n property HotTrack: Boolean read FHotTrack write SetHotTrack default False;\r\n property HintColor;\r\n property OnMouseEnter;\r\n property OnMouseLeave;\r\n property OnParentColorChange;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvScrollBar.pas $';\r\n Revision: '$Revision: 13104 $';\r\n Date: '$Date: 2011-09-07 08:50:43 +0200 (mer. 07 sept. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\n\r\nconstructor TJvScrollBar.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FHotTrack := False;\r\n // ControlStyle := ControlStyle + [csAcceptsControls];\r\nend;\r\n\r\nprocedure TJvScrollBar.MouseEnter(Control: TControl);\r\nbegin\r\n if csDesigning in ComponentState then\r\n Exit;\r\n if not MouseOver then\r\n begin\r\n if HotTrack then\r\n Ctl3D := True;\r\n inherited MouseEnter(Control);\r\n end;\r\nend;\r\n\r\nprocedure TJvScrollBar.MouseLeave(Control: TControl);\r\nbegin\r\n if MouseOver then\r\n begin\r\n if HotTrack then\r\n Ctl3D := False;\r\n inherited MouseLeave(Control);\r\n end;\r\nend;\r\n\r\nprocedure TJvScrollBar.SetHotTrack(Value: Boolean);\r\nbegin\r\n FHotTrack := Value;\r\n if FHotTrack then\r\n Ctl3D := False;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvScrollBox.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvScrollBox.PAS, released on 2001-02-28.\r\n\r\nThe Initial Developer of the Original Code is Sbastien Buysse [sbuysse att buypin dott com]\r\nPortions created by Sbastien Buysse are Copyright (C) 2001 Sbastien Buysse.\r\nAll Rights Reserved.\r\n\r\nContributor(s): Michael Beck [mbeck att bigfoot dott com].\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvScrollBox.pas 13155 2011-11-06 12:31:20Z ahuser $\r\n\r\nunit JvScrollBox;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,\r\n JvExControls, JvExForms, JvJVCLUtils;\r\n\r\ntype\r\n TEraseBackgroundEvent = procedure(Sender: TObject; Canvas: TCanvas; var Result: Boolean) of object;\r\n\r\n TJvScrollBoxFillMode = (sfmTile, sfmStretch, sfmNone);\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvScrollBox = class(TJvExScrollBox)\r\n private\r\n FHotTrack: Boolean;\r\n FOnHorizontalScroll: TNotifyEvent;\r\n FOnVerticalScroll: TNotifyEvent;\r\n FOnPaint: TNotifyEvent;\r\n FCanvas: TCanvas;\r\n FOnEraseBackground: TEraseBackgroundEvent;\r\n FBackground: TJvPicture;\r\n FBackgroundFillMode: TJvScrollBoxFillMode;\r\n FLockRefreshCount : Integer;\r\n\r\n procedure SetHotTrack(const Value: Boolean);\r\n procedure WMHScroll(var Msg: TWMHScroll); message WM_HSCROLL;\r\n procedure WMVScroll(var Msg: TWMVScroll); message WM_VSCROLL;\r\n procedure WMPaint(var Msg: TWMPaint); message WM_PAINT;\r\n procedure SetBackground(const Value: TPicture);\r\n procedure SetBackgroundFillMode(const Value: TJvScrollBoxFillMode);\r\n function GetBackground: TPicture;\r\n protected\r\n procedure GetDlgCode(var Code: TDlgCodes); override;\r\n procedure MouseEnter(Control: TControl); override;\r\n procedure MouseLeave(Control: TControl); override;\r\n procedure WndProc(var Msg: TMessage); override;\r\n procedure KeyDown(var Key: Word; Shift: TShiftState); override;\r\n procedure PaintWindow(DC: HDC); override;\r\n procedure Paint; virtual;\r\n function DoEraseBackground(Canvas: TCanvas; Param: LPARAM): Boolean; override;\r\n procedure PaintBackground;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n\r\n procedure BeginUpdate;\r\n procedure EndUpdate;\r\n\r\n property Canvas: TCanvas read FCanvas;\r\n published\r\n property Background: TPicture read GetBackground write SetBackground;\r\n property BackgroundFillMode: TJvScrollBoxFillMode read FBackgroundFillMode write SetBackgroundFillMode default sfmTile;\r\n property HotTrack: Boolean read FHotTrack write SetHotTrack default False;\r\n property HintColor;\r\n property OnMouseEnter;\r\n property OnMouseLeave;\r\n property OnParentColorChange;\r\n property OnVerticalScroll: TNotifyEvent read FOnVerticalScroll write FOnVerticalScroll;\r\n property OnHorizontalScroll: TNotifyEvent read FOnHorizontalScroll write FOnHorizontalScroll;\r\n property OnKeyDown;\r\n property OnKeyPress;\r\n property OnKeyUp;\r\n property TabStop;\r\n property OnPaint: TNotifyEvent read FOnPaint write FOnPaint;\r\n property OnEraseBackground: TEraseBackgroundEvent read FOnEraseBackground write FOnEraseBackground;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvScrollBox.pas $';\r\n Revision: '$Revision: 13155 $';\r\n Date: '$Date: 2011-11-06 13:31:20 +0100 (dim. 06 nov. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n JvThemes;\r\n\r\nconstructor TJvScrollBox.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FHotTrack := False;\r\n ControlStyle := ControlStyle + [csAcceptsControls];\r\n IncludeThemeStyle(Self, [csNeedsBorderPaint]);\r\n FCanvas := TControlCanvas.Create;\r\n TControlCanvas(FCanvas).Control := Self;\r\n\r\n // We use a TJvPicture to allow silent migration from TJvgScrollBox\r\n // where background was a TBitmap.\r\n FBackground := TJvPicture.Create;\r\n FBackgroundFillMode := sfmTile;\r\n\r\n FLockRefreshCount := 0;\r\nend;\r\n\r\ndestructor TJvScrollBox.Destroy;\r\nbegin\r\n FCanvas.Free;\r\n FBackground.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvScrollBox.WMHScroll(var Msg: TWMHScroll);\r\nbegin\r\n inherited;\r\n if Assigned(FOnHorizontalScroll) then\r\n FOnHorizontalScroll(Self);\r\nend;\r\n\r\nprocedure TJvScrollBox.WMVScroll(var Msg: TWMVScroll);\r\nbegin\r\n inherited;\r\n if Assigned(FOnVerticalScroll) then\r\n FOnVerticalScroll(Self);\r\nend;\r\n\r\nprocedure TJvScrollBox.MouseEnter(Control: TControl);\r\nbegin\r\n if csDesigning in ComponentState then\r\n Exit;\r\n if not MouseOver then\r\n begin\r\n if FHotTrack then\r\n Ctl3D := True;\r\n inherited MouseEnter(Control);\r\n end;\r\nend;\r\n\r\nprocedure TJvScrollBox.MouseLeave(Control: TControl);\r\nbegin\r\n if MouseOver then\r\n begin\r\n if FHotTrack then\r\n Ctl3D := False;\r\n inherited MouseLeave(Control);\r\n end;\r\nend;\r\n\r\nprocedure TJvScrollBox.SetHotTrack(const Value: Boolean);\r\nbegin\r\n FHotTrack := Value;\r\n if Value then\r\n Ctl3D := False;\r\nend;\r\n\r\nprocedure TJvScrollBox.SetBackground(const Value: TPicture);\r\nbegin\r\n FBackground.Assign(Value);\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvScrollBox.SetBackgroundFillMode(const Value: TJvScrollBoxFillMode);\r\nbegin\r\n if FBackgroundFillMode <> Value then\r\n begin\r\n FBackgroundFillMode := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nfunction TJvScrollBox.GetBackground: TPicture;\r\nbegin\r\n // Required because FBackground is a TJvPicture and as such cannot be\r\n // used directly in the property declaration.\r\n Result := FBackground;\r\nend;\r\n\r\nprocedure TJvScrollBox.GetDlgCode(var Code: TDlgCodes);\r\nbegin\r\n Code := [dcWantAllKeys, dcWantArrows];\r\nend;\r\n\r\nprocedure TJvScrollBox.WndProc(var Msg: TMessage);\r\nbegin\r\n if Msg.Msg = WM_LBUTTONDOWN then\r\n if not Focused and not (csDesigning in ComponentState) then\r\n SetFocus;\r\n inherited WndProc(Msg);\r\nend;\r\n\r\nprocedure TJvScrollBox.KeyDown(var Key: Word; Shift: TShiftState);\r\nbegin\r\n inherited KeyDown(Key, Shift);\r\n if Key <> 0 then\r\n case Key of\r\n VK_UP:\r\n Perform(WM_VSCROLL, SB_LINEUP, 0);\r\n VK_DOWN:\r\n Perform(WM_VSCROLL, SB_LINEDOWN, 0);\r\n VK_LEFT:\r\n Perform(WM_HSCROLL, SB_LINELEFT, 0);\r\n VK_RIGHT:\r\n Perform(WM_HSCROLL, SB_LINERIGHT, 0);\r\n VK_NEXT:\r\n if ssShift in Shift then\r\n Perform(WM_HSCROLL, SB_PAGERIGHT, 0)\r\n else\r\n Perform(WM_VSCROLL, SB_PAGEDOWN, 0);\r\n VK_PRIOR:\r\n if ssShift in Shift then\r\n Perform(WM_HSCROLL, SB_PAGELEFT, 0)\r\n else\r\n Perform(WM_VSCROLL, SB_PAGEUP, 0);\r\n VK_HOME:\r\n if ssCtrl in Shift then\r\n Perform(WM_VSCROLL, SB_TOP, 0)\r\n else\r\n Perform(WM_HSCROLL, SB_LEFT, 0);\r\n VK_END:\r\n if ssCtrl in Shift then\r\n Perform(WM_VSCROLL, SB_BOTTOM, 0)\r\n else\r\n Perform(WM_HSCROLL, SB_RIGHT, 0);\r\n end;\r\nend;\r\n\r\nprocedure TJvScrollBox.PaintWindow(DC: HDC);\r\nbegin\r\n FCanvas.Lock;\r\n try\r\n FCanvas.Handle := DC;\r\n try\r\n TControlCanvas(FCanvas).UpdateTextFlags;\r\n Paint;\r\n finally\r\n FCanvas.Handle := 0;\r\n end;\r\n finally\r\n FCanvas.Unlock;\r\n end;\r\nend;\r\n\r\nprocedure TJvScrollBox.WMPaint(var Msg: TWMPaint);\r\nbegin\r\n ControlState := ControlState + [csCustomPaint];\r\n inherited;\r\n ControlState := ControlState - [csCustomPaint];\r\nend;\r\n\r\nfunction TJvScrollBox.DoEraseBackground(Canvas: TCanvas; Param: LPARAM): Boolean;\r\nbegin\r\n Result := False;\r\n if Assigned(FOnEraseBackground) then\r\n FOnEraseBackground(Self, Canvas, Result);\r\n if not Result then\r\n Result := inherited DoEraseBackground(Canvas, Param);\r\n\r\n PaintBackground;\r\nend;\r\n\r\nprocedure TJvScrollBox.Paint;\r\nbegin\r\n if Assigned(FOnPaint) then\r\n FOnPaint(Self);\r\nend;\r\n\r\nprocedure TJvScrollBox.PaintBackground;\r\nvar\r\n R: TRect;\r\n X: Integer;\r\n Y: Integer;\r\n BackgroundHeight: Integer;\r\n BackgroundWidth: Integer;\r\n XOffset: Integer;\r\n YOffset: Integer;\r\n SavedYOffset: Integer;\r\nbegin\r\n if Assigned(Background.Graphic) and not Background.Graphic.Empty then\r\n begin\r\n case BackgroundFillMode of\r\n sfmTile:\r\n begin\r\n R := ClientRect;\r\n BackgroundHeight := FBackground.Height;\r\n BackgroundWidth := FBackground.Width;\r\n\r\n XOffset := HorzScrollBar.Position - Trunc(HorzScrollBar.Position / BackgroundWidth) * BackgroundWidth;\r\n YOffset := VertScrollBar.Position - Trunc(VertScrollBar.Position / BackgroundHeight) * BackgroundHeight;\r\n SavedYOffset := YOffset;\r\n X := R.Left;\r\n while X < R.Right do\r\n begin\r\n Y := R.Top;\r\n while Y < R.Bottom do\r\n begin\r\n Canvas.Draw(X - XOffset, Y - YOffset, Background.Graphic);\r\n\r\n Inc(Y, BackgroundHeight - YOffset);\r\n YOffset := 0;\r\n end;\r\n Inc(X, BackgroundWidth - XOffset);\r\n XOffset := 0;\r\n YOffset := SavedYOffset;\r\n end;\r\n end;\r\n sfmStretch:\r\n begin\r\n R := ClientRect;\r\n if HorzScrollBar.Range > R.Right then\r\n R.Right := HorzScrollBar.Range - R.Left;\r\n if VertScrollBar.Range > R.Bottom then\r\n R.Bottom := VertScrollBar.Range - R.Top;\r\n OffsetRect(R, -HorzScrollBar.Position, -VertScrollBar.Position);\r\n\r\n Canvas.StretchDraw(R, Background.Graphic);\r\n end;\r\n sfmNone:\r\n begin\r\n Canvas.Draw(0, 0, Background.Graphic);\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvScrollBox.BeginUpdate;\r\nbegin\r\n if FLockRefreshCount = 0 then\r\n SendMessage(Handle, WM_SETREDRAW, Ord(False), 0);\r\n\r\n Inc(FLockRefreshCount);\r\nend;\r\n\r\nprocedure TJvScrollBox.EndUpdate;\r\nbegin\r\n Dec(FLockRefreshCount);\r\n if FLockRefreshCount = 0 then\r\n begin\r\n SendMessage(Handle, WM_SETREDRAW, Ord(True), 0);\r\n RedrawWindow(Handle, nil, 0, RDW_ERASE or RDW_INVALIDATE or RDW_FRAME or RDW_ALLCHILDREN);\r\n end;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\n\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvScrollMax.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvScrollMax.PAS, released on 2002-07-04.\r\n\r\nThe Initial Developers of the Original Code are: Andrei Prygounkov     \r\nCopyright (c) 1999, 2002 Andrei Prygounkov\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\ncomponent : TJvScrollMax\r\ndescription : scrollable panels\r\n\r\nHistory:\r\n 1.20:\r\n - first version;\r\n 2.00:\r\n - new property ScrollbarVisible;\r\nKnown Issues:\r\n Some russian comments were translated to english; these comments are marked\r\n with [translated]\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvScrollMax.pas 13138 2011-10-26 23:17:50Z jfudickar $\r\n\r\nunit JvScrollMax;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n SysUtils, Classes,\r\n Windows, Messages, Graphics, Forms, ExtCtrls, Controls, Buttons,\r\n JvButtons, JvComponent, JvExtComponent;\r\n\r\nconst\r\n CM_PARENTBEVELEDCHANGED = WM_USER + 1;\r\n CM_PARENTBUTTONFONTCHANGED = WM_USER + 2;\r\n CM_PARENTBUTTONVISIBLECHANGED = WM_USER + 3;\r\n\r\ntype\r\n TOnCanExpand = procedure(Sender: TObject; var CanExpand: Boolean) of object;\r\n TOnCanCollapse = procedure(Sender: TObject; var CanCollapse: Boolean) of object;\r\n\r\n TJvScrollMax = class;\r\n\r\n TJvScrollMaxBand = class(TJvCustomControl)\r\n private\r\n FData: Pointer;\r\n FExpandedHeight: Integer;\r\n FButton: TSpeedButton;\r\n FExpanded: Boolean;\r\n FOrder: Integer;\r\n FBeveled: Boolean;\r\n FBorderWidth: Integer;\r\n FParentBeveled: Boolean;\r\n FParentButtonFont: Boolean;\r\n FParentButtonVisible: Boolean;\r\n FOnExpand: TNotifyEvent;\r\n FOnCollapse: TNotifyEvent;\r\n FOnCanCollapse: TOnCanCollapse;\r\n FOnCanExpand: TOnCanExpand;\r\n procedure ButtonClick(Sender: TObject);\r\n procedure SetExpanded(const Value: Boolean);\r\n procedure SetExpandedHeight(const Value: Integer);\r\n function GetOrder: Integer;\r\n procedure SetOrder(const Value: Integer);\r\n procedure SetParentBeveled(const Value: Boolean);\r\n procedure SetButtonFont(Value: TFont);\r\n function GetButtonFont: TFont;\r\n procedure SetBeveled(const Value: Boolean);\r\n procedure SetBorderWidth(const Value: Integer);\r\n function IsBeveledStored: Boolean;\r\n procedure SetParentButtonFont(const Value: Boolean);\r\n function IsButtonFontStored: Boolean;\r\n function GetButtonVisible: Boolean;\r\n procedure SetButtonVisible(const Value: Boolean);\r\n function IsButtonVisibleStored: Boolean;\r\n procedure SetParentButtonVisible(const Value: Boolean);\r\n procedure CMParentBeveledChanged(var Msg: TMessage); message CM_PARENTBEVELEDCHANGED;\r\n procedure CMParentButtonFontChanged(var Msg: TMessage); message CM_PARENTBUTTONFONTCHANGED;\r\n procedure CMParentButtonVisibleChanged(var Msg: TMessage); message CM_PARENTBUTTONVISIBLECHANGED;\r\n protected\r\n procedure TextChanged; override;\r\n procedure BoundsChanged; override;\r\n procedure Loaded; override;\r\n procedure Paint; override;\r\n procedure SetParent( AParent: TWinControl); override;\r\n procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;\r\n procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;\r\n procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;\r\n procedure SetZOrder(TopMost: Boolean); override;\r\n function ScrollMax: TJvScrollMax;\r\n procedure UpdateSize(ATop: Integer);\r\n procedure AlignControls(AControl: TControl; var Rect: TRect); override;\r\n function CollapsedHeight: Integer;\r\n procedure ChangeScale(M, D : Integer); override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n property Data: Pointer read FData write FData;\r\n published\r\n property Expanded: Boolean read FExpanded write SetExpanded default True;\r\n property Caption;\r\n property ExpandedHeight: Integer read FExpandedHeight write SetExpandedHeight;\r\n property Order: Integer read GetOrder write SetOrder stored False;\r\n property ButtonVisible: Boolean read GetButtonVisible write SetButtonVisible stored IsButtonVisibleStored;\r\n property ButtonFont: TFont read GetButtonFont write SetButtonFont stored IsButtonFontStored;\r\n property Beveled: Boolean read FBeveled write SetBeveled default True;\r\n property BorderWidth: Integer read FBorderWidth write SetBorderWidth default 0;\r\n property ParentBeveled: Boolean read FParentBeveled write SetParentBeveled stored IsBeveledStored;\r\n property ParentButtonVisible: Boolean read FParentButtonVisible write SetParentButtonVisible default True;\r\n property ParentButtonFont: Boolean read FParentButtonFont write SetParentButtonFont default True;\r\n property OnResize;\r\n property OnExpand: TNotifyEvent read FOnExpand write FOnExpand;\r\n property OnCollapse: TNotifyEvent read FOnCollapse write FOnCollapse;\r\n property OnCanExpand: TOnCanExpand read FOnCanExpand write FOnCanExpand;\r\n property OnCanCollapse: TOnCanCollapse read FOnCanCollapse write FOnCanCollapse;\r\n property Left stored False;\r\n property Top stored False;\r\n property Width;\r\n property Height;\r\n property Color;\r\n property Font;\r\n property ParentColor;\r\n property ParentFont;\r\n property ParentShowHint;\r\n property ShowHint;\r\n property Visible;\r\n property OnDblClick;\r\n property OnDragDrop;\r\n property OnDragOver;\r\n property OnEndDrag;\r\n property OnStartDrag;\r\n property BiDiMode;\r\n property ParentBiDiMode;\r\n end;\r\n\r\n TJvScrollMaxBands = class(TJvCustomControl)\r\n private\r\n FScrolling: Boolean;\r\n protected\r\n procedure FocusChanged(Control: TWinControl); override;\r\n procedure AlignControls(AControl: TControl; var Rect: TRect); override;\r\n procedure ScrollControls(const DeltaY: Integer);\r\n procedure Paint; override;\r\n end;\r\n\r\n TJvPanelScrollBar = class(TJvCustomPanel)\r\n private\r\n FMin: Integer;\r\n FMax: Integer;\r\n FPos: Integer;\r\n FPage: Integer;\r\n Scroll: TPanel;\r\n FDesignInteractive: Boolean;\r\n FInclusive: Boolean;\r\n FOnChange: TNotifyEvent;\r\n FOnScroll: TNotifyEvent;\r\n procedure SetParam(Index, Value: Integer);\r\n procedure SetInclusive(Value: Boolean);\r\n protected\r\n procedure CreateWnd; override;\r\n procedure SetTrackBar;\r\n procedure Loaded; override;\r\n procedure Resize; override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n procedure SetParams(const AMin, AMax, APage, APos: Integer);\r\n property Pos: Integer index 3 read FPos write SetParam;\r\n property DesignInteractive: Boolean read FDesignInteractive write FDesignInteractive;\r\n property Scroller: TPanel read Scroll;\r\n published\r\n property Color;\r\n property Align;\r\n property Min: Integer index 0 read FMin write SetParam;\r\n property Max: Integer index 1 read FMax write SetParam;\r\n property Page: Integer index 2 read FPage write SetParam;\r\n property Position: Integer index 3 read FPos write SetParam;\r\n property Inclusive: Boolean read FInclusive write SetInclusive;\r\n property OnChange: TNotifyEvent read FOnChange write FOnChange;\r\n property OnScroll: TNotifyEvent read FOnScroll write FOnScroll;\r\n end;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvScrollMax = class(TJvCustomPanel)\r\n private\r\n FPnlEdit: TJvScrollMaxBands;\r\n FScrollBar: TJvPanelScrollBar;\r\n FScrollPos: Integer;\r\n FY: Integer;\r\n FButtonFont: TFont;\r\n FOnScroll: TNotifyEvent;\r\n FBeveled: Boolean;\r\n FButtonVisible: Boolean;\r\n FAutoHeight: Boolean;\r\n FExpandedHeight: Integer;\r\n FOneExpanded: Boolean;\r\n procedure Correct;\r\n procedure CorrectHeight;\r\n procedure BandMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);\r\n procedure BandMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);\r\n procedure BandMouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);\r\n procedure ScrollBarScroll(Sender: TObject);\r\n procedure SetButtonFont(Value: TFont);\r\n procedure ButtonFontChanged(Sender: TObject);\r\n function GetBand(Index: Integer): TJvScrollMaxBand;\r\n function GetBandCount: Integer;\r\n procedure SetScrollPos(const Value: Integer);\r\n procedure SetButtonVisible(const Value: Boolean);\r\n procedure SetBeveled(const Value: Boolean);\r\n procedure SetAutoHeight(const Value: Boolean);\r\n procedure SetExpandedHeight(const Value: Integer);\r\n function GetScrollBarWidth: Cardinal;\r\n procedure SetScrollBarWidth(const Value: Cardinal);\r\n function GetScrollBarVisible: Boolean;\r\n procedure SetScrollBarVisible(const Value: Boolean);\r\n procedure SetOneExpanded(const Value: Boolean);\r\n protected\r\n {$IFDEF JVCLThemesEnabled}\r\n procedure SetParentBackground(Value: Boolean); override;\r\n {$ENDIF JVCLThemesEnabled}\r\n procedure Loaded; override;\r\n function GetChildParent: TComponent; override;\r\n procedure CreateParams(var Params: TCreateParams); override;\r\n procedure Resize; override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n\r\n procedure GetChildren(Proc: TGetChildProc; Root: TComponent); override; // public in D2009\r\n procedure ScrollInView(AControl: TControl);\r\n procedure MouseControls(AControls: array of TControl);\r\n procedure MouseClasses(AControlClasses: array of TControlClass);\r\n function AllCollapsed: Boolean;\r\n function AllExpanded: Boolean;\r\n procedure AddBand(Band: TJvScrollMaxBand);\r\n property BandCount: Integer read GetBandCount;\r\n property Bands[Index: Integer]: TJvScrollMaxBand read GetBand;\r\n published\r\n property ScrollPos: Integer read FScrollPos write SetScrollPos default 0;\r\n property BorderWidth default 3;\r\n property Beveled: Boolean read FBeveled write SetBeveled default True;\r\n property ButtonFont: TFont read FButtonFont write SetButtonFont;\r\n property ButtonVisible: Boolean read FButtonVisible write SetButtonVisible default True;\r\n property AutoHeight: Boolean read FAutoHeight write SetAutoHeight;\r\n property ExpandedHeight: Integer read FExpandedHeight write SetExpandedHeight default -1;\r\n property ScrollBarWidth: Cardinal read GetScrollBarWidth write SetScrollBarWidth default 7;\r\n property ScrollBarVisible: Boolean read GetScrollBarVisible write SetScrollBarVisible default True;\r\n property OneExpanded: Boolean read FOneExpanded write SetOneExpanded default False;\r\n property OnScroll: TNotifyEvent read FOnScroll write FOnScroll;\r\n property Align;\r\n property BevelInner;\r\n property BevelOuter;\r\n property BevelWidth;\r\n property BorderStyle;\r\n property Color;\r\n property DragMode;\r\n property Enabled;\r\n property Font;\r\n property ParentColor;\r\n property ParentFont;\r\n property ParentShowHint;\r\n property ShowHint;\r\n property TabOrder;\r\n property TabStop;\r\n property Visible;\r\n property OnResize;\r\n property OnDblClick;\r\n property OnDragDrop;\r\n property OnDragOver;\r\n property OnEndDrag;\r\n property OnStartDrag;\r\n public\r\n property DockManager;\r\n published\r\n property Anchors;\r\n //property AutoSize;\r\n property Constraints;\r\n property BiDiMode;\r\n property UseDockManager default True;\r\n property DockSite;\r\n property DragCursor;\r\n property DragKind;\r\n property ParentBiDiMode;\r\n property OnCanResize;\r\n property OnConstrainedResize;\r\n property OnDockDrop;\r\n property OnDockOver;\r\n property OnEndDock;\r\n property OnGetSiteInfo;\r\n property OnStartDock;\r\n property OnUnDock;\r\n {$IFDEF JVCLThemesEnabled}\r\n property ParentBackground default True;\r\n {$ENDIF JVCLThemesEnabled}\r\n end;\r\n\r\n EJvScrollMaxError = class(Exception);\r\n\r\nvar\r\n crRAHand: Integer;\r\n crRAHandMove: Integer;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvScrollMax.pas $';\r\n Revision: '$Revision: 13138 $';\r\n Date: '$Date: 2011-10-27 01:17:50 +0200 (jeu. 27 oct. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n JvDsgnIntf, JvJCLUtils, JvJVCLUtils, JvThemes, JvResources;\r\n\r\n{ Cursors resources }\r\n{$R JvScrollMax.res}\r\n\r\nfunction PanelBorder(Panel: TCustomPanel): Integer;\r\nbegin\r\n Result := TPanel(Panel).BorderWidth;\r\n if TPanel(Panel).BevelOuter <> bvNone then\r\n Inc(Result, TPanel(Panel).BevelWidth);\r\n if TPanel(Panel).BevelInner <> bvNone then\r\n Inc(Result, TPanel(Panel).BevelWidth);\r\nend;\r\n\r\n{ function DefineCursor was typed from\r\n book \"Secrets of Delphi 2\" by Ray Lischner }\r\n\r\n{ (rom) deactivated see end of file\r\nfunction DefineCursor(Identifier: PChar): TCursor;\r\nvar\r\n Handle: HCURSOR;\r\nbegin\r\n Handle := LoadCursor(HInstance, Identifier);\r\n if Handle = 0 then\r\n raise EOutOfResources.CreateRes(@RsECannotLoadCursorResource);\r\n for Result := 1 to High(TCursor) do\r\n if Screen.Cursors[Result] = Screen.Cursors[crDefault] then\r\n begin\r\n Screen.Cursors[Result] := Handle;\r\n Exit;\r\n end;\r\n raise EOutOfResources.CreateRes(@RsETooManyUserdefinedCursors);\r\nend;\r\n}\r\n\r\n//=== { TJvScroller } ========================================================\r\n\r\ntype\r\n TJvScroller = class(TPanel)\r\n private\r\n FY: Integer;\r\n procedure CMDesignHitTest(var Msg: TCMDesignHitTest); message CM_DESIGNHITTEST;\r\n protected\r\n procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;\r\n procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;\r\n end;\r\n\r\nprocedure TJvScroller.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);\r\nbegin\r\n if Button = mbLeft then\r\n FY := Y;\r\nend;\r\n\r\nprocedure TJvScroller.MouseMove(Shift: TShiftState; X, Y: Integer);\r\nvar\r\n Sm, T, OldPos: Integer;\r\nbegin\r\n if Shift = [ssLeft] then\r\n begin\r\n Sm := FY - Y;\r\n T := Top;\r\n if Sm <> 0 then\r\n begin\r\n with Parent as TJvPanelScrollBar do\r\n begin\r\n OldPos := Pos;\r\n Pos := Pos - Round(Sm * (FMax - FMin + 1) / ClientHeight);\r\n if (Pos <> OldPos) and Assigned(FOnScroll) then\r\n FOnScroll(Parent);\r\n end;\r\n end;\r\n FY := Y - Top + T;\r\n end;\r\nend;\r\n\r\n\r\nprocedure TJvScroller.CMDesignHitTest(var Msg: TCMDesignHitTest);\r\nbegin\r\n with (Owner as TJvPanelScrollBar) do\r\n Msg.Result := Integer(FDesignInteractive and (FPage <> FMax - FMin + 1));\r\nend;\r\n\r\n\r\n//=== { TJvPanelScrollBar } ==================================================\r\n\r\nconstructor TJvPanelScrollBar.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n BevelOuter := bvLowered;\r\n Color := clAppWorkSpace;\r\n Caption := '';\r\n ControlStyle := ControlStyle - [csSetCaption, csAcceptsControls];\r\n Scroll := TJvScroller.Create(Self);\r\n Scroll.Parent := Self;\r\n Scroll.Caption := '';\r\n Scroll.ControlStyle := ControlStyle - [csSetCaption, csAcceptsControls];\r\n FMax := 100;\r\n FPage := 10;\r\n Width := 20;\r\n Height := 100;\r\nend;\r\n\r\nprocedure TJvPanelScrollBar.Loaded;\r\nbegin\r\n inherited Loaded;\r\n Resize;\r\nend;\r\n\r\nprocedure TJvPanelScrollBar.Resize;\r\nbegin\r\n inherited Resize;\r\n with Scroll do\r\n begin\r\n Top := BevelWidth;\r\n Left := BevelWidth;\r\n Width := Self.Width - 2 * BevelWidth;\r\n end;\r\n SetTrackBar;\r\nend;\r\n\r\nprocedure TJvPanelScrollBar.SetTrackBar;\r\nvar\r\n CH, H, T: Integer;\r\n L, FP, P, P1: Integer;\r\nbegin\r\n { Before change of the code necessarily make a copy! [translated] }\r\n if FMin > FMax then\r\n FMin := FMax;\r\n if FPage > FMax - FMin + 1 then\r\n FPage := FMax - FMin + 1;\r\n if FInclusive then\r\n P := FPage\r\n else\r\n P := 0;\r\n P1 := FPage - P;\r\n if FPos > FMax - P then\r\n FPos := FMax - P;\r\n if FPos < FMin then\r\n FPos := FMin;\r\n L := FMax - FMin + 1;\r\n CH := Height - 2 * BevelWidth;\r\n H := Trunc(CH * FPage / L) + 1;\r\n FP := Trunc((FPos - FMin) / L * (L - P1)) + 1;\r\n T := Round(CH * FP / L);\r\n if H < 7 then\r\n H := 7;\r\n if H > CH then\r\n H := CH;\r\n if T < BevelWidth then\r\n T := BevelWidth;\r\n if T + H > Height - BevelWidth then\r\n T := Height - BevelWidth - H;\r\n if FPos = FMax - P then\r\n T := Height - BevelWidth - H;\r\n\r\n with Scroll do\r\n SetBounds(Left, T, Width, H);\r\nend;\r\n\r\nprocedure TJvPanelScrollBar.SetParam(Index, Value: Integer);\r\nbegin\r\n case Index of\r\n 0:\r\n FMin := Value;\r\n 1:\r\n FMax := Value;\r\n 2:\r\n FPage := Value;\r\n 3:\r\n FPos := Value;\r\n end;\r\n SetParams(FMin, FMax, FPage, FPos);\r\nend;\r\n\r\nprocedure TJvPanelScrollBar.SetParams(const AMin, AMax, APage, APos: Integer);\r\nbegin\r\n FMin := AMin;\r\n FMax := AMax;\r\n FPage := APage;\r\n FPos := APos;\r\n if Assigned(FOnChange) then\r\n FOnChange(Self);\r\n SetTrackBar;\r\nend;\r\n\r\nprocedure TJvPanelScrollBar.SetInclusive(Value: Boolean);\r\nbegin\r\n FInclusive := Value;\r\n SetTrackBar;\r\nend;\r\n\r\nprocedure TJvPanelScrollBar.CreateWnd;\r\nbegin\r\n inherited CreateWnd;\r\n SetTrackBar;\r\nend;\r\n\r\n//=== { TJvBandBtn } =========================================================\r\n\r\ntype\r\n TJvBandBtn = class(TJvNoFrameButton)\r\n private\r\n procedure CMDesignHitTest(var Msg: TCMDesignHitTest); message CM_DESIGNHITTEST;\r\n protected\r\n procedure FontChanged; override;\r\n end;\r\n\r\n\r\nprocedure TJvBandBtn.CMDesignHitTest(var Msg: TCMDesignHitTest);\r\nbegin\r\n Msg.Result := 1;\r\nend;\r\n\r\n\r\nprocedure TJvBandBtn.FontChanged;\r\nbegin\r\n inherited FontChanged;\r\n if Parent <> nil then\r\n with Parent as TJvScrollMaxBand do\r\n begin\r\n FParentButtonFont := False;\r\n Canvas.Font := Self.Font;\r\n // (rom) please check this change\r\n //FButton.Height := Canvas.TextHeight('W') + 4;\r\n FButton.Height := CanvasMaxTextHeight(Canvas) + 4;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\n//=== { TJvScrollMaxBand } ===================================================\r\n\r\nconstructor TJvScrollMaxBand.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n ControlStyle := ControlStyle + [csSetCaption, csAcceptsControls];\r\n IncludeThemeStyle(Self, [csParentBackground]);\r\n Height := 50;\r\n FExpandedHeight := 50;\r\n ParentColor := True;\r\n FParentButtonFont := True;\r\n FParentButtonVisible := True;\r\n FParentBeveled := True;\r\n FButton := TJvBandBtn.Create(Self);\r\n with FButton as TJvBandBtn do\r\n begin\r\n SetDesigning(False);\r\n Parent := Self;\r\n Top := 2;\r\n Left := 4;\r\n Cursor := crArrow;\r\n OnClick := ButtonClick;\r\n Margin := 4;\r\n Spacing := -1;\r\n NoBorder := False;\r\n ParentColor := True;\r\n FButton.ParentBiDiMode := True;\r\n end;\r\n Expanded := True;\r\nend;\r\n\r\nprocedure TJvScrollMaxBand.Loaded;\r\nbegin\r\n inherited Loaded;\r\n Perform(CM_PARENTBEVELEDCHANGED, 0, 0);\r\n Perform(CM_PARENTBUTTONVISIBLECHANGED, 0, 0);\r\n Perform(CM_PARENTBUTTONFONTCHANGED, 0, 0);\r\nend;\r\n\r\nprocedure TJvScrollMaxBand.BoundsChanged;\r\nbegin\r\n if FExpanded then\r\n ExpandedHeight := Height;\r\n inherited BoundsChanged;\r\n if Parent <> nil then\r\n ScrollMax.CorrectHeight;\r\nend;\r\n\r\nprocedure TJvScrollMaxBand.TextChanged;\r\nbegin\r\n inherited TextChanged;\r\n FButton.Caption := Caption;\r\nend;\r\n\r\nprocedure TJvScrollMaxBand.SetExpanded(const Value: Boolean);\r\nbegin\r\n if FExpanded <> Value then\r\n begin\r\n FExpanded := Value;\r\n FButton.Glyph.Assign(nil); // fixes GDI resource leak\r\n if FExpanded then\r\n FButton.Glyph.LoadFromResourceName(HInstance, 'JvScrollMaxBandBTNMINUS')\r\n else\r\n FButton.Glyph.LoadFromResourceName(HInstance, 'JvScrollMaxBandBTNPLUS');\r\n if FExpanded and Assigned(FOnExpand) then\r\n FOnExpand(Self);\r\n if not FExpanded and Assigned(FOnCollapse) then\r\n FOnCollapse(Self);\r\n RequestAlign;\r\n if Parent <> nil then\r\n ScrollMax.CorrectHeight;\r\n { if not (csLoading in ComponentState) and (ScrollMax <> nil) then\r\n DesignerModified(ScrollMax); }\r\n end;\r\nend;\r\n\r\nprocedure TJvScrollMaxBand.SetExpandedHeight(const Value: Integer);\r\nbegin\r\n if FExpandedHeight <> Value then\r\n begin\r\n FExpandedHeight := Value;\r\n if FExpanded then\r\n Height := FExpandedHeight;\r\n // RequestAlign - called from SetHeight\r\n end;\r\nend;\r\n\r\nfunction TJvScrollMaxBand.GetOrder: Integer;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := FOrder;\r\n if Parent <> nil then\r\n begin\r\n for I := 0 to Parent.ControlCount - 1 do\r\n if Parent.Controls[I] = Self then\r\n begin\r\n Result := I;\r\n Break;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvScrollMaxBand.SetOrder(const Value: Integer);\r\nbegin\r\n if FOrder <> Value then\r\n begin\r\n if Parent <> nil then\r\n TJvScrollMaxBands(Parent).SetChildOrder(Self, Value);\r\n FOrder := GetOrder;\r\n RequestAlign;\r\n end;\r\nend;\r\n\r\nfunction TJvScrollMaxBand.GetButtonFont: TFont;\r\nbegin\r\n Result := FButton.Font;\r\nend;\r\n\r\nprocedure TJvScrollMaxBand.SetButtonFont(Value: TFont);\r\nbegin\r\n FButton.Font := Value;\r\nend;\r\n\r\nprocedure TJvScrollMaxBand.SetParentButtonFont(const Value: Boolean);\r\nbegin\r\n if FParentButtonFont <> Value then\r\n begin\r\n FParentButtonFont := Value;\r\n if Parent <> nil then\r\n Perform(CM_PARENTBUTTONFONTCHANGED, 0, 0);\r\n end;\r\nend;\r\n\r\nprocedure TJvScrollMaxBand.CMParentButtonFontChanged(var Msg: TMessage);\r\nbegin\r\n if FParentButtonFont then\r\n begin\r\n if ScrollMax <> nil then\r\n SetButtonFont(ScrollMax.FButtonFont);\r\n FParentButtonFont := True;\r\n end;\r\nend;\r\n\r\nfunction TJvScrollMaxBand.IsButtonFontStored: Boolean;\r\nbegin\r\n Result := not ParentButtonFont;\r\nend;\r\n\r\nfunction TJvScrollMaxBand.GetButtonVisible: Boolean;\r\nbegin\r\n Result := FButton.Visible;\r\nend;\r\n\r\nprocedure TJvScrollMaxBand.SetButtonVisible(const Value: Boolean);\r\nbegin\r\n if FButton.Visible <> Value then\r\n begin\r\n FParentButtonVisible := False;\r\n FButton.Visible := Value;\r\n UpdateSize(Top);\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nfunction TJvScrollMaxBand.IsButtonVisibleStored: Boolean;\r\nbegin\r\n Result := not ParentButtonVisible;\r\nend;\r\n\r\nprocedure TJvScrollMaxBand.SetParentButtonVisible(const Value: Boolean);\r\nbegin\r\n if FParentButtonVisible <> Value then\r\n begin\r\n FParentButtonVisible := Value;\r\n if Parent <> nil then\r\n Perform(CM_PARENTBUTTONVISIBLECHANGED, 0, 0);\r\n end;\r\nend;\r\n\r\nprocedure TJvScrollMaxBand.CMParentButtonVisibleChanged(var Msg: TMessage);\r\nbegin\r\n if FParentButtonVisible then\r\n begin\r\n if ScrollMax <> nil then\r\n SetButtonVisible(ScrollMax.FButtonVisible);\r\n FParentButtonVisible := True;\r\n end;\r\nend;\r\n\r\nprocedure TJvScrollMaxBand.SetBeveled(const Value: Boolean);\r\nbegin\r\n if FBeveled <> Value then\r\n begin\r\n FParentBeveled := False;\r\n FBeveled := Value;\r\n UpdateSize(Top);\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nfunction TJvScrollMaxBand.IsBeveledStored: Boolean;\r\nbegin\r\n Result := not ParentBeveled;\r\nend;\r\n\r\nprocedure TJvScrollMaxBand.SetParentBeveled(const Value: Boolean);\r\nbegin\r\n if FParentBeveled <> Value then\r\n begin\r\n FParentBeveled := Value;\r\n if Parent <> nil then\r\n Perform(CM_PARENTBEVELEDCHANGED, 0, 0);\r\n end;\r\nend;\r\n\r\nprocedure TJvScrollMaxBand.CMParentBeveledChanged(var Msg: TMessage);\r\nbegin\r\n if FParentBeveled then\r\n begin\r\n if ScrollMax <> nil then\r\n SetBeveled(ScrollMax.FBeveled);\r\n FParentBeveled := True;\r\n end;\r\nend;\r\n\r\nprocedure TJvScrollMaxBand.ButtonClick(Sender: TObject);\r\nvar\r\n E: Boolean;\r\nbegin\r\n E := True;\r\n if FExpanded then\r\n begin\r\n if Assigned(FOnCanCollapse) then\r\n FOnCanCollapse(Self, E);\r\n end\r\n else\r\n if Assigned(FOnCanExpand) then\r\n FOnCanExpand(Self, E);\r\n if E then\r\n Expanded := not FExpanded;\r\n DesignerModified(Self);\r\nend;\r\n\r\nprocedure TJvScrollMaxBand.SetParent( AParent: TWinControl);\r\nbegin\r\n if not ((AParent is TJvScrollMaxBands) or (AParent = nil)) then\r\n raise EJvScrollMaxError.CreateRes(@RsETJvScrollMaxBandCanBePutOnlyIntoTJv);\r\n inherited SetParent(AParent);\r\n if not (csLoading in ComponentState) then\r\n begin\r\n Perform(CM_PARENTBEVELEDCHANGED, 0, 0);\r\n Perform(CM_PARENTBUTTONVISIBLECHANGED, 0, 0);\r\n Perform(CM_PARENTBUTTONFONTCHANGED, 0, 0);\r\n end;\r\nend;\r\n\r\nprocedure TJvScrollMaxBand.SetZOrder(TopMost: Boolean);\r\nbegin\r\n inherited SetZOrder(TopMost);\r\n RequestAlign;\r\nend;\r\n\r\nprocedure TJvScrollMaxBand.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);\r\nbegin\r\n inherited MouseDown(Button, Shift, X, Y);\r\n ScrollMax.BandMouseDown(Self, Button, Shift, X, Y);\r\nend;\r\n\r\nprocedure TJvScrollMaxBand.MouseMove(Shift: TShiftState; X, Y: Integer);\r\nbegin\r\n inherited MouseMove(Shift, X, Y);\r\n ScrollMax.BandMouseMove(Self, Shift, X, Y);\r\nend;\r\n\r\nprocedure TJvScrollMaxBand.MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);\r\nbegin\r\n inherited MouseUp(Button, Shift, X, Y);\r\n ScrollMax.BandMouseUp(Self, Button, Shift, X, Y);\r\nend;\r\n\r\nfunction TJvScrollMaxBand.ScrollMax: TJvScrollMax;\r\nbegin\r\n if (Parent <> nil) and ((Parent as TJvScrollMaxBands).Parent <> nil) then\r\n Result := (Parent as TJvScrollMaxBands).Parent as TJvScrollMax\r\n else\r\n Result := nil;\r\nend;\r\n\r\nfunction TJvScrollMaxBand.CollapsedHeight: Integer;\r\nbegin\r\n if ButtonVisible then\r\n Result := FButton.BoundsRect.Bottom + FButton.Top\r\n else\r\n Result := 0;\r\nend;\r\n\r\nprocedure TJvScrollMaxBand.UpdateSize(ATop: Integer);\r\nvar\r\n W, H: Integer;\r\nbegin\r\n if FExpanded then\r\n H := FExpandedHeight\r\n else\r\n H := CollapsedHeight;\r\n if ScrollMax <> nil then\r\n begin\r\n W := Parent.Width;\r\n if ScrollMax.ScrollBarVisible then\r\n W := W - 3;\r\n end\r\n else\r\n W := Width;\r\n SetBounds(0, ATop, W, H);\r\n if FBeveled then\r\n FButton.Left := 16\r\n else\r\n FButton.Left := 4;\r\n FButton.Width := Width - FButton.Left * 2;\r\nend;\r\n\r\nprocedure TJvScrollMaxBand.Paint;\r\nconst\r\n Ex: array [Boolean] of Integer = (BF_TOP, BF_RECT);\r\nvar\r\n R: TRect;\r\nbegin\r\n if Canvas.Handle <> NullHandle then\r\n begin\r\n if csDesigning in ComponentState then\r\n DrawDesignFrame(Canvas, ClientRect);\r\n if FBeveled then\r\n begin\r\n R.Left := 1;\r\n if ButtonVisible then\r\n R.Top := FButton.Top + FButton.Height div 2\r\n else\r\n R.Top := 1;\r\n R.Right := Width - R.Left;\r\n R.Bottom := Height - 1;\r\n Windows.DrawEdge(Canvas.Handle, R, EDGE_ETCHED, Ex[FExpanded]);\r\n if ButtonVisible then\r\n begin\r\n Canvas.Brush.Color := Color;\r\n Canvas.Brush.Style := bsSolid;\r\n Canvas.FillRect(Bounds(FButton.Left - 2, R.Top, FButton.Width + 4, 2));\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvScrollMaxBand.AlignControls(AControl: TControl; var Rect: TRect);\r\nvar\r\n BevelSize: Integer;\r\nbegin\r\n BevelSize := FBorderWidth;\r\n if FBeveled then\r\n Inc(BevelSize, 3);\r\n InflateRect(Rect, -BevelSize, -BevelSize);\r\n if ButtonVisible then\r\n begin\r\n Inc(Rect.Top, FButton.Height);\r\n if FButton.Top > FBorderWidth then\r\n Inc(Rect.Top, FButton.Top);\r\n end;\r\n inherited AlignControls(AControl, Rect);\r\nend;\r\n\r\nprocedure TJvScrollMaxBand.SetBorderWidth(const Value: Integer);\r\nbegin\r\n if FBorderWidth <> Value then\r\n begin\r\n FBorderWidth := Value;\r\n Realign;\r\n end;\r\nend;\r\n\r\nprocedure TJvScrollMaxBand.ChangeScale(M, D : Integer);\r\nbegin\r\n inherited ChangeScale(M, D );\r\n ExpandedHeight := FExpandedHeight * M div D;\r\nend;\r\n\r\n//=== { TJvScrollMaxBands } ==================================================\r\n\r\nprocedure TJvScrollMaxBands.AlignControls(AControl: TControl; var Rect: TRect);\r\nvar\r\n I: Integer;\r\n ScrollMax: TJvScrollMax;\r\n T: Integer;\r\n SMax, SPage, SPos: Integer;\r\n\r\n procedure AdjustBottom;\r\n begin\r\n if (Controls[ControlCount - 1].BoundsRect.Bottom < Height) and\r\n (Controls[0].Top < 0) then\r\n begin\r\n if Height - (Controls[ControlCount - 1].BoundsRect.Bottom - Controls[0].Top) > 0 then\r\n ScrollControls(-Controls[0].Top)\r\n else\r\n ScrollControls(Height - Controls[ControlCount - 1].BoundsRect.Bottom);\r\n end;\r\n end;\r\n\r\n procedure AdjustBand;\r\n var\r\n Band: TJvScrollMaxBand;\r\n begin\r\n Band := AControl as TJvScrollMaxBand;\r\n if (Band <> nil) and Band.FExpanded and\r\n (Band.BoundsRect.Bottom > Height) and\r\n (Band.Top > 0) and\r\n not (csLoading in Band.ComponentState) then\r\n begin\r\n ScrollControls(Height - Band.BoundsRect.Bottom);\r\n end;\r\n end;\r\n\r\n procedure SetCursor;\r\n var\r\n I: Integer;\r\n Cursor: TCursor;\r\n begin\r\n if (Controls[ControlCount - 1].BoundsRect.Bottom > ClientHeight) or\r\n (Controls[0].Top < 0) then\r\n Cursor := crRAHand\r\n else\r\n Cursor := crDefault;\r\n for I := 0 to ControlCount - 1 do\r\n Controls[I].Cursor := Cursor;\r\n end;\r\n\r\nbegin\r\n if FScrolling then\r\n Exit;\r\n if (Parent <> nil) and (csLoading in Parent.ComponentState) then\r\n Exit;\r\n ScrollMax := Parent as TJvScrollMax;\r\n if (AControl <> nil) and\r\n (AControl as TJvScrollMaxBand).FExpanded and\r\n ScrollMax.FOneExpanded then\r\n for I := 0 to ControlCount - 1 do\r\n if not (Controls[I] is TJvScrollMaxBand) then\r\n raise EJvScrollMaxError.CreateRes(@RsETJvScrollMaxCanContainOnlyTJvScroll)\r\n else\r\n if Controls[I] <> AControl then\r\n (Controls[I] as TJvScrollMaxBand).Expanded := False;\r\n SPos := ScrollMax.FScrollPos;\r\n if ControlCount > 0 then\r\n begin\r\n for I := 0 to ControlCount - 1 do\r\n begin\r\n if not (Controls[I] is TJvScrollMaxBand) then\r\n raise EJvScrollMaxError.CreateRes(@RsETJvScrollMaxCanContainOnlyTJvScroll);\r\n if I > 0 then\r\n T := Controls[I - 1].BoundsRect.Bottom\r\n else\r\n T := -ScrollMax.FScrollPos;\r\n (Controls[I] as TJvScrollMaxBand).UpdateSize(T);\r\n end;\r\n AdjustBottom;\r\n AdjustBand;\r\n SMax := Controls[ControlCount - 1].BoundsRect.Bottom - Controls[0].Top;\r\n SPos := -Controls[0].Top;\r\n ScrollMax.FScrollPos := SPos;\r\n SetCursor;\r\n end\r\n else\r\n SMax := Height;\r\n SPage := Height;\r\n ScrollMax.FScrollBar.SetParams(0, SMax, SPage, SPos);\r\nend;\r\n\r\nprocedure TJvScrollMaxBands.ScrollControls(const DeltaY: Integer);\r\nbegin\r\n FScrolling := True;\r\n try\r\n ScrollBy(0, DeltaY);\r\n finally\r\n FScrolling := False;\r\n end;\r\nend;\r\n\r\nprocedure TJvScrollMaxBands.FocusChanged(Control: TWinControl);\r\nbegin\r\n inherited FocusChanged(Control);\r\n if (Control <> nil) and\r\n ContainsControl(Control) and\r\n (Parent <> nil) then\r\n (Parent as TJvScrollMax).ScrollInView(Control);\r\nend;\r\n\r\nprocedure TJvScrollMaxBands.Paint;\r\nvar\r\n R: TRect;\r\n S1: string;\r\nbegin\r\n if (csDesigning in ComponentState) and\r\n (ControlCount = 0) and\r\n (Canvas.Handle <> NullHandle) then\r\n begin\r\n R := ClientRect;\r\n Canvas.Font.Color := clAppWorkSpace;\r\n S1 := RsRightClickAndChooseAddBand;\r\n DrawText(Canvas.Handle, S1, -1, R, DT_WORDBREAK {or DT_CENTER or DT_VCENTER});\r\n end;\r\nend;\r\n\r\n//=== { TJvScrollMax } =======================================================\r\n\r\nconstructor TJvScrollMax.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n ControlStyle := ControlStyle - [csSetCaption, csAcceptsControls];\r\n Caption := '';\r\n Width := 250;\r\n Height := 150;\r\n BorderWidth := 3;\r\n FExpandedHeight := -1;\r\n FButtonFont := TFont.Create;\r\n FButtonFont.Name := 'Small Fonts';\r\n FButtonFont.Size := 7;\r\n FButtonFont.OnChange := ButtonFontChanged;\r\n FButtonVisible := True;\r\n FBeveled := True;\r\n ParentColor := True;\r\n FPnlEdit := TJvScrollMaxBands.Create(Self);\r\n with FPnlEdit do\r\n begin\r\n Align := alClient;\r\n Parent := Self;\r\n ControlStyle := ControlStyle + [csAcceptsControls];\r\n ParentColor := True;\r\n end;\r\n FScrollBar := TJvPanelScrollBar.Create(Self);\r\n with FScrollBar do\r\n begin\r\n Inclusive := True;\r\n Parent := Self;\r\n Width := 7;\r\n Align := alRight;\r\n Max := FPnlEdit.Height;\r\n Page := Self.Height;\r\n OnScroll := ScrollBarScroll;\r\n ParentColor := True;\r\n Visible := True;\r\n DesignInteractive := True;\r\n end;\r\n {$IFDEF JVCLThemesEnabled}\r\n ParentBackground := True;\r\n {$ENDIF JVCLThemesEnabled}\r\nend;\r\n\r\ndestructor TJvScrollMax.Destroy;\r\nbegin\r\n FButtonFont.Free;\r\n inherited Destroy;\r\nend;\r\n\r\n{$IFDEF JVCLThemesEnabled}\r\nprocedure TJvScrollMax.SetParentBackground(Value: Boolean);\r\nbegin\r\n inherited SetParentBackground(Value);\r\n if Assigned(FPnlEdit) then\r\n FPnlEdit.ParentBackground := Value;\r\n if Assigned(FScrollBar) then\r\n FScrollBar.ParentBackground := Value;\r\nend;\r\n{$ENDIF JVCLThemesEnabled}\r\n\r\n\r\nprocedure TJvScrollMax.CreateParams(var Params: TCreateParams);\r\nbegin\r\n inherited CreateParams(Params);\r\n with Params do\r\n begin\r\n Style := Style or WS_CLIPCHILDREN;\r\n ExStyle := ExStyle or WS_EX_CONTROLPARENT;\r\n end;\r\nend;\r\n\r\n\r\nprocedure TJvScrollMax.Loaded;\r\nbegin\r\n inherited Loaded;\r\n Resize;\r\n FPnlEdit.Realign;\r\nend;\r\n\r\nprocedure TJvScrollMax.SetButtonFont(Value: TFont);\r\nbegin\r\n FButtonFont.Assign(Value);\r\nend;\r\n\r\nprocedure TJvScrollMax.SetButtonVisible(const Value: Boolean);\r\nbegin\r\n if FButtonVisible <> Value then\r\n begin\r\n FButtonVisible := Value;\r\n FPnlEdit.NotifyControls(CM_PARENTBUTTONVISIBLECHANGED);\r\n end;\r\nend;\r\n\r\nprocedure TJvScrollMax.SetBeveled(const Value: Boolean);\r\nbegin\r\n if FBeveled <> Value then\r\n begin\r\n FBeveled := Value;\r\n FPnlEdit.NotifyControls(CM_PARENTBEVELEDCHANGED);\r\n end;\r\nend;\r\n\r\nprocedure TJvScrollMax.ButtonFontChanged(Sender: TObject);\r\nbegin\r\n FPnlEdit.NotifyControls(CM_PARENTBUTTONFONTCHANGED);\r\nend;\r\n\r\nprocedure TJvScrollMax.MouseControls(AControls: array of TControl);\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := Low(AControls) to High(AControls) do\r\n begin\r\n TJvScrollMax(AControls[I]).OnMouseDown := BandMouseDown;\r\n TJvScrollMax(AControls[I]).OnMouseMove := BandMouseMove;\r\n TJvScrollMax(AControls[I]).OnMouseUp := BandMouseUp;\r\n end;\r\nend;\r\n\r\nprocedure TJvScrollMax.MouseClasses(AControlClasses: array of TControlClass);\r\nvar\r\n I, IB, iC: Integer;\r\nbegin\r\n for I := Low(AControlClasses) to High(AControlClasses) do\r\n for IB := 0 to BandCount - 1 do\r\n for iC := 0 to Bands[IB].ControlCount - 1 do\r\n if Bands[IB].Controls[iC] is AControlClasses[I] then\r\n begin\r\n TJvScrollMax(Bands[IB].Controls[iC]).OnMouseDown := BandMouseDown;\r\n TJvScrollMax(Bands[IB].Controls[iC]).OnMouseMove := BandMouseMove;\r\n TJvScrollMax(Bands[IB].Controls[iC]).OnMouseUp := BandMouseUp;\r\n end;\r\nend;\r\n\r\nprocedure TJvScrollMax.Correct;\r\nvar\r\n Sm: Integer;\r\n CH: Integer;\r\nbegin\r\n if BandCount > 0 then\r\n begin\r\n Sm := 0;\r\n CH := FPnlEdit.Height;\r\n if (Bands[BandCount - 1].BoundsRect.Bottom < CH) and (Bands[0].Top < 0) then\r\n Sm := (CH - Bands[BandCount - 1].BoundsRect.Bottom);\r\n if Bands[0].Top + Sm > 0 then\r\n Sm := -Bands[0].Top;\r\n if Sm <> 0 then\r\n begin\r\n FPnlEdit.ScrollControls(Sm);\r\n FScrollBar.Pos := -Bands[0].Top;\r\n FScrollPos := FScrollBar.Pos;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvScrollMax.BandMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);\r\nvar\r\n CH: Integer;\r\nbegin\r\n if (Button = mbLeft) and (BandCount > 0) then\r\n begin\r\n FY := (Sender as TControl).ClientToScreen(Point(0, Y)).Y;\r\n CH := FPnlEdit.Height;\r\n if (Bands[BandCount - 1].BoundsRect.Bottom > CH) or\r\n (Bands[0].Top < 0) then\r\n Screen.Cursor := crRAHandMove\r\n else\r\n Screen.Cursor := crDefault;\r\n end;\r\nend;\r\n\r\nprocedure TJvScrollMax.BandMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);\r\nvar\r\n Sm: Integer;\r\n CH: Integer;\r\nbegin\r\n if (ssLeft in Shift) and (BandCount > 0) then\r\n begin\r\n Y := (Sender as TControl).ClientToScreen(Point(0, Y)).Y;\r\n CH := FPnlEdit.Height;\r\n if not (Sender = FScrollBar.Scroller) then\r\n Sm := Y - FY\r\n else\r\n Sm := FY - Y;\r\n if Sm < 0 then {Up}\r\n begin\r\n if not (Bands[BandCount - 1].BoundsRect.Bottom > CH) then\r\n Sm := 0\r\n else\r\n if Bands[BandCount - 1].BoundsRect.Bottom + Sm < CH then\r\n Sm := CH - Bands[BandCount - 1].BoundsRect.Bottom;\r\n end\r\n else\r\n if Sm > 0 then {Down}\r\n begin\r\n if not (Bands[0].Top < 0) then\r\n Sm := 0\r\n else\r\n if Bands[0].Top + Sm > 0 then\r\n Sm := -Bands[0].Top;\r\n end;\r\n if Sm <> 0 then\r\n begin\r\n FPnlEdit.ScrollControls(Sm);\r\n FScrollBar.Pos := -Bands[0].Top;\r\n FScrollPos := FScrollBar.Pos;\r\n end;\r\n FY := Y;\r\n Correct;\r\n end;\r\nend;\r\n\r\nprocedure TJvScrollMax.BandMouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);\r\nbegin\r\n Screen.Cursor := crDefault;\r\nend;\r\n\r\nfunction TJvScrollMax.GetBand(Index: Integer): TJvScrollMaxBand;\r\nbegin\r\n Result := TJvScrollMaxBand(FPnlEdit.Controls[Index]);\r\nend;\r\n\r\nfunction TJvScrollMax.GetBandCount: Integer;\r\nbegin\r\n Result := FPnlEdit.ControlCount;\r\nend;\r\n\r\nprocedure TJvScrollMax.GetChildren(Proc: TGetChildProc; Root: TComponent);\r\nbegin\r\n FPnlEdit.GetChildren(Proc, Root);\r\nend;\r\n\r\nfunction TJvScrollMax.GetChildParent: TComponent;\r\nbegin\r\n Result := FPnlEdit;\r\nend;\r\n\r\nprocedure TJvScrollMax.SetScrollPos(const Value: Integer);\r\nbegin\r\n if FScrollPos <> Value then\r\n begin\r\n FScrollPos := Value;\r\n if not (csLoading in ComponentState) then\r\n begin\r\n if FScrollPos > FScrollBar.Max - FScrollBar.Page then\r\n FScrollPos := FScrollBar.Max - FScrollBar.Page;\r\n if FScrollPos < 0 then\r\n FScrollPos := 0;\r\n DesignerModified(Self);\r\n FPnlEdit.Realign;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvScrollMax.ScrollBarScroll(Sender: TObject);\r\nbegin\r\n ScrollPos := FScrollBar.Pos;\r\n if Assigned(FOnScroll) then\r\n FOnScroll(Self);\r\nend;\r\n\r\nprocedure TJvScrollMax.ScrollInView(AControl: TControl);\r\nvar\r\n I: Integer;\r\n Band: TJvScrollMaxBand;\r\n Rect: TRect;\r\nbegin\r\n Band := nil;\r\n for I := 0 to FPnlEdit.ControlCount - 1 do\r\n if (FPnlEdit.Controls[I] as TJvScrollMaxBand).ContainsControl(AControl) then\r\n begin\r\n Band := FPnlEdit.Controls[I] as TJvScrollMaxBand;\r\n Break;\r\n end;\r\n if Band = nil then\r\n raise EJvScrollMaxError.CreateResFmt(@RsEControlsNotAChildOfs, [AControl.Name, Parent.Name]);\r\n Band.Expanded := True;\r\n Rect := AControl.ClientRect;\r\n Dec(Rect.Top, BevelWidth + BorderWidth + 4);\r\n Inc(Rect.Bottom, BevelWidth + BorderWidth + 4);\r\n Rect.TopLeft := ScreenToClient(AControl.ClientToScreen(Rect.TopLeft));\r\n Rect.BottomRight := ScreenToClient(AControl.ClientToScreen(Rect.BottomRight));\r\n if Rect.Top < 0 then\r\n ScrollPos := ScrollPos + Rect.Top\r\n else\r\n if Rect.Bottom > ClientHeight then\r\n begin\r\n if Rect.Bottom - Rect.Top > ClientHeight then\r\n Rect.Bottom := Rect.Top + ClientHeight;\r\n ScrollPos := ScrollPos + Rect.Bottom - ClientHeight;\r\n end;\r\nend;\r\n\r\nprocedure TJvScrollMax.SetAutoHeight(const Value: Boolean);\r\nbegin\r\n if FAutoHeight <> Value then\r\n begin\r\n FAutoHeight := Value;\r\n if FAutoHeight then\r\n CorrectHeight;\r\n end;\r\nend;\r\n\r\nprocedure TJvScrollMax.SetExpandedHeight(const Value: Integer);\r\nbegin\r\n if FExpandedHeight <> Value then\r\n begin\r\n FExpandedHeight := Value;\r\n if FAutoHeight then\r\n CorrectHeight;\r\n end;\r\nend;\r\n\r\nprocedure TJvScrollMax.Resize;\r\nbegin\r\n inherited Resize;\r\n if FAutoHeight and (BandCount > 0) and\r\n not AllCollapsed and (FExpandedHeight > -1) then\r\n FExpandedHeight := Height;\r\n if FAutoHeight then\r\n CorrectHeight;\r\nend;\r\n\r\nprocedure TJvScrollMax.CorrectHeight;\r\nvar\r\n I, H: Integer;\r\n Band: TJvScrollMaxBand;\r\nbegin\r\n if not FAutoHeight or (BandCount = 0) then\r\n Exit;\r\n if AllCollapsed then\r\n begin\r\n H := 0;\r\n for I := 0 to BandCount - 1 do\r\n Inc(H, Bands[I].Height);\r\n ClientHeight := H + 2 * PanelBorder(Self);\r\n end\r\n else\r\n if FExpandedHeight <> -1 then\r\n Height := FExpandedHeight\r\n else\r\n begin\r\n H := 0;\r\n Band := nil;\r\n for I := 0 to BandCount - 1 do\r\n if Bands[I].Height > H then\r\n begin\r\n Band := Bands[I];\r\n H := Band.Height;\r\n end;\r\n H := 0;\r\n for I := 0 to BandCount - 1 do\r\n if Bands[I] = Band then\r\n Inc(H, Bands[I].Height)\r\n else\r\n Inc(H, Bands[I].CollapsedHeight);\r\n ClientHeight := H + 2 * PanelBorder(Self);\r\n end;\r\nend;\r\n\r\nfunction TJvScrollMax.AllCollapsed: Boolean;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := False;\r\n for I := 0 to BandCount - 1 do\r\n if Bands[I].Expanded then\r\n Exit;\r\n Result := True;\r\nend;\r\n\r\nfunction TJvScrollMax.AllExpanded: Boolean;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := False;\r\n for I := 0 to BandCount - 1 do\r\n if not Bands[I].Expanded then\r\n Exit;\r\n Result := True;\r\nend;\r\n\r\nprocedure TJvScrollMax.AddBand(Band: TJvScrollMaxBand);\r\nbegin\r\n Band.Parent := GetChildParent as TWinControl;\r\nend;\r\n\r\nfunction TJvScrollMax.GetScrollBarWidth: Cardinal;\r\nbegin\r\n Result := FScrollBar.Width;\r\nend;\r\n\r\nprocedure TJvScrollMax.SetScrollBarWidth(const Value: Cardinal);\r\nbegin\r\n if Value >= 4 then\r\n FScrollBar.Width := Value;\r\nend;\r\n\r\nfunction TJvScrollMax.GetScrollBarVisible: Boolean;\r\nbegin\r\n Result := FScrollBar.Visible;\r\nend;\r\n\r\nprocedure TJvScrollMax.SetScrollBarVisible(const Value: Boolean);\r\nbegin\r\n FScrollBar.Visible := Value;\r\n if csDesigning in ComponentState then\r\n if not Value then\r\n FScrollBar.Parent := nil\r\n else\r\n FScrollBar.Parent := Self;\r\nend;\r\n\r\nprocedure TJvScrollMax.SetOneExpanded(const Value: Boolean);\r\nbegin\r\n if FOneExpanded <> Value then\r\n begin\r\n FOneExpanded := Value;\r\n { .. }\r\n end;\r\nend;\r\n\r\n{ (rom) deactivated can cause problems\r\ninitialization\r\n crRAHand := DefineCursor('JvHANDCURSOR');\r\n crRAHandMove := DefineCursor('JvHANDMOVECURSOR');\r\n}\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvScrollPanel.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvScrollPanel.PAS, released on 2002-05-26.\r\n\r\nThe Initial Developer of the Original Code is Peter Thrnqvist [peter3 at sourceforge dot net]\r\nPortions created by Peter Thrnqvist are Copyright (C) 2002 Peter Thrnqvist.\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nDescription:\r\n A scrolling TToolWindow like the ones in IE 4.0 with popup scrollbuttons\r\n either on top/bottom or left/right edge.\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvScrollPanel.pas 13104 2011-09-07 06:50:43Z obones $\r\n\r\nunit JvScrollPanel;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n SysUtils, Classes,\r\n Windows, Messages, Graphics, Controls, ToolWin, ExtCtrls,\r\n JvComponent, JvExForms;\r\n\r\ntype\r\n TJvCustomScrollPanel = class;\r\n TJvDivideKind = (dkDivider, dkSeparator);\r\n TJvScrollKind = (sbUp, sbDown, sbLeft, sbRight);\r\n /// (DFCS_SCROLLUP, DFCS_SCROLLDOWN, DFCS_SCROLLLEFT, DFCS_SCROLLRIGHT);\r\n TJvScrollDirection = (sdHorizontal, sdVertical);\r\n TJvScrollingEvent = procedure(Sender: TObject; var AllowChange: Boolean; Kind: TJvScrollKind) of object;\r\n TJvScrolledEvent = procedure(Sender: TObject; Kind: TJvScrollKind) of object;\r\n\r\n TJvDivider = class(TJvGraphicControl)\r\n private\r\n FKind: TJvDivideKind;\r\n FVertical: Boolean;\r\n procedure SetKind(Value: TJvDivideKind);\r\n procedure SetVertical(Value: Boolean);\r\n protected\r\n procedure Paint; override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n published\r\n property Align;\r\n property Vertical: Boolean read FVertical write SetVertical default True;\r\n property Kind: TJvDivideKind read FKind write SetKind default dkDivider;\r\n end;\r\n\r\n TJvScrollButton = class(TJvCustomControl)\r\n private\r\n FDown: Boolean;\r\n FRepeat: Boolean;\r\n FFlat: Boolean;\r\n FAutoRepeat: Boolean;\r\n FIncrement: Word;\r\n FTimer: TTimer;\r\n FKind: TJvScrollKind;\r\n procedure SetKind(Value: TJvScrollKind);\r\n procedure SetFlat(Value: Boolean);\r\n procedure OnTime(Sender: TObject);\r\n protected\r\n procedure SetPosition; virtual;\r\n procedure Paint; override;\r\n procedure Click; override;\r\n procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;\r\n procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;\r\n procedure MouseEnter(Control: TControl); override;\r\n procedure MouseLeave(Control: TControl); override;\r\n procedure EnabledChanged; override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n published\r\n property AutoRepeat: Boolean read FAutoRepeat write FAutoRepeat default False;\r\n property Flat: Boolean read FFlat write SetFlat default False;\r\n property Kind: TJvScrollKind read FKind write SetKind default sbUp;\r\n property Increment: Word read FIncrement write FIncrement default 16;\r\n property Width default 16;\r\n property Height default 16;\r\n end;\r\n\r\n TJvCustomScrollPanel = class(TJvExToolWindow)\r\n private\r\n FScrollDirection: TJvScrollDirection;\r\n FScrollAmount: Word;\r\n FAutoHide: Boolean;\r\n FAutoRepeat: Boolean;\r\n FAutoArrange: Boolean;\r\n FUpLeft: TJvScrollButton;\r\n FDownRight: TJvScrollButton;\r\n FOnScrolling: TJvScrollingEvent;\r\n FOnScrolled: TJvScrolledEvent;\r\n FFlat: Boolean;\r\n procedure SetAutoArrange(Value: Boolean);\r\n procedure SetAutoHide(Value: Boolean);\r\n procedure SetScrollDirection(Value: TJvScrollDirection);\r\n procedure SetFlat(Value: Boolean);\r\n procedure AlignArrows;\r\n procedure UpdateVisible;\r\n procedure ArrangeChildren;\r\n procedure SetupArrows;\r\n procedure SetScrollAmount(const Value: Word);\r\n protected\r\n procedure VisibleChanged; override;\r\n procedure EnabledChanged; override;\r\n procedure SetParent( AParent: TWinControl); override;\r\n procedure Notification(AComponent: TComponent; Operation: TOperation); override;\r\n property AutoHide: Boolean read FAutoHide write SetAutoHide;\r\n property AutoRepeat: Boolean read FAutoRepeat write FAutoRepeat;\r\n property AutoArrange: Boolean read FAutoArrange write SetAutoArrange default False;\r\n property Flat: Boolean read FFlat write SetFlat;\r\n property ScrollDirection: TJvScrollDirection read FScrollDirection write SetScrollDirection;\r\n property ScrollAmount: Word read FScrollAmount write SetScrollAmount default 16;\r\n property OnScrolling: TJvScrollingEvent read FOnScrolling write FOnScrolling;\r\n property OnScrolled: TJvScrolledEvent read FOnScrolled write FOnScrolled;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n procedure SetBounds(ALeft, ATop, AWidth, AHeight: Integer); override;\r\n published\r\n property Align default alTop;\r\n property Height default 35;\r\n end;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvScrollingWindow = class(TJvCustomScrollPanel)\r\n public\r\n constructor Create(AComponent: TComponent); override;\r\n published\r\n property AutoArrange;\r\n property AutoHide default True;\r\n property AutoRepeat default False;\r\n property Flat;\r\n property ScrollDirection default sdHorizontal;\r\n property ScrollAmount;\r\n { inherited ones: }\r\n property Align;\r\n property BorderWidth;\r\n property EdgeInner;\r\n property EdgeOuter;\r\n property EdgeBorders;\r\n/// property BevelInner;\r\n/// property BevelOuter;\r\n/// property BevelKind;\r\n/// property BevelWidth;\r\n property Enabled;\r\n property ShowHint;\r\n property Hint;\r\n property ParentShowHint;\r\n property PopupMenu;\r\n property ImeMode;\r\n property ImeName;\r\n property Color;\r\n property ParentColor;\r\n property OnEnter;\r\n property OnExit;\r\n property OnKeyDown;\r\n property OnKeyPress;\r\n property OnKeyUp;\r\n property OnScrolling;\r\n property OnScrolled;\r\n property TabOrder;\r\n property TabStop;\r\n property HelpContext;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvScrollPanel.pas $';\r\n Revision: '$Revision: 13104 $';\r\n Date: '$Date: 2011-09-07 08:50:43 +0200 (mer. 07 sept. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n Math,\r\n JvThemes, JvExControls;\r\n\r\nconst\r\n cInitTime = 360;\r\n cTimeDelay = 100;\r\n\r\n{\r\nprocedure TileBitmap(Dest: TControl; Source: TBitmap);\r\nvar\r\n X, Y, W, H: Longint;\r\n DR,SR: TRect;\r\n Tmp: TBitmap;\r\n Canvas: TControlCanvas;\r\nbegin\r\n if not Source.Empty then\r\n begin\r\n with Source do\r\n begin\r\n W := Width;\r\n H := Height;\r\n end;\r\n\r\n Tmp := TBitmap.Create;\r\n Canvas := TControlCanvas.Create;\r\n Canvas.Control := Dest;\r\n Tmp.Width := Dest.Width;\r\n Tmp.Height := Dest.Height;\r\n\r\n Y := 0;\r\n SR := Rect(0,0,W,H);\r\n while y < Dest.Height do\r\n begin\r\n X := 0;\r\n while X < Dest.Width do\r\n begin\r\n DR := Rect(X,Y,X+W,Y+H);\r\n Tmp.Canvas.CopyRect(DR,Source.Canvas,SR);\r\n Inc(X, W);\r\n end;\r\n Inc(Y, H);\r\n end;\r\n BitBlt(Canvas.Handle,0,0,Dest.Width,Dest.Height,Tmp.Handle,0,0,SRCCOPY);\r\n// Canvas.Draw(0,0,Tmp);\r\n Tmp.Free;\r\n Canvas.Free;\r\n end;\r\nend;\r\n}\r\n\r\n//=== { TJvDivider } =========================================================\r\n\r\nconstructor TJvDivider.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n SetBounds(0, 0, 16, 16);\r\n FVertical := True;\r\n FKind := dkDivider;\r\nend;\r\n\r\nprocedure TJvDivider.SetVertical(Value: Boolean);\r\nbegin\r\n if FVertical <> Value then\r\n begin\r\n FVertical := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvDivider.SetKind(Value: TJvDivideKind);\r\nbegin\r\n if FKind <> Value then\r\n begin\r\n FKind := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvDivider.Paint;\r\nvar\r\n R: TRect;\r\nbegin\r\n if not Visible then\r\n Exit;\r\n if FKind = dkDivider then\r\n with Canvas do\r\n begin\r\n if FVertical then\r\n begin\r\n R := Rect(Width div 2 - 1, 1, Width, Height - 1);\r\n DrawEdge(Handle, R, EDGE_ETCHED, BF_LEFT);\r\n end\r\n else\r\n begin\r\n R := Rect(1, Height div 2 - 1, Width, Height - 1);\r\n DrawEdge(Handle, R, EDGE_ETCHED, BF_TOP);\r\n end;\r\n end;\r\n if csDesigning in ComponentState then\r\n with Canvas do\r\n begin\r\n Pen.Style := psDot;\r\n Pen.Color := clBtnShadow;\r\n Brush.Style := bsClear;\r\n Rectangle(0, 0, ClientWidth, ClientHeight);\r\n end;\r\nend;\r\n\r\n//=== { TJvScrollButton } ====================================================\r\n\r\nconstructor TJvScrollButton.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n ControlStyle := ControlStyle - [csDoubleClicks, csSetCaption];\r\n FDown := False;\r\n FIncrement := 16;\r\n FAutoRepeat := False;\r\n FFlat := False;\r\n FKind := sbUp;\r\n Width := 16;\r\n Height := 16;\r\nend;\r\n\r\nprocedure TJvScrollButton.SetKind(Value: TJvScrollKind);\r\nbegin\r\n if FKind <> Value then\r\n begin\r\n FKind := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvScrollButton.SetFlat(Value: Boolean);\r\nbegin\r\n if FFlat <> Value then\r\n begin\r\n FFlat := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvScrollButton.MouseEnter(Control: TControl);\r\nbegin\r\n if csDesigning in ComponentState then\r\n Exit;\r\n if not MouseOver then\r\n begin\r\n inherited MouseEnter(Control);\r\n if FFlat then\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvScrollButton.MouseLeave(Control: TControl);\r\nbegin\r\n if MouseOver then\r\n begin\r\n FDown := False;\r\n inherited MouseLeave(Control);\r\n if FFlat then\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvScrollButton.Paint;\r\nconst\r\n Kinds: array [TJvScrollKind] of Integer =\r\n (DFCS_SCROLLUP, DFCS_SCROLLDOWN, DFCS_SCROLLLEFT, DFCS_SCROLLRIGHT);\r\nvar\r\n Flags: Integer;\r\n R: TRect;\r\nbegin\r\n if not Visible then\r\n Exit;\r\n R := GetClientRect;\r\n Flags := Kinds[FKind];\r\n\r\n if not Enabled then\r\n begin\r\n FDown := False;\r\n MouseOver := False;\r\n Flags := Flags or DFCS_INACTIVE or DFCS_FLAT;\r\n end;\r\n\r\n if FDown then\r\n Flags := Flags or DFCS_PUSHED;\r\n\r\n if FFlat and not MouseOver then\r\n Flags := Flags or DFCS_FLAT;\r\n\r\n if MouseOver then\r\n begin\r\n if FKind in [sbUp, sbDown] then\r\n OffsetRect(R, 0, 1)\r\n else\r\n OffsetRect(R, 1, 0);\r\n end;\r\n\r\n DrawFrameControl(Canvas.Handle, R, DFC_SCROLL, Flags);\r\n Frame3D(Canvas, R, clBtnFace, clBtnFace, 1);\r\n if FDown then\r\n Frame3D(Canvas, R, clBtnShadow, clBtnHighLight, 1);\r\nend;\r\n\r\nprocedure TJvScrollButton.Click;\r\nbegin\r\n if Enabled then\r\n begin\r\n inherited Click;\r\n ReleaseCapture;\r\n end;\r\nend;\r\n\r\nprocedure TJvScrollButton.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);\r\nbegin\r\n FDown := True;\r\n inherited MouseDown(Button, Shift, X, Y);\r\n { AutoRepeat }\r\n if Parent is TJvCustomScrollPanel then\r\n FAutoRepeat := (Parent as TJvCustomScrollPanel).AutoRepeat;\r\n if FAutoRepeat then\r\n begin\r\n if not Assigned(FTimer) then\r\n FTimer := TTimer.Create(Self);\r\n with FTimer do\r\n begin\r\n OnTimer := OnTime;\r\n Interval := cInitTime;\r\n Enabled := True;\r\n end;\r\n end;\r\n Repaint;\r\nend;\r\n\r\nprocedure TJvScrollButton.MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);\r\nbegin\r\n if not FRepeat then\r\n SetPosition;\r\n FRepeat := False;\r\n inherited MouseUp(Button, Shift, X, Y);\r\n FreeAndNil(FTimer);\r\n FDown := False;\r\n Repaint;\r\nend;\r\n\r\nprocedure TJvScrollButton.SetPosition;\r\nvar\r\n AllowScroll: Boolean;\r\n Sp: TJvCustomScrollPanel;\r\nbegin\r\n if (Parent = nil) or not (Parent is TJvCustomScrollPanel) or not Parent.Visible then\r\n Exit;\r\n Sp := TJvCustomScrollPanel(Parent);\r\n AllowScroll := True;\r\n if Assigned(Sp.OnScrolling) then\r\n Sp.OnScrolling(Self, AllowScroll, FKind);\r\n if not AllowScroll then\r\n Exit;\r\n\r\n case FKind of\r\n sbUp:\r\n Sp.ScrollBy(0, FIncrement);\r\n sbDown:\r\n Sp.ScrollBy(0, -FIncrement);\r\n sbLeft:\r\n Sp.ScrollBy(FIncrement, 0);\r\n sbRight:\r\n Sp.ScrollBy(-FIncrement, 0);\r\n end;\r\n if Assigned(Sp.OnScrolled) then\r\n Sp.OnScrolled(Self, FKind);\r\n Sp.UpdateVisible;\r\nend;\r\n\r\nprocedure TJvScrollButton.OnTime(Sender: TObject);\r\nbegin\r\n FTimer.Interval := cTimeDelay;\r\n if FDown and MouseCapture then\r\n begin\r\n SetPosition;\r\n FRepeat := True;\r\n if Parent <> nil then\r\n Parent.Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvScrollButton.EnabledChanged;\r\nbegin\r\n inherited EnabledChanged;\r\n if Assigned(Parent) then\r\n Enabled := Parent.Enabled;\r\n Invalidate;\r\nend;\r\n\r\n//=== { TJvCustomScrollPanel } ===============================================\r\n\r\nconstructor TJvCustomScrollPanel.Create(AOwner: TComponent);\r\nbegin\r\n // We must set the csCreating flag ourselves into ControlState so that\r\n // other functions can use it. In particular, the Notification method called\r\n // by one of the inherited Create constructors must see it so as to not call\r\n // Invalidate. If it calls it during creation, it triggers a big AV.\r\n // Note that it doesn't seem that the VCL uses that flag itself.\r\n ControlState := ControlState + [csCreating];\r\n try\r\n inherited Create(AOwner);\r\n // this is very strange: without it I get a \"Control '' has no parent window\" error\r\n // when dropping it in design-time. Never seen the need before\r\n // (rom) probably assigning Align causes it. That needs a parent.\r\n if AOwner is TWinControl then\r\n Parent := TWinControl(AOwner);\r\n ControlStyle := ControlStyle + [csAcceptsControls];\r\n IncludeThemeStyle(Self, [csParentBackground]);\r\n BevelInner := bvRaised;\r\n BevelOuter := bvNone;\r\n BevelKind := bkTile;\r\n FScrollDirection := sdHorizontal;\r\n FScrollAmount := 16;\r\n Align := alTop;\r\n Height := 35;\r\n SetupArrows;\r\n finally\r\n ControlState := ControlState - [csCreating];\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomScrollPanel.AlignArrows;\r\nbegin\r\n if FUpLeft = nil then\r\n Exit;\r\n case FScrollDirection of\r\n sdVertical:\r\n begin\r\n FUpLeft.Kind := sbUp;\r\n FUpLeft.SetBounds(0, 0, ClientWidth, 16);\r\n// FUpLeft.Anchors := [akTop, akLeft, akRight];\r\n FUpLeft.Align := alTop;\r\n\r\n FDownRight.Kind := sbDown;\r\n FDownRight.SetBounds(0, ClientHeight - 16, ClientWidth, 16);\r\n// FDownRight.Anchors := [akLeft, akRight, akBottom];\r\n FDownRight.Align := alBottom;\r\n end;\r\n sdHorizontal:\r\n begin\r\n FUpLeft.Kind := sbLeft;\r\n FUpLeft.SetBounds(0, 0, 16, ClientHeight);\r\n// FUpLeft.Anchors := [akTop, akLeft, akBottom];\r\n FUpLeft.Align := alLeft;\r\n\r\n FDownRight.Kind := sbRight;\r\n FDownRight.SetBounds(ClientWidth - 16, 0, 16, ClientHeight);\r\n// FDownRight.Anchors := [akTop, akRight, akBottom];\r\n FDownRight.Align := alRight;\r\n end;\r\n end;\r\n UpdateVisible;\r\nend;\r\n\r\nprocedure TJvCustomScrollPanel.SetAutoArrange(Value: Boolean);\r\nbegin\r\n if FAutoArrange <> Value then\r\n FAutoArrange := Value;\r\nend;\r\n\r\nprocedure TJvCustomScrollPanel.SetAutoHide(Value: Boolean);\r\nbegin\r\n if FAutoHide <> Value then\r\n begin\r\n FAutoHide := Value;\r\n UpdateVisible;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomScrollPanel.SetScrollAmount(const Value: Word);\r\nbegin\r\n if FScrollAmount <> Value then\r\n begin\r\n FScrollAmount := Value;\r\n if Assigned(FUpLeft) then\r\n FUpLeft.Increment := Value;\r\n if Assigned(FDownRight) then\r\n FDownRight.Increment := Value;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomScrollPanel.SetScrollDirection(Value: TJvScrollDirection);\r\nbegin\r\n if FScrollDirection <> Value then\r\n begin\r\n FScrollDirection := Value;\r\n if FAutoArrange then\r\n ArrangeChildren;\r\n Invalidate;\r\n AlignArrows;\r\n UpdateVisible;\r\n AlignArrows;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomScrollPanel.ArrangeChildren;\r\nvar\r\n I: Integer;\r\nbegin\r\n if FUpLeft = nil then\r\n Exit;\r\n DisableAlign;\r\n try\r\n for I := 0 to ControlCount - 1 do\r\n if (Controls[I] <> FUpLeft) and (Controls[I] <> FDownRight) then\r\n Controls[I].SetBounds(Controls[I].Top, Controls[I].Left, Controls[I].Height, Controls[I].Width);\r\n if not (csLoading in ComponentState) and (Align = alNone) then\r\n SetBounds(0, 0, Height, Width);\r\n finally\r\n EnableAlign;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomScrollPanel.UpdateVisible;\r\nvar\r\n Less, More, I: Integer;\r\nbegin\r\n if FUpLeft = nil then\r\n Exit;\r\n DisableAlign;\r\n try\r\n if FAutoHide then\r\n begin\r\n if FScrollDirection = sdVertical then\r\n begin\r\n Less := ClientWidth;\r\n More := 0;\r\n for I := 0 to ControlCount - 1 do\r\n if (Controls[I] <> FUpLeft) and (Controls[I] <> FDownRight) and Controls[I].Visible then\r\n begin\r\n Less := Min(Controls[I].Top, Less);\r\n More := Max(Controls[I].Top + Controls[I].Height, More);\r\n end;\r\n FUpLeft.Visible := Less < 0;\r\n FDownRight.Visible := More > ClientHeight;\r\n end\r\n else\r\n if FScrollDirection = sdHorizontal then\r\n begin\r\n Less := ClientHeight;\r\n More := 0;\r\n for I := 0 to ControlCount - 1 do\r\n if (Controls[I] <> FUpLeft) and (Controls[I] <> FDownRight) and Controls[I].Visible then\r\n begin\r\n Less := Min(Controls[I].Left, Less);\r\n More := Max(Controls[I].Left + Controls[I].Width, More);\r\n end;\r\n FUpLeft.Visible := Less < 0;\r\n FDownRight.Visible := More > ClientWidth;\r\n end\r\n end\r\n else { always show }\r\n begin\r\n FUpLeft.Visible := True;\r\n FDownRight.Visible := True;\r\n end;\r\n finally\r\n EnableAlign;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomScrollPanel.SetFlat(Value: Boolean);\r\nbegin\r\n if FFlat <> Value then\r\n begin\r\n FFlat := Value;\r\n if FUpLeft <> nil then\r\n begin\r\n FUpLeft.Flat := FFlat;\r\n FDownRight.Flat := FFlat;\r\n end;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomScrollPanel.SetBounds(ALeft, ATop, AWidth, AHeight: Integer);\r\nbegin\r\n inherited SetBounds(ALeft, ATop, AWidth, AHeight);\r\n AlignArrows;\r\n UpdateVisible;\r\nend;\r\n\r\nprocedure TJvCustomScrollPanel.SetupArrows;\r\nbegin\r\n if FUpLeft <> nil then\r\n Exit;\r\n FUpLeft := TJvScrollButton.Create(Self);\r\n FUpLeft.FreeNotification(Self);\r\n FUpLeft.Kind := sbLeft;\r\n\r\n FDownRight := TJvScrollButton.Create(Self);\r\n FDownRight.FreeNotification(Self);\r\n FDownRight.Kind := sbRight;\r\nend;\r\n\r\nprocedure TJvCustomScrollPanel.SetParent( AParent: TWinControl);\r\nbegin\r\n inherited SetParent(AParent);\r\n if FUpLeft = nil then\r\n Exit;\r\n FUpLeft.Parent := Self;\r\n FUpLeft.Visible := True;\r\n FDownRight.Parent := Self;\r\n FDownRight.Visible := True;\r\nend;\r\n\r\nprocedure TJvCustomScrollPanel.Notification(AComponent: TComponent; Operation: TOperation);\r\nbegin\r\n inherited Notification(AComponent, Operation);\r\n if Operation = opRemove then\r\n begin\r\n if AComponent = FUpLeft then\r\n FUpLeft := nil;\r\n if AComponent = FDownRight then\r\n FDownRight := nil;\r\n end;\r\n\r\n // If we invalidate while creating, it triggers a series of exceptions\r\n // leading to an access violation at 0000000\r\n // Note that csCreating is specifically added to ControlState in the\r\n // constructor for Notification to be able to use\r\n if not (csCreating in ControlState) then\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvCustomScrollPanel.EnabledChanged;\r\nbegin\r\n inherited EnabledChanged;\r\n if FUpLeft = nil then\r\n Exit;\r\n FUpLeft.Enabled := Enabled;\r\n FDownRight.Enabled := Enabled;\r\n if AutoHide then\r\n UpdateVisible\r\n else\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvCustomScrollPanel.VisibleChanged;\r\nbegin\r\n inherited VisibleChanged;\r\n if FUpLeft = nil then\r\n Exit;\r\n FUpLeft.Visible := Visible;\r\n FDownRight.Visible := Visible;\r\nend;\r\n\r\n//=== { TJvScrollingWindow } =================================================\r\n\r\nconstructor TJvScrollingWindow.Create(AComponent: TComponent);\r\nbegin\r\n inherited Create(AComponent);\r\n AutoHide := True;\r\n AutoRepeat := False;\r\n ScrollDirection := sdHorizontal;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvScrollText.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvScrollText.PAS, released on 2001-02-28.\r\n\r\nThe Initial Developer of the Original Code is Sbastien Buysse [sbuysse att buypin dott com]\r\nPortions created by Sbastien Buysse are Copyright (C) 2001 Sbastien Buysse.\r\nAll Rights Reserved.\r\n\r\nContributor(s): Michael Beck [mbeck att bigfoot dott com]\r\n Michael Freislich [mikef att korbi dott net]\r\n Gianpiero Caretti [gpcaretti+delphi att gmail dott com]\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvScrollText.pas 13138 2011-10-26 23:17:50Z jfudickar $\r\n\r\nunit JvScrollText;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n SysUtils, Classes, Windows, Messages, Graphics, Controls, Forms, StdCtrls,\r\n JvStaticText, JvImageDrawThread, JvComponent;\r\n\r\ntype\r\n TJvScrollTextDirection = (drFromLeft, drFromRight, drFromTop, drFromBottom); // also in JvMoveableBevel, JvAppearingLabel\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvScrollText = class(TJvCustomControl)\r\n private\r\n FText: TJvStaticText;\r\n FTimerTag: Integer;\r\n FActive: Boolean;\r\n FDelay: Cardinal;\r\n FPixel: Integer;\r\n FCurrPos: Integer;\r\n FSelectable: Boolean;\r\n FScrollDirection: TJvScrollTextDirection;\r\n FScrollSaved: Integer;\r\n FItems: TStringList;\r\n FDefaultAppHintPause: Cardinal;\r\n FScroll: TJvImageDrawThread;\r\n FFont: TFont;\r\n FStartY: Integer;\r\n FDown: Boolean;\r\n FOldMouseMovePt: TPoint;\r\n FOnScrollEnd: TNotifyEvent;\r\n FStreamedActive: Boolean;\r\n function GetItems: TStrings;\r\n procedure SetItems(Value: TStrings);\r\n procedure OnScroll(Sender: TObject);\r\n procedure SetActive(const Value: Boolean);\r\n procedure SetDelay(const Value: Cardinal);\r\n procedure SetPixel(const Value: Integer);\r\n procedure SetScrollDirection(const Value: TJvScrollTextDirection);\r\n function GetAlignment: TAlignment;\r\n procedure SetAlignment(const Value: TAlignment);\r\n function GetColor: TColor;\r\n procedure SetColor(const Value: TColor);\r\n procedure FontChange(Sender: TObject);\r\n procedure ItemsChange(Sender: TObject);\r\n procedure SetFont(Value: TFont);\r\n procedure TextMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);\r\n procedure TextMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);\r\n procedure TextMouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);\r\n procedure TextMouseClick(Sender: TObject);\r\n procedure TextMouseDblClick(Sender: TObject);\r\n function GetWordWrap: Boolean;\r\n procedure SetWordWrap(const Value: Boolean);\r\n procedure DoScrollEnd;\r\n procedure CalcLineSize(ACanvas: TCanvas; const ALine: string; var ALineWidth, ALineHeight: Integer);\r\n procedure CalcTextSize;\r\n protected\r\n procedure Loaded; override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n published\r\n property Alignment: TAlignment read GetAlignment write SetAlignment;\r\n property Items: TStrings read GetItems write SetItems;\r\n property Active: Boolean read FActive write SetActive default False;\r\n property Delay: Cardinal read FDelay write SetDelay default 50;\r\n property ScrollPixels: Integer read FPixel write SetPixel default 1;\r\n property ScrollDirection: TJvScrollTextDirection read FScrollDirection write SetScrollDirection default drFromBottom;\r\n property BackgroundColor: TColor read GetColor write SetColor;\r\n property Font: TFont read FFont write SetFont;\r\n procedure Pause;\r\n procedure Unpause;\r\n procedure Reset;\r\n property Align;\r\n property ShowHint;\r\n property ParentShowHint;\r\n property Height default 150;\r\n property Width default 200;\r\n {$IFDEF JVCLThemesEnabled}\r\n property ParentBackground default True;\r\n {$ENDIF JVCLThemesEnabled}\r\n property WordWrap: Boolean read GetWordWrap write SetWordWrap;\r\n property OnMouseDown;\r\n property OnMouseMove;\r\n property OnMouseUp;\r\n property OnMouseEnter;\r\n property OnMouseLeave;\r\n property OnClick;\r\n property OnDblClick;\r\n\r\n // Triggered when the scroll has reached its end and is about to restart from its source\r\n property OnScrollEnd: TNotifyEvent read FOnScrollEnd write FOnScrollEnd;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvScrollText.pas $';\r\n Revision: '$Revision: 13138 $';\r\n Date: '$Date: 2011-10-27 01:17:50 +0200 (jeu. 27 oct. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n JvJVCLUtils, JvThemes;\r\n\r\nconstructor TJvScrollText.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n IncludeThemeStyle(Self, [csParentBackground]);\r\n Width := 200;\r\n Height := 150;\r\n FActive := False;\r\n FDelay := 50;\r\n FPixel := 1;\r\n FCurrPos := 0;\r\n FSelectable := True;\r\n FScrollDirection := drFromBottom;\r\n FItems := TStringList.Create;\r\n FItems.OnChange := ItemsChange;\r\n\r\n FText := TJvStaticText.Create(Self);\r\n FText.Parent := Self;\r\n FText.Width := Width;\r\n FText.Height := Height;\r\n FText.BorderStyle := sbsNone;\r\n FText.TabStop := False;\r\n FText.Enabled := FSelectable;\r\n FText.AutoSize := False;\r\n FText.OnMouseDown := TextMouseDown;\r\n FText.OnMouseMove := TextMouseMove;\r\n FText.OnMouseUp := TextMouseUp;\r\n FText.OnClick := TextMouseClick;\r\n FText.OnDblClick := TextMouseDblClick;\r\n\r\n FFont := TFont.Create;\r\n FFont.Assign(FText.Font);\r\n FFont.OnChange := FontChange;\r\n\r\n FTimerTag := 0;\r\n FDown := False;\r\n FDefaultAppHintPause := Application.HintPause;\r\n\r\n if not (csDesigning in ComponentState) then\r\n begin\r\n FScroll := TJvImageDrawThread.Create(True);\r\n FScroll.FreeOnTerminate := False;\r\n FScroll.Delay := FDelay;\r\n FScroll.OnDraw := OnScroll;\r\n end;\r\nend;\r\n\r\ndestructor TJvScrollText.Destroy;\r\nbegin\r\n if not (csDesigning in ComponentState) then\r\n begin\r\n FScroll.OnDraw := nil;\r\n FScroll.Free;\r\n end;\r\n Application.HintPause := FDefaultAppHintPause;\r\n FItems.Free;\r\n FText.Free;\r\n FFont.OnChange := nil;\r\n FFont.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvScrollText.DoScrollEnd;\r\nbegin\r\n if Assigned(OnScrollEnd) then\r\n OnScrollEnd(Self);\r\nend;\r\n\r\nprocedure TJvScrollText.Loaded;\r\nbegin\r\n inherited Loaded;\r\n CalcTextSize;\r\n if FStreamedActive then SetActive(True);\r\nend;\r\n\r\nprocedure TJvScrollText.SetFont(Value: TFont);\r\nbegin\r\n FFont.Assign(Value);\r\nend;\r\n\r\nprocedure TJvScrollText.TextMouseDown(Sender: TObject; Button: TMouseButton;\r\n Shift: TShiftState; X, Y: Integer);\r\nvar\r\n P: TPoint;\r\nbegin\r\n P.X := X;\r\n P.Y := Y;\r\n P := FText.ClientToScreen(P);\r\n\r\n if ScrollDirection in [drFromTop, drFromBottom] then\r\n FStartY := P.Y\r\n else\r\n FStartY := P.X;\r\n if not (csDesigning in ComponentState) then\r\n FScroll.OnDraw := nil;\r\n FDown := True;\r\n\r\n if Assigned(OnMouseDown) then\r\n begin\r\n P := ScreenToClient(P);\r\n OnMouseDown(Self, Button, Shift, P.X, P.Y);\r\n end;\r\nend;\r\n\r\nprocedure TJvScrollText.TextMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);\r\nvar\r\n NewY: Integer;\r\n P: TPoint;\r\nbegin\r\n P.X := X;\r\n P.Y := Y;\r\n P := FText.ClientToScreen(P);\r\n\r\n if FDown then\r\n begin\r\n //if NewY>0, going up, NewY<0, going down\r\n\r\n if ScrollDirection in [drFromTop, drFromBottom] then\r\n begin\r\n NewY := FStartY - P.Y;\r\n FStartY := P.Y;\r\n FCurrPos := FCurrPos - NewY;\r\n\r\n if FCurrPos < -FText.Height then\r\n FCurrPos := Height\r\n else\r\n if FCurrPos > Height then\r\n FCurrPos := -FText.Height;\r\n\r\n FText.Top := FCurrPos;\r\n end\r\n else\r\n begin\r\n NewY := FStartY - P.X;\r\n FStartY := P.X;\r\n FCurrPos := FCurrPos - NewY;\r\n\r\n if FCurrPos < -FText.Width then\r\n FCurrPos := Width\r\n else\r\n if FCurrPos > Width then\r\n FCurrPos := -FText.Width;\r\n\r\n FText.Left := FCurrPos;\r\n end;\r\n end;\r\n\r\n if Assigned(OnMouseMove) then\r\n begin\r\n P := ScreenToClient(P);\r\n if (P.X <> FOldMouseMovePt.X) or (P.Y <> FOldMouseMovePt.Y) then\r\n begin\r\n FOldMouseMovePt := P;\r\n OnMouseMove(Self, Shift, P.X, P.Y);\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvScrollText.TextMouseUp(Sender: TObject; Button: TMouseButton;\r\n Shift: TShiftState; X, Y: Integer);\r\nvar\r\n P: TPoint;\r\nbegin\r\n if not (csDesigning in ComponentState) then\r\n FScroll.OnDraw := OnScroll;\r\n FDown := False;\r\n\r\n if Assigned(OnMouseUp) then\r\n begin\r\n P.X := X;\r\n P.Y := Y;\r\n P := Self.ScreenToClient( FText.ClientToScreen(P) );\r\n OnMouseUp(Self, Button, Shift, P.X, P.Y);\r\n end;\r\nend;\r\n\r\nprocedure TJvScrollText.TextMouseClick(Sender: TObject);\r\nbegin\r\n // forward the event of the inner FText to the same event of the scroller\r\n if Assigned(OnClick) then\r\n OnClick(Self);\r\nend;\r\n\r\nprocedure TJvScrollText.TextMouseDblClick(Sender: TObject);\r\nbegin\r\n // forward the double click event of the inner FText to the same event of the scroller\r\n if Assigned(OnDblClick) then\r\n OnDblClick(Self);\r\nend;\r\n\r\nprocedure TJvScrollText.OnScroll(Sender: TObject);\r\nvar\r\n Offset: Integer;\r\n ScrollEnd: Boolean;\r\nbegin\r\n // Must exit because we are \"Synchronized\" and our parent is already\r\n // partly destroyed. If we did not exit, we would get an AV.\r\n if csDestroying in ComponentState then\r\n Exit;\r\n\r\n //tag=1 pause\r\n if FTimerTag = 1 then\r\n begin\r\n if FScrollSaved <= 0 then\r\n begin\r\n SetActive(False);\r\n FTimerTag := 0;\r\n Exit;\r\n end\r\n else\r\n begin\r\n Offset := FScrollSaved;\r\n Dec(FScrollSaved);\r\n end;\r\n end\r\n else\r\n if FTimerTag = 2 then\r\n begin\r\n if FScrollSaved >= FPixel then\r\n begin\r\n FTimerTag := 0;\r\n Offset := FPixel;\r\n end\r\n else\r\n begin\r\n Offset := FScrollSaved;\r\n Inc(FScrollSaved);\r\n end;\r\n end\r\n else\r\n Offset := FPixel;\r\n\r\n //tag=2 unpause\r\n //FScrollDirection\r\n\r\n ScrollEnd := False;\r\n case ScrollDirection of\r\n drFromTop:\r\n begin\r\n if FCurrPos > Height then\r\n begin\r\n FCurrPos := -FText.Height;\r\n ScrollEnd := True;\r\n end\r\n else\r\n FCurrPos := FCurrPos + Offset;\r\n FText.Top := FCurrPos;\r\n end;\r\n drFromRight:\r\n begin\r\n if - FCurrPos > FText.Width then\r\n begin\r\n FCurrPos := Width;\r\n ScrollEnd := True;\r\n end\r\n else\r\n FCurrPos := FCurrPos - Offset;\r\n FText.Left := FCurrPos;\r\n end;\r\n drFromLeft:\r\n begin\r\n if FCurrPos > Width then\r\n begin\r\n FCurrPos := -FText.Width;\r\n ScrollEnd := True;\r\n end\r\n else\r\n FCurrPos := FCurrPos + Offset;\r\n FText.Left := FCurrPos;\r\n end;\r\n drFromBottom:\r\n begin\r\n if - FCurrPos > FText.Height then\r\n begin\r\n FCurrPos := Height;\r\n ScrollEnd := True;\r\n end\r\n else\r\n FCurrPos := FCurrPos - Offset;\r\n FText.Top := FCurrPos;\r\n end;\r\n end;\r\n\r\n // As OnScroll is called from the draw thread's context, we\r\n // must synchronize the event call\r\n if ScrollEnd then\r\n FScroll.Synchronize(DoScrollEnd);\r\nend;\r\n\r\nprocedure TJvScrollText.Pause;\r\nbegin\r\n if FActive then\r\n begin\r\n FScrollSaved := FPixel;\r\n FTimerTag := 1;\r\n end;\r\nend;\r\n\r\nprocedure TJvScrollText.SetActive(const Value: Boolean);\r\nbegin\r\n if (csReading in ComponentState) then\r\n begin\r\n if Value then FStreamedActive := True;\r\n end\r\n else\r\n begin\r\n FActive := Value;\r\n if not (csDesigning in ComponentState) then\r\n FScroll.Paused := not Value;\r\n end;\r\nend;\r\n\r\nprocedure TJvScrollText.SetDelay(const Value: Cardinal);\r\nbegin\r\n if Value > FDefaultAppHintPause then\r\n Application.HintPause := FDefaultAppHintPause\r\n else\r\n if Value > 10 then\r\n Application.HintPause := Value - 10\r\n else\r\n Application.HintPause := Abs(Value - 1);\r\n FDelay := Value;\r\n if not (csDesigning in ComponentState) then\r\n FScroll.Delay := Value;\r\nend;\r\n\r\nprocedure TJvScrollText.SetScrollDirection(const Value: TJvScrollTextDirection);\r\nbegin\r\n FScrollDirection := Value;\r\n FText.Left := 0;\r\n FText.Top := 0;\r\n Reset;\r\nend;\r\n\r\ntype\r\n TJvStaticTextAccess = class(TJvStaticText);\r\n\r\nprocedure TJvScrollText.CalcLineSize(ACanvas: TCanvas; const ALine: string; var ALineWidth,\r\n ALineHeight: Integer);\r\nvar\r\n LineRect: TRect;\r\nbegin\r\n if ALine > '' then\r\n begin\r\n LineRect := ClientRect;\r\n TJvStaticTextAccess(FText).GetTextDisplayInfo(ACanvas.Handle, ALine, LineRect);\r\n ALineWidth := LineRect.Right - LineRect.Left;\r\n ALineHeight := LineRect.Bottom - LineRect.Top;\r\n end\r\n else\r\n begin\r\n ALineWidth := 0;\r\n ALineHeight := CanvasMaxTextHeight(ACanvas);\r\n end;\r\nend;\r\n\r\nprocedure TJvScrollText.CalcTextSize;\r\nvar\r\n I: Integer;\r\n MaxLineWidth, TotalLineHeight: Integer;\r\n LineWidth, LineHeight: Integer;\r\n Ts: TStringList;\r\n DesktopCanvas: TCanvas;\r\nbegin\r\n if csLoading in ComponentState then Exit;\r\n\r\n // calculate the Size of the memo\r\n DesktopCanvas := TCanvas.Create;\r\n try\r\n DesktopCanvas.Handle := GetDC(HWND_DESKTOP);\r\n DesktopCanvas.Font.Assign(FText.Font);\r\n MaxLineWidth := 0;\r\n TotalLineHeight := 0;\r\n Ts := TStringList.Create;\r\n try\r\n Ts.Text := FText.Caption;\r\n for I := 0 to Ts.Count - 1 do\r\n try\r\n CalcLineSize(DesktopCanvas, Ts[i], LineWidth, LineHeight);\r\n if MaxLineWidth < LineWidth then\r\n MaxLineWidth := LineWidth;\r\n TotalLineHeight := TotalLineHeight + LineHeight;\r\n except\r\n end;\r\n if TotalLineHeight <= 0 then\r\n TotalLineHeight := Height;\r\n FText.Height := TotalLineHeight;\r\n if MaxLineWidth <= 0 then\r\n MaxLineWidth := Width;\r\n FText.Width := MaxLineWidth;\r\n DesktopCanvas.Handle := 0;\r\n ReleaseDC(HWND_DESKTOP, Handle);\r\n finally\r\n Ts.Free;\r\n end;\r\n finally\r\n DesktopCanvas.Free;\r\n end;\r\n Reset;\r\nend;\r\n\r\nfunction TJvScrollText.GetItems: TStrings;\r\nbegin\r\n Result := FItems;\r\nend;\r\n\r\nprocedure TJvScrollText.SetItems(Value: TStrings);\r\nbegin\r\n FItems.Assign(Value);\r\nend;\r\n\r\nfunction TJvScrollText.GetColor: TColor;\r\nbegin\r\n Result := FText.Color;\r\nend;\r\n\r\nprocedure TJvScrollText.SetColor(const Value: TColor);\r\nbegin\r\n if (FText.Color <> Value) or (Color <> Value) then\r\n begin\r\n FText.Color := Value;\r\n Color := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvScrollText.FontChange(Sender: TObject);\r\nvar\r\n Al: TAlignment;\r\nbegin\r\n FText.Font.Assign(FFont);\r\n CalcTextSize;\r\n Al := FText.Alignment;\r\n if FText.Alignment = taCenter then\r\n FText.Alignment := taLeftJustify\r\n else\r\n FText.Alignment := taCenter;\r\n FText.Alignment := Al;\r\nend;\r\n\r\nprocedure TJvScrollText.SetPixel(const Value: Integer);\r\nbegin\r\n FPixel := Value;\r\nend;\r\n\r\nprocedure TJvScrollText.Reset;\r\nbegin\r\n case ScrollDirection of\r\n drFromTop:\r\n FCurrPos := -FText.Height;\r\n drFromLeft:\r\n FCurrPos := -FText.Width;\r\n drFromRight:\r\n FCurrPos := Width;\r\n drFromBottom:\r\n FCurrPos := Height;\r\n end;\r\nend;\r\n\r\nprocedure TJvScrollText.Unpause;\r\nbegin\r\n if not FActive then\r\n begin\r\n FScrollSaved := 0;\r\n FTimerTag := 2;\r\n SetActive(True);\r\n end;\r\nend;\r\n\r\nfunction TJvScrollText.GetAlignment: TAlignment;\r\nbegin\r\n Result := FText.Alignment;\r\nend;\r\n\r\nprocedure TJvScrollText.SetAlignment(const Value: TAlignment);\r\nbegin\r\n if FText.Alignment <> Value then\r\n begin\r\n FText.Alignment := Value;\r\n CalcTextSize;\r\n end;\r\nend;\r\n\r\nfunction TJvScrollText.GetWordWrap: Boolean;\r\nbegin\r\n Result := FText.WordWrap;\r\nend;\r\n\r\nprocedure TJvScrollText.ItemsChange(Sender: TObject);\r\nbegin\r\n FText.Caption := Items.Text;\r\n CalcTextSize;\r\nend;\r\n\r\nprocedure TJvScrollText.SetWordWrap(const Value: Boolean);\r\nbegin\r\n if FText.WordWrap <> Value then\r\n begin\r\n FText.WordWrap := Value;\r\n CalcTextSize;\r\n end;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvSearchFiles.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvSearchFiles.PAS, released on 2002-05-26.\r\n\r\nThe Initial Developer of the Original Code is Peter Thrnqvist [peter3 at sourceforge dot net]\r\nPortions created by Peter Thrnqvist are Copyright (C) 2002 Peter Thrnqvist.\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\nDavid Frauzel (DF)\r\nRemko Bonte\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nDescription:\r\n Wrapper for a file search engine.\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvSearchFiles.pas 13104 2011-09-07 06:50:43Z obones $\r\n\r\nunit JvSearchFiles;\r\n\r\n{$I jvcl.inc}\r\n{$I windowsonly.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Classes, SysUtils,\r\n {$IFDEF MSWINDOWS}\r\n Windows,\r\n {$ENDIF MSWINDOWS}\r\n JvComponentBase, JvJCLUtils, JvWin32;\r\n\r\ntype\r\n TJvAttrFlagKind = (tsMustBeSet, tsDontCare, tsMustBeUnSet);\r\n TJvDirOption = (doExcludeSubDirs, doIncludeSubDirs, doExcludeInvalidDirs,\r\n doExcludeCompleteInvalidDirs);\r\n { doExcludeSubDirs\r\n Only search in root directory.\r\n doIncludeSubDirs\r\n Search in root directory and it's sub-directories.\r\n doExcludeInvalidDirs\r\n Search in root directory and it's sub-directories; do not search in\r\n an invalid directory, but do search in the sub-directories of an\r\n invalid directory.\r\n doExcludeCompleteInvalidDirs\r\n Search in root directory and it's sub-directories; do not search in\r\n an invalid directory, and the sub-directories of an invalid directory.\r\n\r\n Invalid directory = directory with params that doesn't agree with the\r\n params specified by DirParams.\r\n }\r\n\r\n TJvSearchOption = (soAllowDuplicates, soCheckRootDirValid,\r\n soExcludeFilesInRootDir, soOwnerData, soSearchDirs, soSearchFiles, soSorted,\r\n soStripDirs, soIncludeSystemHiddenDirs, soIncludeSystemHiddenFiles);\r\n TJvSearchOptions = set of TJvSearchOption;\r\n { soAllowDuplicates\r\n Allow duplicate file/dir names in property Files and Directories.\r\n soCheckRootDirValid\r\n Check if the root-directory is valid; Must DirOption must be equal to\r\n doExcludeSubDirs or doExcludeCompleteInvalidDirs, otherwise this flag is\r\n ignored.\r\n soExcludeFilesInRootDir\r\n Do not search in the root directory.\r\n soOwnerData\r\n Do not fill property Files and Directories while searching\r\n soSearchDirs\r\n Search for directories; ie trigger OnFindDirectory event and update\r\n totals [TotalDirectories, TotalFileSize] when a valid directory is found.\r\n soSearchFiles\r\n Search for files; ie trigger OnFindFile event and update totals\r\n [TotalFileSize, TotalFiles] when a valid file is found.\r\n soSorted\r\n Keep the values in property Files and Directories sorted.\r\n soStripDirs\r\n Strip the path of a dir/file name before inserting it in property\r\n Files and Directories\r\n soIncludeSystemHiddenDirs\r\n Do NOT ignore directories that are both system and hidden.\r\n Examples of such directories are 'RECYCLER', 'System Volume Information' etc.\r\n soIncludeSystemHiddenFiles\r\n Do NOT ignore files that are both system and hidden.\r\n Examples of such files are 'pagefile.sys', 'IO.SYS' etc.\r\n\r\n }\r\n\r\n TJvSearchType = (stAttribute, stFileMask, stFileMaskCaseSensitive,\r\n stLastChangeAfter, stLastChangeBefore, stMaxSize, stMinSize);\r\n TJvSearchTypes = set of TJvSearchType;\r\n\r\n TJvFileSearchEvent = procedure(Sender: TObject; const AName: string) of object;\r\n TJvSearchFilesError = procedure(Sender: TObject; var Handled: Boolean) of object;\r\n TJvCheckEvent = procedure(Sender: TObject; var Result: Boolean) of object;\r\n\r\n TJvErrorResponse = (erAbort, erIgnore, erRaise);\r\n\r\n TJvSearchAttributes = class(TPersistent)\r\n private\r\n FIncludeAttr: DWORD;\r\n FExcludeAttr: DWORD;\r\n function GetAttr(const Index: Integer): TJvAttrFlagKind;\r\n procedure SetAttr(const Index: Integer; Value: TJvAttrFlagKind);\r\n procedure ReadIncludeAttr(Reader: TReader);\r\n procedure ReadExcludeAttr(Reader: TReader);\r\n procedure WriteIncludeAttr(Writer: TWriter);\r\n procedure WriteExcludeAttr(Writer: TWriter);\r\n protected\r\n { DefineProperties is used to publish properties IncludeAttr and\r\n ExcludeAttr }\r\n procedure DefineProperties(Filer: TFiler); override;\r\n public\r\n procedure Assign(Source: TPersistent); override;\r\n property IncludeAttr: DWORD read FIncludeAttr write FIncludeAttr;\r\n property ExcludeAttr: DWORD read FExcludeAttr write FExcludeAttr;\r\n published\r\n property ReadOnly: TJvAttrFlagKind index FILE_ATTRIBUTE_READONLY read GetAttr\r\n write SetAttr stored False;\r\n property Hidden: TJvAttrFlagKind index FILE_ATTRIBUTE_HIDDEN\r\n read GetAttr write SetAttr stored False;\r\n property System: TJvAttrFlagKind index FILE_ATTRIBUTE_SYSTEM\r\n read GetAttr write SetAttr stored False;\r\n property Archive: TJvAttrFlagKind index FILE_ATTRIBUTE_ARCHIVE\r\n read GetAttr write SetAttr stored False;\r\n property Normal: TJvAttrFlagKind index FILE_ATTRIBUTE_NORMAL\r\n read GetAttr write SetAttr stored False;\r\n property Temporary: TJvAttrFlagKind index FILE_ATTRIBUTE_TEMPORARY\r\n read GetAttr write SetAttr stored False;\r\n property SparseFile: TJvAttrFlagKind index FILE_ATTRIBUTE_SPARSE_FILE\r\n read GetAttr write SetAttr stored False;\r\n property ReparsePoint: TJvAttrFlagKind index FILE_ATTRIBUTE_REPARSE_POINT\r\n read GetAttr write SetAttr stored False;\r\n property Compressed: TJvAttrFlagKind index FILE_ATTRIBUTE_COMPRESSED\r\n read GetAttr write SetAttr stored False;\r\n property OffLine: TJvAttrFlagKind index FILE_ATTRIBUTE_OFFLINE\r\n read GetAttr write SetAttr stored False;\r\n property NotContentIndexed: TJvAttrFlagKind index\r\n FILE_ATTRIBUTE_NOT_CONTENT_INDEXED read GetAttr write SetAttr stored False;\r\n property Encrypted: TJvAttrFlagKind index FILE_ATTRIBUTE_ENCRYPTED read\r\n GetAttr write SetAttr stored False;\r\n end;\r\n\r\n TJvSearchParams = class(TPersistent)\r\n private\r\n FMaxSizeHigh: Cardinal;\r\n FMaxSizeLow: Cardinal;\r\n FMinSizeHigh: Cardinal;\r\n FMinSizeLow: Cardinal;\r\n FLastChangeBefore: TDateTime;\r\n FLastChangeBeforeFT: TFileTime;\r\n FLastChangeAfter: TDateTime;\r\n FLastChangeAfterFT: TFileTime;\r\n FSearchTypes: TJvSearchTypes;\r\n FFileMasks: TStringList;\r\n FCaseFileMasks: TStringList;\r\n FFileMaskSeperator: Char;\r\n FAttributes: TJvSearchAttributes;\r\n procedure FileMasksChange(Sender: TObject);\r\n function GetFileMask: string;\r\n function GetMaxSize: Int64;\r\n function GetMinSize: Int64;\r\n function GetFileMasks: TStrings;\r\n function IsLastChangeAfterStored: Boolean;\r\n function IsLastChangeBeforeStored: Boolean;\r\n procedure SetAttributes(const Value: TJvSearchAttributes);\r\n procedure SetFileMasks(const Value: TStrings);\r\n procedure SetFileMask(const Value: string);\r\n procedure SetLastChangeAfter(const Value: TDateTime);\r\n procedure SetLastChangeBefore(const Value: TDateTime);\r\n procedure SetMaxSize(const Value: Int64);\r\n procedure SetMinSize(const Value: Int64);\r\n procedure SetSearchTypes(const Value: TJvSearchTypes);\r\n procedure UpdateCaseMasks;\r\n public\r\n constructor Create; virtual;\r\n destructor Destroy; override;\r\n procedure Assign(Source: TPersistent); override;\r\n function Check(const AFindData: TWin32FindData): Boolean;\r\n property FileMask: string read GetFileMask write SetFileMask;\r\n property FileMaskSeperator: Char read FFileMaskSeperator write\r\n FFileMaskSeperator default ';';\r\n published\r\n property Attributes: TJvSearchAttributes read FAttributes write SetAttributes;\r\n property SearchTypes: TJvSearchTypes read FSearchTypes write SetSearchTypes default [];\r\n property MinSize: Int64 read GetMinSize write SetMinSize;\r\n property MaxSize: Int64 read GetMaxSize write SetMaxSize;\r\n property LastChangeAfter: TDateTime read FLastChangeAfter write SetLastChangeAfter\r\n stored IsLastChangeAfterStored;\r\n property LastChangeBefore: TDateTime read FLastChangeBefore write SetLastChangeBefore\r\n stored IsLastChangeBeforeStored;\r\n property FileMasks: TStrings read GetFileMasks write SetFileMasks;\r\n end;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64 or pidOSX32)]\r\n {$ENDIF RTL230_UP}\r\n TJvSearchFiles = class(TJvComponent)\r\n private\r\n FSearching: Boolean;\r\n FTotalDirectories: Integer;\r\n FTotalFiles: Integer;\r\n FTotalFileSize: Int64;\r\n FRootDirectory: string;\r\n FOnFindFile: TJvFileSearchEvent;\r\n FOnFindDirectory: TJvFileSearchEvent;\r\n FOptions: TJvSearchOptions;\r\n FOnAbort: TNotifyEvent;\r\n FOnError: TJvSearchFilesError;\r\n FOnProgress: TNotifyEvent;\r\n FDirectories: TStringList;\r\n FFiles: TStringList;\r\n FFindData: TWin32FindData;\r\n FAborting: Boolean;\r\n FErrorResponse: TJvErrorResponse;\r\n FOnCheck: TJvCheckEvent;\r\n FOnBeginScanDir: TJvFileSearchEvent;\r\n FDirOption: TJvDirOption;\r\n FDirParams: TJvSearchParams;\r\n FFileParams: TJvSearchParams;\r\n FRecurseDepth: Integer;\r\n function GetIsRootDirValid: Boolean;\r\n function GetIsDepthAllowed(const ADepth: Integer): Boolean;\r\n function GetDirectories: TStrings;\r\n function GetFiles: TStrings;\r\n procedure SetDirParams(const Value: TJvSearchParams);\r\n procedure SetFileParams(const Value: TJvSearchParams);\r\n procedure SetOptions(const Value: TJvSearchOptions);\r\n protected\r\n procedure DoBeginScanDir(const ADirName: string); virtual;\r\n procedure DoFindFile(const APath: string); virtual;\r\n procedure DoFindDir(const APath: string); virtual;\r\n procedure DoAbort; virtual;\r\n procedure DoProgress; virtual;\r\n function DoCheckDir: Boolean; virtual;\r\n function DoCheckFile: Boolean; virtual;\r\n function HandleError: Boolean; virtual;\r\n procedure Init; virtual;\r\n function EnumFiles(const ADirectoryName: string; Dirs: TStrings;\r\n const Search: Boolean): Boolean;\r\n function InternalSearch(const ADirectoryName: string;\r\n const Search: Boolean; var ADepth: Integer): Boolean; virtual;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n procedure Abort;\r\n function Search: Boolean;\r\n property FindData: TWin32FindData read FFindData;\r\n property Files: TStrings read GetFiles;\r\n property Directories: TStrings read GetDirectories;\r\n property IsRootDirValid: Boolean read GetIsRootDirValid;\r\n property Searching: Boolean read FSearching;\r\n property TotalDirectories: Integer read FTotalDirectories;\r\n property TotalFileSize: Int64 read FTotalFileSize;\r\n property TotalFiles: Integer read FTotalFiles;\r\n published\r\n property DirOption: TJvDirOption read FDirOption write FDirOption default doIncludeSubDirs;\r\n // RecurseDepth sets the number of subfolders to search. If 0, all subfolders\r\n // are searched (as long as doIncludeSubDirs is true)\r\n property RecurseDepth: Integer read FRecurseDepth write FRecurseDepth default 0;\r\n property RootDirectory: string read FRootDirectory write FRootDirectory;\r\n property Options: TJvSearchOptions read FOptions write SetOptions default [soSearchFiles];\r\n property ErrorResponse: TJvErrorResponse read FErrorResponse write\r\n FErrorResponse default erAbort;\r\n property DirParams: TJvSearchParams read FDirParams write SetDirParams;\r\n property FileParams: TJvSearchParams read FFileParams write SetFileParams;\r\n property OnBeginScanDir: TJvFileSearchEvent read FOnBeginScanDir write\r\n FOnBeginScanDir;\r\n property OnFindFile: TJvFileSearchEvent read FOnFindFile write FOnFindFile;\r\n property OnFindDirectory: TJvFileSearchEvent read FOnFindDirectory write\r\n FOnFindDirectory;\r\n property OnAbort: TNotifyEvent read FOnAbort write FOnAbort;\r\n property OnError: TJvSearchFilesError read FOnError write FOnError;\r\n { Maybe add a flag to Options to disable OnCheck }\r\n property OnCheck: TJvCheckEvent read FOnCheck write FOnCheck;\r\n // (rom) replaced ProcessMessages with OnProgress event\r\n property OnProgress: TNotifyEvent read FOnProgress write FOnProgress;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvSearchFiles.pas $';\r\n Revision: '$Revision: 13104 $';\r\n Date: '$Date: 2011-09-07 08:50:43 +0200 (mer. 07 sept. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n JclStrings, JclDateTime;\r\n\r\n{ Maybe TJvSearchFiles should be implemented with FindFirst, FindNext.\r\n There isn't a good reason to use FindFirstFile, FindNextFile instead of\r\n FindFirst, FindNext; except to prevent a little overhead perhaps. }\r\n\r\nconst\r\n CDate1_1_1980 = 29221;\r\n\r\nfunction IsDotOrDotDot(P: PChar): Boolean;\r\nbegin\r\n // check if a string is '.' (self) or '..' (parent)\r\n if P^ = '.' then\r\n begin\r\n Inc(P);\r\n Result := (P^ = #0) or ((P^ = '.') and ((P+1)^ = #0));\r\n end\r\n else\r\n Result := False;\r\nend;\r\n\r\nfunction IsSystemAndHidden(const AFindData: TWin32FindData): Boolean;\r\nconst\r\n cSystemHidden = FILE_ATTRIBUTE_SYSTEM or FILE_ATTRIBUTE_HIDDEN;\r\nbegin\r\n with AFindData do\r\n Result := dwFileAttributes and cSystemHidden = cSystemHidden;\r\nend;\r\n\r\n//=== { TJvSearchFiles } =====================================================\r\n\r\nconstructor TJvSearchFiles.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FFiles := TStringList.Create;\r\n FDirectories := TStringList.Create;\r\n FDirParams := TJvSearchParams.Create;\r\n FFileParams := TJvSearchParams.Create;\r\n\r\n { defaults }\r\n Options := [soSearchFiles];\r\n DirOption := doIncludeSubDirs;\r\n ErrorResponse := erAbort;\r\n //FFileParams.SearchTypes := [stFileMask];\r\nend;\r\n\r\ndestructor TJvSearchFiles.Destroy;\r\nbegin\r\n FFiles.Free;\r\n FDirectories.Free;\r\n FFileParams.Free;\r\n FDirParams.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvSearchFiles.Abort;\r\nbegin\r\n if not FSearching then\r\n Exit;\r\n FAborting := True;\r\n DoAbort;\r\nend;\r\n\r\nprocedure TJvSearchFiles.DoAbort;\r\nbegin\r\n if Assigned(FOnAbort) then\r\n FOnAbort(Self);\r\nend;\r\n\r\nprocedure TJvSearchFiles.DoProgress;\r\nbegin\r\n if Assigned(FOnProgress) then\r\n FOnProgress(Self);\r\nend;\r\n\r\nprocedure TJvSearchFiles.DoBeginScanDir(const ADirName: string);\r\nbegin\r\n if Assigned(FOnBeginScanDir) then\r\n FOnBeginScanDir(Self, ADirName);\r\nend;\r\n\r\nfunction TJvSearchFiles.DoCheckDir: Boolean;\r\nbegin\r\n if Assigned(FOnCheck) then\r\n begin\r\n Result := False;\r\n FOnCheck(Self, Result);\r\n end\r\n else\r\n Result := FDirParams.Check(FFindData)\r\nend;\r\n\r\nfunction TJvSearchFiles.DoCheckFile: Boolean;\r\nbegin\r\n if not (soIncludeSystemHiddenFiles in Options) and IsSystemAndHidden(FFindData) then\r\n begin\r\n Result := False;\r\n Exit;\r\n end\r\n else\r\n if Assigned(FOnCheck) then\r\n begin\r\n Result := False;\r\n FOnCheck(Self, Result);\r\n end\r\n else\r\n Result := FFileParams.Check(FFindData)\r\nend;\r\n\r\nprocedure TJvSearchFiles.DoFindDir(const APath: string);\r\nvar\r\n DirName: string;\r\n FileSize: Int64;\r\nbegin\r\n Inc(FTotalDirectories);\r\n with FindData do\r\n begin\r\n if soStripDirs in Options then\r\n DirName := cFileName\r\n else\r\n DirName := APath + cFileName;\r\n\r\n if not (soOwnerData in Options) then\r\n Directories.Add(DirName);\r\n\r\n Int64Rec(FileSize).Lo := nFileSizeLow;\r\n Int64Rec(FileSize).Hi := nFileSizeHigh;\r\n Inc(FTotalFileSize, FileSize);\r\n\r\n { NOTE: soStripDirs also applies to the event }\r\n if Assigned(FOnFindDirectory) then\r\n FOnFindDirectory(Self, DirName);\r\n end;\r\nend;\r\n\r\nprocedure TJvSearchFiles.DoFindFile(const APath: string);\r\nvar\r\n FileName: string;\r\n FileSize: Int64;\r\nbegin\r\n Inc(FTotalFiles);\r\n\r\n with FindData do\r\n begin\r\n if soStripDirs in Options then\r\n FileName := cFileName\r\n else\r\n FileName := APath + cFileName;\r\n\r\n if not (soOwnerData in Options) then\r\n Files.Add(FileName);\r\n\r\n Int64Rec(FileSize).Lo := nFileSizeLow;\r\n Int64Rec(FileSize).Hi := nFileSizeHigh;\r\n Inc(FTotalFileSize, FileSize);\r\n\r\n { NOTE: soStripDirs also applies to the event }\r\n if Assigned(FOnFindFile) then\r\n FOnFindFile(Self, FileName);\r\n end;\r\nend;\r\n\r\nfunction TJvSearchFiles.EnumFiles(const ADirectoryName: string;\r\n Dirs: TStrings; const Search: Boolean): Boolean;\r\nvar\r\n Handle: THandle;\r\n Finished: Boolean;\r\n DirOK: Boolean;\r\nbegin\r\n DoBeginScanDir(ADirectoryName);\r\n\r\n { Always scan the full directory - ie use * as mask - this seems faster\r\n then first using a mask, and then scanning the directory for subdirs }\r\n Handle := FindFirstFile(PChar(ADirectoryName + '*'), FFindData);\r\n Result := Handle <> INVALID_HANDLE_VALUE;\r\n if not Result then\r\n begin\r\n Result := GetLastError in [ERROR_FILE_NOT_FOUND, ERROR_ACCESS_DENIED];;\r\n Exit;\r\n end;\r\n\r\n Finished := False;\r\n try\r\n while not Finished do\r\n begin\r\n // (p3) no need to bring in the Forms unit for this:\r\n if not IsConsole then\r\n DoProgress;\r\n { After DoProgress, the user can have called Abort,\r\n so check it }\r\n if FAborting then\r\n begin\r\n Result := False;\r\n Exit;\r\n end;\r\n\r\n with FFindData do\r\n { Is it a directory? }\r\n if dwFileAttributes and FILE_ATTRIBUTE_DIRECTORY > 0 then\r\n begin\r\n { Filter out '.' and '..'\r\n Other dir names can't begin with a '.' }\r\n\r\n { | Event | AddDir | SearchInDir\r\n -----------------------------------------------------------------\r\n doExcludeSubDirs |\r\n True | Y N N\r\n False | N N N\r\n doIncludeSubDirs |\r\n True | Y Y Y\r\n False | N Y Y\r\n doExcludeInvalidDirs |\r\n True | Y Y Y\r\n False | N Y N\r\n doExcludeCompleteInvalidDirs |\r\n True | Y Y Y\r\n False | N N N\r\n }\r\n if not IsDotOrDotDot(cFileName) and\r\n ((soIncludeSystemHiddenDirs in Options) or not IsSystemAndHidden(FFindData)) then\r\n { Use case to prevent unnecessary calls to DoCheckDir }\r\n case DirOption of\r\n doExcludeSubDirs, doIncludeSubDirs:\r\n begin\r\n if Search and (soSearchDirs in Options) and DoCheckDir then\r\n DoFindDir(ADirectoryName);\r\n if DirOption = doIncludeSubDirs then\r\n Dirs.AddObject(cFileName, TObject(True))\r\n end;\r\n doExcludeInvalidDirs, doExcludeCompleteInvalidDirs:\r\n begin\r\n DirOK := DoCheckDir;\r\n if Search and (soSearchDirs in Options) and DirOK then\r\n DoFindDir(ADirectoryName);\r\n\r\n if (DirOption = doExcludeInvalidDirs) or DirOK then\r\n Dirs.AddObject(cFileName, TObject(DirOK));\r\n end;\r\n end;\r\n end\r\n else\r\n if Search and (soSearchFiles in Options) and DoCheckFile then\r\n DoFindFile(ADirectoryName);\r\n\r\n if not FindNextFile(Handle, FFindData) then\r\n begin\r\n Finished := True;\r\n Result := GetLastError = ERROR_NO_MORE_FILES;\r\n end;\r\n end;\r\n finally\r\n Result := FindClose(Handle) and Result;\r\n end;\r\nend;\r\n\r\nfunction TJvSearchFiles.GetIsRootDirValid: Boolean;\r\nvar\r\n Handle: THandle;\r\nbegin\r\n Handle := FindFirstFile(PChar(ExcludeTrailingPathDelimiter(FRootDirectory)),\r\n FFindData);\r\n Result := Handle <> INVALID_HANDLE_VALUE;\r\n if not Result then\r\n Exit;\r\n\r\n try\r\n with FFindData do\r\n Result := (dwFileAttributes and FILE_ATTRIBUTE_DIRECTORY > 0) and\r\n (cFileName[0] <> '.') and DoCheckDir;\r\n finally\r\n FindClose(Handle);\r\n end;\r\nend;\r\n\r\nfunction TJvSearchFiles.GetIsDepthAllowed(const ADepth: Integer): Boolean;\r\nbegin\r\n Result := (FRecurseDepth = 0) or (ADepth <= FRecurseDepth);\r\nend;\r\n\r\nfunction TJvSearchFiles.HandleError: Boolean;\r\nbegin\r\n { ErrorResponse = erIgnore : Result = True\r\n ErrorResponse = erAbort : Result = False\r\n ErrorResponse = erRaise : The last error is raised.\r\n\r\n If a user implements an OnError event handler, these results can be\r\n overridden.\r\n }\r\n if FAborting then\r\n begin\r\n Result := False;\r\n Exit;\r\n end;\r\n\r\n Result := FErrorResponse = erIgnore;\r\n if Assigned(FOnError) then\r\n FOnError(Self, Result);\r\n if (FErrorResponse = erRaise) and not Result then\r\n RaiseLastOSError;\r\nend;\r\n\r\nfunction TJvSearchFiles.GetDirectories: TStrings;\r\nbegin\r\n Result := FDirectories;\r\nend;\r\n\r\nfunction TJvSearchFiles.GetFiles: TStrings;\r\nbegin\r\n Result := FFiles;\r\nend;\r\n\r\nprocedure TJvSearchFiles.Init;\r\nbegin\r\n FTotalFileSize := 0;\r\n FTotalDirectories := 0;\r\n FTotalFiles := 0;\r\n Directories.Clear;\r\n Files.Clear;\r\n FAborting := False;\r\nend;\r\n\r\nfunction TJvSearchFiles.InternalSearch(const ADirectoryName: string; const Search: Boolean;\r\n var ADepth: Integer): Boolean;\r\nvar\r\n List: TStringList;\r\n DirSep: string;\r\n I: Integer;\r\nbegin\r\n List := TStringList.Create;\r\n try\r\n DirSep := IncludeTrailingPathDelimiter(ADirectoryName);\r\n\r\n Result := EnumFiles(DirSep, List, Search) or HandleError;\r\n if not Result then\r\n Exit;\r\n\r\n { DO NOT set Result := False; the search should continue, this is not an error. }\r\n Inc(ADepth);\r\n if not GetIsDepthAllowed(ADepth) then\r\n Exit;\r\n\r\n { I think it would be better to do no recursion; Don't know if it can\r\n be easy implemented - if you want to keep the depth first search -\r\n and without doing a lot of TList moves }\r\n for I := 0 to List.Count - 1 do\r\n begin\r\n Result := InternalSearch(DirSep + List[I], List.Objects[I] <> nil, ADepth);\r\n if not Result then\r\n Exit;\r\n end;\r\n finally\r\n List.Free;\r\n Dec(ADepth);\r\n end;\r\nend;\r\n\r\nfunction TJvSearchFiles.Search: Boolean;\r\nvar\r\n SearchInRootDir: Boolean;\r\n ADepth: Integer;\r\nbegin\r\n Result := False;\r\n if Searching then\r\n Exit;\r\n\r\n Init;\r\n\r\n FSearching := True;\r\n try\r\n { Search in root directory?\r\n\r\n | soExcludeFiles | soCheckRootDirValid | Else\r\n | InRootDir | |\r\n | | Valid | not Valid |\r\n --------------------------------------------------------------------------\r\n doExcludeSubDirs | No Search | True | No Search | True\r\n doIncludeSubDirs | False | True | False | True\r\n doExcludeInvalidDirs | False | True | False | True\r\n doExcludeCompleteInvalidDirs | False | True | No Search | True\r\n }\r\n SearchInRootDir := not (soExcludeFilesInRootDir in Options) and\r\n (not (soCheckRootDirValid in Options) or IsRootDirValid);\r\n\r\n if not SearchInRootDir and ((DirOption = doExcludeSubDirs) or\r\n ((DirOption = doExcludeCompleteInvalidDirs) and\r\n (soCheckRootDirValid in Options))) then\r\n begin\r\n Result := True;\r\n Exit;\r\n end;\r\n\r\n ADepth := 0;\r\n Result := InternalSearch(FRootDirectory, SearchInRootDir, ADepth);\r\n finally\r\n FSearching := False;\r\n end;\r\nend;\r\n\r\nprocedure TJvSearchFiles.SetDirParams(const Value: TJvSearchParams);\r\nbegin\r\n FDirParams.Assign(Value);\r\nend;\r\n\r\nprocedure TJvSearchFiles.SetFileParams(const Value: TJvSearchParams);\r\nbegin\r\n FFileParams.Assign(Value);\r\nend;\r\n\r\nprocedure TJvSearchFiles.SetOptions(const Value: TJvSearchOptions);\r\nvar\r\n ChangedOptions: TJvSearchOptions;\r\nbegin\r\n { I'm not sure, what to do when the user changes property Options, while\r\n the component is searching for files. As implemented now, the component\r\n just changes the options, and doesn't ensure that the properties hold\r\n for all data. For example unsetting flag soStripDirs while searching,\r\n results in a file list with values stripped, and other values not stripped.\r\n\r\n An other option could be to raise an exception when the user tries to\r\n change Options while the component is searching. But because no serious\r\n harm is caused - by changing Options, while searching - the component\r\n doen't do that.\r\n }\r\n { (p3) you could also do:\r\n if Searching then Exit;\r\n }\r\n // (rom) even better the search should use a local copy which stays unchanged\r\n\r\n if FOptions <> Value then\r\n begin\r\n ChangedOptions := FOptions + Value - (FOptions * Value);\r\n\r\n FOptions := Value;\r\n\r\n if soSorted in ChangedOptions then\r\n begin\r\n FDirectories.Sorted := soSorted in FOptions;\r\n FFiles.Sorted := soSorted in FOptions;\r\n end;\r\n\r\n if soAllowDuplicates in ChangedOptions then\r\n begin\r\n if soAllowDuplicates in FOptions then\r\n begin\r\n FDirectories.Duplicates := dupAccept;\r\n FFiles.Duplicates := dupAccept;\r\n end\r\n else\r\n begin\r\n FDirectories.Duplicates := dupIgnore;\r\n FFiles.Duplicates := dupIgnore;\r\n end;\r\n end;\r\n // soStripDirs; soIncludeSubDirs; soOwnerData\r\n end;\r\nend;\r\n\r\n//=== { TJvSearchAttributes } ================================================\r\n\r\nprocedure TJvSearchAttributes.Assign(Source: TPersistent);\r\nbegin\r\n if Source is TJvSearchAttributes then\r\n begin\r\n IncludeAttr := TJvSearchAttributes(Source).IncludeAttr;\r\n ExcludeAttr := TJvSearchAttributes(Source).ExcludeAttr;\r\n end\r\n else\r\n inherited Assign(Source);\r\nend;\r\n\r\nprocedure TJvSearchAttributes.DefineProperties(Filer: TFiler);\r\nvar\r\n Ancestor: TJvSearchAttributes;\r\n Attr: DWORD;\r\nbegin\r\n Attr := 0;\r\n Ancestor := TJvSearchAttributes(Filer.Ancestor);\r\n if Assigned(Ancestor) then\r\n Attr := Ancestor.FIncludeAttr;\r\n Filer.DefineProperty('IncludeAttr', ReadIncludeAttr, WriteIncludeAttr,\r\n Attr <> FIncludeAttr);\r\n if Assigned(Ancestor) then\r\n Attr := Ancestor.FExcludeAttr;\r\n Filer.DefineProperty('ExcludeAttr', ReadExcludeAttr, WriteExcludeAttr,\r\n Attr <> FExcludeAttr);\r\nend;\r\n\r\nfunction TJvSearchAttributes.GetAttr(const Index: Integer): TJvAttrFlagKind;\r\nbegin\r\n if FIncludeAttr and Index > 0 then\r\n Result := tsMustBeSet\r\n else\r\n if FExcludeAttr and Index > 0 then\r\n Result := tsMustBeUnSet\r\n else\r\n Result := tsDontCare;\r\nend;\r\n\r\nprocedure TJvSearchAttributes.ReadExcludeAttr(Reader: TReader);\r\nbegin\r\n FExcludeAttr := Reader.ReadInteger;\r\nend;\r\n\r\nprocedure TJvSearchAttributes.ReadIncludeAttr(Reader: TReader);\r\nbegin\r\n FIncludeAttr := Reader.ReadInteger;\r\nend;\r\n\r\nprocedure TJvSearchAttributes.SetAttr(const Index: Integer;\r\n Value: TJvAttrFlagKind);\r\nbegin\r\n case Value of\r\n tsMustBeSet:\r\n begin\r\n FIncludeAttr := FIncludeAttr or DWORD(Index);\r\n FExcludeAttr := FExcludeAttr and not Index;\r\n end;\r\n tsMustBeUnSet:\r\n begin\r\n FIncludeAttr := FIncludeAttr and not Index;\r\n FExcludeAttr := FExcludeAttr or DWORD(Index);\r\n end;\r\n tsDontCare:\r\n begin\r\n FIncludeAttr := FIncludeAttr and not Index;\r\n FExcludeAttr := FExcludeAttr and not Index;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvSearchAttributes.WriteExcludeAttr(Writer: TWriter);\r\nbegin\r\n Writer.WriteInteger(FExcludeAttr);\r\nend;\r\n\r\nprocedure TJvSearchAttributes.WriteIncludeAttr(Writer: TWriter);\r\nbegin\r\n Writer.WriteInteger(FIncludeAttr);\r\nend;\r\n\r\n//=== { TJvSearchParams } ====================================================\r\n\r\nconstructor TJvSearchParams.Create;\r\nbegin\r\n // (rom) added inherited Create\r\n inherited Create;\r\n FAttributes := TJvSearchAttributes.Create;\r\n FFileMasks := TStringList.Create;\r\n FFileMasks.OnChange := FileMasksChange;\r\n FCaseFileMasks := TStringList.Create;\r\n\r\n { defaults }\r\n FFileMaskSeperator := ';';\r\n { Set to 1-1-1980 }\r\n FLastChangeBefore := CDate1_1_1980;\r\n FLastChangeAfter := CDate1_1_1980;\r\nend;\r\n\r\ndestructor TJvSearchParams.Destroy;\r\nbegin\r\n FAttributes.Free;\r\n FFileMasks.Free;\r\n FCaseFileMasks.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvSearchParams.Assign(Source: TPersistent);\r\nvar\r\n Src: TJvSearchParams;\r\nbegin\r\n if Source is TJvSearchParams then\r\n begin\r\n Src := TJvSearchParams(Source);\r\n MaxSize := Src.MaxSize;\r\n MinSize := Src.MinSize;\r\n LastChangeBefore := Src.LastChangeBefore;\r\n LastChangeAfter := Src.LastChangeAfter;\r\n SearchTypes := Src.SearchTypes;\r\n FileMasks.Assign(Src.FileMasks);\r\n FileMaskSeperator := Src.FileMaskSeperator;\r\n Attributes.Assign(Src.Attributes);\r\n end\r\n else\r\n inherited Assign(Source);\r\nend;\r\n\r\nfunction TJvSearchParams.Check(const AFindData: TWin32FindData): Boolean;\r\nvar\r\n I: Integer;\r\n FileName: string;\r\nbegin\r\n Result := False;\r\n with AFindData do\r\n begin\r\n if stAttribute in FSearchTypes then\r\n begin\r\n { Note that if you set a flag in both ExcludeAttr and IncludeAttr\r\n the search always returns False }\r\n if dwFileAttributes and Attributes.ExcludeAttr > 0 then\r\n Exit;\r\n if dwFileAttributes and Attributes.IncludeAttr <> Attributes.IncludeAttr then\r\n Exit;\r\n end;\r\n\r\n if stMinSize in FSearchTypes then\r\n if (nFileSizeHigh < FMinSizeHigh) or\r\n ((nFileSizeHigh = FMinSizeHigh) and (nFileSizeLow < FMinSizeLow)) then\r\n Exit;\r\n if stMaxSize in FSearchTypes then\r\n if (nFileSizeHigh > FMaxSizeHigh) or\r\n ((nFileSizeHigh = FMaxSizeHigh) and (nFileSizeLow > FMaxSizeLow)) then\r\n Exit;\r\n if stLastChangeAfter in FSearchTypes then\r\n if CompareFileTime(ftLastWriteTime, FLastChangeAfterFT) < 0 then\r\n Exit;\r\n if stLastChangeBefore in FSearchTypes then\r\n if CompareFileTime(ftLastWriteTime, FLastChangeBeforeFT) > 0 then\r\n Exit;\r\n if (stFileMask in FSearchTypes) and (FFileMasks.Count > 0) then\r\n begin\r\n { StrMatches in JclStrings.pas is case-sensitive, thus for non case-\r\n sensitive search we have to do a little trick. The filename is\r\n upper-cased and compared with masks that are also upper-cased.\r\n This is a bit clumsy; a better solution would be to do this in\r\n StrMatches.\r\n\r\n I guess a lot of masks have the format 'mask*' or '*.ext'; so\r\n if you could specifiy to do a left or right scan in StrMatches\r\n would be better too. Note that if no char follows a '*', the\r\n result is always true; this isn't implemented so in StrMatches }\r\n\r\n if stFileMaskCaseSensitive in SearchTypes then\r\n FileName := cFileName\r\n else\r\n FileName := AnsiUpperCase(cFileName);\r\n\r\n I := 0;\r\n while (I < FFileMasks.Count) and\r\n not JclStrings.StrMatches(FCaseFileMasks[I], FileName) do\r\n Inc(I);\r\n if I >= FFileMasks.Count then\r\n Exit;\r\n end;\r\n end;\r\n Result := True;\r\nend;\r\n\r\nprocedure TJvSearchParams.FileMasksChange(Sender: TObject);\r\nbegin\r\n UpdateCaseMasks;\r\nend;\r\n\r\nfunction TJvSearchParams.GetFileMask: string;\r\nbegin\r\n Result := JclStrings.StringsToStr(FileMasks, FileMaskSeperator);\r\nend;\r\n\r\nfunction TJvSearchParams.GetMaxSize: Int64;\r\nbegin\r\n Int64Rec(Result).Lo := FMaxSizeLow;\r\n Int64Rec(Result).Hi := FMaxSizeHigh;\r\nend;\r\n\r\nfunction TJvSearchParams.GetMinSize: Int64;\r\nbegin\r\n Int64Rec(Result).Lo := FMinSizeLow;\r\n Int64Rec(Result).Hi := FMinSizeHigh;\r\nend;\r\n\r\nfunction TJvSearchParams.GetFileMasks: TStrings;\r\nbegin\r\n Result := FFileMasks;\r\nend;\r\n\r\nfunction TJvSearchParams.IsLastChangeAfterStored: Boolean;\r\nbegin\r\n Result := FLastChangeBefore <> CDate1_1_1980;\r\nend;\r\n\r\nfunction TJvSearchParams.IsLastChangeBeforeStored: Boolean;\r\nbegin\r\n Result := FLastChangeBefore <> CDate1_1_1980;\r\nend;\r\n\r\nprocedure TJvSearchParams.SetAttributes(const Value: TJvSearchAttributes);\r\nbegin\r\n FAttributes.Assign(Value);\r\nend;\r\n\r\nprocedure TJvSearchParams.SetFileMask(const Value: string);\r\nbegin\r\n JclStrings.StrToStrings(Value, FileMaskSeperator, FileMasks);\r\nend;\r\n\r\nprocedure TJvSearchParams.SetFileMasks(const Value: TStrings);\r\nbegin\r\n FFileMasks.Assign(Value);\r\nend;\r\n\r\nprocedure TJvSearchParams.SetLastChangeAfter(const Value: TDateTime);\r\nvar\r\n DosFileTime: Longint;\r\n LocalFileTime: TFileTime;\r\nbegin\r\n { Value must be >= 1-1-1980 }\r\n DosFileTime := DateTimeToDosDateTime(Value);\r\n if not Windows.DosDateTimeToFileTime(LongRec(DosFileTime).Hi,\r\n LongRec(DosFileTime).Lo, LocalFileTime) or\r\n not Windows.LocalFileTimeToFileTime(LocalFileTime, FLastChangeAfterFT) then\r\n RaiseLastOSError;\r\n\r\n FLastChangeAfter := Value;\r\nend;\r\n\r\nprocedure TJvSearchParams.SetLastChangeBefore(const Value: TDateTime);\r\nvar\r\n DosFileTime: Longint;\r\n LocalFileTime: TFileTime;\r\nbegin\r\n { Value must be >= 1-1-1980 }\r\n DosFileTime := DateTimeToDosDateTime(Value);\r\n if not Windows.DosDateTimeToFileTime(LongRec(DosFileTime).Hi,\r\n LongRec(DosFileTime).Lo, LocalFileTime) or\r\n not Windows.LocalFileTimeToFileTime(LocalFileTime, FLastChangeBeforeFT) then\r\n RaiseLastOSError;\r\n\r\n FLastChangeBefore := Value;\r\nend;\r\n\r\nprocedure TJvSearchParams.SetMaxSize(const Value: Int64);\r\nbegin\r\n FMaxSizeHigh := Int64Rec(Value).Hi;\r\n FMaxSizeLow := Int64Rec(Value).Lo;\r\nend;\r\n\r\nprocedure TJvSearchParams.SetMinSize(const Value: Int64);\r\nbegin\r\n FMinSizeHigh := Int64Rec(Value).Hi;\r\n FMinSizeLow := Int64Rec(Value).Lo;\r\nend;\r\n\r\nprocedure TJvSearchParams.SetSearchTypes(const Value: TJvSearchTypes);\r\nvar\r\n ChangedValues: TJvSearchTypes;\r\nbegin\r\n if FSearchTypes = Value then\r\n Exit;\r\n\r\n ChangedValues := FSearchTypes + Value - (FSearchTypes * Value);\r\n FSearchTypes := Value;\r\n\r\n if stFileMaskCaseSensitive in ChangedValues then\r\n UpdateCaseMasks;\r\nend;\r\n\r\nprocedure TJvSearchParams.UpdateCaseMasks;\r\nvar\r\n I: Integer;\r\nbegin\r\n FCaseFileMasks.Assign(FileMasks);\r\n\r\n if not (stFileMaskCaseSensitive in SearchTypes) then\r\n for I := 0 to FCaseFileMasks.Count - 1 do\r\n FCaseFileMasks[I] := AnsiUpperCase(FCaseFileMasks[I]);\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvSecretPanel.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvSecretPanel.pas, released on 2003-10-19.\r\n\r\nThe Initial Developers of the Original Code are: Fedor Koshevnikov, Igor Pavluk and Serge Korolev\r\nCopyright (c) 1997, 1998 Fedor Koshevnikov, Igor Pavluk and Serge Korolev\r\nCopyright (c) 2001,2002 SGB Software\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\n Polaris Software\r\n Peter Thornqvist [peter3 at sourceforge dot net]\r\n\r\nChanges:\r\n2003-10-19:\r\n * Moved TJvSecretPanel from JvxCtrls to this unit\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvSecretPanel.pas 13145 2011-11-02 21:15:19Z ahuser $\r\n\r\nunit JvSecretPanel;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, Messages, Classes, Graphics, Controls, ExtCtrls, Forms,\r\n JvTimer, JvExtComponent;\r\n\r\ntype\r\n TGlyphLayout = (glGlyphLeft, glGlyphRight, glGlyphTop, glGlyphBottom);\r\n TScrollDirection = (sdVertical, sdHorizontal);\r\n TPanelDrawEvent = procedure(Sender: TObject; Canvas: TCanvas; Rect: TRect) of object;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvSecretPanel = class(TJvPubCustomPanel)\r\n private\r\n FActive: Boolean;\r\n FAlignment: TAlignment;\r\n FLines: TStringList;\r\n FCycled: Boolean;\r\n FScrollCnt: Integer;\r\n FMaxScroll: Integer;\r\n FTxtDivider: Byte;\r\n FFirstLine: Integer;\r\n FTimer: TJvTimer;\r\n FTxtRect: TRect;\r\n FPaintRect: TRect;\r\n FGlyphOrigin: TPoint;\r\n FMemoryImage: TBitmap;\r\n FGlyph: TBitmap;\r\n FHiddenList: TList;\r\n FTextStyle: TPanelBevel;\r\n FDirection: TScrollDirection;\r\n FGlyphLayout: TGlyphLayout;\r\n FOnPaintClient: TPanelDrawEvent;\r\n FOnStartPlay: TNotifyEvent;\r\n FOnStopPlay: TNotifyEvent;\r\n FAsyncDrawing: Boolean;\r\n procedure SetAsyncDrawing(Value: Boolean);\r\n function GetInflateWidth: Integer;\r\n function GetInterval: Cardinal;\r\n function GetLines: TStrings;\r\n procedure SetInterval(Value: Cardinal);\r\n procedure SetGlyph(Value: TBitmap);\r\n procedure SetLines(Value: TStrings);\r\n procedure SetActive(Value: Boolean);\r\n procedure SetAlignment(Value: TAlignment);\r\n procedure SetGlyphLayout(Value: TGlyphLayout);\r\n procedure SetTextStyle(Value: TPanelBevel);\r\n procedure SetDirection(Value: TScrollDirection);\r\n procedure RecalcDrawRect;\r\n procedure PaintGlyph;\r\n procedure PaintText;\r\n procedure UpdateMemoryImage;\r\n procedure GlyphChanged(Sender: TObject);\r\n procedure LinesChanged(Sender: TObject);\r\n protected\r\n procedure FontChanged; override;\r\n procedure ColorChanged; override;\r\n procedure BoundsChanged; override;\r\n procedure AlignControls(AControl: TControl; var Rect: TRect); override;\r\n procedure Paint; override;\r\n procedure PaintClient(Canvas: TCanvas; Rect: TRect); virtual;\r\n procedure TimerExpired(Sender: TObject); virtual;\r\n procedure StartPlay; dynamic;\r\n procedure StopPlay; dynamic;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n procedure Play;\r\n procedure Stop;\r\n property Canvas;\r\n published\r\n property AsyncDrawing: Boolean read FAsyncDrawing write SetAsyncDrawing default True;\r\n property Active: Boolean read FActive write SetActive default False;\r\n property Alignment: TAlignment read FAlignment write SetAlignment default taCenter;\r\n property Cycled: Boolean read FCycled write FCycled default False;\r\n property Glyph: TBitmap read FGlyph write SetGlyph;\r\n property GlyphLayout: TGlyphLayout read FGlyphLayout write SetGlyphLayout default glGlyphLeft;\r\n property Interval: Cardinal read GetInterval write SetInterval default 30;\r\n property Lines: TStrings read GetLines write SetLines;\r\n property ScrollDirection: TScrollDirection read FDirection write SetDirection default sdVertical;\r\n property TextStyle: TPanelBevel read FTextStyle write SetTextStyle default bvNone;\r\n property Anchors;\r\n property Constraints;\r\n property Align;\r\n property BevelInner;\r\n property BevelOuter default bvLowered;\r\n property BevelWidth;\r\n property BorderWidth;\r\n property BorderStyle;\r\n property Color;\r\n property Font;\r\n property ParentColor;\r\n property ParentFont;\r\n property ParentShowHint;\r\n property PopupMenu;\r\n property ShowHint;\r\n property TabOrder;\r\n property TabStop;\r\n property Visible;\r\n property OnPaintClient: TPanelDrawEvent read FOnPaintClient write FOnPaintClient;\r\n property OnStartPlay: TNotifyEvent read FOnStartPlay write FOnStartPlay;\r\n property OnStopPlay: TNotifyEvent read FOnStopPlay write FOnStopPlay;\r\n property OnClick;\r\n property OnDblClick;\r\n property OnDragDrop;\r\n property OnDragOver;\r\n property OnEndDrag;\r\n property OnEnter;\r\n property OnExit;\r\n property OnMouseDown;\r\n property OnMouseMove;\r\n property OnMouseUp;\r\n property OnStartDrag;\r\n property OnContextPopup;\r\n property OnResize;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvSecretPanel.pas $';\r\n Revision: '$Revision: 13145 $';\r\n Date: '$Date: 2011-11-02 22:15:19 +0100 (mer. 02 nov. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n SysUtils, Math,\r\n JvJCLUtils, JvJVCLUtils, JvConsts;\r\n\r\nconst\r\n Alignments: array [TAlignment] of Word = (DT_LEFT, DT_RIGHT, DT_CENTER);\r\n// WordWraps: array [Boolean] of Word = (0, DT_WORDBREAK); make Delphi 5 compiler happy // andreas\r\n\r\n//=== { TJvSecretPanel } =====================================================\r\n\r\nconstructor TJvSecretPanel.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FScrollCnt := 0;\r\n FAlignment := taCenter;\r\n FActive := False;\r\n FTxtDivider := 1;\r\n FGlyphLayout := glGlyphLeft;\r\n ControlStyle := ControlStyle - [csSetCaption];\r\n BevelOuter := bvLowered;\r\n FTextStyle := bvNone;\r\n FLines := TStringList.Create;\r\n FLines.OnChange := LinesChanged;\r\n FGlyph := TBitmap.Create;\r\n FGlyph.OnChange := GlyphChanged;\r\n FHiddenList := TList.Create;\r\n FTimer := TJvTimer.Create(Self);\r\n with FTimer do\r\n begin\r\n Enabled := False;\r\n OnTimer := TimerExpired;\r\n Interval := 30;\r\n SyncEvent := False;\r\n FAsyncDrawing := True;\r\n end;\r\nend;\r\n\r\ndestructor TJvSecretPanel.Destroy;\r\nbegin\r\n SetActive(False);\r\n FGlyph.OnChange := nil;\r\n FGlyph.Free;\r\n FLines.OnChange := nil;\r\n FLines.Free;\r\n FHiddenList.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvSecretPanel.GlyphChanged(Sender: TObject);\r\nbegin\r\n if Active then\r\n begin\r\n UpdateMemoryImage;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvSecretPanel.LinesChanged(Sender: TObject);\r\nbegin\r\n if Active then\r\n begin\r\n FScrollCnt := 0;\r\n UpdateMemoryImage;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvSecretPanel.FontChanged;\r\nbegin\r\n inherited FontChanged;\r\n if Active then\r\n UpdateMemoryImage;\r\nend;\r\n\r\nprocedure TJvSecretPanel.ColorChanged;\r\nbegin\r\n inherited ColorChanged;\r\n if Active then\r\n UpdateMemoryImage;\r\nend;\r\n\r\nprocedure TJvSecretPanel.BoundsChanged;\r\nbegin\r\n inherited BoundsChanged;\r\n if Active then\r\n begin\r\n UpdateMemoryImage;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvSecretPanel.SetAsyncDrawing(Value: Boolean);\r\nbegin\r\n if FAsyncDrawing <> Value then\r\n begin\r\n FTimer.SyncEvent := not Value;\r\n FAsyncDrawing := Value;\r\n end;\r\nend;\r\n\r\nprocedure TJvSecretPanel.AlignControls(AControl: TControl; var Rect: TRect);\r\nbegin\r\n inherited AlignControls(AControl, Rect);\r\n if (AControl = nil) and Active then\r\n UpdateMemoryImage;\r\nend;\r\n\r\nfunction TJvSecretPanel.GetInflateWidth: Integer;\r\nbegin\r\n Result := BorderWidth;\r\n if BevelOuter <> bvNone then\r\n Inc(Result, BevelWidth);\r\n if BevelInner <> bvNone then\r\n Inc(Result, BevelWidth);\r\nend;\r\n\r\nprocedure TJvSecretPanel.RecalcDrawRect;\r\nconst\r\n MinOffset = 3;\r\nvar\r\n InflateWidth: Integer;\r\n LastLine: Integer;\r\nbegin\r\n FTxtRect := GetClientRect;\r\n FPaintRect := FTxtRect;\r\n InflateWidth := GetInflateWidth;\r\n InflateRect(FPaintRect, -InflateWidth, -InflateWidth);\r\n Inc(InflateWidth, MinOffset);\r\n InflateRect(FTxtRect, -InflateWidth, -InflateWidth);\r\n case FGlyphLayout of\r\n glGlyphLeft:\r\n begin\r\n FGlyphOrigin.X := FTxtRect.Left;\r\n FGlyphOrigin.Y := (FTxtRect.Bottom + FTxtRect.Top - Glyph.Height) div 2;\r\n if FGlyphOrigin.Y < FTxtRect.Top then\r\n FGlyphOrigin.Y := FTxtRect.Top;\r\n if Glyph.Width > 0 then\r\n begin\r\n Inc(FGlyphOrigin.X, MinOffset);\r\n FTxtRect.Left := FGlyphOrigin.X + Glyph.Width + InflateWidth;\r\n end;\r\n end;\r\n glGlyphRight:\r\n begin\r\n FGlyphOrigin.Y := (FTxtRect.Bottom + FTxtRect.Top - Glyph.Height) div 2;\r\n if FGlyphOrigin.Y < FTxtRect.Top then\r\n FGlyphOrigin.Y := FTxtRect.Top;\r\n FGlyphOrigin.X := FTxtRect.Right - Glyph.Width;\r\n if Glyph.Width > 0 then\r\n begin\r\n Dec(FGlyphOrigin.X, MinOffset);\r\n if FGlyphOrigin.X < FTxtRect.Left then\r\n FGlyphOrigin.X := FTxtRect.Left;\r\n FTxtRect.Right := FGlyphOrigin.X - InflateWidth;\r\n end;\r\n end;\r\n glGlyphTop:\r\n begin\r\n FGlyphOrigin.Y := FTxtRect.Top;\r\n FGlyphOrigin.X := (FTxtRect.Right + FTxtRect.Left - Glyph.Width) div 2;\r\n if FGlyphOrigin.X < FTxtRect.Left then\r\n FGlyphOrigin.X := FTxtRect.Left;\r\n if Glyph.Height > 0 then\r\n begin\r\n Inc(FGlyphOrigin.Y, MinOffset);\r\n FTxtRect.Top := FGlyphOrigin.Y + Glyph.Height + (InflateWidth + MinOffset);\r\n end;\r\n end;\r\n glGlyphBottom:\r\n begin\r\n FGlyphOrigin.X := (FTxtRect.Right + FTxtRect.Left - Glyph.Width) div 2;\r\n if FGlyphOrigin.X < FTxtRect.Left then\r\n FGlyphOrigin.X := FTxtRect.Left;\r\n FGlyphOrigin.Y := FTxtRect.Bottom - Glyph.Height;\r\n if Glyph.Height > 0 then\r\n begin\r\n Dec(FGlyphOrigin.Y, MinOffset);\r\n if FGlyphOrigin.Y < FTxtRect.Top then\r\n FGlyphOrigin.Y := FTxtRect.Top;\r\n FTxtRect.Bottom := FGlyphOrigin.Y - (InflateWidth + MinOffset);\r\n end;\r\n end;\r\n end;\r\n if FDirection = sdHorizontal then\r\n begin\r\n LastLine := Lines.Count - 1;\r\n while (LastLine >= 0) and (Trim(Lines[LastLine]) = '') do\r\n Dec(LastLine);\r\n InflateWidth := RectHeight(FTxtRect) -\r\n (LastLine + 1 - FFirstLine) * FTxtDivider;\r\n if InflateWidth > 0 then\r\n InflateRect(FTxtRect, 0, -InflateWidth div 2);\r\n end;\r\n if (FTxtRect.Left >= FTxtRect.Right) or (FTxtRect.Top >= FTxtRect.Bottom) then\r\n FTxtRect := Rect(0, 0, 0, 0);\r\nend;\r\n\r\nprocedure TJvSecretPanel.PaintGlyph;\r\nbegin\r\n if not FGlyph.Empty then\r\n begin\r\n RecalcDrawRect;\r\n DrawBitmapTransparent(Canvas, FGlyphOrigin.X, FGlyphOrigin.Y,\r\n FGlyph, FGlyph.TransparentColor and not PaletteMask);\r\n end;\r\nend;\r\n\r\nprocedure TJvSecretPanel.PaintText;\r\nvar\r\n STmp: array [0..255] of Char;\r\n R: TRect;\r\n I: Integer;\r\n Flags: Longint;\r\nbegin\r\n if (Lines.Count = 0) or IsRectEmpty(FTxtRect) or not HandleAllocated then\r\n Exit;\r\n FMemoryImage.Canvas.Lock;\r\n try\r\n with FMemoryImage.Canvas do\r\n begin\r\n I := SaveDC(Handle);\r\n try\r\n MoveWindowOrg(Handle, -FTxtRect.Left, -FTxtRect.Top);\r\n Brush.Color := Self.Color;\r\n PaintClient(FMemoryImage.Canvas, FPaintRect);\r\n finally\r\n RestoreDC(Handle, I);\r\n SetBkMode(Handle, Transparent);\r\n end;\r\n end;\r\n R := Bounds(0, 0, RectWidth(FTxtRect), RectHeight(FTxtRect));\r\n if FDirection = sdHorizontal then\r\n begin\r\n if IsRightToLeft then\r\n begin\r\n R.Right := R.Left + FScrollCnt;\r\n R.Left := R.Right - (FMaxScroll - RectWidth(FTxtRect));\r\n end\r\n else\r\n begin\r\n R.Left := R.Right - FScrollCnt;\r\n R.Right := R.Left + (FMaxScroll - RectWidth(FTxtRect));\r\n end;\r\n end\r\n else\r\n begin { sdVertical }\r\n R.Top := R.Bottom - FScrollCnt;\r\n end;\r\n R.Bottom := R.Top + FTxtDivider;\r\n Flags := DT_EXPANDTABS or Alignments[FAlignment] or DT_SINGLELINE or\r\n DT_NOCLIP or DT_NOPREFIX;\r\n Flags := DrawTextBiDiModeFlags(Flags);\r\n for I := FFirstLine to Lines.Count do\r\n begin\r\n if I = Lines.Count then\r\n StrCopy(STmp, ' ')\r\n else\r\n StrPLCopy(STmp, Lines[I], SizeOf(STmp) - 1);\r\n if R.Top >= RectHeight(FTxtRect) then\r\n Break\r\n else\r\n if R.Bottom > 0 then\r\n begin\r\n if FTextStyle <> bvNone then\r\n begin\r\n FMemoryImage.Canvas.Font.Color := clBtnHighlight;\r\n case FTextStyle of\r\n bvLowered:\r\n begin\r\n OffsetRect(R, 1, 1);\r\n DrawText(FMemoryImage.Canvas, STmp, -1, R, Flags);\r\n OffsetRect(R, -1, -1);\r\n end;\r\n bvRaised:\r\n begin\r\n OffsetRect(R, -1, -1);\r\n DrawText(FMemoryImage.Canvas, STmp, -1, R, Flags);\r\n OffsetRect(R, 1, 1);\r\n end;\r\n end;\r\n FMemoryImage.Canvas.Font.Color := Self.Font.Color;\r\n SetBkMode(FMemoryImage.Canvas.Handle, Transparent);\r\n end;\r\n DrawText(FMemoryImage.Canvas, STmp, -1, R, Flags);\r\n end;\r\n OffsetRect(R, 0, FTxtDivider);\r\n end;\r\n Canvas.Lock;\r\n try\r\n BitBlt(Canvas.Handle, FTxtRect.Left, FTxtRect.Top, FMemoryImage.Width,\r\n FMemoryImage.Height, FMemoryImage.Canvas.Handle, 0, 0, SRCCOPY);\r\n ValidateRect(Handle, @FTxtRect);\r\n finally\r\n Canvas.Unlock;\r\n end;\r\n finally\r\n FMemoryImage.Canvas.Unlock;\r\n end;\r\nend;\r\n\r\nprocedure TJvSecretPanel.PaintClient(Canvas: TCanvas; Rect: TRect);\r\nbegin\r\n if Assigned(FOnPaintClient) then\r\n FOnPaintClient(Self, Canvas, Rect)\r\n else\r\n Canvas.FillRect(Rect);\r\nend;\r\n\r\nprocedure TJvSecretPanel.Paint;\r\nvar\r\n Rect: TRect;\r\n TopColor, BottomColor: TColor;\r\n SaveIndex: Integer;\r\n\r\n procedure AdjustColors(Bevel: TPanelBevel);\r\n begin\r\n TopColor := clBtnHighlight;\r\n if Bevel = bvLowered then\r\n TopColor := clBtnShadow;\r\n BottomColor := clBtnShadow;\r\n if Bevel = bvLowered then\r\n BottomColor := clBtnHighlight;\r\n end;\r\n\r\nbegin\r\n Rect := GetClientRect;\r\n if BevelOuter <> bvNone then\r\n begin\r\n AdjustColors(BevelOuter);\r\n Frame3D(Canvas, Rect, TopColor, BottomColor, BevelWidth);\r\n end;\r\n Frame3D(Canvas, Rect, Color, Color, BorderWidth);\r\n if BevelInner <> bvNone then\r\n begin\r\n AdjustColors(BevelInner);\r\n Frame3D(Canvas, Rect, TopColor, BottomColor, BevelWidth);\r\n end;\r\n SaveIndex := SaveDC(Canvas.Handle);\r\n try\r\n IntersectClipRect(Canvas.Handle, Rect.Left, Rect.Top, Rect.Right, Rect.Bottom);\r\n Canvas.Brush.Color := Self.Color;\r\n PaintClient(Canvas, Rect);\r\n finally\r\n RestoreDC(Canvas.Handle, SaveIndex);\r\n end;\r\n if Active then\r\n begin\r\n PaintGlyph;\r\n {PaintText;}\r\n end;\r\nend;\r\n\r\nprocedure TJvSecretPanel.StartPlay;\r\nbegin\r\n if Assigned(FOnStartPlay) then\r\n FOnStartPlay(Self);\r\nend;\r\n\r\nprocedure TJvSecretPanel.StopPlay;\r\nbegin\r\n if Assigned(FOnStopPlay) then\r\n FOnStopPlay(Self);\r\nend;\r\n\r\nprocedure TJvSecretPanel.TimerExpired(Sender: TObject);\r\nbegin\r\n if FScrollCnt < FMaxScroll then\r\n begin\r\n Inc(FScrollCnt);\r\n if Assigned(FMemoryImage) then\r\n PaintText;\r\n end\r\n else\r\n if Cycled then\r\n begin\r\n FScrollCnt := 0;\r\n if Assigned(FMemoryImage) then\r\n PaintText;\r\n end\r\n else\r\n begin\r\n FTimer.Synchronize(Stop);\r\n end;\r\nend;\r\n\r\nprocedure TJvSecretPanel.UpdateMemoryImage;\r\nvar\r\n Metrics: TTextMetric;\r\n I: Integer;\r\nbegin\r\n if FMemoryImage = nil then\r\n FMemoryImage := TBitmap.Create;\r\n FMemoryImage.Canvas.Lock;\r\n try\r\n FFirstLine := 0;\r\n while (FFirstLine < Lines.Count) and (Trim(Lines[FFirstLine]) = '') do\r\n Inc(FFirstLine);\r\n Canvas.Font := Self.Font;\r\n GetTextMetrics(Canvas.Handle, Metrics);\r\n FTxtDivider := Metrics.tmHeight + Metrics.tmExternalLeading;\r\n if FTextStyle <> bvNone then\r\n Inc(FTxtDivider);\r\n RecalcDrawRect;\r\n if FDirection = sdHorizontal then\r\n begin\r\n FMaxScroll := 0;\r\n for I := FFirstLine to Lines.Count - 1 do\r\n FMaxScroll := Max(FMaxScroll, Canvas.TextWidth(Lines[I]));\r\n Inc(FMaxScroll, RectWidth(FTxtRect));\r\n end\r\n else\r\n begin { sdVertical }\r\n FMaxScroll := ((Lines.Count - FFirstLine) * FTxtDivider) +\r\n RectHeight(FTxtRect);\r\n end;\r\n FMemoryImage.Width := RectWidth(FTxtRect);\r\n FMemoryImage.Height := RectHeight(FTxtRect);\r\n with FMemoryImage.Canvas do\r\n begin\r\n Font := Self.Font;\r\n Brush.Color := Self.Color;\r\n SetBkMode(Handle, Transparent);\r\n end;\r\n finally\r\n FMemoryImage.Canvas.Unlock;\r\n end;\r\nend;\r\n\r\nfunction TJvSecretPanel.GetInterval: Cardinal;\r\nbegin\r\n Result := FTimer.Interval;\r\nend;\r\n\r\nprocedure TJvSecretPanel.SetInterval(Value: Cardinal);\r\nbegin\r\n FTimer.Interval := Value;\r\nend;\r\n\r\nprocedure TJvSecretPanel.Play;\r\nbegin\r\n SetActive(True);\r\nend;\r\n\r\nprocedure TJvSecretPanel.Stop;\r\nbegin\r\n SetActive(False);\r\nend;\r\n\r\nprocedure TJvSecretPanel.SetActive(Value: Boolean);\r\nvar\r\n I: Integer;\r\nbegin\r\n if Value <> FActive then\r\n begin\r\n FActive := Value;\r\n if FActive then\r\n begin\r\n FScrollCnt := 0;\r\n UpdateMemoryImage;\r\n try\r\n FTimer.Enabled := True;\r\n StartPlay;\r\n except\r\n FActive := False;\r\n FTimer.Enabled := False;\r\n raise;\r\n end;\r\n end\r\n else\r\n begin\r\n FMemoryImage.Canvas.Lock;\r\n { ensure that canvas is locked before timer is disabled }\r\n FTimer.Enabled := False;\r\n FScrollCnt := 0;\r\n FMemoryImage.Free;\r\n FMemoryImage := nil;\r\n StopPlay;\r\n if (csDesigning in ComponentState) and\r\n not (csDestroying in ComponentState) then\r\n ValidParentForm(Self).Designer.Modified;\r\n end;\r\n if not (csDestroying in ComponentState) then\r\n for I := 0 to Pred(ControlCount) do\r\n begin\r\n if FActive then\r\n begin\r\n if Controls[I].Visible then\r\n FHiddenList.Add(Controls[I]);\r\n if not (csDesigning in ComponentState) then\r\n Controls[I].Visible := False;\r\n end\r\n else\r\n if FHiddenList.IndexOf(Controls[I]) >= 0 then\r\n begin\r\n Controls[I].Visible := True;\r\n Controls[I].Invalidate;\r\n if csDesigning in ComponentState then\r\n Controls[I].Update;\r\n end;\r\n end;\r\n if not FActive then\r\n FHiddenList.Clear;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvSecretPanel.SetAlignment(Value: TAlignment);\r\nbegin\r\n if FAlignment <> Value then\r\n begin\r\n FAlignment := Value;\r\n if Active then\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvSecretPanel.SetGlyph(Value: TBitmap);\r\nbegin\r\n FGlyph.Assign(Value);\r\nend;\r\n\r\nprocedure TJvSecretPanel.SetDirection(Value: TScrollDirection);\r\nbegin\r\n if FDirection <> Value then\r\n begin\r\n FDirection := Value;\r\n if FActive then\r\n begin\r\n FScrollCnt := 0;\r\n UpdateMemoryImage;\r\n Invalidate;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvSecretPanel.SetTextStyle(Value: TPanelBevel);\r\nbegin\r\n if FTextStyle <> Value then\r\n begin\r\n FTextStyle := Value;\r\n if FActive then\r\n begin\r\n UpdateMemoryImage;\r\n Invalidate;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvSecretPanel.SetGlyphLayout(Value: TGlyphLayout);\r\nbegin\r\n if FGlyphLayout <> Value then\r\n begin\r\n FGlyphLayout := Value;\r\n if FActive then\r\n begin\r\n UpdateMemoryImage;\r\n Invalidate;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJvSecretPanel.GetLines: TStrings;\r\nbegin\r\n Result := FLines;\r\nend;\r\n\r\nprocedure TJvSecretPanel.SetLines(Value: TStrings);\r\nbegin\r\n FLines.Assign(Value);\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvSegmentedLEDDisplay.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvSegmentedLEDDisplay.pas, released on --.\r\n\r\nThe Initial Developer of the Original Code is Marcel Bestebroer\r\nPortions created by Marcel Bestebroer are Copyright (C) 2002 - 2003 Marcel\r\nBestebroer\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\n Jay Dubal\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n * Automatic unlit color calculation is not working properly. Maybe a function in JclGraphUtil\r\n can help out there.\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvSegmentedLEDDisplay.pas 13145 2011-11-02 21:15:19Z ahuser $\r\n\r\nunit JvSegmentedLEDDisplay;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n {$IFDEF MSWINDOWS}\r\n Windows,\r\n {$ENDIF MSWINDOWS}\r\n Classes, Graphics,\r\n JvComponent, JvTypes;\r\n\r\n// Additional color values for unlit color settings (TUnlitColor type)\r\n// asn: does this work with clx/linux?\r\nconst\r\n clDefaultBackground = TColor($20100001);\r\n clDefaultLitColor = TColor($20100002);\r\n NullHandle = 0;\r\n\r\ntype\r\n TJvCustomSegmentedLEDDisplay = class;\r\n TJvSegmentedLEDDigits = class;\r\n TJvCustomSegmentedLEDDigit = class;\r\n TJvSegmentedLEDCharacterMapper = class;\r\n\r\n TJvSegmentedLEDDigitClass = class of TJvCustomSegmentedLEDDigit;\r\n\r\n TJvSegmentedLEDDigitClassName = type string;\r\n TUnlitColor = type TColor;\r\n TSlantAngle = 0 .. 44;\r\n TSLDHitInfo = (shiNowhere, shiDigit, shiDigitSegment, shiClientArea);\r\n {$IFNDEF RTL200_UP}\r\n TCharSet = set of Char;\r\n {$ENDIF ~RTL200_UP}\r\n TSegCharMapHeader = record\r\n ID: array[0..11] of AnsiChar;\r\n MappedChars: TCharSet;\r\n Flags: Longint;\r\n end;\r\n\r\n TSegmentRenderType = (srtNone, srtPolygon, srtRect, srtCircle);\r\n TPointArray = array of TPoint;\r\n\r\n TSegmentRenderInfo = record\r\n RenderType: TSegmentRenderType;\r\n Points: TPointArray;\r\n end;\r\n TSegmentRenderInfoArray = array of TSegmentRenderInfo;\r\n\r\n EJVCLSegmentedLEDException = class(EJVCLException);\r\n\r\n TJvCustomSegmentedLEDDisplay = class(TJvGraphicControl)\r\n private\r\n FCharacterMapper: TJvSegmentedLEDCharacterMapper;\r\n FDigitClass: TJvSegmentedLEDDigitClass;\r\n FDigits: TJvSegmentedLEDDigits;\r\n FDotSize: Integer;\r\n FDigitHeight: Integer;\r\n FDigitSpacing: Integer;\r\n FDigitWidth: Integer;\r\n FMaxBaseTop: Integer;\r\n FSegmentLitColor: TColor;\r\n FSegmentSpacing: Integer;\r\n FSegmentThickness: Integer;\r\n FSegmentUnlitColor: TUnlitColor;\r\n FSlant: TSlantAngle;\r\n FText: string;\r\n protected\r\n procedure DefineProperties(Filer: TFiler); override;\r\n procedure Loaded; override;\r\n procedure Paint; override;\r\n function GetText: string;\r\n procedure SetText(Value: string);\r\n procedure SetDigitHeight(Value: Integer);\r\n procedure SetDigits(Value: TJvSegmentedLEDDigits);\r\n procedure SetDigitSpacing(Value: Integer);\r\n procedure SetDigitWidth(Value: Integer);\r\n procedure SetDigitClass(Value: TJvSegmentedLEDDigitClass);\r\n procedure SetDotSize(Value: Integer);\r\n procedure SetSegmentLitColor(Value: TColor);\r\n procedure SetSegmentSpacing(Value: Integer);\r\n procedure SetSegmentThickness(Value: Integer);\r\n procedure SetSegmentUnlitColor(Value: TUnlitColor);\r\n procedure SetSlant(Value: TSlantAngle);\r\n function GetDigitClassName: TJvSegmentedLEDDigitClassName;\r\n procedure SetDigitClassName(Value: TJvSegmentedLEDDigitClassName);\r\n function GetRealUnlitColor: TColor;\r\n function CalcRealUnlitColorBackground: TColor;\r\n function CalcRealUnlitColorLitColor: TColor;\r\n procedure PrimSetText(Value: string);\r\n procedure BaseTopChanged;\r\n procedure HeightChanged;\r\n procedure UpdateDigitsPositions;\r\n procedure InvalidateDigits;\r\n procedure InvalidateView;\r\n procedure UpdateText;\r\n procedure UpdateBounds;\r\n property AutoSize default True;\r\n property CharacterMapper: TJvSegmentedLEDCharacterMapper read FCharacterMapper;\r\n property DigitClass: TJvSegmentedLEDDigitClass read FDigitClass write SetDigitClass;\r\n // Solely needed for design time support of DigitClass\r\n property DigitClassName: TJvSegmentedLEDDigitClassName read GetDigitClassName write SetDigitClassName;\r\n property DigitHeight: Integer read FDigitHeight write SetDigitHeight default 30;\r\n property Digits: TJvSegmentedLEDDigits read FDigits write SetDigits;\r\n property DigitSpacing: Integer read FDigitSpacing write SetDigitSpacing default 2;\r\n property DigitWidth: Integer read FDigitWidth write SetDigitWidth default 20;\r\n property DotSize: Integer read FDotSize write SetDotSize default 4;\r\n property SegmentLitColor: TColor read FSegmentLitColor write SetSegmentLitColor default clWindowText;\r\n property SegmentSpacing: Integer read FSegmentSpacing write SetSegmentSpacing default 2;\r\n property SegmentThickness: Integer read FSegmentThickness write SetSegmentThickness default 2;\r\n property SegmentUnlitColor: TUnlitColor read FSegmentUnlitColor write SetSegmentUnlitColor default clDefaultLitColor;\r\n property Slant: TSlantAngle read FSlant write SetSlant default 0;\r\n property Text: string read GetText write SetText;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n procedure RemapText;\r\n function GetHitInfo(X, Y: Integer): TSLDHitInfo; overload;\r\n function GetHitInfo(X, Y: Integer; out Digit: TJvCustomSegmentedLEDDigit;\r\n out SegmentIndex: Integer): TSLDHitInfo; overload;\r\n end;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvSegmentedLEDDisplay = class(TJvCustomSegmentedLEDDisplay)\r\n public\r\n property DigitClass;\r\n published\r\n property Align;\r\n property Anchors;\r\n property AutoSize;\r\n property Color;\r\n property DigitClassName;\r\n property DigitHeight;\r\n property Digits;\r\n property DigitSpacing;\r\n property DigitWidth;\r\n property DotSize;\r\n property ParentColor;\r\n property PopupMenu;\r\n property SegmentLitColor;\r\n property SegmentSpacing;\r\n property SegmentThickness;\r\n property SegmentUnlitColor;\r\n property Slant;\r\n property Text;\r\n property OnClick;\r\n property OnContextPopup;\r\n property OnDblClick;\r\n property OnMouseDown;\r\n property OnMouseMove;\r\n property OnMouseUp;\r\n end;\r\n\r\n TJvSegmentedLEDDigits = class(TOwnedCollection)\r\n protected\r\n function GetItem(Index: Integer): TJvCustomSegmentedLEDDigit;\r\n procedure SetItem(Index: Integer; Value: TJvCustomSegmentedLEDDigit);\r\n function Display: TJvCustomSegmentedLEDDisplay;\r\n procedure Update(Item: TCollectionItem); override;\r\n public\r\n constructor Create(AOwner: TPersistent);\r\n property Items[Index: Integer]: TJvCustomSegmentedLEDDigit read GetItem write SetItem; default;\r\n end;\r\n\r\n TJvCustomSegmentedLEDDigit = class(TCollectionItem)\r\n private\r\n FLeft: Integer;\r\n FRecalcNeeded: Boolean;\r\n FVertAdjust: Integer;\r\n FSegmentStates: Int64;\r\n FSegmentRenderInfo: TSegmentRenderInfoArray;\r\n FText: string;\r\n protected\r\n // Quick access to Display specified values (slant angle, digit spacing, etc)\r\n DotSize: Integer;\r\n SegmentWidth: Integer;\r\n SlantAngle: Integer;\r\n Spacing: Integer;\r\n MaxSlantDif: Integer;\r\n function GetBaseTop: Integer; virtual;\r\n procedure SetBaseTop(Value: Integer); virtual;\r\n function GetHeight: Integer; virtual;\r\n function GetVertAdjust: Integer;\r\n procedure SetVertAdjust(Value: Integer);\r\n procedure SetIndex(Value: Integer); override;\r\n function GetLeft: Integer;\r\n procedure SetLeft(Value: Integer);\r\n function GetWidth: Integer; virtual;\r\n procedure SetText(Value: string); virtual;\r\n\r\n procedure EnableAllSegs; dynamic;\r\n function GetSegmentRenderInfo(Index: Integer; out RenderType: TSegmentRenderType;\r\n out Points: TPointArray): Boolean;\r\n procedure SetSegmentRenderInfo(Index: Integer; RenderType: TSegmentRenderType;\r\n Points: array of TPoint);\r\n function GetSegmentState(Index: Integer): Boolean;\r\n procedure SetSegmentState(Index: Integer; Value: Boolean);\r\n procedure SetSegmentStates(Value: Int64);\r\n procedure UpdateText(Value: string);\r\n procedure RecalcRefPoints; virtual; abstract;\r\n procedure RecalcSegments; virtual; abstract;\r\n function GetLitSegColor(Index: Integer): TColor; virtual;\r\n function GetUnlitSegColor(Index: Integer): TColor; virtual;\r\n function GetSegmentColor(Index: Integer): TColor;\r\n function Display: TJvCustomSegmentedLEDDisplay;\r\n procedure Invalidate;\r\n procedure InvalidateStates;\r\n procedure InvalidateRefPoints; virtual;\r\n function NeedsPainting: Boolean;\r\n procedure Paint;\r\n procedure PaintSegment(Index: Integer);\r\n\r\n class function MapperFileID: AnsiString; virtual;\r\n\r\n property BaseTop: Integer read GetBaseTop;\r\n property Height: Integer read GetHeight;\r\n property Left: Integer read GetLeft;\r\n property VertAdjust: Integer read GetVertAdjust;\r\n property Width: Integer read GetWidth;\r\n property Text: string read FText write SetText stored False;\r\n\r\n property RecalcNeeded: Boolean read FRecalcNeeded;\r\n public\r\n constructor Create(Collection: TCollection); override;\r\n function GetHitInfo(X, Y: Integer): TSLDHitInfo; overload;\r\n function GetHitInfo(X, Y: Integer; out SegmentIndex: Integer): TSLDHitInfo; overload;\r\n function PtInSegment(SegmentIndex: Integer; Pt: TPoint): Boolean; virtual;\r\n class function SegmentCount: Integer; virtual;\r\n class function GetSegmentName(Index: Integer): string; virtual;\r\n class function GetSegmentIndex(Name: string): Integer; virtual;\r\n function GetSegmentStates: Int64;\r\n function GetSegmentString: string; virtual; abstract;\r\n end;\r\n\r\n TJvBaseSegmentedLEDDigit = class(TJvCustomSegmentedLEDDigit)\r\n private\r\n FDPWidth: Integer;\r\n FUseDP: Boolean;\r\n protected\r\n // Reference points coordinates. Protected fields allows easier read/write access in descendants.\r\n FRefLeft: Integer;\r\n FRefCenterX: Integer;\r\n FRefRight: Integer;\r\n FRefTop: Integer;\r\n FRefCenterY: Integer;\r\n FRefBottom: Integer;\r\n procedure EnableAllSegs; override;\r\n procedure SetUseDP(Value: Boolean); virtual;\r\n function GetDPWidth: Integer;\r\n procedure SetDPWidth(Value: Integer);\r\n procedure UpdateDPWidth; virtual;\r\n procedure CalcASeg(Index: Integer); virtual;\r\n procedure CalcBSeg(Index: Integer); virtual;\r\n procedure CalcCSeg(Index: Integer); virtual;\r\n procedure CalcDSeg(Index: Integer); virtual;\r\n procedure CalcESeg(Index: Integer); virtual;\r\n procedure CalcFSeg(Index: Integer); virtual;\r\n procedure CalcGSeg(Index: Integer); virtual;\r\n procedure CalcDPSeg(Index: Integer); virtual;\r\n function GetWidth: Integer; override;\r\n procedure InvalidateRefPoints; override;\r\n procedure RecalcRefPoints; override;\r\n procedure RecalcSegments; override;\r\n\r\n property DPWidth: Integer read GetDPWidth write SetDPWidth;\r\n property UseDP: Boolean read FUseDP write SetUseDP;\r\n public\r\n class function SegmentCount: Integer; override;\r\n class function GetSegmentName(Index: Integer): string; override;\r\n class function GetSegmentIndex(Name: string): Integer; override;\r\n function GetSegmentString: string; override;\r\n end;\r\n\r\n TJvSegmentedLEDCharacterMapper = class(TPersistent)\r\n private\r\n FCurDigit: TJvCustomSegmentedLEDDigit;\r\n FTextForDigit: string;\r\n FSegMapRemoves: Boolean;\r\n FActiveMapping: array[Char] of Int64;\r\n FMappingChanged: Boolean;\r\n FDisplay: TJvCustomSegmentedLEDDisplay;\r\n protected\r\n function GetCharMapping(Chr: Char): Int64;\r\n procedure SetCharMapping(Chr: Char; Value: Int64);\r\n function MaxSegments: Integer; dynamic;\r\n function MapToSeparators: Boolean; dynamic;\r\n procedure PrimReadMapping(const HdrInfo: TSegCharMapHeader; Stream: TStream); dynamic;\r\n function UpdateStates(var Segments: Int64; SegMask: Int64): Boolean;\r\n procedure HandleDecimalSeparator(var Text: PChar; var Segments: Int64); virtual;\r\n function CharToSegments(Ch: Char; var Segments: Int64): Boolean; virtual;\r\n procedure ControlItemToSegments(var ControlItem: PChar; var Segments: Int64); virtual;\r\n procedure MapControlItems(var Text: PChar; var Segments: Int64); virtual;\r\n procedure MapSimpleText(var Text: PChar; var Segments: Int64); virtual;\r\n procedure MapSegNamesToSegments(var Text: PChar; var Segments: Int64); virtual;\r\n procedure PrimMapText(var Text: PChar; var Segments: Int64); virtual;\r\n procedure Modified;\r\n\r\n property CurDigit: TJvCustomSegmentedLEDDigit read FCurDigit;\r\n property Display: TJvCustomSegmentedLEDDisplay read FDisplay;\r\n property SegMapRemoves: Boolean read FSegMapRemoves write FSegMapRemoves;\r\n property TextForDigit: string read FTextForDigit write FTextForDigit;\r\n property MappingChanged: Boolean read FMappingChanged;\r\n public\r\n constructor Create(ADisplay: TJvCustomSegmentedLEDDisplay);\r\n procedure MapText(var Text: PChar; ADigit: TJvCustomSegmentedLEDDigit);\r\n procedure Clear;\r\n procedure LoadDefaultMapping; dynamic;\r\n procedure LoadFromFile(const FileName: string);\r\n procedure LoadFromStream(Stream: TStream);\r\n procedure SaveToFile(const FileName: string);\r\n procedure SaveToStream(Stream: TStream); dynamic;\r\n\r\n property CharMapping[Chr: Char]: Int64 read GetCharMapping write SetCharMapping;\r\n end;\r\n\r\n // 7-segmented digit\r\n T7SegColonUsage = (scuNone, scuLowOnly, scuFull, scuColonOnly);\r\n TJv7SegmentedLEDDigit = class(TJvBaseSegmentedLEDDigit)\r\n private\r\n FUseColon: T7SegColonUsage;\r\n protected\r\n procedure EnableAllSegs; override;\r\n function GetUseColon: T7SegColonUsage;\r\n procedure SetUseColon(Value: T7SegColonUsage);\r\n procedure RecalcSegments; override;\r\n class function MapperFileID: AnsiString; override;\r\n procedure CalcCHSeg(Index: Integer); virtual;\r\n procedure CalcCLSeg(Index: Integer); virtual;\r\n public\r\n class function SegmentCount: Integer; override;\r\n class function GetSegmentName(Index: Integer): string; override;\r\n class function GetSegmentIndex(Name: string): Integer; override;\r\n published\r\n property UseDP;\r\n property UseColon: T7SegColonUsage read GetUseColon write SetUseColon;\r\n property Text;\r\n end;\r\n\r\n // 14-segmented digit\r\n TJv14SegmentedLEDDigit = class(TJvBaseSegmentedLEDDigit)\r\n protected\r\n procedure RecalcSegments; override;\r\n class function MapperFileID: AnsiString; override;\r\n procedure CalcG1Seg(Index: Integer); virtual;\r\n procedure CalcG2Seg(Index: Integer); virtual;\r\n procedure CalcHSeg(Index: Integer); virtual;\r\n procedure CalcISeg(Index: Integer); virtual;\r\n procedure CalcJSeg(Index: Integer); virtual;\r\n procedure CalcKSeg(Index: Integer); virtual;\r\n procedure CalcLSeg(Index: Integer); virtual;\r\n procedure CalcMSeg(Index: Integer); virtual;\r\n public\r\n class function SegmentCount: Integer; override;\r\n class function GetSegmentName(Index: Integer): string; override;\r\n class function GetSegmentIndex(Name: string): Integer; override;\r\n published\r\n property UseDP;\r\n property Text;\r\n end;\r\n\r\n // 16-segmented digit\r\n TJv16SegmentedLEDDigit = class(TJv14SegmentedLEDDigit)\r\n protected\r\n procedure RecalcSegments; override;\r\n class function MapperFileID: AnsiString; override;\r\n procedure CalcA1Seg(Index: Integer); virtual;\r\n procedure CalcA2Seg(Index: Integer); virtual;\r\n procedure CalcD1Seg(Index: Integer); virtual;\r\n procedure CalcD2Seg(Index: Integer); virtual;\r\n procedure CalcISeg(Index: Integer); override;\r\n procedure CalcLSeg(Index: Integer); override;\r\n public\r\n class function SegmentCount: Integer; override;\r\n class function GetSegmentName(Index: Integer): string; override;\r\n class function GetSegmentIndex(Name: string): Integer; override;\r\n published\r\n property UseDP;\r\n property Text;\r\n end;\r\n\r\n// TUnlitColor support routines\r\nfunction IdentToUnlitColor(const Ident: string; var Int: Longint): Boolean;\r\nfunction UnlitColorToIdent(Int: Longint; var Ident: string): Boolean;\r\nfunction StringToUnlitColor(const S: string): TUnlitColor;\r\nfunction UnlitColorToString(const Color: TUnlitColor): string;\r\n// DigitClass registration routines\r\nfunction DigitClassList: TThreadList;\r\nprocedure RegisterSegmentedLEDDigitClass(DigitClass: TJvSegmentedLEDDigitClass);\r\nprocedure RegisterSegmentedLEDDigitClasses(DigitClasses: array of TJvSegmentedLEDDigitClass);\r\nprocedure UnregisterSegmentedLEDDigitClass(DigitClass: TJvSegmentedLEDDigitClass);\r\nprocedure UnregisterSegmentedLEDDigitClasses(DigitClasses: array of TJvSegmentedLEDDigitClass);\r\nprocedure UnregisterModuleSegmentedLEDDigitClasses(Module: HMODULE);\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvSegmentedLEDDisplay.pas $';\r\n Revision: '$Revision: 13145 $';\r\n Date: '$Date: 2011-11-02 22:15:19 +0100 (mer. 02 nov. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n Controls, SysUtils,\r\n JclGraphUtils,\r\n {$IFNDEF COMPILER12_UP}\r\n JvJCLUtils,\r\n {$ENDIF ~COMPILER12_UP}\r\n JvThemes, JvConsts, JvResources, JclSysUtils;\r\n\r\n{$R JvSegmentedLEDDisplay.res}\r\n\r\nvar\r\n GDigitClassList: TThreadList = nil;\r\n\r\n//=== DigitClass registration routines =======================================\r\n\r\nfunction DigitClassList: TThreadList;\r\nbegin\r\n if GDigitClassList = nil then\r\n GDigitClassList := TThreadList.Create;\r\n Result := GDigitClassList;\r\nend;\r\n\r\nprocedure RegisterSegmentedLEDDigitClass(DigitClass: TJvSegmentedLEDDigitClass);\r\nbegin\r\n with DigitClassList.LockList do\r\n try\r\n if IndexOf(DigitClass) > -1 then\r\n raise EJVCLSegmentedLEDException.CreateRes(@RsEDuplicateDigitClass);\r\n Add(DigitClass);\r\n Classes.RegisterClass(DigitClass);\r\n finally\r\n DigitClassList.UnlockList;\r\n end;\r\nend;\r\n\r\nprocedure RegisterSegmentedLEDDigitClasses(DigitClasses: array of TJvSegmentedLEDDigitClass);\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := Low(DigitClasses) to High(DigitClasses) do\r\n RegisterSegmentedLEDDigitClass(DigitClasses[I]);\r\nend;\r\n\r\nprocedure UnregisterSegmentedLEDDigitClass(DigitClass: TJvSegmentedLEDDigitClass);\r\nbegin\r\n DigitClassList.Remove(DigitClass);\r\nend;\r\n\r\nprocedure UnregisterSegmentedLEDDigitClasses(DigitClasses: array of TJvSegmentedLEDDigitClass);\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := Low(DigitClasses) to High(DigitClasses) do\r\n UnregisterSegmentedLEDDigitClass(DigitClasses[I]);\r\nend;\r\n\r\nprocedure UnregisterModuleSegmentedLEDDigitClasses(Module: HMODULE);\r\n{$IFDEF UNIX}\r\nbegin\r\n // ?\r\nend;\r\n{$ENDIF UNIX}\r\n{$IFDEF MSWINDOWS}\r\nvar\r\n I: Integer;\r\nbegin\r\n with DigitClassList.LockList do\r\n try\r\n for I := Count - 1 downto 0 do\r\n if (Module = 0) or (HMODULE(FindHInstance(Items[I])) = Module) then\r\n Delete(I);\r\n finally\r\n DigitClassList.UnlockList;\r\n end;\r\nend;\r\n{$ENDIF MSWINDOWS}\r\n\r\n\r\n//=== Helper routine: AngleAdjustPoint =======================================\r\n\r\nfunction AngleAdjustPoint(X, Y, Angle: Integer): TPoint;\r\nbegin\r\n Result.X := X - Trunc(ArcTan(Angle * Pi / 180.0) * Y);\r\n Result.Y := Y;\r\nend;\r\n\r\n//=== Helper routine: TextIndex ==============================================\r\n\r\nfunction TextIndex(S: string; const Strings: array of string): Integer;\r\nbegin\r\n Result := High(Strings);\r\n while (Result > -1) and not AnsiSameText(S, Strings[Result]) do\r\n Dec(Result);\r\nend;\r\n\r\n//=== { TJvCustomSegmentedLEDDisplay } =======================================\r\n\r\nconstructor TJvCustomSegmentedLEDDisplay.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n IncludeThemeStyle(Self, [csParentBackground]);\r\n AutoSize := True;\r\n FDigitClass := TJv7SegmentedLEDDigit;\r\n FCharacterMapper := TJvSegmentedLEDCharacterMapper.Create(Self);\r\n FDigits := TJvSegmentedLEDDigits.Create(Self);\r\n FDigitHeight := 30;\r\n FDigitSpacing := 2;\r\n FDigitWidth := 20;\r\n FDotSize := 4;\r\n FSegmentLitColor := clWindowText;\r\n FSegmentSpacing := 2;\r\n FSegmentThickness := 2;\r\n FSegmentUnlitColor := clDefaultLitColor;\r\n ClientWidth := 20;\r\n ClientHeight := 30;\r\nend;\r\n\r\ndestructor TJvCustomSegmentedLEDDisplay.Destroy;\r\nbegin\r\n FreeAndNil(FDigits);\r\n FreeAndNil(FCharacterMapper);\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvCustomSegmentedLEDDisplay.DefineProperties(Filer: TFiler);\r\nbegin\r\n inherited DefineProperties(Filer);\r\n Filer.DefineBinaryProperty('MapperData', CharacterMapper.LoadFromStream,\r\n CharacterMapper.SaveToStream, CharacterMapper.MappingChanged);\r\nend;\r\n\r\nprocedure TJvCustomSegmentedLEDDisplay.Loaded;\r\nbegin\r\n inherited Loaded;\r\n RemapText;\r\nend;\r\n\r\nprocedure TJvCustomSegmentedLEDDisplay.Paint;\r\nvar\r\n I: Integer;\r\nbegin\r\n Canvas.Brush.Color := Color;\r\n Canvas.Brush.Style := bsSolid;\r\n Canvas.Pen.Style := psSolid;\r\n DrawThemedBackground(Self, Canvas, ClientRect);\r\n for I := 0 to FDigits.Count - 1 do\r\n Digits[I].Paint;\r\nend;\r\n\r\nfunction TJvCustomSegmentedLEDDisplay.GetText: string;\r\nbegin\r\n Result := FText;\r\nend;\r\n\r\nprocedure TJvCustomSegmentedLEDDisplay.SetText(Value: string);\r\nbegin\r\n if Value <> Text then\r\n PrimSetText(Value);\r\nend;\r\n\r\nprocedure TJvCustomSegmentedLEDDisplay.SetDigitHeight(Value: Integer);\r\nvar\r\n MaxHeight: Integer;\r\n I: Integer;\r\nbegin\r\n if Value <> DigitHeight then\r\n begin\r\n FDigitHeight := Value;\r\n MaxHeight := 0;\r\n for I := 0 to Digits.Count -1 do\r\n begin\r\n Digits[I].InvalidateRefPoints;\r\n if Digits[I].Height + Digits[I].GetVertAdjust > MaxHeight then\r\n MaxHeight := Digits[I].Height + Digits[I].GetVertAdjust;\r\n end;\r\n if MaxHeight = 0 then\r\n MaxHeight := 13;\r\n // Adjust control height\r\n if AutoSize and not (Align in [alLeft, alRight, alClient]) and\r\n (Anchors * [akTop, akBottom] <> [akTop, akBottom]) and (ClientHeight <> MaxHeight) then\r\n ClientHeight := MaxHeight;\r\n InvalidateView;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomSegmentedLEDDisplay.SetDigits(Value: TJvSegmentedLEDDigits);\r\nbegin\r\nend;\r\n\r\nprocedure TJvCustomSegmentedLEDDisplay.SetDigitSpacing(Value: Integer);\r\nbegin\r\n if Value <> DigitSpacing then\r\n begin\r\n FDigitSpacing := Value;\r\n UpdateDigitsPositions;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomSegmentedLEDDisplay.SetDigitWidth(Value: Integer);\r\nbegin\r\n if Value <> DigitWidth then\r\n begin\r\n FDigitWidth := Value;\r\n if Digits.Count > 0 then\r\n begin\r\n UpdateDigitsPositions;\r\n Digits[0].InvalidateRefPoints;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomSegmentedLEDDisplay.SetDigitClass(Value: TJvSegmentedLEDDigitClass);\r\nvar\r\n I: Integer;\r\nbegin\r\n if (DigitClass <> Value) and (Value <> nil) then\r\n begin\r\n FDigitClass := Value;\r\n I := Digits.Count;\r\n FreeAndNil(FDigits);\r\n FDigits := TJvSegmentedLEDDigits.Create(Self);\r\n while (I > 0) do\r\n begin\r\n Digits.Add;\r\n Dec(I);\r\n end;\r\n if CharacterMapper <> nil then\r\n CharacterMapper.LoadDefaultMapping;\r\n if not (csLoading in ComponentState) then\r\n RemapText;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomSegmentedLEDDisplay.SetDotSize(Value: Integer);\r\nbegin\r\n Value := Value and not 1;\r\n if Value <> DotSize then\r\n begin\r\n FDotSize := Value;\r\n InvalidateDigits;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomSegmentedLEDDisplay.SetSegmentLitColor(Value: TColor);\r\nbegin\r\n if Value <> SegmentLitColor then\r\n begin\r\n FSegmentLitColor := Value;\r\n InvalidateView;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomSegmentedLEDDisplay.SetSegmentSpacing(Value: Integer);\r\nbegin\r\n Value := Value and not 1;\r\n if Value <> SegmentSpacing then\r\n begin\r\n FSegmentSpacing := Value;\r\n InvalidateDigits;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomSegmentedLEDDisplay.SetSegmentThickness(Value: Integer);\r\nbegin\r\n Value := Value and not 1;\r\n if Value <> SegmentThickness then\r\n begin\r\n FSegmentThickness := Value;\r\n InvalidateDigits;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomSegmentedLEDDisplay.SetSegmentUnlitColor(Value: TUnlitColor);\r\nbegin\r\n if Value <> SegmentUnlitColor then\r\n begin\r\n FSegmentUnlitColor := Value;\r\n InvalidateView;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomSegmentedLEDDisplay.SetSlant(Value: TSlantAngle);\r\nbegin\r\n if Value <> Slant then\r\n begin\r\n FSlant := Value;\r\n InvalidateDigits;\r\n UpdateDigitsPositions;\r\n end;\r\nend;\r\n\r\n\r\n\r\nfunction TJvCustomSegmentedLEDDisplay.GetDigitClassName: TJvSegmentedLEDDigitClassName;\r\nbegin\r\n if DigitClass <> nil then\r\n Result := DigitClass.ClassName\r\n else\r\n Result := '';\r\nend;\r\n\r\nprocedure TJvCustomSegmentedLEDDisplay.SetDigitClassName(Value: TJvSegmentedLEDDigitClassName);\r\nvar\r\n AClass: TClass;\r\nbegin\r\n if not AnsiSameStr(Value, DigitClassName) then\r\n begin\r\n if Value <> '' then\r\n begin\r\n AClass := FindClass(Value);\r\n if AClass.InheritsFrom(TJvCustomSegmentedLEDDigit) then\r\n DigitClass := TJvSegmentedLEDDigitClass(FindClass(Value))\r\n else\r\n raise EJVCLSegmentedLEDException.CreateRes(@RsEInvalidClass);\r\n end\r\n else\r\n DigitClass := nil;\r\n end;\r\nend;\r\n\r\nfunction TJvCustomSegmentedLEDDisplay.GetRealUnlitColor: TColor;\r\nbegin\r\n if SegmentUnlitColor = clNone then\r\n Result := Color\r\n else\r\n if SegmentUnlitColor = clDefaultBackground then\r\n Result := CalcRealUnlitColorBackground\r\n else\r\n if SegmentUnlitColor = clDefaultLitColor then\r\n Result := CalcRealUnlitColorLitColor\r\n else\r\n Result := SegmentUnlitColor;\r\nend;\r\n\r\nfunction TJvCustomSegmentedLEDDisplay.CalcRealUnlitColorBackground: TColor;\r\nvar\r\n Int: Integer;\r\nbegin\r\n Int := Intensity(Color32(Color));\r\n if Int > 127 then\r\n { Light color; darken a little }\r\n Result := DarkColor(Color, 30)\r\n else\r\n { Dark color; lighten a little }\r\n Result := BrightColor(Color, 30);\r\nend;\r\n\r\nfunction TJvCustomSegmentedLEDDisplay.CalcRealUnlitColorLitColor: TColor;\r\nbegin\r\n if Intensity(Color32(SegmentLitColor)) > Intensity(Color32(Color)) then\r\n Result := DarkColor(SegmentLitColor, 70)\r\n else\r\n Result := BrightColor(SegmentLitColor, 70);\r\nend;\r\n\r\nprocedure TJvCustomSegmentedLEDDisplay.PrimSetText(Value: string);\r\nvar\r\n P: PChar;\r\n I: Integer;\r\nbegin\r\n { Apply mapping of text. If any digit is changed Invalidate will be called. The stored value for\r\n FText will be the concatenation of each Digit's Text value. }\r\n if CharacterMapper <> nil then\r\n begin\r\n P := PChar(Value);\r\n for I := 0 to Digits.Count -1 do\r\n CharacterMapper.MapText(P, Digits[I]);\r\n UpdateText;\r\n end\r\n else\r\n FText := Value;\r\nend;\r\n\r\nprocedure TJvCustomSegmentedLEDDisplay.BaseTopChanged;\r\nvar\r\n I: Integer;\r\n MaxHeight: Integer;\r\nbegin\r\n // Determine MaxBaseTop\r\n FMaxBaseTop := 0;\r\n for I := 0 to Digits.Count - 1 do\r\n if Digits[I].GetBaseTop > FMaxBaseTop then\r\n FMaxBaseTop := Digits[I].GetBaseTop;\r\n // Vertically adjust digits and determine maximum height\r\n MaxHeight := 0;\r\n for I := 0 to Digits.Count - 1 do\r\n begin\r\n Digits[I].SetVertAdjust(FMaxBaseTop - Digits[I].GetBaseTop);\r\n if Digits[I].Height + Digits[I].GetVertAdjust > MaxHeight then\r\n MaxHeight := Digits[I].Height + Digits[I].GetVertAdjust;\r\n end;\r\n if MaxHeight = 0 then\r\n MaxHeight := 13;\r\n // Adjust control height\r\n if AutoSize and not (Align in [alLeft, alRight, alClient]) and\r\n (Anchors * [akTop, akBottom] <> [akTop, akBottom]) and (ClientHeight <> MaxHeight) then\r\n begin\r\n InvalidateView;\r\n ClientHeight := MaxHeight;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomSegmentedLEDDisplay.HeightChanged;\r\nvar\r\n MaxHeight: Integer;\r\n I: Integer;\r\nbegin\r\n MaxHeight := 0;\r\n for I := 0 to Digits.Count - 1 do\r\n if Digits[I].Height + Digits[I].GetVertAdjust > MaxHeight then\r\n MaxHeight := Digits[I].Height + Digits[I].GetVertAdjust;\r\n if MaxHeight = 0 then\r\n MaxHeight := 13;\r\n // Adjust control height\r\n if AutoSize and not (Align in [alLeft, alRight, alClient]) and\r\n (Anchors * [akTop, akBottom] <> [akTop, akBottom]) and (ClientHeight <> MaxHeight) then\r\n begin\r\n InvalidateView;\r\n ClientHeight := MaxHeight;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomSegmentedLEDDisplay.UpdateDigitsPositions;\r\nvar\r\n I: Integer;\r\n X: Integer;\r\nbegin\r\n if Digits.Count > 0 then\r\n begin\r\n Digits[0].SetLeft(0);\r\n X := Digits[0].Width + DigitSpacing;\r\n for I := 1 to Digits.Count - 1 do\r\n begin\r\n Digits[I].SetLeft(X);\r\n Inc(X, Digits[I].Width + DigitSpacing);\r\n end;\r\n Dec(X, DigitSpacing);\r\n if AutoSize and not (Align in [alTop, alBottom, alClient]) and\r\n (Anchors * [akLeft, akRight] <> [akLeft, akRight]) and (ClientWidth <> X) then\r\n ClientWidth := X;\r\n InvalidateView;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomSegmentedLEDDisplay.InvalidateDigits;\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := 0 to Digits.Count - 1 do\r\n Digits[I].InvalidateRefPoints;\r\nend;\r\n\r\nprocedure TJvCustomSegmentedLEDDisplay.InvalidateView;\r\nbegin\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvCustomSegmentedLEDDisplay.UpdateText;\r\nvar\r\n I: Integer;\r\nbegin\r\n FText := '';\r\n for I := 0 to Digits.Count - 1 do\r\n FText := FText + Digits[I].Text;\r\nend;\r\n\r\nprocedure TJvCustomSegmentedLEDDisplay.UpdateBounds;\r\nbegin\r\n HeightChanged;\r\n UpdateDigitsPositions;\r\nend;\r\n\r\nprocedure TJvCustomSegmentedLEDDisplay.RemapText;\r\nbegin\r\n PrimSetText(Text);\r\nend;\r\n\r\nfunction TJvCustomSegmentedLEDDisplay.GetHitInfo(X, Y: Integer): TSLDHitInfo;\r\nvar\r\n DummyDigit: TJvCustomSegmentedLEDDigit;\r\n DummyIndex: Integer;\r\nbegin\r\n Result := GetHitInfo(X, Y, DummyDigit, DummyIndex);\r\nend;\r\n\r\nfunction TJvCustomSegmentedLEDDisplay.GetHitInfo(X, Y: Integer;\r\n out Digit: TJvCustomSegmentedLEDDigit; out SegmentIndex: Integer): TSLDHitInfo;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := shiNowhere;\r\n if PtInRect(ClientRect, Point(X, Y)) then\r\n begin\r\n // Iterate over each digit and get the hit info from them\r\n I := Digits.Count;\r\n while (I > 0) and (Result = shiNowhere) do\r\n begin\r\n Dec(I);\r\n Result := Digits[I].GetHitInfo(X, Y, SegmentIndex);\r\n end;\r\n if Result <> shiNowhere then\r\n Digit := Digits[I]\r\n else // Result = shiNowhere, but we are in fact in the client area of the control (see outer if)\r\n Result := shiClientArea;\r\n end;\r\nend;\r\n\r\n//=== { TJvSegmentedLEDDigits } ==============================================\r\n\r\nconstructor TJvSegmentedLEDDigits.Create(AOwner: TPersistent);\r\nbegin\r\n inherited Create(AOwner, TJvCustomSegmentedLEDDisplay(AOwner).DigitClass);\r\nend;\r\n\r\nfunction TJvSegmentedLEDDigits.GetItem(Index: Integer): TJvCustomSegmentedLEDDigit;\r\nbegin\r\n Result := TJvCustomSegmentedLEDDigit(inherited Items[Index]);\r\nend;\r\n\r\nprocedure TJvSegmentedLEDDigits.SetItem(Index: Integer; Value: TJvCustomSegmentedLEDDigit);\r\nbegin\r\n inherited Items[Index] := Value;\r\nend;\r\n\r\nfunction TJvSegmentedLEDDigits.Display: TJvCustomSegmentedLEDDisplay;\r\nbegin\r\n Result := TJvCustomSegmentedLEDDisplay(GetOwner);\r\nend;\r\n\r\nprocedure TJvSegmentedLEDDigits.Update(Item: TCollectionItem);\r\nbegin\r\n Assert(Display <> nil);\r\n Display.UpdateBounds;\r\nend;\r\n\r\n//=== { TJvCustomSegmentedLEDDigit } =========================================\r\n\r\nconstructor TJvCustomSegmentedLEDDigit.Create(Collection: TCollection);\r\nbegin\r\n inherited Create(Collection);\r\n InvalidateRefPoints;\r\nend;\r\n\r\nfunction TJvCustomSegmentedLEDDigit.GetBaseTop: Integer;\r\nbegin\r\n Result := 0;\r\nend;\r\n\r\nprocedure TJvCustomSegmentedLEDDigit.SetBaseTop(Value: Integer);\r\nbegin\r\nend;\r\n\r\nfunction TJvCustomSegmentedLEDDigit.GetHeight: Integer;\r\nbegin\r\n Result := Display.DigitHeight;\r\nend;\r\n\r\nfunction TJvCustomSegmentedLEDDigit.GetVertAdjust: Integer;\r\nbegin\r\n Result := FVertAdjust;\r\nend;\r\n\r\nprocedure TJvCustomSegmentedLEDDigit.SetVertAdjust(Value: Integer);\r\nbegin\r\n if Value <> GetVertAdjust then\r\n begin\r\n FVertAdjust := Value;\r\n InvalidateRefPoints;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomSegmentedLEDDigit.SetIndex(Value: Integer);\r\nbegin\r\n inherited SetIndex(Value);\r\n Display.UpdateDigitsPositions;\r\nend;\r\n\r\nfunction TJvCustomSegmentedLEDDigit.GetLeft: Integer;\r\nbegin\r\n Result := FLeft;\r\nend;\r\n\r\nprocedure TJvCustomSegmentedLEDDigit.SetLeft(Value: Integer);\r\nbegin\r\n if Value <> Left then\r\n begin\r\n FLeft := Value;\r\n InvalidateRefPoints;\r\n end;\r\nend;\r\n\r\nfunction TJvCustomSegmentedLEDDigit.GetWidth: Integer;\r\nbegin\r\n Result := Display.DigitWidth + MaxSlantDif;\r\nend;\r\n\r\nprocedure TJvCustomSegmentedLEDDigit.SetText(Value: string);\r\nvar\r\n P: PChar;\r\nbegin\r\n if Value <> Text then\r\n begin\r\n if Display.CharacterMapper <> nil then\r\n begin\r\n P := PChar(Value);\r\n Display.CharacterMapper.MapText(P, Self);\r\n end\r\n else\r\n UpdateText(Value);\r\n Display.UpdateText;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomSegmentedLEDDigit.EnableAllSegs;\r\nbegin\r\nend;\r\n\r\nfunction TJvCustomSegmentedLEDDigit.GetSegmentRenderInfo(Index: Integer;\r\n out RenderType: TSegmentRenderType; out Points: TPointArray): Boolean;\r\nbegin\r\n Result := (Index >= 0) and (Index < SegmentCount);\r\n if Result then\r\n begin\r\n RenderType := FSegmentRenderInfo[Index].RenderType;\r\n Points := FSegmentRenderInfo[Index].Points;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomSegmentedLEDDigit.SetSegmentRenderInfo(Index: Integer;\r\n RenderType: TSegmentRenderType; Points: array of TPoint);\r\nbegin\r\n FSegmentRenderInfo[Index].RenderType := RenderType;\r\n SetLength(FSegmentRenderInfo[Index].Points, Length(Points));\r\n if Length(Points) > 0 then\r\n Move(Points[0], FSegmentRenderInfo[Index].Points[0], Length(Points) * SizeOf(Points[0]));\r\nend;\r\n\r\nfunction TJvCustomSegmentedLEDDigit.GetSegmentState(Index: Integer): Boolean;\r\nbegin\r\n Result := (FSegmentStates and (1 shl Index)) <> 0;\r\nend;\r\n\r\nprocedure TJvCustomSegmentedLEDDigit.SetSegmentState(Index: Integer; Value: Boolean);\r\nbegin\r\n if Value <> GetSegmentState(Index) then\r\n begin\r\n FSegmentStates := FSegmentStates xor (1 shl Index);\r\n InvalidateStates;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomSegmentedLEDDigit.SetSegmentStates(Value: Int64);\r\nbegin\r\n if Value <> FSegmentStates then\r\n begin\r\n FSegmentStates := Value;\r\n InvalidateStates;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomSegmentedLEDDigit.UpdateText(Value: string);\r\nbegin\r\n if Value <> Text then\r\n begin\r\n FText := Value;\r\n Display.UpdateText;\r\n end;\r\nend;\r\n\r\nfunction TJvCustomSegmentedLEDDigit.GetLitSegColor(Index: Integer): TColor;\r\nbegin\r\n Result := Display.SegmentLitColor;\r\nend;\r\n\r\nfunction TJvCustomSegmentedLEDDigit.GetUnlitSegColor(Index: Integer): TColor;\r\nbegin\r\n Result := Display.GetRealUnlitColor;\r\nend;\r\n\r\nfunction TJvCustomSegmentedLEDDigit.GetSegmentColor(Index: Integer): TColor;\r\nbegin\r\n if GetSegmentState(Index) then\r\n Result := GetLitSegColor(Index)\r\n else\r\n Result := GetUnlitSegColor(Index);\r\nend;\r\n\r\nfunction TJvCustomSegmentedLEDDigit.Display: TJvCustomSegmentedLEDDisplay;\r\nbegin\r\n Assert(Collection <> nil);\r\n Result := TJvSegmentedLEDDigits(Collection).Display;\r\n Assert(Result <> nil);\r\nend;\r\n\r\nprocedure TJvCustomSegmentedLEDDigit.Invalidate;\r\nbegin\r\n Display.Invalidate;\r\nend;\r\n\r\nprocedure TJvCustomSegmentedLEDDigit.InvalidateStates;\r\nbegin\r\n Display.Invalidate;\r\nend;\r\n\r\nprocedure TJvCustomSegmentedLEDDigit.InvalidateRefPoints;\r\nbegin\r\n SlantAngle := Display.Slant;\r\n Spacing := Display.SegmentSpacing;\r\n SegmentWidth := Display.SegmentThickness;\r\n DotSize := Display.DotSize;\r\n\r\n MaxSlantDif := Trunc(Abs(ArcTan(SlantAngle * Pi / 180.0) * Display.DigitHeight));\r\n FRecalcNeeded := True;\r\n\r\n SetLength(FSegmentRenderInfo, 0);\r\n SetLength(FSegmentRenderInfo, SegmentCount);\r\n FillChar(FSegmentRenderInfo[0], SegmentCount * SizeOf(FSegmentRenderInfo[0]), 0);\r\n Display.InvalidateView;\r\nend;\r\n\r\nfunction TJvCustomSegmentedLEDDigit.NeedsPainting: Boolean;\r\nbegin\r\n Result := FRecalcNeeded;\r\nend;\r\n\r\nprocedure TJvCustomSegmentedLEDDigit.Paint;\r\nvar\r\n I: Integer;\r\nbegin\r\n if RecalcNeeded then\r\n begin\r\n RecalcRefPoints;\r\n RecalcSegments;\r\n FRecalcNeeded := False;\r\n end;\r\n for I := 0 to SegmentCount - 1 do\r\n PaintSegment(I);\r\nend;\r\n\r\nprocedure TJvCustomSegmentedLEDDigit.PaintSegment(Index: Integer);\r\nvar\r\n SegColor: TColor;\r\nbegin\r\n SegColor := GetSegmentColor(Index);\r\n Display.Canvas.Brush.Color := SegColor;\r\n Display.Canvas.Pen.Color := SegColor;\r\n case FSegmentRenderInfo[Index].RenderType of\r\n srtPolygon:\r\n Display.Canvas.Polygon(FSegmentRenderInfo[Index].Points);\r\n srtCircle:\r\n Display.Canvas.Ellipse(\r\n FSegmentRenderInfo[Index].Points[0].X, FSegmentRenderInfo[Index].Points[0].Y,\r\n FSegmentRenderInfo[Index].Points[1].X, FSegmentRenderInfo[Index].Points[1].Y);\r\n srtRect:\r\n Display.Canvas.Rectangle(\r\n FSegmentRenderInfo[Index].Points[0].X, FSegmentRenderInfo[Index].Points[0].Y,\r\n FSegmentRenderInfo[Index].Points[1].X, FSegmentRenderInfo[Index].Points[1].Y);\r\n end;\r\nend;\r\n\r\nfunction TJvCustomSegmentedLEDDigit.GetHitInfo(X, Y: Integer): TSLDHitInfo;\r\nvar\r\n DummyIndex: Integer;\r\nbegin\r\n Result := GetHitInfo(X, Y, DummyIndex);\r\nend;\r\n\r\nfunction TJvCustomSegmentedLEDDigit.GetHitInfo(X, Y: Integer;\r\n out SegmentIndex: Integer): TSLDHitInfo;\r\nbegin\r\n Result := shiNowhere;\r\n if PtInRect(Rect(Left, 0, Width, Height + BaseTop), Point(X, Y)) then\r\n begin\r\n SegmentIndex := SegmentCount - 1;\r\n while (SegmentIndex >= 0) and not PtInSegment(SegmentIndex, Point(X, Y)) do\r\n Dec(SegmentIndex);\r\n if SegmentIndex > -1 then\r\n Result := shiDigitSegment\r\n else\r\n Result := shiDigit;\r\n end;\r\nend;\r\n\r\nfunction TJvCustomSegmentedLEDDigit.PtInSegment(SegmentIndex: Integer; Pt: TPoint): Boolean;\r\nvar\r\n SegType: TSegmentRenderType;\r\n SegPts: TPointArray;\r\n Rgn: HRGN;\r\nbegin\r\n if GetSegmentRenderInfo(SegmentIndex, SegType, SegPts) then\r\n begin\r\n case SegType of\r\n srtNone:\r\n Result := False;\r\n srtPolygon:\r\n begin\r\n Rgn := CreatePolygonRgn(SegPts[0], Length(SegPts), WINDING);\r\n try\r\n if Rgn <> NullHandle then\r\n Result := PtInRegion(Rgn, Pt.X, Pt.Y)\r\n else\r\n Result := False;\r\n finally\r\n DeleteObject(Rgn);\r\n end;\r\n end;\r\n srtRect:\r\n Result := PtInRect(Rect(SegPts[0].X, SegPts[0].Y, SegPts[1].X, SegPts[1].Y), Pt);\r\n srtCircle:\r\n begin\r\n Rgn := CreateEllipticRgn(SegPts[0].X, SegPts[0].Y, SegPts[1].X, SegPts[1].Y);\r\n try\r\n if Rgn <> NullHandle then\r\n Result := PtInRegion(Rgn, Pt.X, Pt.Y)\r\n else\r\n Result := False;\r\n finally\r\n DeleteObject(Rgn);\r\n end;\r\n end;\r\n else\r\n Result := False; // Call method to check additional render types?\r\n end;\r\n end\r\n else\r\n Result := False;\r\nend;\r\n\r\nfunction TJvCustomSegmentedLEDDigit.GetSegmentStates: Int64;\r\nbegin\r\n Result := FSegmentStates;\r\nend;\r\n\r\nclass function TJvCustomSegmentedLEDDigit.MapperFileID: AnsiString;\r\nbegin\r\n // DO NOTHING.\r\n // THIS CAN'T BE AN ABSTRACT CLASS METHOD AS THIS IS NOT\r\n // SUPPORTED BY C++ BUILDER\r\nend;\r\n\r\nclass function TJvCustomSegmentedLEDDigit.GetSegmentIndex(\r\n Name: string): Integer;\r\nbegin\r\n // DO NOTHING.\r\n // THIS CAN'T BE AN ABSTRACT CLASS METHOD AS THIS IS NOT\r\n // SUPPORTED BY C++ BUILDER\r\n Result := 0;\r\nend;\r\n\r\nclass function TJvCustomSegmentedLEDDigit.GetSegmentName(\r\n Index: Integer): string;\r\nbegin\r\n // DO NOTHING.\r\n // THIS CAN'T BE AN ABSTRACT CLASS METHOD AS THIS IS NOT\r\n // SUPPORTED BY C++ BUILDER\r\n Result := '';\r\nend;\r\n\r\nclass function TJvCustomSegmentedLEDDigit.SegmentCount: Integer;\r\nbegin\r\n // DO NOTHING.\r\n // THIS CAN'T BE AN ABSTRACT CLASS METHOD AS THIS IS NOT\r\n // SUPPORTED BY C++ BUILDER\r\n Result := 0;\r\nend;\r\n\r\n//=== { TJvBaseSegmentedLEDDigit } ===========================================\r\n\r\nprocedure TJvBaseSegmentedLEDDigit.EnableAllSegs;\r\nbegin\r\n inherited EnableAllSegs;\r\n UseDP := True;\r\nend;\r\n\r\nprocedure TJvBaseSegmentedLEDDigit.SetUseDP(Value: Boolean);\r\nbegin\r\n if Value <> UseDP then\r\n begin\r\n FUseDP := Value;\r\n UpdateDPWidth;\r\n InvalidateRefPoints;\r\n end;\r\nend;\r\n\r\nfunction TJvBaseSegmentedLEDDigit.GetDPWidth: Integer;\r\nbegin\r\n Result := FDPWidth;\r\nend;\r\n\r\nprocedure TJvBaseSegmentedLEDDigit.SetDPWidth(Value: Integer);\r\nbegin\r\n if Value <> DPWidth then\r\n begin\r\n FDPWidth := Value;\r\n Display.UpdateDigitsPositions;\r\n end;\r\nend;\r\n\r\nprocedure TJvBaseSegmentedLEDDigit.UpdateDPWidth;\r\nbegin\r\n if UseDP then\r\n begin\r\n // Determine if width will suffice for the DP, otherwise set FDPWidth to the required additional width\r\n if MaxSlantDif < (Spacing + DotSize) then\r\n DPWidth := Spacing + DotSize - MaxSlantDif\r\n else\r\n DPWidth := 0;\r\n end\r\n else\r\n DPWidth := 0;\r\nend;\r\n\r\nprocedure TJvBaseSegmentedLEDDigit.CalcASeg(Index: Integer);\r\nbegin\r\n SetSegmentRenderInfo(Index, srtPolygon, [\r\n AngleAdjustPoint(FRefLeft + Spacing div 2, FRefTop, SlantAngle),\r\n AngleAdjustPoint(FRefRight - Spacing div 2, FRefTop, SlantAngle),\r\n AngleAdjustPoint(FRefRight - Spacing div 2 - SegmentWidth, FRefTop + SegmentWidth, SlantAngle),\r\n AngleAdjustPoint(FRefLeft + Spacing div 2 + SegmentWidth, FRefTop + SegmentWidth, SlantAngle)\r\n ]);\r\nend;\r\n\r\nprocedure TJvBaseSegmentedLEDDigit.CalcBSeg(Index: Integer);\r\nbegin\r\n SetSegmentRenderInfo(Index, srtPolygon, [\r\n AngleAdjustPoint(FRefRight, FRefTop + Spacing div 2, SlantAngle),\r\n AngleAdjustPoint(FRefRight, FRefCenterY - Spacing div 2, SlantAngle),\r\n AngleAdjustPoint(FRefRight - SegmentWidth, FRefCenterY - Spacing div 2 - SegmentWidth, SlantAngle),\r\n AngleAdjustPoint(FRefRight - SegmentWidth, FRefTop + Spacing div 2 + SegmentWidth, SlantAngle)\r\n ]);\r\nend;\r\n\r\nprocedure TJvBaseSegmentedLEDDigit.CalcCSeg(Index: Integer);\r\nbegin\r\n SetSegmentRenderInfo(Index, srtPolygon, [\r\n AngleAdjustPoint(FRefRight, FRefCenterY + Spacing div 2, SlantAngle),\r\n AngleAdjustPoint(FRefRight, FRefBottom - Spacing div 2, SlantAngle),\r\n AngleAdjustPoint(FRefRight - SegmentWidth, FRefBottom - Spacing div 2 - SegmentWidth, SlantAngle),\r\n AngleAdjustPoint(FRefRight - SegmentWidth, FRefCenterY + Spacing div 2 + SegmentWidth, SlantAngle)\r\n ]);\r\nend;\r\n\r\nprocedure TJvBaseSegmentedLEDDigit.CalcDSeg(Index: Integer);\r\nbegin\r\n SetSegmentRenderInfo(Index, srtPolygon, [\r\n AngleAdjustPoint(FRefLeft + Spacing div 2, FRefBottom, SlantAngle),\r\n AngleAdjustPoint(FRefRight - Spacing div 2, FRefBottom, SlantAngle),\r\n AngleAdjustPoint(FRefRight - Spacing div 2 - SegmentWidth, FRefBottom - SegmentWidth, SlantAngle),\r\n AngleAdjustPoint(FRefLeft + Spacing div 2 + SegmentWidth, FRefBottom - SegmentWidth, SlantAngle)\r\n ]);\r\nend;\r\n\r\nprocedure TJvBaseSegmentedLEDDigit.CalcESeg(Index: Integer);\r\nbegin\r\n SetSegmentRenderInfo(Index, srtPolygon, [\r\n AngleAdjustPoint(FRefLeft, FRefCenterY + Spacing div 2, SlantAngle),\r\n AngleAdjustPoint(FRefLeft, FRefBottom - Spacing div 2, SlantAngle),\r\n AngleAdjustPoint(FRefLeft + SegmentWidth, FRefBottom - Spacing div 2 - SegmentWidth, SlantAngle),\r\n AngleAdjustPoint(FRefLeft + SegmentWidth, FRefCenterY + Spacing div 2 + SegmentWidth, SlantAngle)\r\n ]);\r\nend;\r\n\r\nprocedure TJvBaseSegmentedLEDDigit.CalcFSeg(Index: Integer);\r\nbegin\r\n SetSegmentRenderInfo(Index, srtPolygon, [\r\n AngleAdjustPoint(FRefLeft, FRefTop + Spacing div 2, SlantAngle),\r\n AngleAdjustPoint(FRefLeft, FRefCenterY - Spacing div 2, SlantAngle),\r\n AngleAdjustPoint(FRefLeft + SegmentWidth, FRefCenterY - Spacing div 2 - SegmentWidth, SlantAngle),\r\n AngleAdjustPoint(FRefLeft + SegmentWidth, FRefTop + Spacing div 2 + SegmentWidth, SlantAngle)\r\n ]);\r\nend;\r\n\r\nprocedure TJvBaseSegmentedLEDDigit.CalcGSeg(Index: Integer);\r\nbegin\r\n SetSegmentRenderInfo(Index, srtPolygon, [\r\n AngleAdjustPoint(FRefLeft + Spacing div 2, FRefCenterY, SlantAngle),\r\n AngleAdjustPoint(FRefLeft + Spacing div 2 + SegmentWidth div 2, FRefCenterY - SegmentWidth div 2, SlantAngle),\r\n AngleAdjustPoint(FRefRight - Spacing div 2 - SegmentWidth div 2, FRefCenterY - SegmentWidth div 2, SlantAngle),\r\n AngleAdjustPoint(FRefRight - Spacing div 2, FRefCenterY, SlantAngle),\r\n AngleAdjustPoint(FRefRight - Spacing div 2 - SegmentWidth div 2, FRefCenterY + SegmentWidth div 2, SlantAngle),\r\n AngleAdjustPoint(FRefLeft + Spacing div 2 + SegmentWidth div 2, FRefCenterY + SegmentWidth div 2, SlantAngle)\r\n ]);\r\nend;\r\n\r\nprocedure TJvBaseSegmentedLEDDigit.CalcDPSeg(Index: Integer);\r\nvar\r\n UpperLeftPoint: TPoint;\r\nbegin\r\n UpperLeftPoint := AngleAdjustPoint(FRefRight + Spacing, FRefBottom - DotSize, SlantAngle);\r\n SetSegmentRenderInfo(Index, srtCircle, [\r\n UpperLeftPoint,\r\n Point(UpperLeftPoint.X + DotSize, UpperLeftPoint.Y + DotSize)\r\n ]);\r\nend;\r\n\r\nfunction TJvBaseSegmentedLEDDigit.GetWidth: Integer;\r\nbegin\r\n Result := inherited GetWidth + DPWidth;\r\nend;\r\n\r\nprocedure TJvBaseSegmentedLEDDigit.InvalidateRefPoints;\r\nbegin\r\n inherited InvalidateRefPoints;\r\n UpdateDPWidth;\r\nend;\r\n\r\nprocedure TJvBaseSegmentedLEDDigit.RecalcRefPoints;\r\nbegin\r\n FRefLeft := Left + MaxSlantDif;\r\n FRefCenterX := FRefLeft + (Display.DigitWidth - 1) div 2;\r\n FRefRight := FRefLeft + Display.DigitWidth - 1;\r\n FRefTop := GetVertAdjust;\r\n FRefCenterY := FRefTop + (Display.DigitHeight - 1) div 2;\r\n FRefBottom := FRefTop + (Display.DigitHeight - 1);\r\nend;\r\n\r\nprocedure TJvBaseSegmentedLEDDigit.RecalcSegments;\r\nbegin\r\n CalcASeg(0);\r\n CalcBSeg(1);\r\n CalcCSeg(2);\r\n CalcDSeg(3);\r\n CalcESeg(4);\r\n CalcFSeg(5);\r\n CalcGSeg(6);\r\n if UseDP then\r\n CalcDPSeg(7);\r\nend;\r\n\r\nclass function TJvBaseSegmentedLEDDigit.SegmentCount: Integer;\r\nbegin\r\n Result := 8;\r\nend;\r\n\r\nclass function TJvBaseSegmentedLEDDigit.GetSegmentName(Index: Integer): string;\r\nbegin\r\n if Index < 7 then\r\n Result := Chr(Ord('A') + Index)\r\n else\r\n if Index = 7 then\r\n Result := 'DP'\r\n else\r\n Result := '';\r\nend;\r\n\r\nclass function TJvBaseSegmentedLEDDigit.GetSegmentIndex(Name: string): Integer;\r\nbegin\r\n Result := -1;\r\n Name := UpperCase(Name);\r\n if Length(Name) = 1 then\r\n begin\r\n Result := Ord(Name[1]) - Ord('A');\r\n if Result > 6 then\r\n Result := -1;\r\n end\r\n else\r\n if Name = 'DP' then\r\n Result := 7;\r\nend;\r\n\r\nfunction TJvBaseSegmentedLEDDigit.GetSegmentString: string;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := '';\r\n for I := 0 to SegmentCount - 1 do\r\n begin\r\n if GetSegmentState(I) then\r\n begin\r\n if Length(Result) > 0 then\r\n Result := Result + ',' + GetSegmentName(I)\r\n else\r\n Result := GetSegmentName(I);\r\n end;\r\n end;\r\nend;\r\n\r\n//=== { TJvSegmentedLEDCharacterMapper } =====================================\r\n\r\nconstructor TJvSegmentedLEDCharacterMapper.Create(ADisplay: TJvCustomSegmentedLEDDisplay);\r\nbegin\r\n inherited Create;\r\n FDisplay := ADisplay;\r\n LoadDefaultMapping;\r\nend;\r\n\r\nfunction TJvSegmentedLEDCharacterMapper.GetCharMapping(Chr: Char): Int64;\r\nbegin\r\n Result := FActiveMapping[Chr];\r\nend;\r\n\r\nprocedure TJvSegmentedLEDCharacterMapper.SetCharMapping(Chr: Char; Value: Int64);\r\nbegin\r\n FActiveMapping[Chr] := Value;\r\n Modified;\r\nend;\r\n\r\nfunction TJvSegmentedLEDCharacterMapper.MaxSegments: Integer;\r\nbegin\r\n Result := Display.DigitClass.SegmentCount;\r\nend;\r\n\r\nfunction TJvSegmentedLEDCharacterMapper.MapToSeparators: Boolean;\r\nbegin\r\n Result := True;\r\nend;\r\n\r\nprocedure TJvSegmentedLEDCharacterMapper.PrimReadMapping(const HdrInfo: TSegCharMapHeader;\r\n Stream: TStream);\r\nvar\r\n Chr: Char;\r\n MapSize: Byte;\r\n OldMapping: Int64;\r\nbegin\r\n Clear; // clear the mapping table\r\n MapSize := HdrInfo.Flags and 7;\r\n for Chr := #0 to #255 do\r\n if CharInSet(Chr, HdrInfo.MappedChars) then\r\n Stream.ReadBuffer(FActiveMapping[Chr], MapSize);\r\n if HdrInfo.Flags and 16 <> 0 then\r\n begin\r\n // Swap . for DecimalSeparator and , for ThousandSeparator\r\n if JclFormatSettings.DecimalSeparator <> '.' then\r\n begin\r\n OldMapping := FActiveMapping[JclFormatSettings.DecimalSeparator];\r\n FActiveMapping[JclFormatSettings.DecimalSeparator] := FActiveMapping['.'];\r\n FActiveMapping[JclFormatSettings.ThousandSeparator] := OldMapping;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJvSegmentedLEDCharacterMapper.UpdateStates(var Segments: Int64;\r\n SegMask: Int64): Boolean;\r\nvar\r\n OldValue: Int64;\r\nbegin\r\n OldValue := Segments;\r\n if FSegMapRemoves then\r\n Segments := Segments and not SegMask\r\n else\r\n Segments := Segments or SegMask;\r\n Result := Segments <> OldValue;\r\nend;\r\n\r\nprocedure TJvSegmentedLEDCharacterMapper.HandleDecimalSeparator(var Text: PChar;\r\n var Segments: Int64);\r\nbegin\r\n if (CurDigit is TJvBaseSegmentedLEDDigit) and TJvBaseSegmentedLEDDigit(CurDigit).UseDP then\r\n begin\r\n if UpdateStates(Segments, 1 shl CurDigit.GetSegmentIndex('DP')) then\r\n TextForDigit := TextForDigit + JclFormatSettings.DecimalSeparator;\r\n while Text[0] = JclFormatSettings.DecimalSeparator do\r\n Inc(Text);\r\n end;\r\nend;\r\n\r\nfunction TJvSegmentedLEDCharacterMapper.CharToSegments(Ch: Char; var Segments: Int64): Boolean;\r\nbegin\r\n Result := UpdateStates(Segments, FActiveMapping[Ch]) or (Ch = ' ');\r\nend;\r\n\r\nprocedure TJvSegmentedLEDCharacterMapper.ControlItemToSegments(var ControlItem: PChar;\r\n var Segments: Int64);\r\nvar\r\n OrdValue: Byte;\r\nbegin\r\n case ControlItem^ of\r\n '+':\r\n begin\r\n if FSegMapRemoves then\r\n TextForDigit := TextForDigit + '+';\r\n FSegMapRemoves := False;\r\n Inc(ControlItem);\r\n end;\r\n '-':\r\n begin\r\n if not FSegMapRemoves then\r\n TextForDigit := TextForDigit + '-';\r\n FSegMapRemoves := True;\r\n Inc(ControlItem);\r\n end;\r\n '&':\r\n begin\r\n Inc(ControlItem);\r\n if CharToSegments(ControlItem^, Segments) then\r\n TextForDigit := TextForDigit + '&' + ControlItem[0];\r\n Inc(ControlItem);\r\n end;\r\n '#':\r\n begin\r\n Inc(ControlItem);\r\n OrdValue := 0;\r\n while CharInSet(ControlItem[0], DigitSymbols) do\r\n begin\r\n if OrdValue >= 100 then\r\n OrdValue := OrdValue mod 100;\r\n if OrdValue >= 26 then\r\n OrdValue := OrdValue mod 10;\r\n OrdValue := OrdValue * 10 + (Ord(ControlItem[0]) - Ord('0'));\r\n Inc(ControlItem);\r\n end;\r\n if CharToSegments(Chr(OrdValue), Segments) then\r\n begin\r\n if OrdValue in [32 .. 127] then\r\n TextForDigit := TextForDigit + '&' + Chr(OrdValue)\r\n else\r\n TextForDigit := TextForDigit + '#' + IntToStr(OrdValue);\r\n end;\r\n end;\r\n else\r\n MapSegNamesToSegments(ControlItem, Segments);\r\n end;\r\n while ControlItem[0] = ';' do\r\n Inc(ControlItem);\r\nend;\r\n\r\nprocedure TJvSegmentedLEDCharacterMapper.MapControlItems(var Text: PChar; var Segments: Int64);\r\nbegin\r\n Inc(Text);\r\n TextForDigit := TextForDigit + '[';\r\n while not CharInSet(Text^, [#0, ']']) do\r\n ControlItemToSegments(Text, Segments);\r\n if Text^ = ']' then\r\n begin\r\n Inc(Text);\r\n TextForDigit := TextForDigit + ']';\r\n end;\r\n if Text[0] = JclFormatSettings.DecimalSeparator then\r\n HandleDecimalSeparator(Text, Segments);\r\nend;\r\n\r\nprocedure TJvSegmentedLEDCharacterMapper.MapSimpleText(var Text: PChar; var Segments: Int64);\r\nbegin\r\n if CharToSegments(Text^, Segments) then\r\n TextForDigit := TextForDigit + Text^;\r\n Inc(Text);\r\n if Text[0] = JclFormatSettings.DecimalSeparator then\r\n HandleDecimalSeparator(Text, Segments);\r\nend;\r\n\r\nprocedure TJvSegmentedLEDCharacterMapper.MapSegNamesToSegments(var Text: PChar;\r\n var Segments: Int64);\r\nvar\r\n SortedSegNames: TStringList;\r\n I: Integer;\r\nbegin\r\n SortedSegNames := TStringList.Create;\r\n try\r\n for I := 0 to CurDigit.SegmentCount - 1 do\r\n SortedSegNames.Add(CurDigit.GetSegmentName(I));\r\n SortedSegNames.Sort;\r\n\r\n while not CharInSet(Text[0], [#0, ']', ';']) do\r\n begin\r\n I := SortedSegNames.Count - 1;\r\n while I >= 0 do\r\n begin\r\n if AnsiStrLIComp(Text, PChar(SortedSegNames[I]), Length(SortedSegNames[I])) = 0 then\r\n begin\r\n if UpdateStates(Segments, 1 shl CurDigit.GetSegmentIndex(SortedSegNames[I])) then\r\n TextForDigit := TextForDigit + SortedSegNames[I];\r\n Inc(Text, Length(SortedSegNames[I]));\r\n Break; // End the for loop\r\n end;\r\n Dec(I);\r\n end;\r\n if I < 0 then\r\n Inc(Text);\r\n if Text[0] = ',' then\r\n Inc(Text);\r\n end;\r\n finally\r\n FreeAndNil(SortedSegNames);\r\n end;\r\nend;\r\n\r\nprocedure TJvSegmentedLEDCharacterMapper.PrimMapText(var Text: PChar; var Segments: Int64);\r\nbegin\r\n case Text^ of\r\n #0:\r\n Exit;\r\n '[':\r\n MapControlItems(Text, Segments);\r\n else\r\n MapSimpleText(Text, Segments);\r\n end;\r\nend;\r\n\r\nprocedure TJvSegmentedLEDCharacterMapper.Modified;\r\nbegin\r\n FMappingChanged := True;\r\n Display.RemapText;\r\nend;\r\n\r\nprocedure TJvSegmentedLEDCharacterMapper.MapText(var Text: PChar;\r\n ADigit: TJvCustomSegmentedLEDDigit);\r\nvar\r\n States: Int64;\r\nbegin\r\n FCurDigit := ADigit;\r\n FTextForDigit := '';\r\n States := 0;\r\n FSegMapRemoves := False;\r\n PrimMapText(Text, States);\r\n CurDigit.SetSegmentStates(States);\r\n if FTextForDigit = '' then // assume a space was used\r\n FTextForDigit := ' ';\r\n CurDigit.UpdateText(FTextForDigit);\r\nend;\r\n\r\nprocedure TJvSegmentedLEDCharacterMapper.Clear;\r\nbegin\r\n FillChar(FActiveMapping[#0], SizeOf(FActiveMapping), 0);\r\nend;\r\n\r\nprocedure TJvSegmentedLEDCharacterMapper.LoadDefaultMapping;\r\nvar\r\n resName: AnsiString;\r\n Stream: TStream;\r\nbegin\r\n resName := Display.DigitClass.MapperFileID + '_DEFAULT';\r\n if FindResource(HInstance, PChar(string(resName)), RT_RCDATA) <> 0 then\r\n begin\r\n Stream := TResourceStream.Create(HInstance, string(Display.DigitClass.MapperFileID + '_DEFAULT'), RT_RCDATA);\r\n try\r\n LoadFromStream(Stream);\r\n FMappingChanged := False;\r\n finally\r\n FreeAndNil(Stream);\r\n end;\r\n end\r\n else\r\n Clear;\r\nend;\r\n\r\nprocedure TJvSegmentedLEDCharacterMapper.LoadFromFile(const FileName: string);\r\nvar\r\n FS: TFileStream;\r\nbegin\r\n FS := TFileStream.Create(FileName, fmOpenRead + fmShareDenyWrite);\r\n try\r\n LoadFromStream(FS);\r\n finally\r\n FS.Free;\r\n end;\r\nend;\r\n\r\nprocedure TJvSegmentedLEDCharacterMapper.LoadFromStream(Stream: TStream);\r\nvar\r\n OrgPos: Integer;\r\n Hdr: TSegCharMapHeader;\r\nbegin\r\n OrgPos := Stream.Position;\r\n try\r\n Stream.ReadBuffer(Hdr, SizeOf(Hdr));\r\n if StrLIComp(Hdr.ID, PAnsiChar(Display.DigitClass.MapperFileID), Length(Display.DigitClass.MapperFileID)) = 0 then\r\n PrimReadMapping(Hdr, Stream)\r\n else\r\n raise EJVCLSegmentedLEDException.CreateRes(@RsEInvalidMappingFile);\r\n except\r\n Stream.Position := OrgPos;\r\n raise;\r\n end;\r\nend;\r\n\r\nprocedure TJvSegmentedLEDCharacterMapper.SaveToFile(const FileName: string);\r\nvar\r\n FS: TFileStream;\r\nbegin\r\n FS := TFileStream.Create(FileName, fmCreate);\r\n try\r\n SaveToStream(FS);\r\n finally\r\n FS.Free;\r\n end;\r\nend;\r\n\r\nprocedure TJvSegmentedLEDCharacterMapper.SaveToStream(Stream: TStream);\r\nvar\r\n Hdr: TSegCharMapHeader;\r\n TmpID: AnsiString;\r\n MapSize: Byte;\r\n Chr: AnsiChar;\r\n TmpDot: Int64;\r\n TmpComma: Int64;\r\nbegin\r\n FillChar(Hdr, SizeOf(Hdr), 0);\r\n TmpID := Display.DigitClass.MapperFileID;\r\n Move(TmpID[1], Hdr.ID, Length(TmpID));\r\n Hdr.Flags := MaxSegments;\r\n MapSize := (Hdr.Flags div 8) + Ord((Hdr.Flags mod 8) <> 0);\r\n Hdr.Flags := MapSize;\r\n Hdr.Flags := Hdr.Flags or (16 * Ord(MapToSeparators));\r\n Hdr.MappedChars := [];\r\n TmpDot := FActiveMapping['.'];\r\n TmpComma := FActiveMapping[','];\r\n if JclFormatSettings.DecimalSeparator <> '.' then\r\n begin\r\n FActiveMapping['.'] := TmpComma;\r\n FActiveMapping[','] := TmpDot;\r\n end;\r\n try\r\n for Chr := #0 to #255 do\r\n if FActiveMapping[Chr] <> 0 then\r\n Include(Hdr.MappedChars, Chr);\r\n Stream.WriteBuffer(Hdr, SizeOf(Hdr));\r\n for Chr := #0 to #255 do\r\n if FActiveMapping[Chr] <> 0 then\r\n Stream.WriteBuffer(FActiveMapping[Chr], MapSize);\r\n finally\r\n if JclFormatSettings.DecimalSeparator <> '.' then\r\n begin\r\n FActiveMapping['.'] := TmpDot;\r\n FActiveMapping[','] := TmpComma;\r\n end;\r\n end;\r\nend;\r\n\r\n//=== { TJv7SegmentedLEDDigit } ==============================================\r\n\r\nprocedure TJv7SegmentedLEDDigit.EnableAllSegs;\r\nbegin\r\n inherited EnableAllSegs;\r\n UseColon := scuFull;\r\nend;\r\n\r\nfunction TJv7SegmentedLEDDigit.GetUseColon: T7SegColonUsage;\r\nbegin\r\n Result := FUseColon;\r\nend;\r\n\r\nprocedure TJv7SegmentedLEDDigit.SetUseColon(Value: T7SegColonUsage);\r\nbegin\r\n if Value <> UseColon then\r\n begin\r\n FUseColon := Value;\r\n InvalidateRefPoints;\r\n end;\r\nend;\r\n\r\nclass function TJv7SegmentedLEDDigit.SegmentCount: Integer;\r\nbegin\r\n Result := 10;\r\nend;\r\n\r\nclass function TJv7SegmentedLEDDigit.GetSegmentName(Index: Integer): string;\r\nbegin\r\n if Index <= 7 then\r\n Result := inherited GetSegmentName(Index)\r\n else\r\n if Index = 8 then\r\n Result := 'CL'\r\n else\r\n if Index = 9 then\r\n Result := 'CH'\r\n else\r\n Result := '';\r\nend;\r\n\r\nclass function TJv7SegmentedLEDDigit.GetSegmentIndex(Name: string): Integer;\r\nbegin\r\n Result := inherited GetSegmentIndex(Name);\r\n if Result = -1 then\r\n begin\r\n Name := UpperCase(Name);\r\n if Name = 'CL' then\r\n Result := 8\r\n else\r\n if Name = 'CH' then\r\n Result := 9;\r\n end;\r\nend;\r\n\r\nprocedure TJv7SegmentedLEDDigit.RecalcSegments;\r\nbegin\r\n if UseColon <> scuColonOnly then\r\n inherited RecalcSegments;\r\n if UseColon in [scuLowOnly, scuFull, scuColonOnly] then\r\n CalcCLSeg(8);\r\n if UseColon in [scuFull, scuColonOnly] then\r\n CalcCHSeg(9);\r\nend;\r\n\r\nclass function TJv7SegmentedLEDDigit.MapperFileID: AnsiString;\r\nbegin\r\n Result := 'SLDCM_7SEG';\r\nend;\r\n\r\nprocedure TJv7SegmentedLEDDigit.CalcCHSeg(Index: Integer);\r\nvar\r\n UpperLeftPoint: TPoint;\r\nbegin\r\n UpperLeftPoint := AngleAdjustPoint(FRefCenterX - DotSize div 2,\r\n (FRefCenterY - FRefTop) div 2 + FRefTop, SlantAngle);\r\n SetSegmentRenderInfo(Index, srtCircle,\r\n [UpperLeftPoint, Point(UpperLeftPoint.X + DotSize, UpperLeftPoint.Y + DotSize)]);\r\nend;\r\n\r\nprocedure TJv7SegmentedLEDDigit.CalcCLSeg(Index: Integer);\r\nvar\r\n UpperLeftPoint: TPoint;\r\nbegin\r\n UpperLeftPoint := AngleAdjustPoint(FRefCenterX - DotSize div 2,\r\n (FRefBottom - FRefCenterY) div 2 + FRefCenterY - DotSize div 2, SlantAngle);\r\n SetSegmentRenderInfo(Index, srtCircle,\r\n [UpperLeftPoint, Point(UpperLeftPoint.X + DotSize, UpperLeftPoint.Y + DotSize)]);\r\nend;\r\n\r\n//=== { TJv14SegmentedLEDDigit } ==============================================\r\n\r\nprocedure TJv14SegmentedLEDDigit.CalcG1Seg(Index: Integer);\r\nbegin\r\n SetSegmentRenderInfo(Index, srtPolygon, [\r\n AngleAdjustPoint(FRefLeft + Spacing div 2, FRefCenterY, SlantAngle),\r\n AngleAdjustPoint(FRefLeft + Spacing div 2 + SegmentWidth div 2, FRefCenterY - SegmentWidth div 2, SlantAngle),\r\n AngleAdjustPoint(FRefCenterX - Spacing div 2 - SegmentWidth div 4, FRefCenterY - SegmentWidth div 2, SlantAngle),\r\n AngleAdjustPoint(FRefCenterX - Spacing div 2, FRefCenterY, SlantAngle),\r\n AngleAdjustPoint(FRefCenterX - Spacing div 2 - SegmentWidth div 4, FRefCenterY + SegmentWidth div 2, SlantAngle),\r\n AngleAdjustPoint(FRefLeft + Spacing div 2 + SegmentWidth div 2, FRefCenterY + SegmentWidth div 2, SlantAngle)\r\n ]);\r\nend;\r\n\r\nprocedure TJv14SegmentedLEDDigit.CalcG2Seg(Index: Integer);\r\nbegin\r\n SetSegmentRenderInfo(Index, srtPolygon, [\r\n AngleAdjustPoint(FRefCenterX + Spacing div 2, FRefCenterY, SlantAngle),\r\n AngleAdjustPoint(FRefCenterX + Spacing div 2 + SegmentWidth div 4, FRefCenterY - SegmentWidth div 2, SlantAngle),\r\n AngleAdjustPoint(FRefRight - Spacing div 2 - SegmentWidth div 2, FRefCenterY - SegmentWidth div 2, SlantAngle),\r\n AngleAdjustPoint(FRefRight - Spacing div 2, FRefCenterY, SlantAngle),\r\n AngleAdjustPoint(FRefRight - Spacing div 2 - SegmentWidth div 2, FRefCenterY + SegmentWidth div 2, SlantAngle),\r\n AngleAdjustPoint(FRefCenterX + Spacing div 2 + SegmentWidth div 4, FRefCenterY + SegmentWidth div 2, SlantAngle)\r\n ]);\r\nend;\r\n\r\nprocedure TJv14SegmentedLEDDigit.CalcHSeg(Index: Integer);\r\nbegin\r\n SetSegmentRenderInfo(Index, srtPolygon, [\r\n AngleAdjustPoint(FRefLeft + Spacing + SegmentWidth, FRefTop + SegmentWidth + Spacing, SlantAngle),\r\n AngleAdjustPoint(FRefLeft + Spacing + SegmentWidth + SegmentWidth div 2, FRefTop + SegmentWidth + Spacing, SlantAngle),\r\n AngleAdjustPoint(FRefCenterX - Spacing - SegmentWidth div 2, FRefCenterY - SegmentWidth - Spacing, SlantAngle),\r\n AngleAdjustPoint(FRefCenterX - Spacing - SegmentWidth div 2, FRefCenterY - SegmentWidth div 2 - Spacing, SlantAngle),\r\n AngleAdjustPoint(FRefCenterX - Spacing - SegmentWidth, FRefCenterY - SegmentWidth div 2 - Spacing, SlantAngle),\r\n AngleAdjustPoint(FRefLeft + Spacing + SegmentWidth, FRefTop + SegmentWidth + SegmentWidth div 4 + Spacing, SlantAngle)\r\n ]);\r\nend;\r\n\r\nprocedure TJv14SegmentedLEDDigit.CalcISeg(Index: Integer);\r\nbegin\r\n SetSegmentRenderInfo(Index, srtPolygon, [\r\n AngleAdjustPoint(FRefCenterX + SegmentWidth div 2, FRefTop + SegmentWidth + Spacing, SlantAngle),\r\n AngleAdjustPoint(FRefCenterX + SegmentWidth div 2, FRefCenterY - SegmentWidth - Spacing, SlantAngle),\r\n AngleAdjustPoint(FRefCenterX, FRefCenterY - Spacing, SlantAngle),\r\n AngleAdjustPoint(FRefCenterX - SegmentWidth div 2, FRefCenterY - SegmentWidth - Spacing, SlantAngle),\r\n AngleAdjustPoint(FRefCenterX - SegmentWidth div 2, FRefTop + SegmentWidth + Spacing, SlantAngle)\r\n ]);\r\nend;\r\n\r\nprocedure TJv14SegmentedLEDDigit.CalcJSeg(Index: Integer);\r\nbegin\r\n SetSegmentRenderInfo(Index, srtPolygon, [\r\n AngleAdjustPoint(FRefRight - Spacing - SegmentWidth, FRefTop + SegmentWidth + Spacing, SlantAngle),\r\n AngleAdjustPoint(FRefRight - Spacing - SegmentWidth - SegmentWidth div 2, FRefTop + SegmentWidth + Spacing, SlantAngle),\r\n AngleAdjustPoint(FRefCenterX + Spacing + SegmentWidth div 2, FRefCenterY - SegmentWidth - Spacing, SlantAngle),\r\n AngleAdjustPoint(FRefCenterX + Spacing + SegmentWidth div 2, FRefCenterY - SegmentWidth div 2 - Spacing, SlantAngle),\r\n AngleAdjustPoint(FRefCenterX + Spacing + SegmentWidth, FRefCenterY - SegmentWidth div 2 - Spacing, SlantAngle),\r\n AngleAdjustPoint(FRefRight - Spacing - SegmentWidth, FRefTop + SegmentWidth + SegmentWidth div 4 + Spacing, SlantAngle)\r\n ]);\r\nend;\r\n\r\nprocedure TJv14SegmentedLEDDigit.CalcKSeg(Index: Integer);\r\nbegin\r\n SetSegmentRenderInfo(Index, srtPolygon, [\r\n AngleAdjustPoint(FRefLeft + Spacing + SegmentWidth, FRefBottom - SegmentWidth - Spacing, SlantAngle),\r\n AngleAdjustPoint(FRefLeft + Spacing + SegmentWidth + SegmentWidth div 2, FRefBottom - SegmentWidth - Spacing, SlantAngle),\r\n AngleAdjustPoint(FRefCenterX - Spacing - SegmentWidth div 2, FRefCenterY + SegmentWidth + Spacing, SlantAngle),\r\n AngleAdjustPoint(FRefCenterX - Spacing - SegmentWidth div 2, FRefCenterY + SegmentWidth div 2 + Spacing, SlantAngle),\r\n AngleAdjustPoint(FRefCenterX - Spacing - SegmentWidth, FRefCenterY + SegmentWidth div 2 + Spacing, SlantAngle),\r\n AngleAdjustPoint(FRefLeft + Spacing + SegmentWidth, FRefBottom - SegmentWidth - SegmentWidth div 4 - Spacing, SlantAngle)\r\n ]);\r\nend;\r\n\r\nprocedure TJv14SegmentedLEDDigit.CalcLSeg(Index: Integer);\r\nbegin\r\n SetSegmentRenderInfo(Index, srtPolygon, [\r\n AngleAdjustPoint(FRefCenterX + SegmentWidth div 2, FRefBottom - SegmentWidth - Spacing, SlantAngle),\r\n AngleAdjustPoint(FRefCenterX + SegmentWidth div 2, FRefCenterY + SegmentWidth + Spacing, SlantAngle),\r\n AngleAdjustPoint(FRefCenterX, FRefCenterY + Spacing, SlantAngle),\r\n AngleAdjustPoint(FRefCenterX - SegmentWidth div 2, FRefCenterY + SegmentWidth + Spacing, SlantAngle),\r\n AngleAdjustPoint(FRefCenterX - SegmentWidth div 2, FRefBottom - SegmentWidth - Spacing, SlantAngle)\r\n ]);\r\nend;\r\n\r\nprocedure TJv14SegmentedLEDDigit.CalcMSeg(Index: Integer);\r\nbegin\r\n SetSegmentRenderInfo(Index, srtPolygon, [\r\n AngleAdjustPoint(FRefRight - Spacing - SegmentWidth, FRefBottom - SegmentWidth - Spacing, SlantAngle),\r\n AngleAdjustPoint(FRefRight - Spacing - SegmentWidth - SegmentWidth div 2, FRefBottom - SegmentWidth - Spacing, SlantAngle),\r\n AngleAdjustPoint(FRefCenterX + Spacing + SegmentWidth div 2, FRefCenterY + SegmentWidth + Spacing, SlantAngle),\r\n AngleAdjustPoint(FRefCenterX + Spacing + SegmentWidth div 2, FRefCenterY + SegmentWidth div 2 + Spacing, SlantAngle),\r\n AngleAdjustPoint(FRefCenterX + Spacing + SegmentWidth, FRefCenterY + SegmentWidth div 2 + Spacing, SlantAngle),\r\n AngleAdjustPoint(FRefRight - Spacing - SegmentWidth, FRefBottom - SegmentWidth - SegmentWidth div 4 - Spacing, SlantAngle)\r\n ]);\r\nend;\r\n\r\nclass function TJv14SegmentedLEDDigit.GetSegmentIndex(Name: string): Integer;\r\nbegin\r\n Result := TextIndex(Name, ['A', 'B', 'C', 'D', 'E', 'F', 'G1', 'G2', 'H', 'I', 'J', 'K', 'L', 'M', 'DP']);\r\nend;\r\n\r\nclass function TJv14SegmentedLEDDigit.GetSegmentName(Index: Integer): string;\r\nbegin\r\n if Index = 6 then\r\n Result := 'G1'\r\n else\r\n if Index = 7 then\r\n Result := 'G2'\r\n else\r\n if Index < 6 then\r\n Result := Chr(Ord('A') + Index)\r\n else\r\n if (Index > 7) and (Index < 14) then\r\n Result := Chr(Ord('A') + Index - 1)\r\n else\r\n if Index = 14 then\r\n Result := 'DP'\r\n else\r\n Result := '';\r\nend;\r\n\r\nclass function TJv14SegmentedLEDDigit.MapperFileID: AnsiString;\r\nbegin\r\n Result := 'SLDCM_14SEG';\r\nend;\r\n\r\nprocedure TJv14SegmentedLEDDigit.RecalcSegments;\r\nbegin\r\n CalcASeg(0);\r\n CalcBSeg(1);\r\n CalcCSeg(2);\r\n CalcDSeg(3);\r\n CalcESeg(4);\r\n CalcFSeg(5);\r\n CalcG1Seg(6);\r\n CalcG2Seg(7);\r\n CalcHSeg(8);\r\n CalcISeg(9);\r\n CalcJSeg(10);\r\n CalcKSeg(11);\r\n CalcLSeg(12);\r\n CalcMSeg(13);\r\n if UseDP then\r\n CalcDPSeg(14);\r\nend;\r\n\r\nclass function TJv14SegmentedLEDDigit.SegmentCount: Integer;\r\nbegin\r\n Result := 15;\r\nend;\r\n\r\n//=== { TJv16SegmentedLEDDigit } ===============================================\r\n\r\nconst\r\n seg16Names: array[0..16] of string = (\r\n 'A1', 'A2', 'B', 'C', 'D1', 'D2', 'E', 'F', 'G1', 'G2', 'H', 'I', 'J', 'K', 'L', 'M', 'DP');\r\n\r\nprocedure TJv16SegmentedLEDDigit.CalcA1Seg(Index: Integer);\r\nbegin\r\n SetSegmentRenderInfo(Index, srtPolygon, [\r\n AngleAdjustPoint(FRefLeft + Spacing div 2, FRefTop, SlantAngle),\r\n AngleAdjustPoint(FRefCenterX - Spacing div 2, FRefTop, SlantAngle),\r\n AngleAdjustPoint(FRefCenterX - Spacing div 2 - SegmentWidth, FRefTop + SegmentWidth, SlantAngle),\r\n AngleAdjustPoint(FRefLeft + Spacing div 2 + SegmentWidth, FRefTop + SegmentWidth, SlantAngle)\r\n ]);\r\nend;\r\n\r\nprocedure TJv16SegmentedLEDDigit.CalcA2Seg(Index: Integer);\r\nbegin\r\n SetSegmentRenderInfo(Index, srtPolygon, [\r\n AngleAdjustPoint(FRefCenterX + Spacing div 2, FRefTop, SlantAngle),\r\n AngleAdjustPoint(FRefRight - Spacing div 2, FRefTop, SlantAngle),\r\n AngleAdjustPoint(FRefRight - Spacing div 2 - SegmentWidth, FRefTop + SegmentWidth, SlantAngle),\r\n AngleAdjustPoint(FRefCenterX + Spacing div 2 + SegmentWidth, FRefTop + SegmentWidth, SlantAngle)\r\n ]);\r\nend;\r\n\r\nprocedure TJv16SegmentedLEDDigit.CalcD1Seg(Index: Integer);\r\nbegin\r\n SetSegmentRenderInfo(Index, srtPolygon, [\r\n AngleAdjustPoint(FRefLeft + Spacing div 2, FRefBottom, SlantAngle),\r\n AngleAdjustPoint(FRefCenterX - Spacing div 2, FRefBottom, SlantAngle),\r\n AngleAdjustPoint(FRefCenterX - Spacing div 2 - SegmentWidth, FRefBottom - SegmentWidth, SlantAngle),\r\n AngleAdjustPoint(FRefLeft + Spacing div 2 + SegmentWidth, FRefBottom - SegmentWidth, SlantAngle)\r\n ]);\r\nend;\r\n\r\nprocedure TJv16SegmentedLEDDigit.CalcD2Seg(Index: Integer);\r\nbegin\r\n SetSegmentRenderInfo(Index, srtPolygon, [\r\n AngleAdjustPoint(FRefCenterX + Spacing div 2, FRefBottom, SlantAngle),\r\n AngleAdjustPoint(FRefRight - Spacing div 2, FRefBottom, SlantAngle),\r\n AngleAdjustPoint(FRefRight - Spacing div 2 - SegmentWidth, FRefBottom - SegmentWidth, SlantAngle),\r\n AngleAdjustPoint(FRefCenterX + Spacing div 2 + SegmentWidth, FRefBottom - SegmentWidth, SlantAngle)\r\n ]);\r\nend;\r\n\r\nprocedure TJv16SegmentedLEDDigit.CalcISeg(Index: Integer);\r\nbegin\r\n SetSegmentRenderInfo(Index, srtPolygon, [\r\n AngleAdjustPoint(FRefCenterX, FRefTop + Spacing, SlantAngle),\r\n AngleAdjustPoint(FRefCenterX + SegmentWidth div 2, FRefTop + SegmentWidth + Spacing, SlantAngle),\r\n AngleAdjustPoint(FRefCenterX + SegmentWidth div 2, FRefCenterY - SegmentWidth - Spacing, SlantAngle),\r\n AngleAdjustPoint(FRefCenterX, FRefCenterY - Spacing, SlantAngle),\r\n AngleAdjustPoint(FRefCenterX - SegmentWidth div 2, FRefCenterY - SegmentWidth - Spacing, SlantAngle),\r\n AngleAdjustPoint(FRefCenterX - SegmentWidth div 2, FRefTop + SegmentWidth + Spacing, SlantAngle)\r\n ]);\r\nend;\r\n\r\nprocedure TJv16SegmentedLEDDigit.CalcLSeg(Index: Integer);\r\nbegin\r\n SetSegmentRenderInfo(Index, srtPolygon, [\r\n AngleAdjustPoint(FRefCenterX, FRefBottom - Spacing, SlantAngle),\r\n AngleAdjustPoint(FRefCenterX + SegmentWidth div 2, FRefBottom - SegmentWidth - Spacing, SlantAngle),\r\n AngleAdjustPoint(FRefCenterX + SegmentWidth div 2, FRefCenterY + SegmentWidth + Spacing, SlantAngle),\r\n AngleAdjustPoint(FRefCenterX, FRefCenterY + Spacing, SlantAngle),\r\n AngleAdjustPoint(FRefCenterX - SegmentWidth div 2, FRefCenterY + SegmentWidth + Spacing, SlantAngle),\r\n AngleAdjustPoint(FRefCenterX - SegmentWidth div 2, FRefBottom - SegmentWidth - Spacing, SlantAngle)\r\n ]);\r\nend;\r\n\r\nclass function TJv16SegmentedLEDDigit.GetSegmentIndex(Name: string): Integer;\r\nbegin\r\n Result := TextIndex(Name, seg16Names);\r\nend;\r\n\r\nclass function TJv16SegmentedLEDDigit.GetSegmentName(Index: Integer): string;\r\nbegin\r\n Result := seg16Names[Index];\r\nend;\r\n\r\nclass function TJv16SegmentedLEDDigit.MapperFileID: AnsiString;\r\nbegin\r\n Result := 'SLDCM_16SEG';\r\nend;\r\n\r\nprocedure TJv16SegmentedLEDDigit.RecalcSegments;\r\nbegin\r\n CalcA1Seg(0);\r\n CalcA2Seg(1);\r\n CalcBSeg(2);\r\n CalcCSeg(3);\r\n CalcD1Seg(4);\r\n CalcD2Seg(5);\r\n CalcESeg(6);\r\n CalcFSeg(7);\r\n CalcG1Seg(8);\r\n CalcG2Seg(9);\r\n CalcHSeg(10);\r\n CalcISeg(11);\r\n CalcJSeg(12);\r\n CalcKSeg(13);\r\n CalcLSeg(14);\r\n CalcMSeg(15);\r\n if UseDP then\r\n CalcDPSeg(16);\r\nend;\r\n\r\nclass function TJv16SegmentedLEDDigit.SegmentCount: Integer;\r\nbegin\r\n Result := 17;\r\nend;\r\n\r\n//=== { initialization and support routines } =================================\r\n\r\nprocedure ModuleUnload(Instance: HINST);\r\nbegin\r\n UnregisterModuleSegmentedLEDDigitClasses(HMODULE(Instance));\r\nend;\r\n\r\nfunction IdentToUnlitColor(const Ident: string; var Int: Longint): Boolean;\r\nbegin\r\n Int := TextIndex(Ident, ['clDefaultBackground', 'clDefaultLitColor']);\r\n Result := Int > -1;\r\n if Result then\r\n Inc(Int, clDefaultBackground)\r\n else\r\n Result := IdentToColor(Ident, Int);\r\nend;\r\n\r\nfunction UnlitColorToIdent(Int: Longint; var Ident: string): Boolean;\r\nbegin\r\n Result := True;\r\n case Int of\r\n clDefaultBackground:\r\n Ident := 'clDefaultBackground';\r\n clDefaultLitColor:\r\n Ident := 'clDefaultLitColor';\r\n else\r\n Result := ColorToIdent(Int, Ident);\r\n end;\r\nend;\r\n\r\nfunction StringToUnlitColor(const S: string): TUnlitColor;\r\nbegin\r\n if not IdentToUnlitColor(S, Longint(Result)) then\r\n Result := StrToInt(S);\r\nend;\r\n\r\nfunction UnlitColorToString(const Color: TUnlitColor): string;\r\nbegin\r\n if not ColorToIdent(Color, Result) then\r\n Result := Format('%s%.8x', [HexDisplayPrefix, Color]);\r\nend;\r\n\r\ninitialization\r\n {$IFDEF UNITVERSIONING}\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n {$ENDIF UNITVERSIONING}\r\n AddModuleUnloadProc(ModuleUnload);\r\n RegisterSegmentedLEDDigitClasses([TJv7SegmentedLEDDigit, TJv14SegmentedLEDDigit, TJv16SegmentedLEDDigit]);\r\n RegisterIntegerConsts(TypeInfo(TUnlitColor), IdentToUnlitColor, UnlitColorToIdent);\r\n\r\nfinalization\r\n UnregisterIntegerConsts(TypeInfo(TUnlitColor), IdentToUnlitColor, UnlitColorToIdent);\r\n UnregisterModuleSegmentedLEDDigitClasses(HInstance);\r\n FreeAndNil(GDigitClassList);\r\n RemoveModuleUnloadProc(ModuleUnload);\r\n {$IFDEF UNITVERSIONING}\r\n UnregisterUnitVersion(HInstance);\r\n {$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvSegmentedLEDDisplayMapperFrame.dfm", "content": "object fmeJvSegmentedLEDDisplayMapper: TfmeJvSegmentedLEDDisplayMapper\r\n Left = 0\r\n Top = 0\r\n Width = 105\r\n Height = 135\r\n Color = clBlack\r\n ParentColor = False\r\n PopupMenu = pmDigit\r\n TabOrder = 0\r\n object sldEdit: TJvSegmentedLEDDisplay\r\n Left = 5\r\n Top = 5\r\n Width = 95\r\n Height = 125\r\n AutoSize = False\r\n DigitClassName = 'TJv7SegmentedLEDDigit'\r\n DigitHeight = 90\r\n Digits = <>\r\n DigitWidth = 60\r\n DotSize = 12\r\n PopupMenu = pmDigit\r\n SegmentLitColor = clRed\r\n SegmentSpacing = 4\r\n SegmentThickness = 8\r\n SegmentUnlitColor = clMaroon\r\n Slant = 10\r\n OnClick = sldEditClick\r\n OnMouseDown = sldEditMouseDown\r\n end\r\n object pmDigit: TPopupMenu\r\n Left = 5\r\n Top = 55\r\n object miSetStates: TMenuItem\r\n Action = aiEditSetAll\r\n end\r\n object miClearStates: TMenuItem\r\n Action = aiEditClear\r\n end\r\n object miInvertStates: TMenuItem\r\n Action = aiEditInvert\r\n end\r\n end\r\n object mnuCharMapEdit: TMainMenu\r\n Left = 5\r\n Top = 10\r\n object File1: TMenuItem\r\n Caption = '&File'\r\n object Open1: TMenuItem\r\n Action = aiFileOpen\r\n end\r\n object Save1: TMenuItem\r\n Action = aiFileSave\r\n end\r\n object N1: TMenuItem\r\n Caption = '-'\r\n end\r\n object Default1: TMenuItem\r\n Action = aiFileLoadDefault\r\n end\r\n object N2: TMenuItem\r\n Caption = '-'\r\n end\r\n object Close1: TMenuItem\r\n Action = aiFileClose\r\n end\r\n end\r\n object Edit1: TMenuItem\r\n Caption = '&Edit'\r\n object Copy1: TMenuItem\r\n Action = aiEditCopy\r\n end\r\n object Paste1: TMenuItem\r\n Action = aiEditPaste\r\n end\r\n object N3: TMenuItem\r\n Caption = '-'\r\n end\r\n object Selectchar1: TMenuItem\r\n Action = aiEditSelectChar\r\n end\r\n object Apply1: TMenuItem\r\n Action = aiEditApply\r\n end\r\n object Revert1: TMenuItem\r\n Action = aiEditRevert\r\n end\r\n object N4: TMenuItem\r\n Caption = '-'\r\n end\r\n object Setallsegments1: TMenuItem\r\n Action = aiEditSetAll\r\n end\r\n object Emptysegments1: TMenuItem\r\n Action = aiEditClear\r\n end\r\n object Invertsegments1: TMenuItem\r\n Action = aiEditInvert\r\n end\r\n end\r\n end\r\n object alCharMapEditor: TActionList\r\n OnUpdate = alCharMapEditorUpdate\r\n Left = 5\r\n Top = 100\r\n object aiFileOpen: TAction\r\n Caption = '&Open...'\r\n ShortCut = 16463\r\n OnExecute = aiFileOpenExecute\r\n end\r\n object aiFileSave: TAction\r\n Caption = '&Save...'\r\n ShortCut = 16467\r\n OnExecute = aiFileSaveExecute\r\n end\r\n object aiFileLoadDefault: TAction\r\n Caption = '&Default'\r\n OnExecute = aiFileLoadDefaultExecute\r\n end\r\n object aiFileClose: TAction\r\n Caption = '&Close'\r\n ShortCut = 32883\r\n OnExecute = aiFileCloseExecute\r\n end\r\n object aiEditCopy: TAction\r\n Caption = '&Copy'\r\n ShortCut = 16451\r\n OnExecute = aiEditCopyExecute\r\n end\r\n object aiEditPaste: TAction\r\n Caption = '&Paste'\r\n ShortCut = 16470\r\n OnExecute = aiEditPasteExecute\r\n end\r\n object aiEditClear: TAction\r\n Caption = '&Empty segments'\r\n OnExecute = aiEditClearExecute\r\n end\r\n object aiEditSetAll: TAction\r\n Caption = '&Set all segments'\r\n OnExecute = aiEditSetAllExecute\r\n end\r\n object aiEditInvert: TAction\r\n Caption = '&Invert segments'\r\n OnExecute = aiEditInvertExecute\r\n end\r\n object aiEditSelectChar: TAction\r\n Caption = 'Select c&har...'\r\n OnExecute = aiEditSelectCharExecute\r\n end\r\n object aiEditRevert: TAction\r\n Caption = '&Revert'\r\n OnExecute = aiEditRevertExecute\r\n end\r\n object aiEditApply: TAction\r\n Caption = '&Apply'\r\n OnExecute = aiEditApplyExecute\r\n end\r\n end\r\nend\r\n" }, { "path": "External/Jedi/Jvcl/run/JvSegmentedLEDDisplayMapperFrame.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvSegmentedLEDDisplayMapperFrame.pas, released on 2003-07-18.\r\n\r\nThe Initial Developer of the Original Code is Marcel Bestebroer\r\nPortions created by Marcel Bestebroer are Copyright (C) 2002 - 2003 Marcel\r\nBestebroer\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvSegmentedLEDDisplayMapperFrame.pas 13138 2011-10-26 23:17:50Z jfudickar $\r\n\r\nunit JvSegmentedLEDDisplayMapperFrame;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,\r\n ActnList, Menus,\r\n {$IFDEF USE_DXGETTEXT}\r\n JvGnugettext,\r\n {$ENDIF USE_DXGETTEXT}\r\n JvSegmentedLEDDisplay, JvExControls;\r\n\r\ntype\r\n TfmeJvSegmentedLEDDisplayMapper = class(TFrame)\r\n sldEdit: TJvSegmentedLEDDisplay;\r\n pmDigit: TPopupMenu;\r\n miSetStates: TMenuItem;\r\n miClearStates: TMenuItem;\r\n miInvertStates: TMenuItem;\r\n mnuCharMapEdit: TMainMenu;\r\n File1: TMenuItem;\r\n Open1: TMenuItem;\r\n Save1: TMenuItem;\r\n N1: TMenuItem;\r\n Default1: TMenuItem;\r\n N2: TMenuItem;\r\n Close1: TMenuItem;\r\n Edit1: TMenuItem;\r\n Copy1: TMenuItem;\r\n Paste1: TMenuItem;\r\n N3: TMenuItem;\r\n Selectchar1: TMenuItem;\r\n Apply1: TMenuItem;\r\n Revert1: TMenuItem;\r\n N4: TMenuItem;\r\n Setallsegments1: TMenuItem;\r\n Emptysegments1: TMenuItem;\r\n Invertsegments1: TMenuItem;\r\n alCharMapEditor: TActionList;\r\n aiFileOpen: TAction;\r\n aiFileSave: TAction;\r\n aiFileLoadDefault: TAction;\r\n aiFileClose: TAction;\r\n aiEditCopy: TAction;\r\n aiEditPaste: TAction;\r\n aiEditClear: TAction;\r\n aiEditSetAll: TAction;\r\n aiEditInvert: TAction;\r\n aiEditSelectChar: TAction;\r\n aiEditRevert: TAction;\r\n aiEditApply: TAction;\r\n procedure sldEditClick(Sender: TObject);\r\n procedure sldEditMouseDown(Sender: TObject; Button: TMouseButton;\r\n Shift: TShiftState; X, Y: Integer);\r\n procedure alCharMapEditorUpdate(Action: TBasicAction;\r\n var Handled: Boolean);\r\n procedure aiFileOpenExecute(Sender: TObject);\r\n procedure aiFileSaveExecute(Sender: TObject);\r\n procedure aiFileLoadDefaultExecute(Sender: TObject);\r\n procedure aiFileCloseExecute(Sender: TObject);\r\n procedure aiEditCopyExecute(Sender: TObject);\r\n procedure aiEditPasteExecute(Sender: TObject);\r\n procedure aiEditClearExecute(Sender: TObject);\r\n procedure aiEditSetAllExecute(Sender: TObject);\r\n procedure aiEditInvertExecute(Sender: TObject);\r\n procedure aiEditSelectCharExecute(Sender: TObject);\r\n procedure aiEditRevertExecute(Sender: TObject);\r\n procedure aiEditApplyExecute(Sender: TObject);\r\n private\r\n FDisplay: TJvCustomSegmentedLEDDisplay;\r\n FMouseDownX: Integer;\r\n FMouseDownY: Integer;\r\n FCurChar: Char;\r\n FCopiedValue: Int64;\r\n FCharSelected: Boolean;\r\n FCharModified: Boolean;\r\n FMapperModified: Boolean;\r\n FLastOpenFolder: string;\r\n FLastSaveFolder: string;\r\n FLastSaveFileName: string;\r\n FOnDisplayChanged: TNotifyEvent;\r\n FOnClose: TNotifyEvent;\r\n FOnInfoUpdate: TNotifyEvent;\r\n FOnMappingChanged: TNotifyEvent;\r\n function CheckCharModified: Boolean;\r\n function CheckMapperModified: Boolean;\r\n function DoSaveMapping: Boolean;\r\n function GetDigitClass: TJvSegmentedLEDDigitClass;\r\n function GetDisplay: TJvCustomSegmentedLEDDisplay;\r\n function GetMapper: TJvSegmentedLEDCharacterMapper;\r\n procedure SetDisplay(Value: TJvCustomSegmentedLEDDisplay);\r\n protected\r\n procedure DisplayChanged;\r\n procedure CloseEditor;\r\n procedure InfoUpdate;\r\n procedure MappingChanged;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n function CanClose: Boolean;\r\n property DigitClass: TJvSegmentedLEDDigitClass read GetDigitClass;\r\n property CurChar: Char read FCurChar;\r\n property CopiedValue: Int64 read FCopiedValue;\r\n property CharSelected: Boolean read FCharSelected;\r\n property CharModified: Boolean read FCharModified;\r\n property MapperModified: Boolean read FMapperModified;\r\n property LastOpenFolder: string read FLastOpenFolder write FLastOpenFolder;\r\n property LastSaveFolder: string read FLastSaveFolder write FLastSaveFolder;\r\n property Mapper: TJvSegmentedLEDCharacterMapper read GetMapper;\r\n published\r\n property Display: TJvCustomSegmentedLEDDisplay read GetDisplay write SetDisplay;\r\n property OnDisplayChanged: TNotifyEvent read FOnDisplayChanged write FOnDisplayChanged;\r\n property OnClose: TNotifyEvent read FOnClose write FOnClose;\r\n property OnInfoUpdate: TNotifyEvent read FOnInfoUpdate write FOnInfoUpdate;\r\n property OnMappingChanged: TNotifyEvent read FOnMappingChanged write FOnMappingChanged;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvSegmentedLEDDisplayMapperFrame.pas $';\r\n Revision: '$Revision: 13138 $';\r\n Date: '$Date: 2011-10-27 01:17:50 +0200 (jeu. 27 oct. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n JvResources;\r\n\r\n{$R *.dfm}\r\n\r\ntype\r\n TJvCustomSegmentedLEDDisplayAccessProtected = class(TJvCustomSegmentedLEDDisplay);\r\n TJvCustomSegmentedLEDDigitAccessProtected = class(TJvCustomSegmentedLEDDigit);\r\n\r\nfunction Mask(SegCount: Integer): Int64;\r\nbegin\r\n Result := (1 shl SegCount) - 1;\r\nend;\r\n\r\nfunction TfmeJvSegmentedLEDDisplayMapper.CheckCharModified: Boolean;\r\nvar\r\n mr: TModalResult;\r\nbegin\r\n if FCharModified then\r\n begin\r\n mr := MessageDlg(RsTheCurrentCharacterHasBeenModifiedA, mtConfirmation,\r\n [mbYes, mbNo, mbCancel], 0);\r\n Result := mr <> mrCancel;\r\n if mr = mrYes then\r\n aiEditApply.Execute\r\n else\r\n if Result then\r\n FCharModified := False;\r\n end\r\n else\r\n Result := True;\r\nend;\r\n\r\nfunction TfmeJvSegmentedLEDDisplayMapper.CheckMapperModified: Boolean;\r\nvar\r\n mr: TModalResult;\r\nbegin\r\n if FMapperModified then\r\n begin\r\n mr := MessageDlg(RsTheCurrentMappingHasBeenModifiedSav, mtConfirmation,\r\n [mbYes, mbNo, mbCancel], 0);\r\n Result := mr <> mrCancel;\r\n if mr = mrYes then\r\n Result := DoSaveMapping\r\n else\r\n if Result then\r\n FMapperModified := False;\r\n end\r\n else\r\n Result := True;\r\nend;\r\n\r\nfunction TfmeJvSegmentedLEDDisplayMapper.DoSaveMapping: Boolean;\r\nbegin\r\n with TSaveDialog.Create(Application) do\r\n try\r\n InitialDir := LastSaveFolder;\r\n Options := [ofOverwritePrompt, ofNoChangeDir, ofNoValidate, ofPathMustExist,\r\n ofShareAware, ofNoReadOnlyReturn, ofNoTestFileCreate, ofEnableSizing];\r\n Filter := RsSegmentedLEDDisplayMappingFilessdms;\r\n FilterIndex := 0;\r\n FileName := FLastSaveFileName;\r\n Result := Execute;\r\n if Result then\r\n try\r\n FLastSaveFolder := ExtractFilePath(FileName);\r\n FLastSaveFileName := FileName;\r\n Mapper.SaveToFile(FileName);\r\n FMapperModified := False;\r\n except\r\n Result := False;\r\n raise;\r\n end;\r\n finally\r\n Free;\r\n end;\r\nend;\r\n\r\nfunction TfmeJvSegmentedLEDDisplayMapper.GetMapper: TJvSegmentedLEDCharacterMapper;\r\nbegin\r\n Result := TJvCustomSegmentedLEDDisplayAccessProtected(Display).CharacterMapper;\r\nend;\r\n\r\nfunction TfmeJvSegmentedLEDDisplayMapper.GetDigitClass: TJvSegmentedLEDDigitClass;\r\nbegin\r\n Result := TJvCustomSegmentedLEDDisplayAccessProtected(Display).DigitClass;\r\nend;\r\n\r\nfunction TfmeJvSegmentedLEDDisplayMapper.GetDisplay: TJvCustomSegmentedLEDDisplay;\r\nbegin\r\n Result := FDisplay;\r\nend;\r\n\r\nprocedure TfmeJvSegmentedLEDDisplayMapper.SetDisplay(Value: TJvCustomSegmentedLEDDisplay);\r\nbegin\r\n if Value <> Display then\r\n begin\r\n FDisplay := Value;\r\n if Value <> nil then\r\n begin\r\n sldEdit.DigitClass := TJvCustomSegmentedLEDDisplayAccessProtected(Value).DigitClass;\r\n if sldEdit.Digits.Count = 0 then\r\n sldEdit.Digits.Add;\r\n TJvCustomSegmentedLEDDigitAccessProtected(sldEdit.Digits[0]).EnableAllSegs;\r\n DisplayChanged;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TfmeJvSegmentedLEDDisplayMapper.DisplayChanged;\r\nbegin\r\n if Assigned(FOnDisplayChanged) then\r\n FOnDisplayChanged(Self);\r\nend;\r\n\r\nprocedure TfmeJvSegmentedLEDDisplayMapper.CloseEditor;\r\nbegin\r\n if Assigned(FOnClose) then\r\n FOnClose(Self);\r\nend;\r\n\r\nprocedure TfmeJvSegmentedLEDDisplayMapper.InfoUpdate;\r\nbegin\r\n if Assigned(FOnInfoUpdate) then\r\n FOnInfoUpdate(Self);\r\nend;\r\n\r\nprocedure TfmeJvSegmentedLEDDisplayMapper.MappingChanged;\r\nbegin\r\n if Assigned(FOnMappingChanged) then\r\n FOnMappingChanged(Self);\r\nend;\r\n\r\nconstructor TfmeJvSegmentedLEDDisplayMapper.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n {$IFDEF USE_DXGETTEXT}\r\n TranslateComponent(Self);\r\n {$ENDIF USE_DXGETTEXT}\r\n FCopiedValue := -1;\r\nend;\r\n\r\nfunction TfmeJvSegmentedLEDDisplayMapper.CanClose: Boolean;\r\nbegin\r\n Result := CheckCharModified and CheckMapperModified;\r\nend;\r\n\r\nprocedure TfmeJvSegmentedLEDDisplayMapper.sldEditClick(Sender: TObject);\r\nvar\r\n Digit: TJvCustomSegmentedLEDDigit;\r\n SegIdx: Integer;\r\nbegin\r\n if aiEditClear.Enabled and\r\n (sldEdit.GetHitInfo(FMouseDownX, FMouseDownY, Digit, SegIdx) = shiDigitSegment) then\r\n begin\r\n TJvCustomSegmentedLEDDigitAccessProtected(Digit).SetSegmentStates(Digit.GetSegmentStates xor 1 shl SegIdx);\r\n FCharModified := True;\r\n end;\r\nend;\r\n\r\nprocedure TfmeJvSegmentedLEDDisplayMapper.sldEditMouseDown(Sender: TObject;\r\n Button: TMouseButton; Shift: TShiftState; X, Y: Integer);\r\nbegin\r\n FMouseDownX := X;\r\n FMouseDownY := Y;\r\nend;\r\n\r\nprocedure TfmeJvSegmentedLEDDisplayMapper.alCharMapEditorUpdate(Action: TBasicAction;\r\n var Handled: Boolean);\r\nbegin\r\n if Action = aiFileClose then\r\n begin\r\n aiFileOpen.Enabled := Display <> nil;\r\n aiFileSave.Enabled := FMapperModified;\r\n aiFileLoadDefault.Enabled := aiFileOpen.Enabled;\r\n aiEditApply.Enabled := FCharModified;\r\n aiEditPaste.Enabled := (FCopiedValue <> -1);\r\n aiEditRevert.Enabled := FCharModified;\r\n aiEditClear.Enabled := FCharSelected;\r\n aiEditInvert.Enabled := aiEditClear.Enabled;\r\n aiEditSetAll.Enabled := aiEditClear.Enabled;\r\n aiEditCopy.Enabled := aiEditClear.Enabled;\r\n aiEditSelectChar.Enabled := Display <> nil;\r\n InfoUpdate;\r\n end;\r\nend;\r\n\r\nprocedure TfmeJvSegmentedLEDDisplayMapper.aiFileOpenExecute(Sender: TObject);\r\nbegin\r\n if CheckCharModified and CheckMapperModified then\r\n begin\r\n with TOpenDialog.Create(Application) do\r\n try\r\n InitialDir := LastOpenFolder;\r\n Options := [ofNoChangeDir, ofPathMustExist, ofFileMustExist,\r\n ofShareAware, ofNoNetworkButton, ofNoLongNames, ofEnableSizing];\r\n Filter := RsSegmentedLEDDisplayMappingFilessdms;\r\n FilterIndex := 0;\r\n if Execute then\r\n begin\r\n Mapper.LoadFromFile(FileName);\r\n LastOpenFolder := ExtractFilePath(FileName);\r\n aiEditRevert.OnExecute(Sender);\r\n end;\r\n finally\r\n Free;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TfmeJvSegmentedLEDDisplayMapper.aiFileSaveExecute(Sender: TObject);\r\nbegin\r\n if CheckCharModified then\r\n DoSaveMapping;\r\nend;\r\n\r\nprocedure TfmeJvSegmentedLEDDisplayMapper.aiFileLoadDefaultExecute(Sender: TObject);\r\nbegin\r\n if CheckCharModified and CheckMapperModified then\r\n begin\r\n Mapper.LoadDefaultMapping;\r\n aiEditRevert.OnExecute(Sender);\r\n end;\r\nend;\r\n\r\nprocedure TfmeJvSegmentedLEDDisplayMapper.aiFileCloseExecute(Sender: TObject);\r\nvar\r\n ParentForm: TCustomForm;\r\nbegin\r\n CloseEditor;\r\n ParentForm := GetParentForm(Self);\r\n if ParentForm <> nil then\r\n ParentForm.Close;\r\nend;\r\n\r\nprocedure TfmeJvSegmentedLEDDisplayMapper.aiEditCopyExecute(Sender: TObject);\r\nbegin\r\n FCopiedValue := sldEdit.Digits[0].GetSegmentStates;\r\nend;\r\n\r\nprocedure TfmeJvSegmentedLEDDisplayMapper.aiEditPasteExecute(Sender: TObject);\r\nbegin\r\n TJvCustomSegmentedLEDDigitAccessProtected(sldEdit.Digits[0]).SetSegmentStates(FCopiedValue);\r\n FCharModified := True;\r\nend;\r\n\r\nprocedure TfmeJvSegmentedLEDDisplayMapper.aiEditClearExecute(Sender: TObject);\r\nbegin\r\n TJvCustomSegmentedLEDDigitAccessProtected(sldEdit.Digits[0]).SetSegmentStates(0);\r\n FCharModified := True;\r\nend;\r\n\r\nprocedure TfmeJvSegmentedLEDDisplayMapper.aiEditSetAllExecute(Sender: TObject);\r\nvar\r\n Digit: TJvCustomSegmentedLEDDigit;\r\nbegin\r\n Digit := sldEdit.Digits[0];\r\n TJvCustomSegmentedLEDDigitAccessProtected(Digit).SetSegmentStates(Digit.GetSegmentStates or Mask(Digit.SegmentCount));\r\n FCharModified := True;\r\nend;\r\n\r\nprocedure TfmeJvSegmentedLEDDisplayMapper.aiEditInvertExecute(Sender: TObject);\r\nvar\r\n Digit: TJvCustomSegmentedLEDDigit;\r\nbegin\r\n Digit := sldEdit.Digits[0];\r\n TJvCustomSegmentedLEDDigitAccessProtected(Digit).SetSegmentStates(Digit.GetSegmentStates xor Mask(Digit.SegmentCount));\r\n FCharModified := True;\r\nend;\r\n\r\nprocedure TfmeJvSegmentedLEDDisplayMapper.aiEditSelectCharExecute(Sender: TObject);\r\nvar\r\n S: string;\r\n Done: Boolean;\r\nbegin\r\n if FCharSelected then\r\n S := FCurChar\r\n else\r\n S := '';\r\n Done := False;\r\n repeat\r\n if InputQuery(RsSelectCharacter, RsSpecifyANewCharacter, S) then\r\n begin\r\n if Length(S) > 0 then\r\n begin\r\n if (S[1] = '#') and (Length(S) > 1) then\r\n S := Chr(StrToInt(Copy(S, 2, Length(S) - 1)));\r\n FCurChar := S[1];\r\n FCharSelected := True;\r\n Done := True;\r\n aiEditRevert.OnExecute(Sender);\r\n end;\r\n end\r\n else\r\n Done := True;\r\n until Done;\r\nend;\r\n\r\nprocedure TfmeJvSegmentedLEDDisplayMapper.aiEditRevertExecute(Sender: TObject);\r\nbegin\r\n TJvCustomSegmentedLEDDigitAccessProtected(sldEdit.Digits[0]).SetSegmentStates(\r\n Mapper.CharMapping[FCurChar]);\r\n FCharModified := False;\r\nend;\r\n\r\nprocedure TfmeJvSegmentedLEDDisplayMapper.aiEditApplyExecute(Sender: TObject);\r\nbegin\r\n Mapper.CharMapping[FCurChar] := sldEdit.Digits[0].GetSegmentStates;\r\n FCharModified := False;\r\n FMapperModified := True;\r\n MappingChanged;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvSelectDirectory.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvSelectDirectory.PAS, released on 2001-02-28.\r\n\r\nThe Initial Developer of the Original Code is Sbastien Buysse [sbuysse att buypin dott com]\r\nPortions created by Sbastien Buysse are Copyright (C) 2001 Sbastien Buysse.\r\nAll Rights Reserved.\r\n\r\nContributor(s): Michael Beck [mbeck att bigfoot dott com].\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvSelectDirectory.pas 13352 2012-06-14 09:21:26Z obones $\r\n\r\nunit JvSelectDirectory;\r\n\r\n{$I jvcl.inc}\r\n{$I crossplatform.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, Classes,\r\n FileCtrl,\r\n JvBaseDlg;\r\n\r\ntype\r\n { TODO -opeter3 : Rewrite to not depend on FileCtrl? }\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvSelectDirectory = class(TJvCommonDialog)\r\n private\r\n FDirectory: string;\r\n FHelpContext: Longint;\r\n FInitialDir: string;\r\n FClassicDialog: Boolean;\r\n FOptions: TSelectDirOpts;\r\n FTitle: string;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n function Execute(ParentWnd: HWND): Boolean; overload; override;\r\n published\r\n property Directory: string read FDirectory;\r\n property HelpContext: Longint read FHelpContext write FHelpContext default 0;\r\n property InitialDir: string read FInitialDir write FInitialDir;\r\n property ClassicDialog: Boolean read FClassicDialog write FClassicDialog default True;\r\n property Options: TSelectDirOpts read FOptions write FOptions default [sdAllowCreate, sdPerformCreate, sdPrompt];\r\n property Title: string read FTitle write FTitle;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvSelectDirectory.pas $';\r\n Revision: '$Revision: 13352 $';\r\n Date: '$Date: 2012-06-14 11:21:26 +0200 (jeu. 14 juin 2012) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\n\r\nconstructor TJvSelectDirectory.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FDirectory := '';\r\n FInitialDir := '';\r\n FHelpContext := 0;\r\n FClassicDialog := True;\r\n FOptions := [sdAllowCreate, sdPerformCreate, sdPrompt];\r\n FTitle := '';\r\nend;\r\n\r\nfunction TJvSelectDirectory.Execute(ParentWnd: HWND): Boolean;\r\nbegin\r\n FDirectory := InitialDir;\r\n DoShow;\r\n try\r\n if ClassicDialog then\r\n Result := SelectDirectory(FDirectory, Options, HelpContext)\r\n else\r\n Result := SelectDirectory(Title, InitialDir, FDirectory);\r\n finally\r\n DoClose;\r\n end;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvSerialMaker.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain A copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvSerialMaker.PAS, released on 2001-02-28.\r\n\r\nThe Initial Developer of the Original Code is Sbastien Buysse [sbuysse att buypin dott com]\r\nPortions created by Sbastien Buysse are Copyright (C) 2001 Sbastien Buysse.\r\nAll Rights Reserved.\r\n\r\nContributor(s): Michael Beck [mbeck att bigfoot dott com].\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvSerialMaker.pas 13138 2011-10-26 23:17:50Z jfudickar $\r\n\r\nunit JvSerialMaker;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n SysUtils, Classes,\r\n JvComponentBase;\r\n\r\ntype\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64 or pidOSX32)]\r\n {$ENDIF RTL230_UP}\r\n TJvSerialMaker = class(TJvComponent)\r\n private\r\n FUserName: string;\r\n FBase: Integer;\r\n FSerial: string;\r\n FDummy: string;\r\n procedure ChangeUser(AUserName: string);\r\n procedure ChangeBase(ABase: Integer);\r\n public\r\n function GiveSerial(ABase: Integer; AUserName: string): string;\r\n function SerialIsCorrect(ABase: Integer; AUserName: string; Serial: string): Boolean;\r\n published\r\n property UserName: string read FUserName write ChangeUser;\r\n property Base: Integer read FBase write ChangeBase;\r\n { Do not store dummies }\r\n property Serial: string read FSerial write FDummy stored False;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvSerialMaker.pas $';\r\n Revision: '$Revision: 13138 $';\r\n Date: '$Date: 2011-10-27 01:17:50 +0200 (jeu. 27 oct. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n JvResources;\r\n\r\nprocedure TJvSerialMaker.ChangeUser(AUserName: string);\r\nbegin\r\n FUserName := AUserName;\r\n FSerial := GiveSerial(Base, AUserName);\r\nend;\r\n\r\nprocedure TJvSerialMaker.ChangeBase(ABase: Integer);\r\nbegin\r\n FBase := ABase;\r\n FSerial := GiveSerial(ABase, UserName);\r\nend;\r\n\r\nfunction TJvSerialMaker.GiveSerial(ABase: Integer; AUserName: string): string;\r\nvar\r\n A: Integer;\r\nbegin\r\n if (ABase <> 0) and (AUserName <> '') then\r\n begin\r\n A := ABase * Length(AUserName) + Ord(AUserName[1]) * 666;\r\n Result := IntToStr(A) + '-';\r\n A := ABase * Ord(AUserName[1]) * 123;\r\n Result := Result + IntToStr(A) + '-';\r\n A := ABase + (Length(AUserName) * Ord(AUserName[1])) * 6613;\r\n Result := Result + IntToStr(A);\r\n end\r\n else\r\n Result := RsError;\r\nend;\r\n\r\nfunction TJvSerialMaker.SerialIsCorrect(ABase: Integer; AUserName: string; Serial: string): Boolean;\r\nbegin\r\n if (AUserName <> '') and (ABase <> 0) then\r\n Result := Serial = GiveSerial(ABase, AUserName)\r\n else\r\n Result := False;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvSetupApi.pas", "content": "{******************************************************************}\r\n{ }\r\n{ Borland Delphi Runtime Library }\r\n{ Setup and Device Installer API interface unit }\r\n{ }\r\n{ Portions created by Microsoft are }\r\n{ Copyright (C) 1995-1999 Microsoft Corporation. }\r\n{ All Rights Reserved. }\r\n{ }\r\n{ The original file is: setupapi.h, released March 1999. }\r\n{ The original Pascal code is: SetupApi.pas, released 29 Jan 2000. }\r\n{ The initial developer of the Pascal code is Robert Marquardt }\r\n{ (robert_marquardt att gmx dott de) }\r\n{ }\r\n{ Portions created by Robert Marquardt are }\r\n{ Copyright (C) 1999 Robert Marquardt. }\r\n{ }\r\n{ Contributor(s): Marcel van Brakel (brakelm att bart dott nl) }\r\n{ }\r\n{ Obtained through: }\r\n{ Joint Endeavour of Delphi Innovators (Project JEDI) }\r\n{ }\r\n{ You may retrieve the latest version of this file at the Project }\r\n{ JEDI home page, located at http://delphi-jedi.org }\r\n{ }\r\n{ The contents of this file are used with permission, subject to }\r\n{ the Mozilla Public License Version 1.1 (the \"License\"); you may }\r\n{ not use this file except in compliance with the License. You may }\r\n{ obtain a copy of the License at }\r\n{ http://www.mozilla.org/MPL/MPL-1.1.html }\r\n{ }\r\n{ Software distributed under the License is distributed on an }\r\n{ \"AS IS\" basis, WITHOUT WARRANTY OF ANY KIND, either express or }\r\n{ implied. See the License for the specific language governing }\r\n{ rights and limitations under the License. }\r\n{ }\r\n{******************************************************************}\r\n\r\n{* ----------------------------------------------------------------\r\n NOTES ON INTEGRATION\r\n \r\n This file is specific to the JVCL and works well with the current\r\n version of the library.\r\n Note however that is not complete and might well be out of date\r\n with respect to the official windows API.\r\n If you want a more up to date version, you should look for \r\n SetupApi.pas inside the JEDI WinAPI project at this address:\r\n \r\n http://blog.delphi-jedi.net/jedi-api-headers/ \r\n---------------------------------------------------------------- *}\r\n\r\nunit JvSetupApi;\r\n\r\n{$I jvcl.inc}\r\n{$I windowsversion.inc}\r\n\r\ninterface\r\n\r\n{$WEAKPACKAGEUNIT ON}\r\n\r\n// (rom) this is the switch to change between static and dynamic linking.\r\n// (rom) it is enabled by default here.\r\n// (rom) To disable simply change the '$' to a '.'.\r\n{$DEFINE SETUPAPI_LINKONREQUEST}\r\n\r\n(*$HPPEMIT '#include \"setupapi.h\"'*)\r\n\r\nuses\r\n Windows, CommCtrl,\r\n {$IFDEF SETUPAPI_LINKONREQUEST}\r\n ModuleLoader,\r\n {$ENDIF SETUPAPI_LINKONREQUEST}\r\n WinConvTypes;\r\n\r\nconst\r\n ANYSIZE_ARRAY = 1;\r\n {$EXTERNALSYM ANYSIZE_ARRAY}\r\n\r\n//\r\n// Define maximum string length constants as specified by\r\n// Windows 95.\r\n//\r\nconst\r\n LINE_LEN = 256; // Win95-compatible maximum for displayable\r\n {$EXTERNALSYM LINE_LEN}\r\n // strings coming from a device INF.\r\n MAX_INF_STRING_LENGTH = 4096; // Actual maximum size of an INF string\r\n {$EXTERNALSYM MAX_INF_STRING_LENGTH}\r\n // (including string substitutions).\r\n MAX_TITLE_LEN = 60;\r\n {$EXTERNALSYM MAX_TITLE_LEN}\r\n MAX_INSTRUCTION_LEN = 256;\r\n {$EXTERNALSYM MAX_INSTRUCTION_LEN}\r\n MAX_LABEL_LEN = 30;\r\n {$EXTERNALSYM MAX_LABEL_LEN}\r\n MAX_SERVICE_NAME_LEN = 256;\r\n {$EXTERNALSYM MAX_SERVICE_NAME_LEN}\r\n MAX_SUBTITLE_LEN = 256;\r\n {$EXTERNALSYM MAX_SUBTITLE_LEN}\r\n\r\n//\r\n// Define maximum length of a machine name in the format expected by ConfigMgr32\r\n// CM_Connect_Machine (i.e., \"\\\\\\\\MachineName\\0\").\r\n//\r\n\r\n SP_MAX_MACHINENAME_LENGTH = MAX_PATH + 3;\r\n {$EXTERNALSYM SP_MAX_MACHINENAME_LENGTH}\r\n\r\n//\r\n// Define type for reference to loaded inf file\r\n//\r\n\r\ntype\r\n HINF = Pointer;\r\n {$EXTERNALSYM HINF}\r\n\r\n//\r\n// Inf context structure. Applications must not interpret or\r\n// overwrite values in these structures.\r\n//\r\n PInfContext = ^TInfContext;\r\n INFCONTEXT = record\r\n Inf: HINF;\r\n CurrentInf: HINF;\r\n Section: UINT;\r\n Line: UINT;\r\n end;\r\n {$EXTERNALSYM INFCONTEXT}\r\n TInfContext = INFCONTEXT;\r\n\r\n//\r\n// Inf file information structure.\r\n//\r\n PSPInfInformation = ^TSPInfInformation;\r\n SP_INF_INFORMATION = record\r\n InfStyle: DWORD;\r\n InfCount: DWORD;\r\n VersionData: array [0..ANYSIZE_ARRAY - 1] of Byte;\r\n end;\r\n {$EXTERNALSYM SP_INF_INFORMATION}\r\n TSPInfInformation = SP_INF_INFORMATION;\r\n\r\n//\r\n// Define structure for passing alternate platform info into\r\n// SetupSetFileQueueAlternatePlatform and SetupQueryInfOriginalFileInformation.\r\n//\r\n PSPAltPlatformInfoV2 = ^SP_ALTPLATFORM_INFO_V2;\r\n SP_ALTPLATFORM_INFO_V2 = record\r\n cbSize: DWORD;\r\n //\r\n // platform to use (VER_PLATFORM_WIN32_WINDOWS or VER_PLATFORM_WIN32_NT)\r\n //\r\n Platform: DWORD;\r\n //\r\n // major and minor version numbers to use\r\n //\r\n MajorVersion: DWORD;\r\n MinorVersion: DWORD;\r\n //\r\n // processor architecture to use (PROCESSOR_ARCHITECTURE_INTEL,\r\n // PROCESSOR_ARCHITECTURE_ALPHA, PROCESSOR_ARCHITECTURE_IA64, or\r\n // PROCESSOR_ARCHITECTURE_ALPHA64)\r\n //\r\n ProcessorArchitecture: WORD;\r\n\r\n Flags: WORD;\r\n (*\r\n union {\r\n WORD Reserved; // for compatibility with V1 structure\r\n WORD Flags; // indicates validity of non V1 fields\r\n };\r\n *)\r\n\r\n //\r\n // specify SP_ALTPLATFORM_FLAGS_VERSION_RANGE in Flags\r\n // to use FirstValidatedMajorVersion and FirstValidatedMinorVersion\r\n //\r\n // Major and minor versions of the oldest previous OS for which this\r\n // package's digital signature may be considered valid. For example, say\r\n // the alternate platform is VER_PLATFORM_WIN32_NT, version 5.1. However,\r\n // it is wished that driver packages signed with a 5.0 osattr also be\r\n // considered valid. In this case, you'd have a MajorVersion/MinorVersion\r\n // of 5.1, and a FirstValidatedMajorVersion/FirstValidatedMinorVersion of\r\n // 5.0. To validate packages signed for any previous OS release, specify\r\n // 0 for these fields. To only validate against the target alternate\r\n // platform, specify the same values as those in the MajorVersion and\r\n // MinorVersion fields.\r\n //\r\n FirstValidatedMajorVersion: DWORD;\r\n FirstValidatedMinorVersion: DWORD;\r\n end;\r\n {$EXTERNALSYM SP_ALTPLATFORM_INFO_V2}\r\n TSPAltPlatformInfoV2 = SP_ALTPLATFORM_INFO_V2;\r\n\r\n PSPAltPlatformInfoV1 = ^TSPAltPlatformInfoV1;\r\n SP_ALTPLATFORM_INFO_V1 = record\r\n cbSize: DWORD;\r\n //\r\n // platform to use (VER_PLATFORM_WIN32_WINDOWS or VER_PLATFORM_WIN32_NT)\r\n //\r\n Platform: DWORD;\r\n //\r\n // major and minor version numbers to use\r\n //\r\n MajorVersion: DWORD;\r\n MinorVersion: DWORD;\r\n //\r\n // processor architecture to use (PROCESSOR_ARCHITECTURE_INTEL,\r\n // PROCESSOR_ARCHITECTURE_ALPHA, PROCESSOR_ARCHITECTURE_IA64, or\r\n // PROCESSOR_ARCHITECTURE_ALPHA64)\r\n //\r\n ProcessorArchitecture: Word;\r\n Reserved: Word; // must be zero.\r\n end;\r\n {$EXTERNALSYM SP_ALTPLATFORM_INFO_V1}\r\n TSPAltPlatformInfoV1 = SP_ALTPLATFORM_INFO_V1;\r\n\r\n {$IFDEF WINXP_UP}\r\n PSPAltPlatformInfo = PSPAltPlatformInfoV2;\r\n TSPAltPlatformInfo = TSPAltPlatformInfoV2;\r\n {$ELSE}\r\n PSPAltPlatformInfo = PSPAltPlatformInfoV1;\r\n TSPAltPlatformInfo = TSPAltPlatformInfoV1;\r\n {$ENDIF WINXP_UP}\r\n\r\n//\r\n// the following flags are available to SP_ALTPLATFORM_INFO_V2\r\n//\r\nconst\r\n SP_ALTPLATFORM_FLAGS_VERSION_RANGE = $0001; // FirstValidatedMajor/MinorVersion\r\n {$EXTERNALSYM SP_ALTPLATFORM_FLAGS_VERSION_RANGE}\r\n\r\n//\r\n// Define structure that is filled in by SetupQueryInfOriginalFileInformation\r\n// to indicate the INF's original name and the original name of the (potentially\r\n// platform-specific) catalog file specified by that INF.\r\n//\r\ntype\r\n PSPOriginalFileInfoA = ^TSPOriginalFileInfoA;\r\n PSPOriginalFileInfoW = ^TSPOriginalFileInfoW;\r\n SP_ORIGINAL_FILE_INFO_A = record\r\n cbSize: DWORD;\r\n OriginalInfName: array [0..MAX_PATH - 1] of AnsiChar;\r\n OriginalCatalogName: array [0..MAX_PATH - 1] of AnsiChar;\r\n end;\r\n {$EXTERNALSYM SP_ORIGINAL_FILE_INFO_A}\r\n SP_ORIGINAL_FILE_INFO_W = record\r\n cbSize: DWORD;\r\n OriginalInfName: array [0..MAX_PATH - 1] of WideChar;\r\n OriginalCatalogName: array [0..MAX_PATH - 1] of WideChar;\r\n end;\r\n {$EXTERNALSYM SP_ORIGINAL_FILE_INFO_W}\r\n TSPOriginalFileInfoA = SP_ORIGINAL_FILE_INFO_A;\r\n TSPOriginalFileInfoW = SP_ORIGINAL_FILE_INFO_W;\r\n {$IFDEF UNICODE}\r\n PSPOriginalFileInfo = PSPOriginalFileInfoW;\r\n TSPOriginalFileInfo = TSPOriginalFileInfoW;\r\n {$ELSE}\r\n TSPOriginalFileInfo = TSPOriginalFileInfoA;\r\n PSPOriginalFileInfo = PSPOriginalFileInfoA;\r\n {$ENDIF UNICODE}\r\n\r\n//\r\n// SP_INF_INFORMATION.InfStyle values\r\n//\r\nconst\r\n INF_STYLE_NONE = $00000000; // unrecognized or non-existent\r\n {$EXTERNALSYM INF_STYLE_NONE}\r\n INF_STYLE_OLDNT = $00000001; // winnt 3.x\r\n {$EXTERNALSYM INF_STYLE_OLDNT}\r\n INF_STYLE_WIN4 = $00000002; // Win95\r\n {$EXTERNALSYM INF_STYLE_WIN4}\r\n\r\n//\r\n// Additional InfStyle flags that may be specified when calling SetupOpenInfFile.\r\n//\r\n//\r\n INF_STYLE_CACHE_ENABLE = $00000010; // always cache INF, even outside of %windir%\\Inf\r\n {$EXTERNALSYM INF_STYLE_CACHE_ENABLE}\r\n INF_STYLE_CACHE_DISABLE = $00000020; // delete cached INF information\r\n {$EXTERNALSYM INF_STYLE_CACHE_DISABLE}\r\n\r\n//\r\n// Target directory specs.\r\n//\r\n DIRID_ABSOLUTE = DWORD(-1); // real 32-bit -1\r\n {$EXTERNALSYM DIRID_ABSOLUTE}\r\n DIRID_ABSOLUTE_16BIT = $FFFF; // 16-bit -1 for compat w/setupx\r\n {$EXTERNALSYM DIRID_ABSOLUTE_16BIT}\r\n DIRID_NULL = 0;\r\n {$EXTERNALSYM DIRID_NULL}\r\n DIRID_SRCPATH = 1;\r\n {$EXTERNALSYM DIRID_SRCPATH}\r\n DIRID_WINDOWS = 10;\r\n {$EXTERNALSYM DIRID_WINDOWS}\r\n DIRID_SYSTEM = 11; // system32\r\n {$EXTERNALSYM DIRID_SYSTEM}\r\n DIRID_DRIVERS = 12;\r\n {$EXTERNALSYM DIRID_DRIVERS}\r\n DIRID_IOSUBSYS = DIRID_DRIVERS;\r\n {$EXTERNALSYM DIRID_IOSUBSYS}\r\n DIRID_INF = 17;\r\n {$EXTERNALSYM DIRID_INF}\r\n DIRID_HELP = 18;\r\n {$EXTERNALSYM DIRID_HELP}\r\n DIRID_FONTS = 20;\r\n {$EXTERNALSYM DIRID_FONTS}\r\n DIRID_VIEWERS = 21;\r\n {$EXTERNALSYM DIRID_VIEWERS}\r\n DIRID_COLOR = 23;\r\n {$EXTERNALSYM DIRID_COLOR}\r\n DIRID_APPS = 24;\r\n {$EXTERNALSYM DIRID_APPS}\r\n DIRID_SHARED = 25;\r\n {$EXTERNALSYM DIRID_SHARED}\r\n DIRID_BOOT = 30;\r\n {$EXTERNALSYM DIRID_BOOT}\r\n\r\n DIRID_SYSTEM16 = 50;\r\n {$EXTERNALSYM DIRID_SYSTEM16}\r\n DIRID_SPOOL = 51;\r\n {$EXTERNALSYM DIRID_SPOOL}\r\n DIRID_SPOOLDRIVERS = 52;\r\n {$EXTERNALSYM DIRID_SPOOLDRIVERS}\r\n DIRID_USERPROFILE = 53;\r\n {$EXTERNALSYM DIRID_USERPROFILE}\r\n DIRID_LOADER = 54;\r\n {$EXTERNALSYM DIRID_LOADER}\r\n DIRID_PRINTPROCESSOR = 55;\r\n {$EXTERNALSYM DIRID_PRINTPROCESSOR}\r\n\r\n DIRID_DEFAULT = DIRID_SYSTEM;\r\n {$EXTERNALSYM DIRID_DEFAULT}\r\n\r\n//\r\n// The following DIRIDs are for commonly-used shell \"special folders\". The\r\n// complete list of such folders is contained in shlobj.h. In that headerfile,\r\n// each folder is assigned a CSIDL_* value. The DIRID values below are created\r\n// by taking the CSIDL value in shlobj.h and OR'ing it with 0x4000. Thus, if\r\n// an INF needs to reference other special folders not defined below, it may\r\n// generate one using the above mechanism, and setupapi will automatically deal\r\n// with it and use the corresponding shell's path where appropriate. (Remember\r\n// that DIRIDs must be specified in decimal, not hex, in an INF when used for\r\n// string substitution.)\r\n//\r\n DIRID_COMMON_STARTMENU = 16406; // All Users\\Start Menu\r\n {$EXTERNALSYM DIRID_COMMON_STARTMENU}\r\n DIRID_COMMON_PROGRAMS = 16407; // All Users\\Start Menu\\Programs\r\n {$EXTERNALSYM DIRID_COMMON_PROGRAMS}\r\n DIRID_COMMON_STARTUP = 16408; // All Users\\Start Menu\\Programs\\Startup\r\n {$EXTERNALSYM DIRID_COMMON_STARTUP}\r\n DIRID_COMMON_DESKTOPDIRECTORY = 16409; // All Users\\Desktop\r\n {$EXTERNALSYM DIRID_COMMON_DESKTOPDIRECTORY}\r\n DIRID_COMMON_FAVORITES = 16415; // All Users\\Favorites\r\n {$EXTERNALSYM DIRID_COMMON_FAVORITES}\r\n DIRID_COMMON_APPDATA = 16419; // All Users\\Application Data\r\n {$EXTERNALSYM DIRID_COMMON_APPDATA}\r\n\r\n DIRID_PROGRAM_FILES = 16422; // Program Files\r\n {$EXTERNALSYM DIRID_PROGRAM_FILES}\r\n DIRID_SYSTEM_X86 = 16425; // system32 on RISC\r\n {$EXTERNALSYM DIRID_SYSTEM_X86}\r\n DIRID_PROGRAM_FILES_X86 = 16426; // Program Files on RISC\r\n {$EXTERNALSYM DIRID_PROGRAM_FILES_X86}\r\n DIRID_PROGRAM_FILES_COMMON = 16427; // Program Files\\Common\r\n {$EXTERNALSYM DIRID_PROGRAM_FILES_COMMON}\r\n DIRID_PROGRAM_FILES_COMMONX86 = 16428; // x86 Program Files\\Common on RISC\r\n {$EXTERNALSYM DIRID_PROGRAM_FILES_COMMONX86}\r\n\r\n DIRID_COMMON_TEMPLATES = 16429; // All Users\\Templates\r\n {$EXTERNALSYM DIRID_COMMON_TEMPLATES}\r\n DIRID_COMMON_DOCUMENTS = 16430; // All Users\\Documents\r\n {$EXTERNALSYM DIRID_COMMON_DOCUMENTS}\r\n\r\n//\r\n// First user-definable dirid. See SetupSetDirectoryId().\r\n//\r\n DIRID_USER = $8000;\r\n {$EXTERNALSYM DIRID_USER}\r\n\r\n//\r\n// Setup callback notification routine type\r\n//\r\ntype\r\n TSPFileCallbackA = function(Context: Pointer; Notification: UINT;\r\n Param1, Param2: UINT_PTR): UINT; stdcall;\r\n TSPFileCallbackW = function(Context: Pointer; Notification: UINT;\r\n Param1, Param2: UINT_PTR): UINT; stdcall;\r\n {$IFDEF UNICODE}\r\n TSPFileCallback = TSPFileCallbackW;\r\n {$ELSE}\r\n TSPFileCallback = TSPFileCallbackA;\r\n {$ENDIF UNICODE}\r\n\r\n//\r\n// Operation/queue start/end notification. These are ordinal values.\r\n//\r\nconst\r\n SPFILENOTIFY_STARTQUEUE = $00000001;\r\n {$EXTERNALSYM SPFILENOTIFY_STARTQUEUE}\r\n SPFILENOTIFY_ENDQUEUE = $00000002;\r\n {$EXTERNALSYM SPFILENOTIFY_ENDQUEUE}\r\n SPFILENOTIFY_STARTSUBQUEUE = $00000003;\r\n {$EXTERNALSYM SPFILENOTIFY_STARTSUBQUEUE}\r\n SPFILENOTIFY_ENDSUBQUEUE = $00000004;\r\n {$EXTERNALSYM SPFILENOTIFY_ENDSUBQUEUE}\r\n SPFILENOTIFY_STARTDELETE = $00000005;\r\n {$EXTERNALSYM SPFILENOTIFY_STARTDELETE}\r\n SPFILENOTIFY_ENDDELETE = $00000006;\r\n {$EXTERNALSYM SPFILENOTIFY_ENDDELETE}\r\n SPFILENOTIFY_DELETEERROR = $00000007;\r\n {$EXTERNALSYM SPFILENOTIFY_DELETEERROR}\r\n SPFILENOTIFY_STARTRENAME = $00000008;\r\n {$EXTERNALSYM SPFILENOTIFY_STARTRENAME}\r\n SPFILENOTIFY_ENDRENAME = $00000009;\r\n {$EXTERNALSYM SPFILENOTIFY_ENDRENAME}\r\n SPFILENOTIFY_RENAMEERROR = $0000000a;\r\n {$EXTERNALSYM SPFILENOTIFY_RENAMEERROR}\r\n SPFILENOTIFY_STARTCOPY = $0000000b;\r\n {$EXTERNALSYM SPFILENOTIFY_STARTCOPY}\r\n SPFILENOTIFY_ENDCOPY = $0000000c;\r\n {$EXTERNALSYM SPFILENOTIFY_ENDCOPY}\r\n SPFILENOTIFY_COPYERROR = $0000000d;\r\n {$EXTERNALSYM SPFILENOTIFY_COPYERROR}\r\n SPFILENOTIFY_NEEDMEDIA = $0000000e;\r\n {$EXTERNALSYM SPFILENOTIFY_NEEDMEDIA}\r\n SPFILENOTIFY_QUEUESCAN = $0000000f;\r\n {$EXTERNALSYM SPFILENOTIFY_QUEUESCAN}\r\n\r\n//\r\n// These are used with SetupIterateCabinet().\r\n//\r\n SPFILENOTIFY_CABINETINFO = $00000010;\r\n {$EXTERNALSYM SPFILENOTIFY_CABINETINFO}\r\n SPFILENOTIFY_FILEINCABINET = $00000011;\r\n {$EXTERNALSYM SPFILENOTIFY_FILEINCABINET}\r\n SPFILENOTIFY_NEEDNEWCABINET = $00000012;\r\n {$EXTERNALSYM SPFILENOTIFY_NEEDNEWCABINET}\r\n SPFILENOTIFY_FILEEXTRACTED = $00000013;\r\n {$EXTERNALSYM SPFILENOTIFY_FILEEXTRACTED}\r\n SPFILENOTIFY_FILEOPDELAYED = $00000014;\r\n {$EXTERNALSYM SPFILENOTIFY_FILEOPDELAYED}\r\n\r\n//\r\n// These are used for backup operations\r\n//\r\n SPFILENOTIFY_STARTBACKUP = $00000015;\r\n {$EXTERNALSYM SPFILENOTIFY_STARTBACKUP}\r\n SPFILENOTIFY_BACKUPERROR = $00000016;\r\n {$EXTERNALSYM SPFILENOTIFY_BACKUPERROR}\r\n SPFILENOTIFY_ENDBACKUP = $00000017;\r\n {$EXTERNALSYM SPFILENOTIFY_ENDBACKUP}\r\n\r\n//\r\n// Extended notification for SetupScanFileQueue(Flags=SPQ_SCAN_USE_CALLBACKEX)\r\n//\r\n SPFILENOTIFY_QUEUESCAN_EX = $00000018;\r\n {$EXTERNALSYM SPFILENOTIFY_QUEUESCAN_EX}\r\n\r\n SPFILENOTIFY_STARTREGISTRATION = $00000019;\r\n SPFILENOTIFY_ENDREGISTRATION = $00000020;\r\n {$IFDEF COMPILER11_UP}\r\n {$EXTERNALSYM SPFILENOTIFY_STARTREGISTRATION}\r\n {$EXTERNALSYM SPFILENOTIFY_ENDREGISTRATION}\r\n {$ENDIF COMPILER11_UP}\r\n\r\n//\r\n// Extended notification for SetupScanFileQueue(Flags=SPQ_SCAN_USE_CALLBACK_SIGNERINFO)\r\n//\r\n SPFILENOTIFY_QUEUESCAN_SIGNERINFO = $00000040;\r\n {$IFDEF COMPILER11_UP}\r\n {$EXTERNALSYM SPFILENOTIFY_QUEUESCAN_SIGNERINFO}\r\n {$ENDIF COMPILER11_UP}\r\n\r\n//\r\n// Copy notification. These are bit flags that may be combined.\r\n//\r\n SPFILENOTIFY_LANGMISMATCH = $00010000;\r\n {$EXTERNALSYM SPFILENOTIFY_LANGMISMATCH}\r\n SPFILENOTIFY_TARGETEXISTS = $00020000;\r\n {$EXTERNALSYM SPFILENOTIFY_TARGETEXISTS}\r\n SPFILENOTIFY_TARGETNEWER = $00040000;\r\n {$EXTERNALSYM SPFILENOTIFY_TARGETNEWER}\r\n\r\n//\r\n// File operation codes and callback outcomes.\r\n//\r\n FILEOP_COPY = 0;\r\n {$EXTERNALSYM FILEOP_COPY}\r\n FILEOP_RENAME = 1;\r\n {$EXTERNALSYM FILEOP_RENAME}\r\n FILEOP_DELETE = 2;\r\n {$EXTERNALSYM FILEOP_DELETE}\r\n FILEOP_BACKUP = 3;\r\n {$EXTERNALSYM FILEOP_BACKUP}\r\n\r\n FILEOP_ABORT = 0;\r\n {$EXTERNALSYM FILEOP_ABORT}\r\n FILEOP_DOIT = 1;\r\n {$EXTERNALSYM FILEOP_DOIT}\r\n FILEOP_SKIP = 2;\r\n {$EXTERNALSYM FILEOP_SKIP}\r\n FILEOP_RETRY = FILEOP_DOIT;\r\n {$EXTERNALSYM FILEOP_RETRY}\r\n FILEOP_NEWPATH = 4;\r\n {$EXTERNALSYM FILEOP_NEWPATH}\r\n\r\n//\r\n// Flags in inf copy sections\r\n//\r\n COPYFLG_WARN_IF_SKIP = $00000001; // warn if user tries to skip file\r\n {$EXTERNALSYM COPYFLG_WARN_IF_SKIP}\r\n COPYFLG_NOSKIP = $00000002; // disallow skipping this file\r\n {$EXTERNALSYM COPYFLG_NOSKIP}\r\n COPYFLG_NOVERSIONCHECK = $00000004; // ignore versions and overwrite target\r\n {$EXTERNALSYM COPYFLG_NOVERSIONCHECK}\r\n COPYFLG_FORCE_FILE_IN_USE = $00000008; // force file-in-use behavior\r\n {$EXTERNALSYM COPYFLG_FORCE_FILE_IN_USE}\r\n COPYFLG_NO_OVERWRITE = $00000010; // do not copy if file exists on target\r\n {$EXTERNALSYM COPYFLG_NO_OVERWRITE}\r\n COPYFLG_NO_VERSION_DIALOG = $00000020; // do not copy if target is newer\r\n {$EXTERNALSYM COPYFLG_NO_VERSION_DIALOG}\r\n COPYFLG_OVERWRITE_OLDER_ONLY = $00000040; // leave target alone if version same as source\r\n {$EXTERNALSYM COPYFLG_OVERWRITE_OLDER_ONLY}\r\n COPYFLG_REPLACEONLY = $00000400; // copy only if file exists on target\r\n {$EXTERNALSYM COPYFLG_REPLACEONLY}\r\n COPYFLG_NODECOMP = $00000800; // don't attempt to decompress file; copy as-is\r\n {$EXTERNALSYM COPYFLG_NODECOMP}\r\n COPYFLG_REPLACE_BOOT_FILE = $00001000; // file must be present upon reboot (i.e., it's\r\n {$EXTERNALSYM COPYFLG_REPLACE_BOOT_FILE} // needed by the loader); this flag implies a reboot\r\n COPYFLG_NOPRUNE = $00002000; // never prune this file\r\n {$EXTERNALSYM COPYFLG_NOPRUNE}\r\n\r\n//\r\n// Flags in inf delete sections\r\n// New flags go in high word\r\n//\r\n DELFLG_IN_USE = $00000001; // queue in-use file for delete\r\n {$EXTERNALSYM DELFLG_IN_USE}\r\n DELFLG_IN_USE1 = $00010000; // high-word version of DELFLG_IN_USE\r\n {$EXTERNALSYM DELFLG_IN_USE1}\r\n\r\n//\r\n// Source and file paths. Used when notifying queue callback\r\n// of SPFILENOTIFY_STARTxxx, SPFILENOTIFY_ENDxxx, and SPFILENOTIFY_xxxERROR.\r\n//\r\ntype\r\n PFilePathsA = ^TFilePathsA;\r\n PFilePathsW = ^TFilePathsW;\r\n FILEPATHS_A = packed record\r\n Target: PAnsiChar;\r\n Source: PAnsiChar; // not used for delete operations\r\n Win32Error: UINT;\r\n Flags: DWORD; // such as SP_COPY_NOSKIP for copy errors\r\n end;\r\n {$EXTERNALSYM FILEPATHS_A}\r\n FILEPATHS_W = packed record\r\n Target: PWideChar;\r\n Source: PWideChar; // not used for delete operations\r\n Win32Error: UINT;\r\n Flags: DWORD; // such as SP_COPY_NOSKIP for copy errors\r\n end;\r\n {$EXTERNALSYM FILEPATHS_W}\r\n TFilePathsA = FILEPATHS_A;\r\n TFilePathsW = FILEPATHS_W;\r\n {$IFDEF UNICODE}\r\n TFilePaths = TFilePathsW;\r\n PFilePaths = PFilePathsW;\r\n {$ELSE}\r\n TFilePaths = TFilePathsA;\r\n PFilePaths = PFilePathsA;\r\n {$ENDIF UNICODE}\r\n\r\n {$IFDEF WINXP_UP}\r\n PFilePathsSignerInfoA = ^TFilePathsSignerInfoA;\r\n PFilePathsSignerInfoW = ^TFilePathsSignerInfoW;\r\n FILEPATHS_SIGNERINFO_A = packed record\r\n Target: PAnsiChar;\r\n Source: PAnsiChar; // not used for delete operations\r\n Win32Error: UINT;\r\n Flags: DWORD; // such as SP_COPY_NOSKIP for copy errors\r\n DigitalSigner: PAnsiChar;\r\n Version: PAnsiChar;\r\n CatalogFile: PAnsiChar;\r\n end;\r\n {$EXTERNALSYM FILEPATHS_SIGNERINFO_A}\r\n FILEPATHS_SIGNERINFO_W = packed record\r\n Target: PWideChar;\r\n Source: PWideChar; // not used for delete operations\r\n Win32Error: UINT;\r\n Flags: DWORD; // such as SP_COPY_NOSKIP for copy errors\r\n DigitalSigner: PWideChar;\r\n Version: PWideChar;\r\n CatalogFile: PWideChar;\r\n end;\r\n {$EXTERNALSYM FILEPATHS_SIGNERINFO_W}\r\n TFilePathsSignerInfoA = FILEPATHS_SIGNERINFO_A;\r\n TFilePathsSignerInfoW = FILEPATHS_SIGNERINFO_W;\r\n {$IFDEF UNICODE}\r\n TFilePathsSignerInfo = TFilePathsSignerInfoA;\r\n PFilePathsSignerInfo = PFilePathsSignerInfoW;\r\n {$ELSE}\r\n TFilePathsSignerInfo = TFilePathsSignerInfoA;\r\n PFilePathsSignerInfo = PFilePathsSignerInfoA;\r\n {$ENDIF UNICODE}\r\n {$ENDIF WINXP_UP}\r\n\r\n//\r\n// Structure used with SPFILENOTIFY_NEEDMEDIA\r\n//\r\n PSourceMediaA = ^TSourceMediaA;\r\n PSourceMediaW = ^TSourceMediaW;\r\n SOURCE_MEDIA_A = packed record\r\n Reserved: PAnsiChar;\r\n Tagfile: PAnsiChar; // may be NULL\r\n Description: PAnsiChar;\r\n //\r\n // Pathname part and filename part of source file\r\n // that caused us to need the media.\r\n //\r\n SourcePath: PAnsiChar;\r\n SourceFile: PAnsiChar;\r\n Flags: DWORD; // subset of SP_COPY_xxx\r\n end;\r\n {$EXTERNALSYM SOURCE_MEDIA_A}\r\n SOURCE_MEDIA_W = packed record\r\n Reserved: PWideChar;\r\n Tagfile: PWideChar; // may be NULL\r\n Description: PWideChar;\r\n //\r\n // Pathname part and filename part of source file\r\n // that caused us to need the media.\r\n //\r\n SourcePath: PWideChar;\r\n SourceFile: PWideChar;\r\n Flags: DWORD; // subset of SP_COPY_xxx\r\n end;\r\n {$EXTERNALSYM SOURCE_MEDIA_W}\r\n TSourceMediaA = SOURCE_MEDIA_A;\r\n TSourceMediaW = SOURCE_MEDIA_W;\r\n {$IFDEF UNICODE}\r\n TSourceMedia = TSourceMediaW;\r\n PSourceMedia = PSourceMediaW;\r\n {$ELSE}\r\n TSourceMedia = TSourceMediaA;\r\n PSourceMedia = PSourceMediaA;\r\n {$ENDIF UNICODE}\r\n\r\n//\r\n// Structure used with SPFILENOTIFY_CABINETINFO and\r\n// SPFILENOTIFY_NEEDNEWCABINET\r\n//\r\n PCabinetInfoA = ^TCabinetInfoA;\r\n PCabinetInfoW = ^TCabinetInfoW;\r\n CABINET_INFO_A = packed record\r\n CabinetPath: PAnsiChar;\r\n CabinetFile: PAnsiChar;\r\n DiskName: PAnsiChar;\r\n SetId: Word;\r\n CabinetNumber: Word;\r\n end;\r\n {$EXTERNALSYM CABINET_INFO_A}\r\n CABINET_INFO_W = packed record\r\n CabinetPath: PWideChar;\r\n CabinetFile: PWideChar;\r\n DiskName: PWideChar;\r\n SetId: Word;\r\n CabinetNumber: Word;\r\n end;\r\n {$EXTERNALSYM CABINET_INFO_W}\r\n TCabinetInfoA = CABINET_INFO_A;\r\n TCabinetInfoW = CABINET_INFO_W;\r\n {$IFDEF UNICODE}\r\n TCabinetInfo = TCabinetInfoW;\r\n PCabinetInfo = PCabinetInfoW;\r\n {$ELSE}\r\n TCabinetInfo = TCabinetInfoA;\r\n PCabinetInfo = PCabinetInfoA;\r\n {$ENDIF UNICODE}\r\n\r\n//\r\n// Structure used with SPFILENOTIFY_FILEINCABINET\r\n//\r\n PFileInCabinetInfoA = ^TFileInCabinetInfoA;\r\n PFileInCabinetInfoW = ^TFileInCabinetInfoW;\r\n FILE_IN_CABINET_INFO_A = packed record\r\n NameInCabinet: PAnsiChar;\r\n FileSize: DWORD;\r\n Win32Error: DWORD;\r\n DosDate: Word;\r\n DosTime: Word;\r\n DosAttribs: Word;\r\n FullTargetName: array [0..MAX_PATH - 1] of AnsiChar;\r\n end;\r\n {$EXTERNALSYM FILE_IN_CABINET_INFO_A}\r\n FILE_IN_CABINET_INFO_W = packed record\r\n NameInCabinet: PWideChar;\r\n FileSize: DWORD;\r\n Win32Error: DWORD;\r\n DosDate: Word;\r\n DosTime: Word;\r\n DosAttribs: Word;\r\n FullTargetName: array [0..MAX_PATH - 1] of WideChar;\r\n end;\r\n {$EXTERNALSYM FILE_IN_CABINET_INFO_W}\r\n TFileInCabinetInfoA = FILE_IN_CABINET_INFO_A;\r\n TFileInCabinetInfoW = FILE_IN_CABINET_INFO_W;\r\n {$IFDEF UNICODE}\r\n TFileInCabinetInfo = TFileInCabinetInfoW;\r\n PFileInCabinetInfo = PFileInCabinetInfoW;\r\n {$ELSE}\r\n TFileInCabinetInfo = TFileInCabinetInfoA;\r\n PFileInCabinetInfo = PFileInCabinetInfoA;\r\n {$ENDIF UNICODE}\r\n\r\n //\r\n // Structure used for SPFILENOTIFY_***REGISTRATION\r\n // callback\r\n //\r\n {$IFDEF WINXP_UP}\r\n PSPRegisterControlStatusA = ^TSPRegisterControlStatusA;\r\n PSPRegisterControlStatusW = ^TSPRegisterControlStatusW;\r\n SP_REGISTER_CONTROL_STATUSA = packed record\r\n cbSize: DWORD;\r\n FileName: PAnsiChar;\r\n Win32Error: DWORD;\r\n FailureCode: DWORD;\r\n end;\r\n {$EXTERNALSYM SP_REGISTER_CONTROL_STATUSA}\r\n SP_REGISTER_CONTROL_STATUSW = packed record\r\n cbSize: DWORD;\r\n FileName: PWideChar;\r\n Win32Error: DWORD;\r\n FailureCode: DWORD;\r\n end;\r\n {$EXTERNALSYM SP_REGISTER_CONTROL_STATUSW}\r\n TSPRegisterControlStatusA = SP_REGISTER_CONTROL_STATUSA;\r\n TSPRegisterControlStatusW = SP_REGISTER_CONTROL_STATUSW;\r\n {$IFDEF UNICODE}\r\n TSPRegisterControlStatus = TSPRegisterControlStatusW;\r\n PSPRegisterControlStatus = PSPRegisterControlStatusW;\r\n {$ELSE}\r\n TSPRegisterControlStatus = TSPRegisterControlStatusA;\r\n PSPRegisterControlStatus = PSPRegisterControlStatusA;\r\n {$ENDIF UNICODE}\r\n {$ENDIF WINXP_UP}\r\n\r\n//\r\n// valid values for SP_REGISTER_CONTROL_STATUS.FailureCode field\r\n//\r\nconst\r\n SPREG_SUCCESS = $00000000;\r\n {$EXTERNALSYM SPREG_SUCCESS}\r\n SPREG_LOADLIBRARY = $00000001;\r\n {$EXTERNALSYM SPREG_LOADLIBRARY}\r\n SPREG_GETPROCADDR = $00000002;\r\n {$EXTERNALSYM SPREG_GETPROCADDR}\r\n SPREG_REGSVR = $00000003;\r\n {$EXTERNALSYM SPREG_REGSVR}\r\n SPREG_DLLINSTALL = $00000004;\r\n {$EXTERNALSYM SPREG_DLLINSTALL}\r\n SPREG_TIMEOUT = $00000005;\r\n {$EXTERNALSYM SPREG_TIMEOUT}\r\n SPREG_UNKNOWN = $FFFFFFFF;\r\n {$EXTERNALSYM SPREG_UNKNOWN}\r\n\r\n//\r\n// Define type for setup file queue\r\n//\r\ntype\r\n HSPFILEQ = Pointer;\r\n {$EXTERNALSYM HSPFILEQ}\r\n\r\n//\r\n// Structure used with SetupQueueCopyIndirect\r\n//\r\n PSPFileCopyParamsA = ^TSPFileCopyParamsA;\r\n PSPFileCopyParamsW = ^TSPFileCopyParamsW;\r\n SP_FILE_COPY_PARAMS_A = packed record\r\n cbSize: DWORD;\r\n QueueHandle: HSPFILEQ;\r\n SourceRootPath: PAnsiChar;\r\n SourcePath: PAnsiChar;\r\n SourceFilename: PAnsiChar;\r\n SourceDescription: PAnsiChar;\r\n SourceTagfile: PAnsiChar;\r\n TargetDirectory: PAnsiChar;\r\n TargetFilename: PAnsiChar;\r\n CopyStyle: DWORD;\r\n LayoutInf: HINF;\r\n SecurityDescriptor: PAnsiChar;\r\n end;\r\n {$EXTERNALSYM SP_FILE_COPY_PARAMS_A}\r\n SP_FILE_COPY_PARAMS_W = packed record\r\n cbSize: DWORD;\r\n QueueHandle: HSPFILEQ;\r\n SourceRootPath: PWideChar;\r\n SourcePath: PWideChar;\r\n SourceFilename: PWideChar;\r\n SourceDescription: PWideChar;\r\n SourceTagfile: PWideChar;\r\n TargetDirectory: PWideChar;\r\n TargetFilename: PWideChar;\r\n CopyStyle: DWORD;\r\n LayoutInf: HINF;\r\n SecurityDescriptor: PWideChar;\r\n end;\r\n {$EXTERNALSYM SP_FILE_COPY_PARAMS_W}\r\n TSPFileCopyParamsA = SP_FILE_COPY_PARAMS_A;\r\n TSPFileCopyParamsW = SP_FILE_COPY_PARAMS_W;\r\n {$IFDEF UNICODE}\r\n TSPFileCopyParams = TSPFileCopyParamsW;\r\n PSPFileCopyParams = PSPFileCopyParamsW;\r\n {$ELSE}\r\n TSPFileCopyParams = TSPFileCopyParamsA;\r\n PSPFileCopyParams = PSPFileCopyParamsA;\r\n {$ENDIF UNICODE}\r\n\r\n//\r\n// Define type for setup disk space list\r\n//\r\n HDSKSPC = Pointer;\r\n {$EXTERNALSYM HDSKSPC}\r\n\r\n//\r\n// Define type for reference to device information set\r\n//\r\n HDEVINFO = Pointer;\r\n {$EXTERNALSYM HDEVINFO}\r\n\r\n//\r\n// Device information structure (references a device instance\r\n// that is a member of a device information set)\r\n//\r\n PSPDevInfoData = ^TSPDevInfoData;\r\n SP_DEVINFO_DATA = packed record\r\n cbSize: DWORD;\r\n ClassGuid: TGUID;\r\n DevInst: DWORD; // DEVINST handle\r\n Reserved: ULONG_PTR;\r\n end;\r\n {$EXTERNALSYM SP_DEVINFO_DATA}\r\n TSPDevInfoData = SP_DEVINFO_DATA;\r\n\r\n//\r\n// Device interface information structure (references a device\r\n// interface that is associated with the device information\r\n// element that owns it).\r\n//\r\n PSPDeviceInterfaceData = ^TSPDeviceInterfaceData;\r\n SP_DEVICE_INTERFACE_DATA = packed record\r\n cbSize: DWORD;\r\n InterfaceClassGuid: TGUID;\r\n Flags: DWORD;\r\n Reserved: ULONG_PTR;\r\n end;\r\n {$EXTERNALSYM SP_DEVICE_INTERFACE_DATA}\r\n TSPDeviceInterfaceData = SP_DEVICE_INTERFACE_DATA;\r\n\r\n//\r\n// Flags for SP_DEVICE_INTERFACE_DATA.Flags field.\r\n//\r\nconst\r\n SPINT_ACTIVE = $00000001;\r\n {$EXTERNALSYM SPINT_ACTIVE}\r\n SPINT_DEFAULT = $00000002;\r\n {$EXTERNALSYM SPINT_DEFAULT}\r\n SPINT_REMOVED = $00000004;\r\n {$EXTERNALSYM SPINT_REMOVED}\r\n\r\n//\r\n// Backward compatibility--do not use.\r\n//\r\n\r\ntype\r\n TSPInterfaceDeviceData = TSPDeviceInterfaceData;\r\n PSPInterfaceDeviceData = PSPDeviceInterfaceData;\r\n\r\nconst\r\n SPID_ACTIVE = SPINT_ACTIVE;\r\n {$EXTERNALSYM SPID_ACTIVE}\r\n SPID_DEFAULT = SPINT_DEFAULT;\r\n {$EXTERNALSYM SPID_DEFAULT}\r\n SPID_REMOVED = SPINT_REMOVED;\r\n {$EXTERNALSYM SPID_REMOVED}\r\n\r\ntype\r\n TFiller = record\r\n {$IFDEF CPU64}\r\n Fill: array[0..1] of Byte;\r\n {$ENDIF CPU64}\r\n end;\r\n\r\n PSPDeviceInterfaceDetailDataA = ^TSPDeviceInterfaceDetailDataA;\r\n PSPDeviceInterfaceDetailDataW = ^TSPDeviceInterfaceDetailDataW;\r\n SP_DEVICE_INTERFACE_DETAIL_DATA_A = packed record\r\n cbSize: DWORD;\r\n DevicePath: array [0..ANYSIZE_ARRAY - 1] of AnsiChar;\r\n Filler: TFiller;\r\n end;\r\n {$EXTERNALSYM SP_DEVICE_INTERFACE_DETAIL_DATA_A}\r\n SP_DEVICE_INTERFACE_DETAIL_DATA_W = packed record\r\n cbSize: DWORD;\r\n DevicePath: array [0..ANYSIZE_ARRAY - 1] of WideChar;\r\n Filler: TFiller;\r\n end;\r\n {$EXTERNALSYM SP_DEVICE_INTERFACE_DETAIL_DATA_W}\r\n TSPDeviceInterfaceDetailDataA = SP_DEVICE_INTERFACE_DETAIL_DATA_A;\r\n TSPDeviceInterfaceDetailDataW = SP_DEVICE_INTERFACE_DETAIL_DATA_W;\r\n {$IFDEF UNICODE}\r\n TSPDeviceInterfaceDetailData = TSPDeviceInterfaceDetailDataW;\r\n PSPDeviceInterfaceDetailData = PSPDeviceInterfaceDetailDataW;\r\n SP_DEVICE_INTERFACE_DETAIL_DATA = SP_DEVICE_INTERFACE_DETAIL_DATA_W;\r\n {$ELSE}\r\n TSPDeviceInterfaceDetailData = TSPDeviceInterfaceDetailDataA;\r\n PSPDeviceInterfaceDetailData = PSPDeviceInterfaceDetailDataA;\r\n SP_DEVICE_INTERFACE_DETAIL_DATA = SP_DEVICE_INTERFACE_DETAIL_DATA_A;\r\n {$ENDIF UNICODE}\r\n {$EXTERNALSYM SP_DEVICE_INTERFACE_DETAIL_DATA}\r\n\r\n//\r\n// Backward compatibility--do not use.\r\n//\r\n\r\n TSPInterfaceDeviceDetailDataA = TSPDeviceInterfaceDetailDataA;\r\n TSPInterfaceDeviceDetailDataW = TSPDeviceInterfaceDetailDataW;\r\n PSPInterfaceDeviceDetailDataA = PSPDeviceInterfaceDetailDataA;\r\n PSPInterfaceDeviceDetailDataW = PSPDeviceInterfaceDetailDataW;\r\n {$IFDEF UNICODE}\r\n TSPInterfaceDeviceDetailData = TSPInterfaceDeviceDetailDataW;\r\n PSPInterfaceDeviceDetailData = PSPInterfaceDeviceDetailDataW;\r\n {$ELSE}\r\n TSPInterfaceDeviceDetailData = TSPInterfaceDeviceDetailDataA;\r\n PSPInterfaceDeviceDetailData = PSPInterfaceDeviceDetailDataA;\r\n {$ENDIF UNICODE}\r\n\r\n//\r\n// Structure for detailed information on a device information set (used for\r\n// SetupDiGetDeviceInfoListDetail which supercedes the functionality of\r\n// SetupDiGetDeviceInfoListClass).\r\n//\r\n PSPDevInfoListDetailDataA = ^TSPDevInfoListDetailDataA;\r\n PSPDevInfoListDetailDataW = ^TSPDevInfoListDetailDataW;\r\n SP_DEVINFO_LIST_DETAIL_DATA_A = packed record\r\n cbSize: DWORD;\r\n ClassGuid: TGUID;\r\n RemoteMachineHandle: THandle;\r\n RemoteMachineName: array [0..SP_MAX_MACHINENAME_LENGTH - 1] of AnsiChar;\r\n end;\r\n {$EXTERNALSYM SP_DEVINFO_LIST_DETAIL_DATA_A}\r\n SP_DEVINFO_LIST_DETAIL_DATA_W = packed record\r\n cbSize: DWORD;\r\n ClassGuid: TGUID;\r\n RemoteMachineHandle: THandle;\r\n RemoteMachineName: array [0..SP_MAX_MACHINENAME_LENGTH - 1] of WideChar;\r\n end;\r\n {$EXTERNALSYM SP_DEVINFO_LIST_DETAIL_DATA_W}\r\n TSPDevInfoListDetailDataA = SP_DEVINFO_LIST_DETAIL_DATA_A;\r\n TSPDevInfoListDetailDataW = SP_DEVINFO_LIST_DETAIL_DATA_W;\r\n {$IFDEF UNICODE}\r\n TSPDevInfoListDetailData = TSPDevInfoListDetailDataW;\r\n PSPDevInfoListDetailData = PSPDevInfoListDetailDataW;\r\n {$ELSE}\r\n TSPDevInfoListDetailData = TSPDevInfoListDetailDataA;\r\n PSPDevInfoListDetailData = PSPDevInfoListDetailDataA;\r\n {$ENDIF UNICODE}\r\n\r\n//\r\n// Class installer function codes\r\n//\r\nconst\r\n DIF_SELECTDEVICE = $00000001;\r\n {$EXTERNALSYM DIF_SELECTDEVICE}\r\n DIF_INSTALLDEVICE = $00000002;\r\n {$EXTERNALSYM DIF_INSTALLDEVICE}\r\n DIF_ASSIGNRESOURCES = $00000003;\r\n {$EXTERNALSYM DIF_ASSIGNRESOURCES}\r\n DIF_PROPERTIES = $00000004;\r\n {$EXTERNALSYM DIF_PROPERTIES}\r\n DIF_REMOVE = $00000005;\r\n {$EXTERNALSYM DIF_REMOVE}\r\n DIF_FIRSTTIMESETUP = $00000006;\r\n {$EXTERNALSYM DIF_FIRSTTIMESETUP}\r\n DIF_FOUNDDEVICE = $00000007;\r\n {$EXTERNALSYM DIF_FOUNDDEVICE}\r\n DIF_SELECTCLASSDRIVERS = $00000008;\r\n {$EXTERNALSYM DIF_SELECTCLASSDRIVERS}\r\n DIF_VALIDATECLASSDRIVERS = $00000009;\r\n {$EXTERNALSYM DIF_VALIDATECLASSDRIVERS}\r\n DIF_INSTALLCLASSDRIVERS = $0000000A;\r\n {$EXTERNALSYM DIF_INSTALLCLASSDRIVERS}\r\n DIF_CALCDISKSPACE = $0000000B;\r\n {$EXTERNALSYM DIF_CALCDISKSPACE}\r\n DIF_DESTROYPRIVATEDATA = $0000000C;\r\n {$EXTERNALSYM DIF_DESTROYPRIVATEDATA}\r\n DIF_VALIDATEDRIVER = $0000000D;\r\n {$EXTERNALSYM DIF_VALIDATEDRIVER}\r\n DIF_MOVEDEVICE = $0000000E;\r\n {$EXTERNALSYM DIF_MOVEDEVICE}\r\n DIF_DETECT = $0000000F;\r\n {$EXTERNALSYM DIF_DETECT}\r\n DIF_INSTALLWIZARD = $00000010;\r\n {$EXTERNALSYM DIF_INSTALLWIZARD}\r\n DIF_DESTROYWIZARDDATA = $00000011;\r\n {$EXTERNALSYM DIF_DESTROYWIZARDDATA}\r\n DIF_PROPERTYCHANGE = $00000012;\r\n {$EXTERNALSYM DIF_PROPERTYCHANGE}\r\n DIF_ENABLECLASS = $00000013;\r\n {$EXTERNALSYM DIF_ENABLECLASS}\r\n DIF_DETECTVERIFY = $00000014;\r\n {$EXTERNALSYM DIF_DETECTVERIFY}\r\n DIF_INSTALLDEVICEFILES = $00000015;\r\n {$EXTERNALSYM DIF_INSTALLDEVICEFILES}\r\n DIF_UNREMOVE = $00000016;\r\n {$EXTERNALSYM DIF_UNREMOVE}\r\n DIF_SELECTBESTCOMPATDRV = $00000017;\r\n {$EXTERNALSYM DIF_SELECTBESTCOMPATDRV}\r\n DIF_ALLOW_INSTALL = $00000018;\r\n {$EXTERNALSYM DIF_ALLOW_INSTALL}\r\n DIF_REGISTERDEVICE = $00000019;\r\n {$EXTERNALSYM DIF_REGISTERDEVICE}\r\n DIF_NEWDEVICEWIZARD_PRESELECT = $0000001A;\r\n {$EXTERNALSYM DIF_NEWDEVICEWIZARD_PRESELECT}\r\n DIF_NEWDEVICEWIZARD_SELECT = $0000001B;\r\n {$EXTERNALSYM DIF_NEWDEVICEWIZARD_SELECT}\r\n DIF_NEWDEVICEWIZARD_PREANALYZE = $0000001C;\r\n {$EXTERNALSYM DIF_NEWDEVICEWIZARD_PREANALYZE}\r\n DIF_NEWDEVICEWIZARD_POSTANALYZE = $0000001D;\r\n {$EXTERNALSYM DIF_NEWDEVICEWIZARD_POSTANALYZE}\r\n DIF_NEWDEVICEWIZARD_FINISHINSTALL = $0000001E;\r\n {$EXTERNALSYM DIF_NEWDEVICEWIZARD_FINISHINSTALL}\r\n DIF_UNUSED1 = $0000001F;\r\n {$EXTERNALSYM DIF_UNUSED1}\r\n DIF_INSTALLINTERFACES = $00000020;\r\n {$EXTERNALSYM DIF_INSTALLINTERFACES}\r\n DIF_DETECTCANCEL = $00000021;\r\n {$EXTERNALSYM DIF_DETECTCANCEL}\r\n DIF_REGISTER_COINSTALLERS = $00000022;\r\n {$EXTERNALSYM DIF_REGISTER_COINSTALLERS}\r\n DIF_ADDPROPERTYPAGE_ADVANCED = $00000023;\r\n {$EXTERNALSYM DIF_ADDPROPERTYPAGE_ADVANCED}\r\n DIF_ADDPROPERTYPAGE_BASIC = $00000024;\r\n {$EXTERNALSYM DIF_ADDPROPERTYPAGE_BASIC}\r\n DIF_RESERVED1 = $00000025;\r\n {$EXTERNALSYM DIF_RESERVED1}\r\n DIF_TROUBLESHOOTER = $00000026;\r\n {$EXTERNALSYM DIF_TROUBLESHOOTER}\r\n DIF_POWERMESSAGEWAKE = $00000027;\r\n {$EXTERNALSYM DIF_POWERMESSAGEWAKE}\r\n DIF_ADDREMOTEPROPERTYPAGE_ADVANCED = $00000028;\r\n {$EXTERNALSYM DIF_ADDREMOTEPROPERTYPAGE_ADVANCED}\r\n DIF_UPDATEDRIVER_UI = $00000029;\r\n {$EXTERNALSYM DIF_UPDATEDRIVER_UI}\r\n DIF_RESERVED2 = $00000030;\r\n {$EXTERNALSYM DIF_RESERVED2}\r\n\r\ntype\r\n DI_FUNCTION = UINT; // Function type for device installer\r\n {$EXTERNALSYM DI_FUNCTION}\r\n\r\n//\r\n// Device installation parameters structure (associated with a\r\n// particular device information element, or globally with a device\r\n// information set)\r\n//\r\n PSPDevInstallParamsA = ^TSPDevInstallParamsA;\r\n PSPDevInstallParamsW = ^TSPDevInstallParamsW;\r\n SP_DEVINSTALL_PARAMS_A = packed record\r\n cbSize: DWORD;\r\n Flags: DWORD;\r\n FlagsEx: DWORD;\r\n hwndParent: HWND;\r\n InstallMsgHandler: TSPFileCallback;\r\n InstallMsgHandlerContext: Pointer;\r\n FileQueue: HSPFILEQ;\r\n ClassInstallReserved: ULONG_PTR;\r\n Reserved: DWORD;\r\n DriverPath: array [0..MAX_PATH - 1] of AnsiChar;\r\n end;\r\n {$EXTERNALSYM SP_DEVINSTALL_PARAMS_A}\r\n SP_DEVINSTALL_PARAMS_W = packed record\r\n cbSize: DWORD;\r\n Flags: DWORD;\r\n FlagsEx: DWORD;\r\n hwndParent: HWND;\r\n InstallMsgHandler: TSPFileCallback;\r\n InstallMsgHandlerContext: Pointer;\r\n FileQueue: HSPFILEQ;\r\n ClassInstallReserved: ULONG_PTR;\r\n Reserved: DWORD;\r\n DriverPath: array [0..MAX_PATH - 1] of WideChar;\r\n end;\r\n {$EXTERNALSYM SP_DEVINSTALL_PARAMS_W}\r\n TSPDevInstallParamsA = SP_DEVINSTALL_PARAMS_A;\r\n TSPDevInstallParamsW = SP_DEVINSTALL_PARAMS_W;\r\n {$IFDEF UNICODE}\r\n TSPDevInstallParams = TSPDevInstallParamsW;\r\n PSPDevInstallParams = PSPDevInstallParamsW;\r\n {$ELSE}\r\n TSPDevInstallParams = TSPDevInstallParamsA;\r\n PSPDevInstallParams = PSPDevInstallParamsA;\r\n {$ENDIF UNICODE}\r\n\r\n//\r\n// SP_DEVINSTALL_PARAMS.Flags values\r\n//\r\n// Flags for choosing a device\r\n//\r\nconst\r\n DI_SHOWOEM = $00000001; // support Other... button\r\n {$EXTERNALSYM DI_SHOWOEM}\r\n DI_SHOWCOMPAT = $00000002; // show compatibility list\r\n {$EXTERNALSYM DI_SHOWCOMPAT}\r\n DI_SHOWCLASS = $00000004; // show class list\r\n {$EXTERNALSYM DI_SHOWCLASS}\r\n DI_SHOWALL = $00000007; // both class & compat list shown\r\n {$EXTERNALSYM DI_SHOWALL}\r\n DI_NOVCP = $00000008; // don't create a new copy queue--use\r\n {$EXTERNALSYM DI_NOVCP} // caller-supplied FileQueue\r\n DI_DIDCOMPAT = $00000010; // Searched for compatible devices\r\n {$EXTERNALSYM DI_DIDCOMPAT}\r\n DI_DIDCLASS = $00000020; // Searched for class devices\r\n {$EXTERNALSYM DI_DIDCLASS}\r\n DI_AUTOASSIGNRES = $00000040; // No UI for resources if possible\r\n {$EXTERNALSYM DI_AUTOASSIGNRES}\r\n\r\n// flags returned by DiInstallDevice to indicate need to reboot/restart\r\n DI_NEEDRESTART = $00000080; // Reboot required to take effect\r\n {$EXTERNALSYM DI_NEEDRESTART}\r\n DI_NEEDREBOOT = $00000100; // \"\"\r\n {$EXTERNALSYM DI_NEEDREBOOT}\r\n\r\n// flags for device installation\r\n DI_NOBROWSE = $00000200; // no Browse... in InsertDisk\r\n {$EXTERNALSYM DI_NOBROWSE}\r\n\r\n// Flags set by DiBuildDriverInfoList\r\n DI_MULTMFGS = $00000400; // Set if multiple manufacturers in\r\n {$EXTERNALSYM DI_MULTMFGS} // class driver list\r\n\r\n// Flag indicates that device is disabled\r\n DI_DISABLED = $00000800; // Set if device disabled\r\n {$EXTERNALSYM DI_DISABLED}\r\n\r\n// Flags for Device/Class Properties\r\n DI_GENERALPAGE_ADDED = $00001000;\r\n {$EXTERNALSYM DI_GENERALPAGE_ADDED}\r\n DI_RESOURCEPAGE_ADDED = $00002000;\r\n {$EXTERNALSYM DI_RESOURCEPAGE_ADDED}\r\n\r\n// Flag to indicate the setting properties for this Device (or class) caused a change\r\n// so the Dev Mgr UI probably needs to be updatd.\r\n DI_PROPERTIES_CHANGE = $00004000;\r\n {$EXTERNALSYM DI_PROPERTIES_CHANGE}\r\n\r\n// Flag to indicate that the sorting from the INF file should be used.\r\n DI_INF_IS_SORTED = $00008000;\r\n {$EXTERNALSYM DI_INF_IS_SORTED}\r\n\r\n// Flag to indicate that only the the INF specified by SP_DEVINSTALL_PARAMS.DriverPath\r\n// should be searched.\r\n DI_ENUMSINGLEINF = $00010000;\r\n {$EXTERNALSYM DI_ENUMSINGLEINF}\r\n\r\n// Flag that prevents ConfigMgr from removing/re-enumerating devices during device\r\n// registration, installation, and deletion.\r\n DI_DONOTCALLCONFIGMG = $00020000;\r\n {$EXTERNALSYM DI_DONOTCALLCONFIGMG}\r\n\r\n// The following flag can be used to install a device disabled\r\n DI_INSTALLDISABLED = $00040000;\r\n {$EXTERNALSYM DI_INSTALLDISABLED}\r\n\r\n// Flag that causes SetupDiBuildDriverInfoList to build a device's compatible driver\r\n// list from its existing class driver list, instead of the normal INF search.\r\n DI_COMPAT_FROM_CLASS = $00080000;\r\n {$EXTERNALSYM DI_COMPAT_FROM_CLASS}\r\n\r\n// This flag is set if the Class Install params should be used.\r\n DI_CLASSINSTALLPARAMS = $00100000;\r\n {$EXTERNALSYM DI_CLASSINSTALLPARAMS}\r\n\r\n// This flag is set if the caller of DiCallClassInstaller does NOT\r\n// want the internal default action performed if the Class installer\r\n// returns ERROR_DI_DO_DEFAULT.\r\n DI_NODI_DEFAULTACTION = $00200000;\r\n {$EXTERNALSYM DI_NODI_DEFAULTACTION}\r\n\r\n// The setupx flag, DI_NOSYNCPROCESSING (0x00400000L) is not support in the Setup APIs.\r\n\r\n// flags for device installation\r\n DI_QUIETINSTALL = $00800000; // don't confuse the user with\r\n {$EXTERNALSYM DI_QUIETINSTALL} // questions or excess info\r\n DI_NOFILECOPY = $01000000; // No file Copy necessary\r\n {$EXTERNALSYM DI_NOFILECOPY}\r\n DI_FORCECOPY = $02000000; // Force files to be copied from install path\r\n {$EXTERNALSYM DI_FORCECOPY}\r\n DI_DRIVERPAGE_ADDED = $04000000; // Prop provider added Driver page.\r\n {$EXTERNALSYM DI_DRIVERPAGE_ADDED}\r\n DI_USECI_SELECTSTRINGS = $08000000; // Use Class Installer Provided strings in the Select Device Dlg\r\n {$EXTERNALSYM DI_USECI_SELECTSTRINGS}\r\n DI_OVERRIDE_INFFLAGS = $10000000; // Override INF flags\r\n {$EXTERNALSYM DI_OVERRIDE_INFFLAGS}\r\n DI_PROPS_NOCHANGEUSAGE = $20000000; // No Enable/Disable in General Props\r\n {$EXTERNALSYM DI_PROPS_NOCHANGEUSAGE}\r\n\r\n DI_NOSELECTICONS = $40000000; // No small icons in select device dialogs\r\n {$EXTERNALSYM DI_NOSELECTICONS}\r\n\r\n DI_NOWRITE_IDS = DWORD($80000000); // Don't write HW & Compat IDs on install\r\n {$EXTERNALSYM DI_NOWRITE_IDS}\r\n\r\n//\r\n// SP_DEVINSTALL_PARAMS.FlagsEx values\r\n//\r\n DI_FLAGSEX_USEOLDINFSEARCH = $00000001; // Inf Search functions should not use Index Search\r\n {$EXTERNALSYM DI_FLAGSEX_USEOLDINFSEARCH}\r\n DI_FLAGSEX_AUTOSELECTRANK0 = $00000002; // SetupDiSelectDevice doesn't prompt user if rank 0 match\r\n {$EXTERNALSYM DI_FLAGSEX_AUTOSELECTRANK0}\r\n DI_FLAGSEX_CI_FAILED = $00000004; // Failed to Load/Call class installer\r\n {$EXTERNALSYM DI_FLAGSEX_CI_FAILED}\r\n\r\n DI_FLAGSEX_DIDINFOLIST = $00000010; // Did the Class Info List\r\n {$EXTERNALSYM DI_FLAGSEX_DIDINFOLIST}\r\n DI_FLAGSEX_DIDCOMPATINFO = $00000020; // Did the Compat Info List\r\n {$EXTERNALSYM DI_FLAGSEX_DIDCOMPATINFO}\r\n\r\n DI_FLAGSEX_FILTERCLASSES = $00000040;\r\n {$EXTERNALSYM DI_FLAGSEX_FILTERCLASSES}\r\n DI_FLAGSEX_SETFAILEDINSTALL = $00000080;\r\n {$EXTERNALSYM DI_FLAGSEX_SETFAILEDINSTALL}\r\n DI_FLAGSEX_DEVICECHANGE = $00000100;\r\n {$EXTERNALSYM DI_FLAGSEX_DEVICECHANGE}\r\n DI_FLAGSEX_ALWAYSWRITEIDS = $00000200;\r\n {$EXTERNALSYM DI_FLAGSEX_ALWAYSWRITEIDS}\r\n DI_FLAGSEX_PROPCHANGE_PENDING = $00000400; // One or more device property sheets have had changes made\r\n {$EXTERNALSYM DI_FLAGSEX_PROPCHANGE_PENDING} // to them, and need to have a DIF_PROPERTYCHANGE occur.\r\n\r\n DI_FLAGSEX_ALLOWEXCLUDEDDRVS = $00000800;\r\n {$EXTERNALSYM DI_FLAGSEX_ALLOWEXCLUDEDDRVS}\r\n DI_FLAGSEX_NOUIONQUERYREMOVE = $00001000;\r\n {$EXTERNALSYM DI_FLAGSEX_NOUIONQUERYREMOVE}\r\n DI_FLAGSEX_USECLASSFORCOMPAT = $00002000; // Use the device's class when building compat drv list.\r\n {$EXTERNALSYM DI_FLAGSEX_USECLASSFORCOMPAT} // (Ignored if DI_COMPAT_FROM_CLASS flag is specified.)\r\n DI_FLAGSEX_OLDINF_IN_CLASSLIST = $00004000; // Search legacy INFs when building class driver list.\r\n {$EXTERNALSYM DI_FLAGSEX_OLDINF_IN_CLASSLIST}\r\n DI_FLAGSEX_NO_DRVREG_MODIFY = $00008000; // Don't run AddReg and DelReg for device's software (driver) key.\r\n {$EXTERNALSYM DI_FLAGSEX_NO_DRVREG_MODIFY}\r\n DI_FLAGSEX_IN_SYSTEM_SETUP = $00010000; // Installation is occurring during initial system setup.\r\n {$EXTERNALSYM DI_FLAGSEX_IN_SYSTEM_SETUP}\r\n DI_FLAGSEX_INET_DRIVER = $00020000; // Driver came from Windows Update\r\n {$EXTERNALSYM DI_FLAGSEX_INET_DRIVER}\r\n DI_FLAGSEX_APPENDDRIVERLIST = $00040000; // Cause SetupDiBuildDriverInfoList to append\r\n {$EXTERNALSYM DI_FLAGSEX_APPENDDRIVERLIST} // a new driver list to an existing list.\r\n DI_FLAGSEX_PREINSTALLBACKUP = $00080000; // backup all files required by old inf before install\r\n {$EXTERNALSYM DI_FLAGSEX_PREINSTALLBACKUP}\r\n DI_FLAGSEX_BACKUPONREPLACE = $00100000; // backup files required by old inf as they are replaced\r\n {$EXTERNALSYM DI_FLAGSEX_BACKUPONREPLACE}\r\n DI_FLAGSEX_DRIVERLIST_FROM_URL = $00200000; // build driver list from INF(s) retrieved from URL specified\r\n {$EXTERNALSYM DI_FLAGSEX_DRIVERLIST_FROM_URL}\r\n // in SP_DEVINSTALL_PARAMS.DriverPath (empty string means\r\n // Windows Update website)\r\n DI_FLAGSEX_RESERVED1 = $00400000;\r\n {$EXTERNALSYM DI_FLAGSEX_RESERVED1}\r\n DI_FLAGSEX_EXCLUDE_OLD_INET_DRIVERS = $00800000; // Don't include old Internet drivers when building\r\n {$EXTERNALSYM DI_FLAGSEX_EXCLUDE_OLD_INET_DRIVERS}\r\n // a driver list.\r\n DI_FLAGSEX_POWERPAGE_ADDED = $01000000; // class installer added their own power page\r\n {$EXTERNALSYM DI_FLAGSEX_POWERPAGE_ADDED}\r\n\r\n DI_FLAGSEX_FILTERSIMILARDRIVERS = $02000000; // only include similar drivers in class list\r\n {$EXTERNALSYM DI_FLAGSEX_FILTERSIMILARDRIVERS}\r\n DI_FLAGSEX_INSTALLEDDRIVER = $04000000; // only add the installed driver to the class or compat\r\n {$EXTERNALSYM DI_FLAGSEX_INSTALLEDDRIVER}\r\n // driver list. Used in calls to SetupDiBuildDriverInfoList\r\n DI_FLAGSEX_NO_CLASSLIST_NODE_MERGE = $08000000; // Don't remove identical driver nodes from the class list\r\n {$EXTERNALSYM DI_FLAGSEX_NO_CLASSLIST_NODE_MERGE}\r\n DI_FLAGSEX_ALTPLATFORM_DRVSEARCH = $10000000; // Build driver list based on alternate platform information\r\n {$EXTERNALSYM DI_FLAGSEX_ALTPLATFORM_DRVSEARCH}\r\n // specified in associated file queue\r\n DI_FLAGSEX_RESTART_DEVICE_ONLY = $20000000; // only restart the device drivers are being installed on as\r\n {$EXTERNALSYM DI_FLAGSEX_RESTART_DEVICE_ONLY}\r\n\r\n//\r\n// Class installation parameters header. This must be the first field of any\r\n// class install parameter structure. The InstallFunction field must be set to\r\n// the function code corresponding to the structure, and the cbSize field must\r\n// be set to the size of the header structure. E.g.,\r\n//\r\n// SP_ENABLECLASS_PARAMS EnableClassParams;\r\n//\r\n// EnableClassParams.ClassInstallHeader.cbSize = sizeof(SP_CLASSINSTALL_HEADER);\r\n// EnableClassParams.ClassInstallHeader.InstallFunction = DIF_ENABLECLASS;\r\n//\r\ntype\r\n PSPClassInstallHeader = ^TSPClassInstallHeader;\r\n SP_CLASSINSTALL_HEADER = packed record\r\n cbSize: DWORD;\r\n InstallFunction: DI_FUNCTION;\r\n end;\r\n {$EXTERNALSYM SP_CLASSINSTALL_HEADER}\r\n TSPClassInstallHeader = SP_CLASSINSTALL_HEADER;\r\n\r\n//\r\n// Structure corresponding to a DIF_ENABLECLASS install function.\r\n//\r\n PSPEnableClassParams = ^TSPEnableClassParams;\r\n SP_ENABLECLASS_PARAMS = packed record\r\n ClassInstallHeader: TSPClassInstallHeader;\r\n ClassGuid: TGUID;\r\n EnableMessage: DWORD;\r\n end;\r\n {$EXTERNALSYM SP_ENABLECLASS_PARAMS}\r\n TSPEnableClassParams = SP_ENABLECLASS_PARAMS;\r\n\r\nconst\r\n ENABLECLASS_QUERY = 0;\r\n {$EXTERNALSYM ENABLECLASS_QUERY}\r\n ENABLECLASS_SUCCESS = 1;\r\n {$EXTERNALSYM ENABLECLASS_SUCCESS}\r\n ENABLECLASS_FAILURE = 2;\r\n {$EXTERNALSYM ENABLECLASS_FAILURE}\r\n\r\n//\r\n// Structure corresponding to a DIF_MOVEDEVICE install function.\r\n//\r\ntype\r\n PSPMoveDevParams = ^TSPMoveDevParams;\r\n SP_MOVEDEV_PARAMS = packed record\r\n ClassInstallHeader: TSPClassInstallHeader;\r\n SourceDeviceInfoData: TSPDevInfoData;\r\n end;\r\n {$EXTERNALSYM SP_MOVEDEV_PARAMS}\r\n TSPMoveDevParams = SP_MOVEDEV_PARAMS;\r\n {$IFDEF COMPILER11_UP}\r\n {$EXTERNALSYM PSPMoveDevParams}\r\n {$EXTERNALSYM TSPMoveDevParams}\r\n {$ENDIF COMPILER11_UP}\r\n\r\n//\r\n// Values indicating a change in a device's state\r\n//\r\nconst\r\n DICS_ENABLE = $00000001;\r\n {$EXTERNALSYM DICS_ENABLE}\r\n DICS_DISABLE = $00000002;\r\n {$EXTERNALSYM DICS_DISABLE}\r\n DICS_PROPCHANGE = $00000003;\r\n {$EXTERNALSYM DICS_PROPCHANGE}\r\n DICS_START = $00000004;\r\n {$EXTERNALSYM DICS_START}\r\n DICS_STOP = $00000005;\r\n {$EXTERNALSYM DICS_STOP}\r\n\r\n//\r\n// Values specifying the scope of a device property change\r\n//\r\n DICS_FLAG_GLOBAL = $00000001; // make change in all hardware profiles\r\n {$EXTERNALSYM DICS_FLAG_GLOBAL}\r\n DICS_FLAG_CONFIGSPECIFIC = $00000002; // make change in specified profile only\r\n {$EXTERNALSYM DICS_FLAG_CONFIGSPECIFIC}\r\n DICS_FLAG_CONFIGGENERAL = $00000004; // 1 or more hardware profile-specific\r\n {$EXTERNALSYM DICS_FLAG_CONFIGGENERAL} // changes to follow.\r\n\r\n//\r\n// Structure corresponding to a DIF_PROPERTYCHANGE install function.\r\n//\r\ntype\r\n PSPPropChangeParams = ^TSPPropChangeParams;\r\n SP_PROPCHANGE_PARAMS = packed record\r\n ClassInstallHeader: TSPClassInstallHeader;\r\n StateChange: DWORD;\r\n Scope: DWORD;\r\n HwProfile: DWORD;\r\n end;\r\n {$EXTERNALSYM SP_PROPCHANGE_PARAMS}\r\n TSPPropChangeParams = SP_PROPCHANGE_PARAMS;\r\n\r\n//\r\n// Structure corresponding to a DIF_REMOVE install function.\r\n//\r\n PSPRemoveDeviceParams = ^TSPRemoveDeviceParams;\r\n SP_REMOVEDEVICE_PARAMS = packed record\r\n ClassInstallHeader: TSPClassInstallHeader;\r\n Scope: DWORD;\r\n HwProfile: DWORD;\r\n end;\r\n {$EXTERNALSYM SP_REMOVEDEVICE_PARAMS}\r\n TSPRemoveDeviceParams = SP_REMOVEDEVICE_PARAMS;\r\n\r\nconst\r\n DI_REMOVEDEVICE_GLOBAL = $00000001;\r\n {$EXTERNALSYM DI_REMOVEDEVICE_GLOBAL}\r\n DI_REMOVEDEVICE_CONFIGSPECIFIC = $00000002;\r\n {$EXTERNALSYM DI_REMOVEDEVICE_CONFIGSPECIFIC}\r\n\r\n//\r\n// Structure corresponding to a DIF_UNREMOVE install function.\r\n//\r\ntype\r\n PSPUnremoveDeviceParams = ^TSPUnremoveDeviceParams;\r\n SP_UNREMOVEDEVICE_PARAMS = packed record\r\n ClassInstallHeader: TSPClassInstallHeader;\r\n Scope: DWORD;\r\n HwProfile: DWORD;\r\n end;\r\n {$EXTERNALSYM SP_UNREMOVEDEVICE_PARAMS}\r\n TSPUnremoveDeviceParams = SP_UNREMOVEDEVICE_PARAMS;\r\n\r\nconst\r\n DI_UNREMOVEDEVICE_CONFIGSPECIFIC = $00000002;\r\n {$EXTERNALSYM DI_UNREMOVEDEVICE_CONFIGSPECIFIC}\r\n\r\n//\r\n// Structure corresponding to a DIF_SELECTDEVICE install function.\r\n//\r\ntype\r\n PSPSelectDeviceParamsA = ^TSPSelectDeviceParamsA;\r\n PSPSelectDeviceParamsW = ^TSPSelectDeviceParamsW;\r\n SP_SELECTDEVICE_PARAMS_A = packed record\r\n ClassInstallHeader: TSPClassInstallHeader;\r\n Title: array [0..MAX_TITLE_LEN - 1] of AnsiChar;\r\n Instructions: array [0..MAX_INSTRUCTION_LEN - 1] of AnsiChar;\r\n ListLabel: array [0..MAX_LABEL_LEN - 1] of AnsiChar;\r\n SubTitle: array [0..MAX_SUBTITLE_LEN - 1] of AnsiChar;\r\n Reserved: array [0..1] of Byte; // DWORD size alignment\r\n end;\r\n {$EXTERNALSYM SP_SELECTDEVICE_PARAMS_A}\r\n SP_SELECTDEVICE_PARAMS_W = packed record\r\n ClassInstallHeader: TSPClassInstallHeader;\r\n Title: array [0..MAX_TITLE_LEN - 1] of WideChar;\r\n Instructions: array [0..MAX_INSTRUCTION_LEN - 1] of WideChar;\r\n ListLabel: array [0..MAX_LABEL_LEN - 1] of WideChar;\r\n SubTitle: array [0..MAX_SUBTITLE_LEN - 1] of WideChar;\r\n Reserved: array [0..1] of Byte; // DWORD size alignment\r\n end;\r\n {$EXTERNALSYM SP_SELECTDEVICE_PARAMS_W}\r\n TSPSelectdeviceParamsA = SP_SELECTDEVICE_PARAMS_A;\r\n TSPSelectdeviceParamsW = SP_SELECTDEVICE_PARAMS_W;\r\n {$IFDEF UNICODE}\r\n TSPSelectdeviceParams = TSPSelectdeviceParamsW;\r\n PSPSelectDeviceParams = PSPSelectDeviceParamsW;\r\n {$ELSE}\r\n TSPSelectdeviceParams = TSPSelectdeviceParamsA;\r\n PSPSelectDeviceParams = PSPSelectDeviceParamsA;\r\n {$ENDIF UNICODE}\r\n\r\n//\r\n// Callback routine for giving progress notification during detection\r\n//\r\n PDetectProgressNotify = function(ProgressNotifyParam: Pointer; DetectComplete: DWORD): BOOL; stdcall;\r\n\r\n// where:\r\n// ProgressNotifyParam - value supplied by caller requesting detection.\r\n// DetectComplete - Percent completion, to be incremented by class\r\n// installer, as it steps thru its detection.\r\n//\r\n// Return Value - If TRUE, then detection is cancelled. Allows caller\r\n// requesting detection to stop detection asap.\r\n//\r\n\r\n//\r\n// Structure corresponding to a DIF_DETECT install function.\r\n//\r\n PSPDetectDeviceParams = ^TSPDetectDeviceParams;\r\n SP_DETECTDEVICE_PARAMS = packed record\r\n ClassInstallHeader: TSPClassInstallHeader;\r\n DetectProgressNotify: PDetectProgressNotify;\r\n ProgressNotifyParam: Pointer;\r\n end;\r\n {$EXTERNALSYM SP_DETECTDEVICE_PARAMS}\r\n TSPDetectDeviceParams = SP_DETECTDEVICE_PARAMS;\r\n\r\n//\r\n// 'Add New Device' installation wizard structure (backward-compatibility\r\n// only--respond to DIF_NEWDEVICEWIZARD_* requests instead).\r\n//\r\n// Structure corresponding to a DIF_INSTALLWIZARD install function.\r\n// (NOTE: This structure is also applicable for DIF_DESTROYWIZARDDATA,\r\n// but DIF_INSTALLWIZARD is the associated function code in the class\r\n// installation parameter structure in both cases.)\r\n//\r\n// Define maximum number of dynamic wizard pages that can be added to\r\n// hardware install wizard.\r\n//\r\nconst\r\n MAX_INSTALLWIZARD_DYNAPAGES = 20;\r\n {$EXTERNALSYM MAX_INSTALLWIZARD_DYNAPAGES}\r\n\r\ntype\r\n PSPInstallWizardData = ^TSPInstallWizardData;\r\n SP_INSTALLWIZARD_DATA = packed record\r\n ClassInstallHeader: TSPClassInstallHeader;\r\n Flags: DWORD;\r\n DynamicPages: array [0..MAX_INSTALLWIZARD_DYNAPAGES - 1] of HPROPSHEETPAGE;\r\n NumDynamicPages: DWORD;\r\n DynamicPageFlags: DWORD;\r\n PrivateFlags: DWORD;\r\n PrivateData: LPARAM;\r\n hwndWizardDlg: HWND;\r\n end;\r\n {$EXTERNALSYM SP_INSTALLWIZARD_DATA}\r\n TSPInstallWizardData = SP_INSTALLWIZARD_DATA;\r\n\r\n//\r\n// SP_INSTALLWIZARD_DATA.Flags values\r\n//\r\nconst\r\n NDW_INSTALLFLAG_DIDFACTDEFS = $00000001;\r\n {$EXTERNALSYM NDW_INSTALLFLAG_DIDFACTDEFS}\r\n NDW_INSTALLFLAG_HARDWAREALLREADYIN = $00000002;\r\n {$EXTERNALSYM NDW_INSTALLFLAG_HARDWAREALLREADYIN}\r\n NDW_INSTALLFLAG_NEEDRESTART = DI_NEEDRESTART;\r\n {$EXTERNALSYM NDW_INSTALLFLAG_NEEDRESTART}\r\n NDW_INSTALLFLAG_NEEDREBOOT = DI_NEEDREBOOT;\r\n {$EXTERNALSYM NDW_INSTALLFLAG_NEEDREBOOT}\r\n NDW_INSTALLFLAG_NEEDSHUTDOWN = $00000200;\r\n {$EXTERNALSYM NDW_INSTALLFLAG_NEEDSHUTDOWN}\r\n NDW_INSTALLFLAG_EXPRESSINTRO = $00000400;\r\n {$EXTERNALSYM NDW_INSTALLFLAG_EXPRESSINTRO}\r\n NDW_INSTALLFLAG_SKIPISDEVINSTALLED = $00000800;\r\n {$EXTERNALSYM NDW_INSTALLFLAG_SKIPISDEVINSTALLED}\r\n NDW_INSTALLFLAG_NODETECTEDDEVS = $00001000;\r\n {$EXTERNALSYM NDW_INSTALLFLAG_NODETECTEDDEVS}\r\n NDW_INSTALLFLAG_INSTALLSPECIFIC = $00002000;\r\n {$EXTERNALSYM NDW_INSTALLFLAG_INSTALLSPECIFIC}\r\n NDW_INSTALLFLAG_SKIPCLASSLIST = $00004000;\r\n {$EXTERNALSYM NDW_INSTALLFLAG_SKIPCLASSLIST}\r\n NDW_INSTALLFLAG_CI_PICKED_OEM = $00008000;\r\n {$EXTERNALSYM NDW_INSTALLFLAG_CI_PICKED_OEM}\r\n NDW_INSTALLFLAG_PCMCIAMODE = $00010000;\r\n {$EXTERNALSYM NDW_INSTALLFLAG_PCMCIAMODE}\r\n NDW_INSTALLFLAG_PCMCIADEVICE = $00020000;\r\n {$EXTERNALSYM NDW_INSTALLFLAG_PCMCIADEVICE}\r\n NDW_INSTALLFLAG_USERCANCEL = $00040000;\r\n {$EXTERNALSYM NDW_INSTALLFLAG_USERCANCEL}\r\n NDW_INSTALLFLAG_KNOWNCLASS = $00080000;\r\n {$EXTERNALSYM NDW_INSTALLFLAG_KNOWNCLASS}\r\n\r\n//\r\n// SP_INSTALLWIZARD_DATA.DynamicPageFlags values\r\n//\r\n// This flag is set if a Class installer has added pages to the install wizard.\r\n//\r\n DYNAWIZ_FLAG_PAGESADDED = $00000001;\r\n {$EXTERNALSYM DYNAWIZ_FLAG_PAGESADDED}\r\n\r\n//\r\n// Set this flag if you jump to the analyze page, and want it to\r\n// handle conflicts for you. NOTE. You will not get control back\r\n// in the event of a conflict if you set this flag.\r\n//\r\n DYNAWIZ_FLAG_ANALYZE_HANDLECONFLICT = $00000008;\r\n {$EXTERNALSYM DYNAWIZ_FLAG_ANALYZE_HANDLECONFLICT}\r\n\r\n//\r\n// The following flags are not used by the Windows NT hardware wizard.\r\n//\r\n DYNAWIZ_FLAG_INSTALLDET_NEXT = $00000002;\r\n {$EXTERNALSYM DYNAWIZ_FLAG_INSTALLDET_NEXT}\r\n DYNAWIZ_FLAG_INSTALLDET_PREV = $00000004;\r\n {$EXTERNALSYM DYNAWIZ_FLAG_INSTALLDET_PREV}\r\n\r\n//\r\n// Reserve a range of wizard page resource IDs for internal use. Some of\r\n// these IDs are for use by class installers that respond to the obsolete\r\n// DIF_INSTALLWIZARD/DIF_DESTROYWIZARDDATA messages. These IDs are listed\r\n// below.\r\n//\r\n MIN_IDD_DYNAWIZ_RESOURCE_ID = 10000;\r\n {$EXTERNALSYM MIN_IDD_DYNAWIZ_RESOURCE_ID}\r\n MAX_IDD_DYNAWIZ_RESOURCE_ID = 11000;\r\n {$EXTERNALSYM MAX_IDD_DYNAWIZ_RESOURCE_ID}\r\n\r\n//\r\n// Define wizard page resource IDs to be used when adding custom pages to the\r\n// hardware install wizard via DIF_INSTALLWIZARD. Pages marked with\r\n// (CLASS INSTALLER PROVIDED) _must_ be supplied by the class installer if it\r\n// responds to the DIF_INSTALLWIZARD request.\r\n//\r\n\r\n//\r\n// Resource ID for the first page that the install wizard will go to after\r\n// adding the class installer pages. (CLASS INSTALLER PROVIDED)\r\n//\r\n IDD_DYNAWIZ_FIRSTPAGE = 10000;\r\n {$EXTERNALSYM IDD_DYNAWIZ_FIRSTPAGE}\r\n\r\n//\r\n// Resource ID for the page that the Select Device page will go back to.\r\n// (CLASS INSTALLER PROVIDED)\r\n//\r\n IDD_DYNAWIZ_SELECT_PREVPAGE = 10001;\r\n {$EXTERNALSYM IDD_DYNAWIZ_SELECT_PREVPAGE}\r\n\r\n//\r\n// Resource ID for the page that the Select Device page will go forward to.\r\n// (CLASS INSTALLER PROVIDED)\r\n//\r\n IDD_DYNAWIZ_SELECT_NEXTPAGE = 10002;\r\n {$EXTERNALSYM IDD_DYNAWIZ_SELECT_NEXTPAGE}\r\n\r\n//\r\n// Resource ID for the page that the Analyze dialog should go back to\r\n// This will only be used in the event that there is a problem, and the user\r\n// selects Back from the analyze proc. (CLASS INSTALLER PROVIDED)\r\n//\r\n IDD_DYNAWIZ_ANALYZE_PREVPAGE = 10003;\r\n {$EXTERNALSYM IDD_DYNAWIZ_ANALYZE_PREVPAGE}\r\n\r\n//\r\n// Resource ID for the page that the Analyze dialog should go to if it\r\n// continues from the analyze proc. (CLASS INSTALLER PROVIDED)\r\n//\r\n IDD_DYNAWIZ_ANALYZE_NEXTPAGE = 10004;\r\n {$EXTERNALSYM IDD_DYNAWIZ_ANALYZE_NEXTPAGE}\r\n\r\n//\r\n// Resource ID of the hardware install wizard's select device page.\r\n// This ID can be used to go directly to the hardware install wizard's select\r\n// device page. (This is the resource ID of the Select Device wizard page\r\n// retrieved via SetupDiGetWizardPage when SPWPT_SELECTDEVICE is the requested\r\n// PageType.)\r\n//\r\n IDD_DYNAWIZ_SELECTDEV_PAGE = 10009;\r\n {$EXTERNALSYM IDD_DYNAWIZ_SELECTDEV_PAGE}\r\n\r\n//\r\n// Resource ID of the hardware install wizard's device analysis page.\r\n// This ID can be use to go directly to the hardware install wizard's analysis\r\n// page.\r\n//\r\n IDD_DYNAWIZ_ANALYZEDEV_PAGE = 10010;\r\n {$EXTERNALSYM IDD_DYNAWIZ_ANALYZEDEV_PAGE}\r\n\r\n//\r\n// Resource ID of the hardware install wizard's install detected devices page.\r\n// This ID can be use to go directly to the hardware install wizard's install\r\n// detected devices page.\r\n//\r\n IDD_DYNAWIZ_INSTALLDETECTEDDEVS_PAGE = 10011;\r\n {$EXTERNALSYM IDD_DYNAWIZ_INSTALLDETECTEDDEVS_PAGE}\r\n\r\n//\r\n// Resource ID of the hardware install wizard's select class page.\r\n// This ID can be use to go directly to the hardware install wizard's select\r\n// class page.\r\n//\r\n IDD_DYNAWIZ_SELECTCLASS_PAGE = 10012;\r\n {$EXTERNALSYM IDD_DYNAWIZ_SELECTCLASS_PAGE}\r\n\r\n//\r\n// The following class installer-provided wizard page resource IDs are not used\r\n// by the Windows NT hardware wizard.\r\n//\r\n IDD_DYNAWIZ_INSTALLDETECTED_PREVPAGE = 10006;\r\n {$EXTERNALSYM IDD_DYNAWIZ_INSTALLDETECTED_PREVPAGE}\r\n IDD_DYNAWIZ_INSTALLDETECTED_NEXTPAGE = 10007;\r\n {$EXTERNALSYM IDD_DYNAWIZ_INSTALLDETECTED_NEXTPAGE}\r\n IDD_DYNAWIZ_INSTALLDETECTED_NODEVS = 10008;\r\n {$EXTERNALSYM IDD_DYNAWIZ_INSTALLDETECTED_NODEVS}\r\n\r\n//\r\n// Structure corresponding to the following DIF_NEWDEVICEWIZARD_* install\r\n// functions:\r\n//\r\n// DIF_NEWDEVICEWIZARD_PRESELECT\r\n// DIF_NEWDEVICEWIZARD_SELECT\r\n// DIF_NEWDEVICEWIZARD_PREANALYZE\r\n// DIF_NEWDEVICEWIZARD_POSTANALYZE\r\n// DIF_NEWDEVICEWIZARD_FINISHINSTALL\r\n//\r\ntype\r\n PSPNewDeviceWizardData = ^TSPNewDeviceWizardData;\r\n SP_NEWDEVICEWIZARD_DATA = packed record\r\n ClassInstallHeader: TSPClassInstallHeader;\r\n Flags: DWORD; // presently unused--must be zero.\r\n DynamicPages: array [0..MAX_INSTALLWIZARD_DYNAPAGES - 1] of HPROPSHEETPAGE;\r\n NumDynamicPages: DWORD;\r\n hwndWizardDlg: HWND;\r\n end;\r\n {$EXTERNALSYM SP_NEWDEVICEWIZARD_DATA}\r\n TSPNewDeviceWizardData = SP_NEWDEVICEWIZARD_DATA;\r\n\r\n//\r\n// Structure corresponding to the DIF_TROUBLESHOOTER install function\r\n//\r\n PSPTroubleShooterParamsA = ^TSPTroubleShooterParamsA;\r\n PSPTroubleShooterParamsW = ^TSPTroubleShooterParamsW;\r\n SP_TROUBLESHOOTER_PARAMS_A = packed record\r\n ClassInstallHeader: TSPClassInstallHeader;\r\n ChmFile: array [0..MAX_PATH - 1] of AnsiChar;\r\n HtmlTroubleShooter: array [0..MAX_PATH - 1] of AnsiChar;\r\n end;\r\n {$EXTERNALSYM SP_TROUBLESHOOTER_PARAMS_A}\r\n SP_TROUBLESHOOTER_PARAMS_W = packed record\r\n ClassInstallHeader: TSPClassInstallHeader;\r\n ChmFile: array [0..MAX_PATH - 1] of WideChar;\r\n HtmlTroubleShooter: array [0..MAX_PATH - 1] of WideChar;\r\n end;\r\n {$EXTERNALSYM SP_TROUBLESHOOTER_PARAMS_W}\r\n TSPTroubleShooterParamsA = SP_TROUBLESHOOTER_PARAMS_A;\r\n TSPTroubleShooterParamsW = SP_TROUBLESHOOTER_PARAMS_W;\r\n {$IFDEF UNICODE}\r\n TSPTroubleShooterParams = TSPTroubleShooterParamsW;\r\n PSPTroubleShooterParams = PSPTroubleShooterParamsW;\r\n {$ELSE}\r\n TSPTroubleShooterParams = TSPTroubleShooterParamsA;\r\n PSPTroubleShooterParams = PSPTroubleShooterParamsA;\r\n {$ENDIF UNICODE}\r\n\r\n//\r\n// Structure corresponding to the DIF_POWERMESSAGEWAKE install function\r\n//\r\n PSPPowerMessageWakeParamsA = ^TSPPowerMessageWakeParamsA;\r\n PSPPowerMessageWakeParamsW = ^TSPPowerMessageWakeParamsW;\r\n SP_POWERMESSAGEWAKE_PARAMS_A = packed record\r\n ClassInstallHeader: TSPClassInstallHeader;\r\n PowerMessageWake: array [0..(LINE_LEN * 2) - 1] of AnsiChar;\r\n end;\r\n {$EXTERNALSYM SP_POWERMESSAGEWAKE_PARAMS_A}\r\n SP_POWERMESSAGEWAKE_PARAMS_W = packed record\r\n ClassInstallHeader: TSPClassInstallHeader;\r\n PowerMessageWake: array [0..(LINE_LEN * 2) - 1] of WideChar;\r\n end;\r\n {$EXTERNALSYM SP_POWERMESSAGEWAKE_PARAMS_W}\r\n TSPPowerMessageWakeParamsA = SP_POWERMESSAGEWAKE_PARAMS_A;\r\n TSPPowerMessageWakeParamsW = SP_POWERMESSAGEWAKE_PARAMS_W;\r\n {$IFDEF UNICODE}\r\n TSPPowerMessageWakeParams = TSPPowerMessageWakeParamsW;\r\n PSPPowerMessageWakeParams = PSPPowerMessageWakeParamsW;\r\n {$ELSE}\r\n TSPPowerMessageWakeParams = TSPPowerMessageWakeParamsA;\r\n PSPPowerMessageWakeParams = PSPPowerMessageWakeParamsA;\r\n {$ENDIF UNICODE}\r\n\r\n//\r\n// Driver information structure (member of a driver info list that may be associated\r\n// with a particular device instance, or (globally) with a device information set)\r\n//\r\n PSPDrvInfoDataV2A = ^TSPDrvInfoDataV2A;\r\n PSPDrvInfoDataV2W = ^TSPDrvInfoDataV2W;\r\n SP_DRVINFO_DATA_V2_A = packed record\r\n cbSize: DWORD;\r\n DriverType: DWORD;\r\n Reserved: ULONG_PTR;\r\n Description: array [0..LINE_LEN - 1] of AnsiChar;\r\n MfgName: array [0..LINE_LEN - 1] of AnsiChar;\r\n ProviderName: array [0..LINE_LEN - 1] of AnsiChar;\r\n DriverDate: TFileTime;\r\n DriverVersion: Int64;\r\n end;\r\n {$EXTERNALSYM SP_DRVINFO_DATA_V2_A}\r\n SP_DRVINFO_DATA_V2_W = packed record\r\n cbSize: DWORD;\r\n DriverType: DWORD;\r\n Reserved: ULONG_PTR;\r\n Description: array [0..LINE_LEN - 1] of WideChar;\r\n MfgName: array [0..LINE_LEN - 1] of WideChar;\r\n ProviderName: array [0..LINE_LEN - 1] of WideChar;\r\n DriverDate: TFileTime;\r\n DriverVersion: Int64;\r\n end;\r\n {$EXTERNALSYM SP_DRVINFO_DATA_V2_W}\r\n TSPDrvInfoDataV2A = SP_DRVINFO_DATA_V2_A;\r\n TSPDrvInfoDataV2W = SP_DRVINFO_DATA_V2_W;\r\n {$IFDEF UNICODE}\r\n TSPDrvInfoDataV2 = TSPDrvInfoDataV2W;\r\n PSPDrvInfoDataV2 = PSPDrvInfoDataV2W;\r\n {$ELSE}\r\n TSPDrvInfoDataV2 = TSPDrvInfoDataV2A;\r\n PSPDrvInfoDataV2 = PSPDrvInfoDataV2A;\r\n {$ENDIF UNICODE}\r\n\r\n//\r\n// Version 1 of the SP_DRVINFO_DATA structures, used only for compatibility\r\n// with Windows NT 4.0/Windows 95/98 SETUPAPI.DLL\r\n//\r\n PSPDrvInfoDataV1A = ^TSPDrvInfoDataV1A;\r\n PSPDrvInfoDataV1W = ^TSPDrvInfoDataV1W;\r\n SP_DRVINFO_DATA_V1_A = packed record\r\n cbSize: DWORD;\r\n DriverType: DWORD;\r\n Reserved: ULONG_PTR;\r\n Description: array [0..LINE_LEN - 1] of AnsiChar;\r\n MfgName: array [0..LINE_LEN - 1] of AnsiChar;\r\n ProviderName: array [0..LINE_LEN - 1] of AnsiChar;\r\n end;\r\n {$EXTERNALSYM SP_DRVINFO_DATA_V1_A}\r\n SP_DRVINFO_DATA_V1_W = packed record\r\n cbSize: DWORD;\r\n DriverType: DWORD;\r\n Reserved: ULONG_PTR;\r\n Description: array [0..LINE_LEN - 1] of WideChar;\r\n MfgName: array [0..LINE_LEN - 1] of WideChar;\r\n ProviderName: array [0..LINE_LEN - 1] of WideChar;\r\n end;\r\n {$EXTERNALSYM SP_DRVINFO_DATA_V1_W}\r\n TSPDrvInfoDataV1A = SP_DRVINFO_DATA_V1_A;\r\n TSPDrvInfoDataV1W = SP_DRVINFO_DATA_V1_W;\r\n {$IFDEF UNICODE}\r\n TSPDrvInfoDataV1 = TSPDrvInfoDataV1W;\r\n PSPDrvInfoDataV1 = PSPDrvInfoDataV1W;\r\n {$ELSE}\r\n TSPDrvInfoDataV1 = TSPDrvInfoDataV1A;\r\n PSPDrvInfoDataV1 = PSPDrvInfoDataV1A;\r\n {$ENDIF UNICODE}\r\n\r\n {$IFDEF WIN2000_UP}\r\n TSPDrvInfoDataA = TSPDrvInfoDataV2A;\r\n TSPDrvInfoDataW = TSPDrvInfoDataV2W;\r\n PSPDrvInfoDataA = PSPDrvInfoDataV2A;\r\n PSPDrvInfoDataW = PSPDrvInfoDataV2W;\r\n {$IFDEF UNICODE}\r\n TSPDrvInfoData = TSPDrvInfoDataW;\r\n PSPDrvInfoData = PSPDrvInfoDataW;\r\n {$ELSE}\r\n TSPDrvInfoData = TSPDrvInfoDataA;\r\n PSPDrvInfoData = PSPDrvInfoDataA;\r\n {$ENDIF UNICODE}\r\n {$ELSE}\r\n TSPDrvInfoDataA = TSPDrvInfoDataV1A;\r\n TSPDrvInfoDataW = TSPDrvInfoDataV1W;\r\n PSPDrvInfoDataA = PSPDrvInfoDataV1A;\r\n PSPDrvInfoDataW = PSPDrvInfoDataV1W;\r\n {$IFDEF UNICODE}\r\n TSPDrvInfoData = TSPDrvInfoDataW;\r\n PSPDrvInfoData = PSPDrvInfoDataW;\r\n {$ELSE}\r\n TSPDrvInfoData = TSPDrvInfoDataA;\r\n PSPDrvInfoData = PSPDrvInfoDataA;\r\n {$ENDIF UNICODE}\r\n {$ENDIF WIN2000_UP}\r\n\r\n//\r\n// Driver information details structure (provides detailed information about a\r\n// particular driver information structure)\r\n//\r\n PSPDrvInfoDetailDataA = ^TSPDrvInfoDetailDataA;\r\n PSPDrvInfoDetailDataW = ^TSPDrvInfoDetailDataW;\r\n SP_DRVINFO_DETAIL_DATA_A = packed record\r\n cbSize: DWORD;\r\n InfDate: TFileTime;\r\n CompatIDsOffset: DWORD;\r\n CompatIDsLength: DWORD;\r\n Reserved: ULONG_PTR;\r\n SectionName: array [0..LINE_LEN - 1] of AnsiChar;\r\n InfFileName: array [0..MAX_PATH - 1] of AnsiChar;\r\n DrvDescription: array [0..LINE_LEN - 1] of AnsiChar;\r\n HardwareID: array [0..ANYSIZE_ARRAY - 1] of AnsiChar;\r\n end;\r\n {$EXTERNALSYM SP_DRVINFO_DETAIL_DATA_A}\r\n SP_DRVINFO_DETAIL_DATA_W = packed record\r\n cbSize: DWORD;\r\n InfDate: TFileTime;\r\n CompatIDsOffset: DWORD;\r\n CompatIDsLength: DWORD;\r\n Reserved: ULONG_PTR;\r\n SectionName: array [0..LINE_LEN - 1] of WideChar;\r\n InfFileName: array [0..MAX_PATH - 1] of WideChar;\r\n DrvDescription: array [0..LINE_LEN - 1] of WideChar;\r\n HardwareID: array [0..ANYSIZE_ARRAY - 1] of WideChar;\r\n end;\r\n {$EXTERNALSYM SP_DRVINFO_DETAIL_DATA_W}\r\n TSPDrvInfoDetailDataA = SP_DRVINFO_DETAIL_DATA_A;\r\n TSPDrvInfoDetailDataW = SP_DRVINFO_DETAIL_DATA_W;\r\n {$IFDEF UNICODE}\r\n TSPDrvInfoDetailData = TSPDrvInfoDetailDataW;\r\n PSPDrvInfoDetailData = PSPDrvInfoDetailDataW;\r\n {$ELSE}\r\n TSPDrvInfoDetailData = TSPDrvInfoDetailDataA;\r\n PSPDrvInfoDetailData = PSPDrvInfoDetailDataA;\r\n {$ENDIF UNICODE}\r\n\r\n//\r\n// Driver installation parameters (associated with a particular driver\r\n// information element)\r\n//\r\n PSPDrvInstallParams = ^TSPDrvInstallParams;\r\n SP_DRVINSTALL_PARAMS = packed record\r\n cbSize: DWORD;\r\n Rank: DWORD;\r\n Flags: DWORD;\r\n PrivateData: DWORD_PTR;\r\n Reserved: DWORD;\r\n end;\r\n {$EXTERNALSYM SP_DRVINSTALL_PARAMS}\r\n TSPDrvInstallParams = SP_DRVINSTALL_PARAMS;\r\n\r\n//\r\n// SP_DRVINSTALL_PARAMS.Flags values\r\n//\r\nconst\r\n DNF_DUPDESC = $00000001; // Multiple providers have same desc\r\n {$EXTERNALSYM DNF_DUPDESC}\r\n DNF_OLDDRIVER = $00000002; // Driver node specifies old/current driver\r\n {$EXTERNALSYM DNF_OLDDRIVER}\r\n DNF_EXCLUDEFROMLIST = $00000004; // If set, this driver node will not be\r\n {$EXTERNALSYM DNF_EXCLUDEFROMLIST} // displayed in any driver select dialogs.\r\n DNF_NODRIVER = $00000008; // if we want to install no driver\r\n {$EXTERNALSYM DNF_NODRIVER} // (e.g no mouse drv)\r\n DNF_LEGACYINF = $00000010; // this driver node comes from an old-style INF\r\n {$EXTERNALSYM DNF_LEGACYINF}\r\n DNF_CLASS_DRIVER = $00000020; // Driver node represents a class driver\r\n {$EXTERNALSYM DNF_CLASS_DRIVER}\r\n DNF_COMPATIBLE_DRIVER = $00000040; // Driver node represents a compatible driver\r\n {$EXTERNALSYM DNF_COMPATIBLE_DRIVER}\r\n DNF_INET_DRIVER = $00000080; // Driver comes from an internet source\r\n {$EXTERNALSYM DNF_INET_DRIVER}\r\n DNF_UNUSED1 = $00000100;\r\n {$EXTERNALSYM DNF_UNUSED1}\r\n DNF_INDEXED_DRIVER = $00000200; // Driver is contained in the Windows Driver Index\r\n {$EXTERNALSYM DNF_INDEXED_DRIVER}\r\n DNF_OLD_INET_DRIVER = $00000400; // Driver came from the Internet, but we don't currently\r\n {$EXTERNALSYM DNF_OLD_INET_DRIVER} // have access to it's source files. Never attempt to\r\n // install a driver with this flag!\r\n DNF_BAD_DRIVER = $00000800; // Driver node should not be used at all\r\n {$EXTERNALSYM DNF_BAD_DRIVER}\r\n DNF_DUPPROVIDER = $00001000; // Multiple drivers have the same provider and desc\r\n {$EXTERNALSYM DNF_DUPPROVIDER}\r\n\r\n DNF_INF_IS_SIGNED = $00002000; // If file is digitally signed\r\n {$EXTERNALSYM DNF_INF_IS_SIGNED}\r\n DNF_OEM_F6_INF = $00004000; // INF specified from F6 during textmode setup.\r\n {$EXTERNALSYM DNF_OEM_F6_INF}\r\n DNF_DUPDRIVERVER = $00008000; // Multipe drivers have the same desc, provider, and DriverVer values\r\n {$EXTERNALSYM DNF_DUPDRIVERVER}\r\n DNF_BASIC_DRIVER = $00010000; // Driver provides basic functionality, but should\r\n {$EXTERNALSYM DNF_BASIC_DRIVER}\r\n // not be chosen if other signed drivers exist.\r\n//\r\n// Rank values (the lower the Rank number, the better the Rank)\r\n//\r\n DRIVER_HARDWAREID_RANK = $00000FFF; // Any rank less than or equal to\r\n {$EXTERNALSYM DRIVER_HARDWAREID_RANK} // this value is a trusted\r\n // HardwareID match\r\n\r\n DRIVER_COMPATID_RANK = $00003FFF; // Any rank less than or equal to\r\n {$EXTERNALSYM DRIVER_COMPATID_RANK} // this (and greater than\r\n // DRIVER_HARDWAREID_RANK) is a\r\n // trusted CompatibleID match\r\n\r\n DRIVER_UNTRUSTED_RANK = $00008000; // Any rank with this bit set is an\r\n {$EXTERNALSYM DRIVER_UNTRUSTED_RANK} // \"untrusted\" rank, meaning that\r\n // the INF was unsigned.\r\n\r\n DRIVER_UNTRUSTED_HARDWAREID_RANK = $00008FFF; // Any rank less than or equal to\r\n {$EXTERNALSYM DRIVER_UNTRUSTED_HARDWAREID_RANK} // this value (and greater than\r\n // or equal to DRIVER_UNTRUSTED_RANK)\r\n // is an untrusted HardwareID match\r\n\r\n DRIVER_UNTRUSTED_COMPATID_RANK = $0000BFFF; // Any rank less than or equal to\r\n {$EXTERNALSYM DRIVER_UNTRUSTED_COMPATID_RANK} // this value (and greater than\r\n // DRIVER_UNTRUSTED_HARDWAREID_RANK)\r\n // is an untrusted CompatibleID match\r\n\r\n DRIVER_W9X_SUSPECT_RANK = $0000C000; // Any rank that is greater than\r\n {$EXTERNALSYM DRIVER_W9X_SUSPECT_RANK} // or equal to this value, and lesser\r\n // than or equal to 0xFFFF is suspected\r\n // to be a Win9x-only driver, because\r\n // (a) it isn't signed, and (b) there\r\n // is no NT-specific decoration to\r\n // explicitly indicate that the INF\r\n // supports Windows NT/200x\r\n\r\n DRIVER_W9X_SUSPECT_HARDWAREID_RANK = $0000CFFF; // Any rank less than or equal to this\r\n {$EXTERNALSYM DRIVER_W9X_SUSPECT_HARDWAREID_RANK} // (and greater than or equal to\r\n // DRIVER_W9X_SUSPECT_RANK) is a\r\n // hardware ID match suspected of being\r\n // only for Windows 9x platforms.\r\n\r\n DRIVER_W9X_SUSPECT_COMPATID_RANK = $0000FFFF; // Any rank less than or equal to\r\n {$EXTERNALSYM DRIVER_W9X_SUSPECT_COMPATID_RANK} // this (and greater than\r\n // DRIVER_W9X_SUSPECT_HARDWAREID_RANK)\r\n // is a compatible ID match suspected\r\n // of being only for Windows 9x\r\n // platforms.\r\n\r\n//\r\n// Setup callback routine for comparing detection signatures\r\n//\r\ntype\r\n TSPDetsigCmpProc = function(DeviceInfoSet: HDEVINFO; NewDeviceData,\r\n ExistingDeviceData: PSPDevInfoData; CompareContext: Pointer): DWORD; stdcall;\r\n\r\n//\r\n// Define context structure handed to co-installers\r\n//\r\n PCoInstallerContextData = ^TCoInstallerContextData;\r\n COINSTALLER_CONTEXT_DATA = packed record\r\n PostProcessing: BOOL;\r\n InstallResult: DWORD;\r\n PrivateData: Pointer;\r\n end;\r\n {$EXTERNALSYM COINSTALLER_CONTEXT_DATA}\r\n TCoInstallerContextData = COINSTALLER_CONTEXT_DATA;\r\n\r\n//\r\n// Structure containing class image list information.\r\n//\r\n PSPClassImageListData = ^TSPClassImageListData;\r\n SP_CLASSIMAGELIST_DATA = packed record\r\n cbSize: DWORD;\r\n ImageList: HIMAGELIST;\r\n Reserved: ULONG_PTR;\r\n end;\r\n {$EXTERNALSYM SP_CLASSIMAGELIST_DATA}\r\n TSPClassImageListData = SP_CLASSIMAGELIST_DATA;\r\n\r\n//\r\n// Structure to be passed as first parameter (LPVOID lpv) to ExtensionPropSheetPageProc\r\n// entry point in setupapi.dll or to \"EnumPropPages32\" or \"BasicProperties32\" entry\r\n// points provided by class/device property page providers. Used to retrieve a handle\r\n// (or, potentially, multiple handles) to property pages for a specified property page type.\r\n//\r\n PSPPropSheetPageRequest = ^TSPPropSheetPageRequest;\r\n SP_PROPSHEETPAGE_REQUEST = packed record\r\n cbSize: DWORD;\r\n PageRequested: DWORD;\r\n DeviceInfoSet: HDEVINFO;\r\n DeviceInfoData: PSPDevInfoData;\r\n end;\r\n {$EXTERNALSYM SP_PROPSHEETPAGE_REQUEST}\r\n TSPPropSheetPageRequest = SP_PROPSHEETPAGE_REQUEST;\r\n\r\n//\r\n// Property sheet codes used in SP_PROPSHEETPAGE_REQUEST.PageRequested\r\n//\r\nconst\r\n SPPSR_SELECT_DEVICE_RESOURCES = 1; // supplied by setupapi.dll\r\n {$EXTERNALSYM SPPSR_SELECT_DEVICE_RESOURCES}\r\n SPPSR_ENUM_BASIC_DEVICE_PROPERTIES = 2; // supplied by device's BasicProperties32 provider\r\n {$EXTERNALSYM SPPSR_ENUM_BASIC_DEVICE_PROPERTIES}\r\n SPPSR_ENUM_ADV_DEVICE_PROPERTIES = 3; // supplied by class and/or device's EnumPropPages32 provider\r\n {$EXTERNALSYM SPPSR_ENUM_ADV_DEVICE_PROPERTIES}\r\n\r\n//\r\n// Structure used with SetupGetBackupInformation/SetupSetBackupInformation\r\n//\r\ntype\r\n PSPBackupQueueParamsV2A = ^TSPBackupQueueParamsV2A;\r\n PSPBackupQueueParamsV2W = ^TSPBackupQueueParamsV2W;\r\n SP_BACKUP_QUEUE_PARAMS_V2_A = packed record\r\n cbSize: DWORD;\r\n FullInfPath: array [0..MAX_PATH - 1] of AnsiChar; // buffer to hold ANSI pathname of INF file\r\n FilenameOffset: Integer; // offset in CHAR's of filename part (after '\\')\r\n ReinstallInstance: array [0..MAX_PATH - 1] of AnsiChar; // Instance ID (if present)\r\n end;\r\n {$EXTERNALSYM SP_BACKUP_QUEUE_PARAMS_V2_A}\r\n SP_BACKUP_QUEUE_PARAMS_V2_W = packed record\r\n cbSize: DWORD;\r\n FullInfPath: array [0..MAX_PATH - 1] of WideChar; // buffer to hold ANSI pathname of INF file\r\n FilenameOffset: Integer; // offset in CHAR's of filename part (after '\\')\r\n ReinstallInstance: array [0..MAX_PATH - 1] of WideChar; // Instance ID (if present)\r\n end;\r\n {$EXTERNALSYM SP_BACKUP_QUEUE_PARAMS_V2_W}\r\n TSPBackupQueueParamsV2A = SP_BACKUP_QUEUE_PARAMS_V2_A;\r\n TSPBackupQueueParamsV2W = SP_BACKUP_QUEUE_PARAMS_V2_W;\r\n {$IFDEF UNICODE}\r\n TSPBackupQueueParamsV2 = TSPBackupQueueParamsV2W;\r\n PSPBackupQueueParamsV2 = PSPBackupQueueParamsV2W;\r\n {$ELSE}\r\n TSPBackupQueueParamsV2 = TSPBackupQueueParamsV2A;\r\n PSPBackupQueueParamsV2 = PSPBackupQueueParamsV2A;\r\n {$ENDIF UNICODE}\r\n\r\n PSPBackupQueueParamsV1A = ^TSPBackupQueueParamsV1A;\r\n PSPBackupQueueParamsV1W = ^TSPBackupQueueParamsV1W;\r\n SP_BACKUP_QUEUE_PARAMS_V1_A = packed record\r\n cbSize: DWORD;\r\n FullInfPath: array [0..MAX_PATH - 1] of AnsiChar; // buffer to hold ANSI pathname of INF file\r\n FilenameOffset: Integer; // offset in CHAR's of filename part (after '\\')\r\n end;\r\n {$EXTERNALSYM SP_BACKUP_QUEUE_PARAMS_V1_A}\r\n SP_BACKUP_QUEUE_PARAMS_V1_W = packed record\r\n cbSize: DWORD;\r\n FullInfPath: array [0..MAX_PATH - 1] of WideChar; // buffer to hold ANSI pathname of INF file\r\n FilenameOffset: Integer; // offset in CHAR's of filename part (after '\\')\r\n end;\r\n {$EXTERNALSYM SP_BACKUP_QUEUE_PARAMS_V1_W}\r\n TSPBackupQueueParamsV1A = SP_BACKUP_QUEUE_PARAMS_V1_A;\r\n TSPBackupQueueParamsV1W = SP_BACKUP_QUEUE_PARAMS_V1_W;\r\n {$IFDEF UNICODE}\r\n TSPBackupQueueParamsV1 = TSPBackupQueueParamsV1W;\r\n PSPBackupQueueParamsV1 = PSPBackupQueueParamsV1W;\r\n {$ELSE}\r\n TSPBackupQueueParamsV1 = TSPBackupQueueParamsV1A;\r\n PSPBackupQueueParamsV1 = PSPBackupQueueParamsV1A;\r\n {$ENDIF UNICODE}\r\n\r\n {$IFDEF USE_SP_BACKUP_QUEUE_PARAMS_V1}\r\n TSPBackupQueueParamsA = TSPBackupQueueParamsV1A;\r\n TSPBackupQueueParamsW = TSPBackupQueueParamsV1W;\r\n TSPBackupQueueParams = TSPBackupQueueParamsV1;\r\n PSPBackupQueueParamsA = PSPBackupQueueParamsV1A;\r\n PSPBackupQueueParamsW = PSPBackupQueueParamsV1W;\r\n PSPBackupQueueParams = PSPBackupQueueParamsV1;\r\n {$ELSE}\r\n TSPBackupQueueParamsA = TSPBackupQueueParamsV2A;\r\n TSPBackupQueueParamsW = TSPBackupQueueParamsV2W;\r\n TSPBackupQueueParams = TSPBackupQueueParamsV2;\r\n PSPBackupQueueParamsA = PSPBackupQueueParamsV2A;\r\n PSPBackupQueueParamsW = PSPBackupQueueParamsV2W;\r\n PSPBackupQueueParams = PSPBackupQueueParamsV2;\r\n {$ENDIF USE_SP_BACKUP_QUEUE_PARAMS_V1}\r\n\r\n//\r\n// Setupapi-specific error codes\r\n//\r\n// Inf parse outcomes\r\n//\r\nconst\r\n APPLICATION_ERROR_MASK = DWORD($20000000); // from WINNT.h\r\n {$EXTERNALSYM APPLICATION_ERROR_MASK}\r\n ERROR_SEVERITY_ERROR = DWORD($C0000000); // from WINNT.h\r\n {$EXTERNALSYM ERROR_SEVERITY_ERROR}\r\n\r\n ERROR_EXPECTED_SECTION_NAME = DWORD(APPLICATION_ERROR_MASK or ERROR_SEVERITY_ERROR or 0);\r\n {$EXTERNALSYM ERROR_EXPECTED_SECTION_NAME}\r\n ERROR_BAD_SECTION_NAME_LINE = DWORD(APPLICATION_ERROR_MASK or ERROR_SEVERITY_ERROR or 1);\r\n {$EXTERNALSYM ERROR_BAD_SECTION_NAME_LINE}\r\n ERROR_SECTION_NAME_TOO_LONG = DWORD(APPLICATION_ERROR_MASK or ERROR_SEVERITY_ERROR or 2);\r\n {$EXTERNALSYM ERROR_SECTION_NAME_TOO_LONG}\r\n ERROR_GENERAL_SYNTAX = DWORD(APPLICATION_ERROR_MASK or ERROR_SEVERITY_ERROR or 3);\r\n {$EXTERNALSYM ERROR_GENERAL_SYNTAX}\r\n\r\n//\r\n// Inf runtime errors\r\n//\r\n ERROR_WRONG_INF_STYLE = DWORD(APPLICATION_ERROR_MASK or ERROR_SEVERITY_ERROR or $100);\r\n {$EXTERNALSYM ERROR_WRONG_INF_STYLE}\r\n ERROR_SECTION_NOT_FOUND = DWORD(APPLICATION_ERROR_MASK or ERROR_SEVERITY_ERROR or $101);\r\n {$EXTERNALSYM ERROR_SECTION_NOT_FOUND}\r\n ERROR_LINE_NOT_FOUND = DWORD(APPLICATION_ERROR_MASK or ERROR_SEVERITY_ERROR or $102);\r\n {$EXTERNALSYM ERROR_LINE_NOT_FOUND}\r\n ERROR_NO_BACKUP = DWORD(APPLICATION_ERROR_MASK or ERROR_SEVERITY_ERROR or $103);\r\n {$EXTERNALSYM ERROR_NO_BACKUP}\r\n\r\n//\r\n// Device Installer/other errors\r\n//\r\n ERROR_NO_ASSOCIATED_CLASS = DWORD(APPLICATION_ERROR_MASK or ERROR_SEVERITY_ERROR or $200);\r\n {$EXTERNALSYM ERROR_NO_ASSOCIATED_CLASS}\r\n ERROR_CLASS_MISMATCH = DWORD(APPLICATION_ERROR_MASK or ERROR_SEVERITY_ERROR or $201);\r\n {$EXTERNALSYM ERROR_CLASS_MISMATCH}\r\n ERROR_DUPLICATE_FOUND = DWORD(APPLICATION_ERROR_MASK or ERROR_SEVERITY_ERROR or $202);\r\n {$EXTERNALSYM ERROR_DUPLICATE_FOUND}\r\n ERROR_NO_DRIVER_SELECTED = DWORD(APPLICATION_ERROR_MASK or ERROR_SEVERITY_ERROR or $203);\r\n {$EXTERNALSYM ERROR_NO_DRIVER_SELECTED}\r\n ERROR_KEY_DOES_NOT_EXIST = DWORD(APPLICATION_ERROR_MASK or ERROR_SEVERITY_ERROR or $204);\r\n {$EXTERNALSYM ERROR_KEY_DOES_NOT_EXIST}\r\n ERROR_INVALID_DEVINST_NAME = DWORD(APPLICATION_ERROR_MASK or ERROR_SEVERITY_ERROR or $205);\r\n {$EXTERNALSYM ERROR_INVALID_DEVINST_NAME}\r\n ERROR_INVALID_CLASS = DWORD(APPLICATION_ERROR_MASK or ERROR_SEVERITY_ERROR or $206);\r\n {$EXTERNALSYM ERROR_INVALID_CLASS}\r\n ERROR_DEVINST_ALREADY_EXISTS = DWORD(APPLICATION_ERROR_MASK or ERROR_SEVERITY_ERROR or $207);\r\n {$EXTERNALSYM ERROR_DEVINST_ALREADY_EXISTS}\r\n ERROR_DEVINFO_NOT_REGISTERED = DWORD(APPLICATION_ERROR_MASK or ERROR_SEVERITY_ERROR or $208);\r\n {$EXTERNALSYM ERROR_DEVINFO_NOT_REGISTERED}\r\n ERROR_INVALID_REG_PROPERTY = DWORD(APPLICATION_ERROR_MASK or ERROR_SEVERITY_ERROR or $209);\r\n {$EXTERNALSYM ERROR_INVALID_REG_PROPERTY}\r\n ERROR_NO_INF = DWORD(APPLICATION_ERROR_MASK or ERROR_SEVERITY_ERROR or $20A);\r\n {$EXTERNALSYM ERROR_NO_INF}\r\n ERROR_NO_SUCH_DEVINST = DWORD(APPLICATION_ERROR_MASK or ERROR_SEVERITY_ERROR or $20B);\r\n {$EXTERNALSYM ERROR_NO_SUCH_DEVINST}\r\n ERROR_CANT_LOAD_CLASS_ICON = DWORD(APPLICATION_ERROR_MASK or ERROR_SEVERITY_ERROR or $20C);\r\n {$EXTERNALSYM ERROR_CANT_LOAD_CLASS_ICON}\r\n ERROR_INVALID_CLASS_INSTALLER = DWORD(APPLICATION_ERROR_MASK or ERROR_SEVERITY_ERROR or $20D);\r\n {$EXTERNALSYM ERROR_INVALID_CLASS_INSTALLER}\r\n ERROR_DI_DO_DEFAULT = DWORD(APPLICATION_ERROR_MASK or ERROR_SEVERITY_ERROR or $20E);\r\n {$EXTERNALSYM ERROR_DI_DO_DEFAULT}\r\n ERROR_DI_NOFILECOPY = DWORD(APPLICATION_ERROR_MASK or ERROR_SEVERITY_ERROR or $20F);\r\n {$EXTERNALSYM ERROR_DI_NOFILECOPY}\r\n ERROR_INVALID_HWPROFILE = DWORD(APPLICATION_ERROR_MASK or ERROR_SEVERITY_ERROR or $210);\r\n {$EXTERNALSYM ERROR_INVALID_HWPROFILE}\r\n ERROR_NO_DEVICE_SELECTED = DWORD(APPLICATION_ERROR_MASK or ERROR_SEVERITY_ERROR or $211);\r\n {$EXTERNALSYM ERROR_NO_DEVICE_SELECTED}\r\n ERROR_DEVINFO_LIST_LOCKED = DWORD(APPLICATION_ERROR_MASK or ERROR_SEVERITY_ERROR or $212);\r\n {$EXTERNALSYM ERROR_DEVINFO_LIST_LOCKED}\r\n ERROR_DEVINFO_DATA_LOCKED = DWORD(APPLICATION_ERROR_MASK or ERROR_SEVERITY_ERROR or $213);\r\n {$EXTERNALSYM ERROR_DEVINFO_DATA_LOCKED}\r\n ERROR_DI_BAD_PATH = DWORD(APPLICATION_ERROR_MASK or ERROR_SEVERITY_ERROR or $214);\r\n {$EXTERNALSYM ERROR_DI_BAD_PATH}\r\n ERROR_NO_CLASSINSTALL_PARAMS = DWORD(APPLICATION_ERROR_MASK or ERROR_SEVERITY_ERROR or $215);\r\n {$EXTERNALSYM ERROR_NO_CLASSINSTALL_PARAMS}\r\n ERROR_FILEQUEUE_LOCKED = DWORD(APPLICATION_ERROR_MASK or ERROR_SEVERITY_ERROR or $216);\r\n {$EXTERNALSYM ERROR_FILEQUEUE_LOCKED}\r\n ERROR_BAD_SERVICE_INSTALLSECT = DWORD(APPLICATION_ERROR_MASK or ERROR_SEVERITY_ERROR or $217);\r\n {$EXTERNALSYM ERROR_BAD_SERVICE_INSTALLSECT}\r\n ERROR_NO_CLASS_DRIVER_LIST = DWORD(APPLICATION_ERROR_MASK or ERROR_SEVERITY_ERROR or $218);\r\n {$EXTERNALSYM ERROR_NO_CLASS_DRIVER_LIST}\r\n ERROR_NO_ASSOCIATED_SERVICE = DWORD(APPLICATION_ERROR_MASK or ERROR_SEVERITY_ERROR or $219);\r\n {$EXTERNALSYM ERROR_NO_ASSOCIATED_SERVICE}\r\n ERROR_NO_DEFAULT_DEVICE_INTERFACE = DWORD(APPLICATION_ERROR_MASK or ERROR_SEVERITY_ERROR or $21A);\r\n {$EXTERNALSYM ERROR_NO_DEFAULT_DEVICE_INTERFACE}\r\n ERROR_DEVICE_INTERFACE_ACTIVE = DWORD(APPLICATION_ERROR_MASK or ERROR_SEVERITY_ERROR or $21B);\r\n {$EXTERNALSYM ERROR_DEVICE_INTERFACE_ACTIVE}\r\n ERROR_DEVICE_INTERFACE_REMOVED = DWORD(APPLICATION_ERROR_MASK or ERROR_SEVERITY_ERROR or $21C);\r\n {$EXTERNALSYM ERROR_DEVICE_INTERFACE_REMOVED}\r\n ERROR_BAD_INTERFACE_INSTALLSECT = DWORD(APPLICATION_ERROR_MASK or ERROR_SEVERITY_ERROR or $21D);\r\n {$EXTERNALSYM ERROR_BAD_INTERFACE_INSTALLSECT}\r\n ERROR_NO_SUCH_INTERFACE_CLASS = DWORD(APPLICATION_ERROR_MASK or ERROR_SEVERITY_ERROR or $21E);\r\n {$EXTERNALSYM ERROR_NO_SUCH_INTERFACE_CLASS}\r\n ERROR_INVALID_REFERENCE_STRING = DWORD(APPLICATION_ERROR_MASK or ERROR_SEVERITY_ERROR or $21F);\r\n {$EXTERNALSYM ERROR_INVALID_REFERENCE_STRING}\r\n ERROR_INVALID_MACHINENAME = DWORD(APPLICATION_ERROR_MASK or ERROR_SEVERITY_ERROR or $220);\r\n {$EXTERNALSYM ERROR_INVALID_MACHINENAME}\r\n ERROR_REMOTE_COMM_FAILURE = DWORD(APPLICATION_ERROR_MASK or ERROR_SEVERITY_ERROR or $221);\r\n {$EXTERNALSYM ERROR_REMOTE_COMM_FAILURE}\r\n ERROR_MACHINE_UNAVAILABLE = DWORD(APPLICATION_ERROR_MASK or ERROR_SEVERITY_ERROR or $222);\r\n {$EXTERNALSYM ERROR_MACHINE_UNAVAILABLE}\r\n ERROR_NO_CONFIGMGR_SERVICES = DWORD(APPLICATION_ERROR_MASK or ERROR_SEVERITY_ERROR or $223);\r\n {$EXTERNALSYM ERROR_NO_CONFIGMGR_SERVICES}\r\n ERROR_INVALID_PROPPAGE_PROVIDER = DWORD(APPLICATION_ERROR_MASK or ERROR_SEVERITY_ERROR or $224);\r\n {$EXTERNALSYM ERROR_INVALID_PROPPAGE_PROVIDER}\r\n ERROR_NO_SUCH_DEVICE_INTERFACE = DWORD(APPLICATION_ERROR_MASK or ERROR_SEVERITY_ERROR or $225);\r\n {$EXTERNALSYM ERROR_NO_SUCH_DEVICE_INTERFACE}\r\n ERROR_DI_POSTPROCESSING_REQUIRED = DWORD(APPLICATION_ERROR_MASK or ERROR_SEVERITY_ERROR or $226);\r\n {$EXTERNALSYM ERROR_DI_POSTPROCESSING_REQUIRED}\r\n ERROR_INVALID_COINSTALLER = DWORD(APPLICATION_ERROR_MASK or ERROR_SEVERITY_ERROR or $227);\r\n {$EXTERNALSYM ERROR_INVALID_COINSTALLER}\r\n ERROR_NO_COMPAT_DRIVERS = DWORD(APPLICATION_ERROR_MASK or ERROR_SEVERITY_ERROR or $228);\r\n {$EXTERNALSYM ERROR_NO_COMPAT_DRIVERS}\r\n ERROR_NO_DEVICE_ICON = DWORD(APPLICATION_ERROR_MASK or ERROR_SEVERITY_ERROR or $229);\r\n {$EXTERNALSYM ERROR_NO_DEVICE_ICON}\r\n ERROR_INVALID_INF_LOGCONFIG = DWORD(APPLICATION_ERROR_MASK or ERROR_SEVERITY_ERROR or $22A);\r\n {$EXTERNALSYM ERROR_INVALID_INF_LOGCONFIG}\r\n ERROR_DI_DONT_INSTALL = DWORD(APPLICATION_ERROR_MASK or ERROR_SEVERITY_ERROR or $22B);\r\n {$EXTERNALSYM ERROR_DI_DONT_INSTALL}\r\n ERROR_INVALID_FILTER_DRIVER = DWORD(APPLICATION_ERROR_MASK or ERROR_SEVERITY_ERROR or $22C);\r\n {$EXTERNALSYM ERROR_INVALID_FILTER_DRIVER}\r\n ERROR_NON_WINDOWS_NT_DRIVER = DWORD(APPLICATION_ERROR_MASK or ERROR_SEVERITY_ERROR or $22D);\r\n {$EXTERNALSYM ERROR_NON_WINDOWS_NT_DRIVER}\r\n ERROR_NON_WINDOWS_DRIVER = DWORD(APPLICATION_ERROR_MASK or ERROR_SEVERITY_ERROR or $22E);\r\n {$EXTERNALSYM ERROR_NON_WINDOWS_DRIVER}\r\n ERROR_NO_CATALOG_FOR_OEM_INF = DWORD(APPLICATION_ERROR_MASK or ERROR_SEVERITY_ERROR or $22F);\r\n {$EXTERNALSYM ERROR_NO_CATALOG_FOR_OEM_INF}\r\n ERROR_DEVINSTALL_QUEUE_NONNATIVE = DWORD(APPLICATION_ERROR_MASK or ERROR_SEVERITY_ERROR or $230);\r\n {$EXTERNALSYM ERROR_DEVINSTALL_QUEUE_NONNATIVE}\r\n ERROR_NOT_DISABLEABLE = DWORD(APPLICATION_ERROR_MASK or ERROR_SEVERITY_ERROR or $231);\r\n {$EXTERNALSYM ERROR_NOT_DISABLEABLE}\r\n ERROR_CANT_REMOVE_DEVINST = DWORD(APPLICATION_ERROR_MASK or ERROR_SEVERITY_ERROR or $232);\r\n {$EXTERNALSYM ERROR_CANT_REMOVE_DEVINST}\r\n ERROR_INVALID_TARGET = DWORD(APPLICATION_ERROR_MASK or ERROR_SEVERITY_ERROR or $233);\r\n {$EXTERNALSYM ERROR_INVALID_TARGET}\r\n ERROR_DRIVER_NONNATIVE = DWORD(APPLICATION_ERROR_MASK or ERROR_SEVERITY_ERROR or $234);\r\n {$EXTERNALSYM ERROR_DRIVER_NONNATIVE}\r\n ERROR_IN_WOW64 = DWORD(APPLICATION_ERROR_MASK or ERROR_SEVERITY_ERROR or $235);\r\n {$EXTERNALSYM ERROR_IN_WOW64}\r\n ERROR_SET_SYSTEM_RESTORE_POINT = DWORD(APPLICATION_ERROR_MASK or ERROR_SEVERITY_ERROR or $236);\r\n {$EXTERNALSYM ERROR_SET_SYSTEM_RESTORE_POINT}\r\n ERROR_INCORRECTLY_COPIED_INF = DWORD(APPLICATION_ERROR_MASK or ERROR_SEVERITY_ERROR or $237);\r\n {$EXTERNALSYM ERROR_INCORRECTLY_COPIED_INF}\r\n ERROR_SCE_DISABLED = DWORD(APPLICATION_ERROR_MASK or ERROR_SEVERITY_ERROR or $238);\r\n {$EXTERNALSYM ERROR_SCE_DISABLED}\r\n\r\n//\r\n// Backward compatibility--do not use.\r\n//\r\n ERROR_NO_DEFAULT_INTERFACE_DEVICE = ERROR_NO_DEFAULT_DEVICE_INTERFACE;\r\n {$EXTERNALSYM ERROR_NO_DEFAULT_INTERFACE_DEVICE}\r\n ERROR_INTERFACE_DEVICE_ACTIVE = ERROR_DEVICE_INTERFACE_ACTIVE;\r\n {$EXTERNALSYM ERROR_INTERFACE_DEVICE_ACTIVE}\r\n ERROR_INTERFACE_DEVICE_REMOVED = ERROR_DEVICE_INTERFACE_REMOVED;\r\n {$EXTERNALSYM ERROR_INTERFACE_DEVICE_REMOVED}\r\n ERROR_NO_SUCH_INTERFACE_DEVICE = ERROR_NO_SUCH_DEVICE_INTERFACE;\r\n {$EXTERNALSYM ERROR_NO_SUCH_INTERFACE_DEVICE}\r\n\r\n//\r\n// Win9x migration DLL error code\r\n//\r\n ERROR_NOT_INSTALLED = DWORD(APPLICATION_ERROR_MASK or ERROR_SEVERITY_ERROR or $1000);\r\n {$EXTERNALSYM ERROR_NOT_INSTALLED}\r\n\r\n// (rom) moved may consts here to allow for dynamic linking\r\n\r\n//\r\n// SearchControl flags for SetupGetInfInformation\r\n//\r\nconst\r\n INFINFO_INF_SPEC_IS_HINF = 1;\r\n {$EXTERNALSYM INFINFO_INF_SPEC_IS_HINF}\r\n INFINFO_INF_NAME_IS_ABSOLUTE = 2;\r\n {$EXTERNALSYM INFINFO_INF_NAME_IS_ABSOLUTE}\r\n INFINFO_DEFAULT_SEARCH = 3;\r\n {$EXTERNALSYM INFINFO_DEFAULT_SEARCH}\r\n INFINFO_REVERSE_DEFAULT_SEARCH = 4;\r\n {$EXTERNALSYM INFINFO_REVERSE_DEFAULT_SEARCH}\r\n INFINFO_INF_PATH_LIST_SEARCH = 5;\r\n {$EXTERNALSYM INFINFO_INF_PATH_LIST_SEARCH}\r\n\r\n//\r\n// Compression types\r\n//\r\nconst\r\n FILE_COMPRESSION_NONE = 0;\r\n {$EXTERNALSYM FILE_COMPRESSION_NONE}\r\n FILE_COMPRESSION_WINLZA = 1;\r\n {$EXTERNALSYM FILE_COMPRESSION_WINLZA}\r\n FILE_COMPRESSION_MSZIP = 2;\r\n {$EXTERNALSYM FILE_COMPRESSION_MSZIP}\r\n FILE_COMPRESSION_NTCAB = 3;\r\n {$EXTERNALSYM FILE_COMPRESSION_NTCAB}\r\n\r\n//\r\n// Define flags for SourceList APIs.\r\n//\r\nconst\r\n SRCLIST_TEMPORARY = $00000001;\r\n {$EXTERNALSYM SRCLIST_TEMPORARY}\r\n SRCLIST_NOBROWSE = $00000002;\r\n {$EXTERNALSYM SRCLIST_NOBROWSE}\r\n SRCLIST_SYSTEM = $00000010;\r\n {$EXTERNALSYM SRCLIST_SYSTEM}\r\n SRCLIST_USER = $00000020;\r\n {$EXTERNALSYM SRCLIST_USER}\r\n SRCLIST_SYSIFADMIN = $00000040;\r\n {$EXTERNALSYM SRCLIST_SYSIFADMIN}\r\n SRCLIST_SUBDIRS = $00000100;\r\n {$EXTERNALSYM SRCLIST_SUBDIRS}\r\n SRCLIST_APPEND = $00000200;\r\n {$EXTERNALSYM SRCLIST_APPEND}\r\n SRCLIST_NOSTRIPPLATFORM = $00000400;\r\n {$EXTERNALSYM SRCLIST_NOSTRIPPLATFORM}\r\n\r\n//\r\n// Styles for SetupPromptForDisk, SetupCopyError,\r\n// SetupRenameError, SetupDeleteError\r\n//\r\nconst\r\n IDF_NOBROWSE = $00000001;\r\n {$EXTERNALSYM IDF_NOBROWSE}\r\n IDF_NOSKIP = $00000002;\r\n {$EXTERNALSYM IDF_NOSKIP}\r\n IDF_NODETAILS = $00000004;\r\n {$EXTERNALSYM IDF_NODETAILS}\r\n IDF_NOCOMPRESSED = $00000008;\r\n {$EXTERNALSYM IDF_NOCOMPRESSED}\r\n IDF_CHECKFIRST = $00000100;\r\n {$EXTERNALSYM IDF_CHECKFIRST}\r\n IDF_NOBEEP = $00000200;\r\n {$EXTERNALSYM IDF_NOBEEP}\r\n IDF_NOFOREGROUND = $00000400;\r\n {$EXTERNALSYM IDF_NOFOREGROUND}\r\n IDF_WARNIFSKIP = $00000800;\r\n {$EXTERNALSYM IDF_WARNIFSKIP}\r\n IDF_NOREMOVABLEMEDIAPROMPT = $00001000;\r\n {$EXTERNALSYM IDF_NOREMOVABLEMEDIAPROMPT}\r\n IDF_USEDISKNAMEASPROMPT = $00002000;\r\n {$EXTERNALSYM IDF_USEDISKNAMEASPROMPT}\r\n IDF_OEMDISK = DWORD($80000000);\r\n {$EXTERNALSYM IDF_OEMDISK}\r\n\r\n//\r\n// Return values for SetupPromptForDisk, SetupCopyError,\r\n// SetupRenameError, SetupDeleteError, SetupBackupError\r\n//\r\nconst\r\n DPROMPT_SUCCESS = 0;\r\n {$EXTERNALSYM DPROMPT_SUCCESS}\r\n DPROMPT_CANCEL = 1;\r\n {$EXTERNALSYM DPROMPT_CANCEL}\r\n DPROMPT_SKIPFILE = 2;\r\n {$EXTERNALSYM DPROMPT_SKIPFILE}\r\n DPROMPT_BUFFERTOOSMALL = 3;\r\n {$EXTERNALSYM DPROMPT_BUFFERTOOSMALL}\r\n DPROMPT_OUTOFMEMORY = 4;\r\n {$EXTERNALSYM DPROMPT_OUTOFMEMORY}\r\n\r\n//\r\n// Flags for SetupSetDirectoryIdEx\r\n//\r\nconst\r\n SETDIRID_NOT_FULL_PATH = $00000001;\r\n {$EXTERNALSYM SETDIRID_NOT_FULL_PATH}\r\n\r\n//\r\n// InfoDesired values for SetupGetSourceInfo\r\n//\r\nconst\r\n SRCINFO_PATH = 1;\r\n {$EXTERNALSYM SRCINFO_PATH}\r\n SRCINFO_TAGFILE = 2;\r\n {$EXTERNALSYM SRCINFO_TAGFILE}\r\n SRCINFO_DESCRIPTION = 3;\r\n {$EXTERNALSYM SRCINFO_DESCRIPTION}\r\n SRCINFO_FLAGS = 4;\r\n {$EXTERNALSYM SRCINFO_FLAGS}\r\n // SRC_FLAGS allow special treatment of source\r\n // lower 4 bits are reserved for OS use\r\n // the flags may determine what other parameters exist\r\n //\r\n SRCINFO_TAGFILE2 = 5; // alternate tagfile, when SRCINFO_TAGFILE is a cabfile\r\n {$EXTERNALSYM SRCINFO_TAGFILE2}\r\n SRC_FLAGS_CABFILE = $0010; // if set, treat SRCINFO_TAGFILE as a cabfile and specify alternate tagfile\r\n {$EXTERNALSYM SRC_FLAGS_CABFILE}\r\n\r\n//\r\n// CopyStyle values for copy and queue-related APIs\r\n//\r\nconst\r\n SP_COPY_DELETESOURCE = $0000001; // delete source file on successful copy\r\n {$EXTERNALSYM SP_COPY_DELETESOURCE}\r\n SP_COPY_REPLACEONLY = $0000002; // copy only if target file already present\r\n {$EXTERNALSYM SP_COPY_REPLACEONLY}\r\n SP_COPY_NEWER = $0000004; // copy only if source newer than or same as target\r\n {$EXTERNALSYM SP_COPY_NEWER}\r\n SP_COPY_NEWER_OR_SAME = SP_COPY_NEWER;\r\n {$EXTERNALSYM SP_COPY_NEWER_OR_SAME}\r\n SP_COPY_NOOVERWRITE = $0000008; // copy only if target doesn't exist\r\n {$EXTERNALSYM SP_COPY_NOOVERWRITE}\r\n SP_COPY_NODECOMP = $0000010; // don't decompress source file while copying\r\n {$EXTERNALSYM SP_COPY_NODECOMP}\r\n SP_COPY_LANGUAGEAWARE = $0000020; // don't overwrite file of different language\r\n {$EXTERNALSYM SP_COPY_LANGUAGEAWARE}\r\n SP_COPY_SOURCE_ABSOLUTE = $0000040; // SourceFile is a full source path\r\n {$EXTERNALSYM SP_COPY_SOURCE_ABSOLUTE}\r\n SP_COPY_SOURCEPATH_ABSOLUTE = $0000080; // SourcePathRoot is the full path\r\n {$EXTERNALSYM SP_COPY_SOURCEPATH_ABSOLUTE}\r\n SP_COPY_IN_USE_NEEDS_REBOOT = $0000100; // System needs reboot if file in use\r\n {$EXTERNALSYM SP_COPY_IN_USE_NEEDS_REBOOT}\r\n SP_COPY_FORCE_IN_USE = $0000200; // Force target-in-use behavior\r\n {$EXTERNALSYM SP_COPY_FORCE_IN_USE}\r\n SP_COPY_NOSKIP = $0000400; // Skip is disallowed for this file or section\r\n {$EXTERNALSYM SP_COPY_NOSKIP}\r\n SP_FLAG_CABINETCONTINUATION = $0000800; // Used with need media notification\r\n {$EXTERNALSYM SP_FLAG_CABINETCONTINUATION}\r\n SP_COPY_FORCE_NOOVERWRITE = $0001000; // like NOOVERWRITE but no callback nofitication\r\n {$EXTERNALSYM SP_COPY_FORCE_NOOVERWRITE}\r\n SP_COPY_FORCE_NEWER = $0002000; // like NEWER but no callback nofitication\r\n {$EXTERNALSYM SP_COPY_FORCE_NEWER}\r\n SP_COPY_WARNIFSKIP = $0004000; // system critical file: warn if user tries to skip\r\n {$EXTERNALSYM SP_COPY_WARNIFSKIP}\r\n SP_COPY_NOBROWSE = $0008000; // Browsing is disallowed for this file or section\r\n {$EXTERNALSYM SP_COPY_NOBROWSE}\r\n SP_COPY_NEWER_ONLY = $0010000; // copy only if source file newer than target\r\n {$EXTERNALSYM SP_COPY_NEWER_ONLY}\r\n SP_COPY_SOURCE_SIS_MASTER = $0020000; // source is single-instance store master\r\n {$EXTERNALSYM SP_COPY_SOURCE_SIS_MASTER}\r\n SP_COPY_OEMINF_CATALOG_ONLY = $0040000; // (SetupCopyOEMInf only) don't copy INF--just catalog\r\n {$EXTERNALSYM SP_COPY_OEMINF_CATALOG_ONLY}\r\n SP_COPY_REPLACE_BOOT_FILE = $0080000; // file must be present upon reboot (i.e., it's\r\n {$EXTERNALSYM SP_COPY_REPLACE_BOOT_FILE}// needed by the loader); this flag implies a reboot\r\n SP_COPY_NOPRUNE = $0100000; // never prune this file\r\n {$EXTERNALSYM SP_COPY_NOPRUNE}\r\n SP_COPY_OEM_F6_INF = $0200000; // Used when calling SetupCopyOemInf\r\n {$EXTERNALSYM SP_COPY_OEM_F6_INF}\r\n //\r\n // Flags passed to Backup notification\r\n //\r\n SP_BACKUP_BACKUPPASS = $00000001; // file backed up during backup pass\r\n {$EXTERNALSYM SP_BACKUP_BACKUPPASS}\r\n SP_BACKUP_DEMANDPASS = $00000002; // file backed up on demand\r\n {$EXTERNALSYM SP_BACKUP_DEMANDPASS}\r\n SP_BACKUP_SPECIAL = $00000004; // if set, special type of backup\r\n {$EXTERNALSYM SP_BACKUP_SPECIAL}\r\n SP_BACKUP_BOOTFILE = $00000008; // file marked with COPYFLG_REPLACE_BOOT_FILE\r\n {$EXTERNALSYM SP_BACKUP_BOOTFILE}\r\n\r\n//\r\n// Define flags for SetupScanFileQueue.\r\n//\r\nconst\r\n SPQ_SCAN_FILE_PRESENCE = $00000001;\r\n {$EXTERNALSYM SPQ_SCAN_FILE_PRESENCE}\r\n SPQ_SCAN_FILE_VALIDITY = $00000002;\r\n {$EXTERNALSYM SPQ_SCAN_FILE_VALIDITY}\r\n SPQ_SCAN_USE_CALLBACK = $00000004;\r\n {$EXTERNALSYM SPQ_SCAN_USE_CALLBACK}\r\n SPQ_SCAN_USE_CALLBACKEX = $00000008;\r\n {$EXTERNALSYM SPQ_SCAN_USE_CALLBACKEX}\r\n SPQ_SCAN_INFORM_USER = $00000010;\r\n {$EXTERNALSYM SPQ_SCAN_INFORM_USER}\r\n SPQ_SCAN_PRUNE_COPY_QUEUE = $00000020;\r\n {$EXTERNALSYM SPQ_SCAN_PRUNE_COPY_QUEUE}\r\n SPQ_SCAN_USE_CALLBACK_SIGNERINFO = $00000040;\r\n {$EXTERNALSYM SPQ_SCAN_USE_CALLBACK_SIGNERINFO}\r\n SPQ_SCAN_PRUNE_DELREN = $00000080; // remote Delete/Rename queue\r\n {$EXTERNALSYM SPQ_SCAN_PRUNE_DELREN}\r\n\r\n//\r\n// Define flags used with Param2 for SPFILENOTIFY_QUEUESCAN\r\n//\r\n SPQ_DELAYED_COPY = $00000001; // file was in use; registered for delayed copy\r\n {$EXTERNALSYM SPQ_DELAYED_COPY}\r\n\r\n//\r\n// Flags/FlagMask for use with SetupSetFileQueueFlags and returned by SetupGetFileQueueFlags\r\n//\r\nconst\r\n SPQ_FLAG_BACKUP_AWARE = $00000001; // If set, SetupCommitFileQueue will\r\n {$EXTERNALSYM SPQ_FLAG_BACKUP_AWARE} // issue backup notifications.\r\n\r\n SPQ_FLAG_ABORT_IF_UNSIGNED = $00000002; // If set, SetupCommitFileQueue will\r\n {$EXTERNALSYM SPQ_FLAG_ABORT_IF_UNSIGNED}// fail with ERROR_SET_SYSTEM_RESTORE_POINT\r\n // if the user elects to proceed with an\r\n // unsigned queue committal. This allows\r\n // the caller to set a system restore point,\r\n // then re-commit the file queue.\r\n\r\n SPQ_FLAG_FILES_MODIFIED = $00000004; // If set, at least one file was\r\n {$EXTERNALSYM SPQ_FLAG_FILES_MODIFIED} // replaced by a different version\r\n\r\n SPQ_FLAG_VALID = $00000007; // mask of valid flags (can be passed as FlagMask)\r\n {$EXTERNALSYM SPQ_FLAG_VALID}\r\n\r\n//\r\n// Define OEM Source Type values for use in SetupCopyOEMInf.\r\n//\r\n SPOST_NONE = 0;\r\n {$EXTERNALSYM SPOST_NONE}\r\n SPOST_PATH = 1;\r\n {$EXTERNALSYM SPOST_PATH}\r\n SPOST_URL = 2;\r\n {$EXTERNALSYM SPOST_URL}\r\n SPOST_MAX = 3;\r\n {$EXTERNALSYM SPOST_MAX}\r\n\r\n//\r\n// Flags used by SetupUninstallOEMInf\r\n//\r\n SUOI_FORCEDELETE = $00000001;\r\n {$IFDEF COMPILER11_UP}\r\n {$EXTERNALSYM SUOI_FORCEDELETE}\r\n {$ENDIF COMPILER11_UP}\r\n//\r\n// Flags for SetupCreateDiskSpaceList\r\n//\r\nconst\r\n SPDSL_IGNORE_DISK = $00000001; // ignore deletes and on-disk files in copies\r\n {$EXTERNALSYM SPDSL_IGNORE_DISK}\r\n SPDSL_DISALLOW_NEGATIVE_ADJUST = $00000002;\r\n {$EXTERNALSYM SPDSL_DISALLOW_NEGATIVE_ADJUST}\r\n\r\n//\r\n// Define flags that are returned by SetupPromptReboot\r\n//\r\nconst\r\n SPFILEQ_FILE_IN_USE = $00000001;\r\n {$EXTERNALSYM SPFILEQ_FILE_IN_USE}\r\n SPFILEQ_REBOOT_RECOMMENDED = $00000002;\r\n {$EXTERNALSYM SPFILEQ_REBOOT_RECOMMENDED}\r\n SPFILEQ_REBOOT_IN_PROGRESS = $00000004;\r\n {$EXTERNALSYM SPFILEQ_REBOOT_IN_PROGRESS}\r\n\r\n//\r\n// Flags for AddReg section lines in INF. The corresponding value\r\n// is in the AddReg line format given below:\r\n//\r\n// ,,,,...\r\n//\r\n// The low word contains basic flags concerning the general data type\r\n// and AddReg action. The high word contains values that more specifically\r\n// identify the data type of the registry value. The high word is ignored\r\n// by the 16-bit Windows 95 SETUPX APIs.\r\n//\r\n// If has FLG_ADDREG_DELREG_BIT set, it will be ignored by AddReg\r\n// (not supported by SetupX).\r\n//\r\nconst\r\n FLG_ADDREG_DELREG_BIT = $00008000; // if set, interpret as DELREG, see below\r\n {$EXTERNALSYM FLG_ADDREG_DELREG_BIT}\r\n FLG_ADDREG_BINVALUETYPE = $00000001;\r\n {$EXTERNALSYM FLG_ADDREG_BINVALUETYPE}\r\n FLG_ADDREG_NOCLOBBER = $00000002;\r\n {$EXTERNALSYM FLG_ADDREG_NOCLOBBER}\r\n FLG_ADDREG_DELVAL = $00000004;\r\n {$EXTERNALSYM FLG_ADDREG_DELVAL}\r\n FLG_ADDREG_APPEND = $00000008; // Currently supported only\r\n {$EXTERNALSYM FLG_ADDREG_APPEND} // for REG_MULTI_SZ values.\r\n FLG_ADDREG_KEYONLY = $00000010; // Just create the key, ignore value\r\n {$EXTERNALSYM FLG_ADDREG_KEYONLY}\r\n FLG_ADDREG_OVERWRITEONLY = $00000020; // Set only if value already exists\r\n {$EXTERNALSYM FLG_ADDREG_OVERWRITEONLY}\r\n FLG_ADDREG_64BITKEY = $00001000; // make this change in the 64 bit registry.\r\n {$EXTERNALSYM FLG_ADDREG_64BITKEY}\r\n FLG_ADDREG_KEYONLY_COMMON = $00002000; // same as FLG_ADDREG_KEYONLY but also works for DELREG\r\n {$EXTERNALSYM FLG_ADDREG_KEYONLY_COMMON}\r\n FLG_ADDREG_32BITKEY = $00004000; // make this change in the 32 bit registry.\r\n {$EXTERNALSYM FLG_ADDREG_32BITKEY}\r\n //\r\n // The INF may supply any arbitrary data type ordinal in the highword except\r\n // for the following: REG_NONE, REG_SZ, REG_EXPAND_SZ, REG_MULTI_SZ. If this\r\n // technique is used, then the data is given in binary format, one byte per\r\n // field.\r\n //\r\n FLG_ADDREG_TYPE_MASK = DWORD($FFFF0000 or FLG_ADDREG_BINVALUETYPE);\r\n {$EXTERNALSYM FLG_ADDREG_TYPE_MASK}\r\n FLG_ADDREG_TYPE_SZ = $00000000;\r\n {$EXTERNALSYM FLG_ADDREG_TYPE_SZ}\r\n FLG_ADDREG_TYPE_MULTI_SZ = $00010000;\r\n {$EXTERNALSYM FLG_ADDREG_TYPE_MULTI_SZ}\r\n FLG_ADDREG_TYPE_EXPAND_SZ = $00020000;\r\n {$EXTERNALSYM FLG_ADDREG_TYPE_EXPAND_SZ}\r\n FLG_ADDREG_TYPE_BINARY = $00000000 or FLG_ADDREG_BINVALUETYPE;\r\n {$EXTERNALSYM FLG_ADDREG_TYPE_BINARY}\r\n FLG_ADDREG_TYPE_DWORD = $00010000 or FLG_ADDREG_BINVALUETYPE;\r\n {$EXTERNALSYM FLG_ADDREG_TYPE_DWORD}\r\n FLG_ADDREG_TYPE_NONE = $00020000 or FLG_ADDREG_BINVALUETYPE;\r\n {$EXTERNALSYM FLG_ADDREG_TYPE_NONE}\r\n\r\n //\r\n // Flags for DelReg section lines in INF. The corresponding value\r\n // is in the extended DelReg line format given below:\r\n //\r\n // ,,,[,...]\r\n //\r\n // In SetupX and some versions of SetupAPI, will be ignored and will\r\n // be deleted. Use with care.\r\n //\r\n // The bits determined by mask FLG_DELREG_TYPE_MASK indicates type of data expected.\r\n // must have FLG_ADDREG_DELREG_BIT set, otherwise it is ignored and specified\r\n // value will be deleted (allowing an AddReg section to also be used as a DelReg section)\r\n // if is not specified, will be deleted (if specified) otherwise\r\n // will be deleted.\r\n //\r\n // the compatability flag\r\n //\r\n FLG_DELREG_VALUE = $00000000;\r\n {$EXTERNALSYM FLG_DELREG_VALUE}\r\n\r\n FLG_DELREG_TYPE_MASK = FLG_ADDREG_TYPE_MASK; // 0xFFFF0001\r\n {$EXTERNALSYM FLG_DELREG_TYPE_MASK}\r\n FLG_DELREG_TYPE_SZ = FLG_ADDREG_TYPE_SZ; // 0x00000000\r\n {$EXTERNALSYM FLG_DELREG_TYPE_SZ}\r\n FLG_DELREG_TYPE_MULTI_SZ = FLG_ADDREG_TYPE_MULTI_SZ; // 0x00010000\r\n {$EXTERNALSYM FLG_DELREG_TYPE_MULTI_SZ}\r\n FLG_DELREG_TYPE_EXPAND_SZ = FLG_ADDREG_TYPE_EXPAND_SZ; // 0x00020000\r\n {$EXTERNALSYM FLG_DELREG_TYPE_EXPAND_SZ}\r\n FLG_DELREG_TYPE_BINARY = FLG_ADDREG_TYPE_BINARY; // 0x00000001\r\n {$EXTERNALSYM FLG_DELREG_TYPE_BINARY}\r\n FLG_DELREG_TYPE_DWORD = FLG_ADDREG_TYPE_DWORD; // 0x00010001\r\n {$EXTERNALSYM FLG_DELREG_TYPE_DWORD}\r\n FLG_DELREG_TYPE_NONE = FLG_ADDREG_TYPE_NONE; // 0x00020001\r\n {$EXTERNALSYM FLG_DELREG_TYPE_NONE}\r\n FLG_DELREG_64BITKEY = FLG_ADDREG_64BITKEY; // 0x00001000\r\n {$EXTERNALSYM FLG_DELREG_64BITKEY}\r\n FLG_DELREG_KEYONLY_COMMON = FLG_ADDREG_KEYONLY_COMMON; // 0x00002000\r\n {$EXTERNALSYM FLG_DELREG_KEYONLY_COMMON}\r\n FLG_DELREG_32BITKEY = FLG_ADDREG_32BITKEY; // 0x00004000\r\n {$EXTERNALSYM FLG_DELREG_32BITKEY}\r\n\r\n //\r\n // = FLG_DELREG_MULTI_SZ_DELSTRING\r\n // ,,,0x00018002,\r\n // removes all entries matching (case ignored) from multi-sz registry value\r\n //\r\n FLG_DELREG_OPERATION_MASK = $000000FE;\r\n {$EXTERNALSYM FLG_DELREG_OPERATION_MASK}\r\n FLG_DELREG_MULTI_SZ_DELSTRING = FLG_DELREG_TYPE_MULTI_SZ or FLG_ADDREG_DELREG_BIT or $00000002; // 0x00018002\r\n {$EXTERNALSYM FLG_DELREG_MULTI_SZ_DELSTRING}\r\n\r\n//\r\n// Flags for BitReg section lines in INF.\r\n//\r\n FLG_BITREG_CLEARBITS = $00000000;\r\n {$EXTERNALSYM FLG_BITREG_CLEARBITS}\r\n FLG_BITREG_SETBITS = $00000001;\r\n {$EXTERNALSYM FLG_BITREG_SETBITS}\r\n FLG_BITREG_64BITKEY = $00001000;\r\n {$EXTERNALSYM FLG_BITREG_64BITKEY}\r\n FLG_BITREG_32BITKEY = $00004000;\r\n {$EXTERNALSYM FLG_BITREG_32BITKEY}\r\n\r\n//\r\n// Flags for Ini2Reg section lines in INF.\r\n//\r\n FLG_INI2REG_64BITKEY = $00001000;\r\n {$EXTERNALSYM FLG_INI2REG_64BITKEY}\r\n FLG_INI2REG_32BITKEY = $00004000;\r\n {$EXTERNALSYM FLG_INI2REG_32BITKEY}\r\n\r\n//\r\n// Flags for RegSvr section lines in INF\r\n//\r\n FLG_REGSVR_DLLREGISTER = $00000001;\r\n {$EXTERNALSYM FLG_REGSVR_DLLREGISTER}\r\n FLG_REGSVR_DLLINSTALL = $00000002;\r\n {$EXTERNALSYM FLG_REGSVR_DLLINSTALL}\r\n\r\n// Flags for RegSvr section lines in INF\r\n//\r\n FLG_PROFITEM_CURRENTUSER = $00000001;\r\n {$EXTERNALSYM FLG_PROFITEM_CURRENTUSER}\r\n FLG_PROFITEM_DELETE = $00000002;\r\n {$EXTERNALSYM FLG_PROFITEM_DELETE}\r\n FLG_PROFITEM_GROUP = $00000004;\r\n {$EXTERNALSYM FLG_PROFITEM_GROUP}\r\n FLG_PROFITEM_CSIDL = $00000008;\r\n {$EXTERNALSYM FLG_PROFITEM_CSIDL}\r\n\r\n//\r\n// Flags for SetupInstallFromInfSection\r\n//\r\nconst\r\n SPINST_LOGCONFIG = $00000001;\r\n {$EXTERNALSYM SPINST_LOGCONFIG}\r\n SPINST_INIFILES = $00000002;\r\n {$EXTERNALSYM SPINST_INIFILES}\r\n SPINST_REGISTRY = $00000004;\r\n {$EXTERNALSYM SPINST_REGISTRY}\r\n SPINST_INI2REG = $00000008;\r\n {$EXTERNALSYM SPINST_INI2REG}\r\n SPINST_FILES = $00000010;\r\n {$EXTERNALSYM SPINST_FILES}\r\n SPINST_BITREG = $00000020;\r\n {$EXTERNALSYM SPINST_BITREG}\r\n SPINST_REGSVR = $00000040;\r\n {$EXTERNALSYM SPINST_REGSVR}\r\n SPINST_UNREGSVR = $00000080;\r\n {$EXTERNALSYM SPINST_UNREGSVR}\r\n SPINST_PROFILEITEMS = $00000100;\r\n {$EXTERNALSYM SPINST_PROFILEITEMS}\r\n {$IFDEF WINXP_UP}\r\n SPINST_COPYINF = $00000200;\r\n {$EXTERNALSYM SPINST_COPYINF}\r\n SPINST_ALL = $000003ff;\r\n {$EXTERNALSYM SPINST_ALL}\r\n {$ELSE}\r\n SPINST_ALL = $000001ff;\r\n {$EXTERNALSYM SPINST_ALL}\r\n {$ENDIF WINXP_UP}\r\n SPINST_SINGLESECTION = $00010000;\r\n {$EXTERNALSYM SPINST_SINGLESECTION}\r\n SPINST_LOGCONFIG_IS_FORCED = $00020000;\r\n {$EXTERNALSYM SPINST_LOGCONFIG_IS_FORCED}\r\n SPINST_LOGCONFIGS_ARE_OVERRIDES = $00040000;\r\n {$EXTERNALSYM SPINST_LOGCONFIGS_ARE_OVERRIDES}\r\n SPINST_REGISTERCALLBACKAWARE = $00080000;\r\n {$EXTERNALSYM SPINST_REGISTERCALLBACKAWARE}\r\n\r\n//\r\n// Flags for SetupInstallServicesFromInfSection(Ex). These flags are also used\r\n// in the flags field of AddService or DelService lines in a device INF. Some\r\n// of these flags are not permitted in the non-Ex API. These flags are marked\r\n// as such below.\r\n//\r\n\r\n//\r\n// (AddService) move service's tag to front of its group order list\r\n//\r\nconst\r\n SPSVCINST_TAGTOFRONT = $00000001;\r\n {$EXTERNALSYM SPSVCINST_TAGTOFRONT}\r\n\r\n//\r\n// (AddService) **Ex API only** mark this service as the function driver for the\r\n// device being installed\r\n//\r\n SPSVCINST_ASSOCSERVICE = $00000002;\r\n {$EXTERNALSYM SPSVCINST_ASSOCSERVICE}\r\n\r\n//\r\n// (DelService) delete the associated event log entry for a service specified in\r\n// a DelService entry\r\n//\r\n SPSVCINST_DELETEEVENTLOGENTRY = $00000004;\r\n {$EXTERNALSYM SPSVCINST_DELETEEVENTLOGENTRY}\r\n\r\n//\r\n// (AddService) don't overwrite display name if it already exists\r\n//\r\n SPSVCINST_NOCLOBBER_DISPLAYNAME = $00000008;\r\n {$EXTERNALSYM SPSVCINST_NOCLOBBER_DISPLAYNAME}\r\n\r\n//\r\n// (AddService) don't overwrite start type value if service already exists\r\n//\r\n SPSVCINST_NOCLOBBER_STARTTYPE = $00000010;\r\n {$EXTERNALSYM SPSVCINST_NOCLOBBER_STARTTYPE}\r\n\r\n//\r\n// (AddService) don't overwrite error control value if service already exists\r\n//\r\n SPSVCINST_NOCLOBBER_ERRORCONTROL = $00000020;\r\n {$EXTERNALSYM SPSVCINST_NOCLOBBER_ERRORCONTROL}\r\n\r\n//\r\n// (AddService) don't overwrite load order group if it already exists\r\n//\r\n SPSVCINST_NOCLOBBER_LOADORDERGROUP = $00000040;\r\n {$EXTERNALSYM SPSVCINST_NOCLOBBER_LOADORDERGROUP}\r\n\r\n//\r\n// (AddService) don't overwrite dependencies list if it already exists\r\n//\r\n SPSVCINST_NOCLOBBER_DEPENDENCIES = $00000080;\r\n {$EXTERNALSYM SPSVCINST_NOCLOBBER_DEPENDENCIES}\r\n\r\n//\r\n// (AddService) don't overwrite description if it already exists\r\n//\r\n SPSVCINST_NOCLOBBER_DESCRIPTION = $00000100;\r\n {$EXTERNALSYM SPSVCINST_NOCLOBBER_DESCRIPTION}\r\n\r\n//\r\n// (DelService) stop the associated service specified in\r\n// a DelService entry before deleting the service\r\n//\r\n SPSVCINST_STOPSERVICE = $00000200;\r\n {$EXTERNALSYM SPSVCINST_STOPSERVICE}\r\n\r\n//\r\n// (AddService) force overwrite of security settings\r\n//\r\n SPSVCINST_CLOBBER_SECURITY = $00000400;\r\n {$EXTERNALSYM SPSVCINST_CLOBBER_SECURITY}\r\n\r\n//\r\n// Flags for SetupInitializeFileLog\r\n//\r\nconst\r\n SPFILELOG_SYSTEMLOG = $00000001; // use system log -- must be Administrator\r\n {$EXTERNALSYM SPFILELOG_SYSTEMLOG}\r\n SPFILELOG_FORCENEW = $00000002; // not valid with SPFILELOG_SYSTEMLOG\r\n {$EXTERNALSYM SPFILELOG_FORCENEW}\r\n SPFILELOG_QUERYONLY = $00000004; // allows non-administrators to read system log\r\n {$EXTERNALSYM SPFILELOG_QUERYONLY}\r\n\r\n//\r\n// Flags for SetupLogFile\r\n//\r\nconst\r\n SPFILELOG_OEMFILE = $00000001;\r\n {$EXTERNALSYM SPFILELOG_OEMFILE}\r\n\r\n//\r\n// Items retrievable from SetupQueryFileLog()\r\n//\r\nconst\r\n SetupFileLogSourceFilename = $00000000;\r\n {$EXTERNALSYM SetupFileLogSourceFilename}\r\n SetupFileLogChecksum = $00000001;\r\n {$EXTERNALSYM SetupFileLogChecksum}\r\n SetupFileLogDiskTagfile = $00000002;\r\n {$EXTERNALSYM SetupFileLogDiskTagfile}\r\n SetupFileLogDiskDescription = $00000003;\r\n {$EXTERNALSYM SetupFileLogDiskDescription}\r\n SetupFileLogOtherInfo = $00000004;\r\n {$EXTERNALSYM SetupFileLogOtherInfo}\r\n SetupFileLogMax = $00000005;\r\n {$EXTERNALSYM SetupFileLogMax}\r\ntype\r\n SetupFileLogInfo = DWORD;\r\n {$EXTERNALSYM SetupFileLogInfo}\r\n\r\nconst\r\n LogSevInformation = $00000000;\r\n {$EXTERNALSYM LogSevInformation}\r\n LogSevWarning = $00000001;\r\n {$EXTERNALSYM LogSevWarning}\r\n LogSevError = $00000002;\r\n {$EXTERNALSYM LogSevError}\r\n LogSevFatalError = $00000003;\r\n {$EXTERNALSYM LogSevFatalError}\r\n LogSevMaximum = $00000004;\r\n {$EXTERNALSYM LogSevMaximum}\r\ntype\r\n LogSeverity = DWORD;\r\n {$EXTERNALSYM LogSeverity}\r\n\r\n//\r\n// Flags for SetupDiCreateDeviceInfo\r\n//\r\nconst\r\n DICD_GENERATE_ID = $00000001;\r\n {$EXTERNALSYM DICD_GENERATE_ID}\r\n DICD_INHERIT_CLASSDRVS = $00000002;\r\n {$EXTERNALSYM DICD_INHERIT_CLASSDRVS}\r\n\r\n//\r\n// Flags for SetupDiOpenDeviceInfo\r\n//\r\nconst\r\n DIOD_INHERIT_CLASSDRVS = $00000002;\r\n {$EXTERNALSYM DIOD_INHERIT_CLASSDRVS}\r\n DIOD_CANCEL_REMOVE = $00000004;\r\n {$EXTERNALSYM DIOD_CANCEL_REMOVE}\r\n\r\n//\r\n// Flags for SetupDiOpenDeviceInterface\r\n//\r\nconst\r\n DIODI_NO_ADD = $00000001;\r\n {$EXTERNALSYM DIODI_NO_ADD}\r\n\r\n//\r\n// Flags for SetupDiRegisterDeviceInfo\r\n//\r\nconst\r\n SPRDI_FIND_DUPS = $00000001;\r\n {$EXTERNALSYM SPRDI_FIND_DUPS}\r\n\r\n//\r\n// Ordinal values distinguishing between class drivers and\r\n// device drivers.\r\n// (Passed in 'DriverType' parameter of driver information list APIs)\r\n//\r\nconst\r\n SPDIT_NODRIVER = $00000000;\r\n {$EXTERNALSYM SPDIT_NODRIVER}\r\n SPDIT_CLASSDRIVER = $00000001;\r\n {$EXTERNALSYM SPDIT_CLASSDRIVER}\r\n SPDIT_COMPATDRIVER = $00000002;\r\n {$EXTERNALSYM SPDIT_COMPATDRIVER}\r\n\r\n//\r\n// Flags controlling what is included in the device information set built\r\n// by SetupDiGetClassDevs\r\n//\r\nconst\r\n DIGCF_DEFAULT = $00000001; // only valid with DIGCF_DEVICEINTERFACE\r\n {$EXTERNALSYM DIGCF_DEFAULT}\r\n DIGCF_PRESENT = $00000002;\r\n {$EXTERNALSYM DIGCF_PRESENT}\r\n DIGCF_ALLCLASSES = $00000004;\r\n {$EXTERNALSYM DIGCF_ALLCLASSES}\r\n DIGCF_PROFILE = $00000008;\r\n {$EXTERNALSYM DIGCF_PROFILE}\r\n DIGCF_DEVICEINTERFACE = $00000010;\r\n {$EXTERNALSYM DIGCF_DEVICEINTERFACE}\r\n\r\n//\r\n// Backward compatibility--do not use.\r\n//\r\n\r\nconst\r\n DIGCF_INTERFACEDEVICE = DIGCF_DEVICEINTERFACE;\r\n{$EXTERNALSYM DIGCF_INTERFACEDEVICE}\r\n\r\n//\r\n// Flags controlling exclusion from the class information list built\r\n// by SetupDiBuildClassInfoList(Ex)\r\n//\r\nconst\r\n DIBCI_NOINSTALLCLASS = $00000001;\r\n {$EXTERNALSYM DIBCI_NOINSTALLCLASS}\r\n DIBCI_NODISPLAYCLASS = $00000002;\r\n {$EXTERNALSYM DIBCI_NODISPLAYCLASS}\r\n\r\n//\r\n// Flags for SetupDiOpenClassRegKeyEx\r\n//\r\nconst\r\n DIOCR_INSTALLER = $00000001; // class installer registry branch\r\n {$EXTERNALSYM DIOCR_INSTALLER}\r\n DIOCR_INTERFACE = $00000002; // interface class registry branch\r\n {$EXTERNALSYM DIOCR_INTERFACE}\r\n\r\n//\r\n// KeyType values for SetupDiCreateDevRegKey, SetupDiOpenDevRegKey, and\r\n// SetupDiDeleteDevRegKey.\r\n//\r\nconst\r\n DIREG_DEV = $00000001; // Open/Create/Delete device key\r\n {$EXTERNALSYM DIREG_DEV}\r\n DIREG_DRV = $00000002; // Open/Create/Delete driver key\r\n {$EXTERNALSYM DIREG_DRV}\r\n DIREG_BOTH = $00000004; // Delete both driver and Device key\r\n {$EXTERNALSYM DIREG_BOTH}\r\n\r\n//\r\n// Device registry property codes\r\n// (Codes marked as read-only (R) may only be used for\r\n// SetupDiGetDeviceRegistryProperty)\r\n//\r\n// These values should cover the same set of registry properties\r\n// as defined by the CM_DRP codes in cfgmgr32.h.\r\n//\r\n// Note that SPDRP codes are zero based while CM_DRP codes are one based!\r\n//\r\nconst\r\n SPDRP_DEVICEDESC = $00000000; // DeviceDesc (R/W)\r\n {$EXTERNALSYM SPDRP_DEVICEDESC}\r\n SPDRP_HARDWAREID = $00000001; // HardwareID (R/W)\r\n {$EXTERNALSYM SPDRP_HARDWAREID}\r\n SPDRP_COMPATIBLEIDS = $00000002; // CompatibleIDs (R/W)\r\n {$EXTERNALSYM SPDRP_COMPATIBLEIDS}\r\n SPDRP_UNUSED0 = $00000003; // unused\r\n {$EXTERNALSYM SPDRP_UNUSED0}\r\n SPDRP_SERVICE = $00000004; // Service (R/W)\r\n {$EXTERNALSYM SPDRP_SERVICE}\r\n SPDRP_UNUSED1 = $00000005; // unused\r\n {$EXTERNALSYM SPDRP_UNUSED1}\r\n SPDRP_UNUSED2 = $00000006; // unused\r\n {$EXTERNALSYM SPDRP_UNUSED2}\r\n SPDRP_CLASS = $00000007; // Class (R--tied to ClassGUID)\r\n {$EXTERNALSYM SPDRP_CLASS}\r\n SPDRP_CLASSGUID = $00000008; // ClassGUID (R/W)\r\n {$EXTERNALSYM SPDRP_CLASSGUID}\r\n SPDRP_DRIVER = $00000009; // Driver (R/W)\r\n {$EXTERNALSYM SPDRP_DRIVER}\r\n SPDRP_CONFIGFLAGS = $0000000A; // ConfigFlags (R/W)\r\n {$EXTERNALSYM SPDRP_CONFIGFLAGS}\r\n SPDRP_MFG = $0000000B; // Mfg (R/W)\r\n {$EXTERNALSYM SPDRP_MFG}\r\n SPDRP_FRIENDLYNAME = $0000000C; // FriendlyName (R/W)\r\n {$EXTERNALSYM SPDRP_FRIENDLYNAME}\r\n SPDRP_LOCATION_INFORMATION = $0000000D; // LocationInformation (R/W)\r\n {$EXTERNALSYM SPDRP_LOCATION_INFORMATION}\r\n SPDRP_PHYSICAL_DEVICE_OBJECT_NAME = $0000000E; // PhysicalDeviceObjectName (R)\r\n {$EXTERNALSYM SPDRP_PHYSICAL_DEVICE_OBJECT_NAME}\r\n SPDRP_CAPABILITIES = $0000000F; // Capabilities (R)\r\n {$EXTERNALSYM SPDRP_CAPABILITIES}\r\n SPDRP_UI_NUMBER = $00000010; // UiNumber (R)\r\n {$EXTERNALSYM SPDRP_UI_NUMBER}\r\n SPDRP_UPPERFILTERS = $00000011; // UpperFilters (R/W)\r\n {$EXTERNALSYM SPDRP_UPPERFILTERS}\r\n SPDRP_LOWERFILTERS = $00000012; // LowerFilters (R/W)\r\n {$EXTERNALSYM SPDRP_LOWERFILTERS}\r\n SPDRP_BUSTYPEGUID = $00000013; // BusTypeGUID (R)\r\n {$EXTERNALSYM SPDRP_BUSTYPEGUID}\r\n SPDRP_LEGACYBUSTYPE = $00000014; // LegacyBusType (R)\r\n {$EXTERNALSYM SPDRP_LEGACYBUSTYPE}\r\n SPDRP_BUSNUMBER = $00000015; // BusNumber (R)\r\n {$EXTERNALSYM SPDRP_BUSNUMBER}\r\n SPDRP_ENUMERATOR_NAME = $00000016; // Enumerator Name (R)\r\n {$EXTERNALSYM SPDRP_ENUMERATOR_NAME}\r\n SPDRP_SECURITY = $00000017; // Security (R/W, binary form)\r\n {$EXTERNALSYM SPDRP_SECURITY}\r\n SPDRP_SECURITY_SDS = $00000018; // Security (W, SDS form)\r\n {$EXTERNALSYM SPDRP_SECURITY_SDS}\r\n SPDRP_DEVTYPE = $00000019; // Device Type (R/W)\r\n {$EXTERNALSYM SPDRP_DEVTYPE}\r\n SPDRP_EXCLUSIVE = $0000001A; // Device is exclusive-access (R/W)\r\n {$EXTERNALSYM SPDRP_EXCLUSIVE}\r\n SPDRP_CHARACTERISTICS = $0000001B; // Device Characteristics (R/W)\r\n {$EXTERNALSYM SPDRP_CHARACTERISTICS}\r\n SPDRP_ADDRESS = $0000001C; // Device Address (R)\r\n {$EXTERNALSYM SPDRP_ADDRESS}\r\n {$IFDEF WINXP_UP}\r\n SPDRP_UI_NUMBER_DESC_FORMAT = $0000001D; // UiNumberDescFormat (R/W)\r\n {$EXTERNALSYM SPDRP_UI_NUMBER_DESC_FORMAT}\r\n SPDRP_DEVICE_POWER_DATA = $0000001E; // Device Power Data (R)\r\n {$EXTERNALSYM SPDRP_DEVICE_POWER_DATA}\r\n SPDRP_REMOVAL_POLICY = $0000001F; // Removal Policy (R)\r\n {$EXTERNALSYM SPDRP_REMOVAL_POLICY}\r\n SPDRP_REMOVAL_POLICY_HW_DEFAULT = $00000020; // Hardware Removal Policy (R)\r\n {$EXTERNALSYM SPDRP_REMOVAL_POLICY_HW_DEFAULT}\r\n SPDRP_REMOVAL_POLICY_OVERRIDE = $00000021; // Removal Policy Override (RW)\r\n {$EXTERNALSYM SPDRP_REMOVAL_POLICY_OVERRIDE}\r\n SPDRP_INSTALL_STATE = $00000022; // Device Install State (R)\r\n {$EXTERNALSYM SPDRP_INSTALL_STATE}\r\n\r\n SPDRP_MAXIMUM_PROPERTY = $00000023; // Upper bound on ordinals\r\n {$EXTERNALSYM SPDRP_MAXIMUM_PROPERTY}\r\n {$ELSE}\r\n SPDRP_UI_NUMBER_DESC_FORMAT = $0000001E; // UiNumberDescFormat (R/W)\r\n {$EXTERNALSYM SPDRP_UI_NUMBER_DESC_FORMAT}\r\n SPDRP_MAXIMUM_PROPERTY = $0000001F; // Upper bound on ordinals\r\n {$EXTERNALSYM SPDRP_MAXIMUM_PROPERTY}\r\n {$ENDIF WINXP_UP}\r\n//\r\n// Class registry property codes\r\n// (Codes marked as read-only (R) may only be used for\r\n// SetupDiGetClassRegistryProperty)\r\n//\r\n// These values should cover the same set of registry properties\r\n// as defined by the CM_CRP codes in cfgmgr32.h.\r\n// they should also have a 1:1 correspondence with Device registers, where applicable\r\n// but no overlap otherwise\r\n//\r\n SPCRP_SECURITY = $00000017; // Security (R/W, binary form)\r\n {$EXTERNALSYM SPCRP_SECURITY}\r\n SPCRP_SECURITY_SDS = $00000018; // Security (W, SDS form)\r\n {$EXTERNALSYM SPCRP_SECURITY_SDS}\r\n SPCRP_DEVTYPE = $00000019; // Device Type (R/W)\r\n {$EXTERNALSYM SPCRP_DEVTYPE}\r\n SPCRP_EXCLUSIVE = $0000001A; // Device is exclusive-access (R/W)\r\n {$EXTERNALSYM SPCRP_EXCLUSIVE}\r\n SPCRP_CHARACTERISTICS = $0000001B; // Device Characteristics (R/W)\r\n {$EXTERNALSYM SPCRP_CHARACTERISTICS}\r\n SPCRP_MAXIMUM_PROPERTY = $0000001C; // Upper bound on ordinals\r\n {$EXTERNALSYM SPCRP_MAXIMUM_PROPERTY}\r\n\r\n//\r\n// Flags controlling the drawing of mini-icons\r\n//\r\nconst\r\n DMI_MASK = $00000001;\r\n {$EXTERNALSYM DMI_MASK}\r\n DMI_BKCOLOR = $00000002;\r\n {$EXTERNALSYM DMI_BKCOLOR}\r\n DMI_USERECT = $00000004;\r\n {$EXTERNALSYM DMI_USERECT}\r\n\r\n//\r\n// PropertySheetType values for the SetupDiGetClassDevPropertySheets API\r\n//\r\nconst\r\n DIGCDP_FLAG_BASIC = $00000001;\r\n {$EXTERNALSYM DIGCDP_FLAG_BASIC}\r\n DIGCDP_FLAG_ADVANCED = $00000002;\r\n {$EXTERNALSYM DIGCDP_FLAG_ADVANCED}\r\n DIGCDP_FLAG_REMOTE_BASIC = $00000003;\r\n {$EXTERNALSYM DIGCDP_FLAG_REMOTE_BASIC}\r\n DIGCDP_FLAG_REMOTE_ADVANCED = $00000004;\r\n {$EXTERNALSYM DIGCDP_FLAG_REMOTE_ADVANCED}\r\n\r\n//\r\n// Define ICON IDs publicly exposed from setupapi.\r\n//\r\nconst\r\n IDI_RESOURCEFIRST = 159;\r\n {$EXTERNALSYM IDI_RESOURCEFIRST}\r\n IDI_RESOURCE = 159;\r\n {$EXTERNALSYM IDI_RESOURCE}\r\n IDI_RESOURCELAST = 161;\r\n {$EXTERNALSYM IDI_RESOURCELAST}\r\n IDI_RESOURCEOVERLAYFIRST = 161;\r\n {$EXTERNALSYM IDI_RESOURCEOVERLAYFIRST}\r\n IDI_RESOURCEOVERLAYLAST = 161;\r\n {$EXTERNALSYM IDI_RESOURCEOVERLAYLAST}\r\n IDI_CONFLICT = 161;\r\n {$EXTERNALSYM IDI_CONFLICT}\r\n\r\n IDI_CLASSICON_OVERLAYFIRST = 500;\r\n {$EXTERNALSYM IDI_CLASSICON_OVERLAYFIRST}\r\n IDI_CLASSICON_OVERLAYLAST = 502;\r\n {$EXTERNALSYM IDI_CLASSICON_OVERLAYLAST}\r\n IDI_PROBLEM_OVL = 500;\r\n {$EXTERNALSYM IDI_PROBLEM_OVL}\r\n IDI_DISABLED_OVL = 501;\r\n {$EXTERNALSYM IDI_DISABLED_OVL}\r\n IDI_FORCED_OVL = 502;\r\n {$EXTERNALSYM IDI_FORCED_OVL}\r\n\r\n//\r\n// PageType values for SetupDiGetWizardPage API\r\n//\r\nconst\r\n SPWPT_SELECTDEVICE = $00000001;\r\n {$EXTERNALSYM SPWPT_SELECTDEVICE}\r\n\r\n//\r\n// Flags for SetupDiGetWizardPage API\r\n//\r\n SPWP_USE_DEVINFO_DATA = $00000001;\r\n{$EXTERNALSYM SPWP_USE_DEVINFO_DATA}\r\n\r\n{$IFDEF WINXP_UP}\r\ntype\r\n PSP_INF_SIGNER_INFO_A = ^SP_INF_SIGNER_INFO_A;\r\n {$EXTERNALSYM PSP_INF_SIGNER_INFO_A}\r\n SP_INF_SIGNER_INFO_A = packed record\r\n cbSize: DWORD;\r\n CatalogFile: array [0..MAX_PATH - 1] of Char;\r\n DigitalSigner: array [0..MAX_PATH - 1] of Char;\r\n DigitalSignerVersion: array [0..MAX_PATH - 1] of Char;\r\n end;\r\n {$EXTERNALSYM SP_INF_SIGNER_INFO_A}\r\n\r\n PSP_INF_SIGNER_INFO_W = ^SP_INF_SIGNER_INFO_W;\r\n {$EXTERNALSYM PSP_INF_SIGNER_INFO_A}\r\n SP_INF_SIGNER_INFO_W = packed record\r\n cbSize: DWORD;\r\n CatalogFile: array [0..MAX_PATH - 1] of WideChar;\r\n DigitalSigner: array [0..MAX_PATH - 1] of WideChar;\r\n DigitalSignerVersion: array [0..MAX_PATH - 1] of WideChar;\r\n end;\r\n {$EXTERNALSYM SP_INF_SIGNER_INFO_W}\r\n\r\n TSPInfSignerInfoA = SP_INF_SIGNER_INFO_A;\r\n TSPInfSignerInfoW = SP_INF_SIGNER_INFO_W;\r\n PSPInfSignerInfoA = ^TSPInfSignerInfoA;\r\n PSPInfSignerInfoW = ^TSPInfSignerInfoW;\r\n {$IFDEF UNICODE}\r\n TSPInfSignerInfo = TSPInfSignerInfoW;\r\n PSPInfSignerInfo = PSPInfSignerInfoW;\r\n SP_INF_SIGNER_INFO = SP_INF_SIGNER_INFO_W;\r\n {$EXTERNALSYM SP_INF_SIGNER_INFO}\r\n PSP_INF_SIGNER_INFO = PSP_INF_SIGNER_INFO_W;\r\n {$EXTERNALSYM PSP_INF_SIGNER_INFO}\r\n {$ELSE}\r\n TSPInfSignerInfo = TSPInfSignerInfoA;\r\n PSPInfSignerInfo = PSPInfSignerInfoA;\r\n SP_INF_SIGNER_INFO = SP_INF_SIGNER_INFO_A;\r\n {$EXTERNALSYM SP_INF_SIGNER_INFO}\r\n PSP_INF_SIGNER_INFO = PSP_INF_SIGNER_INFO_A;\r\n {$EXTERNALSYM PSP_INF_SIGNER_INFO}\r\n {$ENDIF UNICODE}\r\n\r\n//\r\n// Flags for use by SetupDiGetCustomDeviceProperty\r\n//\r\nconst\r\n DICUSTOMDEVPROP_MERGE_MULTISZ = $00000001;\r\n{$ENDIF WINXP_UP}\r\n\r\n{$IFNDEF SETUPAPI_LINKONREQUEST}\r\n\r\n{$IFDEF WINXP_UP}\r\nfunction SetupGetFileQueueCount(FileQueue: HSPFILEQ; SubQueueFileOp: UINT; var NumOperations: UINT): BOOL; stdcall;\r\n{$EXTERNALSYM SetupGetFileQueueCount}\r\nfunction SetupGetFileQueueFlags(FileQueue: HSPFILEQ; var Flags: DWORD): BOOL; stdcall;\r\n{$EXTERNALSYM SetupGetFileQueueFlags}\r\nfunction SetupSetFileQueueFlags(FileQueue: HSPFILEQ; FlagMask: DWORD; Flags: DWORD): BOOL; stdcall;\r\n{$EXTERNALSYM SetupSetFileQueueFlags}\r\n{$ENDIF WINXP_UP}\r\nfunction SetupGetInfInformationA(InfSpec: Pointer; SearchControl: DWORD;\r\n ReturnBuffer: PSPInfInformation; ReturnBufferSize: DWORD; RequiredSize: PDWORD): BOOL; stdcall;\r\n{$EXTERNALSYM SetupGetInfInformationA}\r\nfunction SetupGetInfInformationW(InfSpec: Pointer; SearchControl: DWORD;\r\n ReturnBuffer: PSPInfInformation; ReturnBufferSize: DWORD; RequiredSize: PDWORD): BOOL; stdcall;\r\n{$EXTERNALSYM SetupGetInfInformationW}\r\nfunction SetupGetInfInformation(InfSpec: Pointer; SearchControl: DWORD;\r\n ReturnBuffer: PSPInfInformation; ReturnBufferSize: DWORD; RequiredSize: PDWORD): BOOL; stdcall;\r\n{$EXTERNALSYM SetupGetInfInformation}\r\n\r\nfunction SetupQueryInfFileInformationA(var InfInformation: TSPInfInformation;\r\n InfIndex: UINT; ReturnBuffer: PAnsiChar; ReturnBufferSize: DWORD;\r\n RequiredSize: PDWORD): BOOL; stdcall;\r\n{$EXTERNALSYM SetupQueryInfFileInformationA}\r\nfunction SetupQueryInfFileInformationW(var InfInformation: TSPInfInformation;\r\n InfIndex: UINT; ReturnBuffer: PWideChar; ReturnBufferSize: DWORD;\r\n RequiredSize: PDWORD): BOOL; stdcall;\r\n{$EXTERNALSYM SetupQueryInfFileInformationW}\r\nfunction SetupQueryInfFileInformation(var InfInformation: TSPInfInformation;\r\n InfIndex: UINT; ReturnBuffer: PTSTR; ReturnBufferSize: DWORD;\r\n RequiredSize: PDWORD): BOOL; stdcall;\r\n{$EXTERNALSYM SetupQueryInfFileInformation}\r\n\r\n{$IFDEF WIN2000_UP}\r\nfunction SetupQueryInfOriginalFileInformationA(var InfInformation: TSPInfInformation;\r\n InfIndex: UINT; AlternatePlatformInfo: PSPAltPlatformInfo;\r\n var OriginalFileInfo: TSPOriginalFileInfoA): BOOL; stdcall;\r\n{$EXTERNALSYM SetupQueryInfOriginalFileInformationA}\r\nfunction SetupQueryInfOriginalFileInformationW(var InfInformation: TSPInfInformation;\r\n InfIndex: UINT; AlternatePlatformInfo: PSPAltPlatformInfo;\r\n var OriginalFileInfo: TSPOriginalFileInfoW): BOOL; stdcall;\r\n{$EXTERNALSYM SetupQueryInfOriginalFileInformationW}\r\nfunction SetupQueryInfOriginalFileInformation(var InfInformation: TSPInfInformation;\r\n InfIndex: UINT; AlternatePlatformInfo: PSPAltPlatformInfo;\r\n var OriginalFileInfo: TSPOriginalFileInfo): BOOL; stdcall;\r\n{$EXTERNALSYM SetupQueryInfOriginalFileInformation}\r\n{$ENDIF WIN2000_UP}\r\n\r\nfunction SetupQueryInfVersionInformationA(var InfInformation: TSPInfInformation;\r\n InfIndex: UINT; const Key, ReturnBuffer: PAnsiChar; ReturnBufferSize: DWORD;\r\n RequiredSize: PDWORD): BOOL; stdcall;\r\n{$EXTERNALSYM SetupQueryInfVersionInformationA}\r\nfunction SetupQueryInfVersionInformationW(var InfInformation: TSPInfInformation;\r\n InfIndex: UINT; const Key, ReturnBuffer: PWideChar; ReturnBufferSize: DWORD;\r\n RequiredSize: PDWORD): BOOL; stdcall;\r\n{$EXTERNALSYM SetupQueryInfVersionInformationW}\r\nfunction SetupQueryInfVersionInformation(var InfInformation: TSPInfInformation;\r\n InfIndex: UINT; const Key, ReturnBuffer: PTSTR; ReturnBufferSize: DWORD;\r\n RequiredSize: PDWORD): BOOL; stdcall;\r\n{$EXTERNALSYM SetupQueryInfVersionInformation}\r\n\r\nfunction SetupGetInfFileListA(const DirectoryPath: PAnsiChar; InfStyle: DWORD;\r\n ReturnBuffer: PAnsiChar; ReturnBufferSize: DWORD; RequiredSize: PDWORD): BOOL; stdcall;\r\n{$EXTERNALSYM SetupGetInfFileListA}\r\nfunction SetupGetInfFileListW(const DirectoryPath: PWideChar; InfStyle: DWORD;\r\n ReturnBuffer: PWideChar; ReturnBufferSize: DWORD; RequiredSize: PDWORD): BOOL; stdcall;\r\n{$EXTERNALSYM SetupGetInfFileListW}\r\nfunction SetupGetInfFileList(const DirectoryPath: PTSTR; InfStyle: DWORD;\r\n ReturnBuffer: PTSTR; ReturnBufferSize: DWORD; RequiredSize: PDWORD): BOOL; stdcall;\r\n{$EXTERNALSYM SetupGetInfFileList}\r\n\r\nfunction SetupOpenInfFileA(const FileName: PAnsiChar; const InfClass: PAnsiChar;\r\n InfStyle: DWORD; ErrorLine: PUINT): HINF; stdcall;\r\n{$EXTERNALSYM SetupOpenInfFileA}\r\nfunction SetupOpenInfFileW(const FileName: PWideChar; const InfClass: PWideChar;\r\n InfStyle: DWORD; ErrorLine: PUINT): HINF; stdcall;\r\n{$EXTERNALSYM SetupOpenInfFileW}\r\nfunction SetupOpenInfFile(const FileName: PTSTR; const InfClass: PTSTR;\r\n InfStyle: DWORD; ErrorLine: PUINT): HINF; stdcall;\r\n{$EXTERNALSYM SetupOpenInfFile}\r\n\r\nfunction SetupOpenMasterInf: HINF; stdcall;\r\n{$EXTERNALSYM SetupOpenMasterInf}\r\n\r\nfunction SetupOpenAppendInfFileA(const FileName: PAnsiChar; InfHandle: HINF;\r\n ErrorLine: PUINT): BOOL; stdcall;\r\n{$EXTERNALSYM SetupOpenAppendInfFileA}\r\nfunction SetupOpenAppendInfFileW(const FileName: PWideChar; InfHandle: HINF;\r\n ErrorLine: PUINT): BOOL; stdcall;\r\n{$EXTERNALSYM SetupOpenAppendInfFileW}\r\nfunction SetupOpenAppendInfFile(const FileName: PTSTR; InfHandle: HINF;\r\n ErrorLine: PUINT): BOOL; stdcall;\r\n{$EXTERNALSYM SetupOpenAppendInfFile}\r\n\r\nprocedure SetupCloseInfFile(InfHandle: HINF); stdcall;\r\n{$EXTERNALSYM SetupCloseInfFile}\r\n\r\nfunction SetupFindFirstLineA(InfHandle: HINF; Section, Key: PAnsiChar;\r\n var Context: TInfContext): BOOL; stdcall;\r\n{$EXTERNALSYM SetupFindFirstLineA}\r\nfunction SetupFindFirstLineW(InfHandle: HINF; Section, Key: PWideChar;\r\n var Context: TInfContext): BOOL; stdcall;\r\n{$EXTERNALSYM SetupFindFirstLineW}\r\nfunction SetupFindFirstLine(InfHandle: HINF; Section, Key: PTSTR;\r\n var Context: TInfContext): BOOL; stdcall;\r\n{$EXTERNALSYM SetupFindFirstLine}\r\n\r\nfunction SetupFindNextLine(var ContextIn, ContextOut: TInfContext): BOOL; stdcall;\r\n{$EXTERNALSYM SetupFindNextLine}\r\n\r\nfunction SetupFindNextMatchLineA(var ContextIn: TInfContext; Key: PAnsiChar;\r\n var ContextOut: TInfContext): BOOL; stdcall;\r\n{$EXTERNALSYM SetupFindNextMatchLineA}\r\nfunction SetupFindNextMatchLineW(var ContextIn: TInfContext; Key: PWideChar;\r\n var ContextOut: TInfContext): BOOL; stdcall;\r\n{$EXTERNALSYM SetupFindNextMatchLineW}\r\nfunction SetupFindNextMatchLine(var ContextIn: TInfContext; Key: PTSTR;\r\n var ContextOut: TInfContext): BOOL; stdcall;\r\n{$EXTERNALSYM SetupFindNextMatchLine}\r\n\r\nfunction SetupGetLineByIndexA(InfHandle: HINF; Section: PAnsiChar; Index: DWORD;\r\n var Context: TInfContext): BOOL; stdcall;\r\n{$EXTERNALSYM SetupGetLineByIndexA}\r\nfunction SetupGetLineByIndexW(InfHandle: HINF; Section: PWideChar; Index: DWORD;\r\n var Context: TInfContext): BOOL; stdcall;\r\n{$EXTERNALSYM SetupGetLineByIndexW}\r\nfunction SetupGetLineByIndex(InfHandle: HINF; Section: PTSTR; Index: DWORD;\r\n var Context: TInfContext): BOOL; stdcall;\r\n{$EXTERNALSYM SetupGetLineByIndex}\r\n\r\nfunction SetupGetLineCountA(InfHandle: HINF; Section: PAnsiChar): Integer; stdcall;\r\n{$EXTERNALSYM SetupGetLineCountA}\r\nfunction SetupGetLineCountW(InfHandle: HINF; Section: PWideChar): Integer; stdcall;\r\n{$EXTERNALSYM SetupGetLineCountW}\r\nfunction SetupGetLineCount(InfHandle: HINF; Section: PTSTR): Integer; stdcall;\r\n{$EXTERNALSYM SetupGetLineCount}\r\n\r\nfunction SetupGetLineTextA(Context: PInfContext; InfHandle: HINF; Section,\r\n Key, ReturnBuffer: PAnsiChar; ReturnBufferSize: DWORD; RequiredSize: PDWORD): BOOL; stdcall;\r\n{$EXTERNALSYM SetupGetLineTextA}\r\nfunction SetupGetLineTextW(Context: PInfContext; InfHandle: HINF; Section,\r\n Key, ReturnBuffer: PWideChar; ReturnBufferSize: DWORD; RequiredSize: PDWORD): BOOL; stdcall;\r\n{$EXTERNALSYM SetupGetLineTextW}\r\nfunction SetupGetLineText(Context: PInfContext; InfHandle: HINF; Section,\r\n Key, ReturnBuffer: PTSTR; ReturnBufferSize: DWORD; RequiredSize: PDWORD): BOOL; stdcall;\r\n{$EXTERNALSYM SetupGetLineText}\r\n\r\nfunction SetupGetFieldCount(var Context: TInfContext): DWORD; stdcall;\r\n{$EXTERNALSYM SetupGetFieldCount}\r\n\r\nfunction SetupGetStringFieldA(var Context: TInfContext; FieldIndex: DWORD;\r\n ReturnBuffer: PAnsiChar; ReturnBufferSize: DWORD; RequiredSize: PDWORD): BOOL; stdcall;\r\n{$EXTERNALSYM SetupGetStringFieldA}\r\nfunction SetupGetStringFieldW(var Context: TInfContext; FieldIndex: DWORD;\r\n ReturnBuffer: PWideChar; ReturnBufferSize: DWORD; RequiredSize: PDWORD): BOOL; stdcall;\r\n{$EXTERNALSYM SetupGetStringFieldW}\r\nfunction SetupGetStringField(var Context: TInfContext; FieldIndex: DWORD;\r\n ReturnBuffer: PTSTR; ReturnBufferSize: DWORD; RequiredSize: PDWORD): BOOL; stdcall;\r\n{$EXTERNALSYM SetupGetStringField}\r\n\r\nfunction SetupGetIntField(var Context: TInfContext; FieldIndex: DWORD;\r\n var IntegerValue: Integer): BOOL; stdcall;\r\n{$EXTERNALSYM SetupGetIntField}\r\n\r\nfunction SetupGetMultiSzFieldA(var Context: TInfContext; FieldIndex: DWORD;\r\n ReturnBuffer: PAnsiChar; ReturnBufferSize: DWORD; RequiredSize: PDWORD): BOOL; stdcall;\r\n{$EXTERNALSYM SetupGetMultiSzFieldA}\r\nfunction SetupGetMultiSzFieldW(var Context: TInfContext; FieldIndex: DWORD;\r\n ReturnBuffer: PWideChar; ReturnBufferSize: DWORD; RequiredSize: PDWORD): BOOL; stdcall;\r\n{$EXTERNALSYM SetupGetMultiSzFieldW}\r\nfunction SetupGetMultiSzField(var Context: TInfContext; FieldIndex: DWORD;\r\n ReturnBuffer: PTSTR; ReturnBufferSize: DWORD; RequiredSize: PDWORD): BOOL; stdcall;\r\n{$EXTERNALSYM SetupGetMultiSzField}\r\n\r\nfunction SetupGetBinaryField(var Context: TInfContext; FieldIndex: DWORD;\r\n ReturnBuffer: PBYTE; ReturnBufferSize: DWORD; RequiredSize: PDWORD): BOOL; stdcall;\r\n{$EXTERNALSYM SetupGetBinaryField}\r\n\r\n//\r\n// SetupGetFileCompressionInfo is depreciated\r\n// use SetupGetFileCompressionInfoEx instead\r\n//\r\n// ActualSourceFileName returned by SetupGetFileCompressionInfo\r\n// must be freed by the export setupapi!MyFree (NT4+ Win95+)\r\n// or LocalFree (Win2k+)\r\n//\r\nfunction SetupGetFileCompressionInfoA(const SourceFileName: PAnsiChar;\r\n var ActualSourceFileName: PAnsiChar; var SourceFileSize: DWORD;\r\n var TargetFileSize: DWORD; var CompressionType: UINT): DWORD; stdcall;\r\n{$EXTERNALSYM SetupGetFileCompressionInfoA}\r\nfunction SetupGetFileCompressionInfoW(const SourceFileName: PWideChar;\r\n var ActualSourceFileName: PWideChar; var SourceFileSize: DWORD;\r\n var TargetFileSize: DWORD; var CompressionType: UINT): DWORD; stdcall;\r\n{$EXTERNALSYM SetupGetFileCompressionInfoW}\r\nfunction SetupGetFileCompressionInfo(const SourceFileName: PTSTR;\r\n var ActualSourceFileName: PTSTR; var SourceFileSize: DWORD;\r\n var TargetFileSize: DWORD; var CompressionType: UINT): DWORD; stdcall;\r\n{$EXTERNALSYM SetupGetFileCompressionInfo}\r\n\r\n{$IFDEF WINXP_UP}\r\n//\r\n// SetupGetFileCompressionInfoEx is the preferred API over\r\n// SetupGetFileCompressionInfo. It follows the normal\r\n// conventions of returning BOOL and writing to user-supplied\r\n// buffer.\r\n//\r\nfunction SetupGetFileCompressionInfoExA(const SourceFileName: PAnsiChar;\r\n ActualSourceFileNameBuffer: PAnsiChar; var ActualSourceFileNameBufferLen: DWORD;\r\n RequiredBufferLen: PDWORD; var SourceFileSize: DWORD;\r\n var TargetFileSize: DWORD; var CompressionType: UINT): BOOL; stdcall;\r\n{$EXTERNALSYM SetupGetFileCompressionInfoExA}\r\nfunction SetupGetFileCompressionInfoExW(const SourceFileName: PWideChar;\r\n ActualSourceFileNameBuffer: PWideChar; var ActualSourceFileNameBufferLen: DWORD;\r\n RequiredBufferLen: PDWORD; var SourceFileSize: DWORD;\r\n var TargetFileSize: DWORD; var CompressionType: UINT): BOOL; stdcall;\r\n{$EXTERNALSYM SetupGetFileCompressionInfoExW}\r\nfunction SetupGetFileCompressionInfoEx(const SourceFileName: PTSTR;\r\n ActualSourceFileNameBuffer: PTSTR; var ActualSourceFileNameBufferLen: DWORD;\r\n RequiredBufferLen: PDWORD; var SourceFileSize: DWORD;\r\n var TargetFileSize: DWORD; var CompressionType: UINT): BOOL; stdcall;\r\n{$EXTERNALSYM SetupGetFileCompressionInfoEx}\r\n{$ENDIF WINXP_UP}\r\n\r\nfunction SetupDecompressOrCopyFileA(const SourceFileName, TargetFileName: PAnsiChar;\r\n var CompressionType: UINT): DWORD; stdcall;\r\n{$EXTERNALSYM SetupDecompressOrCopyFileA}\r\nfunction SetupDecompressOrCopyFileW(const SourceFileName, TargetFileName: PWideChar;\r\n var CompressionType: UINT): DWORD; stdcall;\r\n{$EXTERNALSYM SetupDecompressOrCopyFileW}\r\nfunction SetupDecompressOrCopyFile(const SourceFileName, TargetFileName: PTSTR;\r\n var CompressionType: UINT): DWORD; stdcall;\r\n{$EXTERNALSYM SetupDecompressOrCopyFile}\r\n\r\nfunction SetupGetSourceFileLocationA(InfHandle: HINF; InfContext: PInfContext;\r\n const FileName: PAnsiChar; var SourceId: UINT; ReturnBuffer: PAnsiChar;\r\n ReturnBufferSize: DWORD; RequiredSize: PDWORD): BOOL; stdcall;\r\n{$EXTERNALSYM SetupGetSourceFileLocationA}\r\nfunction SetupGetSourceFileLocationW(InfHandle: HINF; InfContext: PInfContext;\r\n const FileName: PWideChar; var SourceId: UINT; ReturnBuffer: PWideChar;\r\n ReturnBufferSize: DWORD; RequiredSize: PDWORD): BOOL; stdcall;\r\n{$EXTERNALSYM SetupGetSourceFileLocationW}\r\nfunction SetupGetSourceFileLocation(InfHandle: HINF; InfContext: PInfContext;\r\n const FileName: PTSTR; var SourceId: UINT; ReturnBuffer: PTSTR;\r\n ReturnBufferSize: DWORD; RequiredSize: PDWORD): BOOL; stdcall;\r\n{$EXTERNALSYM SetupGetSourceFileLocation}\r\n\r\nfunction SetupGetSourceFileSizeA(InfHandle: HINF; InfContext: PInfContext;\r\n const FileName: PAnsiChar; const Section: PAnsiChar; var FileSize: DWORD;\r\n RoundingFactor: UINT): BOOL; stdcall;\r\n{$EXTERNALSYM SetupGetSourceFileSizeA}\r\nfunction SetupGetSourceFileSizeW(InfHandle: HINF; InfContext: PInfContext;\r\n const FileName: PWideChar; const Section: PWideChar; var FileSize: DWORD;\r\n RoundingFactor: UINT): BOOL; stdcall;\r\n{$EXTERNALSYM SetupGetSourceFileSizeW}\r\nfunction SetupGetSourceFileSize(InfHandle: HINF; InfContext: PInfContext;\r\n const FileName: PTSTR; const Section: PTSTR; var FileSize: DWORD;\r\n RoundingFactor: UINT): BOOL; stdcall;\r\n{$EXTERNALSYM SetupGetSourceFileSize}\r\n\r\nfunction SetupGetTargetPathA(InfHandle: HINF; InfContext: PInfContext;\r\n const Section: PAnsiChar; ReturnBuffer: PAnsiChar; ReturnBufferSize: DWORD;\r\n RequiredSize: PDWORD): BOOL; stdcall;\r\n{$EXTERNALSYM SetupGetTargetPathA}\r\nfunction SetupGetTargetPathW(InfHandle: HINF; InfContext: PInfContext;\r\n const Section: PWideChar; ReturnBuffer: PWideChar; ReturnBufferSize: DWORD;\r\n RequiredSize: PDWORD): BOOL; stdcall;\r\n{$EXTERNALSYM SetupGetTargetPathW}\r\nfunction SetupGetTargetPath(InfHandle: HINF; InfContext: PInfContext;\r\n const Section: PTSTR; ReturnBuffer: PTSTR; ReturnBufferSize: DWORD;\r\n RequiredSize: PDWORD): BOOL; stdcall;\r\n{$EXTERNALSYM SetupGetTargetPath}\r\n\r\nfunction SetupSetSourceListA(Flags: DWORD; SourceList: PPASTR;\r\n SourceCount: UINT): BOOL; stdcall;\r\n{$EXTERNALSYM SetupSetSourceListA}\r\nfunction SetupSetSourceListW(Flags: DWORD; SourceList: PPWSTR;\r\n SourceCount: UINT): BOOL; stdcall;\r\n{$EXTERNALSYM SetupSetSourceListW}\r\nfunction SetupSetSourceList(Flags: DWORD; SourceList: PPSTR;\r\n SourceCount: UINT): BOOL; stdcall;\r\n{$EXTERNALSYM SetupSetSourceList}\r\n\r\nfunction SetupCancelTemporarySourceList: BOOL; stdcall;\r\n{$EXTERNALSYM SetupCancelTemporarySourceList}\r\n\r\nfunction SetupAddToSourceListA(Flags: DWORD; const Source: PAnsiChar): BOOL; stdcall;\r\n{$EXTERNALSYM SetupAddToSourceListA}\r\nfunction SetupAddToSourceListW(Flags: DWORD; const Source: PWideChar): BOOL; stdcall;\r\n{$EXTERNALSYM SetupAddToSourceListW}\r\nfunction SetupAddToSourceList(Flags: DWORD; const Source: PTSTR): BOOL; stdcall;\r\n{$EXTERNALSYM SetupAddToSourceList}\r\n\r\nfunction SetupRemoveFromSourceListA(Flags: DWORD; const Source: PAnsiChar): BOOL; stdcall;\r\n{$EXTERNALSYM SetupRemoveFromSourceListA}\r\nfunction SetupRemoveFromSourceListW(Flags: DWORD; const Source: PWideChar): BOOL; stdcall;\r\n{$EXTERNALSYM SetupRemoveFromSourceListW}\r\nfunction SetupRemoveFromSourceList(Flags: DWORD; const Source: PTSTR): BOOL; stdcall;\r\n{$EXTERNALSYM SetupRemoveFromSourceList}\r\n\r\nfunction SetupQuerySourceListA(Flags: DWORD; var List: PPASTR;\r\n var Count: UINT): BOOL; stdcall;\r\n{$EXTERNALSYM SetupQuerySourceListA}\r\nfunction SetupQuerySourceListW(Flags: DWORD; var List: PPWSTR;\r\n var Count: UINT): BOOL; stdcall;\r\n{$EXTERNALSYM SetupQuerySourceListW}\r\nfunction SetupQuerySourceList(Flags: DWORD; var List: PPSTR;\r\n var Count: UINT): BOOL; stdcall;\r\n{$EXTERNALSYM SetupQuerySourceList}\r\n\r\nfunction SetupFreeSourceListA(var List: PPASTR; Count: UINT): BOOL; stdcall;\r\n{$EXTERNALSYM SetupFreeSourceListA}\r\nfunction SetupFreeSourceListW(var List: PPWSTR; Count: UINT): BOOL; stdcall;\r\n{$EXTERNALSYM SetupFreeSourceListW}\r\nfunction SetupFreeSourceList(var List: PPSTR; Count: UINT): BOOL; stdcall;\r\n{$EXTERNALSYM SetupFreeSourceList}\r\n\r\nfunction SetupPromptForDiskA(hwndParent: HWND; const DialogTitle, DiskName,\r\n PathToSource, FileSought, TagFile: PAnsiChar; DiskPromptStyle: DWORD;\r\n PathBuffer: PAnsiChar; PathBufferSize: DWORD; var PathRequiredSize: DWORD): UINT; stdcall;\r\n{$EXTERNALSYM SetupPromptForDiskA}\r\nfunction SetupPromptForDiskW(hwndParent: HWND; const DialogTitle, DiskName,\r\n PathToSource, FileSought, TagFile: PWideChar; DiskPromptStyle: DWORD;\r\n PathBuffer: PWideChar; PathBufferSize: DWORD; var PathRequiredSize: DWORD): UINT; stdcall;\r\n{$EXTERNALSYM SetupPromptForDiskW}\r\nfunction SetupPromptForDisk(hwndParent: HWND; const DialogTitle, DiskName,\r\n PathToSource, FileSought, TagFile: PTSTR; DiskPromptStyle: DWORD;\r\n PathBuffer: PTSTR; PathBufferSize: DWORD; var PathRequiredSize: DWORD): UINT; stdcall;\r\n{$EXTERNALSYM SetupPromptForDisk}\r\n\r\nfunction SetupCopyErrorA(hwndParent: HWND; const DialogTitle, DiskName,\r\n PathToSource, SourceFile, TargetPathFile: PAnsiChar; Win32ErrorCode: UINT; Style: DWORD;\r\n PathBuffer: PAnsiChar; PathBufferSize: DWORD; PathRequiredSize: PDWORD): UINT; stdcall;\r\n{$EXTERNALSYM SetupCopyErrorA}\r\nfunction SetupCopyErrorW(hwndParent: HWND; const DialogTitle, DiskName,\r\n PathToSource, SourceFile, TargetPathFile: PWideChar; Win32ErrorCode: UINT; Style: DWORD;\r\n PathBuffer: PWideChar; PathBufferSize: DWORD; PathRequiredSize: PDWORD): UINT; stdcall;\r\n{$EXTERNALSYM SetupCopyErrorW}\r\nfunction SetupCopyError(hwndParent: HWND; const DialogTitle, DiskName,\r\n PathToSource, SourceFile, TargetPathFile: PTSTR; Win32ErrorCode: UINT; Style: DWORD;\r\n PathBuffer: PTSTR; PathBufferSize: DWORD; PathRequiredSize: PDWORD): UINT; stdcall;\r\n{$EXTERNALSYM SetupCopyError}\r\n\r\nfunction SetupRenameErrorA(hwndParent: HWND; const DialogTitle, SourceFile,\r\n TargetFile: PAnsiChar; Win32ErrorCode: UINT; Style: DWORD): UINT; stdcall;\r\n{$EXTERNALSYM SetupRenameErrorA}\r\nfunction SetupRenameErrorW(hwndParent: HWND; const DialogTitle, SourceFile,\r\n TargetFile: PWideChar; Win32ErrorCode: UINT; Style: DWORD): UINT; stdcall;\r\n{$EXTERNALSYM SetupRenameErrorW}\r\nfunction SetupRenameError(hwndParent: HWND; const DialogTitle, SourceFile,\r\n TargetFile: PTSTR; Win32ErrorCode: UINT; Style: DWORD): UINT; stdcall;\r\n{$EXTERNALSYM SetupRenameError}\r\n\r\nfunction SetupDeleteErrorA(hwndParent: HWND; const DialogTitle, File_: PAnsiChar;\r\n Win32ErrorCode: UINT; Style: DWORD): UINT; stdcall;\r\n{$EXTERNALSYM SetupDeleteErrorA}\r\nfunction SetupDeleteErrorW(hwndParent: HWND; const DialogTitle, File_: PWideChar;\r\n Win32ErrorCode: UINT; Style: DWORD): UINT; stdcall;\r\n{$EXTERNALSYM SetupDeleteErrorW}\r\nfunction SetupDeleteError(hwndParent: HWND; const DialogTitle, File_: PTSTR;\r\n Win32ErrorCode: UINT; Style: DWORD): UINT; stdcall;\r\n{$EXTERNALSYM SetupDeleteError}\r\n\r\n{$IFDEF WIN2000_UP}\r\nfunction SetupBackupErrorA(hwndParent: HWND; const DialogTitle, SourceFile,\r\n TargetFile: PAnsiChar; Win32ErrorCode: UINT; Style: DWORD): UINT; stdcall;\r\n{$EXTERNALSYM SetupBackupErrorA}\r\nfunction SetupBackupErrorW(hwndParent: HWND; const DialogTitle, SourceFile,\r\n TargetFile: PWideChar; Win32ErrorCode: UINT; Style: DWORD): UINT; stdcall;\r\n{$EXTERNALSYM SetupBackupErrorW}\r\nfunction SetupBackupError(hwndParent: HWND; const DialogTitle, SourceFile,\r\n TargetFile: PTSTR; Win32ErrorCode: UINT; Style: DWORD): UINT; stdcall;\r\n{$EXTERNALSYM SetupBackupError}\r\n{$ENDIF WIN2000_UP}\r\n\r\nfunction SetupSetDirectoryIdA(InfHandle: HINF; Id: DWORD; const Directory: PAnsiChar): BOOL; stdcall;\r\n{$EXTERNALSYM SetupSetDirectoryIdA}\r\nfunction SetupSetDirectoryIdW(InfHandle: HINF; Id: DWORD; const Directory: PWideChar): BOOL; stdcall;\r\n{$EXTERNALSYM SetupSetDirectoryIdW}\r\nfunction SetupSetDirectoryId(InfHandle: HINF; Id: DWORD; const Directory: PTSTR): BOOL; stdcall;\r\n{$EXTERNALSYM SetupSetDirectoryId}\r\n\r\nfunction SetupSetDirectoryIdExA(InfHandle: HINF; Id: DWORD; const Directory: PAnsiChar;\r\n Flags: DWORD; Reserved1: DWORD; Reserved2: Pointer): BOOL; stdcall;\r\n{$EXTERNALSYM SetupSetDirectoryIdExA}\r\nfunction SetupSetDirectoryIdExW(InfHandle: HINF; Id: DWORD; const Directory: PWideChar;\r\n Flags: DWORD; Reserved1: DWORD; Reserved2: Pointer): BOOL; stdcall;\r\n{$EXTERNALSYM SetupSetDirectoryIdExW}\r\nfunction SetupSetDirectoryIdEx(InfHandle: HINF; Id: DWORD; const Directory: PTSTR;\r\n Flags: DWORD; Reserved1: DWORD; Reserved2: Pointer): BOOL; stdcall;\r\n{$EXTERNALSYM SetupSetDirectoryIdEx}\r\n\r\nfunction SetupGetSourceInfoA(InfHandle: HINF; SourceId, InfoDesired: UINT;\r\n ReturnBuffer: PAnsiChar; ReturnBufferSize: DWORD; RequiredSize: PDWORD): BOOL; stdcall;\r\n{$EXTERNALSYM SetupGetSourceInfoA}\r\nfunction SetupGetSourceInfoW(InfHandle: HINF; SourceId, InfoDesired: UINT;\r\n ReturnBuffer: PWideChar; ReturnBufferSize: DWORD; RequiredSize: PDWORD): BOOL; stdcall;\r\n{$EXTERNALSYM SetupGetSourceInfoW}\r\nfunction SetupGetSourceInfo(InfHandle: HINF; SourceId, InfoDesired: UINT;\r\n ReturnBuffer: PTSTR; ReturnBufferSize: DWORD; RequiredSize: PDWORD): BOOL; stdcall;\r\n{$EXTERNALSYM SetupGetSourceInfo}\r\n\r\nfunction SetupInstallFileA(InfHandle: HINF; InfContext: PInfContext;\r\n const SourceFile, SourcePathRoot, DestinationName: PAnsiChar; CopyStyle: DWORD;\r\n CopyMsgHandler: TSPFileCallbackA; Context: Pointer): BOOL; stdcall;\r\n{$EXTERNALSYM SetupInstallFileA}\r\nfunction SetupInstallFileW(InfHandle: HINF; InfContext: PInfContext;\r\n const SourceFile, SourcePathRoot, DestinationName: PWideChar; CopyStyle: DWORD;\r\n CopyMsgHandler: TSPFileCallbackW; Context: Pointer): BOOL; stdcall;\r\n{$EXTERNALSYM SetupInstallFileW}\r\nfunction SetupInstallFile(InfHandle: HINF; InfContext: PInfContext;\r\n const SourceFile, SourcePathRoot, DestinationName: PTSTR; CopyStyle: DWORD;\r\n CopyMsgHandler: TSPFileCallback; Context: Pointer): BOOL; stdcall;\r\n{$EXTERNALSYM SetupInstallFile}\r\n\r\nfunction SetupInstallFileExA(InfHandle: HINF; InfContext: PInfContext;\r\n const SourceFile, SourcePathRoot, DestinationName: PAnsiChar; CopyStyle: DWORD;\r\n CopyMsgHandler: TSPFileCallbackA; Context: Pointer; var FileWasInUse: BOOL): BOOL; stdcall;\r\n{$EXTERNALSYM SetupInstallFileExA}\r\nfunction SetupInstallFileExW(InfHandle: HINF; InfContext: PInfContext;\r\n const SourceFile, SourcePathRoot, DestinationName: PWideChar; CopyStyle: DWORD;\r\n CopyMsgHandler: TSPFileCallbackW; Context: Pointer; var FileWasInUse: BOOL): BOOL; stdcall;\r\n{$EXTERNALSYM SetupInstallFileExW}\r\nfunction SetupInstallFileEx(InfHandle: HINF; InfContext: PInfContext;\r\n const SourceFile, SourcePathRoot, DestinationName: PTSTR; CopyStyle: DWORD;\r\n CopyMsgHandler: TSPFileCallback; Context: Pointer; var FileWasInUse: BOOL): BOOL; stdcall;\r\n{$EXTERNALSYM SetupInstallFileEx}\r\n\r\nfunction SetupOpenFileQueue: HSPFILEQ; stdcall;\r\n{$EXTERNALSYM SetupOpenFileQueue}\r\n\r\nfunction SetupCloseFileQueue(QueueHandle: HSPFILEQ): BOOL; stdcall;\r\n{$EXTERNALSYM SetupCloseFileQueue}\r\n\r\n{$IFDEF WIN2000_UP}\r\nfunction SetupSetFileQueueAlternatePlatformA(QueueHandle: HSPFILEQ;\r\n AlternatePlatformInfo: PSPAltPlatformInfo;\r\n const AlternateDefaultCatalogFile: PAnsiChar): BOOL; stdcall;\r\n{$EXTERNALSYM SetupSetFileQueueAlternatePlatformA}\r\nfunction SetupSetFileQueueAlternatePlatformW(QueueHandle: HSPFILEQ;\r\n AlternatePlatformInfo: PSPAltPlatformInfo;\r\n const AlternateDefaultCatalogFile: PWideChar): BOOL; stdcall;\r\n{$EXTERNALSYM SetupSetFileQueueAlternatePlatformW}\r\nfunction SetupSetFileQueueAlternatePlatform(QueueHandle: HSPFILEQ;\r\n AlternatePlatformInfo: PSPAltPlatformInfo;\r\n const AlternateDefaultCatalogFile: PTSTR): BOOL; stdcall;\r\n{$EXTERNALSYM SetupSetFileQueueAlternatePlatform}\r\n{$ENDIF WIN2000_UP}\r\n\r\nfunction SetupSetPlatformPathOverrideA(const Override_: PAnsiChar): BOOL; stdcall;\r\n{$EXTERNALSYM SetupSetPlatformPathOverrideA}\r\nfunction SetupSetPlatformPathOverrideW(const Override_: PWideChar): BOOL; stdcall;\r\n{$EXTERNALSYM SetupSetPlatformPathOverrideW}\r\nfunction SetupSetPlatformPathOverride(const Override_: PTSTR): BOOL; stdcall;\r\n{$EXTERNALSYM SetupSetPlatformPathOverride}\r\n\r\nfunction SetupQueueCopyA(QueueHandle: HSPFILEQ; const SourceRootPath, SourcePath,\r\n SourceFilename, SourceDescription, SourceTagfile, TargetDirectory,\r\n TargetFilename: PAnsiChar; CopyStyle: DWORD): BOOL; stdcall;\r\n{$EXTERNALSYM SetupQueueCopyA}\r\nfunction SetupQueueCopyW(QueueHandle: HSPFILEQ; const SourceRootPath, SourcePath,\r\n SourceFilename, SourceDescription, SourceTagfile, TargetDirectory,\r\n TargetFilename: PWideChar; CopyStyle: DWORD): BOOL; stdcall;\r\n{$EXTERNALSYM SetupQueueCopyW}\r\nfunction SetupQueueCopy(QueueHandle: HSPFILEQ; const SourceRootPath, SourcePath,\r\n SourceFilename, SourceDescription, SourceTagfile, TargetDirectory,\r\n TargetFilename: PTSTR; CopyStyle: DWORD): BOOL; stdcall;\r\n{$EXTERNALSYM SetupQueueCopy}\r\n\r\n{$IFDEF WIN2000_UP}\r\nfunction SetupQueueCopyIndirectA(var CopyParams: TSPFileCopyParamsA): BOOL; stdcall;\r\n{$EXTERNALSYM SetupQueueCopyIndirectA}\r\nfunction SetupQueueCopyIndirectW(var CopyParams: TSPFileCopyParamsW): BOOL; stdcall;\r\n{$EXTERNALSYM SetupQueueCopyIndirectW}\r\nfunction SetupQueueCopyIndirect(var CopyParams: TSPFileCopyParams): BOOL; stdcall;\r\n{$EXTERNALSYM SetupQueueCopyIndirect}\r\n{$ENDIF WIN2000_UP}\r\n\r\nfunction SetupQueueDefaultCopyA(QueueHandle: HSPFILEQ; InfHandle: HINF;\r\n const SourceRootPath, SourceFilename, TargetFilename: PAnsiChar;\r\n CopyStyle: DWORD): BOOL; stdcall;\r\n{$EXTERNALSYM SetupQueueDefaultCopyA}\r\nfunction SetupQueueDefaultCopyW(QueueHandle: HSPFILEQ; InfHandle: HINF;\r\n const SourceRootPath, SourceFilename, TargetFilename: PWideChar;\r\n CopyStyle: DWORD): BOOL; stdcall;\r\n{$EXTERNALSYM SetupQueueDefaultCopyW}\r\nfunction SetupQueueDefaultCopy(QueueHandle: HSPFILEQ; InfHandle: HINF;\r\n const SourceRootPath, SourceFilename, TargetFilename: PTSTR;\r\n CopyStyle: DWORD): BOOL; stdcall;\r\n{$EXTERNALSYM SetupQueueDefaultCopy}\r\n\r\nfunction SetupQueueCopySectionA(QueueHandle: HSPFILEQ; const SourceRootPath: PAnsiChar;\r\n InfHandle: HINF; ListInfHandle: HINF; const Section: PAnsiChar; CopyStyle: DWORD): BOOL; stdcall;\r\n{$EXTERNALSYM SetupQueueCopySectionA}\r\nfunction SetupQueueCopySectionW(QueueHandle: HSPFILEQ; const SourceRootPath: PWideChar;\r\n InfHandle: HINF; ListInfHandle: HINF; const Section: PWideChar; CopyStyle: DWORD): BOOL; stdcall;\r\n{$EXTERNALSYM SetupQueueCopySectionW}\r\nfunction SetupQueueCopySection(QueueHandle: HSPFILEQ; const SourceRootPath: PTSTR;\r\n InfHandle: HINF; ListInfHandle: HINF; const Section: PTSTR; CopyStyle: DWORD): BOOL; stdcall;\r\n{$EXTERNALSYM SetupQueueCopySection}\r\n\r\nfunction SetupQueueDeleteA(QueueHandle: HSPFILEQ; const PathPart1, PathPart2: PAnsiChar): BOOL; stdcall;\r\n{$EXTERNALSYM SetupQueueDeleteA}\r\nfunction SetupQueueDeleteW(QueueHandle: HSPFILEQ; const PathPart1, PathPart2: PWideChar): BOOL; stdcall;\r\n{$EXTERNALSYM SetupQueueDeleteW}\r\nfunction SetupQueueDelete(QueueHandle: HSPFILEQ; const PathPart1, PathPart2: PTSTR): BOOL; stdcall;\r\n{$EXTERNALSYM SetupQueueDelete}\r\n\r\nfunction SetupQueueDeleteSectionA(QueueHandle: HSPFILEQ; InfHandle: HINF;\r\n ListInfHandle: HINF; const Section: PAnsiChar): BOOL; stdcall;\r\n{$EXTERNALSYM SetupQueueDeleteSectionA}\r\nfunction SetupQueueDeleteSectionW(QueueHandle: HSPFILEQ; InfHandle: HINF;\r\n ListInfHandle: HINF; const Section: PWideChar): BOOL; stdcall;\r\n{$EXTERNALSYM SetupQueueDeleteSectionW}\r\nfunction SetupQueueDeleteSection(QueueHandle: HSPFILEQ; InfHandle: HINF;\r\n ListInfHandle: HINF; const Section: PTSTR): BOOL; stdcall;\r\n{$EXTERNALSYM SetupQueueDeleteSection}\r\n\r\nfunction SetupQueueRenameA(QueueHandle: HSPFILEQ; const SourcePath,\r\n SourceFilename, TargetPath, TargetFilename: PAnsiChar): BOOL; stdcall;\r\n{$EXTERNALSYM SetupQueueRenameA}\r\nfunction SetupQueueRenameW(QueueHandle: HSPFILEQ; const SourcePath,\r\n SourceFilename, TargetPath, TargetFilename: PWideChar): BOOL; stdcall;\r\n{$EXTERNALSYM SetupQueueRenameW}\r\nfunction SetupQueueRename(QueueHandle: HSPFILEQ; const SourcePath,\r\n SourceFilename, TargetPath, TargetFilename: PTSTR): BOOL; stdcall;\r\n{$EXTERNALSYM SetupQueueRename}\r\n\r\nfunction SetupQueueRenameSectionA(QueueHandle: HSPFILEQ; InfHandle: HINF;\r\n ListInfHandle: HINF; const Section: PAnsiChar): BOOL; stdcall;\r\n{$EXTERNALSYM SetupQueueRenameSectionA}\r\nfunction SetupQueueRenameSectionW(QueueHandle: HSPFILEQ; InfHandle: HINF;\r\n ListInfHandle: HINF; const Section: PWideChar): BOOL; stdcall;\r\n{$EXTERNALSYM SetupQueueRenameSectionW}\r\nfunction SetupQueueRenameSection(QueueHandle: HSPFILEQ; InfHandle: HINF;\r\n ListInfHandle: HINF; const Section: PTSTR): BOOL; stdcall;\r\n{$EXTERNALSYM SetupQueueRenameSection}\r\n\r\nfunction SetupCommitFileQueueA(Owner: HWND; QueueHandle: HSPFILEQ;\r\n MsgHandler: TSPFileCallbackA; Context: Pointer): BOOL; stdcall;\r\n{$EXTERNALSYM SetupCommitFileQueueA}\r\nfunction SetupCommitFileQueueW(Owner: HWND; QueueHandle: HSPFILEQ;\r\n MsgHandler: TSPFileCallbackW; Context: Pointer): BOOL; stdcall;\r\n{$EXTERNALSYM SetupCommitFileQueueW}\r\nfunction SetupCommitFileQueue(Owner: HWND; QueueHandle: HSPFILEQ;\r\n MsgHandler: TSPFileCallback; Context: Pointer): BOOL; stdcall;\r\n{$EXTERNALSYM SetupCommitFileQueue}\r\n\r\nfunction SetupScanFileQueueA(FileQueue: HSPFILEQ; Flags: DWORD; Window: HWND;\r\n CallbackRoutine: TSPFileCallbackA; CallbackContext: Pointer; var Result: DWORD): BOOL; stdcall;\r\n{$EXTERNALSYM SetupScanFileQueueA}\r\nfunction SetupScanFileQueueW(FileQueue: HSPFILEQ; Flags: DWORD; Window: HWND;\r\n CallbackRoutine: TSPFileCallbackW; CallbackContext: Pointer; var Result: DWORD): BOOL; stdcall;\r\n{$EXTERNALSYM SetupScanFileQueueW}\r\nfunction SetupScanFileQueue(FileQueue: HSPFILEQ; Flags: DWORD; Window: HWND;\r\n CallbackRoutine: TSPFileCallback; CallbackContext: Pointer; var Result: DWORD): BOOL; stdcall;\r\n{$EXTERNALSYM SetupScanFileQueue}\r\n\r\nfunction SetupCopyOEMInfA(const SourceInfFileName, OEMSourceMediaLocation: PAnsiChar;\r\n OEMSourceMediaType, CopyStyle: DWORD; DestinationInfFileName: PAnsiChar;\r\n DestinationInfFileNameSize: DWORD; RequiredSize: PDWORD;\r\n DestinationInfFileNameComponent: PPASTR): BOOL; stdcall;\r\n{$EXTERNALSYM SetupCopyOEMInfA}\r\nfunction SetupCopyOEMInfW(const SourceInfFileName, OEMSourceMediaLocation: PWideChar;\r\n OEMSourceMediaType, CopyStyle: DWORD; DestinationInfFileName: PWideChar;\r\n DestinationInfFileNameSize: DWORD; RequiredSize: PDWORD;\r\n DestinationInfFileNameComponent: PPWSTR): BOOL; stdcall;\r\n{$EXTERNALSYM SetupCopyOEMInfW}\r\nfunction SetupCopyOEMInf(const SourceInfFileName, OEMSourceMediaLocation: PTSTR;\r\n OEMSourceMediaType, CopyStyle: DWORD; DestinationInfFileName: PTSTR;\r\n DestinationInfFileNameSize: DWORD; RequiredSize: PDWORD;\r\n DestinationInfFileNameComponent: PPSTR): BOOL; stdcall;\r\n{$EXTERNALSYM SetupCopyOEMInf}\r\n\r\n{$IFDEF WINXP_UP}\r\nfunction SetupUninstallOEMInfA(const InfFileName: PAnsiChar; Flags: DWORD; Reserved: Pointer): BOOL; stdcall;\r\n{$EXTERNALSYM SetupUninstallOEMInfA}\r\nfunction SetupUninstallOEMInfW(const InfFileName: PWideChar; Flags: DWORD; Reserved: Pointer): BOOL; stdcall;\r\n{$EXTERNALSYM SetupUninstallOEMInfW}\r\nfunction SetupUninstallOEMInf(const InfFileName: PTSTR; Flags: DWORD; Reserved: Pointer): BOOL; stdcall;\r\n{$EXTERNALSYM SetupUninstallOEMInf}\r\n\r\nfunction SetupUninstallNewlyCopiedInfs(FileQueue: HSPFILEQ; Flags: DWORD; Reserved: Pointer): BOOL; stdcall;\r\n{$EXTERNALSYM SetupUninstallNewlyCopiedInfs}\r\n{$ENDIF WINXP_UP}\r\n\r\n//\r\n// Disk space list APIs\r\n//\r\nfunction SetupCreateDiskSpaceListA(Reserved1: Pointer; Reserved2: DWORD;\r\n Flags: UINT): HDSKSPC; stdcall;\r\n{$EXTERNALSYM SetupCreateDiskSpaceListA}\r\nfunction SetupCreateDiskSpaceListW(Reserved1: Pointer; Reserved2: DWORD;\r\n Flags: UINT): HDSKSPC; stdcall;\r\n{$EXTERNALSYM SetupCreateDiskSpaceListW}\r\nfunction SetupCreateDiskSpaceList(Reserved1: Pointer; Reserved2: DWORD;\r\n Flags: UINT): HDSKSPC; stdcall;\r\n{$EXTERNALSYM SetupCreateDiskSpaceList}\r\n\r\nfunction SetupDuplicateDiskSpaceListA(DiskSpace: HDSKSPC; Reserved1: Pointer;\r\n Reserved2: DWORD; Flags: UINT): HDSKSPC; stdcall;\r\n{$EXTERNALSYM SetupDuplicateDiskSpaceListA}\r\nfunction SetupDuplicateDiskSpaceListW(DiskSpace: HDSKSPC; Reserved1: Pointer;\r\n Reserved2: DWORD; Flags: UINT): HDSKSPC; stdcall;\r\n{$EXTERNALSYM SetupDuplicateDiskSpaceListW}\r\nfunction SetupDuplicateDiskSpaceList(DiskSpace: HDSKSPC; Reserved1: Pointer;\r\n Reserved2: DWORD; Flags: UINT): HDSKSPC; stdcall;\r\n{$EXTERNALSYM SetupDuplicateDiskSpaceList}\r\n\r\nfunction SetupDestroyDiskSpaceList(DiskSpace: HDSKSPC): BOOL; stdcall;\r\n{$EXTERNALSYM SetupDestroyDiskSpaceList}\r\n\r\nfunction SetupQueryDrivesInDiskSpaceListA(DiskSpace: HDSKSPC; ReturnBuffer: PAnsiChar;\r\n ReturnBufferSize: DWORD; RequiredSize: PDWORD): BOOL; stdcall;\r\n{$EXTERNALSYM SetupQueryDrivesInDiskSpaceListA}\r\nfunction SetupQueryDrivesInDiskSpaceListW(DiskSpace: HDSKSPC; ReturnBuffer: PWideChar;\r\n ReturnBufferSize: DWORD; RequiredSize: PDWORD): BOOL; stdcall;\r\n{$EXTERNALSYM SetupQueryDrivesInDiskSpaceListW}\r\nfunction SetupQueryDrivesInDiskSpaceList(DiskSpace: HDSKSPC; ReturnBuffer: PTSTR;\r\n ReturnBufferSize: DWORD; RequiredSize: PDWORD): BOOL; stdcall;\r\n{$EXTERNALSYM SetupQueryDrivesInDiskSpaceList}\r\n\r\nfunction SetupQuerySpaceRequiredOnDriveA(DiskSpace: HDSKSPC; const DriveSpec: PAnsiChar;\r\n var SpaceRequired: Int64; Reserved1: Pointer; Reserved2: UINT): BOOL; stdcall;\r\n{$EXTERNALSYM SetupQuerySpaceRequiredOnDriveA}\r\nfunction SetupQuerySpaceRequiredOnDriveW(DiskSpace: HDSKSPC; const DriveSpec: PWideChar;\r\n var SpaceRequired: Int64; Reserved1: Pointer; Reserved2: UINT): BOOL; stdcall;\r\n{$EXTERNALSYM SetupQuerySpaceRequiredOnDriveW}\r\nfunction SetupQuerySpaceRequiredOnDrive(DiskSpace: HDSKSPC; const DriveSpec: PTSTR;\r\n var SpaceRequired: Int64; Reserved1: Pointer; Reserved2: UINT): BOOL; stdcall;\r\n{$EXTERNALSYM SetupQuerySpaceRequiredOnDrive}\r\n\r\nfunction SetupAdjustDiskSpaceListA(DiskSpace: HDSKSPC; const DriveRoot: PAnsiChar;\r\n Amount: Int64; Reserved1: Pointer; Reserved2: UINT): BOOL; stdcall;\r\n{$EXTERNALSYM SetupAdjustDiskSpaceListA}\r\nfunction SetupAdjustDiskSpaceListW(DiskSpace: HDSKSPC; const DriveRoot: PWideChar;\r\n Amount: Int64; Reserved1: Pointer; Reserved2: UINT): BOOL; stdcall;\r\n{$EXTERNALSYM SetupAdjustDiskSpaceListW}\r\nfunction SetupAdjustDiskSpaceList(DiskSpace: HDSKSPC; const DriveRoot: PTSTR;\r\n Amount: Int64; Reserved1: Pointer; Reserved2: UINT): BOOL; stdcall;\r\n{$EXTERNALSYM SetupAdjustDiskSpaceList}\r\n\r\nfunction SetupAddToDiskSpaceListA(DiskSpace: HDSKSPC; const TargetFilespec: PAnsiChar;\r\n FileSize: Int64; Operation: UINT; Reserved1: Pointer; Reserved2: UINT): BOOL; stdcall;\r\n{$EXTERNALSYM SetupAddToDiskSpaceListA}\r\nfunction SetupAddToDiskSpaceListW(DiskSpace: HDSKSPC; const TargetFilespec: PWideChar;\r\n FileSize: Int64; Operation: UINT; Reserved1: Pointer; Reserved2: UINT): BOOL; stdcall;\r\n{$EXTERNALSYM SetupAddToDiskSpaceListW}\r\nfunction SetupAddToDiskSpaceList(DiskSpace: HDSKSPC; const TargetFilespec: PTSTR;\r\n FileSize: Int64; Operation: UINT; Reserved1: Pointer; Reserved2: UINT): BOOL; stdcall;\r\n{$EXTERNALSYM SetupAddToDiskSpaceList}\r\n\r\nfunction SetupAddSectionToDiskSpaceListA(DiskSpace: HDSKSPC; InfHandle: HINF;\r\n ListInfHandle: HINF; const SectionName: PAnsiChar; Operation: UINT;\r\n Reserved1: Pointer; Reserved2: UINT): BOOL; stdcall;\r\n{$EXTERNALSYM SetupAddSectionToDiskSpaceListA}\r\nfunction SetupAddSectionToDiskSpaceListW(DiskSpace: HDSKSPC; InfHandle: HINF;\r\n ListInfHandle: HINF; const SectionName: PWideChar; Operation: UINT;\r\n Reserved1: Pointer; Reserved2: UINT): BOOL; stdcall;\r\n{$EXTERNALSYM SetupAddSectionToDiskSpaceListW}\r\nfunction SetupAddSectionToDiskSpaceList(DiskSpace: HDSKSPC; InfHandle: HINF;\r\n ListInfHandle: HINF; const SectionName: PTSTR; Operation: UINT;\r\n Reserved1: Pointer; Reserved2: UINT): BOOL; stdcall;\r\n{$EXTERNALSYM SetupAddSectionToDiskSpaceList}\r\n\r\nfunction SetupAddInstallSectionToDiskSpaceListA(DiskSpace: HDSKSPC;\r\n InfHandle: HINF; LayoutInfHandle: HINF; const SectionName: PAnsiChar;\r\n Reserved1: Pointer; Reserved2: UINT): BOOL; stdcall;\r\n{$EXTERNALSYM SetupAddInstallSectionToDiskSpaceListA}\r\nfunction SetupAddInstallSectionToDiskSpaceListW(DiskSpace: HDSKSPC;\r\n InfHandle: HINF; LayoutInfHandle: HINF; const SectionName: PWideChar;\r\n Reserved1: Pointer; Reserved2: UINT): BOOL; stdcall;\r\n{$EXTERNALSYM SetupAddInstallSectionToDiskSpaceListW}\r\nfunction SetupAddInstallSectionToDiskSpaceList(DiskSpace: HDSKSPC;\r\n InfHandle: HINF; LayoutInfHandle: HINF; const SectionName: PTSTR;\r\n Reserved1: Pointer; Reserved2: UINT): BOOL; stdcall;\r\n{$EXTERNALSYM SetupAddInstallSectionToDiskSpaceList}\r\n\r\nfunction SetupRemoveFromDiskSpaceListA(DiskSpace: HDSKSPC; const TargetFilespec: PAnsiChar;\r\n Operation: UINT; Reserved1: Pointer; Reserved2: UINT): BOOL; stdcall;\r\n{$EXTERNALSYM SetupRemoveFromDiskSpaceListA}\r\nfunction SetupRemoveFromDiskSpaceListW(DiskSpace: HDSKSPC; const TargetFilespec: PWideChar;\r\n Operation: UINT; Reserved1: Pointer; Reserved2: UINT): BOOL; stdcall;\r\n{$EXTERNALSYM SetupRemoveFromDiskSpaceListW}\r\nfunction SetupRemoveFromDiskSpaceList(DiskSpace: HDSKSPC; const TargetFilespec: PTSTR;\r\n Operation: UINT; Reserved1: Pointer; Reserved2: UINT): BOOL; stdcall;\r\n{$EXTERNALSYM SetupRemoveFromDiskSpaceList}\r\n\r\nfunction SetupRemoveSectionFromDiskSpaceListA(DiskSpace: HDSKSPC; InfHandle: HINF;\r\n ListInfHandle: HINF; const SectionName: PAnsiChar; Operation: UINT; Reserved1: Pointer;\r\n Reserved2: UINT): BOOL; stdcall;\r\n{$EXTERNALSYM SetupRemoveSectionFromDiskSpaceListA}\r\nfunction SetupRemoveSectionFromDiskSpaceListW(DiskSpace: HDSKSPC; InfHandle: HINF;\r\n ListInfHandle: HINF; const SectionName: PWideChar; Operation: UINT; Reserved1: Pointer;\r\n Reserved2: UINT): BOOL; stdcall;\r\n{$EXTERNALSYM SetupRemoveSectionFromDiskSpaceListW}\r\nfunction SetupRemoveSectionFromDiskSpaceList(DiskSpace: HDSKSPC; InfHandle: HINF;\r\n ListInfHandle: HINF; const SectionName: PTSTR; Operation: UINT; Reserved1: Pointer;\r\n Reserved2: UINT): BOOL; stdcall;\r\n{$EXTERNALSYM SetupRemoveSectionFromDiskSpaceList}\r\n\r\nfunction SetupRemoveInstallSectionFromDiskSpaceListA(DiskSpace: HDSKSPC;\r\n InfHandle: HINF; LayoutInfHandle: HINF; const SectionName: PAnsiChar;\r\n Reserved1: Pointer; Reserved2: UINT): BOOL; stdcall;\r\n{$EXTERNALSYM SetupRemoveInstallSectionFromDiskSpaceListA}\r\nfunction SetupRemoveInstallSectionFromDiskSpaceListW(DiskSpace: HDSKSPC;\r\n InfHandle: HINF; LayoutInfHandle: HINF; const SectionName: PWideChar;\r\n Reserved1: Pointer; Reserved2: UINT): BOOL; stdcall;\r\n{$EXTERNALSYM SetupRemoveInstallSectionFromDiskSpaceListW}\r\nfunction SetupRemoveInstallSectionFromDiskSpaceList(DiskSpace: HDSKSPC;\r\n InfHandle: HINF; LayoutInfHandle: HINF; const SectionName: PTSTR;\r\n Reserved1: Pointer; Reserved2: UINT): BOOL; stdcall;\r\n{$EXTERNALSYM SetupRemoveInstallSectionFromDiskSpaceList}\r\n\r\n//\r\n// Cabinet APIs\r\n//\r\n\r\nfunction SetupIterateCabinetA(const CabinetFile: PAnsiChar; Reserved: DWORD;\r\n MsgHandler: TSPFileCallbackA; Context: Pointer): BOOL; stdcall;\r\n{$EXTERNALSYM SetupIterateCabinetA}\r\nfunction SetupIterateCabinetW(const CabinetFile: PWideChar; Reserved: DWORD;\r\n MsgHandler: TSPFileCallbackW; Context: Pointer): BOOL; stdcall;\r\n{$EXTERNALSYM SetupIterateCabinetW}\r\nfunction SetupIterateCabinet(const CabinetFile: PTSTR; Reserved: DWORD;\r\n MsgHandler: TSPFileCallback; Context: Pointer): BOOL; stdcall;\r\n{$EXTERNALSYM SetupIterateCabinet}\r\n\r\nfunction SetupPromptReboot(FileQueue: HSPFILEQ; Owner: HWND; ScanOnly: BOOL): Integer; stdcall;\r\n{$EXTERNALSYM SetupPromptReboot}\r\n\r\nfunction SetupInitDefaultQueueCallback(OwnerWindow: HWND): Pointer; stdcall;\r\n{$EXTERNALSYM SetupInitDefaultQueueCallback}\r\n\r\nfunction SetupInitDefaultQueueCallbackEx(OwnerWindow: HWND; AlternateProgressWindow: HWND;\r\n ProgressMessage: UINT; Reserved1: DWORD; Reserved2: Pointer): Pointer; stdcall;\r\n{$EXTERNALSYM SetupInitDefaultQueueCallbackEx}\r\n\r\nprocedure SetupTermDefaultQueueCallback(Context: Pointer); stdcall;\r\n{$EXTERNALSYM SetupTermDefaultQueueCallback}\r\n\r\nfunction SetupDefaultQueueCallbackA(Context: Pointer; Notification: UINT;\r\n Param1, Param2: UINT_PTR): UINT; stdcall;\r\n{$EXTERNALSYM SetupDefaultQueueCallbackA}\r\nfunction SetupDefaultQueueCallbackW(Context: Pointer; Notification: UINT;\r\n Param1, Param2: UINT_PTR): UINT; stdcall;\r\n{$EXTERNALSYM SetupDefaultQueueCallbackW}\r\nfunction SetupDefaultQueueCallback(Context: Pointer; Notification: UINT;\r\n Param1, Param2: UINT_PTR): UINT; stdcall;\r\n{$EXTERNALSYM SetupDefaultQueueCallback}\r\n\r\n//\r\n// The INF may supply any arbitrary data type ordinal in the highword except\r\n// for the following: REG_NONE, REG_SZ, REG_EXPAND_SZ, REG_MULTI_SZ. If this\r\n// technique is used, then the data is given in binary format, one byte per\r\n// field.\r\n//\r\n\r\nfunction SetupInstallFromInfSectionA(Owner: HWND; InfHandle: HINF;\r\n const SectionName: PAnsiChar; Flags: UINT; RelativeKeyRoot: HKEY;\r\n const SourceRootPath: PAnsiChar; CopyFlags: UINT; MsgHandler: TSPFileCallbackA;\r\n Context: Pointer; DeviceInfoSet: HDEVINFO; DeviceIn: PSPDevInfoData): BOOL; stdcall;\r\n{$EXTERNALSYM SetupInstallFromInfSectionA}\r\nfunction SetupInstallFromInfSectionW(Owner: HWND; InfHandle: HINF;\r\n const SectionName: PWideChar; Flags: UINT; RelativeKeyRoot: HKEY;\r\n const SourceRootPath: PWideChar; CopyFlags: UINT; MsgHandler: TSPFileCallbackW;\r\n Context: Pointer; DeviceInfoSet: HDEVINFO; DeviceIn: PSPDevInfoData): BOOL; stdcall;\r\n{$EXTERNALSYM SetupInstallFromInfSectionW}\r\nfunction SetupInstallFromInfSection(Owner: HWND; InfHandle: HINF;\r\n const SectionName: PTSTR; Flags: UINT; RelativeKeyRoot: HKEY;\r\n const SourceRootPath: PTSTR; CopyFlags: UINT; MsgHandler: TSPFileCallback;\r\n Context: Pointer; DeviceInfoSet: HDEVINFO; DeviceIn: PSPDevInfoData): BOOL; stdcall;\r\n{$EXTERNALSYM SetupInstallFromInfSection}\r\n\r\nfunction SetupInstallFilesFromInfSectionA(InfHandle: HINF; LayoutInfHandle: HINF;\r\n FileQueue: HSPFILEQ; const SectionName, SourceRootPath: PAnsiChar;\r\n CopyFlags: UINT): BOOL; stdcall;\r\n{$EXTERNALSYM SetupInstallFilesFromInfSectionA}\r\nfunction SetupInstallFilesFromInfSectionW(InfHandle: HINF; LayoutInfHandle: HINF;\r\n FileQueue: HSPFILEQ; const SectionName, SourceRootPath: PWideChar;\r\n CopyFlags: UINT): BOOL; stdcall;\r\n{$EXTERNALSYM SetupInstallFilesFromInfSectionW}\r\nfunction SetupInstallFilesFromInfSection(InfHandle: HINF; LayoutInfHandle: HINF;\r\n FileQueue: HSPFILEQ; const SectionName, SourceRootPath: PTSTR;\r\n CopyFlags: UINT): BOOL; stdcall;\r\n{$EXTERNALSYM SetupInstallFilesFromInfSection}\r\n\r\nfunction SetupInstallServicesFromInfSectionA(InfHandle: HINF;\r\n const SectionName: PAnsiChar; Flags: DWORD): BOOL; stdcall;\r\n{$EXTERNALSYM SetupInstallServicesFromInfSectionA}\r\nfunction SetupInstallServicesFromInfSectionW(InfHandle: HINF;\r\n const SectionName: PWideChar; Flags: DWORD): BOOL; stdcall;\r\n{$EXTERNALSYM SetupInstallServicesFromInfSectionW}\r\nfunction SetupInstallServicesFromInfSection(InfHandle: HINF;\r\n const SectionName: PTSTR; Flags: DWORD): BOOL; stdcall;\r\n{$EXTERNALSYM SetupInstallServicesFromInfSection}\r\n\r\nfunction SetupInstallServicesFromInfSectionExA(InfHandle: HINF;\r\n const SectionName: PAnsiChar; Flags: DWORD; DeviceInfoSet: HDEVINFO;\r\n DeviceInfoData: TSPDevInfoData; Reserved1, Reserved2: Pointer): BOOL; stdcall;\r\n{$EXTERNALSYM SetupInstallServicesFromInfSectionExA}\r\nfunction SetupInstallServicesFromInfSectionExW(InfHandle: HINF;\r\n const SectionName: PWideChar; Flags: DWORD; DeviceInfoSet: HDEVINFO;\r\n DeviceInfoData: TSPDevInfoData; Reserved1, Reserved2: Pointer): BOOL; stdcall;\r\n{$EXTERNALSYM SetupInstallServicesFromInfSectionExW}\r\nfunction SetupInstallServicesFromInfSectionEx(InfHandle: HINF;\r\n const SectionName: PTSTR; Flags: DWORD; DeviceInfoSet: HDEVINFO;\r\n DeviceInfoData: TSPDevInfoData; Reserved1, Reserved2: Pointer): BOOL; stdcall;\r\n{$EXTERNALSYM SetupInstallServicesFromInfSectionEx}\r\n\r\n{$IFDEF WINXP_UP}\r\n//\r\n// High level routine, usually used via rundll32.dll\r\n// to perform right-click install action on INFs\r\n// May be called directly:\r\n//\r\n// wsprintf(CmdLineBuffer,TEXT(\"DefaultInstall 132 %s\"),InfPath);\r\n// InstallHinfSection(NULL,NULL,CmdLineBuffer,0);\r\n//\r\nprocedure InstallHinfSectionA(Window: HWND; ModuleHandle: HINST;\r\n CommandLine: PAnsiChar; ShowCommand: Integer); stdcall;\r\n{$EXTERNALSYM InstallHinfSectionA}\r\nprocedure InstallHinfSectionW(Window: HWND; ModuleHandle: HINST;\r\n CommandLine: PWideChar; ShowCommand: Integer); stdcall;\r\n{$EXTERNALSYM InstallHinfSectionW}\r\nprocedure InstallHinfSection(Window: HWND; ModuleHandle: HINST;\r\n CommandLine: PTSTR; ShowCommand: Integer); stdcall;\r\n{$EXTERNALSYM InstallHinfSection}\r\n{$ENDIF WINXP_UP}\r\n\r\n//\r\n// Define handle type for Setup file log.\r\n//\r\n\r\ntype\r\n HSPFILELOG = Pointer;\r\n {$EXTERNALSYM HSPFILELOG}\r\n\r\nfunction SetupInitializeFileLogA(const LogFileName: PAnsiChar; Flags: DWORD): HSPFILELOG; stdcall;\r\n{$EXTERNALSYM SetupInitializeFileLogA}\r\nfunction SetupInitializeFileLogW(const LogFileName: PWideChar; Flags: DWORD): HSPFILELOG; stdcall;\r\n{$EXTERNALSYM SetupInitializeFileLogW}\r\nfunction SetupInitializeFileLog(const LogFileName: PTSTR; Flags: DWORD): HSPFILELOG; stdcall;\r\n{$EXTERNALSYM SetupInitializeFileLog}\r\n\r\nfunction SetupTerminateFileLog(FileLogHandle: HSPFILELOG): BOOL; stdcall;\r\n{$EXTERNALSYM SetupTerminateFileLog}\r\n\r\nfunction SetupLogFileA(FileLogHandle: HSPFILELOG; const LogSectionName,\r\n SourceFilename, TargetFilename: PAnsiChar; Checksum: DWORD; DiskTagfile,\r\n DiskDescription, OtherInfo: PAnsiChar; Flags: DWORD): BOOL; stdcall;\r\n{$EXTERNALSYM SetupLogFileA}\r\nfunction SetupLogFileW(FileLogHandle: HSPFILELOG; const LogSectionName,\r\n SourceFilename, TargetFilename: PWideChar; Checksum: DWORD; DiskTagfile,\r\n DiskDescription, OtherInfo: PWideChar; Flags: DWORD): BOOL; stdcall;\r\n{$EXTERNALSYM SetupLogFileW}\r\nfunction SetupLogFile(FileLogHandle: HSPFILELOG; const LogSectionName,\r\n SourceFilename, TargetFilename: PTSTR; Checksum: DWORD; DiskTagfile,\r\n DiskDescription, OtherInfo: PTSTR; Flags: DWORD): BOOL; stdcall;\r\n{$EXTERNALSYM SetupLogFile}\r\n\r\nfunction SetupRemoveFileLogEntryA(FileLogHandle: HSPFILELOG;\r\n const LogSectionName: PAnsiChar; const TargetFilename: PAnsiChar): BOOL; stdcall;\r\n{$EXTERNALSYM SetupRemoveFileLogEntryA}\r\nfunction SetupRemoveFileLogEntryW(FileLogHandle: HSPFILELOG;\r\n const LogSectionName: PWideChar; const TargetFilename: PWideChar): BOOL; stdcall;\r\n{$EXTERNALSYM SetupRemoveFileLogEntryW}\r\nfunction SetupRemoveFileLogEntry(FileLogHandle: HSPFILELOG;\r\n const LogSectionName: PTSTR; const TargetFilename: PTSTR): BOOL; stdcall;\r\n{$EXTERNALSYM SetupRemoveFileLogEntry}\r\n\r\nfunction SetupQueryFileLogA(FileLogHandle: HSPFILELOG; const LogSectionName,\r\n TargetFilename: PAnsiChar; DesiredInfo: SetupFileLogInfo; DataOut: PAnsiChar;\r\n ReturnBufferSize: DWORD; RequiredSize: PDWORD): BOOL; stdcall;\r\n{$EXTERNALSYM SetupQueryFileLogA}\r\nfunction SetupQueryFileLogW(FileLogHandle: HSPFILELOG; const LogSectionName,\r\n TargetFilename: PWideChar; DesiredInfo: SetupFileLogInfo; DataOut: PWideChar;\r\n ReturnBufferSize: DWORD; RequiredSize: PDWORD): BOOL; stdcall;\r\n{$EXTERNALSYM SetupQueryFileLogW}\r\nfunction SetupQueryFileLog(FileLogHandle: HSPFILELOG; const LogSectionName,\r\n TargetFilename: PTSTR; DesiredInfo: SetupFileLogInfo; DataOut: PTSTR;\r\n ReturnBufferSize: DWORD; RequiredSize: PDWORD): BOOL; stdcall;\r\n{$EXTERNALSYM SetupQueryFileLog}\r\n\r\n//\r\n// Text logging APIs\r\n//\r\n\r\nfunction SetupOpenLog(Erase: BOOL): BOOL; stdcall;\r\n{$EXTERNALSYM SetupOpenLog}\r\n\r\nfunction SetupLogErrorA(const MessageString: PAnsiChar; Severity: LOGSEVERITY): BOOL; stdcall;\r\n{$EXTERNALSYM SetupLogErrorA}\r\nfunction SetupLogErrorW(const MessageString: PWideChar; Severity: LOGSEVERITY): BOOL; stdcall;\r\n{$EXTERNALSYM SetupLogErrorW}\r\nfunction SetupLogError(const MessageString: PTSTR; Severity: LOGSEVERITY): BOOL; stdcall;\r\n{$EXTERNALSYM SetupLogError}\r\n\r\nprocedure SetupCloseLog; stdcall;\r\n{$EXTERNALSYM SetupCloseLog}\r\n\r\n//\r\n// Backup Information API's\r\n//\r\n\r\n{$IFDEF WIN2000_UP}\r\nfunction SetupGetBackupInformationA(QueueHandle: HSPFILEQ;\r\n var BackupParams: TSPBackupQueueParamsA): BOOL; stdcall;\r\n{$EXTERNALSYM SetupGetBackupInformationA}\r\nfunction SetupGetBackupInformationW(QueueHandle: HSPFILEQ;\r\n var BackupParams: TSPBackupQueueParamsW): BOOL; stdcall;\r\n{$EXTERNALSYM SetupGetBackupInformationW}\r\nfunction SetupGetBackupInformation(QueueHandle: HSPFILEQ;\r\n var BackupParams: TSPBackupQueueParams): BOOL; stdcall;\r\n{$EXTERNALSYM SetupGetBackupInformation}\r\n{$ENDIF WIN2000_UP}\r\n\r\n{$IFDEF WINXP_UP}\r\n\r\nfunction SetupPrepareQueueForRestoreA(QueueHandle: HSPFILEQ;\r\n BackupPath: PAnsiChar; RestoreFlags: DWORD): BOOL; stdcall;\r\n{$EXTERNALSYM SetupPrepareQueueForRestoreA}\r\nfunction SetupPrepareQueueForRestoreW(QueueHandle: HSPFILEQ;\r\n BackupPath: PWideChar; RestoreFlags: DWORD): BOOL; stdcall;\r\n{$EXTERNALSYM SetupPrepareQueueForRestoreW}\r\nfunction SetupPrepareQueueForRestore(QueueHandle: HSPFILEQ;\r\n BackupPath: PTSTR; RestoreFlags: DWORD): BOOL; stdcall;\r\n{$EXTERNALSYM SetupPrepareQueueForRestore}\r\n\r\n//\r\n// Control forcing of Non-Interactive Mode\r\n// Overridden if SetupAPI is run in non-interactive window session\r\n//\r\n\r\nfunction SetupSetNonInteractiveMode(NonInteractiveFlag: BOOL): BOOL; stdcall;\r\n{$EXTERNALSYM SetupSetNonInteractiveMode}\r\nfunction SetupGetNonInteractiveMode: BOOL; stdcall;\r\n{$EXTERNALSYM SetupGetNonInteractiveMode}\r\n\r\n{$ENDIF WINXP_UP}\r\n\r\n//\r\n// Device Installer APIs\r\n//\r\n\r\nfunction SetupDiCreateDeviceInfoList(ClassGuid: PGUID; hwndParent: HWND): HDEVINFO; stdcall;\r\n{$EXTERNALSYM SetupDiCreateDeviceInfoList}\r\n\r\nfunction SetupDiCreateDeviceInfoListExA(ClassGuid: PGUID; hwndParent: HWND;\r\n const MachineName: PAnsiChar; Reserved: Pointer): HDEVINFO; stdcall;\r\n{$EXTERNALSYM SetupDiCreateDeviceInfoListExA}\r\nfunction SetupDiCreateDeviceInfoListExW(ClassGuid: PGUID; hwndParent: HWND;\r\n const MachineName: PWideChar; Reserved: Pointer): HDEVINFO; stdcall;\r\n{$EXTERNALSYM SetupDiCreateDeviceInfoListExW}\r\nfunction SetupDiCreateDeviceInfoListEx(ClassGuid: PGUID; hwndParent: HWND;\r\n const MachineName: PTSTR; Reserved: Pointer): HDEVINFO; stdcall;\r\n{$EXTERNALSYM SetupDiCreateDeviceInfoListEx}\r\n\r\nfunction SetupDiGetDeviceInfoListClass(DeviceInfoSet: HDEVINFO;\r\n var ClassGuid: TGUID): BOOL; stdcall;\r\n{$EXTERNALSYM SetupDiGetDeviceInfoListClass}\r\n\r\nfunction SetupDiGetDeviceInfoListDetailA(DeviceInfoSet: HDEVINFO;\r\n var DeviceInfoSetDetailData: TSPDevInfoListDetailDataA): BOOL; stdcall;\r\n{$EXTERNALSYM SetupDiGetDeviceInfoListDetailA}\r\nfunction SetupDiGetDeviceInfoListDetailW(DeviceInfoSet: HDEVINFO;\r\n var DeviceInfoSetDetailData: TSPDevInfoListDetailDataW): BOOL; stdcall;\r\n{$EXTERNALSYM SetupDiGetDeviceInfoListDetailW}\r\nfunction SetupDiGetDeviceInfoListDetail(DeviceInfoSet: HDEVINFO;\r\n var DeviceInfoSetDetailData: TSPDevInfoListDetailData): BOOL; stdcall;\r\n{$EXTERNALSYM SetupDiGetDeviceInfoListDetail}\r\n\r\nfunction SetupDiCreateDeviceInfoA(DeviceInfoSet: HDEVINFO; const DeviceName: PAnsiChar;\r\n var ClassGuid: TGUID; const DeviceDescription: PAnsiChar; hwndParent: HWND;\r\n CreationFlags: DWORD; DeviceInfoData: PSPDevInfoData): BOOL; stdcall;\r\n{$EXTERNALSYM SetupDiCreateDeviceInfoA}\r\nfunction SetupDiCreateDeviceInfoW(DeviceInfoSet: HDEVINFO; const DeviceName: PWideChar;\r\n var ClassGuid: TGUID; const DeviceDescription: PWideChar; hwndParent: HWND;\r\n CreationFlags: DWORD; DeviceInfoData: PSPDevInfoData): BOOL; stdcall;\r\n{$EXTERNALSYM SetupDiCreateDeviceInfoW}\r\nfunction SetupDiCreateDeviceInfo(DeviceInfoSet: HDEVINFO; const DeviceName: PTSTR;\r\n var ClassGuid: TGUID; const DeviceDescription: PTSTR; hwndParent: HWND;\r\n CreationFlags: DWORD; DeviceInfoData: PSPDevInfoData): BOOL; stdcall;\r\n{$EXTERNALSYM SetupDiCreateDeviceInfo}\r\n\r\n\r\nfunction SetupDiOpenDeviceInfoA(DeviceInfoSet: HDEVINFO;\r\n const DeviceInstanceId: PAnsiChar; hwndParent: HWND; OpenFlags: DWORD;\r\n DeviceInfoData: PSPDevInfoData): BOOL; stdcall;\r\n{$EXTERNALSYM SetupDiOpenDeviceInfoA}\r\nfunction SetupDiOpenDeviceInfoW(DeviceInfoSet: HDEVINFO;\r\n const DeviceInstanceId: PWideChar; hwndParent: HWND; OpenFlags: DWORD;\r\n DeviceInfoData: PSPDevInfoData): BOOL; stdcall;\r\n{$EXTERNALSYM SetupDiOpenDeviceInfoW}\r\nfunction SetupDiOpenDeviceInfo(DeviceInfoSet: HDEVINFO;\r\n const DeviceInstanceId: PTSTR; hwndParent: HWND; OpenFlags: DWORD;\r\n DeviceInfoData: PSPDevInfoData): BOOL; stdcall;\r\n{$EXTERNALSYM SetupDiOpenDeviceInfo}\r\n\r\nfunction SetupDiGetDeviceInstanceIdA(DeviceInfoSet: HDEVINFO;\r\n DeviceInfoData: PSPDevInfoData; DeviceInstanceId: PAnsiChar;\r\n DeviceInstanceIdSize: DWORD; RequiredSize: PDWORD): BOOL; stdcall;\r\n{$EXTERNALSYM SetupDiGetDeviceInstanceIdA}\r\nfunction SetupDiGetDeviceInstanceIdW(DeviceInfoSet: HDEVINFO;\r\n DeviceInfoData: PSPDevInfoData; DeviceInstanceId: PWideChar;\r\n DeviceInstanceIdSize: DWORD; RequiredSize: PDWORD): BOOL; stdcall;\r\n{$EXTERNALSYM SetupDiGetDeviceInstanceIdW}\r\nfunction SetupDiGetDeviceInstanceId(DeviceInfoSet: HDEVINFO;\r\n DeviceInfoData: PSPDevInfoData; DeviceInstanceId: PTSTR;\r\n DeviceInstanceIdSize: DWORD; RequiredSize: PDWORD): BOOL; stdcall;\r\n{$EXTERNALSYM SetupDiGetDeviceInstanceId}\r\n\r\nfunction SetupDiDeleteDeviceInfo(DeviceInfoSet: HDEVINFO;\r\n DeviceInfoData: PSPDevInfoData): BOOL; stdcall;\r\n{$EXTERNALSYM SetupDiDeleteDeviceInfo}\r\n\r\nfunction SetupDiEnumDeviceInfo(DeviceInfoSet: HDEVINFO;\r\n MemberIndex: DWORD; var DeviceInfoData: TSPDevInfoData): BOOL; stdcall;\r\n{$EXTERNALSYM SetupDiEnumDeviceInfo}\r\n\r\nfunction SetupDiDestroyDeviceInfoList(DeviceInfoSet: HDEVINFO): BOOL; stdcall;\r\n{$EXTERNALSYM SetupDiDestroyDeviceInfoList}\r\n\r\nfunction SetupDiEnumDeviceInterfaces(DeviceInfoSet: HDEVINFO;\r\n DeviceInfoData: PSPDevInfoData; const InterfaceClassGuid: TGUID;\r\n MemberIndex: DWORD; var DeviceInterfaceData: TSPDeviceInterfaceData): BOOL; stdcall;\r\n{$EXTERNALSYM SetupDiEnumDeviceInterfaces}\r\n\r\n//\r\n// Backward compatibility--do not use\r\n//\r\n\r\nfunction SetupDiEnumInterfaceDevice(DeviceInfoSet: HDEVINFO;\r\n DeviceInfoData: PSPDevInfoData; const InterfaceClassGuid: TGUID;\r\n MemberIndex: DWORD; var DeviceInterfaceData: TSPDeviceInterfaceData): BOOL; stdcall;\r\n{$EXTERNALSYM SetupDiEnumDeviceInterfaces}\r\n\r\nfunction SetupDiCreateDeviceInterfaceA(DeviceInfoSet: HDEVINFO;\r\n var DeviceInfoData: TSPDevInfoData; var InterfaceClassGuid: TGUID;\r\n const ReferenceString: PAnsiChar; CreationFlags: DWORD;\r\n DeviceInterfaceData: PSPDeviceInterfaceData): BOOL; stdcall;\r\n{$EXTERNALSYM SetupDiCreateDeviceInterfaceA}\r\nfunction SetupDiCreateDeviceInterfaceW(DeviceInfoSet: HDEVINFO;\r\n var DeviceInfoData: TSPDevInfoData; var InterfaceClassGuid: TGUID;\r\n const ReferenceString: PWideChar; CreationFlags: DWORD;\r\n DeviceInterfaceData: PSPDeviceInterfaceData): BOOL; stdcall;\r\n{$EXTERNALSYM SetupDiCreateDeviceInterfaceW}\r\nfunction SetupDiCreateDeviceInterface(DeviceInfoSet: HDEVINFO;\r\n var DeviceInfoData: TSPDevInfoData; var InterfaceClassGuid: TGUID;\r\n const ReferenceString: PTSTR; CreationFlags: DWORD;\r\n DeviceInterfaceData: PSPDeviceInterfaceData): BOOL; stdcall;\r\n{$EXTERNALSYM SetupDiCreateDeviceInterface}\r\n\r\n//\r\n// Backward compatibility--do not use.\r\n//\r\n\r\nfunction SetupDiCreateInterfaceDeviceA(DeviceInfoSet: HDEVINFO;\r\n var DeviceInfoData: TSPDevInfoData; var InterfaceClassGuid: TGUID;\r\n const ReferenceString: PAnsiChar; CreationFlags: DWORD;\r\n DeviceInterfaceData: PSPDeviceInterfaceData): BOOL; stdcall;\r\n{$EXTERNALSYM SetupDiCreateInterfaceDeviceA}\r\nfunction SetupDiCreateInterfaceDeviceW(DeviceInfoSet: HDEVINFO;\r\n var DeviceInfoData: TSPDevInfoData; var InterfaceClassGuid: TGUID;\r\n const ReferenceString: PWideChar; CreationFlags: DWORD;\r\n DeviceInterfaceData: PSPDeviceInterfaceData): BOOL; stdcall;\r\n{$EXTERNALSYM SetupDiCreateInterfaceDeviceW}\r\nfunction SetupDiCreateInterfaceDevice(DeviceInfoSet: HDEVINFO;\r\n var DeviceInfoData: TSPDevInfoData; var InterfaceClassGuid: TGUID;\r\n const ReferenceString: PTSTR; CreationFlags: DWORD;\r\n DeviceInterfaceData: PSPDeviceInterfaceData): BOOL; stdcall;\r\n{$EXTERNALSYM SetupDiCreateInterfaceDevice}\r\n\r\nfunction SetupDiOpenDeviceInterfaceA(DeviceInfoSet: HDEVINFO;\r\n const DevicePath: PAnsiChar; OpenFlags: DWORD;\r\n DeviceInterfaceData: PSPDeviceInterfaceData): BOOL; stdcall;\r\n{$EXTERNALSYM SetupDiOpenDeviceInterfaceA}\r\nfunction SetupDiOpenDeviceInterfaceW(DeviceInfoSet: HDEVINFO;\r\n const DevicePath: PWideChar; OpenFlags: DWORD;\r\n DeviceInterfaceData: PSPDeviceInterfaceData): BOOL; stdcall;\r\n{$EXTERNALSYM SetupDiOpenDeviceInterfaceW}\r\nfunction SetupDiOpenDeviceInterface(DeviceInfoSet: HDEVINFO;\r\n const DevicePath: PTSTR; OpenFlags: DWORD;\r\n DeviceInterfaceData: PSPDeviceInterfaceData): BOOL; stdcall;\r\n{$EXTERNALSYM SetupDiOpenDeviceInterface}\r\n\r\n//\r\n// Backward compatibility--do not use\r\n//\r\n\r\nfunction SetupDiOpenInterfaceDeviceA(DeviceInfoSet: HDEVINFO;\r\n const DevicePath: PAnsiChar; OpenFlags: DWORD;\r\n DeviceInterfaceData: PSPDeviceInterfaceData): BOOL; stdcall;\r\n{$EXTERNALSYM SetupDiOpenInterfaceDeviceA}\r\nfunction SetupDiOpenInterfaceDeviceW(DeviceInfoSet: HDEVINFO;\r\n const DevicePath: PWideChar; OpenFlags: DWORD;\r\n DeviceInterfaceData: PSPDeviceInterfaceData): BOOL; stdcall;\r\n{$EXTERNALSYM SetupDiOpenInterfaceDeviceW}\r\nfunction SetupDiOpenInterfaceDevice(DeviceInfoSet: HDEVINFO;\r\n const DevicePath: PTSTR; OpenFlags: DWORD;\r\n DeviceInterfaceData: PSPDeviceInterfaceData): BOOL; stdcall;\r\n{$EXTERNALSYM SetupDiOpenInterfaceDevice}\r\n\r\nfunction SetupDiGetDeviceInterfaceAlias(DeviceInfoSet: HDEVINFO;\r\n var DeviceInterfaceData: TSPDeviceInterfaceData; var AliasInterfaceClassGuid: TGUID;\r\n var AliasDeviceInterfaceData: TSPDeviceInterfaceData): BOOL; stdcall;\r\n{$EXTERNALSYM SetupDiGetDeviceInterfaceAlias}\r\n\r\n//\r\n// Backward compatibility--do not use.\r\n//\r\n\r\nfunction SetupDiGetInterfaceDeviceAlias(DeviceInfoSet: HDEVINFO;\r\n var DeviceInterfaceData: TSPDeviceInterfaceData;\r\n var AliasInterfaceClassGuid: TGUID;\r\n var AliasDeviceInterfaceData: TSPDeviceInterfaceData): BOOL; stdcall;\r\n{$EXTERNALSYM SetupDiGetInterfaceDeviceAlias}\r\n\r\nfunction SetupDiDeleteDeviceInterfaceData(DeviceInfoSet: HDEVINFO;\r\n var DeviceInterfaceData: TSPDeviceInterfaceData): BOOL; stdcall;\r\n{$EXTERNALSYM SetupDiDeleteDeviceInterfaceData}\r\n\r\n//\r\n// Backward compatibility--do not use.\r\n//\r\n\r\nfunction SetupDiDeleteInterfaceDeviceData(DeviceInfoSet: HDEVINFO;\r\n var DeviceInterfaceData: TSPDeviceInterfaceData): BOOL; stdcall;\r\n{$EXTERNALSYM SetupDiDeleteInterfaceDeviceData}\r\n\r\nfunction SetupDiRemoveDeviceInterface(DeviceInfoSet: HDEVINFO;\r\n var DeviceInterfaceData: TSPDeviceInterfaceData): BOOL; stdcall;\r\n{$EXTERNALSYM SetupDiRemoveDeviceInterface}\r\n\r\n//\r\n// Backward compatibility--do not use.\r\n//\r\n\r\nfunction SetupDiRemoveInterfaceDevice(DeviceInfoSet: HDEVINFO;\r\n var DeviceInterfaceData: TSPDeviceInterfaceData): BOOL; stdcall;\r\n{$EXTERNALSYM SetupDiRemoveInterfaceDevice}\r\n\r\nfunction SetupDiGetDeviceInterfaceDetailA(DeviceInfoSet: HDEVINFO;\r\n DeviceInterfaceData: PSPDeviceInterfaceData;\r\n DeviceInterfaceDetailData: PSPDeviceInterfaceDetailDataA;\r\n DeviceInterfaceDetailDataSize: DWORD; var RequiredSize: DWORD;\r\n Device: PSPDevInfoData): BOOL; stdcall;\r\n{$EXTERNALSYM SetupDiGetDeviceInterfaceDetailA}\r\nfunction SetupDiGetDeviceInterfaceDetailW(DeviceInfoSet: HDEVINFO;\r\n DeviceInterfaceData: PSPDeviceInterfaceData;\r\n DeviceInterfaceDetailData: PSPDeviceInterfaceDetailDataW;\r\n DeviceInterfaceDetailDataSize: DWORD; var RequiredSize: DWORD;\r\n Device: PSPDevInfoData): BOOL; stdcall;\r\n{$EXTERNALSYM SetupDiGetDeviceInterfaceDetailW}\r\nfunction SetupDiGetDeviceInterfaceDetail(DeviceInfoSet: HDEVINFO;\r\n DeviceInterfaceData: PSPDeviceInterfaceData;\r\n DeviceInterfaceDetailData: PSPDeviceInterfaceDetailData;\r\n DeviceInterfaceDetailDataSize: DWORD; var RequiredSize: DWORD;\r\n Device: PSPDevInfoData): BOOL; stdcall;\r\n{$EXTERNALSYM SetupDiGetDeviceInterfaceDetail}\r\n\r\n//\r\n// Backward compatibility--do not use.\r\n//\r\n\r\nfunction SetupDiGetInterfaceDeviceDetailA(DeviceInfoSet: HDEVINFO;\r\n DeviceInterfaceData: PSPDeviceInterfaceData;\r\n DeviceInterfaceDetailData: PSPDeviceInterfaceDetailDataA;\r\n DeviceInterfaceDetailDataSize: DWORD; RequiredSize: PDWORD;\r\n Device: PSPDevInfoData): BOOL; stdcall;\r\n{$EXTERNALSYM SetupDiGetInterfaceDeviceDetailA}\r\nfunction SetupDiGetInterfaceDeviceDetailW(DeviceInfoSet: HDEVINFO;\r\n DeviceInterfaceData: PSPDeviceInterfaceData;\r\n DeviceInterfaceDetailData: PSPDeviceInterfaceDetailDataW;\r\n DeviceInterfaceDetailDataSize: DWORD; RequiredSize: PDWORD;\r\n Device: PSPDevInfoData): BOOL; stdcall;\r\n{$EXTERNALSYM SetupDiGetInterfaceDeviceDetailW}\r\nfunction SetupDiGetInterfaceDeviceDetail(DeviceInfoSet: HDEVINFO;\r\n DeviceInterfaceData: PSPDeviceInterfaceData;\r\n DeviceInterfaceDetailData: PSPDeviceInterfaceDetailData;\r\n DeviceInterfaceDetailDataSize: DWORD; RequiredSize: PDWORD;\r\n Device: PSPDevInfoData): BOOL; stdcall;\r\n{$EXTERNALSYM SetupDiGetInterfaceDeviceDetail}\r\n\r\n//\r\n// Default install handler for DIF_INSTALLINTERFACES.\r\n//\r\n\r\nfunction SetupDiInstallDeviceInterfaces(DeviceInfoSet: HDEVINFO;\r\n var DeviceInfoData: TSPDevInfoData): BOOL; stdcall;\r\n{$EXTERNALSYM SetupDiInstallDeviceInterfaces}\r\n\r\n//\r\n// Backward compatibility--do not use.\r\n//\r\n\r\nfunction SetupDiInstallInterfaceDevices(DeviceInfoSet: HDEVINFO;\r\n var DeviceInfoData: TSPDevInfoData): BOOL; stdcall;\r\n{$EXTERNALSYM SetupDiInstallInterfaceDevices}\r\n\r\n{$IFDEF WINXP_UP}\r\nfunction SetupDiSetDeviceInterfaceDefault(DeviceInfoSet: HDEVINFO;\r\n var DeviceInterfaceData: TSPDeviceInterfaceData; Flags: DWORD;\r\n Reserved: Pointer): BOOL; stdcall;\r\n{$EXTERNALSYM SetupDiSetDeviceInterfaceDefault}\r\n{$ENDIF WINXP_UP}\r\n\r\n//\r\n// Default install handler for DIF_REGISTERDEVICE\r\n//\r\n\r\nfunction SetupDiRegisterDeviceInfo(DeviceInfoSet: HDEVINFO;\r\n var DeviceInfoData: TSPDevInfoData; Flags: DWORD; CompareProc: TSPDetSigCmpProc;\r\n CompareContext: Pointer; DupDeviceInfoData: PSPDevInfoData): BOOL; stdcall;\r\n{$EXTERNALSYM SetupDiRegisterDeviceInfo}\r\n\r\nfunction SetupDiBuildDriverInfoList(DeviceInfoSet: HDEVINFO;\r\n DeviceInfoData: PSPDevInfoData; DriverType: DWORD): BOOL; stdcall;\r\n{$EXTERNALSYM SetupDiBuildDriverInfoList}\r\n\r\nfunction SetupDiCancelDriverInfoSearch(DeviceInfoSet: HDEVINFO): BOOL; stdcall;\r\n{$EXTERNALSYM SetupDiCancelDriverInfoSearch}\r\n\r\nfunction SetupDiEnumDriverInfoA(DeviceInfoSet: HDEVINFO;\r\n DeviceInfoData: PSPDevInfoData; DriverType: DWORD; MemberIndex: DWORD;\r\n var DriverInfoData: TSPDrvInfoDataA): BOOL; stdcall;\r\n{$EXTERNALSYM SetupDiEnumDriverInfoA}\r\nfunction SetupDiEnumDriverInfoW(DeviceInfoSet: HDEVINFO;\r\n DeviceInfoData: PSPDevInfoData; DriverType: DWORD; MemberIndex: DWORD;\r\n var DriverInfoData: TSPDrvInfoDataW): BOOL; stdcall;\r\n{$EXTERNALSYM SetupDiEnumDriverInfoW}\r\nfunction SetupDiEnumDriverInfo(DeviceInfoSet: HDEVINFO;\r\n DeviceInfoData: PSPDevInfoData; DriverType: DWORD; MemberIndex: DWORD;\r\n var DriverInfoData: TSPDrvInfoData): BOOL; stdcall;\r\n{$EXTERNALSYM SetupDiEnumDriverInfo}\r\n\r\nfunction SetupDiGetSelectedDriverA(DeviceInfoSet: HDEVINFO;\r\n DeviceInfoData: PSPDevInfoData; var DriverInfoData: TSPDrvInfoDataA): BOOL; stdcall;\r\n{$EXTERNALSYM SetupDiGetSelectedDriverA}\r\nfunction SetupDiGetSelectedDriverW(DeviceInfoSet: HDEVINFO;\r\n DeviceInfoData: PSPDevInfoData; var DriverInfoData: TSPDrvInfoDataW): BOOL; stdcall;\r\n{$EXTERNALSYM SetupDiGetSelectedDriverW}\r\nfunction SetupDiGetSelectedDriver(DeviceInfoSet: HDEVINFO;\r\n DeviceInfoData: PSPDevInfoData; var DriverInfoData: TSPDrvInfoData): BOOL; stdcall;\r\n{$EXTERNALSYM SetupDiGetSelectedDriver}\r\n\r\nfunction SetupDiSetSelectedDriverA(DeviceInfoSet: HDEVINFO;\r\n DeviceInfoData: PSPDevInfoData; DriverInfoData: PSPDrvInfoDataA): BOOL; stdcall;\r\n{$EXTERNALSYM SetupDiSetSelectedDriverA}\r\nfunction SetupDiSetSelectedDriverW(DeviceInfoSet: HDEVINFO;\r\n DeviceInfoData: PSPDevInfoData; DriverInfoData: PSPDrvInfoDataW): BOOL; stdcall;\r\n{$EXTERNALSYM SetupDiSetSelectedDriverW}\r\nfunction SetupDiSetSelectedDriver(DeviceInfoSet: HDEVINFO;\r\n DeviceInfoData: PSPDevInfoData; DriverInfoData: PSPDrvInfoData): BOOL; stdcall;\r\n{$EXTERNALSYM SetupDiSetSelectedDriver}\r\n\r\nfunction SetupDiGetDriverInfoDetailA(DeviceInfoSet: HDEVINFO;\r\n DeviceInfoData: PSPDevInfoData; var DriverInfoData: TSPDrvInfoDataA;\r\n DriverInfoDetailData: PSPDrvInfoDetailDataA; DriverInfoDetailDataSize: DWORD;\r\n RequiredSize: PDWORD): BOOL; stdcall;\r\n{$EXTERNALSYM SetupDiGetDriverInfoDetailA}\r\nfunction SetupDiGetDriverInfoDetailW(DeviceInfoSet: HDEVINFO;\r\n DeviceInfoData: PSPDevInfoData; var DriverInfoData: TSPDrvInfoDataW;\r\n DriverInfoDetailData: PSPDrvInfoDetailDataW; DriverInfoDetailDataSize: DWORD;\r\n RequiredSize: PDWORD): BOOL; stdcall;\r\n{$EXTERNALSYM SetupDiGetDriverInfoDetailW}\r\nfunction SetupDiGetDriverInfoDetail(DeviceInfoSet: HDEVINFO;\r\n DeviceInfoData: PSPDevInfoData; var DriverInfoData: TSPDrvInfoData;\r\n DriverInfoDetailData: PSPDrvInfoDetailData; DriverInfoDetailDataSize: DWORD;\r\n RequiredSize: PDWORD): BOOL; stdcall;\r\n{$EXTERNALSYM SetupDiGetDriverInfoDetail}\r\n\r\nfunction SetupDiDestroyDriverInfoList(DeviceInfoSet: HDEVINFO;\r\n DeviceInfoData: PSPDevInfoData; DriverType: DWORD): BOOL; stdcall;\r\n{$EXTERNALSYM SetupDiDestroyDriverInfoList}\r\n\r\nfunction SetupDiGetClassDevsA(ClassGuid: PGUID; const Enumerator: PAnsiChar;\r\n hwndParent: HWND; Flags: DWORD): HDEVINFO; stdcall;\r\n{$EXTERNALSYM SetupDiGetClassDevsA}\r\nfunction SetupDiGetClassDevsW(ClassGuid: PGUID; const Enumerator: PWideChar;\r\n hwndParent: HWND; Flags: DWORD): HDEVINFO; stdcall;\r\n{$EXTERNALSYM SetupDiGetClassDevsW}\r\nfunction SetupDiGetClassDevs(ClassGuid: PGUID; const Enumerator: PTSTR;\r\n hwndParent: HWND; Flags: DWORD): HDEVINFO; stdcall;\r\n{$EXTERNALSYM SetupDiGetClassDevs}\r\n\r\nfunction SetupDiGetClassDevsExA(ClassGuid: PGUID; const Enumerator: PAnsiChar;\r\n hwndParent: HWND; Flags: DWORD; DeviceInfoSet: HDEVINFO; const MachineName: PAnsiChar;\r\n Reserved: Pointer): HDEVINFO; stdcall;\r\n{$EXTERNALSYM SetupDiGetClassDevsExA}\r\nfunction SetupDiGetClassDevsExW(ClassGuid: PGUID; const Enumerator: PWideChar;\r\n hwndParent: HWND; Flags: DWORD; DeviceInfoSet: HDEVINFO; const MachineName: PWideChar;\r\n Reserved: Pointer): HDEVINFO; stdcall;\r\n{$EXTERNALSYM SetupDiGetClassDevsExW}\r\nfunction SetupDiGetClassDevsEx(ClassGuid: PGUID; const Enumerator: PTSTR;\r\n hwndParent: HWND; Flags: DWORD; DeviceInfoSet: HDEVINFO; const MachineName: PTSTR;\r\n Reserved: Pointer): HDEVINFO; stdcall;\r\n{$EXTERNALSYM SetupDiGetClassDevsEx}\r\n\r\nfunction SetupDiGetINFClassA(const InfName: PAnsiChar; var ClassGuid: TGUID;\r\n ClassName: PAnsiChar; ClassNameSize: DWORD; RequiredSize: PDWORD): BOOL; stdcall;\r\n{$EXTERNALSYM SetupDiGetINFClassA}\r\nfunction SetupDiGetINFClassW(const InfName: PWideChar; var ClassGuid: TGUID;\r\n ClassName: PWideChar; ClassNameSize: DWORD; RequiredSize: PDWORD): BOOL; stdcall;\r\n{$EXTERNALSYM SetupDiGetINFClassW}\r\nfunction SetupDiGetINFClass(const InfName: PTSTR; var ClassGuid: TGUID;\r\n ClassName: PTSTR; ClassNameSize: DWORD; RequiredSize: PDWORD): BOOL; stdcall;\r\n{$EXTERNALSYM SetupDiGetINFClass}\r\n\r\nfunction SetupDiBuildClassInfoList(Flags: DWORD; ClassGuidList: PGUID;\r\n ClassGuidListSize: DWORD; var RequiredSize: DWORD): BOOL; stdcall;\r\n{$EXTERNALSYM SetupDiBuildClassInfoList}\r\n\r\nfunction SetupDiBuildClassInfoListExA(Flags: DWORD; ClassGuidList: PGUID;\r\n ClassGuidListSize: DWORD; var RequiredSize: DWORD; const MachineName: PAnsiChar;\r\n Reserved: Pointer): BOOL; stdcall;\r\n{$EXTERNALSYM SetupDiBuildClassInfoListExA}\r\nfunction SetupDiBuildClassInfoListExW(Flags: DWORD; ClassGuidList: PGUID;\r\n ClassGuidListSize: DWORD; var RequiredSize: DWORD; const MachineName: PWideChar;\r\n Reserved: Pointer): BOOL; stdcall;\r\n{$EXTERNALSYM SetupDiBuildClassInfoListExW}\r\nfunction SetupDiBuildClassInfoListEx(Flags: DWORD; ClassGuidList: PGUID;\r\n ClassGuidListSize: DWORD; var RequiredSize: DWORD; const MachineName: PTSTR;\r\n Reserved: Pointer): BOOL; stdcall;\r\n{$EXTERNALSYM SetupDiBuildClassInfoListEx}\r\n\r\nfunction SetupDiGetClassDescriptionA(var ClassGuid: TGUID; ClassDescription: PAnsiChar;\r\n ClassDescriptionSize: DWORD; var RequiredSize: DWORD): BOOL; stdcall;\r\n{$EXTERNALSYM SetupDiGetClassDescriptionA}\r\nfunction SetupDiGetClassDescriptionW(var ClassGuid: TGUID; ClassDescription: PWideChar;\r\n ClassDescriptionSize: DWORD; var RequiredSize: DWORD): BOOL; stdcall;\r\n{$EXTERNALSYM SetupDiGetClassDescriptionW}\r\nfunction SetupDiGetClassDescription(var ClassGuid: TGUID; ClassDescription: PTSTR;\r\n ClassDescriptionSize: DWORD; var RequiredSize: DWORD): BOOL; stdcall;\r\n{$EXTERNALSYM SetupDiGetClassDescription}\r\n\r\nfunction SetupDiGetClassDescriptionExA(var ClassGuid: TGUID;\r\n ClassDescription: PAnsiChar; ClassDescriptionSize: DWORD; var RequiredSize: DWORD;\r\n const MachineName: PAnsiChar; Reserved: Pointer): BOOL; stdcall;\r\n{$EXTERNALSYM SetupDiGetClassDescriptionExA}\r\nfunction SetupDiGetClassDescriptionExW(var ClassGuid: TGUID;\r\n ClassDescription: PWideChar; ClassDescriptionSize: DWORD; var RequiredSize: DWORD;\r\n const MachineName: PWideChar; Reserved: Pointer): BOOL; stdcall;\r\n{$EXTERNALSYM SetupDiGetClassDescriptionExW}\r\nfunction SetupDiGetClassDescriptionEx(var ClassGuid: TGUID;\r\n ClassDescription: PTSTR; ClassDescriptionSize: DWORD; var RequiredSize: DWORD;\r\n const MachineName: PTSTR; Reserved: Pointer): BOOL; stdcall;\r\n{$EXTERNALSYM SetupDiGetClassDescriptionEx}\r\n\r\nfunction SetupDiCallClassInstaller(InstallFunction: DI_FUNCTION;\r\n DeviceInfoSet: HDEVINFO; DeviceInfoData: PSPDevInfoData): BOOL; stdcall;\r\n{$EXTERNALSYM SetupDiCallClassInstaller}\r\n\r\n//\r\n// Default install handler for DIF_SELECTDEVICE\r\n//\r\n\r\nfunction SetupDiSelectDevice(DeviceInfoSet: HDEVINFO;\r\n DeviceInfoData: PSPDevInfoData): BOOL; stdcall;\r\n{$EXTERNALSYM SetupDiSelectDevice}\r\n\r\n//\r\n// Default install handler for DIF_SELECTBESTCOMPATDRV\r\n//\r\n\r\nfunction SetupDiSelectBestCompatDrv(DeviceInfoSet: HDEVINFO;\r\n DeviceInfoData: PSPDevInfoData): BOOL; stdcall;\r\n{$EXTERNALSYM SetupDiSelectBestCompatDrv}\r\n\r\n//\r\n// Default install handler for DIF_INSTALLDEVICE\r\n//\r\nfunction SetupDiInstallDevice(DeviceInfoSet: HDEVINFO;\r\n var DeviceInfoData: TSPDevInfoData): BOOL; stdcall;\r\n{$EXTERNALSYM SetupDiInstallDevice}\r\n\r\n//\r\n// Default install handler for DIF_INSTALLDEVICEFILES\r\n//\r\n\r\nfunction SetupDiInstallDriverFiles(DeviceInfoSet: HDEVINFO;\r\n var DeviceInfoData: TSPDevInfoData): BOOL; stdcall;\r\n{$EXTERNALSYM SetupDiInstallDriverFiles}\r\n\r\n//\r\n// Default install handler for DIF_REGISTER_COINSTALLERS\r\n//\r\nfunction SetupDiRegisterCoDeviceInstallers(DeviceInfoSet: HDEVINFO;\r\n var DeviceInfoData: TSPDevInfoData): BOOL; stdcall;\r\n{$EXTERNALSYM SetupDiRegisterCoDeviceInstallers}\r\n\r\n//\r\n// Default install handler for DIF_REMOVE\r\n//\r\n\r\nfunction SetupDiRemoveDevice(DeviceInfoSet: HDEVINFO;\r\n var DeviceInfoData: TSPDevInfoData): BOOL; stdcall;\r\n{$EXTERNALSYM SetupDiRemoveDevice}\r\n\r\n//\r\n// Default install handler for DIF_UNREMOVE\r\n//\r\n\r\nfunction SetupDiUnremoveDevice(DeviceInfoSet: HDEVINFO;\r\n var DeviceInfoData: TSPDevInfoData): BOOL; stdcall;\r\n{$EXTERNALSYM SetupDiUnremoveDevice}\r\n\r\n//\r\n// Default install handler for DIF_MOVEDEVICE\r\n//\r\nfunction SetupDiMoveDuplicateDevice(DeviceInfoSet: HDEVINFO;\r\n var DestinationDeviceInfoData: TSPDevInfoData): BOOL; stdcall;\r\n{$EXTERNALSYM SetupDiMoveDuplicateDevice}\r\n\r\n//\r\n// Default install handler for DIF_PROPERTYCHANGE\r\n//\r\nfunction SetupDiChangeState(DeviceInfoSet: HDEVINFO;\r\n var DeviceInfoData: TSPDevInfoData): BOOL; stdcall;\r\n{$EXTERNALSYM SetupDiChangeState}\r\n\r\nfunction SetupDiInstallClassA(hwndParent: HWND; const InfFileName: PAnsiChar;\r\n Flags: DWORD; FileQueue: HSPFILEQ): BOOL; stdcall;\r\n{$EXTERNALSYM SetupDiInstallClassA}\r\nfunction SetupDiInstallClassW(hwndParent: HWND; const InfFileName: PWideChar;\r\n Flags: DWORD; FileQueue: HSPFILEQ): BOOL; stdcall;\r\n{$EXTERNALSYM SetupDiInstallClassW}\r\nfunction SetupDiInstallClass(hwndParent: HWND; const InfFileName: PTSTR;\r\n Flags: DWORD; FileQueue: HSPFILEQ): BOOL; stdcall;\r\n{$EXTERNALSYM SetupDiInstallClass}\r\n\r\nfunction SetupDiInstallClassExA(hwndParent: HWND; const InfFileName: PAnsiChar;\r\n Flags: DWORD; FileQueue: HSPFILEQ; InterfaceClassGuid: PGUID; Reserved1,\r\n Reserved2: Pointer): BOOL; stdcall;\r\n{$EXTERNALSYM SetupDiInstallClassExA}\r\nfunction SetupDiInstallClassExW(hwndParent: HWND; const InfFileName: PWideChar;\r\n Flags: DWORD; FileQueue: HSPFILEQ; InterfaceClassGuid: PGUID; Reserved1,\r\n Reserved2: Pointer): BOOL; stdcall;\r\n{$EXTERNALSYM SetupDiInstallClassExW}\r\nfunction SetupDiInstallClassEx(hwndParent: HWND; const InfFileName: PTSTR;\r\n Flags: DWORD; FileQueue: HSPFILEQ; InterfaceClassGuid: PGUID; Reserved1,\r\n Reserved2: Pointer): BOOL; stdcall;\r\n{$EXTERNALSYM SetupDiInstallClassEx}\r\n\r\nfunction SetupDiOpenClassRegKey(ClassGuid: PGUID; samDesired: REGSAM): HKEY; stdcall;\r\n{$EXTERNALSYM SetupDiOpenClassRegKey}\r\n\r\nfunction SetupDiOpenClassRegKeyExA(ClassGuid: PGUID; samDesired: REGSAM;\r\n Flags: DWORD; const MachineName: PAnsiChar; Reserved: Pointer): HKEY; stdcall;\r\n{$EXTERNALSYM SetupDiOpenClassRegKeyExA}\r\nfunction SetupDiOpenClassRegKeyExW(ClassGuid: PGUID; samDesired: REGSAM;\r\n Flags: DWORD; const MachineName: PWideChar; Reserved: Pointer): HKEY; stdcall;\r\n{$EXTERNALSYM SetupDiOpenClassRegKeyExW}\r\nfunction SetupDiOpenClassRegKeyEx(ClassGuid: PGUID; samDesired: REGSAM;\r\n Flags: DWORD; const MachineName: PTSTR; Reserved: Pointer): HKEY; stdcall;\r\n{$EXTERNALSYM SetupDiOpenClassRegKeyEx}\r\n\r\nfunction SetupDiCreateDeviceInterfaceRegKeyA(DeviceInfoSet: HDEVINFO;\r\n var DeviceInterfaceData: TSPDeviceInterfaceData; Reserved: DWORD;\r\n samDesired: REGSAM; InfHandle: HINF; const InfSectionName: PAnsiChar): HKEY; stdcall;\r\n{$EXTERNALSYM SetupDiCreateDeviceInterfaceRegKeyA}\r\nfunction SetupDiCreateDeviceInterfaceRegKeyW(DeviceInfoSet: HDEVINFO;\r\n var DeviceInterfaceData: TSPDeviceInterfaceData; Reserved: DWORD;\r\n samDesired: REGSAM; InfHandle: HINF; const InfSectionName: PWideChar): HKEY; stdcall;\r\n{$EXTERNALSYM SetupDiCreateDeviceInterfaceRegKeyW}\r\nfunction SetupDiCreateDeviceInterfaceRegKey(DeviceInfoSet: HDEVINFO;\r\n var DeviceInterfaceData: TSPDeviceInterfaceData; Reserved: DWORD;\r\n samDesired: REGSAM; InfHandle: HINF; const InfSectionName: PTSTR): HKEY; stdcall;\r\n{$EXTERNALSYM SetupDiCreateDeviceInterfaceRegKey}\r\n\r\n//\r\n// Backward compatibility--do not use.\r\n//\r\n\r\nfunction SetupDiCreateInterfaceDeviceRegKeyA(DeviceInfoSet: HDEVINFO;\r\n var DeviceInterfaceData: TSPDeviceInterfaceData; Reserved: DWORD;\r\n samDesired: REGSAM; InfHandle: HINF; const InfSectionName: PAnsiChar): HKEY; stdcall;\r\n{$EXTERNALSYM SetupDiCreateInterfaceDeviceRegKeyA}\r\nfunction SetupDiCreateInterfaceDeviceRegKeyW(DeviceInfoSet: HDEVINFO;\r\n var DeviceInterfaceData: TSPDeviceInterfaceData; Reserved: DWORD;\r\n samDesired: REGSAM; InfHandle: HINF; const InfSectionName: PWideChar): HKEY; stdcall;\r\n{$EXTERNALSYM SetupDiCreateInterfaceDeviceRegKeyW}\r\nfunction SetupDiCreateInterfaceDeviceRegKey(DeviceInfoSet: HDEVINFO;\r\n var DeviceInterfaceData: TSPDeviceInterfaceData; Reserved: DWORD;\r\n samDesired: REGSAM; InfHandle: HINF; const InfSectionName: PTSTR): HKEY; stdcall;\r\n{$EXTERNALSYM SetupDiCreateInterfaceDeviceRegKey}\r\n\r\nfunction SetupDiOpenDeviceInterfaceRegKey(DeviceInfoSet: HDEVINFO;\r\n var DeviceInterfaceData: TSPDeviceInterfaceData; Reserved: DWORD;\r\n samDesired: REGSAM): HKEY; stdcall;\r\n{$EXTERNALSYM SetupDiOpenDeviceInterfaceRegKey}\r\n\r\n//\r\n// Backward compatibility--do not use.\r\n//\r\n\r\nfunction SetupDiOpenInterfaceDeviceRegKey(DeviceInfoSet: HDEVINFO;\r\n var DeviceInterfaceData: TSPDeviceInterfaceData; Reserved: DWORD;\r\n samDesired: REGSAM): HKEY; stdcall;\r\n{$EXTERNALSYM SetupDiOpenInterfaceDeviceRegKey}\r\n\r\nfunction SetupDiDeleteDeviceInterfaceRegKey(DeviceInfoSet: HDEVINFO;\r\n var DeviceInterfaceData: TSPDeviceInterfaceData; Reserved: DWORD): BOOL; stdcall;\r\n{$EXTERNALSYM SetupDiDeleteDeviceInterfaceRegKey}\r\n\r\n//\r\n// Backward compatibility--do not use.\r\n//\r\n\r\nfunction SetupDiDeleteInterfaceDeviceRegKey(DeviceInfoSet: HDEVINFO;\r\n var DeviceInterfaceData: TSPDeviceInterfaceData; Reserved: DWORD): BOOL; stdcall;\r\n{$EXTERNALSYM SetupDiDeleteInterfaceDeviceRegKey}\r\n\r\nfunction SetupDiCreateDevRegKeyA(DeviceInfoSet: HDEVINFO;\r\n var DeviceInfoData: TSPDevInfoData; Scope, HwProfile, KeyType: DWORD;\r\n InfHandle: HINF; const InfSectionName: PAnsiChar): HKEY; stdcall;\r\n{$EXTERNALSYM SetupDiCreateDevRegKeyA}\r\nfunction SetupDiCreateDevRegKeyW(DeviceInfoSet: HDEVINFO;\r\n var DeviceInfoData: TSPDevInfoData; Scope, HwProfile, KeyType: DWORD;\r\n InfHandle: HINF; const InfSectionName: PWideChar): HKEY; stdcall;\r\n{$EXTERNALSYM SetupDiCreateDevRegKeyW}\r\nfunction SetupDiCreateDevRegKey(DeviceInfoSet: HDEVINFO;\r\n var DeviceInfoData: TSPDevInfoData; Scope, HwProfile, KeyType: DWORD;\r\n InfHandle: HINF; const InfSectionName: PTSTR): HKEY; stdcall;\r\n{$EXTERNALSYM SetupDiCreateDevRegKey}\r\n\r\n\r\nfunction SetupDiOpenDevRegKey(DeviceInfoSet: HDEVINFO;\r\n var DeviceInfoData: TSPDevInfoData; Scope, HwProfile, KeyType: DWORD;\r\n samDesired: REGSAM): HKEY; stdcall;\r\n{$EXTERNALSYM SetupDiOpenDevRegKey}\r\n\r\nfunction SetupDiDeleteDevRegKey(DeviceInfoSet: HDEVINFO;\r\n var DeviceInfoData: TSPDevInfoData; Scope, HwProfile,\r\n KeyType: DWORD): BOOL; stdcall;\r\n{$EXTERNALSYM SetupDiDeleteDevRegKey}\r\n\r\nfunction SetupDiGetHwProfileList(HwProfileList: PDWORD; HwProfileListSize: DWORD;\r\n var RequiredSize: DWORD; CurrentlyActiveIndex: PDWORD): BOOL; stdcall;\r\n{$EXTERNALSYM SetupDiGetHwProfileList}\r\n\r\nfunction SetupDiGetHwProfileListExA(HwProfileList: PDWORD;\r\n HwProfileListSize: DWORD; var RequiredSize: DWORD; CurrentlyActiveIndex: PDWORD;\r\n const MachineName: PAnsiChar; Reserved: Pointer): BOOL; stdcall;\r\n{$EXTERNALSYM SetupDiGetHwProfileListExA}\r\nfunction SetupDiGetHwProfileListExW(HwProfileList: PDWORD;\r\n HwProfileListSize: DWORD; var RequiredSize: DWORD; CurrentlyActiveIndex: PDWORD;\r\n const MachineName: PWideChar; Reserved: Pointer): BOOL; stdcall;\r\n{$EXTERNALSYM SetupDiGetHwProfileListExW}\r\nfunction SetupDiGetHwProfileListEx(HwProfileList: PDWORD;\r\n HwProfileListSize: DWORD; var RequiredSize: DWORD; CurrentlyActiveIndex: PDWORD;\r\n const MachineName: PTSTR; Reserved: Pointer): BOOL; stdcall;\r\n{$EXTERNALSYM SetupDiGetHwProfileListEx}\r\n\r\nfunction SetupDiGetDeviceRegistryPropertyA(DeviceInfoSet: HDEVINFO;\r\n const DeviceInfoData: TSPDevInfoData; Property_: DWORD;\r\n var PropertyRegDataType: DWORD; PropertyBuffer: PBYTE; PropertyBufferSize: DWORD;\r\n var RequiredSize: DWORD): BOOL; stdcall;\r\n{$EXTERNALSYM SetupDiGetDeviceRegistryPropertyA}\r\nfunction SetupDiGetDeviceRegistryPropertyW(DeviceInfoSet: HDEVINFO;\r\n const DeviceInfoData: TSPDevInfoData; Property_: DWORD;\r\n var PropertyRegDataType: DWORD; PropertyBuffer: PBYTE; PropertyBufferSize: DWORD;\r\n var RequiredSize: DWORD): BOOL; stdcall;\r\n{$EXTERNALSYM SetupDiGetDeviceRegistryPropertyW}\r\nfunction SetupDiGetDeviceRegistryProperty(DeviceInfoSet: HDEVINFO;\r\n const DeviceInfoData: TSPDevInfoData; Property_: DWORD;\r\n var PropertyRegDataType: DWORD; PropertyBuffer: PBYTE; PropertyBufferSize: DWORD;\r\n var RequiredSize: DWORD): BOOL; stdcall;\r\n{$EXTERNALSYM SetupDiGetDeviceRegistryProperty}\r\n\r\n{$IFDEF WINXP_UP}\r\nfunction SetupDiGetClassRegistryPropertyA(const ClassGuid: TGUID;\r\n Property_: DWORD; PropertyRegDataType: PDWORD; PropertyBuffer: PBYTE;\r\n PropertyBufferSize: DWORD; RequiredSize: PDWORD; const MachineName: PAnsiChar;\r\n Reserved: Pointer): BOOL; stdcall;\r\n{$EXTERNALSYM SetupDiGetClassRegistryPropertyA}\r\nfunction SetupDiGetClassRegistryPropertyW(const ClassGuid: TGUID;\r\n Property_: DWORD; PropertyRegDataType: PDWORD; PropertyBuffer: PBYTE;\r\n PropertyBufferSize: DWORD; RequiredSize: PDWORD; const MachineName: PWideChar;\r\n Reserved: Pointer): BOOL; stdcall;\r\n{$EXTERNALSYM SetupDiGetClassRegistryPropertyW}\r\nfunction SetupDiGetClassRegistryProperty(const ClassGuid: TGUID;\r\n Property_: DWORD; PropertyRegDataType: PDWORD; PropertyBuffer: PBYTE;\r\n PropertyBufferSize: DWORD; RequiredSize: PDWORD; const MachineName: PTSTR;\r\n Reserved: Pointer): BOOL; stdcall;\r\n{$EXTERNALSYM SetupDiGetClassRegistryProperty}\r\n{$ENDIF WINXP_UP}\r\n\r\nfunction SetupDiSetDeviceRegistryPropertyA(DeviceInfoSet: HDEVINFO;\r\n var DeviceInfoData: TSPDevInfoData; Property_: DWORD;\r\n const PropertyBuffer: PBYTE; PropertyBufferSize: DWORD): BOOL; stdcall;\r\n{$EXTERNALSYM SetupDiSetDeviceRegistryPropertyA}\r\nfunction SetupDiSetDeviceRegistryPropertyW(DeviceInfoSet: HDEVINFO;\r\n var DeviceInfoData: TSPDevInfoData; Property_: DWORD;\r\n const PropertyBuffer: PBYTE; PropertyBufferSize: DWORD): BOOL; stdcall;\r\n{$EXTERNALSYM SetupDiSetDeviceRegistryPropertyW}\r\nfunction SetupDiSetDeviceRegistryProperty(DeviceInfoSet: HDEVINFO;\r\n var DeviceInfoData: TSPDevInfoData; Property_: DWORD;\r\n const PropertyBuffer: PBYTE; PropertyBufferSize: DWORD): BOOL; stdcall;\r\n{$EXTERNALSYM SetupDiSetDeviceRegistryProperty}\r\n\r\n{$IFDEF WINXP_UP}\r\nfunction SetupDiSetClassRegistryPropertyA(const ClassGuid: TGUID;\r\n Property_: DWORD; const PropertyBuffer: PBYTE; PropertyBufferSize: DWORD;\r\n const MachineName: PAnsiChar; Reserved: Pointer): BOOL; stdcall;\r\n{$EXTERNALSYM SetupDiSetClassRegistryPropertyA}\r\nfunction SetupDiSetClassRegistryPropertyW(const ClassGuid: TGUID;\r\n Property_: DWORD; const PropertyBuffer: PBYTE; PropertyBufferSize: DWORD;\r\n const MachineName: PWideChar; Reserved: Pointer): BOOL; stdcall;\r\n{$EXTERNALSYM SetupDiSetClassRegistryPropertyW}\r\nfunction SetupDiSetClassRegistryProperty(const ClassGuid: TGUID;\r\n Property_: DWORD; const PropertyBuffer: PBYTE; PropertyBufferSize: DWORD;\r\n const MachineName: PTSTR; Reserved: Pointer): BOOL; stdcall;\r\n{$EXTERNALSYM SetupDiSetClassRegistryProperty}\r\n{$ENDIF WINXP_UP}\r\n\r\nfunction SetupDiGetDeviceInstallParamsA(DeviceInfoSet: HDEVINFO;\r\n DeviceInfoData: PSPDevInfoData;\r\n var DeviceInstallParams: TSPDevInstallParamsA): BOOL; stdcall;\r\n{$EXTERNALSYM SetupDiGetDeviceInstallParamsA}\r\nfunction SetupDiGetDeviceInstallParamsW(DeviceInfoSet: HDEVINFO;\r\n DeviceInfoData: PSPDevInfoData;\r\n var DeviceInstallParams: TSPDevInstallParamsW): BOOL; stdcall;\r\n{$EXTERNALSYM SetupDiGetDeviceInstallParamsW}\r\nfunction SetupDiGetDeviceInstallParams(DeviceInfoSet: HDEVINFO;\r\n DeviceInfoData: PSPDevInfoData;\r\n var DeviceInstallParams: TSPDevInstallParams): BOOL; stdcall;\r\n{$EXTERNALSYM SetupDiGetDeviceInstallParams}\r\n\r\n\r\nfunction SetupDiGetClassInstallParamsA(DeviceInfoSet: HDEVINFO;\r\n DeviceInfoData: PSPDevInfoData; ClassInstallParams: PSPClassInstallHeader;\r\n ClassInstallParamsSize: DWORD; RequiredSize: PDWORD): BOOL; stdcall;\r\n{$EXTERNALSYM SetupDiGetClassInstallParamsA}\r\nfunction SetupDiGetClassInstallParamsW(DeviceInfoSet: HDEVINFO;\r\n DeviceInfoData: PSPDevInfoData; ClassInstallParams: PSPClassInstallHeader;\r\n ClassInstallParamsSize: DWORD; RequiredSize: PDWORD): BOOL; stdcall;\r\n{$EXTERNALSYM SetupDiGetClassInstallParamsW}\r\nfunction SetupDiGetClassInstallParams(DeviceInfoSet: HDEVINFO;\r\n DeviceInfoData: PSPDevInfoData; ClassInstallParams: PSPClassInstallHeader;\r\n ClassInstallParamsSize: DWORD; RequiredSize: PDWORD): BOOL; stdcall;\r\n{$EXTERNALSYM SetupDiGetClassInstallParams}\r\n\r\nfunction SetupDiSetDeviceInstallParamsA(DeviceInfoSet: HDEVINFO;\r\n DeviceInfoData: PSPDevInfoData;\r\n var DeviceInstallParams: TSPDevInstallParamsA): BOOL; stdcall;\r\n{$EXTERNALSYM SetupDiSetDeviceInstallParamsA}\r\nfunction SetupDiSetDeviceInstallParamsW(DeviceInfoSet: HDEVINFO;\r\n DeviceInfoData: PSPDevInfoData;\r\n var DeviceInstallParams: TSPDevInstallParamsW): BOOL; stdcall;\r\n{$EXTERNALSYM SetupDiSetDeviceInstallParamsW}\r\nfunction SetupDiSetDeviceInstallParams(DeviceInfoSet: HDEVINFO;\r\n DeviceInfoData: PSPDevInfoData;\r\n var DeviceInstallParams: TSPDevInstallParams): BOOL; stdcall;\r\n{$EXTERNALSYM SetupDiSetDeviceInstallParams}\r\n\r\nfunction SetupDiSetClassInstallParamsA(DeviceInfoSet: HDEVINFO;\r\n DeviceInfoData: PSPDevInfoData; ClassInstallParams: PSPClassInstallHeader;\r\n ClassInstallParamsSize: DWORD): BOOL; stdcall;\r\n{$EXTERNALSYM SetupDiSetClassInstallParamsA}\r\nfunction SetupDiSetClassInstallParamsW(DeviceInfoSet: HDEVINFO;\r\n DeviceInfoData: PSPDevInfoData; ClassInstallParams: PSPClassInstallHeader;\r\n ClassInstallParamsSize: DWORD): BOOL; stdcall;\r\n{$EXTERNALSYM SetupDiSetClassInstallParamsW}\r\nfunction SetupDiSetClassInstallParams(DeviceInfoSet: HDEVINFO;\r\n DeviceInfoData: PSPDevInfoData; ClassInstallParams: PSPClassInstallHeader;\r\n ClassInstallParamsSize: DWORD): BOOL; stdcall;\r\n{$EXTERNALSYM SetupDiSetClassInstallParams}\r\n\r\nfunction SetupDiGetDriverInstallParamsA(DeviceInfoSet: HDEVINFO;\r\n DeviceInfoData: PSPDevInfoData; var DriverInfoData: TSPDrvInfoDataA;\r\n var DriverInstallParams: TSPDrvInstallParams): BOOL; stdcall;\r\n{$EXTERNALSYM SetupDiGetDriverInstallParamsA}\r\nfunction SetupDiGetDriverInstallParamsW(DeviceInfoSet: HDEVINFO;\r\n DeviceInfoData: PSPDevInfoData; var DriverInfoData: TSPDrvInfoDataW;\r\n var DriverInstallParams: TSPDrvInstallParams): BOOL; stdcall;\r\n{$EXTERNALSYM SetupDiGetDriverInstallParamsW}\r\nfunction SetupDiGetDriverInstallParams(DeviceInfoSet: HDEVINFO;\r\n DeviceInfoData: PSPDevInfoData; var DriverInfoData: TSPDrvInfoData;\r\n var DriverInstallParams: TSPDrvInstallParams): BOOL; stdcall;\r\n{$EXTERNALSYM SetupDiGetDriverInstallParams}\r\n\r\nfunction SetupDiSetDriverInstallParamsA(DeviceInfoSet: HDEVINFO;\r\n DeviceInfoData: PSPDevInfoData; var DriverInfoData: TSPDrvInfoDataA;\r\n var DriverInstallParams: TSPDrvInstallParams): BOOL; stdcall;\r\n{$EXTERNALSYM SetupDiSetDriverInstallParamsA}\r\nfunction SetupDiSetDriverInstallParamsW(DeviceInfoSet: HDEVINFO;\r\n DeviceInfoData: PSPDevInfoData; var DriverInfoData: TSPDrvInfoDataW;\r\n var DriverInstallParams: TSPDrvInstallParams): BOOL; stdcall;\r\n{$EXTERNALSYM SetupDiSetDriverInstallParamsW}\r\nfunction SetupDiSetDriverInstallParams(DeviceInfoSet: HDEVINFO;\r\n DeviceInfoData: PSPDevInfoData; var DriverInfoData: TSPDrvInfoData;\r\n var DriverInstallParams: TSPDrvInstallParams): BOOL; stdcall;\r\n{$EXTERNALSYM SetupDiSetDriverInstallParams}\r\n\r\nfunction SetupDiLoadClassIcon(var ClassGuid: TGUID; LargeIcon: PHICON;\r\n MiniIconIndex: PINT): BOOL; stdcall;\r\n{$EXTERNALSYM SetupDiLoadClassIcon}\r\n\r\nfunction SetupDiDrawMiniIcon(hdc: HDC; rc: TRect; MiniIconIndex: Integer;\r\n Flags: DWORD): Integer; stdcall;\r\n{$EXTERNALSYM SetupDiDrawMiniIcon}\r\n\r\nfunction SetupDiGetClassBitmapIndex(ClassGuid: PGUID;\r\n var MiniIconIndex: Integer): BOOL; stdcall;\r\n{$EXTERNALSYM SetupDiGetClassBitmapIndex}\r\n\r\nfunction SetupDiGetClassImageList(\r\n var ClassImageListData: TSPClassImageListData): BOOL; stdcall;\r\n{$EXTERNALSYM SetupDiGetClassImageList}\r\n\r\nfunction SetupDiGetClassImageListExA(var ClassImageListData: TSPClassImageListData;\r\n const MachineName: PAnsiChar; Reserved: Pointer): BOOL; stdcall;\r\n{$EXTERNALSYM SetupDiGetClassImageListExA}\r\nfunction SetupDiGetClassImageListExW(var ClassImageListData: TSPClassImageListData;\r\n const MachineName: PWideChar; Reserved: Pointer): BOOL; stdcall;\r\n{$EXTERNALSYM SetupDiGetClassImageListExW}\r\nfunction SetupDiGetClassImageListEx(var ClassImageListData: TSPClassImageListData;\r\n const MachineName: PTSTR; Reserved: Pointer): BOOL; stdcall;\r\n{$EXTERNALSYM SetupDiGetClassImageListEx}\r\n\r\nfunction SetupDiGetClassImageIndex(var ClassImageListData: TSPClassImageListData;\r\n var ClassGuid: TGUID; var ImageIndex: Integer): BOOL; stdcall;\r\n{$EXTERNALSYM SetupDiGetClassImageIndex}\r\n\r\nfunction SetupDiDestroyClassImageList(\r\n var ClassImageListData: TSPClassImageListData): BOOL; stdcall;\r\n{$EXTERNALSYM SetupDiDestroyClassImageList}\r\n\r\nfunction SetupDiGetClassDevPropertySheetsA(DeviceInfoSet: HDEVINFO;\r\n DeviceInfoData: PSPDevInfoData; var PropertySheetHeader: TPropSheetHeaderA;\r\n PropertySheetHeaderPageListSize: DWORD; RequiredSize: PDWORD;\r\n PropertySheetType: DWORD): BOOL; stdcall;\r\n{$EXTERNALSYM SetupDiGetClassDevPropertySheetsA}\r\nfunction SetupDiGetClassDevPropertySheetsW(DeviceInfoSet: HDEVINFO;\r\n DeviceInfoData: PSPDevInfoData; var PropertySheetHeader: TPropSheetHeaderW;\r\n PropertySheetHeaderPageListSize: DWORD; RequiredSize: PDWORD;\r\n PropertySheetType: DWORD): BOOL; stdcall;\r\n{$EXTERNALSYM SetupDiGetClassDevPropertySheetsW}\r\nfunction SetupDiGetClassDevPropertySheets(DeviceInfoSet: HDEVINFO;\r\n DeviceInfoData: PSPDevInfoData; var PropertySheetHeader: TPropSheetHeader;\r\n PropertySheetHeaderPageListSize: DWORD; RequiredSize: PDWORD;\r\n PropertySheetType: DWORD): BOOL; stdcall;\r\n{$EXTERNALSYM SetupDiGetClassDevPropertySheets}\r\n\r\nfunction SetupDiAskForOEMDisk(DeviceInfoSet: HDEVINFO; DeviceInfoData: PSPDevInfoData): BOOL; stdcall;\r\n{$EXTERNALSYM SetupDiAskForOEMDisk}\r\n\r\nfunction SetupDiSelectOEMDrv(hwndParent: HWND; DeviceInfoSet: HDEVINFO;\r\n DeviceInfoData: PSPDevInfoData): BOOL; stdcall;\r\n{$EXTERNALSYM SetupDiSelectOEMDrv}\r\n\r\nfunction SetupDiClassNameFromGuidA(var ClassGuid: TGUID; ClassName: PAnsiChar;\r\n ClassNameSize: DWORD; RequiredSize: PDWORD): BOOL; stdcall;\r\n{$EXTERNALSYM SetupDiClassNameFromGuidA}\r\nfunction SetupDiClassNameFromGuidW(var ClassGuid: TGUID; ClassName: PWideChar;\r\n ClassNameSize: DWORD; RequiredSize: PDWORD): BOOL; stdcall;\r\n{$EXTERNALSYM SetupDiClassNameFromGuidW}\r\nfunction SetupDiClassNameFromGuid(var ClassGuid: TGUID; ClassName: PTSTR;\r\n ClassNameSize: DWORD; RequiredSize: PDWORD): BOOL; stdcall;\r\n{$EXTERNALSYM SetupDiClassNameFromGuid}\r\n\r\nfunction SetupDiClassNameFromGuidExA(var ClassGuid: TGUID; ClassName: PAnsiChar;\r\n ClassNameSize: DWORD; RequiredSize: PDWORD; const MachineName: PAnsiChar;\r\n Reserved: Pointer): BOOL; stdcall;\r\n{$EXTERNALSYM SetupDiClassNameFromGuidExA}\r\nfunction SetupDiClassNameFromGuidExW(var ClassGuid: TGUID; ClassName: PWideChar;\r\n ClassNameSize: DWORD; RequiredSize: PDWORD; const MachineName: PWideChar;\r\n Reserved: Pointer): BOOL; stdcall;\r\n{$EXTERNALSYM SetupDiClassNameFromGuidExW}\r\nfunction SetupDiClassNameFromGuidEx(var ClassGuid: TGUID; ClassName: PTSTR;\r\n ClassNameSize: DWORD; RequiredSize: PDWORD; const MachineName: PTSTR;\r\n Reserved: Pointer): BOOL; stdcall;\r\n{$EXTERNALSYM SetupDiClassNameFromGuidEx}\r\n\r\nfunction SetupDiClassGuidsFromNameA(const ClassName: PAnsiChar; ClassGuidList: PGUID;\r\n ClassGuidListSize: DWORD; var RequiredSize: DWORD): BOOL; stdcall;\r\n{$EXTERNALSYM SetupDiClassGuidsFromNameA}\r\nfunction SetupDiClassGuidsFromNameW(const ClassName: PWideChar; ClassGuidList: PGUID;\r\n ClassGuidListSize: DWORD; var RequiredSize: DWORD): BOOL; stdcall;\r\n{$EXTERNALSYM SetupDiClassGuidsFromNameW}\r\nfunction SetupDiClassGuidsFromName(const ClassName: PTSTR; ClassGuidList: PGUID;\r\n ClassGuidListSize: DWORD; var RequiredSize: DWORD): BOOL; stdcall;\r\n{$EXTERNALSYM SetupDiClassGuidsFromName}\r\n\r\nfunction SetupDiClassGuidsFromNameExA(const ClassName: PAnsiChar; ClassGuidList: PGUID;\r\n ClassGuidListSize: DWORD; var RequiredSize: DWORD; const MachineName: PAnsiChar;\r\n Reserved: Pointer): BOOL; stdcall;\r\n{$EXTERNALSYM SetupDiClassGuidsFromNameExA}\r\nfunction SetupDiClassGuidsFromNameExW(const ClassName: PWideChar; ClassGuidList: PGUID;\r\n ClassGuidListSize: DWORD; var RequiredSize: DWORD; const MachineName: PWideChar;\r\n Reserved: Pointer): BOOL; stdcall;\r\n{$EXTERNALSYM SetupDiClassGuidsFromNameExW}\r\nfunction SetupDiClassGuidsFromNameEx(const ClassName: PTSTR; ClassGuidList: PGUID;\r\n ClassGuidListSize: DWORD; var RequiredSize: DWORD; const MachineName: PTSTR;\r\n Reserved: Pointer): BOOL; stdcall;\r\n{$EXTERNALSYM SetupDiClassGuidsFromNameEx}\r\n\r\nfunction SetupDiGetHwProfileFriendlyNameA(HwProfile: DWORD; FriendlyName: PAnsiChar;\r\n FriendlyNameSize: DWORD; RequiredSize: PDWORD): BOOL; stdcall;\r\n{$EXTERNALSYM SetupDiGetHwProfileFriendlyNameA}\r\nfunction SetupDiGetHwProfileFriendlyNameW(HwProfile: DWORD; FriendlyName: PWideChar;\r\n FriendlyNameSize: DWORD; RequiredSize: PDWORD): BOOL; stdcall;\r\n{$EXTERNALSYM SetupDiGetHwProfileFriendlyNameW}\r\nfunction SetupDiGetHwProfileFriendlyName(HwProfile: DWORD; FriendlyName: PTSTR;\r\n FriendlyNameSize: DWORD; RequiredSize: PDWORD): BOOL; stdcall;\r\n{$EXTERNALSYM SetupDiGetHwProfileFriendlyName}\r\n\r\nfunction SetupDiGetHwProfileFriendlyNameExA(HwProfile: DWORD; FriendlyName: PAnsiChar;\r\n FriendlyNameSize: DWORD; RequiredSize: PDWORD; const MachineName: PAnsiChar;\r\n Reserved: Pointer): BOOL; stdcall;\r\n{$EXTERNALSYM SetupDiGetHwProfileFriendlyNameExA}\r\nfunction SetupDiGetHwProfileFriendlyNameExW(HwProfile: DWORD; FriendlyName: PWideChar;\r\n FriendlyNameSize: DWORD; RequiredSize: PDWORD; const MachineName: PWideChar;\r\n Reserved: Pointer): BOOL; stdcall;\r\n{$EXTERNALSYM SetupDiGetHwProfileFriendlyNameExW}\r\nfunction SetupDiGetHwProfileFriendlyNameEx(HwProfile: DWORD; FriendlyName: PTSTR;\r\n FriendlyNameSize: DWORD; RequiredSize: PDWORD; const MachineName: PTSTR;\r\n Reserved: Pointer): BOOL; stdcall;\r\n{$EXTERNALSYM SetupDiGetHwProfileFriendlyNameEx}\r\n\r\nfunction SetupDiGetWizardPage(DeviceInfoSet: HDEVINFO;\r\n DeviceInfoData: PSPDevInfoData; var InstallWizardData: TSPInstallWizardData;\r\n PageType: DWORD; Flags: DWORD): HPROPSHEETPAGE; stdcall;\r\n{$EXTERNALSYM SetupDiGetWizardPage}\r\n\r\nfunction SetupDiGetSelectedDevice(DeviceInfoSet: HDEVINFO;\r\n var DeviceInfoData: TSPDevInfoData): BOOL; stdcall;\r\n{$EXTERNALSYM SetupDiGetSelectedDevice}\r\n\r\nfunction SetupDiSetSelectedDevice(DeviceInfoSet: HDEVINFO;\r\n var DeviceInfoData: TSPDevInfoData): BOOL; stdcall;\r\n{$EXTERNALSYM SetupDiSetSelectedDevice}\r\n\r\nfunction SetupDiGetActualSectionToInstallA(InfHandle: HINF;\r\n const InfSectionName: PAnsiChar; InfSectionWithExt: PAnsiChar; InfSectionWithExtSize: DWORD;\r\n RequiredSize: PDWORD; Extension: PPASTR): BOOL; stdcall;\r\n{$EXTERNALSYM SetupDiGetActualSectionToInstallA}\r\nfunction SetupDiGetActualSectionToInstallW(InfHandle: HINF;\r\n const InfSectionName: PWideChar; InfSectionWithExt: PWideChar; InfSectionWithExtSize: DWORD;\r\n RequiredSize: PDWORD; Extension: PPWSTR): BOOL; stdcall;\r\n{$EXTERNALSYM SetupDiGetActualSectionToInstallW}\r\nfunction SetupDiGetActualSectionToInstall(InfHandle: HINF;\r\n const InfSectionName: PTSTR; InfSectionWithExt: PTSTR; InfSectionWithExtSize: DWORD;\r\n RequiredSize: PDWORD; Extension: PPSTR): BOOL; stdcall;\r\n{$EXTERNALSYM SetupDiGetActualSectionToInstall}\r\n\r\n{$IFDEF WINXP_UP}\r\n\r\nfunction SetupDiGetActualSectionToInstallExA(InfHandle: HINF;\r\n InfSectionName: PAnsiChar; AlternatePlatformInfo: PSPAltPlatformInfo;\r\n InfSectionWithExt: PAnsiChar; InfSectionWithExtSize: DWORD;\r\n RequiredSize: PDWORD; Extension: PPASTR; Reserved: Pointer): BOOL; stdcall;\r\nfunction SetupDiGetActualSectionToInstallExW(InfHandle: HINF;\r\n InfSectionName: PWideChar; AlternatePlatformInfo: PSPAltPlatformInfo;\r\n InfSectionWithExt: PWideChar; InfSectionWithExtSize: DWORD;\r\n RequiredSize: PDWORD; Extension: PPWSTR; Reserved: Pointer): BOOL; stdcall;\r\nfunction SetupDiGetActualSectionToInstallEx(InfHandle: HINF;\r\n InfSectionName: PTSTR; AlternatePlatformInfo: PSPAltPlatformInfo;\r\n InfSectionWithExt: PTSTR; InfSectionWithExtSize: DWORD;\r\n RequiredSize: PDWORD; Extension: PPSTR; Reserved: Pointer): BOOL; stdcall;\r\n\r\n//\r\n// SetupEnumInfSections is for low-level parsing of an INF\r\n//\r\nfunction SetupEnumInfSectionsA(InfHandle: HINF; Index: UINT;\r\n Buffer: PAnsiChar; Size: UINT; SizeNeeded: PUINT): BOOL; stdcall;\r\nfunction SetupEnumInfSectionsW(InfHandle: HINF; Index: UINT;\r\n Buffer: PWideChar; Size: UINT; SizeNeeded: PUINT): BOOL; stdcall;\r\nfunction SetupEnumInfSections(InfHandle: HINF; Index: UINT;\r\n Buffer: PAnsiChar; Size: UINT; SizeNeeded: PUINT): BOOL; stdcall;\r\n\r\nfunction SetupVerifyInfFileA(InfName: PAnsiChar; AltPlatformInfo: PSPAltPlatformInfo;\r\n var InfSignerInfo: TSPInfSignerInfoA): BOOL; stdcall;\r\nfunction SetupVerifyInfFileW(InfName: PWideChar; AltPlatformInfo: PSPAltPlatformInfo;\r\n var InfSignerInfo: TSPInfSignerInfoW): BOOL; stdcall;\r\nfunction SetupVerifyInfFile(InfName: PAnsiChar; AltPlatformInfo: PSPAltPlatformInfo;\r\n var InfSignerInfo: TSPInfSignerInfo): BOOL; stdcall;\r\n\r\nfunction SetupDiGetCustomDevicePropertyA(DeviceInfoSet: HDEVINFO;\r\n const DeviceInfoData: TSPDevInfoData; CustomPropertyName: PAnsiChar;\r\n Flags: DWORD; PropertyRegDataType: PDWORD; PropertyBuffer: PBYTE;\r\n PropertyBufferSize: DWORD; RequiredSize: PDWORD): BOOL; stdcall;\r\nfunction SetupDiGetCustomDevicePropertyW(DeviceInfoSet: HDEVINFO;\r\n const DeviceInfoData: TSPDevInfoData; CustomPropertyName: PWideChar;\r\n Flags: DWORD; PropertyRegDataType: PDWORD; PropertyBuffer: PBYTE;\r\n PropertyBufferSize: DWORD; RequiredSize: PDWORD): BOOL; stdcall;\r\nfunction SetupDiGetCustomDeviceProperty(DeviceInfoSet: HDEVINFO;\r\n const DeviceInfoData: TSPDevInfoData; CustomPropertyName: PAnsiChar;\r\n Flags: DWORD; PropertyRegDataType: PDWORD; PropertyBuffer: PBYTE;\r\n PropertyBufferSize: DWORD; RequiredSize: PDWORD): BOOL; stdcall;\r\n \r\n{$ENDIF WINXP_UP}\r\n\r\n{$ELSE}\r\n\r\n// (rom) remove all #defines Microsoft generated in SetupApi.h\r\n// (rom) to handle A/W functions\r\n\r\n(*$HPPEMIT '#undef SetupGetInfInformation'*)\r\n(*$HPPEMIT '#undef SetupQueryInfFileInformation'*)\r\n(*$HPPEMIT '#undef SetupQueryInfOriginalFileInformation'*)\r\n(*$HPPEMIT '#undef SetupQueryInfVersionInformation'*)\r\n(*$HPPEMIT '#undef SetupGetInfFileList'*)\r\n(*$HPPEMIT '#undef SetupOpenInfFile'*)\r\n(*$HPPEMIT '#undef SetupOpenAppendInfFile'*)\r\n(*$HPPEMIT '#undef SetupFindFirstLine'*)\r\n(*$HPPEMIT '#undef SetupFindNextMatchLine'*)\r\n(*$HPPEMIT '#undef SetupGetLineByIndex'*)\r\n(*$HPPEMIT '#undef SetupGetLineCount'*)\r\n(*$HPPEMIT '#undef SetupGetLineText'*)\r\n(*$HPPEMIT '#undef SetupGetStringField'*)\r\n(*$HPPEMIT '#undef SetupGetMultiSzField'*)\r\n(*$HPPEMIT '#undef SetupGetFileCompressionInfo'*)\r\n{$IFDEF WINXP_UP}\r\n(*$HPPEMIT '#undef SetupGetFileCompressionInfoEx'*)\r\n{$ENDIF WINXP_UP}\r\n(*$HPPEMIT '#undef SetupDecompressOrCopyFile'*)\r\n(*$HPPEMIT '#undef SetupGetSourceFileLocation'*)\r\n(*$HPPEMIT '#undef SetupGetSourceFileSize'*)\r\n(*$HPPEMIT '#undef SetupGetTargetPath'*)\r\n(*$HPPEMIT '#undef SetupSetSourceList'*)\r\n(*$HPPEMIT '#undef SetupAddToSourceList'*)\r\n(*$HPPEMIT '#undef SetupRemoveFromSourceList'*)\r\n(*$HPPEMIT '#undef SetupQuerySourceList'*)\r\n(*$HPPEMIT '#undef SetupFreeSourceList'*)\r\n(*$HPPEMIT '#undef SetupPromptForDisk'*)\r\n(*$HPPEMIT '#undef SetupCopyError'*)\r\n(*$HPPEMIT '#undef SetupRenameError'*)\r\n(*$HPPEMIT '#undef SetupDeleteError'*)\r\n(*$HPPEMIT '#undef SetupBackupError'*)\r\n(*$HPPEMIT '#undef SetupSetDirectoryId'*)\r\n(*$HPPEMIT '#undef SetupSetDirectoryIdEx'*)\r\n(*$HPPEMIT '#undef SetupGetSourceInfo'*)\r\n(*$HPPEMIT '#undef SetupInstallFile'*)\r\n(*$HPPEMIT '#undef SetupInstallFileEx'*)\r\n(*$HPPEMIT '#undef SetupSetFileQueueAlternatePlatform'*)\r\n(*$HPPEMIT '#undef SetupSetPlatformPathOverride'*)\r\n(*$HPPEMIT '#undef SetupQueueCopy'*)\r\n(*$HPPEMIT '#undef SetupQueueCopyIndirect'*)\r\n(*$HPPEMIT '#undef SetupQueueDefaultCopy'*)\r\n(*$HPPEMIT '#undef SetupQueueCopySection'*)\r\n(*$HPPEMIT '#undef SetupQueueDelete'*)\r\n(*$HPPEMIT '#undef SetupQueueDeleteSection'*)\r\n(*$HPPEMIT '#undef SetupQueueRename'*)\r\n(*$HPPEMIT '#undef SetupQueueRenameSection'*)\r\n(*$HPPEMIT '#undef SetupCommitFileQueue'*)\r\n(*$HPPEMIT '#undef SetupScanFileQueue'*)\r\n(*$HPPEMIT '#undef SetupCopyOEMInf'*)\r\n{$IFDEF WINXP_UP}\r\n(*$HPPEMIT '#undef SetupUninstallOEMInf'*)\r\n{$ENDIF WINXP_UP}\r\n(*$HPPEMIT '#undef SetupCreateDiskSpaceList'*)\r\n(*$HPPEMIT '#undef SetupDuplicateDiskSpaceList'*)\r\n(*$HPPEMIT '#undef SetupQueryDrivesInDiskSpaceList'*)\r\n(*$HPPEMIT '#undef SetupQuerySpaceRequiredOnDrive'*)\r\n(*$HPPEMIT '#undef SetupAdjustDiskSpaceList'*)\r\n(*$HPPEMIT '#undef SetupAddToDiskSpaceList'*)\r\n(*$HPPEMIT '#undef SetupAddSectionToDiskSpaceList'*)\r\n(*$HPPEMIT '#undef SetupAddInstallSectionToDiskSpaceList'*)\r\n(*$HPPEMIT '#undef SetupRemoveFromDiskSpaceList'*)\r\n(*$HPPEMIT '#undef SetupRemoveSectionFromDiskSpaceList'*)\r\n(*$HPPEMIT '#undef SetupRemoveInstallSectionFromDiskSpaceList'*)\r\n(*$HPPEMIT '#undef SetupIterateCabinet'*)\r\n(*$HPPEMIT '#undef SetupDefaultQueueCallback'*)\r\n(*$HPPEMIT '#undef SetupInstallFromInfSection'*)\r\n(*$HPPEMIT '#undef SetupInstallFilesFromInfSection'*)\r\n(*$HPPEMIT '#undef SetupInstallServicesFromInfSection'*)\r\n(*$HPPEMIT '#undef SetupInstallServicesFromInfSectionEx'*)\r\n{$IFDEF WINXP_UP}\r\n(*$HPPEMIT '#undef InstallHinfSection'*)\r\n{$ENDIF WINXP_UP}\r\n(*$HPPEMIT '#undef SetupInitializeFileLog'*)\r\n(*$HPPEMIT '#undef SetupLogFile'*)\r\n(*$HPPEMIT '#undef SetupRemoveFileLogEntry'*)\r\n(*$HPPEMIT '#undef SetupQueryFileLog'*)\r\n(*$HPPEMIT '#undef SetupLogError'*)\r\n(*$HPPEMIT '#undef SetupGetBackupInformation'*)\r\n{$IFDEF WINXP_UP}\r\n(*$HPPEMIT '#undef SetupPrepareQueueForRestore'*)\r\n{$ENDIF WINXP_UP}\r\n(*$HPPEMIT '#undef SetupDiCreateDeviceInfoListEx'*)\r\n(*$HPPEMIT '#undef SetupDiGetDeviceInfoListDetail'*)\r\n(*$HPPEMIT '#undef SetupDiCreateDeviceInfo'*)\r\n(*$HPPEMIT '#undef SetupDiOpenDeviceInfo'*)\r\n(*$HPPEMIT '#undef SetupDiGetDeviceInstanceId'*)\r\n(*$HPPEMIT '#undef SetupDiEnumInterfaceDevice'*)\r\n(*$HPPEMIT '#undef SetupDiCreateDeviceInterface'*)\r\n(*$HPPEMIT '#undef SetupDiCreateInterfaceDeviceA'*)\r\n(*$HPPEMIT '#undef SetupDiCreateInterfaceDeviceW'*)\r\n(*$HPPEMIT '#undef SetupDiCreateInterfaceDevice'*)\r\n(*$HPPEMIT '#undef SetupDiOpenDeviceInterface'*)\r\n(*$HPPEMIT '#undef SetupDiOpenInterfaceDeviceA'*)\r\n(*$HPPEMIT '#undef SetupDiOpenInterfaceDeviceW'*)\r\n(*$HPPEMIT '#undef SetupDiOpenInterfaceDevice'*)\r\n(*$HPPEMIT '#undef SetupDiGetInterfaceDeviceAlias'*)\r\n(*$HPPEMIT '#undef SetupDiDeleteInterfaceDeviceData'*)\r\n(*$HPPEMIT '#undef SetupDiRemoveInterfaceDevice'*)\r\n(*$HPPEMIT '#undef SetupDiGetDeviceInterfaceDetail'*)\r\n(*$HPPEMIT '#undef SetupDiGetInterfaceDeviceDetailA'*)\r\n(*$HPPEMIT '#undef SetupDiGetInterfaceDeviceDetailW'*)\r\n(*$HPPEMIT '#undef SetupDiGetInterfaceDeviceDetail'*)\r\n(*$HPPEMIT '#undef SetupDiInstallInterfaceDevices'*)\r\n(*$HPPEMIT '#undef SetupDiEnumDriverInfo'*)\r\n(*$HPPEMIT '#undef SetupDiGetSelectedDriver'*)\r\n(*$HPPEMIT '#undef SetupDiSetSelectedDriver'*)\r\n(*$HPPEMIT '#undef SetupDiGetDriverInfoDetail'*)\r\n(*$HPPEMIT '#undef SetupDiGetClassDevs'*)\r\n(*$HPPEMIT '#undef SetupDiGetClassDevsEx'*)\r\n(*$HPPEMIT '#undef SetupDiGetINFClass'*)\r\n(*$HPPEMIT '#undef SetupDiBuildClassInfoListEx'*)\r\n(*$HPPEMIT '#undef SetupDiGetClassDescription'*)\r\n(*$HPPEMIT '#undef SetupDiGetClassDescriptionEx'*)\r\n(*$HPPEMIT '#undef SetupDiInstallClass'*)\r\n(*$HPPEMIT '#undef SetupDiInstallClassEx'*)\r\n(*$HPPEMIT '#undef SetupDiOpenClassRegKeyEx'*)\r\n(*$HPPEMIT '#undef SetupDiCreateDeviceInterfaceRegKey'*)\r\n(*$HPPEMIT '#undef SetupDiCreateInterfaceDeviceRegKeyA'*)\r\n(*$HPPEMIT '#undef SetupDiCreateInterfaceDeviceRegKeyW'*)\r\n(*$HPPEMIT '#undef SetupDiCreateInterfaceDeviceRegKey'*)\r\n(*$HPPEMIT '#undef SetupDiOpenInterfaceDeviceRegKey'*)\r\n(*$HPPEMIT '#undef SetupDiDeleteInterfaceDeviceRegKey'*)\r\n(*$HPPEMIT '#undef SetupDiCreateDevRegKey'*)\r\n(*$HPPEMIT '#undef SetupDiGetHwProfileListEx'*)\r\n(*$HPPEMIT '#undef SetupDiGetDeviceRegistryProperty'*)\r\n(*$HPPEMIT '#undef SetupDiGetClassRegistryProperty'*)\r\n(*$HPPEMIT '#undef SetupDiSetDeviceRegistryProperty'*)\r\n(*$HPPEMIT '#undef SetupDiSetClassRegistryProperty'*)\r\n(*$HPPEMIT '#undef SetupDiGetDeviceInstallParams'*)\r\n(*$HPPEMIT '#undef SetupDiGetClassInstallParams'*)\r\n(*$HPPEMIT '#undef SetupDiSetDeviceInstallParams'*)\r\n(*$HPPEMIT '#undef SetupDiSetClassInstallParams'*)\r\n(*$HPPEMIT '#undef SetupDiGetDriverInstallParams'*)\r\n(*$HPPEMIT '#undef SetupDiSetDriverInstallParams'*)\r\n(*$HPPEMIT '#undef SetupDiGetClassImageListEx'*)\r\n(*$HPPEMIT '#undef SetupDiGetClassDevPropertySheets'*)\r\n(*$HPPEMIT '#undef SetupDiClassNameFromGuid'*)\r\n(*$HPPEMIT '#undef SetupDiClassNameFromGuidEx'*)\r\n(*$HPPEMIT '#undef SetupDiClassGuidsFromName'*)\r\n(*$HPPEMIT '#undef SetupDiClassGuidsFromNameEx'*)\r\n(*$HPPEMIT '#undef SetupDiGetHwProfileFriendlyName'*)\r\n(*$HPPEMIT '#undef SetupDiGetHwProfileFriendlyNameEx'*)\r\n(*$HPPEMIT '#undef SetupDiGetActualSectionToInstall'*)\r\n{$IFDEF WINXP_UP}\r\n(*$HPPEMIT '#undef SetupDiGetActualSectionToInstallEx'*)\r\n(*$HPPEMIT '#undef SetupEnumInfSections'*)\r\n(*$HPPEMIT '#undef SetupVerifyInfFile'*)\r\n(*$HPPEMIT '#undef SetupDiGetCustomDeviceProperty'*)\r\n{$ENDIF WINXP_UP}\r\n\r\ntype\r\n {$IFDEF WINXP_UP}\r\n TSetupGetFileQueueCount = function(FileQueue: HSPFILEQ; SubQueueFileOp: UINT; var NumOperations: UINT): BOOL; stdcall;\r\n TSetupGetFileQueueFlags = function(FileQueue: HSPFILEQ; var Flags: DWORD): BOOL; stdcall;\r\n TSetupSetFileQueueFlags = function(FileQueue: HSPFILEQ; FlagMask: DWORD; Flags: DWORD): BOOL; stdcall;\r\n {$ENDIF WINXP_UP}\r\n TSetupGetInfInformationA = function(InfSpec: Pointer; SearchControl: DWORD;\r\n ReturnBuffer: PSPInfInformation; ReturnBufferSize: DWORD; RequiredSize: PDWORD): BOOL; stdcall;\r\n TSetupGetInfInformationW = function(InfSpec: Pointer; SearchControl: DWORD;\r\n ReturnBuffer: PSPInfInformation; ReturnBufferSize: DWORD; RequiredSize: PDWORD): BOOL; stdcall;\r\n {$IFDEF UNICODE}\r\n TSetupGetInfInformation = TSetupGetInfInformationW;\r\n {$ELSE}\r\n TSetupGetInfInformation = TSetupGetInfInformationA;\r\n {$ENDIF UNICODE}\r\n\r\n TSetupQueryInfFileInformationA = function(var InfInformation: TSPInfInformation;\r\n InfIndex: UINT; ReturnBuffer: PAnsiChar; ReturnBufferSize: DWORD;\r\n RequiredSize: PDWORD): BOOL; stdcall;\r\n TSetupQueryInfFileInformationW = function(var InfInformation: TSPInfInformation;\r\n InfIndex: UINT; ReturnBuffer: PWideChar; ReturnBufferSize: DWORD;\r\n RequiredSize: PDWORD): BOOL; stdcall;\r\n TSetupQueryInfFileInformation = function(var InfInformation: TSPInfInformation;\r\n InfIndex: UINT; ReturnBuffer: PTSTR; ReturnBufferSize: DWORD;\r\n RequiredSize: PDWORD): BOOL; stdcall;\r\n\r\n {$IFDEF WIN2000_UP}\r\n TSetupQueryInfOriginalFileInformationA = function(var InfInformation: TSPInfInformation;\r\n InfIndex: UINT; AlternatePlatformInfo: PSPAltPlatformInfo;\r\n var OriginalFileInfo: TSPOriginalFileInfoA): BOOL; stdcall;\r\n TSetupQueryInfOriginalFileInformationW = function(var InfInformation: TSPInfInformation;\r\n InfIndex: UINT; AlternatePlatformInfo: PSPAltPlatformInfo;\r\n var OriginalFileInfo: TSPOriginalFileInfoW): BOOL; stdcall;\r\n TSetupQueryInfOriginalFileInformation = function(var InfInformation: TSPInfInformation;\r\n InfIndex: UINT; AlternatePlatformInfo: PSPAltPlatformInfo;\r\n var OriginalFileInfo: TSPOriginalFileInfo): BOOL; stdcall;\r\n {$ENDIF WIN2000_UP}\r\n\r\n TSetupQueryInfVersionInformationA = function(var InfInformation: TSPInfInformation;\r\n InfIndex: UINT; const Key, ReturnBuffer: PAnsiChar; ReturnBufferSize: DWORD;\r\n RequiredSize: PDWORD): BOOL; stdcall;\r\n TSetupQueryInfVersionInformationW = function(var InfInformation: TSPInfInformation;\r\n InfIndex: UINT; const Key, ReturnBuffer: PWideChar; ReturnBufferSize: DWORD;\r\n RequiredSize: PDWORD): BOOL; stdcall;\r\n TSetupQueryInfVersionInformation = function(var InfInformation: TSPInfInformation;\r\n InfIndex: UINT; const Key, ReturnBuffer: PTSTR; ReturnBufferSize: DWORD;\r\n RequiredSize: PDWORD): BOOL; stdcall;\r\n\r\n TSetupGetInfFileListA = function(const DirectoryPath: PAnsiChar; InfStyle: DWORD;\r\n ReturnBuffer: PAnsiChar; ReturnBufferSize: DWORD; RequiredSize: PDWORD): BOOL; stdcall;\r\n TSetupGetInfFileListW = function(const DirectoryPath: PWideChar; InfStyle: DWORD;\r\n ReturnBuffer: PWideChar; ReturnBufferSize: DWORD; RequiredSize: PDWORD): BOOL; stdcall;\r\n TSetupGetInfFileList = function(const DirectoryPath: PTSTR; InfStyle: DWORD;\r\n ReturnBuffer: PTSTR; ReturnBufferSize: DWORD; RequiredSize: PDWORD): BOOL; stdcall;\r\n\r\n TSetupOpenInfFileA = function(const FileName: PAnsiChar; const InfClass: PAnsiChar;\r\n InfStyle: DWORD; ErrorLine: PUINT): HINF; stdcall;\r\n TSetupOpenInfFileW = function(const FileName: PWideChar; const InfClass: PWideChar;\r\n InfStyle: DWORD; ErrorLine: PUINT): HINF; stdcall;\r\n TSetupOpenInfFile = function(const FileName: PTSTR; const InfClass: PTSTR;\r\n InfStyle: DWORD; ErrorLine: PUINT): HINF; stdcall;\r\n\r\n TSetupOpenMasterInf = function: HINF; stdcall;\r\n\r\n TSetupOpenAppendInfFileA = function(const FileName: PAnsiChar; InfHandle: HINF;\r\n ErrorLine: PUINT): BOOL; stdcall;\r\n TSetupOpenAppendInfFileW = function(const FileName: PWideChar; InfHandle: HINF;\r\n ErrorLine: PUINT): BOOL; stdcall;\r\n TSetupOpenAppendInfFile = function(const FileName: PTSTR; InfHandle: HINF;\r\n ErrorLine: PUINT): BOOL; stdcall;\r\n\r\n TSetupCloseInfFile = procedure(InfHandle: HINF); stdcall;\r\n\r\n TSetupFindFirstLineA = function(InfHandle: HINF; Section, Key: PAnsiChar;\r\n var Context: TInfContext): BOOL; stdcall;\r\n TSetupFindFirstLineW = function(InfHandle: HINF; Section, Key: PWideChar;\r\n var Context: TInfContext): BOOL; stdcall;\r\n TSetupFindFirstLine = function(InfHandle: HINF; Section, Key: PTSTR;\r\n var Context: TInfContext): BOOL; stdcall;\r\n\r\n TSetupFindNextLine = function(var ContextIn, ContextOut: TInfContext): BOOL; stdcall;\r\n\r\n TSetupFindNextMatchLineA = function(var ContextIn: TInfContext; Key: PAnsiChar;\r\n var ContextOut: TInfContext): BOOL; stdcall;\r\n TSetupFindNextMatchLineW = function(var ContextIn: TInfContext; Key: PWideChar;\r\n var ContextOut: TInfContext): BOOL; stdcall;\r\n TSetupFindNextMatchLine = function(var ContextIn: TInfContext; Key: PTSTR;\r\n var ContextOut: TInfContext): BOOL; stdcall;\r\n\r\n TSetupGetLineByIndexA = function(InfHandle: HINF; Section: PAnsiChar; Index: DWORD;\r\n var Context: TInfContext): BOOL; stdcall;\r\n TSetupGetLineByIndexW = function(InfHandle: HINF; Section: PWideChar; Index: DWORD;\r\n var Context: TInfContext): BOOL; stdcall;\r\n TSetupGetLineByIndex = function(InfHandle: HINF; Section: PTSTR; Index: DWORD;\r\n var Context: TInfContext): BOOL; stdcall;\r\n\r\n TSetupGetLineCountA = function(InfHandle: HINF; Section: PAnsiChar): Integer; stdcall;\r\n TSetupGetLineCountW = function(InfHandle: HINF; Section: PWideChar): Integer; stdcall;\r\n TSetupGetLineCount = function(InfHandle: HINF; Section: PTSTR): Integer; stdcall;\r\n\r\n TSetupGetLineTextA = function(Context: PInfContext; InfHandle: HINF; Section,\r\n Key, ReturnBuffer: PAnsiChar; ReturnBufferSize: DWORD; RequiredSize: PDWORD): BOOL; stdcall;\r\n TSetupGetLineTextW = function(Context: PInfContext; InfHandle: HINF; Section,\r\n Key, ReturnBuffer: PWideChar; ReturnBufferSize: DWORD; RequiredSize: PDWORD): BOOL; stdcall;\r\n TSetupGetLineText = function(Context: PInfContext; InfHandle: HINF; Section,\r\n Key, ReturnBuffer: PTSTR; ReturnBufferSize: DWORD; RequiredSize: PDWORD): BOOL; stdcall;\r\n\r\n TSetupGetFieldCount = function(var Context: TInfContext): DWORD; stdcall;\r\n\r\n TSetupGetStringFieldA = function(var Context: TInfContext; FieldIndex: DWORD;\r\n ReturnBuffer: PAnsiChar; ReturnBufferSize: DWORD; RequiredSize: PDWORD): BOOL; stdcall;\r\n TSetupGetStringFieldW = function(var Context: TInfContext; FieldIndex: DWORD;\r\n ReturnBuffer: PWideChar; ReturnBufferSize: DWORD; RequiredSize: PDWORD): BOOL; stdcall;\r\n TSetupGetStringField = function(var Context: TInfContext; FieldIndex: DWORD;\r\n ReturnBuffer: PTSTR; ReturnBufferSize: DWORD; RequiredSize: PDWORD): BOOL; stdcall;\r\n\r\n TSetupGetIntField = function(var Context: TInfContext; FieldIndex: DWORD;\r\n var IntegerValue: Integer): BOOL; stdcall;\r\n\r\n TSetupGetMultiSzFieldA = function(var Context: TInfContext; FieldIndex: DWORD;\r\n ReturnBuffer: PAnsiChar; ReturnBufferSize: DWORD; RequiredSize: PDWORD): BOOL; stdcall;\r\n TSetupGetMultiSzFieldW = function(var Context: TInfContext; FieldIndex: DWORD;\r\n ReturnBuffer: PWideChar; ReturnBufferSize: DWORD; RequiredSize: PDWORD): BOOL; stdcall;\r\n TSetupGetMultiSzField = function(var Context: TInfContext; FieldIndex: DWORD;\r\n ReturnBuffer: PTSTR; ReturnBufferSize: DWORD; RequiredSize: PDWORD): BOOL; stdcall;\r\n\r\n TSetupGetBinaryField = function(var Context: TInfContext; FieldIndex: DWORD;\r\n ReturnBuffer: PBYTE; ReturnBufferSize: DWORD; RequiredSize: PDWORD): BOOL; stdcall;\r\n\r\n TSetupGetFileCompressionInfoA = function(const SourceFileName: PAnsiChar;\r\n var ActualSourceFileName: PAnsiChar; var SourceFileSize: DWORD;\r\n var TargetFileSize: DWORD; var CompressionType: UINT): DWORD; stdcall;\r\n TSetupGetFileCompressionInfoW = function(const SourceFileName: PWideChar;\r\n var ActualSourceFileName: PWideChar; var SourceFileSize: DWORD;\r\n var TargetFileSize: DWORD; var CompressionType: UINT): DWORD; stdcall;\r\n TSetupGetFileCompressionInfo = function(const SourceFileName: PTSTR;\r\n var ActualSourceFileName: PTSTR; var SourceFileSize: DWORD;\r\n var TargetFileSize: DWORD; var CompressionType: UINT): DWORD; stdcall;\r\n\r\n {$IFDEF WINXP_UP}\r\n TSetupGetFileCompressionInfoExA = function(const SourceFileName: PAnsiChar;\r\n ActualSourceFileNameBuffer: PAnsiChar; var ActualSourceFileNameBufferLen: DWORD;\r\n RequiredBufferLen: PDWORD; var SourceFileSize: DWORD;\r\n var TargetFileSize: DWORD; var CompressionType: UINT): BOOL; stdcall;\r\n TSetupGetFileCompressionInfoExW = function(const SourceFileName: PWideChar;\r\n ActualSourceFileNameBuffer: PWideChar; var ActualSourceFileNameBufferLen: DWORD;\r\n RequiredBufferLen: PDWORD; var SourceFileSize: DWORD;\r\n var TargetFileSize: DWORD; var CompressionType: UINT): BOOL; stdcall;\r\n TSetupGetFileCompressionInfoEx = function(const SourceFileName: PTSTR;\r\n ActualSourceFileNameBuffer: PTSTR; var ActualSourceFileNameBufferLen: DWORD;\r\n RequiredBufferLen: PDWORD; var SourceFileSize: DWORD;\r\n var TargetFileSize: DWORD; var CompressionType: UINT): BOOL; stdcall;\r\n {$ENDIF WINXP_UP}\r\n\r\n TSetupDecompressOrCopyFileA = function(const SourceFileName, TargetFileName: PAnsiChar;\r\n var CompressionType: UINT): DWORD; stdcall;\r\n TSetupDecompressOrCopyFileW = function(const SourceFileName, TargetFileName: PWideChar;\r\n var CompressionType: UINT): DWORD; stdcall;\r\n TSetupDecompressOrCopyFile = function(const SourceFileName, TargetFileName: PTSTR;\r\n var CompressionType: UINT): DWORD; stdcall;\r\n\r\n TSetupGetSourceFileLocationA = function(InfHandle: HINF; InfContext: PInfContext;\r\n const FileName: PAnsiChar; var SourceId: UINT; ReturnBuffer: PAnsiChar;\r\n ReturnBufferSize: DWORD; RequiredSize: PDWORD): BOOL; stdcall;\r\n TSetupGetSourceFileLocationW = function(InfHandle: HINF; InfContext: PInfContext;\r\n const FileName: PWideChar; var SourceId: UINT; ReturnBuffer: PWideChar;\r\n ReturnBufferSize: DWORD; RequiredSize: PDWORD): BOOL; stdcall;\r\n TSetupGetSourceFileLocation = function(InfHandle: HINF; InfContext: PInfContext;\r\n const FileName: PTSTR; var SourceId: UINT; ReturnBuffer: PTSTR;\r\n ReturnBufferSize: DWORD; RequiredSize: PDWORD): BOOL; stdcall;\r\n\r\n TSetupGetSourceFileSizeA = function(InfHandle: HINF; InfContext: PInfContext;\r\n const FileName: PAnsiChar; const Section: PAnsiChar; var FileSize: DWORD;\r\n RoundingFactor: UINT): BOOL; stdcall;\r\n TSetupGetSourceFileSizeW = function(InfHandle: HINF; InfContext: PInfContext;\r\n const FileName: PWideChar; const Section: PWideChar; var FileSize: DWORD;\r\n RoundingFactor: UINT): BOOL; stdcall;\r\n TSetupGetSourceFileSize = function(InfHandle: HINF; InfContext: PInfContext;\r\n const FileName: PTSTR; const Section: PTSTR; var FileSize: DWORD;\r\n RoundingFactor: UINT): BOOL; stdcall;\r\n\r\n TSetupGetTargetPathA = function(InfHandle: HINF; InfContext: PInfContext;\r\n const Section: PAnsiChar; ReturnBuffer: PAnsiChar; ReturnBufferSize: DWORD;\r\n RequiredSize: PDWORD): BOOL; stdcall;\r\n TSetupGetTargetPathW = function(InfHandle: HINF; InfContext: PInfContext;\r\n const Section: PWideChar; ReturnBuffer: PWideChar; ReturnBufferSize: DWORD;\r\n RequiredSize: PDWORD): BOOL; stdcall;\r\n TSetupGetTargetPath = function(InfHandle: HINF; InfContext: PInfContext;\r\n const Section: PTSTR; ReturnBuffer: PTSTR; ReturnBufferSize: DWORD;\r\n RequiredSize: PDWORD): BOOL; stdcall;\r\n\r\n TSetupSetSourceListA = function(Flags: DWORD; SourceList: PPASTR;\r\n SourceCount: UINT): BOOL; stdcall;\r\n TSetupSetSourceListW = function(Flags: DWORD; SourceList: PPWSTR;\r\n SourceCount: UINT): BOOL; stdcall;\r\n TSetupSetSourceList = function(Flags: DWORD; SourceList: PPSTR;\r\n SourceCount: UINT): BOOL; stdcall;\r\n\r\n TSetupCancelTemporarySourceList = function: BOOL; stdcall;\r\n\r\n TSetupAddToSourceListA = function(Flags: DWORD; const Source: PAnsiChar): BOOL; stdcall;\r\n TSetupAddToSourceListW = function(Flags: DWORD; const Source: PWideChar): BOOL; stdcall;\r\n TSetupAddToSourceList = function(Flags: DWORD; const Source: PTSTR): BOOL; stdcall;\r\n\r\n TSetupRemoveFromSourceListA = function(Flags: DWORD; const Source: PAnsiChar): BOOL; stdcall;\r\n TSetupRemoveFromSourceListW = function(Flags: DWORD; const Source: PWideChar): BOOL; stdcall;\r\n TSetupRemoveFromSourceList = function(Flags: DWORD; const Source: PTSTR): BOOL; stdcall;\r\n\r\n TSetupQuerySourceListA = function(Flags: DWORD; var List: PPASTR;\r\n var Count: UINT): BOOL; stdcall;\r\n TSetupQuerySourceListW = function(Flags: DWORD; var List: PPWSTR;\r\n var Count: UINT): BOOL; stdcall;\r\n TSetupQuerySourceList = function(Flags: DWORD; var List: PPSTR;\r\n var Count: UINT): BOOL; stdcall;\r\n\r\n TSetupFreeSourceListA = function(var List: PPASTR; Count: UINT): BOOL; stdcall;\r\n TSetupFreeSourceListW = function(var List: PPWSTR; Count: UINT): BOOL; stdcall;\r\n TSetupFreeSourceList = function(var List: PPSTR; Count: UINT): BOOL; stdcall;\r\n\r\n TSetupPromptForDiskA = function(hwndParent: HWND; const DialogTitle, DiskName,\r\n PathToSource, FileSought, TagFile: PAnsiChar; DiskPromptStyle: DWORD;\r\n PathBuffer: PAnsiChar; PathBufferSize: DWORD; var PathRequiredSize: DWORD): UINT; stdcall;\r\n TSetupPromptForDiskW = function(hwndParent: HWND; const DialogTitle, DiskName,\r\n PathToSource, FileSought, TagFile: PWideChar; DiskPromptStyle: DWORD;\r\n PathBuffer: PWideChar; PathBufferSize: DWORD; var PathRequiredSize: DWORD): UINT; stdcall;\r\n TSetupPromptForDisk = function(hwndParent: HWND; const DialogTitle, DiskName,\r\n PathToSource, FileSought, TagFile: PTSTR; DiskPromptStyle: DWORD;\r\n PathBuffer: PTSTR; PathBufferSize: DWORD; var PathRequiredSize: DWORD): UINT; stdcall;\r\n\r\n TSetupCopyErrorA = function(hwndParent: HWND; const DialogTitle, DiskName,\r\n PathToSource, SourceFile, TargetPathFile: PAnsiChar; Win32ErrorCode: UINT; Style: DWORD;\r\n PathBuffer: PAnsiChar; PathBufferSize: DWORD; PathRequiredSize: PDWORD): UINT; stdcall;\r\n TSetupCopyErrorW = function(hwndParent: HWND; const DialogTitle, DiskName,\r\n PathToSource, SourceFile, TargetPathFile: PWideChar; Win32ErrorCode: UINT; Style: DWORD;\r\n PathBuffer: PWideChar; PathBufferSize: DWORD; PathRequiredSize: PDWORD): UINT; stdcall;\r\n TSetupCopyError = function(hwndParent: HWND; const DialogTitle, DiskName,\r\n PathToSource, SourceFile, TargetPathFile: PTSTR; Win32ErrorCode: UINT; Style: DWORD;\r\n PathBuffer: PTSTR; PathBufferSize: DWORD; PathRequiredSize: PDWORD): UINT; stdcall;\r\n\r\n TSetupRenameErrorA = function(hwndParent: HWND; const DialogTitle, SourceFile,\r\n TargetFile: PAnsiChar; Win32ErrorCode: UINT; Style: DWORD): UINT; stdcall;\r\n TSetupRenameErrorW = function(hwndParent: HWND; const DialogTitle, SourceFile,\r\n TargetFile: PWideChar; Win32ErrorCode: UINT; Style: DWORD): UINT; stdcall;\r\n TSetupRenameError = function(hwndParent: HWND; const DialogTitle, SourceFile,\r\n TargetFile: PTSTR; Win32ErrorCode: UINT; Style: DWORD): UINT; stdcall;\r\n\r\n TSetupDeleteErrorA = function(hwndParent: HWND; const DialogTitle, File_: PAnsiChar;\r\n Win32ErrorCode: UINT; Style: DWORD): UINT; stdcall;\r\n TSetupDeleteErrorW = function(hwndParent: HWND; const DialogTitle, File_: PWideChar;\r\n Win32ErrorCode: UINT; Style: DWORD): UINT; stdcall;\r\n TSetupDeleteError = function(hwndParent: HWND; const DialogTitle, File_: PTSTR;\r\n Win32ErrorCode: UINT; Style: DWORD): UINT; stdcall;\r\n\r\n {$IFDEF WIN2000_UP}\r\n TSetupBackupErrorA = function(hwndParent: HWND; const DialogTitle, BackupFile,\r\n TargetFile: PAnsiChar; Win32ErrorCode: UINT; Style: DWORD): UINT; stdcall;\r\n TSetupBackupErrorW = function(hwndParent: HWND; const DialogTitle, BackupFile,\r\n TargetFile: PWideChar; Win32ErrorCode: UINT; Style: DWORD): UINT; stdcall;\r\n TSetupBackupError = function(hwndParent: HWND; const DialogTitle, BackupFile,\r\n TargetFile: PTSTR; Win32ErrorCode: UINT; Style: DWORD): UINT; stdcall;\r\n {$ENDIF WIN2000_UP}\r\n\r\n TSetupSetDirectoryIdA = function(InfHandle: HINF; Id: DWORD; const Directory: PAnsiChar): BOOL; stdcall;\r\n TSetupSetDirectoryIdW = function(InfHandle: HINF; Id: DWORD; const Directory: PWideChar): BOOL; stdcall;\r\n TSetupSetDirectoryId = function(InfHandle: HINF; Id: DWORD; const Directory: PTSTR): BOOL; stdcall;\r\n\r\n TSetupSetDirectoryIdExA = function(InfHandle: HINF; Id: DWORD; const Directory: PAnsiChar;\r\n Flags: DWORD; Reserved1: DWORD; Reserved2: Pointer): BOOL; stdcall;\r\n TSetupSetDirectoryIdExW = function(InfHandle: HINF; Id: DWORD; const Directory: PWideChar;\r\n Flags: DWORD; Reserved1: DWORD; Reserved2: Pointer): BOOL; stdcall;\r\n TSetupSetDirectoryIdEx = function(InfHandle: HINF; Id: DWORD; const Directory: PTSTR;\r\n Flags: DWORD; Reserved1: DWORD; Reserved2: Pointer): BOOL; stdcall;\r\n\r\n TSetupGetSourceInfoA = function(InfHandle: HINF; SourceId, InfoDesired: UINT;\r\n ReturnBuffer: PAnsiChar; ReturnBufferSize: DWORD; RequiredSize: PDWORD): BOOL; stdcall;\r\n TSetupGetSourceInfoW = function(InfHandle: HINF; SourceId, InfoDesired: UINT;\r\n ReturnBuffer: PWideChar; ReturnBufferSize: DWORD; RequiredSize: PDWORD): BOOL; stdcall;\r\n TSetupGetSourceInfo = function(InfHandle: HINF; SourceId, InfoDesired: UINT;\r\n ReturnBuffer: PTSTR; ReturnBufferSize: DWORD; RequiredSize: PDWORD): BOOL; stdcall;\r\n\r\n TSetupInstallFileA = function(InfHandle: HINF; InfContext: PInfContext;\r\n const SourceFile, SourcePathRoot, DestinationName: PAnsiChar; CopyStyle: DWORD;\r\n CopyMsgHandler: TSPFileCallbackA; Context: Pointer): BOOL; stdcall;\r\n TSetupInstallFileW = function(InfHandle: HINF; InfContext: PInfContext;\r\n const SourceFile, SourcePathRoot, DestinationName: PWideChar; CopyStyle: DWORD;\r\n CopyMsgHandler: TSPFileCallbackW; Context: Pointer): BOOL; stdcall;\r\n TSetupInstallFile = function(InfHandle: HINF; InfContext: PInfContext;\r\n const SourceFile, SourcePathRoot, DestinationName: PTSTR; CopyStyle: DWORD;\r\n CopyMsgHandler: TSPFileCallback; Context: Pointer): BOOL; stdcall;\r\n\r\n TSetupInstallFileExA = function(InfHandle: HINF; InfContext: PInfContext;\r\n const SourceFile, SourcePathRoot, DestinationName: PAnsiChar; CopyStyle: DWORD;\r\n CopyMsgHandler: TSPFileCallbackA; Context: Pointer; var FileWasInUse: BOOL): BOOL; stdcall;\r\n TSetupInstallFileExW = function(InfHandle: HINF; InfContext: PInfContext;\r\n const SourceFile, SourcePathRoot, DestinationName: PWideChar; CopyStyle: DWORD;\r\n CopyMsgHandler: TSPFileCallbackW; Context: Pointer; var FileWasInUse: BOOL): BOOL; stdcall;\r\n TSetupInstallFileEx = function(InfHandle: HINF; InfContext: PInfContext;\r\n const SourceFile, SourcePathRoot, DestinationName: PTSTR; CopyStyle: DWORD;\r\n CopyMsgHandler: TSPFileCallback; Context: Pointer; var FileWasInUse: BOOL): BOOL; stdcall;\r\n\r\n TSetupOpenFileQueue = function: HSPFILEQ; stdcall;\r\n\r\n TSetupCloseFileQueue = function(QueueHandle: HSPFILEQ): BOOL; stdcall;\r\n\r\n {$IFDEF WIN2000_UP}\r\n TSetupSetFileQueueAlternatePlatformA = function(QueueHandle: HSPFILEQ;\r\n AlternatePlatformInfo: PSPAltPlatformInfo;\r\n const AlternateDefaultCatalogFile: PAnsiChar): BOOL; stdcall;\r\n TSetupSetFileQueueAlternatePlatformW = function(QueueHandle: HSPFILEQ;\r\n AlternatePlatformInfo: PSPAltPlatformInfo;\r\n const AlternateDefaultCatalogFile: PWideChar): BOOL; stdcall;\r\n TSetupSetFileQueueAlternatePlatform = function(QueueHandle: HSPFILEQ;\r\n AlternatePlatformInfo: PSPAltPlatformInfo;\r\n const AlternateDefaultCatalogFile: PTSTR): BOOL; stdcall;\r\n {$ENDIF WIN2000_UP}\r\n\r\n TSetupSetPlatformPathOverrideA = function(const Override_: PAnsiChar): BOOL; stdcall;\r\n TSetupSetPlatformPathOverrideW = function(const Override_: PWideChar): BOOL; stdcall;\r\n TSetupSetPlatformPathOverride = function(const Override_: PTSTR): BOOL; stdcall;\r\n\r\n TSetupQueueCopyA = function(QueueHandle: HSPFILEQ; const SourceRootPath, SourcePath,\r\n SourceFilename, SourceDescription, SourceTagfile, TargetDirectory,\r\n TargetFilename: PAnsiChar; CopyStyle: DWORD): BOOL; stdcall;\r\n TSetupQueueCopyW = function(QueueHandle: HSPFILEQ; const SourceRootPath, SourcePath,\r\n SourceFilename, SourceDescription, SourceTagfile, TargetDirectory,\r\n TargetFilename: PWideChar; CopyStyle: DWORD): BOOL; stdcall;\r\n TSetupQueueCopy = function(QueueHandle: HSPFILEQ; const SourceRootPath, SourcePath,\r\n SourceFilename, SourceDescription, SourceTagfile, TargetDirectory,\r\n TargetFilename: PTSTR; CopyStyle: DWORD): BOOL; stdcall;\r\n\r\n {$IFDEF WIN2000_UP}\r\n TSetupQueueCopyIndirectA = function(var CopyParams: TSPFileCopyParamsA): BOOL; stdcall;\r\n TSetupQueueCopyIndirectW = function(var CopyParams: TSPFileCopyParamsW): BOOL; stdcall;\r\n TSetupQueueCopyIndirect = function(var CopyParams: TSPFileCopyParams): BOOL; stdcall;\r\n {$ENDIF WIN2000_UP}\r\n\r\n TSetupQueueDefaultCopyA = function(QueueHandle: HSPFILEQ; InfHandle: HINF;\r\n const SourceRootPath, SourceFilename, TargetFilename: PAnsiChar;\r\n CopyStyle: DWORD): BOOL; stdcall;\r\n TSetupQueueDefaultCopyW = function(QueueHandle: HSPFILEQ; InfHandle: HINF;\r\n const SourceRootPath, SourceFilename, TargetFilename: PWideChar;\r\n CopyStyle: DWORD): BOOL; stdcall;\r\n TSetupQueueDefaultCopy = function(QueueHandle: HSPFILEQ; InfHandle: HINF;\r\n const SourceRootPath, SourceFilename, TargetFilename: PTSTR;\r\n CopyStyle: DWORD): BOOL; stdcall;\r\n\r\n TSetupQueueCopySectionA = function(QueueHandle: HSPFILEQ; const SourceRootPath: PAnsiChar;\r\n InfHandle: HINF; ListInfHandle: HINF; const Section: PAnsiChar; CopyStyle: DWORD): BOOL; stdcall;\r\n TSetupQueueCopySectionW = function(QueueHandle: HSPFILEQ; const SourceRootPath: PWideChar;\r\n InfHandle: HINF; ListInfHandle: HINF; const Section: PWideChar; CopyStyle: DWORD): BOOL; stdcall;\r\n TSetupQueueCopySection = function(QueueHandle: HSPFILEQ; const SourceRootPath: PTSTR;\r\n InfHandle: HINF; ListInfHandle: HINF; const Section: PTSTR; CopyStyle: DWORD): BOOL; stdcall;\r\n\r\n TSetupQueueDeleteA = function(QueueHandle: HSPFILEQ; const PathPart1, PathPart2: PAnsiChar): BOOL; stdcall;\r\n TSetupQueueDeleteW = function(QueueHandle: HSPFILEQ; const PathPart1, PathPart2: PWideChar): BOOL; stdcall;\r\n TSetupQueueDelete = function(QueueHandle: HSPFILEQ; const PathPart1, PathPart2: PTSTR): BOOL; stdcall;\r\n\r\n TSetupQueueDeleteSectionA = function(QueueHandle: HSPFILEQ; InfHandle: HINF;\r\n ListInfHandle: HINF; const Section: PAnsiChar): BOOL; stdcall;\r\n TSetupQueueDeleteSectionW = function(QueueHandle: HSPFILEQ; InfHandle: HINF;\r\n ListInfHandle: HINF; const Section: PWideChar): BOOL; stdcall;\r\n TSetupQueueDeleteSection = function(QueueHandle: HSPFILEQ; InfHandle: HINF;\r\n ListInfHandle: HINF; const Section: PTSTR): BOOL; stdcall;\r\n\r\n TSetupQueueRenameA = function(QueueHandle: HSPFILEQ; const SourcePath,\r\n SourceFilename, TargetPath, TargetFilename: PAnsiChar): BOOL; stdcall;\r\n TSetupQueueRenameW = function(QueueHandle: HSPFILEQ; const SourcePath,\r\n SourceFilename, TargetPath, TargetFilename: PWideChar): BOOL; stdcall;\r\n TSetupQueueRename = function(QueueHandle: HSPFILEQ; const SourcePath,\r\n SourceFilename, TargetPath, TargetFilename: PTSTR): BOOL; stdcall;\r\n\r\n TSetupQueueRenameSectionA = function(QueueHandle: HSPFILEQ; InfHandle: HINF;\r\n ListInfHandle: HINF; const Section: PAnsiChar): BOOL; stdcall;\r\n TSetupQueueRenameSectionW = function(QueueHandle: HSPFILEQ; InfHandle: HINF;\r\n ListInfHandle: HINF; const Section: PWideChar): BOOL; stdcall;\r\n TSetupQueueRenameSection = function(QueueHandle: HSPFILEQ; InfHandle: HINF;\r\n ListInfHandle: HINF; const Section: PTSTR): BOOL; stdcall;\r\n\r\n TSetupCommitFileQueueA = function(Owner: HWND; QueueHandle: HSPFILEQ;\r\n MsgHandler: TSPFileCallbackA; Context: Pointer): BOOL; stdcall;\r\n TSetupCommitFileQueueW = function(Owner: HWND; QueueHandle: HSPFILEQ;\r\n MsgHandler: TSPFileCallbackW; Context: Pointer): BOOL; stdcall;\r\n TSetupCommitFileQueue = function(Owner: HWND; QueueHandle: HSPFILEQ;\r\n MsgHandler: TSPFileCallback; Context: Pointer): BOOL; stdcall;\r\n\r\n TSetupScanFileQueueA = function(FileQueue: HSPFILEQ; Flags: DWORD; Window: HWND;\r\n CallbackRoutine: TSPFileCallbackA; CallbackContext: Pointer; var Result: DWORD): BOOL; stdcall;\r\n TSetupScanFileQueueW = function(FileQueue: HSPFILEQ; Flags: DWORD; Window: HWND;\r\n CallbackRoutine: TSPFileCallbackW; CallbackContext: Pointer; var Result: DWORD): BOOL; stdcall;\r\n TSetupScanFileQueue = function(FileQueue: HSPFILEQ; Flags: DWORD; Window: HWND;\r\n CallbackRoutine: TSPFileCallback; CallbackContext: Pointer; var Result: DWORD): BOOL; stdcall;\r\n\r\n TSetupCopyOEMInfA = function(const SourceInfFileName, OEMSourceMediaLocation: PAnsiChar;\r\n OEMSourceMediaType, CopyStyle: DWORD; DestinationInfFileName: PAnsiChar;\r\n DestinationInfFileNameSize: DWORD; RequiredSize: PDWORD;\r\n DestinationInfFileNameComponent: PPASTR): BOOL; stdcall;\r\n TSetupCopyOEMInfW = function(const SourceInfFileName, OEMSourceMediaLocation: PWideChar;\r\n OEMSourceMediaType, CopyStyle: DWORD; DestinationInfFileName: PWideChar;\r\n DestinationInfFileNameSize: DWORD; RequiredSize: PDWORD;\r\n DestinationInfFileNameComponent: PPWSTR): BOOL; stdcall;\r\n TSetupCopyOEMInf = function(const SourceInfFileName, OEMSourceMediaLocation: PTSTR;\r\n OEMSourceMediaType, CopyStyle: DWORD; DestinationInfFileName: PTSTR;\r\n DestinationInfFileNameSize: DWORD; RequiredSize: PDWORD;\r\n DestinationInfFileNameComponent: PPSTR): BOOL; stdcall;\r\n\r\n {$IFDEF WINXP_UP}\r\n TSetupUninstallOEMInfA = function(const InfFileName: PAnsiChar; Flags: DWORD; Reserved: Pointer): BOOL; stdcall;\r\n TSetupUninstallOEMInfW = function(const InfFileName: PWideChar; Flags: DWORD; Reserved: Pointer): BOOL; stdcall;\r\n TSetupUninstallOEMInf = function(const InfFileName: PTSTR; Flags: DWORD; Reserved: Pointer): BOOL; stdcall;\r\n\r\n TSetupUninstallNewlyCopiedInfs = function(FileQueue: HSPFILEQ; Flags: DWORD; Reserved: Pointer): BOOL; stdcall;\r\n {$ENDIF WINXP_UP}\r\n\r\n//\r\n// Disk space list APIs\r\n//\r\n TSetupCreateDiskSpaceListA = function(Reserved1: Pointer; Reserved2: DWORD;\r\n Flags: UINT): HDSKSPC; stdcall;\r\n TSetupCreateDiskSpaceListW = function(Reserved1: Pointer; Reserved2: DWORD;\r\n Flags: UINT): HDSKSPC; stdcall;\r\n {$IFDEF UNICODE}\r\n TSetupCreateDiskSpaceList = TSetupCreateDiskSpaceListW;\r\n {$ELSE}\r\n TSetupCreateDiskSpaceList = TSetupCreateDiskSpaceListA;\r\n {$ENDIF UNICODE}\r\n\r\n TSetupDuplicateDiskSpaceListA = function(DiskSpace: HDSKSPC; Reserved1: Pointer;\r\n Reserved2: DWORD; Flags: UINT): HDSKSPC; stdcall;\r\n TSetupDuplicateDiskSpaceListW = function(DiskSpace: HDSKSPC; Reserved1: Pointer;\r\n Reserved2: DWORD; Flags: UINT): HDSKSPC; stdcall;\r\n {$IFDEF UNICODE}\r\n TSetupDuplicateDiskSpaceList = TSetupDuplicateDiskSpaceListW;\r\n {$ELSE}\r\n TSetupDuplicateDiskSpaceList = TSetupDuplicateDiskSpaceListA;\r\n {$ENDIF UNICODE}\r\n\r\n TSetupDestroyDiskSpaceList = function(DiskSpace: HDSKSPC): BOOL; stdcall;\r\n\r\n TSetupQueryDrivesInDiskSpaceListA = function(DiskSpace: HDSKSPC; ReturnBuffer: PAnsiChar;\r\n ReturnBufferSize: DWORD; RequiredSize: PDWORD): BOOL; stdcall;\r\n TSetupQueryDrivesInDiskSpaceListW = function(DiskSpace: HDSKSPC; ReturnBuffer: PWideChar;\r\n ReturnBufferSize: DWORD; RequiredSize: PDWORD): BOOL; stdcall;\r\n TSetupQueryDrivesInDiskSpaceList = function(DiskSpace: HDSKSPC; ReturnBuffer: PTSTR;\r\n ReturnBufferSize: DWORD; RequiredSize: PDWORD): BOOL; stdcall;\r\n\r\n TSetupQuerySpaceRequiredOnDriveA = function(DiskSpace: HDSKSPC; const DriveSpec: PAnsiChar;\r\n var SpaceRequired: Int64; Reserved1: Pointer; Reserved2: UINT): BOOL; stdcall;\r\n TSetupQuerySpaceRequiredOnDriveW = function(DiskSpace: HDSKSPC; const DriveSpec: PWideChar;\r\n var SpaceRequired: Int64; Reserved1: Pointer; Reserved2: UINT): BOOL; stdcall;\r\n TSetupQuerySpaceRequiredOnDrive = function(DiskSpace: HDSKSPC; const DriveSpec: PTSTR;\r\n var SpaceRequired: Int64; Reserved1: Pointer; Reserved2: UINT): BOOL; stdcall;\r\n\r\n TSetupAdjustDiskSpaceListA = function(DiskSpace: HDSKSPC; const DriveRoot: PAnsiChar;\r\n Amount: Int64; Reserved1: Pointer; Reserved2: UINT): BOOL; stdcall;\r\n TSetupAdjustDiskSpaceListW = function(DiskSpace: HDSKSPC; const DriveRoot: PWideChar;\r\n Amount: Int64; Reserved1: Pointer; Reserved2: UINT): BOOL; stdcall;\r\n TSetupAdjustDiskSpaceList = function(DiskSpace: HDSKSPC; const DriveRoot: PTSTR;\r\n Amount: Int64; Reserved1: Pointer; Reserved2: UINT): BOOL; stdcall;\r\n\r\n TSetupAddToDiskSpaceListA = function(DiskSpace: HDSKSPC; const TargetFilespec: PAnsiChar;\r\n FileSize: Int64; Operation: UINT; Reserved1: Pointer; Reserved2: UINT): BOOL; stdcall;\r\n TSetupAddToDiskSpaceListW = function(DiskSpace: HDSKSPC; const TargetFilespec: PWideChar;\r\n FileSize: Int64; Operation: UINT; Reserved1: Pointer; Reserved2: UINT): BOOL; stdcall;\r\n TSetupAddToDiskSpaceList = function(DiskSpace: HDSKSPC; const TargetFilespec: PTSTR;\r\n FileSize: Int64; Operation: UINT; Reserved1: Pointer; Reserved2: UINT): BOOL; stdcall;\r\n\r\n TSetupAddSectionToDiskSpaceListA = function(DiskSpace: HDSKSPC; InfHandle: HINF;\r\n ListInfHandle: HINF; const SectionName: PAnsiChar; Operation: UINT;\r\n Reserved1: Pointer; Reserved2: UINT): BOOL; stdcall;\r\n TSetupAddSectionToDiskSpaceListW = function(DiskSpace: HDSKSPC; InfHandle: HINF;\r\n ListInfHandle: HINF; const SectionName: PWideChar; Operation: UINT;\r\n Reserved1: Pointer; Reserved2: UINT): BOOL; stdcall;\r\n TSetupAddSectionToDiskSpaceList = function(DiskSpace: HDSKSPC; InfHandle: HINF;\r\n ListInfHandle: HINF; const SectionName: PTSTR; Operation: UINT;\r\n Reserved1: Pointer; Reserved2: UINT): BOOL; stdcall;\r\n\r\n TSetupAddInstallSectionToDiskSpaceListA = function(DiskSpace: HDSKSPC;\r\n InfHandle: HINF; LayoutInfHandle: HINF; const SectionName: PAnsiChar;\r\n Reserved1: Pointer; Reserved2: UINT): BOOL; stdcall;\r\n TSetupAddInstallSectionToDiskSpaceListW = function(DiskSpace: HDSKSPC;\r\n InfHandle: HINF; LayoutInfHandle: HINF; const SectionName: PWideChar;\r\n Reserved1: Pointer; Reserved2: UINT): BOOL; stdcall;\r\n TSetupAddInstallSectionToDiskSpaceList = function(DiskSpace: HDSKSPC;\r\n InfHandle: HINF; LayoutInfHandle: HINF; const SectionName: PTSTR;\r\n Reserved1: Pointer; Reserved2: UINT): BOOL; stdcall;\r\n\r\n TSetupRemoveFromDiskSpaceListA = function(DiskSpace: HDSKSPC; const TargetFilespec: PAnsiChar;\r\n Operation: UINT; Reserved1: Pointer; Reserved2: UINT): BOOL; stdcall;\r\n TSetupRemoveFromDiskSpaceListW = function(DiskSpace: HDSKSPC; const TargetFilespec: PWideChar;\r\n Operation: UINT; Reserved1: Pointer; Reserved2: UINT): BOOL; stdcall;\r\n TSetupRemoveFromDiskSpaceList = function(DiskSpace: HDSKSPC; const TargetFilespec: PTSTR;\r\n Operation: UINT; Reserved1: Pointer; Reserved2: UINT): BOOL; stdcall;\r\n\r\n TSetupRemoveSectionFromDiskSpaceListA = function(DiskSpace: HDSKSPC; InfHandle: HINF;\r\n ListInfHandle: HINF; const SectionName: PAnsiChar; Operation: UINT; Reserved1: Pointer;\r\n Reserved2: UINT): BOOL; stdcall;\r\n TSetupRemoveSectionFromDiskSpaceListW = function(DiskSpace: HDSKSPC; InfHandle: HINF;\r\n ListInfHandle: HINF; const SectionName: PWideChar; Operation: UINT; Reserved1: Pointer;\r\n Reserved2: UINT): BOOL; stdcall;\r\n TSetupRemoveSectionFromDiskSpaceList = function(DiskSpace: HDSKSPC; InfHandle: HINF;\r\n ListInfHandle: HINF; const SectionName: PTSTR; Operation: UINT; Reserved1: Pointer;\r\n Reserved2: UINT): BOOL; stdcall;\r\n\r\n TSetupRemoveInstallSectionFromDiskSpaceListA = function(DiskSpace: HDSKSPC;\r\n InfHandle: HINF; LayoutInfHandle: HINF; const SectionName: PAnsiChar;\r\n Reserved1: Pointer; Reserved2: UINT): BOOL; stdcall;\r\n TSetupRemoveInstallSectionFromDiskSpaceListW = function(DiskSpace: HDSKSPC;\r\n InfHandle: HINF; LayoutInfHandle: HINF; const SectionName: PWideChar;\r\n Reserved1: Pointer; Reserved2: UINT): BOOL; stdcall;\r\n TSetupRemoveInstallSectionFromDiskSpaceList = function(DiskSpace: HDSKSPC;\r\n InfHandle: HINF; LayoutInfHandle: HINF; const SectionName: PTSTR;\r\n Reserved1: Pointer; Reserved2: UINT): BOOL; stdcall;\r\n\r\n//\r\n// Cabinet APIs\r\n//\r\n\r\n TSetupIterateCabinetA = function(const CabinetFile: PAnsiChar; Reserved: DWORD;\r\n MsgHandler: TSPFileCallbackA; Context: Pointer): BOOL; stdcall;\r\n TSetupIterateCabinetW = function(const CabinetFile: PWideChar; Reserved: DWORD;\r\n MsgHandler: TSPFileCallbackW; Context: Pointer): BOOL; stdcall;\r\n TSetupIterateCabinet = function(const CabinetFile: PTSTR; Reserved: DWORD;\r\n MsgHandler: TSPFileCallback; Context: Pointer): BOOL; stdcall;\r\n\r\n TSetupPromptReboot = function(FileQueue: HSPFILEQ; Owner: HWND; ScanOnly: BOOL): Integer; stdcall;\r\n\r\n TSetupInitDefaultQueueCallback = function(OwnerWindow: HWND): Pointer; stdcall;\r\n\r\n TSetupInitDefaultQueueCallbackEx = function(OwnerWindow: HWND; AlternateProgressWindow: HWND;\r\n ProgressMessage: UINT; Reserved1: DWORD; Reserved2: Pointer): Pointer; stdcall;\r\n\r\n TSetupTermDefaultQueueCallback = procedure(Context: Pointer); stdcall;\r\n\r\n TSetupDefaultQueueCallbackA = function(Context: Pointer; Notification: UINT;\r\n Param1, Param2: UINT_PTR): UINT; stdcall;\r\n TSetupDefaultQueueCallbackW = function(Context: Pointer; Notification: UINT;\r\n Param1, Param2: UINT_PTR): UINT; stdcall;\r\n {$IFDEF UNICODE}\r\n TSetupDefaultQueueCallback = TSetupDefaultQueueCallbackW;\r\n {$ELSE}\r\n TSetupDefaultQueueCallback = TSetupDefaultQueueCallbackA;\r\n {$ENDIF UNICODE}\r\n\r\n//\r\n// The INF may supply any arbitrary data type ordinal in the highword except\r\n// for the following: REG_NONE, REG_SZ, REG_EXPAND_SZ, REG_MULTI_SZ. If this\r\n// technique is used, then the data is given in binary format, one byte per\r\n// field.\r\n//\r\n\r\n TSetupInstallFromInfSectionA = function(Owner: HWND; InfHandle: HINF;\r\n const SectionName: PAnsiChar; Flags: UINT; RelativeKeyRoot: HKEY;\r\n const SourceRootPath: PAnsiChar; CopyFlags: UINT; MsgHandler: TSPFileCallbackA;\r\n Context: Pointer; DeviceInfoSet: HDEVINFO; DeviceIn: PSPDevInfoData): BOOL; stdcall;\r\n TSetupInstallFromInfSectionW = function(Owner: HWND; InfHandle: HINF;\r\n const SectionName: PWideChar; Flags: UINT; RelativeKeyRoot: HKEY;\r\n const SourceRootPath: PWideChar; CopyFlags: UINT; MsgHandler: TSPFileCallbackW;\r\n Context: Pointer; DeviceInfoSet: HDEVINFO; DeviceIn: PSPDevInfoData): BOOL; stdcall;\r\n TSetupInstallFromInfSection = function(Owner: HWND; InfHandle: HINF;\r\n const SectionName: PTSTR; Flags: UINT; RelativeKeyRoot: HKEY;\r\n const SourceRootPath: PTSTR; CopyFlags: UINT; MsgHandler: TSPFileCallback;\r\n Context: Pointer; DeviceInfoSet: HDEVINFO; DeviceIn: PSPDevInfoData): BOOL; stdcall;\r\n\r\n TSetupInstallFilesFromInfSectionA = function(InfHandle: HINF; LayoutInfHandle: HINF;\r\n FileQueue: HSPFILEQ; const SectionName, SourceRootPath: PAnsiChar;\r\n CopyFlags: UINT): BOOL; stdcall;\r\n TSetupInstallFilesFromInfSectionW = function(InfHandle: HINF; LayoutInfHandle: HINF;\r\n FileQueue: HSPFILEQ; const SectionName, SourceRootPath: PWideChar;\r\n CopyFlags: UINT): BOOL; stdcall;\r\n TSetupInstallFilesFromInfSection = function(InfHandle: HINF; LayoutInfHandle: HINF;\r\n FileQueue: HSPFILEQ; const SectionName, SourceRootPath: PTSTR;\r\n CopyFlags: UINT): BOOL; stdcall;\r\n\r\n TSetupInstallServicesFromInfSectionA = function(InfHandle: HINF;\r\n const SectionName: PAnsiChar; Flags: DWORD): BOOL; stdcall;\r\n TSetupInstallServicesFromInfSectionW = function(InfHandle: HINF;\r\n const SectionName: PWideChar; Flags: DWORD): BOOL; stdcall;\r\n TSetupInstallServicesFromInfSection = function(InfHandle: HINF;\r\n const SectionName: PTSTR; Flags: DWORD): BOOL; stdcall;\r\n\r\n TSetupInstallServicesFromInfSectionExA = function(InfHandle: HINF;\r\n const SectionName: PAnsiChar; Flags: DWORD; DeviceInfoSet: HDEVINFO;\r\n DeviceInfoData: TSPDevInfoData; Reserved1, Reserved2: Pointer): BOOL; stdcall;\r\n TSetupInstallServicesFromInfSectionExW = function(InfHandle: HINF;\r\n const SectionName: PWideChar; Flags: DWORD; DeviceInfoSet: HDEVINFO;\r\n DeviceInfoData: TSPDevInfoData; Reserved1, Reserved2: Pointer): BOOL; stdcall;\r\n TSetupInstallServicesFromInfSectionEx = function(InfHandle: HINF;\r\n const SectionName: PTSTR; Flags: DWORD; DeviceInfoSet: HDEVINFO;\r\n DeviceInfoData: TSPDevInfoData; Reserved1, Reserved2: Pointer): BOOL; stdcall;\r\n\r\n {$IFDEF WINXP_UP}\r\n TInstallHinfSectionA = procedure(Window: HWND; ModuleHandle: HINST;\r\n CommandLine: PAnsiChar; ShowCommand: Integer); stdcall;\r\n TInstallHinfSectionW = procedure(Window: HWND; ModuleHandle: HINST;\r\n CommandLine: PWideChar; ShowCommand: Integer); stdcall;\r\n TInstallHinfSection = procedure (Window: HWND; ModuleHandle: HINST;\r\n CommandLine: PTSTR; ShowCommand: Integer); stdcall;\r\n {$ENDIF WINXP_UP}\r\n\r\n//\r\n// Define handle type for Setup file log.\r\n//\r\n\r\ntype\r\n HSPFILELOG = Pointer;\r\n {$EXTERNALSYM HSPFILELOG}\r\n\r\n TSetupInitializeFileLogA = function(const LogFileName: PAnsiChar; Flags: DWORD): HSPFILELOG; stdcall;\r\n TSetupInitializeFileLogW = function(const LogFileName: PWideChar; Flags: DWORD): HSPFILELOG; stdcall;\r\n TSetupInitializeFileLog = function(const LogFileName: PTSTR; Flags: DWORD): HSPFILELOG; stdcall;\r\n\r\n TSetupTerminateFileLog = function(FileLogHandle: HSPFILELOG): BOOL; stdcall;\r\n\r\n TSetupLogFileA = function(FileLogHandle: HSPFILELOG; const LogSectionName,\r\n SourceFilename, TargetFilename: PAnsiChar; Checksum: DWORD; DiskTagfile,\r\n DiskDescription, OtherInfo: PAnsiChar; Flags: DWORD): BOOL; stdcall;\r\n TSetupLogFileW = function(FileLogHandle: HSPFILELOG; const LogSectionName,\r\n SourceFilename, TargetFilename: PWideChar; Checksum: DWORD; DiskTagfile,\r\n DiskDescription, OtherInfo: PWideChar; Flags: DWORD): BOOL; stdcall;\r\n TSetupLogFile = function(FileLogHandle: HSPFILELOG; const LogSectionName,\r\n SourceFilename, TargetFilename: PTSTR; Checksum: DWORD; DiskTagfile,\r\n DiskDescription, OtherInfo: PTSTR; Flags: DWORD): BOOL; stdcall;\r\n\r\n TSetupRemoveFileLogEntryA = function(FileLogHandle: HSPFILELOG;\r\n const LogSectionName: PAnsiChar; const TargetFilename: PAnsiChar): BOOL; stdcall;\r\n TSetupRemoveFileLogEntryW = function(FileLogHandle: HSPFILELOG;\r\n const LogSectionName: PWideChar; const TargetFilename: PWideChar): BOOL; stdcall;\r\n TSetupRemoveFileLogEntry = function(FileLogHandle: HSPFILELOG;\r\n const LogSectionName: PTSTR; const TargetFilename: PTSTR): BOOL; stdcall;\r\n\r\n TSetupQueryFileLogA = function(FileLogHandle: HSPFILELOG; const LogSectionName,\r\n TargetFilename: PAnsiChar; DesiredInfo: SetupFileLogInfo; DataOut: PAnsiChar;\r\n ReturnBufferSize: DWORD; RequiredSize: PDWORD): BOOL; stdcall;\r\n TSetupQueryFileLogW = function(FileLogHandle: HSPFILELOG; const LogSectionName,\r\n TargetFilename: PWideChar; DesiredInfo: SetupFileLogInfo; DataOut: PWideChar;\r\n ReturnBufferSize: DWORD; RequiredSize: PDWORD): BOOL; stdcall;\r\n TSetupQueryFileLog = function(FileLogHandle: HSPFILELOG; const LogSectionName,\r\n TargetFilename: PTSTR; DesiredInfo: SetupFileLogInfo; DataOut: PTSTR;\r\n ReturnBufferSize: DWORD; RequiredSize: PDWORD): BOOL; stdcall;\r\n\r\n//\r\n// Text logging APIs\r\n//\r\n\r\n TSetupOpenLog = function(Erase: BOOL): BOOL; stdcall;\r\n\r\n TSetupLogErrorA = function(const MessageString: PAnsiChar; Severity: LOGSEVERITY): BOOL; stdcall;\r\n TSetupLogErrorW = function(const MessageString: PWideChar; Severity: LOGSEVERITY): BOOL; stdcall;\r\n TSetupLogError = function(const MessageString: PTSTR; Severity: LOGSEVERITY): BOOL; stdcall;\r\n\r\n TSetupCloseLog = procedure; stdcall;\r\n\r\n//\r\n// Backup Information API\r\n//\r\n\r\n {$IFDEF WIN2000_UP}\r\n TSetupGetBackupInformationA = function(QueueHandle: HSPFILEQ;\r\n var BackupParams: TSPBackupQueueParamsA): BOOL; stdcall;\r\n TSetupGetBackupInformationW = function(QueueHandle: HSPFILEQ;\r\n var BackupParams: TSPBackupQueueParamsW): BOOL; stdcall;\r\n TSetupGetBackupInformation = function(QueueHandle: HSPFILEQ;\r\n var BackupParams: TSPBackupQueueParams): BOOL; stdcall;\r\n {$ENDIF WIN2000_UP}\r\n\r\n {$IFDEF WINXP_UP}\r\n TSetupPrepareQueueForRestoreA = function(QueueHandle: HSPFILEQ;\r\n BackupPath: PAnsiChar; RestoreFlags: DWORD): BOOL; stdcall;\r\n TSetupPrepareQueueForRestoreW = function(QueueHandle: HSPFILEQ;\r\n BackupPath: PWideChar; RestoreFlags: DWORD): BOOL; stdcall;\r\n TSetupPrepareQueueForRestore = function(QueueHandle: HSPFILEQ;\r\n BackupPath: PTSTR; RestoreFlags: DWORD): BOOL; stdcall;\r\n\r\n TSetupSetNonInteractiveMode = function(NonInteractiveFlag: BOOL): BOOL; stdcall;\r\n TSetupGetNonInteractiveMode = function: BOOL; stdcall;\r\n {$ENDIF WINXP_UP}\r\n\r\n//\r\n// Device Installer APIs\r\n//\r\n\r\n TSetupDiCreateDeviceInfoList = function(ClassGuid: PGUID; hwndParent: HWND): HDEVINFO; stdcall;\r\n\r\n TSetupDiCreateDeviceInfoListExA = function(ClassGuid: PGUID; hwndParent: HWND;\r\n const MachineName: PAnsiChar; Reserved: Pointer): HDEVINFO; stdcall;\r\n TSetupDiCreateDeviceInfoListExW = function(ClassGuid: PGUID; hwndParent: HWND;\r\n const MachineName: PWideChar; Reserved: Pointer): HDEVINFO; stdcall;\r\n TSetupDiCreateDeviceInfoListEx = function(ClassGuid: PGUID; hwndParent: HWND;\r\n const MachineName: PTSTR; Reserved: Pointer): HDEVINFO; stdcall;\r\n\r\n TSetupDiGetDeviceInfoListClass = function(DeviceInfoSet: HDEVINFO;\r\n var ClassGuid: TGUID): BOOL; stdcall;\r\n\r\n TSetupDiGetDeviceInfoListDetailA = function(DeviceInfoSet: HDEVINFO;\r\n var DeviceInfoSetDetailData: TSPDevInfoListDetailDataA): BOOL; stdcall;\r\n TSetupDiGetDeviceInfoListDetailW = function(DeviceInfoSet: HDEVINFO;\r\n var DeviceInfoSetDetailData: TSPDevInfoListDetailDataW): BOOL; stdcall;\r\n TSetupDiGetDeviceInfoListDetail = function(DeviceInfoSet: HDEVINFO;\r\n var DeviceInfoSetDetailData: TSPDevInfoListDetailData): BOOL; stdcall;\r\n\r\n TSetupDiCreateDeviceInfoA = function(DeviceInfoSet: HDEVINFO; const DeviceName: PAnsiChar;\r\n var ClassGuid: TGUID; const DeviceDescription: PAnsiChar; hwndParent: HWND;\r\n CreationFlags: DWORD; DeviceInfoData: PSPDevInfoData): BOOL; stdcall;\r\n TSetupDiCreateDeviceInfoW = function(DeviceInfoSet: HDEVINFO; const DeviceName: PWideChar;\r\n var ClassGuid: TGUID; const DeviceDescription: PWideChar; hwndParent: HWND;\r\n CreationFlags: DWORD; DeviceInfoData: PSPDevInfoData): BOOL; stdcall;\r\n TSetupDiCreateDeviceInfo = function(DeviceInfoSet: HDEVINFO; const DeviceName: PTSTR;\r\n var ClassGuid: TGUID; const DeviceDescription: PTSTR; hwndParent: HWND;\r\n CreationFlags: DWORD; DeviceInfoData: PSPDevInfoData): BOOL; stdcall;\r\n\r\n TSetupDiOpenDeviceInfoA = function(DeviceInfoSet: HDEVINFO;\r\n const DeviceInstanceId: PAnsiChar; hwndParent: HWND; OpenFlags: DWORD;\r\n var DeviceInfoData: TSPDevInfoData): BOOL; stdcall;\r\n TSetupDiOpenDeviceInfoW = function(DeviceInfoSet: HDEVINFO;\r\n const DeviceInstanceId: PWideChar; hwndParent: HWND; OpenFlags: DWORD;\r\n var DeviceInfoData: TSPDevInfoData): BOOL; stdcall;\r\n TSetupDiOpenDeviceInfo = function(DeviceInfoSet: HDEVINFO;\r\n const DeviceInstanceId: PTSTR; hwndParent: HWND; OpenFlags: DWORD;\r\n var DeviceInfoData: TSPDevInfoData): BOOL; stdcall;\r\n\r\n TSetupDiGetDeviceInstanceIdA = function(DeviceInfoSet: HDEVINFO;\r\n DeviceInfoData: PSPDevInfoData; DeviceInstanceId: PAnsiChar;\r\n DeviceInstanceIdSize: DWORD; RequiredSize: PDWORD): BOOL; stdcall;\r\n TSetupDiGetDeviceInstanceIdW = function(DeviceInfoSet: HDEVINFO;\r\n DeviceInfoData: PSPDevInfoData; DeviceInstanceId: PWideChar;\r\n DeviceInstanceIdSize: DWORD; RequiredSize: PDWORD): BOOL; stdcall;\r\n TSetupDiGetDeviceInstanceId = function(DeviceInfoSet: HDEVINFO;\r\n DeviceInfoData: PSPDevInfoData; DeviceInstanceId: PTSTR;\r\n DeviceInstanceIdSize: DWORD; RequiredSize: PDWORD): BOOL; stdcall;\r\n\r\n TSetupDiDeleteDeviceInfo = function(DeviceInfoSet: HDEVINFO;\r\n DeviceInfoData: PSPDevInfoData): BOOL; stdcall;\r\n\r\n TSetupDiEnumDeviceInfo = function(DeviceInfoSet: HDEVINFO;\r\n MemberIndex: DWORD; var DeviceInfoData: TSPDevInfoData): BOOL; stdcall;\r\n\r\n TSetupDiDestroyDeviceInfoList = function(DeviceInfoSet: HDEVINFO): BOOL; stdcall;\r\n\r\n TSetupDiEnumDeviceInterfaces = function(DeviceInfoSet: HDEVINFO;\r\n DeviceInfoData: PSPDevInfoData; const InterfaceClassGuid: TGUID;\r\n MemberIndex: DWORD; var DeviceInterfaceData: TSPDeviceInterfaceData): BOOL; stdcall;\r\n\r\n//\r\n// Backward compatibility--do not use\r\n//\r\n\r\n TSetupDiEnumInterfaceDevice = function(DeviceInfoSet: HDEVINFO;\r\n DeviceInfoData: PSPDevInfoData; var InterfaceClassGuid: TGUID;\r\n MemberIndex: DWORD; var DeviceInterfaceData: TSPDeviceInterfaceData): BOOL; stdcall;\r\n\r\n TSetupDiCreateDeviceInterfaceA = function(DeviceInfoSet: HDEVINFO;\r\n var DeviceInfoData: TSPDevInfoData; var InterfaceClassGuid: TGUID;\r\n const ReferenceString: PAnsiChar; CreationFlags: DWORD;\r\n DeviceInterfaceData: PSPDeviceInterfaceData): BOOL; stdcall;\r\n TSetupDiCreateDeviceInterfaceW = function(DeviceInfoSet: HDEVINFO;\r\n var DeviceInfoData: TSPDevInfoData; var InterfaceClassGuid: TGUID;\r\n const ReferenceString: PWideChar; CreationFlags: DWORD;\r\n DeviceInterfaceData: PSPDeviceInterfaceData): BOOL; stdcall;\r\n TSetupDiCreateDeviceInterface = function(DeviceInfoSet: HDEVINFO;\r\n var DeviceInfoData: TSPDevInfoData; var InterfaceClassGuid: TGUID;\r\n const ReferenceString: PTSTR; CreationFlags: DWORD;\r\n DeviceInterfaceData: PSPDeviceInterfaceData): BOOL; stdcall;\r\n\r\n//\r\n// Backward compatibility--do not use.\r\n//\r\n\r\n TSetupDiCreateInterfaceDeviceA = function(DeviceInfoSet: HDEVINFO;\r\n var DeviceInfoData: TSPDevInfoData; var InterfaceClassGuid: TGUID;\r\n const ReferenceString: PAnsiChar; CreationFlags: DWORD;\r\n DeviceInterfaceData: PSPDeviceInterfaceData): BOOL; stdcall;\r\n TSetupDiCreateInterfaceDeviceW = function(DeviceInfoSet: HDEVINFO;\r\n var DeviceInfoData: TSPDevInfoData; var InterfaceClassGuid: TGUID;\r\n const ReferenceString: PWideChar; CreationFlags: DWORD;\r\n DeviceInterfaceData: PSPDeviceInterfaceData): BOOL; stdcall;\r\n TSetupDiCreateInterfaceDevice = function(DeviceInfoSet: HDEVINFO;\r\n var DeviceInfoData: TSPDevInfoData; var InterfaceClassGuid: TGUID;\r\n const ReferenceString: PTSTR; CreationFlags: DWORD;\r\n DeviceInterfaceData: PSPDeviceInterfaceData): BOOL; stdcall;\r\n\r\n TSetupDiOpenDeviceInterfaceA = function(DeviceInfoSet: HDEVINFO;\r\n const DevicePath: PAnsiChar; OpenFlags: DWORD;\r\n DeviceInterfaceData: PSPDeviceInterfaceData): BOOL; stdcall;\r\n TSetupDiOpenDeviceInterfaceW = function(DeviceInfoSet: HDEVINFO;\r\n const DevicePath: PWideChar; OpenFlags: DWORD;\r\n DeviceInterfaceData: PSPDeviceInterfaceData): BOOL; stdcall;\r\n TSetupDiOpenDeviceInterface = function(DeviceInfoSet: HDEVINFO;\r\n const DevicePath: PTSTR; OpenFlags: DWORD;\r\n DeviceInterfaceData: PSPDeviceInterfaceData): BOOL; stdcall;\r\n\r\n//\r\n// Backward compatibility--do not use\r\n//\r\n\r\n TSetupDiOpenInterfaceDeviceA = function(DeviceInfoSet: HDEVINFO;\r\n const DevicePath: PAnsiChar; OpenFlags: DWORD;\r\n DeviceInterfaceData: PSPDeviceInterfaceData): BOOL; stdcall;\r\n TSetupDiOpenInterfaceDeviceW = function(DeviceInfoSet: HDEVINFO;\r\n const DevicePath: PWideChar; OpenFlags: DWORD;\r\n DeviceInterfaceData: PSPDeviceInterfaceData): BOOL; stdcall;\r\n TSetupDiOpenInterfaceDevice = function(DeviceInfoSet: HDEVINFO;\r\n const DevicePath: PTSTR; OpenFlags: DWORD;\r\n DeviceInterfaceData: PSPDeviceInterfaceData): BOOL; stdcall;\r\n\r\n TSetupDiGetDeviceInterfaceAlias = function(DeviceInfoSet: HDEVINFO;\r\n var DeviceInterfaceData: TSPDeviceInterfaceData; var AliasInterfaceClassGuid: TGUID;\r\n var AliasDeviceInterfaceData: TSPDeviceInterfaceData): BOOL; stdcall;\r\n\r\n//\r\n// Backward compatibility--do not use.\r\n//\r\n\r\n TSetupDiGetInterfaceDeviceAlias = function(DeviceInfoSet: HDEVINFO;\r\n var DeviceInterfaceData: TSPDeviceInterfaceData;\r\n var AliasInterfaceClassGuid: TGUID;\r\n var AliasDeviceInterfaceData: TSPDeviceInterfaceData): BOOL; stdcall;\r\n\r\n TSetupDiDeleteDeviceInterfaceData = function(DeviceInfoSet: HDEVINFO;\r\n var DeviceInterfaceData: TSPDeviceInterfaceData): BOOL; stdcall;\r\n\r\n//\r\n// Backward compatibility--do not use.\r\n//\r\n\r\n TSetupDiDeleteInterfaceDeviceData = function(DeviceInfoSet: HDEVINFO;\r\n var DeviceInterfaceData: TSPDeviceInterfaceData): BOOL; stdcall;\r\n\r\n TSetupDiRemoveDeviceInterface = function(DeviceInfoSet: HDEVINFO;\r\n var DeviceInterfaceData: TSPDeviceInterfaceData): BOOL; stdcall;\r\n\r\n//\r\n// Backward compatibility--do not use.\r\n//\r\n\r\n TSetupDiRemoveInterfaceDevice = function(DeviceInfoSet: HDEVINFO;\r\n var DeviceInterfaceData: TSPDeviceInterfaceData): BOOL; stdcall;\r\n\r\n TSetupDiGetDeviceInterfaceDetailA = function(DeviceInfoSet: HDEVINFO;\r\n DeviceInterfaceData: PSPDeviceInterfaceData;\r\n DeviceInterfaceDetailData: PSPDeviceInterfaceDetailDataA;\r\n DeviceInterfaceDetailDataSize: DWORD; var RequiredSize: DWORD;\r\n Device: PSPDevInfoData): BOOL; stdcall;\r\n TSetupDiGetDeviceInterfaceDetailW = function(DeviceInfoSet: HDEVINFO;\r\n DeviceInterfaceData: PSPDeviceInterfaceData;\r\n DeviceInterfaceDetailData: PSPDeviceInterfaceDetailDataW;\r\n DeviceInterfaceDetailDataSize: DWORD; var RequiredSize: DWORD;\r\n Device: PSPDevInfoData): BOOL; stdcall;\r\n TSetupDiGetDeviceInterfaceDetail = function(DeviceInfoSet: HDEVINFO;\r\n DeviceInterfaceData: PSPDeviceInterfaceData;\r\n DeviceInterfaceDetailData: PSPDeviceInterfaceDetailData;\r\n DeviceInterfaceDetailDataSize: DWORD; var RequiredSize: DWORD;\r\n Device: PSPDevInfoData): BOOL; stdcall;\r\n\r\n//\r\n// Backward compatibility--do not use.\r\n//\r\n\r\n TSetupDiGetInterfaceDeviceDetailA = function(DeviceInfoSet: HDEVINFO;\r\n DeviceInterfaceData: PSPDeviceInterfaceData;\r\n DeviceInterfaceDetailData: PSPDeviceInterfaceDetailDataA;\r\n DeviceInterfaceDetailDataSize: DWORD; RequiredSize: PDWORD;\r\n Device: PSPDevInfoData): BOOL; stdcall;\r\n TSetupDiGetInterfaceDeviceDetailW = function(DeviceInfoSet: HDEVINFO;\r\n DeviceInterfaceData: PSPDeviceInterfaceData;\r\n DeviceInterfaceDetailData: PSPDeviceInterfaceDetailDataW;\r\n DeviceInterfaceDetailDataSize: DWORD; RequiredSize: PDWORD;\r\n Device: PSPDevInfoData): BOOL; stdcall;\r\n TSetupDiGetInterfaceDeviceDetail = function(DeviceInfoSet: HDEVINFO;\r\n DeviceInterfaceData: PSPDeviceInterfaceData;\r\n DeviceInterfaceDetailData: PSPDeviceInterfaceDetailData;\r\n DeviceInterfaceDetailDataSize: DWORD; RequiredSize: PDWORD;\r\n Device: PSPDevInfoData): BOOL; stdcall;\r\n\r\n//\r\n// Default install handler for DIF_INSTALLINTERFACES.\r\n//\r\n\r\n TSetupDiInstallDeviceInterfaces = function(DeviceInfoSet: HDEVINFO;\r\n var DeviceInfoData: TSPDevInfoData): BOOL; stdcall;\r\n\r\n//\r\n// Backward compatibility--do not use.\r\n//\r\n\r\n TSetupDiInstallInterfaceDevices = function(DeviceInfoSet: HDEVINFO;\r\n var DeviceInfoData: TSPDevInfoData): BOOL; stdcall;\r\n\r\n {$IFDEF WINXP_UP}\r\n TSetupDiSetDeviceInterfaceDefault = function(DeviceInfoSet: HDEVINFO;\r\n var DeviceInterfaceData: TSPDeviceInterfaceData; Flags: DWORD;\r\n Reserved: Pointer): BOOL; stdcall;\r\n {$ENDIF WINXP_UP}\r\n\r\n//\r\n// Default install handler for DIF_REGISTERDEVICE\r\n//\r\n\r\n TSetupDiRegisterDeviceInfo = function(DeviceInfoSet: HDEVINFO;\r\n var DeviceInfoData: TSPDevInfoData; Flags: DWORD; CompareProc: TSPDetSigCmpProc;\r\n CompareContext: Pointer; DupDeviceInfoData: PSPDevInfoData): BOOL; stdcall;\r\n\r\n TSetupDiBuildDriverInfoList = function(DeviceInfoSet: HDEVINFO;\r\n DeviceInfoData: PSPDevInfoData; DriverType: DWORD): BOOL; stdcall;\r\n\r\n TSetupDiCancelDriverInfoSearch = function(DeviceInfoSet: HDEVINFO): BOOL; stdcall;\r\n\r\n TSetupDiEnumDriverInfoA = function(DeviceInfoSet: HDEVINFO;\r\n DeviceInfoData: PSPDevInfoData; DriverType: DWORD; MemberIndex: DWORD;\r\n var DriverInfoData: TSPDrvInfoDataA): BOOL; stdcall;\r\n TSetupDiEnumDriverInfoW = function(DeviceInfoSet: HDEVINFO;\r\n DeviceInfoData: PSPDevInfoData; DriverType: DWORD; MemberIndex: DWORD;\r\n var DriverInfoData: TSPDrvInfoDataW): BOOL; stdcall;\r\n TSetupDiEnumDriverInfo = function(DeviceInfoSet: HDEVINFO;\r\n DeviceInfoData: PSPDevInfoData; DriverType: DWORD; MemberIndex: DWORD;\r\n var DriverInfoData: TSPDrvInfoData): BOOL; stdcall;\r\n\r\n TSetupDiGetSelectedDriverA = function(DeviceInfoSet: HDEVINFO;\r\n DeviceInfoData: PSPDevInfoData; var DriverInfoData: TSPDrvInfoDataA): BOOL; stdcall;\r\n TSetupDiGetSelectedDriverW = function(DeviceInfoSet: HDEVINFO;\r\n DeviceInfoData: PSPDevInfoData; var DriverInfoData: TSPDrvInfoDataW): BOOL; stdcall;\r\n TSetupDiGetSelectedDriver = function(DeviceInfoSet: HDEVINFO;\r\n DeviceInfoData: PSPDevInfoData; var DriverInfoData: TSPDrvInfoData): BOOL; stdcall;\r\n\r\n TSetupDiSetSelectedDriverA = function(DeviceInfoSet: HDEVINFO;\r\n DeviceInfoData: PSPDevInfoData; DriverInfoData: PSPDrvInfoDataA): BOOL; stdcall;\r\n TSetupDiSetSelectedDriverW = function(DeviceInfoSet: HDEVINFO;\r\n DeviceInfoData: PSPDevInfoData; DriverInfoData: PSPDrvInfoDataW): BOOL; stdcall;\r\n TSetupDiSetSelectedDriver = function(DeviceInfoSet: HDEVINFO;\r\n DeviceInfoData: PSPDevInfoData; DriverInfoData: PSPDrvInfoData): BOOL; stdcall;\r\n\r\n TSetupDiGetDriverInfoDetailA = function(DeviceInfoSet: HDEVINFO;\r\n DeviceInfoData: PSPDevInfoData; var DriverInfoData: TSPDrvInfoDataA;\r\n DriverInfoDetailData: PSPDrvInfoDetailDataA; DriverInfoDetailDataSize: DWORD;\r\n RequiredSize: PDWORD): BOOL; stdcall;\r\n TSetupDiGetDriverInfoDetailW = function(DeviceInfoSet: HDEVINFO;\r\n DeviceInfoData: PSPDevInfoData; var DriverInfoData: TSPDrvInfoDataW;\r\n DriverInfoDetailData: PSPDrvInfoDetailDataW; DriverInfoDetailDataSize: DWORD;\r\n RequiredSize: PDWORD): BOOL; stdcall;\r\n TSetupDiGetDriverInfoDetail = function(DeviceInfoSet: HDEVINFO;\r\n DeviceInfoData: PSPDevInfoData; var DriverInfoData: TSPDrvInfoData;\r\n DriverInfoDetailData: PSPDrvInfoDetailData; DriverInfoDetailDataSize: DWORD;\r\n RequiredSize: PDWORD): BOOL; stdcall;\r\n\r\n TSetupDiDestroyDriverInfoList = function(DeviceInfoSet: HDEVINFO;\r\n DeviceInfoData: PSPDevInfoData; DriverType: DWORD): BOOL; stdcall;\r\n\r\n TSetupDiGetClassDevsA = function(ClassGuid: PGUID; const Enumerator: PAnsiChar;\r\n hwndParent: HWND; Flags: DWORD): HDEVINFO; stdcall;\r\n TSetupDiGetClassDevsW = function(ClassGuid: PGUID; const Enumerator: PWideChar;\r\n hwndParent: HWND; Flags: DWORD): HDEVINFO; stdcall;\r\n TSetupDiGetClassDevs = function(ClassGuid: PGUID; const Enumerator: PTSTR;\r\n hwndParent: HWND; Flags: DWORD): HDEVINFO; stdcall;\r\n\r\n TSetupDiGetClassDevsExA = function(ClassGuid: PGUID; const Enumerator: PAnsiChar;\r\n hwndParent: HWND; Flags: DWORD; DeviceInfoSet: HDEVINFO; const MachineName: PAnsiChar;\r\n Reserved: Pointer): HDEVINFO; stdcall;\r\n TSetupDiGetClassDevsExW = function(ClassGuid: PGUID; const Enumerator: PWideChar;\r\n hwndParent: HWND; Flags: DWORD; DeviceInfoSet: HDEVINFO; const MachineName: PWideChar;\r\n Reserved: Pointer): HDEVINFO; stdcall;\r\n TSetupDiGetClassDevsEx = function(ClassGuid: PGUID; const Enumerator: PTSTR;\r\n hwndParent: HWND; Flags: DWORD; DeviceInfoSet: HDEVINFO; const MachineName: PTSTR;\r\n Reserved: Pointer): HDEVINFO; stdcall;\r\n\r\n TSetupDiGetINFClassA = function(const InfName: PAnsiChar; var ClassGuid: TGUID;\r\n ClassName: PAnsiChar; ClassNameSize: DWORD; RequiredSize: PDWORD): BOOL; stdcall;\r\n TSetupDiGetINFClassW = function(const InfName: PWideChar; var ClassGuid: TGUID;\r\n ClassName: PWideChar; ClassNameSize: DWORD; RequiredSize: PDWORD): BOOL; stdcall;\r\n TSetupDiGetINFClass = function(const InfName: PTSTR; var ClassGuid: TGUID;\r\n ClassName: PTSTR; ClassNameSize: DWORD; RequiredSize: PDWORD): BOOL; stdcall;\r\n\r\n TSetupDiBuildClassInfoList = function(Flags: DWORD; ClassGuidList: PGUID;\r\n ClassGuidListSize: DWORD; var RequiredSize: DWORD): BOOL; stdcall;\r\n\r\n TSetupDiBuildClassInfoListExA = function(Flags: DWORD; ClassGuidList: PGUID;\r\n ClassGuidListSize: DWORD; var RequiredSize: DWORD; const MachineName: PAnsiChar;\r\n Reserved: Pointer): BOOL; stdcall;\r\n TSetupDiBuildClassInfoListExW = function(Flags: DWORD; ClassGuidList: PGUID;\r\n ClassGuidListSize: DWORD; var RequiredSize: DWORD; const MachineName: PWideChar;\r\n Reserved: Pointer): BOOL; stdcall;\r\n TSetupDiBuildClassInfoListEx = function(Flags: DWORD; ClassGuidList: PGUID;\r\n ClassGuidListSize: DWORD; var RequiredSize: DWORD; const MachineName: PTSTR;\r\n Reserved: Pointer): BOOL; stdcall;\r\n\r\n TSetupDiGetClassDescriptionA = function(var ClassGuid: TGUID; ClassDescription: PAnsiChar;\r\n ClassDescriptionSize: DWORD; var RequiredSize: DWORD): BOOL; stdcall;\r\n TSetupDiGetClassDescriptionW = function(var ClassGuid: TGUID; ClassDescription: PWideChar;\r\n ClassDescriptionSize: DWORD; var RequiredSize: DWORD): BOOL; stdcall;\r\n TSetupDiGetClassDescription = function(var ClassGuid: TGUID; ClassDescription: PTSTR;\r\n ClassDescriptionSize: DWORD; var RequiredSize: DWORD): BOOL; stdcall;\r\n\r\n TSetupDiGetClassDescriptionExA = function(var ClassGuid: TGUID;\r\n ClassDescription: PAnsiChar; ClassDescriptionSize: DWORD; var RequiredSize: DWORD;\r\n const MachineName: PAnsiChar; Reserved: Pointer): BOOL; stdcall;\r\n TSetupDiGetClassDescriptionExW = function(var ClassGuid: TGUID;\r\n ClassDescription: PWideChar; ClassDescriptionSize: DWORD; var RequiredSize: DWORD;\r\n const MachineName: PWideChar; Reserved: Pointer): BOOL; stdcall;\r\n TSetupDiGetClassDescriptionEx = function(var ClassGuid: TGUID;\r\n ClassDescription: PTSTR; ClassDescriptionSize: DWORD; var RequiredSize: DWORD;\r\n const MachineName: PTSTR; Reserved: Pointer): BOOL; stdcall;\r\n\r\n TSetupDiCallClassInstaller = function(InstallFunction: DI_FUNCTION;\r\n DeviceInfoSet: HDEVINFO; DeviceInfoData: PSPDevInfoData): BOOL; stdcall;\r\n\r\n//\r\n// Default install handler for DIF_SELECTDEVICE\r\n//\r\n\r\n TSetupDiSelectDevice = function(DeviceInfoSet: HDEVINFO;\r\n DeviceInfoData: PSPDevInfoData): BOOL; stdcall;\r\n\r\n//\r\n// Default install handler for DIF_SELECTBESTCOMPATDRV\r\n//\r\n\r\n TSetupDiSelectBestCompatDrv = function(DeviceInfoSet: HDEVINFO;\r\n DeviceInfoData: PSPDevInfoData): BOOL; stdcall;\r\n\r\n//\r\n// Default install handler for DIF_INSTALLDEVICE\r\n//\r\n TSetupDiInstallDevice = function(DeviceInfoSet: HDEVINFO;\r\n var DeviceInfoData: TSPDevInfoData): BOOL; stdcall;\r\n\r\n//\r\n// Default install handler for DIF_INSTALLDEVICEFILES\r\n//\r\n\r\n TSetupDiInstallDriverFiles = function(DeviceInfoSet: HDEVINFO;\r\n var DeviceInfoData: TSPDevInfoData): BOOL; stdcall;\r\n\r\n//\r\n// Default install handler for DIF_REGISTER_COINSTALLERS\r\n//\r\n TSetupDiRegisterCoDeviceInstallers = function(DeviceInfoSet: HDEVINFO;\r\n var DeviceInfoData: TSPDevInfoData): BOOL; stdcall;\r\n\r\n//\r\n// Default install handler for DIF_REMOVE\r\n//\r\n\r\n TSetupDiRemoveDevice = function(DeviceInfoSet: HDEVINFO;\r\n var DeviceInfoData: TSPDevInfoData): BOOL; stdcall;\r\n\r\n//\r\n// Default install handler for DIF_UNREMOVE\r\n//\r\n\r\n TSetupDiUnremoveDevice = function(DeviceInfoSet: HDEVINFO;\r\n var DeviceInfoData: TSPDevInfoData): BOOL; stdcall;\r\n\r\n//\r\n// Default install handler for DIF_MOVEDEVICE\r\n//\r\n TSetupDiMoveDuplicateDevice = function(DeviceInfoSet: HDEVINFO;\r\n var DestinationDeviceInfoData: TSPDevInfoData): BOOL; stdcall;\r\n\r\n//\r\n// Default install handler for DIF_PROPERTYCHANGE\r\n//\r\n TSetupDiChangeState = function(DeviceInfoSet: HDEVINFO;\r\n var DeviceInfoData: TSPDevInfoData): BOOL; stdcall;\r\n\r\n TSetupDiInstallClassA = function(hwndParent: HWND; const InfFileName: PAnsiChar;\r\n Flags: DWORD; FileQueue: HSPFILEQ): BOOL; stdcall;\r\n TSetupDiInstallClassW = function(hwndParent: HWND; const InfFileName: PWideChar;\r\n Flags: DWORD; FileQueue: HSPFILEQ): BOOL; stdcall;\r\n TSetupDiInstallClass = function(hwndParent: HWND; const InfFileName: PTSTR;\r\n Flags: DWORD; FileQueue: HSPFILEQ): BOOL; stdcall;\r\n\r\n TSetupDiInstallClassExA = function(hwndParent: HWND; const InfFileName: PAnsiChar;\r\n Flags: DWORD; FileQueue: HSPFILEQ; InterfaceClassGuid: PGUID; Reserved1,\r\n Reserved2: Pointer): BOOL; stdcall;\r\n TSetupDiInstallClassExW = function(hwndParent: HWND; const InfFileName: PWideChar;\r\n Flags: DWORD; FileQueue: HSPFILEQ; InterfaceClassGuid: PGUID; Reserved1,\r\n Reserved2: Pointer): BOOL; stdcall;\r\n TSetupDiInstallClassEx = function(hwndParent: HWND; const InfFileName: PTSTR;\r\n Flags: DWORD; FileQueue: HSPFILEQ; InterfaceClassGuid: PGUID; Reserved1,\r\n Reserved2: Pointer): BOOL; stdcall;\r\n\r\n TSetupDiOpenClassRegKey = function(ClassGuid: PGUID; samDesired: REGSAM): HKEY; stdcall;\r\n\r\n TSetupDiOpenClassRegKeyExA = function(ClassGuid: PGUID; samDesired: REGSAM;\r\n Flags: DWORD; const MachineName: PAnsiChar; Reserved: Pointer): HKEY; stdcall;\r\n TSetupDiOpenClassRegKeyExW = function(ClassGuid: PGUID; samDesired: REGSAM;\r\n Flags: DWORD; const MachineName: PWideChar; Reserved: Pointer): HKEY; stdcall;\r\n TSetupDiOpenClassRegKeyEx = function(ClassGuid: PGUID; samDesired: REGSAM;\r\n Flags: DWORD; const MachineName: PTSTR; Reserved: Pointer): HKEY; stdcall;\r\n\r\n TSetupDiCreateDeviceInterfaceRegKeyA = function(DeviceInfoSet: HDEVINFO;\r\n var DeviceInterfaceData: TSPDeviceInterfaceData; Reserved: DWORD;\r\n samDesired: REGSAM; InfHandle: HINF; const InfSectionName: PAnsiChar): HKEY; stdcall;\r\n TSetupDiCreateDeviceInterfaceRegKeyW = function(DeviceInfoSet: HDEVINFO;\r\n var DeviceInterfaceData: TSPDeviceInterfaceData; Reserved: DWORD;\r\n samDesired: REGSAM; InfHandle: HINF; const InfSectionName: PWideChar): HKEY; stdcall;\r\n TSetupDiCreateDeviceInterfaceRegKey = function(DeviceInfoSet: HDEVINFO;\r\n var DeviceInterfaceData: TSPDeviceInterfaceData; Reserved: DWORD;\r\n samDesired: REGSAM; InfHandle: HINF; const InfSectionName: PTSTR): HKEY; stdcall;\r\n\r\n//\r\n// Backward compatibility--do not use.\r\n//\r\n\r\n TSetupDiCreateInterfaceDeviceRegKeyA = function(DeviceInfoSet: HDEVINFO;\r\n var DeviceInterfaceData: TSPDeviceInterfaceData; Reserved: DWORD;\r\n samDesired: REGSAM; InfHandle: HINF; const InfSectionName: PAnsiChar): HKEY; stdcall;\r\n TSetupDiCreateInterfaceDeviceRegKeyW = function(DeviceInfoSet: HDEVINFO;\r\n var DeviceInterfaceData: TSPDeviceInterfaceData; Reserved: DWORD;\r\n samDesired: REGSAM; InfHandle: HINF; const InfSectionName: PWideChar): HKEY; stdcall;\r\n TSetupDiCreateInterfaceDeviceRegKey = function(DeviceInfoSet: HDEVINFO;\r\n var DeviceInterfaceData: TSPDeviceInterfaceData; Reserved: DWORD;\r\n samDesired: REGSAM; InfHandle: HINF; const InfSectionName: PTSTR): HKEY; stdcall;\r\n\r\n TSetupDiOpenDeviceInterfaceRegKey = function(DeviceInfoSet: HDEVINFO;\r\n var DeviceInterfaceData: TSPDeviceInterfaceData; Reserved: DWORD;\r\n samDesired: REGSAM): HKEY; stdcall;\r\n\r\n//\r\n// Backward compatibility--do not use.\r\n//\r\n\r\n TSetupDiOpenInterfaceDeviceRegKey = function(DeviceInfoSet: HDEVINFO;\r\n var DeviceInterfaceData: TSPDeviceInterfaceData; Reserved: DWORD;\r\n samDesired: REGSAM): HKEY; stdcall;\r\n\r\n TSetupDiDeleteDeviceInterfaceRegKey = function(DeviceInfoSet: HDEVINFO;\r\n var DeviceInterfaceData: TSPDeviceInterfaceData; Reserved: DWORD): BOOL; stdcall;\r\n\r\n//\r\n// Backward compatibility--do not use.\r\n//\r\n\r\n TSetupDiDeleteInterfaceDeviceRegKey = function(DeviceInfoSet: HDEVINFO;\r\n var DeviceInterfaceData: TSPDeviceInterfaceData; Reserved: DWORD): BOOL; stdcall;\r\n\r\n TSetupDiCreateDevRegKeyA = function(DeviceInfoSet: HDEVINFO;\r\n var DeviceInfoData: TSPDevInfoData; Scope, HwProfile, KeyType: DWORD;\r\n InfHandle: HINF; const InfSectionName: PAnsiChar): HKEY; stdcall;\r\n TSetupDiCreateDevRegKeyW = function(DeviceInfoSet: HDEVINFO;\r\n var DeviceInfoData: TSPDevInfoData; Scope, HwProfile, KeyType: DWORD;\r\n InfHandle: HINF; const InfSectionName: PWideChar): HKEY; stdcall;\r\n TSetupDiCreateDevRegKey = function(DeviceInfoSet: HDEVINFO;\r\n var DeviceInfoData: TSPDevInfoData; Scope, HwProfile, KeyType: DWORD;\r\n InfHandle: HINF; const InfSectionName: PTSTR): HKEY; stdcall;\r\n\r\n TSetupDiOpenDevRegKey = function(DeviceInfoSet: HDEVINFO;\r\n var DeviceInfoData: TSPDevInfoData; Scope, HwProfile, KeyType: DWORD;\r\n samDesired: REGSAM): HKEY; stdcall;\r\n\r\n TSetupDiDeleteDevRegKey = function(DeviceInfoSet: HDEVINFO;\r\n var DeviceInfoData: TSPDevInfoData; Scope, HwProfile,\r\n KeyType: DWORD): BOOL; stdcall;\r\n\r\n TSetupDiGetHwProfileList = function(HwProfileList: PDWORD; HwProfileListSize: DWORD;\r\n var RequiredSize: DWORD; CurrentlyActiveIndex: PDWORD): BOOL; stdcall;\r\n\r\n TSetupDiGetHwProfileListExA = function(HwProfileList: PDWORD;\r\n HwProfileListSize: DWORD; var RequiredSize: DWORD; CurrentlyActiveIndex: PDWORD;\r\n const MachineName: PAnsiChar; Reserved: Pointer): BOOL; stdcall;\r\n TSetupDiGetHwProfileListExW = function(HwProfileList: PDWORD;\r\n HwProfileListSize: DWORD; var RequiredSize: DWORD; CurrentlyActiveIndex: PDWORD;\r\n const MachineName: PWideChar; Reserved: Pointer): BOOL; stdcall;\r\n TSetupDiGetHwProfileListEx = function(HwProfileList: PDWORD;\r\n HwProfileListSize: DWORD; var RequiredSize: DWORD; CurrentlyActiveIndex: PDWORD;\r\n const MachineName: PTSTR; Reserved: Pointer): BOOL; stdcall;\r\n\r\n TSetupDiGetDeviceRegistryPropertyA = function(DeviceInfoSet: HDEVINFO;\r\n const DeviceInfoData: TSPDevInfoData; Property_: DWORD;\r\n var PropertyRegDataType: DWORD; PropertyBuffer: PBYTE; PropertyBufferSize: DWORD;\r\n var RequiredSize: DWORD): BOOL; stdcall;\r\n TSetupDiGetDeviceRegistryPropertyW = function(DeviceInfoSet: HDEVINFO;\r\n const DeviceInfoData: TSPDevInfoData; Property_: DWORD;\r\n var PropertyRegDataType: DWORD; PropertyBuffer: PBYTE; PropertyBufferSize: DWORD;\r\n var RequiredSize: DWORD): BOOL; stdcall;\r\n {$IFDEF UNICODE}\r\n TSetupDiGetDeviceRegistryProperty = TSetupDiGetDeviceRegistryPropertyW;\r\n {$ELSE}\r\n TSetupDiGetDeviceRegistryProperty = TSetupDiGetDeviceRegistryPropertyA;\r\n {$ENDIF UNICODE}\r\n\r\n {$IFDEF WINXP_UP}\r\n TSetupDiGetClassRegistryPropertyA = function(var ClassGuid: TGUID;\r\n Property_: DWORD; PropertyRegDataType: PDWORD; PropertyBuffer: PBYTE;\r\n PropertyBufferSize: DWORD; RequiredSize: PDWORD; const MachineName: PAnsiChar;\r\n Reserved: Pointer): BOOL; stdcall;\r\n TSetupDiGetClassRegistryPropertyW = function(var ClassGuid: TGUID;\r\n Property_: DWORD; PropertyRegDataType: PDWORD; PropertyBuffer: PBYTE;\r\n PropertyBufferSize: DWORD; RequiredSize: PDWORD; const MachineName: PWideChar;\r\n Reserved: Pointer): BOOL; stdcall;\r\n TSetupDiGetClassRegistryProperty = function(var ClassGuid: TGUID;\r\n Property_: DWORD; PropertyRegDataType: PDWORD; PropertyBuffer: PBYTE;\r\n PropertyBufferSize: DWORD; RequiredSize: PDWORD; const MachineName: PTSTR;\r\n Reserved: Pointer): BOOL; stdcall;\r\n {$ENDIF WINXP_UP}\r\n\r\n TSetupDiSetDeviceRegistryPropertyA = function(DeviceInfoSet: HDEVINFO;\r\n var DeviceInfoData: TSPDevInfoData; Property_: DWORD;\r\n const PropertyBuffer: PBYTE; PropertyBufferSize: DWORD): BOOL; stdcall;\r\n TSetupDiSetDeviceRegistryPropertyW = function(DeviceInfoSet: HDEVINFO;\r\n var DeviceInfoData: TSPDevInfoData; Property_: DWORD;\r\n const PropertyBuffer: PBYTE; PropertyBufferSize: DWORD): BOOL; stdcall;\r\n {$IFDEF UNICODE}\r\n TSetupDiSetDeviceRegistryProperty = TSetupDiSetDeviceRegistryPropertyW;\r\n {$ELSE}\r\n TSetupDiSetDeviceRegistryProperty = TSetupDiSetDeviceRegistryPropertyA;\r\n {$ENDIF UNICODE}\r\n\r\n {$IFDEF WINXP_UP}\r\n TSetupDiSetClassRegistryPropertyA = function(var ClassGuid: TGUID;\r\n Property_: DWORD; const PropertyBuffer: PBYTE; PropertyBufferSize: DWORD;\r\n const MachineName: PAnsiChar; Reserved: Pointer): BOOL; stdcall;\r\n TSetupDiSetClassRegistryPropertyW = function(var ClassGuid: TGUID;\r\n Property_: DWORD; const PropertyBuffer: PBYTE; PropertyBufferSize: DWORD;\r\n const MachineName: PWideChar; Reserved: Pointer): BOOL; stdcall;\r\n TSetupDiSetClassRegistryProperty = function(var ClassGuid: TGUID;\r\n Property_: DWORD; const PropertyBuffer: PBYTE; PropertyBufferSize: DWORD;\r\n const MachineName: PTSTR; Reserved: Pointer): BOOL; stdcall;\r\n {$ENDIF WINXP_UP}\r\n\r\n TSetupDiGetDeviceInstallParamsA = function(DeviceInfoSet: HDEVINFO;\r\n DeviceInfoData: PSPDevInfoData;\r\n var DeviceInstallParams: TSPDevInstallParamsA): BOOL; stdcall;\r\n TSetupDiGetDeviceInstallParamsW = function(DeviceInfoSet: HDEVINFO;\r\n DeviceInfoData: PSPDevInfoData;\r\n var DeviceInstallParams: TSPDevInstallParamsW): BOOL; stdcall;\r\n TSetupDiGetDeviceInstallParams = function(DeviceInfoSet: HDEVINFO;\r\n DeviceInfoData: PSPDevInfoData;\r\n var DeviceInstallParams: TSPDevInstallParams): BOOL; stdcall;\r\n\r\n TSetupDiGetClassInstallParamsA = function(DeviceInfoSet: HDEVINFO;\r\n DeviceInfoData: PSPDevInfoData; ClassInstallParams: PSPClassInstallHeader;\r\n ClassInstallParamsSize: DWORD; RequiredSize: PDWORD): BOOL; stdcall;\r\n TSetupDiGetClassInstallParamsW = function(DeviceInfoSet: HDEVINFO;\r\n DeviceInfoData: PSPDevInfoData; ClassInstallParams: PSPClassInstallHeader;\r\n ClassInstallParamsSize: DWORD; RequiredSize: PDWORD): BOOL; stdcall;\r\n {$IFDEF UNICODE}\r\n TSetupDiGetClassInstallParams = TSetupDiGetClassInstallParamsW;\r\n {$ELSE}\r\n TSetupDiGetClassInstallParams = TSetupDiGetClassInstallParamsA;\r\n {$ENDIF UNICODE}\r\n\r\n TSetupDiSetDeviceInstallParamsA = function(DeviceInfoSet: HDEVINFO;\r\n DeviceInfoData: PSPDevInfoData;\r\n var DeviceInstallParams: TSPDevInstallParamsA): BOOL; stdcall;\r\n TSetupDiSetDeviceInstallParamsW = function(DeviceInfoSet: HDEVINFO;\r\n DeviceInfoData: PSPDevInfoData;\r\n var DeviceInstallParams: TSPDevInstallParamsW): BOOL; stdcall;\r\n TSetupDiSetDeviceInstallParams = function(DeviceInfoSet: HDEVINFO;\r\n DeviceInfoData: PSPDevInfoData;\r\n var DeviceInstallParams: TSPDevInstallParams): BOOL; stdcall;\r\n\r\n TSetupDiSetClassInstallParamsA = function(DeviceInfoSet: HDEVINFO;\r\n DeviceInfoData: PSPDevInfoData; ClassInstallParams: PSPClassInstallHeader;\r\n ClassInstallParamsSize: DWORD): BOOL; stdcall;\r\n TSetupDiSetClassInstallParamsW = function(DeviceInfoSet: HDEVINFO;\r\n DeviceInfoData: PSPDevInfoData; ClassInstallParams: PSPClassInstallHeader;\r\n ClassInstallParamsSize: DWORD): BOOL; stdcall;\r\n {$IFDEF UNICODE}\r\n TSetupDiSetClassInstallParams = TSetupDiSetClassInstallParamsW;\r\n {$ELSE}\r\n TSetupDiSetClassInstallParams = TSetupDiSetClassInstallParamsA;\r\n {$ENDIF UNICODE}\r\n\r\n TSetupDiGetDriverInstallParamsA = function(DeviceInfoSet: HDEVINFO;\r\n DeviceInfoData: PSPDevInfoData; var DriverInfoData: TSPDrvInfoDataA;\r\n var DriverInstallParams: TSPDrvInstallParams): BOOL; stdcall;\r\n TSetupDiGetDriverInstallParamsW = function(DeviceInfoSet: HDEVINFO;\r\n DeviceInfoData: PSPDevInfoData; var DriverInfoData: TSPDrvInfoDataW;\r\n var DriverInstallParams: TSPDrvInstallParams): BOOL; stdcall;\r\n TSetupDiGetDriverInstallParams = function(DeviceInfoSet: HDEVINFO;\r\n DeviceInfoData: PSPDevInfoData; var DriverInfoData: TSPDrvInfoData;\r\n var DriverInstallParams: TSPDrvInstallParams): BOOL; stdcall;\r\n\r\n TSetupDiSetDriverInstallParamsA = function(DeviceInfoSet: HDEVINFO;\r\n DeviceInfoData: PSPDevInfoData; var DriverInfoData: TSPDrvInfoDataA;\r\n var DriverInstallParams: TSPDrvInstallParams): BOOL; stdcall;\r\n TSetupDiSetDriverInstallParamsW = function(DeviceInfoSet: HDEVINFO;\r\n DeviceInfoData: PSPDevInfoData; var DriverInfoData: TSPDrvInfoDataW;\r\n var DriverInstallParams: TSPDrvInstallParams): BOOL; stdcall;\r\n TSetupDiSetDriverInstallParams = function(DeviceInfoSet: HDEVINFO;\r\n DeviceInfoData: PSPDevInfoData; var DriverInfoData: TSPDrvInfoData;\r\n var DriverInstallParams: TSPDrvInstallParams): BOOL; stdcall;\r\n\r\n TSetupDiLoadClassIcon = function(var ClassGuid: TGUID; LargeIcon: PHICON;\r\n MiniIconIndex: PINT): BOOL; stdcall;\r\n\r\n TSetupDiDrawMiniIcon = function(hdc: HDC; rc: TRect; MiniIconIndex: Integer;\r\n Flags: DWORD): Integer; stdcall;\r\n\r\n TSetupDiGetClassBitmapIndex = function(ClassGuid: PGUID;\r\n var MiniIconIndex: Integer): BOOL; stdcall;\r\n\r\n TSetupDiGetClassImageList = function(\r\n var ClassImageListData: TSPClassImageListData): BOOL; stdcall;\r\n\r\n TSetupDiGetClassImageListExA = function(var ClassImageListData: TSPClassImageListData;\r\n const MachineName: PAnsiChar; Reserved: Pointer): BOOL; stdcall;\r\n TSetupDiGetClassImageListExW = function(var ClassImageListData: TSPClassImageListData;\r\n const MachineName: PWideChar; Reserved: Pointer): BOOL; stdcall;\r\n TSetupDiGetClassImageListEx = function(var ClassImageListData: TSPClassImageListData;\r\n const MachineName: PTSTR; Reserved: Pointer): BOOL; stdcall;\r\n\r\n TSetupDiGetClassImageIndex = function(var ClassImageListData: TSPClassImageListData;\r\n var ClassGuid: TGUID; var ImageIndex: Integer): BOOL; stdcall;\r\n\r\n TSetupDiDestroyClassImageList = function(\r\n var ClassImageListData: TSPClassImageListData): BOOL; stdcall;\r\n\r\n TSetupDiGetClassDevPropertySheetsA = function(DeviceInfoSet: HDEVINFO;\r\n DeviceInfoData: PSPDevInfoData; var PropertySheetHeader: TPropSheetHeaderA;\r\n PropertySheetHeaderPageListSize: DWORD; RequiredSize: PDWORD;\r\n PropertySheetType: DWORD): BOOL; stdcall;\r\n TSetupDiGetClassDevPropertySheetsW = function(DeviceInfoSet: HDEVINFO;\r\n DeviceInfoData: PSPDevInfoData; var PropertySheetHeader: TPropSheetHeaderW;\r\n PropertySheetHeaderPageListSize: DWORD; RequiredSize: PDWORD;\r\n PropertySheetType: DWORD): BOOL; stdcall;\r\n TSetupDiGetClassDevPropertySheets = function(DeviceInfoSet: HDEVINFO;\r\n DeviceInfoData: PSPDevInfoData; var PropertySheetHeader: TPropSheetHeader;\r\n PropertySheetHeaderPageListSize: DWORD; RequiredSize: PDWORD;\r\n PropertySheetType: DWORD): BOOL; stdcall;\r\n\r\n TSetupDiAskForOEMDisk = function(DeviceInfoSet: HDEVINFO; DeviceInfoData: PSPDevInfoData): BOOL; stdcall;\r\n\r\n TSetupDiSelectOEMDrv = function(hwndParent: HWND; DeviceInfoSet: HDEVINFO;\r\n DeviceInfoData: PSPDevInfoData): BOOL; stdcall;\r\n\r\n TSetupDiClassNameFromGuidA = function(var ClassGuid: TGUID; ClassName: PAnsiChar;\r\n ClassNameSize: DWORD; RequiredSize: PDWORD): BOOL; stdcall;\r\n TSetupDiClassNameFromGuidW = function(var ClassGuid: TGUID; ClassName: PWideChar;\r\n ClassNameSize: DWORD; RequiredSize: PDWORD): BOOL; stdcall;\r\n TSetupDiClassNameFromGuid = function(var ClassGuid: TGUID; ClassName: PTSTR;\r\n ClassNameSize: DWORD; RequiredSize: PDWORD): BOOL; stdcall;\r\n\r\n TSetupDiClassNameFromGuidExA = function(var ClassGuid: TGUID; ClassName: PAnsiChar;\r\n ClassNameSize: DWORD; RequiredSize: PDWORD; const MachineName: PAnsiChar;\r\n Reserved: Pointer): BOOL; stdcall;\r\n TSetupDiClassNameFromGuidExW = function(var ClassGuid: TGUID; ClassName: PWideChar;\r\n ClassNameSize: DWORD; RequiredSize: PDWORD; const MachineName: PWideChar;\r\n Reserved: Pointer): BOOL; stdcall;\r\n TSetupDiClassNameFromGuidEx = function(var ClassGuid: TGUID; ClassName: PTSTR;\r\n ClassNameSize: DWORD; RequiredSize: PDWORD; const MachineName: PTSTR;\r\n Reserved: Pointer): BOOL; stdcall;\r\n\r\n TSetupDiClassGuidsFromNameA = function(const ClassName: PAnsiChar; ClassGuidList: PGUID;\r\n ClassGuidListSize: DWORD; var RequiredSize: DWORD): BOOL; stdcall;\r\n TSetupDiClassGuidsFromNameW = function(const ClassName: PWideChar; ClassGuidList: PGUID;\r\n ClassGuidListSize: DWORD; var RequiredSize: DWORD): BOOL; stdcall;\r\n TSetupDiClassGuidsFromName = function(const ClassName: PTSTR; ClassGuidList: PGUID;\r\n ClassGuidListSize: DWORD; var RequiredSize: DWORD): BOOL; stdcall;\r\n\r\n TSetupDiClassGuidsFromNameExA = function(const ClassName: PAnsiChar; ClassGuidList: PGUID;\r\n ClassGuidListSize: DWORD; var RequiredSize: DWORD; const MachineName: PAnsiChar;\r\n Reserved: Pointer): BOOL; stdcall;\r\n TSetupDiClassGuidsFromNameExW = function(const ClassName: PWideChar; ClassGuidList: PGUID;\r\n ClassGuidListSize: DWORD; var RequiredSize: DWORD; const MachineName: PWideChar;\r\n Reserved: Pointer): BOOL; stdcall;\r\n TSetupDiClassGuidsFromNameEx = function(const ClassName: PTSTR; ClassGuidList: PGUID;\r\n ClassGuidListSize: DWORD; var RequiredSize: DWORD; const MachineName: PTSTR;\r\n Reserved: Pointer): BOOL; stdcall;\r\n\r\n TSetupDiGetHwProfileFriendlyNameA = function(HwProfile: DWORD; FriendlyName: PAnsiChar;\r\n FriendlyNameSize: DWORD; RequiredSize: PDWORD): BOOL; stdcall;\r\n TSetupDiGetHwProfileFriendlyNameW = function(HwProfile: DWORD; FriendlyName: PWideChar;\r\n FriendlyNameSize: DWORD; RequiredSize: PDWORD): BOOL; stdcall;\r\n TSetupDiGetHwProfileFriendlyName = function(HwProfile: DWORD; FriendlyName: PTSTR;\r\n FriendlyNameSize: DWORD; RequiredSize: PDWORD): BOOL; stdcall;\r\n\r\n TSetupDiGetHwProfileFriendlyNameExA = function(HwProfile: DWORD; FriendlyName: PAnsiChar;\r\n FriendlyNameSize: DWORD; RequiredSize: PDWORD; const MachineName: PAnsiChar;\r\n Reserved: Pointer): BOOL; stdcall;\r\n TSetupDiGetHwProfileFriendlyNameExW = function(HwProfile: DWORD; FriendlyName: PWideChar;\r\n FriendlyNameSize: DWORD; RequiredSize: PDWORD; const MachineName: PWideChar;\r\n Reserved: Pointer): BOOL; stdcall;\r\n TSetupDiGetHwProfileFriendlyNameEx = function(HwProfile: DWORD; FriendlyName: PTSTR;\r\n FriendlyNameSize: DWORD; RequiredSize: PDWORD; const MachineName: PTSTR;\r\n Reserved: Pointer): BOOL; stdcall;\r\n\r\n TSetupDiGetWizardPage = function(DeviceInfoSet: HDEVINFO;\r\n DeviceInfoData: PSPDevInfoData; var InstallWizardData: TSPInstallWizardData;\r\n PageType: DWORD; Flags: DWORD): HPROPSHEETPAGE; stdcall;\r\n\r\n TSetupDiGetSelectedDevice = function(DeviceInfoSet: HDEVINFO;\r\n var DeviceInfoData: TSPDevInfoData): BOOL; stdcall;\r\n\r\n TSetupDiSetSelectedDevice = function(DeviceInfoSet: HDEVINFO;\r\n var DeviceInfoData: TSPDevInfoData): BOOL; stdcall;\r\n\r\n TSetupDiGetActualSectionToInstallA = function(InfHandle: HINF;\r\n const InfSectionName: PAnsiChar; InfSectionWithExt: PAnsiChar; InfSectionWithExtSize: DWORD;\r\n RequiredSize: PDWORD; Extension: PPASTR): BOOL; stdcall;\r\n TSetupDiGetActualSectionToInstallW = function(InfHandle: HINF;\r\n const InfSectionName: PWideChar; InfSectionWithExt: PWideChar; InfSectionWithExtSize: DWORD;\r\n RequiredSize: PDWORD; Extension: PPWSTR): BOOL; stdcall;\r\n TSetupDiGetActualSectionToInstall = function(InfHandle: HINF;\r\n const InfSectionName: PTSTR; InfSectionWithExt: PTSTR; InfSectionWithExtSize: DWORD;\r\n RequiredSize: PDWORD; Extension: PPWSTR): BOOL; stdcall;\r\n\r\n {$IFDEF WINXP_UP}\r\n TSetupDiGetActualSectionToInstallExA = function(InfHandle: HINF;\r\n InfSectionName: PAnsiChar; AlternatePlatformInfo: PSPAltPlatformInfo;\r\n InfSectionWithExt: PAnsiChar; InfSectionWithExtSize: DWORD;\r\n RequiredSize: PDWORD; Extension: PPASTR; Reserved: Pointer): BOOL; stdcall;\r\n TSetupDiGetActualSectionToInstallExW = function(InfHandle: HINF;\r\n InfSectionName: PWideChar; AlternatePlatformInfo: PSPAltPlatformInfo;\r\n InfSectionWithExt: PWideChar; InfSectionWithExtSize: DWORD;\r\n RequiredSize: PDWORD; Extension: PPWSTR; Reserved: Pointer): BOOL; stdcall;\r\n TSetupDiGetActualSectionToInstallEx = function(InfHandle: HINF;\r\n InfSectionName: PTSTR; AlternatePlatformInfo: PSPAltPlatformInfo;\r\n InfSectionWithExt: PTSTR; InfSectionWithExtSize: DWORD;\r\n RequiredSize: PDWORD; Extension: PPSTR; Reserved: Pointer): BOOL; stdcall;\r\n\r\n TSetupEnumInfSectionsA = function(InfHandle: HINF; Index: UINT;\r\n Buffer: PAnsiChar; Size: UINT; SizeNeeded: PUINT): BOOL; stdcall;\r\n TSetupEnumInfSectionsW = function(InfHandle: HINF; Index: UINT;\r\n Buffer: PWideChar; Size: UINT; SizeNeeded: PUINT): BOOL; stdcall;\r\n TSetupEnumInfSections = function(InfHandle: HINF; Index: UINT;\r\n Buffer: PTSTR; Size: UINT; SizeNeeded: PUINT): BOOL; stdcall;\r\n\r\n TSetupVerifyInfFileA = function(InfName: PAnsiChar; AltPlatformInfo: PSPAltPlatformInfo;\r\n var InfSignerInfo: TSPInfSignerInfoA): BOOL; stdcall;\r\n TSetupVerifyInfFileW = function(InfName: PWideChar; AltPlatformInfo: PSPAltPlatformInfo;\r\n var InfSignerInfo: TSPInfSignerInfoW): BOOL; stdcall;\r\n TSetupVerifyInfFile = function(InfName: PTSTR; AltPlatformInfo: PSPAltPlatformInfo;\r\n var InfSignerInfo: TSPInfSignerInfo): BOOL; stdcall;\r\n\r\n TSetupDiGetCustomDevicePropertyA = function(DeviceInfoSet: HDEVINFO;\r\n const DeviceInfoData: TSPDevInfoData; CustomPropertyName: PAnsiChar;\r\n Flags: DWORD; PropertyRegDataType: PDWORD; PropertyBuffer: PBYTE;\r\n PropertyBufferSize: DWORD; RequiredSize: PDWORD): BOOL; stdcall;\r\n TSetupDiGetCustomDevicePropertyW = function(DeviceInfoSet: HDEVINFO;\r\n const DeviceInfoData: TSPDevInfoData; CustomPropertyName: PWideChar;\r\n Flags: DWORD; PropertyRegDataType: PDWORD; PropertyBuffer: PBYTE;\r\n PropertyBufferSize: DWORD; RequiredSize: PDWORD): BOOL; stdcall;\r\n TSetupDiGetCustomDeviceProperty = function(DeviceInfoSet: HDEVINFO;\r\n const DeviceInfoData: TSPDevInfoData; CustomPropertyName: PTSTR;\r\n Flags: DWORD; PropertyRegDataType: PDWORD; PropertyBuffer: PBYTE;\r\n PropertyBufferSize: DWORD; RequiredSize: PDWORD): BOOL; stdcall;\r\n {$ENDIF WINXP_UP}\r\n\r\nvar\r\n {$IFDEF WINXP_UP}\r\n SetupGetFileQueueCount: TSetupGetFileQueueCount;\r\n SetupGetFileQueueFlags: TSetupGetFileQueueFlags;\r\n SetupSetFileQueueFlags: TSetupSetFileQueueFlags;\r\n {$ENDIF WINXP_UP}\r\n SetupGetInfInformationA: TSetupGetInfInformationA;\r\n SetupGetInfInformationW: TSetupGetInfInformationW;\r\n SetupGetInfInformation: TSetupGetInfInformation;\r\n SetupQueryInfFileInformationA: TSetupQueryInfFileInformationA;\r\n SetupQueryInfFileInformationW: TSetupQueryInfFileInformationW;\r\n SetupQueryInfFileInformation: TSetupQueryInfFileInformation;\r\n {$IFDEF WIN2000_UP}\r\n SetupQueryInfOriginalFileInformationA: TSetupQueryInfOriginalFileInformationA;\r\n SetupQueryInfOriginalFileInformationW: TSetupQueryInfOriginalFileInformationW;\r\n SetupQueryInfOriginalFileInformation: TSetupQueryInfOriginalFileInformation;\r\n {$ENDIF WIN2000_UP}\r\n SetupQueryInfVersionInformationA: TSetupQueryInfVersionInformationA;\r\n SetupQueryInfVersionInformationW: TSetupQueryInfVersionInformationW;\r\n SetupQueryInfVersionInformation: TSetupQueryInfVersionInformation;\r\n SetupGetInfFileListA: TSetupGetInfFileListA;\r\n SetupGetInfFileListW: TSetupGetInfFileListW;\r\n SetupGetInfFileList: TSetupGetInfFileList;\r\n SetupOpenInfFileA: TSetupOpenInfFileA;\r\n SetupOpenInfFileW: TSetupOpenInfFileW;\r\n SetupOpenInfFile: TSetupOpenInfFile;\r\n SetupOpenMasterInf: TSetupOpenMasterInf;\r\n SetupOpenAppendInfFileA: TSetupOpenAppendInfFileA;\r\n SetupOpenAppendInfFileW: TSetupOpenAppendInfFileW;\r\n SetupOpenAppendInfFile: TSetupOpenAppendInfFile;\r\n SetupCloseInfFile: TSetupCloseInfFile;\r\n SetupFindFirstLineA: TSetupFindFirstLineA;\r\n SetupFindFirstLineW: TSetupFindFirstLineW;\r\n SetupFindFirstLine: TSetupFindFirstLine;\r\n SetupFindNextLine: TSetupFindNextLine;\r\n SetupFindNextMatchLineA: TSetupFindNextMatchLineA;\r\n SetupFindNextMatchLineW: TSetupFindNextMatchLineW;\r\n SetupFindNextMatchLine: TSetupFindNextMatchLine;\r\n SetupGetLineByIndexA: TSetupGetLineByIndexA;\r\n SetupGetLineByIndexW: TSetupGetLineByIndexW;\r\n SetupGetLineByIndex: TSetupGetLineByIndex;\r\n SetupGetLineCountA: TSetupGetLineCountA;\r\n SetupGetLineCountW: TSetupGetLineCountW;\r\n SetupGetLineCount: TSetupGetLineCount;\r\n SetupGetLineTextA: TSetupGetLineTextA;\r\n SetupGetLineTextW: TSetupGetLineTextW;\r\n SetupGetLineText: TSetupGetLineText;\r\n SetupGetFieldCount: TSetupGetFieldCount;\r\n SetupGetStringFieldA: TSetupGetStringFieldA;\r\n SetupGetStringFieldW: TSetupGetStringFieldW;\r\n SetupGetStringField: TSetupGetStringField;\r\n SetupGetIntField: TSetupGetIntField;\r\n SetupGetMultiSzFieldA: TSetupGetMultiSzFieldA;\r\n SetupGetMultiSzFieldW: TSetupGetMultiSzFieldW;\r\n SetupGetMultiSzField: TSetupGetMultiSzField;\r\n SetupGetBinaryField: TSetupGetBinaryField;\r\n SetupGetFileCompressionInfoA: TSetupGetFileCompressionInfoA;\r\n SetupGetFileCompressionInfoW: TSetupGetFileCompressionInfoW;\r\n SetupGetFileCompressionInfo: TSetupGetFileCompressionInfo;\r\n {$IFDEF WINXP_UP}\r\n SetupGetFileCompressionInfoExA: TSetupGetFileCompressionInfoExA;\r\n SetupGetFileCompressionInfoExW: TSetupGetFileCompressionInfoExW;\r\n SetupGetFileCompressionInfoEx: TSetupGetFileCompressionInfoEx;\r\n {$ENDIF WINXP_UP}\r\n SetupDecompressOrCopyFileA: TSetupDecompressOrCopyFileA;\r\n SetupDecompressOrCopyFileW: TSetupDecompressOrCopyFileW;\r\n SetupDecompressOrCopyFile: TSetupDecompressOrCopyFile;\r\n SetupGetSourceFileLocationA: TSetupGetSourceFileLocationA;\r\n SetupGetSourceFileLocationW: TSetupGetSourceFileLocationW;\r\n SetupGetSourceFileLocation: TSetupGetSourceFileLocation;\r\n SetupGetSourceFileSizeA: TSetupGetSourceFileSizeA;\r\n SetupGetSourceFileSizeW: TSetupGetSourceFileSizeW;\r\n SetupGetSourceFileSize: TSetupGetSourceFileSize;\r\n SetupGetTargetPathA: TSetupGetTargetPathA;\r\n SetupGetTargetPathW: TSetupGetTargetPathW;\r\n SetupGetTargetPath: TSetupGetTargetPath;\r\n SetupSetSourceListA: TSetupSetSourceListA;\r\n SetupSetSourceListW: TSetupSetSourceListW;\r\n SetupSetSourceList: TSetupSetSourceList;\r\n SetupCancelTemporarySourceList: TSetupCancelTemporarySourceList;\r\n SetupAddToSourceListA: TSetupAddToSourceListA;\r\n SetupAddToSourceListW: TSetupAddToSourceListW;\r\n SetupAddToSourceList: TSetupAddToSourceList;\r\n SetupRemoveFromSourceListA: TSetupRemoveFromSourceListA;\r\n SetupRemoveFromSourceListW: TSetupRemoveFromSourceListW;\r\n SetupRemoveFromSourceList: TSetupRemoveFromSourceList;\r\n SetupQuerySourceListA: TSetupQuerySourceListA;\r\n SetupQuerySourceListW: TSetupQuerySourceListW;\r\n SetupQuerySourceList: TSetupQuerySourceList;\r\n SetupFreeSourceListA: TSetupFreeSourceListA;\r\n SetupFreeSourceListW: TSetupFreeSourceListW;\r\n SetupFreeSourceList: TSetupFreeSourceList;\r\n SetupPromptForDiskA: TSetupPromptForDiskA;\r\n SetupPromptForDiskW: TSetupPromptForDiskW;\r\n SetupPromptForDisk: TSetupPromptForDisk;\r\n SetupCopyErrorA: TSetupCopyErrorA;\r\n SetupCopyErrorW: TSetupCopyErrorW;\r\n SetupCopyError: TSetupCopyError;\r\n SetupRenameErrorA: TSetupRenameErrorA;\r\n SetupRenameErrorW: TSetupRenameErrorW;\r\n SetupRenameError: TSetupRenameError;\r\n SetupDeleteErrorA: TSetupDeleteErrorA;\r\n SetupDeleteErrorW: TSetupDeleteErrorW;\r\n SetupDeleteError: TSetupDeleteError;\r\n {$IFDEF WIN2000_UP}\r\n SetupBackupErrorA: TSetupBackupErrorA;\r\n SetupBackupErrorW: TSetupBackupErrorW;\r\n SetupBackupError: TSetupBackupError;\r\n {$ENDIF WIN2000_UP}\r\n SetupSetDirectoryIdA: TSetupSetDirectoryIdA;\r\n SetupSetDirectoryIdW: TSetupSetDirectoryIdW;\r\n SetupSetDirectoryId: TSetupSetDirectoryId;\r\n SetupSetDirectoryIdExA: TSetupSetDirectoryIdExA;\r\n SetupSetDirectoryIdExW: TSetupSetDirectoryIdExW;\r\n SetupSetDirectoryIdEx: TSetupSetDirectoryIdEx;\r\n SetupGetSourceInfoA: TSetupGetSourceInfoA;\r\n SetupGetSourceInfoW: TSetupGetSourceInfoW;\r\n SetupGetSourceInfo: TSetupGetSourceInfo;\r\n SetupInstallFileA: TSetupInstallFileA;\r\n SetupInstallFileW: TSetupInstallFileW;\r\n SetupInstallFile: TSetupInstallFile;\r\n SetupInstallFileExA: TSetupInstallFileExA;\r\n SetupInstallFileExW: TSetupInstallFileExW;\r\n SetupInstallFileEx: TSetupInstallFileEx;\r\n SetupOpenFileQueue: TSetupOpenFileQueue;\r\n SetupCloseFileQueue: TSetupCloseFileQueue;\r\n {$IFDEF WIN2000_UP}\r\n SetupSetFileQueueAlternatePlatformA: TSetupSetFileQueueAlternatePlatformA;\r\n SetupSetFileQueueAlternatePlatformW: TSetupSetFileQueueAlternatePlatformW;\r\n SetupSetFileQueueAlternatePlatform: TSetupSetFileQueueAlternatePlatform;\r\n {$ENDIF WIN2000_UP}\r\n SetupSetPlatformPathOverrideA: TSetupSetPlatformPathOverrideA;\r\n SetupSetPlatformPathOverrideW: TSetupSetPlatformPathOverrideW;\r\n SetupSetPlatformPathOverride: TSetupSetPlatformPathOverride;\r\n SetupQueueCopyA: TSetupQueueCopyA;\r\n SetupQueueCopyW: TSetupQueueCopyW;\r\n SetupQueueCopy: TSetupQueueCopy;\r\n {$IFDEF WIN2000_UP}\r\n SetupQueueCopyIndirectA: TSetupQueueCopyIndirectA;\r\n SetupQueueCopyIndirectW: TSetupQueueCopyIndirectW;\r\n SetupQueueCopyIndirect: TSetupQueueCopyIndirect;\r\n {$ENDIF WIN2000_UP}\r\n SetupQueueDefaultCopyA: TSetupQueueDefaultCopyA;\r\n SetupQueueDefaultCopyW: TSetupQueueDefaultCopyW;\r\n SetupQueueDefaultCopy: TSetupQueueDefaultCopy;\r\n SetupQueueCopySectionA: TSetupQueueCopySectionA;\r\n SetupQueueCopySectionW: TSetupQueueCopySectionW;\r\n SetupQueueCopySection: TSetupQueueCopySection;\r\n SetupQueueDeleteA: TSetupQueueDeleteA;\r\n SetupQueueDeleteW: TSetupQueueDeleteW;\r\n SetupQueueDelete: TSetupQueueDelete;\r\n SetupQueueDeleteSectionA: TSetupQueueDeleteSectionA;\r\n SetupQueueDeleteSectionW: TSetupQueueDeleteSectionW;\r\n SetupQueueDeleteSection: TSetupQueueDeleteSection;\r\n SetupQueueRenameA: TSetupQueueRenameA;\r\n SetupQueueRenameW: TSetupQueueRenameW;\r\n SetupQueueRename: TSetupQueueRename;\r\n SetupQueueRenameSectionA: TSetupQueueRenameSectionA;\r\n SetupQueueRenameSectionW: TSetupQueueRenameSectionW;\r\n SetupQueueRenameSection: TSetupQueueRenameSection;\r\n SetupCommitFileQueueA: TSetupCommitFileQueueA;\r\n SetupCommitFileQueueW: TSetupCommitFileQueueW;\r\n SetupCommitFileQueue: TSetupCommitFileQueue;\r\n SetupScanFileQueueA: TSetupScanFileQueueA;\r\n SetupScanFileQueueW: TSetupScanFileQueueW;\r\n SetupScanFileQueue: TSetupScanFileQueue;\r\n SetupCopyOEMInfA: TSetupCopyOEMInfA;\r\n SetupCopyOEMInfW: TSetupCopyOEMInfW;\r\n SetupCopyOEMInf: TSetupCopyOEMInf;\r\n {$IFDEF WINXP_UP}\r\n SetupUninstallOEMInfA: TSetupUninstallOEMInfA;\r\n SetupUninstallOEMInfW: TSetupUninstallOEMInfW;\r\n SetupUninstallOEMInf: TSetupUninstallOEMInf;\r\n SetupUninstallNewlyCopiedInfs: TSetupUninstallNewlyCopiedInfs;\r\n {$ENDIF WINXP_UP}\r\n SetupCreateDiskSpaceListA: TSetupCreateDiskSpaceListA;\r\n SetupCreateDiskSpaceListW: TSetupCreateDiskSpaceListW;\r\n SetupCreateDiskSpaceList: TSetupCreateDiskSpaceList;\r\n SetupDuplicateDiskSpaceListA: TSetupDuplicateDiskSpaceListA;\r\n SetupDuplicateDiskSpaceListW: TSetupDuplicateDiskSpaceListW;\r\n SetupDuplicateDiskSpaceList: TSetupDuplicateDiskSpaceList;\r\n SetupDestroyDiskSpaceList: TSetupDestroyDiskSpaceList;\r\n SetupQueryDrivesInDiskSpaceListA: TSetupQueryDrivesInDiskSpaceListA;\r\n SetupQueryDrivesInDiskSpaceListW: TSetupQueryDrivesInDiskSpaceListW;\r\n SetupQueryDrivesInDiskSpaceList: TSetupQueryDrivesInDiskSpaceList;\r\n SetupQuerySpaceRequiredOnDriveA: TSetupQuerySpaceRequiredOnDriveA;\r\n SetupQuerySpaceRequiredOnDriveW: TSetupQuerySpaceRequiredOnDriveW;\r\n SetupQuerySpaceRequiredOnDrive: TSetupQuerySpaceRequiredOnDrive;\r\n SetupAdjustDiskSpaceListA: TSetupAdjustDiskSpaceListA;\r\n SetupAdjustDiskSpaceListW: TSetupAdjustDiskSpaceListW;\r\n SetupAdjustDiskSpaceList: TSetupAdjustDiskSpaceList;\r\n SetupAddToDiskSpaceListA: TSetupAddToDiskSpaceListA;\r\n SetupAddToDiskSpaceListW: TSetupAddToDiskSpaceListW;\r\n SetupAddToDiskSpaceList: TSetupAddToDiskSpaceList;\r\n SetupAddSectionToDiskSpaceListA: TSetupAddSectionToDiskSpaceListA;\r\n SetupAddSectionToDiskSpaceListW: TSetupAddSectionToDiskSpaceListW;\r\n SetupAddSectionToDiskSpaceList: TSetupAddSectionToDiskSpaceList;\r\n SetupAddInstallSectionToDiskSpaceListA: TSetupAddInstallSectionToDiskSpaceListA;\r\n SetupAddInstallSectionToDiskSpaceListW: TSetupAddInstallSectionToDiskSpaceListW;\r\n SetupAddInstallSectionToDiskSpaceList: TSetupAddInstallSectionToDiskSpaceList;\r\n SetupRemoveFromDiskSpaceListA: TSetupRemoveFromDiskSpaceListA;\r\n SetupRemoveFromDiskSpaceListW: TSetupRemoveFromDiskSpaceListW;\r\n SetupRemoveFromDiskSpaceList: TSetupRemoveFromDiskSpaceList;\r\n SetupRemoveSectionFromDiskSpaceListA: TSetupRemoveSectionFromDiskSpaceListA;\r\n SetupRemoveSectionFromDiskSpaceListW: TSetupRemoveSectionFromDiskSpaceListW;\r\n SetupRemoveSectionFromDiskSpaceList: TSetupRemoveSectionFromDiskSpaceList;\r\n SetupRemoveInstallSectionFromDiskSpaceListA: TSetupRemoveInstallSectionFromDiskSpaceListA;\r\n SetupRemoveInstallSectionFromDiskSpaceListW: TSetupRemoveInstallSectionFromDiskSpaceListW;\r\n SetupRemoveInstallSectionFromDiskSpaceList: TSetupRemoveInstallSectionFromDiskSpaceList;\r\n SetupIterateCabinetA: TSetupIterateCabinetA;\r\n SetupIterateCabinetW: TSetupIterateCabinetW;\r\n SetupIterateCabinet: TSetupIterateCabinet;\r\n SetupPromptReboot: TSetupPromptReboot;\r\n SetupInitDefaultQueueCallback: TSetupInitDefaultQueueCallback;\r\n SetupInitDefaultQueueCallbackEx: TSetupInitDefaultQueueCallbackEx;\r\n SetupTermDefaultQueueCallback: TSetupTermDefaultQueueCallback;\r\n SetupDefaultQueueCallbackA: TSetupDefaultQueueCallbackA;\r\n SetupDefaultQueueCallbackW: TSetupDefaultQueueCallbackW;\r\n SetupDefaultQueueCallback: TSetupDefaultQueueCallback;\r\n SetupInstallFromInfSectionA: TSetupInstallFromInfSectionA;\r\n SetupInstallFromInfSectionW: TSetupInstallFromInfSectionW;\r\n SetupInstallFromInfSection: TSetupInstallFromInfSection;\r\n SetupInstallFilesFromInfSectionA: TSetupInstallFilesFromInfSectionA;\r\n SetupInstallFilesFromInfSectionW: TSetupInstallFilesFromInfSectionW;\r\n SetupInstallFilesFromInfSection: TSetupInstallFilesFromInfSection;\r\n SetupInstallServicesFromInfSectionA: TSetupInstallServicesFromInfSectionA;\r\n SetupInstallServicesFromInfSectionW: TSetupInstallServicesFromInfSectionW;\r\n SetupInstallServicesFromInfSection: TSetupInstallServicesFromInfSection;\r\n SetupInstallServicesFromInfSectionExA: TSetupInstallServicesFromInfSectionExA;\r\n SetupInstallServicesFromInfSectionExW: TSetupInstallServicesFromInfSectionExW;\r\n SetupInstallServicesFromInfSectionEx: TSetupInstallServicesFromInfSectionEx;\r\n {$IFDEF WINXP_UP}\r\n InstallHinfSectionA: TInstallHinfSectionA;\r\n InstallHinfSectionW: TInstallHinfSectionW;\r\n InstallHinfSection: TInstallHinfSection;\r\n {$ENDIF WINXP_UP}\r\n SetupInitializeFileLogA: TSetupInitializeFileLogA;\r\n SetupInitializeFileLogW: TSetupInitializeFileLogW;\r\n SetupInitializeFileLog: TSetupInitializeFileLog;\r\n SetupTerminateFileLog: TSetupTerminateFileLog;\r\n SetupLogFileA: TSetupLogFileA;\r\n SetupLogFileW: TSetupLogFileW;\r\n SetupLogFile: TSetupLogFile;\r\n SetupRemoveFileLogEntryA: TSetupRemoveFileLogEntryA;\r\n SetupRemoveFileLogEntryW: TSetupRemoveFileLogEntryW;\r\n SetupRemoveFileLogEntry: TSetupRemoveFileLogEntry;\r\n SetupQueryFileLogA: TSetupQueryFileLogA;\r\n SetupQueryFileLogW: TSetupQueryFileLogW;\r\n SetupQueryFileLog: TSetupQueryFileLog;\r\n SetupOpenLog: TSetupOpenLog;\r\n SetupLogErrorA: TSetupLogErrorA;\r\n SetupLogErrorW: TSetupLogErrorW;\r\n SetupLogError: TSetupLogError;\r\n SetupCloseLog: TSetupCloseLog;\r\n {$IFDEF WIN2000_UP}\r\n SetupGetBackupInformationA: TSetupGetBackupInformationA;\r\n SetupGetBackupInformationW: TSetupGetBackupInformationW;\r\n SetupGetBackupInformation: TSetupGetBackupInformation;\r\n {$ENDIF WIN2000_UP}\r\n {$IFDEF WINXP_UP}\r\n SetupPrepareQueueForRestoreA: TSetupPrepareQueueForRestoreA;\r\n SetupPrepareQueueForRestoreW: TSetupPrepareQueueForRestoreW;\r\n SetupPrepareQueueForRestore: TSetupPrepareQueueForRestore;\r\n SetupSetNonInteractiveMode: TSetupSetNonInteractiveMode;\r\n SetupGetNonInteractiveMode: TSetupGetNonInteractiveMode;\r\n {$ENDIF WINXP_UP}\r\n SetupDiCreateDeviceInfoList: TSetupDiCreateDeviceInfoList;\r\n SetupDiCreateDeviceInfoListExA: TSetupDiCreateDeviceInfoListExA;\r\n SetupDiCreateDeviceInfoListExW: TSetupDiCreateDeviceInfoListExW;\r\n SetupDiCreateDeviceInfoListEx: TSetupDiCreateDeviceInfoListEx;\r\n SetupDiGetDeviceInfoListClass: TSetupDiGetDeviceInfoListClass;\r\n SetupDiGetDeviceInfoListDetailA: TSetupDiGetDeviceInfoListDetailA;\r\n SetupDiGetDeviceInfoListDetailW: TSetupDiGetDeviceInfoListDetailW;\r\n SetupDiGetDeviceInfoListDetail: TSetupDiGetDeviceInfoListDetail;\r\n SetupDiCreateDeviceInfoA: TSetupDiCreateDeviceInfoA;\r\n SetupDiCreateDeviceInfoW: TSetupDiCreateDeviceInfoW;\r\n SetupDiCreateDeviceInfo: TSetupDiCreateDeviceInfo;\r\n SetupDiOpenDeviceInfoA: TSetupDiOpenDeviceInfoA;\r\n SetupDiOpenDeviceInfoW: TSetupDiOpenDeviceInfoW;\r\n SetupDiOpenDeviceInfo: TSetupDiOpenDeviceInfo;\r\n SetupDiGetDeviceInstanceIdA: TSetupDiGetDeviceInstanceIdA;\r\n SetupDiGetDeviceInstanceIdW: TSetupDiGetDeviceInstanceIdW;\r\n SetupDiGetDeviceInstanceId: TSetupDiGetDeviceInstanceId;\r\n SetupDiDeleteDeviceInfo: TSetupDiDeleteDeviceInfo;\r\n SetupDiEnumDeviceInfo: TSetupDiEnumDeviceInfo;\r\n SetupDiDestroyDeviceInfoList: TSetupDiDestroyDeviceInfoList;\r\n SetupDiEnumDeviceInterfaces: TSetupDiEnumDeviceInterfaces;\r\n SetupDiEnumInterfaceDevice: TSetupDiEnumDeviceInterfaces;\r\n SetupDiCreateDeviceInterfaceA: TSetupDiCreateDeviceInterfaceA;\r\n SetupDiCreateInterfaceDeviceA: TSetupDiCreateDeviceInterfaceA;\r\n SetupDiCreateDeviceInterfaceW: TSetupDiCreateDeviceInterfaceW;\r\n SetupDiCreateInterfaceDeviceW: TSetupDiCreateDeviceInterfaceW;\r\n SetupDiCreateDeviceInterface: TSetupDiCreateDeviceInterface;\r\n SetupDiCreateInterfaceDevice: TSetupDiCreateInterfaceDevice;\r\n SetupDiOpenDeviceInterfaceA: TSetupDiOpenDeviceInterfaceA;\r\n SetupDiOpenInterfaceDeviceA: TSetupDiOpenDeviceInterfaceA;\r\n SetupDiOpenDeviceInterfaceW: TSetupDiOpenDeviceInterfaceW;\r\n SetupDiOpenInterfaceDeviceW: TSetupDiOpenDeviceInterfaceW;\r\n SetupDiOpenDeviceInterface: TSetupDiOpenDeviceInterface;\r\n SetupDiOpenInterfaceDevice: TSetupDiOpenInterfaceDevice;\r\n SetupDiGetDeviceInterfaceAlias: TSetupDiGetDeviceInterfaceAlias;\r\n SetupDiGetInterfaceDeviceAlias: TSetupDiGetDeviceInterfaceAlias;\r\n SetupDiDeleteDeviceInterfaceData: TSetupDiDeleteDeviceInterfaceData;\r\n SetupDiDeleteInterfaceDeviceData: TSetupDiDeleteDeviceInterfaceData;\r\n SetupDiRemoveDeviceInterface: TSetupDiRemoveDeviceInterface;\r\n SetupDiRemoveInterfaceDevice: TSetupDiRemoveDeviceInterface;\r\n SetupDiGetDeviceInterfaceDetailA: TSetupDiGetDeviceInterfaceDetailA;\r\n SetupDiGetInterfaceDeviceDetailA: TSetupDiGetDeviceInterfaceDetailA;\r\n SetupDiGetDeviceInterfaceDetailW: TSetupDiGetDeviceInterfaceDetailW;\r\n SetupDiGetInterfaceDeviceDetailW: TSetupDiGetDeviceInterfaceDetailW;\r\n SetupDiGetDeviceInterfaceDetail: TSetupDiGetDeviceInterfaceDetail;\r\n SetupDiGetInterfaceDeviceDetail: TSetupDiGetInterfaceDeviceDetail;\r\n SetupDiInstallDeviceInterfaces: TSetupDiInstallDeviceInterfaces;\r\n SetupDiInstallInterfaceDevices: TSetupDiInstallDeviceInterfaces;\r\n {$IFDEF WINXP_UP}\r\n SetupDiSetDeviceInterfaceDefault: TSetupDiSetDeviceInterfaceDefault;\r\n {$ENDIF WINXP_UP}\r\n SetupDiRegisterDeviceInfo: TSetupDiRegisterDeviceInfo;\r\n SetupDiBuildDriverInfoList: TSetupDiBuildDriverInfoList;\r\n SetupDiCancelDriverInfoSearch: TSetupDiCancelDriverInfoSearch;\r\n SetupDiEnumDriverInfoA: TSetupDiEnumDriverInfoA;\r\n SetupDiEnumDriverInfoW: TSetupDiEnumDriverInfoW;\r\n SetupDiEnumDriverInfo: TSetupDiEnumDriverInfo;\r\n SetupDiGetSelectedDriverA: TSetupDiGetSelectedDriverA;\r\n SetupDiGetSelectedDriverW: TSetupDiGetSelectedDriverW;\r\n SetupDiGetSelectedDriver: TSetupDiGetSelectedDriver;\r\n SetupDiSetSelectedDriverA: TSetupDiSetSelectedDriverA;\r\n SetupDiSetSelectedDriverW: TSetupDiSetSelectedDriverW;\r\n SetupDiSetSelectedDriver: TSetupDiSetSelectedDriver;\r\n SetupDiGetDriverInfoDetailA: TSetupDiGetDriverInfoDetailA;\r\n SetupDiGetDriverInfoDetailW: TSetupDiGetDriverInfoDetailW;\r\n SetupDiGetDriverInfoDetail: TSetupDiGetDriverInfoDetail;\r\n SetupDiDestroyDriverInfoList: TSetupDiDestroyDriverInfoList;\r\n SetupDiGetClassDevsA: TSetupDiGetClassDevsA;\r\n SetupDiGetClassDevsW: TSetupDiGetClassDevsW;\r\n SetupDiGetClassDevs: TSetupDiGetClassDevs;\r\n SetupDiGetClassDevsExA: TSetupDiGetClassDevsExA;\r\n SetupDiGetClassDevsExW: TSetupDiGetClassDevsExW;\r\n SetupDiGetClassDevsEx: TSetupDiGetClassDevsEx;\r\n SetupDiGetINFClassA: TSetupDiGetINFClassA;\r\n SetupDiGetINFClassW: TSetupDiGetINFClassW;\r\n SetupDiGetINFClass: TSetupDiGetINFClass;\r\n SetupDiBuildClassInfoList: TSetupDiBuildClassInfoList;\r\n SetupDiBuildClassInfoListExA: TSetupDiBuildClassInfoListExA;\r\n SetupDiBuildClassInfoListExW: TSetupDiBuildClassInfoListExW;\r\n SetupDiBuildClassInfoListEx: TSetupDiBuildClassInfoListEx;\r\n SetupDiGetClassDescriptionA: TSetupDiGetClassDescriptionA;\r\n SetupDiGetClassDescriptionW: TSetupDiGetClassDescriptionW;\r\n SetupDiGetClassDescription: TSetupDiGetClassDescription;\r\n SetupDiGetClassDescriptionExA: TSetupDiGetClassDescriptionExA;\r\n SetupDiGetClassDescriptionExW: TSetupDiGetClassDescriptionExW;\r\n SetupDiGetClassDescriptionEx: TSetupDiGetClassDescriptionEx;\r\n SetupDiCallClassInstaller: TSetupDiCallClassInstaller;\r\n SetupDiSelectDevice: TSetupDiSelectDevice;\r\n SetupDiSelectBestCompatDrv: TSetupDiSelectBestCompatDrv;\r\n SetupDiInstallDevice: TSetupDiInstallDevice;\r\n SetupDiInstallDriverFiles: TSetupDiInstallDriverFiles;\r\n SetupDiRegisterCoDeviceInstallers: TSetupDiRegisterCoDeviceInstallers;\r\n SetupDiRemoveDevice: TSetupDiRemoveDevice;\r\n SetupDiUnremoveDevice: TSetupDiUnremoveDevice;\r\n SetupDiMoveDuplicateDevice: TSetupDiMoveDuplicateDevice;\r\n SetupDiChangeState: TSetupDiChangeState;\r\n SetupDiInstallClassA: TSetupDiInstallClassA;\r\n SetupDiInstallClassW: TSetupDiInstallClassW;\r\n SetupDiInstallClass: TSetupDiInstallClass;\r\n SetupDiInstallClassExA: TSetupDiInstallClassExA;\r\n SetupDiInstallClassExW: TSetupDiInstallClassExW;\r\n SetupDiInstallClassEx: TSetupDiInstallClassEx;\r\n SetupDiOpenClassRegKey: TSetupDiOpenClassRegKey;\r\n SetupDiOpenClassRegKeyExA: TSetupDiOpenClassRegKeyExA;\r\n SetupDiOpenClassRegKeyExW: TSetupDiOpenClassRegKeyExW;\r\n SetupDiOpenClassRegKeyEx: TSetupDiOpenClassRegKeyEx;\r\n SetupDiCreateDeviceInterfaceRegKeyA: TSetupDiCreateDeviceInterfaceRegKeyA;\r\n SetupDiCreateInterfaceDeviceRegKeyA: TSetupDiCreateDeviceInterfaceRegKeyA;\r\n SetupDiCreateDeviceInterfaceRegKeyW: TSetupDiCreateDeviceInterfaceRegKeyW;\r\n SetupDiCreateInterfaceDeviceRegKeyW: TSetupDiCreateDeviceInterfaceRegKeyW;\r\n SetupDiCreateDeviceInterfaceRegKey: TSetupDiCreateDeviceInterfaceRegKey;\r\n SetupDiCreateInterfaceDeviceRegKey: TSetupDiCreateInterfaceDeviceRegKey;\r\n SetupDiOpenDeviceInterfaceRegKey: TSetupDiOpenDeviceInterfaceRegKey;\r\n SetupDiOpenInterfaceDeviceRegKey: TSetupDiOpenDeviceInterfaceRegKey;\r\n SetupDiDeleteDeviceInterfaceRegKey: TSetupDiDeleteDeviceInterfaceRegKey;\r\n SetupDiDeleteInterfaceDeviceRegKey: TSetupDiDeleteDeviceInterfaceRegKey;\r\n SetupDiCreateDevRegKeyA: TSetupDiCreateDevRegKeyA;\r\n SetupDiCreateDevRegKeyW: TSetupDiCreateDevRegKeyW;\r\n SetupDiCreateDevRegKey: TSetupDiCreateDevRegKey;\r\n SetupDiOpenDevRegKey: TSetupDiOpenDevRegKey;\r\n SetupDiDeleteDevRegKey: TSetupDiDeleteDevRegKey;\r\n SetupDiGetHwProfileList: TSetupDiGetHwProfileList;\r\n SetupDiGetHwProfileListExA: TSetupDiGetHwProfileListExA;\r\n SetupDiGetHwProfileListExW: TSetupDiGetHwProfileListExW;\r\n SetupDiGetHwProfileListEx: TSetupDiGetHwProfileListEx;\r\n SetupDiGetDeviceRegistryPropertyA: TSetupDiGetDeviceRegistryPropertyA;\r\n SetupDiGetDeviceRegistryPropertyW: TSetupDiGetDeviceRegistryPropertyW;\r\n SetupDiGetDeviceRegistryProperty: TSetupDiGetDeviceRegistryProperty;\r\n {$IFDEF WINXP_UP}\r\n SetupDiGetClassRegistryPropertyA: TSetupDiGetClassRegistryPropertyA;\r\n SetupDiGetClassRegistryPropertyW: TSetupDiGetClassRegistryPropertyW;\r\n SetupDiGetClassRegistryProperty: TSetupDiGetClassRegistryProperty;\r\n {$ENDIF WINXP_UP}\r\n SetupDiSetDeviceRegistryPropertyA: TSetupDiSetDeviceRegistryPropertyA;\r\n SetupDiSetDeviceRegistryPropertyW: TSetupDiSetDeviceRegistryPropertyW;\r\n SetupDiSetDeviceRegistryProperty: TSetupDiSetDeviceRegistryProperty;\r\n {$IFDEF WINXP_UP}\r\n SetupDiSetClassRegistryPropertyA: TSetupDiSetClassRegistryPropertyA;\r\n SetupDiSetClassRegistryPropertyW: TSetupDiSetClassRegistryPropertyW;\r\n SetupDiSetClassRegistryProperty: TSetupDiSetClassRegistryProperty;\r\n {$ENDIF WINXP_UP}\r\n SetupDiGetDeviceInstallParamsA: TSetupDiGetDeviceInstallParamsA;\r\n SetupDiGetDeviceInstallParamsW: TSetupDiGetDeviceInstallParamsW;\r\n SetupDiGetDeviceInstallParams: TSetupDiGetDeviceInstallParams;\r\n SetupDiGetClassInstallParamsA: TSetupDiGetClassInstallParamsA;\r\n SetupDiGetClassInstallParamsW: TSetupDiGetClassInstallParamsW;\r\n SetupDiGetClassInstallParams: TSetupDiGetClassInstallParams;\r\n SetupDiSetDeviceInstallParamsA: TSetupDiSetDeviceInstallParamsA;\r\n SetupDiSetDeviceInstallParamsW: TSetupDiSetDeviceInstallParamsW;\r\n SetupDiSetDeviceInstallParams: TSetupDiSetDeviceInstallParams;\r\n SetupDiSetClassInstallParamsA: TSetupDiSetClassInstallParamsA;\r\n SetupDiSetClassInstallParamsW: TSetupDiSetClassInstallParamsW;\r\n SetupDiSetClassInstallParams: TSetupDiSetClassInstallParams;\r\n SetupDiGetDriverInstallParamsA: TSetupDiGetDriverInstallParamsA;\r\n SetupDiGetDriverInstallParamsW: TSetupDiGetDriverInstallParamsW;\r\n SetupDiGetDriverInstallParams: TSetupDiGetDriverInstallParams;\r\n SetupDiSetDriverInstallParamsA: TSetupDiSetDriverInstallParamsA;\r\n SetupDiSetDriverInstallParamsW: TSetupDiSetDriverInstallParamsW;\r\n SetupDiSetDriverInstallParams: TSetupDiSetDriverInstallParams;\r\n SetupDiLoadClassIcon: TSetupDiLoadClassIcon;\r\n SetupDiDrawMiniIcon: TSetupDiDrawMiniIcon;\r\n SetupDiGetClassBitmapIndex: TSetupDiGetClassBitmapIndex;\r\n SetupDiGetClassImageList: TSetupDiGetClassImageList;\r\n SetupDiGetClassImageListExA: TSetupDiGetClassImageListExA;\r\n SetupDiGetClassImageListExW: TSetupDiGetClassImageListExW;\r\n SetupDiGetClassImageListEx: TSetupDiGetClassImageListEx;\r\n SetupDiGetClassImageIndex: TSetupDiGetClassImageIndex;\r\n SetupDiDestroyClassImageList: TSetupDiDestroyClassImageList;\r\n SetupDiGetClassDevPropertySheetsA: TSetupDiGetClassDevPropertySheetsA;\r\n SetupDiGetClassDevPropertySheetsW: TSetupDiGetClassDevPropertySheetsW;\r\n SetupDiGetClassDevPropertySheets: TSetupDiGetClassDevPropertySheets;\r\n SetupDiAskForOEMDisk: TSetupDiAskForOEMDisk;\r\n SetupDiSelectOEMDrv: TSetupDiSelectOEMDrv;\r\n SetupDiClassNameFromGuidA: TSetupDiClassNameFromGuidA;\r\n SetupDiClassNameFromGuidW: TSetupDiClassNameFromGuidW;\r\n SetupDiClassNameFromGuid: TSetupDiClassNameFromGuid;\r\n SetupDiClassNameFromGuidExA: TSetupDiClassNameFromGuidExA;\r\n SetupDiClassNameFromGuidExW: TSetupDiClassNameFromGuidExW;\r\n SetupDiClassNameFromGuidEx: TSetupDiClassNameFromGuidEx;\r\n SetupDiClassGuidsFromNameA: TSetupDiClassGuidsFromNameA;\r\n SetupDiClassGuidsFromNameW: TSetupDiClassGuidsFromNameW;\r\n SetupDiClassGuidsFromName: TSetupDiClassGuidsFromName;\r\n SetupDiClassGuidsFromNameExA: TSetupDiClassGuidsFromNameExA;\r\n SetupDiClassGuidsFromNameExW: TSetupDiClassGuidsFromNameExW;\r\n SetupDiClassGuidsFromNameEx: TSetupDiClassGuidsFromNameEx;\r\n SetupDiGetHwProfileFriendlyNameA: TSetupDiGetHwProfileFriendlyNameA;\r\n SetupDiGetHwProfileFriendlyNameW: TSetupDiGetHwProfileFriendlyNameW;\r\n SetupDiGetHwProfileFriendlyName: TSetupDiGetHwProfileFriendlyName;\r\n SetupDiGetHwProfileFriendlyNameExA: TSetupDiGetHwProfileFriendlyNameExA;\r\n SetupDiGetHwProfileFriendlyNameExW: TSetupDiGetHwProfileFriendlyNameExW;\r\n SetupDiGetHwProfileFriendlyNameEx: TSetupDiGetHwProfileFriendlyNameEx;\r\n SetupDiGetWizardPage: TSetupDiGetWizardPage;\r\n SetupDiGetSelectedDevice: TSetupDiGetSelectedDevice;\r\n SetupDiSetSelectedDevice: TSetupDiSetSelectedDevice;\r\n SetupDiGetActualSectionToInstallA: TSetupDiGetActualSectionToInstallA;\r\n SetupDiGetActualSectionToInstallW: TSetupDiGetActualSectionToInstallW;\r\n SetupDiGetActualSectionToInstall: TSetupDiGetActualSectionToInstall;\r\n {$IFDEF WINXP_UP}\r\n SetupDiGetActualSectionToInstallExA: TSetupDiGetActualSectionToInstallExA;\r\n SetupDiGetActualSectionToInstallExW: TSetupDiGetActualSectionToInstallExW;\r\n SetupDiGetActualSectionToInstallEx: TSetupDiGetActualSectionToInstallEx;\r\n SetupEnumInfSectionsA: TSetupEnumInfSectionsA;\r\n SetupEnumInfSectionsW: TSetupEnumInfSectionsW;\r\n SetupEnumInfSections: TSetupEnumInfSections;\r\n SetupVerifyInfFileA: TSetupVerifyInfFileA;\r\n SetupVerifyInfFileW: TSetupVerifyInfFileW;\r\n SetupVerifyInfFile: TSetupVerifyInfFile;\r\n SetupDiGetCustomDevicePropertyA: TSetupDiGetCustomDevicePropertyA;\r\n SetupDiGetCustomDevicePropertyW: TSetupDiGetCustomDevicePropertyW;\r\n SetupDiGetCustomDeviceProperty: TSetupDiGetCustomDeviceProperty;\r\n {$ENDIF WINXP_UP}\r\n\r\n{$ENDIF !SETUPAPI_LINKONREQUEST}\r\n\r\n{$IFNDEF SETUPAPI_LINKONREQUEST}\r\ntype\r\n TModuleHandle = HINST;\r\n{$ENDIF !SETUPAPI_LINKONREQUEST}\r\n\r\nfunction IsSetupApiLoaded: Boolean;\r\nfunction GetSetupApiModuleHandle: TModuleHandle;\r\nfunction LoadSetupApi: Boolean;\r\nprocedure UnloadSetupApi;\r\n\r\nimplementation\r\n\r\nconst\r\n SetupApiModuleName = 'SetupApi.dll';\r\n {$IFDEF UNICODE}\r\n NameSuffix = 'W';\r\n {$ELSE}\r\n NameSuffix = 'A';\r\n {$ENDIF UNICODE}\r\n\r\n{$IFDEF SETUPAPI_LINKONREQUEST}\r\nvar\r\n SetupApiLib: TModuleHandle = INVALID_MODULEHANDLE_VALUE;\r\n SetupApiLoadCount: Integer = 0;\r\n{$ENDIF SETUPAPI_LINKONREQUEST}\r\n\r\nfunction IsSetupApiLoaded: Boolean;\r\nbegin\r\n {$IFDEF SETUPAPI_LINKONREQUEST}\r\n Result := SetupApiLib <> INVALID_MODULEHANDLE_VALUE;\r\n {$ELSE}\r\n Result := True;\r\n {$ENDIF SETUPAPI_LINKONREQUEST}\r\nend;\r\n\r\nfunction GetSetupApiModuleHandle: TModuleHandle;\r\nbegin\r\n {$IFDEF SETUPAPI_LINKONREQUEST}\r\n Result := SetupApiLib;\r\n {$ELSE}\r\n Result := TModuleHandle(0);\r\n {$ENDIF SETUPAPI_LINKONREQUEST}\r\nend;\r\n\r\nfunction LoadSetupApi: Boolean;\r\nbegin\r\n {$IFDEF SETUPAPI_LINKONREQUEST}\r\n Result := True;\r\n Inc(SetupApiLoadCount);\r\n if SetupApiLoadCount > 1 then\r\n Exit;\r\n Result := ModuleLoader.LoadModule(SetupApiLib, SetupApiModuleName);\r\n if Result then\r\n begin\r\n {$IFDEF WINXP_UP}\r\n @SetupGetFileQueueCount := GetModuleSymbolEx(SetupApiLib, 'SetupGetFileQueueCount', Result);\r\n @SetupGetFileQueueFlags := GetModuleSymbolEx(SetupApiLib, 'SetupGetFileQueueFlags', Result);\r\n @SetupSetFileQueueFlags := GetModuleSymbolEx(SetupApiLib, 'SetupSetFileQueueFlags', Result);\r\n {$ENDIF WINXP_UP}\r\n @SetupGetInfInformationA := GetModuleSymbolEx(SetupApiLib, 'SetupGetInfInformationA', Result);\r\n @SetupGetInfInformationW := GetModuleSymbolEx(SetupApiLib, 'SetupGetInfInformationW', Result);\r\n @SetupGetInfInformation := GetModuleSymbolEx(SetupApiLib, 'SetupGetInfInformation' + NameSuffix, Result);\r\n @SetupQueryInfFileInformationA := GetModuleSymbolEx(SetupApiLib, 'SetupQueryInfFileInformationA', Result);\r\n @SetupQueryInfFileInformationW := GetModuleSymbolEx(SetupApiLib, 'SetupQueryInfFileInformationW', Result);\r\n @SetupQueryInfFileInformation := GetModuleSymbolEx(SetupApiLib, 'SetupQueryInfFileInformation' + NameSuffix, Result);\r\n {$IFDEF WIN2000_UP}\r\n @SetupQueryInfOriginalFileInformationA := GetModuleSymbolEx(SetupApiLib, 'SetupQueryInfOriginalFileInformationA', Result);\r\n @SetupQueryInfOriginalFileInformationW := GetModuleSymbolEx(SetupApiLib, 'SetupQueryInfOriginalFileInformationW', Result);\r\n @SetupQueryInfOriginalFileInformation := GetModuleSymbolEx(SetupApiLib, 'SetupQueryInfOriginalFileInformation' + NameSuffix, Result);\r\n {$ENDIF WIN2000_UP}\r\n @SetupQueryInfVersionInformationA := GetModuleSymbolEx(SetupApiLib, 'SetupQueryInfVersionInformationA', Result);\r\n @SetupQueryInfVersionInformationW := GetModuleSymbolEx(SetupApiLib, 'SetupQueryInfVersionInformationW', Result);\r\n @SetupQueryInfVersionInformation := GetModuleSymbolEx(SetupApiLib, 'SetupQueryInfVersionInformation' + NameSuffix, Result);\r\n @SetupGetInfFileListA := GetModuleSymbolEx(SetupApiLib, 'SetupGetInfFileListA', Result);\r\n @SetupGetInfFileListW := GetModuleSymbolEx(SetupApiLib, 'SetupGetInfFileListW', Result);\r\n @SetupGetInfFileList := GetModuleSymbolEx(SetupApiLib, 'SetupGetInfFileList' + NameSuffix, Result);\r\n @SetupOpenInfFileA := GetModuleSymbolEx(SetupApiLib, 'SetupOpenInfFileA', Result);\r\n @SetupOpenInfFileW := GetModuleSymbolEx(SetupApiLib, 'SetupOpenInfFileW', Result);\r\n @SetupOpenInfFile := GetModuleSymbolEx(SetupApiLib, 'SetupOpenInfFile' + NameSuffix, Result);\r\n @SetupOpenMasterInf := GetModuleSymbolEx(SetupApiLib, 'SetupOpenMasterInf', Result);\r\n @SetupOpenAppendInfFileA := GetModuleSymbolEx(SetupApiLib, 'SetupOpenAppendInfFileA', Result);\r\n @SetupOpenAppendInfFileW := GetModuleSymbolEx(SetupApiLib, 'SetupOpenAppendInfFileW', Result);\r\n @SetupOpenAppendInfFile := GetModuleSymbolEx(SetupApiLib, 'SetupOpenAppendInfFile' + NameSuffix, Result);\r\n @SetupCloseInfFile := GetModuleSymbolEx(SetupApiLib, 'SetupCloseInfFile', Result);\r\n @SetupFindFirstLineA := GetModuleSymbolEx(SetupApiLib, 'SetupFindFirstLineA', Result);\r\n @SetupFindFirstLineW := GetModuleSymbolEx(SetupApiLib, 'SetupFindFirstLineW', Result);\r\n @SetupFindFirstLine := GetModuleSymbolEx(SetupApiLib, 'SetupFindFirstLine' + NameSuffix, Result);\r\n @SetupFindNextLine := GetModuleSymbolEx(SetupApiLib, 'SetupFindNextLine', Result);\r\n @SetupFindNextMatchLineA := GetModuleSymbolEx(SetupApiLib, 'SetupFindNextMatchLineA', Result);\r\n @SetupFindNextMatchLineW := GetModuleSymbolEx(SetupApiLib, 'SetupFindNextMatchLineW', Result);\r\n @SetupFindNextMatchLine := GetModuleSymbolEx(SetupApiLib, 'SetupFindNextMatchLine' + NameSuffix, Result);\r\n @SetupGetLineByIndexA := GetModuleSymbolEx(SetupApiLib, 'SetupGetLineByIndexA', Result);\r\n @SetupGetLineByIndexW := GetModuleSymbolEx(SetupApiLib, 'SetupGetLineByIndexW', Result);\r\n @SetupGetLineByIndex := GetModuleSymbolEx(SetupApiLib, 'SetupGetLineByIndex' + NameSuffix, Result);\r\n @SetupGetLineCountA := GetModuleSymbolEx(SetupApiLib, 'SetupGetLineCountA', Result);\r\n @SetupGetLineCountW := GetModuleSymbolEx(SetupApiLib, 'SetupGetLineCountW', Result);\r\n @SetupGetLineCount := GetModuleSymbolEx(SetupApiLib, 'SetupGetLineCount' + NameSuffix, Result);\r\n @SetupGetLineTextA := GetModuleSymbolEx(SetupApiLib, 'SetupGetLineTextA', Result);\r\n @SetupGetLineTextW := GetModuleSymbolEx(SetupApiLib, 'SetupGetLineTextW', Result);\r\n @SetupGetLineText := GetModuleSymbolEx(SetupApiLib, 'SetupGetLineText' + NameSuffix, Result);\r\n @SetupGetFieldCount := GetModuleSymbolEx(SetupApiLib, 'SetupGetFieldCount', Result);\r\n @SetupGetStringFieldA := GetModuleSymbolEx(SetupApiLib, 'SetupGetStringFieldA', Result);\r\n @SetupGetStringFieldW := GetModuleSymbolEx(SetupApiLib, 'SetupGetStringFieldW', Result);\r\n @SetupGetStringField := GetModuleSymbolEx(SetupApiLib, 'SetupGetStringField' + NameSuffix, Result);\r\n @SetupGetIntField := GetModuleSymbolEx(SetupApiLib, 'SetupGetIntField', Result);\r\n @SetupGetMultiSzFieldA := GetModuleSymbolEx(SetupApiLib, 'SetupGetMultiSzFieldA', Result);\r\n @SetupGetMultiSzFieldW := GetModuleSymbolEx(SetupApiLib, 'SetupGetMultiSzFieldW', Result);\r\n @SetupGetMultiSzField := GetModuleSymbolEx(SetupApiLib, 'SetupGetMultiSzField' + NameSuffix, Result);\r\n @SetupGetBinaryField := GetModuleSymbolEx(SetupApiLib, 'SetupGetBinaryField', Result);\r\n @SetupGetFileCompressionInfoA := GetModuleSymbolEx(SetupApiLib, 'SetupGetFileCompressionInfoA', Result);\r\n @SetupGetFileCompressionInfoW := GetModuleSymbolEx(SetupApiLib, 'SetupGetFileCompressionInfoW', Result);\r\n @SetupGetFileCompressionInfo := GetModuleSymbolEx(SetupApiLib, 'SetupGetFileCompressionInfo' + NameSuffix, Result);\r\n {$IFDEF WINXP_UP}\r\n @SetupGetFileCompressionInfoExA := GetModuleSymbolEx(SetupApiLib, 'SetupGetFileCompressionInfoExA', Result);\r\n @SetupGetFileCompressionInfoExW := GetModuleSymbolEx(SetupApiLib, 'SetupGetFileCompressionInfoExW', Result);\r\n @SetupGetFileCompressionInfoEx := GetModuleSymbolEx(SetupApiLib, 'SetupGetFileCompressionInfoEx' + NameSuffix, Result);\r\n {$ENDIF WINXP_UP}\r\n @SetupDecompressOrCopyFileA := GetModuleSymbolEx(SetupApiLib, 'SetupDecompressOrCopyFileA', Result);\r\n @SetupDecompressOrCopyFileW := GetModuleSymbolEx(SetupApiLib, 'SetupDecompressOrCopyFileW', Result);\r\n @SetupDecompressOrCopyFile := GetModuleSymbolEx(SetupApiLib, 'SetupDecompressOrCopyFile' + NameSuffix, Result);\r\n @SetupGetSourceFileLocationA := GetModuleSymbolEx(SetupApiLib, 'SetupGetSourceFileLocationA', Result);\r\n @SetupGetSourceFileLocationW := GetModuleSymbolEx(SetupApiLib, 'SetupGetSourceFileLocationW', Result);\r\n @SetupGetSourceFileLocation := GetModuleSymbolEx(SetupApiLib, 'SetupGetSourceFileLocation' + NameSuffix, Result);\r\n @SetupGetSourceFileSizeA := GetModuleSymbolEx(SetupApiLib, 'SetupGetSourceFileSizeA', Result);\r\n @SetupGetSourceFileSizeW := GetModuleSymbolEx(SetupApiLib, 'SetupGetSourceFileSizeW', Result);\r\n @SetupGetSourceFileSize := GetModuleSymbolEx(SetupApiLib, 'SetupGetSourceFileSize' + NameSuffix, Result);\r\n @SetupGetTargetPathA := GetModuleSymbolEx(SetupApiLib, 'SetupGetTargetPathA', Result);\r\n @SetupGetTargetPathW := GetModuleSymbolEx(SetupApiLib, 'SetupGetTargetPathW', Result);\r\n @SetupGetTargetPath := GetModuleSymbolEx(SetupApiLib, 'SetupGetTargetPath' + NameSuffix, Result);\r\n @SetupSetSourceListA := GetModuleSymbolEx(SetupApiLib, 'SetupSetSourceListA', Result);\r\n @SetupSetSourceListW := GetModuleSymbolEx(SetupApiLib, 'SetupSetSourceListW', Result);\r\n @SetupSetSourceList := GetModuleSymbolEx(SetupApiLib, 'SetupSetSourceList' + NameSuffix, Result);\r\n @SetupCancelTemporarySourceList := GetModuleSymbolEx(SetupApiLib, 'SetupCancelTemporarySourceList', Result);\r\n @SetupAddToSourceListA := GetModuleSymbolEx(SetupApiLib, 'SetupAddToSourceListA', Result);\r\n @SetupAddToSourceListW := GetModuleSymbolEx(SetupApiLib, 'SetupAddToSourceListW', Result);\r\n @SetupAddToSourceList := GetModuleSymbolEx(SetupApiLib, 'SetupAddToSourceList' + NameSuffix, Result);\r\n @SetupRemoveFromSourceListA := GetModuleSymbolEx(SetupApiLib, 'SetupRemoveFromSourceListA', Result);\r\n @SetupRemoveFromSourceListW := GetModuleSymbolEx(SetupApiLib, 'SetupRemoveFromSourceListW', Result);\r\n @SetupRemoveFromSourceList := GetModuleSymbolEx(SetupApiLib, 'SetupRemoveFromSourceList' + NameSuffix, Result);\r\n @SetupQuerySourceListA := GetModuleSymbolEx(SetupApiLib, 'SetupQuerySourceListA', Result);\r\n @SetupQuerySourceListW := GetModuleSymbolEx(SetupApiLib, 'SetupQuerySourceListW', Result);\r\n @SetupQuerySourceList := GetModuleSymbolEx(SetupApiLib, 'SetupQuerySourceList' + NameSuffix, Result);\r\n @SetupFreeSourceListA := GetModuleSymbolEx(SetupApiLib, 'SetupFreeSourceListA', Result);\r\n @SetupFreeSourceListW := GetModuleSymbolEx(SetupApiLib, 'SetupFreeSourceListW', Result);\r\n @SetupFreeSourceList := GetModuleSymbolEx(SetupApiLib, 'SetupFreeSourceList' + NameSuffix, Result);\r\n @SetupPromptForDiskA := GetModuleSymbolEx(SetupApiLib, 'SetupPromptForDiskA', Result);\r\n @SetupPromptForDiskW := GetModuleSymbolEx(SetupApiLib, 'SetupPromptForDiskW', Result);\r\n @SetupPromptForDisk := GetModuleSymbolEx(SetupApiLib, 'SetupPromptForDisk' + NameSuffix, Result);\r\n @SetupCopyErrorA := GetModuleSymbolEx(SetupApiLib, 'SetupCopyErrorA', Result);\r\n @SetupCopyErrorW := GetModuleSymbolEx(SetupApiLib, 'SetupCopyErrorW', Result);\r\n @SetupCopyError := GetModuleSymbolEx(SetupApiLib, 'SetupCopyError' + NameSuffix, Result);\r\n @SetupRenameErrorA := GetModuleSymbolEx(SetupApiLib, 'SetupRenameErrorA', Result);\r\n @SetupRenameErrorW := GetModuleSymbolEx(SetupApiLib, 'SetupRenameErrorW', Result);\r\n @SetupRenameError := GetModuleSymbolEx(SetupApiLib, 'SetupRenameError' + NameSuffix, Result);\r\n @SetupDeleteErrorA := GetModuleSymbolEx(SetupApiLib, 'SetupDeleteErrorA', Result);\r\n @SetupDeleteErrorW := GetModuleSymbolEx(SetupApiLib, 'SetupDeleteErrorW', Result);\r\n @SetupDeleteError := GetModuleSymbolEx(SetupApiLib, 'SetupDeleteError' + NameSuffix, Result);\r\n {$IFDEF WIN2000_UP}\r\n @SetupBackupErrorA := GetModuleSymbolEx(SetupApiLib, 'SetupBackupErrorA', Result);\r\n @SetupBackupErrorW := GetModuleSymbolEx(SetupApiLib, 'SetupBackupErrorW', Result);\r\n @SetupBackupError := GetModuleSymbolEx(SetupApiLib, 'SetupBackupError' + NameSuffix, Result);\r\n {$ENDIF WIN2000_UP}\r\n @SetupSetDirectoryIdA := GetModuleSymbolEx(SetupApiLib, 'SetupSetDirectoryIdA', Result);\r\n @SetupSetDirectoryIdW := GetModuleSymbolEx(SetupApiLib, 'SetupSetDirectoryIdW', Result);\r\n @SetupSetDirectoryId := GetModuleSymbolEx(SetupApiLib, 'SetupSetDirectoryId' + NameSuffix, Result);\r\n @SetupSetDirectoryIdExA := GetModuleSymbolEx(SetupApiLib, 'SetupSetDirectoryIdExA', Result);\r\n @SetupSetDirectoryIdExW := GetModuleSymbolEx(SetupApiLib, 'SetupSetDirectoryIdExW', Result);\r\n @SetupSetDirectoryIdEx := GetModuleSymbolEx(SetupApiLib, 'SetupSetDirectoryIdEx' + NameSuffix, Result);\r\n @SetupGetSourceInfoA := GetModuleSymbolEx(SetupApiLib, 'SetupGetSourceInfoA', Result);\r\n @SetupGetSourceInfoW := GetModuleSymbolEx(SetupApiLib, 'SetupGetSourceInfoW', Result);\r\n @SetupGetSourceInfo := GetModuleSymbolEx(SetupApiLib, 'SetupGetSourceInfo' + NameSuffix, Result);\r\n @SetupInstallFileA := GetModuleSymbolEx(SetupApiLib, 'SetupInstallFileA', Result);\r\n @SetupInstallFileW := GetModuleSymbolEx(SetupApiLib, 'SetupInstallFileW', Result);\r\n @SetupInstallFile := GetModuleSymbolEx(SetupApiLib, 'SetupInstallFile' + NameSuffix, Result);\r\n @SetupInstallFileExA := GetModuleSymbolEx(SetupApiLib, 'SetupInstallFileExA', Result);\r\n @SetupInstallFileExW := GetModuleSymbolEx(SetupApiLib, 'SetupInstallFileExW', Result);\r\n @SetupInstallFileEx := GetModuleSymbolEx(SetupApiLib, 'SetupInstallFileEx' + NameSuffix, Result);\r\n @SetupOpenFileQueue := GetModuleSymbolEx(SetupApiLib, 'SetupOpenFileQueue', Result);\r\n @SetupCloseFileQueue := GetModuleSymbolEx(SetupApiLib, 'SetupCloseFileQueue', Result);\r\n {$IFDEF WIN2000_UP}\r\n @SetupSetFileQueueAlternatePlatformA := GetModuleSymbolEx(SetupApiLib, 'SetupSetFileQueueAlternatePlatformA', Result);\r\n @SetupSetFileQueueAlternatePlatformW := GetModuleSymbolEx(SetupApiLib, 'SetupSetFileQueueAlternatePlatformW', Result);\r\n @SetupSetFileQueueAlternatePlatform := GetModuleSymbolEx(SetupApiLib, 'SetupSetFileQueueAlternatePlatform' + NameSuffix, Result);\r\n {$ENDIF WIN2000_UP}\r\n @SetupSetPlatformPathOverrideA := GetModuleSymbolEx(SetupApiLib, 'SetupSetPlatformPathOverrideA', Result);\r\n @SetupSetPlatformPathOverrideW := GetModuleSymbolEx(SetupApiLib, 'SetupSetPlatformPathOverrideW', Result);\r\n @SetupSetPlatformPathOverride := GetModuleSymbolEx(SetupApiLib, 'SetupSetPlatformPathOverride' + NameSuffix, Result);\r\n @SetupQueueCopyA := GetModuleSymbolEx(SetupApiLib, 'SetupQueueCopyA', Result);\r\n @SetupQueueCopyW := GetModuleSymbolEx(SetupApiLib, 'SetupQueueCopyW', Result);\r\n @SetupQueueCopy := GetModuleSymbolEx(SetupApiLib, 'SetupQueueCopy' + NameSuffix, Result);\r\n {$IFDEF WIN2000_UP}\r\n @SetupQueueCopyIndirectA := GetModuleSymbolEx(SetupApiLib, 'SetupQueueCopyIndirectA', Result);\r\n @SetupQueueCopyIndirectW := GetModuleSymbolEx(SetupApiLib, 'SetupQueueCopyIndirectW', Result);\r\n @SetupQueueCopyIndirect := GetModuleSymbolEx(SetupApiLib, 'SetupQueueCopyIndirect' + NameSuffix, Result);\r\n {$ENDIF WIN2000_UP}\r\n @SetupQueueDefaultCopyA := GetModuleSymbolEx(SetupApiLib, 'SetupQueueDefaultCopyA', Result);\r\n @SetupQueueDefaultCopyW := GetModuleSymbolEx(SetupApiLib, 'SetupQueueDefaultCopyW', Result);\r\n @SetupQueueDefaultCopy := GetModuleSymbolEx(SetupApiLib, 'SetupQueueDefaultCopy' + NameSuffix, Result);\r\n @SetupQueueCopySectionA := GetModuleSymbolEx(SetupApiLib, 'SetupQueueCopySectionA', Result);\r\n @SetupQueueCopySectionW := GetModuleSymbolEx(SetupApiLib, 'SetupQueueCopySectionW', Result);\r\n @SetupQueueCopySection := GetModuleSymbolEx(SetupApiLib, 'SetupQueueCopySection' + NameSuffix, Result);\r\n @SetupQueueDeleteA := GetModuleSymbolEx(SetupApiLib, 'SetupQueueDeleteA', Result);\r\n @SetupQueueDeleteW := GetModuleSymbolEx(SetupApiLib, 'SetupQueueDeleteW', Result);\r\n @SetupQueueDelete := GetModuleSymbolEx(SetupApiLib, 'SetupQueueDelete' + NameSuffix, Result);\r\n @SetupQueueDeleteSectionA := GetModuleSymbolEx(SetupApiLib, 'SetupQueueDeleteSectionA', Result);\r\n @SetupQueueDeleteSectionW := GetModuleSymbolEx(SetupApiLib, 'SetupQueueDeleteSectionW', Result);\r\n @SetupQueueDeleteSection := GetModuleSymbolEx(SetupApiLib, 'SetupQueueDeleteSection' + NameSuffix, Result);\r\n @SetupQueueRenameA := GetModuleSymbolEx(SetupApiLib, 'SetupQueueRenameA', Result);\r\n @SetupQueueRenameW := GetModuleSymbolEx(SetupApiLib, 'SetupQueueRenameW', Result);\r\n @SetupQueueRename := GetModuleSymbolEx(SetupApiLib, 'SetupQueueRename' + NameSuffix, Result);\r\n @SetupQueueRenameSectionA := GetModuleSymbolEx(SetupApiLib, 'SetupQueueRenameSectionA', Result);\r\n @SetupQueueRenameSectionW := GetModuleSymbolEx(SetupApiLib, 'SetupQueueRenameSectionW', Result);\r\n @SetupQueueRenameSection := GetModuleSymbolEx(SetupApiLib, 'SetupQueueRenameSection' + NameSuffix, Result);\r\n @SetupCommitFileQueueA := GetModuleSymbolEx(SetupApiLib, 'SetupCommitFileQueueA', Result);\r\n @SetupCommitFileQueueW := GetModuleSymbolEx(SetupApiLib, 'SetupCommitFileQueueW', Result);\r\n @SetupCommitFileQueue := GetModuleSymbolEx(SetupApiLib, 'SetupCommitFileQueue' + NameSuffix, Result);\r\n @SetupScanFileQueueA := GetModuleSymbolEx(SetupApiLib, 'SetupScanFileQueueA', Result);\r\n @SetupScanFileQueueW := GetModuleSymbolEx(SetupApiLib, 'SetupScanFileQueueW', Result);\r\n @SetupScanFileQueue := GetModuleSymbolEx(SetupApiLib, 'SetupScanFileQueue' + NameSuffix, Result);\r\n @SetupCopyOEMInfA := GetModuleSymbolEx(SetupApiLib, 'SetupCopyOEMInfA', Result);\r\n @SetupCopyOEMInfW := GetModuleSymbolEx(SetupApiLib, 'SetupCopyOEMInfW', Result);\r\n @SetupCopyOEMInf := GetModuleSymbolEx(SetupApiLib, 'SetupCopyOEMInf' + NameSuffix, Result);\r\n {$IFDEF WINXP_UP}\r\n @SetupUninstallOEMInfA := GetModuleSymbolEx(SetupApiLib, 'SetupUninstallOEMInfA', Result);\r\n @SetupUninstallOEMInfW := GetModuleSymbolEx(SetupApiLib, 'SetupUninstallOEMInfW', Result);\r\n @SetupUninstallOEMInf := GetModuleSymbolEx(SetupApiLib, 'SetupUninstallOEMInf' + NameSuffix, Result);\r\n @SetupUninstallNewlyCopiedInfs := GetModuleSymbolEx(SetupApiLib, 'SetupUninstallNewlyCopiedInfs', Result);\r\n {$ENDIF WINXP_UP}\r\n @SetupCreateDiskSpaceListA := GetModuleSymbolEx(SetupApiLib, 'SetupCreateDiskSpaceListA', Result);\r\n @SetupCreateDiskSpaceListW := GetModuleSymbolEx(SetupApiLib, 'SetupCreateDiskSpaceListW', Result);\r\n @SetupCreateDiskSpaceList := GetModuleSymbolEx(SetupApiLib, 'SetupCreateDiskSpaceList' + NameSuffix, Result);\r\n @SetupDuplicateDiskSpaceListA := GetModuleSymbolEx(SetupApiLib, 'SetupDuplicateDiskSpaceListA', Result);\r\n @SetupDuplicateDiskSpaceListW := GetModuleSymbolEx(SetupApiLib, 'SetupDuplicateDiskSpaceListW', Result);\r\n @SetupDuplicateDiskSpaceList := GetModuleSymbolEx(SetupApiLib, 'SetupDuplicateDiskSpaceList' + NameSuffix, Result);\r\n @SetupDestroyDiskSpaceList := GetModuleSymbolEx(SetupApiLib, 'SetupDestroyDiskSpaceList', Result);\r\n @SetupQueryDrivesInDiskSpaceListA := GetModuleSymbolEx(SetupApiLib, 'SetupQueryDrivesInDiskSpaceListA', Result);\r\n @SetupQueryDrivesInDiskSpaceListW := GetModuleSymbolEx(SetupApiLib, 'SetupQueryDrivesInDiskSpaceListW', Result);\r\n @SetupQueryDrivesInDiskSpaceList := GetModuleSymbolEx(SetupApiLib, 'SetupQueryDrivesInDiskSpaceList' + NameSuffix, Result);\r\n @SetupQuerySpaceRequiredOnDriveA := GetModuleSymbolEx(SetupApiLib, 'SetupQuerySpaceRequiredOnDriveA', Result);\r\n @SetupQuerySpaceRequiredOnDriveW := GetModuleSymbolEx(SetupApiLib, 'SetupQuerySpaceRequiredOnDriveW', Result);\r\n @SetupQuerySpaceRequiredOnDrive := GetModuleSymbolEx(SetupApiLib, 'SetupQuerySpaceRequiredOnDrive' + NameSuffix, Result);\r\n @SetupAdjustDiskSpaceListA := GetModuleSymbolEx(SetupApiLib, 'SetupAdjustDiskSpaceListA', Result);\r\n @SetupAdjustDiskSpaceListW := GetModuleSymbolEx(SetupApiLib, 'SetupAdjustDiskSpaceListW', Result);\r\n @SetupAdjustDiskSpaceList := GetModuleSymbolEx(SetupApiLib, 'SetupAdjustDiskSpaceList' + NameSuffix, Result);\r\n @SetupAddToDiskSpaceListA := GetModuleSymbolEx(SetupApiLib, 'SetupAddToDiskSpaceListA', Result);\r\n @SetupAddToDiskSpaceListW := GetModuleSymbolEx(SetupApiLib, 'SetupAddToDiskSpaceListW', Result);\r\n @SetupAddToDiskSpaceList := GetModuleSymbolEx(SetupApiLib, 'SetupAddToDiskSpaceList' + NameSuffix, Result);\r\n @SetupAddSectionToDiskSpaceListA := GetModuleSymbolEx(SetupApiLib, 'SetupAddSectionToDiskSpaceListA', Result);\r\n @SetupAddSectionToDiskSpaceListW := GetModuleSymbolEx(SetupApiLib, 'SetupAddSectionToDiskSpaceListW', Result);\r\n @SetupAddSectionToDiskSpaceList := GetModuleSymbolEx(SetupApiLib, 'SetupAddSectionToDiskSpaceList' + NameSuffix, Result);\r\n @SetupAddInstallSectionToDiskSpaceListA := GetModuleSymbolEx(SetupApiLib, 'SetupAddInstallSectionToDiskSpaceListA', Result);\r\n @SetupAddInstallSectionToDiskSpaceListW := GetModuleSymbolEx(SetupApiLib, 'SetupAddInstallSectionToDiskSpaceListW', Result);\r\n @SetupAddInstallSectionToDiskSpaceList := GetModuleSymbolEx(SetupApiLib, 'SetupAddInstallSectionToDiskSpaceList' + NameSuffix, Result);\r\n @SetupRemoveFromDiskSpaceListA := GetModuleSymbolEx(SetupApiLib, 'SetupRemoveFromDiskSpaceListA', Result);\r\n @SetupRemoveFromDiskSpaceListW := GetModuleSymbolEx(SetupApiLib, 'SetupRemoveFromDiskSpaceListW', Result);\r\n @SetupRemoveFromDiskSpaceList := GetModuleSymbolEx(SetupApiLib, 'SetupRemoveFromDiskSpaceList' + NameSuffix, Result);\r\n @SetupRemoveSectionFromDiskSpaceListA := GetModuleSymbolEx(SetupApiLib, 'SetupRemoveSectionFromDiskSpaceListA', Result);\r\n @SetupRemoveSectionFromDiskSpaceListW := GetModuleSymbolEx(SetupApiLib, 'SetupRemoveSectionFromDiskSpaceListW', Result);\r\n @SetupRemoveSectionFromDiskSpaceList := GetModuleSymbolEx(SetupApiLib, 'SetupRemoveSectionFromDiskSpaceList' + NameSuffix, Result);\r\n @SetupRemoveInstallSectionFromDiskSpaceListA := GetModuleSymbolEx(SetupApiLib, 'SetupRemoveInstallSectionFromDiskSpaceListA', Result);\r\n @SetupRemoveInstallSectionFromDiskSpaceListW := GetModuleSymbolEx(SetupApiLib, 'SetupRemoveInstallSectionFromDiskSpaceListW', Result);\r\n @SetupRemoveInstallSectionFromDiskSpaceList := GetModuleSymbolEx(SetupApiLib, 'SetupRemoveInstallSectionFromDiskSpaceList' + NameSuffix, Result);\r\n @SetupIterateCabinetA := GetModuleSymbolEx(SetupApiLib, 'SetupIterateCabinetA', Result);\r\n @SetupIterateCabinetW := GetModuleSymbolEx(SetupApiLib, 'SetupIterateCabinetW', Result);\r\n @SetupIterateCabinet := GetModuleSymbolEx(SetupApiLib, 'SetupIterateCabinet' + NameSuffix, Result);\r\n @SetupPromptReboot := GetModuleSymbolEx(SetupApiLib, 'SetupPromptReboot', Result);\r\n @SetupInitDefaultQueueCallback := GetModuleSymbolEx(SetupApiLib, 'SetupInitDefaultQueueCallback', Result);\r\n @SetupInitDefaultQueueCallbackEx := GetModuleSymbolEx(SetupApiLib, 'SetupInitDefaultQueueCallbackEx', Result);\r\n @SetupTermDefaultQueueCallback := GetModuleSymbolEx(SetupApiLib, 'SetupTermDefaultQueueCallback', Result);\r\n @SetupDefaultQueueCallbackA := GetModuleSymbolEx(SetupApiLib, 'SetupDefaultQueueCallbackA', Result);\r\n @SetupDefaultQueueCallbackW := GetModuleSymbolEx(SetupApiLib, 'SetupDefaultQueueCallbackW', Result);\r\n @SetupDefaultQueueCallback := GetModuleSymbolEx(SetupApiLib, 'SetupDefaultQueueCallback' + NameSuffix, Result);\r\n @SetupInstallFromInfSectionA := GetModuleSymbolEx(SetupApiLib, 'SetupInstallFromInfSectionA', Result);\r\n @SetupInstallFromInfSectionW := GetModuleSymbolEx(SetupApiLib, 'SetupInstallFromInfSectionW', Result);\r\n @SetupInstallFromInfSection := GetModuleSymbolEx(SetupApiLib, 'SetupInstallFromInfSection' + NameSuffix, Result);\r\n @SetupInstallFilesFromInfSectionA := GetModuleSymbolEx(SetupApiLib, 'SetupInstallFilesFromInfSectionA', Result);\r\n @SetupInstallFilesFromInfSectionW := GetModuleSymbolEx(SetupApiLib, 'SetupInstallFilesFromInfSectionW', Result);\r\n @SetupInstallFilesFromInfSection := GetModuleSymbolEx(SetupApiLib, 'SetupInstallFilesFromInfSection' + NameSuffix, Result);\r\n @SetupInstallServicesFromInfSectionA := GetModuleSymbolEx(SetupApiLib, 'SetupInstallServicesFromInfSectionA', Result);\r\n @SetupInstallServicesFromInfSectionW := GetModuleSymbolEx(SetupApiLib, 'SetupInstallServicesFromInfSectionW', Result);\r\n @SetupInstallServicesFromInfSection := GetModuleSymbolEx(SetupApiLib, 'SetupInstallServicesFromInfSection' + NameSuffix, Result);\r\n @SetupInstallServicesFromInfSectionExA := GetModuleSymbolEx(SetupApiLib, 'SetupInstallServicesFromInfSectionExA', Result);\r\n @SetupInstallServicesFromInfSectionExW := GetModuleSymbolEx(SetupApiLib, 'SetupInstallServicesFromInfSectionExW', Result);\r\n @SetupInstallServicesFromInfSectionEx := GetModuleSymbolEx(SetupApiLib, 'SetupInstallServicesFromInfSectionEx' + NameSuffix, Result);\r\n {$IFDEF WINXP_UP}\r\n @InstallHinfSectionA := GetModuleSymbolEx(SetupApiLib, 'InstallHinfSectionA', Result);\r\n @InstallHinfSectionW := GetModuleSymbolEx(SetupApiLib, 'InstallHinfSectionW', Result);\r\n @InstallHinfSection := GetModuleSymbolEx(SetupApiLib, 'InstallHinfSection' + NameSuffix, Result);\r\n {$ENDIF WINXP_UP}\r\n @SetupInitializeFileLogA := GetModuleSymbolEx(SetupApiLib, 'SetupInitializeFileLogA', Result);\r\n @SetupInitializeFileLogW := GetModuleSymbolEx(SetupApiLib, 'SetupInitializeFileLogW', Result);\r\n @SetupInitializeFileLog := GetModuleSymbolEx(SetupApiLib, 'SetupInitializeFileLog' + NameSuffix, Result);\r\n @SetupTerminateFileLog := GetModuleSymbolEx(SetupApiLib, 'SetupTerminateFileLog', Result);\r\n @SetupLogFileA := GetModuleSymbolEx(SetupApiLib, 'SetupLogFileA', Result);\r\n @SetupLogFileW := GetModuleSymbolEx(SetupApiLib, 'SetupLogFileW', Result);\r\n @SetupLogFile := GetModuleSymbolEx(SetupApiLib, 'SetupLogFile' + NameSuffix, Result);\r\n @SetupRemoveFileLogEntryA := GetModuleSymbolEx(SetupApiLib, 'SetupRemoveFileLogEntryA', Result);\r\n @SetupRemoveFileLogEntryW := GetModuleSymbolEx(SetupApiLib, 'SetupRemoveFileLogEntryW', Result);\r\n @SetupRemoveFileLogEntry := GetModuleSymbolEx(SetupApiLib, 'SetupRemoveFileLogEntry' + NameSuffix, Result);\r\n @SetupQueryFileLogA := GetModuleSymbolEx(SetupApiLib, 'SetupQueryFileLogA', Result);\r\n @SetupQueryFileLogW := GetModuleSymbolEx(SetupApiLib, 'SetupQueryFileLogW', Result);\r\n @SetupQueryFileLog := GetModuleSymbolEx(SetupApiLib, 'SetupQueryFileLog' + NameSuffix, Result);\r\n @SetupOpenLog := GetModuleSymbolEx(SetupApiLib, 'SetupOpenLog', Result);\r\n @SetupLogErrorA := GetModuleSymbolEx(SetupApiLib, 'SetupLogErrorA', Result);\r\n @SetupLogErrorW := GetModuleSymbolEx(SetupApiLib, 'SetupLogErrorW', Result);\r\n @SetupLogError := GetModuleSymbolEx(SetupApiLib, 'SetupLogError' + NameSuffix, Result);\r\n @SetupCloseLog := GetModuleSymbolEx(SetupApiLib, 'SetupCloseLog', Result);\r\n {$IFDEF WIN2000_UP}\r\n @SetupGetBackupInformationA := GetModuleSymbolEx(SetupApiLib, 'SetupGetBackupInformationA', Result);\r\n @SetupGetBackupInformationW := GetModuleSymbolEx(SetupApiLib, 'SetupGetBackupInformationW', Result);\r\n @SetupGetBackupInformation := GetModuleSymbolEx(SetupApiLib, 'SetupGetBackupInformation' + NameSuffix, Result);\r\n {$ENDIF WIN2000_UP}\r\n {$IFDEF WINXP_UP}\r\n @SetupPrepareQueueForRestoreA := GetModuleSymbolEx(SetupApiLib, 'SetupPrepareQueueForRestoreA', Result);\r\n @SetupPrepareQueueForRestoreW := GetModuleSymbolEx(SetupApiLib, 'SetupPrepareQueueForRestoreW', Result);\r\n @SetupPrepareQueueForRestore := GetModuleSymbolEx(SetupApiLib, 'SetupPrepareQueueForRestore' + NameSuffix, Result);\r\n @SetupSetNonInteractiveMode := GetModuleSymbolEx(SetupApiLib, 'SetupSetNonInteractiveMode', Result);\r\n @SetupGetNonInteractiveMode := GetModuleSymbolEx(SetupApiLib, 'SetupGetNonInteractiveMode', Result);\r\n {$ENDIF WINXP_UP}\r\n @SetupDiCreateDeviceInfoList := GetModuleSymbolEx(SetupApiLib, 'SetupDiCreateDeviceInfoList', Result);\r\n @SetupDiCreateDeviceInfoListExA := GetModuleSymbolEx(SetupApiLib, 'SetupDiCreateDeviceInfoListExA', Result);\r\n @SetupDiCreateDeviceInfoListExW := GetModuleSymbolEx(SetupApiLib, 'SetupDiCreateDeviceInfoListExW', Result);\r\n @SetupDiCreateDeviceInfoListEx := GetModuleSymbolEx(SetupApiLib, 'SetupDiCreateDeviceInfoListEx' + NameSuffix, Result);\r\n @SetupDiGetDeviceInfoListClass := GetModuleSymbolEx(SetupApiLib, 'SetupDiGetDeviceInfoListClass', Result);\r\n @SetupDiGetDeviceInfoListDetailA := GetModuleSymbolEx(SetupApiLib, 'SetupDiGetDeviceInfoListDetailA', Result);\r\n @SetupDiGetDeviceInfoListDetailW := GetModuleSymbolEx(SetupApiLib, 'SetupDiGetDeviceInfoListDetailW', Result);\r\n @SetupDiGetDeviceInfoListDetail := GetModuleSymbolEx(SetupApiLib, 'SetupDiGetDeviceInfoListDetail' + NameSuffix, Result);\r\n @SetupDiCreateDeviceInfoA := GetModuleSymbolEx(SetupApiLib, 'SetupDiCreateDeviceInfoA', Result);\r\n @SetupDiCreateDeviceInfoW := GetModuleSymbolEx(SetupApiLib, 'SetupDiCreateDeviceInfoW', Result);\r\n @SetupDiCreateDeviceInfo := GetModuleSymbolEx(SetupApiLib, 'SetupDiCreateDeviceInfo' + NameSuffix, Result);\r\n @SetupDiOpenDeviceInfoA := GetModuleSymbolEx(SetupApiLib, 'SetupDiOpenDeviceInfoA', Result);\r\n @SetupDiOpenDeviceInfoW := GetModuleSymbolEx(SetupApiLib, 'SetupDiOpenDeviceInfoW', Result);\r\n @SetupDiOpenDeviceInfo := GetModuleSymbolEx(SetupApiLib, 'SetupDiOpenDeviceInfo' + NameSuffix, Result);\r\n @SetupDiGetDeviceInstanceIdA := GetModuleSymbolEx(SetupApiLib, 'SetupDiGetDeviceInstanceIdA', Result);\r\n @SetupDiGetDeviceInstanceIdW := GetModuleSymbolEx(SetupApiLib, 'SetupDiGetDeviceInstanceIdW', Result);\r\n @SetupDiGetDeviceInstanceId := GetModuleSymbolEx(SetupApiLib, 'SetupDiGetDeviceInstanceId' + NameSuffix, Result);\r\n @SetupDiDeleteDeviceInfo := GetModuleSymbolEx(SetupApiLib, 'SetupDiDeleteDeviceInfo', Result);\r\n @SetupDiEnumDeviceInfo := GetModuleSymbolEx(SetupApiLib, 'SetupDiEnumDeviceInfo', Result);\r\n @SetupDiDestroyDeviceInfoList := GetModuleSymbolEx(SetupApiLib, 'SetupDiDestroyDeviceInfoList', Result);\r\n @SetupDiEnumDeviceInterfaces := GetModuleSymbolEx(SetupApiLib, 'SetupDiEnumDeviceInterfaces', Result);\r\n @SetupDiEnumInterfaceDevice := GetModuleSymbolEx(SetupApiLib, 'SetupDiEnumDeviceInterfaces', Result);\r\n @SetupDiCreateDeviceInterfaceA := GetModuleSymbolEx(SetupApiLib, 'SetupDiCreateDeviceInterfaceA', Result);\r\n @SetupDiCreateInterfaceDeviceA := GetModuleSymbolEx(SetupApiLib, 'SetupDiCreateDeviceInterfaceA', Result);\r\n @SetupDiCreateDeviceInterfaceW := GetModuleSymbolEx(SetupApiLib, 'SetupDiCreateDeviceInterfaceW', Result);\r\n @SetupDiCreateInterfaceDeviceW := GetModuleSymbolEx(SetupApiLib, 'SetupDiCreateDeviceInterfaceW', Result);\r\n @SetupDiCreateDeviceInterface := GetModuleSymbolEx(SetupApiLib, 'SetupDiCreateDeviceInterface' + NameSuffix, Result);\r\n @SetupDiCreateInterfaceDevice := GetModuleSymbolEx(SetupApiLib, 'SetupDiCreateDeviceInterface' + NameSuffix, Result);\r\n @SetupDiOpenDeviceInterfaceA := GetModuleSymbolEx(SetupApiLib, 'SetupDiOpenDeviceInterfaceA', Result);\r\n @SetupDiOpenInterfaceDeviceA := GetModuleSymbolEx(SetupApiLib, 'SetupDiOpenDeviceInterfaceA', Result);\r\n @SetupDiOpenDeviceInterfaceW := GetModuleSymbolEx(SetupApiLib, 'SetupDiOpenDeviceInterfaceW', Result);\r\n @SetupDiOpenInterfaceDeviceW := GetModuleSymbolEx(SetupApiLib, 'SetupDiOpenDeviceInterfaceW', Result);\r\n @SetupDiOpenDeviceInterface := GetModuleSymbolEx(SetupApiLib, 'SetupDiOpenDeviceInterface' + NameSuffix, Result);\r\n @SetupDiOpenInterfaceDevice := GetModuleSymbolEx(SetupApiLib, 'SetupDiOpenDeviceInterface' + NameSuffix, Result);\r\n @SetupDiGetDeviceInterfaceAlias := GetModuleSymbolEx(SetupApiLib, 'SetupDiGetDeviceInterfaceAlias', Result);\r\n @SetupDiGetInterfaceDeviceAlias := GetModuleSymbolEx(SetupApiLib, 'SetupDiGetDeviceInterfaceAlias', Result);\r\n @SetupDiDeleteDeviceInterfaceData := GetModuleSymbolEx(SetupApiLib, 'SetupDiDeleteDeviceInterfaceData', Result);\r\n @SetupDiDeleteInterfaceDeviceData := GetModuleSymbolEx(SetupApiLib, 'SetupDiDeleteDeviceInterfaceData', Result);\r\n @SetupDiRemoveDeviceInterface := GetModuleSymbolEx(SetupApiLib, 'SetupDiRemoveDeviceInterface', Result);\r\n @SetupDiRemoveInterfaceDevice := GetModuleSymbolEx(SetupApiLib, 'SetupDiRemoveDeviceInterface', Result);\r\n @SetupDiGetDeviceInterfaceDetailA := GetModuleSymbolEx(SetupApiLib, 'SetupDiGetDeviceInterfaceDetailA', Result);\r\n @SetupDiGetInterfaceDeviceDetailA := GetModuleSymbolEx(SetupApiLib, 'SetupDiGetDeviceInterfaceDetailA', Result);\r\n @SetupDiGetDeviceInterfaceDetailW := GetModuleSymbolEx(SetupApiLib, 'SetupDiGetDeviceInterfaceDetailW', Result);\r\n @SetupDiGetInterfaceDeviceDetailW := GetModuleSymbolEx(SetupApiLib, 'SetupDiGetDeviceInterfaceDetailW', Result);\r\n @SetupDiGetDeviceInterfaceDetail := GetModuleSymbolEx(SetupApiLib, 'SetupDiGetDeviceInterfaceDetail' + NameSuffix, Result);\r\n @SetupDiGetInterfaceDeviceDetail := GetModuleSymbolEx(SetupApiLib, 'SetupDiGetDeviceInterfaceDetail' + NameSuffix, Result);\r\n @SetupDiInstallDeviceInterfaces := GetModuleSymbolEx(SetupApiLib, 'SetupDiInstallDeviceInterfaces', Result);\r\n @SetupDiInstallInterfaceDevices := GetModuleSymbolEx(SetupApiLib, 'SetupDiInstallDeviceInterfaces', Result);\r\n {$IFDEF WINXP_UP}\r\n @SetupDiSetDeviceInterfaceDefault := GetModuleSymbolEx(SetupApiLib, 'SetupDiSetDeviceInterfaceDefault', Result);\r\n {$ENDIF WINXP_UP}\r\n @SetupDiRegisterDeviceInfo := GetModuleSymbolEx(SetupApiLib, 'SetupDiRegisterDeviceInfo', Result);\r\n @SetupDiBuildDriverInfoList := GetModuleSymbolEx(SetupApiLib, 'SetupDiBuildDriverInfoList', Result);\r\n @SetupDiCancelDriverInfoSearch := GetModuleSymbolEx(SetupApiLib, 'SetupDiCancelDriverInfoSearch', Result);\r\n @SetupDiEnumDriverInfoA := GetModuleSymbolEx(SetupApiLib, 'SetupDiEnumDriverInfoA', Result);\r\n @SetupDiEnumDriverInfoW := GetModuleSymbolEx(SetupApiLib, 'SetupDiEnumDriverInfoW', Result);\r\n @SetupDiEnumDriverInfo := GetModuleSymbolEx(SetupApiLib, 'SetupDiEnumDriverInfo' + NameSuffix, Result);\r\n @SetupDiGetSelectedDriverA := GetModuleSymbolEx(SetupApiLib, 'SetupDiGetSelectedDriverA', Result);\r\n @SetupDiGetSelectedDriverW := GetModuleSymbolEx(SetupApiLib, 'SetupDiGetSelectedDriverW', Result);\r\n @SetupDiGetSelectedDriver := GetModuleSymbolEx(SetupApiLib, 'SetupDiGetSelectedDriver' + NameSuffix, Result);\r\n @SetupDiSetSelectedDriverA := GetModuleSymbolEx(SetupApiLib, 'SetupDiSetSelectedDriverA', Result);\r\n @SetupDiSetSelectedDriverW := GetModuleSymbolEx(SetupApiLib, 'SetupDiSetSelectedDriverW', Result);\r\n @SetupDiSetSelectedDriver := GetModuleSymbolEx(SetupApiLib, 'SetupDiSetSelectedDriver' + NameSuffix, Result);\r\n @SetupDiGetDriverInfoDetailA := GetModuleSymbolEx(SetupApiLib, 'SetupDiGetDriverInfoDetailA', Result);\r\n @SetupDiGetDriverInfoDetailW := GetModuleSymbolEx(SetupApiLib, 'SetupDiGetDriverInfoDetailW', Result);\r\n @SetupDiGetDriverInfoDetail := GetModuleSymbolEx(SetupApiLib, 'SetupDiGetDriverInfoDetail' + NameSuffix, Result);\r\n @SetupDiDestroyDriverInfoList := GetModuleSymbolEx(SetupApiLib, 'SetupDiDestroyDriverInfoList', Result);\r\n @SetupDiGetClassDevsA := GetModuleSymbolEx(SetupApiLib, 'SetupDiGetClassDevsA', Result);\r\n @SetupDiGetClassDevsW := GetModuleSymbolEx(SetupApiLib, 'SetupDiGetClassDevsW', Result);\r\n @SetupDiGetClassDevs := GetModuleSymbolEx(SetupApiLib, 'SetupDiGetClassDevs' + NameSuffix, Result);\r\n @SetupDiGetClassDevsExA := GetModuleSymbolEx(SetupApiLib, 'SetupDiGetClassDevsExA', Result);\r\n @SetupDiGetClassDevsExW := GetModuleSymbolEx(SetupApiLib, 'SetupDiGetClassDevsExW', Result);\r\n @SetupDiGetClassDevsEx := GetModuleSymbolEx(SetupApiLib, 'SetupDiGetClassDevsEx' + NameSuffix, Result);\r\n @SetupDiGetINFClassA := GetModuleSymbolEx(SetupApiLib, 'SetupDiGetINFClassA', Result);\r\n @SetupDiGetINFClassW := GetModuleSymbolEx(SetupApiLib, 'SetupDiGetINFClassW', Result);\r\n @SetupDiGetINFClass := GetModuleSymbolEx(SetupApiLib, 'SetupDiGetINFClass' + NameSuffix, Result);\r\n @SetupDiBuildClassInfoList := GetModuleSymbolEx(SetupApiLib, 'SetupDiBuildClassInfoList', Result);\r\n @SetupDiBuildClassInfoListExA := GetModuleSymbolEx(SetupApiLib, 'SetupDiBuildClassInfoListExA', Result);\r\n @SetupDiBuildClassInfoListExW := GetModuleSymbolEx(SetupApiLib, 'SetupDiBuildClassInfoListExW', Result);\r\n @SetupDiBuildClassInfoListEx := GetModuleSymbolEx(SetupApiLib, 'SetupDiBuildClassInfoListEx' + NameSuffix, Result);\r\n @SetupDiGetClassDescriptionA := GetModuleSymbolEx(SetupApiLib, 'SetupDiGetClassDescriptionA', Result);\r\n @SetupDiGetClassDescriptionW := GetModuleSymbolEx(SetupApiLib, 'SetupDiGetClassDescriptionW', Result);\r\n @SetupDiGetClassDescription := GetModuleSymbolEx(SetupApiLib, 'SetupDiGetClassDescription' + NameSuffix, Result);\r\n @SetupDiGetClassDescriptionExA := GetModuleSymbolEx(SetupApiLib, 'SetupDiGetClassDescriptionExA', Result);\r\n @SetupDiGetClassDescriptionExW := GetModuleSymbolEx(SetupApiLib, 'SetupDiGetClassDescriptionExW', Result);\r\n @SetupDiGetClassDescriptionEx := GetModuleSymbolEx(SetupApiLib, 'SetupDiGetClassDescriptionEx' + NameSuffix, Result);\r\n @SetupDiCallClassInstaller := GetModuleSymbolEx(SetupApiLib, 'SetupDiCallClassInstaller', Result);\r\n @SetupDiSelectDevice := GetModuleSymbolEx(SetupApiLib, 'SetupDiSelectDevice', Result);\r\n @SetupDiSelectBestCompatDrv := GetModuleSymbolEx(SetupApiLib, 'SetupDiSelectBestCompatDrv', Result);\r\n @SetupDiInstallDevice := GetModuleSymbolEx(SetupApiLib, 'SetupDiInstallDevice', Result);\r\n @SetupDiInstallDriverFiles := GetModuleSymbolEx(SetupApiLib, 'SetupDiInstallDriverFiles', Result);\r\n @SetupDiRegisterCoDeviceInstallers := GetModuleSymbolEx(SetupApiLib, 'SetupDiRegisterCoDeviceInstallers', Result);\r\n @SetupDiRemoveDevice := GetModuleSymbolEx(SetupApiLib, 'SetupDiRemoveDevice', Result);\r\n @SetupDiUnremoveDevice := GetModuleSymbolEx(SetupApiLib, 'SetupDiUnremoveDevice', Result);\r\n @SetupDiMoveDuplicateDevice := GetModuleSymbolEx(SetupApiLib, 'SetupDiMoveDuplicateDevice', Result);\r\n @SetupDiChangeState := GetModuleSymbolEx(SetupApiLib, 'SetupDiChangeState', Result);\r\n @SetupDiInstallClassA := GetModuleSymbolEx(SetupApiLib, 'SetupDiInstallClassA', Result);\r\n @SetupDiInstallClassW := GetModuleSymbolEx(SetupApiLib, 'SetupDiInstallClassW', Result);\r\n @SetupDiInstallClass := GetModuleSymbolEx(SetupApiLib, 'SetupDiInstallClass' + NameSuffix, Result);\r\n @SetupDiInstallClassExA := GetModuleSymbolEx(SetupApiLib, 'SetupDiInstallClassExA', Result);\r\n @SetupDiInstallClassExW := GetModuleSymbolEx(SetupApiLib, 'SetupDiInstallClassExW', Result);\r\n @SetupDiInstallClassEx := GetModuleSymbolEx(SetupApiLib, 'SetupDiInstallClassEx' + NameSuffix, Result);\r\n @SetupDiOpenClassRegKey := GetModuleSymbolEx(SetupApiLib, 'SetupDiOpenClassRegKey', Result);\r\n @SetupDiOpenClassRegKeyExA := GetModuleSymbolEx(SetupApiLib, 'SetupDiOpenClassRegKeyExA', Result);\r\n @SetupDiOpenClassRegKeyExW := GetModuleSymbolEx(SetupApiLib, 'SetupDiOpenClassRegKeyExW', Result);\r\n @SetupDiOpenClassRegKeyEx := GetModuleSymbolEx(SetupApiLib, 'SetupDiOpenClassRegKeyEx' + NameSuffix, Result);\r\n @SetupDiCreateDeviceInterfaceRegKeyA := GetModuleSymbolEx(SetupApiLib, 'SetupDiCreateDeviceInterfaceRegKeyA', Result);\r\n @SetupDiCreateInterfaceDeviceRegKeyA := GetModuleSymbolEx(SetupApiLib, 'SetupDiCreateDeviceInterfaceRegKeyA', Result);\r\n @SetupDiCreateDeviceInterfaceRegKeyW := GetModuleSymbolEx(SetupApiLib, 'SetupDiCreateDeviceInterfaceRegKeyW', Result);\r\n @SetupDiCreateInterfaceDeviceRegKeyW := GetModuleSymbolEx(SetupApiLib, 'SetupDiCreateDeviceInterfaceRegKeyW', Result);\r\n @SetupDiCreateDeviceInterfaceRegKey := GetModuleSymbolEx(SetupApiLib, 'SetupDiCreateDeviceInterfaceRegKey' + NameSuffix, Result);\r\n @SetupDiCreateInterfaceDeviceRegKey := GetModuleSymbolEx(SetupApiLib, 'SetupDiCreateDeviceInterfaceRegKey' + NameSuffix, Result);\r\n @SetupDiOpenDeviceInterfaceRegKey := GetModuleSymbolEx(SetupApiLib, 'SetupDiOpenDeviceInterfaceRegKey', Result);\r\n @SetupDiOpenInterfaceDeviceRegKey := GetModuleSymbolEx(SetupApiLib, 'SetupDiOpenDeviceInterfaceRegKey', Result);\r\n @SetupDiDeleteDeviceInterfaceRegKey := GetModuleSymbolEx(SetupApiLib, 'SetupDiDeleteDeviceInterfaceRegKey', Result);\r\n @SetupDiDeleteInterfaceDeviceRegKey := GetModuleSymbolEx(SetupApiLib, 'SetupDiDeleteDeviceInterfaceRegKey', Result);\r\n @SetupDiCreateDevRegKeyA := GetModuleSymbolEx(SetupApiLib, 'SetupDiCreateDevRegKeyA', Result);\r\n @SetupDiCreateDevRegKeyW := GetModuleSymbolEx(SetupApiLib, 'SetupDiCreateDevRegKeyW', Result);\r\n @SetupDiCreateDevRegKey := GetModuleSymbolEx(SetupApiLib, 'SetupDiCreateDevRegKey' + NameSuffix, Result);\r\n @SetupDiOpenDevRegKey := GetModuleSymbolEx(SetupApiLib, 'SetupDiOpenDevRegKey', Result);\r\n @SetupDiDeleteDevRegKey := GetModuleSymbolEx(SetupApiLib, 'SetupDiDeleteDevRegKey', Result);\r\n @SetupDiGetHwProfileList := GetModuleSymbolEx(SetupApiLib, 'SetupDiGetHwProfileList', Result);\r\n @SetupDiGetHwProfileListExA := GetModuleSymbolEx(SetupApiLib, 'SetupDiGetHwProfileListExA', Result);\r\n @SetupDiGetHwProfileListExW := GetModuleSymbolEx(SetupApiLib, 'SetupDiGetHwProfileListExW', Result);\r\n @SetupDiGetHwProfileListEx := GetModuleSymbolEx(SetupApiLib, 'SetupDiGetHwProfileListEx' + NameSuffix, Result);\r\n @SetupDiGetDeviceRegistryPropertyA := GetModuleSymbolEx(SetupApiLib, 'SetupDiGetDeviceRegistryPropertyA', Result);\r\n @SetupDiGetDeviceRegistryPropertyW := GetModuleSymbolEx(SetupApiLib, 'SetupDiGetDeviceRegistryPropertyW', Result);\r\n @SetupDiGetDeviceRegistryProperty := GetModuleSymbolEx(SetupApiLib, 'SetupDiGetDeviceRegistryProperty' + NameSuffix, Result);\r\n {$IFDEF WINXP_UP}\r\n @SetupDiGetClassRegistryPropertyA := GetModuleSymbolEx(SetupApiLib, 'SetupDiGetClassRegistryPropertyA', Result);\r\n @SetupDiGetClassRegistryPropertyW := GetModuleSymbolEx(SetupApiLib, 'SetupDiGetClassRegistryPropertyW', Result);\r\n @SetupDiGetClassRegistryProperty := GetModuleSymbolEx(SetupApiLib, 'SetupDiGetClassRegistryProperty' + NameSuffix, Result);\r\n {$ENDIF WINXP_UP}\r\n @SetupDiSetDeviceRegistryPropertyA := GetModuleSymbolEx(SetupApiLib, 'SetupDiSetDeviceRegistryPropertyA', Result);\r\n @SetupDiSetDeviceRegistryPropertyW := GetModuleSymbolEx(SetupApiLib, 'SetupDiSetDeviceRegistryPropertyW', Result);\r\n @SetupDiSetDeviceRegistryProperty := GetModuleSymbolEx(SetupApiLib, 'SetupDiSetDeviceRegistryProperty' + NameSuffix, Result);\r\n {$IFDEF WINXP_UP}\r\n @SetupDiSetClassRegistryPropertyA := GetModuleSymbolEx(SetupApiLib, 'SetupDiSetClassRegistryPropertyA', Result);\r\n @SetupDiSetClassRegistryPropertyW := GetModuleSymbolEx(SetupApiLib, 'SetupDiSetClassRegistryPropertyW', Result);\r\n @SetupDiSetClassRegistryProperty := GetModuleSymbolEx(SetupApiLib, 'SetupDiSetClassRegistryProperty' + NameSuffix, Result);\r\n {$ENDIF WINXP_UP}\r\n @SetupDiGetDeviceInstallParamsA := GetModuleSymbolEx(SetupApiLib, 'SetupDiGetDeviceInstallParamsA', Result);\r\n @SetupDiGetDeviceInstallParamsW := GetModuleSymbolEx(SetupApiLib, 'SetupDiGetDeviceInstallParamsW', Result);\r\n @SetupDiGetDeviceInstallParams := GetModuleSymbolEx(SetupApiLib, 'SetupDiGetDeviceInstallParams' + NameSuffix, Result);\r\n @SetupDiGetClassInstallParamsA := GetModuleSymbolEx(SetupApiLib, 'SetupDiGetClassInstallParamsA', Result);\r\n @SetupDiGetClassInstallParamsW := GetModuleSymbolEx(SetupApiLib, 'SetupDiGetClassInstallParamsW', Result);\r\n @SetupDiGetClassInstallParams := GetModuleSymbolEx(SetupApiLib, 'SetupDiGetClassInstallParams' + NameSuffix, Result);\r\n @SetupDiSetDeviceInstallParamsA := GetModuleSymbolEx(SetupApiLib, 'SetupDiSetDeviceInstallParamsA', Result);\r\n @SetupDiSetDeviceInstallParamsW := GetModuleSymbolEx(SetupApiLib, 'SetupDiSetDeviceInstallParamsW', Result);\r\n @SetupDiSetDeviceInstallParams := GetModuleSymbolEx(SetupApiLib, 'SetupDiSetDeviceInstallParams' + NameSuffix, Result);\r\n @SetupDiSetClassInstallParamsA := GetModuleSymbolEx(SetupApiLib, 'SetupDiSetClassInstallParamsA', Result);\r\n @SetupDiSetClassInstallParamsW := GetModuleSymbolEx(SetupApiLib, 'SetupDiSetClassInstallParamsW', Result);\r\n @SetupDiSetClassInstallParams := GetModuleSymbolEx(SetupApiLib, 'SetupDiSetClassInstallParams' + NameSuffix, Result);\r\n @SetupDiGetDriverInstallParamsA := GetModuleSymbolEx(SetupApiLib, 'SetupDiGetDriverInstallParamsA', Result);\r\n @SetupDiGetDriverInstallParamsW := GetModuleSymbolEx(SetupApiLib, 'SetupDiGetDriverInstallParamsW', Result);\r\n @SetupDiGetDriverInstallParams := GetModuleSymbolEx(SetupApiLib, 'SetupDiGetDriverInstallParams' + NameSuffix, Result);\r\n @SetupDiSetDriverInstallParamsA := GetModuleSymbolEx(SetupApiLib, 'SetupDiSetDriverInstallParamsA', Result);\r\n @SetupDiSetDriverInstallParamsW := GetModuleSymbolEx(SetupApiLib, 'SetupDiSetDriverInstallParamsW', Result);\r\n @SetupDiSetDriverInstallParams := GetModuleSymbolEx(SetupApiLib, 'SetupDiSetDriverInstallParams' + NameSuffix, Result);\r\n @SetupDiLoadClassIcon := GetModuleSymbolEx(SetupApiLib, 'SetupDiLoadClassIcon', Result);\r\n @SetupDiDrawMiniIcon := GetModuleSymbolEx(SetupApiLib, 'SetupDiDrawMiniIcon', Result);\r\n @SetupDiGetClassBitmapIndex := GetModuleSymbolEx(SetupApiLib, 'SetupDiGetClassBitmapIndex', Result);\r\n @SetupDiGetClassImageList := GetModuleSymbolEx(SetupApiLib, 'SetupDiGetClassImageList', Result);\r\n @SetupDiGetClassImageListExA := GetModuleSymbolEx(SetupApiLib, 'SetupDiGetClassImageListExA', Result);\r\n @SetupDiGetClassImageListExW := GetModuleSymbolEx(SetupApiLib, 'SetupDiGetClassImageListExW', Result);\r\n @SetupDiGetClassImageListEx := GetModuleSymbolEx(SetupApiLib, 'SetupDiGetClassImageListEx' + NameSuffix, Result);\r\n @SetupDiGetClassImageIndex := GetModuleSymbolEx(SetupApiLib, 'SetupDiGetClassImageIndex', Result);\r\n @SetupDiDestroyClassImageList := GetModuleSymbolEx(SetupApiLib, 'SetupDiDestroyClassImageList', Result);\r\n @SetupDiGetClassDevPropertySheetsA := GetModuleSymbolEx(SetupApiLib, 'SetupDiGetClassDevPropertySheetsA', Result);\r\n @SetupDiGetClassDevPropertySheetsW := GetModuleSymbolEx(SetupApiLib, 'SetupDiGetClassDevPropertySheetsW', Result);\r\n @SetupDiGetClassDevPropertySheets := GetModuleSymbolEx(SetupApiLib, 'SetupDiGetClassDevPropertySheets' + NameSuffix, Result);\r\n @SetupDiAskForOEMDisk := GetModuleSymbolEx(SetupApiLib, 'SetupDiAskForOEMDisk', Result);\r\n @SetupDiSelectOEMDrv := GetModuleSymbolEx(SetupApiLib, 'SetupDiSelectOEMDrv', Result);\r\n @SetupDiClassNameFromGuidA := GetModuleSymbolEx(SetupApiLib, 'SetupDiClassNameFromGuidA', Result);\r\n @SetupDiClassNameFromGuidW := GetModuleSymbolEx(SetupApiLib, 'SetupDiClassNameFromGuidW', Result);\r\n @SetupDiClassNameFromGuid := GetModuleSymbolEx(SetupApiLib, 'SetupDiClassNameFromGuid' + NameSuffix, Result);\r\n @SetupDiClassNameFromGuidExA := GetModuleSymbolEx(SetupApiLib, 'SetupDiClassNameFromGuidExA', Result);\r\n @SetupDiClassNameFromGuidExW := GetModuleSymbolEx(SetupApiLib, 'SetupDiClassNameFromGuidExW', Result);\r\n @SetupDiClassNameFromGuidEx := GetModuleSymbolEx(SetupApiLib, 'SetupDiClassNameFromGuidEx' + NameSuffix, Result);\r\n @SetupDiClassGuidsFromNameA := GetModuleSymbolEx(SetupApiLib, 'SetupDiClassGuidsFromNameA', Result);\r\n @SetupDiClassGuidsFromNameW := GetModuleSymbolEx(SetupApiLib, 'SetupDiClassGuidsFromNameW', Result);\r\n @SetupDiClassGuidsFromName := GetModuleSymbolEx(SetupApiLib, 'SetupDiClassGuidsFromName' + NameSuffix, Result);\r\n @SetupDiClassGuidsFromNameExA := GetModuleSymbolEx(SetupApiLib, 'SetupDiClassGuidsFromNameExA', Result);\r\n @SetupDiClassGuidsFromNameExW := GetModuleSymbolEx(SetupApiLib, 'SetupDiClassGuidsFromNameExW', Result);\r\n @SetupDiClassGuidsFromNameEx := GetModuleSymbolEx(SetupApiLib, 'SetupDiClassGuidsFromNameEx' + NameSuffix, Result);\r\n @SetupDiGetHwProfileFriendlyNameA := GetModuleSymbolEx(SetupApiLib, 'SetupDiGetHwProfileFriendlyNameA', Result);\r\n @SetupDiGetHwProfileFriendlyNameW := GetModuleSymbolEx(SetupApiLib, 'SetupDiGetHwProfileFriendlyNameW', Result);\r\n @SetupDiGetHwProfileFriendlyName := GetModuleSymbolEx(SetupApiLib, 'SetupDiGetHwProfileFriendlyName' + NameSuffix, Result);\r\n @SetupDiGetHwProfileFriendlyNameExA := GetModuleSymbolEx(SetupApiLib, 'SetupDiGetHwProfileFriendlyNameExA', Result);\r\n @SetupDiGetHwProfileFriendlyNameExW := GetModuleSymbolEx(SetupApiLib, 'SetupDiGetHwProfileFriendlyNameExW', Result);\r\n @SetupDiGetHwProfileFriendlyNameEx := GetModuleSymbolEx(SetupApiLib, 'SetupDiGetHwProfileFriendlyNameEx' + NameSuffix, Result);\r\n @SetupDiGetWizardPage := GetModuleSymbolEx(SetupApiLib, 'SetupDiGetWizardPage', Result);\r\n @SetupDiGetSelectedDevice := GetModuleSymbolEx(SetupApiLib, 'SetupDiGetSelectedDevice', Result);\r\n @SetupDiSetSelectedDevice := GetModuleSymbolEx(SetupApiLib, 'SetupDiSetSelectedDevice', Result);\r\n @SetupDiGetActualSectionToInstallA := GetModuleSymbolEx(SetupApiLib, 'SetupDiGetActualSectionToInstallA', Result);\r\n @SetupDiGetActualSectionToInstallW := GetModuleSymbolEx(SetupApiLib, 'SetupDiGetActualSectionToInstallW', Result);\r\n @SetupDiGetActualSectionToInstall := GetModuleSymbolEx(SetupApiLib, 'SetupDiGetActualSectionToInstall' + NameSuffix, Result);\r\n {$IFDEF WINXP_UP}\r\n @SetupDiGetActualSectionToInstallExA := GetModuleSymbolEx(SetupApiLib, 'SetupDiGetActualSectionToInstallExA', Result);\r\n @SetupDiGetActualSectionToInstallExW := GetModuleSymbolEx(SetupApiLib, 'SetupDiGetActualSectionToInstallExW', Result);\r\n @SetupDiGetActualSectionToInstallEx := GetModuleSymbolEx(SetupApiLib, 'SetupDiGetActualSectionToInstallEx' + NameSuffix, Result);\r\n @SetupEnumInfSectionsA := GetModuleSymbolEx(SetupApiLib, 'SetupEnumInfSectionsA', Result);\r\n @SetupEnumInfSectionsW := GetModuleSymbolEx(SetupApiLib, 'SetupEnumInfSectionsW', Result);\r\n @SetupEnumInfSections := GetModuleSymbolEx(SetupApiLib, 'SetupEnumInfSections' + NameSuffix, Result);\r\n @SetupVerifyInfFileA := GetModuleSymbolEx(SetupApiLib, 'SetupVerifyInfFileA', Result);\r\n @SetupVerifyInfFileW := GetModuleSymbolEx(SetupApiLib, 'SetupVerifyInfFileW', Result);\r\n @SetupVerifyInfFile := GetModuleSymbolEx(SetupApiLib, 'SetupVerifyInfFile' + NameSuffix, Result);\r\n @SetupDiGetCustomDevicePropertyA := GetModuleSymbolEx(SetupApiLib, 'SetupDiGetCustomDevicePropertyA', Result);\r\n @SetupDiGetCustomDevicePropertyW := GetModuleSymbolEx(SetupApiLib, 'SetupDiGetCustomDevicePropertyW', Result);\r\n @SetupDiGetCustomDeviceProperty := GetModuleSymbolEx(SetupApiLib, 'SetupDiGetCustomDeviceProperty' + NameSuffix, Result);\r\n {$ENDIF WINXP_UP}\r\n if not Result then\r\n UnloadSetupApi;\r\n end;\r\n {$ELSE}\r\n Result := True;\r\n {$ENDIF SETUPAPI_LINKONREQUEST}\r\nend;\r\n\r\nprocedure UnloadSetupApi;\r\nbegin\r\n {$IFDEF SETUPAPI_LINKONREQUEST}\r\n Dec(SetupApiLoadCount);\r\n if SetupApiLoadCount > 0 then\r\n Exit;\r\n ModuleLoader.UnloadModule(SetupApiLib);\r\n {$IFDEF WINXP_UP}\r\n SetupGetFileQueueCount := nil;\r\n SetupGetFileQueueFlags := nil;\r\n SetupSetFileQueueFlags := nil;\r\n {$ENDIF WINXP_UP}\r\n SetupGetInfInformationA := nil;\r\n SetupGetInfInformationW := nil;\r\n SetupGetInfInformation := nil;\r\n SetupQueryInfFileInformationA := nil;\r\n SetupQueryInfFileInformationW := nil;\r\n SetupQueryInfFileInformation := nil;\r\n {$IFDEF WIN2000_UP}\r\n SetupQueryInfOriginalFileInformationA := nil;\r\n SetupQueryInfOriginalFileInformationW := nil;\r\n SetupQueryInfOriginalFileInformation := nil;\r\n {$ENDIF WIN2000_UP}\r\n SetupQueryInfVersionInformationA := nil;\r\n SetupQueryInfVersionInformationW := nil;\r\n SetupQueryInfVersionInformation := nil;\r\n SetupGetInfFileListA := nil;\r\n SetupGetInfFileListW := nil;\r\n SetupGetInfFileList := nil;\r\n SetupOpenInfFileA := nil;\r\n SetupOpenInfFileW := nil;\r\n SetupOpenInfFile := nil;\r\n SetupOpenMasterInf := nil;\r\n SetupOpenAppendInfFileA := nil;\r\n SetupOpenAppendInfFileW := nil;\r\n SetupOpenAppendInfFile := nil;\r\n SetupCloseInfFile := nil;\r\n SetupFindFirstLineA := nil;\r\n SetupFindFirstLineW := nil;\r\n SetupFindFirstLine := nil;\r\n SetupFindNextLine := nil;\r\n SetupFindNextMatchLineA := nil;\r\n SetupFindNextMatchLineW := nil;\r\n SetupFindNextMatchLine := nil;\r\n SetupGetLineByIndexA := nil;\r\n SetupGetLineByIndexW := nil;\r\n SetupGetLineByIndex := nil;\r\n SetupGetLineCountA := nil;\r\n SetupGetLineCountW := nil;\r\n SetupGetLineCount := nil;\r\n SetupGetLineTextA := nil;\r\n SetupGetLineTextW := nil;\r\n SetupGetLineText := nil;\r\n SetupGetFieldCount := nil;\r\n SetupGetStringFieldA := nil;\r\n SetupGetStringFieldW := nil;\r\n SetupGetStringField := nil;\r\n SetupGetIntField := nil;\r\n SetupGetMultiSzFieldA := nil;\r\n SetupGetMultiSzFieldW := nil;\r\n SetupGetMultiSzField := nil;\r\n SetupGetBinaryField := nil;\r\n SetupGetFileCompressionInfoA := nil;\r\n SetupGetFileCompressionInfoW := nil;\r\n SetupGetFileCompressionInfo := nil;\r\n {$IFDEF WINXP_UP}\r\n SetupGetFileCompressionInfoExA := nil;\r\n SetupGetFileCompressionInfoExW := nil;\r\n SetupGetFileCompressionInfoEx := nil;\r\n {$ENDIF WINXP_UP}\r\n SetupDecompressOrCopyFileA := nil;\r\n SetupDecompressOrCopyFileW := nil;\r\n SetupDecompressOrCopyFile := nil;\r\n SetupGetSourceFileLocationA := nil;\r\n SetupGetSourceFileLocationW := nil;\r\n SetupGetSourceFileLocation := nil;\r\n SetupGetSourceFileSizeA := nil;\r\n SetupGetSourceFileSizeW := nil;\r\n SetupGetSourceFileSize := nil;\r\n SetupGetTargetPathA := nil;\r\n SetupGetTargetPathW := nil;\r\n SetupGetTargetPath := nil;\r\n SetupSetSourceListA := nil;\r\n SetupSetSourceListW := nil;\r\n SetupSetSourceList := nil;\r\n SetupCancelTemporarySourceList := nil;\r\n SetupAddToSourceListA := nil;\r\n SetupAddToSourceListW := nil;\r\n SetupAddToSourceList := nil;\r\n SetupRemoveFromSourceListA := nil;\r\n SetupRemoveFromSourceListW := nil;\r\n SetupRemoveFromSourceList := nil;\r\n SetupQuerySourceListA := nil;\r\n SetupQuerySourceListW := nil;\r\n SetupQuerySourceList := nil;\r\n SetupFreeSourceListA := nil;\r\n SetupFreeSourceListW := nil;\r\n SetupFreeSourceList := nil;\r\n SetupPromptForDiskA := nil;\r\n SetupPromptForDiskW := nil;\r\n SetupPromptForDisk := nil;\r\n SetupCopyErrorA := nil;\r\n SetupCopyErrorW := nil;\r\n SetupCopyError := nil;\r\n SetupRenameErrorA := nil;\r\n SetupRenameErrorW := nil;\r\n SetupRenameError := nil;\r\n SetupDeleteErrorA := nil;\r\n SetupDeleteErrorW := nil;\r\n SetupDeleteError := nil;\r\n {$IFDEF WIN2000_UP}\r\n SetupBackupErrorA := nil;\r\n SetupBackupErrorW := nil;\r\n SetupBackupError := nil;\r\n {$ENDIF WIN2000_UP}\r\n SetupSetDirectoryIdA := nil;\r\n SetupSetDirectoryIdW := nil;\r\n SetupSetDirectoryId := nil;\r\n SetupSetDirectoryIdExA := nil;\r\n SetupSetDirectoryIdExW := nil;\r\n SetupSetDirectoryIdEx := nil;\r\n SetupGetSourceInfoA := nil;\r\n SetupGetSourceInfoW := nil;\r\n SetupGetSourceInfo := nil;\r\n SetupInstallFileA := nil;\r\n SetupInstallFileW := nil;\r\n SetupInstallFile := nil;\r\n SetupInstallFileExA := nil;\r\n SetupInstallFileExW := nil;\r\n SetupInstallFileEx := nil;\r\n SetupOpenFileQueue := nil;\r\n SetupCloseFileQueue := nil;\r\n {$IFDEF WIN2000_UP}\r\n SetupSetFileQueueAlternatePlatformA := nil;\r\n SetupSetFileQueueAlternatePlatformW := nil;\r\n SetupSetFileQueueAlternatePlatform := nil;\r\n {$ENDIF WIN2000_UP}\r\n SetupSetPlatformPathOverrideA := nil;\r\n SetupSetPlatformPathOverrideW := nil;\r\n SetupSetPlatformPathOverride := nil;\r\n SetupQueueCopyA := nil;\r\n SetupQueueCopyW := nil;\r\n SetupQueueCopy := nil;\r\n {$IFDEF WIN2000_UP}\r\n SetupQueueCopyIndirectA := nil;\r\n SetupQueueCopyIndirectW := nil;\r\n SetupQueueCopyIndirect := nil;\r\n {$ENDIF WIN2000_UP}\r\n SetupQueueDefaultCopyA := nil;\r\n SetupQueueDefaultCopyW := nil;\r\n SetupQueueDefaultCopy := nil;\r\n SetupQueueCopySectionA := nil;\r\n SetupQueueCopySectionW := nil;\r\n SetupQueueCopySection := nil;\r\n SetupQueueDeleteA := nil;\r\n SetupQueueDeleteW := nil;\r\n SetupQueueDelete := nil;\r\n SetupQueueDeleteSectionA := nil;\r\n SetupQueueDeleteSectionW := nil;\r\n SetupQueueDeleteSection := nil;\r\n SetupQueueRenameA := nil;\r\n SetupQueueRenameW := nil;\r\n SetupQueueRename := nil;\r\n SetupQueueRenameSectionA := nil;\r\n SetupQueueRenameSectionW := nil;\r\n SetupQueueRenameSection := nil;\r\n SetupCommitFileQueueA := nil;\r\n SetupCommitFileQueueW := nil;\r\n SetupCommitFileQueue := nil;\r\n SetupScanFileQueueA := nil;\r\n SetupScanFileQueueW := nil;\r\n SetupScanFileQueue := nil;\r\n SetupCopyOEMInfA := nil;\r\n SetupCopyOEMInfW := nil;\r\n SetupCopyOEMInf := nil;\r\n {$IFDEF WINXP_UP}\r\n SetupUninstallOEMInfA := nil;\r\n SetupUninstallOEMInfW := nil;\r\n SetupUninstallOEMInf := nil;\r\n SetupUninstallNewlyCopiedInfs := nil;\r\n {$ENDIF WINXP_UP}\r\n SetupCreateDiskSpaceListA := nil;\r\n SetupCreateDiskSpaceListW := nil;\r\n SetupCreateDiskSpaceList := nil;\r\n SetupDuplicateDiskSpaceListA := nil;\r\n SetupDuplicateDiskSpaceListW := nil;\r\n SetupDuplicateDiskSpaceList := nil;\r\n SetupDestroyDiskSpaceList := nil;\r\n SetupQueryDrivesInDiskSpaceListA := nil;\r\n SetupQueryDrivesInDiskSpaceListW := nil;\r\n SetupQueryDrivesInDiskSpaceList := nil;\r\n SetupQuerySpaceRequiredOnDriveA := nil;\r\n SetupQuerySpaceRequiredOnDriveW := nil;\r\n SetupQuerySpaceRequiredOnDrive := nil;\r\n SetupAdjustDiskSpaceListA := nil;\r\n SetupAdjustDiskSpaceListW := nil;\r\n SetupAdjustDiskSpaceList := nil;\r\n SetupAddToDiskSpaceListA := nil;\r\n SetupAddToDiskSpaceListW := nil;\r\n SetupAddToDiskSpaceList := nil;\r\n SetupAddSectionToDiskSpaceListA := nil;\r\n SetupAddSectionToDiskSpaceListW := nil;\r\n SetupAddSectionToDiskSpaceList := nil;\r\n SetupAddInstallSectionToDiskSpaceListA := nil;\r\n SetupAddInstallSectionToDiskSpaceListW := nil;\r\n SetupAddInstallSectionToDiskSpaceList := nil;\r\n SetupRemoveFromDiskSpaceListA := nil;\r\n SetupRemoveFromDiskSpaceListW := nil;\r\n SetupRemoveFromDiskSpaceList := nil;\r\n SetupRemoveSectionFromDiskSpaceListA := nil;\r\n SetupRemoveSectionFromDiskSpaceListW := nil;\r\n SetupRemoveSectionFromDiskSpaceList := nil;\r\n SetupRemoveInstallSectionFromDiskSpaceListA := nil;\r\n SetupRemoveInstallSectionFromDiskSpaceListW := nil;\r\n SetupRemoveInstallSectionFromDiskSpaceList := nil;\r\n SetupIterateCabinetA := nil;\r\n SetupIterateCabinetW := nil;\r\n SetupIterateCabinet := nil;\r\n SetupPromptReboot := nil;\r\n SetupInitDefaultQueueCallback := nil;\r\n SetupInitDefaultQueueCallbackEx := nil;\r\n SetupTermDefaultQueueCallback := nil;\r\n SetupDefaultQueueCallbackA := nil;\r\n SetupDefaultQueueCallbackW := nil;\r\n SetupDefaultQueueCallback := nil;\r\n SetupInstallFromInfSectionA := nil;\r\n SetupInstallFromInfSectionW := nil;\r\n SetupInstallFromInfSection := nil;\r\n SetupInstallFilesFromInfSectionA := nil;\r\n SetupInstallFilesFromInfSectionW := nil;\r\n SetupInstallFilesFromInfSection := nil;\r\n SetupInstallServicesFromInfSectionA := nil;\r\n SetupInstallServicesFromInfSectionW := nil;\r\n SetupInstallServicesFromInfSection := nil;\r\n SetupInstallServicesFromInfSectionExA := nil;\r\n SetupInstallServicesFromInfSectionExW := nil;\r\n SetupInstallServicesFromInfSectionEx := nil;\r\n {$IFDEF WINXP_UP}\r\n InstallHinfSectionA := nil;\r\n InstallHinfSectionW := nil;\r\n InstallHinfSection := nil;\r\n {$ENDIF WINXP_UP}\r\n SetupInitializeFileLogA := nil;\r\n SetupInitializeFileLogW := nil;\r\n SetupInitializeFileLog := nil;\r\n SetupTerminateFileLog := nil;\r\n SetupLogFileA := nil;\r\n SetupLogFileW := nil;\r\n SetupLogFile := nil;\r\n SetupRemoveFileLogEntryA := nil;\r\n SetupRemoveFileLogEntryW := nil;\r\n SetupRemoveFileLogEntry := nil;\r\n SetupQueryFileLogA := nil;\r\n SetupQueryFileLogW := nil;\r\n SetupQueryFileLog := nil;\r\n SetupOpenLog := nil;\r\n SetupLogErrorA := nil;\r\n SetupLogErrorW := nil;\r\n SetupLogError := nil;\r\n SetupCloseLog := nil;\r\n {$IFDEF WIN2000_UP}\r\n SetupGetBackupInformationA := nil;\r\n SetupGetBackupInformationW := nil;\r\n SetupGetBackupInformation := nil;\r\n {$ENDIF WIN2000_UP}\r\n {$IFDEF WINXP_UP}\r\n SetupPrepareQueueForRestoreA := nil;\r\n SetupPrepareQueueForRestoreW := nil;\r\n SetupPrepareQueueForRestore := nil;\r\n SetupSetNonInteractiveMode := nil;\r\n SetupGetNonInteractiveMode := nil;\r\n {$ENDIF WINXP_UP}\r\n SetupDiCreateDeviceInfoList := nil;\r\n SetupDiCreateDeviceInfoListExA := nil;\r\n SetupDiCreateDeviceInfoListExW := nil;\r\n SetupDiCreateDeviceInfoListEx := nil;\r\n SetupDiGetDeviceInfoListClass := nil;\r\n SetupDiGetDeviceInfoListDetailA := nil;\r\n SetupDiGetDeviceInfoListDetailW := nil;\r\n SetupDiGetDeviceInfoListDetail := nil;\r\n SetupDiCreateDeviceInfoA := nil;\r\n SetupDiCreateDeviceInfoW := nil;\r\n SetupDiCreateDeviceInfo := nil;\r\n SetupDiOpenDeviceInfoA := nil;\r\n SetupDiOpenDeviceInfoW := nil;\r\n SetupDiOpenDeviceInfo := nil;\r\n SetupDiGetDeviceInstanceIdA := nil;\r\n SetupDiGetDeviceInstanceIdW := nil;\r\n SetupDiGetDeviceInstanceId := nil;\r\n SetupDiDeleteDeviceInfo := nil;\r\n SetupDiEnumDeviceInfo := nil;\r\n SetupDiDestroyDeviceInfoList := nil;\r\n SetupDiEnumDeviceInterfaces := nil;\r\n SetupDiEnumInterfaceDevice := nil;\r\n SetupDiCreateDeviceInterfaceA := nil;\r\n SetupDiCreateInterfaceDeviceA := nil;\r\n SetupDiCreateDeviceInterfaceW := nil;\r\n SetupDiCreateInterfaceDeviceW := nil;\r\n SetupDiCreateDeviceInterface := nil;\r\n SetupDiCreateInterfaceDevice := nil;\r\n SetupDiOpenDeviceInterfaceA := nil;\r\n SetupDiOpenInterfaceDeviceA := nil;\r\n SetupDiOpenDeviceInterfaceW := nil;\r\n SetupDiOpenInterfaceDeviceW := nil;\r\n SetupDiOpenDeviceInterface := nil;\r\n SetupDiOpenInterfaceDevice := nil;\r\n SetupDiGetDeviceInterfaceAlias := nil;\r\n SetupDiGetInterfaceDeviceAlias := nil;\r\n SetupDiDeleteDeviceInterfaceData := nil;\r\n SetupDiDeleteInterfaceDeviceData := nil;\r\n SetupDiRemoveDeviceInterface := nil;\r\n SetupDiRemoveInterfaceDevice := nil;\r\n SetupDiGetDeviceInterfaceDetailA := nil;\r\n SetupDiGetInterfaceDeviceDetailA := nil;\r\n SetupDiGetDeviceInterfaceDetailW := nil;\r\n SetupDiGetInterfaceDeviceDetailW := nil;\r\n SetupDiGetDeviceInterfaceDetail := nil;\r\n SetupDiGetInterfaceDeviceDetail := nil;\r\n SetupDiInstallDeviceInterfaces := nil;\r\n SetupDiInstallInterfaceDevices := nil;\r\n {$IFDEF WINXP_UP}\r\n SetupDiSetDeviceInterfaceDefault := nil;\r\n {$ENDIF WINXP_UP}\r\n SetupDiRegisterDeviceInfo := nil;\r\n SetupDiBuildDriverInfoList := nil;\r\n SetupDiCancelDriverInfoSearch := nil;\r\n SetupDiEnumDriverInfoA := nil;\r\n SetupDiEnumDriverInfoW := nil;\r\n SetupDiEnumDriverInfo := nil;\r\n SetupDiGetSelectedDriverA := nil;\r\n SetupDiGetSelectedDriverW := nil;\r\n SetupDiGetSelectedDriver := nil;\r\n SetupDiSetSelectedDriverA := nil;\r\n SetupDiSetSelectedDriverW := nil;\r\n SetupDiSetSelectedDriver := nil;\r\n SetupDiGetDriverInfoDetailA := nil;\r\n SetupDiGetDriverInfoDetailW := nil;\r\n SetupDiGetDriverInfoDetail := nil;\r\n SetupDiDestroyDriverInfoList := nil;\r\n SetupDiGetClassDevsA := nil;\r\n SetupDiGetClassDevsW := nil;\r\n SetupDiGetClassDevs := nil;\r\n SetupDiGetClassDevsExA := nil;\r\n SetupDiGetClassDevsExW := nil;\r\n SetupDiGetClassDevsEx := nil;\r\n SetupDiGetINFClassA := nil;\r\n SetupDiGetINFClassW := nil;\r\n SetupDiGetINFClass := nil;\r\n SetupDiBuildClassInfoList := nil;\r\n SetupDiBuildClassInfoListExA := nil;\r\n SetupDiBuildClassInfoListExW := nil;\r\n SetupDiBuildClassInfoListEx := nil;\r\n SetupDiGetClassDescriptionA := nil;\r\n SetupDiGetClassDescriptionW := nil;\r\n SetupDiGetClassDescription := nil;\r\n SetupDiGetClassDescriptionExA := nil;\r\n SetupDiGetClassDescriptionExW := nil;\r\n SetupDiGetClassDescriptionEx := nil;\r\n SetupDiCallClassInstaller := nil;\r\n SetupDiSelectDevice := nil;\r\n SetupDiSelectBestCompatDrv := nil;\r\n SetupDiInstallDevice := nil;\r\n SetupDiInstallDriverFiles := nil;\r\n SetupDiRegisterCoDeviceInstallers := nil;\r\n SetupDiRemoveDevice := nil;\r\n SetupDiUnremoveDevice := nil;\r\n SetupDiMoveDuplicateDevice := nil;\r\n SetupDiChangeState := nil;\r\n SetupDiInstallClassA := nil;\r\n SetupDiInstallClassW := nil;\r\n SetupDiInstallClass := nil;\r\n SetupDiInstallClassExA := nil;\r\n SetupDiInstallClassExW := nil;\r\n SetupDiInstallClassEx := nil;\r\n SetupDiOpenClassRegKey := nil;\r\n SetupDiOpenClassRegKeyExA := nil;\r\n SetupDiOpenClassRegKeyExW := nil;\r\n SetupDiOpenClassRegKeyEx := nil;\r\n SetupDiCreateDeviceInterfaceRegKeyA := nil;\r\n SetupDiCreateInterfaceDeviceRegKeyA := nil;\r\n SetupDiCreateDeviceInterfaceRegKeyW := nil;\r\n SetupDiCreateInterfaceDeviceRegKeyW := nil;\r\n SetupDiCreateDeviceInterfaceRegKey := nil;\r\n SetupDiCreateInterfaceDeviceRegKey := nil;\r\n SetupDiOpenDeviceInterfaceRegKey := nil;\r\n SetupDiOpenInterfaceDeviceRegKey := nil;\r\n SetupDiDeleteDeviceInterfaceRegKey := nil;\r\n SetupDiDeleteInterfaceDeviceRegKey := nil;\r\n SetupDiCreateDevRegKeyA := nil;\r\n SetupDiCreateDevRegKeyW := nil;\r\n SetupDiCreateDevRegKey := nil;\r\n SetupDiOpenDevRegKey := nil;\r\n SetupDiDeleteDevRegKey := nil;\r\n SetupDiGetHwProfileList := nil;\r\n SetupDiGetHwProfileListExA := nil;\r\n SetupDiGetHwProfileListExW := nil;\r\n SetupDiGetHwProfileListEx := nil;\r\n SetupDiGetDeviceRegistryPropertyA := nil;\r\n SetupDiGetDeviceRegistryPropertyW := nil;\r\n SetupDiGetDeviceRegistryProperty := nil;\r\n {$IFDEF WINXP_UP}\r\n SetupDiGetClassRegistryPropertyA := nil;\r\n SetupDiGetClassRegistryPropertyW := nil;\r\n SetupDiGetClassRegistryProperty := nil;\r\n {$ENDIF WINXP_UP}\r\n SetupDiSetDeviceRegistryPropertyA := nil;\r\n SetupDiSetDeviceRegistryPropertyW := nil;\r\n SetupDiSetDeviceRegistryProperty := nil;\r\n {$IFDEF WINXP_UP}\r\n SetupDiSetClassRegistryPropertyA := nil;\r\n SetupDiSetClassRegistryPropertyW := nil;\r\n SetupDiSetClassRegistryProperty := nil;\r\n {$ENDIF WINXP_UP}\r\n SetupDiGetDeviceInstallParamsA := nil;\r\n SetupDiGetDeviceInstallParamsW := nil;\r\n SetupDiGetDeviceInstallParams := nil;\r\n SetupDiGetClassInstallParamsA := nil;\r\n SetupDiGetClassInstallParamsW := nil;\r\n SetupDiGetClassInstallParams := nil;\r\n SetupDiSetDeviceInstallParamsA := nil;\r\n SetupDiSetDeviceInstallParamsW := nil;\r\n SetupDiSetDeviceInstallParams := nil;\r\n SetupDiSetClassInstallParamsA := nil;\r\n SetupDiSetClassInstallParamsW := nil;\r\n SetupDiSetClassInstallParams := nil;\r\n SetupDiGetDriverInstallParamsA := nil;\r\n SetupDiGetDriverInstallParamsW := nil;\r\n SetupDiGetDriverInstallParams := nil;\r\n SetupDiSetDriverInstallParamsA := nil;\r\n SetupDiSetDriverInstallParamsW := nil;\r\n SetupDiSetDriverInstallParams := nil;\r\n SetupDiLoadClassIcon := nil;\r\n SetupDiDrawMiniIcon := nil;\r\n SetupDiGetClassBitmapIndex := nil;\r\n SetupDiGetClassImageList := nil;\r\n SetupDiGetClassImageListExA := nil;\r\n SetupDiGetClassImageListExW := nil;\r\n SetupDiGetClassImageListEx := nil;\r\n SetupDiGetClassImageIndex := nil;\r\n SetupDiDestroyClassImageList := nil;\r\n SetupDiGetClassDevPropertySheetsA := nil;\r\n SetupDiGetClassDevPropertySheetsW := nil;\r\n SetupDiGetClassDevPropertySheets := nil;\r\n SetupDiAskForOEMDisk := nil;\r\n SetupDiSelectOEMDrv := nil;\r\n SetupDiClassNameFromGuidA := nil;\r\n SetupDiClassNameFromGuidW := nil;\r\n SetupDiClassNameFromGuid := nil;\r\n SetupDiClassNameFromGuidExA := nil;\r\n SetupDiClassNameFromGuidExW := nil;\r\n SetupDiClassNameFromGuidEx := nil;\r\n SetupDiClassGuidsFromNameA := nil;\r\n SetupDiClassGuidsFromNameW := nil;\r\n SetupDiClassGuidsFromName := nil;\r\n SetupDiClassGuidsFromNameExA := nil;\r\n SetupDiClassGuidsFromNameExW := nil;\r\n SetupDiClassGuidsFromNameEx := nil;\r\n SetupDiGetHwProfileFriendlyNameA := nil;\r\n SetupDiGetHwProfileFriendlyNameW := nil;\r\n SetupDiGetHwProfileFriendlyName := nil;\r\n SetupDiGetHwProfileFriendlyNameExA := nil;\r\n SetupDiGetHwProfileFriendlyNameExW := nil;\r\n SetupDiGetHwProfileFriendlyNameEx := nil;\r\n SetupDiGetWizardPage := nil;\r\n SetupDiGetSelectedDevice := nil;\r\n SetupDiSetSelectedDevice := nil;\r\n SetupDiGetActualSectionToInstallA := nil;\r\n SetupDiGetActualSectionToInstallW := nil;\r\n SetupDiGetActualSectionToInstall := nil;\r\n {$IFDEF WINXP_UP}\r\n SetupDiGetActualSectionToInstallExA := nil;\r\n SetupDiGetActualSectionToInstallExW := nil;\r\n SetupDiGetActualSectionToInstallEx := nil;\r\n SetupEnumInfSectionsA := nil;\r\n SetupEnumInfSectionsW := nil;\r\n SetupEnumInfSections := nil;\r\n SetupVerifyInfFileA := nil;\r\n SetupVerifyInfFileW := nil;\r\n SetupVerifyInfFile := nil;\r\n SetupDiGetCustomDevicePropertyA := nil;\r\n SetupDiGetCustomDevicePropertyW := nil;\r\n SetupDiGetCustomDeviceProperty := nil;\r\n {$ENDIF WINXP_UP}\r\n {$ENDIF SETUPAPI_LINKONREQUEST}\r\nend;\r\n\r\n{$IFNDEF SETUPAPI_LINKONREQUEST}\r\n\r\n{$IFDEF WINXP_UP}\r\nfunction SetupGetFileQueueCount; external SetupApiModuleName name 'SetupGetFileQueueCount';\r\nfunction SetupGetFileQueueFlags; external SetupApiModuleName name 'SetupGetFileQueueFlags';\r\nfunction SetupSetFileQueueFlags; external SetupApiModuleName name 'SetupSetFileQueueFlags';\r\n{$ENDIF WINXP_UP}\r\nfunction SetupGetInfInformationA; external SetupApiModuleName name 'SetupGetInfInformationA';\r\nfunction SetupGetInfInformationW; external SetupApiModuleName name 'SetupGetInfInformationW';\r\nfunction SetupGetInfInformation; external SetupApiModuleName name 'SetupGetInfInformation' + NameSuffix;\r\nfunction SetupQueryInfFileInformationA; external SetupApiModuleName name 'SetupQueryInfFileInformationA';\r\nfunction SetupQueryInfFileInformationW; external SetupApiModuleName name 'SetupQueryInfFileInformationW';\r\nfunction SetupQueryInfFileInformation; external SetupApiModuleName name 'SetupQueryInfFileInformation' + NameSuffix;\r\n{$IFDEF WIN2000_UP}\r\nfunction SetupQueryInfOriginalFileInformationA; external SetupApiModuleName name 'SetupQueryInfOriginalFileInformationA';\r\nfunction SetupQueryInfOriginalFileInformationW; external SetupApiModuleName name 'SetupQueryInfOriginalFileInformationW';\r\nfunction SetupQueryInfOriginalFileInformation; external SetupApiModuleName name 'SetupQueryInfOriginalFileInformation' + NameSuffix;\r\n{$ENDIF WIN2000_UP}\r\nfunction SetupQueryInfVersionInformationA; external SetupApiModuleName name 'SetupQueryInfVersionInformationA';\r\nfunction SetupQueryInfVersionInformationW; external SetupApiModuleName name 'SetupQueryInfVersionInformationW';\r\nfunction SetupQueryInfVersionInformation; external SetupApiModuleName name 'SetupQueryInfVersionInformation' + NameSuffix;\r\nfunction SetupGetInfFileListA; external SetupApiModuleName name 'SetupGetInfFileListA';\r\nfunction SetupGetInfFileListW; external SetupApiModuleName name 'SetupGetInfFileListW';\r\nfunction SetupGetInfFileList; external SetupApiModuleName name 'SetupGetInfFileList' + NameSuffix;\r\nfunction SetupOpenInfFileA; external SetupApiModuleName name 'SetupOpenInfFileA';\r\nfunction SetupOpenInfFileW; external SetupApiModuleName name 'SetupOpenInfFileW';\r\nfunction SetupOpenInfFile; external SetupApiModuleName name 'SetupOpenInfFile' + NameSuffix;\r\nfunction SetupOpenMasterInf; external SetupApiModuleName name 'SetupOpenMasterInf';\r\nfunction SetupOpenAppendInfFileA; external SetupApiModuleName name 'SetupOpenAppendInfFileA';\r\nfunction SetupOpenAppendInfFileW; external SetupApiModuleName name 'SetupOpenAppendInfFileW';\r\nfunction SetupOpenAppendInfFile; external SetupApiModuleName name 'SetupOpenAppendInfFile' + NameSuffix;\r\nprocedure SetupCloseInfFile; external SetupApiModuleName name 'SetupCloseInfFile';\r\nfunction SetupFindFirstLineA; external SetupApiModuleName name 'SetupFindFirstLineA';\r\nfunction SetupFindFirstLineW; external SetupApiModuleName name 'SetupFindFirstLineW';\r\nfunction SetupFindFirstLine; external SetupApiModuleName name 'SetupFindFirstLine' + NameSuffix;\r\nfunction SetupFindNextLine; external SetupApiModuleName name 'SetupFindNextLine';\r\nfunction SetupFindNextMatchLineA; external SetupApiModuleName name 'SetupFindNextMatchLineA';\r\nfunction SetupFindNextMatchLineW; external SetupApiModuleName name 'SetupFindNextMatchLineW';\r\nfunction SetupFindNextMatchLine; external SetupApiModuleName name 'SetupFindNextMatchLine' + NameSuffix;\r\nfunction SetupGetLineByIndexA; external SetupApiModuleName name 'SetupGetLineByIndexA';\r\nfunction SetupGetLineByIndexW; external SetupApiModuleName name 'SetupGetLineByIndexW';\r\nfunction SetupGetLineByIndex; external SetupApiModuleName name 'SetupGetLineByIndex' + NameSuffix;\r\nfunction SetupGetLineCountA; external SetupApiModuleName name 'SetupGetLineCountA';\r\nfunction SetupGetLineCountW; external SetupApiModuleName name 'SetupGetLineCountW';\r\nfunction SetupGetLineCount; external SetupApiModuleName name 'SetupGetLineCount' + NameSuffix;\r\nfunction SetupGetLineTextA; external SetupApiModuleName name 'SetupGetLineTextA';\r\nfunction SetupGetLineTextW; external SetupApiModuleName name 'SetupGetLineTextW';\r\nfunction SetupGetLineText; external SetupApiModuleName name 'SetupGetLineText' + NameSuffix;\r\nfunction SetupGetFieldCount; external SetupApiModuleName name 'SetupGetFieldCount';\r\nfunction SetupGetStringFieldA; external SetupApiModuleName name 'SetupGetStringFieldA';\r\nfunction SetupGetStringFieldW; external SetupApiModuleName name 'SetupGetStringFieldW';\r\nfunction SetupGetStringField; external SetupApiModuleName name 'SetupGetStringField' + NameSuffix;\r\nfunction SetupGetIntField; external SetupApiModuleName name 'SetupGetIntField';\r\nfunction SetupGetMultiSzFieldA; external SetupApiModuleName name 'SetupGetMultiSzFieldA';\r\nfunction SetupGetMultiSzFieldW; external SetupApiModuleName name 'SetupGetMultiSzFieldW';\r\nfunction SetupGetMultiSzField; external SetupApiModuleName name 'SetupGetMultiSzField' + NameSuffix;\r\nfunction SetupGetBinaryField; external SetupApiModuleName name 'SetupGetBinaryField';\r\nfunction SetupGetFileCompressionInfoA; external SetupApiModuleName name 'SetupGetFileCompressionInfoA';\r\nfunction SetupGetFileCompressionInfoW; external SetupApiModuleName name 'SetupGetFileCompressionInfoW';\r\nfunction SetupGetFileCompressionInfo; external SetupApiModuleName name 'SetupGetFileCompressionInfo' + NameSuffix;\r\n{$IFDEF WINXP_UP}\r\nfunction SetupGetFileCompressionInfoExA; external SetupApiModuleName name 'SetupGetFileCompressionInfoExA';\r\nfunction SetupGetFileCompressionInfoExW; external SetupApiModuleName name 'SetupGetFileCompressionInfoExW';\r\nfunction SetupGetFileCompressionInfoEx; external SetupApiModuleName name 'SetupGetFileCompressionInfoEx' + NameSuffix;\r\n{$ENDIF WINXP_UP}\r\nfunction SetupDecompressOrCopyFileA; external SetupApiModuleName name 'SetupDecompressOrCopyFileA';\r\nfunction SetupDecompressOrCopyFileW; external SetupApiModuleName name 'SetupDecompressOrCopyFileW';\r\nfunction SetupDecompressOrCopyFile; external SetupApiModuleName name 'SetupDecompressOrCopyFile' + NameSuffix;\r\nfunction SetupGetSourceFileLocationA; external SetupApiModuleName name 'SetupGetSourceFileLocationA';\r\nfunction SetupGetSourceFileLocationW; external SetupApiModuleName name 'SetupGetSourceFileLocationW';\r\nfunction SetupGetSourceFileLocation; external SetupApiModuleName name 'SetupGetSourceFileLocation' + NameSuffix;\r\nfunction SetupGetSourceFileSizeA; external SetupApiModuleName name 'SetupGetSourceFileSizeA';\r\nfunction SetupGetSourceFileSizeW; external SetupApiModuleName name 'SetupGetSourceFileSizeW';\r\nfunction SetupGetSourceFileSize; external SetupApiModuleName name 'SetupGetSourceFileSize' + NameSuffix;\r\nfunction SetupGetTargetPathA; external SetupApiModuleName name 'SetupGetTargetPathA';\r\nfunction SetupGetTargetPathW; external SetupApiModuleName name 'SetupGetTargetPathW';\r\nfunction SetupGetTargetPath; external SetupApiModuleName name 'SetupGetTargetPath' + NameSuffix;\r\nfunction SetupSetSourceListA; external SetupApiModuleName name 'SetupSetSourceListA';\r\nfunction SetupSetSourceListW; external SetupApiModuleName name 'SetupSetSourceListW';\r\nfunction SetupSetSourceList; external SetupApiModuleName name 'SetupSetSourceList' + NameSuffix;\r\nfunction SetupCancelTemporarySourceList; external SetupApiModuleName name 'SetupCancelTemporarySourceList';\r\nfunction SetupAddToSourceListA; external SetupApiModuleName name 'SetupAddToSourceListA';\r\nfunction SetupAddToSourceListW; external SetupApiModuleName name 'SetupAddToSourceListW';\r\nfunction SetupAddToSourceList; external SetupApiModuleName name 'SetupAddToSourceList' + NameSuffix;\r\nfunction SetupRemoveFromSourceListA; external SetupApiModuleName name 'SetupRemoveFromSourceListA';\r\nfunction SetupRemoveFromSourceListW; external SetupApiModuleName name 'SetupRemoveFromSourceListW';\r\nfunction SetupRemoveFromSourceList; external SetupApiModuleName name 'SetupRemoveFromSourceList' + NameSuffix;\r\nfunction SetupQuerySourceListA; external SetupApiModuleName name 'SetupQuerySourceListA';\r\nfunction SetupQuerySourceListW; external SetupApiModuleName name 'SetupQuerySourceListW';\r\nfunction SetupQuerySourceList; external SetupApiModuleName name 'SetupQuerySourceList' + NameSuffix;\r\nfunction SetupFreeSourceListA; external SetupApiModuleName name 'SetupFreeSourceListA';\r\nfunction SetupFreeSourceListW; external SetupApiModuleName name 'SetupFreeSourceListW';\r\nfunction SetupFreeSourceList; external SetupApiModuleName name 'SetupFreeSourceList' + NameSuffix;\r\nfunction SetupPromptForDiskA; external SetupApiModuleName name 'SetupPromptForDiskA';\r\nfunction SetupPromptForDiskW; external SetupApiModuleName name 'SetupPromptForDiskW';\r\nfunction SetupPromptForDisk; external SetupApiModuleName name 'SetupPromptForDisk' + NameSuffix;\r\nfunction SetupCopyErrorA; external SetupApiModuleName name 'SetupCopyErrorA';\r\nfunction SetupCopyErrorW; external SetupApiModuleName name 'SetupCopyErrorW';\r\nfunction SetupCopyError; external SetupApiModuleName name 'SetupCopyError' + NameSuffix;\r\nfunction SetupRenameErrorA; external SetupApiModuleName name 'SetupRenameErrorA';\r\nfunction SetupRenameErrorW; external SetupApiModuleName name 'SetupRenameErrorW';\r\nfunction SetupRenameError; external SetupApiModuleName name 'SetupRenameError' + NameSuffix;\r\nfunction SetupDeleteErrorA; external SetupApiModuleName name 'SetupDeleteErrorA';\r\nfunction SetupDeleteErrorW; external SetupApiModuleName name 'SetupDeleteErrorW';\r\nfunction SetupDeleteError; external SetupApiModuleName name 'SetupDeleteError' + NameSuffix;\r\n{$IFDEF WIN2000_UP}\r\nfunction SetupBackupErrorA; external SetupApiModuleName name 'SetupBackupErrorA';\r\nfunction SetupBackupErrorW; external SetupApiModuleName name 'SetupBackupErrorW';\r\nfunction SetupBackupError; external SetupApiModuleName name 'SetupBackupError' + NameSuffix;\r\n{$ENDIF WIN2000_UP}\r\nfunction SetupSetDirectoryIdA; external SetupApiModuleName name 'SetupSetDirectoryIdA';\r\nfunction SetupSetDirectoryIdW; external SetupApiModuleName name 'SetupSetDirectoryIdW';\r\nfunction SetupSetDirectoryId; external SetupApiModuleName name 'SetupSetDirectoryId' + NameSuffix;\r\nfunction SetupSetDirectoryIdExA; external SetupApiModuleName name 'SetupSetDirectoryIdExA';\r\nfunction SetupSetDirectoryIdExW; external SetupApiModuleName name 'SetupSetDirectoryIdExW';\r\nfunction SetupSetDirectoryIdEx; external SetupApiModuleName name 'SetupSetDirectoryIdEx' + NameSuffix;\r\nfunction SetupGetSourceInfoA; external SetupApiModuleName name 'SetupGetSourceInfoA';\r\nfunction SetupGetSourceInfoW; external SetupApiModuleName name 'SetupGetSourceInfoW';\r\nfunction SetupGetSourceInfo; external SetupApiModuleName name 'SetupGetSourceInfo' + NameSuffix;\r\nfunction SetupInstallFileA; external SetupApiModuleName name 'SetupInstallFileA';\r\nfunction SetupInstallFileW; external SetupApiModuleName name 'SetupInstallFileW';\r\nfunction SetupInstallFile; external SetupApiModuleName name 'SetupInstallFile' + NameSuffix;\r\nfunction SetupInstallFileExA; external SetupApiModuleName name 'SetupInstallFileExA';\r\nfunction SetupInstallFileExW; external SetupApiModuleName name 'SetupInstallFileExW';\r\nfunction SetupInstallFileEx; external SetupApiModuleName name 'SetupInstallFileEx' + NameSuffix;\r\nfunction SetupOpenFileQueue; external SetupApiModuleName name 'SetupOpenFileQueue';\r\nfunction SetupCloseFileQueue; external SetupApiModuleName name 'SetupCloseFileQueue';\r\n{$IFDEF WIN2000_UP}\r\nfunction SetupSetFileQueueAlternatePlatformA; external SetupApiModuleName name 'SetupSetFileQueueAlternatePlatformA';\r\nfunction SetupSetFileQueueAlternatePlatformW; external SetupApiModuleName name 'SetupSetFileQueueAlternatePlatformW';\r\nfunction SetupSetFileQueueAlternatePlatform; external SetupApiModuleName name 'SetupSetFileQueueAlternatePlatform' + NameSuffix;\r\n{$ENDIF WIN2000_UP}\r\nfunction SetupSetPlatformPathOverrideA; external SetupApiModuleName name 'SetupSetPlatformPathOverrideA';\r\nfunction SetupSetPlatformPathOverrideW; external SetupApiModuleName name 'SetupSetPlatformPathOverrideW';\r\nfunction SetupSetPlatformPathOverride; external SetupApiModuleName name 'SetupSetPlatformPathOverride' + NameSuffix;\r\nfunction SetupQueueCopyA; external SetupApiModuleName name 'SetupQueueCopyA';\r\nfunction SetupQueueCopyW; external SetupApiModuleName name 'SetupQueueCopyW';\r\nfunction SetupQueueCopy; external SetupApiModuleName name 'SetupQueueCopy' + NameSuffix;\r\n{$IFDEF WIN2000_UP}\r\nfunction SetupQueueCopyIndirectA; external SetupApiModuleName name 'SetupQueueCopyIndirectA';\r\nfunction SetupQueueCopyIndirectW; external SetupApiModuleName name 'SetupQueueCopyIndirectW';\r\nfunction SetupQueueCopyIndirect; external SetupApiModuleName name 'SetupQueueCopyIndirect' + NameSuffix;\r\n{$ENDIF WIN2000_UP}\r\nfunction SetupQueueDefaultCopyA; external SetupApiModuleName name 'SetupQueueDefaultCopyA';\r\nfunction SetupQueueDefaultCopyW; external SetupApiModuleName name 'SetupQueueDefaultCopyW';\r\nfunction SetupQueueDefaultCopy; external SetupApiModuleName name 'SetupQueueDefaultCopy' + NameSuffix;\r\nfunction SetupQueueCopySectionA; external SetupApiModuleName name 'SetupQueueCopySectionA';\r\nfunction SetupQueueCopySectionW; external SetupApiModuleName name 'SetupQueueCopySectionW';\r\nfunction SetupQueueCopySection; external SetupApiModuleName name 'SetupQueueCopySection' + NameSuffix;\r\nfunction SetupQueueDeleteA; external SetupApiModuleName name 'SetupQueueDeleteA';\r\nfunction SetupQueueDeleteW; external SetupApiModuleName name 'SetupQueueDeleteW';\r\nfunction SetupQueueDelete; external SetupApiModuleName name 'SetupQueueDelete' + NameSuffix;\r\nfunction SetupQueueDeleteSectionA; external SetupApiModuleName name 'SetupQueueDeleteSectionA';\r\nfunction SetupQueueDeleteSectionW; external SetupApiModuleName name 'SetupQueueDeleteSectionW';\r\nfunction SetupQueueDeleteSection; external SetupApiModuleName name 'SetupQueueDeleteSection' + NameSuffix;\r\nfunction SetupQueueRenameA; external SetupApiModuleName name 'SetupQueueRenameA';\r\nfunction SetupQueueRenameW; external SetupApiModuleName name 'SetupQueueRenameW';\r\nfunction SetupQueueRename; external SetupApiModuleName name 'SetupQueueRename' + NameSuffix;\r\nfunction SetupQueueRenameSectionA; external SetupApiModuleName name 'SetupQueueRenameSectionA';\r\nfunction SetupQueueRenameSectionW; external SetupApiModuleName name 'SetupQueueRenameSectionW';\r\nfunction SetupQueueRenameSection; external SetupApiModuleName name 'SetupQueueRenameSection' + NameSuffix;\r\nfunction SetupCommitFileQueueA; external SetupApiModuleName name 'SetupCommitFileQueueA';\r\nfunction SetupCommitFileQueueW; external SetupApiModuleName name 'SetupCommitFileQueueW';\r\nfunction SetupCommitFileQueue; external SetupApiModuleName name 'SetupCommitFileQueue' + NameSuffix;\r\nfunction SetupScanFileQueueA; external SetupApiModuleName name 'SetupScanFileQueueA';\r\nfunction SetupScanFileQueueW; external SetupApiModuleName name 'SetupScanFileQueueW';\r\nfunction SetupScanFileQueue; external SetupApiModuleName name 'SetupScanFileQueue' + NameSuffix;\r\nfunction SetupCopyOEMInfA; external SetupApiModuleName name 'SetupCopyOEMInfA';\r\nfunction SetupCopyOEMInfW; external SetupApiModuleName name 'SetupCopyOEMInfW';\r\nfunction SetupCopyOEMInf; external SetupApiModuleName name 'SetupCopyOEMInf' + NameSuffix;\r\n{$IFDEF WINXP_UP}\r\nfunction SetupUninstallOEMInfA; external SetupApiModuleName name 'SetupUninstallOEMInfA';\r\nfunction SetupUninstallOEMInfW; external SetupApiModuleName name 'SetupUninstallOEMInfW';\r\nfunction SetupUninstallOEMInf; external SetupApiModuleName name 'SetupUninstallOEMInf' + NameSuffix;\r\nfunction SetupUninstallNewlyCopiedInfs; external SetupApiModuleName name 'SetupUninstallNewlyCopiedInfs';\r\n{$ENDIF WINXP_UP}\r\nfunction SetupCreateDiskSpaceListA; external SetupApiModuleName name 'SetupCreateDiskSpaceListA';\r\nfunction SetupCreateDiskSpaceListW; external SetupApiModuleName name 'SetupCreateDiskSpaceListW';\r\nfunction SetupCreateDiskSpaceList; external SetupApiModuleName name 'SetupCreateDiskSpaceList' + NameSuffix;\r\nfunction SetupDuplicateDiskSpaceListA; external SetupApiModuleName name 'SetupDuplicateDiskSpaceListA';\r\nfunction SetupDuplicateDiskSpaceListW; external SetupApiModuleName name 'SetupDuplicateDiskSpaceListW';\r\nfunction SetupDuplicateDiskSpaceList; external SetupApiModuleName name 'SetupDuplicateDiskSpaceList' + NameSuffix;\r\nfunction SetupDestroyDiskSpaceList; external SetupApiModuleName name 'SetupDestroyDiskSpaceList';\r\nfunction SetupQueryDrivesInDiskSpaceListA; external SetupApiModuleName name 'SetupQueryDrivesInDiskSpaceListA';\r\nfunction SetupQueryDrivesInDiskSpaceListW; external SetupApiModuleName name 'SetupQueryDrivesInDiskSpaceListW';\r\nfunction SetupQueryDrivesInDiskSpaceList; external SetupApiModuleName name 'SetupQueryDrivesInDiskSpaceList' + NameSuffix;\r\nfunction SetupQuerySpaceRequiredOnDriveA; external SetupApiModuleName name 'SetupQuerySpaceRequiredOnDriveA';\r\nfunction SetupQuerySpaceRequiredOnDriveW; external SetupApiModuleName name 'SetupQuerySpaceRequiredOnDriveW';\r\nfunction SetupQuerySpaceRequiredOnDrive; external SetupApiModuleName name 'SetupQuerySpaceRequiredOnDrive' + NameSuffix;\r\nfunction SetupAdjustDiskSpaceListA; external SetupApiModuleName name 'SetupAdjustDiskSpaceListA';\r\nfunction SetupAdjustDiskSpaceListW; external SetupApiModuleName name 'SetupAdjustDiskSpaceListW';\r\nfunction SetupAdjustDiskSpaceList; external SetupApiModuleName name 'SetupAdjustDiskSpaceList' + NameSuffix;\r\nfunction SetupAddToDiskSpaceListA; external SetupApiModuleName name 'SetupAddToDiskSpaceListA';\r\nfunction SetupAddToDiskSpaceListW; external SetupApiModuleName name 'SetupAddToDiskSpaceListW';\r\nfunction SetupAddToDiskSpaceList; external SetupApiModuleName name 'SetupAddToDiskSpaceList' + NameSuffix;\r\nfunction SetupAddSectionToDiskSpaceListA; external SetupApiModuleName name 'SetupAddSectionToDiskSpaceListA';\r\nfunction SetupAddSectionToDiskSpaceListW; external SetupApiModuleName name 'SetupAddSectionToDiskSpaceListW';\r\nfunction SetupAddSectionToDiskSpaceList; external SetupApiModuleName name 'SetupAddSectionToDiskSpaceList' + NameSuffix;\r\nfunction SetupAddInstallSectionToDiskSpaceListA; external SetupApiModuleName name 'SetupAddInstallSectionToDiskSpaceListA';\r\nfunction SetupAddInstallSectionToDiskSpaceListW; external SetupApiModuleName name 'SetupAddInstallSectionToDiskSpaceListW';\r\nfunction SetupAddInstallSectionToDiskSpaceList; external SetupApiModuleName name 'SetupAddInstallSectionToDiskSpaceList' + NameSuffix;\r\nfunction SetupRemoveFromDiskSpaceListA; external SetupApiModuleName name 'SetupRemoveFromDiskSpaceListA';\r\nfunction SetupRemoveFromDiskSpaceListW; external SetupApiModuleName name 'SetupRemoveFromDiskSpaceListW';\r\nfunction SetupRemoveFromDiskSpaceList; external SetupApiModuleName name 'SetupRemoveFromDiskSpaceList' + NameSuffix;\r\nfunction SetupRemoveSectionFromDiskSpaceListA; external SetupApiModuleName name 'SetupRemoveSectionFromDiskSpaceListA';\r\nfunction SetupRemoveSectionFromDiskSpaceListW; external SetupApiModuleName name 'SetupRemoveSectionFromDiskSpaceListW';\r\nfunction SetupRemoveSectionFromDiskSpaceList; external SetupApiModuleName name 'SetupRemoveSectionFromDiskSpaceList' + NameSuffix;\r\nfunction SetupRemoveInstallSectionFromDiskSpaceListA; external SetupApiModuleName name 'SetupRemoveInstallSectionFromDiskSpaceListA';\r\nfunction SetupRemoveInstallSectionFromDiskSpaceListW; external SetupApiModuleName name 'SetupRemoveInstallSectionFromDiskSpaceListW';\r\nfunction SetupRemoveInstallSectionFromDiskSpaceList; external SetupApiModuleName name 'SetupRemoveInstallSectionFromDiskSpaceList' + NameSuffix;\r\nfunction SetupIterateCabinetA; external SetupApiModuleName name 'SetupIterateCabinetA';\r\nfunction SetupIterateCabinetW; external SetupApiModuleName name 'SetupIterateCabinetW';\r\nfunction SetupIterateCabinet; external SetupApiModuleName name 'SetupIterateCabinet' + NameSuffix;\r\nfunction SetupPromptReboot; external SetupApiModuleName name 'SetupPromptReboot';\r\nfunction SetupInitDefaultQueueCallback; external SetupApiModuleName name 'SetupInitDefaultQueueCallback';\r\nfunction SetupInitDefaultQueueCallbackEx; external SetupApiModuleName name 'SetupInitDefaultQueueCallbackEx';\r\nprocedure SetupTermDefaultQueueCallback; external SetupApiModuleName name 'SetupTermDefaultQueueCallback';\r\nfunction SetupDefaultQueueCallbackA; external SetupApiModuleName name 'SetupDefaultQueueCallbackA';\r\nfunction SetupDefaultQueueCallbackW; external SetupApiModuleName name 'SetupDefaultQueueCallbackW';\r\nfunction SetupDefaultQueueCallback; external SetupApiModuleName name 'SetupDefaultQueueCallback' + NameSuffix;\r\nfunction SetupInstallFromInfSectionA; external SetupApiModuleName name 'SetupInstallFromInfSectionA';\r\nfunction SetupInstallFromInfSectionW; external SetupApiModuleName name 'SetupInstallFromInfSectionW';\r\nfunction SetupInstallFromInfSection; external SetupApiModuleName name 'SetupInstallFromInfSection' + NameSuffix;\r\nfunction SetupInstallFilesFromInfSectionA; external SetupApiModuleName name 'SetupInstallFilesFromInfSectionA';\r\nfunction SetupInstallFilesFromInfSectionW; external SetupApiModuleName name 'SetupInstallFilesFromInfSectionW';\r\nfunction SetupInstallFilesFromInfSection; external SetupApiModuleName name 'SetupInstallFilesFromInfSection' + NameSuffix;\r\nfunction SetupInstallServicesFromInfSectionA; external SetupApiModuleName name 'SetupInstallServicesFromInfSectionA';\r\nfunction SetupInstallServicesFromInfSectionW; external SetupApiModuleName name 'SetupInstallServicesFromInfSectionW';\r\nfunction SetupInstallServicesFromInfSection; external SetupApiModuleName name 'SetupInstallServicesFromInfSection' + NameSuffix;\r\nfunction SetupInstallServicesFromInfSectionExA; external SetupApiModuleName name 'SetupInstallServicesFromInfSectionExA';\r\nfunction SetupInstallServicesFromInfSectionExW; external SetupApiModuleName name 'SetupInstallServicesFromInfSectionExW';\r\nfunction SetupInstallServicesFromInfSectionEx; external SetupApiModuleName name 'SetupInstallServicesFromInfSectionEx' + NameSuffix;\r\n{$IFDEF WINXP_UP}\r\nfunction InstallHinfSectionA; external SetupApiModuleName name 'InstallHinfSectionA';\r\nfunction InstallHinfSectionW; external SetupApiModuleName name 'InstallHinfSectionW';\r\nfunction InstallHinfSection; external SetupApiModuleName name 'InstallHinfSection' + NameSuffix;\r\n{$ENDIF WINXP_UP}\r\nfunction SetupInitializeFileLogA; external SetupApiModuleName name 'SetupInitializeFileLogA';\r\nfunction SetupInitializeFileLogW; external SetupApiModuleName name 'SetupInitializeFileLogW';\r\nfunction SetupInitializeFileLog; external SetupApiModuleName name 'SetupInitializeFileLog' + NameSuffix;\r\nfunction SetupTerminateFileLog; external SetupApiModuleName name 'SetupTerminateFileLog';\r\nfunction SetupLogFileA; external SetupApiModuleName name 'SetupLogFileA';\r\nfunction SetupLogFileW; external SetupApiModuleName name 'SetupLogFileW';\r\nfunction SetupLogFile; external SetupApiModuleName name 'SetupLogFile' + NameSuffix;\r\nfunction SetupRemoveFileLogEntryA; external SetupApiModuleName name 'SetupRemoveFileLogEntryA';\r\nfunction SetupRemoveFileLogEntryW; external SetupApiModuleName name 'SetupRemoveFileLogEntryW';\r\nfunction SetupRemoveFileLogEntry; external SetupApiModuleName name 'SetupRemoveFileLogEntry' + NameSuffix;\r\nfunction SetupQueryFileLogA; external SetupApiModuleName name 'SetupQueryFileLogA';\r\nfunction SetupQueryFileLogW; external SetupApiModuleName name 'SetupQueryFileLogW';\r\nfunction SetupQueryFileLog; external SetupApiModuleName name 'SetupQueryFileLog' + NameSuffix;\r\nfunction SetupOpenLog; external SetupApiModuleName name 'SetupOpenLog';\r\nfunction SetupLogErrorA; external SetupApiModuleName name 'SetupLogErrorA';\r\nfunction SetupLogErrorW; external SetupApiModuleName name 'SetupLogErrorW';\r\nfunction SetupLogError; external SetupApiModuleName name 'SetupLogError' + NameSuffix;\r\nprocedure SetupCloseLog; external SetupApiModuleName name 'SetupCloseLog';\r\n{$IFDEF WIN2000_UP}\r\nfunction SetupGetBackupInformationA; external SetupApiModuleName name 'SetupGetBackupInformationA';\r\nfunction SetupGetBackupInformationW; external SetupApiModuleName name 'SetupGetBackupInformationW';\r\nfunction SetupGetBackupInformation; external SetupApiModuleName name 'SetupGetBackupInformation' + NameSuffix;\r\n{$ENDIF WIN2000_UP}\r\n{$IFDEF WINXP_UP}\r\nfunction SetupPrepareQueueForRestoreA; external SetupApiModuleName name 'SetupPrepareQueueForRestoreA';\r\nfunction SetupPrepareQueueForRestoreW; external SetupApiModuleName name 'SetupPrepareQueueForRestoreW';\r\nfunction SetupPrepareQueueForRestore; external SetupApiModuleName name 'SetupPrepareQueueForRestore' + NameSuffix;\r\nfunction SetupSetNonInteractiveMode; external SetupApiModuleName name 'SetupSetNonInteractiveMode';\r\nfunction SetupGetNonInteractiveMode; external SetupApiModuleName name 'SetupGetNonInteractiveMode';\r\n{$ENDIF WINXP_UP}\r\nfunction SetupDiCreateDeviceInfoList; external SetupApiModuleName name 'SetupDiCreateDeviceInfoList';\r\nfunction SetupDiCreateDeviceInfoListExA; external SetupApiModuleName name 'SetupDiCreateDeviceInfoListExA';\r\nfunction SetupDiCreateDeviceInfoListExW; external SetupApiModuleName name 'SetupDiCreateDeviceInfoListExW';\r\nfunction SetupDiCreateDeviceInfoListEx; external SetupApiModuleName name 'SetupDiCreateDeviceInfoListEx' + NameSuffix;\r\nfunction SetupDiGetDeviceInfoListClass; external SetupApiModuleName name 'SetupDiGetDeviceInfoListClass';\r\nfunction SetupDiGetDeviceInfoListDetailA; external SetupApiModuleName name 'SetupDiGetDeviceInfoListDetailA';\r\nfunction SetupDiGetDeviceInfoListDetailW; external SetupApiModuleName name 'SetupDiGetDeviceInfoListDetailW';\r\nfunction SetupDiGetDeviceInfoListDetail; external SetupApiModuleName name 'SetupDiGetDeviceInfoListDetail' + NameSuffix;\r\nfunction SetupDiCreateDeviceInfoA; external SetupApiModuleName name 'SetupDiCreateDeviceInfoA';\r\nfunction SetupDiCreateDeviceInfoW; external SetupApiModuleName name 'SetupDiCreateDeviceInfoW';\r\nfunction SetupDiCreateDeviceInfo; external SetupApiModuleName name 'SetupDiCreateDeviceInfo' + NameSuffix;\r\nfunction SetupDiOpenDeviceInfoA; external SetupApiModuleName name 'SetupDiOpenDeviceInfoA';\r\nfunction SetupDiOpenDeviceInfoW; external SetupApiModuleName name 'SetupDiOpenDeviceInfoW';\r\nfunction SetupDiOpenDeviceInfo; external SetupApiModuleName name 'SetupDiOpenDeviceInfo' + NameSuffix;\r\nfunction SetupDiGetDeviceInstanceIdA; external SetupApiModuleName name 'SetupDiGetDeviceInstanceIdA';\r\nfunction SetupDiGetDeviceInstanceIdW; external SetupApiModuleName name 'SetupDiGetDeviceInstanceIdW';\r\nfunction SetupDiGetDeviceInstanceId; external SetupApiModuleName name 'SetupDiGetDeviceInstanceId' + NameSuffix;\r\nfunction SetupDiDeleteDeviceInfo; external SetupApiModuleName name 'SetupDiDeleteDeviceInfo';\r\nfunction SetupDiEnumDeviceInfo; external SetupApiModuleName name 'SetupDiEnumDeviceInfo';\r\nfunction SetupDiDestroyDeviceInfoList; external SetupApiModuleName name 'SetupDiDestroyDeviceInfoList';\r\nfunction SetupDiEnumDeviceInterfaces; external SetupApiModuleName name 'SetupDiEnumDeviceInterfaces';\r\nfunction SetupDiEnumInterfaceDevice; external SetupApiModuleName name 'SetupDiEnumDeviceInterfaces';\r\nfunction SetupDiCreateDeviceInterfaceA; external SetupApiModuleName name 'SetupDiCreateDeviceInterfaceA';\r\nfunction SetupDiCreateInterfaceDeviceA; external SetupApiModuleName name 'SetupDiCreateDeviceInterfaceA';\r\nfunction SetupDiCreateDeviceInterfaceW; external SetupApiModuleName name 'SetupDiCreateDeviceInterfaceW';\r\nfunction SetupDiCreateInterfaceDeviceW; external SetupApiModuleName name 'SetupDiCreateDeviceInterfaceW';\r\nfunction SetupDiCreateDeviceInterface; external SetupApiModuleName name 'SetupDiCreateDeviceInterface' + NameSuffix;\r\nfunction SetupDiCreateInterfaceDevice; external SetupApiModuleName name 'SetupDiCreateDeviceInterface' + NameSuffix;\r\nfunction SetupDiOpenDeviceInterfaceA; external SetupApiModuleName name 'SetupDiOpenDeviceInterfaceA';\r\nfunction SetupDiOpenInterfaceDeviceA; external SetupApiModuleName name 'SetupDiOpenDeviceInterfaceA';\r\nfunction SetupDiOpenDeviceInterfaceW; external SetupApiModuleName name 'SetupDiOpenDeviceInterfaceW';\r\nfunction SetupDiOpenInterfaceDeviceW; external SetupApiModuleName name 'SetupDiOpenDeviceInterfaceW';\r\nfunction SetupDiOpenDeviceInterface; external SetupApiModuleName name 'SetupDiOpenDeviceInterface' + NameSuffix;\r\nfunction SetupDiOpenInterfaceDevice; external SetupApiModuleName name 'SetupDiOpenDeviceInterface' + NameSuffix;\r\nfunction SetupDiGetDeviceInterfaceAlias; external SetupApiModuleName name 'SetupDiGetDeviceInterfaceAlias';\r\nfunction SetupDiGetInterfaceDeviceAlias; external SetupApiModuleName name 'SetupDiGetDeviceInterfaceAlias';\r\nfunction SetupDiDeleteDeviceInterfaceData; external SetupApiModuleName name 'SetupDiDeleteDeviceInterfaceData';\r\nfunction SetupDiDeleteInterfaceDeviceData; external SetupApiModuleName name 'SetupDiDeleteDeviceInterfaceData';\r\nfunction SetupDiRemoveDeviceInterface; external SetupApiModuleName name 'SetupDiRemoveDeviceInterface';\r\nfunction SetupDiRemoveInterfaceDevice; external SetupApiModuleName name 'SetupDiRemoveDeviceInterface';\r\nfunction SetupDiGetDeviceInterfaceDetailA; external SetupApiModuleName name 'SetupDiGetDeviceInterfaceDetailA';\r\nfunction SetupDiGetInterfaceDeviceDetailA; external SetupApiModuleName name 'SetupDiGetDeviceInterfaceDetailA';\r\nfunction SetupDiGetDeviceInterfaceDetailW; external SetupApiModuleName name 'SetupDiGetDeviceInterfaceDetailW';\r\nfunction SetupDiGetInterfaceDeviceDetailW; external SetupApiModuleName name 'SetupDiGetDeviceInterfaceDetailW';\r\nfunction SetupDiGetDeviceInterfaceDetail; external SetupApiModuleName name 'SetupDiGetDeviceInterfaceDetail' + NameSuffix;\r\nfunction SetupDiGetInterfaceDeviceDetail; external SetupApiModuleName name 'SetupDiGetDeviceInterfaceDetail' + NameSuffix;\r\nfunction SetupDiInstallDeviceInterfaces; external SetupApiModuleName name 'SetupDiInstallDeviceInterfaces';\r\nfunction SetupDiInstallInterfaceDevices; external SetupApiModuleName name 'SetupDiInstallDeviceInterfaces';\r\n{$IFDEF WINXP_UP}\r\nfunction SetupDiSetDeviceInterfaceDefault; external SetupApiModuleName name 'SetupDiSetDeviceInterfaceDefault';\r\n{$ENDIF WINXP_UP}\r\nfunction SetupDiRegisterDeviceInfo; external SetupApiModuleName name 'SetupDiRegisterDeviceInfo';\r\nfunction SetupDiBuildDriverInfoList; external SetupApiModuleName name 'SetupDiBuildDriverInfoList';\r\nfunction SetupDiCancelDriverInfoSearch; external SetupApiModuleName name 'SetupDiCancelDriverInfoSearch';\r\nfunction SetupDiEnumDriverInfoA; external SetupApiModuleName name 'SetupDiEnumDriverInfoA';\r\nfunction SetupDiEnumDriverInfoW; external SetupApiModuleName name 'SetupDiEnumDriverInfoW';\r\nfunction SetupDiEnumDriverInfo; external SetupApiModuleName name 'SetupDiEnumDriverInfo' + NameSuffix;\r\nfunction SetupDiGetSelectedDriverA; external SetupApiModuleName name 'SetupDiGetSelectedDriverA';\r\nfunction SetupDiGetSelectedDriverW; external SetupApiModuleName name 'SetupDiGetSelectedDriverW';\r\nfunction SetupDiGetSelectedDriver; external SetupApiModuleName name 'SetupDiGetSelectedDriver' + NameSuffix;\r\nfunction SetupDiSetSelectedDriverA; external SetupApiModuleName name 'SetupDiSetSelectedDriverA';\r\nfunction SetupDiSetSelectedDriverW; external SetupApiModuleName name 'SetupDiSetSelectedDriverW';\r\nfunction SetupDiSetSelectedDriver; external SetupApiModuleName name 'SetupDiSetSelectedDriver' + NameSuffix;\r\nfunction SetupDiGetDriverInfoDetailA; external SetupApiModuleName name 'SetupDiGetDriverInfoDetailA';\r\nfunction SetupDiGetDriverInfoDetailW; external SetupApiModuleName name 'SetupDiGetDriverInfoDetailW';\r\nfunction SetupDiGetDriverInfoDetail; external SetupApiModuleName name 'SetupDiGetDriverInfoDetail' + NameSuffix;\r\nfunction SetupDiDestroyDriverInfoList; external SetupApiModuleName name 'SetupDiDestroyDriverInfoList';\r\nfunction SetupDiGetClassDevsA; external SetupApiModuleName name 'SetupDiGetClassDevsA';\r\nfunction SetupDiGetClassDevsW; external SetupApiModuleName name 'SetupDiGetClassDevsW';\r\nfunction SetupDiGetClassDevs; external SetupApiModuleName name 'SetupDiGetClassDevs' + NameSuffix;\r\nfunction SetupDiGetClassDevsExA; external SetupApiModuleName name 'SetupDiGetClassDevsExA';\r\nfunction SetupDiGetClassDevsExW; external SetupApiModuleName name 'SetupDiGetClassDevsExW';\r\nfunction SetupDiGetClassDevsEx; external SetupApiModuleName name 'SetupDiGetClassDevsEx' + NameSuffix;\r\nfunction SetupDiGetINFClassA; external SetupApiModuleName name 'SetupDiGetINFClassA';\r\nfunction SetupDiGetINFClassW; external SetupApiModuleName name 'SetupDiGetINFClassW';\r\nfunction SetupDiGetINFClass; external SetupApiModuleName name 'SetupDiGetINFClass' + NameSuffix;\r\nfunction SetupDiBuildClassInfoList; external SetupApiModuleName name 'SetupDiBuildClassInfoList';\r\nfunction SetupDiBuildClassInfoListExA; external SetupApiModuleName name 'SetupDiBuildClassInfoListExA';\r\nfunction SetupDiBuildClassInfoListExW; external SetupApiModuleName name 'SetupDiBuildClassInfoListExW';\r\nfunction SetupDiBuildClassInfoListEx; external SetupApiModuleName name 'SetupDiBuildClassInfoListEx' + NameSuffix;\r\nfunction SetupDiGetClassDescriptionA; external SetupApiModuleName name 'SetupDiGetClassDescriptionA';\r\nfunction SetupDiGetClassDescriptionW; external SetupApiModuleName name 'SetupDiGetClassDescriptionW';\r\nfunction SetupDiGetClassDescription; external SetupApiModuleName name 'SetupDiGetClassDescription' + NameSuffix;\r\nfunction SetupDiGetClassDescriptionExA; external SetupApiModuleName name 'SetupDiGetClassDescriptionExA';\r\nfunction SetupDiGetClassDescriptionExW; external SetupApiModuleName name 'SetupDiGetClassDescriptionExW';\r\nfunction SetupDiGetClassDescriptionEx; external SetupApiModuleName name 'SetupDiGetClassDescriptionEx' + NameSuffix;\r\nfunction SetupDiCallClassInstaller; external SetupApiModuleName name 'SetupDiCallClassInstaller';\r\nfunction SetupDiSelectDevice; external SetupApiModuleName name 'SetupDiSelectDevice';\r\nfunction SetupDiSelectBestCompatDrv; external SetupApiModuleName name 'SetupDiSelectBestCompatDrv';\r\nfunction SetupDiInstallDevice; external SetupApiModuleName name 'SetupDiInstallDevice';\r\nfunction SetupDiInstallDriverFiles; external SetupApiModuleName name 'SetupDiInstallDriverFiles';\r\nfunction SetupDiRegisterCoDeviceInstallers; external SetupApiModuleName name 'SetupDiRegisterCoDeviceInstallers';\r\nfunction SetupDiRemoveDevice; external SetupApiModuleName name 'SetupDiRemoveDevice';\r\nfunction SetupDiUnremoveDevice; external SetupApiModuleName name 'SetupDiUnremoveDevice';\r\nfunction SetupDiMoveDuplicateDevice; external SetupApiModuleName name 'SetupDiMoveDuplicateDevice';\r\nfunction SetupDiChangeState; external SetupApiModuleName name 'SetupDiChangeState';\r\nfunction SetupDiInstallClassA; external SetupApiModuleName name 'SetupDiInstallClassA';\r\nfunction SetupDiInstallClassW; external SetupApiModuleName name 'SetupDiInstallClassW';\r\nfunction SetupDiInstallClass; external SetupApiModuleName name 'SetupDiInstallClass' + NameSuffix;\r\nfunction SetupDiInstallClassExA; external SetupApiModuleName name 'SetupDiInstallClassExA';\r\nfunction SetupDiInstallClassExW; external SetupApiModuleName name 'SetupDiInstallClassExW';\r\nfunction SetupDiInstallClassEx; external SetupApiModuleName name 'SetupDiInstallClassEx' + NameSuffix;\r\nfunction SetupDiOpenClassRegKey; external SetupApiModuleName name 'SetupDiOpenClassRegKey';\r\nfunction SetupDiOpenClassRegKeyExA; external SetupApiModuleName name 'SetupDiOpenClassRegKeyExA';\r\nfunction SetupDiOpenClassRegKeyExW; external SetupApiModuleName name 'SetupDiOpenClassRegKeyExW';\r\nfunction SetupDiOpenClassRegKeyEx; external SetupApiModuleName name 'SetupDiOpenClassRegKeyEx' + NameSuffix;\r\nfunction SetupDiCreateDeviceInterfaceRegKeyA; external SetupApiModuleName name 'SetupDiCreateDeviceInterfaceRegKeyA';\r\nfunction SetupDiCreateInterfaceDeviceRegKeyA; external SetupApiModuleName name 'SetupDiCreateDeviceInterfaceRegKeyA';\r\nfunction SetupDiCreateDeviceInterfaceRegKeyW; external SetupApiModuleName name 'SetupDiCreateDeviceInterfaceRegKeyW';\r\nfunction SetupDiCreateInterfaceDeviceRegKeyW; external SetupApiModuleName name 'SetupDiCreateDeviceInterfaceRegKeyW';\r\nfunction SetupDiCreateDeviceInterfaceRegKey; external SetupApiModuleName name 'SetupDiCreateDeviceInterfaceRegKey' + NameSuffix;\r\nfunction SetupDiCreateInterfaceDeviceRegKey; external SetupApiModuleName name 'SetupDiCreateDeviceInterfaceRegKey' + NameSuffix;\r\nfunction SetupDiOpenDeviceInterfaceRegKey; external SetupApiModuleName name 'SetupDiOpenDeviceInterfaceRegKey';\r\nfunction SetupDiOpenInterfaceDeviceRegKey; external SetupApiModuleName name 'SetupDiOpenDeviceInterfaceRegKey';\r\nfunction SetupDiDeleteDeviceInterfaceRegKey; external SetupApiModuleName name 'SetupDiDeleteDeviceInterfaceRegKey';\r\nfunction SetupDiDeleteInterfaceDeviceRegKey; external SetupApiModuleName name 'SetupDiDeleteDeviceInterfaceRegKey';\r\nfunction SetupDiCreateDevRegKeyA; external SetupApiModuleName name 'SetupDiCreateDevRegKeyA';\r\nfunction SetupDiCreateDevRegKeyW; external SetupApiModuleName name 'SetupDiCreateDevRegKeyW';\r\nfunction SetupDiCreateDevRegKey; external SetupApiModuleName name 'SetupDiCreateDevRegKey' + NameSuffix;\r\nfunction SetupDiOpenDevRegKey; external SetupApiModuleName name 'SetupDiOpenDevRegKey';\r\nfunction SetupDiDeleteDevRegKey; external SetupApiModuleName name 'SetupDiDeleteDevRegKey';\r\nfunction SetupDiGetHwProfileList; external SetupApiModuleName name 'SetupDiGetHwProfileList';\r\nfunction SetupDiGetHwProfileListExA; external SetupApiModuleName name 'SetupDiGetHwProfileListExA';\r\nfunction SetupDiGetHwProfileListExW; external SetupApiModuleName name 'SetupDiGetHwProfileListExW';\r\nfunction SetupDiGetHwProfileListEx; external SetupApiModuleName name 'SetupDiGetHwProfileListEx' + NameSuffix;\r\nfunction SetupDiGetDeviceRegistryPropertyA; external SetupApiModuleName name 'SetupDiGetDeviceRegistryPropertyA';\r\nfunction SetupDiGetDeviceRegistryPropertyW; external SetupApiModuleName name 'SetupDiGetDeviceRegistryPropertyW';\r\nfunction SetupDiGetDeviceRegistryProperty; external SetupApiModuleName name 'SetupDiGetDeviceRegistryProperty' + NameSuffix;\r\n{$IFDEF WINXP_UP}\r\nfunction SetupDiGetClassRegistryPropertyA; external SetupApiModuleName name 'SetupDiGetClassRegistryPropertyA';\r\nfunction SetupDiGetClassRegistryPropertyW; external SetupApiModuleName name 'SetupDiGetClassRegistryPropertyW';\r\nfunction SetupDiGetClassRegistryProperty; external SetupApiModuleName name 'SetupDiGetClassRegistryProperty' + NameSuffix;\r\n{$ENDIF WINXP_UP}\r\nfunction SetupDiSetDeviceRegistryPropertyA; external SetupApiModuleName name 'SetupDiSetDeviceRegistryPropertyA';\r\nfunction SetupDiSetDeviceRegistryPropertyW; external SetupApiModuleName name 'SetupDiSetDeviceRegistryPropertyW';\r\nfunction SetupDiSetDeviceRegistryProperty; external SetupApiModuleName name 'SetupDiSetDeviceRegistryProperty' + NameSuffix;\r\n{$IFDEF WINXP_UP}\r\nfunction SetupDiSetClassRegistryPropertyA; external SetupApiModuleName name 'SetupDiSetClassRegistryPropertyA';\r\nfunction SetupDiSetClassRegistryPropertyW; external SetupApiModuleName name 'SetupDiSetClassRegistryPropertyW';\r\nfunction SetupDiSetClassRegistryProperty; external SetupApiModuleName name 'SetupDiSetClassRegistryProperty' + NameSuffix;\r\n{$ENDIF WINXP_UP}\r\nfunction SetupDiGetDeviceInstallParamsA; external SetupApiModuleName name 'SetupDiGetDeviceInstallParamsA';\r\nfunction SetupDiGetDeviceInstallParamsW; external SetupApiModuleName name 'SetupDiGetDeviceInstallParamsW';\r\nfunction SetupDiGetDeviceInstallParams; external SetupApiModuleName name 'SetupDiGetDeviceInstallParams' + NameSuffix;\r\nfunction SetupDiGetClassInstallParamsA; external SetupApiModuleName name 'SetupDiGetClassInstallParamsA';\r\nfunction SetupDiGetClassInstallParamsW; external SetupApiModuleName name 'SetupDiGetClassInstallParamsW';\r\nfunction SetupDiGetClassInstallParams; external SetupApiModuleName name 'SetupDiGetClassInstallParams' + NameSuffix;\r\nfunction SetupDiSetDeviceInstallParamsA; external SetupApiModuleName name 'SetupDiSetDeviceInstallParamsA';\r\nfunction SetupDiSetDeviceInstallParamsW; external SetupApiModuleName name 'SetupDiSetDeviceInstallParamsW';\r\nfunction SetupDiSetDeviceInstallParams; external SetupApiModuleName name 'SetupDiSetDeviceInstallParams' + NameSuffix;\r\nfunction SetupDiSetClassInstallParamsA; external SetupApiModuleName name 'SetupDiSetClassInstallParamsA';\r\nfunction SetupDiSetClassInstallParamsW; external SetupApiModuleName name 'SetupDiSetClassInstallParamsW';\r\nfunction SetupDiSetClassInstallParams; external SetupApiModuleName name 'SetupDiSetClassInstallParams' + NameSuffix;\r\nfunction SetupDiGetDriverInstallParamsA; external SetupApiModuleName name 'SetupDiGetDriverInstallParamsA';\r\nfunction SetupDiGetDriverInstallParamsW; external SetupApiModuleName name 'SetupDiGetDriverInstallParamsW';\r\nfunction SetupDiGetDriverInstallParams; external SetupApiModuleName name 'SetupDiGetDriverInstallParams' + NameSuffix;\r\nfunction SetupDiSetDriverInstallParamsA; external SetupApiModuleName name 'SetupDiSetDriverInstallParamsA';\r\nfunction SetupDiSetDriverInstallParamsW; external SetupApiModuleName name 'SetupDiSetDriverInstallParamsW';\r\nfunction SetupDiSetDriverInstallParams; external SetupApiModuleName name 'SetupDiSetDriverInstallParams' + NameSuffix;\r\nfunction SetupDiLoadClassIcon; external SetupApiModuleName name 'SetupDiLoadClassIcon';\r\nfunction SetupDiDrawMiniIcon; external SetupApiModuleName name 'SetupDiDrawMiniIcon';\r\nfunction SetupDiGetClassBitmapIndex; external SetupApiModuleName name 'SetupDiGetClassBitmapIndex';\r\nfunction SetupDiGetClassImageList; external SetupApiModuleName name 'SetupDiGetClassImageList';\r\nfunction SetupDiGetClassImageListExA; external SetupApiModuleName name 'SetupDiGetClassImageListExA';\r\nfunction SetupDiGetClassImageListExW; external SetupApiModuleName name 'SetupDiGetClassImageListExW';\r\nfunction SetupDiGetClassImageListEx; external SetupApiModuleName name 'SetupDiGetClassImageListEx' + NameSuffix;\r\nfunction SetupDiGetClassImageIndex; external SetupApiModuleName name 'SetupDiGetClassImageIndex';\r\nfunction SetupDiDestroyClassImageList; external SetupApiModuleName name 'SetupDiDestroyClassImageList';\r\nfunction SetupDiGetClassDevPropertySheetsA; external SetupApiModuleName name 'SetupDiGetClassDevPropertySheetsA';\r\nfunction SetupDiGetClassDevPropertySheetsW; external SetupApiModuleName name 'SetupDiGetClassDevPropertySheetsW';\r\nfunction SetupDiGetClassDevPropertySheets; external SetupApiModuleName name 'SetupDiGetClassDevPropertySheets' + NameSuffix;\r\nfunction SetupDiAskForOEMDisk; external SetupApiModuleName name 'SetupDiAskForOEMDisk';\r\nfunction SetupDiSelectOEMDrv; external SetupApiModuleName name 'SetupDiSelectOEMDrv';\r\nfunction SetupDiClassNameFromGuidA; external SetupApiModuleName name 'SetupDiClassNameFromGuidA';\r\nfunction SetupDiClassNameFromGuidW; external SetupApiModuleName name 'SetupDiClassNameFromGuidW';\r\nfunction SetupDiClassNameFromGuid; external SetupApiModuleName name 'SetupDiClassNameFromGuid' + NameSuffix;\r\nfunction SetupDiClassNameFromGuidExA; external SetupApiModuleName name 'SetupDiClassNameFromGuidExA';\r\nfunction SetupDiClassNameFromGuidExW; external SetupApiModuleName name 'SetupDiClassNameFromGuidExW';\r\nfunction SetupDiClassNameFromGuidEx; external SetupApiModuleName name 'SetupDiClassNameFromGuidEx' + NameSuffix;\r\nfunction SetupDiClassGuidsFromNameA; external SetupApiModuleName name 'SetupDiClassGuidsFromNameA';\r\nfunction SetupDiClassGuidsFromNameW; external SetupApiModuleName name 'SetupDiClassGuidsFromNameW';\r\nfunction SetupDiClassGuidsFromName; external SetupApiModuleName name 'SetupDiClassGuidsFromName' + NameSuffix;\r\nfunction SetupDiClassGuidsFromNameExA; external SetupApiModuleName name 'SetupDiClassGuidsFromNameExA';\r\nfunction SetupDiClassGuidsFromNameExW; external SetupApiModuleName name 'SetupDiClassGuidsFromNameExW';\r\nfunction SetupDiClassGuidsFromNameEx; external SetupApiModuleName name 'SetupDiClassGuidsFromNameEx' + NameSuffix;\r\nfunction SetupDiGetHwProfileFriendlyNameA; external SetupApiModuleName name 'SetupDiGetHwProfileFriendlyNameA';\r\nfunction SetupDiGetHwProfileFriendlyNameW; external SetupApiModuleName name 'SetupDiGetHwProfileFriendlyNameW';\r\nfunction SetupDiGetHwProfileFriendlyName; external SetupApiModuleName name 'SetupDiGetHwProfileFriendlyName' + NameSuffix;\r\nfunction SetupDiGetHwProfileFriendlyNameExA; external SetupApiModuleName name 'SetupDiGetHwProfileFriendlyNameExA';\r\nfunction SetupDiGetHwProfileFriendlyNameExW; external SetupApiModuleName name 'SetupDiGetHwProfileFriendlyNameExW';\r\nfunction SetupDiGetHwProfileFriendlyNameEx; external SetupApiModuleName name 'SetupDiGetHwProfileFriendlyNameEx' + NameSuffix;\r\nfunction SetupDiGetWizardPage; external SetupApiModuleName name 'SetupDiGetWizardPage';\r\nfunction SetupDiGetSelectedDevice; external SetupApiModuleName name 'SetupDiGetSelectedDevice';\r\nfunction SetupDiSetSelectedDevice; external SetupApiModuleName name 'SetupDiSetSelectedDevice';\r\nfunction SetupDiGetActualSectionToInstallA; external SetupApiModuleName name 'SetupDiGetActualSectionToInstallA';\r\nfunction SetupDiGetActualSectionToInstallW; external SetupApiModuleName name 'SetupDiGetActualSectionToInstallW';\r\nfunction SetupDiGetActualSectionToInstall; external SetupApiModuleName name 'SetupDiGetActualSectionToInstall' + NameSuffix;\r\n{$IFDEF WINXP_UP}\r\nfunction SetupDiGetActualSectionToInstallExA; external SetupApiModuleName name 'SetupDiGetActualSectionToInstallExA';\r\nfunction SetupDiGetActualSectionToInstallExW; external SetupApiModuleName name 'SetupDiGetActualSectionToInstallExW';\r\nfunction SetupDiGetActualSectionToInstallEx; external SetupApiModuleName name 'SetupDiGetActualSectionToInstallEx' + NameSuffix;\r\nfunction SetupEnumInfSectionsA; external SetupApiModuleName name 'SetupEnumInfSectionsA';\r\nfunction SetupEnumInfSectionsW; external SetupApiModuleName name 'SetupEnumInfSectionsW';\r\nfunction SetupEnumInfSections; external SetupApiModuleName name 'SetupEnumInfSections' + NameSuffix;\r\nfunction SetupVerifyInfFileA; external SetupApiModuleName name 'SetupVerifyInfFileA';\r\nfunction SetupVerifyInfFileW; external SetupApiModuleName name 'SetupVerifyInfFileW';;\r\nfunction SetupVerifyInfFile; external SetupApiModuleName name 'SetupVerifyInfFile' + NameSuffix;\r\nfunction SetupDiGetCustomDevicePropertyA; external SetupApiModuleName name 'SetupDiGetCustomDevicePropertyA';\r\nfunction SetupDiGetCustomDevicePropertyW; external SetupApiModuleName name 'SetupDiGetCustomDevicePropertyW';\r\nfunction SetupDiGetCustomDeviceProperty; external SetupApiModuleName name 'SetupDiGetCustomDeviceProperty' + NameSuffix;\r\n{$ENDIF WINXP_UP}\r\n\r\n{$ENDIF !SETUPAPI_LINKONREQUEST}\r\n\r\nend.\r\n\r\n" }, { "path": "External/Jedi/Jvcl/run/JvShape.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvShape.PAS, released on 2001-02-28.\r\n\r\nThe Initial Developer of the Original Code is Sbastien Buysse [sbuysse att buypin dott com]\r\nPortions created by Sbastien Buysse are Copyright (C) 2001 Sbastien Buysse.\r\nAll Rights Reserved.\r\n\r\nContributor(s): Michael Beck [mbeck att bigfoot dott com].\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvShape.pas 13104 2011-09-07 06:50:43Z obones $\r\n\r\nunit JvShape;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n Classes,\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n JvExExtCtrls;\r\n\r\ntype\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvShape = class(TJvExShape)\r\n published\r\n property Anchors;\r\n property Constraints;\r\n property HintColor;\r\n property OnMouseEnter;\r\n property OnMouseLeave;\r\n property OnEndDock;\r\n property OnStartDock;\r\n property OnParentColorChange;\r\n\r\n property OnClick;\r\n property OnConstrainedResize;\r\n property OnContextPopup;\r\n property OnDblClick;\r\n property OnDragDrop;\r\n property OnDragOver;\r\n property OnEndDrag;\r\n property OnMouseDown;\r\n property OnMouseMove;\r\n property OnMouseUp;\r\n property OnMouseWheel;\r\n property OnMouseWheelDown;\r\n property OnMouseWheelUp;\r\n property OnResize;\r\n property OnStartDrag;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvShape.pas $';\r\n Revision: '$Revision: 13104 $';\r\n Date: '$Date: 2011-09-07 08:50:43 +0200 (mer. 07 sept. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend." }, { "path": "External/Jedi/Jvcl/run/JvShapedButton.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvShapedButton.PAS, released on 2002-11-12.\r\n\r\nThe Initial Developer of the Original Code is Jan Verhoeven [jan1 dott verhoeven att wxs dott nl]\r\nPortions created by Jan Verhoeven are Copyright (C) 2002 Jan Verhoeven.\r\nAll Rights Reserved.\r\n\r\nContributor(s): Robert Love [rlove att slcdug dott org].\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvShapedButton.pas 13104 2011-09-07 06:50:43Z obones $\r\n\r\nunit JvShapedButton;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, Messages, Types, SysUtils, Classes, Graphics, Controls,\r\n Forms, Dialogs, StdCtrls,\r\n JvThemes, JvExControls, JvExStdCtrls;\r\n\r\ntype\r\n TJvButtonShapes = (jvSLeftArrow, jvSRightArrow, jvSRound, jvSHex, jvSOctagon,\r\n jvSPar, jvSDiamond, jvSTriangleUp, jvSTriangleDown, jvSTriangleLeft,\r\n jvSTriangleRight, jvSPentagon, jvSRevPentagon, jvSRing);\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvShapedButton = class(TJvExButton, IJvDenySubClassing)\r\n private\r\n FBmp: TBitmap;\r\n FIsFocused: Boolean;\r\n FIsHot: Boolean;\r\n FCanvas: TCanvas;\r\n FHotColor: TColor;\r\n FFlat: Boolean;\r\n FFlatBorderColor: TColor;\r\n FButtonShape: TJvButtonShapes;\r\n FXP: Integer;\r\n FYP: Integer;\r\n FFlatArrow: Boolean;\r\n FAntiAlias: Boolean;\r\n procedure CNDrawItem(var Msg: TWMDrawItem); message CN_DRAWITEM;\r\n procedure WMLButtonDblClk(var Msg: TWMLButtonDblClk); message WM_LBUTTONDBLCLK;\r\n procedure SetHotColor(const Value: TColor);\r\n procedure SetFlat(const Value: Boolean);\r\n procedure SetFlatBorderColor(const Value: TColor);\r\n procedure SetButtonShape(const Value: TJvButtonShapes);\r\n procedure CNDrawItemOctagon(var Msg: TWMDrawItem);\r\n procedure CNDrawItemTriangleDown(var Msg: TWMDrawItem);\r\n procedure CNDrawItemTriangleLeft(var Msg: TWMDrawItem);\r\n procedure CNDrawItemTriangleRight(var Msg: TWMDrawItem);\r\n procedure CNDrawItemTriangleUp(var Msg: TWMDrawItem);\r\n procedure CNDrawItemPar(var Msg: TWMDrawItem);\r\n procedure CalcPentagon(AWidth, AHeight: Integer);\r\n procedure SetFlatArrow(const Value: Boolean);\r\n procedure CNDrawItemLeftArrow(var Msg: TWMDrawItem);\r\n procedure CNDrawItemRightArrow(var Msg: TWMDrawItem);\r\n procedure CNDrawItemRing(var Msg: TWMDrawItem);\r\n procedure CNDrawItemRound(var Msg: TWMDrawItem);\r\n procedure CNDrawItemPentagon(var Msg: TWMDrawItem);\r\n procedure CNDrawItemRevPentagon(var Msg: TWMDrawItem);\r\n procedure CNDrawItemHex(var Msg: TWMDrawItem);\r\n procedure CNDrawItemDiamond(var Msg: TWMDrawItem);\r\n procedure SetButton(ALeft, ATop, AWidth, AHeight: Integer);\r\n procedure DoAntiAlias(Bmp: TBitmap);\r\n procedure SetAntiAlias(const Value: Boolean);\r\n protected\r\n procedure SetRegionOctagon(ALeft, ATop, AWidth, AHeight: Integer);\r\n procedure SetRegionTriangleDown(ALeft, ATop, AWidth, AHeight: Integer);\r\n procedure SetRegionTriangleUp(ALeft, ATop, AWidth, AHeight: Integer);\r\n procedure SetRegionTriangleLeft(ALeft, ATop, AWidth, AHeight: Integer);\r\n procedure SetRegionTriangleRight(ALeft, ATop, AWidth, AHeight: Integer);\r\n procedure SetRegionPar(ALeft, ATop, AWidth, AHeight: Integer);\r\n procedure SetRegionLeftArrow(ALeft, ATop, AWidth, AHeight: Integer);\r\n procedure SetRegionRightArrow(ALeft, ATop, AWidth, AHeight: Integer);\r\n procedure SetRegionRound(ALeft, ATop, AWidth, AHeight: Integer);\r\n procedure SetRegionHex(ALeft, ATop, AWidth, AHeight: Integer);\r\n procedure SetRegionDiamond(ALeft, ATop, AWidth, AHeight: Integer);\r\n procedure SetRegionPentagon(ALeft, ATop, AWidth, AHeight: Integer);\r\n procedure SetRegionRevPentagon(ALeft, ATop, AWidth, AHeight: Integer);\r\n procedure SetRegionRing(ALeft, ATop, AWidth, AHeight: Integer);\r\n function DoEraseBackground(Canvas: TCanvas; Param: LPARAM): Boolean; override;\r\n procedure MouseLeave(Control: TControl); override;\r\n procedure MouseEnter(Control: TControl); override;\r\n procedure FontChanged; override;\r\n procedure EnabledChanged; override;\r\n procedure CreateParams(var Params: TCreateParams); override;\r\n procedure CreateWnd; override;\r\n procedure SetButtonStyle(ADefault: Boolean); override;\r\n public\r\n procedure SetBounds(ALeft, ATop, AWidth, AHeight: Integer); override;\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n published\r\n property ButtonShape: TJvButtonShapes read FButtonShape write SetButtonShape default jvSTriangleUp;\r\n property Color;\r\n property AntiAlias: Boolean read FAntiAlias write SetAntiAlias default False;\r\n property HotColor: TColor read FHotColor write SetHotColor default clBlue;\r\n property Flat: Boolean read FFlat write SetFlat default False;\r\n property FlatBorderColor: TColor read FFlatBorderColor write SetFlatBorderColor default clWhite;\r\n property FlatArrow: Boolean read FFlatArrow write SetFlatArrow default False;\r\n property Width default 65;\r\n property Height default 65;\r\n property ParentShowHint;\r\n property ShowHint;\r\n property TabOrder;\r\n property TabStop;\r\n property Visible;\r\n property OnEnter;\r\n property OnExit;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvShapedButton.pas $';\r\n Revision: '$Revision: 13104 $';\r\n Date: '$Date: 2011-09-07 08:50:43 +0200 (mer. 07 sept. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n Math,\r\n JvJCLUtils;\r\n\r\nconstructor TJvShapedButton.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FAntiAlias := False;\r\n FBmp := TBitmap.Create;\r\n SetBounds(Left, Top, 65, 65);\r\n FCanvas := TCanvas.Create;\r\n FHotColor := clBlue;\r\n FFlatBorderColor := clWhite;\r\n FButtonShape := jvSTriangleUp; //TODO: Change to Left Arrow\r\n FFlat := False;\r\n FFlatArrow := False;\r\nend;\r\n\r\ndestructor TJvShapedButton.Destroy;\r\nbegin\r\n inherited Destroy;\r\n FBmp.Free;\r\n // (rom) destroy Canvas AFTER inherited Destroy\r\n FCanvas.Free;\r\nend;\r\n\r\nprocedure TJvShapedButton.CreateParams(var Params: TCreateParams);\r\nbegin\r\n inherited CreateParams(Params);\r\n with Params do\r\n Style := Style or BS_OWNERDRAW;\r\nend;\r\n\r\nprocedure TJvShapedButton.CreateWnd;\r\nbegin\r\n inherited CreateWnd;\r\n SetButton(Left, Top, Width, Height);\r\nend;\r\n\r\nprocedure TJvShapedButton.SetButton(ALeft, ATop,AWidth, AHeight: Integer);\r\nbegin\r\n if HandleAllocated then\r\n begin\r\n case FButtonShape of\r\n jvSLeftArrow:\r\n SetRegionLeftArrow(ALeft, ATop, AWidth, AHeight);\r\n jvSRightArrow:\r\n SetRegionRightArrow(ALeft, ATop, AWidth, AHeight);\r\n jvSRound:\r\n SetRegionRound(ALeft, ATop, AWidth, AHeight);\r\n jvSHex:\r\n SetRegionHex(ALeft, ATop, AWidth, AHeight);\r\n jvSOctagon:\r\n SetRegionOctagon(ALeft, ATop, AWidth, AHeight);\r\n jvSPar:\r\n SetRegionPar(ALeft, ATop, AWidth, AHeight);\r\n jvSDiamond:\r\n SetRegionDiamond(ALeft, ATop, AWidth, AHeight);\r\n jvSTriangleUp:\r\n SetRegionTriangleUp(ALeft, ATop, AWidth, AHeight);\r\n jvSTriangleDown:\r\n SetRegionTriangleDown(ALeft, ATop, AWidth, AHeight);\r\n jvSTriangleLeft:\r\n SetRegionTriangleLeft(ALeft, ATop, AWidth, AHeight);\r\n jvSTriangleRight:\r\n SetRegionTriangleRight(ALeft, ATop, AWidth, AHeight);\r\n jvSPentagon:\r\n SetRegionPentagon(ALeft, ATop, AWidth, AHeight);\r\n jvSRevPentagon:\r\n SetRegionRevPentagon(ALeft, ATop, AWidth, AHeight);\r\n jvSRing:\r\n SetRegionRing(ALeft, ATop, AWidth, AHeight);\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvShapedButton.SetBounds(ALeft, ATop, AWidth, AHeight: Integer);\r\nbegin\r\n inherited SetBounds(ALeft, ATop, AWidth, AHeight);\r\n SetButton(ALeft, ATop, AWidth, AHeight);\r\nend;\r\n\r\nprocedure TJvShapedButton.CNDrawItem(var Msg: TWMDrawItem);\r\nbegin\r\n case FButtonShape of\r\n jvSLeftArrow:\r\n CNDrawItemLeftArrow(Msg);\r\n jvSRightArrow:\r\n CNDrawItemRightArrow(Msg);\r\n jvSRound:\r\n CNDrawItemRound(Msg);\r\n jvSHex:\r\n CNDrawItemHex(Msg);\r\n jvSOctagon:\r\n CNDrawItemOctagon(Msg);\r\n jvSPar:\r\n CNDrawItemPar(Msg);\r\n jvSDiamond:\r\n CNDrawItemDiamond(Msg);\r\n jvSTriangleUp:\r\n CNDrawItemTriangleUp(Msg);\r\n jvSTriangleDown:\r\n CNDrawItemTriangleDown(Msg);\r\n jvSTriangleLeft:\r\n CNDrawItemTriangleLeft(Msg);\r\n jvSTriangleRight:\r\n CNDrawItemTriangleRight(Msg);\r\n jvSPentagon:\r\n CNDrawItemPentagon(Msg);\r\n jvSRevPentagon:\r\n CNDrawItemRevPentagon(Msg);\r\n jvSRing:\r\n CNDrawItemRing(Msg);\r\n end;\r\nend;\r\n\r\nprocedure TJvShapedButton.FontChanged;\r\nbegin\r\n inherited FontChanged;\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvShapedButton.EnabledChanged;\r\nbegin\r\n inherited EnabledChanged;\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvShapedButton.WMLButtonDblClk(var Msg: TWMLButtonDblClk);\r\nbegin\r\n Perform(WM_LBUTTONDOWN, Msg.Keys, {$IFDEF RTL230_UP}PointToLParam{$ELSE}LPARAM{$ENDIF RTL230_UP}(Msg.Pos));\r\nend;\r\n\r\nprocedure TJvShapedButton.SetButtonStyle(ADefault: Boolean);\r\nbegin\r\n if ADefault <> FIsFocused then\r\n begin\r\n FIsFocused := ADefault;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvShapedButton.MouseEnter(Control: TControl);\r\nbegin\r\n if csDesigning in ComponentState then\r\n Exit;\r\n if not FIsHot then\r\n begin\r\n FIsHot := True;\r\n Invalidate;\r\n inherited MouseEnter(Control);\r\n end;\r\nend;\r\n\r\nprocedure TJvShapedButton.MouseLeave(Control: TControl);\r\nbegin\r\n if FIsHot then\r\n begin\r\n FIsHot := False;\r\n Invalidate;\r\n inherited MouseLeave(Control);\r\n end;\r\nend;\r\n\r\nprocedure TJvShapedButton.SetHotColor(const Value: TColor);\r\nbegin\r\n FHotColor := Value;\r\nend;\r\n\r\nprocedure TJvShapedButton.SetFlat(const Value: Boolean);\r\nbegin\r\n FFlat := Value;\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvShapedButton.SetFlatBorderColor(const Value: TColor);\r\nbegin\r\n FFlatBorderColor := Value;\r\nend;\r\n\r\nprocedure TJvShapedButton.SetButtonShape(const Value: TJvButtonShapes);\r\nbegin\r\n if Value <> FButtonShape then\r\n begin\r\n FButtonShape := Value;\r\n if HandleAllocated then\r\n begin\r\n RecreateWnd;\r\n Invalidate;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvShapedButton.SetRegionOctagon(ALeft, ATop, AWidth, AHeight: Integer);\r\nvar\r\n x4, y4: Integer;\r\n hRegion: HRGN;\r\n Poly: array [0..7] of TPoint;\r\nbegin\r\n x4 := Width div 4;\r\n y4 := AHeight div 4;\r\n Poly[0] := Point(x4, 0);\r\n Poly[1] := Point(AWidth - x4, 0);\r\n Poly[2] := Point(AWidth, y4);\r\n Poly[3] := Point(AWidth, AHeight - y4);\r\n Poly[4] := Point(AWidth - x4, AHeight);\r\n Poly[5] := Point(x4, AHeight);\r\n Poly[6] := Point(0, AHeight - y4);\r\n Poly[7] := Point(0, y4);\r\n hRegion := CreatePolygonRgn(Poly, 8, WINDING);\r\n SetWindowRgn(Handle, hRegion, True);\r\nend;\r\n\r\nprocedure TJvShapedButton.CNDrawItemOctagon(var Msg: TWMDrawItem);\r\nvar\r\n OdsDown, OdsFocus, ActionFocus: Boolean;\r\n Rect: TRect;\r\n Poly: array [0..8] of TPoint;\r\n PolyBR: array [0..4] of TPoint;\r\n PolyTL: array [0..4] of TPoint;\r\n x4, y4, w, h: Integer;\r\n\r\n procedure SetPoly;\r\n begin\r\n w := Rect.Right - Rect.Left + 1;\r\n h := Rect.Bottom - Rect.Top + 1;\r\n x4 := w div 4;\r\n y4 := h div 4;\r\n Poly[0] := Point(Rect.Left + x4, Rect.Top);\r\n Poly[1] := Point(Rect.Right - x4, Rect.Top);\r\n Poly[2] := Point(Rect.Right, Rect.Top + y4);\r\n Poly[3] := Point(Rect.Right, Rect.Bottom - y4);\r\n Poly[4] := Point(Rect.Right - x4, Rect.Bottom);\r\n Poly[5] := Point(Rect.Left + x4, Rect.Bottom);\r\n Poly[6] := Point(Rect.Left, Rect.Bottom - y4);\r\n Poly[7] := Point(Rect.Left, y4);\r\n Poly[8] := Poly[0];\r\n end;\r\n\r\nbegin\r\n if csDestroying in ComponentState then\r\n Exit;\r\n // initialize\r\n FCanvas.Handle := Msg.DrawItemStruct^.hDC;\r\n Rect := ClientRect;\r\n Dec(Rect.Right);\r\n Dec(Rect.Bottom);\r\n SetPoly;\r\n with Msg.DrawItemStruct^ do\r\n begin\r\n OdsDown := itemState and ODS_SELECTED <> 0;\r\n OdsFocus := itemState and ODS_FOCUS <> 0;\r\n ActionFocus := ItemAction = ODA_FOCUS\r\n end;\r\n FBmp.Width := Width;\r\n FBmp.Height := Height;\r\n with FBmp.Canvas do\r\n begin\r\n Pen.Width := 2;\r\n Brush.Color := Color;\r\n if not ActionFocus then\r\n begin\r\n // fill with current Color\r\n Brush.Style := bsSolid;\r\n FillRect(Rect);\r\n end;\r\n // do not fill any more\r\n Brush.Style := bsClear;\r\n // draw border if default\r\n\r\n{ if Default or OdsFocus then\r\n begin\r\n Pen.Color := clWindowFrame;\r\n if not ActionFocus then\r\n Polyline(Poly);\r\n // reduce the area for further operations\r\n InflateRect (Rect, -1, -1);\r\n end;}\r\n // test code:\r\n //InflateRect (Rect, -1, -1);\r\n\r\n if FFlat and (not OdsDown) and (not FIsHot) and (not (csDesigning in ComponentState)) then\r\n begin\r\n Pen.Color := FFlatBorderColor;\r\n Polyline(Poly);\r\n end\r\n else\r\n if OdsDown then\r\n begin\r\n // draw gray border all around\r\n Pen.Color := clBtnShadow;\r\n if not ActionFocus then\r\n Polyline(Poly);\r\n // gray border (Bottom-Right)\r\n Pen.Color := clBtnHighlight;\r\n SetPoly;\r\n PolyBR[0] := Poly[1];\r\n PolyBR[1] := Poly[2];\r\n PolyBR[2] := Poly[3];\r\n PolyBR[3] := Poly[4];\r\n PolyBR[4] := Poly[5];\r\n Polyline(PolyBR);\r\n // white border (Top-Left)\r\n Pen.Color := clWindowFrame;\r\n PolyTL[0] := Poly[5];\r\n PolyTL[1] := Poly[6];\r\n PolyTL[2] := Poly[7];\r\n PolyTL[3] := Poly[0];\r\n PolyTL[4] := Poly[1];\r\n Polyline(PolyTL);\r\n // gray border (Bottom-Right, internal)\r\n Pen.Color := clBtnShadow;\r\n InflateRect(Rect, -1, -1);\r\n SetPoly;\r\n PolyBR[0] := Poly[1];\r\n PolyBR[1] := Poly[2];\r\n PolyBR[2] := Poly[3];\r\n PolyBR[3] := Poly[4];\r\n PolyBR[4] := Poly[5];\r\n Polyline(PolyBR);\r\n end\r\n else\r\n if not ActionFocus then\r\n begin\r\n // gray border (Bottom-Right)\r\n Pen.Color := clWindowFrame;\r\n SetPoly;\r\n PolyBR[0] := Poly[1];\r\n PolyBR[1] := Poly[2];\r\n PolyBR[2] := Poly[3];\r\n PolyBR[3] := Poly[4];\r\n PolyBR[4] := Poly[5];\r\n Polyline(PolyBR);\r\n // white border (Top-Left)\r\n Pen.Color := clBtnHighlight;\r\n PolyTL[0] := Poly[5];\r\n PolyTL[1] := Poly[6];\r\n PolyTL[2] := Poly[7];\r\n PolyTL[3] := Poly[0];\r\n PolyTL[4] := Poly[1];\r\n Polyline(PolyTL);\r\n // gray border (Bottom-Right, internal)\r\n Pen.Color := clBtnShadow;\r\n InflateRect(Rect, -1, -1);\r\n SetPoly;\r\n PolyBR[0] := Poly[1];\r\n PolyBR[1] := Poly[2];\r\n PolyBR[2] := Poly[3];\r\n PolyBR[3] := Poly[4];\r\n PolyBR[4] := Poly[5];\r\n Polyline(PolyBR);\r\n end;\r\n // smooth edges\r\n DoAntiAlias(FBmp);\r\n // draw the caption\r\n InflateRect(Rect, -Width div 5, -Height div 5);\r\n if OdsDown then\r\n begin\r\n Inc(Rect.Left, 2);\r\n Inc(Rect.Top, 2);\r\n end;\r\n Font := Self.Font;\r\n if FIsHot and not OdsDown then\r\n Font.Color := FHotColor;\r\n if not ActionFocus then\r\n DrawText(FBmp.Canvas, Caption, -1,\r\n Rect, DT_SINGLELINE or DT_CENTER or DT_VCENTER);\r\n\r\n // draw the focus Rect around the text\r\n Brush.Style := bsSolid;\r\n Pen.Color := clBlack;\r\n Brush.Color := clWhite;\r\n if FIsFocused or OdsFocus or ActionFocus then\r\n DrawFocusRect(Rect);\r\n end;\r\n FCanvas.Draw(0, 0, FBmp);\r\n FCanvas.Handle := 0;\r\n Msg.Result := 1; // message handled\r\nend;\r\n\r\nprocedure TJvShapedButton.SetRegionTriangleDown(ALeft, ATop, AWidth, AHeight: Integer);\r\nvar\r\n x2: Integer;\r\n hRegion: HRGN;\r\n Poly: array [0..2] of TPoint;\r\nbegin\r\n x2 := Width div 2;\r\n // y2:=AHeight div 2;\r\n Poly[0] := Point(0, 0);\r\n Poly[1] := Point(AWidth, 0);\r\n Poly[2] := Point(x2, AHeight);\r\n hRegion := CreatePolygonRgn(Poly, 3, WINDING);\r\n SetWindowRgn(Handle, hRegion, True);\r\nend;\r\n\r\nprocedure TJvShapedButton.SetRegionTriangleLeft(ALeft, ATop, AWidth, AHeight: Integer);\r\nvar\r\n y2: Integer;\r\n hRegion: HRGN;\r\n Poly: array [0..2] of TPoint;\r\nbegin\r\n // x2:=Width div 2;\r\n y2 := AHeight div 2;\r\n Poly[0] := Point(0, y2);\r\n Poly[1] := Point(AWidth, 0);\r\n Poly[2] := Point(AWidth, AHeight);\r\n hRegion := CreatePolygonRgn(Poly, 3, WINDING);\r\n SetWindowRgn(Handle, hRegion, True);\r\nend;\r\n\r\nprocedure TJvShapedButton.SetRegionTriangleRight(ALeft, ATop, AWidth, AHeight: Integer);\r\nvar\r\n y2: Integer;\r\n hRegion: HRGN;\r\n Poly: array [0..2] of TPoint;\r\nbegin\r\n // x2:=Width div 2;\r\n y2 := AHeight div 2;\r\n Poly[0] := Point(0, 0);\r\n Poly[1] := Point(AWidth, y2);\r\n Poly[2] := Point(0, AHeight);\r\n hRegion := CreatePolygonRgn(Poly, 3, WINDING);\r\n SetWindowRgn(Handle, hRegion, True);\r\nend;\r\n\r\nprocedure TJvShapedButton.SetRegionTriangleUp(ALeft, ATop, AWidth, AHeight: Integer);\r\nvar\r\n x2: Integer;\r\n hRegion: HRGN;\r\n Poly: array [0..2] of TPoint;\r\nbegin\r\n x2 := Width div 2;\r\n // y2:=AHeight div 2;\r\n Poly[0] := Point(x2, 0);\r\n Poly[1] := Point(AWidth, AHeight);\r\n Poly[2] := Point(0, AHeight);\r\n hRegion := CreatePolygonRgn(Poly, 3, WINDING);\r\n SetWindowRgn(Handle, hRegion, True);\r\nend;\r\n\r\nprocedure TJvShapedButton.CNDrawItemTriangleRight(var Msg: TWMDrawItem);\r\nvar\r\n OdsDown, OdsFocus, ActionFocus: Boolean;\r\n Rect: TRect;\r\n Poly: array [0..3] of TPoint;\r\n PolyBR: array [0..2] of TPoint;\r\n PolyTL: array [0..1] of TPoint;\r\n x2, y2, w, h: Integer;\r\n\r\n procedure SetPoly;\r\n begin\r\n w := Rect.Right - Rect.Left + 1;\r\n h := Rect.Bottom - Rect.Top + 1;\r\n x2 := w div 2;\r\n y2 := h div 2;\r\n Poly[0] := Point(Rect.Left, Rect.Top);\r\n Poly[1] := Point(Rect.Right, Rect.Top + y2);\r\n Poly[2] := Point(Rect.Left, Rect.Bottom);\r\n Poly[3] := Poly[0];\r\n end;\r\n\r\nbegin\r\n if csDestroying in ComponentState then\r\n Exit;\r\n // initialize\r\n FCanvas.Handle := Msg.DrawItemStruct^.hDC;\r\n Rect := ClientRect;\r\n Dec(Rect.Right);\r\n Dec(Rect.Bottom);\r\n SetPoly;\r\n with Msg.DrawItemStruct^ do\r\n begin\r\n OdsDown := itemState and ODS_SELECTED <> 0;\r\n OdsFocus := itemState and ODS_FOCUS <> 0;\r\n ActionFocus := ItemAction = ODA_FOCUS;\r\n end;\r\n FBmp.Width := Width;\r\n FBmp.Height := Height;\r\n with FBmp.Canvas do\r\n begin\r\n Pen.Width := 2;\r\n Brush.Color := Color;\r\n if not ActionFocus then\r\n begin\r\n // fill with current Color\r\n Brush.Style := bsSolid;\r\n FillRect(Rect);\r\n end;\r\n // do not fill any more\r\n Brush.Style := bsClear;\r\n // draw border if default\r\n\r\n{ if Default or OdsFocus then\r\n begin\r\n Pen.Color := clWindowFrame;\r\n if not ActionFocus then\r\n Polyline(Poly);\r\n // reduce the area for further operations\r\n InflateRect (Rect, -1, -1);\r\n end;}\r\n // test code:\r\n //InflateRect (Rect, -1, -1);\r\n\r\n if FFlat and (not OdsDown) and (not FIsHot) and (not (csDesigning in ComponentState)) then\r\n begin\r\n Pen.Color := FFlatBorderColor;\r\n Polyline(Poly);\r\n end\r\n else\r\n if OdsDown then\r\n begin\r\n // draw gray border all around\r\n Pen.Color := clBtnShadow;\r\n if not ActionFocus then\r\n Polyline(Poly);\r\n // gray border (Bottom-Right)\r\n Pen.Color := clBtnHighlight;\r\n SetPoly;\r\n PolyBR[0] := Poly[0];\r\n PolyBR[1] := Poly[1];\r\n PolyBR[2] := Poly[2];\r\n Polyline(PolyBR);\r\n // white border (Top-Left)\r\n Pen.Color := clWindowFrame;\r\n PolyTL[0] := Poly[2];\r\n PolyTL[1] := Poly[0];\r\n Polyline(PolyTL);\r\n // gray border (Bottom-Right, internal)\r\n Pen.Color := clBtnShadow;\r\n InflateRect(Rect, -1, -1);\r\n SetPoly;\r\n PolyBR[0] := Poly[0];\r\n PolyBR[1] := Poly[1];\r\n PolyBR[2] := Poly[2];\r\n Polyline(PolyBR);\r\n end\r\n else\r\n if not ActionFocus then\r\n begin\r\n // gray border (Bottom-Right)\r\n Pen.Color := clWindowFrame;\r\n SetPoly;\r\n PolyBR[0] := Poly[0];\r\n PolyBR[1] := Poly[1];\r\n PolyBR[2] := Poly[2];\r\n Polyline(PolyBR);\r\n // white border (Top-Left)\r\n Pen.Color := clBtnHighlight;\r\n PolyTL[0] := Poly[2];\r\n PolyTL[1] := Poly[0];\r\n Polyline(PolyTL);\r\n // gray border (Bottom-Right, internal)\r\n Pen.Color := clBtnShadow;\r\n InflateRect(Rect, -1, -1);\r\n SetPoly;\r\n PolyBR[0] := Poly[0];\r\n PolyBR[1] := Poly[1];\r\n PolyBR[2] := Poly[2];\r\n Polyline(PolyBR);\r\n end;\r\n // smooth edges\r\n DoAntiAlias(FBmp);\r\n // draw the caption\r\n InflateRect(Rect, -Width div 5, -Height div 5);\r\n if OdsDown then\r\n begin\r\n Inc(Rect.Left, 2);\r\n Inc(Rect.Top, 2);\r\n end;\r\n Font := Self.Font;\r\n if FIsHot and not OdsDown then\r\n Font.Color := FHotColor;\r\n if not ActionFocus then\r\n DrawText(FBmp.Canvas, Caption, -1,\r\n Rect, DT_SINGLELINE or DT_CENTER or DT_VCENTER);\r\n\r\n // draw the focus Rect around the text\r\n Brush.Style := bsSolid;\r\n Pen.Color := clBlack;\r\n Brush.Color := clWhite;\r\n if FIsFocused or OdsFocus or ActionFocus then\r\n DrawFocusRect(Rect);\r\n end;\r\n FCanvas.Draw(0, 0, FBmp);\r\n FCanvas.Handle := 0;\r\n Msg.Result := 1; // message handled\r\nend;\r\n\r\nprocedure TJvShapedButton.CNDrawItemTriangleUp(var Msg: TWMDrawItem);\r\nvar\r\n OdsDown, OdsFocus, ActionFocus: Boolean;\r\n Rect: TRect;\r\n Poly: array [0..3] of TPoint;\r\n PolyBR: array [0..2] of TPoint;\r\n PolyTL: array [0..1] of TPoint;\r\n x2, y2, w, h: Integer;\r\n\r\n procedure SetPoly;\r\n begin\r\n w := Rect.Right - Rect.Left + 1;\r\n h := Rect.Bottom - Rect.Top + 1;\r\n x2 := w div 2;\r\n y2 := h div 2;\r\n Poly[0] := Point(Rect.Left + x2, Rect.Top);\r\n Poly[1] := Point(Rect.Right, Rect.Bottom);\r\n Poly[2] := Point(Rect.Left, Rect.Bottom);\r\n Poly[3] := Poly[0];\r\n end;\r\n\r\nbegin\r\n if csDestroying in ComponentState then\r\n Exit;\r\n // initialize\r\n FCanvas.Handle := Msg.DrawItemStruct^.hDC;\r\n Rect := ClientRect;\r\n Dec(Rect.Right);\r\n Dec(Rect.Bottom);\r\n SetPoly;\r\n with Msg.DrawItemStruct^ do\r\n begin\r\n OdsDown := itemState and ODS_SELECTED <> 0;\r\n OdsFocus := itemState and ODS_FOCUS <> 0;\r\n ActionFocus := ItemAction = ODA_FOCUS;\r\n end;\r\n FBmp.Width := Width;\r\n FBmp.Height := Height;\r\n with FBmp.Canvas do\r\n begin\r\n Pen.Width := 2;\r\n Brush.Color := Color;\r\n if not ActionFocus then\r\n begin\r\n // fill with current Color\r\n Brush.Style := bsSolid;\r\n FillRect(Rect);\r\n end;\r\n // do not fill any more\r\n Brush.Style := bsClear;\r\n // draw border if default\r\n\r\n{ if Default or OdsFocus then\r\n begin\r\n Pen.Color := clWindowFrame;\r\n if not ActionFocus then\r\n Polyline(Poly);\r\n // reduce the area for further operations\r\n InflateRect (Rect, -1, -1);\r\n end;}\r\n // test code:\r\n //InflateRect (Rect, -1, -1);\r\n\r\n if FFlat and (not OdsDown) and (not FIsHot) and (not (csDesigning in ComponentState)) then\r\n begin\r\n Pen.Color := FFlatBorderColor;\r\n Polyline(Poly);\r\n end\r\n else\r\n if OdsDown then\r\n begin\r\n // draw gray border all around\r\n Pen.Color := clBtnShadow;\r\n if not ActionFocus then\r\n Polyline(Poly);\r\n // gray border (Bottom-Right)\r\n Pen.Color := clBtnHighlight;\r\n SetPoly;\r\n PolyBR[0] := Poly[0];\r\n PolyBR[1] := Poly[1];\r\n PolyBR[2] := Poly[2];\r\n Polyline(PolyBR);\r\n // white border (Top-Left)\r\n Pen.Color := clWindowFrame;\r\n PolyTL[0] := Poly[2];\r\n PolyTL[1] := Poly[0];\r\n Polyline(PolyTL);\r\n // gray border (Bottom-Right, internal)\r\n Pen.Color := clBtnShadow;\r\n InflateRect(Rect, -1, -1);\r\n SetPoly;\r\n PolyBR[0] := Poly[0];\r\n PolyBR[1] := Poly[1];\r\n PolyBR[2] := Poly[2];\r\n Polyline(PolyBR);\r\n end\r\n else\r\n if not ActionFocus then\r\n begin\r\n // gray border (Bottom-Right)\r\n Pen.Color := clWindowFrame;\r\n SetPoly;\r\n PolyBR[0] := Poly[0];\r\n PolyBR[1] := Poly[1];\r\n PolyBR[2] := Poly[2];\r\n Polyline(PolyBR);\r\n // white border (Top-Left)\r\n Pen.Color := clBtnHighlight;\r\n PolyTL[0] := Poly[2];\r\n PolyTL[1] := Poly[0];\r\n Polyline(PolyTL);\r\n // gray border (Bottom-Right, internal)\r\n Pen.Color := clBtnShadow;\r\n InflateRect(Rect, -1, -1);\r\n SetPoly;\r\n PolyBR[0] := Poly[0];\r\n PolyBR[1] := Poly[1];\r\n PolyBR[2] := Poly[2];\r\n Polyline(PolyBR);\r\n end;\r\n // smooth edges\r\n DoAntiAlias(FBmp);\r\n // draw the caption\r\n InflateRect(Rect, -Width div 5, -Height div 5);\r\n if OdsDown then\r\n begin\r\n Inc(Rect.Left, 2);\r\n Inc(Rect.Top, 2);\r\n end;\r\n Font := Self.Font;\r\n if FIsHot and not OdsDown then\r\n Font.Color := FHotColor;\r\n if not ActionFocus then\r\n DrawText(FBmp.Canvas, Caption, -1,\r\n Rect, DT_SINGLELINE or DT_CENTER or DT_VCENTER);\r\n\r\n // draw the focus Rect around the text\r\n Brush.Style := bsSolid;\r\n Pen.Color := clBlack;\r\n Brush.Color := clWhite;\r\n if FIsFocused or OdsFocus or ActionFocus then\r\n DrawFocusRect(Rect);\r\n end;\r\n FCanvas.Draw(0, 0, FBmp);\r\n FCanvas.Handle := 0;\r\n Msg.Result := 1; // message handled\r\nend;\r\n\r\nprocedure TJvShapedButton.CNDrawItemTriangleLeft(var Msg: TWMDrawItem);\r\nvar\r\n OdsDown, OdsFocus, ActionFocus: Boolean;\r\n Rect: TRect;\r\n Poly: array [0..3] of TPoint;\r\n PolyBR: array [0..1] of TPoint;\r\n PolyTL: array [0..2] of TPoint;\r\n x2, y2, w, h: Integer;\r\n\r\n procedure SetPoly;\r\n begin\r\n w := Rect.Right - Rect.Left + 1;\r\n h := Rect.Bottom - Rect.Top + 1;\r\n x2 := w div 2;\r\n y2 := h div 2;\r\n Poly[0] := Point(Rect.Left, Rect.Top + y2);\r\n Poly[1] := Point(Rect.Right, Rect.Top);\r\n Poly[2] := Point(Rect.Right, Rect.Bottom);\r\n Poly[3] := Poly[0];\r\n end;\r\n\r\nbegin\r\n if csDestroying in ComponentState then\r\n Exit;\r\n // initialize\r\n FCanvas.Handle := Msg.DrawItemStruct^.hDC;\r\n Rect := ClientRect;\r\n Dec(Rect.Right);\r\n Dec(Rect.Bottom);\r\n SetPoly;\r\n with Msg.DrawItemStruct^ do\r\n begin\r\n OdsDown := itemState and ODS_SELECTED <> 0;\r\n OdsFocus := itemState and ODS_FOCUS <> 0;\r\n ActionFocus := ItemAction = ODA_FOCUS;\r\n end;\r\n FBmp.Width := Width;\r\n FBmp.Height := Height;\r\n with FBmp.Canvas do\r\n begin\r\n Pen.Width := 2;\r\n Brush.Color := Color;\r\n if not ActionFocus then\r\n begin\r\n // fill with current Color\r\n Brush.Style := bsSolid;\r\n FillRect(Rect);\r\n end;\r\n // do not fill any more\r\n Brush.Style := bsClear;\r\n // draw border if default\r\n\r\n{ if Default or OdsFocus then\r\n begin\r\n Pen.Color := clWindowFrame;\r\n if not ActionFocus then\r\n Polyline(Poly);\r\n // reduce the area for further operations\r\n InflateRect (Rect, -1, -1);\r\n end;}\r\n // test code:\r\n //InflateRect (Rect, -1, -1);\r\n\r\n if FFlat and (not OdsDown) and (not FIsHot) and (not (csDesigning in ComponentState)) then\r\n begin\r\n Pen.Color := FFlatBorderColor;\r\n Polyline(Poly);\r\n end\r\n else\r\n if OdsDown then\r\n begin\r\n // draw gray border all around\r\n Pen.Color := clBtnShadow;\r\n if not ActionFocus then\r\n Polyline(Poly);\r\n // gray border (Bottom-Right)\r\n Pen.Color := clBtnHighlight;\r\n SetPoly;\r\n PolyBR[0] := Poly[1];\r\n PolyBR[1] := Poly[2];\r\n Polyline(PolyBR);\r\n // white border (Top-Left)\r\n Pen.Color := clWindowFrame;\r\n PolyTL[0] := Poly[2];\r\n PolyTL[1] := Poly[0];\r\n PolyTL[2] := Poly[1];\r\n Polyline(PolyTL);\r\n // gray border (Bottom-Right, internal)\r\n Pen.Color := clBtnShadow;\r\n InflateRect(Rect, -1, -1);\r\n SetPoly;\r\n PolyBR[0] := Poly[1];\r\n PolyBR[1] := Poly[2];\r\n Polyline(PolyBR);\r\n end\r\n else\r\n if not ActionFocus then\r\n begin\r\n // gray border (Bottom-Right)\r\n Pen.Color := clWindowFrame;\r\n SetPoly;\r\n PolyBR[0] := Poly[1];\r\n PolyBR[1] := Poly[2];\r\n Polyline(PolyBR);\r\n // white border (Top-Left)\r\n Pen.Color := clBtnHighlight;\r\n PolyTL[0] := Poly[2];\r\n PolyTL[1] := Poly[0];\r\n PolyTL[2] := Poly[1];\r\n Polyline(PolyTL);\r\n // gray border (Bottom-Right, internal)\r\n Pen.Color := clBtnShadow;\r\n InflateRect(Rect, -1, -1);\r\n SetPoly;\r\n PolyBR[0] := Poly[1];\r\n PolyBR[1] := Poly[2];\r\n Polyline(PolyBR);\r\n end;\r\n // smooth edges\r\n DoAntiAlias(FBmp);\r\n // draw the caption\r\n InflateRect(Rect, -Width div 5, -Height div 5);\r\n if OdsDown then\r\n begin\r\n Inc(Rect.Left, 2);\r\n Inc(Rect.Top, 2);\r\n end;\r\n Font := Self.Font;\r\n if FIsHot and not OdsDown then\r\n Font.Color := FHotColor;\r\n if not ActionFocus then\r\n DrawText(FBmp.Canvas, Caption, -1,\r\n Rect, DT_SINGLELINE or DT_CENTER or DT_VCENTER);\r\n\r\n // draw the focus Rect around the text\r\n Brush.Style := bsSolid;\r\n Pen.Color := clBlack;\r\n Brush.Color := clWhite;\r\n if FIsFocused or OdsFocus or ActionFocus then\r\n DrawFocusRect(Rect);\r\n end;\r\n FCanvas.Draw(0, 0, FBmp);\r\n FCanvas.Handle := 0;\r\n Msg.Result := 1; // message handled\r\nend;\r\n\r\nprocedure TJvShapedButton.CNDrawItemTriangleDown(var Msg: TWMDrawItem);\r\nvar\r\n OdsDown, OdsFocus, ActionFocus: Boolean;\r\n Rect: TRect;\r\n Poly: array [0..3] of TPoint;\r\n PolyBR: array [0..1] of TPoint;\r\n PolyTL: array [0..2] of TPoint;\r\n x2, y2, w, h: Integer;\r\n\r\n procedure SetPoly;\r\n begin\r\n w := Rect.Right - Rect.Left + 1;\r\n h := Rect.Bottom - Rect.Top + 1;\r\n x2 := w div 2;\r\n y2 := h div 2;\r\n Poly[0] := Point(Rect.Left, Rect.Top);\r\n Poly[1] := Point(Rect.Right, Rect.Top);\r\n Poly[2] := Point(Rect.Left + x2, Rect.Bottom);\r\n Poly[3] := Poly[0];\r\n end;\r\n\r\nbegin\r\n if csDestroying in ComponentState then\r\n Exit;\r\n // initialize\r\n FCanvas.Handle := Msg.DrawItemStruct^.hDC;\r\n Rect := ClientRect;\r\n Dec(Rect.Right);\r\n Dec(Rect.Bottom);\r\n SetPoly;\r\n with Msg.DrawItemStruct^ do\r\n begin\r\n OdsDown := itemState and ODS_SELECTED <> 0;\r\n OdsFocus := itemState and ODS_FOCUS <> 0;\r\n ActionFocus := ItemAction = ODA_FOCUS;\r\n end;\r\n FBmp.Width := Width;\r\n FBmp.Height := Height;\r\n with FBmp.Canvas do\r\n begin\r\n Pen.Width := 2;\r\n Brush.Color := Color;\r\n if not ActionFocus then\r\n begin\r\n // fill with current Color\r\n Brush.Style := bsSolid;\r\n FillRect(Rect);\r\n end;\r\n // do not fill any more\r\n Brush.Style := bsClear;\r\n // draw border if default\r\n\r\n{ if Default or OdsFocus then\r\n begin\r\n Pen.Color := clWindowFrame;\r\n if not ActionFocus then\r\n Polyline(Poly);\r\n // reduce the area for further operations\r\n InflateRect (Rect, -1, -1);\r\n end;}\r\n // test code:\r\n //InflateRect (Rect, -1, -1);\r\n\r\n if FFlat and (not OdsDown) and (not FIsHot) and (not (csDesigning in ComponentState)) then\r\n begin\r\n Pen.Color := FFlatBorderColor;\r\n Polyline(Poly);\r\n end\r\n else\r\n if OdsDown then\r\n begin\r\n // draw gray border all around\r\n Pen.Color := clBtnShadow;\r\n if not ActionFocus then\r\n Polyline(Poly);\r\n // gray border (Bottom-Right)\r\n Pen.Color := clBtnHighlight;\r\n SetPoly;\r\n PolyBR[0] := Poly[1];\r\n PolyBR[1] := Poly[2];\r\n Polyline(PolyBR);\r\n // white border (Top-Left)\r\n Pen.Color := clWindowFrame;\r\n PolyTL[0] := Poly[2];\r\n PolyTL[1] := Poly[0];\r\n PolyTL[2] := Poly[1];\r\n Polyline(PolyTL);\r\n // gray border (Bottom-Right, internal)\r\n Pen.Color := clBtnShadow;\r\n InflateRect(Rect, -1, -1);\r\n SetPoly;\r\n PolyBR[0] := Poly[1];\r\n PolyBR[1] := Poly[2];\r\n Polyline(PolyBR);\r\n end\r\n else\r\n if not ActionFocus then\r\n begin\r\n // gray border (Bottom-Right)\r\n Pen.Color := clWindowFrame;\r\n SetPoly;\r\n PolyBR[0] := Poly[1];\r\n PolyBR[1] := Poly[2];\r\n Polyline(PolyBR);\r\n // white border (Top-Left)\r\n Pen.Color := clBtnHighlight;\r\n PolyTL[0] := Poly[2];\r\n PolyTL[1] := Poly[0];\r\n PolyTL[2] := Poly[1];\r\n Polyline(PolyTL);\r\n // gray border (Bottom-Right, internal)\r\n Pen.Color := clBtnShadow;\r\n InflateRect(Rect, -1, -1);\r\n SetPoly;\r\n PolyBR[0] := Poly[1];\r\n PolyBR[1] := Poly[2];\r\n Polyline(PolyBR);\r\n end;\r\n // smooth edges\r\n DoAntiAlias(FBmp);\r\n // draw the caption\r\n InflateRect(Rect, -Width div 5, -Height div 5);\r\n if OdsDown then\r\n begin\r\n Inc(Rect.Left, 2);\r\n Inc(Rect.Top, 2);\r\n end;\r\n Font := Self.Font;\r\n if FIsHot and not OdsDown then\r\n Font.Color := FHotColor;\r\n if not ActionFocus then\r\n DrawText(FBmp.Canvas, Caption, -1,\r\n Rect, DT_SINGLELINE or DT_CENTER or DT_VCENTER);\r\n\r\n // draw the focus Rect around the text\r\n Brush.Style := bsSolid;\r\n Pen.Color := clBlack;\r\n Brush.Color := clWhite;\r\n if FIsFocused or OdsFocus or ActionFocus then\r\n DrawFocusRect(Rect);\r\n end;\r\n FCanvas.Draw(0, 0, FBmp);\r\n FCanvas.Handle := 0;\r\n Msg.Result := 1; // message handled\r\nend;\r\n\r\nprocedure TJvShapedButton.CNDrawItemPar(var Msg: TWMDrawItem);\r\nvar\r\n OdsDown, OdsFocus, ActionFocus: Boolean;\r\n Rect: TRect;\r\n Poly: array [0..4] of TPoint;\r\n PolyBR: array [0..2] of TPoint;\r\n PolyTL: array [0..2] of TPoint;\r\n x4, y2, w, h: Integer;\r\n\r\n procedure SetPoly;\r\n begin\r\n w := Rect.Right - Rect.Left + 1;\r\n h := Rect.Bottom - Rect.Top + 1;\r\n x4 := w div 4;\r\n y2 := h div 2;\r\n Poly[0] := Point(Rect.Left + x4, Rect.Top);\r\n Poly[1] := Point(Rect.Right, Rect.Top);\r\n Poly[2] := Point(Rect.Right - x4, Rect.Bottom);\r\n Poly[3] := Point(Rect.Left, Rect.Bottom);\r\n Poly[4] := Poly[0];\r\n end;\r\n\r\nbegin\r\n if csDestroying in ComponentState then\r\n Exit;\r\n // initialize\r\n FCanvas.Handle := Msg.DrawItemStruct^.hDC;\r\n Rect := ClientRect;\r\n Dec(Rect.Right);\r\n Dec(Rect.Bottom);\r\n SetPoly;\r\n with Msg.DrawItemStruct^ do\r\n begin\r\n OdsDown := itemState and ODS_SELECTED <> 0;\r\n OdsFocus := itemState and ODS_FOCUS <> 0;\r\n ActionFocus := ItemAction = ODA_FOCUS;\r\n end;\r\n FBmp.Width := Width;\r\n FBmp.Height := Height;\r\n with FBmp.Canvas do\r\n begin\r\n Pen.Width := 2;\r\n Brush.Color := Color;\r\n if not ActionFocus then\r\n begin\r\n // fill with current Color\r\n Brush.Style := bsSolid;\r\n FillRect(Rect);\r\n end;\r\n // do not fill any more\r\n Brush.Style := bsClear;\r\n // draw border if default\r\n\r\n{ if Default or OdsFocus then\r\n begin\r\n Pen.Color := clWindowFrame;\r\n if not ActionFocus then\r\n Polyline(Poly);\r\n // reduce the area for further operations\r\n InflateRect (Rect, -1, -1);\r\n end;}\r\n // test code:\r\n //InflateRect (Rect, -1, -1);\r\n\r\n if FFlat and (not OdsDown) and (not FIsHot) and (not (csDesigning in ComponentState)) then\r\n begin\r\n Pen.Color := FFlatBorderColor;\r\n Polyline(Poly);\r\n end\r\n else\r\n if OdsDown then\r\n begin\r\n // draw gray border all around\r\n Pen.Color := clBtnShadow;\r\n if not ActionFocus then\r\n Polyline(Poly);\r\n // gray border (Bottom-Right)\r\n Pen.Color := clBtnHighlight;\r\n SetPoly;\r\n PolyBR[0] := Poly[1];\r\n PolyBR[1] := Poly[2];\r\n PolyBR[2] := Poly[3];\r\n Polyline(PolyBR);\r\n // white border (Top-Left)\r\n Pen.Color := clWindowFrame;\r\n PolyTL[0] := Poly[3];\r\n PolyTL[1] := Poly[0];\r\n PolyTL[2] := Poly[1];\r\n Polyline(PolyTL);\r\n // gray border (Bottom-Right, internal)\r\n Pen.Color := clBtnShadow;\r\n InflateRect(Rect, -1, -1);\r\n SetPoly;\r\n PolyBR[0] := Poly[1];\r\n PolyBR[1] := Poly[2];\r\n PolyBR[2] := Poly[3];\r\n Polyline(PolyBR);\r\n end\r\n else\r\n if not ActionFocus then\r\n begin\r\n // gray border (Bottom-Right)\r\n Pen.Color := clWindowFrame;\r\n SetPoly;\r\n PolyBR[0] := Poly[1];\r\n PolyBR[1] := Poly[2];\r\n PolyBR[2] := Poly[3];\r\n Polyline(PolyBR);\r\n // white border (Top-Left)\r\n Pen.Color := clBtnHighlight;\r\n PolyTL[0] := Poly[3];\r\n PolyTL[1] := Poly[0];\r\n PolyTL[2] := Poly[1];\r\n Polyline(PolyTL);\r\n // gray border (Bottom-Right, internal)\r\n Pen.Color := clBtnShadow;\r\n InflateRect(Rect, -1, -1);\r\n SetPoly;\r\n PolyBR[0] := Poly[1];\r\n PolyBR[1] := Poly[2];\r\n PolyBR[2] := Poly[3];\r\n Polyline(PolyBR);\r\n end;\r\n // smooth edges\r\n DoAntiAlias(FBmp);\r\n // draw the caption\r\n InflateRect(Rect, -Width div 5, -Height div 5);\r\n if OdsDown then\r\n begin\r\n Inc(Rect.Left, 2);\r\n Inc(Rect.Top, 2);\r\n end;\r\n Font := Self.Font;\r\n if FIsHot and not OdsDown then\r\n Font.Color := FHotColor;\r\n if not ActionFocus then\r\n DrawText(FBmp.Canvas, Caption, -1,\r\n Rect, DT_SINGLELINE or DT_CENTER or DT_VCENTER);\r\n\r\n // draw the focus Rect around the text\r\n Brush.Style := bsSolid;\r\n Pen.Color := clBlack;\r\n Brush.Color := clWhite;\r\n if FIsFocused or OdsFocus or ActionFocus then\r\n DrawFocusRect(Rect);\r\n end;\r\n FCanvas.Draw(0, 0, FBmp);\r\n FCanvas.Handle := 0;\r\n Msg.Result := 1; // message handled\r\nend;\r\n\r\nprocedure TJvShapedButton.SetRegionPar(ALeft, ATop, AWidth, AHeight: Integer);\r\nvar\r\n hRegion: HRGN;\r\n Poly: array [0..3] of TPoint;\r\n x4: Integer;\r\nbegin\r\n x4 := Width div 4;\r\n // y2:=AHeight div 2;\r\n Poly[0] := Point(x4, 0);\r\n Poly[1] := Point(AWidth, 0);\r\n Poly[2] := Point(AWidth - x4, AHeight);\r\n Poly[3] := Point(0, AHeight);\r\n hRegion := CreatePolygonRgn(Poly, 4, WINDING);\r\n SetWindowRgn(Handle, hRegion, True);\r\nend;\r\n\r\nprocedure TJvShapedButton.SetRegionDiamond(ALeft, ATop, AWidth,\r\n AHeight: Integer);\r\nvar\r\n hRegion: HRGN;\r\n Poly: array [0..3] of TPoint;\r\n x2, y2: Integer;\r\nbegin\r\n x2 := AWidth div 2;\r\n y2 := AHeight div 2;\r\n Poly[0] := Point(x2, 0);\r\n Poly[1] := Point(AWidth, y2);\r\n Poly[2] := Point(x2, AHeight);\r\n Poly[3] := Point(0, y2);\r\n hRegion := CreatePolygonRgn(Poly, 4, WINDING);\r\n SetWindowRgn(Handle, hRegion, True);\r\nend;\r\n\r\nprocedure TJvShapedButton.SetRegionHex(ALeft, ATop, AWidth,\r\n AHeight: Integer);\r\nvar\r\n hRegion: HRGN;\r\n Poly: array [0..5] of TPoint;\r\n x4, y2: Integer;\r\nbegin\r\n x4 := Width div 4;\r\n y2 := AHeight div 2;\r\n Poly[0] := Point(x4, 0);\r\n Poly[1] := Point(AWidth - x4, 0);\r\n Poly[2] := Point(AWidth, y2);\r\n Poly[3] := Point(AWidth - x4, AHeight);\r\n Poly[4] := Point(x4, AHeight);\r\n Poly[5] := Point(0, y2);\r\n hRegion := CreatePolygonRgn(Poly, 6, WINDING);\r\n SetWindowRgn(Handle, hRegion, True);\r\nend;\r\n\r\nprocedure TJvShapedButton.SetRegionLeftArrow(ALeft, ATop, AWidth,\r\n AHeight: Integer);\r\nvar\r\n hRegion: HRGN;\r\n Poly: array [0..5] of TPoint;\r\n x8, y2: Integer;\r\nbegin\r\n if FFlatArrow then\r\n x8 := Width div 16\r\n else\r\n x8 := Width div 8;\r\n y2 := AHeight div 2;\r\n Poly[0] := Point(0, 0);\r\n Poly[1] := Point(AWidth - x8, 0);\r\n Poly[2] := Point(AWidth, y2);\r\n Poly[3] := Point(AWidth - x8, AHeight);\r\n Poly[4] := Point(0, AHeight);\r\n Poly[5] := Point(x8, y2);\r\n hRegion := CreatePolygonRgn(Poly, 6, WINDING);\r\n SetWindowRgn(Handle, hRegion, True);\r\nend;\r\n\r\nprocedure TJvShapedButton.SetRegionPentagon(ALeft, ATop, AWidth,\r\n AHeight: Integer);\r\nvar\r\n hRegion: HRGN;\r\n Poly: array [0..4] of TPoint;\r\n x2: Integer;\r\nbegin\r\n x2 := AWidth div 2;\r\n CalcPentagon(AWidth, AHeight);\r\n Poly[0] := Point(x2, 0);\r\n Poly[1] := Point(AWidth, FYP);\r\n Poly[2] := Point(AWidth - FXP, AHeight);\r\n Poly[3] := Point(FXP, AHeight);\r\n Poly[4] := Point(0, FYP);\r\n hRegion := CreatePolygonRgn(Poly, 5, WINDING);\r\n SetWindowRgn(Handle, hRegion, True);\r\nend;\r\n\r\nprocedure TJvShapedButton.SetRegionRevPentagon(ALeft, ATop, AWidth,\r\n AHeight: Integer);\r\nvar\r\n hRegion: HRGN;\r\n Poly: array [0..4] of TPoint;\r\n x2: Integer;\r\nbegin\r\n x2 := AWidth div 2;\r\n CalcPentagon(AWidth, AHeight);\r\n Poly[0] := Point(FXP, 0);\r\n Poly[1] := Point(AWidth - FXP, 0);\r\n Poly[2] := Point(AWidth, AHeight - FYP);\r\n Poly[3] := Point(x2, AHeight);\r\n Poly[4] := Point(0, AHeight - FYP);\r\n\r\n hRegion := CreatePolygonRgn(Poly, 5, WINDING);\r\n SetWindowRgn(Handle, hRegion, True);\r\nend;\r\n\r\nprocedure TJvShapedButton.SetRegionRightArrow(ALeft, ATop, AWidth,\r\n AHeight: Integer);\r\nvar\r\n hRegion: HRGN;\r\n Poly: array [0..5] of TPoint;\r\n x8, y2: Integer;\r\nbegin\r\n if FFlatArrow then\r\n x8 := Width div 16\r\n else\r\n x8 := Width div 8;\r\n y2 := AHeight div 2;\r\n Poly[0] := Point(x8, 0);\r\n Poly[1] := Point(AWidth, 0);\r\n Poly[2] := Point(AWidth - x8, y2);\r\n Poly[3] := Point(AWidth, AHeight);\r\n Poly[4] := Point(x8, AHeight);\r\n Poly[5] := Point(0, y2);\r\n hRegion := CreatePolygonRgn(Poly, 6, WINDING);\r\n SetWindowRgn(Handle, hRegion, True);\r\nend;\r\n\r\nprocedure TJvShapedButton.SetRegionRing(ALeft, ATop, AWidth,\r\n AHeight: Integer);\r\nvar\r\n rgn1, rgn2, rgn3: HRGN;\r\n x4, y4: Integer;\r\nbegin\r\n x4 := AWidth div 4 ;\r\n y4 := AHeight div 4;\r\n rgn1 := CreateEllipticRgn(0, 0, AWidth+1, AHeight+1);\r\n rgn2 := CreateEllipticRgn(x4, y4, AWidth - x4, AHeight - x4);\r\n rgn3 := 0; // Remove Warning\r\n Combinergn(rgn3, rgn1, rgn2, RGN_XOR);\r\n SetWindowRgn(Handle, rgn3, True);\r\nend;\r\n\r\nprocedure TJvShapedButton.SetRegionRound(ALeft, ATop, AWidth,\r\n AHeight: Integer);\r\nvar\r\n hRegion: HRGN;\r\nbegin\r\n hRegion := CreateEllipticRgn(0, 0, AWidth, AHeight);\r\n SetWindowRgn(Handle, hRegion, True);\r\nend;\r\n\r\nprocedure TJvShapedButton.CalcPentagon(AWidth, AHeight: Integer);\r\nvar\r\n x2, y2, R: Integer;\r\n A: Extended;\r\nbegin\r\n A := Pi / 2 - (2 * Pi / 5);\r\n x2 := AWidth div 2;\r\n y2 := AHeight div 2;\r\n R := Round(x2 / Cos(A));\r\n FYP := y2 - Round(R * Sin(A));\r\n A := Pi - (4 * Pi / 5);\r\n FXP := Round(x2 - R * Sin(A));\r\nend;\r\n\r\nprocedure TJvShapedButton.SetFlatArrow(const Value: Boolean);\r\nbegin\r\n if Value <> FFlatArrow then\r\n begin\r\n FFlatArrow := Value;\r\n SetBounds(Left, Top, Width, Height);\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvShapedButton.CNDrawItemLeftArrow(var Msg: TWMDrawItem);\r\nvar\r\n OdsDown, OdsFocus, ActionFocus: Boolean;\r\n Rect: TRect;\r\n Poly: array [0..6] of TPoint;\r\n PolyBR: array [0..3] of TPoint;\r\n PolyTL: array [0..3] of TPoint;\r\n x8, y2, w, h: Integer;\r\n\r\n procedure SetPoly;\r\n begin\r\n w := Rect.Right - Rect.Left + 1;\r\n h := Rect.Bottom - Rect.Top + 1;\r\n if FFlatArrow then\r\n x8 := w div 16\r\n else\r\n x8 := w div 8;\r\n y2 := h div 2;\r\n Poly[0] := Point(Rect.Left, Rect.Top);\r\n Poly[1] := Point(Rect.Right - x8, Rect.Top);\r\n Poly[2] := Point(Rect.Right, y2);\r\n Poly[3] := Point(Rect.Right - x8, Rect.Bottom);\r\n Poly[4] := Point(0, Rect.Bottom);\r\n Poly[5] := Point(x8, y2);\r\n Poly[6] := Poly[0];\r\n end;\r\n\r\nbegin\r\n if csDestroying in ComponentState then\r\n Exit;\r\n // initialize\r\n FCanvas.Handle := Msg.DrawItemStruct^.hDC;\r\n Rect := ClientRect;\r\n Dec(Rect.Right);\r\n Dec(Rect.Bottom);\r\n SetPoly;\r\n with Msg.DrawItemStruct^ do\r\n begin\r\n OdsDown := itemState and ODS_SELECTED <> 0;\r\n OdsFocus := itemState and ODS_FOCUS <> 0;\r\n ActionFocus := ItemAction = ODA_FOCUS;\r\n end;\r\n FBmp.Width := Width;\r\n FBmp.Height := Height;\r\n with FBmp.Canvas do\r\n begin\r\n Pen.Width := 2;\r\n Brush.Color := Color;\r\n if not ActionFocus then\r\n begin\r\n // fill with current Color\r\n Brush.Style := bsSolid;\r\n FillRect(Rect);\r\n end;\r\n // do not fill any more\r\n Brush.Style := bsClear;\r\n // draw border if default\r\n\r\n{ if Default or OdsFocus then\r\n begin\r\n Pen.Color := clWindowFrame;\r\n if not ActionFocus then\r\n Polyline(Poly);\r\n // reduce the area for further operations\r\n InflateRect (Rect, -1, -1);\r\n end;}\r\n // test code:\r\n //InflateRect (Rect, -1, -1);\r\n\r\n if FFlat and (not OdsDown) and (not FIsHot) and (not (csDesigning in ComponentState)) then\r\n begin\r\n Pen.Color := FFlatBorderColor;\r\n Polyline(Poly);\r\n end\r\n else\r\n if OdsDown then\r\n begin\r\n // draw gray border all around\r\n Pen.Color := clBtnShadow;\r\n if not ActionFocus then\r\n Polyline(Poly);\r\n // gray border (Bottom-Right)\r\n Pen.Color := clBtnHighlight;\r\n SetPoly;\r\n PolyBR[0] := Poly[1];\r\n PolyBR[1] := Poly[2];\r\n PolyBR[2] := Poly[3];\r\n PolyBR[3] := Poly[4];\r\n Polyline(PolyBR);\r\n // white border (Top-Left)\r\n Pen.Color := clWindowFrame;\r\n PolyTL[0] := Poly[4];\r\n PolyTL[1] := Poly[5];\r\n PolyTL[2] := Poly[0];\r\n PolyTL[3] := Poly[1];\r\n Polyline(PolyTL);\r\n // gray border (Bottom-Right, internal)\r\n Pen.Color := clBtnShadow;\r\n InflateRect(Rect, -1, -1);\r\n SetPoly;\r\n PolyBR[0] := Poly[1];\r\n PolyBR[1] := Poly[2];\r\n PolyBR[2] := Poly[3];\r\n PolyBR[3] := Poly[4];\r\n Polyline(PolyBR);\r\n end\r\n else\r\n if not ActionFocus then\r\n begin\r\n // gray border (Bottom-Right)\r\n Pen.Color := clWindowFrame;\r\n SetPoly;\r\n PolyBR[0] := Poly[1];\r\n PolyBR[1] := Poly[2];\r\n PolyBR[2] := Poly[3];\r\n PolyBR[3] := Poly[4];\r\n Polyline(PolyBR);\r\n // white border (Top-Left)\r\n Pen.Color := clBtnHighlight;\r\n PolyTL[0] := Poly[4];\r\n PolyTL[1] := Poly[5];\r\n PolyTL[2] := Poly[0];\r\n PolyTL[3] := Poly[1];\r\n Polyline(PolyTL);\r\n // gray border (Bottom-Right, internal)\r\n Pen.Color := clBtnShadow;\r\n InflateRect(Rect, -1, -1);\r\n SetPoly;\r\n PolyBR[0] := Poly[1];\r\n PolyBR[1] := Poly[2];\r\n PolyBR[2] := Poly[3];\r\n PolyBR[3] := Poly[4];\r\n Polyline(PolyBR);\r\n end;\r\n // smooth edges\r\n DoAntiAlias(FBmp);\r\n // draw the caption\r\n InflateRect(Rect, -Width div 5, -Height div 5);\r\n if OdsDown then\r\n begin\r\n Inc(Rect.Left, 2);\r\n Inc(Rect.Top, 2);\r\n end;\r\n Font := Self.Font;\r\n if FIsHot and not OdsDown then\r\n Font.Color := FHotColor;\r\n if not ActionFocus then\r\n DrawText(FBmp.Canvas, Caption, -1,\r\n Rect, DT_SINGLELINE or DT_CENTER or DT_VCENTER);\r\n\r\n // draw the focus Rect around the text\r\n Brush.Style := bsSolid;\r\n Pen.Color := clBlack;\r\n Brush.Color := clWhite;\r\n if FIsFocused or OdsFocus or ActionFocus then\r\n DrawFocusRect(Rect);\r\n end;\r\n FCanvas.Draw(0, 0, FBmp);\r\n FCanvas.Handle := 0;\r\n Msg.Result := 1; // message handled\r\nend;\r\n\r\nprocedure TJvShapedButton.CNDrawItemRightArrow(var Msg: TWMDrawItem);\r\nvar\r\n OdsDown, OdsFocus, ActionFocus: Boolean;\r\n Rect: TRect;\r\n Poly: array [0..6] of TPoint;\r\n PolyBR: array [0..3] of TPoint;\r\n PolyTL: array [0..3] of TPoint;\r\n x8, y2, w, h: Integer;\r\n\r\n procedure SetPoly;\r\n begin\r\n w := Rect.Right - Rect.Left + 1;\r\n h := Rect.Bottom - Rect.Top + 1;\r\n if FFlatArrow then\r\n x8 := w div 16\r\n else\r\n x8 := w div 8;\r\n y2 := h div 2;\r\n Poly[0] := Point(Rect.Left + x8, Rect.Top);\r\n Poly[1] := Point(Rect.Right, Rect.Top);\r\n Poly[2] := Point(Rect.Right - x8, y2);\r\n Poly[3] := Point(Rect.Right, Rect.Bottom);\r\n Poly[4] := Point(Rect.Left + x8, Rect.Bottom);\r\n Poly[5] := Point(Rect.Left, y2);\r\n Poly[6] := Poly[0];\r\n end;\r\n\r\nbegin\r\n if csDestroying in ComponentState then\r\n Exit;\r\n // initialize\r\n FCanvas.Handle := Msg.DrawItemStruct^.hDC;\r\n Rect := ClientRect;\r\n Dec(Rect.Right);\r\n Dec(Rect.Bottom);\r\n SetPoly;\r\n with Msg.DrawItemStruct^ do\r\n begin\r\n OdsDown := itemState and ODS_SELECTED <> 0;\r\n OdsFocus := itemState and ODS_FOCUS <> 0;\r\n ActionFocus := ItemAction = ODA_FOCUS;\r\n end;\r\n FBmp.Width := Width;\r\n FBmp.Height := Height;\r\n with FBmp.Canvas do\r\n begin\r\n Pen.Width := 2;\r\n Brush.Color := Color;\r\n if not ActionFocus then\r\n begin\r\n // fill with current Color\r\n Brush.Style := bsSolid;\r\n FillRect(Rect);\r\n end;\r\n // do not fill any more\r\n Brush.Style := bsClear;\r\n // draw border if default\r\n\r\n{ if Default or OdsFocus then\r\n begin\r\n Pen.Color := clWindowFrame;\r\n if not ActionFocus then\r\n Polyline(Poly);\r\n // reduce the area for further operations\r\n InflateRect (Rect, -1, -1);\r\n end;}\r\n // test code:\r\n //InflateRect (Rect, -1, -1);\r\n\r\n if FFlat and (not OdsDown) and (not FIsHot) and (not (csDesigning in ComponentState)) then\r\n begin\r\n Pen.Color := FFlatBorderColor;\r\n Polyline(Poly);\r\n end\r\n else\r\n if OdsDown then\r\n begin\r\n // draw gray border all around\r\n Pen.Color := clBtnShadow;\r\n if not ActionFocus then\r\n Polyline(Poly);\r\n // gray border (Bottom-Right)\r\n Pen.Color := clBtnHighlight;\r\n SetPoly;\r\n PolyBR[0] := Poly[1];\r\n PolyBR[1] := Poly[2];\r\n PolyBR[2] := Poly[3];\r\n PolyBR[3] := Poly[4];\r\n Polyline(PolyBR);\r\n // white border (Top-Left)\r\n Pen.Color := clWindowFrame;\r\n PolyTL[0] := Poly[4];\r\n PolyTL[1] := Poly[5];\r\n PolyTL[2] := Poly[0];\r\n PolyTL[3] := Poly[1];\r\n Polyline(PolyTL);\r\n // gray border (Bottom-Right, internal)\r\n Pen.Color := clBtnShadow;\r\n InflateRect(Rect, -1, -1);\r\n SetPoly;\r\n PolyBR[0] := Poly[1];\r\n PolyBR[1] := Poly[2];\r\n PolyBR[2] := Poly[3];\r\n PolyBR[3] := Poly[4];\r\n Polyline(PolyBR);\r\n end\r\n else\r\n if not ActionFocus then\r\n begin\r\n // gray border (Bottom-Right)\r\n Pen.Color := clWindowFrame;\r\n SetPoly;\r\n PolyBR[0] := Poly[1];\r\n PolyBR[1] := Poly[2];\r\n PolyBR[2] := Poly[3];\r\n PolyBR[3] := Poly[4];\r\n Polyline(PolyBR);\r\n // white border (Top-Left)\r\n Pen.Color := clBtnHighlight;\r\n PolyTL[0] := Poly[4];\r\n PolyTL[1] := Poly[5];\r\n PolyTL[2] := Poly[0];\r\n PolyTL[3] := Poly[1];\r\n Polyline(PolyTL);\r\n // gray border (Bottom-Right, internal)\r\n Pen.Color := clBtnShadow;\r\n InflateRect(Rect, -1, -1);\r\n SetPoly;\r\n PolyBR[0] := Poly[1];\r\n PolyBR[1] := Poly[2];\r\n PolyBR[2] := Poly[3];\r\n PolyBR[3] := Poly[4];\r\n Polyline(PolyBR);\r\n end;\r\n // smooth edges\r\n DoAntiAlias(FBmp);\r\n // draw the caption\r\n InflateRect(Rect, -Width div 5, -Height div 5);\r\n if OdsDown then\r\n begin\r\n Inc(Rect.Left, 2);\r\n Inc(Rect.Top, 2);\r\n end;\r\n Font := Self.Font;\r\n if FIsHot and not OdsDown then\r\n Font.Color := FHotColor;\r\n if not ActionFocus then\r\n DrawText(FBmp.Canvas, Caption, -1,\r\n Rect, DT_SINGLELINE or DT_CENTER or DT_VCENTER);\r\n\r\n // draw the focus Rect around the text\r\n Brush.Style := bsSolid;\r\n Pen.Color := clBlack;\r\n Brush.Color := clWhite;\r\n if FIsFocused or OdsFocus or ActionFocus then\r\n DrawFocusRect(Rect);\r\n end;\r\n FCanvas.Draw(0, 0, FBmp);\r\n FCanvas.Handle := 0;\r\n Msg.Result := 1; // message handled\r\nend;\r\n\r\nprocedure TJvShapedButton.CNDrawItemRing(var Msg: TWMDrawItem);\r\nvar\r\n OdsDown, {OdsFocus,} ActionFocus: Boolean;\r\n R, Ri: TRect;\r\n x4, y4: Integer;\r\nbegin\r\n if csDestroying in ComponentState then\r\n Exit;\r\n // initialize\r\n x4 := (Width div 4) - 1;\r\n y4 := (Height div 4) - 1;\r\n FCanvas.Handle := Msg.DrawItemStruct^.hDC;\r\n R := ClientRect;\r\n Ri := Rect(R.Left + x4, R.Top + y4, R.Right - x4, R.Bottom - y4);\r\n with Msg.DrawItemStruct^ do\r\n begin\r\n OdsDown := itemState and ODS_SELECTED <> 0;\r\n //OdsFocus := itemState and ODS_FOCUS <> 0;\r\n ActionFocus := ItemAction = ODA_FOCUS;\r\n end;\r\n\r\n FBmp.PixelFormat := pf24bit;\r\n FBmp.Width := Width;\r\n FBmp.Height := Height;\r\n\r\n with FBmp.Canvas do\r\n begin\r\n Pen.Width := 2;\r\n Brush.Color := Self.Color;\r\n if not ActionFocus then\r\n begin\r\n // fill with current Color\r\n Brush.Style := bsSolid;\r\n FillRect(R);\r\n end;\r\n Dec(R.Right);\r\n Dec(R.Bottom);\r\n // do not fill any more\r\n Brush.Style := bsClear;\r\n // draw border if default\r\n{ if Default or OdsFocus then\r\n begin\r\n Pen.Color := clWindowFrame;\r\n if not ActionFocus then\r\n begin\r\n Ellipse(R.Left, R.Top, R.Right, R.Bottom);\r\n Ellipse(Ri.Left, Ri.Top, Ri.Right, Ri.Bottom);\r\n end;\r\n // reduce the area for further operations\r\n InflateRect(R, -1, -1);\r\n InflateRect(Ri, 1, 1);\r\n end; }\r\n\r\n if FFlat and (not OdsDown) and (not FIsHot) and (not (csDesigning in ComponentState)) then\r\n begin\r\n Pen.Color := FFlatBorderColor;\r\n Ellipse(R.Left, R.Top, R.Right, R.Bottom);\r\n Ellipse(Ri.Left, Ri.Top, Ri.Right, Ri.Bottom);\r\n end\r\n else\r\n if OdsDown then\r\n begin\r\n // draw gray border all around\r\n Pen.Color := clBtnShadow;\r\n if not ActionFocus then\r\n begin\r\n Ellipse(R.Left, R.Top, R.Right, R.Bottom);\r\n Ellipse(Ri.Left, Ri.Top, Ri.Right, Ri.Bottom);\r\n end;\r\n // white border (Bottom-Right)\r\n Pen.Color := clBtnHighlight;\r\n Arc(R.Left, R.Top, R.Right, R.Bottom, // ellipse\r\n R.Left, R.Bottom, // start\r\n R.Right, R.Top); // end\r\n Pen.Color := clBtnShadow;\r\n Arc(Ri.Left, Ri.Top, Ri.Right, Ri.Bottom, // ellipse\r\n R.Left, R.Bottom, // start\r\n R.Right, R.Top); // end\r\n\r\n // gray border (Top-Left)\r\n Pen.Color := clBtnShadow;\r\n Arc(R.Left, R.Top, R.Right, R.Bottom, // ellipse\r\n R.Right, R.Top, // start\r\n R.Left, R.Bottom); // end\r\n Pen.Color := clBtnHighlight;\r\n Arc(Ri.Left, Ri.Top, Ri.Right, Ri.Bottom, // ellipse\r\n R.Right, R.Top, // start\r\n R.Left, R.Bottom); // end\r\n\r\n // gray border (Top-Left, internal)\r\n Pen.Color := clBtnShadow;\r\n InflateRect(R, -1, -1);\r\n InflateRect(Ri, 1, 1);\r\n // Arc (Rect.Left, Rect.Top, Rect.Right, Rect.Bottom, // ellipse\r\n // Rect.Right, Rect.Top, // start\r\n // Rect.Left, Rect.Bottom); // end\r\n end\r\n else\r\n if not ActionFocus then\r\n begin\r\n // gray border (Bottom-Right)\r\n Pen.Color := clWindowFrame;\r\n Arc(R.Left, R.Top, R.Right, R.Bottom, // ellipse\r\n R.Left, R.Bottom, // start\r\n R.Right, R.Top); // end\r\n Pen.Color := clBtnHighlight;\r\n Arc(Ri.Left, Ri.Top, Ri.Right, Ri.Bottom, // ellipse\r\n R.Left, R.Bottom, // start\r\n R.Right, R.Top); // end\r\n\r\n // white border (Top-Left)\r\n Pen.Color := clBtnHighlight;\r\n Arc(R.Left, R.Top, R.Right, R.Bottom, // ellipse\r\n R.Right, R.Top, // start\r\n R.Left, R.Bottom); // end\r\n Pen.Color := clBtnShadow;\r\n Arc(Ri.Left, Ri.Top, Ri.Right, Ri.Bottom, // ellipse\r\n R.Right, R.Top, // start\r\n R.Left, R.Bottom); // end\r\n\r\n // gray border (Bottom-Right, internal)\r\n Pen.Color := clBtnShadow;\r\n InflateRect(R, -1, -1);\r\n InflateRect(Ri, 1, 1);\r\n Arc(R.Left, R.Top, R.Right, R.Bottom, // ellipse\r\n R.Left, R.Bottom, // start\r\n R.Right, R.Top); // end\r\n Pen.Color := clBtnHighlight;\r\n Arc(Ri.Left, Ri.Top, Ri.Right, Ri.Bottom, // ellipse\r\n R.Left, R.Bottom, // start\r\n R.Right, R.Top); // end\r\n\r\n end;\r\n // smooth edges\r\n DoAntiAlias(FBmp);\r\n // draw the caption\r\n{ InflateRect (Rect, - Width div 5, - Height div 5);\r\n if OdsDown then\r\n begin\r\n Inc (Rect.Left, 2);\r\n Inc (Rect.Top, 2);\r\n end;\r\n Font := Self.Font;\r\n if not ActionFocus then\r\n DrawText(FBmp.Canvas, Caption, -1,\r\n Rect, DT_SINGLELINE or DT_CENTER or DT_VCENTER);\r\n\r\n // draw the focus Rect around the text\r\n Brush.Style := bsSolid;\r\n Pen.Color:= clBlack;\r\n Brush.Color := clWhite;\r\n if FIsFocused or OdsFocus or ActionFocus then\r\n DrawFocusRect (Rect);}\r\n end;\r\n FBmp.Transparent := True;\r\n FBmp.TransparentColor := Self.Color;\r\n FCanvas.Draw(0, 0, FBmp);\r\n FCanvas.Handle := 0;\r\n Msg.Result := 1; // message handled\r\nend;\r\n\r\nprocedure TJvShapedButton.CNDrawItemRound(var Msg: TWMDrawItem);\r\nvar\r\n OdsDown, OdsFocus, ActionFocus: Boolean;\r\n Rect: TRect;\r\nbegin\r\n if csDestroying in ComponentState then\r\n Exit;\r\n // initialize\r\n FCanvas.Handle := Msg.DrawItemStruct^.hDC;\r\n Rect := ClientRect;\r\n Dec(Rect.Right);\r\n Dec(Rect.Bottom);\r\n with Msg.DrawItemStruct^ do\r\n begin\r\n OdsDown := itemState and ODS_SELECTED <> 0;\r\n OdsFocus := itemState and ODS_FOCUS <> 0;\r\n ActionFocus := ItemAction = ODA_FOCUS;\r\n end;\r\n\r\n FBmp.Width := Width;\r\n FBmp.Height := Height;\r\n FBmp.PixelFormat := pf24bit;\r\n\r\n with FBmp.Canvas do\r\n begin\r\n Pen.Width := 2;\r\n Brush.Color := Color;\r\n if not ActionFocus then\r\n begin\r\n // fill with current Color\r\n Brush.Style := bsSolid;\r\n FillRect(Rect);\r\n end;\r\n // do not fill any more\r\n Brush.Style := bsClear;\r\n // draw border if default\r\n{ if Default or OdsFocus then\r\n begin\r\n Pen.Color := clWindowFrame;\r\n if not ActionFocus then\r\n Ellipse(Rect.Left, Rect.Top,\r\n Rect.Right, Rect.Bottom);\r\n // reduce the area for further operations\r\n InflateRect(Rect, -1, -1);\r\n end;}\r\n\r\n if FFlat and (not OdsDown) and (not FIsHot) and (not (csDesigning in ComponentState)) then\r\n begin\r\n Pen.Color := FFlatBorderColor;\r\n Ellipse(Rect.Left, Rect.Top, Rect.Right, Rect.Bottom);\r\n end\r\n else\r\n if OdsDown then\r\n begin\r\n // draw gray border all around\r\n Pen.Color := clBtnShadow;\r\n if not ActionFocus then\r\n Ellipse(Rect.Left, Rect.Top, Rect.Right, Rect.Bottom);\r\n // white border (Bottom-Right)\r\n Pen.Color := clBtnHighlight;\r\n Arc(Rect.Left, Rect.Top, Rect.Right, Rect.Bottom, // ellipse\r\n Rect.Left, Rect.Bottom, // start\r\n Rect.Right, Rect.Top); // end\r\n // gray border (Top-Left)\r\n Pen.Color := clBtnShadow;\r\n Arc(Rect.Left, Rect.Top, Rect.Right, Rect.Bottom, // ellipse\r\n Rect.Right, Rect.Top, // start\r\n Rect.Left, Rect.Bottom); // end\r\n // gray border (Top-Left, internal)\r\n Pen.Color := clBtnShadow;\r\n InflateRect(Rect, -1, -1);\r\n // Arc (Rect.Left, Rect.Top, Rect.Right, Rect.Bottom, // ellipse\r\n // Rect.Right, Rect.Top, // start\r\n // Rect.Left, Rect.Bottom); // end\r\n end\r\n else\r\n if not ActionFocus then\r\n begin\r\n // gray border (Bottom-Right)\r\n Pen.Color := clWindowFrame;\r\n Arc(Rect.Left, Rect.Top, Rect.Right, Rect.Bottom, // ellipse\r\n Rect.Left, Rect.Bottom, // start\r\n Rect.Right, Rect.Top); // end\r\n // white border (Top-Left)\r\n Pen.Color := clBtnHighlight;\r\n Arc(Rect.Left, Rect.Top, Rect.Right, Rect.Bottom, // ellipse\r\n Rect.Right, Rect.Top, // start\r\n Rect.Left, Rect.Bottom); // end\r\n // gray border (Bottom-Right, internal)\r\n Pen.Color := clBtnShadow;\r\n InflateRect(Rect, -1, -1);\r\n Arc(Rect.Left, Rect.Top, Rect.Right, Rect.Bottom, // ellipse\r\n Rect.Left, Rect.Bottom, // start\r\n Rect.Right, Rect.Top); // end\r\n end;\r\n // smooth edges\r\n DoAntiAlias(FBmp);\r\n // draw the caption\r\n InflateRect(Rect, -Width div 5, -Height div 5);\r\n if OdsDown then\r\n begin\r\n Inc(Rect.Left, 2);\r\n Inc(Rect.Top, 2);\r\n end;\r\n Font := Self.Font;\r\n if not ActionFocus then\r\n DrawText(FBmp.Canvas, Caption, -1,\r\n Rect, DT_SINGLELINE or DT_CENTER or DT_VCENTER);\r\n\r\n // draw the focus Rect around the text\r\n Brush.Style := bsSolid;\r\n Pen.Color := clBlack;\r\n Brush.Color := clWhite;\r\n if FIsFocused or OdsFocus or ActionFocus then\r\n DrawFocusRect(Rect);\r\n end;\r\n FCanvas.Draw(0, 0, FBmp);\r\n FCanvas.Handle := 0;\r\n Msg.Result := 1; // message handled\r\nend;\r\n\r\nprocedure TJvShapedButton.CNDrawItemPentagon(var Msg: TWMDrawItem);\r\nvar\r\n OdsDown, OdsFocus, ActionFocus: Boolean;\r\n Rect: TRect;\r\n Poly: array [0..5] of TPoint;\r\n PolyBR: array [0..3] of TPoint;\r\n PolyTL: array [0..2] of TPoint;\r\n x2, y2, w, h: Integer;\r\n\r\n procedure SetPoly;\r\n begin\r\n w := Rect.Right - Rect.Left + 1;\r\n h := Rect.Bottom - Rect.Top + 1;\r\n x2 := w div 2;\r\n y2 := h div 2;\r\n Poly[0] := Point(Rect.Left + x2, Rect.Top);\r\n Poly[1] := Point(Rect.Right, Rect.Top + FYP);\r\n Poly[2] := Point(Rect.Right - FXP, Rect.Bottom);\r\n Poly[3] := Point(Rect.Left + FXP, Rect.Bottom);\r\n Poly[4] := Point(Rect.Left, Rect.Top + FYP);\r\n Poly[5] := Poly[0];\r\n end;\r\n\r\nbegin\r\n if csDestroying in ComponentState then\r\n Exit;\r\n // initialize\r\n FCanvas.Handle := Msg.DrawItemStruct^.hDC;\r\n Rect := ClientRect;\r\n Dec(Rect.Right);\r\n Dec(Rect.Bottom);\r\n SetPoly;\r\n with Msg.DrawItemStruct^ do\r\n begin\r\n OdsDown := itemState and ODS_SELECTED <> 0;\r\n OdsFocus := itemState and ODS_FOCUS <> 0;\r\n ActionFocus := ItemAction = ODA_FOCUS;\r\n end;\r\n FBmp.Width := Width;\r\n FBmp.Height := Height;\r\n\r\n with FBmp.Canvas do\r\n begin\r\n Pen.Width := 2;\r\n Brush.Color := Color;\r\n if not ActionFocus then\r\n begin\r\n // fill with current Color\r\n Brush.Style := bsSolid;\r\n FillRect(Rect);\r\n end;\r\n // do not fill any more\r\n Brush.Style := bsClear;\r\n // draw border if default\r\n\r\n{ if Default or OdsFocus then\r\n begin\r\n Pen.Color := clWindowFrame;\r\n if not ActionFocus then\r\n Polyline(Poly);\r\n // reduce the area for further operations\r\n InflateRect (Rect, -1, -1);\r\n end;}\r\n // test code:\r\n //InflateRect (Rect, -1, -1);\r\n\r\n if FFlat and (not OdsDown) and (not FIsHot) and (not (csDesigning in ComponentState)) then\r\n begin\r\n Pen.Color := FFlatBorderColor;\r\n Polyline(Poly);\r\n end\r\n else\r\n if OdsDown then\r\n begin\r\n // draw gray border all around\r\n Pen.Color := clBtnShadow;\r\n if not ActionFocus then\r\n Polyline(Poly);\r\n // gray border (Bottom-Right)\r\n Pen.Color := clBtnHighlight;\r\n SetPoly;\r\n PolyBR[0] := Poly[0];\r\n PolyBR[1] := Poly[1];\r\n PolyBR[2] := Poly[2];\r\n PolyBR[3] := Poly[3];\r\n Polyline(PolyBR);\r\n // white border (Top-Left)\r\n Pen.Color := clWindowFrame;\r\n PolyTL[0] := Poly[3];\r\n PolyTL[1] := Poly[4];\r\n PolyTL[2] := Poly[0];\r\n Polyline(PolyTL);\r\n // gray border (Bottom-Right, internal)\r\n Pen.Color := clBtnShadow;\r\n InflateRect(Rect, -1, -1);\r\n SetPoly;\r\n PolyBR[0] := Poly[0];\r\n PolyBR[1] := Poly[1];\r\n PolyBR[2] := Poly[2];\r\n PolyBR[3] := Poly[3];\r\n Polyline(PolyBR);\r\n end\r\n else\r\n if not ActionFocus then\r\n begin\r\n // gray border (Bottom-Right)\r\n Pen.Color := clWindowFrame;\r\n SetPoly;\r\n PolyBR[0] := Poly[0];\r\n PolyBR[1] := Poly[1];\r\n PolyBR[2] := Poly[2];\r\n PolyBR[3] := Poly[3];\r\n Polyline(PolyBR);\r\n // white border (Top-Left)\r\n Pen.Color := clBtnHighlight;\r\n PolyTL[0] := Poly[3];\r\n PolyTL[1] := Poly[4];\r\n PolyTL[2] := Poly[0];\r\n Polyline(PolyTL);\r\n // gray border (Bottom-Right, internal)\r\n Pen.Color := clBtnShadow;\r\n InflateRect(Rect, -1, -1);\r\n SetPoly;\r\n PolyBR[0] := Poly[0];\r\n PolyBR[1] := Poly[1];\r\n PolyBR[2] := Poly[2];\r\n PolyBR[3] := Poly[3];\r\n Polyline(PolyBR);\r\n end;\r\n // smooth edges\r\n DoAntiAlias(FBmp);\r\n // draw the caption\r\n InflateRect(Rect, -Width div 5, -Height div 5);\r\n if OdsDown then\r\n begin\r\n Inc(Rect.Left, 2);\r\n Inc(Rect.Top, 2);\r\n end;\r\n Font := Self.Font;\r\n if FIsHot and not OdsDown then\r\n Font.Color := FHotColor;\r\n if not ActionFocus then\r\n DrawText(FBmp.Canvas, Caption, -1,\r\n Rect, DT_SINGLELINE or DT_CENTER or DT_VCENTER);\r\n\r\n // draw the focus Rect around the text\r\n Brush.Style := bsSolid;\r\n Pen.Color := clBlack;\r\n Brush.Color := clWhite;\r\n if FIsFocused or OdsFocus or ActionFocus then\r\n DrawFocusRect(Rect);\r\n end;\r\n FCanvas.Draw(0, 0, FBmp);\r\n FCanvas.Handle := 0;\r\n Msg.Result := 1; // message handled\r\nend;\r\n\r\nprocedure TJvShapedButton.CNDrawItemRevPentagon(var Msg: TWMDrawItem);\r\nvar\r\n OdsDown, OdsFocus, ActionFocus: Boolean;\r\n Rect: TRect;\r\n Poly: array [0..5] of TPoint;\r\n PolyBR: array [0..2] of TPoint;\r\n PolyTL: array [0..3] of TPoint;\r\n x2, y2, w, h: Integer;\r\n\r\n procedure SetPoly;\r\n begin\r\n w := Rect.Right - Rect.Left + 1;\r\n h := Rect.Bottom - Rect.Top + 1;\r\n x2 := w div 2;\r\n y2 := h div 2;\r\n Poly[0] := Point(Rect.Left + FXP, Rect.Top);\r\n Poly[1] := Point(Rect.Right - FXP, Rect.Top);\r\n Poly[2] := Point(Rect.Right, Rect.Bottom - FYP);\r\n Poly[3] := Point(Rect.Left + x2, Rect.Bottom);\r\n Poly[4] := Point(Rect.Left, Rect.Bottom - FYP);\r\n Poly[5] := Poly[0];\r\n end;\r\n\r\nbegin\r\n if csDestroying in ComponentState then\r\n Exit;\r\n // initialize\r\n FCanvas.Handle := Msg.DrawItemStruct^.hDC;\r\n Rect := ClientRect;\r\n Dec(Rect.Right);\r\n Dec(Rect.Bottom);\r\n SetPoly;\r\n with Msg.DrawItemStruct^ do\r\n begin\r\n OdsDown := itemState and ODS_SELECTED <> 0;\r\n OdsFocus := itemState and ODS_FOCUS <> 0;\r\n ActionFocus := ItemAction = ODA_FOCUS;\r\n end;\r\n FBmp.Width := Width;\r\n FBmp.Height := Height;\r\n with FBmp.Canvas do\r\n begin\r\n Pen.Width := 2;\r\n Brush.Color := Color;\r\n if not ActionFocus then\r\n begin\r\n // fill with current Color\r\n Brush.Style := bsSolid;\r\n FillRect(Rect);\r\n end;\r\n // do not fill any more\r\n Brush.Style := bsClear;\r\n // draw border if default\r\n\r\n{ if Default or OdsFocus then\r\n begin\r\n Pen.Color := clWindowFrame;\r\n if not ActionFocus then\r\n Polyline(Poly);\r\n // reduce the area for further operations\r\n InflateRect (Rect, -1, -1);\r\n end;}\r\n // test code:\r\n //InflateRect (Rect, -1, -1);\r\n\r\n if FFlat and (not OdsDown) and (not FIsHot) and (not (csDesigning in ComponentState)) then\r\n begin\r\n Pen.Color := FFlatBorderColor;\r\n Polyline(Poly);\r\n end\r\n else\r\n if OdsDown then\r\n begin\r\n // draw gray border all around\r\n Pen.Color := clBtnShadow;\r\n if not ActionFocus then\r\n Polyline(Poly);\r\n // gray border (Bottom-Right)\r\n Pen.Color := clBtnHighlight;\r\n SetPoly;\r\n PolyBR[0] := Poly[1];\r\n PolyBR[1] := Poly[2];\r\n PolyBR[2] := Poly[3];\r\n Polyline(PolyBR);\r\n // white border (Top-Left)\r\n Pen.Color := clWindowFrame;\r\n PolyTL[0] := Poly[3];\r\n PolyTL[1] := Poly[4];\r\n PolyTL[2] := Poly[0];\r\n PolyTL[3] := Poly[1];\r\n Polyline(PolyTL);\r\n // gray border (Bottom-Right, internal)\r\n Pen.Color := clBtnShadow;\r\n InflateRect(Rect, -1, -1);\r\n SetPoly;\r\n PolyBR[0] := Poly[1];\r\n PolyBR[1] := Poly[2];\r\n PolyBR[2] := Poly[3];\r\n Polyline(PolyBR);\r\n end\r\n else\r\n if not ActionFocus then\r\n begin\r\n // gray border (Bottom-Right)\r\n Pen.Color := clWindowFrame;\r\n SetPoly;\r\n PolyBR[0] := Poly[1];\r\n PolyBR[1] := Poly[2];\r\n PolyBR[2] := Poly[3];\r\n Polyline(PolyBR);\r\n // white border (Top-Left)\r\n Pen.Color := clBtnHighlight;\r\n PolyTL[0] := Poly[3];\r\n PolyTL[1] := Poly[4];\r\n PolyTL[2] := Poly[0];\r\n PolyTL[3] := Poly[1];\r\n Polyline(PolyTL);\r\n // gray border (Bottom-Right, internal)\r\n Pen.Color := clBtnShadow;\r\n InflateRect(Rect, -1, -1);\r\n SetPoly;\r\n PolyBR[0] := Poly[1];\r\n PolyBR[1] := Poly[2];\r\n PolyBR[2] := Poly[3];\r\n Polyline(PolyBR);\r\n end;\r\n // smooth edges\r\n DoAntiAlias(FBmp);\r\n // draw the caption\r\n InflateRect(Rect, -Width div 5, -Height div 5);\r\n if OdsDown then\r\n begin\r\n Inc(Rect.Left, 2);\r\n Inc(Rect.Top, 2);\r\n end;\r\n Font := Self.Font;\r\n if FIsHot and not OdsDown then\r\n Font.Color := FHotColor;\r\n if not ActionFocus then\r\n DrawText(FBmp.Canvas, Caption, -1,\r\n Rect, DT_SINGLELINE or DT_CENTER or DT_VCENTER);\r\n\r\n // draw the focus Rect around the text\r\n Brush.Style := bsSolid;\r\n Pen.Color := clBlack;\r\n Brush.Color := clWhite;\r\n if FIsFocused or OdsFocus or ActionFocus then\r\n DrawFocusRect(Rect);\r\n end;\r\n FCanvas.Draw(0, 0, FBmp);\r\n FCanvas.Handle := 0;\r\n Msg.Result := 1; // message handled\r\nend;\r\n\r\nprocedure TJvShapedButton.CNDrawItemHex(var Msg: TWMDrawItem);\r\nvar\r\n OdsDown, OdsFocus, ActionFocus: Boolean;\r\n Rect: TRect;\r\n Poly: array [0..6] of TPoint;\r\n PolyBR: array [0..3] of TPoint;\r\n PolyTL: array [0..3] of TPoint;\r\n x4, y2, w, h: Integer;\r\n\r\n procedure SetPoly;\r\n begin\r\n w := Rect.Right - Rect.Left + 1;\r\n h := Rect.Bottom - Rect.Top + 1;\r\n x4 := w div 4;\r\n y2 := h div 2;\r\n Poly[0] := Point(Rect.Left + x4, Rect.Top);\r\n Poly[1] := Point(Rect.Right - x4, Rect.Top);\r\n Poly[2] := Point(Rect.Right, y2);\r\n Poly[3] := Point(Rect.Right - x4, Rect.Bottom);\r\n Poly[4] := Point(Rect.Left + x4, Rect.Bottom);\r\n Poly[5] := Point(Rect.Left, y2);\r\n Poly[6] := Poly[0];\r\n end;\r\n\r\nbegin\r\n if csDestroying in ComponentState then\r\n Exit;\r\n // initialize\r\n FCanvas.Handle := Msg.DrawItemStruct^.hDC;\r\n Rect := ClientRect;\r\n Dec(Rect.Right);\r\n Dec(Rect.Bottom);\r\n SetPoly;\r\n with Msg.DrawItemStruct^ do\r\n begin\r\n OdsDown := itemState and ODS_SELECTED <> 0;\r\n OdsFocus := itemState and ODS_FOCUS <> 0;\r\n ActionFocus := ItemAction = ODA_FOCUS;\r\n end;\r\n FBmp.Width := Width;\r\n FBmp.Height := Height;\r\n with FBmp.Canvas do\r\n begin\r\n Pen.Width := 2;\r\n Brush.Color := Color;\r\n if not ActionFocus then\r\n begin\r\n // fill with current Color\r\n Brush.Style := bsSolid;\r\n FillRect(Rect);\r\n end;\r\n // do not fill any more\r\n Brush.Style := bsClear;\r\n // draw border if default\r\n\r\n{ if Default or OdsFocus then\r\n begin\r\n Pen.Color := clWindowFrame;\r\n if not ActionFocus then\r\n Polyline(Poly);\r\n // reduce the area for further operations\r\n InflateRect (Rect, -1, -1);\r\n end;}\r\n // test code:\r\n //InflateRect (Rect, -1, -1);\r\n\r\n if FFlat and (not OdsDown) and (not FIsHot) and (not (csDesigning in ComponentState)) then\r\n begin\r\n Pen.Color := FFlatBorderColor;\r\n Polyline(Poly);\r\n end\r\n else\r\n if OdsDown then\r\n begin\r\n // draw gray border all around\r\n Pen.Color := clBtnShadow;\r\n if not ActionFocus then\r\n Polyline(Poly);\r\n // gray border (Bottom-Right)\r\n Pen.Color := clBtnHighlight;\r\n SetPoly;\r\n PolyBR[0] := Poly[1];\r\n PolyBR[1] := Poly[2];\r\n PolyBR[2] := Poly[3];\r\n PolyBR[3] := Poly[4];\r\n Polyline(PolyBR);\r\n // white border (Top-Left)\r\n Pen.Color := clWindowFrame;\r\n PolyTL[0] := Poly[4];\r\n PolyTL[1] := Poly[5];\r\n PolyTL[2] := Poly[0];\r\n PolyTL[3] := Poly[1];\r\n Polyline(PolyTL);\r\n // gray border (Bottom-Right, internal)\r\n Pen.Color := clBtnShadow;\r\n InflateRect(Rect, -1, -1);\r\n SetPoly;\r\n PolyBR[0] := Poly[1];\r\n PolyBR[1] := Poly[2];\r\n PolyBR[2] := Poly[3];\r\n PolyBR[3] := Poly[4];\r\n Polyline(PolyBR);\r\n end\r\n else\r\n if not ActionFocus then\r\n begin\r\n // gray border (Bottom-Right)\r\n Pen.Color := clWindowFrame;\r\n SetPoly;\r\n PolyBR[0] := Poly[1];\r\n PolyBR[1] := Poly[2];\r\n PolyBR[2] := Poly[3];\r\n PolyBR[3] := Poly[4];\r\n Polyline(PolyBR);\r\n // white border (Top-Left)\r\n Pen.Color := clBtnHighlight;\r\n PolyTL[0] := Poly[4];\r\n PolyTL[1] := Poly[5];\r\n PolyTL[2] := Poly[0];\r\n PolyTL[3] := Poly[1];\r\n Polyline(PolyTL);\r\n // gray border (Bottom-Right, internal)\r\n Pen.Color := clBtnShadow;\r\n InflateRect(Rect, -1, -1);\r\n SetPoly;\r\n PolyBR[0] := Poly[1];\r\n PolyBR[1] := Poly[2];\r\n PolyBR[2] := Poly[3];\r\n PolyBR[3] := Poly[4];\r\n Polyline(PolyBR);\r\n end;\r\n // smooth edges\r\n DoAntiAlias(FBmp);\r\n // draw the caption\r\n InflateRect(Rect, -Width div 5, -Height div 5);\r\n if OdsDown then\r\n begin\r\n Inc(Rect.Left, 2);\r\n Inc(Rect.Top, 2);\r\n end;\r\n Font := Self.Font;\r\n if FIsHot and not OdsDown then\r\n Font.Color := FHotColor;\r\n if not ActionFocus then\r\n DrawText(FBmp.Canvas, Caption, -1,\r\n Rect, DT_SINGLELINE or DT_CENTER or DT_VCENTER);\r\n\r\n // draw the focus Rect around the text\r\n Brush.Style := bsSolid;\r\n Pen.Color := clBlack;\r\n Brush.Color := clWhite;\r\n if FIsFocused or OdsFocus or ActionFocus then\r\n DrawFocusRect(Rect);\r\n end;\r\n FCanvas.Draw(0, 0, FBmp);\r\n FCanvas.Handle := 0;\r\n Msg.Result := 1; // message handled\r\nend;\r\n\r\nprocedure TJvShapedButton.CNDrawItemDiamond(var Msg: TWMDrawItem);\r\nvar\r\n OdsDown, OdsFocus, ActionFocus: Boolean;\r\n Rect: TRect;\r\n Poly: array [0..4] of TPoint;\r\n PolyBR: array [0..2] of TPoint;\r\n PolyTL: array [0..2] of TPoint;\r\n x2, y2, w, h: Integer;\r\n\r\n procedure SetPoly;\r\n begin\r\n w := Rect.Right - Rect.Left + 1;\r\n h := Rect.Bottom - Rect.Top + 1;\r\n x2 := w div 2;\r\n y2 := h div 2;\r\n Poly[0] := Point(Rect.Left + x2, Rect.Top);\r\n Poly[1] := Point(Rect.Right, Rect.Top + y2);\r\n Poly[2] := Point(Rect.Left + x2, Rect.Bottom);\r\n Poly[3] := Point(Rect.Left, Rect.Top + y2);\r\n Poly[4] := Poly[0];\r\n end;\r\n\r\nbegin\r\n if csDestroying in ComponentState then\r\n Exit;\r\n // initialize\r\n FCanvas.Handle := Msg.DrawItemStruct^.hDC;\r\n Rect := ClientRect;\r\n Dec(Rect.Right);\r\n Dec(Rect.Bottom);\r\n SetPoly;\r\n with Msg.DrawItemStruct^ do\r\n begin\r\n OdsDown := itemState and ODS_SELECTED <> 0;\r\n OdsFocus := itemState and ODS_FOCUS <> 0;\r\n ActionFocus := ItemAction = ODA_FOCUS;\r\n end;\r\n FBmp.Width := Width;\r\n FBmp.Height := Height;\r\n with FBmp.Canvas do\r\n begin\r\n Pen.Width := 2;\r\n Brush.Color := Color;\r\n if not ActionFocus then\r\n begin\r\n // fill with current Color\r\n Brush.Style := bsSolid;\r\n FillRect(Rect);\r\n end;\r\n // do not fill any more\r\n Brush.Style := bsClear;\r\n // draw border if default\r\n\r\n{ if Default or OdsFocus then\r\n begin\r\n Pen.Color := clWindowFrame;\r\n if not ActionFocus then\r\n Polyline(Poly);\r\n // reduce the area for further operations\r\n InflateRect (Rect, -1, -1);\r\n end;}\r\n // test code:\r\n //InflateRect (Rect, -1, -1);\r\n\r\n if FFlat and (not OdsDown) and (not FIsHot) and (not (csDesigning in ComponentState)) then\r\n begin\r\n Pen.Color := FFlatBorderColor;\r\n Polyline(Poly);\r\n end\r\n else\r\n if OdsDown then\r\n begin\r\n // draw gray border all around\r\n Pen.Color := clBtnShadow;\r\n if not ActionFocus then\r\n Polyline(Poly);\r\n // gray border (Bottom-Right)\r\n Pen.Color := clBtnHighlight;\r\n SetPoly;\r\n PolyBR[0] := Poly[0];\r\n PolyBR[1] := Poly[1];\r\n PolyBR[2] := Poly[2];\r\n Polyline(PolyBR);\r\n // white border (Top-Left)\r\n Pen.Color := clWindowFrame;\r\n PolyTL[0] := Poly[2];\r\n PolyTL[1] := Poly[3];\r\n PolyTL[2] := Poly[0];\r\n Polyline(PolyTL);\r\n // gray border (Bottom-Right, internal)\r\n Pen.Color := clBtnShadow;\r\n InflateRect(Rect, -1, -1);\r\n SetPoly;\r\n PolyBR[0] := Poly[0];\r\n PolyBR[1] := Poly[1];\r\n PolyBR[2] := Poly[2];\r\n Polyline(PolyBR);\r\n end\r\n else\r\n if not ActionFocus then\r\n begin\r\n // gray border (Bottom-Right)\r\n Pen.Color := clWindowFrame;\r\n SetPoly;\r\n PolyBR[0] := Poly[0];\r\n PolyBR[1] := Poly[1];\r\n PolyBR[2] := Poly[2];\r\n Polyline(PolyBR);\r\n // white border (Top-Left)\r\n Pen.Color := clBtnHighlight;\r\n PolyTL[0] := Poly[2];\r\n PolyTL[1] := Poly[3];\r\n PolyTL[2] := Poly[0];\r\n Polyline(PolyTL);\r\n // gray border (Bottom-Right, internal)\r\n Pen.Color := clBtnShadow;\r\n InflateRect(Rect, -1, -1);\r\n SetPoly;\r\n PolyBR[0] := Poly[0];\r\n PolyBR[1] := Poly[1];\r\n PolyBR[2] := Poly[2];\r\n Polyline(PolyBR);\r\n end;\r\n // smooth edges\r\n DoAntiAlias(FBmp);\r\n // draw the caption\r\n InflateRect(Rect, -Width div 5, -Height div 5);\r\n if OdsDown then\r\n begin\r\n Inc(Rect.Left, 2);\r\n Inc(Rect.Top, 2);\r\n end;\r\n Font := Self.Font;\r\n if FIsHot and not OdsDown then\r\n Font.Color := FHotColor;\r\n if not ActionFocus then\r\n DrawText(FBmp.Canvas, Caption, -1,\r\n Rect, DT_SINGLELINE or DT_CENTER or DT_VCENTER);\r\n\r\n // draw the focus Rect around the text\r\n Brush.Style := bsSolid;\r\n Pen.Color := clBlack;\r\n Brush.Color := clWhite;\r\n if FIsFocused or OdsFocus or ActionFocus then\r\n DrawFocusRect(Rect);\r\n end;\r\n FCanvas.Draw(0, 0, FBmp);\r\n FCanvas.Handle := 0;\r\n Msg.Result := 1; // message handled\r\nend;\r\n\r\nprocedure TJvShapedButton.DoAntiAlias(Bmp: TBitmap);\r\nbegin\r\n if AntiAlias then\r\n JvJCLUtils.AntiAlias(Bmp);\r\nend;\r\n\r\nprocedure TJvShapedButton.SetAntiAlias(const Value: Boolean);\r\nbegin\r\n if FAntiAlias <> Value then\r\n begin\r\n FAntiAlias := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nfunction TJvShapedButton.DoEraseBackground(Canvas: TCanvas; Param: LPARAM): Boolean;\r\nbegin\r\n DrawThemedBackground(Self, Canvas.Handle, ClientRect, Parent.Brush.Handle, False);\r\n Result := True;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvShellHook.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvShellHook.pas, released on 2002-10-27.\r\n\r\nThe Initial Developer of the Original Code is Peter Thornqvist .\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n\r\nDescription:\r\n A wrapper for the Register/DeregisterShellHookWindow functions recently documented by Microsoft.\r\n See MSDN (http://msdn.microsoft.com, search for \"RegisterShellHookWindow\") for more details\r\n NOTE: this might not work on all OS'es and versions!\r\n\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvShellHook.pas 13138 2011-10-26 23:17:50Z jfudickar $\r\n\r\nunit JvShellHook;\r\n\r\n{$I jvcl.inc}\r\n{$I windowsonly.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, Messages, SysUtils, Classes,\r\n JvComponentBase;\r\n\r\ntype\r\n PShellHookInfo = ^TShellHookInfo;\r\n TShellHookInfo = record\r\n hwnd: THandle;\r\n rc: TRect;\r\n end;\r\n SHELLHOOKINFO = TShellHookInfo;\r\n {$EXTERNALSYM SHELLHOOKINFO}\r\n LPSHELLHOOKINFO = PShellHookInfo;\r\n {$EXTERNALSYM LPSHELLHOOKINFO}\r\n\r\ntype\r\n TJvShellHookEvent = procedure(Sender: TObject; var Msg: TMessage) of object;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvShellHook = class(TJvComponent)\r\n private\r\n FWndHandle: THandle;\r\n FHookMsg: Cardinal;\r\n FOnShellMessage: TJvShellHookEvent;\r\n FActive: Boolean;\r\n procedure SetActive(Value: Boolean);\r\n protected\r\n procedure DoShellMessage(var Msg: TMessage); dynamic;\r\n procedure ShellHookMethod(var Msg: TMessage);\r\n public\r\n destructor Destroy; override;\r\n published\r\n property Active: Boolean read FActive write SetActive;\r\n property OnShellMessage: TJvShellHookEvent read FOnShellMessage write FOnShellMessage;\r\n end;\r\n\r\n// load DLL and init function pointers\r\nfunction InitJvShellHooks: Boolean;\r\n// unload DLL and clear function pointers\r\nprocedure UnInitJvShellHooks;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvShellHook.pas $';\r\n Revision: '$Revision: 13138 $';\r\n Date: '$Date: 2011-10-27 01:17:50 +0200 (jeu. 27 oct. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n JvJVCLUtils;\r\n\r\ntype\r\n TRegisterShellHookWindowFunc = function(THandle: HWND): BOOL; stdcall;\r\n\r\nvar\r\n RegisterShellHookWindow: TRegisterShellHookWindowFunc = nil;\r\n DeregisterShellHookWindow: TRegisterShellHookWindowFunc = nil;\r\n GlobalLibHandle: THandle = 0;\r\n\r\nprocedure UnInitJvShellHooks;\r\nbegin\r\n RegisterShellHookWindow := nil;\r\n DeregisterShellHookWindow := nil;\r\n GlobalLibHandle := 0;\r\nend;\r\n\r\nfunction InitJvShellHooks: Boolean;\r\nbegin\r\n if GlobalLibHandle = 0 then\r\n begin\r\n GlobalLibHandle := GetModuleHandle(user32);\r\n if GlobalLibHandle > 0 then\r\n begin\r\n RegisterShellHookWindow := GetProcAddress(GlobalLibHandle, 'RegisterShellHookWindow');\r\n DeregisterShellHookWindow := GetProcAddress(GlobalLibHandle, 'DeregisterShellHookWindow');\r\n end;\r\n end;\r\n Result := (GlobalLibHandle <> 0) and Assigned(RegisterShellHookWindow) and Assigned(DeregisterShellHookWindow);\r\nend;\r\n\r\ndestructor TJvShellHook.Destroy;\r\nbegin\r\n Active := False;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvShellHook.DoShellMessage(var Msg: TMessage);\r\nbegin\r\n if Assigned(FOnShellMessage) then\r\n FOnShellMessage(Self, Msg);\r\nend;\r\n\r\nprocedure TJvShellHook.SetActive(Value: Boolean);\r\nbegin\r\n if FActive <> Value then\r\n begin\r\n if csDesigning in ComponentState then\r\n begin\r\n FActive := Value;\r\n Exit;\r\n end;\r\n if FActive and (FWndHandle <> 0) then\r\n begin\r\n DeregisterShellHookWindow(FWndHandle);\r\n DeallocateHWndEx(FWndHandle);\r\n end;\r\n FWndHandle := 0;\r\n if Value then\r\n begin\r\n if not InitJvShellHooks then\r\n Exit; // raise ?\r\n FWndHandle := AllocateHWndEx(ShellHookMethod);\r\n if FWndHandle <> 0 then\r\n FHookMsg := RegisterWindowMessage('SHELLHOOK'); // do not localize\r\n if not RegisterShellHookWindow(FWndHandle) then\r\n Value := False;\r\n end;\r\n FActive := Value;\r\n end;\r\nend;\r\n\r\nprocedure TJvShellHook.ShellHookMethod(var Msg: TMessage);\r\nbegin\r\n if Msg.Msg = FHookMsg then\r\n DoShellMessage(Msg)\r\n else\r\n with Msg do\r\n Result := DefWindowProc(FWndHandle, Msg, WParam, LParam);\r\nend;\r\n\r\ninitialization\r\n {$IFDEF UNITVERSIONING}\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n {$ENDIF UNITVERSIONING}\r\n\r\nfinalization\r\n UnInitJvShellHooks;\r\n {$IFDEF UNITVERSIONING}\r\n UnregisterUnitVersion(HInstance);\r\n {$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvSimIndicator.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvSimIndicator.PAS, released on 2002-06-15.\r\n\r\nThe Initial Developer of the Original Code is Jan Verhoeven [jan1 dott verhoeven att wxs dott nl]\r\nPortions created by Jan Verhoeven are Copyright (C) 2002 Jan Verhoeven.\r\nAll Rights Reserved.\r\n\r\nContributor(s): Robert Love [rlove att slcdug dott org].\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvSimIndicator.pas 13104 2011-09-07 06:50:43Z obones $\r\n\r\nunit JvSimIndicator;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n SysUtils, Classes, Windows, Graphics, Controls, ExtCtrls,\r\n JvComponent, JvJVCLUtils;\r\n\r\ntype\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvSimIndicator = class(TJvGraphicControl)\r\n private\r\n FValue: Integer;\r\n FMaximum: Integer;\r\n FMinimum: Integer;\r\n FBarColor: TColor;\r\n FBackColor: TColor;\r\n {$IFNDEF COMPILER10_UP}\r\n FMargins: TJvRect;\r\n {$ENDIF !COMPILER10_UP}\r\n procedure SetBarColor(const Value: TColor);\r\n procedure SetMaximum(const Value: Integer);\r\n procedure SetMinimum(const Value: Integer);\r\n procedure SetValue(const Value: Integer);\r\n procedure SetBackColor(const Value: TColor);\r\n {$IFNDEF COMPILER10_UP}\r\n procedure SetMargins(const Value: TJvRect);\r\n {$ENDIF !COMPILER10_UP}\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n procedure Paint; override;\r\n published\r\n property Value: Integer read FValue write SetValue;\r\n property Minimum: Integer read FMinimum write SetMinimum default 0;\r\n property Maximum: Integer read FMaximum write SetMaximum default 100;\r\n property BarColor: TColor read FBarColor write SetBarColor default clLime;\r\n property BackColor: TColor read FBackColor write SetBackColor default clSilver;\r\n property Width default 25;\r\n property Height default 100;\r\n {$IFNDEF COMPILER10_UP}\r\n property Margins: TJvRect read FMargins write SetMargins;\r\n {$ENDIF !COMPILER10_UP}\r\n\r\n property Align;\r\n property Anchors;\r\n property ParentShowHint;\r\n property ShowHint;\r\n property Visible;\r\n\r\n property OnCanResize;\r\n property OnClick;\r\n property OnConstrainedResize;\r\n property OnDblClick;\r\n property OnDragDrop;\r\n property OnDragOver;\r\n property OnEndDock;\r\n property OnEndDrag;\r\n property OnMouseDown;\r\n {$IFDEF COMPILER9_UP}\r\n property OnMouseEnter;\r\n property OnMouseLeave;\r\n {$ENDIF COMPILER9_UP}\r\n property OnMouseMove;\r\n property OnMouseUp;\r\n property OnMouseWheel;\r\n property OnMouseWheelDown;\r\n property OnMouseWheelUp;\r\n property OnResize;\r\n property OnStartDock;\r\n property OnStartDrag;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvSimIndicator.pas $';\r\n Revision: '$Revision: 13104 $';\r\n Date: '$Date: 2011-09-07 08:50:43 +0200 (mer. 07 sept. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\n\r\nconstructor TJvSimIndicator.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n\r\n Width := 25;\r\n Height := 100;\r\n FMinimum := 0;\r\n FMaximum := 100;\r\n FValue := 50;\r\n FBarColor := clLime;\r\n FBackColor := clSilver;\r\n\r\n {$IFNDEF COMPILER10_UP}\r\n FMargins := TJvRect.Create;\r\n {$ENDIF !COMPILER10_UP}\r\nend;\r\n\r\ndestructor TJvSimIndicator.Destroy;\r\nbegin\r\n {$IFNDEF COMPILER10_UP}\r\n FMargins.Free;\r\n {$ENDIF !COMPILER10_UP}\r\n\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvSimIndicator.Paint;\r\nconst\r\n NumberOfBars = 20;\r\nvar\r\n R, Ri: TRect;\r\n I, n: Integer;\r\n h, dh: Integer;\r\nbegin\r\n R := ClientRect;\r\n Canvas.Brush.Color := clSilver;\r\n Canvas.FillRect(R);\r\n Frame3D(Canvas, R, clBtnHighlight, clBtnShadow, 1);\r\n\r\n Dec(R.Top, Margins.Top);\r\n Dec(R.Left, Margins.Left);\r\n Dec(R.Bottom, Margins.Bottom);\r\n Dec(R.Right, Margins.Right);\r\n Frame3D(Canvas, R, clBtnShadow, clBtnHighlight, 1);\r\n\r\n Canvas.Brush.Color := FBackColor;\r\n InflateRect(R, -1, -1);\r\n Canvas.FillRect(R);\r\n Dec(R.Right);\r\n h := R.Bottom - R.Top;\r\n dh := h div NumberOfBars;\r\n n := Round(NumberOfBars * (FValue - FMinimum)/(FMaximum - FMinimum));\r\n Canvas.Brush.Color := FBarColor;\r\n Ri := Rect(R.Left + 1, R.Bottom - dh + 1, R.Right - 1, R.Bottom);\r\n for I := 1 to n do\r\n begin\r\n Canvas.FillRect(Ri);\r\n Dec(Ri.Top, dh);\r\n Dec(Ri.Bottom, dh);\r\n end;\r\nend;\r\n\r\nprocedure TJvSimIndicator.SetBackColor(const Value: TColor);\r\nbegin\r\n if FBackColor <> Value then\r\n begin\r\n FBackColor := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvSimIndicator.SetBarColor(const Value: TColor);\r\nbegin\r\n if FBarColor <> Value then\r\n begin\r\n FBarColor := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvSimIndicator.SetMaximum(const Value: Integer);\r\nbegin\r\n if FMaximum <> Value then\r\n begin\r\n FMaximum := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvSimIndicator.SetMinimum(const Value: Integer);\r\nbegin\r\n if FMinimum <> Value then\r\n begin\r\n FMinimum := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvSimIndicator.SetValue(const Value: Integer);\r\nbegin\r\n if FValue <> Value then\r\n begin\r\n FValue := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\n{$IFNDEF COMPILER10_UP}\r\nprocedure TJvSimIndicator.SetMargins(const Value: TJvRect);\r\nbegin\r\n FMargins.Assign(Value);\r\n Invalidate;\r\nend;\r\n{$ENDIF !COMPILER10_UP}\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend." }, { "path": "External/Jedi/Jvcl/run/JvSimLogic.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvSimLogic.PAS, released on 2002-06-15.\r\n\r\nThe Initial Developer of the Original Code is Jan Verhoeven [jan1 dott verhoeven att wxs dott nl]\r\nPortions created by Jan Verhoeven are Copyright (C) 2002 Jan Verhoeven.\r\nAll Rights Reserved.\r\n\r\nContributor(s): Robert Love [rlove att slcdug dott org].\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nDescription:\r\n This unit includes several visual logic blocks that can be used without any programming.\r\n It is the start of a whole series of simulation blocks.\r\n\r\n There is a string seperation between the visual part and functionality.\r\n\r\n The user creates and removes blocks; joins and moves them.\r\n\r\n The functionality is created every 50 msec in the onTimer event of TJvSimLogicBox.\r\n\r\n No programming is required, just drop a TJvLogicBox in the corner of a form and Build the program.\r\n\r\n All the rest is up to the user.\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvSimLogic.pas 13104 2011-09-07 06:50:43Z obones $\r\n\r\nunit JvSimLogic;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, Messages, Graphics, Controls, Forms, Dialogs, ExtCtrls,\r\n SysUtils, Classes,\r\n JvTypes;\r\n\r\ntype\r\n TJvLogic = class;\r\n\r\n TJvGateStyle = (jgsDI, jgsDO);\r\n TJvLogicFunc = (jlfAND, jlfOR, jlfNOT);\r\n TJvGate = record\r\n Style: TJvGateStyle;\r\n State: Boolean;\r\n Active: Boolean;\r\n Pos: TPoint;\r\n end;\r\n\r\n TJvPointX = class(TPersistent)\r\n private\r\n FX: Integer;\r\n FY: Integer;\r\n public\r\n function Point: TPoint;\r\n procedure SetPoint(const Pt: TPoint);\r\n procedure Assign(Source: TPersistent); override;\r\n published\r\n property X: Integer read FX write FX;\r\n property Y: Integer read FY write FY;\r\n end;\r\n\r\n TJvConMode = (jcmTL, jcmTR, jcmBR, jcmBL);\r\n TJvConPos = (jcpTL, jcpTR, jcpBR, jcpBL);\r\n TJvConShape = (jcsTLBR, jcsTRBL);\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvSIMConnector = class(TGraphicControl)\r\n private\r\n FMdp: TPoint;\r\n FOldp: TPoint;\r\n FConAnchor: TPoint;\r\n FConOffset: TPoint;\r\n FConMode: TJvConMode;\r\n FConHot: TJvConPos;\r\n FDoMove: Boolean;\r\n FDoEdge: Boolean;\r\n FDisCon: TControl;\r\n FDisConI: Integer;\r\n FMode: TJvConMode;\r\n FShape: TJvConShape;\r\n FConSize: Integer;\r\n FConPos: TJvConPos;\r\n FEdge: Extended;\r\n\r\n FFromLogic: TJvLogic;\r\n FToLogic: TJvLogic;\r\n FFromGate: Integer;\r\n FToGate: Integer;\r\n FFromPoint: TJvPointX;\r\n FToPoint: TJvPointX;\r\n procedure SetFromLogic(const Value: TJvLogic);\r\n procedure SetToLogic(const Value: TJvLogic);\r\n procedure SetFromGate(const Value: Integer);\r\n procedure SetToGate(const Value: Integer);\r\n procedure SetFromPoint(const Value: TJvPointX);\r\n procedure SetToPoint(const Value: TJvPointX);\r\n procedure DisconnectFinal;\r\n protected\r\n procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;\r\n procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;\r\n procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n procedure Paint; override;\r\n procedure Notification(AComponent: TComponent; Operation: TOperation); override;\r\n procedure DoMouseDown(X, Y: Integer);\r\n procedure DoMouseMove(dx, dy: Integer);\r\n procedure AnchorCorner(LogTL: TPoint; ACorner: TJvConMode);\r\n procedure MoveConnector(LogTL: TPoint);\r\n procedure Connect;\r\n procedure Disconnect;\r\n published\r\n property FromLogic: TJvLogic read FFromLogic write SetFromLogic;\r\n property FromGate: Integer read FFromGate write SetFromGate;\r\n property FromPoint: TJvPointX read FFromPoint write SetFromPoint;\r\n property ToLogic: TJvLogic read FToLogic write SetToLogic;\r\n property ToGate: Integer read FToGate write SetToGate;\r\n property ToPoint: TJvPointX read FToPoint write SetToPoint;\r\n end;\r\n\r\n TJvLogicGates = array [0..5] of TJvGate;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvLogic = class(TGraphicControl)\r\n private\r\n FDoMove: Boolean;\r\n FDoStyle: Boolean;\r\n FStyleDown: Boolean;\r\n FMdp: TPoint;\r\n FOldp: TPoint;\r\n FGates: TJvLogicGates;\r\n FConnectors: TList;\r\n FNewLeft: Integer;\r\n FNewTop: Integer;\r\n FInput1: Boolean;\r\n FInput2: Boolean;\r\n FInput3: Boolean;\r\n FOutput1: Boolean;\r\n FOutput2: Boolean;\r\n FOutput3: Boolean;\r\n FLogicFunc: TJvLogicFunc;\r\n function GetGate(Index: Integer): TJvGate;\r\n procedure AnchorConnectors;\r\n procedure MoveConnectors;\r\n procedure PaintLed(Index: Integer);\r\n procedure SetInput1(const Value: Boolean);\r\n procedure SetInput2(const Value: Boolean);\r\n procedure SetInput3(const Value: Boolean);\r\n procedure SetOutput1(const Value: Boolean);\r\n procedure SetOutput2(const Value: Boolean);\r\n procedure SetOutput3(const Value: Boolean);\r\n procedure SetLogicFunc(const Value: TJvLogicFunc);\r\n procedure OutCalc;\r\n protected\r\n procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;\r\n procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;\r\n procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;\r\n procedure Resize; override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n procedure Paint; override;\r\n property Gates[Index: Integer]: TJvGate read GetGate;\r\n published\r\n property Input1: Boolean read FInput1 write SetInput1;\r\n property Input2: Boolean read FInput2 write SetInput2;\r\n property Input3: Boolean read FInput3 write SetInput3;\r\n property Output1: Boolean read FOutput1 write SetOutput1;\r\n property Output2: Boolean read FOutput2 write SetOutput2;\r\n property Output3: Boolean read FOutput3 write SetOutput3;\r\n property LogicFunc: TJvLogicFunc read FLogicFunc write SetLogicFunc;\r\n end;\r\n\r\n TJvSimReverseGates = array [0..3] of TJvGate;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvSimReverse = class(TGraphicControl)\r\n private\r\n FDoMove: Boolean;\r\n FMdp: TPoint;\r\n FOldp: TPoint;\r\n FGates: TJvSimReverseGates;\r\n FConnectors: TList;\r\n FNewLeft: Integer;\r\n FNewTop: Integer;\r\n FInput1: Boolean;\r\n FOutput1: Boolean;\r\n FOutput2: Boolean;\r\n FOutput3: Boolean;\r\n function GetGate(Index: Integer): TJvGate;\r\n procedure AnchorConnectors;\r\n procedure MoveConnectors;\r\n procedure PaintLed(Index: Integer);\r\n procedure SetInput1(const Value: Boolean);\r\n procedure SetOutput1(const Value: Boolean);\r\n procedure OutCalc;\r\n procedure SetOutput2(const Value: Boolean);\r\n procedure SetOutput3(const Value: Boolean);\r\n protected\r\n procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;\r\n procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;\r\n procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;\r\n procedure Resize; override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n procedure Paint; override;\r\n property Gates[Index: Integer]: TJvGate read GetGate;\r\n published\r\n property Input1: Boolean read FInput1 write SetInput1;\r\n property Output1: Boolean read FOutput1 write SetOutput1;\r\n property Output2: Boolean read FOutput2 write SetOutput2;\r\n property Output3: Boolean read FOutput3 write SetOutput3;\r\n end;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvSimButton = class(TGraphicControl)\r\n private\r\n FDoMove: Boolean;\r\n FMdp: TPoint;\r\n FOldp: TPoint;\r\n FConnectors: TList;\r\n FDown: Boolean;\r\n FDepressed: Boolean;\r\n FNewLeft: Integer;\r\n FNewTop: Integer;\r\n procedure AnchorConnectors;\r\n procedure MoveConnectors;\r\n procedure PaintLed(Pt: TPoint; Lit: Boolean);\r\n procedure SetDown(const Value: Boolean);\r\n protected\r\n procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;\r\n procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;\r\n procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;\r\n procedure Resize; override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n procedure Paint; override;\r\n published\r\n property Down: Boolean read FDown write SetDown;\r\n end;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvSimLight = class(TGraphicControl)\r\n private\r\n FDoMove: Boolean;\r\n FMdp: TPoint;\r\n FOldp: TPoint;\r\n FConnectors: TList;\r\n FLit: Boolean;\r\n FColorOn: TColor;\r\n FColorOff: TColor;\r\n FNewLeft: Integer;\r\n FNewTop: Integer;\r\n procedure AnchorConnectors;\r\n procedure MoveConnectors;\r\n procedure SetLit(const Value: Boolean);\r\n procedure SetColorOff(const Value: TColor);\r\n procedure SetColorOn(const Value: TColor);\r\n protected\r\n procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;\r\n procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;\r\n procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;\r\n procedure Resize; override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n procedure Paint; override;\r\n published\r\n property Lit: Boolean read FLit write SetLit;\r\n property ColorOn: TColor read FColorOn write SetColorOn;\r\n property ColorOff: TColor read FColorOff write SetColorOff;\r\n end;\r\n\r\n TJvSimBin = class(TGraphicControl)\r\n private\r\n FBmpBin: TBitmap;\r\n protected\r\n procedure Resize; override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n procedure Paint; override;\r\n end;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvSimLogicBox = class(TGraphicControl)\r\n private\r\n FCpu: TTimer;\r\n FBmpCon: TBitmap;\r\n FRCon: TRect;\r\n FDCon: Boolean;\r\n FBmpLogic: TBitmap;\r\n FRLogic: TRect;\r\n FDLogic: Boolean;\r\n FBmpButton: TBitmap;\r\n FRButton: TRect;\r\n FDButton: Boolean;\r\n FBmpLight: TBitmap;\r\n FRLight: TRect;\r\n FDLight: Boolean;\r\n FBmpRev: TBitmap;\r\n FRRev: TRect;\r\n FDRev: Boolean;\r\n FBmpBin: TBitmap;\r\n procedure CpuOnTimer(Sender: TObject);\r\n protected\r\n procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;\r\n procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;\r\n procedure Resize; override;\r\n procedure Loaded; override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n procedure Paint; override;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvSimLogic.pas $';\r\n Revision: '$Revision: 13104 $';\r\n Date: '$Date: 2011-09-07 08:50:43 +0200 (mer. 07 sept. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n JvJVCLUtils;\r\n\r\n\r\n{$R JvSimImages.res}\r\n\r\n// general bin procedure\r\n\r\nprocedure BinCheck(AControl: TControl);\r\nvar\r\n Wc: TWinControl;\r\n I: Integer;\r\n R, Rb: TRect;\r\n Keep: Boolean;\r\nbegin\r\n // check for TJvSimLogicBox\r\n Wc := AControl.Parent;\r\n R := AControl.BoundsRect;\r\n Keep := False;\r\n for I := 0 to Wc.ControlCount - 1 do\r\n if Wc.Controls[I] is TJvSimLogicBox then\r\n begin\r\n Rb := Wc.Controls[I].BoundsRect;\r\n Rb.Left := Rb.Right - 32;\r\n if PtInRect(Rb, Point(R.Left, R.Top)) then\r\n Break\r\n else\r\n if PtInRect(Rb, Point(R.Right, R.Top)) then\r\n Break\r\n else\r\n if PtInRect(Rb, Point(R.Right, R.Bottom)) then\r\n Break\r\n else\r\n if PtInRect(Rb, Point(R.Left, R.Bottom)) then\r\n Break\r\n else\r\n Keep := True;\r\n end;\r\n if not Keep then\r\n AControl.Free;\r\nend;\r\n\r\n//=== { TJvPointX } ==========================================================\r\n\r\nprocedure TJvPointX.Assign(Source: TPersistent);\r\nbegin\r\n if Source is TJvPointX then\r\n begin\r\n FX := TJvPointX(Source).X;\r\n FY := TJvPointX(Source).Y;\r\n end\r\n else\r\n inherited Assign(Source);\r\nend;\r\n\r\nfunction TJvPointX.Point: TPoint;\r\nbegin\r\n Result.X := FX;\r\n Result.Y := FY;\r\nend;\r\n\r\nprocedure TJvPointX.SetPoint(const Pt: TPoint);\r\nbegin\r\n FX := Pt.X;\r\n FY := Pt.Y;\r\nend;\r\n\r\n//=== { TJvSIMConnector } ====================================================\r\n\r\nconstructor TJvSIMConnector.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n Width := 100;\r\n Height := 50;\r\n FMode := jcmTL;\r\n FShape := jcsTLBR;\r\n FConSize := 8;\r\n FConPos := jcpTL;\r\n FEdge := 0.5;\r\n FFromPoint := TJvPointX.Create;\r\n FToPoint := TJvPointX.Create;\r\nend;\r\n\r\ndestructor TJvSIMConnector.Destroy;\r\nbegin\r\n FFromPoint.Free;\r\n FToPoint.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvSIMConnector.DoMouseDown(X, Y: Integer);\r\nvar\r\n P: TPoint;\r\n Rtl, Rbr, Rtr, Rbl: TRect;\r\n D: Integer;\r\nbegin\r\n FDoMove := False;\r\n FDoEdge := False;\r\n D := FConSize;\r\n FOldp := Point(X, Y);\r\n Rtl := Rect(0, 0, D, D);\r\n Rbr := Rect(Width - 1 - D, Height - 1 - D, Width - 1, Height - 1);\r\n Rtr := Rect(Width - 1 - D, 0, Width - 1, D);\r\n Rbl := Rect(0, Height - 1 - D, D, Height - 1);\r\n P := Point(X, Y);\r\n if PtInRect(Rtl, P) and (FShape = jcsTLBR) then\r\n begin\r\n FMode := jcmTL;\r\n FMdp := Point(X, Y);\r\n end\r\n else\r\n if PtInRect(Rtr, P) and (FShape = jcsTRBL) then\r\n begin\r\n FMode := jcmTR;\r\n FMdp := Point(Width - X, Y);\r\n end\r\n else\r\n if PtInRect(Rbr, P) and (FShape = jcsTLBR) then\r\n begin\r\n FMode := jcmBR;\r\n FMdp := Point(Width - X, Height - Y);\r\n end\r\n else\r\n if PtInRect(Rbl, P) and (FShape = jcsTRBL) then\r\n begin\r\n FMode := jcmBL;\r\n FMdp := Point(X, Height - Y);\r\n end\r\n else\r\n if Abs(X - Round(FEdge * Width)) < 10 then\r\n FDoEdge := True\r\n else\r\n begin\r\n FDoMove := True;\r\n FMdp := Point(X, Y);\r\n SetFromLogic(nil);\r\n SetToLogic(nil);\r\n end;\r\n if not FDoEdge then\r\n Disconnect;\r\nend;\r\n\r\nprocedure TJvSIMConnector.MouseDown(Button: TMouseButton; Shift: TShiftState;\r\n X, Y: Integer);\r\nbegin\r\n DoMouseDown(X, Y);\r\nend;\r\n\r\nprocedure TJvSIMConnector.DoMouseMove(dx, dy: Integer);\r\nvar\r\n P: TPoint;\r\n D, d2, nw, nh: Integer;\r\n X, Y: Integer;\r\nbegin\r\n X := dx + FOldp.X;\r\n Y := dy + FOldp.Y;\r\n FOldp := Point(X, Y);\r\n P := ClientToScreen(Point(X, Y));\r\n P := Parent.ScreenToClient(P);\r\n D := FConSize;\r\n d2 := D div 2;\r\n if FDoEdge then\r\n begin\r\n FEdge := X / Width;\r\n Invalidate;\r\n end\r\n else\r\n if FDoMove then\r\n begin\r\n Left := P.X - FMdp.X;\r\n Top := P.Y - FMdp.Y;\r\n end\r\n else\r\n begin\r\n case FMode of\r\n jcmTL:\r\n begin\r\n Left := P.X - FMdp.X;\r\n Top := P.Y - FMdp.Y;\r\n nw := Width + (FMdp.X - X);\r\n if nw < d2 then\r\n begin\r\n Left := Left + nw - D;\r\n Width := -nw + D + D;\r\n FMode := jcmTR;\r\n FShape := jcsTRBL;\r\n case FConPos of\r\n jcpTL:\r\n FConPos := jcpTR;\r\n jcpBR:\r\n FConPos := jcpBL;\r\n end;\r\n FEdge := 1 - FEdge;\r\n end\r\n else\r\n Width := nw;\r\n nh := Height + (FMdp.Y - Y);\r\n if nh < d2 then\r\n begin\r\n Top := Top + nh - D;\r\n Height := -nh + D + D;\r\n FMode := jcmBL;\r\n FShape := jcsTRBL;\r\n case FConPos of\r\n jcpTL:\r\n FConPos := jcpBL;\r\n jcpBR:\r\n FConPos := jcpTR;\r\n end;\r\n end\r\n else\r\n Height := nh;\r\n end;\r\n jcmTR:\r\n begin\r\n Top := P.Y - FMdp.Y;\r\n nw := X + FMdp.X;\r\n if nw < d2 then\r\n begin\r\n Left := Left + nw - D;\r\n Width := -nw + D + D;\r\n FMode := jcmTL;\r\n FShape := jcsTLBR;\r\n case FConPos of\r\n jcpTR:\r\n FConPos := jcpTL;\r\n jcpBL:\r\n FConPos := jcpBR;\r\n end;\r\n FEdge := 1 - FEdge;\r\n end\r\n else\r\n Width := nw;\r\n nh := Height + (FMdp.Y - Y);\r\n if nh < d2 then\r\n begin\r\n Top := Top + nh - D;\r\n Height := -nh + D + D;\r\n FMode := jcmBR;\r\n FShape := jcsTLBR;\r\n case FConPos of\r\n jcpTR:\r\n FConPos := jcpBR;\r\n jcpBL:\r\n FConPos := jcpTL;\r\n end;\r\n end\r\n else\r\n Height := nh;\r\n end;\r\n jcmBR:\r\n begin\r\n nw := X + FMdp.X;\r\n if nw < d2 then\r\n begin\r\n Left := Left + nw - D;\r\n Width := -nw + D + D;\r\n FMode := jcmBL;\r\n FShape := jcsTRBL;\r\n case FConPos of\r\n jcpBR:\r\n FConPos := jcpBL;\r\n jcpTL:\r\n FConPos := jcpTR;\r\n end;\r\n FEdge := 1 - FEdge;\r\n end\r\n else\r\n Width := nw;\r\n nh := Y + FMdp.Y;\r\n if nh < d2 then\r\n begin\r\n Top := Top + nh - D;\r\n Height := -nh + D + D;\r\n FMode := jcmTR;\r\n FShape := jcsTRBL;\r\n case FConPos of\r\n jcpBR:\r\n FConPos := jcpTR;\r\n jcpTL:\r\n FConPos := jcpBL;\r\n end;\r\n end\r\n else\r\n Height := nh;\r\n end;\r\n jcmBL:\r\n begin\r\n Left := P.X - FMdp.X;\r\n nw := Width + (FMdp.X - X);\r\n if nw < d2 then\r\n begin\r\n Left := Left + nw - D;\r\n Width := -nw + D + D;\r\n FMode := jcmBR;\r\n FShape := jcsTLBR;\r\n case FConPos of\r\n jcpBL:\r\n FConPos := jcpBR;\r\n jcpTR:\r\n FConPos := jcpTL;\r\n end;\r\n FEdge := 1 - FEdge;\r\n end\r\n else\r\n Width := nw;\r\n nh := Y + FMdp.Y;\r\n if nh < d2 then\r\n begin\r\n Top := Top + nh - D;\r\n Height := -nh + D + D;\r\n FMode := jcmTL;\r\n FShape := jcsTLBR;\r\n case FConPos of\r\n jcpBL:\r\n FConPos := jcpTL;\r\n jcpTR:\r\n FConPos := jcpBR;\r\n end;\r\n end\r\n else\r\n Height := nh;\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvSIMConnector.MouseMove(Shift: TShiftState; X, Y: Integer);\r\nbegin\r\n if ssLeft in Shift then\r\n DoMouseMove(X - FOldp.X, Y - FOldp.Y);\r\nend;\r\n\r\nprocedure TJvSIMConnector.MouseUp(Button: TMouseButton; Shift: TShiftState;\r\n X, Y: Integer);\r\nbegin\r\n if not FDoEdge then\r\n DisconnectFinal;\r\n BinCheck(Self);\r\nend;\r\n\r\nprocedure TJvSIMConnector.DisconnectFinal;\r\nbegin\r\n if FDisCon = nil then\r\n Exit;\r\n if FDisCon is TJvSimLight then\r\n TJvSimLight(FDisCon).Lit := False\r\n else\r\n if FDisCon is TJvLogic then\r\n begin\r\n if FDisConI = 1 then\r\n TJvLogic(FDisCon).Input1 := False\r\n else\r\n if FDisConI = 2 then\r\n TJvLogic(FDisCon).Input2 := False\r\n else\r\n if FDisConI = 3 then\r\n TJvLogic(FDisCon).Input3 := False\r\n end;\r\nend;\r\n\r\nprocedure TJvSIMConnector.Notification(AComponent: TComponent;\r\n Operation: TOperation);\r\nbegin\r\n inherited Notification(AComponent, Operation);\r\n if (Operation = opRemove) then\r\n if (AComponent = FromLogic) then\r\n FromLogic := nil\r\n else if (AComponent = ToLogic) then\r\n ToLogic := nil;\r\nend;\r\n\r\nprocedure TJvSIMConnector.Paint;\r\nvar\r\n D, d2, w2, xw, yh: Integer;\r\nbegin\r\n D := FConSize;\r\n d2 := D div 2;\r\n w2 := Round(FEdge * Width);\r\n xw := Width - 1;\r\n yh := Height - 1;\r\n\r\n with Canvas do\r\n begin\r\n Brush.Color := clLime;\r\n case FShape of\r\n jcsTLBR:\r\n // a connector is drawn depending in the FConPos\r\n begin\r\n // start new code\r\n case FConPos of\r\n jcpTL: // Draw regular connector\r\n begin\r\n MoveTo(D, d2);\r\n LineTo(w2, d2);\r\n LineTo(w2, yh - d2);\r\n LineTo(xw - D, yh - d2);\r\n Brush.Color := clRed;\r\n Rectangle(0, 0, D, D);\r\n Brush.Color := clLime;\r\n Rectangle(xw - D, yh - D, xw, yh);\r\n end;\r\n jcpBR:\r\n begin\r\n MoveTo(D, d2);\r\n LineTo(xw - d2, d2);\r\n LineTo(xw - d2, yh - D);\r\n Brush.Color := clLime;\r\n Rectangle(0, 0, D, D);\r\n Brush.Color := clRed;\r\n Rectangle(xw - D, yh - D, xw, yh);\r\n end;\r\n end;\r\n // end new code\r\n { MoveTo(D,d2);\r\n LineTo(w2,d2);\r\n LineTo(w2,yh-d2);\r\n LineTo(xw-D,yh-d2);\r\n case FConPos of\r\n jcpTL: Brush.Color:=clRed;\r\n else Brush.Color:=clLime;\r\n end;\r\n Rectangle(0,0,D,D);\r\n case FConPos of\r\n jcpBR: Brush.Color:=clRed;\r\n else Brush.Color:=clLime;\r\n end;\r\n Rectangle(xw-D,yh-D,xw,yh);}\r\n end;\r\n jcsTRBL:\r\n begin\r\n // start new code\r\n case FConPos of\r\n jcpTR: // Draw reverted connector\r\n begin\r\n MoveTo(xw - d2, D);\r\n LineTo(xw - d2, yh - d2);\r\n LineTo(D, yh - d2);\r\n Brush.Color := clRed;\r\n Rectangle(xw - D, 0, xw, D);\r\n Brush.Color := clLime;\r\n Rectangle(0, yh - D, D, yh);\r\n end;\r\n jcpBL: // Draw regular connector\r\n begin\r\n MoveTo(xw - D, d2);\r\n LineTo(w2, d2);\r\n LineTo(w2, yh - d2);\r\n LineTo(D - 1, yh - d2);\r\n Brush.Color := clLime;\r\n Rectangle(xw - D, 0, xw, D);\r\n Brush.Color := clRed;\r\n Rectangle(0, yh - D, D, yh);\r\n end;\r\n end;\r\n // end new code\r\n { MoveTo(xw-D,d2);\r\n LineTo(w2,d2);\r\n LineTo(w2,yh-d2);\r\n LineTo(D-1,yh-d2);\r\n case FConPos of\r\n jcpTR: Brush.Color:=clRed;\r\n else Brush.Color:=clLime;\r\n end;\r\n Rectangle(xw-D,0,xw,D);\r\n case FConPos of\r\n jcpBL: Brush.Color:=clRed;\r\n else Brush.Color:=clLime;\r\n end;\r\n Rectangle(0,yh-D,D,yh);}\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvSIMConnector.SetFromGate(const Value: Integer);\r\nbegin\r\n FFromGate := Value;\r\nend;\r\n\r\nprocedure TJvSIMConnector.SetFromLogic(const Value: TJvLogic);\r\nbegin\r\n ReplaceComponentReference(Self, Value, TComponent(FFromLogic));\r\nend;\r\n\r\nprocedure TJvSIMConnector.SetToGate(const Value: Integer);\r\nbegin\r\n FToGate := Value;\r\nend;\r\n\r\nprocedure TJvSIMConnector.SetToLogic(const Value: TJvLogic);\r\nbegin\r\n ReplaceComponentReference(Self, Value, TComponent(FToLogic));\r\nend;\r\n\r\nprocedure TJvSIMConnector.SetFromPoint(const Value: TJvPointX);\r\nbegin\r\n if Assigned(Value) then\r\n FFromPoint.Assign(Value);\r\nend;\r\n\r\nprocedure TJvSIMConnector.SetToPoint(const Value: TJvPointX);\r\nbegin\r\n if Assigned(Value) then\r\n FToPoint.Assign(Value);\r\nend;\r\n\r\nprocedure TJvSIMConnector.AnchorCorner(LogTL: TPoint; ACorner: TJvConMode);\r\nvar\r\n Rc: TRect;\r\nbegin\r\n FConMode := ACorner;\r\n Rc := BoundsRect;\r\n FConHot := FConPos;\r\n case ACorner of\r\n jcmTL:\r\n begin\r\n FConOffset := Point(Rc.Left - LogTL.X, Rc.Top - LogTL.Y);\r\n FConAnchor := Parent.ScreenToClient(ClientToScreen(Point(Width, Height)));\r\n end;\r\n jcmTR:\r\n begin\r\n FConOffset := Point(Rc.Right - LogTL.X, Rc.Top - LogTL.Y);\r\n FConAnchor := Parent.ScreenToClient(ClientToScreen(Point(0, Height)));\r\n end;\r\n jcmBR:\r\n begin\r\n FConOffset := Point(Rc.Right - LogTL.X, Rc.Bottom - LogTL.Y);\r\n FConAnchor := Parent.ScreenToClient(ClientToScreen(Point(0, 0)));\r\n end;\r\n jcmBL:\r\n begin\r\n FConOffset := Point(Rc.Left - LogTL.X, Rc.Bottom - LogTL.Y);\r\n FConAnchor := Parent.ScreenToClient(ClientToScreen(Point(Width, 0)));\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvSIMConnector.MoveConnector(LogTL: TPoint);\r\nvar\r\n nw, nh: Integer;\r\n D: Integer;\r\n nc: TPoint;\r\nbegin\r\n D := FConSize;\r\n// d2 := D div 2;\r\n nc := Point(LogTL.X + FConOffset.X, LogTL.Y + FConOffset.Y);\r\n case FConMode of\r\n jcmTL:\r\n begin\r\n nw := FConAnchor.X - nc.X;\r\n if nw < D then\r\n begin\r\n Left := FConAnchor.X - D;\r\n Width := -nw + D + D;\r\n end\r\n else\r\n begin\r\n Left := nc.X;\r\n Width := FConAnchor.X - Left;\r\n end;\r\n nh := FConAnchor.Y - nc.Y;\r\n\r\n // adjust new hot position\r\n if (nw < D) and not (nh < D) then\r\n begin\r\n case FConHot of\r\n jcpTL:\r\n FConPos := jcpTR;\r\n jcpBR:\r\n FConPos := jcpBL;\r\n end;\r\n FShape := jcsTRBL;\r\n end\r\n else\r\n if (nw < D) and (nh < D) then\r\n begin\r\n case FConHot of\r\n jcpTL:\r\n FConPos := jcpBR;\r\n jcpBR:\r\n FConPos := jcpTL;\r\n end;\r\n FShape := jcsTLBR;\r\n end\r\n else\r\n if (not nw < D) and (nh < D) then\r\n begin\r\n case FConHot of\r\n jcpTL:\r\n FConPos := jcpBL;\r\n jcpBR:\r\n FConPos := jcpTR;\r\n end;\r\n FShape := jcsTRBL;\r\n end\r\n else\r\n begin\r\n case FConHot of\r\n jcpTL:\r\n FConPos := jcpTL;\r\n jcpBR:\r\n FConPos := jcpBR;\r\n end;\r\n FShape := jcsTLBR;\r\n end;\r\n // end of adjust TL new hot\r\n if nh < D then\r\n begin\r\n Top := FConAnchor.Y - D;\r\n Height := -nh + D + D;\r\n end\r\n else\r\n begin\r\n Top := nc.Y;\r\n Height := FConAnchor.Y - Top;\r\n end;\r\n end;\r\n jcmTR:\r\n begin\r\n nw := nc.X - FConAnchor.X;\r\n if nw <= 0 then\r\n begin\r\n Left := FConAnchor.X + nw - D;\r\n Width := -nw + D + D;\r\n end\r\n else\r\n if nw <= D then\r\n begin\r\n Left := nc.X - D;\r\n Width := -nw + D + D;\r\n end\r\n else\r\n Width := nw;\r\n nh := FConAnchor.Y - nc.Y;\r\n // adjust TR new hot position\r\n if (nw < D) and (not (nh < D)) then\r\n begin\r\n case FConHot of\r\n jcpTR:\r\n FConPos := jcpTL;\r\n jcpBL:\r\n FConPos := jcpBR;\r\n end;\r\n FShape := jcsTLBR;\r\n end\r\n else\r\n if (nw < D) and (nh < D) then\r\n begin\r\n case FConHot of\r\n jcpTR:\r\n FConPos := jcpBL;\r\n jcpBL:\r\n FConPos := jcpTR;\r\n end;\r\n FShape := jcsTRBL;\r\n end\r\n else\r\n if (not nw < D) and (nh < D) then\r\n begin\r\n case FConHot of\r\n jcpTR:\r\n FConPos := jcpBR;\r\n jcpBL:\r\n FConPos := jcpTL;\r\n end;\r\n FShape := jcsTLBR;\r\n end\r\n else\r\n begin\r\n case FConHot of\r\n jcpTR:\r\n FConPos := jcpTR;\r\n jcpBL:\r\n FConPos := jcpBL;\r\n end;\r\n FShape := jcsTRBL;\r\n end;\r\n // end of adjust TR new hot\r\n if nh < D then\r\n begin\r\n Top := FConAnchor.Y - D;\r\n Height := -nh + D + D;\r\n end\r\n else\r\n begin\r\n Top := FConAnchor.Y - nh;\r\n Height := nh;\r\n end;\r\n end;\r\n jcmBR:\r\n begin\r\n nw := nc.X - FConAnchor.X;\r\n if nw <= 0 then\r\n begin\r\n Left := nc.X - D;\r\n Width := -nw + D + D;\r\n end\r\n else\r\n if nw <= D then\r\n begin\r\n Left := nc.X - D;\r\n Width := -nw + D + D;\r\n end\r\n else\r\n Width := nw;\r\n nh := nc.Y - FConAnchor.Y;\r\n // adjust BR new hot position\r\n if (nw < D) and (not (nh < D)) then\r\n begin\r\n case FConHot of\r\n jcpBR:\r\n FConPos := jcpBL;\r\n jcpTL:\r\n FConPos := jcpTR;\r\n end;\r\n FShape := jcsTRBL;\r\n end\r\n else\r\n if (nw < D) and (nh < D) then\r\n begin\r\n case FConHot of\r\n jcpBR:\r\n FConPos := jcpTL;\r\n jcpTL:\r\n FConPos := jcpBR;\r\n end;\r\n FShape := jcsTLBR;\r\n end\r\n else\r\n if (not nw < D) and (nh < D) then\r\n begin\r\n case FConHot of\r\n jcpBR:\r\n FConPos := jcpTR;\r\n jcpTL:\r\n FConPos := jcpBL;\r\n end;\r\n FShape := jcsTRBL;\r\n end\r\n else\r\n begin\r\n case FConHot of\r\n jcpBR:\r\n FConPos := jcpBR;\r\n jcpTL:\r\n FConPos := jcpTL;\r\n end;\r\n FShape := jcsTLBR;\r\n end;\r\n // end of adjust BR new hot\r\n if nh < D then\r\n begin\r\n Top := FConAnchor.Y + nh - D;\r\n Height := -nh + D + D;\r\n end\r\n else\r\n Height := nh;\r\n end;\r\n jcmBL:\r\n begin\r\n nw := FConAnchor.X - nc.X;\r\n if nw < D then\r\n begin\r\n Left := FConAnchor.X - D;\r\n Width := -nw + D + D;\r\n end\r\n else\r\n begin\r\n Left := FConAnchor.X - nw;\r\n Width := nw;\r\n end;\r\n nh := nc.Y - FConAnchor.Y;\r\n // adjust BL new hot position\r\n if (nw < D) and (not (nh < D)) then\r\n begin\r\n case FConHot of\r\n jcpBL:\r\n FConPos := jcpBR;\r\n jcpTR:\r\n FConPos := jcpTL;\r\n end;\r\n FShape := jcsTLBR;\r\n end\r\n else\r\n if (nw < D) and (nh < D) then\r\n begin\r\n case FConHot of\r\n jcpBL:\r\n FConPos := jcpTR;\r\n jcpTR:\r\n FConPos := jcpBL;\r\n end;\r\n FShape := jcsTRBL;\r\n end\r\n else\r\n if (not nw < D) and (nh < D) then\r\n begin\r\n case FConHot of\r\n jcpBL:\r\n FConPos := jcpTL;\r\n jcpTR:\r\n FConPos := jcpBR;\r\n end;\r\n FShape := jcsTLBR;\r\n end\r\n else\r\n begin\r\n case FConHot of\r\n jcpBL:\r\n FConPos := jcpBL;\r\n jcpTR:\r\n FConPos := jcpTR;\r\n end;\r\n FShape := jcsTRBL;\r\n end;\r\n // end of adjust BL new hot\r\n if nh < D then\r\n begin\r\n Top := FConAnchor.Y + nh - D;\r\n Height := -nh + D + D;\r\n end\r\n else\r\n Height := nh;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvSIMConnector.Connect;\r\nvar\r\n Pi, Po: TPoint;\r\n R: TRect;\r\n D, d2, xw, yh: Integer;\r\n Wc: TWinControl;\r\n Vi: Boolean;\r\n sBut: TJvSimButton;\r\n sLog: TJvLogic;\r\n sLight: TJvSimLight;\r\n sRev: TJvSimReverse;\r\n pl: TPoint;\r\n\r\n // convert a corner point to a Parent point\r\n\r\n function ParentPoint(X, Y: Integer): TPoint;\r\n var\r\n P: TPoint;\r\n begin\r\n P := Point(X, Y);\r\n P := ClientToScreen(P);\r\n Result := Wc.ScreenToClient(P);\r\n end;\r\n\r\n function GetVi: Boolean;\r\n var\r\n J: Integer;\r\n begin\r\n Result := True;\r\n for J := 0 to Wc.ControlCount - 1 do\r\n begin\r\n if Wc.Controls[J] is TJvSimButton then\r\n begin\r\n R := Wc.Controls[J].BoundsRect;\r\n InflateRect(R, D, 0);\r\n if PtInRect(R, Pi) then\r\n begin\r\n sBut := TJvSimButton(Wc.Controls[J]);\r\n Vi := sBut.Down;\r\n Exit;\r\n end;\r\n end\r\n else\r\n if Wc.Controls[J] is TJvSimReverse then\r\n begin\r\n R := Wc.Controls[J].BoundsRect;\r\n InflateRect(R, D, D);\r\n if PtInRect(R, Pi) then\r\n begin\r\n sRev := TJvSimReverse(Wc.Controls[J]);\r\n // now check if P is the output area\r\n pl := sRev.Gates[1].Pos;\r\n R := Rect(sRev.Left + pl.X, sRev.Top - D, sRev.Left + pl.X + 12, sRev.Top + pl.Y + 12);\r\n if PtInRect(R, Pi) and sRev.Gates[1].Active then\r\n begin // output\r\n Vi := sRev.Output1;\r\n Exit;\r\n end;\r\n pl := sRev.Gates[2].Pos;\r\n R := Rect(sRev.Left - D, sRev.Top + pl.Y, sRev.Left + pl.X + 12, sRev.Top + pl.Y + 12);\r\n if PtInRect(R, Pi) and sRev.Gates[2].Active then\r\n begin // output\r\n Vi := sRev.Output2;\r\n Exit;\r\n end;\r\n pl := sRev.Gates[3].Pos;\r\n R := Rect(sRev.Left + pl.X, sRev.Top + pl.Y, sRev.Left + pl.X + 12, sRev.Top + sRev.Height + D);\r\n if PtInRect(R, Pi) and sRev.Gates[3].Active then\r\n begin // output\r\n Vi := sRev.Output3;\r\n Exit;\r\n end;\r\n end;\r\n end\r\n else\r\n if Wc.Controls[J] is TJvLogic then\r\n begin\r\n R := Wc.Controls[J].BoundsRect;\r\n InflateRect(R, D, 0);\r\n if PtInRect(R, Pi) then\r\n begin\r\n sLog := TJvLogic(Wc.Controls[J]);\r\n // now check if P is in one of the 3 output area's\r\n R := Rect(sLog.Left + 33, sLog.Top, sLog.Left + sLog.Width + FConSize, sLog.Top + 22);\r\n if PtInRect(R, Pi) and sLog.Gates[3].Active then\r\n begin // output is gate 3\r\n Vi := sLog.Output1;\r\n Exit;\r\n end;\r\n R := Rect(sLog.Left + 33, sLog.Top + 23, sLog.Left + sLog.Width + FConSize, sLog.Top + 44);\r\n if PtInRect(R, Pi) and sLog.Gates[4].Active then\r\n begin // output is gate 4\r\n Vi := sLog.Output2;\r\n Exit;\r\n end;\r\n R := Rect(sLog.Left + 33, sLog.Top + 45, sLog.Left + sLog.Width + FConSize, sLog.Top + 64);\r\n if PtInRect(R, Pi) and sLog.Gates[5].Active then\r\n begin // output is gate 5\r\n Vi := sLog.Output3;\r\n Exit;\r\n end;\r\n end;\r\n end;\r\n end;\r\n Result := False;\r\n end;\r\n\r\n procedure SetVo;\r\n var\r\n J: Integer;\r\n begin\r\n for J := 0 to Wc.ControlCount - 1 do\r\n begin\r\n if (Wc.Controls[J] is TJvSimLight) then\r\n begin\r\n R := Wc.Controls[J].BoundsRect;\r\n InflateRect(R, D, 0);\r\n if PtInRect(R, Po) then\r\n begin\r\n sLight := TJvSimLight(Wc.Controls[J]);\r\n sLight.Lit := Vi;\r\n Exit;\r\n end;\r\n end\r\n else\r\n if Wc.Controls[J] is TJvSimReverse then\r\n begin\r\n R := Wc.Controls[J].BoundsRect;\r\n InflateRect(R, D, 0);\r\n if PtInRect(R, Po) then\r\n begin\r\n sRev := TJvSimReverse(Wc.Controls[J]);\r\n // now check if P is in the input area\r\n pl := sRev.Gates[0].Pos;\r\n R := Rect(sRev.Left + pl.X, sRev.Top + pl.Y, sRev.Left + sRev.Width + D, sRev.Top + pl.Y + 12);\r\n if PtInRect(R, Po) and sRev.Gates[0].Active then\r\n begin // input\r\n sRev.Input1 := Vi;\r\n Exit;\r\n end;\r\n end;\r\n end\r\n else\r\n if Wc.Controls[J] is TJvLogic then\r\n begin\r\n R := Wc.Controls[J].BoundsRect;\r\n InflateRect(R, D, 0);\r\n if PtInRect(R, Po) then\r\n begin\r\n sLog := TJvLogic(Wc.Controls[J]);\r\n // now check if P is in one of the 3 input area's\r\n R := Rect(sLog.Left - D, sLog.Top, sLog.Left + 32, sLog.Top + 22);\r\n if PtInRect(R, Po) and sLog.Gates[0].Active then\r\n begin // input is gate 0\r\n sLog.Input1 := Vi;\r\n Exit;\r\n end;\r\n R := Rect(sLog.Left - D, sLog.Top + 23, sLog.Left + 32, sLog.Top + 44);\r\n if PtInRect(R, Po) and sLog.Gates[1].Active then\r\n begin // input is gate 1\r\n sLog.Input2 := Vi;\r\n Exit;\r\n end;\r\n R := Rect(sLog.Left - D, sLog.Top + 45, sLog.Left + 32, sLog.Top + 64);\r\n if PtInRect(R, Po) and sLog.Gates[2].Active then\r\n begin // input is gate 2\r\n sLog.Input3 := Vi;\r\n Exit;\r\n end;\r\n end;\r\n end;\r\n end;\r\n end;\r\n\r\nbegin\r\n // connect input and output using the FConPos\r\n d2 := FConSize div 2;\r\n D := FConSize;\r\n xw := Width - 1;\r\n yh := Height - 1;\r\n Wc := Parent;\r\n case FConPos of\r\n jcpTL:\r\n begin\r\n Pi := ParentPoint(d2, d2);\r\n Po := ParentPoint(xw - d2, yh - d2);\r\n end;\r\n jcpTR:\r\n begin\r\n Pi := ParentPoint(xw - d2, d2);\r\n Po := ParentPoint(d2, yh - d2);\r\n end;\r\n jcpBR:\r\n begin\r\n Pi := ParentPoint(xw - d2, yh - d2);\r\n Po := ParentPoint(d2, d2);\r\n end;\r\n jcpBL:\r\n begin\r\n Pi := ParentPoint(d2, yh - d2);\r\n Po := ParentPoint(xw - d2, d2);\r\n end;\r\n end;\r\n // get input Vi\r\n if GetVi then\r\n SetVo;\r\nend;\r\n\r\nprocedure TJvSIMConnector.Disconnect;\r\nvar\r\n Pi, Po: TPoint;\r\n R: TRect;\r\n D, d2, xw, yh: Integer;\r\n Wc: TWinControl;\r\n sLog: TJvLogic;\r\n sLight: TJvSimLight;\r\n\r\n // convert a corner point to a Parent point\r\n\r\n function ParentPoint(X, Y: Integer): TPoint;\r\n var\r\n P: TPoint;\r\n begin\r\n P := Point(X, Y);\r\n P := ClientToScreen(P);\r\n Result := Wc.ScreenToClient(P);\r\n end;\r\n\r\n procedure SetVo;\r\n var\r\n J: Integer;\r\n begin\r\n for J := 0 to Wc.ControlCount - 1 do\r\n begin\r\n if Wc.Controls[J] is TJvSimLight then\r\n begin\r\n R := Wc.Controls[J].BoundsRect;\r\n InflateRect(R, D, 0);\r\n if PtInRect(R, Po) then\r\n begin\r\n sLight := TJvSimLight(Wc.Controls[J]);\r\n FDisCon := sLight;\r\n //sLight.Lit:=False;\r\n Exit;\r\n end;\r\n end\r\n else\r\n if Wc.Controls[J] is TJvLogic then\r\n begin\r\n R := Wc.Controls[J].BoundsRect;\r\n InflateRect(R, D, 0);\r\n if PtInRect(R, Po) then\r\n begin\r\n sLog := TJvLogic(Wc.Controls[J]);\r\n // now check if P is in one of the 3 input area's\r\n R := Rect(sLog.Left - D, sLog.Top, sLog.Left + 32, sLog.Top + 22);\r\n if PtInRect(R, Po) and sLog.Gates[0].Active then\r\n begin // input is gate 0\r\n FDisCon := sLog;\r\n FDisConI := 1;\r\n // sLog.Input1:=False;\r\n Exit;\r\n end;\r\n R := Rect(sLog.Left - D, sLog.Top + 23, sLog.Left + 32, sLog.Top + 44);\r\n if PtInRect(R, Po) and sLog.Gates[1].Active then\r\n begin // input is gate 1\r\n FDisCon := sLog;\r\n FDisConI := 2;\r\n // sLog.Input2:=False;\r\n Exit;\r\n end;\r\n R := Rect(sLog.Left - D, sLog.Top + 45, sLog.Left + 32, sLog.Top + 64);\r\n if PtInRect(R, Po) and sLog.Gates[2].Active then\r\n begin // input is gate 2\r\n FDisCon := sLog;\r\n FDisConI := 3;\r\n // sLog.Input3:=False;\r\n Exit;\r\n end;\r\n end;\r\n end;\r\n end;\r\n end;\r\n\r\nbegin\r\n // connect input and output using the FConPos\r\n FDisCon := nil;\r\n FDisConI := 0;\r\n d2 := FConSize div 2;\r\n D := FConSize;\r\n xw := Width - 1;\r\n yh := Height - 1;\r\n Wc := Parent;\r\n case FConPos of\r\n jcpTL:\r\n begin\r\n Pi := ParentPoint(d2, d2);\r\n Po := ParentPoint(xw - d2, yh - d2);\r\n end;\r\n jcpTR:\r\n begin\r\n Pi := ParentPoint(xw - d2, d2);\r\n Po := ParentPoint(d2, yh - d2);\r\n end;\r\n jcpBR:\r\n begin\r\n Pi := ParentPoint(xw - d2, yh - d2);\r\n Po := ParentPoint(d2, d2);\r\n end;\r\n jcpBL:\r\n begin\r\n Pi := ParentPoint(d2, yh - d2);\r\n Po := ParentPoint(xw - d2, d2);\r\n end;\r\n end;\r\n // clear logic inputs and lights\r\n SetVo;\r\nend;\r\n\r\n//=== { TJvLogic } ===========================================================\r\n\r\nconstructor TJvLogic.Create(AOwner: TComponent);\r\nvar\r\n I: Integer;\r\nbegin\r\n inherited Create(AOwner);\r\n Width := 65;\r\n Height := 65;\r\n // initialize Gates\r\n FGates[0].Pos := Point(1, 10);\r\n FGates[1].Pos := Point(1, 28);\r\n FGates[2].Pos := Point(1, 46);\r\n FGates[3].Pos := Point(52, 10);\r\n FGates[4].Pos := Point(52, 28);\r\n FGates[5].Pos := Point(52, 46);\r\n for I := 0 to 5 do\r\n FGates[I].State := False;\r\n for I := 0 to 2 do\r\n begin\r\n FGates[I].Style := jgsDI;\r\n FGates[I + 3].Style := jgsDO;\r\n end;\r\n FLogicFunc := jlfAND;\r\n FGates[0].Active := True;\r\n FGates[1].Active := False;\r\n FGates[2].Active := True;\r\n FGates[3].Active := False;\r\n FGates[4].Active := True;\r\n FGates[5].Active := False;\r\n FConnectors := TList.Create;\r\nend;\r\n\r\ndestructor TJvLogic.Destroy;\r\nbegin\r\n FConnectors.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJvLogic.GetGate(Index: Integer): TJvGate;\r\nbegin\r\n Result := FGates[Index];\r\nend;\r\n\r\nprocedure TJvLogic.MouseDown(Button: TMouseButton; Shift: TShiftState;\r\n X, Y: Integer);\r\nvar\r\n R: TRect;\r\nbegin\r\n FDoMove := False;\r\n FDoStyle := False;\r\n FStyleDown := False;\r\n FMdp := Point(X, Y);\r\n R := ClientRect;\r\n InflateRect(R, -15, -15);\r\n FDoStyle := PtInRect(R, FMdp);\r\n FDoMove := not FDoStyle;\r\n FOldp := Point(X, Y);\r\n if FDoMove then\r\n AnchorConnectors;\r\n if FDoStyle then\r\n begin\r\n FStyleDown := True;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvLogic.MouseMove(Shift: TShiftState; X, Y: Integer);\r\nvar\r\n P: TPoint;\r\nbegin\r\n P := ClientToScreen(Point(X, Y));\r\n P := Parent.ScreenToClient(P);\r\n if ssLeft in Shift then\r\n begin\r\n if FDoMove then\r\n begin\r\n FNewLeft := P.X - FMdp.X;\r\n FNewTop := P.Y - FMdp.Y;\r\n MoveConnectors;\r\n Left := FNewLeft;\r\n Top := FNewTop;\r\n end\r\n end;\r\nend;\r\n\r\nprocedure TJvLogic.AnchorConnectors;\r\nvar\r\n Wc: TWinControl;\r\n I: Integer;\r\n Con: TJvSIMConnector;\r\n R, Rc: TRect;\r\n P: TPoint;\r\nbegin\r\n Wc := Parent;\r\n FConnectors.Clear;\r\n R := BoundsRect;\r\n InflateRect(R, 8, 0);\r\n P := Point(Left, Top);\r\n for I := 0 to Wc.ControlCount - 1 do\r\n if Wc.Controls[I] is TJvSIMConnector then\r\n begin\r\n Con := TJvSIMConnector(Wc.Controls[I]);\r\n // check for corners in bounds\r\n Rc := Con.BoundsRect;\r\n // TL\r\n if PtInRect(R, Point(Rc.Left, Rc.Top)) then\r\n begin\r\n FConnectors.Add(Con);\r\n Con.AnchorCorner(P, jcmTL);\r\n end\r\n // TR\r\n else\r\n if PtInRect(R, Point(Rc.Right, Rc.Top)) then\r\n begin\r\n FConnectors.Add(Con);\r\n Con.AnchorCorner(P, jcmTR);\r\n end\r\n // BR\r\n else\r\n if PtInRect(R, Point(Rc.Right, Rc.Bottom)) then\r\n begin\r\n FConnectors.Add(Con);\r\n Con.AnchorCorner(P, jcmBR);\r\n end\r\n // BL\r\n else\r\n if PtInRect(R, Point(Rc.Left, Rc.Bottom)) then\r\n begin\r\n FConnectors.Add(Con);\r\n Con.AnchorCorner(P, jcmBL);\r\n end\r\n end;\r\nend;\r\n\r\nprocedure TJvLogic.MouseUp(Button: TMouseButton; Shift: TShiftState;\r\n X, Y: Integer);\r\nbegin\r\n FStyleDown := False;\r\n if FDoStyle then\r\n begin\r\n FDoStyle := False;\r\n case FLogicFunc of\r\n jlfAND:\r\n LogicFunc := jlfOR;\r\n jlfOR:\r\n LogicFunc := jlfNOT;\r\n jlfNOT:\r\n LogicFunc := jlfAND;\r\n end;\r\n end;\r\n BinCheck(Self);\r\nend;\r\n\r\nprocedure TJvLogic.PaintLed(Index: Integer);\r\nvar\r\n SurfCol, LitCol: TColor;\r\n P: TPoint;\r\n X, Y: Integer;\r\n Lit: Boolean;\r\nbegin\r\n if not Gates[Index].Active then\r\n Exit;\r\n P := Gates[Index].Pos;\r\n X := P.X;\r\n Y := P.Y;\r\n if Index = 0 then\r\n Lit := FInput1\r\n else\r\n if Index = 1 then\r\n Lit := FInput2\r\n else\r\n if Index = 2 then\r\n Lit := FInput3\r\n else\r\n if Index = 3 then\r\n Lit := FOutput1\r\n else\r\n if Index = 4 then\r\n Lit := FOutput2\r\n else\r\n if Index = 5 then\r\n Lit := FOutput3\r\n else\r\n Lit := False;\r\n if Lit then\r\n begin\r\n if Gates[Index].Style = jgsDI then\r\n SurfCol := clLime\r\n else\r\n SurfCol := clRed;\r\n LitCol := clWhite;\r\n end\r\n else\r\n begin\r\n if Gates[Index].Style = jgsDI then\r\n begin\r\n SurfCol := clGreen;\r\n LitCol := clLime;\r\n end\r\n else\r\n begin\r\n SurfCol := clMaroon;\r\n LitCol := clRed;\r\n end;\r\n end;\r\n with Canvas do\r\n begin\r\n Brush.Color := clSilver;\r\n FillRect(Rect(X, Y, X + 12, Y + 13));\r\n Brush.Style := bsClear;\r\n Pen.Color := clGray;\r\n Ellipse(X, Y, X + 12, Y + 13);\r\n Pen.Color := clBlack;\r\n Brush.Color := SurfCol;\r\n Ellipse(X + 1, Y + 1, X + 11, Y + 12);\r\n Pen.Color := clWhite;\r\n Arc(X + 1, Y + 1, X + 11, Y + 12, X + 0, Y + 12, X + 12, Y + 0);\r\n Pen.Color := LitCol;\r\n Arc(X + 3, Y + 3, X + 8, Y + 9, X + 5, Y + 0, X + 0, Y + 8);\r\n end;\r\nend;\r\n\r\nprocedure TJvLogic.Paint;\r\nvar\r\n I: Integer;\r\n R: TRect;\r\n S: string;\r\nbegin\r\n with Canvas do\r\n begin\r\n Brush.Color := clSilver;\r\n R := ClientRect;\r\n FillRect(R);\r\n Frame3D(Canvas, R, clBtnHighlight, clBtnShadow, 1);\r\n // Frame3D(Canvas,R,clBtnShadow,clBtnHighlight,1);\r\n Brush.Color := clRed;\r\n for I := 0 to 5 do\r\n PaintLed(I);\r\n R := ClientRect;\r\n InflateRect(R, -15, -15);\r\n if FStyleDown then\r\n Frame3D(Canvas, R, clBtnShadow, clBtnHighlight, 1)\r\n else\r\n Frame3D(Canvas, R, clBtnHighlight, clBtnShadow, 1);\r\n // Draw caption\r\n case FLogicFunc of\r\n jlfAND:\r\n S := 'AND'; // do not localize\r\n jlfOR:\r\n S := 'OR'; // do not localize\r\n jlfNOT:\r\n S := 'NOT'; // do not localize\r\n end;\r\n Brush.Style := bsClear;\r\n DrawText(Canvas.handle, PChar(S), -1, R, DT_SINGLELINE or DT_CENTER or DT_VCENTER);\r\n end;\r\nend;\r\n\r\nprocedure TJvLogic.Resize;\r\nbegin\r\n Width := 65;\r\n Height := 65;\r\nend;\r\n\r\nprocedure TJvLogic.MoveConnectors;\r\nvar\r\n I: Integer;\r\n Con: TJvSIMConnector;\r\nbegin\r\n for I := 0 to FConnectors.Count - 1 do\r\n begin\r\n Con := TJvSIMConnector(FConnectors[I]);\r\n Con.MoveConnector(Point(FNewLeft, FNewTop));\r\n end;\r\nend;\r\n\r\nprocedure TJvLogic.OutCalc;\r\nbegin\r\n case FLogicFunc of\r\n jlfAND:\r\n Output2 := Input1 and Input3;\r\n jlfOR:\r\n Output2 := Input1 or Input3;\r\n jlfNOT:\r\n Output2 := not Input2;\r\n end;\r\n\r\nend;\r\n\r\nprocedure TJvLogic.SetInput1(const Value: Boolean);\r\nbegin\r\n if Value <> FInput1 then\r\n begin\r\n FInput1 := Value;\r\n Invalidate;\r\n OutCalc;\r\n end;\r\nend;\r\n\r\nprocedure TJvLogic.SetInput2(const Value: Boolean);\r\nbegin\r\n if Value <> FInput2 then\r\n begin\r\n FInput2 := Value;\r\n Invalidate;\r\n OutCalc;\r\n end;\r\nend;\r\n\r\nprocedure TJvLogic.SetInput3(const Value: Boolean);\r\nbegin\r\n if Value <> FInput3 then\r\n begin\r\n FInput3 := Value;\r\n Invalidate;\r\n OutCalc;\r\n end;\r\nend;\r\n\r\nprocedure TJvLogic.SetOutput1(const Value: Boolean);\r\nbegin\r\n if Value <> FOutput1 then\r\n begin\r\n FOutput1 := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvLogic.SetOutput2(const Value: Boolean);\r\nbegin\r\n if Value <> FOutput2 then\r\n begin\r\n FOutput2 := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvLogic.SetOutput3(const Value: Boolean);\r\nbegin\r\n if Value <> FOutput3 then\r\n begin\r\n FOutput3 := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvLogic.SetLogicFunc(const Value: TJvLogicFunc);\r\nbegin\r\n if Value <> FLogicFunc then\r\n begin\r\n FLogicFunc := Value;\r\n case FLogicFunc of\r\n jlfAND:\r\n begin\r\n FGates[0].Active := True;\r\n FGates[1].Active := False;\r\n FGates[2].Active := True;\r\n FGates[3].Active := False;\r\n FGates[4].Active := True;\r\n FGates[5].Active := False;\r\n end;\r\n jlfOR:\r\n begin\r\n FGates[0].Active := True;\r\n FGates[1].Active := False;\r\n FGates[2].Active := True;\r\n FGates[3].Active := False;\r\n FGates[4].Active := True;\r\n FGates[5].Active := False;\r\n end;\r\n jlfNOT:\r\n begin\r\n FGates[0].Active := False;\r\n FGates[1].Active := True;\r\n FGates[2].Active := False;\r\n FGates[3].Active := False;\r\n FGates[4].Active := True;\r\n FGates[5].Active := False;\r\n end;\r\n end;\r\n Invalidate;\r\n OutCalc;\r\n end;\r\nend;\r\n\r\n//=== { TJvSimButton } =======================================================\r\n\r\nconstructor TJvSimButton.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FDown := False;\r\n Width := 65;\r\n Height := 65;\r\n FConnectors := TList.Create;\r\nend;\r\n\r\ndestructor TJvSimButton.Destroy;\r\nbegin\r\n FConnectors.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvSimButton.AnchorConnectors;\r\nvar\r\n Wc: TWinControl;\r\n I: Integer;\r\n Con: TJvSIMConnector;\r\n R, Rc: TRect;\r\n P: TPoint;\r\nbegin\r\n Wc := Parent;\r\n FConnectors.Clear;\r\n R := BoundsRect;\r\n InflateRect(R, 8, 8);\r\n P := Point(Left, Top);\r\n for I := 0 to Wc.ControlCount - 1 do\r\n if Wc.Controls[I] is TJvSIMConnector then\r\n begin\r\n Con := TJvSIMConnector(Wc.Controls[I]);\r\n // check for corners in bounds\r\n Rc := Con.BoundsRect;\r\n // TL\r\n if PtInRect(R, Point(Rc.Left, Rc.Top)) then\r\n begin\r\n FConnectors.Add(Con);\r\n Con.AnchorCorner(P, jcmTL);\r\n end\r\n // TR\r\n else\r\n if PtInRect(R, Point(Rc.Right, Rc.Top)) then\r\n begin\r\n FConnectors.Add(Con);\r\n Con.AnchorCorner(P, jcmTR);\r\n end\r\n // BR\r\n else\r\n if PtInRect(R, Point(Rc.Right, Rc.Bottom)) then\r\n begin\r\n FConnectors.Add(Con);\r\n Con.AnchorCorner(P, jcmBR);\r\n end\r\n // BL\r\n else\r\n if PtInRect(R, Point(Rc.Left, Rc.Bottom)) then\r\n begin\r\n FConnectors.Add(Con);\r\n Con.AnchorCorner(P, jcmBL);\r\n end\r\n end;\r\nend;\r\n\r\nprocedure TJvSimButton.MouseDown(Button: TMouseButton; Shift: TShiftState;\r\n X, Y: Integer);\r\nvar\r\n R: TRect;\r\nbegin\r\n FMdp := Point(X, Y);\r\n R := ClientRect;\r\n InflateRect(R, -15, -15);\r\n FDoMove := not PtInRect(R, FMdp);\r\n FDepressed := not FDoMove;\r\n FOldp := Point(X, Y);\r\n if FDoMove then\r\n AnchorConnectors\r\n else\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvSimButton.MouseMove(Shift: TShiftState; X, Y: Integer);\r\nvar\r\n P: TPoint;\r\nbegin\r\n if FDepressed then\r\n Exit;\r\n P := ClientToScreen(Point(X, Y));\r\n P := Parent.ScreenToClient(P);\r\n if ssLeft in Shift then\r\n begin\r\n if FDoMove then\r\n begin\r\n FNewLeft := P.X - FMdp.X;\r\n FNewTop := P.Y - FMdp.Y;\r\n MoveConnectors;\r\n Left := FNewLeft;\r\n Top := FNewTop;\r\n end\r\n end;\r\nend;\r\n\r\nprocedure TJvSimButton.MouseUp(Button: TMouseButton; Shift: TShiftState;\r\n X, Y: Integer);\r\nvar\r\n R: TRect;\r\n P: TPoint;\r\nbegin\r\n FDepressed := False;\r\n P := Point(X, Y);\r\n R := ClientRect;\r\n InflateRect(R, -15, -15);\r\n if PtInRect(R, P) then\r\n begin\r\n Down := not FDown;\r\n end\r\n else\r\n BinCheck(Self);\r\nend;\r\n\r\nprocedure TJvSimButton.MoveConnectors;\r\nvar\r\n I: Integer;\r\n Con: TJvSIMConnector;\r\nbegin\r\n for I := 0 to FConnectors.Count - 1 do\r\n begin\r\n Con := TJvSIMConnector(FConnectors[I]);\r\n Con.MoveConnector(Point(FNewLeft, FNewTop));\r\n end;\r\nend;\r\n\r\nprocedure TJvSimButton.Paint;\r\nvar\r\n P: TPoint;\r\n R: TRect;\r\nbegin\r\n with Canvas do\r\n begin\r\n Brush.Color := clSilver;\r\n R := ClientRect;\r\n FillRect(R);\r\n Frame3D(Canvas, R, clBtnHighlight, clBtnShadow, 1);\r\n InflateRect(R, -15, -15);\r\n if FDepressed or FDown then\r\n Frame3D(Canvas, R, clBtnShadow, clBtnHighlight, 1)\r\n else\r\n Frame3D(Canvas, R, clBtnHighlight, clBtnShadow, 1);\r\n P := Point((Width div 2) - 6, (Height div 2) - 6);\r\n PaintLed(P, FDown);\r\n end;\r\nend;\r\n\r\nprocedure TJvSimButton.PaintLed(Pt: TPoint; Lit: Boolean);\r\nvar\r\n SurfCol, LitCol: TColor;\r\n X, Y: Integer;\r\nbegin\r\n X := Pt.X;\r\n Y := Pt.Y;\r\n if Lit then\r\n begin\r\n SurfCol := clRed;\r\n LitCol := clWhite\r\n end\r\n else\r\n begin\r\n SurfCol := clMaroon;\r\n LitCol := clRed;\r\n end;\r\n with Canvas do\r\n begin\r\n Brush.Color := clSilver;\r\n FillRect(Rect(X, Y, X + 12, Y + 13));\r\n Brush.Style := bsClear;\r\n Pen.Color := clGray;\r\n Ellipse(X, Y, X + 12, Y + 13);\r\n Pen.Color := clBlack;\r\n Brush.Color := SurfCol;\r\n Ellipse(X + 1, Y + 1, X + 11, Y + 12);\r\n Pen.Color := clWhite;\r\n Arc(X + 1, Y + 1, X + 11, Y + 12, X + 0, Y + 12, X + 12, Y + 0);\r\n Pen.Color := LitCol;\r\n Arc(X + 3, Y + 3, X + 8, Y + 9, X + 5, Y + 0, X + 0, Y + 8);\r\n end;\r\nend;\r\n\r\nprocedure TJvSimButton.Resize;\r\nbegin\r\n Width := 65;\r\n Height := 65;\r\nend;\r\n\r\nprocedure TJvSimButton.SetDown(const Value: Boolean);\r\nbegin\r\n if Value <> FDown then\r\n begin\r\n FDown := Value;\r\n FDepressed := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\n//=== { TJvSimLight } ========================================================\r\n\r\nconstructor TJvSimLight.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FLit := False;\r\n Width := 65;\r\n Height := 65;\r\n FColorOn := clLime;\r\n FColorOff := clGreen;\r\n FConnectors := TList.Create;\r\nend;\r\n\r\ndestructor TJvSimLight.Destroy;\r\nbegin\r\n FConnectors.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvSimLight.AnchorConnectors;\r\nvar\r\n Wc: TWinControl;\r\n I: Integer;\r\n Con: TJvSIMConnector;\r\n R, Rc: TRect;\r\n P: TPoint;\r\nbegin\r\n Wc := Parent;\r\n FConnectors.Clear;\r\n R := BoundsRect;\r\n InflateRect(R, 8, 8);\r\n P := Point(Left, Top);\r\n for I := 0 to Wc.ControlCount - 1 do\r\n if Wc.Controls[I] is TJvSIMConnector then\r\n begin\r\n Con := TJvSIMConnector(Wc.Controls[I]);\r\n // check for corners in bounds\r\n Rc := Con.BoundsRect;\r\n // TL\r\n if PtInRect(R, Point(Rc.Left, Rc.Top)) then\r\n begin\r\n FConnectors.Add(Con);\r\n Con.AnchorCorner(P, jcmTL);\r\n end\r\n // TR\r\n else\r\n if PtInRect(R, Point(Rc.Right, Rc.Top)) then\r\n begin\r\n FConnectors.Add(Con);\r\n Con.AnchorCorner(P, jcmTR);\r\n end\r\n // BR\r\n else\r\n if PtInRect(R, Point(Rc.Right, Rc.Bottom)) then\r\n begin\r\n FConnectors.Add(Con);\r\n Con.AnchorCorner(P, jcmBR);\r\n end\r\n // BL\r\n else\r\n if PtInRect(R, Point(Rc.Left, Rc.Bottom)) then\r\n begin\r\n FConnectors.Add(Con);\r\n Con.AnchorCorner(P, jcmBL);\r\n end\r\n end;\r\nend;\r\n\r\nprocedure TJvSimLight.MouseDown(Button: TMouseButton; Shift: TShiftState;\r\n X, Y: Integer);\r\nbegin\r\n FMdp := Point(X, Y);\r\n FDoMove := True;\r\n FOldp := Point(X, Y);\r\n AnchorConnectors;\r\nend;\r\n\r\nprocedure TJvSimLight.MouseMove(Shift: TShiftState; X, Y: Integer);\r\nvar\r\n P: TPoint;\r\nbegin\r\n P := ClientToScreen(Point(X, Y));\r\n P := Parent.ScreenToClient(P);\r\n if ssLeft in Shift then\r\n begin\r\n if FDoMove then\r\n begin\r\n FNewLeft := P.X - FMdp.X;\r\n FNewTop := P.Y - FMdp.Y;\r\n MoveConnectors;\r\n Left := FNewLeft;\r\n Top := FNewTop;\r\n end\r\n end;\r\nend;\r\n\r\nprocedure TJvSimLight.MouseUp(Button: TMouseButton; Shift: TShiftState;\r\n X, Y: Integer);\r\nbegin\r\n BinCheck(Self);\r\nend;\r\n\r\nprocedure TJvSimLight.MoveConnectors;\r\nvar\r\n I: Integer;\r\n Con: TJvSIMConnector;\r\nbegin\r\n for I := 0 to FConnectors.Count - 1 do\r\n begin\r\n Con := TJvSIMConnector(FConnectors[I]);\r\n Con.MoveConnector(Point(FNewLeft, FNewTop));\r\n end;\r\nend;\r\n\r\nprocedure TJvSimLight.Paint;\r\nvar\r\n TlPoly, BrPoly: array [0..2] of TPoint;\r\n xw, yh: Integer;\r\n R: TRect;\r\n HiColor, LoColor, SurfCol: TColor;\r\n\r\n procedure DrawFrame;\r\n begin\r\n // rgn := CreatePolygonRgn(TlPoly,3,WINDING);\r\n // SelectClipRgn(Canvas.handle,rgn);\r\n with Canvas do\r\n begin\r\n Brush.Color := SurfCol;\r\n Pen.Color := HiColor;\r\n Pen.Width := 2;\r\n Ellipse(15, 15, xw - 15, yh - 15);\r\n end;\r\n // SelectClipRgn(Canvas.handle,0);\r\n // DeleteObject(rgn);\r\n // rgn := CreatePolygonRgn(BrPoly,3,WINDING);\r\n // SelectClipRgn(Canvas.handle,rgn);\r\n with Canvas do\r\n begin\r\n Brush.Color := SurfCol;\r\n Pen.Color := LoColor;\r\n Pen.Width := 2;\r\n Arc(15, 15, xw - 15, yh - 15, 0, yh, xw, 0);\r\n Pen.Width := 1;\r\n end;\r\n // SelectClipRgn(Canvas.handle,0);\r\n // DeleteObject(rgn);\r\n end;\r\n\r\nbegin\r\n if Lit then\r\n SurfCol := ColorOn\r\n else\r\n SurfCol := ColorOff;\r\n Canvas.Brush.Style := bsSolid;\r\n R := ClientRect;\r\n Canvas.Brush.Color := clSilver;\r\n Canvas.FillRect(R);\r\n Frame3D(Canvas, R, clBtnHighlight, clBtnShadow, 1);\r\n xw := Width - 1;\r\n yh := Height - 1;\r\n// cr := Width div 4;\r\n// x4 := Width div 4;\r\n // topleft region\r\n TlPoly[0] := Point(Left, Top + yh);\r\n TlPoly[1] := Point(Left, Top);\r\n TlPoly[2] := Point(Left + xw, Top);\r\n // Bottom Right region\r\n BrPoly[0] := Point(Left + xw, Top);\r\n BrPoly[1] := Point(Left + xw, Top + yh);\r\n BrPoly[2] := Point(Left, Top + yh);\r\n Canvas.Pen.Style := psSolid;\r\n HiColor := clBtnHighlight;\r\n LoColor := clBtnShadow;\r\n DrawFrame;\r\nend;\r\n\r\nprocedure TJvSimLight.Resize;\r\nbegin\r\n Width := 65;\r\n Height := 65;\r\nend;\r\n\r\nprocedure TJvSimLight.SetLit(const Value: Boolean);\r\nbegin\r\n if Value <> FLit then\r\n begin\r\n FLit := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvSimLight.SetColorOff(const Value: TColor);\r\nbegin\r\n if Value <> FColorOff then\r\n begin\r\n FColorOff := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvSimLight.SetColorOn(const Value: TColor);\r\nbegin\r\n if Value <> FColorOn then\r\n begin\r\n FColorOn := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\n//=== { TJvSimBin } ==========================================================\r\n\r\nconstructor TJvSimBin.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n Width := 65;\r\n Height := 65;\r\n FBmpBin := TBitmap.Create;\r\n FBmpBin.LoadFromResourceName(HInstance, 'JvSimLogicBoxBIN'); // do not localize\r\nend;\r\n\r\ndestructor TJvSimBin.Destroy;\r\nbegin\r\n FBmpBin.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvSimBin.Paint;\r\nvar\r\n Rf: TRect;\r\nbegin\r\n Rf := ClientRect;\r\n Canvas.Brush.Color := clSilver;\r\n Canvas.FillRect(Rect(0, 0, Width, Height));\r\n Frame3D(Canvas, Rf, clBtnHighlight, clBtnShadow, 1);\r\n Canvas.Draw(16, 16, FBmpBin);\r\nend;\r\n\r\nprocedure TJvSimBin.Resize;\r\nbegin\r\n inherited Resize;\r\n Width := 65;\r\n Height := 65;\r\nend;\r\n\r\n//=== { TJvSimLogicBox } =====================================================\r\n\r\nconstructor TJvSimLogicBox.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n Width := 130;\r\n Height := 65;\r\n FBmpCon := TBitmap.Create;\r\n FBmpLogic := TBitmap.Create;\r\n FBmpButton := TBitmap.Create;\r\n FBmpLight := TBitmap.Create;\r\n FBmpRev := TBitmap.Create;\r\n FBmpBin := TBitmap.Create;\r\n FBmpCon.LoadFromResourceName(HInstance, 'JvSimLogicBoxCON'); // do not localize\r\n FBmpLogic.LoadFromResourceName(HInstance, 'JvSimLogicBoxLOGIC'); // do not localize\r\n FBmpButton.LoadFromResourceName(HInstance, 'JvSimLogicBoxBUTTON'); // do not localize\r\n FBmpLight.LoadFromResourceName(HInstance, 'JvSimLogicBoxLIGHT'); // do not localize\r\n FBmpRev.LoadFromResourceName(HInstance, 'JvSimLogicBoxREV'); // do not localize\r\n FBmpBin.LoadFromResourceName(HInstance, 'JvSimLogicBoxBIN'); // do not localize\r\n FRCon := Rect(0, 0, 32, 32);\r\n FRLogic := Rect(33, 0, 64, 32);\r\n FRButton := Rect(0, 33, 32, 64);\r\n FRLight := Rect(33, 33, 64, 64);\r\n FRRev := Rect(65, 0, 97, 32);\r\n FDCon := False;\r\n FDLogic := False;\r\n FDButton := False;\r\n FDLight := False;\r\n FDRev := False;\r\n FCpu := TTimer.Create(Self);\r\n FCpu.Enabled := False;\r\n FCpu.OnTimer := CpuOnTimer;\r\n FCpu.Interval := 50;\r\nend;\r\n\r\ndestructor TJvSimLogicBox.Destroy;\r\nbegin\r\n FCpu.Free;\r\n FBmpCon.Free;\r\n FBmpLogic.Free;\r\n FBmpButton.Free;\r\n FBmpLight.Free;\r\n FBmpRev.Free;\r\n FBmpBin.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvSimLogicBox.Loaded;\r\nbegin\r\n inherited Loaded;\r\n FCpu.Enabled := True;\r\nend;\r\n\r\nprocedure TJvSimLogicBox.CpuOnTimer(Sender: TObject);\r\nvar\r\n Wc: TWinControl;\r\n I: Integer;\r\nbegin\r\n Wc := Parent;\r\n // reset inputs\r\n{ for I:=0 to Wc.ControlCount-1 do\r\n if (Wc.Controls[I] is TJvLogic) then\r\n begin\r\n sLogic:=TJvLogic(Wc.Controls[I]);\r\n for j:=0 to 2 do\r\n sLogic.FGates[j].State:=False;\r\n end\r\n else\r\n if (Wc.Controls[I] is TJvSimLight) then\r\n begin\r\n sLight:=TJvSimLight(Wc.Controls[I]);\r\n sLight.Lit:=False;\r\n end;}\r\n // make connections\r\n for I := 0 to Wc.ControlCount - 1 do\r\n if Wc.Controls[I] is TJvSIMConnector then\r\n TJvSIMConnector(Wc.Controls[I]).Connect;\r\nend;\r\n\r\nprocedure TJvSimLogicBox.MouseDown(Button: TMouseButton;\r\n Shift: TShiftState; X, Y: Integer);\r\nvar\r\n P: TPoint;\r\nbegin\r\n P := Point(X, Y);\r\n FDCon := False;\r\n FDLogic := False;\r\n FDButton := False;\r\n FDLight := False;\r\n if PtInRect(FRCon, P) then\r\n FDCon := True\r\n else\r\n if PtInRect(FRLogic, P) then\r\n FDLogic := True\r\n else\r\n if PtInRect(FRButton, P) then\r\n FDButton := True\r\n else\r\n if PtInRect(FRLight, P) then\r\n FDLight := True\r\n else\r\n if PtInRect(FRRev, P) then\r\n FDRev := True;\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvSimLogicBox.MouseUp(Button: TMouseButton; Shift: TShiftState;\r\n X, Y: Integer);\r\nvar\r\n Wc: TWinControl;\r\n l, t: Integer;\r\nbegin\r\n Wc := Parent;\r\n l := Left;\r\n t := Top + Height + 10;\r\n if FDCon then\r\n with TJvSIMConnector.Create(Wc) do\r\n begin\r\n Parent := Wc;\r\n Left := l;\r\n Top := t;\r\n end\r\n else\r\n if FDLogic then\r\n with TJvLogic.Create(Wc) do\r\n begin\r\n Parent := Wc;\r\n Left := l;\r\n Top := t;\r\n end\r\n else\r\n if FDButton then\r\n with TJvSimButton.Create(Wc) do\r\n begin\r\n Parent := Wc;\r\n Left := l;\r\n Top := t;\r\n end\r\n else\r\n if FDLight then\r\n with TJvSimLight.Create(Wc) do\r\n begin\r\n Parent := Wc;\r\n Left := l;\r\n Top := t;\r\n end\r\n else\r\n if FDRev then\r\n with TJvSimReverse.Create(Wc) do\r\n begin\r\n Parent := Wc;\r\n Left := l;\r\n Top := t;\r\n end;\r\n FDCon := False;\r\n FDLogic := False;\r\n FDButton := False;\r\n FDLight := False;\r\n FDRev := False;\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvSimLogicBox.Paint;\r\nvar\r\n Rb: TRect;\r\nbegin\r\n with Canvas do\r\n begin\r\n Brush.Color := clSilver;\r\n FillRect(ClientRect);\r\n Rb := FRCon;\r\n if not FDCon then\r\n Frame3D(Canvas, Rb, clBtnHighlight, clBtnShadow, 1)\r\n else\r\n Frame3D(Canvas, Rb, clBtnShadow, clBtnHighlight, 1);\r\n Draw(4, 4, FBmpCon);\r\n Rb := FRLogic;\r\n if not FDLogic then\r\n Frame3D(Canvas, Rb, clBtnHighlight, clBtnShadow, 1)\r\n else\r\n Frame3D(Canvas, Rb, clBtnShadow, clBtnHighlight, 1);\r\n Draw(36, 4, FBmpLogic);\r\n Rb := FRButton;\r\n if not FDButton then\r\n Frame3D(Canvas, Rb, clBtnHighlight, clBtnShadow, 1)\r\n else\r\n Frame3D(Canvas, Rb, clBtnShadow, clBtnHighlight, 1);\r\n Draw(4, 36, FBmpButton);\r\n Rb := FRLight;\r\n if not FDLight then\r\n Frame3D(Canvas, Rb, clBtnHighlight, clBtnShadow, 1)\r\n else\r\n Frame3D(Canvas, Rb, clBtnShadow, clBtnHighlight, 1);\r\n Draw(36, 36, FBmpLight);\r\n Rb := FRRev;\r\n if not FDRev then\r\n Frame3D(Canvas, Rb, clBtnHighlight, clBtnShadow, 1)\r\n else\r\n Frame3D(Canvas, Rb, clBtnShadow, clBtnHighlight, 1);\r\n Draw(Rb.Left + 3, Rb.Top + 3, FBmpRev);\r\n\r\n // Draw bin\r\n Draw(100, 16, FBmpBin);\r\n end;\r\nend;\r\n\r\nprocedure TJvSimLogicBox.Resize;\r\nbegin\r\n Width := 130;\r\n Height := 65;\r\nend;\r\n\r\n//=== { TJvSimReverse } ======================================================\r\n\r\nconstructor TJvSimReverse.Create(AOwner: TComponent);\r\nvar\r\n I: Integer;\r\nbegin\r\n inherited Create(AOwner);\r\n Width := 42;\r\n Height := 42;\r\n // initialize Gates\r\n FGates[0].Pos := Point(28, 14);\r\n FGates[1].Pos := Point(14, 1);\r\n FGates[2].Pos := Point(1, 14);\r\n FGates[3].Pos := Point(14, 28);\r\n for I := 0 to 3 do\r\n begin\r\n FGates[I].State := False;\r\n FGates[I].Active := True;\r\n FGates[I].Style := jgsDO;\r\n end;\r\n FGates[0].Style := jgsDI;\r\n FConnectors := TList.Create;\r\nend;\r\n\r\ndestructor TJvSimReverse.Destroy;\r\nbegin\r\n FConnectors.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvSimReverse.AnchorConnectors;\r\nvar\r\n Wc: TWinControl;\r\n I: Integer;\r\n Con: TJvSIMConnector;\r\n R, Rc: TRect;\r\n P: TPoint;\r\nbegin\r\n Wc := Parent;\r\n FConnectors.Clear;\r\n R := BoundsRect;\r\n InflateRect(R, 8, 0);\r\n P := Point(Left, Top);\r\n for I := 0 to Wc.ControlCount - 1 do\r\n if Wc.Controls[I] is TJvSIMConnector then\r\n begin\r\n Con := TJvSIMConnector(Wc.Controls[I]);\r\n // check for corners in bounds\r\n Rc := Con.BoundsRect;\r\n // TL\r\n if PtInRect(R, Point(Rc.Left, Rc.Top)) then\r\n begin\r\n FConnectors.Add(Con);\r\n Con.AnchorCorner(P, jcmTL);\r\n end\r\n // TR\r\n else\r\n if PtInRect(R, Point(Rc.Right, Rc.Top)) then\r\n begin\r\n FConnectors.Add(Con);\r\n Con.AnchorCorner(P, jcmTR);\r\n end\r\n // BR\r\n else\r\n if PtInRect(R, Point(Rc.Right, Rc.Bottom)) then\r\n begin\r\n FConnectors.Add(Con);\r\n Con.AnchorCorner(P, jcmBR);\r\n end\r\n // BL\r\n else\r\n if PtInRect(R, Point(Rc.Left, Rc.Bottom)) then\r\n begin\r\n FConnectors.Add(Con);\r\n Con.AnchorCorner(P, jcmBL);\r\n end\r\n end;\r\nend;\r\n\r\nfunction TJvSimReverse.GetGate(Index: Integer): TJvGate;\r\nbegin\r\n Result := FGates[Index];\r\nend;\r\n\r\nprocedure TJvSimReverse.MouseDown(Button: TMouseButton;\r\n Shift: TShiftState; X, Y: Integer);\r\nbegin\r\n FMdp := Point(X, Y);\r\n FOldp := Point(X, Y);\r\n FDoMove := True;\r\n AnchorConnectors;\r\nend;\r\n\r\nprocedure TJvSimReverse.MouseMove(Shift: TShiftState; X, Y: Integer);\r\nvar\r\n P: TPoint;\r\nbegin\r\n P := ClientToScreen(Point(X, Y));\r\n P := Parent.ScreenToClient(P);\r\n if ssLeft in Shift then\r\n begin\r\n if FDoMove then\r\n begin\r\n FNewLeft := P.X - FMdp.X;\r\n FNewTop := P.Y - FMdp.Y;\r\n MoveConnectors;\r\n Left := FNewLeft;\r\n Top := FNewTop;\r\n end\r\n end;\r\nend;\r\n\r\nprocedure TJvSimReverse.MouseUp(Button: TMouseButton; Shift: TShiftState;\r\n X, Y: Integer);\r\nbegin\r\n BinCheck(Self);\r\nend;\r\n\r\nprocedure TJvSimReverse.MoveConnectors;\r\nvar\r\n I: Integer;\r\n Con: TJvSIMConnector;\r\nbegin\r\n for I := 0 to FConnectors.Count - 1 do\r\n begin\r\n Con := TJvSIMConnector(FConnectors[I]);\r\n Con.MoveConnector(Point(FNewLeft, FNewTop));\r\n end;\r\nend;\r\n\r\nprocedure TJvSimReverse.OutCalc;\r\nbegin\r\n Output1 := Input1;\r\n Output2 := Input1;\r\n Output3 := Input1;\r\nend;\r\n\r\nprocedure TJvSimReverse.Paint;\r\nvar\r\n I: Integer;\r\n R: TRect;\r\n Poly: array [0..2] of TPoint;\r\nbegin\r\n with Canvas do\r\n begin\r\n Brush.Color := clSilver;\r\n R := ClientRect;\r\n FillRect(R);\r\n Frame3D(Canvas, R, clBtnHighlight, clBtnShadow, 1);\r\n Brush.Color := clRed;\r\n for I := 0 to 3 do\r\n PaintLed(I);\r\n R := ClientRect;\r\n // paint triangle\r\n Poly[0] := Point(14, 20);\r\n Poly[1] := Point(26, 14);\r\n Poly[2] := Point(26, 26);\r\n Pen.Style := psClear;\r\n Brush.Color := clBlack;\r\n Polygon(Poly);\r\n Pen.Style := psSolid;\r\n end;\r\nend;\r\n\r\nprocedure TJvSimReverse.PaintLed(Index: Integer);\r\nvar\r\n SurfCol, LitCol: TColor;\r\n P: TPoint;\r\n X, Y: Integer;\r\n Lit: Boolean;\r\nbegin\r\n if not Gates[Index].Active then\r\n Exit;\r\n P := Gates[Index].Pos;\r\n X := P.X;\r\n Y := P.Y;\r\n if Index = 0 then\r\n Lit := Input1\r\n else\r\n if Index = 1 then\r\n Lit := Output1\r\n else\r\n if Index = 2 then\r\n Lit := Output2\r\n else\r\n if Index = 3 then\r\n Lit := Output3\r\n else\r\n Lit := False;\r\n if Lit then\r\n begin\r\n if Gates[Index].Style = jgsDI then\r\n SurfCol := clLime\r\n else\r\n SurfCol := clRed;\r\n LitCol := clWhite;\r\n end\r\n else\r\n begin\r\n if Gates[Index].Style = jgsDI then\r\n begin\r\n SurfCol := clGreen;\r\n LitCol := clLime;\r\n end\r\n else\r\n begin\r\n SurfCol := clMaroon;\r\n LitCol := clRed;\r\n end;\r\n end;\r\n with Canvas do\r\n begin\r\n Brush.Color := clSilver;\r\n FillRect(Rect(X, Y, X + 12, Y + 13));\r\n Brush.Style := bsClear;\r\n Pen.Color := clGray;\r\n Ellipse(X, Y, X + 12, Y + 13);\r\n Pen.Color := clBlack;\r\n Brush.Color := SurfCol;\r\n Ellipse(X + 1, Y + 1, X + 11, Y + 12);\r\n Pen.Color := clWhite;\r\n Arc(X + 1, Y + 1, X + 11, Y + 12, X + 0, Y + 12, X + 12, Y + 0);\r\n Pen.Color := LitCol;\r\n Arc(X + 3, Y + 3, X + 8, Y + 9, X + 5, Y + 0, X + 0, Y + 8);\r\n end;\r\nend;\r\n\r\nprocedure TJvSimReverse.Resize;\r\nbegin\r\n Width := 42;\r\n Height := 42;\r\nend;\r\n\r\nprocedure TJvSimReverse.SetInput1(const Value: Boolean);\r\nbegin\r\n if Value <> FInput1 then\r\n begin\r\n FInput1 := Value;\r\n Invalidate;\r\n OutCalc;\r\n end;\r\nend;\r\n\r\nprocedure TJvSimReverse.SetOutput1(const Value: Boolean);\r\nbegin\r\n if Value <> FOutput1 then\r\n begin\r\n FOutput1 := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvSimReverse.SetOutput2(const Value: Boolean);\r\nbegin\r\n if Value <> FOutput2 then\r\n begin\r\n FOutput2 := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvSimReverse.SetOutput3(const Value: Boolean);\r\nbegin\r\n if Value <> FOutput3 then\r\n begin\r\n FOutput3 := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvSimPID.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvSimPID.PAS, released on 2002-06-15.\r\n\r\nThe Initial Developer of the Original Code is Jan Verhoeven [jan1 dott verhoeven att wxs dott nl]\r\nPortions created by Jan Verhoeven are Copyright (C) 2002 Jan Verhoeven.\r\nAll Rights Reserved.\r\n\r\nContributor(s): Robert Love [rlove att slcdug dott org].\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvSimPID.pas 13104 2011-09-07 06:50:43Z obones $\r\n\r\nunit JvSimPID;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n SysUtils, Classes, Windows, Messages, Graphics, Controls,\r\n JvComponent;\r\n\r\ntype\r\n TJvSymFunc = (sfPid, sfAdd, sfCompare, sfRamp, sfMul);\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvSimPID = class(TJvGraphicControl)\r\n private\r\n FMV: Extended;\r\n FMVColor: TColor;\r\n FSP: Extended;\r\n FSPColor: TColor;\r\n FCV: Extended;\r\n FCVColor: TColor;\r\n FKD: Extended;\r\n FKP: Extended;\r\n FKI: Extended;\r\n FI: Extended;\r\n FD: Extended;\r\n FDirect: Boolean;\r\n FManual: Boolean;\r\n FSource: TJvSimPID;\r\n FActive: Boolean;\r\n FSymFunc: TJvSymFunc;\r\n procedure SetMV(Value: Extended);\r\n procedure SetMVColor(Value: TColor);\r\n procedure SetSP(const Value: Extended);\r\n procedure SetSPColor(const Value: TColor);\r\n procedure SetCV(const Value: Extended);\r\n procedure SetCVColor(const Value: TColor);\r\n procedure SetKD(const Value: Extended);\r\n procedure SetKI(const Value: Extended);\r\n procedure SetKP(const Value: Extended);\r\n procedure CalcOut;\r\n procedure SetDirect(const Value: Boolean);\r\n procedure SetManual(const Value: Boolean);\r\n procedure SetSource(const Value: TJvSimPID);\r\n procedure SetActive(const Value: Boolean);\r\n procedure SetSymFunc(const Value: TJvSymFunc);\r\n protected\r\n procedure Paint; override;\r\n procedure Notification(AComponent: TComponent; Operation: TOperation); override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n procedure Execute;\r\n published\r\n property SymFunc: TJvSymFunc read FSymFunc write SetSymFunc;\r\n property Source: TJvSimPID read FSource write SetSource;\r\n property MV: Extended read FMV write SetMV;\r\n property MVColor: TColor read FMVColor write SetMVColor default clRed;\r\n property SP: Extended read FSP write SetSP;\r\n property SPColor: TColor read FSPColor write SetSPColor default clLime;\r\n property CV: Extended read FCV write SetCV;\r\n property CVColor: TColor read FCVColor write SetCVColor default clYellow;\r\n property KP: Extended read FKP write SetKP;\r\n property KI: Extended read FKI write SetKI;\r\n property KD: Extended read FKD write SetKD;\r\n property Direct: Boolean read FDirect write SetDirect default False;\r\n property Manual: Boolean read FManual write SetManual default False;\r\n property Active: Boolean read FActive write SetActive default False;\r\n\r\n property Align;\r\n property Anchors;\r\n property Color default clWhite;\r\n property Height default 100;\r\n property ParentShowHint;\r\n property PopupMenu;\r\n property ShowHint;\r\n property Width default 20;\r\n property Visible;\r\n\r\n property OnCanResize;\r\n property OnClick;\r\n property OnConstrainedResize;\r\n property OnDblClick;\r\n property OnDragDrop;\r\n property OnDragOver;\r\n property OnEndDock;\r\n property OnEndDrag;\r\n property OnMouseDown;\r\n {$IFDEF COMPILER9_UP}\r\n property OnMouseEnter;\r\n property OnMouseLeave;\r\n {$ENDIF COMPILER9_UP}\r\n property OnMouseMove;\r\n property OnMouseUp;\r\n property OnMouseWheel;\r\n property OnMouseWheelDown;\r\n property OnMouseWheelUp;\r\n property OnResize;\r\n property OnStartDock;\r\n property OnStartDrag;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvSimPID.pas $';\r\n Revision: '$Revision: 13104 $';\r\n Date: '$Date: 2011-09-07 08:50:43 +0200 (mer. 07 sept. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n JvJVCLUtils;\r\n\r\n\r\nconstructor TJvSimPID.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n Color := clWhite;\r\n MVColor := clRed;\r\n SPColor := clLime;\r\n CVColor := clYellow;\r\n Direct := False;\r\n Manual := False;\r\n Active := False;\r\n FMV := 50;\r\n FSP := 50;\r\n FCV := 50;\r\n FKP := 0.5;\r\n FKI := 0;\r\n FKD := 0;\r\n Width := 20;\r\n Height := 100;\r\nend;\r\n\r\nprocedure TJvSimPID.SetMV(Value: Extended);\r\nvar\r\n MVOld: Extended;\r\nbegin\r\n MVOld := FMV;\r\n if Value <> FMV then\r\n begin\r\n if Value > 100 then\r\n MV := 100\r\n else\r\n if Value < 0 then\r\n MV := 0\r\n else\r\n FMV := Value;\r\n end;\r\n FI := FI + KI * (FMV - FSP);\r\n if FI > 50 then\r\n FI := 50;\r\n if FI < -50 then\r\n FI := -50;\r\n FD := KD * (FMV - MVOld);\r\n if FD > 50 then\r\n FD := 50;\r\n if FD < -50 then\r\n FD := -50;\r\n CalcOut;\r\nend;\r\n\r\nprocedure TJvSimPID.SetMVColor(Value: TColor);\r\nbegin\r\n if Value <> FMVColor then\r\n begin\r\n FMVColor := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvSimPID.Paint;\r\n\r\n procedure DrawValue(Left, Right: Integer; Value: Extended; AColor: TColor);\r\n var\r\n DrawRect: TRect;\r\n begin\r\n DrawRect.Left := Left;\r\n DrawRect.Right := Right;\r\n DrawRect.Top := DrawRect.Top + Round((100 - Value) *\r\n (DrawRect.Bottom - DrawRect.Top) / 100);\r\n DrawRect.Bottom := DrawRect.Bottom;\r\n Canvas.Brush.Color := AColor;\r\n Canvas.FillRect(DrawRect);\r\n Canvas.Brush.Color := Color;\r\n DrawRect.Bottom := DrawRect.Top;\r\n DrawRect.Top := DrawRect.Top;\r\n Canvas.FillRect(DrawRect);\r\n end;\r\n\r\nvar\r\n bw: Integer;\r\n DrawRect: TRect;\r\nbegin\r\n DrawRect := ClientRect;\r\n Canvas.Pen.Color := clGray;\r\n Canvas.Pen.Width := 1;\r\n Canvas.Rectangle(DrawRect.Left, DrawRect.Top, DrawRect.Right, DrawRect.Bottom);\r\n InflateRect(DrawRect, -1, -1);\r\n\r\n bw := (DrawRect.Right - DrawRect.Left) div 3;\r\n // first draw the Measured Value\r\n DrawValue(DrawRect.Left + bw, DrawRect.Right - bw, SP, SPColor);\r\n // and now the SetPoint\r\n DrawValue(DrawRect.Left, DrawRect.Left + bw, MV, MVColor);\r\n // draw the Corrective Value (CV)\r\n DrawValue(DrawRect.Right - bw, DrawRect.Right, CV, CVColor);\r\nend;\r\n\r\nprocedure TJvSimPID.SetSP(const Value: Extended);\r\nbegin\r\n if Value <> FSP then\r\n begin\r\n if Value > 100 then\r\n FSP := 100\r\n else\r\n if Value < 0 then\r\n FSP := 0\r\n else\r\n FSP := Value;\r\n CalcOut;\r\n end;\r\nend;\r\n\r\nprocedure TJvSimPID.SetSPColor(const Value: TColor);\r\nbegin\r\n if Value <> FSPColor then\r\n begin\r\n FSPColor := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvSimPID.SetCV(const Value: Extended);\r\nbegin\r\n if Value <> FCV then\r\n begin\r\n if Value > 100 then\r\n FCV := 100\r\n else\r\n if Value < 0 then\r\n FCV := 0\r\n else\r\n FCV := Value;\r\n end;\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvSimPID.SetCVColor(const Value: TColor);\r\nbegin\r\n if Value <> FCVColor then\r\n begin\r\n FCVColor := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvSimPID.SetKD(const Value: Extended);\r\nbegin\r\n FKD := Value;\r\nend;\r\n\r\nprocedure TJvSimPID.SetKI(const Value: Extended);\r\nbegin\r\n FKI := Value;\r\n if FKI = 0 then\r\n FI := 0;\r\nend;\r\n\r\nprocedure TJvSimPID.SetKP(const Value: Extended);\r\nbegin\r\n FKP := Value;\r\nend;\r\n\r\nprocedure TJvSimPID.CalcOut;\r\nvar\r\n Output: Extended;\r\nbegin\r\n if not Manual then\r\n begin\r\n if Direct then\r\n Output := 50 + KP * (MV - SP) + FI + FD\r\n else\r\n Output := 50 - (KP * (MV - SP) + FI + FD);\r\n SetCV(Output);\r\n end;\r\nend;\r\n\r\nprocedure TJvSimPID.SetDirect(const Value: Boolean);\r\nbegin\r\n FDirect := Value;\r\nend;\r\n\r\nprocedure TJvSimPID.SetManual(const Value: Boolean);\r\nbegin\r\n FManual := Value;\r\nend;\r\n\r\nprocedure TJvSimPID.SetSource(const Value: TJvSimPID);\r\nbegin\r\n ReplaceComponentReference(Self, Value, TComponent(FSource));\r\nend;\r\n\r\nprocedure TJvSimPID.Execute;\r\nvar\r\n Value: Extended;\r\nbegin\r\n if Active then\r\n if Assigned(FSource) then\r\n begin\r\n Value := Source.CV;\r\n SetMV(Value);\r\n end;\r\nend;\r\n\r\nprocedure TJvSimPID.SetActive(const Value: Boolean);\r\nbegin\r\n FActive := Value;\r\nend;\r\n\r\nprocedure TJvSimPID.SetSymFunc(const Value: TJvSymFunc);\r\nbegin\r\n FSymFunc := Value;\r\nend;\r\n\r\nprocedure TJvSimPID.Notification(AComponent: TComponent;\r\n Operation: TOperation);\r\nbegin\r\n inherited Notification(AComponent, Operation);\r\n if (AComponent = Source) and (Operation = opRemove) then\r\n Source := nil;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend." }, { "path": "External/Jedi/Jvcl/run/JvSimPIDLinker.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvSimPIDlinker.PAS, released on 2002-06-15.\r\n\r\nThe Initial Developer of the Original Code is Jan Verhoeven [jan1 dott verhoeven att wxs dott nl]\r\nPortions created by Jan Verhoeven are Copyright (C) 2002 Jan Verhoeven.\r\nAll Rights Reserved.\r\n\r\nContributor(s): Robert Love [rlove att slcdug dott org].\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvSimPIDLinker.pas 13104 2011-09-07 06:50:43Z obones $\r\n\r\nunit JvSimPIDLinker;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Classes,\r\n JvSimPID;\r\n\r\ntype\r\n TPIDS = array of TJvSimPID;\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvSimPIDLinker = class(TComponent)\r\n private\r\n FPIDS: TPIDS;\r\n function GetPID(const Index: Integer): TJvSimPID;\r\n procedure SetPID(const Index: Integer; const Value: TJvSimPID);\r\n protected\r\n procedure Notification(AComponent: TComponent; Operation: TOperation);\r\n override;\r\n procedure InitPids;\r\n public\r\n procedure Execute;\r\n constructor Create(AOwner: TComponent); override;\r\n published\r\n property In1: TJvSimPID index 0 read GetPID write SetPID;\r\n property Out1: TJvSimPID index 1 read GetPID write SetPID;\r\n property In2: TJvSimPID index 2 read GetPID write SetPID;\r\n property Out2: TJvSimPID index 3 read GetPID write SetPID;\r\n property In3: TJvSimPID index 4 read GetPID write SetPID;\r\n property Out3: TJvSimPID index 5 read GetPID write SetPID;\r\n property In4: TJvSimPID index 6 read GetPID write SetPID;\r\n property Out4: TJvSimPID index 7 read GetPID write SetPID;\r\n property In5: TJvSimPID index 8 read GetPID write SetPID;\r\n property Out5: TJvSimPID index 9 read GetPID write SetPID;\r\n property In6: TJvSimPID index 10 read GetPID write SetPID;\r\n property Out6: TJvSimPID index 11 read GetPID write SetPID;\r\n property In7: TJvSimPID index 12 read GetPID write SetPID;\r\n property Out7: TJvSimPID index 13 read GetPID write SetPID;\r\n property In8: TJvSimPID index 14 read GetPID write SetPID;\r\n property Out8: TJvSimPID index 15 read GetPID write SetPID;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvSimPIDLinker.pas $';\r\n Revision: '$Revision: 13104 $';\r\n Date: '$Date: 2011-09-07 08:50:43 +0200 (mer. 07 sept. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\n\r\nconstructor TJvSimPIDLinker.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n InitPids;\r\nend;\r\n\r\nprocedure TJvSimPIDLinker.Execute;\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := 0 to Length(FPIDS) - 2 do\r\n if (FPIDS[I] <> nil) and (FPIDS[I + 1] <> nil) then\r\n FPIDS[I].MV := FPIDS[I + 1].CV;\r\nend;\r\n\r\nfunction TJvSimPIDLinker.GetPID(const Index: Integer): TJvSimPID;\r\nbegin\r\n Result := FPIDS[Index];\r\nend;\r\n\r\nprocedure TJvSimPIDLinker.InitPids;\r\nconst\r\n cCount = 16;\r\nvar\r\n I: Integer;\r\nbegin\r\n SetLength(FPIDS, cCount);\r\n for I := 0 to cCount - 1 do\r\n FPIDS[I] := nil;\r\nend;\r\n\r\nprocedure TJvSimPIDLinker.Notification(AComponent: TComponent;\r\n Operation: TOperation);\r\nvar\r\n I: Integer;\r\nbegin\r\n inherited Notification(AComponent, Operation);\r\n if Operation = opRemove then\r\n for I := 0 to Length(FPIDS) - 1 do\r\n if FPIDS[I] = AComponent then\r\n FPIDS[I] := nil;\r\nend;\r\n\r\nprocedure TJvSimPIDLinker.SetPID(const Index: Integer;\r\n const Value: TJvSimPID);\r\nbegin\r\n FPIDS[Index] := Value;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvSimScope.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvSimScope.PAS, released on 2002-06-15.\r\n\r\nThe Initial Developer of the Original Code is Jan Verhoeven [jan1 dott verhoeven att wxs dott nl]\r\nPortions created by Jan Verhoeven are Copyright (C) 2002 Jan Verhoeven.\r\nAll Rights Reserved.\r\n\r\nContributor(s): Robert Love [rlove att slcdug dott org].\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nDescription:\r\n TJvSimScope Properties:\r\n Active Starts/Stops scope\r\n Color Backgroundcolor\r\n GridColor Grid mask color\r\n HorizontalGridSize Size of horiontal grid mask in logical units\r\n VerticalGridSize Size of vertical grid mask in logical units\r\n Interval Scroll speed in 1/100's seconds\r\n LineColor Scope dataline color\r\n Position Dataline value\r\n BaseColor Color of BaseLine\r\n BaseLine BaseLine value\r\n\r\n TJvSimScope Methods:\r\n Clear Clears the control and redraws grid\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvSimScope.pas 13104 2011-09-07 06:50:43Z obones $\r\n\r\nunit JvSimScope;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, Messages, SysUtils, Classes,\r\n Graphics, Controls, Forms, ExtCtrls;\r\n\r\nconst\r\n JvScopeDefaultCapacity = 128;\r\n JvMinimumScopeWidth = 20;\r\n JvMinimumScopeHeight = 20;\r\n\r\n\r\ntype\r\n TJvSimScope = class;\r\n\r\n TJvScopeLineUnit = (jluPercent, jluAbsolute);\r\n\r\n TValues = array of Integer;\r\n \r\n TJvScopeLineValues = class\r\n private\r\n FValues: TValues;\r\n FCount: Integer;\r\n FZeroIndex: Integer;\r\n\r\n procedure SetCapacity(const Value: Integer);\r\n function GetCapacity: Integer;\r\n function GetItem(Index: Integer): Integer;\r\n public\r\n procedure Assign(Source: TJvScopeLineValues);\r\n procedure Add(Value: Integer);\r\n procedure Clear;\r\n\r\n property Capacity: Integer read GetCapacity write SetCapacity;\r\n property Count: Integer read FCount;\r\n property Items[Index: Integer]: Integer read GetItem; default;\r\n end;\r\n\r\n TJvScopeLine = class(TCollectionItem)\r\n private\r\n FPosition: Integer;\r\n FColor: TColor;\r\n FName: string;\r\n FPositionUnit: TJvScopeLineUnit;\r\n FValues: TJvScopeLineValues;\r\n protected\r\n function GetDisplayName: string; override;\r\n public\r\n constructor Create(Collection: Classes.TCollection); override;\r\n destructor Destroy; override;\r\n\r\n procedure Assign(Source: TPersistent); override;\r\n procedure Clear;\r\n property Values: TJvScopeLineValues read FValues;\r\n published\r\n property Name: string read FName write FName;\r\n property Color: TColor read FColor write FColor default clLime;\r\n property Position: Integer read FPosition write FPosition default 50;\r\n property PositionUnit: TJvScopeLineUnit read FPositionUnit write FPositionUnit default jluPercent;\r\n end;\r\n\r\n TJvScopeLines = class(TOwnedCollection)\r\n private\r\n function GetItem(Index: Integer): TJvScopeLine;\r\n procedure SetItem(Index: Integer; const Value: TJvScopeLine);\r\n protected\r\n function GetOwner: TJvSimScope; reintroduce;\r\n procedure Notify(Item: TCollectionItem; Action: TCollectionNotification); override;\r\n public\r\n constructor Create(AOwner: TJvSimScope);\r\n procedure Assign(Source: TPersistent); override;\r\n procedure ClearValues;\r\n\r\n function Add: TJvScopeLine;\r\n function IndexOfName(const AName: string): Integer;\r\n property Lines[Index: Integer]: TJvScopeLine read GetItem write SetItem; default;\r\n end;\r\n\r\n TJvSimScopeDisplayUnit = (jduPixels, jduLogical);\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvSimScope = class(TGraphicControl)\r\n private\r\n FAllowed: Boolean;\r\n FOnUpdate: TNotifyEvent;\r\n FDrawBuffer: TBitmap;\r\n FDrawTimer: TTimer;\r\n FActive: Boolean;\r\n FBaseColor: TColor;\r\n FGridColor: TColor;\r\n FBaseLine: Integer;\r\n FInterval: Integer;\r\n FLines: TJvScopeLines;\r\n FHorizontalGridSize: Integer;\r\n FVerticalGridSize: Integer;\r\n FDisplayUnits: TJvSimScopeDisplayUnit;\r\n FMaximum: Integer;\r\n FMinimum: Integer;\r\n FBaseLineUnit: TJvScopeLineUnit;\r\n FTotalTimeSteps: Integer;\r\n FUpdateTimeSteps: Integer;\r\n\r\n procedure SetActive(Value: Boolean);\r\n procedure SetGridSize(Value: Integer);\r\n procedure SetBaseLine(Value: Integer);\r\n procedure SetInterval(Value: Integer);\r\n procedure SetLines(const Value: TJvScopeLines);\r\n procedure UpdateDisplay(ClearFirst: Boolean);\r\n procedure SetHorizontalGridSize(const Value: Integer);\r\n procedure SetVerticalGridSize(const Value: Integer);\r\n function GetGridSize: Integer;\r\n procedure SetDisplayUnits(const Value: TJvSimScopeDisplayUnit);\r\n procedure SetMaximum(const Value: Integer);\r\n procedure SetMinimum(const Value: Integer);\r\n procedure UpdateComputedValues;\r\n procedure SetBaseLineUnit(const Value: TJvScopeLineUnit);\r\n procedure SetTotalTimeSteps(const Value: Integer);\r\n procedure SetUpdateTimeSteps(const Value: Integer);\r\n protected\r\n FCalcBase: Integer;\r\n FStepPixelWidth: Double;\r\n FCounter: Double;\r\n procedure DrawTimerTimer(Sender: TObject);\r\n function GetLinePixelPosition(Line: TJvScopeLine; Position: Integer): Integer;\r\n procedure Loaded; override;\r\n public\r\n procedure Paint; override;\r\n constructor Create(AOwner: TComponent); override;\r\n procedure UpdateScope;\r\n destructor Destroy; override;\r\n procedure Clear;\r\n procedure ClearValues;\r\n procedure SetBounds(ALeft, ATop, AWidth, AHeight: Integer); override;\r\n published\r\n property Active: Boolean read FActive write SetActive;\r\n property BaseColor: TColor read FBaseColor write FBaseColor default clRed;\r\n property BaseLine: Integer read FBaseLine write SetBaseLine default 50;\r\n property BaseLineUnit: TJvScopeLineUnit read FBaseLineUnit write SetBaseLineUnit default jluPercent;\r\n property Color default clBlack;\r\n property DisplayUnits: TJvSimScopeDisplayUnit read FDisplayUnits write SetDisplayUnits default jduPixels;\r\n property GridColor: TColor read FGridColor write FGridColor default clGreen;\r\n property GridSize: Integer read GetGridSize write SetGridSize stored False default 16;\r\n property HorizontalGridSize: Integer read FHorizontalGridSize write SetHorizontalGridSize default 16;\r\n property Height default 120;\r\n property Interval: Integer read FInterval write SetInterval default 50;\r\n property Lines: TJvScopeLines read FLines write SetLines;\r\n property Minimum: Integer read FMinimum write SetMinimum;\r\n property Maximum: Integer read FMaximum write SetMaximum default 120;\r\n property TotalTimeSteps: Integer read FTotalTimeSteps write SetTotalTimeSteps default 208;\r\n property UpdateTimeSteps: Integer read FUpdateTimeSteps write SetUpdateTimeSteps default 2;\r\n property VerticalGridSize: Integer read FVerticalGridSize write SetVerticalGridSize default 16;\r\n property Width default 208;\r\n\r\n property OnUpdate: TNotifyEvent read FOnUpdate write FOnUpdate;\r\n\r\n property Align;\r\n property Anchors;\r\n property ParentShowHint;\r\n property ShowHint;\r\n property Visible;\r\n\r\n property OnCanResize;\r\n property OnClick;\r\n property OnConstrainedResize;\r\n property OnDblClick;\r\n property OnDragDrop;\r\n property OnDragOver;\r\n property OnEndDock;\r\n property OnEndDrag;\r\n property OnMouseDown;\r\n {$IFDEF COMPILER10_UP}\r\n property OnMouseEnter;\r\n property OnMouseLeave;\r\n {$ENDIF COMPILER10_UP}\r\n property OnMouseMove;\r\n property OnMouseUp;\r\n property OnMouseWheel;\r\n property OnMouseWheelDown;\r\n property OnMouseWheelUp;\r\n property OnResize;\r\n property OnStartDock;\r\n property OnStartDrag;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvSimScope.pas $';\r\n Revision: '$Revision: 13104 $';\r\n Date: '$Date: 2011-09-07 08:50:43 +0200 (mer. 07 sept. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n Math;\r\n\r\n//=== { TJvScopeLineValues } =================================================\r\n\r\nprocedure TJvScopeLineValues.Add(Value: Integer);\r\nbegin\r\n Assert(Assigned(Self));\r\n if Length(FValues)=Count then // auto-growby JvScopeDefaultCapacity\r\n SetCapacity( GetCapacity+JvScopeDefaultCapacity);\r\n\r\n if Count < Capacity then\r\n begin\r\n FValues[FCount] := Value;\r\n Inc(FCount);\r\n end\r\n else\r\n begin\r\n FValues[FZeroIndex] := Value;\r\n FZeroIndex := (FZeroIndex + 1) mod FCount;\r\n end;\r\nend;\r\n\r\nprocedure TJvScopeLineValues.Assign(Source: TJvScopeLineValues);\r\nvar\r\n I: Integer;\r\nbegin\r\n if (not Assigned(Source)) then\r\n raise Exception.Create('TJvScopeLineValues.Assign:Source not assigned');\r\n FCount := Source.FCount;\r\n FZeroIndex := Source.FZeroIndex;\r\n Capacity := Source.Capacity;\r\n for I := 0 to Source.Capacity - 1 do\r\n FValues[I] := Source.FValues[I];\r\nend;\r\n\r\nprocedure TJvScopeLineValues.Clear;\r\nbegin\r\n FCount := 0;\r\n FZeroIndex := 0;\r\n\r\n // Always need to have two values in the queue\r\n Add(0);\r\n Add(0);\r\nend;\r\n\r\nfunction TJvScopeLineValues.GetCapacity: Integer;\r\nbegin\r\n if Assigned(FValues) then\r\n Result := Length(FValues)\r\n else\r\n Result := 0;\r\nend;\r\n\r\nfunction TJvScopeLineValues.GetItem(Index: Integer): Integer;\r\nbegin\r\n if FCount = 0 then\r\n Result := FValues[0]\r\n else\r\n Result := FValues[(Index + FZeroIndex) mod FCount];\r\nend;\r\n\r\nprocedure TJvScopeLineValues.SetCapacity(const Value: Integer);\r\nbegin\r\n if Value <> Capacity then\r\n begin\r\n SetLength(FValues, Value);\r\n end;\r\nend;\r\n\r\n//=== { TJvScopeLine } =======================================================\r\n\r\nprocedure TJvScopeLine.Clear;\r\nbegin\r\n FValues.Clear;\r\nend;\r\n\r\nconstructor TJvScopeLine.Create(Collection: Classes.TCollection);\r\nbegin\r\n // MUST be created before, inherited create will call Notify...\r\n FValues := TJvScopeLineValues.Create;\r\n\r\n inherited Create(Collection);\r\n\r\n FPosition := 50;\r\n FColor := clLime;\r\nend;\r\n\r\ndestructor TJvScopeLine.Destroy;\r\nbegin\r\n FValues.Free;\r\n\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvScopeLine.Assign(Source: TPersistent);\r\nbegin\r\n if Source is TJvScopeLine then\r\n begin\r\n Name := TJvScopeLine(Source).Name;\r\n Color := TJvScopeLine(Source).Color;\r\n Position := TJvScopeLine(Source).Position;\r\n FValues.Assign(TJvScopeLine(Source).FValues);\r\n end\r\n else\r\n inherited Assign(Source);\r\nend;\r\n\r\nfunction TJvScopeLine.GetDisplayName: string;\r\nbegin\r\n if Name = '' then\r\n Result := inherited GetDisplayName\r\n else\r\n Result := Name;\r\nend;\r\n\r\n//=== { TJvScopeLines } ======================================================\r\n\r\nprocedure TJvScopeLines.ClearValues;\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := 0 to Count - 1 do\r\n begin\r\n Lines[I].Clear;\r\n end;\r\nend;\r\n\r\nconstructor TJvScopeLines.Create(AOwner: TJvSimScope);\r\nbegin\r\n inherited Create(AOwner, TJvScopeLine);\r\nend;\r\n\r\nfunction TJvScopeLines.Add: TJvScopeLine;\r\nbegin\r\n Result := TJvScopeLine(inherited Add);\r\nend;\r\n\r\nprocedure TJvScopeLines.Assign(Source: TPersistent);\r\nvar\r\n I: Integer;\r\nbegin\r\n if Source is TJvScopeLines then\r\n begin\r\n Clear;\r\n for I := 0 to TJvScopeLines(Source).Count - 1 do\r\n Add.Assign(TJvScopeLines(Source)[I]);\r\n end\r\n else\r\n inherited Assign(Source);\r\nend;\r\n\r\nfunction TJvScopeLines.GetItem(Index: Integer): TJvScopeLine;\r\nbegin\r\n Result := TJvScopeLine(inherited Items[Index]);\r\nend;\r\n\r\nfunction TJvScopeLines.GetOwner: TJvSimScope;\r\nbegin\r\n Result := inherited GetOwner as TJvSimScope;\r\nend;\r\n\r\nfunction TJvScopeLines.IndexOfName(const AName: string): Integer;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := -1;\r\n for I := 0 to Count - 1 do\r\n if AnsiSameStr(Lines[Result].Name, AName) then\r\n begin\r\n Result := I;\r\n Break;\r\n end;\r\nend;\r\n\r\nprocedure TJvScopeLines.Notify(Item: TCollectionItem;\r\n Action: TCollectionNotification);\r\nbegin\r\n inherited Notify(Item, Action);\r\n\r\n if Action = cnAdded then\r\n begin\r\n TJvScopeLine(Item).FValues.Capacity := GetOwner.TotalTimeSteps;\r\n end;\r\nend;\r\n\r\nprocedure TJvScopeLines.SetItem(Index: Integer; const Value: TJvScopeLine);\r\nbegin\r\n inherited Items[Index] := Value;\r\nend;\r\n\r\n//=== { TJvSimScope } ========================================================\r\n\r\nprocedure TJvSimScope.ClearValues;\r\nbegin\r\n FLines.ClearValues;\r\nend;\r\n\r\nconstructor TJvSimScope.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FAllowed := False;\r\n FDrawBuffer := TBitmap.Create;\r\n FDrawBuffer.Canvas.Brush.Style := bsSolid;\r\n FDrawBuffer.Canvas.Pen.Width := 1;\r\n FDrawBuffer.Canvas.Pen.Style := psSolid;\r\n\r\n FDrawTimer := TTimer.Create(Self);\r\n FDrawTimer.Enabled := False;\r\n FDrawTimer.OnTimer := DrawTimerTimer;\r\n FDrawTimer.Interval := 500;\r\n\r\n FDisplayUnits := jduPixels;\r\n FUpdateTimeSteps := 2;\r\n\r\n Height := 120; { property default }\r\n Width := 208; { property default }\r\n\r\n Color := clBlack;\r\n FGridColor := clGreen;\r\n FBaseColor := clRed;\r\n\r\n BaseLine := 50;\r\n GridSize := 16;\r\n\r\n FLines := TJvScopeLines.Create(Self);\r\n Interval := 50;\r\n FCounter := 1;\r\n\r\n ControlStyle := [csFramed, csOpaque];\r\n FAllowed := True;\r\nend;\r\n\r\ndestructor TJvSimScope.Destroy;\r\nbegin\r\n FDrawBuffer.Free;\r\n FLines.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvSimScope.DrawTimerTimer(Sender: TObject);\r\nbegin\r\n UpdateScope;\r\nend;\r\n\r\nfunction TJvSimScope.GetGridSize: Integer;\r\nbegin\r\n Result := -1;\r\n if HorizontalGridSize = VerticalGridSize then\r\n Result := HorizontalGridSize;\r\nend;\r\n\r\nfunction TJvSimScope.GetLinePixelPosition(Line: TJvScopeLine;\r\n Position: Integer): Integer;\r\nbegin\r\n Result := 0;\r\n case Line.PositionUnit of\r\n jluPercent:\r\n Result := Height - Round(Height * Position / 100);\r\n jluAbsolute:\r\n Result := Height - Round(Height * (Position - Minimum) / (Maximum - Minimum));\r\n end;\r\nend;\r\n\r\nprocedure TJvSimScope.Loaded;\r\nbegin\r\n inherited Loaded;\r\n\r\n // To force having enough values in the scope.\r\n ClearValues;\r\n\r\n FAllowed := True;\r\nend;\r\n\r\nprocedure TJvSimScope.Clear;\r\nvar\r\n A: Double;\r\n I: Integer;\r\n J: Integer;\r\n Position: Double;\r\nbegin\r\n if not FAllowed then\r\n Exit;\r\n UpdateComputedValues;\r\n with FDrawBuffer.Canvas do\r\n begin\r\n Brush.Color := Color;\r\n Pen.Style := psClear;\r\n Rectangle(0, 0, Width + 1, Height + 1);\r\n Pen.Style := psSolid;\r\n Pen.Color := GridColor;\r\n Pen.Width := 1;\r\n { Vertical lines }\r\n A := Width;\r\n while A > 0 do\r\n begin\r\n MoveTo(Round(A - 1), 0);\r\n LineTo(Round(A - 1), Height);\r\n A := A - VerticalGridSize * FStepPixelWidth;\r\n end;\r\n { Horizontal lines - below BaseLine }\r\n A := FCalcBase;\r\n while A < Height do\r\n begin\r\n A := A + HorizontalGridSize * Height / (Maximum - Minimum);\r\n MoveTo(0, Round(A));\r\n LineTo(Width, Round(A));\r\n end;\r\n { Horizontal lines - above BaseLine }\r\n A := FCalcBase;\r\n while A > 0 do\r\n begin\r\n A := A - HorizontalGridSize * Height / (Maximum - Minimum);\r\n MoveTo(0, Round(A));\r\n LineTo(Width, Round(A));\r\n end;\r\n { BaseLine }\r\n Pen.Color := BaseColor;\r\n MoveTo(0, FCalcBase);\r\n LineTo(Width, FCalcBase);\r\n\r\n // Redraw old values to keep history of values\r\n for I := 0 to FLines.Count - 1 do\r\n begin\r\n Pen.Color := FLines[I].Color;\r\n\r\n if FLines[I].FValues.Count > 0 then\r\n begin\r\n Position := (TotalTimeSteps - FLines[I].FValues.Count) * FStepPixelWidth;\r\n\r\n MoveTo(Round(Position), GetLinePixelPosition(FLines[I], FLines[I].FValues[0]));\r\n J := UpdateTimeSteps - 1;\r\n while J < FLines[I].FValues.Count - 1 do\r\n begin\r\n Position := Position + UpdateTimeSteps * FStepPixelWidth;\r\n LineTo(Round(Position), GetLinePixelPosition(FLines[I], FLines[I].FValues[J]));\r\n Inc(J, UpdateTimeSteps);\r\n end;\r\n\r\n end\r\n else\r\n begin\r\n FLines[I].FValues.Clear;\r\n end;\r\n end;\r\n\r\n FCounter := 1;\r\n end;\r\nend;\r\n\r\nprocedure TJvSimScope.SetBaseLine(Value: Integer);\r\nbegin\r\n FBaseLine := Value;\r\n UpdateComputedValues;\r\n UpdateDisplay(True);\r\nend;\r\n\r\nprocedure TJvSimScope.SetBaseLineUnit(const Value: TJvScopeLineUnit);\r\nbegin\r\n if FBaseLineUnit <> Value then\r\n begin\r\n FBaseLineUnit := Value;\r\n UpdateDisplay(True);\r\n end;\r\nend;\r\n\r\nprocedure TJvSimScope.SetInterval(Value: Integer);\r\nbegin\r\n if FInterval <> Value then\r\n begin\r\n FDrawTimer.Enabled := False;\r\n UpdateComputedValues;\r\n FDrawTimer.Interval := Value * 10;\r\n FInterval := Value;\r\n FDrawTimer.Enabled := FActive;\r\n end;\r\nend;\r\n\r\nprocedure TJvSimScope.SetGridSize(Value: Integer);\r\nbegin\r\n if ((Value <> FHorizontalGridSize) or (Value <> FVerticalGridSize)) and (Value > 0) then\r\n begin\r\n FHorizontalGridSize := Value;\r\n FVerticalGridSize := Value;\r\n UpdateDisplay(True);\r\n end;\r\nend;\r\n\r\nprocedure TJvSimScope.SetHorizontalGridSize(const Value: Integer);\r\nbegin\r\n if (FHorizontalGridSize <> Value) and (Value > 0) then\r\n begin\r\n FHorizontalGridSize := Value;\r\n UpdateDisplay(True);\r\n end;\r\nend;\r\n\r\nprocedure TJvSimScope.SetActive(Value: Boolean);\r\nbegin\r\n if FActive <> Value then\r\n begin\r\n UpdateComputedValues;\r\n FDrawTimer.Interval := Interval * 10;\r\n FDrawTimer.Enabled := Value;\r\n FActive := Value;\r\n end;\r\nend;\r\n\r\n{ All drawings is performed on in the FDrawBuffer to speed up\r\n proceedings and eliminate flicker. The Paint procedure merely\r\n copies the contents of the FDrawBuffer. }\r\n\r\nprocedure TJvSimScope.UpdateScope;\r\nvar\r\n A: Double;\r\n I: Integer;\r\n Dest, Src: TRect;\r\n UpdateWidth: Integer;\r\n J: Integer;\r\n PosMinusOne: Double;\r\n PosMinusTwo: Double;\r\nbegin\r\n with FDrawBuffer.Canvas do\r\n begin\r\n Pen.Color := FGridColor;\r\n\r\n UpdateWidth := Round(UpdateTimeSteps * FStepPixelWidth);\r\n\r\n Dest.Top := 0;\r\n Dest.Left := 0;\r\n Dest.Right := Round(Width - UpdateWidth);\r\n Dest.Bottom := Height;\r\n\r\n Src.Top := 0;\r\n Src.Left := Round(UpdateTimeSteps * FStepPixelWidth);\r\n Src.Right := Width;\r\n Src.Bottom := Height;\r\n { Copy bitmap leftwards }\r\n CopyRect(Dest, FDrawBuffer.Canvas, Src);\r\n\r\n { Draw new area }\r\n Pen.Color := Color;\r\n Brush.Color := Color;\r\n BRush.Style := bsSolid;\r\n Dest.Top := 0;\r\n Dest.Left := Width - UpdateWidth;\r\n Dest.Right := Width;\r\n Dest.Bottom := Height;\r\n FilLRect(Dest);\r\n(* Pen.Width := UpdateWidth;\r\n MoveTo(Width - Round(UpdateWidth / 2), 0);\r\n LineTo(Width - Round(UpdateWidth / 2), Height); *)\r\n\r\n\r\n Pen.Color := GridColor;\r\n Pen.Width := 1;\r\n { Draw vertical line if needed }\r\n if FCounter >= Round(VerticalGridSize * FStepPixelWidth / UpdateWidth) then\r\n begin\r\n MoveTo(Width - 1, 0);\r\n LineTo(Width - 1, Height);\r\n FCounter := 0;\r\n end;\r\n FCounter := FCounter + 1;\r\n { Horizontal lines - below BaseLine }\r\n A := FCalcBase;\r\n while A < Height do\r\n begin\r\n A := A + HorizontalGridSize * Height / (Maximum - Minimum);\r\n MoveTo(Width - UpdateWidth, Round(A));\r\n LineTo(Width, Round(A));\r\n end;\r\n { Horizontal lines - above BaseLine }\r\n A := FCalcBase;\r\n while A > 0 do\r\n begin\r\n A := A - HorizontalGridSize * Height / (Maximum - Minimum);\r\n MoveTo(Width - UpdateWidth, Round(A));\r\n LineTo(Width, Round(A));\r\n end;\r\n { BaseLine }\r\n Pen.Color := BaseColor;\r\n MoveTo(Width - UpdateWidth, FCalcBase);\r\n LineTo(Width, FCalcBase);\r\n { Draw position for lines}\r\n for I := 0 to FLines.Count - 1 do\r\n begin\r\n Pen.Color := FLines[I].Color;\r\n\r\n A := GetLinePixelPosition(FLines[I], FLines[I].Position);\r\n PosMinusOne := GetLinePixelPosition(FLines[I], FLines[I].FValues[FLines[I].FValues.Count - 1 * UpdateTimeSteps]);\r\n PosMinusTwo := GetLinePixelPosition(FLines[I], FLines[I].FValues[FLines[I].FValues.Count - 2 * UpdateTimeSteps]);\r\n\r\n MoveTo(Width - UpdateWidth * 2, Round(PosMinusTwo));\r\n LineTo(Width - UpdateWidth, Round(PosMinusOne));\r\n LineTo(Width - 0, Round(A));\r\n for J := 0 to UpdateTimeSteps - 1 do\r\n FLines[I].FValues.Add(FLines[I].Position);\r\n end;\r\n end;\r\n Repaint;\r\n if Assigned(FOnUpdate) then\r\n FOnUpdate(Self);\r\nend;\r\n\r\n{ Called by timer to show updates }\r\n\r\nprocedure TJvSimScope.Paint;\r\nvar\r\n Rect: TRect;\r\nbegin\r\n // inherited Paint;\r\n FDrawBuffer.Height := Height;\r\n FDrawBuffer.Width := Width;\r\n Rect.Top := 0;\r\n Rect.Left := 0;\r\n Rect.Right := Width;\r\n Rect.Bottom := Height;\r\n Canvas.CopyRect(Rect, FDrawBuffer.Canvas, Rect);\r\n FAllowed := True;\r\nend;\r\n\r\n{ Recalulate control after move and/or resize }\r\n\r\nprocedure TJvSimScope.SetBounds(ALeft, ATop, AWidth, AHeight: Integer);\r\nbegin\r\n { BUGFIX/Workaround:JAN 2009 - ACCESS VIOLATIONS AND ODD BEHAVIOUR - SIZE/WIDTH BEING ZAPPED TO ZERO.}\r\n if AWidth < JvMinimumScopeWidth then\r\n AWidth := JvMinimumScopeWidth;\r\n if AHeight < JvMinimumScopeHeight then\r\n AHeight := JvMinimumScopeHeight;\r\n\r\n\r\n inherited SetBounds(ALeft, ATop, AWidth, AHeight);\r\n FDrawBuffer.Height := Height;\r\n FDrawBuffer.Width := Width;\r\n if DisplayUnits = jduPixels then\r\n begin\r\n FMinimum := 0;\r\n FMaximum := AHeight;\r\n FTotalTimeSteps := AWidth;\r\n end;\r\n Clear;\r\nend;\r\n\r\nprocedure TJvSimScope.UpdateComputedValues;\r\nbegin\r\n case FBaseLineUnit of\r\n jluPercent:\r\n FCalcBase := Height - Round(Height * FBaseLine / 100);\r\n jluAbsolute:\r\n FCalcBase := Height - Round(Height * (FBaseLine - Minimum) / (Maximum - Minimum));\r\n end;\r\n FStepPixelWidth := Width / TotalTimeSteps;\r\n if FUpdateTimeSteps * FStepPixelWidth < 2 then\r\n UpdateTimeSteps := 2;\r\nend;\r\n\r\nprocedure TJvSimScope.SetDisplayUnits(const Value: TJvSimScopeDisplayUnit);\r\nbegin\r\n if FDisplayUnits <> Value then\r\n begin\r\n FDisplayUnits := Value;\r\n if FDisplayUnits = jduPixels then\r\n begin\r\n FMinimum := 0;\r\n FMaximum := Height;\r\n end;\r\n UpdateDisplay(True);\r\n end;\r\nend;\r\n\r\nprocedure TJvSimScope.SetLines(const Value: TJvScopeLines);\r\nbegin\r\n FLines.Assign(Value);\r\n Clear;\r\nend;\r\n\r\nprocedure TJvSimScope.SetMaximum(const Value: Integer);\r\nbegin\r\n if (FDisplayUnits <> jduPixels) and (FMaximum <> Value) then\r\n begin\r\n FMaximum := Value;\r\n UpdateDisplay(True);\r\n end;\r\nend;\r\n\r\nprocedure TJvSimScope.SetMinimum(const Value: Integer);\r\nbegin\r\n if (FDisplayUnits <> jduPixels) and (FMinimum <> Value) then\r\n begin\r\n FMinimum := Value;\r\n UpdateDisplay(True);\r\n end;\r\nend;\r\n\r\nprocedure TJvSimScope.SetTotalTimeSteps(const Value: Integer);\r\nbegin\r\n if (FDisplayUnits <> jduPixels) and (FTotalTimeSteps <> Value) then\r\n begin\r\n FTotalTimeSteps := Value;\r\n UpdateDisplay(True);\r\n end;\r\nend;\r\n\r\nprocedure TJvSimScope.SetUpdateTimeSteps(const Value: Integer);\r\nbegin\r\n if (FUpdateTimeSteps <> Value) and (FUpdateTimeSteps > 0) then\r\n begin\r\n FUpdateTimeSteps := Value;\r\n end;\r\nend;\r\n\r\nprocedure TJvSimScope.SetVerticalGridSize(const Value: Integer);\r\nbegin\r\n if (FVerticalGridSize <> Value) and (Value > 0) then\r\n begin\r\n FVerticalGridSize := Value;\r\n UpdateDisplay(True);\r\n end;\r\nend;\r\n\r\nprocedure TJvSimScope.UpdateDisplay(ClearFirst: Boolean);\r\nbegin\r\n if Parent <> nil then\r\n begin\r\n if ClearFirst then\r\n Clear;\r\n Repaint;\r\n end;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvSimpleXml.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvSimpleXML.PAS, released on 2002-06-03\r\n\r\nThe Initial Developer of the Original Code is Sbastien Buysse [sbuysse att buypin dott com]\r\nPortions created by Sbastien Buysse are Copyright (C) 2001 Sbastien Buysse.\r\nAll Rights Reserved.\r\n\r\nContributor(s): Christophe Paris.\r\n Florent Ouchet (move from the JVCL to the JCL).\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues: This component does not parse the !DOCTYPE tags but preserves them\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvSimpleXml.pas 13104 2011-09-07 06:50:43Z obones $\r\n\r\nunit JvSimpleXml;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF MSWINDOWS}\r\n Windows, // Delphi 2005 inline\r\n {$ENDIF MSWINDOWS}\r\n SysUtils, Classes, Variants,\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n JclSimpleXml, JclStreams;\r\n\r\ntype\r\n TJvOnSimpleXMLParsed = TJclOnSimpleXMLParsed;\r\n TJvOnValueParsed = TJclOnValueParsed;\r\n TJvOnSimpleProgress = TJclOnSimpleProgress;\r\n\r\n TJvSimpleXMLElem = TJclSimpleXMLElem;\r\n TJvSimpleXMLElemCData = TJclSimpleXMLElemCData;\r\n TJvSimpleXMLElemClass = TJclSimpleXMLElemClass;\r\n TJvSimpleXMLElemClassic = TJclSimpleXMLElemClassic;\r\n TJvSimpleXMLElemComment = TJclSimpleXMLElemComment;\r\n TJvSimpleXMLElemCompare = TJclSimpleXMLElemCompare;\r\n TJvSimpleXMLElemDocType = TJclSimpleXMLElemDocType;\r\n TJvSimpleXMLElemHeader = TJclSimpleXMLElemHeader;\r\n TJvSimpleXMLElemText = TJclSimpleXMLElemText;\r\n TJvSimpleXMLElems = TJclSimpleXMLElems;\r\n TJvSimpleXMLElemSheet = TJclSimpleXMLElemSheet;\r\n TJvSimpleXMLElemsProlog = TJclSimpleXMLElemsProlog;\r\n EJvSimpleXMLError = EJclSimpleXMLError;\r\n TJvSimpleXMLProp = TJclSimpleXMLProp;\r\n TJvSimpleXMLProps = TJclSimpleXMLProps;\r\n\r\n //Those hash stuffs are for future use only\r\n //Plans are to replace current hash by this mechanism\r\n TJvHashKind = TJclHashKind;\r\n\r\n TJvHashElem = TJclHashElem;\r\n PJvHashElem = PJclHashElem;\r\n TJvHashRecord = TJclHashRecord;\r\n PJvHashRecord = PJclHashRecord;\r\n TJvHashList = TJclHashList;\r\n PJvHashList = PJclHashList;\r\n\r\n TJvSimpleXMLOptions = TJclSimpleXMLOptions;\r\n\r\nconst\r\n sxoAutoCreate = JclSimpleXml.sxoAutoCreate;\r\n sxoAutoIndent = JclSimpleXml.sxoAutoIndent;\r\n sxoAutoEncodeValue = JclSimpleXml.sxoAutoEncodeValue;\r\n sxoAutoEncodeEntity = JclSimpleXml.sxoAutoEncodeEntity;\r\n sxoDoNotSaveProlog = JclSimpleXml.sxoDoNotSaveProlog;\r\n sxoTrimPrecedingTextWhitespace = JclSimpleXml.sxoTrimPrecedingTextWhitespace;\r\n\r\ntype\r\n TJvSimpleXMLEncodeEvent = TJclSimpleXMLEncodeEvent;\r\n TJvSimpleXMLEncodeStreamEvent = TJclSimpleXMLEncodeStreamEvent;\r\n\r\n // to have access to the protected methods\r\n TJclHackSimpleXML = class(TJclSimpleXML)\r\n end;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64 or pidOSX32)]\r\n {$ENDIF RTL230_UP}\r\n TJvSimpleXML = class(TComponent)\r\n private\r\n FJclSimpleXML: TJclHackSimpleXML;\r\n function GetFileName: TFileName;\r\n function GetIndentString: string;\r\n function GetOnDecodeStream: TJvSimpleXMLEncodeStreamEvent;\r\n function GetOnDecodeValue: TJvSimpleXMLEncodeEvent;\r\n function GetOnEncodeStream: TJvSimpleXMLEncodeStreamEvent;\r\n function GetOnEncodeValue: TJvSimpleXMLEncodeEvent;\r\n function GetOnLoadProgress: TJvOnSimpleProgress;\r\n function GetOnSaveProgress: TJvOnSimpleProgress;\r\n function GetOnTagParsed: TJvOnSimpleXMLParsed;\r\n function GetOnValueParsed: TJvOnValueParsed;\r\n function GetOptions: TJvSimpleXMLOptions;\r\n function GetProlog: TJvSimpleXMLElemsProlog;\r\n function GetRoot: TJvSimpleXMLElemClassic;\r\n procedure SetOnDecodeStream(const Value: TJvSimpleXMLEncodeStreamEvent);\r\n procedure SetOnDecodeValue(const Value: TJvSimpleXMLEncodeEvent);\r\n procedure SetOnEncodeStream(const Value: TJvSimpleXMLEncodeStreamEvent);\r\n procedure SetOnEncodeValue(const Value: TJvSimpleXMLEncodeEvent);\r\n procedure SetOnLoadProgress(const Value: TJvOnSimpleProgress);\r\n procedure SetOnSaveProgress(const Value: TJvOnSimpleProgress);\r\n procedure SetOnTagParsed(const Value: TJvOnSimpleXMLParsed);\r\n procedure SetOnValueParsed(const Value: TJvOnValueParsed);\r\n procedure SetOptions(const Value: TJvSimpleXMLOptions);\r\n procedure SetProlog(const Value: TJvSimpleXMLElemsProlog);\r\n protected\r\n procedure SetIndentString(const Value: string);\r\n procedure SetRoot(const Value: TJclSimpleXMLElemClassic);\r\n procedure SetFileName(Value: TFileName);\r\n procedure DoLoadProgress(const APosition, ATotal: Integer);\r\n procedure DoSaveProgress;\r\n procedure DoTagParsed(const AName: string);\r\n procedure DoValueParsed(const AName, AValue: string);\r\n procedure DoEncodeValue(var Value: string); virtual;\r\n procedure DoDecodeValue(var Value: string); virtual;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n procedure LoadFromString(const Value: string);\r\n procedure LoadFromFile(const FileName: TFileName; Encoding: TJclStringEncoding = seAuto; CodePage: Word = CP_ACP);\r\n procedure LoadFromStream(Stream: TStream; Encoding: TJclStringEncoding = seAuto; CodePage: Word = CP_ACP);\r\n procedure LoadFromResourceName(Instance: THandle; const ResName: string);\r\n procedure SaveToFile(FileName: TFileName; Encoding: TJclStringEncoding = seAuto; CodePage: Word = CP_ACP);\r\n procedure SaveToStream(Stream: TStream; Encoding: TJclStringEncoding = seAuto; CodePage: Word = CP_ACP);\r\n function SaveToString: string;\r\n property Prolog: TJvSimpleXMLElemsProlog read GetProlog write SetProlog;\r\n property Root: TJvSimpleXMLElemClassic read GetRoot write SetRoot;\r\n property XMLData: string read SaveToString write LoadFromString;\r\n published\r\n property FileName: TFileName read GetFileName write SetFileName;\r\n property IndentString: string read GetIndentString write SetIndentString;\r\n property Options: TJvSimpleXMLOptions read GetOptions write SetOptions default [sxoAutoIndent, sxoAutoEncodeValue, sxoAutoEncodeEntity];\r\n property OnSaveProgress: TJvOnSimpleProgress read GetOnSaveProgress write SetOnSaveProgress;\r\n property OnLoadProgress: TJvOnSimpleProgress read GetOnLoadProgress write SetOnLoadProgress;\r\n property OnTagParsed: TJvOnSimpleXMLParsed read GetOnTagParsed write SetOnTagParsed;\r\n property OnValueParsed: TJvOnValueParsed read GetOnValueParsed write SetOnValueParsed;\r\n property OnEncodeValue: TJvSimpleXMLEncodeEvent read GetOnEncodeValue write SetOnEncodeValue;\r\n property OnDecodeValue: TJvSimpleXMLEncodeEvent read GetOnDecodeValue write SetOnDecodeValue;\r\n property OnEncodeStream: TJvSimpleXMLEncodeStreamEvent read GetOnEncodeStream write SetOnEncodeStream;\r\n property OnDecodeStream: TJvSimpleXMLEncodeStreamEvent read GetOnDecodeStream write SetOnDecodeStream;\r\n end;\r\n\r\ntype\r\n TXMLVariant = JclSimpleXml.TXMLVariant {$IFDEF COMPILER8_UP} deprecated {$IFDEF SUPPORTS_DEPRECATED_DETAILS} 'Use JclSimpleXml.TXMLVariant' {$ENDIF} {$ENDIF COMPILER8_UP};\r\n\r\nprocedure XMLCreateInto(var ADest: Variant; const AXML: TJvSimpleXMLElem); deprecated {$IFDEF SUPPORTS_DEPRECATED_DETAILS} 'Use JclSimpleXml.XMLCreateInto' {$ENDIF};\r\nfunction XMLCreate(const AXML: TJvSimpleXMLElem): Variant; overload; deprecated {$IFDEF SUPPORTS_DEPRECATED_DETAILS} 'Use JclSimpleXml.XMLCreate' {$ENDIF};\r\nfunction XMLCreate: Variant; overload; deprecated {$IFDEF SUPPORTS_DEPRECATED_DETAILS} 'Use JclSimpleXml.XMLCreate' {$ENDIF};\r\n\r\nfunction VarXML: TVarType; deprecated {$IFDEF SUPPORTS_DEPRECATED_DETAILS} 'Use JclSimpleXml.VarXML' {$ENDIF};\r\n\r\n// Encodes a string into an internal format:\r\n// any character <= #127 is preserved\r\n// all other characters are converted to hex notation except\r\n// for some special characters that are converted to XML entities\r\nfunction SimpleXMLEncode(const S: string): string; {$IFDEF SUPPORTS_DEPRECATED} deprecated {$IFDEF SUPPORTS_DEPRECATED_DETAILS} 'Use JclSimpleXml.SimpleXMLEncode' {$ENDIF} ; {$ENDIF}\r\n// Decodes a string encoded with SimpleXMLEncode:\r\n// any character <= #127 is preserved\r\n// all other characters and substrings are converted from\r\n// the special XML entities to characters or from hex to characters\r\n// NB! Setting TrimBlanks to true will slow down the process considerably\r\nprocedure SimpleXMLDecode(var S: string; TrimBlanks: Boolean); {$IFDEF SUPPORTS_DEPRECATED} deprecated {$IFDEF SUPPORTS_DEPRECATED_DETAILS} 'Use JclSimpleXml.SimpleXMLDecode' {$ENDIF} ; {$ENDIF}\r\n\r\nfunction XMLEncode(const S: string): string; {$IFDEF SUPPORTS_DEPRECATED} deprecated {$IFDEF SUPPORTS_DEPRECATED_DETAILS} 'Use JclSimpleXml.XMLEncode' {$ENDIF} ; {$ENDIF}\r\nfunction XMLDecode(const S: string): string; {$IFDEF SUPPORTS_DEPRECATED} deprecated {$IFDEF SUPPORTS_DEPRECATED_DETAILS} 'Use JclSimpleXml.XMLDecode' {$ENDIF} ; {$ENDIF}\r\n\r\n// Encodes special characters (', \", <, > and &) into XML entities (@apos;, ", <, > and &)\r\nfunction EntityEncode(const S: string): string; {$IFDEF SUPPORTS_DEPRECATED} deprecated {$IFDEF SUPPORTS_DEPRECATED_DETAILS} 'Use JclSimpleXml.EntityEncode' {$ENDIF} ; {$ENDIF}\r\n// Decodes XML entities (@apos;, ", <, > and &) into special characters (', \", <, > and &)\r\nfunction EntityDecode(const S: string): string; {$IFDEF SUPPORTS_DEPRECATED} deprecated {$IFDEF SUPPORTS_DEPRECATED_DETAILS} 'Use JclSimpleXml.EntityDecode' {$ENDIF} ; {$ENDIF}\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvSimpleXml.pas $';\r\n Revision: '$Revision: 13104 $';\r\n Date: '$Date: 2011-09-07 08:50:43 +0200 (mer. 07 sept. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nfunction EntityEncode(const S: string): string;\r\nbegin\r\n Result := JclSimpleXml.EntityEncode(S);\r\nend;\r\n\r\nfunction EntityDecode(const S: string): string;\r\nbegin\r\n Result := JclSimpleXml.EntityDecode(S);\r\nend;\r\n\r\nfunction SimpleXMLEncode(const S: string): string;\r\nbegin\r\n Result := JclSimpleXml.SimpleXMLEncode(S);\r\nend;\r\n\r\nprocedure SimpleXMLDecode(var S: string; TrimBlanks: Boolean);\r\nbegin\r\n JclSimpleXml.SimpleXMLDecode(S, TrimBlanks);\r\nend;\r\n\r\nfunction XMLEncode(const S: string): string;\r\nbegin\r\n Result := JclSimpleXml.SimpleXMLEncode(S);\r\nend;\r\n\r\nfunction XMLDecode(const S: string): string;\r\nbegin\r\n Result := S;\r\n JclSimpleXml.SimpleXMLDecode(Result, False);\r\nend;\r\n\r\nfunction VarXML: TVarType;\r\nbegin\r\n Result := JclSimpleXml.VarXML;\r\nend;\r\n\r\nprocedure XMLCreateInto(var ADest: Variant; const AXML: TJvSimpleXMLElem);\r\nbegin\r\n JclSimpleXml.XMLCreateInto(ADest, AXML);\r\nend;\r\n\r\nfunction XMLCreate(const AXML: TJvSimpleXMLElem): Variant;\r\nbegin\r\n Result := JclSimpleXml.XMLCreate(AXML);\r\nend;\r\n\r\nfunction XMLCreate: Variant;\r\nbegin\r\n Result := JclSimpleXml.XMLCreate;\r\nend;\r\n\r\n//=== { TJvSimpleXML } =======================================================\r\n\r\nconstructor TJvSimpleXML.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FJclSimpleXML := TJclHackSimpleXML.Create;\r\nend;\r\n\r\ndestructor TJvSimpleXML.Destroy;\r\nbegin\r\n FJclSimpleXML.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvSimpleXML.DoDecodeValue(var Value: string);\r\nbegin\r\n FJclSimpleXML.DoDecodeValue(Value);\r\nend;\r\n\r\nprocedure TJvSimpleXML.DoEncodeValue(var Value: string);\r\nbegin\r\n FJclSimpleXML.DoEncodeValue(Value);\r\nend;\r\n\r\nprocedure TJvSimpleXML.DoLoadProgress(const APosition, ATotal: Integer);\r\nbegin\r\n FJclSimpleXML.DoLoadProgress(APosition, ATotal);\r\nend;\r\n\r\nprocedure TJvSimpleXML.DoSaveProgress;\r\nbegin\r\n FJclSimpleXML.DoSaveProgress;\r\nend;\r\n\r\nprocedure TJvSimpleXML.DoTagParsed(const AName: string);\r\nbegin\r\n FJclSimpleXML.DoTagParsed(AName);\r\nend;\r\n\r\nprocedure TJvSimpleXML.DoValueParsed(const AName, AValue: string);\r\nbegin\r\n FJclSimpleXML.DoValueParsed(AName, AValue);\r\nend;\r\n\r\nfunction TJvSimpleXML.GetFileName: TFileName;\r\nbegin\r\n Result := FJclSimpleXML.FileName;\r\nend;\r\n\r\nfunction TJvSimpleXML.GetIndentString: string;\r\nbegin\r\n Result := FJclSimpleXML.IndentString;\r\nend;\r\n\r\nfunction TJvSimpleXML.GetOnDecodeStream: TJvSimpleXMLEncodeStreamEvent;\r\nbegin\r\n Result := FJclSimpleXML.OnDecodeStream;\r\nend;\r\n\r\nfunction TJvSimpleXML.GetOnDecodeValue: TJvSimpleXMLEncodeEvent;\r\nbegin\r\n Result := FJclSimpleXML.OnDecodeValue;\r\nend;\r\n\r\nfunction TJvSimpleXML.GetOnEncodeStream: TJvSimpleXMLEncodeStreamEvent;\r\nbegin\r\n Result := FJclSimpleXML.OnDecodeStream;\r\nend;\r\n\r\nfunction TJvSimpleXML.GetOnEncodeValue: TJvSimpleXMLEncodeEvent;\r\nbegin\r\n Result := FJclSimpleXML.OnEncodeValue;\r\nend;\r\n\r\nfunction TJvSimpleXML.GetOnLoadProgress: TJvOnSimpleProgress;\r\nbegin\r\n Result := FJclSimpleXML.OnLoadProgress;\r\nend;\r\n\r\nfunction TJvSimpleXML.GetOnSaveProgress: TJvOnSimpleProgress;\r\nbegin\r\n Result := FJclSimpleXML.OnSaveProgress;\r\nend;\r\n\r\nfunction TJvSimpleXML.GetOnTagParsed: TJvOnSimpleXMLParsed;\r\nbegin\r\n Result := FJclSimpleXML.OnTagParsed;\r\nend;\r\n\r\nfunction TJvSimpleXML.GetOnValueParsed: TJvOnValueParsed;\r\nbegin\r\n Result := FJclSimpleXML.OnValueParsed;\r\nend;\r\n\r\nfunction TJvSimpleXML.GetOptions: TJvSimpleXMLOptions;\r\nbegin\r\n Result := FJclSimpleXML.Options;\r\nend;\r\n\r\nfunction TJvSimpleXML.GetProlog: TJvSimpleXMLElemsProlog;\r\nbegin\r\n Result := FJclSimpleXML.Prolog;\r\nend;\r\n\r\nfunction TJvSimpleXML.GetRoot: TJvSimpleXMLElemClassic;\r\nbegin\r\n Result := FJclSimpleXML.Root;\r\nend;\r\n\r\nprocedure TJvSimpleXML.LoadFromFile(const FileName: TFileName; Encoding: TJclStringEncoding = seAuto; CodePage: Word =\r\n CP_ACP);\r\nbegin\r\n FJclSimpleXML.LoadFromFile(FileName, Encoding, CodePage);\r\nend;\r\n\r\nprocedure TJvSimpleXML.LoadFromResourceName(Instance: THandle;\r\n const ResName: string);\r\nbegin\r\n FJclSimpleXML.LoadFromResourceName(Instance, ResName);\r\nend;\r\n\r\nprocedure TJvSimpleXML.LoadFromStream(Stream: TStream; Encoding: TJclStringEncoding = seAuto; CodePage: Word = CP_ACP);\r\nbegin\r\n FJclSimpleXML.LoadFromStream(Stream, Encoding, CodePage);\r\nend;\r\n\r\nprocedure TJvSimpleXML.LoadFromString(const Value: string);\r\nbegin\r\n FJclSimpleXML.LoadFromString(Value);\r\nend;\r\n\r\nprocedure TJvSimpleXML.SaveToFile(FileName: TFileName; Encoding: TJclStringEncoding; CodePage: Word);\r\nbegin\r\n FJclSimpleXML.SaveToFile(FileName, Encoding, CodePage);\r\nend;\r\n\r\nprocedure TJvSimpleXML.SaveToStream(Stream: TStream; Encoding: TJclStringEncoding; CodePage: Word);\r\nbegin\r\n FJclSimpleXML.SaveToStream(Stream, Encoding, CodePage);\r\nend;\r\n\r\nfunction TJvSimpleXML.SaveToString: string;\r\nbegin\r\n Result := FJclSimpleXML.SaveToString;\r\nend;\r\n\r\nprocedure TJvSimpleXML.SetFileName(Value: TFileName);\r\nbegin\r\n FJclSimpleXML.FileName := Value;\r\nend;\r\n\r\nprocedure TJvSimpleXML.SetIndentString(const Value: string);\r\nbegin\r\n FJclSimpleXML.IndentString := Value;\r\nend;\r\n\r\nprocedure TJvSimpleXML.SetOnDecodeStream(\r\n const Value: TJvSimpleXMLEncodeStreamEvent);\r\nbegin\r\n FJclSimpleXML.OnDecodeStream := Value;\r\nend;\r\n\r\nprocedure TJvSimpleXML.SetOnDecodeValue(const Value: TJvSimpleXMLEncodeEvent);\r\nbegin\r\n FJclSimpleXML.OnDecodeValue := Value;\r\nend;\r\n\r\nprocedure TJvSimpleXML.SetOnEncodeStream(\r\n const Value: TJvSimpleXMLEncodeStreamEvent);\r\nbegin\r\n FJclSimpleXML.OnEncodeStream := Value;\r\nend;\r\n\r\nprocedure TJvSimpleXML.SetOnEncodeValue(const Value: TJvSimpleXMLEncodeEvent);\r\nbegin\r\n FJclSimpleXML.OnEncodeValue := Value;\r\nend;\r\n\r\nprocedure TJvSimpleXML.SetOnLoadProgress(const Value: TJvOnSimpleProgress);\r\nbegin\r\n FJclSimpleXML.OnLoadProgress := Value;\r\nend;\r\n\r\nprocedure TJvSimpleXML.SetOnSaveProgress(const Value: TJvOnSimpleProgress);\r\nbegin\r\n FJclSimpleXML.OnSaveProgress := Value;\r\nend;\r\n\r\nprocedure TJvSimpleXML.SetOnTagParsed(const Value: TJvOnSimpleXMLParsed);\r\nbegin\r\n FJclSimpleXML.OnTagParsed := Value;\r\nend;\r\n\r\nprocedure TJvSimpleXML.SetOnValueParsed(const Value: TJvOnValueParsed);\r\nbegin\r\n FJclSimpleXML.OnValueParsed := Value;\r\nend;\r\n\r\nprocedure TJvSimpleXML.SetOptions(const Value: TJvSimpleXMLOptions);\r\nbegin\r\n FJclSimpleXML.Options := Value;\r\nend;\r\n\r\nprocedure TJvSimpleXML.SetProlog(const Value: TJvSimpleXMLElemsProlog);\r\nbegin\r\n FJclSimpleXML.Prolog := Value;\r\nend;\r\n\r\nprocedure TJvSimpleXML.SetRoot(const Value: TJclSimpleXMLElemClassic);\r\nbegin\r\n FJclSimpleXML.Root := Value;\r\nend;\r\n\r\ninitialization\r\n {$IFDEF UNITVERSIONING}\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n {$ENDIF UNITVERSIONING}\r\n\r\nfinalization\r\n {$IFDEF UNITVERSIONING}\r\n UnregisterUnitVersion(HInstance);\r\n {$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvSlider.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvSlider.PAS, released on 2001-02-28.\r\n\r\nThe Initial Developer of the Original Code is Sbastien Buysse [sbuysse att buypin dott com]\r\nPortions created by Sbastien Buysse are Copyright (C) 2001 Sbastien Buysse.\r\nAll Rights Reserved.\r\n\r\nContributor(s): Michael Beck [mbeck att bigfoot dott com].\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvSlider.pas 13104 2011-09-07 06:50:43Z obones $\r\n\r\nunit JvSlider;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n SysUtils, Classes, Windows, Messages, Graphics, Controls, ExtCtrls,\r\n JvComponent;\r\n\r\ntype\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvSlider = class(TJvCustomControl)\r\n private\r\n FImageRuler: TBitmap;\r\n FImageThumb: TBitmap;\r\n FThumb1: TBitmap;\r\n FThumb2: TBitmap;\r\n FHorizontal: Boolean;\r\n FClicked: Boolean;\r\n FTracking: Boolean;\r\n FMaximum: Integer;\r\n FDifference: Real;\r\n FPosition: Integer;\r\n FFrom: Integer;\r\n FChanged: Boolean;\r\n FChanging: Boolean;\r\n FOnChanged: TNotifyEvent;\r\n FOnStopChanged: TNotifyEvent;\r\n FOnBeginChange: TNotifyEvent;\r\n FTimer: TTimer;\r\n procedure SetImageThumb(Value: TBitmap);\r\n procedure SetImageRuler(Value: TBitmap);\r\n procedure ThumbChanged(Sender: TObject);\r\n procedure SetMaximum(Value: Integer);\r\n procedure Calculate;\r\n procedure ReCalcule(Sender: TObject);\r\n procedure SetPosition(Value: Integer);\r\n procedure Loading(Sender: TObject);\r\n protected\r\n procedure WMEraseBkgnd(var Msg: TWMEraseBkgnd); message WM_ERASEBKGND;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n\r\n procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;\r\n procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;\r\n procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;\r\n procedure Paint; override;\r\n function CanAutoSize(var NewWidth, NewHeight: Integer): Boolean; override;\r\n published\r\n property ImageRuler: TBitmap read FImageRuler write SetImageRuler;\r\n property ImageThumb: TBitmap read FImageThumb write SetImageThumb;\r\n property Align;\r\n property Anchors;\r\n property Constraints;\r\n\r\n property Visible;\r\n property Enabled;\r\n property Cursor;\r\n property DragMode;\r\n property DragCursor;\r\n property ParentShowHint;\r\n property ShowHint;\r\n property TabOrder;\r\n property Width default 191;\r\n property Height default 11;\r\n property AutoSize default True;\r\n property Horizontal: Boolean read FHorizontal write FHorizontal default True;\r\n property Maximum: Integer read FMaximum write SetMaximum default 100;\r\n property Position: Integer read FPosition write SetPosition default 0;\r\n property OnClick;\r\n property OnDblClick;\r\n property OnEnter;\r\n property OnExit;\r\n property OnKeyDown;\r\n property OnKeyUp;\r\n property OnKeyPress;\r\n property OnDragOver;\r\n property OnDragDrop;\r\n property OnEndDrag;\r\n property OnStartDrag;\r\n property OnBeginChange: TNotifyEvent read FOnBeginChange write FOnBeginChange;\r\n property OnChanged: TNotifyEvent read FOnChanged write FOnChanged;\r\n property OnStopChanged: TNotifyEvent read FOnStopChanged write FOnStopChanged;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvSlider.pas $';\r\n Revision: '$Revision: 13104 $';\r\n Date: '$Date: 2011-09-07 08:50:43 +0200 (mer. 07 sept. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\n\r\n{$R JvSlider.res}\r\n\r\nconstructor TJvSlider.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n ControlStyle := ControlStyle + [csOpaque];\r\n Width := 191;\r\n Height := 11;\r\n FImageRuler := TBitmap.Create;\r\n FImageThumb := TBitmap.Create;\r\n FThumb1 := TBitmap.Create;\r\n FThumb2 := TBitmap.Create;\r\n FClicked := False;\r\n FMaximum := 100;\r\n FTracking := False;\r\n FPosition := 0;\r\n FFrom := 0;\r\n FChanged := False;\r\n FHorizontal := True;\r\n FChanging := False;\r\n FImageThumb.LoadFromResourceName(HInstance, 'JvSliderTHUMB');\r\n FImageRuler.LoadFromResourceName(HInstance, 'JvSliderRULER');\r\n Calculate;\r\n FImageThumb.OnChange := ThumbChanged;\r\n Self.OnResize := ReCalcule;\r\n Calculate;\r\n FTimer := TTimer.Create(Self);\r\n FTimer.Interval := 10;\r\n FTimer.OnTimer := Loading;\r\n FTimer.Enabled := True;\r\n AutoSize := True;\r\nend;\r\n\r\ndestructor TJvSlider.Destroy;\r\nbegin\r\n FImageRuler.Free;\r\n FImageThumb.Free;\r\n FThumb1.Free;\r\n FThumb2.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvSlider.Paint;\r\nvar\r\n T: TRect;\r\nbegin\r\n T.Left := 0;\r\n T.Top := 0;\r\n T.Right := Width;\r\n T.Bottom := Height;\r\n Canvas.StretchDraw(T, FImageRuler);\r\n if FHorizontal then\r\n begin\r\n // horizontal\r\n T.Left := Round(FDifference * FPosition);\r\n if Height - FThumb1.Height < 0 then\r\n T.Top := 0\r\n else\r\n T.Top := (Height - FThumb1.Height) div 2;\r\n FFrom := T.Top;\r\n Canvas.Draw(T.Left, T.Top, FThumb1);\r\n FClicked := False;\r\n end\r\n else\r\n begin\r\n // vertical\r\n if Width - FThumb1.Width < 0 then\r\n T.Left := 0\r\n else\r\n T.Left := (Width - FThumb1.Width) div 2;\r\n T.Top := Round(FDifference * FPosition);\r\n FFrom := T.Left;\r\n Canvas.Draw(T.Left, T.Top, FThumb1);\r\n FClicked := False;\r\n end;\r\nend;\r\n\r\nprocedure TJvSlider.SetMaximum(Value: Integer);\r\nbegin\r\n FMaximum := Value;\r\n if FPosition > FMaximum then\r\n FPosition := FMaximum;\r\n Calculate;\r\n SetPosition(FPosition);\r\nend;\r\n\r\nprocedure TJvSlider.SetPosition(Value: Integer);\r\nbegin\r\n if Value > FMaximum then\r\n Value := FMaximum;\r\n // (rom) fixed the if\r\n if Value < 0 then\r\n Value := 0;\r\n FPosition := Value;\r\n\r\n if not FTracking then\r\n begin\r\n Calculate;\r\n Repaint;\r\n end;\r\nend;\r\n\r\nprocedure TJvSlider.Calculate;\r\nbegin\r\n // calculate the difference between pixels\r\n if FHorizontal then\r\n FDifference := (Width - FThumb1.Width) / FMaximum\r\n else\r\n FDifference := (Height - FThumb1.Height) / FMaximum;\r\nend;\r\n\r\nprocedure TJvSlider.ReCalcule(Sender: TObject);\r\nbegin\r\n Calculate;\r\nend;\r\n\r\nprocedure TJvSlider.MouseMove(Shift: TShiftState; X, Y: Integer);\r\nvar\r\n I: Integer;\r\nbegin\r\n if FTracking and (ssLeft in Shift) then\r\n begin\r\n if FHorizontal then\r\n begin\r\n if (Y in [0..FThumb1.Height]) or FChanging then\r\n begin\r\n I := X - FThumb1.Width div 2;\r\n if I > 0 then\r\n begin\r\n FChanging := True;\r\n I := Round(I / FDifference);\r\n if I > FMaximum then\r\n I := FMaximum;\r\n FPosition := I;\r\n if Assigned(FOnChanged) then\r\n FOnChanged(Self);\r\n Repaint;\r\n end;\r\n end;\r\n end\r\n else\r\n begin\r\n if (X in [0..FThumb1.Width]) or FChanging then\r\n begin\r\n I := Y - FThumb1.Height div 2;\r\n if I > 0 then\r\n begin\r\n FChanging := True;\r\n I := Round(I / FDifference);\r\n if I > FMaximum then\r\n I := FMaximum;\r\n FPosition := I;\r\n if Assigned(FOnChanged) then\r\n FOnChanged(Self);\r\n Repaint;\r\n end;\r\n end;\r\n end;\r\n Repaint;\r\n end;\r\nend;\r\n\r\nprocedure TJvSlider.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);\r\nvar\r\n Tmp: TBitmap;\r\n R: TRect;\r\n P: TPoint;\r\nbegin\r\n FTracking := True;\r\n MouseCapture := True;\r\n R := ClientRect;\r\n P := ClientToScreen(Point(0,0));\r\n OffsetRect(R, P.X, P.Y);\r\n ClipCursor(@R);\r\n if Assigned(FOnBeginChange) then\r\n FOnBeginChange(Self);\r\n if not FChanged then\r\n begin\r\n Tmp := TBitmap.Create;\r\n Tmp.Assign(FThumb1);\r\n FThumb1.Assign(FThumb2);\r\n FThumb2.Assign(Tmp);\r\n Tmp.Free;\r\n FChanged := True;\r\n end;\r\n Repaint;\r\nend;\r\n\r\nprocedure TJvSlider.MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);\r\nvar\r\n Tmp: TBitmap;\r\nbegin\r\n FTracking := False;\r\n FChanging := False;\r\n ClipCursor(nil);\r\n if FChanged then\r\n begin\r\n Tmp := TBitmap.Create;\r\n Tmp.Assign(FThumb1);\r\n FThumb1.Assign(FThumb2);\r\n FThumb2.Assign(Tmp);\r\n Tmp.Free;\r\n FChanged := False;\r\n end;\r\n Repaint;\r\n if Assigned(FOnStopChanged) then\r\n FOnStopChanged(Self);\r\nend;\r\n\r\nprocedure TJvSlider.ThumbChanged(Sender: TObject);\r\nvar\r\n Src, Dest: TRect;\r\nbegin\r\n Dest.Left := 0;\r\n Dest.Top := 0;\r\n Dest.Right := FImageThumb.Width div 2;\r\n Dest.Bottom := FImageThumb.Height;\r\n FThumb1.Width := Dest.Right;\r\n FThumb1.Height := Dest.Bottom;\r\n FThumb1.Canvas.CopyRect(Dest, FImageThumb.Canvas, Dest);\r\n FThumb2.Width := Dest.Right;\r\n FThumb2.Height := Dest.Bottom;\r\n Dest.Left := Dest.Right;\r\n Dest.Top := 0;\r\n Dest.Bottom := FImageThumb.Height;\r\n Dest.Right := FImageThumb.Width;\r\n Src.Left := 0;\r\n Src.Top := 0;\r\n Src.Right := Dest.Left;\r\n Src.Bottom := FImageThumb.Height;\r\n FThumb2.Canvas.CopyRect(Src, FImageThumb.Canvas, Dest);\r\n Invalidate;\r\n Calculate;\r\nend;\r\n\r\nprocedure TJvSlider.SetImageThumb(Value: TBitmap);\r\nbegin\r\n FImageThumb.Assign(Value);\r\n ThumbChanged(nil);\r\nend;\r\n\r\nprocedure TJvSlider.SetImageRuler(Value: TBitmap);\r\nbegin\r\n FImageRuler.Assign(Value);\r\n if (Value.Width > 0) and (Value.Height > 0) and AutoSize then\r\n begin\r\n Height := Value.Height;\r\n Width := Value.Width;\r\n end;\r\n Repaint;\r\n Calculate;\r\nend;\r\n\r\nprocedure TJvSlider.Loading(Sender: TObject);\r\nbegin\r\n FTimer.Enabled := False;\r\n SetImageThumb(FImageThumb);\r\n ThumbChanged(Self);\r\n Calculate;\r\n FTimer.Free;\r\nend;\r\n\r\n\r\nprocedure TJvSlider.WMEraseBkgnd(var Msg: TWMEraseBkgnd);\r\nbegin\r\n Msg.Result := 1;\r\nend;\r\n\r\n\r\nfunction TJvSlider.CanAutoSize(var NewWidth, NewHeight: Integer): Boolean;\r\nbegin\r\n if AutoSize and (FImageRuler.Width > 0) and (FImageRuler.Height > 0) then\r\n begin\r\n NewHeight := FImageRuler.Height;\r\n NewWidth := FImageRuler.Width;\r\n Result := True;\r\n end\r\n else\r\n Result := False;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvSoundControl.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvSoundControl.PAS, released on 2001-02-28.\r\n\r\nThe Initial Developer of the Original Code is Sbastien Buysse [sbuysse att buypin dott com]\r\nPortions created by Sbastien Buysse are Copyright (C) 2001 Sbastien Buysse.\r\nAll Rights Reserved.\r\n\r\nContributor(s): Michael Beck [mbeck att bigfoot dott com].\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvSoundControl.pas 13138 2011-10-26 23:17:50Z jfudickar $\r\n\r\nunit JvSoundControl;\r\n\r\n{$I jvcl.inc}\r\n{$I windowsonly.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, SysUtils, Classes, MMSystem,\r\n JvComponentBase;\r\n\r\ntype\r\n TBalance = 0..100;\r\n\r\n TJvVolumeRec = record\r\n case Byte of\r\n 0:\r\n (LongVolume: Longint);\r\n 1:\r\n (LeftVolume: Word;\r\n RightVolume: Word);\r\n end;\r\n\r\n TJvSoundValue = class(TPersistent)\r\n private\r\n FHandle: Integer;\r\n FOnRefresh: TNotifyEvent;\r\n FOnUpdate: TNotifyEvent;\r\n FBalance: Integer;\r\n FVolume: Integer;\r\n function GetBalance: TBalance;\r\n function GetVolume: Byte;\r\n procedure SetBalance(const Value: TBalance);\r\n procedure SetVolume(const Value: Byte);\r\n protected\r\n property OnRefresh: TNotifyEvent read FOnRefresh write FOnRefresh;\r\n property OnUpdate: TNotifyEvent read FOnUpdate write FOnUpdate;\r\n property Handle: Integer read FHandle write FHandle;\r\n procedure SetValue(Vol: TJvVolumeRec);\r\n function GetValue: TJvVolumeRec;\r\n public\r\n constructor Create;\r\n published\r\n property Volume: Byte read GetVolume write SetVolume stored False;\r\n property Balance: TBalance read GetBalance write SetBalance stored False;\r\n end;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvSoundControl = class(TJvComponent)\r\n private\r\n FMidi: TJvSoundValue;\r\n FCd: TJvSoundValue;\r\n FWave: TJvSoundValue;\r\n FLastError: Integer;\r\n procedure OnCdRefresh(Sender: TObject);\r\n procedure OnWaveRefresh(Sender: TObject);\r\n procedure OnMidiRefresh(Sender: TObject);\r\n procedure OnCdUpdate(Sender: TObject);\r\n procedure OnWaveUpdate(Sender: TObject);\r\n procedure OnMidiUpdate(Sender: TObject);\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n property LastError: Integer read FLastError;\r\n published\r\n property Wave: TJvSoundValue read FWave write FWave;\r\n property Midi: TJvSoundValue read FMidi write FMidi;\r\n property Cd: TJvSoundValue read FCd write FCd;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvSoundControl.pas $';\r\n Revision: '$Revision: 13138 $';\r\n Date: '$Date: 2011-10-27 01:17:50 +0200 (jeu. 27 oct. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\n\r\n//=== { TJvSoundControl } ====================================================\r\n\r\nconstructor TJvSoundControl.Create(AOwner: TComponent);\r\nvar\r\n AuxCaps: TAuxCaps;\r\n WaveOutCaps: TWaveOutCaps;\r\n MidiOutCaps: TMidiOutCaps;\r\n I: Integer;\r\nbegin\r\n inherited Create(AOwner);\r\n FLastError := 0;\r\n\r\n FMidi := TJvSoundValue.Create;\r\n FCd := TJvSoundValue.Create;\r\n FWave := TJvSoundValue.Create;\r\n\r\n FCd.OnRefresh := OnCdRefresh;\r\n FWave.OnRefresh := OnWaveRefresh;\r\n FMidi.OnRefresh := OnMidiRefresh;\r\n\r\n FCd.OnUpdate := OnCdUpdate;\r\n FWave.OnUpdate := OnWaveUpdate;\r\n FMidi.OnUpdate := OnMidiUpdate;\r\n\r\n for I := 0 to auxGetNumDevs - 1 do\r\n begin\r\n auxGetDevCaps(I, @AuxCaps, SizeOf(AuxCaps));\r\n if (AuxCaps.dwSupport and AUXCAPS_VOLUME) <> 0 then\r\n begin\r\n FCd.Handle := I;\r\n Break;\r\n end;\r\n end;\r\n\r\n for I := 0 to waveOutGetNumDevs - 1 do\r\n begin\r\n waveOutGetDevCaps(I, @WaveOutCaps, SizeOf(WaveOutCaps));\r\n if (WaveOutCaps.dwSupport and WAVECAPS_VOLUME) <> 0 then\r\n begin\r\n FWave.Handle := I;\r\n Break;\r\n end;\r\n end;\r\n\r\n for I := 0 to midiOutGetNumDevs - 1 do\r\n begin\r\n MidiOutGetDevCaps(I, @MidiOutCaps, SizeOf(MidiOutCaps));\r\n if (MidiOutCaps.dwSupport and MIDICAPS_VOLUME) <> 0 then\r\n begin\r\n FMidi.Handle := I;\r\n Break;\r\n end;\r\n end;\r\nend;\r\n\r\ndestructor TJvSoundControl.Destroy;\r\nbegin\r\n FMidi.Free;\r\n FCd.Free;\r\n FWave.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvSoundControl.OnCdRefresh(Sender: TObject);\r\nvar\r\n Vol: TJvVolumeRec;\r\nbegin\r\n with Sender as TJvSoundValue do\r\n begin\r\n FLastError := auxGetVolume(Handle, PDWORD(@Vol.LongVolume));\r\n if FLastError = MMSYSERR_NOERROR then\r\n SetValue(Vol);\r\n end;\r\nend;\r\n\r\nprocedure TJvSoundControl.OnCdUpdate(Sender: TObject);\r\nvar\r\n Vol: TJvVolumeRec;\r\nbegin\r\n with Sender as TJvSoundValue do\r\n begin\r\n Vol := GetValue;\r\n FLastError := auxSetVolume(Handle, Vol.LongVolume);\r\n end;\r\nend;\r\n\r\nprocedure TJvSoundControl.OnMidiRefresh(Sender: TObject);\r\nvar\r\n Vol: TJvVolumeRec;\r\nbegin\r\n with Sender as TJvSoundValue do\r\n begin\r\n FLastError := MidiOutGetVolume(Handle, PDWORD(@Vol.LongVolume));\r\n if FLastError = MMSYSERR_NOERROR then\r\n SetValue(Vol);\r\n end;\r\nend;\r\n\r\nprocedure TJvSoundControl.OnMidiUpdate(Sender: TObject);\r\nvar\r\n Vol: TJvVolumeRec;\r\nbegin\r\n with Sender as TJvSoundValue do\r\n begin\r\n Vol := GetValue;\r\n FLastError := MidiOutSetVolume(Handle, Vol.LongVolume);\r\n end;\r\nend;\r\n\r\nprocedure TJvSoundControl.OnWaveRefresh(Sender: TObject);\r\nvar\r\n Vol: TJvVolumeRec;\r\nbegin\r\n with Sender as TJvSoundValue do\r\n begin\r\n FLastError := waveOutGetVolume(Handle, PDWORD(@Vol.LongVolume));\r\n if FLastError = MMSYSERR_NOERROR then\r\n SetValue(Vol);\r\n end;\r\nend;\r\n\r\nprocedure TJvSoundControl.OnWaveUpdate(Sender: TObject);\r\nvar\r\n Vol: TJvVolumeRec;\r\nbegin\r\n with Sender as TJvSoundValue do\r\n begin\r\n Vol := GetValue;\r\n FLastError := WaveOutSetVolume(Handle, Vol.LongVolume);\r\n end;\r\nend;\r\n\r\n//=== { TJvSoundValue } ======================================================\r\n\r\nconstructor TJvSoundValue.Create;\r\nbegin\r\n inherited Create;\r\n FHandle := -1;\r\nend;\r\n\r\nfunction TJvSoundValue.GetBalance: TBalance;\r\nbegin\r\n if Handle = -1 then\r\n Result := 0\r\n else\r\n begin\r\n if Assigned(FOnRefresh) then\r\n FOnRefresh(Self);\r\n Result := FBalance;\r\n end;\r\nend;\r\n\r\nfunction TJvSoundValue.GetValue: TJvVolumeRec;\r\nbegin\r\n Result.LeftVolume := ((FVolume * FBalance) div 100) shl 9;\r\n Result.RightVolume := ((FVolume * (100 - FBalance)) div 100) shl 9;\r\nend;\r\n\r\nfunction TJvSoundValue.GetVolume: Byte;\r\nbegin\r\n if Handle = -1 then\r\n Result := 0\r\n else\r\n begin\r\n if Assigned(FOnRefresh) then\r\n FOnRefresh(Self);\r\n Result := FVolume;\r\n end;\r\nend;\r\n\r\nprocedure TJvSoundValue.SetBalance(const Value: TBalance);\r\nbegin\r\n if Handle <> -1 then\r\n begin\r\n FBalance := Value;\r\n if Assigned(FOnUpdate) then\r\n FOnUpdate(Self);\r\n end;\r\nend;\r\n\r\nprocedure TJvSoundValue.SetValue(Vol: TJvVolumeRec);\r\nvar\r\n Total: Double;\r\nbegin\r\n FVolume := (Vol.LeftVolume + Vol.RightVolume) shr 9;\r\n Total := (Vol.LeftVolume + Vol.RightVolume) / 100;\r\n if Total <> 0 then\r\n FBalance := Round(Vol.LeftVolume / Total);\r\nend;\r\n\r\nprocedure TJvSoundValue.SetVolume(const Value: Byte);\r\nbegin\r\n if Handle <> -1 then\r\n begin\r\n FVolume := Value;\r\n if Assigned(FOnUpdate) then\r\n FOnUpdate(Self);\r\n end;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvSpacer.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvSpacer.PAS, released on 2000-11-22.\r\n\r\nThe Initial Developer of the Original Code is Peter Below <100113 dott 1101 att compuserve dott com>\r\nPortions created by Peter Below are Copyright (C) 2000 Peter Below.\r\nAll Rights Reserved.\r\n\r\nContributor(s): ______________________________________.\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvSpacer.pas 13104 2011-09-07 06:50:43Z obones $\r\n\r\nunit JvSpacer;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n SysUtils, Classes, Graphics, Controls, Forms, ExtCtrls,\r\n JvExtComponent;\r\n\r\ntype\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvSpacer = class(TJvCustomPanel)\r\n private\r\n FSpacing: Integer;\r\n procedure SetSpacing(const Value: Integer);\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n procedure SetBounds(ALeft, ATop, AWidth, AHeight: Integer); override;\r\n published\r\n property Spacing: Integer read FSpacing write SetSpacing default 4;\r\n property Align;\r\n property BevelInner default bvNone;\r\n property BevelOuter default bvNone;\r\n property BorderStyle default bsNone;\r\n property Color;\r\n property DragCursor;\r\n property DragKind;\r\n property OnCanResize;\r\n property DragMode;\r\n property ParentColor;\r\n property Visible;\r\n property OnClick;\r\n property OnDblClick;\r\n property OnDragDrop;\r\n property OnDragOver;\r\n property OnEndDrag;\r\n property OnMouseDown;\r\n property OnMouseMove;\r\n property OnMouseUp;\r\n property OnResize;\r\n property OnStartDrag;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvSpacer.pas $';\r\n Revision: '$Revision: 13104 $';\r\n Date: '$Date: 2011-09-07 08:50:43 +0200 (mer. 07 sept. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nconstructor TJvSpacer.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n ControlStyle := ControlStyle - [csAcceptsControls, csSetCaption];\r\n FSpacing := 4;\r\n BevelInner := bvNone;\r\n BevelOuter := bvNone;\r\n BorderStyle := bsNone;\r\nend;\r\n\r\nprocedure TJvSpacer.SetBounds(ALeft, ATop, AWidth, AHeight: Integer);\r\nbegin\r\n if Align in [alTop, alBottom] then\r\n AHeight := FSpacing\r\n else\r\n if Align in [alLeft, alRight] then\r\n AWidth := FSpacing;\r\n inherited SetBounds(ALeft, ATop, AWidth, AHeight);\r\nend;\r\n\r\nprocedure TJvSpacer.SetSpacing(const Value: Integer);\r\nbegin\r\n if FSpacing <> Value then\r\n begin\r\n FSpacing := Value;\r\n SetBounds(Left, Top, Width, Height);\r\n end;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvSpecialImage.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvSpecialImage.PAS, released on 2001-02-28.\r\n\r\nThe Initial Developer of the Original Code is Sbastien Buysse [sbuysse att buypin dott com]\r\nPortions created by Sbastien Buysse are Copyright (C) 2001 Sbastien Buysse.\r\nAll Rights Reserved.\r\n\r\nContributor(s): Michael Beck [mbeck att bigfoot dott com].\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvSpecialImage.pas 13104 2011-09-07 06:50:43Z obones $\r\n\r\nunit JvSpecialImage;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n SysUtils, Classes, Windows, Graphics, Controls, ExtCtrls, Forms,\r\n JvTypes, JvExExtCtrls;\r\n\r\ntype\r\n TJvBright = 0..200;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvSpecialImage = class(TJvExImage)\r\n private\r\n FInverted: Boolean;\r\n FFlipped: Boolean;\r\n FBrightness: TJvBright;\r\n FOriginal: TPicture;\r\n FMirrored: Boolean;\r\n FWorking: Boolean;\r\n FChangingLocalProperty: Boolean;\r\n procedure SetBright(Value: TJvBright);\r\n procedure SetFlipped(const Value: Boolean);\r\n procedure SetInverted(const Value: Boolean);\r\n procedure SetMirrored(const Value: Boolean);\r\n procedure PictureChanged(Sender: TObject);\r\n procedure ApplyChanges;\r\n function GetPicture: TPicture;\r\n procedure SetPicture(const Value: TPicture);\r\n protected\r\n procedure Loaded; override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n published\r\n property Brightness: TJvBright read FBrightness write SetBright default 100;\r\n property Inverted: Boolean read FInverted write SetInverted default False;\r\n property Flipped: Boolean read FFlipped write SetFlipped default False;\r\n property Mirrored: Boolean read FMirrored write SetMirrored default False;\r\n property Picture: TPicture read GetPicture write SetPicture;\r\n procedure FadeIn;\r\n procedure FadeOut;\r\n procedure Reset;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvSpecialImage.pas $';\r\n Revision: '$Revision: 13104 $';\r\n Date: '$Date: 2011-09-07 08:50:43 +0200 (mer. 07 sept. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\n\r\nconstructor TJvSpecialImage.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FOriginal := TPicture.Create;\r\n FBrightness := 100;\r\n FInverted := False;\r\n FFlipped := False;\r\n FMirrored := False;\r\n FWorking := False;\r\n FChangingLocalProperty := False;\r\n Picture.OnChange := PictureChanged;\r\nend;\r\n\r\ndestructor TJvSpecialImage.Destroy;\r\nbegin\r\n Picture.Assign(FOriginal);\r\n FOriginal.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvSpecialImage.Loaded;\r\nbegin\r\n inherited Loaded;\r\n FOriginal.Assign(Picture);\r\nend;\r\n\r\nprocedure TJvSpecialImage.ApplyChanges;\r\nvar\r\n I, J: Integer;\r\n Line, Line2: PJvRGBArray;\r\n Dest: TBitmap;\r\n Val: Integer;\r\n Tmp: TJvRGBTriple;\r\nbegin\r\n if FWorking or (csLoading in ComponentState) or (csDestroying in ComponentState) then\r\n Exit;\r\n FWorking := True;\r\n Dest := TBitmap.Create;\r\n try\r\n //Copy original bitmap\r\n Dest.Width := FOriginal.Width;\r\n Dest.Height := FOriginal.Height;\r\n Dest.Canvas.Draw(0, 0, FOriginal.Graphic);\r\n Dest.PixelFormat := pf24Bit;\r\n\r\n if not Dest.Empty then\r\n begin\r\n // Set brightness\r\n Val := (FBrightness - 100) * 255 div 100;\r\n if Val > 0 then\r\n begin\r\n for I := 0 to Dest.Height - 1 do\r\n begin\r\n Line := Dest.ScanLine[I];\r\n for J := 0 to Dest.Width - 1 do\r\n with Line[J] do\r\n begin\r\n if rgbBlue + Val > 255 then\r\n rgbBlue := 255\r\n else\r\n rgbBlue := rgbBlue + Val;\r\n if rgbGreen + Val > 255 then\r\n rgbGreen := 255\r\n else\r\n rgbGreen := rgbGreen + Val;\r\n if rgbRed + Val > 255 then\r\n rgbRed := 255\r\n else\r\n rgbRed := rgbRed + Val;\r\n end;\r\n end;\r\n end\r\n else\r\n if Val < 0 then\r\n begin\r\n for I := 0 to Dest.Height - 1 do\r\n begin\r\n Line := Dest.ScanLine[I];\r\n for J := 0 to Dest.Width - 1 do\r\n with Line[J] do\r\n begin\r\n if rgbBlue + Val < 0 then\r\n rgbBlue := 0\r\n else\r\n rgbBlue := rgbBlue + Val;\r\n if rgbGreen + Val < 0 then\r\n rgbGreen := 0\r\n else\r\n rgbGreen := rgbGreen + Val;\r\n if rgbRed + Val < 0 then\r\n rgbRed := 0\r\n else\r\n rgbRed := rgbRed + Val;\r\n end;\r\n end;\r\n end;\r\n\r\n //Set Flipped\r\n if FFlipped then\r\n begin\r\n for I := 0 to (Dest.Height - 1) div 2 do\r\n begin\r\n Line := Dest.ScanLine[I];\r\n Line2 := Dest.ScanLine[Dest.Height - I - 1];\r\n for J := 0 to Dest.Width - 1 do\r\n begin\r\n Tmp := Line[J];\r\n Line[J] := Line2[J];\r\n Line2[J] := Tmp;\r\n end;\r\n end;\r\n end;\r\n\r\n //Set inverted\r\n if FInverted then\r\n begin\r\n for I := 0 to Dest.Height - 1 do\r\n begin\r\n Line := Dest.ScanLine[I];\r\n for J := 0 to Dest.Width - 1 do\r\n with Line[J] do\r\n begin\r\n rgbBlue := not rgbBlue;\r\n rgbGreen := not rgbGreen;\r\n rgbRed := not rgbRed;\r\n end;\r\n end;\r\n end;\r\n\r\n //Set mirrored\r\n if FMirrored then\r\n begin\r\n for I := 0 to Dest.Height - 1 do\r\n begin\r\n Line := Dest.ScanLine[I];\r\n for J := 0 to (Dest.Width - 1) div 2 do\r\n begin\r\n Tmp := Line[J];\r\n Line[J] := Line[Dest.Width - J - 1];\r\n Line[Dest.Width - J - 1] := Tmp;\r\n end;\r\n end;\r\n end;\r\n end;\r\n // We only need to assign the new picture if it occured after having\r\n // changed one of the local properties: Mirrored, Brightness, Inverted,\r\n // Flipped. This way we prevent freeing the graphic used by the inherited\r\n // procedures with the following assignment.\r\n // The most common example is when setting Transparent:\r\n //\r\n // In ExtCtrls.pas, you have this code:\r\n //\r\n // G.Transparent := FTransparent;\r\n //\r\n // This changes the picture, leading to this call stack:\r\n // TJvSpecialImage.PictureChanged -> calls ApplyChanges then\r\n // TJvSpecialImage.ApplyChanges -> calls inherited Picture.Assign(Dest) then\r\n // TPicture.Assign -> calls TPicture.SetGraphic then\r\n // FGraphic is freed, which is Picture.Graphic which is G.\r\n //\r\n // Hence, to prevent the freeing of G, we don't call the inherited\r\n // Picture.Assign, and it does not event prevent the image from being\r\n // updated with the correct values for the local properties as thoses were\r\n // already applied at a previous time when their calls were made.\r\n // This was Mantis 2693.\r\n if FChangingLocalProperty then\r\n inherited Picture.Assign(Dest);\r\n finally\r\n Dest.Free;\r\n FWorking := False;\r\n end;\r\nend;\r\n\r\nprocedure TJvSpecialImage.FadeIn;\r\nvar\r\n I: Integer;\r\nbegin\r\n // (rom) needs better implementation. Timing is by CPU/graphics speed.\r\n for I := 0 to 50 do\r\n begin\r\n Brightness := I * 2;\r\n Application.ProcessMessages;\r\n end;\r\nend;\r\n\r\nprocedure TJvSpecialImage.FadeOut;\r\nvar\r\n I: Integer;\r\nbegin\r\n // (rom) needs better implementation. Timing is by CPU/graphics speed.\r\n for I := 50 downto 0 do\r\n begin\r\n Brightness := I * 2;\r\n Application.ProcessMessages;\r\n end;\r\nend;\r\n\r\nfunction TJvSpecialImage.GetPicture: TPicture;\r\nbegin\r\n Result := inherited Picture;\r\nend;\r\n\r\nprocedure TJvSpecialImage.PictureChanged(Sender: TObject);\r\nbegin\r\n if FWorking = False then\r\n begin\r\n FOriginal.Assign(inherited Picture);\r\n ApplyChanges; // SetBright(FBrightness);\r\n end;\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvSpecialImage.Reset;\r\nbegin\r\n FWorking := True;\r\n Brightness := 100;\r\n Inverted := False;\r\n Flipped := False;\r\n Mirrored := False;\r\n FWorking := False;\r\n Picture.Assign(FOriginal);\r\nend;\r\n\r\nprocedure TJvSpecialImage.SetBright(Value: TJvBright);\r\nbegin\r\n FChangingLocalProperty := True;\r\n try\r\n FBrightness := Value;\r\n ApplyChanges;\r\n finally\r\n FChangingLocalProperty := False;\r\n end;\r\nend;\r\n\r\nprocedure TJvSpecialImage.SetFlipped(const Value: Boolean);\r\nbegin\r\n if Value <> FFlipped then\r\n begin\r\n FChangingLocalProperty := True;\r\n try\r\n FFlipped := Value;\r\n ApplyChanges;\r\n finally\r\n FChangingLocalProperty := False;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvSpecialImage.SetInverted(const Value: Boolean);\r\nbegin\r\n if Value <> FInverted then\r\n begin\r\n FChangingLocalProperty := True;\r\n try\r\n FInverted := Value;\r\n ApplyChanges;\r\n finally\r\n FChangingLocalProperty := False;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvSpecialImage.SetMirrored(const Value: Boolean);\r\nbegin\r\n if Value <> FMirrored then\r\n begin\r\n FChangingLocalProperty := True;\r\n try\r\n FMirrored := Value;\r\n ApplyChanges;\r\n finally\r\n FChangingLocalProperty := False;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvSpecialImage.SetPicture(const Value: TPicture);\r\nbegin\r\n FOriginal.Assign(Value);\r\n inherited Picture := Value;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvSpecialProgress.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvSpecialProgress.PAS, released on 2001-02-28.\r\n\r\nThe Initial Developer of the Original Code is Sbastien Buysse [sbuysse att buypin dott com]\r\nPortions created by Sbastien Buysse are Copyright (C) 2001 Sbastien Buysse.\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\n Michael Beck [mbeck att bigfoot dott com].\r\n [eldorado]\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI home page,\r\nlocated at http://www.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvSpecialProgress.pas 13104 2011-09-07 06:50:43Z obones $\r\n\r\nunit JvSpecialProgress;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n SysUtils, Classes,\r\n Windows, Messages, Graphics, Controls, Forms, ExtCtrls, // for Frame3D\r\n JvComponent;\r\n\r\ntype\r\n TJvTextOption = (toCaption, toFormat, toNoText, toPercent);\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvSpecialProgress = class(TJvGraphicControl)\r\n private\r\n FBorderStyle: TBorderStyle;\r\n FEndColor: TColor;\r\n FGradientBlocks: Boolean;\r\n FMaximum: Integer;\r\n FMinimum: Integer;\r\n FPosition: Integer;\r\n FSolid: Boolean;\r\n FStartColor: TColor;\r\n FStep: Integer;\r\n FTextCentered: Boolean;\r\n FTextOption: TJvTextOption;\r\n FBuffer: TBitmap;\r\n FBlock: Integer;\r\n { FIsChanged indicates if the buffer needs to be redrawn }\r\n FIsChanged: Boolean;\r\n FStart: TColor;\r\n FEnd: TColor;\r\n { If Solid = False then the values of the following vars are valid: }\r\n { FBlockCount is # of blocks }\r\n FBlockCount: Integer;\r\n { FBlockWidth is length of block in pixels + 1 {seperator }\r\n FBlockWidth: Integer;\r\n { FLastBlockPartial indicates whether the last block is of length\r\n FBlockWidth; if FLastBlockPartial is True the progressbar is totally\r\n filled and the last block is *not* of length FBlockWidth, but of\r\n length FLastBlockWidth; if FLastBlockPartial is False the progressbar\r\n is not totally filled or the last block is of length FBlockWidth }\r\n FLastBlockPartial: Boolean;\r\n { FLastBlockWidth specifies the length of the last block if the\r\n progressbar is totally filled, note: *not* +1 for seperator }\r\n FLastBlockWidth: Integer;\r\n function GetPercentDone: Longint;\r\n procedure SetBorderStyle(Value: TBorderStyle);\r\n procedure SetEndColor(const Value: TColor);\r\n procedure SetGradientBlocks(const Value: Boolean);\r\n procedure SetMaximum(const Value: Integer);\r\n procedure SetMinimum(const Value: Integer);\r\n procedure SetPosition(const Value: Integer);\r\n procedure SetSolid(const Value: Boolean);\r\n procedure SetStartColor(const Value: TColor);\r\n procedure SetTextCentered(const Value: Boolean);\r\n procedure SetTextOption(const Value: TJvTextOption);\r\n procedure PaintRectangle;\r\n procedure PaintNonSolid;\r\n procedure PaintSolid;\r\n procedure DoEraseBackground;\r\n procedure PaintText;\r\n protected\r\n procedure Paint; override;\r\n procedure Loaded; override;\r\n procedure ColorChanged; override;\r\n procedure FontChanged; override;\r\n procedure TextChanged; override;\r\n procedure UpdateBuffer;\r\n procedure UpdateBlock;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n procedure StepIt;\r\n property PercentDone: Longint read GetPercentDone;\r\n published\r\n property Align;\r\n property Anchors;\r\n property BorderStyle: TBorderStyle read FBorderStyle write SetBorderStyle default bsNone;\r\n property Caption;\r\n property Color;\r\n property EndColor: TColor read FEndColor write SetEndColor default clBlack;\r\n property Font;\r\n property GradientBlocks: Boolean read FGradientBlocks write SetGradientBlocks default False;\r\n property HintColor;\r\n property Maximum: Integer read FMaximum write SetMaximum default 100;\r\n property Minimum: Integer read FMinimum write SetMinimum default 0;\r\n property ParentColor;\r\n property ParentFont;\r\n property Position: Integer read FPosition write SetPosition default 0;\r\n property ShowHint;\r\n property Solid: Boolean read FSolid write SetSolid default False;\r\n property StartColor: TColor read FStartColor write SetStartColor default clWhite;\r\n property Step: Integer read FStep write FStep default 10;\r\n property TextCentered: Boolean read FTextCentered write SetTextCentered default False;\r\n property TextOption: TJvTextOption read FTextOption write SetTextOption default toNoText;\r\n property Visible;\r\n property OnClick;\r\n property OnDblClick;\r\n property OnDragOver;\r\n property OnDragDrop;\r\n property OnEndDock;\r\n property OnStartDock;\r\n property OnEndDrag;\r\n property OnMouseDown;\r\n property OnMouseMove;\r\n property OnMouseUp;\r\n property OnResize;\r\n property OnStartDrag;\r\n property OnMouseEnter;\r\n property OnMouseLeave;\r\n property OnParentColorChange;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvSpecialProgress.pas $';\r\n Revision: '$Revision: 13104 $';\r\n Date: '$Date: 2011-09-07 08:50:43 +0200 (mer. 07 sept. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\n\r\nconstructor TJvSpecialProgress.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FBuffer := TBitmap.Create;\r\n\r\n ControlStyle := ControlStyle + [csOpaque]; // SMM 20020604\r\n FBorderStyle := bsNone;\r\n FMaximum := 100;\r\n FMinimum := 0;\r\n FStartColor := clWhite;\r\n FStart := clWhite;\r\n FEndColor := clBlack;\r\n FEnd := clBlack;\r\n FPosition := 0;\r\n FSolid := False;\r\n FTextOption := toNoText;\r\n FTextCentered := False;\r\n FGradientBlocks := False;\r\n FStep := 10;\r\n\r\n Width := 150;\r\n Height := 15;\r\n FIsChanged := True;\r\nend;\r\n\r\ndestructor TJvSpecialProgress.Destroy;\r\nbegin\r\n FBuffer.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvSpecialProgress.ColorChanged;\r\nbegin\r\n //inherited ColorChanged; calls CM_COLORCHANGED in VCL\r\n { No need to call inherited; Repaint is called in UpdateBuffer }\r\n FIsChanged := True;\r\n UpdateBuffer;\r\nend;\r\n\r\nprocedure TJvSpecialProgress.FontChanged;\r\nbegin\r\n //inherited FontChanged; calls CM_COLORCHANGED in VCL\r\n { No need to call inherited; Repaint is called in UpdateBuffer }\r\n FBuffer.Canvas.Font := Font;\r\n\r\n { Only update if text is visible }\r\n if TextOption = toNoText then\r\n Exit;\r\n\r\n FIsChanged := True;\r\n UpdateBuffer;\r\nend;\r\n\r\nprocedure TJvSpecialProgress.TextChanged;\r\nbegin\r\n if TextOption in [toCaption, toFormat] then\r\n begin\r\n FIsChanged := True;\r\n UpdateBuffer;\r\n end;\r\n inherited TextChanged;\r\nend;\r\n\r\nfunction TJvSpecialProgress.GetPercentDone: Longint;\r\nbegin\r\n if FMaximum - FMinimum = 0 then\r\n Result := 0\r\n else\r\n Result := MulDiv(FPosition - FMinimum, 100, FMaximum - FMinimum);\r\nend;\r\n\r\nprocedure TJvSpecialProgress.Loaded;\r\nbegin\r\n inherited Loaded;\r\n UpdateBlock;\r\n UpdateBuffer;\r\nend;\r\n\r\nprocedure TJvSpecialProgress.Paint;\r\nbegin\r\n if (FBuffer.Width <> ClientWidth) or (FBuffer.Height <> ClientHeight) then\r\n begin\r\n FIsChanged := True;\r\n UpdateBlock;\r\n UpdateBuffer;\r\n end;\r\n if (ClientWidth > 2) and (ClientHeight > 2) then\r\n begin\r\n BitBlt(Canvas.Handle, 0, 0, ClientWidth, ClientHeight,\r\n FBuffer.Canvas.Handle, 0, 0, SRCCOPY);\r\n end;\r\nend;\r\n\r\nprocedure TJvSpecialProgress.DoEraseBackground;\r\nbegin\r\n if FBlock >= ClientWidth - 2 then\r\n Exit;\r\n\r\n FBuffer.Canvas.Brush.Color := Color;\r\n FBuffer.Canvas.Brush.Style := bsSolid;\r\n FBuffer.Canvas.FillRect(Rect(FBlock + 1, 1, ClientWidth - 1, ClientHeight - 1));\r\nend;\r\n\r\nprocedure TJvSpecialProgress.PaintNonSolid;\r\nvar\r\n RedInc, GreenInc, BlueInc: Real;\r\n Red, Green, Blue: Real;\r\n X: Integer;\r\n I, J: Integer;\r\n LBlockCount: Integer;\r\nbegin\r\n if (FBlock = 0) or (FBlockWidth = 0) then\r\n Exit;\r\n\r\n X := 1;\r\n\r\n { LBlockCount equals # blocks of size FBlockWidth }\r\n if FLastBlockPartial then\r\n LBlockCount := FBlockCount - 1\r\n else\r\n LBlockCount := FBlockCount;\r\n\r\n { Are the start and end colors equal? }\r\n if FStart = FEnd then\r\n begin\r\n { No gradient fill because the start color equals the end color }\r\n FBuffer.Canvas.Brush.Color := FStart;\r\n FBuffer.Canvas.Brush.Style := bsSolid;\r\n for I := 0 to LBlockCount - 1 do\r\n begin\r\n { Width of block is FBlockWidth -1 [-1 for seperator] }\r\n FBuffer.Canvas.FillRect(Bounds(X, 1, FBlockWidth - 1, ClientHeight - 2));\r\n Inc(X, FBlockWidth);\r\n end;\r\n if FLastBlockPartial then\r\n { Width of last block is FLastBlockWidth [no seperator] }\r\n FBuffer.Canvas.FillRect(Bounds(X, 1, FLastBlockWidth, ClientHeight - 2));\r\n end\r\n else\r\n begin\r\n RedInc := (GetRValue(FEnd) - GetRValue(FStart)) / FBlock;\r\n GreenInc := (GetGValue(FEnd) - GetGValue(FStart)) / FBlock;\r\n BlueInc := (GetBValue(FEnd) - GetBValue(FStart)) / FBlock;\r\n\r\n Red := GetRValue(FStart);\r\n Green := GetGValue(FStart);\r\n Blue := GetBValue(FStart);\r\n\r\n FBuffer.Canvas.Brush.Style := bsSolid;\r\n\r\n for I := 0 to LBlockCount - 1 do\r\n begin\r\n if not FGradientBlocks then\r\n begin\r\n FBuffer.Canvas.Brush.Color := RGB(Round(Red), Round(Green), Round(Blue));\r\n Red := Red + RedInc * FBlockWidth;\r\n Blue := Blue + BlueInc * FBlockWidth;\r\n Green := Green + GreenInc * FBlockWidth;\r\n { Width of block is FBlockWidth -1 [-1 for seperator] }\r\n FBuffer.Canvas.FillRect(Bounds(X, 1, FBlockWidth - 1, ClientHeight - 2));\r\n end\r\n else\r\n begin\r\n { Fill the progressbar with slices of 1 width }\r\n for J := 0 to FBlockWidth - 2 do\r\n begin\r\n FBuffer.Canvas.Brush.Color := RGB(Round(Red), Round(Green), Round(Blue));\r\n Red := Red + RedInc;\r\n Blue := Blue + BlueInc;\r\n Green := Green + GreenInc;\r\n FBuffer.Canvas.FillRect(Bounds(X + J, 1, 1, ClientHeight - 2));\r\n end;\r\n { Seperator is not filled, but increase the colors }\r\n Red := Red + RedInc;\r\n Blue := Blue + BlueInc;\r\n Green := Green + GreenInc;\r\n end;\r\n Inc(X, FBlockWidth);\r\n end;\r\n if FLastBlockPartial then\r\n begin\r\n if not FGradientBlocks then\r\n begin\r\n FBuffer.Canvas.Brush.Color := RGB(Round(Red), Round(Green), Round(Blue));\r\n { Width of last block is FLastBlockWidth [no seperator] }\r\n FBuffer.Canvas.FillRect(Bounds(X, 1, FLastBlockWidth, ClientHeight - 2));\r\n end\r\n else\r\n { Width of last block is FLastBlockWidth [no seperator] }\r\n for J := 0 to FLastBlockWidth - 1 do\r\n begin\r\n FBuffer.Canvas.Brush.Color := RGB(Round(Red), Round(Green), Round(Blue));\r\n Red := Red + RedInc;\r\n Blue := Blue + BlueInc;\r\n Green := Green + GreenInc;\r\n FBuffer.Canvas.FillRect(Bounds(X + J, 1, 1, ClientHeight - 2));\r\n end;\r\n end;\r\n end;\r\n\r\n { Draw the block seperators }\r\n X := FBlockWidth;\r\n FBuffer.Canvas.Brush.Color := Color;\r\n for I := 0 to LBlockCount - 1 do\r\n begin\r\n FBuffer.Canvas.FillRect(Bounds(X, 1, 1, ClientHeight - 2));\r\n Inc(X, FBlockWidth);\r\n end;\r\nend;\r\n\r\nprocedure TJvSpecialProgress.PaintRectangle;\r\nvar\r\n Rect: TRect;\r\nbegin\r\n Rect := ClientRect;\r\n if BorderStyle = bsNone then\r\n begin\r\n FBuffer.Canvas.Brush.Color := Color;\r\n FBuffer.Canvas.FrameRect(Rect);\r\n end\r\n else\r\n begin\r\n Frame3D(FBuffer.Canvas, Rect, clBtnFace, clBtnFace, 1);\r\n Frame3D(FBuffer.Canvas, Rect, clBtnShadow, clBtnHighlight, 1);\r\n Frame3D(FBuffer.Canvas, Rect, cl3DDkShadow, clBtnFace, 1);\r\n end;\r\nend;\r\n\r\nprocedure TJvSpecialProgress.PaintSolid;\r\nvar\r\n RedInc, BlueInc, GreenInc: Real;\r\n I: Integer;\r\nbegin\r\n if FBlock = 0 then\r\n Exit;\r\n\r\n if FStart = FEnd then\r\n begin\r\n { No gradient fill because the start color equals the end color }\r\n FBuffer.Canvas.Brush.Color := FStart;\r\n FBuffer.Canvas.Brush.Style := bsSolid;\r\n FBuffer.Canvas.FillRect(Rect(1, 1, 1 + FBlock, ClientHeight - 1));\r\n end\r\n else\r\n begin\r\n RedInc := (GetRValue(FEnd) - GetRValue(FStart)) / FBlock;\r\n GreenInc := (GetGValue(FEnd) - GetGValue(FStart)) / FBlock;\r\n BlueInc := (GetBValue(FEnd) - GetBValue(FStart)) / FBlock;\r\n FBuffer.Canvas.Brush.Style := bsSolid;\r\n { Fill the progressbar with slices of 1 width }\r\n for I := 1 to FBlock do\r\n begin\r\n FBuffer.Canvas.Brush.Color := RGB(\r\n Round(GetRValue(FStart) + ((I - 1) * RedInc)),\r\n Round(GetGValue(FStart) + ((I - 1) * GreenInc)),\r\n Round(GetBValue(FStart) + ((I - 1) * BlueInc)));\r\n FBuffer.Canvas.FillRect(Rect(I, 1, I + 1, ClientHeight - 1));\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvSpecialProgress.PaintText;\r\nvar\r\n S: string;\r\n X, Y: Integer;\r\n LBlock: Integer;\r\nbegin\r\n case TextOption of\r\n toPercent:\r\n S := Format('%d%%', [PercentDone]);\r\n toFormat:\r\n S := Format(Caption, [PercentDone]);\r\n toCaption:\r\n S := Caption;\r\n else {toNoText}\r\n Exit;\r\n end;\r\n\r\n if TextCentered then\r\n LBlock := ClientWidth\r\n else\r\n LBlock := FBlock;\r\n\r\n X := (LBlock - FBuffer.Canvas.TextWidth(S)) div 2;\r\n if X < 0 then\r\n X := 0;\r\n\r\n Y := (ClientHeight - FBuffer.Canvas.TextHeight(S)) div 2;\r\n if Y < 0 then\r\n Y := 0;\r\n\r\n SetBkMode(FBuffer.Canvas.Handle, Windows.TRANSPARENT);\r\n // FBuffer.Canvas.Brush.Color := clNone;\r\n // FBuffer.Canvas.Brush.Style := bsClear;\r\n FBuffer.Canvas.TextOut(X, Y, S);\r\nend;\r\n\r\nprocedure TJvSpecialProgress.SetBorderStyle(Value: TBorderStyle);\r\nbegin\r\n if FBorderStyle <> Value then\r\n begin\r\n FBorderStyle := Value;\r\n\r\n FIsChanged := True;\r\n UpdateBuffer;\r\n end;\r\nend;\r\n\r\nprocedure TJvSpecialProgress.SetEndColor(const Value: TColor);\r\nbegin\r\n if FEndColor <> Value then\r\n begin\r\n FEndColor := Value;\r\n FEnd := ColorToRGB(FEndColor);\r\n\r\n FIsChanged := True;\r\n UpdateBuffer;\r\n end;\r\nend;\r\n\r\nprocedure TJvSpecialProgress.SetGradientBlocks(const Value: Boolean);\r\nbegin\r\n if Value <> FGradientBlocks then\r\n begin\r\n FGradientBlocks := Value;\r\n if not Solid then\r\n begin\r\n FIsChanged := True;\r\n UpdateBuffer;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvSpecialProgress.SetMaximum(const Value: Integer);\r\nvar\r\n OldPercentageDone: Integer;\r\nbegin\r\n if FMaximum <> Value then\r\n begin\r\n OldPercentageDone := GetPercentDone;\r\n\r\n FMaximum := Value;\r\n if FMaximum < FMinimum then\r\n FMaximum := FMinimum;\r\n if FPosition > Value then\r\n FPosition := Value;\r\n\r\n { If the percentage has changed we must update, otherwise check in\r\n UpdateBlock if we must update }\r\n FIsChanged := (TextOption in [toPercent, toFormat]) and (OldPercentageDone <> GetPercentDone);\r\n UpdateBlock;\r\n UpdateBuffer;\r\n end;\r\nend;\r\n\r\nprocedure TJvSpecialProgress.SetMinimum(const Value: Integer);\r\nvar\r\n OldPercentageDone: Integer;\r\nbegin\r\n if FMinimum <> Value then\r\n begin\r\n OldPercentageDone := GetPercentDone;\r\n\r\n FMinimum := Value;\r\n if FMinimum > FMaximum then\r\n FMinimum := FMaximum;\r\n if FPosition < Value then\r\n FPosition := Value;\r\n\r\n { If the percentage has changed we must update, otherwise check in\r\n UpdateBlock if we must update }\r\n FIsChanged := (TextOption in [toPercent, toFormat]) and (OldPercentageDone <> GetPercentDone);\r\n UpdateBlock;\r\n UpdateBuffer;\r\n end;\r\nend;\r\n\r\nprocedure TJvSpecialProgress.SetPosition(const Value: Integer);\r\nvar\r\n OldPercentageDone: Integer;\r\nbegin\r\n if FPosition <> Value then\r\n begin\r\n OldPercentageDone := GetPercentDone;\r\n\r\n FPosition := Value;\r\n if FPosition > FMaximum then\r\n FPosition := FMaximum\r\n else\r\n if FPosition < FMinimum then\r\n FPosition := FMinimum;\r\n\r\n { If the percentage has changed we must update, otherwise check in\r\n UpdateBlock if we must update }\r\n FIsChanged := (TextOption in [toPercent, toFormat]) and (OldPercentageDone <> GetPercentDone);\r\n UpdateBlock;\r\n UpdateBuffer;\r\n end;\r\nend;\r\n\r\nprocedure TJvSpecialProgress.SetSolid(const Value: Boolean);\r\nbegin\r\n if FSolid <> Value then\r\n begin\r\n FSolid := Value;\r\n FIsChanged := True;\r\n UpdateBlock;\r\n UpdateBuffer;\r\n end;\r\nend;\r\n\r\nprocedure TJvSpecialProgress.SetStartColor(const Value: TColor);\r\nbegin\r\n if FStartColor <> Value then\r\n begin\r\n FStartColor := Value;\r\n FStart := ColorToRGB(FStartColor);\r\n FIsChanged := True;\r\n UpdateBuffer;\r\n end;\r\nend;\r\n\r\nprocedure TJvSpecialProgress.SetTextCentered(const Value: Boolean);\r\nbegin\r\n if FTextCentered <> Value then\r\n begin\r\n FTextCentered := Value;\r\n if TextOption <> toNoText then\r\n begin\r\n FIsChanged := True;\r\n UpdateBuffer;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvSpecialProgress.SetTextOption(const Value: TJvTextOption);\r\nbegin\r\n if FTextOption <> Value then\r\n begin\r\n FTextOption := Value;\r\n FIsChanged := True;\r\n UpdateBuffer;\r\n end;\r\nend;\r\n\r\nprocedure TJvSpecialProgress.StepIt;\r\nbegin\r\n if FPosition + FStep > FMaximum then\r\n Position := FMaximum\r\n else\r\n if FPosition + FStep < FMinimum then\r\n Position := FMinimum\r\n else\r\n Position := FPosition + FStep;\r\nend;\r\n\r\nprocedure TJvSpecialProgress.UpdateBuffer;\r\nbegin\r\n if not FIsChanged or (csLoading in ComponentState) then\r\n Exit;\r\n FIsChanged := False;\r\n\r\n if (ClientWidth <= 0) or (ClientHeight <= 0) then\r\n Exit;\r\n FBuffer.Width := ClientWidth;\r\n FBuffer.Height := ClientHeight;\r\n\r\n if FSolid then\r\n PaintSolid\r\n else\r\n PaintNonSolid;\r\n\r\n DoEraseBackground;\r\n PaintText;\r\n PaintRectangle;\r\n\r\n Repaint;\r\nend;\r\n\r\nprocedure TJvSpecialProgress.UpdateBlock;\r\nvar\r\n NewBlock: Integer;\r\n NextBlockWidth: Integer;\r\nbegin\r\n if csLoading in ComponentState then\r\n Exit;\r\n\r\n if (FMaximum = FMinimum) or (ClientWidth < 2) then\r\n Exit;\r\n\r\n { Max width of the progressbar is ClientWidth -2 [-2 for the border],\r\n NewBlock specifies the new length of the progressbar }\r\n NewBlock := MulDiv(FPosition - FMinimum, ClientWidth - 2, FMaximum - FMinimum);\r\n if not FSolid then\r\n begin\r\n { The Block of a solid bar can have a different size than the Block\r\n of a non-solid bar }\r\n FBlockWidth := Round(ClientHeight * 2 div 3);\r\n if FBlockWidth = 0 then\r\n NewBlock := 0\r\n else\r\n begin\r\n { The block count equals 'Block div blockwidth'. We add 1 to\r\n that number if the Block is further than 1/2 of the next block.\r\n Note that the next block doesn't have to be of size FBlockWidth,\r\n because it can be the last block, which can be smaller than\r\n FBlockWidth }\r\n\r\n FBlockCount := NewBlock div FBlockWidth;\r\n NextBlockWidth := ClientWidth - 2 - (FBlockCount * FBlockWidth);\r\n if NextBlockWidth > FBlockWidth then\r\n NextBlockWidth := FBlockWidth;\r\n\r\n if 2 * (NewBlock mod FBlockWidth) > NextBlockWidth then\r\n begin\r\n Inc(FBlockCount);\r\n FLastBlockPartial := NextBlockWidth < FBlockWidth;\r\n FLastBlockWidth := NextBlockWidth;\r\n NewBlock := FBlockWidth * FBlockCount;\r\n { If FLastBlockPartial equals True then the progressbar is totally\r\n filled: }\r\n if FLastBlockPartial then\r\n NewBlock := ClientWidth - 2;\r\n end\r\n else\r\n begin\r\n FLastBlockPartial := False;\r\n NewBlock := FBlockWidth * FBlockCount;\r\n end;\r\n end;\r\n end;\r\n\r\n if NewBlock = FBlock then\r\n Exit;\r\n\r\n FBlock := NewBlock;\r\n\r\n FIsChanged := True;\r\n UpdateBuffer;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n\r\n" }, { "path": "External/Jedi/Jvcl/run/JvSpeedButton.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvSpeedButton.pas, released on 2003-10-19.\r\n\r\nThe Initial Developers of the Original Code are: Fedor Koshevnikov, Igor Pavluk and Serge Korolev\r\nCopyright (c) 1997, 1998 Fedor Koshevnikov, Igor Pavluk and Serge Korolev\r\nCopyright (c) 2001,2002 SGB Software\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\n Polaris Software\r\n Peter Thornqvist [peter3 at sourceforge dot net]\r\n Dejoy Den\r\n Andreas Hausladen\r\n\r\nChanges:\r\n2003-10-19:\r\n * Moved TJvSpeedButton from JvxCtrls to this unit\r\n2005-05-20:(dejoy)\r\n * TJvSpeedButton implemented interface of IJvHotTrack.\r\n2005-06-04:(dejoy)\r\n * fixed bug: memory leak in TJvCustomSpeedButton.Paint;\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvSpeedButton.pas 13415 2012-09-10 09:51:54Z obones $\r\n\r\nunit JvSpeedButton;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n CommCtrl, Types, SysUtils, Classes, Windows, Messages,\r\n Controls, Graphics, Forms, ExtCtrls, Buttons, Menus, ImgList, ActnList,\r\n {$IFDEF HAS_UNIT_SYSTEM_UITYPES}\r\n System.UITypes,\r\n {$ENDIF HAS_UNIT_SYSTEM_UITYPES}\r\n JvExControls, JvComponent, JvConsts, JvTypes, JvHotTrackPersistent,\r\n JvThemes;\r\n\r\ntype\r\n TJvNumGlyphs = 1..5;\r\n TJvDropDownMenuPos = (dmpBottom, dmpRight);\r\n TJvButtonState = (rbsUp, rbsDisabled, rbsDown, rbsExclusive, rbsInactive);\r\n TJvSpeedButtonHotTrackOptions = TJvHotTrackOptions;\r\n\r\n TJvxButtonGlyph = class;\r\n\r\n TJvCustomSpeedButton = class(TJvGraphicControl, IJvHotTrack)\r\n private\r\n FAllowAllUp: Boolean;\r\n FAllowTimer: Boolean;\r\n FDown: Boolean;\r\n FDragging: Boolean;\r\n FDropDownMenu: TPopupMenu;\r\n FFlat: Boolean;\r\n FFontSave: TFont;\r\n FGlyph: TJvxButtonGlyph;\r\n FGroupIndex: Integer;\r\n FHotTrack: Boolean;\r\n FHotTrackFont: TFont;\r\n FHotTrackFontOptions: TJvTrackFontOptions;\r\n FHotTrackOptions: TJvHotTrackOptions;\r\n FInactiveGrayed: Boolean;\r\n FInitRepeatPause: Word;\r\n FLayout: TButtonLayout;\r\n FMargin: Integer;\r\n FMarkDropDown: Boolean;\r\n FMenuPosition: TJvDropDownMenuPos;\r\n FMenuTracking: Boolean;\r\n FModalResult: TModalResult;\r\n FRepeatPause: Word;\r\n FRepeatTimer: TTimer;\r\n FSpacing: Integer;\r\n FStyle: TButtonStyle;\r\n FTransparent: Boolean;\r\n FDoubleBuffered: Boolean;\r\n function GetAlignment: TAlignment;\r\n function GetGrayNewStyle: Boolean;\r\n function GetWordWrap: Boolean;\r\n procedure SetAlignment(Value: TAlignment);\r\n procedure SetAllowAllUp(Value: Boolean);\r\n procedure SetAllowTimer(Value: Boolean);\r\n procedure SetDown(Value: Boolean);\r\n procedure SetDropdownMenu(Value: TPopupMenu);\r\n procedure SetFlat(Value: Boolean);\r\n procedure SetGrayNewStyle(const Value: Boolean);\r\n procedure SetGroupIndex(Value: Integer);\r\n procedure SetInactiveGrayed(Value: Boolean);\r\n procedure SetLayout(Value: TButtonLayout);\r\n procedure SetMargin(Value: Integer);\r\n procedure SetMarkDropDown(Value: Boolean);\r\n procedure SetSpacing(Value: Integer);\r\n procedure SetStyle(Value: TButtonStyle);\r\n procedure SetTransparent(Value: Boolean);\r\n procedure SetWordWrap(Value: Boolean);\r\n\r\n {IJvHotTrack} //added by dejoy 2005-04-20\r\n function GetHotTrack:Boolean;\r\n function GetHotTrackFont:TFont;\r\n function GetHotTrackFontOptions:TJvTrackFontOptions;\r\n function GetHotTrackOptions:TJvHotTrackOptions;\r\n procedure SetHotTrack(Value: Boolean);\r\n procedure SetHotTrackFont(Value: TFont);\r\n procedure SetHotTrackFontOptions(Value: TJvTrackFontOptions);\r\n procedure SetHotTrackOptions(Value: TJvHotTrackOptions);\r\n procedure IJvHotTrack_Assign(Source: IJvHotTrack);\r\n procedure IJvHotTrack.Assign = IJvHotTrack_Assign;\r\n\r\n function CheckMenuDropDown(const Pos: TSmallPoint; Manual: Boolean): Boolean;\r\n procedure DoMouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);\r\n procedure TimerExpired(Sender: TObject);\r\n procedure UpdateExclusive;\r\n procedure CMButtonPressed(var Msg: TCMButtonPressed); message CM_JVBUTTONPRESSED;\r\n procedure CMSysColorChange(var Msg: TMessage); message CM_SYSCOLORCHANGE;\r\n procedure WMLButtonDblClk(var Msg: TWMLButtonDown); message WM_LBUTTONDBLCLK;\r\n procedure WMPaint(var Msg: TWMPaint); message WM_PAINT;\r\n procedure WMRButtonDown(var Msg: TWMRButtonDown); message WM_RBUTTONDOWN;\r\n procedure WMRButtonUp(var Msg: TWMRButtonUp); message WM_RBUTTONUP;\r\n protected\r\n FState: TJvButtonState;\r\n function WantKey(Key: Integer; Shift: TShiftState): Boolean; override;\r\n procedure EnabledChanged; override;\r\n procedure FontChanged; override;\r\n procedure TextChanged; override;\r\n procedure VisibleChanged; override;\r\n function GetDropDownMenuPos: TPoint;\r\n procedure Loaded; override;\r\n procedure Paint; override;\r\n procedure MouseEnter(Control: TControl); override;\r\n procedure MouseLeave(Control: TControl); override;\r\n procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;\r\n procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;\r\n procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;\r\n procedure Notification(AComponent: TComponent; Operation: TOperation); override;\r\n procedure PaintImage(Canvas: TCanvas; ARect: TRect; const Offset: TPoint;\r\n AState: TJvButtonState; DrawMark, PaintOnGlass: Boolean); virtual; abstract;\r\n property ButtonGlyph: TJvxButtonGlyph read FGlyph;\r\n property IsDragging: Boolean read FDragging;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n procedure ButtonClick;\r\n function CheckBtnMenuDropDown: Boolean;\r\n procedure Click; override;\r\n procedure UpdateTracking;\r\n procedure Repaint; override;\r\n protected\r\n property Alignment: TAlignment read GetAlignment write SetAlignment default taCenter;\r\n property AllowAllUp: Boolean read FAllowAllUp write SetAllowAllUp default False;\r\n property AllowTimer: Boolean read FAllowTimer write SetAllowTimer default False;\r\n property DoubleBuffered: Boolean read FDoubleBuffered write FDoubleBuffered default True;\r\n property Down: Boolean read FDown write SetDown default False;\r\n property DropDownMenu: TPopupMenu read FDropDownMenu write SetDropdownMenu;\r\n property Flat: Boolean read FFlat write SetFlat default False;\r\n { If True, Image is grayed when not mouse is in control (Only for flat buttons) }\r\n property GrayedInactive: Boolean read FInactiveGrayed write SetInactiveGrayed default True;\r\n { If True, Image is grayed (when enables=False) like the imagelist does, otherwise like the speedbutton does }\r\n property GrayNewStyle: Boolean read GetGrayNewStyle write SetGrayNewStyle default True;\r\n property GroupIndex: Integer read FGroupIndex write SetGroupIndex default 0;\r\n property HotTrack: Boolean read GetHotTrack write SetHotTrack default False;\r\n property HotTrackFont: TFont read GetHotTrackFont write SetHotTrackFont;\r\n property HotTrackFontOptions: TJvTrackFontOptions read GetHotTrackFontOptions write SetHotTrackFontOptions default\r\n DefaultTrackFontOptions;\r\n property HotTrackOptions: TJvHotTrackOptions read GetHotTrackOptions write SetHotTrackOptions;\r\n property InitPause: Word read FInitRepeatPause write FInitRepeatPause default 500;\r\n { (rb) Weird default }\r\n property Layout: TButtonLayout read FLayout write SetLayout default blGlyphTop;\r\n property Margin: Integer read FMargin write SetMargin default -1;\r\n property MarkDropDown: Boolean read FMarkDropDown write SetMarkDropDown default True;\r\n property MenuPosition: TJvDropDownMenuPos read FMenuPosition write FMenuPosition default dmpBottom;\r\n property ModalResult: TModalResult read FModalResult write FModalResult default 0;\r\n property RepeatInterval: Word read FRepeatPause write FRepeatPause default 100;\r\n { (rb) Weird default }\r\n property Spacing: Integer read FSpacing write SetSpacing default 1;\r\n property Style: TButtonStyle read FStyle write SetStyle default bsAutoDetect;\r\n property Transparent: Boolean read FTransparent write SetTransparent default False;\r\n property WordWrap: Boolean read GetWordWrap write SetWordWrap default False;\r\n property ParentColor default False;\r\n property Color default clBtnFace;\r\n\r\n property OnMouseEnter;\r\n property OnMouseLeave;\r\n end;\r\n\r\n TJvImageSpeedButton = class;\r\n TJvSpeedButton = class;\r\n\r\n TJvImageSpeedButtonActionLink = class(TControlActionLink)\r\n protected\r\n FClient: TJvImageSpeedButton;\r\n procedure AssignClient(AClient: TObject); override;\r\n function IsCheckedLinked: Boolean; override;\r\n function IsGroupIndexLinked: Boolean; override;\r\n procedure SetGroupIndex(Value: Integer); override;\r\n function IsImageIndexLinked: Boolean; override;\r\n procedure SetChecked(Value: Boolean); override;\r\n procedure SetImageIndex(Value: Integer); override;\r\n end;\r\n\r\n TJvSpeedButtonActionLink = class(TControlActionLink)\r\n protected\r\n FClient: TJvSpeedButton;\r\n procedure AssignClient(AClient: TObject); override;\r\n function IsCheckedLinked: Boolean; override;\r\n function IsGroupIndexLinked: Boolean; override;\r\n procedure SetGroupIndex(Value: Integer); override;\r\n procedure SetChecked(Value: Boolean); override;\r\n end;\r\n\r\n TJvImageSpeedButton = class(TJvCustomSpeedButton)\r\n private\r\n FImageChangeLink: TChangeLink;\r\n FImageIndex: TImageIndex;\r\n FImages: TCustomImageList;\r\n FHotTrackImageIndex: TImageIndex;\r\n procedure ImageListChange(Sender: TObject);\r\n procedure SetImageIndex(const Value: TImageIndex);\r\n procedure SetImages(const Value: TCustomImageList);\r\n procedure SetHotTrackImageIndex(const Value: TImageIndex);\r\n protected\r\n procedure ActionChange(Sender: TObject; CheckDefaults: Boolean); override;\r\n\r\n function GetActionLinkClass: TControlActionLinkClass; override;\r\n procedure InvalidateImage;\r\n procedure PaintImage(Canvas: TCanvas; ARect: TRect; const Offset: TPoint;\r\n AState: TJvButtonState; DrawMark, PaintOnGlass: Boolean); override;\r\n function IsImageVisible: Boolean;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n published\r\n property Action;\r\n property Align;\r\n property Alignment;\r\n property AllowAllUp;\r\n property AllowTimer;\r\n property Anchors;\r\n property BiDiMode;\r\n property DragCursor;\r\n property DragKind;\r\n property ParentBiDiMode;\r\n property Caption;\r\n property Constraints;\r\n property Color;\r\n property ParentColor;\r\n { Ensure group index is declared before Down }\r\n property GroupIndex;\r\n property DoubleBuffered;\r\n property Down;\r\n property DragMode;\r\n property DropDownMenu;\r\n property Enabled;\r\n property Flat;\r\n property Font;\r\n property GrayedInactive;\r\n property GrayNewStyle;\r\n property HintColor;\r\n property HotTrack;\r\n property HotTrackFont;\r\n property HotTrackFontOptions;\r\n property HotTrackImageIndex: TImageIndex read FHotTrackImageIndex write SetHotTrackImageIndex;\r\n property ImageIndex: TImageIndex read FImageIndex write SetImageIndex default -1;\r\n property Images: TCustomImageList read FImages write SetImages;\r\n property InitPause;\r\n property Layout;\r\n property Margin;\r\n property MarkDropDown;\r\n property MenuPosition;\r\n property ModalResult;\r\n property ParentFont;\r\n property ParentShowHint default False;\r\n property RepeatInterval;\r\n property ShowHint default True;\r\n property Spacing;\r\n property Style;\r\n property Transparent;\r\n property Visible;\r\n property WordWrap;\r\n\r\n property OnClick;\r\n property OnDblClick;\r\n property OnDragDrop;\r\n property OnDragOver;\r\n property OnEndDock;\r\n property OnStartDock;\r\n property OnEndDrag;\r\n property OnMouseDown;\r\n property OnMouseEnter;\r\n property OnMouseLeave;\r\n property OnMouseMove;\r\n property OnMouseUp;\r\n property OnParentColorChange;\r\n property OnStartDrag;\r\n end;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvSpeedButton = class(TJvCustomSpeedButton)\r\n private\r\n FHotTrackGlyph: TJvxButtonGlyph;\r\n FGlyphFromAction: Boolean;\r\n function GetGlyph: TBitmap;\r\n function GetHotTrackGlyph: TBitmap;\r\n function GetNumGlyphs: TJvNumGlyphs;\r\n procedure GlyphChanged(Sender: TObject);\r\n procedure HotTrackGlyphChanged(Sender: TObject);\r\n procedure SetGlyph(Value: TBitmap);\r\n procedure SetHotTrackGlyph(const Value: TBitmap);\r\n procedure SetNumGlyphs(Value: TJvNumGlyphs);\r\n function IsGlyphStored: Boolean;\r\n protected\r\n procedure ActionChange(Sender: TObject; CheckDefaults: Boolean); override;\r\n\r\n function GetActionLinkClass: TControlActionLinkClass; override;\r\n function GetPalette: HPALETTE; override;\r\n procedure PaintImage(Canvas: TCanvas; ARect: TRect; const Offset: TPoint;\r\n AState: TJvButtonState; DrawMark, PaintOnGlass: Boolean); override;\r\n procedure SyncHotGlyph;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n published\r\n property Action;\r\n property Align;\r\n property Alignment;\r\n property AllowAllUp;\r\n property AllowTimer;\r\n property Anchors;\r\n property BiDiMode;\r\n property DragCursor;\r\n property DragKind;\r\n property ParentBiDiMode;\r\n property Caption;\r\n property Constraints;\r\n property Color;\r\n property ParentColor;\r\n { Ensure group index is declared before Down }\r\n property GroupIndex;\r\n property DoubleBuffered;\r\n property Down;\r\n property DragMode;\r\n property DropDownMenu;\r\n property Enabled;\r\n property Flat;\r\n property Font;\r\n property Glyph: TBitmap read GetGlyph write SetGlyph stored IsGlyphStored;\r\n property GrayedInactive;\r\n property GrayNewStyle;\r\n property HintColor;\r\n property HotTrack;\r\n property HotTrackFont;\r\n property HotTrackFontOptions;\r\n {Inserted by (ag) 2004-09-04}\r\n property HotTrackOptions;\r\n {Insert End}\r\n property HotTrackGlyph: TBitmap read GetHotTrackGlyph write SetHotTrackGlyph;\r\n property InitPause;\r\n property Layout;\r\n property Margin;\r\n property MarkDropDown;\r\n property MenuPosition;\r\n property ModalResult;\r\n property NumGlyphs: TJvNumGlyphs read GetNumGlyphs write SetNumGlyphs default 1;\r\n property ParentFont;\r\n property ParentShowHint default False;\r\n property RepeatInterval;\r\n property ShowHint default True;\r\n property Spacing;\r\n property Style;\r\n property Transparent;\r\n property Visible;\r\n property WordWrap;\r\n\r\n property OnMouseEnter;\r\n property OnMouseLeave;\r\n property OnParentColorChange;\r\n property OnClick;\r\n property OnDblClick;\r\n property OnDragDrop;\r\n property OnDragOver;\r\n property OnEndDrag;\r\n property OnMouseDown;\r\n property OnMouseMove;\r\n property OnMouseUp;\r\n property OnStartDrag;\r\n property OnEndDock;\r\n property OnStartDock;\r\n end;\r\n\r\n TJvButtonImage = class(TObject)\r\n private\r\n FGlyph: TJvxButtonGlyph;\r\n FButtonSize: TPoint;\r\n FCaption: TCaption;\r\n function GetNumGlyphs: TJvNumGlyphs;\r\n procedure SetNumGlyphs(Value: TJvNumGlyphs);\r\n function GetWordWrap: Boolean;\r\n procedure SetWordWrap(Value: Boolean);\r\n function GetAlignment: TAlignment;\r\n procedure SetAlignment(Value: TAlignment);\r\n function GetGlyph: TBitmap;\r\n procedure SetGlyph(Value: TBitmap);\r\n public\r\n constructor Create;\r\n destructor Destroy; override;\r\n procedure Invalidate;\r\n procedure DrawEx(Canvas: TCanvas; X, Y, Margin, Spacing: Integer;\r\n Layout: TButtonLayout; AFont: TFont; Images: TCustomImageList;\r\n ImageIndex: Integer; Flags: Word; PaintOnGlass: Boolean);\r\n procedure Draw(Canvas: TCanvas; X, Y, Margin, Spacing: Integer;\r\n Layout: TButtonLayout; AFont: TFont; Flags: Word; PaintOnGlass: Boolean);\r\n property Alignment: TAlignment read GetAlignment write SetAlignment;\r\n property Caption: TCaption read FCaption write FCaption;\r\n property Glyph: TBitmap read GetGlyph write SetGlyph;\r\n property NumGlyphs: TJvNumGlyphs read GetNumGlyphs write SetNumGlyphs;\r\n property ButtonSize: TPoint read FButtonSize write FButtonSize;\r\n property WordWrap: Boolean read GetWordWrap write SetWordWrap;\r\n end;\r\n\r\n { (rb) Similar class in JvButtons.pas }\r\n TJvxButtonGlyph = class(TObject)\r\n private\r\n FAlignment: TAlignment;\r\n FGlyphList: TCustomImageList;\r\n FGrayNewStyle: Boolean;\r\n FIndexs: array [TJvButtonState] of Integer;\r\n FNumGlyphs: TJvNumGlyphs;\r\n FOnChange: TNotifyEvent;\r\n FOriginal: TBitmap;\r\n FTransparentColor: TColor;\r\n FWordWrap: Boolean;\r\n FPaintOnGlass: Boolean;\r\n procedure GlyphChanged(Sender: TObject);\r\n procedure SetGlyph(Value: TBitmap);\r\n procedure SetGrayNewStyle(const Value: Boolean);\r\n procedure SetNumGlyphs(Value: TJvNumGlyphs);\r\n function MapColor(Color: TColor): TColor;\r\n protected\r\n procedure MinimizeCaption(Canvas: TCanvas; var Caption: string; Width: Integer);\r\n function CreateButtonGlyph(State: TJvButtonState): Integer;\r\n function CreateImageGlyph(State: TJvButtonState; Images: TCustomImageList;\r\n Index: Integer): Integer;\r\n procedure CalcButtonLayout(Canvas: TCanvas; const Client: TRect; const AOffset: TPoint;\r\n var Caption: string; Layout: TButtonLayout; Margin, Spacing: Integer;\r\n PopupMark: Boolean; var GlyphPos: TPoint; var TextBounds: TRect;\r\n Flags: Word; Images: TCustomImageList; ImageIndex: Integer);\r\n public\r\n constructor Create;\r\n destructor Destroy; override;\r\n procedure Invalidate;\r\n function DrawButtonGlyph(Canvas: TCanvas; X, Y: Integer;\r\n State: TJvButtonState): TPoint;\r\n function DrawButtonImage(Canvas: TCanvas; X, Y: Integer; Images: TCustomImageList;\r\n ImageIndex: Integer; State: TJvButtonState): TPoint;\r\n function DrawEx(Canvas: TCanvas; const Client: TRect; const Offset: TPoint;\r\n const Caption: string; Layout: TButtonLayout; Margin, Spacing: Integer;\r\n PopupMark: Boolean; Images: TCustomImageList; ImageIndex: Integer;\r\n State: TJvButtonState; Flags: Word; PaintOnGlass: Boolean): TRect;\r\n procedure DrawButtonText(Canvas: TCanvas; const Caption: string;\r\n TextBounds: TRect; State: TJvButtonState; Flags: Word);\r\n procedure DrawPopupMark(Canvas: TCanvas; X, Y: Integer;\r\n State: TJvButtonState);\r\n function Draw(Canvas: TCanvas; const Client: TRect; const Offset: TPoint;\r\n const Caption: string; Layout: TButtonLayout; Margin, Spacing: Integer;\r\n PopupMark: Boolean; State: TJvButtonState; Flags: Word; PaintOnGlass: Boolean): TRect;\r\n property Alignment: TAlignment read FAlignment write FAlignment;\r\n property Glyph: TBitmap read FOriginal write SetGlyph;\r\n property GrayNewStyle: Boolean read FGrayNewStyle write SetGrayNewStyle;\r\n property NumGlyphs: TJvNumGlyphs read FNumGlyphs write SetNumGlyphs;\r\n property WordWrap: Boolean read FWordWrap write FWordWrap;\r\n property OnChange: TNotifyEvent read FOnChange write FOnChange;\r\n end;\r\n\r\n{ DrawButtonFrame - returns the remaining usable area inside the Client rect }\r\n\r\nfunction DrawButtonFrame(Canvas: TCanvas; const Client: TRect;\r\n IsDown, IsFlat: Boolean; Style: TButtonStyle; AColor: TColor): TRect;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvSpeedButton.pas $';\r\n Revision: '$Revision: 13415 $';\r\n Date: '$Date: 2012-09-10 11:51:54 +0200 (lun. 10 sept. 2012) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n Math, JvJCLUtils, JvJVCLUtils;\r\n\r\ntype\r\n TJvGlyphList = class;\r\n\r\n TJvGlyphCache = class(TObject)\r\n private\r\n FGlyphLists: TList;\r\n public\r\n constructor Create;\r\n destructor Destroy; override;\r\n function GetList(AWidth, AHeight: Integer): TJvGlyphList;\r\n procedure ReturnList(List: TJvGlyphList);\r\n function Empty: Boolean;\r\n end;\r\n\r\n TJvGlyphList = class(TCustomImageList)\r\n private\r\n FUsed: TBits;\r\n FCount: Integer;\r\n function AllocateIndex: Integer;\r\n public\r\n constructor CreateSize(AWidth, AHeight: Integer);\r\n destructor Destroy; override;\r\n function Add(Image, Mask: TBitmap): Integer;\r\n function AddMasked(Image: TBitmap; MaskColor: TColor): Integer;\r\n procedure Delete(Index: Integer);\r\n property Count: Integer read FCount;\r\n end;\r\n\r\n TWinControlAccess = class(TWinControl);\r\n\r\nconst\r\n Alignments: array [TAlignment] of Word = (DT_LEFT, DT_RIGHT, DT_CENTER);\r\n WordWraps: array [Boolean] of Word = (0, DT_WORDBREAK);\r\n\r\nvar\r\n // (rom) changed to var\r\n // (rb) used for?\r\n ButtonCount: Integer;\r\n GlyphCache: TJvGlyphCache;\r\n TempBrushBitmap: TBitmap = nil;\r\n SaveColor1, SaveColor2: TColor;\r\n\r\n//=== Local procedures =======================================================\r\n\r\n{ DrawButtonFrame - returns the remaining usable area inside the Client rect }\r\n\r\nfunction DrawButtonFrame(Canvas: TCanvas; const Client: TRect;\r\n IsDown, IsFlat: Boolean; Style: TButtonStyle; AColor: TColor): TRect;\r\n\r\nvar\r\n NewStyle: Boolean;\r\n ShadowColor, HighlightColor: TColor;\r\n\r\n // Honeymic\r\n function GetHighlightColor(BaseColor: TColor): TColor;\r\n begin\r\n Result := RGB(\r\n Min(GetRValue(ColorToRGB(BaseColor)) + 64, 255),\r\n Min(GetGValue(ColorToRGB(BaseColor)) + 64, 255),\r\n Min(GetBValue(ColorToRGB(BaseColor)) + 64, 255));\r\n end;\r\n\r\n // Honeymic\r\n function GetShadowColor(BaseColor: TColor): TColor;\r\n begin\r\n Result := RGB(\r\n Max(GetRValue(ColorToRGB(BaseColor)) - 64, 0),\r\n Max(GetGValue(ColorToRGB(BaseColor)) - 64, 0),\r\n Max(GetBValue(ColorToRGB(BaseColor)) - 64, 0));\r\n end;\r\n\r\nbegin\r\n Result := Client;\r\n NewStyle := (Style = bsNew) or (Style = bsAutoDetect);\r\n ShadowColor := GetShadowColor(AColor); // Honeymic\r\n HighlightColor := GetHighlightColor(AColor); // Honeymic\r\n\r\n if IsDown then\r\n begin\r\n if NewStyle then\r\n begin\r\n //Polaris\r\n //Frame3D(Canvas, Result,clBtnShadow{ clWindowFrame}, clBtnHighlight, 1);\r\n //if not IsFlat then\r\n // Frame3D(Canvas, Result, clBtnShadow, clBtnFace, 1);\r\n if not IsFlat then\r\n begin\r\n // Honeymic\r\n Frame3D(Canvas, Result, clWindowFrame, HighlightColor, 1);\r\n Frame3D(Canvas, Result, ShadowColor, AColor, 1);\r\n end\r\n else\r\n // Honeymic\r\n Frame3D(Canvas, Result, ShadowColor, HighlightColor, 1);\r\n end\r\n else\r\n begin\r\n if IsFlat then\r\n begin\r\n // Honeymic\r\n Frame3D(Canvas, Result, clWindowFrame, HighlightColor, 1);\r\n end\r\n else\r\n begin\r\n Frame3D(Canvas, Result, clWindowFrame, clWindowFrame, 1);\r\n // Honeymic\r\n Canvas.Pen.Color := clBtnShadow;\r\n Canvas.PolyLine([Point(Result.Left, Result.Bottom - 1),\r\n Point(Result.Left, Result.Top), Point(Result.Right, Result.Top)]);\r\n end;\r\n end;\r\n end\r\n else\r\n begin\r\n if NewStyle then\r\n begin\r\n if IsFlat then\r\n // Honeymic\r\n Frame3D(Canvas, Result, HighlightColor, ShadowColor, 1)\r\n else\r\n begin\r\n // Honeymic\r\n Frame3D(Canvas, Result, HighlightColor, clWindowFrame, 1);\r\n Frame3D(Canvas, Result, AColor, ShadowColor, 1);\r\n end;\r\n end\r\n else\r\n begin\r\n if IsFlat then\r\n // Honeymic\r\n Frame3D(Canvas, Result, HighlightColor, clWindowFrame, 1)\r\n else\r\n begin\r\n Frame3D(Canvas, Result, clWindowFrame, clWindowFrame, 1);\r\n // Honeymic\r\n Frame3D(Canvas, Result, HighlightColor, ShadowColor, 1);\r\n end;\r\n end;\r\n end;\r\n InflateRect(Result, -1, -1);\r\nend;\r\n\r\nfunction GetBrushPattern(Color1, Color2: TColor): TBitmap;\r\nbegin\r\n if TempBrushBitmap = nil then\r\n TempBrushBitmap := CreateTwoColorsBrushPattern(Color1, Color2)\r\n else\r\n begin\r\n if (Color1 <> SaveColor1) or (Color2 <> SaveColor2) then\r\n begin\r\n FreeAndNil(TempBrushBitmap);\r\n TempBrushBitmap := CreateTwoColorsBrushPattern(Color1, Color2);\r\n end;\r\n end;\r\n SaveColor1 := Color1;\r\n SaveColor2 := Color2;\r\n\r\n Result := TempBrushBitmap;\r\nend;\r\n\r\n//=== { TJvButtonImage } =====================================================\r\n\r\nconstructor TJvButtonImage.Create;\r\nbegin\r\n inherited Create;\r\n FGlyph := TJvxButtonGlyph.Create;\r\n NumGlyphs := 1;\r\n FButtonSize := Point(24, 23);\r\nend;\r\n\r\ndestructor TJvButtonImage.Destroy;\r\nbegin\r\n FGlyph.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvButtonImage.Draw(Canvas: TCanvas; X, Y, Margin, Spacing: Integer;\r\n Layout: TButtonLayout; AFont: TFont; Flags: Word; PaintOnGlass: Boolean);\r\nbegin\r\n DrawEx(Canvas, X, Y, Margin, Spacing, Layout, AFont, nil, -1, Flags, PaintOnGlass);\r\nend;\r\n\r\nprocedure TJvButtonImage.DrawEx(Canvas: TCanvas; X, Y, Margin, Spacing: Integer;\r\n Layout: TButtonLayout; AFont: TFont; Images: TCustomImageList; ImageIndex: Integer;\r\n Flags: Word; PaintOnGlass: Boolean);\r\nvar\r\n Target: TRect;\r\n SaveColor: Integer;\r\n SaveFont: TFont;\r\n Offset: TPoint;\r\nbegin\r\n SaveColor := Canvas.Brush.Color;\r\n SaveFont := TFont.Create;\r\n SaveFont.Assign(Canvas.Font);\r\n try\r\n Target := Bounds(X, Y, FButtonSize.X, FButtonSize.Y);\r\n Offset := Point(0, 0);\r\n Canvas.Brush.Color := clBtnFace;\r\n Canvas.FillRect(Target);\r\n Frame3D(Canvas, Target, clBtnShadow, clWindowFrame, 1);\r\n Frame3D(Canvas, Target, clBtnHighlight, clBtnShadow, 1);\r\n if AFont <> nil then\r\n Canvas.Font := AFont;\r\n FGlyph.DrawEx(Canvas, Target, Offset, Caption, Layout, Margin,\r\n Spacing, False, Images, ImageIndex, rbsUp, Flags, PaintOnGlass);\r\n finally\r\n Canvas.Font.Assign(SaveFont);\r\n SaveFont.Free;\r\n Canvas.Brush.Color := SaveColor;\r\n end;\r\nend;\r\n\r\nfunction TJvButtonImage.GetAlignment: TAlignment;\r\nbegin\r\n Result := FGlyph.Alignment;\r\nend;\r\n\r\nfunction TJvButtonImage.GetGlyph: TBitmap;\r\nbegin\r\n Result := FGlyph.Glyph;\r\nend;\r\n\r\nfunction TJvButtonImage.GetNumGlyphs: TJvNumGlyphs;\r\nbegin\r\n Result := FGlyph.NumGlyphs;\r\nend;\r\n\r\nfunction TJvButtonImage.GetWordWrap: Boolean;\r\nbegin\r\n Result := FGlyph.WordWrap;\r\nend;\r\n\r\nprocedure TJvButtonImage.Invalidate;\r\nbegin\r\n FGlyph.Invalidate;\r\nend;\r\n\r\nprocedure TJvButtonImage.SetAlignment(Value: TAlignment);\r\nbegin\r\n FGlyph.Alignment := Value;\r\nend;\r\n\r\nprocedure TJvButtonImage.SetGlyph(Value: TBitmap);\r\nbegin\r\n FGlyph.Glyph := Value;\r\nend;\r\n\r\nprocedure TJvButtonImage.SetNumGlyphs(Value: TJvNumGlyphs);\r\nbegin\r\n FGlyph.NumGlyphs := Value;\r\nend;\r\n\r\nprocedure TJvButtonImage.SetWordWrap(Value: Boolean);\r\nbegin\r\n FGlyph.WordWrap := Value;\r\nend;\r\n\r\n//=== { TJvCustomSpeedButton } ===============================================\r\n\r\nconstructor TJvCustomSpeedButton.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n ParentColor := False;\r\n Color := clBtnFace;\r\n FHotTrack := False;\r\n FHotTrackFont := TFont.Create;\r\n FHotTrackFontOptions := DefaultTrackFontOptions;\r\n FHotTrackOptions := TJvSpeedButtonHotTrackOptions.Create(Self);\r\n FFontSave := TFont.Create;\r\n SetBounds(0, 0, 25, 25);\r\n ControlStyle := [csCaptureMouse, csOpaque, csDoubleClicks];\r\n ControlStyle := ControlStyle + [csReplicatable];\r\n FInactiveGrayed := True;\r\n FGlyph := TJvxButtonGlyph.Create;\r\n FGlyph.GrayNewStyle := True;\r\n ParentFont := True;\r\n ParentShowHint := False;\r\n ShowHint := True;\r\n FSpacing := 1;\r\n FMargin := -1;\r\n FInitRepeatPause := 500;\r\n FRepeatPause := 100;\r\n FStyle := bsAutoDetect;\r\n FLayout := blGlyphTop;\r\n FMarkDropDown := True;\r\n FDoubleBuffered := True;\r\n Inc(ButtonCount);\r\nend;\r\n\r\ndestructor TJvCustomSpeedButton.Destroy;\r\nbegin\r\n FHotTrackOptions.Free;\r\n FGlyph.Free;\r\n Dec(ButtonCount);\r\n if FRepeatTimer <> nil then\r\n FRepeatTimer.Free;\r\n FHotTrackFont.Free;\r\n FFontSave.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvCustomSpeedButton.ButtonClick;\r\nbegin\r\n if FMenuTracking or (not Enabled) or (Assigned(FDropDownMenu) and\r\n DropDownMenu.AutoPopup) then\r\n Exit;\r\n if not FDown then\r\n begin\r\n FState := rbsDown;\r\n Repaint;\r\n end;\r\n try\r\n Sleep(20); // (ahuser) why?\r\n if FGroupIndex = 0 then\r\n Click;\r\n finally\r\n FState := rbsUp;\r\n if FGroupIndex = 0 then\r\n Repaint\r\n else\r\n begin\r\n SetDown(not FDown);\r\n Click;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJvCustomSpeedButton.CheckBtnMenuDropDown: Boolean;\r\nbegin\r\n Result := CheckMenuDropDown(PointToSmallPoint(GetDropDownMenuPos), True);\r\nend;\r\n\r\nfunction TJvCustomSpeedButton.CheckMenuDropDown(const Pos: TSmallPoint;\r\n Manual: Boolean): Boolean;\r\nvar\r\n Form: TCustomForm;\r\n Pt: TPoint;\r\nbegin\r\n Result := False;\r\n if csDesigning in ComponentState then\r\n Exit;\r\n if Assigned(FDropDownMenu) and (DropDownMenu.AutoPopup or Manual) then\r\n begin\r\n Form := GetParentForm(Self);\r\n if Form <> nil then\r\n Form.SendCancelMode(nil);\r\n DropDownMenu.PopupComponent := Self;\r\n Pt := ClientToScreen(SmallPointToPoint(Pos));\r\n DropDownMenu.Popup(Pt.X, Pt.Y);\r\n Result := True;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomSpeedButton.Click;\r\nvar\r\n Form: TCustomForm;\r\nbegin\r\n Form := GetParentForm(Self);\r\n if Form <> nil then\r\n Form.ModalResult := ModalResult;\r\n inherited Click;\r\nend;\r\n\r\nprocedure TJvCustomSpeedButton.CMButtonPressed(var Msg: TCMButtonPressed);\r\nvar\r\n Sender: TControl;\r\nbegin\r\n if (Msg.Index = FGroupIndex) and Parent.HandleAllocated then\r\n begin\r\n Sender := Msg.Control;\r\n if (Sender <> nil) and (Sender is TJvCustomSpeedButton) then\r\n if Sender <> Self then\r\n begin\r\n if TJvCustomSpeedButton(Sender).Down and FDown then\r\n begin\r\n FDown := False;\r\n FState := rbsUp;\r\n Repaint;\r\n end;\r\n FAllowAllUp := TJvCustomSpeedButton(Sender).AllowAllUp;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJvCustomSpeedButton.WantKey(Key: Integer; Shift: TShiftState): Boolean;\r\nbegin\r\n Result := IsAccel(Key, Caption) and Enabled and (ssAlt in Shift);\r\n if Result then\r\n Click\r\n else\r\n inherited WantKey(Key, Shift);\r\nend;\r\n\r\nprocedure TJvCustomSpeedButton.EnabledChanged;\r\nvar\r\n State: TJvButtonState;\r\nbegin\r\n inherited EnabledChanged;\r\n if Enabled then\r\n begin\r\n if Flat then\r\n State := rbsInactive\r\n else\r\n State := rbsUp;\r\n end\r\n else\r\n State := rbsDisabled;\r\n FGlyph.CreateButtonGlyph(State);\r\n { Resync MouseOver }\r\n UpdateTracking;\r\n Repaint;\r\nend;\r\n\r\nprocedure TJvCustomSpeedButton.FontChanged;\r\nbegin\r\n UpdateTrackFont(HotTrackFont, Font, HotTrackFontOptions);\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvCustomSpeedButton.MouseEnter(Control: TControl);\r\nvar\r\n NeedRepaint: Boolean;\r\nbegin\r\n if csDesigning in ComponentState then\r\n Exit;\r\n if not MouseOver and Enabled then\r\n begin\r\n { Don't draw a border if DragMode <> dmAutomatic since this button is meant to\r\n be used as a dock client. }\r\n NeedRepaint :=\r\n {$IFDEF JVCLThemesEnabled}\r\n ThemeServices.{$IFDEF RTL230_UP}Enabled{$ELSE}ThemesEnabled{$ENDIF RTL230_UP} or\r\n {$ENDIF JVCLThemesEnabled}\r\n FHotTrack or (FFlat and Enabled and (DragMode <> dmAutomatic) and (GetCapture = NullHandle));\r\n\r\n NeedRepaint := NeedRepaint and not Mouse.IsDragging;\r\n\r\n inherited MouseEnter(Control); // set MouseOver\r\n { Windows XP introduced hot states also for non-flat buttons. }\r\n if NeedRepaint then\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomSpeedButton.MouseLeave(Control: TControl);\r\nvar\r\n NeedRepaint: Boolean;\r\nbegin\r\n if MouseOver and Enabled then\r\n begin\r\n NeedRepaint :=\r\n {$IFDEF JVCLThemesEnabled}\r\n { Windows XP introduced hot states also for non-flat buttons. }\r\n ThemeServices.{$IFDEF RTL230_UP}Enabled{$ELSE}ThemesEnabled{$ENDIF RTL230_UP} or\r\n {$ENDIF JVCLThemesEnabled}\r\n HotTrack or (FFlat and Enabled and not FDragging and (GetCapture = NullHandle));\r\n\r\n NeedRepaint := NeedRepaint and not Mouse.IsDragging;\r\n\r\n inherited MouseLeave(Control); // set MouseOver\r\n if NeedRepaint then\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomSpeedButton.CMSysColorChange(var Msg: TMessage);\r\nbegin\r\n FGlyph.Invalidate;\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvCustomSpeedButton.TextChanged;\r\nbegin\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvCustomSpeedButton.VisibleChanged;\r\nbegin\r\n inherited VisibleChanged;\r\n if Visible then\r\n UpdateTracking;\r\nend;\r\n\r\nprocedure TJvCustomSpeedButton.DoMouseUp(Button: TMouseButton; Shift: TShiftState;\r\n X, Y: Integer);\r\nvar\r\n DoClick: Boolean;\r\nbegin\r\n if FDragging and (Button = mbLeft) then\r\n begin\r\n FDragging := False;\r\n DoClick := (X >= 0) and (X < ClientWidth) and (Y >= 0) and (Y <= ClientHeight);\r\n if FGroupIndex = 0 then\r\n begin\r\n FState := rbsUp;\r\n { Calling Click might open a new window or something which will remove\r\n the focus; if the new window is modal then UpdateTracking won't be\r\n called until the window is closed, thus: }\r\n MouseLeave(Self);\r\n Perform(CM_MOUSELEAVE, 0, 0);\r\n { Even if the mouse is not in the control (DoClick=False) we must redraw\r\n the image, because it must change from hot -> normal }\r\n //if not DoClick then\r\n Invalidate;\r\n end\r\n else\r\n if DoClick then\r\n begin\r\n SetDown(not FDown);\r\n if FDown then\r\n Repaint;\r\n end\r\n else\r\n begin\r\n if FDown then\r\n FState := rbsExclusive;\r\n Repaint;\r\n end;\r\n if DoClick and not FMenuTracking then\r\n begin\r\n Click;\r\n end;\r\n end;\r\n { After a Click call a lot can happen thus check whether we're hot or not: }\r\n UpdateTracking;\r\nend;\r\n\r\nfunction TJvCustomSpeedButton.GetAlignment: TAlignment;\r\nbegin\r\n Result := FGlyph.Alignment;\r\nend;\r\n\r\nfunction TJvCustomSpeedButton.GetDropDownMenuPos: TPoint;\r\nbegin\r\n if Assigned(FDropDownMenu) then\r\n begin\r\n if MenuPosition = dmpBottom then\r\n begin\r\n case FDropDownMenu.Alignment of\r\n paLeft:\r\n Result := Point(-1, Height);\r\n paRight:\r\n Result := Point(Width + 1, Height);\r\n else {paCenter}\r\n Result := Point(Width div 2, Height);\r\n end;\r\n end\r\n else { dmpRight }\r\n begin\r\n case FDropDownMenu.Alignment of\r\n paLeft:\r\n Result := Point(Width, -1);\r\n paRight:\r\n Result := Point(-1, -1);\r\n else {paCenter}\r\n Result := Point(Width div 2, Height);\r\n end;\r\n end;\r\n end\r\n else\r\n Result := Point(0, 0);\r\nend;\r\n\r\nfunction TJvCustomSpeedButton.GetGrayNewStyle: Boolean;\r\nbegin\r\n Result := FGlyph.GrayNewStyle;\r\nend;\r\n\r\nfunction TJvCustomSpeedButton.GetWordWrap: Boolean;\r\nbegin\r\n Result := FGlyph.WordWrap;\r\nend;\r\n\r\nprocedure TJvCustomSpeedButton.Loaded;\r\nvar\r\n LState: TJvButtonState;\r\nbegin\r\n inherited Loaded;\r\n\r\n if Enabled then\r\n begin\r\n if Flat then\r\n LState := rbsInactive\r\n else\r\n LState := rbsUp;\r\n end\r\n else\r\n LState := rbsDisabled;\r\n FGlyph.CreateButtonGlyph(LState);\r\nend;\r\n\r\nprocedure TJvCustomSpeedButton.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);\r\nvar\r\n P: TPoint;\r\n Msg: TMsg;\r\nbegin\r\n try\r\n if FMenuTracking then\r\n Exit;\r\n inherited MouseDown(Button, Shift, X, Y);\r\n if not MouseOver and Enabled then\r\n begin\r\n MouseOver := True;\r\n Invalidate {Repaint};\r\n end;\r\n if (Button = mbLeft) and Enabled {and not (ssDouble in Shift)} then\r\n begin\r\n if not FDown then\r\n begin\r\n FState := rbsDown;\r\n Invalidate {Repaint};\r\n end;\r\n FDragging := True;\r\n FMenuTracking := True;\r\n try\r\n P := GetDropDownMenuPos;\r\n if CheckMenuDropDown(PointToSmallPoint(P), False) then\r\n DoMouseUp(Button, Shift, X, Y);\r\n if PeekMessage(Msg, 0, 0, 0, PM_NOREMOVE) then\r\n begin\r\n if (Msg.Message = WM_LBUTTONDOWN) or (Msg.Message = WM_LBUTTONDBLCLK) then\r\n begin\r\n P := ScreenToClient(Msg.Pt);\r\n if (P.X >= 0) and (P.X < ClientWidth) and (P.Y >= 0) and (P.Y <= ClientHeight) then\r\n KillMessage(Windows.HWND_DESKTOP, Msg.Message);\r\n end;\r\n end;\r\n finally\r\n FMenuTracking := False;\r\n end;\r\n if FAllowTimer then\r\n begin\r\n if FRepeatTimer = nil then\r\n FRepeatTimer := TTimer.Create(Self);\r\n FRepeatTimer.Interval := InitPause;\r\n FRepeatTimer.OnTimer := TimerExpired;\r\n FRepeatTimer.Enabled := True;\r\n end;\r\n end;\r\n finally\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomSpeedButton.MouseMove(Shift: TShiftState; X, Y: Integer);\r\nvar\r\n NewState: TJvButtonState;\r\nbegin\r\n inherited MouseMove(Shift, X, Y);\r\n if FDragging then\r\n begin\r\n if not FDown then\r\n NewState := rbsUp\r\n else\r\n NewState := rbsExclusive;\r\n if (X >= 0) and (X < ClientWidth) and (Y >= 0) and (Y <= ClientHeight) then\r\n if FDown then\r\n NewState := rbsExclusive\r\n else\r\n NewState := rbsDown;\r\n if NewState <> FState then\r\n begin\r\n FState := NewState;\r\n Repaint;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomSpeedButton.MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);\r\nbegin\r\n inherited MouseUp(Button, Shift, X, Y);\r\n DoMouseUp(Button, Shift, X, Y);\r\n if FRepeatTimer <> nil then\r\n FRepeatTimer.Enabled := False;\r\nend;\r\n\r\nprocedure TJvCustomSpeedButton.Notification(AComponent: TComponent;\r\n Operation: TOperation);\r\nbegin\r\n inherited Notification(AComponent, Operation);\r\n if (AComponent = DropDownMenu) and (Operation = opRemove) then\r\n DropDownMenu := nil;\r\nend;\r\n\r\nprocedure TJvCustomSpeedButton.Paint;\r\nvar\r\n PaintRect: TRect;\r\n State: TJvButtonState;\r\n OldPenColor:TColor;\r\n Offset: TPoint;\r\n {$IFDEF JVCLThemesEnabled}\r\n Button: TThemedButton;\r\n ToolButton: TThemedToolBar;\r\n Details: TThemedElementDetails;\r\n {$ENDIF JVCLThemesEnabled}\r\nbegin\r\n if not Enabled {and not (csDesigning in ComponentState)} then\r\n begin\r\n FState := rbsDisabled;\r\n FDragging := False;\r\n end\r\n else\r\n if FState = rbsDisabled then\r\n if FDown and (GroupIndex <> 0) then\r\n FState := rbsExclusive\r\n else\r\n FState := rbsUp;\r\n\r\n if FFlat and not MouseOver and not (csDesigning in ComponentState) then\r\n { rbsInactive : flat and not 'mouse in control', thus\r\n - picture might be painted gray\r\n - no border, unless Button is exclusive\r\n }\r\n State := rbsInactive\r\n else\r\n State := FState;\r\n\r\n PaintRect := Rect(0, 0, Width, Height);\r\n\r\n {$IFDEF JVCLThemesEnabled}\r\n if ThemeServices.Enabled then\r\n begin\r\n if ControlInGlassPaint(Self) then\r\n FillRect(Canvas.Handle, ClientRect, GetStockObject(BLACK_BRUSH))\r\n else\r\n begin\r\n if FTransparent then\r\n CopyParentImage(Self, Canvas)\r\n else\r\n begin\r\n if not DoubleBuffered then\r\n PerformEraseBackground(Self, Canvas.Handle) // uses Control.Left/Top as Offset\r\n else\r\n PerformEraseBackground(Self, Canvas.Handle, Point(0, 0)); // we are drawing into a bitmap\r\n end;\r\n end;\r\n\r\n if (MouseOver or FDragging) and HotTrack then\r\n Canvas.Font := Self.HotTrackFont\r\n else\r\n Canvas.Font := Self.Font;\r\n\r\n if not Enabled then\r\n Button := tbPushButtonDisabled\r\n else\r\n if FState in [rbsDown, rbsExclusive] then\r\n Button := tbPushButtonPressed\r\n else\r\n if MouseOver or FDragging then\r\n Button := tbPushButtonHot\r\n else\r\n Button := tbPushButtonNormal;\r\n\r\n ToolButton := ttbToolbarDontCare;\r\n if FFlat then\r\n begin\r\n case Button of\r\n tbPushButtonDisabled:\r\n ToolButton := ttbButtonDisabled;\r\n tbPushButtonPressed:\r\n ToolButton := ttbButtonPressed;\r\n tbPushButtonHot:\r\n ToolButton := ttbButtonHot;\r\n tbPushButtonNormal:\r\n ToolButton := ttbButtonNormal;\r\n end;\r\n end;\r\n\r\n if ToolButton = ttbToolbarDontCare then\r\n begin\r\n Details := ThemeServices.GetElementDetails(Button);\r\n ThemeServices.DrawElement(Canvas.Handle, Details, PaintRect);\r\n ThemeServices.GetElementContentRect(Canvas.Handle, Details, PaintRect, PaintRect);\r\n end\r\n else\r\n begin\r\n Details := ThemeServices.GetElementDetails(ToolButton);\r\n ThemeServices.DrawElement(Canvas.Handle, Details, PaintRect);\r\n ThemeServices.GetElementContentRect(Canvas.Handle, Details, PaintRect, PaintRect);\r\n end;\r\n\r\n if (Button = tbPushButtonPressed) and Flat then\r\n // A pressed speed Button has a white text. This applies however only to flat buttons.\r\n //if ToolButton <> ttbToolbarDontCare then\r\n // Canvas.Font.Color := clHighlightText;\r\n Offset := Point(1, 0)\r\n else\r\n Offset := Point(0, 0);\r\n\r\n { Check whether the image need to be painted gray.. }\r\n if (FState = rbsDisabled) or not FInactiveGrayed then\r\n { .. do not paint gray image }\r\n State := FState;\r\n\r\n PaintImage(Canvas, PaintRect, Offset, State,\r\n FMarkDropDown and Assigned(FDropDownMenu), ControlInGlassPaint(Self));\r\n end\r\n else\r\n {$ENDIF JVCLThemesEnabled}\r\n begin\r\n if FTransparent then\r\n CopyParentImage(Self, Canvas)\r\n else\r\n begin\r\n if Flat then\r\n Canvas.Brush.Color := TWinControlAccess(Parent).Color\r\n else\r\n Canvas.Brush.Color := Self.Color;\r\n Canvas.Brush.Style := bsSolid;\r\n Canvas.FillRect(PaintRect);\r\n end;\r\n\r\n if (State <> rbsInactive) or (FState = rbsExclusive) then\r\n PaintRect := DrawButtonFrame(Canvas, PaintRect,\r\n FState in [rbsDown, rbsExclusive], FFlat, FStyle, Color)\r\n else\r\n if FFlat then\r\n InflateRect(PaintRect, -2, -2);\r\n\r\n if (FState = rbsExclusive) and not Transparent and\r\n (not FFlat or (State = rbsInactive)) then\r\n begin\r\n Canvas.Brush.Bitmap := AllocPatternBitmap(Self.Color, clBtnHighlight);\r\n InflateRect(PaintRect, 1, 1);\r\n Canvas.FillRect(PaintRect);\r\n InflateRect(PaintRect, -1, -1);\r\n end;\r\n if FState in [rbsDown, rbsExclusive] then\r\n Offset := Point(1, 1)\r\n else\r\n Offset := Point(0, 0);\r\n\r\n { Check whether the image need to be painted gray.. }\r\n if (FState = rbsDisabled) or not FInactiveGrayed then\r\n { .. do not paint gray image }\r\n State := FState;\r\n\r\n if ((HotTrackOptions.Enabled and Down) or (MouseOver or FDragging)) and HotTrack then\r\n begin\r\n Canvas.Font := Self.HotTrackFont;\r\n {Inserted by (ag) 2004-09-04}\r\n if HotTrackOptions.Enabled then\r\n begin\r\n if Down then //fixed bug: memory leak\r\n Canvas.Brush.Bitmap := GetBrushPattern(HotTrackOptions.Color, clWindow)\r\n else\r\n begin\r\n Canvas.Brush.Color := HotTrackOptions.Color;\r\n Canvas.Brush.Style := bsSolid;\r\n end;\r\n {Inserted by (dejoy) 2005-05-20}\r\n if HotTrackOptions.FrameVisible then\r\n begin\r\n OldPenColor := Canvas.Pen.Color;\r\n Canvas.Pen.Color := HotTrackOptions.FrameColor;\r\n Canvas.Rectangle(0, 0, Width, Height);\r\n Canvas.Pen.Color := OldPenColor;\r\n end\r\n else\r\n begin\r\n PaintRect := ClientRect;\r\n if Flat then\r\n InflateRect(PaintRect,-1,-1)\r\n else\r\n InflateRect(PaintRect,-1,-2);\r\n Canvas.FillRect(PaintRect);\r\n end;\r\n {Insert End by (dejoy)}\r\n if Down then\r\n Canvas.Brush.Bitmap := nil; // release bitmap\r\n end;\r\n {Insert End}\r\n end else\r\n Canvas.Font := Self.Font;\r\n PaintImage(Canvas, PaintRect, Offset, State,\r\n FMarkDropDown and Assigned(FDropDownMenu), ControlInGlassPaint(Self));\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomSpeedButton.Repaint;\r\nbegin\r\n if GetGlassPaintFlag(Self) then\r\n Invalidate\r\n else\r\n inherited;\r\nend;\r\n\r\nprocedure TJvCustomSpeedButton.SetAlignment(Value: TAlignment);\r\nbegin\r\n if Alignment <> Value then\r\n begin\r\n FGlyph.Alignment := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomSpeedButton.SetAllowAllUp(Value: Boolean);\r\nbegin\r\n if FAllowAllUp <> Value then\r\n begin\r\n FAllowAllUp := Value;\r\n UpdateExclusive;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomSpeedButton.SetAllowTimer(Value: Boolean);\r\nbegin\r\n FAllowTimer := Value;\r\n if not FAllowTimer and (FRepeatTimer <> nil) then\r\n begin\r\n FRepeatTimer.Enabled := False;\r\n FRepeatTimer.Free;\r\n FRepeatTimer := nil;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomSpeedButton.SetDown(Value: Boolean);\r\nbegin\r\n if FGroupIndex = 0 then\r\n Value := False;\r\n if Value <> FDown then\r\n begin\r\n if FDown and not FAllowAllUp then\r\n Exit;\r\n FDown := Value;\r\n if Value then\r\n begin\r\n if FState = rbsUp then\r\n Invalidate;\r\n FState := rbsExclusive;\r\n end\r\n else\r\n begin\r\n FState := rbsUp;\r\n end;\r\n Repaint;\r\n if Value then\r\n UpdateExclusive;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomSpeedButton.SetDropdownMenu(Value: TPopupMenu);\r\nbegin\r\n ReplaceComponentReference(Self, Value, TComponent(FDropDownMenu));\r\n if FMarkDropDown then\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvCustomSpeedButton.SetFlat(Value: Boolean);\r\nbegin\r\n if Value <> FFlat then\r\n begin\r\n FFlat := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomSpeedButton.SetGrayNewStyle(const Value: Boolean);\r\nbegin\r\n if GrayNewStyle <> Value then\r\n begin\r\n FGlyph.GrayNewStyle := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomSpeedButton.SetGroupIndex(Value: Integer);\r\nbegin\r\n if FGroupIndex <> Value then\r\n begin\r\n FGroupIndex := Value;\r\n UpdateExclusive;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomSpeedButton.SetHotTrackFont(Value: TFont);\r\nbegin\r\n if (FHotTrackFont<>Value) and (Value <> nil) then\r\n FHotTrackFont.Assign(Value);\r\nend;\r\n\r\nprocedure TJvCustomSpeedButton.SetHotTrackFontOptions(Value: TJvTrackFontOptions);\r\nbegin\r\n if FHotTrackFontOptions <> Value then\r\n begin\r\n FHotTrackFontOptions := Value;\r\n UpdateTrackFont(HotTrackFont, Font, FHotTrackFontOptions);\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomSpeedButton.SetHotTrackOptions(Value: TJvHotTrackOptions);\r\nbegin\r\n if (FHotTrackOptions <> Value) and (Value <> nil) then\r\n FHotTrackOptions.Assign(Value);\r\nend;\r\n\r\nprocedure TJvCustomSpeedButton.IJvHotTrack_Assign(\r\n Source: IJvHotTrack);\r\nbegin\r\n if (Source <> nil) and (IJvHotTrack(Self) <> Source) then\r\n begin\r\n HotTrack := Source.HotTrack;\r\n HotTrackFont :=Source.HotTrackFont;\r\n HotTrackFontOptions := Source.HotTrackFontOptions;\r\n HotTrackOptions := Source.HotTrackOptions;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomSpeedButton.SetInactiveGrayed(Value: Boolean);\r\nbegin\r\n if Value <> FInactiveGrayed then\r\n begin\r\n FInactiveGrayed := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomSpeedButton.SetLayout(Value: TButtonLayout);\r\nbegin\r\n if FLayout <> Value then\r\n begin\r\n FLayout := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomSpeedButton.SetMargin(Value: Integer);\r\nbegin\r\n if (Value <> FMargin) and (Value >= -1) then\r\n begin\r\n FMargin := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomSpeedButton.SetMarkDropDown(Value: Boolean);\r\nbegin\r\n if Value <> FMarkDropDown then\r\n begin\r\n FMarkDropDown := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomSpeedButton.SetSpacing(Value: Integer);\r\nbegin\r\n if Value <> FSpacing then\r\n begin\r\n FSpacing := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomSpeedButton.SetStyle(Value: TButtonStyle);\r\nbegin\r\n if Style <> Value then\r\n begin\r\n FStyle := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomSpeedButton.SetTransparent(Value: Boolean);\r\nbegin\r\n if Value <> FTransparent then\r\n begin\r\n FTransparent := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomSpeedButton.SetWordWrap(Value: Boolean);\r\nbegin\r\n if Value <> WordWrap then\r\n begin\r\n FGlyph.WordWrap := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nfunction TJvCustomSpeedButton.GetHotTrack: Boolean;\r\nbegin\r\n Result := FHotTrack;\r\nend;\r\n\r\nfunction TJvCustomSpeedButton.GetHotTrackFont: TFont;\r\nbegin\r\n Result := FHotTrackFont;\r\nend;\r\n\r\nfunction TJvCustomSpeedButton.GetHotTrackFontOptions: TJvTrackFontOptions;\r\nbegin\r\n Result := FHotTrackFontOptions;\r\nend;\r\n\r\nfunction TJvCustomSpeedButton.GetHotTrackOptions: TJvHotTrackOptions;\r\nbegin\r\n Result := FHotTrackOptions;\r\nend;\r\n\r\nprocedure TJvCustomSpeedButton.SetHotTrack(Value: Boolean);\r\nbegin\r\n if FHotTrack <> Value then\r\n begin\r\n FHotTrack := Value;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomSpeedButton.TimerExpired(Sender: TObject);\r\nbegin\r\n FRepeatTimer.Interval := RepeatInterval;\r\n if (FState = rbsDown) and MouseCapture then\r\n try\r\n Click;\r\n except\r\n FRepeatTimer.Enabled := False;\r\n raise;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomSpeedButton.UpdateExclusive;\r\nvar\r\n Msg: TCMButtonPressed;\r\nbegin\r\n if (FGroupIndex <> 0) and (Parent <> nil) then\r\n begin\r\n Msg.Msg := CM_JVBUTTONPRESSED;\r\n Msg.Index := FGroupIndex;\r\n Msg.Control := Self;\r\n Msg.Result := 0;\r\n Parent.Broadcast(Msg);\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomSpeedButton.UpdateTracking;\r\nvar\r\n P: TPoint;\r\n NewValue: Boolean;\r\nbegin\r\n GetCursorPos(P);\r\n NewValue := Enabled and (FindDragTarget(P, True) = Self) and IsForegroundTask;\r\n if MouseOver <> NewValue then\r\n if NewValue then\r\n Perform(CM_MOUSEENTER, 0, 0)\r\n else\r\n Perform(CM_MOUSELEAVE, 0, 0);\r\nend;\r\n\r\nprocedure TJvCustomSpeedButton.WMLButtonDblClk(var Msg: TWMLButtonDown);\r\nbegin\r\n if not FMenuTracking then\r\n begin\r\n inherited;\r\n if FDown then\r\n DblClick;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomSpeedButton.WMPaint(var Msg: TWMPaint);\r\nvar\r\n MemBitmap: HBitmap;\r\n SaveBitmap: HBitmap;\r\n MemDC: HDC;\r\n Index: Integer;\r\n DC: HDC;\r\nbegin\r\n if not DoubleBuffered or ControlInGlassPaint(Self) then\r\n inherited\r\n else\r\n if Msg.DC <> 0 then\r\n begin\r\n MemBitmap := CreateCompatibleBitmap(Msg.DC, Width, Height);\r\n MemDC := CreateCompatibleDC(Msg.DC);\r\n SaveBitmap := SelectObject(MemDC, MemBitmap);\r\n try\r\n DC := Msg.DC;\r\n Index := SaveDC(DC);\r\n try\r\n Msg.DC := MemDC;\r\n inherited;\r\n Msg.DC := DC;\r\n finally\r\n RestoreDC(Msg.DC, Index);\r\n end;\r\n BitBlt(Msg.DC, 0, 0, Width, Height, MemDC, 0, 0, SRCCOPY);\r\n finally\r\n SelectObject(MemDC, SaveBitmap);\r\n DeleteDC(MemDC);\r\n DeleteObject(MemBitmap);\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomSpeedButton.WMRButtonDown(var Msg: TWMRButtonDown);\r\nbegin\r\n inherited;\r\n UpdateTracking;\r\nend;\r\n\r\nprocedure TJvCustomSpeedButton.WMRButtonUp(var Msg: TWMRButtonUp);\r\nbegin\r\n inherited;\r\n UpdateTracking;\r\nend;\r\n\r\n//=== { TJvGlyphCache } ======================================================\r\n\r\nconstructor TJvGlyphCache.Create;\r\nbegin\r\n inherited Create;\r\n FGlyphLists := TList.Create;\r\nend;\r\n\r\ndestructor TJvGlyphCache.Destroy;\r\nbegin\r\n FGlyphLists.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJvGlyphCache.Empty: Boolean;\r\nbegin\r\n Result := FGlyphLists.Count = 0;\r\nend;\r\n\r\nfunction TJvGlyphCache.GetList(AWidth, AHeight: Integer): TJvGlyphList;\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := FGlyphLists.Count - 1 downto 0 do\r\n begin\r\n Result := TJvGlyphList(FGlyphLists[I]);\r\n with Result do\r\n if (AWidth = Width) and (AHeight = Height) then\r\n Exit;\r\n end;\r\n Result := TJvGlyphList.CreateSize(AWidth, AHeight);\r\n FGlyphLists.Add(Result);\r\nend;\r\n\r\nprocedure TJvGlyphCache.ReturnList(List: TJvGlyphList);\r\nbegin\r\n if List = nil then\r\n Exit;\r\n if List.Count = 0 then\r\n begin\r\n FGlyphLists.Remove(List);\r\n List.Free;\r\n end;\r\nend;\r\n\r\n//=== { TJvGlyphList } =======================================================\r\n\r\nfunction TJvGlyphList.Add(Image, Mask: TBitmap): Integer;\r\nbegin\r\n Result := AllocateIndex;\r\n Replace(Result, Image, Mask);\r\n Inc(FCount);\r\nend;\r\n\r\nfunction TJvGlyphList.AddMasked(Image: TBitmap; MaskColor: TColor): Integer;\r\nbegin\r\n Result := AllocateIndex;\r\n ReplaceMasked(Result, Image, MaskColor);\r\n Inc(FCount);\r\nend;\r\n\r\nfunction TJvGlyphList.AllocateIndex: Integer;\r\nbegin\r\n Result := FUsed.OpenBit;\r\n if Result >= FUsed.Size then\r\n begin\r\n Result := inherited Add(nil, nil);\r\n FUsed.Size := Result + 1;\r\n end;\r\n FUsed[Result] := True;\r\nend;\r\n\r\nconstructor TJvGlyphList.CreateSize(AWidth, AHeight: Integer);\r\nbegin\r\n inherited CreateSize(AWidth, AHeight);\r\n FUsed := TBits.Create;\r\nend;\r\n\r\nprocedure TJvGlyphList.Delete(Index: Integer);\r\nbegin\r\n if FUsed[Index] then\r\n begin\r\n Dec(FCount);\r\n FUsed[Index] := False;\r\n end;\r\nend;\r\n\r\ndestructor TJvGlyphList.Destroy;\r\nbegin\r\n FUsed.Free;\r\n inherited Destroy;\r\nend;\r\n\r\n//=== { TJvImageSpeedButton } ================================================\r\n\r\nprocedure TJvImageSpeedButton.ActionChange(Sender: TObject;\r\n CheckDefaults: Boolean);\r\nbegin\r\n inherited ActionChange(Sender, CheckDefaults);\r\n if Sender is TCustomAction then\r\n with TCustomAction(Sender) do\r\n begin\r\n if (not CheckDefaults or (Self.Images = nil)) and (ActionList <> nil) then\r\n Self.Images := TCustomImageList(ActionList.Images);\r\n if not CheckDefaults or (Self.ImageIndex = -1) then\r\n Self.ImageIndex := ImageIndex;\r\n end;\r\nend;\r\n\r\nconstructor TJvImageSpeedButton.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FImageChangeLink := TChangeLink.Create;\r\n FImageChangeLink.OnChange := ImageListChange;\r\n FImageIndex := -1;\r\nend;\r\n\r\ndestructor TJvImageSpeedButton.Destroy;\r\nbegin\r\n FreeAndNil(FImageChangeLink);\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJvImageSpeedButton.GetActionLinkClass: TControlActionLinkClass;\r\nbegin\r\n Result := TJvImageSpeedButtonActionLink;\r\nend;\r\n\r\nprocedure TJvImageSpeedButton.ImageListChange(Sender: TObject);\r\nbegin\r\n InvalidateImage;\r\nend;\r\n\r\nprocedure TJvImageSpeedButton.InvalidateImage;\r\nbegin\r\n Invalidate;\r\nend;\r\n\r\nfunction TJvImageSpeedButton.IsImageVisible: Boolean;\r\nbegin\r\n Result := {FImageVisible and} Assigned(FImages) and (FImageIndex >= 0)\r\nend;\r\n\r\nprocedure TJvImageSpeedButton.PaintImage(Canvas: TCanvas; ARect: TRect;\r\n const Offset: TPoint; AState: TJvButtonState; DrawMark: Boolean; PaintOnGlass: Boolean);\r\nvar\r\n LImageIndex: TImageIndex;\r\nbegin\r\n if (MouseOver or FDragging) and HotTrack and (HotTrackImageIndex <> -1) then\r\n LImageIndex := HotTrackImageIndex\r\n else\r\n LImageIndex := ImageIndex;\r\n FGlyph.DrawEx(Canvas, ARect, Offset, Caption, FLayout,\r\n FMargin, FSpacing, DrawMark, Images, LImageIndex, AState, DrawTextBiDiModeFlags(Alignments[Alignment]),\r\n PaintOnGlass);\r\nend;\r\n\r\nprocedure TJvImageSpeedButton.SetHotTrackImageIndex(\r\n const Value: TImageIndex);\r\nbegin\r\n if FHotTrackImageIndex <> Value then\r\n begin\r\n FHotTrackImageIndex := Value;\r\n { Only invalidate when hot }\r\n if (MouseOver or FDragging) and HotTrack then\r\n InvalidateImage;\r\n end;\r\nend;\r\n\r\nprocedure TJvImageSpeedButton.SetImageIndex(const Value: TImageIndex);\r\nbegin\r\n if FImageIndex <> Value then\r\n begin\r\n FImageIndex := Value;\r\n { Only invalidate when not hot }\r\n if not (MouseOver or FDragging) or not HotTrack then\r\n InvalidateImage;\r\n end;\r\nend;\r\n\r\nprocedure TJvImageSpeedButton.SetImages(const Value: TCustomImageList);\r\nbegin\r\n ReplaceImageListReference(Self, Value, FImages, FImageChangeLink);\r\n if FImages = nil then\r\n SetImageIndex(-1);\r\n InvalidateImage;\r\nend;\r\n\r\n//=== { TJvImageSpeedButtonActionLink } ======================================\r\n\r\nprocedure TJvImageSpeedButtonActionLink.AssignClient(AClient: TObject);\r\nbegin\r\n inherited AssignClient(AClient);\r\n FClient := AClient as TJvImageSpeedButton;\r\nend;\r\n\r\nfunction TJvImageSpeedButtonActionLink.IsCheckedLinked: Boolean;\r\nbegin\r\n Result := inherited IsCheckedLinked and (FClient.GroupIndex <> 0) and\r\n FClient.AllowAllUp and (FClient.Down = (Action as TCustomAction).Checked);\r\nend;\r\n\r\nfunction TJvImageSpeedButtonActionLink.IsGroupIndexLinked: Boolean;\r\nbegin\r\n { (rb) This will fail in D7 due to a bug in TCustomAction.SetGroupIndex }\r\n Result := (FClient is TJvCustomSpeedButton) and\r\n (FClient.GroupIndex = (Action as TCustomAction).GroupIndex);\r\nend;\r\n\r\nprocedure TJvImageSpeedButtonActionLink.SetGroupIndex(Value: Integer);\r\nbegin\r\n if IsGroupIndexLinked then\r\n FClient.GroupIndex := Value;\r\nend;\r\n\r\nfunction TJvImageSpeedButtonActionLink.IsImageIndexLinked: Boolean;\r\nbegin\r\n Result := inherited IsImageIndexLinked and\r\n (FClient.ImageIndex = (Action as TCustomAction).ImageIndex);\r\nend;\r\n\r\nprocedure TJvImageSpeedButtonActionLink.SetChecked(Value: Boolean);\r\nbegin\r\n if IsCheckedLinked then\r\n FClient.Down := Value;\r\nend;\r\n\r\nprocedure TJvImageSpeedButtonActionLink.SetImageIndex(Value: Integer);\r\nbegin\r\n if IsImageIndexLinked then\r\n FClient.ImageIndex := Value;\r\nend;\r\n\r\n//=== { TJvSpeedButton } =====================================================\r\n\r\nprocedure TJvSpeedButton.ActionChange(Sender: TObject; CheckDefaults: Boolean);\r\n\r\n procedure CopyImage(ImageList: TCustomImageList; Index: Integer);\r\n begin\r\n with Glyph do\r\n begin\r\n Width := ImageList.Width;\r\n Height := ImageList.Height;\r\n Canvas.Brush.Color := clFuchsia;\r\n Canvas.FillRect(Rect(0, 0, Width, Height));\r\n ImageList.Draw(Canvas, 0, 0, Index);\r\n TransparentColor := clFuchsia;\r\n FGlyphFromAction := True;\r\n end;\r\n end;\r\n\r\nbegin\r\n inherited ActionChange(Sender, CheckDefaults);\r\n if Sender is TCustomAction then\r\n with TCustomAction(Sender) do\r\n begin\r\n if CheckDefaults or (Self.GroupIndex = 0) then\r\n Self.GroupIndex := GroupIndex;\r\n { Copy image from action's imagelist }\r\n if (FGlyphFromAction or (Glyph.Empty)) and (ActionList <> nil) and (ActionList.Images <> nil) and\r\n (ImageIndex >= 0) and (ImageIndex < ActionList.Images.Count) then\r\n CopyImage(TCustomImageList(ActionList.Images), ImageIndex);\r\n end;\r\nend;\r\n\r\nconstructor TJvSpeedButton.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FGlyph.OnChange := GlyphChanged;\r\n FHotTrackGlyph := TJvxButtonGlyph.Create;\r\n FHotTrackGlyph.OnChange := HotTrackGlyphChanged;\r\nend;\r\n\r\ndestructor TJvSpeedButton.Destroy;\r\nbegin\r\n FHotTrackGlyph.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJvSpeedButton.GetActionLinkClass: TControlActionLinkClass;\r\nbegin\r\n Result := TJvSpeedButtonActionLink;\r\nend;\r\n\r\nfunction TJvSpeedButton.GetGlyph: TBitmap;\r\nbegin\r\n Result := FGlyph.Glyph;\r\nend;\r\n\r\nfunction TJvSpeedButton.GetHotTrackGlyph: TBitmap;\r\nbegin\r\n Result := FHotTrackGlyph.Glyph;\r\nend;\r\n\r\nfunction TJvSpeedButton.GetNumGlyphs: TJvNumGlyphs;\r\nbegin\r\n Result := FGlyph.NumGlyphs;\r\nend;\r\n\r\nfunction TJvSpeedButton.GetPalette: HPALETTE;\r\nbegin\r\n Result := Glyph.Palette;\r\nend;\r\n\r\nprocedure TJvSpeedButton.GlyphChanged(Sender: TObject);\r\nbegin\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvSpeedButton.HotTrackGlyphChanged(Sender: TObject);\r\nbegin\r\n Invalidate;\r\nend;\r\n\r\nfunction TJvSpeedButton.IsGlyphStored: Boolean;\r\nbegin\r\n Result := not FGlyphFromAction;\r\nend;\r\n\r\nprocedure TJvSpeedButton.PaintImage(Canvas: TCanvas; ARect: TRect; const Offset: TPoint;\r\n AState: TJvButtonState; DrawMark, PaintOnGlass: Boolean);\r\nbegin\r\n if (MouseOver or FDragging) and HotTrack and not HotTrackGlyph.Empty then\r\n begin\r\n SyncHotGlyph;\r\n FHotTrackGlyph.Draw(Canvas, ARect, Offset, Caption, FLayout,\r\n FMargin, FSpacing, DrawMark, AState, DrawTextBiDiModeFlags(Alignments[Alignment]),\r\n PaintOnGlass);\r\n end\r\n else\r\n FGlyph.Draw(Canvas, ARect, Offset, Caption, FLayout,\r\n FMargin, FSpacing, DrawMark, AState, DrawTextBiDiModeFlags(Alignments[Alignment]),\r\n PaintOnGlass);\r\nend;\r\n\r\nprocedure TJvSpeedButton.SetGlyph(Value: TBitmap);\r\nbegin\r\n FGlyph.Glyph := Value;\r\n FGlyphFromAction := False;\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvSpeedButton.SetHotTrackGlyph(const Value: TBitmap);\r\nbegin\r\n FHotTrackGlyph.Glyph := Value;\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvSpeedButton.SetNumGlyphs(Value: TJvNumGlyphs);\r\nbegin\r\n if Value < 0 then\r\n Value := 1\r\n else\r\n if Value > Ord(High(TJvButtonState)) + 1 then\r\n Value := Ord(High(TJvButtonState)) + 1;\r\n if Value <> FGlyph.NumGlyphs then\r\n begin\r\n FGlyph.NumGlyphs := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvSpeedButton.SyncHotGlyph;\r\nbegin\r\n with FHotTrackGlyph do\r\n begin\r\n OnChange := nil;\r\n try\r\n Alignment := FGlyph.Alignment;\r\n GrayNewStyle := FGlyph.GrayNewStyle;\r\n NumGlyphs := FGlyph.NumGlyphs;\r\n WordWrap := FGlyph.WordWrap;\r\n finally\r\n OnChange := HotTrackGlyphChanged;\r\n end;\r\n end;\r\nend;\r\n\r\n//=== { TJvSpeedButtonActionLink } ===========================================\r\n\r\nprocedure TJvSpeedButtonActionLink.AssignClient(AClient: TObject);\r\nbegin\r\n inherited AssignClient(AClient);\r\n FClient := AClient as TJvSpeedButton;\r\nend;\r\n\r\nfunction TJvSpeedButtonActionLink.IsCheckedLinked: Boolean;\r\nbegin\r\n Result := inherited IsCheckedLinked and (FClient.GroupIndex <> 0) and\r\n FClient.AllowAllUp and (FClient.Down = (Action as TCustomAction).Checked);\r\nend;\r\n\r\nfunction TJvSpeedButtonActionLink.IsGroupIndexLinked: Boolean;\r\nbegin\r\n Result := (FClient is TJvSpeedButton) and\r\n (TJvSpeedButton(FClient).GroupIndex = (Action as TCustomAction).GroupIndex);\r\nend;\r\n\r\nprocedure TJvSpeedButtonActionLink.SetGroupIndex(Value: Integer);\r\nbegin\r\n if IsGroupIndexLinked then\r\n TJvSpeedButton(FClient).GroupIndex := Value;\r\nend;\r\n\r\nprocedure TJvSpeedButtonActionLink.SetChecked(Value: Boolean);\r\nbegin\r\n if IsCheckedLinked then\r\n TJvSpeedButton(FClient).Down := Value;\r\nend;\r\n\r\n//=== { TJvxButtonGlyph } ====================================================\r\n\r\nprocedure TJvxButtonGlyph.CalcButtonLayout(Canvas: TCanvas; const Client: TRect; const AOffset: TPoint;\r\n var Caption: string; Layout: TButtonLayout; Margin, Spacing: Integer;\r\n PopupMark: Boolean; var GlyphPos: TPoint; var TextBounds: TRect;\r\n Flags: Word; Images: TCustomImageList; ImageIndex: Integer);\r\nvar\r\n TextPos: TPoint;\r\n MaxSize, ClientSize, GlyphSize, TextSize: TPoint;\r\n TotalSize: TPoint;\r\nbegin\r\n { calculate the item sizes }\r\n ClientSize := Point(Client.Right - Client.Left, Client.Bottom - Client.Top);\r\n if Assigned(Images) and (Images.Width > 0) and (ImageIndex >= 0) and\r\n (ImageIndex < Images.Count) then\r\n GlyphSize := Point(Images.Width, Images.Height)\r\n else\r\n if FOriginal <> nil then\r\n GlyphSize := Point(FOriginal.Width div FNumGlyphs, FOriginal.Height)\r\n else\r\n GlyphSize := Point(0, 0);\r\n\r\n if Layout in [blGlyphLeft, blGlyphRight] then\r\n begin\r\n MaxSize.X := ClientSize.X - GlyphSize.X;\r\n if Margin <> -1 then\r\n Dec(MaxSize.X, Margin);\r\n if Spacing <> -1 then\r\n Dec(MaxSize.X, Spacing);\r\n if PopupMark then\r\n Dec(MaxSize.X, 9);\r\n MaxSize.Y := ClientSize.Y;\r\n end\r\n else { blGlyphTop, blGlyphBottom }\r\n begin\r\n MaxSize.X := ClientSize.X;\r\n MaxSize.Y := ClientSize.Y - GlyphSize.Y;\r\n if Margin <> -1 then\r\n Dec(MaxSize.Y, Margin);\r\n if Spacing <> -1 then\r\n Dec(MaxSize.Y, Spacing);\r\n end;\r\n MaxSize.X := Max(0, MaxSize.X);\r\n MaxSize.Y := Max(0, MaxSize.Y);\r\n MinimizeCaption(Canvas, Caption, MaxSize.X);\r\n if Caption <> '' then\r\n begin\r\n TextBounds := Rect(0, 0, MaxSize.X, 0);\r\n DrawGlassableText(Canvas.Handle, Caption, TextBounds, DT_CALCRECT or DT_VCENTER or\r\n WordWraps[FWordWrap] or Flags);\r\n end\r\n else\r\n TextBounds := Rect(0, 0, 0, 0);\r\n TextBounds.Bottom := Max(TextBounds.Top, TextBounds.Top + Min(MaxSize.Y, RectHeight(TextBounds)));\r\n TextBounds.Right := Max(TextBounds.Left, TextBounds.Left + Min(MaxSize.X, RectWidth(TextBounds)));\r\n TextSize := Point(TextBounds.Right - TextBounds.Left, TextBounds.Bottom - TextBounds.Top);\r\n if PopupMark then\r\n if ((GlyphSize.X = 0) or (GlyphSize.Y = 0)) or (Layout = blGlyphLeft) then\r\n Inc(TextSize.X, 9)\r\n else\r\n if GlyphSize.X > 0 then\r\n Inc(GlyphSize.X, 6);\r\n\r\n { If the Layout has the glyph on the right or the left, then both the\r\n text and the glyph are centered vertically. If the glyph is on the top\r\n or the bottom, then both the text and the glyph are centered horizontally.}\r\n if Layout in [blGlyphLeft, blGlyphRight] then\r\n begin\r\n GlyphPos.Y := (ClientSize.Y - GlyphSize.Y) div 2;\r\n TextPos.Y := (ClientSize.Y - TextSize.Y) div 2;\r\n end\r\n else\r\n begin\r\n GlyphPos.X := (ClientSize.X - GlyphSize.X) div 2;\r\n TextPos.X := (ClientSize.X - TextSize.X) div 2;\r\n end;\r\n if Flags and DT_CENTER = 0 then\r\n begin\r\n if Flags and DT_RIGHT <> 0 then\r\n begin\r\n if Layout in [blGlyphLeft, blGlyphRight] then\r\n GlyphPos.X := ClientSize.X - GlyphSize.X - TextSize.X;\r\n TextPos.X := ClientSize.X - TextSize.X;\r\n end\r\n else\r\n begin\r\n if Layout in [blGlyphLeft, blGlyphRight] then\r\n begin\r\n GlyphPos.X := 0;\r\n TextPos.X := GlyphSize.X;\r\n end\r\n else\r\n TextPos.X := 0;\r\n end;\r\n end;\r\n\r\n { if there is no text or no bitmap, then Spacing is irrelevant }\r\n if (TextSize.X = 0) or (GlyphSize.X = 0) then\r\n Spacing := 0;\r\n { adjust Margin and Spacing }\r\n if Margin = -1 then\r\n begin\r\n if Spacing = -1 then\r\n begin\r\n TotalSize := Point(GlyphSize.X + TextSize.X, GlyphSize.Y + TextSize.Y);\r\n if Layout in [blGlyphLeft, blGlyphRight] then\r\n Margin := (ClientSize.X - TotalSize.X) div 3\r\n else\r\n Margin := (ClientSize.Y - TotalSize.Y) div 3;\r\n Spacing := Margin;\r\n end\r\n else\r\n begin\r\n TotalSize := Point(GlyphSize.X + Spacing + TextSize.X, GlyphSize.Y + Spacing + TextSize.Y);\r\n if (Layout in [blGlyphLeft, blGlyphRight]) then\r\n begin\r\n if Flags and DT_CENTER <> 0 then\r\n Margin := (ClientSize.X div 2) - (TotalSize.X div 2)\r\n else\r\n begin\r\n if Layout = blGlyphRight then\r\n begin\r\n Margin := 0;\r\n if Flags and DT_RIGHT = 0 then\r\n Margin := ClientSize.X - TextSize.X - GlyphSize.X\r\n end\r\n else\r\n Margin := GlyphPos.X;\r\n end;\r\n end\r\n else\r\n Margin := (ClientSize.Y div 2) - (TotalSize.Y div 2);\r\n end;\r\n end\r\n else\r\n begin\r\n if Spacing = -1 then\r\n begin\r\n TotalSize := Point(ClientSize.X - (Margin + GlyphSize.X), ClientSize.Y - (Margin + GlyphSize.Y));\r\n if Layout in [blGlyphLeft, blGlyphRight] then\r\n Spacing := (TotalSize.X div 2) - (TextSize.X div 2)\r\n else\r\n Spacing := (TotalSize.Y div 2) - (TextSize.Y div 2);\r\n end;\r\n end;\r\n case Layout of\r\n blGlyphLeft:\r\n begin\r\n GlyphPos.X := Margin;\r\n TextPos.X := GlyphPos.X + GlyphSize.X + Spacing;\r\n end;\r\n blGlyphRight:\r\n begin\r\n GlyphPos.X := ClientSize.X - Margin - GlyphSize.X;\r\n TextPos.X := GlyphPos.X - Spacing - TextSize.X;\r\n end;\r\n blGlyphTop:\r\n begin\r\n GlyphPos.Y := Margin;\r\n TextPos.Y := GlyphPos.Y + GlyphSize.Y + Spacing;\r\n end;\r\n blGlyphBottom:\r\n begin\r\n GlyphPos.Y := ClientSize.Y - Margin - GlyphSize.Y;\r\n TextPos.Y := GlyphPos.Y - Spacing - TextSize.Y;\r\n end;\r\n end;\r\n\r\n { fixup the result variables }\r\n Inc(GlyphPos.X, Client.Left + AOffset.X);\r\n Inc(GlyphPos.Y, Client.Top + AOffset.Y);\r\n\r\n OffsetRect(TextBounds, TextPos.X + Client.Left + AOffset.X, TextPos.Y + Client.Top + AOffset.Y);\r\nend;\r\n\r\nconstructor TJvxButtonGlyph.Create;\r\nvar\r\n I: TJvButtonState;\r\nbegin\r\n inherited Create;\r\n FOriginal := TBitmap.Create;\r\n FOriginal.OnChange := GlyphChanged;\r\n FTransparentColor := clFuchsia;\r\n FAlignment := taCenter;\r\n FNumGlyphs := 1;\r\n for I := Low(I) to High(I) do\r\n FIndexs[I] := -1;\r\n if GlyphCache = nil then\r\n GlyphCache := TJvGlyphCache.Create;\r\nend;\r\n\r\nfunction TJvxButtonGlyph.CreateButtonGlyph(State: TJvButtonState): Integer;\r\nvar\r\n TmpImage, MonoBmp: TBitmap;\r\n iWidth, iHeight, X, Y: Integer;\r\n IRect, ORect: TRect;\r\n I: TJvButtonState;\r\nbegin\r\n if (State = rbsDown) and (NumGlyphs < 3) then\r\n State := rbsUp;\r\n Result := FIndexs[State];\r\n if (Result <> -1) or (FOriginal.Width = 0) or (FOriginal.Height = 0) or\r\n FOriginal.Empty then\r\n Exit;\r\n iWidth := FOriginal.Width div FNumGlyphs;\r\n iHeight := FOriginal.Height;\r\n if FGlyphList = nil then\r\n begin\r\n if GlyphCache = nil then\r\n GlyphCache := TJvGlyphCache.Create;\r\n FGlyphList := GlyphCache.GetList(iWidth, iHeight);\r\n end;\r\n TmpImage := TBitmap.Create;\r\n try\r\n TmpImage.Width := iWidth;\r\n TmpImage.Height := iHeight;\r\n IRect := Rect(0, 0, iWidth, iHeight);\r\n TmpImage.Canvas.Brush.Color := clBtnFace;\r\n I := State;\r\n if Ord(I) >= NumGlyphs then\r\n I := rbsUp;\r\n ORect := Rect(Ord(I) * iWidth, 0, (Ord(I) + 1) * iWidth, iHeight);\r\n case State of\r\n rbsUp, rbsDown, rbsExclusive:\r\n begin\r\n TmpImage.Canvas.CopyRect(IRect, FOriginal.Canvas, ORect);\r\n FIndexs[State] := TJvGlyphList(FGlyphList).AddMasked(TmpImage,\r\n FTransparentColor);\r\n end;\r\n rbsDisabled:\r\n if NumGlyphs > 1 then\r\n begin\r\n TmpImage.Canvas.CopyRect(IRect, FOriginal.Canvas, ORect);\r\n FIndexs[State] := TJvGlyphList(FGlyphList).AddMasked(TmpImage,\r\n FTransparentColor);\r\n end\r\n else\r\n begin\r\n if FGrayNewStyle then\r\n begin\r\n MonoBmp := CreateDisabledBitmap_NewStyle(FOriginal, FTransparentColor);\r\n try\r\n FIndexs[State] := TJvGlyphList(FGlyphList).AddMasked(MonoBmp,\r\n FTransparentColor);\r\n finally\r\n MonoBmp.Free;\r\n end;\r\n end\r\n else\r\n begin\r\n MonoBmp := CreateDisabledBitmap(FOriginal, clBlack);\r\n try\r\n FIndexs[State] := TJvGlyphList(FGlyphList).AddMasked(MonoBmp,\r\n ColorToRGB(clBtnFace));\r\n finally\r\n MonoBmp.Free;\r\n end;\r\n end;\r\n end;\r\n rbsInactive:\r\n if NumGlyphs > 4 then\r\n begin\r\n TmpImage.Canvas.CopyRect(IRect, FOriginal.Canvas, ORect);\r\n FIndexs[State] := TJvGlyphList(FGlyphList).AddMasked(TmpImage,\r\n FTransparentColor);\r\n end\r\n else\r\n begin\r\n with TmpImage do\r\n for X := 0 to Width - 1 do\r\n for Y := 0 to Height - 1 do\r\n Canvas.Pixels[X, Y] := MapColor(FOriginal.Canvas.Pixels[X, Y]);\r\n FIndexs[State] := TJvGlyphList(FGlyphList).AddMasked(TmpImage,\r\n FTransparentColor);\r\n end;\r\n end;\r\n finally\r\n TmpImage.Free;\r\n end;\r\n Result := FIndexs[State];\r\n FOriginal.Dormant;\r\nend;\r\n\r\nfunction TJvxButtonGlyph.CreateImageGlyph(State: TJvButtonState;\r\n Images: TCustomImageList; Index: Integer): Integer;\r\nvar\r\n TmpImage, Mask: TBitmap;\r\n iWidth, iHeight, X, Y: Integer;\r\nbegin\r\n if State = rbsDown then\r\n State := rbsUp;\r\n Result := FIndexs[State];\r\n if (Result <> -1) or (Images.Width = 0) or (Images.Height = 0) or\r\n (Images.Count = 0) then\r\n Exit;\r\n iWidth := Images.Width;\r\n iHeight := Images.Height;\r\n if FGlyphList = nil then\r\n begin\r\n if GlyphCache = nil then\r\n GlyphCache := TJvGlyphCache.Create;\r\n FGlyphList := GlyphCache.GetList(iWidth, iHeight);\r\n end;\r\n TmpImage := TBitmap.Create;\r\n try\r\n TmpImage.Width := iWidth;\r\n TmpImage.Height := iHeight;\r\n case State of\r\n rbsUp, rbsDown, rbsExclusive:\r\n begin\r\n with TmpImage.Canvas do\r\n begin\r\n FillRect(Rect(0, 0, iWidth, iHeight));\r\n ImageList_Draw(Images.Handle, Index, Handle, 0, 0, ILD_NORMAL);\r\n end;\r\n Mask := TBitmap.Create;\r\n try\r\n with Mask do\r\n begin\r\n Monochrome := True;\r\n Height := iHeight;\r\n Width := iWidth;\r\n end;\r\n with Mask.Canvas do\r\n begin\r\n FillRect(Rect(0, 0, iWidth, iHeight));\r\n ImageList_Draw(Images.Handle, Index, Handle, 0, 0, ILD_MASK);\r\n end;\r\n FIndexs[State] := TJvGlyphList(FGlyphList).Add(TmpImage, Mask);\r\n finally\r\n Mask.Free;\r\n end;\r\n end;\r\n rbsDisabled:\r\n begin\r\n TmpImage.Canvas.Brush.Color := clBtnFace;\r\n TmpImage.Canvas.FillRect(Rect(0, 0, iWidth, iHeight));\r\n ImageListDrawDisabled(Images, TmpImage.Canvas, 0, 0, Index,\r\n clBtnHighlight, clBtnShadow, True);\r\n FIndexs[State] := TJvGlyphList(FGlyphList).AddMasked(TmpImage,\r\n ColorToRGB(clBtnFace));\r\n end;\r\n rbsInactive:\r\n begin\r\n TmpImage.Canvas.Brush.Color := clBtnFace;\r\n TmpImage.Canvas.FillRect(Rect(0, 0, iWidth, iHeight));\r\n ImageList_Draw(Images.Handle, Index, TmpImage.Canvas.Handle, 0, 0, ILD_NORMAL);\r\n with TmpImage do\r\n begin\r\n for X := 0 to Width - 1 do\r\n for Y := 0 to Height - 1 do\r\n Canvas.Pixels[X, Y] := MapColor(Canvas.Pixels[X, Y]);\r\n end;\r\n FIndexs[State] := TJvGlyphList(FGlyphList).AddMasked(TmpImage,\r\n ColorToRGB(clBtnFace));\r\n end;\r\n end;\r\n finally\r\n TmpImage.Free;\r\n end;\r\n Result := FIndexs[State];\r\nend;\r\n\r\ndestructor TJvxButtonGlyph.Destroy;\r\nbegin\r\n FOriginal.Free;\r\n Invalidate;\r\n if Assigned(GlyphCache) and GlyphCache.Empty then\r\n begin\r\n GlyphCache.Free;\r\n GlyphCache := nil;\r\n end;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJvxButtonGlyph.Draw(Canvas: TCanvas; const Client: TRect;\r\n const Offset: TPoint;\r\n const Caption: string; Layout: TButtonLayout; Margin, Spacing: Integer;\r\n PopupMark: Boolean; State: TJvButtonState; Flags: Word; PaintOnGlass: Boolean): TRect;\r\nbegin\r\n Result := DrawEx(Canvas, Client, Offset, Caption, Layout, Margin, Spacing,\r\n PopupMark, nil, -1, State, Flags, PaintOnGlass);\r\nend;\r\n\r\nfunction TJvxButtonGlyph.DrawButtonGlyph(Canvas: TCanvas; X, Y: Integer;\r\n State: TJvButtonState): TPoint;\r\nvar\r\n Index: Integer;\r\nbegin\r\n Result := Point(0, 0);\r\n if (FOriginal = nil) or (FOriginal.Width = 0) or (FOriginal.Height = 0) or\r\n FOriginal.Empty then\r\n Exit;\r\n Index := CreateButtonGlyph(State);\r\n if Index >= 0 then\r\n begin\r\n DrawGlassableImageList(FGlyphList.Handle, Index, Canvas.Handle, X, Y, ILD_NORMAL, FPaintOnGlass);\r\n Result := Point(FGlyphList.Width, FGlyphList.Height);\r\n end;\r\nend;\r\n\r\nfunction TJvxButtonGlyph.DrawButtonImage(Canvas: TCanvas; X, Y: Integer;\r\n Images: TCustomImageList; ImageIndex: Integer; State: TJvButtonState): TPoint;\r\nvar\r\n Index: Integer;\r\nbegin\r\n Result := Point(0, 0);\r\n if (Images = nil) or (ImageIndex < 0) or (ImageIndex >= Images.Count) then\r\n Exit;\r\n\r\n if State = rbsDisabled then\r\n begin\r\n if GrayNewStyle then\r\n Images.Draw(Canvas, X, Y, ImageIndex, False)\r\n else\r\n ImageListDrawDisabled(Images, Canvas, X, Y, ImageIndex, clBtnHighlight,\r\n clBtnShadow, True);\r\n end\r\n else\r\n if State = rbsInactive then\r\n begin\r\n Index := CreateImageGlyph(State, Images, ImageIndex);\r\n if Index >= 0 then\r\n ImageList_Draw(FGlyphList.Handle, Index, Canvas.Handle, X, Y, ILD_NORMAL);\r\n end\r\n else\r\n ImageList_Draw(Images.Handle, ImageIndex, Canvas.Handle, X, Y, ILD_NORMAL);\r\n Result := Point(Images.Width, Images.Height);\r\nend;\r\n\r\nprocedure TJvxButtonGlyph.DrawButtonText(Canvas: TCanvas; const Caption: string;\r\n TextBounds: TRect; State: TJvButtonState; Flags: Word);\r\nvar\r\n DC: HDC;\r\nbegin\r\n Canvas.Brush.Style := bsClear;\r\n Flags := DT_VCENTER or WordWraps[FWordWrap] or Flags;\r\n DC := Canvas.Handle;\r\n if State = rbsDisabled then\r\n begin\r\n OffsetRect(TextBounds, 1, 1);\r\n SetTextColor(DC, ColorToRGB(clBtnHighlight));\r\n DrawGlassableText(DC, Caption, TextBounds, Flags, FPaintOnGlass);\r\n OffsetRect(TextBounds, -1, -1);\r\n SetTextColor(DC, ColorToRGB(clBtnShadow));\r\n DrawGlassableText(DC, Caption, TextBounds, Flags, FPaintOnGlass);\r\n end\r\n else\r\n DrawGlassableText(DC, Caption, TextBounds, Flags, FPaintOnGlass);\r\nend;\r\n\r\nfunction TJvxButtonGlyph.DrawEx(Canvas: TCanvas; const Client: TRect;\r\n const Offset: TPoint;\r\n const Caption: string; Layout: TButtonLayout; Margin, Spacing: Integer;\r\n PopupMark: Boolean; Images: TCustomImageList; ImageIndex: Integer;\r\n State: TJvButtonState; Flags: Word; PaintOnGlass: Boolean): TRect;\r\nvar\r\n UseImages: Boolean;\r\n GlyphPos, PopupPos: TPoint;\r\n TextBounds: TRect;\r\n LCaption: string;\r\nbegin\r\n FPaintOnGlass := PaintOnGlass;\r\n { MinimizeCaption might change the caption }\r\n LCaption := Caption;\r\n CalcButtonLayout(Canvas, Client, Offset, LCaption, Layout, Margin, Spacing,\r\n PopupMark, GlyphPos, TextBounds, Flags, Images, ImageIndex);\r\n UseImages := False;\r\n if Assigned(Images) and (ImageIndex >= 0) and (ImageIndex < Images.Count) and\r\n (Images.Width > 0) then\r\n begin\r\n UseImages := True;\r\n PopupPos := DrawButtonImage(Canvas, GlyphPos.X, GlyphPos.Y, Images,\r\n ImageIndex, State);\r\n end\r\n else\r\n PopupPos := DrawButtonGlyph(Canvas, GlyphPos.X, GlyphPos.Y, State);\r\n DrawButtonText(Canvas, LCaption, TextBounds, State, Flags);\r\n if PopupMark then\r\n if (Layout <> blGlyphLeft) and (((FOriginal <> nil) and\r\n (FOriginal.Width > 0)) or UseImages) then\r\n begin\r\n PopupPos.X := GlyphPos.X + PopupPos.X + 1;\r\n PopupPos.Y := GlyphPos.Y + PopupPos.Y div 2;\r\n DrawPopupMark(Canvas, PopupPos.X, PopupPos.Y, State);\r\n end\r\n else\r\n begin\r\n if LCaption <> '' then\r\n PopupPos.X := TextBounds.Right + 3\r\n else\r\n PopupPos.X := (Client.Left + Client.Right - 7) div 2;\r\n PopupPos.Y := TextBounds.Top + RectHeight(TextBounds) div 2;\r\n DrawPopupMark(Canvas, PopupPos.X, PopupPos.Y, State);\r\n end;\r\n Result := TextBounds;\r\nend;\r\n\r\nprocedure TJvxButtonGlyph.DrawPopupMark(Canvas: TCanvas; X, Y: Integer;\r\n State: TJvButtonState);\r\nvar\r\n AColor: TColor;\r\n\r\n procedure DrawMark;\r\n var\r\n I: Integer;\r\n begin\r\n with Canvas do\r\n begin\r\n for I := 0 to 6 do\r\n begin\r\n Pixels[X + I, Y - 1] := AColor;\r\n if (I > 0) and (I < 6) then\r\n begin\r\n Pixels[X + I, Y] := AColor;\r\n if (I > 1) and (I < 5) then\r\n Pixels[X + I, Y + 1] := AColor;\r\n end;\r\n end;\r\n Pixels[X + 3, Y + 2] := AColor;\r\n end;\r\n end;\r\n\r\nbegin\r\n if State = rbsDisabled then\r\n begin\r\n AColor := clBtnHighlight;\r\n Inc(X, 1);\r\n Inc(Y, 1);\r\n DrawMark;\r\n Dec(X, 1);\r\n Dec(Y, 1);\r\n AColor := clBtnShadow;\r\n end\r\n else\r\n AColor := clBtnText;\r\n DrawMark;\r\nend;\r\n\r\nprocedure TJvxButtonGlyph.GlyphChanged(Sender: TObject);\r\nvar\r\n Glyphs: Integer;\r\nbegin\r\n if Sender = FOriginal then\r\n begin\r\n Invalidate;\r\n if (FOriginal <> nil) and (FOriginal.Height > 0) then\r\n begin\r\n FTransparentColor := FOriginal.TransparentColor and not PaletteMask;\r\n if FOriginal.Width mod FOriginal.Height = 0 then\r\n begin\r\n Glyphs := FOriginal.Width div FOriginal.Height;\r\n if Glyphs > (Ord(High(TJvButtonState)) + 1) then\r\n Glyphs := 1;\r\n SetNumGlyphs(Glyphs);\r\n end;\r\n end;\r\n if Assigned(FOnChange) then\r\n FOnChange(Self);\r\n end;\r\nend;\r\n\r\nprocedure TJvxButtonGlyph.Invalidate;\r\nvar\r\n I: TJvButtonState;\r\nbegin\r\n for I := Low(I) to High(I) do\r\n begin\r\n if Assigned(FGlyphList) then\r\n if FIndexs[I] <> -1 then\r\n TJvGlyphList(FGlyphList).Delete(FIndexs[I]);\r\n FIndexs[I] := -1;\r\n end;\r\n\r\n { Fix for Mantis #4864: JvSpeedButton AV }\r\n if GlyphCache <> nil then\r\n GlyphCache.ReturnList(TJvGlyphList(FGlyphList))\r\n else\r\n FGlyphList.Free;\r\n FGlyphList := nil;\r\nend;\r\n\r\nfunction TJvxButtonGlyph.MapColor(Color: TColor): TColor;\r\nvar\r\n Index: Byte;\r\nbegin\r\n if (Color = FTransparentColor) or (ColorToRGB(Color) = ColorToRGB(clBtnFace)) then\r\n Result := Color\r\n else\r\n begin\r\n Color := ColorToRGB(Color);\r\n Index := Byte(Longint(Word(GetRValue(Color)) * 77 +\r\n Word(GetGValue(Color)) * 150 + Word(GetBValue(Color)) * 29) shr 8);\r\n Result := RGB(Index, Index, Index);\r\n end;\r\nend;\r\n\r\nprocedure TJvxButtonGlyph.MinimizeCaption(Canvas: TCanvas; var Caption: string;\r\n Width: Integer);\r\nvar\r\n I: Integer;\r\n Lines: TStringList;\r\nbegin\r\n if FWordWrap then\r\n Exit;\r\n Lines := TStringList.Create;\r\n try\r\n Lines.Text := Caption;\r\n for I := 0 to Lines.Count - 1 do\r\n Lines[I] := MinimizeText(Lines[I], Canvas, Width);\r\n Caption := TrimRight(Lines.Text);\r\n finally\r\n Lines.Free;\r\n end;\r\nend;\r\n\r\nprocedure TJvxButtonGlyph.SetGlyph(Value: TBitmap);\r\nbegin\r\n Invalidate;\r\n FOriginal.Assign(Value);\r\nend;\r\n\r\nprocedure TJvxButtonGlyph.SetGrayNewStyle(const Value: Boolean);\r\nbegin\r\n if Value <> FGrayNewStyle then\r\n begin\r\n Invalidate;\r\n FGrayNewStyle := Value;\r\n end;\r\nend;\r\n\r\nprocedure TJvxButtonGlyph.SetNumGlyphs(Value: TJvNumGlyphs);\r\nbegin\r\n if (Value <> FNumGlyphs) and (Value > 0) then\r\n begin\r\n Invalidate;\r\n FNumGlyphs := Value;\r\n end;\r\nend;\r\n\r\ninitialization\r\n {$IFDEF UNITVERSIONING}\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n {$ENDIF UNITVERSIONING}\r\n\r\nfinalization\r\n {$IFDEF UNITVERSIONING}\r\n UnregisterUnitVersion(HInstance);\r\n {$ENDIF UNITVERSIONING}\r\n FreeAndNil(GlyphCache);\r\n FreeAndNil(TempBrushBitmap);\r\n\r\nend.\r\n\r\n" }, { "path": "External/Jedi/Jvcl/run/JvSpeedbar.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvSpeedBar.PAS, released on 2002-07-04.\r\n\r\nThe Initial Developers of the Original Code are: Fedor Koshevnikov, Igor Pavluk and Serge Korolev\r\nCopyright (c) 1997, 1998 Fedor Koshevnikov, Igor Pavluk and Serge Korolev\r\nCopyright (c) 2001,2002 SGB Software\r\nAll Rights Reserved.\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvSpeedbar.pas 13415 2012-09-10 09:51:54Z obones $\r\n\r\nunit JvSpeedbar;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n SysUtils, Classes,\r\n Windows, Messages, Menus, Buttons, Controls,\r\n Graphics, Forms, ImgList, ExtCtrls, Grids,\r\n RTLConsts,\r\n {$IFDEF HAS_UNIT_SYSTEM_UITYPES}\r\n System.UITypes,\r\n {$ENDIF HAS_UNIT_SYSTEM_UITYPES}\r\n JclBase,\r\n JvSpeedButton, JvAppStorage, JvConsts, JvTypes, JvFormPlacement,\r\n JvComponent, JvExtComponent, JvThemes, JvExControls;\r\n\r\nconst\r\n DefButtonWidth = 24;\r\n DefButtonHeight = 23;\r\n\r\ntype\r\n TJvSpeedItem = class;\r\n TJvSpeedBarSection = class;\r\n EJvSpeedbarError = class(EJVCLException);\r\n\r\n TBarOrientation = (boHorizontal, boVertical);\r\n TBarPosition = (bpAuto, bpCustom);\r\n TJvSpeedBarOption = (sbAllowDrag, sbAllowResize, sbFlatBtns, sbGrayedBtns,\r\n sbTransparentBtns, sbStretchBitmap);\r\n TJvSpeedBarOptions = set of TJvSpeedBarOption;\r\n TBoundLine = (blTop, blBottom, blLeft, blRight);\r\n TBoundLines = set of TBoundLine;\r\n TSbScaleFlags = set of (sfOffsetX, sfOffsetY, sfBtnSizeX, sfBtnSizeY);\r\n TForEachItem = procedure(Item: TJvSpeedItem; Data: SizeInt) of object;\r\n TApplyAlignEvent = procedure(Sender: TObject; Align: TAlign;\r\n var Apply: Boolean) of object;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvSpeedBar = class(TJvCustomPanel, IJvDenySubClassing)\r\n private\r\n FSections: TList;\r\n FPosition: TBarPosition;\r\n FOrientation: TBarOrientation;\r\n FAlign: TAlign;\r\n FButtonSize: TPoint;\r\n FButtonStyle: TButtonStyle;\r\n FGridSize: TPoint;\r\n FOffset: TPoint;\r\n FEditWin: THandle;\r\n FRowCount: Integer;\r\n FPrevRect: TRect;\r\n FPrevAlign: TAlign;\r\n FOptions: TJvSpeedBarOptions;\r\n FLocked: Boolean;\r\n FVersion: Integer;\r\n FDrag: Boolean;\r\n FResizing: Boolean;\r\n FStartDrag: TPoint;\r\n FWallpaper: TPicture;\r\n FBoundLines: TBoundLines;\r\n FIniLink: TJvIniLink;\r\n FReserved: Integer;\r\n FFix: Boolean;\r\n FDesignStyle: Boolean;\r\n FScaleFlags: TSbScaleFlags;\r\n FOnAddItem: TNotifyEvent;\r\n FOnApplyAlign: TApplyAlignEvent;\r\n FOnPosChanged: TNotifyEvent;\r\n FOnVisibleChanged: TNotifyEvent;\r\n FOnCustomize: TNotifyEvent;\r\n FImages: TCustomImageList;\r\n FImageChangeLink: TChangeLink;\r\n procedure ImageListChange(Sender: TObject);\r\n procedure SetImages(Value: TCustomImageList);\r\n procedure InvalidateItem(Item: TJvSpeedItem; Data: SizeInt);\r\n function GetOrientation: TBarOrientation;\r\n procedure SetOrientation(Value: TBarOrientation);\r\n procedure ApplyOrientation(Value: TBarOrientation);\r\n procedure ApplyButtonSize;\r\n procedure UpdateGridSize;\r\n procedure ClearSections;\r\n function GetAlign: TAlign;\r\n procedure SetAlign(Value: TAlign);\r\n function GetButtonSize(Index: Integer): Integer;\r\n procedure SetButtonSize(Index, Value: Integer);\r\n function GetButtonsOffset(Index: Integer): Integer;\r\n procedure SetButtonsOffset(Index: Integer; Value: Integer);\r\n procedure SetOptions(Value: TJvSpeedBarOptions);\r\n procedure SetBoundLines(Value: TBoundLines);\r\n function MinButtonsOffset: Integer;\r\n procedure WallpaperChanged(Sender: TObject);\r\n procedure SetWallpaper(Value: TPicture);\r\n procedure SetItemParams(Item: TJvSpeedItem; InitBounds: Boolean);\r\n procedure SetItemVisible(Item: TJvSpeedItem; Data: SizeInt);\r\n procedure SetItemEnabled(Item: TJvSpeedItem; Data: SizeInt);\r\n procedure SetItemButtonSize(Item: TJvSpeedItem; Data: SizeInt);\r\n procedure OffsetItem(Item: TJvSpeedItem; Data: SizeInt);\r\n procedure ApplyItemSize(Item: TJvSpeedItem; Data: SizeInt);\r\n procedure AlignItemToGrid(Item: TJvSpeedItem; Data: SizeInt);\r\n procedure SwapItemBounds(Item: TJvSpeedItem; Data: SizeInt);\r\n procedure SetItemEditing(Item: TJvSpeedItem; Data: SizeInt);\r\n procedure HideItem(Item: TJvSpeedItem; Data: SizeInt);\r\n procedure WriteItemLayout(Item: TJvSpeedItem; Data: SizeInt);\r\n procedure FlatItem(Item: TJvSpeedItem; Data: SizeInt);\r\n procedure TransparentItem(Item: TJvSpeedItem; Data: SizeInt);\r\n function GetSection(Index: Integer): TJvSpeedBarSection;\r\n function GetSectionCount: Integer;\r\n procedure GrayedItem(Item: TJvSpeedItem; Data: SizeInt);\r\n function GetFramePos(X, Y: Integer; var Apply: Boolean): Integer;\r\n function GetFrameRect(X, Y: Integer): TRect;\r\n procedure StartDragFrame;\r\n procedure DragFrame(X, Y: Integer);\r\n procedure StopDragFrame(X, Y: Integer);\r\n function CheckResize(Shift: TShiftState; X, Y: Integer): Boolean;\r\n procedure ReadSections(Reader: TReader);\r\n procedure WriteSections(Writer: TWriter);\r\n procedure ReadData(Reader: TReader);\r\n procedure WriteData(Writer: TWriter);\r\n procedure ReadDesignStyle(Reader: TReader);\r\n procedure ReadAllowDrag(Reader: TReader);\r\n procedure WriteDesignStyle(Writer: TWriter);\r\n function GetStorage: TJvFormPlacement;\r\n procedure SetStorage(Value: TJvFormPlacement);\r\n procedure IniSave(Sender: TObject);\r\n procedure IniLoad(Sender: TObject);\r\n protected\r\n procedure VisibleChanged; override;\r\n procedure EnabledChanged; override;\r\n procedure AlignControls(AControl: TControl; var Rect: TRect); override;\r\n function AppendSection(Value: TJvSpeedBarSection): Integer; virtual;\r\n procedure AlignItemsToGrid;\r\n procedure ChangeScale(M, D: Integer); override;\r\n procedure Loaded; override;\r\n procedure Paint; override;\r\n procedure MouseDown(Button: TMouseButton; Shift: TShiftState;\r\n X, Y: Integer); override;\r\n procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;\r\n procedure MouseUp(Button: TMouseButton; Shift: TShiftState;\r\n X, Y: Integer); override;\r\n procedure DefineProperties(Filer: TFiler); override;\r\n procedure Notification(AComponent: TComponent;\r\n Operation: TOperation); override;\r\n procedure SetChildOrder(Component: TComponent; Order: Integer); override;\r\n procedure ForEachItem(Proc: TForEachItem; Data: SizeInt); virtual;\r\n procedure PosChanged; dynamic;\r\n procedure AfterCustomize; dynamic;\r\n property ScaleFlags: TSbScaleFlags read FScaleFlags write FScaleFlags;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n\r\n procedure GetChildren(Proc: TGetChildProc; Root: TComponent); override; // public in D2009\r\n procedure SetFontDefault; virtual;\r\n procedure RemoveItem(Item: TJvSpeedItem);\r\n procedure RemoveSection(Section: Integer); { delete and free section and items }\r\n procedure DeleteSection(Section: Integer); { delete section }\r\n function AddSection(const ACaption: string): Integer;\r\n procedure AddItem(Section: Integer; Item: TJvSpeedItem);\r\n function NewItem(AOwner: TComponent; Section: Integer;\r\n const AName: string): TJvSpeedItem;\r\n function AcceptDropItem(Item: TJvSpeedItem; X, Y: Integer): Boolean;\r\n procedure SetEditing(Win: THandle);\r\n function GetEditing: Boolean;\r\n function SearchItem(const ItemName: string): TJvSpeedItem;\r\n function FindItem(Item: TJvSpeedItem; var Section, Index: Integer): Boolean;\r\n function SearchSection(const ACaption: string): Integer;\r\n procedure Customize(HelpCtx: THelpContext);\r\n procedure SaveLayout;\r\n procedure RestoreLayout;\r\n procedure LoadFromAppStorage(const AppStorage: TJvCustomAppStorage; const Path: string);\r\n procedure SaveToAppStorage(const AppStorage: TJvCustomAppStorage; const Path: string);\r\n procedure Load;\r\n procedure Save;\r\n function ItemsCount(Section: Integer): Integer;\r\n function Items(Section, Index: Integer): TJvSpeedItem;\r\n property EditMode: Boolean read GetEditing;\r\n property SectionCount: Integer read GetSectionCount;\r\n property Sections[Index: Integer]: TJvSpeedBarSection read GetSection;\r\n property Orientation: TBarOrientation read GetOrientation write SetOrientation\r\n default boHorizontal;\r\n property OnAddItem: TNotifyEvent read FOnAddItem write FOnAddItem; { for internal use only }\r\n published\r\n property Font;\r\n property ParentFont default False;\r\n property BoundLines: TBoundLines read FBoundLines write SetBoundLines default [];\r\n property Position: TBarPosition read FPosition write FPosition default bpAuto;\r\n { ensure Position is declared before Align }\r\n property Align: TAlign read GetAlign write SetAlign default alTop;\r\n { ensure Options is declared before BtnOffset... }\r\n property Options: TJvSpeedBarOptions read FOptions write SetOptions\r\n default [sbAllowDrag, sbGrayedBtns];\r\n property BtnOffsetHorz: Integer index 0 read GetButtonsOffset write SetButtonsOffset\r\n stored True;\r\n property BtnOffsetVert: Integer index 1 read GetButtonsOffset write SetButtonsOffset\r\n stored True;\r\n property BtnWidth: Integer index 0 read GetButtonSize write SetButtonSize;\r\n property BtnHeight: Integer index 1 read GetButtonSize write SetButtonSize;\r\n property IniStorage: TJvFormPlacement read GetStorage write SetStorage;\r\n property Version: Integer read FVersion write FVersion default 0;\r\n property Wallpaper: TPicture read FWallpaper write SetWallpaper;\r\n property Images: TCustomImageList read FImages write SetImages;\r\n property BiDiMode;\r\n property DragCursor;\r\n property ParentBiDiMode;\r\n property OnEndDock;\r\n property OnStartDock;\r\n property Locked;\r\n property Constraints;\r\n property BevelInner;\r\n property BevelOuter;\r\n property BevelWidth;\r\n property BorderWidth;\r\n property BorderStyle;\r\n property Color;\r\n property DragMode;\r\n property Enabled;\r\n property ParentColor;\r\n property ParentShowHint default False;\r\n property PopupMenu;\r\n property ShowHint default True;\r\n property TabOrder;\r\n property TabStop;\r\n property Visible;\r\n property OnApplyAlign: TApplyAlignEvent read FOnApplyAlign write FOnApplyAlign;\r\n property OnCustomize: TNotifyEvent read FOnCustomize write FOnCustomize;\r\n property OnPosChanged: TNotifyEvent read FOnPosChanged write FOnPosChanged;\r\n property OnVisibleChanged: TNotifyEvent read FOnVisibleChanged write FOnVisibleChanged;\r\n property OnClick;\r\n property OnDblClick;\r\n property OnDragDrop;\r\n property OnDragOver;\r\n property OnEndDrag;\r\n property OnEnter;\r\n property OnExit;\r\n property OnMouseDown;\r\n property OnMouseMove;\r\n property OnMouseUp;\r\n property OnStartDrag;\r\n property OnContextPopup;\r\n property OnResize;\r\n {$IFDEF JVCLThemesEnabled}\r\n property ParentBackground default True;\r\n {$ENDIF JVCLThemesEnabled}\r\n end;\r\n\r\n TJvSpeedItem = class(TComponent)\r\n private\r\n FCaption: string;\r\n FEditing: Boolean;\r\n FEnabled: Boolean;\r\n FButton: TJvSpeedButton;\r\n FVisible: Boolean;\r\n FStored: Boolean;\r\n FParent: TJvSpeedBar;\r\n FSection: Integer;\r\n FSectionName: string;\r\n FImageIndex: TImageIndex;\r\n procedure SetImageIndex(Value: TImageIndex);\r\n function GetAction: TBasicAction;\r\n procedure SetAction(Value: TBasicAction);\r\n function GetAllowAllUp: Boolean;\r\n procedure SetAllowAllUp(Value: Boolean);\r\n function GetAllowTimer: Boolean;\r\n procedure SetAllowTimer(Value: Boolean);\r\n function GetBtnCaption: TCaption;\r\n procedure SetBtnCaption(const Value: TCaption);\r\n function GetGroupIndex: Integer;\r\n procedure SetGroupIndex(Value: Integer);\r\n function GetDown: Boolean;\r\n procedure SetDown(Value: Boolean);\r\n function GetGlyph: TBitmap;\r\n procedure SetGlyph(Value: TBitmap);\r\n function GetLayout: TButtonLayout;\r\n procedure SetLayout(Value: TButtonLayout);\r\n function GetMargin: Integer;\r\n procedure SetMargin(Value: Integer);\r\n function GetNumGlyphs: TJvNumGlyphs;\r\n procedure SetNumGlyphs(Value: TJvNumGlyphs);\r\n function GetParentShowHint: Boolean;\r\n procedure SetParentShowHint(Value: Boolean);\r\n function GetFont: TFont;\r\n procedure SetFont(Value: TFont);\r\n function GetParentFont: Boolean;\r\n procedure SetParentFont(Value: Boolean);\r\n function IsFontStored: Boolean;\r\n function GetShowHint: Boolean;\r\n procedure SetShowHint(Value: Boolean);\r\n function IsShowHintStored: Boolean;\r\n function GetSpacing: Integer;\r\n procedure SetSpacing(Value: Integer);\r\n function GetCursor: TCursor;\r\n procedure SetCursor(Value: TCursor);\r\n function GetHint: string;\r\n procedure SetHint(const Value: string);\r\n function GetTag: Longint;\r\n procedure SetTag(Value: Longint);\r\n function GetDropDownMenu: TPopupMenu;\r\n procedure SetDropDownMenu(Value: TPopupMenu);\r\n function GetMarkDropDown: Boolean;\r\n procedure SetMarkDropDown(Value: Boolean);\r\n function GetWordWrap: Boolean;\r\n procedure SetWordWrap(Value: Boolean);\r\n function GetOnClick: TNotifyEvent;\r\n procedure SetOnClick(Value: TNotifyEvent);\r\n function GetOnDblClick: TNotifyEvent;\r\n procedure SetOnDblClick(Value: TNotifyEvent);\r\n function GetOnMouseDown: TMouseEvent;\r\n procedure SetOnMouseDown(Value: TMouseEvent);\r\n function GetOnMouseMove: TMouseMoveEvent;\r\n procedure SetOnMouseMove(Value: TMouseMoveEvent);\r\n function GetOnMouseUp: TMouseEvent;\r\n procedure SetOnMouseUp(Value: TMouseEvent);\r\n function GetOnMouseEnter: TNotifyEvent;\r\n procedure SetOnMouseEnter(Value: TNotifyEvent);\r\n function GetOnMouseLeave: TNotifyEvent;\r\n procedure SetOnMouseLeave(Value: TNotifyEvent);\r\n function GetCaption: TCaption;\r\n procedure SetCaption(const Value: TCaption);\r\n procedure SetEditing(Value: Boolean);\r\n function GetLeft: Integer;\r\n function GetTop: Integer;\r\n procedure SetLeft(Value: Integer);\r\n procedure SetTop(Value: Integer);\r\n function GetSection: Integer;\r\n procedure SetSection(Value: Integer);\r\n function GetSectionName: string;\r\n {procedure SetSectionName(const Value: string);}\r\n procedure ReadSection(Reader: TReader);\r\n procedure WriteSection(Writer: TWriter);\r\n procedure ReadSectionName(Reader: TReader);\r\n procedure WriteSectionName(Writer: TWriter);\r\n protected\r\n procedure ReadState(Reader: TReader); override;\r\n procedure SetName(const Value: TComponentName); override;\r\n procedure SetEnabled(Value: Boolean);\r\n procedure SetVisible(Value: Boolean);\r\n procedure DefineProperties(Filer: TFiler); override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n function HasParent: Boolean; override;\r\n function GetParentComponent: TComponent; override;\r\n procedure SetParentComponent(Value: TComponent); override;\r\n procedure ButtonClick;\r\n function CheckBtnMenuDropDown: Boolean;\r\n procedure Click; virtual;\r\n procedure UpdateSection;\r\n procedure InvalidateItem;\r\n property ASection: Integer read GetSection write SetSection;\r\n property SpeedBar: TJvSpeedBar read FParent;\r\n property Button: TJvSpeedButton read FButton;\r\n published\r\n property Action: TBasicAction read GetAction write SetAction;\r\n property AllowAllUp: Boolean read GetAllowAllUp write SetAllowAllUp default False;\r\n property AllowTimer: Boolean read GetAllowTimer write SetAllowTimer default False;\r\n property BtnCaption: TCaption read GetBtnCaption write SetBtnCaption;\r\n property Caption: TCaption read GetCaption write SetCaption;\r\n property GroupIndex: Integer read GetGroupIndex write SetGroupIndex default 0;\r\n property Down: Boolean read GetDown write SetDown default False;\r\n property DropDownMenu: TPopupMenu read GetDropDownMenu write SetDropDownMenu;\r\n property Enabled: Boolean read FEnabled write SetEnabled default True;\r\n property Font: TFont read GetFont write SetFont stored IsFontStored;\r\n property Cursor: TCursor read GetCursor write SetCursor default crDefault;\r\n property Glyph: TBitmap read GetGlyph write SetGlyph;\r\n property Hint: string read GetHint write SetHint;\r\n property ImageIndex: TImageIndex read FImageIndex write SetImageIndex default -1;\r\n property Layout: TButtonLayout read GetLayout write SetLayout default blGlyphTop;\r\n property Margin: Integer read GetMargin write SetMargin default -1;\r\n property MarkDropDown: Boolean read GetMarkDropDown write SetMarkDropDown default True;\r\n property NumGlyphs: TJvNumGlyphs read GetNumGlyphs write SetNumGlyphs default 1;\r\n property ParentShowHint: Boolean read GetParentShowHint write SetParentShowHint default True;\r\n property ParentFont: Boolean read GetParentFont write SetParentFont default True;\r\n property ShowHint: Boolean read GetShowHint write SetShowHint stored IsShowHintStored;\r\n property Spacing: Integer read GetSpacing write SetSpacing default 4;\r\n property Stored: Boolean read FStored write FStored default True;\r\n property Tag: Longint read GetTag write SetTag default 0;\r\n property Left: Integer read GetLeft write SetLeft default 0;\r\n property Top: Integer read GetTop write SetTop default 0;\r\n property Visible: Boolean read FVisible write SetVisible default False;\r\n property WordWrap: Boolean read GetWordWrap write SetWordWrap default False;\r\n property OnClick: TNotifyEvent read GetOnClick write SetOnClick;\r\n property OnDblClick: TNotifyEvent read GetOnDblClick write SetOnDblClick;\r\n property OnMouseDown: TMouseEvent read GetOnMouseDown write SetOnMouseDown;\r\n property OnMouseMove: TMouseMoveEvent read GetOnMouseMove write SetOnMouseMove;\r\n property OnMouseUp: TMouseEvent read GetOnMouseUp write SetOnMouseUp;\r\n property OnMouseEnter: TNotifyEvent read GetOnMouseEnter write SetOnMouseEnter;\r\n property OnMouseLeave: TNotifyEvent read GetOnMouseLeave write SetOnMouseLeave;\r\n end;\r\n\r\n TJvSpeedBarSection = class(TComponent)\r\n private\r\n FList: TList;\r\n FTitle: string;\r\n FParent: TJvSpeedBar;\r\n function Get(Index: Integer): TJvSpeedItem;\r\n procedure Put(Index: Integer; Item: TJvSpeedItem);\r\n function GetCount: Integer;\r\n function GetTitle: string;\r\n procedure SetTitle(const Value: string);\r\n function GetIndex: Integer;\r\n procedure SetIndex(Value: Integer);\r\n procedure SetSpeedBar(Value: TJvSpeedBar);\r\n procedure ValidateCaption(const NewCaption: string);\r\n protected\r\n procedure SetParentComponent(Value: TComponent); override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n function HasParent: Boolean; override;\r\n function GetParentComponent: TComponent; override;\r\n procedure Clear;\r\n procedure RemoveItem(Item: TJvSpeedItem);\r\n property Count: Integer read GetCount;\r\n property Items[Index: Integer]: TJvSpeedItem read Get write Put; default;\r\n property List: TList read FList; { for internal use only }\r\n property SpeedBar: TJvSpeedBar read FParent write SetSpeedBar stored False;\r\n published\r\n property Caption: string read GetTitle write SetTitle;\r\n property Index: Integer read GetIndex write SetIndex stored False;\r\n end;\r\n\r\n TJvBtnControl = class(TJvCustomControl)\r\n private\r\n FImage: TJvButtonImage;\r\n FSpacing: Integer;\r\n FMargin: Integer;\r\n FLayout: TButtonLayout;\r\n FImageIndex: Integer;\r\n FImages: TCustomImageList;\r\n function GetCaption: TCaption;\r\n function GetGlyph: TBitmap;\r\n function GetNumGlyphs: TJvNumGlyphs;\r\n function GetWordWrap: Boolean;\r\n function GetAlignment: TAlignment;\r\n procedure SetAlignment(Value: TAlignment);\r\n procedure SetCaption(const Value: TCaption);\r\n procedure SetNumGlyphs(Value: TJvNumGlyphs);\r\n procedure SetGlyph(Value: TBitmap);\r\n procedure SetWordWrap(Value: Boolean);\r\n protected\r\n procedure CreateParams(var Params: TCreateParams); override;\r\n procedure Paint; override;\r\n procedure BoundsChanged; override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n procedure AssignSpeedItem(Item: TJvSpeedItem);\r\n procedure Activate(Rect: TRect);\r\n procedure ReleaseHandle;\r\n property Alignment: TAlignment read GetAlignment write SetAlignment;\r\n property Caption: TCaption read GetCaption write SetCaption;\r\n property Glyph: TBitmap read GetGlyph write SetGlyph;\r\n property NumGlyphs: TJvNumGlyphs read GetNumGlyphs write SetNumGlyphs;\r\n property Spacing: Integer read FSpacing write FSpacing;\r\n property ImageIndex: Integer read FImageIndex write FImageIndex;\r\n property Images: TCustomImageList read FImages write FImages;\r\n property Margin: Integer read FMargin write FMargin;\r\n property Layout: TButtonLayout read FLayout write FLayout;\r\n property WordWrap: Boolean read GetWordWrap write SetWordWrap;\r\n property Font;\r\n end;\r\n\r\n{ Utility routines for SpeedBar Editors }\r\n\r\nfunction FindSpeedBar(const Pos: TPoint): TJvSpeedBar;\r\nprocedure DrawCellButton(Grid: TDrawGrid; R: TRect; Item: TJvSpeedItem;\r\n Image: TJvButtonImage; ARightToLeft: Boolean = False);\r\nfunction NewSpeedSection(ASpeedBar: TJvSpeedBar; const ACaption: string): Integer;\r\nfunction NewSpeedItem(AOwner: TComponent; ASpeedBar: TJvSpeedBar; Section: Integer;\r\n const AName: string): TJvSpeedItem;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvSpeedbar.pas $';\r\n Revision: '$Revision: 13415 $';\r\n Date: '$Date: 2012-09-10 11:51:54 +0200 (lun. 10 sept. 2012) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n Types, Math,\r\n JvJVCLUtils, JvJCLUtils, JvSpeedbarSetupForm, JvResources;\r\n\r\nconst\r\n DefaultButtonSize: TPoint = (X: DefButtonWidth; Y: DefButtonHeight);\r\n DragFrameWidth = 3;\r\n StartDragOffset = 4;\r\n\r\n// (rom) changed to var\r\nvar\r\n Registered: Boolean = False;\r\n\r\nconst\r\n Alignments: array [TAlignment] of Word = (DT_LEFT, DT_RIGHT, DT_CENTER);\r\n\r\n// (rom) moved here to make JvMaxMin obsolete\r\nprocedure SwapInt(var Int1, Int2: Integer);\r\nvar\r\n I: Integer;\r\nbegin\r\n I := Int1;\r\n Int1 := Int2;\r\n Int2 := I;\r\nend;\r\n\r\n//=== { TJvSpeedBarSection } =================================================\r\n\r\nconstructor TJvSpeedBarSection.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FList := TList.Create;\r\n FTitle := '';\r\nend;\r\n\r\ndestructor TJvSpeedBarSection.Destroy;\r\nbegin\r\n Clear;\r\n if FParent <> nil then\r\n FParent.DeleteSection(Index);\r\n FList.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvSpeedBarSection.Clear;\r\nbegin\r\n while FList.Count > 0 do\r\n begin\r\n TJvSpeedItem(FList[0]).Free;\r\n FList.Delete(0);\r\n end;\r\nend;\r\n\r\nfunction TJvSpeedBarSection.Get(Index: Integer): TJvSpeedItem;\r\nbegin\r\n Result := TJvSpeedItem(FList[Index]);\r\nend;\r\n\r\nprocedure TJvSpeedBarSection.Put(Index: Integer; Item: TJvSpeedItem);\r\nbegin\r\n FList[Index] := Item;\r\nend;\r\n\r\nfunction TJvSpeedBarSection.GetCount: Integer;\r\nbegin\r\n Result := FList.Count;\r\nend;\r\n\r\nfunction TJvSpeedBarSection.GetIndex: Integer;\r\nbegin\r\n if FParent <> nil then\r\n Result := FParent.FSections.IndexOf(Self)\r\n else\r\n Result := -1;\r\nend;\r\n\r\nprocedure TJvSpeedBarSection.SetIndex(Value: Integer);\r\nvar\r\n CurIndex, Count: Integer;\r\nbegin\r\n CurIndex := GetIndex;\r\n if CurIndex >= 0 then\r\n begin\r\n Count := FParent.FSections.Count;\r\n if Value < 0 then\r\n Value := 0;\r\n if Value >= Count then\r\n Value := Count - 1;\r\n if Value <> CurIndex then\r\n begin\r\n FParent.FSections.Delete(CurIndex);\r\n FParent.FSections.Insert(Value, Self);\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJvSpeedBarSection.HasParent: Boolean;\r\nbegin\r\n Result := True;\r\nend;\r\n\r\nprocedure TJvSpeedBarSection.SetSpeedBar(Value: TJvSpeedBar);\r\nvar\r\n CurIndex: Integer;\r\nbegin\r\n CurIndex := GetIndex;\r\n if FParent <> nil then\r\n FParent.DeleteSection(Index);\r\n if Value <> nil then\r\n Value.AppendSection(Self);\r\n if CurIndex >= 0 then\r\n Index := CurIndex;\r\nend;\r\n\r\nfunction TJvSpeedBarSection.GetParentComponent: TComponent;\r\nbegin\r\n Result := FParent;\r\nend;\r\n\r\nprocedure TJvSpeedBarSection.SetParentComponent(Value: TComponent);\r\nbegin\r\n SpeedBar := Value as TJvSpeedBar;\r\nend;\r\n\r\nprocedure TJvSpeedBarSection.RemoveItem(Item: TJvSpeedItem);\r\nvar\r\n I: Integer;\r\nbegin\r\n I := FList.IndexOf(Item);\r\n if I >= 0 then\r\n begin\r\n Item.FButton.Parent := nil;\r\n Item.FParent := nil;\r\n Item.FSection := -1;\r\n FList.Delete(I);\r\n end;\r\nend;\r\n\r\nprocedure TJvSpeedBarSection.ValidateCaption(const NewCaption: string);\r\nvar\r\n I: Integer;\r\nbegin\r\n if FParent <> nil then\r\n begin\r\n I := FParent.SearchSection(NewCaption);\r\n if (I <> Index) and (I >= 0) then\r\n raise EJvSpeedbarError.CreateRes(@SDuplicateString);\r\n end;\r\nend;\r\n\r\nprocedure TJvSpeedBarSection.SetTitle(const Value: string);\r\nbegin\r\n if not (csLoading in ComponentState) then\r\n ValidateCaption(Value);\r\n FTitle := Value;\r\nend;\r\n\r\nfunction TJvSpeedBarSection.GetTitle: string;\r\nbegin\r\n Result := FTitle;\r\nend;\r\n\r\n//=== { TJvSpeedBarButton } ==================================================\r\n\r\ntype\r\n TJvSpeedBarButton = class(TJvSpeedButton)\r\n private\r\n FItem: TJvSpeedItem;\r\n FBtn: TJvBtnControl;\r\n procedure InvalidateGlyph;\r\n protected\r\n procedure VisibleChanged; override;\r\n procedure WndProc(var Msg: TMessage); override;\r\n procedure MouseDown(Button: TMouseButton; Shift: TShiftState;\r\n X, Y: Integer); override;\r\n procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;\r\n procedure MouseUp(Button: TMouseButton; Shift: TShiftState;\r\n X, Y: Integer); override;\r\n procedure PaintImage(Canvas: TCanvas; ARect: TRect; const Offset: TPoint;\r\n AState: TJvButtonState; DrawMark, PaintOnGlass: Boolean); override;\r\n procedure Paint; override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n procedure SetBounds(ALeft, ATop, AWidth, AHeight: Integer); override;\r\n end;\r\n\r\nconstructor TJvSpeedBarButton.Create(AOwner: TComponent);\r\nbegin\r\n FItem := TJvSpeedItem(AOwner);\r\n { Ensure FItem is assigned before inherited Create }\r\n inherited Create(AOwner);\r\n Visible := False;\r\n Style := bsNew;\r\n ParentShowHint := True;\r\n ParentFont := True;\r\nend;\r\n\r\ndestructor TJvSpeedBarButton.Destroy;\r\nbegin\r\n FBtn.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvSpeedBarButton.SetBounds(ALeft, ATop, AWidth, AHeight: Integer);\r\nbegin\r\n if FItem.SpeedBar <> nil then\r\n begin\r\n case FItem.SpeedBar.Orientation of\r\n boHorizontal:\r\n ATop := Max(FItem.SpeedBar.FOffset.Y, ATop);\r\n boVertical:\r\n ALeft := Max(FItem.SpeedBar.FOffset.X, ALeft);\r\n end;\r\n end;\r\n inherited SetBounds(ALeft, ATop, AWidth, AHeight);\r\nend;\r\n\r\nprocedure TJvSpeedBarButton.VisibleChanged;\r\nbegin\r\n if Visible then\r\n begin\r\n ControlStyle := ControlStyle - [csNoDesignVisible];\r\n Invalidate;\r\n end\r\n else\r\n ControlStyle := ControlStyle + [csNoDesignVisible];\r\n inherited;\r\nend;\r\n\r\n\r\nprocedure TJvSpeedBarButton.WndProc(var Msg: TMessage);\r\nbegin\r\n if FItem.FEditing and (csDesigning in ComponentState) and\r\n (Msg.Msg >= WM_MOUSEFIRST) and (Msg.Msg <= WM_MOUSELAST) then\r\n begin\r\n if (Msg.Msg = WM_LBUTTONDOWN) and not Visible then\r\n inherited WndProc(Msg)\r\n else\r\n Dispatch(Msg);\r\n end\r\n else\r\n inherited WndProc(Msg);\r\nend;\r\n\r\n\r\nprocedure TJvSpeedBarButton.MouseDown(Button: TMouseButton; Shift: TShiftState;\r\n X, Y: Integer);\r\nvar\r\n P: TPoint;\r\nbegin\r\n if FItem.FEditing and Visible and (Button = mbLeft) and\r\n (FItem.SpeedBar <> nil) then\r\n begin\r\n P := ClientToScreen(Point(FItem.SpeedBar.BtnWidth {div 2},\r\n FItem.SpeedBar.BtnHeight {div 2}));\r\n X := P.X;\r\n Y := P.Y;\r\n if FBtn = nil then\r\n begin\r\n SetCursorPos(X, Y);\r\n FBtn := TJvBtnControl.Create(Self);\r\n FBtn.AssignSpeedItem(FItem);\r\n end;\r\n BringToFront;\r\n end\r\n else\r\n inherited MouseDown(Button, Shift, X, Y);\r\nend;\r\n\r\nprocedure TJvSpeedBarButton.MouseMove(Shift: TShiftState; X, Y: Integer);\r\nvar\r\n P: TPoint;\r\n R: TRect;\r\nbegin\r\n if FItem.FEditing and (FBtn <> nil) then\r\n begin\r\n P := ClientToScreen(Point(X - (FBtn.Width {div 2}),\r\n Y - (FBtn.Height {div 2})));\r\n X := P.X;\r\n Y := P.Y;\r\n if FItem.SpeedBar <> nil then\r\n begin\r\n Visible := False;\r\n if csDesigning in ComponentState then\r\n begin\r\n R := BoundsRect;\r\n Windows.InvalidateRect(FItem.SpeedBar.Handle, @R, True);\r\n end;\r\n P := FItem.SpeedBar.ScreenToClient(P);\r\n if PtInRect(FItem.SpeedBar.ClientRect, P) then\r\n begin\r\n FBtn.Activate(Bounds(X, Y, FBtn.Width, FBtn.Height));\r\n end\r\n else\r\n FBtn.ReleaseHandle;\r\n end;\r\n end\r\n else\r\n inherited MouseMove(Shift, X, Y);\r\nend;\r\n\r\nprocedure TJvSpeedBarButton.MouseUp(Button: TMouseButton; Shift: TShiftState;\r\n X, Y: Integer);\r\nvar\r\n P: TPoint;\r\nbegin\r\n if FItem.FEditing and (FBtn <> nil) then\r\n begin\r\n X := X - (FBtn.Width {div 2});\r\n Y := Y - (FBtn.Height {div 2});\r\n FBtn.Free;\r\n FBtn := nil;\r\n P := ClientToScreen(Point(X, Y));\r\n if FItem.SpeedBar <> nil then\r\n begin\r\n P := FItem.SpeedBar.ScreenToClient(P);\r\n if PtInRect(FItem.SpeedBar.ClientRect, P) then\r\n begin\r\n if not FItem.SpeedBar.AcceptDropItem(FItem, P.X, P.Y) then\r\n begin\r\n SendMessage(FItem.SpeedBar.FEditWin, CM_SPEEDBARCHANGED, SBR_CHANGED,\r\n LPARAM(FItem.SpeedBar));\r\n end\r\n else\r\n begin\r\n SendMessage(FItem.SpeedBar.FEditWin, CM_SPEEDBARCHANGED, SBR_BTNSELECT,\r\n LPARAM(FItem));\r\n Invalidate;\r\n end;\r\n end\r\n else\r\n begin\r\n SendToBack;\r\n FItem.Visible := False;\r\n SendMessage(FItem.SpeedBar.FEditWin, CM_SPEEDBARCHANGED, SBR_CHANGED,\r\n LPARAM(FItem.SpeedBar));\r\n end;\r\n end;\r\n end\r\n else\r\n inherited MouseUp(Button, Shift, X, Y);\r\nend;\r\n\r\nprocedure TJvSpeedBarButton.InvalidateGlyph;\r\nbegin\r\n TJvxButtonGlyph(ButtonGlyph).Invalidate;\r\nend;\r\n\r\nprocedure TJvSpeedBarButton.PaintImage(Canvas: TCanvas; ARect: TRect; const Offset: TPoint;\r\n AState: TJvButtonState; DrawMark, PaintOnGlass: Boolean);\r\nbegin\r\n if FItem.SpeedBar <> nil then\r\n begin\r\n TJvxButtonGlyph(ButtonGlyph).DrawEx(Canvas, ARect, Offset, Caption, Layout,\r\n Margin, Spacing, DrawMark, FItem.SpeedBar.Images, FItem.FImageIndex,\r\n AState,\r\n DrawTextBiDiModeFlags(Alignments[Alignment]),\r\n PaintOnGlass\r\n );\r\n end\r\n else\r\n inherited PaintImage(Canvas, ARect, Offset, AState, DrawMark, PaintOnGlass);\r\nend;\r\n\r\nprocedure TJvSpeedBarButton.Paint;\r\nbegin\r\n if Visible then\r\n inherited Paint;\r\nend;\r\n\r\n//=== { TJvSpeedItem } =======================================================\r\n\r\nconstructor TJvSpeedItem.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FButton := TJvSpeedBarButton.Create(Self);\r\n FButton.Visible := False;\r\n FButton.SetBounds(0, 0, DefaultButtonSize.X, DefaultButtonSize.Y);\r\n FCaption := '';\r\n ShowHint := True;\r\n ParentShowHint := True;\r\n FVisible := False;\r\n FStored := True;\r\n FEnabled := True;\r\n FEditing := False;\r\n FParent := nil;\r\n FImageIndex := -1;\r\nend;\r\n\r\ndestructor TJvSpeedItem.Destroy;\r\nbegin\r\n FVisible := False;\r\n if FParent <> nil then\r\n FParent.RemoveItem(Self);\r\n FButton.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJvSpeedItem.GetCaption: TCaption;\r\nbegin\r\n Result := TCaption(FCaption);\r\nend;\r\n\r\nprocedure TJvSpeedItem.SetCaption(const Value: TCaption);\r\nvar\r\n ChangeHint: Boolean;\r\nbegin\r\n ChangeHint := (Owner = nil) or not (Owner is TControl) or\r\n not (csLoading in TControl(Owner).ComponentState) and\r\n (Caption = GetShortHint(Hint));\r\n FCaption := Value;\r\n if ChangeHint then\r\n begin\r\n if Pos('|', Value) = 0 then\r\n begin\r\n if Pos('|', Hint) = 0 then\r\n Hint := Value + '|'\r\n else\r\n Hint := Value + '|' + GetLongHint(Hint);\r\n end\r\n else\r\n begin\r\n if GetLongHint(Value) = '' then\r\n Hint := GetShortHint(Value) + '|' + GetLongHint(Hint)\r\n else\r\n Hint := Value;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvSpeedItem.SetName(const Value: TComponentName);\r\nvar\r\n ChangeText: Boolean;\r\nbegin\r\n ChangeText := (Name = Caption) and\r\n ((Owner = nil) or not (Owner is TControl) or\r\n not (csLoading in TControl(Owner).ComponentState));\r\n inherited SetName(Value);\r\n if ChangeText then\r\n Caption := Value;\r\nend;\r\n\r\nprocedure TJvSpeedItem.SetEditing(Value: Boolean);\r\nbegin\r\n FEditing := Value;\r\n if FEditing then\r\n begin\r\n FButton.Enabled := True;\r\n FButton.Flat := False;\r\n end\r\n else\r\n begin\r\n SetEnabled(FEnabled);\r\n if SpeedBar <> nil then\r\n FButton.Flat := (sbFlatBtns in SpeedBar.Options);\r\n end;\r\nend;\r\n\r\nfunction TJvSpeedItem.HasParent: Boolean;\r\nbegin\r\n Result := True;\r\nend;\r\n\r\nprocedure TJvSpeedItem.DefineProperties(Filer: TFiler);\r\n\r\n function DoWrite: Boolean;\r\n begin\r\n if Assigned(Filer.Ancestor) then\r\n Result := GetSectionName <> TJvSpeedItem(Filer.Ancestor).GetSectionName\r\n else\r\n Result := True;\r\n end;\r\n\r\nbegin\r\n inherited DefineProperties(Filer);\r\n Filer.DefineProperty('Section', ReadSection, WriteSection, False);\r\n Filer.DefineProperty('SectionName', ReadSectionName, WriteSectionName, DoWrite);\r\nend;\r\n\r\nprocedure TJvSpeedItem.ReadSectionName(Reader: TReader);\r\nbegin\r\n FSectionName := Reader.ReadString;\r\nend;\r\n\r\nprocedure TJvSpeedItem.WriteSectionName(Writer: TWriter);\r\nbegin\r\n Writer.WriteString(GetSectionName);\r\nend;\r\n\r\nprocedure TJvSpeedItem.ReadSection(Reader: TReader);\r\nbegin\r\n FSection := Reader.ReadInteger;\r\nend;\r\n\r\nprocedure TJvSpeedItem.WriteSection(Writer: TWriter);\r\nbegin\r\n UpdateSection;\r\n Writer.WriteInteger(FSection);\r\nend;\r\n\r\nfunction TJvSpeedItem.GetParentComponent: TComponent;\r\nbegin\r\n Result := FParent;\r\nend;\r\n\r\nprocedure TJvSpeedItem.SetParentComponent(Value: TComponent);\r\nvar\r\n I: Integer;\r\nbegin\r\n if not (csLoading in ComponentState) then\r\n begin\r\n if FParent <> nil then\r\n FParent.RemoveItem(Self);\r\n if (Value <> nil) and (Value is TJvSpeedBar) then\r\n begin\r\n I := TJvSpeedBar(Value).SearchSection(FSectionName);\r\n if I >= 0 then\r\n FSection := I;\r\n TJvSpeedBar(Value).AddItem(FSection, Self);\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvSpeedItem.SetImageIndex(Value: TImageIndex);\r\nbegin\r\n if Value <> FImageIndex then\r\n begin\r\n FImageIndex := Value;\r\n TJvSpeedBarButton(FButton).InvalidateGlyph;\r\n FButton.Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvSpeedItem.ReadState(Reader: TReader);\r\nbegin\r\n inherited ReadState(Reader);\r\n if Reader.Parent is TJvSpeedBar then\r\n begin\r\n if FSectionName <> '' then\r\n FSection := TJvSpeedBar(Reader.Parent).SearchSection(FSectionName);\r\n TJvSpeedBar(Reader.Parent).AddItem(Max(FSection, 0), Self);\r\n end;\r\nend;\r\n\r\nfunction TJvSpeedItem.GetSection: Integer;\r\nbegin\r\n UpdateSection;\r\n Result := FSection;\r\nend;\r\n\r\nprocedure TJvSpeedItem.SetSection(Value: Integer);\r\nbegin\r\n if SpeedBar = nil then\r\n FSection := Value;\r\nend;\r\n\r\nfunction TJvSpeedItem.GetSectionName: string;\r\nbegin\r\n UpdateSection;\r\n if FSection >= 0 then\r\n Result := FParent.Sections[FSection].Caption\r\n else\r\n Result := FSectionName;\r\nend;\r\n\r\n{\r\nprocedure TJvSpeedItem.SetSectionName(const Value: string);\r\nbegin\r\n if FParent <> nil then FSection := FParent.SearchSection(Value)\r\n else FSection := -1;\r\n FSectionName := Value;\r\nend;\r\n}\r\n\r\nprocedure TJvSpeedItem.InvalidateItem;\r\nbegin\r\n FSection := -1;\r\nend;\r\n\r\nprocedure TJvSpeedItem.UpdateSection;\r\nvar\r\n I: Integer;\r\nbegin\r\n if FParent <> nil then\r\n FParent.FindItem(Self, FSection, I)\r\n else\r\n FSection := -1;\r\nend;\r\n\r\nprocedure TJvSpeedItem.SetEnabled(Value: Boolean);\r\nbegin\r\n if (FButton.Enabled <> Value) or (FEnabled <> Value) then\r\n begin\r\n FEnabled := Value;\r\n if not FEditing then\r\n begin\r\n if (SpeedBar <> nil) and Value then\r\n FButton.Enabled := (Value and SpeedBar.Enabled)\r\n else\r\n FButton.Enabled := Value;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvSpeedItem.SetVisible(Value: Boolean);\r\nbegin\r\n if (FButton.Visible <> Value) or (FVisible <> Value) or\r\n (Value and (FButton.Parent = nil)) then\r\n begin\r\n FVisible := Value;\r\n if (SpeedBar <> nil) and Value then\r\n FButton.Visible := Value and SpeedBar.Visible\r\n else\r\n FButton.Visible := Value;\r\n if Value then\r\n FButton.Parent := SpeedBar;\r\n end;\r\nend;\r\n\r\nfunction TJvSpeedItem.GetAllowAllUp: Boolean;\r\nbegin\r\n Result := FButton.AllowAllUp;\r\nend;\r\n\r\nprocedure TJvSpeedItem.SetAllowAllUp(Value: Boolean);\r\nbegin\r\n FButton.AllowAllUp := Value;\r\nend;\r\n\r\nfunction TJvSpeedItem.GetAllowTimer: Boolean;\r\nbegin\r\n Result := FButton.AllowTimer;\r\nend;\r\n\r\nprocedure TJvSpeedItem.SetAllowTimer(Value: Boolean);\r\nbegin\r\n FButton.AllowTimer := Value;\r\nend;\r\n\r\nfunction TJvSpeedItem.GetBtnCaption: TCaption;\r\nbegin\r\n Result := FButton.Caption;\r\nend;\r\n\r\nprocedure TJvSpeedItem.SetBtnCaption(const Value: TCaption);\r\nbegin\r\n FButton.Caption := Value;\r\nend;\r\n\r\nfunction TJvSpeedItem.GetGroupIndex: Integer;\r\nbegin\r\n Result := FButton.GroupIndex;\r\nend;\r\n\r\nprocedure TJvSpeedItem.SetGroupIndex(Value: Integer);\r\nbegin\r\n FButton.GroupIndex := Value;\r\nend;\r\n\r\nfunction TJvSpeedItem.GetOnClick: TNotifyEvent;\r\nbegin\r\n Result := FButton.OnClick;\r\nend;\r\n\r\nprocedure TJvSpeedItem.SetOnClick(Value: TNotifyEvent);\r\nbegin\r\n FButton.OnClick := Value;\r\nend;\r\n\r\nfunction TJvSpeedItem.GetOnDblClick: TNotifyEvent;\r\nbegin\r\n Result := FButton.OnDblClick;\r\nend;\r\n\r\nprocedure TJvSpeedItem.SetOnDblClick(Value: TNotifyEvent);\r\nbegin\r\n FButton.OnDblClick := Value;\r\nend;\r\n\r\nfunction TJvSpeedItem.GetOnMouseDown: TMouseEvent;\r\nbegin\r\n Result := FButton.OnMouseDown;\r\nend;\r\n\r\nprocedure TJvSpeedItem.SetOnMouseDown(Value: TMouseEvent);\r\nbegin\r\n FButton.OnMouseDown := Value;\r\nend;\r\n\r\nfunction TJvSpeedItem.GetOnMouseMove: TMouseMoveEvent;\r\nbegin\r\n Result := FButton.OnMouseMove;\r\nend;\r\n\r\nprocedure TJvSpeedItem.SetOnMouseMove(Value: TMouseMoveEvent);\r\nbegin\r\n FButton.OnMouseMove := Value;\r\nend;\r\n\r\nfunction TJvSpeedItem.GetOnMouseUp: TMouseEvent;\r\nbegin\r\n Result := FButton.OnMouseUp;\r\nend;\r\n\r\nprocedure TJvSpeedItem.SetOnMouseUp(Value: TMouseEvent);\r\nbegin\r\n FButton.OnMouseUp := Value;\r\nend;\r\n\r\nfunction TJvSpeedItem.GetOnMouseEnter: TNotifyEvent;\r\nbegin\r\n Result := FButton.OnMouseEnter;\r\nend;\r\n\r\nprocedure TJvSpeedItem.SetOnMouseEnter(Value: TNotifyEvent);\r\nbegin\r\n FButton.OnMouseEnter := Value;\r\nend;\r\n\r\nfunction TJvSpeedItem.GetOnMouseLeave: TNotifyEvent;\r\nbegin\r\n Result := FButton.OnMouseLeave;\r\nend;\r\n\r\nprocedure TJvSpeedItem.SetOnMouseLeave(Value: TNotifyEvent);\r\nbegin\r\n FButton.OnMouseLeave := Value;\r\nend;\r\n\r\nfunction TJvSpeedItem.GetDown: Boolean;\r\nbegin\r\n Result := FButton.Down;\r\nend;\r\n\r\nprocedure TJvSpeedItem.SetDown(Value: Boolean);\r\nbegin\r\n FButton.Down := Value;\r\nend;\r\n\r\nfunction TJvSpeedItem.GetGlyph: TBitmap;\r\nbegin\r\n Result := FButton.Glyph;\r\nend;\r\n\r\nprocedure TJvSpeedItem.SetGlyph(Value: TBitmap);\r\nbegin\r\n FButton.Glyph := Value;\r\nend;\r\n\r\nfunction TJvSpeedItem.GetLayout: TButtonLayout;\r\nbegin\r\n Result := FButton.Layout;\r\nend;\r\n\r\nprocedure TJvSpeedItem.SetLayout(Value: TButtonLayout);\r\nbegin\r\n FButton.Layout := Value;\r\nend;\r\n\r\nfunction TJvSpeedItem.GetMargin: Integer;\r\nbegin\r\n Result := FButton.Margin;\r\nend;\r\n\r\nprocedure TJvSpeedItem.SetMargin(Value: Integer);\r\nbegin\r\n FButton.Margin := Value;\r\nend;\r\n\r\nfunction TJvSpeedItem.GetNumGlyphs: TJvNumGlyphs;\r\nbegin\r\n Result := FButton.NumGlyphs;\r\nend;\r\n\r\nprocedure TJvSpeedItem.SetNumGlyphs(Value: TJvNumGlyphs);\r\nbegin\r\n FButton.NumGlyphs := Value;\r\nend;\r\n\r\nfunction TJvSpeedItem.GetParentShowHint: Boolean;\r\nbegin\r\n Result := FButton.ParentShowHint;\r\nend;\r\n\r\nprocedure TJvSpeedItem.SetParentShowHint(Value: Boolean);\r\nbegin\r\n FButton.ParentShowHint := Value;\r\nend;\r\n\r\nfunction TJvSpeedItem.GetShowHint: Boolean;\r\nbegin\r\n Result := FButton.ShowHint;\r\nend;\r\n\r\nprocedure TJvSpeedItem.SetShowHint(Value: Boolean);\r\nbegin\r\n FButton.ShowHint := Value;\r\nend;\r\n\r\nfunction TJvSpeedItem.GetFont: TFont;\r\nbegin\r\n Result := FButton.Font;\r\nend;\r\n\r\nprocedure TJvSpeedItem.SetFont(Value: TFont);\r\nbegin\r\n FButton.Font := Value;\r\nend;\r\n\r\nfunction TJvSpeedItem.GetParentFont: Boolean;\r\nbegin\r\n Result := FButton.ParentFont;\r\nend;\r\n\r\nprocedure TJvSpeedItem.SetParentFont(Value: Boolean);\r\nbegin\r\n FButton.ParentFont := Value;\r\nend;\r\n\r\nfunction TJvSpeedItem.IsFontStored: Boolean;\r\nbegin\r\n Result := not ParentFont;\r\nend;\r\n\r\nfunction TJvSpeedItem.IsShowHintStored: Boolean;\r\nbegin\r\n Result := not ParentShowHint;\r\nend;\r\n\r\nfunction TJvSpeedItem.GetSpacing: Integer;\r\nbegin\r\n Result := FButton.Spacing;\r\nend;\r\n\r\nprocedure TJvSpeedItem.SetSpacing(Value: Integer);\r\nbegin\r\n FButton.Spacing := Value;\r\nend;\r\n\r\nfunction TJvSpeedItem.GetCursor: TCursor;\r\nbegin\r\n Result := FButton.Cursor;\r\nend;\r\n\r\nprocedure TJvSpeedItem.SetCursor(Value: TCursor);\r\nbegin\r\n FButton.Cursor := Value;\r\nend;\r\n\r\nfunction TJvSpeedItem.GetHint: string;\r\nbegin\r\n Result := FButton.Hint;\r\nend;\r\n\r\nprocedure TJvSpeedItem.SetHint(const Value: string);\r\nbegin\r\n FButton.Hint := Value;\r\nend;\r\n\r\nfunction TJvSpeedItem.GetAction: TBasicAction;\r\nbegin\r\n Result := FButton.Action;\r\nend;\r\n\r\nprocedure TJvSpeedItem.SetAction(Value: TBasicAction);\r\nbegin\r\n FButton.Action := Value;\r\nend;\r\n\r\nprocedure TJvSpeedItem.ButtonClick;\r\nbegin\r\n FButton.ButtonClick;\r\nend;\r\n\r\nfunction TJvSpeedItem.CheckBtnMenuDropDown: Boolean;\r\nbegin\r\n Result := FButton.CheckBtnMenuDropDown;\r\nend;\r\n\r\nprocedure TJvSpeedItem.Click;\r\nbegin\r\n FButton.Click;\r\nend;\r\n\r\nfunction TJvSpeedItem.GetTag: Longint;\r\nbegin\r\n Result := inherited Tag;\r\nend;\r\n\r\nprocedure TJvSpeedItem.SetTag(Value: Longint);\r\nbegin\r\n inherited Tag := Value;\r\n FButton.Tag := Value;\r\nend;\r\n\r\nfunction TJvSpeedItem.GetDropDownMenu: TPopupMenu;\r\nbegin\r\n Result := FButton.DropDownMenu;\r\nend;\r\n\r\nprocedure TJvSpeedItem.SetDropDownMenu(Value: TPopupMenu);\r\nbegin\r\n FButton.DropDownMenu := Value;\r\nend;\r\n\r\nfunction TJvSpeedItem.GetMarkDropDown: Boolean;\r\nbegin\r\n Result := FButton.MarkDropDown;\r\nend;\r\n\r\nprocedure TJvSpeedItem.SetMarkDropDown(Value: Boolean);\r\nbegin\r\n FButton.MarkDropDown := Value;\r\nend;\r\n\r\nfunction TJvSpeedItem.GetWordWrap: Boolean;\r\nbegin\r\n Result := FButton.WordWrap;\r\nend;\r\n\r\nprocedure TJvSpeedItem.SetWordWrap(Value: Boolean);\r\nbegin\r\n FButton.WordWrap := Value;\r\nend;\r\n\r\nfunction TJvSpeedItem.GetLeft: Integer;\r\nbegin\r\n Result := FButton.Left;\r\nend;\r\n\r\nfunction TJvSpeedItem.GetTop: Integer;\r\nbegin\r\n Result := FButton.Top;\r\nend;\r\n\r\nprocedure TJvSpeedItem.SetLeft(Value: Integer);\r\nbegin\r\n FButton.Left := Value;\r\nend;\r\n\r\nprocedure TJvSpeedItem.SetTop(Value: Integer);\r\nbegin\r\n FButton.Top := Value;\r\nend;\r\n\r\nconst\r\n InternalVer = 1;\r\n\r\n//=== { TJvSpeedBar } ========================================================\r\n\r\nconstructor TJvSpeedBar.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FSections := TList.Create;\r\n FButtonSize := DefaultButtonSize;\r\n FButtonStyle := bsNew;\r\n FWallpaper := TPicture.Create;\r\n FWallpaper.OnChange := WallpaperChanged;\r\n FIniLink := TJvIniLink.Create;\r\n FIniLink.OnSave := IniSave;\r\n FIniLink.OnLoad := IniLoad;\r\n FOffset.X := MinButtonsOffset;\r\n FOffset.Y := FOffset.X;\r\n Height := 2 * FOffset.Y + DefaultButtonSize.Y;\r\n FRowCount := 1;\r\n FEditWin := NullHandle;\r\n FOptions := [sbAllowDrag, sbGrayedBtns];\r\n ControlStyle := ControlStyle - [csSetCaption, csReplicatable];\r\n IncludeThemeStyle(Self, [csNeedsBorderPaint, csParentBackground]);\r\n ParentShowHint := False;\r\n ShowHint := True;\r\n SetFontDefault;\r\n inherited Align := alTop;\r\n FAlign := alTop;\r\n UpdateGridSize;\r\n FImageChangeLink := TChangeLink.Create;\r\n FImageChangeLink.OnChange := ImageListChange;\r\n if not Registered then\r\n begin\r\n {$IFDEF COMPILER7_UP}\r\n GroupDescendentsWith(TJvSpeedItem, TControl);\r\n GroupDescendentsWith(TJvSpeedBarSection, TControl);\r\n {$ENDIF COMPILER7_UP}\r\n RegisterClasses([TJvSpeedItem, TJvSpeedBarSection, TJvSpeedBarButton]);\r\n Registered := True;\r\n end;\r\nend;\r\n\r\ndestructor TJvSpeedBar.Destroy;\r\nbegin\r\n FOnVisibleChanged := nil;\r\n FOnApplyAlign := nil;\r\n FOnPosChanged := nil;\r\n FIniLink.Free;\r\n FWallpaper.OnChange := nil;\r\n FWallpaper.Free;\r\n FWallpaper := nil;\r\n if FEditWin <> NullHandle then\r\n begin\r\n SendMessage(FEditWin, CM_SPEEDBARCHANGED, SBR_DESTROYED, LPARAM(Self));\r\n FEditWin := NullHandle;\r\n end;\r\n ClearSections;\r\n FSections.Free;\r\n FImageChangeLink.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvSpeedBar.Loaded;\r\nbegin\r\n inherited Loaded;\r\n if (FReserved = 0) and FFix then\r\n begin { fix previous version error }\r\n inherited Align := alTop;\r\n FAlign := alTop;\r\n end;\r\n UpdateGridSize;\r\n ForEachItem(SetItemButtonSize, 0);\r\nend;\r\n\r\nprocedure TJvSpeedBar.ReadData(Reader: TReader);\r\nbegin\r\n FReserved := Reader.ReadInteger;\r\nend;\r\n\r\nprocedure TJvSpeedBar.WriteData(Writer: TWriter);\r\nbegin\r\n Writer.WriteInteger(InternalVer);\r\nend;\r\n\r\nprocedure TJvSpeedBar.ReadAllowDrag(Reader: TReader);\r\nbegin\r\n if Reader.ReadBoolean then\r\n Options := Options + [sbAllowDrag]\r\n else\r\n Options := Options - [sbAllowDrag];\r\nend;\r\n\r\nprocedure TJvSpeedBar.ReadDesignStyle(Reader: TReader);\r\nbegin\r\n FDesignStyle := Reader.ReadBoolean;\r\nend;\r\n\r\nprocedure TJvSpeedBar.WriteDesignStyle(Writer: TWriter);\r\nbegin\r\n Writer.WriteBoolean(True);\r\nend;\r\n\r\nprocedure TJvSpeedBar.ReadSections(Reader: TReader);\r\nvar\r\n TmpList: TStringList;\r\n I: Integer;\r\nbegin\r\n TmpList := TStringList.Create;\r\n try\r\n Reader.ReadListBegin;\r\n while not Reader.EndOfList do\r\n TmpList.AddObject(Reader.ReadString, nil);\r\n Reader.ReadListEnd;\r\n if (Reader.Ancestor = nil) or (TmpList.Count > 0) then\r\n for I := 0 to TmpList.Count - 1 do\r\n if SearchSection(TmpList[I]) < 0 then\r\n AddSection(TmpList[I]);\r\n finally\r\n TmpList.Free;\r\n end;\r\nend;\r\n\r\nprocedure TJvSpeedBar.WriteSections(Writer: TWriter);\r\nvar\r\n I: Integer;\r\nbegin\r\n Writer.WriteListBegin;\r\n for I := 0 to FSections.Count - 1 do\r\n Writer.WriteString(Sections[I].Caption);\r\n Writer.WriteListEnd;\r\nend;\r\n\r\nprocedure TJvSpeedBar.DefineProperties(Filer: TFiler);\r\nbegin\r\n inherited DefineProperties(Filer);\r\n Filer.DefineProperty('Sections', ReadSections, WriteSections, False);\r\n Filer.DefineProperty('NewStyle', ReadDesignStyle, WriteDesignStyle, False);\r\n Filer.DefineProperty('InternalVer', ReadData, WriteData,Filer.Ancestor = nil);\r\n { AllowDrag reading for backward compatibility only }\r\n Filer.DefineProperty('AllowDrag', ReadAllowDrag, nil, False);\r\nend;\r\n\r\nfunction TJvSpeedBar.GetSection(Index: Integer): TJvSpeedBarSection;\r\nbegin\r\n Result := TJvSpeedBarSection(FSections[Index]);\r\nend;\r\n\r\nfunction TJvSpeedBar.GetSectionCount: Integer;\r\nbegin\r\n Result := FSections.Count;\r\nend;\r\n\r\nprocedure TJvSpeedBar.ForEachItem(Proc: TForEachItem; Data: SizeInt);\r\nvar\r\n I, Idx: Integer;\r\n Sect: TJvSpeedBarSection;\r\nbegin\r\n for I := 0 to FSections.Count - 1 do\r\n if FSections[I] <> nil then\r\n begin\r\n Sect := TJvSpeedBarSection(FSections[I]);\r\n for Idx := 0 to Sect.Count - 1 do\r\n begin\r\n if (Sect[Idx] <> nil) and Assigned(Proc) then\r\n Proc(TJvSpeedItem(Sect[Idx]), Data);\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJvSpeedBar.MinButtonsOffset: Integer;\r\nbegin\r\n Result := BorderWidth + 2 * Ord(not (sbFlatBtns in Options));\r\n if BevelOuter <> bvNone then\r\n Inc(Result, BevelWidth);\r\n if BevelInner <> bvNone then\r\n Inc(Result, BevelWidth);\r\nend;\r\n\r\nprocedure TJvSpeedBar.SetItemVisible(Item: TJvSpeedItem; Data: SizeInt);\r\nvar\r\n ItemVisible: Boolean;\r\nbegin\r\n ItemVisible := Item.Visible and Self.Visible;\r\n Item.FButton.Visible := ItemVisible;\r\n if (Item.FButton.Parent <> Self) and ItemVisible then\r\n Item.FButton.Parent := Self;\r\nend;\r\n\r\nprocedure TJvSpeedBar.SetItemEnabled(Item: TJvSpeedItem; Data: SizeInt);\r\nbegin\r\n Item.FButton.Enabled := Item.Enabled and Self.Enabled;\r\nend;\r\n\r\nprocedure TJvSpeedBar.SetItemButtonSize(Item: TJvSpeedItem; Data: SizeInt);\r\nbegin\r\n ApplyItemSize(Item, Data);\r\n Item.Visible := Item.Visible; { update visible and parent after loading }\r\nend;\r\n\r\nprocedure TJvSpeedBar.SwapItemBounds(Item: TJvSpeedItem; Data: SizeInt);\r\nbegin\r\n Item.FButton.SetBounds(Item.Top, Item.Left, FButtonSize.X, FButtonSize.Y);\r\nend;\r\n\r\nprocedure TJvSpeedBar.SetFontDefault;\r\n\r\nvar\r\n NCMetrics: TNonClientMetrics;\r\nbegin\r\n ParentFont := False;\r\n with Font do\r\n begin\r\n {$IFDEF RTL210_UP}\r\n NCMetrics.cbSize := TNonClientMetrics.SizeOf;\r\n {$ELSE}\r\n NCMetrics.cbSize := SizeOf(TNonClientMetrics);\r\n {$ENDIF RTL210_UP}\r\n if SystemParametersInfo(SPI_GETNONCLIENTMETRICS, NCMetrics.cbSize, @NCMetrics, 0) then\r\n begin\r\n Handle := CreateFontIndirect(NCMetrics.lfMenuFont);\r\n Charset := DEFAULT_CHARSET;\r\n end\r\n else\r\n begin\r\n Name := 'MS Sans Serif';\r\n Size := 8;\r\n Style := [];\r\n Color := clBtnText;\r\n end;\r\n end;\r\nend;\r\n\r\n\r\n\r\nprocedure TJvSpeedBar.VisibleChanged;\r\nbegin\r\n inherited VisibleChanged;\r\n if not (csLoading in ComponentState) then\r\n ForEachItem(SetItemVisible, 0);\r\n if Assigned(FOnVisibleChanged) then\r\n FOnVisibleChanged(Self);\r\nend;\r\n\r\nprocedure TJvSpeedBar.EnabledChanged;\r\nbegin\r\n inherited EnabledChanged;\r\n if not ((csLoading in ComponentState) or (csDesigning in ComponentState)) then\r\n ForEachItem(SetItemEnabled, 0);\r\nend;\r\n\r\nprocedure TJvSpeedBar.WallpaperChanged(Sender: TObject);\r\nbegin\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvSpeedBar.SetWallpaper(Value: TPicture);\r\nbegin\r\n FWallpaper.Assign(Value);\r\nend;\r\n\r\nprocedure TJvSpeedBar.ClearSections;\r\nbegin\r\n while FSections.Count > 0 do\r\n RemoveSection(FSections.Count - 1);\r\n FSections.Clear;\r\nend;\r\n\r\nfunction TJvSpeedBar.Items(Section, Index: Integer): TJvSpeedItem;\r\nvar\r\n List: TJvSpeedBarSection;\r\nbegin\r\n Result := nil;\r\n if (Section >= 0) and (Section < FSections.Count) then\r\n begin\r\n List := Sections[Section];\r\n if List <> nil then\r\n if (Index >= 0) and (Index < List.Count) then\r\n Result := List[Index];\r\n end;\r\nend;\r\n\r\nfunction TJvSpeedBar.ItemsCount(Section: Integer): Integer;\r\nbegin\r\n Result := 0;\r\n if (Section >= 0) and (Section < FSections.Count) then\r\n begin\r\n if FSections[Section] <> nil then\r\n Result := Sections[Section].Count;\r\n end;\r\nend;\r\n\r\nprocedure TJvSpeedBar.RemoveSection(Section: Integer);\r\nvar\r\n Sect: TJvSpeedBarSection;\r\n Item: TJvSpeedItem;\r\nbegin\r\n Sect := Sections[Section];\r\n if Sect <> nil then\r\n begin\r\n while Sect.Count > 0 do\r\n begin\r\n Item := Sect[0];\r\n Item.Free;\r\n end;\r\n Sect.FParent := nil;\r\n Sect.Free;\r\n FSections[Section] := nil;\r\n end;\r\n FSections.Delete(Section);\r\nend;\r\n\r\nprocedure TJvSpeedBar.DeleteSection(Section: Integer);\r\nvar\r\n Sect: TJvSpeedBarSection;\r\n I: Integer;\r\nbegin\r\n Sect := Sections[Section];\r\n if Sect <> nil then\r\n begin\r\n for I := Sect.Count - 1 downto 0 do\r\n RemoveItem(TJvSpeedItem(Sect[I]));\r\n Sect.FParent := nil;\r\n FSections[Section] := nil;\r\n end;\r\n FSections.Delete(Section);\r\nend;\r\n\r\nprocedure TJvSpeedBar.RemoveItem(Item: TJvSpeedItem);\r\nvar\r\n I, Index: Integer;\r\nbegin\r\n if FindItem(Item, I, Index) then\r\n begin\r\n Item.FButton.Parent := nil;\r\n Item.FParent := nil;\r\n Item.FSection := -1;\r\n Sections[I].FList.Delete(Index);\r\n end;\r\nend;\r\n\r\nfunction TJvSpeedBar.SearchSection(const ACaption: string): Integer;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := -1;\r\n for I := 0 to FSections.Count - 1 do\r\n if Sections[I].Caption = ACaption then\r\n begin\r\n Result := I;\r\n Exit;\r\n end;\r\nend;\r\n\r\nfunction TJvSpeedBar.AppendSection(Value: TJvSpeedBarSection): Integer;\r\nvar\r\n UniqueName: string;\r\n I: Integer;\r\nbegin\r\n I := 0;\r\n UniqueName := Value.Caption;\r\n while SearchSection(UniqueName) >= 0 do\r\n begin\r\n Inc(I);\r\n UniqueName := Value.Caption + Format(' (%d)', [I]);\r\n end;\r\n Value.Caption := UniqueName;\r\n Result := FSections.Add(Value);\r\n if Result >= 0 then\r\n begin\r\n Value.FParent := Self;\r\n for I := 0 to Value.Count - 1 do\r\n begin\r\n Value[I].FSection := Result;\r\n SetItemParams(Value[I], not (csLoading in ComponentState));\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJvSpeedBar.AddSection(const ACaption: string): Integer;\r\nvar\r\n Section: TJvSpeedBarSection;\r\nbegin\r\n if Owner <> nil then\r\n Section := TJvSpeedBarSection.Create(Owner)\r\n else\r\n Section := TJvSpeedBarSection.Create(Self);\r\n Section.Caption := ACaption;\r\n Result := AppendSection(Section);\r\nend;\r\n\r\nprocedure TJvSpeedBar.SetItemParams(Item: TJvSpeedItem; InitBounds: Boolean);\r\nbegin\r\n with Item do\r\n begin\r\n FParent := Self;\r\n with FButton do\r\n begin\r\n if InitBounds then\r\n SetBounds(0, 0, BtnWidth, BtnHeight);\r\n Style := FButtonStyle;\r\n Flat := (sbFlatBtns in Options);\r\n Transparent := (sbTransparentBtns in Options);\r\n GrayedInactive := (sbGrayedBtns in Options);\r\n end;\r\n SetEditing(FEditWin <> NullHandle);\r\n end;\r\nend;\r\n\r\nfunction TJvSpeedBar.NewItem(AOwner: TComponent; Section: Integer;\r\n const AName: string): TJvSpeedItem;\r\nbegin\r\n Result := nil;\r\n if (Section >= 0) and (Section < FSections.Count) then\r\n begin\r\n Result := TJvSpeedItem.Create(AOwner);\r\n try\r\n Sections[Section].FList.Add(Result);\r\n Result.FSection := Section;\r\n SetItemParams(Result, True);\r\n if AName <> '' then\r\n with Result do\r\n begin\r\n Name := AName;\r\n Caption := AName;\r\n FButton.Visible := False;\r\n FButton.Parent := Self;\r\n end;\r\n except\r\n Result.Free;\r\n raise;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvSpeedBar.AddItem(Section: Integer; Item: TJvSpeedItem);\r\nvar\r\n I, Index: Integer;\r\nbegin\r\n if FindItem(Item, I, Index) then\r\n begin\r\n Sections[I].FList.Delete(Index);\r\n if Section >= FSections.Count then\r\n Section := FSections.Count - 1;\r\n Sections[Section].FList.Add(Item);\r\n Item.FSection := Section;\r\n Exit;\r\n end;\r\n if (Section >= 0) and (Item <> nil) then\r\n begin\r\n if Assigned(FOnAddItem) then\r\n begin\r\n FOnAddItem(Item);\r\n Section := Item.FSection;\r\n end;\r\n if FSections.Count = 0 then\r\n Section := AddSection('')\r\n else\r\n if Section >= FSections.Count then\r\n Section := FSections.Count - 1;\r\n Sections[Section].FList.Add(Item);\r\n Item.FSection := Section;\r\n SetItemParams(Item, not (csLoading in ComponentState));\r\n Item.FButton.Visible := False;\r\n Item.FButton.Parent := Self;\r\n end;\r\nend;\r\n\r\nfunction TJvSpeedBar.FindItem(Item: TJvSpeedItem; var Section,\r\n Index: Integer): Boolean;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := False;\r\n Section := -1;\r\n for I := 0 to FSections.Count - 1 do\r\n if FSections[I] <> nil then\r\n begin\r\n Index := Sections[I].FList.IndexOf(Item);\r\n if Index >= 0 then\r\n begin\r\n Section := I;\r\n Result := True;\r\n Exit;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvSpeedBar.AlignItemsToGrid;\r\nbegin\r\n ForEachItem(AlignItemToGrid, 0);\r\nend;\r\n\r\nprocedure TJvSpeedBar.AlignItemToGrid(Item: TJvSpeedItem; Data: SizeInt);\r\nbegin\r\n if Item.Visible then\r\n begin\r\n if GetOrientation = boVertical then\r\n begin\r\n Item.Left := Trunc((Item.Left - FOffset.X) / FGridSize.X) * FGridSize.X + FOffset.X;\r\n Item.Top := Round((Item.Top - FOffset.Y) / FGridSize.Y) * FGridSize.Y + FOffset.Y;\r\n end\r\n else\r\n begin\r\n Item.Left := Round((Item.Left - FOffset.X) / FGridSize.X) * FGridSize.X + FOffset.X;\r\n Item.Top := Trunc((Item.Top - FOffset.Y) / FGridSize.Y) * FGridSize.Y + FOffset.Y;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJvSpeedBar.AcceptDropItem(Item: TJvSpeedItem; X, Y: Integer): Boolean;\r\nvar\r\n I, Sect: Integer;\r\nbegin\r\n Result := False;\r\n if FindItem(Item, Sect, I) then\r\n begin\r\n if GetOrientation = boVertical then\r\n begin\r\n X := Trunc((X - FOffset.X) / FGridSize.X) * FGridSize.X + FOffset.X;\r\n Y := Round((Y - FOffset.Y) / FGridSize.Y) * FGridSize.Y + FOffset.Y;\r\n end\r\n else\r\n begin\r\n X := Round((X - FOffset.X) / FGridSize.X) * FGridSize.X + FOffset.X;\r\n Y := Trunc((Y - FOffset.Y) / FGridSize.Y) * FGridSize.Y + FOffset.Y;\r\n end;\r\n Item.Left := X;\r\n Item.Top := Y;\r\n Result := PtInRect(ClientRect, Point(X, Y));\r\n if Result then\r\n Item.FButton.BringToFront\r\n else\r\n Item.FButton.SendToBack;\r\n Item.Visible := Result;\r\n end;\r\nend;\r\n\r\nprocedure TJvSpeedBar.SetItemEditing(Item: TJvSpeedItem; Data: SizeInt);\r\nbegin\r\n Item.SetEditing(FEditWin <> NullHandle);\r\nend;\r\n\r\nfunction TJvSpeedBar.GetEditing: Boolean;\r\nbegin\r\n Result := (FEditWin <> NullHandle);\r\nend;\r\n\r\nprocedure TJvSpeedBar.SetEditing(Win: THandle);\r\nbegin\r\n FEditWin := Win;\r\n ForEachItem(SetItemEditing, 0);\r\n if (FEditWin = NullHandle) and not (csDesigning in ComponentState) then\r\n AfterCustomize;\r\nend;\r\n\r\nprocedure TJvSpeedBar.Paint;\r\nvar\r\n XCnt, YCnt, X, Y: Integer;\r\n BevelSize, SaveIndex: Integer;\r\n Rect: TRect;\r\n C1, C2: TColor;\r\n\r\n procedure BevelLine(C: TColor; X1, Y1, X2, Y2: Integer);\r\n begin\r\n with Canvas do\r\n begin\r\n Pen.Color := C;\r\n MoveTo(X1, Y1);\r\n LineTo(X2, Y2);\r\n end;\r\n end;\r\n\r\nbegin\r\n if not FLocked then\r\n begin\r\n Rect := ClientRect;\r\n BevelSize := BorderWidth;\r\n if BevelOuter <> bvNone then\r\n Inc(BevelSize, BevelWidth);\r\n if BevelInner <> bvNone then\r\n Inc(BevelSize, BevelWidth);\r\n InflateRect(Rect, -BevelSize, -BevelSize);\r\n inherited Paint;\r\n Canvas.Brush.Color := Color;\r\n {$IFDEF JVCLThemesEnabled}\r\n if ThemeServices.{$IFDEF RTL230_UP}Enabled{$ELSE}ThemesEnabled{$ENDIF RTL230_UP} and ParentBackground then\r\n begin\r\n Canvas.Brush.Color := Parent.Brush.Color;\r\n DrawThemedBackground(Self, Canvas, Rect);\r\n end\r\n else\r\n {$ENDIF JVCLThemesEnabled}\r\n Canvas.FillRect(Rect);\r\n if (FWallpaper.Graphic <> nil) and (FWallpaper.Width > 0) and\r\n (FWallpaper.Height > 0) then\r\n begin\r\n SaveIndex := SaveDC(Canvas.Handle);\r\n try\r\n IntersectClipRect(Canvas.Handle, Rect.Left, Rect.Top, Rect.Right - Rect.Left +\r\n BevelSize, Rect.Bottom - Rect.Top + BevelSize);\r\n if sbStretchBitmap in Options then\r\n Canvas.StretchDraw(Rect, FWallpaper.Graphic)\r\n else\r\n begin\r\n XCnt := (ClientWidth - 2 * BevelSize) div FWallpaper.Width;\r\n YCnt := (ClientHeight - 2 * BevelSize) div FWallpaper.Height;\r\n for X := 0 to XCnt do\r\n for Y := 0 to YCnt do\r\n Canvas.Draw(Rect.Left + X * FWallpaper.Width,\r\n Rect.Top + Y * FWallpaper.Height, FWallpaper.Graphic);\r\n end;\r\n finally\r\n RestoreDC(Canvas.Handle, SaveIndex);\r\n end;\r\n end;\r\n if FBoundLines <> [] then\r\n begin\r\n C1 := clBtnShadow;\r\n C2 := clBtnHighlight;\r\n if blTop in FBoundLines then\r\n begin\r\n BevelLine(C1, Rect.Left, Rect.Top, Rect.Right, Rect.Top);\r\n BevelLine(C2, Rect.Left, Rect.Top + 1, Rect.Right, Rect.Top + 1);\r\n end;\r\n if blLeft in FBoundLines then\r\n begin\r\n BevelLine(C1, Rect.Left, Rect.Top, Rect.Left, Rect.Bottom);\r\n BevelLine(C2, Rect.Left + 1, Rect.Top + Ord(blTop in FBoundLines), Rect.Left + 1, Rect.Bottom);\r\n end;\r\n if blBottom in FBoundLines then\r\n begin\r\n BevelLine(C1, Rect.Left, Rect.Bottom - 2, Rect.Right, Rect.Bottom - 2);\r\n BevelLine(C2, Rect.Left, Rect.Bottom - 1, Rect.Right, Rect.Bottom - 1);\r\n end;\r\n if blRight in FBoundLines then\r\n begin\r\n BevelLine(C1, Rect.Right - 2, Rect.Top, Rect.Right - 2, Rect.Bottom - Ord(blBottom in FBoundLines));\r\n BevelLine(C2, Rect.Right - 1, Rect.Top, Rect.Right - 1, Rect.Bottom);\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvSpeedBar.ApplyOrientation(Value: TBarOrientation);\r\nbegin\r\n if (GetOrientation <> Value) and not (csReading in ComponentState) then\r\n begin\r\n FLocked := True;\r\n try\r\n FOrientation := Value;\r\n SwapInt(Integer(FButtonSize.X), Integer(FButtonSize.Y));\r\n SwapInt(Integer(FGridSize.X), Integer(FGridSize.Y));\r\n SwapInt(Integer(FOffset.X), Integer(FOffset.Y));\r\n ForEachItem(SwapItemBounds, 0);\r\n finally\r\n FLocked := False;\r\n Invalidate;\r\n end;\r\n if FEditWin <> NullHandle then\r\n SendMessage(FEditWin, CM_SPEEDBARCHANGED, SBR_BTNSIZECHANGED, LPARAM(Self));\r\n end;\r\nend;\r\n\r\nprocedure TJvSpeedBar.SetOrientation(Value: TBarOrientation);\r\nbegin\r\n if GetOrientation <> Value then\r\n begin\r\n if FPosition = bpAuto then\r\n raise EJvSpeedbarError.CreateRes(@RsEAutoSpeedbarMode);\r\n ApplyOrientation(Value);\r\n end;\r\nend;\r\n\r\nfunction TJvSpeedBar.GetOrientation: TBarOrientation;\r\nbegin\r\n if FPosition = bpCustom then\r\n Result := FOrientation\r\n else\r\n case Align of\r\n alLeft, alRight:\r\n Result := boVertical;\r\n alTop, alBottom:\r\n Result := boHorizontal;\r\n else\r\n Result := FOrientation;\r\n end;\r\nend;\r\n\r\nfunction TJvSpeedBar.GetAlign: TAlign;\r\nbegin\r\n Result := FAlign;\r\nend;\r\n\r\nprocedure TJvSpeedBar.SetAlign(Value: TAlign);\r\nvar\r\n X, Y: Integer;\r\nbegin\r\n { fix previous version error }\r\n if (csLoading in ComponentState) and (Value = alNone) and\r\n (Position = bpAuto) then\r\n FFix := True;\r\n if Align <> Value then\r\n begin\r\n X := Width;\r\n Y := Height;\r\n if (FPosition = bpAuto) and (Value in [alClient, alNone]) then\r\n raise EJvSpeedbarError.CreateRes(@RsEAutoSpeedbarMode);\r\n inherited Align := Value;\r\n if csLoading in ComponentState then\r\n begin\r\n Width := X;\r\n Height := Y;\r\n end;\r\n if FPosition = bpAuto then\r\n case Value of\r\n alLeft, alRight:\r\n ApplyOrientation(boVertical);\r\n alTop, alBottom:\r\n ApplyOrientation(boHorizontal);\r\n else\r\n if not (csLoading in ComponentState) then\r\n raise EJvSpeedbarError.CreateRes(@RsEAutoSpeedbarMode);\r\n end;\r\n FAlign := inherited Align;\r\n end;\r\nend;\r\n\r\n\r\nprocedure TJvSpeedBar.ChangeScale(M, D: Integer);\r\n\r\nvar\r\n Flags: TSbScaleFlags;\r\nbegin\r\n DisableAlign;\r\n try\r\n if csLoading in ComponentState then\r\n Flags := ScaleFlags\r\n else\r\n Flags := [sfOffsetX, sfOffsetY, sfBtnSizeX, sfBtnSizeY];\r\n if (sfBtnSizeX in Flags) and not (csFixedWidth in ControlStyle) then\r\n FButtonSize.X := MulDiv(FButtonSize.X, M, D);\r\n if sfOffsetX in Flags then\r\n FOffset.X := MulDiv(FOffset.X, M, D);\r\n if (sfBtnSizeY in Flags) and not (csFixedHeight in ControlStyle) then\r\n FButtonSize.Y := MulDiv(FButtonSize.Y, M, D);\r\n if sfOffsetY in Flags then\r\n FOffset.Y := MulDiv(FOffset.Y, M, D);\r\n UpdateGridSize;\r\n inherited ChangeScale(M, D );\r\n ApplyButtonSize;\r\n AlignItemsToGrid;\r\n FScaleFlags := [];\r\n finally\r\n EnableAlign;\r\n end;\r\nend;\r\n\r\nprocedure TJvSpeedBar.AlignControls(AControl: TControl; var Rect: TRect);\r\nvar\r\n P: TPoint;\r\n Min: Integer;\r\nbegin\r\n if FBoundLines <> [] then\r\n begin\r\n if blTop in FBoundLines then\r\n Inc(Rect.Top, 2);\r\n if blBottom in FBoundLines then\r\n Dec(Rect.Bottom, 2);\r\n if blLeft in FBoundLines then\r\n Inc(Rect.Left, 2);\r\n if blRight in FBoundLines then\r\n Dec(Rect.Right, 2);\r\n end;\r\n inherited AlignControls(AControl, Rect);\r\n Min := MinButtonsOffset;\r\n if FOffset.X < Min then\r\n begin\r\n P.X := Min - FOffset.X;\r\n FOffset.X := Min;\r\n end\r\n else\r\n P.X := 0;\r\n if FOffset.Y < Min then\r\n begin\r\n P.Y := Min - FOffset.Y;\r\n FOffset.Y := Min;\r\n end\r\n else\r\n P.Y := 0;\r\n if not (csLoading in ComponentState) and ((P.X <> 0) or (P.Y <> 0)) then\r\n ForEachItem(OffsetItem, SizeInt(@P));\r\nend;\r\n\r\nprocedure TJvSpeedBar.FlatItem(Item: TJvSpeedItem; Data: SizeInt);\r\nbegin\r\n Item.FButton.Flat := Boolean(Data);\r\nend;\r\n\r\nprocedure TJvSpeedBar.GrayedItem(Item: TJvSpeedItem; Data: SizeInt);\r\nbegin\r\n Item.FButton.GrayedInactive := Boolean(Data);\r\nend;\r\n\r\nprocedure TJvSpeedBar.TransparentItem(Item: TJvSpeedItem; Data: SizeInt);\r\nbegin\r\n Item.FButton.Transparent := Boolean(Data);\r\nend;\r\n\r\nprocedure TJvSpeedBar.SetBoundLines(Value: TBoundLines);\r\nbegin\r\n if FBoundLines <> Value then\r\n begin\r\n FBoundLines := Value;\r\n Realign;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvSpeedBar.SetOptions(Value: TJvSpeedBarOptions);\r\nvar\r\n FlatChanged: Boolean;\r\nbegin\r\n if FOptions <> Value then\r\n begin\r\n FlatChanged := (sbFlatBtns in FOptions) <> (sbFlatBtns in Value);\r\n FOptions := Value;\r\n ForEachItem(FlatItem, SizeInt(sbFlatBtns in Options));\r\n ForEachItem(TransparentItem, SizeInt(sbTransparentBtns in Options));\r\n ForEachItem(GrayedItem, SizeInt(sbGrayedBtns in Options));\r\n UpdateGridSize;\r\n if FlatChanged then\r\n Realign;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvSpeedBar.OffsetItem(Item: TJvSpeedItem; Data: SizeInt);\r\nvar\r\n P: TPoint;\r\nbegin\r\n P := PPoint(Data)^;\r\n Item.FButton.SetBounds(Item.Left + P.X, Item.Top + P.Y, FButtonSize.X,\r\n FButtonSize.Y);\r\nend;\r\n\r\nfunction TJvSpeedBar.GetButtonsOffset(Index: Integer): Integer;\r\nbegin\r\n if Index = 0 then\r\n Result := FOffset.X\r\n else\r\n if Index = 1 then\r\n Result := FOffset.Y\r\n else\r\n Result := 0;\r\nend;\r\n\r\nprocedure TJvSpeedBar.SetButtonsOffset(Index: Integer; Value: Integer);\r\nvar\r\n P: TPoint;\r\nbegin\r\n if Value < MinButtonsOffset then\r\n Value := MinButtonsOffset;\r\n P.X := 0;\r\n P.Y := 0;\r\n if Index = 0 then\r\n begin\r\n P.X := Value - FOffset.X;\r\n FOffset.X := Value;\r\n Include(FScaleFlags, sfOffsetX);\r\n end\r\n else\r\n if Index = 1 then\r\n begin\r\n P.Y := Value - FOffset.Y;\r\n FOffset.Y := Value;\r\n Include(FScaleFlags, sfOffsetY);\r\n end;\r\n if (P.X <> 0) or (P.Y <> 0) then\r\n ForEachItem(OffsetItem, SizeInt(@P));\r\nend;\r\n\r\nprocedure TJvSpeedBar.UpdateGridSize;\r\nvar\r\n Base: Integer;\r\nbegin\r\n case Orientation of\r\n boHorizontal:\r\n Base := FButtonSize.X;\r\n else {boVertical:}\r\n Base := FButtonSize.Y;\r\n end;\r\n case Orientation of\r\n boHorizontal:\r\n begin\r\n FGridSize.X := Max(1, Min(8, Base div 3));\r\n while Base mod FGridSize.X <> 0 do\r\n Inc(FGridSize.X);\r\n if (FGridSize.X = Base) and (Base > 1) then\r\n begin\r\n Dec(FGridSize.X);\r\n while (FGridSize.X > 1) and (Base mod FGridSize.X <> 0) do\r\n Dec(FGridSize.X);\r\n end;\r\n FGridSize.Y := FButtonSize.Y;\r\n end;\r\n boVertical:\r\n begin\r\n FGridSize.Y := Max(1, Min(8, Base div 3));\r\n while (Base mod FGridSize.Y <> 0) do\r\n Inc(FGridSize.Y);\r\n if (FGridSize.Y = Base) and (Base > 1) then\r\n begin\r\n Dec(FGridSize.Y);\r\n while (FGridSize.Y > 1) and (Base mod FGridSize.Y <> 0) do\r\n Dec(FGridSize.Y);\r\n end;\r\n FGridSize.X := FButtonSize.X;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvSpeedBar.ApplyItemSize(Item: TJvSpeedItem; Data: SizeInt);\r\nbegin\r\n with Item do\r\n FButton.SetBounds(FButton.Left, FButton.Top, FButtonSize.X, FButtonSize.Y);\r\nend;\r\n\r\nprocedure TJvSpeedBar.ApplyButtonSize;\r\nbegin\r\n ForEachItem(ApplyItemSize, 0);\r\n if FEditWin <> NullHandle then { update SpeedBar editor }\r\n SendMessage(FEditWin, CM_SPEEDBARCHANGED, SBR_BTNSIZECHANGED, LPARAM(Self));\r\nend;\r\n\r\nfunction TJvSpeedBar.GetButtonSize(Index: Integer): Integer;\r\nbegin\r\n if Index = 0 then\r\n Result := FButtonSize.X\r\n else\r\n if Index = 1 then\r\n Result := FButtonSize.Y\r\n else\r\n Result := 0;\r\nend;\r\n\r\nprocedure TJvSpeedBar.SetButtonSize(Index, Value: Integer);\r\nvar\r\n NewSize: TPoint;\r\nbegin\r\n NewSize.X := FButtonSize.X;\r\n NewSize.Y := FButtonSize.Y;\r\n if Index = 0 then\r\n begin\r\n NewSize.X := Value;\r\n Include(FScaleFlags, sfBtnSizeX);\r\n end\r\n else\r\n if Index = 1 then\r\n begin\r\n NewSize.Y := Value;\r\n Include(FScaleFlags, sfBtnSizeY);\r\n end\r\n else\r\n Exit;\r\n FButtonSize := NewSize;\r\n UpdateGridSize;\r\n if not (csReading in ComponentState) then\r\n case Orientation of\r\n boHorizontal:\r\n ClientHeight := Max(ClientHeight, 2 * FOffset.Y + FButtonSize.Y);\r\n boVertical:\r\n ClientWidth := Max(ClientWidth, 2 * FOffset.X + FButtonSize.X);\r\n end;\r\n ApplyButtonSize;\r\nend;\r\n\r\nprocedure TJvSpeedBar.GetChildren(Proc: TGetChildProc ; Root: TComponent);\r\nvar\r\n I, Idx: Integer;\r\n Sect: TJvSpeedBarSection;\r\n Item: TJvSpeedItem;\r\nbegin\r\n inherited GetChildren(Proc, Root);\r\n for I := 0 to FSections.Count - 1 do\r\n begin\r\n Sect := Sections[I];\r\n if Sect <> nil then\r\n Proc(Sect);\r\n end;\r\n for I := 0 to FSections.Count - 1 do\r\n begin\r\n Sect := Sections[I];\r\n if Sect <> nil then\r\n for Idx := 0 to Sect.Count - 1 do\r\n begin\r\n Item := Sect[Idx];\r\n if (Item <> nil) and (Item.Owner <> Self) then\r\n Proc(Item);\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvSpeedBar.SetChildOrder(Component: TComponent; Order: Integer);\r\nbegin\r\n if FSections.IndexOf(Component) >= 0 then\r\n (Component as TJvSpeedBarSection).Index := Order;\r\nend;\r\n\r\nprocedure TJvSpeedBar.Notification(AComponent: TComponent;\r\n Operation: TOperation);\r\nbegin\r\n inherited Notification(AComponent, Operation);\r\n if Operation = opRemove then\r\n if AComponent = FImages then\r\n SetImages(nil);\r\nend;\r\n\r\nprocedure TJvSpeedBar.InvalidateItem(Item: TJvSpeedItem; Data: SizeInt);\r\nbegin\r\n with Item do\r\n if Button <> nil then\r\n begin\r\n TJvSpeedBarButton(Button).InvalidateGlyph;\r\n if FImageIndex >= 0 then\r\n Button.Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvSpeedBar.ImageListChange(Sender: TObject);\r\nbegin\r\n ForEachItem(InvalidateItem, 0);\r\nend;\r\n\r\nprocedure TJvSpeedBar.SetImages(Value: TCustomImageList);\r\nbegin\r\n ReplaceImageListReference(Self, Value, FImages, FImageChangeLink);\r\n ImageListChange(FImages);\r\nend;\r\n\r\nfunction TJvSpeedBar.SearchItem(const ItemName: string): TJvSpeedItem;\r\nvar\r\n I, Idx: Integer;\r\n Sect: TJvSpeedBarSection;\r\n Item: TJvSpeedItem;\r\nbegin\r\n Result := nil;\r\n for I := 0 to FSections.Count - 1 do\r\n if FSections[I] <> nil then\r\n begin\r\n Sect := TJvSpeedBarSection(FSections[I]);\r\n for Idx := 0 to Sect.Count - 1 do\r\n if Sect[Idx] <> nil then\r\n begin\r\n Item := TJvSpeedItem(Sect[Idx]);\r\n if AnsiSameText(Item.Name, ItemName) then\r\n begin\r\n Result := Item;\r\n Break;\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\ntype\r\n TJvSpeedBarPos = (bpTop, bpBottom, bpLeft, bpRight);\r\n\r\nconst\r\n PosToAlign: array [TJvSpeedBarPos] of TAlign = (alTop, alBottom, alLeft, alRight);\r\n\r\nfunction TJvSpeedBar.GetFramePos(X, Y: Integer; var Apply: Boolean): Integer;\r\nvar\r\n P: TPoint;\r\n W, H: Double;\r\nbegin\r\n P := Parent.ScreenToClient(ClientToScreen(Point(X, Y)));\r\n W := Parent.ClientWidth;\r\n H := Parent.ClientHeight;\r\n if P.Y <= P.X * (H / W) then\r\n begin { top or right }\r\n if P.Y >= H * (1 - P.X / W) then\r\n Result := Ord(bpRight)\r\n else\r\n Result := Ord(bpTop);\r\n end\r\n else\r\n begin { left or bottom }\r\n if P.Y >= H * (1 - P.X / W) then\r\n Result := Ord(bpBottom)\r\n else\r\n Result := Ord(bpLeft);\r\n end;\r\n if Assigned(FOnApplyAlign) then\r\n FOnApplyAlign(Self, PosToAlign[TJvSpeedBarPos(Result)], Apply);\r\nend;\r\n\r\nfunction TJvSpeedBar.GetFrameRect(X, Y: Integer): TRect;\r\nvar\r\n Pos: TJvSpeedBarPos;\r\n W: Integer;\r\n Apply: Boolean;\r\n\r\n function InsertBefore(C1, C2: TControl; AAlign: TAlign): Boolean;\r\n begin\r\n Result := False;\r\n case AAlign of\r\n alTop:\r\n Result := C1.Top < C2.Top;\r\n alBottom:\r\n Result := (C1.Top + C1.Height) > (C2.Top + C2.Height);\r\n alLeft:\r\n Result := C1.Left < C2.Left;\r\n alRight:\r\n Result := (C1.Left + C1.Width) > (C2.Left + C2.Width);\r\n end;\r\n end;\r\n\r\n function MaxRect: TRect;\r\n var\r\n I: Integer;\r\n Control: TControl;\r\n begin\r\n Result := Parent.ClientRect;\r\n for I := 0 to Parent.ControlCount - 1 do\r\n begin\r\n Control := Parent.Controls[I];\r\n if (Control.Visible) and (Control <> Self) and not\r\n (Control.Align in [alNone, alClient]) then\r\n begin\r\n if (Control.Align > PosToAlign[Pos]) or ((Control.Align = PosToAlign[Pos]) and\r\n not InsertBefore(Control, Self, Control.Align)) then\r\n Continue;\r\n case Control.Align of\r\n alTop:\r\n Inc(Result.Top, Control.Height);\r\n alBottom:\r\n Dec(Result.Bottom, Control.Height);\r\n alLeft:\r\n Inc(Result.Left, Control.Width);\r\n alRight:\r\n Dec(Result.Right, Control.Width);\r\n end;\r\n end;\r\n end;\r\n end;\r\n\r\nbegin\r\n Apply := True;\r\n Pos := TJvSpeedBarPos(GetFramePos(X, Y, Apply));\r\n if Apply then\r\n begin\r\n Result := MaxRect;\r\n FPrevAlign := PosToAlign[Pos];\r\n end\r\n else\r\n begin\r\n Result := FPrevRect;\r\n Exit;\r\n end;\r\n Result.TopLeft := Parent.ClientToScreen(Result.TopLeft);\r\n Result.BottomRight := Parent.ClientToScreen(Result.BottomRight);\r\n case GetOrientation of\r\n boHorizontal:\r\n W := Height;\r\n boVertical:\r\n W := Width;\r\n else\r\n W := 0;\r\n end;\r\n case Pos of\r\n bpTop:\r\n Result.Bottom := Result.Top + W;\r\n bpBottom:\r\n Result.Top := Result.Bottom - W;\r\n bpLeft:\r\n Result.Right := Result.Left + W;\r\n bpRight:\r\n Result.Left := Result.Right - W;\r\n end;\r\nend;\r\n\r\nprocedure TJvSpeedBar.StartDragFrame;\r\nvar\r\n Rect: TRect;\r\nbegin\r\n Rect.TopLeft := ClientToScreen(Point(0, 0));\r\n Rect.BottomRight := ClientToScreen(Point(Width, Height));\r\n FPrevRect := Rect;\r\n FPrevAlign := Align;\r\n DrawInvertFrame(FPrevRect, DragFrameWidth);\r\n SetCursor(Screen.Cursors[crDragHand]);\r\n FDrag := True;\r\nend;\r\n\r\nprocedure TJvSpeedBar.DragFrame(X, Y: Integer);\r\nvar\r\n Rect: TRect;\r\nbegin\r\n Rect := GetFrameRect(X, Y);\r\n if not EqualRect(Rect, FPrevRect) then\r\n begin\r\n DrawInvertFrame(FPrevRect, DragFrameWidth);\r\n SetCursor(Screen.Cursors[crDragHand]);\r\n FPrevRect := Rect;\r\n DrawInvertFrame(FPrevRect, DragFrameWidth);\r\n end;\r\nend;\r\n\r\nprocedure TJvSpeedBar.StopDragFrame(X, Y: Integer);\r\nvar\r\n Pos: TJvSpeedBarPos;\r\n Apply: Boolean;\r\nbegin\r\n DrawInvertFrame(FPrevRect, DragFrameWidth);\r\n SetCursor(Screen.Cursors[Cursor]);\r\n FDrag := False;\r\n if Align in [alLeft, alTop, alRight, alBottom] then\r\n begin\r\n Apply := True;\r\n Pos := TJvSpeedBarPos(GetFramePos(X, Y, Apply));\r\n Parent.DisableAlign;\r\n try\r\n if Apply then\r\n Align := PosToAlign[Pos]\r\n else\r\n Align := FPrevAlign;\r\n finally\r\n Parent.EnableAlign;\r\n end;\r\n PosChanged;\r\n end;\r\nend;\r\n\r\nfunction TJvSpeedBar.CheckResize(Shift: TShiftState; X, Y: Integer): Boolean;\r\nbegin\r\n Result := False;\r\n if (FEditWin <> NullHandle) and (sbAllowResize in Options) and not FDrag then\r\n begin\r\n if (Align in [alTop, alBottom]) and (X > 0) and (X <= ClientWidth) then\r\n begin\r\n case Align of\r\n alTop:\r\n Result := (Y > ClientHeight - StartDragOffset) and\r\n (Y <= ClientHeight + StartDragOffset);\r\n alBottom:\r\n Result := (Y > -StartDragOffset) and (Y <= StartDragOffset);\r\n end;\r\n if Result then\r\n SetCursor(Screen.Cursors[crSizeNS]);\r\n end;\r\n if (Align in [alLeft, alRight]) and (Y > 0) and (Y <= ClientHeight) then\r\n begin\r\n case Align of\r\n alLeft:\r\n Result := (X > ClientWidth - StartDragOffset) and\r\n (X <= ClientWidth + StartDragOffset);\r\n alRight:\r\n Result := (X > -StartDragOffset) and (X <= StartDragOffset);\r\n end;\r\n if Result then\r\n SetCursor(Screen.Cursors[crSizeWE]);\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvSpeedBar.MouseDown(Button: TMouseButton; Shift: TShiftState;\r\n X, Y: Integer);\r\nbegin\r\n inherited MouseDown(Button, Shift, X, Y);\r\n if (Button = mbLeft) and (Parent <> nil) and CheckResize(Shift, X, Y) then\r\n begin\r\n FResizing := True;\r\n MouseCapture := True;\r\n Exit;\r\n end;\r\n if (Button = mbLeft) and (Parent <> nil) and (sbAllowDrag in Options) and\r\n (Align in [alLeft, alTop, alRight, alBottom]) then\r\n begin\r\n MouseCapture := True;\r\n FStartDrag := Point(X, Y);\r\n end;\r\nend;\r\n\r\nprocedure TJvSpeedBar.MouseMove(Shift: TShiftState; X, Y: Integer);\r\nvar\r\n Cnt: Integer;\r\n P: TPoint;\r\nbegin\r\n inherited MouseMove(Shift, X, Y);\r\n CheckResize(Shift, X, Y);\r\n Cnt := 0;\r\n if (GetCapture = Handle) and (csLButtonDown in ControlState) then\r\n if FResizing then\r\n begin\r\n P := Parent.ScreenToClient(ClientToScreen(Point(X, Y)));\r\n if not PtInRectInclusive(Parent.ClientRect,P) then\r\n Exit;\r\n case Align of\r\n alTop:\r\n Cnt := Abs(Y - (2 * FOffset.Y)) div BtnHeight;\r\n alLeft:\r\n Cnt := Abs(X - (2 * FOffset.X)) div BtnWidth;\r\n alBottom:\r\n Cnt := Abs(ClientHeight - (2 * FOffset.Y) - Y) div BtnHeight;\r\n alRight:\r\n Cnt := Abs(ClientWidth - (2 * FOffset.X) - X) div BtnWidth;\r\n end;\r\n Cnt := Max(1, Cnt);\r\n case Align of\r\n alTop, alBottom:\r\n begin\r\n SetCursor(Screen.Cursors[crSizeNS]);\r\n Height := Min(BtnHeight * Cnt + (2 * FOffset.Y), Parent.ClientHeight);\r\n end;\r\n alLeft, alRight:\r\n begin\r\n SetCursor(Screen.Cursors[crSizeWE]);\r\n Width := Min(BtnWidth * Cnt + (2 * FOffset.X), Parent.ClientWidth);\r\n end;\r\n end;\r\n end\r\n else\r\n if sbAllowDrag in Options then\r\n begin\r\n if FDrag then\r\n DragFrame(X, Y)\r\n else\r\n begin\r\n if (Abs(X - FStartDrag.X) > StartDragOffset) or\r\n (Abs(Y - FStartDrag.Y) > StartDragOffset) then\r\n StartDragFrame;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvSpeedBar.MouseUp(Button: TMouseButton; Shift: TShiftState;\r\n X, Y: Integer);\r\nbegin\r\n if Button = mbLeft then\r\n begin\r\n if FResizing then\r\n begin\r\n FResizing := False;\r\n SetCursor(Screen.Cursors[Cursor]);\r\n end;\r\n if FDrag then\r\n StopDragFrame(X, Y);\r\n MouseCapture := False;\r\n end;\r\n inherited MouseUp(Button, Shift, X, Y);\r\nend;\r\n\r\nprocedure TJvSpeedBar.PosChanged;\r\nbegin\r\n if Assigned(FOnPosChanged) then\r\n FOnPosChanged(Self);\r\nend;\r\n\r\nprocedure TJvSpeedBar.AfterCustomize;\r\nbegin\r\n if Assigned(FOnCustomize) then\r\n FOnCustomize(Self);\r\nend;\r\n\r\nfunction TJvSpeedBar.GetStorage: TJvFormPlacement;\r\nbegin\r\n Result := FIniLink.Storage;\r\nend;\r\n\r\nprocedure TJvSpeedBar.SetStorage(Value: TJvFormPlacement);\r\nbegin\r\n FIniLink.Storage := Value;\r\nend;\r\n\r\nprocedure TJvSpeedBar.Customize(HelpCtx: THelpContext);\r\nbegin\r\n ShowSpeedbarSetupWindow(Self, HelpCtx);\r\nend;\r\n\r\nprocedure TJvSpeedBar.IniSave(Sender: TObject);\r\nbegin\r\n if (Name <> '') and IniStorage.IsActive then\r\n SaveToAppStorage(IniStorage.AppStorage, IniStorage.AppStorage.ConcatPaths([\r\n IniStorage.AppStoragePath, GetDefaultSection(Self)]));\r\nend;\r\n\r\nprocedure TJvSpeedBar.IniLoad(Sender: TObject);\r\nbegin\r\n if (Name <> '') and IniStorage.IsActive then\r\n LoadFromAppStorage(IniStorage.AppStorage, IniStorage.AppStorage.ConcatPaths([\r\n IniStorage.AppStoragePath, GetDefaultSection(Self)]));\r\nend;\r\n\r\nconst\r\n { The following strings should not be localized }\r\n sPosition = 'Position';\r\n sCount = 'Count';\r\n sBtn = 'Button';\r\n sVer = 'Version';\r\n sPixelsPerInch = 'PixelsPerInch';\r\n sBtnWidth = 'BtnWidth';\r\n sBtnHeight = 'BtnHeight';\r\n sBarWidth = 'Width';\r\n\r\ntype\r\n PIniData = ^TIniData;\r\n TIniData = record\r\n AppStorage: TJvCustomAppStorage;\r\n I: Integer;\r\n Path: string;\r\n end;\r\n\r\nprocedure TJvSpeedBar.HideItem(Item: TJvSpeedItem; Data: SizeInt);\r\nbegin\r\n Item.Visible := False;\r\nend;\r\n\r\nprocedure TJvSpeedBar.WriteItemLayout(Item: TJvSpeedItem; Data: SizeInt);\r\nbegin\r\n if Item.Visible and Item.Stored then\r\n begin\r\n Inc(PIniData(Data)^.I);\r\n with PIniData(Data)^ do\r\n AppStorage.WriteString(AppStorage.ConcatPaths([Path, sBtn + IntToStr(I)]),\r\n Format('%s,%d,%d', [Item.Name, Item.Left, Item.Top]));\r\n end;\r\nend;\r\n\r\nprocedure TJvSpeedBar.SaveLayout;\r\nbegin\r\n Save;\r\nend;\r\n\r\nprocedure TJvSpeedBar.RestoreLayout;\r\nbegin\r\n Load;\r\nend;\r\n\r\nprocedure TJvSpeedBar.LoadFromAppStorage(const AppStorage: TJvCustomAppStorage; const Path: string);\r\nconst\r\n Delims = [' ', ','];\r\nvar\r\n Item: TJvSpeedItem;\r\n Count: Integer;\r\n I: Integer;\r\n S: string;\r\nbegin\r\n FPrevAlign := Align;\r\n AppStorage.BeginUpdate;\r\n try\r\n if AppStorage.ReadInteger(AppStorage.ConcatPaths([Path, sVer]), FVersion) < FVersion then\r\n // (marcelb) shouldn't we raise an exception \"Invalid version\" here?\r\n Exit;\r\n if sbAllowDrag in Options then\r\n try\r\n Align := TAlign(AppStorage.ReadInteger(AppStorage.ConcatPaths([Path, sPosition]), Integer(Align)));\r\n except\r\n Align := alTop;\r\n end;\r\n if Owner is TCustomForm then\r\n I := TForm(Owner).PixelsPerInch\r\n else\r\n I := 0;\r\n if Screen.PixelsPerInch <> AppStorage.ReadInteger(AppStorage.ConcatPaths([Path, sPixelsPerInch]), I) then\r\n begin\r\n if FPrevAlign <> Align then\r\n PosChanged;\r\n Exit;\r\n end;\r\n if sbAllowResize in Options then\r\n begin\r\n if Align in [alTop, alBottom] then\r\n Height := AppStorage.ReadInteger(AppStorage.ConcatPaths([Path, sBarWidth]), Height)\r\n else\r\n if Align in [alLeft, alRight] then\r\n Width := AppStorage.ReadInteger(AppStorage.ConcatPaths([Path, sBarWidth]), Width);\r\n end;\r\n if FPrevAlign <> Align then\r\n PosChanged;\r\n {if (AppStorage.ReadInteger(AppStorage.ConcatPaths([Path, sBtnWidth]), FButtonSize.X) >\r\n FButtonSize.X) or (AppStorage.ReadInteger(AppStorage.ConcatPaths([Path, sBtnHeight]),\r\n FButtonSize.Y) > FButtonSize.Y) then Exit;}\r\n Count := AppStorage.ReadInteger(AppStorage.ConcatPaths([Path, sCount]), 0);\r\n if Count > 0 then\r\n begin\r\n ForEachItem(HideItem, 0);\r\n for I := 1 to Count do\r\n begin\r\n S := AppStorage.ReadString(AppStorage.ConcatPaths([Path, sBtn + IntToStr(I)]), '');\r\n if S <> '' then\r\n begin\r\n Item := SearchItem(ExtractWord(1, S, Delims));\r\n if Item <> nil then\r\n begin\r\n Item.Left := Max(StrToIntDef(ExtractWord(2, S, Delims), Item.Left),\r\n FOffset.X);\r\n Item.Top := Max(StrToIntDef(ExtractWord(3, S, Delims), Item.Top),\r\n FOffset.Y);\r\n Item.Visible := True;\r\n end;\r\n end;\r\n end;\r\n end;\r\n finally\r\n AppStorage.EndUpdate;\r\n end;\r\n Repaint;\r\nend;\r\n\r\nprocedure TJvSpeedBar.SaveToAppStorage(const AppStorage: TJvCustomAppStorage; const Path: string);\r\nvar\r\n Data: TIniData;\r\nbegin\r\n AppStorage.BeginUpdate;\r\n try\r\n Data.AppStorage := AppStorage;\r\n Data.Path := Path;\r\n Data.I := 0;\r\n AppStorage.DeleteSubTree(Path);\r\n AppStorage.WriteInteger(AppStorage.ConcatPaths([Path, sPosition]), Integer(Align));\r\n if Align in [alTop, alBottom] then\r\n AppStorage.WriteInteger(AppStorage.ConcatPaths([Path, sBarWidth]), Height)\r\n else\r\n if Align in [alLeft, alRight] then\r\n AppStorage.WriteInteger(AppStorage.ConcatPaths([Path, sBarWidth]), Width);\r\n AppStorage.WriteInteger(AppStorage.ConcatPaths([Path, sVer]), FVersion);\r\n AppStorage.WriteInteger(AppStorage.ConcatPaths([Path, sPixelsPerInch]), Screen.PixelsPerInch);\r\n AppStorage.WriteInteger(AppStorage.ConcatPaths([Path, sBtnWidth]), FButtonSize.X);\r\n AppStorage.WriteInteger(AppStorage.ConcatPaths([Path, sBtnHeight]), FButtonSize.Y);\r\n ForEachItem(WriteItemLayout, SizeInt(@Data));\r\n AppStorage.WriteInteger(AppStorage.ConcatPaths([Path, sCount]), Data.I);\r\n finally\r\n AppStorage.EndUpdate;\r\n end;\r\nend;\r\n\r\nprocedure TJvSpeedBar.Load;\r\nbegin\r\n IniLoad(nil);\r\nend;\r\n\r\nprocedure TJvSpeedBar.Save;\r\nbegin\r\n IniSave(nil);\r\nend;\r\n\r\n//=== { TJvBtnControl } ======================================================\r\n\r\nconstructor TJvBtnControl.Create(AOwner: TComponent);\r\nbegin\r\n FImage := TJvButtonImage.Create;\r\n inherited Create(AOwner);\r\n Cursor := crDragHand;\r\n FSpacing := 1;\r\n FMargin := -1;\r\n FLayout := blGlyphTop;\r\n FImageIndex := -1;\r\nend;\r\n\r\ndestructor TJvBtnControl.Destroy;\r\nbegin\r\n FImage.Free;\r\n inherited Destroy;\r\nend;\r\n\r\n\r\nprocedure TJvBtnControl.CreateParams(var Params: TCreateParams);\r\nbegin\r\n inherited CreateParams(Params);\r\n with Params do\r\n begin\r\n Style := WS_POPUP or WS_DISABLED;\r\n WindowClass.Style := WindowClass.Style or CS_SAVEBITS;\r\n ExStyle := WS_EX_TOOLWINDOW;\r\n end;\r\nend;\r\n\r\n\r\nprocedure TJvBtnControl.AssignSpeedItem(Item: TJvSpeedItem);\r\nbegin\r\n Alignment := Item.FButton.Alignment;\r\n Glyph := Item.Glyph;\r\n NumGlyphs := Item.NumGlyphs;\r\n Spacing := Item.Spacing;\r\n Margin := Item.Margin;\r\n Layout := Item.Layout;\r\n Caption := Item.BtnCaption;\r\n WordWrap := Item.WordWrap;\r\n ImageIndex := Item.ImageIndex;\r\n if Item.SpeedBar <> nil then\r\n Images := Item.SpeedBar.Images\r\n else\r\n Images := nil;\r\n Font := Item.Font;\r\n BiDiMode := Item.FButton.BiDiMode;\r\n SetBounds(0, 0, Item.SpeedBar.BtnWidth, Item.SpeedBar.BtnHeight);\r\nend;\r\n\r\nfunction TJvBtnControl.GetGlyph: TBitmap;\r\nbegin\r\n Result := FImage.Glyph;\r\nend;\r\n\r\nfunction TJvBtnControl.GetNumGlyphs: TJvNumGlyphs;\r\nbegin\r\n Result := FImage.NumGlyphs;\r\nend;\r\n\r\nfunction TJvBtnControl.GetCaption: TCaption;\r\nbegin\r\n Result := FImage.Caption;\r\nend;\r\n\r\nprocedure TJvBtnControl.SetCaption(const Value: TCaption);\r\nbegin\r\n FImage.Caption := Value;\r\nend;\r\n\r\nprocedure TJvBtnControl.SetNumGlyphs(Value: TJvNumGlyphs);\r\nbegin\r\n FImage.NumGlyphs := Value;\r\nend;\r\n\r\nprocedure TJvBtnControl.SetGlyph(Value: TBitmap);\r\nbegin\r\n FImage.Glyph := Value;\r\nend;\r\n\r\nfunction TJvBtnControl.GetWordWrap: Boolean;\r\nbegin\r\n Result := FImage.WordWrap;\r\nend;\r\n\r\nprocedure TJvBtnControl.SetWordWrap(Value: Boolean);\r\nbegin\r\n FImage.WordWrap := Value;\r\nend;\r\n\r\nfunction TJvBtnControl.GetAlignment: TAlignment;\r\nbegin\r\n Result := FImage.Alignment;\r\nend;\r\n\r\nprocedure TJvBtnControl.SetAlignment(Value: TAlignment);\r\nbegin\r\n FImage.Alignment := Value;\r\nend;\r\n\r\nprocedure TJvBtnControl.BoundsChanged;\r\nbegin\r\n FImage.ButtonSize := Point(ClientWidth, ClientHeight);\r\n inherited BoundsChanged;\r\nend;\r\n\r\nprocedure TJvBtnControl.Paint;\r\nbegin\r\n FImage.DrawEx(Canvas, 0, 0, Margin, Spacing, Layout, Font, Images,\r\n ImageIndex,\r\n DrawTextBiDiModeFlags(Alignments[Alignment]),\r\n ControlInGlassPaint(Self)\r\n );\r\nend;\r\n\r\nprocedure TJvBtnControl.Activate(Rect: TRect);\r\nbegin\r\n if IsRectEmpty(BoundsRect) then\r\n BoundsRect := Rect;\r\n SetWindowPos(Handle, HWND_TOPMOST, Rect.Left, Rect.Top, 0,\r\n 0, SWP_SHOWWINDOW or SWP_NOACTIVATE or SWP_NOSIZE);\r\n SetCursor(Screen.Cursors[Cursor]);\r\nend;\r\n\r\nprocedure TJvBtnControl.ReleaseHandle;\r\nbegin\r\n DestroyHandle;\r\nend;\r\n\r\n{ Utility routines }\r\n\r\nfunction NewSpeedSection(ASpeedBar: TJvSpeedBar; const ACaption: string): Integer;\r\nbegin\r\n Result := ASpeedBar.AddSection(ACaption);\r\nend;\r\n\r\nfunction NewSpeedItem(AOwner: TComponent; ASpeedBar: TJvSpeedBar; Section: Integer;\r\n const AName: string): TJvSpeedItem;\r\nbegin\r\n Result := ASpeedBar.NewItem(AOwner, Section, AName);\r\nend;\r\n\r\nfunction FindSpeedBar(const Pos: TPoint): TJvSpeedBar;\r\nvar\r\n Window: TWinControl;\r\n Handle: THandle;\r\nbegin\r\n Result := nil;\r\n Handle := WindowFromPoint(Pos);\r\n Window := nil;\r\n while (Handle <> NullHandle) and (Window = nil) do\r\n begin\r\n Window := FindControl(Handle);\r\n if Window = nil then\r\n Handle := GetParent(Handle);\r\n end;\r\n if Window <> nil then\r\n begin\r\n if Window is TJvSpeedBar then\r\n Result := Window as TJvSpeedBar;\r\n end;\r\nend;\r\n\r\nprocedure DrawCellButton(Grid: TDrawGrid; R: TRect; Item: TJvSpeedItem;\r\n Image: TJvButtonImage; ARightToLeft: Boolean = False);\r\nvar\r\n FBar: TJvSpeedBar;\r\n AFont: TFont;\r\n ImageList: TCustomImageList;\r\nbegin\r\n if Item <> nil then\r\n begin\r\n FBar := Item.SpeedBar;\r\n AFont := nil;\r\n ImageList := nil;\r\n if FBar <> nil then\r\n begin\r\n AFont := FBar.Font;\r\n if Item.ImageIndex >= 0 then\r\n ImageList := FBar.Images;\r\n end;\r\n if ImageList = nil then\r\n Image.Glyph := Item.Glyph\r\n else\r\n Image.Glyph := nil;\r\n with Image do\r\n begin\r\n Alignment := Item.FButton.Alignment;\r\n NumGlyphs := Item.NumGlyphs;\r\n Caption := Item.BtnCaption;\r\n WordWrap := Item.WordWrap;\r\n if FBar <> nil then\r\n ButtonSize := Point(FBar.BtnWidth, FBar.BtnHeight);\r\n end;\r\n Image.DrawEx(Grid.Canvas, R.Left + 1, R.Top + 1, Item.Margin,\r\n Item.Spacing, Item.Layout, AFont, ImageList, Item.ImageIndex,\r\n Item.FButton.DrawTextBiDiModeFlags(Alignments[Image.Alignment]),\r\n False\r\n );\r\n Inc(R.Left, Image.ButtonSize.X + 3);\r\n DrawCellText(Grid, 0, 0, Item.Caption, R, taLeftJustify, vaCenterJustify, ARightToLeft);\r\n end;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvSpeedbarSetupForm.dfm", "content": "object JvSpeedbarSetupWindow: TJvSpeedbarSetupWindow\r\n Left = 231\r\n Top = 121\r\n ActiveControl = SectionList\r\n BorderIcons = [biSystemMenu]\r\n BorderStyle = bsSingle\r\n ClientHeight = 262\r\n ClientWidth = 421\r\n Color = clBtnFace\r\n Font.Charset = DEFAULT_CHARSET\r\n Font.Color = clWindowText\r\n Font.Height = -11\r\n Font.Name = 'MS Sans Serif'\r\n Font.Style = []\r\n FormStyle = fsStayOnTop\r\n Icon.Data = {\r\n 0000010001002020100000000000E80200001600000028000000200000004000\r\n 0000010004000000000000020000000000000000000000000000000000000000\r\n 0000000080000080000000808000800000008000800080800000C0C0C0008080\r\n 80000000FF0000FF000000FFFF00FF000000FF00FF00FFFF0000FFFFFF000000\r\n 0000000000000000000000088000000000000000000000000000000088000000\r\n 0000000000000000000000FF080000000000000000000000000000FF08000000\r\n 000000000000000008000FF080000000000000000000000000880FF000000000\r\n 00000000000000000F00FF080000000000000000000000000FF0FF0888000000\r\n 00008888888888880FFFFF000000000000000000000000000FFFFFFF00000000\r\n 00088888888888880FFFFFF000000000000F7777777777770FFFFF0000000000\r\n 000F7777777777770FFFF08888000000000F7777000000070FFF000008800000\r\n 000F77770FFFFF070FF0F7F7F0800088880F77770FFFFF070F00FFFF70800000\r\n 000F77770FFFFF07008088F7F0800888880F77770FFFFF077780F8FF70800F77\r\n 770F77770FF000077780F8F7F0800F77770F77770FF0F0777780F8FF70800F77\r\n 770F77770FF007777780F8F7F0800F77770F7777000077777780887F70800F77\r\n 770F777777777777778087F7F0800F77770FFFFFFFFFFFFFFF807F7F70800F77\r\n 77800000000000000007F7F7F0800F77778FF888087F7F7F7F7F7F7F70800F77\r\n 778FF8F808F7F7F7F7F7F7F7F0800F77778FF887088888888888888880000F77\r\n 77888877700000000000000000000F7777777777777780800000000000000FFF\r\n FFFFFFFFFFFF800000000000000000000000000000000000000000000000FFFF\r\n FFE7FFFFFFC3FFFFFF83FFFFFF83FFFFF307FFFFF00FFFFFF00FFFFFF003FF00\r\n 0003FE000007FC00000FFC00001FFC000003FC000001FC000001C00000018000\r\n 0001000000010000000100000001000000010000000100000001000000010000\r\n 00010000000100000001000000030000000700001FFF00003FFF80007FFFBA00}\r\n OldCreateOrder = True\r\n Position = poScreenCenter\r\n OnClose = FormClose\r\n OnCreate = FormCreate\r\n OnDestroy = FormDestroy\r\n OnShow = FormShow\r\n PixelsPerInch = 96\r\n TextHeight = 13\r\n object Bevel1: TBevel\r\n Left = 4\r\n Top = 4\r\n Width = 328\r\n Height = 221\r\n Shape = bsFrame\r\n end\r\n object ButtonsLabel: TLabel\r\n Left = 146\r\n Top = 11\r\n Width = 96\r\n Height = 13\r\n Caption = '&Available Buttons: '\r\n FocusControl = ButtonsList\r\n end\r\n object CategoriesLabel: TLabel\r\n Left = 12\r\n Top = 11\r\n Width = 65\r\n Height = 13\r\n Caption = '&Categories: '\r\n end\r\n object HintLabel: TLabel\r\n Left = 4\r\n Top = 231\r\n Width = 413\r\n Height = 29\r\n AutoSize = False\r\n Caption =\r\n 'To add command Buttons, drag and drop Buttons onto the JvSpeedba' +\r\n 'r. To remove command Buttons, drag them off of the JvSpeedbar.'\r\n WordWrap = True\r\n end\r\n object ButtonsList: TDrawGrid\r\n Left = 146\r\n Top = 30\r\n Width = 179\r\n Height = 188\r\n ColCount = 1\r\n DefaultColWidth = 169\r\n DefaultRowHeight = 26\r\n FixedCols = 0\r\n RowCount = 1\r\n FixedRows = 0\r\n Options = [goDrawFocusSelected, goRowSelect]\r\n ScrollBars = ssVertical\r\n TabOrder = 1\r\n OnDrawCell = ButtonsListDrawCell\r\n OnMouseDown = ButtonsListMouseDown\r\n OnMouseMove = ButtonsListMouseMove\r\n OnMouseUp = ButtonsListMouseUp\r\n OnSelectCell = ButtonsListSelectCell\r\n end\r\n object SectionList: TDrawGrid\r\n Left = 12\r\n Top = 30\r\n Width = 129\r\n Height = 188\r\n ColCount = 1\r\n DefaultColWidth = 127\r\n DefaultRowHeight = 15\r\n FixedCols = 0\r\n RowCount = 1\r\n FixedRows = 0\r\n Options = [goDrawFocusSelected, goRowSelect]\r\n ScrollBars = ssVertical\r\n TabOrder = 0\r\n OnDrawCell = SectionListDrawCell\r\n OnSelectCell = SectionListSelectCell\r\n end\r\n object CloseBtn: TButton\r\n Left = 339\r\n Top = 12\r\n Width = 77\r\n Height = 25\r\n Cancel = True\r\n Default = True\r\n ModalResult = 1\r\n TabOrder = 2\r\n OnClick = CloseBtnClick\r\n end\r\n object HelpBtn: TButton\r\n Left = 339\r\n Top = 44\r\n Width = 77\r\n Height = 25\r\n TabOrder = 3\r\n OnClick = HelpBtnClick\r\n end\r\nend\r\n" }, { "path": "External/Jedi/Jvcl/run/JvSpeedbarSetupForm.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvSbSetup.PAS, released on 2002-07-04.\r\n\r\nThe Initial Developers of the Original Code are: Fedor Koshevnikov, Igor Pavluk and Serge Korolev\r\nCopyright (c) 1997, 1998 Fedor Koshevnikov, Igor Pavluk and Serge Korolev\r\nCopyright (c) 2001,2002 SGB Software\r\nAll Rights Reserved.\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvSpeedbarSetupForm.pas 13415 2012-09-10 09:51:54Z obones $\r\n\r\nunit JvSpeedbarSetupForm;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n SysUtils, Classes,\r\n Windows, Messages,\r\n Graphics, Controls, Forms, StdCtrls, Grids, ExtCtrls,\r\n JvConsts, JvSpeedbar, JvSpeedButton, JvComponent;\r\n\r\ntype\r\n TJvSpeedbarSetupWindow = class(TJvForm)\r\n ButtonsList: TDrawGrid;\r\n ButtonsLabel: TLabel;\r\n SectionList: TDrawGrid;\r\n CategoriesLabel: TLabel;\r\n Bevel1: TBevel;\r\n HintLabel: TLabel;\r\n CloseBtn: TButton;\r\n HelpBtn: TButton;\r\n procedure FormClose(Sender: TObject; var Action: TCloseAction);\r\n procedure SectionListSelectCell(Sender: TObject; Col, Row: Longint;\r\n var CanSelect: Boolean);\r\n procedure SectionListDrawCell(Sender: TObject; Col, Row: Longint;\r\n Rect: TRect; State: TGridDrawState);\r\n procedure ButtonsListMouseDown(Sender: TObject; Button: TMouseButton;\r\n Shift: TShiftState; X, Y: Integer);\r\n procedure ButtonsListMouseMove(Sender: TObject; Shift: TShiftState;\r\n X, Y: Integer);\r\n procedure ButtonsListMouseUp(Sender: TObject; Button: TMouseButton;\r\n Shift: TShiftState; X, Y: Integer);\r\n procedure ButtonsListSelectCell(Sender: TObject; Col, Row: Longint;\r\n var CanSelect: Boolean);\r\n procedure FormCreate(Sender: TObject);\r\n procedure FormDestroy(Sender: TObject);\r\n procedure ButtonsListDrawCell(Sender: TObject; Col, Row: Longint;\r\n Rect: TRect; State: TGridDrawState);\r\n procedure CloseBtnClick(Sender: TObject);\r\n procedure HelpBtnClick(Sender: TObject);\r\n procedure FormShow(Sender: TObject);\r\n private\r\n FButton: TJvBtnControl;\r\n FImage: TJvButtonImage;\r\n FSpeedbar: TJvSpeedBar;\r\n FDrag: Boolean;\r\n FDragItem: TJvSpeedItem;\r\n procedure UpdateHint(Section, Row: Integer);\r\n function CheckSpeedBar: Boolean;\r\n function CurrentSection: Integer;\r\n procedure SetSection(Section: Integer);\r\n procedure UpdateCurrentSection;\r\n procedure UpdateData(Section: Integer);\r\n procedure UpdateListHeight;\r\n procedure SetSpeedbar(Value: TJvSpeedBar);\r\n function ItemByRow(Row: Integer): TJvSpeedItem;\r\n procedure CMSpeedBarChanged(var Msg: TMessage); message CM_SPEEDBARCHANGED;\r\n public\r\n property Speedbar: TJvSpeedBar read FSpeedbar write SetSpeedbar;\r\n end;\r\n\r\nprocedure ShowSpeedbarSetupWindow(Speedbar: TJvSpeedBar; HelpCtx: THelpContext);\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvSpeedbarSetupForm.pas $';\r\n Revision: '$Revision: 13415 $';\r\n Date: '$Date: 2012-09-10 11:51:54 +0200 (lun. 10 sept. 2012) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n Types, Math, Consts,\r\n JvJVCLUtils, JvTypes, JvResources;\r\n\r\n{$R *.dfm}\r\n\r\nfunction FindEditor(Speedbar: TJvSpeedBar): TJvSpeedbarSetupWindow;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := nil;\r\n for I := 0 to Screen.FormCount - 1 do\r\n if Screen.Forms[I] is TJvSpeedbarSetupWindow then\r\n if TJvSpeedbarSetupWindow(Screen.Forms[I]).Speedbar = Speedbar then\r\n begin\r\n Result := TJvSpeedbarSetupWindow(Screen.Forms[I]);\r\n Break;\r\n end;\r\nend;\r\n\r\nprocedure ShowSpeedbarSetupWindow(Speedbar: TJvSpeedBar; HelpCtx: THelpContext);\r\nvar\r\n Editor: TJvSpeedbarSetupWindow;\r\nbegin\r\n if Speedbar = nil then\r\n Exit;\r\n Editor := FindEditor(Speedbar);\r\n if Editor = nil then\r\n begin\r\n Editor := TJvSpeedbarSetupWindow.Create(Application);\r\n Editor.Speedbar := Speedbar;\r\n end;\r\n try\r\n if HelpCtx > 0 then\r\n Editor.HelpContext := HelpCtx;\r\n Editor.BorderIcons := [biSystemMenu];\r\n Editor.HelpBtn.Visible := (HelpCtx > 0);\r\n Editor.Show;\r\n if Editor.WindowState = wsMinimized then\r\n Editor.WindowState := wsNormal;\r\n except\r\n Editor.Free;\r\n raise;\r\n end;\r\nend;\r\n\r\nconst\r\n MaxBtnListHeight = 186;\r\n\r\nfunction TJvSpeedbarSetupWindow.CheckSpeedBar: Boolean;\r\nbegin\r\n Result := (FSpeedbar <> nil) and (FSpeedbar.Owner <> nil) and (FSpeedbar.Parent <> nil);\r\nend;\r\n\r\nfunction TJvSpeedbarSetupWindow.CurrentSection: Integer;\r\nbegin\r\n if CheckSpeedBar and (FSpeedbar.SectionCount > 0) then\r\n Result := SectionList.Row\r\n else\r\n Result := -1;\r\nend;\r\n\r\nprocedure TJvSpeedbarSetupWindow.SetSection(Section: Integer);\r\nvar\r\n I: Integer;\r\nbegin\r\n if CheckSpeedBar then\r\n begin\r\n I := Section;\r\n if (I >= 0) and (FSpeedbar.SectionCount > 0) then\r\n ButtonsList.RowCount := FSpeedbar.ItemsCount(I)\r\n else\r\n ButtonsList.RowCount := 0;\r\n SectionList.DefaultColWidth := SectionList.ClientWidth;\r\n ButtonsList.DefaultColWidth := ButtonsList.ClientWidth;\r\n UpdateHint(I, ButtonsList.Row);\r\n end;\r\nend;\r\n\r\nprocedure TJvSpeedbarSetupWindow.UpdateCurrentSection;\r\nbegin\r\n SetSection(CurrentSection);\r\nend;\r\n\r\nprocedure TJvSpeedbarSetupWindow.UpdateData(Section: Integer);\r\nbegin\r\n if CheckSpeedBar then\r\n begin\r\n SectionList.RowCount := FSpeedbar.SectionCount;\r\n UpdateCurrentSection;\r\n if (Section >= 0) and (Section < SectionList.RowCount) then\r\n SectionList.Row := Section;\r\n end\r\n else\r\n begin\r\n SectionList.RowCount := 0;\r\n ButtonsList.RowCount := 0;\r\n end;\r\nend;\r\n\r\nprocedure TJvSpeedbarSetupWindow.UpdateListHeight;\r\nvar\r\n Cnt: Integer;\r\n MaxHeight: Integer;\r\nbegin\r\n Canvas.Font := Font;\r\n MaxHeight := MulDiv(MaxBtnListHeight, Screen.PixelsPerInch, 96);\r\n ButtonsList.DefaultRowHeight := FSpeedbar.BtnHeight + 2;\r\n Cnt := Max(1, Max(ButtonsList.ClientHeight, MaxHeight) div\r\n (FSpeedbar.BtnHeight + 2));\r\n ButtonsList.ClientHeight := Min(MaxHeight,\r\n ButtonsList.DefaultRowHeight * Cnt);\r\n SectionList.ClientHeight := ButtonsList.ClientHeight;\r\n SectionList.DefaultRowHeight := CanvasMaxTextHeight(Canvas) + 2;\r\nend;\r\n\r\nprocedure TJvSpeedbarSetupWindow.SetSpeedbar(Value: TJvSpeedBar);\r\nbegin\r\n if FSpeedbar <> Value then\r\n begin\r\n if FSpeedbar <> nil then\r\n FSpeedbar.SetEditing(NullHandle);\r\n FSpeedbar := Value;\r\n if FSpeedbar <> nil then\r\n begin\r\n FSpeedbar.SetEditing(Handle);\r\n UpdateListHeight;\r\n end;\r\n UpdateData(-1);\r\n end;\r\nend;\r\n\r\nprocedure TJvSpeedbarSetupWindow.CMSpeedBarChanged(var Msg: TMessage);\r\nbegin\r\n if Pointer(Msg.LParam) = FSpeedbar then\r\n case Msg.WParam of\r\n SBR_CHANGED:\r\n UpdateData(CurrentSection);\r\n SBR_DESTROYED:\r\n Close;\r\n SBR_BTNSIZECHANGED:\r\n if FSpeedbar <> nil then\r\n UpdateListHeight;\r\n end;\r\nend;\r\n\r\nfunction TJvSpeedbarSetupWindow.ItemByRow(Row: Integer): TJvSpeedItem;\r\nbegin\r\n Result := FSpeedbar.Items(CurrentSection, Row);\r\nend;\r\n\r\nprocedure TJvSpeedbarSetupWindow.UpdateHint(Section, Row: Integer);\r\nvar\r\n Item: TJvSpeedItem;\r\nbegin\r\n Item := FSpeedbar.Items(Section, Row);\r\n if Item <> nil then\r\n Hint := Item.Hint\r\n else\r\n Hint := '';\r\nend;\r\n\r\nprocedure TJvSpeedbarSetupWindow.FormClose(Sender: TObject; var Action: TCloseAction);\r\nbegin\r\n Action := caFree;\r\n FButton.Free;\r\n FButton := nil;\r\n if FSpeedbar <> nil then\r\n FSpeedbar.SetEditing(NullHandle);\r\n FSpeedbar := nil;\r\nend;\r\n\r\nprocedure TJvSpeedbarSetupWindow.SectionListSelectCell(Sender: TObject; Col,\r\n Row: Longint; var CanSelect: Boolean);\r\nbegin\r\n CanSelect := False;\r\n SetSection(Row);\r\n CanSelect := True;\r\nend;\r\n\r\nprocedure TJvSpeedbarSetupWindow.SectionListDrawCell(Sender: TObject;\r\n Col, Row: Longint; Rect: TRect; State: TGridDrawState);\r\nbegin\r\n if CheckSpeedBar then\r\n if Row < FSpeedbar.SectionCount then\r\n DrawCellText(Sender as TDrawGrid, Col, Row,\r\n FSpeedbar.Sections[Row].Caption, Rect, taLeftJustify, vaCenterJustify,\r\n TDrawGrid(Sender).IsRightToLeft);\r\nend;\r\n\r\nprocedure TJvSpeedbarSetupWindow.ButtonsListMouseDown(Sender: TObject;\r\n Button: TMouseButton; Shift: TShiftState; X, Y: Integer);\r\nvar\r\n Item: TJvSpeedItem;\r\nbegin\r\n Item := ItemByRow(ButtonsList.Row);\r\n if (Item <> nil) and (X < FSpeedbar.BtnWidth + 2) and (Button = mbLeft) then\r\n begin\r\n FDrag := True;\r\n if Item.Visible then\r\n FDragItem := nil\r\n else\r\n begin\r\n FDragItem := Item;\r\n if FButton = nil then\r\n begin\r\n FButton := TJvBtnControl.Create(Self);\r\n FButton.AssignSpeedItem(Item);\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvSpeedbarSetupWindow.ButtonsListMouseMove(Sender: TObject;\r\n Shift: TShiftState; X, Y: Integer);\r\nvar\r\n P: TPoint;\r\nbegin\r\n if FDrag and (FButton <> nil) and (FDragItem <> nil) then\r\n begin\r\n P := (Sender as TControl).ClientToScreen(Point(X, Y));\r\n X := P.X - FButton.Width {div 2};\r\n Y := P.Y - FButton.Height {div 2};\r\n FButton.Activate(Bounds(X, Y, FSpeedbar.BtnWidth, FSpeedbar.BtnHeight));\r\n end\r\n else\r\n if FDrag then\r\n SetCursor(Screen.Cursors[crNoDrop]);\r\nend;\r\n\r\nprocedure TJvSpeedbarSetupWindow.ButtonsListMouseUp(Sender: TObject;\r\n Button: TMouseButton; Shift: TShiftState; X, Y: Integer);\r\nvar\r\n P: TPoint;\r\nbegin\r\n if FDrag and (Button = mbLeft) then\r\n try\r\n if (FDragItem <> nil) and (FButton <> nil) then\r\n begin\r\n Dec(X, FButton.Width {div 2});\r\n Dec(Y, FButton.Height {div 2});\r\n P := (Sender as TControl).ClientToScreen(Point(X, Y));\r\n FButton.Free;\r\n FButton := nil;\r\n if CheckSpeedBar and (FSpeedbar = FindSpeedBar(P)) then\r\n begin\r\n P := FSpeedbar.ScreenToClient(P);\r\n if FSpeedbar.AcceptDropItem(FDragItem, P.X, P.Y) then\r\n UpdateCurrentSection;\r\n end;\r\n end\r\n else\r\n SetCursor(Screen.Cursors[ButtonsList.Cursor]);\r\n finally\r\n FDrag := False;\r\n FDragItem := nil;\r\n end;\r\nend;\r\n\r\nprocedure TJvSpeedbarSetupWindow.ButtonsListSelectCell(Sender: TObject; Col,\r\n Row: Longint; var CanSelect: Boolean);\r\nbegin\r\n CanSelect := not FDrag or (Row = ButtonsList.Row);\r\n if CanSelect then\r\n UpdateHint(CurrentSection, Row)\r\n else\r\n Hint := '';\r\nend;\r\n\r\nprocedure TJvSpeedbarSetupWindow.FormCreate(Sender: TObject);\r\nbegin\r\n FImage := TJvButtonImage.Create;\r\n FButton := nil;\r\n FSpeedbar := nil;\r\n FDrag := False;\r\n CloseBtn.Default := False;\r\n Font.Style := [];\r\n { Load string resources }\r\n CloseBtn.Caption := SOKButton;\r\n HelpBtn.Caption := SHelpButton;\r\n Caption := RsCustomizeSpeedbar;\r\n CategoriesLabel.Caption := RsSpeedbarCategories;\r\n ButtonsLabel.Caption := RsAvailButtons;\r\n HintLabel.Caption := RsSpeedbarEditHint;\r\nend;\r\n\r\nprocedure TJvSpeedbarSetupWindow.FormDestroy(Sender: TObject);\r\nbegin\r\n FImage.Free;\r\nend;\r\n\r\nprocedure TJvSpeedbarSetupWindow.ButtonsListDrawCell(Sender: TObject;\r\n Col, Row: Longint; Rect: TRect; State: TGridDrawState);\r\nvar\r\n I: Integer;\r\nbegin\r\n I := CurrentSection;\r\n if (I >= 0) and (Row < FSpeedbar.ItemsCount(I)) then\r\n DrawCellButton(Sender as TDrawGrid, Rect, ItemByRow(Row), FImage,\r\n TDrawGrid(Sender).IsRightToLeft);\r\nend;\r\n\r\nprocedure TJvSpeedbarSetupWindow.CloseBtnClick(Sender: TObject);\r\nbegin\r\n Close;\r\nend;\r\n\r\nprocedure TJvSpeedbarSetupWindow.HelpBtnClick(Sender: TObject);\r\nbegin\r\n Application.HelpContext(HelpContext);\r\nend;\r\n\r\nprocedure TJvSpeedbarSetupWindow.FormShow(Sender: TObject);\r\nbegin\r\n if FSpeedbar <> nil then\r\n UpdateListHeight;\r\n SectionList.DefaultColWidth := SectionList.ClientWidth;\r\n ButtonsList.DefaultColWidth := ButtonsList.ClientWidth;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvSpellChecker.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvSpellChecker.PAS, released on 2003-08-19.\r\n\r\nThe Initial Developer of the Original Code is Peter Thrnqvist [peter3 at sourceforge dot net]\r\nPortions created by Peter Thrnqvist are Copyright (C) 2003 Peter Thrnqvist.\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n- Items in the UserDictionary are not added to the internal WordTable/SoundexTable when\r\n you add a new item (i.e call UserDictionary.Add). This is mostly for performance.\r\n UserDictionary entries are loaded into the dictionary table in BuildTables, so to get\r\n them added make sure UserDictionary is filled before setting the Dictionary property.\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvSpellChecker.pas 13104 2011-09-07 06:50:43Z obones $\r\n\r\nunit JvSpellChecker;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n SysUtils, Classes, Windows, Controls, Messages,\r\n JvSpellIntf, JvComponentBase;\r\n\r\ntype\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64 or pidOSX32)]\r\n {$ENDIF RTL230_UP}\r\n TJvSpellChecker = class(TJvComponent)\r\n private\r\n FSpellChecker: IJvSpellChecker;\r\n procedure SetText(const Value: string);\r\n function GetText: string;\r\n function GetDictionary: TFileName;\r\n function GetUserDictionary: TStrings;\r\n procedure SetDictionary(const Value: TFileName);\r\n procedure SetUserDictionary(const Value: TStrings);\r\n function GetSpellChecker: IJvSpellChecker;\r\n function GetDelimiters: TSysCharSet;\r\n procedure SetDelimiters(const Value: TSysCharSet);\r\n function GetIgnores: TStrings;\r\n procedure SetIgnores(const Value: TStrings);\r\n function GetCanIgnore: TJvSpellCheckIgnoreEvent;\r\n procedure SetCanIgnore(const Value: TJvSpellCheckIgnoreEvent);\r\n public\r\n // reference to the actual spell check implementation\r\n property SpellChecker: IJvSpellChecker read GetSpellChecker;\r\n property Delimiters: TSysCharSet read GetDelimiters write SetDelimiters;\r\n published\r\n // Surface interface properties to make it a bit easier to work with this component\r\n property Text: string read GetText write SetText;\r\n property Dictionary: TFileName read GetDictionary write SetDictionary;\r\n property UserDictionary: TStrings read GetUserDictionary write SetUserDictionary;\r\n property Ignores: TStrings read GetIgnores write SetIgnores;\r\n property OnCanIgnore: TJvSpellCheckIgnoreEvent read GetCanIgnore write SetCanIgnore;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvSpellChecker.pas $';\r\n Revision: '$Revision: 13104 $';\r\n Date: '$Date: 2011-09-07 08:50:43 +0200 (mer. 07 sept. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n// JclStrings, // StrAddRef, StrDecRef\r\n JvTypes, JvResources;\r\n\r\n// NOTE: hash table and soundex lookup code originally from Julian Bucknall's\r\n// \"Algorithms Alfresco\" column in The Delphi Magazine, Issue 52, December 1999\r\n// Used with permission\r\nconst\r\n WordTableSize = 10007; {a prime}\r\n SoundexTableSize = 26 * 7 * 7 * 7; {the exact number of Soundexes}\r\n cDelimiters: TSysCharSet = [#0..#32, '.', ',', '<', '>', '=', '!', '?', ':', ';', '\"', '''', '(', ')', '[', ']', '{', '}', '+', '|'];\r\n\r\ntype\r\n TSoundex = string[4];\r\n // default implementation of the IJvSpellChecker interface. To provide a new implementation,\r\n // assign a function to the CreateSpellChecker function variable in JvSpellIntf that returns an\r\n // instance of your implementation. For more info, see InternalSpellChecker in this unit.\r\n TJvDefaultSpellChecker = class(TInterfacedObject, IJvSpellChecker)\r\n private\r\n FText: string;\r\n FCurrentWord: string;\r\n FPosition: Integer;\r\n FDictionary: string;\r\n FSuggestions: TStringList;\r\n FUserDictionary: TStringList;\r\n FIgnores: TStringList;\r\n FWordTable: TList;\r\n FSoundexTable: TList;\r\n FDelimiters: TSysCharSet;\r\n FOnCanIgnore: TJvSpellCheckIgnoreEvent;\r\n { IJvSpellChecker }\r\n procedure SetDictionary(const Value: string);\r\n function GetDictionary: string;\r\n function GetUserDictionary: TStrings;\r\n procedure SetUserDictionary(const Value: TStrings);\r\n function GetSuggestions: TStrings;\r\n function GetText: string;\r\n procedure SetText(const Value: string);\r\n function GetIgnores: TStrings;\r\n procedure SetIgnores(const Value: TStrings);\r\n function GetDelimiters: TSysCharSet;\r\n procedure SetDelimiters(const Value: TSysCharSet);\r\n function GetCanIgnore: TJvSpellCheckIgnoreEvent;\r\n procedure SetCanIgnore(const Value: TJvSpellCheckIgnoreEvent);\r\n protected\r\n procedure BuildTables; virtual;\r\n procedure ClearTables; virtual;\r\n function GetCurrentWord: string; virtual;\r\n procedure GetWordSuggestions(const Value: string; AStrings: TStrings); virtual;\r\n procedure AddSoundex(ASoundex: TSoundex; const Value: string); virtual;\r\n procedure AddWord(const Value: string); virtual;\r\n function WordExists(const Value: string): Boolean; virtual;\r\n function CanIgnore(const Value: string): Boolean; virtual;\r\n { IJvSpellChecker }\r\n function Next(out StartIndex, WordLength: Integer): WordBool; virtual;\r\n procedure Seek(Position: Integer); virtual;\r\n public\r\n constructor Create;\r\n destructor Destroy; override;\r\n property Delimiters: TSysCharSet read GetDelimiters write SetDelimiters;\r\n property Suggestions: TStrings read GetSuggestions;\r\n property Dictionary: string read GetDictionary write SetDictionary;\r\n property UserDictionary: TStrings read GetUserDictionary write SetUserDictionary;\r\n property Text: string read GetText write SetText;\r\n property Ignores: TStrings read GetIgnores write SetIgnores;\r\n property OnCanIgnore: TJvSpellCheckIgnoreEvent read GetCanIgnore write SetCanIgnore;\r\n end;\r\n\r\nfunction InternalCreateSpellChecker: IJvSpellChecker;\r\nbegin\r\n // create our implementation of the spell checker interface\r\n Result := TJvDefaultSpellChecker.Create;\r\nend;\r\n\r\nfunction Soundex(const Value: string): TSoundex;\r\nconst\r\n Encode: array ['A'..'Z'] of AnsiChar =\r\n ('0', '1', '2', '3', '0', '1', '2', '/', '0', '2', '2',\r\n '4', '5', '5', '0', '1', '2', '6', '2', '3', '0', '1',\r\n '/', '2', '0', '2');\r\nvar\r\n Ch: Char;\r\n Code, OldCode: AnsiChar;\r\n SxInx: Integer;\r\n I: Integer;\r\n UpperValue: string;\r\nbegin\r\n Result := 'A000';\r\n if Value = '' then\r\n Exit;\r\n// raise Exception.Create('Soundex: input string is empty');\r\n UpperValue := AnsiUpperCase(Value);\r\n\r\n Ch := UpperValue[1];\r\n if (Ch < 'A') or (Ch > 'Z') then\r\n Ch := 'A';\r\n// raise Exception.Create('Soundex: unknown character in input string');\r\n Result[1] := AnsiChar(Ch);\r\n Code := Encode[Ch];\r\n OldCode := Code;\r\n SxInx := 2;\r\n for I := 2 to Length(UpperValue) do\r\n begin\r\n if (Code <> '/') then\r\n OldCode := Code;\r\n Ch := UpperValue[I];\r\n if not ('A' <= Ch) and (Ch <= 'Z') then\r\n Code := '0'\r\n else\r\n Code := Encode[Ch];\r\n if (Code <> OldCode) and (Code > '0') then\r\n begin\r\n Result[SxInx] := Code;\r\n Inc(SxInx);\r\n if SxInx > 4 then\r\n Break;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction ELFHash(const S: string): Integer;\r\nvar\r\n G, I: Integer;\r\nbegin\r\n Result := 0;\r\n for I := 1 to Length(S) do\r\n begin\r\n Result := (Result shl 4) + Ord(S[I]);\r\n G := Result and Longint($F0000000);\r\n if G <> 0 then\r\n Result := Result xor (G shr 24);\r\n Result := Result and (not G);\r\n end;\r\nend;\r\n\r\nfunction SoundexHash(const S: TSoundex): Integer;\r\nbegin\r\n Result :=\r\n ((Ord(S[1]) - Ord('A')) * 343) +\r\n ((Ord(S[2]) - Ord('0')) * 49) +\r\n ((Ord(S[3]) - Ord('0')) * 7) +\r\n (Ord(S[4]) - Ord('0'));\r\nend;\r\n\r\nfunction GetNextWord(var S: PChar; out Word: string; Delimiters: TSysCharSet): Boolean;\r\nvar\r\n Start: PChar;\r\nbegin\r\n Word := '';\r\n Result := S = nil;\r\n if Result then\r\n Exit;\r\n Start := nil;\r\n while True do\r\n begin\r\n if S^ = #0 then\r\n begin\r\n Word := Start;\r\n Result := Start <> nil;\r\n Exit;\r\n end\r\n else\r\n if ((S^ <= #255) and (AnsiChar(S^) in Delimiters)) then\r\n begin\r\n if Start <> nil then\r\n begin\r\n SetString(Word, Start, S - Start);\r\n Exit;\r\n end\r\n else\r\n while ((S^ <= #255) and (AnsiChar(S^) in Delimiters)) and (S^ <> #0) do\r\n Inc(S);\r\n end\r\n else\r\n begin\r\n if Start = nil then\r\n Start := S;\r\n Inc(S);\r\n end;\r\n end;\r\nend;\r\n\r\n//=== { TJvDefaultSpellChecker } =============================================\r\n\r\nconstructor TJvDefaultSpellChecker.Create;\r\nbegin\r\n inherited Create;\r\n FDelimiters := cDelimiters;\r\n FSuggestions := TStringList.Create;\r\n FUserDictionary := TStringList.Create;\r\n FUserDictionary.Sorted := True;\r\n FIgnores := TStringList.Create;\r\n FIgnores.Sorted := True;\r\n\r\n FWordTable := TList.Create;\r\n FWordTable.Count := WordTableSize;\r\n FSoundexTable := TList.Create;\r\n FSoundexTable.Count := SoundexTableSize;\r\nend;\r\n\r\ndestructor TJvDefaultSpellChecker.Destroy;\r\nbegin\r\n ClearTables;\r\n FreeAndNil(FSuggestions);\r\n FreeAndNil(FUserDictionary);\r\n FreeAndNil(FWordTable);\r\n FreeAndNil(FSoundexTable);\r\n FreeAndNil(FIgnores);\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvDefaultSpellChecker.AddSoundex(ASoundex: TSoundex; const Value: string);\r\nvar\r\n Hash: Integer;\r\nbegin\r\n Hash := SoundexHash(ASoundex) mod SoundexTableSize;\r\n if FSoundexTable[Hash] = nil then\r\n FSoundexTable[Hash] := TStringList.Create;\r\n TStringList(FSoundexTable[Hash]).Add(Value);\r\nend;\r\n\r\nprocedure TJvDefaultSpellChecker.AddWord(const Value: string);\r\nvar\r\n Hash: Integer;\r\nbegin\r\n Hash := ELFHash(Value) mod WordTableSize;\r\n if FWordTable[Hash] = nil then\r\n FWordTable[Hash] := TStringList.Create;\r\n TStringList(FWordTable[Hash]).Add(Value);\r\nend;\r\n\r\nprocedure TJvDefaultSpellChecker.BuildTables;\r\nvar\r\n AFile: TextFile;\r\n Value: string;\r\n LastValue: string;\r\n SoundexVal: TSoundex;\r\n I: Integer;\r\n N: Integer;\r\nbegin\r\n ClearTables;\r\n if FileExists(Dictionary) then\r\n begin\r\n System.AssignFile(AFile, Dictionary);\r\n System.Reset(AFile);\r\n try\r\n repeat\r\n ReadLn(AFile, Value);\r\n if Value <> '' then\r\n begin\r\n // (rom) simple compession for dictionary\r\n N := Ord(Value[1]) - Ord('0');\r\n Value := Copy(Value, 2, Length(Value) - 1);\r\n if N > 0 then\r\n Value := Copy(LastValue, 1, N) + Value;\r\n LastValue := Value;\r\n\r\n Value := AnsiLowerCase(Value);\r\n AddWord(Value);\r\n SoundexVal := Soundex(Value);\r\n AddSoundex(SoundexVal, Value);\r\n end;\r\n until Eof(AFile);\r\n finally\r\n System.Close(AFile);\r\n end;\r\n for I := 0 to UserDictionary.Count - 1 do\r\n if UserDictionary[I] <> '' then\r\n begin\r\n Value := AnsiLowerCase(UserDictionary[I]);\r\n AddWord(Value);\r\n SoundexVal := Soundex(Value);\r\n AddSoundex(SoundexVal, Value);\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvDefaultSpellChecker.ClearTables;\r\nvar\r\n I: Integer;\r\nbegin\r\n if FSoundexTable <> nil then\r\n for I := 0 to FSoundexTable.Count - 1 do\r\n begin\r\n TObject(FSoundexTable[I]).Free;\r\n FSoundexTable[I] := nil;\r\n end;\r\n\r\n if FWordTable <> nil then\r\n for I := 0 to FWordTable.Count - 1 do\r\n begin\r\n TObject(FWordTable[I]).Free;\r\n FWordTable[I] := nil;\r\n end;\r\nend;\r\n\r\nfunction TJvDefaultSpellChecker.GetSuggestions: TStrings;\r\nbegin\r\n Result := FSuggestions;\r\nend;\r\n\r\nfunction TJvDefaultSpellChecker.GetText: string;\r\nbegin\r\n Result := FText;\r\nend;\r\n\r\nprocedure TJvDefaultSpellChecker.GetWordSuggestions(const Value: string; AStrings: TStrings);\r\nvar\r\n SoundexVal: TSoundex;\r\n Hash: Integer;\r\nbegin\r\n if AStrings <> nil then\r\n begin\r\n AStrings.BeginUpdate;\r\n try\r\n AStrings.Clear;\r\n SoundexVal := Soundex(Value);\r\n Hash := SoundexHash(SoundexVal) mod SoundexTableSize;\r\n if FSoundexTable[Hash] <> nil then\r\n AStrings.AddStrings(TStringList(FSoundexTable[Hash]));\r\n finally\r\n AStrings.EndUpdate;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJvDefaultSpellChecker.Next(out StartIndex, WordLength: Integer): WordBool;\r\nvar\r\n S: PChar;\r\nbegin\r\n StartIndex := 0;\r\n WordLength := 0;\r\n Result := False;\r\n if FPosition <= 0 then\r\n FPosition := 1;\r\n if FPosition >= Length(FText) then\r\n Exit;\r\n S := PChar(Text) + FPosition - 1;\r\n if (S = nil) or (S^ = #0) or (Trim(S) = '') then\r\n Exit;\r\n while True do\r\n begin\r\n FCurrentWord := '';\r\n GetNextWord(S, FCurrentWord, Delimiters);\r\n WordLength := Length(FCurrentWord);\r\n StartIndex := S - PChar(Text) - WordLength + 1;\r\n FPosition := StartIndex + WordLength;\r\n if (FCurrentWord <> '') and not CanIgnore(FCurrentWord) then\r\n begin\r\n FSuggestions.Clear;\r\n Result := not WordExists(FCurrentWord);\r\n if Result then\r\n begin\r\n GetWordSuggestions(FCurrentWord, FSuggestions);\r\n Break;\r\n end;\r\n end;\r\n if (S = nil) or (S^ = #0) or (Trim(S) = '') then\r\n begin\r\n Result := False;\r\n Break;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvDefaultSpellChecker.Seek(Position: Integer);\r\nbegin\r\n FPosition := Position;\r\nend;\r\n\r\nprocedure TJvDefaultSpellChecker.SetText(const Value: string);\r\nbegin\r\n FText := Value;\r\n FPosition := 1;\r\nend;\r\n\r\nfunction TJvDefaultSpellChecker.WordExists(const Value: string): Boolean;\r\nvar\r\n I: Integer;\r\n Hash: Integer;\r\n List: TStringList;\r\n FWord: string;\r\nbegin\r\n FWord := AnsiLowerCase(Value);\r\n Hash := ELFHash(FWord) mod WordTableSize;\r\n if FWordTable[Hash] <> nil then\r\n begin\r\n List := TStringList(FWordTable[Hash]);\r\n for I := 0 to List.Count - 1 do\r\n if AnsiSameText(PChar(List[I]), FWord) then\r\n begin\r\n Result := True;\r\n Exit;\r\n end;\r\n end;\r\n // ignore or user word?\r\n Result := (UserDictionary.IndexOf(FWord) > -1) or (Ignores.IndexOf(FWord) > -1);\r\nend;\r\n\r\nfunction TJvDefaultSpellChecker.GetDictionary: string;\r\nbegin\r\n Result := FDictionary;\r\nend;\r\n\r\nfunction TJvDefaultSpellChecker.GetUserDictionary: TStrings;\r\nbegin\r\n Result := FUserDictionary;\r\nend;\r\n\r\nprocedure TJvDefaultSpellChecker.SetDictionary(const Value: string);\r\nbegin\r\n if FDictionary <> Value then\r\n begin\r\n FDictionary := Value;\r\n BuildTables;\r\n end;\r\nend;\r\n\r\nprocedure TJvDefaultSpellChecker.SetUserDictionary(const Value: TStrings);\r\nbegin\r\n FUserDictionary.Assign(Value);\r\nend;\r\n\r\nfunction TJvDefaultSpellChecker.GetIgnores: TStrings;\r\nbegin\r\n Result := FIgnores;\r\nend;\r\n\r\nprocedure TJvDefaultSpellChecker.SetIgnores(const Value: TStrings);\r\nbegin\r\n FIgnores.Assign(Value);\r\nend;\r\n\r\nfunction TJvDefaultSpellChecker.GetDelimiters: TSysCharSet;\r\nbegin\r\n Result := FDelimiters;\r\nend;\r\n\r\nprocedure TJvDefaultSpellChecker.SetDelimiters(const Value: TSysCharSet);\r\nbegin\r\n FDelimiters := Value;\r\nend;\r\n\r\nfunction TJvDefaultSpellChecker.CanIgnore(const Value: string): Boolean;\r\nbegin\r\n Result := False;\r\n if Assigned(FOnCanIgnore) then\r\n FOnCanIgnore(Self, Value, Result);\r\nend;\r\n\r\nfunction TJvDefaultSpellChecker.GetCanIgnore: TJvSpellCheckIgnoreEvent;\r\nbegin\r\n Result := FOnCanIgnore;\r\nend;\r\n\r\nprocedure TJvDefaultSpellChecker.SetCanIgnore(const Value: TJvSpellCheckIgnoreEvent);\r\nbegin\r\n FOnCanIgnore := Value;\r\nend;\r\n\r\nfunction TJvDefaultSpellChecker.GetCurrentWord: string;\r\nbegin\r\n Result := FCurrentWord;\r\nend;\r\n\r\n//=== { TJvSpellChecker } ====================================================\r\n\r\nfunction TJvSpellChecker.GetCanIgnore: TJvSpellCheckIgnoreEvent;\r\nbegin\r\n Result := SpellChecker.OnCanIgnore;\r\nend;\r\n\r\nfunction TJvSpellChecker.GetDelimiters: TSysCharSet;\r\nbegin\r\n Result := SpellChecker.Delimiters;\r\nend;\r\n\r\nfunction TJvSpellChecker.GetDictionary: TFileName;\r\nbegin\r\n Result := SpellChecker.Dictionary;\r\nend;\r\n\r\nfunction TJvSpellChecker.GetIgnores: TStrings;\r\nbegin\r\n Result := SpellChecker.Ignores;\r\nend;\r\n\r\nfunction TJvSpellChecker.GetSpellChecker: IJvSpellChecker;\r\nbegin\r\n if FSpellChecker = nil then\r\n begin\r\n if Assigned(CreateSpellChecker) then\r\n FSpellChecker := CreateSpellChecker\r\n else\r\n FSpellChecker := InternalCreateSpellChecker;\r\n end;\r\n Result := FSpellChecker;\r\nend;\r\n\r\nfunction TJvSpellChecker.GetText: string;\r\nbegin\r\n Result := SpellChecker.GetText;\r\nend;\r\n\r\nfunction TJvSpellChecker.GetUserDictionary: TStrings;\r\nbegin\r\n Result := SpellChecker.UserDictionary;\r\nend;\r\n\r\nprocedure TJvSpellChecker.SetCanIgnore(const Value: TJvSpellCheckIgnoreEvent);\r\nbegin\r\n SpellChecker.OnCanIgnore := Value;\r\nend;\r\n\r\nprocedure TJvSpellChecker.SetDelimiters(const Value: TSysCharSet);\r\nbegin\r\n SpellChecker.Delimiters := Value;\r\nend;\r\n\r\nprocedure TJvSpellChecker.SetDictionary(const Value: TFileName);\r\nbegin\r\n SpellChecker.Dictionary := Value;\r\nend;\r\n\r\nprocedure TJvSpellChecker.SetIgnores(const Value: TStrings);\r\nbegin\r\n SpellChecker.Ignores := Value;\r\nend;\r\n\r\nprocedure TJvSpellChecker.SetText(const Value: string);\r\nbegin\r\n SpellChecker.SetText(Value);\r\nend;\r\n\r\nprocedure TJvSpellChecker.SetUserDictionary(const Value: TStrings);\r\nbegin\r\n SpellChecker.UserDictionary := Value;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n{$ENDIF UNITVERSIONING}\r\n\r\n{$IFDEF UNITVERSIONING}\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvSpellIntf.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvSpellIntf.PAS, released on 2003-08-19.\r\n\r\nThe Initial Developer of the Original Code is Peter Thrnqvist [peter3 at sourceforge dot net]\r\nPortions created by Peter Thrnqvist are Copyright (C) 2003 Peter Thrnqvist.\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nDescription:\r\n Interface declarations for classes that want to implement a spell\r\n checker compatible with the TJvSpellChecker component.\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvSpellIntf.pas 12461 2009-08-14 17:21:33Z obones $\r\n\r\nunit JvSpellIntf;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n SysUtils, Classes;\r\n\r\ntype\r\n TJvSpellCheckIgnoreEvent = procedure(Sender: TObject; const Value: string;\r\n var CanIgnore: Boolean) of object;\r\n\r\n IJvSpellChecker = interface\r\n ['{819CE37A-E3C1-4F54-B9E1-1CFAA8AFB887}']\r\n // GetCurrentWord returns the currently found misspelled or missing word\r\n function GetCurrentWord: string;\r\n // Seek moves the internal text pointer to the position in Text given by Position.\r\n // If Position >= Length(Text), calls to Next always returns false.\r\n // Since positioning is 1-based, Seek(0) = Seek(1).\r\n procedure Seek(Position: Integer);\r\n // Next returns true if a misspelled word was found. If a misspelled word\r\n // was found, StartIndex is set to the start of the word in Text and WordLength\r\n // is set to the length of the word. Note that StartIndex is 1-based, i.e the first\r\n // position in Text is 1. If Next returns false, it means that no more misspelled words\r\n // can be found (i.e either when at end of Text or everything from the current point and\r\n // onward is correctly spelled)\r\n function Next(out StartIndex, WordLength: Integer): WordBool;\r\n // The Text to spell check. When Text is changed, the internal position is reset\r\n // to the start of Text (no need to call Seek)\r\n function GetText: string;\r\n procedure SetText(const Value: string);\r\n property Text: string read GetText write SetText;\r\n // Delimiters specifies the characters that are used to break strings into words.\r\n function GetDelimiters: TSysCharSet;\r\n procedure SetDelimiters(const Value: TSysCharSet);\r\n property Delimiters: TSysCharSet read GetDelimiters write SetDelimiters;\r\n\r\n // Adds the content of a dictionary to the internal list of words that are scanned for matches.\r\n procedure SetDictionary(const Value: string);\r\n function GetDictionary: string;\r\n property Dictionary: string read GetDictionary write SetDictionary;\r\n // \"User\" dictionary. This is a list of words, sorted.\r\n // Manage the user dictionary by using the methods of TStrings.\r\n // The main difference between a dictionary and a user dictionary is that you cannot change\r\n // the content of the main dictionary from the interface. In addition, the UserDictionary is presumed to\r\n // contain a list of words, one per line, sorted whereas the dictionary can be in any format (determined\r\n // by the actual implementation).\r\n function GetUserDictionary: TStrings;\r\n procedure SetUserDictionary(const Value: TStrings);\r\n property UserDictionary: TStrings read GetUserDictionary write SetUserDictionary;\r\n // Ignores are used for words that should be ignored in the current session.\r\n // To make an ignore persistent, you should call UserDictionary.Add\r\n // and then save/load from file as needed.\r\n function GetIgnores: TStrings;\r\n procedure SetIgnores(const Value: TStrings);\r\n property Ignores: TStrings read GetIgnores write SetIgnores;\r\n // Suggestion returns the suggested replacements for a misspelled word. How the\r\n // implementation determines valid and/or useful replacement words is defined\r\n // by the implementation.\r\n function GetSuggestions: TStrings;\r\n property Suggestions: TStrings read GetSuggestions;\r\n // Assign a handler to this event when you need to set up ignores for words\r\n // that can't be captured using the ignore list and/or the user dictionary.\r\n function GetCanIgnore: TJvSpellCheckIgnoreEvent;\r\n procedure SetCanIgnore(const Value: TJvSpellCheckIgnoreEvent);\r\n property OnCanIgnore: TJvSpellCheckIgnoreEvent read GetCanIgnore write SetCanIgnore;\r\n end;\r\n\r\nvar\r\n CreateSpellChecker: function: IJvSpellChecker = nil;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvSpellIntf.pas $';\r\n Revision: '$Revision: 12461 $';\r\n Date: '$Date: 2009-08-14 19:21:33 +0200 (ven. 14 août 2009) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvSpellerForm.dfm", "content": "object JvSpellerForm: TJvSpellerForm\r\n Left = 306\r\n Top = 251\r\n BorderStyle = bsDialog\r\n Caption = 'Spelling checker'\r\n ClientHeight = 153\r\n ClientWidth = 371\r\n Color = clBtnFace\r\n Font.Charset = DEFAULT_CHARSET\r\n Font.Color = clWindowText\r\n Font.Height = -11\r\n Font.Name = 'MS Sans Serif'\r\n Font.Style = []\r\n OldCreateOrder = False\r\n PixelsPerInch = 96\r\n TextHeight = 13\r\n object LblContext: TLabel\r\n Left = 0\r\n Top = 33\r\n Width = 371\r\n Height = 86\r\n Hint = 'look ahead box'\r\n Align = alClient\r\n Caption = 'LblContext'\r\n ParentShowHint = False\r\n ShowHint = True\r\n WordWrap = True\r\n ExplicitWidth = 50\r\n ExplicitHeight = 13\r\n end\r\n object TextPanel: TPanel\r\n Left = 0\r\n Top = 0\r\n Width = 371\r\n Height = 33\r\n Align = alTop\r\n BevelInner = bvRaised\r\n BevelOuter = bvLowered\r\n TabOrder = 0\r\n object TxtSpell: TEdit\r\n Left = 7\r\n Top = 7\r\n Width = 293\r\n Height = 21\r\n TabOrder = 0\r\n Text = 'TxtSpell'\r\n end\r\n end\r\n object ButtonPanel: TPanel\r\n Left = 0\r\n Top = 119\r\n Width = 371\r\n Height = 34\r\n Align = alBottom\r\n BevelInner = bvRaised\r\n BevelOuter = bvLowered\r\n TabOrder = 1\r\n object BtnSkip: TButton\r\n Left = 13\r\n Top = 7\r\n Width = 61\r\n Height = 20\r\n Hint = 'Skip this word'\r\n Caption = '&Skip'\r\n ParentShowHint = False\r\n ShowHint = True\r\n TabOrder = 0\r\n end\r\n object BtnChange: TButton\r\n Left = 228\r\n Top = 7\r\n Width = 60\r\n Height = 20\r\n Hint = 'Change to corrected word'\r\n Caption = '&Change'\r\n ParentShowHint = False\r\n ShowHint = True\r\n TabOrder = 3\r\n end\r\n object BtnCancel: TButton\r\n Left = 299\r\n Top = 7\r\n Width = 61\r\n Height = 20\r\n Hint = 'Abort all changes'\r\n Caption = 'Cancel'\r\n ModalResult = 2\r\n ParentShowHint = False\r\n ShowHint = True\r\n TabOrder = 4\r\n end\r\n object BtnAdd: TButton\r\n Left = 156\r\n Top = 7\r\n Width = 61\r\n Height = 20\r\n Hint = 'Add to user Dictionary'\r\n Caption = '&Add'\r\n ParentShowHint = False\r\n ShowHint = True\r\n TabOrder = 2\r\n end\r\n object BtnSkipAll: TButton\r\n Left = 85\r\n Top = 7\r\n Width = 60\r\n Height = 20\r\n Hint = 'Skip all, update and finish'\r\n Caption = 'S&kip All'\r\n ModalResult = 1\r\n ParentShowHint = False\r\n ShowHint = True\r\n TabOrder = 1\r\n end\r\n end\r\nend\r\n" }, { "path": "External/Jedi/Jvcl/run/JvSpellerForm.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvSpellerForm.PAS, released on 2002-06-15.\r\n\r\nThe Initial Developer of the Original Code is Jan Verhoeven [jan1 dott verhoeven att wxs dott nl]\r\nPortions created by Jan Verhoeven are Copyright (C) 2002 Jan Verhoeven.\r\nAll Rights Reserved.\r\n\r\nContributor(s): Robert Love [rlove att slcdug dott org].\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvSpellerForm.pas 13170 2011-11-14 19:25:26Z ahuser $\r\n\r\nunit JvSpellerForm;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n SysUtils, Classes, Windows, Messages, Graphics, Controls, Forms, Dialogs,\r\n StdCtrls, ExtCtrls,\r\n JvComponent;\r\n\r\ntype\r\n TJvSpeller = class;\r\n\r\n TJvSpellerForm = class(TJvForm)\r\n TextPanel: TPanel;\r\n LblContext: TLabel;\r\n TxtSpell: TEdit;\r\n ButtonPanel: TPanel;\r\n BtnSkip: TButton;\r\n BtnChange: TButton;\r\n BtnCancel: TButton;\r\n BtnAdd: TButton;\r\n BtnSkipAll: TButton;\r\n private\r\n FSpeller: TJvSpeller;\r\n end;\r\n\r\n TJvDicIndexArray = array [1..26] of Integer;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64 or pidOSX32)]\r\n {$ENDIF RTL230_UP}\r\n TJvSpeller = class(TComponent)\r\n private\r\n FSourceText: string;\r\n FDict: string;\r\n FUserDic: string;\r\n FUserDicChanged: Boolean;\r\n FDicIndex: TJvDicIndexArray;\r\n FUserDicIndex: TJvDicIndexArray;\r\n FSpellerDialog: TJvSpellerForm;\r\n FWordBegin: Integer;\r\n FWordEnd: Integer;\r\n FDictionary: TFileName;\r\n FUserDictionary: TFileName;\r\n function WordBegin: Boolean;\r\n function WordEnd: Boolean;\r\n function ParseWord: string;\r\n procedure SpellNext;\r\n procedure Skip(Sender: TObject);\r\n procedure Add(Sender: TObject);\r\n procedure Change(Sender: TObject);\r\n procedure IndexDictionary;\r\n procedure IndexUserDictionary;\r\n procedure SetDictionary(const Value: TFileName);\r\n procedure SetUserDictionary(const Value: TFileName);\r\n procedure CreateSpellerDialog(const SpellWord: string);\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n procedure LoadDictionary(const AFile: string);\r\n procedure LoadUserDictionary(const AFile: string);\r\n procedure Spell(var SourceText: string);\r\n published\r\n property Dictionary: TFileName read FDictionary write SetDictionary;\r\n property UserDictionary: TFileName read FUserDictionary write SetUserDictionary;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvSpellerForm.pas $';\r\n Revision: '$Revision: 13170 $';\r\n Date: '$Date: 2011-11-14 20:25:26 +0100 (lun. 14 nov. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n StrUtils,\r\n {$IFNDEF COMPILER12_UP}\r\n JvJCLUtils,\r\n {$ENDIF ~COMPILER12_UP}\r\n JvConsts, JvResources, JvTypes;\r\n\r\n{$R *.dfm}\r\n\r\n{$IFDEF COMPILER6} // BCB 6 doesn't have the PosEx function\r\nfunction PosEx(const FindString, SourceString: string; StartPos: Integer): Integer;\r\nasm\r\n PUSH ESI\r\n PUSH EDI\r\n PUSH EBX\r\n PUSH EDX\r\n TEST EAX,EAX\r\n JE @@qt\r\n TEST EDX,EDX\r\n JE @@qt0\r\n MOV ESI,EAX\r\n MOV EDI,EDX\r\n MOV EAX,[EAX-4]\r\n MOV EDX,[EDX-4]\r\n DEC EAX\r\n SUB EDX,EAX\r\n DEC ECX\r\n SUB EDX,ECX\r\n JNG @@qt0\r\n MOV EBX,EAX\r\n XCHG EAX,EDX\r\n NOP\r\n ADD EDI,ECX\r\n MOV ECX,EAX\r\n MOV AL,BYTE PTR [ESI]\r\n@@lp1: CMP AL,BYTE PTR [EDI]\r\n JE @@uu\r\n@@fr: INC EDI\r\n DEC ECX\r\n JNZ @@lp1\r\n@@qt0: XOR EAX,EAX\r\n JMP @@qt\r\n@@ms: MOV AL,BYTE PTR [ESI]\r\n MOV EBX,EDX\r\n JMP @@fr\r\n@@uu: TEST EDX,EDX\r\n JE @@fd\r\n@@lp2: MOV AL,BYTE PTR [ESI+EBX]\r\n XOR AL,BYTE PTR [EDI+EBX]\r\n JNE @@ms\r\n DEC EBX\r\n JNE @@lp2\r\n@@fd: LEA EAX,[EDI+1]\r\n SUB EAX,[ESP]\r\n@@qt: POP ECX\r\n POP EBX\r\n POP EDI\r\n POP ESI\r\nend;\r\n{$ENDIF COMPILER6}\r\n\r\nprocedure SaveAnsiFileFromString(const AFile, AText: string);\r\nvar\r\n AnsiText: AnsiString;\r\nbegin\r\n AnsiText := AnsiString(AText);\r\n with TFileStream.Create(AFile, fmCreate) do\r\n try\r\n WriteBuffer(AnsiText[1], Length(AnsiText));\r\n finally\r\n Free;\r\n end;\r\nend;\r\n\r\nfunction LoadAnsiFileToString(const AFile: string): string;\r\nvar\r\n AnsiText: AnsiString;\r\nbegin\r\n with TFileStream.Create(AFile, fmOpenRead) do\r\n try\r\n SetLength(AnsiText, Size);\r\n if AnsiText <> '' then\r\n ReadBuffer(AnsiText[1], Size);\r\n finally\r\n Free;\r\n end;\r\n Result := string(AnsiText);\r\nend;\r\n\r\n//=== { TJvSpeller } =========================================================\r\n\r\nconstructor TJvSpeller.Create(AOwner: TComponent);\r\nvar\r\n I: Integer;\r\nbegin\r\n inherited Create(AOwner);\r\n for I := 1 to 26 do\r\n begin\r\n FDicIndex[I] := 1;\r\n FUserDicIndex[I] := 1;\r\n end;\r\nend;\r\n\r\nprocedure TJvSpeller.Add(Sender: TObject);\r\nvar\r\n S: string;\r\nbegin\r\n S := FSpellerDialog.TxtSpell.Text;\r\n if S = '' then\r\n Exit;\r\n FUserDic := FUserDic + LowerCase(S) + Cr;\r\n FUserDicChanged := True;\r\n with TStringList.Create do\r\n try\r\n Text := FUserDic;\r\n Sort;\r\n FUserDic := Text;\r\n finally\r\n Free;\r\n end;\r\n IndexUserDictionary;\r\n Skip(Sender);\r\nend;\r\n\r\nprocedure TJvSpeller.Change(Sender: TObject);\r\nvar\r\n S: string;\r\nbegin\r\n S := FSpellerDialog.TxtSpell.Text;\r\n if S <> '' then\r\n begin\r\n FSourceText := Copy(FSourceText, 1, FWordBegin - 1) + S +\r\n Copy(FSourceText, FWordEnd, Length(FSourceText));\r\n FWordEnd := FWordEnd + (Length(S) - (FWordEnd - FWordBegin));\r\n Skip(Sender);\r\n end;\r\nend;\r\n\r\nprocedure TJvSpeller.IndexDictionary;\r\nvar\r\n I, P, StartPos: Integer;\r\nbegin\r\n FDicIndex[1] := 1;\r\n for I := 2 to 26 do\r\n begin\r\n if FDicIndex[I - 1] <> 1 then\r\n StartPos := FDicIndex[I - 1]\r\n else\r\n StartPos := 1;\r\n P := PosEx(Cr + Chr(96 + I), FDict, StartPos);\r\n if P <> 0 then\r\n FDicIndex[I] := P\r\n else\r\n FDicIndex[I] := FDicIndex[I - 1];\r\n end;\r\nend;\r\n\r\nprocedure TJvSpeller.IndexUserDictionary;\r\nvar\r\n I, P, StartPos: Integer;\r\nbegin\r\n FUserDicIndex[1] := 1;\r\n for I := 2 to 26 do\r\n begin\r\n if FUserDicIndex[I - 1] <> 1 then\r\n StartPos := FUserDicIndex[I - 1]\r\n else\r\n StartPos := 1;\r\n P := PosEx(Cr + Chr(96 + I), FUserDic, StartPos);\r\n if P <> 0 then\r\n FUserDicIndex[I] := P\r\n else\r\n FUserDicIndex[I] := FUserDicIndex[I - 1];\r\n end;\r\nend;\r\n\r\nprocedure TJvSpeller.LoadDictionary(const AFile: string);\r\nbegin\r\n if FileExists(AFile) then\r\n FDict := LoadAnsiFileToString(AFile)\r\n else\r\n FDict := '';\r\n IndexDictionary;\r\nend;\r\n\r\nprocedure TJvSpeller.LoadUserDictionary(const AFile: string);\r\nbegin\r\n UserDictionary := AFile;\r\n FUserDicChanged := False;\r\n if FileExists(AFile) then\r\n FUserDic := LoadAnsiFileToString(AFile)\r\n else\r\n FUserDic := '';\r\n IndexUserDictionary;\r\nend;\r\n\r\nfunction TJvSpeller.ParseWord: string;\r\nbegin\r\n if WordBegin and WordEnd then\r\n Result := Copy(FSourceText, FWordBegin, FWordEnd - FWordBegin)\r\n else\r\n Result := '';\r\nend;\r\n\r\nprocedure TJvSpeller.SetDictionary(const Value: TFileName);\r\nbegin\r\n if FDictionary <> Value then\r\n begin\r\n FDictionary := Value;\r\n LoadDictionary(FDictionary);\r\n end;\r\nend;\r\n\r\nprocedure TJvSpeller.SetUserDictionary(const Value: TFileName);\r\nbegin\r\n if FUserDictionary <> Value then\r\n begin\r\n FUserDictionary := Value;\r\n LoadUserDictionary(FUserDictionary);\r\n end;\r\nend;\r\n\r\nprocedure TJvSpeller.Skip(Sender: TObject);\r\nbegin\r\n FSpellerDialog.TxtSpell.Text := '';\r\n SpellNext;\r\nend;\r\n\r\nprocedure TJvSpeller.CreateSpellerDialog(const SpellWord: string);\r\nbegin\r\n FSpellerDialog := TJvSpellerForm.Create(Application);\r\n with FSpellerDialog do\r\n begin\r\n FSpeller := Self;\r\n BtnSkip.OnClick := Skip;\r\n BtnChange.OnClick := Change;\r\n BtnAdd.OnClick := Add;\r\n BtnAdd.Enabled := UserDictionary <> '';\r\n TxtSpell.Text := SpellWord;\r\n LblContext.Caption := Copy(FSourceText, FWordBegin, 75);\r\n end;\r\nend;\r\n\r\nprocedure TJvSpeller.Spell(var SourceText: string);\r\nvar\r\n Spw, S: string;\r\n StartPos, Index: Integer;\r\nbegin\r\n if FDict = '' then\r\n raise EJVCLException.CreateRes(@RsENoDictionaryLoaded);\r\n\r\n FSourceText := SourceText;\r\n FWordEnd := 1;\r\n\r\n Spw := ParseWord;\r\n while Spw <> '' do\r\n begin\r\n S := AnsiLowerCase(Spw);\r\n Index := Ord(S[1]) - 96;\r\n if (Index > 0) and (Index < 27) then\r\n StartPos := FDicIndex[Index]\r\n else\r\n StartPos := 1;\r\n\r\n if PosEx(S + Cr, FDict, StartPos) = 0 then\r\n begin\r\n if FUserDic <> '' then\r\n begin\r\n if (Index > 0) and (Index < 27) then\r\n StartPos := FUserDicIndex[Index]\r\n else\r\n StartPos := 1;\r\n if PosEx(S + Cr, FUserDic, StartPos) = 0 then\r\n begin\r\n CreateSpellerDialog(Spw);\r\n try\r\n if FSpellerDialog.ShowModal = mrOk then\r\n SourceText := FSourceText;\r\n // (rom) the user dictionary has to be saved always!\r\n if FUserDicChanged then\r\n if FUserDic <> '' then\r\n SaveAnsiFileFromString(UserDictionary, FUserDic);\r\n finally\r\n FSpellerDialog.Free;\r\n end;\r\n Exit;\r\n end\r\n end\r\n else\r\n begin\r\n CreateSpellerDialog(Spw);\r\n try\r\n if FSpellerDialog.ShowModal = mrOk then\r\n SourceText := FSourceText;\r\n // (rom) the user dictionary has to be saved always!\r\n if FUserDicChanged then\r\n if FUserDic <> '' then\r\n SaveAnsiFileFromString(UserDictionary, FUserDic);\r\n finally\r\n FSpellerDialog.Free;\r\n end;\r\n Exit;\r\n end;\r\n end;\r\n\r\n Spw := ParseWord;\r\n end;\r\nend;\r\n\r\nprocedure TJvSpeller.SpellNext;\r\nvar\r\n Spw, S: string;\r\n Index, StartPos: Integer;\r\nbegin\r\n Spw := ParseWord;\r\n while Spw <> '' do\r\n begin\r\n S := AnsiLowerCase(Spw);\r\n Index := Ord(S[1]) - 96;\r\n if (Index > 0) and (Index < 27) then\r\n StartPos := FDicIndex[Index]\r\n else\r\n StartPos := 1;\r\n\r\n if PosEx(S + Cr, FDict, StartPos) = 0 then\r\n begin\r\n if FUserDic <> '' then\r\n begin\r\n if (Index > 0) and (Index < 27) then\r\n StartPos := FUserDicIndex[Index]\r\n else\r\n StartPos := 1;\r\n if PosEx(S + Cr, FUserDic, StartPos) = 0 then\r\n begin\r\n FSpellerDialog.TxtSpell.Text := Spw;\r\n FSpellerDialog.LblContext.Caption := Copy(FSourceText, FWordBegin, 75);\r\n Exit;\r\n end;\r\n end\r\n else\r\n begin\r\n FSpellerDialog.TxtSpell.Text := Spw;\r\n FSpellerDialog.LblContext.Caption := Copy(FSourceText, FWordBegin, 75);\r\n Exit;\r\n end;\r\n end;\r\n Spw := ParseWord;\r\n end;\r\n FSpellerDialog.ModalResult := mrOk;\r\nend;\r\n\r\nfunction TJvSpeller.WordBegin: Boolean;\r\nvar\r\n L: Integer;\r\nbegin\r\n L := Length(FSourceText);\r\n FWordBegin := FWordEnd;\r\n while (FWordBegin <= L) and (not CharInSet(FSourceText[FWordBegin], ['a'..'z', 'A'..'Z'])) do\r\n Inc(FWordBegin);\r\n Result := (FWordBegin <= L);\r\nend;\r\n\r\nfunction TJvSpeller.WordEnd: Boolean;\r\nvar\r\n L: Integer;\r\nbegin\r\n FWordEnd := FWordBegin;\r\n L := Length(FSourceText);\r\n while (FWordEnd <= L) and CharInSet(FSourceText[FWordEnd], ['a'..'z', 'A'..'Z']) do\r\n Inc(FWordEnd);\r\n Result := (FWordEnd <= L);\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvSpin.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvSpin.PAS, released on 2002-07-04.\r\n\r\nThe Initial Developers of the Original Code are: Fedor Koshevnikov, Igor Pavluk and Serge Korolev\r\nCopyright (c) 1997, 1998 Fedor Koshevnikov, Igor Pavluk and Serge Korolev\r\nCopyright (c) 2001,2002 SGB Software\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\n Polaris Software\r\n boerema1\r\n roko\r\n remkobonte\r\n Niels v/d Spek\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvSpin.pas 13415 2012-09-10 09:51:54Z obones $\r\n\r\nunit JvSpin;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n SysUtils, Classes,\r\n Windows, Messages, CommCtrl, ComCtrls, Controls, ExtCtrls, Graphics, Forms,\r\n JvExMask, JvComponent, JvDataSourceIntf;\r\n\r\nconst\r\n DefaultInitRepeatPause = 400; { pause before repeat timer (ms) }\r\n DefaultRepeatPause = 100;\r\n\r\ntype\r\n TSpinButtonState = (sbNotDown, sbTopDown, sbBottomDown);\r\n\r\n TJvSpinButtonStyle = (sbsDefault, sbsClassic);\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvSpinButton = class(TJvGraphicControl)\r\n private\r\n FDown: TSpinButtonState;\r\n FDragging: Boolean;\r\n FUpBitmap: TBitmap; // Custom up arrow\r\n FDownBitmap: TBitmap; // Custom down arrow\r\n FButtonBitmaps: Pointer;\r\n {$IFDEF JVCLThemesEnabled}\r\n FMouseInTopBtn: Boolean;\r\n FMouseInBottomBtn: Boolean;\r\n {$ENDIF JVCLThemesEnabled}\r\n FRepeatTimer: TTimer;\r\n FLastDown: TSpinButtonState;\r\n FFocusControl: TWinControl;\r\n FOnTopClick: TNotifyEvent;\r\n FOnBottomClick: TNotifyEvent;\r\n FButtonStyle: TJvSpinButtonStyle;\r\n FInitRepeatPause: Integer;\r\n FRepeatPause: Integer;\r\n procedure SetButtonStyle(Value: TJvSpinButtonStyle);\r\n procedure TopClick;\r\n procedure BottomClick;\r\n procedure GlyphChanged(Sender: TObject);\r\n function GetDownGlyph: TBitmap;\r\n function GetUpGlyph: TBitmap;\r\n procedure SetDown(Value: TSpinButtonState);\r\n procedure SetDownGlyph(Value: TBitmap);\r\n procedure SetFocusControl(Value: TWinControl);\r\n procedure SetUpGlyph(Value: TBitmap);\r\n procedure TimerExpired(Sender: TObject);\r\n procedure CMSysColorChange(var Msg: TMessage); message CM_SYSCOLORCHANGE;\r\n protected\r\n procedure CheckButtonBitmaps;\r\n procedure RemoveButtonBitmaps;\r\n procedure Paint; override;\r\n procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;\r\n procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;\r\n procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;\r\n procedure Notification(AComponent: TComponent; Operation: TOperation); override;\r\n\r\n function MouseInBottomBtn(const P: TPoint): Boolean;\r\n {$IFDEF JVCLThemesEnabled}\r\n procedure MouseEnter(Control: TControl); override;\r\n procedure MouseLeave(Control: TControl); override;\r\n {$ENDIF JVCLThemesEnabled}\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n property Down: TSpinButtonState read FDown write SetDown default sbNotDown;\r\n published\r\n property ButtonStyle: TJvSpinButtonStyle read FButtonStyle write SetButtonStyle default sbsDefault;\r\n property DragCursor;\r\n property DragKind;\r\n property OnEndDock;\r\n property OnStartDock;\r\n property DragMode;\r\n property Enabled;\r\n property Visible;\r\n property Height default 20;\r\n property Width default 20;\r\n property DownGlyph: TBitmap read GetDownGlyph write SetDownGlyph;\r\n property UpGlyph: TBitmap read GetUpGlyph write SetUpGlyph;\r\n property FocusControl: TWinControl read FFocusControl write SetFocusControl;\r\n property InitRepeatPause: Integer read FInitRepeatPause write FInitRepeatPause default DefaultInitRepeatPause;\r\n property RepeatPause: Integer read FRepeatPause write FRepeatPause default DefaultRepeatPause;\r\n property ShowHint;\r\n property ParentShowHint;\r\n property Anchors;\r\n property Constraints;\r\n property OnBottomClick: TNotifyEvent read FOnBottomClick write FOnBottomClick;\r\n property OnTopClick: TNotifyEvent read FOnTopClick write FOnTopClick;\r\n property OnDragDrop;\r\n property OnDragOver;\r\n property OnEndDrag;\r\n property OnStartDrag;\r\n end;\r\n\r\n {$IFDEF BCB}\r\n TValueType = (vtInt, vtFloat, vtHex);\r\n {$ELSE}\r\n TValueType = (vtInteger, vtFloat, vtHex);\r\n {$ENDIF BCB}\r\n\r\n TSpinButtonKind = (bkStandard, bkDiagonal, bkClassic);\r\n\r\n TJvCheckOption = (coCheckOnChange, coCheckOnExit, coCropBeyondLimit);\r\n TJvCheckOptions = set of TJvCheckOption;\r\n\r\n TJvCustomSpinEdit = class(TJvExCustomMaskEdit)\r\n private\r\n FShowButton: Boolean;\r\n FCheckMaxValue: Boolean;\r\n FCheckMinValue: Boolean;\r\n FCheckOptions: TJvCheckOptions;\r\n FDisplayFormat: string;\r\n FFocused: Boolean;\r\n FLCheckMaxValue: Boolean;\r\n FLCheckMinValue: Boolean;\r\n FAlignment: TAlignment;\r\n FMinValue: Extended;\r\n FMaxValue: Extended;\r\n FOldValue: Extended;\r\n FIncrement: Extended;\r\n FDecimal: Byte;\r\n FChanging: Boolean;\r\n //FOldValue: Extended; // New\r\n FEditorEnabled: Boolean;\r\n FValueType: TValueType;\r\n FButton: TJvSpinButton;\r\n FBtnWindow: TWinControl;\r\n FArrowKeys: Boolean;\r\n FOnTopClick: TNotifyEvent;\r\n FOnBottomClick: TNotifyEvent;\r\n // FButtonKind: TSpinButtonKind;\r\n FUpDown: TCustomUpDown;\r\n FThousands: Boolean; // New\r\n FIsNegative: Boolean;\r\n function StoreCheckMaxValue: Boolean;\r\n function StoreCheckMinValue: Boolean;\r\n procedure SetCheckMaxValue(NewValue: Boolean);\r\n procedure SetCheckMinValue(NewValue: Boolean);\r\n procedure SetMaxValue(NewValue: Extended);\r\n procedure SetMinValue(NewValue: Extended);\r\n\r\n function CheckDefaultRange(CheckMax: Boolean): Boolean;\r\n procedure SetDisplayFormat(const Value: string);\r\n function IsFormatStored: Boolean;\r\n //function TextToValText(const AValue: string): string;\r\n procedure SetFocused(Value: Boolean);\r\n //procedure CheckRange(const AOption: TJvCheckOption);\r\n\r\n //function TryGetValue(var Value: Extended): Boolean; // New\r\n function GetAsInteger: Longint;\r\n function GetButtonKind: TSpinButtonKind;\r\n function GetButtonWidth: Integer;\r\n function GetMinHeight: Integer;\r\n function IsIncrementStored: Boolean;\r\n function IsMaxStored: Boolean;\r\n function IsMinStored: Boolean;\r\n function IsValueStored: Boolean;\r\n procedure GetTextHeight(var SysHeight, Height: Integer);\r\n procedure ResizeButton;\r\n procedure SetAlignment(Value: TAlignment);\r\n procedure SetArrowKeys(Value: Boolean);\r\n procedure SetAsInteger(NewValue: Longint);\r\n procedure SetButtonKind(Value: TSpinButtonKind);\r\n procedure SetDecimal(NewValue: Byte);\r\n procedure SetEditRect;\r\n procedure SetThousands(Value: Boolean);\r\n procedure UpDownClick(Sender: TObject; Button: TUDBtnType);\r\n procedure SetShowButton(Value: Boolean);\r\n procedure CMBiDiModeChanged(var Msg: TMessage); message CM_BIDIMODECHANGED;\r\n procedure CMCtl3DChanged(var Msg: TMessage); message CM_CTL3DCHANGED;\r\n protected\r\n FButtonKind: TSpinButtonKind;\r\n procedure WMPaste(var Msg: TMessage); message WM_PASTE;\r\n procedure WMCut(var Msg: TMessage); message WM_CUT;\r\n procedure FocusKilled(NextWnd: THandle); override;\r\n function DoMouseWheel(Shift: TShiftState; WheelDelta: Integer; MousePos: TPoint): Boolean; override;\r\n procedure BoundsChanged; override;\r\n procedure EnabledChanged; override;\r\n procedure DoEnter; override;\r\n procedure DoExit; override;\r\n procedure FontChanged; override;\r\n function CheckValue(NewValue: Extended): Extended;\r\n function CheckValueRange(NewValue: Extended; RaiseOnError: Boolean): Extended;\r\n function GetValue: Extended; virtual; abstract;\r\n procedure DataChanged; virtual;\r\n procedure RecreateButton;\r\n procedure SetValue(NewValue: Extended); virtual; abstract;\r\n procedure SetValueType(NewType: TValueType); virtual;\r\n\r\n function DefaultDisplayFormat: string; virtual;\r\n property DisplayFormat: string read FDisplayFormat write SetDisplayFormat stored IsFormatStored;\r\n // procedure DefinePropertyes(Filer: TFiler); override;\r\n\r\n function IsValidChar(Key: Char): Boolean; virtual;\r\n procedure Change; override;\r\n procedure CreateParams(var Params: TCreateParams); override;\r\n procedure CreateWnd; override;\r\n procedure DownClick(Sender: TObject); virtual;\r\n procedure KeyDown(var Key: Word; Shift: TShiftState); override;\r\n procedure KeyPress(var Key: Char); override;\r\n procedure UpClick(Sender: TObject); virtual;\r\n property ButtonWidth: Integer read GetButtonWidth;\r\n\r\n procedure DoTopClick;\r\n procedure DoBottomClick;\r\n public\r\n procedure Loaded; override;\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n\r\n property AsInteger: Longint read GetAsInteger write SetAsInteger default 0;\r\n property Text;\r\n property Alignment: TAlignment read FAlignment write SetAlignment default taLeftJustify;\r\n property ArrowKeys: Boolean read FArrowKeys write SetArrowKeys default True;\r\n property ButtonKind: TSpinButtonKind read FButtonKind write SetButtonKind default bkDiagonal;\r\n property Decimal: Byte read FDecimal write SetDecimal default 2;\r\n property EditorEnabled: Boolean read FEditorEnabled write FEditorEnabled default True;\r\n property Increment: Extended read FIncrement write FIncrement stored IsIncrementStored;\r\n property MaxValue: Extended read FMaxValue write SetMaxValue stored IsMaxStored;\r\n property MinValue: Extended read FMinValue write SetMinValue stored IsMinStored;\r\n property CheckOptions: TJvCheckOptions read FCheckOptions write FCheckOptions default\r\n [coCheckOnChange, coCheckOnExit, coCropBeyondLimit];\r\n property CheckMinValue: Boolean read FCheckMinValue write SetCheckMinValue stored StoreCheckMinValue;\r\n property CheckMaxValue: Boolean read FCheckMaxValue write SetCheckMaxValue stored StoreCheckMaxValue;\r\n property ValueType: TValueType read FValueType write SetValueType\r\n default {$IFDEF BCB} vtInt {$ELSE} vtInteger {$ENDIF};\r\n property Value: Extended read GetValue write SetValue stored IsValueStored;\r\n property Thousands: Boolean read FThousands write SetThousands default False;\r\n property ShowButton: Boolean read FShowButton write SetShowButton default True;\r\n property OnBottomClick: TNotifyEvent read FOnBottomClick write FOnBottomClick;\r\n property OnTopClick: TNotifyEvent read FOnTopClick write FOnTopClick;\r\n end;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvSpinEdit = class(TJvCustomSpinEdit)\r\n protected\r\n procedure SetValue(NewValue: Extended); override;\r\n function GetValue: Extended; override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n published\r\n property CheckOptions;\r\n property CheckMinValue;\r\n property CheckMaxValue;\r\n\r\n property BeepOnError;\r\n\r\n property Align;\r\n property Alignment;\r\n property ArrowKeys;\r\n property DisplayFormat;\r\n property ButtonKind default bkDiagonal;\r\n property Thousands;\r\n property Decimal;\r\n property EditorEnabled;\r\n property Increment;\r\n property MaxValue;\r\n property MinValue;\r\n property ShowButton;\r\n property ValueType;\r\n property Value;\r\n property OnBottomClick;\r\n property OnTopClick;\r\n\r\n property AutoSelect;\r\n property AutoSize;\r\n property BorderStyle;\r\n property Color;\r\n property DragCursor;\r\n property BiDiMode;\r\n property DragKind;\r\n property ParentBiDiMode;\r\n property ImeMode;\r\n property ImeName;\r\n property OnEndDock;\r\n property OnStartDock;\r\n property DragMode;\r\n property Enabled;\r\n property Font;\r\n property Anchors;\r\n property Constraints;\r\n property MaxLength;\r\n property ParentColor;\r\n property ParentFont;\r\n property ParentShowHint;\r\n property PopupMenu;\r\n property ReadOnly;\r\n property ShowHint;\r\n property TabOrder;\r\n property TabStop;\r\n property Visible;\r\n property OnChange;\r\n property OnClick;\r\n property OnDblClick;\r\n property OnDragDrop;\r\n property OnDragOver;\r\n property OnEndDrag;\r\n property OnEnter;\r\n property OnExit;\r\n property OnKeyDown;\r\n property OnKeyPress;\r\n property OnKeyUp;\r\n property OnMouseDown;\r\n property OnMouseMove;\r\n property OnMouseUp;\r\n property OnStartDrag;\r\n property OnContextPopup;\r\n property OnMouseWheelDown;\r\n property OnMouseWheelUp;\r\n property HideSelection;\r\n property BevelEdges;\r\n property BevelInner;\r\n property BevelKind default bkNone;\r\n property BevelOuter;\r\n property ClipboardCommands;\r\n end;\r\n\r\n TJvCustomTimeEdit = class;\r\n\r\n TJvCustomTimeEditDataConnector = class(TJvFieldDataConnector)\r\n private\r\n FEdit: TJvCustomTimeEdit;\r\n protected\r\n procedure RecordChanged; override;\r\n procedure UpdateData; override;\r\n property Control: TJvCustomTimeEdit read FEdit;\r\n public\r\n constructor Create(AEdit: TJvCustomTimeEdit);\r\n end;\r\n\r\n TJvCustomTimeEdit = class(TJvCustomSpinEdit)\r\n private\r\n Position: Integer;\r\n FHour24: Boolean;\r\n FShowSeconds: Boolean;\r\n FTime: TDateTime;\r\n FDataConnector: TJvCustomTimeEditDataConnector;\r\n procedure SetShowSeconds(Value: Boolean);\r\n procedure SetHour24(Value: Boolean);\r\n procedure SetDataConnector(const Value: TJvCustomTimeEditDataConnector);\r\n protected\r\n procedure CMGetDataLink(var Msg: TMessage); message CM_GETDATALINK;\r\n procedure WMPaste(var Msg: TMessage); message WM_PASTE;\r\n procedure WMCut(var Msg: TMessage); message WM_CUT;\r\n procedure UpdateTimeDigits(Increment: Boolean);\r\n function IsTimeValid(const Value: string): Boolean;\r\n procedure SetValue(NewValue: Extended); override;\r\n function GetValue: Extended; override;\r\n function GetTime: TDateTime; virtual;\r\n procedure SetTime(Value: TDateTime); virtual;\r\n\r\n procedure UpClick(Sender: TObject); Override;\r\n procedure DownClick(Sender: TObject); Override;\r\n procedure KeyPress(var Key: Char); override;\r\n procedure KeyDown(var Key: Word; Shift: TShiftState); override;\r\n\r\n function CreateDataConnector: TJvCustomTimeEditDataConnector; virtual;\r\n procedure Change; override;\r\n procedure DoExit; override;\r\n\r\n property ButtonKind default bkDiagonal;\r\n property ShowSeconds: Boolean read FShowSeconds write SetShowSeconds default False;\r\n property Hour24: Boolean read FHour24 write SetHour24 default True;\r\n property DataConnector: TJvCustomTimeEditDataConnector read FDataConnector write SetDataConnector;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n\r\n property Time: TDateTime read GetTime write SetTime;\r\n end;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvTimeEdit = class(TJvCustomTimeEdit)\r\n published\r\n property ButtonKind default bkDiagonal;\r\n property ShowSeconds default False;\r\n property Hour24 default True;\r\n property DataConnector;\r\n property ShowButton;\r\n property EditorEnabled;\r\n property ArrowKeys;\r\n\r\n property Align;\r\n property Alignment;\r\n property AutoSelect;\r\n property AutoSize;\r\n property BorderStyle;\r\n property Color;\r\n property DragCursor;\r\n property BiDiMode;\r\n property DragKind;\r\n property ParentBiDiMode;\r\n property ImeMode;\r\n property ImeName;\r\n property OnEndDock;\r\n property OnStartDock;\r\n property DragMode;\r\n property Enabled;\r\n property Font;\r\n property Anchors;\r\n property Constraints;\r\n property MaxLength;\r\n property ParentColor;\r\n property ParentFont;\r\n property ParentShowHint;\r\n property PopupMenu;\r\n property ReadOnly;\r\n property ShowHint;\r\n property TabOrder;\r\n property TabStop;\r\n property Visible;\r\n property OnBottomClick;\r\n property OnChange;\r\n property OnClick;\r\n property OnDblClick;\r\n property OnDragDrop;\r\n property OnDragOver;\r\n property OnEndDrag;\r\n property OnEnter;\r\n property OnExit;\r\n property OnKeyDown;\r\n property OnKeyPress;\r\n property OnKeyUp;\r\n property OnMouseDown;\r\n property OnMouseMove;\r\n property OnMouseUp;\r\n property OnStartDrag;\r\n property OnTopClick;\r\n property OnContextPopup;\r\n property OnMouseWheelDown;\r\n property OnMouseWheelUp;\r\n property HideSelection;\r\n property BevelEdges;\r\n property BevelInner;\r\n property BevelKind default bkNone;\r\n property BevelOuter;\r\n property ClipboardCommands;\r\n end;\r\n\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvSpin.pas $';\r\n Revision: '$Revision: 13415 $';\r\n Date: '$Date: 2012-09-10 11:51:54 +0200 (lun. 10 sept. 2012) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n Types, JvThemes,\r\n {$IFDEF JVCLThemesEnabled}\r\n UxTheme,\r\n {$IFNDEF COMPILER7_UP}\r\n TmSchema,\r\n {$ENDIF !COMPILER7_UP}\r\n {$ENDIF JVCLThemesEnabled}\r\n JvJCLUtils, JvJVCLUtils, JvConsts, JvResources, JclStrings, JclSysUtils;\r\n\r\n{$R JvSpin.Res}\r\n\r\nconst\r\n sSpinUpBtn = 'JvSpinUP';\r\n sSpinDownBtn = 'JvSpinDOWN';\r\n sSpinUpBtnPole = 'JvSpinUPPOLE';\r\n sSpinDownBtnPole = 'JvSpinDOWNPOLE';\r\n\r\n sTimeFormats: array [{Hour24}Boolean, {ShowSeconds}Boolean] of string = (\r\n ('HH:mm AM/PM', 'HH:mm:ss AM/PM'),\r\n ('HH:mm', 'HH:mm:ss')\r\n );\r\n\r\ntype\r\n TColorArray = array [0..2] of TColor;\r\n\r\n TJvUpDown = class(TCustomUpDown)\r\n private\r\n FChanging: Boolean;\r\n procedure ScrollMessage(var Msg: TWMVScroll);\r\n procedure WMHScroll(var Msg: TWMHScroll); message CN_HSCROLL;\r\n procedure WMVScroll(var Msg: TWMVScroll); message CN_VSCROLL;\r\n public\r\n procedure Resize; override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n published\r\n property OnClick;\r\n end;\r\n\r\n { The face of a spin button is stored because they are a bit to complex to\r\n calculate everytime in a Paint method. There are multiple bitmaps stored\r\n for a single spin button, eg disable/top-down/bottom down etc.\r\n\r\n The face bitmaps of a spin button are stored in a TSpinButtonBitmaps\r\n object. Multiple spin buttons can use the same TSpinButtonBitmaps object.\r\n (That is, identical spin buttons (same height, width, button kind etc.) use the\r\n same TSpinButtonBitmaps objects) The TSpinButtonBitmaps objects are managed\r\n by a single TSpinButtonBitmapsManager object.\r\n }\r\n\r\n TSpinButtonBitmapsManager = class;\r\n\r\n TSpinButtonBitmaps = class(TObject)\r\n private\r\n FManager: TSpinButtonBitmapsManager;\r\n FHeight: Integer;\r\n FWidth: Integer;\r\n FStyle: TJvSpinButtonStyle;\r\n FClientCount: Integer;\r\n\r\n FTopDownBtn: TBitmap;\r\n FBottomDownBtn: TBitmap;\r\n FNotDownBtn: TBitmap;\r\n FDisabledBtn: TBitmap;\r\n FCustomGlyphs: Boolean;\r\n FResetOnDraw: Boolean;\r\n {$IFDEF JVCLThemesEnabled}\r\n FTopHotBtn: TBitmap;\r\n FBottomHotBtn: TBitmap;\r\n FIsThemed: Boolean;\r\n {$ENDIF JVCLThemesEnabled}\r\n protected\r\n procedure DrawAllBitmap;\r\n procedure DrawBitmap(ABitmap: TBitmap; ADownState: TSpinButtonState; const Enabled: Boolean);\r\n procedure PoleDrawArrows(ACanvas: TCanvas; const AState: TSpinButtonState; const Enabled: Boolean;\r\n AUpArrow, ADownArrow: TBitmap);\r\n procedure JvDrawArrows(ACanvas: TCanvas; const AState: TSpinButtonState; const Enabled: Boolean;\r\n AUpArrow, ADownArrow: TBitmap);\r\n {$IFDEF JVCLThemesEnabled}\r\n procedure DrawAllBitmapClassicThemed;\r\n procedure DrawAllBitmapDiagonalThemed;\r\n procedure DrawDiagonalThemedArrows(ACanvas: TCanvas; const AState: TSpinButtonState; const Enabled: Boolean;\r\n AUpArrow, ADownArrow: TBitmap);\r\n {$ENDIF JVCLThemesEnabled}\r\n procedure Reset;\r\n\r\n function CompareWith(const AWidth, AHeight: Integer; const AStyle: TJvSpinButtonStyle;\r\n const ACustomGlyphs: Boolean): Integer;\r\n public\r\n constructor Create(AManager: TSpinButtonBitmapsManager; const AWidth, AHeight: Integer;\r\n const AStyle: TJvSpinButtonStyle; const ACustomGlyphs: Boolean); virtual;\r\n destructor Destroy; override;\r\n\r\n procedure AddClient;\r\n procedure RemoveClient;\r\n\r\n procedure Draw(ACanvas: TCanvas; const ADown: TSpinButtonState;\r\n const AEnabled, AMouseInTopBtn, AMouseInBottomBtn: Boolean);\r\n procedure DrawGlyphs(ACanvas: TCanvas; const AState: TSpinButtonState; const Enabled: Boolean;\r\n AUpArrow, ADownArrow: TBitmap);\r\n\r\n property Width: Integer read FWidth;\r\n property Height: Integer read FHeight;\r\n property Style: TJvSpinButtonStyle read FStyle;\r\n property CustomGlyphs: Boolean read FCustomGlyphs;\r\n end;\r\n\r\n TSpinButtonBitmapsManager = class(TObject)\r\n private\r\n FClientCount: Integer;\r\n FList: TList;\r\n protected\r\n function Find(const Width, Height: Integer; const AButtonStyle: TJvSpinButtonStyle;\r\n const ACustomGlyphs: Boolean; var Index: Integer): Boolean;\r\n procedure Remove(Obj: TObject);\r\n public\r\n constructor Create; virtual;\r\n destructor Destroy; override;\r\n\r\n function WantButtons(const Width, Height: Integer; const AButtonStyle: TJvSpinButtonStyle;\r\n const ACustomGlyphs: Boolean): TSpinButtonBitmaps;\r\n\r\n procedure AddClient;\r\n procedure RemoveClient;\r\n end;\r\n\r\nvar\r\n GSpinButtonBitmapsManager: TSpinButtonBitmapsManager = nil;\r\n\r\n//=== Local procedures =======================================================\r\n\r\nfunction SpinButtonBitmapsManager: TSpinButtonBitmapsManager;\r\nbegin\r\n if GSpinButtonBitmapsManager = nil then\r\n GSpinButtonBitmapsManager := TSpinButtonBitmapsManager.Create;\r\n Result := GSpinButtonBitmapsManager;\r\nend;\r\n\r\nfunction DefBtnWidth: Integer;\r\nbegin\r\n Result := GetSystemMetrics(SM_CXVSCROLL);\r\n if Result > 15 then\r\n Result := 15;\r\nend;\r\n\r\nfunction RemoveThousands(const AValue: string): string;\r\nbegin\r\n if JclFormatSettings.DecimalSeparator <> JclFormatSettings.ThousandSeparator then\r\n Result := DelChars(AValue, JclFormatSettings.ThousandSeparator)\r\n else\r\n Result := AValue;\r\nend;\r\n\r\n\r\n//=== { TJvCustomSpinEdit } ==================================================\r\n\r\nconstructor TJvCustomSpinEdit.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FThousands := False; //new\r\n\r\n FFocused := False;\r\n FCheckOptions := [coCheckOnChange, coCheckOnExit, coCropBeyondLimit];\r\n FLCheckMinValue := True;\r\n FLCheckMaxValue := True;\r\n FCheckMinValue := False;\r\n FCheckMaxValue := False;\r\n ControlStyle := ControlStyle - [csSetCaption];\r\n FIncrement := 1.0;\r\n FDecimal := 2;\r\n FEditorEnabled := True;\r\n FButtonKind := bkDiagonal;\r\n FArrowKeys := True;\r\n FShowButton := True;\r\n RecreateButton;\r\nend;\r\n\r\ndestructor TJvCustomSpinEdit.Destroy;\r\nbegin\r\n Destroying;\r\n FChanging := True;\r\n FreeAndNil(FButton);\r\n FreeAndNil(FBtnWindow);\r\n FreeAndNil(FUpDown);\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvCustomSpinEdit.Change;\r\nvar\r\n OldText: string;\r\n OldSelStart: Integer;\r\nbegin\r\n { (rb) Maybe move to CMTextChanged }\r\n if FChanging or not HandleAllocated then\r\n Exit;\r\n\r\n FChanging := True;\r\n FIsNegative := False;\r\n OldSelStart := SelStart;\r\n try\r\n OldText := inherited Text;\r\n if OldText <> '' then\r\n FIsNegative := Text[1] = '-';\r\n try\r\n if not (csDesigning in ComponentState) and (coCheckOnChange in CheckOptions) then\r\n begin\r\n CheckValueRange(Value, not (coCropBeyondLimit in CheckOptions));\r\n SetValue(CheckValue(Value));\r\n end;\r\n except\r\n SetValue(CheckValue(Value));\r\n end;\r\n finally\r\n FChanging := False;\r\n FIsNegative := False; // reset\r\n end;\r\n\r\n SelStart := OldSelStart;\r\n\r\n if FOldValue <> Value then\r\n begin\r\n // Mantis 3469: This has the advantage to be completely transparent to\r\n // the number of decimals shown in the control\r\n\r\n // (outchy) only shift SelStart by the difference in number of ThousandSeparator BEFORE SelStart\r\n // do not shift if SelStart was clamped (new text length is shorter than OldSelText)\r\n if Thousands and (SelStart = OldSelStart) then\r\n SelStart := SelStart + StrCharCount(Copy(Text, 1, SelStart), JclFormatSettings.ThousandSeparator) -\r\n StrCharCount(Copy(OldText, 1, SelStart), JclFormatSettings.ThousandSeparator);\r\n\r\n inherited Change;\r\n FOldValue := Value;\r\n end;\r\nend;\r\n\r\nfunction TJvCustomSpinEdit.CheckDefaultRange(CheckMax: Boolean): Boolean;\r\nbegin\r\n Result := (FMinValue <> 0) or (FMaxValue <> 0);\r\nend;\r\n\r\nfunction TJvCustomSpinEdit.CheckValue(NewValue: Extended): Extended;\r\nbegin\r\n Result := NewValue;\r\n {\r\n if (FMaxValue <> FMinValue) then\r\n begin\r\n if NewValue < FMinValue then\r\n Result := FMinValue\r\n else\r\n if NewValue > FMaxValue then\r\n Result := FMaxValue;\r\n end;\r\n }\r\n if FCheckMinValue or FCheckMaxValue then\r\n begin\r\n if FCheckMinValue and (NewValue < FMinValue) then\r\n Result := FMinValue;\r\n if FCheckMaxValue and (NewValue > FMaxValue) then\r\n Result := FMaxValue;\r\n end;\r\nend;\r\n\r\nfunction TJvCustomSpinEdit.CheckValueRange(NewValue: Extended; RaiseOnError: Boolean): Extended;\r\nbegin\r\n Result := CheckValue(NewValue);\r\n if (FCheckMinValue or FCheckMaxValue) and\r\n RaiseOnError and (Result <> NewValue) then\r\n raise ERangeError.CreateResFmt(@RsEOutOfRangeFloat, [FMinValue, FMaxValue]);\r\nend;\r\n\r\nprocedure TJvCustomSpinEdit.CMBiDiModeChanged(var Msg: TMessage);\r\nbegin\r\n inherited;\r\n ResizeButton;\r\n SetEditRect;\r\nend;\r\n\r\nprocedure TJvCustomSpinEdit.CMCtl3DChanged(var Msg: TMessage);\r\nbegin\r\n inherited;\r\n ResizeButton;\r\n SetEditRect;\r\nend;\r\n\r\nprocedure TJvCustomSpinEdit.CreateParams(var Params: TCreateParams);\r\nconst\r\n Alignments: array [Boolean, TAlignment] of DWORD =\r\n ((ES_LEFT, ES_RIGHT, ES_CENTER), (ES_RIGHT, ES_LEFT, ES_CENTER));\r\nbegin\r\n inherited CreateParams(Params);\r\n Params.Style := Params.Style or WS_CLIPCHILDREN or Alignments[UseRightToLeftAlignment, FAlignment];\r\nend;\r\n\r\nprocedure TJvCustomSpinEdit.CreateWnd;\r\nbegin\r\n inherited CreateWnd;\r\n SetEditRect;\r\nend;\r\n\r\nprocedure TJvCustomSpinEdit.DataChanged;\r\nvar\r\n EditFormat: string;\r\n WasModified: Boolean;\r\nbegin\r\n if (ValueType = vtFloat) and FFocused and (FDisplayFormat <> '') then\r\n begin\r\n EditFormat := '0';\r\n if FDecimal > 0 then\r\n EditFormat := EditFormat + '.' + MakeStr('0', FDecimal); // See Mantis 3936 about the '0' here.\r\n { Changing EditText sets Modified to false }\r\n WasModified := Modified;\r\n try\r\n Text := FormatFloat(EditFormat, Value);\r\n finally\r\n Modified := WasModified;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJvCustomSpinEdit.DefaultDisplayFormat: string;\r\nbegin\r\n Result := ',0.##';\r\nend;\r\n\r\nprocedure TJvCustomSpinEdit.BoundsChanged;\r\nvar\r\n MinHeight: Integer;\r\nbegin\r\n MinHeight := GetMinHeight;\r\n { text edit bug: if size to less than minheight, then edit ctrl does\r\n not display the text }\r\n if Height < MinHeight then\r\n Height := MinHeight\r\n else\r\n begin\r\n ResizeButton;\r\n SetEditRect;\r\n inherited BoundsChanged;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomSpinEdit.WMCut(var Msg: TMessage);\r\nbegin\r\n if FEditorEnabled and not ReadOnly then\r\n inherited;\r\nend;\r\n\r\nprocedure TJvCustomSpinEdit.WMPaste(var Msg: TMessage);\r\nbegin\r\n if FEditorEnabled and not ReadOnly then\r\n inherited;\r\nend;\r\n\r\nprocedure TJvCustomSpinEdit.DoBottomClick;\r\nbegin\r\n if Assigned(FOnBottomClick) then\r\n FOnBottomClick(Self);\r\nend;\r\n\r\nprocedure TJvCustomSpinEdit.DoEnter;\r\nbegin\r\n SetFocused(True);\r\n if AutoSelect and not (csLButtonDown in ControlState) then\r\n SelectAll;\r\n inherited DoEnter;\r\nend;\r\n\r\nprocedure TJvCustomSpinEdit.DoExit;\r\nbegin\r\n SetFocused(False);\r\n try\r\n if not (csDesigning in ComponentState) and (coCheckOnExit in CheckOptions) then\r\n begin\r\n CheckValueRange(Value, not (coCropBeyondLimit in CheckOptions));\r\n SetValue(CheckValue(Value));\r\n end;\r\n except\r\n SetFocused(True);\r\n SelectAll;\r\n if CanFocus then\r\n SetFocus;\r\n raise;\r\n end;\r\n inherited DoExit;\r\nend;\r\n\r\nprocedure TJvCustomSpinEdit.FocusKilled(NextWnd: THandle);\r\nbegin\r\n if ([coCropBeyondLimit, coCheckOnExit] <= CheckOptions) and not (csDesigning in ComponentState) then\r\n SetValue(CheckValue(Value));\r\n inherited FocusKilled(NextWnd);\r\nend;\r\n\r\nfunction TJvCustomSpinEdit.DoMouseWheel(Shift: TShiftState; WheelDelta: Integer; MousePos: TPoint): Boolean;\r\nbegin\r\n if WheelDelta > 0 then\r\n UpClick(nil)\r\n else\r\n DownClick(nil);\r\n Result := True;\r\nend;\r\n\r\nprocedure TJvCustomSpinEdit.DoTopClick;\r\nbegin\r\n if Assigned(FOnTopClick) then\r\n FOnTopClick(Self);\r\nend;\r\n\r\nprocedure TJvCustomSpinEdit.DownClick(Sender: TObject);\r\nvar\r\n OldText: string;\r\nbegin\r\n if ReadOnly then\r\n DoBeepOnError\r\n else\r\n begin\r\n FChanging := True;\r\n try\r\n OldText := inherited Text;\r\n Value := Value - FIncrement;\r\n finally\r\n FChanging := False;\r\n end;\r\n if AnsiCompareText(inherited Text, OldText) <> 0 then\r\n begin\r\n Modified := True;\r\n Change;\r\n end;\r\n DoBottomClick;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomSpinEdit.EnabledChanged;\r\nbegin\r\n inherited EnabledChanged;\r\n if FUpDown <> nil then\r\n begin\r\n FUpDown.Enabled := Enabled;\r\n ResizeButton;\r\n end;\r\n if FButton <> nil then\r\n FButton.Enabled := Enabled;\r\nend;\r\n\r\nprocedure TJvCustomSpinEdit.FontChanged;\r\nbegin\r\n inherited FontChanged;\r\n ResizeButton;\r\n SetEditRect;\r\nend;\r\n\r\n{function TJvCustomSpinEdit.TryGetValue(var Value: Extended): Boolean;\r\nvar\r\n S: string;\r\nbegin\r\n try\r\n S := StringReplace(Text, ThousandSeparator, '', [rfReplaceAll]);\r\n if ValueType = vtFloat then\r\n Value := StrToFloat(S)\r\n else\r\n if ValueType = vtHex then\r\n Value := StrToInt('$' + Text)\r\n else\r\n Value := StrToInt(S);\r\n Result := True;\r\n except\r\n if ValueType = vtFloat then\r\n Value := FMinValue\r\n else\r\n Value := Trunc(FMinValue);\r\n Result := False;\r\n end;\r\nend;}\r\n\r\nfunction TJvCustomSpinEdit.GetAsInteger: Longint;\r\nbegin\r\n Result := Trunc(GetValue);\r\nend;\r\n\r\nfunction TJvCustomSpinEdit.GetButtonKind: TSpinButtonKind;\r\nbegin\r\n Result := FButtonKind;\r\nend;\r\n\r\nfunction TJvCustomSpinEdit.GetButtonWidth: Integer;\r\nbegin\r\n if ShowButton then\r\n begin\r\n if FUpDown <> nil then\r\n Result := FUpDown.Width\r\n else\r\n if FButton <> nil then\r\n Result := FButton.Width\r\n else\r\n Result := DefBtnWidth;\r\n end\r\n else\r\n Result := 0;\r\nend;\r\n\r\nfunction TJvCustomSpinEdit.GetMinHeight: Integer;\r\nvar\r\n I, H: Integer;\r\nbegin\r\n GetTextHeight(I, H);\r\n if I > H then\r\n I := H;\r\n Result := H + (GetSystemMetrics(SM_CYBORDER) * 4) + 1;\r\nend;\r\n\r\nprocedure TJvCustomSpinEdit.GetTextHeight(var SysHeight, Height: Integer);\r\nvar\r\n DC: HDC;\r\n SaveFont: HFONT;\r\n SysMetrics, Metrics: TTextMetric;\r\nbegin\r\n DC := GetDC(HWND_DESKTOP);\r\n GetTextMetrics(DC, SysMetrics);\r\n SaveFont := SelectObject(DC, Font.Handle);\r\n GetTextMetrics(DC, Metrics);\r\n SelectObject(DC, SaveFont);\r\n ReleaseDC(HWND_DESKTOP, DC);\r\n SysHeight := SysMetrics.tmHeight;\r\n Height := Metrics.tmHeight;\r\nend;\r\n\r\nfunction TJvCustomSpinEdit.IsFormatStored: Boolean;\r\nbegin\r\n Result := DisplayFormat <> DefaultDisplayFormat;\r\nend;\r\n\r\nfunction TJvCustomSpinEdit.IsIncrementStored: Boolean;\r\nbegin\r\n Result := FIncrement <> 1.0;\r\nend;\r\n\r\nfunction TJvCustomSpinEdit.IsMaxStored: Boolean;\r\nbegin\r\n Result := MaxValue <> 0.0;\r\nend;\r\n\r\nfunction TJvCustomSpinEdit.IsMinStored: Boolean;\r\nbegin\r\n Result := MinValue <> 0.0;\r\nend;\r\n\r\nfunction TJvCustomSpinEdit.IsValidChar(Key: Char): Boolean;\r\nvar\r\n ValidChars: TSysCharSet;\r\nbegin\r\n ValidChars := DigitChars + ['+', '-'];\r\n if ValueType = vtFloat then\r\n begin\r\n if Pos(JclFormatSettings.DecimalSeparator, Text) = 0 then\r\n begin\r\n if not Thousands or (JclFormatSettings.ThousandSeparator <> '.') then\r\n ValidChars := ValidChars + [JclFormatSettings.DecimalSeparator, '.']\r\n else\r\n ValidChars := ValidChars + [JclFormatSettings.DecimalSeparator];\r\n end;\r\n if Pos('E', AnsiUpperCase(Text)) = 0 then\r\n ValidChars := ValidChars + ['e', 'E'];\r\n end\r\n else\r\n if ValueType = vtHex then\r\n begin\r\n ValidChars := ValidChars + ['A'..'F', 'a'..'f'];\r\n end;\r\n Result := CharInSet(Key, ValidChars) or (Key < #32);\r\n if not FEditorEnabled and Result and ((Key >= #32) or\r\n (Key = BackSpace) or (Key = Del)) then\r\n Result := False;\r\nend;\r\n\r\nfunction TJvCustomSpinEdit.IsValueStored: Boolean;\r\nbegin\r\n Result := GetValue <> 0.0;\r\nend;\r\n\r\nprocedure TJvCustomSpinEdit.KeyDown(var Key: Word; Shift: TShiftState);\r\nbegin\r\n inherited KeyDown(Key, Shift);\r\n if ArrowKeys and ((Key = VK_UP) or (Key = VK_DOWN)) then\r\n begin\r\n if Key = VK_UP then\r\n UpClick(Self)\r\n else\r\n if Key = VK_DOWN then\r\n DownClick(Self);\r\n Key := 0;\r\n end;\r\n // do not delete the decimal separator while typing\r\n // all decimal digits were moved to the integer part and new decimals were added at the end\r\n if (Key = VK_DELETE) and (SelStart < Length(Text)) and (Text[SelStart + 1] = JclFormatSettings.DecimalSeparator) then\r\n Key := VK_RIGHT;\r\n if (Key = VK_BACK) and (SelStart > 0) and (Text[SelStart] = JclFormatSettings.DecimalSeparator) then\r\n Key := VK_LEFT;\r\nend;\r\n\r\nprocedure TJvCustomSpinEdit.KeyPress(var Key: Char);\r\nvar\r\n I: Integer;\r\nbegin\r\n // (outchy) moved at the beginning, hitting '.' now behaves like hitting the decimal separator\r\n if (Key = '.') and (not Thousands or (JclFormatSettings.ThousandSeparator <> '.')) then\r\n Key := JclFormatSettings.DecimalSeparator;\r\n\r\n if (Key = JclFormatSettings.DecimalSeparator) and (ValueType = vtFloat) then\r\n begin\r\n { If the key is the decimal separator move the caret behind it. }\r\n I := Pos(JclFormatSettings.DecimalSeparator, Text);\r\n if I <> 0 then\r\n begin\r\n Key := #0;\r\n SelLength := 0;\r\n SelStart := I;\r\n Exit;\r\n end;\r\n end;\r\n\r\n if not IsValidChar(Key) then\r\n begin\r\n Key := #0;\r\n DoBeepOnError;\r\n end;\r\n\r\n if Key <> #0 then\r\n begin\r\n inherited KeyPress(Key);\r\n if (Key = Cr) or (Key = Esc) then\r\n begin\r\n { must catch and remove this, since it is actually multi-line }\r\n GetParentForm(Self).Perform(CM_DIALOGKEY, Byte(Key), 0);\r\n if Key = Cr then\r\n Key := #0;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomSpinEdit.Loaded;\r\nbegin\r\n inherited Loaded;\r\n FLCheckMinValue := True;\r\n FLCheckMaxValue := True;\r\n FOldValue := Value;\r\nend;\r\n\r\nprocedure TJvCustomSpinEdit.RecreateButton;\r\nbegin\r\n if csDestroying in ComponentState then\r\n Exit;\r\n FButton.Free;\r\n FButton := nil;\r\n FBtnWindow.Free;\r\n FBtnWindow := nil;\r\n FUpDown.Free;\r\n FUpDown := nil;\r\n if ShowButton then\r\n if GetButtonKind = bkStandard then\r\n begin\r\n FUpDown := TJvUpDown.Create(Self);\r\n with TJvUpDown(FUpDown) do\r\n begin\r\n Visible := True;\r\n SetBounds(0, 1, DefBtnWidth, Self.Height);\r\n if BiDiMode = bdRightToLeft then\r\n Align := alLeft\r\n else\r\n Align := alRight;\r\n Parent := Self;\r\n OnClick := UpDownClick;\r\n end;\r\n end\r\n else\r\n begin\r\n FBtnWindow := TWinControl.Create(Self);\r\n FBtnWindow.Visible := True;\r\n FBtnWindow.Parent := Self;\r\n if FButtonKind <> bkClassic then\r\n FBtnWindow.SetBounds(0, 0, DefBtnWidth, Height)\r\n else\r\n FBtnWindow.SetBounds(0, 0, Height, Height);\r\n FButton := TJvSpinButton.Create(Self);\r\n FButton.Visible := True;\r\n if FButtonKind = bkClassic then\r\n FButton.FButtonStyle := sbsClassic;\r\n FButton.Parent := FBtnWindow;\r\n FButton.FocusControl := Self;\r\n FButton.OnTopClick := UpClick;\r\n FButton.OnBottomClick := DownClick;\r\n FButton.SetBounds(1, 1, FBtnWindow.Width - 1, FBtnWindow.Height - 1);\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomSpinEdit.ResizeButton;\r\nvar\r\n R: TRect;\r\nbegin\r\n if FUpDown <> nil then\r\n begin\r\n FUpDown.Width := DefBtnWidth;\r\n if BiDiMode = bdRightToLeft then\r\n FUpDown.Align := alLeft\r\n else\r\n FUpDown.Align := alRight;\r\n end\r\n else\r\n if FButton <> nil then\r\n begin { bkDiagonal }\r\n if Ctl3D and (BorderStyle = bsSingle) then\r\n if FButtonKind = bkClassic then\r\n R := Bounds(Width - DefBtnWidth - 4, -1, DefBtnWidth, Height - 3)\r\n else\r\n R := Bounds(Width - Height - 1, -1, Height - 3, Height - 3)\r\n else\r\n if FButtonKind = bkClassic then\r\n R := Bounds(Width - DefBtnWidth, 0, DefBtnWidth, Height)\r\n else\r\n R := Bounds(Width - Height, 0, Height, Height);\r\n if BiDiMode = bdRightToLeft then\r\n begin\r\n if Ctl3D and (BorderStyle = bsSingle) then\r\n begin\r\n R.Left := -1;\r\n R.Right := Height - 4;\r\n end\r\n else\r\n begin\r\n R.Left := 0;\r\n R.Right := Height;\r\n end;\r\n end;\r\n FBtnWindow.SetBounds(R.Left, R.Top, R.Right - R.Left, R.Bottom - R.Top);\r\n FButton.SetBounds(1, 1, FBtnWindow.Width - 1, FBtnWindow.Height - 1);\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomSpinEdit.SetAlignment(Value: TAlignment);\r\nbegin\r\n if FAlignment <> Value then\r\n begin\r\n FAlignment := Value;\r\n RecreateWnd;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomSpinEdit.SetArrowKeys(Value: Boolean);\r\nbegin\r\n FArrowKeys := Value;\r\n ResizeButton;\r\nend;\r\n\r\nprocedure TJvCustomSpinEdit.SetAsInteger(NewValue: Longint);\r\nbegin\r\n SetValue(NewValue);\r\nend;\r\n\r\nprocedure TJvCustomSpinEdit.SetButtonKind(Value: TSpinButtonKind);\r\nvar\r\n OldKind: TSpinButtonKind;\r\nbegin\r\n OldKind := FButtonKind;\r\n FButtonKind := Value;\r\n if OldKind <> GetButtonKind then\r\n begin\r\n RecreateButton;\r\n ResizeButton;\r\n SetEditRect;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomSpinEdit.SetCheckMaxValue(NewValue: Boolean);\r\nbegin\r\n if FMaxValue <> 0 then\r\n NewValue := True;\r\n FCheckMaxValue := NewValue;\r\n if csLoading in ComponentState then\r\n FLCheckMaxValue := False;\r\n SetValue(Value);\r\nend;\r\n\r\nprocedure TJvCustomSpinEdit.SetCheckMinValue(NewValue: Boolean);\r\nbegin\r\n if FMinValue <> 0 then\r\n NewValue := True;\r\n FCheckMinValue := NewValue;\r\n if csLoading in ComponentState then\r\n FLCheckMinValue := False;\r\n SetValue(Value);\r\nend;\r\n\r\nprocedure TJvCustomSpinEdit.SetShowButton(Value: Boolean);\r\nbegin\r\n if FShowButton <> Value then\r\n begin\r\n FShowButton := Value;\r\n RecreateButton;\r\n ResizeButton;\r\n SetEditRect;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomSpinEdit.SetDecimal(NewValue: Byte);\r\nbegin\r\n if FDecimal <> NewValue then\r\n begin\r\n FDecimal := NewValue;\r\n Value := GetValue;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomSpinEdit.SetDisplayFormat(const Value: string);\r\nbegin\r\n if DisplayFormat <> Value then\r\n begin\r\n FDisplayFormat := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomSpinEdit.SetEditRect;\r\nvar\r\n Loc: TRect;\r\nbegin\r\n if BiDiMode = bdRightToLeft then\r\n begin\r\n SetRect(Loc, GetButtonWidth + 1, 0, ClientWidth - 1, ClientHeight + 1);\r\n SendMessage(Handle, EM_SETMARGINS, EC_LEFTMARGIN, MakeLong(GetButtonWidth, 0));\r\n end\r\n else\r\n begin\r\n SetRect(Loc, 0, 0, ClientWidth - GetButtonWidth - 2, ClientHeight + 1);\r\n SendMessage(Handle, EM_SETMARGINS, EC_RIGHTMARGIN, MakeLong(0, GetButtonWidth));\r\n end;\r\n SendMessage(Handle, EM_SETRECTNP, 0, LPARAM(@Loc));\r\nend;\r\n\r\nprocedure TJvCustomSpinEdit.SetFocused(Value: Boolean);\r\nbegin\r\n if Value <> FFocused then\r\n begin\r\n FFocused := Value;\r\n Invalidate;\r\n DataChanged;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomSpinEdit.SetMaxValue(NewValue: Extended);\r\nvar\r\n Z: Boolean;\r\n B: Boolean;\r\nbegin\r\n if NewValue <> FMaxValue then\r\n begin\r\n B := not StoreCheckMaxValue;\r\n Z := (FMaxValue = 0) <> (NewValue = 0);\r\n FMaxValue := NewValue;\r\n if Z and FLCheckMaxValue then\r\n begin\r\n SetCheckMaxValue(CheckDefaultRange(True));\r\n if B and FLCheckMinValue then\r\n SetCheckMinValue(CheckDefaultRange(False));\r\n end;\r\n SetValue(Value);\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomSpinEdit.SetMinValue(NewValue: Extended);\r\nvar\r\n Z: Boolean;\r\n B: Boolean;\r\nbegin\r\n if NewValue <> FMinValue then\r\n begin\r\n B := not StoreCheckMinValue;\r\n Z := (FMinValue = 0) <> (NewValue = 0);\r\n FMinValue := NewValue;\r\n if Z and FLCheckMinValue then\r\n begin\r\n SetCheckMinValue(CheckDefaultRange(False));\r\n if B and FLCheckMaxValue then\r\n SetCheckMaxValue(CheckDefaultRange(True));\r\n end;\r\n SetValue(Value);\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomSpinEdit.SetThousands(Value: Boolean);\r\nbegin\r\n if ValueType <> vtHex then\r\n FThousands := Value;\r\nend;\r\n\r\nprocedure TJvCustomSpinEdit.SetValueType(NewType: TValueType);\r\nbegin\r\n if FValueType <> NewType then\r\n begin\r\n FValueType := NewType;\r\n Value := GetValue;\r\n if FValueType in [{$IFDEF BCB} vtInt {$ELSE} vtInteger {$ENDIF}, vtHex] then\r\n begin\r\n FIncrement := Round(FIncrement);\r\n if FIncrement = 0 then\r\n FIncrement := 1;\r\n end;\r\n if FValueType = vtHex then\r\n Thousands := False;\r\n end;\r\nend;\r\n\r\nfunction TJvCustomSpinEdit.StoreCheckMaxValue: Boolean;\r\nbegin\r\n Result := (FMaxValue = 0) and (FCheckMaxValue = (FMinValue = 0));\r\nend;\r\n\r\nfunction TJvCustomSpinEdit.StoreCheckMinValue: Boolean;\r\nbegin\r\n Result := (FMinValue = 0) and (FCheckMinValue = (FMaxValue = 0));\r\nend;\r\n\r\nprocedure TJvCustomSpinEdit.UpClick(Sender: TObject);\r\nvar\r\n OldText: string;\r\nbegin\r\n if ReadOnly then\r\n DoBeepOnError\r\n else\r\n begin\r\n FChanging := True;\r\n try\r\n OldText := inherited Text;\r\n Value := Value + FIncrement;\r\n finally\r\n FChanging := False;\r\n end;\r\n if AnsiCompareText(inherited Text, OldText) <> 0 then\r\n begin\r\n Modified := True;\r\n Change;\r\n end;\r\n DoTopClick;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomSpinEdit.UpDownClick(Sender: TObject; Button: TUDBtnType);\r\nbegin\r\n if TabStop and CanFocus then\r\n SetFocus;\r\n case Button of\r\n btNext:\r\n UpClick(Sender);\r\n btPrev:\r\n DownClick(Sender);\r\n end;\r\nend;\r\n\r\n//=== { TJvSpinButton } ======================================================\r\n\r\nconstructor TJvSpinButton.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FButtonStyle := sbsDefault;\r\n FUpBitmap := TBitmap.Create;\r\n FDownBitmap := TBitmap.Create;\r\n FUpBitmap.OnChange := GlyphChanged;\r\n FDownBitmap.OnChange := GlyphChanged;\r\n Height := 20;\r\n Width := 20;\r\n FLastDown := sbNotDown;\r\n FButtonBitmaps := nil;\r\n FInitRepeatPause := DefaultInitRepeatPause;\r\n FRepeatPause := DefaultRepeatPause;\r\n\r\n SpinButtonBitmapsManager.AddClient;\r\nend;\r\n\r\ndestructor TJvSpinButton.Destroy;\r\nbegin\r\n RemoveButtonBitmaps;\r\n SpinButtonBitmapsManager.RemoveClient;\r\n\r\n FUpBitmap.Free;\r\n FDownBitmap.Free;\r\n FRepeatTimer.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvSpinButton.BottomClick;\r\nbegin\r\n if Assigned(FOnBottomClick) then\r\n begin\r\n FOnBottomClick(Self);\r\n if not (csLButtonDown in ControlState) then\r\n FDown := sbNotDown;\r\n end;\r\nend;\r\n\r\nprocedure TJvSpinButton.CheckButtonBitmaps;\r\nbegin\r\n if Assigned(FButtonBitmaps) and\r\n ((TSpinButtonBitmaps(FButtonBitmaps).Height <> Height) or\r\n (TSpinButtonBitmaps(FButtonBitmaps).Width <> Width)) then\r\n RemoveButtonBitmaps;\r\n\r\n if FButtonBitmaps = nil then\r\n begin\r\n FButtonBitmaps := SpinButtonBitmapsManager.WantButtons(Width, Height, ButtonStyle,\r\n not FUpBitmap.Empty or not FDownBitmap.Empty);\r\n TSpinButtonBitmaps(FButtonBitmaps).AddClient;\r\n end;\r\nend;\r\n\r\nprocedure TJvSpinButton.CMSysColorChange(var Msg: TMessage);\r\nbegin\r\n // The buttons we draw are buffered, thus we need to repaint them to theme changes etc.\r\n if FButtonBitmaps <> nil then\r\n TSpinButtonBitmaps(FButtonBitmaps).Reset;\r\nend;\r\n\r\nfunction TJvSpinButton.GetDownGlyph: TBitmap;\r\nbegin\r\n Result := FDownBitmap;\r\nend;\r\n\r\nfunction TJvSpinButton.GetUpGlyph: TBitmap;\r\nbegin\r\n Result := FUpBitmap;\r\nend;\r\n\r\nprocedure TJvSpinButton.GlyphChanged(Sender: TObject);\r\nbegin\r\n if Sender is TBitmap then\r\n TBitmap(Sender).Transparent := True;\r\n RemoveButtonBitmaps;\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvSpinButton.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);\r\nbegin\r\n inherited MouseDown(Button, Shift, X, Y);\r\n if (Button = mbLeft) and Enabled then\r\n begin\r\n if (FFocusControl <> nil) and FFocusControl.TabStop and\r\n FFocusControl.CanFocus and (GetFocus <> FFocusControl.Handle) then\r\n FFocusControl.SetFocus;\r\n if FDown = sbNotDown then\r\n begin\r\n FLastDown := FDown;\r\n if ((FButtonStyle = sbsDefault) and (Y > (-(Height / Width) * X + Height))) or\r\n ((FButtonStyle = sbsClassic) and (Y > (Height div 2))) then\r\n begin\r\n FDown := sbBottomDown;\r\n BottomClick;\r\n end\r\n else\r\n begin\r\n FDown := sbTopDown;\r\n TopClick;\r\n end;\r\n if FLastDown <> FDown then\r\n begin\r\n FLastDown := FDown;\r\n Repaint;\r\n end;\r\n if FRepeatTimer = nil then\r\n FRepeatTimer := TTimer.Create(Self);\r\n FRepeatTimer.OnTimer := TimerExpired;\r\n FRepeatTimer.Interval := InitRepeatPause;\r\n FRepeatTimer.Enabled := True;\r\n end;\r\n FDragging := True;\r\n end;\r\nend;\r\n\r\n{$IFDEF JVCLThemesEnabled}\r\nprocedure TJvSpinButton.MouseEnter(Control: TControl);\r\nbegin\r\n if csDesigning in ComponentState then\r\n Exit;\r\n { (rb) only themed spin buttons have hot states, so it's not necessary\r\n to calc FMouseInBottomBtn and FMouseInTopBtn for non-themed apps }\r\n if not FMouseInTopBtn and not FMouseInBottomBtn then\r\n begin\r\n if MouseInBottomBtn(ScreenToClient(Mouse.CursorPos)) then\r\n FMouseInBottomBtn := True\r\n else\r\n FMouseInTopBtn := True;\r\n if ThemeServices.{$IFDEF RTL230_UP}Enabled{$ELSE}ThemesEnabled{$ENDIF RTL230_UP} then\r\n Repaint;\r\n inherited MouseEnter(Control);\r\n end;\r\nend;\r\n{$ENDIF JVCLThemesEnabled}\r\n\r\nfunction TJvSpinButton.MouseInBottomBtn(const P: TPoint): Boolean;\r\nbegin\r\n Result :=\r\n ((FButtonStyle = sbsDefault)) and (P.Y > (-(Width / Height) * P.X + Height)) or\r\n ((FButtonStyle = sbsClassic) and (P.Y > (Height div 2)));\r\nend;\r\n\r\n{$IFDEF JVCLThemesEnabled}\r\nprocedure TJvSpinButton.MouseLeave(Control: TControl);\r\nbegin\r\n if csDesigning in ComponentState then\r\n Exit;\r\n if FMouseInTopBtn or FMouseInBottomBtn then\r\n begin\r\n FMouseInTopBtn := False;\r\n FMouseInBottomBtn := False;\r\n if ThemeServices.{$IFDEF RTL230_UP}Enabled{$ELSE}ThemesEnabled{$ENDIF RTL230_UP} then\r\n Repaint;\r\n inherited MouseLeave(Control);\r\n end;\r\nend;\r\n{$ENDIF JVCLThemesEnabled}\r\n\r\nprocedure TJvSpinButton.MouseMove(Shift: TShiftState; X, Y: Integer);\r\nvar\r\n NewState: TSpinButtonState;\r\nbegin\r\n inherited MouseMove(Shift, X, Y);\r\n if FDragging then\r\n begin\r\n if (X >= 0) and (X <= Width) and (Y >= 0) and (Y <= Height) then\r\n begin\r\n NewState := FDown;\r\n if MouseInBottomBtn(Point(X, Y)) then\r\n begin\r\n if FDown <> sbBottomDown then\r\n begin\r\n if FLastDown = sbBottomDown then\r\n FDown := sbBottomDown\r\n else\r\n FDown := sbNotDown;\r\n if NewState <> FDown then\r\n Repaint;\r\n end;\r\n end\r\n else\r\n begin\r\n if FDown <> sbTopDown then\r\n begin\r\n if FLastDown = sbTopDown then\r\n FDown := sbTopDown\r\n else\r\n FDown := sbNotDown;\r\n if NewState <> FDown then\r\n Repaint;\r\n end;\r\n end;\r\n end\r\n else\r\n if FDown <> sbNotDown then\r\n begin\r\n FDown := sbNotDown;\r\n Repaint;\r\n end;\r\n end\r\n {$IFDEF JVCLThemesEnabled}\r\n else\r\n if (FMouseInTopBtn or FMouseInBottomBtn) and ThemeServices.{$IFDEF RTL230_UP}Enabled{$ELSE}ThemesEnabled{$ENDIF RTL230_UP} then\r\n begin\r\n if MouseInBottomBtn(Point(X, Y)) then\r\n begin\r\n if not FMouseInBottomBtn then\r\n begin\r\n FMouseInTopBtn := False;\r\n FMouseInBottomBtn := True;\r\n Repaint;\r\n end;\r\n end\r\n else\r\n begin\r\n if not FMouseInTopBtn then\r\n begin\r\n FMouseInTopBtn := True;\r\n FMouseInBottomBtn := False;\r\n Repaint;\r\n end;\r\n end;\r\n end;\r\n {$ENDIF JVCLThemesEnabled}\r\nend;\r\n\r\nprocedure TJvSpinButton.MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);\r\nbegin\r\n inherited MouseUp(Button, Shift, X, Y);\r\n if FDragging then\r\n begin\r\n FDragging := False;\r\n if (X >= 0) and (X <= Width) and (Y >= 0) and (Y <= Height) then\r\n begin\r\n FDown := sbNotDown;\r\n FLastDown := sbNotDown;\r\n Repaint;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvSpinButton.Notification(AComponent: TComponent; Operation: TOperation);\r\nbegin\r\n inherited Notification(AComponent, Operation);\r\n if (Operation = opRemove) and (AComponent = FFocusControl) then\r\n FFocusControl := nil;\r\nend;\r\n\r\nprocedure TJvSpinButton.Paint;\r\nbegin\r\n CheckButtonBitmaps;\r\n\r\n if not Enabled and not (csDesigning in ComponentState) then\r\n FDragging := False;\r\n\r\n {$IFDEF JVCLThemesEnabled}\r\n TSpinButtonBitmaps(FButtonBitmaps).Draw(Canvas, FDown, Enabled, FMouseInTopBtn, FMouseInBottomBtn);\r\n {$ELSE}\r\n TSpinButtonBitmaps(FButtonBitmaps).Draw(Canvas, FDown, Enabled, False, False);\r\n {$ENDIF JVCLThemesEnabled}\r\n if not FUpBitmap.Empty or not FDownBitmap.Empty then\r\n TSpinButtonBitmaps(FButtonBitmaps).DrawGlyphs(Canvas, FDown, Enabled, FUpBitmap, FDownBitmap);\r\nend;\r\n\r\nprocedure TJvSpinButton.RemoveButtonBitmaps;\r\nbegin\r\n if Assigned(FButtonBitmaps) then\r\n begin\r\n TSpinButtonBitmaps(FButtonBitmaps).RemoveClient;\r\n FButtonBitmaps := nil;\r\n end;\r\nend;\r\n\r\nprocedure TJvSpinButton.SetButtonStyle(Value: TJvSpinButtonStyle);\r\nbegin\r\n if Value <> FButtonStyle then\r\n begin\r\n FButtonStyle := Value;\r\n GlyphChanged(Self);\r\n end;\r\nend;\r\n\r\nprocedure TJvSpinButton.SetDown(Value: TSpinButtonState);\r\nvar\r\n OldState: TSpinButtonState;\r\nbegin\r\n OldState := FDown;\r\n FDown := Value;\r\n if OldState <> FDown then\r\n Repaint;\r\nend;\r\n\r\nprocedure TJvSpinButton.SetDownGlyph(Value: TBitmap);\r\nbegin\r\n if Value <> nil then\r\n FDownBitmap.Assign(Value)\r\n else\r\n FDownBitmap.Handle := NullHandle;\r\nend;\r\n\r\nprocedure TJvSpinButton.SetFocusControl(Value: TWinControl);\r\nbegin\r\n ReplaceComponentReference(Self, Value, TComponent(FFocusControl));\r\nend;\r\n\r\nprocedure TJvSpinButton.SetUpGlyph(Value: TBitmap);\r\nbegin\r\n if Value <> nil then\r\n FUpBitmap.Assign(Value)\r\n else\r\n FUpBitmap.Handle := NullHandle;\r\nend;\r\n\r\nprocedure TJvSpinButton.TimerExpired(Sender: TObject);\r\nbegin\r\n FRepeatTimer.Interval := RepeatPause;\r\n if (FDown <> sbNotDown) and MouseCapture then\r\n begin\r\n try\r\n if FDown = sbBottomDown then\r\n BottomClick\r\n else\r\n TopClick;\r\n except\r\n FRepeatTimer.Enabled := False;\r\n raise;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvSpinButton.TopClick;\r\nbegin\r\n if Assigned(FOnTopClick) then\r\n begin\r\n FOnTopClick(Self);\r\n if not (csLButtonDown in ControlState) then\r\n FDown := sbNotDown;\r\n end;\r\nend;\r\n\r\n//=== { TJvSpinEdit } ========================================================\r\n\r\n// (rom) quite unusual not to have it in the Custom base class\r\n\r\nconstructor TJvSpinEdit.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n Text := '0';\r\nend;\r\n\r\nfunction TJvSpinEdit.GetValue: Extended;\r\nbegin\r\n try\r\n case ValueType of\r\n vtFloat:\r\n begin\r\n if FDisplayFormat <> '' then\r\n try\r\n Result := StrToFloat(TextToValText(Text));\r\n except\r\n Result := FMinValue;\r\n end\r\n else\r\n if not TextToFloat(PChar(RemoveThousands(Text)), Result, fvExtended) then\r\n Result := FMinValue;\r\n end;\r\n vtHex:\r\n Result := StrToIntDef('$' + Text, Round(FMinValue));\r\n else {vtInteger}\r\n Result := StrToIntDef(RemoveThousands(Text), Round(FMinValue));\r\n end;\r\n except\r\n if ValueType = vtFloat then\r\n Result := FMinValue\r\n else\r\n Result := Round(FMinValue);\r\n end;\r\nend;\r\n\r\nprocedure TJvSpinEdit.SetValue(NewValue: Extended);\r\nvar\r\n FloatFormat: TFloatFormat;\r\n WasModified: Boolean;\r\nbegin\r\n if Thousands then\r\n FloatFormat := ffNumber\r\n else\r\n FloatFormat := ffFixed;\r\n\r\n { Changing EditText sets Modified to false }\r\n WasModified := Modified;\r\n try\r\n case ValueType of\r\n vtFloat:\r\n if FDisplayFormat <> '' then\r\n Text := FormatFloat(FDisplayFormat, CheckValue(NewValue))\r\n else\r\n Text := FloatToStrF(CheckValue(NewValue), FloatFormat, 15, FDecimal);\r\n vtHex:\r\n if ValueType = vtHex then\r\n Text := IntToHex(Round(CheckValue(NewValue)), 1);\r\n else {vtInteger}\r\n //Text := IntToStr(Round(CheckValue(NewValue)));\r\n Text := FloatToStrF(CheckValue(NewValue), FloatFormat, 15, 0);\r\n end;\r\n if FIsNegative and (Text <> '') and (Text[1] <> '-') then\r\n Text := '-' + Text;\r\n DataChanged;\r\n finally\r\n Modified := WasModified;\r\n end;\r\nend;\r\n\r\n//=== { TJvUpDown } ==========================================================\r\n\r\nconstructor TJvUpDown.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n Orientation := udVertical;\r\n Min := -1;\r\n Max := 1;\r\n Position := 0;\r\nend;\r\n\r\ndestructor TJvUpDown.Destroy;\r\nbegin\r\n OnClick := nil;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvUpDown.Resize;\r\nbegin\r\n if Width <> DefBtnWidth then\r\n Width := DefBtnWidth\r\n else\r\n inherited Resize;\r\nend;\r\n\r\nprocedure TJvUpDown.ScrollMessage(var Msg: TWMVScroll);\r\nbegin\r\n if Msg.ScrollCode = SB_THUMBPOSITION then\r\n begin\r\n if not FChanging then\r\n begin\r\n FChanging := True;\r\n try\r\n if Msg.Pos > 0 then\r\n Click(btNext)\r\n else\r\n if Msg.Pos < 0 then\r\n Click(btPrev);\r\n if HandleAllocated then\r\n SendMessage(Handle, UDM_SETPOS, 0, 0);\r\n finally\r\n FChanging := False;\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvUpDown.WMHScroll(var Msg: TWMHScroll);\r\nbegin\r\n ScrollMessage(TWMVScroll(Msg));\r\nend;\r\n\r\nprocedure TJvUpDown.WMVScroll(var Msg: TWMVScroll);\r\nbegin\r\n ScrollMessage(Msg);\r\nend;\r\n\r\n//=== { TSpinButtonBitmaps } =================================================\r\n\r\nconstructor TSpinButtonBitmaps.Create(AManager: TSpinButtonBitmapsManager;\r\n const AWidth, AHeight: Integer; const AStyle: TJvSpinButtonStyle; const ACustomGlyphs: Boolean);\r\nbegin\r\n inherited Create;\r\n FManager := AManager;\r\n FWidth := AWidth;\r\n FHeight := AHeight;\r\n FStyle := AStyle;\r\n FCustomGlyphs := ACustomGlyphs;\r\n\r\n FTopDownBtn := TBitmap.Create;\r\n FBottomDownBtn := TBitmap.Create;\r\n FNotDownBtn := TBitmap.Create;\r\n FDisabledBtn := TBitmap.Create;\r\n {$IFDEF JVCLThemesEnabled}\r\n FTopHotBtn := TBitmap.Create;\r\n FBottomHotBtn := TBitmap.Create;\r\n {$ENDIF JVCLThemesEnabled}\r\n\r\n DrawAllBitmap;\r\nend;\r\n\r\ndestructor TSpinButtonBitmaps.Destroy;\r\nbegin\r\n FManager.Remove(Self);\r\n\r\n FTopDownBtn.Free;\r\n FBottomDownBtn.Free;\r\n FNotDownBtn.Free;\r\n FDisabledBtn.Free;\r\n {$IFDEF JVCLThemesEnabled}\r\n FTopHotBtn.Free;\r\n FBottomHotBtn.Free;\r\n {$ENDIF JVCLThemesEnabled}\r\n\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TSpinButtonBitmaps.AddClient;\r\nbegin\r\n Inc(FClientCount);\r\nend;\r\n\r\nfunction TSpinButtonBitmaps.CompareWith(const AWidth, AHeight: Integer;\r\n const AStyle: TJvSpinButtonStyle; const ACustomGlyphs: Boolean): Integer;\r\nbegin\r\n // used by the binary search\r\n Result := Self.Width - AWidth;\r\n if Result = 0 then\r\n begin\r\n Result := Self.Height - AHeight;\r\n if Result = 0 then\r\n begin\r\n Result := Ord(Self.Style) - Ord(AStyle);\r\n if Result = 0 then\r\n Result := Ord(Self.CustomGlyphs) - Ord(ACustomGlyphs);\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TSpinButtonBitmaps.Draw(ACanvas: TCanvas;\r\n const ADown: TSpinButtonState; const AEnabled, AMouseInTopBtn, AMouseInBottomBtn: Boolean);\r\nbegin\r\n if FResetOnDraw then\r\n begin\r\n DrawAllBitmap;\r\n FResetOnDraw := False;\r\n end;\r\n\r\n with ACanvas do\r\n if not AEnabled then\r\n Draw(0, 0, FDisabledBtn)\r\n else\r\n case ADown of\r\n sbNotDown:\r\n {$IFDEF JVCLThemesEnabled}\r\n if FIsThemed then\r\n begin\r\n if AMouseInTopBtn then\r\n Draw(0, 0, FTopHotBtn)\r\n else\r\n if AMouseInBottomBtn then\r\n Draw(0, 0, FBottomHotBtn)\r\n else\r\n Draw(0, 0, FNotDownBtn);\r\n end\r\n else\r\n {$ENDIF JVCLThemesEnabled}\r\n Draw(0, 0, FNotDownBtn);\r\n sbTopDown:\r\n Draw(0, 0, FTopDownBtn);\r\n sbBottomDown:\r\n Draw(0, 0, FBottomDownBtn);\r\n end;\r\nend;\r\n\r\nprocedure TSpinButtonBitmaps.DrawAllBitmap;\r\nbegin\r\n {$IFDEF JVCLThemesEnabled}\r\n FIsThemed := ThemeServices.{$IFDEF RTL230_UP}Enabled{$ELSE}ThemesEnabled{$ENDIF RTL230_UP};\r\n if FIsThemed then\r\n begin\r\n if FStyle = sbsClassic then\r\n DrawAllBitmapClassicThemed\r\n else\r\n DrawAllBitmapDiagonalThemed;\r\n Exit;\r\n end;\r\n {$ENDIF JVCLThemesEnabled}\r\n\r\n DrawBitmap(FTopDownBtn, sbTopDown, True);\r\n DrawBitmap(FBottomDownBtn, sbBottomDown, True);\r\n DrawBitmap(FNotDownBtn, sbNotDown, True);\r\n DrawBitmap(FDisabledBtn, sbNotDown, False);\r\nend;\r\n\r\n{$IFDEF JVCLThemesEnabled}\r\n\r\nprocedure TSpinButtonBitmaps.DrawAllBitmapClassicThemed;\r\ntype\r\n TButtonPartState = (bpsNormal, bpsHot, bpsPressed, bpsDisabled);\r\nconst\r\n CDetails: array [Boolean, TButtonPartState] of TThemedSpin = (\r\n (tsUpNormal, tsUpHot, tsUpPressed, tsUpDisabled),\r\n (tsDownNormal, tsDownHot, tsDownPressed, tsDownDisabled)\r\n );\r\nvar\r\n TopRect, BottomRect: TRect;\r\n TopRegion_TopAbove, BottomRegion_TopAbove: HRGN;\r\n TopRegion_BottomAbove, BottomRegion_BottomAbove: HRGN;\r\n\r\n procedure ConstructThemedButton(ABitmap: TBitmap; const AUpState, ADownState: TButtonPartState);\r\n var\r\n Details: TThemedElementDetails;\r\n begin\r\n with ABitmap do\r\n begin\r\n Height := Self.Height;\r\n Width := Self.Width;\r\n\r\n with Canvas do\r\n begin\r\n // Select only top button\r\n if AUpState = bpsNormal then\r\n SelectClipRgn(Handle, TopRegion_BottomAbove)\r\n else\r\n SelectClipRgn(Handle, TopRegion_TopAbove);\r\n // Copy top button\r\n Details := ThemeServices.GetElementDetails(CDetails[False, AUpState]);\r\n ThemeServices.DrawElement(Handle, Details, TopRect);\r\n // Select only bottom button\r\n if AUpState = bpsNormal then\r\n SelectClipRgn(Handle, BottomRegion_BottomAbove)\r\n else\r\n SelectClipRgn(Handle, BottomRegion_TopAbove);\r\n // Copy bottom button\r\n Details := ThemeServices.GetElementDetails(CDetails[True, ADownState]);\r\n ThemeServices.DrawElement(Handle, Details, BottomRect);\r\n // Remove clipping restriction\r\n SelectClipRgn(Handle, 0);\r\n end;\r\n end;\r\n end;\r\n\r\nbegin\r\n TopRect := Rect(0, 0, Width, Height div 2);\r\n InflateRect(TopRect, 1, 1);\r\n\r\n BottomRect := Rect(0, TopRect.Bottom, Width, Height);\r\n InflateRect(BottomRect, 1, 1);\r\n\r\n { Construct the regions (needed because the up & down buttons overlap\r\n each other) }\r\n TopRegion_TopAbove := CreateRectRgn(TopRect.Left, TopRect.Top, TopRect.Right, TopRect.Bottom + 1);\r\n TopRegion_BottomAbove := CreateRectRgn(TopRect.Left, TopRect.Top, TopRect.Right, TopRect.Bottom);\r\n BottomRegion_TopAbove := CreateRectRgn(BottomRect.Left, BottomRect.Top + 1, BottomRect.Right, BottomRect.Bottom);\r\n BottomRegion_BottomAbove := CreateRectRgn(BottomRect.Left, BottomRect.Top, BottomRect.Right, BottomRect.Bottom);\r\n try\r\n { Draw the buttons }\r\n ConstructThemedButton(FTopDownBtn, bpsPressed, bpsNormal);\r\n ConstructThemedButton(FBottomDownBtn, bpsNormal, bpsPressed);\r\n ConstructThemedButton(FNotDownBtn, bpsNormal, bpsNormal);\r\n ConstructThemedButton(FTopHotBtn, bpsHot, bpsNormal);\r\n ConstructThemedButton(FBottomHotBtn, bpsNormal, bpsHot);\r\n ConstructThemedButton(FDisabledBtn, bpsDisabled, bpsDisabled);\r\n finally\r\n DeleteObject(TopRegion_TopAbove);\r\n DeleteObject(BottomRegion_TopAbove);\r\n DeleteObject(TopRegion_BottomAbove);\r\n DeleteObject(BottomRegion_BottomAbove);\r\n end;\r\nend;\r\n\r\nprocedure TSpinButtonBitmaps.DrawAllBitmapDiagonalThemed;\r\ntype\r\n TButtonPartState = (bpsNormal, bpsHot, bpsPressed, bpsDisabled);\r\nconst\r\n CDetails: array [TButtonPartState] of TThemedButton =\r\n (tbPushButtonNormal, tbPushButtonHot, tbPushButtonPressed, tbPushButtonDisabled);\r\nvar\r\n I: TButtonPartState;\r\n TemplateButtons: array [TButtonPartState] of TBitmap;\r\n ThemeColors: array [0..2] of Cardinal;\r\n ButtonRect: TRect;\r\n PaintRect: TRect;\r\n TopRegion, BottomRegion: HRGN;\r\n UpBitmap, DownBitmap: TBitmap;\r\n ptButton: array [0..2] of TPoint;\r\n State: TButtonPartState;\r\n Details: TThemedElementDetails;\r\n\r\n procedure ConstructThemedButton(ABitmap: TBitmap; const AUpState, ADownState: TButtonPartState);\r\n begin\r\n with ABitmap do\r\n begin\r\n Height := Self.Height;\r\n Width := Self.Width;\r\n\r\n with Canvas do\r\n begin\r\n { Select only top button }\r\n SelectClipRgn(Handle, TopRegion);\r\n { Copy top button }\r\n ABitmap.Canvas.Draw(0, 0, TemplateButtons[AUpState]);\r\n { Select only bottom button }\r\n SelectClipRgn(Handle, BottomRegion);\r\n { Copy bottom button }\r\n ABitmap.Canvas.Draw(0, 0, TemplateButtons[ADownState]);\r\n { Remove clipping restriction }\r\n SelectClipRgn(Handle, 0);\r\n\r\n { Draw diagonal }\r\n Pen.Color := ThemeColors[0];\r\n MoveTo(PaintRect.Left, PaintRect.Bottom - 2);\r\n LineTo(PaintRect.Right - 1, PaintRect.Top - 1);\r\n\r\n Pen.Color := ThemeColors[1];\r\n MoveTo(PaintRect.Right - 1, PaintRect.Top);\r\n LineTo(PaintRect.Right - 1, PaintRect.Top);\r\n LineTo(PaintRect.Left, PaintRect.Bottom - 1);\r\n\r\n Pen.Color := ThemeColors[2];\r\n MoveTo(PaintRect.Left + 1, PaintRect.Bottom - 1);\r\n LineTo(PaintRect.Right, PaintRect.Top);\r\n\r\n if not CustomGlyphs then\r\n DrawDiagonalThemedArrows(ABitmap.Canvas, sbNotDown,\r\n AUpState <> bpsDisabled, UpBitmap, DownBitmap);\r\n end;\r\n end;\r\n end;\r\n\r\nbegin\r\n for I := Low(TemplateButtons) to High(TemplateButtons) do\r\n TemplateButtons[I] := TBitmap.Create;\r\n try\r\n ButtonRect := Bounds(0, 0, Width, Height);\r\n PaintRect := ButtonRect;\r\n InflateRect(ButtonRect, 1, 1);\r\n InflateRect(PaintRect, -1, -1);\r\n { Init templates }\r\n for State := Low(TButtonPartState) to High(TButtonPartState) do\r\n with TemplateButtons[State] do\r\n begin\r\n Height := Self.Height;\r\n Width := Self.Width;\r\n Details := ThemeServices.GetElementDetails(CDetails[State]);\r\n ThemeServices.DrawElement(Canvas.Handle, Details, ButtonRect);\r\n end;\r\n\r\n { Init diagonal colors }\r\n Details := ThemeServices.GetElementDetails(tbPushButtonNormal);\r\n with Details do\r\n begin\r\n GetThemeColor(ThemeServices.Theme[Element], Part, State, TMT_EDGELIGHTCOLOR, ThemeColors[0]);\r\n GetThemeColor(ThemeServices.Theme[Element], Part, State, TMT_BORDERCOLORHINT, ThemeColors[1]);\r\n GetThemeColor(ThemeServices.Theme[Element], Part, State, TMT_EDGESHADOWCOLOR, ThemeColors[2]);\r\n end;\r\n\r\n UpBitmap := nil;\r\n DownBitmap := nil;\r\n try\r\n if not CustomGlyphs then\r\n begin\r\n UpBitmap := TBitmap.Create;\r\n UpBitmap.Handle := LoadBitmap(HInstance, sSpinUpBtn);\r\n UpBitmap.Transparent := True;\r\n DownBitmap := TBitmap.Create;\r\n DownBitmap.Handle := LoadBitmap(HInstance, sSpinDownBtn);\r\n DownBitmap.Transparent := True;\r\n end;\r\n\r\n { Init regions, needed to draw the triangles }\r\n ptButton[0] := Point(ButtonRect.Left, ButtonRect.Bottom);\r\n ptButton[1] := Point(ButtonRect.Left, ButtonRect.Top);\r\n ptButton[2] := Point(ButtonRect.Right, ButtonRect.Top);\r\n TopRegion := CreatePolygonRgn(ptButton, 3, WINDING);\r\n ptButton[0] := Point(ButtonRect.Right, ButtonRect.Top);\r\n ptButton[1] := Point(ButtonRect.Right, ButtonRect.Bottom);\r\n ptButton[2] := Point(ButtonRect.Left, ButtonRect.Bottom);\r\n BottomRegion := CreatePolygonRgn(ptButton, 3, WINDING);\r\n try\r\n { Draw the buttons }\r\n ConstructThemedButton(FTopDownBtn, bpsPressed, bpsNormal);\r\n ConstructThemedButton(FBottomDownBtn, bpsNormal, bpsPressed);\r\n ConstructThemedButton(FNotDownBtn, bpsNormal, bpsNormal);\r\n ConstructThemedButton(FTopHotBtn, bpsHot, bpsNormal);\r\n ConstructThemedButton(FBottomHotBtn, bpsNormal, bpsHot);\r\n ConstructThemedButton(FDisabledBtn, bpsDisabled, bpsDisabled);\r\n finally\r\n DeleteObject(TopRegion);\r\n DeleteObject(BottomRegion);\r\n end;\r\n finally\r\n UpBitmap.Free;\r\n DownBitmap.Free;\r\n end;\r\n finally\r\n for I := Low(TemplateButtons) to High(TemplateButtons) do\r\n TemplateButtons[I].Free;\r\n end;\r\nend;\r\n\r\n{$ENDIF JVCLThemesEnabled}\r\n\r\nprocedure TSpinButtonBitmaps.DrawBitmap(ABitmap: TBitmap; ADownState: TSpinButtonState; const Enabled: Boolean);\r\nconst\r\n CColors: TColorArray = (clBtnShadow, clBtnHighlight, cl3DDkShadow);\r\nvar\r\n ButtonRect: TRect;\r\n LColors: TColorArray;\r\n UpArrow, DownArrow: TBitmap;\r\n\r\n procedure JvDraw;\r\n var\r\n TopFlags, BottomFlags: DWORD;\r\n R: TRect;\r\n begin\r\n TopFlags := EDGE_RAISED;\r\n BottomFlags := EDGE_RAISED;\r\n R := ButtonRect;\r\n\r\n with ABitmap.Canvas do\r\n begin\r\n LColors := CColors;\r\n if ADownState = sbTopDown then\r\n begin\r\n LColors[0] := clBtnFace;\r\n LColors[2] := clBtnHighlight;\r\n TopFlags := EDGE_SUNKEN;\r\n end;\r\n if ADownState = sbBottomDown then\r\n begin\r\n LColors[1] := clWindowFrame;\r\n LColors[2] := clBtnShadow;\r\n BottomFlags := EDGE_SUNKEN;\r\n end;\r\n DrawEdge(Handle, R, TopFlags, BF_TOPLEFT or BF_SOFT);\r\n DrawEdge(Handle, R, BottomFlags, BF_BOTTOMRIGHT or BF_SOFT);\r\n InflateRect(R, -1, -1);\r\n\r\n Pen.Color := LColors[0];\r\n MoveTo(R.Left, R.Bottom - 2);\r\n LineTo(R.Right - 1, R.Top - 1);\r\n\r\n Pen.Color := LColors[2];\r\n MoveTo(R.Right - 1, R.Top);\r\n LineTo(R.Right - 1, R.Top);\r\n LineTo(R.Left, R.Bottom - 1);\r\n\r\n Pen.Color := LColors[1];\r\n MoveTo(R.Left + 1, R.Bottom - 1);\r\n LineTo(R.Right, R.Top);\r\n\r\n if not CustomGlyphs then\r\n begin\r\n UpArrow.Assign(nil); // fixes GDI resource leak\r\n UpArrow.LoadFromResourceName(HInstance, sSpinUpBtn);\r\n UpArrow.TransparentColor := clWhite;\r\n UpArrow.Transparent := True;\r\n DownArrow.Assign(nil); // fixes GDI resource leak\r\n DownArrow.LoadFromResourceName(HInstance, sSpinDownBtn);\r\n DownArrow.TransparentColor := clWhite;\r\n DownArrow.Transparent := True;\r\n JvDrawArrows(ABitmap.Canvas, ADownState, Enabled, UpArrow, DownArrow);\r\n end;\r\n end;\r\n end;\r\n\r\n procedure PoleDraw;\r\n var\r\n H: Integer;\r\n TopFlags, BottomFlags: DWORD;\r\n R, R1: TRect;\r\n RSrc: TRect;\r\n begin\r\n TopFlags := EDGE_RAISED;\r\n BottomFlags := EDGE_RAISED;\r\n\r\n with ABitmap.Canvas do\r\n begin\r\n { top glyph }\r\n H := Height div 2;\r\n R := Bounds(0, 0, Width, H);\r\n if ADownState = sbTopDown then\r\n TopFlags := EDGE_SUNKEN\r\n else\r\n R.Bottom := R.Bottom + 1;\r\n if ADownState = sbBottomDown then\r\n BottomFlags := EDGE_SUNKEN;\r\n RSrc := R;\r\n DrawEdge(Handle, R, TopFlags, BF_RECT or BF_SOFT or BF_ADJUST);\r\n R1 := Bounds(0, H, Width, Height);\r\n R1.Bottom := Height;\r\n DrawEdge(Handle, R1, BottomFlags, BF_RECT or BF_SOFT or BF_ADJUST);\r\n if not CustomGlyphs then\r\n begin\r\n UpArrow.Assign(nil); // fixes GDI resource leak\r\n UpArrow.LoadFromResourceName(HInstance, sSpinUpBtnPole);\r\n UpArrow.TransparentColor := clWhite;\r\n UpArrow.Transparent := True;\r\n DownArrow.Assign(nil); // fixes GDI resource leak\r\n DownArrow.LoadFromResourceName(HInstance, sSpinDownBtnPole);\r\n DownArrow.TransparentColor := clWhite;\r\n DownArrow.Transparent := True;\r\n PoleDrawArrows(ABitmap.Canvas, ADownState, Enabled, UpArrow, DownArrow);\r\n end;\r\n end;\r\n end;\r\n\r\nbegin\r\n UpArrow := nil;\r\n DownArrow := nil;\r\n try\r\n if not CustomGlyphs then\r\n begin\r\n UpArrow := TBitmap.Create;\r\n DownArrow := TBitmap.Create;\r\n end;\r\n\r\n ABitmap.Height := Height;\r\n ABitmap.Width := Width;\r\n\r\n with ABitmap.Canvas do\r\n begin\r\n ButtonRect := Bounds(0, 0, Width, Height);\r\n Pen.Width := 1;\r\n Brush.Color := clBtnFace;\r\n Brush.Style := bsSolid;\r\n FillRect(ButtonRect);\r\n end;\r\n if FStyle = sbsClassic then\r\n PoleDraw\r\n else\r\n JvDraw;\r\n finally\r\n UpArrow.Free;\r\n DownArrow.Free;\r\n end;\r\nend;\r\n\r\n{$IFDEF JVCLThemesEnabled}\r\n\r\nprocedure TSpinButtonBitmaps.DrawDiagonalThemedArrows(ACanvas: TCanvas; const AState: TSpinButtonState;\r\n const Enabled: Boolean; AUpArrow, ADownArrow: TBitmap);\r\nvar\r\n UpArrowPos, DownArrowPos: TPoint;\r\n// UpArrowRect, DownArrowRect: TRect;\r\n DisabledBitmap: TBitmap;\r\nbegin\r\n { Init arrow positions }\r\n UpArrowPos := Point(\r\n Round((Width / 4) - (AUpArrow.Width / 2)) + 1,\r\n Round((Height / 4) - (AUpArrow.Height / 2)) + 1);\r\n DownArrowPos := Point(\r\n Round((3 * Width / 4) - (ADownArrow.Width / 2)) - 1,\r\n Round((3 * Height / 4) - (ADownArrow.Height / 2)) - 1);\r\n\r\n //UpArrowRect := Bounds(0, 0, AUpArrow.Width, AUpArrow.Height);\r\n //DownArrowRect := Bounds(0, 0, ADownArrow.Width, ADownArrow.Height);\r\n\r\n with ACanvas do\r\n begin\r\n { Draw up arraw }\r\n if Enabled then\r\n Draw(UpArrowPos.X, UpArrowPos.Y, AUpArrow)\r\n else\r\n begin\r\n DisabledBitmap := CreateDisabledBitmap(AUpArrow, clBlack);\r\n try\r\n Draw(UpArrowPos.X, UpArrowPos.Y, DisabledBitmap);\r\n finally\r\n DisabledBitmap.Free;\r\n end;\r\n end;\r\n\r\n { Draw bottom arrow }\r\n if Enabled then\r\n Draw(DownArrowPos.X, DownArrowPos.Y, ADownArrow)\r\n else\r\n begin\r\n DisabledBitmap := CreateDisabledBitmap(ADownArrow, clBlack);\r\n try\r\n Draw(DownArrowPos.X, DownArrowPos.Y, DisabledBitmap);\r\n finally\r\n DisabledBitmap.Free;\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\n{$ENDIF JVCLThemesEnabled}\r\n\r\nprocedure TSpinButtonBitmaps.DrawGlyphs(ACanvas: TCanvas; const AState: TSpinButtonState; const Enabled: Boolean;\r\n AUpArrow, ADownArrow: TBitmap);\r\nbegin\r\n {$IFDEF JVCLThemesEnabled}\r\n if FIsThemed then\r\n begin\r\n if FStyle <> sbsClassic then\r\n DrawDiagonalThemedArrows(ACanvas, AState, Enabled, AUpArrow, ADownArrow);\r\n Exit;\r\n end;\r\n {$ENDIF JVCLThemesEnabled}\r\n if FStyle = sbsClassic then\r\n PoleDrawArrows(ACanvas, AState, Enabled, AUpArrow, ADownArrow)\r\n else\r\n JvDrawArrows(ACanvas, AState, Enabled, AUpArrow, ADownArrow)\r\nend;\r\n\r\nprocedure TSpinButtonBitmaps.JvDrawArrows(ACanvas: TCanvas; const AState: TSpinButtonState;\r\n const Enabled: Boolean; AUpArrow, ADownArrow: TBitmap);\r\nvar\r\n Dest, Source: TRect;\r\n DeltaRect: Integer;\r\n DisabledBitmap: TBitmap;\r\nbegin\r\n { buttons }\r\n with ACanvas do\r\n begin\r\n { top glyph }\r\n DeltaRect := 1;\r\n if AState = sbTopDown then\r\n Inc(DeltaRect);\r\n\r\n Dest := Bounds(Round((Width / 4) - (AUpArrow.Width / 2)) + DeltaRect,\r\n Round((Height / 4) - (AUpArrow.Height / 2)) + DeltaRect, AUpArrow.Width,\r\n AUpArrow.Height);\r\n Source := Bounds(0, 0, AUpArrow.Width, AUpArrow.Height);\r\n\r\n if Enabled then\r\n BrushCopy( Dest, AUpArrow, Source, AUpArrow.TransparentColor)\r\n else\r\n begin\r\n DisabledBitmap := CreateDisabledBitmap(AUpArrow, clBlack);\r\n try\r\n BrushCopy( Dest, DisabledBitmap, Source, DisabledBitmap.TransparentColor);\r\n finally\r\n DisabledBitmap.Free;\r\n end;\r\n end;\r\n\r\n { bottom glyph }\r\n Dest := Bounds(Round((3 * Width / 4) - (ADownArrow.Width / 2)) - 1,\r\n Round((3 * Height / 4) - (ADownArrow.Height / 2)) - 1,\r\n ADownArrow.Width, ADownArrow.Height);\r\n Source := Bounds(0, 0, ADownArrow.Width, ADownArrow.Height);\r\n\r\n if Enabled then\r\n BrushCopy( Dest, ADownArrow, Source, ADownArrow.TransparentColor)\r\n else\r\n begin\r\n DisabledBitmap := CreateDisabledBitmap(ADownArrow, clBlack);\r\n try\r\n BrushCopy( Dest, DisabledBitmap, Source, DisabledBitmap.TransparentColor);\r\n finally\r\n DisabledBitmap.Free;\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TSpinButtonBitmaps.PoleDrawArrows(ACanvas: TCanvas;\r\n const AState: TSpinButtonState; const Enabled: Boolean; AUpArrow, ADownArrow: TBitmap);\r\nvar\r\n X, Y, I, J, H: Integer;\r\n R1: TRect;\r\n R: TRect;\r\n DisabledBitmap: TBitmap;\r\nbegin\r\n with ACanvas do\r\n begin\r\n H := Height div 2;\r\n R := Bounds(0, 0, Width, H);\r\n if AState <> sbTopDown then\r\n R.Bottom := R.Bottom + 1;\r\n R1 := Bounds(0, H, Width, Height);\r\n R1.Bottom := Height;\r\n I := R.Bottom - R.Top - 1;\r\n J := R1.Bottom - R1.Top - 1;\r\n Y := R.Top + (H - AUpArrow.Height) div 2;\r\n if AState = sbTopDown then\r\n OffsetRect(R1, 0, 1);\r\n\r\n R1.Bottom := R1.Top + I;\r\n if J - AUpArrow.Height < 0 then\r\n Y := R.Top;\r\n X := (Width - AUpArrow.Width) div 2;\r\n\r\n IntersectClipRect(Handle, R.Left, R.Top, R.Right, R.Bottom);\r\n if Enabled then\r\n Draw(X, Y, AUpArrow)\r\n else\r\n begin\r\n DisabledBitmap := CreateDisabledBitmap(AUpArrow, clBlack);\r\n try\r\n Draw(X, Y, DisabledBitmap);\r\n finally\r\n DisabledBitmap.Free;\r\n end;\r\n end;\r\n SelectClipRgn(Handle, 0);\r\n\r\n X := (Width - ADownArrow.Width) div 2;\r\n Y := R1.Top + (I - ADownArrow.Height) div 2;\r\n if I - ADownArrow.Height < 0 then\r\n begin\r\n Dec(R1.Top);\r\n Y := R1.Bottom - ADownArrow.Height\r\n end;\r\n\r\n IntersectClipRect(Handle, R1.Left, R1.Top, R1.Right, R1.Bottom);\r\n if Enabled then\r\n Draw(X, Y, ADownArrow)\r\n else\r\n begin\r\n DisabledBitmap := CreateDisabledBitmap(ADownArrow, clBlack);\r\n try\r\n Draw(X, Y, DisabledBitmap);\r\n finally\r\n DisabledBitmap.Free;\r\n end;\r\n end;\r\n SelectClipRgn(Handle, 0);\r\n end;\r\nend;\r\n\r\nprocedure TSpinButtonBitmaps.RemoveClient;\r\nbegin\r\n Dec(FClientCount);\r\n if FClientCount = 0 then\r\n Self.Free;\r\nend;\r\n\r\nprocedure TSpinButtonBitmaps.Reset;\r\nbegin\r\n FResetOnDraw := True;\r\nend;\r\n\r\n//=== { TSpinButtonBitmapsManager } ==========================================\r\n\r\nconstructor TSpinButtonBitmapsManager.Create;\r\nbegin\r\n inherited Create;\r\n FList := TList.Create;\r\nend;\r\n\r\ndestructor TSpinButtonBitmapsManager.Destroy;\r\nbegin\r\n while FList.Count > 0 do\r\n // this will implicitly remove the object from the list\r\n TObject(FList[0]).Free;\r\n\r\n FList.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TSpinButtonBitmapsManager.AddClient;\r\nbegin\r\n Inc(FClientCount);\r\nend;\r\n\r\nfunction TSpinButtonBitmapsManager.Find(const Width, Height: Integer;\r\n const AButtonStyle: TJvSpinButtonStyle; const ACustomGlyphs: Boolean;\r\n var Index: Integer): Boolean;\r\nvar\r\n L, H, I, C: Integer;\r\nbegin\r\n // same binary search as Classes.TStringList.Find\r\n Result := False;\r\n L := 0;\r\n H := FList.Count - 1;\r\n while L <= H do\r\n begin\r\n I := (L + H) shr 1;\r\n C := TSpinButtonBitmaps(FList[I]).CompareWith(Width, Height, AButtonStyle, ACustomGlyphs);\r\n if C < 0 then\r\n L := I + 1\r\n else\r\n begin\r\n H := I - 1;\r\n if C = 0 then\r\n begin\r\n Result := True;\r\n L := I;\r\n end;\r\n end;\r\n end;\r\n Index := L;\r\nend;\r\n\r\nprocedure TSpinButtonBitmapsManager.Remove(Obj: TObject);\r\nbegin\r\n FList.Remove(Obj);\r\nend;\r\n\r\nprocedure TSpinButtonBitmapsManager.RemoveClient;\r\nbegin\r\n Dec(FClientCount);\r\n if FClientCount = 0 then\r\n begin\r\n if Self = GSpinButtonBitmapsManager then\r\n GSpinButtonBitmapsManager := nil;\r\n Self.Free;\r\n end;\r\nend;\r\n\r\nfunction TSpinButtonBitmapsManager.WantButtons(const Width, Height: Integer;\r\n const AButtonStyle: TJvSpinButtonStyle; const ACustomGlyphs: Boolean): TSpinButtonBitmaps;\r\nvar\r\n Index: Integer;\r\nbegin\r\n if not Find(Width, Height, AButtonStyle, ACustomGlyphs, Index) then\r\n FList.Insert(Index, TSpinButtonBitmaps.Create(Self, Width, Height, AButtonStyle, ACustomGlyphs));\r\n Result := TSpinButtonBitmaps(FList[Index]);\r\nend;\r\n\r\n//=== { TCustomTimeEdit } ==========================================\r\n\r\nprocedure TJvCustomTimeEdit.Change;\r\nbegin\r\n DataConnector.Modify;\r\n inherited Change;\r\nend;\r\n\r\nconstructor TJvCustomTimeEdit.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n ControlStyle := ControlStyle - [csSetCaption] + [csReplicatable];\r\n FDataConnector := CreateDataConnector;\r\n FHour24 := True;\r\n Time := Now; // updates Text\r\nend;\r\n\r\nfunction TJvCustomTimeEdit.CreateDataConnector: TJvCustomTimeEditDataConnector;\r\nbegin\r\n Result := TJvCustomTimeEditDataConnector.Create(Self);\r\nend;\r\n\r\nprocedure TJvCustomTimeEdit.SetDataConnector(const Value: TJvCustomTimeEditDataConnector);\r\nbegin\r\n if Value <> FDataConnector then\r\n FDataConnector.Assign(Value);\r\nend;\r\n\r\nfunction TJvCustomTimeEdit.GetTime: TDateTime;\r\nbegin\r\n Result := 0.0;\r\n if (Text <> '') and IsTimeValid(Text) then\r\n Result := Int(fTime) + StrToTime(Text);\r\nend;\r\n\r\nprocedure TJvCustomTimeEdit.SetTime(Value: TDateTime);\r\nbegin\r\n if FTime <> Value then\r\n begin\r\n FTime := Value;\r\n Text := FormatDateTime(sTimeFormats[Hour24, ShowSeconds], FTime);\r\n end;\r\nend;\r\n\r\nfunction TJvCustomTimeEdit.IsTimeValid(const Value: string): Boolean;\r\nvar\r\n dt: TDateTime;\r\nbegin\r\n Result := TryStrToTime(Value, dt);\r\nend;\r\n\r\nprocedure TJvCustomTimeEdit.SetHour24(Value: Boolean);\r\nbegin\r\n if Value <> FHour24 then\r\n begin\r\n FHour24 := Value;\r\n Text := FormatDateTime(sTimeFormats[Hour24, ShowSeconds], Time);\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomTimeEdit.SetShowSeconds(Value: Boolean);\r\nbegin\r\n if Value <> FShowSeconds then\r\n begin\r\n FShowSeconds := Value;\r\n Text := FormatDateTime(sTimeFormats[Hour24, ShowSeconds], Time);\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomTimeEdit.UpdateTimeDigits(Increment: Boolean);\r\n\r\n procedure SetNumberChar(var S: string; APos: Integer; AValue: Char);\r\n begin\r\n S[APos] := AValue;\r\n end;\r\n\r\n procedure IncNumberChar(var S: string; APos: Integer);\r\n begin\r\n S[APos] := Succ(S[APos]);\r\n end;\r\n\r\n procedure DecNumberChar(var S: string; APos: Integer);\r\n begin\r\n S[APos] := Pred(S[APos]);\r\n end;\r\n\r\nvar\r\n Offset, AMPMOffset: Integer;\r\n NewValue: string;\r\nbegin\r\n if ReadOnly then\r\n begin\r\n MessageBeep(0);\r\n Exit;\r\n end;\r\n if Text = '' then\r\n Exit;\r\n\r\n NewValue := Text;\r\n\r\n AMPMOffset := 10;\r\n if not FShowSeconds then\r\n AMPMOffset := 7;\r\n\r\n Position := SelStart;\r\n // Hours\r\n if (SelStart = 0) or (SelStart = 1) or (SelStart = 2) then\r\n begin\r\n if Hour24 then\r\n begin\r\n if Increment then\r\n begin\r\n if (NewValue[1] = '2') and (NewValue[2] = '3') then\r\n begin\r\n SetNumberChar(NewValue, 1, '0');\r\n SetNumberChar(NewValue, 2, '0');\r\n end\r\n else\r\n if NewValue[2] = '9' then\r\n begin\r\n SetNumberChar(NewValue, 2, '0');\r\n IncNumberChar(NewValue, 1);\r\n end\r\n else\r\n IncNumberChar(NewValue, 2);\r\n end\r\n else // decrement\r\n begin\r\n if (NewValue[1] = '0') and (NewValue[2] = '0') then\r\n begin\r\n SetNumberChar(NewValue, 1, '2');\r\n SetNumberChar(NewValue, 2, '3');\r\n end\r\n else\r\n if NewValue[2] = '0' then\r\n begin\r\n DecNumberChar(NewValue, 1);\r\n SetNumberChar(NewValue, 2, '9');\r\n end\r\n else\r\n DecNumberChar(NewValue, 2);\r\n end;\r\n end\r\n\r\n else // Hour 12 AM/PM\r\n begin\r\n if Increment then\r\n begin\r\n if (NewValue[1] = '1') and (NewValue[2] = '2') then\r\n begin\r\n SetNumberChar(NewValue, 1, '0');\r\n SetNumberChar(NewValue, 2, '1');\r\n if NewValue[AMPMOffset] = 'A' then\r\n SetNumberChar(NewValue, AMPMOffset, 'P')\r\n else\r\n SetNumberChar(NewValue, AMPMOffset, 'A');\r\n end\r\n else\r\n if NewValue[2] = '9' then\r\n begin\r\n IncNumberChar(NewValue, 1);\r\n SetNumberChar(NewValue, 2, '0');\r\n end\r\n else\r\n IncNumberChar(NewValue, 2);\r\n end\r\n else // decrement\r\n begin\r\n if (NewValue[1] = '0') and (NewValue[2] = '1') then\r\n begin\r\n SetNumberChar(NewValue, 1, '1');\r\n SetNumberChar(NewValue, 2, '2');\r\n if NewValue[AMPMOffset] = 'A' then\r\n SetNumberChar(NewValue, AMPMOffset, 'P')\r\n else\r\n SetNumberChar(NewValue, AMPMOffset, 'A');\r\n end\r\n else\r\n if NewValue[2] = '0' then\r\n begin\r\n SetNumberChar(NewValue, 1, '0');\r\n SetNumberChar(NewValue, 2, '9');\r\n end\r\n else\r\n DecNumberChar(NewValue, 2);\r\n end;\r\n end;\r\n end\r\n\r\n // Minutes\r\n else\r\n if (SelStart >= 3) and (SelStart <= AMPMOffset - 2) then\r\n begin\r\n Offset := 7;\r\n if (SelStart <= 5) then\r\n Offset := 4;\r\n\r\n if Increment then\r\n begin\r\n if (NewValue[Offset] = '5') and (NewValue[Offset + 1] = '9') then\r\n begin\r\n SetNumberChar(NewValue, Offset, '0');\r\n SetNumberChar(NewValue, Offset + 1, '0');\r\n end\r\n else\r\n if NewValue[Offset + 1] = '9' then\r\n begin\r\n IncNumberChar(NewValue, Offset);\r\n SetNumberChar(NewValue, Offset + 1, '0');\r\n end\r\n else\r\n IncNumberChar(NewValue, Offset + 1);\r\n end\r\n else // decrement\r\n begin\r\n if (NewValue[Offset] = '0') and (NewValue[Offset + 1] = '0') then\r\n begin\r\n SetNumberChar(NewValue, Offset, '5');\r\n SetNumberChar(NewValue, Offset + 1, '9');\r\n end\r\n else\r\n if NewValue[Offset + 1] = '0' then\r\n begin\r\n DecNumberChar(NewValue, Offset);\r\n SetNumberChar(NewValue, Offset + 1, '9');\r\n end\r\n else\r\n DecNumberChar(NewValue, Offset + 1);\r\n end;\r\n end\r\n\r\n // AM/PM\r\n else\r\n if not Hour24 and (SelStart >= AMPMOffset - 1) and (SelStart <= AMPMOffset + 2) then\r\n begin\r\n case NewValue[AMPMOffset] of\r\n 'A': NewValue[AMPMOffset] := 'P';\r\n 'a': NewValue[AMPMOffset] := 'a';\r\n 'P': NewValue[AMPMOffset] := 'A';\r\n 'p': NewValue[AMPMOffset] := 'a';\r\n end;\r\n end;\r\n Text := NewValue;\r\n SelStart := Position;\r\nend;\r\n\r\nprocedure TJvCustomTimeEdit.WMCut(var Msg: TMessage);\r\nbegin\r\n if EditorEnabled and not ReadOnly then\r\n DataConnector.Edit;\r\n inherited;\r\nend;\r\n\r\nprocedure TJvCustomTimeEdit.WMPaste(var Msg: TMessage);\r\nbegin\r\n if EditorEnabled and not ReadOnly then\r\n DataConnector.Edit;\r\n inherited;\r\nend;\r\n\r\nprocedure TJvCustomTimeEdit.CMGetDataLink(var Msg: TMessage);\r\nbegin\r\n Msg.Result := LResult(DataConnector.GetDataLink);\r\nend;\r\n\r\nprocedure TJvCustomTimeEdit.UpClick(Sender: TObject);\r\nbegin\r\n if ReadOnly then\r\n DoBeepOnError\r\n else\r\n begin\r\n UpdateTimeDigits(True);\r\n DoTopClick;\r\n end;\r\nend;\r\n\r\ndestructor TJvCustomTimeEdit.Destroy;\r\nbegin\r\n FreeAndNil(FDataConnector);\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvCustomTimeEdit.DoExit;\r\nbegin\r\n try\r\n DataConnector.UpdateRecord;\r\n except\r\n SelectAll;\r\n SetFocus;\r\n raise;\r\n end;\r\n inherited DoExit;\r\nend;\r\n\r\nprocedure TJvCustomTimeEdit.DownClick(Sender: TObject);\r\nbegin\r\n if ReadOnly then\r\n DoBeepOnError\r\n else\r\n begin\r\n UpdateTimeDigits(False);\r\n DoBottomClick;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomTimeEdit.KeyDown(var Key: Word; Shift: TShiftState);\r\nbegin\r\n if (Key = VK_DELETE) or ((Key = VK_INSERT) and (ssShift in Shift)) then\r\n DataConnector.Edit;\r\n\r\n inherited KeyDown(Key, Shift);\r\nend;\r\n\r\nprocedure TJvCustomTimeEdit.KeyPress(var Key: Char);\r\n\r\n function SetNumberChar(const S: string; APos: Integer; AValue: Char): string;\r\n begin\r\n Result := S;\r\n Result[APos] := AValue;\r\n end;\r\n\r\nvar\r\n TimePos, MaxLen: Integer;\r\nbegin\r\n MaxLen := 5; // '00:00'\r\n if ShowSeconds then\r\n Inc(MaxLen, 3); // ':00'\r\n if not Hour24 then\r\n Inc(MaxLen, 3); // ' AM'\r\n\r\n case SelStart of\r\n 0: if not CharInSet(Key, ['0'..'2']) then Key := #0;\r\n 1: if not CharInSet(Key, ['0'..'9']) then Key := #0;\r\n 2: if CharInSet(Key, ['0'..'5']) then // allow the user to skip the ':'\r\n SelStart := SelStart + 1\r\n else\r\n Key := ':';\r\n 3: if not CharInSet(Key, ['0'..'5']) then Key := #0;\r\n 4: if not CharInSet(Key, ['0'..'9']) then Key := #0;\r\n end;\r\n if SelStart >= 5 then\r\n begin\r\n TimePos := SelStart;\r\n if not FShowSeconds then\r\n Inc(TimePos, 3);\r\n if SelStart < MaxLen then\r\n begin\r\n case TimePos of\r\n 5: if CharInSet(Key, ['0'..'5']) then\r\n SelStart := SelStart + 1 // allow the user to skip the ':'\r\n else\r\n Key := ':';\r\n 6: if not CharInSet(Key, ['0'..'5']) then Key := #0;\r\n 7: if not CharInSet(Key, ['0'..'9']) then Key := #0;\r\n 8: Key := ' ';\r\n 9: if (Key = 'a') or (Key = 'A') then Key := 'A'\r\n else if (Key = 'p') or (Key = 'P') then Key := 'P'\r\n else Key := #0;\r\n 10: if (Key = 'm') or (Key = 'M') then Key := 'M'\r\n else Key := #0;\r\n end;\r\n end\r\n else\r\n Key := #0;\r\n end;\r\n\r\n if (SelStart <> Length(Text)) and (Key <> #0) then\r\n begin\r\n Position := SelStart;\r\n Text := SetNumberChar(Text, SelStart + 1, Key);\r\n SelStart := Position + 1;\r\n Key := #0;\r\n end;\r\n\r\n if Length(Text) > MaxLen then\r\n Key := #0;\r\nend;\r\n\r\nfunction TJvCustomTimeEdit.GetValue: Extended;\r\nbegin\r\n Result := Time;\r\nend;\r\n\r\nprocedure TJvCustomTimeEdit.SetValue(NewValue: Extended);\r\nbegin\r\n Time := NewValue;\r\nend;\r\n\r\n//=== { TJvCustomTimeEditDataConnector } ====================================\r\n\r\nconstructor TJvCustomTimeEditDataConnector.Create(AEdit: TJvCustomTimeEdit);\r\nbegin\r\n inherited Create;\r\n FEdit := AEdit;\r\nend;\r\n\r\nprocedure TJvCustomTimeEditDataConnector.RecordChanged;\r\nbegin\r\n if Field.IsValid then\r\n begin\r\n FEdit.ReadOnly := not Field.CanModify;\r\n if Field.IsNull then\r\n begin\r\n FEdit.Time := 0.0;\r\n FEdit.Text := ''\r\n end\r\n else\r\n FEdit.Time := Field.AsDateTime;\r\n end\r\n else\r\n begin\r\n FEdit.Time := 0.0;\r\n FEdit.Text := '';\r\n FEdit.ReadOnly := True;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomTimeEditDataConnector.UpdateData;\r\nbegin\r\n if FEdit.Text = '' then\r\n Field.Clear\r\n else\r\n Field.AsDateTime := FEdit.Time;\r\n RecordChanged; // update to stored value\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvSplashWindow.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvSplshWnd.PAS, released on 2002-07-04.\r\n\r\nThe Initial Developers of the Original Code are: Fedor Koshevnikov, Igor Pavluk and Serge Korolev\r\nCopyright (c) 1997, 1998 Fedor Koshevnikov, Igor Pavluk and Serge Korolev\r\nCopyright (c) 2001,2002 SGB Software\r\nAll Rights Reserved.\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvSplashWindow.pas 12461 2009-08-14 17:21:33Z obones $\r\n\r\nunit JvSplashWindow;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n SysUtils, Classes, Windows, Graphics, Controls, Forms, StdCtrls, ExtCtrls,\r\n JvAnimatedImage, JvComponent;\r\n\r\ntype\r\n TJvSplashWindow = class(TJvForm)\r\n private\r\n FTextMessage: TLabel;\r\n function GetMessageText: string;\r\n procedure SetMessageText(const Value: string);\r\n protected\r\n procedure CreateParams(var Params: TCreateParams); override;\r\n public\r\n Image: TImage;\r\n Animation: TJvAnimatedImage;\r\n procedure CenterFor(Form: TCustomForm);\r\n property MessageText: string read GetMessageText write SetMessageText;\r\n end;\r\n\r\nfunction ShowSplashWindow(Graphic: TGraphic; const MsgText: string;\r\n JvxAnimate: Boolean; AlignForm: TCustomForm): TJvSplashWindow;\r\n\r\n// (rom) changed to var (otherwise it makes no sense)\r\nvar\r\n SplashStayOnTop: Boolean = True;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvSplashWindow.pas $';\r\n Revision: '$Revision: 12461 $';\r\n Date: '$Date: 2009-08-14 19:21:33 +0200 (ven. 14 août 2009) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n Math;\r\n\r\nconst\r\n defSplashHeight = 64;\r\n defImageLeft = 16;\r\n defImageTop = 16;\r\n defTextWidth = 238;\r\n defTextLeft = 56;\r\n defTextRight = 16;\r\n\r\nfunction CreateSplashWindow: TJvSplashWindow;\r\nbegin\r\n Result := TJvSplashWindow.CreateNew(Application, 0);\r\n with Result do\r\n begin\r\n BorderIcons := [];\r\n BorderStyle := bsNone;\r\n if SplashStayOnTop then\r\n FormStyle := fsStayOnTop\r\n else\r\n FormStyle := fsNormal;\r\n ClientHeight := defSplashHeight;\r\n ClientWidth := defImageLeft + defTextRight + 32;\r\n Enabled := False;\r\n Font.Height := -11;\r\n Font.Name := 'MS Sans Serif';\r\n PixelsPerInch := 96;\r\n Scaled := True;\r\n Font.Style := [];\r\n Font.Color := clWindowText;\r\n\r\n Image := TImage.Create(Result);\r\n Image.Parent := Result;\r\n Image.Left := defImageLeft;\r\n Image.Top := defImageTop;\r\n Image.Width := 32;\r\n Image.Height := 32;\r\n Image.AutoSize := False;\r\n Image.Stretch := True;\r\n Image.Visible := False;\r\n\r\n FTextMessage := TLabel.Create(Result);\r\n FTextMessage.Parent := Result;\r\n FTextMessage.Left := defTextLeft;\r\n FTextMessage.Width := defTextWidth;\r\n FTextMessage.AutoSize := False;\r\n FTextMessage.Alignment := taCenter;\r\n FTextMessage.WordWrap := True;\r\n\r\n Animation := TJvAnimatedImage.Create(Result);\r\n Animation.Parent := Result;\r\n Animation.Left := defImageLeft;\r\n Animation.Top := defImageTop;\r\n Animation.Width := 32;\r\n Animation.Height := 32;\r\n Animation.Active := False;\r\n Animation.AutoSize := False;\r\n Animation.Stretch := True;\r\n Animation.Visible := False;\r\n end;\r\nend;\r\n\r\nfunction ShowSplashWindow(Graphic: TGraphic; const MsgText: string;\r\n JvxAnimate: Boolean; AlignForm: TCustomForm): TJvSplashWindow;\r\nbegin\r\n Result := CreateSplashWindow;\r\n with Result do\r\n begin\r\n if JvxAnimate and (Graphic <> nil) then\r\n begin\r\n Animation.Glyph := Graphic as TBitmap;\r\n Animation.Visible := True;\r\n Animation.AsyncDrawing := True;\r\n Animation.Active := True;\r\n end\r\n else\r\n if Graphic <> nil then\r\n begin\r\n Image.Picture.Graphic := Graphic;\r\n Image.Visible := True;\r\n end\r\n else\r\n FTextMessage.Left := defImageLeft;\r\n FTextMessage.Caption := MsgText;\r\n MessageText := MsgText;\r\n CenterFor(AlignForm);\r\n Show;\r\n Update;\r\n end;\r\nend;\r\n\r\n\r\nprocedure TJvSplashWindow.CreateParams(var Params: TCreateParams);\r\nbegin\r\n inherited CreateParams(Params);\r\n Params.Style := Params.Style or WS_DLGFRAME;\r\nend;\r\n\r\n\r\n\r\n\r\nfunction TJvSplashWindow.GetMessageText: string;\r\nbegin\r\n Result := FTextMessage.Caption;\r\nend;\r\n\r\nprocedure TJvSplashWindow.SetMessageText(const Value: string);\r\nvar\r\n TextRect: TRect;\r\n VertOff: Integer;\r\nbegin\r\n TextRect := Rect(FTextMessage.Left, 0, Max(Screen.Width div 2 - 64,\r\n defTextWidth), 0);\r\n DrawText(Canvas.Handle,\r\n PChar(Value), - 1, TextRect, DT_CALCRECT or DT_WORDBREAK);\r\n VertOff := (ClientHeight div 2) - ((TextRect.Bottom - TextRect.Top) div 2);\r\n if VertOff < 0 then\r\n VertOff := 10;\r\n TextRect.Top := VertOff;\r\n TextRect.Bottom := TextRect.Bottom + VertOff;\r\n FTextMessage.BoundsRect := TextRect;\r\n ClientWidth := Max(ClientWidth, TextRect.Right + defTextRight);\r\n ClientHeight := Max(ClientHeight, VertOff * 2);\r\n if Value <> FTextMessage.Caption then\r\n begin\r\n FTextMessage.Caption := Value;\r\n Update;\r\n end;\r\nend;\r\n\r\nprocedure TJvSplashWindow.CenterFor(Form: TCustomForm);\r\nvar\r\n NewLeft, NewTop: Integer;\r\n DstRect: TRect;\r\nbegin\r\n if Form = nil then\r\n DstRect := Rect(0, 0, Screen.Width, Screen.Height)\r\n else\r\n DstRect := Form.BoundsRect;\r\n NewLeft := DstRect.Left + ((DstRect.Right - DstRect.Left) div 2) - (Width div 2);\r\n NewTop := DstRect.Top + ((DstRect.Bottom - DstRect.Top) div 2) - (Height div 2);\r\n SetBounds(NewLeft, NewTop, Width, Height);\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvSplit.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvSplit.PAS, released on 2002-07-04.\r\n\r\nThe Initial Developers of the Original Code are: Fedor Koshevnikov, Igor Pavluk and Serge Korolev\r\nCopyright (c) 1997, 1998 Fedor Koshevnikov, Igor Pavluk and Serge Korolev\r\nCopyright (c) 2001,2002 SGB Software\r\nAll Rights Reserved.\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvSplit.pas 13104 2011-09-07 06:50:43Z obones $\r\n\r\nunit JvSplit;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, Controls, ExtCtrls, Forms, Graphics, SysUtils, Classes,\r\n JvExtComponent;\r\n\r\ntype\r\n TSplitterStyle = (spUnknown, spHorizontalFirst, spHorizontalSecond,\r\n spVerticalFirst, spVerticalSecond);\r\n TInverseMode = (imNew, imClear, imMove);\r\n TSplitterMoveEvent = procedure(Sender: TObject; X, Y: Integer;\r\n var AllowChange: Boolean) of object;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvxSplitter = class(TJvCustomPanel)\r\n private\r\n FControlFirst: TControl;\r\n FControlSecond: TControl;\r\n FSizing: Boolean;\r\n FStyle: TSplitterStyle;\r\n FPrevOrg: TPoint;\r\n FOffset: TPoint;\r\n FNoDropCursor: Boolean;\r\n FLimitRect: TRect;\r\n FTopLeftLimit: Integer;\r\n FBottomRightLimit: Integer;\r\n FForm: TCustomForm;\r\n FActiveControl: TWinControl;\r\n FAppShowHint: Boolean;\r\n FOldKeyDown: TKeyEvent;\r\n FOnPosChanged: TNotifyEvent;\r\n FOnPosChanging: TSplitterMoveEvent;\r\n function FindControl: TControl;\r\n procedure ControlKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);\r\n procedure StartInverseRect;\r\n procedure EndInverseRect(X, Y: Integer; AllowChange, Apply: Boolean);\r\n function GetAlign: TAlign;\r\n procedure MoveInverseRect(X, Y: Integer; AllowChange: Boolean);\r\n procedure ShowInverseRect(X, Y: Integer; Mode: TInverseMode);\r\n procedure DrawSizingLine(Split: TPoint);\r\n function GetStyle: TSplitterStyle;\r\n function GetCursor: TCursor;\r\n procedure SetControlFirst(Value: TControl);\r\n procedure SetControlSecond(Value: TControl);\r\n procedure SetAlign(Value: TAlign);\r\n procedure StopSizing(X, Y: Integer; Apply: Boolean);\r\n procedure CheckPosition(var X, Y: Integer);\r\n procedure ReadOffset(Reader: TReader);\r\n procedure WriteOffset(Writer: TWriter);\r\n protected\r\n procedure DefineProperties(Filer: TFiler); override;\r\n procedure Loaded; override;\r\n procedure Notification(AComponent: TComponent; AOperation: TOperation); override;\r\n procedure MouseDown(Button: TMouseButton; Shift: TShiftState;\r\n X, Y: Integer); override;\r\n procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;\r\n procedure MouseUp(Button: TMouseButton; Shift: TShiftState;\r\n X, Y: Integer); override;\r\n procedure Changed; dynamic;\r\n procedure Changing(X, Y: Integer; var AllowChange: Boolean); dynamic;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n procedure UpdateState;\r\n published\r\n property ControlFirst: TControl read FControlFirst write SetControlFirst;\r\n property ControlSecond: TControl read FControlSecond write SetControlSecond;\r\n property Align: TAlign read GetAlign write SetAlign default alNone;\r\n property Constraints;\r\n property BevelInner;\r\n property BevelOuter;\r\n property BevelWidth;\r\n property BorderStyle;\r\n property Enabled;\r\n property Color;\r\n property Flat default True;\r\n property ParentFlat default False;\r\n property Cursor read GetCursor stored False;\r\n property TopLeftLimit: Integer read FTopLeftLimit write FTopLeftLimit default 20;\r\n property BottomRightLimit: Integer read FBottomRightLimit write FBottomRightLimit default 20;\r\n property ParentColor;\r\n property ParentShowHint;\r\n property ShowHint;\r\n property Visible;\r\n property OnPosChanged: TNotifyEvent read FOnPosChanged write FOnPosChanged;\r\n property OnPosChanging: TSplitterMoveEvent read FOnPosChanging write FOnPosChanging;\r\n property OnClick;\r\n property OnDblClick;\r\n property OnEnter;\r\n property OnExit;\r\n property OnMouseDown;\r\n property OnMouseMove;\r\n property OnMouseUp;\r\n property OnResize;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvSplit.pas $';\r\n Revision: '$Revision: 13104 $';\r\n Date: '$Date: 2011-09-07 08:50:43 +0200 (mer. 07 sept. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\n\r\nconst\r\n InverseThickness = 2;\r\n DefWidth = 3;\r\n\r\ntype\r\n TWinControlAccessProtected = class(TWinControl);\r\n\r\nfunction CToC(C1, C2: TControl; P: TPoint): TPoint;\r\nbegin\r\n Result := C1.ScreenToClient(C2.ClientToScreen(P));\r\nend;\r\n\r\nconstructor TJvxSplitter.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n ControlStyle := [csCaptureMouse, csClickEvents,\r\n csOpaque, csDoubleClicks]; // csAcceptsControls\r\n Width := 185;\r\n Height := DefWidth;\r\n FSizing := False;\r\n FTopLeftLimit := 20;\r\n FBottomRightLimit := 20;\r\n FControlFirst := nil;\r\n FControlSecond := nil;\r\n ParentFlat := False;\r\n Flat := True;\r\nend;\r\n\r\nprocedure TJvxSplitter.Loaded;\r\nbegin\r\n inherited Loaded;\r\n UpdateState;\r\nend;\r\n\r\nprocedure TJvxSplitter.DefineProperties(Filer: TFiler); { for backward compatibility }\r\nbegin\r\n inherited DefineProperties(Filer);\r\n Filer.DefineProperty('LimitOffset', ReadOffset, WriteOffset, False);\r\nend;\r\n\r\nprocedure TJvxSplitter.ReadOffset(Reader: TReader);\r\nvar\r\n I: Integer;\r\nbegin\r\n I := Reader.ReadInteger;\r\n FTopLeftLimit := I;\r\n FBottomRightLimit := I;\r\nend;\r\n\r\nprocedure TJvxSplitter.WriteOffset(Writer: TWriter);\r\nbegin\r\n Writer.WriteInteger(FTopLeftLimit);\r\nend;\r\n\r\nprocedure TJvxSplitter.UpdateState;\r\nbegin\r\n inherited Cursor := Cursor;\r\nend;\r\n\r\nfunction TJvxSplitter.FindControl: TControl;\r\nvar\r\n P: TPoint;\r\n I: Integer;\r\nbegin\r\n Result := nil;\r\n P := Point(Left, Top);\r\n case Align of\r\n alLeft:\r\n Dec(P.X);\r\n alRight:\r\n Inc(P.X, Width);\r\n alTop:\r\n Dec(P.Y);\r\n alBottom:\r\n Inc(P.Y, Height);\r\n else\r\n Exit;\r\n end;\r\n for I := 0 to Parent.ControlCount - 1 do\r\n begin\r\n Result := Parent.Controls[I];\r\n if PtInRect(Result.BoundsRect, P) then\r\n Exit;\r\n end;\r\n Result := nil;\r\nend;\r\n\r\nprocedure TJvxSplitter.CheckPosition(var X, Y: Integer);\r\nbegin\r\n if X - FOffset.X < FLimitRect.Left then\r\n X := FLimitRect.Left + FOffset.X\r\n else\r\n if X - FOffset.X + Width > FLimitRect.Right then\r\n X := FLimitRect.Right - Width + FOffset.X;\r\n if Y - FOffset.Y < FLimitRect.Top then\r\n Y := FLimitRect.Top + FOffset.Y\r\n else\r\n if Y - FOffset.Y + Height > FLimitRect.Bottom then\r\n Y := FLimitRect.Bottom + FOffset.Y - Height;\r\nend;\r\n\r\nprocedure TJvxSplitter.StartInverseRect;\r\nvar\r\n R: TRect;\r\n W: Integer;\r\nbegin\r\n if Parent = nil then\r\n Exit;\r\n R := Parent.ClientRect;\r\n FLimitRect.TopLeft := CToC(Self, Parent, Point(R.Left + FTopLeftLimit,\r\n R.Top + FTopLeftLimit));\r\n FLimitRect.BottomRight := CToC(Self, Parent, Point(R.Right - R.Left -\r\n FBottomRightLimit, R.Bottom - R.Top - FBottomRightLimit));\r\n FNoDropCursor := False;\r\n FForm := ValidParentForm(Self);\r\n FForm.Canvas.Handle := GetDCEx(FForm.Handle, 0,\r\n DCX_CACHE or DCX_CLIPSIBLINGS or DCX_LOCKWINDOWUPDATE);\r\n with FForm.Canvas do\r\n begin\r\n Pen.Color := clWhite;\r\n if FStyle in [spHorizontalFirst, spHorizontalSecond] then\r\n W := Height\r\n else\r\n W := Width;\r\n if W > InverseThickness + 1 then\r\n W := W - InverseThickness\r\n else\r\n W := InverseThickness;\r\n Pen.Width := W;\r\n Pen.Mode := pmXOR;\r\n end;\r\n ShowInverseRect(Width div 2, Height div 2, imNew);\r\nend;\r\n\r\nprocedure TJvxSplitter.EndInverseRect(X, Y: Integer; AllowChange, Apply: Boolean);\r\nconst\r\n DecSize = 3;\r\nvar\r\n NewSize: Integer;\r\n Rect: TRect;\r\n W, H: Integer;\r\n DC: HDC;\r\n P: TPoint;\r\nbegin\r\n if FForm <> nil then\r\n begin\r\n ShowInverseRect(0, 0, imClear);\r\n with FForm do\r\n begin\r\n DC := Canvas.Handle;\r\n Canvas.Handle := 0;\r\n ReleaseDC(Handle, DC);\r\n end;\r\n FForm := nil;\r\n end;\r\n FNoDropCursor := False;\r\n if Parent = nil then\r\n Exit;\r\n Rect := Parent.ClientRect;\r\n H := Rect.Bottom - Rect.Top - Height;\r\n W := Rect.Right - Rect.Left - Width;\r\n if not AllowChange then\r\n begin\r\n P := ScreenToClient(FPrevOrg);\r\n X := P.X + FOffset.X - Width div 2;\r\n Y := P.Y + FOffset.Y - Height div 2\r\n end;\r\n if not Apply then\r\n Exit;\r\n CheckPosition(X, Y);\r\n if (ControlFirst.Align = alRight) or\r\n ((ControlSecond <> nil) and (ControlSecond.Align = alRight)) then\r\n begin\r\n X := -X;\r\n FOffset.X := -FOffset.X;\r\n end;\r\n if (ControlFirst.Align = alBottom) or\r\n ((ControlSecond <> nil) and (ControlSecond.Align = alBottom)) then\r\n begin\r\n Y := -Y;\r\n FOffset.Y := -FOffset.Y;\r\n end;\r\n Parent.DisableAlign;\r\n try\r\n if FStyle = spHorizontalFirst then\r\n begin\r\n NewSize := ControlFirst.Height + Y - FOffset.Y;\r\n if NewSize <= 0 then\r\n NewSize := 1;\r\n if NewSize >= H then\r\n NewSize := H - DecSize;\r\n ControlFirst.Height := NewSize;\r\n end\r\n else\r\n if FStyle = spHorizontalSecond then\r\n begin\r\n NewSize := ControlSecond.Height + Y - FOffset.Y;\r\n if NewSize <= 0 then\r\n NewSize := 1;\r\n if NewSize >= H then\r\n NewSize := H - DecSize;\r\n ControlSecond.Height := NewSize;\r\n end\r\n else\r\n if FStyle = spVerticalFirst then\r\n begin\r\n NewSize := ControlFirst.Width + X - FOffset.X;\r\n if NewSize <= 0 then\r\n NewSize := 1;\r\n if NewSize >= W then\r\n NewSize := W - DecSize;\r\n ControlFirst.Width := NewSize;\r\n end\r\n else\r\n if FStyle = spVerticalSecond then\r\n begin\r\n NewSize := ControlSecond.Width + X - FOffset.X;\r\n if NewSize <= 0 then\r\n NewSize := 1;\r\n if NewSize >= W then\r\n NewSize := W - DecSize;\r\n ControlSecond.Width := NewSize;\r\n end;\r\n finally\r\n Parent.EnableAlign;\r\n end;\r\nend;\r\n\r\nprocedure TJvxSplitter.MoveInverseRect(X, Y: Integer; AllowChange: Boolean);\r\nvar\r\n P: TPoint;\r\n NoDrop: Boolean;\r\nbegin\r\n if not AllowChange then\r\n begin\r\n SetCursor(Screen.Cursors[crNoDrop]);\r\n Exit;\r\n end;\r\n P := Point(X, Y);\r\n CheckPosition(X, Y);\r\n NoDrop := not AllowChange or (((X <> P.X) and (FStyle in [spVerticalFirst,\r\n spVerticalSecond])) or ((Y <> P.Y) and (FStyle in [spHorizontalFirst,\r\n spHorizontalSecond])));\r\n if NoDrop <> FNoDropCursor then\r\n begin\r\n FNoDropCursor := NoDrop;\r\n if NoDrop then\r\n SetCursor(Screen.Cursors[crNoDrop])\r\n else\r\n SetCursor(Screen.Cursors[Cursor]);\r\n end;\r\n ShowInverseRect(X - FOffset.X + Width div 2, Y - FOffset.Y + Height div 2,\r\n imMove);\r\nend;\r\n\r\nprocedure TJvxSplitter.ShowInverseRect(X, Y: Integer; Mode: TInverseMode);\r\nvar\r\n Pt: TPoint;\r\n MaxRect: TRect;\r\n Horiz: Boolean;\r\nbegin\r\n Pt := Point(0, 0);\r\n if FStyle in [spHorizontalFirst, spHorizontalSecond] then\r\n begin\r\n Pt.Y := Y;\r\n Horiz := True;\r\n end\r\n else\r\n begin\r\n Pt.X := X;\r\n Horiz := False;\r\n end;\r\n MaxRect := Parent.ClientRect;\r\n Pt := ClientToScreen(Pt);\r\n MaxRect.TopLeft := Parent.ClientToScreen(MaxRect.TopLeft);\r\n MaxRect.BottomRight := Parent.ClientToScreen(MaxRect.BottomRight);\r\n if Pt.X < MaxRect.Left then\r\n Pt.X := MaxRect.Left;\r\n if Pt.X > MaxRect.Right then\r\n Pt.X := MaxRect.Right;\r\n if Pt.Y < MaxRect.Top then\r\n Pt.Y := MaxRect.Top;\r\n if Pt.Y > MaxRect.Bottom then\r\n Pt.Y := MaxRect.Bottom;\r\n if Mode = imMove then\r\n if ((Pt.X = FPrevOrg.X) and not Horiz) or\r\n ((Pt.Y = FPrevOrg.Y) and Horiz) then\r\n Exit;\r\n if Mode in [imClear, imMove] then\r\n DrawSizingLine(FPrevOrg);\r\n if Mode in [imNew, imMove] then\r\n begin\r\n DrawSizingLine(Pt);\r\n FPrevOrg := Pt;\r\n end;\r\nend;\r\n\r\nprocedure TJvxSplitter.DrawSizingLine(Split: TPoint);\r\nvar\r\n P: TPoint;\r\nbegin\r\n if FForm <> nil then\r\n begin\r\n P := FForm.ScreenToClient(Split);\r\n with FForm.Canvas do\r\n begin\r\n MoveTo(P.X, P.Y);\r\n if FStyle in [spHorizontalFirst, spHorizontalSecond] then\r\n LineTo(CToC(FForm, Self, Point(Width, 0)).X, P.Y)\r\n else\r\n LineTo(P.X, CToC(FForm, Self, Point(0, Height)).Y);\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJvxSplitter.GetStyle: TSplitterStyle;\r\nbegin\r\n Result := spUnknown;\r\n if ControlFirst <> nil then\r\n begin\r\n if ((ControlFirst.Align = alTop) and ((ControlSecond = nil) or\r\n (ControlSecond.Align = alClient))) or\r\n ((ControlFirst.Align = alBottom) and ((ControlSecond = nil) or\r\n (ControlSecond.Align = alClient))) then\r\n Result := spHorizontalFirst\r\n else\r\n if ((ControlFirst.Align = alClient) and (ControlSecond <> nil) and\r\n (ControlSecond.Align = alBottom)) or\r\n ((ControlFirst.Align = alClient) and (ControlSecond <> nil) and\r\n (ControlSecond.Align = alTop)) then\r\n Result := spHorizontalSecond\r\n else\r\n if ((ControlFirst.Align = alLeft) and ((ControlSecond = nil) or\r\n (ControlSecond.Align = alClient))) or\r\n ((ControlFirst.Align = alRight) and ((ControlSecond = nil) or\r\n (ControlSecond.Align = alClient))) then\r\n Result := spVerticalFirst\r\n else\r\n if ((ControlFirst.Align = alClient) and (ControlSecond <> nil) and\r\n (ControlSecond.Align = alRight)) or\r\n ((ControlFirst.Align = alClient) and (ControlSecond <> nil) and\r\n (ControlSecond.Align = alLeft)) then\r\n Result := spVerticalSecond;\r\n case Result of\r\n spHorizontalFirst, spVerticalFirst:\r\n if Align <> FControlFirst.Align then\r\n Result := spUnknown;\r\n spHorizontalSecond, spVerticalSecond:\r\n if Align <> FControlSecond.Align then\r\n Result := spUnknown;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvxSplitter.SetAlign(Value: TAlign);\r\nbegin\r\n if not (Align in [alTop, alBottom, alLeft, alRight]) then\r\n begin\r\n inherited Align := Value;\r\n if not (csReading in ComponentState) then\r\n begin\r\n if Value in [alTop, alBottom] then\r\n Height := DefWidth\r\n else\r\n if Value in [alLeft, alRight] then\r\n Width := DefWidth;\r\n end;\r\n end\r\n else\r\n inherited Align := Value;\r\n if (ControlFirst = nil) and (ControlSecond = nil) then\r\n ControlFirst := FindControl;\r\nend;\r\n\r\nfunction TJvxSplitter.GetAlign: TAlign;\r\nbegin\r\n Result := inherited Align;\r\nend;\r\n\r\nfunction TJvxSplitter.GetCursor: TCursor;\r\nbegin\r\n Result := crDefault;\r\n case GetStyle of\r\n spHorizontalFirst, spHorizontalSecond:\r\n Result := crVSplit;\r\n spVerticalFirst, spVerticalSecond:\r\n Result := crHSplit;\r\n end;\r\nend;\r\n\r\nprocedure TJvxSplitter.SetControlFirst(Value: TControl);\r\nbegin\r\n if Value <> FControlFirst then\r\n begin\r\n if FControlFirst <> nil then\r\n FControlFirst.RemoveFreeNotification(Self);\r\n if (Value = Self) or (Value is TForm) then\r\n FControlFirst := nil\r\n else\r\n begin\r\n FControlFirst := Value;\r\n if Value <> nil then\r\n Value.FreeNotification(Self);\r\n end;\r\n UpdateState;\r\n end;\r\nend;\r\n\r\nprocedure TJvxSplitter.SetControlSecond(Value: TControl);\r\nbegin\r\n if Value <> FControlSecond then\r\n begin\r\n if FControlSecond <> nil then\r\n FControlSecond.RemoveFreeNotification(Self);\r\n if (Value = Self) or (Value is TForm) then\r\n FControlSecond := nil\r\n else\r\n begin\r\n FControlSecond := Value;\r\n if Value <> nil then\r\n Value.FreeNotification(Self);\r\n end;\r\n UpdateState;\r\n end;\r\nend;\r\n\r\nprocedure TJvxSplitter.Notification(AComponent: TComponent; AOperation: TOperation);\r\nbegin\r\n inherited Notification(AComponent, AOperation);\r\n if AOperation = opRemove then\r\n begin\r\n if AComponent = ControlFirst then\r\n ControlFirst := nil\r\n else\r\n if AComponent = ControlSecond then\r\n ControlSecond := nil;\r\n end;\r\nend;\r\n\r\nprocedure TJvxSplitter.Changed;\r\nbegin\r\n if Assigned(FOnPosChanged) then\r\n FOnPosChanged(Self);\r\nend;\r\n\r\nprocedure TJvxSplitter.Changing(X, Y: Integer; var AllowChange: Boolean);\r\nbegin\r\n if Assigned(FOnPosChanging) then\r\n FOnPosChanging(Self, X, Y, AllowChange);\r\nend;\r\n\r\nprocedure TJvxSplitter.StopSizing(X, Y: Integer; Apply: Boolean);\r\nvar\r\n AllowChange: Boolean;\r\nbegin\r\n if FSizing then\r\n begin\r\n ReleaseCapture;\r\n AllowChange := Apply;\r\n if Apply then\r\n Changing(X, Y, AllowChange);\r\n EndInverseRect(X, Y, AllowChange, Apply);\r\n FSizing := False;\r\n Application.ShowHint := FAppShowHint;\r\n if Assigned(FActiveControl) then\r\n begin\r\n TWinControlAccessProtected(FActiveControl).OnKeyDown := FOldKeyDown;\r\n FActiveControl := nil;\r\n end;\r\n if Apply then\r\n Changed;\r\n end;\r\nend;\r\n\r\nprocedure TJvxSplitter.ControlKeyDown(Sender: TObject; var Key: Word;\r\n Shift: TShiftState);\r\nbegin\r\n if Assigned(FOldKeyDown) then\r\n FOldKeyDown(Sender, Key, Shift);\r\n StopSizing(0, 0, False);\r\nend;\r\n\r\nprocedure TJvxSplitter.MouseDown(Button: TMouseButton; Shift: TShiftState;\r\n X, Y: Integer);\r\nbegin\r\n inherited MouseDown(Button, Shift, X, Y);\r\n if not (csDesigning in ComponentState) and (Button = mbLeft) then\r\n begin\r\n FStyle := GetStyle;\r\n if FStyle <> spUnknown then\r\n begin\r\n FSizing := True;\r\n FAppShowHint := Application.ShowHint;\r\n SetCapture(Handle);\r\n with ValidParentForm(Self) do\r\n begin\r\n if ActiveControl <> nil then\r\n FActiveControl := ActiveControl\r\n else\r\n FActiveControl := GetParentForm(Self);\r\n FOldKeyDown := TWinControlAccessProtected(FActiveControl).OnKeyDown;\r\n TWinControlAccessProtected(FActiveControl).OnKeyDown := ControlKeyDown;\r\n end;\r\n Application.ShowHint := False;\r\n FOffset := Point(X, Y);\r\n StartInverseRect;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvxSplitter.MouseMove(Shift: TShiftState; X, Y: Integer);\r\nvar\r\n AllowChange: Boolean;\r\nbegin\r\n inherited MouseMove(Shift, X, Y);\r\n if (GetCapture = Handle) and FSizing then\r\n begin\r\n AllowChange := True;\r\n Changing(X, Y, AllowChange);\r\n MoveInverseRect(X, Y, AllowChange);\r\n end;\r\nend;\r\n\r\nprocedure TJvxSplitter.MouseUp(Button: TMouseButton; Shift: TShiftState;\r\n X, Y: Integer);\r\nbegin\r\n StopSizing(X, Y, True);\r\n inherited MouseUp(Button, Shift, X, Y);\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvSplitter.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvSplitter.PAS, released on 2001-02-28.\r\n\r\nThe Initial Developer of the Original Code is Sbastien Buysse [sbuysse att buypin dott com]\r\nPortions created by Sbastien Buysse are Copyright (C) 2001 Sbastien Buysse.\r\nAll Rights Reserved.\r\n\r\nContributor(s): Michael Beck [mbeck att bigfoot dott com].\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvSplitter.pas 13104 2011-09-07 06:50:43Z obones $\r\n\r\nunit JvSplitter;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n SysUtils, Classes,\r\n Windows, Messages, Graphics, Forms, ExtCtrls, Controls,\r\n JvExExtCtrls;\r\n\r\ntype\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvSplitter = class(TJvExSplitter)\r\n {$IFDEF JVCLThemesEnabled}\r\n protected\r\n procedure Paint; override;\r\n {$ENDIF JVCLThemesEnabled}\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n published\r\n property ShowHint;\r\n property HintColor;\r\n property OnMouseEnter;\r\n property OnMouseLeave;\r\n property OnParentColorChange;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvSplitter.pas $';\r\n Revision: '$Revision: 13104 $';\r\n Date: '$Date: 2011-09-07 08:50:43 +0200 (mer. 07 sept. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n JvThemes;\r\n\r\nconstructor TJvSplitter.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n IncludeThemeStyle(Self, [csParentBackground]);\r\nend;\r\n\r\n{$IFDEF JVCLThemesEnabled}\r\nprocedure TJvSplitter.Paint;\r\nvar\r\n Bmp: TBitmap;\r\n DC: THandle;\r\nbegin\r\n if ThemeServices.{$IFDEF RTL230_UP}Enabled{$ELSE}ThemesEnabled{$ENDIF RTL230_UP} then\r\n begin\r\n// DrawThemedBackground(Self, Canvas, ClientRect, Parent.Brush.Color);\r\n DC := Canvas.Handle;\r\n Bmp := TBitmap.Create;\r\n try\r\n Bmp.Width := ClientWidth;\r\n Bmp.Height := ClientHeight;\r\n Canvas.Handle := Bmp.Canvas.Handle;\r\n try\r\n inherited Paint;\r\n finally\r\n Canvas.Handle := DC;\r\n end;\r\n Bmp.Transparent := True;\r\n Bmp.TransparentColor := Color;\r\n Canvas.Draw(0, 0, Bmp);\r\n finally\r\n Bmp.Free;\r\n end;\r\n end\r\n else\r\n inherited Paint;\r\nend;\r\n{$ENDIF JVCLThemesEnabled}\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvStarfield.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvStarfield.PAS, released on 2001-02-28.\r\n\r\nThe Initial Developer of the Original Code is Sbastien Buysse [sbuysse att buypin dott com]\r\nPortions created by Sbastien Buysse are Copyright (C) 2001 Sbastien Buysse.\r\nAll Rights Reserved.\r\n\r\nContributor(s): Michael Beck [mbeck att bigfoot dott com].\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvStarfield.pas 13104 2011-09-07 06:50:43Z obones $\r\n\r\nunit JvStarfield;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, Graphics, Controls,\r\n SysUtils, Classes,\r\n JvTypes, JvImageDrawThread, JvComponent;\r\n\r\ntype\r\n TJvStars = record\r\n X: Integer;\r\n Y: Integer;\r\n Color: TColor;\r\n Speed: Integer;\r\n end;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvStarfield = class(TJvGraphicControl)\r\n private\r\n FStarfield: array of TJvStars;\r\n FThread: TJvImageDrawThread;\r\n FActive: Boolean;\r\n FDelay: Cardinal;\r\n FStars: Word;\r\n FMaxSpeed: Byte;\r\n FBmp: TBitmap;\r\n FOnActiveChanged: TNotifyEvent;\r\n procedure Refresh(Sender: TObject);\r\n procedure SetActive(const Value: Boolean);\r\n procedure SetDelay(const Value: Cardinal);\r\n procedure SetStars(const Value: Word);\r\n protected\r\n procedure Paint; override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n procedure Resize; override;\r\n procedure Clear;\r\n published\r\n property Align;\r\n property Anchors;\r\n property Constraints;\r\n property ParentColor default False;\r\n property Color default clBlack;\r\n property Height default 100;\r\n property Width default 100;\r\n property Delay: Cardinal read FDelay write SetDelay default 50;\r\n property Active: Boolean read FActive write SetActive default False;\r\n property Stars: Word read FStars write SetStars default 100;\r\n property MaxSpeed: Byte read FMaxSpeed write FMaxSpeed default 10;\r\n property Visible;\r\n\r\n property OnMouseDown;\r\n property OnMouseUp;\r\n property OnMouseMove;\r\n property OnClick;\r\n property OnDblClick;\r\n property OnMouseEnter;\r\n property OnMouseLeave;\r\n property OnActiveChanged: TNotifyEvent read FOnActiveChanged write FOnActiveChanged;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvStarfield.pas $';\r\n Revision: '$Revision: 13104 $';\r\n Date: '$Date: 2011-09-07 08:50:43 +0200 (mer. 07 sept. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\n\r\nconstructor TJvStarfield.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n ParentColor := False;\r\n Color := clBlack;\r\n ControlStyle := ControlStyle + [csOpaque];\r\n FDelay := 50;\r\n FActive := False;\r\n FBmp := TBitmap.Create;\r\n\r\n FThread := TJvImageDrawThread.Create(True);\r\n FThread.FreeOnTerminate := False;\r\n FThread.Delay := FDelay;\r\n FThread.OnDraw := Refresh;\r\n Width := 100;\r\n Height := 100;\r\n FMaxSpeed := 10;\r\n\r\n Stars := 100;\r\nend;\r\n\r\ndestructor TJvStarfield.Destroy;\r\nbegin\r\n SetLength(FStarfield, 0);\r\n FThread.OnDraw := nil;\r\n FThread.Terminate;\r\n FreeAndNil(FThread);\r\n FBmp.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvStarfield.Resize;\r\nbegin\r\n inherited Resize;\r\n FBmp.Width := Width;\r\n FBmp.Height := Height;\r\n Stars := FStars;\r\nend;\r\n\r\nprocedure TJvStarfield.SetStars(const Value: Word);\r\nvar\r\n I, J: Integer;\r\nbegin\r\n Randomize;\r\n FStars := Value;\r\n SetLength(FStarfield, FStars);\r\n for I := 0 to FStars - 1 do\r\n begin\r\n FStarfield[I].X := Random(Width div 2) + Width;\r\n FStarfield[I].Y := Random(Height);\r\n FStarfield[I].Speed := Random(FMaxSpeed) + 1;\r\n J := Random(120) + 120;\r\n FStarfield[I].Color := RGB(J, J, J);\r\n end;\r\nend;\r\n\r\nprocedure TJvStarfield.SetActive(const Value: Boolean);\r\nbegin\r\n if (FActive <> Value) and Assigned(FOnActiveChanged) then\r\n FOnActiveChanged(Self);\r\n FActive := Value;\r\n if not (csDesigning in ComponentState) then\r\n FThread.Paused := not FActive;\r\nend;\r\n\r\nprocedure TJvStarfield.SetDelay(const Value: Cardinal);\r\nbegin\r\n FDelay := Value;\r\n FThread.Delay := Value;\r\nend;\r\n\r\nprocedure TJvStarfield.Refresh(Sender: TObject);\r\nbegin\r\n Paint;\r\nend;\r\n\r\nprocedure TJvStarfield.Paint;\r\nvar\r\n I, J: Integer;\r\nbegin\r\n // Must exit because we are \"Synchronized\" and our parent is already\r\n // partly destroyed. If we did not exit, we would get an AV.\r\n if csDestroying in ComponentState then\r\n Exit;\r\n\r\n if csDesigning in ComponentState then\r\n begin\r\n Canvas.Brush.Style := bsClear;\r\n Canvas.Pen.Style := psDot;\r\n Canvas.Pen.Color := clBlack;\r\n Canvas.Rectangle(ClientRect);\r\n end\r\n else\r\n begin\r\n if (FBmp.Height <> Height) or (FBmp.Width <> Width) then\r\n Resize\r\n else\r\n begin\r\n FBmp.Canvas.Brush.Color := Color;\r\n if Color = clNone then\r\n FBmp.Canvas.Brush.Style := bsClear\r\n else\r\n FBmp.Canvas.Brush.Style := bsSolid;\r\n FBmp.Canvas.FillRect(ClientRect);\r\n for I := 0 to FStars - 1 do\r\n begin\r\n if FStarfield[I].X < Width then\r\n FBmp.Canvas.Pixels[FStarfield[I].X, FStarfield[I].Y] := FStarfield[I].Color;\r\n FStarfield[I].X := FStarfield[I].X - FStarfield[I].Speed;\r\n if FStarfield[I].X < 0 then\r\n begin\r\n FStarfield[I].X := Width;\r\n FStarfield[I].Y := Random(Height);\r\n FStarfield[I].Speed := Random(FMaxSpeed) + 1;\r\n J := Random(120) + 120;\r\n FStarfield[I].Color := RGB(J, J, J);\r\n end;\r\n end;\r\n Canvas.Lock;\r\n try\r\n if Color = clNone then\r\n Canvas.Brush.Style := bsClear\r\n else\r\n Canvas.Brush.Style := bsSolid;\r\n Canvas.Draw(0, 0, FBmp);\r\n finally\r\n Canvas.Unlock;\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvStarfield.Clear;\r\nbegin\r\n if not Active then\r\n begin\r\n Canvas.Brush.Color := Color;\r\n if Color = clNone then\r\n Canvas.Brush.Style := bsClear\r\n else\r\n Canvas.Brush.Style := bsSolid;\r\n Canvas.FillRect(ClientRect);\r\n end;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvStartMenuButton.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvStartMenuBtn.PAS, released on 2001-02-28.\r\n\r\nThe Initial Developer of the Original Code is Sbastien Buysse [sbuysse att buypin dott com]\r\nPortions created by Sbastien Buysse are Copyright (C) 2001 Sbastien Buysse.\r\nAll Rights Reserved.\r\n\r\nContributor(s): Michael Beck [mbeck att bigfoot dott com].\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvStartMenuButton.pas 13155 2011-11-06 12:31:20Z ahuser $\r\n\r\nunit JvStartMenuButton;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, SysUtils, Classes, Graphics, Controls, Menus, ImgList,\r\n JvTypes, JvButton, JvComputerInfoEx;\r\n\r\ntype\r\n TJvStartMenuOption = (smCurrentUser, smCommon);\r\n TJvStartMenuOptions = set of TJvStartMenuOption;\r\n\r\nconst\r\n smAllUsers = smCommon;\r\n\r\ntype\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvStartMenuButton = class(TJvCustomButton)\r\n private\r\n FPopup: TPopupMenu;\r\n FDirs: TJvSystemFolders;\r\n FOnLinkClick: TJvLinkClickEvent;\r\n FOnPopup: TNotifyEvent;\r\n FImages: TImageList;\r\n FOptions: TJvStartMenuOptions;\r\n procedure UrlClick(Sender: TObject);\r\n protected\r\n procedure AddIconFrom(Path: string);\r\n procedure DeleteItem(Item: TMenuItem; LookTag: Boolean = False);\r\n procedure PopupCreate(Sender: TObject);\r\n procedure DirectoryClick(Sender: TObject);\r\n procedure DynBuild(Item: TMenuItem; Directory: string);\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n procedure Click; override;\r\n published\r\n property Options: TJvStartMenuOptions read FOptions write FOptions default [smCurrentUser..smAllUsers];\r\n property OnLinkClick: TJvLinkClickEvent read FOnLinkClick write FOnLinkClick;\r\n property OnPopup: TNotifyEvent read FOnPopup write FOnPopup;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvStartMenuButton.pas $';\r\n Revision: '$Revision: 13155 $';\r\n Date: '$Date: 2011-11-06 13:31:20 +0100 (dim. 06 nov. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n ShellAPI,\r\n JvJVCLUtils, JvResources;\r\n\r\nconstructor TJvStartMenuButton.Create(AOwner: TComponent);\r\nvar\r\n MenuItem: TMenuItem;\r\nbegin\r\n inherited Create(AOwner);\r\n FDirs := TJvSystemFolders.Create;\r\n FOptions := [smCurrentUser..smAllUsers];\r\n //Create Popup\r\n FPopup := TPopupMenu.Create(Self);\r\n MenuItem := TMenuItem.Create(FPopup);\r\n MenuItem.Enabled := False;\r\n MenuItem.Caption := RsEmptyItem;\r\n MenuItem.Tag := 1;\r\n FPopup.Items.Add(MenuItem);\r\n FPopup.OnPopup := PopupCreate;\r\n\r\n //Create Images\r\n FImages := TImageList.Create(Self);\r\n FImages.Width := 16;\r\n FImages.Height := 16;\r\n FImages.DrawingStyle := dsTransparent;\r\n FPopup.Images := FImages;\r\n AddIconFrom(FDirs.Windows);\r\nend;\r\n\r\ndestructor TJvStartMenuButton.Destroy;\r\nbegin\r\n FDirs.Free;\r\n DeleteItem(FPopup.Items);\r\n FPopup.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvStartMenuButton.Click;\r\nvar\r\n P: TPoint;\r\nbegin\r\n inherited Click;\r\n P.X := 0;\r\n P.Y := Height;\r\n P := ClientToScreen(P);\r\n FPopup.Popup(P.X, P.Y);\r\n if Assigned(FOnPopup) then\r\n FOnPopup(Self);\r\nend;\r\n\r\nprocedure TJvStartMenuButton.UrlClick(Sender: TObject);\r\nbegin\r\n if Assigned(FOnLinkClick) then\r\n FOnLinkClick(Self, (Sender as TMenuItem).Hint);\r\nend;\r\n\r\nprocedure TJvStartMenuButton.DeleteItem(Item: TMenuItem; LookTag: Boolean);\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := Item.Count - 1 downto 0 do\r\n if (not LookTag) or (Item[I].Tag = 0) then\r\n begin\r\n DeleteItem(Item[I]);\r\n Item[I].Free;\r\n end;\r\nend;\r\n\r\nprocedure TJvStartMenuButton.AddIconFrom(Path: string);\r\nvar\r\n FileInfo: SHFILEINFO;\r\n Bmp: TBitmap;\r\nbegin\r\n SHGetFileInfo(PChar(Path), 0, FileInfo, SizeOf(FileInfo), SHGFI_SMALLICON or SHGFI_ICON);\r\n Bmp := IconToBitmap2(FileInfo.hIcon, 16, clMenu);\r\n try\r\n FImages.AddMasked(Bmp, Bmp.TransparentColor);\r\n finally\r\n Bmp.Free;\r\n end;\r\nend;\r\n\r\nprocedure TJvStartMenuButton.DirectoryClick(Sender: TObject);\r\nbegin\r\n DynBuild((Sender as TMenuItem), (Sender as TMenuItem).Hint);\r\nend;\r\n\r\nprocedure TJvStartMenuButton.PopupCreate(Sender: TObject);\r\nbegin\r\n if smCurrentUser in Options then\r\n DynBuild(FPopup.Items, FDirs.StartMenu);\r\n if smCommon in Options then\r\n DynBuild(FPopup.Items, FDirs.CommonStartMenu);\r\nend;\r\n\r\nprocedure TJvStartMenuButton.DynBuild(Item: TMenuItem; Directory: string);\r\nvar\r\n Res, FolderIndex: Integer;\r\n SearchRec: TSearchRec;\r\n MenuItem, SubMenuItem: TMenuItem;\r\n First: Boolean;\r\n Bmp: TBitmap;\r\n\r\n function GetPathImage(const APath: string): TBitmap;\r\n var\r\n FileInfo: SHFILEINFO;\r\n begin\r\n SHGetFileInfo(PChar(APath), 0, FileInfo, SizeOf(FileInfo), SHGFI_ICON or SHGFI_SMALLICON);\r\n Result := IconToBitmap2(FileInfo.hIcon, 16, clMenu);\r\n// Result := IconToBitmap2(ExtractAssociatedIcon(Application.Handle, PChar(MenuItem.Hint), w),16,clMenu);\r\n end;\r\n\r\nbegin\r\n DeleteItem(Item, True);\r\n if (Directory <> '') and (Directory[Length(Directory)] <> '\\') then\r\n Directory := Directory + '\\';\r\n Res := FindFirst(Directory + '*.*', faAnyFile, SearchRec);\r\n First := True;\r\n FolderIndex := 1;\r\n while Res = 0 do\r\n begin\r\n if (SearchRec.Name <> '.') and (SearchRec.Name <> '..') then\r\n begin\r\n if First then\r\n Item.Items[0].Visible := False;\r\n if (SearchRec.Attr and faDirectory) = faDirectory then\r\n begin\r\n MenuItem := TMenuItem.Create(Item);\r\n MenuItem.Caption := SearchRec.Name;\r\n MenuItem.Hint := Directory + SearchRec.Name;\r\n MenuItem.OnClick := DirectoryClick;\r\n MenuItem.ImageIndex := 0;\r\n Item.Insert(FolderIndex, MenuItem);\r\n Inc(FolderIndex);\r\n SubMenuItem := TMenuItem.Create(MenuItem);\r\n SubMenuItem.Caption := RsEmptyItem;\r\n SubMenuItem.Enabled := False;\r\n SubMenuItem.Tag := 1;\r\n MenuItem.Add(SubMenuItem);\r\n end\r\n else\r\n begin\r\n MenuItem := TMenuItem.Create(Item);\r\n MenuItem.Caption := ChangeFileExt(SearchRec.Name, '');\r\n MenuItem.OnClick := UrlClick;\r\n MenuItem.Hint := Directory + SearchRec.Name;\r\n Bmp := GetPathImage(MenuItem.Hint);\r\n MenuItem.Bitmap.Assign(Bmp);\r\n Bmp.Free;\r\n Item.Add(MenuItem);\r\n end;\r\n end;\r\n Res := FindNext(SearchRec);\r\n end;\r\n FindClose(SearchRec);\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvStaticText.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvStaticText.PAS, released on 2001-02-28.\r\n\r\nThe Initial Developer of the Original Code is Sbastien Buysse [sbuysse att buypin dott com]\r\nPortions created by Sbastien Buysse are Copyright (C) 2001 Sbastien Buysse.\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\nMichael Beck [mbeck att bigfoot dott com].\r\nPeter Thrnqvist \r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nChanges 2002-10-22:\r\n Totally reimplemented (though a lot of code was taken from original TStaticText) to add new properties:\r\n WordWrap, Layout (vertial Alignment), TextMargins (to offset from the edges)\r\n\r\n Also adds virtual DrawItem and AdjustBounds methods to make it easier to derive new\r\n components that handles the drawing differently\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvStaticText.pas 13415 2012-09-10 09:51:54Z obones $\r\n\r\nunit JvStaticText;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, Messages, SysUtils, Classes, Graphics, Controls, StdCtrls, Forms,\r\n JvTypes, JvComponent;\r\n\r\ntype\r\n TJvTextMargins = class(TPersistent)\r\n private\r\n FX: Word;\r\n FY: Word;\r\n FOnChange: TNotifyEvent;\r\n procedure SetX(const Value: Word);\r\n procedure SetY(const Value: Word);\r\n procedure Change;\r\n protected\r\n property OnChange: TNotifyEvent read FOnChange write FOnChange;\r\n published\r\n property X: Word read FX write SetX;\r\n property Y: Word read FY write SetY;\r\n end;\r\n\r\n TJvCustomStaticText = class(TJvWinControl)\r\n private\r\n FFontSave: TFont;\r\n FHotTrack: Boolean;\r\n FHotTrackFont: TFont;\r\n FLayout: TTextLayout;\r\n FAlignment: TAlignment;\r\n FAutoSize: Boolean;\r\n FBorderStyle: TStaticBorderStyle;\r\n FFocusControl: TWinControl;\r\n FShowAccelChar: Boolean;\r\n FTextMargins: TJvTextMargins;\r\n FWordWrap: Boolean;\r\n FHotTrackFontOptions: TJvTrackFOntOptions;\r\n procedure SetAlignment(Value: TAlignment);\r\n procedure SetBorderStyle(Value: TStaticBorderStyle);\r\n procedure SetFocusControl(Value: TWinControl);\r\n procedure SetShowAccelChar(Value: Boolean);\r\n procedure SetHotTrackFont(const Value: TFont);\r\n procedure SetLayout(const Value: TTextLayout);\r\n procedure CNDrawItem(var Msg: TWMDrawItem); message CN_DRAWITEM;\r\n procedure SetTextMargins(const Value: TJvTextMargins);\r\n procedure SetWordWrap(const Value: Boolean);\r\n procedure DoMarginsChange(Sender: TObject);\r\n procedure SetHotTrackFontOptions(const Value: TJvTrackFOntOptions);\r\n protected\r\n procedure Resize; override;\r\n procedure Loaded; override;\r\n procedure MouseEnter(Control: TControl); override;\r\n procedure MouseLeave(Control: TControl); override;\r\n function WantKey(Key: Integer; Shift: TShiftState): Boolean; override;\r\n procedure FontChanged; override;\r\n procedure TextChanged; override;\r\n procedure AdjustBounds; dynamic;\r\n procedure Notification(AComponent: TComponent; Operation: TOperation); override;\r\n procedure SetAutoSize(Value: Boolean); override;\r\n procedure DrawItem(const DrawItemStruct: TDrawItemStruct); virtual;\r\n function GetTextDisplayInfo(ADC: HDC; const AText: string; var ARect: TRect): Cardinal;\r\n procedure CreateParams(var Params: TCreateParams); override;\r\n property Alignment: TAlignment read FAlignment write SetAlignment default taLeftJustify;\r\n property AutoSize: Boolean read FAutoSize write SetAutoSize default True;\r\n property BorderStyle: TStaticBorderStyle read FBorderStyle write SetBorderStyle default sbsNone;\r\n property FocusControl: TWinControl read FFocusControl write SetFocusControl;\r\n property ShowAccelChar: Boolean read FShowAccelChar write SetShowAccelChar default True;\r\n property HotTrack: Boolean read FHotTrack write FHotTrack default False;\r\n property HotTrackFont: TFont read FHotTrackFont write SetHotTrackFont;\r\n property HotTrackFontOptions: TJvTrackFOntOptions read FHotTrackFontOptions write SetHotTrackFontOptions default DefaultTrackFontOptions;\r\n property Layout: TTextLayout read FLayout write SetLayout;\r\n property TextMargins: TJvTextMargins read FTextMargins write SetTextMargins;\r\n property WordWrap: Boolean read FWordWrap write SetWordWrap;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n end;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvStaticText = class(TJvCustomStaticText)\r\n published\r\n property Align;\r\n property Alignment;\r\n property Anchors;\r\n property AutoSize;\r\n property BevelEdges;\r\n property BevelInner;\r\n property BevelKind default bkNone;\r\n property BevelOuter;\r\n property BiDiMode;\r\n property DragCursor;\r\n property DragKind;\r\n property OnEndDock;\r\n property OnStartDock;\r\n property ParentBiDiMode;\r\n property BorderStyle;\r\n property Caption;\r\n property Color;\r\n property Constraints;\r\n property DragMode;\r\n property Enabled;\r\n property FocusControl;\r\n property Font;\r\n property HintColor;\r\n property HotTrack;\r\n property HotTrackFont;\r\n property HotTrackFontOptions;\r\n property Layout;\r\n property ParentColor;\r\n property ParentFont;\r\n property ParentShowHint;\r\n property PopupMenu;\r\n property ShowAccelChar;\r\n property ShowHint;\r\n property TabOrder;\r\n property TabStop;\r\n property TextMargins;\r\n property Visible;\r\n property WordWrap;\r\n property OnClick;\r\n property OnContextPopup;\r\n property OnDblClick;\r\n property OnDragDrop;\r\n property OnDragOver;\r\n property OnEndDrag;\r\n property OnMouseDown;\r\n property OnMouseEnter;\r\n property OnMouseLeave;\r\n property OnMouseMove;\r\n property OnMouseUp;\r\n property OnParentColorChange;\r\n property OnStartDrag;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvStaticText.pas $';\r\n Revision: '$Revision: 13415 $';\r\n Date: '$Date: 2012-09-10 11:51:54 +0200 (lun. 10 sept. 2012) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n Types,\r\n JvJCLUtils, JvJVCLUtils, JvThemes;\r\n\r\n//=== { TJvCustomStaticText } ================================================\r\n\r\nconstructor TJvCustomStaticText.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FTextMargins := TJvTextMargins.Create;\r\n FTextMargins.OnChange := DoMarginsChange;\r\n\r\n FHotTrackFont := TFont.Create;\r\n FFontSave := TFont.Create;\r\n FLayout := tlTop;\r\n ControlStyle := [csCaptureMouse, csClickEvents, csSetCaption,\r\n csOpaque, csReplicatable, csDoubleClicks];\r\n IncludeThemeStyle(Self, [csParentBackground]);\r\n\r\n Width := 65;\r\n Height := 17;\r\n FAutoSize := True;\r\n FShowAccelChar := True;\r\n FHotTrackFontOptions := DefaultTrackFontOptions;\r\nend;\r\n\r\ndestructor TJvCustomStaticText.Destroy;\r\nbegin\r\n FHotTrackFont.Free;\r\n FFontSave.Free;\r\n FTextMargins.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvCustomStaticText.MouseEnter(Control: TControl);\r\nbegin\r\n if csDesigning in ComponentState then\r\n Exit;\r\n if not MouseOver then\r\n begin\r\n if FHotTrack then\r\n begin\r\n FFontSave.Assign(Font);\r\n Font.Assign(FHotTrackFont);\r\n end;\r\n inherited MouseEnter(Control);\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomStaticText.MouseLeave(Control: TControl);\r\nbegin\r\n if MouseOver then\r\n begin\r\n if FHotTrack then\r\n Font.Assign(FFontSave);\r\n inherited MouseLeave(Control);\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomStaticText.SetHotTrackFont(const Value: TFont);\r\nbegin\r\n FHotTrackFont.Assign(Value);\r\nend;\r\n\r\n\r\nprocedure TJvCustomStaticText.CreateParams(var Params: TCreateParams);\r\nbegin\r\n inherited CreateParams(Params);\r\n CreateSubClass(Params, 'STATIC');\r\n with Params do\r\n Style := Style or SS_NOTIFY or SS_OWNERDRAW;\r\nend;\r\n\r\n\r\n\r\nprocedure TJvCustomStaticText.SetLayout(const Value: TTextLayout);\r\nbegin\r\n if FLayout <> Value then\r\n begin\r\n FLayout := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\n\r\nprocedure TJvCustomStaticText.CNDrawItem(var Msg: TWMDrawItem);\r\nbegin\r\n DrawItem(Msg.DrawItemStruct^);\r\nend;\r\n\r\n\r\nprocedure TJvCustomStaticText.DrawItem(const DrawItemStruct: TDrawItemStruct);\r\nconst\r\n cBorders: array [TStaticBorderStyle] of DWORD = (0, BF_MONO, BF_SOFT);\r\nvar\r\n R: TRect;\r\n DrawStyle: Cardinal;\r\n B: HBRUSH;\r\nbegin\r\n B := CreateSolidBrush(ColorToRGB(Color));\r\n try\r\n with DrawItemStruct do\r\n begin\r\n R := rcItem;\r\n DrawThemedBackground(Self, hDC, R, B);\r\n if BorderStyle <> sbsNone then\r\n DrawEdge(hDC, R, BDR_SUNKENOUTER, BF_ADJUST or BF_RECT or cBorders[BorderStyle]);\r\n DrawStyle := GetTextDisplayInfo(hDC, Self.Caption, R);\r\n case Layout of\r\n tlTop:\r\n OffsetRect(R, 0, FTextMargins.Y);\r\n tlBottom:\r\n OffsetRect(R, 0, (ClientHeight - R.Bottom) - FTextMargins.Y);\r\n tlCenter:\r\n OffsetRect(R, 0, (ClientHeight - R.Bottom) div 2);\r\n end;\r\n case Alignment of\r\n taLeftJustify:\r\n OffsetRect(R, FTextMargins.X, 0);\r\n taRightJustify:\r\n OffsetRect(R, (Width - R.Right) - FTextMargins.X, 0);\r\n taCenter:\r\n OffsetRect(R, (Width - R.Right) div 2, 0);\r\n end;\r\n SetBkMode(hDC, Windows.TRANSPARENT);\r\n DrawText(hDC, Caption, Length(Caption), R, DrawStyle);\r\n// DrawText(hDC, Caption, Length(Caption), R, DrawStyle);\r\n end;\r\n finally\r\n DeleteObject(B);\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomStaticText.SetAutoSize(Value: Boolean);\r\nbegin\r\n if FAutoSize <> Value then\r\n begin\r\n FAutoSize := Value;\r\n if Value then\r\n AdjustBounds;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomStaticText.AdjustBounds;\r\nvar\r\n DC: HDC;\r\n R: TRect;\r\n SaveFont: HFont;\r\n TextSize: TSize;\r\nbegin\r\n if not (csReading in ComponentState) and AutoSize and HandleAllocated then\r\n begin\r\n DC := GetDC(HWND_DESKTOP);\r\n if not WordWrap then\r\n begin\r\n SaveFont := SelectObject(DC, Font.Handle);\r\n GetTextExtentPoint32(DC, PChar(Caption), Length(Caption), TextSize);\r\n SelectObject(DC, SaveFont);\r\n SetBounds(Left, Top,\r\n TextSize.cx + (GetSystemMetrics(SM_CXBORDER) * 4),\r\n TextSize.cy + (GetSystemMetrics(SM_CYBORDER) * 4));\r\n end\r\n else\r\n begin\r\n R := ClientRect;\r\n GetTextDisplayInfo(DC, Self.Caption, R);\r\n SetBounds(Left, Top, R.Right, R.Bottom);\r\n end;\r\n ReleaseDC(HWND_DESKTOP, DC);\r\n end;\r\nend;\r\n\r\nfunction TJvCustomStaticText.WantKey(Key: Integer; Shift: TShiftState): Boolean;\r\nbegin\r\n Result := (FFocusControl <> nil) and Enabled and ShowAccelChar and\r\n IsAccel(Key, Caption) and (ssAlt in Shift);\r\n if Result then\r\n if FFocusControl.CanFocus then\r\n FFocusControl.SetFocus;\r\nend;\r\n\r\nprocedure TJvCustomStaticText.FontChanged;\r\nbegin\r\n inherited FontChanged;\r\n AdjustBounds;\r\n UpdateTrackFont(HotTrackFont, Font, HotTrackFontOptions);\r\nend;\r\n\r\nprocedure TJvCustomStaticText.TextChanged;\r\nbegin\r\n inherited TextChanged;\r\n AdjustBounds;\r\nend;\r\n\r\nprocedure TJvCustomStaticText.Loaded;\r\nbegin\r\n inherited Loaded;\r\n AdjustBounds;\r\nend;\r\n\r\nprocedure TJvCustomStaticText.Notification(AComponent: TComponent;\r\n Operation: TOperation);\r\nbegin\r\n inherited Notification(AComponent, Operation);\r\n if (Operation = opRemove) and (AComponent = FFocusControl) then\r\n FFocusControl := nil;\r\nend;\r\n\r\nprocedure TJvCustomStaticText.SetAlignment(Value: TAlignment);\r\nbegin\r\n if FAlignment <> Value then\r\n begin\r\n FAlignment := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomStaticText.SetBorderStyle(Value: TStaticBorderStyle);\r\nbegin\r\n if FBorderStyle <> Value then\r\n begin\r\n FBorderStyle := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomStaticText.SetFocusControl(Value: TWinControl);\r\nbegin\r\n ReplaceComponentReference(Self, Value, TComponent(FFocusControl));\r\nend;\r\n\r\nprocedure TJvCustomStaticText.SetShowAccelChar(Value: Boolean);\r\nbegin\r\n if FShowAccelChar <> Value then\r\n begin\r\n FShowAccelChar := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomStaticText.SetTextMargins(const Value: TJvTextMargins);\r\nbegin\r\n if Value = nil then\r\n begin\r\n FTextMargins.X := 0;\r\n FTextMargins.Y := 0\r\n end\r\n else\r\n begin\r\n FTextMargins.X := Value.X;\r\n FTextMargins.Y := Value.Y;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomStaticText.DoMarginsChange(Sender: TObject);\r\nbegin\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvCustomStaticText.SetWordWrap(const Value: Boolean);\r\nbegin\r\n if FWordWrap <> Value then\r\n begin\r\n FWordWrap := Value;\r\n AdjustBounds;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nfunction TJvCustomStaticText.GetTextDisplayInfo(ADC: HDC; const AText: string; var ARect: TRect): Cardinal;\r\nconst\r\n cAlignment: array [Boolean, TAlignment] of DWORD =\r\n ((DT_LEFT, DT_RIGHT, DT_CENTER), (DT_RIGHT, DT_LEFT, DT_CENTER));\r\n cLayout: array [TTextLayout] of DWORD = (DT_TOP, DT_VCENTER, DT_BOTTOM);\r\n cDrawAccel: array [Boolean] of DWORD = (DT_NOPREFIX, 0);\r\n cWordWrap: array [Boolean] of DWORD = (0{DT_SINGLELINE}, DT_WORDBREAK);\r\nbegin\r\n Result := DT_EXPANDTABS or cAlignment[UseRightToLeftAlignment, Alignment] or\r\n cLayout[Layout] or cDrawAccel[ShowAccelChar] or cWordWrap[WordWrap];\r\n DrawText(ADC, AText, Length(AText), ARect, Result or DT_CALCRECT);\r\nend;\r\n\r\nprocedure TJvCustomStaticText.Resize;\r\nbegin\r\n inherited Resize;\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvCustomStaticText.SetHotTrackFontOptions(const Value: TJvTrackFOntOptions);\r\nbegin\r\n if FHotTrackFontOptions <> Value then\r\n begin\r\n FHotTrackFontOptions := Value;\r\n UpdateTrackFont(HotTrackFont, Font,FHotTrackFontOptions);\r\n end;\r\nend;\r\n\r\n\r\n\r\n\r\n//=== { TJvTextMargins } =====================================================\r\n\r\nprocedure TJvTextMargins.Change;\r\nbegin\r\n if Assigned(FOnChange) then\r\n FOnChange(Self);\r\nend;\r\n\r\nprocedure TJvTextMargins.SetX(const Value: Word);\r\nbegin\r\n if FX <> Value then\r\n begin\r\n FX := Value;\r\n Change;\r\n end;\r\nend;\r\n\r\nprocedure TJvTextMargins.SetY(const Value: Word);\r\nbegin\r\n if FY <> Value then\r\n begin\r\n FY := Value;\r\n Change;\r\n end;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvStatusBar.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvStatusBar2.PAS, released on 2001-02-28.\r\n\r\nThe Initial Developer of the Original Code is Sbastien Buysse [sbuysse att buypin dott com]\r\nPortions created by Sbastien Buysse are Copyright (C) 2001 Sbastien Buysse.\r\nAll Rights Reserved.\r\n\r\nContributor(s): Michael Beck [mbeck att bigfoot dott com].\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvStatusBar.pas 13392 2012-08-11 23:20:08Z ahuser $\r\n\r\nunit JvStatusBar;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, Messages,\r\n CommCtrl,\r\n SysUtils, Classes, Graphics, Controls, Forms, ComCtrls, StdActns,\r\n JVCLVer, JvExComCtrls;\r\n\r\ntype\r\n TJvStatusPanel = class(TStatusPanel)\r\n private\r\n FAboutJVCL: TJVCLAboutInfo;\r\n FControl: TControl;\r\n FMarginLeft: Integer;\r\n FMarginTop: Integer;\r\n procedure SetControl(const Value: TControl);\r\n procedure SetMarginLeft(const Value: Integer);\r\n procedure SetMarginTop(const Value: Integer);\r\n procedure Changed(AllItems: Boolean);\r\n public\r\n constructor Create(Collection: TCollection); override;\r\n destructor Destroy; override;\r\n published\r\n property AboutJVCL: TJVCLAboutInfo read FAboutJVCL write FAboutJVCL stored False;\r\n property Control: TControl read FControl write SetControl;\r\n property MarginLeft: Integer read FMarginLeft write SetMarginLeft default 3;\r\n property MarginTop: Integer read FMarginTop write SetMarginTop default 3;\r\n end;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvStatusBar = class(TJvExStatusBar)\r\n private\r\n FAutoHintShown: Boolean;\r\n FHiddenControls: array of TControl;\r\n procedure WMPaint(var Msg: TWMPaint); message WM_PAINT;\r\n protected\r\n procedure BoundsChanged; override;\r\n procedure CreateParams(var Params: TCreateParams); override;\r\n procedure Notification(AComponent: TComponent; Operation: TOperation); override;\r\n procedure MovePanelControls;\r\n function GetPanelClass: TStatusPanelClass; override;\r\n procedure SBSetParts(var msg: TMessage); message SB_SETPARTS;\r\n {$IFDEF COMPILER16_UP}\r\n procedure WndProc(var Msg: TMessage); override;\r\n {$ENDIF COMPILER16_UP}\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n function ExecuteAction(Action: TBasicAction): Boolean; override;\r\n property AutoHintShown: Boolean read FAutoHintShown;\r\n published\r\n property Color;\r\n property Font;\r\n property HintColor;\r\n property OnMouseEnter;\r\n property OnMouseLeave;\r\n property OnParentColorChange;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvStatusBar.pas $';\r\n Revision: '$Revision: 13392 $';\r\n Date: '$Date: 2012-08-12 01:20:08 +0200 (dim. 12 août 2012) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n JvThemes, JvResources, JvTypes, JvJVCLUtils;\r\n\r\n//=== { TJvStatusBar } =======================================================\r\n\r\nconstructor TJvStatusBar.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n ControlStyle := ControlStyle + [csAcceptsControls];\r\nend;\r\n\r\nprocedure TJvStatusBar.BoundsChanged;\r\nbegin\r\n inherited BoundsChanged;\r\n Realign;\r\n MovePanelControls;\r\nend;\r\n\r\n\r\n\r\nprocedure TJvStatusBar.CreateParams(var Params: TCreateParams);\r\nbegin\r\n inherited CreateParams(Params);\r\n {$IFDEF JVCLThemesEnabled}\r\n if not ThemeServices.{$IFDEF RTL230_UP}Enabled{$ELSE}ThemesEnabled{$ENDIF RTL230_UP} then\r\n {$ENDIF JVCLThemesEnabled}\r\n with Params do\r\n WindowClass.Style := WindowClass.Style and not CS_HREDRAW;\r\nend;\r\n\r\nprocedure TJvStatusBar.WMPaint(var Msg: TWMPaint);\r\nbegin\r\n if FAutoHintShown then\r\n DefaultHandler(Msg)\r\n else\r\n inherited;\r\nend;\r\n\r\n\r\n\r\n\r\n\r\nfunction TJvStatusBar.ExecuteAction(Action: TBasicAction): Boolean;\r\nvar\r\n HintText: string;\r\n PanelEdges: Integer;\r\n Flags: DWORD;\r\n\r\n procedure CancelAutoHintShown;\r\n var\r\n I: Integer;\r\n begin\r\n if FAutoHintShown then\r\n begin\r\n Panels.EndUpdate;\r\n for I := 0 to Length(FHiddenControls) - 1 do\r\n FHiddenControls[I].Visible := True;\r\n FHiddenControls := nil;\r\n FAutoHintShown := False;\r\n end;\r\n end;\r\n\r\n procedure SetAutoHintShown;\r\n var\r\n I: Integer;\r\n begin\r\n if not FAutoHintShown then\r\n begin\r\n Panels.BeginUpdate;\r\n FHiddenControls := nil;\r\n for I := 0 to ControlCount - 1 do\r\n if Controls[I].Visible then\r\n begin\r\n SetLength(FHiddenControls, Length(FHiddenControls) + 1);\r\n FHiddenControls[Length(FHiddenControls) - 1] := Controls[I];\r\n FHiddenControls[I].Visible := False;\r\n end;\r\n FAutoHintShown := True;\r\n end;\r\n end;\r\n\r\nbegin\r\n if AutoHint and (Action is THintAction) and not DoHint then\r\n begin\r\n HintText := Trim(THintAction(Action).Hint);\r\n if Length(HintText) = 0 then\r\n CancelAutoHintShown\r\n else\r\n begin\r\n SetAutoHintShown;\r\n PanelEdges := -1;\r\n Flags := SBT_NOBORDERS;\r\n if UseRightToLeftReading then\r\n Flags := Flags or SBT_RTLREADING;\r\n SendMessage(Handle, SB_SETPARTS, 1, LPARAM(@PanelEdges));\r\n SendMessage(Handle, SB_SETTEXT, Flags, LPARAM(PChar(HintText)));\r\n // (rom) may need VisualCLX part here\r\n end;\r\n Result := True;\r\n end\r\n else\r\n begin\r\n CancelAutoHintShown;\r\n Result := inherited ExecuteAction(Action);\r\n end;\r\nend;\r\n\r\nprocedure TJvStatusBar.Notification(AComponent: TComponent; Operation: TOperation);\r\nvar\r\n I: Integer;\r\nbegin\r\n inherited Notification(AComponent, Operation);\r\n if (Operation = opRemove) and not (csDestroying in ComponentState) then\r\n for I := 0 to Panels.Count - 1 do\r\n begin\r\n if TJvStatusPanel(Panels[I]).Control = AComponent then\r\n TJvStatusPanel(Panels[I]).Control := nil;\r\n end;\r\nend;\r\n\r\nprocedure TJvStatusBar.MovePanelControls;\r\nvar\r\n I, ALeft: Integer;\r\n TmpPanel: TJvStatusPanel;\r\nbegin\r\n ALeft := 0;\r\n for I := 0 to Panels.Count - 1 do\r\n begin\r\n TmpPanel := TJvStatusPanel(Panels[I]);\r\n if TmpPanel.Control <> nil then\r\n with TmpPanel do\r\n Control.SetBounds(ALeft + MarginLeft, MarginTop, Control.Width, Control.Height);\r\n Inc(ALeft, TJvStatusPanel(Panels[I]).Width);\r\n end;\r\nend;\r\n\r\nfunction TJvStatusBar.GetPanelClass: TStatusPanelClass;\r\nbegin\r\n Result := TJvStatusPanel;\r\nend;\r\n\r\nprocedure TJvStatusBar.SBSetParts(var msg: TMessage);\r\nbegin\r\n inherited;\r\n MovePanelControls;\r\nend;\r\n\r\n{$IFDEF COMPILER16_UP}\r\nprocedure TJvStatusBar.WndProc(var Msg: TMessage);\r\nvar\r\n DC, PaintDC: HDC;\r\n Buffer: TBitmap;\r\n PS: TPaintStruct;\r\nbegin\r\n // TStatusBarStyleHook.Paint catches all WM_PAINT but doesn't call Control.PaintControls()\r\n // what causes TGraphicControls to not be painted. With this code we call the PaintControls\r\n // function in that case.\r\n // TODO: When this bug gets fixed in a later Delphi version, the IFDEFs must be adjusted.\r\n if (Msg.Msg = WM_PAINT) and StyleServices.Enabled and not StyleServices.IsSystemStyle then\r\n begin\r\n DC := HDC(Msg.WParam);\r\n if DoubleBuffered and (DC = 0) then\r\n begin\r\n PaintDC := BeginPaint(Handle, PS);\r\n try\r\n Buffer := TBitmap.Create;\r\n try\r\n Buffer.SetSize(Width, Height);\r\n Msg.WParam := WPARAM(Buffer.Canvas.Handle);\r\n inherited WndProc(Msg);\r\n Msg.WParam := WPARAM(DC);\r\n PaintControls(Buffer.Canvas.Handle, nil);\r\n BitBlt(PaintDC, 0, 0, Buffer.Width, Buffer.Height, Buffer.Canvas.Handle, 0, 0, SRCCOPY);\r\n finally\r\n Buffer.Free;\r\n end;\r\n finally\r\n EndPaint(Handle, PS);\r\n end;\r\n end\r\n else\r\n begin\r\n if DC <> 0 then\r\n PaintDC := DC\r\n else\r\n PaintDC := BeginPaint(Handle, PS);\r\n try\r\n Msg.WParam := WPARAM(PaintDC);\r\n inherited WndProc(Msg);\r\n Msg.WParam := WPARAM(DC);\r\n PaintControls(PaintDC, nil);\r\n finally\r\n if DC = 0 then\r\n EndPaint(Handle, PS);\r\n end;\r\n end;\r\n end\r\n else\r\n inherited WndProc(Msg);\r\nend;\r\n{$ENDIF COMPILER16_UP}\r\n\r\n//=== { TJvStatusPanel } =====================================================\r\n\r\ntype\r\n TStatusPanelsAccessProtected = class(TStatusPanels);\r\n\r\nconstructor TJvStatusPanel.Create(Collection: TCollection);\r\nbegin\r\n inherited Create(Collection);\r\n FMarginLeft := 3;\r\n FMarginTop := 3;\r\nend;\r\n\r\ndestructor TJvStatusPanel.Destroy;\r\nbegin\r\n Control := nil;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvStatusPanel.Changed(AllItems: Boolean);\r\nbegin\r\n inherited Changed(AllItems);\r\n (TStatusPanelsAccessProtected(Collection).GetOwner as TJvStatusBar).MovePanelControls;\r\nend;\r\n\r\nprocedure TJvStatusPanel.SetControl(const Value: TControl);\r\nvar\r\n S: TJvStatusBar;\r\nbegin\r\n S := TStatusPanelsAccessProtected(Collection).Owner as TJvStatusBar;\r\n ReplaceComponentReference(S, Value, TComponent(FControl));\r\n if FControl <> nil then\r\n begin\r\n if FControl = S then\r\n begin\r\n FControl := nil; // discard new control\r\n raise EJVCLException.CreateRes(@RsEInvalidControlSelection);\r\n end;\r\n FControl.Parent := S;\r\n FControl.Height := S.ClientHeight - 4;\r\n end;\r\n Changed(False);\r\nend;\r\n\r\nprocedure TJvStatusPanel.SetMarginLeft(const Value: Integer);\r\nbegin\r\n if FMarginLeft <> Value then\r\n begin\r\n FMarginLeft := Value;\r\n Changed(False);\r\n end;\r\nend;\r\n\r\nprocedure TJvStatusPanel.SetMarginTop(const Value: Integer);\r\nbegin\r\n if FMarginTop <> Value then\r\n begin\r\n FMarginTop := Value;\r\n Changed(False);\r\n end;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvStdEditActions.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvStdEditActions.PAS, released on 2008-11-02\r\n\r\nThe Initial Developers of the Original Code are: Andreas Hausladen \r\nCopyright (c) 2008 Andreas Hausladen\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvStdEditActions.pas 12699 2010-02-24 17:31:44Z ahuser $\r\n\r\nunit JvStdEditActions;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n Windows, SysUtils, Classes, Controls, Forms, ActnList, StdCtrls, Clipbrd;\r\n\r\ntype\r\n { The JVCL Edit standard actions automatically support a TWinControl that\r\n implements the IStandardEditActions interface. }\r\n IStandardEditActions = interface\r\n ['{38A87FE4-A1F4-4D47-A882-F7A3F9458264}']\r\n function CanUndo: Boolean;\r\n function CanRedo: Boolean; // not used at the moment\r\n function CanCut: Boolean;\r\n function CanCopy: Boolean;\r\n function CanPaste: Boolean;\r\n function CanSelectAll: Boolean;\r\n\r\n procedure Undo;\r\n procedure Redo; // not used at the moment\r\n procedure Cut;\r\n procedure Copy;\r\n procedure Paste;\r\n procedure ClearSelection; // deletes the selected text\r\n procedure SelectAll;\r\n end;\r\n\r\n { Standard Editor actions }\r\n\r\n TJvEditAction = class(TAction)\r\n private\r\n FControl: TWinControl;\r\n procedure SetControl(Value: TWinControl);\r\n protected\r\n function SupportsControl(Value: TWinControl): Boolean; virtual;\r\n function GetEditControl(Target: TObject): TCustomEdit; virtual;\r\n procedure Notification(AComponent: TComponent; Operation: TOperation); override;\r\n public\r\n destructor Destroy; override;\r\n function HandlesTarget(Target: TObject): Boolean; override;\r\n\r\n property Control: TWinControl read FControl write SetControl;\r\n end;\r\n\r\n TJvEditCut = class(TJvEditAction)\r\n public\r\n procedure ExecuteTarget(Target: TObject); override;\r\n procedure UpdateTarget(Target: TObject); override;\r\n end;\r\n\r\n TJvEditCopy = class(TJvEditAction)\r\n public\r\n procedure ExecuteTarget(Target: TObject); override;\r\n procedure UpdateTarget(Target: TObject); override;\r\n end;\r\n\r\n TJvEditPaste = class(TJvEditAction)\r\n public\r\n procedure ExecuteTarget(Target: TObject); override;\r\n procedure UpdateTarget(Target: TObject); override;\r\n end;\r\n\r\n TJvEditSelectAll = class(TJvEditAction)\r\n public\r\n procedure ExecuteTarget(Target: TObject); override;\r\n procedure UpdateTarget(Target: TObject); override;\r\n end;\r\n\r\n TJvEditUndo = class(TJvEditAction)\r\n public\r\n procedure ExecuteTarget(Target: TObject); override;\r\n procedure UpdateTarget(Target: TObject); override;\r\n end;\r\n\r\n TJvEditDelete = class(TJvEditAction)\r\n public\r\n procedure ExecuteTarget(Target: TObject); override;\r\n { UpdateTarget is required because TJvEditAction.UpdateTarget specifically\r\n checks to see if the action is TEditCut or TJvEditCopy }\r\n procedure UpdateTarget(Target: TObject); override;\r\n end;\r\n\r\n\r\nimplementation\r\n\r\nuses\r\n JvJVCLUtils;\r\n\r\n//=== { TJvEditAction } ==========================================================\r\n\r\ntype\r\n {$IFDEF COMPILER9_UP}\r\n TOpenCustomEdit = TCustomEdit;\r\n {$ELSE}\r\n TOpenCustomEdit = class(TCustomEdit);\r\n {$ENDIF COMPILER9_UP}\r\n\r\ndestructor TJvEditAction.Destroy;\r\nbegin\r\n if FControl <> nil then\r\n FControl.RemoveFreeNotification(Self);\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJvEditAction.GetEditControl(Target: TObject): TCustomEdit;\r\nbegin\r\n Result := Target as TCustomEdit;\r\nend;\r\n\r\nfunction TJvEditAction.HandlesTarget(Target: TObject): Boolean;\r\nbegin\r\n Result := ((Control <> nil) and (Target = Control) or\r\n (Control = nil) and (Target is TWinControl) and SupportsControl(TWinControl(Target))) and\r\n TWinControl(Target).Focused;\r\nend;\r\n\r\nprocedure TJvEditAction.Notification(AComponent: TComponent; Operation: TOperation);\r\nbegin\r\n inherited Notification(AComponent, Operation);\r\n if (Operation = opRemove) and (AComponent = Control) then\r\n Control := nil;\r\nend;\r\n\r\nprocedure TJvEditAction.SetControl(Value: TWinControl);\r\nbegin\r\n if Value <> FControl then\r\n begin\r\n if not SupportsControl(Value) then\r\n Value := nil;\r\n ReplaceComponentReference(Self, Value, TComponent(FControl));\r\n end;\r\nend;\r\n\r\nfunction TJvEditAction.SupportsControl(Value: TWinControl): Boolean;\r\nbegin\r\n Result := (Value is TCustomEdit) or Supports(Value, IStandardEditActions);\r\nend;\r\n\r\n//=== { TJvEditCopy } ==========================================================\r\n\r\nprocedure TJvEditCopy.ExecuteTarget(Target: TObject);\r\nvar\r\n Intf: IStandardEditActions;\r\nbegin\r\n if Supports(Target, IStandardEditActions, Intf) then\r\n Intf.Copy\r\n else if Target is TCustomEdit then\r\n GetEditControl(Target).CopyToClipboard;\r\nend;\r\n\r\nprocedure TJvEditCopy.UpdateTarget(Target: TObject);\r\nvar\r\n Intf: IStandardEditActions;\r\nbegin\r\n if Supports(Target, IStandardEditActions, Intf) then\r\n Enabled := Intf.CanCopy\r\n else if Target is TCustomEdit then\r\n Enabled := (GetEditControl(Target).SelLength > 0);\r\nend;\r\n\r\n//=== { TJvEditCut } ==========================================================\r\n\r\nprocedure TJvEditCut.ExecuteTarget(Target: TObject);\r\nvar\r\n Intf: IStandardEditActions;\r\nbegin\r\n if Supports(Target, IStandardEditActions, Intf) then\r\n Intf.Cut\r\n else if Target is TCustomEdit then\r\n GetEditControl(Target).CutToClipboard;\r\nend;\r\n\r\nprocedure TJvEditCut.UpdateTarget(Target: TObject);\r\nvar\r\n Intf: IStandardEditActions;\r\nbegin\r\n if Supports(Target, IStandardEditActions, Intf) then\r\n Enabled := Intf.CanCut\r\n else if Target is TCustomEdit then\r\n Enabled := (GetEditControl(Target).SelLength > 0) and not TOpenCustomEdit(GetEditControl(Target)).ReadOnly;\r\nend;\r\n\r\n//=== { TJvEditPaste } ==========================================================\r\n\r\nprocedure TJvEditPaste.ExecuteTarget(Target: TObject);\r\nvar\r\n Intf: IStandardEditActions;\r\nbegin\r\n if Supports(Target, IStandardEditActions, Intf) then\r\n Intf.Paste\r\n else if Target is TCustomEdit then\r\n GetEditControl(Target).PasteFromClipboard;\r\nend;\r\n\r\nprocedure TJvEditPaste.UpdateTarget(Target: TObject);\r\nvar\r\n Intf: IStandardEditActions;\r\nbegin\r\n if Supports(Target, IStandardEditActions, Intf) then\r\n Enabled := Intf.CanPaste\r\n else if Target is TCustomEdit then\r\n Enabled := Clipboard.HasFormat(CF_TEXT) and not TOpenCustomEdit(GetEditControl(Target)).ReadOnly;\r\nend;\r\n\r\n//=== { TJvEditSelectAll } ==========================================================\r\n\r\nprocedure TJvEditSelectAll.ExecuteTarget(Target: TObject);\r\nvar\r\n Intf: IStandardEditActions;\r\nbegin\r\n if Supports(Target, IStandardEditActions, Intf) then\r\n Intf.SelectAll\r\n else if Target is TCustomEdit then\r\n GetEditControl(Target).SelectAll;\r\nend;\r\n\r\nprocedure TJvEditSelectAll.UpdateTarget(Target: TObject);\r\nvar\r\n Intf: IStandardEditActions;\r\nbegin\r\n if Supports(Target, IStandardEditActions, Intf) then\r\n Enabled := Intf.CanSelectAll\r\n else if Target is TCustomEdit then\r\n Enabled := Length(GetEditControl(Target).Text) > 0;\r\nend;\r\n\r\n//=== { TJvEditUndo } ==========================================================\r\n\r\nprocedure TJvEditUndo.ExecuteTarget(Target: TObject);\r\nvar\r\n Intf: IStandardEditActions;\r\nbegin\r\n if Supports(Target, IStandardEditActions, Intf) then\r\n Intf.Undo\r\n else if Target is TCustomEdit then\r\n GetEditControl(Target).Undo;\r\nend;\r\n\r\nprocedure TJvEditUndo.UpdateTarget(Target: TObject);\r\nvar\r\n Intf: IStandardEditActions;\r\nbegin\r\n if Supports(Target, IStandardEditActions, Intf) then\r\n Enabled := Intf.CanUndo\r\n else if Target is TCustomEdit then\r\n Enabled := GetEditControl(Target).CanUndo and not TOpenCustomEdit(GetEditControl(Target)).ReadOnly;\r\nend;\r\n\r\n//=== { TJvEditDelete } ==========================================================\r\n\r\nprocedure TJvEditDelete.ExecuteTarget(Target: TObject);\r\nvar\r\n Intf: IStandardEditActions;\r\nbegin\r\n if Supports(Target, IStandardEditActions, Intf) then\r\n Intf.ClearSelection\r\n else if Target is TCustomEdit then\r\n GetEditControl(Target).ClearSelection;\r\nend;\r\n\r\nprocedure TJvEditDelete.UpdateTarget(Target: TObject);\r\nvar\r\n Intf: IStandardEditActions;\r\nbegin\r\n if Supports(Target, IStandardEditActions, Intf) then\r\n Enabled := Intf.CanCut\r\n else if Target is TCustomEdit then\r\n Enabled := (GetEditControl(Target).SelLength > 0) and not TOpenCustomEdit(GetEditControl(Target)).ReadOnly;\r\nend;\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvSticker.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvSticker.PAS, released on 2002-06-15.\r\n\r\nThe Initial Developer of the Original Code is Jan Verhoeven [jan1 dott verhoeven att wxs dott nl]\r\nPortions created by Jan Verhoeven are Copyright (C) 2002 Jan Verhoeven.\r\nAll Rights Reserved.\r\n\r\nContributor(s): Robert Love [rlove att slcdug dott org].\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvSticker.pas 13104 2011-09-07 06:50:43Z obones $\r\n\r\nunit JvSticker;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, Messages, SysUtils, Classes, Graphics, Controls, StdCtrls, Forms,\r\n JvComponent;\r\n\r\ntype\r\n TRectList = array [1..8] of TRect;\r\n \r\n TJvStickSizer = class(TJvCustomControl)\r\n private\r\n FControl: TControl;\r\n FRectList: TRectList;\r\n procedure WMNCHitTest(var Msg: TWMNCHitTest); message WM_NCHITTEST;\r\n procedure WMLButtonDown(var Msg: TWMLButtonDown); message WM_LBUTTONDOWN;\r\n procedure WMMove(var Msg: TWMMove); message WM_MOVE;\r\n protected\r\n procedure BoundsChanged; override;\r\n public\r\n constructor CreateEx(AOwner: TComponent; AControl: TControl);\r\n procedure CreateParams(var Params: TCreateParams); override;\r\n procedure CreateHandle; override;\r\n procedure Paint; override;\r\n procedure SizerControlExit(Sender: TObject);\r\n end;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvSticker = class(TJvGraphicControl)\r\n private\r\n FStickColor: TColor;\r\n procedure SetStickColor(const Value: TColor);\r\n function CaptionDialog(S: string): string;\r\n protected\r\n procedure FontChanged; override;\r\n procedure TextChanged; override;\r\n procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;\r\n procedure MouseEnter(Control: TControl); override;\r\n procedure MouseLeave(Control: TControl); override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n procedure Paint; override;\r\n published\r\n property StickColor: TColor read FStickColor write SetStickColor default clYellow;\r\n property Align;\r\n property Caption;\r\n property Font;\r\n property Height default 65;\r\n property PopupMenu;\r\n property Width default 65;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvSticker.pas $';\r\n Revision: '$Revision: 13104 $';\r\n Date: '$Date: 2011-09-07 08:50:43 +0200 (mer. 07 sept. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n Dialogs,\r\n JvConsts, JvResources, JvWin32;\r\n\r\n//=== { TJvStickSizer } ======================================================\r\n\r\nconst\r\n cPosList: array [1..8] of Integer =\r\n (HTTOPLEFT, HTTOP, HTTOPRIGHT, HTRIGHT,\r\n HTBOTTOMRIGHT, HTBOTTOM, HTBOTTOMLEFT, HTLEFT);\r\n\r\nconstructor TJvStickSizer.CreateEx(AOwner: TComponent; AControl: TControl);\r\nvar\r\n R: TRect;\r\nbegin\r\n inherited Create(AOwner);\r\n FControl := AControl;\r\n // install the new handler\r\n OnExit := SizerControlExit;\r\n // set the size and position\r\n R := FControl.BoundsRect;\r\n InflateRect(R, 2, 2);\r\n BoundsRect := R;\r\n // set the parent\r\n Parent := FControl.Parent;\r\n // Create the list of positions\r\nend;\r\n\r\nprocedure TJvStickSizer.CreateHandle;\r\nbegin\r\n inherited CreateHandle;\r\n SetFocus;\r\nend;\r\n\r\nprocedure TJvStickSizer.CreateParams(var Params: TCreateParams);\r\nbegin\r\n inherited CreateParams(Params);\r\n Params.ExStyle := Params.ExStyle or WS_EX_TRANSPARENT;\r\nend;\r\n\r\nprocedure TJvStickSizer.Paint;\r\nvar\r\n I: Integer;\r\nbegin\r\n Canvas.Brush.Color := clBlack;\r\n for I := Low(FRectList) to High(FRectList) do\r\n Canvas.Rectangle(FRectList[I]);\r\nend;\r\n\r\nprocedure TJvStickSizer.WMNCHitTest(var Msg: TWMNCHitTest);\r\nvar\r\n Pt: TPoint;\r\n I: Integer;\r\nbegin\r\n Pt := Point(Msg.XPos, Msg.YPos);\r\n Pt := ScreenToClient(Pt);\r\n Msg.Result := 0;\r\n for I := Low(FRectList) to High(FRectList) do\r\n if PtInRect(FRectList[I], Pt) then\r\n Msg.Result := cPosList[I];\r\n // if the return value was not set\r\n if Msg.Result = 0 then\r\n inherited;\r\nend;\r\n\r\nprocedure TJvStickSizer.BoundsChanged;\r\nvar\r\n R: TRect;\r\nbegin\r\n R := BoundsRect;\r\n InflateRect(R, -2, -2);\r\n FControl.BoundsRect := R;\r\n // setup data structures\r\n FRectList[1] := Rect(0, 0, 5, 5);\r\n FRectList[2] := Rect(Width div 2 - 3, 0, Width div 2 + 2, 5);\r\n FRectList[3] := Rect(Width - 5, 0, Width, 5);\r\n FRectList[4] := Rect(Width - 5, Height div 2 - 3, Width, Height div 2 + 2);\r\n FRectList[5] := Rect(Width - 5, Height - 5, Width, Height);\r\n FRectList[6] := Rect(Width div 2 - 3, Height - 5, Width div 2 + 2, Height);\r\n FRectList[7] := Rect(0, Height - 5, 5, Height);\r\n FRectList[8] := Rect(0, Height div 2 - 3, 5, Height div 2 + 2);\r\nend;\r\n\r\nprocedure TJvStickSizer.SizerControlExit(Sender: TObject);\r\nbegin\r\n Free;\r\nend;\r\n\r\nprocedure TJvStickSizer.WMLButtonDown(var Msg: TWMLButtonDown);\r\nbegin\r\n Perform(WM_SYSCOMMAND, SC_DRAGMOVE, 0);\r\nend;\r\n\r\nprocedure TJvStickSizer.WMMove(var Msg: TWMMove);\r\nvar\r\n R: TRect;\r\nbegin\r\n R := BoundsRect;\r\n InflateRect(R, -2, -2);\r\n FControl.Invalidate; // repaint entire surface\r\n FControl.BoundsRect := R;\r\nend;\r\n\r\n//=== { TJvSticker } =========================================================\r\n\r\nconstructor TJvSticker.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n Width := 65;\r\n Height := 65;\r\n FStickColor := clYellow;\r\nend;\r\n\r\nprocedure TJvSticker.FontChanged;\r\nbegin\r\n inherited FontChanged;\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvSticker.MouseEnter(Control: TControl);\r\nbegin\r\n if csDesigning in ComponentState then\r\n Exit;\r\n // Cursor := crHandPoint;\r\n inherited MouseEnter(Control);\r\nend;\r\n\r\nprocedure TJvSticker.MouseLeave(Control: TControl);\r\nbegin\r\n if csDesigning in ComponentState then\r\n Exit;\r\n Cursor := crDefault;\r\n inherited MouseLeave(Control);\r\nend;\r\n\r\nprocedure TJvSticker.TextChanged;\r\nbegin\r\n inherited TextChanged;\r\n Invalidate;\r\nend;\r\n\r\nfunction TJvSticker.CaptionDialog(S: string): string;\r\nvar\r\n Form: TJvForm;\r\n Memo: TMemo;\r\nbegin\r\n Result := '';\r\n Form := TJvForm.Create(Self);\r\n try\r\n Form.Width := 350;\r\n Form.Height := 200;\r\n Form.BorderStyle := bsDialog;\r\n Form.Caption := RsEditStickerCaption;\r\n Memo := TMemo.Create(Form);\r\n with Memo do\r\n begin\r\n Align := alClient;\r\n Font.Size := 10;\r\n ScrollBars := ssVertical;\r\n Text := S;\r\n Parent := Form;\r\n end;\r\n Form.Position := poDesktopCenter;\r\n Form.ShowModal;\r\n Result := Memo.Text;\r\n finally\r\n Form.Free;\r\n end;\r\nend;\r\n\r\nprocedure TJvSticker.MouseDown(Button: TMouseButton; Shift: TShiftState;\r\n X, Y: Integer);\r\nvar\r\n H3: Integer;\r\nbegin\r\n inherited MouseDown(Button, Shift, X, Y);\r\n H3 := Height div 3;\r\n if (Button = mbLeft) and (PtInRect(Rect(0, 0, 20, H3), Point(X, Y))) then\r\n with TJvStickSizer.CreateEx(Self.Parent, TControl(Self)) do\r\n Parent := Self.Parent\r\n else\r\n if (Button = mbLeft) and (PtInRect(Rect(0, H3, 20, 2 * H3), Point(X, Y))) then\r\n Caption := CaptionDialog(Caption)\r\n else\r\n if (Button = mbLeft) and (PtInRect(Rect(0, 2 * H3, 20, ClientHeight), Point(X, Y))) then\r\n with TColorDialog.Create(Self) do\r\n begin\r\n Color := FStickColor;\r\n if Execute then\r\n StickColor := Color;\r\n Free;\r\n end\r\n else\r\n inherited MouseDown(Button, Shift, X, Y);\r\nend;\r\n\r\nprocedure TJvSticker.Paint;\r\nvar\r\n R: TRect;\r\n S: string;\r\n H3: Integer;\r\n I: Integer;\r\nbegin\r\n inherited Paint;\r\n H3 := Height div 3;\r\n Canvas.Brush.Color := StickColor;\r\n Canvas.FillRect(Rect(15, 0, Width, Height));\r\n // draw grips\r\n Canvas.Brush.Color := clSilver;\r\n Canvas.FillRect(Rect(0, 0, 15, Height));\r\n // size grip\r\n for I := 1 to 4 do\r\n begin\r\n Canvas.Pen.Color := clWhite;\r\n Canvas.MoveTo(I * 3, 3);\r\n Canvas.LineTo(I * 3, H3 - 2);\r\n Canvas.Pen.Color := clBtnShadow;\r\n Canvas.MoveTo(I * 3 + 1, 3);\r\n Canvas.LineTo(I * 3 + 1, H3 - 2);\r\n end;\r\n // edit grip\r\n for I := 1 to 4 do\r\n begin\r\n Canvas.Pen.Color := clWhite;\r\n Canvas.MoveTo(I * 3, H3 + 2);\r\n Canvas.LineTo(I * 3, 2 * H3 - 2);\r\n Canvas.Pen.Color := clNavy;\r\n Canvas.MoveTo(I * 3 + 1, H3 + 2);\r\n Canvas.LineTo(I * 3 + 1, 2 * H3 - 2);\r\n end;\r\n // Color grip\r\n for I := 1 to 4 do\r\n begin\r\n Canvas.Pen.Color := clWhite;\r\n Canvas.MoveTo(I * 3, 2 * H3 + 2);\r\n Canvas.LineTo(I * 3, Height - 3);\r\n Canvas.Pen.Color := clMaroon;\r\n Canvas.MoveTo(I * 3 + 1, 2 * H3 + 2);\r\n Canvas.LineTo(I * 3 + 1, Height - 3);\r\n end;\r\n R := Rect(15, 0, Width, Height);\r\n S := Caption;\r\n Canvas.Brush.Style := bsClear;\r\n Canvas.Font.Assign(Font);\r\n DrawText(Canvas.Handle, PChar(S), -1, R, DT_WORDBREAK);\r\nend;\r\n\r\nprocedure TJvSticker.SetStickColor(const Value: TColor);\r\nbegin\r\n if FStickColor <> Value then\r\n begin\r\n FStickColor := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend." }, { "path": "External/Jedi/Jvcl/run/JvStrToHtml.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvStrToHtml.PAS, released on 2001-02-28.\r\n\r\nThe Initial Developer of the Original Code is Sbastien Buysse [sbuysse att buypin dott com]\r\nPortions created by Sbastien Buysse are Copyright (C) 2001 Sbastien Buysse.\r\nAll Rights Reserved.\r\n\r\nContributor(s): Michael Beck [mbeck att bigfoot dott com].\r\n Andreas Hausladen [Andreas dott Hausladen att gmx dott de]\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvStrToHtml.pas 13104 2011-09-07 06:50:43Z obones $\r\n\r\nunit JvStrToHtml;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n SysUtils, Classes,\r\n JvComponentBase;\r\n\r\ntype\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64 or pidOSX32)]\r\n {$ENDIF RTL230_UP}\r\n TJvStrToHtml = class(TJvComponent)\r\n private\r\n FHtml: string;\r\n FValue: string;\r\n procedure SetHtml(const Value: string);\r\n procedure SetValue(const Value: string);\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n function TextToHtml(const Text: string): string;\r\n function HtmlToText(const Text: string): string;\r\n published\r\n property Text: string read FValue write SetValue;\r\n property Html: string read FHtml write SetHtml;\r\n end;\r\n\r\nfunction StringToHtml(const Value: string): string;\r\nfunction HtmlToString(const Value: string): string;\r\nfunction CharToHtml(Ch: Char): string;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvStrToHtml.pas $';\r\n Revision: '$Revision: 13104 $';\r\n Date: '$Date: 2011-09-07 08:50:43 +0200 (mer. 07 sept. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\n{$IFNDEF UNICODE}\r\nuses\r\n Windows;\r\n{$ENDIF ~UNICODE}\r\n\r\ntype\r\n TJvHtmlCodeRec = record\r\n Ch: Word;\r\n Html: string;\r\n end;\r\n\r\nconst\r\n { References:\r\n http://www.w3.org/TR/REC-html40/charset.html#h-5.3\r\n http://www.w3.org/TR/REC-html40/sgml/entities.html#h-24.2.1\r\n http://www.w3.org/TR/REC-html40/sgml/entities.html#h-24.4.1\r\n }\r\n Conversions: array [0..240] of TJvHtmlCodeRec = (\r\n (Ch: 34; Html: '"'),\r\n (Ch: 38; Html: '&'),\r\n (Ch: 39; Html: '''),\r\n (Ch: 60; Html: '<'),\r\n (Ch: 62; Html: '>'),\r\n (Ch: 160; Html: ' '),\r\n (Ch: 161; Html: '¡'),\r\n (Ch: 162; Html: '¢'),\r\n (Ch: 163; Html: '£'),\r\n (Ch: 164; Html: '¤'),\r\n (Ch: 165; Html: '¥'),\r\n (Ch: 166; Html: '¦'),\r\n (Ch: 167; Html: '§'),\r\n (Ch: 168; Html: '¨'),\r\n (Ch: 169; Html: '©'),\r\n (Ch: 170; Html: 'ª'),\r\n (Ch: 171; Html: '«'),\r\n (Ch: 172; Html: '¬'),\r\n (Ch: 173; Html: '­'),\r\n (Ch: 174; Html: '®'),\r\n (Ch: 175; Html: '¯'),\r\n (Ch: 176; Html: '°'),\r\n (Ch: 177; Html: '±'),\r\n (Ch: 178; Html: '²'),\r\n (Ch: 179; Html: '³'),\r\n (Ch: 180; Html: '´'),\r\n (Ch: 181; Html: 'µ'),\r\n (Ch: 182; Html: '¶'),\r\n (Ch: 183; Html: '·'),\r\n (Ch: 184; Html: '¸'),\r\n (Ch: 185; Html: '¹'),\r\n (Ch: 186; Html: 'º'),\r\n (Ch: 187; Html: '»'),\r\n (Ch: 188; Html: '¼'),\r\n (Ch: 189; Html: '½'),\r\n (Ch: 190; Html: '¾'),\r\n (Ch: 191; Html: '¿'),\r\n (Ch: 192; Html: 'À'),\r\n (Ch: 193; Html: 'Á'),\r\n (Ch: 194; Html: 'Â'),\r\n (Ch: 195; Html: 'Ã'),\r\n (Ch: 196; Html: 'Ä'),\r\n (Ch: 197; Html: 'Å'),\r\n (Ch: 198; Html: 'Æ'),\r\n (Ch: 199; Html: 'Ç'),\r\n (Ch: 200; Html: 'È'),\r\n (Ch: 201; Html: 'É'),\r\n (Ch: 202; Html: 'Ê'),\r\n (Ch: 203; Html: 'Ë'),\r\n (Ch: 204; Html: 'Ì'),\r\n (Ch: 205; Html: 'Í'),\r\n (Ch: 206; Html: 'Î'),\r\n (Ch: 207; Html: 'Ï'),\r\n (Ch: 208; Html: 'Ð'),\r\n (Ch: 209; Html: 'Ñ'),\r\n (Ch: 210; Html: 'Ò'),\r\n (Ch: 211; Html: 'Ó'),\r\n (Ch: 212; Html: 'Ô'),\r\n (Ch: 213; Html: 'Õ'),\r\n (Ch: 214; Html: 'Ö'),\r\n (Ch: 215; Html: '×'),\r\n (Ch: 216; Html: 'Ø'),\r\n (Ch: 217; Html: 'Ù'),\r\n (Ch: 218; Html: 'Ú'),\r\n (Ch: 219; Html: 'Û'),\r\n (Ch: 220; Html: 'Ü'),\r\n (Ch: 221; Html: 'Ý'),\r\n (Ch: 222; Html: 'Þ'),\r\n (Ch: 223; Html: 'ß'),\r\n (Ch: 224; Html: 'à'),\r\n (Ch: 225; Html: 'á'),\r\n (Ch: 226; Html: 'â'),\r\n (Ch: 227; Html: 'ã'),\r\n (Ch: 228; Html: 'ä'),\r\n (Ch: 229; Html: 'å'),\r\n (Ch: 230; Html: 'æ'),\r\n (Ch: 231; Html: 'ç'),\r\n (Ch: 232; Html: 'è'),\r\n (Ch: 233; Html: 'é'),\r\n (Ch: 234; Html: 'ê'),\r\n (Ch: 235; Html: 'ë'),\r\n (Ch: 236; Html: 'ì'),\r\n (Ch: 237; Html: 'í'),\r\n (Ch: 238; Html: 'î'),\r\n (Ch: 239; Html: 'ï'),\r\n (Ch: 240; Html: 'ð'),\r\n (Ch: 241; Html: 'ñ'),\r\n (Ch: 242; Html: 'ò'),\r\n (Ch: 243; Html: 'ó'),\r\n (Ch: 244; Html: 'ô'),\r\n (Ch: 245; Html: 'õ'),\r\n (Ch: 246; Html: 'ö'),\r\n (Ch: 247; Html: '÷'),\r\n (Ch: 248; Html: 'ø'),\r\n (Ch: 249; Html: 'ù'),\r\n (Ch: 250; Html: 'ú'),\r\n (Ch: 251; Html: 'û'),\r\n (Ch: 252; Html: 'ü'),\r\n (Ch: 253; Html: 'ý'),\r\n (Ch: 254; Html: 'þ'),\r\n (Ch: 255; Html: 'ÿ'),\r\n (Ch: 338; Html: 'Œ'),\r\n (Ch: 339; Html: 'œ'),\r\n (Ch: 352; Html: 'Š'),\r\n (Ch: 353; Html: 'š'),\r\n (Ch: 376; Html: 'Ÿ'),\r\n (Ch: 402; Html: 'ƒ'),\r\n (Ch: 710; Html: 'ˆ'),\r\n (Ch: 732; Html: '˜'),\r\n (Ch: 913; Html: 'Α'),\r\n (Ch: 914; Html: 'Β'),\r\n (Ch: 915; Html: 'Γ'),\r\n (Ch: 916; Html: 'Δ'),\r\n (Ch: 917; Html: 'Ε'),\r\n (Ch: 918; Html: 'Ζ'),\r\n (Ch: 919; Html: 'Η'),\r\n (Ch: 920; Html: 'Θ'),\r\n (Ch: 921; Html: 'Ι'),\r\n (Ch: 922; Html: 'Κ'),\r\n (Ch: 923; Html: 'Λ'),\r\n (Ch: 924; Html: 'Μ'),\r\n (Ch: 925; Html: 'Ν'),\r\n (Ch: 926; Html: 'Ξ'),\r\n (Ch: 927; Html: 'Ο'),\r\n (Ch: 928; Html: 'Π'),\r\n (Ch: 929; Html: 'Ρ'),\r\n (Ch: 931; Html: 'Σ'),\r\n (Ch: 932; Html: 'Τ'),\r\n (Ch: 933; Html: 'Υ'),\r\n (Ch: 934; Html: 'Φ'),\r\n (Ch: 935; Html: 'Χ'),\r\n (Ch: 936; Html: 'Ψ'),\r\n (Ch: 937; Html: 'Ω'),\r\n (Ch: 945; Html: 'α'),\r\n (Ch: 946; Html: 'β'),\r\n (Ch: 947; Html: 'γ'),\r\n (Ch: 948; Html: 'δ'),\r\n (Ch: 949; Html: 'ε'),\r\n (Ch: 950; Html: 'ζ'),\r\n (Ch: 951; Html: 'η'),\r\n (Ch: 952; Html: 'θ'),\r\n (Ch: 953; Html: 'ι'),\r\n (Ch: 954; Html: 'κ'),\r\n (Ch: 955; Html: 'λ'),\r\n (Ch: 956; Html: 'μ'),\r\n (Ch: 957; Html: 'ν'),\r\n (Ch: 958; Html: 'ξ'),\r\n (Ch: 959; Html: 'ο'),\r\n (Ch: 960; Html: 'π'),\r\n (Ch: 961; Html: 'ρ'),\r\n (Ch: 962; Html: 'ς'),\r\n (Ch: 963; Html: 'σ'),\r\n (Ch: 964; Html: 'τ'),\r\n (Ch: 965; Html: 'υ'),\r\n (Ch: 966; Html: 'φ'),\r\n (Ch: 967; Html: 'χ'),\r\n (Ch: 968; Html: 'ψ'),\r\n (Ch: 969; Html: 'ω'),\r\n (Ch: 977; Html: 'ϑ'),\r\n (Ch: 978; Html: 'ϒ'),\r\n (Ch: 982; Html: 'ϖ'),\r\n (Ch: 8194; Html: ' '),\r\n (Ch: 8195; Html: ' '),\r\n (Ch: 8201; Html: ' '),\r\n (Ch: 8204; Html: '‌'),\r\n (Ch: 8205; Html: '‍'),\r\n (Ch: 8206; Html: '‎'),\r\n (Ch: 8207; Html: '‏'),\r\n (Ch: 8211; Html: '–'),\r\n (Ch: 8212; Html: '—'),\r\n (Ch: 8216; Html: '‘'),\r\n (Ch: 8217; Html: '’'),\r\n (Ch: 8218; Html: '‚'),\r\n (Ch: 8220; Html: '“'),\r\n (Ch: 8221; Html: '”'),\r\n (Ch: 8222; Html: '„'),\r\n (Ch: 8224; Html: '†'),\r\n (Ch: 8225; Html: '‡'),\r\n (Ch: 8226; Html: '•'),\r\n (Ch: 8230; Html: '…'),\r\n (Ch: 8240; Html: '‰'),\r\n (Ch: 8242; Html: '′'),\r\n (Ch: 8243; Html: '″'),\r\n (Ch: 8249; Html: '‹'),\r\n (Ch: 8250; Html: '›'),\r\n (Ch: 8254; Html: '‾'),\r\n (Ch: 8364; Html: '€'),\r\n (Ch: 8482; Html: '™'),\r\n (Ch: 8592; Html: '←'),\r\n (Ch: 8593; Html: '↑'),\r\n (Ch: 8594; Html: '→'),\r\n (Ch: 8595; Html: '↓'),\r\n (Ch: 8596; Html: '↔'),\r\n (Ch: 8629; Html: '↵'),\r\n (Ch: 8704; Html: '∀'),\r\n (Ch: 8706; Html: '∂'),\r\n (Ch: 8707; Html: '∃'),\r\n (Ch: 8709; Html: '∅'),\r\n (Ch: 8711; Html: '∇'),\r\n (Ch: 8712; Html: '∈'),\r\n (Ch: 8713; Html: '∉'),\r\n (Ch: 8715; Html: '∋'),\r\n (Ch: 8719; Html: '∏'),\r\n (Ch: 8721; Html: '∑'),\r\n (Ch: 8722; Html: '−'),\r\n (Ch: 8727; Html: '∗'),\r\n (Ch: 8730; Html: '√'),\r\n (Ch: 8733; Html: '∝'),\r\n (Ch: 8734; Html: '∞'),\r\n (Ch: 8736; Html: '∠'),\r\n (Ch: 8743; Html: '∧'),\r\n (Ch: 8744; Html: '∨'),\r\n (Ch: 8745; Html: '∩'),\r\n (Ch: 8746; Html: '∪'),\r\n (Ch: 8747; Html: '∫'),\r\n (Ch: 8756; Html: '∴'),\r\n (Ch: 8764; Html: '∼'),\r\n (Ch: 8773; Html: '≅'),\r\n (Ch: 8776; Html: '≈'),\r\n (Ch: 8800; Html: '≠'),\r\n (Ch: 8801; Html: '≡'),\r\n (Ch: 8804; Html: '≤'),\r\n (Ch: 8805; Html: '≥'),\r\n (Ch: 8834; Html: '⊂'),\r\n (Ch: 8835; Html: '⊃'),\r\n (Ch: 8836; Html: '⊄'),\r\n (Ch: 8838; Html: '⊆'),\r\n (Ch: 8839; Html: '⊇'),\r\n (Ch: 8853; Html: '⊕'),\r\n (Ch: 8855; Html: '⊗'),\r\n (Ch: 8869; Html: '⊥'),\r\n (Ch: 8901; Html: '⋅'),\r\n (Ch: 8968; Html: '⌈'),\r\n (Ch: 8969; Html: '⌉'),\r\n (Ch: 8970; Html: '⌊'),\r\n (Ch: 8971; Html: '⌋'),\r\n (Ch: 9674; Html: '◊'),\r\n (Ch: 9824; Html: '♠'),\r\n (Ch: 9827; Html: '♣'),\r\n (Ch: 9829; Html: '♥'),\r\n (Ch: 9830; Html: '♦')\r\n );\r\n\r\nvar\r\n ConversionsHash: array of Word;\r\n\r\n{$IFNDEF UNICODE}\r\nconst\r\n MB_ERR_INVALID_CHARS = 8;\r\n{$ENDIF ~UNICODE}\r\n\r\n{ TJvStrToHtml }\r\n\r\nconstructor TJvStrToHtml.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FValue := '';\r\n FHtml := '';\r\nend;\r\n\r\nfunction TJvStrToHtml.HtmlToText(const Text: string): string;\r\nbegin\r\n Result := HtmlToString(Text);\r\nend;\r\n\r\nprocedure TJvStrToHtml.SetHtml(const Value: string);\r\nbegin\r\n FValue := HtmlToText(Value);\r\nend;\r\n\r\nprocedure TJvStrToHtml.SetValue(const Value: string);\r\nbegin\r\n FHtml := TextToHtml(Value);\r\nend;\r\n\r\nfunction TJvStrToHtml.TextToHtml(const Text: string): string;\r\nbegin\r\n Result := StringToHtml(Text);\r\nend;\r\n\r\nfunction GetHtmlHash(const S: string): Word;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := Length(S);\r\n for I := 1 to Length(S) do\r\n Result := Word(Result + Ord(S[I]) shl (I mod 4));\r\nend;\r\n\r\nprocedure InitConversionsHash;\r\nvar\r\n I: Integer;\r\nbegin\r\n SetLength(ConversionsHash, Length(Conversions));\r\n for I := 0 to High(ConversionsHash) do\r\n ConversionsHash[I] := GetHtmlHash(Conversions[I].Html);\r\nend;\r\n\r\nfunction StringToHtml(const Value: string): string;\r\nconst\r\n Nbsp = ' ';\r\nvar\r\n I, J: Integer;\r\n Len, AddLen, HtmlLen: Integer;\r\n P: PChar;\r\n Ch: Char;\r\n W: Word;\r\nbegin\r\n Len := Length(Value);\r\n // number of chars to add\r\n AddLen := 0;\r\n for I := 1 to Len do\r\n begin\r\n Ch := Value[I];\r\n if Ch = ' ' then\r\n begin\r\n if (I > 1) and (Value[I - 1] = ' ') then\r\n Inc(AddLen, 5 {Length(Nbsp) - 1});\r\n end\r\n else\r\n if (Ch >= #128) or not (AnsiChar(Ch) in ['A'..'Z', 'a'..'z', '0'..'9', '_']) then\r\n begin\r\n W := Word(Ch);\r\n {$IFNDEF UNICODE}\r\n if W >= 128 then\r\n if MultiByteToWideChar(CP_ACP, MB_ERR_INVALID_CHARS, @Ch, 1, PWideChar(@W), 1) = 0 then\r\n W := Word(Ch);\r\n {$ENDIF ~UNICODE}\r\n for J := Low(Conversions) to High(Conversions) do\r\n if W = Conversions[J].Ch then\r\n begin\r\n Inc(AddLen, Length(Conversions[J].Html) - 1);\r\n Break;\r\n end;\r\n end;\r\n end;\r\n\r\n if AddLen = 0 then\r\n Result := Value\r\n else\r\n begin\r\n SetLength(Result, Len + AddLen);\r\n P := Pointer(Result);\r\n for I := 1 to Len do\r\n begin\r\n Ch := Value[I];\r\n if Ch = ' ' then\r\n begin\r\n if (I > 1) and (Value[I - 1] = ' ') then\r\n begin\r\n HtmlLen := 6 {Length(Nbsp)};\r\n Move(Nbsp[1], P[0], HtmlLen * SizeOf(Char));\r\n Inc(P, HtmlLen);\r\n Ch := #0;\r\n end;\r\n end\r\n else\r\n if (Ch >= #128) or not (AnsiChar(Ch) in ['A'..'Z', 'a'..'z', '0'..'9', '_']) then\r\n begin\r\n W := Word(Ch);\r\n {$IFNDEF UNICODE}\r\n if W >= 128 then\r\n if MultiByteToWideChar(CP_ACP, MB_ERR_INVALID_CHARS, @Ch, 1, PWideChar(@W), 1) = 0 then\r\n W := Word(Ch);\r\n {$ENDIF ~UNICODE}\r\n for J := Low(Conversions) to High(Conversions) do\r\n if W = Conversions[J].Ch then\r\n begin\r\n HtmlLen := Length(Conversions[J].Html);\r\n Move(Conversions[J].Html[1], P[0], HtmlLen * SizeOf(Char)); // Conversions[].Html is a PChar\r\n Inc(P, HtmlLen);\r\n Ch := #0;\r\n Break;\r\n end;\r\n end;\r\n if Ch <> #0 then\r\n begin\r\n P[0] := Ch;\r\n Inc(P);\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction HtmlToString(const Value: string): string;\r\nvar\r\n I, Index, Len: Integer;\r\n Start, J: Integer;\r\n Ch: Char;\r\n W, Hash: Word;\r\n ReplStr: string;\r\nbegin\r\n if ConversionsHash = nil then\r\n InitConversionsHash;\r\n\r\n Len := Length(Value);\r\n SetLength(Result, Len); // worst case\r\n Index := 0;\r\n I := 1;\r\n while I <= Len do\r\n begin\r\n Ch := Value[I];\r\n // html entitiy\r\n if Ch = '&' then\r\n begin\r\n Start := I;\r\n Inc(I);\r\n while (I <= Len) and (Value[I] <> ';') and (I < Start + 20) do\r\n Inc(I);\r\n if Value[I] <> ';' then\r\n I := Start\r\n else\r\n begin\r\n Ch := #0;\r\n ReplStr := Copy(Value, Start, I - Start + 1);\r\n if ReplStr = ' ' then // special treatment for  \r\n Ch := ' '\r\n else\r\n begin\r\n Hash := GetHtmlHash(ReplStr);\r\n J := 0;\r\n while (J < Length(Conversions)) do\r\n begin\r\n while (J < Length(Conversions)) and (ConversionsHash[J] <> Hash) do\r\n Inc(J);\r\n if (J < Length(Conversions)) and (Conversions[J].Html = ReplStr) then\r\n begin\r\n W := Conversions[J].Ch;\r\n Ch := Char(W);\r\n {$IFNDEF UNICODE}\r\n if W >= 128 then\r\n if WideCharToMultiByte(CP_ACP, MB_ERR_INVALID_CHARS, @W, 1, PAnsiChar(@Ch), 1, nil, nil) = 0 then\r\n Ch := Char(W);\r\n {$ENDIF ~UNICODE}\r\n Break;\r\n end;\r\n Inc(J);\r\n end;\r\n end;\r\n\r\n // if no conversion was found, it may actually be a number\r\n if Ch = #0 then\r\n begin\r\n ReplStr := Copy(ReplStr, 2, MaxInt);\r\n if ReplStr <> '' then\r\n begin\r\n if (ReplStr[1] = '#') and (Length(ReplStr) > 1) then\r\n begin\r\n Delete(ReplStr, 1, 1);\r\n if ReplStr[1] = 'x' then // hex value\r\n ReplStr[1] := '$'; // prepare for StrToInt\r\n end;\r\n if StrToIntDef(ReplStr, -1) <> -1 then\r\n Ch := Chr(StrToInt(ReplStr))\r\n else\r\n begin\r\n I := Start;\r\n Ch := Value[I];\r\n end;\r\n end;\r\n end;\r\n end;\r\n end;\r\n\r\n Inc(I);\r\n Inc(Index);\r\n Result[Index] := Ch;\r\n end;\r\n if Index <> Len then\r\n SetLength(Result, Index);\r\nend;\r\n\r\nfunction CharToHtml(Ch: Char): string;\r\nvar\r\n I: Integer;\r\n W: Word;\r\nbegin\r\n if (Ch >= #128) or not (AnsiChar(Ch) in ['A'..'Z', 'a'..'z', '0'..'9', '_']) then\r\n begin\r\n W := Word(Ch);\r\n {$IFNDEF UNICODE}\r\n if (W < 128) or (MultiByteToWideChar(CP_ACP, MB_ERR_INVALID_CHARS, @Ch, 1, PWideChar(@W), 1) <> 0) then\r\n {$ENDIF ~UNICODE}\r\n begin\r\n I := 0;\r\n while (I < Length(Conversions)) and (Conversions[I].Ch <> W) do\r\n Inc(I);\r\n if I < Length(Conversions) then\r\n begin\r\n Result := Conversions[I].Html;\r\n Exit;\r\n end;\r\n end;\r\n end;\r\n Result := Ch;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvStringGrid.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain A copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvStringGrid.PAS, released on 2001-02-28.\r\n\r\nThe Initial Developer of the Original Code is Sebastien Buysse [sbuysse att buypin dott com]\r\nPortions created by Sebastien Buysse are Copyright (C) 2001 S?stien Buysse.\r\nAll Rights Reserved.\r\n\r\nContributor(s): Michael Beck [mbeck att bigfoot dott com].\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvStringGrid.pas 13221 2012-02-24 14:12:04Z obones $\r\n\r\nunit JvStringGrid;\r\n\r\n{$I jvcl.inc}\r\n\r\n//---------------------------------------------------------------\r\n// The inplace-edit-list feature is enabled dynamically when\r\n// compiling JVCL, if the underlying JVCL and VCL base classes\r\n// support it. \r\n//---------------------------------------------------------------\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Grids, StdCtrls,\r\n JvJCLUtils, JvExGrids;\r\n\r\nconst\r\n GM_ACTIVATECELL = WM_USER + 123;\r\n\r\ntype\r\n TGMActivateCell = record\r\n Msg: Cardinal;\r\n {$IFDEF COMPILER16_UP}\r\n\tMsgFiller: TDWordFiller;\r\n {$ENDIF COMPILER16_UP}\r\n Column: Integer;\r\n {$IFDEF COMPILER16_UP}\r\n\tWParamFiller: TDWordFiller;\r\n {$ENDIF COMPILER16_UP}\r\n Row: Integer;\r\n {$IFDEF COMPILER16_UP}\r\n\tLParamFiller: TDWordFiller;\r\n {$ENDIF COMPILER16_UP}\r\n Result: LRESULT;\r\n end;\r\n\r\n TJvStringGrid = class;\r\n TExitCellEvent = procedure(Sender: TJvStringGrid; AColumn, ARow: Integer;\r\n const EditText: string) of object;\r\n TGetCellAlignmentEvent = procedure(Sender: TJvStringGrid; AColumn, ARow: Integer;\r\n State: TGridDrawState; var CellAlignment: TAlignment) of object;\r\n TCaptionClickEvent = procedure(Sender: TJvStringGrid; AColumn, ARow: Integer) of object;\r\n TEditShowEvent = procedure(Sender: TJvStringGrid; ACol, ARow: Longint;\r\n var AllowEdit: Boolean) of object;\r\n TJvSortType = (stNone, stAutomatic, stClassic, stCaseSensitive, stNumeric, stDate, stCurrency);\r\n TProgress = procedure(Sender: TObject; Progression, Total: Integer) of object;\r\n\r\n TJvOnGetEditStyleEvent = procedure(Sender: TJvStringGrid; AColumn, ARow: Integer; PickListStrings: TStrings; var EditStyle: TEditStyle) of object;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvStringGrid = class(TJvExStringGrid)\r\n private\r\n FAlignment: TAlignment;\r\n FOnSetCanvasProperties: TDrawCellEvent;\r\n FOnGetCellAlignment: TGetCellAlignmentEvent;\r\n FOnColWidthsChanged: TNotifyEvent;\r\n FCaptionClick: TCaptionClickEvent;\r\n FCellOnMouseDown: TGridCoord;\r\n FOnExitCell: TExitCellEvent;\r\n FOnLoadProgress: TProgress;\r\n FOnSaveProgress: TProgress;\r\n FOnHorizontalScroll: TNotifyEvent;\r\n FOnVerticalScroll: TNotifyEvent;\r\n FOnShowEditor: TEditShowEvent;\r\n\r\n FCustomInplaceEditStyle: TEditStyle; // NEW\r\n FOnGetEditStyle: TJvOnGetEditStyleEvent;\r\n FPickListStrings: TStringList;\r\n FOnEditButtonClick: TNotifyEvent;\r\n FOnListBoxCloseUp: TNotifyEvent;\r\n\r\n FFixedFont: TFont;\r\n procedure SetAlignment(const Value: TAlignment);\r\n procedure GMActivateCell(var Msg: TGMActivateCell); message GM_ACTIVATECELL;\r\n procedure WMCommand(var Msg: TWMCommand); message WM_COMMAND;\r\n procedure SetFixedFont(const Value: TFont);\r\n procedure DoFixedFontChange(Sender: TObject);\r\n\r\n procedure EditButtonClick(Sender: TObject); dynamic;\r\n procedure ListBoxCloseUp(Sender: TObject); dynamic;\r\n protected\r\n function CreateEditor: TInplaceEdit; override;\r\n function CanEditShow: Boolean; override;\r\n procedure ColWidthsChanged; override;\r\n procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;\r\n procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;\r\n procedure ExitCell(const EditText: string; AColumn, ARow: Integer); virtual;\r\n procedure SetCanvasProperties(AColumn, ARow: Longint; Rect: TRect; State: TGridDrawState); virtual;\r\n procedure DrawCell(AColumn, ARow: Longint; Rect: TRect; State: TGridDrawState); override;\r\n\r\n // NEW: Override to provide dropdown list editing as an event-handler in TJvStringGrid.\r\n function GetEditStyle(ACol, ARow: Longint): TEditStyle; override;\r\n\r\n procedure CaptionClick(AColumn, ARow: Longint); dynamic;\r\n procedure WMHScroll(var Msg: TWMHScroll); message WM_HSCROLL;\r\n procedure WMVScroll(var Msg: TWMVScroll); message WM_VSCROLL;\r\n procedure DoLoadProgress(Position, Count: Integer);\r\n procedure DoSaveProgress(Position, Count: Integer);\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n\r\n function GetCellAlignment(AColumn, ARow: Longint;\r\n State: TGridDrawState): TAlignment; virtual;\r\n procedure DefaultDrawCell(AColumn, ARow: Longint;\r\n Rect: TRect; State: TGridDrawState); virtual;\r\n procedure ActivateCell(AColumn, ARow: Integer);\r\n\r\n // protected => public\r\n procedure InvalidateCell(AColumn, ARow: Integer);\r\n procedure InvalidateCol(AColumn: Integer);\r\n procedure InvalidateRow(ARow: Integer);\r\n procedure MoveColumn(FromIndex, ToIndex: Integer);\r\n procedure MoveRow(FromIndex, ToIndex: Longint);\r\n property GridState;\r\n property InplaceEditor;\r\n\r\n // Calculates and sets the width of a specific column or all columns if Index < 0\r\n // based on the text in the affected Cells.\r\n // MinWidth is the minimum width of the column(s). If MinWidth is < 0,\r\n // DefaultColWidth is used instead\r\n procedure AutoSizeCol(Index, MinWidth: Integer; AColumnPadding: Integer = 8);\r\n\r\n // Inserts a new row at the specified Index and moves all existing rows >= Index down one step\r\n // Returns the inserted row as an empty TStrings\r\n function InsertRow(Index: Integer): TStrings;\r\n\r\n // Inserts a new column at the specified Index and moves all existing columns >= Index to the right\r\n // Returns the inserted column as an empty TStrings\r\n function InsertCol(Index: Integer): TStrings;\r\n\r\n // Removes the row at Index and moves all rows > Index up one step\r\n procedure RemoveRow(Index: Integer);\r\n\r\n // Removes the column at Index and moves all cols > Index to the left\r\n procedure RemoveCol(Index: Integer);\r\n\r\n // Hides the row at Index by setting it's height = -1\r\n // Calling this method repeatedly does nothing (the row retains it's Index even if it's hidden)\r\n procedure HideRow(Index: Integer);\r\n\r\n // Shows the row at Index by setting it's height to AHeight\r\n // if AHeight <= 0, DefaultRowHeight is used instead\r\n procedure ShowRow(Index, AHeight: Integer);\r\n\r\n // Hides the column at Index by setting it's ColWidth = -1\r\n // Calling this method repeatedly does nothing (the column retains it's Index even if it's hidden)\r\n procedure HideCol(Index: Integer);\r\n\r\n // Returns True if the Cell at ACol/ARow is hidden, i.e if it's RowHeight or ColWidth < 0\r\n function IsHidden(ACol, ARow: Integer): Boolean;\r\n\r\n // Shows the column at Index by setting it's width to AWidth\r\n // If AWidth <= 0, DefaultColWidth is used instead\r\n procedure ShowCol(Index, AWidth: Integer);\r\n\r\n // HideCell hides a cell by hiding the row and column that it belongs to.\r\n // This means that both a row and a column is hidden\r\n procedure HideCell(ACol, ARow: Integer);\r\n\r\n // ShowCell shows a previously hidden cell by showing it's corresponding row and column and\r\n // using AWidth/AHeight to set it's size. If AWidth < 0, DefaultColWidth is used instead.\r\n // If AHeight < 0, DefaultRowHeight is used instead. If one dimension of the Cell wasn't\r\n // hidden, nothing happens to that dimension (i.e if ColWidth < 0 but RowHeight := 24, only ColWidth is\r\n // changed to AWidth\r\n procedure ShowCell(ACol, ARow, AWidth, AHeight: Integer);\r\n\r\n // Hides all rows and columns\r\n procedure HideAll;\r\n\r\n // Shows all hidden rows and columns, setting their width/height to AWidth/AHeight as necessary\r\n // If AWidth < 0, DefaultColWidth is used. If AHeight < 0, DefaultRowHeight is used\r\n procedure ShowAll(AWidth, AHeight: Integer);\r\n\r\n // Removes the content in the Cells but does not remove any rows or columns\r\n procedure Clear;\r\n\r\n // Clears selection rectangle!\r\n procedure ClearSelection;\r\n\r\n procedure SortGrid(Column: Integer; Ascending: Boolean = True; Fixed: Boolean = False;\r\n SortType: TJvSortType = stClassic; BlankTop: Boolean = True);\r\n\r\n // Sort grid using the column indices in ColOrder. For example if ColOrder contains\r\n // [1, 3, 0, 2], column 3 is used when the items in column 1 are identical\r\n procedure SortGridByCols(ColOrder: array of Integer; Fixed: Boolean = False);\r\n\r\n procedure SaveToFile(const FileName: string {$IFDEF UNICODE}; Encoding: TEncoding = nil{$ENDIF});\r\n procedure LoadFromFile(const FileName: string {$IFDEF UNICODE}; Encoding: TEncoding = nil{$ENDIF});\r\n procedure LoadFromCSV(const FileName: string; Separator: Char = ';'; QuoteChar: Char = '\"'; StripQuotes: Boolean = True);\r\n procedure SaveToCSV(const FileName: string; Separator: Char = ';'; QuoteChar: Char = '\"');\r\n procedure LoadFromStream(Stream: TStream {$IFDEF UNICODE}; Encoding: TEncoding = nil{$ENDIF});\r\n procedure SaveToStream(Stream: TStream {$IFDEF UNICODE}; Encoding: TEncoding = nil{$ENDIF});\r\n published\r\n property HintColor;\r\n property Alignment: TAlignment read FAlignment write SetAlignment;\r\n property FixedFont: TFont read FFixedFont write SetFixedFont;\r\n property OnExitCell: TExitCellEvent read FOnExitCell write FOnExitCell;\r\n\r\n property OnSetCanvasProperties: TDrawCellEvent read FOnSetCanvasProperties write FOnSetCanvasProperties;\r\n property OnGetCellAlignment: TGetCellAlignmentEvent read FOnGetCellAlignment write FOnGetCellAlignment;\r\n property OnCaptionClick: TCaptionClickEvent read FCaptionClick write FCaptionClick;\r\n property OnColWidthsChanged: TNotifyEvent read FOnColWidthsChanged write FOnColWidthsChanged;\r\n property OnMouseEnter;\r\n property OnMouseLeave;\r\n property OnParentColorChange;\r\n property OnLoadProgress: TProgress read FOnLoadProgress write FOnLoadProgress;\r\n property OnSaveProgress: TProgress read FOnSaveProgress write FOnSaveProgress;\r\n property OnVerticalScroll: TNotifyEvent read FOnVerticalScroll write FOnVerticalScroll;\r\n property OnHorizontalScroll: TNotifyEvent read FOnHorizontalScroll write FOnHorizontalScroll;\r\n property OnShowEditor: TEditShowEvent read FOnShowEditor write FOnShowEditor;\r\n\r\n property OnGetEditStyle: TJvOnGetEditStyleEvent read FOnGetEditStyle write FOnGetEditStyle;\r\n property OnEditButtonClick: TNotifyEvent read FOnEditButtonClick write FOnEditButtonClick; // User clicks on Ellipsis button, get event fired!\r\n property OnListBoxCloseUp: TNotifyEvent read FOnListBoxCloseUp write FOnListBoxCloseUp; // Listbox close up.\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvStringGrid.pas $';\r\n Revision: '$Revision: 13221 $';\r\n Date: '$Date: 2012-02-24 15:12:04 +0100 (ven. 24 févr. 2012) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n Math,\r\n JclBase, // TBytes for Pre-Delphi 2007\r\n JvJVCLUtils;\r\n\r\n//=== { TExInplaceEditList } =================================================\r\n\r\n// If the feature exists in the VCL base classes, we can enable the\r\n// feature here.\r\ntype\r\n TExInplaceEditList = class(TJvExPubInplaceEditList) // was inheriting from TJvExInplaceEdit.-WAP\r\n private\r\n // Important: Style of this inplace editor is set in TInplaceEditList\r\n // FEditStyle - inherited - See VCL Source: ($delphi)\\Source\\vcl\\Grids.pas\r\n //FActiveList : TWinControl; // WP-New: Listbox control stuff\r\n //FPickListLoaded: Boolean; // WP-New\r\n //FPickList : TCustomListbox; // WP-New\r\n //FListVisible : Boolean; // WP-New\r\n FLastCol: Integer;\r\n FLastRow: Integer;\r\n protected\r\n procedure CloseUp(Accept: Boolean); override; // fire event on close up!\r\n procedure DoEditButtonClick; override;\r\n procedure UpdateContents; override; //WP-New! - Put items into listbox!\r\n procedure FocusKilled(NextWnd: THandle); override;\r\n procedure FocusSet(PrevWnd: THandle); override;\r\n public\r\n constructor Create(Owner: TComponent); override;//WP-New!\r\n //property ActiveList: TWinControl read FActiveList write FActiveList;//WP-New!\r\n procedure CreateParams(var Params: TCreateParams); override;\r\n end;\r\n\r\nconstructor TExInplaceEditList.Create(Owner: TComponent);\r\nbegin\r\n inherited Create(Owner);\r\n // todo: tweakage!\r\nend;\r\n\r\n//NEW!\r\nprocedure TExInplaceEditList.UpdateContents;\r\nvar\r\n OwnerGrid: TJvStringGrid;\r\nbegin\r\n inherited UpdateContents;\r\n if EditStyle = esPickList then\r\n begin\r\n ActiveList := PickList;\r\n // Populate the listbox:\r\n Assert(Assigned(Grid));\r\n OwnerGrid := (Grid as TJvStringGrid);\r\n PickList.Items.Assign(OwnerGrid.FPickListStrings);\r\n end;\r\nend;\r\n\r\nprocedure TExInplaceEditList.CreateParams(var Params: TCreateParams);\r\nconst\r\n Flags: array [TAlignment] of DWORD = (ES_LEFT, ES_RIGHT, ES_CENTER);\r\nbegin\r\n inherited CreateParams(Params);\r\n Params.Style := Params.Style or Flags[TJvStringGrid(Grid).Alignment];\r\nend;\r\n\r\nprocedure TExInplaceEditList.FocusKilled(NextWnd: THandle);\r\nbegin\r\n TJvStringGrid(Grid).ExitCell(Text, FLastCol, FLastRow);\r\n inherited FocusKilled(NextWnd);\r\nend;\r\n\r\nprocedure TExInplaceEditList.FocusSet(PrevWnd: THandle);\r\nbegin\r\n FLastCol := TJvStringGrid(Grid).Col;\r\n FLastRow := TJvStringGrid(Grid).Row;\r\n inherited FocusSet(PrevWnd);\r\nend;\r\n\r\nprocedure TExInplaceEditList.CloseUp(Accept: Boolean); //override; // fire event on close up!\r\nbegin\r\n inherited CloseUp(Accept);\r\n if Assigned(Grid) then\r\n TJvStringGrid(Grid).ListBoxCloseUp(Self);\r\nend;\r\n\r\nprocedure TExInplaceEditList.DoEditButtonClick;\r\nbegin\r\n if Assigned(Grid) then\r\n TJvStringGrid(Grid).EditButtonClick(Self);\r\nend;\r\n\r\n//=== { TJvStringGrid } ======================================================\r\n\r\nconstructor TJvStringGrid.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FFixedFont := TFont.Create;\r\n FFixedFont.Assign(Font);\r\n FFixedFont.OnChange := DoFixedFontChange;\r\n // ControlStyle := ControlStyle + [csAcceptsControls];\r\n FPickListStrings := TStringList.Create;\r\nend;\r\n\r\ndestructor TJvStringGrid.Destroy;\r\nbegin\r\n FreeAndNil(FFixedFont);\r\n FreeAndNil(FPickListStrings);\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJvStringGrid.CanEditShow: Boolean;\r\nbegin\r\n Result := inherited CanEditShow;\r\n if Result and Assigned(FOnShowEditor) then\r\n begin\r\n FOnShowEditor(Self, Col, Row, Result);\r\n if not Result then\r\n EditorMode := False;\r\n end;\r\nend;\r\n\r\nprocedure TJvStringGrid.ColWidthsChanged;\r\nbegin\r\n inherited;\r\n if Assigned(FOnColWidthsChanged) then\r\n FOnColWidthsChanged(Self);\r\nend;\r\n\r\nprocedure TJvStringGrid.SortGrid(Column: Integer;\r\n Ascending, Fixed: Boolean; SortType: TJvSortType; BlankTop: Boolean);\r\nconst\r\n cFloatDelta = 0.01;\r\nvar\r\n St: string;\r\n TmpC: Currency;\r\n TmpF: Extended;\r\n TmpD: TDateTime;\r\n LStart: Integer;\r\n LEnd: Integer;\r\n\r\n procedure ExchangeGridRows(I, J: Integer);\r\n var\r\n K: Integer;\r\n begin\r\n if Fixed then\r\n for K := 0 to ColCount - 1 do\r\n Cols[K].Exchange(I, J)\r\n else\r\n for K := FixedCols to ColCount - 1 do\r\n Cols[K].Exchange(I, J);\r\n end;\r\n\r\n function IsSmaller(First, Second: string): Boolean;\r\n\r\n function DetectType(const S1, S2: string): TJvSortType;\r\n var\r\n ExtValue: Extended;\r\n CurrValue: Currency;\r\n DateValue: TDateTime;\r\n begin\r\n if TextToFloat(PChar(S1), ExtValue, fvExtended) and TextToFloat(PChar(S2), ExtValue, fvExtended) then\r\n Result := stNumeric\r\n else\r\n if TextToFloat(PChar(S1), CurrValue, fvCurrency) and TextToFloat(PChar(S2), CurrValue, fvCurrency) then\r\n Result := stCurrency\r\n else\r\n if TryStrToDateTime(S1, DateValue) and TryStrToDateTime(S2, DateValue) then\r\n Result := stDate\r\n else\r\n Result := stClassic;\r\n end;\r\n begin\r\n case DetectType(First, Second) of\r\n stNumeric:\r\n Result := StrToFloat(First) < StrToFloat(Second);\r\n stCurrency:\r\n Result := StrToCurr(First) < StrToCurr(Second);\r\n stDate:\r\n Result := StrToDateTime(First) < StrToDateTime(Second);\r\n stClassic:\r\n Result := AnsiCompareText(First, Second) < 0;\r\n else\r\n Result := First > Second;\r\n end;\r\n end;\r\n\r\n function IsBigger(First, Second: string): Boolean;\r\n begin\r\n Result := IsSmaller(Second, First);\r\n end;\r\n // (rom) A HeapSort has no worst case for O(X)\r\n // (rom) I donated one a long time ago to JCL\r\n // (p3) maybe implemented a secondary sort index when items are equal?\r\n // (p3) ...or use another stable sort method, like heapsort\r\n\r\n procedure QuickSort(L, R: Integer);\r\n var\r\n I, J, m: Integer;\r\n begin\r\n repeat\r\n I := L;\r\n J := R;\r\n m := (L + R) div 2;\r\n St := Cells[Column, m];\r\n repeat\r\n case SortType of\r\n stClassic:\r\n begin\r\n while AnsiCompareText(Cells[Column, I], St) < 0 do\r\n Inc(I);\r\n while AnsiCompareText(Cells[Column, J], St) > 0 do\r\n Dec(J);\r\n end;\r\n stCaseSensitive:\r\n begin\r\n while AnsiCompareStr(Cells[Column, I], St) < 0 do\r\n Inc(I);\r\n while AnsiCompareStr(Cells[Column, J], St) > 0 do\r\n Dec(J);\r\n end;\r\n stNumeric:\r\n begin\r\n TmpF := JvSafeStrToFloatDef(St, 0); // formerly StrToFloatDefIgnoreInvalidCharacters\r\n while JvSafeStrToFloatDef(Cells[Column, I], 0) < TmpF do\r\n Inc(I);\r\n while JvSafeStrToFloatDef(Cells[Column, J], 0) > TmpF do\r\n Dec(J);\r\n end;\r\n stDate:\r\n begin\r\n TmpD := StrToDateTimeDef(St, 0);\r\n while StrToDateTimeDef(Cells[Column, I], 0) < TmpD do\r\n Inc(I);\r\n while StrToDateTimeDef(Cells[Column, J], 0) > TmpD do\r\n Dec(J);\r\n end;\r\n stCurrency:\r\n begin\r\n TmpC := StrToCurrDef(St, 0);\r\n while StrToCurrDef(Cells[Column, I], 0) < TmpC do\r\n Inc(I);\r\n while StrToCurrDef(Cells[Column, J], 0) > TmpC do\r\n Dec(J);\r\n end;\r\n stAutomatic:\r\n begin\r\n while IsSmaller(Cells[Column, I], St) do\r\n Inc(I);\r\n while IsBigger(Cells[Column, J], St) do\r\n Dec(J);\r\n end;\r\n end;\r\n if I <= J then\r\n begin\r\n if I <> J then\r\n ExchangeGridRows(I, J);\r\n Inc(I);\r\n Dec(J);\r\n end;\r\n until (I > J);\r\n if L < J then\r\n QuickSort(L, J);\r\n L := I;\r\n until I >= R;\r\n end;\r\n\r\n procedure InvertGrid;\r\n var\r\n I, J: Integer;\r\n begin\r\n I := FixedRows;\r\n J := RowCount - 1;\r\n while I < J do\r\n begin\r\n ExchangeGridRows(I, J);\r\n Inc(I);\r\n Dec(J);\r\n end;\r\n end;\r\n\r\n function MoveBlankTop: Integer;\r\n var\r\n I, J: Integer;\r\n begin\r\n I := FixedRows;\r\n Result := I;\r\n J := RowCount - 1;\r\n while I <= J do\r\n begin\r\n if Trim(Cells[Column, I]) = '' then\r\n begin\r\n ExchangeGridRows(Result, I);\r\n Inc(Result);\r\n end;\r\n Inc(I);\r\n end;\r\n end;\r\n\r\n procedure MoveBlankBottom;\r\n var\r\n I, J: Integer;\r\n DoSort: Boolean;\r\n begin\r\n I := FixedRows;\r\n DoSort := False;\r\n // avoid empty columns\r\n for J := I to RowCount - 1 do\r\n if Cells[Column, J] <> '' then\r\n begin\r\n DoSort := True;\r\n Break;\r\n end;\r\n if not DoSort then\r\n Exit;\r\n // this is already sorted, so blank items should be at top\r\n while Trim(Cells[Column, I]) = '' do\r\n begin\r\n InsertRow(RowCount).Assign(Rows[I]);\r\n DeleteRow(I);\r\n Inc(J);\r\n if J >= RowCount then\r\n Exit;\r\n end;\r\n end;\r\n\r\nbegin\r\n // (p3) NB!! sorting might trigger the OnExitCell, OnGetEditText and OnSetEditText events!\r\n // make sure you don't do anything in these events\r\n if (Column >= 0) and (Column < ColCount) and (SortType <> stNone) then\r\n begin\r\n LStart := FixedRows;\r\n LEnd := RowCount - 1;\r\n if BlankTop then\r\n LStart := MoveBlankTop;\r\n if LStart < LEnd then\r\n begin\r\n QuickSort(LStart, LEnd);\r\n if not BlankTop then\r\n MoveBlankBottom;\r\n if not Ascending then\r\n InvertGrid;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvStringGrid.LoadFromFile(const FileName: string {$IFDEF UNICODE}; Encoding: TEncoding{$ENDIF});\r\nvar\r\n Stream: TFileStream;\r\nbegin\r\n Stream := TFileStream.Create(FileName, fmOpenRead or fmShareDenyWrite);\r\n try\r\n LoadFromStream(Stream {$IFDEF UNICODE}, Encoding{$ENDIF});\r\n finally\r\n Stream.Free;\r\n end;\r\nend;\r\n\r\nprocedure TJvStringGrid.LoadFromCSV(const FileName: string; Separator: Char = ';'; QuoteChar: Char = '\"'; StripQuotes: Boolean = True);\r\nvar\r\n I: Longint;\r\n Lines, Fields: TStringList;\r\n\r\n procedure SplitLine(const Line: string; Result: TStrings; Delimiter, QuoteChar: Char; StripQuotes: Boolean);\r\n var\r\n I, SLen, QuoteCount: Integer;\r\n S: string;\r\n IgnoreDelim: Boolean;\r\n QuotedStr: PChar;\r\n begin\r\n S := '';\r\n SLen := Length(Line);\r\n IgnoreDelim := False;\r\n QuoteCount := 0;\r\n Result.Clear;\r\n for I := 1 to SLen do\r\n begin\r\n if Line[I] = QuoteChar then\r\n begin\r\n Inc(QuoteCount);\r\n {* A Delimiter surrounded by a pair of QuoteChar has to be ignored.\r\n See example above: \"FirstName, LastName\"\r\n therefor: *}\r\n IgnoreDelim := QuoteCount mod 2 <> 0;\r\n end;\r\n\r\n if IgnoreDelim then\r\n S := S + Line[I]\r\n else\r\n if Line[I] <> Delimiter then\r\n S := S + Line[I]\r\n else\r\n begin\r\n if S <> '' then\r\n begin\r\n if StripQuotes and (S[1] = QuoteChar) then\r\n begin\r\n QuotedStr := PChar(S);\r\n Result.Add(AnsiExtractQuotedStr(QuotedStr, QuoteChar));\r\n end\r\n else\r\n Result.Add(S);\r\n end\r\n else\r\n Result.Add(S);\r\n\r\n S := '';\r\n end;\r\n end;\r\n if S <> '' then\r\n begin\r\n if StripQuotes and (S[1] = QuoteChar) then\r\n begin\r\n QuotedStr := PChar(S);\r\n Result.Add(AnsiExtractQuotedStr(QuotedStr, QuoteChar));\r\n end\r\n else\r\n Result.Add(S);\r\n end\r\n else\r\n Result.Add(S);\r\n end;\r\n\r\nbegin\r\n Lines := TStringList.Create;\r\n Fields := TStringList.Create;\r\n try\r\n Lines.LoadFromFile(FileName);\r\n DoLoadProgress(0, Lines.Count);\r\n RowCount := Lines.Count;\r\n ColCount := FixedCols + 1;\r\n for I := 0 to Lines.Count - 1 do\r\n begin\r\n {* added John *}\r\n SplitLine(Lines[I], Fields, Separator, QuoteChar, StripQuotes);\r\n DoLoadProgress(I, Lines.Count);\r\n\r\n if Fields.Count > ColCount then\r\n ColCount := Fields.Count;\r\n Rows[I].Assign(Fields);\r\n end;\r\n DoLoadProgress(Lines.Count, Lines.Count);\r\n finally\r\n Fields.Free;\r\n Lines.Free;\r\n end;\r\nend;\r\n\r\nprocedure TJvStringGrid.LoadFromStream(Stream: TStream {$IFDEF UNICODE}; Encoding: TEncoding{$ENDIF});\r\nconst\r\n BufSize = 4096;\r\n GrowSize = 1024;\r\nvar\r\n Col, Row, I, Count: Integer;\r\n Buffer: array [0..BufSize - 1] of Byte;\r\n Bytes: TBytes;\r\n Len: Integer;\r\n Size: Int64;\r\n\r\n procedure SetCell;\r\n var\r\n St: string;\r\n begin\r\n {$IFDEF UNICODE}\r\n St := Encoding.GetString(Bytes, 0, Len);\r\n {$ELSE}\r\n SetString(St, PAnsiChar(@Bytes[0]), Len);\r\n {$ENDIF UNICODE}\r\n Cells[Col - 1, Row - 1] := St;\r\n\r\n if Length(Bytes) > BufSize then\r\n SetLength(Bytes, BufSize);\r\n Len := 0;\r\n end;\r\n\r\nbegin\r\n {$IFDEF UNICODE}\r\n if Encoding = nil then\r\n Encoding := TEncoding.Default;\r\n {$ENDIF UNICODE}\r\n Col := 0;\r\n Row := 1;\r\n Size := Stream.Size;\r\n DoLoadProgress(0, Size);\r\n Len := 0;\r\n SetLength(Bytes, BufSize);\r\n while Stream.Position < Size do\r\n begin\r\n Count := Stream.Read(Buffer, BufSize);\r\n DoLoadProgress(Stream.Position, Size);\r\n for I := 0 to Count - 1 do\r\n case Buffer[I] of\r\n 0:\r\n begin\r\n Inc(Col);\r\n if Row > RowCount then\r\n RowCount := Row;\r\n if Col > ColCount then\r\n ColCount := Col;\r\n SetCell;\r\n end;\r\n 1:\r\n begin\r\n Inc(Col);\r\n if Col > ColCount then\r\n ColCount := Col;\r\n SetCell;\r\n Inc(Row);\r\n if Row > RowCount then\r\n RowCount := Row;\r\n Col := 0;\r\n end;\r\n else\r\n if Len >= Length(Bytes) then\r\n SetLength(Bytes, Len + GrowSize);\r\n Bytes[Len] := Buffer[I];\r\n Inc(Len);\r\n end;\r\n end;\r\n RowCount := RowCount - 1;\r\n DoLoadProgress(Stream.Size, Stream.Size);\r\nend;\r\n\r\nprocedure TJvStringGrid.WMHScroll(var Msg: TWMHScroll);\r\nbegin\r\n inherited;\r\n if Assigned(FOnHorizontalScroll) then\r\n FOnHorizontalScroll(Self);\r\nend;\r\n\r\nprocedure TJvStringGrid.WMVScroll(var Msg: TWMVScroll);\r\nbegin\r\n inherited;\r\n if Assigned(FOnVerticalScroll) then\r\n FOnVerticalScroll(Self);\r\nend;\r\n\r\nprocedure TJvStringGrid.SaveToFile(const FileName: string {$IFDEF UNICODE}; Encoding: TEncoding{$ENDIF});\r\nvar\r\n Stream: TFileStream;\r\nbegin\r\n Stream := TFileStream.Create(FileName, fmCreate or fmShareDenyWrite);\r\n try\r\n SaveToStream(Stream {$IFDEF UNICODE}, Encoding{$ENDIF});\r\n finally\r\n Stream.Free;\r\n end;\r\nend;\r\n\r\nprocedure TJvStringGrid.SaveToCSV(const FileName: string; Separator: Char = ';'; QuoteChar: Char = '\"');\r\nvar\r\n I, J: Longint;\r\n BufStr, Value: string;\r\n Lines: TStringList;\r\nbegin\r\n Lines := TStringList.Create;\r\n DoSaveProgress(0, RowCount);\r\n try\r\n Lines.Clear;\r\n for I := 0 to RowCount - 1 do\r\n begin\r\n BufStr := '';\r\n DoSaveProgress(I, RowCount);\r\n for J := 0 to ColCount - 1 do\r\n begin\r\n Value := Cells[J, I];\r\n if Pos(Separator, Value) > 0 then\r\n Value := AnsiQuotedStr(Value, QuoteChar);\r\n BufStr := BufStr + Value;\r\n if J <> (ColCount - 1) then\r\n BufStr := BufStr + Separator;\r\n end;\r\n Lines.Add(BufStr);\r\n end;\r\n DoSaveProgress(RowCount, RowCount);\r\n Lines.SaveToFile(FileName);\r\n finally\r\n Lines.Free;\r\n end;\r\nend;\r\n\r\nprocedure TJvStringGrid.SaveToStream(Stream: TStream {$IFDEF UNICODE}; Encoding: TEncoding{$ENDIF});\r\nvar\r\n I, J, ATotal: Integer;\r\n {$IFNDEF UNICODE}\r\n K: Integer;\r\n {$ENDIF ~UNICODE}\r\n Bytes: TBytes;\r\n St: string;\r\n Len: Integer;\r\n A, B: Byte;\r\nbegin\r\n {$IFDEF UNICODE}\r\n if Encoding = nil then\r\n Encoding := TEncoding.Default;\r\n {$ENDIF UNICODE}\r\n A := 0;\r\n B := 1; // A for end of string, B for end of line\r\n ATotal := RowCount * ColCount;\r\n DoSaveProgress(0, ATotal);\r\n for I := 0 to RowCount - 1 do\r\n begin\r\n for J := 0 to ColCount - 1 do\r\n begin\r\n DoSaveProgress(I * ColCount + J, ATotal);\r\n St := Cells[J, I];\r\n {$IFDEF UNICODE}\r\n Bytes := Encoding.GetBytes(St);\r\n Len := Length(Bytes);\r\n {$ELSE}\r\n Len := Length(St);\r\n if Length(Bytes) < Len then\r\n SetLength(Bytes, Len);\r\n for K := 0 to Len - 1 do\r\n if (St[K + 1] = #1) or (St[K + 1] = #0) then\r\n Bytes[K] := 32\r\n else\r\n Bytes[K] := Byte(St[K + 1]);\r\n {$ENDIF}\r\n if Len > 0 then\r\n Stream.Write(Bytes[0], Len);\r\n if J <> ColCount - 1 then\r\n Stream.Write(A, 1);\r\n end;\r\n Stream.Write(B, 1);\r\n end;\r\n DoSaveProgress(ATotal, ATotal);\r\nend;\r\n\r\nprocedure TJvStringGrid.ActivateCell(AColumn, ARow: Integer);\r\nbegin\r\n PostMessage(Handle, GM_ACTIVATECELL, AColumn, ARow);\r\nend;\r\n\r\nprocedure TJvStringGrid.CaptionClick(AColumn, ARow: Integer);\r\nbegin\r\n if Assigned(FCaptionClick) then\r\n FCaptionClick(Self, AColumn, ARow);\r\nend;\r\n\r\nfunction TJvStringGrid.CreateEditor: TInplaceEdit;\r\nbegin\r\n Result := TExInplaceEditList.Create(Self);\r\nend;\r\n\r\nprocedure TJvStringGrid.DefaultDrawCell(AColumn, ARow: Integer; Rect: TRect;\r\n State: TGridDrawState);\r\nconst\r\n Flags: array [TAlignment] of DWORD = (DT_LEFT, DT_RIGHT, DT_CENTER);\r\nvar\r\n S: string;\r\nbegin\r\n if RowHeights[ARow] < CanvasMaxTextHeight(Canvas) then\r\n Exit;\r\n Canvas.FillRect(Rect);\r\n S := Cells[AColumn, ARow];\r\n if Length(S) > 0 then\r\n begin\r\n InflateRect(Rect, -2, -2);\r\n DrawText(Canvas, S, Length(S), Rect,\r\n DT_SINGLELINE or DT_NOPREFIX or DT_VCENTER or\r\n Flags[GetCellAlignment(AColumn, ARow, State)]);\r\n end;\r\nend;\r\n\r\nfunction TJvStringGrid.GetEditStyle(ACol, ARow: Longint): TEditStyle; //override;\r\nbegin\r\n FCustomInplaceEditStyle := esSimple;\r\n if Assigned(FOnGetEditStyle) then\r\n begin\r\n FPickListStrings.Clear;\r\n FOnGetEditStyle(Self, ACol, ARow, FPickListStrings, FCustomInplaceEditStyle);\r\n end;\r\n Result := FCustomInplaceEditStyle;\r\nend;\r\n\r\nprocedure TJvStringGrid.DrawCell(AColumn, ARow: Integer; Rect: TRect; State: TGridDrawState);\r\nbegin\r\n if (AColumn < FixedCols) or (ARow < FixedRows) then\r\n Canvas.Font := FixedFont;\r\n if Assigned(OnDrawCell) then\r\n inherited DrawCell(AColumn, ARow, Rect, State)\r\n else\r\n begin\r\n SetCanvasProperties(AColumn, ARow, Rect, State);\r\n DefaultDrawCell(AColumn, ARow, Rect, State);\r\n Canvas.Font := Font;\r\n Canvas.Brush := Brush;\r\n end;\r\nend;\r\n\r\nprocedure TJvStringGrid.ExitCell(const EditText: string;\r\n AColumn, ARow: Integer);\r\nbegin\r\n if Assigned(FOnExitCell) then\r\n FOnExitCell(Self, AColumn, ARow, EditText);\r\nend;\r\n\r\nfunction TJvStringGrid.GetCellAlignment(AColumn, ARow: Integer;\r\n State: TGridDrawState): TAlignment;\r\nbegin\r\n Result := FAlignment;\r\n if Assigned(FOnGetCellAlignment) then\r\n FOnGetCellAlignment(Self, AColumn, ARow, State, Result);\r\nend;\r\n\r\nprocedure TJvStringGrid.GMActivateCell(var Msg: TGMActivateCell);\r\nbegin\r\n Col := Msg.Column;\r\n Row := Msg.Row;\r\n EditorMode := True;\r\n if Assigned(InplaceEditor) then\r\n InplaceEditor.SelectAll;\r\nend;\r\n\r\nprocedure TJvStringGrid.InvalidateCell(AColumn, ARow: Integer);\r\nbegin\r\n inherited InvalidateCell(AColumn, ARow);\r\nend;\r\n\r\nprocedure TJvStringGrid.InvalidateCol(AColumn: Integer);\r\nbegin\r\n inherited InvalidateCol(AColumn);\r\nend;\r\n\r\nprocedure TJvStringGrid.InvalidateRow(ARow: Integer);\r\nbegin\r\n inherited InvalidateRow(ARow);\r\nend;\r\n\r\nprocedure TJvStringGrid.MouseDown(Button: TMouseButton; Shift: TShiftState;\r\n X, Y: Integer);\r\nbegin\r\n inherited MouseDown(Button, Shift, X, Y);\r\n if Button = mbLeft then\r\n MouseToCell(X, Y, FCellOnMouseDown.X, FCellOnMouseDown.Y)\r\n else\r\n FCellOnMouseDown := TGridCoord(Point(-1, -1));\r\nend;\r\n\r\nprocedure TJvStringGrid.MouseUp(Button: TMouseButton; Shift: TShiftState;\r\n X, Y: Integer);\r\nvar\r\n Cell: TGridCoord;\r\nbegin\r\n if Button = mbLeft then\r\n MouseToCell(X, Y, Cell.X, Cell.Y);\r\n if CompareMem(@Cell, @FCellOnMouseDown, SizeOf(Cell)) and\r\n ((Cell.X < FixedCols) or (Cell.Y < FixedRows)) then\r\n CaptionClick(Cell.X, Cell.Y);\r\n FCellOnMouseDown := TGridCoord(Point(-1, -1));\r\n inherited MouseUp(Button, Shift, X, Y);\r\nend;\r\n\r\nprocedure TJvStringGrid.SetAlignment(const Value: TAlignment);\r\nbegin\r\n if FAlignment <> Value then\r\n begin\r\n FAlignment := Value;\r\n Invalidate;\r\n if Assigned(InplaceEditor) then\r\n TExInplaceEditList(InplaceEditor).RecreateWnd;\r\n end;\r\nend;\r\n\r\nprocedure TJvStringGrid.SetCanvasProperties(AColumn, ARow: Integer;\r\n Rect: TRect; State: TGridDrawState);\r\nbegin\r\n if Assigned(FOnSetCanvasProperties) then\r\n FOnSetCanvasProperties(Self, AColumn, ARow, Rect, State);\r\nend;\r\n\r\nprocedure TJvStringGrid.WMCommand(var Msg: TWMCommand);\r\nbegin\r\n if EditorMode and (Msg.Ctl = InplaceEditor.Handle) then\r\n inherited\r\n else\r\n if Msg.Ctl <> 0 then\r\n Msg.Result := SendMessage(Msg.Ctl, CN_COMMAND, TMessage(Msg).wParam, TMessage(Msg).lParam);\r\nend;\r\n\r\nfunction TJvStringGrid.InsertCol(Index: Integer): TStrings;\r\nvar\r\n I: Integer;\r\n LStr: TStrings;\r\nbegin\r\n ColCount := ColCount + 1;\r\n if Index < 0 then\r\n Index := 0;\r\n if Index >= ColCount then\r\n Index := ColCount - 1;\r\n Result := Cols[Index];\r\n if ColCount = 1 then\r\n Exit;\r\n for I := ColCount - 2 downto Index do\r\n begin\r\n LStr := Cols[I];\r\n Cols[I + 1] := LStr;\r\n end;\r\n Result := Cols[Index];\r\n Result.Clear;\r\nend;\r\n\r\nfunction TJvStringGrid.InsertRow(Index: Integer): TStrings;\r\nvar\r\n I: Integer;\r\n LStr: TStrings;\r\nbegin\r\n RowCount := RowCount + 1;\r\n if Index < 0 then\r\n Index := 0;\r\n if Index >= RowCount then\r\n Index := RowCount - 1;\r\n Result := Rows[Index];\r\n if RowCount = 1 then\r\n Exit;\r\n for I := RowCount - 2 downto Index do\r\n begin\r\n LStr := Rows[I];\r\n Rows[I + 1] := LStr;\r\n end;\r\n Result.Clear;\r\nend;\r\n\r\nprocedure TJvStringGrid.RemoveCol(Index: Integer);\r\nvar\r\n I: Integer;\r\n LStr: TStrings;\r\nbegin\r\n if Index < 0 then\r\n Index := 0;\r\n if Index >= ColCount then\r\n Index := ColCount - 1;\r\n for I := Index + 1 to ColCount - 1 do\r\n begin\r\n LStr := Cols[I];\r\n Cols[I - 1] := LStr;\r\n end;\r\n if ColCount > 1 then\r\n ColCount := ColCount - 1;\r\nend;\r\n\r\nprocedure TJvStringGrid.RemoveRow(Index: Integer);\r\nvar\r\n I: Integer;\r\n LStr: TStrings;\r\nbegin\r\n if Index < 0 then\r\n Index := 0;\r\n if Index >= RowCount then\r\n Index := RowCount - 1;\r\n for I := Index + 1 to RowCount - 1 do\r\n begin\r\n LStr := Rows[I];\r\n Rows[I - 1] := LStr;\r\n end;\r\n if RowCount > 1 then\r\n RowCount := RowCount - 1;\r\nend;\r\n\r\nprocedure TJvStringGrid.Clear;\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := 0 to ColCount - 1 do\r\n Cols[I].Clear;\r\nend;\r\n\r\nprocedure TJvStringGrid.HideCol(Index: Integer);\r\nbegin\r\n ColWidths[Index] := -1;\r\nend;\r\n\r\nprocedure TJvStringGrid.HideRow(Index: Integer);\r\nbegin\r\n RowHeights[Index] := -1;\r\nend;\r\n\r\nprocedure TJvStringGrid.ShowCol(Index, AWidth: Integer);\r\nbegin\r\n if AWidth <= 0 then\r\n AWidth := DefaultColWidth;\r\n ColWidths[Index] := AWidth;\r\nend;\r\n\r\nprocedure TJvStringGrid.ShowRow(Index, AHeight: Integer);\r\nbegin\r\n if AHeight <= 0 then\r\n AHeight := DefaultRowHeight;\r\n RowHeights[Index] := AHeight;\r\nend;\r\n\r\nprocedure TJvStringGrid.SetFixedFont(const Value: TFont);\r\nbegin\r\n FFixedFont.Assign(Value);\r\nend;\r\n\r\nprocedure TJvStringGrid.DoFixedFontChange(Sender: TObject);\r\nbegin\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvStringGrid.ListBoxCloseUp(Sender: TObject);\r\nbegin\r\n // invoked dynamically from the TInplaceEditList\r\n if Assigned(FOnListBoxCloseUp) then\r\n FOnListBoxCloseUp(Self)\r\nend;\r\n\r\nprocedure TJvStringGrid.EditButtonClick(Sender: TObject);\r\nbegin\r\n if Assigned(FOnEditButtonClick) then\r\n FOnEditButtonClick(Self)\r\nend;\r\n\r\nprocedure TJvStringGrid.AutoSizeCol(Index, MinWidth: Integer; AColumnPadding: Integer);\r\n\r\n // We must use the cell's font for the GetTextExtentPoint32() call.\r\n procedure SetCanvasPropertiesForCell(AColumn, ARow: Integer);\r\n begin\r\n if (AColumn < FixedCols) or (ARow < FixedRows) then\r\n begin\r\n Canvas.Font := FixedFont;\r\n SetCanvasProperties(AColumn, ARow, CellRect(AColumn, ARow), [gdFixed]);\r\n end\r\n else\r\n begin\r\n Canvas.Font := Font;\r\n SetCanvasProperties(AColumn, ARow, CellRect(AColumn, ARow), []);\r\n end;\r\n end;\r\n\r\nvar\r\n I, J, AColWidth: Integer;\r\n ASize: TSize;\r\nbegin\r\n if (Index >= 0) and (Index < ColCount) then\r\n begin\r\n if MinWidth < 0 then\r\n AColWidth := DefaultColWidth\r\n else\r\n AColWidth := MinWidth;\r\n for J := 0 to RowCount - 1 do\r\n begin\r\n SetCanvasPropertiesForCell(Index, J);\r\n if GetTextExtentPoint32(Canvas.Handle, PChar(Cells[Index, J]), Length(Cells[Index, J]), ASize) then\r\n AColWidth := Max(AColWidth, ASize.cx + AColumnPadding);\r\n end;\r\n ColWidths[Index] := AColWidth;\r\n end\r\n else\r\n begin\r\n for I := 0 to ColCount - 1 do\r\n begin\r\n if MinWidth < 0 then\r\n AColWidth := DefaultColWidth\r\n else\r\n AColWidth := MinWidth;\r\n for J := 0 to RowCount - 1 do\r\n begin\r\n SetCanvasPropertiesForCell(Index, J);\r\n if GetTextExtentPoint32(Canvas.Handle, PChar(Cells[I, J]), Length(Cells[I, J]), ASize) then\r\n AColWidth := Max(AColWidth, ASize.cx + AColumnPadding);\r\n end;\r\n ColWidths[I] := AColWidth;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvStringGrid.HideAll;\r\nvar\r\n I: Integer;\r\nbegin\r\n if ColCount < RowCount then\r\n for I := 0 to ColCount - 1 do\r\n ColWidths[I] := -1\r\n else\r\n for I := 0 to RowCount - 1 do\r\n RowHeights[I] := -1;\r\nend;\r\n\r\nprocedure TJvStringGrid.ClearSelection; // Clears selection rectangle!\r\nvar\r\n S: TGridRect;\r\nbegin\r\n S.Left := -1;\r\n S.Top := -1;\r\n S.Right := -1;\r\n S.Bottom := -1;\r\n Self.Selection := S;\r\n Refresh;\r\nend;\r\n\r\nprocedure TJvStringGrid.ShowAll(AWidth, AHeight: Integer);\r\nvar\r\n I: Integer;\r\nbegin\r\n if AWidth < 0 then\r\n AWidth := DefaultColWidth;\r\n if AHeight < 0 then\r\n AHeight := DefaultRowHeight;\r\n for I := 0 to ColCount - 1 do\r\n if ColWidths[I] < 0 then\r\n ColWidths[I] := AWidth;\r\n for I := 0 to RowCount - 1 do\r\n if RowHeights[I] < 0 then\r\n RowHeights[I] := AHeight;\r\nend;\r\n\r\nfunction TJvStringGrid.IsHidden(ACol, ARow: Integer): Boolean;\r\nbegin\r\n Result := (ColWidths[ACol] < 0) or (RowHeights[ARow] < 0);\r\nend;\r\n\r\nprocedure TJvStringGrid.HideCell(ACol, ARow: Integer);\r\nbegin\r\n ColWidths[ACol] := -1;\r\n RowHeights[ARow] := -1;\r\nend;\r\n\r\nprocedure TJvStringGrid.ShowCell(ACol, ARow, AWidth, AHeight: Integer);\r\nbegin\r\n if AWidth < 0 then\r\n AWidth := DefaultColWidth;\r\n if AHeight < 0 then\r\n AWidth := DefaultRowHeight;\r\n if ColWidths[ACol] < 0 then\r\n ColWidths[ACol] := AWidth;\r\n if RowHeights[ARow] < 0 then\r\n RowHeights[ARow] := AHeight;\r\nend;\r\n\r\nprocedure TJvStringGrid.DoLoadProgress(Position, Count: Integer);\r\nbegin\r\n if Assigned(FOnLoadProgress) then\r\n FOnLoadProgress(Self, Position, Count);\r\nend;\r\n\r\nprocedure TJvStringGrid.DoSaveProgress(Position, Count: Integer);\r\nbegin\r\n if Assigned(FOnSaveProgress) then\r\n FOnSaveProgress(Self, Position, Count);\r\nend;\r\n\r\nprocedure TJvStringGrid.SortGridByCols(ColOrder: array of Integer; Fixed: Boolean);\r\nvar\r\n I, J, FirstRow: Integer;\r\n Sorted: Boolean;\r\n\r\n function Sort(Row1, Row2: Integer): Integer;\r\n var\r\n C: Integer;\r\n begin\r\n C := 0;\r\n Result := AnsiCompareStr(Cols[ColOrder[C]][Row1], Cols[ColOrder[C]][Row2]);\r\n if Result = 0 then\r\n begin\r\n Inc(C);\r\n while (C <= High(ColOrder)) and (Result = 0) do\r\n begin\r\n Result := AnsiCompareStr(Cols[ColOrder[C]][Row1], Cols[ColOrder[C]][Row2]);\r\n Inc(C);\r\n end;\r\n end;\r\n end;\r\n\r\nbegin\r\n for I := 0 to High(ColOrder) do\r\n if (ColOrder[I] < 0) or (ColOrder[I] >= ColCount) then\r\n Exit;\r\n\r\n if Fixed then\r\n FirstRow := 0\r\n else\r\n FirstRow := FixedRows;\r\n\r\n J := FirstRow;\r\n Sorted := True;\r\n repeat\r\n Inc(J);\r\n for I := FirstRow to RowCount - 2 do\r\n if Sort(I, I + 1) > 0 then\r\n begin\r\n MoveRow(I + 1, I);\r\n Sorted := False;\r\n end;\r\n until Sorted or (J >= RowCount + 1000);\r\n Repaint;\r\nend;\r\n\r\nprocedure TJvStringGrid.MoveColumn(FromIndex, ToIndex: Integer);\r\nbegin\r\n inherited MoveColumn(FromIndex, ToIndex);\r\nend;\r\n\r\nprocedure TJvStringGrid.MoveRow(FromIndex, ToIndex: Integer);\r\nbegin\r\n inherited MoveRow(FromIndex, ToIndex);\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n\r\n\r\n" }, { "path": "External/Jedi/Jvcl/run/JvStringHolder.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvStrHlder.PAS, released on 2002-07-04.\r\n\r\nThe Initial Developers of the Original Code are: Fedor Koshevnikov, Igor Pavluk and Serge Korolev\r\nCopyright (c) 1997, 1998 Fedor Koshevnikov, Igor Pavluk and Serge Korolev\r\nCopyright (c) 2001,2002 SGB Software\r\nPortions created by Marc Geldon are Copyright (C) 2004 Marc Geldon.\r\nAll Rights Reserved.\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvStringHolder.pas 13404 2012-08-19 17:58:12Z ahuser $\r\n\r\nunit JvStringHolder;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Variants, RTLConsts, SysUtils, Classes;\r\n\r\ntype\r\n TJvMacros = class;\r\n TMacroTextEvent = procedure(Sender: TObject; Data: Variant; var Text: string) of object;\r\n\r\n TJvMacro = class(TCollectionItem)\r\n private\r\n FName: string;\r\n FData: Variant;\r\n FOnGetText: TMacroTextEvent;\r\n function IsMacroStored: Boolean;\r\n function GetText: string;\r\n function GetMacros: TJvMacros;\r\n protected\r\n function GetDisplayName: string; override;\r\n procedure SetDisplayName(const Value: string); override;\r\n procedure GetMacroText(var AText: string);\r\n function GetAsVariant: Variant;\r\n procedure SetAsVariant(Value: Variant);\r\n public\r\n constructor Create(Collection: TCollection); override;\r\n procedure Assign(Source: TPersistent); override;\r\n procedure Clear;\r\n function IsEqual(Value: TJvMacro): Boolean;\r\n property Macros: TJvMacros read GetMacros;\r\n property Text: string read GetText;\r\n published\r\n property Name: string read FName write SetDisplayName;\r\n property Value: Variant read GetAsVariant write SetAsVariant stored IsMacroStored;\r\n property OnGetText: TMacroTextEvent read FOnGetText write FOnGetText;\r\n end;\r\n\r\n TJvMacros = class(TOwnedCollection)\r\n private\r\n function GetMacroValue(const MacroName: string): Variant;\r\n procedure SetMacroValue(const MacroName: string; const Value: Variant);\r\n function GetItem(Index: Integer): TJvMacro;\r\n procedure SetItem(Index: Integer; Value: TJvMacro);\r\n public\r\n constructor Create(AOwner: TPersistent);\r\n procedure AssignValues(Value: TJvMacros);\r\n procedure AddMacro(Value: TJvMacro);\r\n procedure RemoveMacro(Value: TJvMacro);\r\n function CreateMacro(const MacroName: string): TJvMacro;\r\n procedure GetMacroList(List: TList; const MacroNames: string);\r\n function IndexOf(const AName: string): Integer;\r\n function IsEqual(Value: TJvMacros): Boolean;\r\n function ParseString(const Value: string; DoCreate: Boolean; SpecialChar: Char): string;\r\n function MacroByName(const Value: string): TJvMacro;\r\n function FindMacro(const Value: string): TJvMacro;\r\n property Items[Index: Integer]: TJvMacro read GetItem write SetItem; default;\r\n property MacroValues[const MacroName: string]: Variant read GetMacroValue write SetMacroValue;\r\n end;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64 or pidOSX32)]\r\n {$ENDIF RTL230_UP}\r\n TJvStrHolder = class(TComponent)\r\n private\r\n FStrings: TStringList;\r\n FXorKey: string;\r\n FReserved: Integer;\r\n FMacros: TJvMacros;\r\n FMacroChar: Char;\r\n FOnExpandMacros: TNotifyEvent;\r\n FOnChange: TNotifyEvent;\r\n FOnChanging: TNotifyEvent;\r\n function GetDuplicates: TDuplicates;\r\n procedure SetDuplicates(Value: TDuplicates);\r\n function GetSorted: Boolean;\r\n procedure SetSorted(Value: Boolean);\r\n function GetStrings: TStrings;\r\n procedure SetStrings(Value: TStrings);\r\n procedure StringsChanged(Sender: TObject);\r\n procedure StringsChanging(Sender: TObject);\r\n procedure ReadStrings(Reader: TReader);\r\n procedure WriteStrings(Writer: TWriter);\r\n procedure ReadVersion(Reader: TReader);\r\n procedure WriteVersion(Writer: TWriter);\r\n function GetCommaText: string;\r\n procedure SetCommaText(const Value: string);\r\n function GetCapacity: Integer;\r\n procedure SetCapacity(NewCapacity: Integer);\r\n procedure SetMacros(Value: TJvMacros);\r\n procedure RecreateMacros;\r\n procedure SetMacroChar(Value: Char);\r\n protected\r\n procedure AssignTo(Dest: TPersistent); override;\r\n procedure DefineProperties(Filer: TFiler); override;\r\n procedure Changed; dynamic;\r\n procedure Changing; dynamic;\r\n procedure BeforeExpandMacros; dynamic;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n procedure Assign(Source: TPersistent); override;\r\n procedure Clear;\r\n function MacroCount: Integer;\r\n function MacroByName(const MacroName: string): TJvMacro;\r\n function ExpandMacros: string;\r\n property CommaText: string read GetCommaText write SetCommaText;\r\n published\r\n property Capacity: Integer read GetCapacity write SetCapacity default 0;\r\n property MacroChar: Char read FMacroChar write SetMacroChar default '%';\r\n property Macros: TJvMacros read FMacros write SetMacros;\r\n property OnExpandMacros: TNotifyEvent read FOnExpandMacros write FOnExpandMacros;\r\n property Duplicates: TDuplicates read GetDuplicates write SetDuplicates default dupIgnore;\r\n property KeyString: string read FXorKey write FXorKey stored False;\r\n property Sorted: Boolean read GetSorted write SetSorted default False;\r\n property Strings: TStrings read GetStrings write SetStrings stored False;\r\n property OnChange: TNotifyEvent read FOnChange write FOnChange;\r\n property OnChanging: TNotifyEvent read FOnChanging write FOnChanging;\r\n end;\r\n\r\n { MultiStringHolder }\r\n\r\n EJvMultiStringHolderException = class(Exception);\r\n\r\n TJvMultiStringHolderCollectionItem = class(TCollectionItem)\r\n private\r\n FName: string;\r\n FStrings: TStrings;\r\n procedure SetName(Value: string);\r\n procedure SetStrings(const Value: TStrings);\r\n protected\r\n function GetDisplayName: string; override;\r\n public\r\n constructor Create(Collection: TCollection); override;\r\n destructor Destroy; override;\r\n published\r\n property Name: string read FName write SetName;\r\n property Strings: TStrings read FStrings write SetStrings;\r\n end;\r\n\r\n TJvMultiStringHolderCollection = class(TOwnedCollection)\r\n protected\r\n function GetItem(Index: Integer): TJvMultiStringHolderCollectionItem;\r\n procedure SetItem(Index: Integer; Value: TJvMultiStringHolderCollectionItem);\r\n public\r\n function DoesNameExist(const Name: string): Boolean;\r\n property Items[Index: Integer]: TJvMultiStringHolderCollectionItem read GetItem write SetItem;\r\n function Add: TJvMultiStringHolderCollectionItem;\r\n function Insert(Index: Integer): TJvMultiStringHolderCollectionItem;\r\n end;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64 or pidOSX32)]\r\n {$ENDIF RTL230_UP}\r\n TJvMultiStringHolder = class(TComponent)\r\n private\r\n FMultipleStrings: TJvMultiStringHolderCollection;\r\n procedure SetMultipleStrings(Value: TJvMultiStringHolderCollection);\r\n function GetItemByName(const Name: string): TJvMultiStringHolderCollectionItem;\r\n function GetStringsByName(const Name: string): TStrings;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n property ItemByName[const Name: string]: TJvMultiStringHolderCollectionItem read GetItemByName;\r\n property StringsByName[const Name: string]: TStrings read GetStringsByName;\r\n published\r\n property MultipleStrings: TJvMultiStringHolderCollection read FMultipleStrings write SetMultipleStrings;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvStringHolder.pas $';\r\n Revision: '$Revision: 13404 $';\r\n Date: '$Date: 2012-08-19 19:58:12 +0200 (dim. 19 août 2012) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n Consts,\r\n {$IFDEF SUPPORTS_INLINE}\r\n Windows,\r\n {$ENDIF SUPPORTS_INLINE}\r\n JvJCLUtils, JvResources, JvConsts, JvTypes;\r\n\r\nconst\r\n AnsiXorVersion = 1;\r\n XorVersion = 2;\r\n\r\nfunction ExtractName(const Items: string; var Pos: Integer): string;\r\nvar\r\n I: Integer;\r\nbegin\r\n I := Pos;\r\n while (I <= Length(Items)) and (Items[I] <> ';') do\r\n Inc(I);\r\n Result := Trim(Copy(Items, Pos, I - Pos));\r\n if (I <= Length(Items)) and (Items[I] = ';') then\r\n Inc(I);\r\n Pos := I;\r\nend;\r\n\r\nfunction NameDelimiter(C: Char; Delims: TCharSet): Boolean;\r\nbegin\r\n Result := CharInSet(C, [' ', ',', ';', ')', Cr, Lf]) or CharInSet(C, Delims);\r\nend;\r\n\r\nfunction IsLiteral(C: Char): Boolean;\r\nbegin\r\n case C of\r\n '''', '\"':\r\n Result := True;\r\n else\r\n Result := False;\r\n end;\r\nend;\r\n\r\nprocedure CreateMacros(List: TJvMacros; const Value: PChar; SpecialChar: Char; Delims: TCharSet);\r\nvar\r\n CurPos, StartPos: PChar;\r\n CurChar: Char;\r\n Literal: Boolean;\r\n EmbeddedLiteral: Boolean;\r\n Name: string;\r\n\r\n function StripLiterals(Buffer: PChar): string;\r\n var\r\n BufLen: Integer;\r\n TempBuf: PChar;\r\n\r\n procedure StripChar(Value: Char);\r\n var\r\n Len: Integer;\r\n begin\r\n if TempBuf^ = Value then\r\n StrMove(TempBuf, TempBuf + 1, BufLen - 1);\r\n Len := StrLen(TempBuf);\r\n if TempBuf[Len - 1] = Value then\r\n TempBuf[Len - 1] := #0;\r\n end;\r\n\r\n begin\r\n TempBuf := StrNew(Buffer);\r\n BufLen := StrLen(TempBuf) + 1;\r\n Result := '';\r\n try\r\n StripChar('''');\r\n StripChar('\"');\r\n Result := StrPas(TempBuf);\r\n finally\r\n StrDispose(TempBuf);\r\n end;\r\n end;\r\n\r\nbegin\r\n if SpecialChar = #0 then\r\n Exit;\r\n CurPos := Value;\r\n Literal := False;\r\n EmbeddedLiteral := False;\r\n repeat\r\n CurChar := CurPos^;\r\n if (CurChar = SpecialChar) and not Literal and ((CurPos + 1)^ <> SpecialChar) then\r\n begin\r\n StartPos := CurPos;\r\n while (CurChar <> #0) and (Literal or not NameDelimiter(CurChar, Delims)) do\r\n begin\r\n Inc(CurPos);\r\n CurChar := CurPos^;\r\n if IsLiteral(CurChar) then\r\n begin\r\n Literal := not Literal;\r\n if CurPos = StartPos + 1 then\r\n EmbeddedLiteral := True;\r\n end;\r\n end;\r\n CurPos^ := #0;\r\n if EmbeddedLiteral then\r\n begin\r\n Name := StripLiterals(StartPos + 1);\r\n EmbeddedLiteral := False;\r\n end\r\n else\r\n Name := StrPas(StartPos + 1);\r\n if Assigned(List) then\r\n if List.FindMacro(Name) = nil then\r\n List.CreateMacro(Name);\r\n CurPos^ := CurChar;\r\n StartPos^ := '?';\r\n Inc(StartPos);\r\n StrMove(StartPos, CurPos, StrLen(CurPos) + 1);\r\n CurPos := StartPos;\r\n end\r\n else\r\n if (CurChar = SpecialChar) and not Literal and ((CurPos + 1)^ = SpecialChar) then\r\n StrMove(CurPos, CurPos + 1, StrLen(CurPos) + 1)\r\n else\r\n if IsLiteral(CurChar) then\r\n Literal := not Literal;\r\n Inc(CurPos);\r\n until CurChar = #0;\r\nend;\r\n\r\n//=== { TJvMacro } ===========================================================\r\n\r\nconstructor TJvMacro.Create(Collection: TCollection);\r\nbegin\r\n inherited Create(Collection);\r\n FData := Unassigned;\r\nend;\r\n\r\nprocedure TJvMacro.Assign(Source: TPersistent);\r\nbegin\r\n if Source is TJvMacro then\r\n begin\r\n if VarIsEmpty(TJvMacro(Source).FData) then\r\n Clear\r\n else\r\n Value := TJvMacro(Source).FData;\r\n Name := TJvMacro(Source).Name;\r\n end\r\n else\r\n inherited Assign(Source);\r\nend;\r\n\r\nfunction TJvMacro.GetDisplayName: string;\r\nbegin\r\n if FName = '' then\r\n Result := inherited GetDisplayName\r\n else\r\n Result := FName;\r\nend;\r\n\r\nprocedure TJvMacro.SetDisplayName(const Value: string);\r\nbegin\r\n if (Value <> '') and (AnsiCompareText(Value, FName) <> 0) and\r\n (Collection is TJvMacros) and (TJvMacros(Collection).IndexOf(Value) >= 0) then\r\n raise EJVCLException.CreateRes(@SDuplicateString);\r\n FName := Value;\r\n inherited SetDisplayName(Value);\r\nend;\r\n\r\nprocedure TJvMacro.GetMacroText(var AText: string);\r\nbegin\r\n if Assigned(FOnGetText) then\r\n FOnGetText(Self, FData, AText);\r\nend;\r\n\r\nfunction TJvMacro.GetText: string;\r\nbegin\r\n Result := FData;\r\n GetMacroText(Result);\r\nend;\r\n\r\nfunction TJvMacro.GetMacros: TJvMacros;\r\nbegin\r\n if Collection is TJvMacros then\r\n Result := TJvMacros(Collection)\r\n else\r\n Result := nil;\r\nend;\r\n\r\nprocedure TJvMacro.Clear;\r\nbegin\r\n FData := Unassigned;\r\nend;\r\n\r\nfunction TJvMacro.IsMacroStored: Boolean;\r\nbegin\r\n Result := not VarIsEmpty(FData);\r\nend;\r\n\r\nfunction TJvMacro.GetAsVariant: Variant;\r\nbegin\r\n Result := FData;\r\nend;\r\n\r\nprocedure TJvMacro.SetAsVariant(Value: Variant);\r\nbegin\r\n FData := Value;\r\nend;\r\n\r\nfunction TJvMacro.IsEqual(Value: TJvMacro): Boolean;\r\nbegin\r\n Result := (VarType(FData) = VarType(Value.FData)) and\r\n (VarIsEmpty(FData) or (FData = Value.FData)) and\r\n (Name = Value.Name);\r\nend;\r\n\r\n//=== { TJvMacros } ==========================================================\r\n\r\nconstructor TJvMacros.Create(AOwner: TPersistent);\r\nbegin\r\n inherited Create(AOwner, TJvMacro);\r\nend;\r\n\r\nfunction TJvMacros.IndexOf(const AName: string): Integer;\r\nbegin\r\n for Result := 0 to Count - 1 do\r\n if AnsiSameText(TJvMacro(Items[Result]).Name, AName) then\r\n Exit;\r\n Result := -1;\r\nend;\r\n\r\nfunction TJvMacros.GetItem(Index: Integer): TJvMacro;\r\nbegin\r\n Result := TJvMacro(inherited Items[Index]);\r\nend;\r\n\r\nprocedure TJvMacros.SetItem(Index: Integer; Value: TJvMacro);\r\nbegin\r\n inherited SetItem(Index, TCollectionItem(Value));\r\nend;\r\n\r\nprocedure TJvMacros.AddMacro(Value: TJvMacro);\r\nbegin\r\n Value.Collection := Self;\r\nend;\r\n\r\nprocedure TJvMacros.RemoveMacro(Value: TJvMacro);\r\nbegin\r\n if Value.Collection = Self then\r\n Value.Collection := nil;\r\nend;\r\n\r\nfunction TJvMacros.CreateMacro(const MacroName: string): TJvMacro;\r\nbegin\r\n Result := Add as TJvMacro;\r\n Result.Name := MacroName;\r\nend;\r\n\r\nfunction TJvMacros.IsEqual(Value: TJvMacros): Boolean;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := Count = Value.Count;\r\n if Result then\r\n for I := 0 to Count - 1 do\r\n begin\r\n Result := Items[I].IsEqual(Value.Items[I]);\r\n if not Result then\r\n Break;\r\n end;\r\nend;\r\n\r\nfunction TJvMacros.MacroByName(const Value: string): TJvMacro;\r\nbegin\r\n Result := FindMacro(Value);\r\n if Result = nil then\r\n raise EJVCLException.CreateRes(@SInvalidPropertyValue);\r\nend;\r\n\r\nfunction TJvMacros.FindMacro(const Value: string): TJvMacro;\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := 0 to Count - 1 do\r\n begin\r\n Result := TJvMacro(inherited Items[I]);\r\n if AnsiSameText(Result.Name, Value) then\r\n Exit;\r\n end;\r\n Result := nil;\r\nend;\r\n\r\nprocedure TJvMacros.AssignValues(Value: TJvMacros);\r\nvar\r\n I: Integer;\r\n P: TJvMacro;\r\nbegin\r\n BeginUpdate;\r\n try\r\n for I := 0 to Value.Count - 1 do\r\n begin\r\n P := FindMacro(Value[I].Name);\r\n if P <> nil then\r\n P.Assign(Value[I]);\r\n end;\r\n finally\r\n EndUpdate;\r\n end;\r\nend;\r\n\r\nfunction TJvMacros.ParseString(const Value: string; DoCreate: Boolean;\r\n SpecialChar: Char): string;\r\nvar\r\n Macros: TJvMacros;\r\nbegin\r\n Result := Value;\r\n Macros := TJvMacros.Create(Self.GetOwner);\r\n try\r\n CreateMacros(Macros, PChar(Result), SpecialChar, ['.']);\r\n if DoCreate then\r\n begin\r\n Macros.AssignValues(Self);\r\n Self.Assign(Macros);\r\n end;\r\n finally\r\n Macros.Free;\r\n end;\r\nend;\r\n\r\nfunction TJvMacros.GetMacroValue(const MacroName: string): Variant;\r\nvar\r\n I: Integer;\r\n Macros: TList;\r\nbegin\r\n if Pos(';', MacroName) <> 0 then\r\n begin\r\n Macros := TList.Create;\r\n try\r\n GetMacroList(Macros, MacroName);\r\n Result := VarArrayCreate([0, Macros.Count - 1], varVariant);\r\n for I := 0 to Macros.Count - 1 do\r\n Result[I] := TJvMacro(Macros[I]).Value;\r\n finally\r\n Macros.Free;\r\n end;\r\n end\r\n else\r\n Result := MacroByName(MacroName).Value;\r\nend;\r\n\r\nprocedure TJvMacros.SetMacroValue(const MacroName: string;\r\n const Value: Variant);\r\nvar\r\n I: Integer;\r\n Macros: TList;\r\nbegin\r\n if Pos(';', MacroName) <> 0 then\r\n begin\r\n Macros := TList.Create;\r\n try\r\n GetMacroList(Macros, MacroName);\r\n for I := 0 to Macros.Count - 1 do\r\n TJvMacro(Macros[I]).Value := Value[I];\r\n finally\r\n Macros.Free;\r\n end;\r\n end\r\n else\r\n MacroByName(MacroName).Value := Value;\r\nend;\r\n\r\nprocedure TJvMacros.GetMacroList(List: TList; const MacroNames: string);\r\nvar\r\n Pos, Len: Integer;\r\nbegin\r\n Pos := 1;\r\n Len := Length(MacroNames);\r\n while Pos <= Len do\r\n List.Add(MacroByName(ExtractName(MacroNames, Pos)));\r\nend;\r\n\r\n//=== { TJvStrHolder } =======================================================\r\n\r\nconstructor TJvStrHolder.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FStrings := TStringList.Create;\r\n FMacros := TJvMacros.Create(Self);\r\n FMacroChar := '%';\r\n FStrings.OnChange := StringsChanged;\r\n FStrings.OnChanging := StringsChanging;\r\nend;\r\n\r\ndestructor TJvStrHolder.Destroy;\r\nbegin\r\n FOnChange := nil;\r\n FOnChanging := nil;\r\n FMacros.Free;\r\n FStrings.OnChange := nil;\r\n FStrings.OnChanging := nil;\r\n FStrings.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvStrHolder.Assign(Source: TPersistent);\r\nbegin\r\n if Source is TStrings then\r\n FStrings.Assign(Source)\r\n else\r\n if Source is TJvStrHolder then\r\n FStrings.Assign(TJvStrHolder(Source).Strings)\r\n else\r\n inherited Assign(Source);\r\nend;\r\n\r\nprocedure TJvStrHolder.AssignTo(Dest: TPersistent);\r\nbegin\r\n if Dest is TStrings then\r\n Dest.Assign(Strings)\r\n else\r\n inherited AssignTo(Dest);\r\nend;\r\n\r\nprocedure TJvStrHolder.Changed;\r\nbegin\r\n if Assigned(FOnChange) then\r\n FOnChange(Self);\r\nend;\r\n\r\nprocedure TJvStrHolder.Changing;\r\nbegin\r\n if Assigned(FOnChanging) then\r\n FOnChanging(Self);\r\nend;\r\n\r\nprocedure TJvStrHolder.Clear;\r\nbegin\r\n Strings.Clear;\r\nend;\r\n\r\nfunction TJvStrHolder.GetCommaText: string;\r\nbegin\r\n Result := Strings.CommaText;\r\nend;\r\n\r\nprocedure TJvStrHolder.SetCommaText(const Value: string);\r\nbegin\r\n Strings.CommaText := Value;\r\nend;\r\n\r\nfunction TJvStrHolder.GetCapacity: Integer;\r\nbegin\r\n Result := Strings.Capacity;\r\nend;\r\n\r\nprocedure TJvStrHolder.SetCapacity(NewCapacity: Integer);\r\nbegin\r\n Strings.Capacity := NewCapacity;\r\nend;\r\n\r\nprocedure TJvStrHolder.BeforeExpandMacros;\r\nbegin\r\n if Assigned(FOnExpandMacros) then\r\n FOnExpandMacros(Self);\r\nend;\r\n\r\nprocedure TJvStrHolder.SetMacros(Value: TJvMacros);\r\nbegin\r\n FMacros.AssignValues(Value);\r\nend;\r\n\r\nprocedure TJvStrHolder.RecreateMacros;\r\nbegin\r\n if not (csReading in ComponentState) then\r\n Macros.ParseString(Strings.Text, True, MacroChar);\r\nend;\r\n\r\nprocedure TJvStrHolder.SetMacroChar(Value: Char);\r\nbegin\r\n if Value <> FMacroChar then\r\n begin\r\n FMacroChar := Value;\r\n RecreateMacros;\r\n end;\r\nend;\r\n\r\nfunction TJvStrHolder.MacroCount: Integer;\r\nbegin\r\n Result := Macros.Count;\r\nend;\r\n\r\nfunction TJvStrHolder.MacroByName(const MacroName: string): TJvMacro;\r\nbegin\r\n Result := Macros.MacroByName(MacroName);\r\nend;\r\n\r\nfunction TJvStrHolder.ExpandMacros: string;\r\nvar\r\n I, J, P, LiteralChars: Integer;\r\n Macro: TJvMacro;\r\n Found: Boolean;\r\nbegin\r\n BeforeExpandMacros;\r\n Result := Strings.Text;\r\n for I := Macros.Count - 1 downto 0 do\r\n begin\r\n Macro := Macros[I];\r\n if not VarIsEmpty(Macro.FData) then\r\n begin\r\n repeat\r\n P := Pos(MacroChar + Macro.Name, Result);\r\n Found := (P > 0) and ((Length(Result) = P + Length(Macro.Name)) or\r\n NameDelimiter(Result[P + Length(Macro.Name) + 1], ['.']));\r\n if Found then\r\n begin\r\n LiteralChars := 0;\r\n for J := 1 to P - 1 do\r\n if IsLiteral(Result[J]) then\r\n Inc(LiteralChars);\r\n Found := LiteralChars mod 2 = 0;\r\n if Found then\r\n begin\r\n Result := Copy(Result, 1, P - 1) + Macro.Text + Copy(Result,\r\n P + Length(Macro.Name) + 1, MaxInt);\r\n end;\r\n end;\r\n until not Found;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvStrHolder.DefineProperties(Filer: TFiler);\r\n\r\n function DoWrite: Boolean;\r\n var\r\n I: Integer;\r\n Ancestor: TJvStrHolder;\r\n begin\r\n Ancestor := TJvStrHolder(Filer.Ancestor);\r\n Result := False;\r\n if (Ancestor <> nil) and (Ancestor.Strings.Count = Strings.Count) and\r\n (KeyString = Ancestor.KeyString) and (Strings.Count > 0) then\r\n for I := 0 to Strings.Count - 1 do\r\n begin\r\n Result := CompareText(Strings[I], Ancestor.Strings[I]) <> 0;\r\n if Result then\r\n Break;\r\n end\r\n else\r\n Result := (Strings.Count > 0) or (KeyString <> '');\r\n end;\r\n\r\nbegin\r\n inherited DefineProperties(Filer);\r\n { for backward compatibility }\r\n Filer.DefineProperty('InternalVer', ReadVersion, WriteVersion, Filer.Ancestor = nil);\r\n Filer.DefineProperty('StrData', ReadStrings, WriteStrings, DoWrite);\r\nend;\r\n\r\nfunction TJvStrHolder.GetSorted: Boolean;\r\nbegin\r\n Result := FStrings.Sorted;\r\nend;\r\n\r\nfunction TJvStrHolder.GetDuplicates: TDuplicates;\r\nbegin\r\n Result := FStrings.Duplicates;\r\nend;\r\n\r\nprocedure TJvStrHolder.ReadStrings(Reader: TReader);\r\nvar\r\n Tmp: string;\r\nbegin\r\n Strings.BeginUpdate;\r\n try\r\n Reader.ReadListBegin;\r\n if not Reader.EndOfList then\r\n KeyString := Reader.ReadString;\r\n Strings.Clear;\r\n while not Reader.EndOfList do\r\n begin\r\n Tmp := Reader.ReadString;\r\n if FReserved >= AnsiXorVersion then\r\n begin\r\n if FReserved >= XorVersion then\r\n Strings.Add(XorDecodeString(KeyString, Tmp))\r\n else\r\n {$WARNINGS OFF} // XorDecode is deprecated, but we need it for backward compatibility, so hide the warning\r\n Strings.Add(XorDecode(KeyString, Tmp));\r\n {$WARNINGS ON}\r\n end\r\n else\r\n Strings.Add(string(XorString(ShortString(KeyString), ShortString(Tmp))));\r\n end;\r\n Reader.ReadListEnd;\r\n finally\r\n Strings.EndUpdate;\r\n end;\r\nend;\r\n\r\nprocedure TJvStrHolder.SetDuplicates(Value: TDuplicates);\r\nbegin\r\n FStrings.Duplicates := Value;\r\nend;\r\n\r\nprocedure TJvStrHolder.SetSorted(Value: Boolean);\r\nbegin\r\n FStrings.Sorted := Value;\r\nend;\r\n\r\nfunction TJvStrHolder.GetStrings: TStrings;\r\nbegin\r\n Result := FStrings;\r\nend;\r\n\r\nprocedure TJvStrHolder.SetStrings(Value: TStrings);\r\nbegin\r\n if Value <> FStrings then\r\n FStrings.Assign(Value);\r\nend;\r\n\r\nprocedure TJvStrHolder.StringsChanged(Sender: TObject);\r\nbegin\r\n RecreateMacros;\r\n if not (csReading in ComponentState) then\r\n Changed;\r\nend;\r\n\r\nprocedure TJvStrHolder.StringsChanging(Sender: TObject);\r\nbegin\r\n if not (csReading in ComponentState) then\r\n Changing;\r\nend;\r\n\r\nprocedure TJvStrHolder.WriteStrings(Writer: TWriter);\r\nvar\r\n I: Integer;\r\nbegin\r\n Writer.WriteListBegin;\r\n Writer.WriteString(KeyString);\r\n for I := 0 to Strings.Count - 1 do\r\n Writer.WriteString(XorEncodeString(KeyString, Strings[I]));\r\n Writer.WriteListEnd;\r\nend;\r\n\r\nprocedure TJvStrHolder.ReadVersion(Reader: TReader);\r\nbegin\r\n FReserved := Reader.ReadInteger;\r\nend;\r\n\r\nprocedure TJvStrHolder.WriteVersion(Writer: TWriter);\r\nbegin\r\n Writer.WriteInteger(XorVersion);\r\nend;\r\n\r\n//=== { TJvMultiStringHolderCollectionItem } =================================\r\n\r\nprocedure TJvMultiStringHolderCollectionItem.SetName(Value: string);\r\nbegin\r\n Value := Trim(Value);\r\n if Value = '' then\r\n FName := ''\r\n else\r\n begin\r\n if not TJvMultiStringHolderCollection(Collection).DoesNameExist(Value) then\r\n FName := Value\r\n else\r\n raise EJVCLException.CreateRes(@SDuplicateString);\r\n end;\r\nend;\r\n\r\nprocedure TJvMultiStringHolderCollectionItem.SetStrings(const Value: TStrings);\r\nbegin\r\n if Value <> FStrings then\r\n FStrings.Assign(Value);\r\nend;\r\n\r\nfunction TJvMultiStringHolderCollectionItem.GetDisplayName: string;\r\nbegin\r\n if FName <> '' then\r\n Result := FName\r\n else\r\n Result := RsNoName;\r\nend;\r\n\r\nconstructor TJvMultiStringHolderCollectionItem.Create(Collection: TCollection);\r\nbegin\r\n inherited Create(Collection);\r\n FStrings := TStringList.Create;\r\nend;\r\n\r\ndestructor TJvMultiStringHolderCollectionItem.Destroy;\r\nbegin\r\n FStrings.Free;\r\n inherited Destroy;\r\nend;\r\n\r\n//=== { TJvMultiStringHolderCollection } =====================================\r\n\r\nfunction TJvMultiStringHolderCollection.GetItem(Index: Integer): TJvMultiStringHolderCollectionItem;\r\nbegin\r\n Result := TJvMultiStringHolderCollectionItem(inherited GetItem(Index));\r\nend;\r\n\r\nprocedure TJvMultiStringHolderCollection.SetItem(Index: Integer; Value: TJvMultiStringHolderCollectionItem);\r\nbegin\r\n inherited SetItem(Index, Value);\r\nend;\r\n\r\nfunction TJvMultiStringHolderCollection.DoesNameExist(const Name: string): Boolean;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := True;\r\n for I := 0 to Count - 1 do\r\n if CompareText(Items[I].Name, Name) = 0 then\r\n Exit;\r\n Result := False;\r\nend;\r\n\r\nfunction TJvMultiStringHolderCollection.Add: TJvMultiStringHolderCollectionItem;\r\nbegin\r\n Result := TJvMultiStringHolderCollectionItem(inherited Add);\r\nend;\r\n\r\nfunction TJvMultiStringHolderCollection.Insert(Index: Integer): TJvMultiStringHolderCollectionItem;\r\nbegin\r\n Result := Add;\r\n Result.Index := Index;\r\nend;\r\n\r\n//=== { TJvMultiStringHolder } ===============================================\r\n\r\nconstructor TJvMultiStringHolder.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FMultipleStrings := TJvMultiStringHolderCollection.Create(Self, TJvMultiStringHolderCollectionItem);\r\nend;\r\n\r\ndestructor TJvMultiStringHolder.Destroy;\r\nbegin\r\n FMultipleStrings.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvMultiStringHolder.SetMultipleStrings(Value: TJvMultiStringHolderCollection);\r\nbegin\r\n if Value <> FMultipleStrings then\r\n FMultipleStrings.Assign(Value);\r\nend;\r\n\r\nfunction TJvMultiStringHolder.GetItemByName(const Name: string): TJvMultiStringHolderCollectionItem;\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := 0 to MultipleStrings.Count - 1 do\r\n if CompareText(MultipleStrings.Items[I].Name, Name) = 0 then\r\n begin\r\n Result := MultipleStrings.Items[I];\r\n Exit;\r\n end;\r\n raise EJvMultiStringHolderException.CreateResFmt(@RsENoItemFoundWithName, [Name]);\r\nend;\r\n\r\nfunction TJvMultiStringHolder.GetStringsByName(const Name: string): TStrings;\r\nbegin\r\n Result := GetItemByName(Name).Strings;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvStringListToHtml.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvStringListToHtml.PAS, released on 2001-02-28.\r\n\r\nThe Initial Developer of the Original Code is Sbastien Buysse [sbuysse att buypin dott com]\r\nPortions created by Sbastien Buysse are Copyright (C) 2001 Sbastien Buysse.\r\nAll Rights Reserved.\r\n\r\nContributor(s): Michael Beck [mbeck att bigfoot dott com].\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvStringListToHtml.pas 13104 2011-09-07 06:50:43Z obones $\r\n\r\nunit JvStringListToHtml;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n SysUtils, Classes,\r\n JvComponentBase;\r\n\r\ntype\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64 or pidOSX32)]\r\n {$ENDIF RTL230_UP}\r\n TJvStringListToHtml = class(TJvComponent)\r\n private\r\n FStrings: TStringList;\r\n FHTML: TStringList;\r\n FHTMLTitle: string;\r\n FHTMLLineBreak: string;\r\n FIncludeHeader: Boolean;\r\n function GetHTML: TStrings;\r\n function GetStrings: TStrings;\r\n procedure SetStrings(const Value: TStrings);\r\n procedure DoStringsChange(Sender: TObject);\r\n procedure SetHTML(const Value: TStrings);\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n procedure ConvertToHTML(Source: TStrings; const FileName: string);\r\n procedure ConvertToHTMLStrings(Source, Destination: TStrings);\r\n published\r\n property HTML: TStrings read GetHTML write SetHTML stored False;\r\n property Strings: TStrings read GetStrings write SetStrings;\r\n property HTMLLineBreak: string read FHTMLLineBreak write FHTMLLineBreak;\r\n property HTMLTitle: string read FHTMLTitle write FHTMLTitle;\r\n property IncludeHeader: Boolean read FIncludeHeader write FIncludeHeader default True;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvStringListToHtml.pas $';\r\n Revision: '$Revision: 13104 $';\r\n Date: '$Date: 2011-09-07 08:50:43 +0200 (mer. 07 sept. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\n\r\nprocedure ConvertStringsToHTML(Source, Destination: TStrings; const HTMLTitle, HTMLLineBreak: string; IncludeHeader: Boolean);\r\nvar\r\n I: Integer;\r\nbegin\r\n if (Source = nil) or (Destination = nil) then\r\n Exit;\r\n Destination.BeginUpdate;\r\n Source.BeginUpdate;\r\n try\r\n if IncludeHeader then\r\n begin\r\n Destination.Add('');\r\n Destination.Add('' + HTMLTitle + '');\r\n Destination.Add('');\r\n end;\r\n for I := 0 to Source.Count - 1 do\r\n Destination.Add(Source[I] + HTMLLineBreak);\r\n if IncludeHeader then\r\n begin\r\n Destination.Add('');\r\n Destination.Add('');\r\n end;\r\n finally\r\n Source.EndUpdate;\r\n Destination.EndUpdate;\r\n end;\r\nend;\r\n\r\nprocedure TJvStringListToHtml.ConvertToHTML(Source: TStrings; const FileName: string);\r\nvar\r\n Dest: TStringList;\r\nbegin\r\n if Source = nil then\r\n Exit;\r\n Dest := TStringList.Create;\r\n try\r\n ConvertStringsToHTML(Source, Dest, HTMLTitle, HTMLLineBreak, True);\r\n Dest.SaveToFile(FileName);\r\n finally\r\n Dest.Free;\r\n end;\r\nend;\r\n\r\nprocedure TJvStringListToHtml.ConvertToHTMLStrings(Source, Destination: TStrings);\r\nbegin\r\n ConvertStringsToHTML(Source, Destination, HTMLTitle, HTMLLineBreak, IncludeHeader);\r\nend;\r\n\r\nconstructor TJvStringListToHtml.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FStrings := TStringList.Create;\r\n FHTML := TStringList.Create;\r\n FStrings.OnChange := DoStringsChange;\r\n FHTMLLineBreak := '
    ';\r\n FHTMLTitle := 'Converted by TJvStringListToHtml';\r\n FIncludeHeader := True;\r\nend;\r\n\r\ndestructor TJvStringListToHtml.Destroy;\r\nbegin\r\n FreeAndNil(FStrings);\r\n FreeAndNil(FHTML);\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvStringListToHtml.DoStringsChange(Sender: TObject);\r\nbegin\r\n FreeAndNil(FHTML);\r\nend;\r\n\r\nfunction TJvStringListToHtml.GetHTML: TStrings;\r\nbegin\r\n if ComponentState * [csLoading, csDestroying] <> [] then\r\n if FHTML.Count = 0 then\r\n ConvertToHTMLStrings(Strings, FHTML);\r\n Result := FHTML;\r\nend;\r\n\r\nprocedure TJvStringListToHtml.SetHTML(const Value: TStrings);\r\nbegin\r\n // do nothing\r\nend;\r\n\r\nfunction TJvStringListToHtml.GetStrings: TStrings;\r\nbegin\r\n Result := FStrings;\r\nend;\r\n\r\nprocedure TJvStringListToHtml.SetStrings(const Value: TStrings);\r\nbegin\r\n FStrings.Assign(Value);\r\n FHTML.Clear;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvStrings.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvStrings.PAS, released on 2002-06-15.\r\n\r\nThe Initial Developer of the Original Code is Jan Verhoeven [jan1 dott verhoeven att wxs dott nl]\r\nPortions created by Jan Verhoeven are Copyright (C) 2002 Jan Verhoeven.\r\nAll Rights Reserved.\r\n\r\nContributor(s): Robert Love [rlove att slcdug dott org].\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n Should be merged with JCL\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvStrings.pas 13145 2011-11-02 21:15:19Z ahuser $\r\n\r\nunit JvStrings;\r\n\r\n{$I jvcl.inc}\r\n{$I crossplatform.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n {$IFDEF MSWINDOWS}\r\n Windows,\r\n {$ENDIF MSWINDOWS}\r\n Graphics,\r\n SysUtils, Classes;\r\n\r\n{regular expressions}\r\n\r\n{template functions}\r\nfunction ReplaceFirst(const SourceStr, FindStr, ReplaceStr: string): string;\r\nfunction ReplaceLast(const SourceStr, FindStr, ReplaceStr: string): string;\r\nfunction InsertLastBlock(var SourceStr: string; BlockStr: string): Boolean;\r\nfunction RemoveMasterBlocks(const SourceStr: string): string;\r\nfunction RemoveFields(const SourceStr: string): string;\r\n\r\n{http functions}\r\nfunction URLEncode(const Value: AnsiString): AnsiString; // Converts string To A URLEncoded string\r\nfunction URLDecode(const Value: AnsiString): AnsiString; // Converts string From A URLEncoded string\r\n\r\n{set functions}\r\nprocedure SplitSet(AText: string; AList: TStringList);\r\nfunction JoinSet(AList: TStringList): string;\r\nfunction FirstOfSet(const AText: string): string;\r\nfunction LastOfSet(const AText: string): string;\r\nfunction CountOfSet(const AText: string): Integer;\r\nfunction SetRotateRight(const AText: string): string;\r\nfunction SetRotateLeft(const AText: string): string;\r\nfunction SetPick(const AText: string; AIndex: Integer): string;\r\nfunction SetSort(const AText: string): string;\r\nfunction SetUnion(const Set1, Set2: string): string;\r\nfunction SetIntersect(const Set1, Set2: string): string;\r\nfunction SetExclude(const Set1, Set2: string): string;\r\n\r\n{replace any <,> etc by < >}\r\nfunction XMLSafe(const AText: string): string;\r\n\r\n{simple hash, Result can be used in Encrypt}\r\nfunction Hash(const AText: string): Integer;\r\n\r\n{ Base64 encode and decode a string }\r\nfunction B64Encode(const S: AnsiString): AnsiString;\r\nfunction B64Decode(const S: AnsiString): AnsiString;\r\n\r\n{Basic encryption from a Borland Example}\r\nfunction Encrypt(const InString: AnsiString; StartKey, MultKey, AddKey: Integer): AnsiString;\r\nfunction Decrypt(const InString: AnsiString; StartKey, MultKey, AddKey: Integer): AnsiString;\r\n\r\n{Using Encrypt and Decrypt in combination with B64Encode and B64Decode}\r\nfunction EncryptB64(const InString: AnsiString; StartKey, MultKey, AddKey: Integer): AnsiString;\r\nfunction DecryptB64(const InString: AnsiString; StartKey, MultKey, AddKey: Integer): AnsiString;\r\n\r\nprocedure CSVToTags(Src, Dst: TStringList);\r\n// converts a csv list to a tagged string list\r\n\r\nprocedure TagsToCSV(Src, Dst: TStringList);\r\n// converts a tagged string list to a csv list\r\n// only fieldnames from the first record are scanned ib the other records\r\n\r\nprocedure ListSelect(Src, Dst: TStringList; const AKey, AValue: string);\r\n{selects akey=avalue from Src and returns recordset in Dst}\r\n\r\nprocedure ListFilter(Src: TStringList; const AKey, AValue: string);\r\n{filters Src for akey=avalue}\r\n\r\nprocedure ListOrderBy(Src: TStringList; const AKey: string; Numeric: Boolean);\r\n{orders a tagged Src list by akey}\r\n\r\nfunction PosStr(const FindString, SourceString: string;\r\n StartPos: Integer = 1): Integer;\r\n{ PosStr searches the first occurrence of a substring FindString in a string\r\n given by SourceString with case sensitivity (upper and lower case characters\r\n are differed). This function returns the index value of the first character\r\n of a specified substring from which it occurs in a given string starting with\r\n StartPos character index. If a specified substring is not found Q_PosStr\r\n returns zero. The author of algorithm is Peter Morris (UK) (Faststrings unit\r\n from www.torry.ru). }\r\n\r\nfunction PosStrLast(const FindString, SourceString: string): Integer;\r\n{finds the last occurance}\r\n\r\nfunction LastPosChar(const FindChar: Char; SourceString: string): Integer;\r\n\r\nfunction PosText(const FindString, SourceString: string;\r\n StartPos: Integer = 1): Integer;\r\n{ PosText searches the first occurrence of a substring FindString in a string\r\n given by SourceString without case sensitivity (upper and lower case\r\n characters are not differed). This function returns the index value of the\r\n first character of a specified substring from which it occurs in a given\r\n string starting with StartPos character index. If a specified substring is\r\n not found Q_PosStr returns zero. The author of algorithm is Peter Morris\r\n (UK) (Faststrings unit from www.torry.ru). }\r\n\r\nfunction PosTextLast(const FindString, SourceString: string): Integer;\r\n{finds the last occurance}\r\n\r\nfunction NameValuesToXML(const AText: string): string;\r\n{$IFDEF MSWINDOWS}\r\nprocedure LoadResourceFile(AFile: string; MemStream: TMemoryStream);\r\n{$ENDIF MSWINDOWS}\r\nprocedure DirFiles(const ADir, AMask: string; AFileList: TStringList);\r\nprocedure RecurseDirFiles(const ADir: string; var AFileList: TStringList);\r\nprocedure RecurseDirProgs(const ADir: string; var AFileList: TStringList);\r\nprocedure SaveString(const AFile, AText: string);\r\nfunction LoadString(const AFile: string): string;\r\nfunction HexToColor(const AText: string): TColor;\r\nfunction UppercaseHTMLTags(const AText: string): string;\r\nfunction LowercaseHTMLTags(const AText: string): string;\r\nprocedure GetHTMLAnchors(const AFile: string; AList: TStringList);\r\nfunction RelativePath(const ASrc, ADst: string): string;\r\nfunction GetToken(var Start: Integer; const SourceText: string): string;\r\nfunction PosNonSpace(Start: Integer; const SourceText: string): Integer;\r\nfunction PosEscaped(Start: Integer; const SourceText, FindText: string; EscapeChar: Char): Integer;\r\nfunction DeleteEscaped(const SourceText: string; EscapeChar: Char): string;\r\nfunction BeginOfAttribute(Start: Integer; const SourceText: string): Integer;\r\n// parses the beginning of an attribute: space + alpha character\r\nfunction ParseAttribute(var Start: Integer; const SourceText: string; var AName, AValue: string): Boolean;\r\n// parses a name=\"value\" attribute from Start; returns 0 when not found or else the position behind the attribute\r\nprocedure ParseAttributes(const SourceText: string; Attributes: TStrings);\r\n// parses all name=value attributes to the attributes TStringList\r\nfunction HasStrValue(const AText, AName: string; var AValue: string): Boolean;\r\n// checks if a name=\"value\" pair exists and returns any value\r\nfunction GetStrValue(const AText, AName, ADefault: string): string;\r\n// retrieves string value from a line like:\r\n// name=\"jan verhoeven\" email=\"jan1 dott verhoeven att wxs dott nl\"\r\n// returns ADefault when not found\r\nfunction GetHTMLColorValue(const AText, AName: string; ADefault: TColor): TColor;\r\n// same for a color\r\nfunction GetIntValue(const AText, AName: string; ADefault: Integer): Integer;\r\n// same for an Integer\r\nfunction GetFloatValue(const AText, AName: string; ADefault: Extended): Extended;\r\n// same for a float\r\nfunction GetBoolValue(const AText, AName: string): Boolean;\r\n// same for Boolean but without default\r\nfunction GetValue(const AText, AName: string): string;\r\n// retrieves string value from a line like:\r\n// name=\"jan verhoeven\" email=\"jan1 dott verhoeven att wxs dott nl\"\r\nprocedure SetValue(var AText: string; const AName, AValue: string);\r\n// sets a string value in a line\r\nprocedure DeleteValue(var AText: string; const AName: string);\r\n// deletes a AName=\"value\" pair from AText\r\n\r\nprocedure GetNames(AText: string; AList: TStringList);\r\n// get a list of names from a string with name=\"value\" pairs\r\nfunction GetHTMLColor(AColor: TColor): string;\r\n// converts a color value to the HTML hex value\r\nfunction BackPosStr(Start: Integer; const FindString, SourceString: string): Integer;\r\n// finds a string backward case sensitive\r\nfunction BackPosText(Start: Integer; const FindString, SourceString: string): Integer;\r\n// finds a string backward case insensitive\r\nfunction PosRangeStr(Start: Integer; const HeadString, TailString, SourceString: string;\r\n var RangeBegin: Integer; var RangeEnd: Integer): Boolean;\r\n// finds a text range, e.g. .... case sensitive\r\nfunction PosRangeText(Start: Integer; const HeadString, TailString, SourceString: string;\r\n var RangeBegin: Integer; var RangeEnd: Integer): Boolean;\r\n// finds a text range, e.g. .... case insensitive\r\nfunction BackPosRangeStr(Start: Integer; const HeadString, TailString, SourceString: string;\r\n var RangeBegin: Integer; var RangeEnd: Integer): Boolean;\r\n// finds a text range backward, e.g. .... case sensitive\r\nfunction BackPosRangeText(Start: Integer; const HeadString, TailString, SourceString: string;\r\n var RangeBegin: Integer; var RangeEnd: Integer): Boolean;\r\n// finds a text range backward, e.g. .... case insensitive\r\nfunction PosTag(Start: Integer; SourceString: string; var RangeBegin: Integer;\r\n var RangeEnd: Integer): Boolean;\r\n// finds a HTML or XML tag: <....>\r\nfunction InnerTag(Start: Integer; const HeadString, TailString, SourceString: string;\r\n var RangeBegin: Integer; var RangeEnd: Integer): Boolean;\r\n// finds the innertext between opening and closing tags\r\nfunction Easter(NYear: Integer): TDateTime;\r\n// returns the easter date of a year.\r\nfunction GetWeekNumber(Today: TDateTime): string;\r\n//gets a datecode. Returns year and weeknumber in format: YYWW\r\n\r\nfunction ParseNumber(const S: string): Integer;\r\n// parse number returns the last position, starting from 1\r\nfunction ParseDate(const S: string): Integer;\r\n// parse a SQL style data string from positions 1,\r\n// starts and ends with #\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvStrings.pas $';\r\n Revision: '$Revision: 13145 $';\r\n Date: '$Date: 2011-11-02 22:15:19 +0100 (mer. 02 nov. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n {$IFDEF RTL200_UP}\r\n AnsiStrings,\r\n {$ENDIF RTL200_UP}\r\n {$IFNDEF COMPILER12_UP}\r\n JvJCLUtils,\r\n {$ENDIF ~COMPILER12_UP}\r\n JvConsts, JvResources, JvTypes;\r\n\r\nconst\r\n B64Table: AnsiString = 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/';\r\n ValidURLChars: AnsiString = 'ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789$-_@.&+-!*\"''(),;/#?:';\r\n\r\nprocedure SaveString(const AFile, AText: string);\r\nbegin\r\n with TFileStream.Create(AFile, fmCreate) do\r\n try\r\n WriteBuffer(AText[1], Length(AText));\r\n finally\r\n Free;\r\n end;\r\nend;\r\n\r\nfunction LoadString(const AFile: string): string;\r\nvar\r\n S: string;\r\nbegin\r\n with TFileStream.Create(AFile, fmOpenRead) do\r\n try\r\n SetLength(S, Size);\r\n ReadBuffer(S[1], Size);\r\n finally\r\n Free;\r\n end;\r\n Result := S;\r\nend;\r\n\r\nprocedure DeleteValue(var AText: string; const AName: string);\r\nvar\r\n P, P2, L: Integer;\r\nbegin\r\n L := Length(AName) + 2;\r\n P := PosText(AName + '=\"', AText);\r\n if P = 0 then\r\n Exit;\r\n P2 := PosStr('\"', AText, P + L);\r\n if P2 = 0 then\r\n Exit;\r\n if P > 1 then\r\n Dec(P); // include the preceding space if not the first one\r\n Delete(AText, P, P2 - P + 1);\r\nend;\r\n\r\nfunction GetValue(const AText, AName: string): string;\r\nvar\r\n P, P2, L: Integer;\r\nbegin\r\n Result := '';\r\n L := Length(AName) + 2;\r\n P := PosText(AName + '=\"', AText);\r\n if P = 0 then\r\n Exit;\r\n P2 := PosStr('\"', AText, P + L);\r\n if P2 = 0 then\r\n Exit;\r\n Result := Copy(AText, P + L, P2 - (P + L));\r\n Result := SysUtils.StringReplace(Result, '~~', Cr, [rfReplaceAll]);\r\nend;\r\n\r\nfunction HasStrValue(const AText, AName: string; var AValue: string): Boolean;\r\nvar\r\n P, P2, L: Integer;\r\n S: string;\r\nbegin\r\n Result := False;\r\n L := Length(AName) + 2;\r\n P := PosText(AName + '=\"', AText);\r\n if P = 0 then\r\n Exit;\r\n P2 := PosStr('\"', AText, P + L);\r\n if P2 = 0 then\r\n Exit;\r\n S := Copy(AText, P + L, P2 - (P + L));\r\n AValue := SysUtils.StringReplace(S, '~~', Cr, [rfReplaceAll]);\r\n Result := True;\r\nend;\r\n\r\nfunction GetStrValue(const AText, AName, ADefault: string): string;\r\nvar\r\n S: string;\r\nbegin\r\n S := '';\r\n if HasStrValue(AText, AName, S) then\r\n Result := S\r\n else\r\n Result := ADefault;\r\nend;\r\n\r\nfunction GetIntValue(const AText, AName: string; ADefault: Integer): Integer;\r\nvar\r\n S: string;\r\nbegin\r\n S := GetValue(AText, AName);\r\n try\r\n Result := StrToInt(S);\r\n except\r\n Result := ADefault;\r\n end;\r\nend;\r\n\r\nfunction GetFloatValue(const AText, AName: string; ADefault: Extended): Extended;\r\nvar\r\n S: string;\r\nbegin\r\n S := '';\r\n if HasStrValue(AText, AName, S) then\r\n try\r\n Result := StrToFloat(S);\r\n except\r\n Result := ADefault;\r\n end\r\n else\r\n Result := ADefault;\r\nend;\r\n\r\nfunction GetHTMLColorValue(const AText, AName: string; ADefault: TColor): TColor;\r\nvar\r\n S: string;\r\nbegin\r\n S := '';\r\n if HasStrValue(AText, AName, S) then\r\n begin\r\n if Copy(S, 1, 1) = '#' then\r\n S := '$' + Copy(S, 6, 2) + Copy(S, 4, 2) + Copy(S, 2, 2)\r\n else\r\n S := 'cl' + S;\r\n try\r\n Result := StringToColor(S);\r\n except\r\n Result := ADefault;\r\n end;\r\n end\r\n else\r\n Result := ADefault;\r\nend;\r\n\r\nprocedure SetValue(var AText: string; const AName, AValue: string);\r\nvar\r\n P, P2, L: Integer;\r\nbegin\r\n L := Length(AName) + 2;\r\n if AText = '' then\r\n AText := AName + '=\"' + AValue + '\"'\r\n else\r\n begin\r\n P := PosText(AName + '=\"', AText);\r\n if P = 0 then\r\n AText := AText + ' ' + AName + '=\"' + AValue + '\"'\r\n else\r\n begin\r\n P2 := PosStr('\"', AText, P + L);\r\n if P2 = 0 then\r\n Exit;\r\n Delete(AText, P + L, P2 - (P + L));\r\n Insert(AValue, AText, P + L);\r\n end;\r\n end;\r\nend;\r\n\r\nfunction GetHTMLColor(AColor: TColor): string;\r\nbegin\r\n Result := Format('%6.6x', [ColorToRGB(AColor)]);\r\n Result := '=\"#' + Copy(Result, 5, 2) + Copy(Result, 3, 2) + Copy(Result, 1, 2) + '\"';\r\nend;\r\n\r\nfunction BackPosStr(Start: Integer; const FindString, SourceString: string): Integer;\r\nvar\r\n P, L: Integer;\r\nbegin\r\n Result := 0;\r\n L := Length(FindString);\r\n if (L = 0) or (SourceString = '') or (Start < 2) then\r\n Exit;\r\n Start := Start - L;\r\n if Start < 1 then\r\n Exit;\r\n repeat\r\n P := PosStr(FindString, SourceString, Start);\r\n if P < Start then\r\n begin\r\n Result := P;\r\n Exit;\r\n end;\r\n Start := Start - L;\r\n until Start < 1;\r\nend;\r\n\r\nfunction BackPosText(Start: Integer; const FindString, SourceString: string): Integer;\r\nvar\r\n P, L, From: Integer;\r\nbegin\r\n Result := 0;\r\n L := Length(FindString);\r\n if (L = 0) or (SourceString = '') or (Start < 2) then\r\n Exit;\r\n From := Start - L;\r\n if From < 1 then\r\n Exit;\r\n repeat\r\n P := PosText(FindString, SourceString, From);\r\n if P < Start then\r\n begin\r\n Result := P;\r\n Exit;\r\n end;\r\n From := From - L;\r\n until From < 1;\r\nend;\r\n\r\nfunction PosRangeStr(Start: Integer; const HeadString, TailString, SourceString: string;\r\n var RangeBegin: Integer; var RangeEnd: Integer): Boolean;\r\nbegin\r\n Result := False;\r\n RangeBegin := PosStr(HeadString, SourceString, Start);\r\n if RangeBegin = 0 then\r\n Exit;\r\n RangeEnd := PosStr(TailString, SourceString, RangeBegin + Length(HeadString));\r\n if RangeEnd = 0 then\r\n Exit;\r\n RangeEnd := RangeEnd + Length(TailString) - 1;\r\n Result := True;\r\nend;\r\n\r\nfunction PosRangeText(Start: Integer; const HeadString, TailString, SourceString: string;\r\n var RangeBegin: Integer; var RangeEnd: Integer): Boolean;\r\nbegin\r\n Result := False;\r\n RangeBegin := PosText(HeadString, SourceString, Start);\r\n if RangeBegin = 0 then\r\n Exit;\r\n RangeEnd := PosText(TailString, SourceString, RangeBegin + Length(HeadString));\r\n if RangeEnd = 0 then\r\n Exit;\r\n RangeEnd := RangeEnd + Length(TailString) - 1;\r\n Result := True;\r\nend;\r\n\r\nfunction InnerTag(Start: Integer; const HeadString, TailString, SourceString: string;\r\n var RangeBegin: Integer; var RangeEnd: Integer): Boolean;\r\nbegin\r\n Result := False;\r\n RangeBegin := PosText(HeadString, SourceString, Start);\r\n if RangeBegin = 0 then\r\n Exit;\r\n RangeBegin := RangeBegin + Length(HeadString);\r\n RangeEnd := PosText(TailString, SourceString, RangeBegin + Length(HeadString));\r\n if RangeEnd = 0 then\r\n Exit;\r\n RangeEnd := RangeEnd - 1;\r\n Result := True;\r\nend;\r\n\r\nfunction PosTag(Start: Integer; SourceString: string; var RangeBegin: Integer; var RangeEnd: Integer): Boolean;\r\nbegin\r\n Result := PosRangeStr(Start, '<', '>', SourceString, RangeBegin, RangeEnd);\r\nend;\r\n\r\nfunction BackPosRangeStr(Start: Integer; const HeadString, TailString, SourceString: string;\r\n var RangeBegin: Integer; var RangeEnd: Integer): Boolean;\r\nvar\r\n L: Integer;\r\nbegin\r\n // finds a text range backward, e.g. .... case sensitive\r\n Result := False;\r\n L := Length(HeadString);\r\n if (L = 0) or (Start < 2) then\r\n Exit;\r\n Start := Start - L;\r\n if Start < 1 then\r\n Exit;\r\n repeat\r\n if not PosRangeStr(Start, HeadString, TailString, SourceString, RangeBegin, RangeEnd) then\r\n Exit;\r\n if RangeBegin < Start then\r\n begin\r\n Result := True;\r\n Exit;\r\n end;\r\n Start := Start - L;\r\n until Start < 1;\r\nend;\r\n\r\nfunction BackPosRangeText(Start: Integer; const HeadString, TailString, SourceString: string;\r\n var RangeBegin: Integer; var RangeEnd: Integer): Boolean;\r\nvar\r\n L: Integer;\r\nbegin\r\n // finds a text range backward, e.g. .... case insensitive\r\n Result := False;\r\n L := Length(HeadString);\r\n if (L = 0) or (Start < 2) then\r\n Exit;\r\n Start := Start - L;\r\n if Start < 1 then\r\n Exit;\r\n repeat\r\n if not PosRangeText(Start, HeadString, TailString, SourceString, RangeBegin, RangeEnd) then\r\n Exit;\r\n if RangeBegin < Start then\r\n begin\r\n Result := True;\r\n Exit;\r\n end;\r\n Start := Start - L;\r\n until Start < 1;\r\nend;\r\n\r\nfunction PosNonSpace(Start: Integer; const SourceText: string): Integer;\r\nvar\r\n P, L: Integer;\r\nbegin\r\n Result := 0;\r\n L := Length(SourceText);\r\n P := Start;\r\n if L = 0 then\r\n Exit;\r\n while (P < L) and (SourceText[P] = ' ') do\r\n Inc(P);\r\n if SourceText[P] <> ' ' then\r\n Result := P;\r\nend;\r\n\r\nfunction BeginOfAttribute(Start: Integer; const SourceText: string): Integer;\r\nvar\r\n P, L: Integer;\r\nbegin\r\n // parses the beginning of an attribute: space + alpha character\r\n Result := 0;\r\n L := Length(SourceText);\r\n if L = 0 then\r\n Exit;\r\n P := PosStr(' ', SourceText, Start);\r\n if P = 0 then\r\n Exit;\r\n P := PosNonSpace(P, SourceText);\r\n if P = 0 then\r\n Exit;\r\n if CharInSet(SourceText[P], ['a'..'z', 'A'..'Z']) then\r\n Result := P;\r\nend;\r\n\r\nfunction ParseAttribute(var Start: Integer; const SourceText: string;\r\n var AName, AValue: string): Boolean;\r\nvar\r\n PN, PV, P: Integer;\r\nbegin\r\n // parses a name=\"value\" attribute from Start; returns 0 when not found or else the position behind the attribute\r\n Result := False;\r\n PN := BeginOfAttribute(Start, SourceText);\r\n if PN = 0 then\r\n Exit;\r\n P := PosStr('=\"', SourceText, PN);\r\n if P = 0 then\r\n Exit;\r\n AName := Trim(Copy(SourceText, PN, P - PN));\r\n PV := P + 2;\r\n P := PosStr('\"', SourceText, PV);\r\n if P = 0 then\r\n Exit;\r\n AValue := Copy(SourceText, PV, P - PV);\r\n Start := P + 1;\r\n Result := True;\r\nend;\r\n\r\nprocedure ParseAttributes(const SourceText: string; Attributes: TStrings);\r\nvar\r\n Name, Value: string;\r\n Start: Integer;\r\nbegin\r\n Attributes.BeginUpdate;\r\n try\r\n Attributes.Clear;\r\n Start := 1;\r\n while ParseAttribute(Start, SourceText, Name, Value) do\r\n Attributes.Add(Name + '=' + Value);\r\n finally\r\n Attributes.EndUpdate;\r\n end;\r\nend;\r\n\r\nfunction GetToken(var Start: Integer; const SourceText: string): string;\r\nvar\r\n P1, P2: Integer;\r\nbegin\r\n Result := '';\r\n if Start > Length(SourceText) then\r\n Exit;\r\n P1 := PosNonSpace(Start, SourceText);\r\n if P1 = 0 then\r\n Exit;\r\n if SourceText[P1] = '\"' then\r\n begin // quoted token\r\n P2 := PosStr('\"', SourceText, P1 + 1);\r\n if P2 = 0 then\r\n Exit;\r\n Result := Copy(SourceText, P1 + 1, P2 - P1 - 1);\r\n Start := P2 + 1;\r\n end\r\n else\r\n begin\r\n P2 := PosStr(' ', SourceText, P1 + 1);\r\n if P2 = 0 then\r\n P2 := Length(SourceText) + 1;\r\n Result := Copy(SourceText, P1, P2 - P1);\r\n Start := P2;\r\n end;\r\nend;\r\n\r\nfunction Easter(NYear: Integer): TDateTime;\r\nvar\r\n NMonth, NDay, NMoon, NEpact, NSunday, NGold, NCent, NCorX, NCorZ: Integer;\r\nbegin\r\n\r\n { The Golden Number of the year in the 19 year Metonic Cycle }\r\n NGold := ((NYear mod 19) + 1);\r\n\r\n { Calculate the Century }\r\n NCent := ((NYear div 100) + 1);\r\n\r\n { No. of Years in which leap year was dropped in order to keep in step\r\n with the sun }\r\n NCorX := ((3 * NCent) div 4 - 12);\r\n\r\n { Special Correction to Syncronize Easter with the moon's orbit }\r\n NCorZ := ((8 * NCent + 5) div 25 - 5);\r\n\r\n { Find Sunday }\r\n NSunday := ((5 * NYear) div 4 - NCorX - 10);\r\n\r\n { Set Epact (specifies occurance of full moon }\r\n NEpact := ((11 * NGold + 20 + NCorZ - NCorX) mod 30);\r\n\r\n if (NEpact < 0) then\r\n NEpact := NEpact + 30;\r\n\r\n if ((NEpact = 25) and (NGold > 11)) or (NEpact = 24) then\r\n NEpact := NEpact + 1;\r\n\r\n { Find Full Moon }\r\n NMoon := 44 - NEpact;\r\n\r\n if (NMoon < 21) then\r\n NMoon := NMoon + 30;\r\n\r\n { Advance to Sunday }\r\n NMoon := (NMoon + 7 - ((NSunday + NMoon) mod 7));\r\n\r\n if (NMoon > 31) then\r\n begin\r\n NMonth := 4;\r\n NDay := (NMoon - 31);\r\n end\r\n else\r\n begin\r\n NMonth := 3;\r\n NDay := NMoon;\r\n end;\r\n\r\n Result := EncodeDate(NYear, NMonth, NDay);\r\nend;\r\n\r\n//gets a datecode. Returns year and weeknumber in format: YYWW\r\n\r\n{DayOfWeek function returns Integer 1..7 equivalent to Sunday..Saturday.\r\nISO 8601 weeks Start with Monday and the first week of a year is the one which\r\nincludes the first Thursday - Fiddle takes care of all this}\r\n\r\nfunction GetWeekNumber(Today: TDateTime): string;\r\nconst\r\n Fiddle: array [1..7] of Byte = (6, 7, 8, 9, 10, 4, 5);\r\nvar\r\n Present, StartOfYear: TDateTime;\r\n FirstDayOfYear, WeekNumber, NumberOfDays: Integer;\r\n Year, Month, Day: Word;\r\n YearNumber: string;\r\nbegin\r\n Present := Trunc(Today); //truncate to remove hours, mins and secs\r\n DecodeDate(Present, Year, Month, Day); //decode to find year\r\n StartOfYear := EncodeDate(Year, 1, 1); //encode 1st Jan of the year\r\n\r\n //find what day of week 1st Jan is, then add days according to rule\r\n FirstDayOfYear := Fiddle[DayOfWeek(StartOfYear)];\r\n\r\n //calc number of days since beginning of year + additional according to rule\r\n NumberOfDays := Trunc(Present - StartOfYear) + FirstDayOfYear;\r\n\r\n //calc number of weeks\r\n WeekNumber := Trunc(NumberOfDays / 7);\r\n\r\n //Format year, needed to prevent millenium bug and keep the Fluffy Spangle happy\r\n YearNumber := FormatDateTime('yyyy', Present);\r\n\r\n YearNumber := YearNumber + 'W';\r\n\r\n if WeekNumber < 10 then\r\n YearNumber := YearNumber + '0'; //add leading zero for week\r\n\r\n //create datecode string\r\n Result := YearNumber + IntToStr(WeekNumber);\r\n\r\n if WeekNumber = 0 then //recursive call for year begin/end...\r\n //see if previous year end was week 52 or 53\r\n Result := GetWeekNumber(EncodeDate(Year - 1, 12, 31))\r\n else\r\n if WeekNumber = 53 then\r\n //if 31st December less than Thursday then must be week 01 of next year\r\n if DayOfWeek(EncodeDate(Year, 12, 31)) < 5 then\r\n begin\r\n YearNumber := FormatDateTime('yyyy', EncodeDate(Year + 1, 1, 1));\r\n Result := YearNumber + 'W01';\r\n end;\r\nend;\r\n\r\nfunction RelativePath(const ASrc, ADst: string): string;\r\nvar\r\n Doc, SDoc, ParDoc, Img, SImg, ParImg, Rel: string;\r\n PDoc, PImg: Integer;\r\nbegin\r\n Doc := ASrc;\r\n Img := ADst;\r\n repeat\r\n PDoc := Pos('\\', Doc);\r\n if PDoc > 0 then\r\n begin\r\n ParDoc := Copy(Doc, 1, PDoc);\r\n ParDoc[Length(ParDoc)] := '/';\r\n SDoc := SDoc + ParDoc;\r\n Delete(Doc, 1, PDoc);\r\n end;\r\n PImg := Pos('\\', Img);\r\n if PImg > 0 then\r\n begin\r\n ParImg := Copy(Img, 1, PImg);\r\n ParImg[Length(ParImg)] := '/';\r\n SImg := SImg + ParImg;\r\n Delete(Img, 1, PImg);\r\n end;\r\n if (PDoc > 0) and (PImg > 0) and (SDoc <> SImg) then\r\n Rel := '../' + Rel + ParImg;\r\n if (PDoc = 0) and (PImg <> 0) then\r\n begin\r\n Rel := Rel + ParImg + Img;\r\n if Pos(':', Rel) > 0 then\r\n Rel := '';\r\n Result := Rel;\r\n Exit;\r\n end;\r\n if (PDoc > 0) and (PImg = 0) then\r\n begin\r\n Rel := '../' + Rel;\r\n end;\r\n until (PDoc = 0) and (PImg = 0);\r\n Rel := Rel + SysUtils.ExtractFileName(Img);\r\n if Pos(':', Rel) > 0 then\r\n Rel := '';\r\n Result := Rel;\r\nend;\r\n\r\nprocedure GetHTMLAnchors(const AFile: string; AList: TStringList);\r\nvar\r\n S, SA: string;\r\n P1, P2: Integer;\r\nbegin\r\n S := LoadString(AFile);\r\n P1 := 1;\r\n repeat\r\n P1 := PosText('     0 then\r\n begin\r\n P2 := PosText('\"', S, P1 + 9);\r\n if P2 <> 0 then\r\n begin\r\n SA := Copy(S, P1 + 9, P2 - P1 - 9);\r\n AList.Add(SA);\r\n P1 := P2;\r\n end\r\n else\r\n P1 := 0;\r\n end;\r\n until P1 = 0;\r\nend;\r\n\r\nfunction UppercaseHTMLTags(const AText: string): string;\r\nvar\r\n P, P2: Integer;\r\nbegin\r\n Result := '';\r\n P2 := 1;\r\n repeat\r\n P := PosStr('<', AText, P2);\r\n if P > 0 then\r\n begin\r\n Result := Result + Copy(AText, P2, P - P2);\r\n P2 := P;\r\n if Copy(AText, P, 4) = '', AText, P);\r\n if P > 0 then\r\n begin\r\n Result := Result + Copy(AText, P2, P + 3 - P2);\r\n P2 := P + 3;\r\n end\r\n else\r\n Result := Result + Copy(AText, P2, Length(AText));\r\n end\r\n else\r\n begin\r\n P := PosStr('>', AText, P);\r\n if P > 0 then\r\n begin\r\n Result := Result + UpperCase(Copy(AText, P2, P - P2 + 1));\r\n P2 := P + 1;\r\n end\r\n else\r\n Result := Result + Copy(AText, P2, Length(AText));\r\n end;\r\n end\r\n else\r\n begin\r\n Result := Result + Copy(AText, P2, Length(AText));\r\n end;\r\n until P = 0;\r\nend;\r\n\r\nfunction LowercaseHTMLTags(const AText: string): string;\r\nvar\r\n P, P2: Integer;\r\nbegin\r\n Result := '';\r\n P2 := 1;\r\n repeat\r\n P := PosStr('<', AText, P2);\r\n if P > 0 then\r\n begin\r\n Result := Result + Copy(AText, P2, P - P2);\r\n P2 := P;\r\n // now check for comments\r\n if Copy(AText, P, 4) = '', AText, P);\r\n if P > 0 then\r\n begin\r\n Result := Result + Copy(AText, P2, P + 3 - P2);\r\n P2 := P + 3;\r\n end\r\n else\r\n Result := Result + Copy(AText, P2, Length(AText));\r\n end\r\n else\r\n begin\r\n P := PosStr('>', AText, P);\r\n if P > 0 then\r\n begin\r\n Result := Result + LowerCase(Copy(AText, P2, P - P2 + 1));\r\n P2 := P + 1;\r\n end\r\n else\r\n Result := Result + Copy(AText, P2, Length(AText));\r\n end;\r\n end\r\n else\r\n begin\r\n Result := Result + Copy(AText, P2, Length(AText));\r\n end;\r\n until P = 0;\r\nend;\r\n\r\nfunction HexToColor(const AText: string): TColor;\r\nbegin\r\n Result := clBlack;\r\n if Length(AText) <> 7 then\r\n Exit;\r\n if AText[1] <> '#' then\r\n Exit;\r\n try\r\n Result := StringToColor('$' + Copy(AText, 6, 2) + Copy(AText, 4, 2) + Copy(AText, 2, 2));\r\n except\r\n Result := clBlack;\r\n end;\r\nend;\r\n\r\nfunction PosEscaped(Start: Integer; const SourceText, FindText: string; EscapeChar: Char): Integer;\r\nbegin\r\n Result := PosText(FindText, SourceText, Start);\r\n if Result = 0 then\r\n Exit;\r\n if Result = 1 then\r\n Exit;\r\n if SourceText[Result - 1] <> EscapeChar then\r\n Exit;\r\n repeat\r\n Result := PosText(FindText, SourceText, Result + 1);\r\n if Result = 0 then\r\n Exit;\r\n until SourceText[Result - 1] <> EscapeChar;\r\nend;\r\n\r\nfunction DeleteEscaped(const SourceText: string; EscapeChar: Char): string;\r\nvar\r\n I: Integer;\r\n RealLen: Integer;\r\nbegin\r\n RealLen := 0;\r\n SetLength(Result, Length(SourceText));\r\n for I := 1 to Length(SourceText) do\r\n if SourceText[I] <> EscapeChar then\r\n begin\r\n Inc(RealLen);\r\n Result[RealLen] := SourceText[I];\r\n end;\r\n SetLength(Result, RealLen);\r\nend;\r\n\r\nprocedure RecurseDirFiles(const ADir: string; var AFileList: TStringList);\r\nvar\r\n SR: TSearchRec;\r\n FileAttrs: Integer;\r\nbegin\r\n FileAttrs := faAnyFile or faDirectory;\r\n if FindFirst(ADir + PathDelim + AllFilePattern, FileAttrs, SR) = 0 then\r\n while FindNext(SR) = 0 do\r\n if (SR.Attr and faDirectory) <> 0 then\r\n begin\r\n if (SR.Name <> '.') and (SR.Name <> '..') then\r\n RecurseDirFiles(ADir + PathDelim + SR.Name, AFileList);\r\n end\r\n else\r\n AFileList.Add(ADir + PathDelim + SR.Name);\r\n FindClose(SR);\r\nend;\r\n\r\nprocedure RecurseDirProgs(const ADir: string; var AFileList: TStringList);\r\nvar\r\n SR: TSearchRec;\r\n FileAttrs: Integer;\r\n E: string;\r\n {$IFDEF UNIX}\r\n ST: TStatBuf;\r\n {$ENDIF UNIX}\r\nbegin\r\n FileAttrs := faAnyFile or faDirectory;\r\n if FindFirst(ADir + PathDelim + AllFilePattern, FileAttrs, SR) = 0 then\r\n while FindNext(SR) = 0 do\r\n begin\r\n if (SR.Attr and faDirectory) <> 0 then\r\n begin\r\n if (SR.Name <> '.') and (SR.Name <> '..') then\r\n RecurseDirProgs(ADir + PathDelim + SR.Name, AFileList);\r\n end\r\n {$IFDEF MSWINDOWS}\r\n else\r\n begin\r\n E := SysUtils.LowerCase(SysUtils.ExtractFileExt(SR.Name));\r\n if E = '.exe' then\r\n AFileList.Add(ADir + PathDelim + SR.Name);\r\n end;\r\n {$ENDIF MSWINDOWS}\r\n {$IFDEF UNIX}\r\n else\r\n begin\r\n if stat(PChar(ADir + PathDelim + SR.Name), ST) = 0 then\r\n begin\r\n if ST.st_mode and (S_IXUSR or S_IXGRP or S_IXOTH) <> 0 then\r\n AFileList.Add(ADir + PathDelim + SR.Name);\r\n end;\r\n end;\r\n {$ENDIF UNIX}\r\n end;\r\n FindClose(SR);\r\nend;\r\n\r\nprocedure LoadResourceFile(AFile: string; MemStream: TMemoryStream);\r\nvar\r\n ResStream: TResourceStream;\r\n Ext: string;\r\nbegin\r\n Ext := SysUtils.UpperCase(SysUtils.ExtractFileExt(AFile));\r\n Ext := Copy(Ext, 2, Length(Ext));\r\n if Ext = 'HTM' then\r\n Ext := 'HTML';\r\n AFile := SysUtils.ChangeFileExt(AFile, '');\r\n ResStream := TResourceStream.Create(HInstance, PChar(AFile), PChar(Ext));\r\n try\r\n MemStream.CopyFrom(ResStream, ResStream.Size);\r\n finally\r\n ResStream.Free;\r\n end;\r\nend;\r\n\r\nprocedure GetNames(AText: string; AList: TStringList);\r\nvar\r\n P: Integer;\r\n S: string;\r\nbegin\r\n AList.Clear;\r\n repeat\r\n AText := Trim(AText);\r\n P := Pos('=\"', AText);\r\n if P > 0 then\r\n begin\r\n S := Copy(AText, 1, P - 1);\r\n AList.Add(S);\r\n Delete(AText, 1, P + 1);\r\n P := Pos('\"', AText);\r\n if P > 0 then\r\n Delete(AText, 1, P);\r\n end;\r\n until P = 0;\r\nend;\r\n\r\nfunction NameValuesToXML(const AText: string): string;\r\nvar\r\n AList: TStringList;\r\n I, C: Integer;\r\n IName, IValue, Xml: string;\r\nbegin\r\n Result := '';\r\n if AText = '' then\r\n Exit;\r\n AList := TStringList.Create;\r\n GetNames(AText, AList);\r\n C := AList.Count;\r\n if C = 0 then\r\n begin\r\n AList.Free;\r\n Exit\r\n end;\r\n Xml := '' + Cr;\r\n for I := 0 to C - 1 do\r\n begin\r\n IName := AList[I];\r\n IValue := GetValue(AText, IName);\r\n IValue := SysUtils.StringReplace(IValue, '~~', Cr, [rfReplaceAll]);\r\n Xml := Xml + '<' + IName + '>' + Cr;\r\n Xml := Xml + ' ' + IValue + Cr;\r\n Xml := Xml + '' + Cr;\r\n end;\r\n Xml := Xml + '' + Cr;\r\n AList.Free;\r\n Result := Xml;\r\nend;\r\n\r\nfunction LastPosChar(const FindChar: Char; SourceString: string): Integer;\r\nvar\r\n I: Integer;\r\nbegin\r\n I := Length(SourceString);\r\n while (I > 0) and (SourceString[I] <> FindChar) do\r\n Dec(I);\r\n Result := I;\r\nend;\r\n\r\nfunction PosStr(const FindString, SourceString: string; StartPos: Integer): Integer;\r\nvar\r\n P: PChar;\r\nbegin\r\n Result := 0;\r\n if (FindString <> '') and (SourceString <> '') and (StartPos <= Length(SourceString)) then\r\n begin\r\n P := StrPos(PChar(SourceString) + StartPos - 1, PChar(FindString));\r\n if P <> nil then\r\n Result := P - PChar(SourceString) + 1;\r\n end;\r\nend;\r\n\r\nfunction PosText(const FindString, SourceString: string; StartPos: Integer): Integer;\r\nbegin\r\n // Not the fastest implementation but the JCL doesn't have a better one, either.\r\n Result := Pos(UpperCase(FindString), UpperCase(Copy(SourceString, StartPos, MaxInt)));\r\n if Result <> 0 then\r\n Result := Result + StartPos - 1;\r\nend;\r\n\r\nfunction GetBoolValue(const AText, AName: string): Boolean;\r\nbegin\r\n Result := CompareText(GetValue(AText, AName), 'yes') = 0;\r\nend;\r\n\r\nprocedure ListSelect(Src, Dst: TStringList; const AKey, AValue: string);\r\nvar\r\n I: Integer;\r\nbegin\r\n Dst.Clear;\r\n for I := 0 to Src.Count - 1 do\r\n begin\r\n if GetValue(Src[I], AKey) = AValue then\r\n Dst.Add(Src[I]);\r\n end;\r\nend;\r\n\r\nprocedure ListFilter(Src: TStringList; const AKey, AValue: string);\r\nvar\r\n I: Integer;\r\n Dst: TStringList;\r\nbegin\r\n Dst := TStringList.Create;\r\n for I := 0 to Src.Count - 1 do\r\n begin\r\n if GetValue(Src[I], AKey) = AValue then\r\n Dst.Add(Src[I]);\r\n end;\r\n Src.Assign(Dst);\r\n Dst.Free;\r\nend;\r\n\r\nprocedure ListOrderBy(Src: TStringList; const AKey: string; Numeric: Boolean);\r\nvar\r\n I, Index: Integer;\r\n Lit, Dst: TStringList;\r\n S: string;\r\n IValue: Integer;\r\nbegin\r\n if Src.Count < 2 then\r\n Exit; // nothing to sort\r\n Lit := TStringList.Create;\r\n Dst := TStringList.Create;\r\n for I := 0 to Src.Count - 1 do\r\n begin\r\n S := GetValue(Src[I], AKey);\r\n if Numeric then\r\n try\r\n IValue := StrToInt(S);\r\n // format to 5 decimal places for correct string sorting\r\n // e.g. 5 becomes 00005\r\n S := Format('%5.5d', [IValue]);\r\n except\r\n // just use the unformatted value\r\n end;\r\n Lit.AddObject(S, TObject(I));\r\n end;\r\n Lit.Sort;\r\n for I := 0 to Src.Count - 1 do\r\n begin\r\n Index := Integer(Lit.Objects[I]);\r\n Dst.Add(Src[Index]);\r\n end;\r\n Lit.Free;\r\n Src.Assign(Dst);\r\n Dst.Free;\r\nend;\r\n\r\n// converts a csv list to a tagged string list\r\n\r\nprocedure CSVToTags(Src, Dst: TStringList);\r\nvar\r\n I, FI, FC: Integer;\r\n Names: TStringList;\r\n Rec: TStringList;\r\n S: string;\r\nbegin\r\n Dst.Clear;\r\n if Src.Count < 2 then\r\n Exit;\r\n Names := TStringList.Create;\r\n Rec := TStringList.Create;\r\n try\r\n Names.CommaText := Src[0];\r\n FC := Names.Count;\r\n if FC > 0 then\r\n for I := 1 to Src.Count - 1 do\r\n begin\r\n Rec.CommaText := Src[I];\r\n S := '';\r\n for FI := 0 to FC - 1 do\r\n S := S + Names[FI] + '=\"' + Rec[FI] + '\" ';\r\n Dst.Add(S);\r\n end;\r\n finally\r\n Rec.Free;\r\n Names.Free;\r\n end;\r\nend;\r\n\r\n// converts a tagged string list to a csv list\r\n// only fieldnames from the first record are scanned ib the other records\r\n\r\nprocedure TagsToCSV(Src, Dst: TStringList);\r\nvar\r\n I, FI, FC: Integer;\r\n Names: TStringList;\r\n Rec: TStringList;\r\n S: string;\r\nbegin\r\n Dst.Clear;\r\n if Src.Count < 1 then\r\n Exit;\r\n Names := TStringList.Create;\r\n Rec := TStringList.Create;\r\n try\r\n GetNames(Src[0], Names);\r\n FC := Names.Count;\r\n if FC > 0 then\r\n begin\r\n Dst.Add(Names.CommaText);\r\n for I := 0 to Src.Count - 1 do\r\n begin\r\n S := '';\r\n Rec.Clear;\r\n for FI := 0 to FC - 1 do\r\n Rec.Add(GetValue(Src[I], Names[FI]));\r\n Dst.Add(Rec.CommaText);\r\n end;\r\n end;\r\n finally\r\n Rec.Free;\r\n Names.Free;\r\n end;\r\nend;\r\n\r\nfunction B64Encode(const S: AnsiString): AnsiString;\r\nvar\r\n I: Integer;\r\n InBuf: array [0..2] of Byte;\r\n OutBuf: array [0..3] of AnsiChar;\r\nbegin\r\n SetLength(Result, ((Length(S) + 2) div 3) * 4);\r\n for I := 1 to ((Length(S) + 2) div 3) do\r\n begin\r\n if Length(S) < (I * 3) then\r\n Move(S[(I - 1) * 3 + 1], InBuf, Length(S) - (I - 1) * 3)\r\n else\r\n Move(S[(I - 1) * 3 + 1], InBuf, 3);\r\n OutBuf[0] := B64Table[((InBuf[0] and $FC) shr 2) + 1];\r\n OutBuf[1] := B64Table[(((InBuf[0] and $03) shl 4) or ((InBuf[1] and $F0) shr 4)) + 1];\r\n OutBuf[2] := B64Table[(((InBuf[1] and $0F) shl 2) or ((InBuf[2] and $C0) shr 6)) + 1];\r\n OutBuf[3] := B64Table[(InBuf[2] and $3F) + 1];\r\n Move(OutBuf, Result[(I - 1) * 4 + 1], 4);\r\n end;\r\n if (Length(S) mod 3) = 1 then\r\n begin\r\n Result[Length(Result) - 1] := '=';\r\n Result[Length(Result)] := '=';\r\n end\r\n else\r\n if (Length(S) mod 3) = 2 then\r\n Result[Length(Result)] := '=';\r\nend;\r\n\r\nfunction B64Decode(const S: AnsiString): AnsiString;\r\nvar\r\n I: Integer;\r\n InBuf: array [0..3] of Byte;\r\n OutBuf: array [0..2] of Byte;\r\n RetValue: AnsiString;\r\nbegin\r\n if ((Length(S) mod 4) <> 0) or (S = '') then\r\n raise EJVCLException.CreateRes({$IFNDEF CLR}@{$ENDIF}RsEIncorrectStringFormat);\r\n\r\n SetLength(RetValue, ((Length(S) div 4) - 1) * 3);\r\n for I := 1 to ((Length(S) div 4) - 1) do\r\n begin\r\n Move(S[(I - 1) * 4 + 1], InBuf, 4);\r\n if (InBuf[0] > 64) and (InBuf[0] < 91) then\r\n Dec(InBuf[0], 65)\r\n else\r\n if (InBuf[0] > 96) and (InBuf[0] < 123) then\r\n Dec(InBuf[0], 71)\r\n else\r\n if (InBuf[0] > 47) and (InBuf[0] < 58) then\r\n Inc(InBuf[0], 4)\r\n else\r\n if InBuf[0] = 43 then\r\n InBuf[0] := 62\r\n else\r\n InBuf[0] := 63;\r\n if (InBuf[1] > 64) and (InBuf[1] < 91) then\r\n Dec(InBuf[1], 65)\r\n else\r\n if (InBuf[1] > 96) and (InBuf[1] < 123) then\r\n Dec(InBuf[1], 71)\r\n else\r\n if (InBuf[1] > 47) and (InBuf[1] < 58) then\r\n Inc(InBuf[1], 4)\r\n else\r\n if InBuf[1] = 43 then\r\n InBuf[1] := 62\r\n else\r\n InBuf[1] := 63;\r\n if (InBuf[2] > 64) and (InBuf[2] < 91) then\r\n Dec(InBuf[2], 65)\r\n else\r\n if (InBuf[2] > 96) and (InBuf[2] < 123) then\r\n Dec(InBuf[2], 71)\r\n else\r\n if (InBuf[2] > 47) and (InBuf[2] < 58) then\r\n Inc(InBuf[2], 4)\r\n else\r\n if InBuf[2] = 43 then\r\n InBuf[2] := 62\r\n else\r\n InBuf[2] := 63;\r\n if (InBuf[3] > 64) and (InBuf[3] < 91) then\r\n Dec(InBuf[3], 65)\r\n else\r\n if (InBuf[3] > 96) and (InBuf[3] < 123) then\r\n Dec(InBuf[3], 71)\r\n else\r\n if (InBuf[3] > 47) and (InBuf[3] < 58) then\r\n Inc(InBuf[3], 4)\r\n else\r\n if InBuf[3] = 43 then\r\n InBuf[3] := 62\r\n else\r\n InBuf[3] := 63;\r\n OutBuf[0] := (InBuf[0] shl 2) or ((InBuf[1] shr 4) and $03);\r\n OutBuf[1] := (InBuf[1] shl 4) or ((InBuf[2] shr 2) and $0F);\r\n OutBuf[2] := (InBuf[2] shl 6) or (InBuf[3] and $3F);\r\n Move(OutBuf, RetValue[(I - 1) * 3 + 1], 3);\r\n end;\r\n if S <> '' then\r\n begin\r\n Move(S[Length(S) - 3], InBuf, 4);\r\n if InBuf[2] = 61 then\r\n begin\r\n if (InBuf[0] > 64) and (InBuf[0] < 91) then\r\n Dec(InBuf[0], 65)\r\n else\r\n if (InBuf[0] > 96) and (InBuf[0] < 123) then\r\n Dec(InBuf[0], 71)\r\n else\r\n if (InBuf[0] > 47) and (InBuf[0] < 58) then\r\n Inc(InBuf[0], 4)\r\n else\r\n if InBuf[0] = 43 then\r\n InBuf[0] := 62\r\n else\r\n InBuf[0] := 63;\r\n if (InBuf[1] > 64) and (InBuf[1] < 91) then\r\n Dec(InBuf[1], 65)\r\n else\r\n if (InBuf[1] > 96) and (InBuf[1] < 123) then\r\n Dec(InBuf[1], 71)\r\n else\r\n if (InBuf[1] > 47) and (InBuf[1] < 58) then\r\n Inc(InBuf[1], 4)\r\n else\r\n if InBuf[1] = 43 then\r\n InBuf[1] := 62\r\n else\r\n InBuf[1] := 63;\r\n OutBuf[0] := (InBuf[0] shl 2) or ((InBuf[1] shr 4) and $03);\r\n RetValue := RetValue + AnsiChar(OutBuf[0]);\r\n end\r\n else\r\n if InBuf[3] = 61 then\r\n begin\r\n if (InBuf[0] > 64) and (InBuf[0] < 91) then\r\n Dec(InBuf[0], 65)\r\n else\r\n if (InBuf[0] > 96) and (InBuf[0] < 123) then\r\n Dec(InBuf[0], 71)\r\n else\r\n if (InBuf[0] > 47) and (InBuf[0] < 58) then\r\n Inc(InBuf[0], 4)\r\n else\r\n if InBuf[0] = 43 then\r\n InBuf[0] := 62\r\n else\r\n InBuf[0] := 63;\r\n if (InBuf[1] > 64) and (InBuf[1] < 91) then\r\n Dec(InBuf[1], 65)\r\n else\r\n if (InBuf[1] > 96) and (InBuf[1] < 123) then\r\n Dec(InBuf[1], 71)\r\n else\r\n if (InBuf[1] > 47) and (InBuf[1] < 58) then\r\n Inc(InBuf[1], 4)\r\n else\r\n if InBuf[1] = 43 then\r\n InBuf[1] := 62\r\n else\r\n InBuf[1] := 63;\r\n if (InBuf[2] > 64) and (InBuf[2] < 91) then\r\n Dec(InBuf[2], 65)\r\n else\r\n if (InBuf[2] > 96) and (InBuf[2] < 123) then\r\n Dec(InBuf[2], 71)\r\n else\r\n if (InBuf[2] > 47) and (InBuf[2] < 58) then\r\n Inc(InBuf[2], 4)\r\n else\r\n if InBuf[2] = 43 then\r\n InBuf[2] := 62\r\n else\r\n InBuf[2] := 63;\r\n OutBuf[0] := (InBuf[0] shl 2) or ((InBuf[1] shr 4) and $03);\r\n OutBuf[1] := (InBuf[1] shl 4) or ((InBuf[2] shr 2) and $0F);\r\n RetValue := RetValue + AnsiChar(OutBuf[0]) + AnsiChar(OutBuf[1]);\r\n end\r\n else\r\n begin\r\n if (InBuf[0] > 64) and (InBuf[0] < 91) then\r\n Dec(InBuf[0], 65)\r\n else\r\n if (InBuf[0] > 96) and (InBuf[0] < 123) then\r\n Dec(InBuf[0], 71)\r\n else\r\n if (InBuf[0] > 47) and (InBuf[0] < 58) then\r\n Inc(InBuf[0], 4)\r\n else\r\n if InBuf[0] = 43 then\r\n InBuf[0] := 62\r\n else\r\n InBuf[0] := 63;\r\n if (InBuf[1] > 64) and (InBuf[1] < 91) then\r\n Dec(InBuf[1], 65)\r\n else\r\n if (InBuf[1] > 96) and (InBuf[1] < 123) then\r\n Dec(InBuf[1], 71)\r\n else\r\n if (InBuf[1] > 47) and (InBuf[1] < 58) then\r\n Inc(InBuf[1], 4)\r\n else\r\n if InBuf[1] = 43 then\r\n InBuf[1] := 62\r\n else\r\n InBuf[1] := 63;\r\n if (InBuf[2] > 64) and (InBuf[2] < 91) then\r\n Dec(InBuf[2], 65)\r\n else\r\n if (InBuf[2] > 96) and (InBuf[2] < 123) then\r\n Dec(InBuf[2], 71)\r\n else\r\n if (InBuf[2] > 47) and (InBuf[2] < 58) then\r\n Inc(InBuf[2], 4)\r\n else\r\n if InBuf[2] = 43 then\r\n InBuf[2] := 62\r\n else\r\n InBuf[2] := 63;\r\n if (InBuf[3] > 64) and (InBuf[3] < 91) then\r\n Dec(InBuf[3], 65)\r\n else\r\n if (InBuf[3] > 96) and (InBuf[3] < 123) then\r\n Dec(InBuf[3], 71)\r\n else\r\n if (InBuf[3] > 47) and (InBuf[3] < 58) then\r\n Inc(InBuf[3], 4)\r\n else\r\n if InBuf[3] = 43 then\r\n InBuf[3] := 62\r\n else\r\n InBuf[3] := 63;\r\n OutBuf[0] := (InBuf[0] shl 2) or ((InBuf[1] shr 4) and $03);\r\n OutBuf[1] := (InBuf[1] shl 4) or ((InBuf[2] shr 2) and $0F);\r\n OutBuf[2] := (InBuf[2] shl 6) or (InBuf[3] and $3F);\r\n RetValue := RetValue + AnsiChar(OutBuf[0]) + AnsiChar(OutBuf[1]) + AnsiChar(OutBuf[2]);\r\n end;\r\n end;\r\n Result := RetValue;\r\nend;\r\n\r\n{*******************************************************\r\n * Standard Encryption algorithm - Copied from Borland *\r\n *******************************************************}\r\n\r\nfunction Encrypt(const InString: AnsiString; StartKey, MultKey, AddKey: Integer): AnsiString;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := '';\r\n for I := 1 to Length(InString) do\r\n begin\r\n Result := Result + AnsiChar(Byte(InString[I]) xor (StartKey shr 8));\r\n StartKey := (Byte(Result[I]) + StartKey) * MultKey + AddKey;\r\n end;\r\nend;\r\n{*******************************************************\r\n * Standard Decryption algorithm - Copied from Borland *\r\n *******************************************************}\r\n\r\nfunction Decrypt(const InString: AnsiString; StartKey, MultKey, AddKey: Integer): AnsiString;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := '';\r\n for I := 1 to Length(InString) do\r\n begin\r\n Result := Result + AnsiChar(Byte(InString[I]) xor (StartKey shr 8));\r\n StartKey := (Byte(InString[I]) + StartKey) * MultKey + AddKey;\r\n end;\r\nend;\r\n\r\nfunction EncryptB64(const InString: AnsiString; StartKey, MultKey, AddKey: Integer): AnsiString;\r\nbegin\r\n Result := B64Encode(Encrypt(InString, StartKey, MultKey, AddKey));\r\nend;\r\n\r\nfunction DecryptB64(const InString: AnsiString; StartKey, MultKey, AddKey: Integer): AnsiString;\r\nbegin\r\n Result := Decrypt(B64Decode(InString), StartKey, MultKey, AddKey);\r\nend;\r\n\r\nfunction Hash(const AText: string): Integer;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := 0;\r\n if AText = '' then\r\n Exit;\r\n Result := Ord(AText[1]);\r\n for I := 2 to Length(AText) do\r\n Result := (Result * Ord(AText[I])) xor Result;\r\nend;\r\n\r\n{replace any <,> etc by < >}\r\n\r\nfunction XMLSafe(const AText: string): string;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := '';\r\n for I := 1 to Length(AText) do\r\n if AText[I] = '<' then\r\n Result := Result + '<'\r\n else\r\n if AText[I] = '>' then\r\n Result := Result + '>'\r\n else\r\n if AText[I] = '&' then\r\n Result := Result + '&'\r\n else\r\n if (Ord(AText[I]) >= 32) and (Ord(AText[I]) < 128) then\r\n Result := Result + AText[I]\r\n else\r\n if Ord(AText[I]) > 127 then\r\n Result := Result + '&#' + IntToStr(Ord(AText[I])) + ';'\r\n else\r\n Result := Result + ' ';\r\nend;\r\n\r\nfunction FirstOfSet(const AText: string): string;\r\nvar\r\n P: Integer;\r\nbegin\r\n Result := Trim(AText);\r\n if Result = '' then\r\n Exit;\r\n if Result[1] = '\"' then\r\n begin\r\n P := PosStr('\"', Result, 2);\r\n Result := Copy(Result, 2, P - 2);\r\n end\r\n else\r\n begin\r\n P := Pos(' ', Result);\r\n Result := Copy(Result, 1, P - 1);\r\n end;\r\nend;\r\n\r\nfunction LastOfSet(const AText: string): string;\r\nvar\r\n C: Integer;\r\nbegin\r\n Result := Trim(AText);\r\n if Result = '' then\r\n Exit;\r\n C := Length(Result);\r\n if Result[C] = '\"' then\r\n begin\r\n while (C > 1) and (Result[C - 1] <> '\"') do\r\n Dec(C);\r\n Result := Copy(Result, C, Length(Result) - C);\r\n end\r\n else\r\n begin\r\n while (C > 1) and (Result[C - 1] <> ' ') do\r\n Dec(C);\r\n Result := Copy(Result, C, Length(Result));\r\n end;\r\nend;\r\n\r\nfunction CountOfSet(const AText: string): Integer;\r\nvar\r\n Lit: TStringList;\r\nbegin\r\n Lit := TStringList.Create;\r\n SplitSet(AText, Lit);\r\n Result := Lit.Count;\r\n Lit.Free;\r\nend;\r\n\r\nfunction SetRotateRight(const AText: string): string;\r\nvar\r\n Lit: TStringList;\r\n C: Integer;\r\nbegin\r\n Lit := TStringList.Create;\r\n SplitSet(AText, Lit);\r\n C := Lit.Count;\r\n if C > 0 then\r\n begin\r\n Lit.Move(C - 1, 0);\r\n Result := JoinSet(Lit);\r\n end\r\n else\r\n Result := '';\r\n Lit.Free;\r\nend;\r\n\r\nfunction SetRotateLeft(const AText: string): string;\r\nvar\r\n Lit: TStringList;\r\n C: Integer;\r\nbegin\r\n Lit := TStringList.Create;\r\n SplitSet(AText, Lit);\r\n C := Lit.Count;\r\n if C > 0 then\r\n begin\r\n Lit.Move(0, C - 1);\r\n Result := JoinSet(Lit);\r\n end\r\n else\r\n Result := '';\r\n Lit.Free;\r\nend;\r\n\r\nprocedure SplitSet(AText: string; AList: TStringList);\r\nvar\r\n P: Integer;\r\nbegin\r\n AList.Clear;\r\n if AText = '' then\r\n Exit;\r\n AText := Trim(AText);\r\n while AText <> '' do\r\n begin\r\n if AText[1] = '\"' then\r\n begin\r\n Delete(AText, 1, 1);\r\n P := Pos('\"', AText);\r\n if P <> 0 then\r\n begin\r\n AList.Add(Copy(AText, 1, P - 1));\r\n Delete(AText, 1, P);\r\n end;\r\n end\r\n else\r\n begin\r\n P := Pos(' ', AText);\r\n if P = 0 then\r\n begin\r\n AList.Add(AText);\r\n AText := '';\r\n end\r\n else\r\n begin\r\n AList.Add(Copy(AText, 1, P - 1));\r\n Delete(AText, 1, P);\r\n end;\r\n end;\r\n AText := Trim(AText);\r\n end;\r\nend;\r\n\r\nfunction JoinSet(AList: TStringList): string;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := '';\r\n for I := 0 to AList.Count - 1 do\r\n Result := Result + AList[I] + ' ';\r\n Delete(Result, Length(Result), 1);\r\nend;\r\n\r\nfunction SetPick(const AText: string; AIndex: Integer): string;\r\nvar\r\n Lit: TStringList;\r\n C: Integer;\r\nbegin\r\n Lit := TStringList.Create;\r\n SplitSet(AText, Lit);\r\n C := Lit.Count;\r\n if (C > 0) and (AIndex < C) then\r\n Result := Lit[AIndex]\r\n else\r\n Result := '';\r\n Lit.Free;\r\nend;\r\n\r\nfunction SetSort(const AText: string): string;\r\nvar\r\n Lit: TStringList;\r\nbegin\r\n Lit := TStringList.Create;\r\n SplitSet(AText, Lit);\r\n if Lit.Count > 0 then\r\n begin\r\n Lit.Sort;\r\n Result := JoinSet(Lit);\r\n end\r\n else\r\n Result := '';\r\n Lit.Free;\r\nend;\r\n\r\nfunction SetUnion(const Set1, Set2: string): string;\r\nvar\r\n Lit1, Lit2, Lit3: TStringList;\r\n I, C: Integer;\r\nbegin\r\n Lit1 := TStringList.Create;\r\n Lit2 := TStringList.Create;\r\n Lit3 := TStringList.Create;\r\n SplitSet(Set1, Lit1);\r\n SplitSet(Set2, Lit2);\r\n C := Lit2.Count;\r\n if C <> 0 then\r\n begin\r\n Lit2.Addstrings(Lit1);\r\n for I := 0 to Lit2.Count - 1 do\r\n if Lit3.IndexOf(Lit2[I]) = -1 then\r\n Lit3.Add(Lit2[I]);\r\n Result := JoinSet(Lit3);\r\n end\r\n else\r\n begin\r\n Result := JoinSet(Lit1);\r\n end;\r\n Lit1.Free;\r\n Lit2.Free;\r\n Lit3.Free;\r\nend;\r\n\r\nfunction SetIntersect(const Set1, Set2: string): string;\r\nvar\r\n Lit1, Lit2, Lit3: TStringList;\r\n I: Integer;\r\nbegin\r\n Lit1 := TStringList.Create;\r\n Lit2 := TStringList.Create;\r\n Lit3 := TStringList.Create;\r\n SplitSet(Set1, Lit1);\r\n SplitSet(Set2, Lit2);\r\n if Lit2.Count <> 0 then\r\n begin\r\n for I := 0 to Lit2.Count - 1 do\r\n if Lit1.IndexOf(Lit2[I]) <> -1 then\r\n Lit3.Add(Lit2[I]);\r\n Result := JoinSet(Lit3);\r\n end\r\n else\r\n Result := '';\r\n Lit1.Free;\r\n Lit2.Free;\r\n Lit3.Free;\r\nend;\r\n\r\nfunction SetExclude(const Set1, Set2: string): string;\r\nvar\r\n Lit1, Lit2: TStringList;\r\n I, Index: Integer;\r\nbegin\r\n Lit1 := TStringList.Create;\r\n Lit2 := TStringList.Create;\r\n SplitSet(Set1, Lit1);\r\n SplitSet(Set2, Lit2);\r\n if Lit2.Count <> 0 then\r\n begin\r\n for I := 0 to Lit2.Count - 1 do\r\n begin\r\n Index := Lit1.IndexOf(Lit2[I]);\r\n if Index <> -1 then\r\n Lit1.Delete(Index);\r\n end;\r\n Result := JoinSet(Lit1);\r\n end\r\n else\r\n Result := JoinSet(Lit1);\r\n Lit1.Free;\r\n Lit2.Free;\r\nend;\r\n\r\n// This function converts a string into a RFC 1630 compliant URL\r\n\r\nfunction URLEncode(const Value: AnsiString): AnsiString;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := '';\r\n for I := 1 to Length(Value) do\r\n if Pos(UpperCase(Value[I]), ValidURLChars) > 0 then\r\n Result := Result + Value[I]\r\n else\r\n begin\r\n if Value[I] = ' ' then\r\n Result := Result + '+'\r\n else\r\n begin\r\n Result := Result + '%';\r\n Result := Result + AnsiString(IntToHex(Byte(Value[I]), 2));\r\n end;\r\n end;\r\nend;\r\n\r\nfunction URLDecode(const Value: AnsiString): AnsiString;\r\nconst\r\n HexChars: AnsiString = '0123456789ABCDEF';\r\nvar\r\n I: Integer;\r\n Ch, H1, H2: AnsiChar;\r\n Len: Integer;\r\nbegin\r\n Result := '';\r\n Len := Length(Value);\r\n I := 1;\r\n while I <= Len do\r\n begin\r\n Ch := Value[I];\r\n case Ch of\r\n '%':\r\n begin\r\n H1 := Value[I + 1];\r\n H2 := Value[I + 2];\r\n Inc(I, 2);\r\n Result := Result + AnsiChar(Chr((({$IFDEF SUPPORTS_UNICODE}AnsiPos{$ELSE}Pos{$ENDIF SUPPORTS_UNICODE}(H1, HexChars) - 1) * 16) +\r\n ({$IFDEF SUPPORTS_UNICODE}AnsiPos{$ELSE}Pos{$ENDIF SUPPORTS_UNICODE}(H2, HexChars) - 1)));\r\n end;\r\n '+':\r\n Result := Result + ' ';\r\n '&':\r\n Result := Result + CrLf;\r\n else\r\n Result := Result + Ch;\r\n end;\r\n Inc(I);\r\n end;\r\nend;\r\n\r\n{template functions}\r\n\r\nfunction ReplaceFirst(const SourceStr, FindStr, ReplaceStr: string): string;\r\nvar\r\n P: Integer;\r\nbegin\r\n Result := SourceStr;\r\n P := PosText(FindStr, SourceStr, 1);\r\n if P <> 0 then\r\n Result := Copy(SourceStr, 1, P - 1) + ReplaceStr + Copy(SourceStr, P + Length(FindStr), Length(SourceStr));\r\nend;\r\n\r\nfunction ReplaceLast(const SourceStr, FindStr, ReplaceStr: string): string;\r\nvar\r\n P: Integer;\r\nbegin\r\n Result := SourceStr;\r\n P := PosTextLast(FindStr, SourceStr);\r\n if P <> 0 then\r\n Result := Copy(SourceStr, 1, P - 1) + ReplaceStr + Copy(SourceStr, P + Length(FindStr), Length(SourceStr));\r\nend;\r\n\r\n// insert a block template\r\n// the last occurance of {block:aBlockname}\r\n// the block template is marked with {begin:aBlockname} and {end:aBlockname}\r\n\r\nfunction InsertLastBlock(var SourceStr: string; BlockStr: string): Boolean;\r\nvar\r\n // phead: Integer;\r\n PBlock, PE, PB: Integer;\r\n SBB, SBE, SB, SBR: string;\r\n SBBL, SBEL: Integer;\r\nbegin\r\n Result := False;\r\n // phead:= PosStr('',SourceStr,1);\r\n // If phead = 0 Then Exit;\r\n // phead:= phead + 7;\r\n SB := '{block:' + BlockStr + '}';\r\n // sbL:=Length(SB);\r\n SBB := '{begin:' + BlockStr + '}';\r\n SBBL := Length(SBB);\r\n SBE := '{end:' + BlockStr + '}';\r\n SBEL := Length(SBE);\r\n PBlock := PosTextLast(SB, SourceStr);\r\n if PBlock = 0 then\r\n Exit;\r\n PB := PosText(SBB, SourceStr, 1);\r\n if PB = 0 then\r\n Exit;\r\n PE := PosText(SBE, SourceStr, PB);\r\n if PE = 0 then\r\n Exit;\r\n PE := PE + SBEL - 1;\r\n // now replace\r\n SBR := Copy(SourceStr, PB + SBBL, PE - PB - SBBL - SBEL + 1);\r\n SourceStr := Copy(SourceStr, 1, PBlock - 1) + SBR + Copy(SourceStr, PBlock, Length(SourceStr));\r\n Result := True;\r\nend;\r\n\r\n// removes all {begin:somefield} to {end:somefield} from ASource\r\n\r\nfunction RemoveMasterBlocks(const SourceStr: string): string;\r\nvar\r\n S, Src: string;\r\n PB: Integer;\r\n PE: Integer;\r\n PEE: Integer;\r\nbegin\r\n S := '';\r\n Src := SourceStr;\r\n repeat\r\n PB := PosText('{begin:', Src);\r\n if PB > 0 then\r\n begin\r\n PE := PosText('{end:', Src, PB);\r\n if PE > 0 then\r\n begin\r\n PEE := PosStr('}', Src, PE);\r\n if PEE > 0 then\r\n begin\r\n S := S + Copy(Src, 1, PB - 1);\r\n Delete(Src, 1, PEE);\r\n end;\r\n end;\r\n end;\r\n until PB = 0;\r\n Result := S + Src;\r\nend;\r\n\r\n// removes all {field} entries in a template\r\n\r\nfunction RemoveFields(const SourceStr: string): string;\r\nvar\r\n Src, S: string;\r\n PB: Integer;\r\n PE: Integer;\r\nbegin\r\n S := '';\r\n Src := SourceStr;\r\n repeat\r\n PB := Pos('{', Src);\r\n if PB > 0 then\r\n begin\r\n PE := Pos('}', Src);\r\n if PE > 0 then\r\n begin\r\n S := S + Copy(Src, 1, PB - 1);\r\n Delete(Src, 1, PE);\r\n end;\r\n end;\r\n until PB = 0;\r\n Result := S + Src;\r\nend;\r\n\r\n{finds the last occurance}\r\n\r\nfunction PosStrLast(const FindString, SourceString: string): Integer;\r\nvar\r\n I, L: Integer;\r\nbegin\r\n Result := 0;\r\n L := Length(FindString);\r\n if L = 0 then\r\n Exit;\r\n I := Length(SourceString);\r\n if I = 0 then\r\n Exit;\r\n I := I - L + 1;\r\n while I > 0 do\r\n begin\r\n Result := PosStr(FindString, SourceString, I);\r\n if Result > 0 then\r\n Exit;\r\n I := I - L;\r\n end;\r\nend;\r\n\r\n{finds the last occurance}\r\n\r\nfunction PosTextLast(const FindString, SourceString: string): Integer;\r\nvar\r\n I, L: Integer;\r\nbegin\r\n Result := 0;\r\n L := Length(FindString);\r\n if L = 0 then\r\n Exit;\r\n I := Length(SourceString);\r\n if I = 0 then\r\n Exit;\r\n I := I - L + 1;\r\n while I > 0 do\r\n begin\r\n Result := PosText(FindString, SourceString, I);\r\n if Result > 0 then\r\n Exit;\r\n I := I - L;\r\n end;\r\nend;\r\n\r\nprocedure DirFiles(const ADir, AMask: string; AFileList: TStringList);\r\nvar\r\n SR: TSearchRec;\r\n FileAttrs: Integer;\r\nbegin\r\n FileAttrs := faArchive + faDirectory;\r\n if FindFirst(ADir + AMask, FileAttrs, SR) = 0 then\r\n while FindNext(SR) = 0 do\r\n if (SR.Attr and faArchive) <> 0 then\r\n AFileList.Add(ADir + SR.Name);\r\n FindClose(SR);\r\nend;\r\n\r\n// parse number returns the last position, starting from 1\r\n\r\nfunction ParseNumber(const S: string): Integer;\r\nvar\r\n I, E, E2, C: Integer;\r\nbegin\r\n Result := 0;\r\n I := 0;\r\n C := Length(S);\r\n if C = 0 then\r\n Exit;\r\n while (I + 1 <= C) and CharInSet(S[I + 1], DigitChars + [',', '.']) do\r\n Inc(I);\r\n if (I + 1 <= C) and CharInSet(S[I + 1], ['e', 'E']) then\r\n begin\r\n E := I;\r\n Inc(I);\r\n if (I + 1 <= C) and CharInSet(S[I + 1], ['+', '-']) then\r\n Inc(I);\r\n E2 := I;\r\n while (I + 1 <= C) and CharInSet(S[I + 1], DigitChars) do\r\n Inc(I);\r\n if I = E2 then\r\n I := E;\r\n end;\r\n Result := I;\r\nend;\r\n\r\n// parse a SQL style data string from positions 1,\r\n// starts and ends with #\r\n\r\nfunction ParseDate(const S: string): Integer;\r\nvar\r\n P: Integer;\r\nbegin\r\n Result := 0;\r\n if Length(S) < 2 then\r\n Exit;\r\n P := PosStr('#', S, 2);\r\n if P <> 0 then\r\n try\r\n StrToDate(Copy(S, 2, P - 2));\r\n Result := P;\r\n except\r\n Result := 0;\r\n end;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvSwitch.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvSwitch.PAS, released on 2002-07-04.\r\n\r\nThe Initial Developers of the Original Code are: Fedor Koshevnikov, Igor Pavluk and Serge Korolev\r\nCopyright (c) 1997, 1998 Fedor Koshevnikov, Igor Pavluk and Serge Korolev\r\nCopyright (c) 2001,2002 SGB Software\r\nAll Rights Reserved.\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvSwitch.pas 13338 2012-06-13 08:23:33Z obones $\r\n\r\nunit JvSwitch;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n SysUtils, Classes,\r\n Windows, Messages, Graphics, Controls, Forms, Menus,\r\n JvJCLUtils, JvComponent;\r\n\r\ntype\r\n TTextPos = (tpNone, tpLeft, tpRight, tpAbove, tpBelow);\r\n TSwitchBitmaps = set of Boolean;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvSwitch = class(TJvCustomControl)\r\n private\r\n FActive: Boolean;\r\n FBitmaps: array [Boolean] of TBitmap;\r\n FDisableBitmaps: array [Boolean] of TBitmap;\r\n FOnOn: TNotifyEvent;\r\n FOnOff: TNotifyEvent;\r\n FStateOn: Boolean;\r\n FTextPosition: TTextPos;\r\n FBorderStyle: TBorderStyle;\r\n FToggleKey: TShortCut;\r\n FShowFocus: Boolean;\r\n FUserBitmaps: TSwitchBitmaps;\r\n procedure GlyphChanged(Sender: TObject);\r\n procedure SetStateOn(Value: Boolean);\r\n procedure SetTextPosition(Value: TTextPos);\r\n procedure SetBorderStyle(Value: TBorderStyle);\r\n function GetSwitchGlyph(Index: Integer): TBitmap;\r\n procedure SetSwitchGlyph(Index: Integer; Value: TBitmap);\r\n function StoreBitmap(Index: Integer): Boolean;\r\n procedure SetShowFocus(Value: Boolean);\r\n procedure CreateDisabled(Index: Boolean);\r\n procedure ReadBinaryData(Stream: TStream);\r\n procedure WriteBinaryData(Stream: TStream);\r\n protected\r\n procedure FocusChanged(Control: TWinControl); override;\r\n function DoEraseBackground(Canvas: TCanvas; Param: LPARAM): Boolean; override;\r\n function WantKey(Key: Integer; Shift: TShiftState): Boolean; override;\r\n procedure TextChanged; override;\r\n procedure EnabledChanged; override;\r\n procedure DefineProperties(Filer: TFiler); override;\r\n procedure CreateParams(var Params: TCreateParams); override;\r\n function GetPalette: HPALETTE; override;\r\n procedure MouseDown(Button: TMouseButton; Shift: TShiftState;\r\n X, Y: Integer); override;\r\n procedure KeyDown(var Key: Word; Shift: TShiftState); override;\r\n procedure Paint; override;\r\n procedure DoOn; dynamic;\r\n procedure DoOff; dynamic;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n procedure ToggleSwitch;\r\n published\r\n {$IFDEF JVCLThemesEnabled}\r\n property ParentBackground default True;\r\n {$ENDIF JVCLThemesEnabled}\r\n property Align;\r\n property BorderStyle: TBorderStyle read FBorderStyle write SetBorderStyle default bsNone;\r\n property Caption;\r\n property Color;\r\n property Cursor;\r\n property DragCursor;\r\n property DragKind;\r\n property OnEndDock;\r\n property OnStartDock;\r\n property DragMode;\r\n property Enabled;\r\n property Font;\r\n property GlyphOff: TBitmap index 0 read GetSwitchGlyph write SetSwitchGlyph stored StoreBitmap;\r\n property GlyphOn: TBitmap index 1 read GetSwitchGlyph write SetSwitchGlyph stored StoreBitmap;\r\n property ParentColor;\r\n property ParentFont;\r\n property ParentShowHint;\r\n property PopupMenu;\r\n property ShowFocus: Boolean read FShowFocus write SetShowFocus default True;\r\n property ToggleKey: TShortCut read FToggleKey write FToggleKey default Ord(' ');\r\n property ShowHint;\r\n property StateOn: Boolean read FStateOn write SetStateOn default False;\r\n property TabOrder;\r\n property TabStop default True;\r\n property TextPosition: TTextPos read FTextPosition write SetTextPosition default tpNone;\r\n property Anchors;\r\n property Constraints;\r\n property Visible;\r\n property OnClick;\r\n property OnDblClick;\r\n property OnEnter;\r\n property OnExit;\r\n property OnMouseMove;\r\n property OnMouseDown;\r\n property OnMouseUp;\r\n property OnKeyDown;\r\n property OnKeyUp;\r\n property OnKeyPress;\r\n property OnDragOver;\r\n property OnDragDrop;\r\n property OnEndDrag;\r\n property OnStartDrag;\r\n property OnContextPopup;\r\n property OnOn: TNotifyEvent read FOnOn write FOnOn;\r\n property OnOff: TNotifyEvent read FOnOff write FOnOff;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvSwitch.pas $';\r\n Revision: '$Revision: 13338 $';\r\n Date: '$Date: 2012-06-13 10:23:33 +0200 (mer. 13 juin 2012) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n JvJVCLUtils, JvThemes;\r\n\r\n{$R JvSwitch.Res}\r\n\r\nconstructor TJvSwitch.Create(AOwner: TComponent);\r\nvar\r\n I: Boolean;\r\nbegin\r\n inherited Create(AOwner);\r\n ControlStyle := [csClickEvents, csSetCaption, csCaptureMouse,\r\n csOpaque, csDoubleClicks];\r\n IncludeThemeStyle(Self, [csParentBackground]);\r\n Width := 50;\r\n Height := 60;\r\n for I := False to True do\r\n begin\r\n FBitmaps[I] := TBitmap.Create;\r\n SetSwitchGlyph(Ord(I), nil);\r\n FBitmaps[I].OnChange := GlyphChanged;\r\n end;\r\n FUserBitmaps := [];\r\n FShowFocus := True;\r\n FStateOn := False;\r\n FTextPosition := tpNone;\r\n FBorderStyle := bsNone;\r\n FToggleKey := Ord(' ');\r\n TabStop := True;\r\nend;\r\n\r\ndestructor TJvSwitch.Destroy;\r\nvar\r\n I: Boolean;\r\nbegin\r\n for I := False to True do\r\n begin\r\n FBitmaps[I].OnChange := nil;\r\n FDisableBitmaps[I].Free;\r\n FBitmaps[I].Free;\r\n end;\r\n inherited Destroy;\r\nend;\r\n\r\n\r\nprocedure TJvSwitch.CreateParams(var Params: TCreateParams);\r\nconst\r\n BorderStyles: array [TBorderStyle] of Longint = (0, WS_BORDER);\r\nbegin\r\n inherited CreateParams(Params);\r\n with Params do\r\n begin\r\n WindowClass.Style := WindowClass.Style or CS_HREDRAW or CS_VREDRAW;\r\n Style := Style or Longword(BorderStyles[FBorderStyle]);\r\n end;\r\nend;\r\n\r\n\r\nprocedure TJvSwitch.DefineProperties(Filer: TFiler);\r\n\r\n function DoWrite: Boolean;\r\n begin\r\n if Assigned(Filer.Ancestor) then\r\n Result := FUserBitmaps <> TJvSwitch(Filer.Ancestor).FUserBitmaps\r\n else\r\n Result := FUserBitmaps <> [];\r\n end;\r\n\r\nbegin\r\n inherited DefineProperties(Filer);\r\n Filer.DefineBinaryProperty('Data', ReadBinaryData, WriteBinaryData,DoWrite);\r\nend;\r\n\r\n\r\nfunction TJvSwitch.GetPalette: HPALETTE;\r\nbegin\r\n if Enabled then\r\n Result := FBitmaps[FStateOn].Palette\r\n else\r\n Result := 0;\r\nend;\r\n\r\n\r\nprocedure TJvSwitch.ReadBinaryData(Stream: TStream);\r\nbegin\r\n Stream.ReadBuffer(FUserBitmaps, SizeOf(FUserBitmaps));\r\nend;\r\n\r\nprocedure TJvSwitch.WriteBinaryData(Stream: TStream);\r\nbegin\r\n Stream.WriteBuffer(FUserBitmaps, SizeOf(FUserBitmaps));\r\nend;\r\n\r\nfunction TJvSwitch.StoreBitmap(Index: Integer): Boolean;\r\nbegin\r\n Result := (Index <> 0) in FUserBitmaps;\r\nend;\r\n\r\nfunction TJvSwitch.GetSwitchGlyph(Index: Integer): TBitmap;\r\nbegin\r\n if csLoading in ComponentState then\r\n Include(FUserBitmaps, Index <> 0);\r\n Result := FBitmaps[Index <> 0];\r\nend;\r\n\r\nprocedure TJvSwitch.CreateDisabled(Index: Boolean);\r\nbegin\r\n FreeAndNil(FDisableBitmaps[Index]);\r\n FDisableBitmaps[Index] :=\r\n CreateDisabledBitmap(FBitmaps[Index], clBlack);\r\nend;\r\n\r\nprocedure TJvSwitch.GlyphChanged(Sender: TObject);\r\nvar\r\n I: Boolean;\r\nbegin\r\n for I := False to True do\r\n if Sender = FBitmaps[I] then\r\n CreateDisabled(I);\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvSwitch.SetSwitchGlyph(Index: Integer; Value: TBitmap);\r\nconst\r\n ResName: array [Boolean] of PChar = ('JvSwitchOFF', 'JvSwitchON');\r\nbegin\r\n if Value <> nil then\r\n begin\r\n FBitmaps[Index <> 0].Assign(Value);\r\n Include(FUserBitmaps, Index <> 0);\r\n end\r\n else\r\n begin\r\n FBitmaps[Index <> 0].Assign(nil); // fixes GDI resource leak\r\n FBitmaps[Index <> 0].LoadFromResourceName(HInstance, ResName[Index <> 0]);\r\n Exclude(FUserBitmaps, Index <> 0);\r\n end;\r\nend;\r\n\r\nprocedure TJvSwitch.FocusChanged(Control: TWinControl);\r\nvar\r\n Active: Boolean;\r\nbegin\r\n Active := (Control = Self);\r\n if Active <> FActive then\r\n begin\r\n FActive := Active;\r\n if FShowFocus then\r\n Invalidate;\r\n end;\r\n inherited FocusChanged(Control);\r\nend;\r\n\r\nprocedure TJvSwitch.EnabledChanged;\r\nbegin\r\n inherited EnabledChanged;\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvSwitch.TextChanged;\r\nbegin\r\n inherited TextChanged;\r\n Invalidate;\r\nend;\r\n\r\nfunction TJvSwitch.WantKey(Key: Integer; Shift: TShiftState): Boolean;\r\nbegin\r\n Result := IsAccel(Key, Caption) and CanFocus and (ssAlt in Shift);\r\n if Result then\r\n SetFocus;\r\nend;\r\n\r\nfunction TJvSwitch.DoEraseBackground(Canvas: TCanvas; Param: LPARAM): Boolean;\r\nbegin\r\n Result := True; // the component paints the background in Paint\r\nend;\r\n\r\nprocedure TJvSwitch.MouseDown(Button: TMouseButton; Shift: TShiftState;\r\n X, Y: Integer);\r\nbegin\r\n if Button = mbLeft then\r\n begin\r\n if TabStop and CanFocus then\r\n SetFocus;\r\n ToggleSwitch;\r\n end;\r\n inherited MouseDown(Button, Shift, X, Y);\r\nend;\r\n\r\nprocedure TJvSwitch.KeyDown(var Key: Word; Shift: TShiftState);\r\nbegin\r\n inherited KeyDown(Key, Shift);\r\n if FToggleKey = ShortCut(Key, Shift) then\r\n begin\r\n ToggleSwitch;\r\n Key := 0;\r\n end;\r\nend;\r\n\r\nprocedure TJvSwitch.Paint;\r\nvar\r\n ARect: TRect;\r\n Text: string;\r\n FontHeight: Integer;\r\n\r\n procedure DrawBitmap(Bmp: TBitmap);\r\n var\r\n IWidth, IHeight, X, Y: Integer;\r\n IRect: TRect;\r\n begin\r\n IWidth := Bmp.Width;\r\n IHeight := Bmp.Height;\r\n IRect := Rect(0, 0, IWidth, IHeight);\r\n X := 0;\r\n Y := 0;\r\n case FTextPosition of\r\n tpNone:\r\n begin\r\n X := ((Width - IWidth) div 2);\r\n Y := ((Height - IHeight) div 2);\r\n end;\r\n tpLeft:\r\n begin\r\n X := Width - IWidth;\r\n Y := ((Height - IHeight) div 2);\r\n Dec(ARect.Right, IWidth);\r\n end;\r\n tpRight:\r\n begin\r\n X := 0;\r\n Y := ((Height - IHeight) div 2);\r\n Inc(ARect.Left, IWidth);\r\n end;\r\n tpAbove:\r\n begin\r\n X := ((Width - IWidth) div 2);\r\n Y := Height - IHeight;\r\n Dec(ARect.Bottom, IHeight);\r\n end;\r\n tpBelow:\r\n begin\r\n X := ((Width - IWidth) div 2);\r\n Y := 0;\r\n Inc(ARect.Top, IHeight);\r\n end;\r\n end;\r\n Bmp.Transparent := True;\r\n Canvas.Draw(X, Y, Bmp);\r\n if Focused and FShowFocus and TabStop and not (csDesigning in ComponentState) then\r\n Canvas.DrawFocusRect(Rect(X, Y, X + IWidth, Y + IHeight));\r\n end;\r\n\r\nbegin\r\n ARect := GetClientRect;\r\n Canvas.Font := Font;\r\n Canvas.Brush.Color := Color;\r\n DrawThemedBackground(Self, Canvas, ARect);\r\n if not Enabled and (FDisableBitmaps[FStateOn] <> nil) then\r\n DrawBitmap(FDisableBitmaps[FStateOn])\r\n else\r\n DrawBitmap(FBitmaps[FStateOn]);\r\n if FTextPosition <> tpNone then\r\n begin\r\n FontHeight := Canvas.TextHeight('W');\r\n ARect.Top := ((ARect.Bottom + ARect.Top) - FontHeight) shr 1;\r\n ARect.Bottom := ARect.Top + FontHeight;\r\n Text := Caption;\r\n DrawText(Canvas, Text, Length(Caption), ARect, DT_EXPANDTABS or DT_VCENTER or DT_CENTER);\r\n end;\r\nend;\r\n\r\nprocedure TJvSwitch.DoOn;\r\nbegin\r\n if Assigned(FOnOn) then\r\n FOnOn(Self);\r\nend;\r\n\r\nprocedure TJvSwitch.DoOff;\r\nbegin\r\n if Assigned(FOnOff) then\r\n FOnOff(Self);\r\nend;\r\n\r\nprocedure TJvSwitch.ToggleSwitch;\r\nbegin\r\n StateOn := not StateOn;\r\nend;\r\n\r\nprocedure TJvSwitch.SetBorderStyle(Value: TBorderStyle);\r\nbegin\r\n if FBorderStyle <> Value then\r\n begin\r\n FBorderStyle := Value;\r\n RecreateWnd;\r\n end;\r\nend;\r\n\r\nprocedure TJvSwitch.SetStateOn(Value: Boolean);\r\nbegin\r\n if FStateOn <> Value then\r\n begin\r\n FStateOn := Value;\r\n Invalidate;\r\n if Value then\r\n DoOn\r\n else\r\n DoOff;\r\n end;\r\nend;\r\n\r\nprocedure TJvSwitch.SetTextPosition(Value: TTextPos);\r\nbegin\r\n if FTextPosition <> Value then\r\n begin\r\n FTextPosition := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvSwitch.SetShowFocus(Value: Boolean);\r\nbegin\r\n if FShowFocus <> Value then\r\n begin\r\n FShowFocus := Value;\r\n if not (csDesigning in ComponentState) then\r\n Invalidate;\r\n end;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvSyncSplitter.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvSyncSplitter.PAS, released on 2000-11-22.\r\n\r\nThe Initial Developer of the Original Code is Peter Below <100113 dott 1101 att compuserve dott com>\r\nPortions created by Peter Below are Copyright (C) 2000 Peter Below.\r\nAll Rights Reserved.\r\n\r\nContributor(s): ______________________________________.\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvSyncSplitter.pas 13104 2011-09-07 06:50:43Z obones $\r\n\r\nunit JvSyncSplitter;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n SysUtils, Classes, Messages, Controls, ExtCtrls,\r\n JvSplitter;\r\n\r\ntype\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvSyncSplitter = class(TJvSplitter)\r\n private\r\n FPartner: TJvSyncSplitter;\r\n FForcedSize: Boolean;\r\n procedure SetPartner(const Value: TJvSyncSplitter);\r\n protected\r\n function GetResizeStyle: TResizeStyle;\r\n procedure Notification(AComponent: TComponent; Operation: TOperation); override;\r\n procedure SetResizeStyle(Value: TResizeStyle);\r\n procedure VerifyPartner;\r\n procedure WndProc(var Msg: TMessage); override;\r\n published\r\n property Partner: TJvSyncSplitter read FPartner write SetPartner;\r\n property ResizeStyle: TResizeStyle read GetResizeStyle write SetResizeStyle;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvSyncSplitter.pas $';\r\n Revision: '$Revision: 13104 $';\r\n Date: '$Date: 2011-09-07 08:50:43 +0200 (mer. 07 sept. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n JvTypes, JvResources, JvJVCLUtils;\r\n\r\nfunction TJvSyncSplitter.GetResizeStyle: TResizeStyle;\r\nbegin\r\n Result := inherited ResizeStyle\r\nend;\r\n\r\nprocedure TJvSyncSplitter.Notification(AComponent: TComponent; Operation: TOperation);\r\nbegin\r\n inherited Notification(AComponent, Operation);\r\n if (Operation = opRemove) and (AComponent = Partner) then\r\n Partner := nil;\r\nend;\r\n\r\nprocedure TJvSyncSplitter.SetPartner(const Value: TJvSyncSplitter);\r\nbegin\r\n if Value <> Self then\r\n begin\r\n ReplaceComponentReference(Self, Value, TComponent(FPartner));\r\n VerifyPartner;\r\n end\r\n else\r\n raise EJVCLException.CreateRes(@RsEInvalidPartner);\r\nend;\r\n\r\nprocedure TJvSyncSplitter.SetResizeStyle(Value: TResizeStyle);\r\nbegin\r\n inherited ResizeStyle := Value;\r\n VerifyPartner;\r\nend;\r\n\r\nprocedure TJvSyncSplitter.VerifyPartner;\r\nbegin\r\n if csDesigning in ComponentState then\r\n if Assigned(Partner) then\r\n if ((Partner.ResizeStyle = rsUpdate) and (ResizeStyle <> rsUpdate)) or\r\n ((Partner.ResizeStyle <> rsUpdate) and (ResizeStyle = rsUpdate)) then\r\n {if MessageDlg(Format('Current ResizeStyle settings for %s and %s will'\r\n + ' cause problems at runtime. Change both to rsUpdate?',\r\n [Name, Partner.Name]), mtWarning, [mbYes,mbNo], 0) = mrYes then}\r\n begin\r\n if Partner.ResizeStyle = rsUpdate then\r\n ResizeStyle := rsUpdate\r\n else\r\n Partner.ResizeStyle := rsUpdate;\r\n end;\r\nend;\r\n\r\n\r\nprocedure TJvSyncSplitter.WndProc(var Msg: TMessage);\r\nbegin\r\n if Assigned(FPartner) and not FForcedSize and not (csDesigning in ComponentState) then\r\n case Msg.Msg of\r\n WM_MOUSEFIRST..WM_MOUSELAST:\r\n begin\r\n Partner.FForcedSize := True;\r\n try\r\n Partner.Perform(Msg.Msg, Msg.WParam, Msg.LParam);\r\n finally\r\n Partner.FForcedSize := False;\r\n end;\r\n end;\r\n end;\r\n inherited WndProc(Msg);\r\nend;\r\n\r\n\r\n\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvSysRequirements.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvgSysRequirements.PAS, released on 2003-01-15.\r\n\r\nThe Initial Developer of the Original Code is Andrey V. Chudin, [chudin att yandex dott ru]\r\nPortions created by Andrey V. Chudin are Copyright (C) 2003 Andrey V. Chudin.\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\nMichael Beck [mbeck att bigfoot dott com].\r\nBurov Dmitry, translation of russian text.\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvSysRequirements.pas 13145 2011-11-02 21:15:19Z ahuser $\r\n\r\nunit JvSysRequirements;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, SysUtils, Classes, Forms,\r\n JvComponentBase,\r\n JclSysInfo;\r\n\r\ntype\r\n TJvSystemFont = (fsfSmallFont, fsfBigFont);\r\n TJvSystemFontSet = set of TJvSystemFont;\r\n TWindowsVersionSet = set of TWindowsVersion;\r\n TJvSysReqBehavior = (fsbHalt, fsbWarning);\r\n\r\n TJvWarningEvent = procedure(Sender: TObject; var ReportMessage: string;\r\n var DoShowWarning, DoHalt: Boolean) of object;\r\n\r\nconst\r\n AllWindowsVersions = [wvUnknown];\r\n AllSystemFonts = [fsfSmallFont, fsfBigFont];\r\n\r\ntype\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64 or pidOSX32)]\r\n {$ENDIF RTL230_UP}\r\n TJvSysRequirements = class(TJvComponent)\r\n private\r\n FBehavior: TJvSysReqBehavior;\r\n FEnabled: Boolean;\r\n FMinColorDepth: Integer;\r\n FMaxColorDepth: Integer;\r\n FMinScreenX: Integer;\r\n FMaxScreenX: Integer;\r\n FMinScreenY: Integer;\r\n FMaxScreenY: Integer;\r\n FSystemFonts: TJvSystemFontSet;\r\n FWindowsVersions: TWindowsVersionSet;\r\n FMinVideoRefreshRate: Integer;\r\n FMaxVideoRefreshRate: Integer;\r\n FOnWarning: TJvWarningEvent;\r\n procedure SetMinColorDepth(Value: Integer);\r\n procedure SetMaxColorDepth(Value: Integer);\r\n procedure SetMinScreenX(Value: Integer);\r\n procedure SetMaxScreenX(Value: Integer);\r\n procedure SetMinScreenY(Value: Integer);\r\n procedure SetMaxScreenY(Value: Integer);\r\n procedure SetMinVideoRefreshRate(Value: Integer);\r\n procedure SetMaxVideoRefreshRate(Value: Integer);\r\n procedure SetSystemFonts(const Value: TJvSystemFontSet);\r\n procedure SetWindowsVersions(const Value: TWindowsVersionSet);\r\n protected\r\n procedure Loaded; override;\r\n function TestRequirements(var ReportMessage: string): Boolean; dynamic;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n published\r\n property Behavior: TJvSysReqBehavior read FBehavior write FBehavior default fsbHalt;\r\n property Enabled: Boolean read FEnabled write FEnabled default True;\r\n property MinColorDepth: Integer read FMinColorDepth write SetMinColorDepth default 0;\r\n property MaxColorDepth: Integer read FMaxColorDepth write SetMaxColorDepth default 0;\r\n property MinScreenX: Integer read FMinScreenX write SetMinScreenX default 0;\r\n property MaxScreenX: Integer read FMaxScreenX write SetMaxScreenX default 0;\r\n property MinScreenY: Integer read FMinScreenY write SetMinScreenY default 0;\r\n property MaxScreenY: Integer read FMaxScreenY write SetMaxScreenY default 0;\r\n property MinVideoRefreshRate: Integer read FMinVideoRefreshRate write SetMinVideoRefreshRate default 0;\r\n property MaxVideoRefreshRate: Integer read FMaxVideoRefreshRate write SetMaxVideoRefreshRate default 0;\r\n property WindowsVersions: TWindowsVersionSet read FWindowsVersions write SetWindowsVersions default\r\n AllWindowsVersions;\r\n property SystemFonts: TJvSystemFontSet read FSystemFonts write SetSystemFonts default AllSystemFonts;\r\n property OnWarning: TJvWarningEvent read FOnWarning write FOnWarning;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvSysRequirements.pas $';\r\n Revision: '$Revision: 13145 $';\r\n Date: '$Date: 2011-11-02 22:15:19 +0100 (mer. 02 nov. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n JvResources;\r\n\r\nconstructor TJvSysRequirements.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FBehavior := fsbHalt;\r\n FEnabled := True;\r\n FMinColorDepth := 0;\r\n FMaxColorDepth := 0;\r\n FMinScreenX := 0;\r\n FMaxScreenX := 0;\r\n FMinScreenY := 0;\r\n FMaxScreenY := 0;\r\n FMinVideoRefreshRate := 0;\r\n FMaxVideoRefreshRate := 0;\r\n FWindowsVersions := AllWindowsVersions;\r\n FSystemFonts := AllSystemFonts;\r\nend;\r\n\r\nprocedure TJvSysRequirements.Loaded;\r\nvar\r\n ReportMessage: string;\r\n DoShowWarning, DoHalt: Boolean;\r\n Icon: Integer;\r\nbegin\r\n inherited Loaded;\r\n if Enabled and not (csDesigning in ComponentState) then\r\n if not TestRequirements(ReportMessage) then\r\n begin\r\n DoShowWarning := True;\r\n DoHalt := Behavior = fsbHalt;\r\n if Assigned(FOnWarning) then\r\n FOnWarning(Self, ReportMessage, DoShowWarning, DoHalt);\r\n if DoHalt then\r\n Icon := MB_ICONERROR\r\n else\r\n Icon := MB_ICONWARNING;\r\n if DoShowWarning then\r\n Application.MessageBox(PChar(ReportMessage),\r\n PChar(Format(RsSysRequirementsCaption, [ExtractFileName(ParamStr(0))])), MB_OK + Icon);\r\n if DoHalt then\r\n Application.Terminate;\r\n end;\r\nend;\r\n\r\nfunction TJvSysRequirements.TestRequirements(var ReportMessage: string): Boolean;\r\nvar\r\n DC: HDC;\r\n Refresh, ScreenX, ScreenY, BitsPerPixel, LogPixels: Integer;\r\n\r\n procedure Test(Value: Boolean; const ErrMsg: string);\r\n begin\r\n Result := Result and Value;\r\n if not Value then\r\n begin\r\n if ReportMessage <> '' then\r\n ReportMessage := ReportMessage + sLineBreak;\r\n ReportMessage := ReportMessage + ErrMsg;\r\n end;\r\n end;\r\n\r\n procedure TestMinMax(TestVal, MinVal, MaxVal: Integer; const MinMsg, MaxMsg, BetweenMsg: string);\r\n begin\r\n if (MinVal > 0) or (MaxVal > 0) then\r\n if (MinVal > 0) and (MaxVal > 0) then\r\n Test((TestVal >= MinVal) and (TestVal <= MaxVal), Format(BetweenMsg, [TestVal, MinVal, MaxVal]))\r\n else\r\n if MinVal > 0 then\r\n Test(TestVal >= MinVal, Format(MinMsg, [TestVal, MinVal]))\r\n else\r\n Test(TestVal <= MaxVal, Format(MaxMsg, [TestVal, MaxVal]));\r\n end;\r\n\r\nbegin\r\n ReportMessage := '';\r\n Result := True;\r\n\r\n DC := GetDC(HWND_DESKTOP);\r\n BitsPerPixel := GetDeviceCaps(DC, BITSPIXEL);\r\n ScreenX := GetDeviceCaps(DC, HORZRES);\r\n ScreenY := GetDeviceCaps(DC, VERTRES);\r\n Refresh := GetDeviceCaps(DC, VREFRESH);\r\n LogPixels := GetDeviceCaps(DC, LOGPIXELSX);\r\n ReleaseDC(HWND_DESKTOP, DC);\r\n\r\n TestMinMax(BitsPerPixel, MinColorDepth, MaxColorDepth, RsMinColorDepthReq, RsMaxColorDepthReq,\r\n RsBetweenColorDepthReq);\r\n TestMinMax(ScreenX, MinScreenX, MaxScreenX, RsMinScreenXReq, RsMaxScreenXReq, RsBetweenScreenXReq);\r\n TestMinMax(ScreenY, MinScreenY, MaxScreenY, RsMinScreenYReq, RsMaxScreenYReq, RsBetweenScreenYReq);\r\n TestMinMax(Refresh, MinVideoRefreshRate, MaxVideoRefreshRate, RsMinRefreshReq, RsMaxRefreshReq,\r\n RsBetweenRefreshReq);\r\n if not (wvUnknown in WindowsVersions) then\r\n Test(GetWindowsVersion in WindowsVersions, RsWindowsVersionReq);\r\n if SystemFonts = [fsfSmallFont] then\r\n Test(LogPixels = 96, RsSystemFontSmallReq);\r\n if SystemFonts = [fsfBigFont] then\r\n Test(LogPixels = 120, RsSystemFontBigReq);\r\nend;\r\n\r\nprocedure TJvSysRequirements.SetMinColorDepth(Value: Integer);\r\nbegin\r\n Value := Abs(Value);\r\n FMinColorDepth := Value;\r\n if (Value > MaxColorDepth) and (MaxColorDepth <> 0) then\r\n MaxColorDepth := Value;\r\nend;\r\n\r\nprocedure TJvSysRequirements.SetMaxColorDepth(Value: Integer);\r\nbegin\r\n Value := Abs(Value);\r\n FMaxColorDepth := Value;\r\n if (Value <> 0) and (Value < MinColorDepth) then\r\n MinColorDepth := Value;\r\nend;\r\n\r\nprocedure TJvSysRequirements.SetMinScreenX(Value: Integer);\r\nbegin\r\n Value := Abs(Value);\r\n FMinScreenX := Value;\r\n if (Value > MaxScreenX) and (MaxScreenX <> 0) then\r\n MaxScreenX := Value;\r\nend;\r\n\r\nprocedure TJvSysRequirements.SetMaxScreenX(Value: Integer);\r\nbegin\r\n Value := Abs(Value);\r\n FMaxScreenX := Value;\r\n if (Value <> 0) and (MaxScreenX <> 0) then\r\n MinScreenX := Value;\r\nend;\r\n\r\nprocedure TJvSysRequirements.SetMinScreenY(Value: Integer);\r\nbegin\r\n Value := Abs(Value);\r\n FMinScreenY := Value;\r\n if (Value > MaxScreenY) and (MaxScreenY <> 0) then\r\n MaxScreenY := Value;\r\nend;\r\n\r\nprocedure TJvSysRequirements.SetMaxScreenY(Value: Integer);\r\nbegin\r\n Value := Abs(Value);\r\n FMaxScreenY := Value;\r\n if (Value <> 0) and (Value < MinScreenY) then\r\n MinScreenY := Value;\r\nend;\r\n\r\nprocedure TJvSysRequirements.SetMinVideoRefreshRate(Value: Integer);\r\nbegin\r\n Value := Abs(Value);\r\n FMinVideoRefreshRate := Value;\r\n if (Value > MaxVideoRefreshRate) and (MaxVideoRefreshRate <> 0) then\r\n MaxVideoRefreshRate := Value;\r\nend;\r\n\r\nprocedure TJvSysRequirements.SetMaxVideoRefreshRate(Value: Integer);\r\nbegin\r\n Value := Abs(Value);\r\n FMaxVideoRefreshRate := Value;\r\n if (Value <> 0) and (Value < MinVideoRefreshRate) then\r\n MinVideoRefreshRate := Value;\r\nend;\r\n\r\nprocedure TJvSysRequirements.SetSystemFonts(const Value: TJvSystemFontSet);\r\nbegin\r\n if Value = [] then\r\n FSystemFonts := [fsfSmallFont]\r\n else\r\n FSystemFonts := Value;\r\nend;\r\n\r\nprocedure TJvSysRequirements.SetWindowsVersions(const Value: TWindowsVersionSet);\r\nbegin\r\n if ((wvUnknown in Value) and not (wvUnknown in FWindowsVersions)) or (Value = []) then\r\n FWindowsVersions := [wvUnknown]\r\n else\r\n if (wvUnknown in FWindowsVersions) and (Value <> [wvUnknown]) then\r\n FWindowsVersions := Value - [wvUnknown]\r\n else\r\n FWindowsVersions := Value;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend." }, { "path": "External/Jedi/Jvcl/run/JvSystemPopup.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvSystemPopup.PAS, released on 2001-02-28.\r\n\r\nThe Initial Developer of the Original Code is Sbastien Buysse [sbuysse att buypin dott com]\r\nPortions created by Sbastien Buysse are Copyright (C) 2001 Sbastien Buysse.\r\nAll Rights Reserved.\r\n\r\nContributor(s): Michael Beck [mbeck att bigfoot dott com].\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n - the associated TPopupMenu would also be changed during the process :(\r\n\r\nModifications:\r\n 2002.11.22. by Hofi att fw dott hu\r\n - REMOVED the original TMenuItemPrivateAccess hack, overwriting Handle of FPopup\r\n changes the original popup menu itself, not so nice ;)\r\n - ADDED WM_INITMENU handler and a new hack to synchronize the system menu\r\n with the popup menu (because GetSystemMenu( hWnd, True) does not work correctly\r\n inside a WM_INITMENU handler.\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvSystemPopup.pas 13155 2011-11-06 12:31:20Z ahuser $\r\n\r\nunit JvSystemPopup;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Menus,\r\n JvTypes, JvComponentBase;\r\n\r\ntype\r\n TJvPositionInMenu = (pmTop, pmBottom);\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvSystemPopup = class(TJvComponent)\r\n private\r\n FPopup: TPopupMenu;\r\n FOwnerForm: TForm;\r\n FIsHooked: Boolean;\r\n FPosition: TJvPopupPosition;\r\n FPositionInMenu: TJvPositionInMenu;\r\n procedure Hook;\r\n procedure UnHook;\r\n procedure ResetSystemMenu(SystemReset: Boolean = True);\r\n function HandleWndProc(var Msg: TMessage): Boolean;\r\n procedure SetPopup(const Value: TPopupMenu);\r\n procedure PopulateMenu;\r\n procedure SetPosition(const Value: TJvPopupPosition);\r\n procedure SetPositionInMenu(const Value: TJvPositionInMenu);\r\n function GetMenu: HMENU;\r\n protected\r\n procedure Notification(AComponent: TComponent; Operation: TOperation); override;\r\n public\r\n procedure Refresh(SystemReset: Boolean = True);\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n published\r\n property Popup: TPopupMenu read FPopup write SetPopup;\r\n property PositionInMenu: TJvPositionInMenu read FPositionInMenu write\r\n SetPositionInMenu default pmTop;\r\n property Position: TJvPopupPosition read FPosition write SetPosition default ppNone;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvSystemPopup.pas $';\r\n Revision: '$Revision: 13155 $';\r\n Date: '$Date: 2011-11-06 13:31:20 +0100 (dim. 06 nov. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n JvWndProcHook, JvConsts, JvResources, JvJVCLUtils;\r\n\r\ntype\r\n TMenuItemAccessProtected = class(TMenuItem);\r\n\r\nconstructor TJvSystemPopup.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FPosition := ppNone;\r\n FPopup := nil;\r\n FPositionInMenu := pmTop;\r\n\r\n while Assigned(AOwner) and not (AOwner is TForm) do\r\n AOwner := AOwner.Owner;\r\n FOwnerForm := AOwner as TForm;\r\nend;\r\n\r\ndestructor TJvSystemPopup.Destroy;\r\nbegin\r\n Position := ppNone;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJvSystemPopup.GetMenu: HMENU;\r\nbegin\r\n { Return a handle to the copy of the window menu currently in use }\r\n Result := 0;\r\n case FPosition of\r\n ppNone:\r\n ;\r\n ppForm:\r\n if Assigned(FOwnerForm) then\r\n Result := GetSystemMenu(FOwnerForm.Handle, False);\r\n ppApplication:\r\n Result := GetSystemMenu(Application.Handle, False);\r\n end;\r\nend;\r\n\r\nfunction TJvSystemPopup.HandleWndProc(var Msg: TMessage): Boolean;\r\n\r\n function Iterate(MenuItem: TMenuItem): Boolean;\r\n var\r\n I: Integer;\r\n begin\r\n Result := False;\r\n for I := 0 to MenuItem.Count - 1 do\r\n if MenuItem[I].Command = Cardinal(Msg.WParam) then\r\n begin\r\n Result := True;\r\n MenuItem[I].Click;\r\n end\r\n else\r\n if MenuItem[I].Count > 0 then\r\n Result := Iterate(MenuItem[I]);\r\n end;\r\n\r\nvar\r\n SaveIndex: Integer;\r\n MenuItem: TMenuItem;\r\n Canvas: TControlCanvas;\r\n DC: HDC;\r\nbegin\r\n Result := False;\r\n case Msg.Msg of\r\n WM_INITMENU:\r\n // Hack, the original GetSystemMenu( , True) version called by Refresh\r\n // does not have affect immediately in a WM_INITMENU state/handler\r\n // (at least on Win Xp surely not)\r\n Refresh(True);\r\n WM_SYSCOMMAND:\r\n { Catch commands }\r\n if Assigned(FPopup) then\r\n Result := Iterate(FPopup.Items);\r\n WM_DRAWITEM:\r\n { Copied from Forms.pas }\r\n with PDrawItemStruct(Msg.LParam)^ do\r\n if (CtlType = ODT_MENU) and Assigned(FPopup) then\r\n begin\r\n MenuItem := FPopup.FindItem(itemID, fkCommand);\r\n Result := MenuItem <> nil;\r\n if Result then\r\n begin\r\n Canvas := TControlCanvas.Create;\r\n with Canvas do\r\n try\r\n SaveIndex := SaveDC(hDC);\r\n try\r\n Handle := hDC;\r\n Font := Screen.MenuFont;\r\n Menus.DrawMenuItem(MenuItem, Canvas, rcItem,\r\n TOwnerDrawState(LongRec(itemState).Lo));\r\n finally\r\n Handle := 0;\r\n RestoreDC(hDC, SaveIndex)\r\n end;\r\n finally\r\n Free;\r\n end;\r\n end;\r\n end;\r\n WM_MEASUREITEM:\r\n { Copied from Forms.pas }\r\n with PMeasureItemStruct(Msg.LParam)^ do\r\n if (CtlType = ODT_MENU) and Assigned(FPopup) then\r\n begin\r\n MenuItem := FPopup.FindItem(itemID, fkCommand);\r\n Result := MenuItem <> nil;\r\n if Result then\r\n begin\r\n DC := GetWindowDC(Application.Handle);\r\n try\r\n Canvas := TControlCanvas.Create;\r\n with Canvas do\r\n try\r\n SaveIndex := SaveDC(DC);\r\n try\r\n Handle := DC;\r\n Font := Screen.MenuFont;\r\n TMenuItemAccessProtected(MenuItem).MeasureItem(Canvas,\r\n Integer(itemWidth), Integer(itemHeight));\r\n finally\r\n Handle := 0;\r\n RestoreDC(DC, SaveIndex);\r\n end;\r\n finally\r\n Free;\r\n end;\r\n finally\r\n ReleaseDC(Application.Handle, DC);\r\n end;\r\n end\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvSystemPopup.Hook;\r\nbegin\r\n { Hook the application's window or the owner window of TJvSystemPopup }\r\n case FPosition of\r\n ppNone:\r\n ;\r\n ppForm:\r\n begin\r\n if not Assigned(FOwnerForm) then\r\n Exit;\r\n if FIsHooked then\r\n raise EJVCLException.CreateRes(@RsEAlreadyHooked);\r\n RegisterWndProcHook(FOwnerForm, HandleWndProc, hoBeforeMsg);\r\n FIsHooked := True;\r\n end;\r\n ppApplication:\r\n begin\r\n if FIsHooked then\r\n raise EJVCLException.CreateRes(@RsEAlreadyHooked);\r\n Application.HookMainWindow(HandleWndProc);\r\n FIsHooked := True;\r\n end;\r\n end;\r\nend;\r\n\r\nconst\r\n RightToLeftMenuFlag = MFT_RIGHTORDER or MFT_RIGHTJUSTIFY;\r\n Checks: array [Boolean] of DWORD = (MF_UNCHECKED, MF_CHECKED);\r\n Enables: array [Boolean] of DWORD = (MF_DISABLED or MF_GRAYED, MF_ENABLED);\r\n Breaks: array [TMenuBreak] of DWORD = (0, MF_MENUBREAK, MF_MENUBARBREAK);\r\n Separators: array [Boolean] of DWORD = (MF_STRING, MF_SEPARATOR);\r\n\r\n{ AppendMenuItemTo is copied from TMenuItem.AppendTo from Menus.pas }\r\n\r\nfunction AppendMenuItemTo(Menu: HMENU; AMenuItem: TMenuItem;\r\n ARightToLeft: Boolean; InsertAt: Integer; var SubMenu: HMENU): Boolean;\r\nconst\r\n IBreaks: array [TMenuBreak] of DWORD =\r\n (MFT_STRING, MFT_MENUBREAK, MFT_MENUBARBREAK);\r\n IChecks: array [Boolean] of DWORD = (MFS_UNCHECKED, MFS_CHECKED);\r\n IDefaults: array [Boolean] of DWORD = (0, MFS_DEFAULT);\r\n IEnables: array [Boolean] of DWORD = (MFS_DISABLED or MFS_GRAYED, MFS_ENABLED);\r\n IRadios: array [Boolean] of DWORD = (MFT_STRING, MFT_RADIOCHECK);\r\n ISeparators: array [Boolean] of DWORD = (MFT_STRING, MFT_SEPARATOR);\r\n IRTL: array [Boolean] of DWORD = (0, RightToLeftMenuFlag);\r\n IOwnerDraw: array [Boolean] of DWORD = (MFT_STRING, MFT_OWNERDRAW);\r\nvar\r\n MenuItemInfo: TMenuItemInfo;\r\n Caption: string;\r\n NewFlags: Integer;\r\n IsOwnerDraw: Boolean;\r\n ParentMenu: TMenu;\r\nbegin\r\n Result := AMenuItem.Visible;\r\n if not Result then\r\n Exit;\r\n\r\n Caption := AMenuItem.Caption;\r\n if AMenuItem.Count > 0 then\r\n begin\r\n SubMenu := CreatePopupMenu;\r\n MenuItemInfo.hSubMenu := SubMenu;\r\n end\r\n else\r\n if (AMenuItem.ShortCut <> scNone) and ((AMenuItem.Parent = nil) or\r\n (AMenuItem.Parent.Parent <> nil) or not (AMenuItem.Parent.Owner is TMainMenu)) then\r\n Caption := Caption + Tab + ShortCutToText(AMenuItem.ShortCut);\r\n if Lo(GetVersion) >= 4 then\r\n begin\r\n MenuItemInfo.cbSize := 44; // Required for Windows 95\r\n MenuItemInfo.fMask := MIIM_CHECKMARKS or MIIM_DATA or MIIM_ID or\r\n MIIM_STATE or MIIM_SUBMENU or MIIM_TYPE;\r\n ParentMenu := AMenuItem.GetParentMenu;\r\n // IsOwnerDraw := Assigned(ParentMenu) and ParentMenu.IsOwnerDraw or\r\n IsOwnerDraw := Assigned(ParentMenu) and\r\n (ParentMenu.OwnerDraw or (AMenuItem.GetImageList <> nil)) or\r\n Assigned(AMenuItem.Bitmap) and not AMenuItem.Bitmap.Empty;\r\n MenuItemInfo.fType := IRadios[AMenuItem.RadioItem] or\r\n IBreaks[AMenuItem.Break] or\r\n ISeparators[AMenuItem.Caption = cLineCaption] or IRTL[ARightToLeft] or\r\n IOwnerDraw[IsOwnerDraw];\r\n MenuItemInfo.fState := IChecks[AMenuItem.Checked] or\r\n IEnables[AMenuItem.Enabled] or IDefaults[AMenuItem.Default];\r\n MenuItemInfo.wID := AMenuItem.Command;\r\n MenuItemInfo.hSubMenu := 0;\r\n MenuItemInfo.hbmpChecked := 0;\r\n MenuItemInfo.hbmpUnchecked := 0;\r\n MenuItemInfo.dwTypeData := PChar(Caption);\r\n if AMenuItem.Count > 0 then\r\n begin\r\n MenuItemInfo.hSubMenu := SubMenu;\r\n end;\r\n InsertMenuItem(Menu, DWORD(InsertAt), True, MenuItemInfo);\r\n end\r\n else\r\n begin\r\n NewFlags := Breaks[AMenuItem.Break] or Checks[AMenuItem.Checked] or\r\n Enables[AMenuItem.Enabled] or\r\n Separators[AMenuItem.Caption = cLineCaption] or MF_BYPOSITION;\r\n if AMenuItem.Count > 0 then\r\n InsertMenu(Menu, DWORD(InsertAt), MF_POPUP or NewFlags,\r\n SubMenu, PChar(AMenuItem.Caption))\r\n else\r\n InsertMenu(Menu, DWORD(InsertAt), NewFlags, AMenuItem.Command,\r\n PChar(AMenuItem.Caption));\r\n end;\r\nend;\r\n\r\nprocedure IterateMenu(AMenu: HMENU; AMenuItem: TMenuItem;\r\n ARightToLeft: Boolean; InsertAt: Integer);\r\nvar\r\n I: Integer;\r\n SubMenu: HMENU;\r\nbegin\r\n with AMenuItem do\r\n for I := 0 to Count - 1 do\r\n begin\r\n if AppendMenuItemTo(AMenu, Items[I], ARightToLeft, InsertAt, SubMenu) and\r\n (InsertAt >= 0) then\r\n Inc(InsertAt);\r\n\r\n if SubMenu > 0 then\r\n IterateMenu(SubMenu, Items[I], ARightToLeft, 0);\r\n end;\r\nend;\r\n\r\nprocedure TJvSystemPopup.Notification(AComponent: TComponent;\r\n Operation: TOperation);\r\nbegin\r\n inherited Notification(AComponent, Operation);\r\n if (AComponent = FPopup) and (Operation = opRemove) then\r\n Popup := nil;\r\nend;\r\n\r\nprocedure TJvSystemPopup.PopulateMenu;\r\nvar\r\n Menu: HMENU;\r\n MenuItemInfo: TMenuItemInfo;\r\n MenuRightToLeft: Boolean;\r\n InsertAt: Integer;\r\nbegin\r\n { Add all MenuItems to the systemmenu }\r\n if (ComponentState * [csDesigning, csLoading] <> []) or\r\n (FPosition = ppNone) or (FPopup = nil) then\r\n Exit;\r\n\r\n MenuRightToLeft := FPopup.IsRightToLeft;\r\n\r\n Menu := GetMenu;\r\n if Menu = 0 then\r\n Exit;\r\n\r\n if PositionInMenu = pmTop then\r\n InsertAt := 0\r\n else\r\n InsertAt := -1;\r\n\r\n if FPopup.Items.Count > 0 then\r\n begin\r\n { Add a seperator }\r\n FillChar(MenuItemInfo, SizeOf(MenuItemInfo), #0);\r\n MenuItemInfo.cbSize := 44; //SizeOf(MenuItemInfo);\r\n MenuItemInfo.fMask := MIIM_CHECKMARKS or MIIM_DATA or\r\n MIIM_ID or MIIM_STATE or MIIM_SUBMENU or MIIM_TYPE;\r\n MenuItemInfo.fType := MFT_SEPARATOR;\r\n { Give the seperator menu id $EFFF so we can seperate these from the\r\n normal seperators (with id=0), that we don't want to remove in procedure\r\n RemoveNonDefaultItems }\r\n MenuItemInfo.wID := $EFFF;\r\n InsertMenuItem(Menu, DWORD(InsertAt), True, MenuItemInfo);\r\n end;\r\n\r\n IterateMenu(Menu, FPopup.Items, MenuRightToLeft, InsertAt);\r\nend;\r\n\r\nprocedure TJvSystemPopup.Refresh(SystemReset: Boolean = True);\r\nbegin\r\n ResetSystemMenu(SystemReset);\r\n PopulateMenu;\r\nend;\r\n\r\nprocedure TJvSystemPopup.ResetSystemMenu(SystemReset: Boolean);\r\n\r\n // Hack, the original GetSystemMenu( , True) version called by Refresh\r\n // does not have affect immediately in WM_INITMENU state\r\n // (at least on Win Xp surely not)\r\n procedure RemoveNonDefaultItems(Menu: HMENU);\r\n var\r\n Id: Longword;\r\n C: Integer;\r\n begin\r\n if GetMenuItemCount(Menu) > 0 then\r\n begin\r\n for C := GetMenuItemCount(Menu) - 1 downto 0 do\r\n begin\r\n Id := GetMenuItemID(Menu, C);\r\n { MSDN : All predefined window menu items have identifier numbers\r\n greater than $F000. If an application adds commands to the window\r\n menu, it should use identifier numbers less than $F000.\r\n\r\n NOTE : SC_SIZE = $F000, seperators seem to have id = 0, although\r\n SC_SEPARATOR is defined as $F00F.\r\n }\r\n // non default system command or an item with submenuitems\r\n if ((Id > 0) and (Id < $F000)) or (Id = $FFFFFFFF) then\r\n begin\r\n if GetMenuItemCount(GetSubMenu(Menu, C)) > 0 then\r\n RemoveNonDefaultItems(GetSubMenu(Menu, C));\r\n DeleteMenu(Menu, C, MF_BYPOSITION);\r\n end;\r\n end;\r\n end;\r\n end;\r\n\r\nbegin\r\n { Reset the window menu back to the default state. The previous window\r\n menu, if any, is destroyed. }\r\n if ComponentState * [csDesigning, csLoading] <> [] then\r\n Exit;\r\n case FPosition of\r\n ppNone:\r\n ;\r\n ppForm:\r\n if Assigned(FOwnerForm) and not (csDestroying in FOwnerForm.ComponentState) then\r\n if SystemReset then\r\n RemoveNonDefaultItems(GetMenu)\r\n else\r\n GetSystemMenu(FOwnerForm.Handle, True);\r\n ppApplication:\r\n if SystemReset then\r\n RemoveNonDefaultItems(GetMenu)\r\n else\r\n GetSystemMenu(Application.Handle, True);\r\n end;\r\nend;\r\n\r\nprocedure TJvSystemPopup.SetPopup(const Value: TPopupMenu);\r\nbegin\r\n if Assigned(FPopup) then\r\n FPopup.OnChange := nil;\r\n ReplaceComponentReference(Self, Value, TComponent(FPopup));\r\n //if Assigned(FPopup) then\r\n // FPopup.OnChange := MenuChanged;\r\n //if not (csLoading in ComponentState) then\r\n // Refresh;\r\nend;\r\n\r\nprocedure TJvSystemPopup.SetPosition(const Value: TJvPopupPosition);\r\nbegin\r\n if FPosition = Value then\r\n Exit;\r\n\r\n if csDesigning in ComponentState then\r\n begin\r\n FPosition := Value;\r\n Exit;\r\n end;\r\n\r\n UnHook;\r\n ResetSystemMenu;\r\n FPosition := Value;\r\n Hook;\r\n //PopulateMenu;\r\nend;\r\n\r\nprocedure TJvSystemPopup.SetPositionInMenu(const Value: TJvPositionInMenu);\r\nbegin\r\n FPositionInMenu := Value;\r\n //if ComponentState * [csLoading, csDesigning] = [] then\r\n // Refresh;\r\nend;\r\n\r\nprocedure TJvSystemPopup.UnHook;\r\nbegin\r\n if not FIsHooked then\r\n Exit;\r\n\r\n case FPosition of\r\n ppNone:\r\n ;\r\n ppForm:\r\n begin\r\n if not Assigned(FOwnerForm) then\r\n Exit;\r\n UnRegisterWndProcHook(FOwnerForm, HandleWndProc, hoBeforeMsg);\r\n FIsHooked := False;\r\n end;\r\n ppApplication:\r\n begin\r\n Application.UnhookMainWindow(HandleWndProc);\r\n FIsHooked := False;\r\n end;\r\n end;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvTFAlarm.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvTFAlarm.PAS, released on 2003-08-01.\r\n\r\nThe Initial Developer of the Original Code is Unlimited Intelligence Limited.\r\nPortions created by Unlimited Intelligence Limited are Copyright (C) 1999-2002 Unlimited Intelligence Limited.\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\nMike Kolter (original code)\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvTFAlarm.pas 13104 2011-09-07 06:50:43Z obones $\r\n\r\nunit JvTFAlarm;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n SysUtils, Classes, Controls, ExtCtrls,\r\n {$IFDEF BCB}\r\n JvTypes,\r\n {$ENDIF BCB}\r\n JvTFManager;\r\n\r\ntype\r\n TJvTFAlarm = class;\r\n\r\n TJvTFAlarmInfo = class(TObject)\r\n private\r\n FAppt: TJvTFAppt;\r\n FSnoozeMins: Integer;\r\n FDismiss: Boolean;\r\n FNextAlarmTime: TTime;\r\n protected\r\n property NextAlarmTime: TTime read FNextAlarmTime write FNextAlarmTime;\r\n public\r\n constructor Create(AAppt: TJvTFAppt); virtual;\r\n property Appt: TJvTFAppt read FAppt;\r\n property SnoozeMins: Integer read FSnoozeMins write FSnoozeMins;\r\n property Dismiss: Boolean read FDismiss write FDismiss;\r\n end;\r\n\r\n TJvTFAlarmList = class(TStringList)\r\n private\r\n FOwner: TJvTFAlarm;\r\n public\r\n procedure Clear; override;\r\n function GetAlarmForAppt(AAppt: TJvTFAppt): TJvTFAlarmInfo;\r\n function GetAlarmForApptID(const ID: string): TJvTFAlarmInfo;\r\n function IndexOfAppt(AAppt: TJvTFAppt): Integer;\r\n procedure AddAppt(AAppt: TJvTFAppt);\r\n procedure DeleteAppt(AAppt: TJvTFAppt);\r\n property Owner: TJvTFAlarm read FOwner write FOwner;\r\n end;\r\n\r\n TJvTFAlarmEvent = procedure(Sender: TObject; AAppt: TJvTFAppt;\r\n var SnoozeMins: Integer; var Dismiss: Boolean) of object;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvTFAlarm = class(TJvTFComponent)\r\n private\r\n FResources: TStringList;\r\n FTimer: TTimer;\r\n FCurrentDate: TDate;\r\n FAlarmList: TJvTFAlarmList;\r\n FOnAlarm: TJvTFAlarmEvent;\r\n FDefaultSnoozeMins: Integer;\r\n function GetResources: TStrings;\r\n procedure SetResources(Value: TStrings);\r\n function GetTimerInterval: Integer;\r\n procedure SetTimerInterval(Value: Integer);\r\n function GetEnabled: Boolean;\r\n procedure SetEnabled(Value: Boolean);\r\n procedure InternalTimer(Sender: TObject);\r\n protected\r\n procedure DestroyApptNotification(AAppt: TJvTFAppt); override;\r\n procedure ConnectSchedules; virtual;\r\n procedure DisconnectSchedules; virtual;\r\n procedure TimerCheck; virtual;\r\n procedure AlarmCheck; virtual;\r\n procedure Loaded; override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n published\r\n property Resources: TStrings read GetResources write SetResources;\r\n property TimerInterval: Integer read GetTimerInterval write SetTimerInterval default 30000;\r\n property Enabled: Boolean read GetEnabled write SetEnabled default True;\r\n property DefaultSnoozeMins: Integer read FDefaultSnoozeMins write FDefaultSnoozeMins default 5;\r\n property OnAlarm: TJvTFAlarmEvent read FOnAlarm write FOnAlarm;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvTFAlarm.pas $';\r\n Revision: '$Revision: 13104 $';\r\n Date: '$Date: 2011-09-07 08:50:43 +0200 (mer. 07 sept. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n JvTFUtils;\r\n\r\n//=== { TJvTFAlarm } =========================================================\r\n\r\nconstructor TJvTFAlarm.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FDefaultSnoozeMins := 5;\r\n FCurrentDate := Date;\r\n FResources := TStringList.Create;\r\n FTimer := TTimer.Create(Self);\r\n FTimer.Interval := 30000;\r\n FTimer.Enabled := True;\r\n FTimer.OnTimer := InternalTimer;\r\n FAlarmList := TJvTFAlarmList.Create;\r\n FAlarmList.Owner := Self;\r\nend;\r\n\r\ndestructor TJvTFAlarm.Destroy;\r\nbegin\r\n DisconnectSchedules;\r\n FTimer.Free;\r\n FResources.Free;\r\n FAlarmList.Create;\r\n FAlarmList.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvTFAlarm.Loaded;\r\nbegin\r\n inherited Loaded;\r\n ConnectSchedules;\r\nend;\r\n\r\nprocedure TJvTFAlarm.AlarmCheck;\r\nvar\r\n I, J, SnoozeMins: Integer;\r\n Dismiss: Boolean;\r\n Sched: TJvTFSched;\r\n Appt: TJvTFAppt;\r\n AlarmInfo: TJvTFAlarmInfo;\r\n AlarmTime: TTime;\r\nbegin\r\n // 1. Roll through all schedules and add an alarm for each appt with a start\r\n // time that is less than the current time. (Duplicate appts will be ignored.)\r\n // 2. Roll through the alarm list and fire an OnAlarm event when appropriate.\r\n\r\n // 1.\r\n for I := 0 to ScheduleCount - 1 do\r\n begin\r\n Sched := Schedules[I];\r\n for J := 0 to Sched.ApptCount - 1 do\r\n begin\r\n Appt := Sched.Appts[J];\r\n AlarmTime := Appt.StartTime - Appt.AlarmAdvance * ONE_MINUTE;\r\n if (AlarmTime < Frac(Time)) and Appt.AlarmEnabled then\r\n FAlarmList.AddAppt(Appt);\r\n end;\r\n end;\r\n\r\n // 2.\r\n for I := 0 to FAlarmList.Count - 1 do\r\n begin\r\n AlarmInfo := TJvTFAlarmInfo(FAlarmList.Objects[I]);\r\n if not AlarmInfo.Dismiss and (AlarmInfo.NextAlarmTime < Frac(Time)) then\r\n begin\r\n SnoozeMins := AlarmInfo.SnoozeMins;\r\n Dismiss := False;\r\n if Assigned(FOnAlarm) then\r\n begin\r\n FOnAlarm(Self, AlarmInfo.Appt, SnoozeMins, Dismiss);\r\n AlarmInfo.SnoozeMins := SnoozeMins;\r\n AlarmInfo.Dismiss := Dismiss;\r\n end;\r\n AlarmInfo.NextAlarmTime := Time + SnoozeMins * ONE_MINUTE;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvTFAlarm.ConnectSchedules;\r\nvar\r\n I: Integer;\r\n CurrentSchedules: TStringList;\r\n Schedule: TJvTFSched;\r\nbegin\r\n CurrentSchedules := TStringList.Create;\r\n try\r\n FTimer.Enabled := False;\r\n // request all appropriate schedules. Store in temporary list so that\r\n // we can release all schedules no longer needed.\r\n for I := 0 to Resources.Count - 1 do\r\n begin\r\n Schedule := RetrieveSchedule(Resources[I], Date);\r\n CurrentSchedules.AddObject('', Schedule);\r\n end;\r\n\r\n // Now release all schedules no longer needed. (Cross check CurrentSchedules\r\n // against Schedules list.)\r\n for I := 0 to ScheduleCount - 1 do\r\n begin\r\n Schedule := Schedules[I];\r\n if CurrentSchedules.IndexOfObject(Schedule) = -1 then\r\n ReleaseSchedule(Schedule.SchedName, Schedule.SchedDate);\r\n end;\r\n finally\r\n CurrentSchedules.Free;\r\n FTimer.Enabled := True;\r\n end;\r\nend;\r\n\r\nprocedure TJvTFAlarm.DestroyApptNotification(AAppt: TJvTFAppt);\r\nbegin\r\n FAlarmList.DeleteAppt(AAppt);\r\n inherited DestroyApptNotification(AAppt);\r\nend;\r\n\r\nprocedure TJvTFAlarm.DisconnectSchedules;\r\nbegin\r\n ReleaseSchedules;\r\nend;\r\n\r\nfunction TJvTFAlarm.GetEnabled: Boolean;\r\nbegin\r\n Result := FTimer.Enabled;\r\nend;\r\n\r\nfunction TJvTFAlarm.GetTimerInterval: Integer;\r\nbegin\r\n Result := FTimer.Interval;\r\nend;\r\n\r\nfunction TJvTFAlarm.GetResources: TStrings;\r\nbegin\r\n Result := FResources;\r\nend;\r\n\r\nprocedure TJvTFAlarm.InternalTimer(Sender: TObject);\r\nbegin\r\n if Trunc(Date) <> Trunc(FCurrentDate) then\r\n begin\r\n FCurrentDate := Date;\r\n ConnectSchedules;\r\n end;\r\n TimerCheck;\r\nend;\r\n\r\nprocedure TJvTFAlarm.SetEnabled(Value: Boolean);\r\nbegin\r\n FTimer.Enabled := Value;\r\nend;\r\n\r\nprocedure TJvTFAlarm.SetResources(Value: TStrings);\r\nbegin\r\n FResources.Assign(Value);\r\n ConnectSchedules;\r\nend;\r\n\r\nprocedure TJvTFAlarm.SetTimerInterval(Value: Integer);\r\nbegin\r\n FTimer.Interval := Value;\r\nend;\r\n\r\nprocedure TJvTFAlarm.TimerCheck;\r\nbegin\r\n AlarmCheck;\r\nend;\r\n\r\n//=== { TJvTFAlarmInfo } =====================================================\r\n\r\nconstructor TJvTFAlarmInfo.Create(AAppt: TJvTFAppt);\r\nbegin\r\n inherited Create;\r\n FAppt := AAppt;\r\nend;\r\n\r\n//=== { TJvTFAlarmList } =====================================================\r\n\r\nprocedure TJvTFAlarmList.AddAppt(AAppt: TJvTFAppt);\r\nvar\r\n AlarmInfo: TJvTFAlarmInfo;\r\nbegin\r\n if Assigned(AAppt) and (IndexOfAppt(AAppt) = -1) then\r\n begin\r\n AlarmInfo := TJvTFAlarmInfo.Create(AAppt);\r\n AlarmInfo.SnoozeMins := Owner.DefaultSnoozeMins;\r\n AlarmInfo.NextAlarmTime := AAppt.StartTime - AAppt.AlarmAdvance * ONE_MINUTE;\r\n AddObject(AAppt.ID, AlarmInfo);\r\n end;\r\nend;\r\n\r\nprocedure TJvTFAlarmList.Clear;\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := 0 to Count - 1 do\r\n Objects[I].Free;\r\n inherited Clear;\r\nend;\r\n\r\nprocedure TJvTFAlarmList.DeleteAppt(AAppt: TJvTFAppt);\r\nvar\r\n I: Integer;\r\nbegin\r\n I := IndexOfAppt(AAppt);\r\n if I > -1 then\r\n begin\r\n Objects[I].Free;\r\n Delete(I);\r\n end;\r\nend;\r\n\r\nfunction TJvTFAlarmList.GetAlarmForAppt(AAppt: TJvTFAppt): TJvTFAlarmInfo;\r\nbegin\r\n Result := GetAlarmForApptID(AAppt.ID);\r\nend;\r\n\r\nfunction TJvTFAlarmList.GetAlarmForApptID(const ID: string): TJvTFAlarmInfo;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := nil;\r\n I := IndexOf(ID);\r\n if I > -1 then\r\n Result := TJvTFAlarmInfo(Objects[I]);\r\nend;\r\n\r\nfunction TJvTFAlarmList.IndexOfAppt(AAppt: TJvTFAppt): Integer;\r\nbegin\r\n Result := IndexOf(AAppt.ID);\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvTFDays.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvTFDays.PAS, released on 2003-08-01.\r\n\r\nThe Initial Developer of the Original Code is Unlimited Intelligence Limited.\r\nPortions created by Unlimited Intelligence Limited are Copyright (C) 1999-2002 Unlimited Intelligence Limited.\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\nMike Kolter (original code)\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n This version of the source contains modifications which enable the use\r\n of time blocks. These modifications can be found by doing a search for\r\n \"DEF Jv_TIMEBLOCKS\". Previously, two versions were released; one which did\r\n NOT support timeblocks and one which did support timeblocks. (Hence the\r\n use of the compiler defines.)\r\n\r\n These two versions are in the process of being integrated. The compiler\r\n defines remain as an indicator of exactly what has been changed. All\r\n lines that are NOT compiled ($IFNDEF Jv_TIMEBLOCKS and $ELSE) remain\r\n as a reference during the transition, but have been commented out to\r\n reduce confusion. Many of these lines are marked by a \"// remove\" comment.\r\n\r\n The conditional defines and disabled code will be removed and this file\r\n will be cleaned up after the time block code has been fully integrated\r\n and tested.\r\nChanges to JvTFDays by deanh:\r\n============================\r\n\r\nThese changes peform the following functions.\r\n\r\n1) The addition of a new time entry is aborted if the user presses escape.\r\n2) New property for FancyHeader to only show the '00' minutes. This emulates outlook's behaviour.\r\n3) Few changes to clean up the dithering of the background.\r\n4) Hide the blank area that sometimes appears at the bottom of the Calendar when scrolling right down to the bottom.\r\n5) Remove the focus rectangle when ShowFocus is false (the focus rect is not shown in Outlook).\r\n\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvTFDays.pas 13357 2012-06-17 00:06:53Z ahuser $\r\n\r\nunit JvTFDays;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n SysUtils, Classes,\r\n Windows, Messages, Graphics, Controls, Forms, Dialogs,\r\n StdCtrls, ImgList,\r\n JvTFManager, JvTFSparseMatrix, JvTFUtils;\r\n\r\nconst\r\n AbsMinColWidth = 5;\r\n SizingThreshold = 5;\r\n gcUndef = -3;\r\n gcGroupHdr = -2;\r\n gcHdr = -1;\r\n\r\ntype\r\n EJvTFDaysError = class(Exception);\r\n\r\n {$IFDEF Jv_TIMEBLOCKS}\r\n // remove TTFDayOfWeek and TTFDaysOfWeek, they are found in JvTFUtils\r\n //TTFDayOfWeek = (dowSunday, dowMonday, dowTuesday, dowWednesday,\r\n // dowThursday, dowFriday, dowSaturday);\r\n //TTFDaysOfWeek = set of TTFDayOfWeek;\r\n\r\n EJvTFBlockGranError = class(EJvTFDaysError);\r\n {$ENDIF Jv_TIMEBLOCKS}\r\n\r\n // Forward declarations\r\n TJvTFDays = class;\r\n TJvTFDaysCols = class;\r\n TJvTFDaysCol = class;\r\n TJvTFDaysPrinter = class;\r\n TJvTFDaysTemplate = class;\r\n TJvTFDaysHdrAttr = class;\r\n\r\n {$IFDEF Jv_TIMEBLOCKS}\r\n // okay to leave\r\n TJvTFDaysTimeBlocks = class;\r\n TJvTFDaysTimeBlock = class;\r\n {$ENDIF Jv_TIMEBLOCKS}\r\n\r\n TJvTFDaysCoord = record\r\n Col: Integer;\r\n Row: Integer;\r\n CellX: Integer;\r\n CellY: Integer;\r\n AbsX: Integer;\r\n AbsY: Integer;\r\n Schedule: TJvTFSched;\r\n Appt: TJvTFAppt;\r\n DragAccept: Boolean;\r\n end;\r\n\r\n TJvTFDrawPicInfo = class(TObject)\r\n public\r\n ImageList: TCustomImageList;\r\n ImageIndex: Integer;\r\n Glyph: TGraphic;\r\n PicLeft: Integer;\r\n PicTop: Integer;\r\n end;\r\n\r\n TJvTFDaysTemplates = (agtNone, agtLinear, agtComparative);\r\n\r\n TJvTFListMoveEvent = procedure(Sender: TObject; CurIndex, NewIndex: Integer) of object;\r\n\r\n TJvTFCompNamesList = class(TStringList)\r\n private\r\n FOnMove: TJvTFListMoveEvent;\r\n public\r\n procedure Move(CurIndex, NewIndex: Integer); override;\r\n property OnMove: TJvTFListMoveEvent read FOnMove write FOnMove;\r\n end;\r\n\r\n TJvTFDaysTemplate = class(TPersistent)\r\n private\r\n FActiveTemplate: TJvTFDaysTemplates;\r\n FCompDate: TDate;\r\n FCompNames: TJvTFCompNamesList;\r\n FLinearDayCount: Integer;\r\n FLinearEndDate: TDate;\r\n FLinearName: string;\r\n FLinearStartDate: TDate;\r\n FShortTitles: Boolean;\r\n FUpdatingGrid: Boolean;\r\n // Property Access Methods\r\n function GetCompNames: TStrings;\r\n procedure SetActiveTemplate(Value: TJvTFDaysTemplates);\r\n procedure SetCompDate(Value: TDate);\r\n procedure SetCompNames(Value: TStrings);\r\n procedure SetLinearDayCount(Value: Integer);\r\n procedure SetLinearEndDate(Value: TDate);\r\n procedure SetLinearName(const Value: string);\r\n procedure SetLinearStartDate(Value: TDate);\r\n procedure SetShortTitles(Value: Boolean);\r\n protected\r\n FCompNamesChanged: Boolean;\r\n FGrid: TJvTFDays;\r\n FUpdatingCompNames: Boolean;\r\n FIgnoreNav: Boolean;\r\n procedure DoDateChangedEvent;\r\n procedure DoDateChangingEvent(var NewDate: TDate);\r\n procedure CompNamesChanged(Sender: TObject); virtual;\r\n procedure CompNamesMoved(Sender: TObject; CurIndex, NewIndex: Integer); virtual;\r\n procedure LinearDaysChanged; virtual;\r\n procedure BeginGridUpdate;\r\n procedure EndGridUpdate;\r\n public\r\n constructor Create(AApptGrid: TJvTFDays);\r\n destructor Destroy; override;\r\n procedure Assign(Source: TPersistent); override;\r\n procedure BeginCompNamesUpdate;\r\n procedure EndCompNamesUpdate;\r\n procedure UpdateGrid;\r\n property UpdatingGrid: Boolean read FUpdatingGrid;\r\n property ApptGrid: TJvTFDays read FGrid;\r\n published\r\n property ActiveTemplate: TJvTFDaysTemplates read FActiveTemplate write SetActiveTemplate default agtNone;\r\n\r\n property CompDate: TDate read FCompDate write SetCompDate;\r\n property CompNames: TStrings read GetCompNames write SetCompNames;\r\n\r\n property IgnoreNav: Boolean read FIgnoreNav write FIgnoreNav default False;\r\n property LinearDayCount: Integer read FLinearDayCount write SetLinearDayCount;\r\n property LinearEndDate: TDate read FLinearEndDate write SetLinearEndDate;\r\n property LinearName: string read FLinearName write SetLinearName;\r\n property LinearStartDate: TDate read FLinearStartDate write SetLinearStartDate;\r\n\r\n property ShortTitles: Boolean read FShortTitles write SetShortTitles default True;\r\n end;\r\n\r\n TJvTFDaysPrimeTime = class(TPersistent)\r\n private\r\n FStartTime: TTime;\r\n FEndTime: TTime;\r\n FColor: TColor;\r\n procedure SetStartTime(Value: TTime);\r\n procedure SetEndTime(Value: TTime);\r\n procedure SetColor(Value: TColor);\r\n protected\r\n FApptGrid: TJvTFDays;\r\n FFillPic: TBitmap;\r\n procedure Change;\r\n procedure UpdateFillPic;\r\n public\r\n constructor Create(AApptGrid: TJvTFDays);\r\n destructor Destroy; override;\r\n procedure Assign(Source: TPersistent); override;\r\n published\r\n property StartTime: TTime read FStartTime write SetStartTime;\r\n property EndTime: TTime read FEndTime write SetEndTime;\r\n property Color: TColor read FColor write SetColor;\r\n end;\r\n\r\n TJvTFCreateQuickEntryEvent = procedure(Sender: TObject; var ApptID: string;\r\n var StartDate: TDate; var StartTime: TTime; var EndDate: TDate;\r\n var EndTime: TTime; var Confirm: Boolean) of object;\r\n\r\n TJvTFDropApptEvent = procedure(Appt: TJvTFAppt; SchedName: string;\r\n NewStartDate: TDate; NewStartTime: TTime; NewEndDate: TDate;\r\n NewEndTime: TTime; Share: Boolean; var Confirm: Boolean) of object;\r\n\r\n TJvTFDragRowColEvent = procedure(Sender: TObject; Index: Integer;\r\n var NewInfo: Integer; var Confirm: Boolean) of object;\r\n\r\n TJvTFSizeApptEvent = procedure(Sender: TObject; Appt: TJvTFAppt;\r\n var NewEndDT: TDateTime; var Confirm: Boolean) of object;\r\n\r\n TJvTFSelecTJvTFApptEvent = procedure(Sender: TObject; OldSel, NewSel: TJvTFAppt) of object;\r\n\r\n TJvTFDrawApptEvent = procedure(Sender: TObject; ACanvas: TCanvas; ARect: TRect;\r\n Appt: TJvTFAppt; Selected: Boolean) of object;\r\n\r\n TJvTFDrawGrabHandleEvent = procedure(Sender: TObject; ACanvas: TCanvas;\r\n ARect: TRect; Appt: TJvTFAppt; TopHandle: Boolean) of object;\r\n\r\n TJvTFDrawDataCellEvent = procedure(Sender: TObject; ACanvas: TCanvas; ARect: TRect;\r\n Col, Row: Integer) of object;\r\n\r\n TJvTFDaysCorner = (agcTopLeft, agcTopRight, agcBottomLeft, agcBottomRight);\r\n TJvTFDrawCornerEvent = procedure(Sender: TObject; ACanvas: TCanvas; ARect: TRect;\r\n Corner: TJvTFDaysCorner) of object;\r\n\r\n TJvTFDrawHdrEvent = procedure(Sender: TObject; ACanvas: TCanvas; ARect: TRect;\r\n Index: Integer; Selected: Boolean) of object;\r\n\r\n TJvTFDrawApptBarEvent = procedure(Sender: TObject; ACanvas: TCanvas;\r\n Appt: TJvTFAppt; Col: Integer; BarRect, TimeStampRect: TRect) of object;\r\n\r\n TJvTFFailEditorEvent = procedure(Sender: TObject; Col: Integer; Appt: TJvTFAppt;\r\n var EditorBounds: TRect; var Fail: Boolean) of object;\r\n\r\n TJvTFDateChangingEvent = procedure(Sender: TObject; var NewDate: TDate) of object;\r\n\r\n TJvTFGranChangingEvent = procedure(Sender: TObject; var NewGran: Integer) of object;\r\n\r\n TJvTFShadeCellEvent = procedure(Sender: TObject; ColIndex, RowIndex: Integer;\r\n var CellColor: TColor) of object;\r\n\r\n TJvTFBeginEditEvent = procedure(Sender: TObject; Appt: TJvTFAppt;\r\n var AllowEdit: Boolean) of object;\r\n\r\n TJvTFInPlaceApptEditor = class(TMemo)\r\n private\r\n FLinkedAppt: TJvTFAppt;\r\n FQuickCreate: Boolean;\r\n protected\r\n FCancelEdit: Boolean;\r\n procedure DoExit; override;\r\n procedure KeyDown(var Key: Word; Shift: TShiftState); override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n property LinkedAppt: TJvTFAppt read FLinkedAppt write FLinkedAppt;\r\n property QuickCreate: Boolean read FQuickCreate write FQuickCreate;\r\n end;\r\n\r\n TJvTFApptMap = class(TObject)\r\n private\r\n FData: TJvTFSparseMatrix;\r\n function GetLocation(Row, Col: Integer): TJvTFAppt;\r\n protected\r\n FGridCol: TJvTFDaysCol;\r\n procedure Add(Appt: TJvTFAppt);\r\n procedure ProcessMapGroup(GroupStart, GroupEnd: Integer);\r\n procedure UpdateMapGroups;\r\n public\r\n constructor Create(AGridCol: TJvTFDaysCol); virtual;\r\n destructor Destroy; override;\r\n procedure Clear;\r\n function ColCount(Row: Integer): Integer;\r\n procedure GetAppts(StartRow, EndRow: Integer; ApptList: TStringList);\r\n function LocateMapCol(Appt: TJvTFAppt; MapSearchRow: Integer): Integer;\r\n property Location[Row, Col: Integer]: TJvTFAppt read GetLocation;\r\n procedure Refresh;\r\n function HasAppt(Appt: TJvTFAppt): Boolean;\r\n procedure Dump(AName: TFileName); // used for debugging only\r\n end;\r\n\r\n TJvTFDaysOption = (agoSizeCols, agoSizeRows, agoSizeColHdr, agoSizeRowHdr,\r\n agoMoveCols, agoSizeAppt, agoMoveAppt, agoSnapMove,\r\n agoSnapSize, agoEditing, agoShowPics, agoShowText,\r\n agoShowApptHints, agoShowColHdrHints, agoShowSelHint,\r\n agoEnforceMaxColWidth, agoQuickEntry, agoFormattedDesc);\r\n TJvTFDaysOptions = set of TJvTFDaysOption;\r\n\r\n TJvTFDaysState = (agsNormal, agsSizeCol, agsSizeRow, agsSizeColHdr,\r\n agsSizeRowHdr, agsMoveCol, agsSizeAppt, agsMoveAppt);\r\n\r\n {$IFDEF Jv_TIMEBLOCKS}\r\n // ok\r\n TJvTFColTitleStyle = (ctsSingleClip, ctsSingleEllipsis, ctsMultiClip,\r\n ctsMultiEllipsis, ctsHide, ctsRotated);\r\n {$ELSE}\r\n // remove\r\n //TJvTFColTitleStyle = (ctsSingleClip, ctsSingleEllipsis, ctsMultiClip,\r\n // ctsMultiEllipsis, ctsHide);\r\n {$ENDIF Jv_TIMEBLOCKS}\r\n\r\n TJvTFDaysThresholds = class(TPersistent)\r\n private\r\n FDetailHeight: Integer;\r\n FDetailWidth: Integer;\r\n FEditHeight: Integer;\r\n FEditWidth: Integer;\r\n FTextHeight: Integer;\r\n FTextWidth: Integer;\r\n FDropTextFirst: Boolean;\r\n FPicsAllOrNone: Boolean;\r\n FWholePicsOnly: Boolean;\r\n procedure SetDetailHeight(Value: Integer);\r\n procedure SetDetailWidth(Value: Integer);\r\n procedure SetEditHeight(Value: Integer);\r\n procedure SetEditWidth(Value: Integer);\r\n procedure SetTextHeight(Value: Integer);\r\n procedure SetTextWidth(Value: Integer);\r\n procedure SetDropTextFirst(Value: Boolean);\r\n procedure SetPicsAllOrNone(Value: Boolean);\r\n procedure SetWholePicsOnly(Value: Boolean);\r\n protected\r\n FApptGrid: TJvTFDays;\r\n procedure Change; dynamic;\r\n public\r\n constructor Create(AOwner: TJvTFDays);\r\n procedure Assign(Source: TPersistent); override;\r\n published\r\n property DetailHeight: Integer read FDetailHeight write SetDetailHeight default 10;\r\n property DetailWidth: Integer read FDetailWidth write SetDetailWidth default 10;\r\n property EditHeight: Integer read FEditHeight write SetEditHeight default 1;\r\n property EditWidth: Integer read FEditWidth write SetEditWidth default 10;\r\n property TextHeight: Integer read FTextHeight write SetTextHeight default 1;\r\n property TextWidth: Integer read FTextWidth write SetTextWidth default 10;\r\n property DropTextFirst: Boolean read FDropTextFirst write SetDropTextFirst default True;\r\n property PicsAllOrNone: Boolean read FPicsAllOrNone write SetPicsAllOrNone default False;\r\n property WholePicsOnly: Boolean read FWholePicsOnly write SetWholePicsOnly default True;\r\n end;\r\n\r\n TJvTFDaysScrollBar = class(TScrollBar)\r\n protected\r\n procedure CMDesignHitTest(var Msg: TCMDesignHitTest); message CM_DESIGNHITTEST;\r\n procedure CreateWnd; override;\r\n function GetLargeChange: Integer; virtual;\r\n procedure SetLargeChange(Value: Integer); virtual;\r\n procedure UpdateRange; virtual;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n published\r\n property LargeChange: Integer read GetLargeChange write SetLargeChange default 1;\r\n end;\r\n\r\n //TJvTFUpdateTitleEvent = Procedure(Sender: TObject; Col: TJvTFDaysCol;\r\n //var NewTitle: string) of object;\r\n TJvTFUpdateTitlesEvent = procedure(Sender: TObject; Col: TJvTFDaysCol;\r\n var NewGroupTitle, NewTitle: string) of object;\r\n\r\n {$IFDEF Jv_TIMEBLOCKS}\r\n // ok\r\n TJvTFDaysTimeBlock = class(TCollectionItem)\r\n private\r\n FLength: Integer;\r\n FTitle: string;\r\n FName: string;\r\n FAllowAppts: Boolean;\r\n procedure SetLength(Value: Integer);\r\n procedure SetTitle(const Value: string);\r\n procedure SetName(const Value: string);\r\n procedure SetAllowAppts(Value: Boolean);\r\n function GetGridLength: Integer;\r\n function GetBlockCollection: TJvTFDaysTimeBlocks;\r\n protected\r\n function GetDisplayName: string; override;\r\n procedure Change;\r\n public\r\n constructor Create(Collection: TCollection); override;\r\n procedure Assign(Source: TPersistent); override;\r\n property BlockCollection: TJvTFDaysTimeBlocks read GetBlockCollection;\r\n published\r\n property AllowAppts: Boolean read FAllowAppts write SetAllowAppts default True;\r\n property GridLength: Integer read GetGridLength;\r\n property Length: Integer read FLength write SetLength default 1;\r\n property Name: string read FName write SetName;\r\n property Title: string read FTitle write SetTitle;\r\n end;\r\n\r\n // ok\r\n TJvTFDaysTimeBlocks = class(TCollection)\r\n private\r\n FDaysControl: TJvTFDays;\r\n function GetItem(Index: Integer): TJvTFDaysTimeBlock;\r\n procedure SetItem(Index: Integer; Value: TJvTFDaysTimeBlock);\r\n protected\r\n function GetOwner: TPersistent; override;\r\n public\r\n constructor Create(ADaysControl: TJvTFDays);\r\n function Add: TJvTFDaysTimeBlock;\r\n property DaysControl: TJvTFDays read FDaysControl;\r\n procedure Assign(Source: TPersistent); override;\r\n property Items[Index: Integer]: TJvTFDaysTimeBlock read GetItem\r\n write SetItem; default;\r\n function BlockByName(const BlockName: string): TJvTFDaysTimeBlock;\r\n function FindBlock(const BlockName: string): TJvTFDaysTimeBlock;\r\n end;\r\n\r\n // ok\r\n TJvTFDaysBlockProps = class(TPersistent)\r\n private\r\n FBlockGran: Integer;\r\n FDayStart: TTime;\r\n FDaysControl: TJvTFDays;\r\n FBlockHdrAttr: TJvTFDaysHdrAttr;\r\n FSelBlockHdrAttr: TJvTFDaysHdrAttr;\r\n FBlockHdrWidth: Integer;\r\n FOffTimeColor: TColor;\r\n FDataDivColor: TColor;\r\n FSnapMove: Boolean;\r\n FDrawOffTime: Boolean;\r\n procedure SetBlockGran(Value: Integer);\r\n procedure SetDayStart(Value: TTime);\r\n procedure SetBlockHdrAttr(Value: TJvTFDaysHdrAttr);\r\n procedure SetSelBlockHdrAttr(Value: TJvTFDaysHdrAttr);\r\n procedure SetBlockHdrWidth(Value: Integer);\r\n procedure SetOffTimeColor(Value: TColor);\r\n procedure SetDataDivColor(Value: TColor);\r\n procedure SetDrawOffTime(Value: Boolean);\r\n public\r\n constructor Create(ADaysControl: TJvTFDays);\r\n destructor Destroy; override;\r\n procedure Assign(Source: TPersistent); override;\r\n property DaysControl: TJvTFDays read FDaysControl;\r\n procedure Change;\r\n published\r\n property BlockGran: Integer read FBlockGran write SetBlockGran default 60;\r\n property BlockHdrAttr: TJvTFDaysHdrAttr read FBlockHdrAttr write SetBlockHdrAttr;\r\n property BlockHdrWidth: Integer read FBlockHdrWidth write SetBlockHdrWidth default 50;\r\n property DataDivColor: TColor read FDataDivColor write SetDataDivColor default clBlack;\r\n property DayStart: TTime read FDayStart write SetDayStart;\r\n property DrawOffTime: Boolean read FDrawOffTime write SetDrawOffTime default True;\r\n property OffTimeColor: TColor read FOffTimeColor write SetOffTimeColor default clGray;\r\n property SelBlockHdrAttr: TJvTFDaysHdrAttr read FSelBlockHdrAttr write SetSelBlockHdrAttr;\r\n property SnapMove: Boolean read FSnapMove write FSnapMove default True;\r\n end;\r\n\r\n {$ENDIF Jv_TIMEBLOCKS}\r\n\r\n TJvTFDaysCol = class(TCollectionItem)\r\n private\r\n FMap: TJvTFApptMap;\r\n FNullSchedDate: Boolean;\r\n FSchedDate: TDate;\r\n FSchedName: string;\r\n FSchedule: TJvTFSched;\r\n FGroupTitle: string;\r\n FTitle: string;\r\n FWidth: Integer;\r\n procedure SetSchedDate(Value: TDate);\r\n procedure SetSchedName(const Value: string);\r\n procedure SetGroupTitle(const Value: string);\r\n procedure SetTitle(const Value: string);\r\n procedure SetWidth(Value: Integer);\r\n protected\r\n FDisconnecting: Boolean;\r\n function GetDisplayName: string; override;\r\n procedure CheckTemplate;\r\n procedure SetIndex(Value: Integer); override;\r\n public\r\n constructor Create(Collection: TCollection); override;\r\n destructor Destroy; override;\r\n procedure Assign(Source: TPersistent); override;\r\n function ColCollection: TJvTFDaysCols;\r\n property Schedule: TJvTFSched read FSchedule;\r\n function Connected: Boolean;\r\n\r\n procedure Connect;\r\n procedure Disconnect;\r\n procedure SetSchedule(const NewSchedName: string; NewSchedDate: TDate);\r\n\r\n function LocateMapCol(Appt: TJvTFAppt; MapSearchRow: Integer): Integer;\r\n function MapColCount(Row: Integer): Integer;\r\n function MapLocation(Col, Row: Integer): TJvTFAppt;\r\n\r\n procedure RefreshMap;\r\n procedure CalcStartEndRows(Appt: TJvTFAppt; var StartRow, EndRow: Integer);\r\n //procedure UpdateTitle;\r\n procedure UpdateTitles;\r\n\r\n function GetFirstAppt: TJvTFAppt;\r\n function GetPrevAppt(RefAppt: TJvTFAppt): TJvTFAppt;\r\n function GetNextAppt(RefAppt: TJvTFAppt): TJvTFAppt;\r\n function GetLastAppt: TJvTFAppt;\r\n procedure DumpMap;\r\n function ApptInCol(Appt: TJvTFAppt): Boolean;\r\n published\r\n property SchedDate: TDate read FSchedDate write SetSchedDate;\r\n property SchedName: string read FSchedName write SetSchedName;\r\n property GroupTitle: string read FGroupTitle write SetGroupTitle;\r\n property Title: string read FTitle write SetTitle;\r\n property Width: Integer read FWidth write SetWidth;\r\n end;\r\n\r\n TJvTFDaysCols = class(TCollection)\r\n private\r\n FApptGrid: TJvTFDays;\r\n FPrinter: TJvTFDaysPrinter;\r\n FOldCount: Integer;\r\n function GetItem(Index: Integer): TJvTFDaysCol;\r\n procedure SetItem(Index: Integer; Value: TJvTFDaysCol);\r\n protected\r\n FAddingCol: Boolean;\r\n FSizingCols: Boolean;\r\n FUpdating: Boolean;\r\n procedure EnsureCol(Index: Integer);\r\n function GetOwner: TPersistent; override;\r\n procedure SizeCols; virtual;\r\n procedure Update(Item: TCollectionItem); override;\r\n public\r\n constructor Create(AApptGrid: TJvTFDays);\r\n constructor CreateForPrinter(APrinter: TJvTFDaysPrinter);\r\n property ApptGrid: TJvTFDays read FApptGrid;\r\n property Printer: TJvTFDaysPrinter read FPrinter;\r\n\r\n function Add: TJvTFDaysCol;\r\n property AddingCol: Boolean read FAddingCol;\r\n property Updating: Boolean read FUpdating;\r\n\r\n procedure EnsureMinColWidth;\r\n procedure EnsureMaxColWidth;\r\n procedure ResizeCols;\r\n property SizingCols: Boolean read FSizingCols;\r\n procedure MoveCol(SourceIndex, TargetIndex: Integer);\r\n\r\n procedure Assign(Source: TPersistent); override;\r\n property Items[Index: Integer]: TJvTFDaysCol read GetItem write SetItem; default;\r\n procedure UpdateTitles;\r\n end;\r\n\r\n TJvTFRowHdrType = (rhGrid, rhFancy);\r\n\r\n TJvTFDaysFancyRowHdrAttr = class(TPersistent)\r\n private\r\n FColor: TColor;\r\n FHr2400: Boolean;\r\n FMinorFont: TFont;\r\n FMajorFont: TFont;\r\n FTickColor: TColor;\r\n FOnlyShow00Minutes: Boolean;\r\n procedure SetColor(Value: TColor);\r\n procedure SetHr2400(Value: Boolean);\r\n procedure SetMinorFont(Value: TFont);\r\n procedure SetMajorFont(Value: TFont);\r\n procedure SetTickColor(Value: TColor);\r\n procedure SetOnlyShow00Minutes(Value: Boolean);\r\n protected\r\n FGrid: TJvTFDays;\r\n procedure Change; virtual;\r\n procedure FontChange(Sender: TObject); virtual;\r\n public\r\n constructor Create(AOwner: TJvTFDays);\r\n destructor Destroy; override;\r\n procedure Assign(Source: TPersistent); override;\r\n published\r\n property Color: TColor read FColor write SetColor default clBtnFace;\r\n property Hr2400: Boolean read FHr2400 write SetHr2400;\r\n property MinorFont: TFont read FMinorFont write SetMinorFont;\r\n property MajorFont: TFont read FMajorFont write SetMajorFont;\r\n property TickColor: TColor read FTickColor write SetTickColor default clGray;\r\n property OnlyShow00Minutes: Boolean read FOnlyShow00Minutes write SetOnlyShow00Minutes\r\n default True;\r\n end;\r\n\r\n TJvTFDaysHdrAttr = class(TPersistent)\r\n private\r\n FApptGrid: TJvTFDays;\r\n FColor: TColor;\r\n FFont: TFont;\r\n FParentFont: Boolean;\r\n FFrame3D: Boolean;\r\n {$IFDEF Jv_TIMEBLOCKS}\r\n // ok\r\n FFrameColor: TColor;\r\n FTitleRotation: Integer;\r\n {$ENDIF Jv_TIMEBLOCKS}\r\n procedure SetColor(Value: TColor);\r\n procedure SetFont(Value: TFont);\r\n procedure SetParentFont(Value: Boolean);\r\n procedure SetFrame3D(Value: Boolean);\r\n {$IFDEF Jv_TIMEBLOCKS}\r\n // ok\r\n procedure SetFrameColor(Value: TColor);\r\n procedure SetTitleRotation(Value: Integer);\r\n {$ENDIF Jv_TIMEBLOCKS}\r\n protected\r\n procedure Change;\r\n procedure FontChange(Sender: TObject);\r\n public\r\n constructor Create(AOwner: TJvTFDays);\r\n destructor Destroy; override;\r\n procedure Assign(Source: TPersistent); override;\r\n procedure ParentFontChanged;\r\n published\r\n property Color: TColor read FColor write SetColor default clBtnFace;\r\n property Font: TFont read FFont write SetFont;\r\n property ParentFont: Boolean read FParentFont write SetParentFont default True;\r\n property Frame3D: Boolean read FFrame3D write SetFrame3D default True;\r\n {$IFDEF Jv_TIMEBLOCKS}\r\n // ok\r\n property FrameColor: TColor read FFrameColor write SetFrameColor nodefault;\r\n property TitleRotation: Integer read FTitleRotation write SetTitleRotation default 0;\r\n {$ENDIF Jv_TIMEBLOCKS}\r\n end;\r\n\r\n TJvTFTimeStampStyle = (tssNone, tssFullI, tssHalfI, tssBlock);\r\n\r\n TJvTFDaysApptBar = class(TPersistent)\r\n private\r\n FColor: TColor;\r\n FVisible: Boolean;\r\n FWidth: Integer;\r\n FTimeStampStyle: TJvTFTimeStampStyle;\r\n FTimeStampColor: TColor;\r\n procedure SetColor(Value: TColor);\r\n procedure SetVisible(Value: Boolean);\r\n procedure SetWidth(Value: Integer);\r\n procedure SetTFTimeStampStyle(Value: TJvTFTimeStampStyle);\r\n procedure SetTimeStampColor(Value: TColor);\r\n protected\r\n FApptGrid: TJvTFDays;\r\n procedure Change; virtual;\r\n public\r\n constructor Create(AApptGrid: TJvTFDays);\r\n procedure Assign(Source: TPersistent); override;\r\n published\r\n property Color: TColor read FColor write SetColor default clBlue;\r\n property Width: Integer read FWidth write SetWidth default 5;\r\n property Visible: Boolean read FVisible write SetVisible default True;\r\n property TimeStampStyle: TJvTFTimeStampStyle read FTimeStampStyle\r\n write SetTFTimeStampStyle default tssBlock;\r\n property TimeStampColor: TColor read FTimeStampColor\r\n write SetTimeStampColor default clBlue;\r\n end;\r\n\r\n TJvTFDaysApptAttr = class(TPersistent)\r\n private\r\n FColor: TColor;\r\n FFont: TFont;\r\n FParentFont: Boolean;\r\n FFrameColor: TColor;\r\n FFrameWidth: Integer;\r\n procedure SetColor(Value: TColor);\r\n procedure SetFont(Value: TFont);\r\n procedure SetParentFont(Value: Boolean);\r\n procedure SetFrameColor(Value: TColor);\r\n procedure SetFrameWidth(Value: Integer);\r\n protected\r\n FApptGrid: TJvTFDays;\r\n procedure Change; virtual;\r\n procedure FontChange(Sender: TObject); virtual;\r\n public\r\n constructor Create(AApptGrid: TJvTFDays);\r\n destructor Destroy; override;\r\n procedure Assign(Source: TPersistent); override;\r\n procedure ParentFontChanged; virtual;\r\n published\r\n property Color: TColor read FColor write SetColor;\r\n property Font: TFont read FFont write SetFont;\r\n property ParentFont: Boolean read FParentFont write SetParentFont default True;\r\n property FrameColor: TColor read FFrameColor write SetFrameColor default clBlack;\r\n property FrameWidth: Integer read FFrameWidth write SetFrameWidth default 1;\r\n end;\r\n\r\n TJvTFSelCellStyle = (scsSolid, scsFrame, scsCombo);\r\n\r\n TJvTFSelCellAttr = class(TPersistent)\r\n private\r\n FColor: TColor;\r\n FFrameWidth: Integer;\r\n FStyle: TJvTFSelCellStyle;\r\n procedure SetColor(Value: TColor);\r\n procedure SetFrameWidth(Value: Integer);\r\n procedure SetStyle(Value: TJvTFSelCellStyle);\r\n protected\r\n FApptGrid: TJvTFDays;\r\n procedure Change; virtual;\r\n public\r\n constructor Create(AApptGrid: TJvTFDays);\r\n procedure Assign(Source: TPersistent); override;\r\n published\r\n property Color: TColor read FColor write SetColor default clNavy;\r\n property FrameWidth: Integer read FFrameWidth write SetFrameWidth default 2;\r\n property Style: TJvTFSelCellStyle read FStyle write SetStyle default scsSolid;\r\n end;\r\n\r\n TJvTFGrabStyle = (gs3D, gsFlat);\r\n\r\n TJvTFDaysGrabHandles = class(TPersistent)\r\n private\r\n FColor: TColor;\r\n FHeight: Integer;\r\n FStyle: TJvTFGrabStyle;\r\n procedure SetColor(Value: TColor);\r\n procedure SetHeight(Value: Integer);\r\n procedure SetStyle(Value: TJvTFGrabStyle);\r\n protected\r\n FApptGrid: TJvTFDays;\r\n procedure Change; virtual;\r\n property Style: TJvTFGrabStyle read FStyle write SetStyle default gsFlat;\r\n public\r\n constructor Create(AApptGrid: TJvTFDays);\r\n procedure Assign(Source: TPersistent); override;\r\n published\r\n property Height: Integer read FHeight write SetHeight default 6;\r\n property Color: TColor read FColor write SetColor default clBlue;\r\n end;\r\n\r\n {$M+}\r\n TJvTFDaysApptDrawInfo = class(TObject)\r\n private\r\n FColor: TColor;\r\n FFrameColor: TColor;\r\n FFrameWidth: Integer;\r\n FFont: TFont;\r\n FVisible: Boolean;\r\n procedure SetColor(Value: TColor);\r\n procedure SetFrameColor(Value: TColor);\r\n procedure SetFont(Value: TFont);\r\n procedure SetFrameWidth(const Value: Integer);\r\n procedure SetVisible(Value: Boolean);\r\n public\r\n constructor Create;\r\n destructor Destroy; override;\r\n published\r\n property Color: TColor read FColor write SetColor;\r\n property FrameColor: TColor read FFrameColor write SetFrameColor;\r\n property FrameWidth: Integer read FFrameWidth write SetFrameWidth;\r\n property Font: TFont read FFont write SetFont;\r\n property Visible: Boolean read FVisible write SetVisible;\r\n end;\r\n {$M-}\r\n\r\n TJvTFGetDaysApptDrawInfoEvent = procedure(Sender: TObject; Appt: TJvTFAppt;\r\n DrawInfo: TJvTFDaysApptDrawInfo) of object;\r\n\r\n TDynPointArray = array of TPoint;\r\n TDynIntArray = array of Integer;\r\n\r\n TJvTFDaysGrouping = (grNone, grDate, grResource, grCustom);\r\n\r\n TJvTFAutoScrollDir = (asdUp, asdDown, asdLeft, asdRight, asdNowhere);\r\n\r\n TJvTFDays = class(TJvTFControl)\r\n private\r\n // internal stuff\r\n FBorderStyle: TBorderStyle;\r\n FHitTest: TPoint;\r\n FVisibleScrollBars: TJvTFVisibleScrollBars;\r\n FDitheredBackground: Boolean;\r\n\r\n // row, col layout\r\n FGranularity: Integer;\r\n FColHdrHeight: Integer;\r\n FRowHdrWidth: Integer;\r\n FRowHeight: Integer;\r\n FMinRowHeight: Integer;\r\n FDefColWidth: Integer;\r\n FMinColWidth: Integer;\r\n FAutoSizeCols: Boolean;\r\n FColTitleStyle: TJvTFColTitleStyle;\r\n FGroupHdrHeight: Integer;\r\n\r\n FCols: TJvTFDaysCols;\r\n FTemplate: TJvTFDaysTemplate;\r\n\r\n FTopRow: Integer;\r\n FFocusedRow: Integer;\r\n FLeftCol: Integer;\r\n FFocusedCol: Integer;\r\n FGrouping: TJvTFDaysGrouping;\r\n\r\n FGridStartTime: TTime;\r\n FGridEndTime: TTime;\r\n\r\n {$IFDEF Jv_TIMEBLOCKS}\r\n // ok\r\n FTimeBlockProps: TJvTFDaysBlockProps;\r\n FTimeBlocks: TJvTFDaysTimeBlocks;\r\n {$ENDIF Jv_TIMEBLOCKS}\r\n\r\n // visual appearance attr's\r\n FHdrAttr: TJvTFDaysHdrAttr;\r\n FSelHdrAttr: TJvTFDaysHdrAttr;\r\n FApptAttr: TJvTFDaysApptAttr;\r\n FSelApptAttr: TJvTFDaysApptAttr;\r\n FFancyRowHdrAttr: TJvTFDaysFancyRowHdrAttr;\r\n FSelFancyRowHdrAttr: TJvTFDaysFancyRowHdrAttr;\r\n FRowHdrType: TJvTFRowHdrType;\r\n FSelCellAttr: TJvTFSelCellAttr;\r\n FApptBar: TJvTFDaysApptBar;\r\n FApptBuffer: Integer;\r\n FGridLineColor: TColor;\r\n FGrabHandles: TJvTFDaysGrabHandles;\r\n FThresholds: TJvTFDaysThresholds;\r\n FPrimeTime: TJvTFDaysPrimeTime;\r\n FGroupHdrAttr: TJvTFDaysHdrAttr;\r\n FSelGroupHdrAttr: TJvTFDaysHdrAttr;\r\n\r\n FOptions: TJvTFDaysOptions;\r\n FEditor: TJvTFInPlaceApptEditor;\r\n FHintProps: TJvTFHintProps;\r\n\r\n {$IFDEF Jv_TIMEBLOCKS}\r\n // ok\r\n FWeekend: TTFDaysOfWeek;\r\n FWeekendColor: TColor;\r\n {$ENDIF Jv_TIMEBLOCKS}\r\n\r\n // Row/Col Sizing/Moving Events\r\n FOnSizeCol: TJvTFDragRowColEvent;\r\n FOnSizeRow: TJvTFDragRowColEvent;\r\n FOnSizeColHdr: TJvTFDragRowColEvent;\r\n FOnSizeRowHdr: TJvTFDragRowColEvent;\r\n FOnMoveCol: TJvTFDragRowColEvent;\r\n\r\n // Appt mouse events\r\n FOnSelectingAppt: TJvTFVarApptEvent;\r\n FOnSelectAppt: TJvTFSelecTJvTFApptEvent;\r\n FOnSelectedAppt: TNotifyEvent;\r\n FOnSizeAppt: TJvTFSizeApptEvent;\r\n FOnDropAppt: TJvTFDropApptEvent;\r\n\r\n // Drawing events\r\n FOnDrawAppt: TJvTFDrawApptEvent;\r\n FOnDrawApptBar: TJvTFDrawApptBarEvent;\r\n FOnDrawCorner: TJvTFDrawCornerEvent;\r\n FOnDrawColHdr: TJvTFDrawHdrEvent;\r\n FOnDrawDataCell: TJvTFDrawDataCellEvent;\r\n FOnDrawGrabHandle: TJvTFDrawGrabHandleEvent;\r\n FOnDrawMajorRowHdr: TJvTFDrawHdrEvent;\r\n FOnDrawMinorRowHdr: TJvTFDrawHdrEvent;\r\n FOnDrawRowHdr: TJvTFDrawHdrEvent;\r\n //FOnUpdateColTitle: TJvTFUpdateTitleEvent;\r\n FOnUpdateColTitles: TJvTFUpdateTitlesEvent;\r\n FOnDrawGroupHdr: TJvTFDrawHdrEvent;\r\n FOnShadeCell: TJvTFShadeCellEvent;\r\n FOnGetApptDrawInfo: TJvTFGetDaysApptDrawInfoEvent;\r\n\r\n // editor events\r\n FOnFailEditor: TJvTFFailEditorEvent;\r\n FOnCreateQuickEntry: TJvTFCreateQuickEntryEvent;\r\n FOnQuickEntry: TNotifyEvent;\r\n FOnBeginEdit: TJvTFBeginEditEvent;\r\n\r\n // navigation events\r\n FOnInsertAppt: TNotifyEvent;\r\n FOnInsertSchedule: TNotifyEvent;\r\n FOnDeleteAppt: TNotifyEvent;\r\n FOnDeleteSchedule: TNotifyEvent;\r\n FOnDateChanging: TJvTFDateChangingEvent;\r\n FOnDateChanged: TNotifyEvent;\r\n FOnGranularityChanging: TJvTFGranChangingEvent;\r\n FOnGranularityChanged: TNotifyEvent;\r\n FOnFocusedRowChanged: TNotifyEvent;\r\n FOnFocusedColChanged: TNotifyEvent;\r\n FShowFocus: Boolean;\r\n\r\n // internal stuff\r\n procedure CMCtl3DChanged(var Msg: TMessage); message CM_CTL3DCHANGED;\r\n procedure WMGetDlgCode(var Msg: TWMGetDlgCode); message WM_GETDLGCODE;\r\n procedure SetBorderStyle(Value: TBorderStyle);\r\n procedure SetTFVisibleScrollBars(Value: TJvTFVisibleScrollBars);\r\n procedure AlignScrollBars;\r\n function CheckSBVis: Boolean;\r\n procedure SetOnShowHint(Value: TJvTFShowHintEvent);\r\n function GetOnShowHint: TJvTFShowHintEvent;\r\n {$IFDEF Jv_TIMEBLOCKS}\r\n // ok\r\n procedure UpdateWeekendFillPic;\r\n {$ENDIF Jv_TIMEBLOCKS}\r\n\r\n // row, col layout\r\n procedure SetGranularity(Value: Integer);\r\n procedure SetColHdrHeight(Value: Integer);\r\n procedure SetRowHdrWidth(Value: Integer);\r\n procedure SetRowHeight(Value: Integer);\r\n procedure SetMinRowHeight(Value: Integer);\r\n procedure SetMinColWidth(Value: Integer);\r\n procedure SetAutoSizeCols(Value: Boolean);\r\n procedure SetTFColTitleStyle(Value: TJvTFColTitleStyle);\r\n\r\n procedure SetCols(Value: TJvTFDaysCols);\r\n\r\n procedure SetTopRow(Value: Integer);\r\n procedure SetFocusedRow(Value: Integer);\r\n function GetFocusedRow: Integer;\r\n procedure SetLeftCol(Value: Integer);\r\n procedure SetFocusedCol(Value: Integer);\r\n function GetFocusedCol: Integer;\r\n procedure SetGrouping(Value: TJvTFDaysGrouping);\r\n procedure SetGroupHdrHeight(Value: Integer);\r\n\r\n procedure SetGridStartTime(Value: TTime);\r\n procedure SetGridEndTime(Value: TTime);\r\n\r\n {$IFDEF Jv_TIMEBLOCKS}\r\n // ok\r\n procedure SetTimeBlockProps(Value: TJvTFDaysBlockProps);\r\n // ok\r\n procedure SetTimeBlocks(Value: TJvTFDaysTimeBlocks);\r\n {$ENDIF Jv_TIMEBLOCKS}\r\n\r\n // visual appearance attr's\r\n procedure SetHdrAttr(Value: TJvTFDaysHdrAttr);\r\n procedure SetSelHdrAttr(Value: TJvTFDaysHdrAttr);\r\n procedure SetApptAttr(Value: TJvTFDaysApptAttr);\r\n procedure SetSelApptAttr(Value: TJvTFDaysApptAttr);\r\n procedure SetFancyRowHdrAttr(Value: TJvTFDaysFancyRowHdrAttr);\r\n procedure SetSelFancyRowHdrAttr(Value: TJvTFDaysFancyRowHdrAttr);\r\n procedure SetTFRowHdrType(Value: TJvTFRowHdrType);\r\n procedure SetTFSelCellAttr(Value: TJvTFSelCellAttr);\r\n procedure SetApptBar(Value: TJvTFDaysApptBar);\r\n procedure SetApptBuffer(Value: Integer);\r\n procedure SetGridLineColor(Value: TColor);\r\n procedure SetGrabHandles(Value: TJvTFDaysGrabHandles);\r\n procedure SetGroupHdrAttr(Value: TJvTFDaysHdrAttr);\r\n procedure SetSelGroupHdrAttr(Value: TJvTFDaysHdrAttr);\r\n\r\n procedure SetOptions(Value: TJvTFDaysOptions);\r\n procedure SetTFHintProps(Value: TJvTFHintProps);\r\n procedure DrawDither(ACanvas: TCanvas; ARect: TRect; Color1, Color2: TColor);\r\n\r\n {$IFDEF Jv_TIMEBLOCKS}\r\n // ok\r\n procedure SetWeekend(Value: TTFDaysOfWeek);\r\n // ok\r\n procedure SetWeekendColor(Value: TColor);\r\n procedure SetDitheredBackground(const Value: Boolean);\r\n procedure SetShowFocus(const Value: Boolean);\r\n {$ENDIF Jv_TIMEBLOCKS}\r\n protected\r\n FState: TJvTFDaysState;\r\n FHint: TJvTFHint;\r\n FNeedCheckSBParams: Boolean;\r\n PaintBuffer: TBitmap;\r\n {$IFDEF Jv_TIMEBLOCKS}\r\n // ok\r\n FWeekendFillPic: TBitmap;\r\n {$ENDIF Jv_TIMEBLOCKS}\r\n\r\n FBeginDraggingCoord: TJvTFDaysCoord;\r\n FDraggingCoord: TJvTFDaysCoord;\r\n\r\n FSelAppt: TJvTFAppt;\r\n FSelStart: TPoint;\r\n FSelEnd: TPoint;\r\n FFromToSel: Boolean;\r\n FSaveFocCol: Integer;\r\n\r\n FHScrollBar: TJvTFDaysScrollBar;\r\n FVScrollBar: TJvTFDaysScrollBar;\r\n\r\n FAutoScrollDir: TJvTFAutoScrollDir;\r\n FLiveTimer: Boolean;\r\n\r\n FMouseMovePt: TPoint;\r\n FMouseMoveState: TShiftState;\r\n\r\n procedure SetDateFormat(const Value: string); override;\r\n procedure ReqSchedNotification(Schedule: TJvTFSched); override;\r\n procedure RelSchedNotification(Schedule: TJvTFSched); override;\r\n procedure CreateParams(var Params: TCreateParams); override;\r\n\r\n function GetFocusedSchedule: TJvTFSched;\r\n procedure SetSelAppt(Value: TJvTFAppt);\r\n //procedure SetGroupTitles; dynamic;\r\n //procedure ReorderCols;\r\n\r\n // All painting routines\r\n procedure Paint; override;\r\n procedure DrawDataCell(ACanvas: TCanvas; ColIndex, RowIndex: Integer);\r\n procedure DrawEmptyColHdr(ACanvas: TCanvas);\r\n procedure DrawAppt(ACanvas: TCanvas; Col: Integer; Appt: TJvTFAppt;\r\n StartRow, EndRow: Integer);\r\n procedure DrawApptDetail(ACanvas: TCanvas; ARect: TRect; Appt: TJvTFAppt;\r\n Selected: Boolean; Col, StartRow, EndRow: Integer);\r\n procedure DrawApptBar(ACanvas: TCanvas; Appt: TJvTFAppt; BarRect: TRect;\r\n Col, StartRow, EndRow: Integer);\r\n function CalcTimeStampRect(Appt: TJvTFAppt; BarRect: TRect;\r\n Col, StartRow, EndRow: Integer): TRect;\r\n procedure DrawTimeStamp(ACanvas: TCanvas; TimeStampRect: TRect);\r\n procedure DrawPics(ACanvas: TCanvas; var ARect: TRect; Appt: TJvTFAppt);\r\n procedure CreatePicDrawList(ARect: TRect; Appt: TJvTFAppt; DrawList: TList);\r\n procedure FilterPicDrawList(ARect: TRect; DrawList: TList;\r\n var PicsHeight: Integer; var PicsWidth: Integer);\r\n procedure ClearPicDrawList(DrawList: TList);\r\n procedure DrawListPics(ACanvas: TCanvas; var ARect: TRect; DrawList: TList);\r\n procedure DrawGrabLines(ACanvas: TCanvas; LineTop, LineLeft,\r\n LineRight: Integer);\r\n procedure DrawGrabHandle(ACanvas: TCanvas; ARect: TRect;\r\n AAppt: TJvTFAppt; TopHandle: Boolean);\r\n procedure DrawCorner(ACanvas: TCanvas; Corner: TJvTFDaysCorner);\r\n procedure DrawRowHdr(ACanvas: TCanvas; Index: Integer);\r\n //procedure DrawColHdr(ACanvas: TCanvas; Index: Integer);\r\n function GetTallestColTitle(ACanvas: TCanvas): Integer;\r\n\r\n procedure GetApptDrawInfo(DrawInfo: TJvTFDaysApptDrawInfo;\r\n AAppt: TJvTFAppt; Attr: TJvTFDaysApptAttr);\r\n\r\n {$IFDEF Jv_TIMEBLOCKS}\r\n // ok to REPLACE old DrawFrame\r\n procedure DrawFrame(ACanvas: TCanvas; ARect: TRect; Draw3D: Boolean;\r\n FrameColour: TColor);\r\n {$ELSE}\r\n // obsolete\r\n //procedure DrawFrame(ACanvas: TCanvas; ARect: TRect; Draw3D: Boolean);\r\n {$ENDIF Jv_TIMEBLOCKS}\r\n\r\n procedure DrawAppts(ACanvas: TCanvas; DrawAll: Boolean);\r\n procedure AdjustForMargins(var ARect: TRect);\r\n procedure CanDrawWhat(ACanvas: TCanvas; ApptRect: TRect; PicsHeight: Integer;\r\n var CanDrawText, CanDrawPics: Boolean);\r\n procedure ManualFocusRect(ACanvas: TCanvas; ARect: TRect);\r\n // Fancy painting routines\r\n procedure DrawFancyRowHdrs(ACanvas: TCanvas);\r\n procedure DrawMinor(ACanvas: TCanvas; ARect: TRect; RowNum: Integer;\r\n const LabelStr: string; TickLength: Integer; Selected: Boolean);\r\n function GetMinorLabel(RowNum: Integer): string;\r\n function GetMinorTickLength: Integer; virtual;\r\n function GetMajorTickLength: Integer; virtual;\r\n procedure DrawGroupHdrs(ACanvas: TCanvas);\r\n //procedure DrawGroupHdr(ACanvas: TCanvas; ACol: Integer);\r\n procedure DrawColGroupHdr(ACanvas: TCanvas; Index: Integer;\r\n IsGroupHdr: Boolean);\r\n\r\n {$IFDEF Jv_TIMEBLOCKS}\r\n // ok\r\n procedure DrawBlockHdr(ACanvas: TCanvas; BlockIndex: Integer);\r\n // ok\r\n procedure FillBlockHdrDeadSpace(ACanvas: TCanvas);\r\n // REMOVE, replaced by CalcTextPos in JvTFUtils\r\n //procedure CalcTextPos(var ARect: TRect; aAngle: Integer; aTxt: string);\r\n // REMOVE, replaced by DrawAngleText in JvTFUtils\r\n //procedure DrawAngleText(ACanvas: TCanvas; ARect: TRect; aAngle: Integer;\r\n //aTxt: string);\r\n {$ENDIF Jv_TIMEBLOCKS}\r\n\r\n // message handlers\r\n procedure Resize; override;\r\n\r\n procedure WMEraseBkgnd(var Msg: TMessage); message WM_ERASEBKGND;\r\n procedure WMSetCursor(var Msg: TWMSetCursor); message WM_SETCURSOR;\r\n procedure WMNCHitTest(var Msg: TWMNCHitTest); message WM_NCHITTEST;\r\n procedure CMDesignHitTest(var Msg: TCMDesignHitTest); message CM_DESIGNHITTEST;\r\n procedure CNRequestRefresh(var Msg: TCNRequestRefresh); message CN_REQUESTREFRESH;\r\n procedure WMTimer(var Msg: TWMTimer); message WM_TIMER;\r\n\r\n procedure CMFontChanged(var Msg: TMessage); message CM_FONTCHANGED;\r\n procedure CMEnabledChanged(var Msg: TMessage); message CM_ENABLEDCHANGED;\r\n procedure CMMouseLeave(var Msg: TMessage); message CM_MOUSELEAVE;\r\n\r\n // internal routines\r\n procedure Loaded; override;\r\n procedure RefreshControl; override;\r\n procedure UpdateDesigner;\r\n\r\n // scroll bar stuff\r\n procedure CheckSBParams;\r\n procedure ScrollBarScroll(Sender: TObject; ScrollCode: TScrollCode;\r\n var ScrollPos: Integer);\r\n property VisibleScrollBars: TJvTFVisibleScrollBars read FVisibleScrollBars\r\n write SetTFVisibleScrollBars;\r\n\r\n // mouse routines\r\n procedure MouseDown(Button: TMouseButton; Shift: TShiftState;\r\n X, Y: Integer); override;\r\n procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;\r\n procedure MouseUp(Button: TMouseButton; Shift: TShiftState;\r\n X, Y: Integer); override;\r\n procedure DblClick; override;\r\n procedure DoApptHint(GridCoord: TJvTFDaysCoord);\r\n procedure DoCellHint(GridCoord: TJvTFDaysCoord);\r\n\r\n // Drag/Drop routines\r\n procedure DoStartDrag(var DragObject: TDragObject); override;\r\n procedure DragOver(Source: TObject; X, Y: Integer; State: TDragState;\r\n var Accept: Boolean); override;\r\n procedure DoEndDrag(Target: TObject; X, Y: Integer); override;\r\n procedure DropAppt(DragInfo: TJvTFDragInfo; X, Y: Integer);\r\n\r\n procedure BeginDragging(Coord: TJvTFDaysCoord; DragWhat: TJvTFDaysState;\r\n Appt: TJvTFAppt);\r\n procedure DrawDrag(Coord: TJvTFDaysCoord; AAppt: TJvTFAppt; Clear: Boolean);\r\n procedure ContinueDragging(Coord: TJvTFDaysCoord; Appt: TJvTFAppt);\r\n procedure EndDragging(Coord: TJvTFDaysCoord; Appt: TJvTFAppt);\r\n function CanDragWhat(Coord: TJvTFDaysCoord): TJvTFDaysState;\r\n procedure CalcSizeEndTime(Appt: TJvTFAppt; var NewEndDT: TDateTime);\r\n procedure CalcMoveStartEnd(Appt: TJvTFAppt; Coord: TJvTFDaysCoord;\r\n KeepDates, KeepTimes: Boolean; var StartDT, EndDT: TDateTime);\r\n\r\n procedure KillAutoScrollTimer;\r\n\r\n procedure EnsureCol(ACol: Integer);\r\n procedure EnsureRow(ARow: Integer);\r\n\r\n // navigation\r\n procedure KeyDown(var Key: Word; Shift: TShiftState); override;\r\n procedure KeyPress(var Key: Char); override;\r\n procedure DoInsertSchedule; dynamic;\r\n procedure DoInsertAppt; dynamic;\r\n procedure DoDeleteAppt; dynamic;\r\n procedure DoDeleteSchedule; dynamic;\r\n// procedure DoNavigate; virtual;\r\n\r\n function DoMouseWheelDown(Shift: TShiftState; MousePos: TPoint): Boolean; override;\r\n function DoMouseWheelUp(Shift: TShiftState; MousePos: TPoint): Boolean; override;\r\n procedure DestroyApptNotification(AAppt: TJvTFAppt); override;\r\n procedure Navigate(AControl: TJvTFControl; SchedNames: TStringList;\r\n Dates: TJvTFDateList); override;\r\n\r\n procedure DoEnter; override;\r\n procedure DoExit; override;\r\n\r\n // Selection methods\r\n function GetSelStart: TPoint;\r\n function GetSelEnd: TPoint;\r\n procedure SetSelStart(Value: TPoint);\r\n procedure SetSelEnd(Value: TPoint);\r\n procedure QuickEntry(Key: Char); virtual;\r\n\r\n {$IFDEF Jv_TIMEBLOCKS}\r\n // ok\r\n procedure EnsureBlockRules(GridGran, BlockGran: Integer; DayStart: TTime);\r\n // ok\r\n function ValidateBlockRules(GridGran, BlockGran: Integer;\r\n DayStart: TTime): Boolean;\r\n {$ENDIF Jv_TIMEBLOCKS}\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n\r\n function GetTFHintClass: TJvTFHintClass; dynamic;\r\n\r\n // move grab handles\r\n function GetTopGrabHandleRect(Col: Integer; Appt: TJvTFAppt): TRect;\r\n // move grab handles\r\n function GetBottomGrabHandleRect(Col: Integer; Appt: TJvTFAppt): TRect;\r\n function PtInTopHandle(APoint: TPoint; Col: Integer; Appt: TJvTFAppt): Boolean;\r\n function PtInBottomHandle(APoint: TPoint; Col: Integer; Appt: TJvTFAppt): Boolean;\r\n\r\n // grid region functions\r\n function GetAdjClientRect: TRect;\r\n function GetDataAreaRect: TRect;\r\n function GetDataWidth: Integer;\r\n function GetDataHeight: Integer;\r\n function PtToCell(X, Y: Integer): TJvTFDaysCoord;\r\n function CellRect(Col, Row: Integer): TRect;\r\n function VirtualCellRect(Col, Row: Integer): TRect;\r\n function GetApptRect(Col: Integer; Appt: TJvTFAppt): TRect;\r\n function LocateDivCol(X, TotalWidth, SegCount: Integer): Integer;\r\n function CalcGroupHdrHeight: Integer;\r\n function CalcGroupColHdrsHeight: Integer;\r\n function VirtualGroupHdrRect(Col: Integer): TRect;\r\n procedure GetGroupStartEndCols(Col: Integer; var StartCol, EndCol: Integer);\r\n\r\n {$IFDEF Jv_TIMEBLOCKS}\r\n // ok\r\n function RowToTimeBlock(ARow: Integer): Integer;\r\n // ok\r\n procedure GetTimeBlockStartEnd(ATimeBlock: Integer; var BlockStart,\r\n BlockEnd: Integer);\r\n // ok\r\n function CalcBlockHdrWidth: Integer;\r\n // ok\r\n function CalcBlockRowHdrsWidth: Integer;\r\n // ok\r\n procedure GetBlockStartEndRows(Row: Integer; var StartRow, EndRow: Integer);\r\n // ok\r\n function VirtualBlockHdrRect(Row: Integer): TRect;\r\n {$ENDIF Jv_TIMEBLOCKS}\r\n\r\n // editor management routines\r\n procedure EditAppt(Col: Integer; Appt: TJvTFAppt);\r\n procedure FinishEditAppt;\r\n function Editing: Boolean;\r\n function CanEdit: Boolean; dynamic;\r\n\r\n // grid layout routines\r\n function RowsPerHour: Integer;\r\n function RowCount: Integer;\r\n function PossVisibleRows: Integer;\r\n function VisibleRows: Integer;\r\n function FullVisibleRows: Integer;\r\n function VisibleCols: Integer;\r\n function FullVisibleCols: Integer;\r\n function RowToTime(RowNum: Integer): TTime;\r\n function TimeToRow(ATime: TTime): Integer;\r\n procedure TimeToTop(ATime: TTime);\r\n function AdjustEndTime(ATime: TTime): TTime; dynamic;\r\n function RowStartsHour(RowNum: Integer): Boolean;\r\n function RowEndsHour(RowNum: Integer): Boolean;\r\n function RowEndTime(RowNum: Integer): TTime;\r\n\r\n function RowToHour(RowNum: Integer): Word;\r\n function HourStartRow(Hour: Word): Integer;\r\n function HourEndRow(Hour: Word): Integer;\r\n\r\n property State: TJvTFDaysState read FState;\r\n function BottomRow: Integer;\r\n function RightCol: Integer;\r\n property SelAppt: TJvTFAppt read FSelAppt write SetSelAppt;\r\n property FocusedSchedule: TJvTFSched read GetFocusedSchedule;\r\n\r\n procedure DragDrop(Source: TObject; X, Y: Integer); override;\r\n procedure CalcStartEndRows(AAppt: TJvTFAppt; SchedDate: TDate;\r\n var StartRow, EndRow: Integer);\r\n\r\n {$IFDEF Jv_TIMEBLOCKS}\r\n // ok\r\n function IsWeekend(ColIndex: Integer): Boolean;\r\n {$ENDIF Jv_TIMEBLOCKS}\r\n\r\n // date navigation methods\r\n procedure PrevDate;\r\n procedure NextDate;\r\n procedure GotoDate(aDate: TDate);\r\n procedure ScrollDays(NumDays: Integer);\r\n procedure ScrollMonths(NumMonths: Integer);\r\n procedure ScrollYears(NumYears: Integer);\r\n\r\n procedure ReleaseSchedule(const SchedName: string; SchedDate: TDate); override;\r\n procedure RowInView(ARow: Integer);\r\n procedure ColInView(ACol: Integer);\r\n\r\n // selection properties and methods\r\n property FocusedCol: Integer read GetFocusedCol write SetFocusedCol;\r\n property FocusedRow: Integer read GetFocusedRow write SetFocusedRow;\r\n property SelStart: TPoint read GetSelStart write SetSelStart;\r\n property SelEnd: TPoint read GetSelEnd write SetSelEnd;\r\n function CellIsSelected(ACell: TPoint): Boolean;\r\n function ColIsSelected(ACol: Integer): Boolean;\r\n function RowIsSelected(ARow: Integer): Boolean;\r\n procedure ClearSelection;\r\n function ValidSelection: Boolean;\r\n procedure SelFirstAppt;\r\n procedure SelPrevAppt;\r\n procedure SelNextAppt;\r\n procedure SelLastAppt;\r\n procedure SelFirstApptNextCol;\r\n procedure SelFirstApptPrevCol;\r\n procedure ApptInView(AAppt: TJvTFAppt; ACol: Integer);\r\n procedure SelApptCell(AAppt: TJvTFAppt; ACol: Integer);\r\n function GroupHdrIsSelected(ACol: Integer): Boolean;\r\n\r\n {$IFDEF Jv_TIMEBLOCKS}\r\n // ok\r\n function BlockHdrIsSelected(ARow: Integer): Boolean;\r\n {$ENDIF Jv_TIMEBLOCKS}\r\n\r\n function EnumSelCells: TDynPointArray;\r\n function EnumSelCols: TDynIntArray;\r\n function EnumSelRows: TDynIntArray;\r\n\r\n function GetApptDispColor(Appt: TJvTFAppt; Selected: Boolean): TColor;\r\n published\r\n property DitheredBackground: Boolean read FDitheredBackground write SetDitheredBackground default True;\r\n property BorderStyle: TBorderStyle read FBorderStyle write SetBorderStyle default bsSingle;\r\n // grid layout properties\r\n property AutoSizeCols: Boolean read FAutoSizeCols write SetAutoSizeCols default True;\r\n property Granularity: Integer read FGranularity write SetGranularity default 30;\r\n property ColHdrHeight: Integer read FColHdrHeight write SetColHdrHeight default 25;\r\n property Cols: TJvTFDaysCols read FCols write SetCols;\r\n property DefColWidth: Integer read FDefColWidth write FDefColWidth default 100;\r\n property MinColWidth: Integer read FMinColWidth write SetMinColWidth default AbsMinColWidth;\r\n property MinRowHeight: Integer read FMinRowHeight write SetMinRowHeight default 12;\r\n property Options: TJvTFDaysOptions read FOptions write SetOptions\r\n default [agoSizeCols, agoSizeRows, agoSizeColHdr, agoSizeRowHdr,\r\n agoSizeAppt, agoMoveAppt, agoEditing, agoShowPics,\r\n agoShowText, agoShowApptHints, agoQuickEntry, agoShowSelHint];\r\n property RowHdrWidth: Integer read FRowHdrWidth write SetRowHdrWidth default 50;\r\n property RowHeight: Integer read FRowHeight write SetRowHeight default 19;\r\n property ShowFocus:Boolean read FShowFocus write SetShowFocus default True;\r\n property Template: TJvTFDaysTemplate read FTemplate write FTemplate;\r\n property Grouping: TJvTFDaysGrouping read FGrouping write SetGrouping;\r\n property GroupHdrHeight: Integer read FGroupHdrHeight write SetGroupHdrHeight default 25;\r\n\r\n property GridStartTime: TTime read FGridStartTime write SetGridStartTime;\r\n property GridEndTime: TTime read FGridEndTime write SetGridEndTime;\r\n\r\n {$IFDEF Jv_TIMEBLOCKS}\r\n // ok\r\n property TimeBlocks: TJvTFDaysTimeBlocks read FTimeBlocks write SetTimeBlocks;\r\n property TimeBlockProps: TJvTFDaysBlockProps read FTimeBlockProps write SetTimeBlockProps;\r\n {$ENDIF Jv_TIMEBLOCKS}\r\n\r\n // visual appearance properties\r\n property ApptAttr: TJvTFDaysApptAttr read FApptAttr write SetApptAttr;\r\n property SelApptAttr: TJvTFDaysApptAttr read FSelApptAttr write SetSelApptAttr;\r\n property HdrAttr: TJvTFDaysHdrAttr read FHdrAttr write SetHdrAttr;\r\n property SelHdrAttr: TJvTFDaysHdrAttr read FSelHdrAttr write SetSelHdrAttr;\r\n property FancyRowHdrAttr: TJvTFDaysFancyRowHdrAttr read FFancyRowHdrAttr\r\n write SetFancyRowHdrAttr;\r\n property SelFancyRowHdrAttr: TJvTFDaysFancyRowHdrAttr\r\n read FSelFancyRowHdrAttr write SetSelFancyRowHdrAttr;\r\n property SelCellAttr: TJvTFSelCellAttr read FSelCellAttr write SetTFSelCellAttr;\r\n\r\n property ApptBar: TJvTFDaysApptBar read FApptBar write SetApptBar;\r\n property ApptBuffer: Integer read FApptBuffer write SetApptBuffer default 5;\r\n property ColTitleStyle: TJvTFColTitleStyle read FColTitleStyle\r\n write SetTFColTitleStyle default ctsSingleEllipsis;\r\n property GrabHandles: TJvTFDaysGrabHandles read FGrabHandles\r\n write SetGrabHandles;\r\n property GridLineColor: TColor read FGridLineColor write SetGridLineColor\r\n default clGray;\r\n property PrimeTime: TJvTFDaysPrimeTime read FPrimeTime write FPrimeTime;\r\n property RowHdrType: TJvTFRowHdrType read FRowHdrType write SetTFRowHdrType\r\n default rhFancy;\r\n property Thresholds: TJvTFDaysThresholds read FThresholds write FThresholds;\r\n property HintProps: TJvTFHintProps read FHintProps\r\n write SetTFHintProps;\r\n property GroupHdrAttr: TJvTFDaysHdrAttr read FGroupHdrAttr\r\n write SetGroupHdrAttr;\r\n property SelGroupHdrAttr: TJvTFDaysHdrAttr read FSelGroupHdrAttr\r\n write SetSelGroupHdrAttr;\r\n\r\n {$IFDEF Jv_TIMEBLOCKS}\r\n // ok\r\n property Weekend: TTFDaysOfWeek read FWeekend write SetWeekend\r\n default [dowSunday, dowSaturday];\r\n property WeekendColor: TColor read FWeekendColor write SetWeekendColor default clSilver;\r\n {$ENDIF Jv_TIMEBLOCKS}\r\n\r\n // navigation/selection properties\r\n property LeftCol: Integer read FLeftCol write SetLeftCol;\r\n property TopRow: Integer read FTopRow write SetTopRow default 0;\r\n\r\n // Drag/Drop events\r\n property OnDropAppt: TJvTFDropApptEvent read FOnDropAppt write FOnDropAppt;\r\n property OnSizeAppt: TJvTFSizeApptEvent read FOnSizeAppt write FOnSizeAppt;\r\n\r\n // Grid Layout events\r\n property OnSizeCol: TJvTFDragRowColEvent read FOnSizeCol write FOnSizeCol;\r\n property OnSizeRow: TJvTFDragRowColEvent read FOnSizeRow write FOnSizeRow;\r\n property OnSizeColHdr: TJvTFDragRowColEvent read FOnSizeColHdr write FOnSizeColHdr;\r\n property OnSizeRowHdr: TJvTFDragRowColEvent read FOnSizeRowHdr write FOnSizeRowHdr;\r\n property OnMoveCol: TJvTFDragRowColEvent read FOnMoveCol write FOnMoveCol;\r\n\r\n property OnDateChanging: TJvTFDateChangingEvent read FOnDateChanging\r\n write FOnDateChanging;\r\n property OnDateChanged: TNotifyEvent read FOnDateChanged write FOnDateChanged;\r\n property OnGranularityChanging: TJvTFGranChangingEvent read FOnGranularityChanging\r\n write FOnGranularityChanging;\r\n property OnGranularityChanged: TNotifyEvent read FOnGranularityChanged\r\n write FOnGranularityChanged;\r\n\r\n // Custom draw events\r\n property OnDrawAppt: TJvTFDrawApptEvent read FOnDrawAppt write FOnDrawAppt;\r\n property OnDrawApptBar: TJvTFDrawApptBarEvent read FOnDrawApptBar\r\n write FOnDrawApptBar;\r\n property OnDrawColHdr: TJvTFDrawHdrEvent read FOnDrawColHdr write FOnDrawColHdr;\r\n property OnDrawCorner: TJvTFDrawCornerEvent read FOnDrawCorner\r\n write FOnDrawCorner;\r\n property OnDrawDataCell: TJvTFDrawDataCellEvent read FOnDrawDataCell\r\n write FOnDrawDataCell;\r\n property OnDrawGrabHandle: TJvTFDrawGrabHandleEvent read FOnDrawGrabHandle\r\n write FOnDrawGrabHandle;\r\n property OnDrawMajorRowHdr: TJvTFDrawHdrEvent read FOnDrawMajorRowHdr\r\n write FOnDrawMajorRowHdr;\r\n property OnDrawMinorRowHdr: TJvTFDrawHdrEvent read FOnDrawMinorRowHdr\r\n write FOnDrawMinorRowHdr;\r\n property OnDrawRowHdr: TJvTFDrawHdrEvent read FOnDrawRowHdr write FOnDrawRowHdr;\r\n property OnDrawGroupHdr: TJvTFDrawHdrEvent read FOnDrawGroupHdr\r\n write FOnDrawGroupHdr;\r\n property OnShadeCell: TJvTFShadeCellEvent read FOnShadeCell write FOnShadeCell;\r\n property OnGetApptDrawInfo: TJvTFGetDaysApptDrawInfoEvent read FOnGetApptDrawInfo\r\n write FOnGetApptDrawInfo;\r\n\r\n // Input events\r\n property OnFailEditor: TJvTFFailEditorEvent read FOnFailEditor write FOnFailEditor;\r\n property OnInsertAppt: TNotifyEvent read FOnInsertAppt write FOnInsertAppt;\r\n property OnInsertSchedule: TNotifyEvent read FOnInsertSchedule\r\n write FOnInsertSchedule;\r\n property OnDeleteAppt: TNotifyEvent read FOnDeleteAppt write FOnDeleteAppt;\r\n property OnDeleteSchedule: TNotifyEvent read FOnDeleteSchedule\r\n write FOnDeleteSchedule;\r\n property OnCreateQuickEntry: TJvTFCreateQuickEntryEvent read FOnCreateQuickEntry\r\n write FOnCreateQuickEntry;\r\n property OnQuickEntry: TNotifyEvent read FOnQuickEntry write FOnQuickEntry;\r\n property OnBeginEdit: TJvTFBeginEditEvent read FOnBeginEdit write FOnBeginEdit;\r\n\r\n // Help and Hint events\r\n property OnShowHint: TJvTFShowHintEvent read GetOnShowHint\r\n write SetOnShowHint;\r\n\r\n // Misc events\r\n property OnSelectingAppt: TJvTFVarApptEvent read FOnSelectingAppt\r\n write FOnSelectingAppt;\r\n property OnSelectAppt: TJvTFSelecTJvTFApptEvent read FOnSelectAppt\r\n write FOnSelectAppt;\r\n property OnSelectedAppt: TNotifyEvent read FOnSelectedAppt\r\n write FOnSelectedAppt;\r\n //property OnUpdateColTitle: TJvTFUpdateTitleEvent read FOnUpdateColTitle\r\n //write FOnUpdateColTitle;\r\n property OnUpdateColTitles: TJvTFUpdateTitlesEvent read FOnUpdateColTitles\r\n write FOnUpdateColTitles;\r\n property OnFocusedRowChanged: TNotifyEvent read FOnFocusedRowChanged\r\n write FOnFocusedRowChanged;\r\n property OnFocusedColChanged: TNotifyEvent read FOnFocusedColChanged\r\n write FOnFocusedColChanged;\r\n\r\n //Inherited properties\r\n property DateFormat; // from TJvTFControl\r\n property TimeFormat; // from TJvTFControl\r\n// property Navigator; // from TJvTFControl\r\n// property OnNavigate; // from TJvTFControl\r\n\r\n property Align;\r\n property Color default clSilver;\r\n property ParentColor default False;\r\n property Font;\r\n property ParentFont;\r\n property TabStop;\r\n property TabOrder;\r\n property Anchors;\r\n property Constraints;\r\n property DragKind;\r\n property DragCursor;\r\n property DragMode;\r\n property Enabled;\r\n property ParentShowHint;\r\n property PopupMenu;\r\n property ShowHint;\r\n property Visible;\r\n\r\n property OnClick;\r\n property OnDblClick;\r\n property OnDragDrop;\r\n property OnDragOver;\r\n property OnEndDrag;\r\n property OnEnter;\r\n property OnExit;\r\n property OnKeyDown;\r\n property OnKeyPress;\r\n property OnKeyUp;\r\n property OnMouseDown;\r\n property OnMouseMove;\r\n property OnMouseUp;\r\n property OnMouseWheelDown;\r\n property OnMouseWheelUp;\r\n property OnEndDock;\r\n property OnStartDock;\r\n property OnStartDrag;\r\n end;\r\n\r\n TJvTFDaysPrinterPageLayout = class(TJvTFPrinterPageLayout)\r\n private\r\n FColsPerPage: Integer;\r\n FRowsPerPage: Integer;\r\n FAlwaysShowColHdr: Boolean;\r\n FAlwaysShowRowHdr: Boolean;\r\n procedure SetColsPerPage(Value: Integer);\r\n procedure SetRowsPerPage(Value: Integer);\r\n procedure SetAlwaysShowColHdr(Value: Boolean);\r\n procedure SetAlwaysShowRowHdr(Value: Boolean);\r\n public\r\n procedure Assign(Source: TPersistent); override;\r\n published\r\n property ColsPerPage: Integer read FColsPerPage write SetColsPerPage;\r\n property RowsPerPage: Integer read FRowsPerPage write SetRowsPerPage;\r\n property AlwaysShowColHdr: Boolean read FAlwaysShowColHdr\r\n write SetAlwaysShowColHdr;\r\n property AlwaysShowRowHdr: Boolean read FAlwaysShowRowHdr\r\n write SetAlwaysShowRowHdr;\r\n end;\r\n\r\n TJvTFDaysPageInfo = class(TObject)\r\n private\r\n FPageNum: Integer;\r\n FStartRow: Integer;\r\n FEndRow: Integer;\r\n FStartCol: Integer;\r\n FEndCol: Integer;\r\n FRowHeight: Integer;\r\n FColWidth: Integer;\r\n FShowRowHdr: Boolean;\r\n FShowColHdr: Boolean;\r\n public\r\n property PageNum: Integer read FPageNum write FPageNum;\r\n property StartRow: Integer read FStartRow write FStartRow;\r\n property EndRow: Integer read FEndRow write FEndRow;\r\n property StartCol: Integer read FStartCol write FStartCol;\r\n property EndCol: Integer read FEndCol write FEndCol;\r\n property RowHeight: Integer read FRowHeight write FRowHeight;\r\n property ColWidth: Integer read FColWidth write FColWidth;\r\n property ShowRowHdr: Boolean read FShowRowHdr write FShowRowHdr;\r\n property ShowColHdr: Boolean read FShowColHdr write FShowColHdr;\r\n end;\r\n\r\n TJvTFDaysPrinter = class(TJvTFPrinter)\r\n private\r\n FApptCount: Integer;\r\n FApptAttr: TJvTFDaysApptAttr;\r\n FApptBar: TJvTFDaysApptBar;\r\n FApptBuffer: Integer;\r\n FColHdrHeight: Integer;\r\n FColor: TColor;\r\n FCols: TJvTFDaysCols;\r\n FColTitleStyle: TJvTFColTitleStyle;\r\n FFancyRowHdrAttr: TJvTFDaysFancyRowHdrAttr;\r\n FGranularity: Integer;\r\n FGridLineColor: TColor;\r\n FGroupHdrAttr: TJvTFDaysHdrAttr;\r\n FGroupHdrHeight: Integer;\r\n FGrouping: TJvTFDaysGrouping;\r\n FHdrAttr: TJvTFDaysHdrAttr;\r\n FMinColWidth: Integer;\r\n FMinRowHeight: Integer;\r\n FPrimeTime: TJvTFDaysPrimeTime;\r\n FRowHdrType: TJvTFRowHdrType;\r\n FRowHdrWidth: Integer;\r\n FRowHeight: Integer;\r\n FShowPics: Boolean;\r\n FShowText: Boolean;\r\n FFormattedDesc: Boolean;\r\n FThresholds: TJvTFDaysThresholds;\r\n FOnDrawCorner: TJvTFDrawCornerEvent;\r\n //FOnUpdateColTitle: TJvTFUpdateTitleEvent;\r\n FOnUpdateColTitles: TJvTFUpdateTitlesEvent;\r\n FOnDrawColHdr: TJvTFDrawHdrEvent;\r\n FOnDrawGroupHdr: TJvTFDrawHdrEvent;\r\n FOnDrawRowHdr: TJvTFDrawHdrEvent;\r\n FOnDrawMinorRowHdr: TJvTFDrawHdrEvent;\r\n FOnDrawMajorRowHdr: TJvTFDrawHdrEvent;\r\n FOnDrawDataCell: TJvTFDrawDataCellEvent;\r\n FOnDrawAppt: TJvTFDrawApptEvent;\r\n FOnDrawApptBar: TJvTFDrawApptBarEvent;\r\n FOnGetApptDrawInfo: TJvTFGetDaysApptDrawInfoEvent;\r\n FOnShadeCell: TJvTFShadeCellEvent;\r\n FOnApptProgress: TJvTFProgressEvent;\r\n FGridStartTime: TTime;\r\n FGridEndTime: TTime;\r\n procedure SetApptAttr(Value: TJvTFDaysApptAttr);\r\n procedure SetApptBar(Value: TJvTFDaysApptBar);\r\n procedure SetApptBuffer(Value: Integer);\r\n procedure SetColHdrHeight(Value: Integer);\r\n procedure SetColor(Value: TColor);\r\n procedure SetCols(Value: TJvTFDaysCols);\r\n procedure SetTFColTitleStyle(Value: TJvTFColTitleStyle);\r\n procedure SetFancyRowHdrAttr(Value: TJvTFDaysFancyRowHdrAttr);\r\n procedure SetGranularity(Value: Integer);\r\n procedure SetGridLineColor(Value: TColor);\r\n procedure SetGroupHdrAttr(Value: TJvTFDaysHdrAttr);\r\n procedure SetGroupHdrHeight(Value: Integer);\r\n procedure SetGrouping(Value: TJvTFDaysGrouping);\r\n procedure SetHdrAttr(Value: TJvTFDaysHdrAttr);\r\n procedure SetMinColWidth(Value: Integer);\r\n procedure SetMinRowHeight(Value: Integer);\r\n procedure SetPrimeTime(Value: TJvTFDaysPrimeTime);\r\n procedure SetTFRowHdrType(Value: TJvTFRowHdrType);\r\n procedure SetRowHdrWidth(Value: Integer);\r\n procedure SetRowHeight(Value: Integer);\r\n procedure SetShowPics(Value: Boolean);\r\n procedure SetShowText(Value: Boolean);\r\n procedure SetThresholds(Value: TJvTFDaysThresholds);\r\n procedure SetFormattedDesc(Value: Boolean);\r\n function GetApptCount: Integer;\r\n procedure SetGridStartTime(Value: TTime);\r\n procedure SetGridEndTime(Value: TTime);\r\n protected\r\n FPageInfoList: TStringList;\r\n FApptsDrawn: Integer;\r\n FValidPageInfo: Boolean;\r\n procedure SetMeasure(Value: TJvTFPrinterMeasure); override;\r\n procedure DrawBody(ACanvas: TCanvas; ARect: TRect; PageNum: Integer); override;\r\n\r\n procedure Loaded; override;\r\n\r\n // Drawing routines\r\n procedure DrawCorner(ACanvas: TCanvas);\r\n procedure DrawFrame(ACanvas: TCanvas; ARect: TRect; Draw3D: Boolean);\r\n procedure DrawEmptyColHdr(ACanvas: TCanvas; PageInfo: TJvTFDaysPageInfo);\r\n //procedure DrawColHdr(ACanvas: TCanvas; Index: Integer;\r\n //PageInfo: TJvTFDaysPageInfo);\r\n procedure DrawColGroupHdr(ACanvas: TCanvas; Index: Integer;\r\n PageInfo: TJvTFDaysPageInfo; IsGroupHdr: Boolean);\r\n procedure DrawRowHdr(ACanvas: TCanvas; Index: Integer;\r\n PageInfo: TJvTFDaysPageInfo);\r\n procedure DrawGroupHdrs(ACanvas: TCanvas; PageInfo: TJvTFDaysPageInfo);\r\n\r\n procedure DrawFancyRowHdrs(ACanvas: TCanvas; PageInfo: TJvTFDaysPageInfo);\r\n procedure DrawMinor(ACanvas: TCanvas; ARect: TRect; RowNum: Integer;\r\n const LabelStr: string; TickLength: Integer);\r\n function GetMinorLabel(RowNum: Integer; PageInfo: TJvTFDaysPageInfo): string;\r\n function GetMinorTickLength(ACanvas: TCanvas): Integer; virtual;\r\n function GetMajorTickLength: Integer; virtual;\r\n\r\n procedure DrawDataCell(ACanvas: TCanvas; ColIndex, RowIndex: Integer;\r\n PageInfo: TJvTFDaysPageInfo);\r\n procedure DrawAppts(ACanvas: TCanvas; DrawAll: Boolean;\r\n PageInfo: TJvTFDaysPageInfo);\r\n procedure PrintBitmap(ACanvas: TCanvas; SourceRect, DestRect: TRect;\r\n aBitmap: TBitmap);\r\n procedure DrawAppt(ACanvas: TCanvas; Col: Integer; Appt: TJvTFAppt;\r\n StartRow, EndRow: Integer; PageInfo: TJvTFDaysPageInfo);\r\n procedure DrawApptDetail(ACanvas: TCanvas; ARect: TRect; Appt: TJvTFAppt;\r\n Col, StartRow, EndRow: Integer);\r\n procedure DrawApptBar(ACanvas: TCanvas; Appt: TJvTFAppt; BarRect: TRect;\r\n Col, StartRow, EndRow: Integer);\r\n function CalcTimeStampRect(Appt: TJvTFAppt; BarRect: TRect;\r\n Col, StartRow, EndRow: Integer): TRect;\r\n procedure DrawTimeStamp(ACanvas: TCanvas; TimeStampRect: TRect);\r\n procedure GetApptDrawInfo(DrawInfo: TJvTFDaysApptDrawInfo; Appt: TJvTFAppt);\r\n\r\n procedure CreatePicDrawList(ARect: TRect; Appt: TJvTFAppt; DrawList: TList);\r\n procedure FilterPicDrawList(ARect: TRect; DrawList: TList;\r\n var PicsHeight: Integer; var PicsWidth: Integer);\r\n procedure CanDrawWhat(ACanvas: TCanvas; ApptRect: TRect;\r\n PicsHeight, PicsWidth: Integer; var CanDrawText, CanDrawPics: Boolean);\r\n procedure DrawListPics(ACanvas: TCanvas; var ARect: TRect; DrawList: TList);\r\n procedure ClearPicDrawList(DrawList: TList);\r\n\r\n function GetDataWidth(ShowRowHdr: Boolean): Integer;\r\n function GetDataHeight(ShowColHdr: Boolean): Integer;\r\n procedure EnsureRow(RowNum: Integer);\r\n procedure CreateLayout; override;\r\n procedure ClearPageInfo;\r\n procedure CalcPageInfo; dynamic;\r\n procedure CalcPageRowInfo(ShowColHdrs: Boolean; var CalcRowsPerPage,\r\n CalcRowHeight: Integer);\r\n procedure CalcPageColInfo(ShowRowHdrs: Boolean; var CalcColsPerPage,\r\n CalcColWidth: Integer);\r\n function GetPageLayout: TJvTFDaysPrinterPageLayout;\r\n procedure SetPageLayout(Value: TJvTFDaysPrinterPageLayout);\r\n procedure CreateDoc; override;\r\n function GetPageInfo(PageNum: Integer): TJvTFDaysPageInfo;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n procedure SetProperties(aJvTFDays: TJvTFDays); dynamic;\r\n function RowCount: Integer;\r\n function TimeToRow(ATime: TTime): Integer;\r\n function RowToTime(RowNum: Integer): TTime;\r\n function RowToHour(RowNum: Integer): Word;\r\n function RowStartsHour(RowNum: Integer): Boolean;\r\n function RowEndsHour(RowNum: Integer): Boolean;\r\n function HourStartRow(Hour: Word): Integer;\r\n function HourEndRow(Hour: Word): Integer;\r\n function RowEndTime(RowNum: Integer): TTime;\r\n function AdjustEndTime(ATime: TTime): TTime;\r\n function DaysPageLayout: TJvTFDaysPrinterPageLayout;\r\n function CellRect(Col, Row: Integer; PageInfo: TJvTFDaysPageInfo): TRect;\r\n function GetApptRect(Col: Integer; Appt: TJvTFAppt;\r\n PageInfo: TJvTFDaysPageInfo): TRect;\r\n function GetApptDispColor(Appt: TJvTFAppt): TColor;\r\n procedure CalcStartEndRows(AAppt: TJvTFAppt; SchedDate: TDate;\r\n var StartRow, EndRow: Integer);\r\n procedure Prepare; dynamic;\r\n property ApptCount: Integer read GetApptCount;\r\n property PageInfo[PageNum: Integer]: TJvTFDaysPageInfo read GetPageInfo;\r\n procedure FreeDoc; override;\r\n procedure PrintDirect; virtual;\r\n function CalcGroupHdrHeight: Integer;\r\n function CalcGroupColHdrsHeight: Integer;\r\n function VirtualGroupHdrRect(Col: Integer;\r\n PageInfo: TJvTFDaysPageInfo): TRect;\r\n procedure GetGroupStartEndCols(Col: Integer; var StartCol, EndCol: Integer);\r\n published\r\n property PageLayout: TJvTFDaysPrinterPageLayout read GetPageLayout\r\n write SetPageLayout;\r\n property ApptAttr: TJvTFDaysApptAttr read FApptAttr write SetApptAttr;\r\n property ApptBar: TJvTFDaysApptBar read FApptBar write SetApptBar;\r\n property ApptBuffer: Integer read FApptBuffer write SetApptBuffer;\r\n property ColHdrHeight: Integer read FColHdrHeight write SetColHdrHeight;\r\n property Color: TColor read FColor write SetColor;\r\n property Cols: TJvTFDaysCols read FCols write SetCols;\r\n property ColTitleStyle: TJvTFColTitleStyle read FColTitleStyle\r\n write SetTFColTitleStyle;\r\n property DateFormat; // inherited\r\n property FancyRowHdrAttr: TJvTFDaysFancyRowHdrAttr read FFancyRowHdrAttr\r\n write SetFancyRowHdrAttr;\r\n property FormattedDesc: Boolean read FFormattedDesc write SetFormattedDesc;\r\n property Granularity: Integer read FGranularity write SetGranularity;\r\n property GridLineColor: TColor read FGridLineColor write SetGridLineColor;\r\n property GroupHdrAttr: TJvTFDaysHdrAttr read FGroupHdrAttr\r\n write SetGroupHdrAttr;\r\n property GroupHdrHeight: Integer read FGroupHdrHeight\r\n write SetGroupHdrHeight default 25;\r\n property Grouping: TJvTFDaysGrouping read FGrouping write SetGrouping;\r\n property HdrAttr: TJvTFDaysHdrAttr read FHdrAttr write SetHdrAttr;\r\n property MinColWidth: Integer read FMinColWidth write SetMinColWidth;\r\n property MinRowHeight: Integer read FMinRowHeight write SetMinRowHeight;\r\n property PrimeTime: TJvTFDaysPrimeTime read FPrimeTime write SetPrimeTime;\r\n property RowHdrType: TJvTFRowHdrType read FRowHdrType write SetTFRowHdrType;\r\n property RowHdrWidth: Integer read FRowHdrWidth write SetRowHdrWidth;\r\n property RowHeight: Integer read FRowHeight write SetRowHeight;\r\n property ShowPics: Boolean read FShowPics write SetShowPics;\r\n property ShowText: Boolean read FShowText write SetShowText;\r\n property Thresholds: TJvTFDaysThresholds read FThresholds\r\n write SetThresholds;\r\n property TimeFormat; // inherited;\r\n property OnDrawCorner: TJvTFDrawCornerEvent read FOnDrawCorner\r\n write FOnDrawCorner;\r\n property OnDrawGroupHdr: TJvTFDrawHdrEvent read FOnDrawGroupHdr\r\n write FOnDrawGroupHdr;\r\n property OnDrawMinorRowHdr: TJvTFDrawHdrEvent read FOnDrawMinorRowHdr\r\n write FOnDrawMinorRowHdr;\r\n property OnDrawMajorRowHdr: TJvTFDrawHdrEvent read FOnDrawMajorRowHdr\r\n write FOnDrawMajorRowHdr;\r\n //property OnUpdateColTitle: TJvTFUpdateTitleEvent read FOnUpdateColTitle\r\n //write FOnUpdateColTitle;\r\n property OnUpdateColTitles: TJvTFUpdateTitlesEvent read FOnUpdateColTitles\r\n write FOnUpdateColTitles;\r\n property OnDrawColHdr: TJvTFDrawHdrEvent read FOnDrawColHdr write FOnDrawColHdr;\r\n property OnDrawRowHdr: TJvTFDrawHdrEvent read FOnDrawRowHdr write FOnDrawRowHdr;\r\n property OnDrawDataCell: TJvTFDrawDataCellEvent read FOnDrawDataCell\r\n write FOnDrawDataCell;\r\n property OnDrawAppt: TJvTFDrawApptEvent read FOnDrawAppt write FOnDrawAppt;\r\n property OnDrawApptBar: TJvTFDrawApptBarEvent read FOnDrawApptBar\r\n write FOnDrawApptBar;\r\n property OnGetApptDrawInfo: TJvTFGetDaysApptDrawInfoEvent read FOnGetApptDrawInfo\r\n write FOnGetApptDrawInfo;\r\n property OnShadeCell: TJvTFShadeCellEvent read FOnShadeCell write FOnShadeCell;\r\n property OnApptProgress: TJvTFProgressEvent read FOnApptProgress\r\n write FOnApptProgress;\r\n property GridStartTime: TTime read FGridStartTime write SetGridStartTime;\r\n property GridEndTime: TTime read FGridEndTime write SetGridEndTime;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvTFDays.pas $';\r\n Revision: '$Revision: 13357 $';\r\n Date: '$Date: 2012-06-17 02:06:53 +0200 (dim. 17 juin 2012) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n Types, JvResources;\r\n\r\n//Type\r\n // DEF TIMEBLOCK (not conditionally compiled, just marked for reference)\r\n // removed as part of TimeBlock integration\r\n //TVertAlignment = (vaTop, vaCenter, vaBottom);\r\n\r\n// Utility routines\r\n// Most, if not all, of these will be moved out of this unit and into\r\n// a utilities unit.\r\n\r\nfunction StripCRLF(const S: string): string;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := '';\r\n for I := 1 to Length(S) do\r\n if (S[I] <> #13) and (S[I] <> #10) then\r\n Result := Result + S[I];\r\nend;\r\n\r\nfunction EmptyRect: TRect;\r\nbegin\r\n Result := Classes.Rect(0, 0, 0, 0);\r\nend;\r\n\r\nfunction RectWidth(ARect: TRect): Integer;\r\nbegin\r\n Result := ARect.Right - ARect.Left;\r\nend;\r\n\r\nfunction RectHeight(ARect: TRect): Integer;\r\nbegin\r\n Result := ARect.Bottom - ARect.Top;\r\nend;\r\n\r\n// DEF TIMEBLOCK (not conditionally compiled, just marked for reference)\r\n// the type of VAlign was orginally TVertAlignment\r\n\r\nprocedure DrawTxt(ACanvas: TCanvas; ARect: TRect;\r\n const Txt: string; HAlign: TAlignment; VAlign: TJvTFVAlignment);\r\nvar\r\n TxtWidth, TxtHeight, TxtLeft, TxtTop: Integer;\r\nbegin\r\n TxtLeft := 0;\r\n TxtTop := 0;\r\n TxtWidth := ACanvas.TextWidth(Txt);\r\n TxtHeight := ACanvas.TextHeight('Wq');\r\n\r\n case HAlign of\r\n taLeftJustify:\r\n TxtLeft := ARect.Left;\r\n taCenter:\r\n TxtLeft := ARect.Left + RectWidth(ARect) div 2 - TxtWidth div 2;\r\n taRightJustify:\r\n TxtLeft := ARect.Right - TxtWidth;\r\n end;\r\n\r\n case VAlign of\r\n vaTop:\r\n TxtTop := ARect.Top;\r\n vaCenter:\r\n TxtTop := ARect.Top + RectHeight(ARect) div 2 - TxtHeight div 2;\r\n vaBottom:\r\n TxtTop := ARect.Bottom - TxtHeight;\r\n end;\r\n\r\n ACanvas.TextRect(ARect, TxtLeft, TxtTop, Txt);\r\nend;\r\n\r\nfunction Greater(I1, I2: Integer): Integer;\r\nbegin\r\n if I1 > I2 then\r\n Result := I1\r\n else\r\n Result := I2;\r\nend;\r\n\r\nfunction Lesser(I1, I2: Integer): Integer;\r\nbegin\r\n if I1 < I2 then\r\n Result := I1\r\n else\r\n Result := I2;\r\nend;\r\n\r\n//=== { TJvTFDaysTemplate } ==================================================\r\n\r\nconstructor TJvTFDaysTemplate.Create(AApptGrid: TJvTFDays);\r\nbegin\r\n inherited Create;\r\n FGrid := AApptGrid;\r\n\r\n FCompNames := TJvTFCompNamesList.Create;\r\n FCompNames.OnChange := CompNamesChanged;\r\n FCompNames.OnMove := CompNamesMoved;\r\n\r\n FLinearStartDate := Date;\r\n FLinearEndDate := Date;\r\n FLinearDayCount := 1;\r\n FCompDate := Date;\r\n FActiveTemplate := agtNone;\r\n FShortTitles := True;\r\nend;\r\n\r\ndestructor TJvTFDaysTemplate.Destroy;\r\nbegin\r\n FCompNames.OnChange := nil;\r\n FCompNames.OnMove := nil;\r\n FCompNames.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvTFDaysTemplate.SetActiveTemplate(Value: TJvTFDaysTemplates);\r\nbegin\r\n if Value <> FActiveTemplate then\r\n begin\r\n FActiveTemplate := Value;\r\n UpdateGrid;\r\n end;\r\nend;\r\n\r\nprocedure TJvTFDaysTemplate.SetCompDate(Value: TDate);\r\nvar\r\n I: Integer;\r\nbegin\r\n if Trunc(Value) <> Trunc(FCompDate) then\r\n begin\r\n DoDateChangingEvent(Value);\r\n\r\n FCompDate := Value;\r\n if (ActiveTemplate = agtComparative) and Assigned(FGrid) then\r\n try\r\n BeginGridUpdate;\r\n for I := 0 to FGrid.Cols.Count - 1 do\r\n FGrid.Cols[I].SchedDate := CompDate;\r\n finally\r\n EndGridUpdate;\r\n end;\r\n\r\n DoDateChangedEvent;\r\n end;\r\nend;\r\n\r\nfunction TJvTFDaysTemplate.GetCompNames: TStrings;\r\nbegin\r\n Result := FCompNames;\r\nend;\r\n\r\nprocedure TJvTFDaysTemplate.SetCompNames(Value: TStrings);\r\nbegin\r\n FCompNames.Assign(Value);\r\n CompNamesChanged(Self);\r\nend;\r\n\r\nprocedure TJvTFDaysTemplate.SetLinearDayCount(Value: Integer);\r\nbegin\r\n if Value < 1 then\r\n Value := 1;\r\n\r\n if (Value <> FLinearDayCount) then\r\n begin\r\n FLinearDayCount := Value;\r\n if not (csLoading in FGrid.ComponentState) then\r\n begin\r\n FLinearEndDate := FLinearStartDate + Value - 1;\r\n LinearDaysChanged;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvTFDaysTemplate.SetLinearEndDate(Value: TDate);\r\nbegin\r\n if Trunc(Value) < Trunc(FLinearStartDate) then\r\n Value := FLinearStartDate;\r\n\r\n if (Trunc(Value) <> Trunc(FLinearEndDate)) then\r\n begin\r\n FLinearEndDate := Value;\r\n if not (csLoading in FGrid.ComponentState) then\r\n begin\r\n FLinearDayCount := Trunc(FLinearEndDate - FLinearStartDate + 1);\r\n LinearDaysChanged;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvTFDaysTemplate.SetLinearName(const Value: string);\r\nvar\r\n I: Integer;\r\nbegin\r\n if Value <> FLinearName then\r\n begin\r\n FLinearName := Value;\r\n if (ActiveTemplate = agtLinear) and Assigned(FGrid) then\r\n begin\r\n try\r\n BeginGridUpdate;\r\n\r\n for I := 0 to FGrid.Cols.Count - 1 do\r\n FGrid.Cols[I].SchedName := Value;\r\n finally\r\n EndGridUpdate;\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvTFDaysTemplate.SetLinearStartDate(Value: TDate);\r\nvar\r\n I: Integer;\r\nbegin\r\n if Trunc(Value) <> Trunc(FLinearStartDate) then\r\n begin\r\n DoDateChangingEvent(Value);\r\n\r\n FLinearStartDate := Value;\r\n FLinearEndDate := Value + FLinearDayCount - 1;\r\n if (ActiveTemplate = agtLinear) and Assigned(FGrid) then\r\n begin\r\n BeginGridUpdate;\r\n try\r\n for I := 0 to FGrid.Cols.Count - 1 do\r\n FGrid.Cols[I].SchedDate := Value + I;\r\n finally\r\n EndGridUpdate;\r\n end;\r\n end;\r\n\r\n DoDateChangedEvent;\r\n end;\r\nend;\r\n\r\nprocedure TJvTFDaysTemplate.SetShortTitles(Value: Boolean);\r\nbegin\r\n if Value <> FShortTitles then\r\n begin\r\n FShortTitles := Value;\r\n if Assigned(FGrid) and (ActiveTemplate <> agtNone) then\r\n FGrid.Cols.UpdateTitles;\r\n end;\r\nend;\r\n\r\nprocedure TJvTFDaysTemplate.DoDateChangedEvent;\r\nbegin\r\n if Assigned(FGrid) and Assigned(FGrid.FOnDateChanged) then\r\n FGrid.FOnDateChanged(FGrid);\r\nend;\r\n\r\nprocedure TJvTFDaysTemplate.DoDateChangingEvent(var NewDate: TDate);\r\nbegin\r\n if Assigned(FGrid) and Assigned(FGrid.FOnDateChanging) then\r\n FGrid.FOnDateChanging(FGrid, NewDate);\r\nend;\r\n\r\nprocedure TJvTFDaysTemplate.CompNamesChanged(Sender: TObject);\r\nvar\r\n TempNames: TStringList;\r\n I: Integer;\r\n Col: TJvTFDaysCol;\r\nbegin\r\n if FUpdatingCompNames then\r\n begin\r\n FCompNamesChanged := True;\r\n Exit;\r\n end;\r\n\r\n FCompNamesChanged := False;\r\n if (ActiveTemplate = agtComparative) and Assigned(FGrid) then\r\n begin\r\n TempNames := TStringList.Create;\r\n try\r\n BeginGridUpdate;\r\n\r\n // remove any unneeded cols\r\n I := 0;\r\n while I < FGrid.Cols.Count do\r\n if CompNames.IndexOf(FGrid.Cols[I].SchedName) = -1 then\r\n FGrid.Cols[I].Free\r\n else\r\n begin\r\n TempNames.Add(FGrid.Cols[I].SchedName);\r\n Inc(I);\r\n end;\r\n\r\n // add all new cols\r\n for I := 0 to CompNames.Count - 1 do\r\n if TempNames.IndexOf(CompNames[I]) = -1 then\r\n begin\r\n Col := FGrid.Cols.Add;\r\n Col.SchedName := CompNames[I];\r\n Col.SchedDate := CompDate;\r\n end;\r\n finally\r\n TempNames.Free;\r\n EndGridUpdate;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvTFDaysTemplate.LinearDaysChanged;\r\nvar\r\n I, DeltaDays: Integer;\r\n Col: TJvTFDaysCol;\r\nbegin\r\n if (ActiveTemplate = agtLinear) and Assigned(FGrid) then\r\n begin\r\n try\r\n BeginGridUpdate;\r\n\r\n DeltaDays := LinearDayCount - FGrid.Cols.Count;\r\n\r\n // ONLY ONE OF THE FOLLOWING LOOPS WILL BE EXECUTED !!\r\n // Add some days\r\n for I := 1 to DeltaDays do\r\n begin\r\n Col := FGrid.Cols.Add;\r\n Col.SchedName := LinearName;\r\n Col.SchedDate := LinearStartDate + FGrid.Cols.Count - 1;\r\n end;\r\n\r\n // Remove some days\r\n for I := -1 downto DeltaDays do\r\n if FGrid.Cols.Count > 0 then\r\n FGrid.Cols[FGrid.Cols.Count - 1].Free;\r\n finally\r\n EndGridUpdate;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvTFDaysTemplate.Assign(Source: TPersistent);\r\nbegin\r\n if Source is TJvTFDaysTemplate then\r\n begin\r\n FLinearName := TJvTFDaysTemplate(Source).LinearName;\r\n FLinearStartDate := TJvTFDaysTemplate(Source).LinearStartDate;\r\n FLinearEndDate := TJvTFDaysTemplate(Source).LinearEndDate;\r\n FLinearDayCount := TJvTFDaysTemplate(Source).LinearDayCount;\r\n FCompNames.OnChange := nil;\r\n FCompNames.Assign(TJvTFDaysTemplate(Source).CompNames);\r\n FCompNames.OnChange := CompNamesChanged;\r\n FCompDate := TJvTFDaysTemplate(Source).CompDate;\r\n FActiveTemplate := TJvTFDaysTemplate(Source).ActiveTemplate;\r\n FShortTitles := TJvTFDaysTemplate(Source).ShortTitles;\r\n FIgnoreNav := TJvTFDaysTemplate(Source).IgnoreNav;\r\n UpdateGrid;\r\n end\r\n else\r\n inherited Assign(Source);\r\nend;\r\n\r\nprocedure TJvTFDaysTemplate.BeginCompNamesUpdate;\r\nbegin\r\n FUpdatingCompNames := True;\r\nend;\r\n\r\nprocedure TJvTFDaysTemplate.EndCompNamesUpdate;\r\nbegin\r\n FUpdatingCompNames := False;\r\n if FCompNamesChanged then\r\n CompNamesChanged(Self);\r\nend;\r\n\r\nprocedure TJvTFDaysTemplate.UpdateGrid;\r\nvar\r\n I: Integer;\r\n Col: TJvTFDaysCol;\r\nbegin\r\n if not Assigned(FGrid) then\r\n Exit;\r\n\r\n if ActiveTemplate = agtLinear then\r\n begin\r\n try\r\n BeginGridUpdate;\r\n\r\n FGrid.Cols.Clear;\r\n for I := 0 to LinearDayCount - 1 do\r\n begin\r\n Col := FGrid.Cols.Add;\r\n Col.SchedName := LinearName;\r\n Col.SchedDate := LinearStartDate + I;\r\n end;\r\n finally\r\n EndGridUpdate;\r\n end\r\n end\r\n else\r\n if ActiveTemplate = agtComparative then\r\n begin\r\n try\r\n BeginGridUpdate;\r\n FGrid.Cols.Clear;\r\n for I := 0 to CompNames.Count - 1 do\r\n begin\r\n Col := FGrid.Cols.Add;\r\n Col.SchedName := CompNames[I];\r\n Col.SchedDate := CompDate;\r\n end;\r\n finally\r\n EndGridUpdate;\r\n end;\r\n end;\r\n\r\n FGrid.Cols.UpdateTitles;\r\nend;\r\n\r\nprocedure TJvTFDaysTemplate.CompNamesMoved(Sender: TObject;\r\n CurIndex, NewIndex: Integer);\r\nbegin\r\n if Assigned(ApptGrid) and (ActiveTemplate = agtComparative) and\r\n not ApptGrid.Cols.Updating then\r\n ApptGrid.Cols.MoveCol(CurIndex, NewIndex);\r\nend;\r\n\r\nprocedure TJvTFDaysTemplate.BeginGridUpdate;\r\nbegin\r\n FUpdatingGrid := True;\r\nend;\r\n\r\nprocedure TJvTFDaysTemplate.EndGridUpdate;\r\nbegin\r\n FUpdatingGrid := False;\r\n ApptGrid.ProcessBatches;\r\nend;\r\n\r\n//=== { TJvTFDaysPrimeTime } =================================================\r\n\r\nconstructor TJvTFDaysPrimeTime.Create(AApptGrid: TJvTFDays);\r\nbegin\r\n inherited Create;\r\n FApptGrid := AApptGrid;\r\n FStartTime := EncodeTime(8, 0, 0, 0);\r\n FEndTime := EncodeTime(17, 0, 0, 0);\r\n FColor := clYellow;\r\n FFillPic := TBitmap.Create;\r\n FFillPic.Width := 16;\r\n FFillPic.Height := 16;\r\n UpdateFillPic;\r\nend;\r\n\r\ndestructor TJvTFDaysPrimeTime.Destroy;\r\nbegin\r\n FFillPic.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvTFDaysPrimeTime.SetStartTime(Value: TTime);\r\nbegin\r\n if Assigned(FApptGrid) and not (csLoading in FApptGrid.ComponentState) and\r\n (Value >= EndTime) then\r\n raise EJvTFDaysError.CreateRes(@RsEInvalidPrimeTimeStartTime);\r\n\r\n FStartTime := Value;\r\n Change;\r\nend;\r\n\r\nprocedure TJvTFDaysPrimeTime.SetEndTime(Value: TTime);\r\nbegin\r\n if Assigned(FApptGrid) and (Value <= StartTime) and\r\n not (csLoading in FApptGrid.ComponentState) then\r\n raise EJvTFDaysError.CreateRes(@RsEInvalidPrimeTimeEndTime);\r\n\r\n FEndTime := Value;\r\n Change;\r\nend;\r\n\r\nprocedure TJvTFDaysPrimeTime.SetColor(Value: TColor);\r\nbegin\r\n if Value <> FColor then\r\n begin\r\n FColor := Value;\r\n UpdateFillPic;\r\n Change;\r\n end;\r\nend;\r\n\r\nprocedure TJvTFDaysPrimeTime.Change;\r\nbegin\r\n if Assigned(FApptGrid) and not (csLoading in FApptGrid.ComponentState) then\r\n FApptGrid.Invalidate;\r\nend;\r\n\r\nprocedure TJvTFDaysPrimeTime.UpdateFillPic;\r\nbegin\r\n with FFillPic.Canvas do\r\n begin\r\n Brush.Color := FColor;\r\n FillRect(Classes.Rect(0, 0, FFillPic.Width, FFillPic.Height));\r\n end;\r\nend;\r\n\r\nprocedure TJvTFDaysPrimeTime.Assign(Source: TPersistent);\r\nbegin\r\n if Source is TJvTFDaysPrimeTime then\r\n begin\r\n FStartTime := TJvTFDaysPrimeTime(Source).StartTime;\r\n FEndTime := TJvTFDaysPrimeTime(Source).EndTime;\r\n FColor := TJvTFDaysPrimeTime(Source).Color;\r\n UpdateFillPic;\r\n Change;\r\n end\r\n else\r\n inherited Assign(Source);\r\nend;\r\n\r\n//=== { TJvTFInPlaceApptEditor } =============================================\r\n\r\nconstructor TJvTFInPlaceApptEditor.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n\r\n ControlStyle := ControlStyle + [csNoDesignVisible];\r\n\r\n BorderStyle := bsNone;\r\n FQuickCreate := False;\r\n ParentCtl3D := False;\r\n Ctl3D := False;\r\nend;\r\n\r\nprocedure TJvTFInPlaceApptEditor.DoExit;\r\nbegin\r\n inherited DoExit;\r\n try\r\n if not FCancelEdit then\r\n TJvTFDays(Parent).FinishEditAppt\r\n else\r\n if FQuickCreate then\r\n // Free the appointment\r\n FLinkedAppt.Free;\r\n finally\r\n FCancelEdit := False;\r\n Parent.SetFocus;\r\n end;\r\nend;\r\n\r\nprocedure TJvTFInPlaceApptEditor.KeyDown(var Key: Word; Shift: TShiftState);\r\nbegin\r\n inherited KeyDown(Key, Shift);\r\n\r\n if Key = VK_ESCAPE then\r\n begin\r\n FCancelEdit := True;\r\n Key := 0;\r\n Visible := False;\r\n end;\r\nend;\r\n\r\n//=== { TJvTFApptMap } =======================================================\r\n\r\nconstructor TJvTFApptMap.Create(AGridCol: TJvTFDaysCol);\r\nbegin\r\n inherited Create;\r\n FGridCol := AGridCol;\r\n FData := TJvTFSparseMatrix.Create;\r\nend;\r\n\r\ndestructor TJvTFApptMap.Destroy;\r\nbegin\r\n FData.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJvTFApptMap.GetLocation(Row, Col: Integer): TJvTFAppt;\r\nbegin\r\n Result := nil;\r\n if (Row >= 0) and (Col > 0) then\r\n Result := TJvTFAppt(FData[Row, Col]);\r\nend;\r\n\r\nprocedure TJvTFApptMap.Add(Appt: TJvTFAppt);\r\nvar\r\n StartRow, EndRow, MapRow, MapCol: Integer;\r\n Empty: Boolean;\r\n ApptGrid: TJvTFDays;\r\nbegin\r\n // We need to find the left-most col that does not have any appts already\r\n // scheduled in any of the rows needed by the new appt. (In other words,\r\n // we need a contiguous set cols for the new appt.)\r\n\r\n FGridCol.CalcStartEndRows(Appt, StartRow, EndRow);\r\n\r\n StartRow := Greater(StartRow, 0);\r\n\r\n ApptGrid := FGridCol.ColCollection.ApptGrid;\r\n if Assigned(ApptGrid) then\r\n EndRow := Lesser(EndRow, ApptGrid.RowCount - 1)\r\n else\r\n EndRow := Lesser(EndRow, FGridCol.ColCollection.Printer.RowCount - 1);\r\n\r\n MapRow := StartRow;\r\n MapCol := 1;\r\n repeat\r\n Empty := FData[MapRow, MapCol] = 0;\r\n if Empty then\r\n Inc(MapRow)\r\n else\r\n begin\r\n Inc(MapCol);\r\n MapRow := StartRow;\r\n end;\r\n until (MapRow > EndRow) and Empty;\r\n\r\n // Now write the new appt to the map in all rows hit by appt, using the\r\n // col found above.\r\n for MapRow := StartRow to EndRow do\r\n begin\r\n FData[MapRow, MapCol] := NativeInt(Appt);\r\n FData[MapRow, -1] := FData[MapRow, -1] + 1;\r\n end;\r\nend;\r\n\r\nprocedure TJvTFApptMap.ProcessMapGroup(GroupStart, GroupEnd: Integer);\r\nvar\r\n MapRow, Examined, ApptCount, MaxCol, MapCol: Integer;\r\nbegin\r\n // Find the highest used column in group\r\n MaxCol := 0;\r\n for MapRow := GroupStart to GroupEnd do\r\n begin\r\n Examined := 0;\r\n ApptCount := FData[MapRow, -1];\r\n // ApptCount > 0 check added by Mike 1/14/01\r\n if ApptCount > 0 then\r\n begin\r\n MapCol := 1;\r\n\r\n repeat\r\n if FData[MapRow, MapCol] <> 0 then\r\n Inc(Examined);\r\n Inc(MapCol);\r\n until Examined = ApptCount;\r\n\r\n Dec(MapCol);\r\n\r\n MaxCol := Greater(MaxCol, MapCol);\r\n end;\r\n end;\r\n\r\n // Now write MaxCol in col 0 for each row in the groups\r\n for MapRow := GroupStart to GroupEnd do\r\n FData[MapRow, 0] := MaxCol;\r\nend;\r\n\r\nprocedure TJvTFApptMap.UpdateMapGroups;\r\nvar\r\n GridRowCount: Integer;\r\nbegin\r\n if Assigned(FGridCol.ColCollection.ApptGrid) then\r\n GridRowCount := FGridCol.ColCollection.ApptGrid.RowCount\r\n else\r\n if Assigned(FGridCol.ColCollection.Printer) then\r\n GridRowCount := FGridCol.ColCollection.Printer.RowCount\r\n else\r\n GridRowCount := 0;\r\n\r\n // we could try to find a smaller group, by looking for the first and last\r\n // row where there is at least one appt, but CPU wise, it's actually simpler\r\n // to let the ProcessMapGroup function deal with it.\r\n ProcessMapGroup(0, GridRowCount);\r\nend;\r\n\r\nprocedure TJvTFApptMap.Clear;\r\nbegin\r\n FData.Clear;\r\nend;\r\n\r\nfunction TJvTFApptMap.ColCount(Row: Integer): Integer;\r\nbegin\r\n Result := FData[Row, 0];\r\nend;\r\n\r\nprocedure TJvTFApptMap.GetAppts(StartRow, EndRow: Integer; ApptList: TStringList);\r\nvar\r\n Row, Col, Existing, Found, MapCols: Integer;\r\n Appt: TJvTFAppt;\r\nbegin\r\n ApptList.Clear;\r\n\r\n for Row := StartRow to EndRow do\r\n begin\r\n Existing := FData[Row, -1];\r\n MapCols := FData[Row, 0];\r\n Found := 0;\r\n Col := 1;\r\n while (Found < Existing) and (Col <= MapCols) do\r\n begin\r\n if FData[Row, Col] <> 0 then\r\n begin\r\n Inc(Found);\r\n Appt := TJvTFAppt(FData[Row, Col]);\r\n if ApptList.IndexOf(Appt.ID) = -1 then\r\n ApptList.AddObject(Appt.ID, Appt);\r\n end;\r\n Inc(Col);\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJvTFApptMap.LocateMapCol(Appt: TJvTFAppt; MapSearchRow: Integer): Integer;\r\nvar\r\n Col, MapCols, ApptVal: Integer;\r\nbegin\r\n MapCols := FData[MapSearchRow, 0];\r\n Col := 1;\r\n ApptVal := Integer(Appt);\r\n\r\n while (Col <= MapCols) and (FData[MapSearchRow, Col] <> ApptVal) do\r\n Inc(Col);\r\n\r\n if FData[MapSearchRow, Col] = ApptVal then\r\n Result := Col\r\n else\r\n Result := -2;\r\nend;\r\n\r\nprocedure TJvTFApptMap.Refresh;\r\nvar\r\n Sched: TJvTFSched;\r\n I: Integer;\r\nbegin\r\n Clear;\r\n\r\n Sched := FGridCol.Schedule;\r\n if Assigned(Sched) then\r\n begin\r\n for I := 0 to Sched.ApptCount - 1 do\r\n Add(Sched.Appts[I]);\r\n\r\n UpdateMapGroups;\r\n end;\r\nend;\r\n\r\nprocedure TJvTFApptMap.Dump(AName: TFileName);\r\nvar\r\n DumpData: TStringList;\r\nbegin\r\n // used for debugging only\r\n DumpData := TStringList.Create;\r\n try\r\n FData.Dump(DumpData);\r\n DumpData.SaveToFile(AName);\r\n finally\r\n DumpData.Free;\r\n end;\r\nend;\r\n\r\nfunction TJvTFApptMap.HasAppt(Appt: TJvTFAppt): Boolean;\r\nvar\r\n MapRow, MapCol, StartRow, EndRow, ApptsExamined: Integer;\r\n Test: NativeInt;\r\n ApptGrid: TJvTFDays;\r\nbegin\r\n FGridCol.CalcStartEndRows(Appt, StartRow, EndRow);\r\n\r\n StartRow := Greater(StartRow, 0);\r\n\r\n ApptGrid := FGridCol.ColCollection.ApptGrid;\r\n if Assigned(ApptGrid) then\r\n EndRow := Lesser(EndRow, ApptGrid.RowCount - 1)\r\n else\r\n EndRow := Lesser(EndRow, FGridCol.ColCollection.Printer.RowCount - 1);\r\n\r\n MapRow := 0;\r\n Result := False;\r\n while (MapRow <= EndRow) and not Result do\r\n begin\r\n MapCol := 1;\r\n ApptsExamined := 0;\r\n while (ApptsExamined < FData[MapRow, -1]) and not Result do\r\n begin\r\n Test := FData[MapRow, MapCol];\r\n if Test > 0 then\r\n begin\r\n Inc(ApptsExamined);\r\n if Test = NativeInt(Appt) then\r\n Result := True;\r\n end;\r\n\r\n Inc(MapCol);\r\n end;\r\n\r\n Inc(MapRow);\r\n end;\r\nend;\r\n\r\n//=== { TJvTFDaysThresholds } ================================================\r\n\r\nconstructor TJvTFDaysThresholds.Create(AOwner: TJvTFDays);\r\nbegin\r\n inherited Create;\r\n FApptGrid := AOwner;\r\n\r\n FTextHeight := 1;\r\n FTextWidth := 10;\r\n FEditHeight := 1;\r\n FEditWidth := 10;\r\n FDetailWidth := 10;\r\n FDetailHeight := 10;\r\n FDropTextFirst := True;\r\n FPicsAllOrNone := False;\r\n FWholePicsOnly := True;\r\nend;\r\n\r\nprocedure TJvTFDaysThresholds.SetDetailHeight(Value: Integer);\r\nbegin\r\n if Value < 1 then\r\n Value := 1;\r\n if Value <> FDetailHeight then\r\n begin\r\n FDetailHeight := Value;\r\n Change;\r\n end;\r\nend;\r\n\r\nprocedure TJvTFDaysThresholds.SetDetailWidth(Value: Integer);\r\nbegin\r\n if Value < 1 then\r\n Value := 1;\r\n if Value <> FDetailWidth then\r\n begin\r\n FDetailWidth := Value;\r\n Change;\r\n end;\r\nend;\r\n\r\nprocedure TJvTFDaysThresholds.SetEditHeight(Value: Integer);\r\nbegin\r\n if Value < 0 then\r\n Value := 0;\r\n if Value <> FEditHeight then\r\n FEditHeight := Value;\r\nend;\r\n\r\nprocedure TJvTFDaysThresholds.SetEditWidth(Value: Integer);\r\nbegin\r\n if Value < 0 then\r\n Value := 0;\r\n if Value <> FEditWidth then\r\n FEditWidth := Value;\r\nend;\r\n\r\nprocedure TJvTFDaysThresholds.SetTextHeight(Value: Integer);\r\nbegin\r\n if Value < 0 then\r\n Value := 0;\r\n if Value <> FTextHeight then\r\n begin\r\n FTextHeight := Value;\r\n Change;\r\n end;\r\nend;\r\n\r\nprocedure TJvTFDaysThresholds.SetTextWidth(Value: Integer);\r\nbegin\r\n if Value < 0 then\r\n Value := 0;\r\n if Value <> FTextWidth then\r\n begin\r\n FTextWidth := Value;\r\n Change;\r\n end;\r\nend;\r\n\r\nprocedure TJvTFDaysThresholds.SetDropTextFirst(Value: Boolean);\r\nbegin\r\n if Value <> FDropTextFirst then\r\n begin\r\n FDropTextFirst := Value;\r\n Change;\r\n end;\r\nend;\r\n\r\nprocedure TJvTFDaysThresholds.SetPicsAllOrNone(Value: Boolean);\r\nbegin\r\n if Value <> FPicsAllOrNone then\r\n begin\r\n FPicsAllOrNone := Value;\r\n Change;\r\n end;\r\nend;\r\n\r\nprocedure TJvTFDaysThresholds.SetWholePicsOnly(Value: Boolean);\r\nbegin\r\n if Value <> FWholePicsOnly then\r\n begin\r\n FWholePicsOnly := Value;\r\n Change;\r\n end;\r\nend;\r\n\r\nprocedure TJvTFDaysThresholds.Change;\r\nbegin\r\n if Assigned(FApptGrid) then\r\n FApptGrid.Invalidate;\r\nend;\r\n\r\nprocedure TJvTFDaysThresholds.Assign(Source: TPersistent);\r\nbegin\r\n if Source is TJvTFDaysThresholds then\r\n begin\r\n FTextWidth := TJvTFDaysThresholds(Source).TextWidth;\r\n FTextHeight := TJvTFDaysThresholds(Source).TextHeight;\r\n FEditHeight := TJvTFDaysThresholds(Source).EditHeight;\r\n FEditWidth := TJvTFDaysThresholds(Source).EditWidth;\r\n FDropTextFirst := TJvTFDaysThresholds(Source).DropTextFirst;\r\n FPicsAllOrNone := TJvTFDaysThresholds(Source).PicsAllOrNone;\r\n FWholePicsOnly := TJvTFDaysThresholds(Source).WholePicsOnly;\r\n Change;\r\n end\r\n else\r\n inherited Assign(Source);\r\nend;\r\n\r\n//=== { TJvTFDaysScrollBar } =================================================\r\n\r\nconstructor TJvTFDaysScrollBar.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n // if we set the csNoDesignVisible flag then visibility at design time\r\n // is controled by the Visible property, which is exactly what we want.\r\n ControlStyle := ControlStyle + [csNoDesignVisible];\r\n ParentCtl3D := False;\r\n Ctl3D := False;\r\nend;\r\n\r\nprocedure TJvTFDaysScrollBar.CMDesignHitTest(var Msg: TCMDesignHitTest);\r\nbegin\r\n Msg.Result := 1;\r\nend;\r\n\r\nprocedure TJvTFDaysScrollBar.CreateWnd;\r\nbegin\r\n inherited CreateWnd;\r\n UpdateRange;\r\nend;\r\n\r\nfunction TJvTFDaysScrollBar.GetLargeChange: Integer;\r\nbegin\r\n Result := inherited LargeChange;\r\nend;\r\n\r\nprocedure TJvTFDaysScrollBar.SetLargeChange(Value: Integer);\r\nbegin\r\n inherited LargeChange := Value;\r\n UpdateRange;\r\nend;\r\n\r\nprocedure TJvTFDaysScrollBar.UpdateRange;\r\nvar\r\n Info: TScrollInfo;\r\nbegin\r\n FillChar(Info, SizeOf(Info), 0);\r\n with Info do\r\n begin\r\n cbsize := SizeOf(Info);\r\n fmask := SIF_PAGE;\r\n nPage := LargeChange;\r\n end;\r\n SetScrollInfo(Handle, SB_CTL, Info, True);\r\nend;\r\n\r\n//=== { TJvTFDaysCol } =======================================================\r\n\r\nconstructor TJvTFDaysCol.Create(Collection: TCollection);\r\nbegin\r\n inherited Create(Collection);\r\n FNullSchedDate := True;\r\n FMap := TJvTFApptMap.Create(Self);\r\nend;\r\n\r\ndestructor TJvTFDaysCol.Destroy;\r\nbegin\r\n Disconnect;\r\n FMap.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvTFDaysCol.SetSchedDate(Value: TDate);\r\nbegin\r\n if Value <> FSchedDate then\r\n begin\r\n Disconnect;\r\n FSchedDate := Value;\r\n FNullSchedDate := False;\r\n Connect;\r\n //UpdateTitle;\r\n UpdateTitles;\r\n CheckTemplate;\r\n end;\r\nend;\r\n\r\nprocedure TJvTFDaysCol.SetSchedName(const Value: string);\r\nbegin\r\n if Value <> FSchedName then\r\n begin\r\n Disconnect;\r\n FSchedName := Value;\r\n Connect;\r\n //UpdateTitle;\r\n UpdateTitles;\r\n CheckTemplate;\r\n end;\r\nend;\r\n\r\nprocedure TJvTFDaysCol.SetTitle(const Value: string);\r\nbegin\r\n if FTitle <> Value then\r\n begin\r\n FTitle := Value;\r\n if Assigned(ColCollection.ApptGrid) then\r\n ColCollection.ApptGrid.Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvTFDaysCol.SetWidth(Value: Integer);\r\nvar\r\n ApptGrid: TJvTFDays;\r\nbegin\r\n if Value < AbsMinColWidth then\r\n Value := AbsMinColWidth;\r\n\r\n if Assigned(ColCollection.ApptGrid) then\r\n if Value > ColCollection.ApptGrid.GetDataWidth then\r\n Value := ColCollection.ApptGrid.GetDataWidth;\r\n\r\n if Value < 1 then\r\n Value := 1;\r\n\r\n // For the printer, just set the private member then EXIT\r\n if Assigned(ColCollection.Printer) then\r\n begin\r\n FWidth := Value;\r\n Exit;\r\n end;\r\n\r\n if Value <> FWidth then\r\n begin\r\n FWidth := Value;\r\n ApptGrid := ColCollection.ApptGrid;\r\n\r\n if not (csLoading in ApptGrid.ComponentState) then\r\n begin\r\n if ApptGrid.AutoSizeCols then\r\n begin\r\n if not ColCollection.AddingCol and\r\n not (vsbHorz in ApptGrid.VisibleScrollBars) then\r\n ColCollection.ResizeCols;\r\n end\r\n else\r\n ApptGrid.CheckSBVis;\r\n\r\n ApptGrid.CheckSBParams;\r\n ApptGrid.Invalidate;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJvTFDaysCol.GetDisplayName: string;\r\nbegin\r\n Result := SchedName + ' [';\r\n if not FNullSchedDate then\r\n Result := Result + FormatDateTime('ddddd', SchedDate);\r\n Result := Result + ']';\r\n{\r\n if Title <> '' then\r\n Result := Title\r\n else\r\n Result := Inherited GetDisplayName;\r\n}\r\nend;\r\n\r\nprocedure TJvTFDaysCol.CheckTemplate;\r\nbegin\r\n if Assigned(ColCollection.ApptGrid) then\r\n with ColCollection.ApptGrid.Template do\r\n if not UpdatingGrid then\r\n ActiveTemplate := agtNone;\r\nend;\r\n\r\nprocedure TJvTFDaysCol.SetIndex(Value: Integer);\r\nbegin\r\n if not Assigned(ColCollection.ApptGrid) or\r\n (ColCollection.ApptGrid.Template.ActiveTemplate <> agtLinear) then\r\n inherited SetIndex(Value);\r\nend;\r\n\r\nprocedure TJvTFDaysCol.Assign(Source: TPersistent);\r\nbegin\r\n if Source is TJvTFDaysCol then\r\n begin\r\n Title := TJvTFDaysCol(Source).Title;\r\n Width := TJvTFDaysCol(Source).Width;\r\n SchedName := TJvTFDaysCol(Source).SchedName;\r\n SchedDate := TJvTFDaysCol(Source).SchedDate;\r\n end\r\n else\r\n inherited Assign(Source);\r\nend;\r\n\r\nfunction TJvTFDaysCol.ColCollection: TJvTFDaysCols;\r\nbegin\r\n Result := TJvTFDaysCols(Collection);\r\nend;\r\n\r\nfunction TJvTFDaysCol.Connected: Boolean;\r\nbegin\r\n Result := Assigned(FSchedule);\r\nend;\r\n\r\nprocedure TJvTFDaysCol.Connect;\r\nvar\r\n ApptGrid: TJvTFDays;\r\n FPrinter: TJvTFDaysPrinter;\r\nbegin\r\n ApptGrid := ColCollection.ApptGrid;\r\n FPrinter := ColCollection.Printer;\r\n\r\n if Assigned(ApptGrid) then\r\n begin\r\n if not Connected and not (csDesigning in ApptGrid.ComponentState) and\r\n not FNullSchedDate and (SchedName <> '') and Assigned(ApptGrid.ScheduleManager) and\r\n not (csLoading in ApptGrid.ComponentState) then\r\n begin\r\n FSchedule := ApptGrid.RetrieveSchedule(SchedName, SchedDate);\r\n FMap.Refresh;\r\n ApptGrid.Invalidate;\r\n //UpdateTitle;\r\n UpdateTitles;\r\n end;\r\n end\r\n else\r\n if Assigned(FPrinter) then\r\n begin\r\n if not Connected and not (csDesigning in FPrinter.ComponentState) and\r\n not FNullSchedDate and (SchedName <> '') and\r\n Assigned(FPrinter.ScheduleManager) and\r\n not (csLoading in FPrinter.ComponentState) then\r\n begin\r\n FSchedule := FPrinter.RetrieveSchedule(SchedName, SchedDate);\r\n FMap.Refresh;\r\n //UpdateTitle;\r\n UpdateTitles;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvTFDaysCol.Disconnect;\r\nvar\r\n ApptGrid: TJvTFDays;\r\n FPrinter: TJvTFDaysPrinter;\r\n SchedName: string;\r\n SchedDate: TDate;\r\nbegin\r\n if not FDisconnecting then\r\n try\r\n FDisconnecting := True;\r\n\r\n ApptGrid := ColCollection.ApptGrid;\r\n FPrinter := ColCollection.Printer;\r\n\r\n if Assigned(ApptGrid) then\r\n begin\r\n if Connected and Assigned(ApptGrid.ScheduleManager) then\r\n begin\r\n SchedName := Schedule.SchedName;\r\n SchedDate := Schedule.SchedDate;\r\n FSchedule := nil;\r\n FMap.Clear;\r\n ApptGrid.ReleaseSchedule(SchedName, SchedDate);\r\n ApptGrid.Invalidate;\r\n end;\r\n end\r\n else\r\n if Assigned(FPrinter) then\r\n begin\r\n if Connected and Assigned(FPrinter.ScheduleManager) then\r\n begin\r\n SchedName := Schedule.SchedName;\r\n SchedDate := Schedule.SchedDate;\r\n FSchedule := nil;\r\n FMap.Clear;\r\n FPrinter.ReleaseSchedule(SchedName, SchedDate);\r\n end;\r\n end;\r\n finally\r\n FDisconnecting := False;\r\n end;\r\nend;\r\n\r\nprocedure TJvTFDaysCol.SetSchedule(const NewSchedName: string; NewSchedDate: TDate);\r\nbegin\r\n Disconnect;\r\n FSchedName := SchedName;\r\n FSchedDate := SchedDate;\r\n FNullSchedDate := False;\r\n Connect;\r\n //UpdateTitle;\r\n UpdateTitles;\r\n CheckTemplate;\r\nend;\r\n\r\nprocedure TJvTFDaysCol.RefreshMap;\r\nbegin\r\n FMap.Refresh;\r\nend;\r\n\r\nprocedure TJvTFDaysCol.CalcStartEndRows(Appt: TJvTFAppt;\r\n var StartRow, EndRow: Integer);\r\nvar\r\n ApptGrid: TJvTFDays;\r\n FPrinter: TJvTFDaysPrinter;\r\nbegin\r\n ApptGrid := ColCollection.ApptGrid;\r\n FPrinter := ColCollection.Printer;\r\n\r\n if Assigned(ApptGrid) then\r\n begin\r\n if Trunc(Appt.StartDate) = Trunc(SchedDate) then\r\n StartRow := ApptGrid.TimeToRow(Appt.StartTime)\r\n else\r\n StartRow := 0;\r\n\r\n if Trunc(Appt.EndDate) = Trunc(SchedDate) then\r\n EndRow := ApptGrid.TimeToRow(ApptGrid.AdjustEndTime(Appt.EndTime))\r\n else\r\n EndRow := ApptGrid.RowCount - 1;\r\n end\r\n else\r\n if Assigned(FPrinter) then\r\n begin\r\n if Trunc(Appt.StartDate) = Trunc(SchedDate) then\r\n StartRow := FPrinter.TimeToRow(Appt.StartTime)\r\n else\r\n StartRow := 0;\r\n\r\n if Trunc(Appt.EndDate) = Trunc(SchedDate) then\r\n EndRow := FPrinter.TimeToRow(FPrinter.AdjustEndTime(Appt.EndTime))\r\n else\r\n EndRow := FPrinter.RowCount - 1;\r\n end;\r\nend;\r\n{\r\nprocedure TJvTFDaysCol.UpdateTitle;\r\nVar\r\n NewTitle: string;\r\n ApptGrid: TJvTFDays;\r\n FPrinter: TJvTFDaysPrinter;\r\nbegin\r\n ApptGrid := ColCollection.ApptGrid;\r\n FPrinter := ColCollection.Printer;\r\n\r\n if Assigned(ApptGrid) then\r\n begin\r\n if (ApptGrid.Template.ActiveTemplate = agtLinear) and\r\n (ApptGrid.Template.ShortTitles) then\r\n NewTitle := FormatDateTime(ApptGrid.DateFormat, SchedDate)\r\n else\r\n if (ApptGrid.Template.ActiveTemplate = agtComparative) and\r\n (ApptGrid.Template.ShortTitles) then\r\n NewTitle := SchedName\r\n else\r\n NewTitle := SchedName + ' - ' + FormatDateTime(ApptGrid.DateFormat, SchedDate);\r\n\r\n if Assigned(ApptGrid.OnUpdateColTitle) then\r\n ApptGrid.OnUpdateColTitle(ApptGrid, Self, NewTitle);\r\n Title := NewTitle;\r\n end\r\n else\r\n if Assigned(FPrinter) then\r\n begin\r\n NewTitle := SchedName + ' - ' +\r\n FormatDateTime(FPrinter.DateFormat, SchedDate);\r\n if Assigned(FPrinter.OnUpdateColTitle) then\r\n FPrinter.OnUpdateColTitle(FPrinter, Self, NewTitle);\r\n Title := NewTitle;\r\n end;\r\nend;\r\n}\r\n\r\nfunction TJvTFDaysCol.GetFirstAppt: TJvTFAppt;\r\nvar\r\n ApptList: TStringList;\r\nbegin\r\n Result := nil;\r\n ApptList := TStringList.Create;\r\n try\r\n FMap.GetAppts(0, ColCollection.ApptGrid.RowCount - 1, ApptList);\r\n if ApptList.Count > 0 then\r\n Result := TJvTFAppt(ApptList.Objects[0]);\r\n finally\r\n ApptList.Free;\r\n end;\r\nend;\r\n\r\nfunction TJvTFDaysCol.GetLastAppt: TJvTFAppt;\r\nvar\r\n ApptList: TStringList;\r\nbegin\r\n Result := nil;\r\n ApptList := TStringList.Create;\r\n try\r\n FMap.GetAppts(0, ColCollection.ApptGrid.RowCount - 1, ApptList);\r\n if ApptList.Count > 0 then\r\n Result := TJvTFAppt(ApptList.Objects[ApptList.Count - 1]);\r\n finally\r\n ApptList.Free;\r\n end;\r\nend;\r\n\r\nfunction TJvTFDaysCol.GetNextAppt(RefAppt: TJvTFAppt): TJvTFAppt;\r\nvar\r\n ApptList: TStringList;\r\n NextIndex: Integer;\r\nbegin\r\n if not Assigned(RefAppt) then\r\n begin\r\n Result := GetFirstAppt;\r\n Exit;\r\n end;\r\n\r\n Result := nil;\r\n ApptList := TStringList.Create;\r\n try\r\n FMap.GetAppts(0, ColCollection.ApptGrid.RowCount - 1, ApptList);\r\n if ApptList.Count > 0 then\r\n begin\r\n NextIndex := ApptList.IndexOfObject(RefAppt) + 1;\r\n // if NextIndex = 0 then RefAppt is in a different column,\r\n // so return the first appt.\r\n if (NextIndex >= 0) and (NextIndex < ApptList.Count) then\r\n Result := TJvTFAppt(ApptList.Objects[NextIndex]);\r\n end;\r\n finally\r\n ApptList.Free;\r\n end;\r\nend;\r\n\r\nfunction TJvTFDaysCol.GetPrevAppt(RefAppt: TJvTFAppt): TJvTFAppt;\r\nvar\r\n ApptList: TStringList;\r\n PrevIndex: Integer;\r\nbegin\r\n if RefAppt = nil then\r\n begin\r\n Result := GetLastAppt;\r\n Exit;\r\n end;\r\n\r\n Result := nil;\r\n ApptList := TStringList.Create;\r\n try\r\n FMap.GetAppts(0, ColCollection.ApptGrid.RowCount - 1, ApptList);\r\n if ApptList.Count > 0 then\r\n begin\r\n PrevIndex := ApptList.IndexOfObject(RefAppt) - 1;\r\n if PrevIndex > -1 then\r\n Result := TJvTFAppt(ApptList.Objects[PrevIndex])\r\n else\r\n if PrevIndex = -2 then\r\n // RefAppt is in a different column so return last appt\r\n Result := GetLastAppt;\r\n end;\r\n finally\r\n ApptList.Free;\r\n end;\r\nend;\r\n\r\nprocedure TJvTFDaysCol.SetGroupTitle(const Value: string);\r\nbegin\r\n if Value <> FGroupTitle then\r\n begin\r\n FGroupTitle := Value;\r\n if Assigned(ColCollection.ApptGrid) then\r\n ColCollection.ApptGrid.Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvTFDaysCol.UpdateTitles;\r\nvar\r\n NewTitle, NewGroupTitle, NameStr, DateStr: string;\r\n ApptGrid: TJvTFDays;\r\n FPrinter: TJvTFDaysPrinter;\r\n FromGrid: Boolean;\r\n Grouping: TJvTFDaysGrouping;\r\nbegin\r\n ApptGrid := ColCollection.ApptGrid;\r\n FPrinter := ColCollection.Printer;\r\n\r\n if not Assigned(ApptGrid) and not Assigned(FPrinter) then\r\n Exit;\r\n\r\n FromGrid := Assigned(ApptGrid);\r\n if FromGrid then\r\n Grouping := ApptGrid.Grouping\r\n else\r\n Grouping := FPrinter.Grouping;\r\n\r\n if FNullSchedDate then\r\n DateStr := ''\r\n else\r\n if FromGrid then\r\n DateStr := FormatDateTime(ApptGrid.DateFormat, SchedDate)\r\n else\r\n DateStr := FormatDateTime(FPrinter.DateFormat, SchedDate);\r\n\r\n if Assigned(Schedule) and (Schedule.SchedDisplayName <> '') then\r\n NameStr := Schedule.SchedDisplayName\r\n else\r\n NameStr := SchedName;\r\n\r\n case Grouping of\r\n grNone:\r\n begin\r\n NewGroupTitle := '';\r\n NewTitle := NameStr + ' - ' + DateStr;\r\n end;\r\n grDate:\r\n begin\r\n NewGroupTitle := DateStr;\r\n NewTitle := NameStr;\r\n end;\r\n grResource:\r\n begin\r\n NewGroupTitle := NameStr;\r\n NewTitle := DateStr;\r\n end;\r\n grCustom:\r\n begin\r\n NewGroupTitle := GroupTitle;\r\n NewTitle := NameStr + ' - ' + DateStr;\r\n end;\r\n end;\r\n\r\n if FromGrid then\r\n begin\r\n if Assigned(ApptGrid.OnUpdateColTitles) then\r\n ApptGrid.OnUpdateColTitles(ApptGrid, Self, NewGroupTitle, NewTitle)\r\n end\r\n else\r\n if Assigned(FPrinter.OnUpdateColTitles) then\r\n FPrinter.OnUpdateColTitles(FPrinter, Self, NewGroupTitle, NewTitle);\r\n\r\n GroupTitle := NewGroupTitle;\r\n Title := NewTitle;\r\nend;\r\n\r\nprocedure TJvTFDaysCol.DumpMap;\r\nbegin\r\n FMap.Dump('Map Dump (' + IntToStr(Index) + ').txt');\r\nend;\r\n\r\nfunction TJvTFDaysCol.ApptInCol(Appt: TJvTFAppt): Boolean;\r\nbegin\r\n Result := FMap.HasAppt(Appt);\r\nend;\r\n\r\nfunction TJvTFDaysCol.LocateMapCol(Appt: TJvTFAppt; MapSearchRow: Integer): Integer;\r\nbegin\r\n Result := FMap.LocateMapCol(Appt, MapSearchRow);\r\nend;\r\n\r\nfunction TJvTFDaysCol.MapColCount(Row: Integer): Integer;\r\nbegin\r\n Result := FMap.ColCount(Row);\r\nend;\r\n\r\nfunction TJvTFDaysCol.MapLocation(Col, Row: Integer): TJvTFAppt;\r\nbegin\r\n Result := FMap.Location[Row, Col];\r\nend;\r\n\r\n//=== { TJvTFDaysCols } ======================================================\r\n\r\nconstructor TJvTFDaysCols.Create(AApptGrid: TJvTFDays);\r\nbegin\r\n inherited Create(TJvTFDaysCol);\r\n FApptGrid := AApptGrid;\r\n FOldCount := 0;\r\nend;\r\n\r\nconstructor TJvTFDaysCols.CreateForPrinter(APrinter: TJvTFDaysPrinter);\r\nbegin\r\n inherited Create(TJvTFDaysCol);\r\n FPrinter := APrinter;\r\nend;\r\n\r\nfunction TJvTFDaysCols.GetItem(Index: Integer): TJvTFDaysCol;\r\nbegin\r\n Result := TJvTFDaysCol(inherited GetItem(Index));\r\nend;\r\n\r\nprocedure TJvTFDaysCols.SetItem(Index: Integer; Value: TJvTFDaysCol);\r\nbegin\r\n inherited SetItem(Index, Value);\r\nend;\r\n\r\nprocedure TJvTFDaysCols.EnsureCol(Index: Integer);\r\nbegin\r\n if (Index < 0) or (Index > Count - 1) then\r\n raise EJvTFDaysError.CreateRes(@RsEColumnIndexOutOfBounds);\r\nend;\r\n\r\nfunction TJvTFDaysCols.GetOwner: TPersistent;\r\nbegin\r\n if Assigned(FApptGrid) then\r\n Result := FApptGrid\r\n else\r\n if Assigned(FPrinter) then\r\n Result := FPrinter\r\n else\r\n Result := nil;\r\nend;\r\n\r\nprocedure TJvTFDaysCols.SizeCols;\r\nvar\r\n DataWidth, Base, MakeUp, I: Integer;\r\nbegin\r\n // DO NOT RUN IF WE'RE ALREADY IN THE SIZING PROCESS!!\r\n if SizingCols or (Count <= 0) then\r\n Exit;\r\n\r\n if Assigned(FApptGrid) then\r\n try\r\n FSizingCols := True;\r\n DataWidth := ApptGrid.GetDataWidth;\r\n\r\n Base := DataWidth div Count;\r\n\r\n if Base >= ApptGrid.MinColWidth then\r\n begin\r\n MakeUp := DataWidth - (Base * Count);\r\n for I := 0 to MakeUp - 1 do\r\n Items[I].Width := Base + 1;\r\n for I := MakeUp to Count - 1 do\r\n Items[I].Width := Base;\r\n end\r\n finally\r\n FSizingCols := False;\r\n end\r\n else\r\n begin\r\n // sizing for printer\r\n end;\r\nend;\r\n\r\nprocedure TJvTFDaysCols.Update(Item: TCollectionItem);\r\nbegin\r\n{*******************************************************************}\r\n{** DO NOT PUT ANY CALLS TO SHOWMESSAGE IN THIS ROUTINE!!!! *******}\r\n{** IT WILL BLOW UP WHEN REMOVING COLS AT DESIGN TIME!!!! *******}\r\n{*******************************************************************}\r\n\r\n // Exit if owner is printer\r\n if not Assigned(ApptGrid) or (csLoading in ApptGrid.ComponentState) then\r\n Exit;\r\n\r\n try\r\n FUpdating := True;\r\n\r\n ApptGrid.ClearSelection;\r\n\r\n if Count > FOldCount then // we're adding a col\r\n try\r\n FAddingCol := True;\r\n\r\n // if we're adding the first col then set left col to 0.\r\n if FOldCount = 0 then\r\n ApptGrid.LeftCol := 0;\r\n\r\n if ApptGrid.AutoSizeCols then\r\n begin\r\n // default col width to grid's min col width\r\n Items[Count - 1].Width := ApptGrid.MinColWidth;\r\n\r\n if not (vsbHorz in ApptGrid.VisibleScrollBars) then\r\n // run the CheckSBVis routine\r\n if not ApptGrid.CheckSBVis then\r\n // if CheckSBVis didn't resize the cols then recheck\r\n // the visibility of the horz scroll bar. if still not\r\n // visible, then size the cols.\r\n if not (vsbHorz in ApptGrid.VisibleScrollBars) then\r\n SizeCols;\r\n end\r\n else\r\n Items[Count - 1].Width := ApptGrid.DefColWidth;\r\n finally\r\n FAddingCol := False;\r\n end\r\n else\r\n if Count < FOldCount then // we're removing a col\r\n begin\r\n if ApptGrid.FocusedCol >= Count then\r\n ApptGrid.FocusedCol := Count - 1;\r\n\r\n if ApptGrid.SelStart.X >= Count then\r\n ApptGrid.SelStart := Point(Count - 1, ApptGrid.SelStart.Y);\r\n\r\n if ApptGrid.LeftCol >= Count then\r\n ApptGrid.LeftCol := Count - 1;\r\n\r\n if ApptGrid.AutoSizeCols then\r\n begin\r\n if vsbHorz in ApptGrid.VisibleScrollBars then\r\n begin\r\n // run the CheckSBVis routine\r\n if not ApptGrid.CheckSBVis then\r\n // if CheckSBVis didn't resize the cols then recheck\r\n // the visibility of the horz scroll bar. if still not\r\n // visible, then size the cols.\r\n if not (vsbHorz in ApptGrid.VisibleScrollBars) then\r\n SizeCols;\r\n end\r\n else\r\n SizeCols;\r\n end\r\n else\r\n ApptGrid.CheckSBVis;\r\n end;\r\n\r\n finally\r\n FUpdating := False;\r\n FOldCount := Count;\r\n FApptGrid.Invalidate;\r\n end;\r\nend;\r\n\r\nfunction TJvTFDaysCols.Add: TJvTFDaysCol;\r\nbegin\r\n Result := TJvTFDaysCol(inherited Add);\r\nend;\r\n\r\nprocedure TJvTFDaysCols.EnsureMinColWidth;\r\nvar\r\n I, MCW: Integer;\r\nbegin\r\n if Assigned(ApptGrid) then\r\n MCW := ApptGrid.MinColWidth\r\n else\r\n if Assigned(FPrinter) then\r\n MCW := FPrinter.MinColWidth\r\n else\r\n Exit;\r\n\r\n for I := 0 to Count - 1 do\r\n if Items[I].Width < MCW then\r\n Items[I].Width := MCW;\r\nend;\r\n\r\nprocedure TJvTFDaysCols.EnsureMaxColWidth;\r\nvar\r\n I: Integer;\r\n DataW: Integer;\r\nbegin\r\n if not Assigned(ApptGrid) or not (agoEnforceMaxColWidth in ApptGrid.Options) then\r\n Exit;\r\n\r\n DataW := ApptGrid.GetDataWidth;\r\n for I := 0 to Count - 1 do\r\n if Items[I].Width > DataW then\r\n Items[I].Width := DataW;\r\nend;\r\n\r\nprocedure TJvTFDaysCols.ResizeCols;\r\nbegin\r\n SizeCols;\r\nend;\r\n\r\nprocedure TJvTFDaysCols.MoveCol(SourceIndex, TargetIndex: Integer);\r\nvar\r\n SelID: Integer;\r\nbegin\r\n if SourceIndex <> TargetIndex then\r\n begin\r\n SelID := -1;\r\n EnsureCol(SourceIndex);\r\n EnsureCol(TargetIndex);\r\n\r\n if Assigned(ApptGrid) and (ApptGrid.FocusedCol > -1) then\r\n SelID := Items[ApptGrid.FocusedCol].ID;\r\n\r\n Items[SourceIndex].Index := TargetIndex;\r\n\r\n if Assigned(ApptGrid) and (ApptGrid.FocusedCol > -1) then\r\n ApptGrid.FocusedCol := FindItemID(SelID).Index;\r\n\r\n // sychronize the CompName list\r\n if Assigned(ApptGrid) and\r\n (ApptGrid.Template.ActiveTemplate = agtComparative) then\r\n begin\r\n FUpdating := True;\r\n try\r\n ApptGrid.Template.CompNames.Move(SourceIndex, TargetIndex);\r\n finally\r\n FUpdating := False;\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvTFDaysCols.Assign(Source: TPersistent);\r\nvar\r\n I: Integer;\r\nbegin\r\n if Source is TJvTFDaysCols then\r\n begin\r\n BeginUpdate;\r\n try\r\n Clear;\r\n for I := 0 to TJvTFDaysCols(Source).Count - 1 do\r\n Add.Assign(TJvTFDaysCols(Source).Items[I]);\r\n finally\r\n EndUpdate;\r\n end;\r\n end\r\n else\r\n inherited Assign(Source);\r\nend;\r\n\r\nprocedure TJvTFDaysCols.UpdateTitles;\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := 0 to Count - 1 do\r\n //Items[I].UpdateTitle;\r\n Items[I].UpdateTitles;\r\nend;\r\n\r\n//=== { TJvTFDaysFancyRowHdrAttr } ===========================================\r\n\r\nconstructor TJvTFDaysFancyRowHdrAttr.Create(AOwner: TJvTFDays);\r\nbegin\r\n inherited Create;\r\n FGrid := AOwner;\r\n\r\n FTickColor := clGray;\r\n FColor := clBtnFace;\r\n\r\n FMinorFont := TFont.Create;\r\n if Assigned(FGrid) then\r\n FMinorFont.Assign(FGrid.Font);\r\n\r\n FMajorFont := TFont.Create;\r\n if Assigned(FGrid) then\r\n FMajorFont.Assign(FGrid.Font);\r\n FMajorFont.Size := FMajorFont.Size * 2;\r\n\r\n FMinorFont.OnChange := FontChange;\r\n FMajorFont.OnChange := FontChange;\r\n FOnlyShow00Minutes := True;\r\nend;\r\n\r\ndestructor TJvTFDaysFancyRowHdrAttr.Destroy;\r\nbegin\r\n FMinorFont.OnChange := nil;\r\n FMajorFont.OnChange := nil;\r\n FMinorFont.Free;\r\n FMajorFont.Free;\r\n\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvTFDaysFancyRowHdrAttr.SetColor(Value: TColor);\r\nbegin\r\n if Value <> FColor then\r\n begin\r\n FColor := Value;\r\n Change;\r\n end;\r\nend;\r\n\r\nprocedure TJvTFDaysFancyRowHdrAttr.SetHr2400(Value: Boolean);\r\nbegin\r\n if Value <> FHr2400 then\r\n begin\r\n FHr2400 := Value;\r\n Change;\r\n end;\r\nend;\r\n\r\nprocedure TJvTFDaysFancyRowHdrAttr.SetMinorFont(Value: TFont);\r\nbegin\r\n FMinorFont.Assign(Value);\r\nend;\r\n\r\nprocedure TJvTFDaysFancyRowHdrAttr.SetMajorFont(Value: TFont);\r\nbegin\r\n FMajorFont.Assign(Value);\r\nend;\r\n\r\nprocedure TJvTFDaysFancyRowHdrAttr.SetTickColor(Value: TColor);\r\nbegin\r\n if Value <> FTickColor then\r\n begin\r\n FTickColor := Value;\r\n Change;\r\n end;\r\nend;\r\n\r\nprocedure TJvTFDaysFancyRowHdrAttr.SetOnlyShow00Minutes(Value: Boolean);\r\nbegin\r\n if Value <> FOnlyShow00Minutes then\r\n begin\r\n FOnlyShow00Minutes := Value;\r\n Change;\r\n end;\r\nend;\r\n\r\nprocedure TJvTFDaysFancyRowHdrAttr.Change;\r\nbegin\r\n if Assigned(FGrid) then\r\n FGrid.Invalidate;\r\nend;\r\n\r\nprocedure TJvTFDaysFancyRowHdrAttr.FontChange;\r\nbegin\r\n Change;\r\nend;\r\n\r\nprocedure TJvTFDaysFancyRowHdrAttr.Assign(Source: TPersistent);\r\nbegin\r\n if Source is TJvTFDaysFancyRowHdrAttr then\r\n begin\r\n FTickColor := TJvTFDaysFancyRowHdrAttr(Source).TickColor;\r\n FMinorFont.OnChange := nil;\r\n FMajorFont.OnChange := nil;\r\n FMinorFont.Assign(TJvTFDaysFancyRowHdrAttr(Source).MinorFont);\r\n FMajorFont.Assign(TJvTFDaysFancyRowHdrAttr(Source).MajorFont);\r\n FMinorFont.OnChange := FontChange;\r\n FMajorFont.OnChange := FontChange;\r\n FHr2400 := TJvTFDaysFancyRowHdrAttr(Source).Hr2400;\r\n FColor := TJvTFDaysFancyRowHdrAttr(Source).Color;\r\n Change;\r\n end\r\n else\r\n inherited Assign(Source);\r\nend;\r\n\r\n//=== { TJvTFDaysHdrAttr } ===================================================\r\n\r\nconstructor TJvTFDaysHdrAttr.Create(AOwner: TJvTFDays);\r\nbegin\r\n inherited Create;\r\n FApptGrid := AOwner;\r\n FFont := TFont.Create;\r\n if Assigned(FApptGrid) then\r\n begin\r\n FFont.Assign(FApptGrid.Font);\r\n FParentFont := True;\r\n end;\r\n FFont.OnChange := FontChange;\r\n\r\n FColor := clBtnFace;\r\n FFrame3D := True;\r\n {$IFDEF Jv_TIMEBLOCKS}\r\n // ok\r\n FFrameColor := clBlack;\r\n {$ENDIF Jv_TIMEBLOCKS}\r\nend;\r\n\r\ndestructor TJvTFDaysHdrAttr.Destroy;\r\nbegin\r\n FFont.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvTFDaysHdrAttr.SetColor(Value: TColor);\r\nbegin\r\n if Value <> FColor then\r\n begin\r\n FColor := Value;\r\n Change;\r\n end;\r\nend;\r\n\r\nprocedure TJvTFDaysHdrAttr.SetFont(Value: TFont);\r\nbegin\r\n if Value <> FFont then\r\n begin\r\n FFont.Assign(Value);\r\n FFont.OnChange := FontChange;\r\n if Assigned(FApptGrid) then\r\n ParentFont := Value = FApptGrid.Font;\r\n Change;\r\n end;\r\nend;\r\n\r\nprocedure TJvTFDaysHdrAttr.SetParentFont(Value: Boolean);\r\nbegin\r\n if Value and Assigned(FApptGrid) then\r\n Font.Assign(FApptGrid.Font);\r\n FParentFont := Value;\r\nend;\r\n\r\nprocedure TJvTFDaysHdrAttr.SetFrame3D(Value: Boolean);\r\nbegin\r\n if Value <> FFrame3D then\r\n begin\r\n FFrame3D := Value;\r\n Change;\r\n end;\r\nend;\r\n\r\n{$IFDEF Jv_TIMEBLOCKS}\r\n// ok\r\n\r\nprocedure TJvTFDaysHdrAttr.SetFrameColor(Value: TColor);\r\nbegin\r\n if Value <> FFrameColor then\r\n begin\r\n FFrameColor := Value;\r\n Change;\r\n end;\r\nend;\r\n\r\n// ok\r\n\r\nprocedure TJvTFDaysHdrAttr.SetTitleRotation(Value: Integer);\r\nbegin\r\n if Value <> FTitleRotation then\r\n begin\r\n FTitleRotation := Value;\r\n Change;\r\n end;\r\nend;\r\n\r\n{$ENDIF Jv_TIMEBLOCKS}\r\n\r\nprocedure TJvTFDaysHdrAttr.Change;\r\nbegin\r\n if Assigned(FApptGrid) then\r\n FApptGrid.Invalidate;\r\nend;\r\n\r\nprocedure TJvTFDaysHdrAttr.FontChange(Sender: TObject);\r\nbegin\r\n ParentFont := False;\r\n Change;\r\nend;\r\n\r\nprocedure TJvTFDaysHdrAttr.Assign(Source: TPersistent);\r\nbegin\r\n if Source is TJvTFDaysHdrAttr then\r\n try\r\n FParentFont := False;\r\n Frame3D := TJvTFDaysHdrAttr(Source).Frame3D;\r\n FColor := TJvTFDaysHdrAttr(Source).Color;\r\n Font.Assign(TJvTFDaysHdrAttr(Source).Font);\r\n Font.OnChange := FontChange;\r\n ParentFont := TJvTFDaysHdrAttr(Source).ParentFont;\r\n {$IFDEF Jv_TIMEBLOCKS}\r\n // ok\r\n FFrameColor := TJvTFDaysHdrAttr(Source).FrameColor;\r\n // ok\r\n FTitleRotation := TJvTFDaysHdrAttr(Source).TitleRotation;\r\n {$ENDIF Jv_TIMEBLOCKS}\r\n finally\r\n Change;\r\n end\r\n else\r\n inherited Assign(Source);\r\nend;\r\n\r\nprocedure TJvTFDaysHdrAttr.ParentFontChanged;\r\nbegin\r\n if ParentFont and Assigned(FApptGrid) then\r\n begin\r\n // Disconnect Font.OnChange\r\n FFont.OnChange := nil;\r\n // Assign the parent font to FFont\r\n FFont.Assign(FApptGrid.Font);\r\n // Reconnect Font.OnChange\r\n FFont.OnChange := FontChange;\r\n end;\r\nend;\r\n\r\n//=== { TJvTFDaysApptBar } ===================================================\r\n\r\nconstructor TJvTFDaysApptBar.Create(AApptGrid: TJvTFDays);\r\nbegin\r\n inherited Create;\r\n FApptGrid := AApptGrid;\r\n FColor := clBlue;\r\n FWidth := 5;\r\n FVisible := True;\r\n FTimeStampStyle := tssBlock;\r\n FTimeStampColor := clBlue;\r\nend;\r\n\r\nprocedure TJvTFDaysApptBar.SetColor(Value: TColor);\r\nbegin\r\n if FColor <> Value then\r\n begin\r\n FColor := Value;\r\n Change;\r\n end;\r\nend;\r\n\r\nprocedure TJvTFDaysApptBar.SetVisible(Value: Boolean);\r\nbegin\r\n if FVisible <> Value then\r\n begin\r\n FVisible := Value;\r\n Change;\r\n end;\r\nend;\r\n\r\nprocedure TJvTFDaysApptBar.SetWidth(Value: Integer);\r\nbegin\r\n if Value < 0 then\r\n Value := 0;\r\n\r\n if FWidth <> Value then\r\n begin\r\n FWidth := Value;\r\n Change;\r\n end;\r\nend;\r\n\r\nprocedure TJvTFDaysApptBar.Change;\r\nbegin\r\n if Assigned(FApptGrid) then\r\n FApptGrid.Invalidate;\r\nend;\r\n\r\nprocedure TJvTFDaysApptBar.Assign(Source: TPersistent);\r\nbegin\r\n if Source is TJvTFDaysApptBar then\r\n begin\r\n FColor := TJvTFDaysApptBar(Source).Color;\r\n FVisible := TJvTFDaysApptBar(Source).Visible;\r\n FWidth := TJvTFDaysApptBar(Source).Width;\r\n FTimeStampStyle := TJvTFDaysApptBar(Source).TimeStampStyle;\r\n FTimeStampColor := TJvTFDaysApptBar(Source).TimeStampColor;\r\n Change;\r\n end\r\n else\r\n inherited Assign(Source);\r\nend;\r\n\r\nprocedure TJvTFDaysApptBar.SetTimeStampColor(Value: TColor);\r\nbegin\r\n if FTimeStampColor <> Value then\r\n begin\r\n FTimeStampColor := Value;\r\n Change;\r\n end;\r\nend;\r\n\r\nprocedure TJvTFDaysApptBar.SetTFTimeStampStyle(Value: TJvTFTimeStampStyle);\r\nbegin\r\n if FTimeStampStyle <> Value then\r\n begin\r\n FTimeStampStyle := Value;\r\n Change;\r\n end;\r\nend;\r\n\r\n//=== { TJvTFDaysApptAttr } ==================================================\r\n\r\nconstructor TJvTFDaysApptAttr.Create(AApptGrid: TJvTFDays);\r\nbegin\r\n inherited Create;\r\n FApptGrid := AApptGrid;\r\n\r\n FFont := TFont.Create;\r\n if Assigned(FApptGrid) then\r\n begin\r\n FFont.Assign(FApptGrid.Font);\r\n FParentFont := True;\r\n end\r\n else\r\n FParentFont := False;\r\n\r\n FFont.OnChange := FontChange;\r\n\r\n FFrameWidth := 1;\r\n FFrameColor := clBlack;\r\n FColor := clWhite;\r\nend;\r\n\r\ndestructor TJvTFDaysApptAttr.Destroy;\r\nbegin\r\n FFont.OnChange := nil;\r\n FFont.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvTFDaysApptAttr.SetColor(Value: TColor);\r\nbegin\r\n if Value <> FColor then\r\n begin\r\n FColor := Value;\r\n Change;\r\n end;\r\nend;\r\n\r\nprocedure TJvTFDaysApptAttr.SetFont(Value: TFont);\r\nbegin\r\n if Value <> FFont then\r\n begin\r\n FFont.Assign(Value);\r\n FFont.OnChange := FontChange;\r\n if Assigned(FApptGrid) then\r\n ParentFont := Value = FApptGrid.Font;\r\n Change;\r\n end;\r\nend;\r\n\r\nprocedure TJvTFDaysApptAttr.SetParentFont(Value: Boolean);\r\nbegin\r\n if Assigned(FApptGrid) and Value then\r\n Font.Assign(FApptGrid.Font);\r\n FParentFont := Value;\r\nend;\r\n\r\nprocedure TJvTFDaysApptAttr.SetFrameColor(Value: TColor);\r\nbegin\r\n if Value <> FFrameColor then\r\n begin\r\n FFrameColor := Value;\r\n Change;\r\n end;\r\nend;\r\n\r\nprocedure TJvTFDaysApptAttr.SetFrameWidth(Value: Integer);\r\nbegin\r\n if Value <> FFrameWidth then\r\n begin\r\n FFrameWidth := Value;\r\n Change;\r\n end;\r\nend;\r\n\r\nprocedure TJvTFDaysApptAttr.Change;\r\nbegin\r\n if Assigned(FApptGrid) then\r\n FApptGrid.Invalidate;\r\nend;\r\n\r\nprocedure TJvTFDaysApptAttr.FontChange(Sender: TObject);\r\nbegin\r\n ParentFont := False;\r\n Change;\r\nend;\r\n\r\nprocedure TJvTFDaysApptAttr.Assign(Source: TPersistent);\r\nbegin\r\n if Source is TJvTFDaysApptAttr then\r\n try\r\n FParentFont := False;\r\n FFrameWidth := TJvTFDaysApptAttr(Source).FrameWidth;\r\n FFrameColor := TJvTFDaysApptAttr(Source).FrameColor;\r\n FColor := TJvTFDaysApptAttr(Source).Color;\r\n Font.Assign(TJvTFDaysApptAttr(Source).Font);\r\n ParentFont := TJvTFDaysApptAttr(Source).ParentFont;\r\n finally\r\n Change;\r\n end\r\n else\r\n inherited Assign(Source);\r\nend;\r\n\r\nprocedure TJvTFDaysApptAttr.ParentFontChanged;\r\nbegin\r\n if ParentFont and Assigned(FApptGrid) then\r\n begin\r\n FFont.OnChange := nil;\r\n FFont.Assign(FApptGrid.Font);\r\n FFont.OnChange := FontChange;\r\n end;\r\nend;\r\n\r\n//=== { TJvTFSelCellAttr } ===================================================\r\n\r\nconstructor TJvTFSelCellAttr.Create(AApptGrid: TJvTFDays);\r\nbegin\r\n inherited Create;\r\n\r\n FApptGrid := AApptGrid;\r\n FColor := clNavy;\r\n FStyle := scsSolid;\r\n FFrameWidth := 2;\r\nend;\r\n\r\nprocedure TJvTFSelCellAttr.SetColor(Value: TColor);\r\nbegin\r\n if Value <> FColor then\r\n begin\r\n FColor := Value;\r\n Change;\r\n end;\r\nend;\r\n\r\nprocedure TJvTFSelCellAttr.SetFrameWidth(Value: Integer);\r\nbegin\r\n if Value <> FFrameWidth then\r\n begin\r\n FFrameWidth := Value;\r\n Change;\r\n end;\r\nend;\r\n\r\nprocedure TJvTFSelCellAttr.SetStyle(Value: TJvTFSelCellStyle);\r\nbegin\r\n if Value <> FStyle then\r\n begin\r\n FStyle := Value;\r\n Change;\r\n end;\r\nend;\r\n\r\nprocedure TJvTFSelCellAttr.Change;\r\nbegin\r\n if Assigned(FApptGrid) then\r\n FApptGrid.Invalidate;\r\nend;\r\n\r\nprocedure TJvTFSelCellAttr.Assign(Source: TPersistent);\r\nbegin\r\n if Source is TJvTFSelCellAttr then\r\n begin\r\n FColor := TJvTFSelCellAttr(Source).Color;\r\n FStyle := TJvTFSelCellAttr(Source).Style;\r\n FFrameWidth := TJvTFSelCellAttr(Source).FrameWidth;\r\n Change;\r\n end\r\n else\r\n inherited Assign(Source);\r\nend;\r\n\r\n//=== { TJvTFDaysGrabHandles } ===============================================\r\n\r\nconstructor TJvTFDaysGrabHandles.Create(AApptGrid: TJvTFDays);\r\nbegin\r\n inherited Create;\r\n FApptGrid := AApptGrid;\r\n FStyle := gsFlat;\r\n FColor := clBlue;\r\n FHeight := 6;\r\nend;\r\n\r\nprocedure TJvTFDaysGrabHandles.SetColor(Value: TColor);\r\nbegin\r\n if Value <> FColor then\r\n begin\r\n FColor := Value;\r\n Change;\r\n end;\r\nend;\r\n\r\nprocedure TJvTFDaysGrabHandles.SetHeight(Value: Integer);\r\nbegin\r\n if Value < 1 then\r\n Value := 1;\r\n if Value <> FHeight then\r\n begin\r\n FHeight := Value;\r\n Change;\r\n end;\r\nend;\r\n\r\nprocedure TJvTFDaysGrabHandles.SetStyle(Value: TJvTFGrabStyle);\r\nbegin\r\n if Value <> FStyle then\r\n begin\r\n FStyle := Value;\r\n if Style = gs3D then\r\n FHeight := 6;\r\n Change;\r\n end;\r\nend;\r\n\r\nprocedure TJvTFDaysGrabHandles.Change;\r\nbegin\r\n if Assigned(FApptGrid) then\r\n FApptGrid.Invalidate;\r\nend;\r\n\r\nprocedure TJvTFDaysGrabHandles.Assign(Source: TPersistent);\r\nbegin\r\n if Source is TJvTFDaysGrabHandles then\r\n begin\r\n FHeight := TJvTFDaysGrabHandles(Source).Height;\r\n FColor := TJvTFDaysGrabHandles(Source).Color;\r\n FStyle := TJvTFDaysGrabHandles(Source).Style;\r\n Change;\r\n end\r\n else\r\n inherited Assign(Source);\r\nend;\r\n\r\n//=== { TJvTFDays } ==========================================================\r\n\r\nconstructor TJvTFDays.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n ControlStyle := ControlStyle +\r\n [csOpaque, csCaptureMouse, csClickEvents, csDoubleClicks];\r\n\r\n Height := 300;\r\n Width := 400;\r\n FSaveFocCol := -1;\r\n\r\n //set property defaults\r\n FBorderStyle := bsSingle;\r\n FColHdrHeight := 30;\r\n FGroupHdrHeight := 25;\r\n FRowHdrWidth := 50;\r\n FRowHeight := 19;\r\n FGranularity := 30;\r\n FTopRow := 0;\r\n FFocusedRow := -1;\r\n FMinColWidth := AbsMinColWidth;\r\n FLeftCol := -1;\r\n FFocusedCol := -1;\r\n FDefColWidth := 100;\r\n FVisibleScrollBars := [];\r\n FAutoSizeCols := True;\r\n FMinRowHeight := 12;\r\n ParentColor := False;\r\n Color := clSilver;\r\n FOptions := [agoSizeCols, agoSizeRows, agoSizeColHdr, agoSizeRowHdr,\r\n agoSizeAppt, agoMoveAppt, agoEditing, agoShowPics,\r\n agoShowText, agoShowApptHints, agoQuickEntry, agoShowSelHint];\r\n FColTitleStyle := ctsSingleEllipsis;\r\n FRowHdrType := rhFancy;\r\n FSelStart := Point(-1, -1);\r\n FSelEnd := FSelStart;\r\n FApptBuffer := 5;\r\n FFocusedCol := -1;\r\n FFocusedRow := -1;\r\n FGridLineColor := clGray;\r\n FDitheredBackground := True;\r\n\r\n {$IFDEF Jv_TIMEBLOCKS}\r\n // all ok\r\n FWeekend := [dowSunday, dowSaturday];\r\n FWeekendColor := clSilver;\r\n FWeekendFillPic := TBitmap.Create;\r\n FWeekendFillPic.Height := 16;\r\n FWeekendFillPic.Width := 16;\r\n UpdateWeekendFillPic;\r\n {$ENDIF Jv_TIMEBLOCKS}\r\n\r\n // Create internal objects\r\n FVScrollBar := TJvTFDaysScrollBar.Create(Self);\r\n with FVScrollBar do\r\n begin\r\n Kind := sbVertical;\r\n TabStop := False;\r\n Anchors := [];\r\n Parent := Self;\r\n Visible := False;\r\n OnScroll := ScrollBarScroll;\r\n end;\r\n\r\n FHScrollBar := TJvTFDaysScrollBar.Create(Self);\r\n with FHScrollBar do\r\n begin\r\n Kind := sbHorizontal;\r\n TabStop := False;\r\n Anchors := [];\r\n Parent := Self;\r\n Visible := False;\r\n OnScroll := ScrollBarScroll;\r\n end;\r\n\r\n FHdrAttr := TJvTFDaysHdrAttr.Create(Self);\r\n FHdrAttr.Color := clBtnFace;\r\n\r\n FSelHdrAttr := TJvTFDaysHdrAttr.Create(Self);\r\n with FSelHdrAttr do\r\n begin\r\n Color := clBtnFace;\r\n Font.Color := clBlack;\r\n end;\r\n\r\n FGroupHdrAttr := TJvTFDaysHdrAttr.Create(Self);\r\n FGroupHdrAttr.Color := clBtnFace;\r\n\r\n FSelGroupHdrAttr := TJvTFDaysHdrAttr.Create(Self);\r\n with FSelGroupHdrAttr do\r\n begin\r\n Color := clBtnFace;\r\n Font.Color := clBlack;\r\n end;\r\n\r\n FFancyRowHdrAttr := TJvTFDaysFancyRowHdrAttr.Create(Self);\r\n FSelFancyRowHdrAttr := TJvTFDaysFancyRowHdrAttr.Create(Self);\r\n with FSelFancyRowHdrAttr do\r\n begin\r\n TickColor := clBlack;\r\n MinorFont.Color := clBlack;\r\n MajorFont.Color := clBlack;\r\n end;\r\n\r\n FSelCellAttr := TJvTFSelCellAttr.Create(Self);\r\n\r\n FApptBar := TJvTFDaysApptBar.Create(Self);\r\n\r\n FCols := TJvTFDaysCols.Create(Self);\r\n\r\n {$IFDEF Jv_TIMEBLOCKS}\r\n // ok\r\n FTimeBlocks := TJvTFDaysTimeBlocks.Create(Self);\r\n FTimeBlockProps := TJvTFDaysBlockProps.Create(Self);\r\n {$ENDIF Jv_TIMEBLOCKS}\r\n\r\n FEditor := TJvTFInPlaceApptEditor.Create(Self);\r\n with FEditor do\r\n begin\r\n Visible := False;\r\n Parent := Self;\r\n end;\r\n\r\n FThresholds := TJvTFDaysThresholds.Create(Self);\r\n FPrimeTime := TJvTFDaysPrimeTime.Create(Self);\r\n\r\n FApptAttr := TJvTFDaysApptAttr.Create(Self);\r\n FSelApptAttr := TJvTFDaysApptAttr.Create(Self);\r\n\r\n FTemplate := TJvTFDaysTemplate.Create(Self);\r\n\r\n FGrabHandles := TJvTFDaysGrabHandles.Create(Self);\r\n\r\n FHintProps := TJvTFHintProps.Create(Self);\r\n //FHint := TJvTFHint.Create(Self);\r\n FHint := GetTFHintClass.Create(Self);\r\n FHint.RefProps := FHintProps;\r\n PaintBuffer := TBitmap.Create;\r\n FShowFocus := True;\r\nend;\r\n\r\ndestructor TJvTFDays.Destroy;\r\nbegin\r\n FVScrollBar.Free;\r\n FHScrollBar.Free;\r\n FHdrAttr.Free;\r\n FSelHdrAttr.Free;\r\n FGroupHdrAttr.Free;\r\n FSelGroupHdrAttr.Free;\r\n\r\n FFancyRowHdrAttr.Free;\r\n FSelFancyRowHdrAttr.Free;\r\n FSelCellAttr.Free;\r\n FApptBar.Free;\r\n FPrimeTime.Free;\r\n\r\n {$IFDEF Jv_TIMEBLOCKS}\r\n // all ok\r\n FTimeBlocks.Free;\r\n FTimeBlockProps.Free;\r\n FWeekendFillPic.Free;\r\n {$ENDIF Jv_TIMEBLOCKS}\r\n\r\n FEditor.Free;\r\n FThresholds.Free;\r\n FApptAttr.Free;\r\n FSelApptAttr.Free;\r\n FHint.Free;\r\n FHintProps.Free;\r\n FTemplate.Free;\r\n FGrabHandles.Free;\r\n PaintBuffer.Free;\r\n inherited Destroy;\r\n\r\n // This MUST be done after the inherited Destroy as it will set the Manager\r\n // property to nil, thus triggering RelSchedNotification if ScheduleCount\r\n // is still not 0. And in that very method, there is a test on Cols.Count.\r\n // Hence, if FCols was to be freed before inherited, RelSchedNotification\r\n // would try to access a freed object, leading to potential AVs.\r\n FCols.Free;\r\nend;\r\n\r\n\r\n\r\nprocedure TJvTFDays.CMCtl3DChanged(var Msg: TMessage);\r\nbegin\r\n if FBorderStyle = bsSingle then\r\n RecreateWnd;\r\n inherited;\r\nend;\r\n\r\nprocedure TJvTFDays.WMGetDlgCode(var Msg: TWMGetDlgCode);\r\nbegin\r\n Msg.Result := DLGC_WANTALLKEYS or DLGC_WANTARROWS;\r\nend;\r\n\r\n\r\n\r\nprocedure TJvTFDays.SetBorderStyle(Value: TBorderStyle);\r\nbegin\r\n if FBorderStyle <> Value then\r\n begin\r\n FBorderStyle := Value;\r\n RecreateWnd;\r\n end;\r\nend;\r\n\r\nprocedure TJvTFDays.SetTFVisibleScrollBars(Value: TJvTFVisibleScrollBars);\r\nbegin\r\n if Value <> FVisibleScrollBars then\r\n begin\r\n FVisibleScrollBars := Value;\r\n AlignScrollBars;\r\n FVScrollBar.Visible := vsbVert in FVisibleScrollBars;\r\n FHScrollBar.Visible := vsbHorz in FVisibleScrollBars;\r\n end;\r\nend;\r\n\r\nprocedure TJvTFDays.AlignScrollBars;\r\nbegin\r\n // DO NOT INVALIDATE GRID IN THIS METHOD\r\n\r\n FVScrollBar.Left := ClientWidth - FVScrollBar.Width;\r\n FHScrollBar.Top := ClientHeight - FHScrollBar.Height;\r\n\r\n with FVScrollBar do\r\n begin\r\n //group Top := ColHdrHeight;\r\n Top := CalcGroupColHdrsHeight;\r\n if vsbHorz in VisibleScrollBars then\r\n Height := FHScrollBar.Top - Top\r\n else\r\n Height := Self.ClientHeight - Top;\r\n end;\r\n\r\n with FHScrollBar do\r\n begin\r\n {$IFDEF Jv_TIMEBLOCKS}\r\n // ok\r\n Left := CalcBlockRowHdrsWidth;\r\n {$ELSE}\r\n // remove\r\n //Left := RowHdrWidth;\r\n {$ENDIF Jv_TIMEBLOCKS}\r\n\r\n if vsbVert in VisibleScrollBars then\r\n Width := FVScrollBar.Left - Left\r\n else\r\n Width := Self.ClientWidth - Left;\r\n end;\r\nend;\r\n\r\nfunction TJvTFDays.CheckSBVis: Boolean;\r\nvar\r\n NewSBVis: TJvTFVisibleScrollBars;\r\n I, TempWidth, NewDataHeight, NewDataWidth: Integer;\r\n DoColResize: Boolean;\r\n\r\n function CalcDataRect(ForScrollBars: TJvTFVisibleScrollBars): TRect;\r\n begin\r\n Result := GetClientRect;\r\n {$IFDEF Jv_TIMEBLOCKS}\r\n // ok\r\n Inc(Result.Left, CalcBlockRowHdrsWidth);\r\n {$ELSE}\r\n // remove\r\n //Inc(Result.Left, RowHdrWidth);\r\n {$ENDIF Jv_TIMEBLOCKS}\r\n\r\n //group Inc(Result.Top, ColHdrHeight);\r\n Inc(Result.Top, CalcGroupColHdrsHeight);\r\n if vsbHorz in ForScrollBars then\r\n Dec(Result.Bottom, FHScrollBar.Height);\r\n if vsbVert in ForScrollBars then\r\n Dec(Result.Right, FVScrollBar.Width);\r\n end;\r\n\r\n function CalcDataWidth(ForScrollBars: TJvTFVisibleScrollBars): Integer;\r\n begin\r\n Result := RectWidth(CalcDataRect(ForScrollBars));\r\n end;\r\n\r\n function CalcDataHeight(ForScrollBars: TJvTFVisibleScrollBars): Integer;\r\n begin\r\n Result := RectHeight(CalcDataRect(ForScrollBars));\r\n end;\r\n\r\nbegin\r\n NewSBVis := [];\r\n\r\n // First check vert scroll bar, assuming horz is not needed\r\n NewDataHeight := CalcDataHeight(NewSBVis);\r\n if (RowCount * RowHeight > NewDataHeight) or (TopRow > 0) then\r\n Include(NewSBVis, vsbVert);\r\n\r\n if Cols.Count > 0 then\r\n begin\r\n // Now check the horz scroll under the new conditions\r\n NewDataWidth := CalcDataWidth(NewSBVis);\r\n if AutoSizeCols then\r\n begin\r\n if (Cols.Count * MinColWidth > NewDataWidth) or (LeftCol > 0) then\r\n Include(NewSBVis, vsbHorz);\r\n end\r\n else\r\n begin\r\n TempWidth := 0;\r\n I := 0;\r\n while (TempWidth <= NewDataWidth) and (I < Cols.Count) do\r\n begin\r\n Inc(TempWidth, Cols[I].Width);\r\n Inc(I);\r\n end;\r\n\r\n if (TempWidth > NewDataWidth) or (LeftCol > 0) then\r\n Include(NewSBVis, vsbHorz);\r\n end;\r\n end;\r\n\r\n // if the horz scrollbar should show, we must recheck the vert scrollbar,\r\n // since the vert scrollbar was initially checked with the assumption\r\n // that the horz scrollbar was not needed.\r\n if vsbHorz in NewSBVis then\r\n begin\r\n NewDataHeight := CalcDataHeight(NewSBVis);\r\n if (RowCount * RowHeight > NewDataHeight) or (TopRow > 0) then\r\n Include(NewSBVis, vsbVert);\r\n end;\r\n\r\n // if we're autosizing the cols and the vert scrollbar has been\r\n // toggled and the horz scroll isn't visible then we need to resize\r\n // the cols. We can't call Cols.Resize until VisibleScrollBars has\r\n // been updated so just set a flag here.\r\n DoColResize := AutoSizeCols and not (vsbHorz in NewSBVis) and\r\n ((vsbVert in NewSBVis) xor (vsbVert in VisibleScrollBars));\r\n\r\n // At this point NewSBVis will correctly reflect which scrollbars need to\r\n // visible on the control.\r\n VisibleScrollBars := NewSBVis;\r\n\r\n // In order to optimize the resizing of cols when AutoSizeCols is on, this\r\n // function needs a return value specifying whether or not the cols have\r\n // been resized from within this routine. if we're not autosizing cols\r\n // it'll return false, but the result is meaningless.\r\n Result := DoColResize;\r\n\r\n // Finally, resize the cols if necessary\r\n if DoColResize then\r\n Cols.ResizeCols;\r\n\r\n CheckSBParams;\r\nend;\r\n\r\nprocedure TJvTFDays.SetOnShowHint(Value: TJvTFShowHintEvent);\r\nbegin\r\n FHint.OnShowHint := Value;\r\nend;\r\n\r\nfunction TJvTFDays.GetOnShowHint: TJvTFShowHintEvent;\r\nbegin\r\n Result := FHint.OnShowHint;\r\nend;\r\n\r\nprocedure TJvTFDays.SetGranularity(Value: Integer);\r\nvar\r\n ATime: TTime;\r\n MaxRowHeight, I: Integer;\r\nbegin\r\n if Assigned(FOnGranularityChanging) then\r\n FOnGranularityChanging(Self, Value);\r\n\r\n // Enforce minimum granularity of 1 min and max of 60 mins\r\n if Value < 1 then\r\n Value := 1\r\n else\r\n if Value > 60 then\r\n Value := 60;\r\n\r\n // Ensure that granularity is evenly divisable by an hour\r\n while 60 mod Value <> 0 do\r\n Dec(Value);\r\n\r\n // Sum of row heights cannot exceed 32767\r\n MaxRowHeight := 32767 div (60 div Value * 24);\r\n if RowHeight > MaxRowHeight then\r\n RowHeight := MaxRowHeight;\r\n\r\n if Value <> FGranularity then\r\n begin\r\n {$IFDEF Jv_TIMEBLOCKS}\r\n // ok\r\n EnsureBlockRules(Value, TimeBlockProps.BlockGran, TimeBlockProps.DayStart);\r\n {$ENDIF Jv_TIMEBLOCKS}\r\n\r\n ATime := RowToTime(TopRow);\r\n FGranularity := Value;\r\n ClearSelection;\r\n if not (csLoading in ComponentState) then\r\n begin\r\n for I := 0 to Cols.Count - 1 do\r\n Cols[I].RefreshMap;\r\n TopRow := TimeToRow(ATime);\r\n CheckSBVis;\r\n CheckSBParams;\r\n Invalidate;\r\n if Assigned(FOnGranularityChanged) then\r\n FOnGranularityChanged(Self);\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvTFDays.SetColHdrHeight(Value: Integer);\r\nbegin\r\n if Value > RectHeight(GetAdjClientRect) then\r\n Value := RectHeight(GetAdjClientRect);\r\n if Value < 1 then\r\n Value := 1;\r\n\r\n if Value <> ColHdrHeight then\r\n begin\r\n FColHdrHeight := Value;\r\n AlignScrollBars;\r\n if not (csLoading in ComponentState) then\r\n begin\r\n CheckSBVis;\r\n CheckSBParams;\r\n Invalidate;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvTFDays.SetRowHdrWidth(Value: Integer);\r\nbegin\r\n if Value > RectWidth(GetAdjClientRect) then\r\n Value := RectWidth(GetAdjClientRect);\r\n if Value < 1 then\r\n Value := 1;\r\n\r\n if Value <> FRowHdrWidth then\r\n begin\r\n FRowHdrWidth := Value;\r\n AlignScrollBars;\r\n if AutoSizeCols then\r\n begin\r\n if not CheckSBVis then\r\n if not (vsbHorz in VisibleScrollBars) then\r\n Cols.ResizeCols;\r\n end\r\n else\r\n CheckSBVis;\r\n CheckSBParams;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvTFDays.SetRowHeight(Value: Integer);\r\nvar\r\n MaxRowHeight: Integer;\r\nbegin\r\n if Value > GetDataHeight then\r\n Value := GetDataHeight;\r\n if Value < MinRowHeight then\r\n Value := MinRowHeight;\r\n if Value < 1 then\r\n Value := 1;\r\n\r\n // Sum of row heights cannot exceed 32767.\r\n MaxRowHeight := 32767 div (60 div Granularity * 24);\r\n if Value > MaxRowHeight then\r\n Value := MaxRowHeight;\r\n\r\n if Value <> FRowHeight then\r\n begin\r\n FRowHeight := Value;\r\n if not (csLoading in ComponentState) then\r\n begin\r\n CheckSBVis;\r\n CheckSBParams;\r\n Invalidate;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvTFDays.SetMinRowHeight(Value: Integer);\r\nbegin\r\n if Value < AbsMinColWidth then\r\n Value := AbsMinColWidth;\r\n\r\n if Value <> FMinRowHeight then\r\n begin\r\n FMinRowHeight := Value;\r\n if Value > RowHeight then\r\n RowHeight := Value;\r\n end;\r\nend;\r\n\r\nprocedure TJvTFDays.SetMinColWidth(Value: Integer);\r\nbegin\r\n if Value < AbsMinColWidth then\r\n Value := AbsMinColWidth;\r\n\r\n if Value <> FMinColWidth then\r\n begin\r\n FMinColWidth := Value;\r\n if not (csLoading in ComponentState) then\r\n Cols.EnsureMinColWidth;\r\n end;\r\nend;\r\n\r\nprocedure TJvTFDays.SetAutoSizeCols(Value: Boolean);\r\nbegin\r\n if Value <> FAutoSizeCols then\r\n begin\r\n FAutoSizeCols := Value;\r\n if FAutoSizeCols then\r\n if not CheckSBVis then\r\n Cols.ResizeCols;\r\n end;\r\nend;\r\n\r\nprocedure TJvTFDays.SetTFColTitleStyle(Value: TJvTFColTitleStyle);\r\nbegin\r\n if Value <> FColTitleStyle then\r\n begin\r\n FColTitleStyle := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvTFDays.SetCols(Value: TJvTFDaysCols);\r\nbegin\r\n FCols.Assign(Value);\r\nend;\r\n\r\nprocedure TJvTFDays.SetTopRow(Value: Integer);\r\nvar\r\n MaxTopRow: Integer;\r\nbegin\r\n MaxTopRow := RowCount - 1;\r\n if MaxTopRow < 0 then\r\n MaxTopRow := 0;\r\n if Value > MaxTopRow then\r\n Value := MaxTopRow;\r\n\r\n if Value <> FTopRow then\r\n if (Value > -1) and (Value < RowCount) then\r\n begin\r\n if Editing then\r\n FinishEditAppt;\r\n\r\n FTopRow := Value;\r\n FVScrollBar.Position := Value;\r\n CheckSBVis;\r\n Invalidate;\r\n end\r\n else\r\n raise EJvTFDaysError.CreateRes(@RsERowIndexOutOfBounds);\r\nend;\r\n\r\nprocedure TJvTFDays.SetFocusedRow(Value: Integer);\r\nbegin\r\n // ALLOW -1 TO INDICATE NO SELECTED ROW\r\n\r\n {$IFDEF Jv_TIMEBLOCKS}\r\n // ok\r\n if (Value <> -1) and (RowToTimeBlock(Value) = -1) and (TimeBlocks.Count > 0) then\r\n Exit;\r\n {$ENDIF Jv_TIMEBLOCKS}\r\n\r\n if Value <> FFocusedRow then\r\n if (Value >= -1) and (Value < RowCount) then\r\n begin\r\n FFocusedRow := Value;\r\n if not (csDesigning in ComponentState) then\r\n SetFocus;\r\n if not Assigned(SelAppt) and (Value > -1) then\r\n RowInView(Value);\r\n if Assigned(FOnFocusedRowChanged) then\r\n FOnFocusedRowChanged(Self);\r\n Invalidate;\r\n end\r\n else\r\n raise EJvTFDaysError.CreateRes(@RsERowIndexOutOfBounds);\r\nend;\r\n\r\nfunction TJvTFDays.GetFocusedRow: Integer;\r\nbegin\r\n if Focused then\r\n Result := FFocusedRow\r\n else\r\n Result := -1;\r\nend;\r\n\r\nprocedure TJvTFDays.SetLeftCol(Value: Integer);\r\nbegin\r\n // LeftCol will be -1 when no cols are present.\r\n // After the first col is added, LeftCol is set to 0, which is done in\r\n // TJvTFDaysCols.Update. Likewise, when all cols are removed, LeftCol\r\n // must be set to -1. This is also done in TJvTFDaysCols.Update.\r\n\r\n if Value <> FLeftCol then\r\n if Cols.Count > 0 then\r\n if (Value > -1) and (Value < Cols.Count) then\r\n begin\r\n FLeftCol := Value;\r\n FHScrollBar.Position := Value;\r\n if not Cols.Updating then\r\n begin\r\n CheckSBVis;\r\n CheckSBParams;\r\n Invalidate;\r\n end;\r\n end\r\n else\r\n raise EJvTFDaysError.CreateRes(@RsEColumnIndexOutOfBounds)\r\n else\r\n if Value = -1 then\r\n begin\r\n FLeftCol := -1;\r\n Invalidate;\r\n end\r\n else\r\n raise EJvTFDaysError.CreateRes(@RsEColumnIndexOutOfBounds);\r\nend;\r\n\r\nprocedure TJvTFDays.SetFocusedCol(Value: Integer);\r\nbegin\r\n // ALLOW -1 TO INDICATE NO SELECTED COL\r\n\r\n if Value <> FFocusedCol then\r\n if (Value >= -1) and (Value < Cols.Count) then\r\n begin\r\n FFocusedCol := Value;\r\n if not (csDesigning in ComponentState) then\r\n SetFocus;\r\n if not Cols.Updating then\r\n begin\r\n if Value > -1 then\r\n ColInView(Value);\r\n if Assigned(FOnFocusedColChanged) then\r\n FOnFocusedColChanged(Self);\r\n Invalidate;\r\n end;\r\n end\r\n else\r\n raise EJvTFDaysError.CreateRes(@RsEColumnIndexOutOfBounds);\r\nend;\r\n\r\nfunction TJvTFDays.GetFocusedCol: Integer;\r\nbegin\r\n if Focused then\r\n Result := FFocusedCol\r\n else\r\n Result := -1;\r\nend;\r\n\r\nprocedure TJvTFDays.SetHdrAttr(Value: TJvTFDaysHdrAttr);\r\nbegin\r\n FHdrAttr.Assign(Value);\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvTFDays.SetSelHdrAttr(Value: TJvTFDaysHdrAttr);\r\nbegin\r\n FSelHdrAttr.Assign(Value);\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvTFDays.SetApptAttr(Value: TJvTFDaysApptAttr);\r\nbegin\r\n FApptAttr.Assign(Value);\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvTFDays.SetSelApptAttr(Value: TJvTFDaysApptAttr);\r\nbegin\r\n FSelApptAttr.Assign(Value);\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvTFDays.SetFancyRowHdrAttr(Value: TJvTFDaysFancyRowHdrAttr);\r\nbegin\r\n FFancyRowHdrAttr.Assign(Value);\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvTFDays.SetSelFancyRowHdrAttr(Value: TJvTFDaysFancyRowHdrAttr);\r\nbegin\r\n FSelFancyRowHdrAttr.Assign(Value);\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvTFDays.SetTFRowHdrType(Value: TJvTFRowHdrType);\r\nbegin\r\n if Value <> FRowHdrType then\r\n begin\r\n FRowHdrType := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvTFDays.SetTFSelCellAttr(Value: TJvTFSelCellAttr);\r\nbegin\r\n FSelCellAttr.Assign(Value);\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvTFDays.SetApptBar(Value: TJvTFDaysApptBar);\r\nbegin\r\n FApptBar.Assign(Value);\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvTFDays.SetApptBuffer(Value: Integer);\r\nbegin\r\n if Value < 0 then\r\n Value := 0;\r\n if Value <> FApptBuffer then\r\n begin\r\n FApptBuffer := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvTFDays.SetGridLineColor(Value: TColor);\r\nbegin\r\n if Value <> FGridLineColor then\r\n begin\r\n FGridLineColor := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvTFDays.SetGrabHandles(Value: TJvTFDaysGrabHandles);\r\nbegin\r\n FGrabHandles.Assign(Value);\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvTFDays.SetOptions(Value: TJvTFDaysOptions);\r\nbegin\r\n FOptions := Value;\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvTFDays.SetDateFormat(const Value: string);\r\nbegin\r\n if Value <> FDateFormat then\r\n begin\r\n FDateFormat := Value;\r\n Cols.UpdateTitles;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvTFDays.RelSchedNotification(Schedule: TJvTFSched);\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := 0 to Cols.Count - 1 do\r\n if Cols[I].Schedule = Schedule then\r\n Cols[I].Disconnect;\r\n inherited RelSchedNotification(Schedule);\r\nend;\r\n\r\nprocedure TJvTFDays.CreateParams(var Params: TCreateParams);\r\nconst\r\n BorderStyles: array [TBorderStyle] of DWORD = (0, WS_BORDER);\r\nbegin\r\n inherited CreateParams(Params);\r\n with Params do\r\n begin\r\n Style := Style or BorderStyles[FBorderStyle] or WS_CLIPCHILDREN;\r\n if Ctl3D and (FBorderStyle = bsSingle) then\r\n begin\r\n Style := Style and not WS_BORDER;\r\n ExStyle := ExStyle or WS_EX_CLIENTEDGE;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJvTFDays.GetFocusedSchedule: TJvTFSched;\r\nbegin\r\n Result := nil;\r\n if FocusedCol > gcHdr then\r\n Result := Cols[FocusedCol].Schedule;\r\nend;\r\n\r\nprocedure TJvTFDays.SetSelAppt(Value: TJvTFAppt);\r\nbegin\r\n // need event here with var Appt param - allows handler to set Appt\r\n // to nil.\r\n if Assigned(FOnSelectingAppt) then\r\n FOnSelectingAppt(Self, Value);\r\n\r\n if Value <> FSelAppt then\r\n begin\r\n if Editing then\r\n FinishEditAppt;\r\n if Assigned(FOnSelectAppt) then\r\n FOnSelectAppt(Self, FSelAppt, Value);\r\n FSelAppt := Value;\r\n if Assigned(FOnSelectedAppt) then\r\n FOnSelectedAppt(Self);\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvTFDays.Paint;\r\nvar\r\n I, J, RightCol, BottomRow: Integer;\r\nbegin\r\n{ optimization incorrectly kicks in if control is only partially\r\n visible on the screen\r\n if not PaintBuffer.Empty and\r\n ((Canvas.ClipRect.Left <> ClientRect.Left) or\r\n (Canvas.ClipRect.Top <> ClientRect.Top) or\r\n (Canvas.ClipRect.Right <> ClientRect.Right) or\r\n (Canvas.ClipRect.Bottom <> ClientRect.Bottom)) then\r\n begin\r\n With Canvas do\r\n Windows.BitBlt(Canvas.Handle, ClipRect.Left, ClipRect.Top,\r\n RectWidth(ClipRect), RectHeight(ClipRect),\r\n PaintBuffer.Canvas.Handle,\r\n ClipRect.Left, ClipRect.Top, SRCCOPY);\r\n Exit;\r\n end;\r\n }\r\n\r\n with PaintBuffer do\r\n begin\r\n Width := ClientWidth;\r\n Height := ClientHeight;\r\n\r\n with Canvas do\r\n begin\r\n if FDitheredBackground then\r\n // added by TIM, 10/27/2001 10:36:03 PM:\r\n DrawDither(Canvas, Classes.Rect(0, 0, Width, Height), Self.Color, clGray)\r\n else\r\n begin\r\n Brush.Color := Self.Color;\r\n FillRect(Classes.Rect(0, 0, Width, Height));\r\n end;\r\n end;\r\n\r\n DrawCorner(Canvas, agcTopLeft);\r\n\r\n if Cols.Count = 0 then\r\n DrawEmptyColHdr(Canvas);\r\n\r\n DrawGroupHdrs(Canvas);\r\n\r\n RightCol := LeftCol + VisibleCols - 1;\r\n for I := LeftCol to RightCol do\r\n //DrawColHdr(Canvas, I);\r\n DrawColGroupHdr(Canvas, I, False);\r\n\r\n if vsbVert in VisibleScrollBars then\r\n DrawCorner(Canvas, agcTopRight);\r\n\r\n {$IFDEF Jv_TIMEBLOCKS}\r\n // all ok\r\n FillBlockHdrDeadSpace(Canvas);\r\n for I := 0 to TimeBlocks.Count - 1 do\r\n DrawBlockHdr(Canvas, I);\r\n {$ENDIF Jv_TIMEBLOCKS}\r\n\r\n BottomRow := TopRow + VisibleRows - 1;\r\n if RowHdrType = rhFancy then\r\n DrawFancyRowHdrs(Canvas)\r\n else\r\n for I := TopRow to BottomRow do\r\n DrawRowHdr(Canvas, I);\r\n\r\n for I := TopRow to BottomRow do\r\n for J := LeftCol to RightCol do\r\n DrawDataCell(Canvas, J, I);\r\n\r\n if not (csDesigning in ComponentState) then\r\n DrawAppts(Canvas, False);\r\n\r\n if vsbHorz in VisibleScrollBars then\r\n begin\r\n DrawCorner(Canvas, agcBottomLeft);\r\n if vsbVert in VisibleScrollBars then\r\n DrawCorner(Canvas, agcBottomRight);\r\n end;\r\n end;\r\n\r\n if Enabled then\r\n Windows.BitBlt(Canvas.Handle, 0, 0, ClientWidth, ClientHeight,\r\n PaintBuffer.Canvas.Handle, 0, 0, SRCCOPY)\r\n else\r\n Windows.DrawState(Canvas.Handle, 0, nil, PaintBuffer.Handle, 0,\r\n 0, 0, 0, 0, DST_BITMAP or DSS_UNION or DSS_DISABLED);\r\nend;\r\n\r\n{$IFNDEF Jv_TIMEBLOCKS}\r\n// OBSOLETE\r\n{\r\nprocedure TJvTFDays.DrawDataCell(ACanvas: TCanvas; ColIndex, RowIndex: Integer);\r\nVar\r\n SelFrameRect,\r\n FocusRect,\r\n ARect: TRect;\r\n I,\r\n PrimeStartRow,\r\n PrimeEndRow,\r\n FrameOffset: Integer;\r\n CellColor: TColor;\r\n IsPrimeTimeCell: Boolean;\r\nbegin\r\n // Calc the cell rect\r\n ARect.Left := RowHdrWidth;\r\n For I := LeftCol to ColIndex - 1 do\r\n Inc(ARect.Left, Cols[I].Width);\r\n ARect.Right := ARect.Left + Cols[ColIndex].Width;\r\n\r\n //group Top := ColHdrHeight + (RowIndex - TopRow) * RowHeight;\r\n ARect.Top := CalcGroupColHdrsHeight + (RowIndex - TopRow) * RowHeight;\r\n ARect.Bottom := ARect.Top + RowHeight;\r\n\r\n PrimeStartRow := TimeToRow(PrimeTime.StartTime);\r\n PrimeEndRow := TimeToRow(AdjustEndTime(PrimeTime.EndTime));\r\n\r\n IsPrimeTimeCell := (RowIndex >= PrimeStartRow) and (RowIndex <= PrimeEndRow);\r\n\r\n if IsPrimeTimeCell then\r\n CellColor := PrimeTime.Color\r\n else\r\n CellColor := Color;\r\n\r\n if Assigned(FOnShadeCell) then\r\n FOnShadeCell(Self, ColIndex, RowIndex, CellColor);\r\n\r\n if IsPrimeTimeCell and (CellColor = PrimeTime.Color) then\r\n Windows.StretchBlt(ACanvas.Handle, ARect.Left, ARect.Top, RectWidth(ARect),\r\n RectHeight(ARect), PrimeTime.FFillPic.Canvas.Handle,\r\n 0, 0, PrimeTime.FFillPic.Width,\r\n PrimeTime.FFillPic.Height, SRCCOPY)\r\n else\r\n if CellColor <> Color then\r\n begin\r\n ACanvas.Brush.Color := CellColor;\r\n ACanvas.FillRect(ARect);\r\n end;\r\n\r\n if CellIsSelected(Point(ColIndex, RowIndex)) then\r\n if SelCellAttr.Style = scsFrame then\r\n begin\r\n SelFrameRect := ARect;\r\n FrameOffset := -(SelCellAttr.FrameWidth div 2);\r\n Windows.InflateRect(SelFrameRect, FrameOffset, FrameOffset);\r\n\r\n if SelCellAttr.FrameWidth mod 2 <> 0 then\r\n begin\r\n Dec(SelFrameRect.Right);\r\n Dec(SelFrameRect.Bottom);\r\n end;\r\n\r\n With ACanvas do\r\n begin\r\n Pen.Color := SelCellAttr.Color;\r\n Pen.Width := SelCellAttr.FrameWidth;\r\n\r\n if FFromToSel then\r\n begin\r\n // Draw Left border\r\n MoveTo(SelFrameRect.Left, SelFrameRect.Top);\r\n LineTo(SelFrameRect.Left, SelFrameRect.Bottom - 1);\r\n\r\n // Draw Top border only if this cell is the same as SelStart cell\r\n if (ColIndex = SelStart.X) and (RowIndex = SelStart.Y) then\r\n begin\r\n MoveTo(SelFrameRect.Left, SelFrameRect.Top);\r\n LineTo(SelFrameRect.Right - 1, SelFrameRect.Top);\r\n end;\r\n\r\n // Draw Right border\r\n MoveTo(SelFrameRect.Right - 1, SelFrameRect.Top);\r\n LineTo(SelFrameRect.Right - 1, SelFrameRect.Bottom - 1);\r\n\r\n // Draw bottom border only in this cell is the same as SelEnd cell\r\n if (ColIndex = SelEnd.X) and (RowIndex = SelEnd.Y) then\r\n begin\r\n MoveTo(SelFrameRect.Left, SelFrameRect.Bottom - 1);\r\n LineTo(SelFrameRect.Right - 1, SelFrameRect.Bottom - 1);\r\n end;\r\n end\r\n else\r\n begin\r\n // Draw Left border only if col is left-most in selection\r\n if ColIndex = SelStart.X then\r\n begin\r\n MoveTo(SelFrameRect.Left, SelFrameRect.Top);\r\n LineTo(SelFrameRect.Left, SelFrameRect.Bottom - 1);\r\n end;\r\n\r\n // Draw Top border only if row is top-most in selection\r\n if RowIndex = SelStart.Y then\r\n begin\r\n MoveTo(SelFrameRect.Left, SelFrameRect.Top);\r\n LineTo(SelFrameRect.Right - 1, SelFrameRect.Top);\r\n end;\r\n\r\n // Draw Right border only if col is right-most in selection\r\n if ColIndex = SelEnd.X then\r\n begin\r\n MoveTo(SelFrameRect.Right - 1, SelFrameRect.Top);\r\n LineTo(SelFrameRect.Right - 1, SelFrameRect.Bottom - 1);\r\n end;\r\n\r\n // Draw Bottom border only if row is bottom-most in selection\r\n if RowIndex = SelEnd.Y then\r\n begin\r\n MoveTo(SelFrameRect.Left, SelFrameRect.Bottom - 1);\r\n LineTo(SelFrameRect.Right - 1, SelFrameRect.Bottom - 1);\r\n end;\r\n end;\r\n end;\r\n end\r\n // Refer to the private FSel* fields because we want anchor\r\n else\r\n if (SelCellAttr.Style = scsCombo) and\r\n (FSelStart.X = ColIndex) and (FSelStart.Y = RowIndex) then\r\n begin\r\n SelFrameRect := ARect;\r\n FrameOffset := -(SelCellAttr.FrameWidth div 2);\r\n Windows.InflateRect(SelFrameRect, FrameOffset, FrameOffset);\r\n\r\n if SelCellAttr.FrameWidth mod 2 <> 0 then\r\n begin\r\n Dec(SelFrameRect.Right);\r\n Dec(SelFrameRect.Bottom);\r\n end;\r\n\r\n With ACanvas do\r\n begin\r\n Pen.Color := SelCellAttr.Color;\r\n Pen.Width := SelCellAttr.FrameWidth;\r\n MoveTo(SelFrameRect.Left, SelFrameRect.Top);\r\n LineTo(SelFrameRect.Right - 1, SelFrameRect.Top);\r\n LineTo(SelFrameRect.Right - 1, SelFrameRect.Bottom - 1);\r\n LineTo(SelFrameRect.Left, SelFrameRect.Bottom - 1);\r\n LineTo(SelFrameRect.Left, SelFrameRect.Top);\r\n end;\r\n end\r\n else\r\n begin\r\n ACanvas.Brush.Color := SelCellAttr.Color;\r\n ACanvas.FillRect(ARect);\r\n end;\r\n\r\n if (ColIndex = FocusedCol) and (RowIndex = FocusedRow) and Focused then\r\n begin\r\n FocusRect := ARect;\r\n Windows.InflateRect(FocusRect, -1, -1);\r\n Dec(FocusRect.Bottom);\r\n Dec(FocusRect.Right);\r\n ManualFocusRect(ACanvas, FocusRect);\r\n end;\r\n\r\n // Draw a line across the bottom and down the right side\r\n With ACanvas do\r\n begin\r\n Pen.Color := GridLineColor;\r\n Pen.Width := 1;\r\n\r\n MoveTo(ARect.Left, ARect.Bottom - 1);\r\n LineTo(ARect.Right, ARect.Bottom - 1);\r\n MoveTo(ARect.Right - 1, ARect.Top);\r\n LineTo(ARect.Right - 1, ARect.Bottom);\r\n end;\r\n\r\n if Assigned(FOnDrawDataCell) then\r\n FOnDrawDataCell(Self, ACanvas, ARect, ColIndex, RowIndex);\r\nend;\r\n}\r\n{$ENDIF !Jv_TIMEBLOCKS}\r\n\r\n{$IFDEF Jv_TIMEBLOCKS}\r\n// ok\r\nprocedure TJvTFDays.DrawDataCell(ACanvas: TCanvas; ColIndex, RowIndex: Integer);\r\nvar\r\n SelFrameRect, FocusRect, Rect: TRect;\r\n I, PrimeStartRow, PrimeEndRow: Integer;\r\n FrameOffset, BlockStart, BlockEnd, TimeBlockIndex: Integer;\r\n IsPrimeTimeCell: Boolean;\r\n CellColor: TColor;\r\n // col buffer start\r\n BufferRect: TRect;\r\n // col buffer end\r\nbegin\r\n // Calc the cell rect\r\n //block Left := RowHdrWidth;\r\n Rect.Left := CalcBlockRowHdrsWidth;\r\n for I := LeftCol to ColIndex - 1 do\r\n Inc(Rect.Left, Cols[I].Width);\r\n Rect.Right := Rect.Left + Cols[ColIndex].Width;\r\n\r\n //group Top := ColHdrHeight + (RowIndex - TopRow) * RowHeight;\r\n Rect.Top := CalcGroupColHdrsHeight + (RowIndex - TopRow) * RowHeight;\r\n Rect.Bottom := Rect.Top + RowHeight;\r\n\r\n PrimeStartRow := TimeToRow(PrimeTime.StartTime);\r\n PrimeEndRow := TimeToRow(AdjustEndTime(PrimeTime.EndTime));\r\n\r\n IsPrimeTimeCell := (RowIndex >= PrimeStartRow) and (RowIndex <= PrimeEndRow);\r\n\r\n if IsWeekend(ColIndex) then\r\n CellColor := WeekendColor\r\n else\r\n if IsPrimeTimeCell then\r\n CellColor := PrimeTime.Color\r\n else\r\n CellColor := Color;\r\n\r\n if Assigned(FOnShadeCell) then\r\n FOnShadeCell(Self, ColIndex, RowIndex, CellColor);\r\n\r\n if IsWeekend(ColIndex) and (CellColor = WeekendColor) then\r\n begin\r\n if FDitheredBackground then\r\n DrawDither(ACanvas, Rect, CellColor, clWhite)\r\n else\r\n Windows.StretchBlt(ACanvas.Handle, Rect.Left, Rect.Top, RectWidth(Rect),\r\n RectHeight(Rect), FWeekendFillPic.Canvas.Handle,\r\n 0, 0, FWeekendFillPic.Width,\r\n FWeekendFillPic.Height, SRCCOPY);\r\n end\r\n else\r\n if IsPrimeTimeCell and (CellColor = PrimeTime.Color) then\r\n begin\r\n if FDitheredBackground then\r\n DrawDither(ACanvas, Rect, CellColor, clWhite)\r\n else\r\n Windows.StretchBlt(ACanvas.Handle, Rect.Left, Rect.Top, RectWidth(Rect),\r\n RectHeight(Rect), PrimeTime.FFillPic.Canvas.Handle,\r\n 0, 0, PrimeTime.FFillPic.Width,\r\n PrimeTime.FFillPic.Height, SRCCOPY);\r\n end\r\n else\r\n if CellColor <> Color then\r\n begin\r\n ACanvas.Brush.Color := CellColor;\r\n ACanvas.FillRect(Rect);\r\n end\r\n else\r\n begin\r\n if FDitheredBackground then\r\n DrawDither(ACanvas, Rect, CellColor, clWhite);\r\n end;\r\n\r\n {\r\n if IsWeekend(ColIndex) then\r\n Windows.StretchBlt(ACanvas.Handle, ARect.Left, ARect.Top, RectWidth(ARect),\r\n RectHeight(ARect), FWeekendFillPic.Canvas.Handle,\r\n 0, 0, FWeekendFillPic.Width,\r\n FWeekendFillPic.Height, SRCCOPY)\r\n else\r\n if (RowIndex >= PrimeStartRow) and (RowIndex <= PrimeEndRow) then\r\n Windows.StretchBlt(ACanvas.Handle, ARect.Left, ARect.Top, RectWidth(ARect),\r\n RectHeight(ARect), PrimeTime.FFillPic.Canvas.Handle,\r\n 0, 0, PrimeTime.FFillPic.Width,\r\n PrimeTime.FFillPic.Height, SRCCOPY);\r\n }\r\n\r\n if CellIsSelected(Point(ColIndex, RowIndex)) then\r\n if SelCellAttr.Style = scsFrame then\r\n begin\r\n SelFrameRect := Rect;\r\n FrameOffset := -(SelCellAttr.FrameWidth div 2);\r\n Windows.InflateRect(SelFrameRect, FrameOffset, FrameOffset);\r\n\r\n if SelCellAttr.FrameWidth mod 2 <> 0 then\r\n begin\r\n Dec(SelFrameRect.Right);\r\n Dec(SelFrameRect.Bottom);\r\n end;\r\n\r\n with ACanvas do\r\n begin\r\n Pen.Color := SelCellAttr.Color;\r\n Pen.Width := SelCellAttr.FrameWidth;\r\n\r\n if FFromToSel then\r\n begin\r\n // Draw Left border\r\n MoveTo(SelFrameRect.Left, SelFrameRect.Top);\r\n LineTo(SelFrameRect.Left, SelFrameRect.Bottom - 1);\r\n\r\n // Draw Top border only if this cell is the same as SelStart cell\r\n if (ColIndex = SelStart.X) and (RowIndex = SelStart.Y) then\r\n begin\r\n MoveTo(SelFrameRect.Left, SelFrameRect.Top);\r\n LineTo(SelFrameRect.Right - 1, SelFrameRect.Top);\r\n end;\r\n\r\n // Draw Right border\r\n MoveTo(SelFrameRect.Right - 1, SelFrameRect.Top);\r\n LineTo(SelFrameRect.Right - 1, SelFrameRect.Bottom - 1);\r\n\r\n // Draw bottom border only in this cell is the same as SelEnd cell\r\n if (ColIndex = SelEnd.X) and (RowIndex = SelEnd.Y) then\r\n begin\r\n MoveTo(SelFrameRect.Left, SelFrameRect.Bottom - 1);\r\n LineTo(SelFrameRect.Right - 1, SelFrameRect.Bottom - 1);\r\n end;\r\n end\r\n else\r\n begin\r\n // Draw Left border only if col is left-most in selection\r\n if ColIndex = SelStart.X then\r\n begin\r\n MoveTo(SelFrameRect.Left, SelFrameRect.Top);\r\n LineTo(SelFrameRect.Left, SelFrameRect.Bottom - 1);\r\n end;\r\n\r\n // Draw Top border only if row is top-most in selection\r\n if RowIndex = SelStart.Y then\r\n begin\r\n MoveTo(SelFrameRect.Left, SelFrameRect.Top);\r\n LineTo(SelFrameRect.Right - 1, SelFrameRect.Top);\r\n end;\r\n\r\n // Draw Right border only if col is right-most in selection\r\n if ColIndex = SelEnd.X then\r\n begin\r\n MoveTo(SelFrameRect.Right - 1, SelFrameRect.Top);\r\n LineTo(SelFrameRect.Right - 1, SelFrameRect.Bottom - 1);\r\n end;\r\n\r\n // Draw Bottom border only if row is bottom-most in selection\r\n if RowIndex = SelEnd.Y then\r\n begin\r\n MoveTo(SelFrameRect.Left, SelFrameRect.Bottom - 1);\r\n LineTo(SelFrameRect.Right - 1, SelFrameRect.Bottom - 1);\r\n end;\r\n end;\r\n end;\r\n end\r\n // Refer to the private FSel* fields because we want anchor\r\n else\r\n if (SelCellAttr.Style = scsCombo) and\r\n (FSelStart.X = ColIndex) and (FSelStart.Y = RowIndex) then\r\n begin\r\n SelFrameRect := Rect;\r\n FrameOffset := -(SelCellAttr.FrameWidth div 2);\r\n Windows.InflateRect(SelFrameRect, FrameOffset, FrameOffset);\r\n\r\n if SelCellAttr.FrameWidth mod 2 <> 0 then\r\n begin\r\n Dec(SelFrameRect.Right);\r\n Dec(SelFrameRect.Bottom);\r\n end;\r\n\r\n with ACanvas do\r\n begin\r\n Pen.Color := SelCellAttr.Color;\r\n Pen.Width := SelCellAttr.FrameWidth;\r\n MoveTo(SelFrameRect.Left, SelFrameRect.Top);\r\n LineTo(SelFrameRect.Right - 1, SelFrameRect.Top);\r\n LineTo(SelFrameRect.Right - 1, SelFrameRect.Bottom - 1);\r\n LineTo(SelFrameRect.Left, SelFrameRect.Bottom - 1);\r\n LineTo(SelFrameRect.Left, SelFrameRect.Top);\r\n end;\r\n end\r\n else\r\n begin\r\n ACanvas.Brush.Color := SelCellAttr.Color;\r\n ACanvas.FillRect(Rect);\r\n end;\r\n\r\n if (ColIndex = FocusedCol) and (RowIndex = FocusedRow) and Focused and ShowFocus then\r\n begin\r\n FocusRect := Rect;\r\n Windows.InflateRect(FocusRect, -1, -1);\r\n Dec(FocusRect.Bottom);\r\n Dec(FocusRect.Right);\r\n ManualFocusRect(ACanvas, FocusRect);\r\n end;\r\n\r\n // Draw a line across the bottom and down the right side\r\n with ACanvas do\r\n begin\r\n Pen.Color := GridLineColor;\r\n Pen.Width := 1;\r\n\r\n MoveTo(Rect.Left, Rect.Bottom - 1);\r\n LineTo(Rect.Right, Rect.Bottom - 1);\r\n MoveTo(Rect.Right - 1, Rect.Top);\r\n LineTo(Rect.Right - 1, Rect.Bottom);\r\n\r\n if TimeBlocks.Count > 0 then\r\n begin\r\n GetTimeBlockStartEnd(0, BlockStart, BlockEnd);\r\n if RowIndex = BlockStart - 1 then\r\n begin\r\n Pen.Color := TimeBlockProps.DataDivColor;\r\n MoveTo(Rect.Left, Rect.Bottom - 1);\r\n LineTo(Rect.Right, Rect.Bottom - 1);\r\n end;\r\n\r\n TimeBlockIndex := RowToTimeBlock(RowIndex);\r\n if TimeBlockIndex > -1 then\r\n begin\r\n GetTimeBlockStartEnd(TimeBlockIndex, BlockStart, BlockEnd);\r\n if BlockEnd = RowIndex then\r\n begin\r\n Pen.Color := TimeBlockProps.DataDivColor;\r\n MoveTo(Rect.Left, Rect.Bottom - 1);\r\n LineTo(Rect.Right, Rect.Bottom - 1);\r\n end;\r\n end;\r\n end;\r\n end;\r\n\r\n // Col Buffer start\r\n // Draw the column buffer\r\n with ACanvas do\r\n begin\r\n BufferRect := Rect;\r\n BufferRect.Right := BufferRect.Left + ApptBar.Width; // + 10 to simulate buffer\r\n\r\n Brush.Color := clWhite;\r\n FillRect(BufferRect);\r\n\r\n Pen.Color := clBlack;\r\n Pen.Width := 1;\r\n\r\n MoveTo(BufferRect.Right, BufferRect.Top);\r\n LineTo(BufferRect.Right, BufferRect.Bottom);\r\n end;\r\n // Col buffer end\r\n\r\n if Assigned(FOnDrawDataCell) then\r\n FOnDrawDataCell(Self, ACanvas, Rect, ColIndex, RowIndex);\r\nend;\r\n{$ENDIF Jv_TIMEBLOCKS}\r\n\r\nprocedure TJvTFDays.DrawEmptyColHdr(ACanvas: TCanvas);\r\nvar\r\n Rect: TRect;\r\nbegin\r\n {$IFDEF Jv_TIMEBLOCKS}\r\n // ok\r\n Rect.Left := CalcBlockRowHdrsWidth;\r\n {$ELSE}\r\n // remove\r\n //Left := RowHdrWidth;\r\n {$ENDIF Jv_TIMEBLOCKS}\r\n Rect.Top := 0;\r\n Rect.Right := Rect.Left + GetDataWidth;\r\n //group Bottom := ColHdrHeight;\r\n Rect.Bottom := CalcGroupColHdrsHeight;\r\n\r\n ACanvas.Brush.Color := HdrAttr.Color;\r\n ACanvas.FillRect(Rect);\r\n ACanvas.Pen.Color := clGray;\r\n ACanvas.MoveTo(Rect.Left, Rect.Bottom - 1);\r\n ACanvas.LineTo(Rect.Right, Rect.Bottom - 1);\r\nend;\r\n\r\nprocedure TJvTFDays.DrawAppt(ACanvas: TCanvas; Col: Integer;\r\n Appt: TJvTFAppt; StartRow, EndRow: Integer);\r\nvar\r\n ApptRect: TRect;\r\n ClipRgn: HRgn;\r\nbegin\r\n ApptRect := GetApptRect(Col, Appt);\r\n\r\n if Windows.IsRectEmpty(ApptRect) then\r\n Exit;\r\n\r\n // Printer bug, fixed\r\n ClipRgn := Windows.CreateRectRgn(RowHdrWidth, CalcGroupColHdrsHeight,\r\n ClientWidth, ClientHeight);\r\n Windows.SelectClipRgn(ACanvas.Handle, ClipRgn);\r\n DrawApptDetail(ACanvas, ApptRect, Appt, Appt = SelAppt, Col, StartRow, EndRow);\r\n Windows.SelectClipRgn(ACanvas.Handle, 0);\r\n Windows.DeleteObject(ClipRgn);\r\nend;\r\n\r\nfunction TJvTFDays.CalcTimeStampRect(Appt: TJvTFAppt; BarRect: TRect;\r\n Col, StartRow, EndRow: Integer): TRect;\r\nvar\r\n Offset, ApptLength: TTime;\r\n ColDate: TDate;\r\n StartPercent, EndPercent: Double;\r\nbegin\r\n Result := BarRect;\r\n\r\n if StartRow < 0 then\r\n StartRow := 0;\r\n\r\n if EndRow > RowCount - 1 then\r\n EndRow := RowCount - 1;\r\n\r\n Offset := RowToTime(StartRow);\r\n ApptLength := RowEndTime(EndRow) - Offset;\r\n ColDate := Cols[Col].SchedDate;\r\n\r\n if Trunc(ColDate) <> Trunc(Appt.StartDate) then\r\n StartPercent := 0\r\n else\r\n StartPercent := (Appt.StartTime - Offset) / ApptLength;\r\n\r\n if Trunc(ColDate) <> Trunc(Appt.EndDate) then\r\n EndPercent := 1.0\r\n else\r\n EndPercent := (Appt.EndTime - Offset) / ApptLength;\r\n\r\n Result.Top := Round((BarRect.Bottom - BarRect.Top) * StartPercent) + BarRect.Top;\r\n Result.Bottom := Round((BarRect.Bottom - BarRect.Top) * EndPercent) + BarRect.Top;\r\nend;\r\n\r\nprocedure TJvTFDays.DrawTimeStamp(ACanvas: TCanvas; TimeStampRect: TRect);\r\nvar\r\n OldColor: TColor;\r\n StampLeft: Integer;\r\nbegin\r\n with ACanvas do\r\n case ApptBar.TimeStampStyle of\r\n tssFullI:\r\n begin\r\n OldColor := Pen.Color;\r\n Pen.Color := ApptBar.TimeStampColor;\r\n MoveTo(TimeStampRect.Left + 1, TimeStampRect.Top);\r\n LineTo(TimeStampRect.Right - 1, TimeStampRect.Top);\r\n MoveTo(TimeStampRect.Left + 1, TimeStampRect.Bottom - 1);\r\n LineTo(TimeStampRect.Right - 1, TimeStampRect.Bottom - 1);\r\n\r\n if ApptBar.Width > 5 then\r\n Pen.Width := 2\r\n else\r\n Pen.Width := 1;\r\n\r\n // Printer bug, fixed\r\n StampLeft := TimeStampRect.Left + RectWidth(TimeStampRect) div 2;\r\n MoveTo(StampLeft, TimeStampRect.Top + 1);\r\n LineTo(StampLeft, TimeStampRect.Bottom - 1);\r\n\r\n Pen.Width := 1;\r\n\r\n Pen.Color := OldColor;\r\n end;\r\n tssHalfI:\r\n begin\r\n // we only want the left half of the time stamp rect\r\n TimeStampRect.Right := (TimeStampRect.Left + TimeStampRect.Right) div 2;\r\n\r\n OldColor := Pen.Color;\r\n Pen.Color := ApptBar.TimeStampColor;\r\n MoveTo(TimeStampRect.Left, TimeStampRect.Top);\r\n LineTo(TimeStampRect.Right - 0, TimeStampRect.Top);\r\n MoveTo(TimeStampRect.Left, TimeStampRect.Bottom - 0);\r\n LineTo(TimeStampRect.Right - 0, TimeStampRect.Bottom - 0);\r\n\r\n if ApptBar.Width > 5 then\r\n Pen.Width := 2\r\n else\r\n Pen.Width := 1;\r\n MoveTo(TimeStampRect.Right - 0, TimeStampRect.Top + 1);\r\n LineTo(TimeStampRect.Right - 0, TimeStampRect.Bottom);\r\n Pen.Color := OldColor;\r\n Pen.Width := 1;\r\n end;\r\n tssBlock:\r\n begin\r\n // we only want the left half of the time stamp rect\r\n TimeStampRect.Right := (TimeStampRect.Left + TimeStampRect.Right) div 2;\r\n\r\n OldColor := Brush.Color;\r\n Brush.Color := ApptBar.TimeStampColor;\r\n FillRect(TimeStampRect);\r\n Brush.Color := OldColor;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvTFDays.DrawApptBar(ACanvas: TCanvas; Appt: TJvTFAppt;\r\n BarRect: TRect; Col, StartRow, EndRow: Integer);\r\nvar\r\n OldColor: TColor;\r\n TimeStampRect: TRect;\r\n Attr: TJvTFDaysApptAttr;\r\nbegin\r\n with ACanvas do\r\n begin\r\n if Appt <> SelAppt then\r\n Attr := ApptAttr\r\n else\r\n Attr := SelApptAttr;\r\n\r\n // Fill Bar Color\r\n OldColor := Brush.Color;\r\n if Appt.BarColor = clDefault then\r\n Brush.Color := ApptBar.Color\r\n else\r\n Brush.Color := Appt.BarColor;\r\n\r\n FillRect(BarRect);\r\n\r\n // Draw Bar Border\r\n Pen.Width := 1;\r\n Pen.Color := Attr.FrameColor;\r\n\r\n MoveTo(BarRect.Right - 1, BarRect.Top);\r\n LineTo(BarRect.Right - 1, BarRect.Bottom);\r\n// Rectangle(BarRect);\r\n\r\n Brush.Color := OldColor;\r\n\r\n // Draw Time Stamp\r\n TimeStampRect := CalcTimeStampRect(Appt, BarRect, Col, StartRow, EndRow);\r\n if ApptBar.TimeStampStyle <> tssNone then\r\n DrawTimeStamp(ACanvas, TimeStampRect);\r\n\r\n if Assigned(FOnDrawApptBar) then\r\n FOnDrawApptBar(Self, ACanvas, Appt, Col, BarRect, TimeStampRect);\r\n end;\r\nend;\r\n\r\nprocedure TJvTFDays.DrawApptDetail(ACanvas: TCanvas; ARect: TRect;\r\n Appt: TJvTFAppt; Selected: Boolean; Col, StartRow, EndRow: Integer);\r\nvar\r\n TheFrameRect, TxtRect, DetailRect, BarRect, HandleRect: TRect;\r\n Txt: string;\r\n Flags: UINT;\r\n CanDrawText, CanDrawPics, CanDrawAppt: Boolean;\r\n PicsHeight, PicsWidth: Integer;\r\n DrawList: TList;\r\n Attr: TJvTFDaysApptAttr;\r\n DrawInfo: TJvTFDaysApptDrawInfo;\r\nbegin\r\n with ACanvas do\r\n begin\r\n if Appt <> SelAppt then\r\n Attr := ApptAttr\r\n else\r\n Attr := SelApptAttr;\r\n\r\n DrawInfo := TJvTFDaysApptDrawInfo.Create;\r\n try\r\n GetApptDrawInfo(DrawInfo, Appt, Attr);\r\n Font.Assign(DrawInfo.Font);\r\n Brush.Color := DrawInfo.Color;\r\n Pen.Color := DrawInfo.FrameColor;\r\n Pen.Width := DrawInfo.FrameWidth;\r\n CanDrawAppt := DrawInfo.Visible;\r\n finally\r\n DrawInfo.Free;\r\n end;\r\n\r\n // !!!!!!!!!!!!!!!!!!!!!!!!!!\r\n // EXIT IF NOTHING TO DRAW !!\r\n // !!!!!!!!!!!!!!!!!!!!!!!!!!\r\n if not CanDrawAppt then\r\n Exit;\r\n\r\n FillRect(ARect);\r\n\r\n TheFrameRect := ARect;\r\n Windows.InflateRect(TheFrameRect, -(Attr.FrameWidth div 2), -(Attr.FrameWidth div 2));\r\n\r\n // Need to fine tune the frame rect\r\n if Attr.FrameWidth mod 2 = 0 then\r\n begin\r\n Inc(TheFrameRect.Right);\r\n Inc(TheFrameRect.Bottom);\r\n end;\r\n\r\n MoveTo(TheFrameRect.Left, TheFrameRect.Top);\r\n LineTo(TheFrameRect.Right - 1, TheFrameRect.Top);\r\n LineTo(TheFrameRect.Right - 1, TheFrameRect.Bottom - 1);\r\n LineTo(TheFrameRect.Left, TheFrameRect.Bottom - 1);\r\n LineTo(TheFrameRect.Left, TheFrameRect.Top);\r\n\r\n // Only go through the following work if all details must be drawn\r\n// if (RectHeight(ARect) > Thresholds.DetailHeight) and\r\n// (RectWidth(ARect) > Thresholds.DetailWidth) then\r\n begin\r\n Windows.InflateRect(TheFrameRect, -(Attr.FrameWidth div 2), -(Attr.FrameWidth div 2));\r\n\r\n DetailRect := TheFrameRect;\r\n\r\n if ApptBar.Visible then\r\n begin\r\n Inc(DetailRect.Left, ApptBar.Width);\r\n Windows.SubtractRect(BarRect, TheFrameRect, DetailRect);\r\n Dec(BarRect.Bottom);\r\n\r\n DrawApptBar(ACanvas, Appt, BarRect, Col, StartRow, EndRow);\r\n end;\r\n\r\n TxtRect := DetailRect;\r\n\r\n AdjustForMargins(TxtRect);\r\n\r\n DrawList := TList.Create;\r\n try\r\n CreatePicDrawList(TxtRect, Appt, DrawList);\r\n FilterPicDrawList(TxtRect, DrawList, PicsHeight, PicsWidth);\r\n // Calc'ing text height and width in CanDrawWhat\r\n CanDrawWhat(ACanvas, TxtRect, PicsHeight, CanDrawText, CanDrawPics);\r\n\r\n if CanDrawPics then\r\n begin\r\n DrawListPics(ACanvas, TxtRect, DrawList);\r\n Inc(TxtRect.Left, PicsWidth); // Tim\r\n end;\r\n finally\r\n ClearPicDrawList(DrawList);\r\n DrawList.Free;\r\n end;\r\n\r\n if CanDrawText then\r\n begin\r\n Flags := DT_WORDBREAK or DT_NOPREFIX or DT_EDITCONTROL;\r\n\r\n Txt := ScheduleManager.GetApptDisplayText(Self, Appt);\r\n\r\n if not (agoFormattedDesc in Options) then\r\n begin\r\n Txt := StripCRLF(Txt);\r\n Flags := Flags or DT_END_ELLIPSIS;\r\n end;\r\n\r\n //PTxt := StrNew(PChar(Txt));\r\n Windows.DrawText(ACanvas.Handle, PChar(Txt), -1, TxtRect, Flags);\r\n end;\r\n end;\r\n\r\n if Assigned(FOnDrawAppt) then\r\n FOnDrawAppt(Self, ACanvas, ARect, Appt, Selected);\r\n\r\n if Selected then\r\n begin\r\n { OLD 3D HANDLES CODE\r\n if agoMoveAppt in Options then\r\n DrawGrabLines(ACanvas, ARect.Top + 0, ARect.Left + 2,\r\n ARect.Right - 3);\r\n if agoSizeAppt in Options then\r\n DrawGrabLines(ACanvas, ARect.Bottom - GrabHandles.Height,\r\n ARect.Left + 2, ARect.Right - 3);\r\n }\r\n // move grab handles\r\n if agoMoveAppt in Options then\r\n begin\r\n// HandleRect := Classes.Rect(ARect.Left + 2, ARect.Top, ARect.Right - 3,\r\n// ARect.Top + GrabHandles.Height);\r\n// DrawGrabHandle(ACanvas, HandleRect, Appt, True);\r\n HandleRect := GetTopGrabHandleRect(Col, Appt);\r\n DrawGrabHandle(ACanvas, HandleRect, Appt, True);\r\n end;\r\n if agoSizeAppt in Options then\r\n begin\r\n// HandleRect := Classes.Rect(ARect.Left + 2,\r\n// ARect.Bottom - GrabHandles.Height,\r\n// ARect.Right - 3, ARect.Bottom);\r\n// DrawGrabHandle(ACanvas, HandleRect, Appt, False);\r\n HandleRect := GetBottomGrabHandleRect(Col, Appt);\r\n DrawGrabHandle(ACanvas, HandleRect, Appt, False);\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvTFDays.DrawPics(ACanvas: TCanvas; var ARect: TRect; Appt: TJvTFAppt);\r\nvar\r\n I, PicAdjust, NextPicLeft, CustomPicLeft, ImageIndex: Integer;\r\n ImageList: TCustomImageList;\r\n ImageMap: TJvTFStateImageMap;\r\n CustomImageMap: TJvTFCustomImageMap;\r\nbegin\r\n PicAdjust := 0;\r\n NextPicLeft := ARect.Left;\r\n\r\n if (agoShowPics in Options) and Assigned(ScheduleManager.CustomImages) then\r\n begin\r\n ImageList := ScheduleManager.CustomImages;\r\n CustomImageMap := Appt.ImageMap;\r\n\r\n for I := 0 to CustomImageMap.Count - 1 do\r\n begin\r\n ImageIndex := CustomImageMap[I];\r\n ImageList.Draw(ACanvas, NextPicLeft, ARect.Top, ImageIndex);\r\n Inc(NextPicLeft, ImageList.Width + 2);\r\n end;\r\n\r\n if CustomImageMap.Count > 0 then\r\n PicAdjust := ImageList.Height + 2;\r\n end;\r\n CustomPicLeft := NextPicLeft;\r\n\r\n if (agoShowPics in Options) and Assigned(ScheduleManager.StateImages) then\r\n begin\r\n ImageList := ScheduleManager.StateImages;\r\n ImageMap := ScheduleManager.StateImageMap;\r\n\r\n if Appt.AlarmEnabled then\r\n begin\r\n ImageIndex := ImageMap.AlarmEnabled;\r\n if ImageIndex > -1 then\r\n begin\r\n ImageList.Draw(ACanvas, NextPicLeft, ARect.Top, ImageIndex);\r\n Inc(NextPicLeft, ImageList.Width + 2);\r\n end;\r\n end\r\n else\r\n begin\r\n ImageIndex := ImageMap.AlarmDisabled;\r\n if ImageIndex > -1 then\r\n begin\r\n ImageList.Draw(ACanvas, NextPicLeft, ARect.Top, ImageIndex);\r\n Inc(NextPicLeft, ImageList.Width + 2);\r\n end;\r\n end;\r\n\r\n ImageIndex := ImageMap.Shared;\r\n if Appt.Shared and (ImageIndex > -1) then\r\n begin\r\n ImageList.Draw(ACanvas, NextPicLeft, ARect.Top, ImageIndex);\r\n Inc(NextPicLeft, ImageList.Width + 2);\r\n end;\r\n\r\n if Appt.Modified and (ImageMap.Modified > -1) then\r\n begin\r\n ImageList.Draw(ACanvas, NextPicLeft, ARect.Top, ImageMap.Modified);\r\n Inc(NextPicLeft, ImageList.Width + 2);\r\n end;\r\n\r\n if (NextPicLeft <> CustomPicLeft) and (ImageList.Height + 2 > PicAdjust) then\r\n PicAdjust := ImageList.Height + 2;\r\n end;\r\n\r\n Inc(ARect.Top, PicAdjust);\r\nend;\r\n\r\nprocedure TJvTFDays.CreatePicDrawList(ARect: TRect; Appt: TJvTFAppt;\r\n DrawList: TList);\r\nvar\r\n I, NextPicLeft, ImageIndex: Integer;\r\n ImageList: TCustomImageList;\r\n ImageMap: TJvTFStateImageMap;\r\n CustomImageMap: TJvTFCustomImageMap;\r\n\r\n procedure AddToList(AImageList: TCustomImageList; AImageIndex: Integer;\r\n AGlyph: TGraphic; APicLeft, APicTop: Integer);\r\n var\r\n DrawInfo: TJvTFDrawPicInfo;\r\n begin\r\n DrawInfo := TJvTFDrawPicInfo.Create;\r\n DrawInfo.ImageList := AImageList;\r\n DrawInfo.ImageIndex := AImageIndex;\r\n DrawInfo.Glyph := AGlyph;\r\n DrawInfo.PicLeft := APicLeft;\r\n DrawInfo.PicTop := APicTop;\r\n DrawList.Add(DrawInfo);\r\n end;\r\n\r\nbegin\r\n NextPicLeft := ARect.Left;\r\n\r\n if (agoShowPics in Options) and Assigned(Appt.Glyph.Graphic) and not Appt.Glyph.Graphic.Empty then\r\n begin\r\n AddToList(nil, -1, Appt.Glyph.Graphic, NextPicLeft, ARect.Top);\r\n Inc(NextPicLeft, Appt.Glyph.Graphic.Width + 2);\r\n end;\r\n\r\n if (agoShowPics in Options) and Assigned(ScheduleManager.CustomImages) then\r\n begin\r\n ImageList := ScheduleManager.CustomImages;\r\n CustomImageMap := Appt.ImageMap;\r\n\r\n for I := 0 to CustomImageMap.Count - 1 do\r\n begin\r\n ImageIndex := CustomImageMap[I];\r\n AddToList(ImageList, ImageIndex, nil, NextPicLeft, ARect.Top);\r\n Inc(NextPicLeft, ImageList.Width + 2);\r\n end;\r\n end;\r\n\r\n if (agoShowPics in Options) and Assigned(ScheduleManager.StateImages) then\r\n begin\r\n ImageList := ScheduleManager.StateImages;\r\n ImageMap := ScheduleManager.StateImageMap;\r\n\r\n if Appt.AlarmEnabled then\r\n begin\r\n ImageIndex := ImageMap.AlarmEnabled;\r\n if ImageIndex > -1 then\r\n begin\r\n AddToList(ImageList, ImageIndex, nil, NextPicLeft, ARect.Top);\r\n Inc(NextPicLeft, ImageList.Width + 2);\r\n end\r\n end\r\n else\r\n begin\r\n ImageIndex := ImageMap.AlarmDisabled;\r\n if ImageIndex > -1 then\r\n begin\r\n AddToList(ImageList, ImageIndex, nil, NextPicLeft, ARect.Top);\r\n Inc(NextPicLeft, ImageList.Width + 2);\r\n end;\r\n end;\r\n\r\n ImageIndex := ImageMap.Shared;\r\n if Appt.Shared and (ImageIndex > -1) then\r\n begin\r\n AddToList(ImageList, ImageIndex, nil, NextPicLeft, ARect.Top);\r\n Inc(NextPicLeft, ImageList.Width + 2);\r\n end;\r\n\r\n if Appt.Modified and (ImageMap.Modified > -1) then\r\n begin\r\n AddToList(ImageList, ImageMap.Modified, nil, NextPicLeft, ARect.Top);\r\n // The following line generates a compiler hint so comment out,\r\n // but leave here as reminder in case method is expanded.\r\n //Inc(NextPicLeft, ImageList.Width + 2);\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvTFDays.FilterPicDrawList(ARect: TRect; DrawList: TList;\r\n var PicsHeight: Integer; var PicsWidth: Integer);\r\nvar\r\n I, NextPicLeft: Integer;\r\n DrawIt: Boolean;\r\n DrawInfo: TJvTFDrawPicInfo;\r\nbegin\r\n PicsHeight := 0;\r\n PicsWidth := 0;\r\n if DrawList.Count = 0 then\r\n Exit;\r\n\r\n if Thresholds.PicsAllOrNone then\r\n begin\r\n DrawInfo := TJvTFDrawPicInfo(DrawList[DrawList.Count - 1]);\r\n if DrawInfo.PicLeft + DrawInfo.ImageList.Width >= ARect.Right then\r\n begin\r\n while DrawList.Count > 0 do\r\n begin\r\n TJvTFDrawPicInfo(DrawList[0]).Free;\r\n DrawList.Delete(0);\r\n end;\r\n end;\r\n end;\r\n\r\n NextPicLeft := ARect.Left;\r\n I := 0;\r\n while I < DrawList.Count do\r\n begin\r\n DrawInfo := TJvTFDrawPicInfo(DrawList[I]);\r\n with DrawInfo do\r\n begin\r\n DrawIt := True;\r\n// if Thresholds.WholePicsOnly and\r\n// ((PicLeft + ImageList.Width >= ARect.Right) or\r\n// (PicTop + ImageList.Height >= ARect.Bottom)) then\r\n// DrawIt := False;\r\n\r\n if DrawIt then\r\n begin\r\n if Assigned(ImageList) then\r\n PicsHeight := Greater(PicsHeight, ImageList.Height + 2)\r\n else\r\n PicsHeight := Greater(PicsHeight, Glyph.Height + 2);\r\n PicLeft := NextPicLeft;\r\n if Assigned(ImageList) then\r\n Inc(NextPicLeft, ImageList.Width + 2)\r\n else\r\n Inc(NextPicLeft, Glyph.Width + 2);\r\n // Increment I to move onto next pic in list\r\n Inc(I);\r\n end\r\n else // Remove pic from list\r\n begin\r\n // Remove pic from list\r\n DrawInfo.Free;\r\n DrawList.Delete(I);\r\n // DO NOT increment I - Since pic was removed from list\r\n // I will now point to next pic\r\n end;\r\n end;\r\n end;\r\n PicsWidth := NextPicLeft - ARect.Left;\r\nend;\r\n\r\nprocedure TJvTFDays.ClearPicDrawList(DrawList: TList);\r\nbegin\r\n while DrawList.Count > 0 do\r\n begin\r\n TJvTFDrawPicInfo(DrawList[0]).Free;\r\n DrawList.Delete(0);\r\n end;\r\nend;\r\n\r\nprocedure TJvTFDays.DrawListPics(ACanvas: TCanvas; var ARect: TRect;\r\n DrawList: TList);\r\nvar\r\n I: Integer;\r\n DrawInfo: TJvTFDrawPicInfo;\r\nbegin\r\n for I := 0 to DrawList.Count - 1 do\r\n begin\r\n DrawInfo := TJvTFDrawPicInfo(DrawList[I]);\r\n with DrawInfo do\r\n begin\r\n if Assigned(ImageList) then\r\n ImageList.Draw(ACanvas, PicLeft, PicTop, ImageIndex)\r\n else\r\n ACanvas.Draw(PicLeft, PicTop, Glyph);\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvTFDays.DrawGrabLines(ACanvas: TCanvas; LineTop, LineLeft,\r\n LineRight: Integer);\r\nbegin\r\n // This draws the 3D grab handles, which have been replaced by flat style\r\n // handles. This remains as reference for possible future comeback as option.\r\n with ACanvas do\r\n begin\r\n Pen.Width := 1;\r\n Pen.Color := clWhite;\r\n MoveTo(LineLeft, LineTop);\r\n LineTo(LineRight, LineTop);\r\n MoveTo(LineLeft, LineTop + 1);\r\n LineTo(LineLeft + 1, LineTop + 1);\r\n Pen.Color := clSilver;\r\n LineTo(LineRight - 1, LineTop + 1);\r\n Pen.Color := clGray;\r\n LineTo(LineRight, LineTop + 1);\r\n MoveTo(LineLeft, LineTop + 2);\r\n LineTo(LineRight, LineTop + 2);\r\n\r\n Pen.Color := clWhite;\r\n MoveTo(LineLeft, LineTop + 3);\r\n LineTo(LineRight, LineTop + 3);\r\n MoveTo(LineLeft, LineTop + 4);\r\n LineTo(LineLeft + 1, LineTop + 4);\r\n Pen.Color := clSilver;\r\n LineTo(LineRight - 1, LineTop + 4);\r\n Pen.Color := clGray;\r\n LineTo(LineRight, LineTop + 4);\r\n MoveTo(LineLeft, LineTop + 5);\r\n LineTo(LineRight, LineTop + 5);\r\n end\r\nend;\r\n\r\nprocedure TJvTFDays.DrawGrabHandle(ACanvas: TCanvas; ARect: TRect;\r\n AAppt: TJvTFAppt; TopHandle: Boolean);\r\nbegin\r\n with ACanvas do\r\n begin\r\n Pen.Color := clBlack;\r\n Pen.Width := 1;\r\n Brush.Color := GrabHandles.Color;\r\n Rectangle(ARect.Left, ARect.Top, ARect.Right, ARect.Bottom);\r\n end;\r\n if Assigned(FOnDrawGrabHandle) then\r\n FOnDrawGrabHandle(Self, ACanvas, ARect, AAppt, TopHandle);\r\nend;\r\n\r\nprocedure TJvTFDays.DrawCorner(ACanvas: TCanvas; Corner: TJvTFDaysCorner);\r\nvar\r\n ARect: TRect;\r\n CornerLeft: Integer;\r\nbegin\r\n case Corner of\r\n //group agcTopLeft : ARect := Classes.Rect(0, 0, RowHdrWidth, ColHdrHeight);\r\n agcTopLeft:\r\n {$IFDEF Jv_TIMEBLOCKS}\r\n // ok\r\n ARect := Classes.Rect(0, 0, CalcBlockRowHdrsWidth, CalcGroupColHdrsHeight);\r\n {$ELSE}\r\n // remove\r\n // ARect := Classes.Rect(0, 0, RowHdrWidth, CalcGroupColHdrsHeight);\r\n {$ENDIF Jv_TIMEBLOCKS}\r\n agcTopRight:\r\n begin\r\n CornerLeft := Lesser(CellRect(RightCol, -1).Right, ClientWidth - FVScrollBar.Width);\r\n //group ARect := Classes.Rect(CornerLeft, 0, ClientWidth, ColHdrHeight);\r\n ARect := Classes.Rect(CornerLeft, 0, ClientWidth, CalcGroupColHdrsHeight);\r\n end;\r\n agcBottomLeft:\r\n {$IFDEF Jv_TIMEBLOCKS}\r\n // ok\r\n ARect := Classes.Rect(0, ClientHeight - FHScrollBar.Height,\r\n CalcBlockRowHdrsWidth, ClientHeight);\r\n {$ELSE}\r\n // remove\r\n // ARect := Classes.Rect(0, ClientHeight - FHScrollBar.Height,\r\n // RowHdrWidth, ClientHeight);\r\n {$ENDIF Jv_TIMEBLOCKS}\r\n\r\n agcBottomRight:\r\n ARect := Classes.Rect(ClientWidth - FVScrollBar.Width - 1,\r\n ClientHeight - FHScrollBar.Height - 1, ClientWidth, ClientHeight);\r\n end;\r\n\r\n with ACanvas do\r\n begin\r\n Brush.Color := HdrAttr.Color;\r\n FillRect(ARect);\r\n\r\n if HdrAttr.Frame3D then\r\n {$IFDEF Jv_TIMEBLOCKS}\r\n // ok\r\n DrawFrame(ACanvas, ARect,\r\n not ((Corner = agcTopLeft) and not HdrAttr.Frame3D), GridLineColor)\r\n {$ELSE}\r\n // remove\r\n //DrawFrame(ACanvas, ARect,\r\n // not ((Corner = agcTopLeft) and not HdrAttr.Frame3D))\r\n {$ENDIF Jv_TIMEBLOCKS}\r\n else\r\n begin\r\n case Corner of\r\n agcTopLeft:\r\n if RowHdrType = rhFancy then\r\n begin\r\n Pen.Color := FancyRowHdrAttr.TickColor;\r\n MoveTo(ARect.Right - 1, ARect.Top);\r\n LineTo(ARect.Right - 1, ARect.Bottom - 1);\r\n MoveTo(ARect.Left, ARect.Bottom - 1);\r\n LineTo(ARect.Right, ARect.Bottom - 1);\r\n end\r\n else\r\n {$IFDEF Jv_TIMEBLOCKS}\r\n // ok\r\n DrawFrame(ACanvas, ARect, False, GridLineColor);\r\n {$ELSE}\r\n // remove\r\n //DrawFrame(ACanvas, ARect, False);\r\n {$ENDIF Jv_TIMEBLOCKS}\r\n agcTopRight:\r\n begin\r\n Pen.Color := clGray;\r\n MoveTo(ARect.Left, ARect.Bottom - 1);\r\n LineTo(ARect.Right, ARect.Bottom - 1);\r\n if VirtualCellRect(RightCol, -1).Right > ClientWidth - FVScrollBar.Width then\r\n begin\r\n MoveTo(ClientWidth - FVScrollBar.Width, ARect.Top);\r\n LineTo(ClientWidth - FVScrollBar.Width, ARect.Bottom - 1);\r\n end;\r\n end;\r\n agcBottomLeft:\r\n begin\r\n Pen.Color := clGray;\r\n MoveTo(ARect.Right - 1, ARect.Top);\r\n LineTo(ARect.Right - 1, ARect.Bottom);\r\n MoveTo(ARect.Left, ARect.Top);\r\n LineTo(ARect.Right - 1, ARect.Top);\r\n end;\r\n end;\r\n end;\r\n\r\n if Assigned(FOnDrawCorner) then\r\n FOnDrawCorner(Self, ACanvas, ARect, Corner);\r\n end;\r\nend;\r\n\r\nprocedure TJvTFDays.DrawRowHdr(ACanvas: TCanvas; Index: Integer);\r\nvar\r\n Rect: TRect;\r\n UseAttr: TJvTFDaysHdrAttr;\r\n Txt: string;\r\nbegin\r\n {$IFDEF Jv_TIMEBLOCKS}\r\n // ok\r\n Rect.Left := CalcBlockHdrWidth;\r\n {$ELSE}\r\n // remove\r\n //Rect.Left := 0;\r\n {$ENDIF Jv_TIMEBLOCKS}\r\n\r\n //group Rect.Top := ColHdrHeight + (Index - TopRow) * RowHeight;\r\n Rect.Top := CalcGroupColHdrsHeight + (Index - TopRow) * RowHeight;\r\n\r\n {$IFDEF Jv_TIMEBLOCKS}\r\n // ok\r\n Rect.Right := Rect.Left + RowHdrWidth;\r\n {$ELSE}\r\n // remove\r\n //Rect.Right := RowHdrWidth;\r\n {$ENDIF Jv_TIMEBLOCKS}\r\n\r\n Rect.Bottom := Rect.Top + RowHeight;\r\n\r\n Txt := FormatDateTime(TimeFormat, RowToTime(Index));\r\n\r\n if RowIsSelected(Index) then\r\n UseAttr := SelHdrAttr\r\n else\r\n UseAttr := HdrAttr;\r\n\r\n ACanvas.Brush.Color := UseAttr.Color;\r\n ACanvas.Font.Assign(UseAttr.Font);\r\n\r\n DrawTxt(ACanvas, Rect, Txt, taCenter, vaCenter);\r\n\r\n if (Index = FocusedRow) and Focused and ShowFocus then\r\n begin\r\n Windows.InflateRect(Rect, -2, -2);\r\n ManualFocusRect(ACanvas, Rect);\r\n Windows.InflateRect(Rect, 2, 2);\r\n end;\r\n\r\n {$IFDEF Jv_TIMEBLOCKS}\r\n // ok\r\n DrawFrame(ACanvas, Rect, UseAttr.Frame3D, UseAttr.FrameColor);\r\n {$ELSE}\r\n // remove\r\n //DrawFrame(ACanvas, ARect, UseAttr.Frame3D);\r\n {$ENDIF Jv_TIMEBLOCKS}\r\n\r\n if Assigned(FOnDrawRowHdr) then\r\n FOnDrawRowHdr(Self, ACanvas, Rect, Index, RowIsSelected(Index));\r\nend;\r\n\r\n{\r\nprocedure TJvTFDays.DrawColHdr(ACanvas: TCanvas; Index: Integer);\r\nvar\r\n ARect,\r\n TxtRect,\r\n CalcRect: TRect;\r\n Txt: string;\r\n PTxt: PChar;\r\n UseAttr: TJvTFDaysHdrAttr;\r\n Flags: UINT;\r\n TxtHt,\r\n TxtRectHt: Integer;\r\nbegin\r\n ARect := CellRect(Index, -1);\r\n\r\n //Txt := Copy(Cols[Index].Title, 1, Length(Cols[Index].Title));\r\n Txt := Cols[Index].Title;\r\n\r\n if ColIsSelected(Index) then\r\n UseAttr := SelHdrAttr\r\n else\r\n UseAttr := HdrAttr;\r\n\r\n ACanvas.Brush.Color := UseAttr.Color;\r\n ACanvas.Font.Assign(UseAttr.Font);\r\n\r\n Flags := DT_NOPREFIX or DT_CENTER;\r\n Case ColTitleStyle of\r\n ctsSingleClip : Flags := Flags or DT_SINGLELINE or DT_VCENTER;\r\n ctsSingleEllipsis: Flags := Flags or DT_END_ELLIPSIS or DT_SINGLELINE or\r\n DT_VCENTER;\r\n ctsMultiClip : Flags := Flags or DT_WORDBREAK;\r\n ctsMultiEllipsis : Flags := Flags or DT_END_ELLIPSIS or\r\n DT_WORDBREAK or DT_EDITCONTROL;\r\n ctsHide : Flags := Flags or DT_SINGLELINE or DT_VCENTER;\r\n end;\r\n\r\n ACanvas.FillRect(ARect);\r\n TxtRect := ARect;\r\n Windows.InflateRect(TxtRect, -2, -2);\r\n CalcRect := TxtRect;\r\n\r\n PTxt := StrNew(PChar(Txt));\r\n if (ColTitleStyle = ctsMultiClip) or\r\n (ColTitleStyle = ctsMultiEllipsis) then\r\n begin\r\n TxtHt := Windows.DrawText(ACanvas.Handle, PTxt, -1, CalcRect,\r\n Flags or DT_CALCRECT);\r\n\r\n if TxtHt < RectHeight(TxtRect) then\r\n begin\r\n // we need to vertically center the text\r\n TxtRectHt := RectHeight(TxtRect);\r\n TxtRect.Top := TxtRect.Top + RectHeight(TxtRect) div 2 - TxtHt div 2;\r\n TxtRect.Bottom := Lesser(TxtRect.Top + TxtRectHt, TxtRect.Bottom);\r\n end;\r\n end\r\n else\r\n if ColTitleStyle = ctsHide then\r\n begin\r\n Windows.DrawText(ACanvas.Handle, PTxt, -1, CalcRect, Flags or DT_CALCRECT);\r\n if RectWidth(CalcRect) > RectWidth(TxtRect) then\r\n PTxt := '';\r\n end;\r\n\r\n Windows.DrawText(ACanvas.Handle, PTxt, -1, TxtRect, Flags);\r\n\r\n if (Index = FocusedCol) and Focused then\r\n begin\r\n CalcRect := ARect;\r\n Windows.InflateRect(CalcRect, -2, -2);\r\n ManualFocusRect(ACanvas, CalcRect);\r\n {\r\n if Windows.IsRectEmpty(TxtRect) then\r\n Windows.InflateRect(TxtRect, 5, 5);\r\n ManualFocusRect(ACanvas, TxtRect);\r\n }\r\n{ end;\r\n\r\n DrawFrame(ACanvas, ARect, UseAttr.Frame3D);\r\n\r\n if Assigned(FOnDrawColHdr) then\r\n FOnDrawColHdr(Self, ACanvas, ARect, Index, ColIsSelected(Index));\r\nend;\r\n}\r\n\r\n// returns height in pixels of tallest col title\r\n// assumes word wrap and bounds all of title\r\n\r\nfunction TJvTFDays.GetTallestColTitle(ACanvas: TCanvas): Integer;\r\nvar\r\n I, Tallest, ColLeft, TxtHt: Integer;\r\n LRect: TRect;\r\n TheCol: TJvTFDaysCol;\r\n Txt: string;\r\n Flags: UINT;\r\nbegin\r\n {$IFDEF Jv_TIMEBLOCKS}\r\n // ok\r\n ColLeft := CalcBlockRowHdrsWidth;\r\n {$ELSE}\r\n // remove\r\n //ColLeft := RowHdrWidth;\r\n {$ENDIF Jv_TIMEBLOCKS}\r\n\r\n Tallest := 0;\r\n for I := 0 to Cols.Count - 1 do\r\n begin\r\n TheCol := Cols[I];\r\n\r\n // (rom) silly assignments\r\n // Just set top (0), left, and bottom (ColHdrHeight) for now.\r\n //group ARect := Classes.Rect(ColLeft, 0, 0, ColHdrHeight);\r\n LRect := Classes.Rect(ColLeft, CalcGroupHdrHeight, 0, CalcGroupColHdrsHeight);\r\n // Set right by adding this col's width to the left value\r\n LRect.Right := LRect.Left + TheCol.Width;\r\n LRect := CellRect(I, -1);\r\n Windows.InflateRect(LRect, -2, -2);\r\n\r\n Txt := Copy(TheCol.Title, 1, Length(TheCol.Title));\r\n\r\n if ColIsSelected(I) then\r\n begin\r\n ACanvas.Brush.Color := SelHdrAttr.Color;\r\n ACanvas.Font.Assign(SelHdrAttr.Font);\r\n end\r\n else\r\n begin\r\n ACanvas.Brush.Color := HdrAttr.Color;\r\n ACanvas.Font.Assign(HdrAttr.Font);\r\n end;\r\n\r\n // All parameters now specified. Now calc text height.\r\n Flags := DT_NOPREFIX or DT_WORDBREAK or DT_CENTER or DT_CALCRECT;\r\n TxtHt := Windows.DrawText(ACanvas.Handle, PChar(Txt), -1, LRect, Flags);\r\n\r\n if TxtHt > Tallest then\r\n Tallest := TxtHt;\r\n\r\n Inc(ColLeft, TheCol.Width);\r\n end;\r\n Result := Tallest;\r\nend;\r\n\r\n{$IFNDEF Jv_TIMEBLOCKS}\r\n// remove\r\n{\r\nprocedure TJvTFDays.DrawFrame(ACanvas: TCanvas; ARect: TRect; Draw3D: Boolean);\r\nvar\r\n OldPenColor: TColor;\r\nbegin\r\n OldPenColor := ACanvas.Pen.Color;\r\n\r\n if Draw3D then\r\n ACanvas.Pen.Color := clBtnShadow\r\n else\r\n ACanvas.Pen.Color := GridLineColor;\r\n\r\n ACanvas.MoveTo(ARect.Right - 1, ARect.Top);\r\n ACanvas.LineTo(ARect.Right - 1, ARect.Bottom);\r\n ACanvas.MoveTo(ARect.Left, ARect.Bottom - 1);\r\n ACanvas.LineTo(ARect.Right, ARect.Bottom - 1);\r\n\r\n if Draw3D then\r\n begin\r\n ACanvas.Pen.Color := clBtnHighlight;\r\n ACanvas.MoveTo(ARect.Left, ARect.Top);\r\n ACanvas.LineTo(ARect.Right, ARect.Top);\r\n ACanvas.MoveTo(ARect.Left, ARect.Top);\r\n ACanvas.LineTo(ARect.Left, ARect.Bottom);\r\n end;\r\n\r\n ACanvas.Pen.Color := OldPenColor;\r\nend;\r\n}\r\n{$ENDIF !Jv_TIMEBLOCKS}\r\n\r\nprocedure TJvTFDays.DrawAppts(ACanvas: TCanvas; DrawAll: Boolean);\r\nvar\r\n FromCol, ToCol, FromRow, ToRow, Col, I: Integer;\r\n ApptStartRow, ApptEndRow, SchedDate: Integer;\r\n Appt: TJvTFAppt;\r\n TempSelAppt: TJvTFAppt;\r\nbegin\r\n if DrawAll then\r\n begin\r\n FromCol := 0;\r\n ToCol := Cols.Count - 1;\r\n FromRow := 0;\r\n ToRow := RowCount - 1;\r\n end\r\n else\r\n begin\r\n FromCol := LeftCol;\r\n ToCol := RightCol;\r\n FromRow := TopRow;\r\n ToRow := BottomRow;\r\n end;\r\n\r\n for Col := FromCol to ToCol do\r\n if Cols[Col].Connected then\r\n begin\r\n TempSelAppt := nil;\r\n SchedDate := Trunc(Cols[Col].SchedDate);\r\n for I := 0 to Cols[Col].Schedule.ApptCount - 1 do\r\n begin\r\n Appt := Cols[Col].Schedule.Appts[I];\r\n // Added by Mike 10/31/01 7:04pm - Happy Haloween!!\r\n // We want to draw the selected appt last. Check to see if the\r\n // current appt is selected, if so, save a reference in TempSelAppt\r\n // and then use TempSelAppt to draw the appt after the loop finishes.\r\n // This solves the problem of having the bottom grab handle\r\n // overwritten by an appt that lies immediately below the sel appt.\r\n if Appt = SelAppt then\r\n TempSelAppt := Appt\r\n else\r\n begin\r\n CalcStartEndRows(Appt, SchedDate, ApptStartRow, ApptEndRow);\r\n\r\n if (ApptStartRow <= ToRow) and (ApptEndRow >= FromRow) then\r\n DrawAppt(ACanvas, Col, Appt, ApptStartRow, ApptEndRow);\r\n end;\r\n end;\r\n\r\n // Added by Mike 10/31/01 7:04 pm - see above\r\n if Assigned(TempSelAppt) then\r\n begin\r\n CalcStartEndRows(TempSelAppt, SchedDate, ApptStartRow, ApptEndRow);\r\n\r\n if (ApptStartRow <= ToRow) and (ApptEndRow >= FromRow) then\r\n DrawAppt(ACanvas, Col, TempSelAppt, ApptStartRow, ApptEndRow);\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvTFDays.AdjustForMargins(var ARect: TRect);\r\nbegin\r\n // Make room for side margins and grab handles\r\n // Changed by TIM:\r\n // Windows.InflateRect(ARect, -2, -2);\r\n Windows.InflateRect(ARect, -1, -1);\r\n\r\n // Commented out by Tim:\r\n // if agoMoveAppt in Options then\r\n // Inc(ARect.Top, GrabHandles.Height - 1);\r\n // if agoSizeAppt in Options then\r\n // Dec(ARect.Bottom, GrabHandles.Height - 1);\r\nend;\r\n\r\nprocedure TJvTFDays.CanDrawWhat(ACanvas: TCanvas; ApptRect: TRect;\r\n PicsHeight: Integer; var CanDrawText, CanDrawPics: Boolean);\r\n//var\r\n// TextHeightThreshold,\r\n// TextWidthThreshold: Integer;\r\nbegin\r\n// TextHeightThreshold := CanvasMaxTextHeight(ACanvas) * Thresholds.TextHeight;\r\n// TextWidthThreshold := ACanvas.TextWidth('Bi') div 2 * Thresholds.TextWidth;\r\n\r\n// if TextHeightThreshold + PicsHeight < RectHeight(ApptRect) then\r\n// begin\r\n// CanDrawText := RectWidth(ApptRect) >= TextWidthThreshold;\r\n// CanDrawPics := True;\r\n// end\r\n// else\r\n// if Thresholds.DropTextFirst then\r\n// begin\r\n// CanDrawText := False;\r\n// CanDrawPics := True;\r\n// if Thresholds.WholePicsOnly then\r\n// if PicsHeight > RectHeight(ApptRect) then\r\n// CanDrawPics := False;\r\n// end\r\n// else\r\n// begin\r\n// CanDrawText := (RectHeight(ApptRect) >= TextHeightThreshold) and\r\n// (RectWidth(ApptRect) >= TextWidthThreshold);\r\n// CanDrawPics := False;\r\n// end;\r\n\r\n CanDrawText := True;\r\n CanDrawPics := True;\r\n\r\n if not (agoShowPics in Options) then\r\n CanDrawPics := False;\r\n if not (agoShowText in Options) then\r\n CanDrawText := False;\r\nend;\r\n\r\nprocedure TJvTFDays.ManualFocusRect(ACanvas: TCanvas; ARect: TRect);\r\nvar\r\n Mark: Boolean;\r\n I: Integer;\r\n OldPenMode: TPenMode;\r\nbegin\r\n OldPenMode := ACanvas.Pen.Mode;\r\n ACanvas.Pen.Mode := pmNot;\r\n\r\n Mark := True;\r\n\r\n // Top side\r\n for I := ARect.Left to ARect.Right - 1 do\r\n begin\r\n if Mark then\r\n ACanvas.Pixels[I, ARect.Top] := clBlack;\r\n Mark := not Mark;\r\n end;\r\n\r\n // Right side\r\n for I := ARect.Top + 1 to ARect.Bottom - 1 do\r\n begin\r\n if Mark then\r\n ACanvas.Pixels[ARect.Right - 1, I] := clBlack;\r\n Mark := not Mark;\r\n end;\r\n\r\n // Bottom side\r\n for I := ARect.Right - 2 downto ARect.Left do\r\n begin\r\n if Mark then\r\n ACanvas.Pixels[I, ARect.Bottom - 1] := clBlack;\r\n Mark := not Mark;\r\n end;\r\n\r\n // Left side\r\n for I := ARect.Bottom - 2 downto ARect.Top + 1 do\r\n begin\r\n if Mark then\r\n ACanvas.Pixels[ARect.Left, I] := clBlack;\r\n Mark := not Mark;\r\n end;\r\n\r\n ACanvas.Pen.Mode := OldPenMode;\r\nend;\r\n\r\nprocedure TJvTFDays.DrawFancyRowHdrs(ACanvas: TCanvas);\r\nvar\r\n I, J, MajorTickLength, MinorTickLength, TickLength: Integer;\r\n LRect: TRect;\r\n Lbl: string;\r\n PrevHour, CurrentHour: Word;\r\n // FirstMajor,\r\n Selected, PrevHrSel, CurrHrSel, Switch: Boolean;\r\nbegin\r\n MajorTickLength := GetMajorTickLength;\r\n MinorTickLength := GetMinorTickLength;\r\n\r\n// FirstMajor := True;\r\n PrevHour := RowToHour(TopRow);\r\n PrevHrSel := False;\r\n CurrHrSel := False;\r\n for I := TopRow to BottomRow do\r\n begin\r\n CurrentHour := RowToHour(I);\r\n\r\n Switch := (CurrentHour <> PrevHour) or (I = BottomRow);\r\n if Switch then\r\n begin\r\n PrevHrSel := CurrHrSel;\r\n CurrHrSel := False;\r\n end;\r\n\r\n // Determine if this row is selected\r\n Selected := False;\r\n J := 0;\r\n while (J < Cols.Count) and not Selected do\r\n if CellIsSelected(Point(J, I)) then\r\n Selected := True\r\n else\r\n Inc(J);\r\n\r\n CurrHrSel := CurrHrSel or Selected;\r\n\r\n LRect := CellRect(-1, I);\r\n Lbl := GetMinorLabel(I);\r\n if not RowEndsHour(I) then\r\n TickLength := MinorTickLength\r\n else\r\n TickLength := MajorTickLength;\r\n\r\n DrawMinor(ACanvas, LRect, I, Lbl, TickLength, Selected);\r\n\r\n // Draw Major if needed\r\n if Switch and (Granularity <> 60) then\r\n begin\r\n if I <> TopRow + 1 then\r\n begin\r\n {$IFDEF Jv_TIMEBLOCKS}\r\n // ok\r\n LRect.Left := CalcBlockHdrWidth;\r\n LRect.Right := LRect.Left + RowHdrWidth - MinorTickLength;\r\n {$ELSE}\r\n // remove\r\n //LRect.Left := 0;\r\n //LRect.Right := RowHdrWidth - MinorTickLength;\r\n {$ENDIF Jv_TIMEBLOCKS}\r\n\r\n LRect.Top := VirtualCellRect(-1, HourStartRow(PrevHour)).Top;\r\n //group if LRect.Top < ColHdrHeight then\r\n //group LRect.Top := ColHdrHeight;\r\n if LRect.Top < CalcGroupColHdrsHeight then\r\n LRect.Top := CalcGroupColHdrsHeight;\r\n LRect.Bottom := VirtualCellRect(-1, HourEndRow(PrevHour)).Bottom - 1;\r\n if LRect.Bottom > ClientHeight then\r\n LRect.Bottom := ClientHeight;\r\n\r\n if FancyRowHdrAttr.Hr2400 then\r\n Lbl := IntToStr(PrevHour)\r\n else\r\n begin\r\n if PrevHour = 0 then\r\n Lbl := '12'\r\n else\r\n if PrevHour > 12 then\r\n Lbl := IntToStr(PrevHour - 12)\r\n else\r\n Lbl := IntToStr(PrevHour);\r\n\r\n{ if FirstMajor or (PrevHour = 0) or (PrevHour = 12) then\r\n if PrevHour < 12 then\r\n Lbl := Lbl + 'a'\r\n else\r\n Lbl := Lbl + 'p';\r\n}\r\n end;\r\n\r\n if PrevHrSel then\r\n ACanvas.Font.Assign(SelFancyRowHdrAttr.MajorFont)\r\n else\r\n ACanvas.Font.Assign(FancyRowHdrAttr.MajorFont);\r\n\r\n ACanvas.Brush.Style := bsClear;\r\n\r\n Windows.DrawText(ACanvas.Handle, PChar(Lbl), -1, LRect,\r\n DT_NOPREFIX or DT_SINGLELINE or DT_CENTER or DT_VCENTER);\r\n\r\n if Assigned(FOnDrawMajorRowHdr) then\r\n FOnDrawMajorRowHdr(Self, ACanvas, LRect, I - 1, PrevHrSel);\r\n\r\n// FirstMajor := False;\r\n end;\r\n if Switch then\r\n PrevHour := CurrentHour;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvTFDays.DrawMinor(ACanvas: TCanvas; ARect: TRect; RowNum: Integer;\r\n const LabelStr: string; TickLength: Integer; Selected: Boolean);\r\nvar\r\n Attr: TJvTFDaysFancyRowHdrAttr;\r\n MinorRect, TxtRect: TRect;\r\nbegin\r\n // do the background shading\r\n ACanvas.Brush.Color := FancyRowHdrAttr.Color;\r\n ACanvas.FillRect(ARect);\r\n\r\n MinorRect := ARect;\r\n MinorRect.Left := (MinorRect.Right - GetMinorTickLength) div 2;\r\n\r\n if Selected then\r\n begin\r\n Attr := SelFancyRowHdrAttr;\r\n // Shade the minor rect if selected\r\n ACanvas.Brush.Color := Attr.Color;\r\n ACanvas.FillRect(MinorRect);\r\n end\r\n else\r\n Attr := FancyRowHdrAttr;\r\n\r\n with ACanvas do\r\n begin\r\n // draw the right border line\r\n Pen.Color := Attr.TickColor;\r\n MoveTo(ARect.Right - 1, ARect.Top);\r\n LineTo(ARect.Right - 1, ARect.Bottom);\r\n\r\n // now draw the tick\r\n MoveTo(ARect.Right - 5, ARect.Bottom - 1);\r\n LineTo(ARect.Right - 5 - TickLength, ARect.Bottom - 1);\r\n end;\r\n\r\n // set up a 2 pel margin on the right and bottom sides\r\n TxtRect := ARect;\r\n TxtRect.Right := TxtRect.Right - 6;\r\n TxtRect.Bottom := TxtRect.Bottom - 2;\r\n\r\n // now draw the LabelStr right aligned\r\n ACanvas.Font.Assign(Attr.MinorFont);\r\n ACanvas.Brush.Style := bsClear;\r\n\r\n // draw the focus rect if needed\r\n if (RowNum = FocusedRow) and Focused and ShowFocus then\r\n begin\r\n Windows.InflateRect(MinorRect, -2, -2);\r\n MinorRect.Left := MinorRect.Right - ACanvas.TextWidth(LabelStr) - 2;\r\n ManualFocusRect(ACanvas, MinorRect);\r\n end;\r\n\r\n Windows.DrawText(ACanvas.Handle, PChar(LabelStr), -1, TxtRect,\r\n DT_SINGLELINE or DT_RIGHT or DT_NOPREFIX or DT_VCENTER);\r\n\r\n if Assigned(FOnDrawMinorRowHdr) then\r\n FOnDrawMinorRowHdr(Self, ACanvas, ARect, RowNum, Selected);\r\nend;\r\n\r\nfunction TJvTFDays.GetMinorLabel(RowNum: Integer): string;\r\nconst\r\n Full24 = 'h:nn';\r\n FullAP = 'h:nna/p';\r\n MinOnly = ':nn';\r\nvar\r\n FirstHourRow: Integer;\r\n TimeFmt: string;\r\n RowTime: TTime;\r\n// LastFullRow, LastHourStart: Integer;\r\n// LastHour: Word;\r\nbegin\r\n if Granularity = 60 then\r\n TimeFmt := Full24\r\n else\r\n TimeFmt := MinOnly;\r\n// else\r\n// if (RowNum = TopRow) and (not RowStartsHour(RowNum) or (PossVisibleRows = 1)) then\r\n// TimeFmt := Full24\r\n// else\r\n// begin\r\n// LastFullRow := TopRow + FullVisibleRows - 1;\r\n// LastHour := RowToHour(LastFullRow);\r\n// LastHourStart := HourStartRow(LastHour);\r\n//\r\n// if (RowNum = LastHourStart) or\r\n// ((LastHourStart = TopRow) and (RowNum = TopRow)) then\r\n// TimeFmt := Full24\r\n// else\r\n// TimeFmt := MinOnly;\r\n// end;\r\n\r\n if (TimeFmt = Full24) and not FancyRowHdrAttr.Hr2400 then\r\n TimeFmt := FullAP;\r\n\r\n // Get the Row Time\r\n RowTime := RowToTime(RowNum);\r\n\r\n if (FancyRowHdrAttr.OnlyShow00Minutes and (ExtractMins(RowTime) = 0)) or\r\n (not FancyRowHdrAttr.OnlyShow00Minutes) then\r\n begin\r\n if (not FancyRowHdrAttr.Hr2400) and (Granularity < 60) then\r\n begin\r\n // Get the first row with a 00 hour\r\n FirstHourRow := TopRow;\r\n while (FirstHourRow < BottomRow) and (ExtractMins(RowToTime(FirstHourRow)) <> 0) do\r\n Inc(FirstHourRow);\r\n if RowTime = 0 then\r\n Result := {$IFDEF RTL220_UP}FormatSettings.{$ENDIF RTL220_UP}TimeAMString\r\n else\r\n if RowTime = 0.50 then\r\n Result := {$IFDEF RTL220_UP}FormatSettings.{$ENDIF RTL220_UP}TimePMString\r\n else\r\n if (RowNum = FirstHourRow) and (ExtractMins(RowTime) = 0) then\r\n begin\r\n if RowTime < 0.50 then\r\n Result := {$IFDEF RTL220_UP}FormatSettings.{$ENDIF RTL220_UP}TimeAMString\r\n else\r\n Result := {$IFDEF RTL220_UP}FormatSettings.{$ENDIF RTL220_UP}TimePMString;\r\n end\r\n else\r\n Result := FormatDateTime(TimeFmt, RowTime);\r\n end\r\n else\r\n Result := FormatDateTime(TimeFmt, RowTime);\r\n end\r\n else\r\n Result := '';\r\nend;\r\n\r\nfunction TJvTFDays.GetMinorTickLength: Integer;\r\nvar\r\n TempFont: TFont;\r\nbegin\r\n TempFont := TFont.Create;\r\n try\r\n TempFont.Assign(Canvas.Font);\r\n Canvas.Font.Assign(FancyRowHdrAttr.MinorFont);\r\n Result := Canvas.TextWidth('22:22a') - 10;\r\n Canvas.Font.Assign(TempFont);\r\n finally\r\n TempFont.Free;\r\n end;\r\nend;\r\n\r\nfunction TJvTFDays.GetMajorTickLength: Integer;\r\nbegin\r\n Result := RowHdrWidth - 8;\r\nend;\r\n\r\nprocedure TJvTFDays.Resize;\r\nvar\r\n ColsResized: Boolean;\r\nbegin\r\n if Editing then\r\n FinishEditAppt;\r\n AlignScrollBars;\r\n\r\n if not (csLoading in ComponentState) then\r\n begin\r\n if RowHeight > GetDataHeight then\r\n RowHeight := GetDataHeight;\r\n\r\n Cols.EnsureMaxColWidth;\r\n\r\n if AutoSizeCols then\r\n begin\r\n ColsResized := CheckSBVis;\r\n if not (vsbHorz in VisibleScrollBars) and not ColsResized then\r\n Cols.ResizeCols;\r\n end\r\n else\r\n CheckSBVis;\r\n end;\r\n\r\n CheckSBParams;\r\n\r\n inherited Resize;\r\nend;\r\n\r\nprocedure TJvTFDays.WMEraseBkgnd(var Msg: TMessage);\r\nbegin\r\n Msg.Result := LRESULT(False);\r\nend;\r\n\r\nprocedure TJvTFDays.CMFontChanged(var Msg: TMessage);\r\nbegin\r\n HdrAttr.ParentFontChanged;\r\n SelHdrAttr.ParentFontChanged;\r\n ApptAttr.ParentFontChanged;\r\n SelApptAttr.ParentFontChanged;\r\n inherited;\r\nend;\r\n\r\nprocedure TJvTFDays.CMEnabledChanged(var Msg: TMessage);\r\nbegin\r\n FVScrollBar.Enabled := Enabled;\r\n FHScrollBar.Enabled := Enabled;\r\n Invalidate;\r\n\r\n if Enabled and FNeedCheckSBParams then\r\n begin\r\n // This is needed because of a TScrollBar bug. If the Max or LargeChange\r\n // properties are changed while the scrollbar is disabled, the\r\n // scrollbar will magically enable itself. Very frustrating. Anyway...\r\n // This check and call to CheckSBParams will work around the problem.\r\n // See TJvTFDays.CheckSBParams for other part of workaround.\r\n FNeedCheckSBParams := False;\r\n CheckSBParams;\r\n end;\r\nend;\r\n\r\nprocedure TJvTFDays.WMSetCursor(var Msg: TWMSetCursor);\r\nvar\r\n Cur: HCURSOR;\r\n Coord: TJvTFDaysCoord;\r\nbegin\r\n Cur := 0;\r\n with Msg do\r\n if HitTest = HTCLIENT then\r\n begin\r\n Coord := PtToCell(FHitTest.X, FHitTest.Y);\r\n case CanDragWhat(Coord) of\r\n agsSizeCol, agsSizeRowHdr:\r\n Cur := Screen.Cursors[crHSplit];\r\n agsSizeRow, agsSizeColHdr:\r\n Cur := Screen.Cursors[crVSplit];\r\n agsSizeAppt:\r\n Cur := Screen.Cursors[crSizeNS];\r\n agsMoveAppt:\r\n Cur := Screen.Cursors[crDrag];\r\n end;\r\n end;\r\n\r\n if Cur <> 0 then\r\n SetCursor(Cur)\r\n else\r\n inherited;\r\nend;\r\n\r\nprocedure TJvTFDays.WMNCHitTest(var Msg: TWMNCHitTest);\r\nbegin\r\n DefaultHandler(Msg);\r\n FHitTest := ScreenToClient(SmallPointToPoint(Msg.Pos));\r\nend;\r\n\r\nprocedure TJvTFDays.CMDesignHitTest(var Msg: TCMDesignHitTest);\r\nvar\r\n TempState: TJvTFDaysState;\r\n Coord: TJvTFDaysCoord;\r\nbegin\r\n Coord := PtToCell(Msg.Pos.X, Msg.Pos.Y);\r\n\r\n TempState := CanDragWhat(Coord);\r\n Msg.Result := LRESULT(Ord(TempState <> agsNormal));\r\nend;\r\n\r\nprocedure TJvTFDays.CNRequestRefresh(var Msg: TCNRequestRefresh);\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := 0 to Cols.Count - 1 do\r\n if (Cols[I].Schedule = Msg.Schedule) or (Msg.Schedule = nil) then\r\n Cols[I].RefreshMap;\r\n inherited;\r\nend;\r\n\r\nprocedure TJvTFDays.Loaded;\r\nvar\r\n I: Integer;\r\nbegin\r\n FHScrollBar.Position := LeftCol;\r\n FVScrollBar.Position := TopRow;\r\n inherited Loaded;\r\n CheckSBVis;\r\n CheckSBParams;\r\n\r\n Template.UpdateGrid;\r\n\r\n Cols.FOldCount := Cols.Count;\r\n\r\n for I := 0 to Cols.Count - 1 do\r\n Cols[I].Connect;\r\n\r\n AlignScrollBars;\r\nend;\r\n\r\nprocedure TJvTFDays.RefreshControl;\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := 0 to Cols.Count - 1 do\r\n // Should do some additional checking here (which is commented out)\r\n //if (Cols[I].Schedule = Msg.Schedule) or (Msg.Schedule = nil) then\r\n Cols[I].RefreshMap;\r\n inherited RefreshControl;\r\nend;\r\n\r\nprocedure TJvTFDays.UpdateDesigner;\r\nvar\r\n ParentForm: TCustomForm;\r\nbegin\r\n if (csDesigning in ComponentState) and HandleAllocated and\r\n not (csUpdating in ComponentState) then\r\n begin\r\n ParentForm := GetParentForm(Self);\r\n if Assigned(ParentForm) and Assigned(ParentForm.Designer) then\r\n ParentForm.Designer.Modified;\r\n end;\r\nend;\r\n\r\nprocedure TJvTFDays.CheckSBParams;\r\nvar\r\n I, TempWidth, RightCol: Integer;\r\nbegin\r\n if not Enabled then\r\n begin\r\n // This is needed because of a TScrollBar bug. if the Max or LargeChange\r\n // properties are changed while the scrollbar is disabled, the\r\n // scrollbar will magically enable itself. Very frustrating. Anyway...\r\n // This check and exit will workaround the problem.\r\n // See TJvTFDays.CMEnabledChanged for other part of workaround.\r\n FNeedCheckSBParams := True;\r\n Exit;\r\n end;\r\n\r\n if vsbVert in VisibleScrollBars then\r\n with FVScrollBar do\r\n begin\r\n Max := RowCount - 2;\r\n LargeChange := FullVisibleRows;\r\n end;\r\n\r\n if vsbHorz in VisibleScrollBars then\r\n with FHScrollBar do\r\n begin\r\n Max := Cols.Count - 1;\r\n RightCol := LeftCol + VisibleCols - 1;\r\n\r\n TempWidth := 0;\r\n for I := LeftCol to RightCol do\r\n Inc(TempWidth, Cols[I].Width);\r\n\r\n if TempWidth <= RectWidth(GetDataAreaRect) then\r\n LargeChange := VisibleCols\r\n else\r\n LargeChange := VisibleCols - 1;\r\n end;\r\nend;\r\n\r\nprocedure TJvTFDays.ScrollBarScroll(Sender: TObject;\r\n ScrollCode: TScrollCode; var ScrollPos: Integer);\r\nvar\r\n SB: TJvTFDaysScrollBar;\r\n I, TempWidth: Integer;\r\nbegin\r\n if csLoading in ComponentState then\r\n Exit;\r\n\r\n if not (csDesigning in ComponentState) then\r\n SetFocus;\r\n\r\n if Editing then\r\n FinishEditAppt;\r\n\r\n SB := TJvTFDaysScrollBar(Sender);\r\n\r\n case ScrollCode of\r\n scLineUp, scLineDown, scPageUp, scPageDown, scTrack:\r\n if SB.Kind = sbVertical then\r\n begin\r\n if (ScrollCode = scLineDown) or (ScrollCode = scPageDown) then\r\n ScrollPos := Lesser(ScrollPos, RowCount - FullVisibleRows);\r\n TopRow := ScrollPos;\r\n UpdateDesigner;\r\n end\r\n else\r\n begin\r\n if ScrollPos > LeftCol then\r\n begin\r\n TempWidth := 0;\r\n for I := LeftCol to Cols.Count - 1 do\r\n Inc(TempWidth, Cols[I].Width);\r\n if TempWidth <= GetDataWidth then\r\n ScrollPos := LeftCol;\r\n end;\r\n LeftCol := ScrollPos;\r\n UpdateDesigner;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvTFDays.MouseDown(Button: TMouseButton;\r\n Shift: TShiftState; X, Y: Integer);\r\nvar\r\n GridCoord: TJvTFDaysCoord;\r\n DragWhat: TJvTFDaysState;\r\nbegin\r\n if not Enabled then\r\n Exit;\r\n\r\n FHint.ReleaseHandle;\r\n\r\n inherited;\r\n\r\n if ssDouble in Shift then\r\n Exit;\r\n\r\n if not (csDesigning in ComponentState) then\r\n SetFocus;\r\n\r\n GridCoord := PtToCell(X, Y);\r\n\r\n if ssLeft in Shift then\r\n with GridCoord do\r\n begin\r\n SetSelAppt(Appt);\r\n // need to recalculate GridCoord here because component user may have\r\n // freed the appt (esp. in a multi-user environment).\r\n GridCoord := PtToCell(X, Y);\r\n\r\n if Col > gcHdr then\r\n FocusedCol := Col;\r\n if Row > gcHdr then\r\n FocusedRow := Row;\r\n\r\n if (Col > gcHdr) and (Row > gcHdr) then\r\n SelStart := Point(Col, Row)\r\n else\r\n if (Col = gcHdr) and (Row > gcHdr) then\r\n SelStart := Point(FocusedCol, Row)\r\n else\r\n if (Col > gcHdr) and (Row = gcHdr) then\r\n SelStart := Point(Col, FocusedRow);\r\n end;\r\n\r\n if (State = agsNormal) and (ssLeft in Shift) then\r\n begin\r\n DragWhat := CanDragWhat(GridCoord);\r\n case DragWhat of\r\n agsSizeCol, agsSizeRow, agsSizeColHdr, agsSizeRowHdr,\r\n agsMoveCol, agsSizeAppt:\r\n BeginDragging(GridCoord, DragWhat, GridCoord.Appt);\r\n agsMoveAppt:\r\n BeginDrag(False);\r\n agsNormal:\r\n if Assigned(SelAppt) then\r\n EditAppt(GridCoord.Col, SelAppt);\r\n end;\r\n\r\n if DragWhat in [agsSizeAppt, agsMoveAppt, agsNormal] then\r\n begin\r\n FAutoScrollDir := asdNowhere;\r\n FLiveTimer := True;\r\n Windows.SetTimer(Handle, 1, 60, nil);\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvTFDays.MouseMove(Shift: TShiftState; X, Y: Integer);\r\nvar\r\n GridCoord: TJvTFDaysCoord;\r\n AutoScrollMargin: TRect;\r\n SelStartDate, SelEndDate: TDate;\r\n SelStartTime, SelEndTime: TTime;\r\n OldFSelEnd, HintTopLeft: TPoint;\r\n FSelEndChanged: Boolean;\r\n\r\n procedure UpdateAutoScroll;\r\n begin\r\n AutoScrollMargin := GetDataAreaRect;\r\n //Windows.InflateRect(AutoScrollMargin, -10, -10);\r\n\r\n if Y < AutoScrollMargin.Top then\r\n FAutoScrollDir := asdUp\r\n else\r\n if Y > AutoScrollMargin.Bottom then\r\n FAutoScrollDir := asdDown\r\n else\r\n if X < AutoScrollMargin.Left then\r\n FAutoScrollDir := asdLeft\r\n else\r\n if X > AutoScrollMargin.Right then\r\n FAutoScrollDir := asdRight\r\n else\r\n FAutoScrollDir := asdNowhere;\r\n end;\r\n\r\nbegin\r\n if not Enabled then\r\n Exit;\r\n\r\n inherited MouseMove(Shift, X, Y);\r\n\r\n GridCoord := PtToCell(X, Y);\r\n\r\n if State = agsNormal then\r\n if Assigned(GridCoord.Appt) then\r\n DoApptHint(GridCoord)\r\n else\r\n DoCellHint(GridCoord);\r\n\r\n if not Focused and not (csDesigning in ComponentState) then\r\n Exit;\r\n\r\n FMouseMovePt := Point(X, Y);\r\n FMouseMoveState := Shift;\r\n\r\n case State of\r\n agsNormal:\r\n if ssLeft in Shift then\r\n begin\r\n with GridCoord do\r\n begin\r\n if Col > gcHdr then\r\n FocusedCol := Col\r\n else\r\n FocusedCol := LeftCol;\r\n\r\n if Row > gcHdr then\r\n FocusedRow := Lesser(Row, Lesser(RowCount - 1, BottomRow + 1))\r\n else\r\n if FAutoScrollDir = asdDown then\r\n FocusedRow := RowCount - 1\r\n else\r\n FocusedRow := TopRow;\r\n end;\r\n OldFSelEnd := FSelEnd;\r\n SelEnd := Point(FocusedCol, FocusedRow);\r\n FSelEndChanged := (OldFSelEnd.X <> FSelEnd.X) or\r\n (OldFSelEnd.Y <> FSelEnd.Y);\r\n\r\n if (agoShowSelHint in Options) and\r\n (SelStart.X > gcHdr) and (SelStart.Y > gcHdr) and\r\n (SelEnd.X > gcHdr) and (SelEnd.Y > gcHdr) and\r\n ((SelStart.X <> SelEnd.X) or (SelStart.Y <> SelEnd.Y)) then\r\n begin\r\n HintTopLeft := CellRect(GridCoord.Col, GridCoord.Row).TopLeft;\r\n if FSelEndChanged then\r\n begin\r\n SelStartDate := Cols[SelStart.X].SchedDate;\r\n SelStartTime := RowToTime(SelStart.Y);\r\n SelEndDate := Cols[SelEnd.X].SchedDate;\r\n SelEndTime := RowToTime(SelEnd.Y) +\r\n EncodeTime(0, Granularity - 1, 0, 0);\r\n\r\n FHint.StartEndHint(SelStartDate, SelEndDate, SelStartTime,\r\n SelEndTime, HintTopLeft.X,\r\n HintTopLeft.Y, True);\r\n\r\n end\r\n end\r\n else\r\n FHint.ReleaseHandle;\r\n\r\n UpdateAutoScroll;\r\n end;\r\n agsSizeCol..agsMoveCol:\r\n ContinueDragging(GridCoord, nil);\r\n agsSizeAppt:\r\n begin\r\n UpdateAutoScroll;\r\n\r\n if Y > GetDataAreaRect.Bottom then\r\n GridCoord.Row := Lesser(BottomRow + 1, RowCount - 1);\r\n\r\n if FAutoScrollDir = asdNowhere then\r\n ContinueDragging(GridCoord, nil);\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvTFDays.MouseUp(Button: TMouseButton; Shift: TShiftState;\r\n X, Y: Integer);\r\nvar\r\n GridCoord: TJvTFDaysCoord;\r\nbegin\r\n if not Enabled then\r\n Exit;\r\n\r\n inherited MouseUp(Button, Shift, X, Y);\r\n\r\n if not Focused and not (csDesigning in ComponentState) then\r\n Exit;\r\n\r\n KillAutoScrollTimer;\r\n\r\n GridCoord := PtToCell(X, Y);\r\n\r\n case State of\r\n agsSizeCol..agsSizeAppt:\r\n EndDragging(GridCoord, nil);\r\n agsNormal:\r\n FHint.ReleaseHandle;\r\n end;\r\nend;\r\n\r\nprocedure TJvTFDays.DblClick;\r\nbegin\r\n if Editing then\r\n FinishEditAppt;\r\n inherited DblClick;\r\nend;\r\n\r\nprocedure TJvTFDays.DoStartDrag(var DragObject: TDragObject);\r\nbegin\r\n if Editing then\r\n FinishEditAppt;\r\n\r\n inherited DoStartDrag(DragObject);\r\n\r\n FDragInfo.Appt := SelAppt;\r\n\r\n if FocusedCol > gcHdr then\r\n FDragInfo.Schedule := Cols[FocusedCol].Schedule;\r\nend;\r\n\r\nprocedure TJvTFDays.DragOver(Source: TObject; X, Y: Integer;\r\n State: TDragState; var Accept: Boolean);\r\nvar\r\n GridCoord: TJvTFDaysCoord;\r\n Appt: TJvTFAppt;\r\n SrcDragInfo: TJvTFDragInfo;\r\n AutoScrollMargin: TRect;\r\n\r\n procedure UpdateAutoScroll;\r\n begin\r\n AutoScrollMargin := GetDataAreaRect;\r\n Windows.InflateRect(AutoScrollMargin, -10, -10);\r\n\r\n if Y < AutoScrollMargin.Top then\r\n FAutoScrollDir := asdUp\r\n else\r\n if Y > AutoScrollMargin.Bottom then\r\n FAutoScrollDir := asdDown\r\n else\r\n if X < AutoScrollMargin.Left then\r\n FAutoScrollDir := asdLeft\r\n else\r\n if X > AutoScrollMargin.Right then\r\n FAutoScrollDir := asdRight\r\n else\r\n FAutoScrollDir := asdNowhere;\r\n end;\r\n\r\nbegin\r\n inherited DragOver(Source, X, Y, State, Accept);\r\n if Source is TJvTFControl then\r\n begin\r\n SrcDragInfo := TJvTFControl(Source).DragInfo;\r\n GridCoord := PtToCell(X, Y);\r\n Accept := GridCoord.DragAccept;\r\n Appt := SrcDragInfo.Appt;\r\n\r\n case State of\r\n dsDragEnter:\r\n begin\r\n if not Assigned(FDragInfo) then\r\n FDragInfo := SrcDragInfo;\r\n BeginDragging(GridCoord, agsMoveAppt, Appt);\r\n end;\r\n dsDragLeave:\r\n begin\r\n EndDragging(GridCoord, Appt);\r\n if FDragInfo.ApptCtrl <> Self then\r\n FDragInfo := nil;\r\n end;\r\n dsDragMove:\r\n begin\r\n FMouseMovePt := Point(X, Y);\r\n UpdateAutoScroll;\r\n\r\n if Y > GetDataAreaRect.Bottom then\r\n GridCoord.Row := Lesser(BottomRow + 1, RowCount - 1);\r\n\r\n if FAutoScrollDir = asdNowhere then\r\n ContinueDragging(GridCoord, Appt);\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvTFDays.DoEndDrag(Target: TObject; X, Y: Integer);\r\nbegin\r\n KillAutoScrollTimer;\r\n FState := agsNormal;\r\n inherited DoEndDrag(Target, X, Y);\r\nend;\r\n\r\nprocedure TJvTFDays.DropAppt(DragInfo: TJvTFDragInfo; X, Y: Integer);\r\nconst\r\n cClassName = 'TJvTFCustomGlance';\r\nvar\r\n Appt: TJvTFAppt;\r\n Coord: TJvTFDaysCoord;\r\n Confirm, SchedNameChange, StartDateChange, Share: Boolean;\r\n NewSchedName: string;\r\n NewStartDate, NewEndDate: TDate;\r\n NewStartTime: TTime;\r\n NewEndTime: TDateTime;\r\n NewStartDT, NewEndDT: TDateTime;\r\nbegin\r\n FHint.ReleaseHandle;\r\n // APPOINTMENT CAN ONLY BE DROPPED IN THE DATA AREA !!!\r\n Appt := DragInfo.Appt;\r\n\r\n // Calc new info\r\n // DragAppt.Shift --> Ctrl = share, Shift = keep dates, Alt = keep times\r\n Coord := PtToCell(X, Y);\r\n NewSchedName := Cols[Coord.Col].SchedName;\r\n CalcMoveStartEnd(Appt, Coord, ssShift in DragInfo.Shift,\r\n ssAlt in DragInfo.Shift, NewStartDT, NewEndDT);\r\n\r\n NewStartDate := Trunc(NewStartDT);\r\n NewStartTime := Frac(NewStartDT);\r\n NewEndDate := Trunc(NewEndDT);\r\n NewEndTime := Frac(NewEndDT);\r\n\r\n // Do a confirm drop event\r\n Confirm := True;\r\n if Assigned(FOnDropAppt) then\r\n FOnDropAppt(Appt, NewSchedName, NewStartDate, NewStartTime,\r\n NewEndDate, NewEndTime, ssCtrl in DragInfo.Shift, Confirm);\r\n\r\n if Confirm then\r\n begin\r\n //SchedNameChange := NewSchedName <> DragInfo.Schedule.SchedName;\r\n SchedNameChange := IsClassByName(DragInfo.ApptCtrl, cClassName) or\r\n (NewSchedName <> DragInfo.Schedule.SchedName);\r\n StartDateChange := (Trunc(NewStartDate) <> Trunc(Appt.StartDate)) or\r\n (Trunc(NewEndDate) <> Trunc(Appt.EndDate));\r\n Share := ssCtrl in DragInfo.Shift;\r\n\r\n Appt.BeginUpdate;\r\n try\r\n if (SchedNameChange and not StartDateChange and not Share) or\r\n (not SchedNameChange and StartDateChange and not Share) or\r\n (SchedNameChange and StartDateChange and not Share) or\r\n (not SchedNameChange and StartDateChange and Share) or\r\n (SchedNameChange and StartDateChange and Share) then\r\n begin\r\n if DragInfo.ApptCtrl is TJvTFDays then\r\n Appt.RemoveSchedule(DragInfo.Schedule.SchedName)\r\n else\r\n if IsClassByName(DragInfo.ApptCtrl, cClassName) then\r\n Appt.ClearSchedules;\r\n\r\n // THE FOLLOWING CODE SHOULD NOT BE NECESSARY.\r\n // Make sure the old schedules get refreshed\r\n {\r\n aDate := Appt.StartDate;\r\n while Trunc(aDate) <= Trunc(Appt.EndDate) do\r\n begin\r\n Sched := ScheduleManager.FindSchedule(DragInfo.Schedule.SchedName, aDate);\r\n if Assigned(Sched) then\r\n ScheduleManager.RefreshConnections(Sched);\r\n aDate := aDate + 1;\r\n end;\r\n }\r\n end;\r\n\r\n // Now we set the new StartEnd\r\n Appt.SetStartEnd(NewStartDate, NewStartTime, NewEndDate, NewEndTime);\r\n // if there's a change in SchedName then add the appt to the schedule\r\n Appt.AddSchedule(NewSchedName);\r\n // THE FOLLOWING CODE SHOULD NOT BE NECESSARY.\r\n //ScheduleManager.RefreshConnections(Appt);\r\n finally\r\n Appt.EndUpdate;\r\n end;\r\n end;\r\n\r\n if DragInfo.ApptCtrl <> Self then\r\n FState := agsNormal;\r\nend;\r\n\r\nprocedure TJvTFDays.BeginDragging(Coord: TJvTFDaysCoord;\r\n DragWhat: TJvTFDaysState; Appt: TJvTFAppt);\r\nbegin\r\n Update;\r\n\r\n FState := DragWhat;\r\n FBeginDraggingCoord := Coord;\r\n FDraggingCoord := Coord;\r\n if (State <> agsMoveAppt) or Coord.DragAccept then\r\n DrawDrag(Coord, Appt, False);\r\nend;\r\n\r\nprocedure TJvTFDays.DrawDrag(Coord: TJvTFDaysCoord; AAppt: TJvTFAppt;\r\n Clear: Boolean);\r\nvar\r\n OldPen: TPen;\r\n DragRect: TRect;\r\n I, LineLeft, StartRow, EndRow, DragRectHt: Integer;\r\n Sched: TJvTFSched;\r\n StartDT, EndDT: TDateTime;\r\n SchedName: string;\r\n\r\n procedure DrawFrame(ARect: TRect);\r\n begin\r\n Canvas.MoveTo(ARect.Left, ARect.Top);\r\n Canvas.LineTo(ARect.Right - 2, ARect.Top);\r\n Canvas.LineTo(ARect.Right - 2, ARect.Bottom - 2);\r\n Canvas.LineTo(ARect.Left, ARect.Bottom - 2);\r\n Canvas.LineTo(ARect.Left, ARect.Top);\r\n end;\r\n\r\nbegin\r\n if ((State = agsSizeAppt) and not Assigned(Coord.Schedule)) or\r\n ((State = agsMoveAppt) and ((Coord.Row < 0) or (Coord.Col < 0))) then\r\n Exit;\r\n\r\n OldPen := TPen.Create;\r\n try\r\n with Canvas, Coord do\r\n begin\r\n OldPen.Assign(Pen);\r\n Pen.Style := psDot;\r\n Pen.Mode := pmXOR;\r\n Pen.Width := 1;\r\n\r\n case State of\r\n agsSizeCol, agsSizeRowHdr:\r\n begin\r\n MoveTo(AbsX, 0);\r\n LineTo(AbsX, ClientHeight);\r\n end;\r\n agsSizeRow, agsSizeColHdr:\r\n begin\r\n MoveTo(0, AbsY);\r\n LineTo(ClientWidth, AbsY);\r\n end;\r\n agsMoveCol:\r\n begin\r\n Pen.Mode := pmNotXOR;\r\n Pen.Style := psSolid;\r\n Pen.Width := 3;\r\n\r\n LineLeft := AbsX - CellX;\r\n if FDraggingCoord.Col > FBeginDraggingCoord.Col then\r\n Inc(LineLeft, Cols[FDraggingCoord.Col].Width);\r\n\r\n MoveTo(LineLeft, 0);\r\n LineTo(LineLeft, ClientHeight);\r\n end;\r\n agsSizeAppt:\r\n begin\r\n Pen.Style := psSolid;\r\n Pen.Mode := pmNotXOR;\r\n\r\n AAppt := FBeginDraggingCoord.Appt;\r\n\r\n CalcSizeEndTime(AAppt, EndDT);\r\n\r\n if Clear and FHint.HandleAllocated then\r\n begin\r\n FHint.ReleaseHandle;\r\n // Control must be updated here. if not, drag lines will\r\n // not be drawn properly.\r\n Update;\r\n end;\r\n\r\n SchedName := Coord.Schedule.SchedName;\r\n for I := 0 to Cols.Count - 1 do\r\n begin\r\n Sched := Cols[I].Schedule;\r\n if Assigned(Sched) and (Sched.SchedName = SchedName) and\r\n ((Trunc(Sched.SchedDate) >= Trunc(AAppt.StartDate)) and\r\n (Trunc(Sched.SchedDate) <= Trunc(EndDT))) then\r\n begin\r\n //Calc Start and end rows\r\n if Trunc(Sched.SchedDate) = Trunc(AAppt.StartDate) then\r\n StartRow := TimeToRow(AAppt.StartTime)\r\n else\r\n StartRow := 0;\r\n if Trunc(Sched.SchedDate) = Trunc(EndDT) then\r\n EndRow := TimeToRow(AdjustEndTime(EndDT))\r\n else\r\n EndRow := RowCount - 1;\r\n\r\n DragRectHt := (EndRow - StartRow + 1) * RowHeight;\r\n DragRect := VirtualCellRect(I, StartRow);\r\n DragRect.Bottom := DragRect.Top + DragRectHt;\r\n\r\n DragRect.Top := Greater(DragRect.Top, GetDataAreaRect.Top);\r\n DragRect.Bottom := Lesser(DragRect.Bottom, GetDataAreaRect.Bottom);\r\n\r\n DrawFrame(DragRect);\r\n end;\r\n end;\r\n\r\n if not Clear and (agoShowApptHints in Options) then\r\n FHint.StartEndHint(AAppt.StartDate, Trunc(EndDT),\r\n AAppt.StartTime, Frac(EndDT), DragRect.Left + 2,\r\n DragRect.Bottom + 2, True);\r\n end;\r\n agsMoveAppt:\r\n begin\r\n Pen.Style := psSolid;\r\n Pen.Mode := pmNotXOR;\r\n\r\n Coord.Row := Greater(0, Greater(Coord.Row, TopRow - 1));\r\n\r\n CalcMoveStartEnd(AAppt, Coord, ssShift in FDragInfo.Shift,\r\n ssAlt in FDragInfo.Shift, StartDT, EndDT);\r\n\r\n if Clear and FHint.HandleAllocated then\r\n begin\r\n FHint.ReleaseHandle;\r\n Update;\r\n end;\r\n\r\n if Assigned(Coord.Schedule) then\r\n SchedName := Coord.Schedule.SchedName;\r\n DragRect := Classes.Rect(-1, -1, -1, -1); // Used to not show hint if outside a valid day.\r\n for I := 0 to Cols.Count - 1 do\r\n begin\r\n Sched := Cols[I].Schedule;\r\n if Assigned(Sched) and (Sched.SchedName = SchedName) and\r\n ((Trunc(Sched.SchedDate) >= Trunc(StartDT)) and\r\n (Trunc(Sched.SchedDate) <= Trunc(EndDT))) then\r\n begin\r\n //Calc Start and end rows\r\n if Trunc(Sched.SchedDate) = Trunc(StartDT) then\r\n StartRow := TimeToRow(StartDT)\r\n else\r\n StartRow := 0;\r\n if Trunc(Sched.SchedDate) = Trunc(EndDT) then\r\n EndRow := TimeToRow(AdjustEndTime(EndDT))\r\n else\r\n EndRow := RowCount - 1;\r\n\r\n DragRectHt := (EndRow - StartRow + 1) * RowHeight;\r\n DragRect := VirtualCellRect(I, StartRow);\r\n DragRect.Bottom := DragRect.Top + DragRectHt;\r\n DragRect.Top := Greater(DragRect.Top, GetDataAreaRect.Top);\r\n DrawFrame(DragRect);\r\n end;\r\n end;\r\n if not Clear and (agoShowApptHints in Options) and\r\n (DragRect.Top <> -1) and (DragRect.Left <> -1) and\r\n (DragRect.Right <> -1) and (DragRect.Bottom <> -1) then\r\n FHint.StartEndHint(Trunc(StartDT), Trunc(EndDT),\r\n Frac(StartDT), Frac(EndDT),\r\n DragRect.Right + 2, DragRect.Top + 2,\r\n True);\r\n end;\r\n end;\r\n end;\r\n finally\r\n Canvas.Pen.Assign(OldPen);\r\n OldPen.Free;\r\n end;\r\nend;\r\n\r\nprocedure TJvTFDays.ContinueDragging(Coord: TJvTFDaysCoord; Appt: TJvTFAppt);\r\nvar\r\n ValidDrag, SameSchedName, ValidEnd, DiffCoord: Boolean;\r\n SameDateLaterTime, LaterDate, DoDrawDrag: Boolean;\r\n OldLeft, NewLeft: Integer;\r\nbegin\r\n if State = agsSizeAppt then\r\n begin\r\n Coord.Row := Greater(Coord.Row, TopRow);\r\n Coord.Row := Lesser(Coord.Row, BottomRow);\r\n end;\r\n\r\n DoDrawDrag := False;\r\n\r\n case State of\r\n agsSizeCol, agsSizeRowHdr, agsSizeRow, agsSizeColHdr:\r\n DoDrawDrag := True;\r\n agsMoveCol:\r\n begin\r\n OldLeft := FDraggingCoord.AbsX - FDraggingCoord.CellX;\r\n NewLeft := Coord.AbsX - Coord.CellX;\r\n DoDrawDrag := (OldLeft <> NewLeft) and\r\n (Coord.Row = gcHdr) and (Coord.Col > gcHdr);\r\n end;\r\n agsSizeAppt:\r\n begin\r\n SameSchedName := False;\r\n ValidEnd := False;\r\n DiffCoord := False;\r\n ValidDrag := Assigned(FBeginDraggingCoord.Schedule) and\r\n Assigned(FDraggingCoord.Schedule) and Assigned(Coord.Schedule);\r\n if ValidDrag then\r\n begin\r\n SameSchedName :=\r\n FDraggingCoord.Schedule.SchedName = FBeginDraggingCoord.Schedule.SchedName;\r\n LaterDate := (Trunc(Coord.Schedule.SchedDate) > Trunc(FBeginDraggingCoord.Appt.StartDate)) and\r\n (Coord.Row >= 0);\r\n SameDateLaterTime :=\r\n (Trunc(Coord.Schedule.SchedDate) = Trunc(FBeginDraggingCoord.Appt.StartDate)) and\r\n (Coord.Row >= TimeToRow(FBeginDraggingCoord.Appt.StartTime));\r\n ValidEnd := LaterDate or SameDateLaterTime;\r\n DiffCoord := not ((Coord.Row = FDraggingCoord.Row) and (Coord.Col = FDraggingCoord.Col));\r\n end;\r\n DoDrawDrag := ValidDrag and SameSchedName and ValidEnd and DiffCoord;\r\n end;\r\n agsMoveAppt:\r\n DoDrawDrag := (Coord.Col <> FDraggingCoord.Col) or (Coord.Row <> FDraggingCoord.Row);\r\n end;\r\n\r\n if DoDrawDrag then\r\n begin\r\n if (State <> agsMoveAppt) or FDraggingCoord.DragAccept then\r\n DrawDrag(FDraggingCoord, Appt, True); // clear old line\r\n FDraggingCoord := Coord;\r\n if (State <> agsMoveAppt) or FDraggingCoord.DragAccept then\r\n DrawDrag(FDraggingCoord, Appt, False); // draw new line\r\n end;\r\nend;\r\n\r\nprocedure TJvTFDays.EndDragging(Coord: TJvTFDaysCoord; Appt: TJvTFAppt);\r\nvar\r\n Confirm: Boolean;\r\n ColNum, DeltaSize, NewSize: Integer;\r\n NewEndDT: TDateTime;\r\nbegin\r\n Confirm := True;\r\n try\r\n if (State <> agsMoveAppt) or FDraggingCoord.DragAccept then\r\n DrawDrag(FDraggingCoord, Appt, True); // clear old line\r\n\r\n case State of\r\n agsSizeCol:\r\n begin\r\n ColNum := FBeginDraggingCoord.Col;\r\n DeltaSize := Coord.AbsX - FBeginDraggingCoord.AbsX;\r\n NewSize := Cols[ColNum].Width + DeltaSize;\r\n\r\n if Assigned(FOnSizeCol) then\r\n FOnSizeCol(Self, ColNum, NewSize, Confirm);\r\n\r\n if Confirm then\r\n begin\r\n Cols[ColNum].Width := NewSize;\r\n UpdateDesigner;\r\n end;\r\n end;\r\n agsSizeRow:\r\n begin\r\n DeltaSize := Coord.AbsY - FBeginDraggingCoord.AbsY;\r\n NewSize := RowHeight + DeltaSize;\r\n\r\n if Assigned(FOnSizeRow) then\r\n FOnSizeRow(Self, 0, NewSize, Confirm);\r\n\r\n if Confirm then\r\n begin\r\n RowHeight := NewSize;\r\n UpdateDesigner;\r\n end;\r\n end;\r\n agsSizeColHdr:\r\n begin\r\n DeltaSize := Coord.AbsY - FBeginDraggingCoord.AbsY;\r\n NewSize := ColHdrHeight + DeltaSize;\r\n\r\n if Assigned(FOnSizeColHdr) then\r\n FOnSizeColHdr(Self, 0, NewSize, Confirm);\r\n\r\n if Confirm then\r\n begin\r\n ColHdrHeight := NewSize;\r\n UpdateDesigner;\r\n end;\r\n end;\r\n agsSizeRowHdr:\r\n begin\r\n DeltaSize := Coord.AbsX - FBeginDraggingCoord.AbsX;\r\n NewSize := RowHdrWidth + DeltaSize;\r\n\r\n if Assigned(FOnSizeRowHdr) then\r\n FOnSizeRowHdr(Self, 0, NewSize, Confirm);\r\n\r\n if Confirm then\r\n begin\r\n RowHdrWidth := NewSize;\r\n UpdateDesigner;\r\n end;\r\n end;\r\n agsMoveCol:\r\n begin\r\n NewSize := FDraggingCoord.Col;\r\n if Assigned(FOnMoveCol) then\r\n FOnMoveCol(Self, FBeginDraggingCoord.Col, NewSize, Confirm);\r\n\r\n if Confirm then\r\n begin\r\n Cols.MoveCol(FBeginDraggingCoord.Col, NewSize);\r\n UpdateDesigner;\r\n end;\r\n end;\r\n agsSizeAppt:\r\n begin\r\n FHint.ReleaseHandle;\r\n Appt := FBeginDraggingCoord.Appt;\r\n CalcSizeEndTime(Appt, NewEndDT);\r\n\r\n if Assigned(FOnSizeAppt) then\r\n FOnSizeAppt(Self, Appt, NewEndDT, Confirm);\r\n\r\n if Confirm then\r\n begin\r\n // WHY AM I CALLING RefreshControls HERE?????\r\n ScheduleManager.RefreshConnections(Appt);\r\n Appt.SetStartEnd(Appt.StartDate, Appt.StartTime,\r\n Trunc(NewEndDT), Frac(NewEndDT));\r\n ScheduleManager.RefreshConnections(Appt);\r\n end;\r\n end;\r\n //agsMoveAppt: nothing special here - see DropAppt method\r\n end;\r\n finally\r\n // Don't reset state if moving appt. State will be reset in DoEndDrag\r\n // and/or DropAppt methods. Resetting State here will cause problems when\r\n // dragging between multiple appt controls.\r\n if State <> agsMoveAppt then\r\n FState := agsNormal;\r\n end;\r\nend;\r\n\r\nfunction TJvTFDays.CanDragWhat(Coord: TJvTFDaysCoord): TJvTFDaysState;\r\nvar\r\n TopHandleRect, BottomHandleRect: TRect;\r\nbegin\r\n case State of\r\n agsSizeCol, agsSizeRow, agsSizeColHdr, agsSizeRowHdr,\r\n agsMoveCol, agsSizeAppt, agsMoveAppt:\r\n begin\r\n Result := State;\r\n Exit;\r\n end;\r\n else\r\n Result := agsNormal;\r\n end;\r\n\r\n with Coord do\r\n begin\r\n if ((agoSizeCols in Options) or (csDesigning in ComponentState)) and\r\n (Row = gcHdr) and (Col > gcHdr) and\r\n (CellX > Cols[Col].Width - SizingThreshold) then\r\n begin\r\n Result := agsSizeCol;\r\n Exit;\r\n end;\r\n\r\n if ((agoSizeRows in Options) or (csDesigning in ComponentState)) and\r\n (Row > gcHdr) and (Col = gcHdr) and\r\n (CellY > RowHeight - SizingThreshold) then\r\n begin\r\n Result := agsSizeRow;\r\n Exit;\r\n end;\r\n\r\n if ((agoSizeColHdr in Options) or (csDesigning in ComponentState)) and\r\n (Row = gcHdr) and (Col > gcUndef) and\r\n (CellY > ColHdrHeight - SizingThreshold) then\r\n begin\r\n Result := agsSizeColHdr;\r\n Exit;\r\n end;\r\n\r\n if ((agoSizeRowHdr in Options) or (csDesigning in ComponentState)) and\r\n (Row > gcUndef) and (Col = gcHdr) and\r\n (CellX > RowHdrWidth - SizingThreshold) then\r\n begin\r\n Result := agsSizeRowHdr;\r\n Exit;\r\n end;\r\n\r\n if ((agoMoveCols in Options) or (csDesigning in ComponentState)) and\r\n (Coord.Row = gcHdr) and (Coord.Col > gcHdr) and\r\n not (Template.ActiveTemplate = agtLinear) and\r\n ((State = agsNormal) or (State = agsMoveCol)) and\r\n (Cols.Count > 1) then\r\n begin\r\n Result := agsMoveCol;\r\n Exit;\r\n end;\r\n\r\n // move grab handles\r\n if Assigned(SelAppt) then\r\n begin\r\n TopHandleRect := GetTopGrabHandleRect(Col, SelAppt);\r\n BottomHandleRect := GetBottomGrabHandleRect(Col, SelAppt);\r\n if Windows.PtInRect(TopHandleRect, Point(AbsX, AbsY)) and\r\n (agoMoveAppt in Options) then\r\n Result := agsMoveAppt\r\n else\r\n if Windows.PtInRect(BottomHandleRect, Point(AbsX, AbsY)) and\r\n (agoSizeAppt in Options) then\r\n Result := agsSizeAppt;\r\n end;\r\n\r\n// if ((agoSizeAppt in Options) or (agoMoveAppt in Options)) and\r\n// Assigned(Appt) and (Appt = SelAppt) then\r\n// begin\r\n// ApptRect := GetApptRect(Col, Appt);\r\n// if (AbsY <= ApptRect.Top + GrabHandles.Height - 1) and\r\n// (agoMoveAppt in Options) then\r\n// begin\r\n// Result := agsMoveAppt;\r\n// Exit;\r\n// end\r\n// else\r\n// if (AbsY >= ApptRect.Bottom - GrabHandles.Height + 1) and\r\n// (agoSizeAppt in Options) then\r\n// begin\r\n// Result := agsSizeAppt;\r\n// Exit;\r\n// end;\r\n// end;\r\n end;\r\nend;\r\n\r\nprocedure TJvTFDays.CalcSizeEndTime(Appt: TJvTFAppt; var NewEndDT: TDateTime);\r\nvar\r\n TimeOffset: TTime;\r\n Sched: TJvTFSched;\r\nbegin\r\n Sched := FDraggingCoord.Schedule;\r\n if (Sched.SchedName = FBeginDraggingCoord.Schedule.SchedName) and\r\n (Trunc(Sched.SchedDate) >= Trunc(Appt.StartDate)) then\r\n if agoSnapSize in Options then\r\n if FDraggingCoord.Row <> RowCount - 1 then\r\n NewEndDT := Trunc(Sched.SchedDate) + Frac(RowToTime(FDraggingCoord.Row + 1))\r\n else\r\n NewEndDT := Trunc(Sched.SchedDate) + Frac(RowEndTime(FDraggingCoord.Row))\r\n else\r\n begin\r\n TimeOffset := Frac(Appt.EndTime) -\r\n Frac(RowToTime(TimeToRow(AdjustEndTime(Appt.EndTime))));\r\n NewEndDT := Trunc(Sched.SchedDate) +\r\n Frac(RowToTime(FDraggingCoord.Row)) + TimeOffset;\r\n end\r\n else\r\n NewEndDT := Trunc(Appt.EndDate) + Frac(Appt.EndTime);\r\nend;\r\n\r\n{$IFNDEF Jv_TIMEBLOCKS}\r\n// remove\r\n{\r\nprocedure TJvTFDays.CalcMoveStartEnd(Appt: TJvTFAppt; Coord: TJvTFDaysCoord;\r\n KeepDates, KeepTimes: Boolean; var StartDT, EndDT: TDateTime);\r\nvar\r\n NewStart,\r\n NewEnd: TDateTime;\r\nbegin\r\n NewStart := Trunc(Cols[Coord.Col].SchedDate) + Frac(RowToTime(Coord.Row));\r\n if not (agoSnapMove in Options) then\r\n NewStart := NewStart +\r\n Frac(Appt.StartTime) - RowToTime(TimeToRow(Appt.StartTime));\r\n\r\n NewEnd := (Trunc(Appt.EndDate) + Frac(Appt.EndTime)) -\r\n (Trunc(Appt.StartDate) + Frac(Appt.StartTime)) +\r\n NewStart;\r\n\r\n if KeepDates then\r\n begin\r\n NewStart := Trunc(Appt.StartDate) + Frac(NewStart);\r\n NewEnd := Trunc(Appt.EndDate) + Frac(NewEnd);\r\n end;\r\n\r\n if KeepTimes then\r\n begin\r\n NewStart := Trunc(NewStart) + Frac(Appt.StartTime);\r\n NewEnd := Trunc(NewEnd) + Frac(Appt.EndTime);\r\n end;\r\n\r\n StartDT := NewStart;\r\n EndDT := NewEnd;\r\nend;\r\n}\r\n{$ENDIF !Jv_TIMEBLOCKS}\r\n\r\n{$IFDEF Jv_TIMEBLOCKS}\r\n// ok\r\nprocedure TJvTFDays.CalcMoveStartEnd(Appt: TJvTFAppt; Coord: TJvTFDaysCoord;\r\n KeepDates, KeepTimes: Boolean; var StartDT, EndDT: TDateTime);\r\nvar\r\n NewStart, NewEnd: TDateTime;\r\n TimeBlockIndex, BlockStartRow, BlockEndRow: Integer;\r\n BlockStartTime, BlockEndTime: TTime;\r\n H, M, S, MS: Word;\r\nbegin\r\n TimeBlockIndex := RowToTimeBlock(Coord.Row);\r\n if TimeBlockProps.SnapMove and (TimeBlockIndex > -1) then\r\n begin\r\n GetTimeBlockStartEnd(TimeBlockIndex, BlockStartRow, BlockEndRow);\r\n BlockStartTime := RowToTime(BlockStartRow);\r\n BlockEndTime := RowEndTime(BlockEndRow);\r\n NewStart := Trunc(Cols[Coord.Col].SchedDate) + Frac(BlockStartTime);\r\n NewEnd := Trunc(NewStart) + Frac(BlockEndTime);\r\n end\r\n else\r\n begin\r\n NewStart := Trunc(Cols[Coord.Col].SchedDate) + Frac(RowToTime(Coord.Row));\r\n if not (agoSnapMove in Options) then\r\n NewStart := NewStart +\r\n Frac(Appt.StartTime) - RowToTime(TimeToRow(Appt.StartTime));\r\n\r\n NewEnd := (Trunc(Appt.EndDate) + Frac(Appt.EndTime)) -\r\n (Trunc(Appt.StartDate) + Frac(Appt.StartTime)) +\r\n NewStart;\r\n\r\n // NewEnd cannot fall exactly on midnight. Bad things happen.\r\n DecodeTime(NewEnd, H, M, S, MS);\r\n if (H = 0) and (M = 0) and (S = 0) then\r\n NewEnd := NewEnd - ONE_SECOND;\r\n\r\n if KeepDates then\r\n begin\r\n NewStart := Trunc(Appt.StartDate) + Frac(NewStart);\r\n NewEnd := Trunc(Appt.EndDate) + Frac(NewEnd);\r\n end;\r\n\r\n if KeepTimes then\r\n begin\r\n NewStart := Trunc(NewStart) + Frac(Appt.StartTime);\r\n NewEnd := Trunc(NewEnd) + Frac(Appt.EndTime);\r\n end;\r\n end;\r\n\r\n StartDT := NewStart;\r\n EndDT := NewEnd;\r\nend;\r\n{$ENDIF Jv_TIMEBLOCKS}\r\n\r\nprocedure TJvTFDays.EnsureCol(ACol: Integer);\r\nbegin\r\n if (ACol < 0) or (ACol > Cols.Count - 1) then\r\n raise EJvTFDaysError.CreateRes(@RsEColumnIndexOutOfBounds);\r\nend;\r\n\r\nprocedure TJvTFDays.EnsureRow(ARow: Integer);\r\nbegin\r\n if (ARow < 0) or (ARow > RowCount - 1) then\r\n raise EJvTFDaysError.CreateRes(@RsERowIndexOutOfBounds);\r\nend;\r\n\r\nprocedure TJvTFDays.KeyDown(var Key: Word; Shift: TShiftState);\r\nvar\r\n H: Word;\r\n Handled: Boolean;\r\n\r\n procedure DoSel;\r\n begin\r\n if ssShift in Shift then\r\n SelEnd := Point(FocusedCol, FocusedRow)\r\n else\r\n SelStart := Point(FocusedCol, FocusedRow);\r\n ColInView(FocusedCol);\r\n RowInView(FocusedRow);\r\n end;\r\n\r\nbegin\r\n Handled := True;\r\n inherited KeyDown(Key, Shift);\r\n\r\n case Key of\r\n VK_RETURN:\r\n if ssAlt in Shift then\r\n EditAppt(FocusedCol, SelAppt);\r\n VK_UP:\r\n if ssCtrl in Shift then\r\n ScrollDays(-7)\r\n else\r\n if ssAlt in Shift then\r\n SelPrevAppt\r\n else\r\n begin\r\n FocusedRow := Greater(FocusedRow - 1, 0);\r\n DoSel;\r\n end;\r\n VK_DOWN:\r\n if ssCtrl in Shift then\r\n ScrollDays(7)\r\n else\r\n if ssAlt in Shift then\r\n SelNextAppt\r\n else\r\n begin\r\n FocusedRow := Lesser(FocusedRow + 1, RowCount - 1);\r\n DoSel;\r\n end;\r\n VK_RIGHT:\r\n if ssCtrl in Shift then\r\n NextDate\r\n else\r\n if ssAlt in Shift then\r\n SelFirstApptNextCol\r\n else\r\n begin\r\n FocusedCol := Lesser(FocusedCol + 1, Cols.Count - 1);\r\n DoSel;\r\n end;\r\n VK_LEFT:\r\n if ssCtrl in Shift then\r\n PrevDate\r\n else\r\n if ssAlt in Shift then\r\n SelFirstApptPrevCol\r\n else\r\n begin\r\n FocusedCol := Greater(FocusedCol - 1, 0);\r\n DoSel;\r\n end;\r\n VK_PRIOR:\r\n if ssCtrl in Shift then\r\n ScrollMonths(-1)\r\n else\r\n begin\r\n TopRow := Greater(TopRow - FullVisibleRows, 0);\r\n FocusedRow := Greater(FocusedRow - FullVisibleRows, TopRow);\r\n DoSel;\r\n end;\r\n VK_NEXT:\r\n if ssCtrl in Shift then\r\n ScrollMonths(1)\r\n else\r\n begin\r\n TopRow := Lesser(TopRow + FullVisibleRows, RowCount - FullVisibleRows);\r\n FocusedRow := Lesser(FocusedRow + FullVisibleRows, RowCount - 1);\r\n DoSel;\r\n end;\r\n VK_HOME:\r\n if ssCtrl in Shift then\r\n TopRow := TimeToRow(PrimeTime.StartTime)\r\n else\r\n begin\r\n TopRow := 0;\r\n FocusedRow := 0;\r\n DoSel;\r\n end;\r\n VK_END:\r\n if ssCtrl in Shift then\r\n RowInView(TimeToRow(AdjustEndTime(PrimeTime.EndTime)))\r\n else\r\n begin\r\n RowInView(RowCount - 1);\r\n FocusedRow := RowCount - 1;\r\n DoSel;\r\n end;\r\n VK_F1..VK_F12:\r\n if ssCtrl in Shift then\r\n begin\r\n H := Key - VK_F1 + 1;\r\n if ssShift in Shift then\r\n Inc(H, 12);\r\n if Key = VK_F12 then\r\n Dec(H, 12);\r\n RowInView(TimeToRow(EncodeTime(H, 0, 0, 0)));\r\n end;\r\n VK_INSERT:\r\n if Shift = [ssCtrl] then\r\n case Granularity of\r\n 2:\r\n Granularity := 1;\r\n 3:\r\n Granularity := 2;\r\n 4:\r\n Granularity := 3;\r\n 5:\r\n Granularity := 4;\r\n 6:\r\n Granularity := 5;\r\n 10:\r\n Granularity := 6;\r\n 12:\r\n Granularity := 10;\r\n 15:\r\n Granularity := 12;\r\n 20:\r\n Granularity := 15;\r\n 30:\r\n Granularity := 20;\r\n 60:\r\n Granularity := 30;\r\n end\r\n else\r\n if Shift = [ssShift] then\r\n DoInsertSchedule\r\n else\r\n if Shift = [] then\r\n DoInsertAppt;\r\n VK_DELETE:\r\n if Shift = [ssCtrl] then\r\n case Granularity of\r\n 1:\r\n Granularity := 2;\r\n 2:\r\n Granularity := 3;\r\n 3:\r\n Granularity := 4;\r\n 4:\r\n Granularity := 5;\r\n 5:\r\n Granularity := 6;\r\n 6:\r\n Granularity := 10;\r\n 10:\r\n Granularity := 12;\r\n 12:\r\n Granularity := 15;\r\n 15:\r\n Granularity := 20;\r\n 20:\r\n Granularity := 30;\r\n 30:\r\n Granularity := 60;\r\n end\r\n else\r\n if Shift = [ssShift] then\r\n DoDeleteSchedule\r\n else\r\n if Shift = [] then\r\n DoDeleteAppt;\r\n else\r\n Handled := False;\r\n end;\r\n\r\n if Handled then\r\n Key := 0;\r\nend;\r\n\r\nprocedure TJvTFDays.KeyPress(var Key: Char);\r\nbegin\r\n inherited KeyPress(Key);\r\n QuickEntry(Key);\r\nend;\r\n\r\nprocedure TJvTFDays.DoInsertSchedule;\r\nbegin\r\n if Assigned(FOnInsertSchedule) then\r\n FOnInsertSchedule(Self);\r\nend;\r\n\r\nprocedure TJvTFDays.DoInsertAppt;\r\nbegin\r\n if Assigned(FOnInsertAppt) then\r\n FOnInsertAppt(Self);\r\nend;\r\n\r\nprocedure TJvTFDays.DoDeleteAppt;\r\nbegin\r\n if Assigned(FOnDeleteAppt) then\r\n FOnDeleteAppt(Self);\r\nend;\r\n\r\nprocedure TJvTFDays.DoDeleteSchedule;\r\nbegin\r\n if Assigned(FOnDeleteSchedule) then\r\n FOnDeleteSchedule(Self);\r\nend;\r\n\r\nfunction TJvTFDays.DoMouseWheelDown(Shift: TShiftState;\r\n MousePos: TPoint): Boolean;\r\nbegin\r\n Result := inherited DoMouseWheelDown(Shift, MousePos);\r\n if not Result then\r\n begin\r\n if TopRow < RowCount - FullVisibleRows then\r\n TopRow := TopRow + 1;\r\n Result := True;\r\n end;\r\nend;\r\n\r\nfunction TJvTFDays.DoMouseWheelUp(Shift: TShiftState;\r\n MousePos: TPoint): Boolean;\r\nbegin\r\n Result := inherited DoMouseWheelUp(Shift, MousePos);\r\n if not Result then\r\n begin\r\n if TopRow > 0 then\r\n TopRow := TopRow - 1;\r\n Result := True;\r\n end;\r\nend;\r\n\r\nprocedure TJvTFDays.DestroyApptNotification(AAppt: TJvTFAppt);\r\nbegin\r\n if AAppt = SelAppt then\r\n SelAppt := nil;\r\n inherited DestroyApptNotification(AAppt);\r\nend;\r\n\r\nprocedure TJvTFDays.CMMouseLeave(var Msg: TMessage);\r\nbegin\r\n FHint.ReleaseHandle;\r\n inherited;\r\nend;\r\n\r\nprocedure TJvTFDays.DoEnter;\r\nbegin\r\n inherited DoEnter;\r\n if Assigned(FOnFocusedColChanged) then\r\n FOnFocusedColChanged(Self);\r\n if Assigned(FOnFocusedRowChanged) then\r\n FOnFocusedRowChanged(Self);\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvTFDays.DoExit;\r\nbegin\r\n if Assigned(FOnFocusedColChanged) then\r\n FOnFocusedColChanged(Self);\r\n if Assigned(FOnFocusedRowChanged) then\r\n FOnFocusedRowChanged(Self);\r\n Invalidate;\r\n inherited DoExit;\r\nend;\r\n\r\nfunction TJvTFDays.GetSelStart: TPoint;\r\nbegin\r\n // This routine will always return the start of the selection regardless\r\n // of whether FSelStart and FSelEnd are in the correct order or not.\r\n if FFromToSel then\r\n if (FSelStart.X < FSelEnd.X) or\r\n ((FSelStart.X = FSelEnd.X) and (FSelStart.Y < FSelEnd.Y)) then\r\n Result := FSelStart\r\n else\r\n Result := FSelEnd\r\n else\r\n Result := Point(Lesser(FSelStart.X, FSelEnd.X),\r\n Lesser(FSelStart.Y, FSelEnd.Y));\r\nend;\r\n\r\nfunction TJvTFDays.GetSelEnd: TPoint;\r\nbegin\r\n // This routine will always return the end of the selection regardless\r\n // of whether FSelStart and FSelEnd are in the correct order or not.\r\n if FFromToSel then\r\n if (FSelStart.X < FSelEnd.X) or\r\n ((FSelStart.X = FSelEnd.X) and (FSelStart.Y < FSelEnd.Y)) then\r\n Result := FSelEnd\r\n else\r\n Result := FSelStart\r\n else\r\n Result := Point(Greater(FSelStart.X, FSelEnd.X),\r\n Greater(FSelStart.Y, FSelEnd.Y));\r\nend;\r\n\r\n{$IFNDEF Jv_TIMEBLOCKS}\r\n// remove\r\n{\r\nprocedure TJvTFDays.SetSelStart(Value: TPoint);\r\nbegin\r\n FSelStart := Value;\r\n FSelEnd := Value;\r\n DoNavigate;\r\n Invalidate;\r\nend;\r\n}\r\n{$ENDIF !Jv_TIMEBLOCKS}\r\n\r\n{$IFDEF Jv_TIMEBLOCKS}\r\n// ok\r\nprocedure TJvTFDays.SetSelStart(Value: TPoint);\r\nvar\r\n TimeBlock, StartRow, EndRow: Integer;\r\nbegin\r\n TimeBlock := RowToTimeBlock(Value.Y);\r\n if (TimeBlock = -1) and (TimeBlocks.Count > 0) then\r\n Exit;\r\n\r\n FSelStart := Value;\r\n FSelEnd := Value;\r\n\r\n if TimeBlock > -1 then\r\n begin\r\n GetTimeBlockStartEnd(TimeBlock, StartRow, EndRow);\r\n FSelStart.Y := StartRow;\r\n FSelEnd.Y := EndRow;\r\n end;\r\n\r\n// DoNavigate;\r\n Invalidate;\r\nend;\r\n{$ENDIF Jv_TIMEBLOCKS}\r\n\r\n{$IFNDEF Jv_TIMEBLOCKS}\r\n// remove\r\n{\r\nprocedure TJvTFDays.SetSelEnd(Value: TPoint);\r\nvar\r\n SameName,\r\n Consecutive: Boolean;\r\n I,\r\n TestStart,\r\n TestEnd,\r\n DateDiff: Integer;\r\nbegin\r\n /////////////////////////////////////////////////////////////////////\r\n // This routine enforces the rules by which cells can be selected.\r\n // There are two different types of selection:\r\n // 1. From/To - As mouse moves from cell(1, 4) to cell(2, 8)...\r\n // Cell(1, 4) through cell(1, LastRow) is selected, AND\r\n // Cell(2, TopRow) through cell(2, 8) is selected.\r\n // 2. Block - As mouse moves from cell(1, 4) to cell(2, 8)...\r\n // Cell(1, 4) through cell(1, 8) is selected, AND\r\n // Cell(2, 4) through cell(2, 8) is selected.\r\n //\r\n // There are six different cases that are possible:\r\n // 1. Same SchedName (resource), contiguous dates ==> From/To selection\r\n // (Mike - 1/1/99 and Mike - 1/2/99)\r\n // 2. Same name, non-contiguous dates ==> Selection not allowed\r\n // (Mike - 1/1/99 and Mike - 2/1/99)\r\n // 3. Same name, same date ==> Block selection\r\n // (Mike - 1/1/99 and Mike - 1/1/99)\r\n // 4. Different name, contiguous dates ==> Selection not allowed\r\n // (Mike - 1/1/99 and Jennifer - 1/2/99)\r\n // 5. Different name, non-contiguous dates ==> Selection not allowed\r\n // (Mike - 1/1/99 and Jennifer - 2/1/99)\r\n // 6. Different name, same date ==> Block selection\r\n // (Mike - 1/1/99 and Jennifer - 1/1/99)\r\n ///////////////////////////////////////////////////////////////////////\r\n\r\n // Check for different end value\r\n if (FSelEnd.X <> Value.X) or (FSelEnd.Y <> Value.Y) then\r\n begin\r\n // Check for valid end\r\n if (FSelStart.X > gcHdr) and (Value.X > gcHdr) and (FSelEnd.X > gcHdr) and\r\n (FSelStart.Y > gcHdr) and (Value.Y > gcHdr) and (FSelEnd.Y > gcHdr) then\r\n begin\r\n // FFromToSel flag needed for drawing selection frame when\r\n // SelCellAttr.Style = scsFrame. Frame is drawn in DrawDataCell.\r\n //FFromToSel := False;\r\n\r\n // We need a two-level check. First check new end (Value) against\r\n // old end (FSelEnd). if that is NOT a valid end then check\r\n // new end (Value) against start (FSelStart).\r\n\r\n // IMPORTANT NOTE: When in a case #1 and selection moves up or down\r\n // within the same column, the code below will interpret that as\r\n // Case #3. This is not exactly correct, but it still yields the\r\n // correct results.\r\n\r\n // First check new end against old end\r\n SameName := Cols[FSelEnd.X].SchedName = Cols[Value.X].SchedName;\r\n DateDiff := Abs(Trunc(Cols[FSelEnd.X].SchedDate) -\r\n Trunc(Cols[Value.X].SchedDate));\r\n\r\n if ( SameName and (DateDiff = 1)) or // Case #1\r\n ( SameName and (DateDiff = 0)) or // Case #3\r\n (not SameName and (DateDiff = 0)) then // Case #6\r\n begin\r\n FFromToSel := (SameName and (DateDiff = 1)) or\r\n (FFromToSel and (SameName and (DateDiff = 0)));\r\n\r\n FSelEnd := Value;\r\n DoNavigate;\r\n Invalidate;\r\n end\r\n else\r\n // if first check fails then check new end against start\r\n begin\r\n SameName := Cols[FSelStart.X].SchedName = Cols[Value.X].SchedName;\r\n DateDiff := Abs(Trunc(Cols[FSelStart.X].SchedDate) -\r\n Trunc(Cols[Value.X].SchedDate));\r\n if ( SameName and (DateDiff = 1)) or // Case #1\r\n ( SameName and (DateDiff = 0)) or // Case #3\r\n (not SameName and (DateDiff = 0)) then // Case #6\r\n begin\r\n FFromToSel := (SameName and (DateDiff = 1)) or\r\n (FFromToSel and (SameName and (DateDiff = 0)));\r\n\r\n FSelEnd := Value;\r\n DoNavigate;\r\n Invalidate;\r\n end\r\n else\r\n // Do a third check for \"lagging selection\"\r\n // (Sometimes mouse loses selection, especially when speed\r\n // threshold is exceeded.)\r\n begin\r\n // Check for consecutive dates\r\n TestStart := Lesser(SelStart.X, Value.X);\r\n TestEnd := Greater(SelStart.X, Value.X);\r\n I := TestStart;\r\n Consecutive := True;\r\n while (I < TestEnd) and Consecutive do\r\n if Trunc(Cols[I + 1].SchedDate) -\r\n Trunc(Cols[I].SchedDate) <> 1 then\r\n Consecutive := False\r\n else\r\n Inc(I);\r\n\r\n if Consecutive then\r\n begin\r\n FFromToSel := True;\r\n FSelEnd := Value;\r\n DoNavigate;\r\n Invalidate;\r\n end\r\n else\r\n FFromToSel := False;\r\n end;\r\n end;\r\n end;\r\n end;\r\nend;\r\n}\r\n{$ENDIF !Jv_TIMEBLOCKS}\r\n\r\n{$IFDEF Jv_TIMEBLOCKS}\r\n// ok\r\nprocedure TJvTFDays.SetSelEnd(Value: TPoint);\r\nvar\r\n SameName, Consecutive, InTimeBlock: Boolean;\r\n I, TestStart, TestEnd, DateDiff, TimeBlock: Integer;\r\n SelStartTimeBlock, StartRow, EndRow: Integer;\r\n\r\n procedure CheckFollowMouse;\r\n begin\r\n if (TimeBlocks.Count > 0) and SameName and (DateDiff = 1) and\r\n (Value.X <> SelStart.X) then\r\n SelStart := Point(Value.X, SelStart.Y);\r\n end;\r\n\r\nbegin\r\n {\r\n This routine enforces the rules by which cells can be selected.\r\n There are two different types of selection:\r\n 1. From/To - As mouse moves from cell(1, 4) to cell(2, 8)...\r\n Cell(1, 4) through cell(1, LastRow) is selected, AND\r\n Cell(2, TopRow) through cell(2, 8) is selected.\r\n 2. Block - As mouse moves from cell(1, 4) to cell(2, 8)...\r\n Cell(1, 4) through cell(1, 8) is selected, AND\r\n Cell(2, 4) through cell(2, 8) is selected.\r\n\r\n NOTE: The Block selection type should not be confused with\r\n Time Blocks. They are two different things. The only\r\n type of allowable selection when using Time Blocks is\r\n Block, however a Block selection can exist without\r\n the use of Time Blocks.\r\n\r\n There are six different cases that are possible:\r\n 1. Same SchedName (resource), contiguous dates ==> From/To selection\r\n (Mike - 1/1/99 and Mike - 1/2/99)\r\n 2. Same name, non-contiguous dates ==> Selection not allowed\r\n (Mike - 1/1/99 and Mike - 2/1/99)\r\n 3. Same name, same date ==> Block selection\r\n (Mike - 1/1/99 and Mike - 1/1/99)\r\n 4. Different name, contiguous dates ==> Selection not allowed\r\n (Mike - 1/1/99 and Jennifer - 1/2/99)\r\n 5. Different name, non-contiguous dates ==> Selection not allowed\r\n (Mike - 1/1/99 and Jennifer - 2/1/99)\r\n 6. Different name, same date ==> Block selection\r\n (Mike - 1/1/99 and Jennifer - 1/1/99)\r\n }\r\n\r\n // Do a time block check and adjust Value.Y if necessary to always\r\n // select the entire time block.\r\n TimeBlock := RowToTimeBlock(Value.Y);\r\n if (TimeBlock = -1) and (TimeBlocks.Count > 0) then\r\n Exit;\r\n\r\n SelStartTimeBlock := RowToTimeBlock(SelStart.Y);\r\n InTimeBlock := (TimeBlock > -1) or (SelStartTimeBlock > -1);\r\n if InTimeBlock then\r\n begin\r\n if TimeBlock > -1 then\r\n begin\r\n GetTimeBlockStartEnd(TimeBlock, StartRow, EndRow);\r\n SelStart := Point(SelStart.X, StartRow);\r\n end\r\n else\r\n SelStart := Point(SelStart.X, Value.Y);\r\n Value.Y := EndRow;\r\n end;\r\n\r\n // Check for different end value\r\n if (FSelEnd.X <> Value.X) or (FSelEnd.Y <> Value.Y) then\r\n begin\r\n // Check for valid end\r\n if (FSelStart.X > gcHdr) and (Value.X > gcHdr) and (FSelEnd.X > gcHdr) and\r\n (FSelStart.Y > gcHdr) and (Value.Y > gcHdr) and (FSelEnd.Y > gcHdr) then\r\n begin\r\n // FFromToSel flag needed for drawing selection frame when\r\n // SelCellAttr.Style = scsFrame. Frame is drawn in DrawDataCell.\r\n //FFromToSel := False;\r\n\r\n // We need a two-level check. First check new end (Value) against\r\n // old end (FSelEnd). if that is NOT a valid end then check\r\n // new end (Value) against start (FSelStart).\r\n\r\n // IMPORTANT NOTE: When in a case #1 and selection moves up or down\r\n // within the same column, the code below will interpret that as\r\n // Case #3. This is not exactly correct, but it still yields the\r\n // correct results.\r\n\r\n // First check new end against old end\r\n SameName := Cols[FSelEnd.X].SchedName = Cols[Value.X].SchedName;\r\n DateDiff := Abs(Trunc(Cols[FSelEnd.X].SchedDate) -\r\n Trunc(Cols[Value.X].SchedDate));\r\n\r\n CheckFollowMouse;\r\n\r\n if (SameName and (DateDiff = 1) and (TimeBlocks.Count = 0)) or // Case #1 only if no timeblocks\r\n (SameName and (DateDiff = 0)) or // Case #3\r\n (not SameName and (DateDiff = 0)) then // Case #6\r\n begin\r\n FFromToSel := (SameName and (DateDiff = 1)) or\r\n (FFromToSel and (SameName and (DateDiff = 0)));\r\n\r\n FSelEnd := Value;\r\n// DoNavigate;\r\n Invalidate;\r\n end\r\n else\r\n // if first check fails then check new end against start\r\n begin\r\n SameName := Cols[FSelStart.X].SchedName = Cols[Value.X].SchedName;\r\n DateDiff := Abs(Trunc(Cols[FSelStart.X].SchedDate) -\r\n Trunc(Cols[Value.X].SchedDate));\r\n\r\n CheckFollowMouse;\r\n\r\n if (SameName and (DateDiff = 1) and (TimeBlocks.Count = 0)) or // Case #1 only if no timeblocks\r\n (SameName and (DateDiff = 0)) or // Case #3\r\n (not SameName and (DateDiff = 0)) then // Case #6\r\n begin\r\n FFromToSel := (SameName and (DateDiff = 1)) or\r\n (FFromToSel and (SameName and (DateDiff = 0)));\r\n\r\n FSelEnd := Value;\r\n// DoNavigate;\r\n Invalidate;\r\n end\r\n else\r\n // Do a third check for \"lagging selection\"\r\n // (Sometimes mouse loses selection, especially when speed\r\n // threshold is exceeded.)\r\n begin\r\n // Check for consecutive dates\r\n TestStart := Lesser(SelStart.X, Value.X);\r\n TestEnd := Greater(SelStart.X, Value.X);\r\n I := TestStart;\r\n Consecutive := False;\r\n while (I < TestEnd) and Consecutive do\r\n if Trunc(Cols[I + 1].SchedDate) -\r\n Trunc(Cols[I].SchedDate) <> 1 then\r\n Consecutive := False\r\n else\r\n Inc(I);\r\n\r\n if Consecutive then\r\n begin\r\n FFromToSel := True;\r\n FSelEnd := Value;\r\n// DoNavigate;\r\n Invalidate;\r\n end\r\n else\r\n FFromToSel := False;\r\n end;\r\n end;\r\n end;\r\n end;\r\nend;\r\n{$ENDIF Jv_TIMEBLOCKS}\r\n\r\nprocedure TJvTFDays.QuickEntry(Key: Char);\r\nvar\r\n Appt: TJvTFAppt;\r\n ApptStartDate, ApptEndDate: TDate;\r\n ApptStartTime, ApptEndTime: TTime;\r\n I: Integer;\r\n ID: string;\r\n Confirm: Boolean;\r\nbegin\r\n // Ord(key) must be >= 32 to quick entry an appt.\r\n if (Ord(Key) >= 32) and ValidSelection and not Assigned(SelAppt) and\r\n (agoQuickEntry in Options) and (agoEditing in Options) and CanEdit then\r\n begin\r\n // Calc the appt's start and end info\r\n ApptStartDate := Cols[SelStart.X].SchedDate;\r\n ApptEndDate := Cols[SelEnd.X].SchedDate;\r\n ApptStartTime := RowToTime(SelStart.Y);\r\n // subtract one min from granularity and then add it back in. This\r\n // avoids min overflow when granularity = 60.\r\n ApptEndTime := RowToTime(SelEnd.Y) +\r\n EncodeTime(0, Granularity - 1, 0, 0) +\r\n EncodeTime(0, 1, 0, 0);\r\n // if we're on the last row make sure end time is not = 0 (12am next day)\r\n // This avoids InvalidStartEnd exception when calling Appt.SetStartEnd\r\n if SelEnd.Y = RowCount - 1 then\r\n ApptEndTime := ApptEndTime - EncodeTime(0, 0, 1, 0);\r\n\r\n ID := '';\r\n Confirm := True;\r\n\r\n if Assigned(FOnCreateQuickEntry) then\r\n FOnCreateQuickEntry(Self, ID, ApptStartDate, ApptStartTime,\r\n ApptEndDate, ApptEndTime, Confirm);\r\n\r\n if Confirm and Assigned(ScheduleManager) then\r\n begin\r\n Appt := ScheduleManager.dbNewAppt(ID);\r\n Appt.Persistent := True;\r\n\r\n // Set the Start/end info\r\n Appt.SetStartEnd(ApptStartDate, ApptStartTime, ApptEndDate, ApptEndTime);\r\n\r\n // Set the Schedule (resource) names\r\n for I := SelStart.X to SelEnd.X do\r\n if ColIsSelected(I) then\r\n Appt.AddSchedule(Cols[I].SchedName);\r\n\r\n Appt.Persistent := False;\r\n\r\n SetSelAppt(Appt);\r\n EditAppt(SelStart.X, SelAppt);\r\n // Put the Key in the editor and set the caret\r\n FEditor.Text := Key;\r\n FEditor.SelStart := 1;\r\n FEditor.QuickCreate := True;\r\n\r\n if Assigned(FOnQuickEntry) then\r\n FOnQuickEntry(Self);\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJvTFDays.GetAdjClientRect: TRect;\r\nbegin\r\n Result := GetClientRect;\r\n\r\n if Assigned(FVScrollBar) and FVScrollBar.Visible then\r\n Dec(Result.Right, FVScrollBar.Width);\r\n if Assigned(FHScrollBar) and FHScrollBar.Visible then\r\n Dec(Result.Bottom, FHScrollBar.Height);\r\nend;\r\n\r\nfunction TJvTFDays.GetDataAreaRect: TRect;\r\nbegin\r\n Result := GetAdjClientRect;\r\n\r\n {$IFDEF Jv_TIMEBLOCKS}\r\n // ok\r\n Inc(Result.Left, CalcBlockRowHdrsWidth);\r\n {$ELSE}\r\n // remove\r\n //Inc(Result.Left, RowHdrWidth);\r\n {$ENDIF Jv_TIMEBLOCKS}\r\n\r\n //group Inc(Result.Top, ColHdrHeight);\r\n Inc(Result.Top, CalcGroupColHdrsHeight);\r\nend;\r\n\r\nfunction TJvTFDays.GetDataWidth: Integer;\r\nbegin\r\n Result := RectWidth(GetDataAreaRect);\r\nend;\r\n\r\nfunction TJvTFDays.GetDataHeight: Integer;\r\nbegin\r\n Result := RectHeight(GetDataAreaRect);\r\nend;\r\n\r\n{$IFNDEF Jv_TIMEBLOCKS}\r\n// remove\r\n{\r\nfunction TJvTFDays.PtToCell(X, Y: Integer): TJvTFDaysCoord;\r\nVar\r\n ColNum,\r\n RowNum,\r\n AdjX,\r\n AdjY,\r\n Temp,\r\n TotalWidth,\r\n SegCount,\r\n MapCol: Integer;\r\n Done: Boolean;\r\n ApptRect: TRect;\r\nbegin\r\n With Result do\r\n begin\r\n Col := gcUndef;\r\n Row := gcUndef;\r\n CellX := -100;\r\n CellY := -100;\r\n AbsX := X;\r\n AbsY := Y;\r\n Schedule := nil;\r\n Appt := nil;\r\n end;\r\n\r\n if X < RowHdrWidth then\r\n begin\r\n Result.Col := gcHdr;\r\n Result.CellX := X;\r\n end\r\n else\r\n if LeftCol > -1 then\r\n begin\r\n // Find the col that PtX falls in\r\n ColNum := LeftCol;\r\n AdjX := X - RowHdrWidth;\r\n Done := False;\r\n Temp := 0;\r\n\r\n while (ColNum < Cols.Count) and not Done do\r\n begin\r\n Inc(Temp, Cols[ColNum].Width);\r\n if AdjX < Temp then\r\n begin\r\n Done := True;\r\n Result.Col := ColNum;\r\n Result.CellX := AdjX - (Temp - Cols[ColNum].Width);\r\n end\r\n else\r\n Inc(ColNum);\r\n end;\r\n end;\r\n\r\n if Y < CalcGroupHdrHeight then\r\n begin\r\n Result.Row := gcGroupHdr;\r\n Result.CellY := Y;\r\n end\r\n //else\r\n //if Y < ColHdrHeight then\r\n else\r\n if Y < CalcGroupColHdrsHeight then\r\n begin\r\n Result.Row := gcHdr;\r\n Result.CellY := Y - CalcGroupHdrHeight;\r\n end\r\n else\r\n if TopRow > -1 then\r\n begin\r\n RowNum := TopRow;\r\n //group AdjY := Y - ColHdrHeight;\r\n AdjY := Y - CalcGroupColHdrsHeight;\r\n Done := False;\r\n Temp := 0;\r\n\r\n while (RowNum < RowCount) and not Done do\r\n begin\r\n Inc(Temp, RowHeight);\r\n if AdjY < Temp then\r\n begin\r\n Done := True;\r\n Result.Row := RowNum;\r\n Result.CellY := AdjY - (Temp - RowHeight);\r\n end\r\n else\r\n Inc(RowNum);\r\n end;\r\n end;\r\n\r\n if Result.Col > gcHdr then\r\n begin\r\n Result.Schedule := Cols[Result.Col].Schedule;\r\n\r\n if (Result.Row > gcHdr) and Assigned(Result.Schedule) then\r\n begin\r\n TotalWidth := Cols[Result.Col].Width;\r\n SegCount := Cols[Result.Col].MapColCount(Result.Row);\r\n if SegCount > 0 then\r\n begin\r\n MapCol := LocateDivCol(Result.CellX, TotalWidth, SegCount);\r\n Result.Appt := Cols[Result.Col].MapLocation(MapCol, Result.Row);\r\n\r\n ApptRect := GetApptRect(Result.Col, Result.Appt);\r\n if not Windows.PtInRect(ApptRect, Point(X, Y)) then\r\n Result.Appt := nil;\r\n end;\r\n end;\r\n end;\r\n\r\n Result.DragAccept := (Result.Row > gcHdr) and (Result.Col > gcHdr);\r\nend;\r\n}\r\n{$ENDIF !Jv_TIMEBLOCKS}\r\n\r\n{$IFDEF Jv_TIMEBLOCKS}\r\n// ok\r\nfunction TJvTFDays.PtToCell(X, Y: Integer): TJvTFDaysCoord;\r\nvar\r\n ColNum, RowNum, AdjX, AdjY, Temp, TotalWidth, SegCount, MapCol: Integer;\r\n Done: Boolean;\r\n ApptRect: TRect;\r\nbegin\r\n with Result do\r\n begin\r\n Col := gcUndef;\r\n Row := gcUndef;\r\n CellX := -100;\r\n CellY := -100;\r\n AbsX := X;\r\n AbsY := Y;\r\n Schedule := nil;\r\n Appt := nil;\r\n end;\r\n\r\n if X < CalcBlockHdrWidth then\r\n begin\r\n // POSSIBLE BUG!!\r\n //Result.Row := gcGroupHdr; // WRONG CODE\r\n Result.Col := gcGroupHdr; // UNTESTED - CORRECT CODE\r\n Result.CellX := X;\r\n end\r\n //block if X < RowHdrWidth then\r\n else\r\n if X < CalcBlockRowHdrsWidth then\r\n begin\r\n Result.Col := gcHdr;\r\n Result.CellX := X - CalcBlockHdrWidth;\r\n end\r\n else\r\n if LeftCol > -1 then\r\n begin\r\n // Find the col that PtX falls in\r\n ColNum := LeftCol;\r\n //block AdjX := X - RowHdrWidth;\r\n AdjX := X - CalcBlockRowHdrsWidth;\r\n Done := False;\r\n Temp := 0;\r\n\r\n while (ColNum < Cols.Count) and not Done do\r\n begin\r\n Inc(Temp, Cols[ColNum].Width);\r\n if AdjX < Temp then\r\n begin\r\n Done := True;\r\n Result.Col := ColNum;\r\n Result.CellX := AdjX - (Temp - Cols[ColNum].Width);\r\n end\r\n else\r\n Inc(ColNum);\r\n end;\r\n if not Done then\r\n begin\r\n Result.Col := Cols.Count-1;\r\n Result.CellX := AdjX - (Temp - Cols[Cols.Count-1].Width);\r\n end;\r\n end;\r\n\r\n if Y < CalcGroupHdrHeight then\r\n begin\r\n Result.Row := gcGroupHdr;\r\n Result.CellY := Y;\r\n end\r\n //else if Y < ColHdrHeight then\r\n else\r\n if Y < CalcGroupColHdrsHeight then\r\n begin\r\n Result.Row := gcHdr;\r\n Result.CellY := Y - CalcGroupHdrHeight;\r\n end\r\n else\r\n if TopRow > -1 then\r\n begin\r\n RowNum := TopRow;\r\n //group AdjY := Y - ColHdrHeight;\r\n AdjY := Y - CalcGroupColHdrsHeight;\r\n Done := False;\r\n Temp := 0;\r\n\r\n while (RowNum < RowCount) and not Done do\r\n begin\r\n Inc(Temp, RowHeight);\r\n if AdjY < Temp then\r\n begin\r\n Done := True;\r\n Result.Row := RowNum;\r\n Result.CellY := AdjY - (Temp - RowHeight);\r\n end\r\n else\r\n Inc(RowNum);\r\n end;\r\n if not Done then\r\n begin\r\n Result.Row := RowCount-1;\r\n Result.CellY := AdjY - (Temp - RowHeight);\r\n end;\r\n end;\r\n\r\n if Result.Col > gcHdr then\r\n begin\r\n Result.Schedule := Cols[Result.Col].Schedule;\r\n\r\n // move grab handles\r\n if PtInTopHandle(Point(X, Y), Result.Col, SelAppt) then\r\n Result.Appt := SelAppt\r\n else\r\n if PtInBottomHandle(Point(X, Y), Result.Col, SelAppt) then\r\n Result.Appt := SelAppt\r\n else\r\n if (Result.Row > gcHdr) and Assigned(Result.Schedule) then\r\n begin\r\n TotalWidth := Cols[Result.Col].Width;\r\n SegCount := Cols[Result.Col].MapColCount(Result.Row);\r\n if SegCount > 0 then\r\n begin\r\n MapCol := LocateDivCol(Result.CellX, TotalWidth, SegCount);\r\n Result.Appt := Cols[Result.Col].MapLocation(MapCol, Result.Row);\r\n\r\n ApptRect := GetApptRect(Result.Col, Result.Appt);\r\n if not Windows.PtInRect(ApptRect, Point(X, Y)) then\r\n Result.Appt := nil;\r\n end;\r\n end;\r\n end;\r\n\r\n Result.DragAccept := (Result.Row > gcHdr) and (Result.Col > gcHdr);\r\nend;\r\n{$ENDIF Jv_TIMEBLOCKS}\r\n\r\n{$IFNDEF Jv_TIMEBLOCKS}\r\n// remove\r\n{\r\nfunction TJvTFDays.CellRect(Col, Row: Integer): TRect;\r\nVar\r\n I: Integer;\r\n VisGrpHdrRect: TRect;\r\nbegin\r\n if (Row = gcGroupHdr) and (Col > gcHdr) then\r\n begin\r\n VisGrpHdrRect := Classes.Rect(RowHdrWidth, 0, RowHdrWidth + GetDataWidth,\r\n CalcGroupHdrHeight);\r\n Windows.IntersectRect(Result, VisGrpHdrRect, VirtualGroupHdrRect(Col));\r\n end\r\n else\r\n if Col < 0 then // Row hdr\r\n if Row < 0 then\r\n //group Result := Classes.Rect(0, 0, RowHdrWidth, ColHdrHeight) // origin cell\r\n Result := Classes.Rect(0, 0, RowHdrWidth, CalcGroupColHdrsHeight) // origin cell\r\n else\r\n if (Row >= TopRow) and (Row <= BottomRow) then\r\n // Row Hdr for visible data row\r\n begin\r\n Result.Left := 0;\r\n //group Top := ColHdrHeight + (Row - TopRow) * RowHeight;\r\n Result.Top := CalcGroupColHdrsHeight + (Row - TopRow) * RowHeight;\r\n Result.Right := RowHdrWidth;\r\n Result.Bottom := Result.Top + RowHeight;\r\n end\r\n else\r\n // Row Hdr for non-visible data row\r\n Result := EmptyRect\r\n\r\n else\r\n if (Col >= LeftCol) and (Col <= RightCol) then // visible data col\r\n if Row < 0 then\r\n // Col hdr for visible data col\r\n begin\r\n Result.Left := RowHdrWidth;\r\n For I := LeftCol to Col - 1 do\r\n Inc(Result.Left, Cols[I].Width);\r\n Result.Right := Result.Left + Cols[Col].Width;\r\n //group Top := 0;\r\n Result.Top := CalcGroupHdrHeight;\r\n //group Bottom := ColHdrHeight;\r\n Result.Bottom := CalcGroupColHdrsHeight;\r\n end\r\n else\r\n if (Row >= TopRow) and (Row <= BottomRow) then\r\n // visible data cell\r\n begin\r\n Result.Left := RowHdrWidth;\r\n For I := LeftCol to Col - 1 do\r\n Inc(Result.Left, Cols[I].Width);\r\n Result.Right := Result.Left + Cols[Col].Width;\r\n //group Top := ColHdrHeight + (Row - TopRow) * RowHeight;\r\n Result.Top := CalcGroupColHdrsHeight + (Row - TopRow) * RowHeight;\r\n Result.Bottom := Result.Top + RowHeight;\r\n end\r\n else\r\n // non-visible data cell (visible col, but non-visible row)\r\n Result := EmptyRect\r\n\r\n else // non-visible data col\r\n Result := EmptyRect;\r\nend;\r\n}\r\n{$ENDIF !Jv_TIMEBLOCKS}\r\n\r\n{$IFDEF Jv_TIMEBLOCKS}\r\n// ok\r\nfunction TJvTFDays.CellRect(Col, Row: Integer): TRect;\r\nvar\r\n I: Integer;\r\n VisGrpHdrRect: TRect;\r\nbegin\r\n if (Col = gcGroupHdr) and (Row > gcHdr) then\r\n begin\r\n VisGrpHdrRect := Classes.Rect(0, CalcGroupColHdrsHeight, CalcBlockRowHdrsWidth,\r\n CalcGroupColHdrsHeight + GetDataHeight);\r\n Windows.IntersectRect(Result, VisGrpHdrRect, VirtualBlockHdrRect(Row));\r\n end\r\n else\r\n if (Row = gcGroupHdr) and (Col > gcHdr) then\r\n begin\r\n //block VisGrpHdrRect := Classes.Rect(RowHdrWidth, 0, RowHdrWidth + GetDataWidth,\r\n // CalcGroupHdrHeight);\r\n VisGrpHdrRect := Classes.Rect(CalcBlockRowHdrsWidth, 0,\r\n CalcBlockRowHdrsWidth + GetDataWidth, CalcGroupHdrHeight);\r\n Windows.IntersectRect(Result, VisGrpHdrRect, VirtualGroupHdrRect(Col));\r\n end\r\n else\r\n if Col < 0 then // Row hdr\r\n if Row < 0 then\r\n //group Result := Classes.Rect(0, 0, RowHdrWidth, ColHdrHeight) // origin cell\r\n //block Result := Classes.Rect(0, 0, RowHdrWidth, CalcGroupColHdrsHeight) // origin cell\r\n Result := Classes.Rect(0, 0, CalcBlockRowHdrsWidth, CalcGroupColHdrsHeight)\r\n else\r\n if (Row >= TopRow) and (Row <= BottomRow) then\r\n // Row Hdr for visible data row\r\n begin\r\n //block Left := 0;\r\n Result.Left := CalcBlockHdrWidth;\r\n //group Top := ColHdrHeight + (Row - TopRow) * RowHeight;\r\n Result.Top := CalcGroupColHdrsHeight + (Row - TopRow) * RowHeight;\r\n //block Right := RowHdrWidth;\r\n Result.Right := Result.Left + RowHdrWidth;\r\n Result.Bottom := Result.Top + RowHeight;\r\n end\r\n else\r\n // Row Hdr for non-visible data row\r\n Result := EmptyRect\r\n else\r\n if (Col >= LeftCol) and (Col <= RightCol) then // visible data col\r\n if Row < 0 then\r\n // Col hdr for visible data col\r\n begin\r\n //block Result.Left := RowHdrWidth;\r\n Result.Left := CalcBlockRowHdrsWidth;\r\n for I := LeftCol to Col - 1 do\r\n Inc(Result.Left, Cols[I].Width);\r\n Result.Right := Result.Left + Cols[Col].Width;\r\n //group Result.Top := 0;\r\n Result.Top := CalcGroupHdrHeight;\r\n //group Result.Bottom := ColHdrHeight;\r\n Result.Bottom := CalcGroupColHdrsHeight;\r\n end\r\n else\r\n if (Row >= TopRow) and (Row <= BottomRow) then\r\n // visible data cell\r\n begin\r\n //block Result.Left := RowHdrWidth;\r\n Result.Left := CalcBlockRowHdrsWidth;\r\n for I := LeftCol to Col - 1 do\r\n Inc(Result.Left, Cols[I].Width);\r\n Result.Right := Result.Left + Cols[Col].Width;\r\n //group Result.Top := ColHdrHeight + (Row - TopRow) * RowHeight;\r\n Result.Top := CalcGroupColHdrsHeight + (Row - TopRow) * RowHeight;\r\n Result.Bottom := Result.Top + RowHeight;\r\n end\r\n else\r\n // non-visible data cell (visible col, but non-visible row)\r\n Result := EmptyRect\r\n\r\n else // non-visible data col\r\n Result := EmptyRect;\r\nend;\r\n{$ENDIF Jv_TIMEBLOCKS}\r\n\r\n{$IFNDEF Jv_TIMEBLOCKS}\r\n// remove\r\n{\r\nfunction TJvTFDays.VirtualCellRect(Col, Row: Integer): TRect;\r\nVar\r\n I: Integer;\r\nbegin\r\n if Row = gcGroupHdr then\r\n Result := VirtualGroupHdrRect(Col)\r\n else\r\n begin\r\n if Col > -1 then\r\n begin\r\n Result.Left := RowHdrWidth;\r\n // At most, only one of the following For loops will execute\r\n // depending on whether Col is to the left or to the right of LeftCol\r\n For I := LeftCol to Col - 1 do\r\n Inc(Result.Left, Cols[I].Width);\r\n\r\n For I := LeftCol - 1 downto Col do\r\n Dec(Result.Left, Cols[I].Width);\r\n Result.Right := Result.Left + Cols[Col].Width;\r\n end\r\n else\r\n begin\r\n Result.Left := 0;\r\n Result.Right := RowHdrWidth;\r\n end;\r\n\r\n if Row > -1 then\r\n begin\r\n //group Result.Top := ColHdrHeight + (Row - TopRow) * RowHeight;\r\n Result.Top := CalcGroupColHdrsHeight + (Row - TopRow) * RowHeight;\r\n Result.Bottom := Result.Top + RowHeight;\r\n end\r\n else\r\n begin\r\n //group Result.Top := 0;\r\n Result.Top := CalcGroupHdrHeight;\r\n Result.Bottom := Result.Top + ColHdrHeight;\r\n end;\r\n end;\r\nend;\r\n}\r\n{$ENDIF !Jv_TIMEBLOCKS}\r\n\r\n{$IFDEF Jv_TIMEBLOCKS}\r\n// ok\r\nfunction TJvTFDays.VirtualCellRect(Col, Row: Integer): TRect;\r\nvar\r\n I: Integer;\r\nbegin\r\n if (Col = gcGroupHdr) and (Row > gcHdr) then\r\n Result := VirtualBlockHdrRect(Row)\r\n else\r\n if (Row = gcGroupHdr) and (Col > gcHdr) then\r\n Result := VirtualGroupHdrRect(Col)\r\n else\r\n begin\r\n if Col > -1 then\r\n begin\r\n //block Result.Left := RowHdrWidth;\r\n Result.Left := CalcBlockRowHdrsWidth;\r\n // At most, only one of the following For loops will execute\r\n // depending on whether Col is to the Result.Left or to the Result.Right of LeftCol\r\n for I := LeftCol to Col - 1 do\r\n Inc(Result.Left, Cols[I].Width);\r\n\r\n for I := LeftCol - 1 downto Col do\r\n Dec(Result.Left, Cols[I].Width);\r\n Result.Right := Result.Left + Cols[Col].Width;\r\n end\r\n else\r\n begin\r\n //block Result.Left := 0;\r\n Result.Left := CalcBlockHdrWidth;\r\n //block Result.Right := RowHdrWidth;\r\n Result.Right := Result.Left + RowHdrWidth;\r\n end;\r\n\r\n if Row > -1 then\r\n begin\r\n //group Result.Top := ColHdrHeight + (Row - TopRow) * RowHeight;\r\n Result.Top := CalcGroupColHdrsHeight + (Row - TopRow) * RowHeight;\r\n Result.Bottom := Result.Top + RowHeight;\r\n end\r\n else\r\n begin\r\n //group Result.Top := 0;\r\n Result.Top := CalcGroupHdrHeight;\r\n Result.Bottom := Result.Top + ColHdrHeight;\r\n end;\r\n end;\r\nend;\r\n{$ENDIF Jv_TIMEBLOCKS}\r\n\r\nfunction TJvTFDays.GetApptRect(Col: Integer; Appt: TJvTFAppt): TRect;\r\nvar\r\n MapCol, MapColCount, Base, MakeUp, BaseWidth, MakeUpWidth: Integer;\r\n BaseCount, GridColWidth, ApptWidth, StartRow, EndRow: Integer;\r\n VirtCellRect: TRect;\r\nbegin\r\n if not Assigned(Appt) then\r\n begin\r\n Result := EmptyRect;\r\n Exit;\r\n end;\r\n\r\n CalcStartEndRows(Appt, Cols[Col].SchedDate, StartRow, EndRow);\r\n\r\n if (StartRow < 0) and (EndRow >= 0) then\r\n StartRow := 0;\r\n // if the above condition fails and the StartRow is STILL invalid then\r\n // let the 'Map col not found' catch the error.\r\n\r\n EndRow := Lesser(EndRow, RowCount - 1);\r\n\r\n MapCol := Cols[Col].LocateMapCol(Appt, StartRow);\r\n\r\n if MapCol < 1 then\r\n begin\r\n //Cols[Col].DumpMap;\r\n raise EJvTFDaysError.CreateRes(@RsEMapColNotFoundForAppointment);\r\n end;\r\n\r\n MapColCount := Cols[Col].MapColCount(StartRow);\r\n if MapColCount < 1 then\r\n begin\r\n //Cols[Col].FMap.Dump('corrupt dump.txt'); !!! FOR DEBUGGING ONLY !!!!\r\n //Cols[Col].DumpMap;\r\n raise EJvTFDaysError.CreateRes(@RsECorruptAppointmentMap);\r\n end;\r\n\r\n // Col guaranteed to be partially visible\r\n VirtCellRect := VirtualCellRect(Col, StartRow);\r\n GridColWidth := RectWidth(VirtCellRect);\r\n\r\n // The Base* and MakeUp* code that follows calcs the appt width and Result.Left\r\n // and takes into account a total width that isn't evenly divisible by\r\n // the map col count. If there is a discrepancy then that discrepancy\r\n // is divided up among the cols working Result.Left to Result.Right.\r\n //\r\n // Example: Total width = 113, col count = 5\r\n // col 1 = 23\r\n // col 2 = 23\r\n // col 3 = 23\r\n // col 4 = 22\r\n // col 5 = 22\r\n // Total = 113\r\n //\r\n // As opposed to:\r\n // width of all cols = Total div colcount = 22\r\n // ==> Total = 22 * 5 = 110 [110 <> 113]\r\n Base := GridColWidth div MapColCount;\r\n MakeUp := GridColWidth mod MapColCount;\r\n\r\n MakeUpWidth := Lesser(MapCol - 1, MakeUp) * (Base + 1);\r\n BaseCount := MapCol - 1 - MakeUp;\r\n if BaseCount > 0 then\r\n BaseWidth := BaseCount * Base\r\n else\r\n BaseWidth := 0;\r\n\r\n ApptWidth := Base;\r\n if MapCol <= MakeUp then\r\n Inc(ApptWidth);\r\n\r\n Result.Left := VirtCellRect.Left + MakeUpWidth + BaseWidth;\r\n Result.Right := Result.Left + ApptWidth - ApptBuffer;\r\n Result.Top := VirtCellRect.Top;\r\n Result.Bottom := VirtualCellRect(Col, EndRow).Bottom;\r\nend;\r\n\r\nfunction TJvTFDays.LocateDivCol(X, TotalWidth, SegCount: Integer): Integer;\r\nvar\r\n Base, MakeUp, ApproxSeg, MakeUpWidth: Integer;\r\n BaseCount, BaseWidth, SegWidth, NextSegStart: Integer;\r\nbegin\r\n if X <= 0 then\r\n Result := 1\r\n else\r\n if X >= TotalWidth then\r\n Result := SegCount\r\n else\r\n begin\r\n Base := TotalWidth div SegCount;\r\n // Protect against div by zero\r\n if Base < 1 then\r\n Base := 1;\r\n MakeUp := TotalWidth mod SegCount;\r\n\r\n ApproxSeg := X div Base;\r\n\r\n MakeUpWidth := Lesser(ApproxSeg - 1, MakeUp) * (Base + 1);\r\n BaseCount := ApproxSeg - 1 - MakeUp;\r\n if BaseCount > 0 then\r\n BaseWidth := BaseCount * Base\r\n else\r\n BaseWidth := 0;\r\n\r\n SegWidth := Base;\r\n if ApproxSeg <= MakeUp then\r\n Inc(SegWidth);\r\n\r\n NextSegStart := MakeUpWidth + BaseWidth + SegWidth;\r\n if X < NextSegStart then\r\n Result := ApproxSeg\r\n else\r\n Result := ApproxSeg + 1;\r\n end;\r\nend;\r\n\r\nprocedure TJvTFDays.EditAppt(Col: Integer; Appt: TJvTFAppt);\r\nvar\r\n Schedule: TJvTFSched;\r\n ApptRect, EditorRect: TRect;\r\n // EditHeightThreshold, EditWidthThreshold: Integer;\r\n FailEditor: Boolean;\r\n PicsHeight, PicsWidth, FrameOffset: Integer;\r\n DrawList: TList;\r\n CanDrawText, CanDrawPics: Boolean;\r\n DrawInfo: TJvTFDaysApptDrawInfo;\r\n AllowEdit: Boolean;\r\nbegin\r\n FEditor.QuickCreate := False;\r\n EnsureCol(Col);\r\n Schedule := Cols[Col].Schedule;\r\n if not Assigned(Schedule) or not Assigned(Appt) or\r\n not (agoEditing in Options) or not CanEdit then\r\n Exit;\r\n\r\n AllowEdit := True;\r\n if Assigned(FOnBeginEdit) then\r\n FOnBeginEdit(Self, Appt, AllowEdit);\r\n if not AllowEdit then\r\n Exit;\r\n\r\n DrawInfo := TJvTFDaysApptDrawInfo.Create;\r\n try\r\n GetApptDrawInfo(DrawInfo, Appt, SelApptAttr);\r\n FrameOffset := DrawInfo.FrameWidth div 2 * 2;\r\n Canvas.Font := DrawInfo.Font;\r\n FEditor.Font := DrawInfo.Font;\r\n FEditor.Color := DrawInfo.Color;\r\n finally\r\n DrawInfo.Free;\r\n end;\r\n\r\n ApptRect := GetApptRect(Col, Appt);\r\n\r\n Windows.InflateRect(ApptRect, -FrameOffset, -FrameOffset);\r\n\r\n if ApptBar.Visible then\r\n Inc(ApptRect.Left, ApptBar.Width);\r\n\r\n AdjustForMargins(ApptRect);\r\n\r\n DrawList := TList.Create;\r\n try\r\n CreatePicDrawList(ApptRect, Appt, DrawList);\r\n FilterPicDrawList(ApptRect, DrawList, PicsHeight, PicsWidth);\r\n CanDrawWhat(Canvas, ApptRect, PicsHeight, CanDrawText, CanDrawPics);\r\n finally\r\n ClearPicDrawList(DrawList);\r\n DrawList.Free;\r\n end;\r\n\r\n if CanDrawPics then\r\n Inc(ApptRect.Left, PicsHeight);\r\n\r\n Windows.IntersectRect(EditorRect, GetDataAreaRect, ApptRect);\r\n\r\n// Commented out by Tim - No longer required since no editor failure.\r\n// EditHeightThreshold := CanvasMaxTextHeight(Canvas) * Thresholds.EditHeight;\r\n// EditWidthThreshold := Canvas.TextWidth('Bi') div 2 * Thresholds.EditWidth;\r\n\r\n// Commented out by Tim - The editor should no longer ever fail.\r\n// FailEditor := (RectHeight(EditorRect) < EditHeightThreshold) or\r\n// (RectWidth(EditorRect) < EditWidthThreshold);\r\n FailEditor := False;\r\n\r\n if FailEditor then\r\n begin\r\n if Assigned(FOnFailEditor) then\r\n FOnFailEditor(Self, Col, Appt, EditorRect, FailEditor);\r\n if not FailEditor then\r\n FEditor.BorderStyle := bsSingle;\r\n end\r\n else\r\n FEditor.BorderStyle := bsNone;\r\n\r\n if not FailEditor then\r\n with FEditor do\r\n begin\r\n FEditor.LinkedAppt := Appt;\r\n BoundsRect := EditorRect;\r\n\r\n if agoFormattedDesc in Options then\r\n Text := Appt.Description\r\n else\r\n Text := StripCRLF(Appt.Description);\r\n\r\n Self.Update; // not calling update here increases flicker\r\n Visible := True;\r\n\r\n if not (csDesigning in ComponentState) then\r\n SetFocus;\r\n SelLength := 0;\r\n SelStart := 0;\r\n end;\r\nend;\r\n\r\nprocedure TJvTFDays.FinishEditAppt;\r\nbegin\r\n if Assigned(FEditor.LinkedAppt) then\r\n FEditor.LinkedAppt.Description := FEditor.Text;\r\n FEditor.Visible := False;\r\nend;\r\n\r\nfunction TJvTFDays.Editing: Boolean;\r\nbegin\r\n Result := FEditor.Visible;\r\nend;\r\n\r\nfunction TJvTFDays.CanEdit: Boolean;\r\nbegin\r\n Result := agoShowText in Options;\r\nend;\r\n\r\nfunction TJvTFDays.RowsPerHour: Integer;\r\nbegin\r\n Result := 60 div Granularity;\r\nend;\r\n\r\nfunction TJvTFDays.RowCount: Integer;\r\nvar\r\n Adjustment, H, M, S, MS: Word;\r\n WorkTime: TTime;\r\nbegin\r\n WorkTime := GridEndTime;\r\n\r\n DecodeTime(WorkTime, H, M, S, MS);\r\n Adjustment := 0;\r\n\r\n if (H = 0) and (M = 0) then\r\n begin\r\n WorkTime := EncodeTime(23, 59, 59, 999);\r\n Adjustment := 1;\r\n end;\r\n\r\n //DecodeTime(GridEndTime - GridStartTime, H, M, S, MS);\r\n DecodeTime(WorkTime - GridStartTime, H, M, S, MS);\r\n Result := (H * 60 + M) div Granularity + Adjustment;\r\nend;\r\n\r\nfunction TJvTFDays.PossVisibleRows: Integer;\r\nvar\r\n DataHt: Integer;\r\nbegin\r\n //group DataHt := GetAdjClientRect.Bottom - ColHdrHeight;\r\n DataHt := GetAdjClientRect.Bottom - CalcGroupColHdrsHeight;\r\n Result := DataHt div RowHeight;\r\n if DataHt mod RowHeight <> 0 then\r\n Inc(Result);\r\nend;\r\n\r\nfunction TJvTFDays.VisibleRows: Integer;\r\nbegin\r\n Result := Lesser(PossVisibleRows, RowCount - TopRow);\r\nend;\r\n\r\nfunction TJvTFDays.FullVisibleRows: Integer;\r\nvar\r\n Poss, Vis: Integer;\r\nbegin\r\n Poss := PossVisibleRows;\r\n Vis := VisibleRows;\r\n\r\n if Poss = Vis then\r\n if GetDataHeight mod RowHeight = 0 then\r\n Result := Vis\r\n else\r\n Result := Vis - 1\r\n else\r\n Result := Vis;\r\nend;\r\n\r\nfunction TJvTFDays.VisibleCols: Integer;\r\nvar\r\n DataWidth, ColNum, TempColWidths: Integer;\r\nbegin\r\n if Cols.Count > 0 then\r\n begin\r\n // Calc the width of the data area\r\n DataWidth := GetDataWidth;\r\n\r\n // loop through cols until sum of col widths is >= width of data area\r\n TempColWidths := 0;\r\n ColNum := LeftCol;\r\n repeat\r\n Inc(TempColWidths, Cols[ColNum].Width);\r\n Inc(ColNum);\r\n until (TempColWidths >= DataWidth) or (ColNum = Cols.Count);\r\n\r\n Result := ColNum - LeftCol;\r\n end\r\n else\r\n Result := 0;\r\nend;\r\n\r\nfunction TJvTFDays.FullVisibleCols: Integer;\r\nvar\r\n I, RightCol, TempWidth: Integer;\r\nbegin\r\n // sum the widths of all visible cols\r\n RightCol := LeftCol + VisibleCols - 1;\r\n TempWidth := 0;\r\n for I := LeftCol to RightCol do\r\n Inc(TempWidth, Cols[I].Width);\r\n\r\n // if TempWidth > Data width then fully vis cols = one less the visible cols\r\n if TempWidth <= GetDataWidth then\r\n Result := VisibleCols\r\n else\r\n Result := VisibleCols - 1;\r\nend;\r\n\r\nfunction TJvTFDays.RowToTime(RowNum: Integer): TTime;\r\nvar\r\n TotalMins: Integer;\r\n WorkHours, WorkMins: Word;\r\n H, M, S, MS: Word;\r\n Offset: Integer;\r\nbegin\r\n EnsureRow(RowNum);\r\n\r\n DecodeTime(GridStartTime, H, M, S, MS);\r\n Offset := H * 60 + M;\r\n TotalMins := RowNum * Granularity + Offset;\r\n\r\n WorkHours := TotalMins div 60;\r\n WorkMins := TotalMins mod 60;\r\n if WorkHours < 24 then\r\n Result := EncodeTime(WorkHours, WorkMins, 0, 0)\r\n else\r\n Result := EncodeTime(23, 59, 59, 999);\r\nend;\r\n\r\nfunction TJvTFDays.TimeToRow(ATime: TTime): Integer;\r\nvar\r\n TotalMins: Integer;\r\n WorkHours, WorkMins, WorkSecs, WorkMSecs: Word;\r\n H, M, S, MS: Word;\r\n Offset: Integer;\r\nbegin\r\n DecodeTime(ATime, WorkHours, WorkMins, WorkSecs, WorkMSecs);\r\n\r\n // Convert the given time to minutes\r\n DecodeTime(GridStartTime, H, M, S, MS);\r\n Offset := H * 60 + M;\r\n TotalMins := WorkHours * 60 + WorkMins - Offset;\r\n\r\n // Find the row number by dividing the time in minutes by the granularity\r\n Result := TotalMins div Granularity;\r\n if (TotalMins < 0) and (TotalMins mod Granularity <> 0) then\r\n Dec(Result);\r\nend;\r\n\r\nprocedure TJvTFDays.TimeToTop(ATime: TTime);\r\nbegin\r\n TopRow := TimeToRow(ATime);\r\nend;\r\n\r\nfunction TJvTFDays.AdjustEndTime(ATime: TTime): TTime;\r\nbegin\r\n Result := Frac(Frac(ATime) - Frac(EncodeTime(0, 0, 1, 0)));\r\nend;\r\n\r\nfunction TJvTFDays.RowStartsHour(RowNum: Integer): Boolean;\r\nvar\r\n H, M, S, MS: Word;\r\nbegin\r\n EnsureRow(RowNum);\r\n\r\n DecodeTime(RowToTime(RowNum), H, M, S, MS);\r\n Result := M = 0;\r\nend;\r\n\r\nfunction TJvTFDays.RowEndsHour(RowNum: Integer): Boolean;\r\nvar\r\n H, M, S, MS: Word;\r\n TempTime: TTime;\r\nbegin\r\n EnsureRow(RowNum);\r\n\r\n TempTime := RowToTime(RowNum) + EncodeTime(0, Granularity - 1, 0, 0);\r\n DecodeTime(TempTime, H, M, S, MS);\r\n Result := M = 59;\r\nend;\r\n\r\nfunction TJvTFDays.RowEndTime(RowNum: Integer): TTime;\r\nbegin\r\n Result := RowToTime(RowNum) +\r\n Granularity * EncodeTime(0, 1, 0, 0) - EncodeTime(0, 0, 1, 0);\r\nend;\r\n\r\nfunction TJvTFDays.RowToHour(RowNum: Integer): Word;\r\nvar\r\n H, M, S, MS: Word;\r\nbegin\r\n DecodeTime(RowToTime(RowNum), H, M, S, MS);\r\n Result := H;\r\nend;\r\n\r\nfunction TJvTFDays.HourStartRow(Hour: Word): Integer;\r\nbegin\r\n Result := TimeToRow(EncodeTime(Hour, 0, 0, 0));\r\nend;\r\n\r\nfunction TJvTFDays.HourEndRow(Hour: Word): Integer;\r\nbegin\r\n Result := TimeToRow(EncodeTime(Hour, 59, 0, 0));\r\nend;\r\n\r\nfunction TJvTFDays.BottomRow: Integer;\r\nbegin\r\n Result := TopRow + VisibleRows - 1;\r\nend;\r\n\r\nfunction TJvTFDays.RightCol: Integer;\r\nbegin\r\n Result := LeftCol + VisibleCols - 1;\r\nend;\r\n\r\nprocedure TJvTFDays.DragDrop(Source: TObject; X, Y: Integer);\r\nbegin\r\n if Source is TJvTFControl then\r\n DropAppt(TJvTFControl(Source).DragInfo, X, Y);\r\n\r\n inherited DragDrop(Source, X, Y);\r\nend;\r\n\r\nprocedure TJvTFDays.CalcStartEndRows(AAppt: TJvTFAppt; SchedDate: TDate;\r\n var StartRow, EndRow: Integer);\r\nbegin\r\n if Trunc(AAppt.StartDate) = Trunc(SchedDate) then\r\n StartRow := TimeToRow(AAppt.StartTime)\r\n else\r\n StartRow := 0;\r\n\r\n if Trunc(AAppt.EndDate) = Trunc(SchedDate) then\r\n EndRow := TimeToRow(AdjustEndTime(AAppt.EndTime))\r\n else\r\n EndRow := RowCount - 1;\r\nend;\r\n\r\nprocedure TJvTFDays.PrevDate;\r\nbegin\r\n case Template.ActiveTemplate of\r\n agtLinear:\r\n Template.LinearStartDate := Template.LinearStartDate - 1;\r\n agtComparative:\r\n Template.CompDate := Template.CompDate - 1;\r\n end;\r\nend;\r\n\r\nprocedure TJvTFDays.NextDate;\r\nbegin\r\n case Template.ActiveTemplate of\r\n agtLinear:\r\n Template.LinearStartDate := Template.LinearStartDate + 1;\r\n agtComparative:\r\n Template.CompDate := Template.CompDate + 1;\r\n end;\r\nend;\r\n\r\nprocedure TJvTFDays.GotoDate(aDate: TDate);\r\nbegin\r\n case Template.ActiveTemplate of\r\n agtLinear:\r\n Template.LinearStartDate := aDate;\r\n agtComparative:\r\n Template.CompDate := aDate;\r\n end;\r\nend;\r\n\r\nprocedure TJvTFDays.ScrollDays(NumDays: Integer);\r\nvar\r\n OldDate: TDate;\r\n CanScroll: Boolean;\r\nbegin\r\n CanScroll := True;\r\n OldDate := Template.LinearStartDate;\r\n case Template.ActiveTemplate of\r\n agtLinear:\r\n OldDate := Template.LinearStartDate;\r\n agtComparative:\r\n OldDate := Template.CompDate;\r\n else\r\n CanScroll := False;\r\n end;\r\n\r\n if CanScroll then\r\n GotoDate(OldDate + NumDays);\r\nend;\r\n\r\nprocedure TJvTFDays.ScrollMonths(NumMonths: Integer);\r\nvar\r\n OldDate, EOM: TDate;\r\n CanScroll: Boolean;\r\n Y, M, D, EOMY, EOMM, EOMD, DeltaY, DeltaM: Word;\r\nbegin\r\n CanScroll := True;\r\n OldDate := Template.LinearStartDate;\r\n case Template.ActiveTemplate of\r\n agtLinear: OldDate := Template.LinearStartDate;\r\n agtComparative: OldDate := Template.CompDate;\r\n else\r\n CanScroll := False;\r\n end;\r\n\r\n if CanScroll then\r\n begin\r\n DecodeDate(OldDate, Y, M, D);\r\n\r\n DeltaY := NumMonths div 12;\r\n DeltaM := NumMonths mod 12;\r\n M := M + DeltaM;\r\n if M < 1 then\r\n begin\r\n Dec(DeltaY);\r\n M := 12 + M;\r\n end\r\n else\r\n if M > 12 then\r\n begin\r\n Inc(DeltaY);\r\n M := M - 12;\r\n end;\r\n\r\n Y := Y + DeltaY;\r\n EOM := EndOfMonth(EncodeDate(Y, M, 1));\r\n DecodeDate(EOM, EOMY, EOMM, EOMD);\r\n D := Lesser(D, EOMD);\r\n GotoDate(EncodeDate(Y, M, D));\r\n end;\r\nend;\r\n\r\nprocedure TJvTFDays.ScrollYears(NumYears: Integer);\r\nvar\r\n OldDate, EOM: TDate;\r\n Y, M, D, EOMY, EOMM, EOMD: Word;\r\n CanScroll: Boolean;\r\nbegin\r\n CanScroll := True;\r\n OldDate := Template.LinearStartDate;\r\n case Template.ActiveTemplate of\r\n agtLinear:\r\n OldDate := Template.LinearStartDate;\r\n agtComparative:\r\n OldDate := Template.CompDate;\r\n else\r\n CanScroll := False;\r\n end;\r\n\r\n if CanScroll then\r\n begin\r\n DecodeDate(OldDate, Y, M, D);\r\n Inc(Y, NumYears);\r\n EOM := EndOfMonth(EncodeDate(Y, M, 1));\r\n DecodeDate(EOM, EOMY, EOMM, EOMD);\r\n D := Lesser(D, EOMD);\r\n GotoDate(EncodeDate(Y, M, D));\r\n end;\r\nend;\r\n\r\nprocedure TJvTFDays.ReleaseSchedule(const SchedName: string; SchedDate: TDate);\r\nvar\r\n Used: Boolean;\r\n I: Integer;\r\n Col: TJvTFDaysCol;\r\nbegin\r\n // Only release schedule if not used by any grid cols\r\n Used := False;\r\n for I := 0 to Cols.Count - 1 do\r\n begin\r\n Col := Cols[I];\r\n if (Col.SchedName = SchedName) and\r\n (Trunc(Col.SchedDate) = Trunc(SchedDate)) and Col.Connected then\r\n Used := True and not (csDestroying in ScheduleManager.ComponentState);\r\n end;\r\n\r\n if not Used then\r\n inherited ReleaseSchedule(SchedName, SchedDate);\r\nend;\r\n\r\nprocedure TJvTFDays.RowInView(ARow: Integer);\r\nbegin\r\n EnsureRow(ARow);\r\n\r\n if ARow < TopRow then\r\n TopRow := ARow\r\n else\r\n if ARow > TopRow + FullVisibleRows - 1 then\r\n TopRow := Greater(ARow - FullVisibleRows + 1, 0);\r\nend;\r\n\r\nprocedure TJvTFDays.ColInView(ACol: Integer);\r\nvar\r\n I, ColSizes: Integer;\r\n DataWidth: Integer;\r\nbegin\r\n EnsureCol(ACol);\r\n\r\n if ACol < LeftCol then\r\n LeftCol := ACol\r\n else\r\n if ACol > RightCol then\r\n begin\r\n ColSizes := 0;\r\n DataWidth := RectWidth(GetDataAreaRect);\r\n I := ACol + 1;\r\n while (ColSizes < DataWidth) and (I >= 0) do\r\n begin\r\n Dec(I);\r\n Inc(ColSizes, Cols[I].Width);\r\n end;\r\n LeftCol := I + 1;\r\n end;\r\nend;\r\n\r\nfunction TJvTFDays.CellIsSelected(ACell: TPoint): Boolean;\r\nvar\r\n SelSameName, SelSameDate: Boolean;\r\n NameList: TStringList;\r\n I, TestStart, TestEnd: Integer;\r\n TestDate: TDate;\r\n\r\n function PointInDataArea(APoint: TPoint): Boolean;\r\n begin\r\n Result := (APoint.X > gcHdr) and (APoint.Y > gcHdr);\r\n end;\r\n\r\nbegin\r\n Result := False;\r\n if PointInDataArea(SelStart) and PointInDataArea(SelEnd) and PointInDataArea(ACell) then\r\n begin\r\n SelSameName := Cols[SelStart.X].SchedName = Cols[SelEnd.X].SchedName;\r\n SelSameDate := Trunc(Cols[SelStart.X].SchedDate) =\r\n Trunc(Cols[SelEnd.X].SchedDate);\r\n\r\n if SelSameName and SelSameDate then\r\n begin\r\n if (Cols[ACell.X].SchedName = Cols[SelStart.X].SchedName) and\r\n (Trunc(Cols[ACell.X].SchedDate) = Trunc(Cols[SelStart.X].SchedDate)) then\r\n Result := (ACell.Y >= SelStart.Y) and (ACell.Y <= SelEnd.Y)\r\n end\r\n else\r\n if SelSameName then\r\n begin\r\n if Cols[ACell.X].SchedName = Cols[SelStart.X].SchedName then\r\n begin\r\n TestDate := Cols[ACell.X].SchedDate;\r\n if Trunc(TestDate) = Trunc(Cols[SelStart.X].SchedDate) then\r\n Result := ACell.Y >= SelStart.Y\r\n else\r\n if (Trunc(TestDate) > Trunc(Cols[SelStart.X].SchedDate)) and\r\n (Trunc(TestDate) < Trunc(Cols[SelEnd.X].SchedDate)) then\r\n Result := True\r\n else\r\n if Trunc(TestDate) = Trunc(Cols[SelEnd.X].SchedDate) then\r\n Result := ACell.Y <= SelEnd.Y;\r\n end\r\n end\r\n else\r\n if SelSameDate then\r\n begin\r\n NameList := TStringList.Create;\r\n NameList.Sorted := True;\r\n NameList.Duplicates := dupIgnore;\r\n\r\n try\r\n for I := SelStart.X to SelEnd.X do\r\n NameList.Add(Cols[I].SchedName);\r\n\r\n if (NameList.IndexOf(Cols[ACell.X].SchedName) > -1) and\r\n (Trunc(Cols[SelStart.X].SchedDate) = Trunc(Cols[ACell.X].SchedDate)) then\r\n begin\r\n TestStart := Lesser(SelStart.Y, SelEnd.Y);\r\n TestEnd := Greater(SelStart.Y, SelEnd.Y);\r\n Result := (ACell.Y >= TestStart) and (ACell.Y <= TestEnd);\r\n end;\r\n finally\r\n NameList.Free;\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJvTFDays.ColIsSelected(ACol: Integer): Boolean;\r\nvar\r\n SelSameName, SelSameDate: Boolean;\r\n I: Integer;\r\n StartCol, EndCol, TestCol: TJvTFDaysCol;\r\nbegin\r\n Result := False;\r\n if (SelStart.X > gcHdr) and (SelEnd.X > gcHdr) then\r\n // Don't know if we really should be doing the follow check\r\n //and (ACol >= SelStart.X) and (ACol <= SelEnd.X) then\r\n begin\r\n // Determine type of selection (case)\r\n StartCol := Cols[SelStart.X];\r\n EndCol := Cols[SelEnd.X];\r\n TestCol := Cols[ACol];\r\n\r\n SelSameName := StartCol.SchedName = EndCol.SchedName;\r\n SelSameDate := Trunc(StartCol.SchedDate) = Trunc(EndCol.SchedDate);\r\n\r\n if SelSameName and SelSameDate then\r\n Result := (TestCol.SchedName = StartCol.SchedName) and\r\n (Trunc(TestCol.SchedDate) = Trunc(StartCol.SchedDate))\r\n else\r\n if SelSameName then\r\n Result := (TestCol.SchedName = StartCol.SchedName) and\r\n (Trunc(TestCol.SchedDate) >= Trunc(StartCol.SchedDate)) and\r\n (Trunc(TestCol.SchedDate) <= Trunc(EndCol.SchedDate))\r\n else\r\n if SelSameDate then\r\n if Trunc(TestCol.SchedDate) = Trunc(StartCol.SchedDate) then\r\n begin\r\n I := SelStart.X;\r\n while (I <= SelEnd.X) and not Result do\r\n if TestCol.SchedName = Cols[I].SchedName then\r\n Result := True\r\n else\r\n Inc(I);\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJvTFDays.RowIsSelected(ARow: Integer): Boolean;\r\nvar\r\n SelSameName, SelSameDate: Boolean;\r\n StartCol, EndCol: TJvTFDaysCol;\r\nbegin\r\n Result := False;\r\n if (SelStart.Y > gcHdr) and (SelEnd.Y > gcHdr) and\r\n (SelStart.X > gcHdr) and (SelEnd.X > gcHdr) then\r\n begin\r\n StartCol := Cols[SelStart.X];\r\n EndCol := Cols[SelEnd.X];\r\n\r\n SelSameName := StartCol.SchedName = EndCol.SchedName;\r\n SelSameDate := Trunc(StartCol.SchedDate) = Trunc(EndCol.SchedDate);\r\n\r\n if (SelSameName and SelSameDate) or SelSameDate then\r\n Result := (ARow >= SelStart.Y) and (ARow <= SelEnd.Y)\r\n else\r\n if SelSameName then\r\n Result := (ARow >= SelStart.Y) or (ARow <= SelEnd.Y);\r\n end;\r\nend;\r\n\r\nprocedure TJvTFDays.ClearSelection;\r\nbegin\r\n SelStart := Point(-1, -1);\r\nend;\r\n\r\nfunction TJvTFDays.ValidSelection: Boolean;\r\nbegin\r\n Result := (SelStart.X > gcHdr) and (SelStart.Y > gcHdr) and\r\n (SelEnd.X > gcHdr) and (SelEnd.Y > gcHdr);\r\nend;\r\n\r\nfunction TJvTFDays.EnumSelCells: TDynPointArray;\r\nvar\r\n SelSameName, SelSameDate: Boolean;\r\n NameList: TStringList;\r\n NextEntry, ACol, ARow: Integer;\r\n TestDate: TDate;\r\n\r\n procedure AddToArray(X, Y: Integer);\r\n begin\r\n Result[NextEntry] := Point(X, Y);\r\n Inc(NextEntry);\r\n end;\r\n\r\n procedure BumpLength(Bump: Integer);\r\n begin\r\n SetLength(Result, Length(Result) + Bump);\r\n end;\r\n\r\nbegin\r\n SetLength(Result, 0);\r\n NextEntry := 0;\r\n\r\n // EXIT IF NOTHING SELECTED\r\n if (SelStart.X <= gcHdr) or (SelStart.Y <= gcHdr) or\r\n (SelEnd.X <= gcHdr) or (SelEnd.Y <= gcHdr) then\r\n Exit;\r\n\r\n SelSameName := Cols[SelStart.X].SchedName = Cols[SelEnd.X].SchedName;\r\n SelSameDate := Trunc(Cols[SelStart.X].SchedDate) =\r\n Trunc(Cols[SelEnd.X].SchedDate);\r\n\r\n if SelSameName and SelSameDate then\r\n for ACol := 0 to Cols.Count - 1 do\r\n begin\r\n if (Cols[ACol].SchedName = Cols[SelStart.X].SchedName) and\r\n (Trunc(Cols[ACol].SchedDate) = Trunc(Cols[SelStart.X].SchedDate)) then\r\n begin\r\n BumpLength(SelEnd.Y - SelStart.Y + 1);\r\n for ARow := SelStart.Y to SelEnd.Y do\r\n AddToArray(ACol, ARow);\r\n end;\r\n end\r\n else\r\n if SelSameName then\r\n // only have to go to SelEnd.X??\r\n // What about if two cols have same SchedName and SchedDate??\r\n for ACol := 0 to Cols.Count - 1 do\r\n begin\r\n if Cols[ACol].SchedName = Cols[SelStart.X].SchedName then\r\n begin\r\n TestDate := Cols[ACol].SchedDate;\r\n\r\n if Trunc(TestDate) = Trunc(Cols[SelStart.X].SchedDate) then\r\n begin\r\n BumpLength(RowCount - SelStart.Y);\r\n for ARow := SelStart.Y to RowCount - 1 do\r\n AddToArray(ACol, ARow);\r\n end\r\n else\r\n if (Trunc(TestDate) > Trunc(Cols[SelStart.X].SchedDate)) and\r\n (Trunc(TestDate) < Trunc(Cols[SelEnd.X].SchedDate)) then\r\n begin\r\n BumpLength(RowCount);\r\n for ARow := 0 to RowCount - 1 do\r\n AddToArray(ACol, ARow);\r\n end\r\n else\r\n if Trunc(TestDate) = Trunc(Cols[SelEnd.X].SchedDate) then\r\n begin\r\n BumpLength(SelEnd.Y + 1);\r\n for ARow := 0 to SelEnd.Y do\r\n AddToArray(ACol, ARow);\r\n end;\r\n end;\r\n end\r\n else\r\n if SelSameDate then\r\n begin\r\n NameList := TStringList.Create;\r\n NameList.Sorted := True;\r\n NameList.Duplicates := dupIgnore;\r\n TestDate := Cols[SelStart.X].SchedDate;\r\n\r\n try\r\n for ACol := SelStart.X to SelEnd.X do\r\n NameList.Add(Cols[ACol].SchedName);\r\n\r\n for ACol := 0 to Cols.Count - 1 do\r\n if (NameList.IndexOf(Cols[ACol].SchedName) > -1) and\r\n (Trunc(Cols[ACol].SchedDate) = Trunc(TestDate)) then\r\n begin\r\n BumpLength(SelEnd.Y - SelStart.Y + 1);\r\n for ARow := SelStart.Y to SelEnd.Y do\r\n AddToArray(ACol, ARow);\r\n end;\r\n finally\r\n NameList.Free;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJvTFDays.EnumSelCols: TDynIntArray;\r\nvar\r\n SelSameName, SelSameDate: Boolean;\r\n I: Integer;\r\n TempList: TStringList;\r\n StartCol, EndCol, TestCol: TJvTFDaysCol;\r\n\r\n procedure AddToArray(ACol: Integer);\r\n begin\r\n SetLength(Result, Length(Result) + 1);\r\n Result[Length(Result) - 1] := ACol;\r\n end;\r\n\r\nbegin\r\n SetLength(Result, 0);\r\n\r\n if (SelStart.X > gcHdr) and (SelEnd.X > gcHdr) then\r\n begin\r\n StartCol := Cols[SelStart.X];\r\n EndCol := Cols[SelEnd.X];\r\n\r\n SelSameName := StartCol.SchedName = EndCol.SchedName;\r\n SelSameDate := Trunc(StartCol.SchedDate) = Trunc(EndCol.SchedDate);\r\n\r\n if SelSameName and SelSameDate then\r\n for I := 0 to Cols.Count - 1 do\r\n begin\r\n TestCol := Cols[I];\r\n if (TestCol.SchedName = StartCol.SchedName) and\r\n (Trunc(TestCol.SchedDate) = Trunc(StartCol.SchedDate)) then\r\n AddToArray(I);\r\n end\r\n else\r\n if SelSameName then\r\n for I := 0 to Cols.Count - 1 do\r\n begin\r\n TestCol := Cols[I];\r\n if (TestCol.SchedName = StartCol.SchedName) and\r\n ((Trunc(TestCol.SchedDate) >= Trunc(StartCol.SchedDate)) and\r\n (Trunc(TestCol.SchedDate) <= Trunc(EndCol.SchedDate))) then\r\n AddToArray(I);\r\n end\r\n else\r\n if SelSameDate then\r\n begin\r\n TempList := TStringList.Create;\r\n TempList.Sorted := True;\r\n TempList.Duplicates := dupIgnore;\r\n\r\n try\r\n for I := SelStart.X to SelEnd.X do\r\n TempList.Add(Cols[I].SchedName);\r\n\r\n for I := 0 to Cols.Count - 1 do\r\n begin\r\n TestCol := Cols[I];\r\n if (Trunc(TestCol.SchedDate) = Trunc(StartCol.SchedDate)) and\r\n (TempList.IndexOf(TestCol.SchedName) > -1) then\r\n AddToArray(I);\r\n end;\r\n finally\r\n TempList.Free;\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJvTFDays.EnumSelRows: TDynIntArray;\r\nvar\r\n SelSameName, SelSameDate: Boolean;\r\n StartCol, EndCol: TJvTFDaysCol;\r\n I: Integer;\r\n\r\n procedure AddToArray(ACol: Integer);\r\n begin\r\n SetLength(Result, Length(Result) + 1);\r\n Result[Length(Result) - 1] := ACol;\r\n end;\r\n\r\nbegin\r\n SetLength(Result, 0);\r\n\r\n if (SelStart.Y > gcHdr) and (SelEnd.Y > gcHdr) and\r\n (SelStart.X > gcHdr) and (SelEnd.X > gcHdr) then\r\n begin\r\n StartCol := Cols[SelStart.X];\r\n EndCol := Cols[SelEnd.X];\r\n\r\n SelSameName := StartCol.SchedName = EndCol.SchedName;\r\n SelSameDate := Trunc(StartCol.SchedDate) = Trunc(EndCol.SchedDate);\r\n\r\n if (SelSameName and SelSameDate) or SelSameDate then\r\n for I := SelStart.Y to SelEnd.Y do\r\n AddToArray(I)\r\n else\r\n if SelSameName then\r\n for I := 0 to RowCount - 1 do\r\n if (I >= SelStart.Y) or (I <= SelEnd.Y) then\r\n AddToArray(I);\r\n end;\r\nend;\r\n\r\nfunction TJvTFDays.GetApptDispColor(Appt: TJvTFAppt; Selected: Boolean): TColor;\r\nbegin\r\n if Selected then\r\n if SelApptAttr.Color = clDefault then\r\n if Appt.Color = clDefault then\r\n Result := ApptAttr.Color\r\n else\r\n Result := Appt.Color\r\n else\r\n Result := SelApptAttr.Color\r\n else\r\n if Appt.Color = clDefault then\r\n Result := ApptAttr.Color\r\n else\r\n Result := Appt.Color;\r\nend;\r\n\r\nprocedure TJvTFDays.ReqSchedNotification(Schedule: TJvTFSched);\r\nvar\r\n I: Integer;\r\n Col: TJvTFDaysCol;\r\nbegin\r\n inherited ReqSchedNotification(Schedule);\r\n\r\n for I := 0 to Cols.Count - 1 do\r\n begin\r\n Col := Cols[I];\r\n if (Col.SchedName = Schedule.SchedName) and\r\n (Trunc(Col.SchedDate) = Trunc(Schedule.SchedDate)) then\r\n Col.Connect;\r\n end;\r\nend;\r\n\r\nprocedure TJvTFDays.SelFirstAppt;\r\nvar\r\n FirstAppt: TJvTFAppt;\r\n RefCol: Integer;\r\nbegin\r\n RefCol := 0;\r\n FirstAppt := nil;\r\n\r\n while not Assigned(FirstAppt) and (RefCol < Cols.Count) do\r\n begin\r\n FirstAppt := Cols[RefCol].GetFirstAppt;\r\n Inc(RefCol);\r\n end;\r\n\r\n if Assigned(FirstAppt) then\r\n begin\r\n SelAppt := FirstAppt;\r\n // The actual Reference Col will be one less than RefCol coming out of\r\n // the above loop.\r\n ApptInView(FirstAppt, RefCol - 1);\r\n SelApptCell(FirstAppt, RefCol - 1);\r\n end;\r\nend;\r\n\r\nprocedure TJvTFDays.SelLastAppt;\r\nvar\r\n LastAppt: TJvTFAppt;\r\n RefCol: Integer;\r\nbegin\r\n RefCol := Cols.Count - 1;\r\n LastAppt := nil;\r\n\r\n while not Assigned(LastAppt) and (RefCol > -1) do\r\n begin\r\n LastAppt := Cols[RefCol].GetLastAppt;\r\n Dec(RefCol);\r\n end;\r\n\r\n if Assigned(LastAppt) then\r\n begin\r\n SelAppt := LastAppt;\r\n ApptInView(LastAppt, RefCol + 1);\r\n SelApptCell(LastAppt, RefCol + 1);\r\n end;\r\n\r\n{\r\n if Cols.Count > 0 then\r\n LastAppt := Cols[Cols.Count - 1].GetLastAppt;\r\n\r\n if not Assigned(LastAppt) and (Cols.Count > 1) then\r\n begin\r\n RefCol := Cols.Count - 2;\r\n while not Assigned(LastAppt) and (RefCol >= 0) do\r\n begin\r\n LastAppt := Cols[RefCol].GetLastAppt;\r\n Dec(RefCol);\r\n end;\r\n if Assigned(LastAppt) then\r\n Inc(RefCol);\r\n end;\r\n\r\n SelAppt := LastAppt;\r\n ApptInView(LastAppt, RefCol);\r\n SelApptCell(LastAppt, RefCol);\r\n}\r\nend;\r\n\r\nprocedure TJvTFDays.SelNextAppt;\r\nvar\r\n RefAppt, NextAppt: TJvTFAppt;\r\n RefCol: Integer;\r\nbegin\r\n RefAppt := SelAppt;\r\n RefCol := FocusedCol;\r\n if RefCol < 0 then\r\n RefCol := 0;\r\n\r\n NextAppt := nil;\r\n while not Assigned(NextAppt) and (RefCol < Cols.Count) do\r\n begin\r\n NextAppt := Cols[RefCol].GetNextAppt(RefAppt);\r\n Inc(RefCol);\r\n end;\r\n\r\n if Assigned(NextAppt) then\r\n begin\r\n SelAppt := NextAppt;\r\n ApptInView(NextAppt, RefCol - 1);\r\n SelApptCell(NextAppt, RefCol - 1);\r\n end;\r\n\r\n{\r\n RefAppt := SelAppt;\r\n RefCol := Greater(FocusedCol, 0);\r\n\r\n if Assigned(RefAppt) then\r\n NextAppt := Cols[RefCol].GetNextAppt(RefAppt)\r\n else\r\n NextAppt := Cols[RefCol].GetFirstAppt;\r\n\r\n if not Assigned(NextAppt) then\r\n begin\r\n NextCol := RefCol + 1;\r\n if NextCol = Cols.Count then\r\n NextCol := 0;\r\n\r\n while not Assigned(NextAppt) and (NextCol <> RefCol) do\r\n begin\r\n NextAppt := Cols[NextCol].GetFirstAppt;\r\n if not Assigned(NextAppt) then\r\n begin\r\n Inc(NextCol);\r\n if NextCol = Cols.Count then\r\n NextCol := 0;\r\n end;\r\n end;\r\n RefCol := NextCol;\r\n end;\r\n\r\n SelAppt := NextAppt;\r\n ApptInView(NextAppt, RefCol);\r\n SelApptCell(NextAppt, RefCol);\r\n}\r\nend;\r\n\r\nprocedure TJvTFDays.SelPrevAppt;\r\nvar\r\n RefAppt, PrevAppt: TJvTFAppt;\r\n RefCol: Integer;\r\nbegin\r\n RefAppt := SelAppt;\r\n RefCol := FocusedCol;\r\n if RefCol < 0 then\r\n RefCol := Cols.Count - 1;\r\n\r\n PrevAppt := nil;\r\n while not Assigned(PrevAppt) and (RefCol > -1) do\r\n begin\r\n PrevAppt := Cols[RefCol].GetPrevAppt(RefAppt);\r\n Dec(RefCol);\r\n end;\r\n\r\n if Assigned(PrevAppt) then\r\n begin\r\n SelAppt := PrevAppt;\r\n ApptInView(PrevAppt, RefCol + 1);\r\n SelApptCell(PrevAppt, RefCol + 1);\r\n end;\r\n\r\n{\r\n if Assigned(RefAppt) then\r\n PrevAppt := Cols[RefCol].GetPrevAppt(RefAppt)\r\n else\r\n PrevAppt := Cols[RefCol].GetFirstAppt;\r\n\r\n if not Assigned(PrevAppt) then\r\n begin\r\n PrevCol := RefCol - 1;\r\n if PrevCol = -1 then\r\n PrevCol := Cols.Count - 1;\r\n\r\n while not Assigned(PrevAppt) and (PrevCol <> RefCol) do\r\n begin\r\n PrevAppt := Cols[PrevCol].GetLastAppt;\r\n if not Assigned(PrevAppt) then\r\n begin\r\n Dec(PrevCol);\r\n if PrevCol = -1 then\r\n PrevCol := Cols.Count - 1;\r\n end;\r\n end;\r\n\r\n RefCol := PrevCol;\r\n end;\r\n\r\n SelAppt := PrevAppt;\r\n ApptInView(PrevAppt, RefCol);\r\n SelApptCell(PrevAppt, RefCol);\r\n}\r\nend;\r\n\r\nprocedure TJvTFDays.ApptInView(AAppt: TJvTFAppt; ACol: Integer);\r\nvar\r\n StartRow, EndRow: Integer;\r\nbegin\r\n if Assigned(AAppt) and Assigned(Cols[ACol].Schedule) then\r\n begin\r\n CalcStartEndRows(AAppt, Cols[ACol].Schedule.SchedDate, StartRow, EndRow);\r\n RowInView(StartRow);\r\n ColInView(ACol);\r\n //TopRow := StartRow;\r\n //LeftCol := ACol;\r\n end;\r\nend;\r\n\r\nprocedure TJvTFDays.SelApptCell(AAppt: TJvTFAppt; ACol: Integer);\r\nvar\r\n StartRow, EndRow: Integer;\r\nbegin\r\n if Assigned(AAppt) and Assigned(Cols[ACol].Schedule) and\r\n (Cols[ACol].Schedule.ApptByID(AAppt.ID) <> nil) then\r\n begin\r\n CalcStartEndRows(AAppt, Cols[ACol].Schedule.SchedDate, StartRow, EndRow);\r\n SelStart := Point(ACol, StartRow);\r\n FocusedCol := ACol;\r\n FocusedRow := StartRow;\r\n end;\r\nend;\r\n\r\nprocedure TJvTFDays.SetGrouping(Value: TJvTFDaysGrouping);\r\nvar\r\n CheckSB: Boolean;\r\nbegin\r\n if Value <> FGrouping then\r\n begin\r\n CheckSB := (Value = grNone) or (FGrouping = grNone);\r\n FGrouping := Value;\r\n Cols.UpdateTitles;\r\n if CheckSB then\r\n begin\r\n AlignScrollBars;\r\n if not (csLoading in ComponentState) then\r\n begin\r\n CheckSBVis;\r\n CheckSBParams;\r\n end;\r\n end;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\n{\r\nprocedure TJvTFDays.SetGroupTitles;\r\nvar\r\n I: Integer;\r\nbegin\r\n Case Grouping of\r\n grNone :\r\n For I := 0 to Cols.Count - 1 do\r\n begin\r\n Cols[I].GroupTitle := '';\r\n //Cols[I].UpdateTitle;\r\n Cols[I].UpdateTitles;\r\n end;\r\n grDate :\r\n For I := 0 to Cols.Count - 1 do\r\n begin\r\n Cols[I].GroupTitle := FormatDateTime(DateFormat, Cols[I].SchedDate);\r\n Cols[I].Title := Cols[I].SchedName;\r\n end;\r\n grResource :\r\n For I := 0 to Cols.Count - 1 do\r\n begin\r\n Cols[I].GroupTitle := Cols[I].SchedName;\r\n Cols[I].Title := FormatDateTime(DateFormat, Cols[I].SchedDate);\r\n end;\r\n grCustom :\r\n For I := 0 to Cols.Count - 1 do\r\n begin\r\n Cols[I].GroupTitle := '';\r\n end;\r\n end;\r\nend;\r\n}\r\n\r\nprocedure TJvTFDays.SetTFHintProps(Value: TJvTFHintProps);\r\nbegin\r\n FHintProps.Assign(Value);\r\nend;\r\n\r\nprocedure TJvTFDays.DrawDither(ACanvas: TCanvas; ARect: TRect;\r\n Color1, Color2: TColor);\r\nvar\r\n DitherBitmap: TBitmap;\r\n I, J: Integer;\r\n// TL: TPoint;\r\n// ClipRgn: HRgn;\r\nbegin\r\n DitherBitmap := TBitmap.Create;\r\n try\r\n // create dithered bitmap\r\n// DitherBitmap.Width := RectWidth(ARect);\r\n// DitherBitmap.Height := RectHeight(ARect);\r\n DitherBitmap.Width := 8;\r\n DitherBitmap.Height := 8;\r\n\r\n for I := 0 to DitherBitmap.Width - 1 do\r\n for J := 0 to DitherBitmap.Height - 1 do\r\n if (I + J) mod 2 = 0 then\r\n DitherBitmap.Canvas.Pixels[I, J] := Color1\r\n else\r\n DitherBitmap.Canvas.Pixels[I, J] := Color2;\r\n\r\n // copy bitmap into canvas\r\n// ClipRgn := Windows.CreateRectRgn(ARect.Left, ARect.Top, ARect.Right + 1, ARect.Bottom + 1);\r\n// try\r\n// Windows.SelectClipRgn(ACanvas.Handle, ClipRgn);\r\n// TL.X := ARect.Left;\r\n// while (TL.X <= ARect.Right) do\r\n// begin\r\n// TL.Y := ARect.Top;\r\n// while (TL.Y <= ARect.Bottom) do\r\n// begin\r\n// Windows.BitBlt(ACanvas.Handle, TL.X, TL.Y, DitherBitmap.Width, DitherBitmap.Height,\r\n// DitherBitmap.Canvas.Handle, 0, 0, SRCCOPY);\r\n// TL.Y := TL.Y + DitherBitmap.Height;\r\n// end;\r\n// TL.X := TL.X + DitherBitmap.Width;\r\n// end;\r\n// finally\r\n// Windows.SelectClipRgn(ACanvas.Handle, 0);\r\n// Windows.DeleteObject(ClipRgn);\r\n// end;\r\n\r\n ACanvas.Brush.Bitmap := DitherBitmap;\r\n ACanvas.FillRect(ARect);\r\n\r\n// Windows.BitBlt(ACanvas.Handle, ARect.Left, ARect.Top, DitherBitmap.Width, DitherBitmap.Height,\r\n// DitherBitmap.Canvas.Handle, 0, 0, SRCCOPY);\r\n finally\r\n DitherBitmap.Free;\r\n end;\r\nend;\r\n\r\nprocedure TJvTFDays.SelFirstApptNextCol;\r\nvar\r\n FirstAppt: TJvTFAppt;\r\n RefCol: Integer;\r\nbegin\r\n RefCol := FocusedCol + 1;\r\n FirstAppt := nil;\r\n\r\n while not Assigned(FirstAppt) and (RefCol < Cols.Count) do\r\n begin\r\n FirstAppt := Cols[RefCol].GetFirstAppt;\r\n Inc(RefCol);\r\n end;\r\n\r\n if Assigned(FirstAppt) then\r\n begin\r\n SelAppt := FirstAppt;\r\n // The actual Reference Col will be one less than RefCol coming out of\r\n // the above loop.\r\n ApptInView(FirstAppt, RefCol - 1);\r\n SelApptCell(FirstAppt, RefCol - 1);\r\n end;\r\nend;\r\n\r\nprocedure TJvTFDays.SelFirstApptPrevCol;\r\nvar\r\n FirstAppt: TJvTFAppt;\r\n RefCol: Integer;\r\nbegin\r\n if Cols.Count = 0 then\r\n Exit;\r\n\r\n RefCol := FocusedCol - 1;\r\n if RefCol < 0 then\r\n RefCol := 0;\r\n FirstAppt := nil;\r\n\r\n while not Assigned(FirstAppt) and (RefCol > -1) do\r\n begin\r\n FirstAppt := Cols[RefCol].GetFirstAppt;\r\n Dec(RefCol);\r\n end;\r\n\r\n if Assigned(FirstAppt) then\r\n begin\r\n SelAppt := FirstAppt;\r\n ApptInView(FirstAppt, RefCol + 1);\r\n SelApptCell(FirstAppt, RefCol + 1);\r\n end;\r\nend;\r\n\r\nprocedure TJvTFDays.SetGroupHdrHeight(Value: Integer);\r\nbegin\r\n if Value > RectHeight(GetAdjClientRect) then\r\n Value := RectHeight(GetAdjClientRect);\r\n if Value < 0 then\r\n Value := 0;\r\n\r\n if Value <> FGroupHdrHeight then\r\n begin\r\n FGroupHdrHeight := Value;\r\n AlignScrollBars;\r\n if not (csLoading in ComponentState) then\r\n begin\r\n CheckSBVis;\r\n CheckSBParams;\r\n Invalidate;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvTFDays.DrawGroupHdrs(ACanvas: TCanvas);\r\nvar\r\n CurrGroup: string;\r\n I: Integer;\r\nbegin\r\n if (CalcGroupHdrHeight > 0) and (Cols.Count > 0) then\r\n begin\r\n CurrGroup := Cols[LeftCol].GroupTitle;\r\n DrawColGroupHdr(ACanvas, LeftCol, True);\r\n for I := LeftCol + 1 to RightCol do\r\n if Cols[I].GroupTitle <> CurrGroup then\r\n begin\r\n CurrGroup := Cols[I].GroupTitle;\r\n DrawColGroupHdr(ACanvas, I, True);\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJvTFDays.CalcGroupColHdrsHeight: Integer;\r\nbegin\r\n Result := CalcGroupHdrHeight + ColHdrHeight;\r\nend;\r\n\r\nfunction TJvTFDays.CalcGroupHdrHeight: Integer;\r\nbegin\r\n if Grouping = grNone then\r\n Result := 0\r\n else\r\n Result := GroupHdrHeight;\r\nend;\r\n\r\nfunction TJvTFDays.VirtualGroupHdrRect(Col: Integer): TRect;\r\nvar\r\n I, GroupStartCol, GroupEndCol, GroupWidth: Integer;\r\nbegin\r\n EnsureCol(Col);\r\n\r\n Result.Top := 0;\r\n Result.Bottom := CalcGroupHdrHeight;\r\n\r\n GetGroupStartEndCols(Col, GroupStartCol, GroupEndCol);\r\n GroupWidth := 0;\r\n for I := GroupStartCol to GroupEndCol do\r\n Inc(GroupWidth, Cols[I].Width);\r\n\r\n {$IFDEF Jv_TIMEBLOCKS}\r\n // ok\r\n Result.Left := CalcBlockRowHdrsWidth;\r\n {$ELSE}\r\n // remove\r\n //Result.Left := RowHdrWidth;\r\n {$ENDIF Jv_TIMEBLOCKS}\r\n\r\n // At most, only one of the following For loops will execute\r\n // depending on whether Col is to the left or to the right of LeftCol\r\n for I := LeftCol - 1 downto GroupStartCol do\r\n Dec(Result.Left, Cols[I].Width);\r\n\r\n for I := LeftCol to GroupStartCol - 1 do\r\n Inc(Result.Left, Cols[I].Width);\r\n\r\n Result.Right := Result.Left + GroupWidth;\r\nend;\r\n\r\nprocedure TJvTFDays.GetGroupStartEndCols(Col: Integer;\r\n var StartCol, EndCol: Integer);\r\nvar\r\n I: Integer;\r\nbegin\r\n EnsureCol(Col);\r\n\r\n // find group start col\r\n I := Col;\r\n while (I >= 0) and (Cols[I].GroupTitle = Cols[Col].GroupTitle) do\r\n begin\r\n StartCol := I;\r\n Dec(I);\r\n end;\r\n\r\n // find group end col\r\n I := Col;\r\n while (I < Cols.Count) and (Cols[I].GroupTitle = Cols[Col].GroupTitle) do\r\n begin\r\n EndCol := I;\r\n Inc(I);\r\n end;\r\nend;\r\n\r\n{\r\nprocedure TJvTFDays.DrawGroupHdr(ACanvas: TCanvas; ACol: Integer);\r\nvar\r\n ARect: TRect;\r\n Attr: TJvTFDaysHdrAttr;\r\nbegin\r\n ARect := VirtualGroupHdrRect(ACol);\r\n if GroupHdrIsSelected(ACol) then\r\n Attr := SelGroupHdrAttr\r\n else\r\n Attr := GroupHdrAttr;\r\n\r\n With ACanvas do\r\n begin\r\n Font.Assign(Attr.Font);\r\n Brush.Color := Attr.Color;\r\n FillRect(ARect);\r\n\r\n {\r\n Brush.Color := clWhite;\r\n FillRect(ARect);\r\n Pen.Color := clBlack;\r\n MoveTo(ARect.Left, ARect.Top);\r\n LineTo(ARect.Right - 1, ARect.Bottom - 1);\r\n MoveTo(ARect.Right - 1, ARect.Top);\r\n LineTo(ARect.Left, ARect.Bottom - 1);\r\n }\r\n {\r\n MoveTo(ARect.Right - 1, ARect.Top);\r\n LineTo(ARect.Right - 1, ARect.Bottom - 1);\r\n LineTo(ARect.Left, ARect.Bottom - 1);\r\n }\r\n{ end;\r\nend;\r\n}\r\n\r\nprocedure TJvTFDays.SetGroupHdrAttr(Value: TJvTFDaysHdrAttr);\r\nbegin\r\n FGroupHdrAttr.Assign(Value);\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvTFDays.SetSelGroupHdrAttr(Value: TJvTFDaysHdrAttr);\r\nbegin\r\n FSelGroupHdrAttr.Assign(Value);\r\n Invalidate;\r\nend;\r\n\r\nfunction TJvTFDays.GroupHdrIsSelected(ACol: Integer): Boolean;\r\nvar\r\n I, GroupStartCol, GroupEndCol: Integer;\r\nbegin\r\n GetGroupStartEndCols(ACol, GroupStartCol, GroupEndCol);\r\n Result := False;\r\n I := GroupStartCol;\r\n while (I <= GroupEndCol) and not Result do\r\n begin\r\n if ColIsSelected(I) then\r\n Result := True;\r\n Inc(I);\r\n end;\r\nend;\r\n\r\nprocedure TJvTFDays.DrawColGroupHdr(ACanvas: TCanvas; Index: Integer;\r\n IsGroupHdr: Boolean);\r\nvar\r\n ARect, TxtRect, CalcRect, TxtBounds: TRect;\r\n Txt: string;\r\n PTxt: PChar;\r\n UseAttr: TJvTFDaysHdrAttr;\r\n Flags: UINT;\r\n TxtHt, TxtRectHt: Integer;\r\nbegin\r\n if IsGroupHdr then\r\n begin\r\n ARect := VirtualGroupHdrRect(Index);\r\n ARect.Left := Greater(ARect.Left, GetDataAreaRect.Left);\r\n Txt := Copy(Cols[Index].GroupTitle, 1, Length(Cols[Index].GroupTitle));\r\n if GroupHdrIsSelected(Index) then\r\n UseAttr := SelGroupHdrAttr\r\n else\r\n UseAttr := GroupHdrAttr;\r\n end\r\n else\r\n begin\r\n ARect := CellRect(Index, -1);\r\n //Txt := Copy(Cols[Index].Title, 1, Length(Cols[Index].Title));\r\n Txt := Copy(Cols[Index].Title, 1, Length(Cols[Index].Title));\r\n if ColIsSelected(Index) then\r\n UseAttr := SelHdrAttr\r\n else\r\n UseAttr := HdrAttr;\r\n end;\r\n\r\n ACanvas.Brush.Color := UseAttr.Color;\r\n ACanvas.Font.Assign(UseAttr.Font);\r\n\r\n Flags := DT_NOPREFIX or DT_CENTER;\r\n case ColTitleStyle of\r\n ctsSingleClip:\r\n Flags := Flags or DT_SINGLELINE or DT_VCENTER;\r\n ctsSingleEllipsis:\r\n Flags := Flags or DT_END_ELLIPSIS or DT_SINGLELINE or DT_VCENTER;\r\n ctsMultiClip:\r\n Flags := Flags or DT_WORDBREAK;\r\n ctsMultiEllipsis:\r\n Flags := Flags or DT_END_ELLIPSIS or DT_WORDBREAK or DT_EDITCONTROL;\r\n ctsHide:\r\n Flags := Flags or DT_SINGLELINE or DT_VCENTER;\r\n end;\r\n\r\n ACanvas.FillRect(ARect);\r\n TxtRect := ARect;\r\n Windows.InflateRect(TxtRect, -2, -2);\r\n CalcRect := TxtRect;\r\n\r\n // Allocate length of Txt + 4 chars\r\n // (1 char for null terminator, 3 chars for ellipsis)\r\n // Ahh, what the hell. Allocate + dozen chars for good measure.\r\n // (This is continuing to give me problems and I don't know why.)\r\n //PTxt := StrAlloc((Length(Txt) + 4) * SizeOf(Char));\r\n PTxt := StrAlloc((Length(Txt) + 12) * SizeOf(Char));\r\n try\r\n StrPCopy(PTxt, Txt);\r\n\r\n if (ColTitleStyle = ctsMultiClip) or (ColTitleStyle = ctsMultiEllipsis) then\r\n begin\r\n TxtHt := Windows.DrawText(ACanvas.Handle, PTxt, -1, CalcRect,\r\n Flags or DT_CALCRECT);\r\n // \"reset\" PTxt\r\n StrPCopy(PTxt, Txt);\r\n\r\n if TxtHt < RectHeight(TxtRect) then\r\n begin\r\n // we need to vertically center the text\r\n TxtRectHt := RectHeight(TxtRect);\r\n TxtRect.Top := TxtRect.Top + RectHeight(TxtRect) div 2 - TxtHt div 2;\r\n TxtRect.Bottom := Lesser(TxtRect.Top + TxtRectHt, TxtRect.Bottom);\r\n end;\r\n end\r\n else\r\n if ColTitleStyle = ctsHide then\r\n begin\r\n Windows.DrawText(ACanvas.Handle, PTxt, -1, CalcRect, Flags or DT_CALCRECT);\r\n if RectWidth(CalcRect) > RectWidth(TxtRect) then\r\n StrPCopy(PTxt, '');\r\n end\r\n {$IFDEF Jv_TIMEBLOCKS}\r\n // okay to leave\r\n else\r\n if ColTitleStyle = ctsRotated then\r\n //DrawAngleText(ACanvas, TxtRect, UseAttr.TitleRotation, Txt);\r\n DrawAngleText(ACanvas, TxtRect, TxtBounds, UseAttr.TitleRotation,\r\n taCenter, vaCenter, Txt);\r\n {$ELSE}\r\n // remove\r\n //; // semi-colon needed to terminate last end\r\n {$ENDIF Jv_TIMEBLOCKS}\r\n\r\n {$IFDEF Jv_TIMEBLOCKS}\r\n // okay to leave\r\n if ColTitleStyle <> ctsRotated then\r\n Windows.DrawText(ACanvas.Handle, PTxt, -1, TxtRect, Flags);\r\n {$ELSE}\r\n // remove\r\n //Windows.DrawText(ACanvas.Handle, PTxt, -1, TxtRect, Flags);\r\n {$ENDIF Jv_TIMEBLOCKS}\r\n finally\r\n StrDispose(PTxt);\r\n end;\r\n\r\n if not IsGroupHdr and (Index = FocusedCol) and Focused then\r\n begin\r\n CalcRect := ARect;\r\n Windows.InflateRect(CalcRect, -2, -2);\r\n ManualFocusRect(ACanvas, CalcRect);\r\n {\r\n if Windows.IsRectEmpty(TxtRect) then\r\n Windows.InflateRect(TxtRect, 5, 5);\r\n ManualFocusRect(ACanvas, TxtRect);\r\n }\r\n end;\r\n\r\n {$IFDEF Jv_TIMEBLOCKS}\r\n // okay to leave\r\n DrawFrame(ACanvas, ARect, UseAttr.Frame3D, UseAttr.FrameColor);\r\n {$ELSE}\r\n // remove\r\n //DrawFrame(ACanvas, ARect, UseAttr.Frame3D);\r\n {$ENDIF Jv_TIMEBLOCKS}\r\n\r\n if IsGroupHdr then\r\n begin\r\n if Assigned(FOnDrawGroupHdr) then\r\n FOnDrawGroupHdr(Self, ACanvas, ARect, Index, GroupHdrIsSelected(Index));\r\n end\r\n else\r\n if Assigned(FOnDrawColHdr) then\r\n FOnDrawColHdr(Self, ACanvas, ARect, Index, ColIsSelected(Index));\r\nend;\r\n\r\n{$IFDEF Jv_TIMEBLOCKS}\r\n// ok\r\n\r\nprocedure TJvTFDays.SetTimeBlocks(Value: TJvTFDaysTimeBlocks);\r\nbegin\r\n FTimeBlocks.Assign(Value);\r\nend;\r\n\r\nprocedure TJvTFDays.SetTimeBlockProps(Value: TJvTFDaysBlockProps);\r\nbegin\r\n FTimeBlockProps.Assign(Value);\r\nend;\r\n\r\nprocedure TJvTFDays.SetWeekend(Value: TTFDaysOfWeek);\r\nbegin\r\n if Value <> FWeekend then\r\n begin\r\n FWeekend := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvTFDays.SetWeekendColor(Value: TColor);\r\nbegin\r\n if Value <> FWeekendColor then\r\n begin\r\n FWeekendColor := Value;\r\n UpdateWeekendFillPic;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvTFDays.UpdateWeekendFillPic;\r\nbegin\r\n FWeekendFillPic.Canvas.Brush.Color := WeekendColor;\r\n FWeekendFillPic.Canvas.FillRect(Classes.Rect(0, 0, FWeekendFillPic.Width,\r\n FWeekendFillPic.Height));\r\nend;\r\n\r\nprocedure TJvTFDays.DrawBlockHdr(ACanvas: TCanvas; BlockIndex: Integer);\r\nvar\r\n ARect, HdrPicRect, TxtBounds: TRect;\r\n StartRow, EndRow: Integer;\r\n ClipIt: Boolean;\r\n Attr: TJvTFDaysHdrAttr;\r\n TimeBlock: TJvTFDaysTimeBlock;\r\n HdrPic: TBitmap;\r\nbegin\r\n TimeBlock := TimeBlocks[BlockIndex];\r\n GetTimeBlockStartEnd(BlockIndex, StartRow, EndRow);\r\n //ARect := VirtualBlockHdrRect(StartRow);\r\n ARect := CellRect(gcGroupHdr, StartRow);\r\n HdrPicRect := VirtualBlockHdrRect(StartRow);\r\n ClipIt := HdrPicRect.Top < ARect.Top;\r\n\r\n Windows.OffsetRect(HdrPicRect, -HdrPicRect.Left, -HdrPicRect.Top);\r\n\r\n HdrPic := TBitmap.Create;\r\n try\r\n HdrPic.Width := RectWidth(HdrPicRect);\r\n HdrPic.Height := RectHeight(HdrPicRect);\r\n\r\n if BlockHdrIsSelected(StartRow) then\r\n Attr := TimeBlockProps.SelBlockHdrAttr\r\n else\r\n Attr := TimeBlockProps.BlockHdrAttr;\r\n\r\n //With ACanvas do\r\n with HdrPic.Canvas do\r\n begin\r\n Brush.Color := Attr.Color;\r\n FillRect(HdrPicRect);\r\n\r\n Font.Assign(Attr.Font);\r\n //DrawAngleText(HdrPic.Canvas, HdrPicRect, Attr.TitleRotation,\r\n //TimeBlock.Title);\r\n DrawAngleText(HdrPic.Canvas, HdrPicRect, TxtBounds, Attr.TitleRotation,\r\n taCenter, vaCenter, TimeBlock.Title);\r\n\r\n if Attr.Frame3D then\r\n DrawFrame(HdrPic.Canvas, HdrPicRect, True, Attr.FrameColor)\r\n else\r\n begin\r\n Pen.Color := Attr.FrameColor;\r\n MoveTo(HdrPicRect.Right - 1, HdrPicRect.Top);\r\n LineTo(HdrPicRect.Right - 1, HdrPicRect.Bottom);\r\n MoveTo(HdrPicRect.Left, HdrPicRect.Bottom - 1);\r\n LineTo(HdrPicRect.Right, HdrPicRect.Bottom - 1);\r\n end;\r\n end;\r\n\r\n if ClipIt then\r\n HdrPicRect.Top := HdrPicRect.Bottom - RectHeight(ARect);\r\n\r\n Windows.BitBlt(ACanvas.Handle, ARect.Left, ARect.Top, RectWidth(ARect),\r\n RectHeight(ARect), HdrPic.Canvas.Handle, 0, HdrPicRect.Top, SRCCOPY);\r\n finally\r\n HdrPic.Free;\r\n end;\r\nend;\r\n\r\nprocedure TJvTFDays.FillBlockHdrDeadSpace(ACanvas: TCanvas);\r\nvar\r\n ARect: TRect;\r\n StartRow, EndRow: Integer;\r\n\r\n procedure FillIt;\r\n begin\r\n with ACanvas do\r\n begin\r\n //Brush.Color := TimeBlockProps.BlockHdrAttr.Color;\r\n Brush.Color := TimeBlockProps.OffTimeColor;\r\n FillRect(ARect);\r\n\r\n Pen.Color := TimeBlockProps.BlockHdrAttr.FrameColor;\r\n MoveTo(ARect.Right - 1, ARect.Top);\r\n LineTo(ARect.Right - 1, ARect.Bottom);\r\n MoveTo(ARect.Left, ARect.Bottom - 1);\r\n LineTo(ARect.Right, ARect.Bottom - 1);\r\n end;\r\n end;\r\n\r\nbegin\r\n if TimeBlocks.Count = 0 then\r\n Exit;\r\n\r\n ARect.Left := 0;\r\n ARect.Right := CalcBlockHdrWidth;\r\n\r\n GetTimeBlockStartEnd(0, StartRow, EndRow);\r\n if StartRow > TopRow then\r\n begin\r\n ARect.Top := CalcGroupColHdrsHeight;\r\n ARect.Bottom := Lesser(VirtualBlockHdrRect(StartRow).Top,\r\n GetDataAreaRect.Bottom);\r\n FillIt;\r\n end;\r\n\r\n GetTimeBlockStartEnd(TimeBlocks.Count - 1, StartRow, EndRow);\r\n if EndRow < BottomRow then\r\n begin\r\n ARect.Top := Greater(VirtualBlockHdrRect(EndRow).Bottom,\r\n GetDataAreaRect.Top);\r\n ARect.Bottom := GetDataAreaRect.Bottom;\r\n FillIt;\r\n end;\r\nend;\r\n\r\n//////////////////////////////////////////////////////////////////\r\n// Credit for the CalcTextPos routine goes to Joerg Lingner. //\r\n// It comes from his JLLabel component (freeware - Torry's). //\r\n// It is used here with his permission. Thanks Joerg! //\r\n// He can be reached at jlingner att t-online dott de //\r\n//////////////////////////////////////////////////////////////////\r\n{\r\nprocedure TJvTFDays.CalcTextPos(var ARect: TRect; aAngle: Integer;\r\n aTxt: string);\r\n//==========================================================================\r\n// Calculate text pos. depend. on: Font, Escapement, Alignment and length\r\n//--------------------------------------------------------------------------\r\nvar\r\n DC : HDC;\r\n hSavFont: HFont;\r\n Size : TSize;\r\n x,y : Integer;\r\n cStr : array [0..255] of Char;\r\n SaveRect: TRect;\r\nbegin\r\n aAngle := aAngle div 10;\r\n SaveRect := ARect;\r\n\r\n StrPCopy(cStr, aTxt);\r\n DC := GetDC(HWND_DESKTOP);\r\n hSavFont := SelectObject(DC, Font.Handle);\r\n GetTextExtentPoint32(DC, cStr, Length(aTxt), Size);\r\n SelectObject(DC, hSavFont);\r\n ReleaseDC(HWND_DESKTOP, DC);\r\n\r\n x := 0;\r\n y := 0;\r\n\r\n if aAngle<=90 then\r\n begin // 1.Quadrant\r\n x := 0;\r\n y := Trunc(Size.cx * sin(aAngle*Pi/180));\r\n end\r\n else\r\n if aAngle<=180 then\r\n begin // 2.Quadrant\r\n x := Trunc(Size.cx * -cos(aAngle*Pi/180));\r\n y := Trunc(Size.cx * sin(aAngle*Pi/180) + Size.cy * cos((180-aAngle)*Pi/180));\r\n end\r\n else\r\n if aAngle<=270 then\r\n begin // 3.Quadrant\r\n x := Trunc(Size.cx * -cos(aAngle*Pi/180) + Size.cy * sin((aAngle-180)*Pi/180));\r\n y := Trunc(Size.cy * sin((270-aAngle)*Pi/180));\r\n end\r\n else\r\n if aAngle<=360 then\r\n begin // 4.Quadrant\r\n x := Trunc(Size.cy * sin((360-aAngle)*Pi/180));\r\n y := 0;\r\n end;\r\n ARect.Top := ARect.Top + y;\r\n ARect.Left := ARect.Left + x;\r\n\r\n x := Abs(Trunc(Size.cx * cos(aAngle*Pi/180))) + Abs(Trunc(Size.cy * sin(aAngle*Pi/180)));\r\n y := Abs(Trunc(Size.cx * sin(aAngle*Pi/180))) + Abs(Trunc(Size.cy * cos(aAngle*Pi/180)));\r\n\r\n //Mike:\r\n ARect.Left := ARect.Left + ((RectWidth(SaveRect) - X) div 2); // align center\r\n //ARect.Left := ARect.Left + RectWidth(SaveRect) - X; // align right\r\n ARect.Top := ARect.Top + ((RectHeight(SaveRect) - Y) div 2); // align center\r\n //ARect.Top := ARect.Top + RectHeight(SaveRect) - Y; // align bottom\r\nend;\r\n}\r\n\r\n{\r\nprocedure TJvTFDays.DrawAngleText(ACanvas: TCanvas; ARect: TRect;\r\n aAngle: Integer; aTxt: string);\r\nvar\r\n LogFont: TLogFont;\r\n TxtRect: TRect;\r\n Flags: UINT;\r\n PTxt: PChar;\r\n ClipRgn: HRgn;\r\nbegin\r\n TxtRect := ARect;\r\n CalcTextPos(TxtRect, aAngle, aTxt);\r\n\r\n Windows.GetObject(ACanvas.Font.Handle, SizeOf(LogFont), @LogFont);\r\n LogFont.lfEscapement := aAngle;\r\n LogFont.lfOrientation := LogFont.lfEscapement;\r\n ACanvas.Font.Handle := CreateFontIndirect(LogFont);\r\n\r\n Flags := DT_NOPREFIX or DT_LEFT or DT_TOP or DT_NOCLIP or DT_SINGLELINE;\r\n\r\n PTxt := StrAlloc((Length(aTxt) + 4) * SizeOf(Char));\r\n StrPCopy(PTxt, aTxt);\r\n\r\n ClipRgn := Windows.CreateRectRgn(ARect.Left, ARect.Top,\r\n ARect.Right, ARect.Bottom);\r\n Windows.SelectClipRgn(ACanvas.Handle, ClipRgn);\r\n\r\n Windows.DrawText(ACanvas.Handle, PTxt, -1, TxtRect, Flags);\r\n\r\n Windows.SelectClipRgn(ACanvas.Handle, 0);\r\n Windows.DeleteObject(ClipRgn);\r\n StrDispose(PTxt);\r\n ACanvas.Font.Handle := 0;\r\nend;\r\n}\r\n\r\nprocedure TJvTFDays.EnsureBlockRules(GridGran, BlockGran: Integer;\r\n DayStart: TTime);\r\nvar\r\n GridHrs, GridMins, BlockHrs, BlockMins, S, MS: Word;\r\n RowStartTime: TTime;\r\nbegin\r\n if TimeBlocks.Count > 0 then\r\n begin\r\n if GridGran > BlockGran then\r\n raise EJvTFBlockGranError.CreateRes(@RsEGridGranularityCannotBeGreater);\r\n\r\n if (BlockGran mod GridGran) <> 0 then\r\n raise EJvTFBlockGranError.CreateRes(@RsETimeBlockGranularityMustBeEvenly);\r\n\r\n DecodeTime(DayStart, BlockHrs, BlockMins, S, MS);\r\n RowStartTime := RowToTime(TimeToRow(DayStart));\r\n DecodeTime(RowStartTime, GridHrs, GridMins, S, MS);\r\n if (BlockHrs <> GridHrs) or (BlockMins <> GridMins) then\r\n raise EJvTFBlockGranError.CreateRes(@RsETimeBlocksMustBeginExactlyOn);\r\n end;\r\nend;\r\n\r\nfunction TJvTFDays.ValidateBlockRules(GridGran, BlockGran: Integer;\r\n DayStart: TTime): Boolean;\r\nvar\r\n GridHrs, GridMins, BlockHrs, BlockMins, S, MS: Word;\r\n RowStartTime: TTime;\r\nbegin\r\n Result := True;\r\n if TimeBlocks.Count > 0 then\r\n begin\r\n if GridGran > BlockGran then\r\n Result := False;\r\n\r\n if (BlockGran mod GridGran) <> 0 then\r\n Result := False;\r\n\r\n DecodeTime(DayStart, BlockHrs, BlockMins, S, MS);\r\n RowStartTime := RowToTime(TimeToRow(DayStart));\r\n DecodeTime(RowStartTime, GridHrs, GridMins, S, MS);\r\n if (BlockHrs <> GridHrs) or (BlockMins <> GridMins) then\r\n Result := False;\r\n end;\r\nend;\r\n\r\nfunction TJvTFDays.RowToTimeBlock(ARow: Integer): Integer;\r\nvar\r\n I, BlockStart, BlockEnd: Integer;\r\nbegin\r\n Result := -1;\r\n if TimeBlocks.Count = 0 then\r\n Exit;\r\n\r\n I := 0;\r\n repeat\r\n GetTimeBlockStartEnd(I, BlockStart, BlockEnd);\r\n if (BlockStart <= ARow) and (ARow <= BlockEnd) then\r\n Result := I;\r\n Inc(I);\r\n until (I = TimeBlocks.Count) or (Result <> -1);\r\nend;\r\n\r\nprocedure TJvTFDays.GetTimeBlockStartEnd(ATimeBlock: Integer;\r\n var BlockStart, BlockEnd: Integer);\r\nvar\r\n I: Integer;\r\nbegin\r\n if ATimeBlock < 0 then\r\n begin\r\n BlockStart := -1;\r\n BlockEnd := -1;\r\n Exit;\r\n end;\r\n\r\n BlockStart := TimeToRow(TimeBlockProps.DayStart);\r\n I := 0;\r\n while (I < ATimeBlock) do\r\n begin\r\n //Inc(BlockStart, TimeBlocks[I].Length);\r\n Inc(BlockStart, TimeBlocks[I].GridLength);\r\n Inc(I);\r\n end;\r\n //BlockEnd := BlockStart + TimeBlocks[ATimeBlock].Length - 1;\r\n BlockEnd := BlockStart + TimeBlocks[ATimeBlock].GridLength - 1;\r\nend;\r\n\r\nfunction TJvTFDays.CalcBlockHdrWidth: Integer;\r\nbegin\r\n if TimeBlocks.Count > 0 then\r\n Result := TimeBlockProps.BlockHdrWidth\r\n else\r\n Result := 0;\r\nend;\r\n\r\nfunction TJvTFDays.CalcBlockRowHdrsWidth: Integer;\r\nbegin\r\n Result := CalcBlockHdrWidth + RowHdrWidth;\r\nend;\r\n\r\nprocedure TJvTFDays.GetBlockStartEndRows(Row: Integer;\r\n var StartRow, EndRow: Integer);\r\nbegin\r\n GetTimeBlockStartEnd(RowToTimeBlock(Row), StartRow, EndRow);\r\nend;\r\n\r\nfunction TJvTFDays.VirtualBlockHdrRect(Row: Integer): TRect;\r\nvar\r\n BlockStartRow, BlockEndRow, BlockHeight: Integer;\r\nbegin\r\n EnsureRow(Row);\r\n\r\n Result.Left := 0;\r\n Result.Right := CalcBlockHdrWidth;\r\n\r\n GetBlockStartEndRows(Row, BlockStartRow, BlockEndRow);\r\n BlockHeight := (BlockEndRow - BlockStartRow + 1) * RowHeight;\r\n\r\n Result.Top := CalcGroupColHdrsHeight + ((BlockStartRow - TopRow) * RowHeight);\r\n Result.Bottom := Result.Top + BlockHeight;\r\nend;\r\n\r\nfunction TJvTFDays.IsWeekend(ColIndex: Integer): Boolean;\r\nbegin\r\n Result := BorlToDOW(DayOfWeek(Cols[ColIndex].SchedDate)) in Weekend;\r\nend;\r\n\r\nfunction TJvTFDays.BlockHdrIsSelected(ARow: Integer): Boolean;\r\nvar\r\n I, StartRow, EndRow: Integer;\r\nbegin\r\n GetBlockStartEndRows(ARow, StartRow, EndRow);\r\n Result := False;\r\n I := StartRow;\r\n while (I <= EndRow) and not Result do\r\n begin\r\n if RowIsSelected(I) then\r\n Result := True;\r\n Inc(I);\r\n end;\r\nend;\r\n\r\nprocedure TJvTFDays.DrawFrame(ACanvas: TCanvas; ARect: TRect; Draw3D: Boolean;\r\n FrameColour: TColor);\r\nvar\r\n OldPenColor: TColor;\r\nbegin\r\n with ACanvas, ARect do\r\n begin\r\n OldPenColor := Pen.Color;\r\n\r\n if Draw3D then\r\n Pen.Color := clBtnShadow\r\n else\r\n Pen.Color := FrameColour;\r\n\r\n MoveTo(Right - 1, Top);\r\n LineTo(Right - 1, Bottom);\r\n MoveTo(Left, Bottom - 1);\r\n LineTo(Right, Bottom - 1);\r\n\r\n if Draw3D then\r\n begin\r\n Pen.Color := clBtnHighlight;\r\n MoveTo(Left, Top);\r\n LineTo(Right, Top);\r\n MoveTo(Left, Top);\r\n LineTo(Left, Bottom);\r\n end;\r\n\r\n Pen.Color := OldPenColor;\r\n end;\r\nend;\r\n\r\n{$ENDIF Jv_TIMEBLOCKS}\r\n\r\nprocedure TJvTFDays.SetGridEndTime(Value: TTime);\r\nvar\r\n I, NewTopRow: Integer;\r\n TopTime: TTime;\r\n WorkEnd: TTime;\r\n H, M, S, MS: Word;\r\nbegin\r\n WorkEnd := Value;\r\n DecodeTime(WorkEnd, H, M, S, MS);\r\n if (H = 0) and (M = 0) then\r\n WorkEnd := EncodeTime(23, 59, 59, 999);\r\n\r\n if not (csLoading in ComponentState) and (WorkEnd <= GridStartTime) then\r\n raise EJvTFDaysError.CreateRes(@RsEGridEndTimeCannotBePriorToGridStart);\r\n\r\n TopTime := RowToTime(TopRow);\r\n FGridEndTime := Value;\r\n\r\n ClearSelection;\r\n if not (csLoading in ComponentState) then\r\n begin\r\n for I := 0 to Cols.Count - 1 do\r\n Cols[I].RefreshMap;\r\n //TopRow := TimeToRow(TopTime);\r\n\r\n if RowCount <= PossVisibleRows then\r\n TopRow := 0\r\n else\r\n begin\r\n if TopTime < GridStartTime then\r\n NewTopRow := 0\r\n else\r\n NewTopRow := TimeToRow(TopTime);\r\n TopRow := Lesser(NewTopRow, RowCount - 1 - VisibleRows + 1);\r\n end;\r\n\r\n CheckSBVis;\r\n CheckSBParams;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvTFDays.SetGridStartTime(Value: TTime);\r\nvar\r\n I, NewTopRow: Integer;\r\n TopTime: TTime;\r\n WorkEnd: TTime;\r\n H, M, S, MS: Word;\r\nbegin\r\n WorkEnd := GridEndTime;\r\n DecodeTime(WorkEnd, H, M, S, MS);\r\n if (H = 0) and (M = 0) then\r\n WorkEnd := EncodeTime(23, 59, 59, 999);\r\n\r\n if not (csLoading in ComponentState) and (Value >= WorkEnd) then\r\n raise EJvTFDaysError.CreateRes(@RsEGridStartTimeCannotBeAfterGridEndTi);\r\n\r\n TopTime := RowToTime(TopRow);\r\n FGridStartTime := Value;\r\n\r\n ClearSelection;\r\n if not (csLoading in ComponentState) then\r\n begin\r\n for I := 0 to Cols.Count - 1 do\r\n Cols[I].RefreshMap;\r\n //TopRow := TimeToRow(TopTime);\r\n\r\n if RowCount <= PossVisibleRows then\r\n TopRow := 0\r\n else\r\n begin\r\n if TopTime < GridStartTime then\r\n NewTopRow := 0\r\n else\r\n NewTopRow := TimeToRow(TopTime);\r\n TopRow := Lesser(NewTopRow, RowCount - 1 - VisibleRows + 1);\r\n end;\r\n\r\n CheckSBVis;\r\n CheckSBParams;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvTFDays.WMTimer(var Msg: TWMTimer);\r\nvar\r\n I, TempWidth: Integer;\r\n PtInfo: TJvTFDaysCoord;\r\n OldTopRow, OldLeftCol: Integer;\r\n X, Y: Integer;\r\nbegin\r\n if Cols.Count = 0 then\r\n Exit;\r\n\r\n OldTopRow := TopRow;\r\n OldLeftCol := LeftCol;\r\n\r\n case FAutoScrollDir of\r\n asdUp:\r\n TopRow := Greater(TopRow - 1, 0);\r\n asdDown:\r\n TopRow := Lesser(TopRow + 1, RowCount - FullVisibleRows);\r\n asdLeft:\r\n LeftCol := Greater(LeftCol - 1, 0);\r\n asdRight:\r\n begin\r\n TempWidth := 0;\r\n for I := LeftCol to Cols.Count - 1 do\r\n Inc(TempWidth, Cols[I].Width);\r\n if TempWidth > GetDataWidth then\r\n LeftCol := LeftCol + 1;\r\n end;\r\n end;\r\n\r\n if (FAutoScrollDir <> asdNowhere) and\r\n ((TopRow <> OldTopRow) or (LeftCol <> OldLeftCol)) then\r\n begin\r\n X := FMouseMovePt.X;\r\n Y := FMouseMovePt.Y;\r\n\r\n if State <> agsMoveAppt then\r\n MouseMove(FMouseMoveState, X, Y);\r\n\r\n Update;\r\n\r\n PtInfo := PtToCell(FMouseMovePt.X, FMouseMovePt.Y);\r\n\r\n if Y >= GetDataAreaRect.Bottom then\r\n PtInfo.Row := Lesser(BottomRow + 1, RowCount - 1);\r\n\r\n if State = agsSizeAppt then\r\n begin\r\n DrawDrag(PtInfo, nil, False);\r\n ContinueDragging(PtInfo, nil);\r\n end\r\n else\r\n if State = agsMoveAppt then\r\n begin\r\n DrawDrag(PtInfo, FDragInfo.Appt, False);\r\n FDraggingCoord.Row := PtInfo.Row;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvTFDays.KillAutoScrollTimer;\r\nbegin\r\n if FLiveTimer then\r\n begin\r\n FLiveTimer := False;\r\n Windows.KillTimer(Handle, 1);\r\n end;\r\nend;\r\n\r\nprocedure TJvTFDays.Navigate(AControl: TJvTFControl;\r\n SchedNames: TStringList; Dates: TJvTFDateList);\r\nvar\r\n I, J: Integer;\r\n ACol: TJvTFDaysCol;\r\nbegin\r\n inherited Navigate(AControl, SchedNames, Dates);\r\n\r\n if not Template.IgnoreNav and (Dates.Count > 0) then\r\n case Template.ActiveTemplate of\r\n agtLinear:\r\n Template.LinearStartDate := Dates[0];\r\n agtComparative:\r\n Template.CompDate := Dates[0];\r\n agtNone:\r\n begin\r\n Cols.BeginUpdate;\r\n try\r\n Cols.Clear;\r\n if Grouping = grDate then\r\n for I := 0 to Dates.Count - 1 do\r\n for J := 0 to SchedNames.Count - 1 do\r\n begin\r\n ACol := Cols.Add;\r\n ACol.SchedName := SchedNames[J];\r\n ACol.SchedDate := Dates[I];\r\n end\r\n else\r\n for I := 0 to SchedNames.Count - 1 do\r\n for J := 0 to Dates.Count - 1 do\r\n begin\r\n ACol := Cols.Add;\r\n ACol.SchedName := SchedNames[I];\r\n ACol.SchedDate := Dates[J];\r\n end;\r\n finally\r\n Cols.EndUpdate;\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\n{\r\nprocedure TJvTFDays.ReorderCols;\r\nvar\r\n NewList: TStringList;\r\n I, Slot: Integer;\r\n ColToAdd: TJvTFDaysCol;\r\n\r\n function SortCompare: Boolean;\r\n var\r\n CurrCol: TJvTFDaysCol;\r\n begin\r\n CurrCol := TJvTFDaysCol(NewList.Objects[Slot]);\r\n if Grouping = grDate then\r\n Result := Trunc(CurrCol.SchedDate) > Trunc(ColToAdd.SchedDate)\r\n else\r\n if Grouping = grResource then\r\n Result := CurrCol.SchedName > ColToAdd.SchedName\r\n else\r\n Result := True;\r\n end;\r\n\r\nbegin\r\n NewList := TStringList.Create;\r\n Try\r\n For I := 0 to Cols.Count - 1 do\r\n begin\r\n ColToAdd := Cols[I];\r\n\r\n Slot := 0;\r\n while (Slot < NewList.Count) and not SortCompare do\r\n Inc(Slot);\r\n\r\n NewList.InsertObject(Slot, '', ColToAdd);\r\n end;\r\n\r\n For I := 0 to NewList.Count - 1 do\r\n TJvTFDaysCol(NewList.Objects[I]).Index := I;\r\n Finally\r\n NewList.Free;\r\n end;\r\nend;\r\n}\r\n\r\n//procedure TJvTFDays.DoNavigate;\r\n//var\r\n// SchedNameList: TStringList;\r\n// DateList: TJvTFDateList;\r\n// I,\r\n// SMIndex: Integer;\r\n// ACol: TJvTFDaysCol;\r\n//begin\r\n// if not Assigned(Navigator) then\r\n// Exit;\r\n//\r\n// SchedNameList := TStringList.Create;\r\n// DateList := TJvTFDateList.Create;\r\n// try\r\n// for I := 0 to Cols.Count - 1 do\r\n// begin\r\n// ACol := Cols[I];\r\n// if ColIsSelected(I) then\r\n// begin\r\n// SMIndex := SchedNameList.IndexOf(ACol.SchedName);\r\n// if SMIndex = -1 then\r\n// SchedNameList.Add(ACol.SchedName);\r\n// DateList.Add(ACol.SchedDate);\r\n// end;\r\n// end;\r\n//\r\n// Navigator.Navigate(Self, SchedNameList, DateList);\r\n// finally\r\n// SchedNameList.Free;\r\n// DateList.Free;\r\n// end;\r\n//end;\r\n\r\nfunction TJvTFDays.GetTFHintClass: TJvTFHintClass;\r\nbegin\r\n Result := TJvTFHint;\r\nend;\r\n\r\nprocedure TJvTFDays.DoApptHint(GridCoord: TJvTFDaysCoord);\r\nvar\r\n ApptRect, VisApptRect: TRect;\r\nbegin\r\n if Assigned(GridCoord.Appt) and not Editing and (agoShowApptHints in Options) then\r\n begin\r\n ApptRect := GetApptRect(GridCoord.Col, GridCoord.Appt);\r\n Windows.IntersectRect(VisApptRect, ApptRect, GetDataAreaRect);\r\n FHint.ApptHint(GridCoord.Appt, VisApptRect.Left + 2,\r\n VisApptRect.Bottom + 2, True, True,\r\n agoFormattedDesc in Options);\r\n end;\r\nend;\r\n\r\nprocedure TJvTFDays.DoCellHint(GridCoord: TJvTFDaysCoord);\r\nvar\r\n ColHdrRect: TRect;\r\n HintText: string;\r\nbegin\r\n if csDesigning in ComponentState then\r\n Exit;\r\n\r\n if (GridCoord.Row = -1) and (GridCoord.Col > -1) and (agoShowColHdrHints in Options) then\r\n HintText := Cols[GridCoord.Col].Title\r\n else\r\n HintText := '';\r\n\r\n ColHdrRect := CellRect(GridCoord.Col, GridCoord.Row);\r\n FHint.CellHint(GridCoord.Row, GridCoord.Col, HintText, ColHdrRect);\r\nend;\r\n\r\nprocedure TJvTFDays.GetApptDrawInfo(DrawInfo: TJvTFDaysApptDrawInfo;\r\n AAppt: TJvTFAppt; Attr: TJvTFDaysApptAttr);\r\nbegin\r\n DrawInfo.Color := GetApptDispColor(AAppt, AAppt = SelAppt);\r\n DrawInfo.FrameColor := Attr.FrameColor;\r\n DrawInfo.FrameWidth := Attr.FrameWidth;\r\n DrawInfo.Font := Attr.Font;\r\n DrawInfo.Visible := True;\r\n\r\n if Assigned(FOnGetApptDrawInfo) then\r\n FOnGetApptDrawInfo(Self, AAppt, DrawInfo);\r\nend;\r\n\r\n// move grab handles\r\n//function TJvTFDays.GetBottomGrabHandleRect(Col: Integer; Appt: TJvTFAppt): TRect;\r\n//begin\r\n// Result := Classes.Rect(0, 0, 0, 0);\r\n// if (Col = FocusedCol) and (Col > gcHdr) and Assigned(Appt) and\r\n// Cols[Col].ApptInCol(Appt) then\r\n// begin\r\n// Result := GetApptRect(Col, Appt);\r\n// Result.Top := Result.Bottom - GrabHandles.Height;\r\n// Windows.OffsetRect(Result, 0, GrabHandles.Height);\r\n// end;\r\n//end;\r\n//\r\n//// move grab handles\r\n//function TJvTFDays.GetTopGrabHandleRect(Col: Integer; Appt: TJvTFAppt): TRect;\r\n//begin\r\n// Result := Classes.Rect(0, 0, 0, 0);\r\n// if (Col = FocusedCol) and (Col > gcHdr) and Assigned(Appt) and\r\n// Cols[Col].ApptInCol(Appt) then\r\n// begin\r\n// Result := GetApptRect(Col, Appt);\r\n// Result.Bottom := Result.Top + GrabHandles.Height;\r\n// Windows.OffsetRect(Result, 0, -GrabHandles.Height);\r\n// end;\r\n//end;\r\n\r\n// move grab handles\r\n\r\nfunction TJvTFDays.GetBottomGrabHandleRect(Col: Integer; Appt: TJvTFAppt): TRect;\r\nbegin\r\n Result := Classes.Rect(0, 0, 0, 0);\r\n// if (Col = FocusedCol) and (Col > gcHdr) and Assigned(Appt) and\r\n if (Col > gcHdr) and Assigned(Appt) and Cols[Col].ApptInCol(Appt) then\r\n begin\r\n Result := GetApptRect(Col, Appt);\r\n Result.Top := Result.Bottom - GrabHandles.Height;\r\n Windows.OffsetRect(Result, 0, GrabHandles.Height);\r\n end;\r\nend;\r\n\r\n// move grab handles\r\n\r\nfunction TJvTFDays.GetTopGrabHandleRect(Col: Integer; Appt: TJvTFAppt): TRect;\r\nbegin\r\n Result := Classes.Rect(0, 0, 0, 0);\r\n// if (Col = FocusedCol) and (Col > gcHdr) and Assigned(Appt) and\r\n if (Col > gcHdr) and Assigned(Appt) and Cols[Col].ApptInCol(Appt) then\r\n begin\r\n Result := GetApptRect(Col, Appt);\r\n Result.Bottom := Result.Top + GrabHandles.Height;\r\n Windows.OffsetRect(Result, 0, -GrabHandles.Height);\r\n end;\r\nend;\r\n\r\nfunction TJvTFDays.PtInBottomHandle(APoint: TPoint; Col: Integer;\r\n Appt: TJvTFAppt): Boolean;\r\nvar\r\n HandleRect: TRect;\r\nbegin\r\n Result := False;\r\n // move grab handles\r\n if Assigned(Appt) and Cols[Col].ApptInCol(Appt) then\r\n begin\r\n HandleRect := GetBottomGrabHandleRect(Col, Appt);\r\n Result := Windows.PtInRect(HandleRect, APoint) and\r\n (agoSizeAppt in Options);\r\n end;\r\nend;\r\n\r\nfunction TJvTFDays.PtInTopHandle(APoint: TPoint; Col: Integer;\r\n Appt: TJvTFAppt): Boolean;\r\nvar\r\n HandleRect: TRect;\r\nbegin\r\n Result := False;\r\n // move grab handles\r\n if Assigned(Appt) and Cols[Col].ApptInCol(Appt) then\r\n begin\r\n HandleRect := GetTopGrabHandleRect(Col, Appt);\r\n Result := Windows.PtInRect(HandleRect, APoint) and\r\n (agoMoveAppt in Options);\r\n end;\r\nend;\r\n\r\nprocedure TJvTFDays.SetDitheredBackground(const Value: Boolean);\r\nbegin\r\n FDitheredBackground := Value;\r\n Refresh;\r\nend;\r\n\r\nprocedure TJvTFDays.SetShowFocus(const Value: Boolean);\r\nbegin\r\n if FShowFocus <> Value then\r\n begin\r\n FShowFocus := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\n//=== { TJvTFDaysPrinter } ===================================================\r\n\r\nconstructor TJvTFDaysPrinter.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n\r\n FGroupHdrHeight := 25;\r\n\r\n FPageInfoList := TStringList.Create;\r\n FApptAttr := TJvTFDaysApptAttr.Create(nil);\r\n FApptBar := TJvTFDaysApptBar.Create(nil);\r\n FCols := TJvTFDaysCols.CreateForPrinter(Self);\r\n FFancyRowHdrAttr := TJvTFDaysFancyRowHdrAttr.Create(nil);\r\n FHdrAttr := TJvTFDaysHdrAttr.Create(nil);\r\n FGroupHdrAttr := TJvTFDaysHdrAttr.Create(nil);\r\n FPrimeTime := TJvTFDaysPrimeTime.Create(nil);\r\n FThresholds := TJvTFDaysThresholds.Create(nil);\r\nend;\r\n\r\ndestructor TJvTFDaysPrinter.Destroy;\r\nbegin\r\n FCols.Free;\r\n FApptAttr.Free;\r\n FApptBar.Free;\r\n FFancyRowHdrAttr.Free;\r\n FHdrAttr.Free;\r\n FGroupHdrAttr.Free;\r\n FPrimeTime.Free;\r\n FThresholds.Free;\r\n\r\n // ClearPageInfo *MUST* be called here. FreeDoc will not call ClearPageInfo\r\n // since we are freeing FPageInfoList here and the inherited Destroy calls\r\n // FreeDoc. (That call to FreeDoc would call ClearPageInfo AFTER\r\n // FPageInfoList has been destroyed.)\r\n ClearPageInfo;\r\n FPageInfoList.Free;\r\n FPageInfoList := nil;\r\n\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJvTFDaysPrinter.AdjustEndTime(ATime: TTime): TTime;\r\nbegin\r\n Result := Frac(Frac(ATime) - Frac(EncodeTime(0, 0, 1, 0)));\r\nend;\r\n\r\nprocedure TJvTFDaysPrinter.CalcPageColInfo(ShowRowHdrs: Boolean;\r\n var CalcColsPerPage, CalcColWidth: Integer);\r\nvar\r\n DataWidth, TargetColsPerPage: Integer;\r\nbegin\r\n // Calculate the cols per page\r\n if DaysPageLayout.ColsPerPage = 0 then\r\n TargetColsPerPage := Cols.Count\r\n else\r\n TargetColsPerPage := DaysPageLayout.ColsPerPage;\r\n\r\n DataWidth := GetDataWidth(ShowRowHdrs);\r\n if TargetColsPerPage > 0 then\r\n begin\r\n CalcColWidth := DataWidth div TargetColsPerPage;\r\n CalcColWidth := Greater(CalcColWidth, MinColWidth);\r\n CalcColsPerPage := DataWidth div CalcColWidth;\r\n end\r\n else\r\n begin\r\n CalcColsPerPage := 1;\r\n CalcColWidth := DataWidth;\r\n end;\r\nend;\r\n\r\nprocedure TJvTFDaysPrinter.CalcPageInfo;\r\nvar\r\n Segments: TStringList;\r\n PageInfo, SegmentInfo: TJvTFDaysPageInfo;\r\n WorkRowHeight, WorkRowsPerPage, WorkColWidth, WorkColsPerPage: Integer;\r\n CurrRow, CurrCol, I, WorkEndCol: Integer;\r\n WorkShowRowHdr: Boolean;\r\nbegin\r\n // ALL MEASUREMENTS ARE ASSUMED TO BE IN PIXELS !!\r\n ClearPageInfo;\r\n\r\n // Calculate the segments\r\n // A segment is concerned with rows only (if all rows fit on one page then\r\n // there is one segment. if the rows fit on two pages then there are two\r\n // segments...)\r\n Segments := TStringList.Create;\r\n\r\n try\r\n // create the segments\r\n CurrRow := 0;\r\n while CurrRow < RowCount do\r\n begin\r\n PageInfo := TJvTFDaysPageInfo.Create;\r\n Segments.AddObject('', PageInfo);\r\n with PageInfo do\r\n begin\r\n PageNum := Segments.Count;\r\n StartRow := CurrRow;\r\n\r\n ShowColHdr := (CurrRow = 0) or DaysPageLayout.AlwaysShowColHdr;\r\n CalcPageRowInfo(ShowColHdr, WorkRowsPerPage, WorkRowHeight);\r\n EndRow := Lesser(CurrRow + WorkRowsPerPage - 1, RowCount - 1);\r\n RowHeight := WorkRowHeight;\r\n end;\r\n CurrRow := PageInfo.EndRow + 1;\r\n end;\r\n\r\n // create the pages\r\n CurrCol := 0;\r\n while CurrCol < Cols.Count do\r\n begin\r\n WorkShowRowHdr := (CurrCol = 0) or DaysPageLayout.AlwaysShowRowHdr;\r\n CalcPageColInfo(WorkShowRowHdr, WorkColsPerPage, WorkColWidth);\r\n WorkEndCol := CurrCol + WorkColsPerPage - 1;\r\n WorkEndCol := Lesser(WorkEndCol, Cols.Count - 1);\r\n\r\n for I := 0 to Segments.Count - 1 do\r\n begin\r\n SegmentInfo := TJvTFDaysPageInfo(Segments.Objects[I]);\r\n\r\n PageInfo := TJvTFDaysPageInfo.Create;\r\n FPageInfoList.AddObject('', PageInfo);\r\n with PageInfo do\r\n begin\r\n PageNum := FPageInfoList.Count;\r\n StartRow := SegmentInfo.StartRow;\r\n EndRow := SegmentInfo.EndRow;\r\n RowHeight := SegmentInfo.RowHeight;\r\n ShowColHdr := SegmentInfo.ShowColHdr;\r\n StartCol := CurrCol;\r\n EndCol := WorkEndCol;\r\n ColWidth := WorkColWidth;\r\n ShowRowHdr := WorkShowRowHdr;\r\n end;\r\n end;\r\n CurrCol := WorkEndCol + 1;\r\n end;\r\n finally\r\n // clean up the segments\r\n while Segments.Count > 0 do\r\n begin\r\n Segments.Objects[0].Free;\r\n Segments.Delete(0);\r\n end;\r\n Segments.Free;\r\n FValidPageInfo := True;\r\n end;\r\nend;\r\n\r\nprocedure TJvTFDaysPrinter.CalcPageRowInfo(ShowColHdrs: Boolean;\r\n var CalcRowsPerPage, CalcRowHeight: Integer);\r\nvar\r\n DataHeight, TargetRowsPerPage: Integer;\r\nbegin\r\n // Calculate the rows per page\r\n if DaysPageLayout.RowsPerPage = 0 then\r\n TargetRowsPerPage := RowCount\r\n else\r\n TargetRowsPerPage := DaysPageLayout.RowsPerPage;\r\n\r\n DataHeight := GetDataHeight(ShowColHdrs);\r\n CalcRowHeight := DataHeight div TargetRowsPerPage;\r\n CalcRowHeight := Greater(CalcRowHeight, MinRowHeight);\r\n CalcRowsPerPage := DataHeight div CalcRowHeight;\r\nend;\r\n\r\nprocedure TJvTFDaysPrinter.CalcStartEndRows(AAppt: TJvTFAppt;\r\n SchedDate: TDate; var StartRow, EndRow: Integer);\r\nbegin\r\n if Trunc(AAppt.StartDate) = Trunc(SchedDate) then\r\n StartRow := TimeToRow(AAppt.StartTime)\r\n else\r\n StartRow := 0;\r\n\r\n if Trunc(AAppt.EndDate) = Trunc(SchedDate) then\r\n EndRow := TimeToRow(AdjustEndTime(AAppt.EndTime))\r\n else\r\n EndRow := RowCount - 1;\r\nend;\r\n\r\nprocedure TJvTFDaysPrinter.CanDrawWhat(ACanvas: TCanvas; ApptRect: TRect;\r\n PicsHeight, PicsWidth: Integer; var CanDrawText, CanDrawPics: Boolean);\r\nvar\r\n TextHeightThreshold, TextWidthThreshold: Integer;\r\nbegin\r\n TextHeightThreshold := ACanvas.TextHeight('Wq') * Thresholds.TextHeight;\r\n TextWidthThreshold := ACanvas.TextWidth('Bi') div 2 * Thresholds.TextWidth;\r\n\r\n if TextHeightThreshold < RectHeight(ApptRect) then\r\n begin\r\n CanDrawText := RectWidth(ApptRect) >= TextWidthThreshold;\r\n CanDrawPics := True;\r\n end\r\n else\r\n if Thresholds.DropTextFirst then\r\n begin\r\n CanDrawText := False;\r\n CanDrawPics := True;\r\n if Thresholds.WholePicsOnly then\r\n if PicsHeight > RectHeight(ApptRect) then\r\n CanDrawPics := False;\r\n end\r\n else\r\n begin\r\n CanDrawText := (RectHeight(ApptRect) >= TextHeightThreshold) and\r\n (RectWidth(ApptRect) >= TextWidthThreshold);\r\n CanDrawPics := False;\r\n end;\r\n\r\n if not ShowPics then\r\n CanDrawPics := False;\r\n if not ShowText then\r\n CanDrawText := False;\r\nend;\r\n\r\nfunction TJvTFDaysPrinter.CellRect(Col, Row: Integer;\r\n PageInfo: TJvTFDaysPageInfo): TRect;\r\nvar\r\n VisGrpHdrRect: TRect;\r\nbegin\r\n if (Row = gcGroupHdr) and (Col > gcHdr) then\r\n begin\r\n VisGrpHdrRect := Classes.Rect(RowHdrWidth, 0,\r\n RowHdrWidth + GetDataWidth(PageInfo.ShowRowHdr),\r\n CalcGroupHdrHeight);\r\n Windows.IntersectRect(Result, VisGrpHdrRect,\r\n VirtualGroupHdrRect(Col, PageInfo));\r\n end\r\n else\r\n if Col < 0 then // Row hdr\r\n if Row < 0 then\r\n // origin cell\r\n if PageInfo.ShowColHdr and PageInfo.ShowRowHdr then\r\n //group Result := Classes.Rect(0, 0, RowHdrWidth, ColHdrHeight)\r\n Result := Classes.Rect(0, 0, RowHdrWidth, CalcGroupColHdrsHeight)\r\n else\r\n Result := EmptyRect\r\n else\r\n if (Row >= PageInfo.StartRow) and (Row <= PageInfo.EndRow) then\r\n // Row Hdr for visible data row\r\n if PageInfo.ShowRowHdr then\r\n begin\r\n Result.Left := 0;\r\n if PageInfo.ShowColHdr then\r\n //group Result.Top := ColHdrHeight\r\n Result.Top := CalcGroupColHdrsHeight\r\n else\r\n Result.Top := 0;\r\n Result.Top := Result.Top + (Row - PageInfo.StartRow) * PageInfo.RowHeight;\r\n Result.Right := RowHdrWidth;\r\n Result.Bottom := Result.Top + PageInfo.RowHeight;\r\n end\r\n else\r\n Result := EmptyRect\r\n else\r\n // Row Hdr for non-visible data row\r\n Result := EmptyRect\r\n else\r\n if (Col >= PageInfo.StartCol) and (Col <= PageInfo.EndCol) then\r\n // visible data col\r\n if Row < 0 then\r\n // Col hdr for visible data col\r\n if PageInfo.ShowColHdr then\r\n begin\r\n if PageInfo.ShowRowHdr then\r\n Result.Left := RowHdrWidth\r\n else\r\n Result.Left := 0;\r\n Inc(Result.Left, PageInfo.ColWidth * (Col - PageInfo.StartCol));\r\n Result.Right := Result.Left + PageInfo.ColWidth;\r\n\r\n { variable width columns, leave for future reference\r\n For I := LeftCol to Col - 1 do\r\n Inc(Result.Left, Cols[I].Width);\r\n Result.Right := Result.Left + Cols[Col].Width;\r\n }\r\n\r\n //group Result.Top := 0;\r\n Result.Top := CalcGroupHdrHeight;\r\n //group Result.Bottom := ColHdrHeight;\r\n Result.Bottom := Result.Top + ColHdrHeight;\r\n end\r\n else\r\n Result := EmptyRect\r\n else\r\n if (Row >= PageInfo.StartRow) and (Row <= PageInfo.EndRow) then\r\n // visible data cell\r\n begin\r\n if PageInfo.ShowRowHdr then\r\n Result.Left := RowHdrWidth\r\n else\r\n Result.Left := 0;\r\n Inc(Result.Left, PageInfo.ColWidth * (Col - PageInfo.StartCol));\r\n Result.Right := Result.Left + PageInfo.ColWidth;\r\n\r\n { variable width cols, leave for future reference\r\n For I := LeftCol to Col - 1 do\r\n Inc(Result.Left, Cols[I].Width);\r\n Result.Right := Result.Left + Cols[Col].Width;\r\n }\r\n\r\n if PageInfo.ShowColHdr then\r\n //group Result.Top := ColHdrHeight\r\n Result.Top := CalcGroupColHdrsHeight\r\n else\r\n Result.Top := 0;\r\n Inc(Result.Top, (Row - PageInfo.StartRow) * PageInfo.RowHeight);\r\n Result.Bottom := Result.Top + PageInfo.RowHeight;\r\n end\r\n else\r\n // non-visible data cell (visible col, but non-visible row)\r\n Result := EmptyRect\r\n\r\n else // non-visible data col\r\n Result := EmptyRect;\r\nend;\r\n\r\nprocedure TJvTFDaysPrinter.ClearPageInfo;\r\nbegin\r\n if not Assigned(FPageInfoList) then\r\n Exit;\r\n\r\n while FPageInfoList.Count > 0 do\r\n begin\r\n FPageInfoList.Objects[0].Free;\r\n FPageInfoList.Delete(0);\r\n end;\r\n FValidPageInfo := False;\r\nend;\r\n\r\nprocedure TJvTFDaysPrinter.ClearPicDrawList(DrawList: TList);\r\nbegin\r\n while DrawList.Count > 0 do\r\n begin\r\n TJvTFDrawPicInfo(DrawList[0]).Free;\r\n DrawList.Delete(0);\r\n end;\r\nend;\r\n\r\nprocedure TJvTFDaysPrinter.CreateLayout;\r\nbegin\r\n FPageLayout := TJvTFDaysPrinterPageLayout.Create(Self);\r\nend;\r\n\r\nprocedure TJvTFDaysPrinter.CreatePicDrawList(ARect: TRect; Appt: TJvTFAppt;\r\n DrawList: TList);\r\nvar\r\n I, NextPicLeft, ImageIndex, PicWidth: Integer;\r\n ImageList: TCustomImageList;\r\n ImageMap: TJvTFStateImageMap;\r\n CustomImageMap: TJvTFCustomImageMap;\r\n\r\n procedure AddToList(AImageList: TCustomImageList; AImageIndex: Integer;\r\n APicLeft, APicTop: Integer);\r\n var\r\n DrawInfo: TJvTFDrawPicInfo;\r\n begin\r\n DrawInfo := TJvTFDrawPicInfo.Create;\r\n DrawInfo.ImageList := AImageList;\r\n DrawInfo.ImageIndex := AImageIndex;\r\n DrawInfo.PicLeft := APicLeft;\r\n DrawInfo.PicTop := APicTop;\r\n DrawList.Add(DrawInfo);\r\n end;\r\n\r\nbegin\r\n NextPicLeft := ARect.Left;\r\n\r\n if ShowPics and Assigned(ScheduleManager.CustomImages) then\r\n begin\r\n ImageList := ScheduleManager.CustomImages;\r\n CustomImageMap := Appt.ImageMap;\r\n PicWidth := ScreenToPrinter(ImageList.Width + 2, True);\r\n\r\n for I := 0 to CustomImageMap.Count - 1 do\r\n begin\r\n ImageIndex := CustomImageMap[I];\r\n AddToList(ImageList, ImageIndex, NextPicLeft, ARect.Top);\r\n Inc(NextPicLeft, PicWidth);\r\n end;\r\n end;\r\n\r\n if ShowPics and Assigned(ScheduleManager.StateImages) then\r\n begin\r\n ImageList := ScheduleManager.StateImages;\r\n PicWidth := ScreenToPrinter(ImageList.Width + 2, True);\r\n ImageMap := ScheduleManager.StateImageMap;\r\n\r\n if Appt.AlarmEnabled then\r\n begin\r\n ImageIndex := ImageMap.AlarmEnabled;\r\n if ImageIndex > -1 then\r\n begin\r\n AddToList(ImageList, ImageIndex, NextPicLeft, ARect.Top);\r\n Inc(NextPicLeft, PicWidth);\r\n end\r\n end\r\n else\r\n begin\r\n ImageIndex := ImageMap.AlarmDisabled;\r\n if ImageIndex > -1 then\r\n begin\r\n AddToList(ImageList, ImageIndex, NextPicLeft, ARect.Top);\r\n Inc(NextPicLeft, PicWidth);\r\n end;\r\n end;\r\n\r\n ImageIndex := ImageMap.Shared;\r\n if Appt.Shared and (ImageIndex > -1) then\r\n begin\r\n AddToList(ImageList, ImageIndex, NextPicLeft, ARect.Top);\r\n // The following line generates a compiler hint so comment out,\r\n // but leave here as reminder in case method is expanded.\r\n //Inc(NextPicLeft, ImageList.Width + 2);\r\n end;\r\n\r\n { don't show modified pic in printed page\r\n if Appt.Modified and (ImageMap.Modified > -1) then\r\n begin\r\n AddToList(ImageList, ImageMap.Modified, NextPicLeft, ARect.Top);\r\n // The following line generates a compiler hint so comment out,\r\n // but leave here as reminder in case method is expanded.\r\n //Inc(NextPicLeft, ImageList.Width + 2);\r\n end;\r\n }\r\n end;\r\nend;\r\n\r\nfunction TJvTFDaysPrinter.DaysPageLayout: TJvTFDaysPrinterPageLayout;\r\nbegin\r\n Result := TJvTFDaysPrinterPageLayout(PageLayout);\r\nend;\r\n\r\n{***************************************************************************\r\n * The following routine was based off of a routine originally found in the\r\n * PrinterDemo #1 project of Earl F. Glynn's Computer Lab and is used with\r\n * permission.\r\n * http://www.efg2.com/Lab/OtherProjects/PrinterDemo1.htm\r\n *\r\n * This routine solves a color \"washing\" problem encountered on some printers.\r\n * It demonstrates the proper use of StretchDIBits. Many thanks to Earl\r\n * for providing the Computer Lab. This solution saved me several hours\r\n * of research and trial and error.\r\n ****************************************************************************}\r\n\r\nprocedure TJvTFDaysPrinter.PrintBitmap(ACanvas: TCanvas; SourceRect,\r\n DestRect: TRect; aBitmap: TBitmap);\r\nvar\r\n BitmapHeader: pBitmapInfo;\r\n BitmapImage: POINTER;\r\n\r\n HeaderSize: LongWord;\r\n ImageSize: LongWord;\r\n\r\nbegin\r\n GetDIBSizes(aBitmap.Handle, HeaderSize, ImageSize);\r\n GetMem(BitmapHeader, HeaderSize);\r\n GetMem(BitmapImage, ImageSize);\r\n try\r\n GetDIB(aBitmap.Handle, aBitmap.Palette, BitmapHeader^, BitmapImage^);\r\n StretchDIBits(ACanvas.Handle,\r\n DestRect.Left, DestRect.Top,\r\n DestRect.Right - DestRect.Left,\r\n DestRect.Bottom - DestRect.Top,\r\n SourceRect.Left, SourceRect.Top,\r\n RectWidth(SourceRect),\r\n RectHeight(SourceRect),\r\n BitmapImage,\r\n TBitmapInfo(BitmapHeader^),\r\n DIB_RGB_COLORS,\r\n SRCCOPY);\r\n finally\r\n FreeMem(BitmapHeader);\r\n FreeMem(BitmapImage)\r\n end;\r\nend;\r\n\r\nprocedure TJvTFDaysPrinter.DrawAppt(ACanvas: TCanvas; Col: Integer;\r\n Appt: TJvTFAppt; StartRow, EndRow: Integer; PageInfo: TJvTFDaysPageInfo);\r\nvar\r\n ApptRect, DataRect: TRect;\r\n ClipRgn: HRgn;\r\nbegin\r\n ApptRect := GetApptRect(Col, Appt, PageInfo);\r\n\r\n if Windows.IsRectEmpty(ApptRect) then\r\n Exit;\r\n\r\n // Printer bug start, fixed\r\n // Calc the data area rect on the given canvas\r\n if PageInfo.ShowRowHdr then\r\n DataRect.Left := RowHdrWidth\r\n else\r\n DataRect.Left := 0;\r\n\r\n if PageInfo.ShowColHdr then\r\n DataRect.Top := CalcGroupColHdrsHeight\r\n else\r\n DataRect.Top := 0;\r\n\r\n DataRect.Right := DataRect.Left + BodyWidth;\r\n DataRect.Bottom := DataRect.Top + BodyHeight;\r\n\r\n // Need to add BodyLeft and BodyTop to account for ViewPortOrg adjustment\r\n ClipRgn := Windows.CreateRectRgn(DataRect.Left + BodyLeft,\r\n DataRect.Top + BodyTop, DataRect.Right + BodyLeft, DataRect.Bottom + BodyTop);\r\n\r\n Windows.SelectClipRgn(ACanvas.Handle, ClipRgn);\r\n DrawApptDetail(ACanvas, ApptRect, Appt, Col, StartRow, EndRow);\r\n Windows.SelectClipRgn(ACanvas.Handle, 0);\r\n Windows.DeleteObject(ClipRgn);\r\n // Printer bug end, fixed\r\nend;\r\n\r\nfunction TJvTFDaysPrinter.CalcTimeStampRect(Appt: TJvTFAppt; BarRect: TRect;\r\n Col, StartRow, EndRow: Integer): TRect;\r\nvar\r\n Offset, ApptLength: TTime;\r\n ColDate: TDate;\r\n StartPercent, EndPercent: Double;\r\nbegin\r\n Result := BarRect;\r\n\r\n if StartRow < 0 then\r\n StartRow := 0;\r\n\r\n if EndRow > RowCount - 1 then\r\n EndRow := RowCount - 1;\r\n\r\n Offset := RowToTime(StartRow);\r\n ApptLength := RowEndTime(EndRow) - Offset;\r\n ColDate := Cols[Col].SchedDate;\r\n\r\n if Trunc(ColDate) <> Trunc(Appt.StartDate) then\r\n StartPercent := 0\r\n else\r\n StartPercent := (Appt.StartTime - Offset) / ApptLength;\r\n\r\n if Trunc(ColDate) <> Trunc(Appt.EndDate) then\r\n EndPercent := 1.0\r\n else\r\n EndPercent := (Appt.EndTime - Offset) / ApptLength;\r\n\r\n Result.Top := Round((BarRect.Bottom - BarRect.Top) * StartPercent) +\r\n BarRect.Top;\r\n Result.Bottom := Round((BarRect.Bottom - BarRect.Top) * EndPercent) +\r\n BarRect.Top;\r\nend;\r\n\r\nprocedure TJvTFDaysPrinter.DrawTimeStamp(ACanvas: TCanvas; TimeStampRect: TRect);\r\nvar\r\n OldColor: TColor;\r\n StampLeft: Integer;\r\nbegin\r\n with ACanvas do\r\n case ApptBar.TimeStampStyle of\r\n tssFullI:\r\n begin\r\n OldColor := Pen.Color;\r\n Pen.Color := ApptBar.TimeStampColor;\r\n Pen.Width := ScreenToPrinter(2, False);\r\n\r\n MoveTo(TimeStampRect.Left + 1, TimeStampRect.Top);\r\n LineTo(TimeStampRect.Right - 1, TimeStampRect.Top);\r\n MoveTo(TimeStampRect.Left + 1, TimeStampRect.Bottom - 1);\r\n LineTo(TimeStampRect.Right - 1, TimeStampRect.Bottom - 1);\r\n\r\n if ApptBar.Width > 5 then\r\n Pen.Width := ScreenToPrinter(2, True)\r\n else\r\n Pen.Width := ScreenToPrinter(1, True);\r\n\r\n // Printer bug, fixed\r\n StampLeft := TimeStampRect.Left + RectWidth(TimeStampRect) div 2;\r\n MoveTo(StampLeft, TimeStampRect.Top + 1);\r\n LineTo(StampLeft, TimeStampRect.Bottom - 1);\r\n\r\n Pen.Width := 1;\r\n\r\n Pen.Color := OldColor;\r\n end;\r\n tssHalfI:\r\n begin\r\n // we only want the left half of the time stamp rect\r\n TimeStampRect.Right := (TimeStampRect.Left + TimeStampRect.Right) div 2;\r\n\r\n OldColor := Pen.Color;\r\n Pen.Color := ApptBar.TimeStampColor;\r\n Pen.Width := ScreenToPrinter(2, False);\r\n\r\n MoveTo(TimeStampRect.Left, TimeStampRect.Top);\r\n LineTo(TimeStampRect.Right - 0, TimeStampRect.Top);\r\n MoveTo(TimeStampRect.Left, TimeStampRect.Bottom - 0);\r\n LineTo(TimeStampRect.Right - 0, TimeStampRect.Bottom - 0);\r\n\r\n if ApptBar.Width > 5 then\r\n Pen.Width := ScreenToPrinter(2, True)\r\n else\r\n Pen.Width := ScreenToPrinter(1, True);\r\n\r\n MoveTo(TimeStampRect.Right - 0, TimeStampRect.Top + 1);\r\n LineTo(TimeStampRect.Right - 0, TimeStampRect.Bottom);\r\n Pen.Color := OldColor;\r\n Pen.Width := 1;\r\n end;\r\n tssBlock:\r\n begin\r\n // we only want the left half of the time stamp rect\r\n TimeStampRect.Right := (TimeStampRect.Left + TimeStampRect.Right) div 2;\r\n\r\n OldColor := Brush.Color;\r\n Brush.Color := ApptBar.TimeStampColor;\r\n FillRect(TimeStampRect);\r\n Brush.Color := OldColor;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvTFDaysPrinter.DrawApptBar(ACanvas: TCanvas; Appt: TJvTFAppt;\r\n BarRect: TRect; Col, StartRow, EndRow: Integer);\r\nvar\r\n OldColor: TColor;\r\n TimeStampRect: TRect;\r\nbegin\r\n with ACanvas do\r\n begin\r\n // Fill Bar Color\r\n OldColor := Brush.Color;\r\n if Appt.BarColor = clDefault then\r\n Brush.Color := ApptBar.Color\r\n else\r\n Brush.Color := Appt.BarColor;\r\n\r\n FillRect(BarRect);\r\n Brush.Color := OldColor;\r\n\r\n // Draw Bar Border\r\n Pen.Width := 1;\r\n Pen.Color := ApptAttr.FrameColor;\r\n MoveTo(BarRect.Right - 1, BarRect.Top);\r\n LineTo(BarRect.Right - 1, BarRect.Bottom);\r\n\r\n // Draw Time Stamp\r\n TimeStampRect := CalcTimeStampRect(Appt, BarRect, Col, StartRow, EndRow);\r\n if ApptBar.TimeStampStyle <> tssNone then\r\n DrawTimeStamp(ACanvas, TimeStampRect);\r\n\r\n if Assigned(FOnDrawApptBar) then\r\n FOnDrawApptBar(Self, ACanvas, Appt, Col, BarRect, TimeStampRect);\r\n end;\r\nend;\r\n\r\n{\r\nprocedure TJvTFDaysPrinter.DrawApptBar(ACanvas: TCanvas; Appt: TJvTFAppt;\r\n BarRect: TRect; Col, StartRow, EndRow: Integer);\r\nvar\r\n OldColor: TColor;\r\n MarkerRect: TRect;\r\n Offset,\r\n ApptLength: TTime;\r\n ColDate: TDate;\r\n StartPercent,\r\n EndPercent: Double;\r\nbegin\r\n With ACanvas do\r\n begin\r\n // Fill Bar Color\r\n OldColor := Brush.Color;\r\n if Appt.BarColor = clDefault then\r\n Brush.Color := ApptBar.Color\r\n else\r\n Brush.Color := Appt.BarColor;\r\n\r\n FillRect(BarRect);\r\n Brush.Color := OldColor;\r\n\r\n // Draw Bar Border\r\n Pen.Width := 1;\r\n Pen.Color := ApptAttr.FrameColor;\r\n MoveTo(BarRect.Right - 1, BarRect.Top);\r\n LineTo(BarRect.Right - 1, BarRect.Bottom);\r\n\r\n // Draw Time Stamp\r\n Case ApptBar.TimeStampStyle of\r\n tssFullI :\r\n begin\r\n MarkerRect := BarRect;\r\n\r\n Offset := RowToTime(StartRow);\r\n ApptLength := RowEndTime(EndRow) - Offset;\r\n ColDate := Cols[Col].SchedDate;\r\n\r\n if Trunc(ColDate) <> Trunc(Appt.StartDate) then\r\n StartPercent := 0\r\n else\r\n StartPercent := (Appt.StartTime - Offset) / ApptLength;\r\n\r\n if Trunc(ColDate) <> Trunc(Appt.EndDate) then\r\n EndPercent := 1.0\r\n else\r\n EndPercent := (Appt.EndTime - Offset) / ApptLength;\r\n\r\n MarkerRect.Top := Round((BarRect.Bottom - BarRect.Top) *\r\n StartPercent) + BarRect.Top;\r\n MarkerRect.Bottom := Round((BarRect.Bottom - BarRect.Top) *\r\n EndPercent) + BarRect.Top;\r\n\r\n OldColor := Pen.Color;\r\n Pen.Color := ApptBar.TimeStampColor;\r\n Pen.Width := ScreenToPrinter(2, False);\r\n\r\n MoveTo(MarkerRect.Left + 1, MarkerRect.Top);\r\n LineTo(MarkerRect.Right - 1, MarkerRect.Top);\r\n MoveTo(MarkerRect.Left + 1, MarkerRect.Bottom - 1);\r\n LineTo(MarkerRect.Right - 1, MarkerRect.Bottom - 1);\r\n\r\n if ApptBar.Width > 5 then\r\n Pen.Width := ScreenToPrinter(2, True)\r\n else\r\n Pen.Width := ScreenToPrinter(1, True);\r\n\r\n MoveTo((MarkerRect.Right) div 2, MarkerRect.Top + 1);\r\n LineTo((MarkerRect.Right) div 2, MarkerRect.Bottom - 1);\r\n Pen.Width := 1;\r\n\r\n Pen.Color := OldColor;\r\n end;\r\n\r\n tssHalfI :\r\n begin\r\n MarkerRect := BarRect;\r\n MarkerRect.Right := MarkerRect.Right div 2;\r\n\r\n Offset := RowToTime(StartRow);\r\n ApptLength := RowEndTime(EndRow) - Offset;\r\n ColDate := Cols[Col].SchedDate;\r\n\r\n if Trunc(ColDate) <> Trunc(Appt.StartDate) then\r\n StartPercent := 0\r\n else\r\n StartPercent := (Appt.StartTime - Offset) / ApptLength;\r\n\r\n if Trunc(ColDate) <> Trunc(Appt.EndDate) then\r\n EndPercent := 1.0\r\n else\r\n EndPercent := (Appt.EndTime - Offset) / ApptLength;\r\n\r\n MarkerRect.Top := Round((BarRect.Bottom - BarRect.Top) *\r\n StartPercent) + BarRect.Top;\r\n MarkerRect.Bottom := Round((BarRect.Bottom - BarRect.Top) *\r\n EndPercent) + BarRect.Top;\r\n\r\n OldColor := Pen.Color;\r\n Pen.Color := ApptBar.TimeStampColor;\r\n Pen.Width := ScreenToPrinter(2, False);\r\n\r\n MoveTo(MarkerRect.Left, MarkerRect.Top);\r\n LineTo(MarkerRect.Right - 0, MarkerRect.Top);\r\n MoveTo(MarkerRect.Left, MarkerRect.Bottom - 0);\r\n LineTo(MarkerRect.Right - 0, MarkerRect.Bottom - 0);\r\n\r\n if ApptBar.Width > 5 then\r\n Pen.Width := ScreenToPrinter(2, True)\r\n else\r\n Pen.Width := ScreenToPrinter(1, True);\r\n MoveTo(MarkerRect.Right - 0, MarkerRect.Top + 1);\r\n LineTo(MarkerRect.Right - 0, MarkerRect.Bottom);\r\n Pen.Color := OldColor;\r\n Pen.Width := 1;\r\n end;\r\n\r\n tssBlock :\r\n begin\r\n MarkerRect := BarRect;\r\n MarkerRect.Right := MarkerRect.Right div 2;\r\n\r\n Offset := RowToTime(StartRow);\r\n ApptLength := RowEndTime(EndRow) - Offset;\r\n ColDate := Cols[Col].SchedDate;\r\n\r\n if Trunc(ColDate) <> Trunc(Appt.StartDate) then\r\n StartPercent := 0\r\n else\r\n StartPercent := (Appt.StartTime - Offset) / ApptLength;\r\n\r\n if Trunc(ColDate) <> Trunc(Appt.EndDate) then\r\n EndPercent := 1.0\r\n else\r\n EndPercent := (Appt.EndTime - Offset) / ApptLength;\r\n\r\n MarkerRect.Top := Round((BarRect.Bottom - BarRect.Top) *\r\n StartPercent) + BarRect.Top;\r\n MarkerRect.Bottom := Round((BarRect.Bottom - BarRect.Top) *\r\n EndPercent) + BarRect.Top;\r\n\r\n OldColor := Brush.Color;\r\n Brush.Color := ApptBar.TimeStampColor;\r\n FillRect(MarkerRect);\r\n Brush.Color := OldColor;\r\n end;\r\n end;\r\n end;\r\nend;\r\n}\r\n\r\nprocedure TJvTFDaysPrinter.DrawApptDetail(ACanvas: TCanvas; ARect: TRect;\r\n Appt: TJvTFAppt; Col, StartRow, EndRow: Integer);\r\nvar\r\n TheFrameRect, TxtRect, DetailRect, BarRect: TRect;\r\n Txt: string;\r\n Flags: UINT;\r\n CanDrawText, CanDrawPics, CanDrawAppt: Boolean;\r\n PicsHeight, PicsWidth: Integer;\r\n DrawList: TList;\r\n DrawInfo: TJvTFDaysApptDrawInfo;\r\nbegin\r\n with ACanvas do\r\n begin\r\n DrawInfo := TJvTFDaysApptDrawInfo.Create;\r\n try\r\n GetApptDrawInfo(DrawInfo, Appt);\r\n Font.Assign(DrawInfo.Font);\r\n Brush.Color := DrawInfo.Color;\r\n Pen.Color := DrawInfo.FrameColor;\r\n Pen.Width := DrawInfo.FrameWidth;\r\n CanDrawAppt := DrawInfo.Visible;\r\n finally\r\n DrawInfo.Free;\r\n end;\r\n\r\n // !!!!!!!!!!!!!!!!!!!!!!!!!!\r\n // EXIT IF NOTHING TO DRAW !!\r\n // !!!!!!!!!!!!!!!!!!!!!!!!!!\r\n if not CanDrawAppt then\r\n Exit;\r\n\r\n //Brush.Color := GetApptDispColor(Appt);\r\n FillRect(ARect);\r\n\r\n //Pen.Color := ApptAttr.FrameColor;\r\n //Pen.Width := ApptAttr.FrameWidth;\r\n TheFrameRect := ARect;\r\n Windows.InflateRect(TheFrameRect, -(ApptAttr.FrameWidth div 2),\r\n -(ApptAttr.FrameWidth div 2));\r\n\r\n // Need to fine tune the frame rect\r\n if ApptAttr.FrameWidth mod 2 = 0 then\r\n begin\r\n Inc(TheFrameRect.Right);\r\n Inc(TheFrameRect.Bottom);\r\n end;\r\n\r\n MoveTo(TheFrameRect.Left, TheFrameRect.Top);\r\n LineTo(TheFrameRect.Right - 1, TheFrameRect.Top);\r\n LineTo(TheFrameRect.Right - 1, TheFrameRect.Bottom - 1);\r\n LineTo(TheFrameRect.Left, TheFrameRect.Bottom - 1);\r\n LineTo(TheFrameRect.Left, TheFrameRect.Top);\r\n\r\n // Only go through the following work if all details must be drawn\r\n if (RectHeight(ARect) > Thresholds.DetailHeight) and\r\n (RectWidth(ARect) > Thresholds.DetailWidth) then\r\n begin\r\n Windows.InflateRect(TheFrameRect, -(ApptAttr.FrameWidth div 2),\r\n -(ApptAttr.FrameWidth div 2));\r\n\r\n DetailRect := TheFrameRect;\r\n\r\n if ApptBar.Visible then\r\n begin\r\n Inc(DetailRect.Left, ApptBar.Width);\r\n Windows.SubtractRect(BarRect, TheFrameRect, DetailRect);\r\n Dec(BarRect.Bottom);\r\n DrawApptBar(ACanvas, Appt, BarRect, Col, StartRow, EndRow);\r\n end;\r\n\r\n TxtRect := DetailRect;\r\n\r\n Windows.InflateRect(TxtRect, -2, -2);\r\n\r\n DrawList := TList.Create;\r\n try\r\n // Set the canvas' font now so text height and width calc's will\r\n // be correct.\r\n //Font := ApptAttr.Font;\r\n CreatePicDrawList(TxtRect, Appt, DrawList);\r\n FilterPicDrawList(TxtRect, DrawList, PicsHeight, PicsWidth);\r\n // Calc'ing text height and width in CanDrawWhat\r\n CanDrawWhat(ACanvas, TxtRect, PicsHeight, PicsWidth, CanDrawText, CanDrawPics);\r\n\r\n if CanDrawPics then\r\n begin\r\n DrawListPics(ACanvas, TxtRect, DrawList);\r\n Inc(TxtRect.Left, PicsWidth); // Mantis 2340: Be coherent with JvTFDays\r\n end;\r\n finally\r\n ClearPicDrawList(DrawList);\r\n DrawList.Free;\r\n end;\r\n\r\n if CanDrawText then\r\n begin\r\n Flags := DT_WORDBREAK or DT_NOPREFIX or DT_EDITCONTROL;\r\n\r\n Txt := ScheduleManager.GetApptDisplayText(Self, Appt);\r\n\r\n if not FormattedDesc then\r\n begin\r\n Txt := StripCRLF(Txt);\r\n Flags := Flags or DT_END_ELLIPSIS;\r\n end;\r\n\r\n Windows.DrawText(ACanvas.Handle, PChar(Txt), -1, TxtRect, Flags);\r\n end;\r\n end;\r\n\r\n if Assigned(FOnDrawAppt) then\r\n FOnDrawAppt(Self, ACanvas, ARect, Appt, False);\r\n end;\r\nend;\r\n\r\nprocedure TJvTFDaysPrinter.DrawAppts(ACanvas: TCanvas; DrawAll: Boolean;\r\n PageInfo: TJvTFDaysPageInfo);\r\nvar\r\n FromCol, ToCol, FromRow, ToRow, Col, I: Integer;\r\n ApptStartRow, ApptEndRow, SchedDate: Integer;\r\n Appt: TJvTFAppt;\r\nbegin\r\n if Aborted then\r\n Exit;\r\n\r\n if DrawAll then\r\n begin\r\n FromCol := 0;\r\n ToCol := Cols.Count - 1;\r\n FromRow := 0;\r\n ToRow := RowCount - 1;\r\n end\r\n else\r\n begin\r\n FromCol := PageInfo.StartCol;\r\n ToCol := PageInfo.EndCol;\r\n FromRow := PageInfo.StartRow;\r\n ToRow := PageInfo.EndRow;\r\n end;\r\n\r\n if Assigned(FOnApptProgress) and (FApptsDrawn = 0) then\r\n FOnApptProgress(Self, 0, ApptCount);\r\n Application.ProcessMessages;\r\n\r\n Col := FromCol;\r\n while (Col <= ToCol) and not Aborted do\r\n //For Col := FromCol to ToCol do\r\n begin\r\n if Cols[Col].Connected and not Aborted then\r\n begin\r\n SchedDate := Trunc(Cols[Col].SchedDate);\r\n I := 0;\r\n while (I < Cols[Col].Schedule.ApptCount) and not Aborted do\r\n //For I := 0 to Cols[Col].Schedule.ApptCount - 1 do\r\n begin\r\n Appt := Cols[Col].Schedule.Appts[I];\r\n\r\n CalcStartEndRows(Appt, SchedDate, ApptStartRow, ApptEndRow);\r\n\r\n if (ApptStartRow <= ToRow) and (ApptEndRow >= FromRow) then\r\n begin\r\n DrawAppt(ACanvas, Col, Appt, ApptStartRow, ApptEndRow, PageInfo);\r\n Inc(FApptsDrawn);\r\n if Assigned(FOnApptProgress) then\r\n FOnApptProgress(Self, FApptsDrawn, ApptCount);\r\n Application.ProcessMessages;\r\n end;\r\n Inc(I);\r\n end;\r\n end;\r\n Inc(Col);\r\n end;\r\nend;\r\n\r\nprocedure TJvTFDaysPrinter.DrawBody(ACanvas: TCanvas; ARect: TRect;\r\n PageNum: Integer);\r\nvar\r\n SaveMeasure: TJvTFPrinterMeasure;\r\n PageInfo: TJvTFDaysPageInfo;\r\n I, J: Integer;\r\nbegin\r\n if Aborted then\r\n Exit;\r\n\r\n SaveMeasure := Measure;\r\n Measure := pmPixels;\r\n\r\n PageInfo := TJvTFDaysPageInfo(FPageInfoList.Objects[PageNum - 1]);\r\n\r\n with ACanvas do\r\n begin\r\n Brush.Color := Self.Color;\r\n FillRect(ARect);\r\n\r\n DrawCorner(ACanvas);\r\n\r\n if PageInfo.ShowColHdr then\r\n begin\r\n if Cols.Count = 0 then\r\n DrawEmptyColHdr(ACanvas, PageInfo)\r\n else\r\n begin\r\n DrawGroupHdrs(ACanvas, PageInfo);\r\n for I := PageInfo.StartCol to PageInfo.EndCol do\r\n begin\r\n if Aborted then\r\n Break;\r\n //DrawColHdr(ACanvas, I, PageInfo);\r\n DrawColGroupHdr(ACanvas, I, PageInfo, False);\r\n end;\r\n end;\r\n end;\r\n\r\n if PageInfo.ShowRowHdr then\r\n if RowHdrType = rhFancy then\r\n DrawFancyRowHdrs(ACanvas, PageInfo)\r\n else\r\n for I := PageInfo.StartRow to PageInfo.EndRow do\r\n begin\r\n if Aborted then\r\n Break;\r\n DrawRowHdr(ACanvas, I, PageInfo);\r\n end;\r\n\r\n for I := PageInfo.StartRow to PageInfo.EndRow do\r\n for J := PageInfo.StartCol to PageInfo.EndCol do\r\n begin\r\n if Aborted then\r\n Break;\r\n DrawDataCell(ACanvas, J, I, PageInfo);\r\n end;\r\n\r\n if not (csDesigning in ComponentState) and not Aborted then\r\n DrawAppts(ACanvas, False, PageInfo);\r\n end;\r\n\r\n Measure := SaveMeasure;\r\n\r\n inherited DrawBody(ACanvas, ARect, PageNum);\r\nend;\r\n\r\n{\r\nprocedure TJvTFDaysPrinter.DrawColHdr(ACanvas: TCanvas; Index: Integer;\r\n PageInfo: TJvTFDaysPageInfo);\r\nvar\r\n ARect,\r\n TxtRect,\r\n CalcRect: TRect;\r\n Txt: string;\r\n PTxt: PChar;\r\n Flags: UINT;\r\n TxtHt,\r\n TxtRectHt: Integer;\r\nbegin\r\n ARect := CellRect(Index, -1, PageInfo);\r\n\r\n //Txt := Copy(Cols[Index].Title, 1, Length(Cols[Index].Title));\r\n Txt := Cols[Index].Title;\r\n\r\n ACanvas.Brush.Color := HdrAttr.Color;\r\n ACanvas.Font.Assign(HdrAttr.Font);\r\n\r\n Flags := DT_NOPREFIX or DT_CENTER;\r\n Case ColTitleStyle of\r\n ctsSingleClip : Flags := Flags or DT_SINGLELINE or DT_VCENTER;\r\n ctsSingleEllipsis: Flags := Flags or DT_END_ELLIPSIS or DT_SINGLELINE or\r\n DT_VCENTER;\r\n ctsMultiClip : Flags := Flags or DT_WORDBREAK;\r\n ctsMultiEllipsis : Flags := Flags or DT_END_ELLIPSIS or DT_WORDBREAK or\r\n DT_EDITCONTROL;\r\n ctsHide : Flags := Flags or DT_SINGLELINE or DT_VCENTER;\r\n end;\r\n\r\n ACanvas.FillRect(ARect);\r\n TxtRect := ARect;\r\n Windows.InflateRect(TxtRect, -2, -2);\r\n CalcRect := TxtRect;\r\n\r\n //PTxt := StrNew(PChar(Txt));\r\n PTxt := StrAlloc((Length(Txt) + 4) * SizeOf(Char));\r\n StrPCopy(PTxt, Txt);\r\n\r\n if (ColTitleStyle = ctsMultiClip) or\r\n (ColTitleStyle = ctsMultiEllipsis) then\r\n begin\r\n TxtHt := Windows.DrawText(ACanvas.Handle, PTxt, -1, CalcRect,\r\n Flags or DT_CALCRECT);\r\n\r\n if TxtHt < RectHeight(TxtRect) then\r\n begin\r\n // we need to vertically center the text\r\n TxtRectHt := RectHeight(TxtRect);\r\n TxtRect.Top := TxtRect.Top + RectHeight(TxtRect) div 2 - TxtHt div 2;\r\n TxtRect.Bottom := Lesser(TxtRect.Top + TxtRectHt, TxtRect.Bottom);\r\n end;\r\n end\r\n else\r\n if ColTitleStyle = ctsHide then\r\n begin\r\n Windows.DrawText(ACanvas.Handle, PTxt, -1, CalcRect, Flags or DT_CALCRECT);\r\n if RectWidth(CalcRect) > RectWidth(TxtRect) then\r\n StrPCopy(PTxt, '');\r\n end;\r\n\r\n Windows.DrawText(ACanvas.Handle, PTxt, -1, TxtRect, Flags);\r\n StrDispose(PTxt);\r\n\r\n DrawFrame(ACanvas, ARect, HdrAttr.Frame3D);\r\n\r\n if Assigned(FOnDrawColHdr) then\r\n FOnDrawColHdr(Self, ACanvas, ARect, Index, False);\r\nend;\r\n}\r\n\r\nprocedure TJvTFDaysPrinter.DrawCorner(ACanvas: TCanvas);\r\nvar\r\n ARect: TRect;\r\nbegin\r\n //group ARect := Classes.Rect(0, 0, RowHdrWidth, ColHdrHeight);\r\n ARect := Classes.Rect(0, 0, RowHdrWidth, CalcGroupColHdrsHeight);\r\n with ACanvas do\r\n begin\r\n Brush.Color := HdrAttr.Color;\r\n FillRect(ARect);\r\n\r\n if HdrAttr.Frame3D then\r\n DrawFrame(ACanvas, ARect, HdrAttr.Frame3D)\r\n else\r\n begin\r\n if RowHdrType = rhFancy then\r\n begin\r\n Pen.Color := FancyRowHdrAttr.TickColor;\r\n MoveTo(ARect.Right - 1, ARect.Top);\r\n LineTo(ARect.Right - 1, ARect.Bottom - 1);\r\n MoveTo(ARect.Left, ARect.Bottom - 1);\r\n LineTo(ARect.Right, ARect.Bottom - 1);\r\n end\r\n else\r\n DrawFrame(ACanvas, ARect, False);\r\n end;\r\n\r\n if Assigned(FOnDrawCorner) then\r\n FOnDrawCorner(Self, ACanvas, ARect, agcTopLeft);\r\n end;\r\nend;\r\n\r\nprocedure TJvTFDaysPrinter.DrawDataCell(ACanvas: TCanvas; ColIndex,\r\n RowIndex: Integer; PageInfo: TJvTFDaysPageInfo);\r\nvar\r\n ARect: TRect;\r\n PrimeStartRow, PrimeEndRow: Integer;\r\n CellColor: TColor;\r\nbegin\r\n // Calc the cell rect\r\n if PageInfo.ShowRowHdr then\r\n ARect.Left := RowHdrWidth\r\n else\r\n ARect.Left := 0;\r\n\r\n ARect.Left := ARect.Left + (ColIndex - PageInfo.StartCol) * PageInfo.ColWidth;\r\n ARect.Right := ARect.Left + PageInfo.ColWidth;\r\n\r\n { variable col widths, leave for future reference\r\n For I := LeftCol to ColIndex - 1 do\r\n Inc(ARect.Left, Cols[I].Width);\r\n ARect.Right := ARect.Left + Cols[ColIndex].Width;\r\n }\r\n\r\n if PageInfo.ShowColHdr then\r\n //group ARect.Top := ColHdrHeight\r\n ARect.Top := CalcGroupColHdrsHeight\r\n else\r\n ARect.Top := 0;\r\n\r\n ARect.Top := ARect.Top + (RowIndex - PageInfo.StartRow) * PageInfo.RowHeight;\r\n ARect.Bottom := ARect.Top + PageInfo.RowHeight;\r\n\r\n PrimeStartRow := TimeToRow(PrimeTime.StartTime);\r\n PrimeEndRow := TimeToRow(AdjustEndTime(PrimeTime.EndTime));\r\n\r\n if (RowIndex >= PrimeStartRow) and (RowIndex <= PrimeEndRow) then\r\n CellColor := PrimeTime.Color\r\n else\r\n CellColor := Color;\r\n\r\n if Assigned(FOnShadeCell) then\r\n FOnShadeCell(Self, ColIndex, RowIndex, CellColor);\r\n\r\n if CellColor <> Color then\r\n begin\r\n ACanvas.Brush.Color := CellColor;\r\n ACanvas.FillRect(ARect);\r\n end;\r\n\r\n // Draw a line across the ARect.Bottom and down the ARect.Right side\r\n with ACanvas do\r\n begin\r\n Pen.Color := GridLineColor;\r\n Pen.Width := 1;\r\n\r\n MoveTo(ARect.Left, ARect.Bottom - 1);\r\n LineTo(ARect.Right, ARect.Bottom - 1);\r\n MoveTo(ARect.Right - 1, ARect.Top);\r\n LineTo(ARect.Right - 1, ARect.Bottom - 1);\r\n end;\r\n\r\n if Assigned(FOnDrawDataCell) then\r\n FOnDrawDataCell(Self, ACanvas, ARect, ColIndex, RowIndex);\r\nend;\r\n\r\nprocedure TJvTFDaysPrinter.DrawEmptyColHdr(ACanvas: TCanvas;\r\n PageInfo: TJvTFDaysPageInfo);\r\nvar\r\n ARect: TRect;\r\nbegin\r\n ARect.Left := RowHdrWidth;\r\n ARect.Top := 0;\r\n ARect.Right := ARect.Left + GetDataWidth(PageInfo.ShowRowHdr);\r\n //group ARect.Bottom := ColHdrHeight;\r\n ARect.Bottom := CalcGroupColHdrsHeight;\r\n\r\n with ACanvas do\r\n begin\r\n Brush.Color := HdrAttr.Color;\r\n FillRect(ARect);\r\n Pen.Color := clGray;\r\n MoveTo(ARect.Left, ARect.Bottom - 1);\r\n LineTo(ARect.Right, ARect.Bottom - 1);\r\n end;\r\nend;\r\n\r\nprocedure TJvTFDaysPrinter.DrawFancyRowHdrs(ACanvas: TCanvas;\r\n PageInfo: TJvTFDaysPageInfo);\r\nvar\r\n I, MajorTickLength, MinorTickLength, TickLength: Integer;\r\n ARect: TRect;\r\n Lbl: string;\r\n PrevHour, CurrentHour: Word;\r\n FirstMajor, Switch: Boolean;\r\nbegin\r\n MajorTickLength := GetMajorTickLength;\r\n MinorTickLength := GetMinorTickLength(ACanvas);\r\n\r\n FirstMajor := True;\r\n PrevHour := RowToHour(PageInfo.StartRow);\r\n for I := PageInfo.StartRow to PageInfo.EndRow do\r\n begin\r\n CurrentHour := RowToHour(I);\r\n\r\n Switch := (CurrentHour <> PrevHour) or (I = PageInfo.EndRow);\r\n\r\n ARect := CellRect(-1, I, PageInfo);\r\n Lbl := GetMinorLabel(I, PageInfo);\r\n if not RowEndsHour(I) then\r\n TickLength := MinorTickLength\r\n else\r\n TickLength := MajorTickLength;\r\n\r\n DrawMinor(ACanvas, ARect, I, Lbl, TickLength);\r\n\r\n // Draw Major if needed\r\n if Switch and (Granularity <> 60) then\r\n begin\r\n if I <> PageInfo.StartRow + 1 then\r\n begin\r\n ARect.Left := 1; // Allow for a small margin on ARect.Left side\r\n ARect.Right := RowHdrWidth; // No \"cutting\" before the end of the cell.\r\n ARect.Top := CellRect(-1, HourStartRow(PrevHour), PageInfo).Top;\r\n\r\n //group if ARect.Top < ColHdrHeight then\r\n //group ARect.Top := ColHdrHeight;\r\n if ARect.Top < CalcGroupColHdrsHeight then\r\n ARect.Top := CalcGroupColHdrsHeight;\r\n ARect.Bottom := CellRect(-1, HourEndRow(PrevHour), PageInfo).Bottom - 1;\r\n\r\n // No need to check for ARect.Bottom to be outside the page, CellRect\r\n // calculates it so that it does not happen. And using GetDataHeight\r\n // is not a good idea as it removes the column header height, which\r\n // is NOT what we want here as we want the page's integral height.\r\n // If we wer to use it, we would trigger Mantis 2340.\r\n\r\n if FancyRowHdrAttr.Hr2400 then\r\n Lbl := IntToStr(PrevHour)\r\n else\r\n begin\r\n if PrevHour = 0 then\r\n Lbl := '12'\r\n else\r\n if PrevHour > 12 then\r\n Lbl := IntToStr(PrevHour - 12)\r\n else\r\n Lbl := IntToStr(PrevHour);\r\n\r\n if FirstMajor or (PrevHour = 0) or (PrevHour = 12) then\r\n if PrevHour < 12 then\r\n Lbl := Lbl + 'a'\r\n else\r\n Lbl := Lbl + 'p';\r\n end;\r\n\r\n ACanvas.Font.Assign(FancyRowHdrAttr.MajorFont);\r\n ACanvas.Brush.Style := bsClear;\r\n\r\n Windows.DrawText(ACanvas.Handle, PChar(Lbl), -1, ARect,\r\n DT_NOPREFIX or DT_SINGLELINE or DT_LEFT or DT_VCENTER);\r\n\r\n if Assigned(FOnDrawMajorRowHdr) then\r\n FOnDrawMajorRowHdr(Self, ACanvas, ARect, I - 1, False);\r\n\r\n FirstMajor := False;\r\n end;\r\n if Switch then\r\n PrevHour := CurrentHour;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvTFDaysPrinter.DrawFrame(ACanvas: TCanvas; ARect: TRect;\r\n Draw3D: Boolean);\r\nvar\r\n OldPenColor: TColor;\r\nbegin\r\n with ACanvas do\r\n begin\r\n OldPenColor := Pen.Color;\r\n\r\n if Draw3D then\r\n Pen.Color := clBtnShadow\r\n else\r\n Pen.Color := GridLineColor;\r\n MoveTo(ARect.Right - 1, ARect.Top);\r\n LineTo(ARect.Right - 1, ARect.Bottom);\r\n MoveTo(ARect.Left, ARect.Bottom - 1);\r\n LineTo(ARect.Right, ARect.Bottom - 1);\r\n\r\n if Draw3D then\r\n begin\r\n Pen.Color := clBtnHighlight;\r\n MoveTo(ARect.Left, ARect.Top);\r\n LineTo(ARect.Right, ARect.Top);\r\n MoveTo(ARect.Left, ARect.Top);\r\n LineTo(ARect.Left, ARect.Bottom);\r\n end;\r\n\r\n Pen.Color := OldPenColor;\r\n end;\r\nend;\r\n\r\nprocedure TJvTFDaysPrinter.DrawListPics(ACanvas: TCanvas;\r\n var ARect: TRect; DrawList: TList);\r\nvar\r\n I: Integer;\r\n DrawInfo: TJvTFDrawPicInfo;\r\n Pic: TBitmap;\r\n DestRect: TRect;\r\nbegin\r\n Pic := TBitmap.Create;\r\n Pic.Canvas.Brush.Color := ACanvas.Brush.Color;\r\n try\r\n for I := 0 to DrawList.Count - 1 do\r\n begin\r\n DrawInfo := TJvTFDrawPicInfo(DrawList[I]);\r\n Pic.Height := DrawInfo.ImageList.Height;\r\n Pic.Width := DrawInfo.ImageList.Width;\r\n Pic.Canvas.FillRect(Classes.Rect(0, 0, Pic.Width, Pic.Height));\r\n with DrawInfo do\r\n ImageList.Draw(Pic.Canvas, 0, 0, ImageIndex);\r\n DestRect.Left := DrawInfo.PicLeft;\r\n DestRect.Top := DrawInfo.PicTop;\r\n DestRect.Right := DrawInfo.PicLeft +\r\n ScreenToPrinter(DrawInfo.ImageList.Width + 2, True);\r\n DestRect.Bottom := DrawInfo.PicTop +\r\n ScreenToPrinter(DrawInfo.ImageList.Height + 2, False);\r\n PrintBitmap(ACanvas, Classes.Rect(0, 0, Pic.Width, Pic.Height), DestRect, Pic);\r\n end;\r\n finally\r\n Pic.Free;\r\n end;\r\nend;\r\n\r\nprocedure TJvTFDaysPrinter.DrawMinor(ACanvas: TCanvas; ARect: TRect;\r\n RowNum: Integer; const LabelStr: string; TickLength: Integer);\r\nvar\r\n MinorRect, TxtRect: TRect;\r\nbegin\r\n // do the background shading\r\n ACanvas.Brush.Color := FancyRowHdrAttr.Color;\r\n ACanvas.FillRect(ARect);\r\n\r\n MinorRect := ARect;\r\n MinorRect.Left := MinorRect.Right - GetMinorTickLength(ACanvas);\r\n\r\n with ACanvas do\r\n begin\r\n // draw the right border line\r\n Pen.Color := FancyRowHdrAttr.TickColor;\r\n MoveTo(ARect.Right - 1, ARect.Top);\r\n LineTo(ARect.Right - 1, ARect.Bottom);\r\n\r\n // now draw the tick\r\n MoveTo(ARect.Right - 1, ARect.Bottom - 1);\r\n LineTo(ARect.Right - 1 - TickLength, ARect.Bottom - 1);\r\n end;\r\n\r\n // set up a 2 pel margin on the right and bottom sides\r\n TxtRect := ARect;\r\n TxtRect.Right := TxtRect.Right - 2;\r\n TxtRect.Bottom := TxtRect.Bottom - 2;\r\n\r\n // now draw the LabelStr right aligned\r\n ACanvas.Font.Assign(FancyRowHdrAttr.MinorFont);\r\n ACanvas.Brush.Style := bsClear;\r\n\r\n Windows.DrawText(ACanvas.Handle, PChar(LabelStr), -1, TxtRect,\r\n DT_SINGLELINE or DT_RIGHT or DT_NOPREFIX or DT_VCENTER);\r\n\r\n if Assigned(FOnDrawMinorRowHdr) then\r\n FOnDrawMinorRowHdr(Self, ACanvas, ARect, RowNum, False);\r\nend;\r\n\r\nprocedure TJvTFDaysPrinter.DrawRowHdr(ACanvas: TCanvas; Index: Integer;\r\n PageInfo: TJvTFDaysPageInfo);\r\nvar\r\n ARect: TRect;\r\n Txt: string;\r\nbegin\r\n ARect.Left := 0;\r\n if PageInfo.ShowColHdr then\r\n //group Top := ColHdrHeight\r\n ARect.Top := CalcGroupColHdrsHeight\r\n else\r\n ARect.Top := 0;\r\n ARect.Top := ARect.Top + (Index - PageInfo.StartRow) * PageInfo.RowHeight;\r\n ARect.Right := RowHdrWidth;\r\n ARect.Bottom := ARect.Top + PageInfo.RowHeight;\r\n\r\n Txt := FormatDateTime(TimeFormat, RowToTime(Index));\r\n\r\n ACanvas.Brush.Color := HdrAttr.Color;\r\n ACanvas.Font.Assign(HdrAttr.Font);\r\n\r\n DrawTxt(ACanvas, ARect, Txt, taCenter, vaCenter);\r\n\r\n DrawFrame(ACanvas, ARect, HdrAttr.Frame3D);\r\n\r\n if Assigned(FOnDrawRowHdr) then\r\n FOnDrawRowHdr(Self, ACanvas, ARect, Index, False);\r\nend;\r\n\r\nprocedure TJvTFDaysPrinter.EnsureRow(RowNum: Integer);\r\nbegin\r\n if RowNum >= RowCount then\r\n raise EJvTFPrinterError.CreateResFmt(@RsEInvalidRowd, [RowNum]);\r\nend;\r\n\r\nprocedure TJvTFDaysPrinter.FilterPicDrawList(ARect: TRect;\r\n DrawList: TList; var PicsHeight: Integer; var PicsWidth: Integer);\r\nvar\r\n I, NextPicLeft, PicRight, PicBottom: Integer;\r\n DrawIt: Boolean;\r\n DrawInfo: TJvTFDrawPicInfo;\r\nbegin\r\n PicsHeight := 0;\r\n PicsWidth := 0;\r\n if DrawList.Count = 0 then\r\n Exit;\r\n\r\n if Thresholds.PicsAllOrNone then\r\n begin\r\n DrawInfo := TJvTFDrawPicInfo(DrawList[DrawList.Count - 1]);\r\n PicRight := DrawInfo.PicLeft + ScreenToPrinter(DrawInfo.ImageList.Width, True);\r\n if PicRight >= ARect.Right then\r\n begin\r\n while DrawList.Count > 0 do\r\n begin\r\n TJvTFDrawPicInfo(DrawList[0]).Free;\r\n DrawList.Delete(0);\r\n end;\r\n end;\r\n end;\r\n\r\n PicsHeight := 0;\r\n NextPicLeft := ARect.Left;\r\n I := 0;\r\n while I < DrawList.Count do\r\n begin\r\n DrawInfo := TJvTFDrawPicInfo(DrawList[I]);\r\n with DrawInfo do\r\n begin\r\n PicRight := PicLeft + ScreenToPrinter(ImageList.Width + 2, True);\r\n PicBottom := PicTop + ScreenToPrinter(ImageList.Height + 2, False);\r\n DrawIt := True;\r\n\r\n if Thresholds.WholePicsOnly and\r\n (PicRight >= ARect.Right) or (PicBottom >= ARect.Bottom) then\r\n DrawIt := False;\r\n\r\n if DrawIt then\r\n begin\r\n //PicsHeight := Greater(PicsHeight, ImageList.Height + 2);\r\n PicsHeight := Greater(PicsHeight, PicBottom - PicTop + 2);\r\n PicLeft := NextPicLeft;\r\n //Inc(NextPicLeft, ImageList.Width + 2);\r\n Inc(NextPicLeft, PicRight - PicLeft + 2);\r\n // Increment I to move onto next pic in list\r\n Inc(I);\r\n end\r\n else // Remove pic from list\r\n begin\r\n // Remove pic from list\r\n DrawInfo.Free;\r\n DrawList.Delete(I);\r\n // DO NOT increment I - Since pic was removed from list\r\n // I will now point to next pic\r\n end;\r\n end;\r\n end;\r\n PicsWidth := NextPicLeft - ARect.Left;\r\nend;\r\n\r\nfunction TJvTFDaysPrinter.GetApptDispColor(Appt: TJvTFAppt): TColor;\r\nbegin\r\n if Appt.Color = clDefault then\r\n Result := ApptAttr.Color\r\n else\r\n Result := Appt.Color;\r\nend;\r\n\r\nfunction TJvTFDaysPrinter.GetApptRect(Col: Integer; Appt: TJvTFAppt;\r\n PageInfo: TJvTFDaysPageInfo): TRect;\r\nvar\r\n MapCol, MapColCount, Base, MakeUp, BaseWidth, MakeUpWidth: Integer;\r\n BaseCount, GridColWidth, ApptWidth, StartRow, EndRow: Integer;\r\n WorkLeft, WorkTop: Integer;\r\nbegin\r\n if not Assigned(Appt) then\r\n begin\r\n Result := EmptyRect;\r\n Exit;\r\n end;\r\n\r\n CalcStartEndRows(Appt, Cols[Col].SchedDate, StartRow, EndRow);\r\n\r\n if (StartRow < 0) and (EndRow >= 0) then\r\n StartRow := 0;\r\n // if the above condition fails and the StartRow is STILL invalid then\r\n // let the 'Map col not found' catch the error.\r\n\r\n // Printer bug, fixed\r\n EndRow := Lesser(EndRow, PageInfo.EndRow);\r\n\r\n MapCol := Cols[Col].LocateMapCol(Appt, StartRow);\r\n if MapCol < 1 then\r\n begin\r\n raise EJvTFDaysError.CreateRes(@RsEMapColNotFoundForAppointment);\r\n end;\r\n\r\n MapColCount := Cols[Col].MapColCount(StartRow);\r\n if MapColCount < 1 then\r\n begin\r\n //Cols[Col].FMap.Dump('corrupt dump.txt'); !!! FOR DEBUGGING ONLY !!!!\r\n raise EJvTFPrinterError.CreateRes(@RsECorruptAppointmentMap);\r\n end;\r\n\r\n // Col guaranteed to be partially visible\r\n // Printer bug start, fixed\r\n WorkLeft := CellRect(Col, Greater(StartRow, PageInfo.StartRow), PageInfo).Left;\r\n if StartRow < PageInfo.StartRow then\r\n WorkTop := CellRect(Col, PageInfo.StartRow, PageInfo).Top -\r\n PageInfo.RowHeight * (PageInfo.StartRow - StartRow)\r\n else\r\n WorkTop := CellRect(Col, StartRow, PageInfo).Top;\r\n // Printer bug end, fixed\r\n\r\n GridColWidth := PageInfo.ColWidth;\r\n\r\n // The Base* and MakeUp* code that follows calc's the appt width and left\r\n // and takes into account a total width that isn't evenly divisible by\r\n // the map col count. if there is a discrepency then that discrepency\r\n // is divvied up amoung the cols working Result.Left to Result.Right.\r\n //\r\n // Example: Total width = 113, col count = 5\r\n // col 1 = 23\r\n // col 2 = 23\r\n // col 3 = 23\r\n // col 4 = 22\r\n // col 5 = 22\r\n // Total = 113\r\n //\r\n // As opposed to:\r\n // width of all cols = Total div colcount = 22\r\n // ==> Total = 22 * 5 = 110 [110 <> 113]\r\n Base := GridColWidth div MapColCount;\r\n MakeUp := GridColWidth mod MapColCount;\r\n\r\n MakeUpWidth := Lesser(MapCol - 1, MakeUp) * (Base + 1);\r\n BaseCount := MapCol - 1 - MakeUp;\r\n if BaseCount > 0 then\r\n BaseWidth := BaseCount * Base\r\n else\r\n BaseWidth := 0;\r\n\r\n ApptWidth := Base;\r\n if MapCol <= MakeUp then\r\n Inc(ApptWidth);\r\n\r\n // Printer bug, fixed\r\n Result.Left := WorkLeft + MakeUpWidth + BaseWidth;\r\n\r\n Result.Right := Result.Left + ApptWidth - ApptBuffer;\r\n\r\n // Printer bug, fixed\r\n Result.Top := WorkTop;\r\n\r\n Result.Bottom := CellRect(Col, EndRow, PageInfo).Bottom;\r\nend;\r\n\r\nfunction TJvTFDaysPrinter.GetDataHeight(ShowColHdr: Boolean): Integer;\r\nbegin\r\n Result := BodyHeight;\r\n if ShowColHdr then\r\n //group Dec(Result, ConvertMeasure(ColHdrHeight, Measure, pmPixels, False));\r\n Dec(Result, ConvertMeasure(CalcGroupColHdrsHeight, Measure, pmPixels, False));\r\nend;\r\n\r\nfunction TJvTFDaysPrinter.GetDataWidth(ShowRowHdr: Boolean): Integer;\r\nbegin\r\n Result := BodyWidth;\r\n if ShowRowHdr then\r\n Dec(Result, ConvertMeasure(RowHdrWidth, Measure, pmPixels, True));\r\nend;\r\n\r\nfunction TJvTFDaysPrinter.GetMajorTickLength: Integer;\r\nbegin\r\n Result := RowHdrWidth;\r\nend;\r\n\r\nfunction TJvTFDaysPrinter.GetMinorLabel(RowNum: Integer;\r\n PageInfo: TJvTFDaysPageInfo): string;\r\nconst\r\n Full24 = 'h:nn';\r\n FullAP = 'h:nna/p';\r\n MinOnly = ':nn';\r\nvar\r\n TimeFmt: string;\r\n LastFullRow, LastHourStart: Integer;\r\n LastHour: Word;\r\nbegin\r\n if Granularity = 60 then\r\n TimeFmt := Full24\r\n else\r\n if (RowNum = PageInfo.StartRow) and not RowStartsHour(RowNum) then\r\n TimeFmt := Full24\r\n else\r\n begin\r\n LastFullRow := PageInfo.EndRow;\r\n LastHour := RowToHour(LastFullRow);\r\n LastHourStart := HourStartRow(LastHour);\r\n\r\n if ((RowNum = LastHourStart) and not RowStartsHour(RowNum)) or\r\n ((LastHourStart = PageInfo.StartRow) and (RowNum = PageInfo.StartRow)) then\r\n TimeFmt := Full24\r\n else\r\n TimeFmt := MinOnly;\r\n end;\r\n\r\n if (TimeFmt = Full24) and not FancyRowHdrAttr.Hr2400 then\r\n TimeFmt := FullAP;\r\n\r\n Result := FormatDateTime(TimeFmt, RowToTime(RowNum));\r\nend;\r\n\r\nfunction TJvTFDaysPrinter.GetMinorTickLength(ACanvas: TCanvas): Integer;\r\nvar\r\n TempFont: TFont;\r\nbegin\r\n TempFont := TFont.Create;\r\n try\r\n TempFont.Assign(ACanvas.Font);\r\n ACanvas.Font.Assign(FancyRowHdrAttr.MinorFont);\r\n Result := ACanvas.TextWidth('22:22a');\r\n ACanvas.Font.Assign(TempFont);\r\n finally\r\n TempFont.Free;\r\n end;\r\nend;\r\n\r\nfunction TJvTFDaysPrinter.HourEndRow(Hour: Word): Integer;\r\nbegin\r\n Result := TimeToRow(EncodeTime(Hour, 59, 0, 0));\r\nend;\r\n\r\nfunction TJvTFDaysPrinter.HourStartRow(Hour: Word): Integer;\r\nbegin\r\n Result := TimeToRow(EncodeTime(Hour, 0, 0, 0));\r\nend;\r\n\r\nprocedure TJvTFDaysPrinter.Loaded;\r\nvar\r\n I: Integer;\r\nbegin\r\n inherited Loaded;\r\n for I := 0 to Cols.Count - 1 do\r\n Cols[I].Connect;\r\nend;\r\n\r\nprocedure TJvTFDaysPrinter.Prepare;\r\nvar\r\n I: Integer;\r\nbegin\r\n NewDoc;\r\n try\r\n FApptsDrawn := 0;\r\n CalcPageInfo;\r\n if FPageInfoList.Count = 0 then\r\n raise EJvTFPrinterError.CreateRes(@RsEThereIsNoDataToPrint);\r\n\r\n for I := 0 to FPageInfoList.Count - 1 do\r\n NewPage;\r\n //Except on EJvTFPrinterError do\r\n except\r\n begin\r\n FreeDoc;\r\n raise;\r\n end;\r\n end;\r\n FApptsDrawn := 0;\r\n FinishDoc;\r\nend;\r\n\r\nfunction TJvTFDaysPrinter.RowCount: Integer;\r\nvar\r\n Adjustment, H, M, S, MS: Word;\r\n WorkTime: TTime;\r\nbegin\r\n WorkTime := GridEndTime;\r\n\r\n DecodeTime(WorkTime, H, M, S, MS);\r\n Adjustment := 0;\r\n\r\n if (H = 0) and (M = 0) then\r\n begin\r\n WorkTime := EncodeTime(23, 59, 59, 999);\r\n Adjustment := 1;\r\n end;\r\n\r\n //DecodeTime(GridEndTime - GridStartTime, H, M, S, MS);\r\n DecodeTime(WorkTime - GridStartTime, H, M, S, MS);\r\n Result := (H * 60 + M) div Granularity + Adjustment;\r\nend;\r\n\r\nfunction TJvTFDaysPrinter.RowEndsHour(RowNum: Integer): Boolean;\r\nvar\r\n H, M, S, MS: Word;\r\n TempTime: TTime;\r\nbegin\r\n EnsureRow(RowNum);\r\n\r\n TempTime := RowToTime(RowNum) + EncodeTime(0, Granularity - 1, 0, 0);\r\n DecodeTime(TempTime, H, M, S, MS);\r\n Result := M = 59;\r\nend;\r\n\r\nfunction TJvTFDaysPrinter.RowEndTime(RowNum: Integer): TTime;\r\nbegin\r\n Result := RowToTime(RowNum) +\r\n Granularity * EncodeTime(0, 1, 0, 0) - EncodeTime(0, 0, 1, 0);\r\nend;\r\n\r\nfunction TJvTFDaysPrinter.RowStartsHour(RowNum: Integer): Boolean;\r\nvar\r\n H, M, S, MS: Word;\r\nbegin\r\n EnsureRow(RowNum);\r\n\r\n DecodeTime(RowToTime(RowNum), H, M, S, MS);\r\n Result := M = 0;\r\nend;\r\n\r\nfunction TJvTFDaysPrinter.RowToHour(RowNum: Integer): Word;\r\nvar\r\n H, M, S, MS: Word;\r\nbegin\r\n DecodeTime(RowToTime(RowNum), H, M, S, MS);\r\n Result := H;\r\nend;\r\n\r\nfunction TJvTFDaysPrinter.RowToTime(RowNum: Integer): TTime;\r\nvar\r\n TotalMins: Integer;\r\n WorkHours, WorkMins: Word;\r\n H, M, S, MS: Word;\r\n Offset: Integer;\r\nbegin\r\n DecodeTime(GridStartTime, H, M, S, MS);\r\n Offset := H * 60 + M;\r\n TotalMins := RowNum * Granularity + Offset;\r\n\r\n WorkHours := TotalMins div 60;\r\n WorkMins := TotalMins mod 60;\r\n if WorkHours < 24 then\r\n Result := EncodeTime(WorkHours, WorkMins, 0, 0)\r\n else\r\n Result := EncodeTime(23, 59, 59, 999);\r\nend;\r\n\r\nprocedure TJvTFDaysPrinter.SetApptAttr(Value: TJvTFDaysApptAttr);\r\nbegin\r\n SetPropertyCheck;\r\n FApptAttr.Assign(Value);\r\nend;\r\n\r\nprocedure TJvTFDaysPrinter.SetApptBar(Value: TJvTFDaysApptBar);\r\nbegin\r\n SetPropertyCheck;\r\n FApptBar.Assign(Value);\r\nend;\r\n\r\nprocedure TJvTFDaysPrinter.SetApptBuffer(Value: Integer);\r\nbegin\r\n SetPropertyCheck;\r\n if Value < 0 then\r\n Value := 0;\r\n FApptBuffer := Value;\r\nend;\r\n\r\nprocedure TJvTFDaysPrinter.SetColHdrHeight(Value: Integer);\r\nbegin\r\n SetPropertyCheck;\r\n if Value < 0 then\r\n Value := 0;\r\n FColHdrHeight := Value;\r\nend;\r\n\r\nprocedure TJvTFDaysPrinter.SetColor(Value: TColor);\r\nbegin\r\n SetPropertyCheck;\r\n FColor := Value;\r\nend;\r\n\r\nprocedure TJvTFDaysPrinter.SetCols(Value: TJvTFDaysCols);\r\nbegin\r\n FCols.Assign(Value);\r\nend;\r\n\r\nprocedure TJvTFDaysPrinter.SetTFColTitleStyle(Value: TJvTFColTitleStyle);\r\nbegin\r\n SetPropertyCheck;\r\n FColTitleStyle := Value;\r\nend;\r\n\r\nprocedure TJvTFDaysPrinter.SetFancyRowHdrAttr(Value: TJvTFDaysFancyRowHdrAttr);\r\nbegin\r\n SetPropertyCheck;\r\n FFancyRowHdrAttr.Assign(Value);\r\nend;\r\n\r\nprocedure TJvTFDaysPrinter.SetGranularity(Value: Integer);\r\nvar\r\n MaxRowHeight, I: Integer;\r\nbegin\r\n SetPropertyCheck;\r\n\r\n // Enforce minimum granularity of 1 min and max of 60 mins\r\n if Value < 1 then\r\n Value := 1\r\n else\r\n if Value > 60 then\r\n Value := 60;\r\n\r\n // Ensure that granularity is evenly divisable by an hour\r\n while 60 mod Value <> 0 do\r\n Dec(Value);\r\n\r\n // Sum of row heights cannot exceed 32767\r\n MaxRowHeight := 32767 div (60 div Value * 24);\r\n if RowHeight > MaxRowHeight then\r\n RowHeight := MaxRowHeight;\r\n\r\n if Value <> FGranularity then\r\n begin\r\n FGranularity := Value;\r\n if not (csLoading in ComponentState) then\r\n begin\r\n for I := 0 to Cols.Count - 1 do\r\n Cols[I].RefreshMap;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvTFDaysPrinter.SetGridLineColor(Value: TColor);\r\nbegin\r\n SetPropertyCheck;\r\n FGridLineColor := Value;\r\nend;\r\n\r\nprocedure TJvTFDaysPrinter.SetHdrAttr(Value: TJvTFDaysHdrAttr);\r\nbegin\r\n SetPropertyCheck;\r\n FHdrAttr.Assign(Value);\r\nend;\r\n\r\nprocedure TJvTFDaysPrinter.SetMeasure(Value: TJvTFPrinterMeasure);\r\nvar\r\n I: Integer;\r\nbegin\r\n try\r\n FConvertingProps := True;\r\n if Value <> Measure then\r\n begin\r\n // convert properties\r\n ApptAttr.FrameWidth := ConvertMeasure(ApptAttr.FrameWidth, Measure,\r\n Value, False);\r\n ApptBar.Width := ConvertMeasure(ApptBar.Width, Measure, Value, True);\r\n ApptBuffer := ConvertMeasure(ApptBuffer, Measure, Value, True);\r\n ColHdrHeight := ConvertMeasure(ColHdrHeight, Measure, Value, False);\r\n GroupHdrHeight := ConvertMeasure(GroupHdrHeight, Measure, Value, False);\r\n\r\n for I := 0 to Cols.Count - 1 do\r\n Cols[I].Width := ConvertMeasure(Cols[I].Width, Measure, Value, True);\r\n\r\n MinColWidth := ConvertMeasure(MinColWidth, Measure, Value, True);\r\n MinRowHeight := ConvertMeasure(MinRowHeight, Measure, Value, False);\r\n RowHdrWidth := ConvertMeasure(RowHdrWidth, Measure, Value, True);\r\n RowHeight := ConvertMeasure(RowHeight, Measure, Value, False);\r\n Thresholds.DetailHeight := ConvertMeasure(Thresholds.DetailHeight,\r\n Measure, Value, False);\r\n Thresholds.DetailWidth := ConvertMeasure(Thresholds.DetailWidth,\r\n Measure, Value, True);\r\n\r\n inherited SetMeasure(Value);\r\n end;\r\n finally\r\n FConvertingProps := False;\r\n end;\r\nend;\r\n\r\nprocedure TJvTFDaysPrinter.SetMinColWidth(Value: Integer);\r\nbegin\r\n SetPropertyCheck;\r\n if Value < AbsMinColWidth then\r\n Value := AbsMinColWidth;\r\n FMinColWidth := Value;\r\nend;\r\n\r\nprocedure TJvTFDaysPrinter.SetMinRowHeight(Value: Integer);\r\nbegin\r\n SetPropertyCheck;\r\n if Value < 1 then\r\n Value := 1;\r\n FMinRowHeight := Value;\r\nend;\r\n\r\nprocedure TJvTFDaysPrinter.SetPrimeTime(Value: TJvTFDaysPrimeTime);\r\nbegin\r\n SetPropertyCheck;\r\n FPrimeTime.Assign(Value);\r\nend;\r\n\r\nprocedure TJvTFDaysPrinter.SetProperties(aJvTFDays: TJvTFDays);\r\nbegin\r\n ApptAttr := aJvTFDays.ApptAttr;\r\n ApptAttr.FrameWidth :=\r\n ConvertMeasure(ScreenToPrinter(ApptAttr.FrameWidth, False), pmPixels,\r\n Measure, False);\r\n\r\n ApptBar := aJvTFDays.ApptBar;\r\n ApptBar.Width := ConvertMeasure(ScreenToPrinter(ApptBar.Width, True), pmPixels,\r\n Measure, True);\r\n\r\n ApptBuffer := ConvertMeasure(ScreenToPrinter(aJvTFDays.ApptBuffer, True),\r\n pmPixels, Measure, True);\r\n ColHdrHeight := ConvertMeasure(ScreenToPrinter(aJvTFDays.ColHdrHeight, False),\r\n pmPixels, Measure, False);\r\n\r\n Color := aJvTFDays.Color;\r\n ColTitleStyle := aJvTFDays.ColTitleStyle;\r\n DateFormat := aJvTFDays.DateFormat;\r\n FancyRowHdrAttr := aJvTFDays.FancyRowHdrAttr;\r\n FormattedDesc := agoFormattedDesc in aJvTFDays.Options;\r\n Granularity := aJvTFDays.Granularity;\r\n GridLineColor := aJvTFDays.GridLineColor;\r\n GroupHdrAttr := aJvTFDays.GroupHdrAttr;\r\n //GroupHdrHeight := aJvTFDays.GroupHdrHeight;\r\n GroupHdrHeight := ConvertMeasure(ScreenToPrinter(aJvTFDays.GroupHdrHeight,\r\n False), pmPixels, Measure, False);\r\n Grouping := aJvTFDays.Grouping;\r\n HdrAttr := aJvTFDays.HdrAttr;\r\n\r\n MinColWidth := ConvertMeasure(ScreenToPrinter(aJvTFDays.MinColWidth, True),\r\n pmPixels, Measure, True);\r\n\r\n PrimeTime := aJvTFDays.PrimeTime;\r\n RowHdrType := aJvTFDays.RowHdrType;\r\n\r\n RowHdrWidth := ConvertMeasure(ScreenToPrinter(aJvTFDays.RowHdrWidth, True),\r\n pmPixels, Measure, True);\r\n RowHeight := ConvertMeasure(ScreenToPrinter(aJvTFDays.RowHeight, False),\r\n pmPixels, Measure, False);\r\n\r\n ShowPics := agoShowPics in aJvTFDays.Options;\r\n ShowText := agoShowText in aJvTFDays.Options;\r\n Thresholds := aJvTFDays.Thresholds;\r\n Thresholds.DetailHeight :=\r\n ConvertMeasure(ScreenToPrinter(Thresholds.DetailHeight, False), pmPixels,\r\n Measure, False);\r\n Thresholds.DetailWidth :=\r\n ConvertMeasure(ScreenToPrinter(Thresholds.DetailWidth, True), pmPixels,\r\n Measure, True);\r\n\r\n TimeFormat := aJvTFDays.TimeFormat;\r\n\r\n // Set the property fields directly to avoid validity check. Assume\r\n // settings from aJvTFDays are already validated.\r\n FGridStartTime := aJvTFDays.GridStartTime;\r\n FGridEndTime := aJvTFDays.GridEndTime;\r\nend;\r\n\r\nprocedure TJvTFDaysPrinter.SetTFRowHdrType(Value: TJvTFRowHdrType);\r\nbegin\r\n SetPropertyCheck;\r\n FRowHdrType := Value;\r\nend;\r\n\r\nprocedure TJvTFDaysPrinter.SetRowHdrWidth(Value: Integer);\r\nbegin\r\n SetPropertyCheck;\r\n if Value < 0 then\r\n Value := 0;\r\n FRowHdrWidth := Value;\r\nend;\r\n\r\nprocedure TJvTFDaysPrinter.SetRowHeight(Value: Integer);\r\nbegin\r\n SetPropertyCheck;\r\n if Value < 0 then\r\n Value := 0;\r\n FRowHeight := Value;\r\nend;\r\n\r\nprocedure TJvTFDaysPrinter.SetShowPics(Value: Boolean);\r\nbegin\r\n SetPropertyCheck;\r\n FShowPics := Value;\r\nend;\r\n\r\nprocedure TJvTFDaysPrinter.SetShowText(Value: Boolean);\r\nbegin\r\n SetPropertyCheck;\r\n FShowText := Value;\r\nend;\r\n\r\nprocedure TJvTFDaysPrinter.SetThresholds(Value: TJvTFDaysThresholds);\r\nbegin\r\n SetPropertyCheck;\r\n FThresholds.Assign(Value);\r\nend;\r\n\r\nfunction TJvTFDaysPrinter.TimeToRow(ATime: TTime): Integer;\r\nvar\r\n TotalMins: Integer;\r\n WorkHours, WorkMins, WorkSecs, WorkMSecs: Word;\r\n H, M, S, MS: Word;\r\n Offset: Integer;\r\nbegin\r\n DecodeTime(ATime, WorkHours, WorkMins, WorkSecs, WorkMSecs);\r\n\r\n // Convert the given time to minutes\r\n DecodeTime(GridStartTime, H, M, S, MS);\r\n Offset := H * 60 + M;\r\n TotalMins := WorkHours * 60 + WorkMins - Offset;\r\n\r\n // Find the row number by dividing the time in minutes by the granularity\r\n Result := TotalMins div Granularity;\r\n if (TotalMins < 0) and (TotalMins mod Granularity <> 0) then\r\n Dec(Result);\r\nend;\r\n\r\nfunction TJvTFDaysPrinter.GetPageLayout: TJvTFDaysPrinterPageLayout;\r\nbegin\r\n Result := TJvTFDaysPrinterPageLayout(inherited PageLayout);\r\nend;\r\n\r\nprocedure TJvTFDaysPrinter.SetPageLayout(Value: TJvTFDaysPrinterPageLayout);\r\nbegin\r\n inherited PageLayout := Value;\r\nend;\r\n\r\nprocedure TJvTFDaysPrinter.CreateDoc;\r\nvar\r\n I: Integer;\r\nbegin\r\n inherited CreateDoc;\r\n FApptCount := 0;\r\n for I := 0 to Cols.Count - 1 do\r\n Inc(FApptCount, Cols[I].Schedule.ApptCount);\r\nend;\r\n\r\nfunction TJvTFDaysPrinter.GetApptCount: Integer;\r\nvar\r\n I: Integer;\r\nbegin\r\n if State = spsNoDoc then\r\n begin\r\n Result := 0;\r\n for I := 0 to Cols.Count - 1 do\r\n Inc(Result, Cols[I].Schedule.ApptCount);\r\n end\r\n else\r\n Result := FApptCount;\r\nend;\r\n\r\nfunction TJvTFDaysPrinter.GetPageInfo(PageNum: Integer): TJvTFDaysPageInfo;\r\nbegin\r\n if not FValidPageInfo then\r\n raise EJvTFPrinterError.CreateRes(@RsENoPageInfoExists);\r\n\r\n Result := TJvTFDaysPageInfo(FPageInfoList.Objects[PageNum - 1]);\r\nend;\r\n\r\nprocedure TJvTFDaysPrinter.FreeDoc;\r\nbegin\r\n inherited FreeDoc;\r\n\r\n // Do not call ClearPageInfo if component is being destroyed. This must be\r\n // done in TJvTFDaysPrinter.Destroy. TJvTFPrinter.Destroy calls FreeDoc\r\n // and since TJvTFDaysPrinter.Destroy frees FPageInfo a NASTY AV happens.\r\n if not (csDestroying in ComponentState) then\r\n ClearPageInfo;\r\nend;\r\n\r\nprocedure TJvTFDaysPrinter.SetFormattedDesc(Value: Boolean);\r\nbegin\r\n SetPropertyCheck;\r\n FFormattedDesc := Value;\r\nend;\r\n\r\nprocedure TJvTFDaysPrinter.SetGroupHdrAttr(Value: TJvTFDaysHdrAttr);\r\nbegin\r\n SetPropertyCheck;\r\n FGroupHdrAttr.Assign(Value);\r\nend;\r\n\r\nprocedure TJvTFDaysPrinter.SetGroupHdrHeight(Value: Integer);\r\nbegin\r\n SetPropertyCheck;\r\n if Value < 0 then\r\n Value := 0;\r\n FGroupHdrHeight := Value;\r\nend;\r\n\r\nprocedure TJvTFDaysPrinter.SetGrouping(Value: TJvTFDaysGrouping);\r\nbegin\r\n SetPropertyCheck;\r\n FGrouping := Value;\r\n Cols.UpdateTitles;\r\nend;\r\n\r\nprocedure TJvTFDaysPrinter.DrawColGroupHdr(ACanvas: TCanvas;\r\n Index: Integer; PageInfo: TJvTFDaysPageInfo; IsGroupHdr: Boolean);\r\nvar\r\n ARect, TxtRect, CalcRect: TRect;\r\n Txt: string;\r\n Flags: UINT;\r\n TxtHt, TxtRectHt: Integer;\r\n UseAttr: TJvTFDaysHdrAttr;\r\nbegin\r\n if IsGroupHdr then\r\n begin\r\n ARect := VirtualGroupHdrRect(Index, PageInfo);\r\n Txt := Cols[Index].GroupTitle;\r\n UseAttr := GroupHdrAttr;\r\n end\r\n else\r\n begin\r\n ARect := CellRect(Index, -1, PageInfo);\r\n Txt := Cols[Index].Title;\r\n UseAttr := HdrAttr;\r\n end;\r\n\r\n ACanvas.Brush.Color := UseAttr.Color;\r\n ACanvas.Font.Assign(UseAttr.Font);\r\n\r\n Flags := DT_NOPREFIX or DT_CENTER;\r\n case ColTitleStyle of\r\n ctsSingleClip:\r\n Flags := Flags or DT_SINGLELINE or DT_VCENTER;\r\n ctsSingleEllipsis:\r\n Flags := Flags or DT_END_ELLIPSIS or DT_SINGLELINE or DT_VCENTER;\r\n ctsMultiClip:\r\n Flags := Flags or DT_WORDBREAK;\r\n ctsMultiEllipsis:\r\n Flags := Flags or DT_END_ELLIPSIS or DT_WORDBREAK or DT_EDITCONTROL;\r\n ctsHide:\r\n Flags := Flags or DT_SINGLELINE or DT_VCENTER;\r\n end;\r\n\r\n ACanvas.FillRect(ARect);\r\n TxtRect := ARect;\r\n Windows.InflateRect(TxtRect, -2, -2);\r\n CalcRect := TxtRect;\r\n\r\n if (ColTitleStyle = ctsMultiClip) or (ColTitleStyle = ctsMultiEllipsis) then\r\n begin\r\n TxtHt := Windows.DrawText(ACanvas.Handle, PChar(Txt), -1, CalcRect,\r\n Flags or DT_CALCRECT);\r\n\r\n if TxtHt < RectHeight(TxtRect) then\r\n begin\r\n // we need to vertically center the text\r\n TxtRectHt := RectHeight(TxtRect);\r\n TxtRect.Top := TxtRect.Top + RectHeight(TxtRect) div 2 - TxtHt div 2;\r\n TxtRect.Bottom := Lesser(TxtRect.Top + TxtRectHt, TxtRect.Bottom);\r\n end;\r\n end\r\n else\r\n if ColTitleStyle = ctsHide then\r\n begin\r\n Windows.DrawText(ACanvas.Handle, PChar(Txt), -1, CalcRect, Flags or DT_CALCRECT);\r\n if RectWidth(CalcRect) > RectWidth(TxtRect) then\r\n Txt := '';\r\n end;\r\n\r\n Windows.DrawText(ACanvas.Handle, PChar(Txt), -1, TxtRect, Flags);\r\n\r\n DrawFrame(ACanvas, ARect, HdrAttr.Frame3D);\r\n\r\n if IsGroupHdr then\r\n begin\r\n if Assigned(FOnDrawGroupHdr) then\r\n FOnDrawGroupHdr(Self, ACanvas, ARect, Index, False);\r\n end\r\n else\r\n if Assigned(FOnDrawColHdr) then\r\n FOnDrawColHdr(Self, ACanvas, ARect, Index, False);\r\nend;\r\n\r\nprocedure TJvTFDaysPrinter.DrawGroupHdrs(ACanvas: TCanvas;\r\n PageInfo: TJvTFDaysPageInfo);\r\nvar\r\n CurrGroup: string;\r\n I: Integer;\r\nbegin\r\n if CalcGroupHdrHeight > 0 then\r\n begin\r\n CurrGroup := Cols[PageInfo.StartCol].GroupTitle;\r\n DrawColGroupHdr(ACanvas, PageInfo.StartCol, PageInfo, True);\r\n for I := PageInfo.StartCol + 1 to PageInfo.EndCol do\r\n if Cols[I].GroupTitle <> CurrGroup then\r\n begin\r\n CurrGroup := Cols[I].GroupTitle;\r\n DrawColGroupHdr(ACanvas, I, PageInfo, True);\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJvTFDaysPrinter.CalcGroupColHdrsHeight: Integer;\r\nbegin\r\n Result := CalcGroupHdrHeight + ColHdrHeight;\r\nend;\r\n\r\nfunction TJvTFDaysPrinter.CalcGroupHdrHeight: Integer;\r\nbegin\r\n if Grouping = grNone then\r\n Result := 0\r\n else\r\n Result := GroupHdrHeight;\r\nend;\r\n\r\nfunction TJvTFDaysPrinter.VirtualGroupHdrRect(Col: Integer;\r\n PageInfo: TJvTFDaysPageInfo): TRect;\r\nvar\r\n I, GroupStartCol, GroupEndCol, GroupWidth: Integer;\r\nbegin\r\n Result.Top := 0;\r\n Result.Bottom := CalcGroupHdrHeight;\r\n\r\n GetGroupStartEndCols(Col, GroupStartCol, GroupEndCol);\r\n GroupWidth := 0;\r\n for I := GroupStartCol to GroupEndCol do\r\n Inc(GroupWidth, PageInfo.ColWidth);\r\n\r\n Result.Left := RowHdrWidth;\r\n // At most, only one of the following For loops will execute\r\n // depending on whether Col is to the left or to the right of LeftCol\r\n //For I := LeftCol - 1 downto GroupStartCol do\r\n for I := PageInfo.StartCol - 1 downto GroupStartCol do\r\n Dec(Result.Left, PageInfo.ColWidth);\r\n\r\n //For I := LeftCol to GroupStartCol - 1 do\r\n for I := PageInfo.StartCol to GroupStartCol - 1 do\r\n Inc(Result.Left, PageInfo.ColWidth);\r\n\r\n Result.Right := Result.Left + GroupWidth;\r\nend;\r\n\r\nprocedure TJvTFDaysPrinter.GetGroupStartEndCols(Col: Integer;\r\n var StartCol, EndCol: Integer);\r\nvar\r\n I: Integer;\r\nbegin\r\n // find group start col\r\n I := Col;\r\n while (I >= 0) and (Cols[I].GroupTitle = Cols[Col].GroupTitle) do\r\n begin\r\n StartCol := I;\r\n Dec(I);\r\n end;\r\n\r\n // find group end col\r\n I := Col;\r\n while (I < Cols.Count) and (Cols[I].GroupTitle = Cols[Col].GroupTitle) do\r\n begin\r\n EndCol := I;\r\n Inc(I);\r\n end;\r\nend;\r\n\r\nprocedure TJvTFDaysPrinter.PrintDirect;\r\nbegin\r\n DirectPrint := True;\r\n try\r\n try\r\n Prepare;\r\n finally\r\n FreeDoc;\r\n end;\r\n finally\r\n DirectPrint := False;\r\n end;\r\nend;\r\n\r\nprocedure TJvTFDaysPrinter.GetApptDrawInfo(DrawInfo: TJvTFDaysApptDrawInfo;\r\n Appt: TJvTFAppt);\r\nbegin\r\n DrawInfo.Color := GetApptDispColor(Appt);\r\n DrawInfo.FrameColor := ApptAttr.FrameColor;\r\n DrawInfo.FrameWidth := ApptAttr.FrameWidth;\r\n DrawInfo.Font := ApptAttr.Font;\r\n DrawInfo.Visible := True;\r\n\r\n if Assigned(FOnGetApptDrawInfo) then\r\n FOnGetApptDrawInfo(Self, Appt, DrawInfo);\r\nend;\r\n\r\nprocedure TJvTFDaysPrinter.SetGridEndTime(Value: TTime);\r\nvar\r\n I: Integer;\r\n WorkEnd: TTime;\r\n H, M, S, MS: Word;\r\nbegin\r\n WorkEnd := Value;\r\n DecodeTime(WorkEnd, H, M, S, MS);\r\n if (H = 0) and (M = 0) then\r\n WorkEnd := EncodeTime(23, 59, 59, 999);\r\n\r\n if not (csLoading in ComponentState) and (WorkEnd <= GridStartTime) then\r\n raise EJvTFDaysError.CreateRes(@RsEGridEndTimeCannotBePriorToGridStart);\r\n\r\n FGridEndTime := Value;\r\n\r\n if not (csLoading in ComponentState) then\r\n for I := 0 to Cols.Count - 1 do\r\n Cols[I].RefreshMap;\r\nend;\r\n\r\nprocedure TJvTFDaysPrinter.SetGridStartTime(Value: TTime);\r\nvar\r\n I: Integer;\r\n WorkEnd: TTime;\r\n H, M, S, MS: Word;\r\nbegin\r\n WorkEnd := GridEndTime;\r\n DecodeTime(WorkEnd, H, M, S, MS);\r\n if (H = 0) and (M = 0) then\r\n WorkEnd := EncodeTime(23, 59, 59, 999);\r\n\r\n if not (csLoading in ComponentState) and (Value >= WorkEnd) then\r\n raise EJvTFDaysError.CreateRes(@RsEGridStartTimeCannotBeAfterGridEndTi);\r\n\r\n FGridStartTime := Value;\r\n\r\n if not (csLoading in ComponentState) then\r\n for I := 0 to Cols.Count - 1 do\r\n Cols[I].RefreshMap;\r\nend;\r\n\r\n//=== { TJvTFDaysPrinterPageLayout } =========================================\r\n\r\nprocedure TJvTFDaysPrinterPageLayout.Assign(Source: TPersistent);\r\nbegin\r\n inherited Assign(Source);\r\n if Source is TJvTFDaysPrinterPageLayout then\r\n begin\r\n FColsPerPage := TJvTFDaysPrinterPageLayout(Source).ColsPerPage;\r\n FRowsPerPage := TJvTFDaysPrinterPageLayout(Source).RowsPerPage;\r\n FAlwaysShowColHdr := TJvTFDaysPrinterPageLayout(Source).AlwaysShowColHdr;\r\n FAlwaysShowRowHdr := TJvTFDaysPrinterPageLayout(Source).AlwaysShowRowHdr;\r\n // Don't call Change. Ancestor will call it.\r\n end;\r\nend;\r\n\r\nprocedure TJvTFDaysPrinterPageLayout.SetAlwaysShowColHdr(Value: Boolean);\r\nbegin\r\n SetPropertyCheck;\r\n\r\n if Value <> FAlwaysShowColHdr then\r\n begin\r\n FAlwaysShowColHdr := Value;\r\n Change;\r\n end;\r\nend;\r\n\r\nprocedure TJvTFDaysPrinterPageLayout.SetAlwaysShowRowHdr(Value: Boolean);\r\nbegin\r\n SetPropertyCheck;\r\n\r\n if Value <> FAlwaysShowRowHdr then\r\n begin\r\n FAlwaysShowRowHdr := Value;\r\n Change;\r\n end;\r\nend;\r\n\r\nprocedure TJvTFDaysPrinterPageLayout.SetColsPerPage(Value: Integer);\r\nbegin\r\n SetPropertyCheck;\r\n\r\n if Value < 0 then\r\n Value := 0;\r\n if Value <> FColsPerPage then\r\n begin\r\n FColsPerPage := Value;\r\n Change;\r\n end;\r\nend;\r\n\r\nprocedure TJvTFDaysPrinterPageLayout.SetRowsPerPage(Value: Integer);\r\nbegin\r\n SetPropertyCheck;\r\n\r\n if Value < 0 then\r\n Value := 0;\r\n if Value <> FRowsPerPage then\r\n begin\r\n FRowsPerPage := Value;\r\n Change;\r\n end;\r\nend;\r\n\r\n//=== { TJvTFCompNamesList } =================================================\r\n\r\nprocedure TJvTFCompNamesList.Move(CurIndex, NewIndex: Integer);\r\nbegin\r\n inherited Move(CurIndex, NewIndex);\r\n if Assigned(FOnMove) then\r\n FOnMove(Self, CurIndex, NewIndex);\r\nend;\r\n\r\n{$IFDEF Jv_TIMEBLOCKS}\r\n// ok\r\n\r\n//=== { TJvTFDaysTimeBlock } =================================================\r\n\r\nconstructor TJvTFDaysTimeBlock.Create(Collection: TCollection);\r\nbegin\r\n inherited Create(Collection);\r\n FLength := 1;\r\n FName := 'Block' + IntToStr(Index);\r\n FTitle := Name;\r\n FAllowAppts := True;\r\nend;\r\n\r\nprocedure TJvTFDaysTimeBlock.Assign(Source: TPersistent);\r\nbegin\r\n if Source is TJvTFDaysTimeBlock then\r\n begin\r\n FLength := TJvTFDaysTimeBlock(Source).Length;\r\n FTitle := TJvTFDaysTimeBlock(Source).Title;\r\n FAllowAppts := TJvTFDaysTimeBlock(Source).AllowAppts;\r\n Change;\r\n end\r\n else\r\n inherited Assign(Source);\r\nend;\r\n\r\nprocedure TJvTFDaysTimeBlock.Change;\r\nbegin\r\n if Assigned(BlockCollection) and Assigned(BlockCollection.DaysControl) then\r\n BlockCollection.DaysControl.Invalidate;\r\nend;\r\n\r\nfunction TJvTFDaysTimeBlock.GetBlockCollection: TJvTFDaysTimeBlocks;\r\nbegin\r\n Result := TJvTFDaysTimeBlocks(Collection);\r\nend;\r\n\r\nfunction TJvTFDaysTimeBlock.GetDisplayName: string;\r\nbegin\r\n Result := Name;\r\n if Result = '' then\r\n Result := inherited GetDisplayName;\r\nend;\r\n\r\nfunction TJvTFDaysTimeBlock.GetGridLength: Integer;\r\nvar\r\n Days: TJvTFDays;\r\nbegin\r\n Days := BlockCollection.DaysControl;\r\n Result := Length * (Days.TimeBlockProps.BlockGran div Days.Granularity);\r\nend;\r\n\r\nprocedure TJvTFDaysTimeBlock.SetAllowAppts(Value: Boolean);\r\nbegin\r\n FAllowAppts := Value;\r\nend;\r\n\r\nprocedure TJvTFDaysTimeBlock.SetLength(Value: Integer);\r\nbegin\r\n if Value < 1 then\r\n Value := 1;\r\n if Value <> FLength then\r\n begin\r\n FLength := Value;\r\n Change;\r\n end;\r\nend;\r\n\r\nprocedure TJvTFDaysTimeBlock.SetName(const Value: string);\r\nbegin\r\n if Value = '' then\r\n raise EJvTFDaysError.CreateRes(@RsEATimeBlockNameCannotBeNull);\r\n\r\n if Value <> FName then\r\n if not Assigned(BlockCollection.FindBlock(Value)) then\r\n begin\r\n if Title = Name then\r\n Title := Value;\r\n FName := Value;\r\n Change;\r\n end\r\n else\r\n raise EJvTFDaysError.CreateResFmt(@RsEAnotherTimeBlockWithTheName, [Value]);\r\nend;\r\n\r\nprocedure TJvTFDaysTimeBlock.SetTitle(const Value: string);\r\nbegin\r\n if Value <> FTitle then\r\n begin\r\n FTitle := Value;\r\n Change;\r\n end;\r\nend;\r\n\r\n//=== { TJvTFDaysTimeBlocks } ================================================\r\n\r\nconstructor TJvTFDaysTimeBlocks.Create(ADaysControl: TJvTFDays);\r\nbegin\r\n inherited Create(TJvTFDaysTimeBlock);\r\n FDaysControl := ADaysControl;\r\nend;\r\n\r\nfunction TJvTFDaysTimeBlocks.Add: TJvTFDaysTimeBlock;\r\nbegin\r\n Result := TJvTFDaysTimeBlock(inherited Add);\r\nend;\r\n\r\nprocedure TJvTFDaysTimeBlocks.Assign(Source: TPersistent);\r\nvar\r\n I: Integer;\r\nbegin\r\n if Source is TJvTFDaysTimeBlocks then\r\n begin\r\n BeginUpdate;\r\n try\r\n Clear;\r\n for I := 0 to TJvTFDaysTimeBlocks(Source).Count - 1 do\r\n Add.Assign(TJvTFDaysTimeBlocks(Source).Items[I]);\r\n finally\r\n EndUpdate;\r\n end;\r\n end\r\n else\r\n inherited Assign(Source);\r\nend;\r\n\r\nfunction TJvTFDaysTimeBlocks.BlockByName(const BlockName: string): TJvTFDaysTimeBlock;\r\nbegin\r\n Result := FindBlock(BlockName);\r\n if not Assigned(Result) then\r\n raise EJvTFDaysError.CreateResFmt(@RsEATimeBlockWithTheNamesDoesNotExist,\r\n [BlockName]);\r\nend;\r\n\r\nfunction TJvTFDaysTimeBlocks.FindBlock(const BlockName: string): TJvTFDaysTimeBlock;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := nil;\r\n I := 0;\r\n while (I < Count) and not Assigned(Result) do\r\n begin\r\n if Items[I].Name = BlockName then\r\n Result := Items[I];\r\n Inc(I);\r\n end;\r\nend;\r\n\r\nfunction TJvTFDaysTimeBlocks.GetItem(Index: Integer): TJvTFDaysTimeBlock;\r\nbegin\r\n Result := TJvTFDaysTimeBlock(inherited GetItem(Index));\r\nend;\r\n\r\nfunction TJvTFDaysTimeBlocks.GetOwner: TPersistent;\r\nbegin\r\n Result := DaysControl;\r\nend;\r\n\r\nprocedure TJvTFDaysTimeBlocks.SetItem(Index: Integer;\r\n Value: TJvTFDaysTimeBlock);\r\nbegin\r\n inherited SetItem(Index, Value);\r\nend;\r\n\r\n//=== { TJvTFDaysBlockProps } ================================================\r\n\r\nconstructor TJvTFDaysBlockProps.Create(ADaysControl: TJvTFDays);\r\nbegin\r\n inherited Create;\r\n FBlockGran := 60;\r\n FDaysControl := ADaysControl;\r\n FBlockHdrWidth := 50;\r\n FBlockHdrAttr := TJvTFDaysHdrAttr.Create(DaysControl);\r\n FSelBlockHdrAttr := TJvTFDaysHdrAttr.Create(DaysControl);\r\n FOffTimeColor := clGray;\r\n FDataDivColor := clBlack;\r\n FSnapMove := True;\r\n FDrawOffTime := True;\r\n with FSelBlockHdrAttr do\r\n begin\r\n Color := clBtnFace;\r\n Font.Color := clBlack;\r\n FrameColor := clBlack;\r\n end;\r\nend;\r\n\r\ndestructor TJvTFDaysBlockProps.Destroy;\r\nbegin\r\n FBlockHdrAttr.Free;\r\n FSelBlockHdrAttr.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvTFDaysBlockProps.Assign(Source: TPersistent);\r\nbegin\r\n if Source is TJvTFDaysBlockProps then\r\n begin\r\n FBlockGran := TJvTFDaysBlockProps(Source).BlockGran;\r\n FDayStart := TJvTFDaysBlockProps(Source).DayStart;\r\n FBlockHdrWidth := TJvTFDaysBlockProps(Source).BlockHdrWidth;\r\n FBlockHdrAttr.Assign(TJvTFDaysBlockProps(Source).BlockHdrAttr);\r\n FSelBlockHdrAttr.Assign(TJvTFDaysBlockProps(Source).SelBlockHdrAttr);\r\n FOffTimeColor := TJvTFDaysBlockProps(Source).OffTimeColor;\r\n FDataDivColor := TJvTFDaysBlockProps(Source).DataDivColor;\r\n FSnapMove := TJvTFDaysBlockProps(Source).SnapMove;\r\n FDrawOffTime := TJvTFDaysBlockProps(Source).DrawOffTime;\r\n Change;\r\n end\r\n else\r\n inherited Assign(Source);\r\nend;\r\n\r\nprocedure TJvTFDaysBlockProps.Change;\r\nbegin\r\n if Assigned(DaysControl) then\r\n DaysControl.Invalidate;\r\nend;\r\n\r\nprocedure TJvTFDaysBlockProps.SetBlockGran(Value: Integer);\r\nbegin\r\n if csLoading in DaysControl.ComponentState then\r\n begin\r\n FBlockGran := Value;\r\n Exit;\r\n end;\r\n\r\n // Enforce minimum granularity of 1 min and max of 60 mins\r\n if Value < 1 then\r\n Value := 1\r\n else\r\n if Value > 60 then\r\n Value := 60;\r\n\r\n // Ensure that granularity is evenly divisible by an hour\r\n //while 60 mod Value <> 0 do\r\n //Dec(Value);\r\n Value := Value - 60 mod Value;\r\n\r\n if Value <> FBlockGran then\r\n begin\r\n DaysControl.EnsureBlockRules(DaysControl.Granularity, Value, DayStart);\r\n FBlockGran := Value;\r\n Change;\r\n end;\r\nend;\r\n\r\nprocedure TJvTFDaysBlockProps.SetBlockHdrAttr(Value: TJvTFDaysHdrAttr);\r\nbegin\r\n FBlockHdrAttr.Assign(Value);\r\n DaysControl.Invalidate;\r\nend;\r\n\r\nprocedure TJvTFDaysBlockProps.SetBlockHdrWidth(Value: Integer);\r\nbegin\r\n if Value <> FBlockHdrWidth then\r\n begin\r\n FBlockHdrWidth := Value;\r\n Change;\r\n end;\r\nend;\r\n\r\nprocedure TJvTFDaysBlockProps.SetDataDivColor(Value: TColor);\r\nbegin\r\n if Value <> FDataDivColor then\r\n begin\r\n FDataDivColor := Value;\r\n Change;\r\n end;\r\nend;\r\n\r\nprocedure TJvTFDaysBlockProps.SetDayStart(Value: TTime);\r\nbegin\r\n if Value <> FDayStart then\r\n begin\r\n DaysControl.EnsureBlockRules(DaysControl.Granularity, BlockGran, Value);\r\n FDayStart := Value;\r\n Change;\r\n end;\r\nend;\r\n\r\nprocedure TJvTFDaysBlockProps.SetDrawOffTime(Value: Boolean);\r\nbegin\r\n if Value <> FDrawOffTime then\r\n begin\r\n FDrawOffTime := Value;\r\n Change;\r\n end;\r\nend;\r\n\r\nprocedure TJvTFDaysBlockProps.SetOffTimeColor(Value: TColor);\r\nbegin\r\n if Value <> FOffTimeColor then\r\n begin\r\n FOffTimeColor := Value;\r\n Change;\r\n end;\r\nend;\r\n\r\nprocedure TJvTFDaysBlockProps.SetSelBlockHdrAttr(Value: TJvTFDaysHdrAttr);\r\nbegin\r\n FSelBlockHdrAttr.Assign(Value);\r\n DaysControl.Invalidate;\r\nend;\r\n\r\n{$ENDIF Jv_TIMEBLOCKS}\r\n\r\n//=== { TJvTFDaysApptDrawInfo } ==============================================\r\n\r\nconstructor TJvTFDaysApptDrawInfo.Create;\r\nbegin\r\n inherited Create;\r\n FFont := TFont.Create;\r\nend;\r\n\r\ndestructor TJvTFDaysApptDrawInfo.Destroy;\r\nbegin\r\n FFont.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvTFDaysApptDrawInfo.SetColor(Value: TColor);\r\nbegin\r\n FColor := Value;\r\nend;\r\n\r\nprocedure TJvTFDaysApptDrawInfo.SetFont(Value: TFont);\r\nbegin\r\n FFont.Assign(Value);\r\nend;\r\n\r\nprocedure TJvTFDaysApptDrawInfo.SetFrameColor(Value: TColor);\r\nbegin\r\n FFrameColor := Value;\r\nend;\r\n\r\nprocedure TJvTFDaysApptDrawInfo.SetFrameWidth(const Value: Integer);\r\nbegin\r\n FFrameWidth := Value;\r\nend;\r\n\r\nprocedure TJvTFDaysApptDrawInfo.SetVisible(Value: Boolean);\r\nbegin\r\n FVisible := Value;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvTFGantt.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvTFGantt.PAS, released on 2003-08-01.\r\n\r\nThe Initial Developer of the Original Code is Unlimited Intelligence Limited.\r\nPortions created by Unlimited Intelligence Limited are Copyright (C) 1999-2002 Unlimited Intelligence Limited.\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\nMike Kolter (original code)\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\n .CDK.REGLINK=JvTFGanttComponentsReg.pas\r\n Created 10/6/2001 6:14:06 PM\r\n Eagle Software CDK, Version 5.13 Rev. B\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvTFGantt.pas 13138 2011-10-26 23:17:50Z jfudickar $\r\n\r\nunit JvTFGantt;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n SysUtils, Classes, Windows, Messages, Graphics, Controls,\r\n Forms, Dialogs, StdCtrls,\r\n JvTFUtils, JvTFManager;\r\n\r\ntype\r\n TJvTFGanttScrollBar = class(TScrollBar)\r\n private\r\n procedure CMDesignHitTest(var Msg: TCMDesignHitTest); message CM_DESIGNHITTEST;\r\n protected\r\n procedure CreateWnd; override;\r\n function GetLargeChange: Integer; virtual;\r\n procedure SetLargeChange(Value: Integer); virtual;\r\n procedure UpdateRange; virtual;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n published\r\n property LargeChange: Integer read GetLargeChange write SetLargeChange default 1;\r\n end;\r\n\r\n TJvTFGanttScale = (ugsYear, ugsQuarter, ugsMonth, ugsWeek, ugsDay, ugsHour, ugsHalfHour, ugsQuarterHour, ugsMinute);\r\n\r\n TJvTFGanttScaleFormat = class(TPersistent)\r\n private\r\n FScale: TJvTFGanttScale;\r\n FFont: TFont;\r\n FFormat: string;\r\n FWidth: Integer;\r\n function GetFont: TFont;\r\n procedure SetFont(const Value: TFont);\r\n public\r\n constructor Create;\r\n destructor Destroy; override;\r\n published\r\n property Format: string read FFormat write FFormat;\r\n property Font: TFont read GetFont write SetFont;\r\n property Scale: TJvTFGanttScale read FScale write FScale;\r\n property Width: Integer read FWidth write FWidth;\r\n end;\r\n\r\n TJvTFGantt = class(TJvTFControl)\r\n private\r\n // property fields\r\n FMajorScale: TJvTFGanttScaleFormat;\r\n FMinorScale: TJvTFGanttScaleFormat;\r\n FHScrollBar: TJvTFGanttScrollBar;\r\n FVScrollBar: TJvTFGanttScrollBar;\r\n FVisibleScrollBars: TJvTFVisibleScrollBars;\r\n FCustomGlyphs: TBitmap;\r\n // Other class variables\r\n FPaintBuffer: TBitmap;\r\n procedure CMSysColorChange(var Msg: TMessage); message CM_SYSCOLORCHANGE;\r\n procedure CMDesignHitTest(var Msg: TCMDesignHitTest); message CM_DESIGNHITTEST;\r\n procedure CMFontChanged(var Msg: TMessage); message CM_FONTCHANGED;\r\n protected\r\n procedure DrawMajor(ACanvas: TCanvas); virtual;\r\n procedure DrawMinor(ACanvas: TCanvas); virtual;\r\n procedure SetVisibleScrollBars(Value: TJvTFVisibleScrollBars); virtual;\r\n function CalcHeaderHeight: Integer;\r\n procedure AlignScrollBars; virtual;\r\n function GetMinorScale: TJvTFGanttScaleFormat; virtual;\r\n procedure SetMinorScale(const Value: TJvTFGanttScaleFormat); virtual;\r\n function GetMajorScale: TJvTFGanttScaleFormat; virtual;\r\n procedure SetMajorScale(const Value: TJvTFGanttScaleFormat); virtual;\r\n procedure DrawClientArea; virtual;\r\n procedure DrawHeader(ACanvas: TCanvas); virtual;\r\n procedure Loaded; override;\r\n procedure Resize; override;\r\n procedure DrawCustomGlyph(SomeBitmap: TBitmap;\r\n TargetLeft, TargetTop, ImageIndex, NumGlyphsPerBitmap: Integer); dynamic;\r\n function ClientCursorPos: TPoint;\r\n function ValidMouseAtDesignTime: Boolean;\r\n procedure AdjustComponentHeightBasedOnFontChange; virtual;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n procedure PrepareAllBitmaps;\r\n procedure PrepareBitmaps(SomeGlyph: TBitmap; ResourceName: PChar); dynamic;\r\n procedure Paint; override;\r\n published\r\n property MajorScale: TJvTFGanttScaleFormat read GetMajorScale write SetMajorScale;\r\n property MinorScale: TJvTFGanttScaleFormat read GetMinorScale write SetMinorScale;\r\n property VisibleScrollBars: TJvTFVisibleScrollBars read FVisibleScrollBars write SetVisibleScrollBars\r\n default [vsbHorz, vsbVert];\r\n property Align;\r\n property Anchors;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvTFGantt.pas $';\r\n Revision: '$Revision: 13138 $';\r\n Date: '$Date: 2011-10-27 01:17:50 +0200 (jeu. 27 oct. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n JvJVCLUtils, JvResources;\r\n\r\n//=== { TJvTFGantt } =========================================================\r\n\r\nconstructor TJvTFGantt.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FPaintBuffer := TBitmap.Create;\r\n FCustomGlyphs := TBitmap.Create;\r\n FVisibleScrollBars := [vsbHorz, vsbVert];\r\n\r\n FVScrollBar := TJvTFGanttScrollBar.Create(Self);\r\n with FVScrollBar do\r\n begin\r\n Kind := sbVertical;\r\n TabStop := False;\r\n Anchors := [];\r\n Parent := Self;\r\n Visible := True;\r\n // OnScroll := ScrollBarScroll;\r\n end;\r\n\r\n FHScrollBar := TJvTFGanttScrollBar.Create(Self);\r\n with FHScrollBar do\r\n begin\r\n Kind := sbHorizontal;\r\n TabStop := False;\r\n Anchors := [];\r\n Parent := Self;\r\n Visible := True;\r\n // OnScroll := ScrollBarScroll;\r\n end;\r\n\r\n FMajorScale := TJvTFGanttScaleFormat.Create;\r\n FMajorScale.Scale := ugsMonth;\r\n FMajorScale.Format := 'mmmm';\r\n FMinorScale := TJvTFGanttScaleFormat.Create;\r\n FMinorScale.Scale := ugsDay;\r\n FMinorScale.Format := 'dd';\r\n\r\n PrepareAllBitmaps;\r\nend;\r\n\r\ndestructor TJvTFGantt.Destroy;\r\nbegin\r\n FPaintBuffer.Free;\r\n FMajorScale.Free;\r\n FMinorScale.Free;\r\n FVScrollBar.Free;\r\n FHScrollBar.Free;\r\n FCustomGlyphs.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvTFGantt.Loaded;\r\nbegin\r\n inherited Loaded;\r\n AlignScrollBars;\r\nend;\r\n\r\nprocedure TJvTFGantt.DrawMajor(ACanvas: TCanvas);\r\nvar\r\n Caption: string;\r\nbegin\r\n ACanvas.Font.Assign(FMajorScale.Font);\r\n Caption := RsThisIsTheMajorScale;\r\n ACanvas.TextOut((Width div 2) - (ACanvas.TextWidth(Caption) div 2), 2, Caption);\r\nend;\r\n\r\nprocedure TJvTFGantt.DrawMinor(ACanvas: TCanvas);\r\nvar\r\n Caption: string;\r\nbegin\r\n ACanvas.Font.Assign(FMinorScale.Font);\r\n Caption := RsThisIsTheMinorScale;\r\n ACanvas.TextOut((Width div 2) - (ACanvas.TextWidth(Caption) div 2),\r\n (CalcHeaderHeight div 2) + 2, Caption);\r\nend;\r\n\r\nfunction TJvTFGantt.CalcHeaderHeight: Integer;\r\nbegin\r\n Result := 0;\r\n\r\n Canvas.Font.Assign(FMajorScale.Font);\r\n Result := Result + CanvasMaxTextHeight(Canvas);\r\n\r\n Canvas.Font.Assign(FMinorScale.Font);\r\n Result := Result + CanvasMaxTextHeight(Canvas);\r\n\r\n Result := Result + 4;\r\nend;\r\n\r\nprocedure TJvTFGantt.Resize;\r\nbegin\r\n inherited Resize;\r\n AlignScrollBars;\r\nend;\r\n\r\nprocedure TJvTFGantt.SetMajorScale(const Value: TJvTFGanttScaleFormat);\r\nbegin\r\n FMajorScale.Assign(Value);\r\nend;\r\n\r\nfunction TJvTFGantt.GetMajorScale: TJvTFGanttScaleFormat;\r\nbegin\r\n Result := FMajorScale;\r\nend;\r\n\r\nprocedure TJvTFGantt.SetMinorScale(const Value: TJvTFGanttScaleFormat);\r\nbegin\r\n FMinorScale.Assign(Value);\r\nend;\r\n\r\nfunction TJvTFGantt.GetMinorScale: TJvTFGanttScaleFormat;\r\nbegin\r\n Result := FMinorScale;\r\nend;\r\n\r\nprocedure TJvTFGantt.SetVisibleScrollBars(Value: TJvTFVisibleScrollBars);\r\nbegin\r\n if Value <> FVisibleScrollBars then\r\n begin\r\n FVisibleScrollBars := Value;\r\n AlignScrollBars;\r\n FVScrollBar.Visible := vsbVert in FVisibleScrollBars;\r\n FHScrollBar.Visible := vsbHorz in FVisibleScrollBars;\r\n end;\r\nend;\r\n\r\nprocedure TJvTFGantt.AlignScrollBars;\r\nbegin\r\n // DO NOT INVALIDATE GRID IN THIS METHOD\r\n FVScrollBar.Left := ClientWidth - FVScrollBar.Width;\r\n FVScrollBar.Top := CalcHeaderHeight;\r\n FVScrollBar.Height := FHScrollBar.Top - FVScrollBar.Top;\r\n\r\n FHScrollBar.Top := ClientHeight - FHScrollBar.Height;\r\n FHScrollBar.Left := 0;\r\n FHScrollBar.Width := FVScrollBar.Left - FHScrollBar.Left;\r\n\r\n with FVScrollBar do\r\n if vsbHorz in VisibleScrollBars then\r\n Height := FHScrollBar.Top - Top\r\n else\r\n Height := Self.ClientHeight - Top;\r\n\r\n with FHScrollBar do\r\n if vsbVert in VisibleScrollBars then\r\n Width := FVScrollBar.Left - Left\r\n else\r\n Width := Self.ClientWidth - Left;\r\nend;\r\n\r\nprocedure TJvTFGantt.DrawClientArea;\r\nbegin\r\n // Draw the client area\r\nend;\r\n\r\nprocedure TJvTFGantt.DrawHeader(ACanvas: TCanvas);\r\nbegin\r\n DrawMajor(ACanvas);\r\n DrawMinor(ACanvas);\r\nend;\r\n\r\nprocedure TJvTFGantt.Paint;\r\nbegin\r\n inherited Paint;\r\n with FPaintBuffer do\r\n begin\r\n Width := ClientWidth;\r\n Height := ClientHeight;\r\n\r\n with Canvas do\r\n begin\r\n Brush.Color := Self.Color;\r\n FillRect(Rect(0, 0, Width, Height));\r\n end;\r\n\r\n DrawHeader(Canvas);\r\n DrawClientArea;\r\n end;\r\n if Enabled then\r\n Windows.BitBlt(Canvas.Handle, 0, 0, ClientWidth, ClientHeight, FPaintBuffer.Canvas.Handle, 0, 0, SRCCOPY)\r\n else\r\n Windows.DrawState(Canvas.Handle, 0, nil, FPaintBuffer.Handle, 0, 0, 0, 0, 0, DST_BITMAP or DSS_UNION or\r\n DSS_DISABLED);\r\n\r\nend;\r\n\r\n{ Draws SomeBitmap out to the canvas. Use ImageIndex = 0 and NumGlyphsPerBitmap = 1 to draw the entire image,\r\n or use other values to specify sub-glyphs within the image (for bitmaps that contain several same-sized\r\n images aligned side-to-side in a single row).\r\n\r\n TargetLeft and TargetTop are the left and top coordinates in the Canvas where you would like this image to appear.\r\n Use 0 and 0 to place the image in the top left corner.\r\n\r\n CDK: Call this method from an appropriate point in your code (e.g., a \"Paint\" or \"DrawItem\" override).\r\n\r\n Examples:\r\n\r\n // Draws entire image:\r\n DrawCustomGlyph(FCustomGlyphs, 0, 0, 0, 1);\r\n\r\n // Draws last image within FCustomGlyph (which contains four side-to-side images):\r\n DrawCustomGlyph(FCustomGlyphs, 0, 0, 3, 4);\r\n}\r\n\r\nprocedure TJvTFGantt.DrawCustomGlyph(SomeBitmap: TBitmap;\r\n TargetLeft, TargetTop, ImageIndex, NumGlyphsPerBitmap: Integer);\r\nvar\r\n LocalImageWidth: Integer;\r\n SourceRect, DestRect: TRect;\r\nbegin\r\n with Canvas do\r\n begin\r\n if NumGlyphsPerBitmap = 0 then\r\n NumGlyphsPerBitmap := 1;\r\n LocalImageWidth := SomeBitmap.Width div NumGlyphsPerBitmap;\r\n\r\n SourceRect.Left := ImageIndex * LocalImageWidth;\r\n SourceRect.Top := 0;\r\n SourceRect.Right := SourceRect.Left + LocalImageWidth;\r\n SourceRect.Bottom := SourceRect.Top + SomeBitmap.Height;\r\n\r\n DestRect.Left := TargetLeft;\r\n DestRect.Top := TargetTop;\r\n DestRect.Right := DestRect.Left + LocalImageWidth;\r\n DestRect.Bottom := DestRect.Top + SomeBitmap.Height;\r\n CopyRect(DestRect, SomeBitmap.Canvas, SourceRect);\r\n end;\r\nend;\r\n\r\n{ Prepares glyphs for display.\r\n The following colors in your glyphs will be replaced:\r\n\r\n Yellow with clBtnHighlight\r\n Silver with clBtnFace\r\n Gray with clBtnShadow\r\n White with clWindow\r\n Red with clWindowText\r\n\r\n CDK: Modify your glyphs so that they conform to the colors above, or alternatively\r\n modify the colors referenced in the code below.\r\n}\r\n\r\nprocedure TJvTFGantt.PrepareBitmaps(SomeGlyph: TBitmap; ResourceName: PChar);\r\nvar\r\n LocalBitmap: TBitmap;\r\n\r\n procedure ReplaceColors(SourceBmp, TargetBmp: TBitmap; SourceColor, TargetColor: TColor);\r\n begin\r\n TargetBmp.Canvas.Brush.Color := TargetColor;\r\n TargetBmp.Canvas.BrushCopy(SourceBmp.Canvas.ClipRect, SourceBmp,\r\n SourceBmp.Canvas.ClipRect, SourceColor);\r\n end;\r\n\r\nbegin\r\n LocalBitmap := TBitmap.Create;\r\n try\r\n LocalBitmap.LoadFromResourceName(HInstance, ResourceName);\r\n SomeGlyph.Width := LocalBitmap.Width;\r\n SomeGlyph.Height := LocalBitmap.Height;\r\n\r\n { Replace the following colors after loading bitmap:\r\n\r\n clYellow with clBtnHighlight\r\n clSilver with clBtnFace\r\n clGray with clBtnShadow\r\n clWhite with clWindow\r\n clRed with clWindowText\r\n }\r\n\r\n { Must call ReplaceColors an odd number of times, to ensure that final image ends up in SomeGlyph.\r\n As it turns out, we need to make exactly five replacements. Note that each subsequent call to\r\n ReplaceColors switches the order of parameters LocalBitmap and SomeGlyph. This is because\r\n we are copying the image back and forth, replacing individual colors with each copy. }\r\n\r\n ReplaceColors(LocalBitmap, SomeGlyph, clYellow, clBtnHighlight);\r\n ReplaceColors(SomeGlyph, LocalBitmap, clSilver, clBtnFace);\r\n ReplaceColors(LocalBitmap, SomeGlyph, clGray, clBtnShadow);\r\n ReplaceColors(SomeGlyph, LocalBitmap, clWhite, clWindow);\r\n ReplaceColors(LocalBitmap, SomeGlyph, clRed, clWindowText);\r\n finally\r\n LocalBitmap.Free;\r\n end;\r\nend;\r\n\r\nprocedure TJvTFGantt.PrepareAllBitmaps;\r\nbegin\r\n { CDK: Replace BITMAP_RESOURCE_NAME with the name of your bitmap resource. }\r\n// PrepareBitmaps(FCustomGlyphs, 'BITMAP_RESOURCE_NAME');\r\n { CDK: If you have other Glyphs that need loading/preparing, place additional\r\n calls to PrepareBitmaps here. }\r\nend;\r\n\r\nprocedure TJvTFGantt.CMSysColorChange(var Msg: TMessage);\r\nbegin\r\n inherited;\r\n PrepareAllBitmaps;\r\nend;\r\n\r\nfunction TJvTFGantt.ClientCursorPos: TPoint;\r\nbegin\r\n GetCursorPos(Result);\r\n Result := ScreenToClient(Result);\r\nend;\r\n\r\nfunction TJvTFGantt.ValidMouseAtDesignTime: Boolean;\r\nbegin\r\n Result := False;\r\nend;\r\n\r\nprocedure TJvTFGantt.CMDesignHitTest(var Msg: TCMDesignHitTest);\r\nbegin\r\n // True = Allow design-time mouse hits to get through if Alt key is down.\r\n Msg.Result := Ord(ValidMouseAtDesignTime);\r\nend;\r\n\r\nprocedure TJvTFGantt.CMFontChanged(var Msg: TMessage);\r\nbegin\r\n inherited;\r\n AdjustComponentHeightBasedOnFontChange;\r\nend;\r\n\r\nprocedure TJvTFGantt.AdjustComponentHeightBasedOnFontChange;\r\nbegin\r\n{ CDK: Add code to calculate the new height. If this is a composite component\r\n and you have any edit boxes, the edit box size will have already changed\r\n based on the new font (providing this method is called from a CM_FontChanged\r\n message handler).\r\n\r\n For example, your code might look like this:\r\n\r\n LockHeight := False;\r\n Height := Edit1.Height;\r\n Button1.Height := Height;\r\n LockHeight := True;\r\n}\r\nend;\r\n\r\n//=== { TJvTFGanttScaleFormat } ==============================================\r\n\r\nconstructor TJvTFGanttScaleFormat.Create;\r\nbegin\r\n // (rom) added inherited Create\r\n inherited Create;\r\n FFont := TFont.Create;\r\nend;\r\n\r\ndestructor TJvTFGanttScaleFormat.Destroy;\r\nbegin\r\n FFont.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJvTFGanttScaleFormat.GetFont: TFont;\r\nbegin\r\n Result := FFont;\r\nend;\r\n\r\nprocedure TJvTFGanttScaleFormat.SetFont(const Value: TFont);\r\nbegin\r\n FFont.Assign(Value);\r\nend;\r\n\r\n//=== { TJvTFGanttScrollBar } ================================================\r\n\r\nconstructor TJvTFGanttScrollBar.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n // If we set the csNoDesignVisible flag then visibility at design time\r\n // is controlled by the Visible property, which is exactly what we want.\r\n ControlStyle := ControlStyle + [csNoDesignVisible];\r\n ParentCtl3D := False;\r\n Ctl3D := False;\r\nend;\r\n\r\nprocedure TJvTFGanttScrollBar.CMDesignHitTest(var Msg: TCMDesignHitTest);\r\nbegin\r\n Msg.Result := 1;\r\nend;\r\n\r\nprocedure TJvTFGanttScrollBar.CreateWnd;\r\nbegin\r\n inherited CreateWnd;\r\n UpdateRange;\r\nend;\r\n\r\nfunction TJvTFGanttScrollBar.GetLargeChange: Integer;\r\nbegin\r\n Result := inherited LargeChange;\r\nend;\r\n\r\nprocedure TJvTFGanttScrollBar.SetLargeChange(Value: Integer);\r\nbegin\r\n inherited LargeChange := Value;\r\n UpdateRange;\r\nend;\r\n\r\nprocedure TJvTFGanttScrollBar.UpdateRange;\r\nvar\r\n Info: TScrollInfo;\r\nbegin\r\n FillChar(Info, SizeOf(Info), 0);\r\n with Info do\r\n begin\r\n cbSize := SizeOf(Info);\r\n fMask := SIF_PAGE;\r\n nPage := LargeChange;\r\n end;\r\n SetScrollInfo(Handle, SB_CTL, Info, True);\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvTFGlance.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvTFGlance.PAS, released on 2003-08-01.\r\n\r\nThe Initial Developer of the Original Code is Unlimited Intelligence Limited.\r\nPortions created by Unlimited Intelligence Limited are Copyright (C) 1999-2002 Unlimited Intelligence Limited.\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\nMike Kolter (original code)\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvTFGlance.pas 13138 2011-10-26 23:17:50Z jfudickar $\r\n\r\nunit JvTFGlance;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n SysUtils, Classes, Windows, Messages, Graphics, Controls, Forms, Dialogs, ImgList,\r\n {$IFDEF BCB}\r\n JvTypes, // TDate/TTime\r\n {$ENDIF BCB}\r\n JvTFUtils, JvTFManager;\r\n\r\ntype\r\n EJvTFGlanceError = class(Exception);\r\n EGlanceViewerError = class(EJvTFGlanceError);\r\n\r\n TJvTFGlanceCell = class;\r\n TJvTFGlanceCells = class;\r\n TJvTFCustomGlance = class;\r\n TJvTFGlanceViewer = class;\r\n TJvTFCellPics = class;\r\n\r\n TJvTFUpdateTitleEvent = procedure(Sender: TObject; var NewTitle: string) of object;\r\n TJvApptHintEvent = procedure(Sender: TObject; Appt: TJvTFAppt; var Handled: Boolean) of object;\r\n\r\n TJvTFCellPic = class(TCollectionItem)\r\n private\r\n FPicName: string;\r\n FPicIndex: Integer;\r\n FPicPoint: TPoint;\r\n FHints: TStringList;\r\n function GetHints: TStrings;\r\n procedure SetPicName(const Value: string);\r\n procedure SetPicIndex(Value: Integer);\r\n procedure SetHints(Value: TStrings);\r\n protected\r\n function GetDisplayName: string; override;\r\n procedure Change; virtual;\r\n procedure SetPicPoint(X, Y: Integer);\r\n public\r\n constructor Create(Collection: TCollection); override;\r\n destructor Destroy; override;\r\n procedure Assign(Source: TPersistent); override;\r\n function PicCollection: TJvTFCellPics;\r\n property PicPoint: TPoint read FPicPoint;\r\n published\r\n property PicName: string read FPicName write SetPicName;\r\n property PicIndex: Integer read FPicIndex write SetPicIndex;\r\n property Hints: TStrings read GetHints write SetHints;\r\n end;\r\n\r\n TJvTFCellPics = class(TCollection)\r\n private\r\n function GetItem(Index: Integer): TJvTFCellPic;\r\n procedure SetItem(Index: Integer; Value: TJvTFCellPic);\r\n protected\r\n FGlanceCell: TJvTFGlanceCell;\r\n function GetOwner: TPersistent; override;\r\n public\r\n constructor Create(AGlanceCell: TJvTFGlanceCell);\r\n function Add: TJvTFCellPic;\r\n property GlanceCell: TJvTFGlanceCell read FGlanceCell;\r\n procedure Assign(Source: TPersistent); override;\r\n property Items[Index: Integer]: TJvTFCellPic read GetItem write SetItem; default;\r\n function PicByName(const PicName: string): TJvTFCellPic;\r\n function GetPicIndex(const PicName: string): Integer;\r\n function AddPic(const PicName: string; PicIndex: Integer): TJvTFCellPic;\r\n end;\r\n\r\n TJvTFSplitOrientation = (soHorizontal, soVertical);\r\n\r\n TJvTFGlanceCell = class(TCollectionItem)\r\n private\r\n FColor: TColor;\r\n FCellDate: TDate;\r\n FColIndex: Integer;\r\n FRowIndex: Integer;\r\n FCellPics: TJvTFCellPics;\r\n FCanSelect: Boolean;\r\n FSchedules: TStringList;\r\n FTitleText: string;\r\n\r\n FSplitRef: TJvTFGlanceCell;\r\n FSplitOrientation: TJvTFSplitOrientation;\r\n FIsSubCell: Boolean;\r\n\r\n procedure SetColor(Value: TColor);\r\n procedure SetCellPics(Value: TJvTFCellPics);\r\n procedure SetCanSelect(Value: Boolean);\r\n function GetSchedule(Index: Integer): TJvTFSched;\r\n procedure SetSplitOrientation(Value: TJvTFSplitOrientation);\r\n function GetParentCell: TJvTFGlanceCell;\r\n function GetSubCell: TJvTFGlanceCell;\r\n protected\r\n // (rom) bad names\r\n FDestroying: Boolean;\r\n FCellCollection: TJvTFGlanceCells;\r\n function GetDisplayName: string; override;\r\n procedure InternalSetCellDate(Value: TDate);\r\n procedure SetCellDate(Value: TDate);\r\n procedure SetColIndex(Value: Integer);\r\n procedure SetRowIndex(Value: Integer);\r\n procedure Change; virtual;\r\n procedure SetTitleText(const Value: string);\r\n procedure Split;\r\n procedure Combine;\r\n public\r\n constructor Create(Collection: TCollection); override;\r\n destructor Destroy; override;\r\n procedure Assign(Source: TPersistent); override;\r\n property CellCollection: TJvTFGlanceCells read FCellCollection;\r\n\r\n function ScheduleCount: Integer;\r\n property Schedules[Index: Integer]: TJvTFSched read GetSchedule;\r\n function IndexOfSchedule(const SchedName: string; SchedDate: TDate): Integer;\r\n function IndexOfSchedObj(ASched: TJvTFSched): Integer;\r\n procedure CheckConnections;\r\n function IsSchedUsed(ASched: TJvTFSched): Boolean;\r\n property TitleText: string read FTitleText;\r\n property SplitOrientation: TJvTFSplitOrientation read FSplitOrientation\r\n write SetSplitOrientation default soHorizontal;\r\n property SplitRef: TJvTFGlanceCell read FSplitRef;\r\n function IsParent: Boolean;\r\n function IsSubCell: Boolean;\r\n function IsSplit: Boolean;\r\n property ParentCell: TJvTFGlanceCell read GetParentCell;\r\n property SubCell: TJvTFGlanceCell read GetSubCell;\r\n published\r\n property Color: TColor read FColor write SetColor;\r\n property CellDate: TDate read FCellDate write SetCellDate;\r\n property ColIndex: Integer read FColIndex;\r\n property RowIndex: Integer read FRowIndex;\r\n property CellPics: TJvTFCellPics read FCellPics write SetCellPics;\r\n property CanSelect: Boolean read FCanSelect write SetCanSelect;\r\n end;\r\n\r\n{ TODO: Clean up AddError, DestroyError, etc. in TJvTFGlanceCells and TJvTFGlanceCell }\r\n TJvTFGlanceCells = class(TCollection)\r\n private\r\n FGlanceControl: TJvTFCustomGlance;\r\n FDestroying: Boolean;\r\n function GetItem(Index: Integer): TJvTFGlanceCell;\r\n procedure SetItem(Index: Integer; Value: TJvTFGlanceCell);\r\n function GetCell(ColIndex, RowIndex: Integer): TJvTFGlanceCell;\r\n protected\r\n // (rom) bad names\r\n FAllowAdd: Boolean;\r\n FAllowDestroy: Boolean;\r\n FCheckingAllConnections: Boolean;\r\n FConfiguring: Boolean;\r\n function GetOwner: TPersistent; override;\r\n function InternalAdd: TJvTFGlanceCell;\r\n procedure AddError; dynamic;\r\n procedure DestroyError; dynamic;\r\n procedure EnsureCellCount;\r\n procedure EnsureCells;\r\n procedure ConfigCells; virtual;\r\n procedure Update(Item: TCollectionItem); override;\r\n public\r\n constructor Create(AGlanceControl: TJvTFCustomGlance);\r\n destructor Destroy; override;\r\n function Add: TJvTFGlanceCell;\r\n property GlanceControl: TJvTFCustomGlance read FGlanceControl;\r\n procedure Assign(Source: TPersistent); override;\r\n property Items[Index: Integer]: TJvTFGlanceCell read GetItem write SetItem; default;\r\n property AllowAdd: Boolean read FAllowAdd;\r\n property AllowDestroy: Boolean read FAllowDestroy;\r\n property Cells[ColIndex, RowIndex: Integer]: TJvTFGlanceCell read GetCell;\r\n procedure CheckConnections;\r\n property Configuring: Boolean read FConfiguring;\r\n procedure ReconfigCells;\r\n\r\n function IsSchedUsed(ASched: TJvTFSched): Boolean;\r\n end;\r\n\r\n TJvTFFrameStyle = (fs3DRaised, fs3DLowered, fsFlat, fsNone);\r\n TJvTFFrameAttr = class(TPersistent)\r\n private\r\n FStyle: TJvTFFrameStyle;\r\n FColor: TColor;\r\n FWidth: Integer;\r\n FControl: TJvTFControl;\r\n FOnChange: TNotifyEvent;\r\n procedure SetStyle(Value: TJvTFFrameStyle);\r\n procedure SetColor(Value: TColor);\r\n procedure SetWidth(Value: Integer);\r\n protected\r\n procedure Change; virtual;\r\n public\r\n constructor Create(AOwner: TJvTFControl);\r\n procedure Assign(Source: TPersistent); override;\r\n property Control: TJvTFControl read FControl;\r\n property OnChange: TNotifyEvent read FOnChange write FOnChange;\r\n published\r\n property Style: TJvTFFrameStyle read FStyle write SetStyle default fsFlat;\r\n property Color: TColor read FColor write SetColor default clBlack;\r\n property Width: Integer read FWidth write SetWidth default 1;\r\n end;\r\n\r\n TJvTFGlanceFrameAttr = class(TJvTFFrameAttr)\r\n private\r\n FGlanceControl: TJvTFCustomGlance;\r\n protected\r\n procedure Change; override;\r\n public\r\n constructor Create(AOwner: TJvTFCustomGlance);\r\n property GlanceControl: TJvTFCustomGlance read FGlanceControl;\r\n end;\r\n\r\n TJvTFTextAttr = class(TPersistent)\r\n private\r\n FFont: TFont;\r\n FOnChange: TNotifyEvent;\r\n FRotation: Integer;\r\n FAlignH: TAlignment;\r\n FAlignV: TJvTFVAlignment;\r\n procedure SetFont(Value: TFont);\r\n procedure SetRotation(Value: Integer);\r\n procedure SetAlignH(Value: TAlignment);\r\n procedure SetAlignV(Value: TJvTFVAlignment);\r\n protected\r\n procedure FontChange(Sender: TObject);\r\n procedure DoChange; virtual;\r\n public\r\n constructor Create;\r\n destructor Destroy; override;\r\n procedure Assign(Source: TPersistent); override;\r\n property OnChange: TNotifyEvent read FOnChange write FOnChange;\r\n published\r\n property Font: TFont read FFont write SetFont;\r\n property Rotation: Integer read FRotation write SetRotation default 0;\r\n property AlignH: TAlignment read FAlignH write SetAlignH default taLeftJustify;\r\n property AlignV: TJvTFVAlignment read FAlignV write SetAlignV default vaCenter;\r\n end;\r\n\r\n TJvTFGlanceTitlePicAttr = class(TPersistent)\r\n private\r\n FAlignH: TAlignment;\r\n FAlignV: TJvTFVAlignment;\r\n FOnChange: TNotifyEvent;\r\n procedure SetAlignH(Value: TAlignment);\r\n procedure SetAlignV(Value: TJvTFVAlignment);\r\n protected\r\n procedure DoChange;\r\n public\r\n constructor Create;\r\n procedure Assign(Source: TPersistent); override;\r\n property OnChange: TNotifyEvent read FOnChange write FOnChange;\r\n published\r\n property AlignH: TAlignment read FAlignH write SetAlignH default taLeftJustify;\r\n property AlignV: TJvTFVAlignment read FAlignV write SetAlignV default vaCenter;\r\n end;\r\n\r\n TJvTFTitleAlign = alTop..alRight;\r\n TJvTFGlanceTitleAttr = class(TPersistent)\r\n private\r\n FAlign: TJvTFTitleAlign;\r\n //FDayFormat: string;\r\n FColor: TColor;\r\n FHeight: Integer;\r\n FVisible: Boolean;\r\n FFrameAttr: TJvTFGlanceFrameAttr;\r\n FGlanceControl: TJvTFCustomGlance;\r\n FDayTxtAttr: TJvTFTextAttr;\r\n FPicAttr: TJvTFGlanceTitlePicAttr;\r\n procedure SetAlign(Value: TJvTFTitleAlign);\r\n //procedure SetDayFormat(Value: string);\r\n procedure SetColor(Value: TColor);\r\n procedure SetHeight(Value: Integer);\r\n procedure SetVisible(Value: Boolean);\r\n procedure SetFrameAttr(Value: TJvTFGlanceFrameAttr);\r\n procedure SetDayTxtAttr(Value: TJvTFTextAttr);\r\n procedure SetPicAttr(Value: TJvTFGlanceTitlePicAttr);\r\n protected\r\n procedure Change;\r\n procedure TxtAttrChange(Sender: TObject);\r\n procedure PicAttrChange(Sender: TObject);\r\n public\r\n constructor Create(AOwner: TJvTFCustomGlance);\r\n destructor Destroy; override;\r\n procedure Assign(Source: TPersistent); override;\r\n property GlanceControl: TJvTFCustomGlance read FGlanceControl;\r\n published\r\n property Align: TJvTFTitleAlign read FAlign write SetAlign default alTop;\r\n //property DayFormat: string read FDayFormat write SetDayFormat;\r\n property Color: TColor read FColor write SetColor default clBtnFace;\r\n property Height: Integer read FHeight write SetHeight default 20;\r\n property Visible: Boolean read FVisible write SetVisible default True;\r\n property FrameAttr: TJvTFGlanceFrameAttr read FFrameAttr write SetFrameAttr;\r\n property DayTxtAttr: TJvTFTextAttr read FDayTxtAttr write SetDayTxtAttr;\r\n property PicAttr: TJvTFGlanceTitlePicAttr read FPicAttr write SetPicAttr;\r\n end;\r\n\r\n TJvTFGlanceCellAttr = class(TPersistent)\r\n private\r\n FColor: TColor;\r\n FFrameAttr: TJvTFGlanceFrameAttr;\r\n FTitleAttr: TJvTFGlanceTitleAttr;\r\n FGlanceControl: TJvTFCustomGlance;\r\n FFont: TFont;\r\n FDrawBottomLine: Boolean;\r\n procedure SetColor(Value: TColor);\r\n procedure SetFrameAttr(Value: TJvTFGlanceFrameAttr);\r\n procedure SetTitleAttr(Value: TJvTFGlanceTitleAttr);\r\n procedure SetFont(Value: TFont);\r\n procedure SetDrawBottomLine(Value: Boolean);\r\n protected\r\n procedure FontChange(Sender: TObject);\r\n procedure Change;\r\n public\r\n constructor Create(AOwner: TJvTFCustomGlance);\r\n destructor Destroy; override;\r\n procedure Assign(Source: TPersistent); override;\r\n property GlanceControl: TJvTFCustomGlance read FGlanceControl;\r\n published\r\n property Color: TColor read FColor write SetColor default clWhite;\r\n property Font: TFont read FFont write SetFont;\r\n property FrameAttr: TJvTFGlanceFrameAttr read FFrameAttr write SetFrameAttr;\r\n property TitleAttr: TJvTFGlanceTitleAttr read FTitleAttr write SetTitleAttr;\r\n property DrawBottomLine: Boolean read FDrawBottomLine write SetDrawBottomLine;\r\n end;\r\n\r\n TJvTFGlanceTitle = class(TPersistent)\r\n private\r\n FColor: TColor;\r\n FHeight: Integer;\r\n FVisible: Boolean;\r\n FGlanceControl: TJvTFCustomGlance;\r\n FFrameAttr: TJvTFGlanceFrameAttr;\r\n FTxtAttr: TJvTFTextAttr;\r\n FOnChange: TNotifyEvent;\r\n procedure SetColor(Value: TColor);\r\n procedure SetHeight(Value: Integer);\r\n procedure SetVisible(Value: Boolean);\r\n procedure SetFrameAttr(Value: TJvTFGlanceFrameAttr);\r\n procedure SetTxtAttr(Value: TJvTFTextAttr);\r\n protected\r\n procedure Change;\r\n procedure TxtAttrChange(Sender: TObject);\r\n public\r\n constructor Create(AOwner: TJvTFCustomGlance);\r\n destructor Destroy; override;\r\n\r\n procedure Assign(Source: TPersistent); override;\r\n property GlanceControl: TJvTFCustomGlance read FGlanceControl;\r\n property OnChange: TNotifyEvent read FOnChange write FOnChange;\r\n published\r\n property Color: TColor read FColor write SetColor default clBtnFace;\r\n property FrameAttr: TJvTFGlanceFrameAttr read FFrameAttr write SetFrameAttr;\r\n property Height: Integer read FHeight write SetHeight default 40;\r\n property Visible: Boolean read FVisible write SetVisible default True;\r\n property TxtAttr: TJvTFTextAttr read FTxtAttr write SetTxtAttr;\r\n end;\r\n\r\n TJvTFGlanceMainTitle = class(TJvTFGlanceTitle)\r\n private\r\n FTitle: string;\r\n procedure SetTitle(const Value: string);\r\n public\r\n constructor Create(AOwner: TJvTFCustomGlance);\r\n procedure Assign(Source: TPersistent); override;\r\n published\r\n property Title: string read FTitle write SetTitle;\r\n end;\r\n\r\n TJvTFGlanceCoord = record\r\n Col: Integer;\r\n Row: Integer;\r\n Cell: TJvTFGlanceCell;\r\n CellX: Integer;\r\n CellY: Integer;\r\n AbsX: Integer;\r\n AbsY: Integer;\r\n DragAccept: Boolean;\r\n InCellTitle: Boolean;\r\n CellTitlePic: TJvTFCellPic;\r\n Appt: TJvTFAppt;\r\n end;\r\n\r\n TJvTFGlanceSelOrder = (soColMajor, soRowMajor, soRect);\r\n\r\n TJvTFGlanceSelList = class(TJvTFDateList)\r\n private\r\n FGlanceControl: TJvTFCustomGlance;\r\n public\r\n constructor Create(AOwner: TJvTFCustomGlance);\r\n property GlanceControl: TJvTFCustomGlance read FGlanceControl;\r\n end;\r\n\r\n TJvTFGlanceDrawTitleEvent = procedure(Sender: TObject; ACanvas: TCanvas;\r\n ARect: TRect) of object;\r\n TJvTFGlanceDrawCellEvent = procedure(Sender: TObject; ACanvas: TCanvas;\r\n ACellRect, ATitleRect, ABodyRect: TRect; Attr: TJvTFGlanceCellAttr;\r\n Cell: TJvTFGlanceCell) of object;\r\n\r\n TJvTFGlanceDropApptEvent = procedure(Sender: TObject; Appt: TJvTFAppt;\r\n var NewStartDate, NewEndDate: TDate; var Confirm: Boolean) of object;\r\n\r\n TJvTFUpdateCellTitleTextEvent = procedure(Sender: TObject; Cell: TJvTFGlanceCell;\r\n var NewText: string) of object;\r\n\r\n TJvTFCustomGlance = class(TJvTFControl)\r\n private\r\n FGapSize: Integer;\r\n FBorderStyle: TBorderStyle;\r\n //FStartOfWeek: Word;\r\n FStartOfWeek: TTFDayOfWeek;\r\n\r\n FRowCount: Integer;\r\n FColCount: Integer;\r\n FCells: TJvTFGlanceCells;\r\n FStartDate: TDate;\r\n FOriginDate: TDate;\r\n FCellPics: TCustomImageList;\r\n\r\n FTitleAttr: TJvTFGlanceMainTitle;\r\n FAllowCustomDates: Boolean;\r\n\r\n FCellAttr: TJvTFGlanceCellAttr;\r\n FSelCellAttr: TJvTFGlanceCellAttr;\r\n FSelOrder: TJvTFGlanceSelOrder;\r\n FSel: TJvTFGlanceSelList;\r\n FUpdatingSel: Boolean;\r\n\r\n FViewer: TJvTFGlanceViewer;\r\n\r\n FOnConfigCells: TNotifyEvent;\r\n FOnDrawTitle: TJvTFGlanceDrawTitleEvent;\r\n FOnDrawCell: TJvTFGlanceDrawCellEvent;\r\n FOnSelChanged: TNotifyEvent;\r\n FOnDropAppt: TJvTFGlanceDropApptEvent;\r\n FOnUpdateCellTitleText: TJvTFUpdateCellTitleTextEvent;\r\n\r\n FHintProps: TJvTFHintProps;\r\n\r\n FSchedNames: TStringList;\r\n\r\n FSelAppt: TJvTFAppt;\r\n FOnApptHint: TJvApptHintEvent;\r\n\r\n function GetSchedNames: TStrings;\r\n procedure SetBorderStyle(Value: TBorderStyle);\r\n\r\n procedure SetRowCount(Value: Integer);\r\n procedure SetCells(Value: TJvTFGlanceCells);\r\n procedure SetStartDate(Value: TDate);\r\n procedure SetOriginDate(Value: TDate);\r\n procedure SetTitleAttr(Value: TJvTFGlanceMainTitle);\r\n\r\n procedure SetCellAttr(Value: TJvTFGlanceCellAttr);\r\n procedure SetTFSelCellAttr(Value: TJvTFGlanceCellAttr);\r\n procedure SetViewer(Value: TJvTFGlanceViewer);\r\n procedure SetCellPics(Value: TCustomImageList);\r\n\r\n procedure SetHintProps(Value: TJvTFHintProps);\r\n procedure SetSchedNames(Value: TStrings);\r\n\r\n procedure SetSelAppt(Value: TJvTFAppt);\r\n protected\r\n // (rom) bad names\r\n FCreatingControl: Boolean;\r\n\r\n FPaintBuffer: TBitmap;\r\n FSelAnchor: TJvTFGlanceCell;\r\n FMouseCell: TJvTFGlanceCell;\r\n FImageChangeLink: TChangeLink;\r\n FHint: TJvTFHint;\r\n\r\n procedure SetColCount(Value: Integer); virtual;\r\n procedure SetStartOfWeek(Value: TTFDayOfWeek); virtual;\r\n\r\n procedure EnsureCol(Col: Integer);\r\n procedure EnsureRow(Row: Integer);\r\n procedure EnsureCell(ACell: TJvTFGlanceCell);\r\n function ValidCol(Col: Integer): Boolean;\r\n function ValidRow(Row: Integer): Boolean;\r\n function ValidCell(Col, Row: Integer): Boolean;\r\n\r\n procedure WMEraseBkgnd(var Msg: TMessage); message WM_ERASEBKGND;\r\n procedure CMCtl3DChanged(var Msg: TMessage); message CM_CTL3DCHANGED;\r\n procedure Loaded; override;\r\n procedure Notification(AComponent: TComponent; Operation: TOperation); override;\r\n procedure ImageListChange(Sender: TObject);\r\n procedure Notify(Sender: TObject; Code: TJvTFServNotifyCode); override;\r\n\r\n procedure GlanceTitleChange(Sender: TObject);\r\n\r\n // mouse routines\r\n procedure MouseDown(Button: TMouseButton; Shift: TShiftState;\r\n X, Y: Integer); override;\r\n procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;\r\n procedure MouseUp(Button: TMouseButton; Shift: TShiftState;\r\n X, Y: Integer); override;\r\n procedure DblClick; override;\r\n procedure Click; override;\r\n\r\n procedure CheckApptHint(Info: TJvTFGlanceCoord); virtual;\r\n\r\n // Drag/Drop routines\r\n procedure DoStartDrag(var DragObject: TDragObject); override;\r\n procedure DragOver(Source: TObject; X, Y: Integer; State: TDragState;\r\n var Accept: Boolean); override;\r\n procedure DoEndDrag(Target: TObject; X, Y: Integer); override;\r\n procedure DropAppt(DragInfo: TJvTFDragInfo; X, Y: Integer);\r\n\r\n // selection routines\r\n procedure UpdateSelection;\r\n procedure SelChange(Sender: TObject); virtual;\r\n property SelOrder: TJvTFGlanceSelOrder read FSelOrder write FSelOrder;\r\n procedure InternalSelectCell(ACell: TJvTFGlanceCell); virtual;\r\n procedure InternalDeselectCell(ACell: TJvTFGlanceCell); virtual;\r\n\r\n // Drawing routines\r\n procedure Paint; override;\r\n procedure DrawTitle(ACanvas: TCanvas); virtual;\r\n procedure DrawCells(ACanvas: TCanvas);\r\n procedure DrawCell(ACanvas: TCanvas; ACell: TJvTFGlanceCell);\r\n procedure DrawCellTitle(ACanvas: TCanvas; ATitleRect: TRect;\r\n Attr: TJvTFGlanceCellAttr; Cell: TJvTFGlanceCell);\r\n procedure DrawCellTitleFrame(ACanvas: TCanvas; ATitleRect: TRect;\r\n Attr: TJvTFGlanceCellAttr);\r\n procedure DrawCellFrame(ACanvas: TCanvas; ARect: TRect;\r\n Attr: TJvTFGlanceCellAttr; ACell: TJvTFGlanceCell);\r\n procedure Draw3DFrame(ACanvas: TCanvas; ARect: TRect; TLColor,\r\n BRColor: TColor);\r\n function PicsToDraw(ACell: TJvTFGlanceCell): Boolean;\r\n procedure GetPicsWidthHeight(ACell: TJvTFGlanceCell; PicBuffer: Integer;\r\n Horz: Boolean; var PicsWidth, PicsHeight: Integer);\r\n function ValidPicIndex(PicIndex: Integer): Boolean;\r\n\r\n // Drawing event dispatch methods\r\n procedure DoDrawTitle(ACanvas: TCanvas; ARect: TRect); virtual;\r\n procedure DoDrawCell(ACanvas: TCanvas; ACellRect, ATitleRect,\r\n ABodyRect: TRect; Attr: TJvTFGlanceCellAttr; Cell: TJvTFGlanceCell); virtual;\r\n\r\n procedure ConfigCells; virtual;\r\n procedure DoConfigCells; virtual;\r\n procedure SetCellDate(ACell: TJvTFGlanceCell; CellDate: TDate);\r\n procedure UpdateCellTitles;\r\n procedure UpdateCellTitleText(Cell: TJvTFGlanceCell);\r\n function GetCellTitleText(Cell: TJvTFGlanceCell): string; virtual;\r\n\r\n procedure CreateParams(var Params: TCreateParams); override;\r\n\r\n procedure SchedNamesChange(Sender: TObject);\r\n property SelAppt: TJvTFAppt read FSelAppt write SetSelAppt;\r\n property AllowCustomDates: Boolean read FAllowCustomDates write FAllowCustomDates;\r\n // configuration properties and events\r\n property RowCount: Integer read FRowCount write SetRowCount default 6;\r\n property ColCount: Integer read FColCount write SetColCount default 7;\r\n property StartDate: TDate read FStartDate write SetStartDate;\r\n property OriginDate: TDate read FOriginDate write SetOriginDate;\r\n property OnConfigCells: TNotifyEvent read FOnConfigCells write FOnConfigCells;\r\n property StartOfWeek: TTFDayOfWeek read FStartOfWeek write SetStartOfWeek default dowSunday;\r\n public\r\n function GetTFHintClass: TJvTFHintClass; dynamic;\r\n\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n procedure SetBounds(ALeft, ATop, AWidth, AHeight: Integer); override;\r\n\r\n procedure ReleaseSchedule(const SchedName: string; SchedDate: TDate); override;\r\n procedure SafeReleaseSchedule(ASched: TJvTFSched);\r\n\r\n function GetDataTop: Integer; dynamic;\r\n function GetDataLeft: Integer; dynamic;\r\n function GetDataWidth: Integer; dynamic;\r\n function GetDataHeight: Integer; dynamic;\r\n\r\n procedure SplitRects(Col, Row: Integer; var ParentRect, SubRect: TRect);\r\n function CellRect(ACell: TJvTFGlanceCell): TRect;\r\n function WholeCellRect(Col, Row: Integer): TRect;\r\n function TitleRect: TRect;\r\n function CellTitleRect(ACell: TJvTFGlanceCell): TRect;\r\n function CellBodyRect(ACell: TJvTFGlanceCell): TRect;\r\n function CalcCellTitleRect(ACell: TJvTFGlanceCell; Selected, Full: Boolean): TRect;\r\n function CalcCellBodyRect(ACell: TJvTFGlanceCell; Selected, Full: Boolean): TRect;\r\n function PtToCell(X, Y: Integer): TJvTFGlanceCoord;\r\n property Sel: TJvTFGlanceSelList read FSel write FSel;\r\n function DateIsSelected(ADate: TDate): Boolean;\r\n function CellIsSelected(ACell: TJvTFGlanceCell): Boolean;\r\n procedure SelectCell(ACell: TJvTFGlanceCell; Clear: Boolean = True); virtual;\r\n procedure DeselectCell(ACell: TJvTFGlanceCell); virtual;\r\n procedure BeginSelUpdate;\r\n procedure EndSelUpdate;\r\n property UpdatingSel: Boolean read FUpdatingSel;\r\n\r\n function GetCellAttr(ACell: TJvTFGlanceCell): TJvTFGlanceCellAttr; virtual;\r\n procedure CheckViewerApptHint(X, Y: Integer);\r\n\r\n procedure DragDrop(Source: TObject; X, Y: Integer); override;\r\n procedure ReconfigCells;\r\n procedure SplitCell(ACell: TJvTFGlanceCell);\r\n procedure CombineCell(ACell: TJvTFGlanceCell);\r\n published\r\n property Cells: TJvTFGlanceCells read FCells write SetCells;\r\n property BorderStyle: TBorderStyle read FBorderStyle write SetBorderStyle default bsSingle;\r\n property GapSize: Integer read FGapSize write FGapSize;\r\n property TitleAttr: TJvTFGlanceMainTitle read FTitleAttr write SetTitleAttr;\r\n property CellAttr: TJvTFGlanceCellAttr read FCellAttr write SetCellAttr;\r\n property SelCellAttr: TJvTFGlanceCellAttr read FSelCellAttr write SetTFSelCellAttr;\r\n property CellPics: TCustomImageList read FCellPics write SetCellPics;\r\n property Viewer: TJvTFGlanceViewer read FViewer write SetViewer;\r\n property HintProps: TJvTFHintProps read FHintProps write SetHintProps;\r\n property SchedNames: TStrings read GetSchedNames write SetSchedNames;\r\n property OnDrawTitle: TJvTFGlanceDrawTitleEvent read FOnDrawTitle write FOnDrawTitle;\r\n property OnDrawCell: TJvTFGlanceDrawCellEvent read FOnDrawCell write FOnDrawCell;\r\n property OnSelChanged: TNotifyEvent read FOnSelChanged write FOnSelChanged;\r\n property OnDropAppt: TJvTFGlanceDropApptEvent read FOnDropAppt write FOnDropAppt;\r\n property OnUpdateCellTitleText: TJvTFUpdateCellTitleTextEvent read FOnUpdateCellTitleText\r\n write FOnUpdateCellTitleText;\r\n property OnApptHint: TJvApptHintEvent read FOnApptHint write FOnApptHint;\r\n\r\n property DateFormat; // from TJvTFControl\r\n property TimeFormat; // from TJvTFControl\r\n\r\n property Align;\r\n property Color default clWindow;\r\n property ParentColor default False;\r\n property TabStop default True;\r\n property TabOrder;\r\n property Anchors;\r\n property Constraints;\r\n property DragKind;\r\n property DragCursor;\r\n property DragMode;\r\n property Enabled;\r\n property ParentShowHint;\r\n property PopupMenu;\r\n property ShowHint;\r\n property Visible;\r\n\r\n property OnClick;\r\n property OnDblClick;\r\n property OnDragDrop;\r\n property OnDragOver;\r\n property OnEndDrag;\r\n property OnEnter;\r\n property OnExit;\r\n property OnKeyDown;\r\n property OnKeyPress;\r\n property OnKeyUp;\r\n property OnMouseDown;\r\n property OnMouseMove;\r\n property OnMouseUp;\r\n property OnMouseWheelDown;\r\n property OnMouseWheelUp;\r\n property OnEndDock;\r\n property OnStartDock;\r\n property OnStartDrag;\r\n end;\r\n\r\n TJvTFGlanceViewer = class(TComponent)\r\n private\r\n FGlanceControl: TJvTFCustomGlance;\r\n FVisible: Boolean;\r\n FCell: TJvTFGlanceCell;\r\n FPhysicalCell: TJvTFGlanceCell;\r\n FRepeatGrouped: Boolean;\r\n FShowSchedNamesInHint: Boolean;\r\n FShowStartEndTimeInHint: Boolean;\r\n FOnApptHint: TJvApptHintEvent;\r\n procedure DoGlanceControlApptHint(Sender: TObject; Appt: TJvTFAppt; var Handled: Boolean);\r\n procedure SetShowSchedNamesInHint(const Value: Boolean);\r\n function GetRepeatAppt(Index: Integer): TJvTFAppt;\r\n function GetSchedule(Index: Integer): TJvTFSched;\r\n function GetDate: TDate;\r\n procedure SetRepeatGrouped(Value: Boolean);\r\n function GetDistinctAppt(Index: Integer): TJvTFAppt;\r\n function GetAppt(Index: Integer): TJvTFAppt;\r\n procedure SetShowStartEndTimeInHint(const Value: Boolean);\r\n protected\r\n FInPlaceEdit: Boolean;\r\n\r\n procedure SetInplaceEdit(const Value: Boolean); virtual;\r\n procedure SetVisible(Value: Boolean); virtual; abstract;\r\n procedure SetGlanceControl(Value: TJvTFCustomGlance); virtual;\r\n procedure ParentReconfig; virtual;\r\n procedure EnsureCol(ACol: Integer);\r\n procedure EnsureRow(ARow: Integer);\r\n procedure MouseAccel(X, Y: Integer); virtual;\r\n procedure GetDistinctAppts(ApptList: TStringList);\r\n\r\n procedure FinishEditAppt; virtual;\r\n function Editing: Boolean; virtual;\r\n function CanEdit: Boolean; virtual;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n procedure Notify(Sender: TObject; Code: TJvTFServNotifyCode); virtual;\r\n\r\n procedure SetTo(ACell: TJvTFGlanceCell); virtual;\r\n procedure MoveTo(ACell: TJvTFGlanceCell); virtual;\r\n procedure Refresh; virtual; abstract;\r\n procedure Realign; virtual; abstract;\r\n procedure PaintTo(ACanvas: TCanvas; ACell: TJvTFGlanceCell); virtual; abstract;\r\n\r\n property GlanceControl: TJvTFCustomGlance read FGlanceControl;\r\n property Cell: TJvTFGlanceCell read FCell;\r\n property PhysicalCell: TJvTFGlanceCell read FPhysicalCell;\r\n property Date: TDate read GetDate;\r\n property Visible: Boolean read FVisible write SetVisible;\r\n function CalcBoundsRect(ACell: TJvTFGlanceCell): TRect; virtual;\r\n\r\n function ApptCount: Integer;\r\n property Appts[Index: Integer]: TJvTFAppt read GetAppt;\r\n function ScheduleCount: Integer;\r\n property Schedules[Index: Integer]: TJvTFSched read GetSchedule;\r\n function GetApptAt(X, Y: Integer): TJvTFAppt; virtual;\r\n published\r\n property RepeatGrouped: Boolean read FRepeatGrouped write SetRepeatGrouped default True;\r\n property ShowSchedNamesInHint: Boolean read FShowSchedNamesInHint write SetShowSchedNamesInHint default True;\r\n property ShowStartEndTimeInHint: Boolean read FShowStartEndTimeInHint write SetShowStartEndTimeInHint default True;\r\n property InPlaceEdit: Boolean read FInPlaceEdit write SetInplaceEdit default True;\r\n property OnApptHint: TJvApptHintEvent read FOnApptHint write FOnApptHint;\r\n end;\r\n\r\n TJvTFGlance = class(TJvTFCustomGlance)\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n published\r\n property RowCount;\r\n property ColCount;\r\n property OriginDate;\r\n property OnConfigCells;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvTFGlance.pas $';\r\n Revision: '$Revision: 13138 $';\r\n Date: '$Date: 2011-10-27 01:17:50 +0200 (jeu. 27 oct. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n JvResources, JclStrings, JvJVCLUtils;\r\n\r\n//=== { TJvTFGlanceCell } ====================================================\r\n\r\nconstructor TJvTFGlanceCell.Create(Collection: TCollection);\r\nbegin\r\n inherited Create(Collection);\r\n FCellCollection := TJvTFGlanceCells(Collection);\r\n\r\n if Assigned(CellCollection) and not CellCollection.AllowAdd then\r\n CellCollection.AddError;\r\n\r\n FCellPics := TJvTFCellPics.Create(Self);\r\n FCanSelect := True;\r\n\r\n FSchedules := TStringList.Create;\r\n FSplitOrientation := soHorizontal;\r\nend;\r\n\r\ndestructor TJvTFGlanceCell.Destroy;\r\nvar\r\n DisconnectList: TStringList;\r\n I: Integer;\r\n ASched: TJvTFSched;\r\nbegin\r\n FDestroying := True;\r\n\r\n //if not CellCollection.AllowDestroy and not CellCollection.FDestroying then\r\n //CellCollection.DestroyError;\r\n\r\n if not IsSubCell then\r\n FSplitRef.Free\r\n else\r\n if Assigned(FSplitRef) then\r\n begin\r\n FSplitRef.FSplitRef := nil;\r\n FSplitRef := nil;\r\n end;\r\n\r\n FCellPics.Free;\r\n\r\n DisconnectList := TStringList.Create;\r\n try\r\n DisconnectList.Assign(FSchedules);\r\n FSchedules.Clear;\r\n\r\n for I := 0 to DisconnectList.Count - 1 do\r\n begin\r\n ASched := TJvTFSched(DisconnectList.Objects[I]);\r\n CellCollection.GlanceControl.ReleaseSchedule(ASched.SchedName,\r\n ASched.SchedDate);\r\n end;\r\n finally\r\n DisconnectList.Free;\r\n end;\r\n FSchedules.Free;\r\n\r\n inherited Destroy;\r\nend;\r\n\r\n{ TODO 3 -cMisc: Complete TGlance.Assign }\r\n\r\nprocedure TJvTFGlanceCell.Assign(Source: TPersistent);\r\nbegin\r\n if Source is TJvTFGlanceCell then\r\n begin\r\n end\r\n else\r\n inherited Assign(Source);\r\nend;\r\n\r\nprocedure TJvTFGlanceCell.Change;\r\nbegin\r\n if Assigned(CellCollection.GlanceControl) then\r\n CellCollection.GlanceControl.Invalidate;\r\nend;\r\n\r\nprocedure TJvTFGlanceCell.CheckConnections;\r\nvar\r\n GlanceControl: TJvTFCustomGlance;\r\n I: Integer;\r\n ASched: TJvTFSched;\r\n ASchedName, ASchedID: string;\r\nbegin\r\n GlanceControl := CellCollection.GlanceControl;\r\n\r\n if CellCollection.Configuring or not Assigned(GlanceControl.ScheduleManager) or\r\n (csLoading in GlanceControl.ComponentState) then\r\n Exit;\r\n\r\n // First, disconnect any schedules that shouldn't be connected\r\n I := 0;\r\n while I < FSchedules.Count do\r\n begin\r\n ASched := TJvTFSched(FSchedules.Objects[I]);\r\n if (GlanceControl.SchedNames.IndexOf(ASched.SchedName) = -1) or\r\n not EqualDates(ASched.SchedDate, CellDate) then\r\n begin\r\n FSchedules.Delete(I);\r\n GlanceControl.SafeReleaseSchedule(ASched);\r\n end\r\n else\r\n Inc(I);\r\n end;\r\n\r\n // Now connect any schedules that are not connected and should be\r\n for I := 0 to GlanceControl.SchedNames.Count - 1 do\r\n begin\r\n ASchedName := GlanceControl.SchedNames[I];\r\n ASchedID := TJvTFScheduleManager.GetScheduleID(ASchedName, CellDate);\r\n if FSchedules.IndexOf(ASchedID) = -1 then\r\n begin\r\n ASched := GlanceControl.RetrieveSchedule(ASchedName, CellDate);\r\n FSchedules.AddObject(ASchedID, ASched);\r\n end;\r\n end;\r\n\r\n if not CellCollection.FCheckingAllConnections then\r\n GlanceControl.ScheduleManager.ProcessBatches;\r\nend;\r\n\r\nprocedure TJvTFGlanceCell.Combine;\r\nvar\r\n LSubCell: TJvTFGlanceCell;\r\nbegin\r\n if IsSplit then\r\n begin\r\n LSubCell := SubCell;\r\n FSplitRef.FSplitRef := nil;\r\n FSplitRef := nil;\r\n CellCollection.ReconfigCells;\r\n if not FDestroying and (LSubCell <> Self) then\r\n LSubCell.Free;\r\n end;\r\nend;\r\n\r\nfunction TJvTFGlanceCell.GetDisplayName: string;\r\nvar\r\n Glance: TJvTFCustomGlance;\r\nbegin\r\n Glance := CellCollection.GlanceControl;\r\n if Assigned(Glance) then\r\n Result := FormatDateTime(Glance.DateFormat, CellDate)\r\n else\r\n Result := FormatDateTime('m/d/yyyy', CellDate);\r\nend;\r\n\r\nfunction TJvTFGlanceCell.GetParentCell: TJvTFGlanceCell;\r\nbegin\r\n if IsParent then\r\n Result := Self\r\n else\r\n Result := SplitRef;\r\nend;\r\n\r\nfunction TJvTFGlanceCell.GetSchedule(Index: Integer): TJvTFSched;\r\nbegin\r\n Result := TJvTFSched(FSchedules.Objects[Index]);\r\nend;\r\n\r\nfunction TJvTFGlanceCell.GetSubCell: TJvTFGlanceCell;\r\nbegin\r\n if IsSubCell then\r\n Result := Self\r\n else\r\n Result := SplitRef;\r\nend;\r\n\r\nfunction TJvTFGlanceCell.IndexOfSchedObj(ASched: TJvTFSched): Integer;\r\nbegin\r\n Result := FSchedules.IndexOfObject(ASched);\r\nend;\r\n\r\nfunction TJvTFGlanceCell.IndexOfSchedule(const SchedName: string; SchedDate: TDate): Integer;\r\nbegin\r\n Result := FSchedules.IndexOf(TJvTFScheduleManager.GetScheduleID(SchedName, SchedDate));\r\nend;\r\n\r\nprocedure TJvTFGlanceCell.InternalSetCellDate(Value: TDate);\r\nbegin\r\n if not EqualDates(Value, FCellDate) then\r\n begin\r\n FCellDate := Value;\r\n if not CellCollection.Configuring and\r\n not (csLoading in CellCollection.GlanceControl.ComponentState) then\r\n begin\r\n CellCollection.GlanceControl.UpdateCellTitleText(Self);\r\n CheckConnections;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJvTFGlanceCell.IsParent: Boolean;\r\nbegin\r\n Result := not IsSubCell;\r\nend;\r\n\r\nfunction TJvTFGlanceCell.IsSchedUsed(ASched: TJvTFSched): Boolean;\r\nbegin\r\n Result := IndexOfSchedObj(ASched) <> -1;\r\nend;\r\n\r\nfunction TJvTFGlanceCell.IsSplit: Boolean;\r\nbegin\r\n //Result := Assigned(ParentCell.SubCell);\r\n Result := Assigned(FSplitRef);\r\nend;\r\n\r\nfunction TJvTFGlanceCell.IsSubCell: Boolean;\r\nbegin\r\n Result := FIsSubCell;\r\nend;\r\n\r\nfunction TJvTFGlanceCell.ScheduleCount: Integer;\r\nbegin\r\n Result := FSchedules.Count;\r\nend;\r\n\r\nprocedure TJvTFGlanceCell.SetCanSelect(Value: Boolean);\r\nbegin\r\n FCanSelect := Value;\r\nend;\r\n\r\nprocedure TJvTFGlanceCell.SetCellDate(Value: TDate);\r\nbegin\r\n if Assigned(CellCollection.GlanceControl) and\r\n (not CellCollection.GlanceControl.AllowCustomDates and\r\n not (csLoading in CellCollection.GlanceControl.ComponentState)) then\r\n raise EJvTFGlanceError.CreateRes(@RsECellDatesCannotBeChanged);\r\n\r\n InternalSetCellDate(Value);\r\nend;\r\n\r\nprocedure TJvTFGlanceCell.SetCellPics(Value: TJvTFCellPics);\r\nbegin\r\n FCellPics.Assign(Value);\r\n Change;\r\nend;\r\n\r\nprocedure TJvTFGlanceCell.SetColIndex(Value: Integer);\r\nbegin\r\n FColIndex := Value;\r\nend;\r\n\r\nprocedure TJvTFGlanceCell.SetColor(Value: TColor);\r\nbegin\r\n if Value <> FColor then\r\n begin\r\n FColor := Value;\r\n Change;\r\n end;\r\nend;\r\n\r\nprocedure TJvTFGlanceCell.SetRowIndex(Value: Integer);\r\nbegin\r\n FRowIndex := Value;\r\nend;\r\n\r\n//=== { TJvTFGlanceCells } ===================================================\r\n\r\nconstructor TJvTFGlanceCells.Create(AGlanceControl: TJvTFCustomGlance);\r\nbegin\r\n inherited Create(TJvTFGlanceCell);\r\n FGlanceControl := AGlanceControl;\r\nend;\r\n\r\ndestructor TJvTFGlanceCells.Destroy;\r\nbegin\r\n FDestroying := True;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJvTFGlanceCells.Add: TJvTFGlanceCell;\r\nbegin\r\n Result := nil;\r\n AddError;\r\nend;\r\n\r\nprocedure TJvTFGlanceCells.AddError;\r\nbegin\r\n //if Assigned(GlanceControl) and not (csLoading in GlanceControl.ComponentState) then\r\n //raise EJvTFGlanceError.Create('Cells cannot be manually added');\r\nend;\r\n\r\nprocedure TJvTFGlanceCells.Assign(Source: TPersistent);\r\nvar\r\n I: Integer;\r\nbegin\r\n if Source is TJvTFGlanceCells then\r\n begin\r\n BeginUpdate;\r\n try\r\n FAllowDestroy := True;\r\n try\r\n Clear;\r\n finally\r\n FAllowDestroy := False;\r\n end;\r\n\r\n for I := 0 to TJvTFGlanceCells(Source).Count - 1 do\r\n InternalAdd.Assign(TJvTFGlanceCells(Source).Items[I]);\r\n finally\r\n EndUpdate;\r\n end;\r\n end\r\n else\r\n inherited Assign(Source);\r\nend;\r\n\r\nprocedure TJvTFGlanceCells.CheckConnections;\r\nvar\r\n I: Integer;\r\nbegin\r\n if (not Assigned(GlanceControl) or not Assigned(GlanceControl.ScheduleManager)) or\r\n (csLoading in GlanceControl.ComponentState) then\r\n Exit;\r\n\r\n FCheckingAllConnections := True;\r\n try\r\n {\r\n for I := 0 to Count - 1 do\r\n Items[I].CheckConnections;\r\n }\r\n for I := 0 to Count - 1 do\r\n with Items[I] do\r\n begin\r\n CheckConnections;\r\n if IsSplit then\r\n SubCell.CheckConnections;\r\n end;\r\n finally\r\n FCheckingAllConnections := False;\r\n GlanceControl.ScheduleManager.ProcessBatches;\r\n end;\r\nend;\r\n\r\nprocedure TJvTFGlanceCells.ConfigCells;\r\nbegin\r\n {\r\n if not Assigned(GlanceControl) or\r\n (csDesigning in GlanceControl.ComponentState) then\r\n Exit;\r\n }\r\n if Configuring then\r\n Exit;\r\n\r\n FConfiguring := True;\r\n try\r\n GlanceControl.ConfigCells;\r\n finally\r\n FConfiguring := False;\r\n end;\r\n\r\n // connect and release cells to/from schedule objects here.\r\n CheckConnections;\r\n\r\n if Assigned(GlanceControl.Viewer) then\r\n GlanceControl.Viewer.ParentReconfig;\r\nend;\r\n\r\nprocedure TJvTFGlanceCells.DestroyError;\r\nbegin\r\n //raise EJvTFGlanceError.Create('Cells cannot be manually destroyed');\r\nend;\r\n\r\nprocedure TJvTFGlanceCells.EnsureCellCount;\r\nvar\r\n I, DeltaCount: Integer;\r\nbegin\r\n {\r\n if not Assigned(GlanceControl) or\r\n (csDesigning in GlanceControl.ComponentState) then\r\n Exit;\r\n }\r\n if not Assigned(GlanceControl) then\r\n Exit;\r\n\r\n // Adjust the cell count\r\n DeltaCount := GlanceControl.RowCount * GlanceControl.ColCount - Count;\r\n\r\n for I := 1 to DeltaCount do\r\n InternalAdd;\r\n\r\n FAllowDestroy := True;\r\n try\r\n for I := -1 downto DeltaCount do\r\n Items[Count - 1].Free;\r\n finally\r\n FAllowDestroy := False;\r\n end;\r\nend;\r\n\r\nprocedure TJvTFGlanceCells.EnsureCells;\r\nvar\r\n I, J, K: Integer;\r\n SaveConfiguring: Boolean;\r\nbegin\r\n SaveConfiguring := Configuring;\r\n FConfiguring := True;\r\n try\r\n EnsureCellCount;\r\n\r\n K := 0;\r\n for I := 0 to GlanceControl.RowCount - 1 do\r\n for J := 0 to GlanceControl.ColCount - 1 do\r\n with Items[K] do\r\n begin\r\n SetColIndex(J);\r\n SetRowIndex(I);\r\n CellPics.Clear;\r\n Combine;\r\n Inc(K);\r\n end;\r\n finally\r\n FConfiguring := SaveConfiguring;\r\n end;\r\nend;\r\n\r\nfunction TJvTFGlanceCells.GetCell(ColIndex, RowIndex: Integer): TJvTFGlanceCell;\r\nvar\r\n AbsIndex: Integer;\r\n S: string;\r\nbegin\r\n Result := nil;\r\n if not Assigned(GlanceControl) then\r\n Exit;\r\n\r\n AbsIndex := RowIndex * GlanceControl.ColCount + ColIndex;\r\n if (AbsIndex >= 0) and (AbsIndex < Count) then\r\n begin\r\n Result := Items[AbsIndex];\r\n if ((Result.ColIndex <> ColIndex) or (Result.RowIndex <> RowIndex)) and not (csDesigning in GlanceControl.ComponentState) then\r\n begin\r\n S := '(' + IntToStr(Result.ColIndex) + ':' + IntToStr(ColIndex) + ') ' +\r\n '(' + IntToStr(Result.RowIndex) + ':' + IntToStr(RowIndex) + ')';\r\n raise EJvTFGlanceError.CreateResFmt(@RsECellMapHasBeenCorrupteds, [S]);\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJvTFGlanceCells.GetItem(Index: Integer): TJvTFGlanceCell;\r\nbegin\r\n Result := TJvTFGlanceCell(inherited GetItem(Index));\r\nend;\r\n\r\nfunction TJvTFGlanceCells.GetOwner: TPersistent;\r\nbegin\r\n Result := GlanceControl;\r\nend;\r\n\r\nfunction TJvTFGlanceCells.InternalAdd: TJvTFGlanceCell;\r\nbegin\r\n FAllowAdd := True;\r\n try\r\n Result := TJvTFGlanceCell(inherited Add);\r\n finally\r\n FAllowAdd := False;\r\n end;\r\nend;\r\n\r\nfunction TJvTFGlanceCells.IsSchedUsed(ASched: TJvTFSched): Boolean;\r\nvar\r\n I: Integer;\r\n ACell: TJvTFGlanceCell;\r\nbegin\r\n Result := False;\r\n I := 0;\r\n while (I < Count) and not Result do\r\n begin\r\n ACell := Items[I];\r\n\r\n if ACell.IsSchedUsed(ASched) then\r\n Result := True\r\n else\r\n if ACell.IsSplit and ACell.SubCell.IsSchedUsed(ASched) then\r\n Result := True\r\n else\r\n Inc(I);\r\n end;\r\nend;\r\n\r\nprocedure TJvTFGlanceCells.ReconfigCells;\r\nvar\r\n I: Integer;\r\nbegin\r\n if FConfiguring then\r\n Exit;\r\n\r\n FConfiguring := True;\r\n try\r\n for I := 0 to Count - 1 do\r\n with Items[I] do\r\n begin\r\n CellPics.Clear;\r\n if IsSplit then\r\n SubCell.CellPics.Clear;\r\n end;\r\n EnsureCells;\r\n GlanceControl.ConfigCells;\r\n finally\r\n FConfiguring := False;\r\n end;\r\n\r\n // connect and release cells to/from schedule objects here.\r\n CheckConnections;\r\n\r\n if Assigned(GlanceControl.Viewer) then\r\n GlanceControl.Viewer.ParentReconfig;\r\n GlanceControl.Invalidate;\r\nend;\r\n\r\nprocedure TJvTFGlanceCells.SetItem(Index: Integer; Value: TJvTFGlanceCell);\r\nbegin\r\n inherited SetItem(Index, Value);\r\nend;\r\n\r\nprocedure TJvTFGlanceCells.Update(Item: TCollectionItem);\r\nbegin\r\nend;\r\n\r\n//=== { TJvTFCustomGlance } ==================================================\r\n\r\nconstructor TJvTFCustomGlance.Create(AOwner: TComponent);\r\nbegin\r\n FCreatingControl := True;\r\n\r\n AllowCustomDates := False;\r\n inherited Create(AOwner);\r\n ControlStyle := ControlStyle + [csOpaque, csCaptureMouse, csClickEvents,\r\n csDoubleClicks];\r\n TabStop := True;\r\n Height := 300;\r\n Width := 300;\r\n\r\n //Color := clRed;\r\n FBorderStyle := bsSingle;\r\n FStartOfWeek := dowSunday;\r\n FGapSize := 0;\r\n FRowCount := 6;\r\n FColCount := 7;\r\n\r\n FPaintBuffer := TBitmap.Create;\r\n\r\n FSchedNames := TStringList.Create;\r\n FSchedNames.OnChange := SchedNamesChange;\r\n\r\n FCells := TJvTFGlanceCells.Create(Self);\r\n StartDate := Date;\r\n\r\n FTitleAttr := TJvTFGlanceMainTitle.Create(Self);\r\n\r\n// obones: Commented out, it goes against the default value in TJvTFGlanceMainTitle\r\n// FTitleAttr.Visible := False; // not visible by default. (Tim)\r\n FTitleAttr.OnChange := GlanceTitleChange;\r\n\r\n FCellAttr := TJvTFGlanceCellAttr.Create(Self);\r\n FCellAttr.TitleAttr.DayTxtAttr.AlignH := taLeftJustify;\r\n FSelCellAttr := TJvTFGlanceCellAttr.Create(Self);\r\n FSelCellAttr.TitleAttr.Color := clNavy;\r\n FSelCellAttr.TitleAttr.DayTxtAttr.Font.Color := clWhite;\r\n\r\n //FSelOrder := soColMajor;\r\n FSelOrder := soRowMajor;\r\n FSel := TJvTFGlanceSelList.Create(Self);\r\n FSel.OnChange := SelChange;\r\n\r\n FImageChangeLink := TChangeLink.Create;\r\n FImageChangeLink.OnChange := ImageListChange;\r\n\r\n FHintProps := TJvTFHintProps.Create(Self);\r\n //FHint := TJvTFHint.Create(Self);\r\n FHint := GetTFHintClass.Create(Self);\r\n FHint.RefProps := FHintProps;\r\n\r\n FCreatingControl := False;\r\n\r\n Cells.EnsureCells;\r\n Cells.ConfigCells;\r\nend;\r\n\r\ndestructor TJvTFCustomGlance.Destroy;\r\nbegin\r\n FCells.Free;\r\n FTitleAttr.Free;\r\n FCellAttr.Free;\r\n FSelCellAttr.Free;\r\n FSel.OnChange := nil;\r\n FSel.Free;\r\n FPaintBuffer.Free;\r\n FImageChangeLink.Free;\r\n\r\n FHint.Free;\r\n FHintProps.Free;\r\n\r\n FSchedNames.OnChange := nil;\r\n FSchedNames.Free;\r\n\r\n Viewer := nil;\r\n\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJvTFCustomGlance.CalcCellBodyRect(ACell: TJvTFGlanceCell;\r\n Selected, Full: Boolean): TRect;\r\nvar\r\n Attr: TJvTFGlanceCellAttr;\r\n Offset: Integer;\r\nbegin\r\n Windows.SubtractRect(Result, CellRect(ACell),\r\n CalcCellTitleRect(ACell, Selected, True));\r\n if not Full then\r\n begin\r\n if Selected then\r\n Attr := SelCellAttr\r\n else\r\n Attr := CellAttr;\r\n\r\n case Attr.FrameAttr.Style of\r\n fs3DRaised, fs3DLowered:\r\n Offset := 1;\r\n fsFlat:\r\n Offset := Attr.FrameAttr.Width;\r\n else\r\n Offset := 0;\r\n end;\r\n\r\n // Col 0 has frame running down left side of cell, whereas others\r\n // do not.\r\n if ACell.ColIndex = 0 then\r\n Inc(Result.Left, Offset);\r\n\r\n Dec(Result.Bottom, Offset);\r\n Dec(Result.Right, Offset);\r\n end;\r\nend;\r\n\r\nfunction TJvTFCustomGlance.CellIsSelected(ACell: TJvTFGlanceCell): Boolean;\r\nbegin\r\n Result := False;\r\n if Assigned(ACell) then\r\n Result := DateIsSelected(ACell.CellDate);\r\nend;\r\n\r\nfunction TJvTFCustomGlance.CellRect(ACell: TJvTFGlanceCell): TRect;\r\nvar\r\n ParentRect, SubRect: TRect;\r\nbegin\r\n Result := EmptyRect;\r\n if Assigned(ACell) then\r\n begin\r\n SplitRects(ACell.ColIndex, ACell.RowIndex, ParentRect, SubRect);\r\n if ACell.IsParent then\r\n Result := ParentRect\r\n else\r\n Result := SubRect;\r\n end;\r\nend;\r\n\r\nfunction TJvTFCustomGlance.CalcCellTitleRect(ACell: TJvTFGlanceCell;\r\n Selected, Full: Boolean): TRect;\r\nvar\r\n Attr: TJvTFGlanceCellAttr;\r\nbegin\r\n if Selected then\r\n Attr := SelCellAttr\r\n else\r\n Attr := CellAttr;\r\n\r\n if not Attr.TitleAttr.Visible then\r\n begin\r\n Result := Rect(0, 0, 0, 0);\r\n Exit;\r\n end\r\n else\r\n Result := CellRect(ACell);\r\n\r\n case Attr.TitleAttr.Align of\r\n alTop:\r\n Result.Bottom := Result.Top + Attr.TitleAttr.Height;\r\n alBottom:\r\n Result.Top := Result.Bottom - Attr.TitleAttr.Height;\r\n alLeft:\r\n Result.Right := Result.Left + Attr.TitleAttr.Height;\r\n alRight:\r\n Result.Left := Result.Right - Attr.TitleAttr.Height;\r\n end;\r\n\r\n if not Full then\r\n begin\r\n case Attr.TitleAttr.FrameAttr.Style of\r\n fs3DLowered, fs3DRaised:\r\n Windows.InflateRect(Result, -1, -1);\r\n fsFlat:\r\n case Attr.TitleAttr.Align of\r\n alTop:\r\n Dec(Result.Bottom, Attr.TitleAttr.FrameAttr.Width);\r\n alBottom:\r\n Inc(Result.Top, Attr.TitleAttr.FrameAttr.Width);\r\n alLeft:\r\n Dec(Result.Right, Attr.TitleAttr.FrameAttr.Width);\r\n alRight:\r\n Inc(Result.Left, Attr.TitleAttr.FrameAttr.Width);\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\n\r\n\r\nprocedure TJvTFCustomGlance.CMCtl3DChanged(var Msg: TMessage);\r\nbegin\r\n if FBorderStyle = bsSingle then\r\n RecreateWnd;\r\n inherited;\r\nend;\r\n\r\nprocedure TJvTFCustomGlance.CreateParams(var Params: TCreateParams);\r\nconst\r\n BorderStyles: array [TBorderStyle] of DWORD = (0, WS_BORDER);\r\nbegin\r\n inherited CreateParams(Params);\r\n with Params do\r\n begin\r\n Style := Style or BorderStyles[FBorderStyle] or WS_CLIPCHILDREN;\r\n if Ctl3D and (FBorderStyle = bsSingle) then\r\n begin\r\n Style := Style and not WS_BORDER;\r\n ExStyle := ExStyle or WS_EX_CLIENTEDGE;\r\n end;\r\n end;\r\nend;\r\n\r\n\r\n\r\nfunction TJvTFCustomGlance.DateIsSelected(ADate: TDate): Boolean;\r\nbegin\r\n Result := Sel.IndexOf(ADate) <> -1;\r\nend;\r\n\r\nprocedure TJvTFCustomGlance.DblClick;\r\nbegin\r\n inherited DblClick;\r\nend;\r\n\r\nprocedure TJvTFCustomGlance.Click;\r\nbegin\r\n inherited Click;\r\nend;\r\n\r\nprocedure TJvTFCustomGlance.DoConfigCells;\r\nbegin\r\n if Assigned(FOnConfigCells) then\r\n FOnConfigCells(Self);\r\nend;\r\n\r\nprocedure TJvTFCustomGlance.Draw3DFrame(ACanvas: TCanvas; ARect: TRect;\r\n TLColor, BRColor: TColor);\r\nvar\r\n OldPenColor: TColor;\r\nbegin\r\n with ACanvas do\r\n begin\r\n OldPenColor := Pen.Color;\r\n Pen.Color := TLColor;\r\n MoveTo(ARect.Left, ARect.Top);\r\n LineTo(ARect.Right, ARect.Top);\r\n MoveTo(ARect.Left, ARect.Top);\r\n LineTo(ARect.Left, ARect.Bottom);\r\n\r\n Pen.Color := BRColor;\r\n MoveTo(ARect.Right - 1, ARect.Top);\r\n LineTo(ARect.Right - 1, ARect.Bottom);\r\n MoveTo(ARect.Left, ARect.Bottom - 1);\r\n LineTo(ARect.Right, ARect.Bottom - 1);\r\n Pen.Color := OldPenColor;\r\n end;\r\nend;\r\n\r\nprocedure TJvTFCustomGlance.DrawCell(ACanvas: TCanvas; ACell: TJvTFGlanceCell);\r\nvar\r\n ARect, TitleRect, BodyRect: TRect;\r\n Attr: TJvTFGlanceCellAttr;\r\nbegin\r\n with ACanvas do\r\n begin\r\n ARect := CellRect(ACell);\r\n Attr := GetCellAttr(ACell);\r\n TitleRect := CellTitleRect(ACell);\r\n\r\n // calc the body rect\r\n Windows.SubtractRect(BodyRect, ARect, TitleRect);\r\n\r\n // draw the cell title\r\n if Attr.TitleAttr.Visible then\r\n DrawCellTitle(ACanvas, TitleRect, Attr, ACell);\r\n\r\n // shade the body of the cell\r\n Brush.Color := Attr.Color;\r\n FillRect(BodyRect);\r\n\r\n DrawCellFrame(ACanvas, ARect, Attr, ACell);\r\n\r\n // draw the cell data\r\n if Assigned(Viewer) and not (csDesigning in ComponentState) then\r\n Viewer.PaintTo(ACanvas, ACell);\r\n\r\n DoDrawCell(ACanvas, ARect, TitleRect, BodyRect, Attr, ACell);\r\n end;\r\nend;\r\n\r\nprocedure TJvTFCustomGlance.DrawCells(ACanvas: TCanvas);\r\nvar\r\n Col, Row: Integer;\r\n ACell: TJvTFGlanceCell;\r\nbegin\r\n for Col := 0 to ColCount - 1 do\r\n for Row := 0 to RowCount - 1 do\r\n begin\r\n ACell := Cells.Cells[Col, Row];\r\n DrawCell(ACanvas, ACell);\r\n if Assigned(ACell.SubCell) then\r\n DrawCell(ACanvas, ACell.SubCell);\r\n end;\r\nend;\r\n\r\nprocedure TJvTFCustomGlance.DrawTitle(ACanvas: TCanvas);\r\nvar\r\n ARect, TxtRect: TRect;\r\n Flags: UINT;\r\n PTxt: PChar;\r\n Txt: string;\r\n OldPen: TPen;\r\n OldBrush: TBrush;\r\n OldFont: TFont;\r\n I, LineBottom: Integer;\r\nbegin\r\n if not TitleAttr.Visible then\r\n Exit;\r\n\r\n ARect := TitleRect;\r\n TxtRect := ARect;\r\n Windows.InflateRect(TxtRect, -2, -2);\r\n\r\n with ACanvas do\r\n begin\r\n OldPen := TPen.Create;\r\n OldPen.Assign(Pen);\r\n OldBrush := TBrush.Create;\r\n OldBrush.Assign(Brush);\r\n OldFont := TFont.Create;\r\n OldFont.Assign(Font);\r\n\r\n Brush.Color := TitleAttr.Color;\r\n FillRect(ARect);\r\n\r\n //Pen.Color := clBlack;\r\n //MoveTo(ARect.Left, ARect.Bottom - 1);\r\n //LineTo(ARect.Right, ARect.Bottom - 1);\r\n\r\n case TitleAttr.FrameAttr.Style of\r\n fs3DRaised:\r\n Draw3DFrame(ACanvas, ARect, clBtnHighlight, clBtnShadow);\r\n fs3DLowered:\r\n Draw3DFrame(ACanvas, ARect, clBtnShadow, clBtnHighlight);\r\n {\r\n fs3DRaised, fs3DLowered :\r\n begin\r\n if TitleAttr.FrameAttr.Style = fs3DRaised then\r\n Pen.Color := clBtnHighlight\r\n else\r\n Pen.Color := clBtnShadow;\r\n\r\n MoveTo(ARect.Left, ARect.Top);\r\n LineTo(ARect.Right, ARect.Top);\r\n MoveTo(ARect.Left, ARect.Top);\r\n LineTo(ARect.Left, ARect.Bottom);\r\n\r\n if TitleAttr.FrameAttr.Style = fs3DRaised then\r\n Pen.Color := clBtnShadow\r\n else\r\n Pen.Color := clBtnHighlight;\r\n\r\n MoveTo(ARect.Right - 1, ARect.Top);\r\n LineTo(ARect.Right - 1, ARect.Bottom);\r\n MoveTo(ARect.Left, ARect.Bottom - 1);\r\n LineTo(ARect.Right, ARect.Bottom - 1);\r\n end;\r\n }\r\n fsFlat:\r\n begin\r\n Pen.Color := TitleAttr.FrameAttr.Color;\r\n {\r\n Pen.Width := TitleAttr.FrameAttr.Width;\r\n LineBottom := ARect.Bottom - Pen.Width div 2;\r\n if Odd(Pen.Width) then\r\n Dec(LineBottom);\r\n MoveTo(ARect.Left, LineBottom);\r\n LineTo(ARect.Right, LineBottom);\r\n }\r\n Pen.Width := 1;\r\n LineBottom := ARect.Bottom - 1;\r\n for I := 1 to TitleAttr.FrameAttr.Width do\r\n begin\r\n MoveTo(ARect.Left, LineBottom);\r\n LineTo(ARect.Right, LineBottom);\r\n Dec(LineBottom);\r\n end;\r\n end;\r\n end;\r\n\r\n //Font.Assign(TitleAttr.Font);\r\n Font.Assign(TitleAttr.TxtAttr.Font);\r\n Flags := DT_NOPREFIX or DT_CENTER or DT_SINGLELINE or DT_VCENTER;\r\n\r\n // Allocate length of Txt + 4 chars\r\n // (1 char for null terminator, 3 chars for ellipsis)\r\n Txt := TitleAttr.Title;\r\n PTxt := StrAlloc((Length(Txt) + 4) * SizeOf(Char));\r\n StrPCopy(PTxt, Txt);\r\n\r\n Windows.DrawText(ACanvas.Handle, PTxt, -1, TxtRect, Flags);\r\n StrDispose(PTxt);\r\n\r\n Pen.Assign(OldPen);\r\n Brush.Assign(OldBrush);\r\n Font.Assign(OldFont);\r\n OldPen.Free;\r\n OldBrush.Free;\r\n OldFont.Free;\r\n end;\r\n\r\n DoDrawTitle(ACanvas, ARect);\r\nend;\r\n\r\nprocedure TJvTFCustomGlance.EnsureCell(ACell: TJvTFGlanceCell);\r\nbegin\r\n if not Assigned(ACell) then\r\n raise EJvTFGlanceError.CreateRes(@RsECellObjectNotAssigned);\r\nend;\r\n\r\nprocedure TJvTFCustomGlance.EnsureCol(Col: Integer);\r\nbegin\r\n if (Col < 0) or (Col >= ColCount) then\r\n raise EJvTFGlanceError.CreateResFmt(@RsEInvalidColIndexd, [Col]);\r\nend;\r\n\r\nprocedure TJvTFCustomGlance.EnsureRow(Row: Integer);\r\nbegin\r\n if (Row < 0) or (Row >= RowCount) then\r\n raise EJvTFGlanceError.CreateResFmt(@RsEInvalidRowIndexd, [Row]);\r\nend;\r\n\r\nfunction TJvTFCustomGlance.GetCellAttr(ACell: TJvTFGlanceCell): TJvTFGlanceCellAttr;\r\nbegin\r\n if CellIsSelected(ACell) then\r\n Result := SelCellAttr\r\n else\r\n Result := CellAttr;\r\nend;\r\n\r\nfunction TJvTFCustomGlance.GetDataHeight: Integer;\r\nbegin\r\n Result := ClientHeight - GetDataTop;\r\nend;\r\n\r\nfunction TJvTFCustomGlance.GetDataLeft: Integer;\r\nbegin\r\n Result := 0;\r\nend;\r\n\r\nfunction TJvTFCustomGlance.GetDataTop: Integer;\r\nbegin\r\n Result := 0;\r\n if TitleAttr.Visible then\r\n Inc(Result, TitleAttr.Height);\r\nend;\r\n\r\nfunction TJvTFCustomGlance.GetDataWidth: Integer;\r\nbegin\r\n Result := ClientWidth - GetDataLeft;\r\nend;\r\n\r\nprocedure TJvTFCustomGlance.ImageListChange(Sender: TObject);\r\nbegin\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvTFCustomGlance.InternalSelectCell(ACell: TJvTFGlanceCell);\r\nbegin\r\n if Assigned(ACell) and ACell.CanSelect then\r\n Sel.Add(ACell.CellDate);\r\nend;\r\n\r\nprocedure TJvTFCustomGlance.Loaded;\r\nbegin\r\n inherited Loaded;\r\n Cells.EnsureCells;\r\n Cells.ConfigCells;\r\nend;\r\n\r\nprocedure TJvTFCustomGlance.MouseDown(Button: TMouseButton; Shift: TShiftState;\r\n X, Y: Integer);\r\nvar\r\n Info: TJvTFGlanceCoord;\r\nbegin\r\n inherited MouseDown(Button, Shift, X, Y);\r\n\r\n if Enabled then\r\n SetFocus;\r\n\r\n Info := PtToCell(X, Y);\r\n if Assigned(Viewer) and (Viewer.Cell <> Info.Cell) then\r\n Viewer.Visible := False;\r\n\r\n if ssLeft in Shift then\r\n begin\r\n if ssShift in Shift then\r\n begin\r\n // contiguous selection\r\n if Info.Cell.CanSelect then\r\n begin\r\n FMouseCell := Info.Cell;\r\n UpdateSelection;\r\n end;\r\n end\r\n else\r\n if ssCtrl in Shift then\r\n begin\r\n // non-contiguous selection\r\n if CellIsSelected(Info.Cell) then\r\n DeselectCell(Info.Cell)\r\n else\r\n SelectCell(Info.Cell, False);\r\n end\r\n else\r\n begin\r\n if Assigned(Info.Cell) and Info.Cell.CanSelect then\r\n SelectCell(Info.Cell, True);\r\n SelAppt := Info.Appt;\r\n if Assigned(Info.Appt) then\r\n BeginDrag(False);\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvTFCustomGlance.MouseMove(Shift: TShiftState; X, Y: Integer);\r\nvar\r\n //S: string;\r\n Info: TJvTFGlanceCoord;\r\n Hints: TStrings;\r\nbegin\r\n inherited MouseMove(Shift, X, Y);\r\n\r\n Info := PtToCell(X, Y);\r\n\r\n if not Focused and not (csDesigning in ComponentState) then\r\n Exit;\r\n\r\n if Assigned(Info.CellTitlePic) then\r\n Hints := Info.CellTitlePic.Hints\r\n else\r\n Hints := nil;\r\n\r\n FHint.MultiLineObjHint(Info.CellTitlePic, X, Y, Hints);\r\n {\r\n if Assigned(Info.CellTitlePic) then\r\n FHint.MultiLineObjHint(Info.CellTitlePic, X, Y, Info.CellTitlePic.Hints)\r\n else\r\n FHint.ReleaseHandle;\r\n }\r\n\r\n if (Info.Col > -1) and (Info.Row > -1) and not Info.InCellTitle then\r\n CheckApptHint(Info);\r\n\r\n // EXIT if we've already processed a mouse move for the current cell\r\n if Info.Cell = FMouseCell then\r\n Exit;\r\n\r\n FMouseCell := Info.Cell;\r\n\r\n // TESTING ONLY!!!\r\n //S := IntToStr(Info.Col) + ', ' + IntToStr(Info.Row);\r\n //GetParentForm(Self).Caption := S;\r\n\r\n if ssLeft in Shift then\r\n begin\r\n UpdateSelection;\r\n end;\r\nend;\r\n\r\nprocedure TJvTFCustomGlance.MouseUp(Button: TMouseButton; Shift: TShiftState;\r\n X, Y: Integer);\r\nvar\r\n Info: TJvTFGlanceCoord;\r\nbegin\r\n inherited MouseUp(Button, Shift, X, Y);\r\n\r\n if (Sel.Count = 1) and Assigned(Viewer) then\r\n begin\r\n Info := PtToCell(X, Y);\r\n Viewer.MoveTo(Info.Cell);\r\n Viewer.Visible := True;\r\n if not Info.InCellTitle then\r\n Viewer.MouseAccel(X, Y);\r\n end;\r\nend;\r\n\r\nprocedure TJvTFCustomGlance.Notification(AComponent: TComponent;\r\n Operation: TOperation);\r\nbegin\r\n inherited Notification(AComponent, Operation);\r\n if Operation = opRemove then\r\n if AComponent = Viewer then\r\n Viewer := nil\r\n else\r\n if AComponent = CellPics then\r\n CellPics := nil;\r\nend;\r\n\r\nprocedure TJvTFCustomGlance.Paint;\r\nbegin\r\n with FPaintBuffer do\r\n begin\r\n Height := ClientHeight;\r\n Width := ClientWidth;\r\n\r\n with Canvas do\r\n begin\r\n Brush.Color := Color;\r\n FillRect(ClientRect);\r\n end;\r\n\r\n DrawTitle(Canvas);\r\n DrawCells(Canvas);\r\n end;\r\n\r\n if Enabled then\r\n Windows.BitBlt(Canvas.Handle, 0, 0, ClientWidth, ClientHeight,\r\n FPaintBuffer.Canvas.Handle, 0, 0, SRCCOPY)\r\n else\r\n Windows.DrawState(Canvas.Handle, 0, nil, FPaintBuffer.Handle, 0,\r\n 0, 0, 0, 0, DST_BITMAP or DSS_UNION or DSS_DISABLED);\r\nend;\r\n\r\nfunction TJvTFCustomGlance.PtToCell(X, Y: Integer): TJvTFGlanceCoord;\r\nvar\r\n I, AdjX, AdjY, ViewerX, ViewerY: Integer;\r\n PicRect, ViewerBounds, ParentRect, SubRect: TRect;\r\n VCell: TJvTFGlanceCell;\r\n InSubRect: Boolean;\r\nbegin\r\n with Result do\r\n begin\r\n AbsX := X;\r\n AbsY := Y;\r\n\r\n AdjY := Y - GetDataTop;\r\n if AdjY < 0 then\r\n Row := -1\r\n else\r\n Row := GetDivNum(GetDataHeight, RowCount, AdjY);\r\n\r\n AdjX := X - GetDataLeft;\r\n if AdjX < 0 then\r\n Col := -1\r\n else\r\n Col := GetDivNum(GetDataWidth, ColCount, AdjX);\r\n\r\n if (Col >= 0) and (Row >= 0) then\r\n begin\r\n Cell := Cells.Cells[Col, Row];\r\n SplitRects(Col, Row, ParentRect, SubRect);\r\n InSubRect := Windows.PtInRect(SubRect, Point(X, Y));\r\n if InSubRect then\r\n Cell := Cell.SubCell;\r\n end\r\n else\r\n begin\r\n InSubRect := False;\r\n Cell := nil;\r\n end;\r\n\r\n if Col < 0 then\r\n CellX := X\r\n else\r\n if InSubRect and (Cell.SplitOrientation = soVertical) then\r\n CellX := X - SubRect.Left\r\n else\r\n CellX := X - ParentRect.Left;\r\n\r\n if Row < 0 then\r\n CellY := Y\r\n else\r\n if InSubRect and (Cell.SplitOrientation = soHorizontal) then\r\n CellY := Y - SubRect.Top\r\n else\r\n CellY := Y - ParentRect.Top;\r\n\r\n DragAccept := (Col > -1) and (Row > -1) and Assigned(ScheduleManager);\r\n\r\n CellTitlePic := nil;\r\n InCellTitle := Windows.PtInRect(CellTitleRect(Cell), Point(X, Y));\r\n if InCellTitle and Assigned(Cell) and Assigned(CellPics) then\r\n begin\r\n I := 0;\r\n while (I < Cell.CellPics.Count) and not Assigned(CellTitlePic) do\r\n begin\r\n PicRect.TopLeft := Cell.CellPics[I].PicPoint;\r\n PicRect.Right := PicRect.Left + CellPics.Width;\r\n PicRect.Bottom := PicRect.Top + CellPics.Height;\r\n if Windows.PtInRect(PicRect, Point(X, Y)) then\r\n CellTitlePic := Cell.CellPics[I]\r\n else\r\n Inc(I);\r\n end;\r\n end;\r\n\r\n Appt := nil;\r\n if Assigned(Viewer) and not InCellTitle and\r\n (Col > -1) and (Row > -1) then\r\n begin\r\n VCell := Viewer.Cell;\r\n\r\n Viewer.SetTo(Cell);\r\n ViewerBounds := Viewer.CalcBoundsRect(Cell);\r\n\r\n ViewerX := AbsX - ViewerBounds.Left;\r\n ViewerY := AbsY - ViewerBounds.Top;\r\n\r\n Appt := Viewer.GetApptAt(ViewerX, ViewerY);\r\n\r\n Viewer.SetTo(VCell);\r\n end;\r\n end;\r\nend;\r\n\r\n// Parameter Clear defaults to True for D4+ versions\r\n\r\nprocedure TJvTFCustomGlance.SelectCell(ACell: TJvTFGlanceCell; Clear: Boolean);\r\nbegin\r\n EnsureCell(ACell);\r\n\r\n BeginSelUpdate;\r\n try\r\n if Clear then\r\n begin\r\n Sel.Clear;\r\n FSelAnchor := ACell;\r\n end;\r\n InternalSelectCell(ACell);\r\n finally\r\n EndSelUpdate;\r\n end;\r\nend;\r\n\r\nprocedure TJvTFCustomGlance.SetBorderStyle(Value: TBorderStyle);\r\nbegin\r\n if FBorderStyle <> Value then\r\n begin\r\n FBorderStyle := Value;\r\n RecreateWnd;\r\n end;\r\nend;\r\n\r\nprocedure TJvTFCustomGlance.SetBounds(ALeft, ATop, AWidth, AHeight: Integer);\r\nbegin\r\n inherited SetBounds(ALeft, ATop, AWidth, AHeight);\r\n if Assigned(Viewer) then\r\n Viewer.Realign;\r\nend;\r\n\r\nprocedure TJvTFCustomGlance.SetCellAttr(Value: TJvTFGlanceCellAttr);\r\nbegin\r\n FCellAttr.Assign(Value);\r\nend;\r\n\r\nprocedure TJvTFCustomGlance.SetCellPics(Value: TCustomImageList);\r\nbegin\r\n if ReplaceImageListReference (Self, Value, FCellPics, FImageChangeLink) then\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvTFCustomGlance.SetCells(Value: TJvTFGlanceCells);\r\nbegin\r\n FCells.Assign(Value);\r\nend;\r\n\r\nprocedure TJvTFCustomGlance.SetColCount(Value: Integer);\r\nbegin\r\n Value := Greater(Value, 1);\r\n\r\n if Value <> FColCount then\r\n begin\r\n FColCount := Value;\r\n Cells.EnsureCells;\r\n Cells.ConfigCells;\r\n if Assigned(Viewer) then\r\n Viewer.Realign;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvTFCustomGlance.SetOriginDate(Value: TDate);\r\nbegin\r\n if not EqualDates(Value, FOriginDate) then\r\n begin\r\n FOriginDate := Value;\r\n StartOfWeek := BorlToDOW(DayOfWeek(Value));\r\n if not FCreatingControl and not (csLoading in ComponentState) then\r\n Cells.ConfigCells;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvTFCustomGlance.SetRowCount(Value: Integer);\r\nbegin\r\n Value := Greater(Value, 1);\r\n\r\n if Value <> FRowCount then\r\n begin\r\n FRowCount := Value;\r\n Cells.EnsureCells;\r\n Cells.ConfigCells;\r\n if Assigned(Viewer) then\r\n Viewer.Realign;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvTFCustomGlance.SetTFSelCellAttr(Value: TJvTFGlanceCellAttr);\r\nbegin\r\n FSelCellAttr.Assign(Value);\r\nend;\r\n\r\nprocedure TJvTFCustomGlance.SetStartDate(Value: TDate);\r\nbegin\r\n if not EqualDates(Value, FStartDate) then\r\n begin\r\n FStartDate := Value;\r\n while BorlToDOW(DayOfWeek(Value)) <> StartOfWeek do\r\n Value := Value - 1;\r\n OriginDate := Value;\r\n end;\r\nend;\r\n\r\nprocedure TJvTFCustomGlance.SetStartOfWeek(Value: TTFDayOfWeek);\r\nvar\r\n WorkDate: TDate;\r\nbegin\r\n if Value <> FStartOfWeek then\r\n begin\r\n FStartOfWeek := Value;\r\n\r\n WorkDate := StartDate;\r\n while BorlToDOW(DayOfWeek(WorkDate)) <> FStartOfWeek do\r\n WorkDate := WorkDate - 1;\r\n OriginDate := WorkDate;\r\n\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvTFCustomGlance.SetTitleAttr(Value: TJvTFGlanceMainTitle);\r\nbegin\r\n FTitleAttr.Assign(Value);\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvTFCustomGlance.SetViewer(Value: TJvTFGlanceViewer);\r\nbegin\r\n if Value <> FViewer then\r\n begin\r\n if Assigned(FViewer) then\r\n FViewer.Notify(Self, sncDisconnectControl);\r\n if Assigned(Value) then\r\n Value.Notify(Self, sncConnectControl);\r\n ReplaceComponentReference(Self, Value, TComponent(FViewer));\r\n if Assigned(FViewer) then\r\n begin\r\n FViewer.MoveTo(Cells.Cells[0, 0]);\r\n FViewer.Visible := (csDesigning in ComponentState);\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJvTFCustomGlance.TitleRect: TRect;\r\nbegin\r\n Result := Rect(0, 0, ClientWidth, 0);\r\n if TitleAttr.Visible then\r\n Result.Bottom := TitleAttr.Height;\r\nend;\r\n\r\nprocedure TJvTFCustomGlance.UpdateSelection;\r\nvar\r\n Col, Row, StartCol, EndCol, StartRow, EndRow: Integer;\r\n ACell, ACell1, ACell2: TJvTFGlanceCell;\r\nbegin\r\n BeginSelUpdate;\r\n\r\n try\r\n if not Assigned(FMouseCell) or not Assigned(FSelAnchor) then\r\n Exit;\r\n\r\n Sel.Clear;\r\n if SelOrder = soColMajor then\r\n begin\r\n // handle the first sel col\r\n if FMouseCell.ColIndex < FSelAnchor.ColIndex then // sel end is left of anchor\r\n begin\r\n for Row := 0 to FSelAnchor.RowIndex do\r\n begin\r\n ACell := Cells.Cells[FSelAnchor.ColIndex, Row];\r\n InternalSelectCell(ACell);\r\n InternalSelectCell(ACell.SubCell);\r\n end;\r\n if not FSelAnchor.IsSubCell then\r\n InternalDeselectCell(FSelAnchor.SubCell);\r\n end\r\n else\r\n if FMouseCell.ColIndex = FSelAnchor.ColIndex then // sel end is in same col as anchor\r\n begin\r\n StartRow := Lesser(FSelAnchor.RowIndex, FMouseCell.RowIndex);\r\n EndRow := Greater(FSelAnchor.RowIndex, FMouseCell.RowIndex);\r\n for Row := StartRow to EndRow do\r\n begin\r\n ACell := Cells.Cells[FSelAnchor.ColIndex, Row];\r\n InternalSelectCell(ACell);\r\n InternalSelectCell(ACell.SubCell);\r\n end;\r\n\r\n if (FMouseCell.RowIndex < FSelAnchor.RowIndex) then\r\n begin\r\n if FMouseCell.IsSubCell then\r\n InternalDeselectCell(FMouseCell.ParentCell);\r\n if FSelAnchor.IsParent then\r\n InternalDeselectCell(FSelAnchor.SubCell);\r\n end\r\n else\r\n if FMouseCell = FSelAnchor then\r\n InternalDeselectCell(FMouseCell.SplitRef)\r\n else\r\n if FMouseCell.RowIndex > FSelAnchor.RowIndex then\r\n begin\r\n if FMouseCell.IsParent then\r\n InternalDeselectCell(FMouseCell.SubCell);\r\n if FSelAnchor.IsSubCell then\r\n InternalDeselectCell(FSelAnchor.ParentCell);\r\n end;\r\n end\r\n else // sel end is to the right of anchor\r\n begin\r\n InternalSelectCell(FSelAnchor);\r\n if FSelAnchor.IsParent then\r\n InternalSelectCell(FSelAnchor.SubCell);\r\n\r\n for Row := FSelAnchor.RowIndex + 1 to RowCount - 1 do\r\n begin\r\n InternalSelectCell(FSelAnchor.ParentCell);\r\n InternalSelectCell(FSelAnchor.SubCell);\r\n end;\r\n end;\r\n\r\n // handle any intermediate cols (all rows in col will be selected)\r\n StartCol := Lesser(FSelAnchor.ColIndex, FMouseCell.ColIndex);\r\n EndCol := Greater(FSelAnchor.ColIndex, FMouseCell.ColIndex);\r\n for Col := StartCol + 1 to EndCol - 1 do\r\n for Row := 0 to RowCount - 1 do\r\n begin\r\n ACell := Cells.Cells[Col, Row];\r\n InternalSelectCell(ACell);\r\n InternalSelectCell(ACell.SubCell);\r\n end;\r\n\r\n // handle the last sel col\r\n if FMouseCell.ColIndex < FSelAnchor.ColIndex then\r\n begin\r\n InternalSelectCell(FMouseCell);\r\n if FMouseCell.IsParent then\r\n InternalSelectCell(FMouseCell.SubCell);\r\n\r\n for Row := FMouseCell.RowIndex + 1 to RowCount - 1 do\r\n begin\r\n ACell := Cells.Cells[FMouseCell.ColIndex, Row];\r\n InternalSelectCell(ACell);\r\n InternalSelectCell(ACell.SubCell);\r\n end;\r\n end\r\n else\r\n if FMouseCell.ColIndex > FSelAnchor.ColIndex then\r\n begin\r\n for Row := 0 to FMouseCell.RowIndex do\r\n begin\r\n ACell := Cells.Cells[FMouseCell.ColIndex, Row];\r\n InternalSelectCell(ACell);\r\n InternalSelectCell(ACell.SubCell);\r\n end;\r\n if FMouseCell.IsParent then\r\n InternalDeselectCell(FMouseCell.SubCell);\r\n end\r\n end\r\n else\r\n if SelOrder = soRowMajor then\r\n begin\r\n // handle the first sel row\r\n if FMouseCell.RowIndex < FSelAnchor.RowIndex then\r\n begin\r\n for Col := 0 to FSelAnchor.ColIndex do\r\n begin\r\n ACell := Cells.Cells[Col, FSelAnchor.RowIndex];\r\n InternalSelectCell(ACell);\r\n InternalSelectCell(ACell.SubCell);\r\n end;\r\n if FSelAnchor.IsParent then\r\n InternalDeselectCell(FSelAnchor.SubCell);\r\n end\r\n else\r\n if FMouseCell.RowIndex = FSelAnchor.RowIndex then\r\n begin\r\n if FMouseCell = FSelAnchor then\r\n InternalSelectCell(FMouseCell)\r\n else\r\n begin\r\n if FMouseCell.ColIndex < FSelAnchor.ColIndex then\r\n begin\r\n ACell1 := FMouseCell;\r\n ACell2 := FSelAnchor;\r\n end\r\n else\r\n begin\r\n ACell1 := FSelAnchor;\r\n ACell2 := FMouseCell;\r\n end;\r\n\r\n InternalSelectCell(ACell1);\r\n if ACell1.IsParent then\r\n InternalSelectCell(ACell1.SubCell);\r\n\r\n InternalSelectCell(ACell2);\r\n if ACell2.IsSubCell then\r\n InternalSelectCell(ACell2.ParentCell);\r\n\r\n for Col := ACell1.ColIndex + 1 to ACell2.ColIndex - 1 do\r\n begin\r\n ACell := Cells.Cells[Col, FMouseCell.RowIndex];\r\n InternalSelectCell(ACell);\r\n InternalSelectCell(ACell.SubCell);\r\n end;\r\n end;\r\n end\r\n else\r\n begin\r\n InternalSelectCell(FSelAnchor);\r\n if FSelAnchor.IsParent then\r\n InternalSelectCell(FSelAnchor.SubCell);\r\n\r\n for Col := FSelAnchor.ColIndex + 1 to ColCount - 1 do\r\n begin\r\n ACell := Cells.Cells[Col, FSelAnchor.RowIndex];\r\n InternalSelectCell(ACell);\r\n InternalSelectCell(ACell.SubCell);\r\n end;\r\n end;\r\n\r\n // handle any intermediate rows (all cols in row will be selected)\r\n StartRow := Lesser(FSelAnchor.RowIndex, FMouseCell.RowIndex);\r\n EndRow := Greater(FSelAnchor.RowIndex, FMouseCell.RowIndex);\r\n for Col := 0 to ColCount - 1 do\r\n for Row := StartRow + 1 to EndRow - 1 do\r\n begin\r\n ACell := Cells.Cells[Col, Row];\r\n InternalSelectCell(ACell);\r\n InternalSelectCell(ACell.SubCell);\r\n end;\r\n\r\n // handle last sel row\r\n if FMouseCell.RowIndex < FSelAnchor.RowIndex then\r\n begin\r\n InternalSelectCell(FMouseCell);\r\n if FMouseCell.IsParent then\r\n InternalSelectCell(FMouseCell.SubCell);\r\n\r\n for Col := FMouseCell.ColIndex + 1 to ColCount - 1 do\r\n begin\r\n ACell := Cells.Cells[Col, FMouseCell.RowIndex];\r\n InternalSelectCell(ACell);\r\n InternalSelectCell(ACell.SubCell);\r\n end;\r\n end\r\n else\r\n if FMouseCell.RowIndex > FSelAnchor.RowIndex then\r\n begin\r\n for Col := 0 to FMouseCell.ColIndex do\r\n begin\r\n ACell := Cells.Cells[Col, FMouseCell.RowIndex];\r\n InternalSelectCell(ACell);\r\n InternalSelectCell(ACell.SubCell);\r\n end;\r\n if FMouseCell.IsParent then\r\n InternalDeselectCell(FMouseCell.SubCell);\r\n end\r\n end\r\n else\r\n begin\r\n StartRow := Lesser(FSelAnchor.RowIndex, FMouseCell.RowIndex);\r\n EndRow := Greater(FSelAnchor.RowIndex, FMouseCell.RowIndex);\r\n StartCol := Lesser(FSelAnchor.ColIndex, FMouseCell.ColIndex);\r\n EndCol := Greater(FSelAnchor.ColIndex, FMouseCell.ColIndex);\r\n\r\n // select all cells and subcells in square\r\n for Col := StartCol to EndCol do\r\n for Row := StartRow to EndRow do\r\n begin\r\n ACell := Cells.Cells[Col, Row];\r\n InternalSelectCell(ACell);\r\n InternalSelectCell(ACell.SubCell);\r\n end;\r\n\r\n // for direction (anchor --> mouse)\r\n // W, NW, N, NE: if anchor is parent, anchor subcell is NOT selected and\r\n // if mouse is subcell, mouse parent is NOT selected\r\n if (FMouseCell.RowIndex < FSelAnchor.RowIndex) or // all northerly dir\r\n ((FMouseCell.RowIndex = FSelAnchor.RowIndex) and\r\n (FMouseCell.ColIndex < FSelAnchor.ColIndex)) then // west\r\n begin\r\n if FSelAnchor.IsParent then\r\n InternalDeselectCell(FSelAnchor.SubCell);\r\n\r\n if FMouseCell.IsSubCell then\r\n InternalDeselectCell(FMouseCell.ParentCell);\r\n end\r\n // for direction E, SE, S, SW:\r\n // if anchor is subcell, anchor parent is NOT selected and\r\n // if mouse is parent, mouse subcell is NOT selected\r\n else\r\n begin\r\n if FSelAnchor.IsSubCell then\r\n InternalDeselectCell(FSelAnchor.ParentCell);\r\n\r\n if FMouseCell.IsParent then\r\n InternalDeselectCell(FMouseCell.SubCell);\r\n end;\r\n end;\r\n finally\r\n EndSelUpdate;\r\n end;\r\nend;\r\n\r\nfunction TJvTFCustomGlance.ValidCell(Col, Row: Integer): Boolean;\r\nbegin\r\n Result := False;\r\n if ValidCol(Col) and ValidRow(Row) then\r\n Result := Assigned(Cells.Cells[Col, Row]);\r\nend;\r\n\r\nfunction TJvTFCustomGlance.ValidCol(Col: Integer): Boolean;\r\nbegin\r\n Result := (Col >= 0) and (Col < ColCount);\r\nend;\r\n\r\nfunction TJvTFCustomGlance.ValidRow(Row: Integer): Boolean;\r\nbegin\r\n Result := (Row >= 0) and (Row < RowCount);\r\nend;\r\n\r\nprocedure TJvTFCustomGlance.WMEraseBkgnd(var Msg: TMessage);\r\nbegin\r\n Msg.Result := LRESULT(False);\r\nend;\r\n\r\nfunction TJvTFCustomGlance.CellBodyRect(ACell: TJvTFGlanceCell): TRect;\r\nbegin\r\n Result := CalcCellBodyRect(ACell, CellIsSelected(ACell), True);\r\nend;\r\n\r\nfunction TJvTFCustomGlance.CellTitleRect(ACell: TJvTFGlanceCell): TRect;\r\nbegin\r\n Result := CalcCellTitleRect(ACell, CellIsSelected(ACell), True);\r\nend;\r\n\r\nprocedure TJvTFCustomGlance.DrawCellTitle(ACanvas: TCanvas; ATitleRect: TRect;\r\n Attr: TJvTFGlanceCellAttr; Cell: TJvTFGlanceCell);\r\nconst\r\n PicBuffer = 2;\r\nvar\r\n Txt: string;\r\n DayRect, PicRect, AdjTitleRect, TextBounds: TRect;\r\n HorzLayout: Boolean;\r\n I, PicIndex, PicLeft, PicTop, PicsHeight, PicsWidth: Integer;\r\nbegin\r\n // shade the title\r\n ACanvas.Brush.Color := Attr.TitleAttr.Color;\r\n ACanvas.FillRect(ATitleRect);\r\n\r\n HorzLayout := (Attr.TitleAttr.Align = alTop) or\r\n (Attr.TitleAttr.Align = alBottom);\r\n\r\n if Assigned(Cell) then\r\n begin\r\n //Txt := FormatDateTime(Attr.TitleAttr.DayFormat, Cell.CellDate);\r\n Txt := Cell.TitleText;\r\n AdjTitleRect := ATitleRect;\r\n Windows.InflateRect(AdjTitleRect, -2, -2);\r\n\r\n // Draw the day text and Calc the rects\r\n if Txt <> '' then\r\n begin\r\n ACanvas.Font := Attr.TitleAttr.DayTxtAttr.Font;\r\n DrawAngleText(ACanvas, AdjTitleRect, TextBounds,\r\n Attr.TitleAttr.DayTxtAttr.Rotation,\r\n Attr.TitleAttr.DayTxtAttr.AlignH,\r\n Attr.TitleAttr.DayTxtAttr.AlignV, Txt);\r\n\r\n DayRect := AdjTitleRect;\r\n case Attr.TitleAttr.Align of\r\n alTop, alBottom:\r\n case Attr.TitleAttr.DayTxtAttr.AlignH of\r\n taLeftJustify:\r\n DayRect.Right := TextBounds.Right;\r\n taRightJustify:\r\n DayRect.Left := TextBounds.Left;\r\n end;\r\n alLeft, alRight:\r\n case Attr.TitleAttr.DayTxtAttr.AlignV of\r\n vaTop:\r\n DayRect.Bottom := TextBounds.Bottom;\r\n vaBottom:\r\n DayRect.Top := TextBounds.Top;\r\n end;\r\n end;\r\n Windows.SubtractRect(PicRect, AdjTitleRect, DayRect);\r\n end\r\n else\r\n begin\r\n DayRect := Rect(0, 0, 0, 0);\r\n PicRect := AdjTitleRect;\r\n end;\r\n\r\n // draw the pics\r\n if PicsToDraw(Cell) then\r\n begin\r\n GetPicsWidthHeight(Cell, PicBuffer, HorzLayout, PicsWidth, PicsHeight);\r\n\r\n // find PicLeft of first pic\r\n case Attr.TitleAttr.PicAttr.AlignH of\r\n taLeftJustify:\r\n PicLeft := PicRect.Left;\r\n taCenter:\r\n PicLeft := PicRect.Left + RectWidth(PicRect) div 2 - PicsWidth div 2;\r\n else\r\n PicLeft := PicRect.Right - PicsWidth;\r\n end;\r\n\r\n // find PicTop of first pic\r\n case Attr.TitleAttr.PicAttr.AlignV of\r\n vaTop:\r\n PicTop := PicRect.Top;\r\n vaCenter:\r\n PicTop := PicRect.Top + RectHeight(PicRect) div 2 - PicsHeight div 2;\r\n else\r\n PicTop := PicRect.Bottom - PicsHeight;\r\n end;\r\n\r\n for I := 0 to Cell.CellPics.Count - 1 do\r\n begin\r\n PicIndex := Cell.CellPics[I].PicIndex;\r\n if ValidPicIndex(PicIndex) then\r\n begin\r\n Cell.CellPics[I].SetPicPoint(PicLeft, PicTop);\r\n CellPics.Draw(ACanvas, PicLeft, PicTop, PicIndex);\r\n if HorzLayout then\r\n Inc(PicLeft, CellPics.Width + PicBuffer)\r\n else\r\n Inc(PicTop, CellPics.Height + PicBuffer);\r\n end;\r\n end;\r\n end;\r\n end;\r\n\r\n // draw the title frame\r\n DrawCellTitleFrame(ACanvas, ATitleRect, Attr);\r\nend;\r\n\r\nprocedure TJvTFCustomGlance.DrawCellFrame(ACanvas: TCanvas; ARect: TRect;\r\n Attr: TJvTFGlanceCellAttr; ACell: TJvTFGlanceCell);\r\nvar\r\n I, LineBottom: Integer;\r\nbegin\r\n with ACanvas do\r\n begin\r\n // draw the cell frame\r\n case Attr.FrameAttr.Style of\r\n fs3DRaised:\r\n Draw3DFrame(ACanvas, ARect, clBtnHighlight, clBtnShadow);\r\n fs3DLowered:\r\n Draw3DFrame(ACanvas, ARect, clBtnShadow, clBtnHighlight);\r\n fsFlat:\r\n begin\r\n Pen.Color := Attr.FrameAttr.Color;\r\n Pen.Width := 1;\r\n\r\n // draw the bottom line\r\n LineBottom := ARect.Bottom - 1;\r\n for I := 1 to Attr.FrameAttr.Width do\r\n begin\r\n MoveTo(ARect.Left, LineBottom);\r\n LineTo(ARect.Right, LineBottom);\r\n Dec(LineBottom);\r\n end;\r\n\r\n // draw the right line\r\n LineBottom := ARect.Right - 1;\r\n for I := 1 to Attr.FrameAttr.Width do\r\n begin\r\n MoveTo(LineBottom, ARect.Top);\r\n LineTo(LineBottom, ARect.Bottom);\r\n Dec(LineBottom);\r\n end;\r\n\r\n // draw the left line only for col 0 cells\r\n if ACell.ColIndex = 0 then\r\n begin\r\n LineBottom := ARect.Left;\r\n for I := 1 to Attr.FrameAttr.Width do\r\n begin\r\n MoveTo(LineBottom, ARect.Top);\r\n LineTo(LineBottom, ARect.Bottom);\r\n Inc(LineBottom);\r\n end;\r\n end;\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvTFCustomGlance.DrawCellTitleFrame(ACanvas: TCanvas; ATitleRect: TRect;\r\n Attr: TJvTFGlanceCellAttr);\r\nvar\r\n I, LineBottom: Integer;\r\nbegin\r\n with ACanvas do\r\n begin\r\n // draw the title frame\r\n case Attr.TitleAttr.FrameAttr.Style of\r\n fs3DRaised:\r\n Draw3DFrame(ACanvas, ATitleRect, clBtnHighlight, clBtnShadow);\r\n fs3DLowered:\r\n Draw3DFrame(ACanvas, ATitleRect, clBtnShadow, clBtnHighlight);\r\n fsFlat:\r\n begin\r\n Pen.Color := Attr.TitleAttr.FrameAttr.Color;\r\n case Attr.TitleAttr.Align of\r\n alTop:\r\n begin\r\n if Attr.DrawBottomLine then\r\n begin\r\n LineBottom := ATitleRect.Bottom - 1;\r\n for I := 1 to Attr.TitleAttr.FrameAttr.Width do\r\n begin\r\n MoveTo(ATitleRect.Left + FGapSize, LineBottom);\r\n LineTo(ATitleRect.Right - FGapSize, LineBottom);\r\n Dec(LineBottom);\r\n end;\r\n end;\r\n end;\r\n alBottom:\r\n begin\r\n LineBottom := ATitleRect.Top;\r\n for I := 1 to Attr.TitleAttr.FrameAttr.Width do\r\n begin\r\n MoveTo(ATitleRect.Left + 4, LineBottom);\r\n LineTo(ATitleRect.Right - 4, LineBottom);\r\n Inc(LineBottom);\r\n end;\r\n end;\r\n alLeft:\r\n begin\r\n LineBottom := ATitleRect.Right - 1;\r\n for I := 1 to Attr.TitleAttr.FrameAttr.Width do\r\n begin\r\n MoveTo(LineBottom, ATitleRect.Top);\r\n LineTo(LineBottom, ATitleRect.Bottom);\r\n Dec(LineBottom);\r\n end;\r\n end;\r\n alRight:\r\n begin\r\n LineBottom := ATitleRect.Left;\r\n for I := 1 to Attr.TitleAttr.FrameAttr.Width do\r\n begin\r\n MoveTo(LineBottom, ATitleRect.Top);\r\n LineTo(LineBottom, ATitleRect.Bottom);\r\n Inc(LineBottom);\r\n end;\r\n end;\r\n end;\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJvTFCustomGlance.PicsToDraw(ACell: TJvTFGlanceCell): Boolean;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := False;\r\n if Assigned(CellPics) and (CellPics.Count > 0) then\r\n begin\r\n I := 0;\r\n while (I < ACell.CellPics.Count) and not Result do\r\n if ACell.CellPics[I].PicIndex > -1 then\r\n Result := True\r\n else\r\n Inc(I);\r\n end;\r\nend;\r\n\r\nprocedure TJvTFCustomGlance.GetPicsWidthHeight(ACell: TJvTFGlanceCell;\r\n PicBuffer: Integer; Horz: Boolean; var PicsWidth, PicsHeight: Integer);\r\nvar\r\n I, PicIndex: Integer;\r\nbegin\r\n if Horz then\r\n begin\r\n PicsWidth := 0;\r\n PicsHeight := CellPics.Height;\r\n end\r\n else\r\n begin\r\n PicsWidth := CellPics.Width;\r\n PicsHeight := 0;\r\n end;\r\n\r\n for I := 0 to ACell.CellPics.Count - 1 do\r\n begin\r\n PicIndex := ACell.CellPics[I].PicIndex;\r\n if ValidPicIndex(PicIndex) then\r\n if Horz then\r\n Inc(PicsWidth, CellPics.Width + PicBuffer)\r\n else\r\n Inc(PicsHeight, CellPics.Height + PicBuffer);\r\n end;\r\n\r\n if Horz and (PicsWidth > 0) then\r\n Dec(PicsWidth, PicBuffer);\r\n\r\n if not Horz and (PicsHeight > 0) then\r\n Dec(PicsHeight, PicBuffer);\r\nend;\r\n\r\nfunction TJvTFCustomGlance.ValidPicIndex(PicIndex: Integer): Boolean;\r\nbegin\r\n Result := (PicIndex >= 0) and (PicIndex < CellPics.Count);\r\nend;\r\n\r\nprocedure TJvTFCustomGlance.SetHintProps(Value: TJvTFHintProps);\r\nbegin\r\n FHintProps.Assign(Value);\r\nend;\r\n\r\nprocedure TJvTFCustomGlance.DoDrawCell(ACanvas: TCanvas;\r\n ACellRect, ATitleRect, ABodyRect: TRect; Attr: TJvTFGlanceCellAttr;\r\n Cell: TJvTFGlanceCell);\r\nbegin\r\n if Assigned(FOnDrawCell) then\r\n FOnDrawCell(Self, ACanvas, ACellRect, ATitleRect, ABodyRect, Attr, Cell);\r\nend;\r\n\r\nprocedure TJvTFCustomGlance.DoDrawTitle(ACanvas: TCanvas; ARect: TRect);\r\nbegin\r\n if Assigned(FOnDrawTitle) then\r\n FOnDrawTitle(Self, ACanvas, ARect);\r\nend;\r\n\r\nprocedure TJvTFCustomGlance.InternalDeselectCell(ACell: TJvTFGlanceCell);\r\nvar\r\n I: Integer;\r\nbegin\r\n if Assigned(ACell) then\r\n begin\r\n I := Sel.IndexOf(ACell.CellDate);\r\n if I > -1 then\r\n Sel.Delete(I);\r\n end;\r\nend;\r\n\r\nprocedure TJvTFCustomGlance.DeselectCell(ACell: TJvTFGlanceCell);\r\nbegin\r\n EnsureCell(ACell);\r\n InternalDeselectCell(ACell);\r\nend;\r\n\r\nprocedure TJvTFCustomGlance.BeginSelUpdate;\r\nbegin\r\n FUpdatingSel := True;\r\nend;\r\n\r\nprocedure TJvTFCustomGlance.EndSelUpdate;\r\nbegin\r\n FUpdatingSel := False;\r\n SelChange(Self);\r\nend;\r\n\r\nprocedure TJvTFCustomGlance.SelChange(Sender: TObject);\r\n//var\r\n// SchedNameList: TStringList;\r\n// DateList: TJvTFDateList;\r\n// I: Integer;\r\nbegin\r\n if not UpdatingSel then\r\n begin\r\n if Assigned(FOnSelChanged) then\r\n FOnSelChanged(Self);\r\n\r\n // DoNavigate\r\n// if Assigned(Navigator) then\r\n// begin\r\n// SchedNameList := TStringList.Create;\r\n// DateList := TJvTFDateList.Create;\r\n// Try\r\n// SchedNameList.Assign(SchedNames);\r\n//\r\n// For I := 0 to Sel.Count - 1 do\r\n// DateList.Add(Sel[I]);\r\n//\r\n// Navigator.Navigate(Self, SchedNameList, DateList);\r\n// Finally\r\n// SchedNameList.Free;\r\n// DateList.Free;\r\n// end;\r\n// end;\r\n\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvTFCustomGlance.ReleaseSchedule(const SchedName: string;\r\n SchedDate: TDate);\r\nbegin\r\n // ALWAYS RELEASE SCHEDULE HERE\r\n inherited ReleaseSchedule(SchedName, SchedDate);\r\nend;\r\n\r\nfunction TJvTFCustomGlance.GetSchedNames: TStrings;\r\nbegin\r\n Result := FSchedNames;\r\nend;\r\n\r\nprocedure TJvTFCustomGlance.SetSchedNames(Value: TStrings);\r\nbegin\r\n FSchedNames.Assign(Value);\r\n // SchedNamesChange will run\r\nend;\r\n\r\nprocedure TJvTFCustomGlance.SafeReleaseSchedule(ASched: TJvTFSched);\r\nbegin\r\n if not Cells.IsSchedUsed(ASched) then\r\n ReleaseSchedule(ASched.SchedName, ASched.SchedDate);\r\nend;\r\n\r\nprocedure TJvTFCustomGlance.SchedNamesChange(Sender: TObject);\r\nbegin\r\n if not (csDesigning in ComponentState) and not (csCreating in ControlState) then\r\n Cells.CheckConnections;\r\nend;\r\n\r\nprocedure TJvTFCustomGlance.Notify(Sender: TObject; Code: TJvTFServNotifyCode);\r\nbegin\r\n inherited Notify(Sender, Code);\r\n\r\n // WHAT IS THIS CODE FOR ??!!?!!\r\n if Assigned(Viewer) then\r\n Viewer.Refresh;\r\nend;\r\n\r\nprocedure TJvTFCustomGlance.CheckApptHint(Info: TJvTFGlanceCoord);\r\nvar\r\n ExtraDesc: string;\r\n Handled: Boolean;\r\nbegin\r\n if Assigned(FViewer) and FViewer.ShowSchedNamesInHint then\r\n ExtraDesc := StringsToStr(SchedNames, ', ', False);\r\n ExtraDesc := ExtraDesc + #13#10;\r\n\r\n Handled := False;\r\n if Assigned(OnApptHint) then\r\n FOnApptHint(Self, Info.Appt, Handled);\r\n if not Handled then\r\n FHint.ApptHint(Info.Appt, Info.AbsX + 8, Info.AbsY + 8,\r\n not Assigned(FViewer) or FViewer.ShowStartEndTimeInHint, True, False, ExtraDesc);\r\nend;\r\n\r\nprocedure TJvTFCustomGlance.CheckViewerApptHint(X, Y: Integer);\r\nvar\r\n Info: TJvTFGlanceCoord;\r\nbegin\r\n Info := PtToCell(X, Y);\r\n CheckApptHint(Info);\r\nend;\r\n\r\nprocedure TJvTFCustomGlance.DoEndDrag(Target: TObject; X, Y: Integer);\r\nbegin\r\n inherited DoEndDrag(Target, X, Y);\r\nend;\r\n\r\nprocedure TJvTFCustomGlance.DoStartDrag(var DragObject: TDragObject);\r\nbegin\r\n if Assigned(Viewer) and Viewer.Editing then\r\n Viewer.FinishEditAppt;\r\n\r\n inherited DoStartDrag(DragObject);\r\n\r\n FDragInfo.Appt := SelAppt;\r\nend;\r\n\r\nprocedure TJvTFCustomGlance.DragOver(Source: TObject; X, Y: Integer;\r\n State: TDragState; var Accept: Boolean);\r\nvar\r\n SrcDragInfo: TJvTFDragInfo;\r\n PtInfo: TJvTFGlanceCoord;\r\n //Appt: TJvTFAppt;\r\nbegin\r\n //Viewer.Visible := False;\r\n\r\n inherited DragOver(Source, X, Y, State, Accept);\r\n\r\n if Source is TJvTFControl then\r\n begin\r\n SrcDragInfo := TJvTFControl(Source).DragInfo;\r\n PtInfo := PtToCell(X, Y);\r\n Accept := PtInfo.DragAccept;\r\n //Appt := SrcDragInfo.Appt;\r\n\r\n case State of\r\n dsDragEnter:\r\n begin\r\n if not Assigned(FDragInfo) then\r\n FDragInfo := SrcDragInfo;\r\n //BeginDragging(GridCoord, agsMoveAppt, Appt);\r\n end;\r\n dsDragLeave:\r\n begin\r\n //EndDragging(GridCoord, Appt);\r\n if FDragInfo.ApptCtrl <> Self then\r\n FDragInfo := nil;\r\n end;\r\n //dsDragMove: ContinueDragging(GridCoord, Appt);\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvTFCustomGlance.SetSelAppt(Value: TJvTFAppt);\r\nbegin\r\n if Value <> FSelAppt then\r\n begin\r\n FSelAppt := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvTFCustomGlance.DragDrop(Source: TObject; X, Y: Integer);\r\nbegin\r\n if Source is TJvTFControl then\r\n DropAppt(TJvTFControl(Source).DragInfo, X, Y);\r\n\r\n inherited DragDrop(Source, X, Y);\r\nend;\r\n\r\nprocedure TJvTFCustomGlance.DropAppt(DragInfo: TJvTFDragInfo; X, Y: Integer);\r\nvar\r\n NewStart, NewEnd: TDate;\r\n Appt: TJvTFAppt;\r\n PtInfo: TJvTFGlanceCoord;\r\n Confirm: Boolean;\r\nbegin\r\n FHint.ReleaseHandle;\r\n Appt := DragInfo.Appt;\r\n\r\n if not Assigned(Appt) then\r\n Exit; // happens sometimes\r\n\r\n // calc new info\r\n // Schedule(s) do not change\r\n PtInfo := PtToCell(X, Y);\r\n NewStart := PtInfo.Cell.CellDate;\r\n NewEnd := Trunc(Appt.EndDate) - Trunc(Appt.StartDate) + NewStart;\r\n\r\n Confirm := True;\r\n if Assigned(FOnDropAppt) then\r\n FOnDropAppt(Self, Appt, NewStart, NewEnd, Confirm);\r\n\r\n if Confirm then\r\n begin\r\n {\r\n DateChange := (Trunc(Appt.StartDate) <> Trunc(NewStart)) or\r\n (Trunc(Appt.EndDate) <> Trunc(NewEnd));\r\n\r\n if DateChange then\r\n begin\r\n end;\r\n }\r\n\r\n Appt.SetStartEnd(NewStart, Appt.StartTime, NewEnd, Appt.EndTime);\r\n ScheduleManager.RefreshConnections(Appt);\r\n end;\r\nend;\r\n\r\nprocedure TJvTFCustomGlance.ConfigCells;\r\nbegin\r\n // DO NOT DIRECTLY CALL THIS ROUTINE!\r\n // This routine is called by TJvTFGlanceCells.ConfigCells.\r\n // Use this routine to set the cell dates by calling\r\n // TJvTFCustomGlance.SetCellDate.\r\n // Override this routine in successors to customize\r\n // cell/date configuration.\r\n\r\n { Example:\r\n CellDate := OriginDate;\r\n For Row := 0 to RowCount - 1 do\r\n For Col := 0 to ColCount - 1 do\r\n begin\r\n SetCellDate(Col, Row, CellDate);\r\n CellDate := CellDate + 1;\r\n end;\r\n }\r\n DoConfigCells;\r\n UpdateCellTitles;\r\nend;\r\n\r\nprocedure TJvTFCustomGlance.SetCellDate(ACell: TJvTFGlanceCell; CellDate: TDate);\r\nbegin\r\n ACell.InternalSetCellDate(CellDate);\r\nend;\r\n\r\nprocedure TJvTFCustomGlance.ReconfigCells;\r\nbegin\r\n Cells.ReconfigCells;\r\nend;\r\n\r\nprocedure TJvTFCustomGlance.GlanceTitleChange(Sender: TObject);\r\nbegin\r\n if Assigned(Viewer) then\r\n Viewer.Realign;\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvTFCustomGlance.UpdateCellTitleText(Cell: TJvTFGlanceCell);\r\nvar\r\n NewTitleText: string;\r\nbegin\r\n NewTitleText := GetCellTitleText(Cell);\r\n if Assigned(FOnUpdateCellTitleText) then\r\n FOnUpdateCellTitleText(Self, Cell, NewTitleText);\r\n Cell.SetTitleText(NewTitleText);\r\nend;\r\n\r\nfunction TJvTFCustomGlance.GetCellTitleText(Cell: TJvTFGlanceCell): string;\r\nbegin\r\n Result := FormatDateTime('mm/d/yyyy', Cell.CellDate);\r\nend;\r\n\r\nfunction TJvTFCustomGlance.WholeCellRect(Col, Row: Integer): TRect;\r\nbegin\r\n Result.Left := GetDataLeft + GetDivStart(GetDataWidth, ColCount, Col);\r\n Result.Right := Result.Left + GetDivLength(GetDataWidth, ColCount, Col);\r\n Result.Top := GetDataTop + GetDivStart(GetDataHeight, RowCount, Row);\r\n Result.Bottom := Result.Top + GetDivLength(GetDataHeight, RowCount, Row);\r\nend;\r\n\r\nprocedure TJvTFCustomGlance.SplitRects(Col, Row: Integer;\r\n var ParentRect, SubRect: TRect);\r\nvar\r\n ACell: TJvTFGlanceCell;\r\n WorkRect: TRect;\r\nbegin\r\n ParentRect := EmptyRect;\r\n SubRect := EmptyRect;\r\n if not (ValidCol(Col) and ValidRow(Row)) then\r\n Exit;\r\n\r\n WorkRect := WholeCellRect(Col, Row);\r\n ParentRect := WorkRect;\r\n\r\n ACell := Cells.Cells[Col, Row];\r\n if ACell.IsSplit then\r\n begin\r\n if ACell.SplitOrientation = soHorizontal then\r\n ParentRect.Bottom := ParentRect.Top + RectHeight(ParentRect) div 2\r\n else\r\n ParentRect.Right := ParentRect.Left + RectWidth(ParentRect) div 2;\r\n Windows.SubtractRect(SubRect, WorkRect, ParentRect);\r\n end;\r\nend;\r\n\r\nprocedure TJvTFCustomGlance.UpdateCellTitles;\r\nvar\r\n I: Integer;\r\n ACell: TJvTFGlanceCell;\r\nbegin\r\n for I := 0 to Cells.Count - 1 do\r\n begin\r\n ACell := Cells[I];\r\n UpdateCellTitleText(ACell);\r\n if Assigned(ACell.SubCell) then\r\n UpdateCellTitleText(ACell.SubCell);\r\n end;\r\nend;\r\n\r\nprocedure TJvTFCustomGlance.SplitCell(ACell: TJvTFGlanceCell);\r\nbegin\r\n ACell.Split;\r\nend;\r\n\r\nprocedure TJvTFCustomGlance.CombineCell(ACell: TJvTFGlanceCell);\r\nbegin\r\n ACell.Combine;\r\nend;\r\n\r\nfunction TJvTFCustomGlance.GetTFHintClass: TJvTFHintClass;\r\nbegin\r\n Result := TJvTFHint;\r\nend;\r\n\r\n//=== { TJvTFGlanceTitle } ===================================================\r\n\r\nconstructor TJvTFGlanceTitle.Create(AOwner: TJvTFCustomGlance);\r\nbegin\r\n inherited Create;\r\n FGlanceControl := AOwner;\r\n\r\n FTxtAttr := TJvTFTextAttr.Create;\r\n FTxtAttr.Font.Size := 16;\r\n FTxtAttr.Font.Style := FTxtAttr.Font.Style + [fsBold];\r\n FTxtAttr.OnChange := TxtAttrChange;\r\n\r\n FFrameAttr := TJvTFGlanceFrameAttr.Create(AOwner);\r\n\r\n FColor := clBtnFace;\r\n FHeight := 40;\r\n FVisible := True;\r\nend;\r\n\r\ndestructor TJvTFGlanceTitle.Destroy;\r\nbegin\r\n FFrameAttr.Free;\r\n FTxtAttr.OnChange := nil;\r\n FTxtAttr.Free;\r\n\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvTFGlanceTitle.Assign(Source: TPersistent);\r\nbegin\r\n if Source is TJvTFGlanceTitle then\r\n begin\r\n FColor := TJvTFGlanceTitle(Source).Color;\r\n FHeight := TJvTFGlanceTitle(Source).Height;\r\n FVisible := TJvTFGlanceTitle(Source).Visible;\r\n FFrameAttr.Assign(TJvTFGlanceTitle(Source).FrameAttr);\r\n FTxtAttr.Assign(TJvTFGlanceTitle(Source).TxtAttr);\r\n Change;\r\n end\r\n else\r\n inherited Assign(Source);\r\nend;\r\n\r\nprocedure TJvTFGlanceTitle.Change;\r\nbegin\r\n if Assigned(FOnChange) then\r\n FOnChange(Self);\r\nend;\r\n\r\nprocedure TJvTFGlanceTitle.SetColor(Value: TColor);\r\nbegin\r\n if Value <> FColor then\r\n begin\r\n FColor := Value;\r\n Change;\r\n end;\r\nend;\r\n\r\nprocedure TJvTFGlanceTitle.SetFrameAttr(Value: TJvTFGlanceFrameAttr);\r\nbegin\r\n FFrameAttr.Assign(Value);\r\nend;\r\n\r\nprocedure TJvTFGlanceTitle.SetHeight(Value: Integer);\r\nbegin\r\n Value := Greater(Value, 0);\r\n if Assigned(GlanceControl) then\r\n Value := Lesser(Value, GlanceControl.Height - 5);\r\n\r\n if Value <> FHeight then\r\n begin\r\n FHeight := Value;\r\n Change;\r\n end;\r\nend;\r\n\r\nprocedure TJvTFGlanceTitle.SetTxtAttr(Value: TJvTFTextAttr);\r\nbegin\r\n FTxtAttr.Assign(Value);\r\n Change;\r\nend;\r\n\r\nprocedure TJvTFGlanceTitle.SetVisible(Value: Boolean);\r\nbegin\r\n if Value <> FVisible then\r\n begin\r\n FVisible := Value;\r\n Change;\r\n end;\r\nend;\r\n\r\nprocedure TJvTFGlanceTitle.TxtAttrChange(Sender: TObject);\r\nbegin\r\n Change;\r\nend;\r\n\r\n//=== { TJvTFFrameAttr } =====================================================\r\n\r\nconstructor TJvTFFrameAttr.Create(AOwner: TJvTFControl);\r\nbegin\r\n inherited Create;\r\n FControl := AOwner;\r\n\r\n FStyle := fsFlat;\r\n FColor := clBlack;\r\n FWidth := 1;\r\nend;\r\n\r\nprocedure TJvTFFrameAttr.Assign(Source: TPersistent);\r\nbegin\r\n if Source is TJvTFFrameAttr then\r\n begin\r\n FStyle := TJvTFFrameAttr(Source).Style;\r\n FColor := TJvTFFrameAttr(Source).Color;\r\n FWidth := TJvTFFrameAttr(Source).Width;\r\n Change;\r\n end\r\n else\r\n inherited Assign(Source);\r\nend;\r\n\r\nprocedure TJvTFFrameAttr.Change;\r\nbegin\r\n if Assigned(FOnChange) then\r\n FOnChange(Self);\r\n\r\n if Assigned(Control) then\r\n Control.Invalidate;\r\nend;\r\n\r\nprocedure TJvTFFrameAttr.SetColor(Value: TColor);\r\nbegin\r\n if Value <> FColor then\r\n begin\r\n FColor := Value;\r\n Change;\r\n end;\r\nend;\r\n\r\nprocedure TJvTFFrameAttr.SetStyle(Value: TJvTFFrameStyle);\r\nbegin\r\n if Value <> FStyle then\r\n begin\r\n FStyle := Value;\r\n Change;\r\n end;\r\nend;\r\n\r\nprocedure TJvTFFrameAttr.SetWidth(Value: Integer);\r\nbegin\r\n Value := Greater(Value, 1);\r\n\r\n if Value <> FWidth then\r\n begin\r\n FWidth := Value;\r\n Change;\r\n end;\r\nend;\r\n\r\n//=== { TJvTFGlanceCellAttr } ================================================\r\n\r\nconstructor TJvTFGlanceCellAttr.Create(AOwner: TJvTFCustomGlance);\r\nbegin\r\n inherited Create;\r\n FGlanceControl := AOwner;\r\n\r\n FColor := clWhite;\r\n FFrameAttr := TJvTFGlanceFrameAttr.Create(AOwner);\r\n FTitleAttr := TJvTFGlanceTitleAttr.Create(AOwner);\r\n\r\n FFont := TFont.Create;\r\n FFont.OnChange := FontChange;\r\nend;\r\n\r\ndestructor TJvTFGlanceCellAttr.Destroy;\r\nbegin\r\n FFrameAttr.Free;\r\n FTitleAttr.Free;\r\n FFont.Free;\r\n\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvTFGlanceCellAttr.Assign(Source: TPersistent);\r\nbegin\r\n if Source is TJvTFGlanceCellAttr then\r\n begin\r\n FColor := TJvTFGlanceCellAttr(Source).Color;\r\n FFrameAttr.Assign(TJvTFGlanceCellAttr(Source).FrameAttr);\r\n FTitleAttr.Assign(TJvTFGlanceCellAttr(Source).TitleAttr);\r\n FFont.Assign(TJvTFGlanceCellAttr(Source).Font);\r\n Change;\r\n end\r\n else\r\n inherited Assign(Source);\r\nend;\r\n\r\nprocedure TJvTFGlanceCellAttr.Change;\r\nbegin\r\n if Assigned(GlanceControl) then\r\n GlanceControl.Invalidate;\r\nend;\r\n\r\nprocedure TJvTFGlanceCellAttr.FontChange(Sender: TObject);\r\nbegin\r\n Change;\r\nend;\r\n\r\nprocedure TJvTFGlanceCellAttr.SetDrawBottomLine(Value: Boolean);\r\nbegin\r\n if Value <> FDrawBottomLine then\r\n begin\r\n FDrawBottomLine := Value;\r\n Change;\r\n end;\r\nend;\r\n\r\nprocedure TJvTFGlanceCellAttr.SetColor(Value: TColor);\r\nbegin\r\n if Value <> FColor then\r\n begin\r\n FColor := Value;\r\n Change;\r\n end;\r\nend;\r\n\r\nprocedure TJvTFGlanceCellAttr.SetFont(Value: TFont);\r\nbegin\r\n FFont.Assign(Value);\r\nend;\r\n\r\nprocedure TJvTFGlanceCellAttr.SetFrameAttr(Value: TJvTFGlanceFrameAttr);\r\nbegin\r\n FFrameAttr.Assign(Value);\r\nend;\r\n\r\nprocedure TJvTFGlanceCellAttr.SetTitleAttr(Value: TJvTFGlanceTitleAttr);\r\nbegin\r\n FTitleAttr.Assign(Value);\r\nend;\r\n\r\n//=== { TJvTFGlanceTitleAttr } ===============================================\r\n\r\nconstructor TJvTFGlanceTitleAttr.Create(AOwner: TJvTFCustomGlance);\r\nbegin\r\n inherited Create;\r\n FGlanceControl := AOwner;\r\n\r\n FAlign := alTop;\r\n\r\n FColor := clBtnFace;\r\n FHeight := 20;\r\n FVisible := True;\r\n //FDayFormat := 'd';\r\n\r\n FFrameAttr := TJvTFGlanceFrameAttr.Create(AOwner);\r\n\r\n FDayTxtAttr := TJvTFTextAttr.Create;\r\n FDayTxtAttr.OnChange := TxtAttrChange;\r\n\r\n FPicAttr := TJvTFGlanceTitlePicAttr.Create;\r\n FPicAttr.OnChange := PicAttrChange;\r\nend;\r\n\r\ndestructor TJvTFGlanceTitleAttr.Destroy;\r\nbegin\r\n FFrameAttr.Free;\r\n FDayTxtAttr.OnChange := nil;\r\n FDayTxtAttr.Free;\r\n FPicAttr.OnChange := nil;\r\n FPicAttr.Free;\r\n\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvTFGlanceTitleAttr.Assign(Source: TPersistent);\r\nbegin\r\n if Source is TJvTFGlanceTitleAttr then\r\n begin\r\n FAlign := TJvTFGlanceTitleAttr(Source).Align;\r\n //FDayFormat := TJvTFGlanceTitleAttr(Source).DayFormat;\r\n FColor := TJvTFGlanceTitleAttr(Source).Color;\r\n FHeight := TJvTFGlanceTitleAttr(Source).Height;\r\n FVisible := TJvTFGlanceTitleAttr(Source).Visible;\r\n FFrameAttr.Assign(TJvTFGlanceTitleAttr(Source).FrameAttr);\r\n FDayTxtAttr.Assign(TJvTFGlanceTitleAttr(Source).DayTxtAttr);\r\n Change;\r\n end\r\n else\r\n inherited Assign(Source);\r\nend;\r\n\r\nprocedure TJvTFGlanceTitleAttr.Change;\r\nbegin\r\n if Assigned(GlanceControl) then\r\n begin\r\n if Assigned(GlanceControl.Viewer) then\r\n GlanceControl.Viewer.Realign;\r\n GlanceControl.Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvTFGlanceTitleAttr.PicAttrChange(Sender: TObject);\r\nbegin\r\n Change;\r\nend;\r\n\r\nprocedure TJvTFGlanceTitleAttr.SetAlign(Value: TJvTFTitleAlign);\r\nbegin\r\n if Value <> FAlign then\r\n begin\r\n FAlign := Value;\r\n Change;\r\n end;\r\nend;\r\n\r\nprocedure TJvTFGlanceTitleAttr.SetColor(Value: TColor);\r\nbegin\r\n if Value <> FColor then\r\n begin\r\n FColor := Value;\r\n Change;\r\n end;\r\nend;\r\n\r\n{\r\nprocedure TJvTFGlanceTitleAttr.SetDayFormat(const Value: string);\r\nbegin\r\n if Value <> FDayFormat then\r\n begin\r\n FDayFormat := Value;\r\n Change;\r\n end;\r\nend;\r\n}\r\n\r\nprocedure TJvTFGlanceTitleAttr.SetDayTxtAttr(Value: TJvTFTextAttr);\r\nbegin\r\n FDayTxtAttr.Assign(Value);\r\n Change;\r\nend;\r\n\r\nprocedure TJvTFGlanceTitleAttr.SetFrameAttr(Value: TJvTFGlanceFrameAttr);\r\nbegin\r\n FFrameAttr.Assign(Value);\r\n Change;\r\nend;\r\n\r\nprocedure TJvTFGlanceTitleAttr.SetHeight(Value: Integer);\r\nbegin\r\n if Value <> FHeight then\r\n begin\r\n FHeight := Value;\r\n Change;\r\n end;\r\nend;\r\n\r\nprocedure TJvTFGlanceTitleAttr.SetPicAttr(Value: TJvTFGlanceTitlePicAttr);\r\nbegin\r\n FPicAttr.Assign(Value);\r\n Change;\r\nend;\r\n\r\nprocedure TJvTFGlanceTitleAttr.SetVisible(Value: Boolean);\r\nbegin\r\n if Value <> FVisible then\r\n begin\r\n FVisible := Value;\r\n Change;\r\n end;\r\nend;\r\n\r\nprocedure TJvTFGlanceTitleAttr.TxtAttrChange(Sender: TObject);\r\nbegin\r\n Change;\r\nend;\r\n\r\n//=== { TJvTFGlanceSelList } =================================================\r\n\r\nconstructor TJvTFGlanceSelList.Create(AOwner: TJvTFCustomGlance);\r\nbegin\r\n inherited Create;\r\n FGlanceControl := AOwner;\r\nend;\r\n\r\n//=== { TJvTFGlanceViewer } ==================================================\r\n\r\nconstructor TJvTFGlanceViewer.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FRepeatGrouped := True;\r\n FShowSchedNamesInHint := True;\r\n FInplaceEdit := True;\r\nend;\r\n\r\nfunction TJvTFGlanceViewer.ApptCount: Integer;\r\nvar\r\n I: Integer;\r\n ApptList: TStringList;\r\nbegin\r\n if RepeatGrouped then\r\n begin\r\n Result := 0;\r\n for I := 0 to ScheduleCount - 1 do\r\n Inc(Result, Schedules[I].ApptCount);\r\n end\r\n else\r\n begin\r\n ApptList := TStringList.Create;\r\n try\r\n GetDistinctAppts(ApptList);\r\n Result := ApptList.Count;\r\n finally\r\n ApptList.Free;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvTFGlanceViewer.EnsureCol(ACol: Integer);\r\nbegin\r\n GlanceControl.EnsureCol(ACol);\r\nend;\r\n\r\nprocedure TJvTFGlanceViewer.EnsureRow(ARow: Integer);\r\nbegin\r\n GlanceControl.EnsureRow(ARow);\r\nend;\r\n\r\nfunction TJvTFGlanceViewer.GetRepeatAppt(Index: Integer): TJvTFAppt;\r\nvar\r\n I, AbsIndex: Integer;\r\nbegin\r\n if (Index < 0) or (Index > ApptCount - 1) then\r\n raise EGlanceViewerError.CreateResFmt(@RsEApptIndexOutOfBoundsd, [Index]);\r\n\r\n AbsIndex := 0;\r\n I := -1;\r\n\r\n repeat\r\n Inc(I);\r\n Inc(AbsIndex, Schedules[I].ApptCount);\r\n until AbsIndex - 1 >= Index;\r\n\r\n Result := Schedules[I].Appts[Schedules[I].ApptCount - (AbsIndex - Index)];\r\nend;\r\n\r\nfunction TJvTFGlanceViewer.GetDate: TDate;\r\nbegin\r\n Result := Cell.CellDate;\r\nend;\r\n\r\nfunction TJvTFGlanceViewer.GetDistinctAppt(Index: Integer): TJvTFAppt;\r\nvar\r\n ApptList: TStringList;\r\nbegin\r\n Result := nil;\r\n ApptList := TStringList.Create;\r\n try\r\n GetDistinctAppts(ApptList);\r\n if (Index < 0) or (Index >= ApptList.Count) then\r\n raise EGlanceViewerError.CreateResFmt(@RsEApptIndexOutOfBoundsd, [Index]);\r\n\r\n Result := TJvTFAppt(ApptList.Objects[Index]);\r\n finally\r\n ApptList.Free;\r\n end;\r\nend;\r\n\r\nprocedure TJvTFGlanceViewer.GetDistinctAppts(ApptList: TStringList);\r\nvar\r\n I,\r\n J: Integer;\r\n Sched: TJvTFSched;\r\n Appt: TJvTFAppt;\r\nbegin\r\n ApptList.Clear;\r\n\r\n for I := 0 to ScheduleCount - 1 do\r\n begin\r\n Sched := Schedules[I];\r\n for J := 0 to Sched.ApptCount - 1 do\r\n begin\r\n Appt := Sched.Appts[J];\r\n if ApptList.IndexOf(Appt.ID) = -1 then\r\n ApptList.AddObject(Appt.ID, Appt);\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJvTFGlanceViewer.GetSchedule(Index: Integer): TJvTFSched;\r\nbegin\r\n Result := Cell.Schedules[Index];\r\nend;\r\n\r\nprocedure TJvTFGlanceViewer.MouseAccel(X, Y: Integer);\r\nbegin\r\n // do nothing, leave implemenation to successors\r\nend;\r\n\r\nprocedure TJvTFGlanceViewer.MoveTo(ACell: TJvTFGlanceCell);\r\nbegin\r\n SetTo(ACell);\r\n FPhysicalCell := ACell;\r\n Realign;\r\nend;\r\n\r\nprocedure TJvTFGlanceViewer.Notify(Sender: TObject; Code: TJvTFServNotifyCode);\r\nbegin\r\n case Code of\r\n sncConnectControl:\r\n SetGlanceControl(TJvTFCustomGlance(Sender));\r\n sncDisconnectControl:\r\n if GlanceControl = Sender then\r\n SetGlanceControl(nil);\r\n end;\r\nend;\r\n\r\nprocedure TJvTFGlanceViewer.ParentReconfig;\r\nbegin\r\n // do nothing, leave implementation to successors\r\nend;\r\n\r\nfunction TJvTFGlanceViewer.ScheduleCount: Integer;\r\nbegin\r\n if Assigned(Cell) then\r\n Result := Cell.ScheduleCount\r\n else\r\n Result := 0;\r\nend;\r\n\r\nprocedure TJvTFGlanceViewer.SetGlanceControl(Value: TJvTFCustomGlance);\r\nbegin\r\n FGlanceControl := Value;\r\n if Assigned(FGlanceControl) then\r\n FGlanceControl.OnApptHint := DoGlanceControlApptHint;\r\nend;\r\n\r\nprocedure TJvTFGlanceViewer.SetInplaceEdit(const Value: Boolean);\r\nbegin\r\n FInPlaceEdit := Value;\r\nend;\r\n\r\nprocedure TJvTFGlanceViewer.SetRepeatGrouped(Value: Boolean);\r\nbegin\r\n if Value <> FRepeatGrouped then\r\n begin\r\n FRepeatGrouped := Value;\r\n Refresh;\r\n end;\r\nend;\r\n\r\nprocedure TJvTFGlanceViewer.SetShowSchedNamesInHint(\r\n const Value: Boolean);\r\nbegin\r\n if FShowSchedNamesInHint <> Value then\r\n begin\r\n FShowSchedNamesInHint := Value;\r\n Refresh;\r\n end;\r\nend;\r\n\r\nprocedure TJvTFGlanceViewer.SetTo(ACell: TJvTFGlanceCell);\r\nbegin\r\n FCell := ACell;\r\nend;\r\n\r\nfunction TJvTFGlanceViewer.GetAppt(Index: Integer): TJvTFAppt;\r\nbegin\r\n if RepeatGrouped then\r\n Result := GetRepeatAppt(Index)\r\n else\r\n Result := GetDistinctAppt(Index);\r\nend;\r\n\r\nfunction TJvTFGlanceViewer.CalcBoundsRect(ACell: TJvTFGlanceCell): TRect;\r\nbegin\r\n if Assigned(GlanceControl) and Assigned(ACell) then\r\n with GlanceControl do\r\n Result := CalcCellBodyRect(ACell, CellIsSelected(ACell), False)\r\n else\r\n Result := Rect(0, 0, 0, 0);\r\nend;\r\n\r\nfunction TJvTFGlanceViewer.GetApptAt(X, Y: Integer): TJvTFAppt;\r\nbegin\r\n Result := nil;\r\nend;\r\n\r\nfunction TJvTFGlanceViewer.CanEdit: Boolean;\r\nbegin\r\n Result := False;\r\nend;\r\n\r\nfunction TJvTFGlanceViewer.Editing: Boolean;\r\nbegin\r\n Result := False;\r\nend;\r\n\r\nprocedure TJvTFGlanceViewer.FinishEditAppt;\r\nbegin\r\n // do nothing, leave implementation to successors\r\nend;\r\n\r\n//=== { TJvTFGlanceFrameAttr } ===============================================\r\n\r\nprocedure TJvTFGlanceFrameAttr.Change;\r\nbegin\r\n inherited Change;\r\n if Assigned(GlanceControl) and Assigned(GlanceControl.Viewer) then\r\n GlanceControl.Viewer.Realign;\r\nend;\r\n\r\nconstructor TJvTFGlanceFrameAttr.Create(AOwner: TJvTFCustomGlance);\r\nbegin\r\n inherited Create(AOwner);\r\n FGlanceControl := AOwner;\r\nend;\r\n\r\n//=== { TJvTFTextAttr } ======================================================\r\n\r\nconstructor TJvTFTextAttr.Create;\r\nbegin\r\n inherited Create;\r\n\r\n FFont := TFont.Create;\r\n FFont.OnChange := FontChange;\r\n FAlignH := taLeftJustify;\r\n FAlignV := vaCenter;\r\nend;\r\n\r\ndestructor TJvTFTextAttr.Destroy;\r\nbegin\r\n FFont.OnChange := nil;\r\n FFont.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvTFTextAttr.Assign(Source: TPersistent);\r\nbegin\r\n if Source is TJvTFTextAttr then\r\n begin\r\n FFont.Assign(TJvTFTextAttr(Source).Font);\r\n FRotation := TJvTFTextAttr(Source).Rotation;\r\n FAlignH := TJvTFTextAttr(Source).AlignH;\r\n FAlignV := TJvTFTextAttr(Source).AlignV;\r\n DoChange;\r\n end\r\n else\r\n inherited Assign(Source);\r\nend;\r\n\r\nprocedure TJvTFTextAttr.DoChange;\r\nbegin\r\n if Assigned(FOnChange) then\r\n FOnChange(Self);\r\nend;\r\n\r\nprocedure TJvTFTextAttr.FontChange(Sender: TObject);\r\nbegin\r\n DoChange;\r\nend;\r\n\r\nprocedure TJvTFTextAttr.SetAlignH(Value: TAlignment);\r\nbegin\r\n if Value <> FAlignH then\r\n begin\r\n FAlignH := Value;\r\n DoChange;\r\n end;\r\nend;\r\n\r\nprocedure TJvTFTextAttr.SetAlignV(Value: TJvTFVAlignment);\r\nbegin\r\n if Value <> FAlignV then\r\n begin\r\n FAlignV := Value;\r\n DoChange;\r\n end;\r\nend;\r\n\r\nprocedure TJvTFTextAttr.SetFont(Value: TFont);\r\nbegin\r\n FFont.Assign(Value);\r\n DoChange;\r\nend;\r\n\r\nprocedure TJvTFTextAttr.SetRotation(Value: Integer);\r\nbegin\r\n if Value <> FRotation then\r\n begin\r\n FRotation := Value;\r\n DoChange;\r\n end;\r\nend;\r\n\r\n//=== { TJvTFCellPics } ======================================================\r\n\r\nconstructor TJvTFCellPics.Create(AGlanceCell: TJvTFGlanceCell);\r\nbegin\r\n inherited Create(TJvTFCellPic);\r\n FGlanceCell := AGlanceCell;\r\nend;\r\n\r\nfunction TJvTFCellPics.Add: TJvTFCellPic;\r\nbegin\r\n Result := TJvTFCellPic(inherited Add);\r\nend;\r\n\r\nfunction TJvTFCellPics.AddPic(const PicName: string; PicIndex: Integer): TJvTFCellPic;\r\nbegin\r\n Result := Add;\r\n Result.PicName := PicName;\r\n Result.PicIndex := PicIndex;\r\nend;\r\n\r\nprocedure TJvTFCellPics.Assign(Source: TPersistent);\r\nvar\r\n I: Integer;\r\nbegin\r\n if Source is TJvTFCellPics then\r\n begin\r\n BeginUpdate;\r\n try\r\n Clear;\r\n for I := 0 to TJvTFCellPics(Source).Count - 1 do\r\n Add.Assign(TJvTFCellPics(Source).Items[I]);\r\n finally\r\n EndUpdate;\r\n end\r\n end\r\n else\r\n inherited Assign(Source);\r\nend;\r\n\r\nfunction TJvTFCellPics.GetItem(Index: Integer): TJvTFCellPic;\r\nbegin\r\n Result := TJvTFCellPic(inherited GetItem(Index));\r\nend;\r\n\r\nfunction TJvTFCellPics.GetOwner: TPersistent;\r\nbegin\r\n Result := GlanceCell;\r\nend;\r\n\r\nfunction TJvTFCellPics.GetPicIndex(const PicName: string): Integer;\r\nvar\r\n CellPic: TJvTFCellPic;\r\nbegin\r\n Result := -1;\r\n CellPic := PicByName(PicName);\r\n if Assigned(CellPic) then\r\n Result := CellPic.PicIndex;\r\nend;\r\n\r\nfunction TJvTFCellPics.PicByName(const PicName: string): TJvTFCellPic;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := nil;\r\n I := 0;\r\n while (I < Count) and not Assigned(Result) do\r\n begin\r\n if Items[I].PicName = PicName then\r\n Result := Items[I];\r\n Inc(I);\r\n end;\r\nend;\r\n\r\nprocedure TJvTFCellPics.SetItem(Index: Integer; Value: TJvTFCellPic);\r\nbegin\r\n inherited SetItem(Index, Value);\r\nend;\r\n\r\n//=== { TJvTFCellPic } =======================================================\r\n\r\nconstructor TJvTFCellPic.Create(Collection: TCollection);\r\nbegin\r\n inherited Create(Collection);\r\n FPicIndex := -1;\r\n FHints := TStringList.Create;\r\nend;\r\n\r\ndestructor TJvTFCellPic.Destroy;\r\nbegin\r\n FHints.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvTFCellPic.Assign(Source: TPersistent);\r\nbegin\r\n if Source is TJvTFCellPic then\r\n begin\r\n FPicName := TJvTFCellPic(Source).PicName;\r\n FPicIndex := TJvTFCellPic(Source).PicIndex;\r\n Change;\r\n end\r\n else\r\n inherited Assign(Source);\r\nend;\r\n\r\nprocedure TJvTFCellPic.Change;\r\nbegin\r\n if Assigned(PicCollection.GlanceCell.CellCollection.GlanceControl) then\r\n PicCollection.GlanceCell.CellCollection.GlanceControl.Invalidate;\r\nend;\r\n\r\nfunction TJvTFCellPic.GetDisplayName: string;\r\nbegin\r\n if PicName <> '' then\r\n Result := PicName\r\n else\r\n Result := inherited GetDisplayName;\r\nend;\r\n\r\nfunction TJvTFCellPic.PicCollection: TJvTFCellPics;\r\nbegin\r\n Result := TJvTFCellPics(Collection);\r\nend;\r\n\r\nfunction TJvTFCellPic.GetHints: TStrings;\r\nbegin\r\n Result := FHints;\r\nend;\r\n\r\nprocedure TJvTFCellPic.SetHints(Value: TStrings);\r\nbegin\r\n FHints.Assign(Value);\r\nend;\r\n\r\nprocedure TJvTFCellPic.SetPicIndex(Value: Integer);\r\nbegin\r\n if Value <> FPicIndex then\r\n begin\r\n FPicIndex := Value;\r\n Change;\r\n end;\r\nend;\r\n\r\nprocedure TJvTFCellPic.SetPicName(const Value: string);\r\nbegin\r\n if Value <> FPicName then\r\n begin\r\n FPicName := Value;\r\n Change;\r\n end;\r\nend;\r\n\r\nprocedure TJvTFCellPic.SetPicPoint(X, Y: Integer);\r\nbegin\r\n FPicPoint := Point(X, Y);\r\nend;\r\n\r\n//=== { TJvTFGlanceTitlePicAttr } ============================================\r\n\r\nconstructor TJvTFGlanceTitlePicAttr.Create;\r\nbegin\r\n inherited Create;\r\n FAlignH := taLeftJustify;\r\n FAlignV := vaCenter;\r\nend;\r\n\r\nprocedure TJvTFGlanceTitlePicAttr.Assign(Source: TPersistent);\r\nbegin\r\n if Source is TJvTFGlanceTitlePicAttr then\r\n begin\r\n FAlignH := TJvTFGlanceTitlePicAttr(Source).AlignH;\r\n FAlignV := TJvTFGlanceTitlePicAttr(Source).AlignV;\r\n DoChange;\r\n end\r\n else\r\n inherited Assign(Source);\r\nend;\r\n\r\nprocedure TJvTFGlanceTitlePicAttr.DoChange;\r\nbegin\r\n if Assigned(FOnChange) then\r\n FOnChange(Self);\r\nend;\r\n\r\nprocedure TJvTFGlanceTitlePicAttr.SetAlignH(Value: TAlignment);\r\nbegin\r\n if Value <> FAlignH then\r\n begin\r\n FAlignH := Value;\r\n DoChange;\r\n end;\r\nend;\r\n\r\nprocedure TJvTFGlanceTitlePicAttr.SetAlignV(Value: TJvTFVAlignment);\r\nbegin\r\n if Value <> FAlignV then\r\n begin\r\n FAlignV := Value;\r\n DoChange;\r\n end;\r\nend;\r\n\r\n//=== { TJvTFGlance } ========================================================\r\n\r\nconstructor TJvTFGlance.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n AllowCustomDates := True;\r\nend;\r\n\r\n//=== { TJvTFGlanceMainTitle } ===============================================\r\n\r\nconstructor TJvTFGlanceMainTitle.Create(AOwner: TJvTFCustomGlance);\r\nbegin\r\n inherited Create(AOwner);\r\n FTitle := RsGlanceMainTitle;\r\nend;\r\n\r\nprocedure TJvTFGlanceMainTitle.Assign(Source: TPersistent);\r\nbegin\r\n if Source is TJvTFGlanceMainTitle then\r\n FTitle := TJvTFGlanceMainTitle(Source).Title;\r\n\r\n inherited Assign(Source);\r\nend;\r\n\r\nprocedure TJvTFGlanceMainTitle.SetTitle(const Value: string);\r\nbegin\r\n if Value <> FTitle then\r\n begin\r\n FTitle := Value;\r\n Change;\r\n end;\r\nend;\r\n\r\nprocedure TJvTFGlanceCell.SetSplitOrientation(Value: TJvTFSplitOrientation);\r\nbegin\r\n if Value <> FSplitOrientation then\r\n begin\r\n FSplitOrientation := Value;\r\n if IsSubCell then\r\n ParentCell.SplitOrientation := Value\r\n else\r\n if IsSplit then\r\n begin\r\n SubCell.SplitOrientation := Value;\r\n Change;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvTFGlanceCell.SetTitleText(const Value: string);\r\nbegin\r\n FTitleText := Value;\r\nend;\r\n\r\nprocedure TJvTFGlanceCell.Split;\r\nbegin\r\n if Assigned(CellCollection.GlanceControl) and\r\n not CellCollection.GlanceControl.AllowCustomDates and\r\n not CellCollection.Configuring then\r\n raise EJvTFGlanceError.CreateRes(@RsECellCannotBeSplit);\r\n\r\n if IsSubCell then\r\n raise EJvTFGlanceError.CreateRes(@RsEASubcellCannotBeSplit);\r\n\r\n if not IsSplit then\r\n begin\r\n FSplitRef := TJvTFGlanceCell.Create(nil);\r\n //FSplitRef := TJvTFGlanceCell.Create(CellCollection);\r\n FSplitRef.FCellCollection := CellCollection;\r\n FSplitRef.SetColIndex(ColIndex);\r\n FSplitRef.SetRowIndex(RowIndex);\r\n FSplitRef.FSplitOrientation := SplitOrientation;\r\n FSplitRef.FSplitRef := Self;\r\n FSplitRef.FIsSubCell := True;\r\n if not CellCollection.Configuring then\r\n CellCollection.ReconfigCells;\r\n end;\r\nend;\r\n\r\nprocedure TJvTFGlanceViewer.SetShowStartEndTimeInHint(const Value: Boolean);\r\nbegin\r\n if FShowStartEndTimeInHint <> Value then\r\n begin\r\n FShowStartEndTimeInHint := Value;\r\n Refresh;\r\n end;\r\nend;\r\n\r\nprocedure TJvTFGlanceViewer.DoGlanceControlApptHint(Sender: TObject;\r\n Appt: TJvTFAppt; var Handled: Boolean);\r\nbegin\r\n if Assigned(FOnApptHint) then\r\n FOnApptHint(Sender, Appt, Handled);\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend." }, { "path": "External/Jedi/Jvcl/run/JvTFGlanceTextViewer.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvTFGlanceTextViewer.PAS, released on 2003-08-01.\r\n\r\nThe Initial Developer of the Original Code is Unlimited Intelligence Limited.\r\nPortions created by Unlimited Intelligence Limited are Copyright (C) 1999-2002 Unlimited Intelligence Limited.\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\nMike Kolter (original code)\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvTFGlanceTextViewer.pas 13138 2011-10-26 23:17:50Z jfudickar $\r\n\r\nunit JvTFGlanceTextViewer;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n SysUtils, Classes, Windows, Messages, Graphics, Controls, Forms, Dialogs, StdCtrls,\r\n JvComponent,\r\n JvTFManager, JvTFGlance, JvTFUtils;\r\n\r\ntype\r\n TJvTFGlanceTextViewer = class;\r\n\r\n TJvTFGlTxtVwDrawInfo = record\r\n Cell: TJvTFGlanceCell;\r\n Font: TFont;\r\n Color: TColor;\r\n aRect: TRect;\r\n end;\r\n\r\n TJvTFGlTxtVwPointInfo = record\r\n AbsX: Integer;\r\n AbsY: Integer;\r\n AbsLineNum: Integer;\r\n RelLineNum: Integer;\r\n end;\r\n\r\n TJvDrawApptEvent = procedure(Sender: TObject; ACanvas: TCanvas; DrawInfo: TJvTFGlTxtVwDrawInfo; \r\n Appt: TJvTFAppt; Rect:TRect; var Handled: Boolean) of object;\r\n TJvApptHintEvent = procedure(Sender: TObject; Appt: TJvTFAppt; var Handled: Boolean) of object;\r\n\r\n TJvTFGVTxtEditor = class(TMemo)\r\n private\r\n FLinkedAppt: TJvTFAppt;\r\n protected\r\n FCancelEdit: Boolean;\r\n procedure DoExit; override;\r\n procedure KeyDown(var Key: Word; Shift: TShiftState); override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n property LinkedAppt: TJvTFAppt read FLinkedAppt write FLinkedAppt;\r\n end;\r\n\r\n TJvTFGVTextControl = class(TJvCustomControl)\r\n private\r\n FViewer: TJvTFGlanceTextViewer;\r\n FReplicating: Boolean;\r\n FMouseLine: Integer;\r\n FCanEdit: Boolean;\r\n FShowDDButton: Boolean;\r\n\r\n function GetGlanceControl: TJvTFCustomGlance;\r\n procedure SetTopLine(Value: Integer);\r\n function GetTopLine: Integer;\r\n procedure SetCanEdit(const Value: Boolean);\r\n procedure SetShowDDButton(const Value: Boolean);\r\n protected\r\n FMousePtInfo: TJvTFGlTxtVwPointInfo;\r\n FDDBtnRect: TRect;\r\n FMouseInControl: Boolean;\r\n FScrollUpBtnBMP: TBitmap;\r\n FScrollDnBtnBMP: TBitmap;\r\n FEditor: TJvTFGVTxtEditor;\r\n\r\n // See in MouseDown for details on usage of these three members\r\n FWasMovedTicks: Cardinal;\r\n FWasInDblClick: Boolean;\r\n FHasScrolled: Boolean;\r\n\r\n procedure MouseEnter(Control: TControl); override;\r\n procedure MouseLeave(Control: TControl); override;\r\n\r\n procedure WMEraseBkgnd(var Msg: TMessage); message WM_ERASEBKGND;\r\n procedure DoEnter; override;\r\n procedure DoExit; override;\r\n\r\n procedure SetMouseLine(Value: Integer);\r\n property MouseLine: Integer read FMouseLine write SetMouseLine;\r\n procedure UpdateDDBtnRect;\r\n\r\n procedure DblClick; override;\r\n procedure DoViewerDblClick;\r\n procedure DoViewerClick;\r\n procedure DoViewerEnter;\r\n\r\n procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;\r\n procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;\r\n procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;\r\n procedure MouseAccel(X, Y: Integer);\r\n procedure Click; override;\r\n\r\n procedure DragOver(Source: TObject; X, Y: Integer; State: TDragState;\r\n var Accept: Boolean); override;\r\n\r\n property Replicating: Boolean read FReplicating;\r\n procedure Paint; override;\r\n procedure DrawDDButton(ACanvas: TCanvas);\r\n procedure DrawArrow(ACanvas: TCanvas; aRect: TRect; Direction: TJvTFDirection);\r\n procedure DrawScrollUpBtn(ACanvas: TCanvas; aCellRect: TRect);\r\n procedure DrawScrollDnBtn(ACanvas: TCanvas; aCellRect: TRect);\r\n function GetStartEndString(Appt: TJvTFAppt): string;\r\n\r\n function CalcLineHeight: Integer;\r\n function CalcAbsLineNum(Y: Integer): Integer;\r\n function LineRect(AbsLineNum: Integer): TRect;\r\n function CalcPointInfo(X, Y: Integer): TJvTFGlTxtVwPointInfo;\r\n function RelToAbs(Rel: Integer): Integer;\r\n function AbsToRel(Abs: Integer): Integer;\r\n function FindApptAtLine(RelLineNum: Integer): TJvTFAppt;\r\n function GetApptRelLineNum(Appt: TJvTFAppt): Integer;\r\n\r\n procedure Scroll(ScrollBy: Integer);\r\n function ScrollUpBtnRect(aCellRect: TRect): TRect;\r\n function ScrollDnBtnRect(aCellRect: TRect): TRect;\r\n procedure InitScrollUpBtnBMP;\r\n procedure InitScrollDnBtnBMP;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n\r\n procedure PaintTo(ACanvas: TCanvas; DrawInfo: TJvTFGlTxtVwDrawInfo); overload;\r\n procedure SetBounds(ALeft, ATop, AWidth, AHeight: Integer); override;\r\n\r\n property Viewer: TJvTFGlanceTextViewer read FViewer;\r\n property GlanceControl: TJvTFCustomGlance read GetGlanceControl;\r\n\r\n // editor management routines\r\n //procedure EditAppt(Col, Row: Integer; Appt: TJvTFAppt);\r\n procedure EditAppt(ACell: TJvTFGlanceCell; RelLine: Integer; Appt: TJvTFAppt);\r\n procedure FinishEditAppt;\r\n function Editing: Boolean;\r\n\r\n function LineCount: Integer;\r\n function AbsLineCount: Integer;\r\n function ViewableLines: Integer;\r\n function FullViewableLines: Integer;\r\n property TopLine: Integer read GetTopLine write SetTopLine;\r\n\r\n function GetApptAt(X, Y: Integer): TJvTFAppt;\r\n function GetApptAccel(X, Y: Integer): TJvTFAppt;\r\n\r\n property CanEdit: Boolean read FCanEdit write SetCanEdit;\r\n property ShowDDButton: Boolean read FShowDDButton write SetShowDDButton default True;\r\n end;\r\n\r\n TJvTFLineDDClickEvent = procedure(Sender: TObject; LineNum: Integer) of object;\r\n\r\n TJvTFTxtVwApptAttr = class(TPersistent)\r\n private\r\n FColor: TColor;\r\n FFontColor: TColor;\r\n FOnChange: TNotifyEvent;\r\n procedure SetColor(Value: TColor);\r\n procedure SetFontColor(Value: TColor);\r\n protected\r\n procedure Change;\r\n public\r\n constructor Create(AOwner: TComponent);\r\n procedure Assign(Source: TPersistent); override;\r\n property OnChange: TNotifyEvent read FOnChange write FOnChange;\r\n published\r\n property Color: TColor read FColor write SetColor default clBlue;\r\n property FontColor: TColor read FFontColor write SetFontColor default clWhite;\r\n end;\r\n\r\n TJvTFGlTxtVwEditorAlign = (eaLine, eaCell);\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvTFGlanceTextViewer = class(TJvTFGlanceViewer)\r\n private\r\n FViewControl: TJvTFGVTextControl;\r\n FLineSpacing: Integer;\r\n FEditorAlign: TJvTFGlTxtVwEditorAlign;\r\n FOnLineDDClick: TJvTFLineDDClickEvent;\r\n FShowStartEnd: Boolean;\r\n FTopLines: TStringList;\r\n FSelApptAttr: TJvTFTxtVwApptAttr;\r\n FSelAppt: TJvTFAppt;\r\n FOnDblClick: TNotifyEvent;\r\n FOnClick: TNotifyEvent;\r\n FOnEnter: TNotifyEvent;\r\n FOnDrawAppt: TJvDrawApptEvent;\r\n\r\n procedure SetLineSpacing(Value: Integer);\r\n procedure SetSelApptAttr(Value: TJvTFTxtVwApptAttr);\r\n procedure SetEditorAlign(Value: TJvTFGlTxtVwEditorAlign);\r\n procedure SetShowStartEnd(Value: Boolean);\r\n function GetCellString(ACell: TJvTFGlanceCell): string;\r\n procedure SetShowLineDDButton(const Value: Boolean);\r\n function GetShowLineDDButton: Boolean;\r\n protected\r\n procedure SetVisible(Value: Boolean); override;\r\n procedure SetGlanceControl(Value: TJvTFCustomGlance); override;\r\n procedure SelApptAttrChange(Sender: TObject);\r\n procedure Change; virtual;\r\n procedure LineDDClick(LineNum: Integer); virtual;\r\n\r\n procedure DoDblClick(); virtual;\r\n procedure DoClick; virtual;\r\n procedure DoEnter; virtual;\r\n procedure DoDrawAppt(ACanvas: TCanvas; DrawInfo: TJvTFGlTxtVwDrawInfo;\r\n Appt: TJvTFAppt; Rect: TRect; var Handled: Boolean);\r\n\r\n procedure ParentReconfig; override;\r\n procedure SetSelAppt(Value: TJvTFAppt);\r\n procedure SetInplaceEdit(const Value: Boolean); override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n\r\n procedure Notify(Sender: TObject; Code: TJvTFServNotifyCode); override;\r\n procedure MouseAccel(X, Y: Integer); override;\r\n\r\n procedure Refresh; override;\r\n procedure Realign; override;\r\n procedure PaintTo(ACanvas: TCanvas; ACell: TJvTFGlanceCell); override;\r\n function GetDrawInfo(ACell: TJvTFGlanceCell): TJvTFGlTxtVwDrawInfo;\r\n procedure ResetTopLines;\r\n property SelAppt: TJvTFAppt read FSelAppt;\r\n\r\n procedure SetTopLine(ACell: TJvTFGlanceCell; Value: Integer);\r\n function GetTopLine(ACell: TJvTFGlanceCell): Integer;\r\n function GetApptAt(X, Y: Integer): TJvTFAppt; override;\r\n\r\n // editor management routines\r\n procedure EditAppt(ACell: TJvTFGlanceCell; RelLine: Integer; Appt: TJvTFAppt);\r\n procedure FinishEditAppt; override;\r\n function Editing: Boolean; override;\r\n function CanEdit: Boolean; override;\r\n published\r\n property LineSpacing: Integer read FLineSpacing write SetLineSpacing default 0;\r\n property OnLineDDClick: TJvTFLineDDClickEvent read FOnLineDDClick write FOnLineDDClick;\r\n property SelApptAttr: TJvTFTxtVwApptAttr read FSelApptAttr write SetSelApptAttr;\r\n property EditorAlign: TJvTFGlTxtVwEditorAlign read FEditorAlign write SetEditorAlign default eaLine;\r\n property ShowStartEnd: Boolean read FShowStartEnd write SetShowStartEnd default True;\r\n property ShowLineDDButton: Boolean read GetShowLineDDButton write SetShowLineDDButton default True;\r\n property OnDblClick: TNotifyEvent read FOnDblClick write FOnDblClick;\r\n property OnClick: TNotifyEvent read FOnClick write FOnClick;\r\n property OnEnter: TNotifyEvent read FOnEnter write FOnEnter;\r\n property OnDrawAppt: TJvDrawApptEvent read FOnDrawAppt write FOnDrawAppt;\r\n property OnApptHint;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvTFGlanceTextViewer.pas $';\r\n Revision: '$Revision: 13138 $';\r\n Date: '$Date: 2011-10-27 01:17:50 +0200 (jeu. 27 oct. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n JvResources;\r\n\r\n//=== { TJvTFGVTextControl } =================================================\r\n\r\nconstructor TJvTFGVTextControl.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n if AOwner is TJvTFGlanceTextViewer then\r\n FViewer := TJvTFGlanceTextViewer(AOwner);\r\n\r\n DoubleBuffered := True;\r\n FShowDDButton := True;\r\n\r\n FReplicating := True;\r\n FMouseLine := -1;\r\n\r\n FScrollUpBtnBMP := TBitmap.Create;\r\n InitScrollUpBtnBMP;\r\n FScrollDnBtnBMP := TBitmap.Create;\r\n InitScrollDnBtnBMP;\r\n\r\n FEditor := TJvTFGVTxtEditor.Create(Self);\r\n FEditor.Visible := False;\r\n FEditor.Parent := Self;\r\n\r\n FWasMovedTicks := 0;\r\n FWasInDblClick := False;\r\n\r\n //FEditor.Parent := Viewer.GlanceControl;\r\n // (rom) deactivated seems of no use\r\n // if FEditor.Parent = nil then\r\n // Beep;\r\nend;\r\n\r\nfunction TJvTFGVTextControl.CalcAbsLineNum(Y: Integer): Integer;\r\nbegin\r\n Result := Y div CalcLineHeight;\r\nend;\r\n\r\nprocedure TJvTFGVTextControl.DrawDDButton(ACanvas: TCanvas);\r\nbegin\r\n with ACanvas do\r\n begin\r\n Brush.Color := clBtnFace;\r\n FillRect(FDDBtnRect);\r\n\r\n DrawArrow(ACanvas, FDDBtnRect, dirDown);\r\n\r\n Pen.Color := clBlack;\r\n Polyline([FDDBtnRect.TopLeft, Point(FDDBtnRect.Right, FDDBtnRect.Top),\r\n FDDBtnRect.BottomRight, Point(FDDBtnRect.Left, FDDBtnRect.Bottom),\r\n FDDBtnRect.TopLeft]);\r\n {\r\n if Windows.PtInRect(aRect, FMouseLoc) then\r\n begin\r\n Pen.Color := clBtnHighlight;\r\n MoveTo(aRect.Left, aRect.Top);\r\n LineTo(aRect.Left, aRect.Bottom);\r\n MoveTo(aRect.Left, aRect.Top);\r\n LineTo(aRect.Right, aRect.Top);\r\n\r\n Pen.Color := clBtnShadow;\r\n MoveTo(aRect.Right - 1, aRect.Top);\r\n LineTo(aRect.Right - 1, aRect.Bottom);\r\n MoveTo(aRect.Right, aRect.Bottom - 1);\r\n LineTo(aRect.Left, aRect.Bottom - 1);\r\n end;\r\n }\r\n end;\r\nend;\r\n\r\nfunction TJvTFGVTextControl.GetGlanceControl: TJvTFCustomGlance;\r\nbegin\r\n Result := nil;\r\n if Assigned(Viewer) then\r\n Result := Viewer.GlanceControl;\r\nend;\r\n\r\nfunction TJvTFGVTextControl.CalcLineHeight: Integer;\r\nbegin\r\n Result := Canvas.TextHeight('Wq') + Viewer.LineSpacing;\r\nend;\r\n\r\nfunction TJvTFGVTextControl.LineRect(AbsLineNum: Integer): TRect;\r\nvar\r\n LineHt: Integer;\r\nbegin\r\n LineHt := CalcLineHeight;\r\n Result := ClientRect;\r\n Result.Top := LineHt * AbsLineNum;\r\n Result.Bottom := Lesser(Result.Top + LineHt, Result.Bottom);\r\nend;\r\n\r\nprocedure TJvTFGVTextControl.Paint;\r\nvar\r\n DrawInfo: TJvTFGlTxtVwDrawInfo;\r\nbegin\r\n {\r\n All drawing should be done in a PaintTo method. PaintTo should have ACanvas\r\n and aRect Params. All drawing code within PaintTo should rely solely on\r\n the ACanvas and aRect parameters given.\r\n\r\n This method (Paint) should then call PaintTo(Canvas, ClientRect) to draw the\r\n info on the viewer control. TJvTFCustomGlance.DrawCell should call\r\n PaintTo(PaintBuffer, CellBodyRect(Col, Row, Selected, False)) to draw the\r\n info on the GlanceControl.\r\n }\r\n\r\n Viewer.SetTo(Viewer.PhysicalCell);\r\n DrawInfo := Viewer.GetDrawInfo(Viewer.Cell);\r\n DrawInfo.aRect := ClientRect;\r\n\r\n FReplicating := False;\r\n try\r\n PaintTo(Canvas, DrawInfo);\r\n finally\r\n FReplicating := True;\r\n end;\r\n\r\n{\r\n // for TESTING PURPOSES ONLY!!\r\n with Canvas do\r\n begin\r\n Pen.Color := clBlack;\r\n MoveTo(0, 0);\r\n LineTo(ClientWidth, ClientHeight);\r\n end;\r\n}\r\nend;\r\n\r\nprocedure TJvTFGVTextControl.PaintTo(ACanvas: TCanvas; DrawInfo: TJvTFGlTxtVwDrawInfo);\r\nvar\r\n I, NextLineTop, LastLine, Line: Integer;\r\n aRect, LineRect, TxtRect, BtnRect: TRect;\r\n Flags: UINT;\r\n Txt: string;\r\n Appt: TJvTFAppt;\r\n RegFontColor,\r\n RegBrushColor: TColor;\r\n DrawingHandled: Boolean;\r\nbegin\r\n Viewer.SetTo(DrawInfo.Cell);\r\n\r\n with ACanvas do\r\n begin\r\n aRect := DrawInfo.aRect;\r\n\r\n //Brush.Color := Viewer.Color;\r\n Brush.Color := DrawInfo.Color;\r\n FillRect(aRect);\r\n\r\n //Font.Assign(Viewer.Font);\r\n Font.Assign(DrawInfo.Font);\r\n Self.Canvas.Font.Assign(DrawInfo.Font);\r\n\r\n RegBrushColor := Brush.Color;\r\n RegFontColor := Font.Color;\r\n\r\n NextLineTop := aRect.Top;\r\n LineRect.Left := aRect.Left;\r\n LineRect.Right := aRect.Right;\r\n\r\n //Flags := DT_LEFT or DT_NOPREFIX or DT_SINGLELINE or DT_VCENTER;\r\n Flags := DT_LEFT or DT_NOPREFIX or DT_SINGLELINE or DT_TOP;\r\n\r\n if csDesigning in ComponentState then\r\n LastLine := 2\r\n else\r\n LastLine := Lesser(ViewableLines - 1, LineCount - TopLine - 1);\r\n\r\n for I := 0 to LastLine do\r\n begin\r\n Brush.Color := RegBrushColor;\r\n Font.Color := RegFontColor;\r\n\r\n LineRect.Top := NextLineTop;\r\n LineRect.Bottom := Lesser(NextLineTop + CalcLineHeight, aRect.Bottom);\r\n\r\n if csDesigning in ComponentState then\r\n begin\r\n Txt := 'Appt ' + IntToStr(I);\r\n Appt := nil;\r\n end\r\n else\r\n begin\r\n Line := AbsToRel(I);\r\n if Line < 0 then\r\n Line := 0;\r\n if Line >= Viewer.ApptCount then\r\n Line := 0;\r\n Appt := Viewer.Appts[Line];\r\n\r\n Txt := '';\r\n if Viewer.ShowStartEnd then\r\n Txt := GetStartEndString(Appt) + ': ';\r\n Txt := Txt + StringReplace(Appt.Description, #13#10, ' ', [rfReplaceAll]);\r\n\r\n if Appt = Viewer.SelAppt then\r\n begin\r\n Brush.Color := Viewer.SelApptAttr.Color;\r\n Font.Color := Viewer.SelApptAttr.FontColor;\r\n\r\n FillRect(LineRect);\r\n\r\n if I <> 0 then\r\n begin\r\n MoveTo(aRect.Left, LineRect.Top);\r\n LineTo(aRect.Right, LineRect.Top);\r\n end;\r\n if I <> AbsLineCount - 1 then\r\n begin\r\n MoveTo(aRect.Left, LineRect.Bottom - 1);\r\n LineTo(aRect.Right, LineRect.Bottom - 1);\r\n end;\r\n end\r\n else\r\n begin\r\n if Appt.Color <> clDefault then\r\n begin\r\n Brush.Color := Appt.Color;\r\n FillRect(LineRect);\r\n end;\r\n end;\r\n end;\r\n\r\n TxtRect := LineRect;\r\n Windows.InflateRect(TxtRect, -1, -1);\r\n\r\n DrawingHandled := False;\r\n if Assigned(Viewer) then\r\n Viewer.DoDrawAppt(ACanvas, DrawInfo, Appt, LineRect, DrawingHandled);\r\n\r\n if not DrawingHandled then\r\n begin\r\n // PTxt := StrAlloc((Length(Txt) + 4) * SizeOf(Char));\r\n // StrPCopy(PTxt, Txt);\r\n // Windows.DrawText(ACanvas.Handle, PTxt, -1, TxtRect, Flags);\r\n // StrDispose(PTxt);\r\n Windows.DrawText(ACanvas.Handle, PChar(Txt), Length(Txt), TxtRect, Flags);\r\n end;\r\n\r\n Inc(NextLineTop, CalcLineHeight);\r\n end;\r\n end;\r\n\r\n if not (csDesigning in ComponentState) then\r\n begin\r\n if not Replicating and (FMousePtInfo.RelLineNum < Viewer.ApptCount) and\r\n FMouseInControl and FShowDDButton then\r\n DrawDDButton(ACanvas);\r\n\r\n BtnRect := ScrollUpBtnRect(DrawInfo.aRect);\r\n if not Windows.IsRectEmpty(BtnRect) then\r\n DrawScrollUpBtn(ACanvas, DrawInfo.aRect);\r\n\r\n BtnRect := ScrollDnBtnRect(DrawInfo.aRect);\r\n if not Windows.IsRectEmpty(BtnRect) then\r\n DrawScrollDnBtn(ACanvas, DrawInfo.aRect);\r\n\r\n {\r\n if TopLine > 0 then\r\n DrawScrollUpBtn(ACanvas, DrawInfo.aRect);\r\n\r\n BottomLine := TopLine + FullViewableLines - 1;\r\n LastLine := LineCount - 1;\r\n if BottomLine < LastLine then\r\n DrawScrollDnBtn(ACanvas, DrawInfo.aRect);\r\n }\r\n end;\r\nend;\r\n\r\nprocedure TJvTFGVTextControl.WMEraseBkgnd(var Msg: TMessage);\r\nbegin\r\n Msg.Result := LRESULT(False);\r\nend;\r\n\r\nprocedure TJvTFGVTextControl.MouseMove(Shift: TShiftState; X, Y: Integer);\r\nvar\r\n GlancePt: TPoint;\r\nbegin\r\n inherited MouseMove(Shift, X, Y);\r\n FMousePtInfo := CalcPointInfo(X, Y);\r\n MouseLine := FMousePtInfo.AbsLineNum;\r\n //SetFocus;\r\n\r\n GlancePt := Point(X, Y);\r\n GlancePt := Viewer.GlanceControl.ScreenToClient(ClientToScreen(Point(X, Y)));\r\n Viewer.GlanceControl.CheckViewerApptHint(GlancePt.X, GlancePt.Y);\r\n\r\n // for TESTING ONLY!!!\r\n //Invalidate;\r\n ////////////////////\r\nend;\r\n\r\nprocedure TJvTFGVTextControl.SetBounds(ALeft, ATop, AWidth, AHeight: Integer);\r\nbegin\r\n // If the control is being moved, we keep track of when this happened.\r\n // See in MouseUp for details of usage of this value.\r\n if (Left <> ALeft) or (Top <> ATop) then\r\n FWasMovedTicks := GetTickCount\r\n else\r\n FWasMovedTicks := 0;\r\n\r\n inherited SetBounds(ALeft, ATop, AWidth, AHeight);\r\nend;\r\n\r\nprocedure TJvTFGVTextControl.SetMouseLine(Value: Integer);\r\nbegin\r\n if Value <> FMouseLine then\r\n begin\r\n FMouseLine := Value;\r\n UpdateDDBtnRect;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvTFGVTextControl.DrawArrow(ACanvas: TCanvas; aRect: TRect;\r\n Direction: TJvTFDirection);\r\nvar\r\n I, ArrowHeight, ArrowWidth, BaseX, BaseY: Integer;\r\nbegin\r\n ArrowWidth := RectWidth(aRect) - 2;\r\n if not Odd(ArrowWidth) then\r\n Dec(ArrowWidth);\r\n ArrowHeight := (ArrowWidth + 1) div 2;\r\n\r\n case Direction of\r\n dirUp:\r\n begin\r\n BaseX := aRect.Left + RectWidth(aRect) div 2 - ArrowWidth div 2;\r\n BaseY := aRect.Top + RectHeight(aRect) div 2 + ArrowHeight div 2 - 1;\r\n\r\n for I := ArrowHeight downto 1 do\r\n with ACanvas do\r\n begin\r\n MoveTo(BaseX, BaseY);\r\n LineTo(BaseX + I * 2 - 1, BaseY);\r\n Inc(BaseX);\r\n Dec(BaseY);\r\n end;\r\n end;\r\n dirDown:\r\n begin\r\n BaseX := aRect.Left + RectWidth(aRect) div 2 - ArrowWidth div 2;\r\n BaseY := aRect.Top + RectHeight(aRect) div 2 - ArrowHeight div 2 + 1;\r\n\r\n for I := ArrowHeight downto 1 do\r\n with ACanvas do\r\n begin\r\n MoveTo(BaseX, BaseY);\r\n LineTo(BaseX + I * 2 - 1, BaseY);\r\n Inc(BaseX);\r\n Inc(BaseY);\r\n end;\r\n end;\r\n dirLeft:\r\n begin\r\n BaseX := aRect.Left + RectWidth(aRect) div 2 + ArrowHeight div 2;\r\n BaseY := aRect.Top + RectHeight(aRect) div 2 - ArrowWidth div 2;\r\n\r\n for I := ArrowHeight downto 1 do\r\n with ACanvas do\r\n begin\r\n MoveTo(BaseX, BaseY);\r\n LineTo(BaseX, BaseY + I * 2 - 1);\r\n Dec(BaseX);\r\n Inc(BaseY);\r\n end;\r\n end;\r\n else\r\n BaseX := aRect.Left + RectWidth(aRect) div 2 - ArrowHeight div 2;\r\n BaseY := aRect.Top + RectHeight(aRect) div 2 - ArrowWidth div 2;\r\n\r\n for I := ArrowHeight downto 1 do\r\n with ACanvas do\r\n begin\r\n MoveTo(BaseX, BaseY);\r\n LineTo(BaseX, BaseY + I * 2 - 1);\r\n Inc(BaseX);\r\n Inc(BaseY);\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvTFGVTextControl.UpdateDDBtnRect;\r\nbegin\r\n FDDBtnRect := LineRect(FMousePtInfo.AbsLineNum);\r\n FDDBtnRect.Right := ClientRect.Right - 1;\r\n FDDBtnRect.Left := FDDBtnRect.Right - 10;\r\n Inc(FDDBtnRect.Top, 2);\r\n Dec(FDDBtnRect.Bottom, 1);\r\nend;\r\n\r\nprocedure TJvTFGVTextControl.DoEnter;\r\nbegin\r\n inherited DoEnter;\r\n Viewer.SetSelAppt(FindApptAtLine(FMousePtInfo.RelLineNum));\r\n DoViewerEnter;\r\nend;\r\n\r\nprocedure TJvTFGVTextControl.DoExit;\r\nbegin\r\n inherited DoExit;\r\n FMouseLine := -1;\r\nend;\r\n\r\n{\r\nfunction TJvTFGVTextControl.LineCount: Integer;\r\nvar\r\n ACell: TJvTFGlanceCell;\r\n I: Integer;\r\nbegin\r\n Result := 0;\r\n ACell := Viewer.GlanceControl.Cells.Cells[Viewer.Col, Viewer.Row];\r\n\r\n for I := 0 to ACell.ScheduleCount - 1 do\r\n Inc(Result, ACell.Schedules[I].ApptCount);\r\nend;\r\n}\r\n\r\nfunction TJvTFGVTextControl.LineCount: Integer;\r\nbegin\r\n Result := Viewer.ApptCount;\r\nend;\r\n\r\nprocedure TJvTFGVTextControl.SetTopLine(Value: Integer);\r\nbegin\r\n Viewer.SetTopLine(Viewer.Cell, Value);\r\nend;\r\n\r\nfunction TJvTFGVTextControl.CalcPointInfo(X, Y: Integer): TJvTFGlTxtVwPointInfo;\r\nbegin\r\n with Result do\r\n begin\r\n AbsX := X;\r\n AbsY := Y;\r\n AbsLineNum := CalcAbsLineNum(Y);\r\n RelLineNum := TopLine + AbsLineNum;\r\n end;\r\nend;\r\n\r\nfunction TJvTFGVTextControl.ViewableLines: Integer;\r\nvar\r\n aRect: TRect;\r\nbegin\r\n aRect := GlanceControl.CalcCellBodyRect(Viewer.Cell,\r\n GlanceControl.CellIsSelected(Viewer.Cell), False);\r\n\r\n Result := RectHeight(aRect) div CalcLineHeight;\r\n if RectHeight(aRect) mod CalcLineHeight > 0 then\r\n Inc(Result);\r\nend;\r\n\r\nfunction TJvTFGVTextControl.AbsToRel(Abs: Integer): Integer;\r\nbegin\r\n Result := TopLine + Abs;\r\nend;\r\n\r\nfunction TJvTFGVTextControl.RelToAbs(Rel: Integer): Integer;\r\nbegin\r\n Result := Rel - TopLine;\r\nend;\r\n\r\nprocedure TJvTFGVTextControl.DoViewerDblClick;\r\nbegin\r\n if FHasScrolled then\r\n Exit;\r\n\r\n Viewer.DoDblClick;\r\n FWasInDblClick := True;\r\nend;\r\n\r\nprocedure TJvTFGVTextControl.DoViewerClick;\r\nbegin\r\n Viewer.DoClick;\r\nend;\r\n\r\nprocedure TJvTFGVTextControl.DoViewerEnter;\r\nbegin\r\n Viewer.DoEnter;\r\nend;\r\n\r\nprocedure TJvTFGVTextControl.DblClick;\r\nbegin\r\n if FHasScrolled then\r\n Exit;\r\n\r\n inherited DblClick;\r\n DoViewerDblClick;\r\nend;\r\n\r\nprocedure TJvTFGVTextControl.MouseDown(Button: TMouseButton;\r\n Shift: TShiftState; X, Y: Integer);\r\nvar\r\n Appt: TJvTFAppt;\r\n ticks: Cardinal;\r\nbegin\r\n inherited MouseDown(Button, Shift, X, Y);\r\n SetFocus;\r\n\r\n // In order not to trigger double clicks when clicking too fast on the\r\n // little arrows in the list, we keep track of wether or not scrolling\r\n // occured. But of course, we have to reinitialize this, and the best\r\n // Place to do it is here, in MouseDown.\r\n FHasScrolled := False;\r\n\r\n if Windows.PtInRect(ScrollDnBtnRect(ClientRect), Point(X, Y)) then\r\n Scroll(1)\r\n else\r\n if Windows.PtInRect(ScrollUpBtnRect(ClientRect), Point(X, Y)) then\r\n Scroll(-1)\r\n else\r\n begin\r\n Appt := FindApptAtLine(FMousePtInfo.RelLineNum);\r\n if Assigned(Appt) then\r\n begin\r\n if Viewer.SelAppt <> Appt then\r\n begin\r\n Viewer.SetSelAppt(Appt);\r\n Click;\r\n end;\r\n end;\r\n\r\n if Windows.PtInRect(FDDBtnRect, Point(X, Y)) and Assigned(Viewer) then\r\n begin\r\n EditAppt(Viewer.Cell, FMousePtInfo.RelLineNum, Appt);\r\n Viewer.LineDDClick(MouseLine);\r\n end\r\n else\r\n begin\r\n // When the user double clicks in a cell that is not already selected,\r\n // we are moved to the new place. As a result, the second MouseUp is\r\n // sent to us, not the grid, which result in a double click not being\r\n // triggered. In order to trigger the double click, we keep track of\r\n // the change of location in SetBounds and if we get a MouseUp event\r\n // in less than the double click time, we know it's a because of a\r\n // double click and we trigger the appropriate event.\r\n ticks := GetTickCount;\r\n if (ticks - FWasMovedTicks < GetDoubleClickTime) then\r\n begin\r\n DoViewerDblClick;\r\n end;\r\n FWasMovedTicks := 0;\r\n\r\n // only start dragging if the mouse down has not happened in the double\r\n // click window. That's because if we get a MouseDown right after a\r\n // DoubleClick, then we will never receive the MouseUp. The code below\r\n // would lead to the start of a drag of an appointment leading to potential\r\n // problems when clicking again (like dropping an non existent appointment).\r\n // To avoid this, we keep track of the fact that we went through a double\r\n // click and do nothing when we get a mouse down right after that.\r\n if not Windows.PtInRect(FDDBtnRect, Point(X, Y)) and Assigned(Appt) and\r\n not FWasInDblClick then\r\n Viewer.GlanceControl.BeginDrag(False);\r\n end;\r\n end;\r\n\r\n FWasInDblClick := False;\r\nend;\r\n\r\nprocedure TJvTFGVTextControl.MouseUp(Button: TMouseButton;\r\n Shift: TShiftState; X, Y: Integer);\r\nbegin\r\n inherited MouseUp(Button, Shift, X, Y);\r\nend;\r\n\r\nprocedure TJvTFGVTextControl.MouseEnter(Control: TControl);\r\nbegin\r\n FMouseInControl := True;\r\n inherited MouseEnter(Control);\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvTFGVTextControl.MouseLeave(Control: TControl);\r\nbegin\r\n FMouseInControl := False;\r\n inherited MouseLeave(Control);\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvTFGVTextControl.Scroll(ScrollBy: Integer);\r\nvar\r\n CurrTop: Integer;\r\nbegin\r\n CurrTop := Viewer.GetTopLine(Viewer.Cell);\r\n Viewer.SetTopLine(Viewer.Cell, CurrTop + ScrollBy);\r\n FHasScrolled := True;\r\nend;\r\n\r\nfunction TJvTFGVTextControl.GetTopLine: Integer;\r\nbegin\r\n Result := Viewer.GetTopLine(Viewer.Cell);\r\nend;\r\n\r\nfunction TJvTFGVTextControl.ScrollDnBtnRect(aCellRect: TRect): TRect;\r\nvar\r\n BtnLeft,\r\n BtnTop: Integer;\r\nbegin\r\n if TopLine + FullViewableLines - 1 < LineCount - 1 then\r\n begin\r\n Result := Rect(0, 0, FScrollDnBtnBMP.Width, FScrollDnBtnBMP.Height);\r\n BtnLeft := aCellRect.Right - 10 - RectWidth(Result);\r\n BtnTop := aCellRect.Bottom - RectHeight(Result);\r\n Windows.OffsetRect(Result, BtnLeft, BtnTop);\r\n end\r\n else\r\n Result := Rect(0, 0, 0, 0);\r\nend;\r\n\r\nfunction TJvTFGVTextControl.ScrollUpBtnRect(aCellRect: TRect): TRect;\r\nvar\r\n BtnLeft: Integer;\r\nbegin\r\n if TopLine > 0 then\r\n begin\r\n Result := Rect(0, 0, FScrollUpBtnBMP.Width, FScrollUpBtnBMP.Height);\r\n BtnLeft := aCellRect.Right - 10 - RectWidth(Result);\r\n Windows.OffsetRect(Result, BtnLeft, aCellRect.Top);\r\n end\r\n else\r\n Result := Rect(0, 0, 0, 0);\r\nend;\r\n\r\nprocedure TJvTFGVTextControl.SetCanEdit(const Value: Boolean);\r\nbegin\r\n FCanEdit := Value;\r\nend;\r\n\r\nprocedure TJvTFGVTextControl.SetShowDDButton(const Value: Boolean);\r\nbegin\r\n FShowDDButton := Value;\r\nend;\r\n\r\ndestructor TJvTFGVTextControl.Destroy;\r\nbegin\r\n FEditor.Free;\r\n FScrollUpBtnBMP.Free;\r\n FScrollDnBtnBMP.Free;\r\n\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvTFGVTextControl.InitScrollDnBtnBMP;\r\nbegin\r\n with FScrollDnBtnBMP do\r\n begin\r\n Height := 9;\r\n Width := 16;\r\n\r\n with Canvas do\r\n begin\r\n Brush.Color := clBtnFace;\r\n FillRect(Rect(0, 0, Width, Height));\r\n\r\n Pen.Color := clBlack;\r\n Polyline([Point(0, 0), Point(Width - 1, 0),\r\n Point(Width - 1, Height - 1), Point(0, Height - 1),\r\n Point(0, 0)]);\r\n\r\n MoveTo(2, 2);\r\n LineTo(14, 2);\r\n MoveTo(2, 3);\r\n LineTo(14, 3);\r\n MoveTo(7, 4);\r\n LineTo(13, 4);\r\n MoveTo(8, 5);\r\n LineTo(12, 5);\r\n MoveTo(9, 6);\r\n LineTo(11, 6);\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvTFGVTextControl.InitScrollUpBtnBMP;\r\nbegin\r\n with FScrollUpBtnBMP do\r\n begin\r\n Height := 9;\r\n Width := 16;\r\n\r\n with Canvas do\r\n begin\r\n Brush.Color := clBtnFace;\r\n FillRect(Rect(0, 0, Width, Height));\r\n\r\n Pen.Color := clBlack;\r\n Polyline([Point(0, 0), Point(Width - 1, 0),\r\n Point(Width - 1, Height - 1), Point(0, Height - 1),\r\n Point(0, 0)]);\r\n\r\n MoveTo(9, 2);\r\n LineTo(11, 2);\r\n MoveTo(8, 3);\r\n LineTo(12, 3);\r\n MoveTo(7, 4);\r\n LineTo(13, 4);\r\n MoveTo(2, 5);\r\n LineTo(14, 5);\r\n MoveTo(2, 6);\r\n LineTo(14, 6);\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvTFGVTextControl.DrawScrollDnBtn(ACanvas: TCanvas; aCellRect: TRect);\r\nvar\r\n aRect: TRect;\r\nbegin\r\n aRect := ScrollDnBtnRect(aCellRect);\r\n Windows.BitBlt(ACanvas.Handle, aRect.Left, aRect.Top, RectWidth(aRect),\r\n RectHeight(aRect), FScrollDnBtnBMP.Canvas.Handle, 0, 0, SRCCOPY);\r\nend;\r\n\r\nprocedure TJvTFGVTextControl.DrawScrollUpBtn(ACanvas: TCanvas; aCellRect: TRect);\r\nvar\r\n aRect: TRect;\r\nbegin\r\n aRect := ScrollUpBtnRect(aCellRect);\r\n Windows.BitBlt(ACanvas.Handle, aRect.Left, aRect.Top, RectWidth(aRect),\r\n RectHeight(aRect), FScrollUpBtnBMP.Canvas.Handle, 0, 0, SRCCOPY);\r\nend;\r\n\r\nfunction TJvTFGVTextControl.FullViewableLines: Integer;\r\nvar\r\n aRect: TRect;\r\nbegin\r\n aRect := GlanceControl.CalcCellBodyRect(Viewer.Cell,\r\n GlanceControl.CellIsSelected(Viewer.Cell), False);\r\n\r\n Result := RectHeight(aRect) div CalcLineHeight;\r\nend;\r\n\r\n{\r\nprocedure TJvTFGVTextControl.EditAppt(Col, Row: Integer; Appt: TJvTFAppt);\r\nvar\r\n EditLine: Integer;\r\n EditorRect: TRect;\r\nbegin\r\n EditLine := RelToAbs(GetApptRelLineNum(Appt));\r\n if not Assigned(Appt) or not CanEdit or\r\n ((EditLine < 0) or (EditLine > AbsLineCount)) then\r\n Exit;\r\n\r\n Viewer.EnsureCol(Col);\r\n Viewer.EnsureRow(Row);\r\n if (Viewer.Col <> Col) or (Viewer.Row <> Row) then\r\n Viewer.MoveTo(Col, Row);\r\n\r\n if Viewer.EditorAlign = eaLine then\r\n begin\r\n EditorRect := LineRect(EditLine);\r\n FEditor.WordWrap := False;\r\n FEditor.BorderStyle := bsSingle;\r\n end\r\n else\r\n begin\r\n EditorRect := ClientRect;\r\n FEditor.WordWrap := True;\r\n FEditor.BorderStyle := bsNone;\r\n end;\r\n\r\n with FEditor do\r\n begin\r\n LinkedAppt := Appt;\r\n Color := Viewer.SelApptAttr.Color;\r\n Font := Viewer.GlanceControl.SelCellAttr.Font;\r\n Font.Color := Viewer.SelApptAttr.FontColor;\r\n BoundsRect := EditorRect;\r\n\r\n Text := Appt.Description;\r\n {\r\n if agoFormattedDesc in Options then\r\n Text := Appt.Description\r\n else\r\n Text := StripCRLF(Appt.Description);\r\n }\r\n\r\n{ //Self.Update; // not calling update here increases flicker\r\n Visible := True;\r\n SetFocus;\r\n SelLength := 0;\r\n SelStart := 0;\r\n end;\r\nend;\r\n}\r\n\r\nprocedure TJvTFGVTextControl.EditAppt(ACell: TJvTFGlanceCell; RelLine: Integer; Appt: TJvTFAppt);\r\nvar\r\n EditLine: Integer;\r\n EditorRect: TRect;\r\nbegin\r\n //EditLine := RelToAbs(GetApptRelLineNum(Appt));\r\n EditLine := RelToAbs(RelLine);\r\n if not Assigned(Appt) or not CanEdit or\r\n ((EditLine < 0) or (EditLine > AbsLineCount)) then\r\n Exit;\r\n\r\n Viewer.MoveTo(ACell);\r\n\r\n if Viewer.EditorAlign = eaLine then\r\n begin\r\n EditorRect := LineRect(EditLine);\r\n FEditor.WordWrap := False;\r\n FEditor.BorderStyle := bsSingle;\r\n end\r\n else\r\n begin\r\n EditorRect := ClientRect;\r\n FEditor.WordWrap := True;\r\n FEditor.BorderStyle := bsNone;\r\n end;\r\n\r\n with FEditor do\r\n begin\r\n LinkedAppt := Appt;\r\n Color := Viewer.SelApptAttr.Color;\r\n Font := Viewer.GlanceControl.SelCellAttr.Font;\r\n Font.Color := Viewer.SelApptAttr.FontColor;\r\n BoundsRect := EditorRect;\r\n\r\n Text := Appt.Description;\r\n {\r\n if agoFormattedDesc in Options then\r\n Text := Appt.Description\r\n else\r\n Text := StripCRLF(Appt.Description);\r\n }\r\n\r\n //Self.Update; // not calling update here increases flicker\r\n Visible := True;\r\n SetFocus;\r\n SelLength := 0;\r\n SelStart := 0;\r\n end;\r\nend;\r\n\r\n\r\nfunction TJvTFGVTextControl.Editing: Boolean;\r\nbegin\r\n Result := FEditor.Visible;\r\nend;\r\n\r\nprocedure TJvTFGVTextControl.FinishEditAppt;\r\nbegin\r\n if Assigned(FEditor.LinkedAppt) then\r\n FEditor.LinkedAppt.Description := FEditor.Text;\r\n FEditor.Visible := False;\r\nend;\r\n\r\nfunction TJvTFGVTextControl.FindApptAtLine(RelLineNum: Integer): TJvTFAppt;\r\nbegin\r\n if Assigned(Viewer) and\r\n (RelLineNum >= 0) and (RelLineNum < Viewer.ApptCount) then\r\n Result := Viewer.Appts[RelLineNum]\r\n else\r\n Result := nil;\r\nend;\r\n\r\nfunction TJvTFGVTextControl.GetApptRelLineNum(Appt: TJvTFAppt): Integer;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := -1;\r\n if not Assigned(Appt) then\r\n Exit;\r\n\r\n I := 0;\r\n while (I < Viewer.ApptCount) and (Result = -1) do\r\n if Viewer.Appts[I] = Appt then\r\n Result := I\r\n else\r\n Inc(I);\r\nend;\r\n\r\nfunction TJvTFGVTextControl.AbsLineCount: Integer;\r\nbegin\r\n //Result := Lesser(ViewableLines - 1, LineCount - TopLine - 1);\r\n Result := RectHeight(ClientRect) div CalcLineHeight;\r\n if RectHeight(ClientRect) mod CalcLineHeight > 0 then\r\n Inc(Result);\r\nend;\r\n\r\nprocedure TJvTFGVTextControl.MouseAccel(X, Y: Integer);\r\nvar\r\n Appt: TJvTFAppt;\r\nbegin\r\n Appt := GetApptAccel(X, Y);\r\n if Assigned(Appt) then\r\n Viewer.SetSelAppt(Appt);\r\nend;\r\n\r\nprocedure TJvTFGVTextControl.Click;\r\nbegin\r\n DoViewerClick;\r\nend;\r\n\r\nfunction TJvTFGVTextControl.GetStartEndString(Appt: TJvTFAppt): string;\r\nvar\r\n ShowDates: Boolean;\r\n DateFormat,\r\n TimeFormat: string;\r\nbegin\r\n ShowDates := (Trunc(Appt.StartDate) <> Trunc(Viewer.Date)) or\r\n (Trunc(Appt.EndDate) <> Trunc(Viewer.Date));\r\n DateFormat := Viewer.GlanceControl.DateFormat;\r\n TimeFormat := Viewer.GlanceControl.TimeFormat;\r\n\r\n Result := '';\r\n if ShowDates then\r\n Result := FormatDateTime(DateFormat, Appt.StartDate) + ' ';\r\n\r\n Result := Result + FormatDateTime(TimeFormat, Appt.StartTime) + ' - ';\r\n\r\n if ShowDates then\r\n Result := Result + FormatDateTime(DateFormat, Appt.EndDate) + ' ';\r\n\r\n Result := Result + FormatDateTime(TimeFormat, Appt.EndTime);\r\nend;\r\n\r\nfunction TJvTFGVTextControl.GetApptAccel(X, Y: Integer): TJvTFAppt;\r\nvar\r\n LocalPt: TPoint;\r\nbegin\r\n LocalPt := ScreenToClient(Viewer.GlanceControl.ClientToScreen(Point(X, Y)));\r\n Result := GetApptAt(LocalPt.X, LocalPt.Y);\r\nend;\r\n\r\nfunction TJvTFGVTextControl.GetApptAt(X, Y: Integer): TJvTFAppt;\r\nvar\r\n PtInfo: TJvTFGlTxtVwPointInfo;\r\nbegin\r\n PtInfo := CalcPointInfo(X, Y);\r\n Result := FindApptAtLine(PtInfo.RelLineNum);\r\nend;\r\n\r\nprocedure TJvTFGVTextControl.DragOver(Source: TObject; X, Y: Integer;\r\n State: TDragState; var Accept: Boolean);\r\nbegin\r\n inherited DragOver(Source, X, Y, State, Accept);\r\n if Source is TJvTFControl then\r\n Viewer.Visible := False;\r\nend;\r\n\r\n//=== { TJvTFGlanceTextViewer } ==============================================\r\n\r\nconstructor TJvTFGlanceTextViewer.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n\r\n FTopLines := TStringList.Create;\r\n FViewControl := TJvTFGVTextControl.Create(Self);\r\n FSelApptAttr := TJvTFTxtVwApptAttr.Create(Self);\r\n FSelApptAttr.OnChange := SelApptAttrChange;\r\n FEditorAlign := eaLine;\r\n FShowStartEnd := True;\r\nend;\r\n\r\ndestructor TJvTFGlanceTextViewer.Destroy;\r\nbegin\r\n FViewControl.Free;\r\n FTopLines.Free;\r\n FSelApptAttr.OnChange := nil;\r\n FSelApptAttr.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvTFGlanceTextViewer.Change;\r\nbegin\r\n Refresh;\r\nend;\r\n\r\nprocedure TJvTFGlanceTextViewer.SetEditorAlign(Value: TJvTFGlTxtVwEditorAlign);\r\nbegin\r\n FEditorAlign := Value;\r\nend;\r\n\r\nfunction TJvTFGlanceTextViewer.GetDrawInfo(ACell: TJvTFGlanceCell): TJvTFGlTxtVwDrawInfo;\r\nvar\r\n Attr: TJvTFGlanceCellAttr;\r\nbegin\r\n if not Assigned(GlanceControl) then\r\n raise EGlanceViewerError.CreateRes(@RsEGlanceControlNotAssigned);\r\n\r\n with Result do\r\n begin\r\n Cell := ACell;\r\n Attr := GlanceControl.GetCellAttr(ACell);\r\n Font := Attr.Font;\r\n Color := Attr.Color;\r\n aRect := GlanceControl.CalcCellBodyRect(ACell,\r\n GlanceControl.CellIsSelected(ACell), False);\r\n end;\r\nend;\r\n\r\nfunction TJvTFGlanceTextViewer.GetTopLine(ACell: TJvTFGlanceCell): Integer;\r\nvar\r\n I: Integer;\r\nbegin\r\n I := FTopLines.IndexOf(GetCellString(ACell));\r\n if I > -1 then\r\n Result := Integer(FTopLines.Objects[I])\r\n else\r\n Result := 0;\r\nend;\r\n\r\nprocedure TJvTFGlanceTextViewer.LineDDClick(LineNum: Integer);\r\nbegin\r\n if Assigned(FOnLineDDClick) then\r\n FOnLineDDClick(Self, LineNum);\r\nend;\r\n\r\nprocedure TJvTFGlanceTextViewer.DoDblClick;\r\nbegin\r\n if Assigned(FOnDblClick) then\r\n FOnDblClick(Self);\r\nend;\r\n\r\nprocedure TJvTFGlanceTextViewer.DoClick;\r\nbegin\r\n if Assigned(FOnClick) then\r\n FOnClick(Self);\r\nend;\r\n\r\nprocedure TJvTFGlanceTextViewer.DoEnter;\r\nbegin\r\n if Assigned(FOnEnter) then\r\n FOnEnter(Self);\r\nend;\r\n\r\nprocedure TJvTFGlanceTextViewer.MouseAccel(X, Y: Integer);\r\nbegin\r\n inherited MouseAccel(X, Y);\r\n FViewControl.MouseAccel(X, Y);\r\n DoClick;\r\nend;\r\n\r\nprocedure TJvTFGlanceTextViewer.Notify(Sender: TObject;\r\n Code: TJvTFServNotifyCode);\r\nbegin\r\n inherited Notify(Sender, Code);\r\nend;\r\n\r\nprocedure TJvTFGlanceTextViewer.PaintTo(ACanvas: TCanvas; ACell: TJvTFGlanceCell);\r\nbegin\r\n FViewControl.PaintTo(ACanvas, GetDrawInfo(ACell));\r\nend;\r\n\r\nprocedure TJvTFGlanceTextViewer.ParentReconfig;\r\nbegin\r\n inherited ParentReconfig;\r\n FTopLines.Clear;\r\nend;\r\n\r\nprocedure TJvTFGlanceTextViewer.Realign;\r\nbegin\r\n if not Assigned(GlanceControl) then\r\n Exit;\r\n\r\n FViewControl.BoundsRect := CalcBoundsRect(Cell);\r\n if not FViewControl.Replicating then\r\n SetSelAppt(nil);\r\nend;\r\n\r\nprocedure TJvTFGlanceTextViewer.Refresh;\r\nbegin\r\n FViewControl.Invalidate;\r\nend;\r\n\r\nprocedure TJvTFGlanceTextViewer.ResetTopLines;\r\nbegin\r\n FTopLines.Clear;\r\n GlanceControl.Invalidate;\r\nend;\r\n\r\nprocedure TJvTFGlanceTextViewer.SelApptAttrChange(Sender: TObject);\r\nbegin\r\n //Change;\r\n FViewControl.Invalidate;\r\nend;\r\n\r\nprocedure TJvTFGlanceTextViewer.SetGlanceControl(Value: TJvTFCustomGlance);\r\nbegin\r\n inherited SetGlanceControl(Value);\r\n FViewControl.Parent := Value;\r\nend;\r\n\r\nprocedure TJvTFGlanceTextViewer.SetInplaceEdit(const Value: Boolean);\r\nbegin\r\n inherited SetInplaceEdit(Value);\r\n\r\n FViewControl.CanEdit := InPlaceEdit;\r\n FViewControl.Invalidate;\r\nend;\r\n\r\nprocedure TJvTFGlanceTextViewer.SetLineSpacing(Value: Integer);\r\nbegin\r\n //Value := Greater(Value, 0);\r\n if Value <> FLineSpacing then\r\n begin\r\n FLineSpacing := Value;\r\n Change;\r\n end;\r\nend;\r\n\r\nprocedure TJvTFGlanceTextViewer.SetSelAppt(Value: TJvTFAppt);\r\nbegin\r\n FSelAppt := Value;\r\n FViewControl.Invalidate;\r\nend;\r\n\r\nprocedure TJvTFGlanceTextViewer.SetSelApptAttr(Value: TJvTFTxtVwApptAttr);\r\nbegin\r\n FSelApptAttr.Assign(Value);\r\nend;\r\n\r\nprocedure TJvTFGlanceTextViewer.SetTopLine(ACell: TJvTFGlanceCell; Value: Integer);\r\nvar\r\n I: Integer;\r\n CellStr: string;\r\nbegin\r\n Value := Greater(Value, 0);\r\n Value := Lesser(Value, ApptCount - 1);\r\n\r\n // bug fix - this effectively hides the hint window. The showing/hiding\r\n // of the hint window was causing the viewer to be positioned at the\r\n // wrong cell due to repainting as the hint window would hide/show.\r\n GlanceControl.CheckViewerApptHint(-1, -1);\r\n\r\n CellStr := GetCellString(ACell);\r\n I := FTopLines.IndexOf(CellStr);\r\n if I > -1 then\r\n if Value = 0 then\r\n FTopLines.Delete(I)\r\n else\r\n FTopLines.Objects[I] := TObject(Value)\r\n else\r\n if Value <> 0 then\r\n FTopLines.AddObject(CellStr, TObject(Value));\r\n Refresh;\r\nend;\r\n\r\nprocedure TJvTFGlanceTextViewer.SetVisible(Value: Boolean);\r\nbegin\r\n // MORE STUFF NEEDS TO BE ADDED HERE!\r\n FViewControl.Visible := Value;\r\nend;\r\n\r\nprocedure TJvTFGlanceTextViewer.SetShowStartEnd(Value: Boolean);\r\nbegin\r\n if Value <> FShowStartEnd then\r\n begin\r\n FShowStartEnd := Value;\r\n if not (csLoading in ComponentState) then\r\n begin\r\n GlanceControl.Invalidate;\r\n FViewControl.Invalidate;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJvTFGlanceTextViewer.GetApptAt(X, Y: Integer): TJvTFAppt;\r\nbegin\r\n Result := FViewControl.GetApptAt(X, Y);\r\nend;\r\n\r\nfunction TJvTFGlanceTextViewer.CanEdit: Boolean;\r\nbegin\r\n Result := FViewControl.CanEdit and InPlaceEdit;\r\nend;\r\n\r\nprocedure TJvTFGlanceTextViewer.EditAppt(ACell: TJvTFGlanceCell; RelLine: Integer;\r\n Appt: TJvTFAppt);\r\nbegin\r\n FViewControl.EditAppt(ACell, RelLine, Appt);\r\nend;\r\n\r\nfunction TJvTFGlanceTextViewer.Editing: Boolean;\r\nbegin\r\n Result := FViewControl.Editing;\r\nend;\r\n\r\nprocedure TJvTFGlanceTextViewer.FinishEditAppt;\r\nbegin\r\n FViewControl.FinishEditAppt;\r\nend;\r\n\r\nfunction TJvTFGlanceTextViewer.GetCellString(ACell: TJvTFGlanceCell): string;\r\nbegin\r\n Result := '';\r\n if Assigned(ACell) then\r\n begin\r\n Result := IntToStr(ACell.ColIndex) + ',' + IntToStr(ACell.RowIndex);\r\n if ACell.IsSubcell then\r\n Result := Result + 'S';\r\n end;\r\nend;\r\n\r\nfunction TJvTFGlanceTextViewer.GetShowLineDDButton: Boolean;\r\nbegin\r\n Result := FViewControl.ShowDDButton;\r\nend;\r\n\r\nprocedure TJvTFGlanceTextViewer.DoDrawAppt(ACanvas: TCanvas;\r\n DrawInfo: TJvTFGlTxtVwDrawInfo; Appt: TJvTFAppt; Rect: TRect; var Handled: Boolean);\r\nbegin\r\n if Assigned(FOnDrawAppt) then\r\n FOnDrawAppt(Self, ACanvas, DrawInfo, Appt, Rect, Handled);\r\nend;\r\n\r\nprocedure TJvTFGlanceTextViewer.SetShowLineDDButton(const Value: Boolean);\r\nbegin\r\n FViewControl.ShowDDButton := Value;\r\nend;\r\n\r\n//=== { TJvTFGVTxtEditor } ===================================================\r\n\r\nconstructor TJvTFGVTxtEditor.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n\r\n ControlStyle := ControlStyle + [csNoDesignVisible];\r\n\r\n ParentCtl3D := False;\r\n Ctl3D := False;\r\nend;\r\n\r\ndestructor TJvTFGVTxtEditor.Destroy;\r\nbegin\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvTFGVTxtEditor.DoExit;\r\nbegin\r\n inherited DoExit;\r\n try\r\n if not FCancelEdit then\r\n TJvTFGVTextControl(Owner).FinishEditAppt;\r\n finally\r\n FCancelEdit := False;\r\n Parent.SetFocus;\r\n end;\r\nend;\r\n\r\nprocedure TJvTFGVTxtEditor.KeyDown(var Key: Word; Shift: TShiftState);\r\nbegin\r\n inherited KeyDown(Key, Shift);\r\n\r\n if Key = VK_ESCAPE then\r\n begin\r\n FCancelEdit := True;\r\n Key := 0;\r\n Visible := False;\r\n end\r\n else\r\n if (Key = VK_RETURN) and (ssCtrl in Shift) then\r\n TJvTFGVTextControl(Owner).FinishEditAppt;\r\nend;\r\n\r\n//=== { TJvTFTxtVwApptAttr } =================================================\r\n\r\nconstructor TJvTFTxtVwApptAttr.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create;\r\n FColor := clBlue;\r\n FFontColor := clWhite;\r\nend;\r\n\r\nprocedure TJvTFTxtVwApptAttr.Assign(Source: TPersistent);\r\nbegin\r\n if Source is TJvTFTxtVwApptAttr then\r\n begin\r\n FColor := TJvTFTxtVwApptAttr(Source).Color;\r\n FFontColor := TJvTFTxtVwApptAttr(Source).FontColor;\r\n Change;\r\n end\r\n else\r\n inherited Assign(Source);\r\nend;\r\n\r\nprocedure TJvTFTxtVwApptAttr.Change;\r\nbegin\r\n if Assigned(FOnChange) then\r\n FOnChange(Self);\r\nend;\r\n\r\nprocedure TJvTFTxtVwApptAttr.SetColor(Value: TColor);\r\nbegin\r\n if Value <> FColor then\r\n begin\r\n FColor := Value;\r\n Change;\r\n end;\r\nend;\r\n\r\nprocedure TJvTFTxtVwApptAttr.SetFontColor(Value: TColor);\r\nbegin\r\n if Value <> FFontColor then\r\n begin\r\n FFontColor := Value;\r\n Change;\r\n end;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend." }, { "path": "External/Jedi/Jvcl/run/JvTFManager.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvTFManager.PAS, released on 2003-08-01.\r\n\r\nThe Initial Developer of the Original Code is Unlimited Intelligence Limited.\r\nPortions created by Unlimited Intelligence Limited are Copyright (C) 1999-2002 Unlimited Intelligence Limited.\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\nMike Kolter (original code)\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvTFManager.pas 13138 2011-10-26 23:17:50Z jfudickar $\r\n\r\nunit JvTFManager;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Classes, SysUtils, Windows, Controls, Messages,\r\n Graphics, ImgList, ExtCtrls, Printers,\r\n JvComponentBase, JvComponent, JvTypes,\r\n JvTFUtils;\r\n\r\nconst\r\n CN_REQUESTREFRESH = $BD01;\r\n\r\ntype\r\n // Redeclaration of this type. It is used in JvTFMonths.TJvTFDrawDWTitleEvent.\r\n // If not redeclared here, Delphi complains of 'unknown type' because it\r\n // will not automatically bring in 'JvTFUtils' into the uses clause when\r\n // a TJvTFDrawDWTitleEvent prototype is created.\r\n TTFDayOfWeek = JvTFUtils.TTFDayOfWeek;\r\n EJvTFScheduleManagerError = class(Exception);\r\n\r\n TJvTFTimeRange = record\r\n StartTime: TTime;\r\n EndTime: TTime;\r\n end;\r\n\r\n TJvTFServNotifyCode = (sncDestroyAppt,\r\n sncDestroySchedule,\r\n sncLoadAppt,\r\n sncSchedLoadAppt,\r\n sncSchedUnloadAppt,\r\n sncPostAppt,\r\n sncDeleteAppt,\r\n sncRequestSchedule,\r\n sncReleaseSchedule,\r\n sncConnectComponent,\r\n sncDisconnectComponent,\r\n sncConnectControl,\r\n sncDisconnectControl,\r\n sncConnectAppt,\r\n sncDisconnectAppt,\r\n sncRefresh);\r\n\r\n TJvTFScheduleManager = class;\r\n {$M+}\r\n TJvTFSched = class;\r\n {$M-}\r\n TJvTFAppt = class;\r\n TJvTFComponent = class;\r\n TJvTFControl = class;\r\n TJvTFPrinter = class;\r\n TJvTFHint = class;\r\n // TJvTFNavigator = class;\r\n\r\n TJvTFSchedClass = class of TJvTFSched;\r\n TJvTFApptClass = class of TJvTFAppt;\r\n TJvTFHintClass = class of TJvTFHint;\r\n\r\n TCNRequestRefresh = record\r\n Msg: Cardinal;\r\n Schedule: TJvTFSched;\r\n Unused: Longint;\r\n Result: Longint;\r\n end;\r\n\r\n TJvTFDateList = class\r\n private\r\n FOnChange: TNotifyEvent;\r\n protected\r\n FList: TStringList;\r\n function GetDate(Index: Integer): TDate;\r\n procedure Change; virtual;\r\n public\r\n constructor Create;\r\n destructor Destroy; override;\r\n function Add(ADate: TDate): Integer;\r\n procedure Delete(Index: Integer);\r\n procedure Clear;\r\n function Count: Integer;\r\n function IndexOf(ADate: TDate): Integer;\r\n property Dates[Index: Integer]: TDate read GetDate; default;\r\n property OnChange: TNotifyEvent read FOnChange write FOnChange;\r\n end;\r\n\r\n TJvTFNavEvent = procedure(Sender: TObject; aControl: TJvTFControl;\r\n SchedNames: TStringList; Dates: TJvTFDateList) of object;\r\n TJvTFControlEvent = procedure(Sender: TObject; aControl: TJvTFControl) of object;\r\n TJvTFSchedEvent = procedure(Sender: TObject; Schedule: TJvTFSched) of object;\r\n TJvTFApptEvent = procedure(Sender: TObject; Appt: TJvTFAppt) of object;\r\n TJvTFVarApptEvent = procedure(Sender: TObject; var Appt: TJvTFAppt) of object;\r\n TJvTFFlushEvent = procedure(Sender, FlushObj: TObject; var FlushIt: Boolean) of object;\r\n\r\n // implicit post fix\r\n TJvTFPostApptQueryEvent = procedure(Sender: TObject; Appt: TJvTFAppt;\r\n var CanPost: Boolean) of object;\r\n\r\n TJvTFCustomImageMap = class(TPersistent)\r\n private\r\n FMap: TStringList;\r\n function GetImage(MapIndex: Integer): Integer;\r\n procedure SetImage(MapIndex: Integer; Value: Integer);\r\n function GetImageName(MapIndex: Integer): string;\r\n protected\r\n FAppt: TJvTFAppt;\r\n procedure Change;\r\n public\r\n constructor Create(anAppt: TJvTFAppt);\r\n destructor Destroy; override;\r\n property Images[MapIndex: Integer]: Integer read GetImage write SetImage; default;\r\n property ImageNames[MapIndex: Integer]: string read GetImageName;\r\n function Count: Integer;\r\n procedure Add(const ImageName: string; ImageIndex: Integer);\r\n procedure Delete(MapIndex: Integer);\r\n procedure Move(SrcMapIndex, DestMapIndex: Integer);\r\n function FindMapIndex(const ImageName: string): Integer;\r\n function FindImageIndex(const ImageName: string): Integer;\r\n procedure Clear;\r\n procedure Assign(Source: TPersistent); override;\r\n end;\r\n\r\n TJvTFStatePic = (spAlarmEnabled, spAlarmDisabled, spShared, spRecurring,\r\n spModified);\r\n\r\n TJvTFStateImageMap = class(TPersistent)\r\n private\r\n FPics: array[Low(TJvTFStatePic)..High(TJvTFStatePic)] of Integer;\r\n\r\n procedure SetImage(StatePicID: TJvTFStatePic; Value: Integer);\r\n function GetImage(StatePicID: TJvTFStatePic): Integer;\r\n function GetAlarmDisabled: Integer;\r\n function GetAlarmEnabled: Integer;\r\n function GetModified: Integer;\r\n function GetRecurring: Integer;\r\n function GetShared: Integer;\r\n procedure SetAlarmDisabled(const Value: Integer);\r\n procedure SetAlarmEnabled(const Value: Integer);\r\n procedure SetModified(const Value: Integer);\r\n procedure SetRecurring(const Value: Integer);\r\n procedure SetShared(const Value: Integer);\r\n protected\r\n FScheduleManager: TJvTFScheduleManager;\r\n FUpdating: Boolean;\r\n procedure Change;\r\n public\r\n constructor Create(Serv: TJvTFScheduleManager);\r\n procedure BeginUpdate;\r\n procedure EndUpdate;\r\n procedure Clear;\r\n procedure Assign(Source: TPersistent); override;\r\n property Pics[Index: TJvTFStatePic]: Integer read GetImage write SetImage;\r\n published\r\n property AlarmEnabled: Integer {index spAlarmEnabled}\r\n read GetAlarmEnabled write SetAlarmEnabled;\r\n property AlarmDisabled: Integer {index spAlarmDisabled}\r\n read GetAlarmDisabled write SetAlarmDisabled;\r\n property Shared: Integer {index spShared}\r\n read GetShared write SetShared;\r\n property Recurring: Integer {index spRecurring}\r\n read GetRecurring write SetRecurring;\r\n //read GetImage write SetImage;\r\n property Modified: Integer {index spModified}\r\n read GetModified write SetModified;\r\n end;\r\n\r\n TDynTimeRangeArray = array of TJvTFTimeRange;\r\n\r\n TDynApptArray = array of TJvTFAppt;\r\n\r\n TDynSchedArray = array of TJvTFSched;\r\n\r\n TJvTFAppt = class(TPersistent)\r\n private\r\n FStartDate: TDate;\r\n FEndDate: TDate;\r\n FStartTime: TTime;\r\n FEndTime: TTime;\r\n FDescription: string;\r\n FAlarmEnabled: Boolean;\r\n FAlarmAdvance: Integer;\r\n FImageMap: TJvTFCustomImageMap;\r\n FData: Integer;\r\n FPersistent: Boolean;\r\n FColor: TColor;\r\n FBarColor: TColor;\r\n FRefreshed: Boolean;\r\n FGlyph: TPicture;\r\n FDestroying: Boolean;\r\n\r\n function GetDescription: string;\r\n procedure SetDescription(Value: string);\r\n procedure SetAlarmEnabled(Value: Boolean);\r\n procedure SetAlarmAdvance(Value: Integer);\r\n procedure SetColor(Value: TColor);\r\n procedure SetBarColor(Value: TColor);\r\n function GetStartDateTime: TDateTime;\r\n function GetEndDateTime: TDateTime;\r\n function GetStartDate: TDate;\r\n function GetEndDate: TDate;\r\n function GetStartTime: TTime;\r\n function GetEndTime: TTime;\r\n procedure SetRefreshed(Value: Boolean);\r\n procedure SetGlyph(const Value: TPicture);\r\n protected\r\n FID: string;\r\n FModified: Boolean;\r\n FScheduleManager: TJvTFScheduleManager;\r\n FConnections: TStringList;\r\n FSchedules: TStringList;\r\n FDeleting: Boolean;\r\n // implicit post fix\r\n FUpdating: Boolean;\r\n\r\n procedure Notify(Sender: TObject; Code: TJvTFServNotifyCode);\r\n procedure NotifyManager(Serv: TJvTFScheduleManager; Sender: TObject;\r\n Code: TJvTFServNotifyCode);\r\n procedure NotifySchedule(Sched: TJvTFSched; Sender: TObject;\r\n Code: TJvTFServNotifyCode);\r\n\r\n function GetConnection(Index: Integer): TJvTFSched;\r\n function GetSchedule(Index: Integer): string;\r\n procedure CheckConnections;\r\n\r\n procedure Connect(Schedule: TJvTFSched);\r\n procedure Disconnect(Schedule: TJvTFSched);\r\n procedure Change;\r\n procedure InternalClearSchedules;\r\n procedure DeleteApptNotification;\r\n // implicit post fix\r\n procedure PostApptNotification;\r\n procedure RefreshNotification;\r\n\r\n property Destroying: Boolean read FDestroying;\r\n public\r\n constructor Create(Serv: TJvTFScheduleManager; const ApptID: string); virtual;\r\n destructor Destroy; override;\r\n\r\n procedure Assign(Source: TPersistent); override;\r\n procedure SetStartEnd(NewStartDate: TDate; NewStartTime: TTime;\r\n NewEndDate: TDate; NewEndTime: TTime);\r\n\r\n procedure SetModified;\r\n function Modified: Boolean; dynamic;\r\n property ScheduleManager: TJvTFScheduleManager read FScheduleManager;\r\n\r\n function ConnectionCount: Integer;\r\n property Connections[Index: Integer]: TJvTFSched read GetConnection;\r\n\r\n function ScheduleCount: Integer;\r\n property Schedules[Index: Integer]: string read GetSchedule;\r\n procedure AddSchedule(const SchedName: string);\r\n procedure RemoveSchedule(const SchedName: string);\r\n procedure AssignSchedules(List: TStrings);\r\n procedure ClearSchedules;\r\n function IndexOfSchedule(const SchedName: string): Integer;\r\n function Shared: Boolean;\r\n\r\n procedure Post;\r\n procedure Refresh;\r\n procedure Delete;\r\n\r\n // implicit post fix\r\n procedure BeginUpdate;\r\n procedure EndUpdate;\r\n property Updating: Boolean read FUpdating;\r\n\r\n property ImageMap: TJvTFCustomImageMap read FImageMap write FImageMap;\r\n procedure RefreshControls;\r\n property Refreshed: Boolean read FRefreshed write SetRefreshed;\r\n published\r\n property ID: string read FID;\r\n property StartDate: TDate read GetStartDate;\r\n property EndDate: TDate read GetEndDate;\r\n property StartTime: TTime read GetStartTime;\r\n property EndTime: TTime read GetEndTime;\r\n property StartDateTime: TDateTime read GetStartDateTime;\r\n property EndDateTime: TDateTime read GetEndDateTime;\r\n property Description: string read GetDescription write SetDescription;\r\n property AlarmEnabled: Boolean read FAlarmEnabled write SetAlarmEnabled;\r\n property AlarmAdvance: Integer read FAlarmAdvance write SetAlarmAdvance;\r\n property Data: Integer read FData write FData;\r\n property Persistent: Boolean read FPersistent write FPersistent;\r\n property Color: TColor read FColor write SetColor default clDefault;\r\n property BarColor: TColor read FBarColor write SetBarColor default clDefault;\r\n property Glyph: TPicture read FGlyph write SetGlyph;\r\n end;\r\n\r\n {$M+}\r\n TJvTFSched = class(TObject)\r\n private\r\n FAppts: TStringList;\r\n FConControls: TStringList;\r\n FConComponents: TStringList;\r\n FDestroying: Boolean;\r\n FData: Integer;\r\n FPersistent: Boolean;\r\n FSchedDisplayName: string;\r\n procedure SetSchedDisplayName(const Value: string);\r\n\r\n function GetAppt(Index: Integer): TJvTFAppt;\r\n protected\r\n FSchedName: string;\r\n FSchedDate: TDate;\r\n FScheduleManager: TJvTFScheduleManager;\r\n FCached: Boolean;\r\n FCachedTime: DWORD;\r\n procedure Notify(Sender: TObject; Code: TJvTFServNotifyCode);\r\n procedure NotifyManager(Serv: TJvTFScheduleManager; Sender: TObject;\r\n Code: TJvTFServNotifyCode);\r\n procedure NotifyAppt(Appt: TJvTFAppt; Sender: TObject;\r\n Code: TJvTFServNotifyCode);\r\n function GetConControl(Index: Integer): TJvTFControl;\r\n function GetConComponent(Index: Integer): TJvTFComponent;\r\n procedure ConnectAppt(Appt: TJvTFAppt);\r\n procedure DisconnectAppt(Appt: TJvTFAppt);\r\n procedure ConnectionsOnChange(Sender: TObject);\r\n procedure CheckConnections;\r\n function GetFreeUsedTime(FreeTime: Boolean): TDynTimeRangeArray; dynamic;\r\n public\r\n constructor Create(Serv: TJvTFScheduleManager; const AName: string; ADate: TDate); virtual;\r\n destructor Destroy; override;\r\n\r\n function ApptCount: Integer;\r\n function ApptByID(const ID: string): TJvTFAppt;\r\n property Appts[Index: Integer]: TJvTFAppt read GetAppt;\r\n\r\n function ConControlCount: Integer;\r\n property ConControls[Index: Integer]: TJvTFControl read GetConControl;\r\n\r\n function ConComponentCount: Integer;\r\n property ConComponents[Index: Integer]: TJvTFComponent read GetConComponent;\r\n\r\n procedure AddAppt(Appt: TJvTFAppt);\r\n procedure RemoveAppt(Appt: TJvTFAppt);\r\n\r\n //procedure RefreshAppts;\r\n procedure Refresh;\r\n procedure PostAppts;\r\n\r\n // Conflict and free time methods\r\n function GetFreeTime: TDynTimeRangeArray; dynamic;\r\n function GetUsedTime: TDynTimeRangeArray; dynamic;\r\n function TimeIsFree(TimeRange: TJvTFTimeRange): Boolean; overload; dynamic;\r\n function TimeIsFree(RangeStart, RangeEnd: TTime): Boolean; overload; dynamic;\r\n // The ApptHasConflicts(anAppt: TJvTFAppt) method declared here checks\r\n // ONLY THIS SCHEDULE!!\r\n function ApptHasConflicts(anAppt: TJvTFAppt): Boolean; dynamic;\r\n function EnumConflicts(TimeRange: TJvTFTimeRange): TDynApptArray;\r\n overload; dynamic;\r\n function EnumConflicts(RangeStart, RangeEnd: TTime): TDynApptArray;\r\n overload; dynamic;\r\n // The following EnumConflicts(anAppt: TJvTFAppt) checks\r\n // ONLY THIS SCHEDULE!!\r\n function EnumConflicts(anAppt: TJvTFAppt): TDynApptArray;\r\n overload; dynamic;\r\n\r\n property Cached: Boolean read FCached;\r\n property CachedTime: DWORD read FCachedTime;\r\n property Destroying: Boolean read FDestroying;\r\n\r\n function GetFirstAppt: TJvTFAppt;\r\n function GetLastAppt: TJvTFAppt;\r\n published\r\n property SchedDisplayName: string read FSchedDisplayName\r\n write SetSchedDisplayName;\r\n property SchedName: string read FSchedName;\r\n property SchedDate: TDate read FSchedDate;\r\n property ScheduleManager: TJvTFScheduleManager read FScheduleManager;\r\n property Data: Integer read FData write FData;\r\n property Persistent: Boolean read FPersistent write FPersistent;\r\n end;\r\n {$M-}\r\n\r\n TJvTFScheduleManagerCacheType = (ctNone, ctTimed, ctBuffer);\r\n TJvTFScheduleManagerCache = class(TPersistent)\r\n private\r\n FCacheType: TJvTFScheduleManagerCacheType;\r\n FTimedDelay: Integer;\r\n FBufferCount: Integer;\r\n FTimer: TTimer;\r\n procedure SetCacheType(Value: TJvTFScheduleManagerCacheType);\r\n procedure SetTimedDelay(Value: Integer);\r\n procedure SetBufferCount(Value: Integer);\r\n protected\r\n FScheduleManager: TJvTFScheduleManager;\r\n procedure FlushManager; virtual;\r\n procedure TimerOnTimer(Sender: TObject); virtual;\r\n public\r\n constructor Create(SchedManager: TJvTFScheduleManager);\r\n destructor Destroy; override;\r\n procedure Assign(Source: TPersistent); override;\r\n published\r\n property CacheType: TJvTFScheduleManagerCacheType read FCacheType write SetCacheType\r\n default ctTimed;\r\n property TimedDelay: Integer read FTimedDelay write SetTimedDelay\r\n default 30000;\r\n property BufferCount: Integer read FBufferCount write SetBufferCount\r\n default 7;\r\n end;\r\n\r\n TJvTFSchedLoadMode = (slmOnDemand, slmBatch);\r\n TJvTFLoadBatchEvent = procedure(Sender: TObject; BatchName: string;\r\n BatchStartDate, BatchEndDate: TDate) of object;\r\n\r\n TJvTFGetApptDisplayTextEvent = procedure(Sender: TObject; Source: TComponent;\r\n Appt: TJvTFAppt; var DisplayText: string) of object;\r\n\r\n TJvTFApptDescEvent = procedure(Sender: TObject; Appt: TJvTFAppt;\r\n var Description: string) of object;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvTFScheduleManager = class(TComponent)\r\n private\r\n FAlwaysPost: Boolean;\r\n FAppts: TStringList;\r\n FSchedules: TStringList;\r\n FConControls: TStringList;\r\n FConComponents: TStringList;\r\n FOnNeedAppts: TJvTFSchedEvent;\r\n FOnRefreshAppt: TJvTFApptEvent;\r\n FOnRefreshSched: TJvTFSchedEvent;\r\n FOnRefreshAll: TNotifyEvent;\r\n FOnDeleteAppt: TJvTFApptEvent;\r\n FOnPostAppt: TJvTFApptEvent;\r\n FOnFlush: TJvTFFlushEvent;\r\n FOnCreateAppt: TJvTFApptEvent;\r\n FOnCreateSchedule: TJvTFSchedEvent;\r\n FOnDestroyAppt: TJvTFApptEvent;\r\n FOnDestroySchedule: TJvTFSchedEvent;\r\n FOnGetApptDisplayText: TJvTFGetApptDisplayTextEvent;\r\n FOnGetApptDescription: TJvTFApptDescEvent;\r\n FOnSetApptDescription: TJvTFApptDescEvent;\r\n\r\n FSchedLoadMode: TJvTFSchedLoadMode;\r\n FOnLoadBatch: TJvTFLoadBatchEvent;\r\n FOnBatchesProcessed: TNotifyEvent;\r\n\r\n FRefreshAutoReconcile: Boolean;\r\n\r\n FStateImages: TCustomImageList;\r\n FCustomImages: TCustomImageList;\r\n FStateImageMap: TJvTFStateImageMap;\r\n FCache: TJvTFScheduleManagerCache;\r\n\r\n // implicit post fix\r\n FOnPostApptQuery: TJvTFPostApptQueryEvent;\r\n\r\n function GetAppt(Index: Integer): TJvTFAppt;\r\n function GetSchedule(Index: Integer): TJvTFSched;\r\n function GetConControl(Index: Integer): TJvTFControl;\r\n function GetConComponent(Index: Integer): TJvTFComponent;\r\n procedure SetStateImages(Value: TCustomImageList);\r\n procedure SetCustomImages(Value: TCustomImageList);\r\n procedure SetCache(Value: TJvTFScheduleManagerCache);\r\n\r\n procedure SetTFSchedLoadMode(Value: TJvTFSchedLoadMode);\r\n procedure SetRefreshAutoReconcile(Value: Boolean);\r\n protected\r\n FLoadingAppts: Boolean;\r\n FRefreshing: Boolean;\r\n FImageChangeLink: TChangeLink;\r\n FFlushing: Boolean;\r\n FDestroying: Boolean;\r\n FSchedBatch: TStringList;\r\n FApptBeingDestroyed: TJvTFAppt;\r\n\r\n procedure Notification(AComponent: TComponent; Operation: TOperation); override;\r\n procedure ConnectControl(ApptCtrl: TJvTFControl);\r\n procedure DisconnectControl(ApptCtrl: TJvTFControl);\r\n procedure ConnectComponent(Comp: TJvTFComponent);\r\n procedure DisconnectComponent(Comp: TJvTFComponent);\r\n\r\n procedure Notify(Sender: TObject; Code: TJvTFServNotifyCode); virtual;\r\n procedure NotifyAppt(Appt: TJvTFAppt; Sender: TObject;\r\n Code: TJvTFServNotifyCode);\r\n procedure NotifySchedule(Sched: TJvTFSched; Sender: TObject;\r\n Code: TJvTFServNotifyCode);\r\n procedure NotifyApptCtrl(ApptCtrl: TJvTFControl; Sender: TObject;\r\n Code: TJvTFServNotifyCode);\r\n procedure NotifyComp(Comp: TJvTFComponent; Sender: TObject;\r\n Code: TJvTFServNotifyCode);\r\n\r\n procedure RetrieveSchedule(const SchedName: string; SchedDate: TDate;\r\n var Schedule: TJvTFSched; var LoadedNow: Boolean);\r\n\r\n procedure NeedAppts(Schedule: TJvTFSched); virtual;\r\n procedure AddAppt(Appt: TJvTFAppt);\r\n procedure RemoveAppt(Appt: TJvTFAppt);\r\n procedure RemoveSchedule(Sched: TJvTFSched);\r\n\r\n //procedure RefreshAppt(Appt: TJvTFAppt);\r\n procedure DeleteAppt(Appt: TJvTFAppt);\r\n procedure PostAppt(Appt: TJvTFAppt);\r\n\r\n // implicit post fix\r\n function QueryPostAppt(Appt: TJvTFAppt): Boolean;\r\n\r\n procedure AddToBatch(ASched: TJvTFSched);\r\n procedure LoadBatch(const BatchName: string; BatchStartDate,\r\n BatchEndDate: TDate); virtual;\r\n\r\n procedure RequestRefresh(ApptCtrl: TJvTFControl;\r\n Schedule: TJvTFSched); overload; dynamic;\r\n procedure RequestRefresh(Comp: TJvTFComponent;\r\n Schedule: TJvTFSched); overload; dynamic;\r\n\r\n procedure ImageListChange(Sender: TObject);\r\n procedure FlushAppts;\r\n function FlushObject(FlushObj: TObject): Boolean;\r\n\r\n procedure DoCreateApptEvent(anAppt: TJvTFAppt); dynamic;\r\n procedure DoCreateScheduleEvent(aSchedule: TJvTFSched); dynamic;\r\n procedure DoDestroyApptEvent(anAppt: TJvTFAppt); dynamic;\r\n procedure DoDestroyScheduleEvent(aSchedule: TJvTFSched); dynamic;\r\n\r\n procedure SetApptDescription(Appt: TJvTFAppt; var Value: string); virtual;\r\n procedure GetApptDescription(Appt: TJvTFAppt; var Value: string); virtual;\r\n public\r\n class function GetScheduleID(const SchedName: string; SchedDate: TDate): string;\r\n class function GenerateApptID: string; virtual;\r\n\r\n function GetSchedClass: TJvTFSchedClass; dynamic;\r\n function GetApptClass: TJvTFApptClass; dynamic;\r\n\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n\r\n function ApptCount: Integer;\r\n property Appts[Index: Integer]: TJvTFAppt read GetAppt;\r\n function FindAppt(const ID: string): TJvTFAppt;\r\n\r\n function ScheduleCount: Integer;\r\n property Schedules[Index: Integer]: TJvTFSched read GetSchedule;\r\n function FindSchedule(const SchedName: string; SchedDate: TDate): TJvTFSched;\r\n\r\n function ConControlCount: Integer;\r\n property ConControls[Index: Integer]: TJvTFControl read GetConControl;\r\n function ConComponentCount: Integer;\r\n property ConComponents[Index: Integer]: TJvTFComponent read GetConComponent;\r\n\r\n function RequestSchedule(ApptCtrl: TJvTFControl; const SchedName: string;\r\n SchedDate: TDate): TJvTFSched; overload;\r\n function RequestSchedule(ApptCtrl: TJvTFControl; const SchedName: string;\r\n SchedDate: TDate; var LoadedNow: Boolean): TJvTFSched; overload;\r\n\r\n function RequestSchedule(Comp: TJvTFComponent; const SchedName: string;\r\n SchedDate: TDate): TJvTFSched; overload;\r\n function RequestSchedule(Comp: TJvTFComponent; const SchedName: string;\r\n SchedDate: TDate; var LoadedNow: Boolean): TJvTFSched; overload;\r\n\r\n procedure ReleaseSchedule(ApptCtrl: TJvTFControl; const SchedName: string;\r\n SchedDate: TDate); overload;\r\n procedure ReleaseSchedule(Comp: TJvTFComponent; const SchedName: string;\r\n SchedDate: TDate); overload;\r\n\r\n procedure ProcessBatches;\r\n\r\n procedure RequestAppt(const ID: string; var Appt: TJvTFAppt; var New: Boolean);\r\n\r\n property LoadingAppts: Boolean read FLoadingAppts;\r\n property Refreshing: Boolean read FRefreshing;\r\n\r\n procedure dbPostAppt(Appt: TJvTFAppt);\r\n procedure dbDeleteAppt(Appt: TJvTFAppt);\r\n procedure dbDeleteAllAppt;\r\n procedure dbRefreshAppt(Appt: TJvTFAppt);\r\n procedure dbRefreshSched(Sched: TJvTFSched);\r\n procedure dbRefreshAll;\r\n procedure dbRefreshOrphans;\r\n function dbNewAppt(const ID: string): TJvTFAppt;\r\n\r\n procedure PostAppts;\r\n procedure RefreshAppts;\r\n procedure ReconcileRefresh(Scope: TObject);\r\n\r\n procedure RefreshConnections(Trigger: TObject); virtual;\r\n property Flushing: Boolean read FFlushing;\r\n procedure Flush(All: Boolean = False); virtual;\r\n\r\n function GetApptDisplayText(AComponent: TComponent;\r\n Appt: TJvTFAppt): string; virtual;\r\n published\r\n property AlwaysPost: Boolean read FAlwaysPost write FAlwaysPost default False;\r\n property OnNeedAppts: TJvTFSchedEvent read FOnNeedAppts write FOnNeedAppts;\r\n property OnRefreshAppt: TJvTFApptEvent read FOnRefreshAppt write FOnRefreshAppt;\r\n property OnRefreshSched: TJvTFSchedEvent read FOnRefreshSched\r\n write FOnRefreshSched;\r\n property OnRefreshAll: TNotifyEvent read FOnRefreshAll write FOnRefreshAll;\r\n property OnPostAppt: TJvTFApptEvent read FOnPostAppt write FOnPostAppt;\r\n property OnDeleteAppt: TJvTFApptEvent read FOnDeleteAppt write FOnDeleteAppt;\r\n property StateImages: TCustomImageList read FStateImages write SetStateImages;\r\n property CustomImages: TCustomImageList read FCustomImages write SetCustomImages;\r\n property StateImageMap: TJvTFStateImageMap read FStateImageMap write FStateImageMap;\r\n property Cache: TJvTFScheduleManagerCache read FCache write SetCache;\r\n // implicit post fix\r\n property OnPostApptQuery: TJvTFPostApptQueryEvent read FOnPostApptQuery\r\n write FOnPostApptQuery;\r\n property OnFlush: TJvTFFlushEvent read FOnFlush write FOnFlush;\r\n property OnCreateAppt: TJvTFApptEvent read FOnCreateAppt write FOnCreateAppt;\r\n property OnDestroyAppt: TJvTFApptEvent read FOnDestroyAppt write FOnDestroyAppt;\r\n property OnCreateSchedule: TJvTFSchedEvent read FOnCreateSchedule\r\n write FOnCreateSchedule;\r\n property OnDestroySchedule: TJvTFSchedEvent read FOnDestroySchedule\r\n write FOnDestroySchedule;\r\n property OnLoadBatch: TJvTFLoadBatchEvent read FOnLoadBatch write FOnLoadBatch;\r\n property OnBatchesProcessed: TNotifyEvent read FOnBatchesProcessed\r\n write FOnBatchesProcessed;\r\n property OnGetApptDisplayText: TJvTFGetApptDisplayTextEvent\r\n read FOnGetApptDisplayText write FOnGetApptDisplayText;\r\n property OnGetApptDescription: TJvTFApptDescEvent read FOnGetApptDescription\r\n write FOnGetApptDescription;\r\n property OnSetApptDescription: TJvTFApptDescEvent read FOnSetApptDescription\r\n write FOnSetApptDescription;\r\n\r\n property SchedLoadMode: TJvTFSchedLoadMode read FSchedLoadMode\r\n write SetTFSchedLoadMode default slmOnDemand;\r\n property RefreshAutoReconcile: Boolean read FRefreshAutoReconcile\r\n write SetRefreshAutoReconcile default False;\r\n end;\r\n\r\n TJvTFHintProps = class(TPersistent)\r\n private\r\n FHintColor: TColor;\r\n FHintHidePause: Integer;\r\n FHintPause: Integer;\r\n procedure SetHintColor(Value: TColor);\r\n procedure SetHintHidePause(Value: Integer);\r\n procedure SetHintPause(Value: Integer);\r\n protected\r\n FControl: TJvTFControl;\r\n procedure Change; virtual;\r\n public\r\n constructor Create(AOwner: TJvTFControl);\r\n procedure Assign(Source: TPersistent); override;\r\n published\r\n property HintColor: TColor read FHintColor write SetHintColor default clDefault;\r\n property HintHidePause: Integer read FHintHidePause write SetHintHidePause default -1;\r\n property HintPause: Integer read FHintPause write SetHintPause default -1;\r\n end;\r\n\r\n TJvTFHintType = (shtAppt, shtStartEnd, shtCell, shtObj);\r\n\r\n TJvTFShowHintEvent = procedure(Sender: TObject; HintType: TJvTFHintType;\r\n Ref: TObject; var HintRect: TRect; var HintText: string) of object;\r\n\r\n // NOTE:\r\n // The Pause property has the same meaning as the Application.HintPause\r\n // property. The ShortPause property has the same meaning as the\r\n // Application.HintHidePause property.\r\n TJvTFHint = class(THintWindow)\r\n private\r\n FTimer: TTimer;\r\n FPause: Integer;\r\n FShortPause: Integer;\r\n FOnShowHint: TJvTFShowHintEvent;\r\n FRefProps: TJvTFHintProps;\r\n procedure SetPause(Value: Integer);\r\n procedure SetShortPause(Value: Integer);\r\n protected\r\n FApptCtrl: TJvTFControl;\r\n FOldAppt: TJvTFAppt;\r\n FOldObj: TObject;\r\n FShortTimer: Boolean;\r\n FHintRect: TRect;\r\n FHintText: string;\r\n FHintCell: TPoint;\r\n FHintType: TJvTFHintType;\r\n procedure TimerOnTimer(Sender: TObject); virtual;\r\n procedure PrepTimer(Short: Boolean);\r\n procedure SetHintText(StartDate, EndDate: TDate; StartTime, EndTime: TTime;\r\n const Desc: string; ShowDatesTimes, ShowDesc: Boolean);\r\n procedure DoHint(Sustained: Boolean);\r\n procedure CreateParams(var Params: TCreateParams); override;\r\n procedure PropertyCheck; dynamic;\r\n public\r\n constructor Create(anApptCtrl: TJvTFControl); reintroduce;\r\n destructor Destroy; override;\r\n procedure ActivateHint(Rect: TRect; const AHint: THintString); override;\r\n procedure ApptHint(Appt: TJvTFAppt; X, Y: Integer;\r\n ShowDatesTimes, ShowDesc, FormattedDesc: Boolean; const ExtraDesc: string = ''); virtual;\r\n procedure StartEndHint(StartDate, EndDate: TDate; StartTime, EndTime: TTime;\r\n X, Y: Integer; ShowDates: Boolean);\r\n procedure CellHint(Row, Col: Integer; const HintText: string; CellRect: TRect);\r\n\r\n procedure MultiLineObjHint(Obj: TObject; X, Y: Integer; Hints: TStrings);\r\n\r\n procedure ReleaseHandle; virtual;\r\n // See above note on Pause and ShortPause properties\r\n property Pause: Integer read FPause write SetPause default 3000;\r\n property ShortPause: Integer read FShortPause write SetShortPause default 1500;\r\n property OnShowHint: TJvTFShowHintEvent read FOnShowHint write FOnShowHint;\r\n property HintType: TJvTFHintType read FHintType;\r\n property RefProps: TJvTFHintProps read FRefProps write FRefProps;\r\n end;\r\n\r\n TJvTFDragInfo = class(TObject)\r\n private\r\n FApptCtrl: TJvTFControl;\r\n FSchedule: TJvTFSched;\r\n FAppt: TJvTFAppt;\r\n FShift: TShiftState;\r\n public\r\n property ApptCtrl: TJvTFControl read FApptCtrl write FApptCtrl;\r\n property Schedule: TJvTFSched read FSchedule write FSchedule;\r\n property Appt: TJvTFAppt read FAppt write FAppt;\r\n property Shift: TShiftState read FShift write FShift;\r\n end;\r\n\r\n TJvTFComponent = class(TJvComponent)\r\n private\r\n FScheduleManager: TJvTFScheduleManager;\r\n FSchedules: TStringList;\r\n procedure SetManager(Value: TJvTFScheduleManager);\r\n function GetSchedule(Index: Integer): TJvTFSched;\r\n protected\r\n FDateFormat: string;\r\n FTimeFormat: string;\r\n\r\n procedure UpdateDesigner;\r\n\r\n procedure SetDateFormat(const Value: string); virtual;\r\n procedure SetTimeFormat(const Value: string); virtual;\r\n procedure Notify(Sender: TObject; Code: TJvTFServNotifyCode); virtual;\r\n procedure ReqSchedNotification(Schedule: TJvTFSched); virtual;\r\n procedure RelSchedNotification(Schedule: TJvTFSched); virtual;\r\n procedure NotifyManager(Serv: TJvTFScheduleManager; Sender: TObject;\r\n Code: TJvTFServNotifyCode);\r\n procedure RefreshComponent; dynamic;\r\n property DateFormat: string read FDateFormat write SetDateFormat;\r\n property TimeFormat: string read FTimeFormat write SetTimeFormat;\r\n procedure DestroyApptNotification(anAppt: TJvTFAppt); virtual;\r\n procedure DestroySchedNotification(ASched: TJvTFSched); virtual;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n\r\n function ScheduleCount: Integer;\r\n property Schedules[Index: Integer]: TJvTFSched read GetSchedule;\r\n function FindSchedule(const SchedName: string; SchedDate: TDate): TJvTFSched;\r\n function RetrieveSchedule(const SchedName: string; SchedDate: TDate): TJvTFSched;\r\n procedure ReleaseSchedule(const SchedName: string; SchedDate: TDate); virtual;\r\n procedure ReleaseSchedules;\r\n procedure ProcessBatches;\r\n published\r\n property ScheduleManager: TJvTFScheduleManager read FScheduleManager write SetManager;\r\n end;\r\n\r\n TJvTFControl = class(TJvCustomControl)\r\n private\r\n FScheduleManager: TJvTFScheduleManager;\r\n FSchedules: TStringList;\r\n // FNavigator: TJvTFNavigator;\r\n // FOnNavigate: TJvTFNavEvent;\r\n procedure SetManager(Value: TJvTFScheduleManager);\r\n function GetSchedule(Index: Integer): TJvTFSched;\r\n // procedure SetNavigator(Value: TJvTFNavigator);\r\n protected\r\n FDateFormat: string;\r\n FTimeFormat: string;\r\n FDragInfo: TJvTFDragInfo;\r\n FShift: TShiftState;\r\n procedure Notification(AComponent: TComponent; Operation: TOperation); override;\r\n procedure SetDateFormat(const Value: string); virtual;\r\n procedure SetTimeFormat(const Value: string); virtual;\r\n procedure Notify(Sender: TObject; Code: TJvTFServNotifyCode); virtual;\r\n procedure ReqSchedNotification(Schedule: TJvTFSched); virtual;\r\n procedure RelSchedNotification(Schedule: TJvTFSched); virtual;\r\n procedure NotifyManager(Serv: TJvTFScheduleManager; Sender: TObject;\r\n Code: TJvTFServNotifyCode);\r\n procedure CNRequestRefresh(var Msg: TCNRequestRefresh); message CN_REQUESTREFRESH;\r\n procedure RefreshControl; dynamic;\r\n property DateFormat: string read FDateFormat write SetDateFormat;\r\n property TimeFormat: string read FTimeFormat write SetTimeFormat;\r\n procedure DestroyApptNotification(anAppt: TJvTFAppt); virtual;\r\n procedure DestroySchedNotification(ASched: TJvTFSched); virtual;\r\n procedure DoStartDrag(var DragObject: TDragObject); override;\r\n procedure DoEndDrag(Target: TObject; X, Y: Integer); override;\r\n procedure MouseDown(Button: TMouseButton; Shift: TShiftState;\r\n X, Y: Integer); override;\r\n procedure Navigate(aControl: TJvTFControl; SchedNames: TStringList;\r\n Dates: TJvTFDateList); virtual;\r\n // property Navigator: TJvTFNavigator read FNavigator write SetNavigator;\r\n // property OnNavigate: TJvTFNavEvent read FOnNavigate write FOnNavigate;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n\r\n function ScheduleCount: Integer;\r\n property Schedules[Index: Integer]: TJvTFSched read GetSchedule;\r\n function FindSchedule(const SchedName: string; SchedDate: TDate): TJvTFSched;\r\n function RetrieveSchedule(const SchedName: string; SchedDate: TDate): TJvTFSched;\r\n procedure ReleaseSchedule(const SchedName: string; SchedDate: TDate); virtual;\r\n procedure ReleaseSchedules;\r\n property DragInfo: TJvTFDragInfo read FDragInfo;\r\n procedure ProcessBatches;\r\n published\r\n property ScheduleManager: TJvTFScheduleManager read FScheduleManager write SetManager;\r\n end;\r\n\r\n EJvTFPrinterError = class(Exception);\r\n TJvTFMargins = TRect;\r\n TJvTFPrinterMeasure = (pmPixels, pmInches, pmMM);\r\n TJvTFPrinterState = (spsNoDoc, spsCreating, spsAssembling, spsFinished);\r\n TJvTFPrinterDrawEvent = procedure(Sender: TObject; aCanvas: TCanvas;\r\n ARect: TRect; PageNum: Integer) of object;\r\n\r\n TJvTFProgressEvent = procedure(Sender: TObject; Current, Total: Integer)\r\n of object;\r\n\r\n TJvTFPrinterPageLayout = class(TPersistent)\r\n private\r\n FFooterHeight: Integer;\r\n FHeaderHeight: Integer;\r\n FMargins: TJvTFMargins;\r\n FPrinter: TJvTFPrinter;\r\n procedure SetFooterHeight(Value: Integer);\r\n procedure SetHeaderHeight(Value: Integer);\r\n function GetMargin(Index: Integer): Integer;\r\n procedure SetMargin(Index: Integer; Value: Integer);\r\n protected\r\n procedure Change; virtual;\r\n property Printer: TJvTFPrinter read FPrinter;\r\n procedure SetPropertyCheck;\r\n public\r\n constructor Create(aPrinter: TJvTFPrinter); virtual;\r\n procedure Assign(Source: TPersistent); override;\r\n published\r\n property FooterHeight: Integer read FFooterHeight write SetFooterHeight;\r\n property HeaderHeight: Integer read FHeaderHeight write SetHeaderHeight;\r\n property MarginLeft: Integer index 1 read GetMargin write SetMargin;\r\n property MarginTop: Integer index 2 read GetMargin write SetMargin;\r\n property MarginRight: Integer index 3 read GetMargin write SetMargin;\r\n property MarginBottom: Integer index 4 read GetMargin write SetMargin;\r\n end;\r\n\r\n TJvTFPrinter = class(TJvTFComponent)\r\n private\r\n FPages: TStringList;\r\n FBodies: TStringList;\r\n FMarginOffsets: TJvTFMargins; // always in pixels\r\n FMeasure: TJvTFPrinterMeasure;\r\n FOnDrawBody: TJvTFPrinterDrawEvent;\r\n FOnDrawHeader: TJvTFPrinterDrawEvent;\r\n FOnDrawFooter: TJvTFPrinterDrawEvent;\r\n FOnPrintProgress: TJvTFProgressEvent;\r\n FOnAssembleProgress: TJvTFProgressEvent;\r\n FOnMarginError: TNotifyEvent;\r\n FTitle: string;\r\n FDirectPrint: Boolean;\r\n function GetPage(Index: Integer): TMetafile;\r\n function GetBodyHeight: Integer; // always in pixels\r\n function GetBodyWidth: Integer; // always in pixels\r\n function GetBodyLeft: Integer; // always in pixels\r\n function GetBodyTop: Integer; // always in pixels\r\n function GetDocDateTime: TDateTime;\r\n procedure SetPageLayout(Value: TJvTFPrinterPageLayout);\r\n procedure SetDirectPrint(Value: Boolean);\r\n protected\r\n FPageLayout: TJvTFPrinterPageLayout;\r\n FState: TJvTFPrinterState;\r\n FDocDateTime: TDateTime;\r\n FPageCount: Integer; // NOTE: SEE GetPageCount !!\r\n FConvertingProps: Boolean;\r\n FAborted: Boolean;\r\n procedure SetMarginOffset(Index: Integer; Value: Integer); // always in pixels\r\n function GetMarginOffset(Index: Integer): Integer; // always in pixels\r\n function GetUnprintable: TJvTFMargins; // always in pixels\r\n procedure MarginError; dynamic;\r\n procedure InitializeMargins;\r\n property BodyHeight: Integer read GetBodyHeight; // always in pixels\r\n property BodyWidth: Integer read GetBodyWidth; // always in pixels\r\n property BodyLeft: Integer read GetBodyLeft; // always in pixels\r\n property BodyTop: Integer read GetBodyTop; // always in pixels\r\n procedure DrawBody(aCanvas: TCanvas; ARect: TRect; PageNum: Integer); virtual;\r\n procedure DrawHeader(aCanvas: TCanvas; ARect: TRect; PageNum: Integer); virtual;\r\n procedure DrawFooter(aCanvas: TCanvas; ARect: TRect; PageNum: Integer); virtual;\r\n procedure SetTitle(const Value: string); virtual;\r\n function GetPageCount: Integer;\r\n procedure SetMeasure(Value: TJvTFPrinterMeasure); virtual;\r\n procedure CreateLayout; virtual;\r\n procedure SetPropertyCheck; dynamic;\r\n\r\n procedure GetHeaderFooterRects(var HeaderRect, FooterRect: TRect);\r\n\r\n // document management methods\r\n procedure CreateDoc; dynamic;\r\n procedure NewPage; dynamic;\r\n procedure FinishDoc; dynamic;\r\n procedure NewDoc; dynamic;\r\n property DirectPrint: Boolean read FDirectPrint write SetDirectPrint\r\n default False;\r\n public\r\n\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n\r\n property PageCount: Integer read GetPageCount;\r\n property Pages[Index: Integer]: TMetafile read GetPage;\r\n function ConvertMeasure(Value: Integer; FromMeasure,\r\n ToMeasure: TJvTFPrinterMeasure; Horizontal: Boolean): Integer;\r\n function ScreenToPrinter(Value: Integer; Horizontal: Boolean): Integer;\r\n function PrinterToScreen(Value: Integer; Horizontal: Boolean): Integer;\r\n\r\n property State: TJvTFPrinterState read FState;\r\n procedure FreeDoc; dynamic;\r\n procedure Print; dynamic;\r\n procedure AbortPrint;\r\n property DocDateTime: TDateTime read GetDocDateTime;\r\n property ConvertingProps: Boolean read FConvertingProps;\r\n procedure SaveDocToFiles(BaseFileName: TFileName);\r\n property Aborted: Boolean read FAborted;\r\n published\r\n property PageLayout: TJvTFPrinterPageLayout read FPageLayout\r\n write SetPageLayout;\r\n property Measure: TJvTFPrinterMeasure read FMeasure write SetMeasure\r\n default pmInches;\r\n property OnDrawBody: TJvTFPrinterDrawEvent read FOnDrawBody\r\n write FOnDrawBody;\r\n property OnDrawHeader: TJvTFPrinterDrawEvent read FOnDrawHeader\r\n write FOnDrawHeader;\r\n property OnDrawFooter: TJvTFPrinterDrawEvent read FOnDrawFooter\r\n write FOnDrawFooter;\r\n property OnPrintProgress: TJvTFProgressEvent read FOnPrintProgress\r\n write FOnPrintProgress;\r\n property OnAssembleProgress: TJvTFProgressEvent read FOnAssembleProgress\r\n write FOnAssembleProgress;\r\n property OnMarginError: TNotifyEvent read FOnMarginError\r\n write FOnMarginError;\r\n property Title: string read FTitle write SetTitle;\r\n end;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvTFUniversalPrinter = class(TJvTFPrinter)\r\n public\r\n procedure NewDoc; override;\r\n procedure CreateDoc; override;\r\n procedure NewPage; override;\r\n procedure FinishDoc; override;\r\n published\r\n property DirectPrint;\r\n end;\r\n\r\n TJvTFDWNameSource = (dwnsSysLong, dwnsSysShort, dwnsCustom);\r\n\r\n TJvTFDrawDWTitleEvent = procedure(Sender: TObject; aCanvas: TCanvas;\r\n ARect: TRect; DOW: TTFDayOfWeek; DWName: string) of object;\r\n\r\n TJvTFDWNames = class(TPersistent)\r\n private\r\n FSource: TJvTFDWNameSource;\r\n FDWN_Sunday: string;\r\n FDWN_Monday: string;\r\n FDWN_Tuesday: string;\r\n FDWN_Wednesday: string;\r\n FDWN_Thursday: string;\r\n FDWN_Friday: string;\r\n FDWN_Saturday: string;\r\n FOnChange: TNotifyEvent;\r\n procedure SetDWN(Index: Integer; const Value: string);\r\n function GetDWN(Index: Integer): string;\r\n procedure SetSource(Value: TJvTFDWNameSource);\r\n protected\r\n procedure Change; virtual;\r\n public\r\n constructor Create;\r\n procedure Assign(Source: TPersistent); override;\r\n function GetDWName(DWIndex: Integer): string;\r\n published\r\n property Source: TJvTFDWNameSource read FSource write SetSource default dwnsSysShort;\r\n property DWN_Sunday: string index 1 read GetDWN write SetDWN;\r\n property DWN_Monday: string index 2 read GetDWN write SetDWN;\r\n property DWN_Tuesday: string index 3 read GetDWN write SetDWN;\r\n property DWN_Wednesday: string index 4 read GetDWN write SetDWN;\r\n property DWN_Thursday: string index 5 read GetDWN write SetDWN;\r\n property DWN_Friday: string index 6 read GetDWN write SetDWN;\r\n property DWN_Saturday: string index 7 read GetDWN write SetDWN;\r\n property OnChange: TNotifyEvent read FOnChange write FOnChange;\r\n end;\r\n\r\n // TJvTFNavigator = class(TComponent)\r\n // private\r\n // FBeforeNavigate: TJvTFNavEvent;\r\n // FAfterNavigate: TJvTFNavEvent;\r\n // FControls: TStringList;\r\n // function GetControl(Index: Integer): TJvTFControl;\r\n // protected\r\n // FNavigating: Boolean;\r\n // procedure RegisterControl(aControl: TJvTFControl);\r\n // procedure UnregisterControl(aControl: TJvTFControl);\r\n // public\r\n // constructor Create(AOwner: TComponent); override;\r\n // destructor Destroy; override;\r\n //\r\n // function ControlCount: Integer;\r\n // property Controls[Index: Integer]: TJvTFControl read GetControl;\r\n //\r\n // procedure Navigate(aControl: TJvTFControl; SchedNames: TStringList;\r\n // Dates: TJvTFDateList); virtual;\r\n // property Navigating: Boolean read FNavigating;\r\n // published\r\n // property BeforeNavigate: TJvTFNavEvent read FBeforeNavigate\r\n // write FBeforeNavigate;\r\n // property AfterNavigate: TJvTFNavEvent read FAfterNavigate\r\n // write FAfterNavigate;\r\n // end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvTFManager.pas $';\r\n Revision: '$Revision: 13138 $';\r\n Date: '$Date: 2011-10-27 01:17:50 +0200 (jeu. 27 oct. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n JvResources,\r\n Dialogs, Forms, JvJVCLUtils, JclSysUtils;\r\n\r\nfunction AdjustEndTime(ATime: TTime): TTime;\r\nbegin\r\n Result := Frac(Frac(ATime) - Frac(EncodeTime(0, 0, 1, 0)));\r\nend;\r\n\r\nfunction CenterRect(Rect1, Rect2: TRect): TRect;\r\nvar\r\n Rect1Width, Rect1Height, Rect2Width, Rect2Height: Integer;\r\nbegin\r\n Rect1Width := Rect1.Right - Rect1.Left - 1;\r\n Rect1Height := Rect1.Bottom - Rect1.Top - 1;\r\n Rect2Width := Rect2.Right - Rect2.Left - 1;\r\n Rect2Height := Rect2.Bottom - Rect2.Top - 1;\r\n\r\n Result.Left := Rect1.Left + ((Rect1Width - Rect2Width) div 2) - 1;\r\n Result.Top := Rect1.Top + ((Rect1Height - Rect2Height) div 2) - 1;\r\n Result.Right := Result.Left + Rect2Width;\r\n Result.Bottom := Result.Top + Rect2Height;\r\nend;\r\n\r\nfunction MoveRect(ARect: TRect; NewLeft, NewTop: Integer): TRect;\r\nbegin\r\n Result := ARect;\r\n OffsetRect(Result, NewLeft - ARect.Left, NewTop - ARect.Top);\r\nend;\r\n\r\nfunction StripCRLF(const S: string): string;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := '';\r\n for I := 1 to Length(S) do\r\n if (S[I] <> #13) and (S[I] <> #10) then\r\n Result := Result + S[I];\r\nend;\r\n\r\n//=== { TJvTFCustomImageMap } ================================================\r\n\r\nconstructor TJvTFCustomImageMap.Create(anAppt: TJvTFAppt);\r\nbegin\r\n if not Assigned(anAppt) then\r\n raise EJvTFScheduleManagerError.CreateRes(@RsECouldNotCreateCustomImageMap);\r\n\r\n inherited Create;\r\n FAppt := anAppt;\r\n FMap := TStringList.Create;\r\nend;\r\n\r\ndestructor TJvTFCustomImageMap.Destroy;\r\nbegin\r\n FMap.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJvTFCustomImageMap.GetImage(MapIndex: Integer): Integer;\r\nbegin\r\n Result := Integer(FMap.Objects[MapIndex]);\r\nend;\r\n\r\nprocedure TJvTFCustomImageMap.SetImage(MapIndex, Value: Integer);\r\nbegin\r\n FMap.Objects[MapIndex] := TObject(Value);\r\nend;\r\n\r\nfunction TJvTFCustomImageMap.GetImageName(MapIndex: Integer): string;\r\nbegin\r\n Result := FMap[MapIndex];\r\nend;\r\n\r\nprocedure TJvTFCustomImageMap.Change;\r\nbegin\r\n if Assigned(FAppt.ScheduleManager) then\r\n begin\r\n FAppt.ScheduleManager.RefreshConnections(FAppt);\r\n // implicit post fix\r\n FAppt.Change;\r\n end;\r\nend;\r\n\r\nfunction TJvTFCustomImageMap.Count: Integer;\r\nbegin\r\n Result := FMap.Count;\r\nend;\r\n\r\nprocedure TJvTFCustomImageMap.Add(const ImageName: string; ImageIndex: Integer);\r\nbegin\r\n if FMap.IndexOf(ImageName) = -1 then\r\n begin\r\n FMap.AddObject(ImageName, TObject(ImageIndex));\r\n Change;\r\n end;\r\nend;\r\n\r\nprocedure TJvTFCustomImageMap.Delete(MapIndex: Integer);\r\nbegin\r\n FMap.Delete(MapIndex);\r\n Change;\r\nend;\r\n\r\nprocedure TJvTFCustomImageMap.Move(SrcMapIndex, DestMapIndex: Integer);\r\nbegin\r\n FMap.Move(SrcMapIndex, DestMapIndex);\r\nend;\r\n\r\nfunction TJvTFCustomImageMap.FindMapIndex(const ImageName: string): Integer;\r\nbegin\r\n Result := FMap.IndexOf(ImageName);\r\nend;\r\n\r\nfunction TJvTFCustomImageMap.FindImageIndex(const ImageName: string): Integer;\r\nbegin\r\n Result := FindMapIndex(ImageName);\r\n if Result > -1 then\r\n Result := GetImage(Result);\r\nend;\r\n\r\nprocedure TJvTFCustomImageMap.Clear;\r\nbegin\r\n while FMap.Count > 0 do\r\n FMap.Delete(0);\r\n Change;\r\nend;\r\n\r\nprocedure TJvTFCustomImageMap.Assign(Source: TPersistent);\r\nvar\r\n I: Integer;\r\nbegin\r\n if Source is TJvTFCustomImageMap then\r\n begin\r\n while FMap.Count > 0 do\r\n FMap.Delete(0);\r\n\r\n for I := 0 to TJvTFCustomImageMap(Source).Count - 1 do\r\n Add(TJvTFCustomImageMap(Source).ImageNames[I],\r\n TJvTFCustomImageMap(Source).Images[I]);\r\n Change;\r\n end\r\n else\r\n inherited Assign(Source);\r\nend;\r\n\r\n//=== { TJvTFStateImageMap } =================================================\r\n\r\nconstructor TJvTFStateImageMap.Create(Serv: TJvTFScheduleManager);\r\nvar\r\n I: TJvTFStatePic;\r\nbegin\r\n inherited Create;\r\n\r\n for I := Low(TJvTFStatePic) to High(TJvTFStatePic) do\r\n FPics[I] := -1;\r\n\r\n FUpdating := False;\r\nend;\r\n\r\nprocedure TJvTFStateImageMap.SetImage(StatePicID: TJvTFStatePic; Value: Integer);\r\nbegin\r\n if Value < -1 then\r\n Value := -1;\r\n if FPics[StatePicID] <> Value then\r\n begin\r\n FPics[StatePicID] := Value;\r\n Change;\r\n end;\r\nend;\r\n\r\nfunction TJvTFStateImageMap.GetImage(StatePicID: TJvTFStatePic): Integer;\r\nbegin\r\n Result := FPics[StatePicID];\r\nend;\r\n\r\nfunction TJvTFStateImageMap.GetAlarmDisabled: Integer;\r\nbegin\r\n Result := GetImage(spAlarmDisabled);\r\nend;\r\n\r\nfunction TJvTFStateImageMap.GetAlarmEnabled: Integer;\r\nbegin\r\n Result := GetImage(spAlarmEnabled);\r\nend;\r\n\r\nfunction TJvTFStateImageMap.GetModified: Integer;\r\nbegin\r\n Result := GetImage(spModified);\r\nend;\r\n\r\nfunction TJvTFStateImageMap.GetRecurring: Integer;\r\nbegin\r\n Result := GetImage(spRecurring);\r\nend;\r\n\r\nfunction TJvTFStateImageMap.GetShared: Integer;\r\nbegin\r\n Result := GetImage(spShared);\r\nend;\r\n\r\nprocedure TJvTFStateImageMap.SetAlarmDisabled(const Value: Integer);\r\nbegin\r\n SetImage(spAlarmDisabled, Value);\r\nend;\r\n\r\nprocedure TJvTFStateImageMap.SetAlarmEnabled(const Value: Integer);\r\nbegin\r\n SetImage(spAlarmEnabled, Value);\r\nend;\r\n\r\nprocedure TJvTFStateImageMap.SetModified(const Value: Integer);\r\nbegin\r\n SetImage(spModified, Value);\r\nend;\r\n\r\nprocedure TJvTFStateImageMap.SetRecurring(const Value: Integer);\r\nbegin\r\n SetImage(spRecurring, Value);\r\nend;\r\n\r\nprocedure TJvTFStateImageMap.SetShared(const Value: Integer);\r\nbegin\r\n SetImage(spShared, Value);\r\nend;\r\n\r\nprocedure TJvTFStateImageMap.Change;\r\nbegin\r\n if Assigned(FScheduleManager) and not (csLoading in FScheduleManager.ComponentState) and\r\n not (csDesigning in FScheduleManager.ComponentState) and not FUpdating then\r\n FScheduleManager.RefreshConnections(nil);\r\nend;\r\n\r\nprocedure TJvTFStateImageMap.BeginUpdate;\r\nbegin\r\n FUpdating := True;\r\nend;\r\n\r\nprocedure TJvTFStateImageMap.EndUpdate;\r\nbegin\r\n if FUpdating then\r\n begin\r\n FUpdating := False;\r\n Change;\r\n end;\r\nend;\r\n\r\nprocedure TJvTFStateImageMap.Clear;\r\nvar\r\n I: TJvTFStatePic;\r\nbegin\r\n for I := Low(TJvTFStatePic) to High(TJvTFStatePic) do\r\n FPics[I] := -1;\r\n Change;\r\nend;\r\n\r\nprocedure TJvTFStateImageMap.Assign(Source: TPersistent);\r\nvar\r\n Pic: TJvTFStatePic;\r\nbegin\r\n if Source is TJvTFStateImageMap then\r\n begin\r\n for Pic := Low(TJvTFStatePic) to High(TJvTFStatePic) do\r\n FPics[Pic] := TJvTFStateImageMap(Source).Pics[Pic];\r\n Change;\r\n end\r\n else\r\n inherited Assign(Source);\r\nend;\r\n\r\n//=== { TJvTFAppt } ==========================================================\r\n\r\nconstructor TJvTFAppt.Create(Serv: TJvTFScheduleManager; const ApptID: string);\r\nbegin\r\n if not Assigned(Serv) then\r\n raise EJvTFScheduleManagerError.CreateRes(@RsECouldNotCreateAppointmentObject);\r\n\r\n inherited Create;\r\n\r\n FGlyph := TPicture.Create;\r\n\r\n FSchedules := TStringList.Create;\r\n FConnections := TStringList.Create;\r\n\r\n FStartDate := Date;\r\n FStartTime := Time;\r\n FEndDate := Date;\r\n FEndTime := FStartTime + EncodeTime(0, 1, 0, 0);\r\n FScheduleManager := Serv;\r\n FDestroying := False;\r\n\r\n if ApptID <> '' then\r\n FID := ApptID\r\n else\r\n FID := FScheduleManager.GenerateApptID;\r\n\r\n FModified := False;\r\n FColor := clDefault;\r\n FBarColor := clDefault;\r\n\r\n FImageMap := TJvTFCustomImageMap.Create(Self);\r\n\r\n ScheduleManager.Notify(Self, sncLoadAppt);\r\n\r\n Serv.DoCreateApptEvent(Self);\r\nend;\r\n\r\ndestructor TJvTFAppt.Destroy;\r\nbegin\r\n FDestroying := True;\r\n if Assigned(ScheduleManager) then\r\n ScheduleManager.DoDestroyApptEvent(Self);\r\n\r\n ScheduleManager.Notify(Self, sncDestroyAppt);\r\n\r\n FSchedules.Free;\r\n FConnections.Free;\r\n FImageMap.Free;\r\n\r\n FGlyph.Free;\r\n\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJvTFAppt.GetDescription: string;\r\nbegin\r\n Result := FDescription;\r\n ScheduleManager.GetApptDescription(Self, Result);\r\nend;\r\n\r\nprocedure TJvTFAppt.SetDescription(Value: string);\r\nbegin\r\n ScheduleManager.SetApptDescription(Self, Value);\r\n if Value <> FDescription then\r\n begin\r\n FDescription := Value;\r\n if not ScheduleManager.LoadingAppts and not ScheduleManager.Refreshing then\r\n begin\r\n FModified := True;\r\n Change;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvTFAppt.SetAlarmEnabled(Value: Boolean);\r\nbegin\r\n if Value <> FAlarmEnabled then\r\n begin\r\n FAlarmEnabled := Value;\r\n if not ScheduleManager.LoadingAppts and not ScheduleManager.Refreshing then\r\n begin\r\n FModified := True;\r\n Change;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvTFAppt.SetAlarmAdvance(Value: Integer);\r\nbegin\r\n if Value < 0 then\r\n Value := 0;\r\n\r\n if Value <> FAlarmAdvance then\r\n begin\r\n FAlarmAdvance := Value;\r\n if not ScheduleManager.LoadingAppts and not ScheduleManager.Refreshing then\r\n begin\r\n FModified := True;\r\n Change;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvTFAppt.SetColor(Value: TColor);\r\nbegin\r\n if Value <> FColor then\r\n begin\r\n FColor := Value;\r\n if not ScheduleManager.LoadingAppts and not ScheduleManager.Refreshing then\r\n begin\r\n FModified := True;\r\n Change;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvTFAppt.SetBarColor(Value: TColor);\r\nbegin\r\n if Value <> FBarColor then\r\n begin\r\n FBarColor := Value;\r\n if not ScheduleManager.LoadingAppts and not ScheduleManager.Refreshing then\r\n begin\r\n FModified := True;\r\n Change;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvTFAppt.Notify(Sender: TObject; Code: TJvTFServNotifyCode);\r\nbegin\r\n case Code of\r\n sncConnectAppt:\r\n Connect(TJvTFSched(Sender));\r\n sncDisconnectAppt:\r\n Disconnect(TJvTFSched(Sender));\r\n // implicit post fix\r\n //sncPostAppt: FModified := False;\r\n sncPostAppt:\r\n PostApptNotification;\r\n sncDeleteAppt:\r\n InternalClearSchedules;\r\n sncRefresh:\r\n FModified := False;\r\n end;\r\nend;\r\n\r\nprocedure TJvTFAppt.NotifyManager(Serv: TJvTFScheduleManager; Sender: TObject;\r\n Code: TJvTFServNotifyCode);\r\nbegin\r\n if Assigned(Serv) then\r\n Serv.Notify(Sender, Code)\r\n else\r\n raise EJvTFScheduleManagerError.CreateRes(@RsEScheduleManagerNotificationFailedSc);\r\nend;\r\n\r\nprocedure TJvTFAppt.NotifySchedule(Sched: TJvTFSched; Sender: TObject;\r\n Code: TJvTFServNotifyCode);\r\nbegin\r\n if Assigned(Sched) then\r\n Sched.Notify(Sender, Code)\r\n else\r\n raise EJvTFScheduleManagerError.CreateRes(@RsEScheduleNotificationFailed);\r\nend;\r\n\r\nfunction TJvTFAppt.GetConnection(Index: Integer): TJvTFSched;\r\nbegin\r\n Result := TJvTFSched(FConnections.Objects[Index]);\r\nend;\r\n\r\nfunction TJvTFAppt.GetSchedule(Index: Integer): string;\r\nbegin\r\n Result := FSchedules[Index];\r\nend;\r\n\r\nprocedure TJvTFAppt.CheckConnections;\r\nvar\r\n Schedule: TJvTFSched;\r\n I: Integer;\r\n ADate: TDate;\r\n Temp: TStringList;\r\nbegin\r\n // Schedules --> Connections\r\n for I := 0 to ScheduleCount - 1 do\r\n begin\r\n ADate := StartDate;\r\n while Trunc(ADate) <= Trunc(EndDate) do\r\n begin\r\n Schedule := ScheduleManager.FindSchedule(Schedules[I], ADate);\r\n if Assigned(Schedule) and (FConnections.IndexOfObject(Schedule) = -1) then\r\n Connect(Schedule);\r\n\r\n ADate := ADate + 1;\r\n end;\r\n end;\r\n\r\n // Connections --> Schedules\r\n Temp := TStringList.Create;\r\n try\r\n Temp.Assign(FConnections);\r\n for I := 0 to Temp.Count - 1 do\r\n begin\r\n Schedule := TJvTFSched(Temp.Objects[I]);\r\n if (FSchedules.IndexOf(Schedule.SchedName) = -1) or\r\n ((Trunc(Schedule.SchedDate) < Trunc(StartDate)) or\r\n (Trunc(Schedule.SchedDate) > Trunc(EndDate))) then\r\n Disconnect(Schedule);\r\n end;\r\n finally\r\n Temp.Free;\r\n end;\r\n\r\n { implicit post fix\r\n If not FDeleting and not ScheduleManager.LoadingAppts and not ScheduleManager.Refreshing Then\r\n // To avoid display anomolies we need to post the appt here.\r\n Post;\r\n }\r\nend;\r\n\r\nprocedure TJvTFAppt.Connect(Schedule: TJvTFSched);\r\nvar\r\n SchedID: string;\r\n I: Integer;\r\nbegin\r\n if Assigned(Schedule) then\r\n begin\r\n Schedule.Notify(Self, sncConnectAppt);\r\n\r\n SchedID := ScheduleManager.GetScheduleID(Schedule.SchedName, Schedule.SchedDate);\r\n I := FConnections.IndexOf(SchedID);\r\n if I = -1 then\r\n begin\r\n FConnections.AddObject(SchedID, Schedule);\r\n ScheduleManager.RefreshConnections(Schedule);\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvTFAppt.Disconnect(Schedule: TJvTFSched);\r\nvar\r\n I: Integer;\r\nbegin\r\n if Assigned(Schedule) then\r\n begin\r\n Schedule.Notify(Self, sncDisconnectAppt);\r\n\r\n I := FConnections.IndexOfObject(Schedule);\r\n if I > -1 then\r\n begin\r\n FConnections.Delete(I);\r\n ScheduleManager.RefreshConnections(Schedule);\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvTFAppt.Change;\r\nbegin\r\n // implicit post fix\r\n if not ScheduleManager.LoadingAppts and not ScheduleManager.Refreshing and not Updating then\r\n Post;\r\n ScheduleManager.RefreshConnections(Self);\r\nend;\r\n\r\nprocedure TJvTFAppt.InternalClearSchedules;\r\nbegin\r\n FSchedules.Clear;\r\n CheckConnections;\r\nend;\r\n\r\nprocedure TJvTFAppt.Assign(Source: TPersistent);\r\nvar\r\n I: Integer;\r\nbegin\r\n if Source is TJvTFAppt then\r\n begin\r\n for I := 0 to TJvTFAppt(Source).ScheduleCount - 1 do\r\n AddSchedule(TJvTFAppt(Source).Schedules[I]);\r\n ImageMap.Assign(TJvTFAppt(Source).ImageMap);\r\n SetStartEnd(TJvTFAppt(Source).StartDate, TJvTFAppt(Source).StartTime,\r\n TJvTFAppt(Source).EndDate, TJvTFAppt(Source).EndTime);\r\n Description := TJvTFAppt(Source).Description;\r\n AlarmEnabled := TJvTFAppt(Source).AlarmEnabled;\r\n AlarmAdvance := TJvTFAppt(Source).AlarmAdvance;\r\n Data := TJvTFAppt(Source).Data;\r\n end\r\n else\r\n inherited Assign(Source);\r\nend;\r\n\r\nprocedure TJvTFAppt.SetStartEnd(NewStartDate: TDate; NewStartTime: TTime;\r\n NewEndDate: TDate; NewEndTime: TTime);\r\nbegin\r\n // The following avoids time overflow into next day when it is not\r\n // intended. (Add appt to last row of days would cause invalid\r\n // start/end exception.)\r\n if Frac(NewEndTime) <= EncodeTime(0, 0, 0, 999) then\r\n NewEndTime := EncodeTime(23, 59, 59, 0);\r\n\r\n if Trunc(NewStartDate) <= Trunc(NewEndDate) then\r\n begin\r\n if Trunc(NewStartDate) = Trunc(NewEndDate) then\r\n if Frac(NewStartTime) >= Frac(NewEndTime) then\r\n raise EJvTFScheduleManagerError.CreateRes(@RsEInvalidStartAndEndTimes);\r\n\r\n FStartDate := NewStartDate;\r\n FEndDate := NewEndDate;\r\n FStartTime := NewStartTime;\r\n FEndTime := NewEndTime;\r\n\r\n CheckConnections;\r\n\r\n if not ScheduleManager.LoadingAppts and not ScheduleManager.Refreshing then\r\n begin\r\n FModified := True;\r\n Change;\r\n end\r\n end\r\n else\r\n raise EJvTFScheduleManagerError.CreateRes(@RsEInvalidStartAndEndDates);\r\nend;\r\n\r\nprocedure TJvTFAppt.SetModified;\r\nbegin\r\n FModified := True;\r\n // implicit post fix\r\n Change;\r\nend;\r\n\r\nfunction TJvTFAppt.Modified: Boolean;\r\nbegin\r\n Result := FModified;\r\nend;\r\n\r\nfunction TJvTFAppt.ConnectionCount: Integer;\r\nbegin\r\n Result := FConnections.Count;\r\nend;\r\n\r\nfunction TJvTFAppt.ScheduleCount: Integer;\r\nbegin\r\n Result := FSchedules.Count;\r\nend;\r\n\r\nprocedure TJvTFAppt.AddSchedule(const SchedName: string);\r\nvar\r\n ADate: TDate;\r\n Schedule: TJvTFSched;\r\nbegin\r\n if SchedName = '' then\r\n Exit;\r\n\r\n // Add it to the schedules list\r\n if FSchedules.IndexOf(SchedName) = -1 then\r\n begin\r\n FSchedules.Add(SchedName);\r\n if not ScheduleManager.LoadingAppts and not ScheduleManager.Refreshing then\r\n begin\r\n FModified := True;\r\n // implicit post fix\r\n Change;\r\n end;\r\n end;\r\n\r\n // Check for needed connections\r\n // (Only connects to currently loaded schedules. Will not load a schedule.)\r\n ADate := StartDate;\r\n while Trunc(ADate) <= Trunc(EndDate) do\r\n begin\r\n Schedule := ScheduleManager.FindSchedule(SchedName, ADate);\r\n if Assigned(Schedule) then\r\n Connect(Schedule);\r\n ADate := ADate + 1;\r\n end;\r\n\r\n { implicit post fix\r\n // To avoid display anomolies we need to post the appt here.\r\n If not FDeleting and not ScheduleManager.LoadingAppts and not ScheduleManager.Refreshing Then\r\n Post;\r\n }\r\nend;\r\n\r\nprocedure TJvTFAppt.RemoveSchedule(const SchedName: string);\r\nvar\r\n I: Integer;\r\n ADate: TDate;\r\n Schedule: TJvTFSched;\r\nbegin\r\n if SchedName = '' then\r\n Exit;\r\n\r\n // Remove it from the schedule list\r\n I := FSchedules.IndexOf(SchedName);\r\n if I > -1 then\r\n begin\r\n FSchedules.Delete(I);\r\n if not ScheduleManager.LoadingAppts and not ScheduleManager.Refreshing then\r\n begin\r\n FModified := True;\r\n // implicit post fix\r\n Change;\r\n end;\r\n end;\r\n\r\n // Check for invalid connections and disconnect\r\n ADate := StartDate;\r\n while Trunc(ADate) <= Trunc(EndDate) do\r\n begin\r\n Schedule := ScheduleManager.FindSchedule(SchedName, ADate);\r\n if Assigned(Schedule) then\r\n Disconnect(Schedule);\r\n\r\n ADate := ADate + 1;\r\n end;\r\n\r\n { implicit post fix\r\n // To avoid display anomolies we need to post the appt here.\r\n If not FDeleting and not ScheduleManager.LoadingAppts and not ScheduleManager.Refreshing Then\r\n Post;\r\n }\r\nend;\r\n\r\nprocedure TJvTFAppt.AssignSchedules(List: TStrings);\r\nbegin\r\n FSchedules.Assign(List);\r\n if not ScheduleManager.LoadingAppts and not ScheduleManager.Refreshing then\r\n begin\r\n FModified := True;\r\n // implicit post fix\r\n Change;\r\n end;\r\n\r\n CheckConnections;\r\nend;\r\n\r\nprocedure TJvTFAppt.ClearSchedules;\r\nbegin\r\n FSchedules.Clear;\r\n\r\n if not ScheduleManager.LoadingAppts and not ScheduleManager.Refreshing then\r\n begin\r\n FModified := True;\r\n // implicit post fix\r\n Change;\r\n end;\r\n\r\n CheckConnections;\r\nend;\r\n\r\nfunction TJvTFAppt.IndexOfSchedule(const SchedName: string): Integer;\r\nbegin\r\n Result := FSchedules.IndexOf(SchedName);\r\nend;\r\n\r\nfunction TJvTFAppt.Shared: Boolean;\r\nbegin\r\n Result := ScheduleCount > 1;\r\nend;\r\n\r\nprocedure TJvTFAppt.Post;\r\nbegin\r\n ScheduleManager.dbPostAppt(Self);\r\nend;\r\n\r\nprocedure TJvTFAppt.Refresh;\r\nbegin\r\n ScheduleManager.dbRefreshAppt(Self);\r\nend;\r\n\r\nprocedure TJvTFAppt.Delete;\r\nbegin\r\n ScheduleManager.dbDeleteAppt(Self);\r\nend;\r\n\r\nprocedure TJvTFAppt.RefreshControls;\r\nbegin\r\n ScheduleManager.RefreshConnections(Self);\r\nend;\r\n\r\nfunction TJvTFAppt.GetEndDateTime: TDateTime;\r\nbegin\r\n Result := Trunc(EndDate) + Frac(EndTime);\r\nend;\r\n\r\nfunction TJvTFAppt.GetStartDateTime: TDateTime;\r\nbegin\r\n Result := Trunc(StartDate) + Frac(StartTime);\r\nend;\r\n\r\nfunction TJvTFAppt.GetEndDate: TDate;\r\nbegin\r\n Result := Int(FEndDate);\r\nend;\r\n\r\nfunction TJvTFAppt.GetEndTime: TTime;\r\nbegin\r\n Result := Frac(FEndTime);\r\nend;\r\n\r\nfunction TJvTFAppt.GetStartDate: TDate;\r\nbegin\r\n Result := Int(FStartDate);\r\nend;\r\n\r\nfunction TJvTFAppt.GetStartTime: TTime;\r\nbegin\r\n Result := Frac(FStartTime);\r\nend;\r\n\r\nprocedure TJvTFAppt.DeleteApptNotification;\r\nbegin\r\n FDeleting := True;\r\n try\r\n InternalClearSchedules;\r\n finally\r\n FDeleting := False;\r\n end;\r\nend;\r\n\r\nprocedure TJvTFAppt.PostApptNotification;\r\nbegin\r\n FModified := False;\r\n FUpdating := False;\r\nend;\r\n\r\nprocedure TJvTFAppt.BeginUpdate;\r\nbegin\r\n FUpdating := True;\r\nend;\r\n\r\nprocedure TJvTFAppt.EndUpdate;\r\nbegin\r\n if FUpdating then\r\n begin\r\n FUpdating := False;\r\n Change;\r\n end;\r\nend;\r\n\r\nprocedure TJvTFAppt.SetRefreshed(Value: Boolean);\r\nbegin\r\n FRefreshed := Value;\r\nend;\r\n\r\nprocedure TJvTFAppt.SetGlyph(const Value: TPicture);\r\nbegin\r\n FGlyph.Assign(Value);\r\nend;\r\n\r\nprocedure TJvTFAppt.RefreshNotification;\r\nbegin\r\n FModified := False;\r\n Refreshed := False;\r\nend;\r\n\r\n//=== { TJvTFSched } =========================================================\r\n\r\nconstructor TJvTFSched.Create(Serv: TJvTFScheduleManager; const AName: string;\r\n ADate: TDate);\r\nbegin\r\n inherited Create;\r\n\r\n FScheduleManager := Serv;\r\n FSchedName := AName;\r\n FSchedDate := ADate;\r\n\r\n FAppts := TStringList.Create;\r\n FConControls := TStringList.Create;\r\n FConControls.OnChange := ConnectionsOnChange;\r\n FConComponents := TStringList.Create;\r\n FConComponents.OnChange := ConnectionsOnChange;\r\n\r\n if Assigned(Serv) then\r\n Serv.DoCreateScheduleEvent(Self);\r\nend;\r\n\r\ndestructor TJvTFSched.Destroy;\r\nvar\r\n Ctrl: TJvTFControl;\r\n Comp: TJvTFComponent;\r\n Appt: TJvTFAppt;\r\nbegin\r\n FDestroying := True;\r\n\r\n if Assigned(ScheduleManager) then\r\n ScheduleManager.DoDestroyScheduleEvent(Self);\r\n\r\n while ConControlCount > 0 do\r\n begin\r\n Ctrl := TJvTFControl(FConControls.Objects[0]);\r\n ScheduleManager.ReleaseSchedule(Ctrl, SchedName, SchedDate);\r\n end;\r\n\r\n while ConComponentCount > 0 do\r\n begin\r\n Comp := TJvTFComponent(FConComponents.Objects[0]);\r\n ScheduleManager.ReleaseSchedule(Comp, SchedName, SchedDate);\r\n end;\r\n\r\n while ApptCount > 0 do\r\n begin\r\n Appt := Appts[0];\r\n Appt.Notify(Self, sncDisconnectAppt);\r\n end;\r\n\r\n ScheduleManager.Notify(Self, sncDestroySchedule);\r\n\r\n FAppts.Free;\r\n FConControls.Free;\r\n FConComponents.Free;\r\n\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJvTFSched.GetAppt(Index: Integer): TJvTFAppt;\r\nbegin\r\n Result := TJvTFAppt(FAppts.Objects[Index]);\r\nend;\r\n\r\nprocedure TJvTFSched.Notify(Sender: TObject; Code: TJvTFServNotifyCode);\r\nvar\r\n I: Integer;\r\n ConList: TStringList;\r\nbegin\r\n if Sender is TJvTFControl then\r\n ConList := FConControls\r\n else\r\n if Sender is TJvTFComponent then\r\n ConList := FConComponents\r\n else\r\n ConList := nil;\r\n\r\n case Code of\r\n sncRequestSchedule:\r\n if ConList.IndexOfObject(Sender) = -1 then\r\n ConList.AddObject('', Sender);\r\n sncReleaseSchedule:\r\n begin\r\n I := ConList.IndexOfObject(Sender);\r\n if I > -1 then\r\n ConList.Delete(I);\r\n end;\r\n sncConnectAppt:\r\n ConnectAppt(TJvTFAppt(Sender));\r\n sncDisconnectAppt:\r\n DisconnectAppt(TJvTFAppt(Sender));\r\n end;\r\nend;\r\n\r\nprocedure TJvTFSched.NotifyManager(Serv: TJvTFScheduleManager; Sender: TObject;\r\n Code: TJvTFServNotifyCode);\r\nbegin\r\n if Assigned(Serv) then\r\n Serv.Notify(Sender, Code)\r\n else\r\n raise EJvTFScheduleManagerError.CreateRes(@RsEScheduleManagerNotificationFailedSc);\r\nend;\r\n\r\nprocedure TJvTFSched.NotifyAppt(Appt: TJvTFAppt; Sender: TObject;\r\n Code: TJvTFServNotifyCode);\r\nbegin\r\n if Assigned(Appt) then\r\n Appt.Notify(Sender, Code)\r\n else\r\n raise EJvTFScheduleManagerError.CreateRes(@RsEAppointmentNotificationFailed);\r\nend;\r\n\r\nfunction TJvTFSched.GetConControl(Index: Integer): TJvTFControl;\r\nbegin\r\n Result := TJvTFControl(FConControls.Objects[Index]);\r\nend;\r\n\r\nfunction TJvTFSched.GetConComponent(Index: Integer): TJvTFComponent;\r\nbegin\r\n Result := TJvTFComponent(FConComponents.Objects[Index]);\r\nend;\r\n\r\nprocedure TJvTFSched.ConnectAppt(Appt: TJvTFAppt);\r\nbegin\r\n if FAppts.IndexOf(Appt.ID) = -1 then\r\n FAppts.AddObject(Appt.ID, Appt);\r\nend;\r\n\r\nprocedure TJvTFSched.DisconnectAppt(Appt: TJvTFAppt);\r\nvar\r\n I: Integer;\r\nbegin\r\n I := FAppts.IndexOf(Appt.ID);\r\n if I > -1 then\r\n FAppts.Delete(I);\r\nend;\r\n\r\nprocedure TJvTFSched.ConnectionsOnChange(Sender: TObject);\r\nbegin\r\n if (FConControls.Count = 0) and (FConComponents.Count = 0) then\r\n begin\r\n FCached := True;\r\n FCachedTime := Windows.GetTickCount;\r\n end\r\n else\r\n FCached := False;\r\nend;\r\n\r\nprocedure TJvTFSched.CheckConnections;\r\nvar\r\n I: Integer;\r\n Appt: TJvTFAppt;\r\n DateHit, NameMatch, NotConnected: Boolean;\r\nbegin\r\n // Check each appt in the ScheduleManager to see if that appt should be connected\r\n // to this schedule. If so, then connect it.\r\n for I := 0 to ScheduleManager.ApptCount - 1 do\r\n begin\r\n Appt := ScheduleManager.Appts[I];\r\n DateHit := (Trunc(SchedDate) >= Trunc(Appt.StartDate)) and\r\n (Trunc(SchedDate) <= Trunc(Appt.EndDate));\r\n NameMatch := Appt.IndexOfSchedule(SchedName) > -1;\r\n NotConnected := ApptByID(Appt.ID) = nil;\r\n if DateHit and NameMatch and NotConnected then\r\n Appt.Notify(Self, sncConnectAppt);\r\n end;\r\nend;\r\n\r\nfunction TJvTFSched.GetFreeUsedTime(FreeTime: Boolean): TDynTimeRangeArray;\r\nvar\r\n // 60 mins X 24 hrs = 1440 ==> minutes in a day\r\n DayArray: array [0..1439] of Boolean; // I'm a poet and don't know it.\r\n I, J, MinStart, MinEnd: Integer;\r\n anAppt: TJvTFAppt;\r\n StartTime, EndTime: TTime;\r\n Switch, MinIsFree, InRange: Boolean;\r\n\r\n function TimeToMinNum(ATime: TTime): Integer;\r\n var\r\n H, M, S, MS: Word;\r\n begin\r\n DecodeTime(ATime, H, M, S, MS);\r\n Result := H * 60 + M;\r\n end;\r\n\r\n function MinNumToTime(MinNum: Integer): TTime;\r\n begin\r\n Result := EncodeTime(MinNum div 60, MinNum mod 60, 0, 0);\r\n end;\r\n\r\n procedure StartRange;\r\n begin\r\n StartTime := MinNumToTime(I);\r\n InRange := True;\r\n end;\r\n\r\n procedure EndRange;\r\n begin\r\n EndTime := MinNumToTime(I);\r\n\r\n // add range to resultant array\r\n SetLength(Result, Length(Result) + 1);\r\n Result[High(Result)].StartTime := StartTime;\r\n Result[High(Result)].EndTime := EndTime;\r\n\r\n InRange := False;\r\n end;\r\n\r\nbegin\r\n // Initialize resultant array\r\n SetLength(Result, 1);\r\n Result[0].StartTime := 0.0;\r\n Result[0].EndTime := EncodeTime(23, 59, 59, 0);\r\n\r\n // EXIT if nothing to do\r\n if ApptCount = 0 then\r\n begin\r\n if not FreeTime then\r\n SetLength(Result, 0);\r\n Exit;\r\n end;\r\n\r\n // Initialize working array\r\n // True ==> free minute\r\n // False ==> used minute\r\n for I := 0 to 1439 do\r\n DayArray[I] := True;\r\n\r\n // Go through the appts and mark used minutes in the working array\r\n for I := 0 to ApptCount - 1 do\r\n begin\r\n anAppt := Appts[I];\r\n MinStart := TimeToMinNum(anAppt.StartTime);\r\n MinEnd := TimeToMinNum(AdjustEndTime(anAppt.EndTime));\r\n\r\n for J := MinStart to MinEnd do\r\n DayArray[J] := False;\r\n end;\r\n\r\n // Now convert working array to resultant array\r\n SetLength(Result, 0);\r\n MinIsFree := not FreeTime;\r\n for I := 0 to 1439 do\r\n begin\r\n Switch := DayArray[I] xor MinIsFree;\r\n MinIsFree := DayArray[I];\r\n if Switch then\r\n if MinIsFree then\r\n if FreeTime then\r\n StartRange\r\n else\r\n EndRange\r\n else\r\n if FreeTime then\r\n EndRange\r\n else\r\n StartRange\r\n end;\r\n\r\n // close and add the last range if needed\r\n if InRange then\r\n begin\r\n I := 1439; // set I to last min of day\r\n EndRange;\r\n end;\r\nend;\r\n\r\nfunction TJvTFSched.ApptCount: Integer;\r\nbegin\r\n Result := FAppts.Count;\r\nend;\r\n\r\nfunction TJvTFSched.ApptByID(const ID: string): TJvTFAppt;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := nil;\r\n I := FAppts.IndexOf(ID);\r\n if I > -1 then\r\n Result := TJvTFAppt(FAppts.Objects[I]);\r\nend;\r\n\r\nfunction TJvTFSched.ConControlCount: Integer;\r\nbegin\r\n Result := FConControls.Count;\r\nend;\r\n\r\nfunction TJvTFSched.ConComponentCount: Integer;\r\nbegin\r\n Result := FConComponents.Count;\r\nend;\r\n\r\nprocedure TJvTFSched.AddAppt(Appt: TJvTFAppt);\r\nbegin\r\n if Assigned(Appt) then\r\n Appt.AddSchedule(SchedName);\r\nend;\r\n\r\nprocedure TJvTFSched.RemoveAppt(Appt: TJvTFAppt);\r\nbegin\r\n if Assigned(Appt) then\r\n Appt.RemoveSchedule(SchedName);\r\nend;\r\n{\r\nprocedure TJvTFSched.RefreshAppts;\r\nVar\r\n I,\r\n J,\r\n K: Integer;\r\n ApptIDList,\r\n RefList: TStringList;\r\n Appt: TJvTFAppt;\r\n Sched: TJvTFSched;\r\n RefID: string;\r\nbegin\r\n // In a multi-user environment, appt objects may be deleted as a result\r\n // of calling dbRefreshAppt. (Component user may call Appt.Free.)\r\n // To account for this we need to build a list of appt ID's instead of\r\n // working directly from the ScheduleManager's appointment list.\r\n // We also need to build a list of connections (Components and\r\n // TJvTFControls) that need to be refreshed.\r\n\r\n ApptIDList := TStringList.Create;\r\n RefList := TStringList.Create;\r\n RefList.Duplicates := dupIgnore;\r\n Try\r\n For I := 0 to ApptCount - 1 do\r\n Begin\r\n Appt := Appts[I];\r\n ApptIDList.Add(Appt.ID);\r\n For J := 0 to Appt.ConnectionCount - 1 do\r\n Begin\r\n Sched := Appt.Connections[J];\r\n For K := 0 to Sched.ConComponentCount - 1 do\r\n Begin\r\n RefID := IntToStr(Integer(Sched.ConComponents[K]));\r\n RefList.AddObject(RefID, Sched.ConComponents[K]);\r\n End;\r\n For K := 0 to Sched.ConControlCount - 1 do\r\n Begin\r\n RefID := IntToStr(Integer(Sched.ConControls[K]));\r\n RefList.AddObject(RefID, Sched.ConControls[K]);\r\n End;\r\n End;\r\n End;\r\n\r\n For I := 0 to ApptIDList.Count - 1 do\r\n Begin\r\n Appt := ScheduleManager.FindAppt(ApptIDList[I]);\r\n If Assigned(Appt) Then\r\n ScheduleManager.dbRefreshAppt(Appt);\r\n End;\r\n\r\n For I := 0 to RefList.Count - 1 do\r\n ScheduleManager.RefreshConnections(RefList.Objects[I]);\r\n Finally\r\n ApptIDList.Free;\r\n RefList.Free;\r\n End;\r\nend;\r\n}\r\n\r\nprocedure TJvTFSched.PostAppts;\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := 0 to ApptCount - 1 do\r\n ScheduleManager.dbPostAppt(Appts[I]);\r\nend;\r\n\r\nfunction TJvTFSched.GetFreeTime: TDynTimeRangeArray;\r\nbegin\r\n Result := GetFreeUsedTime(True);\r\nend;\r\n\r\nfunction TJvTFSched.GetUsedTime: TDynTimeRangeArray;\r\nbegin\r\n Result := GetFreeUsedTime(False);\r\nend;\r\n\r\nfunction TJvTFSched.TimeIsFree(TimeRange: TJvTFTimeRange): Boolean;\r\nvar\r\n Appt: TJvTFAppt;\r\n I: Integer;\r\nbegin\r\n Result := True;\r\n I := 0;\r\n\r\n while (I < ApptCount) and Result do\r\n begin\r\n Appt := Appts[I];\r\n if (Frac(Appt.StartTime) <= Frac(AdjustEndTime(TimeRange.EndTime))) and\r\n (Frac(AdjustEndTime(Appt.EndTime)) >= Frac(TimeRange.StartTime)) then\r\n Result := False\r\n else\r\n Inc(I);\r\n end;\r\nend;\r\n\r\nfunction TJvTFSched.TimeIsFree(RangeStart, RangeEnd: TTime): Boolean;\r\nvar\r\n TimeRange: TJvTFTimeRange;\r\nbegin\r\n TimeRange.StartTime := RangeStart;\r\n TimeRange.EndTime := RangeEnd;\r\n Result := TimeIsFree(TimeRange);\r\nend;\r\n\r\nfunction TJvTFSched.ApptHasConflicts(anAppt: TJvTFAppt): Boolean;\r\nvar\r\n Appt: TJvTFAppt;\r\n I: Integer;\r\nbegin\r\n Result := False;\r\n I := 0;\r\n\r\n while (I < ApptCount) and not Result do\r\n begin\r\n Appt := Appts[I];\r\n if (Appt <> anAppt) and // Don't flag for the given appt\r\n (Frac(Appt.StartTime) <= Frac(AdjustEndTime(anAppt.EndTime))) and\r\n (Frac(AdjustEndTime(Appt.EndTime)) >= Frac(anAppt.StartTime)) then\r\n Result := True\r\n else\r\n Inc(I);\r\n end;\r\nend;\r\n\r\nfunction TJvTFSched.EnumConflicts(TimeRange: TJvTFTimeRange): TDynApptArray;\r\nvar\r\n Appt: TJvTFAppt;\r\n I: Integer;\r\nbegin\r\n SetLength(Result, 0);\r\n for I := 0 to ApptCount - 1 do\r\n begin\r\n Appt := Appts[I];\r\n if (Frac(Appt.StartTime) <= Frac(AdjustEndTime(TimeRange.EndTime))) and\r\n (Frac(AdjustEndTime(Appt.EndTime)) >= Frac(TimeRange.StartTime)) then\r\n begin\r\n SetLength(Result, Length(Result) + 1);\r\n Result[High(Result)] := Appt;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJvTFSched.EnumConflicts(RangeStart, RangeEnd: TTime): TDynApptArray;\r\nvar\r\n TimeRange: TJvTFTimeRange;\r\nbegin\r\n TimeRange.StartTime := RangeStart;\r\n TimeRange.EndTime := RangeEnd;\r\n Result := EnumConflicts(TimeRange);\r\nend;\r\n\r\nfunction TJvTFSched.EnumConflicts(anAppt: TJvTFAppt): TDynApptArray;\r\nvar\r\n Appt: TJvTFAppt;\r\n I: Integer;\r\nbegin\r\n SetLength(Result, 0);\r\n for I := 0 to ApptCount - 1 do\r\n begin\r\n Appt := Appts[I];\r\n if (Appt <> anAppt) and // don't add the given appt\r\n (Frac(Appt.StartTime) <= Frac(AdjustEndTime(anAppt.EndTime))) and\r\n (Frac(AdjustEndTime(Appt.EndTime)) >= Frac(anAppt.StartTime)) then\r\n begin\r\n SetLength(Result, Length(Result) + 1);\r\n Result[High(Result)] := Appt;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJvTFSched.GetFirstAppt: TJvTFAppt;\r\nvar\r\n I: Integer;\r\n anAppt: TJvTFAppt;\r\nbegin\r\n Result := nil;\r\n I := 0;\r\n while (I < ApptCount) do\r\n begin\r\n anAppt := Appts[I];\r\n if Trunc(anAppt.StartDate) < Trunc(SchedDate) then\r\n begin\r\n Result := anAppt;\r\n Break; // APPOINTMENT STARTS AT 0:00 (12:00am) SO LEAVE LOOP\r\n end\r\n else\r\n if not Assigned(Result) then\r\n Result := anAppt\r\n else\r\n if Frac(anAppt.StartTime) < Frac(Result.StartTime) then\r\n Result := anAppt;\r\n Inc(I);\r\n end;\r\nend;\r\n\r\nfunction TJvTFSched.GetLastAppt: TJvTFAppt;\r\nvar\r\n I: Integer;\r\n anAppt: TJvTFAppt;\r\nbegin\r\n Result := nil;\r\n I := 0;\r\n while (I < ApptCount) do\r\n begin\r\n anAppt := Appts[I];\r\n if Trunc(anAppt.EndDate) > Trunc(SchedDate) then\r\n begin\r\n Result := anAppt;\r\n Break; // APPOINTMENT ENDS AT 23:59 (11:59pm) SO LEAVE LOOP\r\n end\r\n else\r\n if not Assigned(Result) then\r\n Result := anAppt\r\n else\r\n if Frac(anAppt.EndTime) > Frac(Result.EndTime) then\r\n Result := anAppt;\r\n Inc(I);\r\n end;\r\nend;\r\n\r\nprocedure TJvTFSched.Refresh;\r\nbegin\r\n ScheduleManager.dbRefreshSched(Self);\r\nend;\r\n\r\nprocedure TJvTFSched.SetSchedDisplayName(const Value: string);\r\nbegin\r\n if FSchedDisplayName <> Value then\r\n begin\r\n FSchedDisplayName := Value;\r\n ScheduleManager.RefreshConnections(Self);\r\n end;\r\nend;\r\n\r\n//=== { TJvTFScheduleManagerCache } ==========================================\r\n\r\nconstructor TJvTFScheduleManagerCache.Create(SchedManager: TJvTFScheduleManager);\r\nbegin\r\n inherited Create;\r\n FScheduleManager := SchedManager;\r\n\r\n FCacheType := ctTimed;\r\n FTimedDelay := 30000;\r\n FBufferCount := 7;\r\n\r\n FTimer := TTimer.Create(nil);\r\n FTimer.OnTimer := TimerOnTimer;\r\n FTimer.Interval := FTimedDelay;\r\n FTimer.Enabled := FCacheType = ctTimed;\r\nend;\r\n\r\ndestructor TJvTFScheduleManagerCache.Destroy;\r\nbegin\r\n FTimer.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvTFScheduleManagerCache.SetCacheType(Value: TJvTFScheduleManagerCacheType);\r\nbegin\r\n if Value <> FCacheType then\r\n begin\r\n FCacheType := Value;\r\n FTimer.Enabled := Value = ctTimed;\r\n FlushManager;\r\n end;\r\nend;\r\n\r\nprocedure TJvTFScheduleManagerCache.SetTimedDelay(Value: Integer);\r\nbegin\r\n if Value < 0 then\r\n Value := 0;\r\n if Value <> FTimedDelay then\r\n begin\r\n FTimedDelay := Value;\r\n FTimer.Enabled := False;\r\n FTimer.Interval := Value;\r\n if CacheType = ctTimed then\r\n begin\r\n FTimer.Enabled := True;\r\n FlushManager;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvTFScheduleManagerCache.SetBufferCount(Value: Integer);\r\nbegin\r\n if Value < 0 then\r\n Value := 0;\r\n if Value <> FBufferCount then\r\n begin\r\n FBufferCount := Value;\r\n if CacheType = ctBuffer then\r\n FlushManager;\r\n end;\r\nend;\r\n\r\nprocedure TJvTFScheduleManagerCache.FlushManager;\r\nbegin\r\n if Assigned(FScheduleManager) then\r\n FScheduleManager.Flush(False);\r\nend;\r\n\r\nprocedure TJvTFScheduleManagerCache.TimerOnTimer(Sender: TObject);\r\nbegin\r\n FlushManager;\r\nend;\r\n\r\nprocedure TJvTFScheduleManagerCache.Assign(Source: TPersistent);\r\nbegin\r\n if Source is TJvTFScheduleManagerCache then\r\n begin\r\n FCacheType := TJvTFScheduleManagerCache(Source).CacheType;\r\n FTimedDelay := TJvTFScheduleManagerCache(Source).TimedDelay;\r\n FBufferCount := TJvTFScheduleManagerCache(Source).BufferCount;\r\n if FTimer.Enabled then\r\n begin\r\n FTimer.Enabled := False;\r\n FTimer.Interval := FTimedDelay;\r\n FTimer.Enabled := FCacheType = ctTimed;\r\n end;\r\n FlushManager;\r\n end\r\n else\r\n inherited Assign(Source);\r\nend;\r\n\r\n//=== { TJvTFScheduleManager } ===============================================\r\n\r\nconstructor TJvTFScheduleManager.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n\r\n FSchedLoadMode := slmOnDemand;\r\n FAppts := TStringList.Create;\r\n FSchedules := TStringList.Create;\r\n\r\n FSchedBatch := TStringList.Create;\r\n FSchedBatch.Sorted := True;\r\n FSchedBatch.Duplicates := dupIgnore;\r\n\r\n FConControls := TStringList.Create;\r\n FConComponents := TStringList.Create;\r\n\r\n FStateImageMap := TJvTFStateImageMap.Create(Self);\r\n FImageChangeLink := TChangeLink.Create;\r\n FImageChangeLink.OnChange := ImageListChange;\r\n\r\n FCache := TJvTFScheduleManagerCache.Create(Self);\r\n FApptBeingDestroyed := nil;\r\nend;\r\n\r\ndestructor TJvTFScheduleManager.Destroy;\r\nbegin\r\n FDestroying := True;\r\n\r\n while ConControlCount > 0 do\r\n ConControls[0].ScheduleManager := nil;\r\n\r\n while ConComponentCount > 0 do\r\n ConComponents[0].ScheduleManager := nil;\r\n\r\n while ScheduleCount > 0 do\r\n Schedules[0].Free;\r\n\r\n while ApptCount > 0 do\r\n Appts[0].Free;\r\n\r\n FAppts.Free;\r\n FSchedBatch.Free;\r\n FSchedules.Free;\r\n FConControls.Free;\r\n FConComponents.Free;\r\n FStateImageMap.Free;\r\n\r\n StateImages := nil;\r\n CustomImages := nil;\r\n FImageChangeLink.Free;\r\n\r\n FCache.Free;\r\n\r\n inherited Destroy;\r\nend;\r\n\r\nclass function TJvTFScheduleManager.GetScheduleID(const SchedName: string;\r\n SchedDate: TDate): string;\r\nbegin\r\n Result := SchedName + IntToStr(Trunc(SchedDate));\r\nend;\r\n\r\nclass function TJvTFScheduleManager.GenerateApptID: string;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := FloatToStr(Now);\r\n Randomize;\r\n for I := 1 to 5 do\r\n Result := Result + Chr(Random(25) + 65);\r\nend;\r\n\r\nfunction TJvTFScheduleManager.GetAppt(Index: Integer): TJvTFAppt;\r\nbegin\r\n Result := TJvTFAppt(FAppts.Objects[Index]);\r\nend;\r\n\r\nfunction TJvTFScheduleManager.GetSchedule(Index: Integer): TJvTFSched;\r\nbegin\r\n Result := TJvTFSched(FSchedules.Objects[Index]);\r\nend;\r\n\r\nfunction TJvTFScheduleManager.GetConControl(Index: Integer): TJvTFControl;\r\nbegin\r\n Result := TJvTFControl(FConControls.Objects[Index]);\r\nend;\r\n\r\nfunction TJvTFScheduleManager.GetConComponent(Index: Integer): TJvTFComponent;\r\nbegin\r\n Result := TJvTFComponent(FConComponents.Objects[Index]);\r\nend;\r\n\r\nprocedure TJvTFScheduleManager.SetStateImages(Value: TCustomImageList);\r\nbegin\r\n ReplaceImageListReference(Self, Value, FStateImages, FImageChangeLink);\r\nend;\r\n\r\nprocedure TJvTFScheduleManager.SetCustomImages(Value: TCustomImageList);\r\nbegin\r\n ReplaceImageListReference(Self, Value, FCustomImages, FImageChangeLink);\r\nend;\r\n\r\nprocedure TJvTFScheduleManager.SetCache(Value: TJvTFScheduleManagerCache);\r\nbegin\r\n FCache.Assign(Value);\r\nend;\r\n\r\nprocedure TJvTFScheduleManager.Notification(AComponent: TComponent;\r\n Operation: TOperation);\r\nbegin\r\n inherited Notification(AComponent, Operation);\r\n if Operation = opRemove then\r\n if AComponent = StateImages then\r\n begin\r\n StateImages := nil;\r\n RefreshConnections(nil);\r\n end\r\n else\r\n if AComponent = CustomImages then\r\n begin\r\n CustomImages := nil;\r\n RefreshConnections(nil);\r\n end;\r\nend;\r\n\r\nprocedure TJvTFScheduleManager.ConnectControl(ApptCtrl: TJvTFControl);\r\nvar\r\n I: Integer;\r\nbegin\r\n if not Assigned(ApptCtrl) then\r\n Exit;\r\n\r\n I := FConControls.IndexOfObject(ApptCtrl);\r\n if I = -1 then\r\n FConControls.AddObject('', ApptCtrl);\r\nend;\r\n\r\nprocedure TJvTFScheduleManager.DisconnectControl(ApptCtrl: TJvTFControl);\r\nvar\r\n I: Integer;\r\nbegin\r\n if not Assigned(ApptCtrl) then\r\n Exit;\r\n\r\n I := FConControls.IndexOfObject(ApptCtrl);\r\n if I > -1 then\r\n begin\r\n ApptCtrl.ReleaseSchedules;\r\n FConControls.Delete(I);\r\n end;\r\nend;\r\n\r\nprocedure TJvTFScheduleManager.ConnectComponent(Comp: TJvTFComponent);\r\nvar\r\n I: Integer;\r\nbegin\r\n if not Assigned(Comp) then\r\n Exit;\r\n\r\n I := FConComponents.IndexOfObject(Comp);\r\n if I = -1 then\r\n FConComponents.AddObject('', Comp);\r\nend;\r\n\r\nprocedure TJvTFScheduleManager.DisconnectComponent(Comp: TJvTFComponent);\r\nvar\r\n I: Integer;\r\nbegin\r\n if not Assigned(Comp) then\r\n Exit;\r\n\r\n I := FConComponents.IndexOfObject(Comp);\r\n if I > -1 then\r\n begin\r\n Comp.ReleaseSchedules;\r\n FConComponents.Delete(I);\r\n end;\r\nend;\r\n\r\nprocedure TJvTFScheduleManager.Notify(Sender: TObject; Code: TJvTFServNotifyCode);\r\nbegin\r\n case Code of\r\n sncConnectComponent:\r\n ConnectComponent(TJvTFComponent(Sender));\r\n sncDisconnectComponent:\r\n DisconnectComponent(TJvTFComponent(Sender));\r\n sncConnectControl:\r\n ConnectControl(TJvTFControl(Sender));\r\n sncDisconnectControl:\r\n DisconnectControl(TJvTFControl(Sender));\r\n sncLoadAppt:\r\n AddAppt(TJvTFAppt(Sender));\r\n sncDestroyAppt:\r\n RemoveAppt(TJvTFAppt(Sender));\r\n sncDestroySchedule:\r\n RemoveSchedule(TJvTFSched(Sender));\r\n end;\r\nend;\r\n\r\nprocedure TJvTFScheduleManager.NotifyAppt(Appt: TJvTFAppt; Sender: TObject;\r\n Code: TJvTFServNotifyCode);\r\nbegin\r\n if Assigned(Appt) then\r\n Appt.Notify(Sender, Code);\r\nend;\r\n\r\nprocedure TJvTFScheduleManager.NotifySchedule(Sched: TJvTFSched; Sender: TObject;\r\n Code: TJvTFServNotifyCode);\r\nbegin\r\n if Assigned(Sched) then\r\n Sched.Notify(Sender, Code);\r\nend;\r\n\r\nprocedure TJvTFScheduleManager.NotifyApptCtrl(ApptCtrl: TJvTFControl;\r\n Sender: TObject; Code: TJvTFServNotifyCode);\r\nbegin\r\n if Assigned(ApptCtrl) then\r\n ApptCtrl.Notify(Sender, Code);\r\nend;\r\n\r\nprocedure TJvTFScheduleManager.NotifyComp(Comp: TJvTFComponent;\r\n Sender: TObject; Code: TJvTFServNotifyCode);\r\nbegin\r\n if Assigned(Comp) then\r\n Comp.Notify(Sender, Code);\r\nend;\r\n\r\nprocedure TJvTFScheduleManager.RetrieveSchedule(const SchedName: string; SchedDate: TDate;\r\n var Schedule: TJvTFSched; var LoadedNow: Boolean);\r\nvar\r\n SchedID: string;\r\n I: Integer;\r\nbegin\r\n SchedID := GetScheduleID(SchedName, SchedDate);\r\n I := FSchedules.IndexOf(SchedID);\r\n\r\n if I > -1 then\r\n begin\r\n Schedule := TJvTFSched(FSchedules.Objects[I]);\r\n LoadedNow := False;\r\n end\r\n else\r\n begin\r\n //Schedule := TJvTFSched.Create(Self, SchedName, SchedDate);\r\n Schedule := GetSchedClass.Create(Self, SchedName, SchedDate);\r\n FSchedules.AddObject(SchedID, Schedule);\r\n LoadedNow := True;\r\n if Cache.CacheType = ctBuffer then\r\n Flush(False);\r\n Schedule.CheckConnections;\r\n end;\r\nend;\r\n\r\nprocedure TJvTFScheduleManager.NeedAppts(Schedule: TJvTFSched);\r\nbegin\r\n FLoadingAppts := True;\r\n try\r\n if Assigned(FOnNeedAppts) then\r\n FOnNeedAppts(Self, Schedule);\r\n finally\r\n FLoadingAppts := False;\r\n RefreshConnections(Schedule);\r\n end;\r\nend;\r\n\r\nprocedure TJvTFScheduleManager.AddAppt(Appt: TJvTFAppt);\r\nbegin\r\n if FAppts.IndexOfObject(Appt) = -1 then\r\n FAppts.AddObject(Appt.ID, Appt);\r\nend;\r\n\r\nprocedure TJvTFScheduleManager.RemoveAppt(Appt: TJvTFAppt);\r\nvar\r\n I: Integer;\r\n IndexOfAppt: Integer;\r\nbegin\r\n if Appt = FApptBeingDestroyed then\r\n Exit; // Do Nothing if this is already the Appt we are\r\n // destroying ourselves\r\n\r\n IndexOfAppt := FAppts.IndexOfObject(Appt);\r\n if IndexOfAppt = -1 then\r\n Exit; // Nothing to do if the appt is not in our list\r\n\r\n for I := 0 to ConControlCount - 1 do\r\n NotifyApptCtrl(ConControls[I], Appt, sncDestroyAppt);\r\n\r\n for I := 0 to ConComponentCount - 1 do\r\n NotifyComp(ConComponents[I], Appt, sncDestroyAppt);\r\n\r\n while Appt.ConnectionCount > 0 do\r\n Appt.Notify(Appt.Connections[0], sncDisconnectAppt);\r\n\r\n FAppts.Delete(IndexOfAppt);\r\n\r\n // Do not free if the appt is being destroyed by someone else\r\n if not Appt.Destroying then\r\n begin\r\n FApptBeingDestroyed := Appt;\r\n try\r\n Appt.Free;\r\n finally\r\n FApptBeingDestroyed := nil;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvTFScheduleManager.RemoveSchedule(Sched: TJvTFSched);\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := 0 to ConControlCount - 1 do\r\n NotifyApptCtrl(ConControls[I], Sched, sncDestroySchedule);\r\n\r\n for I := 0 to ConComponentCount - 1 do\r\n NotifyComp(ConComponents[I], Sched, sncDestroySchedule);\r\n\r\n FSchedules.Delete(FSchedules.IndexOfObject(Sched));\r\n Flush(False);\r\nend;\r\n\r\n{\r\nprocedure TJvTFScheduleManager.RefreshAppt(Appt: TJvTFAppt);\r\nbegin\r\n FLoadingAppts := True;\r\n Try\r\n NotifyAppt(Appt, Self, sncRefresh);\r\n If Assigned(FOnRefreshAppt) Then\r\n FOnRefreshAppt(Self, Appt);\r\n Finally\r\n FLoadingAppts := False;\r\n End;\r\nend;\r\n}\r\n\r\nprocedure TJvTFScheduleManager.DeleteAppt(Appt: TJvTFAppt);\r\nbegin\r\n if Assigned(FOnDeleteAppt) then\r\n FOnDeleteAppt(Self, Appt);\r\nend;\r\n\r\nprocedure TJvTFScheduleManager.PostAppt(Appt: TJvTFAppt);\r\nbegin\r\n if Assigned(FOnPostAppt) then\r\n FOnPostAppt(Self, Appt);\r\nend;\r\n\r\nprocedure TJvTFScheduleManager.RequestRefresh(ApptCtrl: TJvTFControl;\r\n Schedule: TJvTFSched);\r\nbegin\r\n NotifyApptCtrl(ApptCtrl, Self, sncRefresh);\r\n {\r\n If Assigned(ApptCtrl) Then\r\n Windows.PostMessage(ApptCtrl.Handle, CN_REQUESTREFRESH, WPARAM(Schedule), 0)\r\n Else\r\n Raise EJvTFScheduleManagerError.Create('Could not send refresh request. ' +\r\n 'ApptCtrl not assigned');\r\n }\r\nend;\r\n\r\nprocedure TJvTFScheduleManager.RequestRefresh(Comp: TJvTFComponent;\r\n Schedule: TJvTFSched);\r\nbegin\r\n NotifyComp(Comp, Self, sncRefresh);\r\nend;\r\n\r\nprocedure TJvTFScheduleManager.ImageListChange(Sender: TObject);\r\nbegin\r\n if not (csDestroying in ComponentState) then\r\n RefreshConnections(nil);\r\nend;\r\n\r\nprocedure TJvTFScheduleManager.FlushAppts;\r\nvar\r\n I: Integer;\r\nbegin\r\n I := 0;\r\n while I < ApptCount do\r\n if (Appts[I].ConnectionCount = 0) and not Appts[I].Persistent then\r\n begin\r\n if not FlushObject(Appts[I]) then\r\n Inc(I);\r\n end\r\n else\r\n Inc(I);\r\nend;\r\n\r\nfunction TJvTFScheduleManager.FlushObject(FlushObj: TObject): Boolean;\r\nvar\r\n FlushIt: Boolean;\r\nbegin\r\n Result := False;\r\n if Assigned(FlushObj) then\r\n begin\r\n FlushIt := True;\r\n if Assigned(FOnFlush) then\r\n FOnFlush(Self, FlushObj, FlushIt);\r\n if FlushIt then\r\n FlushObj.Free;\r\n Result := FlushIt;\r\n end;\r\nend;\r\n\r\nprocedure TJvTFScheduleManager.DoCreateApptEvent(anAppt: TJvTFAppt);\r\nbegin\r\n if Assigned(FOnCreateAppt) then\r\n FOnCreateAppt(Self, anAppt);\r\nend;\r\n\r\nprocedure TJvTFScheduleManager.DoCreateScheduleEvent(aSchedule: TJvTFSched);\r\nbegin\r\n if Assigned(FOnCreateSchedule) then\r\n FOnCreateSchedule(Self, aSchedule);\r\nend;\r\n\r\nprocedure TJvTFScheduleManager.DoDestroyApptEvent(anAppt: TJvTFAppt);\r\nbegin\r\n if Assigned(FOnDestroyAppt) then\r\n FOnDestroyAppt(Self, anAppt);\r\nend;\r\n\r\nprocedure TJvTFScheduleManager.DoDestroyScheduleEvent(aSchedule: TJvTFSched);\r\nbegin\r\n if Assigned(FOnDestroySchedule) then\r\n FOnDestroySchedule(Self, aSchedule);\r\nend;\r\n\r\nfunction TJvTFScheduleManager.ApptCount: Integer;\r\nbegin\r\n Result := FAppts.Count;\r\nend;\r\n\r\nfunction TJvTFScheduleManager.FindAppt(const ID: string): TJvTFAppt;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := nil;\r\n I := FAppts.IndexOf(ID);\r\n if I > -1 then\r\n Result := TJvTFAppt(FAppts.Objects[I]);\r\nend;\r\n\r\nfunction TJvTFScheduleManager.ScheduleCount: Integer;\r\nbegin\r\n Result := FSchedules.Count;\r\nend;\r\n\r\nfunction TJvTFScheduleManager.FindSchedule(const SchedName: string;\r\n SchedDate: TDate): TJvTFSched;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := nil;\r\n I := FSchedules.IndexOf(GetScheduleID(SchedName, SchedDate));\r\n if I > -1 then\r\n Result := TJvTFSched(FSchedules.Objects[I]);\r\nend;\r\n\r\nfunction TJvTFScheduleManager.ConControlCount: Integer;\r\nbegin\r\n Result := FConControls.Count;\r\nend;\r\n\r\nfunction TJvTFScheduleManager.ConComponentCount: Integer;\r\nbegin\r\n Result := FConComponents.Count;\r\nend;\r\n\r\nfunction TJvTFScheduleManager.RequestSchedule(ApptCtrl: TJvTFControl;\r\n const SchedName: string; SchedDate: TDate): TJvTFSched;\r\nvar\r\n ApptsNeeded: Boolean;\r\nbegin\r\n RetrieveSchedule(SchedName, SchedDate, Result, ApptsNeeded);\r\n\r\n if Assigned(ApptCtrl) then\r\n begin\r\n Result.Notify(ApptCtrl, sncRequestSchedule);\r\n ApptCtrl.Notify(Result, sncRequestSchedule);\r\n end;\r\n\r\n if ApptsNeeded then\r\n if SchedLoadMode = slmOnDemand then\r\n NeedAppts(Result)\r\n else\r\n begin\r\n AddToBatch(Result);\r\n end;\r\nend;\r\n\r\nfunction TJvTFScheduleManager.RequestSchedule(ApptCtrl: TJvTFControl;\r\n const SchedName: string; SchedDate: TDate; var LoadedNow: Boolean): TJvTFSched;\r\nbegin\r\n RetrieveSchedule(SchedName, SchedDate, Result, LoadedNow);\r\n\r\n if Assigned(ApptCtrl) then\r\n begin\r\n Result.Notify(ApptCtrl, sncRequestSchedule);\r\n ApptCtrl.Notify(Result, sncRequestSchedule);\r\n end;\r\n\r\n if LoadedNow then\r\n begin\r\n if SchedLoadMode = slmOnDemand then\r\n NeedAppts(Result)\r\n else\r\n AddToBatch(Result);\r\n end;\r\nend;\r\n\r\nfunction TJvTFScheduleManager.RequestSchedule(Comp: TJvTFComponent;\r\n const SchedName: string; SchedDate: TDate): TJvTFSched;\r\nvar\r\n ApptsNeeded: Boolean;\r\nbegin\r\n RetrieveSchedule(SchedName, SchedDate, Result, ApptsNeeded);\r\n\r\n if Assigned(Comp) then\r\n begin\r\n Result.Notify(Comp, sncRequestSchedule);\r\n Comp.Notify(Result, sncRequestSchedule);\r\n end;\r\n\r\n if ApptsNeeded then\r\n begin\r\n if SchedLoadMode = slmOnDemand then\r\n NeedAppts(Result)\r\n else\r\n AddToBatch(Result);\r\n end;\r\nend;\r\n\r\nfunction TJvTFScheduleManager.RequestSchedule(Comp: TJvTFComponent;\r\n const SchedName: string; SchedDate: TDate; var LoadedNow: Boolean): TJvTFSched;\r\nbegin\r\n RetrieveSchedule(SchedName, SchedDate, Result, LoadedNow);\r\n\r\n if Assigned(Comp) then\r\n begin\r\n Result.Notify(Comp, sncRequestSchedule);\r\n Comp.Notify(Result, sncRequestSchedule);\r\n end;\r\n\r\n if LoadedNow then\r\n begin\r\n if SchedLoadMode = slmOnDemand then\r\n NeedAppts(Result)\r\n else\r\n AddToBatch(Result);\r\n end;\r\nend;\r\n\r\nprocedure TJvTFScheduleManager.ReleaseSchedule(ApptCtrl: TJvTFControl;\r\n const SchedName: string; SchedDate: TDate);\r\nvar\r\n SchedID: string;\r\n I: Integer;\r\n Schedule: TJvTFSched;\r\nbegin\r\n SchedID := GetScheduleID(SchedName, SchedDate);\r\n I := FSchedules.IndexOf(SchedID);\r\n\r\n if I > -1 then\r\n begin\r\n Schedule := TJvTFSched(FSchedules.Objects[I]);\r\n\r\n if Assigned(ApptCtrl) then\r\n begin\r\n Schedule.Notify(ApptCtrl, sncReleaseSchedule);\r\n ApptCtrl.Notify(Schedule, sncReleaseSchedule);\r\n end;\r\n\r\n if (Cache.CacheType = ctBuffer) then\r\n Flush(False);\r\n end;\r\nend;\r\n\r\nprocedure TJvTFScheduleManager.ReleaseSchedule(Comp: TJvTFComponent;\r\n const SchedName: string; SchedDate: TDate);\r\nvar\r\n SchedID: string;\r\n I: Integer;\r\n Schedule: TJvTFSched;\r\nbegin\r\n SchedID := GetScheduleID(SchedName, SchedDate);\r\n I := FSchedules.IndexOf(SchedID);\r\n\r\n if I > -1 then\r\n begin\r\n Schedule := TJvTFSched(FSchedules.Objects[I]);\r\n\r\n if Assigned(Comp) then\r\n begin\r\n Schedule.Notify(Comp, sncReleaseSchedule);\r\n Comp.Notify(Schedule, sncReleaseSchedule);\r\n end;\r\n\r\n if Cache.CacheType = ctBuffer then\r\n Flush(False);\r\n end;\r\nend;\r\n\r\nprocedure TJvTFScheduleManager.RequestAppt(const ID: string; var Appt: TJvTFAppt;\r\n var New: Boolean);\r\nvar\r\n I: Integer;\r\nbegin\r\n I := -1;\r\n if ID <> '' then\r\n I := FAppts.IndexOf(ID);\r\n\r\n if I > -1 then\r\n begin\r\n Appt := TJvTFAppt(FAppts.Objects[I]);\r\n New := False;\r\n end\r\n else\r\n begin\r\n //Appt := TJvTFAppt.Create(Self, ID);\r\n Appt := GetApptClass.Create(Self, ID);\r\n New := True;\r\n end;\r\nend;\r\n\r\nprocedure TJvTFScheduleManager.dbPostAppt(Appt: TJvTFAppt);\r\nbegin\r\n { implicit post fix\r\n If Assigned(Appt) Then\r\n If (AlwaysPost or Appt.Modified) Then\r\n Begin\r\n PostAppt(Appt);\r\n Appt.Notify(Self, sncPostAppt);\r\n End;\r\n }\r\n\r\n // implicit post fix\r\n if Assigned(Appt) and\r\n (AlwaysPost or Appt.Modified) and\r\n QueryPostAppt(Appt) then\r\n begin\r\n PostAppt(Appt);\r\n Appt.Notify(Self, sncPostAppt);\r\n end;\r\nend;\r\n\r\nprocedure TJvTFScheduleManager.dbDeleteAppt(Appt: TJvTFAppt);\r\nbegin\r\n if Assigned(Appt) then\r\n begin\r\n DeleteAppt(Appt);\r\n Appt.Notify(Self, sncDeleteAppt);\r\n end;\r\nend;\r\n\r\nprocedure TJvTFScheduleManager.dbDeleteAllAppt;\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := FAppts.Count - 1 downto 0 do\r\n RemoveAppt(TJvTFAppt(FAppts.Objects[0]));\r\nend;\r\n\r\nprocedure TJvTFScheduleManager.dbRefreshAppt(Appt: TJvTFAppt);\r\nbegin\r\n if Assigned(Appt) then\r\n begin\r\n FRefreshing := True;\r\n try\r\n Appt.Notify(Self, sncRefresh);\r\n if Assigned(FOnRefreshAppt) then\r\n FOnRefreshAppt(Self, Appt);\r\n if RefreshAutoReconcile then\r\n ReconcileRefresh(Appt);\r\n finally\r\n FRefreshing := False;\r\n\r\n // BUG - IT'S A LITTLE LATE TO BE USING THE APPT AS A REFRESH TRIGGER!!!\r\n //RefreshConnections(Appt);\r\n // Use nil as trigger to refresh everything\r\n RefreshConnections(nil);\r\n end;\r\n end;\r\n {\r\n If Assigned(Appt) Then\r\n RefreshAppt(Appt);\r\n }\r\nend;\r\n\r\nfunction TJvTFScheduleManager.dbNewAppt(const ID: string): TJvTFAppt;\r\nvar\r\n New: Boolean;\r\nbegin\r\n Result := nil;\r\n RequestAppt(ID, Result, New);\r\n if not New then\r\n raise EJvTFScheduleManagerError.CreateRes(@RsECouldNotCreateNewAppointment);\r\nend;\r\n\r\nprocedure TJvTFScheduleManager.PostAppts;\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := 0 to ApptCount - 1 do\r\n dbPostAppt(Appts[I]);\r\nend;\r\n\r\nprocedure TJvTFScheduleManager.RefreshAppts;\r\nvar\r\n I: Integer;\r\n ApptIDList: TStringList;\r\n Appt: TJvTFAppt;\r\nbegin\r\n // In a multi-user environment, appt objects may be deleted as a result\r\n // of calling dbRefreshAppt. (Component user may call Appt.Free.)\r\n // To account for this we need to build a list of appt ID's instead of\r\n // working directly from the ScheduleManager's appointment list.\r\n\r\n ApptIDList := TStringList.Create;\r\n try\r\n for I := 0 to ApptCount - 1 do\r\n begin\r\n Appt := Appts[I];\r\n ApptIDList.Add(Appt.ID);\r\n end;\r\n\r\n for I := 0 to ApptIDList.Count - 1 do\r\n begin\r\n Appt := FindAppt(ApptIDList[I]);\r\n if Assigned(Appt) then\r\n dbRefreshAppt(Appt);\r\n end;\r\n\r\n RefreshConnections(nil);\r\n finally\r\n ApptIDList.Free;\r\n end;\r\nend;\r\n\r\nprocedure TJvTFScheduleManager.RefreshConnections(Trigger: TObject);\r\nvar\r\n Sched: TJvTFSched;\r\n Appt: TJvTFAppt;\r\n I: Integer;\r\nbegin\r\n // Do not refresh if we're loading or refreshing appts\r\n if FLoadingAppts or Refreshing then\r\n Exit;\r\n\r\n if Trigger = nil then\r\n begin\r\n // refresh all schedules for all controls connected to ScheduleManager\r\n for I := 0 to ConControlCount - 1 do\r\n RequestRefresh(ConControls[I], nil);\r\n // refresh all schedules for all components connected to the ScheduleManager\r\n for I := 0 to ConComponentCount - 1 do\r\n RequestRefresh(ConComponents[I], nil);\r\n end\r\n else\r\n if Trigger is TJvTFComponent then\r\n begin\r\n // refresh all schedules for given component\r\n RequestRefresh(TJvTFComponent(Trigger), nil);\r\n end\r\n else\r\n if Trigger is TJvTFControl then\r\n begin\r\n // refresh all schedules for given control\r\n RequestRefresh(TJvTFControl(Trigger), nil);\r\n end\r\n else\r\n if Trigger is TJvTFSched then\r\n begin\r\n // refresh all appt controls connected to schedule\r\n Sched := TJvTFSched(Trigger);\r\n for I := 0 to Sched.ConControlCount - 1 do\r\n RequestRefresh(Sched.ConControls[I], Sched);\r\n // refresh all utf components connected to schedule\r\n for I := 0 to Sched.ConComponentCount - 1 do\r\n RequestRefresh(Sched.ConComponents[I], Sched);\r\n end\r\n else\r\n if Trigger is TJvTFAppt then\r\n begin\r\n // refresh all appt controls for all schedules connected to this appt\r\n Appt := TJvTFAppt(Trigger);\r\n for I := 0 to Appt.ConnectionCount - 1 do\r\n RefreshConnections(Appt.Connections[I]);\r\n end\r\n else\r\n raise EJvTFScheduleManagerError.CreateRes(@RsEInvalidTriggerForRefreshControls)\r\nend;\r\n\r\nprocedure TJvTFScheduleManager.Flush(All: Boolean); //param All defaults to False\r\nvar\r\n I: Integer;\r\n Sched: TJvTFSched;\r\n MRUList: TStringList;\r\n CacheTimeUp: Boolean;\r\nbegin\r\n if FFlushing or FDestroying then\r\n Exit;\r\n\r\n FFlushing := True;\r\n try\r\n if All then\r\n begin\r\n I := 0;\r\n while I < ScheduleCount do\r\n begin\r\n Sched := Schedules[I];\r\n if Sched.Cached and not Sched.Persistent then\r\n begin\r\n if not FlushObject(Sched) then\r\n Inc(I);\r\n end\r\n else\r\n Inc(I);\r\n end;\r\n FlushAppts;\r\n end\r\n else\r\n if Cache.CacheType = ctTimed then\r\n begin\r\n I := 0;\r\n while I < ScheduleCount do\r\n begin\r\n Sched := Schedules[I];\r\n CacheTimeUp := Windows.GetTickCount - Sched.CachedTime >=\r\n UINT(Cache.TimedDelay);\r\n if Sched.Cached and CacheTimeUp then\r\n begin\r\n if not FlushObject(Sched) then\r\n Inc(I);\r\n end\r\n else\r\n Inc(I);\r\n end;\r\n FlushAppts;\r\n end\r\n else\r\n if Cache.CacheType = ctBuffer then\r\n begin\r\n MRUList := TStringList.Create;\r\n try\r\n MRUList.Sorted := True;\r\n MRUList.Duplicates := dupAccept;\r\n for I := 0 to ScheduleCount - 1 do\r\n begin\r\n Sched := Schedules[I];\r\n if Sched.Cached then\r\n MRUList.AddObject(IntToHex(Sched.CachedTime, 8), Sched);\r\n end;\r\n for I := 0 to MRUList.Count - 1 - Cache.BufferCount do\r\n FlushObject(MRUList.Objects[I]);\r\n FlushAppts;\r\n finally\r\n MRUList.Free;\r\n end;\r\n end;\r\n\r\n finally\r\n FFlushing := False;\r\n end;\r\nend;\r\n\r\nprocedure TJvTFScheduleManager.dbRefreshAll;\r\nvar\r\n I: Integer;\r\nbegin\r\n FRefreshing := True;\r\n try\r\n for I := 0 to ApptCount - 1 do\r\n NotifyAppt(Appts[I], Self, sncRefresh);\r\n if Assigned(FOnRefreshAll) then\r\n FOnRefreshAll(Self);\r\n if RefreshAutoReconcile then\r\n ReconcileRefresh(Self);\r\n finally\r\n FRefreshing := False;\r\n RefreshConnections(nil);\r\n end;\r\nend;\r\n\r\nprocedure TJvTFScheduleManager.dbRefreshOrphans;\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := 0 to ApptCount - 1 do\r\n if Appts[I].ConnectionCount = 0 then\r\n dbRefreshAppt(Appts[I]);\r\nend;\r\n\r\nprocedure TJvTFScheduleManager.dbRefreshSched(Sched: TJvTFSched);\r\nvar\r\n I: Integer;\r\nbegin\r\n if Assigned(Sched) then\r\n begin\r\n FRefreshing := True;\r\n try\r\n for I := 0 to Sched.ApptCount - 1 do\r\n NotifyAppt(Sched.Appts[I], Self, sncRefresh);\r\n if Assigned(FOnRefreshSched) then\r\n FOnRefreshSched(Self, Sched);\r\n if RefreshAutoReconcile then\r\n ReconcileRefresh(Sched);\r\n finally\r\n FRefreshing := False;\r\n RefreshConnections(Sched);\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvTFScheduleManager.SetTFSchedLoadMode(Value: TJvTFSchedLoadMode);\r\nbegin\r\n if (Value <> FSchedLoadMode) and (Value = slmOnDemand) then\r\n // make sure we process any queued batches before changing mode\r\n ProcessBatches;\r\n\r\n FSchedLoadMode := Value;\r\nend;\r\n\r\nprocedure TJvTFScheduleManager.AddToBatch(ASched: TJvTFSched);\r\nvar\r\n SchedID: string;\r\nbegin\r\n SchedID := TJvTFScheduleManager.GetScheduleID(ASched.SchedName, ASched.SchedDate);\r\n FSchedBatch.AddObject(SchedID, ASched);\r\nend;\r\n\r\nprocedure TJvTFScheduleManager.ProcessBatches;\r\nvar\r\n I: Integer;\r\n ASched: TJvTFSched;\r\n CompName: string;\r\n CompDate: TDate;\r\n BatchName: string;\r\n BatchStartDate: TDate;\r\n BatchEndDate: TDate;\r\n\r\n procedure UpdateCompares(ASched: TJvTFSched);\r\n begin\r\n CompName := ASched.SchedName;\r\n CompDate := ASched.SchedDate;\r\n end;\r\n\r\n procedure NewBatch(ASched: TJvTFSched);\r\n begin\r\n BatchName := ASched.SchedName;\r\n BatchStartDate := ASched.SchedDate;\r\n BatchEndDate := ASched.SchedDate;\r\n end;\r\n\r\nbegin\r\n if FSchedBatch.Count = 0 then\r\n Exit;\r\n\r\n // added by Mike 1/14/01\r\n FLoadingAppts := True;\r\n try\r\n // Prime the process (reminds me of COBOL - yuck!)\r\n ASched := TJvTFSched(FSchedBatch.Objects[0]);\r\n UpdateCompares(ASched);\r\n NewBatch(ASched);\r\n\r\n for I := 1 to FSchedBatch.Count - 1 do\r\n begin\r\n ASched := TJvTFSched(FSchedBatch.Objects[I]);\r\n\r\n if (ASched.SchedName <> CompName) or\r\n (Trunc(ASched.SchedDate) - 1 <> Trunc(CompDate)) then\r\n begin\r\n // Hit new batch. Load the current batch and then\r\n // set batch info to new batch.\r\n LoadBatch(BatchName, BatchStartDate, BatchEndDate);\r\n NewBatch(ASched);\r\n end\r\n else\r\n // Still in current batch. Update the batch end date.\r\n BatchEndDate := ASched.SchedDate;\r\n\r\n UpdateCompares(ASched);\r\n end;\r\n\r\n // Load the last batch\r\n LoadBatch(BatchName, BatchStartDate, BatchEndDate);\r\n\r\n FSchedBatch.Clear;\r\n\r\n // ADD OnBatchesProcessed EVENT HERE !!\r\n if Assigned(FOnBatchesProcessed) then\r\n FOnBatchesProcessed(Self);\r\n finally\r\n // added by Mike 1/14/01\r\n FLoadingAppts := False;\r\n // added by Mike 1/14/01\r\n RefreshConnections(nil);\r\n end;\r\nend;\r\n\r\nprocedure TJvTFScheduleManager.LoadBatch(const BatchName: string; BatchStartDate,\r\n BatchEndDate: TDate);\r\nbegin\r\n if Assigned(FOnLoadBatch) then\r\n FOnLoadBatch(Self, BatchName, BatchStartDate, BatchEndDate);\r\nend;\r\n\r\nfunction TJvTFScheduleManager.QueryPostAppt(Appt: TJvTFAppt): Boolean;\r\nbegin\r\n Result := True;\r\n if Assigned(FOnPostApptQuery) then\r\n FOnPostApptQuery(Self, Appt, Result);\r\nend;\r\n\r\nfunction TJvTFScheduleManager.GetApptDisplayText(AComponent: TComponent;\r\n Appt: TJvTFAppt): string;\r\nbegin\r\n if Assigned(Appt) then\r\n Result := Appt.Description\r\n else\r\n Result := '';\r\n\r\n if Assigned(FOnGetApptDisplayText) then\r\n FOnGetApptDisplayText(Self, AComponent, Appt, Result);\r\nend;\r\n\r\nprocedure TJvTFScheduleManager.SetApptDescription(Appt: TJvTFAppt; var Value: string);\r\nbegin\r\n if Assigned(FOnSetApptDescription) then\r\n FOnSetApptDescription(Self, Appt, Value);\r\nend;\r\n\r\nprocedure TJvTFScheduleManager.GetApptDescription(Appt: TJvTFAppt; var Value: string);\r\nbegin\r\n if Assigned(FOnGetApptDescription) then\r\n FOnGetApptDescription(Self, Appt, Value);\r\nend;\r\n\r\nfunction TJvTFScheduleManager.GetApptClass: TJvTFApptClass;\r\nbegin\r\n Result := TJvTFAppt;\r\nend;\r\n\r\nfunction TJvTFScheduleManager.GetSchedClass: TJvTFSchedClass;\r\nbegin\r\n Result := TJvTFSched;\r\nend;\r\n\r\nprocedure TJvTFScheduleManager.ReconcileRefresh(Scope: TObject);\r\nvar\r\n Appt: TJvTFAppt;\r\n Sched: TJvTFSched;\r\n I: Integer;\r\nbegin\r\n if Scope is TJvTFAppt then\r\n begin\r\n Appt := TJvTFAppt(Scope);\r\n if not Appt.Refreshed then\r\n Appt.ClearSchedules;\r\n end\r\n else\r\n if Scope is TJvTFSched then\r\n begin\r\n Sched := TJvTFSched(Scope);\r\n I := 0;\r\n while I < Sched.ApptCount do\r\n begin\r\n Appt := Sched.Appts[I];\r\n if not Appt.Refreshed then\r\n Appt.ClearSchedules\r\n else\r\n Inc(I);\r\n end;\r\n end\r\n else\r\n if Scope is TJvTFScheduleManager then\r\n for I := 0 to ApptCount - 1 do\r\n ReconcileRefresh(Appts[I])\r\n else\r\n raise EJvTFScheduleManagerError.CreateRes(@RsEInvalidScopeInReconcileRefresh);\r\nend;\r\n\r\nprocedure TJvTFScheduleManager.SetRefreshAutoReconcile(Value: Boolean);\r\nbegin\r\n FRefreshAutoReconcile := Value;\r\nend;\r\n\r\n//=== { TJvTFHint } ==========================================================\r\n\r\nconstructor TJvTFHint.Create(anApptCtrl: TJvTFControl);\r\nbegin\r\n inherited Create(anApptCtrl);\r\n FApptCtrl := anApptCtrl;\r\n FTimer := TTimer.Create(Self);\r\n FShortPause := 1000;\r\n FPause := 3000;\r\n FTimer.OnTimer := TimerOnTimer;\r\n PrepTimer(True);\r\nend;\r\n\r\ndestructor TJvTFHint.Destroy;\r\nbegin\r\n FTimer.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvTFHint.SetPause(Value: Integer);\r\nbegin\r\n FPause := Value;\r\nend;\r\n\r\nprocedure TJvTFHint.SetShortPause(Value: Integer);\r\nbegin\r\n FShortPause := Value;\r\nend;\r\n\r\nprocedure TJvTFHint.TimerOnTimer(Sender: TObject);\r\nbegin\r\n FTimer.Enabled := False;\r\n\r\n if FShortTimer then\r\n DoHint(False)\r\n else\r\n begin\r\n ReleaseHandle;\r\n PrepTimer(True);\r\n end;\r\nend;\r\n\r\nprocedure TJvTFHint.PrepTimer(Short: Boolean);\r\nbegin\r\n ReleaseHandle;\r\n FShortTimer := Short;\r\n if Short then\r\n FTimer.Interval := FShortPause\r\n else\r\n FTimer.Interval := FPause;\r\nend;\r\n\r\nprocedure TJvTFHint.SetHintText(StartDate, EndDate: TDate; StartTime,\r\n EndTime: TTime; const Desc: string; ShowDatesTimes, ShowDesc: Boolean);\r\nvar\r\n ShowDates: Boolean;\r\n HintText, DFormat, TFormat: string;\r\nbegin\r\n HintText := '';\r\n if ShowDatesTimes then\r\n begin\r\n DFormat := FApptCtrl.DateFormat;\r\n TFormat := FApptCtrl.TimeFormat;\r\n ShowDates := Trunc(StartDate) <> Trunc(EndDate);\r\n\r\n if ShowDates then\r\n HintText := FormatDateTime(DFormat, StartDate) + ' ';\r\n HintText := HintText + FormatDateTime(TFormat, StartTime) + ' - ';\r\n if ShowDates then\r\n HintText := HintText + FormatDateTime(DFormat, EndDate) + ' ';\r\n HintText := HintText + FormatDateTime(TFormat, EndTime);\r\n end;\r\n\r\n if ShowDesc then\r\n begin\r\n if HintText <> '' then\r\n HintText := HintText + #13#10;\r\n HintText := HintText + Desc;\r\n end;\r\n FHintText := HintText;\r\nend;\r\n\r\nprocedure TJvTFHint.DoHint(Sustained: Boolean);\r\nvar\r\n Ref: TObject;\r\nbegin\r\n PropertyCheck;\r\n {\r\n If Assigned(FOnShowHint) Then\r\n FOnShowHint(Self, HintType, FHintRect, FHintText);\r\n }\r\n\r\n if Assigned(FOnShowHint) then\r\n begin\r\n if HintType = shtAppt then\r\n Ref := FOldAppt\r\n else\r\n if HintType = shtObj then\r\n Ref := FOldObj\r\n else\r\n Ref := nil;\r\n\r\n FOnShowHint(Self, HintType, Ref, FHintRect, FHintText);\r\n end;\r\n if not Windows.IsRectEmpty(FHintRect) and (FHintText <> '') then\r\n if Sustained then\r\n begin\r\n inherited ActivateHint(FHintRect, FHintText);\r\n end\r\n else\r\n ActivateHint(FHintRect, FHintText);\r\nend;\r\n\r\n\r\n\r\nprocedure TJvTFHint.CreateParams(var Params: TCreateParams);\r\nbegin\r\n inherited CreateParams(Params);\r\n with Params do\r\n begin\r\n WindowClass.Style := WindowClass.Style and not CS_SAVEBITS;\r\n end;\r\nend;\r\n\r\n\r\nprocedure TJvTFHint.ActivateHint(Rect: TRect; const AHint: THintString);\r\nbegin\r\n PrepTimer(False);\r\n inherited ActivateHint(Rect, AHint);\r\n // Reset the timer so we get the full interval\r\n FTimer.Enabled := False;\r\n FTimer.Enabled := True;\r\nend;\r\n\r\nprocedure TJvTFHint.ApptHint(Appt: TJvTFAppt; X, Y: Integer; ShowDatesTimes,\r\n ShowDesc, FormattedDesc: Boolean; const ExtraDesc: string = '');\r\nvar\r\n HintTopLeft: TPoint;\r\n Immediate: Boolean;\r\n ApptDesc: string;\r\nbegin\r\n if Appt <> FOldAppt then\r\n begin\r\n FHintType := shtAppt;\r\n Immediate := not FShortTimer;\r\n FHintCell := Point(-100, -100);\r\n FOldAppt := Appt;\r\n if Assigned(Appt) then\r\n begin\r\n ApptDesc := Appt.Description;\r\n if not FormattedDesc then\r\n ApptDesc := StripCRLF(ApptDesc);\r\n ApptDesc := ExtraDesc + ApptDesc;\r\n SetHintText(Appt.StartDate, Appt.EndDate, Appt.StartTime, Appt.EndTime,\r\n ApptDesc, ShowDatesTimes, ShowDesc);\r\n FHintRect := CalcHintRect(FApptCtrl.Width, FHintText, nil);\r\n HintTopLeft := FApptCtrl.ClientToScreen(Point(X, Y));\r\n FHintRect := MoveRect(FHintRect, HintTopLeft.X, HintTopLeft.Y);\r\n if Immediate then\r\n DoHint(False)\r\n else\r\n begin\r\n PrepTimer(True);\r\n FTimer.Enabled := True;\r\n end;\r\n end\r\n else\r\n begin\r\n ReleaseHandle;\r\n PrepTimer(True);\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvTFHint.StartEndHint(StartDate, EndDate: TDate; StartTime,\r\n EndTime: TTime; X, Y: Integer; ShowDates: Boolean);\r\nvar\r\n HintTopLeft: TPoint;\r\nbegin\r\n FHintType := shtStartEnd;\r\n SetHintText(StartDate, EndDate, StartTime, EndTime, '', True, False);\r\n FHintRect := CalcHintRect(FApptCtrl.Width, FHintText, nil);\r\n HintTopLeft := FApptCtrl.ClientToScreen(Point(X, Y));\r\n FHintRect := MoveRect(FHintRect, HintTopLeft.X, HintTopLeft.Y);\r\n if HandleAllocated and Showing then\r\n BoundsRect := FHintRect\r\n else\r\n DoHint(True);\r\nend;\r\n\r\nprocedure TJvTFHint.CellHint(Row, Col: Integer; const HintText: string; CellRect: TRect);\r\nvar\r\n Immediate: Boolean;\r\n DiffCell: Boolean;\r\nbegin\r\n DiffCell := (Row <> FHintCell.Y) or (Col <> FHintCell.X);\r\n if DiffCell or not FTimer.Enabled then\r\n begin\r\n FHintType := shtCell;\r\n FOldAppt := nil;\r\n ReleaseHandle;\r\n FHintCell.X := Col;\r\n FHintCell.Y := Row;\r\n Immediate := not FShortTimer;\r\n FHintText := HintText;\r\n //If (FHintText <> '') and DiffCell Then\r\n if FHintText <> '' then\r\n begin\r\n CellRect.TopLeft := FApptCtrl.ClientToScreen(CellRect.TopLeft);\r\n CellRect.BottomRight := FApptCtrl.ClientToScreen(CellRect.BottomRight);\r\n FHintRect := CalcHintRect(FApptCtrl.Width, FHintText, nil);\r\n FHintRect := CenterRect(CellRect, FHintRect);\r\n if Immediate then\r\n DoHint(False)\r\n else\r\n begin\r\n PrepTimer(True);\r\n FTimer.Enabled := True;\r\n end;\r\n end\r\n else\r\n begin\r\n ReleaseHandle;\r\n PrepTimer(True);\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvTFHint.ReleaseHandle;\r\nbegin\r\n FTimer.Enabled := False;\r\n DestroyHandle;\r\nend;\r\n\r\nprocedure TJvTFHint.PropertyCheck;\r\nbegin\r\n if Assigned(RefProps) then\r\n begin\r\n if RefProps.HintColor = clDefault then\r\n Color := Application.HintColor\r\n else\r\n Color := RefProps.HintColor;\r\n\r\n if RefProps.HintHidePause = -1 then\r\n Pause := Application.HintHidePause\r\n else\r\n Pause := RefProps.HintHidePause;\r\n\r\n if RefProps.HintPause = -1 then\r\n ShortPause := Application.HintPause\r\n else\r\n ShortPause := RefProps.HintPause;\r\n end;\r\nend;\r\n\r\nprocedure TJvTFHint.MultiLineObjHint(Obj: TObject; X, Y: Integer;\r\n Hints: TStrings);\r\nvar\r\n Immediate: Boolean;\r\n HintTopLeft: TPoint;\r\nbegin\r\n if Obj <> FOldObj then\r\n begin\r\n FOldAppt := nil;\r\n FHintType := shtObj;\r\n Immediate := not FShortTimer;\r\n FHintCell := Point(-100, -100);\r\n FOldObj := Obj;\r\n if Assigned(Obj) and (Hints.Count > 0) then\r\n begin\r\n FHintText := Hints.Text;\r\n FHintRect := CalcHintRect(FApptCtrl.Width, FHintText, nil);\r\n HintTopLeft := FApptCtrl.ClientToScreen(Point(X + 8, Y + 16));\r\n FHintRect := MoveRect(FHintRect, HintTopLeft.X, HintTopLeft.Y);\r\n\r\n if Immediate then\r\n DoHint(False)\r\n else\r\n begin\r\n PrepTimer(True);\r\n FTimer.Enabled := True;\r\n end;\r\n end\r\n else\r\n begin\r\n ReleaseHandle;\r\n PrepTimer(True);\r\n end;\r\n end;\r\nend;\r\n\r\n//=== { TJvTFControl } =======================================================\r\n\r\nconstructor TJvTFControl.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n\r\n FSchedules := TStringList.Create;\r\n FTimeFormat := 't'; // global short time format\r\n FDateFormat := 'ddddd'; // global short date format\r\nend;\r\n\r\ndestructor TJvTFControl.Destroy;\r\nbegin\r\n ScheduleManager := nil;\r\n FSchedules.Free;\r\n\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvTFControl.SetManager(Value: TJvTFScheduleManager);\r\nbegin\r\n if Value <> FScheduleManager then\r\n begin\r\n if Assigned(FScheduleManager) then\r\n FScheduleManager.Notify(Self, sncDisconnectControl);\r\n FScheduleManager := nil;\r\n\r\n if Assigned(Value) then\r\n Value.Notify(Self, sncConnectControl);\r\n FScheduleManager := Value;\r\n end;\r\nend;\r\n\r\nfunction TJvTFControl.GetSchedule(Index: Integer): TJvTFSched;\r\nbegin\r\n Result := TJvTFSched(FSchedules.Objects[Index]);\r\nend;\r\n\r\nprocedure TJvTFControl.SetDateFormat(const Value: string);\r\nbegin\r\n if FDateFormat <> Value then\r\n begin\r\n FDateFormat := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvTFControl.SetTimeFormat(const Value: string);\r\nbegin\r\n if FTimeFormat <> Value then\r\n begin\r\n FTimeFormat := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvTFControl.Notify(Sender: TObject;\r\n Code: TJvTFServNotifyCode);\r\nbegin\r\n case Code of\r\n sncRequestSchedule:\r\n ReqSchedNotification(TJvTFSched(Sender));\r\n sncReleaseSchedule:\r\n RelSchedNotification(TJvTFSched(Sender));\r\n sncRefresh:\r\n RefreshControl;\r\n sncDestroyAppt:\r\n DestroyApptNotification(TJvTFAppt(Sender));\r\n sncDestroySchedule:\r\n DestroySchedNotification(TJvTFSched(Sender));\r\n end;\r\nend;\r\n\r\nprocedure TJvTFControl.ReqSchedNotification(Schedule: TJvTFSched);\r\nvar\r\n SchedID: string;\r\nbegin\r\n SchedID := TJvTFScheduleManager.GetScheduleID(Schedule.SchedName, Schedule.SchedDate);\r\n if FSchedules.IndexOf(SchedID) = -1 then\r\n FSchedules.AddObject(SchedID, Schedule);\r\nend;\r\n\r\nprocedure TJvTFControl.RelSchedNotification(Schedule: TJvTFSched);\r\nvar\r\n I: Integer;\r\nbegin\r\n I := FSchedules.IndexOfObject(Schedule);\r\n if I > -1 then\r\n FSchedules.Delete(I);\r\nend;\r\n\r\nprocedure TJvTFControl.NotifyManager(Serv: TJvTFScheduleManager;\r\n Sender: TObject; Code: TJvTFServNotifyCode);\r\nbegin\r\n if Assigned(Serv) then\r\n Serv.Notify(Sender, Code)\r\n else\r\n raise EJvTFScheduleManagerError.CreateRes(@RsEScheduleManagerNotificationFailedSc);\r\nend;\r\n\r\nprocedure TJvTFControl.CNRequestRefresh(var Msg: TCNRequestRefresh);\r\nbegin\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvTFControl.RefreshControl;\r\nbegin\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvTFControl.DestroyApptNotification(anAppt: TJvTFAppt);\r\nbegin\r\n // do nothing, leave implementation to successors\r\nend;\r\n\r\nprocedure TJvTFControl.DestroySchedNotification(ASched: TJvTFSched);\r\nbegin\r\n // do nothing, leave implementation to successors\r\nend;\r\n\r\nprocedure TJvTFControl.DoStartDrag(var DragObject: TDragObject);\r\nbegin\r\n inherited DoStartDrag(DragObject);\r\n\r\n FDragInfo := TJvTFDragInfo.Create;\r\n with FDragInfo do\r\n begin\r\n ApptCtrl := Self;\r\n Shift := Self.FShift;\r\n end;\r\n\r\n {\r\n Originally, a specific drag object was created and given to the DragObject\r\n param. This worked fine. Because of differences in the VCL DragObject\r\n hierarachy between D3 and D4, the decision was made to move away from\r\n using a drag object.\r\n\r\n FDragAppt := TDragAppt.Create(Self);\r\n With FDragAppt do\r\n Begin\r\n ApptCtrl := Self;\r\n Schedule := SelSchedule;\r\n Appt := SelAppt;\r\n Shift := FDragShift;\r\n End;\r\n DragObject := FDragAppt;\r\n }\r\nend;\r\n\r\nprocedure TJvTFControl.DoEndDrag(Target: TObject; X, Y: Integer);\r\nbegin\r\n inherited DoEndDrag(Target, X, Y);\r\n\r\n FDragInfo.Free;\r\n FDragInfo := nil;\r\nend;\r\n\r\nprocedure TJvTFControl.MouseDown(Button: TMouseButton; Shift: TShiftState;\r\n X, Y: Integer);\r\nbegin\r\n inherited MouseDown(Button, Shift, X, Y);\r\n FShift := Shift;\r\nend;\r\n\r\nfunction TJvTFControl.ScheduleCount: Integer;\r\nbegin\r\n Result := FSchedules.Count;\r\nend;\r\n\r\nfunction TJvTFControl.FindSchedule(const SchedName: string;\r\n SchedDate: TDate): TJvTFSched;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := nil;\r\n\r\n I := FSchedules.IndexOf(TJvTFScheduleManager.GetScheduleID(SchedName, SchedDate));\r\n if I > -1 then\r\n Result := TJvTFSched(FSchedules.Objects[I]);\r\nend;\r\n\r\nfunction TJvTFControl.RetrieveSchedule(const SchedName: string;\r\n SchedDate: TDate): TJvTFSched;\r\nbegin\r\n Result := FindSchedule(SchedName, SchedDate);\r\n\r\n if not Assigned(Result) then\r\n if Assigned(ScheduleManager) then\r\n Result := ScheduleManager.RequestSchedule(Self, SchedName, SchedDate)\r\n else\r\n raise EJvTFScheduleManagerError.CreateRes(@RsECouldNotRetrieveSchedule);\r\nend;\r\n\r\nprocedure TJvTFControl.ReleaseSchedule(const SchedName: string;\r\n SchedDate: TDate);\r\nvar\r\n SchedID: string;\r\nbegin\r\n SchedID := TJvTFScheduleManager.GetScheduleID(SchedName, SchedDate);\r\n if FSchedules.IndexOf(SchedID) > -1 then\r\n if Assigned(ScheduleManager) then\r\n ScheduleManager.ReleaseSchedule(Self, SchedName, SchedDate)\r\n else\r\n raise EJvTFScheduleManagerError.CreateRes(@RsECouldNotReleaseSchedule);\r\n\r\nend;\r\n\r\nprocedure TJvTFControl.ReleaseSchedules;\r\nbegin\r\n while ScheduleCount > 0 do\r\n ReleaseSchedule(Schedules[0].SchedName, Schedules[0].SchedDate);\r\nend;\r\n\r\nprocedure TJvTFControl.Notification(AComponent: TComponent;\r\n Operation: TOperation);\r\nbegin\r\n inherited Notification(AComponent, Operation);\r\n // If (AComponent = Navigator) and (Operation = opRemove) Then\r\n // Navigator := nil;\r\nend;\r\n\r\n//procedure TJvTFControl.SetNavigator(Value: TJvTFNavigator);\r\n//begin\r\n// If Value <> FNavigator Then\r\n// Begin\r\n// If Assigned(FNavigator) Then\r\n// FNavigator.UnregisterControl(Self);\r\n// FNavigator := nil;\r\n//\r\n// If Assigned(Value) Then\r\n// Value.RegisterControl(Self);\r\n// FNavigator := Value;\r\n// End;\r\n//end;\r\n\r\nprocedure TJvTFControl.Navigate(aControl: TJvTFControl;\r\n SchedNames: TStringList; Dates: TJvTFDateList);\r\nbegin\r\n // If Assigned(FOnNavigate) Then\r\n // FOnNavigate(Self, aControl, SchedNames, Dates);\r\nend;\r\n\r\nprocedure TJvTFControl.ProcessBatches;\r\nbegin\r\n if Assigned(ScheduleManager) and (ScheduleManager.SchedLoadMode = slmBatch) then\r\n ScheduleManager.ProcessBatches;\r\nend;\r\n\r\n//=== { TJvTFComponent } =====================================================\r\n\r\nconstructor TJvTFComponent.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n\r\n FSchedules := TStringList.Create;\r\n FTimeFormat := 't'; // global short time format\r\n FDateFormat := 'ddddd'; // global short date format\r\nend;\r\n\r\ndestructor TJvTFComponent.Destroy;\r\nbegin\r\n ScheduleManager := nil;\r\n FSchedules.Free;\r\n\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvTFComponent.DestroyApptNotification(anAppt: TJvTFAppt);\r\nbegin\r\n // do nothing, leave implementation to descendants\r\nend;\r\n\r\nprocedure TJvTFComponent.DestroySchedNotification(ASched: TJvTFSched);\r\nbegin\r\n // do nothing, leave implementation to descendants\r\nend;\r\n\r\nfunction TJvTFComponent.FindSchedule(const SchedName: string;\r\n SchedDate: TDate): TJvTFSched;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := nil;\r\n\r\n I := FSchedules.IndexOf(TJvTFScheduleManager.GetScheduleID(SchedName, SchedDate));\r\n if I > -1 then\r\n Result := TJvTFSched(FSchedules.Objects[I]);\r\nend;\r\n\r\nfunction TJvTFComponent.GetSchedule(Index: Integer): TJvTFSched;\r\nbegin\r\n Result := TJvTFSched(FSchedules.Objects[Index]);\r\nend;\r\n\r\nprocedure TJvTFComponent.Notify(Sender: TObject; Code: TJvTFServNotifyCode);\r\nbegin\r\n case Code of\r\n sncRequestSchedule:\r\n ReqSchedNotification(TJvTFSched(Sender));\r\n sncReleaseSchedule:\r\n RelSchedNotification(TJvTFSched(Sender));\r\n sncRefresh:\r\n RefreshComponent;\r\n sncDestroyAppt:\r\n DestroyApptNotification(TJvTFAppt(Sender));\r\n sncDestroySchedule:\r\n DestroySchedNotification(TJvTFSched(Sender));\r\n end;\r\nend;\r\n\r\nprocedure TJvTFComponent.NotifyManager(Serv: TJvTFScheduleManager; Sender: TObject;\r\n Code: TJvTFServNotifyCode);\r\nbegin\r\n if Assigned(Serv) then\r\n Serv.Notify(Sender, Code)\r\n else\r\n raise EJvTFScheduleManagerError.CreateRes(@RsEScheduleManagerNotificationFailedSc);\r\nend;\r\n\r\nprocedure TJvTFComponent.ProcessBatches;\r\nbegin\r\n if Assigned(ScheduleManager) and (ScheduleManager.SchedLoadMode = slmBatch) then\r\n ScheduleManager.ProcessBatches;\r\nend;\r\n\r\nprocedure TJvTFComponent.RefreshComponent;\r\nbegin\r\n // do nothing, leave implementation to descendants\r\nend;\r\n\r\nprocedure TJvTFComponent.ReleaseSchedule(const SchedName: string;\r\n SchedDate: TDate);\r\nvar\r\n SchedID: string;\r\nbegin\r\n SchedID := TJvTFScheduleManager.GetScheduleID(SchedName, SchedDate);\r\n if FSchedules.IndexOf(SchedID) > -1 then\r\n if Assigned(ScheduleManager) then\r\n ScheduleManager.ReleaseSchedule(Self, SchedName, SchedDate)\r\n else\r\n raise EJvTFScheduleManagerError.CreateRes(@RsECouldNotReleaseSchedule);\r\nend;\r\n\r\nprocedure TJvTFComponent.ReleaseSchedules;\r\nbegin\r\n while ScheduleCount > 0 do\r\n ReleaseSchedule(Schedules[0].SchedName, Schedules[0].SchedDate);\r\nend;\r\n\r\nprocedure TJvTFComponent.RelSchedNotification(Schedule: TJvTFSched);\r\nvar\r\n I: Integer;\r\nbegin\r\n I := FSchedules.IndexOfObject(Schedule);\r\n if I > -1 then\r\n FSchedules.Delete(I);\r\nend;\r\n\r\nprocedure TJvTFComponent.ReqSchedNotification(Schedule: TJvTFSched);\r\nvar\r\n SchedID: string;\r\nbegin\r\n SchedID := TJvTFScheduleManager.GetScheduleID(Schedule.SchedName, Schedule.SchedDate);\r\n if FSchedules.IndexOf(SchedID) = -1 then\r\n FSchedules.AddObject(SchedID, Schedule);\r\nend;\r\n\r\nfunction TJvTFComponent.RetrieveSchedule(const SchedName: string;\r\n SchedDate: TDate): TJvTFSched;\r\nbegin\r\n Result := FindSchedule(SchedName, SchedDate);\r\n\r\n if not Assigned(Result) then\r\n if Assigned(ScheduleManager) then\r\n Result := ScheduleManager.RequestSchedule(Self, SchedName, SchedDate)\r\n else\r\n raise EJvTFScheduleManagerError.CreateRes(@RsECouldNotRetrieveSchedule);\r\nend;\r\n\r\nfunction TJvTFComponent.ScheduleCount: Integer;\r\nbegin\r\n Result := FSchedules.Count;\r\nend;\r\n\r\nprocedure TJvTFComponent.SetDateFormat(const Value: string);\r\nbegin\r\n FDateFormat := Value;\r\nend;\r\n\r\nprocedure TJvTFComponent.SetManager(Value: TJvTFScheduleManager);\r\nbegin\r\n if Value <> FScheduleManager then\r\n begin\r\n if Assigned(FScheduleManager) then\r\n FScheduleManager.Notify(Self, sncDisconnectComponent);\r\n FScheduleManager := nil;\r\n\r\n if Assigned(Value) then\r\n Value.Notify(Self, sncConnectComponent);\r\n FScheduleManager := Value;\r\n end;\r\nend;\r\n\r\nprocedure TJvTFComponent.SetTimeFormat(const Value: string);\r\nbegin\r\n FTimeFormat := Value;\r\nend;\r\n\r\nprocedure TJvTFComponent.UpdateDesigner;\r\nvar\r\n ParentForm: TCustomForm;\r\nbegin\r\n if (csDesigning in ComponentState) and not (csUpdating in ComponentState) then\r\n begin\r\n try\r\n ParentForm := TCustomForm(Owner);\r\n if Assigned(ParentForm) and Assigned(ParentForm.Designer) then\r\n ParentForm.Designer.Modified;\r\n except\r\n // handle the exception by doing nothing\r\n end;\r\n end;\r\nend;\r\n\r\n//=== { TJvTFPrinter } =======================================================\r\n\r\nconstructor TJvTFPrinter.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n CreateLayout;\r\n FMeasure := pmInches;\r\n FPages := TStringList.Create;\r\n FBodies := TStringList.Create;\r\n InitializeMargins;\r\nend;\r\n\r\ndestructor TJvTFPrinter.Destroy;\r\nbegin\r\n FreeDoc;\r\n FBodies.Free;\r\n FPages.Free;\r\n\r\n FPageLayout.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvTFPrinter.AbortPrint;\r\nbegin\r\n if Printer.Printing then\r\n Printer.Abort\r\n else\r\n FAborted := True;\r\nend;\r\n\r\nfunction TJvTFPrinter.ConvertMeasure(Value: Integer; FromMeasure,\r\n ToMeasure: TJvTFPrinterMeasure; Horizontal: Boolean): Integer;\r\nconst\r\n MMFactor = 2.54;\r\nvar\r\n PPI: Integer;\r\nbegin\r\n if Horizontal then\r\n PPI := Windows.GetDeviceCaps(Printer.Handle, LOGPIXELSX)\r\n else\r\n PPI := Windows.GetDeviceCaps(Printer.Handle, LOGPIXELSY);\r\n if (FromMeasure = pmPixels) and (ToMeasure = pmInches) then\r\n Result := round(Value / PPI * 100)\r\n else\r\n if (FromMeasure = pmPixels) and (ToMeasure = pmMM) then\r\n Result := round(Value / PPI * 100 * MMFactor)\r\n else\r\n if (FromMeasure = pmInches) and (ToMeasure = pmPixels) then\r\n Result := round(Value / 100 * PPI)\r\n else\r\n if (FromMeasure = pmInches) and (ToMeasure = pmMM) then\r\n Result := round(Value * MMFactor)\r\n else\r\n if (FromMeasure = pmMM) and (ToMeasure = pmPixels) then\r\n Result := round(Value / MMFactor / 100 * PPI)\r\n else\r\n if (FromMeasure = pmMM) and (ToMeasure = pmInches) then\r\n Result := round(Value / MMFactor)\r\n else\r\n Result := Value;\r\nend;\r\n\r\nprocedure TJvTFPrinter.CreateDoc;\r\nbegin\r\n if State = spsNoDoc then\r\n begin\r\n FState := spsCreating;\r\n FAborted := False;\r\n\r\n FDocDateTime := Now;\r\n if DirectPrint then\r\n Printer.BeginDoc;\r\n end\r\n else\r\n raise EJvTFPrinterError.CreateRes(@RsECouldNotCreateADocumentBecauseA);\r\nend;\r\n\r\nprocedure TJvTFPrinter.CreateLayout;\r\nbegin\r\n FPageLayout := TJvTFPrinterPageLayout.Create(Self);\r\nend;\r\n\r\nprocedure TJvTFPrinter.DrawBody(aCanvas: TCanvas; ARect: TRect;\r\n PageNum: Integer);\r\nbegin\r\n if Assigned(FOnDrawBody) then\r\n FOnDrawBody(Self, aCanvas, ARect, PageNum);\r\nend;\r\n\r\nprocedure TJvTFPrinter.DrawFooter(aCanvas: TCanvas; ARect: TRect;\r\n PageNum: Integer);\r\nbegin\r\n if Assigned(FOnDrawFooter) then\r\n FOnDrawFooter(Self, aCanvas, ARect, PageNum);\r\nend;\r\n\r\nprocedure TJvTFPrinter.DrawHeader(aCanvas: TCanvas; ARect: TRect;\r\n PageNum: Integer);\r\nbegin\r\n if Assigned(FOnDrawHeader) then\r\n FOnDrawHeader(Self, aCanvas, ARect, PageNum);\r\nend;\r\n\r\nprocedure TJvTFPrinter.FinishDoc;\r\nvar\r\n I: Integer;\r\n aCanvas: TMetafileCanvas;\r\n HeaderRect, FooterRect: TRect;\r\nbegin\r\n if Aborted then\r\n Exit;\r\n\r\n if State <> spsCreating then\r\n raise EJvTFPrinterError.CreateRes(@RsECouldNotFinishDocumentBecauseNo);\r\n\r\n FPageCount := FBodies.Count;\r\n FState := spsAssembling;\r\n try\r\n if Assigned(FOnAssembleProgress) then\r\n FOnAssembleProgress(Self, 0, FBodies.Count);\r\n\r\n if DirectPrint then\r\n Printer.EndDoc\r\n else\r\n begin\r\n GetHeaderFooterRects(HeaderRect, FooterRect);\r\n I := 0;\r\n while (I < FBodies.Count) and not Aborted do\r\n begin\r\n aCanvas := TMetafileCanvas(FBodies.Objects[I]);\r\n\r\n try\r\n DrawHeader(aCanvas, HeaderRect, I + 1);\r\n DrawFooter(aCanvas, FooterRect, I + 1);\r\n finally\r\n aCanvas.Free;\r\n FBodies.Objects[I] := nil;\r\n end;\r\n\r\n if Assigned(FOnAssembleProgress) then\r\n FOnAssembleProgress(Self, I + 1, FBodies.Count);\r\n\r\n Inc(I);\r\n Application.ProcessMessages;\r\n end;\r\n end;\r\n\r\n FBodies.Clear;\r\n finally\r\n FState := spsFinished;\r\n end;\r\nend;\r\n\r\nprocedure TJvTFPrinter.FreeDoc;\r\nbegin\r\n while FBodies.Count > 0 do\r\n begin\r\n FBodies.Objects[0].Free;\r\n FBodies.Delete(0);\r\n end;\r\n\r\n while FPages.Count > 0 do\r\n begin\r\n FPages.Objects[0].Free;\r\n FPages.Delete(0);\r\n end;\r\n\r\n FState := spsNoDoc;\r\nend;\r\n\r\nfunction TJvTFPrinter.GetBodyHeight: Integer; // always in pixels\r\nvar\r\n PhysHeight, TopMarginPels, BottomMarginPels, HeaderPels, FooterPels: Integer;\r\nbegin\r\n PhysHeight := Windows.GetDeviceCaps(Printer.Handle, PHYSICALHEIGHT);\r\n TopMarginPels := ConvertMeasure(PageLayout.MarginTop, Measure, pmPixels, False);\r\n BottomMarginPels := ConvertMeasure(PageLayout.MarginBottom, Measure, pmPixels, False);\r\n HeaderPels := ConvertMeasure(PageLayout.HeaderHeight, Measure, pmPixels, False);\r\n FooterPels := ConvertMeasure(PageLayout.FooterHeight, Measure, pmPixels, False);\r\n\r\n Result := PhysHeight - TopMarginPels - BottomMarginPels -\r\n HeaderPels - FooterPels;\r\nend;\r\n\r\nfunction TJvTFPrinter.GetBodyLeft: Integer; // always in pixels\r\nbegin\r\n Result := GetMarginOffset(1);\r\nend;\r\n\r\nfunction TJvTFPrinter.GetBodyTop: Integer; // always in pixels\r\nbegin\r\n Result := GetMarginOffset(2) +\r\n ConvertMeasure(PageLayout.HeaderHeight, Measure, pmPixels, False) + 1;\r\nend;\r\n\r\nfunction TJvTFPrinter.GetBodyWidth: Integer; // always in pixels\r\nvar\r\n PhysWidth, LeftMarginPels, RightMarginPels: Integer;\r\nbegin\r\n PhysWidth := Windows.GetDeviceCaps(Printer.Handle, PHYSICALWIDTH);\r\n LeftMarginPels := ConvertMeasure(PageLayout.MarginLeft, Measure, pmPixels, True);\r\n RightMarginPels := ConvertMeasure(PageLayout.MarginRight, Measure, pmPixels, True);\r\n\r\n Result := PhysWidth - LeftMarginPels - RightMarginPels;\r\nend;\r\n\r\nfunction TJvTFPrinter.GetDocDateTime: TDateTime;\r\nbegin\r\n if State = spsNoDoc then\r\n raise EJvTFPrinterError.CreateRes(@RsEDocumentDoesNotExist);\r\n\r\n Result := FDocDateTime;\r\nend;\r\n\r\nprocedure TJvTFPrinter.GetHeaderFooterRects(var HeaderRect, FooterRect: TRect);\r\nbegin\r\n HeaderRect.Left := FMarginOffsets.Left;\r\n HeaderRect.Top := FMarginOffsets.Top;\r\n HeaderRect.Right := HeaderRect.Left + BodyWidth;\r\n HeaderRect.Bottom := HeaderRect.Top + ConvertMeasure(PageLayout.HeaderHeight,\r\n Measure, pmPixels, False);\r\n\r\n FooterRect.Left := HeaderRect.Left;\r\n FooterRect.Right := HeaderRect.Right;\r\n FooterRect.Top := BodyTop + BodyHeight;\r\n FooterRect.Bottom := FooterRect.Top + ConvertMeasure(PageLayout.FooterHeight,\r\n Measure, pmPixels, False);\r\nend;\r\n\r\nfunction TJvTFPrinter.GetMarginOffset(Index: Integer): Integer;\r\nbegin\r\n case Index of\r\n 1:\r\n Result := FMarginOffsets.Left;\r\n 2:\r\n Result := FMarginOffsets.Top;\r\n 3:\r\n Result := FMarginOffsets.Right;\r\n else\r\n Result := FMarginOffsets.Bottom;\r\n end;\r\nend;\r\n\r\n\r\n\r\nfunction TJvTFPrinter.GetPage(Index: Integer): TMetafile;\r\nbegin\r\n if DirectPrint then\r\n raise EJvTFPrinterError.CreateRes(@RsEDocumentPagesCannotBeAccessedIf);\r\n\r\n if State <> spsFinished then\r\n raise EJvTFPrinterError.CreateRes(@RsEDocumentPagesAreInaccessibleUntil);\r\n Result := TMetafile(FPages.Objects[Index]);\r\nend;\r\n\r\n\r\nfunction TJvTFPrinter.GetPageCount: Integer;\r\nbegin\r\n case State of\r\n spsNoDoc:\r\n raise EJvTFPrinterError.CreateRes(@RsECouldNotRetrievePageCount);\r\n spsCreating:\r\n Result := FBodies.Count;\r\n spsAssembling:\r\n Result := FPageCount;\r\n spsFinished:\r\n Result := FPages.Count;\r\n else\r\n Result := -1;\r\n end;\r\nend;\r\n\r\nfunction TJvTFPrinter.GetUnprintable: TJvTFMargins;\r\nvar\r\n LeftMarg, TopMarg, WidthPaper, HeightPaper, WidthPrintable, HeightPrintable: Integer;\r\nbegin\r\n LeftMarg := Windows.GetDeviceCaps(Printer.Handle, PHYSICALOFFSETX);\r\n TopMarg := Windows.GetDeviceCaps(Printer.Handle, PHYSICALOFFSETY);\r\n WidthPaper := Windows.GetDeviceCaps(Printer.Handle, PHYSICALWIDTH);\r\n HeightPaper := Windows.GetDeviceCaps(Printer.Handle, PHYSICALHEIGHT);\r\n WidthPrintable := Printer.PageWidth;\r\n HeightPrintable := Printer.PageHeight;\r\n\r\n with Result do\r\n begin\r\n Left := LeftMarg;\r\n Top := TopMarg;\r\n Right := WidthPaper - WidthPrintable - LeftMarg;\r\n Bottom := HeightPaper - HeightPrintable - TopMarg;\r\n end;\r\nend;\r\n\r\nprocedure TJvTFPrinter.InitializeMargins;\r\nvar\r\n I, Unprintable, NewMargin: Integer;\r\n Horz: Boolean;\r\nbegin\r\n for I := 1 to 4 do\r\n begin\r\n SetMarginOffset(I, 0);\r\n\r\n case I of\r\n 1:\r\n Unprintable := GetUnprintable.Left;\r\n 2:\r\n Unprintable := GetUnprintable.Top;\r\n 3:\r\n Unprintable := GetUnprintable.Right;\r\n else\r\n Unprintable := GetUnprintable.Bottom;\r\n end;\r\n\r\n Horz := (I = 1) or (I = 3);\r\n NewMargin := ConvertMeasure(Unprintable, pmPixels, Measure, Horz);\r\n\r\n case I of\r\n 1:\r\n PageLayout.FMargins.Left := NewMargin;\r\n 2:\r\n PageLayout.FMargins.Top := NewMargin;\r\n 3:\r\n PageLayout.FMargins.Right := NewMargin;\r\n else\r\n PageLayout.FMargins.Bottom := NewMargin;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvTFPrinter.MarginError;\r\nbegin\r\n if Assigned(FOnMarginError) then\r\n FOnMarginError(Self);\r\nend;\r\n\r\nprocedure TJvTFPrinter.NewDoc;\r\nbegin\r\n FreeDoc;\r\n CreateDoc;\r\nend;\r\n\r\nprocedure TJvTFPrinter.NewPage;\r\nvar\r\n aMetafile: TMetafile;\r\n aCanvas: TCanvas;\r\n HeaderRect, FooterRect: TRect;\r\nbegin\r\n if Aborted then\r\n Exit;\r\n\r\n if DirectPrint then\r\n begin\r\n if PageCount > 0 then\r\n Printer.NewPage;\r\n aCanvas := Printer.Canvas;\r\n FPages.Add('');\r\n end\r\n else\r\n begin\r\n // Create a TMetafile for the page\r\n aMetafile := TMetafile.Create;\r\n FPages.AddObject('', aMetafile);\r\n // Create a TMetafileCanvas as a canvas for the page.\r\n // Store the canvas in FBodies so we can retrieve it later to draw\r\n // the header and footer.\r\n aCanvas := TMetafileCanvas.Create(aMetafile, Printer.Handle);\r\n end;\r\n FBodies.AddObject('', aCanvas);\r\n aCanvas.Font.PixelsPerInch := Windows.GetDeviceCaps(Printer.Handle,\r\n LOGPIXELSX);\r\n\r\n Windows.SetViewPortOrgEx(aCanvas.Handle, BodyLeft, BodyTop, nil);\r\n DrawBody(aCanvas, Rect(BodyLeft, BodyTop, BodyWidth - BodyLeft,\r\n BodyHeight - BodyTop), FPages.Count);\r\n Windows.SetViewPortOrgEx(aCanvas.Handle, 0, 0, nil);\r\n if DirectPrint then\r\n begin\r\n GetHeaderFooterRects(HeaderRect, FooterRect);\r\n DrawHeader(aCanvas, HeaderRect, PageCount);\r\n DrawFooter(aCanvas, FooterRect, PageCount);\r\n end;\r\nend;\r\n\r\nprocedure TJvTFPrinter.Print;\r\nvar\r\n I: Integer;\r\nbegin\r\n if Aborted or DirectPrint then\r\n Exit;\r\n\r\n if State <> spsFinished then\r\n raise EJvTFPrinterError.CreateRes(@RsEOnlyAFinishedDocumentCanBePrinted);\r\n if PageCount = 0 then\r\n raise EJvTFPrinterError.CreateRes(@RsEThereAreNoPagesToPrint);\r\n\r\n if Assigned(FOnPrintProgress) then\r\n FOnPrintProgress(Self, 0, PageCount);\r\n Application.ProcessMessages;\r\n\r\n Printer.Title := Title;\r\n Printer.BeginDoc;\r\n if not Printer.Aborted then\r\n Printer.Canvas.Draw(0, 0, Pages[0]);\r\n\r\n if Assigned(FOnPrintProgress) then\r\n FOnPrintProgress(Self, 1, PageCount);\r\n Application.ProcessMessages;\r\n\r\n I := 1;\r\n while (I < PageCount) and not Printer.Aborted do\r\n begin\r\n if not Printer.Aborted then\r\n Printer.NewPage;\r\n if not Printer.Aborted then\r\n Printer.Canvas.Draw(0, 0, Pages[I]);\r\n Inc(I);\r\n if Assigned(FOnPrintProgress) then\r\n FOnPrintProgress(Self, I, PageCount);\r\n Application.ProcessMessages;\r\n end;\r\n\r\n if not Printer.Aborted then\r\n Printer.EndDoc;\r\nend;\r\n\r\nfunction TJvTFPrinter.PrinterToScreen(Value: Integer;\r\n Horizontal: Boolean): Integer;\r\nvar\r\n ScreenPPI, PrinterPPI: Integer;\r\nbegin\r\n ScreenPPI := Screen.PixelsPerInch;\r\n if Horizontal then\r\n PrinterPPI := Windows.GetDeviceCaps(Printer.Handle, LOGPIXELSX)\r\n else\r\n PrinterPPI := Windows.GetDeviceCaps(Printer.Handle, LOGPIXELSY);\r\n Result := Trunc(ScreenPPI / PrinterPPI * Value);\r\nend;\r\n\r\nprocedure TJvTFPrinter.SaveDocToFiles(BaseFileName: TFileName);\r\nvar\r\n I: Integer;\r\nbegin\r\n if State <> spsFinished then\r\n raise EJvTFPrinterError.CreateRes(@RsEDocumentMustBeFinishedToSaveToFile);\r\n\r\n for I := 0 to PageCount - 1 do\r\n Pages[I].SaveToFile(BaseFileName + '_' + IntToStr(I + 1) + '.emf');\r\nend;\r\n\r\nfunction TJvTFPrinter.ScreenToPrinter(Value: Integer;\r\n Horizontal: Boolean): Integer;\r\nvar\r\n ScreenPPI, PrinterPPI: Integer;\r\nbegin\r\n ScreenPPI := Screen.PixelsPerInch;\r\n if Horizontal then\r\n PrinterPPI := Windows.GetDeviceCaps(Printer.Handle, LOGPIXELSX)\r\n else\r\n PrinterPPI := Windows.GetDeviceCaps(Printer.Handle, LOGPIXELSY);\r\n Result := Trunc(PrinterPPI / ScreenPPI * Value);\r\nend;\r\n\r\nprocedure TJvTFPrinter.SetDirectPrint(Value: Boolean);\r\nbegin\r\n SetPropertyCheck;\r\n FDirectPrint := Value;\r\nend;\r\n\r\nprocedure TJvTFPrinter.SetMarginOffset(Index, Value: Integer);\r\nbegin\r\n // Allow negative value...\r\n // SetMargin will catch that case and throw exception\r\n case Index of\r\n 1:\r\n FMarginOffsets.Left := Value;\r\n 2:\r\n FMarginOffsets.Top := Value;\r\n 3:\r\n FMarginOffsets.Right := Value;\r\n else\r\n FMarginOffsets.Bottom := Value;\r\n end;\r\nend;\r\n\r\nprocedure TJvTFPrinter.SetMeasure(Value: TJvTFPrinterMeasure);\r\nbegin\r\n try\r\n FConvertingProps := True;\r\n if Value <> FMeasure then\r\n begin\r\n PageLayout.FHeaderHeight := ConvertMeasure(PageLayout.FHeaderHeight,\r\n FMeasure, Value, False);\r\n PageLayout.FFooterHeight := ConvertMeasure(PageLayout.FFooterHeight,\r\n FMeasure, Value, False);\r\n\r\n PageLayout.FMargins.Left := ConvertMeasure(PageLayout.FMargins.Left,\r\n FMeasure, Value, True);\r\n PageLayout.FMargins.Right := ConvertMeasure(PageLayout.FMargins.Right,\r\n FMeasure, Value, True);\r\n PageLayout.FMargins.Top := ConvertMeasure(PageLayout.FMargins.Top,\r\n FMeasure, Value, False);\r\n PageLayout.FMargins.Bottom := ConvertMeasure(PageLayout.FMargins.Bottom,\r\n FMeasure, Value, False);\r\n FMeasure := Value;\r\n end;\r\n finally\r\n FConvertingProps := False;\r\n end;\r\nend;\r\n\r\nprocedure TJvTFPrinter.SetPageLayout(Value: TJvTFPrinterPageLayout);\r\nbegin\r\n FPageLayout.Assign(Value);\r\nend;\r\n\r\nprocedure TJvTFPrinter.SetPropertyCheck;\r\nbegin\r\n if (State <> spsNoDoc) and not ConvertingProps then\r\n raise EJvTFPrinterError.CreateRes(@RsEThisPropertyCannotBeChangedIfA);\r\nend;\r\n\r\nprocedure TJvTFPrinter.SetTitle(const Value: string);\r\nbegin\r\n FTitle := Value;\r\nend;\r\n\r\n//=== { TJvTFPrinterPageLayout } =============================================\r\n\r\nconstructor TJvTFPrinterPageLayout.Create(aPrinter: TJvTFPrinter);\r\nbegin\r\n inherited Create;\r\n if not Assigned(aPrinter) then\r\n raise EJvTFPrinterError.CreateRes(@RsECouldNotCreateTJvTFPrinterPageLayou);\r\n\r\n FPrinter := aPrinter;\r\nend;\r\n\r\nprocedure TJvTFPrinterPageLayout.Assign(Source: TPersistent);\r\nvar\r\n SourceMeas, DestMeas: TJvTFPrinterMeasure;\r\n WorkVal: Integer;\r\n SourceLayout: TJvTFPrinterPageLayout;\r\nbegin\r\n if (Source is TJvTFPrinterPageLayout) then\r\n begin\r\n if not Assigned(Printer) or not Assigned(TJvTFPrinterPageLayout(Source).Printer) then\r\n Exit; // raise?\r\n SourceLayout := TJvTFPrinterPageLayout(Source);\r\n SourceMeas := SourceLayout.Printer.Measure;\r\n DestMeas := Printer.Measure;\r\n\r\n WorkVal := SourceLayout.MarginLeft;\r\n WorkVal := Printer.ConvertMeasure(WorkVal, SourceMeas, DestMeas, True);\r\n SetMargin(1, WorkVal);\r\n\r\n WorkVal := SourceLayout.MarginTop;\r\n WorkVal := Printer.ConvertMeasure(WorkVal, SourceMeas, DestMeas, False);\r\n SetMargin(2, WorkVal);\r\n\r\n WorkVal := SourceLayout.MarginRight;\r\n WorkVal := Printer.ConvertMeasure(WorkVal, SourceMeas, DestMeas, True);\r\n SetMargin(3, WorkVal);\r\n\r\n WorkVal := SourceLayout.MarginBottom;\r\n WorkVal := Printer.ConvertMeasure(WorkVal, SourceMeas, DestMeas, False);\r\n SetMargin(4, WorkVal);\r\n\r\n WorkVal := SourceLayout.HeaderHeight;\r\n WorkVal := Printer.ConvertMeasure(WorkVal, SourceMeas, DestMeas, False);\r\n SetHeaderHeight(WorkVal);\r\n\r\n WorkVal := SourceLayout.FooterHeight;\r\n WorkVal := Printer.ConvertMeasure(WorkVal, SourceMeas, DestMeas, False);\r\n SetFooterHeight(WorkVal);\r\n end\r\n else\r\n inherited Assign(Source);\r\nend;\r\n\r\nprocedure TJvTFPrinterPageLayout.Change;\r\nbegin\r\n // do nothing, leave to descendants\r\nend;\r\n\r\nfunction TJvTFPrinterPageLayout.GetMargin(Index: Integer): Integer;\r\nbegin\r\n case Index of\r\n 1:\r\n Result := FMargins.Left;\r\n 2:\r\n Result := FMargins.Top;\r\n 3:\r\n Result := FMargins.Right;\r\n else\r\n Result := FMargins.Bottom;\r\n end;\r\nend;\r\n\r\nprocedure TJvTFPrinterPageLayout.SetFooterHeight(Value: Integer);\r\nvar\r\n Check: Integer;\r\nbegin\r\n SetPropertyCheck;\r\n\r\n if Value < 0 then\r\n Value := 0;\r\n\r\n if Value <> FFooterHeight then\r\n begin\r\n Check := FFooterHeight;\r\n FFooterHeight := Value;\r\n if Printer.BodyHeight < 1 then\r\n begin\r\n FFooterHeight := Check;\r\n raise EJvTFPrinterError.CreateResFmt(@RsEInvalidFooterHeightd, [Value]);\r\n end\r\n else\r\n Change;\r\n end;\r\nend;\r\n\r\nprocedure TJvTFPrinterPageLayout.SetHeaderHeight(Value: Integer);\r\nvar\r\n Check: Integer;\r\nbegin\r\n SetPropertyCheck;\r\n\r\n if Value < 0 then\r\n Value := 0;\r\n if Value <> FHeaderHeight then\r\n begin\r\n Check := FHeaderHeight;\r\n FHeaderHeight := Value;\r\n if Printer.BodyHeight < 1 then\r\n begin\r\n FHeaderHeight := Check;\r\n raise EJvTFPrinterError.CreateResFmt(@RsEInvalidHeaderHeightd, [Value]);\r\n end\r\n else\r\n Change;\r\n end;\r\nend;\r\n\r\nprocedure TJvTFPrinterPageLayout.SetMargin(Index, Value: Integer);\r\nvar\r\n Unprintable, UserMarginPels, CurrMargin, NewMargin: Integer;\r\n Horz, Err: Boolean;\r\nbegin\r\n SetPropertyCheck;\r\n\r\n CurrMargin := GetMargin(Index);\r\n if Value <> CurrMargin then\r\n begin\r\n Horz := (Index = 1) or (Index = 3);\r\n case Index of\r\n 1:\r\n Unprintable := Printer.GetUnprintable.Left;\r\n 2:\r\n Unprintable := Printer.GetUnprintable.Top;\r\n 3:\r\n Unprintable := Printer.GetUnprintable.Right;\r\n else\r\n Unprintable := Printer.GetUnprintable.Bottom;\r\n end;\r\n\r\n UserMarginPels := Printer.ConvertMeasure(Value, Printer.Measure,\r\n pmPixels, Horz);\r\n Printer.SetMarginOffset(Index, UserMarginPels - Unprintable);\r\n\r\n if Printer.GetMarginOffset(Index) >= 0 then\r\n begin\r\n Err := False;\r\n NewMargin := Value;\r\n end\r\n else\r\n begin\r\n Err := True;\r\n Printer.SetMarginOffset(Index, 0);\r\n NewMargin := Printer.ConvertMeasure(Unprintable, pmPixels,\r\n Printer.Measure, Horz);\r\n end;\r\n\r\n if not Err then\r\n case Index of\r\n 1:\r\n FMargins.Left := NewMargin;\r\n 2:\r\n FMargins.Top := NewMargin;\r\n 3:\r\n FMargins.Right := NewMargin;\r\n else\r\n FMargins.Bottom := NewMargin;\r\n end\r\n else\r\n //SetMargin(Index, NewMargin);\r\n case Index of\r\n 1:\r\n MarginLeft := NewMargin;\r\n 2:\r\n MarginTop := NewMargin;\r\n 3:\r\n MarginRight := NewMargin;\r\n else\r\n MarginBottom := NewMargin;\r\n end;\r\n\r\n if Err and Assigned(Printer) then\r\n begin\r\n Printer.UpdateDesigner;\r\n Printer.MarginError;\r\n end;\r\n\r\n Change;\r\n end;\r\nend;\r\n\r\nprocedure TJvTFPrinterPageLayout.SetPropertyCheck;\r\nbegin\r\n Printer.SetPropertyCheck;\r\nend;\r\n\r\n//=== { TJvTFUniversalPrinter } ==============================================\r\n\r\nprocedure TJvTFUniversalPrinter.CreateDoc;\r\nbegin\r\n inherited CreateDoc;\r\nend;\r\n\r\nprocedure TJvTFUniversalPrinter.FinishDoc;\r\nbegin\r\n inherited FinishDoc;\r\nend;\r\n\r\nprocedure TJvTFUniversalPrinter.NewDoc;\r\nbegin\r\n inherited NewDoc;\r\nend;\r\n\r\nprocedure TJvTFUniversalPrinter.NewPage;\r\nbegin\r\n inherited NewPage;\r\nend;\r\n\r\n//=== { TJvTFHintProps } =====================================================\r\n\r\nconstructor TJvTFHintProps.Create(AOwner: TJvTFControl);\r\nbegin\r\n inherited Create;\r\n FControl := AOwner;\r\n\r\n FHintColor := clDefault;\r\n FHintHidePause := -1;\r\n FHintPause := -1;\r\nend;\r\n\r\nprocedure TJvTFHintProps.Assign(Source: TPersistent);\r\nbegin\r\n if Source is TJvTFHint then\r\n begin\r\n FHintColor := TJvTFHintProps(Source).HintColor;\r\n FHintHidePause := TJvTFHintProps(Source).HintHidePause;\r\n FHintPause := TJvTFHintProps(Source).HintPause;\r\n Change;\r\n end\r\n else\r\n inherited Assign(Source);\r\nend;\r\n\r\nprocedure TJvTFHintProps.Change;\r\nbegin\r\n // do nothing\r\nend;\r\n\r\nprocedure TJvTFHintProps.SetHintColor(Value: TColor);\r\nbegin\r\n if Value <> FHintColor then\r\n begin\r\n FHintColor := Value;\r\n Change;\r\n end;\r\nend;\r\n\r\nprocedure TJvTFHintProps.SetHintHidePause(Value: Integer);\r\nbegin\r\n if Value < -1 then\r\n Value := -1;\r\n\r\n if Value <> FHintHidePause then\r\n begin\r\n FHintHidePause := Value;\r\n Change;\r\n end;\r\nend;\r\n\r\nprocedure TJvTFHintProps.SetHintPause(Value: Integer);\r\nbegin\r\n if Value < -1 then\r\n Value := -1;\r\n\r\n if Value <> HintPause then\r\n begin\r\n FHintPause := Value;\r\n Change;\r\n end;\r\nend;\r\n\r\n//=== { TJvTFDWNames } =======================================================\r\n\r\nconstructor TJvTFDWNames.Create;\r\nbegin\r\n inherited Create;\r\n FSource := dwnsSysShort;\r\n FDWN_Sunday := 'S';\r\n FDWN_Monday := 'M';\r\n FDWN_Tuesday := 'T';\r\n FDWN_Wednesday := 'W';\r\n FDWN_Thursday := 'T';\r\n FDWN_Friday := 'F';\r\n FDWN_Saturday := 'S';\r\nend;\r\n\r\nprocedure TJvTFDWNames.Assign(Source: TPersistent);\r\nbegin\r\n if Source is TJvTFDWNames then\r\n begin\r\n FDWN_Sunday := TJvTFDWNames(Source).DWN_Sunday;\r\n FDWN_Monday := TJvTFDWNames(Source).DWN_Monday;\r\n FDWN_Tuesday := TJvTFDWNames(Source).DWN_Tuesday;\r\n FDWN_Wednesday := TJvTFDWNames(Source).DWN_Wednesday;\r\n FDWN_Thursday := TJvTFDWNames(Source).DWN_Thursday;\r\n FDWN_Friday := TJvTFDWNames(Source).DWN_Friday;\r\n FDWN_Saturday := TJvTFDWNames(Source).DWN_Saturday;\r\n FSource := TJvTFDWNames(Source).Source;\r\n Change;\r\n end\r\n else\r\n inherited Assign(Source);\r\nend;\r\n\r\nprocedure TJvTFDWNames.Change;\r\nbegin\r\n if Assigned(FOnChange) then\r\n FOnChange(Self);\r\nend;\r\n\r\nfunction TJvTFDWNames.GetDWN(Index: Integer): string;\r\nbegin\r\n case Index of\r\n 1:\r\n Result := FDWN_Sunday;\r\n 2:\r\n Result := FDWN_Monday;\r\n 3:\r\n Result := FDWN_Tuesday;\r\n 4:\r\n Result := FDWN_Wednesday;\r\n 5:\r\n Result := FDWN_Thursday;\r\n 6:\r\n Result := FDWN_Friday;\r\n 7:\r\n Result := FDWN_Saturday;\r\n else\r\n Result := '';\r\n end;\r\nend;\r\n\r\nfunction TJvTFDWNames.GetDWName(DWIndex: Integer): string;\r\nbegin\r\n case Source of\r\n dwnsSysLong:\r\n Result := JclFormatSettings.LongDayNames[DWIndex];\r\n dwnsSysShort:\r\n Result := JclFormatSettings.ShortDayNames[DWIndex];\r\n else // dwnsCustom\r\n Result := GetDWN(DWIndex);\r\n end;\r\nend;\r\n\r\nprocedure TJvTFDWNames.SetDWN(Index: Integer; const Value: string);\r\nbegin\r\n case Index of\r\n 1:\r\n FDWN_Sunday := Value;\r\n 2:\r\n FDWN_Monday := Value;\r\n 3:\r\n FDWN_Tuesday := Value;\r\n 4:\r\n FDWN_Wednesday := Value;\r\n 5:\r\n FDWN_Thursday := Value;\r\n 6:\r\n FDWN_Friday := Value;\r\n 7:\r\n FDWN_Saturday := Value;\r\n end;\r\n\r\n if Source = dwnsCustom then\r\n Change;\r\nend;\r\n\r\nprocedure TJvTFDWNames.SetSource(Value: TJvTFDWNameSource);\r\nbegin\r\n if Value <> FSource then\r\n begin\r\n FSource := Value;\r\n Change;\r\n end;\r\nend;\r\n\r\n//=== { TJvTFDateList } ======================================================\r\n\r\nconstructor TJvTFDateList.Create;\r\nbegin\r\n inherited Create;\r\n FList := TStringList.Create;\r\n FList.Sorted := True;\r\n FList.Duplicates := dupIgnore;\r\nend;\r\n\r\ndestructor TJvTFDateList.Destroy;\r\nbegin\r\n FList.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJvTFDateList.Add(ADate: TDate): Integer;\r\nbegin\r\n Result := FList.Add(IntToStr(Trunc(ADate)));\r\n Change;\r\nend;\r\n\r\nprocedure TJvTFDateList.Change;\r\nbegin\r\n if Assigned(FOnChange) then\r\n FOnChange(Self);\r\nend;\r\n\r\nprocedure TJvTFDateList.Clear;\r\nbegin\r\n FList.Clear;\r\n Change;\r\nend;\r\n\r\nfunction TJvTFDateList.Count: Integer;\r\nbegin\r\n Result := FList.Count;\r\nend;\r\n\r\nprocedure TJvTFDateList.Delete(Index: Integer);\r\nbegin\r\n FList.Delete(Index);\r\n Change;\r\nend;\r\n\r\nfunction TJvTFDateList.GetDate(Index: Integer): TDate;\r\nbegin\r\n Result := StrToInt(FList[Index]);\r\nend;\r\n\r\nfunction TJvTFDateList.IndexOf(ADate: TDate): Integer;\r\nbegin\r\n Result := FList.IndexOf(IntToStr(Trunc(ADate)));\r\nend;\r\n\r\n//=== { TJvTFNavigator } =====================================================\r\n\r\n//constructor TJvTFNavigator.Create(AOwner: TComponent);\r\n//begin\r\n// inherited Create(AOwner);\r\n// FControls := TStringList.Create;\r\n//end;\r\n//\r\n//destructor TJvTFNavigator.Destroy;\r\n//begin\r\n// While ControlCount > 0 do\r\n// UnregisterControl(Controls[0]);\r\n// FControls.Free;\r\n//\r\n// inherited Destroy;\r\n//end;\r\n//\r\n//function TJvTFNavigator.ControlCount: Integer;\r\n//begin\r\n// Result := FControls.Count;\r\n//end;\r\n//\r\n//function TJvTFNavigator.GetControl(Index: Integer): TJvTFControl;\r\n//begin\r\n// Result := TJvTFControl(FControls.Objects[Index]);\r\n//end;\r\n//\r\n//procedure TJvTFNavigator.Navigate(aControl: TJvTFControl;\r\n// SchedNames: TStringList; Dates: TJvTFDateList);\r\n//var\r\n// I: Integer;\r\n// Control: TJvTFControl;\r\n//begin\r\n// If Navigating or not Assigned(aControl) Then\r\n// Exit;\r\n//\r\n// If Assigned(FBeforeNavigate) Then\r\n// FBeforeNavigate(Self, aControl, SchedNames, Dates);\r\n//\r\n// FNavigating := True;\r\n// Try\r\n// For I := 0 to ControlCount - 1 do\r\n// Begin\r\n// Control := Controls[I];\r\n// If Control <> aControl Then\r\n// //Controls[I].Notify(aControl, sncNavigate);\r\n// Control.Navigate(aControl, SchedNames, Dates);\r\n// End;\r\n// Finally\r\n// FNavigating := False;\r\n// End;\r\n//\r\n// If Assigned(FAfterNavigate) Then\r\n// FAfterNavigate(Self, aControl, SchedNames, Dates);\r\n//end;\r\n//\r\n//procedure TJvTFNavigator.RegisterControl(aControl: TJvTFControl);\r\n//var\r\n// I: Integer;\r\n//begin\r\n// I := FControls.IndexOfObject(aControl);\r\n// If I = -1 Then\r\n// FControls.AddObject('', aControl);\r\n//end;\r\n//\r\n//procedure TJvTFNavigator.UnregisterControl(aControl: TJvTFControl);\r\n//var\r\n// I: Integer;\r\n//begin\r\n// I := FControls.IndexOfObject(aControl);\r\n// If I > -1 Then\r\n// FControls.Delete(I);\r\n//end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvTFMonths.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvTFMonths.PAS, released on 2003-08-01.\r\n\r\nThe Initial Developer of the Original Code is Unlimited Intelligence Limited.\r\nPortions created by Unlimited Intelligence Limited are Copyright (C) 1999-2002 Unlimited Intelligence Limited.\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\nMike Kolter (original code)\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvTFMonths.pas 13104 2011-09-07 06:50:43Z obones $\r\n\r\nunit JvTFMonths;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n SysUtils, Classes, Windows, Messages, Graphics, Controls, Forms, Dialogs,\r\n JvTFGlance, JvTFUtils, JvTFManager;\r\n\r\ntype\r\n TJvTFMonthsScrollSize = (mssMonth, mssWeek);\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvTFMonths = class(TJvTFCustomGlance)\r\n private\r\n FDisplayDate: TDate;\r\n FDWNames: TJvTFDWNames;\r\n FDWTitleAttr: TJvTFGlanceTitle;\r\n FOnDrawDWTitle: TJvTFDrawDWTitleEvent;\r\n FOnUpdateTitle: TJvTFUpdateTitleEvent;\r\n FOffDays: TTFDaysOfWeek;\r\n FExtraDayCellAttr: TJvTFGlanceCellAttr;\r\n FOffDayCellAttr: TJvTFGlanceCellAttr;\r\n FScrollSize: TJvTFMonthsScrollSize;\r\n FSplitSatSun: Boolean;\r\n FDayFormat: string;\r\n FFirstDayOfMonthFormat: string;\r\n function GetMonth: Word;\r\n procedure SetMonth(Value: Word);\r\n function GetYear: Word;\r\n procedure SetYear(Value: Word);\r\n procedure SetDisplayDate(Value: TDate);\r\n procedure SetDWNames(Value: TJvTFDWNames);\r\n procedure SetDWTitleAttr(Value: TJvTFGlanceTitle);\r\n procedure SetOffDays(Value: TTFDaysOfWeek);\r\n procedure SetExtraDayCellAttr(Value: TJvTFGlanceCellAttr);\r\n procedure SetOffDayCellAttr(Value: TJvTFGlanceCellAttr);\r\n procedure SetSplitSatSun(Value: Boolean);\r\n procedure SetDayFormat(const Value: string);\r\n procedure SetFirstDayOfMonthFormat(const Value: string);\r\n protected\r\n procedure SetStartOfWeek(Value: TTFDayOfWeek); override;\r\n procedure SetColCount(Value: Integer); override;\r\n procedure ConfigCells; override;\r\n procedure DWNamesChange(Sender: TObject);\r\n procedure Navigate(AControl: TJvTFControl; SchedNames: TStringList;\r\n Dates: TJvTFDateList); override;\r\n // draws the DWTitles\r\n procedure DrawTitle(ACanvas: TCanvas); override;\r\n procedure UpdateTitle;\r\n procedure NextMonth;\r\n procedure PrevMonth;\r\n procedure NextWeek;\r\n procedure PrevWeek;\r\n function GetCellTitleText(Cell: TJvTFGlanceCell): string; override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n function GetDataTop: Integer; override;\r\n function GetCellAttr(ACell: TJvTFGlanceCell): TJvTFGlanceCellAttr; override;\r\n function CellIsExtraDay(ACell: TJvTFGlanceCell): Boolean;\r\n function CellIsOffDay(ACell: TJvTFGlanceCell): Boolean;\r\n function DOWShowing(DOW: TTFDayOfWeek): Boolean;\r\n procedure ScrollPrev;\r\n procedure ScrollNext;\r\n published\r\n property ScrollSize: TJvTFMonthsScrollSize read FScrollSize write FScrollSize default mssMonth;\r\n property Month: Word read GetMonth write SetMonth;\r\n property Year: Word read GetYear write SetYear;\r\n property DisplayDate: TDate read FDisplayDate write SetDisplayDate;\r\n property DWNames: TJvTFDWNames read FDWNames write SetDWNames;\r\n property DWTitleAttr: TJvTFGlanceTitle read FDWTitleAttr write SetDWTitleAttr;\r\n property OffDays: TTFDaysOfWeek read FOffDays write SetOffDays default [dowSunday, dowSaturday];\r\n property ExtraDayCellAttr: TJvTFGlanceCellAttr read FExtraDayCellAttr write SetExtraDayCellAttr;\r\n property OffDayCellAttr: TJvTFGlanceCellAttr read FOffDayCellAttr write SetOffDayCellAttr;\r\n property SplitSatSun: Boolean read FSplitSatSun write SetSplitSatSun default False;\r\n property OnDrawDWTitle: TJvTFDrawDWTitleEvent read FOnDrawDWTitle write FOnDrawDWTitle;\r\n property OnUpdateTitle: TJvTFUpdateTitleEvent read FOnUpdateTitle write FOnUpdateTitle;\r\n property StartOfWeek;\r\n property ColCount;\r\n property FirstDayOfMonthFormat: string read FFirstDayOfMonthFormat write SetFirstDayOfMonthFormat;\r\n property DayFormat: string read FDayFormat write SetDayFormat;\r\n// property Navigator;\r\n// property OnNavigate;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvTFMonths.pas $';\r\n Revision: '$Revision: 13104 $';\r\n Date: '$Date: 2011-09-07 08:50:43 +0200 (mer. 07 sept. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n DateUtils;\r\n\r\nconstructor TJvTFMonths.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n DisplayDate := Date;\r\n\r\n FOffDays := [dowSunday, dowSaturday];\r\n FScrollSize := mssMonth;\r\n\r\n FDWNames := TJvTFDWNames.Create;\r\n FDWNames.OnChange := DWNamesChange;\r\n\r\n FExtraDayCellAttr := TJvTFGlanceCellAttr.Create(Self);\r\n FOffDayCellAttr := TJvTFGlanceCellAttr.Create(Self);\r\n\r\n CellAttr.TitleAttr.Color := clWhite;\r\n FExtraDayCellAttr.TitleAttr.Color := clWhite;\r\n FOffDayCellAttr.TitleAttr.Color := clWhite;\r\n\r\n FDayFormat := 'd';\r\n FFirstDayOfMonthFormat := 'mmm d';\r\n\r\n FDWTitleAttr := TJvTFGlanceTitle.Create(Self);\r\n with FDWTitleAttr do\r\n begin\r\n// Assign(TitleAttr);\r\n TxtAttr.Font.Size := 8;\r\n TxtAttr.Font.Style := [];\r\n Height := 20;\r\n Visible := True;\r\n FrameAttr.Style := fs3DRaised;\r\n OnChange := GlanceTitleChange;\r\n end;\r\nend;\r\n\r\ndestructor TJvTFMonths.Destroy;\r\nbegin\r\n FDWNames.OnChange := nil;\r\n FDWNames.Free;\r\n FDWTitleAttr.Free;\r\n FExtraDayCellAttr.Free;\r\n FOffDayCellAttr.Free;\r\n\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJvTFMonths.CellIsExtraDay(ACell: TJvTFGlanceCell): Boolean;\r\nvar\r\n Y, M, D: Word;\r\nbegin\r\n DecodeDate(ACell.CellDate, Y, M, D);\r\n Result := (Y <> Self.Year) or (M <> Self.Month);\r\nend;\r\n\r\nfunction TJvTFMonths.CellIsOffDay(ACell: TJvTFGlanceCell): Boolean;\r\nbegin\r\n Result := DateToDOW(ACell.CellDate) in OffDays\r\nend;\r\n\r\nprocedure TJvTFMonths.ConfigCells;\r\nvar\r\n Row, Col, SplitCount: Integer;\r\n Cell: TJvTFGlanceCell;\r\nbegin\r\n{\r\n For Row := 0 to RowCount - 1 do\r\n For Col := 0 to ColCount - 1 do\r\n begin\r\n Cell := Cells.Cells[Col, Row];\r\n if SplitSatSun and (DateToDow(Cell.CellDate) = dowSaturday) Then\r\n SplitCell(Cell)\r\n else\r\n Cell.Combine;\r\n end;\r\n\r\n{\r\n Found := False;\r\n Col := 0;\r\n While (Col < ColCount) and not Found do\r\n if DateToDOW(Cells.Cells[Col, 0].CellDate) = dowSaturday Then\r\n Found := True\r\n else\r\n Inc(Col);\r\n\r\n if Found Then\r\n For Row := 0 to RowCount - 1 do\r\n if SplitSatSun Then\r\n SplitCell(Cells.Cells[Col, Row])\r\n else\r\n Cells.Cells[Col, Row].Combine;\r\n}\r\n\r\n for Row := 0 to RowCount - 1 do\r\n begin\r\n SplitCount := 0;\r\n\r\n for Col := 0 to ColCount - 1 do\r\n begin\r\n Cell := Cells.Cells[Col, Row];\r\n SetCellDate(Cell, OriginDate + Row * 7 + Col + SplitCount);\r\n\r\n if SplitSatSun and (DateToDOW(Cell.CellDate) = dowSaturday) then\r\n SplitCell(Cell)\r\n else\r\n CombineCell(Cell);\r\n\r\n if Cell.IsSplit then\r\n begin\r\n Inc(SplitCount);\r\n SetCellDate(Cell.SubCell, OriginDate + Row * 7 + Col + SplitCount);\r\n end;\r\n end;\r\n end;\r\n\r\n inherited ConfigCells;\r\nend;\r\n\r\nfunction TJvTFMonths.DOWShowing(DOW: TTFDayOfWeek): Boolean;\r\nvar\r\n I: Integer;\r\n TestDOW: TTFDayOfWeek;\r\nbegin\r\n // THIS ROUTINE SUPPORTS ONLY SAT/SUN SPLITS\r\n if (DOW = dowSunday) and SplitSatSun then\r\n Result := DOWShowing(dowSaturday)\r\n else\r\n begin\r\n I := 0;\r\n Result := False;\r\n TestDOW := StartOfWeek;\r\n while (I < ColCount) and not Result do\r\n if TestDOW = DOW then\r\n Result := True\r\n else\r\n IncDOW(TestDOW, 1);\r\n end;\r\nend;\r\n\r\nprocedure TJvTFMonths.DrawTitle(ACanvas: TCanvas);\r\nvar\r\n I, Col, LineBottom: Integer;\r\n CurrDOW: TTFDayOfWeek;\r\n R, TempRect, TxtRect, TextBounds: TRect;\r\n OldPen: TPen;\r\n OldBrush: TBrush;\r\n OldFont: TFont;\r\n Txt: string;\r\nbegin\r\n inherited DrawTitle(ACanvas);\r\n if not DWTitleAttr.Visible then\r\n Exit;\r\n\r\n with ACanvas do\r\n begin\r\n OldPen := TPen.Create;\r\n OldPen.Assign(Pen);\r\n OldBrush := TBrush.Create;\r\n OldBrush.Assign(Brush);\r\n OldFont := TFont.Create;\r\n OldFont.Assign(Font);\r\n end;\r\n\r\n // draw the DWTitles\r\n R.Top := inherited GetDataTop;\r\n R.Bottom := GetDataTop;\r\n\r\n CurrDOW := StartOfWeek;\r\n\r\n for Col := 0 to ColCount - 1 do\r\n begin\r\n TempRect := WholeCellRect(Col, 0);\r\n R.Left := TempRect.Left;\r\n R.Right := TempRect.Right;\r\n TxtRect := R;\r\n Windows.InflateRect(TxtRect, -1, -1);\r\n\r\n with ACanvas do\r\n begin\r\n Brush.Color := DWTitleAttr.Color;\r\n FillRect(R);\r\n\r\n case DWTitleAttr.FrameAttr.Style of\r\n fs3DRaised:\r\n Draw3DFrame(ACanvas, R, clBtnHighlight, clBtnShadow);\r\n fs3DLowered:\r\n Draw3DFrame(ACanvas, R, clBtnShadow, clBtnHighlight);\r\n fsFlat:\r\n begin\r\n Pen.Color := DWTitleAttr.FrameAttr.Color;\r\n Pen.Width := DWTitleAttr.FrameAttr.Width;\r\n if Col = 0 then\r\n begin\r\n MoveTo(R.Left, R.Top);\r\n LineTo(R.Left, R.Bottom);\r\n end;\r\n PolyLine([Point(R.Right - 1, R.Top),\r\n Point(R.Right - 1, R.Bottom - 1),\r\n Point(R.Left - 1, R.Bottom - 1)]);\r\n end;\r\n fsNone:\r\n begin\r\n Pen.Color := DWTitleAttr.FrameAttr.Color;\r\n Pen.Width := 1;\r\n LineBottom := R.Bottom - 1;\r\n for I := 1 to DWTitleAttr.FrameAttr.Width do\r\n begin\r\n MoveTo(R.Left, LineBottom);\r\n LineTo(R.Right, LineBottom);\r\n Dec(LineBottom);\r\n end;\r\n end;\r\n end;\r\n\r\n Txt := DWNames.GetDWName(DOWToBorl(CurrDOW));\r\n if SplitSatSun and (CurrDOW = dowSaturday) then\r\n begin\r\n IncDOW(CurrDOW, 1);\r\n Txt := Txt + '/' + DWNames.GetDWName(DOWToBorl(CurrDOW));\r\n end;\r\n\r\n Font := DWTitleAttr.TxtAttr.Font;\r\n DrawAngleText(ACanvas, TxtRect, TextBounds,\r\n DWTitleAttr.TxtAttr.Rotation,\r\n DWTitleAttr.TxtAttr.AlignH,\r\n DWTitleAttr.TxtAttr.AlignV, Txt);\r\n end;\r\n\r\n if Assigned(FOnDrawDWTitle) then\r\n FOnDrawDWTitle(Self, ACanvas, R, CurrDOW, Txt);\r\n\r\n IncDOW(CurrDOW, 1);\r\n end;\r\n\r\n with ACanvas do\r\n begin\r\n Pen.Assign(OldPen);\r\n Brush.Assign(OldBrush);\r\n Font.Assign(OldFont);\r\n OldPen.Free;\r\n OldBrush.Free;\r\n OldFont.Free;\r\n end;\r\nend;\r\n\r\nprocedure TJvTFMonths.DWNamesChange(Sender: TObject);\r\nbegin\r\n Invalidate;\r\nend;\r\n\r\nfunction TJvTFMonths.GetCellAttr(ACell: TJvTFGlanceCell): TJvTFGlanceCellAttr;\r\nbegin\r\n if CellIsSelected(ACell) then\r\n Result := SelCellAttr\r\n else\r\n if CellIsExtraDay(ACell) then\r\n Result := ExtraDayCellAttr\r\n else\r\n if CellIsOffDay(ACell) then\r\n Result := OffDayCellAttr\r\n else\r\n Result := CellAttr;\r\nend;\r\n\r\nfunction TJvTFMonths.GetCellTitleText(Cell: TJvTFGlanceCell): string;\r\nbegin\r\n if CellIsExtraDay(Cell) and (IsFirstOfMonth(Cell.CellDate) or EqualDates(Cell.CellDate, OriginDate)) then\r\n Result := FormatDateTime(FirstDayOfMonthFormat, Cell.CellDate)\r\n else\r\n Result := FormatDateTime(DayFormat, Cell.CellDate);\r\nend;\r\n\r\nfunction TJvTFMonths.GetDataTop: Integer;\r\nbegin\r\n Result := inherited GetDataTop;\r\n if DWTitleAttr.Visible then\r\n Inc(Result, DWTitleAttr.Height);\r\nend;\r\n\r\nfunction TJvTFMonths.GetMonth: Word;\r\nbegin\r\n Result := ExtractMonth(DisplayDate);\r\nend;\r\n\r\nfunction TJvTFMonths.GetYear: Word;\r\nbegin\r\n Result := ExtractYear(DisplayDate);\r\nend;\r\n\r\nprocedure TJvTFMonths.Navigate(AControl: TJvTFControl;\r\n SchedNames: TStringList; Dates: TJvTFDateList);\r\nbegin\r\n inherited Navigate(AControl, SchedNames, Dates);\r\n if Dates.Count > 0 then\r\n DisplayDate := Dates[0];\r\nend;\r\n\r\nprocedure TJvTFMonths.NextMonth;\r\nvar\r\n Temp: TDateTime;\r\nbegin\r\n Temp := DisplayDate;\r\n IncMonths(Temp, 1);\r\n DisplayDate := Temp;\r\nend;\r\n\r\nprocedure TJvTFMonths.NextWeek;\r\nvar\r\n Temp: TDateTime;\r\nbegin\r\n Temp := DisplayDate;\r\n IncWeeks(Temp, 1);\r\n DisplayDate := Temp;\r\nend;\r\n\r\nprocedure TJvTFMonths.PrevMonth;\r\nvar\r\n Temp: TDateTime;\r\nbegin\r\n Temp := DisplayDate;\r\n IncMonths(Temp, -1);\r\n DisplayDate := Temp;\r\nend;\r\n\r\nprocedure TJvTFMonths.PrevWeek;\r\nvar\r\n Temp: TDateTime;\r\nbegin\r\n Temp := DisplayDate;\r\n IncWeeks(Temp, -1);\r\n DisplayDate := Temp;\r\nend;\r\n\r\nprocedure TJvTFMonths.ScrollNext;\r\nbegin\r\n if ScrollSize = mssMonth then\r\n NextMonth\r\n else\r\n NextWeek;\r\nend;\r\n\r\nprocedure TJvTFMonths.ScrollPrev;\r\nbegin\r\n if ScrollSize = mssMonth then\r\n PrevMonth\r\n else\r\n PrevWeek;\r\nend;\r\n\r\nprocedure TJvTFMonths.SetColCount(Value: Integer);\r\nbegin\r\n Value := Lesser(Value, 7);\r\n inherited SetColCount(Value);\r\nend;\r\n\r\nprocedure TJvTFMonths.SetDayFormat(const Value: string);\r\nbegin\r\n if Value <> FDayFormat then\r\n begin\r\n FDayFormat := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvTFMonths.SetDisplayDate(Value: TDate);\r\nbegin\r\n FDisplayDate := Value;\r\n if ScrollSize = mssMonth then\r\n StartDate := FirstOfMonth(Value)\r\n else\r\n StartDate := Value;\r\n UpdateTitle;\r\nend;\r\n\r\nprocedure TJvTFMonths.SetDWNames(Value: TJvTFDWNames);\r\nbegin\r\n FDWNames.Assign(Value);\r\nend;\r\n\r\nprocedure TJvTFMonths.SetDWTitleAttr(Value: TJvTFGlanceTitle);\r\nbegin\r\n FDWTitleAttr.Assign(Value);\r\nend;\r\n\r\nprocedure TJvTFMonths.SetExtraDayCellAttr(Value: TJvTFGlanceCellAttr);\r\nbegin\r\n FExtraDayCellAttr.Assign(Value);\r\nend;\r\n\r\nprocedure TJvTFMonths.SetFirstDayOfMonthFormat(const Value: string);\r\nbegin\r\n if Value <> FFirstDayOfMonthFormat then\r\n begin\r\n FFirstDayOfMonthFormat := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvTFMonths.SetMonth(Value: Word);\r\nvar\r\n Y, M, D: Word;\r\nbegin\r\n // Don't set the month while loading, the DisplayDate will be loaded as well\r\n if csLoading in ComponentState then\r\n Exit;\r\n\r\n EnsureMonth(Value);\r\n\r\n DecodeDate(DisplayDate, Y, M, D);\r\n if Value <> M then\r\n begin\r\n // Ensure the day is still inside the valid values for the new month\r\n if D > DaysInAMonth(Y, Value) then\r\n D := DaysInAMonth(Y, Value);\r\n DisplayDate := EncodeDate(Y, Value, D);\r\n end;\r\nend;\r\n\r\nprocedure TJvTFMonths.SetOffDayCellAttr(Value: TJvTFGlanceCellAttr);\r\nbegin\r\n FOffDayCellAttr.Assign(Value);\r\nend;\r\n\r\nprocedure TJvTFMonths.SetOffDays(Value: TTFDaysOfWeek);\r\nbegin\r\n if Value <> FOffDays then\r\n begin\r\n FOffDays := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvTFMonths.SetSplitSatSun(Value: Boolean);\r\nbegin\r\n if Value <> FSplitSatSun then\r\n begin\r\n if DOWShowing(dowSunday) or DOWShowing(dowSaturday) then\r\n if Value then\r\n begin\r\n if StartOfWeek = dowSunday then\r\n StartOfWeek := dowMonday;\r\n ColCount := ColCount - 1;\r\n end\r\n else\r\n ColCount := ColCount + 1;\r\n\r\n FSplitSatSun := Value;\r\n Cells.ReconfigCells;\r\n end;\r\nend;\r\n\r\nprocedure TJvTFMonths.SetStartOfWeek(Value: TTFDayOfWeek);\r\nbegin\r\n if SplitSatSun and (Value = dowSunday) then\r\n Value := dowSaturday;\r\n inherited SetStartOfWeek(Value);\r\nend;\r\n\r\nprocedure TJvTFMonths.SetYear(Value: Word);\r\nvar\r\n Y, M, D: Word;\r\nbegin\r\n // Don't set the year while loading, the DisplayDate will be loaded as well\r\n if csLoading in ComponentState then\r\n Exit;\r\n\r\n DecodeDate(DisplayDate, Y, M, D);\r\n if Value <> Y then\r\n begin\r\n // Ensure the day is still inside the valid values for the month of\r\n // the new year. This case only happens with February, by the way.\r\n if D > DaysInAMonth(Value, M) then\r\n D := DaysInAMonth(Value, M);\r\n DisplayDate := EncodeDate(Value, M, D);\r\n end;\r\nend;\r\n\r\nprocedure TJvTFMonths.UpdateTitle;\r\nvar\r\n NewTitle: string;\r\nbegin\r\n NewTitle := FormatDateTime('mmmm yyyy', DisplayDate);\r\n if NewTitle <> TitleAttr.Title then\r\n begin\r\n if Assigned(FOnUpdateTitle) then\r\n FOnUpdateTitle(Self, NewTitle);\r\n TitleAttr.Title := NewTitle;\r\n end;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend." }, { "path": "External/Jedi/Jvcl/run/JvTFSparseMatrix.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvTFSparseMatrix.PAS, released on 2003-08-01.\r\n\r\nThe Initial Developer of the Original Code is Unlimited Intelligence Limited.\r\nPortions created by Unlimited Intelligence Limited are Copyright (C) 1999-2002 Unlimited Intelligence Limited.\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\nMike Kolter (original code)\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvTFSparseMatrix.pas 13397 2012-08-16 17:23:19Z ahuser $\r\n\r\nunit JvTFSparseMatrix;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Classes, SysUtils;\r\n\r\ntype\r\n {$IFNDEF COMPILER12_UP}\r\n NativeInt = Integer;\r\n {$ENDIF ~COMPILER12_UP}\r\n\r\n EJvTFSparseMatrixError = class(Exception);\r\n PSMQuantum = ^TSMQuantum;\r\n TSMQuantum = record\r\n Index: Integer;\r\n Data: NativeInt;\r\n Link: PSMQuantum;\r\n end;\r\n\r\n TJvTFSparseMatrix = class(TObject)\r\n private\r\n FMatrix: TSMQuantum;\r\n FNullValue: NativeInt;\r\n procedure SetNullValue(Value: NativeInt);\r\n function GetData(Row, Col: Integer): NativeInt;\r\n procedure SetData(Row, Col: Integer; Value: NativeInt);\r\n procedure Put(Row, Col: Integer; Data: NativeInt);\r\n function Get(Row, Col: Integer): NativeInt;\r\n function FindQuantum(Row, Col: Integer;\r\n var Prev, Curr: PSMQuantum; var RowExists: Boolean): Boolean;\r\n public\r\n destructor Destroy; override;\r\n procedure Clear;\r\n procedure Pack;\r\n procedure CopyTo(DestMatrix: TJvTFSparseMatrix);\r\n property Data[Row, Col: Integer]: NativeInt read GetData write SetData; default;\r\n property NullValue: NativeInt read FNullValue write SetNullValue default 0;\r\n procedure Dump(const DumpList: TStrings);\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvTFSparseMatrix.pas $';\r\n Revision: '$Revision: 13397 $';\r\n Date: '$Date: 2012-08-16 19:23:19 +0200 (jeu. 16 août 2012) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n JvResources;\r\n\r\ndestructor TJvTFSparseMatrix.Destroy;\r\nbegin\r\n Clear;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvTFSparseMatrix.Clear;\r\nvar\r\n P, CurrRow, CurrCol: PSMQuantum;\r\nbegin\r\n CurrRow := PSMQuantum(FMatrix.Data);\r\n\r\n while CurrRow <> nil do\r\n begin\r\n CurrCol := CurrRow^.Link;\r\n while CurrCol <> nil do\r\n begin\r\n P := CurrCol;\r\n CurrCol := CurrCol^.Link;\r\n Dispose(P);\r\n end;\r\n\r\n P := CurrRow;\r\n CurrRow := PSMQuantum(CurrRow^.Data);\r\n Dispose(P);\r\n end;\r\n\r\n FMatrix.Data := 0;\r\nend;\r\n\r\nprocedure TJvTFSparseMatrix.CopyTo(DestMatrix: TJvTFSparseMatrix);\r\nvar\r\n CurrRow, CurrCol: PSMQuantum;\r\nbegin\r\n DestMatrix.Clear;\r\n DestMatrix.NullValue := NullValue;\r\n\r\n CurrRow := PSMQuantum(FMatrix.Data);\r\n\r\n while CurrRow <> nil do\r\n begin\r\n CurrCol := CurrRow^.Link;\r\n while CurrCol <> nil do\r\n begin\r\n DestMatrix[CurrRow^.Index, CurrCol^.Index] := CurrCol^.Data;\r\n CurrCol := CurrCol^.Link;\r\n end;\r\n\r\n CurrRow := PSMQuantum(CurrRow^.Data);\r\n end;\r\nend;\r\n\r\nprocedure TJvTFSparseMatrix.Dump(const DumpList: TStrings);\r\nvar\r\n CurrRow, CurrCol: PSMQuantum;\r\nbegin\r\n DumpList.Clear;\r\n CurrRow := PSMQuantum(FMatrix.Data);\r\n DumpList.BeginUpdate;\r\n try\r\n while CurrRow <> nil do\r\n begin\r\n CurrCol := CurrRow^.Link;\r\n while CurrCol <> nil do\r\n begin\r\n DumpList.Add('(' + IntToStr(CurrRow^.Index) + ', ' +\r\n IntToStr(CurrCol^.Index) + ') ' +\r\n IntToStr(CurrCol^.Data));\r\n CurrCol := CurrCol^.Link;\r\n end;\r\n CurrRow := PSMQuantum(CurrRow^.Data);\r\n end;\r\n finally\r\n DumpList.EndUpdate;\r\n end;\r\nend;\r\n\r\nfunction TJvTFSparseMatrix.FindQuantum(Row, Col: Integer;\r\n var Prev, Curr: PSMQuantum; var RowExists: Boolean): Boolean;\r\nbegin\r\n Prev := @FMatrix;\r\n Curr := PSMQuantum(FMatrix.Data);\r\n Result := False;\r\n RowExists := False;\r\n\r\n // Find Row Header\r\n while (Curr <> nil) and (Curr^.Index < Row) do\r\n begin\r\n Prev := Curr;\r\n Curr := PSMQuantum(Curr^.Data);\r\n end;\r\n\r\n // If Row Header found, then find col\r\n if (Curr <> nil) and (Curr^.Index = Row) then\r\n begin\r\n RowExists := True;\r\n Prev := Curr;\r\n Curr := Curr^.Link;\r\n while (Curr <> nil) and (Curr^.Index < Col) do\r\n begin\r\n Prev := Curr;\r\n Curr := Curr^.Link;\r\n end;\r\n\r\n Result := (Curr <> nil) and (Curr^.Index = Col);\r\n end;\r\nend;\r\n\r\nfunction TJvTFSparseMatrix.Get(Row, Col: Integer): NativeInt;\r\nvar\r\n Prev, Curr: PSMQuantum;\r\n RowExists: Boolean;\r\nbegin\r\n if FindQuantum(Row, Col, Prev, Curr, RowExists) then\r\n Result := Curr^.Data\r\n else\r\n Result := NullValue;\r\nend;\r\n\r\nfunction TJvTFSparseMatrix.GetData(Row, Col: Integer): NativeInt;\r\nbegin\r\n Result := Get(Row, Col);\r\nend;\r\n\r\nprocedure TJvTFSparseMatrix.Put(Row, Col: Integer; Data: NativeInt);\r\nvar\r\n P, Prev, Curr: PSMQuantum;\r\n RowExists: Boolean;\r\nbegin\r\n if FindQuantum(Row, Col, Prev, Curr, RowExists) then\r\n if Data <> NullValue then\r\n Curr^.Data := Data\r\n else\r\n begin\r\n Prev^.Link := Curr^.Link;\r\n Dispose(Curr);\r\n end\r\n else\r\n if Data <> NullValue then\r\n begin\r\n if not RowExists then\r\n begin\r\n New(P);\r\n P^.Index := Row;\r\n P^.Link := nil;\r\n P^.Data := Prev^.Data;\r\n PSMQuantum(Prev^.Data) := P;\r\n Prev := P;\r\n end;\r\n\r\n New(P);\r\n P^.Index := Col;\r\n P^.Data := Data;\r\n P^.Link := Prev^.Link;\r\n Prev^.Link := P;\r\n end;\r\nend;\r\n\r\nprocedure TJvTFSparseMatrix.SetData(Row, Col: Integer; Value: NativeInt);\r\nbegin\r\n Put(Row, Col, Value);\r\nend;\r\n\r\nprocedure TJvTFSparseMatrix.SetNullValue(Value: NativeInt);\r\nbegin\r\n if FMatrix.Data = 0 then\r\n FNullValue := Value\r\n else\r\n raise EJvTFSparseMatrixError.CreateRes(@RsEMatrixMustBeEmpty);\r\nend;\r\n\r\nprocedure TJvTFSparseMatrix.Pack;\r\nvar\r\n P, Prev, CurrRow: PSMQuantum;\r\nbegin\r\n CurrRow := PSMQuantum(FMatrix.Data);\r\n Prev := @FMatrix;\r\n\r\n while CurrRow <> nil do\r\n begin\r\n if CurrRow^.Link <> nil then\r\n begin\r\n Prev := CurrRow;\r\n CurrRow := PSMQuantum(CurrRow^.Data);\r\n end\r\n else\r\n begin\r\n P := CurrRow;\r\n Prev^.Data := CurrRow^.Data;\r\n Dispose(P);\r\n CurrRow := PSMQuantum(Prev^.Data);\r\n end;\r\n end;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvTFUtils.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvTFUtils.PAS, released on 2003-08-01.\r\n\r\nThe Initial Developer of the Original Code is Unlimited Intelligence Limited.\r\nPortions created by Unlimited Intelligence Limited are Copyright (C) 1999-2002 Unlimited Intelligence Limited.\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\nMike Kolter (original code)\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvTFUtils.pas 13174 2011-11-19 23:13:38Z ahuser $\r\n\r\nunit JvTFUtils;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, Graphics, Controls, Classes, SysUtils;\r\n\r\n{$IFNDEF COMPILER12_UP} // Delphi 2009 knows System::TDate and System::TTime\r\n{$HPPEMIT '#ifndef TDate'}\r\n{$HPPEMIT '#define TDate Controls::TDate'}\r\n{$HPPEMIT '#define TTime Controls::TTime'}\r\n{$HPPEMIT '#endif'}\r\n{$ENDIF ~COMPILER12_UP}\r\n\r\ntype\r\n TJvTFVisibleScrollBars = set of (vsbHorz, vsbVert);\r\n EJvTFDateError = class(Exception);\r\n\r\n TTFDayOfWeek = (dowSunday, dowMonday, dowTuesday, dowWednesday,\r\n dowThursday, dowFriday, dowSaturday);\r\n TTFDaysOfWeek = set of TTFDayOfWeek;\r\n\r\n TJvTFVAlignment = (vaTop, vaCenter, vaBottom);\r\n\r\n TJvTFDirection = (dirUp, dirDown, dirLeft, dirRight);\r\n\r\nconst\r\n DOW_WEEK: TTFDaysOfWeek = [dowSunday..dowSaturday];\r\n DOW_WEEKEND: TTFDaysOfWeek = [dowSunday, dowSaturday];\r\n DOW_WORKWEEK: TTFDaysOfWeek = [dowMonday..dowFriday];\r\n\r\n ONE_HOUR = 1 / 24;\r\n ONE_MINUTE = ONE_HOUR / 60;\r\n ONE_SECOND = ONE_MINUTE / 60;\r\n ONE_MILLISECOND = ONE_SECOND / 1000;\r\n\r\nfunction ExtractYear(ADate: TDateTime): Word;\r\nfunction ExtractMonth(ADate: TDateTime): Word;\r\nfunction ExtractDay(ADate: TDateTime): Word;\r\nfunction ExtractHours(ATime: TDateTime): Word;\r\nfunction ExtractMins(ATime: TDateTime): Word;\r\nfunction ExtractSecs(ATime: TDateTime): Word;\r\nfunction ExtractMSecs(ATime: TDateTime): Word;\r\nfunction FirstOfMonth(ADate: TDateTime): TDateTime;\r\nfunction GetDayOfNthDOW(Year, Month, DOW, N: Word): Word;\r\nfunction GetWeeksInMonth(Year, Month: Word; StartOfWeek: Integer): Word;\r\n\r\nprocedure IncBorlDOW(var BorlDOW: Integer; N: Integer = 1);\r\nprocedure IncDOW(var DOW: TTFDayOfWeek; N: Integer = 1);\r\nprocedure IncDays(var ADate: TDateTime; N: Integer = 1);\r\nprocedure IncWeeks(var ADate: TDateTime; N: Integer = 1);\r\nprocedure IncMonths(var ADate: TDateTime; N: Integer = 1);\r\nprocedure IncYears(var ADate: TDateTime; N: Integer = 1);\r\n\r\nfunction EndOfMonth(ADate: TDateTime): TDateTime;\r\nfunction IsFirstOfMonth(ADate: TDateTime): Boolean;\r\nfunction IsEndOfMonth(ADate: TDateTime): Boolean;\r\nprocedure EnsureMonth(Month: Word);\r\nprocedure EnsureDOW(DOW: Word);\r\nfunction EqualDates(D1, D2: TDateTime): Boolean;\r\nfunction Lesser(N1, N2: Integer): Integer;\r\nfunction Greater(N1, N2: Integer): Integer;\r\nfunction GetDivLength(TotalLength, DivCount, DivNum: Integer): Integer;\r\nfunction GetDivNum(TotalLength, DivCount, X: Integer): Integer;\r\nfunction GetDivStart(TotalLength, DivCount, DivNum: Integer): Integer;\r\nfunction DOWToBorl(ADOW: TTFDayOfWeek): Integer;\r\nfunction BorlToDOW(BorlDOW: Integer): TTFDayOfWeek;\r\nfunction DateToDOW(ADate: TDateTime): TTFDayOfWeek;\r\n\r\nprocedure CalcTextPos(HostRect: TRect; var TextLeft, TextTop: Integer;\r\n var TextBounds: TRect; AFont: TFont; AAngle: Integer;\r\n HAlign: TAlignment; VAlign: TJvTFVAlignment; ATxt: string);\r\n\r\nprocedure DrawAngleText(ACanvas: TCanvas; HostRect: TRect;\r\n var TextBounds: TRect; AAngle: Integer; HAlign: TAlignment;\r\n VAlign: TJvTFVAlignment; ATxt: string);\r\n\r\nfunction RectWidth(ARect: TRect): Integer;\r\nfunction RectHeight(ARect: TRect): Integer;\r\nfunction EmptyRect: TRect;\r\nfunction IsClassByName(Obj: TObject; ClassName: string): Boolean;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvTFUtils.pas $';\r\n Revision: '$Revision: 13174 $';\r\n Date: '$Date: 2011-11-20 00:13:38 +0100 (dim. 20 nov. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n JvResources;\r\n\r\nfunction ExtractYear(ADate: TDateTime): Word;\r\nvar\r\n M, D: Word;\r\nbegin\r\n DecodeDate(ADate, Result, M, D);\r\nend;\r\n\r\nfunction ExtractMonth(ADate: TDateTime): Word;\r\nvar\r\n Y, D: Word;\r\nbegin\r\n DecodeDate(ADate, Y, Result, D);\r\nend;\r\n\r\nfunction ExtractDay(ADate: TDateTime): Word;\r\nvar\r\n Y, M: Word;\r\nbegin\r\n DecodeDate(ADate, Y, M, Result);\r\nend;\r\n\r\nfunction FirstOfMonth(ADate: TDateTime): TDateTime;\r\nvar\r\n Y, M, D: Word;\r\nbegin\r\n DecodeDate(ADate, Y, M, D);\r\n Result := EncodeDate(Y, M, 1);\r\nend;\r\n\r\nfunction GetDayOfNthDOW(Year, Month, DOW, N: Word): Word;\r\nvar\r\n FirstDayDOW: Word;\r\n WorkDate: TDateTime;\r\nbegin\r\n WorkDate := EncodeDate(Year, Month, 1);\r\n FirstDayDOW := DayOfWeek(WorkDate);\r\n WorkDate := WorkDate + (DOW - FirstDayDOW);\r\n if DOW < FirstDayDOW then\r\n WorkDate := WorkDate + 7;\r\n\r\n // WorkDate is now at the first DOW\r\n // Now adjust for N\r\n WorkDate := WorkDate + (7 * (N - 1));\r\n\r\n Result := ExtractDay(WorkDate);\r\n // Finally, check to make sure WorkDate is in the given month\r\n if Trunc(EncodeDate(Year, Month, 1)) <> Trunc(FirstOfMonth(WorkDate)) then\r\n raise EJvTFDateError.CreateRes(@RsEResultDoesNotFallInMonth);\r\nend;\r\n\r\nfunction GetWeeksInMonth(Year, Month: Word; StartOfWeek: Integer): Word;\r\nvar\r\n DOW,\r\n EndOfWeek: Integer;\r\n EOM,\r\n WorkDate: TDateTime;\r\nbegin\r\n // Get the end of the week\r\n EndOfWeek := StartOfWeek;\r\n IncBorlDOW(EndOfWeek, -1);\r\n\r\n // Start working at the first of the month\r\n WorkDate := EncodeDate(Year, Month, 1);\r\n\r\n // Get the end of the month\r\n EOM := EndOfMonth(WorkDate);\r\n\r\n // Get the day the first falls on\r\n DOW := DayOfWeek(WorkDate);\r\n\r\n // Advance WorkDate to the end of the week\r\n while DOW <> EndOfWeek do\r\n begin\r\n IncBorlDOW(DOW, 1);\r\n WorkDate := WorkDate + 1;\r\n end;\r\n\r\n // We're now on week 1\r\n Result := 1;\r\n // Now roll through the rest of the month\r\n while Trunc(WorkDate) < Trunc(EOM) do\r\n begin\r\n Inc(Result);\r\n IncWeeks(WorkDate, 1);\r\n end;\r\nend;\r\n\r\nprocedure IncBorlDOW(var BorlDOW: Integer; N: Integer); // N defaults to 1\r\nbegin\r\n BorlDOW := (BorlDOW + (N mod 7)) mod 7;\r\n if BorlDOW = 0 then\r\n BorlDOW := 7;\r\n BorlDOW := Abs(BorlDOW);\r\nend;\r\n\r\nprocedure IncDOW(var DOW: TTFDayOfWeek; N: Integer);\r\n // N defaults to 1\r\nvar\r\n BorlDOW: Integer;\r\nbegin\r\n BorlDOW := DOWToBorl(DOW);\r\n IncBorlDOW(BorlDOW, N);\r\n DOW := BorlToDOW(BorlDOW);\r\nend;\r\n\r\nprocedure IncDays(var ADate: TDateTime; N: Integer);\r\n // N defaults to 1\r\nbegin\r\n ADate := ADate + N;\r\nend;\r\n\r\nprocedure IncWeeks(var ADate: TDateTime; N: Integer);\r\n // N defaults to 1\r\nbegin\r\n ADate := ADate + N * 7;\r\nend;\r\n\r\nprocedure IncMonths(var ADate: TDateTime; N: Integer);\r\n // N defaults to 1\r\nvar\r\n Y, M, D, EOMD: Word;\r\n X : Cardinal;\r\nbegin\r\n DecodeDate(ADate, Y, M, D);\r\n X := ((Y * 12) + M - 1 + N);\r\n Y := X div 12;\r\n M := (X mod 12) + 1;\r\n\r\n // Be careful not to get invalid date in Feb.\r\n if M = 2 then\r\n begin\r\n EOMD := ExtractDay(EndOfMonth(EncodeDate(Y, M, 1)));\r\n if D > EOMD then\r\n D := EOMD;\r\n end;\r\n\r\n ADate := EncodeDate(Y, M, D);\r\nend;\r\n\r\nprocedure IncYears(var ADate: TDateTime; N: Integer);\r\n // N defaults to 1\r\nvar\r\n Y, M, D, EOMD: Word;\r\nbegin\r\n DecodeDate(ADate, Y, M, D);\r\n Inc(Y, N);\r\n\r\n // Be careful not to get invalid date in Feb.\r\n if M = 2 then\r\n begin\r\n EOMD := ExtractDay(EndOfMonth(EncodeDate(Y, M, 1)));\r\n if D > EOMD then\r\n D := EOMD;\r\n end;\r\n\r\n ADate := EncodeDate(Y, M, D);\r\nend;\r\n\r\nfunction EndOfMonth(ADate: TDateTime): TDateTime;\r\nvar\r\n Y, M, D: Word;\r\nbegin\r\n DecodeDate(ADate, Y, M, D);\r\n Inc(M);\r\n if M > 12 then\r\n begin\r\n M := 1;\r\n Inc(Y);\r\n end;\r\n Result := EncodeDate(Y, M, 1) - 1;\r\nend;\r\n\r\nfunction IsFirstOfMonth(ADate: TDateTime): Boolean;\r\nvar\r\n Y, M, D: Word;\r\nbegin\r\n DecodeDate(ADate, Y, M, D);\r\n Result := D = 1;\r\nend;\r\n\r\nfunction IsEndOfMonth(ADate: TDateTime): Boolean;\r\nbegin\r\n Result := EqualDates(ADate, EndOfMonth(ADate));\r\nend;\r\n\r\nprocedure EnsureMonth(Month: Word);\r\nbegin\r\n if (Month < 1) or (Month > 12) then\r\n raise EJvTFDateError.CreateResFmt(@RsEInvalidMonthValue, [Month]);\r\nend;\r\n\r\nprocedure EnsureDOW(DOW: Word);\r\nbegin\r\n if (DOW < 1) or (DOW > 7) then\r\n raise EJvTFDateError.CreateResFmt(@RsEInvalidDayOfWeekValue, [DOW]);\r\nend;\r\n\r\nfunction EqualDates(D1, D2: TDateTime): Boolean;\r\nbegin\r\n Result := Trunc(D1) = Trunc(D2);\r\nend;\r\n\r\nfunction ExtractHours(ATime: TDateTime): Word;\r\nvar\r\n M, S, MS: Word;\r\nbegin\r\n DecodeTime(ATime, Result, M, S, MS);\r\nend;\r\n\r\nfunction ExtractMins(ATime: TDateTime): Word;\r\nvar\r\n H, S, MS: Word;\r\nbegin\r\n DecodeTime(ATime, H, Result, S, MS);\r\nend;\r\n\r\nfunction ExtractSecs(ATime: TDateTime): Word;\r\nvar\r\n H, M, MS: Word;\r\nbegin\r\n DecodeTime(ATime, H, M, Result, MS);\r\nend;\r\n\r\nfunction ExtractMSecs(ATime: TDateTime): Word;\r\nvar\r\n H, M, S: Word;\r\nbegin\r\n DecodeTime(ATime, H, M, S, Result);\r\nend;\r\n\r\nfunction Lesser(N1, N2: Integer): Integer;\r\nbegin\r\n if N1 < N2 then\r\n Result := N1\r\n else\r\n Result := N2;\r\nend;\r\n\r\nfunction Greater(N1, N2: Integer): Integer;\r\nbegin\r\n if N1 > N2 then\r\n Result := N1\r\n else\r\n Result := N2;\r\nend;\r\n\r\nfunction GetDivLength(TotalLength, DivCount, DivNum: Integer): Integer;\r\nbegin\r\n if (DivNum < 0) or (DivNum >= DivCount) then\r\n Result := -1\r\n else\r\n begin\r\n Result := TotalLength div DivCount;\r\n if DivNum < TotalLength mod DivCount then\r\n Inc(Result);\r\n end;\r\nend;\r\n\r\nfunction GetDivNum(TotalLength, DivCount, X: Integer): Integer;\r\nvar\r\n Base,\r\n MakeUp,\r\n MakeUpWidth: Integer;\r\nbegin\r\n if (X < 0) or (X >= TotalLength) then\r\n Result := -1\r\n else\r\n begin\r\n Base := TotalLength div DivCount;\r\n MakeUp := TotalLength mod DivCount;\r\n MakeUpWidth := MakeUp * (Base + 1);\r\n\r\n if X < MakeUpWidth then\r\n Result := X div (Base + 1)\r\n else\r\n Result := (X - MakeUpWidth) div Base + MakeUp;\r\n end;\r\nend;\r\n\r\nfunction GetDivStart(TotalLength, DivCount, DivNum: Integer): Integer;\r\nvar\r\n Base,\r\n MakeUp,\r\n MakeUpWidth: Integer;\r\nbegin\r\n if (DivNum < 0) or (DivNum >= DivCount) then\r\n Result := -1\r\n else\r\n begin\r\n Base := TotalLength div DivCount;\r\n MakeUp := TotalLength mod DivCount;\r\n MakeUpWidth := MakeUp * (Base + 1);\r\n\r\n if DivNum <= MakeUp then\r\n Result := DivNum * (Base + 1)\r\n else\r\n Result := (DivNum - MakeUp) * Base + MakeUpWidth;\r\n end;\r\nend;\r\n\r\nfunction DOWToBorl(ADOW: TTFDayOfWeek): Integer;\r\nbegin\r\n Result := Ord(ADOW) + 1;\r\nend;\r\n\r\nfunction BorlToDOW(BorlDOW: Integer): TTFDayOfWeek;\r\nbegin\r\n Result := TTFDayOfWeek(BorlDOW - 1);\r\nend;\r\n\r\nfunction DateToDOW(ADate: TDateTime): TTFDayOfWeek;\r\nvar\r\n BorlDOW: Integer;\r\nbegin\r\n BorlDOW := DayOfWeek(ADate);\r\n Result := BorlToDOW(BorlDOW);\r\nend;\r\n\r\n//////////////////////////////////////////////////////////////////\r\n// Credit for the CalcTextPos routine goes to Joerg Lingner. //\r\n// It comes from his JLLabel component (freeware - Torry's). //\r\n// It is used here with his permission. Thanks Joerg! //\r\n// He can be reached at jlingner att t-online dott de //\r\n//////////////////////////////////////////////////////////////////\r\n\r\nprocedure CalcTextPos(HostRect: TRect; var TextLeft, TextTop: Integer;\r\n var TextBounds: TRect; AFont: TFont; AAngle: Integer;\r\n HAlign: TAlignment; VAlign: TJvTFVAlignment; ATxt: string);\r\n{==========================================================================}\r\n{ Calculate text pos. depend. on: Font, Escapement, Alignment and length }\r\n{--------------------------------------------------------------------------}\r\nvar\r\n DC: HDC;\r\n hSavFont: HFONT;\r\n Size: TSize;\r\n X, Y: Integer;\r\n //cStr : array[0..255] of Char;\r\n PTxt: PChar;\r\n A, B, C, D: Integer;\r\n lb, lt, rb, rt: TPoint;\r\nbegin\r\n AAngle := AAngle div 10;\r\n\r\n PTxt := StrAlloc((Length(ATxt) + 4) * SizeOf(Char));\r\n StrPCopy(PTxt, ATxt);\r\n\r\n //StrPCopy(cStr, ATxt);\r\n DC := GetDC(HWND_DESKTOP);\r\n hSavFont := SelectObject(DC, AFont.Handle);\r\n //GetTextExtentPoint32(DC, cStr, Length(ATxt), Size);\r\n Windows.GetTextExtentPoint32(DC, PTxt, StrLen(PTxt), Size);\r\n StrDispose(PTxt);\r\n SelectObject(DC, hSavFont);\r\n ReleaseDC(HWND_DESKTOP, DC);\r\n\r\n X := 0;\r\n Y := 0;\r\n\r\n if AAngle <= 90 then\r\n begin { 1.Quadrant }\r\n X := 0;\r\n Y := Trunc(Size.cx * Sin(AAngle * Pi / 180));\r\n end\r\n else\r\n if AAngle <= 180 then\r\n begin { 2.Quadrant }\r\n X := Trunc(Size.cx * -Cos(AAngle * Pi / 180));\r\n Y := Trunc(Size.cx * Sin(AAngle * Pi / 180) + Size.cy * Cos((180 - AAngle) * Pi / 180));\r\n end\r\n else\r\n if AAngle <= 270 then\r\n begin { 3.Quadrant }\r\n X := Trunc(Size.cx * -Cos(AAngle * Pi / 180) + Size.cy * Sin((AAngle - 180) * Pi / 180));\r\n Y := Trunc(Size.cy * Sin((270 - AAngle) * Pi / 180));\r\n end\r\n else\r\n if AAngle <= 360 then\r\n begin { 4.Quadrant }\r\n X := Trunc(Size.cy * Sin((360 - AAngle) * Pi / 180));\r\n Y := 0;\r\n end;\r\n\r\n TextLeft := HostRect.Left + X;\r\n TextTop := HostRect.Top + Y;\r\n //ARect.Top := ARect.Top + Y;\r\n //ARect.Left := ARect.Left + X;\r\n\r\n X := Abs(Trunc(Size.cx * Cos(AAngle * Pi / 180))) + Abs(Trunc(Size.cy * Sin(AAngle * Pi / 180)));\r\n Y := Abs(Trunc(Size.cx * Sin(AAngle * Pi / 180))) + Abs(Trunc(Size.cy * Cos(AAngle * Pi / 180)));\r\n\r\n case HAlign of\r\n taCenter:\r\n //ARect.Left := ARect.Left + ((RectWidth(SaveRect) - X) div 2);\r\n TextLeft := TextLeft + ((RectWidth(HostRect) - X) div 2);\r\n taRightJustify:\r\n //ARect.Left := ARect.Left + RectWidth(SaveRect) - X;\r\n TextLeft := TextLeft + RectWidth(HostRect) - X;\r\n end;\r\n\r\n case VAlign of\r\n vaCenter:\r\n //ARect.Top := ARect.Top + ((RectHeight(SaveRect) - Y) div 2);\r\n TextTop := TextTop + ((RectHeight(HostRect) - Y) div 2);\r\n vaBottom:\r\n //ARect.Top := ARect.Top + RectHeight(SaveRect) - Y;\r\n TextTop := TextTop + RectHeight(HostRect) - Y;\r\n end;\r\n\r\n //ARect.Right := ARect.Left + X;\r\n //ARect.Bottom := ARect.Top + Y;\r\n//********************************************\r\n// calculate the border areas\r\n\r\n A := Trunc(Size.cy * Sin(AAngle * Pi / 180));\r\n B := Trunc(Size.cy * Cos(AAngle * Pi / 180));\r\n C := Trunc(Size.cx * Cos(AAngle * Pi / 180));\r\n D := Trunc(Size.cx * Sin(AAngle * Pi / 180));\r\n\r\n //lt := ARect.TopLeft;\r\n lt := Point(TextLeft, TextTop);\r\n lb := lt;\r\n lb.X := lb.X + A;\r\n lb.Y := lb.Y + B;\r\n rb := lb;\r\n rb.X := rb.X + C;\r\n rb.Y := rb.Y - D;\r\n rt := rb;\r\n rt.X := rt.X - A;\r\n rt.Y := rt.Y - B;\r\n\r\n TextBounds.Left := Lesser(Lesser(lt.X, lb.X), Lesser(rb.X, rt.X));\r\n TextBounds.Right := Greater(Greater(lt.X, lb.X), Greater(rb.X, rt.X));\r\n TextBounds.Top := Lesser(Lesser(lt.Y, lb.Y), Lesser(rb.Y, rt.Y));\r\n TextBounds.Bottom := Greater(Greater(lt.Y, lb.Y), Greater(rb.Y, rt.Y));\r\n//*********************************************************************************************\r\nend;\r\n\r\nprocedure DrawAngleText(ACanvas: TCanvas; HostRect: TRect;\r\n var TextBounds: TRect; AAngle: Integer; HAlign: TAlignment;\r\n VAlign: TJvTFVAlignment; ATxt: string);\r\nvar\r\n LogFont: TLogFont;\r\n TxtRect: TRect;\r\n Flags: UINT;\r\n PTxt: PChar;\r\n ClipRgn: HRgn;\r\n TextLeft,\r\n TextTop: Integer;\r\nbegin\r\n //TxtRect := ARect;\r\n //CalcTextPos(TxtRect, ACanvas.Font, AAngle, HAlign, VAlign, ATxt);\r\n CalcTextPos(HostRect, TextLeft, TextTop, TextBounds, ACanvas.Font, AAngle,\r\n HAlign, VAlign, ATxt);\r\n Windows.GetObject(ACanvas.Font.Handle, SizeOf(LogFont), @LogFont);\r\n LogFont.lfEscapement := AAngle;\r\n LogFont.lfOrientation := LogFont.lfEscapement;\r\n ACanvas.Font.Handle := CreateFontIndirect(LogFont);\r\n Flags := DT_NOPREFIX or DT_LEFT or DT_TOP or DT_NOCLIP or DT_SINGLELINE;\r\n\r\n PTxt := StrAlloc((Length(ATxt) + 4) * SizeOf(Char));\r\n StrPCopy(PTxt, ATxt);\r\n //ClipRgn := Windows.CreateRectRgn(ARect.Left, ARect.Top,\r\n // ARect.Right, ARect.Bottom);\r\n ClipRgn := Windows.CreateRectRgn(HostRect.Left, HostRect.Top,\r\n HostRect.Right, HostRect.Bottom);\r\n Windows.SelectClipRgn(ACanvas.Handle, ClipRgn);\r\n\r\n //Windows.DrawText(ACanvas.Handle, PTxt, -1, TxtRect, Flags);\r\n TxtRect := Rect(TextLeft, TextTop, TextLeft + 1, TextTop + 1);\r\n Windows.DrawText(ACanvas.Handle, PTxt, -1, TxtRect, Flags);\r\n\r\n Windows.SelectClipRgn(ACanvas.Handle, 0);\r\n Windows.DeleteObject(ClipRgn);\r\n StrDispose(PTxt);\r\n ACanvas.Font.Handle := 0;\r\n\r\n //ARect := TxtRect;\r\nend;\r\n\r\nfunction RectWidth(ARect: TRect): Integer;\r\nbegin\r\n Result := ARect.Right - ARect.Left;\r\nend;\r\n\r\nfunction RectHeight(ARect: TRect): Integer;\r\nbegin\r\n Result := ARect.Bottom - ARect.Top;\r\nend;\r\n\r\nfunction EmptyRect: TRect;\r\nbegin\r\n Result := Rect(0, 0, 0, 0);\r\nend;\r\n\r\nfunction IsClassByName(Obj: TObject; ClassName: string): Boolean;\r\nvar\r\n ClassRef: TClass;\r\nbegin\r\n Result := False;\r\n ClassRef := Obj.ClassType;\r\n while (ClassRef <> nil) and not Result do\r\n if ClassRef.ClassName = ClassName then\r\n Result := True\r\n else\r\n ClassRef := ClassRef.ClassParent;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvTFWeeks.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvTFWeeks.PAS, released on 2003-08-01.\r\n\r\nThe Initial Developer of the Original Code is Unlimited Intelligence Limited.\r\nPortions created by Unlimited Intelligence Limited are Copyright (C) 1999-2002 Unlimited Intelligence Limited.\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\nMike Kolter (original code)\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvTFWeeks.pas 13145 2011-11-02 21:15:19Z ahuser $\r\n\r\nunit JvTFWeeks;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n SysUtils, Classes, Windows, Messages, Graphics, Controls, Forms, Dialogs,\r\n JvTFManager, JvTFGlance, JvTFUtils;\r\n\r\ntype\r\n TJvTFDispOrder = (doLeftRight, doTopBottom);\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvTFWeeks = class(TJvTFCustomGlance)\r\n private\r\n FWeekCount: Integer;\r\n FDisplayDays: TTFDaysOfWeek;\r\n FSplitDay: TTFDayOfWeek;\r\n FIgnoreSplit: Boolean;\r\n FDisplayOrder: TJvTFDispOrder;\r\n FDWNames: TJvTFDWNames;\r\n FDWTitleAttr: TJvTFGlanceTitle;\r\n FOnDrawDWTitle: TJvTFDrawDWTitleEvent;\r\n FOnUpdateTitle: TJvTFUpdateTitleEvent;\r\n function GetDisplayDate: TDate;\r\n procedure SetDisplayDate(Value: TDate);\r\n procedure SetWeekCount(Value: Integer);\r\n procedure SetDisplayDays(Value: TTFDaysOfWeek);\r\n procedure SetSplitDay(Value: TTFDayOfWeek);\r\n procedure SetIgnoreSplit(Value: Boolean);\r\n procedure SetDisplayOrder(Value: TJvTFDispOrder);\r\n procedure SetDWNames(Value: TJvTFDWNames);\r\n procedure SetDWTitleAttr(Value: TJvTFGlanceTitle);\r\n protected\r\n procedure ConfigCells; override;\r\n procedure SetStartOfWeek(Value: TTFDayOfWeek); override;\r\n procedure DWNamesChange(Sender: TObject);\r\n procedure Navigate(AControl: TJvTFControl; SchedNames: TStringList;\r\n Dates: TJvTFDateList); override;\r\n\r\n function GetSplitParentDay: TTFDayOfWeek;\r\n function GetCellTitleText(Cell: TJvTFGlanceCell): string; override;\r\n\r\n // draws the DW Titles\r\n procedure DrawTitle(ACanvas: TCanvas); override;\r\n procedure UpdateTitle;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n function GetDataTop: Integer; override;\r\n function DisplayDayCount: Integer;\r\n procedure PrevWeek;\r\n procedure NextWeek;\r\n published\r\n property DisplayDate: TDate read GetDisplayDate write SetDisplayDate;\r\n property DisplayDays: TTFDaysOfWeek read FDisplayDays write SetDisplayDays\r\n default [dowSunday..dowSaturday];\r\n property DisplayOrder: TJvTFDispOrder read FDisplayOrder write SetDisplayOrder;\r\n property DWNames: TJvTFDWNames read FDWNames write SetDWNames;\r\n property DWTitleAttr: TJvTFGlanceTitle read FDWTitleAttr write SetDWTitleAttr;\r\n property IgnoreSplit: Boolean read FIgnoreSplit write SetIgnoreSplit default False;\r\n property SplitDay: TTFDayOfWeek read FSplitDay write SetSplitDay default dowSunday;\r\n property WeekCount: Integer read FWeekCount write SetWeekCount default 1;\r\n property OnDrawDWTitle: TJvTFDrawDWTitleEvent read FOnDrawDWTitle write FOnDrawDWTitle;\r\n property OnUpdateTitle: TJvTFUpdateTitleEvent read FOnUpdateTitle write FOnUpdateTitle;\r\n property StartOfWeek default dowMonday;\r\n// property Navigator;\r\n// property OnNavigate;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvTFWeeks.pas $';\r\n Revision: '$Revision: 13145 $';\r\n Date: '$Date: 2011-11-02 22:15:19 +0100 (mer. 02 nov. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n JvResources;\r\n\r\nprocedure TJvTFWeeks.ConfigCells;\r\nvar\r\n Row, Col, CalcRowCount: Integer;\r\n CurrDate: TDateTime;\r\n DayToSplit: TTFDayOfWeek;\r\n CanSplit: Boolean;\r\n\r\n procedure DisplayDateCheck;\r\n begin\r\n while not (DateToDOW(CurrDate) in DisplayDays) do\r\n IncDays(CurrDate, 1);\r\n end;\r\n\r\n procedure ConfigCell(ACell: TJvTFGlanceCell);\r\n var\r\n TestDay: TTFDayOfWeek;\r\n begin\r\n DisplayDateCheck;\r\n SetCellDate(ACell, CurrDate);\r\n TestDay := DateToDOW(CurrDate);\r\n IncDays(CurrDate, 1);\r\n\r\n if (TestDay = DayToSplit) and (SplitDay in DisplayDays) and CanSplit then\r\n begin\r\n SplitCell(ACell);\r\n DisplayDateCheck;\r\n SetCellDate(ACell.Subcell, CurrDate);\r\n IncDays(CurrDate, 1);\r\n end\r\n else\r\n CombineCell(ACell);\r\n end;\r\n\r\nbegin\r\n if WeekCount = 1 then\r\n begin\r\n ColCount := 2;\r\n\r\n CalcRowCount := DisplayDayCount;\r\n if Odd(CalcRowCount) and not (SplitDay in DisplayDays) then\r\n Inc(CalcRowCount);\r\n RowCount := CalcRowCount div 2;\r\n\r\n CanSplit := not IgnoreSplit and Odd(DisplayDayCount);\r\n end\r\n else\r\n begin\r\n if not IgnoreSplit and (SplitDay in DisplayDays) then\r\n ColCount := DisplayDayCount - 1\r\n else\r\n ColCount := DisplayDayCount;\r\n RowCount := WeekCount;\r\n CanSplit := not IgnoreSplit;\r\n end;\r\n\r\n DayToSplit := GetSplitParentDay;\r\n\r\n CurrDate := OriginDate;\r\n if DisplayOrder = doLeftRight then\r\n for Row := 0 to RowCount - 1 do\r\n for Col := 0 to ColCount - 1 do\r\n ConfigCell(Cells.Cells[Col, Row])\r\n else\r\n for Col := 0 to ColCount - 1 do\r\n for Row := 0 to RowCount - 1 do\r\n ConfigCell(Cells.Cells[Col, Row]);\r\n\r\n inherited ConfigCells;\r\nend;\r\n\r\nconstructor TJvTFWeeks.Create(AOwner: TComponent);\r\nbegin\r\n FWeekCount := 1;\r\n FDisplayDays := DOW_WEEK;\r\n FSplitDay := dowSunday;\r\n FIgnoreSplit := False;\r\n\r\n inherited Create(AOwner);\r\n\r\n GapSize := 4;\r\n CellAttr.TitleAttr.Color := clWhite;\r\n CellAttr.TitleAttr.FrameAttr.Color := clGray;\r\n\r\n FDWNames := TJvTFDWNames.Create;\r\n FDWNames.OnChange := DWNamesChange;\r\n\r\n FDWTitleAttr := TJvTFGlanceTitle.Create(Self);\r\n with FDWTitleAttr do\r\n begin\r\n Assign(TitleAttr);\r\n TxtAttr.Font.Size := 8;\r\n Height := 20;\r\n OnChange := GlanceTitleChange;\r\n end;\r\n\r\n StartOfWeek := dowMonday;\r\n DisplayDate := Date;\r\nend;\r\n\r\ndestructor TJvTFWeeks.Destroy;\r\nbegin\r\n FDWNames.OnChange := nil;\r\n FDWNames.Free;\r\n FDWTitleAttr.OnChange := nil;\r\n FDWTitleAttr.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJvTFWeeks.DisplayDayCount: Integer;\r\nvar\r\n DOW: TTFDayOfWeek;\r\nbegin\r\n Result := 0;\r\n for DOW := Low(TTFDayOfWeek) to High(TTFDayOfWeek) do\r\n if DOW in DisplayDays then\r\n Inc(Result);\r\nend;\r\n\r\nprocedure TJvTFWeeks.DrawTitle(ACanvas: TCanvas);\r\nvar\r\n I, Col, LineBottom: Integer;\r\n SplitParentDay, CurrDOW: TTFDayOfWeek;\r\n ARect, TempRect, TxtRect, TextBounds: TRect;\r\n OldPen: TPen;\r\n OldBrush: TBrush;\r\n OldFont: TFont;\r\n Txt: string;\r\n\r\n procedure CheckCurrDOW;\r\n begin\r\n while not (CurrDOW in DisplayDays) do\r\n IncDOW(CurrDOW, 1);\r\n end;\r\n\r\nbegin\r\n inherited DrawTitle(ACanvas);\r\n\r\n // Don't draw the DW Titles if we're only showing one week.\r\n if not DWTitleAttr.Visible or (WeekCount = 1) then\r\n Exit;\r\n\r\n with ACanvas do\r\n begin\r\n OldPen := TPen.Create;\r\n OldPen.Assign(Pen);\r\n OldBrush := TBrush.Create;\r\n OldBrush.Assign(Brush);\r\n OldFont := TFont.Create;\r\n OldFont.Assign(Font);\r\n end;\r\n\r\n // draw the DWTitles\r\n ARect.Top := inherited GetDataTop;\r\n ARect.Bottom := GetDataTop;\r\n\r\n CurrDOW := StartOfWeek;\r\n SplitParentDay := GetSplitParentDay;\r\n\r\n for Col := 0 to ColCount - 1 do\r\n begin\r\n TempRect := WholeCellRect(Col, 0);\r\n ARect.Left := TempRect.Left;\r\n ARect.Right := TempRect.Right;\r\n TxtRect := ARect;\r\n Windows.InflateRect(TxtRect, -1, -1);\r\n\r\n with ACanvas do\r\n begin\r\n Brush.Color := DWTitleAttr.Color;\r\n FillRect(ARect);\r\n\r\n case DWTitleAttr.FrameAttr.Style of\r\n fs3DRaised:\r\n Draw3DFrame(ACanvas, ARect, clBtnHighlight, clBtnShadow);\r\n fs3DLowered:\r\n Draw3DFrame(ACanvas, ARect, clBtnShadow, clBtnHighlight);\r\n fsFlat:\r\n begin\r\n Pen.Color := DWTitleAttr.FrameAttr.Color;\r\n Pen.Width := DWTitleAttr.FrameAttr.Width;\r\n if Col = 0 then\r\n begin\r\n MoveTo(ARect.Left, ARect.Top);\r\n LineTo(ARect.Left, ARect.Bottom);\r\n end;\r\n Polyline([Point(ARect.Right - 1, ARect.Top),\r\n Point(ARect.Right - 1, ARect.Bottom - 1),\r\n Point(ARect.Left - 1, ARect.Bottom - 1)]);\r\n end;\r\n fsNone:\r\n begin\r\n Pen.Color := DWTitleAttr.FrameAttr.Color;\r\n Pen.Width := 1;\r\n LineBottom := ARect.Bottom - 1;\r\n for I := 1 to DWTitleAttr.FrameAttr.Width do\r\n begin\r\n MoveTo(ARect.Left, LineBottom);\r\n LineTo(ARect.Right, LineBottom);\r\n Dec(LineBottom);\r\n end;\r\n end;\r\n end;\r\n\r\n CheckCurrDOW;\r\n Txt := DWNames.GetDWName(DOWToBorl(CurrDOW));\r\n\r\n if (CurrDOW = SplitParentDay) and (SplitDay in DisplayDays) and not IgnoreSplit then\r\n begin\r\n IncDOW(CurrDOW, 1);\r\n CheckCurrDOW;\r\n Txt := Txt + '/' + DWNames.GetDWName(DOWToBorl(CurrDOW));\r\n end;\r\n\r\n Font := DWTitleAttr.TxtAttr.Font;\r\n DrawAngleText(ACanvas, TxtRect, TextBounds,\r\n DWTitleAttr.TxtAttr.Rotation,\r\n DWTitleAttr.TxtAttr.AlignH,\r\n DWTitleAttr.TxtAttr.AlignV, Txt);\r\n end;\r\n\r\n if Assigned(FOnDrawDWTitle) then\r\n FOnDrawDWTitle(Self, ACanvas, ARect, CurrDOW, Txt);\r\n\r\n IncDOW(CurrDOW, 1);\r\n end;\r\n\r\n with ACanvas do\r\n begin\r\n Pen.Assign(OldPen);\r\n Brush.Assign(OldBrush);\r\n Font.Assign(OldFont);\r\n OldPen.Free;\r\n OldBrush.Free;\r\n OldFont.Free;\r\n end;\r\nend;\r\n\r\nprocedure TJvTFWeeks.DWNamesChange(Sender: TObject);\r\nbegin\r\n UpdateCellTitles;\r\n Invalidate;\r\nend;\r\n\r\nfunction TJvTFWeeks.GetCellTitleText(Cell: TJvTFGlanceCell): string;\r\nbegin\r\n Result := '';\r\n //Result := FormatDateTime('dddd, mmm d', Cell.CellDate);\r\n if Assigned(DWNames) then\r\n begin\r\n if WeekCount = 1 then\r\n Result := DWNames.GetDWName(DayOfWeek(Cell.CellDate)) + ', ';\r\n if DateFormat = '' then\r\n Result := Result + FormatDateTime('mmm d', Cell.CellDate)\r\n else\r\n Result := Result + FormatDateTime(DateFormat, Cell.CellDate);\r\n end\r\n else\r\n Result := FormatDateTime(DateFormat, Cell.CellDate);\r\nend;\r\n\r\nfunction TJvTFWeeks.GetDataTop: Integer;\r\nbegin\r\n Result := inherited GetDataTop;\r\n if DWTitleAttr.Visible and (WeekCount > 1) then\r\n Inc(Result, DWTitleAttr.Height);\r\nend;\r\n\r\nfunction TJvTFWeeks.GetDisplayDate: TDate;\r\nbegin\r\n Result := StartDate;\r\nend;\r\n\r\nfunction TJvTFWeeks.GetSplitParentDay: TTFDayOfWeek;\r\nbegin\r\n Result := SplitDay;\r\n IncDOW(Result, -1);\r\n while not (Result in DisplayDays) and (Result <> SplitDay) do\r\n IncDOW(Result, -1);\r\nend;\r\n\r\nprocedure TJvTFWeeks.Navigate(AControl: TJvTFControl;\r\n SchedNames: TStringList; Dates: TJvTFDateList);\r\nbegin\r\n inherited Navigate(AControl, SchedNames, Dates);\r\n if Dates.Count > 0 then\r\n DisplayDate := Dates[0];\r\nend;\r\n\r\nprocedure TJvTFWeeks.NextWeek;\r\nbegin\r\n DisplayDate := DisplayDate + 7;\r\nend;\r\n\r\nprocedure TJvTFWeeks.PrevWeek;\r\nbegin\r\n DisplayDate := DisplayDate - 7;\r\nend;\r\n\r\nprocedure TJvTFWeeks.SetDisplayDate(Value: TDate);\r\nbegin\r\n StartDate := Value;\r\n UpdateTitle;\r\nend;\r\n\r\nprocedure TJvTFWeeks.SetDisplayDays(Value: TTFDaysOfWeek);\r\nbegin\r\n if Value = [] then\r\n Exit;\r\n\r\n if Value <> FDisplayDays then\r\n begin\r\n FDisplayDays := Value;\r\n ReconfigCells;\r\n end;\r\nend;\r\n\r\nprocedure TJvTFWeeks.SetDisplayOrder(Value: TJvTFDispOrder);\r\nbegin\r\n if WeekCount > 1 then\r\n Value := doLeftRight;\r\n\r\n if Value <> FDisplayOrder then\r\n begin\r\n FDisplayOrder := Value;\r\n ReconfigCells;\r\n end;\r\nend;\r\n\r\nprocedure TJvTFWeeks.SetDWNames(Value: TJvTFDWNames);\r\nbegin\r\n FDWNames.Assign(Value);\r\nend;\r\n\r\nprocedure TJvTFWeeks.SetDWTitleAttr(Value: TJvTFGlanceTitle);\r\nbegin\r\n FDWTitleAttr.Assign(Value);\r\nend;\r\n\r\nprocedure TJvTFWeeks.SetIgnoreSplit(Value: Boolean);\r\nbegin\r\n if Value <> FIgnoreSplit then\r\n begin\r\n FIgnoreSplit := Value;\r\n ReconfigCells;\r\n end;\r\nend;\r\n\r\nprocedure TJvTFWeeks.SetSplitDay(Value: TTFDayOfWeek);\r\nbegin\r\n if Value <> FSplitDay then\r\n begin\r\n FSplitDay := Value;\r\n ReconfigCells;\r\n end;\r\nend;\r\n\r\nprocedure TJvTFWeeks.SetStartOfWeek(Value: TTFDayOfWeek);\r\nbegin\r\n if not IgnoreSplit and (Value = SplitDay) then\r\n IncDOW(Value, -1);\r\n inherited SetStartOfWeek(Value);\r\nend;\r\n\r\nprocedure TJvTFWeeks.SetWeekCount(Value: Integer);\r\nbegin\r\n Value := Greater(Value, 1);\r\n if Value <> FWeekCount then\r\n begin\r\n DisplayOrder := doLeftRight;\r\n FWeekCount := Value;\r\n ReconfigCells;\r\n end;\r\nend;\r\n\r\nprocedure TJvTFWeeks.UpdateTitle;\r\nvar\r\n NewTitle: string;\r\nbegin\r\n NewTitle := Format(RsWeekOf, [FormatDateTime('mmm d, yyyy', OriginDate)]);\r\n if NewTitle <> TitleAttr.Title then\r\n begin\r\n if Assigned(FOnUpdateTitle) then\r\n FOnUpdateTitle(Self, NewTitle);\r\n TitleAttr.Title := NewTitle;\r\n end;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvTMTimeLine.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvTMTimeLine.PAS, released on 2002-05-26.\r\n\r\nThe Initial Developer of the Original Code is Peter Thrnqvist [peter3 at sourceforge dot net]\r\nPortions created by Peter Thrnqvist are Copyright (C) 2002 Peter Thrnqvist.\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nDescription:\r\n A component that mimicks the time line in MS Team Manager\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvTMTimeLine.pas 13104 2011-09-07 06:50:43Z obones $\r\n\r\nunit JvTMTimeLine;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n SysUtils, Classes,\r\n Windows, Messages, Controls, Buttons, Graphics, ExtCtrls, Forms, ImgList,\r\n {$IFDEF BCB}\r\n JvTypes, // TDate / TTime macros\r\n {$ENDIF BCB}\r\n JvExtComponent, JvExControls;\r\n\r\ntype\r\n TJvTLSelFrame = class(TPersistent)\r\n private\r\n FVisible: Boolean;\r\n FPen: TPen;\r\n FOnChange: TNotifyEvent;\r\n procedure SetPen(const Value: TPen);\r\n procedure SetVisible(const Value: Boolean);\r\n procedure PenChange(Sender: TObject);\r\n protected\r\n procedure DoChange; virtual;\r\n public\r\n constructor Create;\r\n destructor Destroy; override;\r\n procedure Assign(Source: TPersistent); override;\r\n published\r\n property Pen: TPen read FPen write SetPen;\r\n property Visible: Boolean read FVisible write SetVisible default True;\r\n property OnChange: TNotifyEvent read FOnChange write FOnChange;\r\n end;\r\n\r\n TJvBtnDown = (bdNone, bdLeft, bdRight);\r\n TJvObjectReadEvent = procedure(Sender: TObject; Stream: TStream; var AObject: TObject) of object;\r\n TJvObjectWriteEvent = procedure(Sender: TObject; Stream: TStream; const AObject: TObject) of object;\r\n\r\n TJvCustomTMTimeline = class(TJvCustomPanel)\r\n private\r\n FTimer: TTimer;\r\n FImages: TImageList;\r\n FChangeLink: TChangeLink;\r\n FDateImages: TStringlist;\r\n FObjects: TStringlist;\r\n FLeftBtn: TSpeedButton;\r\n FRightBtn: TSpeedButton;\r\n FMonthFont: TFont;\r\n FBtnDown: TJvBtnDown;\r\n FReadOnly: Boolean;\r\n FRightClickSelect: Boolean;\r\n FDayWidth: Integer;\r\n FButtonWidth: Integer;\r\n FDate: TDate;\r\n FSelDate: TDate;\r\n FMinDate: TDate;\r\n FMaxDate: TDate;\r\n FImageCursor: TCursor;\r\n FRealCursor: TCursor;\r\n FTodayColor: TColor;\r\n FSelection: TJvTLSelFrame;\r\n FOnChange: TNotifyEvent;\r\n FLargeChange: Word;\r\n FSmallChange: Word;\r\n FOnWriteObject: TJvObjectWriteEvent;\r\n FOnReadObject: TJvObjectReadEvent;\r\n FObjectsFontStyle: TFontStyles;\r\n FShowWeeks: Boolean;\r\n FShowMonths: Boolean;\r\n FShowToday: Boolean;\r\n FLineColor: TColor;\r\n FShift: TShiftState;\r\n FShowTodayIcon: Boolean;\r\n function GetRectForDate(ADate: TDate): TRect;\r\n function DateFromPos(APos: Integer): TDate;\r\n procedure DoTimer(Sender: TObject);\r\n procedure SetFirstDate(const Value: TDate);\r\n procedure SetReadOnly(const Value: Boolean);\r\n procedure SetMonthFont(const Value: TFont);\r\n procedure SetSelDate(const Value: TDate);\r\n procedure SetDayWidth(const Value: Integer);\r\n function GetBorderStyle: TBorderStyle;\r\n procedure SetBorderStyle(const Value: TBorderStyle);\r\n procedure SetImages(const Value: TImageList);\r\n procedure DoChange(Sender: TObject);\r\n function GetImageIndex(ADate: TDate): Integer;\r\n procedure SetImageIndex(ADate: TDate; const Value: Integer);\r\n procedure DrawDates(ACanvas: TCanvas);\r\n procedure DrawSelectionFrame(ACanvas: TCanvas; ARect: TRect);\r\n procedure DrawImage(ACanvas: TCanvas; ADate: TDate; const ARect: TRect);\r\n procedure DrawToday(ACanvas: TCanvas; const ARect: TRect);\r\n procedure SetImageCursor(const Value: TCursor);\r\n procedure SetSelection(const Value: TJvTLSelFrame);\r\n procedure DoLMouseDown(Sender: TObject; Button: TMouseButton;\r\n Shift: TShiftState; X, Y: Integer);\r\n procedure DoMouseUp(Sender: TObject; Button: TMouseButton;\r\n Shift: TShiftState; X, Y: Integer);\r\n procedure DoRMouseDown(Sender: TObject; Button: TMouseButton;\r\n Shift: TShiftState; X, Y: Integer);\r\n // this is needed so we receive the arrow keys\r\n\r\n procedure DrawFrame(ACanvas: TCanvas; AColor: TColor;\r\n ALineWidth: Integer; ARect: TRect);\r\n procedure SetTodayColor(const Value: TColor);\r\n procedure SetLineColor(const Value: TColor);\r\n procedure SetRightClickSelect(const Value: Boolean);\r\n procedure SetMaxDate(const Value: TDate);\r\n procedure SetMinDate(const Value: TDate);\r\n procedure SetLargeChange(const Value: Word);\r\n procedure SetSmallChange(const Value: Word);\r\n function GetObjects(ADate: TDate): TObject;\r\n procedure SetObjects(ADate: TDate; const Value: TObject);\r\n procedure SetButtonWidth(const Value: Integer);\r\n procedure SetObjectsFontStyle(const Value: TFontStyles);\r\n procedure SetShowMonths(const Value: Boolean);\r\n procedure SetShowToday(const Value: Boolean);\r\n procedure SetShowWeeks(const Value: Boolean);\r\n function ReadMagic(Stream: TStream): Boolean;\r\n procedure StartTimer;\r\n procedure StopTimer;\r\n function DateHasImage(ADate: TDateTime): Boolean;\r\n procedure SetShowTodayIcon(const Value: Boolean);\r\n protected\r\n procedure GetDlgCode(var Code: TDlgCodes); override;\r\n procedure CursorChanged; override;\r\n procedure EnabledChanged; override;\r\n procedure Paint; override;\r\n function DoMouseWheelDown(Shift: TShiftState; MousePos: TPoint): Boolean; override;\r\n function DoMouseWheelUp(Shift: TShiftState; MousePos: TPoint): Boolean; override;\r\n procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;\r\n procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;\r\n procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;\r\n procedure KeyDown(var Key: Word; Shift: TShiftState); override;\r\n\r\n procedure Notification(AComponent: TComponent; Operation: TOperation); override;\r\n procedure Change; virtual;\r\n procedure LoadObject(Stream: TStream; var AObject: TObject); virtual;\r\n procedure SaveObject(Stream: TStream; const AObject: TObject); virtual;\r\n function GetLastVisibleDate: TDate;\r\n function GetVisibleDays: Integer;\r\n\r\n property BorderStyle: TBorderStyle read GetBorderStyle write SetBorderStyle;\r\n property ButtonWidth: Integer read FButtonWidth write SetButtonWidth default 12;\r\n property Cursor;\r\n property DayWidth: Integer read FDayWidth write SetDayWidth default 19;\r\n property ObjectsFontStyle: TFontStyles read FObjectsFontStyle write SetObjectsFontStyle default [fsUnderline];\r\n property ImageCursor: TCursor read FImageCursor write SetImageCursor default crHandPoint;\r\n property Images: TImageList read FImages write SetImages;\r\n property LargeChange: Word read FLargeChange write SetLargeChange default 30;\r\n property Date: TDate read FDate write SetFirstDate;\r\n property SelDate: TDate read FSelDate write SetSelDate;\r\n property MaxDate: TDate read FMaxDate write SetMaxDate;\r\n property MinDate: TDate read FMinDate write SetMinDate;\r\n property MonthFont: TFont read FMonthFont write SetMonthFont;\r\n property ReadOnly: Boolean read FReadOnly write SetReadOnly;\r\n property RightClickSelect: Boolean read FRightClickSelect write SetRightClickSelect;\r\n property SmallChange: Word read FSmallChange write SetSmallChange default 7;\r\n property Selection: TJvTLSelFrame read FSelection write SetSelection;\r\n property TodayColor: TColor read FTodayColor write SetTodayColor default clAqua;\r\n property LineColor: TColor read FLineColor write SetLineColor default clBlack;\r\n property ShowToday: Boolean read FShowToday write SetShowToday default True;\r\n property ShowTodayIcon: Boolean read FShowTodayIcon write SetShowTodayIcon default True;\r\n property ShowWeeks: Boolean read FShowWeeks write SetShowWeeks default True;\r\n property ShowMonths: Boolean read FShowMonths write SetShowMonths default True;\r\n property LastVisibleDate: TDate read GetLastVisibleDate;\r\n property VisibleDays: Integer read GetVisibleDays;\r\n property Height default 56;\r\n property Color default clWindow;\r\n property RightButton: TSpeedButton read FRightBtn;\r\n property LeftButton: TSpeedButton read FLeftBtn;\r\n property OnChange: TNotifyEvent read FOnChange write FOnChange;\r\n property OnReadObject: TJvObjectReadEvent read FOnReadObject write FOnReadObject;\r\n property OnWriteObject: TJvObjectWriteEvent read FOnWriteObject write FOnWriteObject;\r\n property Align default alTop;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n // this procedure resets all imageindexes to -1\r\n procedure ClearImages;\r\n // this procedure frees all the objects in the Objects array\r\n procedure ClearObjects;\r\n // scrools the display Delta number of days. Delta can be either negative or positive\r\n procedure ScrollDate(Sender: TObject; Delta: Integer);\r\n // this procedure loads data from a stream and calls the OnReadObject event\r\n procedure LoadFromStream(Stream: TStream);\r\n // this procedure saves data to a stream and calls the OnWriteObject event\r\n procedure SaveToStream(Stream: TStream);\r\n procedure LoadFromFile(const Filename: string);\r\n procedure SaveToFile(const Filename: string);\r\n // gets / sets the imageindex for a specific date\r\n property ImageIndex[ADate: TDate]: Integer read GetImageIndex write SetImageIndex;\r\n // gets / sets the TObject for a specific date\r\n property Objects[ADate: TDate]: TObject read GetObjects write SetObjects;\r\n end;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvTMTimeline = class(TJvCustomTMTimeline)\r\n public\r\n property RightButton;\r\n property LeftButton;\r\n published\r\n // gets / sets the borderstyle of the control and the scroll-buttons\r\n property BorderStyle;\r\n // gets / sets the width of the buttons\r\n property ButtonWidth;\r\n // gets / sets the selected date\r\n property SelDate;\r\n // gets / sets the width of each day\r\n property DayWidth;\r\n // gets / sets the cursor to use when a date has an image associated\r\n property ImageCursor;\r\n // sets / gets the imagelist associated with the control\r\n property Images;\r\n // sets the interval for large changes (ctrl+click or ctrl+arrows)\r\n property LargeChange;\r\n // gets / sets the first visible date on the left edge\r\n // OnChange is called when this date changes\r\n property Date;\r\n // sets the maximum date that users can scroll to\r\n property MaxDate;\r\n // sets the minimum date that users can scroll to\r\n property MinDate;\r\n // gets / sets the font used for the month display\r\n property MonthFont;\r\n // gets / sets the fontstyle for Objects that are non-nil\r\n property ObjectsFontStyle;\r\n property ReadOnly;\r\n // gets / sets whether a right-click changes the Date property and moves the selection frame\r\n property RightClickSelect;\r\n // sets the interval for small changes (left-click or arrows)\r\n property SmallChange;\r\n // gets / sets the properties for the selection frame\r\n property Selection;\r\n // displays todays date in a different color\r\n property ShowToday;\r\n // displays todays date with a double-diamond icon\r\n property ShowTodayIcon;\r\n // shows / hides the dotted week separator\r\n property ShowWeeks;\r\n // shows the month separator line\r\n property ShowMonths;\r\n // gets / sets the background color for the today item\r\n property TodayColor;\r\n // gets / sets color of lines (dotted and solid)\r\n property LineColor;\r\n // this returns the date of the last fully visible date in the control\r\n property LastVisibleDate;\r\n // this returns the number of fully visible days in the control\r\n property VisibleDays;\r\n property Action;\r\n property Align default alTop;\r\n property Anchors;\r\n property Constraints;\r\n property Cursor;\r\n property Enabled;\r\n property Font;\r\n property Height;\r\n property Hint;\r\n property ParentColor;\r\n property ParentFont;\r\n property ParentShowHint;\r\n property PopupMenu;\r\n property ShowHint;\r\n property TabOrder;\r\n property TabStop;\r\n property Color;\r\n // triggered when the display is scrolled or when the left-most date changes\r\n property OnChange;\r\n // triggered when the control is clicked\r\n property OnClick;\r\n property OnContextPopup;\r\n property OnDblClick;\r\n property OnDragDrop;\r\n property OnDragOver;\r\n property OnEndDrag;\r\n property OnEnter;\r\n property OnExit;\r\n property OnKeyDown;\r\n property OnKeyPress;\r\n property OnKeyUp;\r\n property OnMouseDown;\r\n property OnMouseMove;\r\n property OnMouseUp;\r\n // triggered for each object when reading from a file\r\n property OnReadObject;\r\n // triggered for each object when writing to a file\r\n property OnWriteObject;\r\n property OnStartDrag;\r\n property OnStartDock;\r\n property OnEndDock;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvTMTimeLine.pas $';\r\n Revision: '$Revision: 13104 $';\r\n Date: '$Date: 2011-09-07 08:50:43 +0200 (mer. 07 sept. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n Consts,\r\n JvJCLUtils, JvJVCLUtils, JvThemes, JclSysUtils;\r\n\r\n{$R JvTMTimeLine.res}\r\n\r\nconst\r\n cMagic = 'Jv.TMTIMELINE1';\r\n\r\n//=== { TJvTLSelFrame } ======================================================\r\n\r\nconstructor TJvTLSelFrame.Create;\r\nbegin\r\n inherited Create;\r\n FPen := TPen.Create;\r\n FPen.OnChange := PenChange;\r\n FVisible := True;\r\nend;\r\n\r\ndestructor TJvTLSelFrame.Destroy;\r\nbegin\r\n FPen.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvTLSelFrame.Assign(Source: TPersistent);\r\nbegin\r\n if Source is TJvTLSelFrame then\r\n begin\r\n Pen := TJvTLSelFrame(Source).Pen;\r\n Visible := TJvTLSelFrame(Source).Visible;\r\n PenChange(Self);\r\n end\r\n else\r\n inherited Assign(Source);\r\nend;\r\n\r\nprocedure TJvTLSelFrame.PenChange(Sender: TObject);\r\nbegin\r\n DoChange;\r\nend;\r\n\r\nprocedure TJvTLSelFrame.DoChange;\r\nbegin\r\n if Assigned(FOnChange) then\r\n FOnChange(Self);\r\nend;\r\n\r\nprocedure TJvTLSelFrame.SetPen(const Value: TPen);\r\nbegin\r\n FPen.Assign(Value);\r\n DoChange;\r\nend;\r\n\r\nprocedure TJvTLSelFrame.SetVisible(const Value: Boolean);\r\nbegin\r\n if FVisible <> Value then\r\n begin\r\n FVisible := Value;\r\n DoChange;\r\n end;\r\nend;\r\n\r\n//=== { TJvCustomTMTimeline } ================================================\r\n\r\nconstructor TJvCustomTMTimeline.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n DoubleBuffered := True;\r\n ControlStyle := ControlStyle - [csSetCaption, csAcceptsControls];\r\n IncludeThemeStyle(Self, [csNeedsBorderPaint]);\r\n\r\n FSelection := TJvTLSelFrame.Create;\r\n FSelection.Pen.Width := 2;\r\n FSelection.OnChange := DoChange;\r\n\r\n FChangeLink := TChangeLink.Create;\r\n FChangeLink.OnChange := DoChange;\r\n\r\n FDateImages := TStringlist.Create;\r\n FDateImages.Sorted := True;\r\n FObjects := TStringlist.Create;\r\n FObjects.Sorted := True;\r\n\r\n FMonthFont := TFont.Create;\r\n FMonthFont.Style := [fsItalic, fsBold];\r\n FMonthFont.Name := 'Times New Roman';\r\n FMonthFont.Size := 18;\r\n\r\n FObjectsFontStyle := [fsUnderline];\r\n FButtonWidth := 12;\r\n FDate := SysUtils.Date - 7;\r\n FSelDate := FDate - 1;\r\n FDayWidth := 19;\r\n FImageCursor := crHandPoint;\r\n FSmallChange := 7;\r\n FLargeChange := 30;\r\n FTodayColor := clAqua;\r\n FLineColor := clBlack;\r\n FShowToday := True;\r\n FShowTodayIcon := True;\r\n FShowWeeks := True;\r\n FShowMonths := True;\r\n Font.Size := 7;\r\n Font.Name := 'Times New Roman';\r\n\r\n FLeftBtn := TSpeedButton.Create(Self);\r\n with FLeftBtn do\r\n begin\r\n Align := alLeft;\r\n Width := FButtonWidth;\r\n Parent := Self;\r\n Transparent := False;\r\n Layout := blGlyphTop;\r\n Glyph.LoadFromResourceName(HInstance, 'JvCustomTMTimelineSCROLLLEFT');\r\n\r\n OnMouseDown := DoLMouseDown;\r\n OnMouseUp := DoMouseUp;\r\n // OnClick := LeftClick;\r\n end;\r\n\r\n FRightBtn := TSpeedButton.Create(Self);\r\n with FRightBtn do\r\n begin\r\n Align := alRight;\r\n Width := FButtonWidth;\r\n Parent := Self;\r\n Transparent := False;\r\n Layout := blGlyphTop;\r\n Glyph.LoadFromResourceName(HInstance, 'JvCustomTMTimelineSCROLLRIGHT');\r\n\r\n OnMouseDown := DoRMouseDown;\r\n OnMouseUp := DoMouseUp;\r\n end;\r\n FLeftBtn.SetSubComponent(True);\r\n FRightBtn.SetSubComponent(True);\r\n Height := 56;\r\n BevelInner := bvNone;\r\n BevelOuter := bvNone;\r\n Color := clWindow;\r\n Align := alTop;\r\n BorderStyle := bsSingle;\r\nend;\r\n\r\ndestructor TJvCustomTMTimeline.Destroy;\r\nbegin\r\n FChangeLink.Free;\r\n FMonthFont.Free;\r\n FSelection.Free;\r\n FDateImages.Free;\r\n FObjects.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvCustomTMTimeline.StartTimer;\r\nbegin\r\n if not Assigned(FTimer) then\r\n begin\r\n FTimer := TTimer.Create(Self);\r\n FTimer.OnTimer := DoTimer;\r\n FTimer.Interval := 400;\r\n end;\r\n FTimer.Enabled := True;\r\nend;\r\n\r\nprocedure TJvCustomTMTimeline.StopTimer;\r\nbegin\r\n FTimer.Free;\r\n FTimer := nil;\r\nend;\r\n\r\nprocedure TJvCustomTMTimeline.DoLMouseDown(Sender: TObject; Button: TMouseButton;\r\n Shift: TShiftState; X, Y: Integer);\r\nbegin\r\n if Button = mbRight then\r\n Exit;\r\n if ssCtrl in Shift then\r\n ScrollDate(Sender, -LargeChange)\r\n else\r\n ScrollDate(Sender, -SmallChange);\r\n FBtnDown := bdLeft;\r\n FShift := Shift;\r\n StartTimer;\r\nend;\r\n\r\nprocedure TJvCustomTMTimeline.DoRMouseDown(Sender: TObject; Button: TMouseButton;\r\n Shift: TShiftState; X, Y: Integer);\r\nbegin\r\n if Button = mbRight then\r\n Exit;\r\n if ssCtrl in Shift then\r\n ScrollDate(Sender, LargeChange)\r\n else\r\n ScrollDate(Sender, SmallChange);\r\n FShift := Shift;\r\n FBtnDown := bdRight;\r\n StartTimer;\r\nend;\r\n\r\nprocedure TJvCustomTMTimeline.DoMouseUp(Sender: TObject; Button: TMouseButton;\r\n Shift: TShiftState; X, Y: Integer);\r\nbegin\r\n FBtnDown := bdNone;\r\n StopTimer;\r\nend;\r\n\r\nprocedure TJvCustomTMTimeline.DoTimer(Sender: TObject);\r\nbegin\r\n FTimer.Enabled := False;\r\n case FBtnDown of\r\n bdLeft:\r\n if ssCtrl in FShift then\r\n ScrollDate(Sender, -LargeChange)\r\n else\r\n ScrollDate(Sender, -SmallChange);\r\n bdRight:\r\n if ssCtrl in FShift then\r\n ScrollDate(Sender, LargeChange)\r\n else\r\n ScrollDate(Sender, SmallChange);\r\n bdNone:\r\n begin\r\n FTimer.Interval := 400;\r\n Exit;\r\n end;\r\n end;\r\n FTimer.Interval := 70;\r\n FTimer.Enabled := True;\r\nend;\r\n\r\nprocedure TJvCustomTMTimeline.DoChange(Sender: TObject);\r\nbegin\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvCustomTMTimeline.ScrollDate(Sender: TObject; Delta: Integer);\r\nbegin\r\n Delta := Trunc(Self.Date + Delta);\r\n if ((MinDate = 0) or (Delta > MinDate)) and\r\n ((MaxDate = 0) or (Delta < MaxDate)) then\r\n Self.Date := Delta;\r\nend;\r\n\r\nfunction TJvCustomTMTimeline.GetRectForDate(ADate: {$IFNDEF RTL200_UP}Controls.{$ENDIF ~RTL200_UP}TDate): TRect;\r\nbegin\r\n // all rects are the same size...\r\n Result := Rect(0, 0, DayWidth, ClientHeight + 1);\r\n // ...but we must move the entire rect to the correct date\r\n OffsetRect(Result, Trunc(ADate - Self.Date) * DayWidth, 0);\r\n // ...and finally compensate for the inital offset\r\n if ReadOnly then\r\n OffsetRect(Result, 1, 0) // no buttons showing\r\n else\r\n OffsetRect(Result, ButtonWidth, 0);\r\nend;\r\n\r\nfunction TJvCustomTMTimeline.DateFromPos(APos: Integer): {$IFNDEF RTL200_UP}Controls.{$ENDIF ~RTL200_UP}TDate;\r\nvar\r\n Tmp: Integer;\r\nbegin\r\n if not ReadOnly then\r\n Tmp := APos - ButtonWidth\r\n else\r\n Tmp := APos - 1;\r\n Result := Self.Date + (Tmp div FDayWidth);\r\nend;\r\n\r\nprocedure TJvCustomTMTimeline.DrawToday(ACanvas: TCanvas; const ARect: TRect);\r\nvar\r\n Tmp: TColor;\r\n Bmp: TBitmap;\r\n R: TRect;\r\nbegin\r\n if ShowTodayIcon then\r\n Bmp := TBitmap.Create\r\n else\r\n Bmp := nil;\r\n Tmp := ACanvas.Brush.Color;\r\n try\r\n if ShowTodayIcon then\r\n Bmp.LoadFromResourceName(HInstance, 'JvCustomTMTimelineMILESTONELARGE');\r\n if ShowToday then\r\n begin\r\n ACanvas.Brush.Color := FTodayColor;\r\n ACanvas.FillRect(ARect);\r\n end;\r\n if ShowTodayIcon then\r\n begin\r\n R := Rect(ARect.Left + ((ARect.Right - ARect.Left) - Bmp.Width) div 2,\r\n ARect.Top + CanvasMaxTextHeight(ACanvas) + 2,\r\n ARect.Left + ((ARect.Right - ARect.Left) - Bmp.Width) div 2 + Bmp.Width,\r\n ARect.Top + Bmp.Height + CanvasMaxTextHeight(ACanvas) + 2);\r\n(* {$IFDEF VCL}\r\n ACanvas.BrushCopy(R, Bmp, Rect(0, 0, Bmp.Width, Bmp.Height), clFuchsia);\r\n {$ENDIF VCL}\r\n {$IFDEF VisualCLX}\r\n *)\r\n Bmp.Transparent := True;\r\n ACanvas.Draw(R.Left, R.Top, Bmp);\r\n// {$ENDIF VisualCLX}\r\n end;\r\n finally\r\n ACanvas.Brush.Color := Tmp;\r\n Bmp.Free;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomTMTimeline.DrawDates(ACanvas: TCanvas);\r\nvar\r\n I, FirstOffset: Integer;\r\n Y, M, D: Word;\r\n R: TRect;\r\n Size: TSize;\r\n S: string;\r\n FTmpStyle: TFontStyles;\r\n AContinue: Boolean;\r\nbegin\r\n AContinue := True;\r\n // DoBeforeDraw(ACanvas);\r\n if not AContinue then\r\n Exit;\r\n if not ReadOnly then\r\n FirstOffset := ButtonWidth\r\n else\r\n FirstOffset := 1;\r\n // first loop: draw dates, today and images\r\n FTmpStyle := Font.Style;\r\n for I := 0 to Width div FDayWidth do\r\n begin\r\n R := GetRectForDate(Self.Date + I);\r\n if Self.Date + I = SysUtils.Date then\r\n DrawToday(ACanvas, R);\r\n\r\n DecodeDate(Self.Date + I, Y, M, D);\r\n R := Rect(I * FDayWidth, 4, I * FDayWidth + FDayWidth, Font.Size + 4);\r\n OffsetRect(R, FirstOffset, 0);\r\n S := Format('%.2d', [D]);\r\n SetBkMode(ACanvas.Handle, TRANSPARENT);\r\n if Objects[Self.Date + I] <> nil then\r\n ACanvas.Font.Style := FObjectsFontStyle\r\n else\r\n ACanvas.Font.Style := FTmpStyle;\r\n\r\n DrawText(ACanvas.Handle, PChar(S), Length(S), R,\r\n DT_CENTER or DT_VCENTER or DT_SINGLELINE or DT_NOPREFIX or DT_NOCLIP);\r\n DrawImage(ACanvas, Self.Date + I, GetRectForDate(Self.Date + I));\r\n // frame should be drawn on top of text and image\r\n if (Trunc(SelDate) = Trunc(Self.Date + I)) and not ReadOnly then\r\n DrawSelectionFrame(ACanvas, GetRectForDate(SelDate));\r\n\r\n ACanvas.Font := Font;\r\n if not Enabled then\r\n ACanvas.Font.Color := clGrayText;\r\n end;\r\n\r\n // second loop: draw months and years and separators\r\n if ShowWeeks or ShowMonths then\r\n for I := 0 to (Width div DayWidth) do\r\n begin\r\n R := GetRectForDate(Self.Date + I);\r\n DecodeDate(FDate + I, Y, M, D);\r\n if ShowWeeks and (DayOfWeek(Self.Date + I) = 1) then\r\n with ACanvas do\r\n begin\r\n // draw the dotted week separator between sunday and monday\r\n Brush.Color := Color;\r\n Pen.Width := 1;\r\n Pen.Style := psDot;\r\n Pen.Color := FLineColor;\r\n MoveTo(I * FDayWidth + FDayWidth + FirstOffset, 0);\r\n LineTo(I * FDayWidth + FDayWidth + FirstOffset, Height);\r\n end;\r\n\r\n ACanvas.Font := MonthFont;\r\n if not Enabled then\r\n ACanvas.Font.Color := clGrayText;\r\n if ShowMonths then\r\n begin\r\n if MonthDays[IsLeapYear(Y), M] = D then\r\n begin\r\n // draw text for end of this month:\r\n S := JclFormatSettings.ShortMonthNames[M];\r\n Size := ACanvas.TextExtent(S);\r\n R := Rect(I * FDayWidth + FDayWidth - Size.cx - 8,\r\n Height - Size.cy - 4, I * FDayWidth + FDayWidth, Height - 4);\r\n OffsetRect(R, FirstOffset, 0);\r\n SetBkMode(ACanvas.Handle, TRANSPARENT);\r\n DrawText(ACanvas.Handle, PChar(S), Length(S), R,\r\n DT_LEFT or DT_VCENTER or DT_SINGLELINE or DT_NOPREFIX or DT_NOCLIP);\r\n end\r\n else\r\n if D = 1 then\r\n begin\r\n // draw text for start of this month and the year:\r\n S := Format('%s %d', [JclFormatSettings.ShortMonthNames[M], Y]);\r\n Size := ACanvas.TextExtent(S);\r\n R := Rect(I * FDayWidth + 4, Height - Size.cy - 4, I * FDayWidth + Size.cx + 4, Height - 4);\r\n OffsetRect(R, FirstOffset, 0);\r\n SetBkMode(ACanvas.Handle, TRANSPARENT);\r\n DrawText(ACanvas.Handle, PChar(S), Length(S), R,\r\n DT_LEFT or DT_VCENTER or DT_SINGLELINE or DT_NOPREFIX or DT_NOCLIP);\r\n\r\n // Draw the separator\r\n with ACanvas do\r\n begin\r\n Pen.Width := 1;\r\n Pen.Style := psSolid;\r\n Pen.Color := FLineColor;\r\n MoveTo(I * FDayWidth + FirstOffset, 0);\r\n LineTo(I * FDayWidth + FirstOffset, Height);\r\n end;\r\n end;\r\n end;\r\n end;\r\n\r\n // finally, clean up the display\r\n if (ButtonWidth > 0) and not ReadOnly then\r\n with ACanvas do\r\n begin\r\n // draw a vertical line just to the right of the left scroll button and\r\n // just to the left of the right scroll button to\r\n // make them stand out a little bit more when buttons are flat:\r\n Pen.Width := 1;\r\n Pen.Color := clBlack;\r\n Pen.Style := psSolid;\r\n if BorderStyle = bsNone then\r\n begin\r\n MoveTo(FLeftBtn.Width, 0);\r\n LineTo(FLeftBtn.Width, Height);\r\n end;\r\n MoveTo(FRightBtn.Left - 1, 0);\r\n LineTo(FRightBtn.Left - 1, Height);\r\n end;\r\n // DoAfterDraw(ACanvas);\r\nend;\r\n\r\nprocedure TJvCustomTMTimeline.DrawSelectionFrame(ACanvas: TCanvas; ARect: TRect);\r\nbegin\r\n if not FSelection.Visible then\r\n Exit;\r\n if (ARect.Right > 0) and (ARect.Left <= Width) then\r\n begin\r\n ARect.Bottom := ARect.Bottom - ACanvas.Pen.Width;\r\n with FSelection do\r\n DrawFrame(ACanvas, Pen.Color, Pen.Width, ARect);\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomTMTimeline.DrawImage(ACanvas: TCanvas; ADate: {$IFNDEF RTL200_UP}Controls.{$ENDIF ~RTL200_UP}TDate; const ARect: TRect);\r\nvar\r\n I, X, Y: Integer;\r\nbegin\r\n if DateHasImage(ADate) then\r\n begin\r\n I := ImageIndex[ADate];\r\n X := ARect.Left + (FDayWidth - Images.Width) div 2;\r\n // Y := Max((Height - Images.Height) div 4, CanvasMaxTextHeight(ACanvas) + 2);\r\n Y := CanvasMaxTextHeight(ACanvas) + 2;\r\n Images.Draw(ACanvas, X, Y, I);\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomTMTimeline.Paint;\r\nbegin\r\n if not Showing or (csLoading in ComponentState) then\r\n Exit;\r\n inherited Canvas.Font := Font;\r\n DrawDates(inherited Canvas);\r\nend;\r\n\r\nprocedure TJvCustomTMTimeline.DrawFrame(ACanvas: TCanvas; AColor: TColor;\r\n ALineWidth: Integer; ARect: TRect);\r\nvar\r\n Tmp: TColor;\r\nbegin\r\n if ALineWidth = 0 then\r\n Exit;\r\n Tmp := ACanvas.Brush.Color;\r\n try\r\n ACanvas.Brush.Color := AColor;\r\n ACanvas.FrameRect(ARect);\r\n InflateRect(ARect, -Abs(ALineWidth) + 1, -Abs(ALineWidth) + 1);\r\n ACanvas.FrameRect(ARect);\r\n ACanvas.FloodFill(ARect.Left - 1, ARect.Top - 1, AColor, fsBorder);\r\n finally\r\n ACanvas.Brush.Color := Tmp;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomTMTimeline.SetFirstDate(const Value: {$IFNDEF RTL200_UP}Controls.{$ENDIF ~RTL200_UP}TDate);\r\nbegin\r\n if Trunc(FDate) <> Trunc(Value) then\r\n begin\r\n if (FMinDate > 0) and (Trunc(FMinDate) > Trunc(FDate)) then\r\n FDate := FMinDate\r\n else\r\n if (FMaxDate > 0) and (Trunc(FMaxDate) < Trunc(FDate)) then\r\n FDate := Trunc(FMaxDate)\r\n else\r\n FDate := Trunc(Value);\r\n Change;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomTMTimeline.SetReadOnly(const Value: Boolean);\r\nbegin\r\n if FReadOnly <> Value then\r\n begin\r\n FReadOnly := Value;\r\n FLeftBtn.Visible := not FReadOnly;\r\n FRightBtn.Visible := not FReadOnly;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomTMTimeline.SetMonthFont(const Value: TFont);\r\nbegin\r\n FMonthFont.Assign(Value);\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvCustomTMTimeline.SetSelDate(const Value: {$IFNDEF RTL200_UP}Controls.{$ENDIF ~RTL200_UP}TDate);\r\nvar\r\n R: TRect;\r\nbegin\r\n if FSelDate <> Value then\r\n begin\r\n // erase old selection\r\n R := GetRectForDate(FSelDate);\r\n InflateRect(R, Selection.Pen.Width + 1, Selection.Pen.Width + 1);\r\n Windows.InvalidateRect(Handle, @R, True);\r\n FSelDate := Value;\r\n if Enabled then\r\n begin\r\n // draw new selection\r\n R := GetRectForDate(FSelDate);\r\n InflateRect(R, Selection.Pen.Width + 1, Selection.Pen.Width + 1);\r\n Windows.InvalidateRect(Handle, @R, True);\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomTMTimeline.SetDayWidth(const Value: Integer);\r\nbegin\r\n if (FDayWidth <> Value) and (Value > 0) then\r\n begin\r\n FDayWidth := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomTMTimeline.MouseDown(Button: TMouseButton;\r\n Shift: TShiftState; X, Y: Integer);\r\nbegin\r\n inherited;\r\n if (Button = mbLeft) or ((Button = mbRight) and RightClickSelect) then\r\n SelDate := DateFromPos(X);\r\n if CanFocus and not Focused then\r\n SetFocus;\r\nend;\r\n\r\nprocedure TJvCustomTMTimeline.MouseUp(Button: TMouseButton; Shift: TShiftState;\r\n X, Y: Integer);\r\nbegin\r\n inherited MouseUp(Button, Shift, X, Y);\r\nend;\r\n\r\nfunction TJvCustomTMTimeline.GetBorderStyle: TBorderStyle;\r\nbegin\r\n Result := inherited BorderStyle;\r\nend;\r\n\r\nprocedure TJvCustomTMTimeline.SetBorderStyle(const Value: TBorderStyle);\r\nbegin\r\n if BorderStyle <> Value then\r\n begin\r\n inherited BorderStyle := Value;\r\n FLeftBtn.Flat := BorderStyle = bsNone;\r\n FRightBtn.Flat := BorderStyle = bsNone;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomTMTimeline.SetImages(const Value: TImageList);\r\nbegin\r\n if FImages <> Value then\r\n begin\r\n if Assigned(FImages) then\r\n FImages.UnRegisterChanges(FChangeLink);\r\n ReplaceComponentReference(Self, Value, TComponent(FImages));\r\n if Assigned(FImages) then\r\n FImages.RegisterChanges(FChangeLink);\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomTMTimeline.Notification(AComponent: TComponent;\r\n Operation: TOperation);\r\nbegin\r\n inherited Notification(AComponent, Operation);\r\n if (Operation = opRemove) and (AComponent = FImages) then\r\n FImages := nil;\r\nend;\r\n\r\nfunction TJvCustomTMTimeline.GetImageIndex(ADate: {$IFNDEF RTL200_UP}Controls.{$ENDIF ~RTL200_UP}TDate): Integer;\r\nbegin\r\n Result := FDateImages.IndexOf(IntToStr(Trunc(ADate)));\r\n if Result > -1 then\r\n Result := Integer(FDateImages.Objects[Result]);\r\nend;\r\n\r\nprocedure TJvCustomTMTimeline.SetImageIndex(ADate: {$IFNDEF RTL200_UP}Controls.{$ENDIF ~RTL200_UP}TDate;\r\n const Value: Integer);\r\nvar\r\n I: Integer;\r\nbegin\r\n I := FDateImages.IndexOf(IntToStr(Trunc(ADate)));\r\n if I < 0 then\r\n I := FDateImages.Add(IntToStr(Trunc(ADate)));\r\n FDateImages.Objects[I] := TObject(Value);\r\n Invalidate;\r\nend;\r\n\r\nfunction TJvCustomTMTimeline.GetObjects(ADate: {$IFNDEF RTL200_UP}Controls.{$ENDIF ~RTL200_UP}TDate): TObject;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := nil;\r\n I := FObjects.IndexOf(IntToStr(Trunc(ADate)));\r\n if I > -1 then\r\n Result := FObjects.Objects[I];\r\nend;\r\n\r\nprocedure TJvCustomTMTimeline.SetObjects(ADate: {$IFNDEF RTL200_UP}Controls.{$ENDIF ~RTL200_UP}TDate; const Value: TObject);\r\nvar\r\n I: Integer;\r\nbegin\r\n I := FObjects.IndexOf(IntToStr(Trunc(ADate)));\r\n if I < 0 then\r\n I := FObjects.Add(IntToStr(Trunc(ADate)));\r\n if Value = nil then\r\n FObjects.Delete(I)\r\n else\r\n FObjects.Objects[I] := Value;\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvCustomTMTimeline.Change;\r\nbegin\r\n if Assigned(FOnChange) then\r\n FOnChange(Self);\r\nend;\r\n\r\nprocedure TJvCustomTMTimeline.MouseMove(Shift: TShiftState; X, Y: Integer);\r\nvar\r\n ADate: TDate;\r\nbegin\r\n inherited MouseMove(Shift, X, Y);\r\n ADate := DateFromPos(X);\r\n if DateHasImage(ADate) then\r\n inherited Cursor := FImageCursor\r\n else\r\n Cursor := FRealCursor;\r\nend;\r\n\r\nprocedure TJvCustomTMTimeline.SetImageCursor(const Value: TCursor);\r\nbegin\r\n if FImageCursor <> Value then\r\n begin\r\n FImageCursor := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomTMTimeline.SetSelection(const Value: TJvTLSelFrame);\r\nbegin\r\n FSelection.Assign(Value);\r\nend;\r\n\r\nprocedure TJvCustomTMTimeline.GetDlgCode(var Code: TDlgCodes);\r\nbegin\r\n Include(Code, dcWantArrows);\r\n Exclude(Code, dcNative);\r\nend;\r\n\r\nprocedure TJvCustomTMTimeline.EnabledChanged;\r\nbegin\r\n inherited EnabledChanged;\r\n // asn: VisualCLX inherited Create emits EnableChanged event\r\n if Assigned(FRightBtn) then\r\n begin\r\n FLeftBtn.Enabled := Enabled;\r\n FRightBtn.Enabled := Enabled;\r\n end;\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvCustomTMTimeline.KeyDown(var Key: Word; Shift: TShiftState);\r\nbegin\r\n inherited KeyDown(Key, Shift);\r\n if not Enabled or ReadOnly then\r\n Exit;\r\n // handling keys in KeyDown gives automatic\r\n // scrolling when holding the key down\r\n case Key of\r\n VK_LEFT:\r\n if ssCtrl in Shift then\r\n ScrollDate(nil, -LargeChange)\r\n else\r\n if ssShift in Shift then\r\n begin\r\n SelDate := SelDate - 1;\r\n // make sure the selection is visible:\r\n if SelDate > GetLastVisibleDate then\r\n Self.Date := SelDate - GetVisibleDays + 1;\r\n if SelDate < Self.Date then\r\n Self.Date := SelDate;\r\n Click;\r\n end\r\n else\r\n ScrollDate(nil, -SmallChange);\r\n VK_RIGHT:\r\n if ssCtrl in Shift then\r\n ScrollDate(nil, LargeChange)\r\n else\r\n if ssShift in Shift then\r\n begin\r\n SelDate := SelDate + 1;\r\n // make sure the selection is visible:\r\n if SelDate > GetLastVisibleDate then\r\n Self.Date := SelDate - GetVisibleDays + 1;\r\n if SelDate < Self.Date then\r\n Self.Date := SelDate;\r\n Click;\r\n end\r\n else\r\n ScrollDate(nil, SmallChange);\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomTMTimeline.SetTodayColor(const Value: TColor);\r\nbegin\r\n if FTodayColor <> Value then\r\n begin\r\n FTodayColor := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomTMTimeline.SetRightClickSelect(const Value: Boolean);\r\nbegin\r\n if FRightClickSelect <> Value then\r\n FRightClickSelect := Value;\r\nend;\r\n\r\nprocedure TJvCustomTMTimeline.SetMaxDate(const Value: {$IFNDEF RTL200_UP}Controls.{$ENDIF ~RTL200_UP}TDate);\r\nbegin\r\n if Trunc(FMaxDate) <> Trunc(Value) then\r\n begin\r\n FMaxDate := Trunc(Value);\r\n if FMaxDate <= 0 then\r\n Exit;\r\n if FMaxDate < Trunc(Self.Date) then\r\n Self.Date := FMaxDate;\r\n if FMaxDate < Trunc(FSelDate) then\r\n SelDate := FMaxDate;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomTMTimeline.SetMinDate(const Value: {$IFNDEF RTL200_UP}Controls.{$ENDIF ~RTL200_UP}TDate);\r\nbegin\r\n if Trunc(FMinDate) <> Trunc(Value) then\r\n begin\r\n FMinDate := Trunc(Value);\r\n if FMinDate <= 0 then\r\n Exit;\r\n if FMinDate > Trunc(Self.Date) then\r\n Self.Date := FMinDate;\r\n if FMinDate > Trunc(FSelDate) then\r\n SelDate := FMinDate;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomTMTimeline.SetLargeChange(const Value: Word);\r\nbegin\r\n FLargeChange := Value;\r\nend;\r\n\r\nprocedure TJvCustomTMTimeline.SetSmallChange(const Value: Word);\r\nbegin\r\n FSmallChange := Value;\r\nend;\r\n\r\nprocedure TJvCustomTMTimeline.ClearObjects;\r\nbegin\r\n while FObjects.Count > 0 do\r\n begin\r\n FObjects.Objects[0].Free;\r\n FObjects.Delete(0);\r\n end;\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvCustomTMTimeline.ClearImages;\r\nbegin\r\n FDateImages.Clear;\r\nend;\r\n\r\nfunction TJvCustomTMTimeline.GetLastVisibleDate: {$IFNDEF RTL200_UP}Controls.{$ENDIF ~RTL200_UP}TDate;\r\nvar\r\n Tmp: Integer;\r\nbegin\r\n if not ReadOnly then\r\n Tmp := FButtonWidth * 2\r\n else\r\n Tmp := 1;\r\n Result := FDate + ((Width - Tmp) div DayWidth) - 1;\r\nend;\r\n\r\nprocedure TJvCustomTMTimeline.SetButtonWidth(const Value: Integer);\r\nbegin\r\n if FButtonWidth <> Value then\r\n begin\r\n FButtonWidth := Value;\r\n FLeftBtn.Width := FButtonWidth;\r\n FRightBtn.Width := FButtonWidth;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomTMTimeline.LoadFromFile(const Filename: string);\r\nvar\r\n F: TFileStream;\r\nbegin\r\n F := TFileStream.Create(Filename, fmOpenRead or fmShareDenyNone);\r\n try\r\n LoadFromStream(F);\r\n finally\r\n F.Free;\r\n end;\r\nend;\r\n\r\nprocedure WriteInt(Stream: TStream; Value: Integer);\r\nbegin\r\n Stream.Write(Value, SizeOf(Value));\r\nend;\r\n\r\nprocedure WriteStr(Stream: TStream; const Value: string);\r\nvar\r\n I: Integer;\r\n UTF8Value: UTF8String;\r\nbegin\r\n UTF8Value := UTF8Encode(Value);\r\n I := Length(UTF8Value);\r\n WriteInt(Stream, I);\r\n if I > 0 then\r\n Stream.Write(UTF8Value[1], I);\r\nend;\r\n\r\nfunction ReadInt(Stream: TStream): Integer;\r\nbegin\r\n Stream.Read(Result, SizeOf(Result));\r\nend;\r\n\r\nfunction ReadStr(Stream: TStream): string;\r\nvar\r\n I: Integer;\r\n UTF8Value: UTF8String;\r\nbegin\r\n I := ReadInt(Stream);\r\n SetLength(Result, I);\r\n if I > 0 then\r\n begin\r\n Stream.Read(UTF8Value[1], I);\r\n Result := UTF8ToString(UTF8Value);\r\n end;\r\nend;\r\n\r\nfunction TJvCustomTMTimeline.ReadMagic(Stream: TStream): Boolean;\r\nbegin\r\n Result := AnsiSameStr(ReadStr(Stream), cMagic);\r\nend;\r\n\r\nprocedure TJvCustomTMTimeline.LoadFromStream(Stream: TStream);\r\nvar\r\n O: TObject;\r\n I: Integer;\r\nbegin\r\n ClearImages;\r\n ClearObjects;\r\n if not ReadMagic(Stream) then\r\n raise EStreamError.CreateRes(@SInvalidImage);\r\n FDateImages.Text := ReadStr(Stream);\r\n for I := 0 to FDateImages.Count - 1 do\r\n FDateImages.Objects[I] := TObject(ReadInt(Stream));\r\n FObjects.Text := ReadStr(Stream);\r\n for I := 0 to FObjects.Count - 1 do\r\n begin\r\n O := nil;\r\n LoadObject(Stream, O);\r\n FObjects.Objects[I] := O;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomTMTimeline.SaveToStream(Stream: TStream);\r\nvar\r\n I: Integer;\r\nbegin\r\n WriteStr(Stream, cMagic);\r\n WriteStr(Stream, FDateImages.Text);\r\n for I := 0 to FDateImages.Count - 1 do\r\n WriteInt(Stream, Integer(FDateImages.Objects[I]));\r\n WriteStr(Stream, FObjects.Text);\r\n for I := 0 to FObjects.Count - 1 do\r\n SaveObject(Stream, FObjects.Objects[I]);\r\nend;\r\n\r\nprocedure TJvCustomTMTimeline.SaveToFile(const Filename: string);\r\nvar\r\n F: TFileStream;\r\nbegin\r\n F := TFileStream.Create(Filename, fmCreate);\r\n try\r\n SaveToStream(F);\r\n finally\r\n F.Free;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomTMTimeline.LoadObject(Stream: TStream; var AObject: TObject);\r\nbegin\r\n if Assigned(FOnReadObject) then\r\n FOnReadObject(Self, Stream, AObject);\r\nend;\r\n\r\nprocedure TJvCustomTMTimeline.SaveObject(Stream: TStream; const AObject: TObject);\r\nbegin\r\n if Assigned(FOnWriteObject) then\r\n FOnWriteObject(Self, Stream, AObject);\r\nend;\r\n\r\nprocedure TJvCustomTMTimeline.SetObjectsFontStyle(const Value: TFontStyles);\r\nbegin\r\n if FObjectsFontStyle <> Value then\r\n begin\r\n FObjectsFontStyle := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nfunction TJvCustomTMTimeline.DoMouseWheelDown(Shift: TShiftState; MousePos: TPoint): Boolean;\r\nbegin\r\n Result := inherited DoMouseWheelDown(Shift, MousePos);\r\n if not Result then\r\n ScrollDate(Self, -1);\r\nend;\r\n\r\nfunction TJvCustomTMTimeline.DoMouseWheelUp(Shift: TShiftState; MousePos: TPoint): Boolean;\r\nbegin\r\n Result := inherited DoMouseWheelUp(Shift, MousePos);\r\n if not Result then\r\n ScrollDate(Self, 1);\r\nend;\r\n\r\nfunction TJvCustomTMTimeline.GetVisibleDays: Integer;\r\nbegin\r\n Result := Trunc(GetLastVisibleDate - Self.Date) + 1;\r\nend;\r\n\r\nprocedure TJvCustomTMTimeline.SetShowMonths(const Value: Boolean);\r\nbegin\r\n if FShowMonths <> Value then\r\n begin\r\n FShowMonths := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomTMTimeline.SetShowToday(const Value: Boolean);\r\nbegin\r\n if FShowToday <> Value then\r\n begin\r\n FShowToday := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomTMTimeline.SetShowWeeks(const Value: Boolean);\r\nbegin\r\n if FShowWeeks <> Value then\r\n begin\r\n FShowWeeks := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomTMTimeline.SetLineColor(const Value: TColor);\r\nbegin\r\n if FLineColor <> Value then\r\n begin\r\n FLineColor := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomTMTimeline.CursorChanged;\r\nbegin\r\n inherited CursorChanged;\r\n FRealCursor := Cursor;\r\nend;\r\n\r\nfunction TJvCustomTMTimeline.DateHasImage(ADate: TDateTime): Boolean;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := False;\r\n if Assigned(Images) then\r\n begin\r\n I := ImageIndex[ADate];\r\n Result := (I >= 0) and (I < Images.Count);\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomTMTimeline.SetShowTodayIcon(const Value: Boolean);\r\nbegin\r\n if FShowTodayIcon <> Value then\r\n begin\r\n FShowTodayIcon := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvTabBar.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvTabBar.pas, released on 2004-12-23.\r\n\r\nThe Initial Developer of the Original Code is Andreas Hausladen \r\nPortions created by Andreas Hausladen are Copyright (C) 2004 Andreas Hausladen.\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvTabBar.pas 13415 2012-09-10 09:51:54Z obones $\r\n\r\nunit JvTabBar;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, Messages, Graphics, Controls, Forms, ImgList, Menus, Buttons,\r\n ExtCtrls,\r\n SysUtils, Classes, Contnrs,\r\n {$IFDEF HAS_UNIT_SYSTEM_UITYPES}\r\n System.UITypes,\r\n {$ENDIF HAS_UNIT_SYSTEM_UITYPES}\r\n JvThemes;\r\n\r\ntype\r\n TJvCustomTabBar = class;\r\n TJvTabBarItem = class;\r\n\r\n TJvTabBarOrientation = (toTop, toBottom);\r\n TJvTabBarScrollButtonKind = (sbScrollLeft, sbScrollRight);\r\n TJvTabBarScrollButtonState = (sbsHidden, sbsNormal, sbsHot, sbsPressed, sbsDisabled);\r\n\r\n TJvGetModifiedEvent = procedure(Sender: TJvTabBarItem; var Modified: Boolean) of object;\r\n TJvGetEnabledEvent = procedure(Sender: TJvTabBarItem; var Enabled: Boolean) of object;\r\n\r\n IPageList = interface\r\n ['{6BB90183-CFB1-4431-9CFD-E9A032E0C94C}']\r\n function CanChange(AIndex: Integer): Boolean;\r\n procedure SetActivePageIndex(AIndex: Integer);\r\n function GetPageCount: Integer;\r\n function GetPageCaption(AIndex: Integer): string;\r\n procedure AddPage(const ACaption: string);\r\n procedure DeletePage(Index: Integer);\r\n procedure MovePage(CurIndex, NewIndex: Integer);\r\n procedure PageCaptionChanged(Index: Integer; const NewCaption: string);\r\n end;\r\n\r\n TJvTabBarItem = class(TCollectionItem)\r\n private\r\n FLeft: Integer; // used for calculating DisplayRect\r\n\r\n FImageIndex: TImageIndex;\r\n FEnabled: Boolean;\r\n FVisible: Boolean;\r\n FTag: Integer;\r\n FData: TObject;\r\n FHint: TCaption;\r\n FName: string;\r\n FCaption: TCaption;\r\n FImages: TCustomImageList;\r\n FModified: Boolean;\r\n FPopupMenu: TPopupMenu;\r\n FOnGetEnabled: TJvGetEnabledEvent;\r\n FOnGetModified: TJvGetModifiedEvent;\r\n FShowHint: Boolean;\r\n FAutoDeleteDatas: TObjectList;\r\n function GetEnabled: Boolean;\r\n function GetModified: Boolean;\r\n\r\n procedure SetPopupMenu(const Value: TPopupMenu);\r\n function GetClosing: Boolean;\r\n procedure SetModified(const Value: Boolean);\r\n procedure SetCaption(const Value: TCaption);\r\n procedure SetSelected(const Value: Boolean);\r\n procedure SetEnabled(const Value: Boolean);\r\n procedure SetImageIndex(const Value: TImageIndex);\r\n procedure SetName(const Value: string);\r\n procedure SetVisible(const Value: Boolean);\r\n function GetTabBar: TJvCustomTabBar;\r\n function GetSelected: Boolean;\r\n function GetDisplayRect: TRect;\r\n function GetHot: Boolean;\r\n protected\r\n procedure Changed; virtual;\r\n\r\n procedure SetIndex(Value: Integer); override;\r\n procedure Notification(Component: TComponent; Operation: TOperation); virtual;\r\n property Name: string read FName write SetName;\r\n public\r\n constructor Create(Collection: Classes.TCollection); override;\r\n destructor Destroy; override;\r\n procedure Assign(Source: TPersistent); override;\r\n function GetImages: TCustomImageList;\r\n function CanSelect: Boolean;\r\n function GetNextVisible: TJvTabBarItem;\r\n function GetPreviousVisible: TJvTabBarItem;\r\n procedure MakeVisible;\r\n function AutoDeleteData: TObjectList;\r\n\r\n property Data: TObject read FData write FData;\r\n property TabBar: TJvCustomTabBar read GetTabBar;\r\n property DisplayRect: TRect read GetDisplayRect;\r\n property Hot: Boolean read GetHot;\r\n property Closing: Boolean read GetClosing;\r\n published\r\n property Caption: TCaption read FCaption write SetCaption;\r\n property Selected: Boolean read GetSelected write SetSelected default False;\r\n property Enabled: Boolean read GetEnabled write SetEnabled default True;\r\n property Modified: Boolean read GetModified write SetModified default False;\r\n property Hint: TCaption read FHint write FHint;\r\n property ImageIndex: TImageIndex read FImageIndex write SetImageIndex default -1;\r\n property Tag: Integer read FTag write FTag default 0;\r\n property Visible: Boolean read FVisible write SetVisible default True;\r\n property PopupMenu: TPopupMenu read FPopupMenu write SetPopupMenu;\r\n property ShowHint: Boolean read FShowHint write FShowHint default True;\r\n\r\n property OnGetModified: TJvGetModifiedEvent read FOnGetModified write FOnGetModified;\r\n property OnGetEnabled: TJvGetEnabledEvent read FOnGetEnabled write FOnGetEnabled;\r\n end;\r\n\r\n TJvTabBarItems = class(TOwnedCollection)\r\n private\r\n function GetTabBar: TJvCustomTabBar;\r\n function GetItem(Index: Integer): TJvTabBarItem;\r\n procedure SetItem(Index: Integer; const Value: TJvTabBarItem);\r\n protected\r\n function Find(const AName: string): TJvTabBarItem;\r\n procedure Notify(Item: TCollectionItem; Action: TCollectionNotification); override;\r\n public\r\n function IndexOf(Item: TJvTabBarItem): Integer;\r\n procedure EndUpdate; override;\r\n property Items[Index: Integer]: TJvTabBarItem read GetItem write SetItem; default;\r\n\r\n property TabBar: TJvCustomTabBar read GetTabBar;\r\n end;\r\n\r\n TJvTabBarPainterOptionType = (poPaintsHotTab, poBottomScrollButtons);\r\n TJvTabBarPainterOptions = set of TJvTabBarPainterOptionType;\r\n\r\n TJvTabBarPainter = class(TComponent)\r\n private\r\n FOnChangeList: TList;\r\n protected\r\n procedure Changed; virtual;\r\n\r\n procedure DrawBackground(Canvas: TCanvas; TabBar: TJvCustomTabBar; R: TRect); virtual; abstract;\r\n procedure DrawTab(Canvas: TCanvas; Tab: TJvTabBarItem; R: TRect); virtual; abstract;\r\n procedure DrawDivider(Canvas: TCanvas; LeftTab: TJvTabBarItem; R: TRect); virtual; abstract;\r\n procedure DrawMoveDivider(Canvas: TCanvas; Tab: TJvTabBarItem; MoveLeft: Boolean); virtual; abstract;\r\n function GetDividerWidth(Canvas: TCanvas; LeftTab: TJvTabBarItem): Integer; virtual; abstract;\r\n function GetTabSize(Canvas: TCanvas; Tab: TJvTabBarItem): TSize; virtual; abstract;\r\n function GetCloseRect(Canvas: TCanvas; Tab: TJvTabBarItem; R: TRect): TRect; virtual; abstract;\r\n function Options: TJvTabBarPainterOptions; virtual; abstract;\r\n\r\n procedure DrawScrollButton(Canvas: TCanvas; TabBar: TJvCustomTabBar; Button: TJvTabBarScrollButtonKind;\r\n State: TJvTabBarScrollButtonState; R: TRect); virtual;\r\n procedure GetScrollButtons(TabBar: TJvCustomTabBar; var LeftButton, RightButton: TRect); {virtual; reserved for future use }\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n end;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvModernTabBarPainter = class(TJvTabBarPainter)\r\n private\r\n FFont: TFont;\r\n FDisabledFont: TFont;\r\n FSelectedFont: TFont;\r\n FColor: TColor;\r\n FTabColor: TColor;\r\n FControlDivideColor: TColor;\r\n FBorderColor: TColor;\r\n FModifiedCrossColor: TColor;\r\n FCloseRectColor: TColor;\r\n FCloseRectColorDisabled: TColor;\r\n FCloseCrossColorDisabled: TColor;\r\n FCloseCrossColorSelected: TColor;\r\n FCloseCrossColor: TColor;\r\n FCloseColor: TColor;\r\n FCloseColorSelected: TColor;\r\n FDividerColor: TColor;\r\n FMoveDividerColor: TColor;\r\n FTabWidth: Integer;\r\n\r\n procedure SetCloseRectColorDisabled(const Value: TColor);\r\n procedure SetCloseColor(const Value: TColor);\r\n procedure SetCloseColorSelected(const Value: TColor);\r\n procedure SetCloseCrossColor(const Value: TColor);\r\n procedure SetCloseCrossColorDisabled(const Value: TColor);\r\n procedure SetCloseRectColor(const Value: TColor);\r\n procedure SetFont(const Value: TFont);\r\n procedure SetDisabledFont(const Value: TFont);\r\n procedure SetSelectedFont(const Value: TFont);\r\n\r\n procedure SetModifiedCrossColor(const Value: TColor);\r\n procedure SetBorderColor(const Value: TColor);\r\n procedure SetControlDivideColor(const Value: TColor);\r\n\r\n procedure SetTabColor(const Value: TColor);\r\n procedure SetColor(const Value: TColor);\r\n procedure FontChanged(Sender: TObject);\r\n procedure SetDividerColor(const Value: TColor);\r\n procedure SetCloseCrossColorSelected(const Value: TColor);\r\n procedure SetTabWidth(Value: Integer);\r\n protected\r\n procedure DrawBackground(Canvas: TCanvas; TabBar: TJvCustomTabBar; R: TRect); override;\r\n procedure DrawTab(Canvas: TCanvas; Tab: TJvTabBarItem; R: TRect); override;\r\n procedure DrawDivider(Canvas: TCanvas; LeftTab: TJvTabBarItem; R: TRect); override;\r\n procedure DrawMoveDivider(Canvas: TCanvas; Tab: TJvTabBarItem; MoveLeft: Boolean); override;\r\n function GetDividerWidth(Canvas: TCanvas; LeftTab: TJvTabBarItem): Integer; override;\r\n function GetTabSize(Canvas: TCanvas; Tab: TJvTabBarItem): TSize; override;\r\n function GetCloseRect(Canvas: TCanvas; Tab: TJvTabBarItem; R: TRect): TRect; override;\r\n function Options: TJvTabBarPainterOptions; override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n published\r\n property TabColor: TColor read FTabColor write SetTabColor default clBtnFace;\r\n property Color: TColor read FColor write SetColor default clWindow;\r\n property BorderColor: TColor read FBorderColor write SetBorderColor default clSilver;\r\n property ControlDivideColor: TColor read FControlDivideColor write SetControlDivideColor default clBlack;\r\n property ModifiedCrossColor: TColor read FModifiedCrossColor write SetModifiedCrossColor default clRed;\r\n property CloseColorSelected: TColor read FCloseColorSelected write SetCloseColorSelected default $F4F4F4;\r\n property CloseColor: TColor read FCloseColor write SetCloseColor default clWhite;\r\n property CloseCrossColorSelected: TColor read FCloseCrossColorSelected write SetCloseCrossColorSelected default clBlack;\r\n property CloseCrossColor: TColor read FCloseCrossColor write SetCloseCrossColor default $5D5D5D;\r\n property CloseCrossColorDisabled: TColor read FCloseCrossColorDisabled write SetCloseCrossColorDisabled default $ADADAD;\r\n property CloseRectColor: TColor read FCloseRectColor write SetCloseRectColor default $868686;\r\n property CloseRectColorDisabled: TColor read FCloseRectColorDisabled write SetCloseRectColorDisabled default $D6D6D6;\r\n property DividerColor: TColor read FDividerColor write SetDividerColor default $99A8AC;\r\n property MoveDividerColor: TColor read FMoveDividerColor write FMoveDividerColor default clBlack;\r\n property TabWidth: Integer read FTabWidth write SetTabWidth default 0;\r\n\r\n property Font: TFont read FFont write SetFont;\r\n property DisabledFont: TFont read FDisabledFont write SetDisabledFont;\r\n property SelectedFont: TFont read FSelectedFont write SetSelectedFont;\r\n end;\r\n TJvTabBarModernPainter = TJvModernTabBarPainter; // TJvModernTabBarPainter should have been named TJvTabBarModernPainter\r\n\r\n TJvTabBarItemEvent = procedure(Sender: TObject; Item: TJvTabBarItem) of object;\r\n TJvTabBarSelectingEvent = procedure(Sender: TObject; Item: TJvTabBarItem; var AllowSelect: Boolean) of object;\r\n TJvTabBarClosingEvent = procedure(Sender: TObject; Item: TJvTabBarItem; var AllowClose: Boolean) of object;\r\n TJvTabBarCloseQueryEvent = procedure(Sender: TObject; Item: TJvTabBarItem; var CanClose: Boolean) of object;\r\n TJvTabBarScrollButtonClickEvent = procedure(Sender: TObject; Button: TJvTabBarScrollButtonKind) of object;\r\n\r\n TJvTabBarScrollButtonInfo = record\r\n State: TJvTabBarScrollButtonState;\r\n Rect: TRect;\r\n ExState: Boolean;\r\n end;\r\n\r\n TJvCustomTabBar = class(TCustomControl)\r\n private\r\n FTabs: TJvTabBarItems;\r\n FPainter: TJvTabBarPainter;\r\n FDefaultPainter: TJvTabBarPainter;\r\n FChangeLink: TChangeLink;\r\n FCloseButton: Boolean;\r\n FRightClickSelect: Boolean;\r\n FImages: TCustomImageList;\r\n FHotTracking: Boolean;\r\n FHotTab: TJvTabBarItem;\r\n FSelectedTab: TJvTabBarItem;\r\n FClosingTab: TJvTabBarItem;\r\n FLastInsertTab: TJvTabBarItem;\r\n FMouseDownClosingTab: TJvTabBarItem;\r\n FMargin: Integer;\r\n FAutoFreeClosed: Boolean;\r\n FAllowUnselected: Boolean;\r\n FSelectBeforeClose: Boolean;\r\n FPageList: TCustomControl;\r\n\r\n FOnTabClosing: TJvTabBarClosingEvent;\r\n FOnTabSelected: TJvTabBarItemEvent;\r\n FOnTabSelecting: TJvTabBarSelectingEvent;\r\n FOnTabCloseQuery: TJvTabBarCloseQueryEvent;\r\n FOnTabClosed: TJvTabBarItemEvent;\r\n FOnTabMoved: TJvTabBarItemEvent;\r\n FOnChange: TNotifyEvent;\r\n\r\n // scrolling\r\n FLeftIndex: Integer;\r\n FLastTabRight: Integer;\r\n FRequiredWidth: Integer;\r\n FBarWidth: Integer;\r\n FBtnLeftScroll: TJvTabBarScrollButtonInfo;\r\n FBtnRightScroll: TJvTabBarScrollButtonInfo;\r\n FScrollButtonBackground: TBitmap;\r\n FHint: TCaption;\r\n FFlatScrollButtons: Boolean;\r\n FAllowTabMoving: Boolean;\r\n FOrientation: TJvTabBarOrientation;\r\n FOnScrollButtonClick: TJvTabBarScrollButtonClickEvent;\r\n FPageListTabLink: Boolean;\r\n\r\n FRepeatTimer: TTimer;\r\n FScrollRepeatedClicked: Boolean;\r\n FOnLeftTabChange: TNotifyEvent;\r\n\r\n function GetLeftTab: TJvTabBarItem;\r\n procedure SetLeftTab(Value: TJvTabBarItem);\r\n procedure SetSelectedTab(Value: TJvTabBarItem);\r\n procedure SetTabs(Value: TJvTabBarItems);\r\n procedure SetPainter(Value: TJvTabBarPainter);\r\n procedure SetImages(Value: TCustomImageList);\r\n procedure SetCloseButton(Value: Boolean);\r\n procedure SetMargin(Value: Integer);\r\n\r\n procedure SetHotTab(Tab: TJvTabBarItem);\r\n procedure SetClosingTab(Tab: TJvTabBarItem);\r\n procedure UpdateScrollButtons;\r\n function FindSelectableTab(Tab: TJvTabBarItem): TJvTabBarItem;\r\n procedure SetHint(const Value: TCaption);\r\n procedure SetFlatScrollButtons(const Value: Boolean);\r\n procedure SetPageList(const Value: TCustomControl);\r\n procedure SetOrientation(const Value: TJvTabBarOrientation);\r\n procedure TimerExpired(Sender: TObject);\r\n protected\r\n procedure DrawScrollBarGlyph(Canvas: TCanvas; X, Y: Integer; Left, Disabled: Boolean);\r\n procedure Resize; override;\r\n procedure CalcTabsRects;\r\n procedure Paint; override;\r\n procedure PaintTab(Canvas: TCanvas; Tab: TJvTabBarItem); virtual;\r\n procedure PaintScrollButtons;\r\n\r\n function GetTabWidth(Tab: TJvTabBarItem): Integer;\r\n function GetTabHeight(Tab: TJvTabBarItem): Integer;\r\n\r\n function CurrentPainter: TJvTabBarPainter;\r\n procedure Notification(Component: TComponent; Operation: TOperation); override;\r\n\r\n function TabClosing(Tab: TJvTabBarItem): Boolean; virtual;\r\n function TabCloseQuery(Tab: TJvTabBarItem): Boolean; virtual;\r\n procedure TabClosed(Tab: TJvTabBarItem); virtual;\r\n function TabSelecting(Tab: TJvTabBarItem): Boolean; virtual;\r\n procedure TabSelected(Tab: TJvTabBarItem); virtual;\r\n procedure TabMoved(Tab: TJvTabBarItem); virtual;\r\n procedure Changed; virtual;\r\n procedure ImagesChanged(Sender: TObject); virtual;\r\n procedure ScrollButtonClick(Button: TJvTabBarScrollButtonKind); virtual;\r\n procedure LeftTabChanged; virtual;\r\n\r\n procedure DragOver(Source: TObject; X: Integer; Y: Integer;\r\n State: TDragState; var Accept: Boolean); override;\r\n procedure DragCanceled; override;\r\n\r\n function ScrollButtonsMouseDown(Button: TMouseButton; Shift: TShiftState; X: Integer; Y: Integer): Boolean; virtual;\r\n function ScrollButtonsMouseUp(Button: TMouseButton; Shift: TShiftState; X: Integer; Y: Integer): Boolean; virtual;\r\n function ScrollButtonsMouseMove(Shift: TShiftState; X: Integer; Y: Integer): Boolean; virtual;\r\n\r\n function DoMouseWheel(Shift: TShiftState; WheelDelta: Integer; MousePos: TPoint): Boolean; override;\r\n procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X: Integer; Y: Integer); override;\r\n procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X: Integer; Y: Integer); override;\r\n procedure MouseMove(Shift: TShiftState; X: Integer; Y: Integer); override;\r\n procedure CMMouseLeave(var Msg: TMessage); message CM_MOUSELEAVE;\r\n procedure WMEraseBkgnd(var Msg: TWMEraseBkgnd); message WM_ERASEBKGND;\r\n procedure Loaded; override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n\r\n function AddTab(const Caption: string): TJvTabBarItem;\r\n function FindTab(const Caption: string): TJvTabBarItem; // returns the first tab with the given Caption\r\n function TabAt(X, Y: Integer): TJvTabBarItem;\r\n function MakeVisible(Tab: TJvTabBarItem): Boolean;\r\n function FindData(Data: TObject): TJvTabBarItem;\r\n function CloseTab(ATab: TJvTabBarItem): Boolean;\r\n\r\n procedure DragDrop(Source: TObject; X: Integer; Y: Integer); override;\r\n\r\n property PageListTabLink: Boolean read FPageListTabLink write FPageListTabLink default False; // if true the PageList's Pages[] are kept in sync with the Tabs\r\n property PageList: TCustomControl read FPageList write SetPageList;\r\n property Painter: TJvTabBarPainter read FPainter write SetPainter;\r\n property Images: TCustomImageList read FImages write SetImages;\r\n property Tabs: TJvTabBarItems read FTabs write SetTabs;\r\n\r\n // Status\r\n property SelectedTab: TJvTabBarItem read FSelectedTab write SetSelectedTab;\r\n property LeftTab: TJvTabBarItem read GetLeftTab write SetLeftTab;\r\n property HotTab: TJvTabBarItem read FHotTab;\r\n property ClosingTab: TJvTabBarItem read FClosingTab;\r\n\r\n // Options\r\n property Orientation: TJvTabBarOrientation read FOrientation write SetOrientation default toTop;\r\n property CloseButton: Boolean read FCloseButton write SetCloseButton default True;\r\n property RightClickSelect: Boolean read FRightClickSelect write FRightClickSelect default True;\r\n property HotTracking: Boolean read FHotTracking write FHotTracking default False;\r\n property AutoFreeClosed: Boolean read FAutoFreeClosed write FAutoFreeClosed default True;\r\n property AllowUnselected: Boolean read FAllowUnselected write FAllowUnselected default False;\r\n property SelectBeforeClose: Boolean read FSelectBeforeClose write FSelectBeforeClose default False;\r\n property Margin: Integer read FMargin write SetMargin default 6;\r\n property FlatScrollButtons: Boolean read FFlatScrollButtons write SetFlatScrollButtons default True;\r\n property Hint: TCaption read FHint write SetHint;\r\n property AllowTabMoving: Boolean read FAllowTabMoving write FAllowTabMoving default False;\r\n\r\n // Events\r\n\r\n { With OnTabClosing you can prevent the close button [X] in the tab from shrinking.\r\n If you want to ask the user you should use OnTabCloseQuery }\r\n property OnTabClosing: TJvTabBarClosingEvent read FOnTabClosing write FOnTabClosing;\r\n property OnTabCloseQuery: TJvTabBarCloseQueryEvent read FOnTabCloseQuery write FOnTabCloseQuery;\r\n property OnTabClosed: TJvTabBarItemEvent read FOnTabClosed write FOnTabClosed;\r\n property OnTabSelecting: TJvTabBarSelectingEvent read FOnTabSelecting write FOnTabSelecting;\r\n property OnTabSelected: TJvTabBarItemEvent read FOnTabSelected write FOnTabSelected;\r\n property OnTabMoved: TJvTabBarItemEvent read FOnTabMoved write FOnTabMoved;\r\n property OnChange: TNotifyEvent read FOnChange write FOnChange;\r\n property OnScrollButtonClick: TJvTabBarScrollButtonClickEvent read FOnScrollButtonClick write FOnScrollButtonClick;\r\n property OnLeftTabChange: TNotifyEvent read FOnLeftTabChange write FOnLeftTabChange;\r\n end;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvTabBar = class(TJvCustomTabBar)\r\n published\r\n property Align default alTop;\r\n property Cursor;\r\n property PopupMenu;\r\n property ShowHint default False;\r\n property Height default 23;\r\n property Hint;\r\n property Visible;\r\n property Enabled;\r\n\r\n property Orientation;\r\n property CloseButton;\r\n property RightClickSelect;\r\n property HotTracking;\r\n property AutoFreeClosed;\r\n property AllowUnselected;\r\n property SelectBeforeClose;\r\n property Margin;\r\n property FlatScrollButtons;\r\n property AllowTabMoving;\r\n\r\n property PageListTabLink;\r\n property PageList;\r\n property Painter;\r\n property Images;\r\n property Tabs;\r\n\r\n property OnTabClosing;\r\n property OnTabCloseQuery;\r\n property OnTabClosed;\r\n property OnTabSelecting;\r\n property OnTabSelected;\r\n property OnTabMoved;\r\n property OnChange;\r\n property OnLeftTabChange;\r\n\r\n property OnMouseDown;\r\n property OnMouseMove;\r\n property OnMouseUp;\r\n property OnContextPopup;\r\n\r\n property OnClick;\r\n property OnDblClick;\r\n\r\n property OnDragDrop;\r\n property OnDragOver;\r\n property OnStartDrag;\r\n property OnEndDrag;\r\n\r\n property OnStartDock;\r\n property OnEndDock;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvTabBar.pas $';\r\n Revision: '$Revision: 13415 $';\r\n Date: '$Date: 2012-09-10 11:51:54 +0200 (lun. 10 sept. 2012) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n Types,\r\n JvJVCLUtils;\r\n\r\n//=== { TJvCustomTabBar } ====================================================\r\n\r\nconstructor TJvCustomTabBar.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n ControlStyle := ControlStyle - [csAcceptsControls, csOpaque] {+ [csDesignInteractive]};\r\n\r\n FTabs := TJvTabBarItems.Create(Self, TJvTabBarItem);\r\n FChangeLink := TChangeLink.Create;\r\n FChangeLink.OnChange := ImagesChanged;\r\n\r\n FOrientation := toTop;\r\n FRightClickSelect := True;\r\n FCloseButton := True;\r\n FAutoFreeClosed := True;\r\n FFlatScrollButtons := True;\r\n\r\n FMargin := 6;\r\n\r\n Align := alTop;\r\n Height := 23;\r\nend;\r\n\r\ndestructor TJvCustomTabBar.Destroy;\r\nbegin\r\n // these events are too dangerous during object destruction\r\n FOnTabSelected := nil;\r\n FOnTabSelecting := nil;\r\n FOnChange := nil;\r\n\r\n Painter := nil;\r\n Images := nil;\r\n FChangeLink.Free;\r\n FTabs.Free;\r\n FTabs := nil;\r\n FScrollButtonBackground.Free;\r\n FScrollButtonBackground := nil;\r\n\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvCustomTabBar.LeftTabChanged;\r\nbegin\r\n if Assigned(FOnLeftTabChange) then\r\n FOnLeftTabChange(Self);\r\nend;\r\n\r\nprocedure TJvCustomTabBar.Loaded;\r\nbegin\r\n inherited Loaded;\r\n SelectedTab := FindSelectableTab(nil);\r\n UpdateScrollButtons;\r\nend;\r\n\r\nprocedure TJvCustomTabBar.Notification(Component: TComponent; Operation: TOperation);\r\nvar\r\n I: Integer;\r\nbegin\r\n inherited Notification(Component, Operation);\r\n if Operation = opRemove then\r\n begin\r\n if Component = FPainter then\r\n Painter := nil\r\n else\r\n if Component = FImages then\r\n Images := nil\r\n else\r\n if Component = FPageList then\r\n PageList := nil;\r\n end;\r\n if FTabs <> nil then\r\n for I := Tabs.Count - 1 downto 0 do\r\n Tabs[I].Notification(Component, Operation);\r\nend;\r\n\r\nprocedure TJvCustomTabBar.DrawScrollBarGlyph(Canvas: TCanvas; X, Y: Integer; Left, Disabled: Boolean);\r\n\r\n procedure OffsetPt(var Pt: TPoint; X, Y: Integer);\r\n begin\r\n Pt := Point(Pt.X + X, Pt.Y + Y);\r\n end;\r\n\r\nconst\r\n W = 4;\r\n H = 7;\r\nvar\r\n Pts: array [0..2] of TPoint;\r\n Brush: TBrush;\r\n Pen: TPen;\r\nbegin\r\n Brush := TBrush.Create;\r\n Pen := TPen.Create;\r\n try\r\n Brush.Assign(Canvas.Brush);\r\n Pen.Assign(Canvas.Pen);\r\n\r\n if Left then\r\n begin\r\n Pts[0] := Point(X + W - 1, Y + 0);\r\n Pts[1] := Point(X + W - 1, Y + H - 1);\r\n Pts[2] := Point(X + 0, Y + (H - 1) div 2);\r\n end\r\n else\r\n begin\r\n Pts[0] := Point(X + 0, Y + 0);\r\n Pts[1] := Point(X + 0, Y + H - 1);\r\n Pts[2] := Point(X + W - 1, Y + (H - 1) div 2);\r\n end;\r\n Canvas.Brush.Style := bsSolid;\r\n if Disabled then\r\n begin\r\n Canvas.Brush.Color := clWhite;\r\n OffsetPt(Pts[0], 1, 1);\r\n OffsetPt(Pts[1], 1, 1);\r\n OffsetPt(Pts[2], 1, 1);\r\n end\r\n else\r\n Canvas.Brush.Color := clBlack;\r\n\r\n Canvas.Pen.Color := Canvas.Brush.Color;\r\n Canvas.Polygon(Pts);\r\n if Disabled then\r\n begin\r\n Canvas.Brush.Color := clGray;\r\n OffsetPt(Pts[0], -1, -1);\r\n OffsetPt(Pts[1], -1, -1);\r\n OffsetPt(Pts[2], -1, -1);\r\n Canvas.Pen.Color := Canvas.Brush.Color;\r\n Canvas.Polygon(Pts);\r\n end;\r\n finally\r\n Canvas.Pen.Assign(Pen);\r\n Canvas.Brush.Assign(Brush);\r\n Pen.Free;\r\n Brush.Free;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomTabBar.SetTabs(Value: TJvTabBarItems);\r\nbegin\r\n if Value <> FTabs then\r\n FTabs.Assign(Value);\r\nend;\r\n\r\nprocedure TJvCustomTabBar.SetPainter(Value: TJvTabBarPainter);\r\nbegin\r\n if Value <> FPainter then\r\n begin\r\n if FPainter <> nil then\r\n FPainter.FOnChangeList.Extract(Self);\r\n ReplaceComponentReference(Self, Value, tComponent(FPainter));\r\n if FPainter <> nil then\r\n begin\r\n FreeAndNil(FDefaultPainter);\r\n FPainter.FOnChangeList.Add(Self);\r\n if Parent <> nil then\r\n UpdateScrollButtons;\r\n end;\r\n\r\n if not (csDestroying in ComponentState) then\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomTabBar.SetImages(Value: TCustomImageList);\r\nbegin\r\n if ReplaceImageListReference(Self, Value, FImages, FChangeLink) then\r\n if not (csDestroying in ComponentState) then\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvCustomTabBar.SetCloseButton(Value: Boolean);\r\nbegin\r\n if Value <> FCloseButton then\r\n begin\r\n FCloseButton := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomTabBar.SetMargin(Value: Integer);\r\nbegin\r\n if Value <> FMargin then\r\n begin\r\n FMargin := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomTabBar.SetSelectedTab(Value: TJvTabBarItem);\r\nbegin\r\n if Value <> FSelectedTab then\r\n begin\r\n if (Value <> nil) and not Value.CanSelect then\r\n Exit;\r\n\r\n if TabSelecting(Value) then\r\n begin\r\n FSelectedTab := Value;\r\n if not (csDestroying in ComponentState) then\r\n Invalidate;\r\n MakeVisible(FSelectedTab);\r\n TabSelected(FSelectedTab);\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJvCustomTabBar.CurrentPainter: TJvTabBarPainter;\r\nbegin\r\n Result := FPainter;\r\n if Result = nil then\r\n begin\r\n if FDefaultPainter = nil then\r\n FDefaultPainter := TJvModernTabBarPainter.Create(Self);\r\n Result := FDefaultPainter;\r\n end;\r\nend;\r\n\r\nfunction TJvCustomTabBar.TabClosing(Tab: TJvTabBarItem): Boolean;\r\nbegin\r\n Result := True;\r\n if Assigned(FOnTabClosing) then\r\n FOnTabClosing(Self, Tab, Result);\r\nend;\r\n\r\nfunction TJvCustomTabBar.TabCloseQuery(Tab: TJvTabBarItem): Boolean;\r\nbegin\r\n Result := True;\r\n if Assigned(FOnTabCloseQuery) then\r\n FOnTabCloseQuery(Self, Tab, Result);\r\nend;\r\n\r\nprocedure TJvCustomTabBar.TabClosed(Tab: TJvTabBarItem);\r\nbegin\r\n if AutoFreeClosed and not (csDesigning in ComponentState) then\r\n Tab.Visible := False;\r\n try\r\n if Assigned(FOnTabClosed) then\r\n FOnTabClosed(Self, Tab);\r\n finally\r\n // Do not double release if somebody \"accidentally\" released the Tab in TabClosed even if AutoFreeClosed is true\r\n if AutoFreeClosed and not (csDesigning in ComponentState) and (FTabs.IndexOf(Tab) <> -1) then\r\n Tab.Free;\r\n end;\r\nend;\r\n\r\nfunction TJvCustomTabBar.TabSelecting(Tab: TJvTabBarItem): Boolean;\r\nbegin\r\n Result := True;\r\n if Assigned(FOnTabSelecting) then\r\n FOnTabSelecting(Self, Tab, Result);\r\nend;\r\n\r\nprocedure TJvCustomTabBar.TabSelected(Tab: TJvTabBarItem);\r\nvar\r\n PageListIntf: IPageList;\r\nbegin\r\n if (PageList <> nil) and Supports(PageList, IPageList, PageListIntf) then\r\n begin\r\n if Tab <> nil then\r\n PageListIntf.SetActivePageIndex(Tab.Index)\r\n else\r\n PageListIntf.SetActivePageIndex(-1);\r\n PageListIntf := nil; // who knows what OnTabSelected does with the PageList\r\n end;\r\n if Assigned(FOnTabSelected) then\r\n FOnTabSelected(Self, Tab);\r\nend;\r\n\r\nfunction TJvCustomTabBar.FindSelectableTab(Tab: TJvTabBarItem): TJvTabBarItem;\r\nvar\r\n Index: Integer;\r\nbegin\r\n Result := Tab;\r\n if (Result <> nil) and not Result.CanSelect then\r\n begin\r\n if AllowUnselected then\r\n Result := nil\r\n else\r\n begin\r\n Index := Result.Index + 1;\r\n while Index < Tabs.Count do\r\n begin\r\n if Tabs[Index].CanSelect then\r\n Break;\r\n Inc(Index);\r\n end;\r\n if Index >= Tabs.Count then\r\n begin\r\n Index := Result.Index - 1;\r\n while Index >= 0 do\r\n begin\r\n if Tabs[Index].CanSelect then\r\n Break;\r\n Dec(Index);\r\n end;\r\n end;\r\n if Index >= 0 then\r\n Result := Tabs[Index]\r\n else\r\n Result := nil;\r\n end;\r\n end;\r\n if not AllowUnselected and not (Result <> nil) then\r\n begin\r\n // try to find a selectable tab\r\n for Index := 0 to Tabs.Count - 1 do\r\n if Tabs[Index].CanSelect then\r\n begin\r\n Result := Tabs[Index];\r\n Break;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomTabBar.Changed;\r\nbegin\r\n if not (csDestroying in ComponentState) then\r\n begin\r\n // The TabSelected tab is now no more selectable\r\n SelectedTab := FindSelectableTab(SelectedTab);\r\n if Tabs.UpdateCount = 0 then\r\n begin\r\n Invalidate;\r\n if Assigned(FOnChange) then\r\n FOnChange(Self);\r\n UpdateScrollButtons;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomTabBar.ImagesChanged(Sender: TObject);\r\nbegin\r\n if not (csDestroying in ComponentState) then\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvCustomTabBar.TabMoved(Tab: TJvTabBarItem);\r\nbegin\r\n if Assigned(FOnTabMoved) then\r\n FOnTabMoved(Self, Tab);\r\nend;\r\n\r\nprocedure TJvCustomTabBar.DragOver(Source: TObject; X: Integer; Y: Integer;\r\n State: TDragState; var Accept: Boolean);\r\nvar\r\n InsertTab: TJvTabBarItem;\r\nbegin\r\n if AllowTabMoving then\r\n begin\r\n InsertTab := TabAt(X, Y);\r\n if InsertTab = nil then\r\n if (LeftTab <> nil) and (X < LeftTab.FLeft) then\r\n InsertTab := LeftTab\r\n else\r\n if Tabs.Count > 0 then\r\n InsertTab := Tabs[Tabs.Count - 1];\r\n\r\n Accept := (Source = Self) and (SelectedTab <> nil) and (InsertTab <> SelectedTab) and (InsertTab <> nil);\r\n if Accept then\r\n begin\r\n if InsertTab <> FLastInsertTab then\r\n begin\r\n if FLastInsertTab <> nil then\r\n Repaint;\r\n { Paint MoveDivider }\r\n FLastInsertTab := InsertTab;\r\n CurrentPainter.DrawMoveDivider(Canvas, InsertTab, InsertTab.Index < SelectedTab.Index);\r\n end;\r\n { inherited DrawOver sets Accept to False if no event handler is assigned. }\r\n if Assigned(OnDragOver) then\r\n OnDragOver(Self, Source, X, Y, State, Accept);\r\n Exit;\r\n end\r\n else\r\n if FLastInsertTab <> nil then\r\n begin\r\n Repaint;\r\n FLastInsertTab := nil;\r\n end;\r\n end;\r\n inherited DragOver(Source, X, Y, State, Accept);\r\nend;\r\n\r\nprocedure TJvCustomTabBar.DragCanceled;\r\nbegin\r\n if FLastInsertTab <> nil then\r\n Repaint;\r\n FLastInsertTab := nil;\r\n inherited DragCanceled;\r\nend;\r\n\r\nprocedure TJvCustomTabBar.DragDrop(Source: TObject; X: Integer; Y: Integer);\r\nvar\r\n InsertTab: TJvTabBarItem;\r\nbegin\r\n if AllowTabMoving and (Source = Self) and (SelectedTab <> nil) then\r\n begin\r\n InsertTab := TabAt(X, Y);\r\n if InsertTab = nil then\r\n if (LeftTab <> nil) and (X < LeftTab.FLeft) then\r\n InsertTab := LeftTab\r\n else\r\n InsertTab := Tabs[Tabs.Count - 1];\r\n if InsertTab <> nil then\r\n begin\r\n SelectedTab.Index := InsertTab.Index;\r\n TabMoved(SelectedTab);\r\n SelectedTab.MakeVisible;\r\n UpdateScrollButtons;\r\n end;\r\n end\r\n else\r\n if FLastInsertTab <> nil then\r\n Repaint;\r\n FLastInsertTab := nil;\r\n inherited DragDrop(Source, X, Y);\r\nend;\r\n\r\nprocedure TJvCustomTabBar.CMMouseLeave(var Msg: TMessage);\r\nbegin\r\n SetHotTab(nil);\r\n inherited;\r\nend;\r\n\r\nprocedure TJvCustomTabBar.WMEraseBkgnd(var Msg: TWMEraseBkgnd);\r\nbegin\r\n Msg.Result := 1;\r\nend;\r\n\r\nfunction TJvCustomTabBar.DoMouseWheel(Shift: TShiftState; WheelDelta: Integer; MousePos: TPoint): Boolean;\r\nbegin\r\n Result := inherited DoMouseWheel(Shift, WheelDelta, MousePos);\r\n if not Result then\r\n begin\r\n Result := True;\r\n\r\n if SelectedTab = nil then\r\n SelectedTab := LeftTab;\r\n if SelectedTab = nil then\r\n Exit; // nothing to do\r\n\r\n WheelDelta := WheelDelta div WHEEL_DELTA;\r\n while WheelDelta <> 0 do\r\n begin\r\n if WheelDelta < 0 then\r\n begin\r\n if SelectedTab.GetNextVisible <> nil then\r\n SelectedTab := SelectedTab.GetNextVisible\r\n else\r\n Break;\r\n end\r\n else\r\n begin\r\n if SelectedTab.GetPreviousVisible <> nil then\r\n SelectedTab := SelectedTab.GetPreviousVisible\r\n else\r\n Break;\r\n end;\r\n\r\n if WheelDelta < 0 then\r\n Inc(WheelDelta)\r\n else\r\n Dec(WheelDelta);\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomTabBar.MouseDown(Button: TMouseButton; Shift: TShiftState; X,\r\n Y: Integer);\r\nvar\r\n Tab: TJvTabBarItem;\r\n LastSelected: TJvTabBarItem;\r\nbegin\r\n if ScrollButtonsMouseDown(Button, Shift, X, Y) then\r\n Exit;\r\n\r\n if Button = mbLeft then\r\n begin\r\n FMouseDownClosingTab := nil;\r\n SetClosingTab(nil); // no tab should be closed\r\n\r\n LastSelected := SelectedTab;\r\n Tab := TabAt(X, Y);\r\n if Tab <> nil then\r\n SelectedTab := Tab;\r\n\r\n if (Tab <> nil) and (Tab = SelectedTab) then\r\n if CloseButton and (not SelectBeforeClose or (SelectedTab = LastSelected)) then\r\n begin\r\n if PtInRect(CurrentPainter.GetCloseRect(Canvas, Tab, Tab.DisplayRect), Point(X, Y)) then\r\n begin\r\n if TabClosing(Tab) then\r\n begin\r\n if FTabs.IndexOf(Tab) = -1 then\r\n Tab := nil; // We should not keep a reference if somebody \"accidentally\" released the Tab in TabClosing\r\n FMouseDownClosingTab := Tab;\r\n SetClosingTab(Tab);\r\n end;\r\n inherited MouseDown(Button, Shift, X, Y);\r\n Exit;\r\n end;\r\n end;\r\n if (FClosingTab = nil) and AllowTabMoving and\r\n ([ssLeft, ssMiddle, ssRight] * Shift = [ssLeft]) then\r\n BeginDrag(False);\r\n end;\r\n inherited MouseDown(Button, Shift, X, Y);\r\nend;\r\n\r\nprocedure TJvCustomTabBar.MouseUp(Button: TMouseButton; Shift: TShiftState;\r\n X, Y: Integer);\r\nvar\r\n Pt: TPoint;\r\n Tab: TJvTabBarItem;\r\nbegin\r\n if ScrollButtonsMouseUp(Button, Shift, X, Y) then\r\n Exit;\r\n\r\n try\r\n if RightClickSelect and not (PopupMenu <> nil) and (Button = mbRight) then\r\n begin\r\n Tab := TabAt(X, Y);\r\n if Tab <> nil then\r\n SelectedTab := Tab;\r\n if (Tab <> nil) and (Tab.PopupMenu <> nil) then\r\n begin\r\n Pt := ClientToScreen(Point(X, Y));\r\n Tab.PopupMenu.Popup(Pt.X, Pt.Y);\r\n end;\r\n end\r\n else\r\n if Button = mbLeft then\r\n begin\r\n if (FClosingTab <> nil) and CloseButton then\r\n begin\r\n CalcTabsRects;\r\n if PtInRect(CurrentPainter.GetCloseRect(Canvas, FClosingTab, FClosingTab.DisplayRect), Point(X, Y)) then\r\n begin\r\n if TabCloseQuery(FClosingTab) then\r\n TabClosed(FClosingTab)\r\n end;\r\n end;\r\n end;\r\n finally\r\n FMouseDownClosingTab := nil;\r\n SetClosingTab(nil);\r\n end;\r\n inherited MouseUp(Button, Shift, X, Y);\r\nend;\r\n\r\nprocedure TJvCustomTabBar.MouseMove(Shift: TShiftState; X, Y: Integer);\r\nvar\r\n Tab: TJvTabBarItem;\r\n NewHint: TCaption;\r\nbegin\r\n CalcTabsRects; // maybe inefficent\r\n if ScrollButtonsMouseMove(Shift, X, Y) then\r\n Exit;\r\n\r\n Tab := TabAt(X, Y);\r\n if HotTracking and ([ssLeft, ssMiddle, ssRight] * Shift = []) then\r\n SetHotTab(Tab);\r\n\r\n if CloseButton and (FMouseDownClosingTab <> nil) and (ssLeft in Shift) then\r\n begin\r\n if PtInRect(CurrentPainter.GetCloseRect(Canvas, FMouseDownClosingTab,\r\n FMouseDownClosingTab.DisplayRect), Point(X, Y)) then\r\n SetClosingTab(FMouseDownClosingTab)\r\n else\r\n SetClosingTab(nil)\r\n end;\r\n\r\n if (Tab <> nil) and Tab.ShowHint then\r\n NewHint := Tab.Hint\r\n else\r\n NewHint := FHint;\r\n\r\n if NewHint <> inherited Hint then\r\n begin\r\n Application.CancelHint;\r\n ShowHint := False;\r\n ShowHint := True;\r\n inherited Hint := NewHint;\r\n end;\r\n\r\n inherited MouseMove(Shift, X, Y);\r\nend;\r\n\r\nfunction TJvCustomTabBar.ScrollButtonsMouseDown(Button: TMouseButton;\r\n Shift: TShiftState; X, Y: Integer): Boolean;\r\n\r\n function HandleButton(Kind: TJvTabBarScrollButtonKind; var State: TJvTabBarScrollButtonState;\r\n X, Y: Integer; const R: TRect): Boolean;\r\n begin\r\n Result := PtInRect(R, Point(X, Y));\r\n case State of\r\n sbsNormal, sbsHot:\r\n begin\r\n if Result then\r\n begin\r\n State := sbsPressed;\r\n PaintScrollButtons;\r\n\r\n if FRepeatTimer = nil then\r\n FRepeatTimer := TTimer.Create(Self);\r\n FRepeatTimer.OnTimer := TimerExpired;\r\n FRepeatTimer.Interval := 400;\r\n FRepeatTimer.Enabled := True;\r\n FRepeatTimer.Tag := Integer(Kind);\r\n FScrollRepeatedClicked := False;\r\n end;\r\n end;\r\n end;\r\n end;\r\n\r\nbegin\r\n Result := False;\r\n if (FBtnLeftScroll.State <> sbsHidden) then\r\n Result := HandleButton(sbScrollLeft, FBtnLeftScroll.State, X, Y, FBtnLeftScroll.Rect);\r\n if not Result and (FBtnRightScroll.State <> sbsHidden) then\r\n Result := HandleButton(sbScrollRight, FBtnRightScroll.State, X, Y, FBtnRightScroll.Rect);\r\nend;\r\n\r\nfunction TJvCustomTabBar.ScrollButtonsMouseMove(Shift: TShiftState; X, Y: Integer): Boolean;\r\n\r\n function HandleButton(var ExState: Boolean; var State: TJvTabBarScrollButtonState;\r\n X, Y: Integer; const R: TRect): Boolean;\r\n begin\r\n Result := PtInRect(R, Point(X, Y));\r\n case State of\r\n sbsNormal:\r\n begin\r\n if Result then\r\n begin\r\n State := sbsHot;\r\n PaintScrollButtons;\r\n Result := True;\r\n end;\r\n end;\r\n sbsPressed:\r\n begin\r\n if not Result then\r\n begin\r\n ExState := True;\r\n State := sbsNormal;\r\n PaintScrollButtons;\r\n State := sbsPressed;\r\n end\r\n else\r\n begin\r\n if ExState then\r\n begin\r\n ExState := False;\r\n PaintScrollButtons;\r\n end;\r\n end;\r\n end;\r\n sbsHot:\r\n begin\r\n if not Result then\r\n begin\r\n State := sbsNormal;\r\n PaintScrollButtons;\r\n end;\r\n end;\r\n end;\r\n end;\r\n\r\nbegin\r\n Result := False;\r\n if (FBtnLeftScroll.State <> sbsHidden) then\r\n Result := HandleButton(FBtnLeftScroll.ExState, FBtnLeftScroll.State, X, Y, FBtnLeftScroll.Rect);\r\n if not Result and (FBtnRightScroll.State <> sbsHidden) then\r\n Result := HandleButton(FBtnRightScroll.ExState, FBtnRightScroll.State, X, Y, FBtnRightScroll.Rect);\r\nend;\r\n\r\nfunction TJvCustomTabBar.ScrollButtonsMouseUp(Button: TMouseButton;\r\n Shift: TShiftState; X, Y: Integer): Boolean;\r\n\r\n function HandleButton(Kind: TJvTabBarScrollButtonKind; var State: TJvTabBarScrollButtonState;\r\n X, Y: Integer; const R: TRect): Boolean;\r\n begin\r\n Result := PtInRect(R, Point(X, Y));\r\n case State of\r\n sbsPressed:\r\n begin\r\n FreeAndNil(FRepeatTimer);\r\n State := sbsNormal;\r\n PaintScrollButtons;\r\n if Result and not FScrollRepeatedClicked then\r\n ScrollButtonClick(Kind);\r\n FScrollRepeatedClicked := False;\r\n end;\r\n end;\r\n end;\r\n\r\nbegin\r\n Result := False;\r\n if (FBtnLeftScroll.State <> sbsHidden) then\r\n Result := HandleButton(sbScrollLeft, FBtnLeftScroll.State, X, Y, FBtnLeftScroll.Rect);\r\n if not Result and (FBtnRightScroll.State <> sbsHidden) then\r\n Result := HandleButton(sbScrollRight, FBtnRightScroll.State, X, Y, FBtnRightScroll.Rect);\r\nend;\r\n\r\nprocedure TJvCustomTabBar.TimerExpired(Sender: TObject);\r\nvar\r\n Kind: TJvTabBarScrollButtonKind;\r\n State: TJvTabBarScrollButtonState;\r\nbegin\r\n FRepeatTimer.Interval := 100;\r\n Kind := TJvTabBarScrollButtonKind(FRepeatTimer.Tag);\r\n case Kind of\r\n sbScrollLeft:\r\n State := FBtnLeftScroll.State;\r\n sbScrollRight:\r\n State := FBtnRightScroll.State;\r\n else\r\n Exit;\r\n end;\r\n\r\n if (State = sbsPressed) and Enabled {and MouseCapture} then\r\n begin\r\n try\r\n FScrollRepeatedClicked := True;\r\n ScrollButtonClick(Kind);\r\n case Kind of\r\n sbScrollLeft:\r\n if not (FBtnLeftScroll.State in [sbsHidden, sbsDisabled]) then\r\n FBtnLeftScroll.State := sbsPressed;\r\n sbScrollRight:\r\n if not (FBtnRightScroll.State in [sbsHidden, sbsDisabled]) then\r\n FBtnRightScroll.State := sbsPressed;\r\n end;\r\n except\r\n FRepeatTimer.Enabled := False;\r\n raise;\r\n end;\r\n end\r\n else\r\n FreeAndNil(FRepeatTimer);\r\nend;\r\n\r\nprocedure TJvCustomTabBar.SetHotTab(Tab: TJvTabBarItem);\r\nbegin\r\n if (csDestroying in ComponentState) or not HotTracking then\r\n FHotTab := nil\r\n else\r\n if Tab <> FHotTab then\r\n begin\r\n FHotTab := Tab;\r\n if poPaintsHotTab in CurrentPainter.Options then\r\n Paint;\r\n end;\r\nend;\r\n\r\nfunction TJvCustomTabBar.CloseTab(ATab: TJvTabBarItem): Boolean;\r\nbegin\r\n Result := False;\r\n if ATab <> nil then\r\n begin\r\n FClosingTab := ATab;\r\n try\r\n Result := TabCloseQuery(FClosingTab);\r\n if Result then\r\n TabClosed(FClosingTab);\r\n finally\r\n FClosingTab := nil;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJvCustomTabBar.AddTab(const Caption: string): TJvTabBarItem;\r\nbegin\r\n Result := TJvTabBarItem(Tabs.Add);\r\n Result.Caption := Caption;\r\nend;\r\n\r\nfunction TJvCustomTabBar.FindTab(const Caption: string): TJvTabBarItem;\r\nvar\r\n i: Integer;\r\nbegin\r\n for i := 0 to Tabs.Count - 1 do\r\n if Caption = Tabs[i].Caption then\r\n begin\r\n Result := Tabs[i];\r\n Exit;\r\n end;\r\n Result := nil;\r\nend;\r\n\r\nprocedure TJvCustomTabBar.CalcTabsRects;\r\nvar\r\n I, X: Integer;\r\n Tab: TJvTabBarItem;\r\n Offset: Integer;\r\n Index: Integer;\r\nbegin\r\n if csDestroying in ComponentState then\r\n Exit;\r\n\r\n Offset := 0;\r\n X := Margin; // adjust for scrolled area\r\n Index := 0;\r\n for I := 0 to Tabs.Count - 1 do\r\n begin\r\n Tab := Tabs[I];\r\n if Tab.Visible then\r\n begin\r\n Tab.FLeft := X;\r\n Inc(X, GetTabWidth(Tab));\r\n Inc(X, CurrentPainter.GetDividerWidth(Canvas, Tab));\r\n if Index < FLeftIndex then\r\n begin\r\n Inc(Offset, X); // this tab is placed too left.\r\n X := 0;\r\n Tab.FLeft := -Offset - 10;\r\n end;\r\n Inc(Index);\r\n end\r\n else\r\n Tab.FLeft := -1;\r\n end;\r\n\r\n FRequiredWidth := X + Offset;\r\n FLastTabRight := X;\r\nend;\r\n\r\nprocedure TJvCustomTabBar.Paint;\r\nvar\r\n I: Integer;\r\n Bmp: TBitmap;\r\n R: TRect;\r\nbegin\r\n CalcTabsRects;\r\n Bmp := TBitmap.Create;\r\n try\r\n Bmp.Width := ClientWidth;\r\n Bmp.Height := ClientHeight;\r\n CurrentPainter.DrawBackground(Bmp.Canvas, Self, ClientRect);\r\n if (FBtnLeftScroll.State <> sbsHidden) and (FBtnRightScroll.State <> sbsHidden) then\r\n begin\r\n if FScrollButtonBackground = nil then\r\n FScrollButtonBackground := TBitmap.Create;\r\n FScrollButtonBackground.Width := Bmp.Width - FBarWidth;\r\n FScrollButtonBackground.Height := Bmp.Height;\r\n R := Rect(FBarWidth, 0, Bmp.Width, Bmp.Height);\r\n FScrollButtonBackground.Canvas.CopyRect(Rect(0, 0, FScrollButtonBackground.Width, R.Bottom), Bmp.Canvas, R);\r\n PaintScrollButtons;\r\n if FBarWidth > 0 then\r\n Bmp.Width := FBarWidth;\r\n end;\r\n\r\n if FBarWidth > 0 then\r\n for I := 0 to Tabs.Count - 1 do\r\n if Tabs[I].Visible then\r\n PaintTab(Bmp.Canvas, Tabs[I]);\r\n Canvas.Draw(0, 0, Bmp);\r\n finally\r\n Bmp.Free;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomTabBar.PaintTab(Canvas: TCanvas; Tab: TJvTabBarItem);\r\nvar\r\n R: TRect;\r\nbegin\r\n if csDestroying in ComponentState then\r\n Exit;\r\n\r\n if Tab.Visible then\r\n begin\r\n R := Tab.DisplayRect;\r\n if (R.Right >= 0) and (R.Left < FBarWidth) then\r\n begin\r\n CurrentPainter.DrawTab(Canvas, Tab, R);\r\n R.Left := R.Right;\r\n R.Right := R.Left + CurrentPainter.GetDividerWidth(Canvas, Tab) - 1;\r\n CurrentPainter.DrawDivider(Canvas, Tab, R);\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomTabBar.PaintScrollButtons;\r\nbegin\r\n if (FScrollButtonBackground = nil) and Visible then\r\n Paint\r\n else // paint scroll button's background and the buttons\r\n Canvas.Draw(FBarWidth, 0, FScrollButtonBackground);\r\n\r\n CurrentPainter.DrawScrollButton(Canvas, Self, sbScrollLeft, FBtnLeftScroll.State, FBtnLeftScroll.Rect);\r\n CurrentPainter.DrawScrollButton(Canvas, Self, sbScrollRight, FBtnRightScroll.State, FBtnRightScroll.Rect);\r\nend;\r\n\r\nfunction TJvCustomTabBar.GetTabHeight(Tab: TJvTabBarItem): Integer;\r\nbegin\r\n Result := Abs(CurrentPainter.GetTabSize(Canvas, Tab).cy);\r\n if Result > High(Word) then\r\n Result := High(Word);\r\nend;\r\n\r\nfunction TJvCustomTabBar.GetTabWidth(Tab: TJvTabBarItem): Integer;\r\nbegin\r\n Result := Abs(CurrentPainter.GetTabSize(Canvas, Tab).cx);\r\n if Result > High(Word) then\r\n Result := High(Word);\r\nend;\r\n\r\nfunction TJvCustomTabBar.TabAt(X, Y: Integer): TJvTabBarItem;\r\nvar\r\n I: Integer;\r\n Pt: TPoint;\r\nbegin\r\n if (FBtnLeftScroll.State = sbsHidden) or (X < FBarWidth) then\r\n begin\r\n CalcTabsRects;\r\n Pt := Point(X, Y);\r\n for I := 0 to Tabs.Count - 1 do\r\n if PtInRect(Tabs[I].DisplayRect, Pt) then\r\n begin\r\n Result := Tabs[I];\r\n Exit;\r\n end;\r\n end;\r\n Result := nil;\r\nend;\r\n\r\nprocedure TJvCustomTabBar.SetClosingTab(Tab: TJvTabBarItem);\r\nbegin\r\n if Tab <> FClosingTab then\r\n begin\r\n FClosingTab := Tab; // this tab should be TabClosed\r\n Paint;\r\n end;\r\nend;\r\n\r\nfunction TJvCustomTabBar.GetLeftTab: TJvTabBarItem;\r\nbegin\r\n if (Tabs <> nil) and (FLeftIndex < Tabs.Count) then\r\n begin\r\n Result := Tabs[FLeftIndex];\r\n if not Result.Visible then\r\n Result := Result.GetNextVisible;\r\n end\r\n else\r\n Result := nil;\r\nend;\r\n\r\nprocedure TJvCustomTabBar.SetLeftTab(Value: TJvTabBarItem);\r\nvar\r\n Index: Integer;\r\n Tab: TJvTabBarItem;\r\nbegin\r\n Index := 0;\r\n if Value <> nil then\r\n begin\r\n // find first visible before or at Value.Index\r\n if (Tabs <> nil) and (Tabs.Count > 0) and (Value <> Tabs[0]) then\r\n begin\r\n while Index < Tabs.Count do\r\n begin\r\n Tab := Tabs[Index].GetNextVisible;\r\n if Tab = nil then\r\n begin\r\n Index := FLeftIndex; // do not change\r\n Break;\r\n end\r\n else\r\n begin\r\n Index := Tab.Index;\r\n if Tab.Index >= Value.Index then\r\n Break;\r\n end;\r\n end;\r\n if Index >= Tabs.Count then\r\n Index := FLeftIndex; // do not change\r\n end;\r\n end;\r\n if Index <> FLeftIndex then\r\n begin\r\n FLeftIndex := Index;\r\n Invalidate;\r\n UpdateScrollButtons;\r\n LeftTabChanged;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomTabBar.UpdateScrollButtons;\r\nconst\r\n State: array[Boolean] of TJvTabBarScrollButtonState = (sbsDisabled, sbsNormal);\r\n BtnSize = 12;\r\nbegin\r\n CalcTabsRects;\r\n if (FRequiredWidth < ClientWidth) or ((FLeftIndex = 0) and\r\n (FLastTabRight <= ClientWidth)) then\r\n begin\r\n FBtnLeftScroll.State := sbsHidden;\r\n FBtnRightScroll.State := sbsHidden;\r\n FLeftIndex := 0;\r\n FBarWidth := ClientWidth;\r\n Invalidate;\r\n end\r\n else\r\n begin\r\n FBtnLeftScroll.State := sbsNormal;\r\n FBtnRightScroll.State := sbsNormal;\r\n\r\n if poBottomScrollButtons in CurrentPainter.Options then\r\n begin\r\n FBtnLeftScroll.Rect := Bounds(ClientWidth - BtnSize * 2 - 1 - 1,\r\n ClientHeight - BtnSize - 2, BtnSize, BtnSize);\r\n FBtnRightScroll.Rect := Bounds(FBtnLeftScroll.Rect.Right,\r\n ClientHeight - BtnSize - 2, BtnSize, BtnSize);\r\n end\r\n else\r\n begin\r\n FBtnLeftScroll.Rect := Bounds(ClientWidth - BtnSize * 2 - 1 - 1, 2, BtnSize, BtnSize);\r\n FBtnRightScroll.Rect := Bounds(FBtnLeftScroll.Rect.Right, 2, BtnSize, BtnSize);\r\n end;\r\n if not FlatScrollButtons then\r\n OffsetRect(FBtnRightScroll.Rect, -1, 0);\r\n\r\n //CurrentPainter.GetScrollButtons(Self, FBtnLeftScroll.Rect, FBtnRightScroll.Rect);\r\n\r\n FBarWidth := FBtnLeftScroll.Rect.Left - 2;\r\n\r\n FBtnLeftScroll.State := State[FLeftIndex > 0];\r\n FBtnRightScroll.State := State[FLastTabRight >= ClientWidth];\r\n\r\n PaintScrollButtons;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomTabBar.Resize;\r\nbegin\r\n UpdateScrollButtons;\r\n inherited Resize;\r\nend;\r\n\r\nprocedure TJvCustomTabBar.ScrollButtonClick(Button: TJvTabBarScrollButtonKind);\r\nbegin\r\n if Button = sbScrollLeft then\r\n begin\r\n if FBtnLeftScroll.State in [sbsHidden, sbsDisabled] then\r\n Exit;\r\n Dec(FLeftIndex);\r\n end\r\n else\r\n if Button = sbScrollRight then\r\n begin\r\n if FBtnRightScroll.State in [sbsHidden, sbsDisabled] then\r\n Exit;\r\n Inc(FLeftIndex);\r\n end;\r\n UpdateScrollButtons;\r\n Invalidate;\r\n if Assigned(FOnScrollButtonClick) then\r\n FOnScrollButtonClick(Self, Button);\r\n LeftTabChanged;\r\nend;\r\n\r\nfunction TJvCustomTabBar.MakeVisible(Tab: TJvTabBarItem): Boolean;\r\nvar\r\n R: TRect;\r\n LastLeftIndex: Integer;\r\n AtLeft: Boolean;\r\nbegin\r\n Result := False;\r\n if (Tab = nil) or not Tab.Visible then\r\n Exit;\r\n\r\n LastLeftIndex := FLeftIndex;\r\n if FBarWidth > 0 then\r\n begin\r\n AtLeft := False;\r\n repeat\r\n CalcTabsRects;\r\n R := Tab.DisplayRect;\r\n if (R.Right > FBarWidth) and not AtLeft then\r\n Inc(FLeftIndex)\r\n else\r\n if R.Left < 0 then\r\n begin\r\n Dec(FLeftIndex);\r\n AtLeft := True; // prevent an endless loop\r\n end\r\n else\r\n Break;\r\n until FLeftIndex = Tabs.Count - 1;\r\n end\r\n else\r\n FLeftIndex := 0;\r\n if (R.Left < 0) and (FLeftIndex > 0) then\r\n Dec(FLeftIndex); // bar is too small\r\n if FLeftIndex <> LastLeftIndex then\r\n begin\r\n UpdateScrollButtons;\r\n Invalidate;\r\n LeftTabChanged;\r\n end;\r\nend;\r\n\r\nfunction TJvCustomTabBar.FindData(Data: TObject): TJvTabBarItem;\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := 0 to Tabs.Count - 1 do\r\n if Tabs[I].Data = Data then\r\n begin\r\n Result := Tabs[I];\r\n Exit;\r\n end;\r\n Result := nil;\r\nend;\r\n\r\nprocedure TJvCustomTabBar.SetHint(const Value: TCaption);\r\nbegin\r\n if Value <> FHint then\r\n FHint := Value;\r\nend;\r\n\r\nprocedure TJvCustomTabBar.SetFlatScrollButtons(const Value: Boolean);\r\nbegin\r\n if Value <> FFlatScrollButtons then\r\n begin\r\n FFlatScrollButtons := Value;\r\n FBtnLeftScroll.State := sbsHidden;\r\n FBtnRightScroll.State := sbsHidden;\r\n UpdateScrollButtons;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomTabBar.SetPageList(const Value: TCustomControl);\r\nvar\r\n PageListIntf: IPageList;\r\nbegin\r\n if Value <> FPageList then\r\n begin\r\n if Value <> nil then\r\n begin\r\n if not Supports(Value, IPageList, PageListIntf) then\r\n Exit;\r\n if SelectedTab <> nil then\r\n PageListIntf.SetActivePageIndex(SelectedTab.Index)\r\n else\r\n PageListIntf.SetActivePageIndex(0);\r\n PageListIntf := nil;\r\n end;\r\n if FPageList <> nil then\r\n FPageList.RemoveFreeNotification(Self);\r\n FPageList := Value;\r\n if FPageList <> nil then\r\n FPageList.FreeNotification(Self);\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomTabBar.SetOrientation(const Value: TJvTabBarOrientation);\r\nbegin\r\n if Value <> FOrientation then\r\n begin\r\n FOrientation := Value;\r\n CalcTabsRects;\r\n Repaint;\r\n end;\r\nend;\r\n\r\n//=== { TJvTabBarItem } ======================================================\r\n\r\nconstructor TJvTabBarItem.Create(Collection: Classes.TCollection);\r\nbegin\r\n inherited Create(Collection);\r\n FImageIndex := -1;\r\n FEnabled := True;\r\n FVisible := True;\r\n FShowHint := True;\r\nend;\r\n\r\ndestructor TJvTabBarItem.Destroy;\r\nbegin\r\n PopupMenu := nil;\r\n Visible := False; // CanSelect returns false\r\n FAutoDeleteDatas.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvTabBarItem.Assign(Source: TPersistent);\r\nbegin\r\n if Source is TJvTabBarItem then\r\n begin\r\n with TJvTabBarItem(Source) do\r\n begin\r\n Self.FImageIndex := FImageIndex;\r\n Self.FEnabled := FEnabled;\r\n Self.FVisible := FVisible;\r\n Self.FTag := FTag;\r\n Self.FData := FData;\r\n Self.FHint := FHint;\r\n Self.FShowHint := FShowHint;\r\n Self.FName := FName;\r\n Self.FCaption := FCaption;\r\n Self.FModified := FModified;\r\n Self.FImages := FImages;\r\n Changed;\r\n end;\r\n end\r\n else\r\n inherited Assign(Source);\r\nend;\r\n\r\nprocedure TJvTabBarItem.Notification(Component: TComponent;\r\n Operation: TOperation);\r\nbegin\r\n if Operation = opRemove then\r\n if Component = PopupMenu then\r\n PopupMenu := nil;\r\nend;\r\n\r\nprocedure TJvTabBarItem.Changed;\r\nbegin\r\n TabBar.Changed;\r\nend;\r\n\r\nfunction TJvTabBarItem.GetDisplayRect: TRect;\r\nbegin\r\n if not Visible then\r\n Result := Rect(-1, -1, -1, -1)\r\n else\r\n begin\r\n if FLeft = -1 then\r\n TabBar.CalcTabsRects; // not initialized\r\n\r\n case TabBar.Orientation of\r\n toBottom:\r\n Result := Rect(FLeft, 0,\r\n FLeft + TabBar.GetTabWidth(Self), 0 + TabBar.GetTabHeight(Self));\r\n else\r\n // toTop\r\n Result := Rect(FLeft, TabBar.ClientHeight - TabBar.GetTabHeight(Self),\r\n FLeft + TabBar.GetTabWidth(Self), TabBar.ClientHeight);\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJvTabBarItem.GetHot: Boolean;\r\nbegin\r\n Result := TabBar.HotTab = Self;\r\nend;\r\n\r\nfunction TJvTabBarItem.GetImages: TCustomImageList;\r\nbegin\r\n Result := TabBar.Images;\r\nend;\r\n\r\nfunction TJvTabBarItem.GetSelected: Boolean;\r\nbegin\r\n Result := TabBar.SelectedTab = Self;\r\nend;\r\n\r\nfunction TJvTabBarItem.GetTabBar: TJvCustomTabBar;\r\nbegin\r\n Result := (GetOwner as TJvTabBarItems).TabBar;\r\nend;\r\n\r\nprocedure TJvTabBarItem.SetCaption(const Value: TCaption);\r\nvar\r\n PageListIntf: IPageList;\r\nbegin\r\n if Value <> FCaption then\r\n begin\r\n FCaption := Value;\r\n if TabBar.PageListTabLink and (TabBar.PageList <> nil) and\r\n not (csLoading in TabBar.ComponentState) and\r\n Supports(TabBar.PageList, IPageList, PageListIntf) then\r\n PageListIntf.PageCaptionChanged(Index, FCaption);\r\n Changed;\r\n end;\r\nend;\r\n\r\nprocedure TJvTabBarItem.SetEnabled(const Value: Boolean);\r\nbegin\r\n if Value <> FEnabled then\r\n begin\r\n FEnabled := Value;\r\n Changed;\r\n end;\r\nend;\r\n\r\nprocedure TJvTabBarItem.SetImageIndex(const Value: TImageIndex);\r\nbegin\r\n if Value <> FImageIndex then\r\n begin\r\n FImageIndex := Value;\r\n Changed;\r\n end;\r\nend;\r\n\r\nprocedure TJvTabBarItem.SetName(const Value: string);\r\nbegin\r\n if (Value <> FName) and (TJvTabBarItems(Collection).Find(Value) = nil) then\r\n FName := Value;\r\nend;\r\n\r\nprocedure TJvTabBarItem.SetSelected(const Value: Boolean);\r\nbegin\r\n if Value then\r\n TabBar.SelectedTab := Self;\r\nend;\r\n\r\nprocedure TJvTabBarItem.SetVisible(const Value: Boolean);\r\nbegin\r\n if Value <> FVisible then\r\n begin\r\n FVisible := Value;\r\n FLeft := -1; // discard\r\n Changed;\r\n end;\r\nend;\r\n\r\nfunction TJvTabBarItem.CanSelect: Boolean;\r\nbegin\r\n Result := Visible and Enabled;\r\nend;\r\n\r\nfunction TJvTabBarItem.GetNextVisible: TJvTabBarItem;\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := Index + 1 to TabBar.Tabs.Count - 1 do\r\n if TabBar.Tabs[I].Visible then\r\n begin\r\n Result := TabBar.Tabs[I];\r\n Exit;\r\n end;\r\n Result := nil;\r\nend;\r\n\r\nfunction TJvTabBarItem.GetPreviousVisible: TJvTabBarItem;\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := Index - 1 downto 0 do\r\n if TabBar.Tabs[I].Visible then\r\n begin\r\n Result := TabBar.Tabs[I];\r\n Exit;\r\n end;\r\n Result := nil;\r\nend;\r\n\r\nfunction TJvTabBarItem.AutoDeleteData: TObjectList;\r\nbegin\r\n if FAutoDeleteDatas = nil then\r\n FAutoDeleteDatas := TObjectList.Create;\r\n Result := FAutoDeleteDatas;\r\nend;\r\n\r\nfunction TJvTabBarItem.GetClosing: Boolean;\r\nbegin\r\n Result := TabBar.ClosingTab = Self;\r\nend;\r\n\r\nprocedure TJvTabBarItem.SetModified(const Value: Boolean);\r\nbegin\r\n if Value <> FModified then\r\n begin\r\n FModified := Value;\r\n Changed;\r\n end;\r\nend;\r\n\r\nprocedure TJvTabBarItem.SetPopupMenu(const Value: TPopupMenu);\r\nbegin\r\n if Value <> FPopupMenu then\r\n begin\r\n if FPopupMenu <> nil then\r\n FPopupMenu.RemoveFreeNotification(TabBar);\r\n FPopupMenu := Value;\r\n if FPopupMenu <> nil then\r\n FPopupMenu.FreeNotification(TabBar);\r\n end;\r\nend;\r\n\r\nprocedure TJvTabBarItem.MakeVisible;\r\nbegin\r\n TabBar.MakeVisible(Self);\r\nend;\r\n\r\nfunction TJvTabBarItem.GetEnabled: Boolean;\r\nbegin\r\n Result := FEnabled;\r\n if Assigned(FOnGetEnabled) then\r\n FOnGetEnabled(Self, Result);\r\nend;\r\n\r\nfunction TJvTabBarItem.GetModified: Boolean;\r\nbegin\r\n Result := FModified;\r\n if Assigned(FOnGetModified) then\r\n FOnGetModified(Self, Result);\r\nend;\r\n\r\nprocedure TJvTabBarItem.SetIndex(Value: Integer);\r\nvar\r\n PageListIntf: IPageList;\r\n LastIndex: Integer;\r\nbegin\r\n LastIndex := Index;\r\n inherited SetIndex(Value);\r\n if TabBar.PageListTabLink and (LastIndex <> Index) and (TabBar.PageList <> nil) and\r\n not (csLoading in TabBar.ComponentState) and\r\n Supports(TabBar.PageList, IPageList, PageListIntf) then\r\n PageListIntf.MovePage(LastIndex, Index);\r\n Changed;\r\nend;\r\n\r\n//=== { TJvTabBarItems } =====================================================\r\n\r\nprocedure TJvTabBarItems.EndUpdate;\r\nbegin\r\n inherited EndUpdate;\r\n if UpdateCount = 0 then\r\n TabBar.Changed;\r\nend;\r\n\r\nfunction TJvTabBarItems.Find(const AName: string): TJvTabBarItem;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := nil;\r\n for I := 0 to Count - 1 do\r\n if Items[I].Name = AName then\r\n begin\r\n Result := Items[I];\r\n Break;\r\n end;\r\nend;\r\n\r\nfunction TJvTabBarItems.GetTabBar: TJvCustomTabBar;\r\nbegin\r\n Result := GetOwner as TJvCustomTabBar;\r\nend;\r\n\r\nfunction TJvTabBarItems.GetItem(Index: Integer): TJvTabBarItem;\r\nbegin\r\n Result := TJvTabBarItem(inherited Items[Index]);\r\nend;\r\n\r\nprocedure TJvTabBarItems.SetItem(Index: Integer; const Value: TJvTabBarItem);\r\nbegin\r\n if Value <> GetItem(Index) then\r\n GetItem(Index).Assign(Value);\r\nend;\r\n\r\nprocedure TJvTabBarItems.Notify(Item: TCollectionItem; Action: TCollectionNotification);\r\nvar\r\n PageListIntf: IPageList;\r\nbegin\r\n inherited Notify(Item, Action);\r\n if Action in [cnExtracting, cnDeleting] then\r\n begin\r\n // unselect the item to delete\r\n if TabBar.SelectedTab = Item then\r\n TabBar.SelectedTab := nil;\r\n if TabBar.HotTab = Item then\r\n TabBar.SetHotTab(nil);\r\n if TabBar.FMouseDownClosingTab = Item then\r\n TabBar.FMouseDownClosingTab := nil;\r\n if TabBar.ClosingTab = Item then\r\n TabBar.FClosingTab := nil;\r\n if TabBar.FLastInsertTab = Item then\r\n TabBar.FLastInsertTab := nil;\r\n if not (csDestroying in TabBar.ComponentState) and (TabBar.LeftTab = Item) then\r\n TabBar.LeftTab := TabBar.LeftTab.GetPreviousVisible;\r\n end;\r\n if TabBar.PageListTabLink and (TabBar.PageList <> nil) and\r\n not (csLoading in TabBar.ComponentState) and\r\n Supports(TabBar.PageList, IPageList, PageListIntf) then\r\n begin\r\n case Action of\r\n cnAdded:\r\n PageListIntf.AddPage(TJvTabBarItem(Item).Caption);\r\n cnExtracting, cnDeleting:\r\n PageListIntf.DeletePage(TJvTabBarItem(Item).Index);\r\n end;\r\n end;\r\n TabBar.Changed;\r\nend;\r\n\r\nfunction TJvTabBarItems.IndexOf(Item: TJvTabBarItem): Integer;\r\nbegin\r\n for Result := 0 to Count - 1 do\r\n if Items[Result] = Item then\r\n Exit;\r\n Result := -1;\r\nend;\r\n\r\n//=== { TJvTabBarPainter } ===================================================\r\n\r\nconstructor TJvTabBarPainter.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FOnChangeList := TList.Create;\r\nend;\r\n\r\ndestructor TJvTabBarPainter.Destroy;\r\nbegin\r\n inherited Destroy; // invokes TJvTabBar.Notification that accesses FOnChangeList\r\n FOnChangeList.Free;\r\nend;\r\n\r\nprocedure TJvTabBarPainter.Changed;\r\nvar\r\n i: Integer;\r\nbegin\r\n for i := 0 to FOnChangeList.Count - 1 do\r\n TJvCustomTabBar(FOnChangeList[i]).ImagesChanged(Self);\r\nend;\r\n\r\nprocedure TJvTabBarPainter.GetScrollButtons(TabBar: TJvCustomTabBar; var LeftButton, RightButton: TRect);\r\nbegin\r\n { reserved for future use }\r\nend;\r\n\r\nprocedure TJvTabBarPainter.DrawScrollButton(Canvas: TCanvas; TabBar: TJvCustomTabBar; Button: TJvTabBarScrollButtonKind;\r\n State: TJvTabBarScrollButtonState; R: TRect);\r\n{$IFDEF JVCLThemesEnabled}\r\nconst\r\n States: array[TJvTabBarScrollButtonState] of Integer = (0, 0, DFCS_HOT, DFCS_PUSHED, DFCS_INACTIVE);\r\n ScrollTypes: array[TJvTabBarScrollButtonKind] of Integer = (DFCS_SCROLLLEFT, DFCS_SCROLLRIGHT);\r\n{$ENDIF JVCLThemesEnabled}\r\nbegin\r\n {$IFDEF JVCLThemesEnabled}\r\n if ThemeServices.{$IFDEF RTL230_UP}Enabled{$ELSE}ThemesEnabled{$ENDIF RTL230_UP} then\r\n DrawThemedFrameControl(Canvas.Handle, R, DFC_SCROLL, ScrollTypes[Button] or States[State])\r\n else\r\n {$ENDIF JVCLThemesEnabled}\r\n begin\r\n if TabBar.FlatScrollButtons then\r\n DrawButtonFace(Canvas, R, 1, bsNew, False, State = sbsPressed, False)\r\n else\r\n DrawButtonFace(Canvas, R, 1, bsWin31, False, State = sbsPressed, False);\r\n if State = sbsPressed then\r\n OffsetRect(R, 1, 1);\r\n TabBar.DrawScrollBarGlyph(Canvas,\r\n R.Left + (R.Right - R.Left - 4) div 2,\r\n R.Top + (R.Bottom - R.Top - 7) div 2,\r\n Button = sbScrollLeft, State = sbsDisabled);\r\n end;\r\nend;\r\n\r\n//=== { TJvModernTabBarPainter } =============================================\r\n\r\nconstructor TJvModernTabBarPainter.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FFont := TFont.Create;\r\n FDisabledFont := TFont.Create;\r\n FSelectedFont := TFont.Create;\r\n\r\n FFont.Color := clWindowText;\r\n FDisabledFont.Color := clGrayText;\r\n FSelectedFont.Assign(FFont);\r\n\r\n FFont.OnChange := FontChanged;\r\n FDisabledFont.OnChange := FontChanged;\r\n FSelectedFont.OnChange := FontChanged;\r\n\r\n FTabColor := clBtnFace;\r\n FColor := clWindow;\r\n FBorderColor := clSilver;\r\n FControlDivideColor := clBlack;\r\n\r\n FModifiedCrossColor := clRed;\r\n FCloseColorSelected := $F4F4F4;\r\n FCloseColor := clWhite;\r\n FCloseCrossColorSelected := clBlack;\r\n FCloseCrossColor := $5D5D5D;\r\n FCloseCrossColorDisabled := $ADADAD;\r\n FCloseRectColor := $868686;\r\n FCloseRectColorDisabled := $D6D6D6;\r\n FDividerColor := $99A8AC;\r\n FMoveDividerColor := clBlack;\r\nend;\r\n\r\ndestructor TJvModernTabBarPainter.Destroy;\r\nbegin\r\n FFont.Free;\r\n FDisabledFont.Free;\r\n FSelectedFont.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvModernTabBarPainter.DrawBackground(Canvas: TCanvas; TabBar: TJvCustomTabBar; R: TRect);\r\nbegin\r\n with Canvas do\r\n begin\r\n Brush.Style := bsSolid;\r\n Brush.Color := Color;\r\n FillRect(R);\r\n\r\n Brush.Style := bsClear;\r\n Pen.Color := BorderColor;\r\n Pen.Width := 1;\r\n if TabBar.Orientation = toBottom then\r\n begin\r\n MoveTo(0, R.Bottom - 1);\r\n LineTo(0, 0);\r\n Pen.Color := ControlDivideColor;\r\n LineTo(R.Right - 1, 0);\r\n Pen.Color := BorderColor;\r\n LineTo(R.Right - 1, R.Bottom - 1);\r\n LineTo(0, R.Bottom - 1);\r\n end\r\n else // toTop\r\n begin\r\n MoveTo(0, R.Bottom - 1);\r\n LineTo(0, 0);\r\n LineTo(R.Right - 1, 0);\r\n LineTo(R.Right - 1, R.Bottom - 1);\r\n Pen.Color := ControlDivideColor;\r\n LineTo(0, R.Bottom - 1);\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvModernTabBarPainter.DrawDivider(Canvas: TCanvas; LeftTab: TJvTabBarItem; R: TRect);\r\nbegin\r\n if not LeftTab.Selected then\r\n begin\r\n if (LeftTab.TabBar.SelectedTab = nil) or\r\n (LeftTab.GetNextVisible <> LeftTab.TabBar.SelectedTab) then\r\n begin\r\n with Canvas do\r\n begin\r\n Pen.Color := DividerColor;\r\n Pen.Width := 1;\r\n MoveTo(R.Right - 1, R.Top + 3);\r\n LineTo(R.Right - 1, R.Bottom - 3);\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvModernTabBarPainter.DrawMoveDivider(Canvas: TCanvas; Tab: TJvTabBarItem; MoveLeft: Boolean);\r\nvar\r\n R: TRect;\r\nbegin\r\n with Canvas do\r\n begin\r\n R := Tab.DisplayRect;\r\n Inc(R.Top, 4);\r\n Dec(R.Bottom, 2);\r\n if MoveLeft then\r\n begin\r\n Dec(R.Left);\r\n R.Right := R.Left + 4\r\n end\r\n else\r\n begin\r\n Dec(R.Right, 1);\r\n R.Left := R.Right - 4;\r\n end;\r\n Brush.Color := MoveDividerColor;\r\n FillRect(R);\r\n end;\r\nend;\r\n\r\nprocedure TJvModernTabBarPainter.DrawTab(Canvas: TCanvas; Tab: TJvTabBarItem; R: TRect);\r\nvar\r\n CloseR: TRect;\r\nbegin\r\n with Canvas do\r\n begin\r\n Brush.Style := bsSolid;\r\n Brush.Color := Color;\r\n Pen.Mode := pmCopy;\r\n Pen.Style := psSolid;\r\n Pen.Width := 1;\r\n\r\n if Tab.Selected then\r\n begin\r\n Brush.Style := bsSolid;\r\n Brush.Color := TabColor;\r\n FillRect(R);\r\n\r\n Pen.Color := ControlDivideColor;\r\n if Tab.TabBar.Orientation = toBottom then\r\n begin\r\n MoveTo(R.Left, R.Top);\r\n LineTo(R.Left, R.Bottom - 1);\r\n LineTo(R.Right - 1, R.Bottom - 1);\r\n LineTo(R.Right - 1, R.Top - 1{end});\r\n end\r\n else // toTop\r\n begin\r\n MoveTo(R.Left, R.Bottom - 1);\r\n LineTo(R.Left, R.Top);\r\n LineTo(R.Right - 1, R.Top);\r\n LineTo(R.Right - 1, R.Bottom - 1 + 1{end});\r\n end;\r\n end;\r\n\r\n if Tab.Enabled and not Tab.Selected and Tab.Hot then\r\n begin\r\n // hot\r\n Pen.Color := DividerColor;\r\n MoveTo(R.Left, R.Top);\r\n LineTo(R.Right - 1 - 1, R.Top);\r\n end;\r\n\r\n if Tab.TabBar.CloseButton then\r\n begin\r\n // close button color\r\n if Tab.Selected then\r\n Brush.Color := CloseColorSelected\r\n else\r\n Brush.Color := CloseColor;\r\n\r\n CloseR := GetCloseRect(Canvas, Tab, R);\r\n Pen.Color := CloseRectColor;\r\n if not Tab.Enabled then\r\n Pen.Color := CloseRectColorDisabled;\r\n\r\n if Tab.Closing then\r\n // shrink\r\n Rectangle(CloseR.Left + 1, CloseR.Top + 1, CloseR.Right - 1, CloseR.Bottom - 1)\r\n else\r\n Rectangle(CloseR);\r\n\r\n if Tab.Modified then\r\n Pen.Color := ModifiedCrossColor\r\n else\r\n if Tab.Selected and not Tab.Closing then\r\n Pen.Color := CloseCrossColorSelected\r\n else\r\n if Tab.Enabled then\r\n Pen.Color := CloseCrossColor\r\n else\r\n Pen.Color := CloseCrossColorDisabled;\r\n\r\n // close cross\r\n MoveTo(CloseR.Left + 3, CloseR.Top + 3);\r\n LineTo(CloseR.Right - 3, CloseR.Bottom - 3);\r\n MoveTo(CloseR.Left + 4, CloseR.Top + 3);\r\n LineTo(CloseR.Right - 4, CloseR.Bottom - 3);\r\n\r\n MoveTo(CloseR.Right - 4, CloseR.Top + 3);\r\n LineTo(CloseR.Left + 2, CloseR.Bottom - 3);\r\n MoveTo(CloseR.Right - 5, CloseR.Top + 3);\r\n LineTo(CloseR.Left + 3, CloseR.Bottom - 3);\r\n\r\n // remove intersection\r\n if Tab.Modified then\r\n FillRect(Rect(CloseR.Left + 5, CloseR.Top + 4, CloseR.Right - 5, CloseR.Bottom - 4));\r\n\r\n R.Left := CloseR.Right;\r\n end;\r\n\r\n InflateRect(R, -1, -1);\r\n\r\n if not Tab.TabBar.CloseButton then\r\n Inc(R.Left, 2);\r\n\r\n if (Tab.ImageIndex <> -1) and (Tab.GetImages <> nil) then\r\n begin\r\n Tab.GetImages.Draw(Canvas, R.Left, R.Top + (R.Bottom - R.Top - Tab.GetImages.Height) div 2,\r\n Tab.ImageIndex, Tab.Enabled);\r\n Inc(R.Left, Tab.GetImages.Width + 2);\r\n end;\r\n\r\n if Tab.Enabled then\r\n begin\r\n if Tab.Selected then\r\n Font.Assign(Self.SelectedFont)\r\n else\r\n Font.Assign(Self.Font);\r\n end\r\n else\r\n Font.Assign(Self.DisabledFont);\r\n\r\n Brush.Style := bsClear;\r\n TextRect(R, R.Left + 3, R.Top + 3, Tab.Caption);\r\n end;\r\nend;\r\n\r\nfunction TJvModernTabBarPainter.GetCloseRect(Canvas: TCanvas; Tab: TJvTabBarItem; R: TRect): TRect;\r\nbegin\r\n Result.Left := R.Left + 5;\r\n Result.Top := R.Top + 5;\r\n Result.Right := Result.Left + 12;\r\n Result.Bottom := Result.Top + 11;\r\nend;\r\n\r\nfunction TJvModernTabBarPainter.GetDividerWidth(Canvas: TCanvas; LeftTab: TJvTabBarItem): Integer;\r\nbegin\r\n Result := 1;\r\nend;\r\n\r\nfunction TJvModernTabBarPainter.GetTabSize(Canvas: TCanvas; Tab: TJvTabBarItem): TSize;\r\nbegin\r\n if Tab.Enabled then\r\n begin\r\n if Tab.Selected then\r\n Canvas.Font.Assign(SelectedFont)\r\n else\r\n Canvas.Font.Assign(Font)\r\n end\r\n else\r\n Canvas.Font.Assign(DisabledFont);\r\n\r\n Result.cx := Canvas.TextWidth(Tab.Caption) + 11;\r\n Result.cy := Canvas.TextHeight(Tab.Caption + 'Ag') + 7;\r\n if Tab.TabBar.CloseButton then\r\n Result.cx := Result.cx + 15;\r\n if (Tab.ImageIndex <> -1) and (Tab.GetImages <> nil) then\r\n Result.cx := Result.cx + Tab.GetImages.Width + 2;\r\n\r\n if TabWidth > 0 then\r\n Result.cx := TabWidth;\r\nend;\r\n\r\nfunction TJvModernTabBarPainter.Options: TJvTabBarPainterOptions;\r\nbegin\r\n Result := [poPaintsHotTab];\r\nend;\r\n\r\nprocedure TJvModernTabBarPainter.FontChanged(Sender: TObject);\r\nbegin\r\n Changed;\r\nend;\r\n\r\nprocedure TJvModernTabBarPainter.SetBorderColor(const Value: TColor);\r\nbegin\r\n if Value <> FBorderColor then\r\n begin\r\n FBorderColor := Value;\r\n Changed;\r\n end;\r\nend;\r\n\r\nprocedure TJvModernTabBarPainter.SetColor(const Value: TColor);\r\nbegin\r\n if Value <> FColor then\r\n begin\r\n FColor := Value;\r\n Changed;\r\n end;\r\nend;\r\n\r\nprocedure TJvModernTabBarPainter.SetControlDivideColor(const Value: TColor);\r\nbegin\r\n if Value <> FControlDivideColor then\r\n begin\r\n FControlDivideColor := Value;\r\n Changed;\r\n end;\r\nend;\r\n\r\nprocedure TJvModernTabBarPainter.SetModifiedCrossColor(const Value: TColor);\r\nbegin\r\n if Value <> FModifiedCrossColor then\r\n begin\r\n FModifiedCrossColor := Value;\r\n Changed;\r\n end;\r\nend;\r\n\r\nprocedure TJvModernTabBarPainter.SetTabColor(const Value: TColor);\r\nbegin\r\n if Value <> FTabColor then\r\n begin\r\n FTabColor := Value;\r\n Changed;\r\n end;\r\nend;\r\n\r\nprocedure TJvModernTabBarPainter.SetCloseColor(const Value: TColor);\r\nbegin\r\n if Value <> FCloseColor then\r\n begin\r\n FCloseColor := Value;\r\n Changed;\r\n end;\r\nend;\r\n\r\nprocedure TJvModernTabBarPainter.SetCloseColorSelected(const Value: TColor);\r\nbegin\r\n if Value <> FCloseColorSelected then\r\n begin\r\n FCloseColorSelected := Value;\r\n Changed;\r\n end;\r\nend;\r\n\r\nprocedure TJvModernTabBarPainter.SetCloseCrossColor(const Value: TColor);\r\nbegin\r\n if Value <> FCloseCrossColor then\r\n begin\r\n FCloseCrossColor := Value;\r\n Changed;\r\n end;\r\nend;\r\n\r\nprocedure TJvModernTabBarPainter.SetCloseCrossColorDisabled(const Value: TColor);\r\nbegin\r\n if Value <> FCloseCrossColorDisabled then\r\n begin\r\n FCloseCrossColorDisabled := Value;\r\n Changed;\r\n end;\r\nend;\r\n\r\nprocedure TJvModernTabBarPainter.SetCloseCrossColorSelected(const Value: TColor);\r\nbegin\r\n if Value <> FCloseCrossColorSelected then\r\n begin\r\n FCloseCrossColorSelected := Value;\r\n Changed;\r\n end;\r\nend;\r\n\r\nprocedure TJvModernTabBarPainter.SetCloseRectColor(const Value: TColor);\r\nbegin\r\n if Value <> FCloseRectColor then\r\n begin\r\n FCloseRectColor := Value;\r\n Changed;\r\n end;\r\nend;\r\n\r\nprocedure TJvModernTabBarPainter.SetCloseRectColorDisabled(const Value: TColor);\r\nbegin\r\n if Value <> FCloseRectColorDisabled then\r\n begin\r\n FCloseRectColorDisabled := Value;\r\n Changed;\r\n end;\r\nend;\r\n\r\nprocedure TJvModernTabBarPainter.SetDividerColor(const Value: TColor);\r\nbegin\r\n if Value <> FDividerColor then\r\n begin\r\n FDividerColor := Value;\r\n Changed;\r\n end;\r\nend;\r\n\r\nprocedure TJvModernTabBarPainter.SetTabWidth(Value: Integer);\r\nbegin\r\n if Value < 0 then\r\n Value := 0;\r\n if Value <> FTabWidth then\r\n begin\r\n FTabWidth := Value;\r\n Changed;\r\n end;\r\nend;\r\n\r\nprocedure TJvModernTabBarPainter.SetFont(const Value: TFont);\r\nbegin\r\n if Value <> FFont then\r\n FFont.Assign(Value);\r\nend;\r\n\r\nprocedure TJvModernTabBarPainter.SetDisabledFont(const Value: TFont);\r\nbegin\r\n if Value <> FDisabledFont then\r\n FDisabledFont.Assign(Value);\r\nend;\r\n\r\nprocedure TJvModernTabBarPainter.SetSelectedFont(const Value: TFont);\r\nbegin\r\n if Value <> FSelectedFont then\r\n FSelectedFont.Assign(Value);\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvTabBarXPPainter.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvTabBarXPPainter.pas, released on 2007-05-07.\r\n\r\nThe Initial Developer of the Original Code is Valdir Stiebe Junior \r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvTabBarXPPainter.pas 13104 2011-09-07 06:50:43Z obones $\r\n\r\nunit JvTabBarXPPainter;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\n{$IFDEF JVCLThemesEnabled}\r\n\r\nuses\r\n Windows, SysUtils, Classes, Graphics, JvTabBar;\r\n\r\ntype\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvTabBarXPPainter = class(TJvTabBarModernPainter)\r\n private\r\n FFixedTabSize: Integer;\r\n procedure SetFixedTabSize(const Value: Integer);\r\n protected\r\n procedure DrawBackground(Canvas: TCanvas; TabBar: TJvCustomTabBar; R: TRect); override;\r\n procedure DrawTab(Canvas: TCanvas; Tab: TJvTabBarItem; R: TRect); override;\r\n procedure DrawDivider(Canvas: TCanvas; LeftTab: TJvTabBarItem; R: TRect); override;\r\n procedure DrawMoveDivider(Canvas: TCanvas; Tab: TJvTabBarItem; MoveLeft: Boolean); override;\r\n function GetDividerWidth(Canvas: TCanvas; LeftTab: TJvTabBarItem): Integer; override;\r\n function GetTabSize(Canvas: TCanvas; Tab: TJvTabBarItem): TSize; override;\r\n function GetCloseRect(Canvas: TCanvas; Tab: TJvTabBarItem; R: TRect): TRect; override;\r\n published\r\n property FixedTabSize: Integer read FFixedTabSize write SetFixedTabSize;\r\n end;\r\n\r\n{$ENDIF JVCLThemesEnabled}\r\n\r\nimplementation\r\n\r\n{$IFDEF JVCLThemesEnabled}\r\n\r\nuses\r\n Math, JvThemes;\r\n\r\n{ TJvTabBarXPPainter }\r\n\r\nprocedure TJvTabBarXPPainter.DrawBackground(Canvas: TCanvas;\r\n TabBar: TJvCustomTabBar; R: TRect);\r\nvar\r\n Details: TThemedElementDetails;\r\nbegin\r\n if ThemeServices.{$IFDEF RTL230_UP}Enabled{$ELSE}ThemesEnabled{$ENDIF RTL230_UP} then\r\n begin\r\n Details := ThemeServices.GetElementDetails(ttTabRoot);\r\n ThemeServices.DrawElement(Canvas.Handle, Details, R);\r\n end\r\n else\r\n inherited DrawBackground(Canvas, TabBar, R);\r\nend;\r\n\r\nprocedure TJvTabBarXPPainter.DrawDivider(Canvas: TCanvas; LeftTab: TJvTabBarItem; R: TRect);\r\nbegin\r\n if not ThemeServices.{$IFDEF RTL230_UP}Enabled{$ELSE}ThemesEnabled{$ENDIF RTL230_UP} then\r\n inherited DrawDivider(Canvas, LeftTab, R);\r\nend;\r\n\r\nprocedure TJvTabBarXPPainter.DrawMoveDivider(Canvas: TCanvas; Tab: TJvTabBarItem;\r\n MoveLeft: Boolean);\r\nbegin\r\n if not ThemeServices.{$IFDEF RTL230_UP}Enabled{$ELSE}ThemesEnabled{$ENDIF RTL230_UP} then\r\n inherited DrawMoveDivider(Canvas, Tab, MoveLeft);\r\nend;\r\n\r\nprocedure TJvTabBarXPPainter.DrawTab(Canvas: TCanvas; Tab: TJvTabBarItem;\r\n R: TRect);\r\nvar\r\n TabDetails, ButtonDetails: TThemedElementDetails;\r\n CloseRect, TextRect: TRect;\r\nbegin\r\n if ThemeServices.{$IFDEF RTL230_UP}Enabled{$ELSE}ThemesEnabled{$ENDIF RTL230_UP} then\r\n begin\r\n if Tab.Selected then\r\n begin\r\n ButtonDetails := ThemeServices.GetElementDetails(twSmallCloseButtonNormal);\r\n TabDetails := ThemeServices.GetElementDetails(ttTabItemSelected);\r\n end\r\n else if Tab.Hot then\r\n begin\r\n ButtonDetails := ThemeServices.GetElementDetails(twSmallCloseButtonHot);\r\n TabDetails := ThemeServices.GetElementDetails(ttTabItemHot);\r\n end\r\n else\r\n begin\r\n ButtonDetails := ThemeServices.GetElementDetails(twSmallCloseButtonNormal);\r\n TabDetails := ThemeServices.GetElementDetails(ttTabItemNormal);\r\n end;\r\n\r\n if Tab.Closing then\r\n ButtonDetails := ThemeServices.GetElementDetails(twSmallCloseButtonPushed);\r\n ThemeServices.DrawElement(Canvas.Handle, TabDetails, R);\r\n\r\n if (Tab.ImageIndex <> -1) and (Tab.GetImages <> nil) then\r\n begin\r\n Tab.GetImages.Draw(Canvas, R.Left + 4, R.Top + (R.Bottom - R.Top - Tab.GetImages.Height) div 2,\r\n Tab.ImageIndex, Tab.Enabled);\r\n Inc(R.Left, Tab.GetImages.Width + 2);\r\n end;\r\n\r\n TextRect := R;\r\n TextRect.Left := TextRect.Left + Tab.TabBar.Margin;\r\n if Tab.TabBar.CloseButton then\r\n begin\r\n CloseRect := GetCloseRect(Canvas, Tab, R);\r\n TextRect.Right := CloseRect.Left - 3;\r\n end\r\n else\r\n Dec(TextRect.Right, 3);\r\n {$IFDEF COMPILER16_UP}\r\n ThemeServices.DrawText(Canvas.Handle, TabDetails, Tab.Caption, TextRect, [tfSingleLine, tfVerticalCenter, tfWordEllipsis]);\r\n {$ELSE}\r\n ThemeServices.DrawText(Canvas.Handle, TabDetails, Tab.Caption, TextRect, DT_SINGLELINE or DT_VCENTER or DT_WORD_ELLIPSIS, 0);\r\n {$ENDIF COMPILER16_UP}\r\n\r\n if Tab.TabBar.CloseButton then\r\n ThemeServices.DrawElement(Canvas.Handle, ButtonDetails, CloseRect);\r\n end\r\n else\r\n inherited DrawTab(Canvas, Tab, R);\r\nend;\r\n\r\nfunction TJvTabBarXPPainter.GetCloseRect(Canvas: TCanvas; Tab: TJvTabBarItem;\r\n R: TRect): TRect;\r\nbegin\r\n if ThemeServices.{$IFDEF RTL230_UP}Enabled{$ELSE}ThemesEnabled{$ENDIF RTL230_UP} then\r\n begin\r\n Result.Right := R.Right - 5;\r\n Result.Top := R.Top + ((R.Bottom div 2) - 8);\r\n Result.Left := Result.Right - 15;\r\n Result.Bottom := Result.Top + 15;\r\n end\r\n else\r\n Result := inherited GetCloseRect(Canvas, Tab, R);\r\nend;\r\n\r\nfunction TJvTabBarXPPainter.GetDividerWidth(Canvas: TCanvas; LeftTab: TJvTabBarItem): Integer;\r\nbegin\r\n if ThemeServices.{$IFDEF RTL230_UP}Enabled{$ELSE}ThemesEnabled{$ENDIF RTL230_UP} then\r\n Result := 1\r\n else\r\n Result := inherited GetDividerWidth(Canvas, LeftTab);\r\nend;\r\n\r\nfunction TJvTabBarXPPainter.GetTabSize(Canvas: TCanvas; Tab: TJvTabBarItem): TSize;\r\nbegin\r\n if FixedTabSize > 0 then\r\n begin\r\n if ThemeServices.{$IFDEF RTL230_UP}Enabled{$ELSE}ThemesEnabled{$ENDIF RTL230_UP} then\r\n Result.cx := FixedTabSize\r\n else\r\n Result.cx := Min(FixedTabSize + 40, Canvas.TextWidth(Tab.Caption) + 26);\r\n end\r\n else\r\n begin\r\n if ThemeServices.{$IFDEF RTL230_UP}Enabled{$ELSE}ThemesEnabled{$ENDIF RTL230_UP} then\r\n begin\r\n Result.cx := Canvas.TextWidth(Tab.Caption) + 16;\r\n if (Tab.ImageIndex <> -1) and (Tab.GetImages <> nil) then\r\n Inc(Result.cx, Tab.GetImages.Width + 2);\r\n if Tab.TabBar.CloseButton then\r\n Inc(Result.cx, 18);\r\n end\r\n else\r\n Result := inherited GetTabSize(Canvas, Tab);\r\n end;\r\n Result.cy := Tab.TabBar.Height - 3;\r\nend;\r\n\r\nprocedure TJvTabBarXPPainter.SetFixedTabSize(const Value: Integer);\r\nbegin\r\n if Value <> FixedTabSize then\r\n begin\r\n FFixedTabSize := Value;\r\n Changed;\r\n end;\r\nend;\r\n{$ENDIF JVCLThemesEnabled}\r\n\r\nend." }, { "path": "External/Jedi/Jvcl/run/JvTextListBox.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvTextListBox.pas, released on 2003-10-19.\r\n\r\nThe Initial Developers of the Original Code are: Fedor Koshevnikov, Igor Pavluk and Serge Korolev\r\nCopyright (c) 1997, 1998 Fedor Koshevnikov, Igor Pavluk and Serge Korolev\r\nCopyright (c) 2001,2002 SGB Software\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\n Polaris Software\r\n Peter Thornqvist [peter3 at sourceforge dot net]\r\n\r\nChanges:\r\n2003-10-19:\r\n * Moved TJvTextListBox from JvxCtrls to this unit\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvTextListBox.pas 13104 2011-09-07 06:50:43Z obones $\r\n\r\nunit JvTextListBox;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, Messages, Graphics, StdCtrls, Classes,\r\n JvExStdCtrls;\r\n\r\ntype\r\n TPositiveInt = 1..MaxInt;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvTextListBox = class(TJvExCustomListBox)\r\n private\r\n FMaxWidth: Integer;\r\n procedure ResetHorizontalExtent;\r\n procedure SetHorizontalExtent;\r\n function GetItemWidth(Index: Integer): Integer;\r\n protected\r\n procedure WndProc(var Msg: TMessage); override;\r\n published\r\n property Align;\r\n property BorderStyle;\r\n property Color;\r\n property DragCursor;\r\n property DragMode;\r\n property Enabled;\r\n property ExtendedSelect;\r\n property Font;\r\n property IntegralHeight;\r\n property Anchors;\r\n property BiDiMode;\r\n property Constraints;\r\n property DragKind;\r\n property ParentBiDiMode;\r\n property ImeMode;\r\n property ImeName;\r\n property ItemHeight;\r\n property Items;\r\n property MultiSelect;\r\n property ParentColor;\r\n property ParentFont;\r\n property ParentShowHint;\r\n property PopupMenu;\r\n property ShowHint;\r\n property Sorted;\r\n property TabOrder;\r\n property TabStop;\r\n property TabWidth;\r\n property Visible;\r\n property OnClick;\r\n property OnDblClick;\r\n property OnDragDrop;\r\n property OnDragOver;\r\n property OnEndDrag;\r\n property OnEnter;\r\n property OnExit;\r\n property OnKeyDown;\r\n property OnKeyPress;\r\n property OnKeyUp;\r\n property OnMouseDown;\r\n property OnMouseMove;\r\n property OnMouseUp;\r\n property OnStartDrag;\r\n property OnContextPopup;\r\n property OnMouseWheelDown;\r\n property OnMouseWheelUp;\r\n property OnEndDock;\r\n property OnStartDock;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvTextListBox.pas $';\r\n Revision: '$Revision: 13104 $';\r\n Date: '$Date: 2011-09-07 08:50:43 +0200 (mer. 07 sept. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n Math;\r\n\r\nprocedure TJvTextListBox.SetHorizontalExtent;\r\nbegin\r\n SendMessage(Handle, LB_SETHORIZONTALEXTENT, FMaxWidth, 0);\r\nend;\r\n\r\nfunction TJvTextListBox.GetItemWidth(Index: Integer): Integer;\r\nvar\r\n ATabWidth: Longint;\r\n S: string;\r\nbegin\r\n S := Items[Index] + 'x';\r\n if TabWidth > 0 then\r\n begin\r\n ATabWidth := Round((TabWidth * Canvas.TextWidth('0')) * 0.25);\r\n Result := LoWord(GetTabbedTextExtent(Canvas.Handle, @S[1], Length(S),\r\n 1, ATabWidth));\r\n end\r\n else\r\n Result := Canvas.TextWidth(S);\r\nend;\r\n\r\nprocedure TJvTextListBox.ResetHorizontalExtent;\r\nvar\r\n I: Integer;\r\nbegin\r\n FMaxWidth := 0;\r\n for I := 0 to Items.Count - 1 do\r\n FMaxWidth := Max(FMaxWidth, GetItemWidth(I));\r\n SetHorizontalExtent;\r\nend;\r\n\r\nprocedure TJvTextListBox.WndProc(var Msg: TMessage);\r\nbegin\r\n case Msg.Msg of\r\n LB_ADDSTRING, LB_INSERTSTRING:\r\n begin\r\n inherited WndProc(Msg);\r\n FMaxWidth := Max(FMaxWidth, GetItemWidth(Msg.Result));\r\n SetHorizontalExtent;\r\n end;\r\n LB_DELETESTRING:\r\n begin\r\n if GetItemWidth(Msg.WParam) >= FMaxWidth then\r\n begin\r\n Perform(WM_HSCROLL, SB_TOP, 0);\r\n inherited WndProc(Msg);\r\n ResetHorizontalExtent;\r\n end\r\n else\r\n inherited WndProc(Msg);\r\n end;\r\n LB_RESETCONTENT:\r\n begin\r\n FMaxWidth := 0;\r\n SetHorizontalExtent;\r\n Perform(WM_HSCROLL, SB_TOP, 0);\r\n inherited WndProc(Msg);\r\n end;\r\n WM_SETFONT:\r\n begin\r\n inherited WndProc(Msg);\r\n Canvas.Font.Assign(Self.Font);\r\n ResetHorizontalExtent;\r\n end;\r\n else\r\n inherited WndProc(Msg);\r\n end;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend." }, { "path": "External/Jedi/Jvcl/run/JvThemes.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvThemes.PAS, released on 2003-09-25\r\n\r\nThe Initial Developers of the Original Code are: Andreas Hausladen \r\nAll Rights Reserved.\r\n\r\nContributors:\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvThemes.pas 13415 2012-09-10 09:51:54Z obones $\r\n\r\nunit JvThemes;\r\n\r\n{$I jvcl.inc}\r\n{$IFDEF JVCLThemesEnabled}\r\n{$I windowsonly.inc}\r\n{$ENDIF JVCLThemesEnabled}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, Messages, CommCtrl, Types, SysUtils, Classes, Contnrs,\r\n {$IFDEF HAS_UNIT_SYSTEM_UITYPES}\r\n System.UITypes,\r\n {$ENDIF}\r\n {$IFDEF JVCLThemesEnabled}\r\n {$IFDEF COMPILER7_UP}\r\n Themes, UxTheme,\r\n {$ELSE}\r\n ThemeSrv,\r\n {$ENDIF COMPILER7_UP}\r\n {$ENDIF JVCLThemesEnabled}\r\n Controls, Forms, Graphics, Buttons;\r\n\r\nconst\r\n // Add a message handler to a component that is themed by the ThemeManager but\r\n // should not be themed.\r\n CM_DENYSUBCLASSING = CM_BASE + 2000; // from ThemeMgr.pas\r\n\r\ntype\r\n TCMDenySubClassing = TMessage;\r\n\r\n{$IFDEF JVCLThemesEnabled}\r\n\r\n{.$MESSAGE HINT 'A few types are IFDEFed out for Pulsar in order to compile this unit. This needs a review.'}\r\n// ahuser: This is more an internal JVCL unit. All the types and constants wouldn't be necessary\r\n// if we didn't support Delphi 6 with the ThemeManagerD6.\r\n\r\n// type name redirection\r\ntype\r\n TThemedElement = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.TThemedElement; {$EXTERNALSYM TThemedElement}\r\n TThemedButton = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.TThemedButton; {$EXTERNALSYM TThemedButton}\r\n TThemedClock = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.TThemedClock; {$EXTERNALSYM TThemedClock}\r\n TThemedComboBox = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.TThemedComboBox; {$EXTERNALSYM TThemedComboBox}\r\n TThemedEdit = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.TThemedEdit; {$EXTERNALSYM TThemedEdit}\r\n TThemedExplorerBar = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.TThemedExplorerBar; {$EXTERNALSYM TThemedExplorerBar}\r\n TThemedHeader = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.TThemedHeader; {$EXTERNALSYM TThemedHeader}\r\n TThemedListview = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.TThemedListview; {$EXTERNALSYM TThemedListview}\r\n TThemedMenu = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.TThemedMenu; {$EXTERNALSYM TThemedMenu}\r\n TThemedPage = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.TThemedPage; {$EXTERNALSYM TThemedPage}\r\n TThemedProgress = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.TThemedProgress; {$EXTERNALSYM TThemedProgress}\r\n TThemedRebar = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.TThemedRebar; {$EXTERNALSYM TThemedRebar}\r\n TThemedScrollBar = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.TThemedScrollBar; {$EXTERNALSYM TThemedScrollBar}\r\n TThemedSpin = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.TThemedSpin; {$EXTERNALSYM TThemedSpin}\r\n TThemedStartPanel = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.TThemedStartPanel; {$EXTERNALSYM TThemedStartPanel}\r\n TThemedStatus = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.TThemedStatus; {$EXTERNALSYM TThemedStatus}\r\n TThemedTab = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.TThemedTab; {$EXTERNALSYM TThemedTab}\r\n TThemedTaskBand = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.TThemedTaskBand; {$EXTERNALSYM TThemedTaskBand}\r\n TThemedTaskBar = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.TThemedTaskBar; {$EXTERNALSYM TThemedTaskBar}\r\n TThemedToolBar = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.TThemedToolBar; {$EXTERNALSYM TThemedToolBar}\r\n TThemedToolTip = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.TThemedToolTip; {$EXTERNALSYM TThemedToolTip}\r\n TThemedTrackBar = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.TThemedTrackBar; {$EXTERNALSYM TThemedTrackBar}\r\n TThemedTrayNotify = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.TThemedTrayNotify; {$EXTERNALSYM TThemedTrayNotify}\r\n TThemedTreeview = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.TThemedTreeview; {$EXTERNALSYM TThemedTreeview}\r\n TThemedWindow = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.TThemedWindow; {$EXTERNALSYM TThemedWindow}\r\n TThemeData = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.TThemeData; {$EXTERNALSYM TThemeData}\r\n\r\n PThemedElementDetails = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.PThemedElementDetails; {$EXTERNALSYM PThemedElementDetails}\r\n TThemedElementDetails = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.TThemedElementDetails; {$EXTERNALSYM TThemedElementDetails}\r\n {$IFDEF COMPILER16_UP}\r\n TThemeServices = Themes.TCustomStyleServices; {$EXTERNALSYM TThemeServices}\r\n {$ELSE}\r\n TThemeServices = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.TThemeServices; {$EXTERNALSYM TThemeServices}\r\n {$ENDIF COMPILER16_UP}\r\n\r\n// enumerations as constants\r\n\r\n// TThemedElement\r\nconst\r\n teButton = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.teButton; {$EXTERNALSYM teButton}\r\n teClock = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.teClock; {$EXTERNALSYM teClock}\r\n teComboBox = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.teComboBox; {$EXTERNALSYM teComboBox}\r\n teEdit = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.teEdit; {$EXTERNALSYM teEdit}\r\n teExplorerBar = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.teExplorerBar; {$EXTERNALSYM teExplorerBar}\r\n teHeader = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.teHeader; {$EXTERNALSYM teHeader}\r\n teListView = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.teListView; {$EXTERNALSYM teListView}\r\n teMenu = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.teMenu; {$EXTERNALSYM teMenu}\r\n tePage = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.tePage; {$EXTERNALSYM tePage}\r\n teProgress = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.teProgress; {$EXTERNALSYM teProgress}\r\n teRebar = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.teRebar; {$EXTERNALSYM teRebar}\r\n teScrollBar = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.teScrollBar; {$EXTERNALSYM teScrollBar}\r\n teSpin = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.teSpin; {$EXTERNALSYM teSpin}\r\n teStartPanel = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.teStartPanel; {$EXTERNALSYM teStartPanel}\r\n teStatus = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.teStatus; {$EXTERNALSYM teStatus}\r\n teTab = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.teTab; {$EXTERNALSYM teTab}\r\n teTaskBand = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.teTaskBand; {$EXTERNALSYM teTaskBand}\r\n teTaskBar = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.teTaskBar; {$EXTERNALSYM teTaskBar}\r\n teToolBar = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.teToolBar; {$EXTERNALSYM teToolBar}\r\n teToolTip = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.teToolTip; {$EXTERNALSYM teToolTip}\r\n teTrackBar = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.teTrackBar; {$EXTERNALSYM teTrackBar}\r\n teTrayNotify = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.teTrayNotify; {$EXTERNALSYM teTrayNotify}\r\n teTreeview = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.teTreeview; {$EXTERNALSYM teTreeview}\r\n teWindow = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.teWindow; {$EXTERNALSYM teWindow}\r\n\r\n// TThemedButton\r\nconst\r\n tbButtonDontCare = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.tbButtonDontCare; {$EXTERNALSYM tbButtonDontCare}\r\n tbButtonRoot = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.tbButtonRoot; {$EXTERNALSYM tbButtonRoot}\r\n tbPushButtonNormal = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.tbPushButtonNormal; {$EXTERNALSYM tbPushButtonNormal}\r\n tbPushButtonHot = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.tbPushButtonHot; {$EXTERNALSYM tbPushButtonHot}\r\n tbPushButtonPressed = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.tbPushButtonPressed; {$EXTERNALSYM tbPushButtonPressed}\r\n tbPushButtonDisabled = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.tbPushButtonDisabled; {$EXTERNALSYM tbPushButtonDisabled}\r\n tbPushButtonDefaulted = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.tbPushButtonDefaulted; {$EXTERNALSYM tbPushButtonDefaulted}\r\n tbRadioButtonUncheckedNormal = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.tbRadioButtonUncheckedNormal; {$EXTERNALSYM tbRadioButtonUncheckedNormal}\r\n tbRadioButtonUncheckedHot = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.tbRadioButtonUncheckedHot; {$EXTERNALSYM tbRadioButtonUncheckedHot}\r\n tbRadioButtonUncheckedPressed = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.tbRadioButtonUncheckedPressed; {$EXTERNALSYM tbRadioButtonUncheckedPressed}\r\n tbRadioButtonUncheckedDisabled = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.tbRadioButtonUncheckedDisabled; {$EXTERNALSYM tbRadioButtonUncheckedDisabled}\r\n tbRadioButtonCheckedNormal = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.tbRadioButtonCheckedNormal; {$EXTERNALSYM tbRadioButtonCheckedNormal}\r\n tbRadioButtonCheckedHot = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.tbRadioButtonCheckedHot; {$EXTERNALSYM tbRadioButtonCheckedHot}\r\n tbRadioButtonCheckedPressed = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.tbRadioButtonCheckedPressed; {$EXTERNALSYM tbRadioButtonCheckedPressed}\r\n tbRadioButtonCheckedDisabled = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.tbRadioButtonCheckedDisabled; {$EXTERNALSYM tbRadioButtonCheckedDisabled}\r\n tbCheckBoxUncheckedNormal = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.tbCheckBoxUncheckedNormal; {$EXTERNALSYM tbCheckBoxUncheckedNormal}\r\n tbCheckBoxUncheckedHot = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.tbCheckBoxUncheckedHot; {$EXTERNALSYM tbCheckBoxUncheckedHot}\r\n tbCheckBoxUncheckedPressed = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.tbCheckBoxUncheckedPressed; {$EXTERNALSYM tbCheckBoxUncheckedPressed}\r\n tbCheckBoxUncheckedDisabled = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.tbCheckBoxUncheckedDisabled; {$EXTERNALSYM tbCheckBoxUncheckedDisabled}\r\n tbCheckBoxCheckedNormal = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.tbCheckBoxCheckedNormal; {$EXTERNALSYM tbCheckBoxCheckedNormal}\r\n tbCheckBoxCheckedHot = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.tbCheckBoxCheckedHot; {$EXTERNALSYM tbCheckBoxCheckedHot}\r\n tbCheckBoxCheckedPressed = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.tbCheckBoxCheckedPressed; {$EXTERNALSYM tbCheckBoxCheckedPressed}\r\n tbCheckBoxCheckedDisabled = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.tbCheckBoxCheckedDisabled; {$EXTERNALSYM tbCheckBoxCheckedDisabled}\r\n tbCheckBoxMixedNormal = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.tbCheckBoxMixedNormal; {$EXTERNALSYM tbCheckBoxMixedNormal}\r\n tbCheckBoxMixedHot = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.tbCheckBoxMixedHot; {$EXTERNALSYM tbCheckBoxMixedHot}\r\n tbCheckBoxMixedPressed = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.tbCheckBoxMixedPressed; {$EXTERNALSYM tbCheckBoxMixedPressed}\r\n tbCheckBoxMixedDisabled = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.tbCheckBoxMixedDisabled; {$EXTERNALSYM tbCheckBoxMixedDisabled}\r\n tbGroupBoxNormal = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.tbGroupBoxNormal; {$EXTERNALSYM tbGroupBoxNormal}\r\n tbGroupBoxDisabled = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.tbGroupBoxDisabled; {$EXTERNALSYM tbGroupBoxDisabled}\r\n tbUserButton = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.tbUserButton; {$EXTERNALSYM tbUserButton}\r\n\r\n// TThemedClock\r\nconst\r\n tcClockDontCare = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.tcClockDontCare; {$EXTERNALSYM tcClockDontCare}\r\n tcClockRoot = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.tcClockRoot; {$EXTERNALSYM tcClockRoot}\r\n tcTimeNormal = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.tcTimeNormal; {$EXTERNALSYM tcTimeNormal}\r\n\r\n// TThemedComboBox\r\nconst\r\n tcComboBoxDontCare = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.tcComboBoxDontCare; {$EXTERNALSYM tcComboBoxDontCare}\r\n tcComboBoxRoot = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.tcComboBoxRoot; {$EXTERNALSYM tcComboBoxRoot}\r\n tcDropDownButtonNormal = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.tcDropDownButtonNormal; {$EXTERNALSYM tcDropDownButtonNormal}\r\n tcDropDownButtonHot = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.tcDropDownButtonHot; {$EXTERNALSYM tcDropDownButtonHot}\r\n tcDropDownButtonPressed = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.tcDropDownButtonPressed; {$EXTERNALSYM tcDropDownButtonPressed}\r\n tcDropDownButtonDisabled = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.tcDropDownButtonDisabled; {$EXTERNALSYM tcDropDownButtonDisabled}\r\n\r\n// TThemedEdit\r\nconst\r\n teEditDontCare = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.teEditDontCare; {$EXTERNALSYM teEditDontCare}\r\n teEditRoot = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.teEditRoot; {$EXTERNALSYM teEditRoot}\r\n teEditTextNormal = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.teEditTextNormal; {$EXTERNALSYM teEditTextNormal}\r\n teEditTextHot = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.teEditTextHot; {$EXTERNALSYM teEditTextHot}\r\n teEditTextSelected = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.teEditTextSelected; {$EXTERNALSYM teEditTextSelected}\r\n teEditTextDisabled = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.teEditTextDisabled; {$EXTERNALSYM teEditTextDisabled}\r\n teEditTextFocused = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.teEditTextFocused; {$EXTERNALSYM teEditTextFocused}\r\n teEditTextReadOnly = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.teEditTextReadOnly; {$EXTERNALSYM teEditTextReadOnly}\r\n teEditTextAssist = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.teEditTextAssist; {$EXTERNALSYM teEditTextAssist}\r\n teEditCaret = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.teEditCaret; {$EXTERNALSYM teEditCaret}\r\n\r\n// TThemedExplorerBar\r\nconst\r\n tebExplorerBarDontCare = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.tebExplorerBarDontCare; {$EXTERNALSYM tebExplorerBarDontCare}\r\n tebExplorerBarRoot = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.tebExplorerBarRoot; {$EXTERNALSYM tebExplorerBarRoot}\r\n tebHeaderBackgroundNormal = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.tebHeaderBackgroundNormal; {$EXTERNALSYM tebHeaderBackgroundNormal}\r\n tebHeaderBackgroundHot = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.tebHeaderBackgroundHot; {$EXTERNALSYM tebHeaderBackgroundHot}\r\n tebHeaderBackgroundPressed = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.tebHeaderBackgroundPressed; {$EXTERNALSYM tebHeaderBackgroundPressed}\r\n tebHeaderCloseNormal = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.tebHeaderCloseNormal; {$EXTERNALSYM tebHeaderCloseNormal}\r\n tebHeaderCloseHot = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.tebHeaderCloseHot; {$EXTERNALSYM tebHeaderCloseHot}\r\n tebHeaderClosePressed = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.tebHeaderClosePressed; {$EXTERNALSYM tebHeaderClosePressed}\r\n tebHeaderPinNormal = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.tebHeaderPinNormal; {$EXTERNALSYM tebHeaderPinNormal}\r\n tebHeaderPinHot = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.tebHeaderPinHot; {$EXTERNALSYM tebHeaderPinHot}\r\n tebHeaderPinPressed = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.tebHeaderPinPressed; {$EXTERNALSYM tebHeaderPinPressed}\r\n tebHeaderPinSelectedNormal = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.tebHeaderPinSelectedNormal; {$EXTERNALSYM tebHeaderPinSelectedNormal}\r\n tebHeaderPinSelectedHot = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.tebHeaderPinSelectedHot; {$EXTERNALSYM tebHeaderPinSelectedHot}\r\n tebHeaderPinSelectedPressed = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.tebHeaderPinSelectedPressed; {$EXTERNALSYM tebHeaderPinSelectedPressed}\r\n tebIEBarMenuNormal = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.tebIEBarMenuNormal; {$EXTERNALSYM tebIEBarMenuNormal}\r\n tebIEBarMenuHot = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.tebIEBarMenuHot; {$EXTERNALSYM tebIEBarMenuHot}\r\n tebIEBarMenuPressed = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.tebIEBarMenuPressed; {$EXTERNALSYM tebIEBarMenuPressed}\r\n tebNormalGroupBackground = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.tebNormalGroupBackground; {$EXTERNALSYM tebNormalGroupBackground}\r\n tebNormalGroupCollapseNormal = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.tebNormalGroupCollapseNormal; {$EXTERNALSYM tebNormalGroupCollapseNormal}\r\n tebNormalGroupCollapseHot = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.tebNormalGroupCollapseHot; {$EXTERNALSYM tebNormalGroupCollapseHot}\r\n tebNormalGroupCollapsePressed = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.tebNormalGroupCollapsePressed; {$EXTERNALSYM tebNormalGroupCollapsePressed}\r\n tebNormalGroupExpandNormal = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.tebNormalGroupExpandNormal; {$EXTERNALSYM tebNormalGroupExpandNormal}\r\n tebNormalGroupExpandHot = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.tebNormalGroupExpandHot; {$EXTERNALSYM tebNormalGroupExpandHot}\r\n tebNormalGroupExpandPressed = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.tebNormalGroupExpandPressed; {$EXTERNALSYM tebNormalGroupExpandPressed}\r\n tebNormalGroupHead = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.tebNormalGroupHead; {$EXTERNALSYM tebNormalGroupHead}\r\n tebSpecialGroupBackground = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.tebSpecialGroupBackground; {$EXTERNALSYM tebSpecialGroupBackground}\r\n {$IFNDEF COMPILER16_UP}\r\n tebSpecialGroupCollapseSpecial = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.tebSpecialGroupCollapseSpecial; {$EXTERNALSYM tebSpecialGroupCollapseSpecial}\r\n {$ENDIF ~COMPILER16_UP}\r\n tebSpecialGroupCollapseHot = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.tebSpecialGroupCollapseHot; {$EXTERNALSYM tebSpecialGroupCollapseHot}\r\n tebSpecialGroupCollapsePressed = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.tebSpecialGroupCollapsePressed; {$EXTERNALSYM tebSpecialGroupCollapsePressed}\r\n {$IFNDEF COMPILER16_UP}\r\n tebSpecialGroupExpandSpecial = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.tebSpecialGroupExpandSpecial; {$EXTERNALSYM tebSpecialGroupExpandSpecial}\r\n {$ENDIF ~COMPILER16_UP}\r\n tebSpecialGroupExpandHot = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.tebSpecialGroupExpandHot; {$EXTERNALSYM tebSpecialGroupExpandHot}\r\n tebSpecialGroupExpandPressed = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.tebSpecialGroupExpandPressed; {$EXTERNALSYM tebSpecialGroupExpandPressed}\r\n tebSpecialGroupHead = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.tebSpecialGroupHead; {$EXTERNALSYM tebSpecialGroupHead}\r\n\r\n// TThemedHeader\r\nconst\r\n thHeaderDontCare = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.thHeaderDontCare; {$EXTERNALSYM thHeaderDontCare}\r\n thHeaderRoot = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.thHeaderRoot; {$EXTERNALSYM thHeaderRoot}\r\n thHeaderItemNormal = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.thHeaderItemNormal; {$EXTERNALSYM thHeaderItemNormal}\r\n thHeaderItemHot = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.thHeaderItemHot; {$EXTERNALSYM thHeaderItemHot}\r\n thHeaderItemPressed = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.thHeaderItemPressed; {$EXTERNALSYM thHeaderItemPressed}\r\n thHeaderItemLeftNormal = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.thHeaderItemLeftNormal; {$EXTERNALSYM thHeaderItemLeftNormal}\r\n thHeaderItemLeftHot = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.thHeaderItemLeftHot; {$EXTERNALSYM thHeaderItemLeftHot}\r\n thHeaderItemLeftPressed = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.thHeaderItemLeftPressed; {$EXTERNALSYM thHeaderItemLeftPressed}\r\n thHeaderItemRightNormal = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.thHeaderItemRightNormal; {$EXTERNALSYM thHeaderItemRightNormal}\r\n thHeaderItemRightHot = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.thHeaderItemRightHot; {$EXTERNALSYM thHeaderItemRightHot}\r\n thHeaderItemRightPressed = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.thHeaderItemRightPressed; {$EXTERNALSYM thHeaderItemRightPressed}\r\n thHeaderSortArrowSortedUp = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.thHeaderSortArrowSortedUp; {$EXTERNALSYM thHeaderSortArrowSortedUp}\r\n thHeaderSortArrowSortedDown = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.thHeaderSortArrowSortedDown; {$EXTERNALSYM thHeaderSortArrowSortedDown}\r\n\r\n// TThemedListview\r\nconst\r\n tlListviewDontCare = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.tlListviewDontCare; {$EXTERNALSYM tlListviewDontCare}\r\n tlListviewRoot = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.tlListviewRoot; {$EXTERNALSYM tlListviewRoot}\r\n tlListItemNormal = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.tlListItemNormal; {$EXTERNALSYM tlListItemNormal}\r\n tlListItemHot = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.tlListItemHot; {$EXTERNALSYM tlListItemHot}\r\n tlListItemSelected = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.tlListItemSelected; {$EXTERNALSYM tlListItemSelected}\r\n tlListItemDisabled = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.tlListItemDisabled; {$EXTERNALSYM tlListItemDisabled}\r\n tlListItemSelectedNotFocus = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.tlListItemSelectedNotFocus; {$EXTERNALSYM tlListItemSelectedNotFocus}\r\n tlListGroup = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.tlListGroup; {$EXTERNALSYM tlListGroup}\r\n tlListDetail = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.tlListDetail; {$EXTERNALSYM tlListDetail}\r\n tlListSortDetail = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.tlListSortDetail; {$EXTERNALSYM tlListSortDetail}\r\n tlEmptyText = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.tlEmptyText; {$EXTERNALSYM tlEmptyText}\r\n\r\n// TThemedMenu\r\nconst\r\n tmMenuDontCare = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.tmMenuDontCare; {$EXTERNALSYM tmMenuDontCare}\r\n tmMenuRoot = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.tmMenuRoot; {$EXTERNALSYM tmMenuRoot}\r\n tmMenuItemNormal = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.tmMenuItemNormal; {$EXTERNALSYM tmMenuItemNormal}\r\n tmMenuItemSelected = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.tmMenuItemSelected; {$EXTERNALSYM tmMenuItemSelected}\r\n tmMenuItemDemoted = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.tmMenuItemDemoted; {$EXTERNALSYM tmMenuItemDemoted}\r\n tmMenuDropDown = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.tmMenuDropDown; {$EXTERNALSYM tmMenuDropDown}\r\n tmMenuBarItem = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.tmMenuBarItem; {$EXTERNALSYM tmMenuBarItem}\r\n tmMenuBarDropDown = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.tmMenuBarDropDown; {$EXTERNALSYM tmMenuBarDropDown}\r\n tmChevron = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.tmChevron; {$EXTERNALSYM tmChevron}\r\n tmSeparator = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.tmSeparator; {$EXTERNALSYM tmSeparator}\r\n\r\n// TThemedPage\r\nconst\r\n tpPageDontCare = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.tpPageDontCare; {$EXTERNALSYM tpPageDontCare}\r\n tpPageRoot = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.tpPageRoot; {$EXTERNALSYM tpPageRoot}\r\n tpUpNormal = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.tpUpNormal; {$EXTERNALSYM tpUpNormal}\r\n tpUpHot = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.tpUpHot; {$EXTERNALSYM tpUpHot}\r\n tpUpPressed = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.tpUpPressed; {$EXTERNALSYM tpUpPressed}\r\n tpUpDisabled = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.tpUpDisabled; {$EXTERNALSYM tpUpDisabled}\r\n tpDownNormal = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.tpDownNormal; {$EXTERNALSYM tpDownNormal}\r\n tpDownHot = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.tpDownHot; {$EXTERNALSYM tpDownHot}\r\n tpDownPressed = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.tpDownPressed; {$EXTERNALSYM tpDownPressed}\r\n tpDownDisabled = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.tpDownDisabled; {$EXTERNALSYM tpDownDisabled}\r\n tpUpHorzNormal = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.tpUpHorzNormal; {$EXTERNALSYM tpUpHorzNormal}\r\n tpUpHorzHot = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.tpUpHorzHot; {$EXTERNALSYM tpUpHorzHot}\r\n tpUpHorzPressed = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.tpUpHorzPressed; {$EXTERNALSYM tpUpHorzPressed}\r\n tpUpHorzDisabled = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.tpUpHorzDisabled; {$EXTERNALSYM tpUpHorzDisabled}\r\n tpDownHorzNormal = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.tpDownHorzNormal; {$EXTERNALSYM tpDownHorzNormal}\r\n tpDownHorzHot = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.tpDownHorzHot; {$EXTERNALSYM tpDownHorzHot}\r\n tpDownHorzPressed = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.tpDownHorzPressed; {$EXTERNALSYM tpDownHorzPressed}\r\n tpDownHorzDisabled = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.tpDownHorzDisabled; {$EXTERNALSYM tpDownHorzDisabled}\r\n\r\n// TThemedProgress\r\nconst\r\n tpProgressDontCare = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.tpProgressDontCare; {$EXTERNALSYM tpProgressDontCare}\r\n tpProgressRoot = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.tpProgressRoot; {$EXTERNALSYM tpProgressRoot}\r\n tpBar = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.tpBar; {$EXTERNALSYM tpBar}\r\n tpBarVert = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.tpBarVert; {$EXTERNALSYM tpBarVert}\r\n tpChunk = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.tpChunk; {$EXTERNALSYM tpChunk}\r\n tpChunkVert = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.tpChunkVert; {$EXTERNALSYM tpChunkVert}\r\n\r\n// TThemedRebar\r\nconst\r\n trRebarDontCare = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.trRebarDontCare; {$EXTERNALSYM trRebarDontCare}\r\n trRebarRoot = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.trRebarRoot; {$EXTERNALSYM trRebarRoot}\r\n trGripper = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.trGripper; {$EXTERNALSYM trGripper}\r\n trGripperVert = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.trGripperVert; {$EXTERNALSYM trGripperVert}\r\n {$IFNDEF COMPILER16_UP}\r\n trBandNormal = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.trBandNormal; {$EXTERNALSYM trBandNormal}\r\n trBandHot = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.trBandHot; {$EXTERNALSYM trBandHot}\r\n trBandPressed = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.trBandPressed; {$EXTERNALSYM trBandPressed}\r\n trBandDisabled = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.trBandDisabled; {$EXTERNALSYM trBandDisabled}\r\n trBandChecked = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.trBandChecked; {$EXTERNALSYM trBandChecked}\r\n trBandHotChecked = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.trBandHotChecked; {$EXTERNALSYM trBandHotChecked}\r\n {$ENDIF ~COMPILER16_UP}\r\n trChevronNormal = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.trChevronNormal; {$EXTERNALSYM trChevronNormal}\r\n trChevronHot = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.trChevronHot; {$EXTERNALSYM trChevronHot}\r\n trChevronPressed = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.trChevronPressed; {$EXTERNALSYM trChevronPressed}\r\n {$IFNDEF COMPILER16_UP}\r\n trChevronDisabled = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.trChevronDisabled; {$EXTERNALSYM trChevronDisabled}\r\n {$ENDIF ~COMPILER16_UP}\r\n trChevronVertNormal = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.trChevronVertNormal; {$EXTERNALSYM trChevronVertNormal}\r\n trChevronVertHot = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.trChevronVertHot; {$EXTERNALSYM trChevronVertHot}\r\n trChevronVertPressed = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.trChevronVertPressed; {$EXTERNALSYM trChevronVertPressed}\r\n {$IFNDEF COMPILER16_UP}\r\n trChevronVertDisabled = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.trChevronVertDisabled; {$EXTERNALSYM trChevronVertDisabled}\r\n {$ENDIF ~COMPILER16_UP}\r\n\r\n// TThemedScrollBar\r\nconst\r\n tsScrollBarDontCare = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.tsScrollBarDontCare; {$EXTERNALSYM tsScrollBarDontCare}\r\n tsScrollBarRoot = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.tsScrollBarRoot; {$EXTERNALSYM tsScrollBarRoot}\r\n tsArrowBtnUpNormal = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.tsArrowBtnUpNormal; {$EXTERNALSYM tsArrowBtnUpNormal}\r\n tsArrowBtnUpHot = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.tsArrowBtnUpHot; {$EXTERNALSYM tsArrowBtnUpHot}\r\n tsArrowBtnUpPressed = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.tsArrowBtnUpPressed; {$EXTERNALSYM tsArrowBtnUpPressed}\r\n tsArrowBtnUpDisabled = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.tsArrowBtnUpDisabled; {$EXTERNALSYM tsArrowBtnUpDisabled}\r\n tsArrowBtnDownNormal = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.tsArrowBtnDownNormal; {$EXTERNALSYM tsArrowBtnDownNormal}\r\n tsArrowBtnDownHot = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.tsArrowBtnDownHot; {$EXTERNALSYM tsArrowBtnDownHot}\r\n tsArrowBtnDownPressed = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.tsArrowBtnDownPressed; {$EXTERNALSYM tsArrowBtnDownPressed}\r\n tsArrowBtnDownDisabled = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.tsArrowBtnDownDisabled; {$EXTERNALSYM tsArrowBtnDownDisabled}\r\n tsArrowBtnLeftNormal = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.tsArrowBtnLeftNormal; {$EXTERNALSYM tsArrowBtnLeftNormal}\r\n tsArrowBtnLeftHot = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.tsArrowBtnLeftHot; {$EXTERNALSYM tsArrowBtnLeftHot}\r\n tsArrowBtnLeftPressed = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.tsArrowBtnLeftPressed; {$EXTERNALSYM tsArrowBtnLeftPressed}\r\n tsArrowBtnLeftDisabled = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.tsArrowBtnLeftDisabled; {$EXTERNALSYM tsArrowBtnLeftDisabled}\r\n tsArrowBtnRightNormal = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.tsArrowBtnRightNormal; {$EXTERNALSYM tsArrowBtnRightNormal}\r\n tsArrowBtnRightHot = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.tsArrowBtnRightHot; {$EXTERNALSYM tsArrowBtnRightHot}\r\n tsArrowBtnRightPressed = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.tsArrowBtnRightPressed; {$EXTERNALSYM tsArrowBtnRightPressed}\r\n tsArrowBtnRightDisabled = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.tsArrowBtnRightDisabled; {$EXTERNALSYM tsArrowBtnRightDisabled}\r\n tsThumbBtnHorzNormal = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.tsThumbBtnHorzNormal; {$EXTERNALSYM tsThumbBtnHorzNormal}\r\n tsThumbBtnHorzHot = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.tsThumbBtnHorzHot; {$EXTERNALSYM tsThumbBtnHorzHot}\r\n tsThumbBtnHorzPressed = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.tsThumbBtnHorzPressed; {$EXTERNALSYM tsThumbBtnHorzPressed}\r\n tsThumbBtnHorzDisabled = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.tsThumbBtnHorzDisabled; {$EXTERNALSYM tsThumbBtnHorzDisabled}\r\n tsThumbBtnVertNormal = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.tsThumbBtnVertNormal; {$EXTERNALSYM tsThumbBtnVertNormal}\r\n tsThumbBtnVertHot = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.tsThumbBtnVertHot; {$EXTERNALSYM tsThumbBtnVertHot}\r\n tsThumbBtnVertPressed = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.tsThumbBtnVertPressed; {$EXTERNALSYM tsThumbBtnVertPressed}\r\n tsThumbBtnVertDisabled = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.tsThumbBtnVertDisabled; {$EXTERNALSYM tsThumbBtnVertDisabled}\r\n tsLowerTrackHorzNormal = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.tsLowerTrackHorzNormal; {$EXTERNALSYM tsLowerTrackHorzNormal}\r\n tsLowerTrackHorzHot = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.tsLowerTrackHorzHot; {$EXTERNALSYM tsLowerTrackHorzHot}\r\n tsLowerTrackHorzPressed = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.tsLowerTrackHorzPressed; {$EXTERNALSYM tsLowerTrackHorzPressed}\r\n tsLowerTrackHorzDisabled = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.tsLowerTrackHorzDisabled; {$EXTERNALSYM tsLowerTrackHorzDisabled}\r\n tsUpperTrackHorzNormal = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.tsUpperTrackHorzNormal; {$EXTERNALSYM tsUpperTrackHorzNormal}\r\n tsUpperTrackHorzHot = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.tsUpperTrackHorzHot; {$EXTERNALSYM tsUpperTrackHorzHot}\r\n tsUpperTrackHorzPressed = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.tsUpperTrackHorzPressed; {$EXTERNALSYM tsUpperTrackHorzPressed}\r\n tsUpperTrackHorzDisabled = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.tsUpperTrackHorzDisabled; {$EXTERNALSYM tsUpperTrackHorzDisabled}\r\n tsLowerTrackVertNormal = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.tsLowerTrackVertNormal; {$EXTERNALSYM tsLowerTrackVertNormal}\r\n tsLowerTrackVertHot = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.tsLowerTrackVertHot; {$EXTERNALSYM tsLowerTrackVertHot}\r\n tsLowerTrackVertPressed = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.tsLowerTrackVertPressed; {$EXTERNALSYM tsLowerTrackVertPressed}\r\n tsLowerTrackVertDisabled = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.tsLowerTrackVertDisabled; {$EXTERNALSYM tsLowerTrackVertDisabled}\r\n tsUpperTrackVertNormal = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.tsUpperTrackVertNormal; {$EXTERNALSYM tsUpperTrackVertNormal}\r\n tsUpperTrackVertHot = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.tsUpperTrackVertHot; {$EXTERNALSYM tsUpperTrackVertHot}\r\n tsUpperTrackVertPressed = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.tsUpperTrackVertPressed; {$EXTERNALSYM tsUpperTrackVertPressed}\r\n tsUpperTrackVertDisabled = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.tsUpperTrackVertDisabled; {$EXTERNALSYM tsUpperTrackVertDisabled}\r\n tsGripperHorzNormal = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.tsGripperHorzNormal; {$EXTERNALSYM tsGripperHorzNormal}\r\n tsGripperHorzHot = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.tsGripperHorzHot; {$EXTERNALSYM tsGripperHorzHot}\r\n tsGripperHorzPressed = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.tsGripperHorzPressed; {$EXTERNALSYM tsGripperHorzPressed}\r\n tsGripperHorzDisabled = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.tsGripperHorzDisabled; {$EXTERNALSYM tsGripperHorzDisabled}\r\n tsGripperVertNormal = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.tsGripperVertNormal; {$EXTERNALSYM tsGripperVertNormal}\r\n tsGripperVertHot = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.tsGripperVertHot; {$EXTERNALSYM tsGripperVertHot}\r\n tsGripperVertPressed = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.tsGripperVertPressed; {$EXTERNALSYM tsGripperVertPressed}\r\n tsGripperVertDisabled = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.tsGripperVertDisabled; {$EXTERNALSYM tsGripperVertDisabled}\r\n tsSizeBoxRightAlign = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.tsSizeBoxRightAlign; {$EXTERNALSYM tsSizeBoxRightAlign}\r\n tsSizeBoxLeftAlign = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.tsSizeBoxLeftAlign; {$EXTERNALSYM tsSizeBoxLeftAlign}\r\n\r\n// TThemedSpin\r\nconst\r\n tsSpinDontCare = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.tsSpinDontCare; {$EXTERNALSYM tsSpinDontCare}\r\n tsSpinRoot = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.tsSpinRoot; {$EXTERNALSYM tsSpinRoot}\r\n tsUpNormal = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.tsUpNormal; {$EXTERNALSYM tsUpNormal}\r\n tsUpHot = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.tsUpHot; {$EXTERNALSYM tsUpHot}\r\n tsUpPressed = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.tsUpPressed; {$EXTERNALSYM tsUpPressed}\r\n tsUpDisabled = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.tsUpDisabled; {$EXTERNALSYM tsUpDisabled}\r\n tsDownNormal = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.tsDownNormal; {$EXTERNALSYM tsDownNormal}\r\n tsDownHot = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.tsDownHot; {$EXTERNALSYM tsDownHot}\r\n tsDownPressed = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.tsDownPressed; {$EXTERNALSYM tsDownPressed}\r\n tsDownDisabled = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.tsDownDisabled; {$EXTERNALSYM tsDownDisabled}\r\n tsUpHorzNormal = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.tsUpHorzNormal; {$EXTERNALSYM tsUpHorzNormal}\r\n tsUpHorzHot = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.tsUpHorzHot; {$EXTERNALSYM tsUpHorzHot}\r\n tsUpHorzPressed = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.tsUpHorzPressed; {$EXTERNALSYM tsUpHorzPressed}\r\n tsUpHorzDisabled = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.tsUpHorzDisabled; {$EXTERNALSYM tsUpHorzDisabled}\r\n tsDownHorzNormal = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.tsDownHorzNormal; {$EXTERNALSYM tsDownHorzNormal}\r\n tsDownHorzHot = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.tsDownHorzHot; {$EXTERNALSYM tsDownHorzHot}\r\n tsDownHorzPressed = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.tsDownHorzPressed; {$EXTERNALSYM tsDownHorzPressed}\r\n tsDownHorzDisabled = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.tsDownHorzDisabled; {$EXTERNALSYM tsDownHorzDisabled}\r\n\r\n// TThemedStartPanel\r\nconst\r\n tspStartPanelDontCare = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.tspStartPanelDontCare; {$EXTERNALSYM tspStartPanelDontCare}\r\n tspStartPanelRoot = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.tspStartPanelRoot; {$EXTERNALSYM tspStartPanelRoot}\r\n tspUserPane = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.tspUserPane; {$EXTERNALSYM tspUserPane}\r\n tspMorePrograms = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.tspMorePrograms; {$EXTERNALSYM tspMorePrograms}\r\n tspMoreProgramsArrowNormal = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.tspMoreProgramsArrowNormal; {$EXTERNALSYM tspMoreProgramsArrowNormal}\r\n tspMoreProgramsArrowHot = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.tspMoreProgramsArrowHot; {$EXTERNALSYM tspMoreProgramsArrowHot}\r\n tspMoreProgramsArrowPressed = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.tspMoreProgramsArrowPressed; {$EXTERNALSYM tspMoreProgramsArrowPressed}\r\n tspProgList = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.tspProgList; {$EXTERNALSYM tspProgList}\r\n tspProgListSeparator = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.tspProgListSeparator; {$EXTERNALSYM tspProgListSeparator}\r\n tspPlacesList = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.tspPlacesList; {$EXTERNALSYM tspPlacesList}\r\n tspPlacesListSeparator = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.tspPlacesListSeparator; {$EXTERNALSYM tspPlacesListSeparator}\r\n tspLogOff = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.tspLogOff; {$EXTERNALSYM tspLogOff}\r\n tspLogOffButtonsNormal = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.tspLogOffButtonsNormal; {$EXTERNALSYM tspLogOffButtonsNormal}\r\n tspLogOffButtonsHot = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.tspLogOffButtonsHot; {$EXTERNALSYM tspLogOffButtonsHot}\r\n tspLogOffButtonsPressed = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.tspLogOffButtonsPressed; {$EXTERNALSYM tspLogOffButtonsPressed}\r\n tspUserPicture = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.tspUserPicture; {$EXTERNALSYM tspUserPicture}\r\n tspPreview = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.tspPreview; {$EXTERNALSYM tspPreview}\r\n\r\n// TThemedStatus\r\nconst\r\n tsStatusDontCare = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.tsStatusDontCare; {$EXTERNALSYM tsStatusDontCare}\r\n tsStatusRoot = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.tsStatusRoot; {$EXTERNALSYM tsStatusRoot}\r\n tsPane = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.tsPane; {$EXTERNALSYM tsPane}\r\n tsGripperPane = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.tsGripperPane; {$EXTERNALSYM tsGripperPane}\r\n tsGripper = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.tsGripper; {$EXTERNALSYM tsGripper}\r\n\r\n// TThemedTab\r\nconst\r\n ttTabDontCare = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.ttTabDontCare; {$EXTERNALSYM ttTabDontCare}\r\n ttTabRoot = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.ttTabRoot; {$EXTERNALSYM ttTabRoot}\r\n ttTabItemNormal = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.ttTabItemNormal; {$EXTERNALSYM ttTabItemNormal}\r\n ttTabItemHot = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.ttTabItemHot; {$EXTERNALSYM ttTabItemHot}\r\n ttTabItemSelected = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.ttTabItemSelected; {$EXTERNALSYM ttTabItemSelected}\r\n ttTabItemDisabled = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.ttTabItemDisabled; {$EXTERNALSYM ttTabItemDisabled}\r\n ttTabItemFocused = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.ttTabItemFocused; {$EXTERNALSYM ttTabItemFocused}\r\n ttTabItemLeftEdgeNormal = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.ttTabItemLeftEdgeNormal; {$EXTERNALSYM ttTabItemLeftEdgeNormal}\r\n ttTabItemLeftEdgeHot = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.ttTabItemLeftEdgeHot; {$EXTERNALSYM ttTabItemLeftEdgeHot}\r\n ttTabItemLeftEdgeSelected = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.ttTabItemLeftEdgeSelected; {$EXTERNALSYM ttTabItemLeftEdgeSelected}\r\n ttTabItemLeftEdgeDisabled = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.ttTabItemLeftEdgeDisabled; {$EXTERNALSYM ttTabItemLeftEdgeDisabled}\r\n ttTabItemLeftEdgeFocused = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.ttTabItemLeftEdgeFocused; {$EXTERNALSYM ttTabItemLeftEdgeFocused}\r\n ttTabItemRightEdgeNormal = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.ttTabItemRightEdgeNormal; {$EXTERNALSYM ttTabItemRightEdgeNormal}\r\n ttTabItemRightEdgeHot = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.ttTabItemRightEdgeHot; {$EXTERNALSYM ttTabItemRightEdgeHot}\r\n ttTabItemRightEdgeSelected = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.ttTabItemRightEdgeSelected; {$EXTERNALSYM ttTabItemRightEdgeSelected}\r\n ttTabItemRightEdgeDisabled = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.ttTabItemRightEdgeDisabled; {$EXTERNALSYM ttTabItemRightEdgeDisabled}\r\n ttTabItemRightEdgeFocused = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.ttTabItemRightEdgeFocused; {$EXTERNALSYM ttTabItemRightEdgeFocused}\r\n ttTabItemBothEdgeNormal = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.ttTabItemBothEdgeNormal; {$EXTERNALSYM ttTabItemBothEdgeNormal}\r\n ttTabItemBothEdgeHot = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.ttTabItemBothEdgeHot; {$EXTERNALSYM ttTabItemBothEdgeHot}\r\n ttTabItemBothEdgeSelected = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.ttTabItemBothEdgeSelected; {$EXTERNALSYM ttTabItemBothEdgeSelected}\r\n ttTabItemBothEdgeDisabled = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.ttTabItemBothEdgeDisabled; {$EXTERNALSYM ttTabItemBothEdgeDisabled}\r\n ttTabItemBothEdgeFocused = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.ttTabItemBothEdgeFocused; {$EXTERNALSYM ttTabItemBothEdgeFocused}\r\n ttTopTabItemNormal = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.ttTopTabItemNormal; {$EXTERNALSYM ttTopTabItemNormal}\r\n ttTopTabItemHot = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.ttTopTabItemHot; {$EXTERNALSYM ttTopTabItemHot}\r\n ttTopTabItemSelected = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.ttTopTabItemSelected; {$EXTERNALSYM ttTopTabItemSelected}\r\n ttTopTabItemDisabled = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.ttTopTabItemDisabled; {$EXTERNALSYM ttTopTabItemDisabled}\r\n ttTopTabItemFocused = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.ttTopTabItemFocused; {$EXTERNALSYM ttTopTabItemFocused}\r\n ttTopTabItemLeftEdgeNormal = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.ttTopTabItemLeftEdgeNormal; {$EXTERNALSYM ttTopTabItemLeftEdgeNormal}\r\n ttTopTabItemLeftEdgeHot = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.ttTopTabItemLeftEdgeHot; {$EXTERNALSYM ttTopTabItemLeftEdgeHot}\r\n ttTopTabItemLeftEdgeSelected = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.ttTopTabItemLeftEdgeSelected; {$EXTERNALSYM ttTopTabItemLeftEdgeSelected}\r\n ttTopTabItemLeftEdgeDisabled = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.ttTopTabItemLeftEdgeDisabled; {$EXTERNALSYM ttTopTabItemLeftEdgeDisabled}\r\n ttTopTabItemLeftEdgeFocused = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.ttTopTabItemLeftEdgeFocused; {$EXTERNALSYM ttTopTabItemLeftEdgeFocused}\r\n ttTopTabItemRightEdgeNormal = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.ttTopTabItemRightEdgeNormal; {$EXTERNALSYM ttTopTabItemRightEdgeNormal}\r\n ttTopTabItemRightEdgeHot = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.ttTopTabItemRightEdgeHot; {$EXTERNALSYM ttTopTabItemRightEdgeHot}\r\n ttTopTabItemRightEdgeSelected = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.ttTopTabItemRightEdgeSelected; {$EXTERNALSYM ttTopTabItemRightEdgeSelected}\r\n ttTopTabItemRightEdgeDisabled = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.ttTopTabItemRightEdgeDisabled; {$EXTERNALSYM ttTopTabItemRightEdgeDisabled}\r\n ttTopTabItemRightEdgeFocused = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.ttTopTabItemRightEdgeFocused; {$EXTERNALSYM ttTopTabItemRightEdgeFocused}\r\n ttTopTabItemBothEdgeNormal = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.ttTopTabItemBothEdgeNormal; {$EXTERNALSYM ttTopTabItemBothEdgeNormal}\r\n ttTopTabItemBothEdgeHot = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.ttTopTabItemBothEdgeHot; {$EXTERNALSYM ttTopTabItemBothEdgeHot}\r\n ttTopTabItemBothEdgeSelected = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.ttTopTabItemBothEdgeSelected; {$EXTERNALSYM ttTopTabItemBothEdgeSelected}\r\n ttTopTabItemBothEdgeDisabled = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.ttTopTabItemBothEdgeDisabled; {$EXTERNALSYM ttTopTabItemBothEdgeDisabled}\r\n ttTopTabItemBothEdgeFocused = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.ttTopTabItemBothEdgeFocused; {$EXTERNALSYM ttTopTabItemBothEdgeFocused}\r\n ttPane = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.ttPane; {$EXTERNALSYM ttPane}\r\n ttBody = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.ttBody; {$EXTERNALSYM ttBody}\r\n\r\n// TThemedTaskBand\r\nconst\r\n ttbTaskBandDontCare = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.ttbTaskBandDontCare; {$EXTERNALSYM ttbTaskBandDontCare}\r\n ttbTaskBandRoot = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.ttbTaskBandRoot; {$EXTERNALSYM ttbTaskBandRoot}\r\n ttbGroupCount = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.ttbGroupCount; {$EXTERNALSYM ttbGroupCount}\r\n ttbFlashButton = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.ttbFlashButton; {$EXTERNALSYM ttbFlashButton}\r\n ttpFlashButtonGroupMenu = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.ttpFlashButtonGroupMenu; {$EXTERNALSYM ttpFlashButtonGroupMenu}\r\n\r\n{$IFNDEF COMPILER16_UP}\r\n// TThemedTaskBar\r\nconst\r\n ttTaskBarDontCare = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.ttTaskBarDontCare; {$EXTERNALSYM ttTaskBarDontCare}\r\n ttTaskBarRoot = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.ttTaskBarRoot; {$EXTERNALSYM ttTaskBarRoot}\r\n ttbTimeNormal = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.ttbTimeNormal; {$EXTERNALSYM ttbTimeNormal}\r\n{$ENDIF ~COMPILER16_UP}\r\n\r\n// TThemedToolBar\r\nconst\r\n ttbToolBarDontCare = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.ttbToolBarDontCare; {$EXTERNALSYM ttbToolBarDontCare}\r\n ttbToolBarRoot = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.ttbToolBarRoot; {$EXTERNALSYM ttbToolBarRoot}\r\n ttbButtonNormal = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.ttbButtonNormal; {$EXTERNALSYM ttbButtonNormal}\r\n ttbButtonHot = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.ttbButtonHot; {$EXTERNALSYM ttbButtonHot}\r\n ttbButtonPressed = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.ttbButtonPressed; {$EXTERNALSYM ttbButtonPressed}\r\n ttbButtonDisabled = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.ttbButtonDisabled; {$EXTERNALSYM ttbButtonDisabled}\r\n ttbButtonChecked = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.ttbButtonChecked; {$EXTERNALSYM ttbButtonChecked}\r\n ttbButtonCheckedHot = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.ttbButtonCheckedHot; {$EXTERNALSYM ttbButtonCheckedHot}\r\n ttbDropDownButtonNormal = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.ttbDropDownButtonNormal; {$EXTERNALSYM ttbDropDownButtonNormal}\r\n ttbDropDownButtonHot = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.ttbDropDownButtonHot; {$EXTERNALSYM ttbDropDownButtonHot}\r\n ttbDropDownButtonPressed = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.ttbDropDownButtonPressed; {$EXTERNALSYM ttbDropDownButtonPressed}\r\n ttbDropDownButtonDisabled = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.ttbDropDownButtonDisabled; {$EXTERNALSYM ttbDropDownButtonDisabled}\r\n ttbDropDownButtonChecked = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.ttbDropDownButtonChecked; {$EXTERNALSYM ttbDropDownButtonChecked}\r\n ttbDropDownButtonCheckedHot = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.ttbDropDownButtonCheckedHot; {$EXTERNALSYM ttbDropDownButtonCheckedHot}\r\n ttbSplitButtonNormal = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.ttbSplitButtonNormal; {$EXTERNALSYM ttbSplitButtonNormal}\r\n ttbSplitButtonHot = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.ttbSplitButtonHot; {$EXTERNALSYM ttbSplitButtonHot}\r\n ttbSplitButtonPressed = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.ttbSplitButtonPressed; {$EXTERNALSYM ttbSplitButtonPressed}\r\n ttbSplitButtonDisabled = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.ttbSplitButtonDisabled; {$EXTERNALSYM ttbSplitButtonDisabled}\r\n ttbSplitButtonChecked = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.ttbSplitButtonChecked; {$EXTERNALSYM ttbSplitButtonChecked}\r\n ttbSplitButtonCheckedHot = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.ttbSplitButtonCheckedHot; {$EXTERNALSYM ttbSplitButtonCheckedHot}\r\n ttbSplitButtonDropDownNormal = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.ttbSplitButtonDropDownNormal; {$EXTERNALSYM ttbSplitButtonDropDownNormal}\r\n ttbSplitButtonDropDownHot = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.ttbSplitButtonDropDownHot; {$EXTERNALSYM ttbSplitButtonDropDownHot}\r\n ttbSplitButtonDropDownPressed = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.ttbSplitButtonDropDownPressed; {$EXTERNALSYM ttbSplitButtonDropDownPressed}\r\n ttbSplitButtonDropDownDisabled = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.ttbSplitButtonDropDownDisabled; {$EXTERNALSYM ttbSplitButtonDropDownDisabled}\r\n ttbSplitButtonDropDownChecked = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.ttbSplitButtonDropDownChecked; {$EXTERNALSYM ttbSplitButtonDropDownChecked}\r\n ttbSplitButtonDropDownCheckedHot = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.ttbSplitButtonDropDownCheckedHot; {$EXTERNALSYM ttbSplitButtonDropDownCheckedHot}\r\n ttbSeparatorNormal = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.ttbSeparatorNormal; {$EXTERNALSYM ttbSeparatorNormal}\r\n ttbSeparatorHot = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.ttbSeparatorHot; {$EXTERNALSYM ttbSeparatorHot}\r\n ttbSeparatorPressed = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.ttbSeparatorPressed; {$EXTERNALSYM ttbSeparatorPressed}\r\n ttbSeparatorDisabled = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.ttbSeparatorDisabled; {$EXTERNALSYM ttbSeparatorDisabled}\r\n ttbSeparatorChecked = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.ttbSeparatorChecked; {$EXTERNALSYM ttbSeparatorChecked}\r\n ttbSeparatorCheckedHot = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.ttbSeparatorCheckedHot; {$EXTERNALSYM ttbSeparatorCheckedHot}\r\n ttbSeparatorVertNormal = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.ttbSeparatorVertNormal; {$EXTERNALSYM ttbSeparatorVertNormal}\r\n ttbSeparatorVertHot = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.ttbSeparatorVertHot; {$EXTERNALSYM ttbSeparatorVertHot}\r\n ttbSeparatorVertPressed = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.ttbSeparatorVertPressed; {$EXTERNALSYM ttbSeparatorVertPressed}\r\n ttbSeparatorVertDisabled = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.ttbSeparatorVertDisabled; {$EXTERNALSYM ttbSeparatorVertDisabled}\r\n ttbSeparatorVertChecked = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.ttbSeparatorVertChecked; {$EXTERNALSYM ttbSeparatorVertChecked}\r\n ttbSeparatorVertCheckedHot = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.ttbSeparatorVertCheckedHot; {$EXTERNALSYM ttbSeparatorVertCheckedHot}\r\n\r\n// TThemedToolTip\r\nconst\r\n tttToolTipDontCare = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.tttToolTipDontCare; {$EXTERNALSYM tttToolTipDontCare}\r\n tttToolTipRoot = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.tttToolTipRoot; {$EXTERNALSYM tttToolTipRoot}\r\n tttStandardNormal = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.tttStandardNormal; {$EXTERNALSYM tttStandardNormal}\r\n tttStandardLink = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.tttStandardLink; {$EXTERNALSYM tttStandardLink}\r\n tttStandardTitleNormal = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.tttStandardTitleNormal; {$EXTERNALSYM tttStandardTitleNormal}\r\n tttStandardTitleLink = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.tttStandardTitleLink; {$EXTERNALSYM tttStandardTitleLink}\r\n tttBaloonNormal = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.tttBaloonNormal; {$EXTERNALSYM tttBaloonNormal}\r\n tttBaloonLink = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.tttBaloonLink; {$EXTERNALSYM tttBaloonLink}\r\n tttBaloonTitleNormal = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.tttBaloonTitleNormal; {$EXTERNALSYM tttBaloonTitleNormal}\r\n tttBaloonTitleLink = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.tttBaloonTitleLink; {$EXTERNALSYM tttBaloonTitleLink}\r\n tttCloseNormal = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.tttCloseNormal; {$EXTERNALSYM tttCloseNormal}\r\n tttCloseHot = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.tttCloseHot; {$EXTERNALSYM tttCloseHot}\r\n tttClosePressed = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.tttClosePressed; {$EXTERNALSYM tttClosePressed}\r\n\r\n// TThemedTrackBar\r\nconst\r\n ttbTrackBarDontCare = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.ttbTrackBarDontCare; {$EXTERNALSYM ttbTrackBarDontCare}\r\n ttbTrackBarRoot = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.ttbTrackBarRoot; {$EXTERNALSYM ttbTrackBarRoot}\r\n ttbTrack = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.ttbTrack; {$EXTERNALSYM ttbTrack}\r\n ttbTrackVert = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.ttbTrackVert; {$EXTERNALSYM ttbTrackVert}\r\n ttbThumbNormal = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.ttbThumbNormal; {$EXTERNALSYM ttbThumbNormal}\r\n ttbThumbHot = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.ttbThumbHot; {$EXTERNALSYM ttbThumbHot}\r\n ttbThumbPressed = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.ttbThumbPressed; {$EXTERNALSYM ttbThumbPressed}\r\n ttbThumbFocused = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.ttbThumbFocused; {$EXTERNALSYM ttbThumbFocused}\r\n ttbThumbDisabled = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.ttbThumbDisabled; {$EXTERNALSYM ttbThumbDisabled}\r\n ttbThumbBottomNormal = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.ttbThumbBottomNormal; {$EXTERNALSYM ttbThumbBottomNormal}\r\n ttbThumbBottomHot = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.ttbThumbBottomHot; {$EXTERNALSYM ttbThumbBottomHot}\r\n ttbThumbBottomPressed = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.ttbThumbBottomPressed; {$EXTERNALSYM ttbThumbBottomPressed}\r\n ttbThumbBottomFocused = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.ttbThumbBottomFocused; {$EXTERNALSYM ttbThumbBottomFocused}\r\n ttbThumbBottomDisabled = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.ttbThumbBottomDisabled; {$EXTERNALSYM ttbThumbBottomDisabled}\r\n ttbThumbTopNormal = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.ttbThumbTopNormal; {$EXTERNALSYM ttbThumbTopNormal}\r\n ttbThumbTopHot = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.ttbThumbTopHot; {$EXTERNALSYM ttbThumbTopHot}\r\n ttbThumbTopPressed = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.ttbThumbTopPressed; {$EXTERNALSYM ttbThumbTopPressed}\r\n ttbThumbTopFocused = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.ttbThumbTopFocused; {$EXTERNALSYM ttbThumbTopFocused}\r\n ttbThumbTopDisabled = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.ttbThumbTopDisabled; {$EXTERNALSYM ttbThumbTopDisabled}\r\n ttbThumbVertNormal = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.ttbThumbVertNormal; {$EXTERNALSYM ttbThumbVertNormal}\r\n ttbThumbVertHot = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.ttbThumbVertHot; {$EXTERNALSYM ttbThumbVertHot}\r\n ttbThumbVertPressed = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.ttbThumbVertPressed; {$EXTERNALSYM ttbThumbVertPressed}\r\n ttbThumbVertFocused = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.ttbThumbVertFocused; {$EXTERNALSYM ttbThumbVertFocused}\r\n ttbThumbVertDisabled = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.ttbThumbVertDisabled; {$EXTERNALSYM ttbThumbVertDisabled}\r\n ttbThumbLeftNormal = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.ttbThumbLeftNormal; {$EXTERNALSYM ttbThumbLeftNormal}\r\n ttbThumbLeftHot = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.ttbThumbLeftHot; {$EXTERNALSYM ttbThumbLeftHot}\r\n ttbThumbLeftPressed = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.ttbThumbLeftPressed; {$EXTERNALSYM ttbThumbLeftPressed}\r\n ttbThumbLeftFocused = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.ttbThumbLeftFocused; {$EXTERNALSYM ttbThumbLeftFocused}\r\n ttbThumbLeftDisabled = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.ttbThumbLeftDisabled; {$EXTERNALSYM ttbThumbLeftDisabled}\r\n ttbThumbRightNormal = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.ttbThumbRightNormal; {$EXTERNALSYM ttbThumbRightNormal}\r\n ttbThumbRightHot = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.ttbThumbRightHot; {$EXTERNALSYM ttbThumbRightHot}\r\n ttbThumbRightPressed = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.ttbThumbRightPressed; {$EXTERNALSYM ttbThumbRightPressed}\r\n ttbThumbRightFocused = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.ttbThumbRightFocused; {$EXTERNALSYM ttbThumbRightFocused}\r\n ttbThumbRightDisabled = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.ttbThumbRightDisabled; {$EXTERNALSYM ttbThumbRightDisabled}\r\n ttbThumbTics = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.ttbThumbTics; {$EXTERNALSYM ttbThumbTics}\r\n ttbThumbTicsVert = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.ttbThumbTicsVert; {$EXTERNALSYM ttbThumbTicsVert}\r\n\r\n// TThemedTrayNotify\r\nconst\r\n ttnTrayNotifyDontCare = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.ttnTrayNotifyDontCare; {$EXTERNALSYM ttnTrayNotifyDontCare}\r\n ttnTrayNotifyRoot = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.ttnTrayNotifyRoot; {$EXTERNALSYM ttnTrayNotifyRoot}\r\n ttnBackground = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.ttnBackground; {$EXTERNALSYM ttnBackground}\r\n ttnAnimBackground = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.ttnAnimBackground; {$EXTERNALSYM ttnAnimBackground}\r\n\r\n// TThemedTreeview\r\nconst\r\n ttTreeviewDontCare = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.ttTreeviewDontCare; {$EXTERNALSYM ttTreeviewDontCare}\r\n ttTreeviewRoot = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.ttTreeviewRoot; {$EXTERNALSYM ttTreeviewRoot}\r\n ttItemNormal = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.ttItemNormal; {$EXTERNALSYM ttItemNormal}\r\n ttItemHot = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.ttItemHot; {$EXTERNALSYM ttItemHot}\r\n ttItemSelected = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.ttItemSelected; {$EXTERNALSYM ttItemSelected}\r\n ttItemDisabled = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.ttItemDisabled; {$EXTERNALSYM ttItemDisabled}\r\n ttItemSelectedNotFocus = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.ttItemSelectedNotFocus; {$EXTERNALSYM ttItemSelectedNotFocus}\r\n ttGlyphClosed = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.ttGlyphClosed; {$EXTERNALSYM ttGlyphClosed}\r\n ttGlyphOpened = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.ttGlyphOpened; {$EXTERNALSYM ttGlyphOpened}\r\n ttBranch = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.ttBranch; {$EXTERNALSYM ttBranch}\r\n\r\n// TThemedWindow\r\nconst\r\n twWindowDontCare = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.twWindowDontCare; {$EXTERNALSYM twWindowDontCare}\r\n twWindowRoot = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.twWindowRoot; {$EXTERNALSYM twWindowRoot}\r\n twCaptionActive = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.twCaptionActive; {$EXTERNALSYM twCaptionActive}\r\n twCaptionInactive = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.twCaptionInactive; {$EXTERNALSYM twCaptionInactive}\r\n twCaptionDisabled = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.twCaptionDisabled; {$EXTERNALSYM twCaptionDisabled}\r\n twSmallCaptionActive = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.twSmallCaptionActive; {$EXTERNALSYM twSmallCaptionActive}\r\n twSmallCaptionInactive = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.twSmallCaptionInactive; {$EXTERNALSYM twSmallCaptionInactive}\r\n twSmallCaptionDisabled = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.twSmallCaptionDisabled; {$EXTERNALSYM twSmallCaptionDisabled}\r\n twMinCaptionActive = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.twMinCaptionActive; {$EXTERNALSYM twMinCaptionActive}\r\n twMinCaptionInactive = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.twMinCaptionInactive; {$EXTERNALSYM twMinCaptionInactive}\r\n twMinCaptionDisabled = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.twMinCaptionDisabled; {$EXTERNALSYM twMinCaptionDisabled}\r\n twSmallMinCaptionActive = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.twSmallMinCaptionActive; {$EXTERNALSYM twSmallMinCaptionActive}\r\n twSmallMinCaptionInactive = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.twSmallMinCaptionInactive; {$EXTERNALSYM twSmallMinCaptionInactive}\r\n twSmallMinCaptionDisabled = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.twSmallMinCaptionDisabled; {$EXTERNALSYM twSmallMinCaptionDisabled}\r\n twMaxCaptionActive = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.twMaxCaptionActive; {$EXTERNALSYM twMaxCaptionActive}\r\n twMaxCaptionInactive = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.twMaxCaptionInactive; {$EXTERNALSYM twMaxCaptionInactive}\r\n twMaxCaptionDisabled = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.twMaxCaptionDisabled; {$EXTERNALSYM twMaxCaptionDisabled}\r\n twSmallMaxCaptionActive = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.twSmallMaxCaptionActive; {$EXTERNALSYM twSmallMaxCaptionActive}\r\n twSmallMaxCaptionInactive = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.twSmallMaxCaptionInactive; {$EXTERNALSYM twSmallMaxCaptionInactive}\r\n twSmallMaxCaptionDisabled = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.twSmallMaxCaptionDisabled; {$EXTERNALSYM twSmallMaxCaptionDisabled}\r\n twFrameLeftActive = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.twFrameLeftActive; {$EXTERNALSYM twFrameLeftActive}\r\n twFrameLeftInactive = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.twFrameLeftInactive; {$EXTERNALSYM twFrameLeftInactive}\r\n twFrameRightActive = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.twFrameRightActive; {$EXTERNALSYM twFrameRightActive}\r\n twFrameRightInactive = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.twFrameRightInactive; {$EXTERNALSYM twFrameRightInactive}\r\n twFrameBottomActive = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.twFrameBottomActive; {$EXTERNALSYM twFrameBottomActive}\r\n twFrameBottomInactive = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.twFrameBottomInactive; {$EXTERNALSYM twFrameBottomInactive}\r\n twSmallFrameLeftActive = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.twSmallFrameLeftActive; {$EXTERNALSYM twSmallFrameLeftActive}\r\n twSmallFrameLeftInactive = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.twSmallFrameLeftInactive; {$EXTERNALSYM twSmallFrameLeftInactive}\r\n twSmallFrameRightActive = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.twSmallFrameRightActive; {$EXTERNALSYM twSmallFrameRightActive}\r\n twSmallFrameRightInactive = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.twSmallFrameRightInactive; {$EXTERNALSYM twSmallFrameRightInactive}\r\n twSmallFrameBottomActive = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.twSmallFrameBottomActive; {$EXTERNALSYM twSmallFrameBottomActive}\r\n twSmallFrameBottomInactive = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.twSmallFrameBottomInactive; {$EXTERNALSYM twSmallFrameBottomInactive}\r\n twSysButtonNormal = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.twSysButtonNormal; {$EXTERNALSYM twSysButtonNormal}\r\n twSysButtonHot = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.twSysButtonHot; {$EXTERNALSYM twSysButtonHot}\r\n twSysButtonPushed = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.twSysButtonPushed; {$EXTERNALSYM twSysButtonPushed}\r\n twSysButtonDisabled = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.twSysButtonDisabled; {$EXTERNALSYM twSysButtonDisabled}\r\n twMDISysButtonNormal = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.twMDISysButtonNormal; {$EXTERNALSYM twMDISysButtonNormal}\r\n twMDISysButtonHot = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.twMDISysButtonHot; {$EXTERNALSYM twMDISysButtonHot}\r\n twMDISysButtonPushed = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.twMDISysButtonPushed; {$EXTERNALSYM twMDISysButtonPushed}\r\n twMDISysButtonDisabled = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.twMDISysButtonDisabled; {$EXTERNALSYM twMDISysButtonDisabled}\r\n twMinButtonNormal = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.twMinButtonNormal; {$EXTERNALSYM twMinButtonNormal}\r\n twMinButtonHot = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.twMinButtonHot; {$EXTERNALSYM twMinButtonHot}\r\n twMinButtonPushed = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.twMinButtonPushed; {$EXTERNALSYM twMinButtonPushed}\r\n twMinButtonDisabled = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.twMinButtonDisabled; {$EXTERNALSYM twMinButtonDisabled}\r\n twMDIMinButtonNormal = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.twMDIMinButtonNormal; {$EXTERNALSYM twMDIMinButtonNormal}\r\n twMDIMinButtonHot = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.twMDIMinButtonHot; {$EXTERNALSYM twMDIMinButtonHot}\r\n twMDIMinButtonPushed = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.twMDIMinButtonPushed; {$EXTERNALSYM twMDIMinButtonPushed}\r\n twMDIMinButtonDisabled = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.twMDIMinButtonDisabled; {$EXTERNALSYM twMDIMinButtonDisabled}\r\n twMaxButtonNormal = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.twMaxButtonNormal; {$EXTERNALSYM twMaxButtonNormal}\r\n twMaxButtonHot = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.twMaxButtonHot; {$EXTERNALSYM twMaxButtonHot}\r\n twMaxButtonPushed = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.twMaxButtonPushed; {$EXTERNALSYM twMaxButtonPushed}\r\n twMaxButtonDisabled = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.twMaxButtonDisabled; {$EXTERNALSYM twMaxButtonDisabled}\r\n twCloseButtonNormal = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.twCloseButtonNormal; {$EXTERNALSYM twCloseButtonNormal}\r\n twCloseButtonHot = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.twCloseButtonHot; {$EXTERNALSYM twCloseButtonHot}\r\n twCloseButtonPushed = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.twCloseButtonPushed; {$EXTERNALSYM twCloseButtonPushed}\r\n twCloseButtonDisabled = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.twCloseButtonDisabled; {$EXTERNALSYM twCloseButtonDisabled}\r\n twSmallCloseButtonNormal = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.twSmallCloseButtonNormal; {$EXTERNALSYM twSmallCloseButtonNormal}\r\n twSmallCloseButtonHot = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.twSmallCloseButtonHot; {$EXTERNALSYM twSmallCloseButtonHot}\r\n twSmallCloseButtonPushed = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.twSmallCloseButtonPushed; {$EXTERNALSYM twSmallCloseButtonPushed}\r\n twSmallCloseButtonDisabled = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.twSmallCloseButtonDisabled; {$EXTERNALSYM twSmallCloseButtonDisabled}\r\n twMDICloseButtonNormal = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.twMDICloseButtonNormal; {$EXTERNALSYM twMDICloseButtonNormal}\r\n twMDICloseButtonHot = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.twMDICloseButtonHot; {$EXTERNALSYM twMDICloseButtonHot}\r\n twMDICloseButtonPushed = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.twMDICloseButtonPushed; {$EXTERNALSYM twMDICloseButtonPushed}\r\n twMDICloseButtonDisabled = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.twMDICloseButtonDisabled; {$EXTERNALSYM twMDICloseButtonDisabled}\r\n twRestoreButtonNormal = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.twRestoreButtonNormal; {$EXTERNALSYM twRestoreButtonNormal}\r\n twRestoreButtonHot = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.twRestoreButtonHot; {$EXTERNALSYM twRestoreButtonHot}\r\n twRestoreButtonPushed = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.twRestoreButtonPushed; {$EXTERNALSYM twRestoreButtonPushed}\r\n twRestoreButtonDisabled = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.twRestoreButtonDisabled; {$EXTERNALSYM twRestoreButtonDisabled}\r\n twMDIRestoreButtonNormal = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.twMDIRestoreButtonNormal; {$EXTERNALSYM twMDIRestoreButtonNormal}\r\n twMDIRestoreButtonHot = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.twMDIRestoreButtonHot; {$EXTERNALSYM twMDIRestoreButtonHot}\r\n twMDIRestoreButtonPushed = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.twMDIRestoreButtonPushed; {$EXTERNALSYM twMDIRestoreButtonPushed}\r\n twMDIRestoreButtonDisabled = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.twMDIRestoreButtonDisabled; {$EXTERNALSYM twMDIRestoreButtonDisabled}\r\n twHelpButtonNormal = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.twHelpButtonNormal; {$EXTERNALSYM twHelpButtonNormal}\r\n twHelpButtonHot = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.twHelpButtonHot; {$EXTERNALSYM twHelpButtonHot}\r\n twHelpButtonPushed = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.twHelpButtonPushed; {$EXTERNALSYM twHelpButtonPushed}\r\n twHelpButtonDisabled = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.twHelpButtonDisabled; {$EXTERNALSYM twHelpButtonDisabled}\r\n twMDIHelpButtonNormal = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.twMDIHelpButtonNormal; {$EXTERNALSYM twMDIHelpButtonNormal}\r\n twMDIHelpButtonHot = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.twMDIHelpButtonHot; {$EXTERNALSYM twMDIHelpButtonHot}\r\n twMDIHelpButtonPushed = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.twMDIHelpButtonPushed; {$EXTERNALSYM twMDIHelpButtonPushed}\r\n twMDIHelpButtonDisabled = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.twMDIHelpButtonDisabled; {$EXTERNALSYM twMDIHelpButtonDisabled}\r\n twHorzScrollNormal = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.twHorzScrollNormal; {$EXTERNALSYM twHorzScrollNormal}\r\n twHorzScrollHot = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.twHorzScrollHot; {$EXTERNALSYM twHorzScrollHot}\r\n twHorzScrollPushed = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.twHorzScrollPushed; {$EXTERNALSYM twHorzScrollPushed}\r\n twHorzScrollDisabled = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.twHorzScrollDisabled; {$EXTERNALSYM twHorzScrollDisabled}\r\n twHorzThumbNormal = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.twHorzThumbNormal; {$EXTERNALSYM twHorzThumbNormal}\r\n twHorzThumbHot = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.twHorzThumbHot; {$EXTERNALSYM twHorzThumbHot}\r\n twHorzThumbPushed = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.twHorzThumbPushed; {$EXTERNALSYM twHorzThumbPushed}\r\n twHorzThumbDisabled = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.twHorzThumbDisabled; {$EXTERNALSYM twHorzThumbDisabled}\r\n twVertScrollNormal = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.twVertScrollNormal; {$EXTERNALSYM twVertScrollNormal}\r\n twVertScrollHot = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.twVertScrollHot; {$EXTERNALSYM twVertScrollHot}\r\n twVertScrollPushed = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.twVertScrollPushed; {$EXTERNALSYM twVertScrollPushed}\r\n twVertScrollDisabled = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.twVertScrollDisabled; {$EXTERNALSYM twVertScrollDisabled}\r\n twVertThumbNormal = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.twVertThumbNormal; {$EXTERNALSYM twVertThumbNormal}\r\n twVertThumbHot = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.twVertThumbHot; {$EXTERNALSYM twVertThumbHot}\r\n twVertThumbPushed = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.twVertThumbPushed; {$EXTERNALSYM twVertThumbPushed}\r\n twVertThumbDisabled = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.twVertThumbDisabled; {$EXTERNALSYM twVertThumbDisabled}\r\n twDialog = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.twDialog; {$EXTERNALSYM twDialog}\r\n twCaptionSizingTemplate = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.twCaptionSizingTemplate; {$EXTERNALSYM twCaptionSizingTemplate}\r\n twSmallCaptionSizingTemplate = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.twSmallCaptionSizingTemplate; {$EXTERNALSYM twSmallCaptionSizingTemplate}\r\n twFrameLeftSizingTemplate = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.twFrameLeftSizingTemplate; {$EXTERNALSYM twFrameLeftSizingTemplate}\r\n twSmallFrameLeftSizingTemplate = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.twSmallFrameLeftSizingTemplate; {$EXTERNALSYM twSmallFrameLeftSizingTemplate}\r\n twFrameRightSizingTemplate = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.twFrameRightSizingTemplate; {$EXTERNALSYM twFrameRightSizingTemplate}\r\n twSmallFrameRightSizingTemplate = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.twSmallFrameRightSizingTemplate; {$EXTERNALSYM twSmallFrameRightSizingTemplate}\r\n twFrameBottomSizingTemplate = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.twFrameBottomSizingTemplate; {$EXTERNALSYM twFrameBottomSizingTemplate}\r\n twSmallFrameBottomSizingTemplate = {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.twSmallFrameBottomSizingTemplate; {$EXTERNALSYM twSmallFrameBottomSizingTemplate}\r\n\r\ntype\r\n TThemeServicesEx = class(TThemeServices)\r\n public\r\n {$IFNDEF COMPILER7_UP}\r\n procedure ApplyThemeChange;\r\n {$ENDIF ~COMPILER7_UP}\r\n {$IFNDEF COMPILER16_UP}\r\n function GetElementContentRect(DC: HDC; Details: TThemedElementDetails;\r\n const BoundingRect: TRect; out AContentRect: TRect): Boolean;\r\n function IsSystemStyle: Boolean;\r\n function Enabled: Boolean;\r\n function Available: Boolean;\r\n {$ENDIF ~COMPILER16_UP}\r\n end;\r\n\r\nfunction ThemeServices: TThemeServicesEx;\r\nfunction StyleServices: TThemeServicesEx;\r\n\r\n{ PaintControlBorder paints the themed border for WinControls only when they\r\n have the WS_EX_CLIENTEDGE. }\r\nprocedure PaintControlBorder(Control: TWinControl);\r\n\r\n{ DrawThemedBorder draws a teEditTextNormal element (border) to the DC. It uses\r\n the Control's BoundsRect. DrawThemedBorder forces border painting. }\r\nprocedure DrawThemedBorder(Control: TControl);\r\n\r\n{$ENDIF JVCLThemesEnabled}\r\n\r\ntype\r\n {$IFDEF COMPILER7_UP}\r\n TJvThemeStyle = TControlStyle;\r\n {$ELSE}\r\n TJvThemeStyle = set of (csNeedsBorderPaint, csParentBackground);\r\n {$ENDIF COMPILER7_UP}\r\n\r\n{\r\n Instead of the ControlStyle property you should use the following functions:\r\n\r\n ControlStyle := ControlStyle + [csXxx]; -> IncludeThemeStyle(Self, [csXxx]);\r\n ControlStyle := ControlStyle - [csXxx]; -> ExcludeThemeStyle(Self, [csXxx]);\r\n if csXxx in ControlStyle then -> if csXxx in GetThemeStyle(Self) then\r\n\r\n}\r\nprocedure IncludeThemeStyle(Control: TControl; Style: TJvThemeStyle);\r\nprocedure ExcludeThemeStyle(Control: TControl; Style: TJvThemeStyle);\r\nfunction GetThemeStyle(Control: TControl): TJvThemeStyle;\r\n\r\n{ DrawThemedBackground fills R with Canvas.Brush.Color/Color. If the control uses\r\n csParentBackground and the color is that of it's parent the Rect is not filled\r\n because then it is done by the JvThemes/VCL7. }\r\nprocedure DrawThemedBackground(Control: TControl; Canvas: TCanvas;\r\n const R: TRect; NeedsParentBackground: Boolean = True); overload;\r\nprocedure DrawThemedBackground(Control: TControl; Canvas: TCanvas;\r\n const R: TRect; Color: TColor; NeedsParentBackground: Boolean = True); overload;\r\nprocedure DrawThemedBackground(Control: TControl; DC: HDC; const R: TRect;\r\n Brush: HBRUSH; NeedsParentBackground: Boolean = True); overload;\r\n\r\n{ DrawThemesFrameControl draws a themed frame control when theming is enabled. }\r\nfunction DrawThemedFrameControl(DC: HDC; const Rect: TRect; uType, uState: UINT): BOOL;\r\n\r\n\r\n{ PerformEraseBackground sends a WM_ERASEBKGND message to the Control's parent. }\r\nprocedure PerformEraseBackground(Control: TControl; DC: HDC; Offset: TPoint); overload;\r\nprocedure PerformEraseBackground(Control: TControl; DC: HDC; Offset: TPoint; const R: TRect); overload;\r\nprocedure PerformEraseBackground(Control: TControl; DC: HDC); overload;\r\nprocedure PerformEraseBackground(Control: TControl; DC: HDC; const R: TRect); overload;\r\n\r\n\r\n{ DrawThemedButtonFace draws a themed button when theming is enabled. }\r\nfunction DrawThemedButtonFace(Control: TControl; Canvas: TCanvas; const Client: TRect;\r\n BevelWidth: Integer; Style: TButtonStyle; IsRounded, IsDown,\r\n IsFocused, IsHot: Boolean): TRect;\r\n\r\n{ IsMouseOver returns True if the mouse is over the control. }\r\nfunction IsMouseOver(Control: TControl): Boolean;\r\n\r\n// ~COMPILER7_UP: These functions are helpers for Delphi 6 that doesn't have the csParentPackground flag.\r\n{ GetParentBackground returns True if the Control has the csParentPackground\r\n ControlStyle }\r\nfunction GetParentBackground(Control: TWinControl): Boolean;\r\n{ SetParentBackground sets the Control's csParentPackground ControlStyle }\r\nprocedure SetParentBackground(Control: TWinControl; Value: Boolean);\r\n\r\n{ GetGlassPaintFlag returns True if csGlassPaint in ControlState }\r\nfunction GetGlassPaintFlag(AControl: TControl): Boolean;\r\n{ ControlInGlassPaint returns True if the Control is painted on a glass area }\r\nfunction ControlInGlassPaint(AControl: TControl): Boolean;\r\n{ DrawGlassableText paints text to a device context with support of PaintOnGlass }\r\nprocedure DrawGlassableText(DC: HDC; const Text: string; var TextRect: TRect; TextFlags: Cardinal;\r\n PaintOnGlass: Boolean = False);\r\n{ DrawGlassableImageList paint a transparent imagelist image to the canvas with\r\n support of PaintOnGlass }\r\nprocedure DrawGlassableImageList(ImageList: HIMAGELIST; Index: Integer; Dest: HDC; X, Y: Integer;\r\n Style: UINT; PaintOnGlass: Boolean = False);\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvThemes.pas $';\r\n Revision: '$Revision: 13415 $';\r\n Date: '$Date: 2012-09-10 11:51:54 +0200 (lun. 10 sept. 2012) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\n{$IFNDEF COMPILER10_UP}\r\nuses\r\n JclSysUtils;\r\n{$ENDIF ~COMPILER10_UP}\r\n\r\ntype\r\n TWinControlThemeInfo = class(TWinControl)\r\n public\r\n property Color;\r\n end;\r\n\r\nprocedure DrawThemedBackground(Control: TControl; Canvas: TCanvas;\r\n const R: TRect; NeedsParentBackground: Boolean = True);\r\nbegin\r\n DrawThemedBackground(Control, Canvas, R, Canvas.Brush.Color, NeedsParentBackground);\r\nend;\r\n\r\nprocedure DrawThemedBackground(Control: TControl; Canvas: TCanvas;\r\n const R: TRect; Color: TColor; NeedsParentBackground: Boolean = True);\r\nvar\r\n Cl: TColor;\r\nbegin\r\n {$IFDEF JVCLThemesEnabled}\r\n if ThemeServices.Enabled and\r\n (Control.Parent <> nil) and\r\n ((Color = TWinControlThemeInfo(Control.Parent).Color) or\r\n (ColorToRGB(Color) = ColorToRGB(TWinControlThemeInfo(Control.Parent).Color))) and\r\n ((not NeedsParentBackground) or (csParentBackground in GetThemeStyle(Control))) then\r\n begin\r\n if Control is TWinControl then\r\n begin\r\n if TWinControl(Control).DoubleBuffered then\r\n PerformEraseBackground(Control, Canvas.Handle, R)\r\n else\r\n ThemeServices.DrawParentBackground(TWinControl(Control).Handle, Canvas.Handle, nil,\r\n False, @R);\r\n end\r\n else\r\n PerformEraseBackground(Control, Canvas.Handle, R)\r\n end\r\n else\r\n {$ENDIF JVCLThemesEnabled}\r\n begin\r\n Cl := Canvas.Brush.Color;\r\n if Cl <> Color then\r\n Canvas.Brush.Color := Color;\r\n Canvas.FillRect(R);\r\n if Cl <> Canvas.Brush.Color then\r\n Canvas.Brush.Color := Cl;\r\n end;\r\nend;\r\n\r\nprocedure DrawThemedBackground(Control: TControl; DC: HDC; const R: TRect;\r\n Brush: HBRUSH; NeedsParentBackground: Boolean = True);\r\n{$IFDEF JVCLThemesEnabled}\r\nvar\r\n LogBrush: TLogBrush;\r\n{$ENDIF JVCLThemesEnabled}\r\nbegin\r\n {$IFDEF JVCLThemesEnabled}\r\n GetObject(Brush, SizeOf(LogBrush), @LogBrush);\r\n if ThemeServices.Enabled and\r\n (Control.Parent <> nil) and\r\n (LogBrush.lbColor = Cardinal(ColorToRGB(TWinControlThemeInfo(Control.Parent).Color))) and\r\n ((not NeedsParentBackground) or\r\n (csParentBackground in GetThemeStyle(Control))) then\r\n begin\r\n if Control is TWinControl then\r\n begin\r\n if TWinControl(Control).DoubleBuffered then\r\n PerformEraseBackground(Control, DC, R)\r\n else\r\n ThemeServices.DrawParentBackground(TWinControl(Control).Handle, DC, nil, False, @R);\r\n end\r\n else\r\n PerformEraseBackground(Control, DC, R)\r\n end\r\n else\r\n {$ENDIF JVCLThemesEnabled}\r\n FillRect(DC, R, Brush);\r\nend;\r\n\r\nfunction DrawThemedFrameControl(DC: HDC; const Rect: TRect; uType, uState: UINT): BOOL;\r\n{$IFDEF JVCLThemesEnabled}\r\nconst\r\n Mask = $00FF;\r\nvar\r\n Btn: TThemedButton;\r\n ComboBox: TThemedComboBox;\r\n ScrollBar: TThemedScrollBar;\r\n R: TRect;\r\n Details: TThemedElementDetails;\r\n{$ENDIF JVCLThemesEnabled}\r\nbegin\r\n Result := False;\r\n {$IFDEF JVCLThemesEnabled}\r\n if ThemeServices.Enabled then\r\n begin\r\n R := Rect;\r\n case uType of\r\n DFC_BUTTON:\r\n case uState and Mask of\r\n DFCS_BUTTONPUSH:\r\n begin\r\n if uState and (DFCS_TRANSPARENT or DFCS_FLAT) = 0 then\r\n begin\r\n if uState and DFCS_INACTIVE <> 0 then\r\n Btn := tbPushButtonDisabled\r\n else\r\n if uState and DFCS_PUSHED <> 0 then\r\n Btn := tbPushButtonPressed\r\n else\r\n if uState and DFCS_HOT <> 0 then\r\n Btn := tbPushButtonHot\r\n else\r\n if uState and DFCS_MONO <> 0 then\r\n Btn := tbPushButtonDefaulted\r\n else\r\n Btn := tbPushButtonNormal;\r\n\r\n Details := ThemeServices.GetElementDetails(Btn);\r\n ThemeServices.DrawElement(DC, Details, R);\r\n Result := True;\r\n end;\r\n end;\r\n DFCS_BUTTONCHECK:\r\n begin\r\n if uState and DFCS_CHECKED <> 0 then\r\n begin\r\n if uState and DFCS_INACTIVE <> 0 then\r\n Btn := tbCheckBoxCheckedDisabled\r\n else\r\n if uState and DFCS_PUSHED <> 0 then\r\n Btn := tbCheckBoxCheckedPressed\r\n else\r\n if uState and DFCS_HOT <> 0 then\r\n Btn := tbCheckBoxCheckedHot\r\n else\r\n Btn := tbCheckBoxCheckedNormal;\r\n end\r\n else\r\n if uState and DFCS_MONO <> 0 then\r\n begin\r\n if uState and DFCS_INACTIVE <> 0 then\r\n Btn := tbCheckBoxMixedDisabled\r\n else\r\n if uState and DFCS_PUSHED <> 0 then\r\n Btn := tbCheckBoxMixedPressed\r\n else\r\n if uState and DFCS_HOT <> 0 then\r\n Btn := tbCheckBoxMixedHot\r\n else\r\n Btn := tbCheckBoxMixedNormal;\r\n end\r\n else\r\n begin\r\n if uState and DFCS_INACTIVE <> 0 then\r\n Btn := tbCheckBoxUncheckedDisabled\r\n else\r\n if uState and DFCS_PUSHED <> 0 then\r\n Btn := tbCheckBoxUncheckedPressed\r\n else\r\n if uState and DFCS_HOT <> 0 then\r\n Btn := tbCheckBoxUncheckedHot\r\n else\r\n Btn := tbCheckBoxUncheckedNormal;\r\n end;\r\n Details := ThemeServices.GetElementDetails(Btn);\r\n ThemeServices.DrawElement(DC, Details, R);\r\n Result := True;\r\n end;\r\n DFCS_BUTTONRADIO:\r\n begin\r\n if uState and DFCS_CHECKED <> 0 then\r\n begin\r\n if uState and DFCS_INACTIVE <> 0 then\r\n Btn := tbRadioButtonCheckedDisabled\r\n else\r\n if uState and DFCS_PUSHED <> 0 then\r\n Btn := tbRadioButtonCheckedPressed\r\n else\r\n if uState and DFCS_HOT <> 0 then\r\n Btn := tbRadioButtonCheckedHot\r\n else\r\n Btn := tbRadioButtonCheckedNormal;\r\n end\r\n else\r\n begin\r\n if uState and DFCS_INACTIVE <> 0 then\r\n Btn := tbRadioButtonUncheckedDisabled\r\n else\r\n if uState and DFCS_PUSHED <> 0 then\r\n Btn := tbRadioButtonUncheckedPressed\r\n else\r\n if uState and DFCS_HOT <> 0 then\r\n Btn := tbRadioButtonUncheckedHot\r\n else\r\n Btn := tbRadioButtonUncheckedNormal;\r\n end;\r\n Details := ThemeServices.GetElementDetails(Btn);\r\n ThemeServices.DrawElement(DC, Details, R);\r\n Result := True;\r\n end;\r\n end;\r\n DFC_SCROLL:\r\n begin\r\n case uState and Mask of\r\n DFCS_SCROLLCOMBOBOX:\r\n begin\r\n if uState and DFCS_INACTIVE <> 0 then\r\n ComboBox := tcDropDownButtonDisabled\r\n else\r\n if uState and DFCS_PUSHED <> 0 then\r\n ComboBox := tcDropDownButtonPressed\r\n else\r\n if uState and DFCS_HOT <> 0 then\r\n ComboBox := tcDropDownButtonHot\r\n else\r\n ComboBox := tcDropDownButtonNormal;\r\n\r\n Details := ThemeServices.GetElementDetails(ComboBox);\r\n ThemeServices.DrawElement(DC, Details, R);\r\n Result := True;\r\n end;\r\n DFCS_SCROLLUP:\r\n if uState and (DFCS_TRANSPARENT {or DFCS_FLAT}) = 0 then\r\n begin\r\n if uState and DFCS_INACTIVE <> 0 then\r\n ScrollBar := tsArrowBtnUpDisabled\r\n else\r\n if uState and DFCS_PUSHED <> 0 then\r\n ScrollBar := tsArrowBtnUpPressed\r\n else\r\n if uState and DFCS_HOT <> 0 then\r\n ScrollBar := tsArrowBtnUpHot\r\n else\r\n ScrollBar := tsArrowBtnUpNormal;\r\n\r\n Details := ThemeServices.GetElementDetails(ScrollBar);\r\n ThemeServices.DrawElement(DC, Details, R);\r\n Result := True;\r\n end;\r\n DFCS_SCROLLDOWN:\r\n if uState and (DFCS_TRANSPARENT {or DFCS_FLAT}) = 0 then\r\n begin\r\n if uState and DFCS_INACTIVE <> 0 then\r\n ScrollBar := tsArrowBtnDownDisabled\r\n else\r\n if uState and DFCS_PUSHED <> 0 then\r\n ScrollBar := tsArrowBtnDownPressed\r\n else\r\n if uState and DFCS_HOT <> 0 then\r\n ScrollBar := tsArrowBtnDownHot\r\n else\r\n ScrollBar := tsArrowBtnDownNormal;\r\n\r\n Details := ThemeServices.GetElementDetails(ScrollBar);\r\n ThemeServices.DrawElement(DC, Details, R);\r\n Result := True;\r\n end;\r\n DFCS_SCROLLLEFT:\r\n if uState and (DFCS_TRANSPARENT {or DFCS_FLAT}) = 0 then\r\n begin\r\n if uState and DFCS_INACTIVE <> 0 then\r\n ScrollBar := tsArrowBtnLeftDisabled\r\n else\r\n if uState and DFCS_PUSHED <> 0 then\r\n ScrollBar := tsArrowBtnLeftPressed\r\n else\r\n if uState and DFCS_HOT <> 0 then\r\n ScrollBar := tsArrowBtnLeftHot\r\n else\r\n ScrollBar := tsArrowBtnLeftNormal;\r\n\r\n Details := ThemeServices.GetElementDetails(ScrollBar);\r\n ThemeServices.DrawElement(DC, Details, R);\r\n Result := True;\r\n end;\r\n DFCS_SCROLLRIGHT:\r\n if uState and (DFCS_TRANSPARENT {or DFCS_FLAT}) = 0 then\r\n begin\r\n if uState and DFCS_INACTIVE <> 0 then\r\n ScrollBar := tsArrowBtnRightDisabled\r\n else\r\n if uState and DFCS_PUSHED <> 0 then\r\n ScrollBar := tsArrowBtnRightPressed\r\n else\r\n if uState and DFCS_HOT <> 0 then\r\n ScrollBar := tsArrowBtnRightHot\r\n else\r\n ScrollBar := tsArrowBtnRightNormal;\r\n\r\n Details := ThemeServices.GetElementDetails(ScrollBar);\r\n ThemeServices.DrawElement(DC, Details, R);\r\n Result := True;\r\n end;\r\n end;\r\n end;\r\n end;\r\n end;\r\n {$ENDIF JVCLThemesEnabled}\r\n\r\n if not Result then\r\n Result := DrawFrameControl(DC, Rect, uType, uState);\r\nend;\r\n\r\nfunction IsInvalidRect(const R: TRect): Boolean; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\nbegin\r\n Result := (R.Left = MaxInt) and (R.Top = MaxInt) and (R.Right = MaxInt) and (R.Bottom = MaxInt);\r\nend;\r\n\r\nprocedure PerformEraseBackground(Control: TControl; DC: HDC; Offset: TPoint);\r\nbegin\r\n PerformEraseBackground(Control, DC, Offset, Rect(MaxInt, MaxInt, MaxInt, MaxInt));\r\nend;\r\n\r\nprocedure PerformEraseBackground(Control: TControl; DC: HDC; Offset: TPoint; const R: TRect);\r\nvar\r\n WindowOrg: TPoint;\r\n OrgRgn, Rgn: THandle;\r\n {$IFDEF COMPILER16_UP}\r\n OldPen: HPEN;\r\n OldBrush: HBRUSH;\r\n OldFont: HFONT;\r\n OldTextColor: TColorRef;\r\n OldBkMode: Integer;\r\n {$ENDIF COMPILER16_UP}\r\nbegin\r\n if Control.Parent <> nil then\r\n begin\r\n if (Offset.X <> 0) and (Offset.Y <> 0) then\r\n begin\r\n GetWindowOrgEx(DC, WindowOrg);\r\n if Control is TGraphicControl then\r\n SetWindowOrgEx(DC, -Offset.X, -Offset.Y, nil)\r\n else\r\n SetWindowOrgEx(DC, WindowOrg.X + Offset.X, WindowOrg.Y + Offset.Y, nil);\r\n end;\r\n\r\n OrgRgn := 0;\r\n if not IsInvalidRect(R) then\r\n begin\r\n OrgRgn := CreateRectRgn(0, 0, 1, 1);\r\n if GetClipRgn(DC, OrgRgn) = 0 then\r\n begin\r\n DeleteObject(OrgRgn);\r\n OrgRgn := 0;\r\n end;\r\n Rgn := CreateRectRgnIndirect(R);\r\n SelectClipRgn(DC, Rgn);\r\n DeleteObject(Rgn);\r\n end;\r\n\r\n try\r\n {$IFDEF COMPILER16_UP}\r\n // Delphi XE2's Style-Engine has a bug in the TStyleHook.WMEraseBkgnd that replaces the\r\n // selected GDI objects with the TCanvas default objects (\"System\" font, ...).\r\n // We need to repair the damage in order to have the same behavior of the native theming API.\r\n // General rule for WM_ERASEBKGND: Return the DC in the state in that it was when the function\r\n // was called.\r\n OldPen := 0;\r\n OldBrush := 0;\r\n OldFont := 0;\r\n OldTextColor := 0;\r\n OldBkMode := 0;\r\n if StyleServices.Enabled and not StyleServices.IsSystemStyle then\r\n begin\r\n OldPen := GetCurrentObject(DC, OBJ_PEN);\r\n OldBrush := GetCurrentObject(DC, OBJ_BRUSH);\r\n OldFont := GetCurrentObject(DC, OBJ_FONT);\r\n OldTextColor := GetTextColor(DC);\r\n OldBkMode := GetBkMode(DC);\r\n end;\r\n {$ENDIF COMPILER16_UP}\r\n Control.Parent.Perform(WM_ERASEBKGND, DC, DC); // force redraw\r\n {$IFDEF COMPILER16_UP}\r\n if StyleServices.Enabled and not StyleServices.IsSystemStyle then\r\n begin\r\n if GetCurrentObject(DC, OBJ_PEN) <> OldPen then\r\n SelectObject(DC, OldPen);\r\n if GetCurrentObject(DC, OBJ_BRUSH) <> OldBrush then\r\n SelectObject(DC, OldBrush);\r\n if GetCurrentObject(DC, OBJ_FONT) <> OldFont then\r\n SelectObject(DC, OldFont);\r\n if GetTextColor(DC) <> OldTextColor then\r\n SetTextColor(DC, OldTextColor);\r\n if GetBkMode(DC) <> OldBkMode then\r\n SetBkMode(DC, OldBkMode);\r\n end;\r\n {$ENDIF COMPILER16_UP}\r\n finally\r\n if (Offset.X <> 0) and (Offset.Y <> 0) then\r\n SetWindowOrgEx(DC, WindowOrg.X, WindowOrg.Y, nil);\r\n\r\n if OrgRgn <> 0 then\r\n begin\r\n SelectClipRgn(DC, OrgRgn);\r\n DeleteObject(OrgRgn);\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure PerformEraseBackground(Control: TControl; DC: HDC);\r\nbegin\r\n PerformEraseBackground(Control, DC, Point(Control.Left, Control.Top));\r\nend;\r\n\r\nprocedure PerformEraseBackground(Control: TControl; DC: HDC; const R: TRect);\r\nbegin\r\n PerformEraseBackground(Control, DC, Point(Control.Left, Control.Top), R);\r\nend;\r\n\r\nfunction DrawThemedButtonFace(Control: TControl; Canvas: TCanvas;\r\n const Client: TRect; BevelWidth: Integer; Style: TButtonStyle;\r\n IsRounded, IsDown, IsFocused, IsHot: Boolean): TRect;\r\n{$IFDEF JVCLThemesEnabled}\r\nvar\r\n Btn: TThemedButton;\r\n Details: TThemedElementDetails;\r\n{$ENDIF JVCLThemesEnabled}\r\nbegin\r\n {$IFDEF JVCLThemesEnabled}\r\n if (Style <> bsWin31) and ThemeServices.Enabled then\r\n begin\r\n Result := Client;\r\n\r\n if IsDown then\r\n Btn := tbPushButtonPressed\r\n else\r\n if IsFocused then\r\n Btn := tbPushButtonDefaulted\r\n else\r\n if IsHot then\r\n Btn := tbPushButtonHot\r\n else\r\n Btn := tbPushButtonNormal;\r\n\r\n Details := ThemeServices.GetElementDetails(Btn);\r\n ThemeServices.DrawElement(Canvas.Handle, Details, Result);\r\n ThemeServices.GetElementContentRect(Canvas.Handle, Details, Client, Result);\r\n\r\n if IsFocused then\r\n DrawFocusRect(Canvas.Handle, Result);\r\n\r\n InflateRect(Result, -BevelWidth, -BevelWidth);\r\n end\r\n else\r\n {$ENDIF JVCLThemesEnabled}\r\n Result := DrawButtonFace(Canvas, Client, BevelWidth, Style, IsRounded, IsDown, IsFocused);\r\nend;\r\n\r\nfunction IsMouseOver(Control: TControl): Boolean;\r\nvar\r\n Pt: TPoint;\r\nbegin\r\n Pt := Control.ScreenToClient(Mouse.CursorPos);\r\n Result := PtInRect(Control.ClientRect, Pt);\r\nend;\r\n\r\nfunction GetParentBackground(Control: TWinControl): Boolean;\r\nbegin\r\n Result := csParentBackground in GetThemeStyle(Control);\r\nend;\r\n\r\nprocedure SetParentBackground(Control: TWinControl; Value: Boolean);\r\nbegin\r\n if Value <> GetParentBackground(Control) then\r\n begin\r\n if Value then\r\n IncludeThemeStyle(Control, [csParentBackground])\r\n else\r\n ExcludeThemeStyle(Control, [csParentBackground]);\r\n Control.Invalidate;\r\n end;\r\nend;\r\n\r\nfunction GetGlassPaintFlag(AControl: TControl): Boolean;\r\n{$IFDEF COMPILER11}\r\nvar\r\n Form: TCustomForm;\r\n{$ENDIF COMPILER11}\r\nbegin\r\n {$IFDEF COMPILER12_UP}\r\n Result := csGlassPaint in AControl.ControlState;\r\n {$ELSE}\r\n Result := False;\r\n {$IFDEF COMPILER11}\r\n Form := GetParentForm(AControl);\r\n if (Form <> nil) and Form.GlassFrame.Enabled then\r\n Result := Form.GlassFrame.IntersectsControl(AControl);\r\n {$ENDIF COMPILER11}\r\n {$ENDIF COMPILER12_UP}\r\nend;\r\n\r\nfunction ControlInGlassPaint(AControl: TControl): Boolean;\r\n{$IFDEF COMPILER11_UP}\r\nvar\r\n Parent: TWinControl;\r\n{$ENDIF COMPILER11_UP}\r\nbegin\r\n {$IFDEF COMPILER11_UP}\r\n Result := GetGlassPaintFlag(AControl);\r\n if Result then\r\n begin\r\n Parent := AControl.Parent;\r\n while (Parent <> nil) and not Parent.DoubleBuffered and not (Parent is TCustomForm) do\r\n Parent := Parent.Parent;\r\n Result := (Parent = nil) or not Parent.DoubleBuffered or (Parent is TCustomForm);\r\n end;\r\n {$ELSE}\r\n Result := False;\r\n {$ENDIF COMPILER11_UP}\r\nend;\r\n\r\nprocedure DrawGlassableText(DC: HDC; const Text: string; var TextRect: TRect; TextFlags: Cardinal;\r\n PaintOnGlass: Boolean = False);\r\n{$IFDEF COMPILER11_UP}\r\nvar\r\n Options: TDTTOpts;\r\n {$IFDEF COMPILER11}\r\n S: WideString;\r\n {$ENDIF COMPILER11}\r\n{$ENDIF COMPILER11_UP}\r\nbegin\r\n {$IFDEF COMPILER11_UP}\r\n if ThemeServices.Enabled and CheckWin32Version(6, 0) then\r\n begin\r\n FillChar(Options, SizeOf(Options), 0);\r\n Options.dwSize := SizeOf(Options);\r\n if TextFlags and DT_CALCRECT <> 0 then\r\n Options.dwFlags := Options.dwFlags or DTT_CALCRECT;\r\n if PaintOnGlass then\r\n Options.dwFlags := Options.dwFlags or DTT_COMPOSITED;\r\n Options.dwFlags := Options.dwFlags or DTT_TEXTCOLOR;\r\n Options.crText := GetTextColor(DC);\r\n\r\n {$IFDEF COMPILER16_UP}\r\n if not StyleServices.IsSystemStyle then\r\n begin\r\n // The Style engine doesn't have DrawThemeTextEx support\r\n {$WARNINGS OFF} // ignore \"deprecated\" warning\r\n StyleServices.DrawText(DC, StyleServices.GetElementDetails(tbPushButtonNormal), Text, TextRect, TextFlags, 0);\r\n {$WARNINGS ON}\r\n Exit;\r\n end\r\n else\r\n {$ENDIF}\r\n begin\r\n {$IFDEF COMPILER12_UP}\r\n with ThemeServices do\r\n if DrawThemeTextEx(Theme[teToolBar], DC, TP_BUTTON, TS_NORMAL, PWideChar(Text), Length(Text),\r\n TextFlags, TextRect, Options) <> E_NOTIMPL then\r\n Exit;\r\n {$ELSE}\r\n S := Text;\r\n with ThemeServices do\r\n if DrawThemeTextEx(Theme[teToolBar], DC, TP_BUTTON, TS_NORMAL, PWideChar(S), Length(S),\r\n TextFlags, @TextRect, Options) <> E_NOTIMPL then\r\n Exit;\r\n {$ENDIF COMPILER12_UP}\r\n end;\r\n end;\r\n {$ENDIF COMPILER11_UP}\r\n Windows.DrawText(DC, PChar(Text), Length(Text), TextRect, TextFlags);\r\nend;\r\n\r\nprocedure DrawGlassableImageList(ImageList: HIMAGELIST; Index: Integer; Dest: HDC; X, Y: Integer;\r\n Style: UINT; PaintOnGlass: Boolean = False);\r\n{$IFDEF COMPILER11_UP}\r\nvar\r\n PaintBuffer: HPAINTBUFFER;\r\n R: TRect;\r\n MemDC, MaskDC: HDC;\r\n CX, CY, XX, YY: Integer;\r\n MaskBmp: TBitmap;\r\n{$ENDIF COMPILER11_UP}\r\nbegin\r\n {$IFDEF COMPILER11_UP}\r\n if PaintOnGlass and CheckWin32Version(6, 0) then\r\n begin\r\n { TODO : Not working correctly on a JvSpeedButton. But it works if used direcly on\r\n a sheet of glass. Some optimizations could be done. }\r\n\r\n ImageList_GetIconSize(ImageList, CX, CY);\r\n R := Rect(X, Y, X + CX, Y + CY);\r\n\r\n PaintBuffer := BeginBufferedPaint(Dest, R, BPBF_TOPDOWNDIB, nil, MemDC);\r\n try\r\n ImageList_Draw(ImageList, Index, MemDC, X, Y, Style);\r\n BufferedPaintMakeOpaque(PaintBuffer, @R);\r\n\r\n MaskBmp := TBitmap.Create;\r\n try\r\n MaskBmp.Width := CX;\r\n MaskBmp.Height := CY;\r\n MaskDC := MaskBmp.Canvas.Handle;\r\n ImageList_Draw(ImageList, Index, MaskDC, 0, 0, ILD_MASK);\r\n for YY := 0 to CY - 1 do\r\n for XX := 0 to CX - 1 do\r\n if GetPixel(MaskDC, XX, YY) <> 0 then\r\n begin\r\n R := Rect(X + XX, Y + YY, X + XX + 1, Y + YY + 1);\r\n BufferedPaintSetAlpha(PaintBuffer, @R, 0);\r\n //SetPixel(MemDC, X + XX, Y + YY, GetPixel(MemDC, X + XX, Y + YY) and $00FFFFFF);\r\n end;\r\n finally\r\n MaskBmp.Free;\r\n end;\r\n finally\r\n EndBufferedPaint(PaintBuffer, True);\r\n end;\r\n end\r\n else\r\n {$ENDIF COMPILER11_UP}\r\n ImageList_Draw(ImageList, Index, Dest, X, Y, Style);\r\nend;\r\n\r\n{$IFDEF JVCLThemesEnabled}\r\n\r\n{$IFNDEF COMPILER7_UP}\r\nprocedure TThemeServicesEx.ApplyThemeChange;\r\nbegin\r\n ThemeServices.UpdateThemes;\r\n ThemeServices.DoOnThemeChange;\r\nend;\r\n{$ENDIF ~COMPILER7_UP}\r\n\r\n{$IFNDEF COMPILER16_UP}\r\nfunction TThemeServicesEx.GetElementContentRect(DC: HDC; Details: TThemedElementDetails;\r\n const BoundingRect: TRect; out AContentRect: TRect): Boolean;\r\nbegin\r\n AContentRect := ContentRect(DC, Details, BoundingRect);\r\n Result := True;\r\nend;\r\n\r\nfunction TThemeServicesEx.IsSystemStyle: Boolean;\r\nbegin\r\n Result := True;\r\nend;\r\n\r\nfunction TThemeServicesEx.Enabled: Boolean;\r\nbegin\r\n Result := ThemesEnabled;\r\nend;\r\n\r\nfunction TThemeServicesEx.Available: Boolean;\r\nbegin\r\n Result := ThemesAvailable;\r\nend;\r\n{$ENDIF ~COMPILER16_UP}\r\n\r\nfunction ThemeServices: TThemeServicesEx;\r\nbegin\r\n Result := TThemeServicesEx(\r\n {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.{$IFDEF RTL230_UP}StyleServices{$ELSE}ThemeServices{$ENDIF RTL230_UP});\r\nend;\r\n\r\nfunction StyleServices: TThemeServicesEx;\r\nbegin\r\n Result := TThemeServicesEx(\r\n {$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.{$IFDEF RTL230_UP}StyleServices{$ELSE}ThemeServices{$ENDIF RTL230_UP});\r\nend;\r\n\r\nprocedure PaintControlBorder(Control: TWinControl);\r\nbegin\r\n ThemeServices.PaintBorder(TWinControl(Control), False)\r\nend;\r\n\r\nprocedure DrawThemedBorder(Control: TControl);\r\nvar\r\n Details: TThemedElementDetails;\r\n DrawRect: TRect;\r\n DC: HDC;\r\n Handle: THandle;\r\nbegin\r\n if Control is TWinControl then\r\n begin\r\n Handle := TWinControl(Control).Handle;\r\n DC := GetWindowDC(Handle);\r\n GetWindowRect(Handle, DrawRect);\r\n OffsetRect(DrawRect, -DrawRect.Left, -DrawRect.Top);\r\n end\r\n else\r\n begin\r\n if Control.Parent = nil then\r\n Exit;\r\n Handle := Control.Parent.Handle;\r\n DC := GetDC(Handle);\r\n DrawRect := Control.BoundsRect;\r\n end;\r\n\r\n ExcludeClipRect(DC, DrawRect.Left + 2, DrawRect.Top + 2, DrawRect.Right - 2, DrawRect.Bottom - 2);\r\n Details := ThemeServices.GetElementDetails(teEditTextNormal);\r\n ThemeServices.DrawElement(DC, Details, DrawRect);\r\n\r\n ReleaseDC(Handle, DC);\r\nend;\r\n\r\n{$IFDEF COMPILER7_UP}\r\n\r\n{ Delphi 7 and newer handle these styles itself. }\r\n\r\ntype\r\n TControlAccessProtected = class(TControl);\r\n\r\nprocedure IncludeThemeStyle(Control: TControl; Style: TJvThemeStyle);\r\nbegin\r\n with TControlAccessProtected(Control) do\r\n ControlStyle := ControlStyle + (Style * [csNeedsBorderPaint, csParentBackground]);\r\nend;\r\n\r\nprocedure ExcludeThemeStyle(Control: TControl; Style: TJvThemeStyle);\r\nbegin\r\n with TControlAccessProtected(Control) do\r\n ControlStyle := ControlStyle - (Style * [csNeedsBorderPaint, csParentBackground]);\r\nend;\r\n\r\nfunction GetThemeStyle(Control: TControl): TJvThemeStyle;\r\nbegin\r\n with TControlAccessProtected(Control) do\r\n Result := ControlStyle * [csNeedsBorderPaint, csParentBackground];\r\nend;\r\n\r\n{$ELSE} // COMPILER7_UP\r\n\r\n{ Delphi 5 and 6 need WindowProc hooks }\r\n\r\ntype\r\n THookStatus = (hsNone, hsInWndProc, hsDelete);\r\n\r\n TThemeHook = class(TObject)\r\n public\r\n FControl: TControl;\r\n FStatus: THookStatus;\r\n FWndProcCount: Integer;\r\n FDead: Boolean;\r\n FThemeStyle: TJvThemeStyle;\r\n FOrgWndProc: TWndMethod;\r\n\r\n procedure WndProc(var Msg: TMessage);\r\n protected\r\n procedure ThemedPaint(var Msg: TWMPaint; var Handled: Boolean);\r\n procedure ThemedNCPaint(var Msg: TWMNCPaint);\r\n procedure ThemedEraseBkgnd(var Msg: TWMEraseBkgnd; var Handled: Boolean);\r\n procedure ThemedCtlColorStatic(var Msg: TWMCtlColorStatic; var Handled: Boolean);\r\n public\r\n constructor Create(AControl: TControl);\r\n destructor Destroy; override;\r\n procedure DeleteHook;\r\n\r\n procedure IncludeThemeStyle(Style: TJvThemeStyle);\r\n procedure ExcludeThemeStyle(Style: TJvThemeStyle);\r\n\r\n property Control: TControl read FControl;\r\n property ThemeStyle: TJvThemeStyle read FThemeStyle;\r\n end;\r\n\r\n { TThemeHookList contains all ThemeHooks. }\r\n TThemeHookList = class(TObjectList)\r\n private\r\n FLock: TRTLCriticalSection;\r\n FRecreationList: TList;\r\n FDeadList: TObjectList;\r\n FEraseBkgndHooked: Boolean;\r\n public\r\n constructor Create;\r\n destructor Destroy; override;\r\n\r\n procedure Enter;\r\n procedure Leave;\r\n\r\n function FindControl(Control: TControl): TThemeHook;\r\n\r\n { GetControl returns the TThemeHook for the Control. If there is no item\r\n it creates a new one. }\r\n function GetControl(Control: TControl): TThemeHook;\r\n\r\n property RecreationList: TList read FRecreationList;\r\n end;\r\n\r\n { TThemeHookComponent is responsible for unhooking TGraphicControls. }\r\n TThemeHookComponent = class(TComponent)\r\n protected\r\n procedure Notification(AComponent: TComponent; Operation: TOperation); override;\r\n end;\r\n\r\n// global ThemeHook list\r\nvar\r\n GlobalThemeHooks: TThemeHookList = nil;\r\n ThemeHookComponent: TThemeHookComponent = nil;\r\n WinControlHookInstalled: Boolean = False;\r\n\r\nprocedure InstallWinControlHook; forward;\r\nprocedure UninstallWinControlHook; forward;\r\n\r\nfunction ThemeHooks: TThemeHookList;\r\nbegin\r\n if not Assigned(GlobalThemeHooks) then\r\n GlobalThemeHooks := TThemeHookList.Create;\r\n Result := GlobalThemeHooks;\r\nend;\r\n\r\n//=== { TThemeHookList } =====================================================\r\n\r\nconstructor TThemeHookList.Create;\r\nbegin\r\n inherited Create;\r\n FRecreationList := TList.Create;\r\n FDeadList := TObjectList.Create;\r\n InitializeCriticalSection(FLock);\r\n\r\n ThemeHookComponent := TThemeHookComponent.Create(nil); // global variable\r\nend;\r\n\r\ndestructor TThemeHookList.Destroy;\r\nbegin\r\n FRecreationList.Free;\r\n FDeadList.Free;\r\n DeleteCriticalSection(FLock);\r\n\r\n Clear; // destroy TThemeHook instances which require ThemeHookComponent\r\n ThemeHookComponent.Free; // global variable\r\n\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TThemeHookList.Enter;\r\nbegin\r\n EnterCriticalSection(FLock);\r\nend;\r\n\r\nprocedure TThemeHookList.Leave;\r\nbegin\r\n LeaveCriticalSection(FLock);\r\nend;\r\n\r\nfunction TThemeHookList.FindControl(Control: TControl): TThemeHook;\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := 0 to Count - 1 do\r\n begin\r\n Result := TThemeHook(Items[I]);\r\n if Result.FControl = Control then\r\n Exit;\r\n end;\r\n Result := nil;\r\nend;\r\n\r\nfunction TThemeHookList.GetControl(Control: TControl): TThemeHook;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := FindControl(Control);\r\n if Result = nil then\r\n begin\r\n for I := 0 to FDeadList.Count - 1 do\r\n begin\r\n Result := TThemeHook(FDeadList[I]);\r\n if Result.Control = Control then\r\n begin\r\n Result.FDead := False;\r\n if (Result.FControl <> nil) and not (csDesigning in Result.FControl.ComponentState) then\r\n if Result.FControl is TGraphicControl then\r\n Result.FControl.FreeNotification(ThemeHookComponent);\r\n FDeadList.Extract(Result);\r\n Add(Result);\r\n Exit;\r\n end;\r\n end;\r\n Result := TThemeHook.Create(Control);\r\n Add(Result);\r\n end;\r\nend;\r\n\r\n//=== { TThemeHook } =========================================================\r\n\r\nconstructor TThemeHook.Create(AControl: TControl);\r\nbegin\r\n inherited Create;\r\n FControl := AControl;\r\n if not (csDesigning in FControl.ComponentState) then\r\n begin\r\n FOrgWndProc := FControl.WindowProc;\r\n FControl.FreeNotification(ThemeHookComponent);\r\n FControl.WindowProc := WndProc;\r\n if not WinControlHookInstalled then\r\n InstallWinControlHook;\r\n end;\r\nend;\r\n\r\ndestructor TThemeHook.Destroy;\r\nbegin\r\n if FControl <> nil then\r\n FControl.RemoveFreeNotification(ThemeHookComponent);\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TThemeHook.DeleteHook;\r\nbegin\r\n if (FControl <> nil) and not (csDesigning in FControl.ComponentState) then\r\n begin\r\n if TMethod(FControl.WindowProc).Code = @TThemeHook.WndProc then\r\n FControl.WindowProc := FOrgWndProc\r\n else\r\n if not (TMethod(FControl.WindowProc).Code = TMethod(FOrgWndProc).Code) then\r\n FDead := True; // keep WndProc\r\n FControl.RemoveFreeNotification(ThemeHookComponent);\r\n FControl := nil;\r\n end;\r\n if FStatus = hsInWndProc then\r\n FStatus := hsDelete;\r\n if FStatus = hsDelete then\r\n Exit;\r\n if not FDead then\r\n ThemeHooks.RecreationList.Remove(FControl);\r\n ThemeHooks.Enter;\r\n try\r\n if FDead then\r\n begin\r\n ThemeHooks.Extract(Self);\r\n ThemeHooks.FDeadList.Add(Self);\r\n end\r\n else\r\n ThemeHooks.Remove(Self)\r\n finally\r\n ThemeHooks.Leave;\r\n end;\r\nend;\r\n\r\nprocedure TThemeHook.IncludeThemeStyle(Style: TJvThemeStyle);\r\nbegin\r\n FThemeStyle := FThemeStyle + Style;\r\nend;\r\n\r\nprocedure TThemeHook.ExcludeThemeStyle(Style: TJvThemeStyle);\r\nbegin\r\n FThemeStyle := FThemeStyle - Style;\r\n if FThemeStyle = [] then\r\n DeleteHook;\r\nend;\r\n\r\nprocedure TThemeHook.WndProc(var Msg: TMessage);\r\nvar\r\n Handled: Boolean;\r\nbegin\r\n // Should not happen but it can if the WindowProc is hooked by another component\r\n if ThemeHooks = nil then\r\n Exit;\r\n if FDead then\r\n begin\r\n FOrgWndProc(Msg);\r\n Exit;\r\n end;\r\n\r\n Handled := False;\r\n case Msg.Msg of\r\n CM_RECREATEWND:\r\n if ThemeHooks.RecreationList.IndexOf(Control) = -1 then\r\n ThemeHooks.RecreationList.Add(Control);\r\n WM_PAINT:\r\n if ThemeServices.ThemesEnabled then\r\n ThemedPaint(TWMPaint(Msg), Handled);\r\n WM_ERASEBKGND:\r\n if ThemeServices.ThemesEnabled then\r\n ThemedEraseBkgnd(TWMEraseBkgnd(Msg), Handled);\r\n CN_CTLCOLORSTATIC, CN_CTLCOLORBTN:\r\n if ThemeServices.ThemesEnabled then\r\n ThemedCtlColorStatic(TWMCtlColorStatic(Msg), Handled);\r\n end;\r\n\r\n Inc(FWndProcCount);\r\n try\r\n FStatus := hsInWndProc;\r\n if not Handled then\r\n FOrgWndProc(Msg);\r\n finally\r\n Dec(FWndProcCount);\r\n if (FStatus = hsDelete) and (FWndProcCount <= 0) then\r\n begin\r\n FStatus := hsNone;\r\n DeleteHook;\r\n if Msg.Msg = WM_DESTROY then\r\n Msg.Msg := 0;\r\n end\r\n end;\r\n\r\n case Msg.Msg of\r\n WM_NCPAINT:\r\n if ThemeServices.ThemesEnabled then\r\n ThemedNCPaint(TWMNCPaint(Msg));\r\n WM_DESTROY:\r\n if (csDestroying in Control.ComponentState) and (ThemeHooks.RecreationList.IndexOf(Control) = -1) then\r\n DeleteHook;\r\n end;\r\n\r\n while ThemeHooks.RecreationList.Count > 0 do\r\n begin\r\n TWinControl(ThemeHooks.RecreationList[0]).HandleNeeded;\r\n ThemeHooks.RecreationList.Delete(0);\r\n end;\r\nend;\r\n\r\nprocedure TThemeHook.ThemedPaint(var Msg: TWMPaint; var Handled: Boolean);\r\nbegin\r\n if Control is TGraphicControl then\r\n if csParentBackground in ThemeStyle then\r\n PerformEraseBackground(Control, Msg.DC);\r\nend;\r\n\r\nprocedure TThemeHook.ThemedNCPaint(var Msg: TWMNCPaint);\r\nbegin\r\n if csNeedsBorderPaint in ThemeStyle then\r\n if Control is TWinControl then\r\n begin\r\n ThemeServices.PaintBorder(TWinControl(Control), False);\r\n Msg.Result := 0;\r\n end;\r\nend;\r\n\r\nprocedure TThemeHook.ThemedEraseBkgnd(var Msg: TWMEraseBkgnd; var Handled: Boolean);\r\nbegin\r\n if ThemeHooks.FEraseBkgndHooked then\r\n Exit;\r\n\r\n if csParentBackground in ThemeStyle then\r\n if Control is TWinControl then\r\n begin\r\n if TWinControl(Control).DoubleBuffered then\r\n PerformEraseBackground(Control, Msg.DC)\r\n else\r\n ThemeServices.DrawParentBackground(TWinControl(Control).Handle, Msg.DC, nil, False);\r\n Msg.Result := 1;\r\n Handled := True;\r\n end;\r\nend;\r\n\r\nprocedure TThemeHook.ThemedCtlColorStatic(var Msg: TWMCtlColorStatic; var Handled: Boolean);\r\nbegin\r\n if csParentBackground in ThemeStyle then\r\n begin\r\n if Control is TWinControl then\r\n begin\r\n ThemedEraseBkgnd(TWMEraseBkgnd(Msg), Handled);\r\n Msg.Result := GetStockObject(NULL_BRUSH);\r\n end;\r\n end;\r\nend;\r\n\r\n//=== { TThemeHookComponent } ================================================\r\n\r\nprocedure TThemeHookComponent.Notification(AComponent: TComponent; Operation: TOperation);\r\nvar\r\n ThemeHook: TThemeHook;\r\nbegin\r\n if Operation = opRemove then\r\n begin\r\n ThemeHooks.Enter;\r\n try\r\n ThemeHook := ThemeHooks.FindControl(TControl(AComponent));\r\n finally\r\n ThemeHooks.Leave;\r\n end;\r\n if ThemeHook <> nil then\r\n ThemeHook.DeleteHook;\r\n end;\r\nend;\r\n\r\n//=== functions ==============================================================\r\n\r\nprocedure IncludeThemeStyle(Control: TControl; Style: TJvThemeStyle);\r\nbegin\r\n if Style <> [] then\r\n begin\r\n ThemeHooks.Enter;\r\n try\r\n ThemeHooks.GetControl(Control).IncludeThemeStyle(Style);\r\n finally\r\n ThemeHooks.Leave;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure ExcludeThemeStyle(Control: TControl; Style: TJvThemeStyle);\r\nbegin\r\n if Style <> [] then\r\n begin\r\n ThemeHooks.Enter;\r\n try\r\n ThemeHooks.GetControl(Control).ExcludeThemeStyle(Style);\r\n finally\r\n ThemeHooks.Leave;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction GetThemeStyle(Control: TControl): TJvThemeStyle;\r\nvar\r\n ThemeHook: TThemeHook;\r\nbegin\r\n ThemeHooks.Enter;\r\n try\r\n ThemeHook := ThemeHooks.FindControl(Control);\r\n if Assigned(ThemeHook) then\r\n Result := ThemeHook.ThemeStyle\r\n else\r\n Result := [];\r\n finally\r\n ThemeHooks.Leave;\r\n end;\r\nend;\r\n\r\nprocedure WMEraseBkgndHook(Self: TWinControl; var Msg: TWMEraseBkgnd);\r\nvar\r\n R: TRect;\r\nbegin\r\n if not Self.DoubleBuffered or (Msg.DC = HDC(Msg.Unused)) then\r\n begin\r\n if ThemeServices.ThemesEnabled and (csParentBackground in GetThemeStyle(Self)) then\r\n begin\r\n R := Self.ClientRect;\r\n ThemeServices.DrawParentBackground(Self.Handle, Msg.DC, nil, False, @R);\r\n end\r\n else\r\n FillRect(Msg.DC, Self.ClientRect, Self.Brush.Handle);\r\n end;\r\n Msg.Result := 1;\r\nend;\r\n\r\ntype\r\n TJumpCode = packed record\r\n Pop: Byte; // pop xxx\r\n Jmp: Byte; // jmp Offset\r\n Offset: Integer;\r\n end;\r\n PJumpCode = ^TJumpCode;\r\n\r\nvar\r\n SavedWinControlCode: TJumpCode;\r\n\r\nprocedure InstallWinControlHook;\r\nvar\r\n Code: TJumpCode;\r\n P: procedure;\r\n N: Cardinal;\r\nbegin\r\n if WinControlHookInstalled then\r\n Exit;\r\n\r\n P := GetDynamicMethod(TWinControl, WM_ERASEBKGND);\r\n if Assigned(P) then\r\n begin\r\n if PByte(@P)^ = $53 then // push ebx\r\n Code.Pop := $5B // pop ebx \r\n else\r\n if PByte(@P)^ = $55 then // push ebp\r\n Code.Pop := $5D // pop ebp\r\n else\r\n Exit;\r\n\r\n Code.Jmp := $E9;\r\n Code.Offset := PAnsiChar(@WMEraseBkgndHook) - (PAnsiChar(@P) + 1) - SizeOf(Code);\r\n\r\n { The strange thing is that the $e9 cannot be overriden with a \"PUSH xxx\" }\r\n if ReadProcessMemory(GetCurrentProcess, Pointer(PAnsiChar(@P) + 1),\r\n @SavedWinControlCode, SizeOf(SavedWinControlCode), N) and\r\n WriteProtectedMemory(Pointer(PAnsiChar(@P) + 1), @Code, SizeOf(Code), N) then\r\n begin\r\n WinControlHookInstalled := True;\r\n ThemeHooks.FEraseBkgndHooked := True;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure UninstallWinControlHook;\r\nvar\r\n P: procedure;\r\n OldProtect, Dummy: Cardinal;\r\nbegin\r\n if not WinControlHookInstalled then\r\n Exit;\r\n\r\n P := GetDynamicMethod(TWinControl, WM_ERASEBKGND);\r\n if Assigned(P) then\r\n begin\r\n if VirtualProtect(Pointer(Cardinal(@P) + 1), SizeOf(SavedWinControlCode), PAGE_EXECUTE_READWRITE,\r\n OldProtect) then\r\n try\r\n PJumpCode(Cardinal(@P) + 1)^ := SavedWinControlCode;\r\n WinControlHookInstalled := False;\r\n FlushInstructionCache(GetCurrentProcess, @P, SizeOf(SavedWinControlCode));\r\n finally\r\n VirtualProtect(Pointer(Cardinal(@P) + 1), SizeOf(SavedWinControlCode), OldProtect, Dummy);\r\n end;\r\n end;\r\nend;\r\n\r\n{$ENDIF COMPILER7_UP}\r\n\r\n{$ELSE} // JVCLThemesEnabled\r\n\r\nprocedure IncludeThemeStyle(Control: TControl; Style: TJvThemeStyle);\r\nbegin\r\nend;\r\n\r\nprocedure ExcludeThemeStyle(Control: TControl; Style: TJvThemeStyle);\r\nbegin\r\nend;\r\n\r\nfunction GetThemeStyle(Control: TControl): TJvThemeStyle;\r\nbegin\r\n Result := [];\r\nend;\r\n\r\n{$ENDIF JVCLThemesEnabled}\r\n\r\n{$IFDEF JVCLThemesEnabled}\r\n\r\n{$IFNDEF COMPILER10_UP}\r\ntype\r\n PPointer = ^Pointer;\r\n\r\nvar\r\n OrgWinControlWMPrintClient: procedure(Instance: TObject; var Msg: TMessage);\r\n\r\nprocedure FixedWMPrintClient(Instance: TObject; var Msg: TMessage);\r\nvar\r\n IdSave: Integer;\r\nbegin\r\n if Msg.Msg = WM_PRINTCLIENT then\r\n begin\r\n IdSave := SaveDC(HDC(Msg.WParam));\r\n try\r\n OrgWinControlWMPrintClient(Instance, Msg);\r\n finally\r\n RestoreDC(HDC(Msg.WParam), IdSave);\r\n end;\r\n end\r\n else\r\n OrgWinControlWMPrintClient(Instance, Msg);\r\nend;\r\n\r\nfunction FindWMPrintClient: PPointer;\r\nvar\r\n IdxList: PDynamicIndexList;\r\n I: Integer;\r\nbegin\r\n IdxList := GetDynamicIndexList(TWinControl);\r\n for I := 0 to GetDynamicMethodCount(TWinControl) - 1 do\r\n if IdxList[I] = WM_PRINTCLIENT then\r\n begin\r\n Result := @(GetDynamicAddressList(TWinControl)[I]);\r\n Exit;\r\n end;\r\n Result := nil;\r\nend;\r\n\r\nprocedure InitializeWMPrintClientFix;\r\nvar\r\n NewProc: Pointer;\r\n Proc: PPointer;\r\n OldProtect, Dummy: Cardinal;\r\nbegin\r\n Proc := FindWMPrintClient();\r\n if Proc <> nil then\r\n begin\r\n OrgWinControlWMPrintClient := Proc^;\r\n NewProc := @FixedWMPrintClient;\r\n\r\n if VirtualProtect(Proc, SizeOf(NewProc), PAGE_EXECUTE_READWRITE, OldProtect) then\r\n try\r\n Proc^ := NewProc;\r\n finally\r\n VirtualProtect(Proc, SizeOf(NewProc), OldProtect, Dummy);\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure FinalizeWMPrintClientFix;\r\nvar\r\n NewProc: Pointer;\r\n Proc: PPointer;\r\n OldProtect, Dummy: Cardinal;\r\nbegin\r\n Proc := FindWMPrintClient;\r\n if Proc <> nil then\r\n begin\r\n NewProc := @OrgWinControlWMPrintClient;\r\n\r\n if VirtualProtect(Proc, SizeOf(NewProc), PAGE_EXECUTE_READWRITE, OldProtect) then\r\n try\r\n Proc^ := NewProc;\r\n finally\r\n VirtualProtect(Proc, SizeOf(NewProc), OldProtect, Dummy);\r\n end;\r\n end;\r\nend;\r\n{$ENDIF ~COMPILER10_UP}\r\n\r\n{$ENDIF JVCLThemesEnabled}\r\n\r\ninitialization\r\n {$IFDEF UNITVERSIONING}\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n {$ENDIF UNITVERSIONING}\r\n\r\n {$IFDEF JVCLThemesEnabled}\r\n {$IFNDEF COMPILER10_UP}\r\n InitializeWMPrintClientFix;\r\n {$ENDIF ~COMPILER10_UP}\r\n {$ENDIF JVCLThemesEnabled}\r\n\r\nfinalization\r\n {$IFDEF JVCLThemesEnabled}\r\n\r\n {$IFNDEF COMPILER10_UP}\r\n FinalizeWMPrintClientFix;\r\n {$ENDIF ~COMPILER10_UP}\r\n\r\n {$IFNDEF COMPILER7_UP}\r\n FreeAndNil(GlobalThemeHooks);\r\n UninstallWinControlHook;\r\n {$ENDIF !COMPILER7_UP}\r\n {$ENDIF JVCLThemesEnabled}\r\n\r\n {$IFDEF UNITVERSIONING}\r\n UnregisterUnitVersion(HInstance);\r\n {$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvThread.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvThread.PAS, released on 2001-02-28.\r\n\r\nThe Initial Developer of the Original Code is Sbastien Buysse [sbuysse att buypin dott com]\r\nPortions created by Sbastien Buysse are Copyright (C) 2001 Sbastien Buysse.\r\nAll Rights Reserved.\r\n\r\nContributor(s): Michael Beck [mbeck att bigfoot dott com].\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvThread.pas 13104 2011-09-07 06:50:43Z obones $\r\n\r\nunit JvThread;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, SysUtils, Classes, SyncObjs, Controls, ExtCtrls, Forms, Dialogs,\r\n JvTypes, JvComponentBase, JvComponent;\r\n\r\ntype\r\n // TThreadPriority has been marked platform and we don't want the warning\r\n {$IFDEF RTL230_UP}{$IFDEF MSWINDOWS}{$WARNINGS OFF}TThreadPriority = Classes.TThreadPriority;{$WARNINGS ON}{$ENDIF RTL230_UP}{$ENDIF MSWINDOWS}\r\n\r\n TJvCustomThreadDialog = class;\r\n TJvCustomThreadDialogForm = class;\r\n TJvThread = class;\r\n\r\n TJvCustomThreadDialogFormEvent = procedure(DialogForm: TJvCustomThreadDialogForm) of object;\r\n TJvThreadCancelEvent = procedure(CurrentThread: TJvThread) of object;\r\n TJvThreadExceptionEvent = procedure (Sender: TObject; E: Exception; EAddr: Pointer) of object;\r\n\r\n TJvCustomThreadDialogOptions = class(TPersistent)\r\n private\r\n FFormStyle: TFormStyle;\r\n FOwner: TJvCustomThreadDialog;\r\n FShowDelay: Integer;\r\n FShowDialog: Boolean;\r\n FShowModal: Boolean;\r\n procedure SetShowDelay(const Value: Integer);\r\n procedure SetShowDialog(Value: Boolean);\r\n procedure SetShowModal(Value: Boolean);\r\n public\r\n constructor Create(AOwner: TJvCustomThreadDialog); virtual;\r\n published\r\n property FormStyle: TFormStyle read FFormStyle write FFormStyle;\r\n // Delay in milliseconds for starting the thread dialog\r\n property ShowDelay: Integer read FShowDelay write SetShowDelay default 0;\r\n // Flag if there should be a dialog which shows the thread status\r\n property ShowDialog: Boolean read FShowDialog write SetShowDialog default False;\r\n // Flag if the status dialog is modal\r\n property ShowModal: Boolean read FShowModal write SetShowModal default True;\r\n end;\r\n\r\n TJvCustomThreadDialogForm = class(TJvForm)\r\n private\r\n FConnectedDataObject: TObject;\r\n FConnectedThread: TJvThread;\r\n FDialogOptions: TJvCustomThreadDialogOptions;\r\n FFormControlsCreated: Boolean;\r\n FFormIsShown: Boolean;\r\n FInternalShowDelay: Integer;\r\n FInternalTimer: TTimer;\r\n FInternalTimerInterval: Integer;\r\n FOnClose: TCloseEvent;\r\n FSaveOnClose: TCloseEvent;\r\n FOnCloseQuery: TCloseQueryEvent;\r\n FOnPressCancel: TJvThreadCancelEvent;\r\n FOnShow: TNotifyEvent;\r\n FSaveOnShow: TNotifyEvent;\r\n FParentHandle: HWND;\r\n procedure CloseThreadForm;\r\n function GetConnectedDataComponent: TComponent;\r\n procedure SetConnectedDataComponent(Value: TComponent);\r\n procedure SetConnectedDataObject(Value: TObject);\r\n procedure SetInternalTimerInterval(Value: Integer);\r\n procedure SetOnClose(Value: TCloseEvent);\r\n procedure OnInternalTimer(Sender: TObject); virtual;\r\n protected\r\n procedure CreateFormControls; virtual;\r\n procedure FreeFormControls; virtual;\r\n procedure CreateParams(var Params: TCreateParams); override;\r\n procedure InitializeFormContents; virtual;\r\n procedure Notification(AComponent: TComponent; Operation: TOperation); override;\r\n procedure ReplaceFormClose(Sender: TObject; var Action: TCloseAction);\r\n procedure ReplaceFormCloseQuery(Sender: TObject; var CanClose: Boolean);\r\n procedure ReplaceFormShow(Sender: TObject);\r\n procedure TransferDialogOptions; virtual;\r\n procedure UpdateFormContents; virtual;\r\n property FormControlsCreated: Boolean read FFormControlsCreated;\r\n property FormIsShown: Boolean read FFormIsShown default False;\r\n property OnPressCancel: TJvThreadCancelEvent read FOnPressCancel write FOnPressCancel;\r\n public\r\n constructor CreateNew(AOwner: TComponent; Dummy: Integer = 0); override;\r\n constructor CreateNewFormStyle(AOwner: TJvThread; FormStyle: TFormStyle;\r\n Parent: TWinControl = nil); virtual;\r\n destructor Destroy; override;\r\n procedure DefaultCancelBtnClick(Sender: TObject);\r\n property ConnectedDataComponent: TComponent read GetConnectedDataComponent write SetConnectedDataComponent;\r\n property ConnectedDataObject: TObject read FConnectedDataObject write SetConnectedDataObject;\r\n property ConnectedThread: TJvThread read FConnectedThread;\r\n property DialogOptions: TJvCustomThreadDialogOptions read FDialogOptions write FDialogOptions;\r\n property InternalTimerInterval: Integer read FInternalTimerInterval write SetInternalTimerInterval;\r\n published\r\n property OnClose: TCloseEvent read FOnClose write SetOnClose;\r\n property OnCloseQuery: TCloseQueryEvent read FOnCloseQuery write FOnCloseQuery;\r\n property OnShow: TNotifyEvent read FOnShow write FOnShow;\r\n end;\r\n\r\n TJvCustomThreadDialog = class(TJvComponent)\r\n private\r\n FDialogOptions: TJvCustomThreadDialogOptions;\r\n FOnPressCancel: TJvThreadCancelEvent;\r\n protected\r\n function CreateDialogOptions: TJvCustomThreadDialogOptions; virtual; abstract;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n function CreateThreadDialogForm(ConnectedThread: TJvThread): TJvCustomThreadDialogForm; virtual; abstract;\r\n published\r\n property DialogOptions: TJvCustomThreadDialogOptions read FDialogOptions write FDialogOptions;\r\n property OnPressCancel: TJvThreadCancelEvent read FOnPressCancel write FOnPressCancel;\r\n end;\r\n\r\n TJvThreadShowMessageDlgEvent = procedure(const Msg: string; AType: TMsgDlgType;\r\n AButtons: TMsgDlgButtons; HelpCtx: Longint; var DlgResult: Word) of object;\r\n\r\n // This thread is a descendent of TThread but proposes a different\r\n // behaviour with regard to being suspended or resumed.\r\n // Indeed, the MSDN recommends not to use them and it was even noticed\r\n // that using Suspend and Resume under Windows NT, 2K and XP led to weird\r\n // errors such as being refused access to the thread, despite being its\r\n // creator.\r\n // So another mechanism has been implemented: the thread must be\r\n // paused instead of suspended.\r\n // Pausing the thread actually acquires a critical section which the Execute\r\n // function must try to get before it calls InternalExecute.\r\n // Hence, if the critical section was acquired before this try, the Execute\r\n // function is stopped and the thread paused until another thread (the main\r\n // thread in most cases) releases the critical section when setting\r\n // Paused to false.\r\n // Obviously, the Execute method in derived classes has to be cooperative\r\n // and actually acquire and release the FPauseSection critical section via\r\n // the appropriate protected methods\r\n TJvPausableThread = class(TJvCustomThread)\r\n private\r\n FPauseSection: TCriticalSection;\r\n FPaused: Boolean;\r\n\r\n procedure SetPaused(const Value: Boolean);\r\n protected\r\n procedure EnterUnpauseableSection;\r\n procedure LeaveUnpauseableSection;\r\n public\r\n constructor Create(CreateSuspended: Boolean);\r\n destructor Destroy; override;\r\n\r\n property Paused: Boolean read FPaused write SetPaused;\r\n end;\r\n\r\n TJvBaseThread = class(TJvPausableThread)\r\n private\r\n FException: Exception;\r\n FExceptionAddr: Pointer;\r\n FInternalTerminate: Boolean;\r\n FExecuteEvent: TJvNotifyParamsEvent;\r\n FOnResumeDone: Boolean;\r\n FExecuteIsActive: Boolean;\r\n FFinished: Boolean;\r\n FOnShowMessageDlgEvent: TJvThreadShowMessageDlgEvent;\r\n FOnException: TJvThreadExceptionEvent;\r\n FParams: Pointer;\r\n FSender: TObject;\r\n FSynchAButtons: TMsgDlgButtons;\r\n FSynchAType: TMsgDlgType;\r\n FSynchHelpCtx: Longint;\r\n FSynchMessageDlgResult: Word;\r\n FSynchMsg: string;\r\n procedure ExceptionHandler;\r\n protected\r\n procedure InternalMessageDlg;\r\n public\r\n constructor Create(Sender: TObject; Event: TJvNotifyParamsEvent; Params: Pointer); virtual;\r\n {$IFNDEF COMPILER14_UP}\r\n procedure Resume; // There is no way to silence the compiler (\"Resume\" is deprecated)\r\n {$ENDIF ~COMPILER14_UP}\r\n procedure ResumeThread;\r\n procedure Execute; override;\r\n procedure Synchronize(Method: TThreadMethod);\r\n function SynchMessageDlg(const Msg: string; AType: TMsgDlgType;\r\n AButtons: TMsgDlgButtons; HelpCtx: Longint): Word;\r\n property Container: TObject read FSender;\r\n property ExecuteIsActive: Boolean read FExecuteIsActive;\r\n property Finished: Boolean read FFinished;\r\n property Terminated;\r\n property Params: Pointer read FParams;\r\n property ReturnValue;\r\n property OnShowMessageDlgEvent: TJvThreadShowMessageDlgEvent read FOnShowMessageDlgEvent write FOnShowMessageDlgEvent;\r\n property OnException: TJvThreadExceptionEvent read FOnException write FOnException;\r\n end;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64 or pidOSX32)]\r\n {$ENDIF RTL230_UP}\r\n TJvThread = class(TJvComponent)\r\n private\r\n FAfterCreateDialogForm: TJvCustomThreadDialogFormEvent;\r\n FBeforeResume: TNotifyEvent;\r\n FConnectedDataObject: TObject;\r\n FDisalbeDialogShowDelayCounter: Integer;\r\n FThreads: TThreadList;\r\n FListLocker: TCriticalSection;\r\n FLockedList: TList;\r\n FExclusive: Boolean;\r\n FMaxCount: Integer;\r\n FRunOnCreate: Boolean;\r\n FOnBegin: TNotifyEvent;\r\n FOnExecute: TJvNotifyParamsEvent;\r\n FOnFinish: TNotifyEvent;\r\n FOnFinishAll: TNotifyEvent;\r\n FFreeOnTerminate: Boolean;\r\n FOnCancelExecute: TJvThreadCancelEvent;\r\n FOnShowMessageDlgEvent: TJvThreadShowMessageDlgEvent;\r\n FOnException: TJvThreadExceptionEvent;\r\n {$IFDEF MSWINDOWS}\r\n FPriority: TThreadPriority;\r\n {$ENDIF MSWINDOWS}\r\n FThreadDialog: TJvCustomThreadDialog;\r\n FThreadDialogAllowed: Boolean;\r\n FThreadDialogForm: TJvCustomThreadDialogForm;\r\n FThreadName: String;\r\n procedure DoBegin;\r\n procedure DoTerminate(Sender: TObject);\r\n function GetCount: Integer;\r\n function GetThreads(Index: Integer): TJvBaseThread;\r\n function GetTerminated: Boolean; // in context of thread in list - for itself; in others - for all threads in list\r\n procedure SetReturnValue(RetVal: Integer); // in context of thread in list - set return value (slower)\r\n function GetReturnValue: Integer; // in context of thread in list - get return value (slower)\r\n procedure CreateThreadDialogForm;\r\n procedure CloseThreadDialogForm;\r\n function GetConnectedDataComponent: TComponent;\r\n function GetCurrentThread: TJvBaseThread;\r\n procedure SetConnectedDataComponent(Value: TComponent);\r\n procedure SetConnectedDataObject(Value: TObject);\r\n procedure SetThreadDialog(const Value: TJvCustomThreadDialog);\r\n procedure SetThreadName(const Value: String);\r\n procedure ShowThreadDialogForm;\r\n protected\r\n procedure InternalAfterCreateDialogForm(DialogForm: TJvCustomThreadDialogForm); virtual;\r\n function GetOneThreadIsRunning: Boolean;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n procedure CancelExecute; virtual;\r\n function Execute(P: Pointer): TJvBaseThread;\r\n procedure ExecuteAndWait(P: Pointer); // wait for all threads in list\r\n procedure ExecuteThreadAndWait(P: Pointer); // wait only this thread\r\n procedure ExecuteWithDialog(P: Pointer);\r\n procedure Notification(AComponent: TComponent; Operation: TOperation); override;\r\n\r\n procedure Synchronize(Method: TThreadMethod); // (slower)\r\n function SynchMessageDlg(const Msg: string; AType: TMsgDlgType; AButtons: TMsgDlgButtons; HelpCtx: Longint): Word;\r\n\r\n procedure Lock; // for safe use of property Threads[]\r\n procedure Unlock;\r\n\r\n property ConnectedDataComponent: TComponent read GetConnectedDataComponent write SetConnectedDataComponent;\r\n property ConnectedDataObject: TObject read FConnectedDataObject write SetConnectedDataObject;\r\n property Count: Integer read GetCount;\r\n property Threads[Index: Integer]: TJvBaseThread read GetThreads;\r\n property LastThread: TJvBaseThread read GetCurrentThread; //GetLastThread;\r\n property Terminated: Boolean read GetTerminated; // in context of thread in list - for itself; in others - for all threads in list\r\n property ReturnValue: Integer read GetReturnValue write SetReturnValue; // in context of thread in list - set return value (slower)\r\n property OneThreadIsRunning: Boolean read GetOneThreadIsRunning;\r\n // Property to allow/disallow the thread dialog form\r\n property ThreadDialogAllowed: Boolean read FThreadDialogAllowed write FThreadDialogAllowed default True;\r\n property ThreadDialogForm: TJvCustomThreadDialogForm read FThreadDialogForm;\r\n function CalcThreadName(ThreadPos: Integer): String;\r\n // Disables the delayed showing of the thread dialog\r\n procedure DisableDialogShowDelay;\r\n // Enables the delayed showing of the thread dialog\r\n procedure EnableDialogShowDelay;\r\n // Is the delayed showing of the thread dialog disabled\r\n function IsDialogShowDelayDisabled: Boolean;\r\n {$IFDEF MSWINDOWS}\r\n procedure SetPriority(NewPriority: TThreadPriority); // in context of thread in list - for itself; in other contexts - for all threads in list\r\n {$ENDIF MSWINDOWS}\r\n procedure Resume(BaseThread: TJvBaseThread); overload;\r\n procedure Resume; overload; // resumes all threads including deferred (RunOnCreate=false)\r\n procedure Suspend; // in context of thread in list - for itself; in other contexts - for all threads in list\r\n procedure Terminate; // terminates all threads\r\n procedure WaitFor; // wait for all threads\r\n procedure RemoveZombie(BaseThread: TJvBaseThread); overload; // remove finished thread (where FreeOnTerminate was false)\r\n procedure RemoveZombie; overload; // remove all finished threads (where FreeOnTerminate was false)\r\n //1 //Combination of Terminate and WaitFor, optional RemoveZombie\r\n procedure TerminateWaitFor(iRemoveZombies: Boolean = true);\r\n published\r\n property Exclusive: Boolean read FExclusive write FExclusive;\r\n property MaxCount: Integer read FMaxCount write FMaxCount;\r\n property RunOnCreate: Boolean read FRunOnCreate write FRunOnCreate;\r\n property FreeOnTerminate: Boolean read FFreeOnTerminate write FFreeOnTerminate;\r\n {$IFDEF MSWINDOWS}\r\n property Priority: TThreadPriority read FPriority write FPriority default tpNormal;\r\n {$ENDIF MSWINDOWS}\r\n property ThreadDialog: TJvCustomThreadDialog read FThreadDialog write SetThreadDialog;\r\n property ThreadName: String read FThreadName write SetThreadName;\r\n property AfterCreateDialogForm: TJvCustomThreadDialogFormEvent read FAfterCreateDialogForm write FAfterCreateDialogForm;\r\n property BeforeResume: TNotifyEvent read FBeforeResume write FBeforeResume;\r\n property OnBegin: TNotifyEvent read FOnBegin write FOnBegin;\r\n property OnCancelExecute: TJvThreadCancelEvent read FOnCancelExecute write FOnCancelExecute;\r\n property OnExecute: TJvNotifyParamsEvent read FOnExecute write FOnExecute;\r\n property OnFinish: TNotifyEvent read FOnFinish write FOnFinish;\r\n property OnFinishAll: TNotifyEvent read FOnFinishAll write FOnFinishAll;\r\n property OnShowMessageDlgEvent: TJvThreadShowMessageDlgEvent read FOnShowMessageDlgEvent write FOnShowMessageDlgEvent;\r\n property OnException: TJvThreadExceptionEvent read FOnException write FOnException;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvThread.pas $';\r\n Revision: '$Revision: 13104 $';\r\n Date: '$Date: 2011-09-07 08:50:43 +0200 (mer. 07 sept. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n JvResources, JvJVCLUtils, System.Types, System.UITypes;\r\n\r\n//=== { TJvCustomThreadDialogOptions } =======================================\r\n\r\nconstructor TJvCustomThreadDialogOptions.Create(AOwner: TJvCustomThreadDialog);\r\nbegin\r\n inherited Create;\r\n FOwner := AOwner;\r\n FShowDialog := False;\r\n FShowModal := True;\r\n FShowDelay := 0;\r\nend;\r\n\r\nprocedure TJvCustomThreadDialogOptions.SetShowDelay(const Value: Integer);\r\nbegin\r\n FShowDelay := Value;\r\n if FShowDelay < 0 then\r\n FShowDelay := 0;\r\nend;\r\n\r\nprocedure TJvCustomThreadDialogOptions.SetShowDialog(Value: Boolean);\r\nbegin\r\n FShowDialog := Value;\r\nend;\r\n\r\nprocedure TJvCustomThreadDialogOptions.SetShowModal(Value: Boolean);\r\nbegin\r\n FShowModal := Value;\r\nend;\r\n\r\n//=== { TJvCustomThreadDialogForm } ==========================================\r\n\r\nconstructor TJvCustomThreadDialogForm.CreateNew(AOwner: TComponent; Dummy: Integer = 0);\r\nbegin\r\n inherited CreateNew(AOwner, Dummy);\r\n FInternalTimerInterval := 500;\r\n if AOwner is TJvThread then\r\n FConnectedThread := TJvThread(AOwner)\r\n else\r\n raise EJVCLException.CreateRes(@RsENotATJvThread);\r\n FSaveOnShow := inherited OnShow;\r\n FSaveOnClose := inherited OnClose;\r\n inherited OnShow := ReplaceFormShow;\r\n inherited OnClose := ReplaceFormClose;\r\n inherited OnCloseQuery := ReplaceFormCloseQuery;\r\n FInternalTimer := TTimer.Create(Self);\r\n FInternalTimer.OnTimer := OnInternalTimer;\r\n FInternalTimer.Interval := FInternalTimerInterval;\r\n FInternalShowDelay := 0;\r\n FFormIsShown := False;\r\n FFormControlsCreated := False;\r\nend;\r\n\r\nconstructor TJvCustomThreadDialogForm.CreateNewFormStyle(AOwner: TJvThread; FormStyle: TFormStyle;\r\n Parent: TWinControl = nil);\r\nbegin\r\n if FormStyle <> fsStayOnTop then\r\n if Assigned(Parent) then\r\n FParentHandle := Parent.Handle\r\n else\r\n FParentHandle := 0;\r\n CreateNew(AOwner);\r\nend;\r\n\r\ndestructor TJvCustomThreadDialogForm.Destroy;\r\nbegin\r\n FreeFormControls;\r\n FreeAndNil(FInternalTimer);\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvCustomThreadDialogForm.CloseThreadForm;\r\nbegin\r\n Hide;\r\n if fsModal in FormState then\r\n ModalResult := mrCancel\r\n else\r\n Close;\r\nend;\r\n\r\nprocedure TJvCustomThreadDialogForm.CreateFormControls;\r\nbegin\r\n FFormControlsCreated := True;\r\nend;\r\n\r\nprocedure TJvCustomThreadDialogForm.FreeFormControls;\r\nbegin\r\n FFormControlsCreated := False;\r\nend;\r\n\r\nprocedure TJvCustomThreadDialogForm.CreateParams(var Params: TCreateParams);\r\nbegin\r\n inherited CreateParams(Params);\r\n if FParentHandle <> 0 then\r\n Params.WndParent := FParentHandle;\r\nend;\r\n\r\nprocedure TJvCustomThreadDialogForm.DefaultCancelBtnClick(Sender: TObject);\r\nbegin\r\n if Assigned(FOnPressCancel) then\r\n FOnPressCancel(FConnectedThread)\r\n else\r\n if Assigned(FConnectedThread) then\r\n FConnectedThread.CancelExecute;\r\n ModalResult := mrNone;\r\nend;\r\n\r\nfunction TJvCustomThreadDialogForm.GetConnectedDataComponent: TComponent;\r\nbegin\r\n if Assigned(FConnectedDataObject) and (FConnectedDataObject is TComponent) then\r\n Result := TComponent(ConnectedDataObject)\r\n else\r\n Result := nil;\r\nend;\r\n\r\nprocedure TJvCustomThreadDialogForm.InitializeFormContents;\r\nbegin\r\nend;\r\n\r\nprocedure TJvCustomThreadDialogForm.Notification(AComponent: TComponent; Operation: TOperation);\r\nbegin\r\n inherited Notification(AComponent, Operation);\r\n if Operation = opRemove then\r\n if AComponent = FConnectedDataObject then\r\n ConnectedDataObject := nil;\r\nend;\r\n\r\nprocedure TJvCustomThreadDialogForm.OnInternalTimer(Sender: TObject);\r\nbegin\r\n if not (csDestroying in ComponentState) then\r\n begin\r\n if not Assigned(ConnectedThread) then\r\n CloseThreadForm\r\n else // connected component present\r\n if ConnectedThread.Terminated or not ConnectedThread.OneThreadIsRunning then\r\n begin\r\n if FormIsShown then\r\n CloseThreadForm;\r\n end\r\n else // not terminated\r\n begin\r\n if FInternalShowDelay > 0 then // Dialog is not shown until yet\r\n FInternalShowDelay := FInternalShowDelay - FInternalTimerInterval\r\n else\r\n if not FormIsShown then\r\n begin\r\n if ConnectedThread.ThreadDialogAllowed and not ConnectedThread.IsDialogShowDelayDisabled then\r\n begin\r\n if DialogOptions.ShowModal then\r\n ShowModal\r\n else\r\n Show;\r\n end;\r\n end\r\n else\r\n if ConnectedThread.ThreadDialogAllowed and FormIsShown then\r\n UpdateFormContents;\r\n end; // not terminated\r\n end; // if not (csDestroying in ComponentState) then\r\nend;\r\n\r\nprocedure TJvCustomThreadDialogForm.ReplaceFormClose(Sender: TObject; var Action: TCloseAction);\r\nbegin\r\n FFormIsShown := False;\r\n if Assigned(FInternalTimer) then\r\n FInternalTimer.Enabled := False;\r\n Action := caFree;\r\n if Assigned(FOnClose) then\r\n FOnClose(Sender, Action);\r\n if Assigned(FSaveOnClose) then\r\n FSaveOnClose(Sender, Action);\r\nend;\r\n\r\nprocedure TJvCustomThreadDialogForm.ReplaceFormCloseQuery(Sender: TObject; var CanClose: Boolean);\r\nbegin\r\n if Assigned(FConnectedThread) then\r\n CanClose := not FConnectedThread.OneThreadIsRunning\r\n else\r\n CanClose := True;\r\n if CanClose then\r\n if Assigned(FOnCloseQuery) then\r\n FOnCloseQuery(Sender, CanClose);\r\nend;\r\n\r\nprocedure TJvCustomThreadDialogForm.ReplaceFormShow(Sender: TObject);\r\nbegin\r\n FFormIsShown := True;\r\n if not FormControlsCreated then\r\n CreateFormControls;\r\n InitializeFormContents;\r\n UpdateFormContents;\r\n FInternalTimer.Enabled := True;\r\n if Assigned(FOnShow) then\r\n FOnShow(Sender);\r\n if Assigned(FSaveOnShow) then\r\n FSaveOnShow(Sender);\r\nend;\r\n\r\nprocedure TJvCustomThreadDialogForm.TransferDialogOptions;\r\nbegin\r\n if Assigned(DialogOptions) then\r\n fInternalShowDelay := DialogOptions.ShowDelay;\r\nend;\r\n\r\nprocedure TJvCustomThreadDialogForm.UpdateFormContents;\r\nbegin\r\nend;\r\n\r\nprocedure TJvCustomThreadDialogForm.SetConnectedDataComponent(Value:\r\n TComponent);\r\nbegin\r\n if Assigned(FConnectedDataObject) and (FConnectedDataObject is TComponent) then\r\n TComponent(FConnectedDataObject).RemoveFreeNotification(self);\r\n ConnectedDataObject := Value;\r\n if Assigned(FConnectedDataObject) and (FConnectedDataObject is TComponent) then\r\n TComponent(FConnectedDataObject).FreeNotification(self);\r\nend;\r\n\r\nprocedure TJvCustomThreadDialogForm.SetConnectedDataObject(Value: TObject);\r\nbegin\r\n FConnectedDataObject := Value;\r\nend;\r\n\r\nprocedure TJvCustomThreadDialogForm.SetInternalTimerInterval(Value: Integer);\r\nbegin\r\n if Value < 1 then\r\n Value := 1;\r\n FInternalTimerInterval := Value;\r\n FInternalTimer.Interval := Value;\r\nend;\r\n\r\nprocedure TJvCustomThreadDialogForm.SetOnClose(Value: TCloseEvent);\r\nbegin\r\n FOnClose := Value;\r\nend;\r\n\r\n//=== { TJvCustomThreadDialog } ==============================================\r\n\r\nconstructor TJvCustomThreadDialog.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FDialogOptions := CreateDialogOptions;\r\nend;\r\n\r\ndestructor TJvCustomThreadDialog.Destroy;\r\nbegin\r\n FDialogOptions.Free;\r\n inherited Destroy;\r\nend;\r\n\r\n//=== { TJvThread } ==========================================================\r\n\r\nconstructor TJvThread.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FRunOnCreate := True;\r\n FExclusive := True;\r\n FFreeOnTerminate := True;\r\n FThreads := TThreadList.Create;\r\n FListLocker := TCriticalSection.Create;\r\n {$IFDEF MSWINDOWS}\r\n FPriority := tpNormal;\r\n {$ENDIF MSWINDOWS}\r\n FThreadDialogAllowed := True;\r\n FDisalbeDialogShowDelayCounter := 0;\r\nend;\r\n\r\ndestructor TJvThread.Destroy;\r\nbegin\r\n Terminate;\r\n while OneThreadIsRunning do\r\n begin\r\n Sleep(1);\r\n // Delphi 6+ uses an IPC event and CheckSynchronize\r\n CheckSynchronize; // TThread.OnTerminate is synchronized\r\n end;\r\n FThreads.Free;\r\n FListLocker.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJvThread.CalcThreadName(ThreadPos: Integer): String;\r\nbegin\r\n if ThreadName = '' then\r\n Result := Name\r\n else\r\n Result := ThreadName;\r\n if Result = '' then\r\n Result := ClassName;\r\n if ThreadPos > 0 then\r\n Result := Result + ' ['+Inttostr(ThreadPos)+']';\r\nend;\r\n\r\nprocedure TJvThread.Notification(AComponent: TComponent; Operation: TOperation);\r\nbegin\r\n inherited Notification(AComponent, Operation);\r\n if Operation = opRemove then\r\n if AComponent = FThreadDialog then\r\n FThreadDialog := nil\r\n else\r\n if AComponent = FThreadDialogForm then\r\n FThreadDialogForm := nil\r\n else\r\n if AComponent = FConnectedDataObject then\r\n ConnectedDataObject := nil;\r\nend;\r\n\r\nfunction TJvThread.Execute(P: Pointer): TJvBaseThread;\r\nvar\r\n BaseThread: TJvBaseThread;\r\nbegin\r\n BaseThread := nil;\r\n if not ((Exclusive and OneThreadIsRunning) or ((FMaxCount > 0) and (Count >= FMaxCount))) and\r\n Assigned(FOnExecute) then\r\n begin\r\n try\r\n BaseThread := TJvBaseThread.Create(Self, FOnExecute, P);\r\n BaseThread.FreeOnTerminate := FFreeOnTerminate;\r\n BaseThread.OnShowMessageDlgEvent := OnShowMessageDlgEvent;\r\n BaseThread.OnException := OnException;\r\n {$IFDEF MSWINDOWS}\r\n BaseThread.Priority := Priority;\r\n {$ENDIF MSWINDOWS}\r\n BaseThread.OnTerminate := DoTerminate;\r\n BaseThread.ThreadName := CalcThreadName(Count);\r\n FThreads.Add(BaseThread);\r\n DoBegin;\r\n except\r\n // We can't terminate right now due to discrepancy between old and recent versions of TThread\r\n if Assigned(BaseThread) then\r\n BaseThread.FInternalTerminate := True;\r\n end;\r\n\r\n if FRunOnCreate and Assigned(BaseThread) then\r\n Resume(BaseThread);\r\n end;\r\n Result := BaseThread;\r\nend;\r\n\r\nprocedure TJvThread.DoBegin;\r\nbegin\r\n if Assigned(FOnBegin) then\r\n FOnBegin(Self);\r\nend;\r\n\r\nprocedure TJvThread.ExecuteAndWait(P: Pointer);\r\nvar\r\n B: Boolean;\r\n Thread: TJvBaseThread;\r\nbegin\r\n B := FRunOnCreate;\r\n FRunOnCreate := True;\r\n try\r\n Thread := Execute(P);\r\n finally\r\n FRunOnCreate := B;\r\n end;\r\n\r\n if Assigned(Thread) then\r\n WaitFor; // all threads in list\r\nend;\r\n\r\nprocedure TJvThread.ExecuteThreadAndWait(P: Pointer);\r\nvar\r\n B: Boolean;\r\n Thread: TJvBaseThread;\r\nbegin\r\n B := FRunOnCreate;\r\n FRunOnCreate := True;\r\n try\r\n Thread := Execute(P);\r\n finally\r\n FRunOnCreate := B;\r\n end;\r\n if Assigned(Thread) then\r\n while (not Thread.Finished) do // wait for this thread\r\n Application.HandleMessage;\r\nend;\r\n\r\nprocedure TJvThread.Resume(BaseThread: TJvBaseThread);\r\nvar\r\n B: Boolean;\r\nbegin\r\n if Assigned(BaseThread) then\r\n begin\r\n CreateThreadDialogForm;\r\n B := BaseThread.FOnResumeDone;\r\n BaseThread.ResumeThread;\r\n if (not B) and\r\n (not BaseThread.FInternalTerminate) and\r\n (not BaseThread.Finished) then\r\n begin\r\n ShowThreadDialogForm;\r\n end;\r\n end\r\n else\r\n Resume; // no target, resume all\r\nend;\r\n\r\nprocedure TJvThread.Resume; // All\r\nvar\r\n List: TList;\r\n I: Integer;\r\n Thread: TJvBaseThread;\r\nbegin\r\n List := FThreads.LockList;\r\n try\r\n for I := 0 to List.Count - 1 do\r\n begin\r\n Thread := TJvBaseThread(List[I]);\r\n while Thread.Suspended do\r\n Resume(Thread);\r\n end;\r\n finally\r\n FThreads.UnlockList;\r\n end;\r\nend;\r\n\r\nprocedure TJvThread.Suspend;\r\nvar\r\n List: TList;\r\n I: Integer;\r\n Thread: TJvBaseThread;\r\nbegin\r\n Thread := GetCurrentThread;\r\n if Assigned(Thread) then\r\n Thread.Suspended := True // suspend itself\r\n else\r\n begin\r\n List := FThreads.LockList; // suspend all\r\n try\r\n for I := 0 to List.Count - 1 do\r\n try // against \"Access denied\" for already finished threads\r\n Thread := TJvBaseThread(List[I]);\r\n if not Thread.Finished then // it's faster (prevents raising exceptions in most cases)\r\n Thread.Suspended := True\r\n except\r\n end;\r\n finally\r\n FThreads.UnlockList;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvThread.Terminate;\r\nvar\r\n List: TList;\r\n I: Integer;\r\nbegin\r\n List := FThreads.LockList;\r\n try\r\n for I := 0 to List.Count - 1 do\r\n TJvBaseThread(List[I]).Terminate;\r\n Resume; // All\r\n finally\r\n FThreads.UnlockList;\r\n end;\r\nend;\r\n\r\nprocedure TJvThread.CancelExecute;\r\nbegin\r\n if Assigned(fOnCancelExecute) then\r\n fOnCancelExecute (Self)\r\n else\r\n Terminate;\r\nend;\r\n\r\nprocedure TJvThread.DoTerminate(Sender: TObject);\r\nbegin\r\n TJvBaseThread(Sender).FExecuteIsActive := False;\r\n if Assigned(FOnFinish) then\r\n try\r\n FOnFinish(Sender);\r\n except\r\n // DoTerminate is part of destructor; destructor should not raise exceptions\r\n end;\r\n\r\n if TJvBaseThread(Sender).FreeOnTerminate then\r\n FThreads.Remove(Sender);\r\n TJvBaseThread(Sender).FFinished := True;\r\n\r\n if Count = 0 then\r\n begin\r\n CloseThreadDialogForm;\r\n if Assigned(FOnFinishAll) then\r\n try\r\n FOnFinishAll(Self);\r\n except\r\n // DoTerminate is part of destructor; destructor should not raise exceptions\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvThread.RemoveZombie(BaseThread: TJvBaseThread); // remove finished thread (where FreeOnTerminate was false)\r\nbegin\r\n if Assigned(BaseThread) then\r\n begin\r\n if BaseThread.FFinished and (not BaseThread.FreeOnTerminate) then\r\n begin\r\n FThreads.Remove(BaseThread);\r\n BaseThread.Free;\r\n end;\r\n end\r\n else\r\n RemoveZombie; // no target, do for all\r\nend;\r\n\r\nprocedure TJvThread.RemoveZombie; // remove all finished threads (where FreeOnTerminate was false)\r\nvar\r\n List: TList;\r\n I: Integer;\r\n Thread: TJvBaseThread;\r\nbegin\r\n List := FThreads.LockList;\r\n try\r\n for I := List.Count - 1 downto 0 do\r\n begin\r\n Thread := TJvBaseThread(List[I]);\r\n if Thread.FFinished and (not Thread.FreeOnTerminate) then\r\n begin\r\n FThreads.Remove(Thread);\r\n Thread.Free;\r\n end;\r\n end;\r\n finally\r\n FThreads.UnlockList;\r\n end;\r\nend;\r\n\r\nfunction TJvThread.GetTerminated: Boolean;\r\nvar\r\n H: DWORD;\r\n List: TList;\r\n I: Integer;\r\n Thread: TJvBaseThread;\r\nbegin\r\n H := GetCurrentThreadID;\r\n Result := True;\r\n List:=FThreads.LockList;\r\n try\r\n for I := 0 to List.Count - 1 do\r\n begin\r\n Thread := TJvBaseThread(List[I]);\r\n if Thread.ThreadID = H then\r\n begin\r\n Result := Thread.Terminated; // context of thread in list\r\n Break;\r\n end\r\n else\r\n Result := Result and Thread.Terminated; // context of all other threads\r\n end;\r\n finally\r\n FThreads.UnlockList;\r\n end;\r\nend;\r\n\r\nprocedure TJvThread.WaitFor;\r\nbegin\r\n while OneThreadIsRunning do\r\n Application.HandleMessage;\r\nend;\r\n\r\nprocedure TJvThread.SetReturnValue(RetVal: Integer);\r\nvar\r\n Thread: TJvBaseThread;\r\nbegin\r\n Thread := GetCurrentThread;\r\n if Assigned(Thread) then\r\n Thread.ReturnValue := RetVal;\r\nend;\r\n\r\nfunction TJvThread.GetReturnValue: Integer;\r\nvar\r\n Thread: TJvBaseThread;\r\nbegin\r\n Thread := GetCurrentThread;\r\n if Assigned(Thread) then\r\n Result := Thread.ReturnValue\r\n else\r\n Result := 0;\r\nend;\r\n\r\nfunction TJvThread.GetCount: Integer;\r\nvar\r\n List: TList;\r\nbegin\r\n List := FThreads.LockList;\r\n try\r\n Result := List.Count;\r\n finally\r\n FThreads.UnlockList;\r\n end;\r\nend;\r\n\r\nfunction TJvThread.GetCurrentThread: TJvBaseThread;\r\nvar\r\n H: DWORD;\r\n List: TList;\r\n I: Integer;\r\n Thread: TJvBaseThread;\r\nbegin\r\n Result := nil;\r\n H := GetCurrentThreadID;\r\n List := FThreads.LockList;\r\n try\r\n for I := 0 to List.Count - 1 do\r\n begin\r\n Thread := TJvBaseThread(List[I]);\r\n if Thread.ThreadID = H then\r\n begin\r\n Result := Thread;\r\n Break;\r\n end;\r\n end;\r\n finally\r\n FThreads.UnlockList;\r\n end;\r\nend;\r\n\r\nfunction TJvThread.GetOneThreadIsRunning: Boolean;\r\nvar\r\n I: Integer;\r\n List: TList;\r\nbegin\r\n Result := False;\r\n List := FThreads.LockList;\r\n try\r\n for I := 0 to List.Count - 1 do\r\n begin\r\n Result := not TJvBaseThread(List[I]).Finished;\r\n if Result then\r\n Break;\r\n end;\r\n finally\r\n FThreads.UnlockList;\r\n end;\r\nend;\r\n\r\nprocedure TJvThread.Lock; // for safe use of property Threads[]\r\nbegin\r\n FListLocker.Acquire;\r\n try\r\n if not Assigned(FLockedList) then\r\n FLockedList := FThreads.LockList;\r\n except\r\n FListLocker.Release;\r\n raise;\r\n end;\r\nend;\r\n\r\nfunction TJvThread.GetThreads(Index: Integer): TJvBaseThread;\r\nbegin\r\n FListLocker.Acquire;\r\n try\r\n if Assigned(FLockedList) then\r\n Result := TJvBaseThread(FLockedList[Index])\r\n else\r\n Result := nil;\r\n finally\r\n FListLocker.Release;\r\n end;\r\nend;\r\n\r\nprocedure TJvThread.Unlock;\r\nbegin\r\n try\r\n if Assigned(FLockedList) then\r\n begin\r\n FThreads.UnlockList;\r\n FLockedList := nil;\r\n end;\r\n finally\r\n FListLocker.Release;\r\n end;\r\nend;\r\n\r\nprocedure TJvThread.Synchronize(Method: TThreadMethod);\r\nvar\r\n Thread: TJvBaseThread;\r\nbegin\r\n DisableDialogShowDelay;\r\n try\r\n Thread := GetCurrentThread;\r\n if Assigned(Thread) then\r\n Thread.Synchronize(Method)\r\n else\r\n Method;\r\n finally\r\n EnableDialogShowDelay;\r\n end;\r\nend;\r\n\r\nfunction TJvThread.SynchMessageDlg(const Msg: string; AType: TMsgDlgType; AButtons: TMsgDlgButtons; HelpCtx: Longint):\r\n Word;\r\nvar\r\n Thread: TJvBaseThread;\r\nbegin\r\n DisableDialogShowDelay;\r\n try\r\n Thread := GetCurrentThread;\r\n if Assigned(Thread) then\r\n Result := Thread.SynchMessageDlg(Msg, AType, AButtons, HelpCtx)\r\n else\r\n if Assigned(OnShowMessageDlgEvent) then\r\n OnShowMessageDlgEvent(Msg, AType,\r\n AButtons, HelpCtx, Result)\r\n else\r\n Result := MessageDlg(Msg, AType, AButtons, HelpCtx);\r\n finally\r\n EnableDialogShowDelay;\r\n end;\r\nend;\r\n\r\n{$IFDEF MSWINDOWS}\r\nprocedure TJvThread.SetPriority(NewPriority: TThreadPriority);\r\nvar\r\n List: TList;\r\n Thread: TJvBaseThread;\r\n I: Integer;\r\nbegin\r\n List := FThreads.LockList;\r\n try\r\n Thread := GetCurrentThread;\r\n if Assigned(Thread) then\r\n Thread.Priority := NewPriority // context of thread in list\r\n else\r\n begin\r\n for I := 0 to List.Count - 1 do // context of all other threads\r\n TJvBaseThread(List[I]).Priority := NewPriority;\r\n Priority := NewPriority;\r\n end;\r\n finally\r\n FThreads.UnlockList;\r\n end;\r\nend;\r\n{$ENDIF MSWINDOWS}\r\n\r\nprocedure TJvThread.CreateThreadDialogForm;\r\nbegin\r\n if Assigned(ThreadDialog) and not Assigned(FThreadDialogForm) then\r\n begin\r\n FThreadDialogForm := ThreadDialog.CreateThreadDialogForm(Self);\r\n if Assigned(FThreadDialogForm) then\r\n begin\r\n FreeNotification(FThreadDialogForm);\r\n FThreadDialogForm.CreateFormControls;\r\n FThreadDialogForm.ConnectedDataObject := ConnectedDataObject;\r\n FThreadDialogForm.TransferDialogOptions;\r\n InternalAfterCreateDialogForm(FThreadDialogForm);\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvThread.DisableDialogShowDelay;\r\nbegin\r\n Inc(FDisalbeDialogShowDelayCounter);\r\nend;\r\n\r\nprocedure TJvThread.EnableDialogShowDelay;\r\nbegin\r\n Dec(FDisalbeDialogShowDelayCounter);\r\nend;\r\n\r\nprocedure TJvThread.ExecuteWithDialog(P: Pointer);\r\nbegin\r\n if Assigned(ThreadDialog) and ThreadDialog.DialogOptions.ShowDialog and\r\n ThreadDialog.DialogOptions.ShowModal then\r\n ExecuteAndWait(P)\r\n else\r\n Execute(P);\r\nend;\r\n\r\nprocedure TJvThread.CloseThreadDialogForm;\r\nbegin\r\n if Assigned(ThreadDialogForm) then\r\n begin\r\n while Assigned(ThreadDialogForm) AND ThreadDialogForm.Visible do\r\n begin\r\n ThreadDialogForm.CloseThreadForm;\r\n Application.HandleMessage;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJvThread.GetConnectedDataComponent: TComponent;\r\nbegin\r\n if Assigned(FConnectedDataObject) and (FConnectedDataObject is TComponent) then\r\n Result := TComponent(ConnectedDataObject)\r\n else\r\n Result := nil;\r\nend;\r\n\r\nprocedure TJvThread.InternalAfterCreateDialogForm(DialogForm: TJvCustomThreadDialogForm);\r\nbegin\r\n if Assigned(FAfterCreateDialogForm) then\r\n FAfterCreateDialogForm(DialogForm);\r\nend;\r\n\r\nfunction TJvThread.IsDialogShowDelayDisabled: Boolean;\r\nbegin\r\n Result := FDisalbeDialogShowDelayCounter > 0;\r\nend;\r\n\r\nprocedure TJvThread.SetConnectedDataComponent(Value: TComponent);\r\nbegin\r\n if Assigned(FConnectedDataObject) and (FConnectedDataObject is TComponent) then\r\n TComponent(FConnectedDataObject).RemoveFreeNotification(self);\r\n ConnectedDataObject := Value;\r\n if Assigned(FConnectedDataObject) and (FConnectedDataObject is TComponent) then\r\n TComponent(FConnectedDataObject).FreeNotification(self);\r\nend;\r\n\r\nprocedure TJvThread.SetConnectedDataObject(Value: TObject);\r\nbegin\r\n FConnectedDataObject := Value;\r\n if Assigned(FThreadDialogForm) then\r\n FThreadDialogForm.ConnectedDataObject := Value;\r\nend;\r\n\r\nprocedure TJvThread.SetThreadDialog(const Value: TJvCustomThreadDialog);\r\nbegin\r\n ReplaceComponentReference(Self, Value, TComponent(FThreadDialog));\r\nend;\r\n\r\nprocedure TJvThread.SetThreadName(const Value: String);\r\nvar\r\n i: Integer;\r\nbegin\r\n FThreadName := Value;\r\n Lock;\r\n try\r\n for i := 0 to Count -1 do\r\n if Assigned(Threads[i]) then\r\n Threads[i].ThreadName := CalcThreadName(i);\r\n finally\r\n UnLock;\r\n end;\r\nend;\r\n\r\nprocedure TJvThread.ShowThreadDialogForm;\r\nbegin\r\n if Assigned (ThreadDialog) and Assigned(FThreadDialogForm) then\r\n if ThreadDialog.DialogOptions.ShowDelay <= 0 then\r\n begin\r\n if ThreadDialog.DialogOptions.ShowModal then\r\n FThreadDialogForm.ShowModal\r\n else\r\n FThreadDialogForm.Show;\r\n end;\r\nend;\r\n\r\nprocedure TJvThread.TerminateWaitFor(iRemoveZombies: Boolean = true);\r\nbegin\r\n Terminate;\r\n WaitFor;\r\n if iRemoveZombies then\r\n RemoveZombie;\r\nend;\r\n\r\n//=== { TJvBaseThread } ======================================================\r\n\r\nconstructor TJvBaseThread.Create(Sender: TObject; Event: TJvNotifyParamsEvent; Params: Pointer);\r\nbegin\r\n inherited Create(True);\r\n FSender := Sender;\r\n FExecuteEvent := Event;\r\n FParams := Params;\r\nend;\r\n\r\nprocedure TJvBaseThread.ExceptionHandler;\r\nbegin\r\n ShowException(FException, FExceptionAddr);\r\nend;\r\n\r\nprocedure TJvBaseThread.ResumeThread;\r\nbegin\r\n if not FOnResumeDone then\r\n begin\r\n // the first resume (perhaps deferred)\r\n FOnResumeDone := True;\r\n if (FSender is TJvThread) and Assigned(TJvThread(FSender).BeforeResume) then\r\n try\r\n TJvThread(FSender).BeforeResume(Self);\r\n except\r\n // Self.Terminate;\r\n // We can't terminate right now due to discrepancy between old and recent versions TThread\r\n FInternalTerminate := True;\r\n end;\r\n FExecuteIsActive := True;\r\n end;\r\n {$WARNINGS OFF}\r\n inherited Resume; // after suspend too\r\n {$WARNINGS ON}\r\nend;\r\n\r\n{$IFNDEF COMPILER14_UP}\r\nprocedure TJvBaseThread.Resume;\r\nbegin\r\n ResumeThread;\r\nend;\r\n{$ENDIF ~COMPILER14_UP}\r\n\r\nprocedure TJvBaseThread.Execute;\r\nbegin\r\n try\r\n FExecuteIsActive := True;\r\n NameThread(ThreadName);\r\n if FInternalTerminate then\r\n Terminate;\r\n FExecuteEvent(Self, FParams);\r\n except\r\n on E: Exception do\r\n if Assigned(OnException) then\r\n OnException(self, E, ExceptAddr)\r\n else\r\n begin\r\n FException := E;\r\n FExceptionAddr := ExceptAddr;\r\n Synchronize(ExceptionHandler);\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvBaseThread.Synchronize(Method: TThreadMethod);\r\nbegin\r\n inherited Synchronize(Method);\r\nend;\r\n\r\nprocedure TJvBaseThread.InternalMessageDlg;\r\nbegin\r\n if Assigned(OnShowMessageDlgEvent) then\r\n OnShowMessageDlgEvent(FSynchMsg, FSynchAType,\r\n FSynchAButtons, FSynchHelpCtx, FSynchMessageDlgResult)\r\n else\r\n FSynchMessageDlgResult := MessageDlg(FSynchMsg, FSynchAType, FSynchAButtons, FSynchHelpCtx);\r\nend;\r\n\r\nfunction TJvBaseThread.SynchMessageDlg(const Msg: string; AType: TMsgDlgType;\r\n AButtons: TMsgDlgButtons; HelpCtx: Longint): Word;\r\nbegin\r\n FSynchMsg := Msg;\r\n FSynchAType := AType;\r\n FSynchAButtons := AButtons;\r\n FSynchHelpCtx := HelpCtx;\r\n Self.Synchronize(InternalMessageDlg);\r\n Result := FSynchMessageDlgResult;\r\nend;\r\n\r\n{ TJvPausableThread }\r\n\r\nconstructor TJvPausableThread.Create(CreateSuspended: Boolean);\r\nbegin\r\n FPauseSection := TCriticalSection.Create;\r\n inherited Create(CreateSuspended);\r\nend;\r\n\r\ndestructor TJvPausableThread.Destroy;\r\nbegin\r\n if Paused then\r\n begin\r\n Terminate;\r\n Paused := False;\r\n end;\r\n\r\n inherited Destroy;\r\n FPauseSection.Free;\r\nend;\r\n\r\nprocedure TJvPausableThread.EnterUnpauseableSection;\r\nbegin\r\n FPauseSection.Acquire;\r\nend;\r\n\r\nprocedure TJvPausableThread.LeaveUnpauseableSection;\r\nbegin\r\n FPauseSection.Release;\r\nend;\r\n\r\nprocedure TJvPausableThread.SetPaused(const Value: Boolean);\r\nbegin\r\n if FPaused <> Value then\r\n begin\r\n // store the Value\r\n FPaused := Value;\r\n\r\n if FPaused then\r\n FPauseSection.Acquire\r\n else\r\n FPauseSection.Release;\r\n end;\r\n\r\n // If the thread was created \"Suspended\", then we must start it\r\n if Suspended and not Paused then\r\n Suspended := False;\r\nend;\r\n\r\ninitialization\r\n {$IFDEF UNITVERSIONING}\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n {$ENDIF UNITVERSIONING}\r\n\r\nfinalization\r\n {$IFDEF UNITVERSIONING}\r\n UnregisterUnitVersion(HInstance);\r\n {$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvThreadDialog.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvThreadDialog.PAS, released on 2004-12-06.\r\n\r\nThe Initial Developer of the Original Code is Jens Fudickar [jens dott fudickar att oratool dott de]\r\nAll Rights Reserved.\r\n\r\nContributor(s): Jens Fudickar [jens dott fudickar att oratool dott de].\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvThreadDialog.pas 13172 2011-11-19 10:33:20Z jfudickar $\r\n\r\nunit JvThreadDialog;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n SysUtils, Classes, Forms, StdCtrls,\r\n {$IFDEF MSWINDOWS}\r\n Windows, Controls, ComCtrls,\r\n {$ENDIF MSWINDOWS}\r\n {$IFDEF UNIX}\r\n QWindows,\r\n {$ENDIF UNIX}\r\n JvThread, JvDynControlEngine, JvDynControlEngineIntf;\r\n\r\ntype\r\n TJvThreadBaseDialogOptions = class;\r\n TJvChangeThreadDialogOptionsEvent = procedure(DialogOptions: TJvThreadBaseDialogOptions) of object;\r\n\r\n TJvThreadBaseDialogOptions = class(TJvCustomThreadDialogOptions)\r\n private\r\n FCancelButtonCaption: string;\r\n FCaption: string;\r\n FEnableCancelButton: Boolean;\r\n FInfoText: string;\r\n FInfoTextAlignment: TAlignment;\r\n FShowCancelButton: Boolean;\r\n FShowElapsedTime: Boolean;\r\n protected\r\n procedure SetCancelButtonCaption(Value: string);\r\n procedure SetCaption(Value: string);\r\n procedure SetEnableCancelButton(Value: Boolean);\r\n procedure SetInfoText(Value: string);\r\n procedure SetShowCancelButton(Value: Boolean);\r\n procedure SetShowElapsedTime(Value: Boolean);\r\n public\r\n constructor Create(AOwner: TJvCustomThreadDialog); override;\r\n published\r\n property CancelButtonCaption: string read FCancelButtonCaption write SetCancelButtonCaption;\r\n property Caption: string read FCaption write SetCaption;\r\n property EnableCancelButton: Boolean read FEnableCancelButton write SetEnableCancelButton default True;\r\n property InfoText: string read FInfoText write SetInfoText;\r\n property InfoTextAlignment: TAlignment read FInfoTextAlignment write FInfoTextAlignment default taLeftJustify;\r\n property ShowCancelButton: Boolean read FShowCancelButton write SetShowCancelButton default True;\r\n property ShowElapsedTime: Boolean read FShowElapsedTime write SetShowElapsedTime default True;\r\n end;\r\n\r\n TJvThreadBaseDialog = class(TJvCustomThreadDialog)\r\n private\r\n FChangeThreadDialogOptions: TJvChangeThreadDialogOptionsEvent;\r\n published\r\n property OnPressCancel;\r\n property ChangeThreadDialogOptions: TJvChangeThreadDialogOptionsEvent read FChangeThreadDialogOptions write\r\n FChangeThreadDialogOptions;\r\n end;\r\n\r\n TJvThreadAnimateDialogOptions = class(TJvThreadBaseDialogOptions)\r\n private\r\n FCommonAVI: TCommonAVI;\r\n FFileName: string;\r\n FResName: string;\r\n published\r\n property CommonAVI: TCommonAVI read FCommonAVI write FCommonAVI;\r\n property FileName: string read FFileName write FFileName;\r\n property ResName: string read FResName write FResName;\r\n end;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64 or pidOSX32)]\r\n {$ENDIF RTL230_UP}\r\n TJvThreadAnimateDialog = class(TJvThreadBaseDialog)\r\n private\r\n function GetDialogOptions: TJvThreadAnimateDialogOptions;\r\n procedure SetDialogOptions(Value: TJvThreadAnimateDialogOptions);\r\n protected\r\n function CreateDialogOptions: TJvCustomThreadDialogOptions; override;\r\n public\r\n function CreateThreadDialogForm(ConnectedThread: TJvThread): TJvCustomThreadDialogForm; override;\r\n published\r\n property DialogOptions: TJvThreadAnimateDialogOptions read GetDialogOptions write SetDialogOptions;\r\n end;\r\n\r\n TJvThreadSimpleDialogOptions = class(TJvThreadBaseDialogOptions)\r\n private\r\n FProgressBarMarquee: Boolean;\r\n FProgressBarMax: Integer;\r\n FProgressBarMin: Integer;\r\n FProgressBarPosition: Integer;\r\n FProgressBarSmooth: Boolean;\r\n FShowProgressBar: Boolean;\r\n public\r\n constructor Create(AOwner: TJvCustomThreadDialog); override;\r\n published\r\n property ProgressBarMarquee: Boolean read FProgressBarMarquee write FProgressBarMarquee default False;\r\n property ProgressBarMax: Integer read FProgressBarMax write FProgressBarMax default 100;\r\n property ProgressBarMin: Integer read FProgressBarMin write FProgressBarMin default 0;\r\n property ProgressBarPosition: Integer read FProgressBarPosition write FProgressBarPosition default -1;\r\n property ProgressBarSmooth: Boolean read FProgressBarSmooth write FProgressBarSmooth default False;\r\n property ShowProgressBar: Boolean read FShowProgressBar write FShowProgressBar default False;\r\n end;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64 or pidOSX32)]\r\n {$ENDIF RTL230_UP}\r\n TJvThreadSimpleDialog = class(TJvThreadBaseDialog)\r\n private\r\n function GetDialogOptions: TJvThreadSimpleDialogOptions;\r\n procedure SetDialogOptions(Value: TJvThreadSimpleDialogOptions);\r\n protected\r\n function CreateDialogOptions: TJvCustomThreadDialogOptions; override;\r\n public\r\n function CreateThreadDialogForm(ConnectedThread: TJvThread): TJvCustomThreadDialogForm; override;\r\n published\r\n property DialogOptions: TJvThreadSimpleDialogOptions read GetDialogOptions write SetDialogOptions;\r\n end;\r\n\r\n TJvDynControlEngineThreadDialogForm = class(TJvCustomThreadDialogForm)\r\n private\r\n FDefaultBorderWidth: Integer;\r\n FDynControlEngine: TJvDynControlEngine;\r\n function GetDynControlEngine: TJvDynControlEngine;\r\n procedure SetDynControlEngine(const Value: TJvDynControlEngine);\r\n protected\r\n procedure CreateTextPanel(AOwner: TComponent; AParent: TWinControl; var Panel: TWinControl; var Text: TControl;\r\n TextAlignment: TAlignment; const BaseName: string);\r\n property DefaultBorderWidth: Integer read FDefaultBorderWidth write FDefaultBorderWidth;\r\n property DynControlEngine: TJvDynControlEngine read GetDynControlEngine write SetDynControlEngine;\r\n end;\r\n\r\n TJvThreadBaseDialogForm = class(TJvDynControlEngineThreadDialogForm)\r\n private\r\n FCancelBtn: TButton;\r\n FCancelButtonPanel: TWinControl;\r\n FChangeThreadDialogOptions: TJvChangeThreadDialogOptionsEvent;\r\n FInfoText: TControl;\r\n FInfoTextPanel: TWinControl;\r\n FMainPanel: TWinControl;\r\n FOrgInfoTextWidth: Integer;\r\n FStartTime: TDateTime;\r\n FTimeText: TControl;\r\n FTimeTextPanel: TWinControl;\r\n IInfoTextControlAutoSize: IJvDynControlAutoSize;\r\n IInfoTextControlCaption: IJvDynControlCaption;\r\n ITimeTextControlCaption: IJvDynControlCaption;\r\n function CalculateFormHeight: Integer; virtual;\r\n function CalculateFormWidth: Integer; virtual;\r\n procedure CreateControlCancelButton;\r\n procedure CreateControlInfoText;\r\n procedure CreateControlMainPanel;\r\n procedure CreateControlTimeText;\r\n procedure SetControlHeightWidth; virtual;\r\n procedure SetFormDefaultProperties;\r\n procedure SetFormInfoText; virtual;\r\n function GetDialogOptions: TJvThreadBaseDialogOptions;\r\n procedure SetDialogOptions(const Value: TJvThreadBaseDialogOptions);\r\n procedure SetFormHeightWidth;\r\n protected\r\n procedure FreeFormControls; override;\r\n procedure InitializeFormContents; override;\r\n procedure UpdateFormContents; override;\r\n public\r\n property DialogOptions: TJvThreadBaseDialogOptions read GetDialogOptions write SetDialogOptions;\r\n property ChangeThreadDialogOptions: TJvChangeThreadDialogOptionsEvent read\r\n FChangeThreadDialogOptions write FChangeThreadDialogOptions;\r\n end;\r\n\r\n TJvThreadSimpleDialogForm = class(TJvThreadBaseDialogForm)\r\n private\r\n FCounter: Integer;\r\n FProgressbar: TWinControl;\r\n FProgressbarPanel: TWinControl;\r\n IProgressBarControl : IJvDynControlProgressbar;\r\n function CalculateFormHeight: Integer; override;\r\n procedure CreateControlProgressBar;\r\n function GetDialogOptions: TJvThreadSimpleDialogOptions;\r\n procedure SetControlHeightWidth; override;\r\n procedure SetDialogOptions(Value: TJvThreadSimpleDialogOptions);\r\n protected\r\n procedure CreateFormControls; override;\r\n procedure FreeFormControls; override;\r\n procedure InitializeFormContents; override;\r\n procedure UpdateFormContents; override;\r\n public\r\n property DialogOptions: TJvThreadSimpleDialogOptions read GetDialogOptions write SetDialogOptions;\r\n end;\r\n\r\n TJvThreadAnimateDialogForm = class(TJvThreadBaseDialogForm)\r\n private\r\n FAnimate: TAnimate;\r\n FAnimatePanel: TWinControl;\r\n function CalculateFormHeight: Integer; override;\r\n function CalculateFormWidth: Integer; override;\r\n procedure CreateControlAnimate;\r\n function GetDialogOptions: TJvThreadAnimateDialogOptions;\r\n procedure SetControlHeightWidth; override;\r\n procedure SetDialogOptions(Value: TJvThreadAnimateDialogOptions);\r\n protected\r\n procedure CreateFormControls; override;\r\n procedure InitializeFormContents; override;\r\n procedure UpdateFormContents; override;\r\n public\r\n property DialogOptions: TJvThreadAnimateDialogOptions read GetDialogOptions write SetDialogOptions;\r\n end;\r\n\r\n\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvThreadDialog.pas $';\r\n Revision: '$Revision: 13172 $';\r\n Date: '$Date: 2011-11-19 11:33:20 +0100 (sam. 19 nov. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n Dialogs, Graphics,\r\n {$IFDEF COMPILER11_UP} // Delphi 2007 introduced ShellAnimations\r\n ShellAnimations,\r\n {$ENDIF COMPILER11_UP}\r\n JvResources;\r\n\r\nfunction Max(a, b: Integer): Integer;\r\nbegin\r\n if a > b then\r\n Result := a\r\n else\r\n Result := b;\r\nend;\r\n\r\n//=== { TJvThreadBaseDialogOptions } =========================================\r\n\r\nconstructor TJvThreadBaseDialogOptions.Create(AOwner: TJvCustomThreadDialog);\r\nbegin\r\n inherited Create(AOwner);\r\n FEnableCancelButton := True;\r\n FShowCancelButton := True;\r\n FShowElapsedTime := True;\r\n FCancelButtonCaption := RsButtonCancelCaption;\r\n FInfoTextAlignment := taLeftJustify;\r\nend;\r\n\r\nprocedure TJvThreadBaseDialogOptions.SetCancelButtonCaption(Value: string);\r\nbegin\r\n FCancelButtonCaption := Value;\r\nend;\r\n\r\nprocedure TJvThreadBaseDialogOptions.SetCaption(Value: string);\r\nbegin\r\n FCaption := Value;\r\nend;\r\n\r\nprocedure TJvThreadBaseDialogOptions.SetEnableCancelButton(Value: Boolean);\r\nbegin\r\n FEnableCancelButton := Value;\r\nend;\r\n\r\nprocedure TJvThreadBaseDialogOptions.SetInfoText(Value: string);\r\nbegin\r\n FInfoText := Value;\r\nend;\r\n\r\nprocedure TJvThreadBaseDialogOptions.SetShowCancelButton(Value: Boolean);\r\nbegin\r\n FShowCancelButton := Value;\r\nend;\r\n\r\nprocedure TJvThreadBaseDialogOptions.SetShowElapsedTime(Value: Boolean);\r\nbegin\r\n FShowElapsedTime := Value;\r\nend;\r\n\r\n//=== { TJvThreadSimpleDialog } ==============================================\r\n\r\nfunction TJvThreadSimpleDialog.CreateDialogOptions: TJvCustomThreadDialogOptions;\r\nbegin\r\n Result := TJvThreadSimpleDialogOptions.Create(Self);\r\nend;\r\n\r\nfunction TJvThreadSimpleDialog.CreateThreadDialogForm(ConnectedThread: TJvThread): TJvCustomThreadDialogForm;\r\nvar\r\n ThreadDialogForm: TJvThreadSimpleDialogForm;\r\nbegin\r\n if DialogOptions.ShowDialog then\r\n begin\r\n ThreadDialogForm := TJvThreadSimpleDialogForm.CreateNewFormStyle(ConnectedThread, DialogOptions.FormStyle);\r\n ThreadDialogForm.DialogOptions := DialogOptions;\r\n ThreadDialogForm.OnPressCancel := OnPressCancel;\r\n ThreadDialogForm.ChangeThreadDialogOptions := ChangeThreadDialogOptions;\r\n// ThreadDialogForm.CreateFormControls;\r\n Result := ThreadDialogForm;\r\n end\r\n else\r\n Result := nil;\r\nend;\r\n\r\nfunction TJvThreadSimpleDialog.GetDialogOptions: TJvThreadSimpleDialogOptions;\r\nbegin\r\n Result := TJvThreadSimpleDialogOptions(inherited DialogOptions);\r\nend;\r\n\r\nprocedure TJvThreadSimpleDialog.SetDialogOptions(Value: TJvThreadSimpleDialogOptions);\r\nbegin\r\n inherited DialogOptions.Assign(Value);\r\nend;\r\n\r\n//=== { TJvThreadAnimateDialog } =============================================\r\n\r\nfunction TJvThreadAnimateDialog.CreateDialogOptions: TJvCustomThreadDialogOptions;\r\nbegin\r\n Result := TJvThreadAnimateDialogOptions.Create(Self);\r\nend;\r\n\r\nfunction TJvThreadAnimateDialog.CreateThreadDialogForm(ConnectedThread: TJvThread):\r\nTJvCustomThreadDialogForm;\r\nvar\r\n ThreadDialogForm: TJvThreadAnimateDialogForm;\r\nbegin\r\n if DialogOptions.ShowDialog then\r\n begin\r\n ThreadDialogForm := TJvThreadAnimateDialogForm.CreateNewFormStyle(ConnectedThread,\r\n DialogOptions.FormStyle);\r\n ThreadDialogForm.DialogOptions := DialogOptions;\r\n ThreadDialogForm.ChangeThreadDialogOptions := ChangeThreadDialogOptions;\r\n ThreadDialogForm.OnPressCancel := OnPressCancel;\r\n// ThreadDialogForm.CreateFormControls;\r\n Result := ThreadDialogForm;\r\n end\r\n else\r\n Result := nil;\r\nend;\r\n\r\nfunction TJvThreadAnimateDialog.GetDialogOptions: TJvThreadAnimateDialogOptions;\r\nbegin\r\n Result := TJvThreadAnimateDialogOptions(inherited DialogOptions);\r\nend;\r\n\r\nprocedure TJvThreadAnimateDialog.SetDialogOptions(Value: TJvThreadAnimateDialogOptions);\r\nbegin\r\n inherited DialogOptions.Assign(Value);\r\nend;\r\n\r\n//=== { TJvThreadSimpleDialogOptions } =======================================\r\n\r\nconstructor TJvThreadSimpleDialogOptions.Create(AOwner: TJvCustomThreadDialog);\r\nbegin\r\n inherited Create(AOwner);\r\n FShowProgressBar := False;\r\n FProgressBarPosition := -1;\r\n FProgressBarSmooth := False;\r\n FProgressBarMax := 100;\r\n FProgressBarMin := 0;\r\n FProgressBarMarquee := False;\r\nend;\r\n\r\nfunction TJvThreadSimpleDialogForm.CalculateFormHeight: Integer;\r\nbegin\r\n Result := inherited CalculateFormHeight;\r\n if Assigned(FProgressbarPanel) and FProgressbarPanel.Visible then\r\n Result := Result + FProgressbarPanel.Height;\r\nend;\r\n\r\nprocedure TJvThreadSimpleDialogForm.CreateControlProgressBar;\r\nvar\r\n ITmpPanel: IJvDynControlPanel;\r\n ITmpAlign: IJvDynControlAlign;\r\nbegin\r\n FProgressbarPanel := DynControlEngine.CreatePanelControl(Self, FMainPanel, 'ProgressbarPanel', '', alTop);\r\n if not Supports(FProgressbarPanel, IJvDynControlPanel, ITmpPanel) then\r\n raise EIntfCastError.CreateRes(@RsEIntfCastError);\r\n ITmpPanel.ControlSetBorder(bvNone, bvNone, 0, bsNone, FDefaultBorderWidth);\r\n FProgressbar := DynControlEngine.CreateProgressbarControl(Self, FProgressbarPanel, 'Progressbar');\r\n Supports(FProgressbar, IJvDynControlProgressbar, IProgressBarControl);\r\n FProgressbarPanel.Height := FProgressbar.Height + FDefaultBorderWidth*2;\r\n if Supports(FProgressbar, IJvDynControlAlign, ITmpAlign) then\r\n ITmpAlign.ControlSetAlign(alClient);\r\nend;\r\n\r\nprocedure TJvThreadSimpleDialogForm.CreateFormControls;\r\nbegin\r\n Inherited CreateFormControls;\r\n FDefaultBorderWidth := 3;\r\n CreateControlMainPanel;\r\n\r\n CreateControlInfoText;\r\n CreateControlTimeText;\r\n CreateControlProgressBar;\r\n\r\n CreateControlCancelButton;\r\n\r\n SetFormDefaultProperties;\r\n SetFormHeightWidth;\r\nend;\r\n\r\nprocedure TJvThreadSimpleDialogForm.FreeFormControls;\r\nbegin\r\n IProgressBarControl := nil;\r\n inherited;\r\nend;\r\n\r\nprocedure TJvThreadSimpleDialogForm.InitializeFormContents;\r\nbegin\r\n inherited InitializeFormContents;\r\n FCounter := 0;\r\nend;\r\n\r\nprocedure TJvThreadSimpleDialogForm.UpdateFormContents;\r\nbegin\r\n if (csDestroying in ComponentState) or not FormIsShown then\r\n Exit;\r\n inherited UpdateFormContents;\r\n if Assigned(DialogOptions) then\r\n begin\r\n if Assigned(FProgressbarPanel) then\r\n FProgressbarPanel.Visible := DialogOptions.ShowProgressBar;\r\n if Assigned(IProgressBarControl) then\r\n begin\r\n IProgressBarControl.ControlSetMin(DialogOptions.ProgressBarMin);\r\n IProgressBarControl.ControlSetMax(DialogOptions.ProgressBarMax);\r\n IProgressBarControl.ControlSetMarquee(DialogOptions.ProgressBarMarquee);\r\n if not DialogOptions.ProgressBarMarquee then\r\n if (DialogOptions.ProgressBarPosition >= DialogOptions.ProgressBarMin) and (DialogOptions.ProgressBarPosition <= DialogOptions.ProgressBarMax) then\r\n IProgressBarControl.ControlSetPosition(DialogOptions.ProgressBarPosition)\r\n else\r\n IProgressBarControl.ControlSetPosition(((FCounter*10) mod (DialogOptions.ProgressBarMax-DialogOptions.ProgressBarMin)+10));\r\n IProgressBarControl.ControlSetSmooth(DialogOptions.ProgressBarSmooth);\r\n end;\r\n case FCounter mod 4 of\r\n 0: Caption := DialogOptions.Caption + ' | ';\r\n 1: Caption := DialogOptions.Caption + ' / ';\r\n 2: Caption := DialogOptions.Caption + ' --';\r\n else\r\n Caption := DialogOptions.Caption + ' \\ ';\r\n end;\r\n Inc (FCounter);\r\n end;\r\n SetFormHeightWidth;\r\nend;\r\n\r\nfunction TJvThreadSimpleDialogForm.GetDialogOptions: TJvThreadSimpleDialogOptions;\r\nbegin\r\n Result := TJvThreadSimpleDialogOptions(inherited DialogOptions);\r\nend;\r\n\r\nprocedure TJvThreadSimpleDialogForm.SetControlHeightWidth;\r\nbegin\r\n inherited SetControlHeightWidth;\r\n if Assigned(FProgressbarPanel) then\r\n FProgressbarPanel.Width := FTimeTextPanel.Width;\r\nend;\r\n\r\nprocedure TJvThreadSimpleDialogForm.SetDialogOptions(Value:\r\n TJvThreadSimpleDialogOptions);\r\nbegin\r\n inherited DialogOptions := Value;\r\nend;\r\n\r\nfunction TJvThreadAnimateDialogForm.CalculateFormHeight: Integer;\r\nbegin\r\n Result := inherited CalculateFormHeight;\r\n if Assigned(FAnimatePanel) and FAnimatePanel.Visible then\r\n Result := Result + FAnimatePanel.Height;\r\nend;\r\n\r\nfunction TJvThreadAnimateDialogForm.CalculateFormWidth: Integer;\r\nvar\r\n W: Integer;\r\nbegin\r\n W := Inherited CalculateFormWidth;\r\n\r\n if Assigned(FAnimatePanel) and FAnimatePanel.Visible then\r\n W := Max(W, FAnimate.Width + 20);\r\n\r\n Result := w;\r\nend;\r\n\r\nprocedure TJvThreadAnimateDialogForm.CreateControlAnimate;\r\nvar\r\n ITmpPanel: IJvDynControlPanel;\r\nbegin\r\n FAnimatePanel := DynControlEngine.CreatePanelControl(Self, FMainPanel, 'AnimatePanel', '', alTop);\r\n if not Supports(FAnimatePanel, IJvDynControlPanel, ITmpPanel) then\r\n raise EIntfCastError.CreateRes(@RsEIntfCastError);\r\n ITmpPanel.ControlSetBorder(bvNone, bvRaised, 0, bsNone, FDefaultBorderWidth);\r\n\r\n FAnimate := TAnimate.Create(Self);\r\n FAnimate.Parent := FAnimatePanel;\r\n FAnimate.Top := FDefaultBorderWidth;\r\n FAnimate.Left := FDefaultBorderWidth;\r\n FAnimate.AutoSize := True;\r\n FAnimate.CommonAVI := TJvThreadAnimateDialogOptions(DialogOptions).CommonAVI;\r\n FAnimate.FileName := TJvThreadAnimateDialogOptions(DialogOptions).FileName;\r\n FAnimate.ResName := TJvThreadAnimateDialogOptions(DialogOptions).ResName;\r\n FAnimatePanel.Height := FAnimate.Height + FDefaultBorderWidth*2;\r\nend;\r\n\r\nprocedure TJvThreadAnimateDialogForm.CreateFormControls;\r\nbegin\r\n Inherited CreateFormControls;\r\n FDefaultBorderWidth := 3;\r\n CreateControlMainPanel;\r\n\r\n CreateControlInfoText;\r\n CreateControlAnimate;\r\n CreateControlTimeText;\r\n\r\n CreateControlCancelButton;\r\n\r\n SetFormDefaultProperties;\r\n SetFormHeightWidth;\r\nend;\r\n\r\nprocedure TJvThreadAnimateDialogForm.InitializeFormContents;\r\nbegin\r\n inherited InitializeFormContents;\r\n FAnimate.Active := True;\r\nend;\r\n\r\nprocedure TJvThreadAnimateDialogForm.UpdateFormContents;\r\nbegin\r\n if (csDestroying in ComponentState) or not FormIsShown then\r\n Exit;\r\n inherited UpdateFormContents;\r\n if Assigned(DialogOptions) then\r\n begin\r\n Caption := DialogOptions.Caption;\r\n FAnimatePanel.Visible := FileExists(FAnimate.FileName) or\r\n (FAnimate.CommonAVI <> aviNone) or (FAnimate.ResName <> '');\r\n end;\r\n SetFormHeightWidth;\r\nend;\r\n\r\nfunction TJvThreadAnimateDialogForm.GetDialogOptions: TJvThreadAnimateDialogOptions;\r\nbegin\r\n Result := TJvThreadAnimateDialogOptions(inherited DialogOptions);\r\nend;\r\n\r\nprocedure TJvThreadAnimateDialogForm.SetControlHeightWidth;\r\nvar h : Integer;\r\nbegin\r\n Inherited SetControlHeightWidth;\r\n FAnimate.Left := (FAnimatePanel.Width - FAnimate.Width) div 2;\r\n FAnimatePanel.Height := FAnimate.Height + FDefaultBorderWidth*2;\r\n h := 0;\r\n if Assigned(FInfoTextPanel) and FInfoTextPanel.Visible then\r\n begin\r\n FInfoTextPanel.Top := h;\r\n H := H + FInfoTextPanel.Height;\r\n end;\r\n if Assigned(FAnimatePanel) and FAnimatePanel.Visible then\r\n begin\r\n FAnimatePanel.Top := h;\r\n H := H + FAnimatePanel.Height;\r\n end;\r\n if Assigned(FTimeTextPanel) and FTimeTextPanel.Visible then\r\n begin\r\n FTimeTextPanel.Top := h;\r\n H := H + FTimeTextPanel.Height;\r\n end;\r\n if Assigned(FCancelButtonPanel) and FCancelButtonPanel.Visible then\r\n begin\r\n FCancelButtonPanel.Top := h;\r\n\r\n // No need to assign, this is not used later on\r\n //H := H + FCancelButtonPanel.Height;\r\n end;\r\nend;\r\n\r\nprocedure TJvThreadAnimateDialogForm.SetDialogOptions(Value:\r\n TJvThreadAnimateDialogOptions);\r\nbegin\r\n inherited DialogOptions := Value;\r\nend;\r\n\r\nprocedure TJvDynControlEngineThreadDialogForm.CreateTextPanel(AOwner: TComponent; AParent: TWinControl; var Panel:\r\n TWinControl; var Text: TControl; TextAlignment: TAlignment; const BaseName: string);\r\nvar\r\n ITmpPanel: IJvDynControlPanel;\r\n ITmpAlignment: IJvDynControlAlignment;\r\nbegin\r\n Panel := DynControlEngine.CreatePanelControl(AOwner, AParent,\r\n BaseName + 'Panel', '', alTop);\r\n if not Supports(Panel, IJvDynControlPanel, ITmpPanel) then\r\n raise EIntfCastError.CreateRes(@RsEIntfCastError);\r\n ITmpPanel.ControlSetBorder(bvNone, bvNone, 0, bsNone, FDefaultBorderWidth);\r\n Text := DynControlEngine.CreateLabelControl(AOwner,\r\n Panel, BaseName + 'StaticText', '', nil);\r\n Text.Top := FDefaultBorderWidth;\r\n Text.Left := FDefaultBorderWidth;\r\n if Supports(Text, IJvDynControlAlignment, ITmpAlignment) then\r\n ITmpAlignment.ControlSetAlignment(TextAlignment);\r\nend;\r\n\r\nfunction TJvDynControlEngineThreadDialogForm.GetDynControlEngine: TJvDynControlEngine;\r\nbegin\r\n Result := DefaultDynControlEngine;\r\nend;\r\n\r\nprocedure TJvDynControlEngineThreadDialogForm.SetDynControlEngine(const Value: TJvDynControlEngine);\r\nbegin\r\n if not Assigned(Value) then\r\n FDynControlEngine := DefaultDynControlEngine\r\n else\r\n FDynControlEngine := Value;\r\nend;\r\n\r\nfunction TJvThreadBaseDialogForm.CalculateFormHeight: Integer;\r\nvar\r\n H: Integer;\r\nbegin\r\n H := 0;\r\n if Assigned(FInfoTextPanel) and FInfoTextPanel.Visible then\r\n H := FInfoTextPanel.Height;\r\n if Assigned(FTimeTextPanel) and FTimeTextPanel.Visible then\r\n H := H + FTimeTextPanel.Height;\r\n if Assigned(FCancelButtonPanel) and FCancelButtonPanel.Visible then\r\n H := H + FCancelButtonPanel.Height;\r\n Result := h;\r\nend;\r\n\r\nfunction TJvThreadBaseDialogForm.CalculateFormWidth: Integer;\r\nvar\r\n W: Integer;\r\nbegin\r\n if Assigned(FInfoTextPanel) and FInfoTextPanel.Visible then\r\n W := FOrgInfoTextWidth + 20\r\n else\r\n W := 0;\r\n W := Round(W/10)*10;\r\n if W < 250 then\r\n W := 250;\r\n if W > Screen.Width-100 then\r\n W := Screen.Width-100;\r\n Result := w;\r\nend;\r\n\r\nprocedure TJvThreadBaseDialogForm.CreateControlCancelButton;\r\nbegin\r\n FCancelButtonPanel := DynControlEngine.CreatePanelControl(Self,\r\n FMainPanel, 'ButtonPanel', '', alTop);\r\n FCancelBtn := DynControlEngine.CreateButton(Self, FCancelButtonPanel,\r\n 'CancelBtn', DialogOptions.CancelButtonCaption, '', DefaultCancelBtnClick,\r\n True, True);\r\n FCancelBtn.Anchors := [akTop];\r\n FCancelBtn.Top := FDefaultBorderWidth;\r\n FCancelButtonPanel.Height := FCancelBtn.Height + FDefaultBorderWidth*2;\r\nend;\r\n\r\nprocedure TJvThreadBaseDialogForm.CreateControlInfoText;\r\nbegin\r\n CreateTextPanel(Self, FMainPanel, FInfoTextPanel, FInfoText,\r\n DialogOptions.InfoTextAlignment, 'Info');\r\n Supports(FInfoText, IJvDynControlCaption, IInfoTextControlCaption);\r\n Supports(FInfoText, IJvDynControlAutoSize, IInfoTextControlAutoSize);\r\nend;\r\n\r\nprocedure TJvThreadBaseDialogForm.CreateControlMainPanel;\r\nvar\r\n ITmpPanel: IJvDynControlPanel;\r\nbegin\r\n FMainPanel := DynControlEngine.CreatePanelControl(Self, Self,\r\n 'MainPanel', '', alClient);\r\n if not Supports(FMainPanel, IJvDynControlPanel, ITmpPanel) then\r\n raise EIntfCastError.CreateRes(@RsEIntfCastError);\r\n ITmpPanel.ControlSetBorder(bvNone, bvNone, 0, bsNone, FDefaultBorderWidth);\r\nend;\r\n\r\nprocedure TJvThreadBaseDialogForm.CreateControlTimeText;\r\nbegin\r\n CreateTextPanel(Self, FMainPanel, FTimeTextPanel, FTimeText, taCenter, 'Time');\r\n Supports(FTimeText, IJvDynControlCaption, ITimeTextControlCaption);\r\nend;\r\n\r\nprocedure TJvThreadBaseDialogForm.FreeFormControls;\r\nbegin\r\n IInfoTextControlAutoSize:= nil;\r\n IInfoTextControlCaption:= nil;\r\n ITimeTextControlCaption:= nil;\r\n inherited;\r\nend;\r\n\r\nprocedure TJvThreadBaseDialogForm.InitializeFormContents;\r\nbegin\r\n inherited InitializeFormContents;\r\n SetFormHeightWidth;\r\n FStartTime := Now;\r\nend;\r\n\r\nprocedure TJvThreadBaseDialogForm.SetControlHeightWidth;\r\nbegin\r\n if Assigned(FCancelButtonPanel) and Assigned(FCancelBtn) then\r\n FCancelBtn.Left := (FCancelButtonPanel.Width - FCancelBtn.Width) div 2;\r\n if Assigned(FInfoText) and Assigned(FInfoTextPanel) then\r\n begin\r\n FInfoText.Width := FInfoTextPanel.Width-FDefaultBorderWidth*2;\r\n FInfoTextPanel.Height := FInfoText.Height+FDefaultBorderWidth*2;\r\n end;\r\n if Assigned(FTimeText) and Assigned(FTimeTextPanel) then\r\n begin\r\n FTimeText.Width := FTimeTextPanel.Width-FDefaultBorderWidth*2;\r\n FTimeTextPanel.Height := FTimeText.Height+FDefaultBorderWidth*2;\r\n end;\r\nend;\r\n\r\nprocedure TJvThreadBaseDialogForm.SetFormDefaultProperties;\r\nbegin\r\n BorderIcons := [];\r\n BorderStyle := bsDialog;\r\n Caption := ' ';\r\n FormStyle := DialogOptions.FormStyle;\r\n {$IFDEF COMPILER7_UP}\r\n Position := poOwnerFormCenter;\r\n {$ELSE}\r\n Position := poScreenCenter;\r\n {$ENDIF COMPILER7_UP};\r\nend;\r\n\r\nprocedure TJvThreadBaseDialogForm.SetFormHeightWidth;\r\nvar\r\n H, W: Integer;\r\nbegin\r\n if (csDestroying in ComponentState) or not FormIsShown then\r\n Exit;\r\n w := CalculateFormWidth;\r\n W := Round(W/10)*10;\r\n if W < (ClientWidth -50) then // Reduces the resize flickering when the text is changed to often\r\n ClientWidth := W\r\n else if W > ClientWidth then\r\n ClientWidth := W+20; // Reduces the resize flickering when the text is changed to often\r\n SetControlHeightWidth;\r\n h := CalculateFormHeight + FDefaultBorderWidth*2;\r\n h := Round(h/10)*10;\r\n if H > Screen.Height-100 then\r\n H := Screen.Height-100;\r\n if ClientHeight <> H then\r\n ClientHeight := H;\r\nend;\r\n\r\nprocedure TJvThreadBaseDialogForm.SetFormInfoText;\r\nbegin\r\n if (csDestroying in ComponentState) or not FormIsShown then\r\n Exit;\r\n if Assigned(IInfoTextControlCaption) and Assigned(DialogOptions) then\r\n if IInfoTextControlCaption.ControlGetCaption<>DialogOptions.InfoText then\r\n begin\r\n IInfoTextControlCaption.ControlSetCaption(DialogOptions.FInfoText);\r\n if Assigned(IInfoTextControlAutoSize) then\r\n begin\r\n IInfoTextControlAutoSize.ControlSetAutoSize(True);\r\n IInfoTextControlAutoSize.ControlSetAutoSize(False);\r\n end;\r\n FInfoText.Left := FDefaultBorderWidth; // Some Components change the left position when activating autosize (TcxStaticText)\r\n FOrgInfoTextWidth := FInfoText.Width;\r\n end;\r\n FInfoTextPanel.Visible := DialogOptions.FInfoText <> '';\r\nend;\r\n\r\nprocedure TJvThreadBaseDialogForm.UpdateFormContents;\r\nbegin\r\n if (csDestroying in ComponentState) or not FormIsShown then\r\n Exit;\r\n inherited UpdateFormContents;\r\n if Assigned(DialogOptions) then\r\n begin\r\n FTimeTextPanel.Visible := DialogOptions.ShowElapsedTime;\r\n FCancelBtn.Enabled := DialogOptions.EnableCancelButton;\r\n FCancelButtonPanel.Visible := DialogOptions.ShowCancelButton;\r\n if Assigned(ChangeThreadDialogOptions) then\r\n ChangeThreadDialogOptions(DialogOptions);\r\n\r\n SetFormInfoText;\r\n\r\n if Assigned(ITimeTextControlCaption) then\r\n ITimeTextControlCaption.ControlSetCaption (FormatDateTime('hh:nn:ss', Now - FStartTime));\r\n\r\n end;\r\n SetFormHeightWidth;\r\nend;\r\n\r\nfunction TJvThreadBaseDialogForm.GetDialogOptions: TJvThreadBaseDialogOptions;\r\nbegin\r\n Result := TJvThreadSimpleDialogOptions(inherited DialogOptions);\r\nend;\r\n\r\nprocedure TJvThreadBaseDialogForm.SetDialogOptions(const Value: TJvThreadBaseDialogOptions);\r\nbegin\r\n inherited DialogOptions := Value;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvThreadTimer.pas", "content": "{-----------------------------------------------------------------------------\r\n\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvThreadTimer.PAS, released on 2001-02-28.\r\n\r\nThe Initial Developer of the Original Code is S?stien Buysse [sbuysse att buypin dott com]\r\nPortions created by S?stien Buysse are Copyright (C) 2001 S?stien Buysse.\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\nMichael Beck [mbeck att bigfoot dott com].\r\nPeter Thrnqvist\r\nIvo Bauer\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n\r\nHistory:\r\n 2003-07-24 (p3)\r\n * Changed Active->Enabled and Delay->Interval to make property names match TTimer\r\n * Changed implementation so that setting Enabled := false, frees the thread instead\r\n of suspending it. This makes it possible to restart the timer interval.\r\n 2003-07-25 (ivobauer)\r\n * Rewritten almost everything.\r\n\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvThreadTimer.pas 13104 2011-09-07 06:50:43Z obones $\r\n\r\nunit JvThreadTimer;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, SysUtils, Classes,\r\n JvTypes, JvComponentBase;\r\n\r\ntype\r\n // TThreadPriority has been marked platform and we don't want the warning\r\n {$IFDEF RTL230_UP}{$IFDEF MSWINDOWS}{$WARNINGS OFF}TThreadPriority = Classes.TThreadPriority;{$WARNINGS ON}{$ENDIF RTL230_UP}{$ENDIF MSWINDOWS}\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64 or pidOSX32)]\r\n {$ENDIF RTL230_UP}\r\n TJvThreadTimer = class(TJvComponent)\r\n private\r\n FEnabled: Boolean;\r\n FInterval: Cardinal;\r\n FKeepAlive: Boolean;\r\n FOnTimer: TNotifyEvent;\r\n {$IFDEF MSWINDOWS}\r\n FPriority: TThreadPriority;\r\n {$ENDIF MSWINDOWS}\r\n FStreamedEnabled: Boolean;\r\n FThread: TThread;\r\n procedure SetEnabled(const Value: Boolean);\r\n procedure SetInterval(const Value: Cardinal);\r\n procedure SetOnTimer(const Value: TNotifyEvent);\r\n {$IFDEF MSWINDOWS}\r\n procedure SetPriority(const Value: TThreadPriority);\r\n {$ENDIF MSWINDOWS}\r\n procedure SetKeepAlive(const Value: Boolean);\r\n protected\r\n procedure DoOnTimer;\r\n procedure Loaded; override;\r\n procedure StopTimer;\r\n procedure UpdateTimer;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n property Thread: TThread read FThread;\r\n published\r\n // (p3) renamed Active->Enabled, Delay->Interval to make it compatible with TTimer\r\n property Enabled: Boolean read FEnabled write SetEnabled default False;\r\n property Interval: Cardinal read FInterval write SetInterval default 1000;\r\n property KeepAlive: Boolean read FKeepAlive write SetKeepAlive default False;\r\n property OnTimer: TNotifyEvent read FOnTimer write SetOnTimer;\r\n {$IFDEF MSWINDOWS}\r\n property Priority: TThreadPriority read FPriority write SetPriority default tpNormal;\r\n {$ENDIF MSWINDOWS}\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvThreadTimer.pas $';\r\n Revision: '$Revision: 13104 $';\r\n Date: '$Date: 2011-09-07 08:50:43 +0200 (mer. 07 sept. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n Messages,\r\n JvJCLUtils;\r\n\r\ntype\r\n TJvTimerThread = class(TJvCustomThread)\r\n private\r\n FEvent: THandle;\r\n FHasBeenSuspended: Boolean;\r\n FInterval: Cardinal;\r\n FTimer: TJvThreadTimer;\r\n {$IFDEF MSWINDOWS}\r\n FPriority: TThreadPriority;\r\n {$ENDIF MSWINDOWS}\r\n FSynchronizing: Boolean;\r\n protected\r\n procedure DoSuspend;\r\n procedure Execute; override;\r\n public\r\n constructor Create(ATimer: TJvThreadTimer);\r\n destructor Destroy; override;\r\n procedure Stop;\r\n property Interval: Cardinal read FInterval;\r\n property Timer: TJvThreadTimer read FTimer;\r\n property Synchronizing: Boolean read FSynchronizing;\r\n end;\r\n\r\nfunction SubtractMin0(const Big, Small: Cardinal): Cardinal;\r\nbegin\r\n if Big <= Small then\r\n Result := 0\r\n else\r\n Result := Big - Small;\r\nend;\r\n\r\n//=== { TJvTimerThread } =====================================================\r\n\r\nconstructor TJvTimerThread.Create(ATimer: TJvThreadTimer);\r\nbegin\r\n inherited Create(False);\r\n\r\n { Manually reset = false; Initial State = false }\r\n FEvent := CreateEvent(nil, False, False, nil);\r\n if FEvent = 0 then\r\n RaiseLastOSError;\r\n FInterval := ATimer.FInterval;\r\n FTimer := ATimer;\r\n {$IFDEF MSWINDOWS}\r\n FPriority := ATimer.Priority; // setting the priority is deferred to Execute()\r\n {$ENDIF MSWINDOWS}\r\n ThreadName := Format('%s: %s',[ClassName, ATimer.Name]);\r\nend;\r\n\r\ndestructor TJvTimerThread.Destroy;\r\nbegin\r\n Stop;\r\n inherited Destroy;\r\n if FEvent <> 0 then\r\n CloseHandle(FEvent);\r\nend;\r\n\r\nprocedure TJvTimerThread.DoSuspend;\r\nbegin\r\n FHasBeenSuspended := True;\r\n Suspended := True;\r\nend;\r\n\r\nprocedure TJvTimerThread.Execute;\r\nvar\r\n Offset, TickCount: Cardinal;\r\nbegin\r\n NameThread(ThreadName);\r\n {$IFDEF MSWINDOWS}\r\n Priority := FPriority;\r\n {$ENDIF MSWINDOWS}\r\n if WaitForSingleObject(FEvent, Interval) <> WAIT_TIMEOUT then\r\n Exit;\r\n\r\n while not Terminated do\r\n begin\r\n FHasBeenSuspended := False;\r\n\r\n TickCount := GetTickCount;\r\n if not Terminated then\r\n begin\r\n FSynchronizing := True;\r\n try\r\n Synchronize(FTimer.DoOnTimer);\r\n finally\r\n FSynchronizing := False;\r\n end;\r\n end;\r\n\r\n // Determine how much time it took to execute OnTimer event handler. Take a care\r\n // of wrapping the value returned by GetTickCount API around zero if Windows is\r\n // run continuously for more than 49.7 days.\r\n if FHasBeenSuspended then\r\n Offset := 0\r\n else\r\n begin\r\n Offset := GetTickCount;\r\n if Offset >= TickCount then\r\n Dec(Offset, TickCount)\r\n else\r\n Inc(Offset, High(Cardinal) - TickCount);\r\n end;\r\n\r\n // Make sure Offset is less than or equal to FInterval.\r\n // (rb) Ensure it's atomic, because of KeepAlive\r\n if Terminated or (WaitForSingleObject(FEvent, SubtractMin0(Interval, Offset)) <> WAIT_TIMEOUT) then\r\n Exit;\r\n end;\r\nend;\r\n\r\nprocedure TJvTimerThread.Stop;\r\nbegin\r\n Terminate;\r\n SetEvent(FEvent);\r\n if Suspended then\r\n Suspended := False;\r\nend;\r\n\r\n//=== { TJvThreadTimer } =====================================================\r\n\r\nconstructor TJvThreadTimer.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FInterval := 1000;\r\n {$IFDEF MSWINDOWS}\r\n FPriority := tpNormal;\r\n {$ENDIF MSWINDOWS}\r\nend;\r\n\r\ndestructor TJvThreadTimer.Destroy;\r\nbegin\r\n StopTimer;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvThreadTimer.DoOnTimer;\r\nbegin\r\n if csDestroying in ComponentState then\r\n Exit;\r\n\r\n try\r\n if Assigned(FOnTimer) then\r\n FOnTimer(Self);\r\n except\r\n if Assigned(ApplicationHandleException) then\r\n ApplicationHandleException(Self);\r\n end;\r\nend;\r\n\r\nprocedure TJvThreadTimer.Loaded;\r\nbegin\r\n inherited Loaded;\r\n SetEnabled(FStreamedEnabled);\r\nend;\r\n\r\nprocedure TJvThreadTimer.SetEnabled(const Value: Boolean);\r\nbegin\r\n if csLoading in ComponentState then\r\n FStreamedEnabled := Value\r\n else\r\n if FEnabled <> Value then\r\n begin\r\n FEnabled := Value;\r\n UpdateTimer;\r\n end;\r\nend;\r\n\r\nprocedure TJvThreadTimer.SetInterval(const Value: Cardinal);\r\nbegin\r\n if FInterval <> Value then\r\n begin\r\n FInterval := Value;\r\n UpdateTimer;\r\n end;\r\nend;\r\n\r\nprocedure TJvThreadTimer.SetKeepAlive(const Value: Boolean);\r\nbegin\r\n if FKeepAlive <> Value then\r\n begin\r\n StopTimer;\r\n FKeepAlive := Value;\r\n UpdateTimer;\r\n end;\r\nend;\r\n\r\nprocedure TJvThreadTimer.SetOnTimer(const Value: TNotifyEvent);\r\nbegin\r\n if @FOnTimer <> @Value then\r\n begin\r\n FOnTimer := Value;\r\n UpdateTimer;\r\n end;\r\nend;\r\n\r\n{$IFDEF MSWINDOWS}\r\nprocedure TJvThreadTimer.SetPriority(const Value: TThreadPriority);\r\nbegin\r\n if FPriority <> Value then\r\n begin\r\n FPriority := Value;\r\n if FThread <> nil then\r\n FThread.Priority := FPriority;\r\n end;\r\nend;\r\n{$ENDIF MSWINDOWS}\r\n\r\nprocedure TJvThreadTimer.StopTimer;\r\nbegin\r\n if FThread <> nil then\r\n begin\r\n TJvTimerThread(FThread).Stop;\r\n if not TJvTimerThread(FThread).Synchronizing then\r\n FreeAndNil(FThread)\r\n else\r\n begin\r\n // We can't destroy the thread because it called us through Synchronize()\r\n // and is waiting for our return. But we need to destroy it after it returned.\r\n TJvTimerThread(FThread).FreeOnTerminate := True;\r\n FThread := nil\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvThreadTimer.UpdateTimer;\r\nvar\r\n DoEnable: Boolean;\r\nbegin\r\n if ComponentState * [csDesigning, csLoading] <> [] then\r\n Exit;\r\n\r\n DoEnable := FEnabled and Assigned(FOnTimer) and (FInterval > 0);\r\n\r\n if not KeepAlive then\r\n StopTimer;\r\n\r\n if DoEnable then\r\n begin\r\n if FThread <> nil then\r\n begin\r\n TJvTimerThread(FThread).FInterval := FInterval;\r\n if FThread.Suspended then\r\n FThread.Suspended := False;\r\n end\r\n else\r\n FThread := TJvTimerThread.Create(Self);\r\n end\r\n else\r\n if FThread <> nil then\r\n begin\r\n if not FThread.Suspended then\r\n TJvTimerThread(FThread).DoSuspend;\r\n\r\n TJvTimerThread(FThread).FInterval := FInterval;\r\n end;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvThumbImage.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvThumbImage.PAS, released on 2002-07-03.\r\n\r\nThe Initial Developer of the Original Code is John Kozikopulos [Stdreamer att Excite dott com]\r\nPortions created by John Kozikopulos are Copyright (C) 2002 John Kozikopulos.\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n\r\nChanges form the previous Version:\r\n\r\nConverted the rotation Functions to use scanlines for faster results\r\n I have converted the movement from an array of TRGBTriple to an\r\n an array of bytes. Right now it must rotate the following formats\r\n without big speed differences and problems pf8bit,pf24bit,pf32bit\r\n the pf4bit,pf1bit is converted to pf8bit.\r\n The Pfdevice,pfcustom is converted into pf24bit.\r\n all the Color conversions do not revert to the primary state after the\r\n rotation\r\n\r\nAdded the Mirror routines\r\nRemoved the 180 degree rotation and replaced by the mirror(mtBoth) call.\r\n this let the GDI engine to make the rotation and it is faster than any\r\n rotation I have tested until now I have tested this routine with\r\n and image of 2300x3500x24bit without any problems on Win2K.\r\n I must test it on Win98 before release.\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvThumbImage.pas 13104 2011-09-07 06:50:43Z obones $\r\n\r\nunit JvThumbImage;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, Classes, Controls, ExtCtrls, SysUtils, Messages, Graphics, Forms,\r\n jpeg, Dialogs,\r\n JvBaseThumbnail;\r\n\r\ntype\r\n TAngle = (AT0, AT90, AT180, AT270);\r\n\r\n // (rom) renamed elements\r\n TMirror = (mtHorizontal, mtVertical, mtBoth);\r\n\r\n TCurveArray = array [0..255] of Byte;\r\n TRotateNotify = procedure(Sender: TObject; Percent: Byte; var Cancel: Boolean) of object;\r\n TFilterEmpty = function: Byte;\r\n TFilterArray = array [1..9] of Byte;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvThumbImage = class(TJvBaseThumbImage)\r\n private\r\n FAngle: TAngle;\r\n FModified: Boolean;\r\n FOnRotate: TRotateNotify;\r\n FZoom: Word;\r\n FOnLoad: TNotifyEvent;\r\n FFileName: string;\r\n FClass: TGraphicClass;\r\n FOnInvalidImage: TInvalidImageEvent;\r\n procedure Rotate90;\r\n //procedure Rotate180;\r\n procedure Rotate270;\r\n procedure SetAngle(AAngle: TAngle);\r\n function GetModify: Boolean;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n procedure Mirror(MirrorType: TMirror);\r\n procedure ChangeRGB(R, G, B: Longint);\r\n procedure ChangeRGBCurves(R, G, B: TCurveArray);\r\n procedure ScaleDown(MaxW, MaxH: Longint);\r\n procedure LoadFromFile(AFile: string); //virtual;\r\n procedure LoadFromStream(AStream: TStream; AType: TGRFKind); // needs more tests\r\n procedure SaveToStream(AStream: TStream; AType: TGRFKind); // testing it\r\n procedure SaveToFile(AFile: string);\r\n procedure Save;\r\n procedure BitmapNeeded;\r\n // Procedure FilterFactory(Filter: TFilterArray; Divider: Byte);\r\n procedure Invert;\r\n procedure Contrast(const Percent: TPercent);\r\n procedure Lightness(const Percent: TPercent);\r\n procedure Grayscale;\r\n procedure Rotate(AAngle: TAngle);\r\n function GetFilter: string;\r\n //property JpegScale: TJPegScale read vJPegScale write vJpegScale;\r\n published\r\n property Angle: TAngle read FAngle write SetAngle;\r\n property Modified: Boolean read FModified;\r\n //Property OnRelease : TdestroyNotify read EVonrelease write Evonrelease;\r\n property CanModify: Boolean read GetModify;\r\n property Zoom: Word read FZoom write FZoom;\r\n // (rom) should be called in the implementation more often\r\n property OnRotate: TRotateNotify read FOnRotate write FOnRotate;\r\n property OnLoaded: TNotifyEvent read FOnLoad write FOnLoad;\r\n property OnInvalidImage: TInvalidImageEvent read FOnInvalidImage write FOnInvalidImage;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvThumbImage.pas $';\r\n Revision: '$Revision: 13104 $';\r\n Date: '$Date: 2011-09-07 08:50:43 +0200 (mer. 07 sept. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n JvThumbnails, JvTypes, JvResources;\r\n\r\nconstructor TJvThumbImage.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FAngle := AT0;\r\n// FClass := Graphics.TBitmap;\r\n FModified := False;\r\nend;\r\n\r\ndestructor TJvThumbImage.Destroy;\r\nbegin\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvThumbImage.Lightness(const Percent: TPercent);\r\nvar\r\n Amount: Integer;\r\n RCurve: TCurveArray;\r\n I: Integer;\r\nbegin\r\n Amount := Round((255 / 100) * Percent);\r\n if Amount > 0 then\r\n for I := 0 to 255 do\r\n RCurve[I] := BoundByte(0, 255, I + ((Amount * (I xor 255)) shr 8))\r\n else\r\n for I := 0 to 255 do\r\n RCurve[I] := BoundByte(0, 255, I - ((Abs(Amount) * I) shr 8));\r\n ChangeRGBCurves(RCurve, RCurve, RCurve);\r\nend;\r\n\r\nprocedure TJvThumbImage.Rotate(AAngle: TAngle);\r\nbegin\r\n case AAngle of\r\n AT90:\r\n Rotate90;\r\n AT180:\r\n Mirror(mtBoth);\r\n AT270:\r\n Rotate270;\r\n end;\r\nend;\r\n\r\nfunction TJvThumbImage.GetFilter: string;\r\nvar\r\n // a: string;\r\n P: Longint;\r\nbegin\r\n Result := Graphics.GraphicFilter(TGraphic);\r\n // (rom) better clean that up\r\n P := Pos('(', Result);\r\n InsertStr(Result, RsPcxTga, P);\r\n P := Pos('|', Result);\r\n InsertStr(Result, RsPcxTga, P);\r\n Result := Result + RsFileFilters;\r\n //Graphics.GraphicFilter(TGraphic)+'|PCX File|*.PCX|Targa File|*.TGA';\r\n { TODO : Add in the filter the rest of the images we support but are not registered to the Graphics unit }\r\nend;\r\n\r\nprocedure TJvThumbImage.Contrast;\r\nvar\r\n Amount: Integer;\r\n Counter: Integer;\r\n Colors: TCurveArray;\r\nbegin\r\n Amount := Round((256 / 100) * Percent);\r\n for Counter := 0 to 127 do\r\n Colors[Counter] := BoundByte(0, 255, Counter - ((Abs(128 - Counter) * Amount) div 256));\r\n for Counter := 127 to 255 do\r\n Colors[Counter] := BoundByte(0, 255, Counter + ((Abs(128 - Counter) * Amount) div 256));\r\n ChangeRGBCurves(Colors, Colors, Colors);\r\nend;\r\n\r\nprocedure TJvThumbImage.LoadFromStream(AStream: TStream; AType: TGRFKind);\r\nvar\r\n Bmp: Graphics.TBitmap;\r\n Jpg: TJpegImage;\r\n Wmf: TMetafile;\r\n Ico: TIcon;\r\nbegin\r\n //testing the stream load capabilities;\r\n // (rom) deactivated because LoadFromStream is not defined that way\r\n //AStream.Seek(0, soFromBeginning); //most of the stream error are generated because this is not at the proper position\r\n case AType of\r\n grBMP:\r\n begin\r\n Bmp := Graphics.TBitmap.Create;\r\n try\r\n Bmp.LoadFromStream(AStream);\r\n Bmp.PixelFormat := pf24bit;\r\n Picture.Assign(Bmp);\r\n finally\r\n FreeAndNil(Bmp);\r\n end;\r\n end;\r\n grJPG:\r\n begin\r\n Jpg := TJpegImage.Create;\r\n try\r\n Jpg.LoadFromStream(AStream);\r\n Picture.Assign(Jpg);\r\n finally\r\n FreeAndNil(Jpg);\r\n end;\r\n end;\r\n grWMF, grEMF:\r\n begin\r\n Wmf := Graphics.TMetafile.Create;\r\n try\r\n Wmf.LoadFromStream(AStream);\r\n Picture.Assign(Wmf);\r\n finally\r\n FreeAndNil(Wmf);\r\n end;\r\n end;\r\n grICO:\r\n begin\r\n Ico := Graphics.TIcon.Create;\r\n try\r\n Ico.LoadFromStream(AStream);\r\n Picture.Assign(Ico);\r\n finally\r\n FreeAndNil(Ico);\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvThumbImage.SaveToStream(AStream: TStream; AType: TGRFKind);\r\nvar\r\n Bmp: Graphics.TBitmap;\r\n Jpg: TJpegImage;\r\n Wmf: TMetafile;\r\n Ico: TIcon;\r\nbegin\r\n //testing the stream Save capabilities;\r\n // (rom) deactivated because SaveToStream is not defined that way\r\n //AStream.Seek(0, soFromBeginning); //most of the stream error are generated because this is not at the proper position\r\n case AType of\r\n grBMP:\r\n begin\r\n Bmp := Graphics.TBitmap.Create;\r\n // (rom) secured\r\n try\r\n Bmp.Assign(Picture.Graphic);\r\n Bmp.PixelFormat := pf24bit;\r\n Bmp.SaveToStream(AStream);\r\n finally\r\n FreeAndNil(Bmp);\r\n end;\r\n end;\r\n grJPG:\r\n begin\r\n Jpg := TJpegImage.Create;\r\n try\r\n Jpg.Assign(Picture.Graphic);\r\n Jpg.SaveToStream(AStream);\r\n finally\r\n FreeAndNil(Jpg);\r\n end;\r\n end;\r\n grWMF, grEMF:\r\n begin\r\n Wmf := Graphics.TMetafile.Create;\r\n try\r\n Wmf.Assign(Picture.Graphic);\r\n Wmf.SaveToStream(AStream);\r\n finally\r\n FreeAndNil(Wmf);\r\n end;\r\n end;\r\n grICO:\r\n begin\r\n Ico := Graphics.TIcon.Create;\r\n try\r\n Ico.Assign(Picture.Graphic);\r\n Ico.SaveToStream(AStream);\r\n finally\r\n FreeAndNil(Ico);\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvThumbImage.LoadFromFile(AFile: string);\r\nvar\r\n JpegImage: TJpegImage;\r\n Fl: TFileStream;\r\nbegin\r\n try\r\n if UpperCase(ExtractFileExt(AFile)) = '.JPG' then\r\n begin\r\n JpegImage := TJpegImage.Create;\r\n\r\n if Parent is TJvThumbnail then\r\n begin\r\n Fl := TFileStream.Create(AFile, fmOpenRead or fmShareDenyWrite);\r\n // (rom) this is idiotic\r\n try\r\n case Fl.Size of\r\n 0..1000000:\r\n JpegImage.Scale := jsFullSize;\r\n 1000001..4000000:\r\n JpegImage.Scale := jsHalf;\r\n 4000001..7000000:\r\n JpegImage.Scale := jsQuarter;\r\n else\r\n JpegImage.Scale := jsEighth;\r\n end;\r\n finally\r\n Fl.Free;\r\n end;\r\n end\r\n else\r\n JpegImage.Scale := jsFullSize;\r\n JpegImage.LoadFromFile(AFile);\r\n // Picture.Bitmap := Graphics.TBitmap.Create;\r\n with Picture.Bitmap do\r\n begin\r\n Width := JpegImage.Width;\r\n Height := JpegImage.Height;\r\n Picture.Bitmap.Canvas.Draw(0, 0, JpegImage);\r\n Self.FClass := TJpegImage;\r\n end;\r\n FreeAndNil(JpegImage);\r\n end\r\n else\r\n begin\r\n try\r\n Picture.LoadFromFile(AFile);\r\n except\r\n if Assigned(FOnInvalidImage) then\r\n begin\r\n FOnInvalidImage(Self, AFile);\r\n Exit;\r\n end\r\n else\r\n raise;\r\n end;\r\n Self.FClass := TGraphicClass(Picture.Graphic.ClassType);\r\n end;\r\n FFileName := AFile;\r\n FAngle := AT0;\r\n if Assigned(FOnLoad) then\r\n FOnLoad(Self);\r\n except\r\n on E: Exception do\r\n begin\r\n FFileName := '';\r\n Self.FClass := nil;\r\n raise;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvThumbImage.SaveToFile(AFile: string);\r\nvar\r\n Ext: string;\r\n Jpg: TJpegImage;\r\n Bmp: TBitmap;\r\n Wmf: TMetafile;\r\nbegin\r\n // (rom) enforcing a file extension is bad style\r\n Ext := UpperCase(ExtractFileExt(AFile));\r\n if (Ext = '.JPG') or (Ext = '.JPEG') then\r\n try\r\n Jpg := TJpegImage.Create;\r\n Jpg.Assign(Picture.Graphic);\r\n Jpg.CompressionQuality := 75;\r\n Jpg.Compress;\r\n Jpg.SaveToFile(AFile);\r\n finally\r\n FreeAndNil(Jpg);\r\n end\r\n else\r\n if Ext = '.BMP' then\r\n try\r\n Bmp := Graphics.TBitmap.Create;\r\n Bmp.Assign(Picture.Graphic);\r\n Bmp.Canvas.Draw(0, 0, Picture.Graphic);\r\n Bmp.SaveToFile(AFile);\r\n finally\r\n FreeAndNil(Bmp);\r\n end\r\n else\r\n if Ext = '.WMF' then\r\n try\r\n Wmf := TMetafile.Create;\r\n Wmf.Assign(Picture.Graphic);\r\n Wmf.Enhanced := False;\r\n Wmf.SaveToFile(AFile);\r\n finally\r\n FreeAndNil(Wmf);\r\n end\r\n else\r\n if Ext = '.EMF' then\r\n try\r\n Wmf := Graphics.TMetafile.Create;\r\n Wmf.Assign(Picture.Graphic);\r\n Wmf.Enhanced := True;\r\n Wmf.SaveToFile(AFile);\r\n finally\r\n FreeAndNil(Wmf);\r\n end\r\n else\r\n raise EJVCLException.CreateResFmt(@RsEUnknownFileExtension, [Ext]);\r\nend;\r\n\r\nprocedure TJvThumbImage.Save;\r\nvar\r\n Temp: TGraphic;\r\nbegin\r\n if FClass <> nil then\r\n begin\r\n Temp := FClass.Create;\r\n Temp.Assign(Self.Picture.Graphic);\r\n Temp.SaveToFile(FFileName);\r\n FreeAndNil(Temp);\r\n end\r\n else\r\n SaveToFile(FFileName);\r\nend;\r\n\r\nprocedure TJvThumbImage.BitmapNeeded;\r\nvar\r\n Bmp: Graphics.TBitmap;\r\nbegin\r\n Bmp := Graphics.TBitmap.Create;\r\n try\r\n Bmp.HandleType := bmDIB;\r\n // Bmp.PixelFormat := pf24Bit;\r\n // Bmp.Width := Picture.Graphic.Width;\r\n // Bmp.Height := Picture.Graphic.Height;\r\n // Bmp.Canvas.Draw(0,0,Picture.Graphic);\r\n Bmp.Assign(Picture.Graphic);\r\n Picture.Graphic.Assign(Bmp);\r\n finally\r\n Bmp.Free;\r\n end;\r\nend;\r\n\r\nprocedure TJvThumbImage.ScaleDown(MaxW, MaxH: Longint);\r\nvar\r\n NewSize: TPoint;\r\n Bmp: Graphics.TBitmap;\r\nbegin\r\n NewSize := ProportionalSize(Point(Picture.Width, Picture.Height), Point(MaxW, MaxH));\r\n if (NewSize.X > Picture.Width) and (NewSize.Y > Picture.Height) then\r\n Exit;\r\n // SomeTimes when the resize is bigger than 1600% then the strechDraw\r\n // doesn't produce any results at all so do it more than once to make\r\n // absolutly sure the will have an image in any case.\r\n if ((Picture.Width div NewSize.X) > 16) or ((Picture.Height div NewSize.Y) > 16) then\r\n ScaleDown(2 * MaxW, 2 * MaxH);\r\n Bmp := Graphics.TBitmap.Create;\r\n try\r\n Bmp.Width := NewSize.X;\r\n Bmp.Height := NewSize.Y;\r\n Bmp.HandleType := bmDIB;\r\n Bmp.PixelFormat := pf24bit;\r\n Bmp.Canvas.StretchDraw(Rect(0, 0, Bmp.Width, Bmp.Height), Picture.Graphic);\r\n Picture.Assign(Bmp);\r\n Picture.Bitmap.Dormant;\r\n Picture.Bitmap.FreeImage;\r\n finally\r\n FreeAndNil(Bmp);\r\n end;\r\n FModified := True;\r\nend;\r\n\r\nfunction TJvThumbImage.GetModify: Boolean;\r\nbegin\r\n Result := False;\r\n if not Assigned(Picture) or not Assigned(Picture.Graphic) then\r\n Exit;\r\n if Picture.Graphic.Empty then\r\n Result := False\r\n else\r\n if Picture.Graphic is Graphics.TMetafile then\r\n Result := False\r\n else\r\n Result := not (Picture.Graphic is Graphics.TIcon);\r\nend;\r\n\r\nprocedure TJvThumbImage.Grayscale;\r\n{At this point I would like to thanks The author of the EFG's computer lab\r\n (I don't Recall His name Right now) for the fantastic job he has\r\n done gathering all this info}\r\nvar\r\n Line: PJvRGBArray;\r\n MemBmp: Graphics.TBitmap;\r\n Row, Col: Word;\r\n Intens: Byte;\r\nbegin\r\n if CanModify then\r\n begin\r\n MemBmp := Graphics.TBitmap.Create;\r\n try\r\n MemBmp.Width := Picture.Width;\r\n MemBmp.Height := Picture.Height;\r\n MemBmp.Assign(Picture.Graphic);\r\n MemBmp.PixelFormat := pf24bit;\r\n MemBmp.HandleType := bmDIB;\r\n for Row := 0 to MemBmp.Height - 1 do\r\n begin\r\n Line := MemBmp.ScanLine[Row];\r\n for Col := 0 to MemBmp.Width - 1 do\r\n begin\r\n Intens := (Line[Col].rgbRed + Line[Col].rgbGreen + Line[Col].rgbBlue)\r\n div 3;\r\n Line[Col].rgbRed := Intens;\r\n Line[Col].rgbGreen := Intens;\r\n Line[Col].rgbBlue := Intens;\r\n end;\r\n end;\r\n if Picture.Graphic is TJpegImage then\r\n TJpegImage(Picture.Graphic).Assign(MemBmp);\r\n if Picture.Graphic is Graphics.TBitmap then\r\n Picture.Bitmap.Assign(MemBmp);\r\n finally\r\n MemBmp.Free;\r\n end;\r\n end;\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvThumbImage.Invert;\r\nvar\r\n R: TCurveArray;\r\n I: Byte;\r\nbegin\r\n for I := 0 to 255 do\r\n R[I] := 255 - I;\r\n ChangeRGBCurves(R, R, R);\r\nend;\r\n\r\nprocedure TJvThumbImage.ChangeRGBCurves(R, G, B: TCurveArray);\r\nvar\r\n Line: PJvRGBArray;\r\n MemBmp: Graphics.TBitmap;\r\n Row, Col: Word;\r\nbegin\r\n {\r\n This procedure substitutes the values of R,G,B acordinally to the arrays the\r\n user passes in it. This is the simplest way to change the curve of a Color\r\n depending on an algorithm created by the user.\r\n The substitute value of a red 0 is the value which lies in the R[0] position.\r\n for a simple example have a look at the invert procedure above\r\n }\r\n if CanModify then\r\n begin\r\n MemBmp := Graphics.TBitmap.Create;\r\n try\r\n MemBmp.Width := Picture.Width;\r\n MemBmp.Height := Picture.Height;\r\n MemBmp.Assign(Picture.Graphic);\r\n MemBmp.PixelFormat := pf24bit;\r\n MemBmp.HandleType := bmDIB;\r\n for Row := 0 to MemBmp.Height - 1 do\r\n begin\r\n Line := MemBmp.ScanLine[Row];\r\n for Col := 0 to MemBmp.Width - 1 do\r\n begin\r\n Line[Col].rgbRed := R[Line[Col].rgbRed];\r\n Line[Col].rgbGreen := G[Line[Col].rgbGreen];\r\n Line[Col].rgbBlue := B[Line[Col].rgbBlue];\r\n end;\r\n end;\r\n if Picture.Graphic is TJpegImage then\r\n TJpegImage(Picture.Graphic).Assign(MemBmp);\r\n if Picture.Graphic is Graphics.TBitmap then\r\n Picture.Bitmap.Assign(MemBmp);\r\n finally\r\n FreeAndNil(MemBmp);\r\n end;\r\n end;\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvThumbImage.Mirror(MirrorType: TMirror);\r\nvar\r\n MemBmp: Graphics.TBitmap;\r\n // RotateBmp: Graphics.TBitmap;\r\n Dest: TRect;\r\nbegin\r\n if Assigned(Picture.Graphic) then\r\n if CanModify then\r\n begin\r\n MemBmp := Graphics.TBitmap.Create;\r\n try\r\n MemBmp.PixelFormat := pf24bit;\r\n MemBmp.HandleType := bmDIB;\r\n MemBmp.Width := Self.Picture.Graphic.Width;\r\n MemBmp.Height := Self.Picture.Height;\r\n MemBmp.Canvas.Draw(0, 0, Picture.Graphic);\r\n //MemBmp.Assign(Picture.Graphic);\r\n case MirrorType of\r\n mtHorizontal:\r\n begin\r\n //SpiegelnVertikal(MemBmp);\r\n //SpiegelnHorizontal(MemBmp);\r\n Dest.Left := MemBmp.Width;\r\n Dest.Top := 0;\r\n Dest.Right := -MemBmp.Width;\r\n Dest.Bottom := MemBmp.Height;\r\n end;\r\n mtVertical:\r\n begin\r\n // SpiegelnVertikal(MemBmp);\r\n //SpiegelnHorizontal(MemBmp);\r\n Dest.Left := 0;\r\n Dest.Top := MemBmp.Height;\r\n Dest.Right := MemBmp.Width;\r\n Dest.Bottom := -MemBmp.Height;\r\n end;\r\n mtBoth:\r\n begin\r\n Dest.Left := MemBmp.Width;\r\n Dest.Top := MemBmp.Height;\r\n Dest.Right := -MemBmp.Width;\r\n Dest.Bottom := -MemBmp.Height;\r\n end;\r\n end;\r\n { stretchblt(RotateBmp.Canvas.Handle,Dest.Left,Dest.Top,Dest.Right,Dest.Bottom,\r\n MemBmp.Canvas.Handle,0,0,MemBmp.Width,MemBmp.Height,SRCCOPY);}\r\n {procedure Rotate180Grad(Bitmap: Graphics.TBitmap); forward;\r\n procedure Rotate90Grad(Bitmap: Graphics.TBitmap); forward;\r\n procedure Rotate270Grad(Bitmap: Graphics.TBitmap); forward;}\r\n StretchBlt(MemBmp.Canvas.Handle, Dest.Left, Dest.Top, Dest.Right, Dest.Bottom,\r\n MemBmp.Canvas.Handle, 0, 0, MemBmp.Width, MemBmp.Height, SRCCOPY);\r\n Picture.Graphic.Assign(MemBmp);\r\n Invalidate;\r\n // FreeAndNil(RotateBmp);\r\n finally\r\n FreeAndNil(MemBmp);\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvThumbImage.ChangeRGB(R, G, B: Longint);\r\n{\r\nJust a simple procedure to increase or decrease the values of the each channel\r\nin the image idependendly from each other. E.G.\r\nlets say the R,G,B vars have the values of 5,-3,7 this means that the red\r\nchannel should be increased buy 5 points in all the image the green value will\r\nbe decreased by 3 points and the blue value will be increased by 7 points.\r\nThis will happen to all the image by the same value no Color limunocity is\r\nbeen preserved or values calculations depenting on the current channel values;\r\n}\r\nvar\r\n Line: PJvRGBArray;\r\n InBmp: Graphics.TBitmap;\r\n Row, Col: Integer;\r\nbegin\r\n if not CanModify then\r\n Exit;\r\n InBmp := Graphics.TBitmap.Create;\r\n try\r\n InBmp.Width := Picture.Width;\r\n InBmp.Height := Picture.Height;\r\n InBmp.Assign(Picture.Graphic);\r\n InBmp.HandleType := bmDIB;\r\n InBmp.PixelFormat := pf24bit;\r\n for Row := 0 to InBmp.Height - 1 do\r\n begin\r\n Line := InBmp.ScanLine[Row];\r\n for Col := 0 to InBmp.Width - 1 do\r\n begin\r\n Line[Col].rgbRed := BoundByte(0, 255, Line[Col].rgbRed + R);\r\n Line[Col].rgbGreen := BoundByte(0, 255, Line[Col].rgbGreen + G);\r\n Line[Col].rgbBlue := BoundByte(0, 255, Line[Col].rgbBlue + B);\r\n end;\r\n end;\r\n { if Picture.Graphic is TJpegImage then\r\n TJpegImage(Picture.Graphic).Assign(InBmp){}\r\n // else\r\n Picture.Graphic.Assign(InBmp);\r\n Invalidate;\r\n FModified := True;\r\n finally\r\n InBmp.Free;\r\n end;\r\nend;\r\n\r\nprocedure TJvThumbImage.SetAngle(AAngle: TAngle);\r\nbegin\r\n { Procedure to actually decide wich should be the rotation in conjuction with the\r\n image's phisical Angle}\r\n if Assigned(Picture.Graphic) then\r\n if CanModify then\r\n if AAngle <> FAngle then\r\n begin\r\n if FAngle = AT0 then\r\n begin\r\n if AAngle = AT90 then\r\n begin\r\n Rotate90;\r\n if Parent is TJvThumbnail then\r\n SendMessage(TJvThumbnail(Parent).Handle, TH_IMAGESIZECHANGED, 0, 0);\r\n end;\r\n if AAngle = AT180 then\r\n begin\r\n //rotate180;\r\n Mirror(mtBoth);\r\n end;\r\n if AAngle = AT270 then\r\n begin\r\n Rotate270;\r\n if Parent is TJvThumbnail then\r\n SendMessage(TJvThumbnail(Parent).Handle, TH_IMAGESIZECHANGED, 0, 0);\r\n end;\r\n end;\r\n if FAngle = AT90 then\r\n begin\r\n if AAngle = AT180 then\r\n begin\r\n Rotate90;\r\n if Parent is TJvThumbnail then\r\n SendMessage(TJvThumbnail(Parent).Handle, TH_IMAGESIZECHANGED, 0, 0);\r\n end;\r\n if AAngle = AT270 then\r\n begin\r\n //rotate180;\r\n Mirror(mtBoth);\r\n end;\r\n if AAngle = AT0 then\r\n begin\r\n Rotate270;\r\n if Parent is TJvThumbnail then\r\n SendMessage(TJvThumbnail(Parent).Handle, TH_IMAGESIZECHANGED, 0, 0);\r\n end;\r\n end;\r\n if FAngle = AT180 then\r\n begin\r\n if AAngle = AT90 then\r\n begin\r\n Rotate270;\r\n if Parent is TJvThumbnail then\r\n SendMessage(TJvThumbnail(Parent).Handle, TH_IMAGESIZECHANGED, 0, 0);\r\n end;\r\n if AAngle = AT0 then\r\n begin\r\n //rotate180;\r\n Mirror(mtBoth);\r\n end;\r\n if AAngle = AT270 then\r\n begin\r\n Rotate90;\r\n if Parent is TJvThumbnail then\r\n SendMessage(TJvThumbnail(Parent).Handle, TH_IMAGESIZECHANGED, 0, 0);\r\n end;\r\n end;\r\n if FAngle = AT270 then\r\n begin\r\n if AAngle = AT90 then\r\n begin\r\n //rotate180;\r\n Mirror(mtBoth);\r\n end;\r\n if AAngle = AT0 then\r\n begin\r\n Rotate90;\r\n if Parent is TJvThumbnail then\r\n SendMessage(TJvThumbnail(Parent).Handle, TH_IMAGESIZECHANGED, 0, 0);\r\n end;\r\n if AAngle = AT180 then\r\n begin\r\n Rotate270;\r\n if Parent is TJvThumbnail then\r\n SendMessage(TJvThumbnail(Parent).Handle, TH_IMAGESIZECHANGED, 0, 0);\r\n end;\r\n end;\r\n FAngle := AAngle;\r\n FModified := FAngle <> AT0;\r\n end;\r\nend;\r\n\r\nprocedure TJvThumbImage.Rotate270;\r\nvar\r\n MemBmp: Graphics.TBitmap;\r\n PByte1: PJvRGBArray;\r\n PByte2: PJvRGBArray;\r\n // Stp: Byte;\r\n RotateBmp: Graphics.TBitmap;\r\n I, J: Longint;\r\nbegin\r\n if Assigned(Picture.Graphic) then\r\n if CanModify then\r\n begin\r\n RotateBmp := nil;\r\n MemBmp := Graphics.TBitmap.Create;\r\n RotateBmp := Graphics.TBitmap.Create;\r\n try\r\n MemBmp.Assign(Picture.Graphic);\r\n MemBmp.HandleType := bmDIB;\r\n MemBmp.PixelFormat := pf24bit;\r\n RotateBmp.PixelFormat := MemBmp.PixelFormat;\r\n RotateBmp.HandleType := MemBmp.HandleType;\r\n RotateBmp.Width := MemBmp.Height;\r\n RotateBmp.Height := MemBmp.Width; {}\r\n I := 0; //RotateBmp.Height-1;\r\n while I < RotateBmp.Height {-1} do\r\n begin\r\n PByte1 := RotateBmp.ScanLine[I];\r\n J := 0;\r\n while J < MemBmp.Height {-1} do\r\n begin\r\n PByte2 := MemBmp.ScanLine[J];\r\n PByte1[J] := PByte2[RotateBmp.Height - 1 - I];\r\n Inc(J);\r\n end;\r\n Inc(I);\r\n end;\r\n Picture.Bitmap.Assign(RotateBmp);\r\n Invalidate;\r\n finally\r\n FreeAndNil(RotateBmp);\r\n FreeAndNil(MemBmp);\r\n end;\r\n end;\r\nend;\r\n\r\n(*\r\nprocedure TJvThumbImage.Rotate180;\r\nvar\r\n MemBmp: Graphics.TBitmap;\r\n RotateBmp: Graphics.TBitmap;\r\n I, J: Longint;\r\n Brake: Boolean;\r\n R: TRect;\r\nbegin\r\n //Procedure to rotate the image at 180d cw or ccw is the same\r\n\r\n { TODO : Removed the 180 degree rotation and replaced by the mirror(mtBoth) call.\r\n this let the GDI engine to make the rotation and it is faster than any\r\n rotation I have tested until now I have tested this routine with\r\n and image of 2300x3500x24bit with out any problems on Win2K.\r\n I must test it on Win98 before release. }\r\n if Assigned(Picture.Graphic) then\r\n if CanModify then\r\n begin\r\n if not Assigned(FOnRotate) then\r\n Screen.Cursor := crHourGlass;\r\n MemBmp := Graphics.TBitmap.Create;\r\n MemBmp.Width := Picture.Width;\r\n MemBmp.Height := Picture.Height;\r\n MemBmp.canvas.Draw(0, 0, Picture.Graphic);\r\n MemBmp.Palette := Picture.Graphic.Palette;\r\n RotateBmp := Graphics.TBitmap.Create;\r\n RotateBmp.Assign(MemBmp);\r\n R := MemBmp.Canvas.ClipRect;\r\n for I := Left to R.Right do\r\n for J := Top to R.Bottom do\r\n begin\r\n RotateBmp.Canvas.Pixels[R.Right - I - 1, R.Bottom - J - 1] :=\r\n MemBmp.Canvas.Pixels[I, J];\r\n if Assigned(FOnRotate) then\r\n begin\r\n Brake := False;\r\n FOnRotate(Self, Trunc(((I * J) / (R.Right * R.Bottom)) * 100), Brake);\r\n if Brake then\r\n begin\r\n RotateBmp.Free;\r\n MemBmp.Free;\r\n Exit;\r\n end;\r\n end;\r\n end;\r\n Picture.Bitmap.Assign(RotateBmp);\r\n Invalidate;\r\n RotateBmp.Free;\r\n MemBmp.Free;\r\n if not Assigned(FOnRotate) then\r\n Screen.Cursor := crArrow;\r\n end;\r\nend;\r\n*)\r\n\r\nprocedure TJvThumbImage.Rotate90;\r\nvar\r\n MemBmp: Graphics.TBitmap;\r\n PByte1: PJvRGBArray;\r\n PByte2: PJvRGBArray;\r\n // Stp: Byte;\r\n RotateBmp: Graphics.TBitmap;\r\n I, J {, C}: Longint;\r\nbegin\r\n //Procedure to rotate an image at 90D clockwise or 270D ccw\r\n if Assigned(Picture.Graphic) then\r\n if CanModify then\r\n begin\r\n RotateBmp := nil;\r\n MemBmp := Graphics.TBitmap.Create;\r\n RotateBmp := Graphics.TBitmap.Create;\r\n try\r\n MemBmp.Assign(Picture.Graphic);\r\n MemBmp.HandleType := bmDIB;\r\n //MemBmp.PixelFormat := pf24bit;\r\n { Case MemBmp.PixelFormat of\r\n pf4bit,pf1bit : begin MemBmp.PixelFormat := pf8bit; Stp := 1; end;\r\n pf8bit : Stp := 1;\r\n pf16bit,PF15Bit : Stp := 2;\r\n pf24bit : Stp := 3;\r\n pf32bit : Stp := 4;\r\n pfDevice,\r\n pfCustom : begin\r\n MemBmp.PixelFormat := pf24bit;\r\n Stp:=3;\r\n end;\r\n else Exit;\r\n end;{}\r\n MemBmp.PixelFormat := pf24bit;\r\n // Stp := 3;\r\n RotateBmp.FreeImage;\r\n RotateBmp.PixelFormat := MemBmp.PixelFormat;\r\n RotateBmp.HandleType := MemBmp.HandleType;\r\n RotateBmp.Width := MemBmp.Height;\r\n RotateBmp.Height := MemBmp.Width;\r\n I := RotateBmp.Height - 1;\r\n while I >= 0 do\r\n begin\r\n PByte1 := RotateBmp.ScanLine[I];\r\n J := 0;\r\n while J < MemBmp.Height do\r\n begin\r\n PByte2 := MemBmp.ScanLine[MemBmp.Height - 1 - J];\r\n PByte1[J] := PByte2[I];\r\n Inc(J);\r\n end;\r\n Dec(I);\r\n end;\r\n Picture.Bitmap.Assign(RotateBmp);\r\n finally\r\n FreeAndNil(RotateBmp);\r\n FreeAndNil(MemBmp);\r\n end;\r\n end;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvThumbViews.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain A Copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvThumbView.PAS, released on 2002-07-03.\r\n\r\nThe Initial Developer of the Original Code is John Kozikopulos [Stdreamer att Excite dott com]\r\nPortions created by John Kozikopulos are Copyright (C) 2002 John Kozikopulos.\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvThumbViews.pas 13138 2011-10-26 23:17:50Z jfudickar $\r\n\r\nunit JvThumbViews;\r\n\r\n{$I jvcl.inc}\r\n{$I windowsonly.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, Classes, Controls, Forms, ExtCtrls,\r\n SysUtils, Messages, Graphics,\r\n JvThumbnails, JvBaseThumbnail, JvExControls;\r\n\r\ntype\r\n // (rom) already in JvBaseThumbnail\r\n //TPercent = 0..100;\r\n TScrollMode = (smHorizontal, smVertical, smBoth);\r\n TViewType = (vtNormal, vtCenter, vtFitToScreen);\r\n // (rom) obviously unused\r\n //TBufferAction = (bfCancel, bfCreate, bfOpen, bfInsert, bfReplace, bfDelete);\r\n TTitleNotify = procedure(Sender: TObject; FileName: string;\r\n var ThumbnailTitle: string; var ThumbnailFont: TFont;\r\n var ThumbnailColor: TColor) of object;\r\n TProgressStartNotify = procedure(Sender: TObject; Max: Integer) of object;\r\n\r\n TJvThumbList = class(TStringList) // declare A new type of Thumblist and try not to Break the old code;\r\n protected\r\n function GetThumbnail(Index: Longint): TJvThumbnail;\r\n public\r\n property Thumbnail[Index: Longint]: TJvThumbnail read GetThumbnail; default;\r\n end;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvThumbView = class(TJvBaseThumbView)\r\n private\r\n FMaxSize: TPoint;\r\n FThumbSize: TPoint;\r\n// Dummy: string;\r\n FPercent: TPercent;\r\n FDirectory: string;\r\n FScrollMode: TScrollMode;\r\n FAutoScrolling: Boolean;\r\n FSelected: Longint;\r\n FAlignView: TViewType;\r\n FThumbGap: Byte;\r\n FMaxX: Word;\r\n FMinMemory: Boolean;\r\n FOnGetTitle: TTitleNotify;\r\n FOnChanging: TNotifyEvent;\r\n FOnChange: TNotifyEvent;\r\n FOnStartScanning: TProgressStartNotify;\r\n FOnStopScanning: TNotifyEvent;\r\n FOnScanProgress: TProgressNotify;\r\n FWaitUntilFull: Boolean;\r\n FPainted: Boolean;\r\n FFileList: TStringList;\r\n FFileListSorted: TStringList;\r\n FSorted: Boolean;\r\n FFilling: Boolean;\r\n FFilter: string;\r\n// FBufferFile: string;\r\n FThumbColor: TColor;\r\n FAsButtons: Boolean;\r\n FTitlePlacement: TTitlePos;\r\n FOnKeyDown: TKeyEvent;\r\n FOnKeyUp: TKeyEvent;\r\n FOnKeyPress: TKeyPressEvent;\r\n FAutoHandleKeyb: Boolean;\r\n FGraphicExtensions: TStringList;\r\n FShowShadow: Boolean;\r\n FShadowColor: TColor;\r\n FThumbList: TJvThumbList;\r\n FOnInvalidImage: TInvalidImageEvent;\r\n FDiskSize: DWORD;\r\n procedure WMPaint(var Msg: TWMPaint); message WM_PAINT;\r\n procedure GetFiles(ADirectory: string);\r\n procedure SetSorted(const Value: Boolean);\r\n procedure CalculateMaxX;\r\n procedure CalculateSize;\r\n function CalculateXPos(Num: Word): Longint;\r\n function CalculateYPos(Num: Word): Longint;\r\n procedure ScrollTo(const Number: Longint);\r\n procedure SetAlignView(AType: TViewType);\r\n procedure Reposition(Start: Integer);\r\n procedure GoLeft;\r\n procedure GoRight;\r\n procedure GoDown;\r\n procedure GoUp;\r\n procedure SetAsButton(const NewVal: Boolean);\r\n procedure SetTitlePos(const NewVal: TTitlePos);\r\n function CreateFilter: string;\r\n procedure SetFilters;\r\n //function GetBufferName(AName: string): string;\r\n function GetMaxHeight: Longint;\r\n function GetMaxWidth: Longint;\r\n procedure DoInvalidImage(Sender: TObject; const FileName: string);\r\n // procedure WMLoadWhenReady(var Msg: TMessage); message WM_LOADWHENREADY;\r\n protected\r\n procedure GetDlgCode(var Code: TDlgCodes); override;\r\n procedure SetScrollMode(AMode: TScrollMode);\r\n procedure SetSelected(Number: Longint);\r\n // procedure SetBufferFile(NewName: string);\r\n procedure Resize; override;\r\n procedure SetMaxWidth(W: Longint);\r\n procedure SetDirectory(Value: string);\r\n procedure SetMaxHeight(H: Longint);\r\n procedure KeyPress(var Key: Char); override;\r\n procedure KeyDown(var Key: Word; Shift: TShiftState); override;\r\n procedure KeyUp(var Key: Word; Shift: TShiftState); override;\r\n procedure SetThumbGap(Sp: Byte);\r\n procedure SetPercent(P: TPercent);\r\n procedure SetSelectedFile(AFile: string);\r\n function GetSelectedFile: string;\r\n procedure MouseDown(Button: TMouseButton; Shift: TShiftState;\r\n X, Y: Integer); override;\r\n // function GetBufferFile: string;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n procedure AddThumb(ATitle: string; Redraw: Boolean);\r\n function AddFromFile(AFile: string) : Integer;\r\n procedure AddFromStream(AStream: TStream; AType: TGRFKind); overload;\r\n function AddFromStream(AStream: TStream; AType: TGRFKind; const aTitle: string): Integer; overload;\r\n\r\n procedure Delete(No: Longint);\r\n procedure EmptyList;\r\n procedure SortList;\r\n procedure Refresh;\r\n function GetCount: Word;\r\n property ThumbList: TJvThumbList read FThumbList write FThumbList;\r\n published\r\n property SelectedFile: string read GetSelectedFile write SetSelectedFile;\r\n property AlignView: TViewType read FAlignView write SetAlignView;\r\n property AutoScrolling: Boolean read FAutoScrolling write FAutoScrolling;\r\n property ThumbGap: Byte read FThumbGap write SetThumbGap;\r\n property AutoHandleKeyb: Boolean read FAutoHandleKeyb write FAutoHandleKeyb;\r\n property MinMemory: Boolean read FMinMemory write FMinMemory;\r\n property Count: Word read GetCount default 0;\r\n property MaxWidth: Longint read GetMaxWidth write SetMaxWidth;\r\n property MaxHeight: Longint read GetMaxHeight write SetMaxHeight;\r\n property Size: TPercent read FPercent write SetPercent;\r\n property ScrollMode: TScrollMode read FScrollMode write SetScrollMode;\r\n property Directory: string read FDirectory write SetDirectory;\r\n property Sorted: Boolean read FSorted write SetSorted;\r\n property Selected: Longint read FSelected write SetSelected default -1;\r\n property OnStartScanning: TProgressStartNotify read FOnStartScanning write FOnStartScanning;\r\n property OnStopScanning: TNotifyEvent read FOnStopScanning write FOnStopScanning;\r\n property OnScanProgress: TProgressNotify read FOnScanProgress write FOnScanProgress;\r\n property OnGetTitle: TTitleNotify read FOnGetTitle write FOnGetTitle;\r\n property OnInvalidImage: TInvalidImageEvent read FOnInvalidImage write FOnInvalidImage;\r\n property OnChange: TNotifyEvent read FOnChange write FOnChange;\r\n property OnChanging: TNotifyEvent read FOnChanging write FOnChanging;\r\n property OnKeyUp: TKeyEvent read FOnKeyUp write FOnKeyUp;\r\n property OnKeyDown: TKeyEvent read FOnKeyDown write FOnKeyDown;\r\n property OnKeyPress: TKeyPressEvent read FOnKeyPress write FOnKeyPress;\r\n property AsButtons: Boolean read FAsButtons write SetAsButton;\r\n property TitlePlacement: TTitlePos read FTitlePlacement write SetTitlePos default tpUp;\r\n property Filter: string read FFilter write FFilter;\r\n // Property BufferFile : String Read FBufferFile write SetBufferFile;\r\n property ThumbColor: TColor read FThumbColor write FThumbColor;\r\n property ShowShadow: Boolean read FShowShadow write FShowShadow;\r\n property ShadowColor: TColor read FShadowColor write FShadowColor;\r\n property AutoScroll;\r\n property PopupMenu;\r\n property BorderStyle;\r\n property Align;\r\n property Color;\r\n property Cursor;\r\n property DragCursor;\r\n property DragMode;\r\n property Enabled;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvThumbViews.pas $';\r\n Revision: '$Revision: 13138 $';\r\n Date: '$Date: 2011-10-27 01:17:50 +0200 (jeu. 27 oct. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n JvConsts;\r\n\r\n{const\r\n FGraphicExtensions : array[1..9] of string = ('*.BMP','*.JPG','*.WMF','*.EMF',\r\n '*.ICO','*.GIF','*.PCX',\r\n '*.TGA','*.PNG'); {}\r\n\r\nconstructor TJvThumbView.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n TabStop := True;\r\n FPainted := False;\r\n Width := 600;\r\n Height := 480;\r\n FMaxSize.X := 200;\r\n FMaxSize.Y := 200;\r\n FPercent := 100;\r\n FThumbGap := 4;\r\n VertScrollBar.Tracking := True;\r\n HorzScrollBar.Tracking := True;\r\n FScrollMode := smHorizontal;\r\n Caption := '';\r\n CalculateSize;\r\n FWaitUntilFull := False;\r\n FFilling := False;\r\n FSorted := True;\r\n FMinMemory := True;\r\n FSelected := -1;\r\n AutoScrolling := True;\r\n FDiskSize := 0;\r\n FAutoHandleKeyb := True;\r\n FFilter := CreateFilter;\r\n FThumbList := TJvThumbList.Create;\r\n FThumbList.Sorted := Sorted;\r\n FFileList := TStringList.Create;\r\n FFileList.Clear;\r\n FFileListSorted := TStringList.Create;\r\n FFileListSorted.Clear;\r\n FThumbColor := clNone;\r\nend;\r\n\r\ndestructor TJvThumbView.Destroy;\r\nbegin\r\n FreeAndNil(FFileListSorted);\r\n FreeAndNil(FFileList);\r\n FreeAndNil(FThumbList);\r\n //FreeAndNil(FFilter);\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvThumbView.DoInvalidImage(Sender: TObject; const FileName: string);\r\nbegin\r\n if Assigned(FOnInvalidImage) then\r\n FOnInvalidImage(Sender, FileName);\r\nend;\r\n\r\nprocedure TJvThumbView.AddThumb(ATitle: string; Redraw: Boolean);\r\nvar\r\n Thb: TJvThumbnail;\r\nbegin\r\n Thb := TJvThumbnail.Create(Self);\r\n Thb.Left := CalculateXPos(Count + 1);\r\n Thb.Top := CalculateYPos(Count + 1);\r\n Thb.Width := FThumbSize.X;\r\n Thb.Height := FThumbSize.Y;\r\n Thb.AsButton := FAsButtons;\r\n Thb.TitlePlacement := FTitlePlacement;\r\n Thb.ShadowColor := FShadowColor;\r\n Thb.ShowShadow := FShowShadow;\r\n Thb.OnClick := OnClick;\r\n Thb.Photo.OnClick := OnClick;\r\n Thb.Photo.OnInvalidImage := DoInvalidImage;\r\n Thb.OnDblClick := OnDblClick;\r\n Thb.Photo.OnDblClick := OnDblClick;\r\n Thb.MinimizeMemory := MinMemory;\r\n Thb.Color := Self.Color;\r\n Thb.Title := ATitle;\r\n if FThumbColor = clNone then\r\n begin\r\n Thb.Color := Self.Color;\r\n Thb.ParentColor := True;\r\n Thb.TitleColor := Self.Color;\r\n end\r\n else\r\n Thb.Color := FThumbColor;\r\n FThumbList.AddObject(Thb.Title, Thb);\r\n Thb.Parent := Self;\r\n if Redraw then\r\n begin\r\n CalculateSize;\r\n Reposition(0);\r\n end;\r\nend;\r\n\r\nprocedure TJvThumbView.GetFiles(ADirectory: string);\r\nvar\r\n SearchRec: TSearchRec;\r\n FResult: Integer;\r\n NumExtensions: Integer;\r\n\r\n function FindFirstGraphic(AExtension: string): Integer;\r\n begin\r\n // (rom) strange flag faArchive\r\n FindFirstGraphic :=\r\n FindFirst(ADirectory + AExtension, faArchive, SearchRec);\r\n end;\r\n\r\nbegin\r\n FFileList.Clear;\r\n FFileListSorted.Clear;\r\n SetFilters;\r\n if not DirectoryExists(ADirectory) then\r\n Exit;\r\n if ADirectory[Length(ADirectory)] <> PathDelim then\r\n ADirectory := ADirectory + PathDelim;\r\n for NumExtensions := 0 to FGraphicExtensions.Count - 1 do\r\n begin\r\n if (FindFirstGraphic(FGraphicExtensions[NumExtensions]) = 0) then\r\n begin\r\n try\r\n if (FFileList.IndexOf(ADirectory + SearchRec.Name) < 0) then\r\n begin\r\n FFileList.Add(ADirectory + SearchRec.Name);\r\n FFileListSorted.Add(ADirectory + SearchRec.Name);\r\n repeat\r\n FResult := FindNext(SearchRec);\r\n if (FResult = 0) and (FFileList.IndexOf(ADirectory + SearchRec.Name) < 0) then\r\n begin\r\n FFileList.Add(ADirectory + SearchRec.Name);\r\n FFileListSorted.Add(ADirectory + SearchRec.Name);\r\n end;\r\n until FResult <> 0;\r\n end;\r\n finally\r\n FindClose(SearchRec);\r\n end;\r\n end;\r\n end;\r\n FFileListSorted.Sort;\r\n if Assigned(FGraphicExtensions) then\r\n FreeAndNil(FGraphicExtensions);\r\nend;\r\n\r\nprocedure TJvThumbView.SetAlignView(AType: TViewType);\r\nbegin\r\n if AType <> FAlignView then\r\n begin\r\n FAlignView := AType;\r\n Reposition(0);\r\n end;\r\nend;\r\n\r\nprocedure TJvThumbView.ScrollTo(const Number: Longint);\r\nvar\r\n TN: TJvThumbnail;\r\nbegin\r\n// if AutoScrolling then\r\n if (Number < 0) or (Number >= FThumbList.Count) then\r\n Exit;\r\n TN := TJvThumbnail(FThumbList.Objects[Number]);\r\n case ScrollMode of\r\n smVertical:\r\n begin\r\n if TN.Top < 0 then\r\n VertScrollBar.Position := VertScrollBar.Position +\r\n (TN.Top - (TN.Width div 2));\r\n if TN.Top + TN.Height > Height then\r\n VertScrollBar.Position := VertScrollBar.Position +\r\n (TN.Top - (Height - TN.Height - (TN.Height div 2)));\r\n end;\r\n smHorizontal:\r\n begin\r\n if TN.Left < 0 then\r\n HorzScrollBar.Position := HorzScrollBar.Position +\r\n (TN.Left - (TN.Width div 2));\r\n if TN.Left + TN.Width > Width then\r\n HorzScrollBar.Position := HorzScrollBar.Position +\r\n (TN.Left - (Width - TN.Width - (TN.Width div 2)));\r\n end;\r\n smBoth:\r\n begin\r\n if TN.Top < 0 then\r\n VertScrollBar.Position := VertScrollBar.Position +\r\n (TN.Top - (TN.Width div 2));\r\n if TN.Top + TN.Height > Height then\r\n VertScrollBar.Position := VertScrollBar.Position +\r\n (TN.Top - (TN.Height - (TN.Height div 2)));\r\n if TN.Left < 0 then\r\n HorzScrollBar.Position := HorzScrollBar.Position +\r\n (TN.Left - (TN.Width div 2));\r\n if TN.Left + TN.Width > Width then\r\n HorzScrollBar.Position := HorzScrollBar.Position +\r\n (TN.Left - (Width - TN.Width - (TN.Width div 2)));\r\n end;\r\n end;\r\n if FSelected <> Number then\r\n begin\r\n FSelected := Number;\r\n if Assigned(OnClick) then\r\n OnClick(Self);\r\n end;\r\nend;\r\n\r\n(*\r\nfunction TJvThumbView.GetBufferName(AName: string): string;\r\nvar\r\n tst: string;\r\n FN: string;\r\n Res: string;\r\nbegin\r\n tst := completepath(extractFiledir(AName));\r\n if tst = AName then\r\n begin // No FileName included only A Directory;\r\n // the user wants us to Create A seperate file for each\r\n // Directory it opens in A pre-specified path\r\n FN := ReplaceChar(FDirectory, '\\', '_', 0, False); //Create the FileName from the path\r\n FN := ReplaceChar(FN, ':', '_', 0, False); //Create the FileName from the path\r\n Res := AName + fn;\r\n end\r\n else\r\n begin // the user has specified either A full path and A name or just A name\r\n if tst = '' then\r\n // the user has specified only A name to use\r\n // in each Directory that is opened by the component there will be created\r\n // A file with name where the thumbs are been saved;\r\n Res := CompletePath(FDirectory) + AName\r\n else\r\n // the user has specified A full path and A file name weach is the same\r\n // for all the directories he/she opens.\r\n Res := AName;\r\n end;\r\n Result := Res;\r\nend;\r\n*)\r\n\r\n//Procedure TJvThumbView.SetBufferFile(NewName: string);\r\n//var\r\n// tst: string;\r\n//begin\r\n// If NewName <> FBufferFile then\r\n// tst := GetBufferName(NewName);\r\n// End;\r\n//end;\r\n\r\nprocedure TJvThumbView.SetSelected(Number: Longint);\r\nvar\r\n TN: TJvThumbnail;\r\nbegin\r\n if (Number < 0) or (Number >= FThumbList.Count) then\r\n Number := -1;\r\n\r\n if FThumbList.Count > 0 then\r\n begin\r\n if FSelected <> -1 then\r\n begin\r\n TN := TJvThumbnail(FThumbList.Objects[FSelected]);\r\n TN.TitleColor := TN.Color;\r\n TN.TitleFont.Color := TN.Font.Color;\r\n end;\r\n if Number <> -1 then\r\n begin\r\n TN := TJvThumbnail(FThumbList.Objects[Number]);\r\n TN.TitleColor := clHighlight;\r\n TN.TitleFont.Color := clHighlightText;\r\n if AutoScrolling then\r\n begin\r\n if (TN.Top + TN.Height > Height) or (TN.Top < 0) then\r\n ScrollTo(Number);\r\n if (TN.Left + TN.Width > Width) or (TN.Left < 0) then\r\n ScrollTo(Number);\r\n end\r\n end;\r\n if FSelected <> Number then\r\n begin\r\n if Assigned(FOnChanging) then\r\n FOnChanging(Self);\r\n\r\n FSelected := Number;\r\n\r\n if Assigned(FOnChange) then\r\n FOnChange(Self);\r\n end;\r\n end\r\n else\r\n FSelected := -1;\r\nend;\r\n\r\nfunction TJvThumbView.GetSelectedFile;\r\nbegin\r\n if Selected <> -1 then\r\n Result := TJvThumbnail(FThumbList.Objects[Selected]).FileName;\r\nend;\r\n\r\nprocedure TJvThumbView.SetSelectedFile(AFile: string);\r\nvar\r\n I: Longint;\r\n Dir: string;\r\nbegin\r\n Dir := ExtractFileDir(AFile);\r\n if Dir[Length(Dir)] = PathDelim then\r\n Dir := Copy(Dir, 0, Length(Dir) - 1);\r\n Directory := Dir;\r\n for I := 0 to FThumbList.Count - 1 do\r\n if TJvThumbnail(FThumbList.Objects[I]).FileName = AFile then\r\n begin\r\n Selected := I;\r\n if not FAutoScrolling then\r\n ScrollTo(I);\r\n Exit;\r\n end;\r\nend;\r\n\r\nprocedure TJvThumbView.SetDirectory(Value: string);\r\nvar\r\n Counter1, FStartTime: DWORD;\r\n Cancel: Boolean;\r\n ReadFileList: TStringList;\r\n OldCursor: TCursor;\r\n// Pic: TPicture;\r\nbegin\r\n FSelected := -1;\r\n // if not FPainted then\r\n // begin\r\n // postMessage(Self.Handle, WM_LOADWHENREADY, 0, 0);\r\n // Exit;\r\n // end;\r\n FDiskSize := 0;\r\n if FFilling then\r\n Exit;\r\n if Value <> '' then\r\n begin\r\n ReadFileList := TStringList.Create;\r\n OldCursor := Cursor;\r\n try\r\n FFilling := True;\r\n // if Assigned(ReadFileList) then FreeAndNil(ReadFileList);\r\n FStartTime := GetTickCount;\r\n GetFiles(Value);\r\n if FSorted then\r\n ReadFileList.Assign(FFileListSorted)\r\n else\r\n ReadFileList.Assign(FFileList);\r\n EmptyList;\r\n FDirectory := Value;\r\n if Assigned(FOnStartScanning) then\r\n FOnStartScanning(Self, ReadFileList.Count - 1);\r\n if ReadFileList.Count > 0 then\r\n begin\r\n Cancel := False;\r\n for Counter1 := 0 to ReadFileList.Count - 1 do\r\n begin\r\n if Assigned(FOnScanProgress) then\r\n FOnScanProgress(Self, Counter1 + 1, Cancel);\r\n if Cancel then\r\n Break;\r\n AddThumb(ExtractFilename(ReadFileList.Strings[Counter1]), True);\r\n TJvThumbnail(FThumbList.Objects[Counter1]).FileName := ReadFileList.Strings[Counter1];\r\n Inc(FDiskSize, TJvThumbnail(FThumbList.Objects[Counter1]).FileSize);\r\n if (Cursor <> crHourGlass) and (GetTickCount - FStartTime > 1000) then\r\n Cursor := crHourGlass;\r\n end;\r\n end;\r\n if Assigned(FOnStopScanning) then\r\n FOnStopScanning(Self);\r\n finally\r\n FreeAndNil(ReadFileList);\r\n FFilling := False;\r\n Cursor := OldCursor;\r\n end\r\n end\r\n else\r\n EmptyList;\r\n FDirectory := Value;\r\n if (FThumbList.Count > 0) and (Selected < 0) then\r\n SetSelected(0);\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvThumbView.Reposition(Start: Integer);\r\nvar\r\n I: Integer;\r\n Tmp1: Longint;\r\n Tmp2: Longint;\r\n TN: TJvThumbnail;\r\nbegin\r\n Tmp2 := HorzScrollBar.Position;\r\n HorzScrollBar.Position := 0;\r\n Tmp1 := VertScrollBar.Position;\r\n VertScrollBar.Position := 0;\r\n for I := Start to FThumbList.Count - 1 do\r\n begin\r\n TN := TJvThumbnail(FThumbList.Objects[I]);\r\n if TN <> nil then\r\n begin\r\n TN.Left := CalculateXPos(I + 1);\r\n TN.Top := CalculateYPos(I + 1);\r\n TN.Width := FThumbSize.X;\r\n TN.Height := FThumbSize.Y;\r\n end;\r\n end;\r\n HorzScrollBar.Position := Tmp2;\r\n VertScrollBar.Position := Tmp1;\r\nend;\r\n\r\nprocedure TJvThumbView.CalculateMaxX;\r\nvar\r\n A: Longint;\r\nbegin\r\n case FScrollMode of\r\n smVertical:\r\n A := (Width - 20) div (FThumbSize.X + FThumbGap);\r\n smHorizontal:\r\n A := (Height - 20) div (FThumbSize.Y + FThumbGap);\r\n smBoth:\r\n A := JkCeil(Sqrt(FThumbList.Count));\r\n else\r\n A := 1;\r\n end;\r\n if A < 1 then\r\n A := 1;\r\n if A <> FMaxX then\r\n FMaxX := A;\r\nend;\r\n\r\nprocedure TJvThumbView.CalculateSize;\r\nbegin\r\n FThumbSize.X := Trunc((MaxWidth / 100.0) * Size);\r\n FThumbSize.Y := Trunc((MaxHeight / 100.0) * Size);\r\n CalculateMaxX;\r\nend;\r\n\r\nfunction TJvThumbView.CalculateXPos(Num: Word): Longint;\r\nvar\r\n VPos, HPos: Longint;\r\n Temp: Longint;\r\n Tmp: Longint;\r\n Spact: Longint;\r\nbegin\r\n if Num > 0 then\r\n begin\r\n Spact := FThumbGap;\r\n case FScrollMode of\r\n smVertical, smBoth:\r\n begin\r\n if (FAlignView = vtFitToScreen) and (FScrollMode = smVertical) then\r\n Spact := ((Width - 20) - (FThumbSize.X * FMaxX)) div (FMaxX + 1);\r\n VPos := JkCeil(Num / FMaxX);\r\n HPos := (Num - (VPos * FMaxX)) + FMaxX;\r\n Temp := (FThumbSize.X * (HPos - 1)) + (HPos * Spact);\r\n if (FAlignView = vtCenter) and (FScrollMode = smVertical) then\r\n begin\r\n Tmp := ((Width - 20) div 2) - (((FThumbSize.X + FThumbGap) * FMaxX) div 2);\r\n Temp := Temp + Tmp;\r\n end;\r\n end;\r\n smHorizontal:\r\n begin\r\n VPos := JkCeil(Num / FMaxX);\r\n Temp := (FThumbSize.Y * (VPos - 1)) + (VPos * Spact);\r\n end\r\n else\r\n Temp := 0\r\n end;\r\n end\r\n else\r\n Temp := 0;\r\n Result := Temp;\r\nend;\r\n\r\nfunction TJvThumbView.CalculateYPos(Num: Word): Longint;\r\nvar\r\n VPos, HPos: Longint;\r\n Temp: Longint;\r\n Tmp: Longint;\r\n Spact: Longint;\r\nbegin\r\n if Num > 0 then\r\n begin\r\n Spact := FThumbGap;\r\n case FScrollMode of\r\n smVertical, smBoth:\r\n begin\r\n VPos := JkCeil(Num / FMaxX);\r\n Temp := (FThumbSize.Y * (VPos - 1)) + (VPos * Spact);\r\n end;\r\n smHorizontal:\r\n begin\r\n if FAlignView = vtFitToScreen then\r\n Spact := ((Height - 20) - ((FThumbSize.Y + FThumbGap) * FMaxX)) div (FMaxX + 1);\r\n HPos := JkCeil(Num / FMaxX);\r\n VPos := (Num - (HPos * FMaxX)) + FMaxX;\r\n Temp := (FThumbSize.X * (VPos - 1)) + (VPos * Spact);\r\n if FAlignView = vtCenter then\r\n begin\r\n Tmp := ((Height - 20) div 2) - ((FThumbSize.Y * FMaxX) div 2);\r\n Temp := Temp + Tmp;\r\n end;\r\n end;\r\n else\r\n Temp := 0;\r\n end;\r\n end\r\n else\r\n Temp := 0;\r\n Result := Temp;\r\nend;\r\n\r\nprocedure TJvThumbView.MouseDown(Button: TMouseButton; Shift: TShiftState;\r\n X, Y: Integer);\r\nvar\r\n No: Word;\r\n TempX, TempY: Longint;\r\nbegin\r\n // Check to see if there are any problems removing the following\r\n // For sure it solves A focus problem I'm having in an application\r\n // setfocus;\r\n if Count > 0 then\r\n case ScrollMode of\r\n smVertical, smBoth:\r\n begin\r\n TempX := JkCeil((X + HorzScrollBar.Position) / (FThumbSize.X + FThumbGap));\r\n TempY := JkCeil((Y + VertScrollBar.Position) / (FThumbSize.Y + FThumbGap));\r\n if TempX > FMaxX then\r\n TempX := FMaxX;\r\n if TempY < 1 then\r\n TempY := 1;\r\n No := ((TempY - 1) * FMaxX + TempX) - 1;\r\n if No < Count then\r\n if TJvThumbnail(FThumbList.Objects[No]) <> nil then\r\n if (X > TJvThumbnail(FThumbList.Objects[No]).Left) and\r\n (X < TJvThumbnail(FThumbList.Objects[No]).Left +\r\n TJvThumbnail(FThumbList.Objects[No]).Width) and\r\n (Y > TJvThumbnail(FThumbList.Objects[No]).Top) and\r\n (Y < TJvThumbnail(FThumbList.Objects[No]).Top +\r\n TJvThumbnail(FThumbList.Objects[No]).Height) then\r\n SetSelected(No)\r\n else\r\n SetSelected(-1)\r\n else\r\n SetSelected(-1)\r\n else\r\n SetSelected(-1);\r\n end;\r\n smHorizontal:\r\n begin\r\n TempX := JkCeil((X + HorzScrollBar.Position) / (FThumbSize.X + FThumbGap));\r\n TempY := JkCeil((Y + VertScrollBar.Position) / (FThumbSize.Y + FThumbGap));\r\n if TempY > FMaxX then\r\n TempY := FMaxX;\r\n if TempX < 1 then\r\n TempX := 1;\r\n No := ((TempX - 1) * FMaxX + TempY) - 1;\r\n if No < Count then\r\n if TJvThumbnail(FThumbList.Objects[No]) <> nil then\r\n if (X > TJvThumbnail(FThumbList.Objects[No]).Left) and\r\n (X < TJvThumbnail(FThumbList.Objects[No]).Left +\r\n TJvThumbnail(FThumbList.Objects[No]).Width) and\r\n (Y > TJvThumbnail(FThumbList.Objects[No]).Top) and\r\n (Y < TJvThumbnail(FThumbList.Objects[No]).Top +\r\n TJvThumbnail(FThumbList.Objects[No]).Height) then\r\n SetSelected(No)\r\n else\r\n SetSelected(-1)\r\n else\r\n SetSelected(-1)\r\n else\r\n SetSelected(-1);\r\n end;\r\n else\r\n SetSelected(-1);\r\n end;\r\n inherited MouseDown(Button, Shift, X, Y);\r\nend;\r\n\r\nprocedure TJvThumbView.AddFromStream(AStream: TStream; AType: TGRFKind);\r\nbegin\r\n AddFromStream(AStream, AType, '');\r\nend;\r\n\r\nfunction TJvThumbView.AddFromStream(AStream: TStream; AType: TGRFKind; const aTitle: string): Integer;\r\nvar\r\n Thb: TJvThumbnail;\r\nbegin\r\n Thb := TJvThumbnail.Create(Self);\r\n Thb.StreamFileType := AType;\r\n Thb.Left := CalculateXPos(Count + 1);\r\n Thb.Top := CalculateYPos(Count + 1);\r\n Thb.Width := FThumbSize.X;\r\n Thb.Height := FThumbSize.Y;\r\n Thb.OnClick := OnClick;\r\n Thb.Photo.OnClick := OnClick;\r\n Thb.OnDblClick := OnDblClick;\r\n Thb.Title := aTitle;\r\n Thb.Photo.OnDblClick := OnDblClick;\r\n // Thb.Buffer := Vbuffer;\r\n Thb.Photo.LoadFromStream(AStream, Thb.StreamFileType);\r\n Result := FThumbList.AddObject(Thb.Title, Thb);\r\n InsertControl(Thb);\r\n CalculateSize;\r\n Reposition(Result);\r\nend;\r\n\r\nfunction TJvThumbView.AddFromFile(AFile: string) : Integer;\r\nvar\r\n ThumbnailTitle: string;\r\n FFont: TFont;\r\n FColor: TColor;\r\n Thb: TJvThumbnail;\r\nbegin\r\n Thb := TJvThumbnail.Create(Self);\r\n if Assigned(FOnGetTitle) then\r\n begin\r\n ThumbnailTitle := ExtractFilename(AFile);\r\n FFont := TFont.Create;\r\n FColor := clBtnFace;\r\n if Assigned(FOnGetTitle) then\r\n FOnGetTitle(Self, AFile, ThumbnailTitle, FFont, FColor);\r\n Thb.SetTitlePanel(ThumbnailTitle, FFont, FColor);\r\n FreeAndNil(FFont);\r\n end;\r\n Thb.OnClick := OnClick;\r\n Thb.Photo.OnClick := OnClick;\r\n Thb.OnDblClick := OnDblClick;\r\n Thb.Photo.OnDblClick := OnDblClick;\r\n Thb.MinimizeMemory := MinMemory;\r\n // Thb.Buffer := VBuffer;\r\n FThumbList.AddObject(AFile, Thb);\r\n InsertControl(Thb);\r\n CalculateSize;\r\n Reposition(0);\r\n TJvThumbnail(FThumbList.Objects[FThumbList.IndexOf(AFile)]).FileName := AFile;\r\n result := FThumbList.IndexOf(AFile);\r\nend;\r\n\r\nprocedure TJvThumbView.Delete(No: Longint);\r\nvar\r\n Dummy: Longint;\r\nbegin\r\n if No >= FThumbList.Count then\r\n begin\r\n end //Raise an exception\r\n else\r\n begin\r\n Dummy := FFileList.IndexOf(SelectedFile);\r\n if Dummy >= 0 then\r\n FFileList.Delete(Dummy);\r\n Dummy := FFileListSorted.IndexOf(SelectedFile);\r\n if Dummy >= 0 then\r\n FFileListSorted.Delete(Dummy);\r\n TJvThumbnail(FThumbList.Objects[No]).Free;\r\n FThumbList.Delete(No);\r\n FSelected := -1;\r\n //CalculateSize;\r\n Dec(No, 1);\r\n if No < 0 then\r\n No := 0;\r\n Reposition(No);\r\n Refresh;\r\n Repaint;\r\n end\r\nend;\r\n\r\nprocedure TJvThumbView.SetThumbGap(Sp: Byte);\r\nbegin\r\n case FAlignView of\r\n vtNormal, vtCenter:\r\n begin\r\n FThumbGap := Sp;\r\n CalculateMaxX;\r\n Reposition(0);\r\n end;\r\n vtFitToScreen:\r\n FThumbGap := Sp;\r\n end;\r\nend;\r\n\r\nfunction TJvThumbView.GetCount: Word;\r\nbegin\r\n Result := FThumbList.Count;\r\nend;\r\n\r\nprocedure TJvThumbView.SortList;\r\nbegin\r\n // add code to resort the list\r\n FThumbList.Sort;\r\n CalculateSize;\r\n Reposition(0);\r\nend;\r\n\r\nprocedure TJvThumbView.Refresh;\r\nvar\r\n I: Longint;\r\nbegin\r\n CalculateSize;\r\n Reposition(0);\r\n for I := 0 to FThumbList.Count - 1 do\r\n FThumbList.Thumbnail[I].Refresh;\r\n inherited Refresh;\r\nend;\r\n\r\nprocedure TJvThumbView.EmptyList;\r\nvar\r\n Metr: Integer;\r\nbegin\r\n for Metr := Count - 1 downto 0 do\r\n if FThumbList.Objects[Metr] <> nil then\r\n begin\r\n TJvThumbnail(FThumbList.Objects[Metr]).Parent := nil;\r\n TJvThumbnail(FThumbList.Objects[Metr]).Free;\r\n FThumbList.Delete(Metr);\r\n end;\r\n FSelected := -1; // Mantis #5140\r\nend;\r\n\r\nprocedure TJvThumbView.SetMaxWidth(W: Longint);\r\nbegin\r\n FMaxSize.X := W;\r\n CalculateSize;\r\n Reposition(0);\r\nend;\r\n\r\nprocedure TJvThumbView.SetMaxHeight(H: Longint);\r\nbegin\r\n // if FMaxSize.Y AMode then\r\n begin\r\n FScrollMode := AMode;\r\n CalculateSize;\r\n Reposition(0);\r\n if Selected > -1 then\r\n ScrollTo(Selected);\r\n end\r\nend;\r\n\r\nprocedure TJvThumbView.KeyUp(var Key: Word; Shift: TShiftState);\r\nbegin\r\n if Assigned(FOnKeyUp) then\r\n FOnKeyUp(Self, Key, Shift);\r\n inherited KeyUp(Key, Shift);\r\nend;\r\n\r\nprocedure TJvThumbView.KeyDown(var Key: Word; Shift: TShiftState);\r\nbegin\r\n if AutoHandleKeyb and (FThumbList.Count > 0) then\r\n case Key of\r\n VK_RIGHT:\r\n begin\r\n GoRight;\r\n ScrollTo(Selected);\r\n end;\r\n VK_DOWN:\r\n begin\r\n GoDown;\r\n ScrollTo(Selected);\r\n end;\r\n VK_LEFT:\r\n begin\r\n GoLeft;\r\n ScrollTo(Selected);\r\n end;\r\n VK_UP:\r\n begin\r\n GoUp;\r\n ScrollTo(Selected);\r\n end;\r\n VK_DELETE:\r\n begin\r\n end;\r\n VK_PRIOR:\r\n begin\r\n end;\r\n VK_NEXT:\r\n begin\r\n end;\r\n VK_END:\r\n begin\r\n Selected := Count - 1;\r\n ScrollTo(Selected);\r\n end;\r\n VK_HOME:\r\n begin\r\n Selected := 0;\r\n ScrollTo(Selected);\r\n end;\r\n end;\r\n inherited KeyDown(Key, Shift);\r\nend;\r\n\r\nprocedure TJvThumbView.KeyPress(var Key: Char);\r\nbegin\r\n if Assigned(FOnKeyPress) then\r\n FOnKeyPress(Self, Key);\r\n inherited KeyPress(Key);\r\nend;\r\n\r\nprocedure TJvThumbView.SetSorted(const Value: Boolean);\r\nbegin\r\n if Value <> FSorted then\r\n begin\r\n FSorted := Value;\r\n if not FPainted then\r\n Exit;\r\n FThumbList.Sorted := FSorted;\r\n SetDirectory(FDirectory); // force reread\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvThumbView.GetDlgCode(var Code: TDlgCodes);\r\nbegin\r\n Code := [dcWantArrows, dcWantAllKeys];\r\nend;\r\n\r\nprocedure TJvThumbView.GoRight;\r\nvar\r\n Actual: Longint;\r\nbegin\r\n Actual := 0;\r\n if ScrollMode = smHorizontal then\r\n Actual := Selected + FMaxX;\r\n if (ScrollMode = smVertical) or (ScrollMode = smBoth) then\r\n Actual := Selected + 1;\r\n if (Actual > Count - 1) or (Actual < 0) then\r\n Actual := Selected;\r\n Selected := Actual;\r\nend;\r\n\r\nprocedure TJvThumbView.GoLeft;\r\nvar\r\n Actual: Longint;\r\nbegin\r\n Actual := 0;\r\n if ScrollMode = smHorizontal then\r\n Actual := Selected - FMaxX;\r\n if (ScrollMode = smVertical) or (ScrollMode = smBoth) then\r\n Actual := Selected - 1;\r\n if (Actual > Count - 1) or (Actual < 0) then\r\n Actual := Selected;\r\n Selected := Actual;\r\nend;\r\n\r\nprocedure TJvThumbView.GoDown;\r\nvar\r\n Actual: Longint;\r\nbegin\r\n Actual := 0;\r\n if ScrollMode = smHorizontal then\r\n Actual := Selected + 1;\r\n if (ScrollMode = smVertical) or (ScrollMode = smBoth) then\r\n Actual := Selected + FMaxX;\r\n if (Actual > Count - 1) or (Actual < 0) then\r\n Actual := Selected;\r\n Selected := Actual;\r\nend;\r\n\r\nprocedure TJvThumbView.GoUp;\r\nvar\r\n Actual: Longint;\r\nbegin\r\n Actual := 0;\r\n if ScrollMode = smHorizontal then\r\n Actual := Selected - 1;\r\n if (ScrollMode = smVertical) or (ScrollMode = smBoth) then\r\n Actual := Selected - FMaxX;\r\n if (Actual > Count - 1) or (Actual < 0) then\r\n Actual := Selected;\r\n Selected := Actual;\r\nend;\r\n\r\nprocedure TJvThumbView.SetAsButton(const NewVal: Boolean);\r\nvar\r\n I: Longint;\r\nbegin\r\n if NewVal <> FAsButtons then\r\n begin\r\n for I := 0 to FThumbList.Count - 1 do\r\n FThumbList.Thumbnail[I].AsButton := NewVal;\r\n FAsButtons := NewVal;\r\n end;\r\nend;\r\n\r\nprocedure TJvThumbView.SetTitlePos(const NewVal: TTitlePos);\r\nvar\r\n I: Longint;\r\nbegin\r\n if NewVal <> FTitlePlacement then\r\n begin\r\n for I := 0 to FThumbList.Count - 1 do\r\n FThumbList.Thumbnail[I].TitlePlacement := NewVal;\r\n FTitlePlacement := NewVal;\r\n end;\r\nend;\r\n\r\nfunction TJvThumbView.CreateFilter: string;\r\n//var\r\n// Res: string;\r\n// Pos: Longint;\r\nbegin\r\n Result := GraphicFilter(TGraphic);\r\nend;\r\n\r\nprocedure TJvThumbView.SetFilters;\r\nvar\r\n Cp1 {, CP2}: Integer; // CurrentPosition;\r\n// Md: Byte; // Mode\r\n Res: string;\r\n// Sub: string;\r\n Final: string;\r\nbegin\r\n if not Assigned(FGraphicExtensions) then\r\n FGraphicExtensions := TStringList.Create;\r\n// Cp1 := 0;\r\n// CP2 := 0;\r\n Res := FFilter;\r\n Final := '';\r\n repeat\r\n Cp1 := Pos('|', Res);\r\n if Cp1 > 0 then\r\n begin\r\n System.Delete(Res, 1, Cp1);\r\n Cp1 := Pos('|', Res);\r\n if Cp1 > 0 then\r\n begin\r\n Final := Final + ';' + Copy(Res, 1, Cp1 - 1);\r\n System.Delete(Res, 1, Cp1);\r\n end\r\n else\r\n Final := Final + ';' + Res;\r\n end\r\n else\r\n Final := Final + ';' + Res;\r\n until Cp1 = 0;\r\n Final := ReplaceAllstr(Final, ';', sLineBreak, False);\r\n FGraphicExtensions.Text := Final;\r\n\r\n Cp1 := 0;\r\n repeat\r\n if FGraphicExtensions[Cp1] = '' then\r\n FGraphicExtensions.Delete(Cp1)\r\n else\r\n Inc(Cp1);\r\n until Cp1 = FGraphicExtensions.Count;\r\nend;\r\n\r\nfunction TJvThumbList.GetThumbnail(Index: Longint): TJvThumbnail;\r\nbegin\r\n Result := TJvThumbnail(Objects[Index]);\r\nend;\r\n\r\nfunction TJvThumbView.GetMaxHeight: Longint;\r\nbegin\r\n Result := FMaxSize.Y;\r\nend;\r\n\r\nfunction TJvThumbView.GetMaxWidth: Longint;\r\nbegin\r\n Result := FMaxSize.X;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvThumbnails.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvThumbNail.PAS, released on 2002-07-03.\r\n\r\nThe Initial Developer of the Original Code is John Kozikopulos [Stdreamer att Excite dott com]\r\nPortions created by John Kozikopulos are Copyright (C) 2002 John Kozikopulos.\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nDescription:\r\n Thumbimage, ThumbNail components\r\n Thumbimage is a TImage descentant wich passes the control of the mouse events\r\n to the ThumbNail and have the ability to change an images look by changing\r\n the rgb values with the changergb,changergbcurve procedures.\r\n You can have precise control over the images look.\r\n The changergb procedure just adds the values you pass to its rgb variables to\r\n the actual values of the image.\r\n The Changergbcurves procedure just replaces the value of the rgb values\r\n accordingly with the values that passed in the the arrays.\r\n e.g.\r\n the r array in the position 15 has a value of 35 this meens that wherever in\r\n the Picture there is a pixels which has a red value equall to 15 it will be ]\r\n replaced with the value 35.\r\n\r\n ThumbNail is what the name says a component to simply shrink an image\r\n proportionally to fit in a portion of the screen with some extra mouse handling\r\n to Create a Button like effect. Just give it a FileName and it will do the work\r\n for you.\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvThumbnails.pas 13104 2011-09-07 06:50:43Z obones $\r\n\r\nunit JvThumbnails;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Classes, Controls, ExtCtrls, SysUtils, Messages, Graphics, Windows, Forms,\r\n JvThumbImage, JvBaseThumbnail, Dialogs;\r\n\r\nconst\r\n TH_IMAGESIZECHANGED = WM_USER + 1;\r\n\r\ntype\r\n // (rom) elements renamed\r\n TTitlePos = (tpUp, tpDown, tpNone);\r\n\r\n TTitleNotify = procedure(Sender: TObject; FileName: string;\r\n var ThumbnailTitle: string) of object;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvThumbnail = class(TJvBaseThumbnail)\r\n private\r\n FTitle: string;\r\n FTitlePanel: TJvThumbTitle;\r\n FTitleColor: TColor;\r\n FTitleFont: TFont;\r\n FStreamFileKind: TGRFKind;\r\n FDFileCreated: string;\r\n FDFileChanged: string;\r\n FDFileAccessed: string;\r\n FShowTitle: Boolean;\r\n FDFileSize: Longint;\r\n FStream: TStream;\r\n FImageWidth: Longint;\r\n FImageHeight: Longint;\r\n FClientHeight: Word;\r\n FClientWidth: Word;\r\n FShadowObj: TShape;\r\n FUpdated: Boolean;\r\n FImageReady: Boolean;\r\n FTitlePlacement: TTitlePos;\r\n FPhotoName: TFileName;\r\n FPhoto: TJvThumbImage;\r\n FOnGetTitle: TTitleNotify;\r\n FMousePressed: Boolean;\r\n FDestroying: Boolean;\r\n FAsButton: Boolean;\r\n FMinimizeMemory: Boolean;\r\n FAutoLoad: Boolean; // if True then load the image either from a thumb file or Create it from the FileName\r\n FShadowColor: TColor;\r\n FShowShadow: Boolean;\r\n FHShadowOffset: Word;\r\n FVShadowOffset: Word;\r\n procedure WMPaint(var Msg: TWMPaint); message WM_PAINT;\r\n procedure PhotoOnProgress(Sender: TObject; Stage: TProgressStage;\r\n PercentDone: Byte; RedrawNow: Boolean;\r\n const R: TRect; const Msg: string);\r\n procedure RefreshFont(Sender: TObject);\r\n procedure SetFileName(const AFile: string);\r\n function LoadFile(AFile: string): string;\r\n function GetFileName: string;\r\n procedure CalculateImageSize; virtual;\r\n procedure SetClientWidth(AWidth: Word);\r\n procedure SetDummyStr(AStr: string);\r\n procedure SetMinimizeMemory(Min: Boolean);\r\n procedure SetDummyCard(AInt: Longint);\r\n procedure SetClientHeight(AHeight: Word);\r\n procedure SetShowTitle(const AState: Boolean);\r\n procedure SetTitlePlacement(const AState: TTitlePos);\r\n procedure SetTitle(const Value: string);\r\n procedure SetTitleColor(const Value: TColor);\r\n procedure SetStream(const AStream: TStream);\r\n procedure SetTitleFont(const Value: TFont);\r\n procedure GetFileInfo(AName: string);\r\n procedure SetShowShadow(Show: Boolean);\r\n// procedure SetShadowColor(aColor: TColor);\r\n protected\r\n procedure THSizeChanged(var Msg: TMessage); message TH_IMAGESIZECHANGED;\r\n procedure MouseDown(Button: TMouseButton; Shift: TShiftState;\r\n X, Y: Integer); override;\r\n procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;\r\n procedure MouseUp(Button: TMouseButton; Shift: TShiftState;\r\n X, Y: Integer); override;\r\n procedure BoundsChanged; override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n procedure SetTitlePanel(ATitle: string; AFont: TFont; AColor: TColor);\r\n procedure Refresh;\r\n property Stream: TStream read FStream write SetStream;\r\n property Photo: TJvThumbImage read FPhoto write FPhoto;\r\n published\r\n property FileName: string read GetFileName write SetFileName;\r\n property Title: string read FTitle write SetTitle;\r\n property TitleColor: TColor read FTitleColor write SetTitleColor;\r\n property TitleFont: TFont read FTitleFont write SetTitleFont;\r\n property ImageReady: Boolean read FImageReady;\r\n property OnGetTitle: TTitleNotify read FOnGetTitle write FOnGetTitle;\r\n property ClientWidth: Word read FClientWidth write SetClientWidth;\r\n property ClientHeight: Word read FClientHeight write SetClientHeight;\r\n { Do not store dummies }\r\n property FileSize: Longint read FDFileSize write SetDummyCard stored False;\r\n property FileAccessed: string read FDFileAccessed write SetDummyStr stored False;\r\n property FileCreated: string read FDFileCreated write SetDummyStr stored False;\r\n property FileChanged: string read FDFileChanged write SetDummyStr stored False;\r\n property ImageWidth: Longint read FImageWidth default 0;\r\n property ImageHeight: Longint read FImageHeight default 0;\r\n property AsButton: Boolean read FAsButton write FAsButton;\r\n property MinimizeMemory: Boolean read FMinimizeMemory write SetMinimizeMemory;\r\n property StreamFileType: TGRFKind read FStreamFileKind write FStreamFileKind;\r\n property ShowTitle: Boolean read FShowTitle write SetShowTitle;\r\n property TitlePlacement: TTitlePos read FTitlePlacement write SetTitlePlacement;\r\n property AutoLoad: Boolean read FAutoLoad write FAutoLoad;\r\n property ShadowColor: TColor read FShadowColor write FShadowColor;\r\n property ShowShadow: Boolean read FShowShadow write SetShowShadow;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvThumbnails.pas $';\r\n Revision: '$Revision: 13104 $';\r\n Date: '$Date: 2011-09-07 08:50:43 +0200 (mer. 07 sept. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n jpeg,\r\n JvThumbViews, JvResources;\r\n\r\nconstructor TJvThumbnail.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FPhotoName := TFileName.Create;\r\n FHShadowOffset := 3;\r\n FVShadowOffset := 3;\r\n FShowShadow := False;\r\n FShadowColor := clSilver;\r\n FShadowObj := TShape.Create(Self);\r\n FShadowObj.Visible := FShowShadow;\r\n FShadowObj.Brush.Color := FShadowColor;\r\n FShadowObj.Parent := Self;\r\n FShadowObj.Pen.Style := psClear;\r\n Photo := TJvThumbImage.Create(Self);\r\n Photo.AutoSize := False;\r\n Photo.Align := alNone;\r\n Photo.Stretch := True;\r\n Photo.OnProgress := PhotoOnProgress;\r\n\r\n FShadowObj.Width := Photo.Width;\r\n FShadowObj.Height := Photo.Height;\r\n FShadowObj.Left := Photo.Left + FHShadowOffset;\r\n FShadowObj.Top := Photo.Top + FVShadowOffset;\r\n FTitlePanel := TJvThumbTitle.Create(Self);\r\n FTitlePanel.Align := alTop;\r\n FTitlePanel.Height := 15;\r\n FTitlePanel.Alignment := taCenter;\r\n FTitleColor := clBtnFace;\r\n FTitlePanel.Color := FTitleColor;\r\n FTitleFont := TFont.Create;\r\n FTitleFont.OnChange := RefreshFont;\r\n FTitlePanel.BevelOuter := bvLowered;\r\n FTitlePanel.ParentColor := True;\r\n FTitlePanel.Color := Self.Color;\r\n if FTitlePlacement = tpNone then\r\n FTitlePanel.Visible := False;\r\n FTitle := '';\r\n FUpdated := False;\r\n InsertControl(Photo);\r\n InsertControl(FTitlePanel);\r\n Align := alNone;\r\n if AOwner is TJvThumbView then\r\n begin\r\n Width := TJvThumbView(Owner).MaxWidth;\r\n Height := TJvThumbView(Owner).MaxHeight;\r\n end\r\n else\r\n begin\r\n Width := 120;\r\n Height := 120;\r\n end;\r\n FMinimizeMemory := True;\r\n AsButton := False;\r\n Left := 10;\r\n Top := 10;\r\n Visible := True;\r\n BevelOuter := bvRaised;\r\n StreamFileType := grBMP;\r\n FAutoLoad := True;\r\nend;\r\n\r\ndestructor TJvThumbnail.Destroy;\r\nbegin\r\n FDestroying := True;\r\n Photo.OnProgress := nil;\r\n FPhotoName.Free;\r\n FTitleFont.OnChange := nil;\r\n FTitleFont.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvThumbnail.SetShowTitle(const AState: Boolean);\r\nbegin\r\n if AState <> FShowTitle then\r\n begin\r\n FShowTitle := AState;\r\n FTitlePanel.Visible := AState;\r\n end\r\nend;\r\n\r\nprocedure TJvThumbnail.BoundsChanged;\r\nbegin\r\n CalculateImageSize;\r\n inherited BoundsChanged;\r\nend;\r\n\r\nprocedure TJvThumbnail.SetStream(const AStream: TStream);\r\nvar\r\n Bmp: Graphics.TBitmap;\r\n Size: TPoint;\r\n Img2: TJPEGImage;\r\nbegin\r\n case StreamFileType of\r\n grBMP:\r\n Photo.Picture.Bitmap.LoadFromStream(AStream);\r\n grEMF, grWMF:\r\n Photo.Picture.Metafile.LoadFromStream(AStream);\r\n grJPG:\r\n begin\r\n Img2 := TJPEGImage.Create;\r\n Img2.LoadFromStream(AStream);\r\n Photo.Picture.Assign(Img2);\r\n FreeAndNil(Img2);\r\n end;\r\n end;\r\n\r\n if FMinimizeMemory then\r\n begin\r\n Bmp := Graphics.TBitmap.Create;\r\n if Parent is TJvThumbView then\r\n Size := ProportionalSize(Point(Photo.Picture.Width, Photo.Picture.Height),\r\n Point(TJvThumbView(Parent).MaxWidth, TJvThumbView(Parent).MaxHeight))\r\n else\r\n Size := ProportionalSize(Point(Photo.Picture.Width, Photo.Picture.Height),\r\n Point(Width, Height));\r\n Bmp.Width := Size.X;\r\n Bmp.Height := Size.Y;\r\n Bmp.handletype := bmDIB;\r\n Bmp.pixelformat := pf24bit;\r\n Bmp.Canvas.StretchDraw(rect(0, 0, Bmp.Width, Bmp.Height),\r\n Photo.Picture.Graphic);\r\n //Photo.Picture.Graphic.Free; // (rom) not needed\r\n //Photo.Picture.Graphic := nil;\r\n Photo.Picture.Assign(Bmp);\r\n Bmp.Free;\r\n end;\r\nend;\r\n\r\nprocedure TJvThumbnail.SetClientWidth(AWidth: Word);\r\nbegin\r\n FClientWidth := (Width - (BorderWidth * 2)) - 8;\r\nend;\r\n\r\nprocedure TJvThumbnail.SetClientHeight(AHeight: Word);\r\nbegin\r\n if Assigned(FTitlePanel) then\r\n FClientHeight := Height - (FTitlePanel.Height + 8)\r\n else\r\n FClientHeight := Height - 8;\r\nend;\r\n\r\n// dummy property functions to allow the object inspector to\r\n// show the properties and their values\r\n\r\nprocedure TJvThumbnail.SetDummyStr(AStr: string);\r\nbegin\r\nend;\r\n\r\nprocedure TJvThumbnail.SetDummyCard(AInt: Longint);\r\nbegin\r\nend;\r\n\r\nprocedure TJvThumbnail.PhotoOnProgress(Sender: TObject; Stage: TProgressStage;\r\n PercentDone: Byte; RedrawNow: Boolean; const R: TRect; const Msg: string);\r\nbegin\r\n FImageReady := (Stage = psEnding);\r\nend;\r\n\r\nprocedure TJvThumbnail.MouseDown(Button: TMouseButton; Shift: TShiftState;\r\n X, Y: Integer);\r\nbegin\r\n if AsButton then\r\n if Button = mbLeft then\r\n begin\r\n FMousePressed := True;\r\n BevelOuter := bvLowered;\r\n FTitlePanel.BevelOuter := bvRaised;\r\n end;\r\n inherited MouseDown(Button, Shift, X, Y);\r\nend;\r\n\r\nprocedure TJvThumbnail.SetShowShadow(Show: Boolean);\r\nbegin\r\n FShadowObj.Visible := Show;\r\n FShowShadow := Show;\r\nend;\r\n\r\n{procedure TJvThumbnail.SetShadowColor(aColor: TColor);\r\nbegin\r\n FShadowObj.Brush.Color := aColor;\r\n FShadowColor := aColor;\r\nend;}\r\n\r\nprocedure TJvThumbnail.MouseMove(Shift: TShiftState; X, Y: Integer);\r\nbegin\r\n if AsButton then\r\n if FMousePressed then\r\n begin\r\n if (X < 0) or (X > Width) or (Y < 0) or (Y > Height) then\r\n begin\r\n BevelOuter := bvRaised;\r\n FTitlePanel.BevelOuter := bvLowered\r\n end\r\n else\r\n begin\r\n BevelOuter := bvLowered;\r\n FTitlePanel.BevelOuter := bvRaised;\r\n end;\r\n end;\r\n inherited MouseMove(Shift, X, Y);\r\nend;\r\n\r\nprocedure TJvThumbnail.MouseUp(Button: TMouseButton; Shift: TShiftState;\r\n X, Y: Integer);\r\nbegin\r\n if AsButton then\r\n if Button = mbLeft then\r\n begin\r\n FMousePressed := False;\r\n BevelOuter := bvRaised;\r\n FTitlePanel.BevelOuter := bvLowered;\r\n end;\r\n inherited MouseUp(Button, Shift, X, Y);\r\nend;\r\n\r\nprocedure TJvThumbnail.GetFileInfo(AName: string);\r\nvar\r\n FileInfo: TWin32FindData;\r\n H: THandle;\r\n Dft: DWORD;\r\n Lft: TFileTime;\r\nbegin\r\n H := Windows.FindFirstFile(PChar(AName), FileInfo);\r\n if H <> INVALID_HANDLE_VALUE then\r\n begin\r\n Windows.FindClose(H);\r\n FileTimeToLocalFileTime(FileInfo.ftLastAccessTime, Lft);\r\n FileTimeToDosDateTime(Lft, LongRec(Dft).Hi, LongRec(Dft).Lo);\r\n try\r\n FDFileAccessed := DateTimeToStr(FileDateToDateTime(Dft));\r\n except\r\n FDFileAccessed := RsUnknown;\r\n end;\r\n FileTimeToLocalFileTime(FileInfo.ftLastwriteTime, Lft);\r\n FileTimeToDosDateTime(Lft, LongRec(Dft).Hi, LongRec(Dft).Lo);\r\n try\r\n FDFileChanged := DateTimeToStr(FileDateToDateTime(Dft));\r\n except\r\n FDFileChanged := RsUnknown;\r\n end;\r\n FileTimeToLocalFileTime(FileInfo.ftCreationTime, Lft);\r\n FileTimeToDosDateTime(Lft, LongRec(Dft).Hi, LongRec(Dft).Lo);\r\n try\r\n FDFileCreated := DateTimeToStr(FileDateToDateTime(Dft));\r\n except\r\n FDFileCreated := RsUnknown;\r\n end;\r\n FDFileSize := (FileInfo.nFileSizeHigh * MAXDWORD) + FileInfo.nFileSizeLow;\r\n end;\r\nend;\r\n\r\nfunction TJvThumbnail.GetFileName: string;\r\nbegin\r\n Result := FPhotoName.FileName;\r\nend;\r\n\r\nfunction TJvThumbnail.LoadFile(AFile: string): string;\r\nvar\r\n FName: string;\r\nbegin\r\n try\r\n FName := AFile;\r\n Photo.LoadFromFile(AFile);\r\n FImageWidth := Photo.Picture.Width;\r\n FImageHeight := Photo.Picture.Height;\r\n FUpdated := False;\r\n CalculateImageSize;\r\n Photo.Visible := True;\r\n except\r\n // (rom) ShowMessage removed\r\n FName := '';\r\n end;\r\n if MinimizeMemory and (FPhotoName.FileName <> '') then\r\n begin\r\n if Owner is TJvThumbView then\r\n Photo.ScaleDown(TJvThumbView(Owner).MaxWidth, TJvThumbView(Owner).MaxHeight)\r\n else\r\n Photo.ScaleDown(Width, Height);\r\n end;\r\n Result := FName;\r\nend;\r\n\r\nprocedure TJvThumbnail.SetFileName(const AFile: string);\r\nvar\r\n FName: string;\r\n// Pos: Longint;\r\n// tmp: TJvThumbImage;\r\n// D1, D2: TdateTime;\r\nbegin\r\n if AFile <> '' then\r\n begin\r\n GetFileInfo(AFile);\r\n if FAutoLoad then\r\n FName := LoadFile(AFile);\r\n end\r\n else\r\n FName := ''; {}\r\n if FName = AFile then\r\n if (Title = ExtractFileName(FPhotoName.FileName)) or (Title = '') then\r\n Title := ExtractFileName(FName);\r\n FPhotoName.FileName := FName;\r\nend;\r\n\r\nprocedure TJvThumbnail.CalculateImageSize;\r\nvar\r\n Percent: Byte;\r\n TempX, TempY: Single;\r\nbegin\r\n SetClientHeight(15);\r\n SetClientWidth(15);\r\n if (Photo.Picture.Width > ClientWidth) or (Photo.Picture.Height > ClientHeight) then\r\n begin\r\n TempX := ((ClientWidth) / Photo.Picture.Width) * 100;\r\n TempY := ((ClientHeight) / Photo.Picture.Height) * 100;\r\n end\r\n else\r\n begin\r\n TempX := 100;\r\n TempY := 100;\r\n end;\r\n if TempX <= TempY then\r\n Percent := Trunc(TempX)\r\n else\r\n Percent := Trunc(TempY);\r\n Photo.Width := Trunc((Photo.Picture.Width / 100) * Percent);\r\n Photo.Height := Trunc((Photo.Picture.Height / 100) * Percent);\r\n Photo.Left := Trunc(Width / 2 - Photo.Width / 2);\r\n Photo.Top := (Height div 2) - (Photo.Height div 2);\r\n case FTitlePlacement of\r\n tpUp:\r\n Photo.Top := Photo.Top + (FTitlePanel.Height div 2);\r\n tpDown:\r\n Photo.Top := Photo.Top - (FTitlePanel.Height div 2);\r\n end;\r\n FShadowObj.SetBounds(Photo.Left + FHShadowOffset, Photo.Top + FVShadowOffset,\r\n Photo.Width, Photo.Height);\r\nend;\r\n\r\nprocedure TJvThumbnail.THSizeChanged(var Msg: TMessage);\r\nbegin\r\n CalculateImageSize;\r\nend;\r\n\r\nprocedure TJvThumbnail.SetTitle(const Value: string);\r\nbegin\r\n if Value <> FTitle then\r\n begin\r\n FTitle := Value;\r\n FTitlePanel.Caption := Value;\r\n end;\r\nend;\r\n\r\nprocedure TJvThumbnail.WMPaint(var Msg: TWMPaint);\r\nvar\r\n ThumbnailTitle: string;\r\nbegin\r\n if not FUpdated then\r\n begin\r\n ThumbnailTitle := Title;\r\n if Assigned(FOnGetTitle) then\r\n begin\r\n FOnGetTitle(Self, FileName, ThumbnailTitle);\r\n SetTitle(ThumbnailTitle);\r\n end\r\n else\r\n begin\r\n if ThumbnailTitle = '' then\r\n SetTitle(ExtractFileName(FileName))\r\n else\r\n SetTitle(ThumbnailTitle);\r\n end;\r\n FUpdated := True;\r\n end;\r\n inherited;\r\nend;\r\n\r\nprocedure TJvThumbnail.SetTitleColor(const Value: TColor);\r\nbegin\r\n if Value <> FTitleColor then\r\n begin\r\n FTitleColor := Value;\r\n FTitlePanel.Color := Value;\r\n end;\r\nend;\r\n\r\nprocedure TJvThumbnail.SetTitleFont(const Value: TFont);\r\nbegin\r\n FTitleFont.Assign(Value);\r\nend;\r\n\r\nprocedure TJvThumbnail.RefreshFont(Sender: TObject);\r\nbegin\r\n FTitlePanel.Font.Assign(FTitleFont);\r\nend;\r\n\r\nprocedure TJvThumbnail.SetTitlePanel(ATitle: string; AFont: TFont;\r\n AColor: TColor);\r\nbegin\r\n SetTitleFont(AFont);\r\n SetTitleColor(AColor);\r\n SetTitle(ATitle);\r\n FUpdated := True;\r\nend;\r\n\r\nprocedure TJvThumbnail.SetTitlePlacement(const AState: TTitlePos);\r\nbegin\r\n if AState <> FTitlePlacement then\r\n case AState of\r\n tpUp:\r\n FTitlePanel.Align := alTop;\r\n tpDown:\r\n FTitlePanel.Align := alBottom;\r\n tpNone:\r\n FTitlePanel.Visible := False;\r\n end;\r\n if FTitlePlacement = tpNone then\r\n FTitlePanel.Visible := True;\r\n FTitlePlacement := AState;\r\n CalculateImageSize;\r\nend;\r\n\r\nprocedure TJvThumbnail.SetMinimizeMemory(Min: Boolean);\r\nbegin\r\n if Assigned(Photo.Picture.Graphic) then\r\n begin\r\n if FMinimizeMemory <> Min then\r\n begin\r\n if Min then\r\n begin\r\n if Owner is TJvThumbView then\r\n Photo.ScaleDown(TJvThumbView(Owner).MaxWidth, TJvThumbView(Owner).MaxHeight)\r\n else\r\n Photo.ScaleDown(Width, Height);\r\n end\r\n else\r\n if FMinimizeMemory then\r\n Photo.Picture.LoadFromFile(FileName);\r\n FMinimizeMemory := Min;\r\n end;\r\n end\r\n else\r\n FMinimizeMemory := Min;\r\nend;\r\n\r\nprocedure TJvThumbnail.Refresh;\r\nbegin\r\n CalculateImageSize;\r\n inherited Refresh;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvTimeLimit.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvTimeLimit.PAS, released on 2001-02-28.\r\n\r\nThe Initial Developer of the Original Code is Sbastien Buysse [sbuysse att buypin dott com]\r\nPortions created by Sbastien Buysse are Copyright (C) 2001 Sbastien Buysse.\r\nAll Rights Reserved.\r\n\r\nContributor(s): Michael Beck [mbeck att bigfoot dott com].\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvTimeLimit.pas 13104 2011-09-07 06:50:43Z obones $\r\n\r\nunit JvTimeLimit;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n SysUtils, Classes, Controls, Dialogs, Forms,\r\n JvComponentBase, JvTypes;\r\n\r\ntype\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64 or pidOSX32)]\r\n {$ENDIF RTL230_UP}\r\n TJvTimeLimit = class(TJvComponent)\r\n private\r\n FDate: TDate;\r\n FOnExpire: TNotifyEvent;\r\n protected\r\n procedure Loaded; override;\r\n published\r\n property EndDate: TDate read FDate write FDate;\r\n property OnExpire: TNotifyEvent read FOnExpire write FOnExpire;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvTimeLimit.pas $';\r\n Revision: '$Revision: 13104 $';\r\n Date: '$Date: 2011-09-07 08:50:43 +0200 (mer. 07 sept. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n JvResources;\r\n\r\nprocedure TJvTimeLimit.Loaded;\r\nbegin\r\n if not (csDesigning in ComponentState) then\r\n if Date >= FDate then\r\n begin\r\n if Assigned(FOnExpire) then\r\n FOnExpire(Self)\r\n else\r\n ShowMessage(RsExpired);\r\n Application.Terminate;\r\n end;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvTimeLine.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvTimeLine.PAS, released on 2002-05-26.\r\n\r\nThe Initial Developer of the Original Code is Peter Thrnqvist [peter3 at sourceforge dot net]\r\nPortions created by Peter Thrnqvist are Copyright (C) 2002 Peter Thrnqvist.\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nDescription:\r\n A timeline component with support for inserting items at selectable dates.\r\n\r\nKnown Issues:\r\n 2004-12-07:\r\n - ShowSelection: if true, the selected item is painted with clHighlight/clHighlightText\r\n - OnItemMouseMove event\r\n - Bug fix for dragging: if DragMode is dmManual, no drag is performed automatically (duh!)\r\n - SupportsColor property to set the color of the support lines (vert and horz)\r\n\r\n\r\n\r\n Bugs / Limitations:\r\n * DateAtPos is approximate\r\n * PosAtDate is slightly better\r\n * FirstVisibleDate always start at day 1 of month\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvTimeLine.pas 13180 2011-11-22 12:45:23Z obones $\r\n\r\nunit JvTimeLine;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n SysUtils, Classes,\r\n Windows, Messages, Graphics, Controls, Forms, StdCtrls, ExtCtrls, ImgList,\r\n JvConsts, JvComponent;\r\n\r\ntype\r\n TJvTimeItems = class;\r\n TJvCustomTimeLine = class;\r\n TJvTimeItemType = (asPixels, asDays);\r\n\r\n TJvTimeLineState = (tlDragPending, tlDragging, tlMouseDown, tlClearPending);\r\n TJvTimeLineStates = set of TJvTimeLineState;\r\n\r\n TJvTimeItem = class(TCollectionItem)\r\n private\r\n FRect: TRect;\r\n FParent: TJvTimeItems;\r\n FData: Pointer;\r\n FImageIndex: Integer;\r\n FImageOffset: Integer;\r\n FDate: TDateTime;\r\n FCaption: string;\r\n FColor: TColor;\r\n FTextColor: TColor;\r\n FHint: string;\r\n FLevel: Integer;\r\n FWidth: Integer;\r\n FStyle: TJvTimeItemType;\r\n FSelected: Boolean;\r\n FEnabled: Boolean;\r\n FOnDestroy: TNotifyEvent;\r\n procedure SetEnabled(Value: Boolean);\r\n procedure SetImageOffset(Value: Integer);\r\n procedure SetStyle(Value: TJvTimeItemType);\r\n procedure SetSelected(Value: Boolean);\r\n procedure SetDate(Value: TDateTime);\r\n procedure SetCaption(Value: string);\r\n procedure SetColor(Value: TColor);\r\n procedure SetTextColor(Value: TColor);\r\n procedure SetImageIndex(Value: Integer);\r\n procedure SetLevel(Value: Integer);\r\n procedure SetWidth(Value: Integer);\r\n function GetBounds(Index: Integer): Integer;\r\n procedure SetBounds(Index: Integer; Value: Integer);\r\n protected\r\n procedure Update; virtual;\r\n function GetDisplayName: string; override;\r\n procedure DoDestroy;\r\n public\r\n constructor Create(Collection: Classes.TCollection); override;\r\n destructor Destroy; override;\r\n procedure Remove; virtual;\r\n procedure Assign(Source: TPersistent); override;\r\n property Data: Pointer read FData write FData;\r\n published\r\n property Enabled: Boolean read FEnabled write SetEnabled default True;\r\n property Left: Integer index 0 read GetBounds write SetBounds;\r\n property Top: Integer index 1 read GetBounds write SetBounds;\r\n property Caption: string read FCaption write SetCaption;\r\n property Color: TColor read FColor write SetColor default clWindow;\r\n property Date: TDateTime read FDate write SetDate;\r\n property Hint: string read FHint write FHint;\r\n property ImageIndex: Integer read FImageIndex write SetImageIndex default -1;\r\n property ImageOffset: Integer read FImageOffset write SetImageOffset default 0;\r\n property Level: Integer read FLevel write SetLevel default 0;\r\n property Selected: Boolean read FSelected write SetSelected default False;\r\n property TextColor: TColor read FTextColor write SetTextColor default clBlack;\r\n property WidthAs: TJvTimeItemType read FStyle write SetStyle default asPixels;\r\n property Width: Integer read FWidth write SetWidth default 50;\r\n property OnDestroy: TNotifyEvent read FOnDestroy write FOnDestroy;\r\n end;\r\n\r\n TJvTimeItems = class(TCollection)\r\n private\r\n FTimeLine: TJvCustomTimeLine;\r\n function GetItem(Index: Integer): TJvTimeItem;\r\n procedure SetItem(Index: Integer; Value: TJvTimeItem);\r\n protected\r\n function GetOwner: TPersistent; override;\r\n procedure Update(Item: TCollectionItem); override;\r\n public\r\n constructor Create(TimeLine: TJvCustomTimeLine);\r\n function Add: TJvTimeItem;\r\n procedure Refresh;\r\n property Items[Index: Integer]: TJvTimeItem read GetItem write SetItem; default;\r\n end;\r\n\r\n TJvYearWidth = 12..MaxInt;\r\n // TItemAlign=(tiCenter,tiLeft);\r\n TJvTimeLineStyle = (tlDefault, tlOwnerDrawFixed, tlOwnerDrawVariable);\r\n TJvScrollArrow = (scrollLeft, scrollRight, scrollUp, scrollDown);\r\n TJvScrollArrows = set of TJvScrollArrow;\r\n TJvTimeItemClickEvent = procedure(Sender: TObject; Item: TJvTimeItem) of object;\r\n TJvDrawTimeItemEvent = procedure(Sender: TObject; Canvas: TCanvas; Item:\r\n TJvTimeItem; var R: TRect) of object;\r\n TJvMeasureTimeItemEvent = procedure(Sender: TObject; Item: TJvTimeItem; var\r\n ItemHeight: Integer) of object;\r\n TJvStreamItemEvent = procedure(Sender: TObject; Item: TJvTimeItem; Stream:\r\n TStream) of object;\r\n TJvItemMovedEvent = procedure(Sender: TObject; Item: TJvTimeItem;\r\n var NewStartDate: TDateTime; var NewLevel: Integer) of object;\r\n TJvItemMovingEvent = procedure(Sender: TObject; Item: TJvTimeItem; var\r\n AllowMove: Boolean) of object;\r\n TJvItemMouseMove = procedure(Sender: TObject; Item: TJvTimeItem; X, Y: Integer) of object;\r\n\r\n TJvTLScrollBtn = class(TJvGraphicControl)\r\n private\r\n FFlat: Boolean;\r\n FPushed: Boolean;\r\n FTimeLine: TJvCustomTimeLine;\r\n FDirection: TJvScrollArrow;\r\n FRepeatClick: Boolean;\r\n FTimer: TTimer;\r\n {$IFDEF JVCLThemesEnabled}\r\n FMouseInControl: Boolean;\r\n {$ENDIF JVCLThemesEnabled}\r\n procedure SetDirection(const Value: TJvScrollArrow);\r\n procedure SetFlat(const Value: Boolean);\r\n procedure SetTimeLine(const Value: TJvCustomTimeLine);\r\n procedure UpdatePlacement;\r\n procedure OnTimer(Sender: TObject);\r\n protected\r\n {$IFDEF JVCLThemesEnabled}\r\n procedure MouseEnter(Control: TControl); override;\r\n procedure MouseLeave(Control: TControl); override;\r\n {$ENDIF JVCLThemesEnabled}\r\n procedure MouseDown(Button: TMouseButton; Shift: TShiftState;\r\n X, Y: Integer); override;\r\n procedure MouseUp(Button: TMouseButton; Shift: TShiftState;\r\n X, Y: Integer); override;\r\n procedure Click; override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n procedure Paint; override;\r\n property RepeatClick: Boolean read FRepeatClick write FRepeatClick;\r\n published\r\n property Flat: Boolean read FFlat write SetFlat;\r\n property Direction: TJvScrollArrow read FDirection write SetDirection;\r\n property TimeLine: TJvCustomTimeLine read FTimeLine write SetTimeLine;\r\n end;\r\n\r\n TJvCustomTimeLine = class(TJvCustomControl)\r\n private\r\n FItemHintImageList: TCustomImageList;\r\n FArrows: array [TJvScrollArrow] of TJvTLScrollBtn;\r\n FList: TList;\r\n FBmp: TBitmap;\r\n FYearWidth: TJvYearWidth;\r\n FBorderStyle: TBorderStyle;\r\n FUpdate: Integer;\r\n FMonthWidth: Extended;\r\n FTopOffset: Integer;\r\n FItemOffset: Integer;\r\n FScrollHeight: Integer;\r\n FScrollWidth: Integer;\r\n FFirstDate: TDate;\r\n FShowMonths: Boolean;\r\n FShowDays: Boolean;\r\n FMultiSelect: Boolean;\r\n FShowItemHint: Boolean;\r\n FSupportLines: Boolean;\r\n FFlat: Boolean;\r\n FHelperYears: Boolean;\r\n FDragLine: Boolean;\r\n FLineVisible: Boolean;\r\n //--FMouseDown: Boolean;\r\n FNewHeight: Integer;\r\n FOldX: Integer;\r\n FOldHint: string;\r\n FStyle: TJvTimeLineStyle;\r\n FScrollArrows: TJvScrollArrows;\r\n FTimeItems: TJvTimeItems;\r\n FItemHeight: Integer;\r\n FTopLevel: Integer;\r\n FImages: TCustomImageList;\r\n FYearFont: TFont;\r\n FSelectedItem: TJvTimeItem;\r\n FYearList: TList;\r\n FImageChangeLink: TChangeLink;\r\n FOnVertScroll: TScrollEvent;\r\n FOnHorzScroll: TScrollEvent;\r\n FOnItemClick: TJvTimeItemClickEvent;\r\n FOnDrawItem: TJvDrawTimeItemEvent;\r\n FOnMeasureItem: TJvMeasureTimeItemEvent;\r\n FOnLoadItem: TJvStreamItemEvent;\r\n FOnSaveItem: TJvStreamItemEvent;\r\n FOnSize: TNotifyEvent;\r\n FOnItemMoved: TJvItemMovedEvent;\r\n FOnItemMoving: TJvItemMovingEvent;\r\n FLastScrollCode: TScrollCode;\r\n FHorzSupport: Boolean;\r\n FShowHiddenItemHints: Boolean;\r\n FOnItemDblClick: TJvTimeItemClickEvent;\r\n FCanvas: TControlCanvas;\r\n FAutoDrag: Boolean;// automatic (or allowed) drag start\r\n FDragImages: TDragImageList;\r\n FDragItem: TJvTimeItem;\r\n FStartPos: TPoint;\r\n FStates: TJvTimeLineStates;\r\n FRangeAnchor: TJvTimeItem;\r\n FAutoSize: Boolean;\r\n FShowSelection: Boolean;\r\n FOnItemMouseMove: TJvItemMouseMove;\r\n FSupportsColor: TColor;\r\n procedure SetHelperYears(Value: Boolean);\r\n procedure SetFlat(Value: Boolean);\r\n procedure SetScrollArrows(Value: TJvScrollArrows);\r\n procedure SetBorderStyle(Value: TBorderStyle);\r\n procedure SetYearFont(Value: TFont);\r\n procedure SetYearWidth(Value: TJvYearWidth);\r\n procedure SetFirstDate(Value: TDate);\r\n procedure SetTimeItems(Value: TJvTimeItems);\r\n procedure SetImages(Value: TCustomImageList);\r\n procedure SetShowMonths(Value: Boolean);\r\n procedure SetShowDays(Value: Boolean);\r\n procedure SetSelectedItem(Value: TJvTimeItem);\r\n procedure SetMultiSelect(Value: Boolean);\r\n procedure SetTopOffset(Value: Integer);\r\n procedure SetTopLevel(Value: Integer);\r\n // procedure SetItemAlign(Value: TItemAlign);\r\n procedure SetSupportLines(Value: Boolean);\r\n procedure SetStyle(Value: TJvTimeLineStyle);\r\n procedure SetItemHeight(Value: Integer);\r\n procedure ImagesChanged(Sender: TObject);\r\n function GetLastDate: TDate;\r\n procedure HighLiteItem(Item: TJvTimeItem);\r\n procedure UpdateOffset;\r\n\r\n procedure CNKeyDown(var Msg: TWMKeyDown); message CN_KEYDOWN;\r\n procedure WMNCCalcSize(var Msg: TWMNCCalcSize); message WM_NCCALCSIZE;\r\n procedure WMNCPaint(var Msg: TMessage); message WM_NCPAINT;\r\n procedure WMCancelMode(var Msg: TWMCancelMode); message WM_CANCELMODE;\r\n procedure CMEnter(var Msg: TWMNoParams); message CM_ENTER;\r\n procedure CMExit(var Msg: TWMNoParams); message CM_EXIT;\r\n procedure CMDrag(var Msg: TCMDrag); message CM_DRAG;\r\n procedure DrawDays(ACanvas: TCanvas; Days, StartAt: Integer);\r\n procedure DrawDayNumbers(ACanvas: TCanvas; Days, StartAt: Integer);\r\n procedure DrawMonth(ACanvas: TCanvas; StartAt, M: Integer);\r\n procedure DrawMonthName(ACanvas: TCanvas; Month, StartAt: Integer);\r\n procedure DrawYear(ACanvas: TCanvas; StartAt: Integer; YR: string);\r\n procedure DrawTimeLine(ACanvas: TCanvas);\r\n procedure DrawVertSupport(ACanvas: TCanvas; StartAt: Integer);\r\n procedure DrawHorzSupports(ACanvas: TCanvas);\r\n procedure DrawFocus;\r\n procedure DrawLeftItemHint(ACanvas: TCanvas);\r\n procedure DrawRightItemHint(ACanvas: TCanvas);\r\n procedure DrawScrollButtons;\r\n procedure DoYearFontChange(Sender: TObject);\r\n procedure DoDragOver(Source: TDragObject; X, Y: Integer; CanDrop: Boolean);\r\n function HasItemsToLeft: Boolean;\r\n function HasItemsToRight: Boolean;\r\n procedure SetHorzSupport(const Value: Boolean);\r\n function GetMonth: Word;\r\n function GetYear: Word;\r\n procedure SetMonth(const Value: Word);\r\n procedure SetYear(const Value: Word);\r\n procedure SetShowHiddenItemHints(const Value: Boolean);\r\n procedure HandleClickSelection(LastFocused, NewItem: TJvTimeItem;\r\n Shift: TShiftState);\r\n function HasMoved(P: TPoint): Boolean;\r\n function GetHint: string;\r\n procedure SetHint(const Value: string);\r\n procedure SetShowSelection(const Value: Boolean);\r\n procedure SetSupportsColor(const Value: TColor);\r\n protected\r\n // Some helper functions for selection\r\n procedure AddToSelection(AItem: TJvTimeItem); overload;\r\n procedure SelectItems(StartItem, EndItem: TJvTimeItem; AddOnly: Boolean);\r\n procedure RemoveFromSelection(AItem: TJvTimeItem);\r\n procedure ClearSelection;\r\n procedure SetAutoSize(Value: Boolean); override;\r\n function ItemMoving(Item: TJvTimeItem): Boolean; virtual;\r\n procedure ItemMoved(Item: TJvTimeItem; var NewDate: TDateTime; var NewLevel: Integer); virtual;\r\n function ItemMouseMove(X, Y: Integer): Boolean; virtual;\r\n procedure MouseDown(Button: TMouseButton; Shift: TShiftState;\r\n X, Y: Integer); override;\r\n procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);\r\n override;\r\n procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;\r\n procedure DblClick; override;\r\n procedure Click; override;\r\n procedure Paint; override;\r\n procedure DrawDragLine(X: Integer); virtual;\r\n procedure MoveDragLine(ANewX: Integer); virtual;\r\n procedure VertScroll(ScrollCode: TScrollCode; var ScrollPos: Integer); virtual;\r\n procedure HorzScroll(ScrollCode: TScrollCode; var ScrollPos: Integer); virtual;\r\n procedure ItemClick(Item: TJvTimeItem); virtual;\r\n procedure ItemDblClick(Item: TJvTimeItem); virtual;\r\n procedure Size; virtual;\r\n procedure SaveItem(Item: TJvTimeItem; Stream: TStream); virtual;\r\n procedure LoadItem(Item: TJvTimeItem; Stream: TStream); virtual;\r\n procedure MeasureItem(Item: TJvTimeItem; var ItemHeight: Integer); virtual;\r\n procedure DrawItem(Item: TJvTimeItem; ACanvas: TCanvas; var R: TRect); virtual;\r\n procedure UpdateItem(Index: Integer; ACanvas: TCanvas); virtual;\r\n procedure UpdateItems; virtual;\r\n procedure UpdateItemHint(X,Y: Integer);\r\n procedure Notification(AComponent: TComponent; Operation: TOperation); override;\r\n procedure CreateWnd; override;\r\n function GetDragImages: TDragImageList; override;\r\n property Align default alTop;\r\n property Color default clWindow;\r\n\r\n { new properties }\r\n property Year: Word read GetYear write SetYear;\r\n property Month: Word read GetMonth write SetMonth;\r\n property Selected: TJvTimeItem read FSelectedItem write SetSelectedItem;\r\n property ShowHiddenItemHints: Boolean read FShowHiddenItemHints write\r\n SetShowHiddenItemHints default True;\r\n property BorderStyle: TBorderStyle read FBorderStyle write SetBorderStyle\r\n default bsSingle;\r\n property DragLine: Boolean read FDragLine write FDragLine default True;\r\n property ShowItemHint: Boolean read FShowItemHint write FShowItemHint default False;\r\n property AutoSize: Boolean read FAutoSize write SetAutoSize default False;\r\n property HelperYears: Boolean read FHelperYears write SetHelperYears default True;\r\n property MultiSelect: Boolean read FMultiSelect write SetMultiSelect default False;\r\n property Flat: Boolean read FFlat write SetFlat default False;\r\n property Hint: string read GetHint write SetHint;\r\n property YearFont: TFont read FYearFont write SetYearFont;\r\n property YearWidth: TJvYearWidth read FYearWidth write SetYearWidth default 140;\r\n property TopOffset: Integer read FTopOffset write SetTopOffset default 21;\r\n property ShowMonthNames: Boolean read FShowMonths write SetShowMonths;\r\n property ShowSelection: Boolean read FShowSelection write SetShowSelection default False;\r\n property ShowDays: Boolean read FShowDays write SetShowDays default False;\r\n property FirstVisibleDate: TDate read FFirstDate write SetFirstDate;\r\n property Images: TCustomImageList read FImages write SetImages;\r\n property Items: TJvTimeItems read FTimeItems write SetTimeItems;\r\n property ItemHeight: Integer read FItemHeight write SetItemHeight default 12;\r\n // property ItemAlign: TItemAlign read FItemAlign write SetItemAlign default tiCenter;\r\n property VertSupports: Boolean read FSupportLines write SetSupportLines default False;\r\n property HorzSupports: Boolean read FHorzSupport write SetHorzSupport;\r\n property SupportsColor: TColor read FSupportsColor write SetSupportsColor default clBtnFace;\r\n property Style: TJvTimeLineStyle read FStyle write SetStyle default tlDefault;\r\n property TopLevel: Integer read FTopLevel write SetTopLevel default 0;\r\n property ScrollArrows: TJvScrollArrows read FScrollArrows write\r\n SetScrollArrows default [scrollLeft..scrollDown];\r\n property OnItemClick: TJvTimeItemClickEvent read FOnItemClick write FOnItemClick;\r\n property OnItemDblClick: TJvTimeItemClickEvent read FOnItemDblClick write FOnItemDblClick;\r\n property OnSize: TNotifyEvent read FOnSize write FOnSize;\r\n property OnHorzScroll: TScrollEvent read FOnHorzScroll write FOnHorzScroll;\r\n property OnVertScroll: TScrollEvent read FOnVertScroll write FOnVertScroll;\r\n property OnDrawItem: TJvDrawTimeItemEvent read FOnDrawItem write FOnDrawItem;\r\n property OnMeasureItem: TJvMeasureTimeItemEvent read FOnMeasureItem write FOnMeasureItem;\r\n property OnSaveItem: TJvStreamItemEvent read FOnSaveItem write FOnSaveItem;\r\n property OnLoadItem: TJvStreamItemEvent read FOnLoadItem write FOnLoadItem;\r\n property OnItemMoved: TJvItemMovedEvent read FOnItemMoved write FOnItemMoved;\r\n property OnItemMouseMove: TJvItemMouseMove read FOnItemMouseMove write FOnItemMouseMove;\r\n property OnItemMoving: TJvItemMovingEvent read FOnItemMoving write FOnItemMoving;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n procedure NextYear;\r\n procedure PrevYear;\r\n procedure NextMonth;\r\n procedure PrevMonth;\r\n function ItemAtPos(X, Y: Integer): TJvTimeItem; virtual;\r\n function LevelAtPos(Pos: Integer): Integer; virtual;\r\n function DateAtPos(Pos: Integer): TDateTime; virtual;\r\n function PosAtDate(Date: TDateTime): Integer; virtual;\r\n procedure AutoLevels(Complete, ResetLevels: Boolean); virtual;\r\n procedure LoadFromFile(FileName: string); virtual;\r\n procedure SaveToFile(FileName: string); virtual;\r\n procedure LoadFromStream(Stream: TStream); virtual;\r\n procedure SaveToStream(Stream: TStream); virtual;\r\n procedure BeginUpdate; virtual;\r\n procedure EndUpdate; virtual;\r\n procedure SetBounds(ALeft, ATop, AWidth, AHeight: Integer); override;\r\n procedure BeginDrag(Immediate: Boolean; Threshold: Integer = -1);\r\n end;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvTimeLine = class(TJvCustomTimeLine)\r\n public\r\n property Selected;\r\n published\r\n property Align;\r\n property Color;\r\n property Cursor;\r\n property DoubleBuffered default True;\r\n property DragLine;\r\n property Enabled;\r\n property Height;\r\n property HelperYears;\r\n property ShowSelection;\r\n property Hint;\r\n property Left;\r\n property PopupMenu;\r\n property ParentShowHint;\r\n property ShowHint;\r\n property Top;\r\n property Visible;\r\n property Width;\r\n property Font;\r\n property ScrollArrows;\r\n property TabStop;\r\n property TabOrder;\r\n property OnMouseDown;\r\n property OnMouseUp;\r\n property OnMouseMove;\r\n property OnMouseEnter;\r\n property OnMouseLeave;\r\n property OnDblClick;\r\n property OnClick;\r\n\r\n\r\n property BorderStyle;\r\n property AutoSize;\r\n property DragCursor;\r\n property DragMode;\r\n property OnEndDrag;\r\n property OnStartDrag;\r\n property OnDragOver;\r\n property OnDragDrop;\r\n property MultiSelect;\r\n property Flat;\r\n property YearFont;\r\n property YearWidth;\r\n property TopOffset;\r\n property ShowDays;\r\n property ShowHiddenItemHints;\r\n property ShowItemHint;\r\n property ShowMonthNames;\r\n property FirstVisibleDate;\r\n property Images;\r\n property Items;\r\n property ItemHeight;\r\n // property ItemAlign;\r\n property VertSupports;\r\n property HorzSupports;\r\n property SupportsColor;\r\n property Style;\r\n property TopLevel;\r\n property OnItemClick;\r\n property OnItemDblClick;\r\n property OnSize;\r\n property OnHorzScroll;\r\n property OnVertScroll;\r\n property OnDrawItem;\r\n property OnMeasureItem;\r\n property OnSaveItem;\r\n property OnLoadItem;\r\n property OnItemMoved;\r\n property OnItemMouseMove;\r\n property OnItemMoving;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvTimeLine.pas $';\r\n Revision: '$Revision: 13180 $';\r\n Date: '$Date: 2011-11-22 13:45:23 +0100 (mar. 22 nov. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n Math, Types,\r\n JvJCLUtils, JvJVCLUtils, JvThemes, JclSysUtils;\r\n\r\n{$R JvTimeLine.res}\r\n\r\nconst\r\n FDayLineLength = 4;\r\n FDayTextTop = 5;\r\n FMonthLineLength = 10;\r\n FMonthTextTop = 24;\r\n FYearLineLength = 24;\r\n FYearTextTop = 32;\r\n FScrollEdgeOffset = 8;\r\n\r\nvar\r\n FInitRepeatPause: Cardinal = 140;\r\n FRepeatPause: Cardinal = 30;\r\n\r\nfunction MonthCount(Date1, Date2: TDateTime): Integer;\r\nvar\r\n Y1, M1, D1, Y2, M2, D2: Word;\r\nbegin\r\n DecodeDate(Date1, Y1, M1, D1);\r\n DecodeDate(Date2, Y2, M2, D2);\r\n Result := (Y2 - Y1) * 12 + (M2 - M1);\r\n if (D1 = 1) and (D2 = 1) then\r\n Dec(Result);\r\nend;\r\n\r\nfunction PixelsForDays(Date: TDateTime; PixelsPerMonth: Integer): Integer;\r\nvar\r\n Y, M, D: Word;\r\nbegin\r\n DecodeDate(Date - 1, Y, M, D);\r\n Result := D * PixelsPerMonth div MonthDays[IsLeapYear(Y), M];\r\nend;\r\n\r\nfunction DateCompare(Item1, Item2: Pointer): Integer;\r\nbegin\r\n Result := Trunc(TJvTimeItem(Item1).Date - TJvTimeItem(Item2).Date);\r\nend;\r\n\r\nfunction RectInRect(const Rect1, Rect2: TRect): Boolean;\r\nvar\r\n R: TRect;\r\nbegin\r\n Result := IntersectRect(R, Rect1, Rect2);\r\nend;\r\n\r\n//=== { TJvTimeItem } ========================================================\r\n\r\nconstructor TJvTimeItem.Create(Collection: Classes.TCollection);\r\nbegin\r\n inherited Create(Collection);\r\n FParent := TJvTimeItems(Collection);\r\n FEnabled := True;\r\n FCaption := '';\r\n FDate := Trunc(Now);\r\n FColor := clWindow;\r\n FTextColor := clBlack;\r\n FRect := Rect(0, 0, 0, 0);\r\n FSelected := False;\r\n FImageIndex := Collection.Count - 1;\r\n FLevel := FImageIndex;\r\n FWidth := 50;\r\n FStyle := asPixels;\r\n FImageOffset := 0;\r\n Update;\r\nend;\r\n\r\ndestructor TJvTimeItem.Destroy;\r\nbegin\r\n DoDestroy;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvTimeItem.DoDestroy;\r\nbegin\r\n if Assigned(OnDestroy) then\r\n OnDestroy(Self);\r\nend;\r\n\r\nprocedure TJvTimeItem.Remove;\r\nbegin\r\n Windows.InvalidateRect(FParent.FTimeLine.Handle, @FRect, True);\r\n // (rom) suspicious\r\n inherited Free;\r\nend;\r\n\r\nprocedure TJvTimeItem.Assign(Source: TPersistent);\r\nbegin\r\n if Source is TJvTimeItem then\r\n begin\r\n Caption := TJvTimeItem(Source).Caption;\r\n ImageIndex := TJvTimeItem(Source).ImageIndex;\r\n Date := TJvTimeItem(Source).Date;\r\n Level := TJvTimeItem(Source).Level;\r\n Width := TJvTimeItem(Source).Width;\r\n Hint := TJvTimeItem(Source).Hint;\r\n Color := TJvTimeItem(Source).Color;\r\n TextColor := TJvTimeItem(Source).TextColor;\r\n end\r\n else\r\n inherited Assign(Source);\r\nend;\r\n\r\nprocedure TJvTimeItem.Update;\r\nbegin\r\n Windows.InvalidateRect(FParent.FTimeLine.Handle, @FRect, True);\r\n FParent.FTimeLine.UpdateItem(Index, FParent.FTimeLine.Canvas);\r\n Windows.InvalidateRect(FParent.FTimeLine.Handle, @FRect, True);\r\nend;\r\n\r\nfunction TJvTimeItem.GetDisplayName: string;\r\nbegin\r\n Result := Caption;\r\n if Result = '' then\r\n Result := inherited GetDisplayName;\r\nend;\r\n\r\nprocedure TJvTimeItem.SetEnabled(Value: Boolean);\r\nbegin\r\n if FEnabled <> Value then\r\n begin\r\n FEnabled := Value;\r\n Update;\r\n end;\r\nend;\r\n\r\nprocedure TJvTimeItem.SetImageOffset(Value: Integer);\r\nbegin\r\n if FImageOffset <> Value then\r\n begin\r\n FImageOffset := Value;\r\n Update;\r\n end;\r\nend;\r\n\r\nprocedure TJvTimeItem.SetStyle(Value: TJvTimeItemType);\r\nbegin\r\n if FStyle <> Value then\r\n begin\r\n FStyle := Value;\r\n Update;\r\n end;\r\nend;\r\n\r\nprocedure TJvTimeItem.SetSelected(Value: Boolean);\r\nbegin\r\n if FSelected <> Value then\r\n begin\r\n FSelected := Value;\r\n Update;\r\n end;\r\nend;\r\n\r\nprocedure TJvTimeItem.SetDate(Value: TDateTime);\r\nbegin\r\n if FDate <> Value then\r\n begin\r\n FDate := Value;\r\n Update;\r\n end;\r\nend;\r\n\r\nprocedure TJvTimeItem.SetCaption(Value: string);\r\nbegin\r\n if FCaption <> Value then\r\n begin\r\n FCaption := Value;\r\n Update;\r\n end;\r\nend;\r\n\r\nprocedure TJvTimeItem.SetColor(Value: TColor);\r\nbegin\r\n if FColor <> Value then\r\n begin\r\n FColor := Value;\r\n Update;\r\n end;\r\nend;\r\n\r\nprocedure TJvTimeItem.SetTextColor(Value: TColor);\r\nbegin\r\n if FTextColor <> Value then\r\n begin\r\n FTextColor := Value;\r\n Update;\r\n end;\r\nend;\r\n\r\nprocedure TJvTimeItem.SetImageIndex(Value: Integer);\r\nbegin\r\n if FImageIndex <> Value then\r\n begin\r\n FImageIndex := Value;\r\n Update;\r\n end;\r\nend;\r\n\r\nprocedure TJvTimeItem.SetWidth(Value: Integer);\r\nbegin\r\n if FWidth <> Value then\r\n begin\r\n FWidth := Value;\r\n Update;\r\n end;\r\nend;\r\n\r\nprocedure TJvTimeItem.SetLevel(Value: Integer);\r\nbegin\r\n if FLevel <> Value then\r\n begin\r\n FLevel := Value;\r\n FParent.FTimeLine.Repaint;\r\n end;\r\nend;\r\n\r\nfunction TJvTimeItem.GetBounds(Index: Integer): Integer;\r\nbegin\r\n case Index of\r\n 0:\r\n Result := FRect.Left;\r\n 1:\r\n Result := FRect.Top;\r\n else\r\n Result := 0;\r\n end;\r\nend;\r\n\r\nprocedure TJvTimeItem.SetBounds(Index: Integer; Value: Integer);\r\nbegin\r\n case Index of\r\n 0:\r\n if FRect.Left <> Value then\r\n begin\r\n OffsetRect(FRect, Value - FRect.Left, 0);\r\n Date := FParent.FTimeLine.DateAtPos(FRect.Left);\r\n FParent.FTimeLine.Invalidate;\r\n end;\r\n 1:\r\n if FRect.Top <> Value then\r\n begin\r\n FParent.FTimeLine.UpdateOffset;\r\n if Value < FParent.FTimeLine.FItemOffset then\r\n Value := FParent.FTimeLine.FItemOffset;\r\n OffsetRect(FRect, 0, Value - FRect.Top);\r\n Level := FParent.FTimeLine.LevelAtPos(FRect.Top);\r\n FParent.FTimeLine.Invalidate;\r\n end;\r\n end;\r\nend;\r\n\r\n//=== { TJvTimeItems } =======================================================\r\n\r\nconstructor TJvTimeItems.Create(TimeLine: TJvCustomTimeLine);\r\nbegin\r\n inherited Create(TJvTimeItem);\r\n FTimeLine := TimeLine;\r\nend;\r\n\r\nfunction TJvTimeItems.Add: TJvTimeItem;\r\nbegin\r\n Result := TJvTimeItem(inherited Add);\r\n Update(Result);\r\nend;\r\n\r\nprocedure TJvTimeItems.Refresh;\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := 0 to Count - 1 do\r\n Items[I].Update;\r\nend;\r\n\r\nfunction TJvTimeItems.GetItem(Index: Integer): TJvTimeItem;\r\nbegin\r\n Result := TJvTimeItem(inherited GetItem(Index));\r\nend;\r\n\r\nprocedure TJvTimeItems.SetItem(Index: Integer; Value: TJvTimeItem);\r\nbegin\r\n inherited SetItem(Index, Value);\r\nend;\r\n\r\nfunction TJvTimeItems.GetOwner: TPersistent;\r\nbegin\r\n Result := FTimeLine;\r\nend;\r\n\r\nprocedure TJvTimeItems.Update(Item: TCollectionItem);\r\nbegin\r\n if Item <> nil then\r\n FTimeLine.UpdateItem(Item.Index, FTimeLine.Canvas)\r\n else\r\n FTimeLine.UpdateItems;\r\nend;\r\n\r\n//=== { TJvTLScrollBtn } =====================================================\r\n\r\nconstructor TJvTLScrollBtn.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n ControlStyle := ControlStyle + [csCaptureMouse, csClickEvents, csOpaque] -\r\n [csDoubleClicks];\r\nend;\r\n\r\n{$IFDEF JVCLThemesEnabled}\r\n\r\nprocedure TJvTLScrollBtn.MouseEnter(Control: TControl);\r\nbegin\r\n if ThemeServices.{$IFDEF RTL230_UP}Enabled{$ELSE}ThemesEnabled{$ENDIF RTL230_UP} and not (FMouseInControl) and not (csDesigning in ComponentState) then\r\n begin\r\n FMouseInControl := True;\r\n Invalidate;\r\n end;\r\n inherited MouseEnter(Control);\r\nend;\r\n\r\nprocedure TJvTLScrollBtn.MouseLeave(Control: TControl);\r\nbegin\r\n inherited MouseLeave(Control);\r\n if ThemeServices.{$IFDEF RTL230_UP}Enabled{$ELSE}ThemesEnabled{$ENDIF RTL230_UP} and FMouseInControl then\r\n begin\r\n FMouseInControl := False;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\n{$ENDIF JVCLThemesEnabled}\r\n\r\nprocedure TJvTLScrollBtn.Paint;\r\nconst\r\n Directions: array [TJvScrollArrow] of Integer =\r\n (DFCS_SCROLLLEFT, DFCS_SCROLLRIGHT, DFCS_SCROLLUP, DFCS_SCROLLDOWN);\r\n CFlat: array [Boolean] of Word = (0, DFCS_FLAT);\r\n CPushed: array [Boolean] of Word = (0, DFCS_PUSHED);\r\n{$IFDEF JVCLThemesEnabled}\r\nvar\r\n Button: TThemedScrollBar;\r\n Details: TThemedElementDetails;\r\n{$ENDIF JVCLThemesEnabled}\r\nbegin\r\n if TimeLine = nil then\r\n Exit;\r\n if not Visible then\r\n Exit;\r\n\r\n {$IFDEF JVCLThemesEnabled}\r\n if ThemeServices.{$IFDEF RTL230_UP}Enabled{$ELSE}ThemesEnabled{$ENDIF RTL230_UP} then\r\n begin\r\n if FPushed then\r\n Button := tsArrowBtnLeftPressed\r\n else\r\n if FMouseInControl then\r\n Button := tsArrowBtnLeftHot\r\n else\r\n Button := tsArrowBtnLeftNormal;\r\n\r\n case Direction of\r\n scrollRight:\r\n Button := TThemedScrollBar(Ord(tsArrowBtnRightNormal) + Ord(Button) - Ord(tsArrowBtnLeftNormal));\r\n scrollUp:\r\n Button := TThemedScrollBar(Ord(tsArrowBtnUpNormal) + Ord(Button) - Ord(tsArrowBtnLeftNormal));\r\n scrollDown:\r\n Button := TThemedScrollBar(Ord(tsArrowBtnDownNormal) + Ord(Button) - Ord(tsArrowBtnLeftNormal));\r\n end;\r\n Details := ThemeServices.GetElementDetails(Button);\r\n ThemeServices.DrawElement(Canvas.Handle, Details, Rect(0, 0, Width, Height));\r\n end\r\n else\r\n {$ENDIF JVCLThemesEnabled}\r\n // TimeLine.FSelectedItem := nil; { fixes begindrag bug ? }\r\n DrawFrameControl(Canvas.Handle, Rect(0, 0, Width, Height), DFC_SCROLL,\r\n CFlat[Flat] or CPushed[FPushed] or Directions[Direction]);\r\nend;\r\n\r\nprocedure TJvTLScrollBtn.UpdatePlacement;\r\nbegin\r\n if TimeLine = nil then\r\n Exit;\r\n TimeLine.UpdateOffset;\r\n case FDirection of\r\n scrollLeft:\r\n begin\r\n SetBounds(FScrollEdgeOffset, TimeLine.Height - FScrollEdgeOffset -\r\n TimeLine.FScrollHeight,\r\n TimeLine.FScrollWidth, TimeLine.FScrollHeight);\r\n Anchors := [akLeft, akBottom];\r\n end;\r\n scrollRight:\r\n begin\r\n SetBounds(TimeLine.Width - FScrollEdgeOffset - TimeLine.FScrollWidth * 2,\r\n TimeLine.Height - FScrollEdgeOffset - TimeLine.FScrollHeight,\r\n TimeLine.FScrollWidth, TimeLine.FScrollHeight);\r\n Anchors := [akRight, akBottom];\r\n end;\r\n scrollUp:\r\n begin\r\n Anchors := [];\r\n SetBounds(TimeLine.Width - FScrollEdgeOffset - TimeLine.FScrollWidth,\r\n TimeLine.FItemOffset + FScrollEdgeOffset,\r\n TimeLine.FScrollWidth, TimeLine.FScrollHeight);\r\n Anchors := [akRight, akTop];\r\n end;\r\n scrollDown:\r\n begin\r\n SetBounds(TimeLine.Width - FScrollEdgeOffset - TimeLine.FScrollWidth,\r\n TimeLine.Height - FScrollEdgeOffset - TimeLine.FScrollHeight * 2,\r\n TimeLine.FScrollWidth, TimeLine.FScrollHeight);\r\n Anchors := [akRight, akBottom];\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvTLScrollBtn.SetDirection(const Value: TJvScrollArrow);\r\nbegin\r\n FDirection := Value;\r\n if (TimeLine <> nil) and (TimeLine.Parent <> nil )then\r\n begin\r\n UpdatePlacement;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvTLScrollBtn.SetFlat(const Value: Boolean);\r\nbegin\r\n if FFlat <> Value then\r\n begin\r\n FFlat := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvTLScrollBtn.SetTimeLine(const Value: TJvCustomTimeLine);\r\nbegin\r\n FTimeLine := Value;\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvTLScrollBtn.MouseDown(Button: TMouseButton;\r\n Shift: TShiftState; X, Y: Integer);\r\nbegin\r\n inherited MouseDown(Button, Shift, X, Y);\r\n if RepeatClick then\r\n begin\r\n if FTimer = nil then\r\n FTimer := TTimer.Create(Self);\r\n\r\n FTimer.OnTimer := OnTimer;\r\n FTimer.Interval := FInitRepeatPause;\r\n FTimer.Enabled := True;\r\n end;\r\n FPushed := True;\r\n Invalidate;\r\n // Click;\r\nend;\r\n\r\nprocedure TJvTLScrollBtn.MouseUp(Button: TMouseButton; Shift: TShiftState;\r\n X, Y: Integer);\r\nbegin\r\n inherited MouseUp(Button, Shift, X, Y);\r\n FPushed := False;\r\n Invalidate;\r\n if FTimer <> nil then\r\n FTimer.Enabled := False;\r\nend;\r\n\r\nprocedure TJvTLScrollBtn.Click;\r\nvar\r\n ScrollPos: Integer;\r\n ScrollCode: TScrollCode;\r\n ShiftState: TShiftState;\r\n KeyState: TKeyboardState;\r\n\r\n function GetScrollCode(LargeChange: Boolean): TScrollCode;\r\n begin\r\n case Direction of\r\n scrollLeft:\r\n if LargeChange then\r\n Result := scPageUp\r\n else\r\n Result := scLineUp;\r\n scrollRight:\r\n if LargeChange then\r\n Result := scPageDown\r\n else\r\n Result := scLineDown;\r\n scrollUp: Result := scLineUp;\r\n else\r\n Result := scLineDown;\r\n end;\r\n end;\r\n\r\nbegin\r\n if TimeLine = nil then\r\n Exit;\r\n\r\n GetKeyboardState(KeyState);\r\n ShiftState := KeyboardStateToShiftState(KeyState);\r\n\r\n ScrollCode := GetScrollCode(ssCtrl in ShiftState);\r\n TimeLine.FLastScrollCode := ScrollCode;\r\n case Direction of\r\n scrollLeft:\r\n begin\r\n if ssCtrl in ShiftState then\r\n TimeLine.PrevYear\r\n else\r\n TimeLine.PrevMonth;\r\n ScrollPos := Trunc(TimeLine.FirstVisibleDate);\r\n TimeLine.HorzScroll(ScrollCode, ScrollPos);\r\n TimeLine.SetFirstDate(ScrollPos);\r\n end;\r\n scrollRight:\r\n begin\r\n if ssCtrl in ShiftState then\r\n TimeLine.NextYear\r\n else\r\n TimeLine.NextMonth;\r\n ScrollPos := Trunc(TimeLine.FirstVisibleDate);\r\n TimeLine.HorzScroll(ScrollCode, ScrollPos);\r\n TimeLine.SetFirstDate(ScrollPos);\r\n end;\r\n scrollUp:\r\n begin\r\n if TimeLine.FTopLevel > 0 then\r\n ScrollPos := TimeLine.FTopLevel - 1;\r\n TimeLine.VertScroll(ScrollCode, ScrollPos);\r\n if ScrollPos >= 0 then\r\n TimeLine.SetTopLevel(ScrollPos);\r\n end;\r\n scrollDown:\r\n begin\r\n ScrollPos := TimeLine.FTopLevel + 1;\r\n TimeLine.VertScroll(ScrollCode, ScrollPos);\r\n if (ScrollPos >= 0) then\r\n TimeLine.SetTopLevel(ScrollPos);\r\n end;\r\n end;\r\n if TimeLine.CanFocus then\r\n TimeLine.SetFocus;\r\n inherited;\r\nend;\r\n\r\nprocedure TJvTLScrollBtn.OnTimer(Sender: TObject);\r\nbegin\r\n FTimer.Interval := FRepeatPause;\r\n if FPushed and MouseCapture then\r\n try\r\n Click;\r\n except\r\n FTimer.Enabled := False;\r\n raise;\r\n end;\r\nend;\r\n\r\n//=== { TJvCustomTimeLine } ==================================================\r\n\r\nconstructor TJvCustomTimeLine.Create(AOwner: TComponent);\r\nvar\r\n Bmp: TBitmap;\r\nbegin\r\n inherited Create(AOwner);\r\n FStates := [];\r\n FOldX := -1;\r\n\r\n FCanvas := TControlCanvas.Create;\r\n FCanvas.Control := Self;\r\n FCanvas.Pen.Color := clBlack;\r\n FCanvas.Pen.Mode := pmNotXor;\r\n FCanvas.Pen.Style := psDot;\r\n\r\n Bmp := TBitmap.Create;\r\n FItemHintImageList := TCustomImageList.CreateSize(14, 6);\r\n try\r\n Bmp.LoadFromResourceName(HInstance, 'JvCustomTimeLineITEMLEFT');\r\n FItemHintImageList.Add(Bmp, nil);\r\n Bmp.Assign(nil); // fixes GDI resource leak\r\n Bmp.LoadFromResourceName(HInstance, 'JvCustomTimeLineITEMRIGHT');\r\n FItemHintImageList.Add(Bmp, nil);\r\n finally\r\n Bmp.Free;\r\n end;\r\n FSupportsColor := clBtnFace;\r\n DoubleBuffered := True;\r\n FBmp := TBitmap.Create;\r\n FList := TList.Create;\r\n FHelperYears := True;\r\n ControlStyle := [csOpaque, csClickEvents, csDoubleClicks,\r\n csCaptureMouse, csDisplayDragImage];\r\n FBorderStyle := bsSingle;\r\n Color := clWhite;\r\n FYearList := TList.Create;\r\n FScrollArrows := [scrollLeft..scrollDown];\r\n FSupportLines := False;\r\n FTopOffset := 21;\r\n FShowDays := False;\r\n FItemHeight := 12;\r\n FTopLevel := 0;\r\n FStyle := tlDefault;\r\n FShowItemHint := False;\r\n FShowHiddenItemHints := True;\r\n FFlat := False;\r\n FYearWidth := 140;\r\n FMonthWidth := 12;\r\n FMultiSelect := False;\r\n FDragLine := True;\r\n FTimeItems := TJvTimeItems.Create(Self);\r\n FImageChangeLink := TChangeLink.Create;\r\n FImageChangeLink.OnChange := ImagesChanged;\r\n FYearFont := TFont.Create;\r\n FYearFont.Size := 18;\r\n FYearFont.OnChange := DoYearFontChange;\r\n FNewHeight := 0;\r\n FAutoSize := False;\r\n FScrollWidth := GetSystemMetrics(SM_CXHSCROLL);\r\n FScrollHeight := GetSystemMetrics(SM_CXVSCROLL);\r\n UpdateOffset;\r\n Align := alTop;\r\n Height := 120;\r\n SetFirstDate(Date);\r\nend;\r\n\r\ndestructor TJvCustomTimeLine.Destroy;\r\nbegin\r\n FDragImages.Free;\r\n FCanvas.Free;\r\n FYearList.Free;\r\n FBmp.Free;\r\n FList.Free;\r\n FTimeItems.Free;\r\n FImageChangeLink.Free;\r\n FYearFont.Free;\r\n FItemHintImageList.Free;\r\n inherited Destroy;\r\nend;\r\nprocedure TJvCustomTimeLine.DoYearFontChange(Sender: TObject);\r\nbegin\r\n Invalidate;\r\nend;\r\n\r\n\r\nprocedure TJvCustomTimeLine.CreateWnd;\r\nvar\r\n I: TJvScrollArrow;\r\nbegin\r\n inherited CreateWnd;\r\n for I := Low(TJvScrollArrow) to High(TJvScrollArrow) do\r\n begin\r\n if FArrows[I] = nil then\r\n begin\r\n FArrows[I] := TJvTLScrollBtn.Create(Self);\r\n FArrows[I].Parent := Self;\r\n FArrows[I].TimeLine := Self;\r\n FArrows[I].Height := FScrollHeight;\r\n FArrows[I].Width := FScrollWidth;\r\n FArrows[I].Direction := I;\r\n FArrows[I].RepeatClick := I in [scrollLeft, scrollRight];\r\n end\r\n else\r\n FArrows[I].UpdatePlacement;\r\n end;\r\nend;\r\n\r\n\r\n\r\n\r\nprocedure TJvCustomTimeLine.UpdateOffset;\r\nbegin\r\n FItemOffset := FTopOffset + FYearTextTop + Abs(FYearFont.Height) * 2;\r\nend;\r\n\r\nprocedure TJvCustomTimeLine.SetHelperYears(Value: Boolean);\r\nbegin\r\n if FHelperYears <> Value then\r\n begin\r\n FHelperYears := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomTimeLine.SetFlat(Value: Boolean);\r\nbegin\r\n if FFlat <> Value then\r\n begin\r\n FFlat := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomTimeLine.SetScrollArrows(Value: TJvScrollArrows);\r\nbegin\r\n if FScrollArrows <> Value then\r\n begin\r\n FScrollArrows := Value;\r\n DrawScrollButtons;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomTimeLine.DrawScrollButtons;\r\nvar\r\n I: TJvScrollArrow;\r\nbegin\r\n if FArrows[scrollLeft] = nil then\r\n Exit;\r\n for I := Low(TJvScrollArrow) to High(TJvScrollArrow) do\r\n FArrows[I].Flat := Flat;\r\n FArrows[scrollLeft].Visible := scrollLeft in ScrollArrows;\r\n FArrows[scrollRight].Visible := scrollRight in ScrollArrows;\r\n FArrows[scrollUp].Visible :=\r\n (scrollUp in ScrollArrows) and (FTopLevel > 0);\r\n FArrows[scrollDown].Visible :=\r\n (scrollDown in ScrollArrows) and (FNewHeight >= Height) and not AutoSize ;\r\nend;\r\n\r\nprocedure TJvCustomTimeLine.SetBorderStyle(Value: TBorderStyle);\r\nbegin\r\n if FBorderStyle <> Value then\r\n begin\r\n FBorderStyle := Value;\r\n RecreateWnd;\r\n end;\r\nend;\r\n\r\n\r\nprocedure TJvCustomTimeLine.SetTopLevel(Value: Integer);\r\nbegin\r\n if FTopLevel <> Value then\r\n begin\r\n FTopLevel := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomTimeLine.SetTopOffset(Value: Integer);\r\nbegin\r\n if FTopOffset <> Value then\r\n begin\r\n FTopOffset := Value;\r\n UpdateOffset;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomTimeLine.SetMultiSelect(Value: Boolean);\r\nbegin\r\n if FMultiSelect <> Value then\r\n begin\r\n FMultiSelect := Value;\r\n if not FMultiSelect then\r\n HighLiteItem(Selected);\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomTimeLine.SetYearFont(Value: TFont);\r\nbegin\r\n FYearFont.Assign(Value);\r\n UpdateOffset;\r\n // Invalidate;\r\nend;\r\n\r\nprocedure TJvCustomTimeLine.SetYearWidth(Value: TJvYearWidth);\r\nbegin\r\n if FYearWidth <> Value then\r\n begin\r\n FYearWidth := Value;\r\n FMonthWidth := FYearWidth / 12;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomTimeLine.SetFirstDate(Value: TDate);\r\nvar\r\n Y, M, D: Word;\r\nbegin\r\n DecodeDate(Value, Y, M, D);\r\n Value := EncodeDate(Y, M, 1);\r\n if Trunc(FFirstDate) <> Trunc(Value) then\r\n begin\r\n FFirstDate := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomTimeLine.SetTimeItems(Value: TJvTimeItems);\r\nbegin\r\n FTimeItems.Assign(Value);\r\nend;\r\n\r\nprocedure TJvCustomTimeLine.SetImages(Value: TCustomImageList);\r\nbegin\r\n if ReplaceImageListReference(Self, Value, FImages, FImageChangeLink) then\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvCustomTimeLine.SetSelectedItem(Value: TJvTimeItem);\r\nbegin\r\n if FSelectedItem <> Value then\r\n begin\r\n if Value <> nil then\r\n Value.Selected := True;\r\n UpdateItems;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomTimeLine.SetStyle(Value: TJvTimeLineStyle);\r\nbegin\r\n if FStyle <> Value then\r\n begin\r\n FStyle := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomTimeLine.SetItemHeight(Value: Integer);\r\nbegin\r\n if FItemHeight <> Value then\r\n begin\r\n FItemHeight := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomTimeLine.SetShowMonths(Value: Boolean);\r\nbegin\r\n if FShowMonths <> Value then\r\n begin\r\n FShowMonths := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomTimeLine.SetShowDays(Value: Boolean);\r\nbegin\r\n if FShowDays <> Value then\r\n begin\r\n FShowDays := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomTimeLine.SetSupportLines(Value: Boolean);\r\nbegin\r\n if FSupportLines <> Value then\r\n begin\r\n FSupportLines := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomTimeLine.ImagesChanged(Sender: TObject);\r\nbegin\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvCustomTimeLine.Notification(AComponent: TComponent;\r\n Operation: TOperation);\r\nbegin\r\n inherited Notification(AComponent, Operation);\r\n if (Operation = opRemove) and (AComponent = FImages) then\r\n Images := nil;\r\nend;\r\n\r\nprocedure TJvCustomTimeLine.MouseDown(Button: TMouseButton; Shift: TShiftState;\r\n X, Y: Integer);\r\nvar\r\n // Copied a lot from (Mike Linschke's) virtualtree.\r\n // Some stuff maybe unnecessairy or overkill/wrong.\r\n\r\n IsHit, // the node's caption or images are hit\r\n ItemSelected, // the new node (if any) is selected\r\n ShiftEmpty: Boolean; // ShiftState = []\r\n ShiftState: TShiftState;\r\n LastSelected: TJvTimeItem;\r\n LSelectedItem: TJvTimeItem;\r\nbegin\r\n //OutputDebugString('MouseDown');\r\n if Button = mbLeft then\r\n Include(FStates, tlMouseDown);\r\n\r\n // Get the currently focused node to make multiple multi-selection blocks possible.\r\n LastSelected := FSelectedItem;\r\n ShiftState := Shift * [ssCtrl, ssShift];\r\n ShiftEmpty := ShiftState = [];\r\n FAutoDrag := (DragMode = dmAutomatic) or Dragging;\r\n LSelectedItem := ItemAtPos(X, Y);\r\n IsHit := Assigned(LSelectedItem);\r\n ItemSelected := IsHit; // and LSelectedItem.Selected;\r\n\r\n if ItemSelected and ItemMoving(LSelectedItem) then\r\n begin\r\n FStartPos := Point(X, Y);\r\n FLineVisible := True;\r\n end\r\n else\r\n LSelectedItem := nil;\r\n\r\n // pending clearance\r\n if MultiSelect and ShiftEmpty and IsHit and FAutoDrag then\r\n Include(FStates, tlClearPending);\r\n\r\n\r\n if (not IsHit and MultiSelect and ShiftEmpty) or\r\n (IsHit and (ShiftEmpty or not MultiSelect)) then\r\n begin\r\n if ItemSelected then\r\n begin\r\n ClearSelection;\r\n AddToSelection(LSelectedItem);\r\n end\r\n else\r\n ClearSelection;\r\n end;\r\n\r\n // focus change\r\n if not Focused and CanFocus then\r\n SetFocus;\r\n\r\n // Handle selection and node focus change.\r\n if IsHit then\r\n begin\r\n if MultiSelect and not Dragging and not ShiftEmpty then\r\n HandleClickSelection(LastSelected, LSelectedItem, ShiftState)\r\n else\r\n begin\r\n if ShiftEmpty then\r\n FRangeAnchor := LSelectedItem;\r\n\r\n // If the hit node is not yet selected then do it now.\r\n if not ItemSelected then\r\n AddToSelection(LSelectedItem);\r\n end;\r\n\r\n // Drag'n drop initiation\r\n // If we lost focus in the interim the button states would be cleared in WM_KILLFOCUS.\r\n if FAutoDrag then\r\n BeginDrag(False);\r\n end;\r\n\r\n inherited MouseDown(Button, Shift, X, Y);\r\n\r\n if (Dragging or FAutoDrag) and FLineVisible and (tlMouseDown in FStates) and\r\n not (tlDragPending in FStates) then\r\n MoveDragLine(X);\r\nend;\r\n\r\nfunction TJvCustomTimeLine.HasMoved(P: TPoint): Boolean;\r\nbegin\r\n Result := FAutoDrag or Dragging and ((Abs(FStartPos.X - P.X) > 10) or (Abs(FStartPos.Y - P.Y) > ItemHeight div 2));\r\nend;\r\n\r\nprocedure TJvCustomTimeLine.MouseUp(Button: TMouseButton; Shift: TShiftState; X,\r\n Y: Integer);\r\nvar\r\n ReselectFocusedNode: Boolean;\r\n FNewDate: TDateTime;\r\n FNewLevel: Integer;\r\nbegin\r\n if (Button = mbLeft) and (tlMouseDown in FStates) then\r\n Exclude(FStates, tlMouseDown)\r\n else\r\n begin\r\n inherited MouseUp(Button, Shift, X, Y);\r\n Exit;\r\n end;\r\n\r\n //OutputDebugString('MouseUp');\r\n if not (tlDragPending in FStates) then\r\n begin\r\n // Don't respond to right/mid clicks\r\n if not (tlMouseDown in FStates) then\r\n MoveDragLine(-1);\r\n\r\n if tlClearPending in FStates then\r\n begin\r\n ReselectFocusedNode := Assigned(FSelectedItem) and FSelectedItem.Selected;\r\n ClearSelection;\r\n if ReselectFocusedNode then\r\n AddToSelection(FSelectedItem);\r\n Invalidate;\r\n end;\r\n if Assigned(FSelectedItem) and HasMoved(Point(X, Y)) then\r\n begin\r\n FNewDate := DateAtPos(X);\r\n FNewLevel := LevelAtPos(Y);\r\n ItemMoved(FSelectedItem, FNewDate, FNewLevel);\r\n FSelectedItem.Date := FNewDate;\r\n FSelectedItem.Level := FNewLevel;\r\n Invalidate;\r\n end;\r\n FStates := FStates - [tlClearPending];\r\n end;\r\n //else\r\n //OutputDebugString('Drag pending');\r\n\r\n inherited MouseUp(Button, Shift, X, Y);\r\n FAutoDrag := False;\r\nend;\r\n\r\nprocedure TJvCustomTimeLine.MouseMove(Shift: TShiftState; X, Y: Integer);\r\nbegin\r\n if (FStates * [tlDragging, tlMouseDown] <> []) and FLineVisible and FAutoDrag then\r\n begin\r\n //OutputDebugString('Move MouseDown');\r\n MoveDragLine(X);\r\n end;\r\n UpdateItemHint(X,Y);\r\n if not ItemMouseMove(X, Y) then\r\n inherited MouseMove(Shift, X, Y);\r\nend;\r\n\r\nprocedure TJvCustomTimeLine.DrawDragLine(X: Integer);\r\nbegin\r\n if not DragLine then\r\n Exit;\r\n FCanvas.MoveTo(X, 0);\r\n FCanvas.LineTo(X, ClientHeight);\r\nend;\r\n\r\nprocedure TJvCustomTimeLine.MoveDragLine(ANewX: Integer);\r\nbegin\r\n if FOldX <> ANewX then\r\n begin\r\n //OutputDebugString(PChar(Format('Old %D New %D', [FOldx, ANewX])));\r\n\r\n // We're drawing directly on the canvas, thus everytime the screen is\r\n // updated (because for example an item is selected) it may erase\r\n // some of the lines we already have drawn\r\n //\r\n // Thus call UpdateWindow(Handle) (same effect as Repaint) which will\r\n // draw all outstanding paint events.\r\n //\r\n // The screen will then not be updated until we release the mouse.\r\n\r\n if FOldX = -1 then\r\n UpdateWindow(Handle);\r\n\r\n if FOldX <> -1 then\r\n DrawDragLine(FOldX);\r\n\r\n if ANewX <> -1 then\r\n DrawDragLine(ANewX);\r\n\r\n FOldX := ANewX;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomTimeLine.AutoLevels(Complete, ResetLevels: Boolean);\r\nvar\r\n I, J, K, Count: Integer;\r\nbegin\r\n if csDestroying in ComponentState then\r\n Exit;\r\n BeginUpdate;\r\n try\r\n FList.Clear;\r\n\r\n Count := Items.Count - 1;\r\n for I := 0 to Count do\r\n begin\r\n if ResetLevels then\r\n begin\r\n Items[I].Level := 0;\r\n UpdateItem(Items[I].Index, Canvas);\r\n end;\r\n FList.Add(Items[I]);\r\n end;\r\n\r\n FList.Sort(DateCompare);\r\n\r\n for I := 0 to Count do\r\n begin\r\n if Complete then\r\n K := 0\r\n else\r\n K := I + 1;\r\n for J := K to Count do\r\n if RectInRect(TJvTimeItem(FList[I]).FRect, TJvTimeItem(FList[J]).FRect) and\r\n (FList[I] <> FList[J]) then\r\n begin\r\n TJvTimeItem(FList[J]).Level := TJvTimeItem(FList[J]).Level + 1;\r\n UpdateItem(TJvTimeItem(FList[J]).Index, Canvas);\r\n end;\r\n end;\r\n finally\r\n EndUpdate;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomTimeLine.HighLiteItem(Item: TJvTimeItem);\r\nbegin\r\n if Assigned(Item) and not (csDestroying in ComponentState) then\r\n begin\r\n Item.Selected := True;\r\n UpdateItem(Item.Index, Canvas);\r\n end;\r\nend;\r\n\r\nfunction TJvCustomTimeLine.LevelAtPos(Pos: Integer): Integer;\r\nbegin\r\n if Pos <= FItemOffset then\r\n Result := FTopLevel\r\n else\r\n Result := (Pos - FItemOffset) div FItemHeight + FTopLevel\r\nend;\r\n\r\nfunction TJvCustomTimeLine.ItemAtPos(X, Y: Integer): TJvTimeItem;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := nil;\r\n for I := 0 to FTimeItems.Count - 1 do\r\n if PtInRect(FTimeItems[I].FRect, Point(X, Y)) then\r\n begin\r\n Result := FTimeItems[I];\r\n Exit;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomTimeLine.DrawDays(ACanvas: TCanvas; Days, StartAt: Integer);\r\nvar\r\n aDay, aStop, aStart: Extended;\r\n I: Integer;\r\nbegin\r\n if csDestroying in ComponentState then\r\n Exit;\r\n aDay := FMonthWidth / Days;\r\n aStop := FMonthWidth;\r\n aStart := aDay;\r\n ACanvas.Pen.Width := 1;\r\n ACanvas.Pen.Style := psSolid;\r\n\r\n if FMonthWidth >= 360 then\r\n DrawDayNumbers(ACanvas, Days, StartAt);\r\n I := 1;\r\n while (aStart < aStop) and (I < Days) do\r\n begin\r\n ACanvas.MoveTo(Trunc(StartAt + aStart), FTopOffset);\r\n ACanvas.LineTo(Trunc(StartAt + aStart), FTopOffset + FDayLineLength);\r\n aStart := aStart + aDay;\r\n Inc(I);\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomTimeLine.DrawDayNumbers(ACanvas: TCanvas; Days, StartAt:\r\n Integer);\r\nvar\r\n I: Integer;\r\n LRect: TRect;\r\n DayWidth: Extended;\r\n sDay: string;\r\nbegin\r\n if csDestroying in ComponentState then\r\n Exit;\r\n ACanvas.Font.Size := Font.Size - 2;\r\n DayWidth := FMonthWidth / Days;\r\n with ACanvas do\r\n for I := 1 to Days do\r\n begin\r\n sDay := IntToStr(I);\r\n LRect.Left := Round((I - 1) * DayWidth) + (StartAt + Round(DayWidth) div 2\r\n - TextWidth(sDay) div 2);\r\n LRect.Right := LRect.Left + TextWidth(sDay);\r\n LRect.Top := FTopOffset + FDayTextTop;\r\n LRect.Bottom := LRect.Top + TextHeight(sDay);\r\n DrawText(ACanvas.Handle, PChar(sDay), -1, LRect, DT_CENTER or DT_VCENTER or DT_SINGLELINE);\r\n\r\n end;\r\n ACanvas.Font.Size := Font.Size + 2;\r\nend;\r\n\r\nprocedure TJvCustomTimeLine.DrawMonth(ACanvas: TCanvas; StartAt, M: Integer);\r\nbegin\r\n if csDestroying in ComponentState then\r\n Exit;\r\n ACanvas.Pen.Width := 1;\r\n if (FYearWidth >= 140) or (M mod 3 = 1) then\r\n { draw every month only if it fits }\r\n begin\r\n ACanvas.MoveTo(StartAt, FTopOffset);\r\n ACanvas.LineTo(StartAt, FTopOffset + FMonthLineLength);\r\n end;\r\n ACanvas.Pen.Width := 1;\r\nend;\r\n\r\nprocedure TJvCustomTimeLine.DrawMonthName(ACanvas: TCanvas; Month, StartAt:\r\n Integer);\r\nvar\r\n LRect: TRect;\r\n AName: string;\r\nbegin\r\n if csDestroying in ComponentState then\r\n Exit;\r\n if FMonthWidth > 120 then\r\n AName := JclFormatSettings.LongMonthNames[Month]\r\n else\r\n AName := JclFormatSettings.ShortMonthNames[Month];\r\n\r\n with ACanvas do\r\n begin\r\n ACanvas.Font.Assign(Self.Font);\r\n LRect.Left := StartAt + Round(FMonthWidth) div 2 - TextWidth(AName) div 2;\r\n LRect.Right := LRect.Left + TextWidth(AName);\r\n LRect.Top := FTopOffset + FMonthTextTop;\r\n LRect.Bottom := LRect.Top + TextHeight(AName);\r\n DrawText(ACanvas.Handle, PChar(AName), -1, LRect, DT_CENTER or DT_VCENTER or DT_SINGLELINE);\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomTimeLine.DrawYear(ACanvas: TCanvas; StartAt: Integer; YR: string);\r\nvar\r\n LRect: TRect;\r\nbegin\r\n if csDestroying in ComponentState then\r\n Exit;\r\n ACanvas.Font := FYearFont;\r\n ACanvas.Pen.Width := 1;\r\n if FYearWidth <= 96 then\r\n YR := Copy(YR, Length(YR) - 1, Length(YR)); { skip 100's }\r\n LRect.Left := StartAt - ACanvas.TextWidth(YR) div 2;\r\n LRect.Top := FTopOffset + FYearTextTop;\r\n LRect.Right := StartAt + ACanvas.TextWidth(YR) div 2;\r\n LRect.Bottom := LRect.Top + ACanvas.TextHeight(YR);\r\n { draw vertical line }\r\n ACanvas.MoveTo(StartAt, FTopOffset);\r\n ACanvas.LineTo(StartAt, FTopOffset + FYearLineLength);\r\n { draw text }\r\n SetBkMode(ACanvas.Handle, Transparent);\r\n DrawText(ACanvas.Handle, PChar(YR), Length(YR), LRect,\r\n DT_CENTER or DT_VCENTER or DT_SINGLELINE);\r\n with ACanvas.Pen do\r\n begin\r\n Width := 1;\r\n Style := psSolid;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomTimeLine.DrawHorzSupports(ACanvas: TCanvas);\r\nvar\r\n I, J: Integer;\r\n Tmp: TColor;\r\nbegin\r\n if csDestroying in ComponentState then\r\n Exit;\r\n UpdateOffset;\r\n I := 0;\r\n J := FItemOffset - 4;\r\n Tmp := ACanvas.Pen.Color;\r\n ACanvas.Pen.Color := SupportsColor;\r\n while I < ClientWidth do\r\n begin\r\n ACanvas.MoveTo(I, FTopOffset + Abs(ACanvas.Font.Height) + 8);\r\n ACanvas.LineTo(I, ClientHeight);\r\n I := ClientWidth + 1;\r\n while J < ClientHeight do\r\n begin\r\n ACanvas.MoveTo(0, J);\r\n ACanvas.LineTo(ClientWidth, J);\r\n Inc(J, ItemHeight);\r\n end;\r\n end;\r\n ACanvas.Pen.Color := Tmp;\r\nend;\r\n\r\nprocedure TJvCustomTimeLine.DrawVertSupport(ACanvas: TCanvas; StartAt: Integer);\r\nvar\r\n Tmp: TColor;\r\nbegin\r\n if csDestroying in ComponentState then\r\n Exit;\r\n UpdateOffset;\r\n with ACanvas do\r\n begin\r\n Tmp := Pen.Color;\r\n Pen.Color := SupportsColor;\r\n Pen.Width := 1;\r\n MoveTo(StartAt, FItemOffset - 4);\r\n LineTo(StartAt, Height);\r\n Pen.Color := Tmp;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomTimeLine.DrawTimeLine(ACanvas: TCanvas);\r\nvar\r\n Y, M, D: Word;\r\n I, fYr: Integer;\r\n FirstYear: Boolean;\r\n LastDate: TDateTime;\r\n R: TRect;\r\n aShadowLeft, aShadowRight: string;\r\n\r\n procedure AdjustYears(var Y, M: Word);\r\n begin\r\n if M = 13 then\r\n begin\r\n Inc(Y);\r\n M := 1;\r\n end\r\n else\r\n if M = 0 then\r\n begin\r\n Dec(Y);\r\n M := 12;\r\n end;\r\n end;\r\n\r\nbegin\r\n if csDestroying in ComponentState then\r\n Exit;\r\n FYearList.Clear;\r\n UpdateOffset;\r\n { draw the top horizontal line }\r\n with ACanvas do\r\n begin\r\n Font := Self.Font;\r\n Brush.Color := Color;\r\n Pen.Color := Self.Font.Color;\r\n FillRect(ClientRect);\r\n MoveTo(0, FTopOffset);\r\n LineTo(Width, FTopOffset);\r\n // MoveTo(0, FTopOffset - 1);\r\n // LineTo(Width, FTopOffset - 1);\r\n end;\r\n\r\n { draw years and months }\r\n I := 0;\r\n DecodeDate(FFirstDate, Y, M, D);\r\n aShadowLeft := IntToStr(Y);\r\n fYr := Y;\r\n DecodeDate(GetLastDate, Y, M, D);\r\n aShadowRight := IntToStr(Y);\r\n SetBkMode(ACanvas.Handle, TRANSPARENT);\r\n LastDate := FFirstDate;\r\n FirstYear := True;\r\n while LastDate <= (GetLastDate + 5) do\r\n begin\r\n DecodeDate(LastDate, Y, M, D);\r\n if M <> 1 then\r\n begin { not a new year, so it's a month }\r\n DrawMonth(ACanvas, I, M);\r\n if FSupportLines and ((FYearWidth >= 140) or (M mod 3 = 1)) then\r\n DrawVertSupport(ACanvas, I);\r\n if FShowMonths and (FYearWidth >= 140) then\r\n DrawMonthName(ACanvas, M, I);\r\n if FShowDays and (FYearWidth >= 1200) then\r\n DrawDays(ACanvas, MonthDays[IsLeapYear(Y), M], I);\r\n end\r\n else\r\n begin { this is a new year }\r\n FYearList.Add(Pointer(I));\r\n if FirstYear then\r\n begin\r\n fYr := Y;\r\n FirstYear := False;\r\n end;\r\n if FSupportLines then\r\n DrawVertSupport(ACanvas, I);\r\n { draw text for january here }\r\n if FShowMonths and (FYearWidth >= 144) then\r\n DrawMonthName(ACanvas, M, I);\r\n if FShowDays and (FYearWidth >= 1200) then\r\n DrawDays(ACanvas, MonthDays[IsLeapYear(Y), M], I);\r\n end;\r\n Inc(I, Trunc(FMonthWidth));\r\n\r\n Inc(M);\r\n AdjustYears(Y, M);\r\n LastDate := EncodeDate(Y, M, 1);\r\n end;\r\n\r\n { draw years after all the others }\r\n if FHelperYears then\r\n begin\r\n ACanvas.Font := Self.Font;\r\n R := Rect(4, 4, ACanvas.TextWidth(aShadowLeft) + 8, FTopOffset);\r\n DrawText(ACanvas.Handle, PChar(aShadowLeft), -1, R, DT_VCENTER or\r\n DT_SINGLELINE);\r\n ACanvas.Font := Self.Font;\r\n R := Rect(Width - (ACanvas.TextWidth(aShadowRight) + 8), 4, Width,\r\n FTopOffset);\r\n DrawText(ACanvas.Handle, PChar(aShadowRight), -1, R,\r\n DT_VCENTER or DT_SINGLELINE);\r\n end;\r\n for I := 0 to FYearList.Count - 1 do\r\n begin\r\n DrawYear(ACanvas, Integer(FYearList[I]), IntToStr(fYr));\r\n Inc(fYr);\r\n end;\r\n if HorzSupports then\r\n DrawHorzSupports(ACanvas);\r\n UpdateItems;\r\n DrawScrollButtons;\r\n if FShowHiddenItemHints then\r\n begin\r\n DrawLeftItemHint(ACanvas);\r\n DrawRightItemHint(ACanvas);\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomTimeLine.DrawLeftItemHint(ACanvas: TCanvas);\r\nvar\r\n R: TRect;\r\nbegin\r\n if csDestroying in ComponentState then\r\n Exit;\r\n if HasItemsToLeft then\r\n begin\r\n R := FArrows[scrollLeft].BoundsRect;\r\n OffsetRect(R, 0, -FItemHintImageList.Height - 2);\r\n FItemHintImageList.Draw(ACanvas, R.Left, R.Top, 0);\r\n // R := Rect(FScrollEdgeOffset,Height - FScrollEdgeOffset - FScrollHeight * 2,Width,\r\n // Height);\r\n // SetBkMode(ACanvas.Handle,TRANSPARENT);\r\n // ACanvas.Font.Style := [fsBold];\r\n // DrawText(ACanvas.Handle,PChar('...'),-1,R,DT_SINGLELINE or DT_NOCLIP or DT_NOPREFIX);\r\n // ACanvas.TextRect(R,R.Left,R.Top,'...');\r\n (* // this should be 32 pixels high:\r\n UpdateOffset;\r\n R := Rect(4, FItemOffset div 2 - 8, 8, FItemOffset div 2 + 8);\r\n // R := Rect(2,FItemOffset * 2,6,ClientHeight - FItemOffset * 2);\r\n ACanvas.Brush.Color := clNavy;\r\n ACanvas.FillRect(R); *)\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomTimeLine.DrawRightItemHint(ACanvas: TCanvas);\r\nvar\r\n R: TRect;\r\nbegin\r\n if csDestroying in ComponentState then\r\n Exit;\r\n if HasItemsToRight then\r\n begin\r\n R := FArrows[scrollRight].BoundsRect;\r\n OffsetRect(R, 0, -FItemHintImageList.Height - 2);\r\n FItemHintImageList.Draw(ACanvas, R.Left, R.Top, 1);\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomTimeLine.DrawFocus;\r\nvar\r\n Tmp: TColor;\r\n // R: TRect;\r\nbegin\r\n if csDestroying in ComponentState then\r\n Exit;\r\n with Canvas do\r\n begin\r\n Tmp := Pen.Color;\r\n Pen.Color := clNavy;\r\n Pen.Width := 2;\r\n Brush.Style := bsClear;\r\n Rectangle(1, 1, ClientWidth, ClientHeight);\r\n Pen.Color := Tmp;\r\n Pen.Width := 1;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomTimeLine.Paint;\r\nbegin\r\n if (FUpdate <> 0) or (csDestroying in ComponentState) then\r\n Exit;\r\n DrawTimeLine(Canvas);\r\n if Focused then\r\n DrawFocus;\r\nend;\r\n\r\nprocedure TJvCustomTimeLine.MeasureItem(Item: TJvTimeItem; var ItemHeight:\r\n Integer);\r\nbegin\r\n if Assigned(FOnMeasureItem) and (Style = tlOwnerDrawVariable) then\r\n FOnMeasureItem(Self, Item, ItemHeight)\r\n else\r\n ItemHeight := FItemHeight;\r\nend;\r\n\r\nprocedure TJvCustomTimeLine.DrawItem(Item: TJvTimeItem; ACanvas: TCanvas; var R: TRect);\r\nbegin\r\n if Assigned(FOnDrawItem) and (FStyle in [tlOwnerDrawVariable, tlOwnerDrawFixed]) then\r\n FOnDrawItem(Self, ACanvas, Item, R)\r\n else\r\n begin\r\n ACanvas.Brush.Color := Item.Color;\r\n ACanvas.Font.Color := Item.TextColor;\r\n\r\n if Assigned(FImages) and (Item.ImageIndex > -1) then\r\n begin\r\n if FUpdate = 0 then\r\n begin\r\n ACanvas.Brush.Color := Color;\r\n ACanvas.FillRect(Rect(R.Left + Item.ImageOffset,\r\n R.Top, R.Left + Item.ImageOffset + FImages.Width,\r\n R.Top + FImages.Height));\r\n with FImages do\r\n Draw(ACanvas, R.Left + Item.ImageOffset, R.Top, Item.ImageIndex, Item.Enabled);\r\n end;\r\n Inc(R.Top, FImages.Height + 4); { adjust top to make room for text drawing }\r\n end;\r\n\r\n if FUpdate = 0 then\r\n begin\r\n if Item.Selected and Item.Enabled and ShowSelection then\r\n begin\r\n ACanvas.Brush.Color := clHighLight;\r\n ACanvas.Font.Color := clHighLightText;\r\n end\r\n else\r\n if not Item.Enabled then\r\n begin\r\n ACanvas.Brush.Color := Color;\r\n ACanvas.Font.Color := Color xor clWhite;\r\n end\r\n else\r\n begin\r\n ACanvas.Brush.Color := Item.Color;\r\n ACanvas.Font.Color := Item.TextColor;\r\n end;\r\n\r\n ACanvas.Pen.Color := Item.TextColor;\r\n if (Length(Item.Caption) > 0) then\r\n begin\r\n R.Bottom := Min(R.Top + ACanvas.TextHeight(Item.Caption), R.Bottom);\r\n\r\n ACanvas.Rectangle(R);\r\n R.Left := R.Left + 2;\r\n SetBkMode(ACanvas.Handle, TRANSPARENT);\r\n Windows.DrawTextEx(ACanvas.Handle, PChar(Item.Caption), Length(Item.Caption), R,\r\n DT_LEFT or DT_NOPREFIX or DT_SINGLELINE or DT_END_ELLIPSIS, nil);\r\n end\r\n else\r\n begin\r\n R.Bottom := Min(R.Top + ACanvas.TextHeight('Wq'), R.Bottom);\r\n ACanvas.Rectangle(R);\r\n if Item.Selected and Item.Enabled then\r\n ACanvas.DrawFocusRect(R);\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomTimeLine.VertScroll(ScrollCode: TScrollCode;\r\n var ScrollPos: Integer);\r\nbegin\r\n if Assigned(FOnVertScroll) then\r\n FOnVertScroll(Self, ScrollCode, ScrollPos);\r\nend;\r\n\r\nprocedure TJvCustomTimeLine.HorzScroll(ScrollCode: TScrollCode;\r\n var ScrollPos: Integer);\r\nbegin\r\n if Assigned(FOnHorzScroll) then\r\n FOnHorzScroll(Self, ScrollCode, ScrollPos);\r\nend;\r\n\r\nprocedure TJvCustomTimeLine.ItemClick(Item: TJvTimeItem);\r\nbegin\r\n if Assigned(FOnItemClick) then\r\n FOnItemClick(Self, Item);\r\nend;\r\n\r\nprocedure TJvCustomTimeLine.Size;\r\nbegin\r\n if Assigned(FOnSize) then\r\n FOnSize(Self);\r\nend;\r\n\r\nprocedure TJvCustomTimeLine.SaveItem(Item: TJvTimeItem; Stream: TStream);\r\nbegin\r\n if Assigned(FOnSaveItem) then\r\n FOnSaveItem(Self, Item, Stream);\r\nend;\r\n\r\nprocedure TJvCustomTimeLine.LoadItem(Item: TJvTimeItem; Stream: TStream);\r\nbegin\r\n if Assigned(FOnLoadItem) then\r\n FOnLoadItem(Self, Item, Stream);\r\nend;\r\n\r\nprocedure TJvCustomTimeLine.UpdateItem(Index: Integer; ACanvas: TCanvas);\r\nvar\r\n LHeight: Integer;\r\n LItem: TJvTimeItem;\r\n LRect: TRect;\r\nbegin\r\n UpdateOffset;\r\n LItem := FTimeItems[Index];\r\n ACanvas.Font := Font;\r\n LHeight := FItemHeight;\r\n\r\n MeasureItem(LItem, LHeight);\r\n\r\n LRect.Left := PosAtDate(LItem.Date);\r\n LRect.Top := FItemOffset + (LHeight * (LItem.Level - FTopLevel));\r\n LRect.Bottom := LRect.Top + LHeight;\r\n if LItem.WidthAs = asPixels then\r\n LRect.Right := LRect.Left + LItem.Width\r\n else\r\n LRect.Right := PosAtDate(LItem.Date + LItem.Width);\r\n\r\n FNewHeight := Max(LRect.Bottom + FTopOffset, FNewHeight);\r\n if (LItem.Level < FTopLevel) or not RectInRect(LRect, ClientRect) or (FUpdate <> 0) then\r\n Exit;\r\n LItem.FRect := LRect;\r\n DrawItem(LItem, ACanvas, LRect);\r\n LItem.FRect := LRect;\r\nend;\r\n\r\nprocedure TJvCustomTimeLine.UpdateItems;\r\nvar\r\n I: Integer;\r\nbegin\r\n if csDestroying in ComponentState then\r\n Exit;\r\n FNewHeight := 0;\r\n for I := 0 to FTimeItems.Count - 1 do\r\n UpdateItem(I, Canvas);\r\n if FAutoSize and (Align in [alTop, alBottom, alNone]) and\r\n (Height <> FNewHeight + FScrollHeight + 2) and (Items.Count > 0) then\r\n begin\r\n Height := FNewHeight + FScrollHeight + 2;\r\n Size;\r\n end;\r\nend;\r\n\r\n{ very approximate }\r\n\r\nfunction TJvCustomTimeLine.GetLastDate: TDate;\r\nbegin\r\n Result := FFirstDate + ((Width - 1) * (365.22 / (FYearWidth)));\r\nend;\r\n\r\nfunction Ceil(Value: Extended): Integer;\r\nbegin\r\n Result := Trunc(Value);\r\n if Frac(Value) > 0 then\r\n Inc(Result);\r\nend;\r\n\r\nfunction TJvCustomTimeLine.DateAtPos(Pos: Integer): TDateTime;\r\nvar\r\n YR, M, D: Word;\r\n em, xremain, xday: Integer;\r\nbegin\r\n em := Trunc(Pos / FMonthWidth); { elapsed months }\r\n xremain := Pos mod Trunc(FMonthWidth);\r\n DecodeDate(FFirstDate, YR, M, D);\r\n em := M + em;\r\n YR := YR + em div 12;\r\n em := em mod 12;\r\n if em < 1 then\r\n begin\r\n em := 12;\r\n Dec(YR);\r\n end;\r\n\r\n xday := Ceil(xremain * (MonthDays[IsLeapYear(YR), em] / FMonthWidth));\r\n\r\n if xday <= 0 then\r\n xday := 1\r\n else\r\n if xday > MonthDays[IsLeapYear(YR), em] then\r\n xday := MonthDays[IsLeapYear(YR), em];\r\n Result := EncodeDate(YR, em, xday);\r\nend;\r\n\r\nfunction TJvCustomTimeLine.PosAtDate(Date: TDateTime): Integer;\r\nvar\r\n M, D: Integer;\r\nbegin\r\n M := MonthCount(FFirstDate, Date);\r\n D := PixelsForDays(Date, Round(FMonthWidth));\r\n Result := Round((M * FMonthWidth + D) + FMonthWidth / 60);\r\n { add in a little to place in \"center\" }\r\nend;\r\n\r\nprocedure TJvCustomTimeLine.LoadFromFile(FileName: string);\r\nvar\r\n Stream: TFileStream;\r\nbegin\r\n Stream := TFileStream.Create(FileName, fmOpenRead);\r\n try\r\n LoadFromStream(Stream);\r\n finally\r\n Stream.Free;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomTimeLine.SaveToFile(FileName: string);\r\nvar\r\n Stream: TFileStream;\r\nbegin\r\n Stream := TFileStream.Create(FileName, fmCreate);\r\n try\r\n SaveToStream(Stream);\r\n finally\r\n Stream.Free;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomTimeLine.LoadFromStream(Stream: TStream);\r\nvar\r\n I: Integer;\r\n Ch: AnsiChar;\r\n S: string;\r\n UTF8Str: AnsiString;\r\n Item: TJvTimeItem;\r\nbegin\r\n I := 0;\r\n Item := Items.Add;\r\n while Stream.Position < Stream.Size do\r\n begin\r\n UTF8Str := '';\r\n Stream.Read(Ch, 1);\r\n while Ch <> Cr do\r\n begin\r\n UTF8Str := UTF8Str + Ch;\r\n Stream.Read(Ch, 1);\r\n end;\r\n S := UTF8ToString(UTF8Str);\r\n\r\n case I of\r\n 0: // Caption\r\n Item.Caption := S;\r\n 1: // Color\r\n Item.Color := StrToInt(S);\r\n 2: // Date\r\n Item.Date := StrToDateTime(S);\r\n 3: // Hint\r\n Item.Hint := S;\r\n 4: // ImageIndex\r\n Item.ImageIndex := StrToInt(S);\r\n 5: // Level\r\n Item.Level := StrToInt(S);\r\n 6: // Selected\r\n Item.Selected := Boolean(StrToInt(S));\r\n 7: // TextColor\r\n Item.TextColor := StrToInt(S);\r\n 8: // Width\r\n begin\r\n Item.Width := StrToInt(S);\r\n LoadItem(Item, Stream);\r\n I := -1;\r\n Item := Items.Add;\r\n end;\r\n end; { case }\r\n Inc(I);\r\n end;\r\n Item.Free; { always one too many }\r\nend;\r\n\r\nprocedure TJvCustomTimeLine.SaveToStream(Stream: TStream);\r\nvar\r\n I: Integer;\r\n S: string;\r\n UTF8Str: UTF8String;\r\nbegin\r\n for I := 0 to Items.Count - 1 do\r\n begin\r\n with Items[I] do\r\n begin\r\n S := Caption + Cr;\r\n UTF8Str := UTF8Encode(S);\r\n Stream.Write(UTF8Str[1], Length(UTF8Str));\r\n\r\n S := IntToStr(ColorToRGB(Color)) + Cr;\r\n UTF8Str := UTF8Encode(S);\r\n Stream.Write(UTF8Str[1], Length(UTF8Str));\r\n\r\n S := DateTimeToStr(Date) + Cr;\r\n UTF8Str := UTF8Encode(S);\r\n Stream.Write(UTF8Str[1], Length(UTF8Str));\r\n\r\n S := Hint + Cr;\r\n UTF8Str := UTF8Encode(S);\r\n Stream.Write(UTF8Str[1], Length(UTF8Str));\r\n\r\n S := IntToStr(ImageIndex) + Cr;\r\n UTF8Str := UTF8Encode(S);\r\n Stream.Write(UTF8Str[1], Length(UTF8Str));\r\n\r\n S := IntToStr(Level) + Cr;\r\n UTF8Str := UTF8Encode(S);\r\n Stream.Write(UTF8Str[1], Length(UTF8Str));\r\n\r\n S := IntToStr(Ord(Selected)) + Cr;\r\n UTF8Str := UTF8Encode(S);\r\n Stream.Write(UTF8Str[1], Length(UTF8Str));\r\n\r\n S := IntToStr(ColorToRGB(TextColor)) + Cr;\r\n UTF8Str := UTF8Encode(S);\r\n Stream.Write(UTF8Str[1], Length(UTF8Str));\r\n\r\n S := IntToStr(Width) + Cr;\r\n UTF8Str := UTF8Encode(S);\r\n Stream.Write(UTF8Str[1], Length(UTF8Str));\r\n\r\n { let the user save his data stuff }\r\n SaveItem(Items[I], Stream);\r\n end;\r\n end;\r\n UTF8Str := UTF8String(Cr);\r\n Stream.Write(UTF8Str[1], 1);\r\nend;\r\n\r\nprocedure TJvCustomTimeLine.BeginUpdate;\r\nbegin\r\n Inc(FUpdate);\r\nend;\r\n\r\nprocedure TJvCustomTimeLine.EndUpdate;\r\nbegin\r\n Dec(FUpdate);\r\n if FUpdate = 0 then\r\n Repaint;\r\nend;\r\n\r\nprocedure TJvCustomTimeLine.ItemMoved(Item: TJvTimeItem; var NewDate: TDateTime; var NewLevel: Integer);\r\nbegin\r\n if Assigned(FOnItemMoved) then\r\n FOnItemMoved(Self, Item, NewDate, NewLevel);\r\nend;\r\n\r\nfunction TJvCustomTimeLine.ItemMouseMove(X, Y: Integer): Boolean;\r\nvar\r\n AItem: TJvTimeItem;\r\nbegin\r\n Result := False;\r\n if Assigned(FOnItemMouseMove) then\r\n begin\r\n AItem := ItemAtPos(X, Y);\r\n if AItem <> nil then\r\n begin\r\n FOnItemMouseMove(Self, AItem, X, Y);\r\n Result := True;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJvCustomTimeLine.ItemMoving(Item: TJvTimeItem): Boolean;\r\nbegin\r\n Result := True;\r\n if Assigned(FOnItemMoving) then\r\n FOnItemMoving(Self, Item, Result);\r\nend;\r\n\r\n\r\nprocedure TJvCustomTimeLine.CNKeyDown(var Msg: TWMKeyDown);\r\nvar\r\n KeyState: TKeyboardState;\r\n ShiftState: TShiftState;\r\nbegin\r\n GetKeyboardState(KeyState);\r\n ShiftState := KeyboardStateToShiftState(KeyState);\r\n Msg.Result := 0;\r\n case Msg.CharCode of\r\n VK_LEFT:\r\n if ssCtrl in ShiftState then\r\n PrevYear\r\n else\r\n PrevMonth;\r\n VK_UP:\r\n if FArrows[scrollUp].Visible then\r\n TopLevel := TopLevel - 1;\r\n VK_RIGHT:\r\n if ssCtrl in ShiftState then\r\n NextYear\r\n else\r\n NextMonth;\r\n VK_DOWN:\r\n if FArrows[scrollDown].Visible then\r\n TopLevel := TopLevel + 1;\r\n else\r\n inherited;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomTimeLine.WMNCPaint(var Msg: TMessage);\r\nvar\r\n DC: HDC;\r\n RC, RW: TRect;\r\n ACanvas: TCanvas;\r\n {$IFDEF JVCLThemesEnabled}\r\n Details: TThemedElementDetails;\r\n {$ENDIF JVCLThemesEnabled}\r\nbegin\r\n if csDestroying in ComponentState then\r\n Exit;\r\n ACanvas := TCanvas.Create;\r\n { Get window DC that is clipped to the non-client area }\r\n DC := GetWindowDC(Handle);\r\n ACanvas.Handle := DC;\r\n try\r\n Windows.GetClientRect(Handle, RC);\r\n GetWindowRect(Handle, RW);\r\n MapWindowPoints(0, Handle, RW, 2);\r\n OffsetRect(RC, -RW.Left, -RW.Top);\r\n ExcludeClipRect(DC, RC.Left, RC.Top, RC.Right, RC.Bottom);\r\n { Draw borders in non-client area }\r\n OffsetRect(RW, -RW.Left, -RW.Top);\r\n {$IFDEF JVCLThemesEnabled}\r\n if ThemeServices.{$IFDEF RTL230_UP}Enabled{$ELSE}ThemesEnabled{$ENDIF RTL230_UP} then\r\n begin\r\n if FBorderStyle = bsSingle then\r\n begin\r\n Details := ThemeServices.GetElementDetails(teEditTextNormal);\r\n ThemeServices.DrawElement(ACanvas.Handle, Details, RW);\r\n ThemeServices.GetElementContentRect(ACanvas.Handle, Details, RW, RW);\r\n end;\r\n end\r\n else\r\n {$ENDIF JVCLThemesEnabled}\r\n if FBorderStyle = bsSingle then\r\n begin\r\n Frame3D(ACanvas, RW, clBtnShadow, clBtnHighlight, 1);\r\n Frame3D(ACanvas, RW, cl3dDKShadow, clBtnFace, 1);\r\n end\r\n else\r\n Frame3D(ACanvas, RW, Color, Color, 2);\r\n\r\n { Erase parts not drawn }\r\n IntersectClipRect(DC, RW.Left, RW.Top, RW.Right, RW.Bottom);\r\n Windows.FillRect(DC, RW, Brush.Handle);\r\n finally\r\n ACanvas.Handle := 0;\r\n ReleaseDC(Handle, DC);\r\n ACanvas.Free;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomTimeLine.WMNCCalcSize(var Msg: TWMNCCalcSize);\r\nbegin\r\n InflateRect(Msg.CalcSize_Params^.rgrc[0], -2, -2);\r\n inherited;\r\nend;\r\n\r\nprocedure TJvCustomTimeLine.CMEnter(var Msg: TWMNoParams);\r\nbegin\r\n if CanFocus then\r\n begin\r\n SetFocus;\r\n Invalidate;\r\n end;\r\n inherited;\r\nend;\r\n\r\nprocedure TJvCustomTimeLine.CMExit(var Msg: TWMNoParams);\r\nbegin\r\n if MouseCapture then\r\n ReleaseCapture;\r\n inherited;\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvCustomTimeLine.WMCancelMode(var Msg: TWMCancelMode);\r\nbegin\r\n FStates := FStates - [tlClearPending, tlDragPending];\r\n inherited;\r\nend;\r\n\r\nprocedure TJvCustomTimeLine.CMDrag(var Msg: TCMDrag);\r\nvar\r\n P: TPoint;\r\nbegin\r\n inherited;\r\n with Msg.DragRec^ do\r\n case Msg.DragMessage of\r\n dmDragEnter, dmDragLeave, dmDragMove:\r\n begin\r\n Exclude(FStates, tlDragPending);\r\n\r\n if Msg.DragMessage = dmDragEnter then\r\n begin\r\n // Maybe perform an MouseDown event?\r\n FLineVisible := True;\r\n Include(FStates, tlDragging);\r\n end;\r\n if Msg.DragMessage = dmDragLeave then\r\n begin\r\n // We're done; clean it up\r\n FStates := FStates - [tlDragging, tlDragPending];\r\n\r\n // Really finish it (See TBaseVirtualTree.DragFinished;)\r\n GetCursorPos(P);\r\n P := ScreenToClient(P);\r\n Perform(WM_LBUTTONUP, 0, {$IFDEF RTL230_UP}PointToLParam{$ELSE}LPARAM{$ENDIF RTL230_UP}(PointToSmallPoint(P)));\r\n end;\r\n\r\n if Msg.DragMessage = dmDragMove then\r\n begin\r\n P := ScreenToClient(Pos);\r\n DoDragOver(Source, P.X, P.Y, Msg.Result <> 0);\r\n end;\r\n end;\r\n dmDragDrop:\r\n if Assigned(FDragItem) then\r\n begin\r\n// P := ScreenToClient(Pos);\r\n// FDragItem.Date := DateAtPos(Pt.X);\r\n// FDragItem.Level := LevelAtPos(Pt.Y);\r\n FDragItem := nil;\r\n Invalidate;\r\n end;\r\n dmFindTarget:\r\n begin\r\n // Maybe perform an MouseDown event?\r\n\r\n if not (tlDragging in FStates) and not Assigned(FDragItem) then\r\n begin\r\n // Did the user click on an item?\r\n P := ScreenToClient(Pos);\r\n FDragItem := ItemAtPos(P.X, P.Y);\r\n\r\n // Set the dragitem as selected; don't care about shift/ctrl :)\r\n ClearSelection;\r\n AddToSelection(FDragItem);\r\n end;\r\n\r\n if FDragItem = nil then\r\n // The user did not click on an item.\r\n Msg.Result := 0\r\n else\r\n Msg.Result := LRESULT(Self);\r\n\r\n // This is a reliable place to check whether VCL drag has\r\n // really begun.\r\n if tlDragPending in FStates then\r\n begin\r\n FStates := FStates - [tlDragPending, tlClearPending];\r\n // Safety check\r\n if FDragItem <> nil then\r\n begin\r\n FStates := FStates + [tlDragging];\r\n FLineVisible := True;\r\n end;\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomTimeLine.SetAutoSize(Value: Boolean);\r\nbegin\r\n if FAutoSize <> Value then\r\n begin\r\n FAutoSize := Value;\r\n if FAutoSize then\r\n SetTopLevel(0);\r\n { if (Align in [alLeft,alRight,alClient]) then\r\n FAutoSize := False\r\n else}\r\n Invalidate;\r\n end;\r\nend;\r\n\r\n\r\n\r\nfunction TJvCustomTimeLine.HasItemsToLeft: Boolean;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := True;\r\n for I := 0 to Items.Count - 1 do\r\n if Items[I].Left <= 0 then\r\n Exit;\r\n Result := False;\r\nend;\r\n\r\nfunction TJvCustomTimeLine.HasItemsToRight: Boolean;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := True;\r\n for I := 0 to Items.Count - 1 do\r\n if Items[I].Left >= ClientWidth - 8 then\r\n Exit;\r\n Result := False;\r\nend;\r\n\r\nprocedure TJvCustomTimeLine.SetHorzSupport(const Value: Boolean);\r\nbegin\r\n if FHorzSupport <> Value then\r\n begin\r\n FHorzSupport := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomTimeLine.SetBounds(ALeft, ATop, AWidth, AHeight: Integer);\r\nvar\r\n I: TJvScrollArrow;\r\nbegin\r\n inherited SetBounds(ALeft, ATop, AWidth, AHeight);\r\n for I := Low(TJvScrollArrow) to High(TJvScrollArrow) do\r\n if FArrows[I] <> nil then\r\n FArrows[I].UpdatePlacement;\r\nend;\r\n\r\nfunction TJvCustomTimeLine.GetMonth: Word;\r\nvar\r\n M, D: Word;\r\nbegin\r\n DecodeDate(FFirstDate, Result, M, D);\r\nend;\r\n\r\nfunction TJvCustomTimeLine.GetYear: Word;\r\nvar\r\n Y, D: Word;\r\nbegin\r\n DecodeDate(FFirstDate, Y, Result, D);\r\nend;\r\n\r\nprocedure TJvCustomTimeLine.SetMonth(const Value: Word);\r\nvar\r\n Y, M, D: Word;\r\nbegin\r\n DecodeDate(FFirstDate, Y, M, D);\r\n M := Value;\r\n FFirstDate := EncodeDate(Y, M, D);\r\nend;\r\n\r\nprocedure TJvCustomTimeLine.SetYear(const Value: Word);\r\nvar\r\n Y, M, D: Word;\r\nbegin\r\n DecodeDate(FFirstDate, Y, M, D);\r\n Y := Value;\r\n FFirstDate := EncodeDate(Y, M, D);\r\nend;\r\n\r\nprocedure TJvCustomTimeLine.NextMonth;\r\nbegin\r\n //PRY 2002.06.04\r\n //SetFirstDate(IncMonth(FFirstDate));\r\n SetFirstDate(IncMonth(FFirstDate, 1));\r\nend;\r\n\r\nprocedure TJvCustomTimeLine.NextYear;\r\nbegin\r\n //PRY 2002.06.04\r\n //SetFirstDate(IncYear(FFirstDate));\r\n SetFirstDate(IncYear(FFirstDate, 1));\r\nend;\r\n\r\nprocedure TJvCustomTimeLine.PrevMonth;\r\nbegin\r\n SetFirstDate(IncMonth(FFirstDate, -1));\r\nend;\r\n\r\nprocedure TJvCustomTimeLine.PrevYear;\r\nbegin\r\n //PRY 2002.06.04\r\n //SetFirstDate(IncYear(FFirstDate, -1));\r\n SetFirstDate(IncYear(FFirstDate, -1));\r\nend;\r\n\r\nprocedure TJvCustomTimeLine.SetShowHiddenItemHints(const Value: Boolean);\r\nbegin\r\n if FShowHiddenItemHints <> Value then\r\n begin\r\n FShowHiddenItemHints := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomTimeLine.ItemDblClick(Item: TJvTimeItem);\r\nbegin\r\n if Assigned(FOnItemDblClick) then\r\n FOnItemDblClick(Self, Item);\r\nend;\r\n\r\nprocedure TJvCustomTimeLine.DblClick;\r\nvar\r\n Tmp: Boolean;\r\n P: TPoint;\r\nbegin\r\n Tmp := DragLine;\r\n try\r\n DragLine := False;\r\n inherited DblClick;\r\n if GetCursorPos(P) then\r\n begin\r\n P := ScreenToClient(P);\r\n FSelectedItem := ItemAtPos(P.X, P.Y);\r\n end;\r\n if Assigned(FSelectedItem) then\r\n begin\r\n FLineVisible := False;\r\n ItemDblClick(FSelectedItem);\r\n end;\r\n finally\r\n DragLine := Tmp;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomTimeLine.Click;\r\nvar\r\n P: TPoint;\r\nbegin\r\n inherited Click;\r\n if GetCursorPos(P) then\r\n begin\r\n P := ScreenToClient(P);\r\n FSelectedItem := ItemAtPos(P.X, P.Y);\r\n end;\r\n if Assigned(FSelectedItem) then\r\n begin\r\n ItemClick(FSelectedItem);\r\n //FLineVisible := False;\r\n end;\r\n Invalidate;\r\nend;\r\n\r\n\r\nprocedure TJvCustomTimeLine.DoDragOver(Source: TDragObject; X, Y: Integer;\r\n CanDrop: Boolean);\r\nbegin\r\n if (tlDragging in FStates) and FLineVisible then\r\n MoveDragLine(X);\r\nend;\r\n\r\n\r\nprocedure TJvCustomTimeLine.HandleClickSelection(LastFocused,\r\n NewItem: TJvTimeItem; Shift: TShiftState);\r\nbegin\r\n // Ctrl key down\r\n if ssCtrl in Shift then\r\n begin\r\n if ssShift in Shift then\r\n SelectItems(FRangeAnchor, NewItem, True)\r\n else\r\n begin\r\n FRangeAnchor := NewItem;\r\n if NewItem.Selected then\r\n RemoveFromSelection(NewItem)\r\n else\r\n AddToSelection(NewItem);\r\n end;\r\n end\r\n else\r\n if ssShift in Shift then\r\n begin\r\n FRangeAnchor := NewItem;\r\n AddToSelection(NewItem);\r\n end\r\n else\r\n begin\r\n // any other case\r\n if not NewItem.Selected then\r\n AddToSelection(NewItem);\r\n\r\n // assign new reference item\r\n FRangeAnchor := NewItem;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomTimeLine.AddToSelection(AItem: TJvTimeItem);\r\nbegin\r\n if not Assigned(AItem) then\r\n Exit;\r\n AItem.Selected := True;\r\n FSelectedItem := AItem;\r\nend;\r\n\r\nprocedure TJvCustomTimeLine.RemoveFromSelection(AItem: TJvTimeItem);\r\nbegin\r\n if not Assigned(AItem) then\r\n Exit;\r\n AItem.Selected := False;\r\n if FSelectedItem = AItem then\r\n FSelectedItem := nil;\r\nend;\r\n\r\nprocedure TJvCustomTimeLine.SelectItems(StartItem, EndItem: TJvTimeItem;\r\n AddOnly: Boolean);\r\nvar\r\n LowLevel, HighLevel: Integer;\r\n LowDate, HighDate: TDateTime;\r\n I: Integer;\r\n\r\n procedure SwapInt(var Int1, Int2: Integer);\r\n var\r\n I: Integer;\r\n begin\r\n I := Int1;\r\n Int1 := Int2;\r\n Int2 := I;\r\n end;\r\n\r\n procedure SwapDate(var Date1, Date2: TDateTime);\r\n var\r\n D: TDateTime;\r\n begin\r\n D := Date1;\r\n Date1 := Date2;\r\n Date2 := D;\r\n end;\r\n\r\nbegin\r\n // Called when mouseclick + [CTRL] + [SHIFT]\r\n //\r\n LowLevel := StartItem.Level;\r\n HighLevel := EndItem.Level;\r\n if LowLevel > HighLevel then\r\n SwapInt(LowLevel, HighLevel);\r\n\r\n LowDate := StartItem.Date;\r\n HighDate := EndItem.Date;\r\n if LowDate > HighDate then\r\n SwapDate(LowDate, HighDate);\r\n\r\n for I := 0 to Items.Count - 1 do\r\n with Items[I] do\r\n Selected := (AddOnly and Selected) or\r\n ((LowLevel <= Level) and (Level <= HighLevel) and\r\n (LowDate <= Date) and (Date <= HighDate));\r\nend;\r\n\r\nprocedure TJvCustomTimeLine.BeginDrag(Immediate: Boolean;\r\n Threshold: Integer);\r\nbegin\r\n Include(FStates, tlDragPending);\r\n inherited BeginDrag(Immediate, Threshold);\r\nend;\r\n\r\nprocedure TJvCustomTimeLine.ClearSelection;\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := 0 to Items.Count - 1 do\r\n Items[I].Selected := False;\r\n FSelectedItem := nil;\r\nend;\r\n\r\nfunction TJvCustomTimeLine.GetDragImages: TDragImageList;\r\nvar\r\n Bmp: TBitmap;\r\n P: TPoint;\r\n R: TRect;\r\n H: Integer;\r\nbegin\r\n GetCursorPos(P);\r\n P := ScreenToClient(P);\r\n\r\n FSelectedItem := ItemAtPos(P.X, P.Y);\r\n FreeAndNil(FDragImages);\r\n if (FSelectedItem <> nil) then\r\n begin\r\n Bmp := TBitmap.Create;\r\n try\r\n Bmp.PixelFormat := pf24bit;\r\n MeasureItem(FSelectedItem, H);\r\n Bmp.Width := FSelectedItem.FRect.Right - FSelectedItem.FRect.Left;\r\n Bmp.Height := H;\r\n FDragImages := TImageList.CreateSize(Bmp.Width, H);\r\n R := Rect(0, 0, Bmp.Width, H);\r\n DrawItem(FSelectedItem, Bmp.Canvas, R);\r\n FDragImages.AddMasked(Bmp, Bmp.TransparentColor);\r\n FDragImages.DragCursor := DragCursor;\r\n FDragImages.SetDragImage(0, 10, 10); // P.X-FSelectedItem.FRect.Left, P.Y-FSelectedItem.FRect.Top);\r\n finally\r\n Bmp.Free;\r\n end;\r\n end;\r\n Result := FDragImages;\r\nend;\r\n\r\n\r\nprocedure TJvCustomTimeLine.UpdateItemHint(X,Y: Integer);\r\nvar\r\n Ti: TJvTimeItem;\r\nbegin\r\n if ShowHint and ShowItemHint then\r\n begin\r\n Ti := ItemAtPos(X,Y);\r\n if (Ti <> nil) and (Ti.Hint <> '') then\r\n inherited Hint := Ti.Hint\r\n else\r\n inherited Hint := FOldHint;\r\n// if Application <> nil then // (p3) \"tracking\" hint\r\n// Application.ActivateHint(ClientToScreen(Point(X,Y)));\r\n end;\r\nend;\r\n\r\nfunction TJvCustomTimeLine.GetHint: string;\r\nbegin\r\n Result := inherited Hint;\r\nend;\r\n\r\nprocedure TJvCustomTimeLine.SetHint(const Value: string);\r\nbegin\r\n inherited Hint := Value;\r\n FOldHint := Value;\r\nend;\r\n\r\n\r\nprocedure TJvCustomTimeLine.SetShowSelection(const Value: Boolean);\r\nbegin\r\n if FShowSelection <> Value then\r\n begin\r\n FShowSelection := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomTimeLine.SetSupportsColor(const Value: TColor);\r\nbegin\r\n if FSupportsColor <> Value then\r\n begin\r\n FSupportsColor := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\n\r\n\r\n// initialization\r\n// SystemParametersInfo(SPI_GETKEYBOARDDELAY, 0, @FInitRepeatPause, 0);\r\n// SystemParametersInfo(SPI_GETKEYBOARDSPEED, 0, @FRepeatPause, 0);\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvTimer.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvTimer.PAS, released on 2002-07-04.\r\n\r\nThe Initial Developers of the Original Code are: Fedor Koshevnikov, Igor Pavluk and Serge Korolev\r\nCopyright (c) 1997, 1998 Fedor Koshevnikov, Igor Pavluk and Serge Korolev\r\nCopyright (c) 2001,2002 SGB Software\r\nAll Rights Reserved.\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvTimer.pas 13138 2011-10-26 23:17:50Z jfudickar $\r\n\r\nunit JvTimer;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, Messages, SysUtils, ExtCtrls, Classes;\r\n\r\ntype\r\n // TThreadPriority has been marked platform and we don't want the warning\r\n {$IFDEF RTL230_UP}{$IFDEF MSWINDOWS}{$WARNINGS OFF}TThreadPriority = Classes.TThreadPriority;{$WARNINGS ON}{$ENDIF RTL230_UP}{$ENDIF MSWINDOWS}\r\n\r\n TJvTimerEventTime = (tetPre, tetPost);\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64 or pidOSX32)]\r\n {$ENDIF RTL230_UP}\r\n TJvTimer = class(TComponent)\r\n private\r\n FEnabled: Boolean;\r\n FInterval: Cardinal;\r\n FOnTimer: TNotifyEvent;\r\n FSyncEvent: Boolean;\r\n FThreaded: Boolean;\r\n FTimerThread: TThread;\r\n FTimer: TTimer;\r\n FEventTime: TJvTimerEventTime;\r\n {$IFDEF MSWINDOWS}\r\n FThreadPriority: TThreadPriority;\r\n {$ENDIF MSWINDOWS}\r\n FInTimerEvent: Boolean;\r\n {$IFDEF MSWINDOWS}\r\n procedure SetThreadPriority(Value: TThreadPriority);\r\n {$ENDIF MSWINDOWS}\r\n procedure SetThreaded(Value: Boolean);\r\n procedure SetEnabled(Value: Boolean);\r\n procedure SetInterval(Value: Cardinal);\r\n procedure SetOnTimer(Value: TNotifyEvent);\r\n procedure UpdateTimer;\r\n protected\r\n procedure DoTimer(Sender: TObject);\r\n procedure Timer; virtual;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n procedure Synchronize(Method: TThreadMethod);\r\n published\r\n property EventTime: TJvTimerEventTime read FEventTime write FEventTime default tetPre;\r\n property Enabled: Boolean read FEnabled write SetEnabled default True;\r\n property Interval: Cardinal read FInterval write SetInterval default 1000;\r\n property SyncEvent: Boolean read FSyncEvent write FSyncEvent default True;\r\n property Threaded: Boolean read FThreaded write SetThreaded default True;\r\n {$IFDEF MSWINDOWS}\r\n property ThreadPriority: TThreadPriority read FThreadPriority write SetThreadPriority default tpNormal;\r\n {$ENDIF MSWINDOWS}\r\n property OnTimer: TNotifyEvent read FOnTimer write SetOnTimer;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvTimer.pas $';\r\n Revision: '$Revision: 13138 $';\r\n Date: '$Date: 2011-10-27 01:17:50 +0200 (jeu. 27 oct. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n Forms, SyncObjs,\r\n JvResources, JvTypes;\r\n\r\n//=== { TJvTimerThread } =====================================================\r\n\r\ntype\r\n TJvTimerThread = class(TJvCustomThread)\r\n private\r\n FOwner: TJvTimer;\r\n FInterval: Cardinal;\r\n FException: Exception;\r\n FPaused: Boolean;\r\n FPauseSection: TCriticalSection;\r\n FCurrentDuration: Cardinal;\r\n\r\n procedure HandleException;\r\n procedure SetPaused(const Value: Boolean);\r\n function GetPaused: Boolean;\r\n protected\r\n procedure Execute; override;\r\n public\r\n constructor Create(Timer: TJvTimer; Enabled: Boolean);\r\n destructor Destroy; override;\r\n property Terminated;\r\n\r\n property Paused: Boolean read GetPaused write SetPaused;\r\n end;\r\n\r\nconstructor TJvTimerThread.Create(Timer: TJvTimer; Enabled: Boolean);\r\nbegin\r\n FOwner := Timer;\r\n FPauseSection := TCriticalSection.Create;\r\n inherited Create(not Enabled);\r\n FInterval := 1000;\r\n FreeOnTerminate := False;\r\n ThreadName := Format('%s: %s',[ClassName, Timer.Name]);\r\nend;\r\n\r\nprocedure TJvTimerThread.HandleException;\r\nbegin\r\n if not (FException is EAbort) then\r\n Application.HandleException(Self);\r\nend;\r\n\r\nprocedure TJvTimerThread.SetPaused(const Value: Boolean);\r\nbegin\r\n if FPaused <> Value then\r\n begin\r\n FPauseSection.Acquire;\r\n FPaused := Value;\r\n FPauseSection.Release;\r\n\r\n if not FPaused and Suspended then\r\n Suspended := False;\r\n end;\r\nend;\r\n\r\ndestructor TJvTimerThread.Destroy;\r\nbegin\r\n inherited Destroy;\r\n\r\n // Used by Execute, and hence in the inherited Destroy (Mantis 3819).\r\n FPauseSection.Free;\r\nend;\r\n\r\nprocedure TJvTimerThread.Execute;\r\nconst\r\n Step = 10; // Time of a wait slot, in milliseconds\r\nvar\r\n EventTime: TJvTimerEventTime;\r\n\r\n function ThreadClosed: Boolean;\r\n begin\r\n Result := Terminated or Application.Terminated or (FOwner = nil);\r\n end;\r\n\r\nbegin\r\n NameThread(ThreadName);\r\n repeat\r\n EventTime := FOwner.EventTime;\r\n\r\n if EventTime = tetPost then\r\n begin\r\n { Wait first and then trigger the event }\r\n FCurrentDuration := 0;\r\n while not ThreadClosed and (FCurrentDuration < FInterval) do\r\n begin\r\n SleepEx(Step, False);\r\n Inc(FCurrentDuration, Step);\r\n end;\r\n end;\r\n\r\n if not ThreadClosed and not ThreadClosed and FOwner.FEnabled then\r\n begin\r\n if FOwner.SyncEvent then\r\n begin\r\n Synchronize(FOwner.Timer)\r\n end\r\n else\r\n begin\r\n try\r\n FOwner.Timer;\r\n except\r\n on E: Exception do\r\n begin\r\n FException := E;\r\n HandleException;\r\n end;\r\n end;\r\n end;\r\n end;\r\n\r\n if EventTime = tetPre then\r\n begin\r\n { Wait after the event was triggered }\r\n FCurrentDuration := 0;\r\n while not ThreadClosed and (FCurrentDuration < FInterval) do\r\n begin\r\n SleepEx(Step, False);\r\n Inc(FCurrentDuration, Step);\r\n end;\r\n end;\r\n\r\n // while we are paused, we do not do anything. However, we do call SleepEx\r\n // in the alertable state to avoid 100% CPU usage. Note that the delay\r\n // should not be 0 as it may lead to 100% CPU in that case. 10 is a safe\r\n // value that is small enough not to have a big impact on restart.\r\n while Paused and not Terminated do\r\n SleepEx(10, True);\r\n until Terminated;\r\nend;\r\n\r\nfunction TJvTimerThread.GetPaused: Boolean;\r\nbegin\r\n FPauseSection.Acquire;\r\n Result := FPaused;\r\n FPauseSection.Release;\r\nend;\r\n\r\n//=== { TJvTimer } ===========================================================\r\n\r\nconstructor TJvTimer.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FEventTime := tetPre;\r\n FEnabled := True;\r\n FInterval := 1000;\r\n FSyncEvent := True;\r\n FThreaded := True;\r\n {$IFDEF MSWINDOWS}\r\n FThreadPriority := tpNormal;\r\n {$ENDIF MSWINDOWS}\r\n FTimerThread := nil;\r\n FTimer := nil;\r\nend;\r\n\r\ndestructor TJvTimer.Destroy;\r\nbegin\r\n Destroying;\r\n FEnabled := False;\r\n FOnTimer := nil;\r\n {TTimerThread(FTimerThread).FOwner := nil;}\r\n if Assigned(FTimerThread) then\r\n begin\r\n FTimerThread.Terminate;\r\n (FTimerThread as TJvTimerThread).Paused := False;\r\n FTimerThread.Free;\r\n end;\r\n FTimer.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvTimer.DoTimer(Sender: TObject);\r\nbegin\r\n Timer;\r\nend;\r\n\r\nprocedure TJvTimer.UpdateTimer;\r\nbegin\r\n if (FInterval <> 0) and FEnabled and Assigned(FOnTimer) then\r\n begin\r\n if FThreaded then\r\n begin\r\n FreeAndNil(FTimer);\r\n if not Assigned(FTimerThread) then\r\n FTimerThread := TJvTimerThread.Create(Self, False);\r\n\r\n TJvTimerThread(FTimerThread).Paused := True;\r\n TJvTimerThread(FTimerThread).FCurrentDuration := 0;\r\n TJvTimerThread(FTimerThread).FInterval := FInterval;\r\n\r\n {$IFDEF MSWINDOWS}\r\n FTimerThread.Priority := FThreadPriority;\r\n {$ENDIF MSWINDOWS}\r\n\r\n TJvTimerThread(FTimerThread).Paused := False;\r\n end\r\n else\r\n begin\r\n FreeAndNil(FTimerThread);\r\n\r\n if not Assigned(FTimer) then\r\n FTimer := TTimer.Create(Self);\r\n FTimer.Interval := FInterval;\r\n FTimer.OnTimer := DoTimer;\r\n FTimer.Enabled := True;\r\n end;\r\n end\r\n else\r\n begin\r\n { Don't destroy the thread or the timer if we are currently in the event }\r\n if FInTimerEvent then\r\n begin\r\n if FTimerThread <> nil then\r\n TJvTimerThread(FTimerThread).Paused := True;\r\n if FTimer <> nil then\r\n FTimer.Enabled := False;\r\n Exit;\r\n end;\r\n\r\n FreeAndNil(FTimerThread);\r\n FreeAndNil(FTimer);\r\n end;\r\nend;\r\n\r\nprocedure TJvTimer.SetEnabled(Value: Boolean);\r\nbegin\r\n if Value <> FEnabled then\r\n begin\r\n FEnabled := Value;\r\n UpdateTimer;\r\n end;\r\nend;\r\n\r\nprocedure TJvTimer.SetInterval(Value: Cardinal);\r\nbegin\r\n if Value <> FInterval then\r\n begin\r\n FInterval := Value;\r\n UpdateTimer;\r\n end;\r\nend;\r\n\r\nprocedure TJvTimer.SetThreaded(Value: Boolean);\r\nbegin\r\n if Value <> FThreaded then\r\n begin\r\n if FInTimerEvent then\r\n raise Exception.CreateResFmt(@RsCannotChangeInTimerEvent, ['TJvTimer.Threaded']); // do not localize\r\n FThreaded := Value;\r\n UpdateTimer;\r\n end;\r\nend;\r\n\r\n{$IFDEF MSWINDOWS}\r\nprocedure TJvTimer.SetThreadPriority(Value: TThreadPriority);\r\nbegin\r\n if Value <> FThreadPriority then\r\n begin\r\n FThreadPriority := Value;\r\n if FThreaded then\r\n UpdateTimer;\r\n end;\r\nend;\r\n{$ENDIF MSWINDOWS}\r\n\r\nprocedure TJvTimer.Synchronize(Method: TThreadMethod);\r\nbegin\r\n if FTimerThread <> nil then\r\n begin\r\n with TJvTimerThread(FTimerThread) do\r\n begin\r\n if Suspended or Terminated then\r\n Method\r\n else\r\n TJvTimerThread(FTimerThread).Synchronize(Method);\r\n end;\r\n end\r\n else\r\n Method;\r\nend;\r\n\r\nprocedure TJvTimer.SetOnTimer(Value: TNotifyEvent);\r\nbegin\r\n if Assigned(FOnTimer) <> Assigned(Value) then\r\n begin\r\n FOnTimer := Value;\r\n UpdateTimer;\r\n end\r\n else\r\n FOnTimer := Value;\r\nend;\r\n\r\nprocedure TJvTimer.Timer;\r\nbegin\r\n if FEnabled and not (csDestroying in ComponentState) and Assigned(FOnTimer) then\r\n begin\r\n FInTimerEvent := True;\r\n try\r\n FOnTimer(Self);\r\n finally\r\n FInTimerEvent := False;\r\n end;\r\n end;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvTimerList.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvTimerList.PAS, released on 2002-07-04.\r\n\r\nThe Initial Developers of the Original Code are: Fedor Koshevnikov, Igor Pavluk and Serge Korolev\r\nCopyright (c) 1997, 1998 Fedor Koshevnikov, Igor Pavluk and Serge Korolev\r\nCopyright (c) 2001,2002 SGB Software\r\nAll Rights Reserved.\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nContributor(s):\r\n- (p3) Rewritten to use TCollectionItem instead of TComponent for TJvTimerItem\r\n Change this in your own code:\r\n * CreateNewEvent -> Events.Add\r\n * AddItem -> Events.Add and then read the Item.Handle property\r\n * NextHandle -> Events.NextHandle\r\n * Delete() -> Events.DeleteByHandle()\r\n * IndexFromHandle -> Events.IndexFromHandle\r\n * ItemIndexByHandle -> Events.ItemIndexByHandle\r\n * Sort -> Events.Sort\r\n * EnabledCount -> Events.EnabledCount\r\n Additionally, if you cast Events[Index] to TComponent somewhere, you will have to\r\n change/remove it\r\n NOTE\r\n If you are using this component, the saved values in the dfm won't work. You can\r\n set them up again after loading the project, but you can also open your dfm\r\n in Notepad (assuming you have saved it as text, which you should), load the\r\n project into Delphi, ignore all warnings and then copy and paste from notepad\r\n to the Collection Editor for the Events property.\r\n\r\nKnown Issues:\r\n\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvTimerList.pas 13104 2011-09-07 06:50:43Z obones $\r\n\r\nunit JvTimerList;\r\n\r\n{$I jvcl.inc}\r\n{$I windowsonly.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, Messages, SysUtils, Classes;\r\n\r\nconst\r\n DefaultInterval = 1000;\r\n\r\ntype\r\n TAllTimersEvent = procedure(Sender: TObject; Handle: Longint) of object;\r\n\r\n TJvTimerEvent = class;\r\n TJvTimerList = class;\r\n\r\n // (rom) used THandle where needed\r\n TJvTimerEvents = class(TOwnedCollection)\r\n private\r\n FInterval: Longint;\r\n FStartInterval: Longint;\r\n FSequence: Longint;\r\n FParent: TJvTimerList;\r\n function GetEnabledCount: Integer;\r\n function GetItem(Index: Integer): TJvTimerEvent;\r\n procedure SetItem(Index: Integer; const Value: TJvTimerEvent);\r\n protected\r\n procedure CalculateInterval(StartTicks: Longint);\r\n procedure UpdateEvents(StartTicks: Longint);\r\n function ProcessEvents: Boolean;\r\n procedure Notify(Item: TCollectionItem; Action: TCollectionNotification); override;\r\n public\r\n constructor Create(AOwner: TPersistent);\r\n procedure Activate;\r\n function Add: TJvTimerEvent;\r\n procedure Deactivate;\r\n procedure DeleteByHandle(AHandle: THandle); virtual;\r\n function ItemByHandle(AHandle: THandle): TJvTimerEvent;\r\n function ItemIndexByHandle(AHandle: THandle): Integer;\r\n function IndexOfName(const AName: string): Integer;\r\n function ItemByName(const AName: string): TJvTimerEvent;\r\n function NextHandle: THandle;\r\n procedure Sort;\r\n procedure Assign(Source: TPersistent); override;\r\n property Items[Index: Integer]: TJvTimerEvent read GetItem write SetItem; default;\r\n property EnabledCount: Integer read GetEnabledCount;\r\n end;\r\n\r\n TJvTimerEvent = class(TCollectionItem)\r\n private\r\n FCycled: Boolean;\r\n FEnabled: Boolean;\r\n FExecCount: Integer;\r\n FHandle: THandle;\r\n FInterval: Longint;\r\n FLastExecute: Longint;\r\n FParentList: TJvTimerList;\r\n FRepeatCount: Integer;\r\n FOnTimer: TNotifyEvent;\r\n FName: string;\r\n function GetAsSeconds: Cardinal;\r\n procedure SetAsSeconds(Value: Cardinal);\r\n procedure SetRepeatCount(Value: Integer);\r\n procedure SetEnabled(Value: Boolean);\r\n procedure SetInterval(Value: Longint);\r\n protected\r\n function GetDisplayName: string; override;\r\n public\r\n constructor Create(ACollection: Classes.TCollection); override;\r\n destructor Destroy; override;\r\n\r\n property AsSeconds: Cardinal read GetAsSeconds write SetAsSeconds;\r\n property Handle: THandle read FHandle;\r\n property ExecCount: Integer read FExecCount;\r\n property TimerList: TJvTimerList read FParentList;\r\n procedure Assign(Source: TPersistent); override;\r\n published\r\n property Name: string read FName write FName;\r\n property Cycled: Boolean read FCycled write FCycled default True;\r\n property RepeatCount: Integer read FRepeatCount write SetRepeatCount default 0;\r\n property Enabled: Boolean read FEnabled write SetEnabled default True;\r\n property Interval: Longint read FInterval write SetInterval default DefaultInterval;\r\n property OnTimer: TNotifyEvent read FOnTimer write FOnTimer;\r\n end;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64 or pidOSX32)]\r\n {$ENDIF RTL230_UP}\r\n TJvTimerList = class(TComponent)\r\n private\r\n FEvents: TJvTimerEvents;\r\n FWndHandle: THandle;\r\n FOnFinish: TNotifyEvent;\r\n FOnTimers: TAllTimersEvent;\r\n FActive: Boolean;\r\n FSorted: Boolean;\r\n procedure TimerWndProc(var Msg: TMessage);\r\n procedure UpdateTimer;\r\n procedure SetEvents(const Value: TJvTimerEvents);\r\n procedure SetActive(Value: Boolean);\r\n procedure SetSorted(const Value: Boolean);\r\n protected\r\n procedure DoTimer(Event: TJvTimerEvent); dynamic;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n function Add(AOnTimer: TNotifyEvent; AInterval: Longint;\r\n ACycled: Boolean): THandle; virtual;\r\n published\r\n property Active: Boolean read FActive write SetActive default False;\r\n property Events: TJvTimerEvents read FEvents write SetEvents;\r\n // NB! Setting sorted to true means that the index of the Events are changed!!!\r\n property Sorted: Boolean read FSorted write SetSorted default False;\r\n property OnFinish: TNotifyEvent read FOnFinish write FOnFinish;\r\n property OnTimers: TAllTimersEvent read FOnTimers write FOnTimers;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvTimerList.pas $';\r\n Revision: '$Revision: 13104 $';\r\n Date: '$Date: 2011-09-07 08:50:43 +0200 (mer. 07 sept. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n Consts,\r\n Forms, // for Application.HandleException\r\n Math,\r\n JvJVCLUtils, JvResources, JvTypes;\r\n\r\nconst\r\n MinInterval = 100; { 0.1 sec }\r\n MaxTimerInterval: Longint = High(Longint);\r\n\r\n//=== { TJvTimerEvent } ======================================================\r\n\r\nconstructor TJvTimerEvent.Create(ACollection: Classes.TCollection);\r\nbegin\r\n FHandle := INVALID_HANDLE_VALUE;\r\n inherited Create(ACollection);\r\n FCycled := True;\r\n FRepeatCount := 0;\r\n FEnabled := True;\r\n FExecCount := 0;\r\n\r\n // Do not set FInterval directly or the timer would never trigger\r\n // if its Interval is left to its default value. This is because\r\n // the default value for Enabled is True. If it were False, then\r\n // the user would have to set Enable to True and thus trigger the\r\n // creation of the timer.\r\n Interval := DefaultInterval;\r\n\r\n FLastExecute := GetTickCount;\r\nend;\r\n\r\ndestructor TJvTimerEvent.Destroy;\r\nbegin\r\n FOnTimer := nil;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvTimerEvent.SetEnabled(Value: Boolean);\r\nbegin\r\n if Value <> FEnabled then\r\n begin\r\n FEnabled := Value;\r\n if FEnabled then\r\n begin\r\n FExecCount := 0;\r\n FLastExecute := GetTickCount;\r\n if FParentList <> nil then\r\n with FParentList do\r\n begin\r\n Events.CalculateInterval(GetTickCount);\r\n UpdateTimer;\r\n Events.Activate;\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvTimerEvent.SetInterval(Value: Longint);\r\nbegin\r\n if Value <> FInterval then\r\n begin\r\n FInterval := Value;\r\n if FParentList <> nil then\r\n with FParentList do\r\n begin\r\n Events.CalculateInterval(GetTickCount);\r\n UpdateTimer;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvTimerEvent.SetRepeatCount(Value: Integer);\r\nbegin\r\n if FRepeatCount <> Value then\r\n begin\r\n Value := Max(Value, Integer(not FCycled));\r\n if not (csDesigning in FParentList.ComponentState) then\r\n if FEnabled and (Value <= FExecCount) then\r\n Enabled := False;\r\n FRepeatCount := Value;\r\n end;\r\nend;\r\n\r\nfunction TJvTimerEvent.GetAsSeconds: Cardinal;\r\nbegin\r\n Result := Interval div 1000;\r\nend;\r\n\r\nprocedure TJvTimerEvent.SetAsSeconds(Value: Cardinal);\r\nbegin\r\n Interval := Value * 1000;\r\nend;\r\n\r\nprocedure TJvTimerEvent.Assign(Source: TPersistent);\r\nbegin\r\n if Source is TJvTimerEvent then\r\n begin\r\n if Source <> Self then\r\n begin\r\n Cycled := TJvTimerEvent(Source).Cycled;\r\n Enabled := TJvTimerEvent(Source).Enabled;\r\n Interval := TJvTimerEvent(Source).Interval;\r\n Name := TJvTimerEvent(Source).Name;\r\n RepeatCount := TJvTimerEvent(Source).RepeatCount;\r\n end;\r\n end\r\n else\r\n inherited Assign(Source);\r\nend;\r\n\r\n//=== { TJvTimerList } =======================================================\r\n\r\nconstructor TJvTimerList.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FEvents := TJvTimerEvents.Create(Self);\r\n FWndHandle := INVALID_HANDLE_VALUE;\r\n Events.Deactivate;\r\nend;\r\n\r\ndestructor TJvTimerList.Destroy;\r\nbegin\r\n OnFinish := nil;\r\n OnTimers := nil;\r\n Events.Deactivate;\r\n Events.Clear;\r\n FEvents.Free;\r\n inherited Destroy;\r\nend;\r\n\r\n{ Create a new timer event and returns a handle }\r\n\r\nfunction TJvTimerList.Add(AOnTimer: TNotifyEvent; AInterval: Longint;\r\n ACycled: Boolean): THandle;\r\nvar\r\n T: TJvTimerEvent;\r\nbegin\r\n T := Events.Add;\r\n T.FParentList := Self;\r\n with T do\r\n begin\r\n OnTimer := AOnTimer;\r\n FParentList := Self;\r\n FHandle := Events.NextHandle;\r\n Interval := AInterval;\r\n Cycled := ACycled;\r\n Result := FHandle;\r\n end;\r\n Events.CalculateInterval(GetTickCount);\r\n if Sorted then\r\n Events.Sort;\r\n UpdateTimer;\r\nend;\r\n\r\nprocedure TJvTimerList.TimerWndProc(var Msg: TMessage);\r\nbegin\r\n if not (csDesigning in ComponentState) then\r\n begin\r\n with Msg do\r\n if Msg = WM_TIMER then\r\n try\r\n if (not (csDesigning in ComponentState)) and\r\n (Events.FStartInterval = 0) and Active then\r\n begin\r\n if Events.ProcessEvents then\r\n begin\r\n if Events.EnabledCount = 0 then\r\n Events.Deactivate\r\n else\r\n begin\r\n Events.CalculateInterval(GetTickCount);\r\n UpdateTimer;\r\n end;\r\n end;\r\n end\r\n else\r\n UpdateTimer;\r\n except\r\n Application.HandleException(Self);\r\n end\r\n else\r\n Result := DefWindowProc(FWndHandle, Msg, WParam, LParam);\r\n end;\r\nend;\r\n\r\nprocedure TJvTimerList.UpdateTimer;\r\nvar\r\n TimerInterval: Cardinal;\r\nbegin\r\n if not (csDesigning in ComponentState) then\r\n begin\r\n if Events.FInterval <= MaxTimerInterval then\r\n TimerInterval := Events.FInterval\r\n else\r\n if (Events.FInterval - Events.FStartInterval) <= MaxTimerInterval then\r\n begin\r\n TimerInterval := Cardinal(Events.FInterval - Events.FStartInterval);\r\n Events.FStartInterval := 0;\r\n end\r\n else\r\n begin\r\n TimerInterval := MaxTimerInterval;\r\n Events.FStartInterval := Events.FStartInterval + MaxTimerInterval;\r\n end;\r\n if not (csDesigning in ComponentState) and (FWndHandle <> INVALID_HANDLE_VALUE) then\r\n begin\r\n KillTimer(FWndHandle, 1);\r\n if Events.EnabledCount = 0 then\r\n Events.Deactivate\r\n else\r\n if Events.FInterval > 0 then\r\n if SetTimer(FWndHandle, 1, TimerInterval, nil) = 0 then\r\n begin\r\n Events.Deactivate;\r\n raise EOutOfResources.CreateRes(@SNoTimers);\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvTimerList.SetEvents(const Value: TJvTimerEvents);\r\nbegin\r\n FEvents.Assign(Value);\r\nend;\r\n\r\nprocedure TJvTimerList.SetActive(Value: Boolean);\r\nvar\r\n StartTicks: Longint;\r\nbegin\r\n if FActive <> Value then\r\n begin\r\n if not (csDesigning in ComponentState) then\r\n begin\r\n if Value then\r\n begin\r\n FWndHandle := AllocateHWndEx(TimerWndProc);\r\n StartTicks := GetTickCount;\r\n Events.UpdateEvents(StartTicks);\r\n Events.CalculateInterval(StartTicks);\r\n if Sorted then\r\n Events.Sort;\r\n UpdateTimer;\r\n end\r\n else\r\n begin\r\n KillTimer(FWndHandle, 1);\r\n DeallocateHWndEx(FWndHandle);\r\n FWndHandle := INVALID_HANDLE_VALUE;\r\n if Assigned(FOnFinish) then\r\n FOnFinish(Self);\r\n end;\r\n Events.FStartInterval := 0;\r\n end;\r\n FActive := Value;\r\n end;\r\nend;\r\n\r\nprocedure TJvTimerList.DoTimer(Event: TJvTimerEvent);\r\nbegin\r\n with Event do\r\n if Assigned(FOnTimer) then\r\n FOnTimer(Event);\r\n if Assigned(FOnTimers) then\r\n FOnTimers(Self, Event.Handle);\r\nend;\r\n\r\n//===TJvTimerEvents ==========================================================\r\n\r\nconstructor TJvTimerEvents.Create(AOwner: TPersistent);\r\nbegin\r\n if not (AOwner is TJvTimerList) then\r\n raise EJVCLException.CreateRes(@RsEOwnerMustBeTJvTimerList);\r\n inherited Create(AOwner, TJvTimerEvent);\r\n FParent := TJvTimerList(AOwner);\r\nend;\r\n\r\nprocedure TJvTimerEvents.Activate;\r\nbegin\r\n FParent.Active := True;\r\nend;\r\n\r\nfunction TJvTimerEvents.Add: TJvTimerEvent;\r\nbegin\r\n Result := TJvTimerEvent(inherited Add);\r\nend;\r\n\r\nprocedure TJvTimerEvents.Assign(Source: TPersistent);\r\nvar\r\n I: Integer;\r\nbegin\r\n if Source is TJvTimerEvents then\r\n begin\r\n Clear;\r\n for I := 0 to TJvTimerEvents(Source).Count - 1 do\r\n Add.Assign(TJvTimerEvents(Source).Items[I]);\r\n end\r\n else\r\n inherited Assign(Source);\r\nend;\r\n\r\nprocedure TJvTimerEvents.CalculateInterval(StartTicks: Integer);\r\nvar\r\n I: Integer;\r\n ExitLoop: Boolean;\r\nbegin\r\n if not (csDesigning in (Owner as TJvTimerList).ComponentState) then\r\n begin\r\n if Count = 0 then\r\n FInterval := 0\r\n else\r\n begin\r\n FStartInterval := 0;\r\n FInterval := MaxLongint;\r\n for I := 0 to Count - 1 do\r\n with Items[I] do\r\n if Enabled and (Interval > 0) then\r\n begin\r\n if Interval < Self.FInterval then\r\n Self.FInterval := Interval;\r\n if Self.FInterval > (Interval - (StartTicks - FLastExecute)) then\r\n Self.FInterval := (Interval - (StartTicks - FLastExecute));\r\n end;\r\n if FInterval < MinInterval then\r\n FInterval := MinInterval;\r\n if FInterval = MaxLongint then\r\n FInterval := 0\r\n else\r\n begin\r\n repeat\r\n ExitLoop := True;\r\n for I := 0 to Count - 1 do\r\n with Items[I] do\r\n if (Interval mod Self.FInterval) <> 0 then\r\n begin\r\n Dec(Self.FInterval, Interval mod Self.FInterval);\r\n ExitLoop := False;\r\n Break;\r\n end;\r\n until ExitLoop or (FInterval <= MinInterval);\r\n if FInterval < MinInterval then\r\n FInterval := MinInterval;\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvTimerEvents.Deactivate;\r\nbegin\r\n if not (csLoading in FParent.ComponentState) then\r\n FParent.Active := False;\r\nend;\r\n\r\nprocedure TJvTimerEvents.DeleteByHandle(AHandle: THandle);\r\nvar\r\n I: Integer;\r\nbegin\r\n I := ItemIndexByHandle(AHandle);\r\n if I >= 0 then\r\n Delete(I);\r\n if FParent.Active then\r\n begin\r\n CalculateInterval(GetTickCount);\r\n FParent.UpdateTimer;\r\n end;\r\nend;\r\n\r\nfunction TJvTimerEvents.GetEnabledCount: Integer;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := 0;\r\n for I := 0 to Count - 1 do\r\n if Items[I].Enabled then\r\n Inc(Result);\r\nend;\r\n\r\nfunction TJvTimerEvents.GetItem(Index: Integer): TJvTimerEvent;\r\nbegin\r\n Result := TJvTimerEvent(inherited Items[Index]);\r\nend;\r\n\r\nfunction TJvTimerEvents.ItemByHandle(AHandle: THandle): TJvTimerEvent;\r\nvar\r\n I: Integer;\r\nbegin\r\n I := ItemIndexByHandle(AHandle);\r\n if I >= 0 then\r\n Result := Items[I]\r\n else\r\n Result := nil;\r\nend;\r\n\r\nfunction TJvTimerEvents.ItemIndexByHandle(AHandle: THandle): Integer;\r\nbegin\r\n for Result := 0 to Count - 1 do\r\n if Items[Result].Handle = AHandle then\r\n Exit;\r\n Result := -1;\r\nend;\r\n\r\nfunction TJvTimerEvents.NextHandle: THandle;\r\nbegin\r\n Inc(FSequence);\r\n Result := FSequence;\r\nend;\r\n\r\nprocedure TJvTimerEvents.Notify(Item: TCollectionItem;\r\n Action: TCollectionNotification);\r\nbegin\r\n inherited Notify(Item, Action);\r\n if Action = cnAdded then\r\n with TJvTimerEvent(Item) do\r\n begin\r\n FParentList := FParent;\r\n FHandle := NextHandle;\r\n FParentList := Self.FParent;\r\n CalculateInterval(GetTickCount);\r\n if FParent.Sorted then\r\n Sort;\r\n FParent.UpdateTimer;\r\n end;\r\nend;\r\n\r\nfunction TJvTimerEvents.ProcessEvents: Boolean;\r\nvar\r\n I: Integer;\r\n Item: TJvTimerEvent;\r\n StartTicks: Longint;\r\nbegin\r\n Result := False;\r\n if not (csDesigning in (Owner as TJvTimerList).ComponentState) then\r\n begin\r\n StartTicks := GetTickCount;\r\n for I := Count - 1 downto 0 do\r\n begin\r\n Item := Items[I];\r\n if (Item <> nil) and Item.Enabled then\r\n with Item do\r\n if (StartTicks - FLastExecute) >= (Interval - (MinInterval div 2)) then\r\n begin\r\n FLastExecute := StartTicks;\r\n Inc(FExecCount);\r\n Enabled := not ((not Cycled) and (FExecCount >= RepeatCount));\r\n if not Enabled then\r\n Result := True;\r\n FParent.DoTimer(Item);\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvTimerEvents.SetItem(Index: Integer; const Value: TJvTimerEvent);\r\nbegin\r\n inherited Items[Index] := Value;\r\nend;\r\n\r\nprocedure TJvTimerEvents.Sort;\r\nvar\r\n I: Integer;\r\n ExitLoop: Boolean;\r\nbegin\r\n if not (csDesigning in (Owner as TJvTimerList).ComponentState) then\r\n repeat\r\n ExitLoop := True;\r\n for I := 0 to Count - 2 do\r\n begin\r\n if Items[I].Interval > Items[I + 1].Interval then\r\n begin\r\n Items[I].Index := I + 1;\r\n// Items[I+1].Index := I;\r\n ExitLoop := False;\r\n end;\r\n end;\r\n until ExitLoop;\r\nend;\r\n\r\nprocedure TJvTimerEvents.UpdateEvents(StartTicks: Integer);\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := 0 to Count - 1 do\r\n if Items[I].Enabled then\r\n Items[I].FLastExecute := StartTicks;\r\nend;\r\n\r\nfunction TJvTimerEvent.GetDisplayName: string;\r\nbegin\r\n Result := Name;\r\n if Result = '' then\r\n Result := inherited GetDisplayName;\r\nend;\r\n\r\nfunction TJvTimerEvents.IndexOfName(const AName: string): Integer;\r\nbegin\r\n for Result := 0 to Count - 1 do\r\n if AnsiSameText(AName, Items[Result].Name) then\r\n Exit;\r\n Result := -1;\r\nend;\r\n\r\nfunction TJvTimerEvents.ItemByName(const AName: string): TJvTimerEvent;\r\nvar\r\n I: Integer;\r\nbegin\r\n I := IndexOfName(AName);\r\n if I >= 0 then\r\n Result := Items[I]\r\n else\r\n Result := nil;\r\nend;\r\n\r\nprocedure TJvTimerList.SetSorted(const Value: Boolean);\r\nbegin\r\n if FSorted <> Value then\r\n begin\r\n FSorted := Value;\r\n if FSorted then\r\n Events.Sort;\r\n end;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvTipOfDay.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvTipsOfDay.PAS, released on 2001-02-28.\r\n\r\nThe Initial Developers of the Original Code are Sbastien Buysse [sbuysse att buypin dott com]\r\nand Peter Thrnqvist [peter3 at sourceforge dot net]. Portions created by Sbastien Buysse\r\nare Copyright (C) 2001 Sbastien Buysse. Portions created by Peter Thrnqvist\r\nare Copyright (C) 2002 Peter Thrnqvist.\r\nAll Rights Reserved.\r\n\r\nContributor(s): Michael Beck [mbeck att bigfoot dott com].\r\n Remko Bonte [remkobonte att myrealbox dott com]\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvTipOfDay.pas 13352 2012-06-14 09:21:26Z obones $\r\n\r\nunit JvTipOfDay;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, Classes, Graphics, Controls, Messages, Forms, StdCtrls,\r\n JvAppStorage, JvBaseDlg, JvButtonPersistent, JvSpeedButton;\r\n\r\ntype\r\n TJvCanShowEvent = procedure(Sender: TObject; var CanShow: Boolean) of object;\r\n TJvTipOfDayOption = (toShowOnStartUp, toUseAppStorage, toShowWhenFormShown, toHideStartupCheckbox);\r\n TJvTipOfDayOptions = set of TJvTipOfDayOption;\r\n\r\n TJvTipOfDayStyle = (tsVC, tsStandard);\r\n\r\n TJvTipOfDayButtonPersistent = TJvButtonPersistent;\r\n \r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64 or pidOSX32)]\r\n {$ENDIF RTL230_UP}\r\n TJvTipOfDay = class(TJvCommonDialog)\r\n private\r\n FAppStorage: TJvCustomAppStorage;\r\n FAppStoragePath: string;\r\n FTitle: string;\r\n FCheckBoxText: string;\r\n FHeaderText: string;\r\n FColor: TColor;\r\n FDefaultFonts: Boolean;\r\n FTipFont: TFont;\r\n FHeaderFont: TFont;\r\n FButtonNext: TJvTipOfDayButtonPersistent;\r\n FButtonClose: TJvTipOfDayButtonPersistent;\r\n FOptions: TJvTipOfDayOptions;\r\n FTips: TStringList;\r\n FStyle: TJvTipOfDayStyle;\r\n FCurrentTip: Integer;\r\n FOnAfterExecute: TNotifyEvent;\r\n FOnCanShow: TJvCanShowEvent;\r\n { For reentrance check: }\r\n FRunning: Boolean;\r\n { FIsAutoExecute = False -> User called Execute\r\n FIsAutoExecute = True -> Execute is called in method Loaded }\r\n FIsAutoExecute: Boolean;\r\n { Maybe a bit overkill, but use a generic base class to access the\r\n visual components, thus enabling you to easily extend the\r\n 'Tip of the Day' component }\r\n FTipLabel: TControl;\r\n FNextTipButton: TControl;\r\n FCheckBox: TButtonControl;\r\n { Parent form: }\r\n FForm: TCustomForm;\r\n FDummyMsgSend: Boolean;\r\n procedure FontChanged(Sender: TObject);\r\n // function GetRegKey: string;\r\n function GetTips: TStrings;\r\n function IsFontStored: Boolean;\r\n procedure SetButtonClose(const Value: TJvTipOfDayButtonPersistent);\r\n procedure SetButtonNext(const Value: TJvTipOfDayButtonPersistent);\r\n procedure SetDefaultFonts(const Value: Boolean);\r\n procedure SetHeaderFont(const Value: TFont);\r\n procedure SetTipFont(const Value: TFont);\r\n procedure SetTips(const Value: TStrings);\r\n procedure SetStyle(const Value: TJvTipOfDayStyle);\r\n protected\r\n procedure SetAppStorage(Value: TJvCustomAppStorage);\r\n { Called after the dialog has been shown. Fires the OnAfterExecute\r\n event, thus enabling the user to update the appstorage or other\r\n persistent data: }\r\n procedure DoAfterExecute; virtual;\r\n { Determines whether the dialog can be shown; user can write an\r\n event handler to override the default behaviour: }\r\n function CanShow: Boolean; virtual;\r\n { Initializes the \"Standard Component Gallery\" Tip of the Day dialog: }\r\n procedure InitStandard(AForm: TForm);\r\n { Initializes the \"New VC++ look\" Tip of the Day dialog: }\r\n procedure InitVC(AForm: TForm);\r\n { Called in Loaded method; sets flag FIsAutoExecute to True to indicate\r\n that the Execute was automatically called, thus not by the user: }\r\n procedure AutoExecute;\r\n { Functions to read/write from a default location a value that\r\n determines whether the dialog must be shown; if the user wants\r\n to store this value in another location he must write an OnCanShow\r\n and an OnAfterExecute event handler: }\r\n function ReadFromAppStorage: Boolean; virtual;\r\n procedure WriteToAppStorage(DoShowOnStartUp: Boolean); virtual;\r\n { Sets the fonts (HeaderFont and TipFont) to the default fonts\r\n associated with Style: }\r\n procedure UpdateFonts;\r\n { Places a new tip on the dialog: }\r\n procedure UpdateTip;\r\n { Handles button clicks on the 'Next' button: }\r\n procedure HandleNextClick(Sender: TObject);\r\n { Hooks/Unhooks the parent form, this is done if\r\n toShowWhenFormShown is in Options }\r\n procedure HookForm;\r\n procedure UnHookForm;\r\n { The hook; responds when the parent form activates }\r\n function HookProc(var Msg: TMessage): Boolean;\r\n procedure Loaded; override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n function Execute(ParentWnd: HWND): Boolean; overload; override;\r\n procedure Notification(AComponent: TComponent; Operation: TOperation); override;\r\n procedure LoadFromFile(const AFileName: string);\r\n procedure SaveToFile(const AFileName: string);\r\n property IsAutoExecute: Boolean read FIsAutoExecute;\r\n published\r\n property AppStorage: TJvCustomAppStorage read FAppStorage write SetAppStorage;\r\n property AppStoragePath: string read FAppStoragePath write FAppStoragePath;\r\n property ButtonNext: TJvTipOfDayButtonPersistent read FButtonNext write SetButtonNext;\r\n property ButtonClose: TJvTipOfDayButtonPersistent read FButtonClose write SetButtonClose;\r\n property CheckBoxText: string read FCheckBoxText write FCheckBoxText;\r\n property Color: TColor read FColor write FColor default clWhite;\r\n property DefaultFonts: Boolean read FDefaultFonts write SetDefaultFonts default True;\r\n property HeaderFont: TFont read FHeaderFont write SetHeaderFont stored IsFontStored;\r\n property HeaderText: string read FHeaderText write FHeaderText;\r\n property OnAfterExecute: TNotifyEvent read FOnAfterExecute write FOnAfterExecute;\r\n property OnCanShow: TJvCanShowEvent read FOnCanShow write FOnCanShow;\r\n property Options: TJvTipOfDayOptions read FOptions write FOptions default [toShowOnStartUp];\r\n property Style: TJvTipOfDayStyle read FStyle write SetStyle default tsVC;\r\n property TipFont: TFont read FTipFont write SetTipFont stored IsFontStored;\r\n property Tips: TStrings read GetTips write SetTips;\r\n property Title: string read FTitle write FTitle;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvTipOfDay.pas $';\r\n Revision: '$Revision: 13352 $';\r\n Date: '$Date: 2012-06-14 11:21:26 +0200 (jeu. 14 juin 2012) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n SysUtils, ExtCtrls, Dialogs,\r\n JvWndProcHook,\r\n JvButton, JvResources, JvComponent, JvJVCLUtils;\r\n\r\n{$R JvTipOfDay.res}\r\n\r\n\r\n\r\n\r\ntype\r\n TControlAccessProtected = class(TControl);\r\n TButtonControlAccessProtected = class(TButtonControl);\r\n\r\nconstructor TJvTipOfDay.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FTips := TStringList.Create;\r\n\r\n FTipFont := TFont.Create;\r\n FTipFont.OnChange := FontChanged;\r\n\r\n FHeaderFont := TFont.Create;\r\n FHeaderFont.OnChange := FontChanged;\r\n\r\n FButtonNext := TJvTipOfDayButtonPersistent.Create(Self);\r\n FButtonNext.Caption := RsNextCaption;\r\n FButtonNext.Flat := False;\r\n FButtonNext.HotTrack := False;\r\n\r\n FButtonClose := TJvTipOfDayButtonPersistent.Create(Self);\r\n FButtonClose.Caption := RsCloseCaption;\r\n FButtonClose.Flat := False;\r\n FButtonClose.HotTrack := False;\r\n\r\n FHeaderText := RsTipsHeaderText;\r\n FTitle := RsTipsTitle;\r\n FCheckBoxText := RsTipsCheckBoxText;\r\n\r\n FColor := clWhite;\r\n FStyle := tsVC;\r\n FDefaultFonts := True;\r\n FOptions := [toShowOnStartUp];\r\n FIsAutoExecute := False;\r\n\r\n UpdateFonts;\r\nend;\r\n\r\ndestructor TJvTipOfDay.Destroy;\r\nbegin\r\n FTips.Free;\r\n FTipFont.Free;\r\n FHeaderFont.Free;\r\n FButtonNext.Free;\r\n FButtonClose.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvTipOfDay.SetAppStorage(Value: TJvCustomAppStorage);\r\nbegin\r\n ReplaceComponentReference(Self, Value, TComponent(FAppStorage));\r\nend;\r\n\r\nprocedure TJvTipOfDay.AutoExecute;\r\nbegin\r\n FIsAutoExecute := True;\r\n try\r\n Execute;\r\n finally\r\n FIsAutoExecute := False;\r\n end;\r\nend;\r\n\r\nfunction TJvTipOfDay.CanShow: Boolean;\r\nbegin\r\n // Show the dialog if the user called Execute (FIsAutoExecute=False) or\r\n // if flag toShowOnStartUp is in Options..\r\n Result := not FIsAutoExecute or (toShowOnStartUp in Options);\r\n\r\n // ..but enable the user to override this behaviour\r\n if not (csDesigning in ComponentState) and Assigned(FOnCanShow) then\r\n FOnCanShow(Self, Result);\r\nend;\r\n\r\nprocedure TJvTipOfDay.DoAfterExecute;\r\nbegin\r\n if csDesigning in ComponentState then\r\n Exit;\r\n if Assigned(FOnAfterExecute) then\r\n FOnAfterExecute(Self);\r\nend;\r\n\r\nfunction TJvTipOfDay.Execute(ParentWnd: HWND): Boolean;\r\nvar\r\n LForm: TJvForm;\r\nbegin\r\n Result := False;\r\n // Reentrance check\r\n if FRunning then\r\n Exit;\r\n FRunning := True;\r\n try\r\n if toUseAppStorage in Options then\r\n begin\r\n if ReadFromAppStorage then\r\n Include(FOptions, toShowOnStartUp)\r\n else\r\n Exclude(FOptions, toShowOnStartUp);\r\n end;\r\n\r\n if not CanShow then\r\n Exit;\r\n\r\n { toShowOnStartUp will be changed in ExecuteVS/ExecuteStandard if\r\n the user changes the checkbox }\r\n LForm := TJvForm.Create(Application);\r\n with LForm do\r\n try\r\n if Style = tsVC then\r\n InitVC(LForm)\r\n else\r\n InitStandard(LForm);\r\n\r\n Randomize;\r\n FCurrentTip := Random(Tips.Count);\r\n\r\n UpdateTip;\r\n\r\n Result := ShowModal = mrOk;\r\n\r\n if not (toHideStartupCheckbox in Options) then\r\n if TButtonControlAccessProtected(FCheckBox).Checked then\r\n Include(FOptions, toShowOnStartUp)\r\n else\r\n Exclude(FOptions, toShowOnStartUp)\r\n finally\r\n Free;\r\n end;\r\n\r\n DoAfterExecute;\r\n\r\n if toUseAppStorage in Options then\r\n WriteToAppStorage(toShowOnStartUp in Options);\r\n finally\r\n FRunning := False;\r\n end;\r\nend;\r\n\r\n\r\n\r\nprocedure TJvTipOfDay.Notification(AComponent: TComponent; Operation: TOperation);\r\nbegin\r\n inherited Notification(AComponent, Operation);\r\n if (Operation = opRemove) and (AComponent = FAppStorage) then\r\n FAppStorage := nil;\r\nend;\r\n\r\nprocedure TJvTipOfDay.FontChanged(Sender: TObject);\r\nbegin\r\n FDefaultFonts := False;\r\nend;\r\n\r\n{\r\nfunction TJvTipOfDay.GetRegKey: string;\r\nbegin\r\n Result := Application.Title + '_' + Name;\r\nend;\r\n}\r\n\r\nprocedure TJvTipOfDay.HandleNextClick(Sender: TObject);\r\nbegin\r\n FCurrentTip := (FCurrentTip + 1) mod Tips.Count;\r\n UpdateTip;\r\nend;\r\n\r\nprocedure TJvTipOfDay.HookForm;\r\nbegin\r\n if Owner is TControl then\r\n FForm := GetParentForm(TControl(Owner))\r\n else\r\n FForm := nil;\r\n if not Assigned(FForm) then\r\n Exit;\r\n FDummyMsgSend := False;\r\n JvWndProcHook.RegisterWndProcHook(FForm, HookProc, hoAfterMsg);\r\nend;\r\n\r\n\r\nfunction TJvTipOfDay.HookProc(var Msg: TMessage): Boolean;\r\nbegin\r\n Result := False;\r\n case Msg.Msg of\r\n WM_ACTIVATEAPP:\r\n begin\r\n { Maybe the form is hooked by other components that are also\r\n waiting for WM_ACTIVATEAPP; if we call AutoExecute now, those\r\n components will not receive that message until the tip dialog\r\n is closed; Thus we send a dummy message to the hooked window and\r\n respond to that message }\r\n PostMessage(FForm.Handle, WM_NULL, 0, 0);\r\n FDummyMsgSend := True;\r\n end;\r\n // (rom) better use a private message value\r\n WM_NULL:\r\n if not FRunning and FDummyMsgSend then\r\n begin\r\n FDummyMsgSend := False;\r\n AutoExecute;\r\n UnHookForm;\r\n end;\r\n end;\r\nend;\r\n\r\n\r\nprocedure TJvTipOfDay.InitStandard(AForm: TForm);\r\nbegin\r\n with AForm do\r\n begin\r\n BorderStyle := bsDialog;\r\n { Title }\r\n Caption := Self.Title;\r\n ClientHeight := 267;\r\n ClientWidth := 347;\r\n\r\n // Maybe poMainFormCenter? If so check if whe're at design-time\r\n Position := poScreenCenter;\r\n\r\n with TShape.Create(AForm) do\r\n begin\r\n Parent := AForm;\r\n SetBounds(18, 18, 311, 200);\r\n Brush.Color := clBtnFace;\r\n Pen.Color := cl3DDkShadow;\r\n end;\r\n with TShape.Create(AForm) do\r\n begin\r\n Parent := AForm;\r\n SetBounds(30, 28, 285, 180);\r\n Brush.Color := Self.Color;\r\n Pen.Color := Self.Color;\r\n end;\r\n\r\n with TImage.Create(AForm) do\r\n begin\r\n Parent := AForm;\r\n SetBounds(30, 28, 40, 53);\r\n AutoSize := True;\r\n Picture.Bitmap.LoadFromResourceName(HInstance, 'JvTipOfDayPIC2');\r\n Transparent := True;\r\n end;\r\n { Header: 'Did you know...' }\r\n with TLabel.Create(AForm) do\r\n begin\r\n Parent := AForm;\r\n SetBounds(70, 46, 105, 16);\r\n Caption := Self.HeaderText;\r\n Color := Self.Color;\r\n Font := Self.HeaderFont;\r\n end;\r\n { Tip label }\r\n FTipLabel := TLabel.Create(AForm);\r\n with TLabel(FTipLabel) do\r\n begin\r\n Parent := AForm;\r\n SetBounds(42, 102, 261, 83);\r\n AutoSize := False;\r\n Color := Self.Color;\r\n WordWrap := True;\r\n Font := Self.TipFont;\r\n end;\r\n\r\n { CheckBox: 'Show Tips on StartUp' }\r\n if not (toHideStartupCheckbox in Options) then\r\n begin\r\n FCheckBox := TCheckBox.Create(AForm);\r\n with TCheckBox(FCheckBox) do\r\n begin\r\n Parent := AForm;\r\n SetBounds(20, 236, 144, 17);\r\n Caption := Self.CheckBoxText;\r\n Checked := toShowOnStartUp in Options;\r\n end;\r\n end;\r\n\r\n { ButtonNext }\r\n if ButtonNext.Flat then\r\n { Flat means no focus.. }\r\n FNextTipButton := TJvSpeedButton.Create(AForm)\r\n else\r\n { ..so create a TJvButton unless Flat is set to True }\r\n FNextTipButton := TJvCustomButton.Create(AForm);\r\n\r\n with TControlAccessProtected(FNextTipButton) do\r\n begin\r\n Parent := AForm;\r\n SetBounds(164, 232, 75, 25);\r\n OnClick := HandleNextClick;\r\n Assign(ButtonNext);\r\n end;\r\n\r\n { ButtonClose }\r\n if ButtonClose.Flat then\r\n { Flat means no focus.. }\r\n with TJvSpeedButton.Create(AForm) do\r\n begin\r\n Parent := AForm;\r\n SetBounds(252, 232, 75, 25);\r\n Assign(ButtonClose);\r\n ModalResult := mrOk;\r\n end\r\n else\r\n { ..so create a TJvButton unless Flat is set to True }\r\n with TJvCustomButton.Create(AForm) do\r\n begin\r\n Parent := AForm;\r\n SetBounds(251, 232, 75, 25);\r\n Cancel := True;\r\n Default := True;\r\n Assign(ButtonClose);\r\n ModalResult := mrOk;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvTipOfDay.InitVC(AForm: TForm);\r\nbegin\r\n with AForm do\r\n begin\r\n BorderStyle := bsDialog;\r\n { Title }\r\n Caption := Self.Title;\r\n ClientHeight := 258;\r\n ClientWidth := 400;\r\n\r\n // Maybe poMainFormCenter? If so check if whe're at design-time\r\n Position := poScreenCenter;\r\n with TShape.Create(AForm) do\r\n begin\r\n Parent := AForm;\r\n SetBounds(8, 8, 384, 206);\r\n Brush.Color := Self.Color;\r\n Pen.Color := clGray;\r\n Pen.Style := psInsideFrame;\r\n end;\r\n with TShape.Create(AForm) do\r\n begin\r\n Parent := AForm;\r\n SetBounds(8, 8, 53, 205);\r\n Brush.Color := clGray;\r\n Pen.Color := clGray;\r\n end;\r\n with TShape.Create(AForm) do\r\n begin\r\n Parent := AForm;\r\n SetBounds(61, 63, 330, 1);\r\n Brush.Color := clGray;\r\n Pen.Color := clGray;\r\n Pen.Width := 10;\r\n end;\r\n\r\n { Header: 'Did you know...' }\r\n with TLabel.Create(AForm) do\r\n begin\r\n Parent := AForm;\r\n SetBounds(71, 24, 135, 23);\r\n Caption := Self.HeaderText;\r\n Color := Self.Color;\r\n Font := Self.HeaderFont;\r\n end;\r\n with TImage.Create(AForm) do\r\n begin\r\n Parent := AForm;\r\n SetBounds(21, 22, 41, 43);\r\n Picture.Bitmap.LoadFromResourceName(HInstance, 'JvTipOfDayPIC1');\r\n end;\r\n\r\n { CheckBox: 'Show Tips on StartUp' }\r\n if not (toHideStartupCheckbox in Options) then\r\n begin\r\n FCheckBox := TCheckBox.Create(AForm);\r\n with TCheckBox(FCheckBox) do\r\n begin\r\n Parent := AForm;\r\n SetBounds(8, 225, 200, 17);\r\n Caption := Self.CheckBoxText;\r\n Checked := toShowOnStartUp in Options;\r\n end;\r\n end;\r\n\r\n { ButtonNext }\r\n if ButtonNext.Flat then\r\n { Flat means no focus.. }\r\n FNextTipButton := TJvSpeedButton.Create(AForm)\r\n else\r\n { ..so create a TJvButton unless Flat is set to True }\r\n FNextTipButton := TJvCustomButton.Create(AForm);\r\n\r\n with TControlAccessProtected(FNextTipButton) do\r\n begin\r\n Parent := AForm;\r\n SetBounds(227, 225, 77, 25);\r\n OnClick := HandleNextClick;\r\n Assign(ButtonNext);\r\n end;\r\n\r\n { ButtonClose }\r\n if ButtonClose.Flat then\r\n { Flat means no focus.. }\r\n with TJvSpeedButton.Create(AForm) do\r\n begin\r\n Parent := AForm;\r\n SetBounds(317, 225, 75, 25);\r\n Assign(ButtonClose);\r\n ModalResult := mrOk;\r\n end\r\n else\r\n { ..so create a TJvButton unless Flat is set to True }\r\n with TJvCustomButton.Create(AForm) do\r\n begin\r\n Parent := AForm;\r\n SetBounds(317, 225, 75, 25);\r\n Cancel := True;\r\n Default := True;\r\n Assign(ButtonClose);\r\n ModalResult := mrOk;\r\n end;\r\n\r\n { Tip label }\r\n FTipLabel := TLabel.Create(AForm);\r\n with TLabel(FTipLabel) do\r\n begin\r\n Parent := AForm;\r\n SetBounds(71, 75, 306, 134);\r\n AutoSize := False;\r\n Color := Self.Color;\r\n WordWrap := True;\r\n Font := Self.TipFont;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJvTipOfDay.IsFontStored: Boolean;\r\nbegin\r\n Result := not DefaultFonts;\r\nend;\r\n\r\nprocedure TJvTipOfDay.Loaded;\r\nbegin\r\n inherited Loaded;\r\n if csDesigning in ComponentState then\r\n Exit;\r\n\r\n if toShowWhenFormShown in Options then\r\n HookForm\r\n else\r\n // Call AutoExecute, which will call Execute.\r\n // Execute will determine (by calling CanShow) if the dialog actually\r\n // must be shown.\r\n AutoExecute;\r\nend;\r\n\r\nprocedure TJvTipOfDay.LoadFromFile(const AFileName: string);\r\nbegin\r\n if Length(AFileName) = 0 then\r\n with TOpenDialog.Create(Application) do\r\n try\r\n if Execute then\r\n Tips.LoadFromFile(FileName);\r\n finally\r\n Free;\r\n end\r\n else\r\n if FileExists(AFileName) then\r\n Tips.LoadFromFile(AFileName);\r\nend;\r\n\r\nfunction TJvTipOfDay.ReadFromAppStorage: Boolean;\r\nbegin\r\n if Assigned(AppStorage) then\r\n Result := AppStorage.ReadBoolean(AppStorage.ConcatPaths([AppStoragePath,RsStoreShowOnStartUp]), toShowOnStartUp in Options)\r\n else\r\n Result := False;\r\nend;\r\n\r\nprocedure TJvTipOfDay.SaveToFile(const AFileName: string);\r\nbegin\r\n if Length(AFileName) = 0 then\r\n with TSaveDialog.Create(Application) do\r\n try\r\n if Execute then\r\n Tips.SaveToFile(FileName);\r\n finally\r\n Free;\r\n end\r\n else\r\n Tips.SaveToFile(AFileName);\r\nend;\r\n\r\nprocedure TJvTipOfDay.SetButtonClose(const Value: TJvTipOfDayButtonPersistent);\r\nbegin\r\n FButtonClose.Assign(Value);\r\nend;\r\n\r\nprocedure TJvTipOfDay.SetButtonNext(const Value: TJvTipOfDayButtonPersistent);\r\nbegin\r\n FButtonNext.Assign(Value);\r\nend;\r\n\r\nprocedure TJvTipOfDay.SetDefaultFonts(const Value: Boolean);\r\nbegin\r\n if Value <> FDefaultFonts then\r\n begin\r\n FDefaultFonts := Value;\r\n if FDefaultFonts then\r\n UpdateFonts;\r\n end;\r\nend;\r\n\r\nprocedure TJvTipOfDay.SetHeaderFont(const Value: TFont);\r\nbegin\r\n FHeaderFont.Assign(Value);\r\nend;\r\n\r\nprocedure TJvTipOfDay.SetStyle(const Value: TJvTipOfDayStyle);\r\nbegin\r\n if FStyle <> Value then\r\n begin\r\n FStyle := Value;\r\n if FDefaultFonts then\r\n UpdateFonts;\r\n end;\r\nend;\r\n\r\nprocedure TJvTipOfDay.SetTipFont(const Value: TFont);\r\nbegin\r\n FTipFont.Assign(Value);\r\nend;\r\n\r\nfunction TJvTipOfDay.GetTips: TStrings;\r\nbegin\r\n Result := FTips;\r\nend;\r\n\r\nprocedure TJvTipOfDay.SetTips(const Value: TStrings);\r\nbegin\r\n FTips.Assign(Value);\r\nend;\r\n\r\nprocedure TJvTipOfDay.UnHookForm;\r\nbegin\r\n JvWndProcHook.UnRegisterWndProcHook(FForm, HookProc, hoAfterMsg);\r\nend;\r\n\r\nprocedure TJvTipOfDay.UpdateFonts;\r\nvar\r\n SavedDefaultFonts: Boolean;\r\nbegin\r\n { If we change the fonts, FDefaultFonts will be set to False (in\r\n FontChanged), thus before changing we must save the current\r\n value of FDefaultFonts\r\n }\r\n SavedDefaultFonts := FDefaultFonts;\r\n\r\n FTipFont.Charset := DEFAULT_CHARSET;\r\n FTipFont.Color := clWindowText;\r\n FTipFont.Name := 'MS Sans Serif';\r\n FTipFont.Pitch := fpDefault;\r\n FTipFont.Size := 8;\r\n FTipFont.Style := [];\r\n\r\n FHeaderFont.Charset := DEFAULT_CHARSET;\r\n FHeaderFont.Color := clWindowText;\r\n FHeaderFont.Pitch := fpDefault;\r\n FHeaderFont.Style := [fsBold];\r\n\r\n case Style of\r\n tsVC:\r\n begin\r\n FHeaderFont.Name := 'Times New Roman';\r\n FHeaderFont.Size := 15;\r\n end;\r\n tsStandard:\r\n begin\r\n FHeaderFont.Name := 'System';\r\n FHeaderFont.Size := 10;\r\n end;\r\n end;\r\n\r\n FDefaultFonts := SavedDefaultFonts;\r\nend;\r\n\r\nprocedure TJvTipOfDay.UpdateTip;\r\nbegin\r\n if Tips.Count > 0 then\r\n TControlAccessProtected(FTipLabel).Caption := Tips[FCurrentTip];\r\n if Tips.Count <= 1 then\r\n TControlAccessProtected(FNextTipButton).Enabled := False;\r\nend;\r\n\r\nprocedure TJvTipOfDay.WriteToAppStorage(DoShowOnStartUp: Boolean);\r\nbegin\r\n if Assigned(AppStorage) then\r\n AppStorage.WriteBoolean(AppStorage.ConcatPaths([AppStoragePath,RsStoreShowOnStartUp]), DoShowOnStartUp);\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n\r\n" }, { "path": "External/Jedi/Jvcl/run/JvToolBar.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvToolBar.PAS, released on 2001-02-28.\r\n\r\nThe Initial Developer of the Original Code is Sbastien Buysse [sbuysse att buypin dott com]\r\nPortions created by Sbastien Buysse are Copyright (C) 2001 Sbastien Buysse.\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\n Michael Beck [mbeck att bigfoot dott com].\r\n Olivier Sannier [obones att altern dott org].\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvToolBar.pas 13155 2011-11-06 12:31:20Z ahuser $\r\n\r\nunit JvToolBar;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, Messages, CommCtrl, SysUtils, Classes, Graphics, Controls,\r\n Forms, ComCtrls, Menus,\r\n JvMenus, JvExComCtrls;\r\n\r\ntype\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvToolBar = class(TJvExToolBar)\r\n private\r\n FChangeLink: TJvMenuChangeLink;\r\n FTempMenu: TJvPopupMenu;\r\n FButtonMenu: TMenuItem;\r\n FMenuShowingCount: Integer;\r\n procedure ClearTempMenu;\r\n function GetMenu: TMainMenu;\r\n procedure SetMenu(const Value: TMainMenu);\r\n procedure MenuChange(Sender: TJvMainMenu; Source: TMenuItem; Rebuild: Boolean);\r\n procedure CNNotify(var Msg: TWMNotify); message CN_NOTIFY;\r\n procedure CNDropDownClosed(var Msg: TMessage); message CN_DROPDOWNCLOSED;\r\n protected\r\n procedure AdjustSize; override;\r\n {$IFDEF COMPILER12_UP}\r\n public\r\n {$ENDIF COMPILER12_UP}\r\n procedure GetChildren(Proc: TGetChildProc; Root: TComponent); override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n published\r\n property HintColor;\r\n property Menu: TMainMenu read GetMenu write SetMenu;\r\n property OnMouseEnter;\r\n property OnMouseLeave;\r\n property OnParentColorChange;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvToolBar.pas $';\r\n Revision: '$Revision: 13155 $';\r\n Date: '$Date: 2011-11-06 13:31:20 +0100 (dim. 06 nov. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nconstructor TJvToolBar.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FChangeLink := TJvMenuChangeLink.Create;\r\n FChangeLink.OnChange := MenuChange;\r\n ControlStyle := ControlStyle + [csAcceptsControls];\r\n FMenuShowingCount := 0;\r\nend;\r\n\r\ndestructor TJvToolBar.Destroy;\r\nbegin\r\n if (Menu <> nil) and (Menu is TJvMainMenu) then\r\n TJvMainMenu(Menu).UnregisterChanges(FChangeLink);\r\n FChangeLink.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJvToolBar.GetMenu: TMainMenu;\r\nbegin\r\n Result := inherited Menu;\r\nend;\r\n\r\nprocedure TJvToolBar.SetMenu(const Value: TMainMenu);\r\nbegin\r\n // if trying to set the same menu, do nothing\r\n if Menu = Value then\r\n Exit;\r\n\r\n if Assigned(Menu) and (Menu is TJvMainMenu) then\r\n // if the current menu is a TJvMainMenu, we must\r\n // unregister us from being told the changes\r\n TJvMainMenu(Menu).UnregisterChanges(FChangeLink);\r\n\r\n if Value is TJvMainMenu then\r\n // if the new menu is a TJvMainMenu then we register a link\r\n // with the menu to get informed when it has changed\r\n TJvMainMenu(Value).RegisterChanges(FChangeLink);\r\n\r\n // and we set the inherited value, so that the inherited\r\n // methods can deal with the menu too, the most obvious\r\n // one being the creation of the required TToolButton\r\n inherited Menu := Value;\r\nend;\r\n\r\nprocedure TJvToolBar.MenuChange(Sender: TJvMainMenu; Source: TMenuItem; Rebuild: Boolean);\r\nvar\r\n VisibleMenuItemsCount, VisibleButtonsCount: Integer;\r\n I: Integer;\r\nbegin\r\n if Sender = Menu then\r\n begin\r\n // Compute our own value for rebuild, as the value passed\r\n // to us is not correct (see TJvMenuChangeLink for details)\r\n // We rebuild if the number of visible items in the menu is different\r\n // from the number of buttons visible in the toolbar.\r\n VisibleMenuItemsCount := 0;\r\n for I := 0 to Menu.Items.Count-1 do\r\n if Menu.Items[i].Visible then\r\n Inc(VisibleMenuItemsCount);\r\n VisibleButtonsCount := 0;\r\n for I := 0 to ButtonCount-1 do\r\n if Buttons[i].Visible then\r\n Inc(VisibleButtonsCount);\r\n Rebuild := VisibleMenuItemsCount <> VisibleButtonsCount;\r\n\r\n // if rebuild is necessary then\r\n if Rebuild then\r\n begin\r\n // force reloading menu by changing value twice\r\n // this is the only way of doing it as the creation of\r\n // the TToolButton is done in the original SetMenu in\r\n // TToolbar and this procedure is private\r\n Menu := nil;\r\n Menu := Sender;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvToolBar.AdjustSize;\r\nvar\r\n I: Integer;\r\n TotWidth: Integer;\r\nbegin\r\n inherited AdjustSize;\r\n\r\n // if there is a menu and the toolbar is not wrapable,\r\n // update width according to sum of button widths\r\n if (Menu <> nil) and not Wrapable then\r\n begin\r\n TotWidth := 0;\r\n for I := 0 to ButtonCount - 1 do\r\n TotWidth := TotWidth + Buttons[I].Width;\r\n Width := TotWidth;\r\n end;\r\nend;\r\n\r\nprocedure TJvToolBar.ClearTempMenu;\r\nvar\r\n I: Integer;\r\n Item: TMenuItem;\r\nbegin\r\n if (FButtonMenu <> nil) and (FTempMenu <> nil) then\r\n begin\r\n for I := FTempMenu.Items.Count - 1 downto 0 do\r\n begin\r\n Item := FTempMenu.Items[I];\r\n FTempMenu.Items.Delete(I);\r\n FButtonMenu.Insert(0, Item);\r\n end;\r\n FTempMenu.Free;\r\n FTempMenu := nil;\r\n FButtonMenu := nil;\r\n end;\r\nend;\r\n\r\nprocedure TJvToolBar.CNNotify(var Msg: TWMNotify);\r\nvar\r\n Button: TToolButton;\r\n JvParentMenu: TJvMainMenu;\r\n Menu: TMenu;\r\n I: Integer;\r\n Item: TMenuItem;\r\nbegin\r\n // we process the WM_NOTIFY message ourselves to be able to\r\n // display a dropdown JvMenu instead of a regular one.\r\n // However, we do that only if the menu is a TJvMainMenu and\r\n // if the code in WM_NOTIFY is TBN_DROPDOWN. Anything else\r\n // is given back to the inherited method.\r\n // The code is mostly inspired from the Delphi 6 VCL source code,\r\n // the major change being the creation of a TJvPopupMenu\r\n // instead of a TPopupMenu.\r\n with Msg do\r\n begin\r\n case NMHdr^.code of\r\n TBN_DROPDOWN:\r\n with PNMToolBar(NMHdr)^ do\r\n { We can safely assume that a TBN_DROPDOWN message was generated by a\r\n TToolButton and not any TControl. }\r\n if Perform(TB_GETBUTTON, iItem, LPARAM(@tbButton)) <> 0 then\r\n begin\r\n Button := TToolButton(tbButton.dwData);\r\n if Button <> nil then\r\n begin\r\n Menu := nil;\r\n if Button.MenuItem <> nil then\r\n Menu := Button.MenuItem.GetParentMenu;\r\n if Menu is TJvMainMenu then\r\n begin\r\n JvParentMenu := Button.MenuItem.GetParentMenu as TJvMainMenu;\r\n Button.MenuItem.Click;\r\n ClearTempMenu;\r\n FTempMenu := TJvPopupMenu.Create(nil);\r\n if JvParentMenu <> nil then\r\n FTempMenu.BiDiMode := JvParentMenu.BiDiMode;\r\n FTempMenu.HelpContext := Button.MenuItem.HelpContext;\r\n FTempMenu.TrackButton := tbLeftButton;\r\n Menu := Button.MenuItem.GetParentMenu;\r\n if Menu <> nil then\r\n FTempMenu.Assign(JvParentMenu);\r\n FButtonMenu := Button.MenuItem;\r\n for I := FButtonMenu.Count - 1 downto 0 do\r\n begin\r\n Item := FButtonMenu.Items[I];\r\n FButtonMenu.Delete(I);\r\n FTempMenu.Items.Insert(0, Item);\r\n end;\r\n\r\n Button.DropdownMenu := FTempMenu;\r\n // for some reason, while the menu is showing,\r\n // it is possible that a second message comes\r\n // up and asks for the menu to show up.\r\n // so we keep track of that fact, and only when\r\n // the count comes back to 0, we hide the menu\r\n // in the CN_DROPDOWNCLOSED handler\r\n Inc(FMenuShowingCount);\r\n // show the temporary popup menu\r\n Button.CheckMenuDropdown;\r\n end\r\n else\r\n inherited;\r\n end;\r\n end;\r\n else\r\n inherited;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvToolBar.CNDropDownClosed(var Msg: TMessage);\r\nbegin\r\n if FMenuShowingCount = 1 then\r\n ClearTempMenu;\r\n Dec(FMenuShowingCount);\r\n inherited;\r\nend;\r\n\r\nprocedure TJvToolBar.GetChildren(Proc: TGetChildProc; Root: TComponent);\r\nbegin\r\n // This is required by v5 VCL so that it doesn't save the buttons\r\n // created because of the menu property. This is redundant\r\n // under v6 VCL because it already does that check.\r\n if not Assigned(Menu) then\r\n inherited GetChildren(Proc, Root);\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvToolEdit.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvToolEdit.PAS, released on 2002-07-04.\r\n\r\nThe Initial Developers of the Original Code are: Fedor Koshevnikov, Igor Pavluk and Serge Korolev\r\nCopyright (c) 1997, 1998 Fedor Koshevnikov, Igor Pavluk and Serge Korolev\r\nCopyright (c) 2001,2002 SGB Software\r\nAll Rights Reserved.\r\n\r\nContributers:\r\n Rob den Braasem [rbraasem att xs4all dott nl]\r\n Polaris Software\r\n rblaurindo\r\n Andreas Hausladen\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n (rb) Move button related functionality from TJvCustomComboEdit to TJvEditButton\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvToolEdit.pas 13415 2012-09-10 09:51:54Z obones $\r\n\r\nunit JvToolEdit;\r\n\r\n{$I jvcl.inc}\r\n{$I crossplatform.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n {$IFDEF MSWINDOWS}\r\n Windows, Messages, ShellAPI, ActiveX,\r\n {$ENDIF MSWINDOWS}\r\n Types,\r\n ShlObj,\r\n Variants,\r\n SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls, Menus,\r\n Buttons, FileCtrl, Mask, ImgList, ActnList, ExtDlgs,\r\n {$IFDEF HAS_UNIT_SYSTEM_UITYPES}\r\n System.UITypes,\r\n {$ENDIF HAS_UNIT_SYSTEM_UITYPES}\r\n JvConsts,\r\n JvExControls, JvSpeedButton, JvTypes, JvExMask,\r\n JvDataSourceIntf, JvBrowseFolder;\r\n\r\nconst\r\n scAltDown = scAlt + VK_DOWN;\r\n DefEditBtnWidth = 21;\r\n\r\n{$IFNDEF COMPILER7_UP}\r\n// Autocomplete stuff for Delphi 5 and 6. (missing in ShlObj)\r\ntype\r\n IAutoComplete = interface(IUnknown)\r\n ['{00bb2762-6a77-11d0-a535-00c04fd7d062}']\r\n function Init(hwndEdit: THandle; punkACL: IUnknown;\r\n pwszRegKeyPath: LPCWSTR; pwszQuickComplete: LPCWSTR): HRESULT; stdcall;\r\n function Enable(fEnable: BOOL): HRESULT; stdcall;\r\n end;\r\n {$EXTERNALSYM IAutoComplete}\r\n\r\nconst\r\n { IAutoComplete2 options }\r\n ACO_NONE = 0;\r\n ACO_AUTOSUGGEST = $1;\r\n ACO_AUTOAPPEND = $2;\r\n ACO_SEARCH = $4;\r\n ACO_FILTERPREFIXES = $8;\r\n ACO_USETAB = $10;\r\n ACO_UPDOWNKEYDROPSLIST = $20;\r\n ACO_RTLREADING = $40;\r\n\r\ntype\r\n IAutoComplete2 = interface(IAutoComplete)\r\n ['{EAC04BC0-3791-11d2-BB95-0060977B464C}']\r\n function SetOptions(dwFlag: DWORD): HRESULT; stdcall;\r\n function GetOptions(var dwFlag: DWORD): HRESULT; stdcall;\r\n end;\r\n {$EXTERNALSYM IAutoComplete2}\r\n \r\n // To avoid ambiguities, we include shldisp.h and define the _di_ interfaces ourselves\r\n {$HPPEMIT '#include \"shldisp.h\"'}\r\n {$HPPEMIT 'typedef DelphiInterface _di_IAutoComplete;'}\r\n {$HPPEMIT 'typedef DelphiInterface _di_IAutoComplete2;'}\r\n{$ENDIF !COMPILER7_UP}\r\n\r\n// C++ Builder needs this HPPEMIT in order for the generated header to compile.\r\n{$HPPEMIT 'typedef DelphiInterface _di_IEnumString;'}\r\n\r\ntype\r\n TFileExt = type string;\r\n\r\n TCloseUpEvent = procedure(Sender: TObject; Accept: Boolean) of object;\r\n TPopupAlign = (epaRight, epaLeft);\r\n\r\n TJvPopupWindowBase = TJvExCustomControl;\r\n\r\n TJvPopupWindow = class(TJvPopupWindowBase)\r\n private\r\n FEditor: TWinControl;\r\n FCloseUp: TCloseUpEvent;\r\n procedure WMMouseActivate(var Msg: TMessage); message WM_MOUSEACTIVATE;\r\n procedure WMActivate(var Msg: TWMActivate); message WM_ACTIVATE;\r\n protected\r\n FActiveControl: TWinControl;\r\n FIsFocusable: Boolean;\r\n procedure CreateParams(var Params: TCreateParams); override;\r\n function GetValue: Variant; virtual; abstract;\r\n procedure SetValue(const Value: Variant); virtual; abstract;\r\n procedure InvalidateEditor;\r\n procedure MouseUp(Button: TMouseButton; Shift: TShiftState;\r\n X, Y: Integer); override;\r\n procedure CloseUp(Accept: Boolean); virtual;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n function GetPopupText: string; virtual;\r\n procedure Hide;\r\n procedure Show(Origin: TPoint); virtual;\r\n { Determines the ctrl that receives the keyboard input if the dropdown\r\n window is showing, but the combo edit still has focus }\r\n property ActiveControl: TWinControl read FActiveControl;\r\n { Determines whether the popup window may be activated }\r\n property IsFocusable: Boolean read FIsFocusable;\r\n property OnCloseUp: TCloseUpEvent read FCloseUp write FCloseUp;\r\n end;\r\n\r\n TJvEditButton = class(TJvImageSpeedButton)\r\n private\r\n FNoAction: Boolean;\r\n procedure WMContextMenu(var Msg: TWMContextMenu); message WM_CONTEXTMENU;\r\n function GetGlyph: TBitmap;\r\n function GetNumGlyphs: TJvNumGlyphs;\r\n function GetUseGlyph: Boolean;\r\n procedure SetGlyph(const Value: TBitmap);\r\n procedure SetNumGlyphs(Value: TJvNumGlyphs);\r\n protected\r\n {$IFDEF JVCLThemesEnabled}\r\n FDrawThemedDropDownBtn: Boolean;\r\n {$ENDIF JVCLThemesEnabled}\r\n FStandard: Boolean;\r\n procedure MouseDown(Button: TMouseButton; Shift: TShiftState;\r\n X, Y: Integer); override;\r\n procedure PaintImage(Canvas: TCanvas; ARect: TRect; const Offset: TPoint;\r\n AState: TJvButtonState; DrawMark: Boolean; PaintOnGlass: Boolean); override;\r\n procedure Paint; override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n procedure Click; override;\r\n\r\n property UseGlyph: Boolean read GetUseGlyph;// write FDrawGlyph;\r\n property Glyph: TBitmap read GetGlyph write SetGlyph;\r\n property NumGlyphs: TJvNumGlyphs read GetNumGlyphs write SetNumGlyphs;\r\n end;\r\n\r\n TGlyphKind = (gkCustom, gkDefault, gkDropDown, gkEllipsis);\r\n TJvImageKind = (ikCustom, ikDefault, ikDropDown, ikEllipsis);\r\n\r\n TJvCustomComboEdit = class;\r\n\r\n TJvCustomComboEditActionLink = class(TWinControlActionLink)\r\n protected\r\n function IsCaptionLinked: Boolean; override;\r\n function IsHintLinked: Boolean; override;\r\n function IsImageIndexLinked: Boolean; override;\r\n function IsOnExecuteLinked: Boolean; override;\r\n function IsShortCutLinked: Boolean; override;\r\n procedure SetHint(const Value: THintString); override;\r\n procedure SetImageIndex(Value: Integer); override;\r\n procedure SetOnExecute(Value: TNotifyEvent); override;\r\n procedure SetShortCut(Value: TShortCut); override;\r\n end;\r\n\r\n TJvCustomComboEditActionLinkClass = class of TJvCustomComboEditActionLink;\r\n\r\n TJvAutoCompleteOption = (acoAutoSuggest, acoAutoAppend, acoSearch,\r\n acoFilterPrefixes, acoUseTab, acoUpDownKeyDropsList, acoRTLReading);\r\n TJvAutoCompleteOptions = set of TJvAutoCompleteOption;\r\n TJvAutoCompleteFileOption = (acfFileSystem, acfFileSysDirs, acfURLHistory, acfURLMRU);\r\n TJvAutoCompleteFileOptions = set of TJvAutoCompleteFileOption;\r\n\r\n TJvCustomComboEditDataConnector = class(TJvFieldDataConnector)\r\n private\r\n FEdit: TJvCustomComboEdit;\r\n protected\r\n procedure RecordChanged; override;\r\n procedure UpdateData; override;\r\n property Control: TJvCustomComboEdit read FEdit;\r\n public\r\n constructor Create(AEdit: TJvCustomComboEdit);\r\n end;\r\n\r\n TJvCustomComboEdit = class(TJvExCustomMaskEdit)\r\n private\r\n FOnButtonClick: TNotifyEvent;\r\n FOnPopupShown: TNotifyEvent;\r\n FOnPopupHidden: TNotifyEvent;\r\n FClickKey: TShortCut;\r\n FReadOnly: Boolean;\r\n FDirectInput: Boolean;\r\n FAlwaysEnableButton: Boolean;\r\n FAlwaysShowPopup: Boolean;\r\n FPopupAlign: TPopupAlign;\r\n FGroupIndex: Integer;\r\n FDisabledColor: TColor;\r\n FDisabledTextColor: TColor;\r\n FOnKeyDown: TKeyEvent;\r\n FImages: TCustomImageList;\r\n FImageIndex: TImageIndex;\r\n FImageKind: TJvImageKind;\r\n FNumGlyphs: Integer;\r\n FStreamedButtonWidth: Integer;\r\n FStreamedFixedWidth: Boolean;\r\n FOnEnabledChanged: TNotifyEvent;\r\n { We hide the button by setting its width to 0, thus we have to store the\r\n width the button should have when shown again in FSavedButtonWidth: }\r\n FSavedButtonWidth: Integer;\r\n FDataConnector: TJvCustomComboEditDataConnector;\r\n FAlignment: TAlignment;\r\n FAutoCompleteIntf: IAutoComplete;\r\n FAutoCompleteItems: TStrings;\r\n FAutoCompleteOptions: TJvAutoCompleteOptions;\r\n FTextChanged: Boolean;\r\n FInCMExit: Integer;\r\n FCheckOnExit: Boolean;\r\n FOnPopupChange: TNotifyEvent;\r\n FOnPopupValueAccepted: TNotifyEvent;\r\n procedure SetAutoCompleteItems(Strings: TStrings);\r\n procedure SetAutoCompleteOptions(const Value: TJvAutoCompleteOptions);\r\n procedure SetAlignment(Value: TAlignment);\r\n function GetFlat: Boolean;\r\n procedure ReadCtl3D(Reader: TReader);\r\n procedure ReadParentCtl3D(Reader: TReader);\r\n procedure SetFlat(const Value: Boolean);\r\n function GetParentFlat: Boolean;\r\n procedure SetParentFlat(const Value: Boolean);\r\n function IsFlatStored: Boolean;\r\n function BtnWidthStored: Boolean;\r\n function GetButtonFlat: Boolean;\r\n function GetButtonHint: string;\r\n function GetButtonWidth: Integer;\r\n function GetDirectInput: Boolean;\r\n function GetGlyph: TBitmap;\r\n function GetGlyphKind: TGlyphKind;\r\n function GetMinHeight: Integer;\r\n function GetNumGlyphs: TNumGlyphs;\r\n function GetPopupVisible: Boolean;\r\n function GetShowButton: Boolean;\r\n function GetTextHeight: Integer;\r\n function IsImageIndexStored: Boolean;\r\n function IsCustomGlyph: Boolean;\r\n procedure EditButtonClick(Sender: TObject);\r\n procedure ReadGlyphKind(Reader: TReader);\r\n procedure RecreateGlyph;\r\n procedure SetButtonFlat(const Value: Boolean);\r\n procedure SetButtonHint(const Value: string);\r\n procedure SetButtonWidth(Value: Integer);\r\n procedure SetGlyph(Value: TBitmap);\r\n procedure SetGlyphKind(Value: TGlyphKind);\r\n procedure SetImageIndex(const Value: TImageIndex);\r\n procedure SetImageKind(const Value: TJvImageKind);\r\n procedure SetImages(const Value: TCustomImageList);\r\n procedure SetNumGlyphs(const Value: TNumGlyphs);\r\n procedure SetShowButton(const Value: Boolean);\r\n procedure SetDataConnector(const Value: TJvCustomComboEditDataConnector);\r\n procedure UpdateBtnBounds(var NewLeft, NewTop, NewWidth, NewHeight: Integer);\r\n procedure UpdateGroup;\r\n procedure CMWantSpecialKey(var Msg: TCMWantSpecialKey); message CM_WANTSPECIALKEY;\r\n procedure CMBiDiModeChanged(var Msg: TMessage); message CM_BIDIMODECHANGED;\r\n procedure CMCancelMode(var Msg: TCMCancelMode); message CM_CANCELMODE;\r\n procedure CMCtl3DChanged(var Msg: TMessage); message CM_CTL3DCHANGED;\r\n procedure CNCtlColor(var Msg: TMessage); message CN_CTLCOLOREDIT;\r\n procedure WMPaint(var Msg: TWMPaint); message WM_PAINT;\r\n procedure CMPopupCloseup(var Msg: TMessage); message CM_POPUPCLOSEUP;\r\n {$IFDEF JVCLThemesEnabled}\r\n procedure WMNCPaint(var Msg: TWMNCPaint); message WM_NCPAINT;\r\n procedure WMNCCalcSize(var Msg: TWMNCCalcSize); message WM_NCCALCSIZE;\r\n {$ENDIF JVCLThemesEnabled}\r\n procedure WMNCHitTest(var Msg: TWMNCHitTest); message WM_NCHITTEST;\r\n procedure CMFixCaretPosition(var Msg: TMessage); message CM_FIXCARETPOSITION;\r\n protected\r\n FButton: TJvEditButton;\r\n FBtnControl: TWinControl;\r\n FPopupVisible: Boolean;\r\n FFocused: Boolean;\r\n FPopup: TWinControl;\r\n function CreateDataConnector: TJvCustomComboEditDataConnector; virtual;\r\n procedure CustomAlignPosition(Control: TControl; var NewLeft, NewTop, NewWidth,\r\n NewHeight: Integer; var AlignRect: TRect; AlignInfo: TAlignInfo); override;\r\n procedure WndProc(var Msg: TMessage); override;\r\n procedure WMClear(var Msg: TMessage); message WM_CLEAR;\r\n procedure WMCut(var Msg: TMessage); message WM_CUT;\r\n procedure WMPaste(var Msg: TMessage); message WM_PASTE;\r\n procedure AdjustSize; override;\r\n procedure FocusKilled(NextWnd: THandle); override;\r\n procedure FocusSet(PrevWnd: THandle); override;\r\n procedure EnabledChanged; override;\r\n procedure FontChanged; override;\r\n procedure DoEnter; override;\r\n procedure DoExit; override;\r\n procedure DoCtl3DChanged; virtual;\r\n function DoEraseBackground(Canvas: TCanvas; Param: LPARAM): Boolean; override;\r\n { Repositions the child controls; checkbox }\r\n procedure UpdateControls; virtual;\r\n { Updates the margins of the edit box }\r\n procedure UpdateMargins; dynamic;\r\n { Returns the margins of the edit box }\r\n procedure GetInternalMargins(var ALeft, ARight: Integer); virtual;\r\n procedure CreatePopup; virtual;\r\n procedure HidePopup; virtual; // (ahuser): WARNING: Do not release or free the component in HidePopup -> else AV in MouseUp\r\n procedure ShowPopup(Origin: TPoint); virtual;\r\n function AcceptPopup(var Value: Variant): Boolean; virtual;\r\n function EditCanModify: Boolean; override;\r\n function GetActionLinkClass: TControlActionLinkClass; override;\r\n function GetPopupValue: Variant; virtual;\r\n function GetReadOnly: Boolean; virtual;\r\n function GetSettingCursor: Boolean;\r\n procedure AcceptValue(const Value: Variant); virtual;\r\n procedure ActionChange(Sender: TObject; CheckDefaults: Boolean); override;\r\n procedure AdjustHeight;\r\n procedure ButtonClick; dynamic;\r\n procedure Change; override;\r\n procedure CreateWnd; override;\r\n procedure CreateParams(var Params: TCreateParams); override;\r\n procedure CreateAutoComplete; virtual;\r\n procedure DestroyWnd; override;\r\n procedure DestroyAutoComplete; virtual;\r\n procedure UpdateAutoComplete; virtual;\r\n function GetAutoCompleteSource: IEnumString; virtual;\r\n procedure DefineProperties(Filer: TFiler); override;\r\n procedure DoChange; virtual; //virtual Polaris\r\n procedure KeyDown(var Key: Word; Shift: TShiftState); override;\r\n procedure KeyPress(var Key: Char); override;\r\n procedure Loaded; override;\r\n procedure LocalKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);\r\n procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;\r\n procedure Notification(AComponent: TComponent; Operation: TOperation); override;\r\n procedure PopupChange; virtual;\r\n procedure PopupCloseUp(Sender: TObject; Accept: Boolean); virtual;\r\n procedure AsyncPopupCloseUp(Accept: Boolean); virtual;\r\n procedure PopupDropDown(DisableEdit: Boolean); virtual;\r\n procedure SetClipboardCommands(const Value: TJvClipboardCommands); override;\r\n procedure SetDirectInput(Value: Boolean);\r\n procedure SetDisabledColor(const Value: TColor); virtual;\r\n procedure SetDisabledTextColor(const Value: TColor); virtual;\r\n procedure SetGroupIndex(const Value: Integer);\r\n procedure SetPopupValue(const Value: Variant); virtual;\r\n procedure SetReadOnly(Value: Boolean); virtual;\r\n procedure SetShowCaret;\r\n procedure UpdatePopupVisible;\r\n procedure CMExit(var Message: TCMExit); message CM_EXIT;\r\n property Alignment: TAlignment read FAlignment write SetAlignment default taLeftJustify;\r\n property AlwaysEnableButton: Boolean read FAlwaysEnableButton write FAlwaysEnableButton default False;\r\n property AlwaysShowPopup: Boolean read FAlwaysShowPopup write FAlwaysShowPopup default False;\r\n property AutoCompleteItems: TStrings read FAutoCompleteItems write SetAutoCompleteItems;\r\n property AutoCompleteOptions: TJvAutoCompleteOptions read FAutoCompleteOptions write SetAutoCompleteOptions default [];\r\n property Button: TJvEditButton read FButton;\r\n property ButtonFlat: Boolean read GetButtonFlat write SetButtonFlat default False;\r\n property ButtonHint: string read GetButtonHint write SetButtonHint;\r\n property ButtonWidth: Integer read GetButtonWidth write SetButtonWidth stored BtnWidthStored;\r\n property ClickKey: TShortCut read FClickKey write FClickKey default scAltDown;\r\n property DirectInput: Boolean read GetDirectInput write SetDirectInput default True;\r\n property DisabledColor: TColor read FDisabledColor write SetDisabledColor default clWindow;\r\n property DisabledTextColor: TColor read FDisabledTextColor write SetDisabledTextColor default clGrayText;\r\n property Flat: Boolean read GetFlat write SetFlat stored IsFlatStored;\r\n property ParentFlat: Boolean read GetParentFlat write SetParentFlat default True;\r\n property Glyph: TBitmap read GetGlyph write SetGlyph stored IsCustomGlyph;\r\n property GroupIndex: Integer read FGroupIndex write SetGroupIndex default -1;\r\n property ImageIndex: TImageIndex read FImageIndex write SetImageIndex stored IsImageIndexStored default -1;\r\n property ImageKind: TJvImageKind read FImageKind write SetImageKind default ikCustom;\r\n property Images: TCustomImageList read FImages write SetImages;\r\n property NumGlyphs: TNumGlyphs read GetNumGlyphs write SetNumGlyphs default 1;\r\n property OnButtonClick: TNotifyEvent read FOnButtonClick write FOnButtonClick;\r\n property OnKeyDown: TKeyEvent read FOnKeyDown write FOnKeyDown;\r\n property PopupAlign: TPopupAlign read FPopupAlign write FPopupAlign default epaRight;\r\n property PopupVisible: Boolean read GetPopupVisible;\r\n property ReadOnly: Boolean read GetReadOnly write SetReadOnly default False;\r\n property SettingCursor: Boolean read GetSettingCursor;\r\n property ShowButton: Boolean read GetShowButton write SetShowButton default True;\r\n // CheckOnExit disables the ValidateEdit call that TCustomMaskEdit executes when\r\n // it receives a CM_EXIT message. If you set it to False, you should call ValidateEdit\r\n // yourself when you want to validate the value (like in the OK button of a dialog).\r\n property CheckOnExit: Boolean read FCheckOnExit write FCheckOnExit default True;\r\n property OnEnabledChanged: TNotifyEvent read FOnEnabledChanged write FOnEnabledChanged;\r\n property OnPopupShown: TNotifyEvent read FOnPopupShown write FOnPopupShown;\r\n property OnPopupHidden: TNotifyEvent read FOnPopupHidden write FOnPopupHidden;\r\n // OnPopupChange is triggered when the edit text is changed while the popup is visible.\r\n property OnPopupChange: TNotifyEvent read FOnPopupChange write FOnPopupChange;\r\n // OnPopupValueAccepted is triggered when the value from the popup is accepted and written to\r\n // the edit's text property. It is not triggered if the new value is the same as the old value.\r\n property OnPopupValueAccepted: TNotifyEvent read FOnPopupValueAccepted write FOnPopupValueAccepted;\r\n\r\n property DataConnector: TJvCustomComboEditDataConnector read FDataConnector write SetDataConnector;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n procedure ValidateEdit; override;\r\n class function DefaultImageIndex: TImageIndex; virtual;\r\n class function DefaultImages: TCustomImageList; virtual;\r\n procedure DoClick;\r\n procedure SelectAll;\r\n { Backwards compatibility; moved to public&published; eventually remove }\r\n property GlyphKind: TGlyphKind read GetGlyphKind write SetGlyphKind;\r\n property Ctl3D;\r\n end;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvComboEdit = class(TJvCustomComboEdit)\r\n public\r\n property Button;\r\n published\r\n property Action;\r\n property Align;\r\n property Alignment;\r\n property AlwaysEnableButton;\r\n property AlwaysShowPopup;\r\n property Anchors;\r\n property AutoSelect;\r\n property AutoSize;\r\n property AutoCompleteItems;\r\n property AutoCompleteOptions;\r\n property BevelEdges;\r\n property BevelInner;\r\n property BevelKind default bkNone;\r\n property BevelOuter;\r\n property BiDiMode;\r\n property DragCursor;\r\n property DragKind;\r\n property Flat;\r\n property ImeMode;\r\n property ImeName;\r\n property OEMConvert;\r\n property ParentBiDiMode;\r\n property ParentFlat;\r\n property OnEndDock;\r\n property OnStartDock;\r\n property BorderStyle;\r\n property ButtonFlat;\r\n property ButtonHint;\r\n property ButtonWidth;\r\n property CharCase;\r\n property ClickKey;\r\n property ClipboardCommands;\r\n property Color;\r\n property Constraints;\r\n property DirectInput;\r\n property DisabledColor;\r\n property DisabledTextColor;\r\n property DragMode;\r\n property EditMask;\r\n property Enabled;\r\n property Font;\r\n property Glyph;\r\n property HideSelection;\r\n property ImageIndex;\r\n property ImageKind;\r\n property Images;\r\n property MaxLength;\r\n property NumGlyphs;\r\n property ParentColor;\r\n property ParentFont;\r\n property ParentShowHint;\r\n property PopupMenu;\r\n property ReadOnly;\r\n property ShowHint;\r\n property ShowButton;\r\n property TabOrder;\r\n property TabStop;\r\n property Text;\r\n property Visible;\r\n property OnButtonClick;\r\n property OnChange;\r\n property OnClick;\r\n property OnContextPopup;\r\n property OnDblClick;\r\n property OnDragDrop;\r\n property OnDragOver;\r\n property OnEndDrag;\r\n property OnEnter;\r\n property OnExit;\r\n property OnKeyDown;\r\n property OnKeyPress;\r\n property OnKeyUp;\r\n property OnMouseDown;\r\n property OnMouseEnter;\r\n property OnMouseLeave;\r\n property OnMouseMove;\r\n property OnMouseUp;\r\n property OnStartDrag;\r\n\r\n property DataConnector;\r\n property OnPopupShown;\r\n property OnPopupHidden;\r\n property OnPopupChange;\r\n property OnPopupValueAccepted;\r\n end;\r\n\r\n { TJvFileDirEdit }\r\n { The common parent of TJvFilenameEdit and TJvDirectoryEdit }\r\n { For internal use only; it's not intended to be used separately }\r\n\r\ntype\r\n TExecOpenDialogEvent = procedure(Sender: TObject; var AName: string; var AAction: Boolean) of object;\r\n\r\n TJvFileDirEdit = class(TJvCustomComboEdit)\r\n private\r\n FErrMode: Cardinal;\r\n FMultipleDirs: Boolean;\r\n FOnDropFiles: TNotifyEvent;\r\n FOnBeforeDialog: TExecOpenDialogEvent;\r\n FOnAfterDialog: TExecOpenDialogEvent;\r\n FAcceptFiles: Boolean;\r\n FMRUList: IUnknown;\r\n FHistoryList: IUnknown;\r\n FFileSystemList: IUnknown;\r\n FAutoCompleteFileOptions: TJvAutoCompleteFileOptions;\r\n FAutoCompleteSourceIntf: IEnumString;\r\n procedure SetAutoCompleteFileOptions(const Value: TJvAutoCompleteFileOptions);\r\n procedure SetDragAccept(Value: Boolean);\r\n procedure SetAcceptFiles(Value: Boolean);\r\n procedure WMDropFiles(var Msg: TWMDropFiles); message WM_DROPFILES;\r\n {$IFDEF JVCLThemesEnabled}\r\n procedure CMSysColorChange(var Msg: TMessage); message CM_SYSCOLORCHANGE;\r\n {$ENDIF JVCLThemesEnabled}\r\n protected\r\n procedure CreateHandle; override;\r\n procedure DestroyWindowHandle; override;\r\n procedure DestroyAutoComplete; override;\r\n procedure UpdateAutoComplete; override;\r\n function GetAutoCompleteSource: IEnumString; override;\r\n function GetLongName: string; virtual; abstract;\r\n function GetShortName: string; virtual; abstract;\r\n function GetLocalizedName: string; virtual; abstract;\r\n procedure DoAfterDialog(var FileName: string; var Action: Boolean); dynamic;\r\n procedure DoBeforeDialog(var FileName: string; var Action: Boolean); dynamic;\r\n procedure ReceptFileDir(const AFileName: string); virtual; abstract;\r\n procedure ClearFileList; virtual;\r\n procedure Change; override;\r\n procedure DisableSysErrors;\r\n procedure EnableSysErrors;\r\n property AutoCompleteFileOptions: TJvAutoCompleteFileOptions read FAutoCompleteFileOptions write\r\n SetAutoCompleteFileOptions;\r\n property AutoCompleteOptions default [acoAutoSuggest];\r\n property ImageKind default ikDefault;\r\n property MaxLength;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n property LongName: string read GetLongName;\r\n property ShortName: string read GetShortName;\r\n property LocalizedName: string read GetLocalizedName;\r\n published\r\n property AcceptFiles: Boolean read FAcceptFiles write SetAcceptFiles default True;\r\n property AlwaysEnableButton default True;\r\n property AlwaysShowPopup default True;\r\n property OnBeforeDialog: TExecOpenDialogEvent read FOnBeforeDialog write FOnBeforeDialog;\r\n property OnAfterDialog: TExecOpenDialogEvent read FOnAfterDialog write FOnAfterDialog;\r\n property OnDropFiles: TNotifyEvent read FOnDropFiles write FOnDropFiles;\r\n property OnButtonClick;\r\n property ClipboardCommands;\r\n property DisabledTextColor;\r\n property DisabledColor;\r\n {$IFDEF UNICODE}\r\n property OEMConvert default False; // Mantis 4454\r\n {$ELSE}\r\n property OEMConvert default True; // Mantis 3621\r\n {$ENDIF UNICODE}\r\n end;\r\n\r\n TFileDialogKind = (dkOpen, dkSave, dkOpenPicture, dkSavePicture);\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvFilenameEdit = class(TJvFileDirEdit)\r\n private\r\n FDialog: TOpenDialog;\r\n FDialogKind: TFileDialogKind;\r\n FAddQuotes: Boolean;\r\n FPhysicalFileName: string;\r\n FDisplayLocalizedName: Boolean;\r\n procedure CreateEditDialog;\r\n function GetFileName: TFileName;\r\n function GetDefaultExt: TFileExt;\r\n function GetFileEditStyle: TFileEditStyle;\r\n function GetFilter: string;\r\n function GetFilterIndex: Integer;\r\n function GetInitialDir: string;\r\n function GetHistoryList: TStrings;\r\n function GetOptions: TOpenOptions;\r\n function GetDialogTitle: string;\r\n function GetDialogFiles: TStrings;\r\n procedure SetDialogKind(Value: TFileDialogKind);\r\n procedure SetFileName(const Value: TFileName);\r\n procedure SetDefaultExt(Value: TFileExt);\r\n procedure SetFileEditStyle(Value: TFileEditStyle);\r\n procedure SetFilter(const Value: string);\r\n procedure SetFilterIndex(Value: Integer);\r\n procedure SetInitialDir(const Value: string);\r\n procedure SetHistoryList(Value: TStrings);\r\n procedure SetOptions(Value: TOpenOptions);\r\n procedure SetDialogTitle(const Value: string);\r\n function IsCustomTitle: Boolean;\r\n function IsCustomFilter: Boolean;\r\n procedure SetDisplayLocalizedName(const Value: Boolean);\r\n protected\r\n procedure PopupDropDown(DisableEdit: Boolean); override;\r\n procedure ReceptFileDir(const AFileName: string); override;\r\n procedure ClearFileList; override;\r\n function GetLongName: string; override;\r\n function GetShortName: string; override;\r\n function GetLocalizedName: string; override;\r\n procedure DoEnter; override;\r\n procedure DoExit; override;\r\n procedure WndProc(var Msg: TMessage); override;\r\n procedure Change; override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n class function DefaultImageIndex: TImageIndex; override;\r\n property Dialog: TOpenDialog read FDialog;\r\n property DialogFiles: TStrings read GetDialogFiles;\r\n published\r\n property Action;\r\n property Align;\r\n property AutoSize;\r\n property AddQuotes: Boolean read FAddQuotes write FAddQuotes default True;\r\n property DialogKind: TFileDialogKind read FDialogKind write SetDialogKind default dkOpen;\r\n property DisplayLocalizedName: Boolean read FDisplayLocalizedName write SetDisplayLocalizedName default False;\r\n property DefaultExt: TFileExt read GetDefaultExt write SetDefaultExt;\r\n property AutoCompleteOptions;\r\n property AutoCompleteFileOptions default [acfFileSystem];\r\n property BevelEdges;\r\n property BevelInner;\r\n property BevelKind default bkNone;\r\n property BevelOuter;\r\n property Flat;\r\n property ParentFlat;\r\n { (rb) Obsolete; added 'stored False', eventually remove }\r\n property FileEditStyle: TFileEditStyle read GetFileEditStyle write SetFileEditStyle stored False;\r\n property FileName: TFileName read GetFileName write SetFileName stored False;\r\n property Filter: string read GetFilter write SetFilter stored IsCustomFilter;\r\n property FilterIndex: Integer read GetFilterIndex write SetFilterIndex default 1;\r\n property InitialDir: string read GetInitialDir write SetInitialDir;\r\n { (rb) Obsolete; added 'stored False', eventually remove }\r\n property HistoryList: TStrings read GetHistoryList write SetHistoryList stored False;\r\n property DialogOptions: TOpenOptions read GetOptions write SetOptions default [ofHideReadOnly];\r\n property DialogTitle: string read GetDialogTitle write SetDialogTitle stored IsCustomTitle;\r\n property AutoSelect;\r\n property ButtonHint;\r\n property ButtonFlat;\r\n property BorderStyle;\r\n property CharCase;\r\n property ClickKey;\r\n property Color;\r\n property DirectInput;\r\n property DragCursor;\r\n property BiDiMode;\r\n property DragKind;\r\n property ParentBiDiMode;\r\n property ImeMode;\r\n property ImeName;\r\n property OnEndDock;\r\n property OnStartDock;\r\n property DragMode;\r\n property EditMask;\r\n property Enabled;\r\n property Font;\r\n property Glyph;\r\n property GroupIndex;\r\n property ImageIndex;\r\n property Images;\r\n property ImageKind;\r\n property NumGlyphs;\r\n property ButtonWidth;\r\n property HideSelection;\r\n property Anchors;\r\n property Constraints;\r\n property ParentColor;\r\n property ParentFont;\r\n property ParentShowHint;\r\n property PopupMenu;\r\n property ReadOnly;\r\n property ShowHint;\r\n property ShowButton;\r\n property TabOrder;\r\n property TabStop;\r\n property Text;\r\n property Visible;\r\n property OnChange;\r\n property OnClick;\r\n property OnDblClick;\r\n property OnDragDrop;\r\n property OnDragOver;\r\n property OnEndDrag;\r\n property OnEnter;\r\n property OnExit;\r\n property OnKeyDown;\r\n property OnKeyPress;\r\n property OnKeyUp;\r\n property OnMouseDown;\r\n property OnMouseEnter;\r\n property OnMouseLeave;\r\n property OnMouseMove;\r\n property OnMouseUp;\r\n property OnStartDrag;\r\n property OnContextPopup;\r\n end;\r\n\r\n TDirDialogKind = (dkVCL, dkWin32);\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvDirectoryEdit = class(TJvFileDirEdit)\r\n private\r\n FOptions: TSelectDirOpts;\r\n FInitialDir: string;\r\n FDialogText: string;\r\n FDialogKind: TDirDialogKind;\r\n FPhysicalDirectory: string;\r\n FDisplayLocalizedName: Boolean;\r\n FOptionsWin32: TOptionsDir;\r\n\r\n procedure SetDirectory(const Value: string);\r\n function GetDirectory: string;\r\n procedure SetDisplayLocalizedName(const Value: Boolean);\r\n protected\r\n FMultipleDirs: Boolean;\r\n procedure PopupDropDown(DisableEdit: Boolean); override;\r\n procedure ReceptFileDir(const AFileName: string); override;\r\n function GetLongName: string; override;\r\n function GetShortName: string; override;\r\n function GetLocalizedName: string; override;\r\n procedure DoEnter; override;\r\n procedure DoExit; override;\r\n procedure WndProc(var Msg: TMessage); override;\r\n procedure Change; override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n class function DefaultImageIndex: TImageIndex; override;\r\n property Directory: string read GetDirectory write SetDirectory;\r\n published\r\n property Action;\r\n property Align;\r\n property AutoSize;\r\n property DialogKind: TDirDialogKind read FDialogKind write FDialogKind default dkVCL;\r\n property DialogText: string read FDialogText write FDialogText;\r\n property DisplayLocalizedName: Boolean read FDisplayLocalizedName write SetDisplayLocalizedName default False;\r\n property AutoCompleteOptions;\r\n property AutoCompleteFileOptions default [acfFileSystem, acfFileSysDirs];\r\n property BevelEdges;\r\n property BevelInner;\r\n property BevelKind default bkNone;\r\n property BevelOuter;\r\n property Flat;\r\n property ParentFlat;\r\n property DialogOptions: TSelectDirOpts read FOptions write FOptions default [sdAllowCreate];\r\n property DialogOptionsWin32: TOptionsDir read FOptionsWin32 write FOptionsWin32 default DefaultJvBrowseFolderDialogOptions;\r\n property InitialDir: string read FInitialDir write FInitialDir;\r\n property MultipleDirs: Boolean read FMultipleDirs write FMultipleDirs default False;\r\n property AutoSelect;\r\n property ButtonHint;\r\n property ButtonFlat;\r\n property BorderStyle;\r\n property CharCase;\r\n property ClickKey;\r\n property Color;\r\n property DirectInput;\r\n property DragCursor;\r\n property BiDiMode;\r\n property ParentBiDiMode;\r\n property ImeMode;\r\n property ImeName;\r\n property DragKind;\r\n property OnEndDock;\r\n property OnStartDock;\r\n property DragMode;\r\n property EditMask;\r\n property Enabled;\r\n property Font;\r\n property Glyph;\r\n property GroupIndex;\r\n property ImageIndex;\r\n property Images;\r\n property ImageKind;\r\n property NumGlyphs;\r\n property ButtonWidth;\r\n property HideSelection;\r\n property Anchors;\r\n property Constraints;\r\n property ParentColor;\r\n property ParentFont;\r\n property ParentShowHint;\r\n property PopupMenu;\r\n property ReadOnly;\r\n property ShowHint;\r\n property ShowButton;\r\n property TabOrder;\r\n property TabStop;\r\n property Text;\r\n property Visible;\r\n property OnChange;\r\n property OnClick;\r\n property OnDblClick;\r\n property OnDragDrop;\r\n property OnDragOver;\r\n property OnEndDrag;\r\n property OnEnter;\r\n property OnExit;\r\n property OnKeyDown;\r\n property OnKeyPress;\r\n property OnKeyUp;\r\n property OnMouseDown;\r\n property OnMouseEnter;\r\n property OnMouseLeave;\r\n property OnMouseMove;\r\n property OnMouseUp;\r\n property OnStartDrag;\r\n property OnContextPopup;\r\n end;\r\n\r\n TCalendarStyle = (csPopup, csDialog);\r\n TYearDigits = (dyDefault, dyFour, dyTwo);\r\n\r\nconst\r\n {$IFDEF DEFAULT_POPUP_CALENDAR}\r\n dcsDefault = csPopup;\r\n {$ELSE}\r\n dcsDefault = csDialog;\r\n {$ENDIF DEFAULT_POPUP_CALENDAR}\r\n\r\ntype\r\n TExecDateDialog = procedure(Sender: TObject; var ADate: TDateTime;\r\n var Action: Boolean) of object;\r\n TJvInvalidDateEvent = procedure(Sender: TObject; const DateString: string;\r\n var NewDate: TDateTime; var Accept: Boolean) of object;\r\n TPreferredDateFormat = (pdLocale, pdLocaleOnly, pdCustom, pdCustomOnly);\r\n\r\n TJvCustomDateEditDataConnector = class(TJvCustomComboEditDataConnector)\r\n private\r\n FDefaultDate: TDateTime;\r\n FDefaultDateIsNow: Boolean;\r\n procedure SetDefaultDateIsNow(const Value: Boolean);\r\n function IsDefaultDateStored: Boolean;\r\n protected\r\n procedure RecordChanged; override;\r\n procedure UpdateData; override;\r\n public\r\n procedure Assign(Source: TPersistent); override;\r\n published\r\n property DefaultDate: TDateTime read FDefaultDate write FDefaultDate stored IsDefaultDateStored;\r\n property DefaultDateIsNow: Boolean read FDefaultDateIsNow write SetDefaultDateIsNow default False;\r\n end;\r\n\r\n TJvCustomDateEdit = class(TJvCustomComboEdit)\r\n private\r\n FMinDate: TDateTime;\r\n FMaxDate: TDateTime;\r\n FTitle: string;\r\n FOnAcceptDate: TExecDateDialog;\r\n FOnInvalidDate: TJvInvalidDateEvent;\r\n FDefaultToday: Boolean;\r\n FPopupColor: TColor;\r\n FBlanksChar: Char;\r\n FCalendarHints: TStringList;\r\n FStartOfWeek: TDayOfWeekName;\r\n FWeekends: TDaysOfWeek;\r\n FWeekendColor: TColor;\r\n FCustomDateFormat: string;\r\n FYearDigits: TYearDigits;\r\n FDateFormatPreferred: TPreferredDateFormat;\r\n FDateFormat: string;\r\n FDateFormat2: string;\r\n FFormatting: Boolean;\r\n FShowNullDate: Boolean;\r\n procedure SetMinDate(Value: TDateTime);\r\n procedure SetMaxDate(Value: TDateTime);\r\n function GetDate: TDateTime;\r\n procedure SetCustomDateFormat(const Value: string);\r\n procedure SetDateFormatPreferred(Value: TPreferredDateFormat);\r\n function IsDateFormatStored: Boolean;\r\n function IsDateFormatPreferredStored: Boolean;\r\n procedure SetYearDigits(Value: TYearDigits);\r\n function GetPopupColor: TColor;\r\n procedure SetPopupColor(Value: TColor);\r\n function GetDialogTitle: string;\r\n procedure SetDialogTitle(const Value: string);\r\n function IsCustomTitle: Boolean;\r\n function IsDateStored: Boolean;\r\n function GetCalendarStyle: TCalendarStyle;\r\n procedure SetCalendarStyle(Value: TCalendarStyle);\r\n function GetCalendarHints: TStrings;\r\n procedure SetCalendarHints(Value: TStrings);\r\n procedure CalendarHintsChanged(Sender: TObject);\r\n procedure SetWeekendColor(Value: TColor);\r\n procedure SetWeekends(Value: TDaysOfWeek);\r\n procedure SetStartOfWeek(Value: TDayOfWeekName);\r\n procedure SetBlanksChar(Value: Char);\r\n function TextStored: Boolean;\r\n function StoreMinDate: Boolean;\r\n function StoreMaxDate: Boolean;\r\n function FourDigitYear: Boolean;\r\n procedure WMContextMenu(var Msg: TWMContextMenu); message WM_CONTEXTMENU;\r\n procedure SetShowNullDate(const Value: Boolean);\r\n protected\r\n FDateAutoBetween: Boolean;\r\n procedure SetDate(Value: TDateTime); virtual;\r\n function DoInvalidDate(const DateString: string; var ANewDate: TDateTime): Boolean; virtual;\r\n procedure SetDateAutoBetween(Value: Boolean); virtual;\r\n procedure TestDateBetween(var Value: TDateTime); virtual;\r\n procedure DoExit; override;\r\n procedure Change; override;\r\n procedure KeyDown(var Key: Word; Shift: TShiftState); override;\r\n procedure KeyPress(var Key: Char); override;\r\n procedure CreateWindowHandle(const Params: TCreateParams); override;\r\n function AcceptPopup(var Value: Variant): Boolean; override;\r\n procedure AcceptValue(const Value: Variant); override;\r\n procedure SetPopupValue(const Value: Variant); override;\r\n function GetDateFormat: string;\r\n procedure ApplyDate(Value: TDateTime); virtual;\r\n procedure UpdateFormat;\r\n procedure UpdatePopup;\r\n procedure PopupDropDown(DisableEdit: Boolean); override;\r\n procedure SetParent(AParent: TWinControl); override;\r\n function GetDefaultDateFormat: string; virtual;\r\n function GetDefaultDateFormatPreferred: TPreferredDateFormat; virtual;\r\n function CreateDataConnector: TJvCustomComboEditDataConnector; override;\r\n function DisplayNullDateAsEmptyText: Boolean; virtual;\r\n\r\n property BlanksChar: Char read FBlanksChar write SetBlanksChar default ' ';\r\n property CalendarHints: TStrings read GetCalendarHints write SetCalendarHints;\r\n property CheckOnExit default False;\r\n property DefaultToday: Boolean read FDefaultToday write FDefaultToday default False;\r\n property DialogTitle: string read GetDialogTitle write SetDialogTitle stored IsCustomTitle;\r\n property EditMask stored False;\r\n property Formatting: Boolean read FFormatting;\r\n property ImageKind default ikDefault;\r\n property PopupColor: TColor read GetPopupColor write SetPopupColor default clMenu;\r\n property CalendarStyle: TCalendarStyle read GetCalendarStyle\r\n write SetCalendarStyle default dcsDefault;\r\n property StartOfWeek: TDayOfWeekName read FStartOfWeek write SetStartOfWeek default Mon;\r\n property Weekends: TDaysOfWeek read FWeekends write SetWeekends default [Sun];\r\n property WeekendColor: TColor read FWeekendColor write SetWeekendColor default clRed;\r\n property DateFormat: string read FCustomDateFormat write SetCustomDateFormat stored IsDateFormatStored;\r\n property DateFormatPreferred: TPreferredDateFormat read FDateFormatPreferred\r\n write SetDateFormatPreferred stored IsDateFormatPreferredStored;\r\n property YearDigits: TYearDigits read FYearDigits write SetYearDigits default dyDefault;\r\n property OnAcceptDate: TExecDateDialog read FOnAcceptDate write FOnAcceptDate;\r\n property OnInvalidDate: TJvInvalidDateEvent read FOnInvalidDate write FOnInvalidDate;\r\n property MaxLength stored False;\r\n { Text is already stored via Date property }\r\n property Text stored False;\r\n property ShowNullDate: Boolean read FShowNullDate write SetShowNullDate;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n class function DefaultImageIndex: TImageIndex; override;\r\n\r\n procedure ValidateEdit; override;\r\n procedure CheckValidDate; virtual;\r\n function GetDateMask: string;\r\n procedure UpdateMask; virtual;\r\n\r\n property Date: TDateTime read GetDate write SetDate stored IsDateStored;\r\n property PopupVisible;\r\n property DateAutoBetween: Boolean read FDateAutoBetween write SetDateAutoBetween default True;\r\n property MinDate: TDateTime read FMinDate write SetMinDate stored StoreMinDate;\r\n property MaxDate: TDateTime read FMaxDate write SetMaxDate stored StoreMaxDate;\r\n end;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvDateEdit = class(TJvCustomDateEdit)\r\n protected\r\n procedure SetDate(Value: TDateTime); override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n property EditMask;\r\n published\r\n property Date;\r\n property DateFormat;\r\n property DateFormatPreferred;\r\n property DateAutoBetween;\r\n property MinDate;\r\n property MaxDate;\r\n property Align; \r\n property Action;\r\n property AutoSelect;\r\n property AutoSize;\r\n property BlanksChar;\r\n property BorderStyle;\r\n property ButtonHint;\r\n property ButtonFlat;\r\n property CalendarHints;\r\n property CheckOnExit;\r\n property ClickKey;\r\n property Color;\r\n property DefaultToday;\r\n property DialogTitle;\r\n property DirectInput;\r\n property DragCursor;\r\n property BevelEdges;\r\n property BevelInner;\r\n property BevelKind default bkNone;\r\n property BevelOuter;\r\n property BiDiMode;\r\n property DragKind;\r\n property Flat;\r\n property ParentBiDiMode;\r\n property ParentFlat;\r\n property ImeMode;\r\n property ImeName;\r\n property OnEndDock;\r\n property OnStartDock;\r\n property DragMode;\r\n property Enabled;\r\n property Font;\r\n property Glyph;\r\n property GroupIndex;\r\n property ImageIndex;\r\n property Images;\r\n property ImageKind;\r\n property NumGlyphs;\r\n property ButtonWidth;\r\n property HideSelection;\r\n property Anchors;\r\n property Constraints;\r\n property MaxLength;\r\n property ParentColor;\r\n property ParentFont;\r\n property ParentShowHint;\r\n property PopupAlign;\r\n property PopupColor;\r\n property PopupMenu;\r\n property ReadOnly;\r\n property ShowHint;\r\n property ShowButton;\r\n property CalendarStyle;\r\n property ShowNullDate;\r\n property StartOfWeek;\r\n property Weekends;\r\n property WeekendColor;\r\n property YearDigits;\r\n property TabOrder;\r\n property TabStop;\r\n property Text;\r\n property Visible;\r\n property OnAcceptDate;\r\n property OnInvalidDate;\r\n property OnButtonClick;\r\n property OnChange;\r\n property OnClick;\r\n property OnDblClick;\r\n property OnDragDrop;\r\n property OnDragOver;\r\n property OnEndDrag;\r\n property OnEnter;\r\n property OnExit;\r\n property OnKeyPress;\r\n property OnKeyUp;\r\n property OnMouseDown;\r\n property OnMouseEnter;\r\n property OnMouseLeave;\r\n property OnMouseMove;\r\n property OnMouseUp;\r\n property OnStartDrag;\r\n property OnContextPopup;\r\n property ClipboardCommands;\r\n property DisabledTextColor;\r\n property DisabledColor;\r\n property OnKeyDown;\r\n property OnPopupHidden;\r\n property OnPopupShown;\r\n\r\n property DataConnector;\r\n end;\r\n\r\n EComboEditError = class(EJVCLException);\r\n\r\n{ Utility routines }\r\n\r\nprocedure DateFormatChanged;\r\n\r\nfunction EditorTextMargins(Editor: TCustomEdit): TPoint;\r\n\r\nfunction PaintComboEdit(Editor: TJvCustomComboEdit; const AText: string;\r\n AAlignment: TAlignment; StandardPaint: Boolean;\r\n var ACanvas: TControlCanvas; var Msg: TWMPaint): Boolean;\r\nfunction PaintEdit(Editor: TCustomEdit; const AText: string;\r\n AAlignment: TAlignment; PopupVisible: Boolean;\r\n DisabledTextColor: TColor; StandardPaint: Boolean;\r\n var ACanvas: TControlCanvas; var Msg: TWMPaint): Boolean;\r\n\r\nfunction LoadDefaultBitmap(Bmp: TBitmap; Item: Integer): Boolean;\r\n\r\nfunction IsInWordArray(Value: Word; const A: array of Word): Boolean;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvToolEdit.pas $';\r\n Revision: '$Revision: 13415 $';\r\n Date: '$Date: 2012-09-10 11:51:54 +0200 (lun. 10 sept. 2012) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n RTLConsts, Math, MaskUtils,\r\n MultiMon,\r\n {$IFDEF COMPILER16_UP}\r\n Vcl.Themes,\r\n {$ENDIF COMPILER16_UP}\r\n JclFileUtils, JclStrings,\r\n JvPickDate, JvJCLUtils, JvJVCLUtils,\r\n JvThemes, JvResources, JclSysUtils;\r\n\r\n{$R JvToolEdit.res}\r\n\r\ntype\r\n {$HINTS OFF}\r\n TCustomMaskEditAccessPrivate = class(TCustomEdit)\r\n private\r\n // Do not remove these fields, although they are not used.\r\n FEditMask: TEditMask;\r\n FMaskBlank: Char;\r\n FMaxChars: Integer;\r\n FMaskSave: Boolean;\r\n FMaskState: TMaskedState;\r\n FCaretPos: Integer;\r\n FBtnDownX: Integer;\r\n FOldValue: string;\r\n FSettingCursor: Boolean;\r\n end;\r\n {$HINTS ON}\r\n\r\n TCustomEditAccessProtected = class(TCustomEdit);\r\n TCustomFormAccessProtected = class(TCustomForm);\r\n TWinControlAccessProtected = class(TWinControl);\r\n\r\nconst\r\n sDirBmp = 'JvDirectoryEditGLYPH'; { Directory editor button glyph }\r\n sFileBmp = 'JvFilenameEditGLYPH'; { Filename editor button glyph }\r\n sDateBmp = 'JvCustomDateEditGLYPH'; { Date editor button glyph }\r\n\r\n {$IFDEF JVCLThemesEnabled}\r\n // (rb) should/can these be put in a separate resource file?\r\n sDirXPBmp = 'JvDirectoryEditXPGLYPH';\r\n sFileXPBmp = 'JvFilenameEditXPGLYPH';\r\n {$ENDIF JVCLThemesEnabled}\r\n\r\nconst\r\n ACLO_NONE = 0; // don't enumerate anything\r\n ACLO_CURRENTDIR = 1; // enumerate current directory\r\n ACLO_MYCOMPUTER = 2; // enumerate MyComputer\r\n ACLO_DESKTOP = 4; // enumerate Desktop Folder\r\n ACLO_FAVORITES = 8; // enumerate Favorites Folder\r\n ACLO_FILESYSONLY = 16; // enumerate only the file system\r\n ACLO_FILESYSDIRS = 32; // enumerate only the file system dirs, UNC shares, and UNC servers.\r\n\r\n //IID_IAutoCompList: TGUID = (D1:$00BB2760; D2:$6A77; D3:$11D0; D4:($A5, $35, $00, $C0, $4F, $D7, $D0, $62));\r\n //IID_IObjMgr: TGUID = (D1:$00BB2761; D2:$6A77; D3:$11D0; D4:($A5, $35, $00, $C0, $4F, $D7, $D0, $62));\r\n //IID_IACList: TGUID = (D1:$77A130B0; D2:$94FD; D3:$11D0; D4:($A5, $44, $00, $C0, $4F, $D7, $d0, $62));\r\n //IID_IACList2: TGUID = (D1:$470141a0; D2:$5186; D3:$11d2; D4:($bb, $b6, $00, $60, $97, $7b, $46, $4c));\r\n //IID_ICurrentWorkingDirectory: TGUID = (D1:$91956d21; D2:$9276; D3:$11d1; D4:($92, $1a, $00, $60, $97, $df, $5b, $d4));\r\n\r\n CLSID_AutoComplete: TGUID = (D1:$00BB2763; D2:$6A77; D3:$11D0; D4:($A5, $35, $00, $C0, $4F, $D7, $D0, $62));\r\n CLSID_ACLHistory: TGUID = (D1:$00BB2764; D2:$6A77; D3:$11D0; D4:($A5, $35, $00, $C0, $4F, $D7, $D0, $62));\r\n CLSID_ACListISF: TGUID = (D1:$03C036F1; D2:$A186; D3:$11D0; D4:($82, $4A, $00, $AA, $00, $5B, $43, $83));\r\n CLSID_ACLMRU: TGUID = (D1:$6756a641; D2:$de71; D3:$11d0; D4:($83, $1b, $0, $aa, $0, $5b, $43, $83));\r\n CLSID_ACLMulti: TGUID = (D1:$00BB2765; D2:$6A77; D3:$11D0; D4:($A5, $35, $00, $C0, $4F, $D7, $D0, $62));\r\n\r\n //#if (_WIN32_IE >= 0x0600)\r\n //CLSID_ACLCustomMRU: TGUID = (D1:$6935db93; D2:$21e8; D3:$4ccc; D4:($be, $b9, $9f, $e3, $c7, $7a, $29, $7a));\r\n //#endif\r\n\r\ntype\r\n TAutoCompleteSource = class(TInterfacedObject, IEnumString)\r\n private\r\n FComboEdit: TJvCustomComboEdit;\r\n FCurrentIndex: Integer;\r\n protected\r\n { IEnumString }\r\n function Next(celt: Longint; out elt; pceltFetched: PLongint): HRESULT; stdcall;\r\n function Skip(celt: Longint): HRESULT; stdcall;\r\n function Reset: HRESULT; stdcall;\r\n function Clone(out enm: IEnumString): HRESULT; stdcall;\r\n public\r\n constructor Create(AComboEdit: TJvCustomComboEdit; const StartIndex: Integer); virtual;\r\n end;\r\n\r\n IACList = interface(IUnknown)\r\n ['{77A130B0-94FD-11D0-A544-00C04FD7d062}']\r\n function Expand(pszExpand: string): HRESULT; stdcall;\r\n end;\r\n\r\n IACList2 = interface(IACList)\r\n ['{470141a0-5186-11d2-bbb6-0060977b464c}']\r\n function SetOptions(dwFlag: DWORD): HRESULT; stdcall;\r\n function GetOptions(var pdwFlag: DWORD): HRESULT; stdcall;\r\n end;\r\n\r\n IObjMgr = interface(IUnknown)\r\n ['{00BB2761-6A77-11D0-a535-00c04fd7d062}']\r\n function Append(punk: IUnknown): HRESULT; stdcall;\r\n function Remove(punk: IUnknown): HRESULT; stdcall;\r\n end;\r\n\r\ntype\r\n { TDateHook is used to only have 1 hook per application for monitoring\r\n date changes;\r\n\r\n We can't use WM_WININICHANGE or CM_WININICHANGE in the controls\r\n itself, because it comes too early. (The Application object does the\r\n changing on receiving WM_WININICHANGE; The Application object receives it\r\n later than the forms, controls etc.\r\n }\r\n\r\n TDateHook = class(TObject)\r\n private\r\n FCount: Integer;\r\n FHooked: Boolean;\r\n FWinIniChangeReceived: Boolean;\r\n protected\r\n function FormatSettingsChange(var Msg: TMessage): Boolean;\r\n procedure Hook;\r\n procedure UnHook;\r\n public\r\n procedure Add;\r\n procedure Delete;\r\n end;\r\n\r\nvar\r\n GDateHook: TDateHook = nil;\r\n GDateImageIndex: TImageIndex = -1;\r\n GDefaultComboEditImagesList: TImageList = nil;\r\n GDirImageIndex: TImageIndex = -1;\r\n GFileImageIndex: TImageIndex = -1;\r\n {$IFDEF JVCLThemesEnabled}\r\n GDirImageIndexXP: TImageIndex = -1;\r\n GFileImageIndexXP: TImageIndex = -1;\r\n {$ENDIF JVCLThemesEnabled}\r\n GCoInitialized: Integer = 0;\r\n\r\n//=== Local procedures =======================================================\r\n\r\nfunction DateHook: TDateHook;\r\nbegin\r\n if GDateHook = nil then\r\n GDateHook := TDateHook.Create;\r\n Result := GDateHook;\r\nend;\r\n\r\nfunction ClipFilename(const FileName: string; const Clip: Boolean): string;\r\nvar\r\n Params: string;\r\nbegin\r\n if FileExists(FileName) then\r\n Result := FileName\r\n else\r\n if DirectoryExists(FileName) then\r\n Result := IncludeTrailingPathDelimiter(FileName)\r\n else\r\n if Clip then\r\n SplitCommandLine(FileName, Result, Params)\r\n else\r\n Result := FileName;\r\nend;\r\n\r\nfunction ExtFilename(const FileName: string): string;\r\nbegin\r\n if (Pos(' ', FileName) > 0) and (FileName[1] <> '\"') then\r\n Result := Format('\"%s\"', [FileName])\r\n else\r\n Result := FileName;\r\nend;\r\n\r\nfunction NvlDate(DateValue, DefaultValue: TDateTime): TDateTime;\r\nbegin\r\n if DateValue = NullDate then\r\n Result := DefaultValue\r\n else\r\n Result := DateValue;\r\nend;\r\n\r\nfunction ParentFormVisible(AControl: TControl): Boolean;\r\nvar\r\n Form: TCustomForm;\r\nbegin\r\n Form := GetParentForm(AControl);\r\n Result := Assigned(Form) and Form.Visible;\r\nend;\r\n\r\n//=== Global procedures ======================================================\r\n\r\nprocedure DateFormatChanged;\r\n\r\n procedure IterateControls(AControl: TWinControl);\r\n var\r\n I: Integer;\r\n begin\r\n with AControl do\r\n for I := 0 to ControlCount - 1 do\r\n begin\r\n if Controls[I] is TJvCustomDateEdit then\r\n TJvCustomDateEdit(Controls[I]).UpdateMask\r\n else\r\n if Controls[I] is TWinControl then\r\n IterateControls(TWinControl(Controls[I]));\r\n end;\r\n end;\r\n\r\nvar\r\n I: Integer;\r\nbegin\r\n if Screen <> nil then\r\n for I := 0 to Screen.FormCount - 1 do\r\n IterateControls(Screen.Forms[I]);\r\nend;\r\n\r\nfunction EditorTextMargins(Editor: TCustomEdit): TPoint;\r\nvar\r\n I: Integer;\r\n ed: TCustomEditAccessProtected;\r\nbegin\r\n ed := TCustomEditAccessProtected(Editor);\r\n if ed.BorderStyle = bsNone then\r\n I := 0\r\n else\r\n if ed.Ctl3D then\r\n I := 1\r\n else\r\n I := 2;\r\n if GetWindowLong(ed.Handle, GWL_STYLE) and ES_MULTILINE = 0 then\r\n Result.X := (SendMessage(ed.Handle, EM_GETMARGINS, 0, 0) and $0000FFFF) + I\r\n else\r\n Result.X := I;\r\n Result.Y := I;\r\nend;\r\n\r\nfunction IsInWordArray(Value: Word; const A: array of Word): Boolean;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := True;\r\n for I := 0 to High(A) do\r\n if A[I] = Value then\r\n Exit;\r\n Result := False;\r\nend;\r\n\r\nfunction LoadDefaultBitmap(Bmp: TBitmap; Item: Integer): Boolean;\r\nbegin\r\n Bmp.Handle := LoadBitmap(0, PChar(Item));\r\n Result := Bmp.Handle <> 0;\r\nend;\r\n\r\nfunction PaintComboEdit(Editor: TJvCustomComboEdit; const AText: string;\r\n AAlignment: TAlignment; StandardPaint: Boolean;\r\n var ACanvas: TControlCanvas; var Msg: TWMPaint): Boolean;\r\nbegin\r\n if not (csDestroying in Editor.ComponentState) then\r\n begin\r\n Result := PaintEdit(Editor, AText, AAlignment, Editor.PopupVisible,\r\n Editor.FDisabledTextColor, StandardPaint, ACanvas, Msg);\r\n end\r\n else\r\n Result := True;\r\nend;\r\n\r\nfunction PaintEdit(Editor: TCustomEdit; const AText: string;\r\n AAlignment: TAlignment; PopupVisible: Boolean;\r\n DisabledTextColor: TColor; StandardPaint: Boolean;\r\n var ACanvas: TControlCanvas; var Msg: TWMPaint): Boolean;\r\ntype\r\n TEd = TCustomEditAccessProtected;\r\nconst\r\n AlignStyle: array [Boolean, TAlignment] of DWORD =\r\n ((WS_EX_LEFT, WS_EX_RIGHT, WS_EX_LEFT),\r\n (WS_EX_RIGHT, WS_EX_LEFT, WS_EX_LEFT));\r\n {$IFDEF COMPILER16_UP}\r\n ColorStates: array[Boolean] of TStyleColor = (scEditDisabled, scEdit);\r\n FontColorStates: array[Boolean] of TStyleFont = (sfEditBoxTextDisabled, sfEditBoxTextNormal);\r\n {$ENDIF COMPILER16_UP}\r\nvar\r\n LTextWidth, X: Integer;\r\n EditRect: TRect;\r\n DC: HDC;\r\n PS: TPaintStruct;\r\n S: string;\r\n ExStyle: DWORD;\r\nbegin\r\n Result := True;\r\n if csDestroying in Editor.ComponentState then\r\n Exit;\r\n if TEd(Editor).UseRightToLeftAlignment then\r\n ChangeBiDiModeAlignment(AAlignment);\r\n if StandardPaint and not (csPaintCopy in TEd(Editor).ControlState) then\r\n begin\r\n if SysLocale.MiddleEast and TEd(Editor).HandleAllocated and TEd(Editor).IsRightToLeft then\r\n begin { This keeps the right aligned text, right aligned }\r\n ExStyle := DWORD(GetWindowLong(TEd(Editor).Handle, GWL_EXSTYLE)) and not (WS_EX_RIGHT or WS_EX_RTLREADING or WS_EX_LEFTSCROLLBAR);\r\n if TEd(Editor).UseRightToLeftReading then\r\n ExStyle := ExStyle or WS_EX_RTLREADING;\r\n if TEd(Editor).UseRightToLeftScrollBar then\r\n ExStyle := ExStyle or WS_EX_LEFTSCROLLBAR;\r\n ExStyle := ExStyle or AlignStyle[TEd(Editor).UseRightToLeftAlignment, AAlignment];\r\n if DWORD(GetWindowLong(TEd(Editor).Handle, GWL_EXSTYLE)) <> ExStyle then\r\n SetWindowLong(TEd(Editor).Handle, GWL_EXSTYLE, ExStyle);\r\n end;\r\n Result := False;\r\n { return false if we need to use standard paint handler }\r\n Exit;\r\n end;\r\n { Since edit controls do not handle justification unless multi-line (and\r\n then only poorly) we will draw right and center justify manually unless\r\n the edit has the focus. }\r\n if ACanvas = nil then\r\n begin\r\n ACanvas := TControlCanvas.Create;\r\n ACanvas.Control := Editor;\r\n end;\r\n DC := Msg.DC;\r\n if DC = 0 then\r\n DC := BeginPaint(TEd(Editor).Handle, PS);\r\n ACanvas.Handle := DC;\r\n try\r\n ACanvas.Font := TEd(Editor).Font;\r\n with ACanvas do\r\n begin\r\n SendRectMessage(Editor.Handle, EM_GETRECT, 0, EditRect);\r\n if not TEd(Editor).Ctl3D and (TEd(Editor).BorderStyle = bsSingle) then\r\n begin\r\n Brush.Color := clWindowFrame;\r\n FrameRect(TEd(Editor).ClientRect);\r\n end;\r\n S := AText;\r\n LTextWidth := TextWidth(S);\r\n if PopupVisible then\r\n X := EditRect.Left\r\n else\r\n begin\r\n case AAlignment of\r\n taLeftJustify:\r\n X := EditRect.Left;\r\n taRightJustify:\r\n X := EditRect.Right - LTextWidth;\r\n else\r\n X := (EditRect.Right + EditRect.Left - LTextWidth) div 2;\r\n end;\r\n end;\r\n if SysLocale.MiddleEast then\r\n UpdateTextFlags;\r\n if not TEd(Editor).Enabled then\r\n begin\r\n // if PS.fErase then // (p3) fErase is not set to true when control is disabled\r\n TEd(Editor).Perform(WM_ERASEBKGND, ACanvas.Handle, 0);\r\n\r\n SaveDC(ACanvas.Handle);\r\n try\r\n ACanvas.Brush.Style := bsClear;\r\n {$IFDEF COMPILER16_UP}\r\n if StyleServices.Enabled and not StyleServices.IsSystemStyle then\r\n begin\r\n ACanvas.Brush.Color := StyleServices.GetStyleColor(ColorStates[Editor.Enabled]);\r\n ACanvas.Font.Color := StyleServices.GetStyleFontColor(FontColorStates[Editor.Enabled]);\r\n end\r\n else\r\n {$ENDIF COMPILER16_UP}\r\n ACanvas.Font.Color := DisabledTextColor;\r\n ACanvas.TextRect(EditRect, X, EditRect.Top, S);\r\n finally\r\n RestoreDC(ACanvas.Handle, -1);\r\n end;\r\n end\r\n else\r\n begin\r\n {$IFDEF COMPILER16_UP}\r\n if StyleServices.Enabled and not StyleServices.IsSystemStyle then\r\n begin\r\n ACanvas.Brush.Color := StyleServices.GetStyleColor(ColorStates[Editor.Enabled]);\r\n ACanvas.Font.Color := StyleServices.GetStyleFontColor(FontColorStates[Editor.Enabled]);\r\n end\r\n else\r\n {$ENDIF COMPILER16_UP}\r\n Brush.Color := TEd(Editor).Color;\r\n ACanvas.TextRect(EditRect, X, EditRect.Top, S);\r\n end;\r\n end;\r\n finally\r\n ACanvas.Handle := 0;\r\n if Msg.DC = 0 then\r\n EndPaint(TEd(Editor).Handle, PS);\r\n end;\r\nend;\r\n\r\n//=== { TAutoCompleteSource } ================================================\r\n\r\nconstructor TAutoCompleteSource.Create(AComboEdit: TJvCustomComboEdit; const StartIndex: Integer);\r\nbegin\r\n inherited Create;\r\n FComboEdit := AComboEdit;\r\n FCurrentIndex := StartIndex;\r\nend;\r\n\r\nfunction TAutoCompleteSource.Clone(out enm: IEnumString): HRESULT;\r\nbegin\r\n { Save state }\r\n try\r\n enm := TAutoCompleteSource.Create(FComboEdit, FCurrentIndex);\r\n Result := S_OK;\r\n except\r\n Result := E_UNEXPECTED;\r\n end;\r\nend;\r\n\r\nfunction TAutoCompleteSource.Next(celt: Integer; out elt;\r\n pceltFetched: PLongint): HRESULT;\r\nvar\r\n Fetched: Integer;\r\n S: string;\r\n Ptr: POleStr;\r\n Size: Integer;\r\nbegin\r\n if Pointer(elt) = nil then\r\n begin\r\n Result := E_FAIL;\r\n Exit;\r\n end;\r\n\r\n Fetched := 0;\r\n\r\n while (Fetched < celt) and (FCurrentIndex < FComboEdit.AutoCompleteItems.Count) do\r\n begin\r\n S := FComboEdit.AutoCompleteItems[FCurrentIndex];\r\n Size := (Length(S) + 1) * SizeOf(WideChar);\r\n Ptr := CoTaskMemAlloc(Size);\r\n if Ptr = nil then\r\n begin\r\n Result := E_OUTOFMEMORY;\r\n Exit;\r\n end;\r\n StringToWideChar(S, Ptr, Size);\r\n\r\n TOleStrList(elt)[Fetched] := Ptr;\r\n\r\n Inc(FCurrentIndex);\r\n Inc(Fetched);\r\n end;\r\n\r\n if Assigned(pceltFetched) then\r\n pceltFetched^ := Fetched;\r\n\r\n if Fetched = celt then\r\n Result := S_OK\r\n else\r\n Result := S_FALSE;\r\nend;\r\n\r\nfunction TAutoCompleteSource.Reset: HRESULT;\r\nbegin\r\n FCurrentIndex := 0;\r\n Result := S_OK;\r\nend;\r\n\r\nfunction TAutoCompleteSource.Skip(celt: Integer): HRESULT;\r\nbegin\r\n Inc(FCurrentIndex, celt);\r\n if FCurrentIndex < FComboEdit.AutoCompleteItems.Count then\r\n Result := S_OK\r\n else\r\n begin\r\n Result := S_FALSE;\r\n FCurrentIndex := FComboEdit.AutoCompleteItems.Count;\r\n end;\r\nend;\r\n\r\n//=== { TDateHook } ==========================================================\r\n\r\nprocedure TDateHook.Add;\r\nbegin\r\n if FCount = 0 then\r\n Hook;\r\n Inc(FCount);\r\nend;\r\n\r\nprocedure TDateHook.Delete;\r\nbegin\r\n if FCount > 0 then\r\n Dec(FCount);\r\n if FCount = 0 then\r\n UnHook;\r\nend;\r\n\r\nfunction TDateHook.FormatSettingsChange(var Msg: TMessage): Boolean;\r\nbegin\r\n Result := False;\r\n if (Msg.Msg = WM_WININICHANGE) and Application.UpdateFormatSettings then\r\n begin\r\n // Let the application obj do the changing; we receive the message\r\n // before the application obj, thus jump over it:\r\n PostMessage(Application.Handle, WM_NULL, 0, 0);\r\n FWinIniChangeReceived := True;\r\n end\r\n else\r\n if (Msg.Msg = WM_NULL) and FWinIniChangeReceived then\r\n begin\r\n FWinIniChangeReceived := False;\r\n DateFormatChanged;\r\n end;\r\nend;\r\n\r\nprocedure TDateHook.Hook;\r\nbegin\r\n if not FHooked then\r\n begin\r\n Application.HookMainWindow(FormatSettingsChange);\r\n FHooked := True;\r\n end;\r\nend;\r\n\r\nprocedure TDateHook.UnHook;\r\nbegin\r\n if FHooked then\r\n begin\r\n Application.UnhookMainWindow(FormatSettingsChange);\r\n FHooked := False;\r\n end;\r\nend;\r\n\r\n//=== { TJvCustomComboEditDataConnector } ====================================\r\n\r\nconstructor TJvCustomComboEditDataConnector.Create(AEdit: TJvCustomComboEdit);\r\nbegin\r\n inherited Create;\r\n FEdit := AEdit;\r\nend;\r\n\r\nprocedure TJvCustomComboEditDataConnector.RecordChanged;\r\nbegin\r\n if Field.IsValid then\r\n begin\r\n FEdit.ReadOnly := not Field.CanModify;\r\n FEdit.Text := Field.AsString;\r\n end\r\n else\r\n begin\r\n FEdit.Text := '';\r\n FEdit.ReadOnly := True;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomComboEditDataConnector.UpdateData;\r\nbegin\r\n Field.AsString := FEdit.Text;\r\n FEdit.Text := Field.AsString; // update to stored value\r\nend;\r\n\r\n//=== { TJvCustomComboEdit } =================================================\r\n\r\nconstructor TJvCustomComboEdit.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FDataConnector := CreateDataConnector;\r\n ControlStyle := ControlStyle + [csCaptureMouse];\r\n Height := 21;\r\n FDirectInput := True;\r\n FClickKey := scAltDown;\r\n FPopupAlign := epaRight;\r\n FBtnControl := TWinControl.Create(Self);\r\n with FBtnControl do\r\n ControlStyle := ControlStyle + [csReplicatable];\r\n FBtnControl.Width := DefEditBtnWidth;\r\n FBtnControl.Height := 17;\r\n FBtnControl.Visible := True;\r\n FBtnControl.Parent := Self;\r\n FBtnControl.Align := alCustom;\r\n FButton := TJvEditButton.Create(Self);\r\n FButton.SetBounds(0, 0, FBtnControl.Width, FBtnControl.Height);\r\n FButton.Visible := True;\r\n FButton.Align := alClient;\r\n FButton.OnClick := EditButtonClick;\r\n FButton.Parent := FBtnControl;\r\n\r\n FAlwaysEnableButton := False;\r\n FDisabledColor := clWindow;\r\n FDisabledTextColor := clGrayText;\r\n FGroupIndex := -1;\r\n FStreamedButtonWidth := -1;\r\n FImageKind := ikCustom;\r\n FImageIndex := -1;\r\n FNumGlyphs := 1;\r\n FAutoCompleteItems := TStringList.Create;\r\n FAutoCompleteOptions := [];\r\n FCheckOnExit := True;\r\n\r\n // Move to class contructor when Delphi 2010 is the minimum version\r\n if GCoInitialized >= 0 then\r\n begin\r\n Inc(GCoInitialized);\r\n if GCoInitialized = 1 then\r\n if not Succeeded(CoInitialize(nil)) then\r\n GCoInitialized := -1;\r\n end;\r\n inherited OnKeyDown := LocalKeyDown;\r\nend;\r\n\r\ndestructor TJvCustomComboEdit.Destroy;\r\nbegin\r\n PopupCloseUp(Self, False);\r\n FButton.OnClick := nil;\r\n DestroyAutoComplete;\r\n FAutoCompleteItems.Free;\r\n FDataConnector.Free;\r\n inherited Destroy;\r\n\r\n // call after WM_DESTROY\r\n\r\n // Move to class destructor when Delphi 2010 is the minimum version\r\n if GCoInitialized > 0 then\r\n begin\r\n Dec(GCoInitialized);\r\n if GCoInitialized = 0 then\r\n CoUninitialize;\r\n end;\r\nend;\r\n\r\nfunction TJvCustomComboEdit.AcceptPopup(var Value: Variant): Boolean;\r\nbegin\r\n Result := True;\r\nend;\r\n\r\nprocedure TJvCustomComboEdit.AcceptValue(const Value: Variant);\r\nbegin\r\n if Text <> VarToStr(Value) then\r\n begin\r\n Text := Value;\r\n Modified := True;\r\n UpdatePopupVisible;\r\n //DoChange; (ahuser) \"Text := Value\" triggers Change;\r\n end;\r\n if Assigned(FOnPopupValueAccepted) then\r\n FOnPopupValueAccepted(Self);\r\nend;\r\n\r\nprocedure TJvCustomComboEdit.ActionChange(Sender: TObject;\r\n CheckDefaults: Boolean);\r\nbegin\r\n if Sender is TCustomAction then\r\n with TCustomAction(Sender) do\r\n begin\r\n if not CheckDefaults or not Assigned(Self.Images) then\r\n Self.Images := TCustomImageList(ActionList.Images);\r\n if not CheckDefaults or Self.Enabled then\r\n Self.Enabled := Enabled;\r\n if not CheckDefaults or (Self.HelpContext = 0) then\r\n Self.HelpContext := HelpContext;\r\n if not CheckDefaults or (Self.Hint = '') then\r\n Self.ButtonHint := Hint;\r\n if not CheckDefaults or (Self.ImageIndex = -1) then\r\n Self.ImageIndex := ImageIndex;\r\n if not CheckDefaults or (Self.ClickKey = scNone) then\r\n Self.ClickKey := ShortCut;\r\n if not CheckDefaults or Self.Visible then\r\n Self.Visible := Visible;\r\n if not CheckDefaults or not Assigned(Self.OnButtonClick) then\r\n Self.OnButtonClick := OnExecute;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomComboEdit.AdjustHeight;\r\nvar\r\n DC: HDC;\r\n SaveFont: HFONT;\r\n I: Integer;\r\n SysMetrics, Metrics: TTextMetric;\r\nbegin\r\n // Get text height\r\n DC := GetDC(HWND_DESKTOP);\r\n GetTextMetrics(DC, SysMetrics);\r\n SaveFont := SelectObject(DC, Font.Handle);\r\n GetTextMetrics(DC, Metrics);\r\n SelectObject(DC, SaveFont);\r\n ReleaseDC(HWND_DESKTOP, DC);\r\n\r\n // If necessary reserve space for border\r\n I := 0;\r\n if BorderStyle <> bsNone then\r\n begin\r\n if not Flat then\r\n I := 8\r\n else\r\n I := 6;\r\n I := GetSystemMetrics(SM_CYBORDER) * I;\r\n end;\r\n\r\n if Height < Metrics.tmHeight + I then\r\n Height := Metrics.tmHeight + I;\r\nend;\r\n\r\nprocedure TJvCustomComboEdit.AdjustSize;\r\nvar\r\n MinHeight: Integer;\r\nbegin\r\n inherited AdjustSize;\r\n if not (csLoading in ComponentState) then\r\n begin\r\n MinHeight := GetMinHeight;\r\n { text edit bug: if size to less than MinHeight, then edit ctrl does\r\n not display the text }\r\n if Height < MinHeight then\r\n begin\r\n Height := MinHeight;\r\n Exit;\r\n end;\r\n end\r\n else\r\n begin\r\n if (FPopup <> nil) and (csDesigning in ComponentState) then\r\n FPopup.SetBounds(0, Height + 1, 10, 10);\r\n end;\r\n UpdateControls;\r\n UpdateMargins;\r\nend;\r\n\r\nprocedure TJvCustomComboEdit.AsyncPopupCloseUp(Accept: Boolean);\r\nbegin\r\n PostMessage(Handle, CM_POPUPCLOSEUP, Ord(Accept), 0);\r\nend;\r\n\r\nfunction TJvCustomComboEdit.BtnWidthStored: Boolean;\r\nbegin\r\n if (FImageKind = ikDefault) and (DefaultImages <> nil) and (DefaultImageIndex >= 0) then\r\n Result := ButtonWidth <> Max(DefaultImages.Width + 6, DefEditBtnWidth)\r\n else\r\n if FImageKind = ikDropDown then\r\n Result := ButtonWidth <> GetSystemMetrics(SM_CXVSCROLL)\r\n else\r\n Result := ButtonWidth <> DefEditBtnWidth;\r\nend;\r\n\r\nprocedure TJvCustomComboEdit.ButtonClick;\r\nbegin\r\n if Assigned(FOnButtonClick) then\r\n FOnButtonClick(Self);\r\n\r\n if (FPopup <> nil) and FPopupVisible then\r\n PopupCloseUp(FPopup, True)\r\n else\r\n PopupDropDown(True);\r\nend;\r\n\r\nprocedure TJvCustomComboEdit.Change;\r\nbegin\r\n DataConnector.Modify;\r\n if not PopupVisible then\r\n DoChange\r\n else\r\n PopupChange;\r\nend;\r\n\r\nprocedure TJvCustomComboEdit.CMBiDiModeChanged(var Msg: TMessage);\r\nbegin\r\n inherited;\r\n if FPopup <> nil then\r\n FPopup.BiDiMode := BiDiMode;\r\nend;\r\n\r\nprocedure TJvCustomComboEdit.CMCancelMode(var Msg: TCMCancelMode);\r\nbegin\r\n if (Msg.Sender <> Self) and (Msg.Sender <> FPopup) and\r\n (Msg.Sender <> FButton) and ((FPopup <> nil) and\r\n not FPopup.ContainsControl(Msg.Sender)) then\r\n PopupCloseUp(FPopup, False);\r\nend;\r\n\r\nprocedure TJvCustomComboEdit.CMCtl3DChanged(var Msg: TMessage);\r\nbegin\r\n inherited;\r\n DoCtl3DChanged;\r\nend;\r\n\r\nprocedure TJvCustomComboEdit.CMExit(var Message: TCMExit);\r\nbegin\r\n Inc(FInCMExit); // used for FCheckOnExit\r\n try\r\n inherited;\r\n finally\r\n Dec(FInCMExit);\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomComboEdit.CMPopupCloseup(var Msg: TMessage);\r\nbegin\r\n PopupCloseUp(Self, Boolean(Msg.WParam));\r\nend;\r\n\r\nprocedure TJvCustomComboEdit.CMWantSpecialKey(var Msg: TCMWantSpecialKey);\r\nbegin\r\n inherited;\r\n { Ignore tabs when popup is visible }\r\n if PopupVisible and (Msg.CharCode = VK_TAB) then\r\n Msg.Result := 1;\r\nend;\r\n\r\nprocedure TJvCustomComboEdit.CNCtlColor(var Msg: TMessage);\r\nvar\r\n TextColor: Longint;\r\nbegin\r\n inherited;\r\n TextColor := ColorToRGB(Font.Color);\r\n if not Enabled and (ColorToRGB(Color) <> ColorToRGB(clGrayText)) then\r\n TextColor := ColorToRGB(clGrayText);\r\n SetTextColor(Msg.WParam, TextColor);\r\nend;\r\n\r\nprocedure TJvCustomComboEdit.CreateAutoComplete;\r\nbegin\r\n if HandleAllocated and not (csDesigning in ComponentState) and\r\n {not Assigned(FAutoCompleteIntf) and} (AutoCompleteOptions <> []) then\r\n begin\r\n { Create the autocomplete object. }\r\n if Succeeded(CoCreateInstance(CLSID_AutoComplete, nil, CLSCTX_INPROC_SERVER, IAutoComplete,\r\n FAutoCompleteIntf)) then\r\n begin\r\n { Initialize the autocomplete object. }\r\n FAutoCompleteIntf.Init(Self.Handle, GetAutoCompleteSource, nil, nil);\r\n end\r\n else\r\n FAutoCompleteIntf := nil;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomComboEdit.DestroyAutoComplete;\r\nbegin\r\n FAutoCompleteIntf := nil;\r\nend;\r\n\r\nprocedure TJvCustomComboEdit.CreateParams(var Params: TCreateParams);\r\nconst\r\n Alignments: array [TAlignment] of LongWord = (ES_LEFT, ES_RIGHT, ES_CENTER);\r\nbegin\r\n inherited CreateParams(Params);\r\n Params.Style := Params.Style or\r\n ES_MULTILINE or WS_CLIPCHILDREN or Alignments[FAlignment];\r\nend;\r\n\r\nprocedure TJvCustomComboEdit.CreatePopup;\r\nbegin\r\n { Notification }\r\nend;\r\n\r\nprocedure TJvCustomComboEdit.CreateWnd;\r\nbegin\r\n inherited CreateWnd;\r\n UpdateControls;\r\n UpdateMargins;\r\n if AutoCompleteOptions <> [] then\r\n begin\r\n CreateAutoComplete;\r\n UpdateAutoComplete;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomComboEdit.CustomAlignPosition(Control: TControl;\r\n var NewLeft, NewTop, NewWidth, NewHeight: Integer;\r\n var AlignRect: TRect; AlignInfo: TAlignInfo);\r\nbegin\r\n if Control = FBtnControl then\r\n UpdateBtnBounds(NewLeft, NewTop, NewWidth, NewHeight);\r\nend;\r\n\r\nclass function TJvCustomComboEdit.DefaultImageIndex: TImageIndex;\r\nbegin\r\n Result := -1;\r\nend;\r\n\r\nclass function TJvCustomComboEdit.DefaultImages: TCustomImageList;\r\nbegin\r\n if GDefaultComboEditImagesList = nil then\r\n GDefaultComboEditImagesList := TImageList.CreateSize(14, 12);\r\n Result := TCustomImageList(GDefaultComboEditImagesList);\r\nend;\r\n\r\nprocedure TJvCustomComboEdit.DefineProperties(Filer: TFiler);\r\nbegin\r\n inherited DefineProperties(Filer);\r\n\r\n Filer.DefineProperty('GlyphKind', ReadGlyphKind, nil, False);\r\n Filer.DefineProperty('Ctl3D', ReadCtl3D, nil, False);\r\n Filer.DefineProperty('ParentCtl3D', ReadParentCtl3D, nil, False);\r\nend;\r\n\r\nprocedure TJvCustomComboEdit.DestroyWnd;\r\nbegin\r\n inherited DestroyWnd;\r\n { Mantis #3642 }\r\n DestroyAutoComplete;\r\nend;\r\n\r\nprocedure TJvCustomComboEdit.DoChange;\r\nbegin\r\n inherited Change;\r\nend;\r\n\r\nprocedure TJvCustomComboEdit.DoClick;\r\nbegin\r\n EditButtonClick(Self);\r\nend;\r\n\r\nprocedure TJvCustomComboEdit.WMClear(var Msg: TMessage);\r\nbegin\r\n Text := '';\r\nend;\r\n\r\nprocedure TJvCustomComboEdit.WMCut(var Msg: TMessage);\r\nbegin\r\n if FDirectInput and not ReadOnly then\r\n inherited;\r\nend;\r\n\r\nprocedure TJvCustomComboEdit.WMPaste(var Msg: TMessage);\r\nbegin\r\n if FDirectInput and not ReadOnly then\r\n inherited;\r\n UpdateGroup;\r\nend;\r\n\r\nprocedure TJvCustomComboEdit.DoCtl3DChanged;\r\nbegin\r\n UpdateMargins;\r\n UpdateControls;\r\nend;\r\n\r\nprocedure TJvCustomComboEdit.CMFixCaretPosition(var Msg: TMessage);\r\nbegin\r\n SelStart := SendMessage(Handle, EM_CHARFROMPOS, 0, Msg.LParam);\r\n inherited;\r\nend;\r\n\r\nprocedure TJvCustomComboEdit.DoEnter;\r\nvar\r\n Pt: TPoint;\r\nbegin\r\n if AutoSelect and not (csLButtonDown in ControlState) then\r\n SelectAll\r\n else\r\n if IsMasked and (csLButtonDown in ControlState) and\r\n (GetWindowLong(Handle, GWL_STYLE) and ES_MULTILINE <> 0) then\r\n begin\r\n { ES_MULTILINE causes the edit to place the caret at the wrong location. }\r\n if GetCursorPos(Pt) then\r\n begin\r\n Pt := ScreenToClient(Pt);\r\n PostMessage(Handle, CM_FIXCARETPOSITION, 0, MakeLong(Word(Pt.X), Word(Pt.Y)));\r\n end;\r\n end;\r\n inherited DoEnter;\r\nend;\r\n\r\nprocedure TJvCustomComboEdit.DoExit;\r\nbegin\r\n DataConnector.UpdateRecord;\r\n inherited DoExit;\r\nend;\r\n\r\nprocedure TJvCustomComboEdit.FocusKilled(NextWnd: THandle);\r\nvar\r\n Sender: TWinControl;\r\nbegin\r\n inherited FocusKilled(NextWnd);\r\n FFocused := Screen.ActiveControl <> Self;\r\n if not FFocused then\r\n begin\r\n Sender := FindControl(NextWnd);\r\n if (Sender <> Self) and (Sender <> FPopup) and\r\n {(Sender <> FButton)} ((FPopup <> nil) and\r\n not FPopup.ContainsControl(Sender)) then\r\n begin\r\n { MSDN : While processing this message (WM_KILLFOCUS), do not make any\r\n function calls that display or activate a window.\r\n }\r\n AsyncPopupCloseUp(False);\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJvCustomComboEdit.DoEraseBackground(Canvas: TCanvas; Param: LPARAM): Boolean;\r\nbegin\r\n Result := True;\r\n if csDestroying in ComponentState then\r\n { (rb) Implementation diffs; some return True other False }\r\n Exit;\r\n if Enabled then\r\n Result := inherited DoEraseBackground(Canvas, Param)\r\n else\r\n begin\r\n {$IFDEF COMPILER16_UP}\r\n if StyleServices.Enabled and not StyleServices.IsSystemStyle then\r\n begin\r\n // Ignore FDisabldColor. The Style dictates the color\r\n Result := inherited DoEraseBackground(Canvas, Param);\r\n end\r\n else\r\n {$ENDIF COMPILER16_UP}\r\n begin\r\n Canvas.Brush.Color := FDisabledColor;\r\n Canvas.Brush.Style := bsSolid;\r\n Canvas.FillRect(ClientRect);\r\n end;\r\nend;\r\nend;\r\n\r\nprocedure TJvCustomComboEdit.FocusSet(PrevWnd: THandle);\r\nbegin\r\n inherited FocusSet(PrevWnd); // triggers OnExit and OnEnter => Focus could be changed\r\n FFocused := Screen.ActiveControl = Self;\r\n if FFocused then\r\n SetShowCaret;\r\nend;\r\n\r\nprocedure TJvCustomComboEdit.EditButtonClick(Sender: TObject);\r\nbegin\r\n if (not FReadOnly) or AlwaysEnableButton then\r\n ButtonClick;\r\nend;\r\n\r\nfunction TJvCustomComboEdit.EditCanModify: Boolean;\r\nbegin\r\n Result := not FReadOnly;\r\nend;\r\n\r\nprocedure TJvCustomComboEdit.EnabledChanged;\r\nbegin\r\n inherited EnabledChanged;\r\n Invalidate;\r\n FButton.Enabled := Enabled;\r\n if Assigned(FOnEnabledChanged) then\r\n FOnEnabledChanged(Self);\r\nend;\r\n\r\nprocedure TJvCustomComboEdit.FontChanged;\r\nbegin\r\n inherited FontChanged;\r\n if HandleAllocated then\r\n UpdateMargins;\r\nend;\r\n\r\nfunction TJvCustomComboEdit.GetActionLinkClass: TControlActionLinkClass;\r\nbegin\r\n Result := TJvCustomComboEditActionLink;\r\nend;\r\n\r\nfunction TJvCustomComboEdit.GetAutoCompleteSource: IEnumString;\r\nbegin\r\n Result := TAutoCompleteSource.Create(Self, 0);\r\nend;\r\n\r\nfunction TJvCustomComboEdit.GetButtonFlat: Boolean;\r\nbegin\r\n Result := FButton.Flat;\r\nend;\r\n\r\nfunction TJvCustomComboEdit.GetButtonHint: string;\r\nbegin\r\n Result := FButton.Hint;\r\nend;\r\n\r\nfunction TJvCustomComboEdit.GetButtonWidth: Integer;\r\nbegin\r\n if ShowButton then\r\n Result := FButton.Width\r\n else\r\n Result := FSavedButtonWidth;\r\nend;\r\n\r\nfunction TJvCustomComboEdit.GetDirectInput: Boolean;\r\nbegin\r\n Result := FDirectInput;\r\nend;\r\n\r\nfunction TJvCustomComboEdit.GetFlat: Boolean;\r\nbegin\r\n Result := not Ctl3D;\r\nend;\r\n\r\nfunction TJvCustomComboEdit.GetParentFlat: Boolean;\r\nbegin\r\n Result := ParentCtl3D;\r\nend;\r\n\r\nprocedure TJvCustomComboEdit.SetFlat(const Value: Boolean);\r\nbegin\r\n Ctl3D := not Value;\r\nend;\r\n\r\nprocedure TJvCustomComboEdit.SetParentFlat(const Value: Boolean);\r\nbegin\r\n ParentCtl3D := Value;\r\nend;\r\n\r\nfunction TJvCustomComboEdit.GetGlyph: TBitmap;\r\nbegin\r\n Result := FButton.Glyph;\r\nend;\r\n\r\nfunction TJvCustomComboEdit.GetGlyphKind: TGlyphKind;\r\nbegin\r\n Result := TGlyphKind(FImageKind);\r\nend;\r\n\r\nprocedure TJvCustomComboEdit.GetInternalMargins(var ALeft, ARight: Integer);\r\nconst\r\n CPixelsBetweenEditAndButton = 2;\r\nbegin\r\n ARight := ARight + FBtnControl.Width + CPixelsBetweenEditAndButton;\r\nend;\r\n\r\nfunction TJvCustomComboEdit.GetMinHeight: Integer;\r\nvar\r\n I: Integer;\r\nbegin\r\n I := GetTextHeight;\r\n if BorderStyle = bsSingle then\r\n I := I + GetSystemMetrics(SM_CYBORDER) * 4 + 1;\r\n Result := I;\r\nend;\r\n\r\nfunction TJvCustomComboEdit.GetNumGlyphs: TNumGlyphs;\r\nbegin\r\n if ImageKind <> ikCustom then\r\n Result := FNumGlyphs\r\n else\r\n Result := FButton.NumGlyphs;\r\nend;\r\n\r\nfunction TJvCustomComboEdit.GetPopupValue: Variant;\r\nbegin\r\n if FPopup is TJvPopupWindow then\r\n Result := TJvPopupWindow(FPopup).GetValue\r\n else\r\n Result := '';\r\nend;\r\n\r\nfunction TJvCustomComboEdit.GetPopupVisible: Boolean;\r\nbegin\r\n Result := (FPopup <> nil) and FPopupVisible;\r\nend;\r\n\r\nfunction TJvCustomComboEdit.GetReadOnly: Boolean;\r\nbegin\r\n Result := FReadOnly;\r\nend;\r\n\r\nfunction TJvCustomComboEdit.GetSettingCursor: Boolean;\r\nbegin\r\n Result := TCustomMaskEditAccessPrivate(Self).FSettingCursor;\r\nend;\r\n\r\nfunction TJvCustomComboEdit.GetShowButton: Boolean;\r\nbegin\r\n Result := FBtnControl.Visible;\r\nend;\r\n\r\nfunction TJvCustomComboEdit.GetTextHeight: Integer;\r\nvar\r\n DC: HDC;\r\n SaveFont: HFONT;\r\n SysMetrics, Metrics: TTextMetric;\r\nbegin\r\n DC := GetDC(HWND_DESKTOP);\r\n try\r\n GetTextMetrics(DC, SysMetrics);\r\n SaveFont := SelectObject(DC, Font.Handle);\r\n GetTextMetrics(DC, Metrics);\r\n SelectObject(DC, SaveFont);\r\n finally\r\n ReleaseDC(HWND_DESKTOP, DC);\r\n end;\r\n Result := Metrics.tmHeight;\r\nend;\r\n\r\nprocedure TJvCustomComboEdit.HidePopup;\r\nbegin\r\n if FPopup is TJvPopupWindow then\r\n begin\r\n TJvPopupWindow(FPopup).Hide;\r\n if Assigned(FOnPopupHidden) then\r\n FOnPopupHidden(Self);\r\n end;\r\nend;\r\n\r\nfunction TJvCustomComboEdit.IsCustomGlyph: Boolean;\r\nbegin\r\n Result := Assigned(Glyph) and (ImageKind = ikCustom);\r\nend;\r\n\r\nfunction TJvCustomComboEdit.IsFlatStored: Boolean;\r\nbegin\r\n { Same as IsCtl3DStored }\r\n Result := not ParentCtl3D;\r\nend;\r\n\r\nfunction TJvCustomComboEdit.IsImageIndexStored: Boolean;\r\nbegin\r\n Result :=\r\n not (ActionLink is TJvCustomComboEditActionLink) or\r\n not (ActionLink as TJvCustomComboEditActionLink).IsImageIndexLinked;\r\nend;\r\n\r\nprocedure TJvCustomComboEdit.KeyDown(var Key: Word; Shift: TShiftState);\r\nvar\r\n Form: TCustomForm;\r\nbegin\r\n UpdateGroup;\r\n\r\n Form := GetParentForm(Self);\r\n if (ssCtrl in Shift) then\r\n case Key of\r\n VK_RETURN:\r\n if (Form <> nil) {and Form.KeyPreview} then\r\n begin\r\n TWinControlAccessProtected(Form).KeyDown(Key, Shift);\r\n Key := 0;\r\n end;\r\n VK_TAB:\r\n if (Form <> nil) {and Form.KeyPreview} then\r\n begin\r\n TWinControlAccessProtected(Form).KeyDown(Key, Shift);\r\n Key := 0;\r\n end;\r\n end;\r\n //Original\r\n inherited KeyDown(Key, Shift);\r\n if (FClickKey = ShortCut(Key, Shift)) and (ButtonWidth > 0) then\r\n begin\r\n EditButtonClick(Self);\r\n Key := 0;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomComboEdit.KeyPress(var Key: Char);\r\nvar\r\n Form: TCustomForm;\r\nbegin\r\n Form := GetParentForm(Self);\r\n\r\n if (Key = Cr) or (Key = Esc) or ((Key = Lf) and PopupVisible) then\r\n begin\r\n if PopupVisible then\r\n begin\r\n PopupCloseUp(FPopup, Key <> Esc);\r\n Key := #0;\r\n end\r\n else\r\n begin\r\n { must catch and remove this, since is actually multi-line }\r\n if (Form <> nil) and (Form.Perform(CM_DIALOGKEY, Byte(Key), 0) <> 0) then\r\n begin\r\n Key := #0;\r\n Exit;\r\n end;\r\n if Key = Cr then\r\n begin\r\n inherited KeyPress(Key);\r\n Key := #0;\r\n Exit;\r\n end;\r\n end;\r\n end;\r\n if (Key = Tab) or (Key = Lf) then\r\n begin\r\n Key := #0;\r\n { (rb) Next code has no use because Key = #0? }\r\n if (Form <> nil) {and Form.KeyPreview} then\r\n TWinControlAccessProtected(Form).KeyPress(Key);\r\n end;\r\n inherited KeyPress(Key);\r\n\r\n if (Key = #27) and DataConnector.Active then\r\n begin\r\n DataConnector.Reset;\r\n Key := #0;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomComboEdit.Loaded;\r\nbegin\r\n inherited Loaded;\r\n if FStreamedButtonWidth >= 0 then\r\n begin\r\n SetButtonWidth(FStreamedButtonWidth);\r\n if FStreamedFixedWidth then\r\n with FButton do\r\n ControlStyle := ControlStyle + [csFixedWidth];\r\n end;\r\n\r\n UpdateControls;\r\n UpdateMargins;\r\nend;\r\n\r\nprocedure TJvCustomComboEdit.LocalKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);\r\nbegin\r\n UpdateGroup;\r\n if Assigned(FOnKeyDown) then\r\n FOnKeyDown(Sender, Key, Shift);\r\nend;\r\n\r\nprocedure TJvCustomComboEdit.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);\r\nbegin\r\n if (FPopup <> nil) and (Button = mbLeft) then\r\n begin\r\n if CanFocus then\r\n SetFocus;\r\n if not FFocused then\r\n Exit;\r\n if FPopupVisible then\r\n PopupCloseUp(FPopup, False);\r\n {else\r\n if (not ReadOnly or AlwaysEnable) and (not DirectInput) then\r\n PopupDropDown(True);}\r\n end;\r\n inherited MouseDown(Button, Shift, X, Y);\r\nend;\r\n\r\nprocedure TJvCustomComboEdit.Notification(AComponent: TComponent; Operation: TOperation);\r\nbegin\r\n inherited Notification(AComponent, Operation);\r\n if (Operation = opRemove) and (AComponent = FImages) then\r\n Images := nil;\r\n if (Operation = opRemove) and (AComponent = FPopup) then\r\n FPopup := nil;\r\nend;\r\n\r\nprocedure TJvCustomComboEdit.PopupChange;\r\nbegin\r\n if Assigned(FOnPopupChange) then\r\n FOnPopupChange(Self);\r\nend;\r\n\r\nprocedure TJvCustomComboEdit.PopupCloseUp(Sender: TObject; Accept: Boolean);\r\nvar\r\n AValue: Variant;\r\nbegin\r\n if (FPopup <> nil) and FPopupVisible then\r\n begin\r\n if GetCapture <> 0 then\r\n SendMessage(GetCapture, WM_CANCELMODE, 0, 0);\r\n AValue := GetPopupValue;\r\n HidePopup;\r\n try\r\n try\r\n if CanFocus and ParentFormVisible(Self) then\r\n begin\r\n SetFocus;\r\n if GetFocus = Handle then\r\n SetShowCaret;\r\n end;\r\n except\r\n { ignore exceptions }\r\n end;\r\n SetDirectInput(DirectInput);\r\n Invalidate;\r\n try\r\n if Accept and AcceptPopup(AValue) and EditCanModify then\r\n begin\r\n AcceptValue(AValue);\r\n if FFocused then\r\n inherited SelectAll;\r\n end\r\n else\r\n Reset;\r\n except\r\n Reset;\r\n raise;\r\n end;\r\n finally\r\n FPopupVisible := False;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomComboEdit.PopupDropDown(DisableEdit: Boolean);\r\ntype\r\n TJvSizeRect = record\r\n Top: Integer;\r\n Left: Integer;\r\n Width: Integer;\r\n Height: Integer;\r\n end;\r\nvar\r\n P: TPoint;\r\n Y: Integer;\r\n SR: TJvSizeRect;\r\n Monitor: TMonitor;\r\n Rect: TRect;\r\nbegin\r\n if not ((ReadOnly and not FAlwaysShowPopup) or FPopupVisible) then\r\n begin\r\n CreatePopup;\r\n if FPopup = nil then\r\n Exit;\r\n\r\n P := Parent.ClientToScreen(Point(Left, Top));\r\n Monitor := FindMonitor(MonitorFromWindow(Handle, MONITOR_DEFAULTTONEAREST));\r\n Rect := GetWorkAreaRect(Monitor);\r\n SR.Top := Rect.Top;\r\n SR.Left := Rect.Left;\r\n SR.Width := Rect.Right - Rect.Left;\r\n SR.Height := Rect.Bottom - Rect.Top;\r\n Y := P.Y + Height;\r\n if Y + FPopup.Height > SR.Top + SR.Height then\r\n Y := P.Y - FPopup.Height;\r\n case FPopupAlign of\r\n epaRight:\r\n begin\r\n Dec(P.X, FPopup.Width - Width);\r\n if P.X < SR.Left then\r\n Inc(P.X, FPopup.Width - Width);\r\n end;\r\n epaLeft:\r\n if P.X + FPopup.Width > SR.Left + SR.Width then\r\n Dec(P.X, FPopup.Width - Width);\r\n end;\r\n if P.X < SR.Left then\r\n P.X := SR.Left\r\n else\r\n if P.X + FPopup.Width > SR.Left + SR.Width then\r\n P.X := SR.Left + SR.Width - FPopup.Width;\r\n if Text <> '' then\r\n SetPopupValue(Text)\r\n else\r\n SetPopupValue(Null);\r\n if CanFocus then\r\n SetFocus;\r\n ShowPopup(Point(P.X, Y));\r\n FPopupVisible := True;\r\n if DisableEdit then\r\n begin\r\n inherited ReadOnly := True;\r\n HideCaret(Handle);\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomComboEdit.ReadCtl3D(Reader: TReader);\r\nbegin\r\n Flat := not Reader.ReadBoolean;\r\nend;\r\n\r\nprocedure TJvCustomComboEdit.ReadParentCtl3D(Reader: TReader);\r\nbegin\r\n ParentFlat := Reader.ReadBoolean;\r\nend;\r\n\r\nprocedure TJvCustomComboEdit.ReadGlyphKind(Reader: TReader);\r\nconst\r\n sEnumValues: array [TGlyphKind] of string =\r\n ('gkCustom', 'gkDefault', 'gkDropDown', 'gkEllipsis');\r\nvar\r\n S: string;\r\n GlyphKind: TGlyphKind;\r\nbegin\r\n { No need to drag in TypInfo.pas }\r\n S := Reader.ReadIdent;\r\n for GlyphKind := Low(TGlyphKind) to High(TGlyphKind) do\r\n if SameText(S, sEnumValues[GlyphKind]) then\r\n begin\r\n ImageKind := TJvImageKind(GlyphKind);\r\n Break;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomComboEdit.RecreateGlyph;\r\nvar\r\n NewGlyph: TBitmap;\r\n\r\n function CreateEllipsisGlyph: TBitmap;\r\n var\r\n W, g, I: Integer;\r\n begin\r\n Result := TBitmap.Create;\r\n with Result do\r\n try\r\n Monochrome := True;\r\n Width := Max(1, FButton.Width - 6);\r\n Height := 4;\r\n W := 2;\r\n g := (Result.Width - 3 * W) div 2;\r\n if g <= 0 then\r\n g := 1;\r\n if g > 3 then\r\n g := 3;\r\n I := (Width - 3 * W - 2 * g) div 2;\r\n PatBlt(Canvas.Handle, I, 1, W, W, BLACKNESS);\r\n PatBlt(Canvas.Handle, I + g + W, 1, W, W, BLACKNESS);\r\n PatBlt(Canvas.Handle, I + 2 * g + 2 * W, 1, W, W, BLACKNESS);\r\n except\r\n Free;\r\n raise;\r\n end;\r\n end;\r\n\r\nbegin\r\n { Delay until button is shown }\r\n if not ShowButton then\r\n Exit;\r\n\r\n if FImageKind in [ikDropDown, ikEllipsis] then\r\n begin\r\n FButton.ImageIndex := -1;\r\n FButton.NumGlyphs := 1;\r\n end;\r\n {$IFDEF JVCLThemesEnabled}\r\n FButton.FDrawThemedDropDownBtn := FImageKind = ikDropDown;\r\n {$ENDIF JVCLThemesEnabled}\r\n\r\n case FImageKind of\r\n ikDropDown:\r\n begin\r\n {$IFDEF JVCLThemesEnabled}\r\n { When XP Themes are enabled, ButtonFlat = False, GlyphKind = gkDropDown then\r\n the glyph is the default themed dropdown button. When ButtonFlat = True, we\r\n can't use that default dropdown button (because we then use toolbar buttons,\r\n and there is no themed dropdown toolbar button) }\r\n FButton.FDrawThemedDropDownBtn :=\r\n ThemeServices.{$IFDEF RTL230_UP}Enabled{$ELSE}ThemesEnabled{$ENDIF RTL230_UP} and not ButtonFlat;\r\n if FButton.FDrawThemedDropDownBtn then\r\n begin\r\n FButton.ButtonGlyph.Glyph := nil;\r\n FButton.Invalidate;\r\n end\r\n else\r\n {$ENDIF JVCLThemesEnabled}\r\n begin\r\n LoadDefaultBitmap(FButton.ButtonGlyph.Glyph, OBM_COMBO);\r\n FButton.Invalidate;\r\n end;\r\n end;\r\n ikEllipsis:\r\n begin\r\n NewGlyph := CreateEllipsisGlyph;\r\n try\r\n FButton.ButtonGlyph.Glyph := NewGlyph;\r\n FButton.Invalidate;\r\n finally\r\n NewGlyph.Destroy;\r\n end;\r\n end;\r\n else\r\n// FButton.ButtonGlyph.Glyph := nil;\r\n FButton.Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomComboEdit.SelectAll;\r\nbegin\r\n if DirectInput then\r\n inherited SelectAll;\r\nend;\r\n\r\nprocedure TJvCustomComboEdit.SetAlignment(Value: TAlignment);\r\nbegin\r\n if FAlignment <> Value then\r\n begin\r\n FAlignment := Value;\r\n RecreateWnd;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomComboEdit.SetAutoCompleteItems(Strings: TStrings);\r\nbegin\r\n FAutoCompleteItems.Assign(Strings);\r\nend;\r\n\r\nprocedure TJvCustomComboEdit.SetAutoCompleteOptions(const Value: TJvAutoCompleteOptions);\r\nbegin\r\n if Value <> FAutoCompleteOptions then\r\n begin\r\n FAutoCompleteOptions := Value;\r\n\r\n if not Assigned(FAutoCompleteIntf) then\r\n CreateAutoComplete;\r\n UpdateAutoComplete;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomComboEdit.SetButtonFlat(const Value: Boolean);\r\nbegin\r\n FButton.Flat := Value;\r\n {$IFDEF JVCLThemesEnabled}\r\n { When XP Themes are enabled, ButtonFlat = False, GlyphKind = gkDropDown then\r\n the glyph is the default themed dropdown button. When ButtonFlat = True, we\r\n can't use that default dropdown button, so we have to recreate the glyph\r\n in this special case }\r\n if ThemeServices.{$IFDEF RTL230_UP}Enabled{$ELSE}ThemesEnabled{$ENDIF RTL230_UP} and (ImageKind = ikDropDown) then\r\n RecreateGlyph;\r\n {$ENDIF JVCLThemesEnabled}\r\nend;\r\n\r\nprocedure TJvCustomComboEdit.SetButtonHint(const Value: string);\r\nbegin\r\n FButton.Hint := Value;\r\nend;\r\n\r\nprocedure TJvCustomComboEdit.SetButtonWidth(Value: Integer);\r\nbegin\r\n if csLoading in ComponentState then\r\n begin\r\n FStreamedButtonWidth := Value;\r\n FStreamedFixedWidth := False;\r\n end\r\n else\r\n if not ShowButton then\r\n FSavedButtonWidth := Value\r\n else\r\n if (ButtonWidth <> Value) {or ((Value > 0) <> ShowButton)} then\r\n begin\r\n if Value > 1 then\r\n FBtnControl.Visible := True\r\n else\r\n begin\r\n FSavedButtonWidth := ButtonWidth;\r\n FBtnControl.Visible := False;\r\n end;\r\n if csCreating in ControlState then\r\n begin\r\n FBtnControl.Width := Value;\r\n FButton.Width := Value;\r\n with FButton do\r\n ControlStyle := ControlStyle - [csFixedWidth];\r\n { Some glyphs are size dependant (ellipses), thus recreate on size changes }\r\n RecreateGlyph;\r\n end\r\n else\r\n if (Value <> ButtonWidth) and\r\n ((Assigned(Parent) and (Value < ClientWidth)) or\r\n (not Assigned(Parent) and (Value < Width))) then\r\n begin\r\n FBtnControl.SetBounds(FBtnControl.Left + FBtnControl.Width - Value,\r\n FBtnControl.Top, Value, FBtnControl.Height);\r\n FButton.Width := Value;\r\n with FButton do\r\n ControlStyle := ControlStyle - [csFixedWidth];\r\n if HandleAllocated then\r\n RecreateWnd;\r\n { Some glyphs are size dependant (ellipses), thus recreate on size changes }\r\n RecreateGlyph;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomComboEdit.SetClipboardCommands(const Value: TJvClipboardCommands);\r\nbegin\r\n if ClipboardCommands <> Value then\r\n begin\r\n inherited SetClipboardCommands(Value);\r\n if ReadOnly and not (ClipboardCommands <= [caCopy]) then\r\n ClipboardCommands := [caCopy];\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomComboEdit.SetDirectInput(Value: Boolean);\r\nbegin\r\n inherited ReadOnly := not Value or FReadOnly;\r\n FDirectInput := Value;\r\nend;\r\n\r\nprocedure TJvCustomComboEdit.SetDisabledColor(const Value: TColor);\r\nbegin\r\n if FDisabledColor <> Value then\r\n begin\r\n FDisabledColor := Value;\r\n if not Enabled then\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomComboEdit.SetDisabledTextColor(const Value: TColor);\r\nbegin\r\n if FDisabledTextColor <> Value then\r\n begin\r\n FDisabledTextColor := Value;\r\n if not Enabled then\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomComboEdit.SetGlyph(Value: TBitmap);\r\nbegin\r\n ImageKind := ikCustom;\r\n FButton.Glyph := Value;\r\n FNumGlyphs := FButton.NumGlyphs;\r\nend;\r\n\r\nprocedure TJvCustomComboEdit.SetGlyphKind(Value: TGlyphKind);\r\nbegin\r\n ImageKind := TJvImageKind(Value);\r\nend;\r\n\r\nprocedure TJvCustomComboEdit.SetGroupIndex(const Value: Integer);\r\nbegin\r\n FGroupIndex := Value;\r\n UpdateGroup;\r\nend;\r\n\r\nprocedure TJvCustomComboEdit.SetImageIndex(const Value: TImageIndex);\r\nbegin\r\n if FImageIndex <> Value then\r\n begin\r\n FImageIndex := Value;\r\n if FImageKind = ikCustom then\r\n FButton.ImageIndex := FImageIndex;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomComboEdit.SetImageKind(const Value: TJvImageKind);\r\nbegin\r\n if FImageKind <> Value then\r\n begin\r\n FImageKind := Value;\r\n RecreateGlyph;\r\n case FImageKind of\r\n ikCustom:\r\n begin\r\n FButton.Images := FImages;\r\n FButton.ImageIndex := FImageIndex;\r\n FButton.NumGlyphs := FNumGlyphs;\r\n end;\r\n ikDefault:\r\n begin\r\n FButton.Images := DefaultImages;\r\n FButton.ImageIndex := DefaultImageIndex;\r\n { Default glyphs have a default width }\r\n if Assigned(FButton.Images) and (FButton.ImageIndex >= 0) then\r\n ButtonWidth := Max(FButton.Images.Width + 6, FButton.Width)\r\n end;\r\n ikDropDown:\r\n if csLoading in ComponentState then\r\n begin\r\n if (FStreamedButtonWidth < 0) or FStreamedFixedWidth then\r\n begin\r\n ButtonWidth := GetSystemMetrics(SM_CXVSCROLL);\r\n { Setting ButtonWidth will set FStreamedFixedWidth to False, thus\r\n reapply it. }\r\n FStreamedFixedWidth := True;\r\n end;\r\n end\r\n else\r\n begin\r\n ButtonWidth := GetSystemMetrics(SM_CXVSCROLL);\r\n { Setting ButtonWidth will remove the csFixedWidth flag, thus\r\n reapply it. }\r\n with FButton do\r\n ControlStyle := ControlStyle + [csFixedWidth];\r\n end;\r\n ikEllipsis: ;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomComboEdit.SetImages(const Value: TCustomImageList);\r\nbegin\r\n ReplaceComponentReference(Self, Value, TComponent(FImages));\r\n if FImages = nil then\r\n SetImageIndex(-1);\r\n if ImageKind = ikCustom then\r\n begin\r\n FButton.Images := FImages;\r\n FButton.ImageIndex := FImageIndex;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomComboEdit.SetNumGlyphs(const Value: TNumGlyphs);\r\nbegin\r\n //if FGlyphKind in [gkDropDown, gkEllipsis] then\r\n // FButton.NumGlyphs := 1\r\n //else\r\n //if FGlyphKind = gkDefault then\r\n // FButton.NumGlyphs := FDefNumGlyphs\r\n //else\r\n FNumGlyphs := Value;\r\n if ImageKind = ikCustom then\r\n FButton.NumGlyphs := Value;\r\nend;\r\n\r\nprocedure TJvCustomComboEdit.SetPopupValue(const Value: Variant);\r\nbegin\r\n if FPopup is TJvPopupWindow then\r\n TJvPopupWindow(FPopup).SetValue(Value);\r\nend;\r\n\r\nprocedure TJvCustomComboEdit.SetReadOnly(Value: Boolean);\r\nbegin\r\n if Value <> FReadOnly then\r\n begin\r\n FReadOnly := Value;\r\n inherited ReadOnly := Value or not FDirectInput;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomComboEdit.SetShowButton(const Value: Boolean);\r\nbegin\r\n if ShowButton <> Value then\r\n begin\r\n if Value then\r\n begin\r\n { FBtnControl needs to be visible first, otherwise only FSavedButtonWidth\r\n is changed when setting ButtonWidth }\r\n FBtnControl.Visible := True;\r\n ButtonWidth := FSavedButtonWidth\r\n end\r\n else\r\n ButtonWidth := 0;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomComboEdit.SetDataConnector(const Value: TJvCustomComboEditDataConnector);\r\nbegin\r\n if Value <> FDataConnector then\r\n FDataConnector.Assign(Value);\r\nend;\r\n\r\nfunction TJvCustomComboEdit.CreateDataConnector: TJvCustomComboEditDataConnector;\r\nbegin\r\n Result := TJvCustomComboEditDataConnector.Create(Self);\r\nend;\r\n\r\nprocedure TJvCustomComboEdit.SetShowCaret;\r\nconst\r\n CaretWidth: array [Boolean] of Integer = (1, 2);\r\nbegin\r\n CreateCaret(Handle, 0, CaretWidth[fsBold in Font.Style], GetTextHeight);\r\n ShowCaret(Handle);\r\nend;\r\n\r\nprocedure TJvCustomComboEdit.ShowPopup(Origin: TPoint);\r\nbegin\r\n if FPopup is TJvPopupWindow then\r\n begin\r\n TJvPopupWindow(FPopup).Show(Origin);\r\n if Assigned(FOnPopupShown) then\r\n FOnPopupShown(Self);\r\n end;\r\nend;\r\n\r\n\r\nprocedure TJvCustomComboEdit.UpdateAutoComplete;\r\nconst\r\n cAutoCompleteOptionValues: array [TJvAutoCompleteOption] of DWORD =\r\n (ACO_AUTOSUGGEST, ACO_AUTOAPPEND,\r\n ACO_SEARCH, ACO_FILTERPREFIXES, ACO_USETAB, ACO_UPDOWNKEYDROPSLIST,\r\n ACO_RTLREADING);\r\nvar\r\n Flags: DWORD;\r\n Option: TJvAutoCompleteOption;\r\n AutoComplete2: IAutoComplete2;\r\nbegin\r\n if HandleAllocated and not (csDesigning in ComponentState) then\r\n begin\r\n if Supports(FAutoCompleteIntf, IAutoComplete2, AutoComplete2) then\r\n begin\r\n { Set the options of the autocomplete object. }\r\n Flags := 0;\r\n for Option := Low(TJvAutoCompleteOption) to High(TJvAutoCompleteOption) do\r\n if Option in AutoCompleteOptions then\r\n Inc(Flags, cAutoCompleteOptionValues[Option]);\r\n\r\n AutoComplete2.SetOptions(Flags);\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomComboEdit.UpdateBtnBounds(var NewLeft, NewTop, NewWidth, NewHeight: Integer);\r\nvar\r\n BtnRect: TRect;\r\nbegin\r\n {$IFDEF JVCLThemesEnabled}\r\n if ThemeServices.{$IFDEF RTL230_UP}Enabled{$ELSE}ThemesEnabled{$ENDIF RTL230_UP} then\r\n begin\r\n if BorderStyle = bsSingle then\r\n begin\r\n if Ctl3D then\r\n BtnRect := Bounds(Width - FButton.Width - 2 - 1, 0 + 1,\r\n FButton.Width, Height - 2 - 2)\r\n else\r\n BtnRect := Bounds(Width - FButton.Width - 1 - 1, 1 + 1,\r\n FButton.Width, Height - 2 - 2);\r\n end\r\n else\r\n BtnRect := Bounds(Width - FButton.Width, 0,\r\n FButton.Width, Height);\r\n end\r\n else\r\n {$ENDIF JVCLThemesEnabled}\r\n begin\r\n if BorderStyle = bsSingle then\r\n begin\r\n if not Flat then\r\n BtnRect := Bounds(Width - FButton.Width - 4 + 1, 0 + 1,\r\n FButton.Width, Height - 4)\r\n else\r\n BtnRect := Bounds(Width - FButton.Width - 2, 2,\r\n FButton.Width, Height - 4)\r\n end\r\n else\r\n BtnRect := Bounds(Width - FButton.Width, 0,\r\n FButton.Width, Height);\r\n end;\r\n\r\n // Mantis 4754: Bevels must be taken into account\r\n if BevelKind <> bkNone then\r\n begin\r\n if BevelInner <> bvNone then\r\n begin\r\n Dec(BtnRect.Left, 2);\r\n Dec(BtnRect.Right, 2);\r\n Dec(BtnRect.Bottom, 2);\r\n end;\r\n\r\n if BevelOuter <> bvNone then\r\n begin\r\n Dec(BtnRect.Left, 2);\r\n Dec(BtnRect.Right, 2);\r\n Dec(BtnRect.Bottom, 2);\r\n end;\r\n end;\r\n\r\n\r\n NewLeft := BtnRect.Left;\r\n NewTop := BtnRect.Top;\r\n NewWidth := BtnRect.Right - BtnRect.Left;\r\n NewHeight := BtnRect.Bottom - BtnRect.Top;\r\nend;\r\n\r\nprocedure TJvCustomComboEdit.UpdateControls;\r\nbegin\r\n { Notification }\r\nend;\r\n\r\nprocedure TJvCustomComboEdit.UpdateGroup;\r\nvar\r\n I: Integer;\r\nbegin\r\n if (FGroupIndex <> -1) and (Owner <> nil) then\r\n for I := 0 to Owner.ComponentCount - 1 do\r\n if Owner.Components[I] is TJvCustomComboEdit then\r\n with TJvCustomComboEdit(Owner.Components[I]) do\r\n if (Name <> Self.Name) and (FGroupIndex = Self.FGroupIndex) then\r\n Clear;\r\nend;\r\n\r\nprocedure TJvCustomComboEdit.UpdateMargins;\r\nvar\r\n LLeft, LRight, LTop: Integer;\r\n Loc: TRect;\r\nbegin\r\n { Delay until Loaded and Handle is created }\r\n if (csLoading in ComponentState) or not HandleAllocated then\r\n Exit;\r\n\r\n {UpdateMargins gets called whenever the layout of child controls changes.\r\n It uses GetInternalMargins to determine the left and right margins of the\r\n actual text area.}\r\n\r\n AdjustHeight;\r\n\r\n LTop := 0;\r\n LLeft := 0;\r\n LRight := 0;\r\n {$IFDEF JVCLThemesEnabled}\r\n { If flat and themes are enabled, move the left edge of the edit rectangle\r\n to the right, otherwise the theme edge paints over the border }\r\n { (rb) This was for a specific font/language; check if this is still necessary }\r\n if ThemeServices.{$IFDEF RTL230_UP}Enabled{$ELSE}ThemesEnabled{$ENDIF RTL230_UP} then\r\n begin\r\n if BorderStyle = bsSingle then\r\n begin\r\n if not Ctl3D then\r\n LLeft := 3\r\n else\r\n begin\r\n LLeft := 1;\r\n LTop := 1;\r\n end;\r\n end;\r\n end;\r\n if ThemeServices.{$IFDEF RTL230_UP}Enabled{$ELSE}ThemesEnabled{$ENDIF RTL230_UP} then\r\n begin\r\n if BorderStyle = bsSingle then\r\n if Ctl3D then\r\n LRight := 1\r\n else\r\n LRight := -1;\r\n end\r\n else\r\n {$ENDIF JVCLThemesEnabled}\r\n if (BorderStyle = bsSingle) and not Flat then\r\n LTop := 2;\r\n\r\n GetInternalMargins(LLeft, LRight);\r\n\r\n SetRect(Loc, LLeft, LTop, Width - LRight-3, ClientHeight - 1);\r\n SendRectMessage(Handle, EM_SETRECTNP, 0, Loc);\r\n // (rb) EM_SETMARGINS necessary?\r\n //SendMessage(Handle, EM_SETMARGINS, EC_RIGHTMARGIN or EC_LEFTMARGIN, MakeLong(LLeft, LRight));\r\nend;\r\n\r\nprocedure TJvCustomComboEdit.UpdatePopupVisible;\r\nbegin\r\n FPopupVisible := (FPopup <> nil) and FPopup.Visible;\r\nend;\r\n\r\nprocedure TJvCustomComboEdit.ValidateEdit;\r\nbegin\r\n if CheckOnExit or (FInCMExit = 0) then\r\n inherited ValidateEdit;\r\nend;\r\n\r\n{$IFDEF JVCLThemesEnabled}\r\nprocedure TJvCustomComboEdit.WMNCCalcSize(var Msg: TWMNCCalcSize);\r\nbegin\r\n if ThemeServices.{$IFDEF RTL230_UP}Enabled{$ELSE}ThemesEnabled{$ENDIF RTL230_UP} and Ctl3D and (BorderStyle = bsSingle) then\r\n begin\r\n with Msg.CalcSize_Params^ do\r\n InflateRect(rgrc[0], 1, 1);\r\n end;\r\n inherited;\r\nend;\r\n{$ENDIF JVCLThemesEnabled}\r\n\r\nprocedure TJvCustomComboEdit.WMNCHitTest(var Msg: TWMNCHitTest);\r\nvar\r\n P: TPoint;\r\nbegin\r\n inherited;\r\n if (Msg.Result = HTCLIENT) and not (csDesigning in ComponentState) and ShowButton then\r\n begin\r\n P := Point(FBtnControl.Left, FBtnControl.Top);\r\n Windows.ClientToScreen(Handle, P);\r\n if Msg.XPos > P.X then\r\n Msg.Result := HTBORDER; {HTCAPTION;}\r\n end;\r\nend;\r\n\r\n{$IFDEF JVCLThemesEnabled}\r\nprocedure TJvCustomComboEdit.WMNCPaint(var Msg: TWMNCPaint);\r\nvar\r\n DC: HDC;\r\n DrawRect: TRect;\r\n Details: TThemedElementDetails;\r\nbegin\r\n if ThemeServices.{$IFDEF RTL230_UP}Enabled{$ELSE}ThemesEnabled{$ENDIF RTL230_UP} and Ctl3D and (BorderStyle = bsSingle) and\r\n not CheckWin32Version(6, 0) then // Vista draws the border animated and not with teEditTextNormal\r\n begin\r\n DC := GetWindowDC(Handle);\r\n try\r\n GetWindowRect(Handle, DrawRect);\r\n OffsetRect(DrawRect, -DrawRect.Left, -DrawRect.Top);\r\n ExcludeClipRect(DC, DrawRect.Left + 1, DrawRect.Top + 1, DrawRect.Right - 1, DrawRect.Bottom - 1);\r\n\r\n Details := ThemeServices.GetElementDetails(teEditTextNormal);\r\n ThemeServices.DrawElement(DC, Details, DrawRect);\r\n finally\r\n ReleaseDC(Handle, DC);\r\n end;\r\n Msg.Result := 0;\r\n end\r\n else\r\n inherited;\r\nend;\r\n{$ENDIF JVCLThemesEnabled}\r\n\r\nprocedure TJvCustomComboEdit.WMPaint(var Msg: TWMPaint);\r\nvar\r\n Canvas: TControlCanvas;\r\nbegin\r\n if csDestroying in ComponentState then\r\n Exit;\r\n if Enabled then\r\n inherited\r\n else\r\n begin\r\n Canvas := nil;\r\n if not PaintEdit(Self, Text, FAlignment, PopupVisible,\r\n DisabledTextColor, Focused and not PopupVisible, Canvas, Msg) then\r\n inherited;\r\n Canvas.Free;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomComboEdit.WndProc(var Msg: TMessage);\r\nbegin\r\n if (((Msg.Msg >= WM_KEYFIRST) and (Msg.Msg <= WM_KEYLAST)) or (Msg.Msg = WM_CONTEXTMENU)) and\r\n not SettingCursor and PopupVisible and\r\n (FPopup is TJvPopupWindow) and Assigned(TJvPopupWindow(FPopup).ActiveControl) then\r\n begin\r\n // Mantis 4872: Avoid stack overflow.\r\n if (Msg.Msg <> WM_CONTEXTMENU) or\r\n (ControlAtPos(ScreenToClient(SmallPointToPoint(TWMContextMenu(Msg).Pos)), False) = TJvPopupWindow(FPopup).ActiveControl) then\r\n begin\r\n with Msg do\r\n Result := TJvPopupWindow(FPopup).ActiveControl.Perform(Msg, WParam, LParam);\r\n\r\n if Msg.Result = 0 then\r\n Exit;\r\n end;\r\n end;\r\n\r\n { The AutoComplete functionality sends a WM_SETTEXT. But only SetTextBuf()\r\n generates the required CM_TEXTCHANGED message after the WM_SETTEXT which is\r\n now missing in this case. The following code ignores the SetTextBuf()\r\n generated CM_TEXTCHANGE and performs it's own CM_TEXTCHANGE message after\r\n each WM_SETTEXT. }\r\n if (Msg.Msg = CM_TEXTCHANGED) and FTextChanged then // ignore the message generated by TControl.SetTextBuf()\r\n begin\r\n FTextChanged := False;\r\n Exit;\r\n end;\r\n\r\n inherited WndProc(Msg);\r\n\r\n if Msg.Msg = WM_SETTEXT then\r\n begin\r\n FTextChanged := False;\r\n Perform(CM_TEXTCHANGED, 0, 0); // generate our own CM_TEXTCHANGED message\r\n FTextChanged := True;\r\n end;\r\nend;\r\n\r\n//=== { TJvCustomComboEditActionLink } =======================================\r\n\r\nfunction TJvCustomComboEditActionLink.IsCaptionLinked: Boolean;\r\nbegin\r\n Result := False;\r\nend;\r\n\r\nfunction TJvCustomComboEditActionLink.IsHintLinked: Boolean;\r\nbegin\r\n Result := (Action is TCustomAction) and (FClient is TJvCustomComboEdit) and\r\n ((FClient as TJvCustomComboEdit).ButtonHint = (Action as TCustomAction).Hint);\r\nend;\r\n\r\nfunction TJvCustomComboEditActionLink.IsImageIndexLinked: Boolean;\r\nbegin\r\n Result := inherited IsImageIndexLinked and (FClient is TJvCustomComboEdit) and\r\n ((FClient as TJvCustomComboEdit).ImageIndex = (Action as TCustomAction).ImageIndex);\r\nend;\r\n\r\nfunction TJvCustomComboEditActionLink.IsOnExecuteLinked: Boolean;\r\nbegin\r\n Result := (Action is TCustomAction) and (FClient is TJvCustomComboEdit) and\r\n (@(FClient as TJvCustomComboEdit).OnButtonClick = @Action.OnExecute);\r\nend;\r\n\r\nfunction TJvCustomComboEditActionLink.IsShortCutLinked: Boolean;\r\nbegin\r\n Result := inherited IsImageIndexLinked and (FClient is TJvCustomComboEdit) and\r\n ((FClient as TJvCustomComboEdit).ClickKey = (Action as TCustomAction).ShortCut);\r\nend;\r\n\r\nprocedure TJvCustomComboEditActionLink.SetHint(const Value: THintString);\r\nbegin\r\n if IsHintLinked then\r\n (FClient as TJvCustomComboEdit).ButtonHint := Value;\r\nend;\r\n\r\nprocedure TJvCustomComboEditActionLink.SetImageIndex(Value: Integer);\r\nbegin\r\n if IsImageIndexLinked then\r\n (FClient as TJvCustomComboEdit).ImageIndex := Value;\r\nend;\r\n\r\nprocedure TJvCustomComboEditActionLink.SetOnExecute(Value: TNotifyEvent);\r\nbegin\r\n if IsOnExecuteLinked then\r\n (FClient as TJvCustomComboEdit).OnButtonClick := Value;\r\nend;\r\n\r\nprocedure TJvCustomComboEditActionLink.SetShortCut(Value: TShortCut);\r\nbegin\r\n if IsShortCutLinked then\r\n (FClient as TJvCustomComboEdit).ClickKey := Value;\r\nend;\r\n\r\n//=== { TJvCustomDateEditDataConnector } =====================================\r\n\r\nprocedure TJvCustomDateEditDataConnector.Assign(Source: TPersistent);\r\nbegin\r\n inherited Assign(Source);\r\n if Source is TJvCustomDateEditDataConnector then\r\n begin\r\n FDefaultDate := TJvCustomDateEditDataConnector(Source).FDefaultDate;\r\n FDefaultDateIsNow := TJvCustomDateEditDataConnector(Source).DefaultDateIsNow;\r\n end;\r\nend;\r\n\r\nfunction TJvCustomDateEditDataConnector.IsDefaultDateStored: Boolean;\r\nbegin\r\n Result := FDefaultDate <> 0;\r\nend;\r\n\r\nprocedure TJvCustomDateEditDataConnector.RecordChanged;\r\nbegin\r\n if Field.IsValid then\r\n begin\r\n Control.ReadOnly := not Field.CanModify;\r\n TJvCustomDateEdit(Control).Date := Field.AsDateTime;\r\n end\r\n else\r\n inherited RecordChanged;\r\nend;\r\n\r\nprocedure TJvCustomDateEditDataConnector.SetDefaultDateIsNow(const Value: Boolean);\r\nbegin\r\n if Value <> FDefaultDateIsNow then\r\n FDefaultDateIsNow := Value;\r\nend;\r\n\r\nprocedure TJvCustomDateEditDataConnector.UpdateData;\r\nbegin\r\n if TJvCustomDateEdit(Control).Date = 0 then\r\n begin\r\n if DefaultDateIsNow then\r\n Field.AsDateTime := Now\r\n else\r\n if NullDate <> 0 then\r\n Field.AsDateTime := DefaultDate\r\n else\r\n Field.Clear;\r\n end\r\n else\r\n Field.AsDateTime := TJvCustomDateEdit(Control).Date;\r\n TJvCustomDateEdit(Control).Date := Field.AsDateTime; // update\r\nend;\r\n\r\n//=== { TJvCustomDateEdit } ==================================================\r\n\r\nconstructor TJvCustomDateEdit.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FDateAutoBetween := True;\r\n FMinDate := NullDate;\r\n FMaxDate := NullDate;\r\n\r\n FCheckOnExit := False;\r\n FBlanksChar := ' ';\r\n FTitle := RsDateDlgCaption;\r\n FPopupColor := clMenu;\r\n // FDefNumGlyphs := 2;\r\n FStartOfWeek := Mon;\r\n FWeekends := [Sun];\r\n FWeekendColor := clRed;\r\n FYearDigits := dyDefault;\r\n FCalendarHints := TStringList.Create;\r\n FCalendarHints.OnChange := CalendarHintsChanged;\r\n DateHook.Add;\r\n FCustomDateFormat := GetDefaultDateFormat;\r\n FDateFormatPreferred := GetDefaultDateFormatPreferred;\r\n\r\n ControlState := ControlState + [csCreating];\r\n try\r\n UpdateFormat;\r\n {$IFDEF DEFAULT_POPUP_CALENDAR}\r\n FPopup := TJvPopupWindow(CreatePopupCalendar(Self, BiDiMode, FMinDate, FMaxDate));\r\n TJvPopupWindow(FPopup).OnCloseUp := PopupCloseUp;\r\n TJvPopupWindow(FPopup).Color := FPopupColor;\r\n {$ENDIF DEFAULT_POPUP_CALENDAR}\r\n ImageKind := ikDefault; { force update }\r\n finally\r\n ControlState := ControlState - [csCreating];\r\n end;\r\nend;\r\n\r\ndestructor TJvCustomDateEdit.Destroy;\r\nbegin\r\n DateHook.Delete;\r\n\r\n if FPopup is TJvPopupWindow then\r\n begin\r\n TJvPopupWindow(FPopup).OnCloseUp := nil;\r\n FPopup.Parent := nil;\r\n end;\r\n FPopup.Free;\r\n FPopup := nil;\r\n FCalendarHints.OnChange := nil;\r\n FCalendarHints.Free;\r\n FCalendarHints := nil;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJvCustomDateEdit.DisplayNullDateAsEmptyText: Boolean;\r\nbegin\r\n Result := not ShowNullDate;\r\nend;\r\n\r\nfunction TJvCustomDateEdit.CreateDataConnector: TJvCustomComboEditDataConnector;\r\nbegin\r\n Result := TJvCustomDateEditDataConnector.Create(Self);\r\nend;\r\n\r\nfunction TJvCustomDateEdit.AcceptPopup(var Value: Variant): Boolean;\r\nvar\r\n D: TDateTime;\r\nbegin\r\n Result := True;\r\n if Assigned(FOnAcceptDate) then\r\n begin\r\n if VarIsNullEmpty(Value) then\r\n D := NullDate\r\n else\r\n try\r\n D := VarToDateTime(Value);\r\n except\r\n if DefaultToday then\r\n D := SysUtils.Date\r\n else\r\n D := NullDate;\r\n end;\r\n FOnAcceptDate(Self, D, Result);\r\n if Result then\r\n Value := VarFromDateTime(D);\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomDateEdit.AcceptValue(const Value: Variant);\r\nbegin\r\n SetDate(VarToDateTime(Value));\r\n UpdatePopupVisible;\r\n if Modified then\r\n inherited Change;\r\n if Assigned(FOnPopupValueAccepted) then\r\n FOnPopupValueAccepted(Self);\r\nend;\r\n\r\nprocedure TJvCustomDateEdit.ApplyDate(Value: TDateTime);\r\nbegin\r\n SetDate(Value);\r\n SelectAll;\r\nend;\r\n\r\nprocedure TJvCustomDateEdit.CalendarHintsChanged(Sender: TObject);\r\nbegin\r\n FCalendarHints.OnChange := nil;\r\n try\r\n while CalendarHints.Count > 4 do\r\n CalendarHints.Delete(CalendarHints.Count - 1);\r\n finally\r\n FCalendarHints.OnChange := CalendarHintsChanged;\r\n end;\r\n if not (csDesigning in ComponentState) then\r\n UpdatePopup;\r\nend;\r\n\r\nprocedure TJvCustomDateEdit.Change;\r\nbegin\r\n if not FFormatting then\r\n inherited Change;\r\nend;\r\n\r\nprocedure TJvCustomDateEdit.CheckValidDate;\r\nvar\r\n ADate: TDateTime;\r\nbegin\r\n if TextStored then\r\n try\r\n FFormatting := True;\r\n try\r\n SetDate(StrToDateFmt(FDateFormat, Text));\r\n finally\r\n FFormatting := False;\r\n end;\r\n except\r\n if FDateFormat2 <> '' then\r\n try\r\n FFormatting := True;\r\n try\r\n SetDate(StrToDateFmt(FDateFormat2, Text));\r\n finally\r\n FFormatting := False;\r\n end;\r\n except\r\n if CanFocus then\r\n SetFocus;\r\n ADate := Self.Date;\r\n if DoInvalidDate(Text,ADate) then\r\n Self.Date := ADate\r\n else\r\n raise;\r\n end\r\n else\r\n begin\r\n if CanFocus then\r\n SetFocus;\r\n ADate := Self.Date;\r\n if DoInvalidDate(Text,ADate) then\r\n Self.Date := ADate\r\n else\r\n raise;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomDateEdit.CreateWindowHandle(const Params: TCreateParams);\r\nbegin\r\n inherited CreateWindowHandle(Params);\r\n if Handle <> 0 then\r\n UpdateMask;\r\nend;\r\n\r\nclass function TJvCustomDateEdit.DefaultImageIndex: TImageIndex;\r\nvar\r\n Bmp: TBitmap;\r\nbegin\r\n if GDateImageIndex < 0 then\r\n begin\r\n Bmp := TBitmap.Create;\r\n try\r\n Bmp.LoadFromResourceName(HInstance, sDateBmp);\r\n GDateImageIndex := DefaultImages.AddMasked(Bmp, clFuchsia);\r\n finally\r\n Bmp.Free;\r\n end;\r\n end;\r\n\r\n Result := GDateImageIndex;\r\nend;\r\n\r\nprocedure TJvCustomDateEdit.DoExit;\r\nbegin\r\n if not (csDesigning in ComponentState) and CheckOnExit then\r\n CheckValidDate;\r\n inherited DoExit;\r\nend;\r\n\r\nfunction TJvCustomDateEdit.DoInvalidDate(const DateString: string; var ANewDate: TDateTime): Boolean;\r\nbegin\r\n Result := False;\r\n if Assigned(FOnInvalidDate) then\r\n FOnInvalidDate(Self, DateString, ANewDate, Result);\r\nend;\r\n\r\nfunction TJvCustomDateEdit.FourDigitYear: Boolean;\r\nbegin\r\n Result := (FYearDigits = dyFour) or ((FYearDigits = dyDefault) and IsFourDigitYear);\r\nend;\r\n\r\nfunction TJvCustomDateEdit.GetCalendarHints: TStrings;\r\nbegin\r\n Result := FCalendarHints;\r\nend;\r\n\r\nfunction TJvCustomDateEdit.GetCalendarStyle: TCalendarStyle;\r\nbegin\r\n if FPopup <> nil then\r\n Result := csPopup\r\n else\r\n Result := csDialog;\r\nend;\r\n\r\nfunction TJvCustomDateEdit.GetDate: TDateTime;\r\nbegin\r\n if DefaultToday then\r\n Result := SysUtils.Date\r\n else\r\n Result := NullDate;\r\n Result := StrToDateFmtDef(FDateFormat, Text, Result);\r\nend;\r\n\r\nfunction TJvCustomDateEdit.GetDateFormat: string;\r\nbegin\r\n Result := FDateFormat;\r\nend;\r\n\r\nfunction TJvCustomDateEdit.GetDateMask: string;\r\nbegin\r\n Result := DefDateMask(FBlanksChar, FourDigitYear);\r\nend;\r\n\r\nfunction TJvCustomDateEdit.GetDialogTitle: string;\r\nbegin\r\n Result := FTitle;\r\nend;\r\n\r\nfunction TJvCustomDateEdit.GetPopupColor: TColor;\r\nbegin\r\n if FPopup is TJvPopupWindow then\r\n Result := TJvPopupWindow(FPopup).Color\r\n else\r\n Result := FPopupColor;\r\nend;\r\n\r\nfunction TJvCustomDateEdit.IsCustomTitle: Boolean;\r\nbegin\r\n Result := (AnsiCompareStr(RsDateDlgCaption, DialogTitle) <> 0) and (DialogTitle <> '');\r\nend;\r\n\r\nfunction TJvCustomDateEdit.IsDateStored: Boolean;\r\nbegin\r\n Result := not DefaultToday;\r\nend;\r\n\r\nprocedure TJvCustomDateEdit.KeyDown(var Key: Word; Shift: TShiftState);\r\nbegin\r\n if not ReadOnly then\r\n begin\r\n if IsInWordArray(Key, [VK_PRIOR, VK_NEXT, VK_LEFT, VK_UP, VK_RIGHT, VK_DOWN,\r\n VK_ADD, VK_SUBTRACT, VK_RETURN]) and PopupVisible then\r\n begin\r\n if FPopup is TJvPopupWindow then\r\n TJvPopupWindow(FPopup).KeyDown(Key, Shift);\r\n Key := 0;\r\n end\r\n else\r\n if (Shift = []) and DirectInput then\r\n begin\r\n case Key of\r\n VK_ADD:\r\n begin\r\n ApplyDate(NvlDate(Date, Now) + 1);\r\n Key := 0;\r\n end;\r\n VK_SUBTRACT:\r\n begin\r\n ApplyDate(NvlDate(Date, Now) - 1);\r\n Key := 0;\r\n end;\r\n end;\r\n end;\r\n end;\r\n inherited KeyDown(Key, Shift);\r\nend;\r\n\r\nprocedure TJvCustomDateEdit.KeyPress(var Key: Char);\r\nbegin\r\n if not ReadOnly then\r\n begin\r\n if CharInSet(Key, ['T', 't', '+', '-']) and PopupVisible then\r\n begin\r\n if FPopup is TJvPopupWindow then\r\n TJvPopupWindow(FPopup).KeyPress(Key);\r\n Key := #0;\r\n end\r\n else\r\n if DirectInput then\r\n case Key of\r\n 'T', 't':\r\n begin\r\n ApplyDate(Trunc(Now));\r\n Key := #0;\r\n end;\r\n '+', '-':\r\n Key := #0;\r\n end;\r\n end;\r\n inherited KeyPress(Key);\r\nend;\r\n\r\nprocedure TJvCustomDateEdit.PopupDropDown(DisableEdit: Boolean);\r\nvar\r\n D: TDateTime;\r\n Action: Boolean;\r\nbegin\r\n if CalendarStyle = csDialog then\r\n begin\r\n D := Self.Date;\r\n Action := SelectDate(Self, D, DialogTitle, StartOfWeek, Weekends,\r\n WeekendColor, CalendarHints, MinDate, MaxDate);\r\n if CanFocus then\r\n SetFocus;\r\n if Action then\r\n begin\r\n if Assigned(FOnAcceptDate) then\r\n FOnAcceptDate(Self, D, Action);\r\n if Action then\r\n begin\r\n Self.Date := D;\r\n if FFocused then\r\n inherited SelectAll;\r\n end;\r\n end;\r\n end\r\n else\r\n inherited PopupDropDown(DisableEdit);\r\nend;\r\n\r\nprocedure TJvCustomDateEdit.SetParent(AParent: TWinControl);\r\nbegin\r\n // This is here to help debugging parenting issues such as Mantis 3042\r\n inherited SetParent(AParent);\r\nend;\r\n\r\nprocedure TJvCustomDateEdit.SetBlanksChar(Value: Char);\r\nbegin\r\n if Value <> FBlanksChar then\r\n begin\r\n if Value < ' ' then\r\n Value := ' ';\r\n FBlanksChar := Value;\r\n UpdateMask;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomDateEdit.SetCalendarHints(Value: TStrings);\r\nbegin\r\n FCalendarHints.Assign(Value);\r\nend;\r\n\r\nprocedure TJvCustomDateEdit.SetCalendarStyle(Value: TCalendarStyle);\r\nbegin\r\n if Value <> CalendarStyle then\r\n case Value of\r\n csPopup:\r\n begin\r\n if FPopup = nil then\r\n FPopup := TJvPopupWindow(CreatePopupCalendar(Self, BiDiMode,\r\n FMinDate, FMaxDate));\r\n TJvPopupWindow(FPopup).OnCloseUp := PopupCloseUp;\r\n TJvPopupWindow(FPopup).Color := FPopupColor;\r\n UpdatePopup;\r\n end;\r\n csDialog:\r\n FreeAndNil(FPopup);\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomDateEdit.SetDate(Value: TDateTime);\r\nvar\r\n D: TDateTime;\r\n SavedModified: Boolean;\r\nbegin\r\n if not ValidDate(Value) or (Value = NullDate) then\r\n if DefaultToday then\r\n Value := SysUtils.Date\r\n else\r\n Value := NullDate;\r\n D := Self.Date;\r\n SavedModified := Modified;\r\n TestDateBetween(Value);\r\n if (Value = NullDate) and DisplayNullDateAsEmptyText then\r\n Text := ''\r\n else\r\n Text := FormatDateTime(FDateFormat, Value);\r\n Modified := SavedModified or (D <> Self.Date);\r\nend;\r\n\r\nprocedure TJvCustomDateEdit.SetDateAutoBetween(Value: Boolean);\r\nvar\r\n D: TDateTime;\r\nbegin\r\n if Value <> FDateAutoBetween then\r\n begin\r\n FDateAutoBetween := Value;\r\n if Value then\r\n begin\r\n D := Date;\r\n TestDateBetween(D);\r\n if D <> Date then\r\n Date := D;\r\n end;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomDateEdit.SetDialogTitle(const Value: string);\r\nbegin\r\n FTitle := Value;\r\nend;\r\n\r\nprocedure TJvCustomDateEdit.SetMaxDate(Value: TDateTime);\r\nbegin\r\n if Value <> FMaxDate then\r\n begin\r\n //Check unacceptable MaxDate < MinDate\r\n if (Value <> NullDate) and (FMinDate <> NullDate) and (Value < FMinDate) then\r\n if FDateAutoBetween then\r\n SetMinDate(Value)\r\n else\r\n raise EJVCLException.CreateResFmt(@RsEDateMaxLimit, [DateToStr(FMinDate)]);\r\n FMaxDate := Value;\r\n UpdatePopup;\r\n if FDateAutoBetween then\r\n SetDate(Date);\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomDateEdit.SetMinDate(Value: TDateTime);\r\nbegin\r\n if Value <> FMinDate then\r\n begin\r\n //!!!!! Necessarily check\r\n\r\n // Check unacceptable MinDate > MaxDate [Translated]\r\n if (Value <> NullDate) and (FMaxDate <> NullDate) and (Value > FMaxDate) then\r\n if FDateAutoBetween then\r\n SetMaxDate(Value)\r\n else\r\n raise EJVCLException.CreateResFmt(@RsEDateMinLimit, [DateToStr(FMaxDate)]);\r\n FMinDate := Value;\r\n UpdatePopup;\r\n if FDateAutoBetween then\r\n SetDate(Date);\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomDateEdit.SetPopupColor(Value: TColor);\r\nbegin\r\n if Value <> PopupColor then\r\n begin\r\n if FPopup is TJvPopupWindow then\r\n TJvPopupWindow(FPopup).Color := Value;\r\n FPopupColor := Value;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomDateEdit.SetPopupValue(const Value: Variant);\r\nbegin\r\n inherited SetPopupValue(StrToDateFmtDef(FDateFormat, VarToStr(Value), SysUtils.Date));\r\nend;\r\n\r\nprocedure TJvCustomDateEdit.SetShowNullDate(const Value: Boolean);\r\nbegin\r\n if FShowNullDate <> Value then\r\n begin\r\n FShowNullDate := Value;\r\n SetDate(Date);\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomDateEdit.SetStartOfWeek(Value: TDayOfWeekName);\r\nbegin\r\n if Value <> FStartOfWeek then\r\n begin\r\n FStartOfWeek := Value;\r\n UpdatePopup;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomDateEdit.SetWeekendColor(Value: TColor);\r\nbegin\r\n if Value <> FWeekendColor then\r\n begin\r\n FWeekendColor := Value;\r\n UpdatePopup;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomDateEdit.SetWeekends(Value: TDaysOfWeek);\r\nbegin\r\n if Value <> FWeekends then\r\n begin\r\n FWeekends := Value;\r\n UpdatePopup;\r\n end;\r\nend;\r\n\r\nfunction TJvCustomDateEdit.GetDefaultDateFormat: string;\r\nbegin\r\n Result := '';\r\nend;\r\n\r\nfunction TJvCustomDateEdit.IsDateFormatStored: Boolean;\r\nbegin\r\n Result := (FCustomDateFormat <> GetDefaultDateFormat);\r\nend;\r\n\r\nfunction TJvCustomDateEdit.GetDefaultDateFormatPreferred: TPreferredDateFormat;\r\nbegin\r\n Result := pdLocaleOnly;\r\nend;\r\n\r\nfunction TJvCustomDateEdit.IsDateFormatPreferredStored: Boolean;\r\nbegin\r\n Result := (FDateFormatPreferred <> GetDefaultDateFormatPreferred);\r\nend;\r\n\r\nprocedure TJvCustomDateEdit.SetDateFormatPreferred(Value: TPreferredDateFormat);\r\nbegin\r\n if FDateFormatPreferred <> Value then\r\n begin\r\n FDateFormatPreferred := Value;\r\n if not (csLoading in ComponentState) then\r\n UpdateMask;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomDateEdit.SetCustomDateFormat(const Value: string);\r\nbegin\r\n if FCustomDateFormat <> Value then\r\n begin\r\n FCustomDateFormat := Value;\r\n if not (csLoading in ComponentState) then\r\n begin\r\n if FDateFormatPreferred in [pdCustom, pdCustomOnly] then\r\n UpdateMask\r\n else\r\n UpdateFormat;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomDateEdit.SetYearDigits(Value: TYearDigits);\r\nbegin\r\n if FYearDigits <> Value then\r\n begin\r\n FYearDigits := Value;\r\n UpdateMask;\r\n end;\r\nend;\r\n\r\nfunction TJvCustomDateEdit.StoreMaxDate: Boolean;\r\nbegin\r\n Result := FMaxDate <> NullDate;\r\nend;\r\n\r\nfunction TJvCustomDateEdit.StoreMinDate: Boolean;\r\nbegin\r\n Result := FMinDate <> NullDate;\r\nend;\r\n\r\nprocedure TJvCustomDateEdit.TestDateBetween(var Value: TDateTime);\r\nbegin\r\n if FDateAutoBetween then\r\n begin\r\n if (FMinDate <> NullDate) and (Value <> NullDate) and (Value < FMinDate) then\r\n Value := FMinDate;\r\n if (FMaxDate <> NullDate) and (Value <> NullDate) and (Value > FMaxDate) then\r\n Value := FMaxDate;\r\n end;\r\nend;\r\n\r\nfunction TJvCustomDateEdit.TextStored: Boolean;\r\nbegin\r\n Result := not IsEmptyStr(Text, [#0, ' ', JclFormatSettings.DateSeparator, FBlanksChar]);\r\nend;\r\n\r\nprocedure TJvCustomDateEdit.UpdateFormat;\r\nbegin\r\n if (FDateFormatPreferred in [pdLocale, pdLocaleOnly]) or (FCustomDateFormat = '') then\r\n begin\r\n FDateFormat := DefDateFormat(FourDigitYear);\r\n if FDateFormatPreferred = pdLocale then\r\n FDateFormat2 := FCustomDateFormat\r\n else\r\n FDateFormat2 := '';\r\n end\r\n else\r\n begin\r\n FDateFormat := FCustomDateFormat;\r\n if FDateFormatPreferred = pdCustom then\r\n FDateFormat2 := DefDateFormat(FourDigitYear)\r\n else\r\n FDateFormat2 := '';\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomDateEdit.UpdateMask;\r\nvar\r\n DateValue: TDateTime;\r\n OldFormat: string;\r\nbegin\r\n DateValue := GetDate;\r\n OldFormat := FDateFormat;\r\n UpdateFormat;\r\n if (GetDateMask <> EditMask) or (OldFormat <> FDateFormat) then\r\n begin\r\n { force update }\r\n EditMask := '';\r\n EditMask := GetDateMask;\r\n end;\r\n UpdatePopup;\r\n SetDate(DateValue);\r\nend;\r\n\r\nprocedure TJvCustomDateEdit.UpdatePopup;\r\nbegin\r\n if FPopup <> nil then\r\n SetupPopupCalendar(FPopup, StartOfWeek, Weekends, WeekendColor,\r\n CalendarHints, FourDigitYear, MinDate, MaxDate);\r\nend;\r\n\r\nprocedure TJvCustomDateEdit.ValidateEdit;\r\nbegin\r\n if TextStored and CheckOnExit then\r\n CheckValidDate;\r\nend;\r\n\r\nprocedure TJvCustomDateEdit.WMContextMenu(var Msg: TWMContextMenu);\r\nbegin\r\n if not PopupVisible then\r\n inherited;\r\nend;\r\n\r\n//=== { TJvDateEdit } ========================================================\r\n\r\n// (rom) unusual not to have it implemented in the Custom base class\r\n\r\nconstructor TJvDateEdit.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n UpdateMask;\r\nend;\r\n\r\nprocedure TJvDateEdit.SetDate(Value: TDateTime);\r\nbegin\r\n if not FDateAutoBetween then\r\n if Value <> NullDate then\r\n begin\r\n if ((FMinDate <> NullDate) and (FMaxDate <> NullDate) and\r\n ((Value < FMinDate) or (Value > FMaxDate))) then\r\n raise EJVCLException.CreateResFmt(@RsEDateOutOfRange, [FormatDateTime(FDateFormat, Value),\r\n FormatDateTime(FDateFormat, FMinDate), FormatDateTime(FDateFormat, FMaxDate)])\r\n else\r\n if (FMinDate <> NullDate) and (Value < FMinDate) then\r\n raise EJVCLException.CreateResFmt(@RsEDateOutOfMin, [FormatDateTime(FDateFormat, Value),\r\n FormatDateTime(FDateFormat, FMinDate)])\r\n else\r\n if (FMaxDate <> NullDate) and (Value > FMaxDate) then\r\n raise EJVCLException.CreateResFmt(@RsEDateOutOfMax, [FormatDateTime(FDateFormat, Value),\r\n FormatDateTime(FDateFormat, FMaxDate)]);\r\n end;\r\n inherited SetDate(Value);\r\nend;\r\n\r\n//=== { TJvDirectoryEdit } ===================================================\r\n\r\nconstructor TJvDirectoryEdit.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FOptions := [sdAllowCreate];\r\n FOptionsWin32 := DefaultJvBrowseFolderDialogOptions;\r\n FAutoCompleteFileOptions := [acfFileSystem, acfFileSysDirs];\r\n FDialogKind := dkWin32;\r\nend;\r\n\r\nclass function TJvDirectoryEdit.DefaultImageIndex: TImageIndex;\r\nvar\r\n Bmp: TBitmap;\r\nbegin\r\n {$IFDEF JVCLThemesEnabled}\r\n if ThemeServices.{$IFDEF RTL230_UP}Enabled{$ELSE}ThemesEnabled{$ENDIF RTL230_UP} then\r\n begin\r\n if GDirImageIndexXP < 0 then\r\n begin\r\n Bmp := TBitmap.Create;\r\n try\r\n Bmp.LoadFromResourceName(HInstance, sDirXPBmp);\r\n GDirImageIndexXP := DefaultImages.AddMasked(Bmp, clFuchsia);\r\n finally\r\n Bmp.Free;\r\n end;\r\n end;\r\n Result := GDirImageIndexXP;\r\n Exit;\r\n end;\r\n {$ENDIF JVCLThemesEnabled}\r\n\r\n if GDirImageIndex < 0 then\r\n begin\r\n Bmp := TBitmap.Create;\r\n try\r\n Bmp.LoadFromResourceName(HInstance, sDirBmp);\r\n GDirImageIndex := DefaultImages.AddMasked(Bmp, clFuchsia);\r\n finally\r\n Bmp.Free;\r\n end;\r\n end;\r\n Result := GDirImageIndex;\r\nend;\r\n\r\nfunction TJvDirectoryEdit.GetLongName: string;\r\nvar\r\n Txt, Temp: string;\r\n Pos: Integer;\r\nbegin\r\n Txt := Directory;\r\n if not MultipleDirs then\r\n Result := ShortToLongPath(Txt)\r\n else\r\n begin\r\n Result := '';\r\n Pos := 1;\r\n while Pos <= Length(Txt) do\r\n begin\r\n Temp := ShortToLongPath(ExtractSubstr(Txt, Pos, [PathSep]));\r\n if (Result <> '') and (Temp <> '') then\r\n Result := Result + PathSep;\r\n Result := Result + Temp;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJvDirectoryEdit.GetShortName: string;\r\nvar\r\n Txt, Temp: string;\r\n Pos: Integer;\r\nbegin\r\n Txt := Directory;\r\n if not MultipleDirs then\r\n Result := LongToShortPath(Txt)\r\n else\r\n begin\r\n Result := '';\r\n Pos := 1;\r\n while Pos <= Length(Txt) do\r\n begin\r\n Temp := LongToShortPath(ExtractSubstr(Txt, Pos, [PathSep]));\r\n if (Result <> '') and (Temp <> '') then\r\n Result := Result + PathSep;\r\n Result := Result + Temp;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJvDirectoryEdit.GetLocalizedName: string;\r\nvar\r\n Txt, Temp: string;\r\n Pos: Integer;\r\nbegin\r\n Txt := Directory;\r\n if not MultipleDirs then\r\n Result := PathGetLocalizedPath(Txt)\r\n else\r\n begin\r\n Result := '';\r\n Pos := 1;\r\n while Pos <= Length(Txt) do\r\n begin\r\n Temp := PathGetLocalizedPath(ExtractSubstr(Txt, Pos, [PathSep]));\r\n if (Result <> '') and (Temp <> '') then\r\n Result := Result + PathSep;\r\n Result := Result + Temp;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvDirectoryEdit.DoEnter;\r\nbegin\r\n Text := FPhysicalDirectory;\r\n inherited DoEnter;\r\nend;\r\n\r\nprocedure TJvDirectoryEdit.DoExit;\r\nvar\r\n Txt: string;\r\nbegin\r\n inherited DoExit;\r\n if DisplayLocalizedName then\r\n begin\r\n Txt := Text;\r\n Text := LocalizedName;\r\n FPhysicalDirectory := Txt; // by using \"Text:=\" the WM_SETTEXT handler changes the PhysicalDirectory\r\n end;\r\nend;\r\n\r\nprocedure TJvDirectoryEdit.WndProc(var Msg: TMessage);\r\nbegin\r\n inherited WndProc(Msg);\r\n if Msg.Msg = WM_SETTEXT then\r\n FPhysicalDirectory := Text;\r\nend;\r\n\r\nprocedure TJvDirectoryEdit.Change;\r\nbegin\r\n inherited Change;\r\n FPhysicalDirectory := Text;\r\nend;\r\n\r\nprocedure TJvDirectoryEdit.SetDirectory(const Value: string);\r\nbegin\r\n if not FDisplayLocalizedName or Focused then\r\n Text := Value\r\n else\r\n begin\r\n FPhysicalDirectory := Value; // is used in GetLocalizedName\r\n Text := LocalizedName;\r\n end;\r\n FPhysicalDirectory := Value; // must be set after \"Text:=\"\r\nend;\r\n\r\nfunction TJvDirectoryEdit.GetDirectory: string;\r\nbegin\r\n if not FDisplayLocalizedName or Focused then\r\n Result := Text\r\n else\r\n Result := FPhysicalDirectory;\r\nend;\r\n\r\nprocedure TJvDirectoryEdit.SetDisplayLocalizedName(const Value: Boolean);\r\nvar\r\n Txt: string;\r\nbegin\r\n if Value <> FDisplayLocalizedName then\r\n begin\r\n if FDisplayLocalizedName and not Focused then\r\n Text := FPhysicalDirectory;\r\n\r\n FDisplayLocalizedName := Value;\r\n\r\n if FDisplayLocalizedName and not Focused then\r\n begin\r\n Txt := Text;\r\n Text := LocalizedName;\r\n FPhysicalDirectory := Txt; // must be set after \"Text:=\"\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvDirectoryEdit.PopupDropDown(DisableEdit: Boolean);\r\nvar\r\n Temp, Txt: string;\r\n Action: Boolean;\r\n BrowseForFolder: TJvBrowseForFolderDialog;\r\nbegin\r\n Temp := Directory;\r\n Action := True;\r\n DoBeforeDialog(Temp, Action);\r\n if not Action then\r\n Exit;\r\n if Temp = '' then\r\n begin\r\n if InitialDir <> '' then\r\n Temp := InitialDir\r\n else\r\n Temp := PathDelim;\r\n end;\r\n\r\n if not DirectoryExists(Temp) then\r\n Temp := PathDelim;\r\n\r\n case DialogKind of\r\n dkVCL:\r\n begin\r\n DisableSysErrors;\r\n try\r\n Action := SelectDirectory(Temp, FOptions, Self.HelpContext);\r\n finally\r\n EnableSysErrors;\r\n end;\r\n end;\r\n dkWin32:\r\n begin\r\n BrowseForFolder := TJvBrowseForFolderDialog.Create(Self);\r\n try\r\n BrowseForFolder.Options := DialogOptionsWin32;\r\n BrowseForFolder.Directory := Temp;\r\n BrowseForFolder.StatusText := DialogText;\r\n Action := BrowseForFolder.Execute;\r\n Temp := BrowseForFolder.Directory;\r\n finally\r\n BrowseForFolder.Free;\r\n end;\r\n end;\r\n end;\r\n\r\n if CanFocus then\r\n SetFocus;\r\n DoAfterDialog(Temp, Action);\r\n if Action then\r\n begin\r\n SelText := '';\r\n if (Text = '') or not MultipleDirs then\r\n Txt := Temp\r\n else\r\n Txt := Directory + PathSep + Temp;\r\n Text := Txt;\r\n FPhysicalDirectory := Txt; // Must be set after \"Text:=\"\r\n if (Temp <> '') and DirectoryExists(Temp) then\r\n InitialDir := Temp;\r\n end;\r\nend;\r\n\r\nprocedure TJvDirectoryEdit.ReceptFileDir(const AFileName: string);\r\nvar\r\n Temp: string;\r\nbegin\r\n if FileExists(AFileName) then\r\n Temp := StrEnsureNoSuffix(PathDelim, ExtractFilePath(AFileName))\r\n else\r\n Temp := StrEnsureNoSuffix(PathDelim, AFileName);\r\n if (Text = '') or not MultipleDirs then\r\n Text := Temp\r\n else\r\n Text := Text + PathSep + Temp;\r\nend;\r\n\r\n//=== { TJvEditButton } ======================================================\r\n\r\nconstructor TJvEditButton.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FStandard := True;\r\n ControlStyle := ControlStyle + [csReplicatable];\r\n ParentShowHint := True;\r\nend;\r\n\r\nprocedure TJvEditButton.Click;\r\nbegin\r\n if not FNoAction then\r\n inherited Click\r\n else\r\n FNoAction := False;\r\nend;\r\n\r\nfunction TJvEditButton.GetGlyph: TBitmap;\r\nbegin\r\n Result := ButtonGlyph.Glyph;\r\nend;\r\n\r\nfunction TJvEditButton.GetNumGlyphs: TJvNumGlyphs;\r\nbegin\r\n Result := ButtonGlyph.NumGlyphs;\r\nend;\r\n\r\nfunction TJvEditButton.GetUseGlyph: Boolean;\r\nbegin\r\n Result := not Assigned(Images) or (ImageIndex < 0);\r\nend;\r\n\r\nprocedure TJvEditButton.MouseDown(Button: TMouseButton; Shift: TShiftState;\r\n X, Y: Integer);\r\nbegin\r\n inherited MouseDown(Button, Shift, X, Y);\r\n if (Button = mbLeft) and (Owner <> nil) then\r\n with TJvCustomComboEdit(Owner) do\r\n begin\r\n FNoAction := (FPopup <> nil) and FPopupVisible;\r\n if not FPopupVisible then\r\n begin\r\n if TabStop and CanFocus and (GetFocus <> Handle) then\r\n SetFocus;\r\n end\r\n else\r\n PopupCloseUp(FPopup, FStandard);\r\n end;\r\nend;\r\n\r\nprocedure TJvEditButton.Paint;\r\n{$IFDEF JVCLThemesEnabled}\r\nvar\r\n ThemedState: TThemedComboBox;\r\n Details: TThemedElementDetails;\r\n R: TRect;\r\n{$ENDIF JVCLThemesEnabled}\r\nbegin\r\n {$IFDEF JVCLThemesEnabled}\r\n if ThemeServices.{$IFDEF RTL230_UP}Enabled{$ELSE}ThemesEnabled{$ENDIF RTL230_UP} then\r\n begin\r\n if FDrawThemedDropDownBtn then\r\n begin\r\n if not Enabled then\r\n ThemedState := tcDropDownButtonDisabled\r\n else\r\n if FState in [rbsDown, rbsExclusive] then\r\n ThemedState := tcDropDownButtonPressed\r\n else\r\n if MouseOver or IsDragging then\r\n ThemedState := tcDropDownButtonHot\r\n else\r\n ThemedState := tcDropDownButtonNormal;\r\n R := ClientRect;\r\n Details := ThemeServices.GetElementDetails(ThemedState);\r\n ThemeServices.DrawElement(Canvas.Handle, Details, R);\r\n end\r\n else\r\n inherited Paint;\r\n end\r\n else\r\n {$ENDIF JVCLThemesEnabled}\r\n begin\r\n inherited Paint;\r\n if FState <> rbsDown then\r\n with Canvas do\r\n begin\r\n Pen.Color := clBtnFace;\r\n MoveTo(0, 0);\r\n LineTo(0, Self.Height - 1);\r\n Pen.Color := clBtnHighlight;\r\n MoveTo(1, 1);\r\n LineTo(1, Self.Height - 2);\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvEditButton.PaintImage(Canvas: TCanvas; ARect: TRect;\r\n const Offset: TPoint; AState: TJvButtonState; DrawMark: Boolean; PaintOnGlass: Boolean);\r\nbegin\r\n if UseGlyph then\r\n ButtonGlyph.Draw(Canvas, ARect, Offset, '', Layout,\r\n Margin, Spacing, False, AState, 0, PaintOnGlass)\r\n else\r\n inherited PaintImage(Canvas, ARect, Offset, AState, DrawMark, PaintOnGlass);\r\nend;\r\n\r\nprocedure TJvEditButton.SetGlyph(const Value: TBitmap);\r\nbegin\r\n ButtonGlyph.Glyph := Value;\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvEditButton.SetNumGlyphs(Value: TJvNumGlyphs);\r\nbegin\r\n if Value < 0 then\r\n Value := 1\r\n else\r\n if Value > Ord(High(TJvButtonState)) + 1 then\r\n Value := Ord(High(TJvButtonState)) + 1;\r\n if Value <> ButtonGlyph.NumGlyphs then\r\n begin\r\n ButtonGlyph.NumGlyphs := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvEditButton.WMContextMenu(var Msg: TWMContextMenu);\r\nbegin\r\n { (rb) Without this, we get 2 context menu's (1 from the form, another from\r\n the combo edit; don't know exactly what is causing this. (I guess\r\n it's related to FBtnControl being a TWinControl) }\r\n Msg.Result := 1;\r\nend;\r\n\r\n//=== { TJvFileDirEdit } =====================================================\r\n\r\nconstructor TJvFileDirEdit.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n {$IFNDEF UNICODE}\r\n OEMConvert := True;\r\n {$ENDIF ~UNICODE}\r\n FAcceptFiles := True;\r\n AlwaysEnableButton := True;\r\n AlwaysShowPopup := True;\r\n FAutoCompleteOptions := [acoAutoSuggest];\r\n ControlState := ControlState + [csCreating];\r\n try\r\n ImageKind := ikDefault; { force update }\r\n finally\r\n ControlState := ControlState - [csCreating];\r\n end;\r\nend;\r\n\r\nprocedure TJvFileDirEdit.Change;\r\nvar\r\n Ps: Integer;\r\nbegin\r\n // The control becomes confused when the Text property has a #10 or #13 in it.\r\n Ps := Pos(#10, Text);\r\n if Ps = 0 then\r\n Ps := Pos(#13, Text);\r\n if Ps > 0 then\r\n Text := Copy(Text, 1, Ps - 1)\r\n else\r\n inherited Change;\r\nend;\r\n\r\nprocedure TJvFileDirEdit.ClearFileList;\r\nbegin\r\nend;\r\n\r\n{$IFDEF JVCLThemesEnabled}\r\nprocedure TJvFileDirEdit.CMSysColorChange(var Msg: TMessage);\r\nbegin\r\n inherited;\r\n // We use this event to respond to theme changes (no WM_THEMECHANGED are broadcasted\r\n // to the components)\r\n // Note that there is a bug in TApplication.WndProc, so the application will not\r\n // change from non-themed to themed.\r\n if ImageKind = ikDefault then\r\n Button.ImageIndex := DefaultImageIndex;\r\nend;\r\n{$ENDIF JVCLThemesEnabled}\r\n\r\nprocedure TJvFileDirEdit.CreateHandle;\r\nbegin\r\n inherited CreateHandle;\r\n\r\n if FAcceptFiles then\r\n SetDragAccept(True);\r\nend;\r\n\r\nprocedure TJvFileDirEdit.DestroyWindowHandle;\r\nbegin\r\n SetDragAccept(False);\r\n inherited DestroyWindowHandle;\r\nend;\r\n\r\nprocedure TJvFileDirEdit.DisableSysErrors;\r\nbegin\r\n {$IFDEF MSWINDOWS}\r\n FErrMode := SetErrorMode(SEM_NOOPENFILEERRORBOX or SEM_FAILCRITICALERRORS);\r\n {$ENDIF MSWINDOWS}\r\nend;\r\n\r\nprocedure TJvFileDirEdit.DoAfterDialog(var FileName: string; var Action: Boolean);\r\nbegin\r\n if Assigned(FOnAfterDialog) then\r\n FOnAfterDialog(Self, FileName, Action);\r\nend;\r\n\r\nprocedure TJvFileDirEdit.DoBeforeDialog(var FileName: string; var Action: Boolean);\r\nbegin\r\n if Assigned(FOnBeforeDialog) then\r\n FOnBeforeDialog(Self, FileName, Action);\r\nend;\r\n\r\nprocedure TJvFileDirEdit.EnableSysErrors;\r\nbegin\r\n {$IFDEF MSWINDOWS}\r\n SetErrorMode(FErrMode);\r\n {$ENDIF MSWINDOWS}\r\n FErrMode := 0;\r\nend;\r\n\r\nfunction TJvFileDirEdit.GetAutoCompleteSource: IEnumString;\r\nbegin\r\n if Failed(CoCreateInstance(CLSID_ACLMulti, nil, CLSCTX_INPROC_SERVER, IEnumString, FAutoCompleteSourceIntf)) then\r\n FAutoCompleteSourceIntf := nil;\r\n Result := FAutoCompleteSourceIntf;\r\nend;\r\n\r\nprocedure TJvFileDirEdit.SetAcceptFiles(Value: Boolean);\r\nbegin\r\n if FAcceptFiles <> Value then\r\n begin\r\n SetDragAccept(Value);\r\n FAcceptFiles := Value;\r\n end;\r\nend;\r\n\r\nprocedure TJvFileDirEdit.SetAutoCompleteFileOptions(const Value: TJvAutoCompleteFileOptions);\r\nbegin\r\n if FAutoCompleteFileOptions <> Value then\r\n begin\r\n FAutoCompleteFileOptions := Value;\r\n if not (csDesigning in ComponentState) then\r\n UpdateAutoComplete;\r\n end;\r\nend;\r\n\r\nprocedure TJvFileDirEdit.SetDragAccept(Value: Boolean);\r\nbegin\r\n if not (csDesigning in ComponentState) and (Handle <> 0) then\r\n DragAcceptFiles(Handle, Value);\r\nend;\r\n\r\nprocedure TJvFileDirEdit.DestroyAutoComplete;\r\nbegin\r\n // Mantis 3112: We drop the references we get to the various interfaces\r\n // thus avoiding accesses to them triggered by the ancestor(s) destructor(s)\r\n FMRUList := nil;\r\n FHistoryList := nil;\r\n FFileSystemList:= nil;\r\n FAutoCompleteSourceIntf := nil;\r\n\r\n inherited DestroyAutoComplete;\r\nend;\r\n\r\nprocedure TJvFileDirEdit.UpdateAutoComplete;\r\nvar\r\n ObjMgr: IObjMgr;\r\n List2: IACList2;\r\n Options: DWORD;\r\nbegin\r\n if Supports(FAutoCompleteSourceIntf, IObjMgr, ObjMgr) then\r\n begin\r\n if acfURLMRU in AutoCompleteFileOptions then\r\n begin\r\n if not Assigned(FMRUList) and\r\n Succeeded(CoCreateInstance(CLSID_ACLMRU, nil, CLSCTX_INPROC_SERVER, IUnknown, FMRUList)) then\r\n begin\r\n ObjMgr.Append(FMRUList);\r\n end\r\n end\r\n else\r\n if Assigned(FMRUList) then\r\n begin\r\n ObjMgr.Remove(FMRUList);\r\n FMRUList := nil;\r\n end;\r\n\r\n if acfURLHistory in AutoCompleteFileOptions then\r\n begin\r\n if not Assigned(FHistoryList) and\r\n Succeeded(CoCreateInstance(CLSID_ACLHistory, nil, CLSCTX_INPROC_SERVER, IUnknown, FHistoryList)) then\r\n begin\r\n ObjMgr.Append(FHistoryList);\r\n end;\r\n end\r\n else\r\n if Assigned(FHistoryList) then\r\n begin\r\n ObjMgr.Remove(FHistoryList);\r\n FHistoryList := nil;\r\n end;\r\n\r\n if [acfFileSystem, acfFileSysDirs] * AutoCompleteFileOptions <> [] then\r\n begin\r\n if not Assigned(FFileSystemList) and\r\n Succeeded(CoCreateInstance(CLSID_ACListISF, nil, CLSCTX_INPROC_SERVER, IUnknown, FFileSystemList)) then\r\n begin\r\n ObjMgr.Append(FFileSystemList);\r\n end;\r\n\r\n Options := ACLO_FILESYSONLY;\r\n if acfFileSysDirs in AutoCompleteFileOptions then\r\n Options := Options or ACLO_FILESYSDIRS;\r\n\r\n if Supports(FFileSystemList, IACList2, List2) then\r\n List2.SetOptions(Options);\r\n end\r\n else\r\n if Assigned(FFileSystemList) then\r\n begin\r\n ObjMgr.Remove(FFileSystemList);\r\n FFileSystemList := nil;\r\n end;\r\n end;\r\n\r\n inherited UpdateAutoComplete;\r\nend;\r\n\r\nprocedure TJvFileDirEdit.WMDropFiles(var Msg: TWMDropFiles);\r\nvar\r\n AFileName: array [0..255] of Char;\r\n I, Num: Cardinal;\r\nbegin\r\n Msg.Result := 0;\r\n try\r\n Num := DragQueryFile(Msg.Drop, $FFFFFFFF, nil, 0);\r\n if Num > 0 then\r\n begin\r\n ClearFileList;\r\n for I := 0 to Num - 1 do\r\n begin\r\n DragQueryFile(Msg.Drop, I, PChar(@AFileName[0]), Pred(SizeOf(AFileName)));\r\n ReceptFileDir(StrPas(AFileName));\r\n if not FMultipleDirs then\r\n Break;\r\n end;\r\n if Assigned(FOnDropFiles) then\r\n FOnDropFiles(Self);\r\n end;\r\n finally\r\n DragFinish(Msg.Drop);\r\n end;\r\nend;\r\n\r\n//=== { TJvFilenameEdit } ====================================================\r\n\r\nconstructor TJvFilenameEdit.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FAddQuotes := True;\r\n FAutoCompleteFileOptions := [acfFileSystem];\r\n CreateEditDialog;\r\nend;\r\n\r\nprocedure TJvFilenameEdit.ClearFileList;\r\nbegin\r\n FDialog.Files.Clear;\r\nend;\r\n\r\nprocedure TJvFilenameEdit.CreateEditDialog;\r\nvar\r\n NewDialog: TOpenDialog;\r\nbegin\r\n case FDialogKind of\r\n dkOpen:\r\n NewDialog := TOpenDialog.Create(Self);\r\n dkOpenPicture:\r\n NewDialog := TOpenPictureDialog.Create(Self);\r\n dkSavePicture:\r\n NewDialog := TSavePictureDialog.Create(Self);\r\n else { dkSave }\r\n NewDialog := TSaveDialog.Create(Self);\r\n end;\r\n try\r\n if FDialog <> nil then\r\n begin\r\n with NewDialog do\r\n begin\r\n DefaultExt := FDialog.DefaultExt;\r\n FileEditStyle := FDialog.FileEditStyle;\r\n FileName := FDialog.FileName;\r\n Filter := FDialog.Filter;\r\n FilterIndex := FDialog.FilterIndex;\r\n InitialDir := FDialog.InitialDir;\r\n HistoryList := FDialog.HistoryList;\r\n Files.Assign(FDialog.Files);\r\n Options := FDialog.Options;\r\n Title := FDialog.Title;\r\n end;\r\n FDialog.Free;\r\n end\r\n else\r\n begin\r\n NewDialog.Title := RsBrowseCaption;\r\n NewDialog.Filter := RsDefaultFilter;\r\n NewDialog.Options := [ofHideReadOnly];\r\n end;\r\n finally\r\n FDialog := NewDialog;\r\n end;\r\nend;\r\n\r\nclass function TJvFilenameEdit.DefaultImageIndex: TImageIndex;\r\nvar\r\n Bmp: TBitmap;\r\nbegin\r\n {$IFDEF JVCLThemesEnabled}\r\n if ThemeServices.{$IFDEF RTL230_UP}Enabled{$ELSE}ThemesEnabled{$ENDIF RTL230_UP} then\r\n begin\r\n if GFileImageIndexXP < 0 then\r\n begin\r\n Bmp := TBitmap.Create;\r\n try\r\n Bmp.LoadFromResourceName(HInstance, sFileXPBmp);\r\n GFileImageIndexXP := DefaultImages.AddMasked(Bmp, clFuchsia);\r\n finally\r\n Bmp.Free;\r\n end;\r\n end;\r\n Result := GFileImageIndexXP;\r\n Exit;\r\n end;\r\n {$ENDIF JVCLThemesEnabled}\r\n\r\n if GFileImageIndex < 0 then\r\n begin\r\n Bmp := TBitmap.Create;\r\n try\r\n Bmp.LoadFromResourceName(HInstance, sFileBmp);\r\n GFileImageIndex := DefaultImages.AddMasked(Bmp, clFuchsia);\r\n finally\r\n Bmp.Free;\r\n end;\r\n end;\r\n Result := GFileImageIndex;\r\nend;\r\n\r\nfunction TJvFilenameEdit.GetDefaultExt: TFileExt;\r\nbegin\r\n Result := FDialog.DefaultExt;\r\nend;\r\n\r\nfunction TJvFilenameEdit.GetDialogFiles: TStrings;\r\nbegin\r\n Result := FDialog.Files;\r\nend;\r\n\r\nfunction TJvFilenameEdit.GetDialogTitle: string;\r\nbegin\r\n Result := FDialog.Title;\r\nend;\r\n\r\nfunction TJvFilenameEdit.GetFileEditStyle: TFileEditStyle;\r\nbegin\r\n Result := FDialog.FileEditStyle;\r\nend;\r\n\r\nfunction TJvFilenameEdit.GetFilter: string;\r\nbegin\r\n Result := FDialog.Filter;\r\nend;\r\n\r\nfunction TJvFilenameEdit.GetFilterIndex: Integer;\r\nbegin\r\n Result := FDialog.FilterIndex;\r\nend;\r\n\r\nfunction TJvFilenameEdit.GetHistoryList: TStrings;\r\nbegin\r\n Result := FDialog.HistoryList;\r\nend;\r\n\r\nfunction TJvFilenameEdit.GetInitialDir: string;\r\nbegin\r\n Result := FDialog.InitialDir;\r\nend;\r\n\r\nfunction TJvFilenameEdit.GetLongName: string;\r\nbegin\r\n Result := ShortToLongFileName(FileName);\r\nend;\r\n\r\nfunction TJvFilenameEdit.GetOptions: TOpenOptions;\r\nbegin\r\n Result := FDialog.Options;\r\nend;\r\n\r\nfunction TJvFilenameEdit.GetShortName: string;\r\nbegin\r\n Result := LongToShortFileName(FileName);\r\nend;\r\n\r\nfunction TJvFilenameEdit.GetLocalizedName: string;\r\nbegin\r\n Result := PathGetLocalizedPath(FileName);\r\nend;\r\n\r\nfunction TJvFilenameEdit.IsCustomFilter: Boolean;\r\nbegin\r\n Result := AnsiCompareStr(RsDefaultFilter, FDialog.Filter) <> 0;\r\nend;\r\n\r\nfunction TJvFilenameEdit.IsCustomTitle: Boolean;\r\nbegin\r\n Result := AnsiCompareStr(RsBrowseCaption, FDialog.Title) <> 0;\r\nend;\r\n\r\nprocedure TJvFilenameEdit.DoEnter;\r\nbegin\r\n Text := FPhysicalFileName;\r\n inherited DoEnter;\r\nend;\r\n\r\nprocedure TJvFilenameEdit.DoExit;\r\nvar\r\n Txt: string;\r\nbegin\r\n inherited DoExit;\r\n if DisplayLocalizedName then\r\n begin\r\n Txt := Text;\r\n Text := LocalizedName;\r\n FPhysicalFileName := Txt; // by using \"Text:=\" the WM_SETTEXT handler changes the PhysicalFileName\r\n end;\r\nend;\r\n\r\nprocedure TJvFilenameEdit.WndProc(var Msg: TMessage);\r\nbegin\r\n inherited WndProc(Msg);\r\n if Msg.Msg = WM_SETTEXT then\r\n FPhysicalFileName := Text;\r\nend;\r\n\r\nprocedure TJvFilenameEdit.Change;\r\nbegin\r\n inherited Change;\r\n FPhysicalFileName := Text;\r\nend;\r\n\r\nprocedure TJvFilenameEdit.SetDisplayLocalizedName(const Value: Boolean);\r\nvar\r\n Txt: string;\r\nbegin\r\n if Value <> FDisplayLocalizedName then\r\n begin\r\n if FDisplayLocalizedName and not Focused then\r\n Text := FPhysicalFileName;\r\n\r\n FDisplayLocalizedName := Value;\r\n\r\n if FDisplayLocalizedName and not Focused then\r\n begin\r\n Txt := Text;\r\n Text := LocalizedName;\r\n FPhysicalFileName := Txt; // must be set after \"Text:=\"\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvFilenameEdit.SetFileName(const Value: TFileName);\r\nvar\r\n Txt: string;\r\nbegin\r\n if (Value = '') or ValidFileName(ClipFilename(Value, AddQuotes)) then\r\n begin\r\n if AddQuotes then\r\n Txt := ExtFilename(Value)\r\n else\r\n Txt := Value;\r\n\r\n if not FDisplayLocalizedName or Focused then\r\n Text := Txt\r\n else\r\n Text := PathGetLocalizedPath(Txt);\r\n FPhysicalFileName := Txt; // must be set after \"Text:=\"\r\n\r\n ClearFileList;\r\n end\r\n else\r\n raise EComboEditError.CreateResFmt(@SInvalidFilename, [Value]);\r\nend;\r\n\r\nfunction TJvFilenameEdit.GetFileName: TFileName;\r\nbegin\r\n if not FDisplayLocalizedName or Focused then\r\n Result := ClipFilename(Text, AddQuotes)\r\n else\r\n Result := ClipFilename(FPhysicalFileName, AddQuotes);\r\nend;\r\n\r\nprocedure TJvFilenameEdit.PopupDropDown(DisableEdit: Boolean);\r\nvar\r\n Temp: string;\r\n Action: Boolean;\r\nbegin\r\n Action := True;\r\n Temp := FileName;\r\n DoBeforeDialog(Temp, Action);\r\n if not Action then\r\n Exit;\r\n if ValidFileName(Temp) then\r\n try\r\n if DirectoryExists(ExtractFilePath(Temp)) then\r\n SetInitialDir(ExtractFilePath(Temp));\r\n if (ExtractFileName(Temp) = '') or\r\n not ValidFileName(ExtractFileName(Temp)) then\r\n Temp := '';\r\n FDialog.FileName := Temp;\r\n except\r\n { ignore any exceptions }\r\n end;\r\n FDialog.HelpContext := Self.HelpContext;\r\n DisableSysErrors;\r\n try\r\n Action := FDialog.Execute;\r\n finally\r\n EnableSysErrors;\r\n end;\r\n if Action then\r\n Temp := FDialog.FileName;\r\n if CanFocus then\r\n SetFocus;\r\n DoAfterDialog(Temp, Action);\r\n if Action then\r\n begin\r\n if AddQuotes then\r\n inherited Text := ExtFilename(Temp)\r\n else\r\n inherited Text := Temp;\r\n SetInitialDir(ExtractFilePath(FDialog.FileName));\r\n end;\r\nend;\r\n\r\nprocedure TJvFilenameEdit.ReceptFileDir(const AFileName: string);\r\nbegin\r\n if FMultipleDirs then\r\n begin\r\n if FDialog.Files.Count = 0 then\r\n SetFileName(AFileName);\r\n FDialog.Files.Add(AFileName);\r\n end\r\n else\r\n SetFileName(AFileName);\r\nend;\r\n\r\nprocedure TJvFilenameEdit.SetDefaultExt(Value: TFileExt);\r\nbegin\r\n FDialog.DefaultExt := Value;\r\nend;\r\n\r\nprocedure TJvFilenameEdit.SetDialogKind(Value: TFileDialogKind);\r\nbegin\r\n if FDialogKind <> Value then\r\n begin\r\n FDialogKind := Value;\r\n CreateEditDialog;\r\n end;\r\nend;\r\n\r\nprocedure TJvFilenameEdit.SetDialogTitle(const Value: string);\r\nbegin\r\n FDialog.Title := Value;\r\nend;\r\n\r\nprocedure TJvFilenameEdit.SetFileEditStyle(Value: TFileEditStyle);\r\nbegin\r\n FDialog.FileEditStyle := Value;\r\nend;\r\n\r\nprocedure TJvFilenameEdit.SetFilter(const Value: string);\r\nbegin\r\n FDialog.Filter := Value;\r\nend;\r\n\r\nprocedure TJvFilenameEdit.SetFilterIndex(Value: Integer);\r\nbegin\r\n FDialog.FilterIndex := Value;\r\nend;\r\n\r\nprocedure TJvFilenameEdit.SetHistoryList(Value: TStrings);\r\nbegin\r\n FDialog.HistoryList := Value;\r\nend;\r\n\r\nprocedure TJvFilenameEdit.SetInitialDir(const Value: string);\r\nbegin\r\n FDialog.InitialDir := Value;\r\nend;\r\n\r\nprocedure TJvFilenameEdit.SetOptions(Value: TOpenOptions);\r\nbegin\r\n if Value <> FDialog.Options then\r\n begin\r\n FDialog.Options := Value;\r\n FMultipleDirs := ofAllowMultiSelect in FDialog.Options;\r\n if not FMultipleDirs then\r\n ClearFileList;\r\n end;\r\nend;\r\n\r\n//=== { TJvPopupWindow } =====================================================\r\n\r\nconstructor TJvPopupWindow.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n\r\n FEditor := AOwner as TWinControl;\r\n ControlStyle := ControlStyle + [csNoDesignVisible, csReplicatable];\r\n\r\n // If we were to add csAcceptsControls at design time, any attempt\r\n // to paste a component while a component using TJvPopupWindow is active\r\n // would lead to the parent of the pasted component being set to the\r\n // TJvPopupWindow instead of the parent of the selected component.\r\n // This was reported in issue 3042 and was seen in TJvCustomDateEdit\r\n // descendents\r\n if not (csDesigning in ComponentState) then\r\n ControlStyle := ControlStyle + [csAcceptsControls];\r\n Visible := False;\r\n Ctl3D := False;\r\n ParentCtl3D := False;\r\n Parent := FEditor;\r\n // use same size on small and large font:\r\n //Scaled := False;\r\nend;\r\n\r\nprocedure TJvPopupWindow.CloseUp(Accept: Boolean);\r\nbegin\r\n if Assigned(FCloseUp) then\r\n FCloseUp(Self, Accept);\r\nend;\r\n\r\nprocedure TJvPopupWindow.CreateParams(var Params: TCreateParams);\r\nbegin\r\n inherited CreateParams(Params);\r\n with Params do\r\n begin\r\n Style := WS_POPUP or WS_BORDER or WS_CLIPCHILDREN;\r\n ExStyle := WS_EX_TOOLWINDOW;\r\n WindowClass.Style := WindowClass.Style or CS_SAVEBITS;\r\n end;\r\nend;\r\n\r\nfunction TJvPopupWindow.GetPopupText: string;\r\nbegin\r\n Result := '';\r\nend;\r\n\r\nprocedure TJvPopupWindow.Hide;\r\nbegin\r\n SetWindowPos(Handle, 0, 0, 0, 0, 0, SWP_NOZORDER or\r\n SWP_NOMOVE or SWP_NOSIZE or SWP_NOACTIVATE or SWP_HIDEWINDOW);\r\n Visible := False;\r\nend;\r\n\r\nprocedure TJvPopupWindow.InvalidateEditor;\r\nvar\r\n R: TRect;\r\nbegin\r\n if FEditor is TJvCustomComboEdit then\r\n with TJvCustomComboEdit(FEditor) do\r\n SetRect(R, 0, 0, ClientWidth - FBtnControl.Width {Polaris - 2}, ClientHeight + 1)\r\n else\r\n R := FEditor.ClientRect;\r\n Windows.InvalidateRect(FEditor.Handle, @R, False);\r\n UpdateWindow(FEditor.Handle);\r\nend;\r\n\r\nprocedure TJvPopupWindow.MouseUp(Button: TMouseButton;\r\n Shift: TShiftState; X, Y: Integer);\r\nbegin\r\n inherited MouseUp(Button, Shift, X, Y);\r\n if Button = mbLeft then\r\n CloseUp(PtInRect(ClientRect, Point(X, Y)));\r\nend;\r\n\r\nprocedure TJvPopupWindow.Show(Origin: TPoint);\r\nbegin\r\n SetBounds(Origin.X, Origin.Y, Width, Height);\r\n SetWindowPos(Handle, HWND_TOP, Origin.X, Origin.Y, 0, 0,\r\n SWP_NOACTIVATE or SWP_SHOWWINDOW or SWP_NOSIZE);\r\n Visible := True;\r\nend;\r\n\r\nprocedure TJvPopupWindow.WMActivate(var Msg: TWMActivate);\r\nbegin\r\n inherited;\r\n if Msg.Active = WA_INACTIVE then\r\n begin\r\n if FEditor is TJvCustomComboEdit then\r\n TJvCustomComboEdit(FEditor).AsyncPopupCloseUp(False)\r\n else\r\n CloseUp(False);\r\n end;\r\nend;\r\n\r\nprocedure TJvPopupWindow.WMMouseActivate(var Msg: TMessage);\r\nbegin\r\n if FIsFocusable then\r\n inherited\r\n else\r\n Msg.Result := MA_NOACTIVATE;\r\nend;\r\n\r\n\r\ninitialization\r\n {$IFDEF UNITVERSIONING}\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n {$ENDIF UNITVERSIONING}\r\n\r\nfinalization\r\n FreeAndNil(GDateHook);\r\n FreeAndNil(GDefaultComboEditImagesList);\r\n {$IFDEF UNITVERSIONING}\r\n UnregisterUnitVersion(HInstance);\r\n {$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvTracker.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvTracker.PAS, released on 2002-06-15.\r\n\r\nThe Initial Developer of the Original Code is Jan Verhoeven [jan1 dott verhoeven att wxs dott nl]\r\nPortions created by Jan Verhoeven are Copyright (C) 2002 Jan Verhoeven.\r\nAll Rights Reserved.\r\n\r\nContributor(s): Robert Love [rlove att slcdug dott org].\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n When Position 0 you can not click on the far left of the button to move.\r\n When Position 100 you can not click on the far Right of the button to move.\r\n\r\nChange: (Lionel Reynaud, 2009-2011)\r\n - TrackColor property become TrackColorStart\r\n - Added TrackColorEnd property : now you can have a track color from TrackColorStart to TrackColorEnd\r\n - Added Step property : now track can go step by step\r\n - Added the action of the keyboard arrow\r\n - Added some inherited properties\r\n - bug corrected : add font property to the draw canvas\r\n - Add draw min, max values and introduce event property OnShowMinMaxValue\r\n\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvTracker.pas 13104 2011-09-07 06:50:43Z obones $\r\n\r\nunit JvTracker;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, Messages, Graphics, Controls, ExtCtrls,\r\n SysUtils, Classes,\r\n JvComponent;\r\n\r\ntype\r\n TOnChangedValue = procedure(Sender: TObject; NewValue: Integer) of object;\r\n TOnShowMinMaxValue = procedure(Sender: TObject; var aMin, aMax: string) of object;\r\n\r\n TjtbOrientation = (jtbHorizontal, jtbVertical);\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvTracker = class(TJvCustomControl)\r\n private\r\n FHitRect: TRect;\r\n FTrackRect: TRect;\r\n FThumbRect: TRect;\r\n FThumbPosition: Integer;\r\n FThumbMin: Integer;\r\n FThumbMax: Integer;\r\n FValue: Integer;\r\n FMinimum: Integer;\r\n FMaximum: Integer;\r\n FTrackColorStart: TColor;\r\n FTrackColorEnd: TColor;\r\n FThumbColor: TColor;\r\n FBackColor: TColor;\r\n FThumbWidth: Integer;\r\n FThumbHeight: Integer;\r\n FTrackHeight: Integer;\r\n FOnChangedValue: TOnChangedValue;\r\n FShowCaption: Boolean;\r\n FCaptionColor: TColor;\r\n FTrackBorder: Boolean;\r\n FThumbBorder: Boolean;\r\n FBackBorder: Boolean;\r\n FCaptionBold: Boolean;\r\n FOrientation: TjtbOrientation;\r\n FBackBitmap: TBitmap;\r\n { Added By Steve Childs, 18/4/00 }\r\n FClickWasInRect: Boolean; // Was the original mouse click in the Track Rect ?\r\n FBorderColor: TColor;\r\n FTrackPositionColored: Boolean;\r\n FTrackR, FTrackG, FTrackB: Integer;\r\n DTrackR, DTrackG, DTrackB: Integer;\r\n FStep: Integer;\r\n FOnShowMinMaxValue: TOnShowMinMaxValue;\r\n FShowMinMax: Boolean;\r\n procedure SetMaximum(const Value: Integer);\r\n procedure SetMinimum(const Value: Integer);\r\n procedure SetValue(const Value: Integer);\r\n procedure SetBackColor(const Value: TColor);\r\n procedure SetTrackColor(Index: Integer; const Value: TColor);\r\n procedure SetThumbColor(const Value: TColor);\r\n procedure SetThumbWidth(const Value: Integer);\r\n procedure SetTrackRect;\r\n procedure SetThumbMinMax;\r\n procedure SetThumbRect;\r\n procedure SetThumbHeight(const Value: Integer);\r\n procedure SetTrackHeight(const Value: Integer);\r\n procedure UpdatePosition;\r\n procedure SetOnChangedValue(const Value: TOnChangedValue);\r\n procedure UpdateValue;\r\n procedure SetCaptionColor(const Value: TColor);\r\n procedure SetShowCaption(const Value: Boolean);\r\n procedure SetBackBorder(const Value: Boolean);\r\n procedure SetTrackBorder(const Value: Boolean);\r\n procedure SetThumbBorder(const Value: Boolean);\r\n procedure SetCaptionBold(const Value: Boolean);\r\n procedure SetOrientation(const Value: TjtbOrientation);\r\n procedure SetBackBitmap(const Value: TBitmap);\r\n procedure BackBitmapChanged(Sender: TObject);\r\n { Added By Steve Childs, 18/4/00 }\r\n procedure SetBorderColor(const Value: TColor);\r\n procedure SetTrackPositionColored(const Value: Boolean);\r\n procedure CalculateTrackColor;\r\n procedure CNKeyDown(var Message: TWMKeyDown); message CN_KEYDOWN;\r\n procedure SetShowMinMax(const Value: Boolean);\r\n procedure ReadTrackColor(Reader: TReader);\r\n protected\r\n function DoEraseBackground(Canvas: TCanvas; Param: LPARAM): Boolean; override;\r\n procedure DoChangedValue(NewValue: Integer);\r\n procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;\r\n { Added By Steve Childs, 18/4/00 }\r\n procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;\r\n { Added By Steve Childs, 18/4/00 }\r\n procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;\r\n procedure BoundsChanged; override;\r\n procedure DefineProperties(Filer: TFiler); override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n procedure Paint; override;\r\n published\r\n property Minimum: Integer read FMinimum write SetMinimum default 0;\r\n property Maximum: Integer read FMaximum write SetMaximum default 100;\r\n property Step: Integer read FStep write FStep default 1;\r\n property Value: Integer read FValue write SetValue default 0;\r\n property Orientation: TjtbOrientation read FOrientation write SetOrientation default jtbHorizontal;\r\n property BackBitmap: TBitmap read FBackBitmap write SetBackBitmap;\r\n property BackColor: TColor read FBackColor write SetBackColor default clBtnFace;\r\n property BackBorder: Boolean read FBackBorder write SetBackBorder default False;\r\n property TrackColorStart: TColor index 0 read FTrackColorStart write SetTrackColor default clGray;\r\n property TrackColorEnd: TColor index 1 read FTrackColorEnd write SetTrackColor default clGray;\r\n property TrackPositionColored: Boolean read FTrackPositionColored write SetTrackPositionColored default False;\r\n property TrackBorder: Boolean read FTrackBorder write SetTrackBorder default True;\r\n property BorderColor: TColor read FBorderColor write SetBorderColor default clBlack;\r\n {\r\n Changed Next 4 By Steve Childs, 18/4/00, Corrects Spelling Mistake\r\n Although, this may cause more trouble than it's worth with exisiting users\r\n So you might want to comment these out\r\n }\r\n property ThumbColor: TColor read FThumbColor write SetThumbColor default clSilver;\r\n property ThumbBorder: Boolean read FThumbBorder write SetThumbBorder default False;\r\n property ThumbWidth: Integer read FThumbWidth write SetThumbWidth default 20;\r\n property ThumbHeight: Integer read FThumbHeight write SetThumbHeight default 16;\r\n property TrackHeight: Integer read FTrackHeight write SetTrackHeight default 6;\r\n property ShowCaption: Boolean read FShowCaption write SetShowCaption default True;\r\n property CaptionColor: TColor read FCaptionColor write SetCaptionColor default clBlack;\r\n property CaptionBold: Boolean read FCaptionBold write SetCaptionBold default False;\r\n property ShowMinMax: Boolean read FShowMinMax write SetShowMinMax default False;\r\n property OnChangedValue: TOnChangedValue read FOnChangedValue write SetOnChangedValue;\r\n property OnShowMinMaxValue: TOnShowMinMaxValue read FOnShowMinMaxValue write FOnShowMinMaxValue;\r\n\r\n { inherited properties }\r\n property Align;\r\n property Anchors;\r\n property DragCursor;\r\n property DragKind;\r\n //property Color;\r\n property Constraints;\r\n property DragMode;\r\n property Enabled;\r\n property Font;\r\n property ParentColor;\r\n property ParentFont;\r\n property ParentShowHint;\r\n property PopupMenu;\r\n property ShowHint;\r\n property TabOrder;\r\n property TabStop;\r\n property Visible;\r\n property OnClick;\r\n property OnContextPopup;\r\n property OnDblClick;\r\n property OnDragDrop;\r\n property OnDragOver;\r\n property OnEndDrag;\r\n property OnEnter;\r\n property OnExit;\r\n property OnMouseDown;\r\n property OnMouseMove;\r\n property OnMouseUp;\r\n property OnStartDrag;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvTracker.pas $';\r\n Revision: '$Revision: 13104 $';\r\n Date: '$Date: 2011-09-07 08:50:43 +0200 (mer. 07 sept. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\n\r\nconstructor TJvTracker.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n Width := 150;\r\n Height := 24;\r\n FOrientation := jtbHorizontal;\r\n FTrackHeight := 6;\r\n FThumbWidth := 20;\r\n FThumbHeight := 16;\r\n FThumbBorder := False;\r\n FBackColor := clBtnFace;\r\n TrackColorStart := clGray;\r\n TrackColorEnd := clGray;\r\n FTrackBorder := True;\r\n FBorderColor := clBlack;\r\n FThumbColor := clSilver;\r\n FCaptionColor := clBlack;\r\n FShowCaption := True;\r\n FShowMinMax := False;\r\n FMinimum := 0;\r\n FMaximum := 100;\r\n FValue := 0;\r\n FStep := 1;\r\n FCaptionBold := False;\r\n FBackBorder := False;\r\n FBackBitmap := TBitmap.Create;\r\n FBackBitmap.OnChange := BackBitmapChanged;\r\nend;\r\n\r\nprocedure TJvTracker.ReadTrackColor(Reader: TReader);\r\nbegin\r\n TrackColorStart := Reader.ReadInteger;\r\nend;\r\n\r\nprocedure TJvTracker.DefineProperties(Filer: TFiler);\r\nbegin\r\n inherited DefineProperties(Filer);\r\n // backward compatibility TrackColor was renamed to TrackColotStart (2011-06-11)\r\n Filer.DefineProperty('TrackColor', ReadTrackColor, nil, False);\r\nend;\r\n\r\ndestructor TJvTracker.Destroy;\r\nbegin\r\n FBackBitmap.OnChange := nil;\r\n FBackBitmap.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvTracker.UpdateValue;\r\nbegin\r\n FValue := Round(FMinimum +\r\n (FThumbPosition - FThumbMin) / (FThumbMax - FThumbMin) * (FMaximum - FMinimum));\r\n if FStep <> 1 then\r\n FValue := (FValue div FStep) * FStep;\r\nend;\r\n\r\nprocedure TJvTracker.SetThumbMinMax;\r\nbegin\r\n case Orientation of\r\n jtbHorizontal:\r\n begin\r\n FThumbMin := 5 + (FThumbWidth div 2);\r\n FThumbMax := Width - FThumbMin;\r\n end;\r\n jtbVertical:\r\n begin\r\n FThumbMin := 5 + (FThumbHeight div 2);\r\n FThumbMax := Height - FThumbMin;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvTracker.SetTrackRect;\r\nvar\r\n DX, DY: Integer;\r\nbegin\r\n case Orientation of\r\n jtbHorizontal:\r\n begin\r\n DY := (Height - FTrackHeight) div 2;\r\n FTrackRect := Rect(FThumbMin, DY, FThumbMax, Height - DY);\r\n FHitRect := FTrackRect;\r\n InflateRect(FHitRect, 0, (FThumbHeight - FTrackHeight) div 2);\r\n end;\r\n jtbVertical:\r\n begin\r\n DX := (Width - FTrackHeight) div 2;\r\n FTrackRect := Rect(DX, FThumbMin, Width - DX, FThumbMax);\r\n FHitRect := FTrackRect;\r\n InflateRect(FHitRect, (FThumbWidth - FTrackHeight) div 2, 0);\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvTracker.SetThumbRect;\r\nvar\r\n DX, DY: Integer;\r\nbegin\r\n case Orientation of\r\n jtbHorizontal:\r\n begin\r\n DX := FThumbWidth div 2;\r\n DY := (Height - FThumbHeight) div 2;\r\n FThumbRect := Rect(FThumbPosition - DX, DY, FThumbPosition + DX, Height - DY);\r\n end;\r\n jtbVertical:\r\n begin\r\n DY := FThumbHeight div 2;\r\n DX := (Width - FThumbWidth) div 2;\r\n FThumbRect := Rect(DX, FThumbPosition - DY, Width - DX, FThumbPosition + DY);\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvTracker.Paint;\r\nvar\r\n {Added By Steve Childs 18/04/00 - Double Buffer Bitmap}\r\n Buffer: TBitmap;\r\n\r\n procedure DrawBackBitmap;\r\n var\r\n IX, IY: Integer;\r\n BmpWidth, BmpHeight: Integer;\r\n hCanvas, BmpCanvas: HDC;\r\n begin\r\n BmpWidth := FBackBitmap.Width;\r\n BmpHeight := FBackBitmap.Height;\r\n BmpCanvas := FBackBitmap.Canvas.Handle;\r\n { Changed By Steve Childs 18/04/00 - Now Points To Buffer.Canvas Bitmap}\r\n hCanvas := Buffer.Canvas.Handle;\r\n for IY := 0 to ClientHeight div BmpHeight do\r\n for IX := 0 to ClientWidth div BmpWidth do\r\n BitBlt(hCanvas, IX * BmpWidth, IY * BmpHeight,\r\n BmpWidth, BmpHeight, BmpCanvas, 0, 0, SRCCOPY);\r\n\r\n { Old Code!!}\r\n { hCanvas := THandle(Canvas.handle);\r\n for IY := 0 to ClientHeight div BmpHeight do\r\n for IX := 0 to ClientWidth div BmpWidth do\r\n BitBlt(hCanvas, IX * BmpWidth, IY * BmpHeight,\r\n BmpWidth, BmpHeight, BmpCanvas,\r\n 0, 0, SRCCOPY);\r\n end;}\r\n end;\r\n\r\n procedure DrawBackground;\r\n begin\r\n { Changed By Steve Childs 18/04/00 - Now Refers To Buffer Bitmap}\r\n if FBackBorder then\r\n Buffer.Canvas.Pen.Color := FBorderColor // modified 2-jul-2000 by Jan Verhoeven\r\n else\r\n Buffer.Canvas.Pen.Color := FBackColor;\r\n Buffer.Canvas.Brush.Color := FBackColor;\r\n Buffer.Canvas.Rectangle(Rect(0, 0, Width, Height));\r\n end;\r\n\r\n procedure DrawTrack;\r\n var\r\n Factor: Integer;\r\n LColor: TColor;\r\n begin\r\n { Changed By Steve Childs 18/04/00 - Now Refers To Buffer Bitmap}\r\n if FTrackPositionColored and (Maximum - Minimum > 0) then\r\n begin // 2-jul-2000 Jan Verhoeven\r\n{ old colde\r\n Factor := Value / (Maximum - Minimum);\r\n R := GetRValue(FTrackColorStart);\r\n G := GetGValue(FTrackColorStart);\r\n B := GetBValue(FTrackColorStart);\r\n LColor := RGB(Trunc(Factor * R), Trunc(Factor * G), Trunc(Factor * B));\r\n}\r\n Factor := Round((Value - Minimum) * 255 / (Maximum - Minimum));\r\n LColor := RGB(FTrackR + MulDiv(Factor, DTrackR, 255),\r\n FTrackG + MulDiv(Factor, DTrackG, 255),\r\n FTrackB + MulDiv(Factor, DTrackB, 255));\r\n\r\n Buffer.Canvas.Brush.Color := LColor;\r\n end\r\n else\r\n Buffer.Canvas.Brush.Color := FTrackColorStart;\r\n Buffer.Canvas.FillRect(FTrackRect);\r\n Buffer.Canvas.Pen.Style := psSolid;\r\n if FTrackBorder then\r\n Frame3D(Buffer.Canvas, FTrackRect, clBlack, clBtnHighlight, 1);\r\n end;\r\n\r\n procedure DrawCaption;\r\n var\r\n S: string;\r\n begin\r\n { Changed By Steve Childs 18/04/00 - Now Refers To Buffer Bitmap}\r\n S := IntToStr(FValue);\r\n Buffer.Canvas.Brush.Style := bsClear;\r\n if CaptionBold then\r\n Buffer.Canvas.Font.Style := Canvas.Font.Style + [fsBold]\r\n else\r\n Buffer.Canvas.Font.Style := Canvas.Font.Style - [fsBold];\r\n Buffer.Canvas.Font.Color := CaptionColor;\r\n DrawText(Buffer.Canvas.Handle, PChar(S), -1, FThumbRect,\r\n DT_CENTER or DT_VCENTER or DT_SINGLELINE or DT_END_ELLIPSIS);\r\n end;\r\n\r\n procedure DrawThumb;\r\n begin\r\n { Changed By Steve Childs 18/04/00 - Now Refers To Buffer Bitmap}\r\n Buffer.Canvas.Brush.Color := FThumbColor;\r\n Buffer.Canvas.FillRect(FThumbRect);\r\n Buffer.Canvas.Pen.Style := psSolid;\r\n Frame3D(Buffer.Canvas, FThumbRect, clBtnHighlight, clBlack, 1);\r\n end;\r\n\r\n procedure DrawMinMax;\r\n var\r\n lMin, lMax: string;\r\n lRect: TRect;\r\n begin\r\n lMin := IntToStr(Minimum);\r\n lMax := IntToStr(Maximum);\r\n if Assigned(FOnShowMinMaxValue) then\r\n FOnShowMinMaxValue(Self,lMin,lMax);\r\n lRect := FTrackRect;\r\n Buffer.Canvas.Brush.Style := bsClear;\r\n Buffer.Canvas.Font.Size := Buffer.Canvas.Font.Size - 2; // Reduce size\r\n\r\n case Orientation of\r\n jtbHorizontal:\r\n begin\r\n lRect.Top := lRect.Top + TrackHeight;\r\n lRect.Bottom := lRect.Bottom + TrackHeight + 4;\r\n DrawText(Buffer.Canvas.Handle, PChar(lMin), -1, lRect,\r\n DT_LEFT or DT_VCENTER or DT_SINGLELINE or DT_END_ELLIPSIS);\r\n DrawText(Buffer.Canvas.Handle, PChar(lMax), -1, lRect,\r\n DT_RIGHT or DT_VCENTER or DT_SINGLELINE or DT_END_ELLIPSIS);\r\n end;\r\n jtbVertical:\r\n begin\r\n lRect.Left := lRect.Left + TrackHeight;\r\n lRect.Right := lRect.Right + TrackHeight + ThumbWidth;\r\n DrawText(Buffer.Canvas.Handle, PChar(lMin), -1, lRect,\r\n DT_LEFT or DT_TOP or DT_SINGLELINE or DT_END_ELLIPSIS);\r\n DrawText(Buffer.Canvas.Handle, PChar(lMax), -1, lRect,\r\n DT_LEFT or DT_BOTTOM or DT_SINGLELINE or DT_END_ELLIPSIS);\r\n end;\r\n end;\r\n end;\r\n\r\nbegin\r\n { Added By Steve Childs 18/04/00 - Added Double Buffering}\r\n Buffer := TBitmap.Create;\r\n try\r\n { Added By Steve Childs 18/04/00 - Setup DoubleBuffer Bitmap}\r\n Buffer.Width := ClientWidth;\r\n Buffer.Height := ClientHeight;\r\n Buffer.Canvas.Font := Font;\r\n\r\n SetThumbMinMax;\r\n SetThumbRect;\r\n SetTrackRect;\r\n if Assigned(FBackBitmap) and (FBackBitmap.Height <> 0) and (FBackBitmap.Width <> 0) then\r\n DrawBackBitmap\r\n else\r\n DrawBackground;\r\n DrawTrack;\r\n DrawThumb;\r\n if ShowCaption then\r\n DrawCaption;\r\n if ShowMinMax then\r\n DrawMinMax;\r\n finally\r\n { Added By Steve Childs 18/04/00 - Finally, Draw the Buffer onto Main Canvas}\r\n Canvas.Draw(0, 0, Buffer);\r\n { Added By Steve Childs 18/04/00 - Free Buffer}\r\n Buffer.Free;\r\n end;\r\nend;\r\n\r\nprocedure TJvTracker.SetBackColor(const Value: TColor);\r\nbegin\r\n if FBackColor <> Value then\r\n begin\r\n FBackColor := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvTracker.SetMaximum(const Value: Integer);\r\nbegin\r\n if (Value <> FMaximum) and (Value > FMinimum) then\r\n begin\r\n FMaximum := Value;\r\n if FValue > FMaximum then\r\n FValue := FMaximum;\r\n UpdatePosition;\r\n end;\r\nend;\r\n\r\nprocedure TJvTracker.SetMinimum(const Value: Integer);\r\nbegin\r\n if (Value <> FMinimum) and (Value < FMaximum) then\r\n begin\r\n FMinimum := Value;\r\n if FValue < FMinimum then\r\n FValue := FMinimum;\r\n UpdatePosition;\r\n end;\r\nend;\r\n\r\nprocedure TJvTracker.UpdatePosition;\r\nvar\r\n Factor: Extended;\r\nbegin\r\n Factor := (FValue - FMinimum) / (FMaximum - FMinimum);\r\n FThumbPosition := FThumbMin + Round((FThumbMax - FThumbMin) * Factor);\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvTracker.CalculateTrackColor;\r\nbegin\r\n FTrackR := FTrackColorStart and $000000FF;\r\n FTrackG := (FTrackColorStart shr 8) and $000000FF;\r\n FTrackB := (FTrackColorStart shr 16) and $000000FF;\r\n DTrackR := (FTrackColorEnd and $000000FF) - FTrackR;\r\n DTrackG := ((FTrackColorEnd shr 8) and $000000FF) - FTrackG;\r\n DTrackB := ((FTrackColorEnd shr 16) and $000000FF) - FTrackB;\r\nend;\r\n\r\nprocedure TJvTracker.SetTrackColor(Index: Integer; const Value: TColor);\r\nbegin\r\n case Index of\r\n 0:\r\n if FTrackColorStart <> Value then\r\n begin\r\n FTrackColorStart := Value;\r\n CalculateTrackColor;\r\n Invalidate;\r\n end;\r\n 1:\r\n if FTrackColorEnd <> Value then\r\n begin\r\n FTrackColorEnd := Value;\r\n CalculateTrackColor;\r\n Invalidate;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvTracker.SetThumbColor(const Value: TColor);\r\nbegin\r\n if FThumbColor <> Value then\r\n begin\r\n FThumbColor := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvTracker.SetValue(const Value: Integer);\r\nbegin\r\n if (Value <> FValue) and (Value >= FMinimum) and (Value <= FMaximum) then\r\n begin\r\n FValue := (Value div FStep) * FStep;\r\n UpdatePosition;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvTracker.SetThumbWidth(const Value: Integer);\r\nbegin\r\n if FThumbWidth <> Value then\r\n begin\r\n FThumbWidth := Value;\r\n SetThumbMinMax;\r\n SetThumbRect;\r\n SetTrackRect;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvTracker.SetThumbHeight(const Value: Integer);\r\nbegin\r\n if (FThumbHeight <> Value) and (Value < Height) then\r\n begin\r\n FThumbHeight := Value;\r\n SetThumbMinMax;\r\n SetThumbRect;\r\n SetTrackRect;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvTracker.SetTrackHeight(const Value: Integer);\r\nbegin\r\n case Orientation of\r\n jtbHorizontal:\r\n if (FTrackHeight <> Value) and (Value < Height) then\r\n begin\r\n FTrackHeight := Value;\r\n SetTrackRect;\r\n Invalidate;\r\n end;\r\n jtbVertical:\r\n if (FTrackHeight <> Value) and (Value < Width) then\r\n begin\r\n FTrackHeight := Value;\r\n SetTrackRect;\r\n Invalidate;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvTracker.SetOnChangedValue(const Value: TOnChangedValue);\r\nbegin\r\n FOnChangedValue := Value;\r\nend;\r\n\r\nprocedure TJvTracker.DoChangedValue(NewValue: Integer);\r\nbegin\r\n if Assigned(FOnChangedValue) then\r\n FOnChangedValue(Self, NewValue);\r\nend;\r\n\r\nprocedure TJvTracker.BoundsChanged;\r\nbegin\r\n inherited BoundsChanged;\r\n SetThumbMinMax;\r\n SetTrackRect;\r\n UpdatePosition;\r\nend;\r\n\r\nprocedure TJvTracker.SetCaptionColor(const Value: TColor);\r\nbegin\r\n if FCaptionColor <> Value then\r\n begin\r\n FCaptionColor := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvTracker.SetShowCaption(const Value: Boolean);\r\nbegin\r\n if FShowCaption <> Value then\r\n begin\r\n FShowCaption := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvTracker.SetShowMinMax(const Value: Boolean);\r\nbegin\r\n if FShowMinMax <> Value then\r\n begin\r\n FShowMinMax := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvTracker.SetBackBorder(const Value: Boolean);\r\nbegin\r\n if FBackBorder <> Value then\r\n begin\r\n FBackBorder := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvTracker.SetTrackBorder(const Value: Boolean);\r\nbegin\r\n if FTrackBorder <> Value then\r\n begin\r\n FTrackBorder := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvTracker.SetThumbBorder(const Value: Boolean);\r\nbegin\r\n if FThumbBorder <> Value then\r\n begin\r\n FThumbBorder := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvTracker.SetCaptionBold(const Value: Boolean);\r\nbegin\r\n if FCaptionBold <> Value then\r\n begin\r\n FCaptionBold := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvTracker.SetOrientation(const Value: TjtbOrientation);\r\nvar\r\n Tmp: Integer;\r\nbegin\r\n if FOrientation <> Value then\r\n begin\r\n FOrientation := Value;\r\n if csDesigning in ComponentState then\r\n begin\r\n Tmp := Width;\r\n Width := Height;\r\n Height := Tmp;\r\n end;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvTracker.SetBackBitmap(const Value: TBitmap);\r\nbegin\r\n FBackBitmap.Assign(Value);\r\nend;\r\n\r\nprocedure TJvTracker.BackBitmapChanged(Sender: TObject);\r\nbegin\r\n Invalidate;\r\nend;\r\n\r\nfunction TJvTracker.DoEraseBackground(Canvas: TCanvas; Param: LPARAM): Boolean;\r\n{ Added By Steve Childs 18/04/00\r\n This elimates the flickering background when the thumb is updated\r\n}\r\nbegin\r\n { Added By Steve Childs 18/04/00 - Tell Windows that we have cleared background }\r\n Result := True;\r\nend;\r\n\r\nprocedure TJvTracker.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);\r\nbegin\r\n Self.SetFocus;\r\n if ssLeft in Shift then\r\n if PtInRect(FHitRect, Point(X, Y)) then\r\n begin\r\n {\r\n Added By Steve Childs 18/04/00 - Set Flag To Tell MouseMove event that\r\n the mouse was originally clicked in the Track Rect\r\n }\r\n FClickWasInRect := True;\r\n case Orientation of\r\n jtbHorizontal:\r\n FThumbPosition := X;\r\n jtbVertical:\r\n FThumbPosition := Y;\r\n end;\r\n UpdateValue;\r\n SetThumbRect;\r\n Invalidate;\r\n DoChangedValue(FValue);\r\n end;\r\nend;\r\n\r\nprocedure TJvTracker.MouseMove(Shift: TShiftState; X, Y: Integer);\r\nbegin\r\n inherited MouseMove(Shift, X, Y);\r\n if ssLeft in Shift then\r\n if FClickWasInRect then\r\n begin\r\n {\r\n - Added By Steve Childs 18/04/00\r\n OK, we know that when the mouse button went down, the\r\n click was in the rect. So, we only need to check that it's now\r\n within the bounds of the track (otherwise the button goes off the\r\n end of the track!!)\r\n\r\n }\r\n // If (X >= FTrackRect.Left) and (X <= FTrackRect.Right) then\r\n if PtInRect(FTrackRect, Point(X, Y)) then // 2-jul-2000 Jan Verhoeven\r\n if Orientation = jtbHorizontal then\r\n FThumbPosition := X\r\n else\r\n FThumbPosition := Y\r\n else\r\n begin\r\n { Added By Steve Childs 18/04/00\r\n If it's off the edges - Set Either to left or right, depending on\r\n which side the mouse is!!\r\n }\r\n // 2-jul-2000 Jan Verhoeven\r\n if Orientation = jtbHorizontal then\r\n begin\r\n if X < FTrackRect.Left then\r\n FThumbPosition := FTrackRect.Left - 1\r\n else\r\n if X > FTrackRect.Right then\r\n FThumbPosition := FTrackRect.Right + 1\r\n else\r\n FThumbPosition := X;\r\n end\r\n else\r\n begin\r\n if Y < FTrackRect.Top then\r\n FThumbPosition := FTrackRect.Top - 1\r\n else\r\n if Y > FTrackRect.Bottom then\r\n FThumbPosition := FTrackRect.Bottom + 1\r\n else\r\n FThumbPosition := Y;\r\n end;\r\n { If X < FTrackRect.Left then\r\n FThumbPosition := FTrackRect.Left-1\r\n else\r\n // Must Be Off Right\r\n FThumbPosition := FTrackRect.Right+1;}\r\n end;\r\n UpdateValue;\r\n SetThumbRect;\r\n Invalidate;\r\n DoChangedValue(FValue);\r\n end;\r\nend;\r\n\r\nprocedure TJvTracker.MouseUp(Button: TMouseButton; Shift: TShiftState;\r\n X, Y: Integer);\r\nbegin\r\n { Added By Steve Childs 18/04/00 - Clear Flag}\r\n FClickWasInRect := False;\r\n inherited MouseUp(Button, Shift, X, Y);\r\nend;\r\n\r\nprocedure TJvTracker.SetBorderColor(const Value: TColor);\r\nbegin\r\n if FBorderColor <> Value then\r\n begin\r\n FBorderColor := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvTracker.SetTrackPositionColored(const Value: Boolean);\r\nbegin\r\n if FTrackPositionColored <> Value then\r\n begin\r\n FTrackPositionColored := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvTracker.CNKeyDown(var Message: TWMKeyDown);\r\nbegin\r\n case Message.CharCode of\r\n VK_LEFT, VK_UP:\r\n Value := Value - FStep;\r\n VK_RIGHT, VK_DOWN:\r\n Value := Value + FStep;\r\n end;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvTranslateString.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvBaseDBLogonDialog.pas, released on 2006-07-21\r\n\r\nThe Initial Developer of the Original Code is Jens Fudickar\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvTranslateString.pas 13415 2012-09-10 09:51:54Z obones $\r\n\r\nunit JvTranslateString;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Classes,\r\n JvComponentBase, JvResources;\r\n\r\ntype\r\n /// This component is for string-replacement. All replacements are based on\r\n /// delimiter-encapsulated words. The delimiters can be freely defined. The default\r\n /// is : \"%\"\r\n ///\r\n /// The following replacements are defined:\r\n /// APPL_NAME : Name of the application out of the File-Version-Information\r\n /// COMPANY_NAME : Name of the company of the application out of the File-Version-Information\r\n /// DATE : Current Date\r\n /// TIME : Current Time\r\n /// DATETIME : Current Date/Time\r\n /// EXENAME : Filename of the application\r\n /// FILENAME : Filename of the application without extention\r\n /// FULLDIREXE : Directory of the application exe file\r\n /// FORMNAME : Name of the current form\r\n /// FORMCAPTION : Caption of the current form\r\n /// FILEVERSION : Version of the application file out of the File-Version-Information\r\n /// PRODUCTVERSION : Product version of the application out of the File-Version-Information\r\n /// SCREENSIZE : Size of the screen in format widthxheight\r\n /// DESKTOPSIZE : Size of the desktop in format widthxheight\r\n TProcessCommandEvent = procedure(Sender: TObject; const Command: string;\r\n var CommandResult: string; var Changed: Boolean) of object;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64 or pidOSX32)]\r\n {$ENDIF RTL230_UP}\r\n TJvTranslateString = class(TJvComponent)\r\n private\r\n FAppNameHandled: Boolean;\r\n FAppName: string;\r\n FCompanyNameHandled: Boolean;\r\n FCompanyName: string;\r\n FFileVersionHandled: Boolean;\r\n FFileVersion: string;\r\n FProductVersionHandled: Boolean;\r\n FProductVersion: string;\r\n FDateFormat: string;\r\n FDateSeparator: Char;\r\n FTimeSeparator: Char;\r\n FDateTimeFormat: string;\r\n FLeftDelimiter: string;\r\n FRightDelimiter: string;\r\n FTimeFormat: string;\r\n FOnProcessCommand: TProcessCommandEvent;\r\n function GetFormName: string;\r\n function GetFormCaption: string;\r\n function GetVersionInfoAppName: string;\r\n function GetVersionInfoFileVersion: string;\r\n function GetVersionInfoProductVersion: string;\r\n function GetVersionInfoCompanyName: string;\r\n function ProcessCommand(const Command: string; var CommandResult: string): Boolean;\r\n procedure SetDateFormat(const Value: string);\r\n procedure SetDateTimeFormat(const Value: string);\r\n procedure SetTimeFormat(const Value: string);\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n function TranslateString(InString: string; var Changed: Boolean): string; overload;\r\n function TranslateString(InString: string): string; overload;\r\n published\r\n property DateFormat: string read FDateFormat write SetDateFormat;\r\n property DateSeparator: Char read FDateSeparator write FDateSeparator;\r\n property DateTimeFormat: string read FDateTimeFormat write SetDateTimeFormat;\r\n property LeftDelimiter: string read FLeftDelimiter write FLeftDelimiter;\r\n property RightDelimiter: string read FRightDelimiter write FRightDelimiter;\r\n property TimeFormat: string read FTimeFormat write SetTimeFormat;\r\n property TimeSeparator: Char read FTimeSeparator write FTimeSeparator;\r\n property OnProcessCommand: TProcessCommandEvent read FOnProcessCommand write FOnProcessCommand;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvTranslateString.pas $';\r\n Revision: '$Revision: 13415 $';\r\n Date: '$Date: 2012-09-10 11:51:54 +0200 (lun. 10 sept. 2012) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n {$IFDEF HAS_UNIT_SYSTEM_UITYPES}\r\n System.UITypes,\r\n {$ENDIF}\r\n SysUtils, Types, Forms, Dialogs,\r\n JclFileUtils,\r\n JvJCLUtils,\r\n JvJVCLUtils;\r\n\r\nconst\r\n cAppNameMask = 'APPL_NAME';\r\n cCompanyNameMask = 'COMPANY_NAME';\r\n cDateMask = 'DATE';\r\n cTimeMask = 'TIME';\r\n cDateTimeMask = 'DATETIME';\r\n cExeNameMask = 'EXENAME';\r\n cFileNameMask = 'FILENAME';\r\n cFullDirExeMask = 'FULLDIREXE';\r\n cFormNameMask = 'FORMNAME';\r\n cFormCaptionMask = 'FORMCAPTION';\r\n cFileVersionMask = 'FILEVERSION';\r\n cProductVersionMask = 'PRODUCTVERSION';\r\n cScreenSizeMask = 'SCREENSIZE';\r\n cDesktopSizeMask = 'DESKTOPSIZE';\r\n\r\n cDefaultAppName = 'MyJVCLApplication';\r\n cDefaultCompanyName = 'MyCompany';\r\n cDefaultVersion = '0.0.0.0';\r\n\r\nconstructor TJvTranslateString.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FAppNameHandled := False;\r\n FCompanyNameHandled := False;\r\n FLeftDelimiter := '%';\r\n FRightDelimiter := '%';\r\n FDateFormat := 'dd_mm_yyyy';\r\n FTimeFormat := 'hh_nn_ss';\r\n FDateTimeFormat := 'dd_mm_yyyy hh_nn_ss';\r\n FDateSeparator := chr(255);\r\n FTimeSeparator := chr(255);\r\n FProductVersionHandled := False;\r\n FFileVersionHandled := False;\r\nend;\r\n\r\nfunction TJvTranslateString.GetFormName: string;\r\n\r\n function GetName(Comp: TComponent): string;\r\n begin\r\n if Assigned(Owner) then\r\n if Comp is TCustomForm then\r\n Result := TCustomForm(Comp).Name\r\n else\r\n Result := GetName(Comp.Owner)\r\n else\r\n Result := '';\r\n end;\r\n\r\nbegin\r\n Result := GetName(Owner);\r\nend;\r\n\r\nfunction TJvTranslateString.GetFormCaption: string;\r\n\r\n function GetCaption(Comp: TComponent): string;\r\n begin\r\n if Assigned(Owner) then\r\n if Comp is TCustomForm then\r\n Result := TCustomForm(Comp).Caption\r\n else\r\n Result := GetCaption(Comp.Owner)\r\n else\r\n Result := '';\r\n end;\r\n\r\nbegin\r\n Result := GetCaption(Owner);\r\nend;\r\n\r\nfunction TJvTranslateString.GetVersionInfoAppName: string;\r\nvar\r\n VersionInfo: TJclFileVersionInfo;\r\nbegin\r\n if FAppNameHandled then\r\n Result := FAppName\r\n else\r\n try\r\n VersionInfo := TJclFileVersionInfo.Create(Application.ExeName);\r\n try\r\n Result := VersionInfo.ProductName;\r\n FAppName := Result;\r\n FAppNameHandled := True;\r\n finally\r\n VersionInfo.Free;\r\n end;\r\n except\r\n on EJclFileVersionInfoError do\r\n begin\r\n MessageDlg(Format(RsRootValueReplaceFmt, [cAppNameMask, cDefaultAppName]), mtInformation, [mbOK], 0);\r\n Result := cDefaultAppName;\r\n FAppName := Result;\r\n FAppNameHandled := True;\r\n end\r\n else\r\n raise;\r\n end;\r\nend;\r\n\r\nfunction TJvTranslateString.GetVersionInfoFileVersion: string;\r\nvar\r\n VersionInfo: TJclFileVersionInfo;\r\nbegin\r\n if FFileVersionHandled then\r\n Result := FFileVersion\r\n else\r\n try\r\n VersionInfo := TJclFileVersionInfo.Create(Application.ExeName);\r\n try\r\n Result := VersionInfo.FileVersion;\r\n FFileVersion := Result;\r\n FFileVersionHandled := True;\r\n finally\r\n VersionInfo.Free;\r\n end;\r\n except\r\n on EJclFileVersionInfoError do\r\n begin\r\n MessageDlg(Format(RsRootValueReplaceFmt, [cFileVersionMask, cDefaultVersion]), mtInformation, [mbOK], 0);\r\n Result := cDefaultVersion;\r\n FFileVersion := Result;\r\n FFileVersionHandled := True;\r\n end\r\n else\r\n raise;\r\n end;\r\nend;\r\n\r\nfunction TJvTranslateString.GetVersionInfoProductVersion: string;\r\nvar\r\n VersionInfo: TJclFileVersionInfo;\r\nbegin\r\n if FProductVersionHandled then\r\n Result := FProductVersion\r\n else\r\n try\r\n VersionInfo := TJclFileVersionInfo.Create(Application.ExeName);\r\n try\r\n Result := VersionInfo.ProductVersion;\r\n FProductVersion := Result;\r\n FProductVersionHandled := True;\r\n finally\r\n VersionInfo.Free;\r\n end;\r\n except\r\n on EJclFileVersionInfoError do\r\n begin\r\n MessageDlg(Format(RsRootValueReplaceFmt, [cProductVersionMask, cDefaultVersion]), mtInformation, [mbOK], 0);\r\n Result := cDefaultVersion;\r\n FProductVersion := Result;\r\n FProductVersionHandled := True;\r\n end\r\n else\r\n raise;\r\n end;\r\nend;\r\n\r\nfunction TJvTranslateString.GetVersionInfoCompanyName: string;\r\nvar\r\n VersionInfo: TJclFileVersionInfo;\r\nbegin\r\n if FCompanyNameHandled then\r\n Result := FCompanyName\r\n else\r\n try\r\n VersionInfo := TJclFileVersionInfo.Create(Application.ExeName);\r\n try\r\n Result := VersionInfo.CompanyName;\r\n FCompanyName := Result;\r\n FCompanyNameHandled := True;\r\n finally\r\n VersionInfo.Free;\r\n end;\r\n except\r\n on EJclFileVersionInfoError do\r\n begin\r\n MessageDlg(Format(RsRootValueReplaceFmt, [cCompanyNameMask, cDefaultCompanyName]), mtInformation, [mbOK], 0);\r\n Result := cDefaultCompanyName;\r\n FCompanyName := Result;\r\n FCompanyNameHandled := True;\r\n end\r\n else\r\n raise;\r\n end;\r\nend;\r\n\r\nfunction TJvTranslateString.ProcessCommand(const Command: string; var CommandResult: string): Boolean;\r\nvar\r\n UpperCommand: string;\r\nbegin\r\n Result := True;\r\n UpperCommand := Trim(UpperCase(Command));\r\n if UpperCommand = cAppNameMask then\r\n begin\r\n CommandResult := GetVersionInfoAppName;\r\n if CommandResult = '' then\r\n CommandResult := ExtractFileName(ChangeFileExt(Application.ExeName, ''));\r\n end\r\n else\r\n if UpperCommand = cCompanyNameMask then\r\n begin\r\n CommandResult := GetVersionInfoCompanyName;\r\n if CommandResult = '' then\r\n CommandResult := DefCompanyName;\r\n end\r\n else\r\n if UpperCommand = cFileVersionMask then\r\n CommandResult := GetVersionInfoFileVersion\r\n else\r\n if UpperCommand = cProductVersionMask then\r\n CommandResult := GetVersionInfoProductVersion\r\n else\r\n if UpperCommand = cDateMask then\r\n DateTimeToString(CommandResult, DateFormat, Now)\r\n else\r\n if UpperCommand = cTimeMask then\r\n DateTimeToString(CommandResult, TimeFormat, Now)\r\n else\r\n if UpperCommand = cDateTimeMask then\r\n DateTimeToString(CommandResult, DateTimeFormat, Now)\r\n else\r\n if UpperCommand = cExeNameMask then\r\n CommandResult := Application.ExeName\r\n else\r\n if UpperCommand = cFileNameMask then\r\n CommandResult := ExtractFileName(ChangeFileExt(Application.ExeName, ''))\r\n else\r\n if UpperCommand = cFullDirExeMask then\r\n CommandResult := ExtractFileDir(Application.ExeName)\r\n else\r\n if UpperCommand = cFormNameMask then\r\n CommandResult := GetFormName\r\n else\r\n if UpperCommand = cFormCaptionMask then\r\n CommandResult := GetFormCaption\r\n else\r\n if UpperCommand = cScreenSizeMask then\r\n CommandResult := Format('%dx%d', [Screen.Width, Screen.Height])\r\n else\r\n if UpperCommand = cDesktopSizeMask then\r\n CommandResult := Format('%dx%d', [Screen.DesktopWidth, Screen.DesktopHeight])\r\n else\r\n Result := False;\r\n if Assigned(FOnProcessCommand) then\r\n FOnProcessCommand(Self, UpperCommand, CommandResult, Result);\r\nend;\r\n\r\nprocedure TJvTranslateString.SetDateFormat(const Value: string);\r\nvar i : Integer;\r\nbegin\r\n FDateFormat := Value;\r\n if DateSeparator = chr(255) then\r\n for i := 1 to Length(Value) do\r\n if not CharInSet(Value[i],['0'..'9']) then\r\n begin\r\n DateSeparator:= Value[i];\r\n Exit;\r\n end;\r\nend;\r\n\r\nprocedure TJvTranslateString.SetDateTimeFormat(const Value: string);\r\nbegin\r\n FDateTimeFormat := Value;\r\nend;\r\n\r\nprocedure TJvTranslateString.SetTimeFormat(const Value: string);\r\nvar i : Integer;\r\nbegin\r\n FTimeFormat := Value;\r\n if TimeSeparator = chr(255) then\r\n for i := 1 to Length(Value) do\r\n if not CharInSet(Value[i],['0'..'9']) then\r\n begin\r\n TimeSeparator:= Value[i];\r\n Exit;\r\n end;\r\nend;\r\n\r\nfunction TJvTranslateString.TranslateString(InString: string): string;\r\nvar\r\n I, J: Integer;\r\n Command: string;\r\n CommandResult: string;\r\nbegin\r\n Result := '';\r\n while InString <> '' do\r\n begin\r\n I := Pos(LeftDelimiter, InString);\r\n if I = 0 then\r\n begin\r\n Result := Result + InString;\r\n InString := '';\r\n end\r\n else\r\n begin\r\n Result := Result + Copy(InString, 1, I-1);\r\n Delete(InString, 1, i);\r\n J := Pos(RightDelimiter, InString);\r\n if J > 0 then\r\n begin\r\n Command := Copy(InString, 1, J-1);\r\n if ProcessCommand(Command, CommandResult) then\r\n begin\r\n Result := Result + CommandResult;\r\n Delete(InString, 1, J);\r\n end\r\n else\r\n begin\r\n Result := Result + Copy(InString, 1, J-1);\r\n Delete(InString, 1, J-1);\r\n end;\r\n end\r\n else\r\n begin\r\n Result := Result + LeftDelimiter + InString;\r\n InString := '';\r\n end\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJvTranslateString.TranslateString(InString: string; var Changed: Boolean): string;\r\nvar\r\n I, J: Integer;\r\n Command: string;\r\n CommandResult: string;\r\nbegin\r\n Result := '';\r\n Changed := False;\r\n while InString <> '' do\r\n begin\r\n I := Pos(LeftDelimiter, InString);\r\n if I = 0 then\r\n begin\r\n Result := Result + InString;\r\n InString := '';\r\n end\r\n else\r\n begin\r\n Result := Result + Copy(InString, 1, I-1);\r\n Delete(InString, 1, I);\r\n J := Pos(RightDelimiter, InString);\r\n Command := Copy(InString, 1, J-1);\r\n if ProcessCommand(Command, CommandResult) then\r\n begin\r\n Result := Result + CommandResult;\r\n Delete(InString, 1, J);\r\n Changed := True;\r\n end\r\n else\r\n begin\r\n Result := Result + Copy(InString, 1, J-1);\r\n Delete(InString, 1, J-1);\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n\r\n" }, { "path": "External/Jedi/Jvcl/run/JvTranslator.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvTranslator.PAS, released on 2002-06-03\r\n\r\nThe Initial Developer of the Original Code is Sbastien Buysse [sbuysse att buypin dott com]\r\nPortions created by Sbastien Buysse are Copyright (C) 2001 Sbastien Buysse.\r\nAll Rights Reserved.\r\n\r\nContributor(s): _________________________________.\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvTranslator.pas 13415 2012-09-10 09:51:54Z obones $\r\n\r\nunit JvTranslator;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n SysUtils, Classes, IniFiles,\r\n Forms, ComCtrls, Menus, Dialogs,\r\n JvSimpleXml, JvComponentBase,\r\n JclSimpleXml;\r\n\r\ntype\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64 or pidOSX32)]\r\n {$ENDIF RTL230_UP}\r\n TJvTranslator = class(TJvComponent)\r\n private\r\n FXML: TJvSimpleXml;\r\n FSkipList: TList;\r\n function IsObject(const Obj: TClass; const ClassName: string): Boolean;\r\n protected\r\n function FindItemNamed(Root: TJvSimpleXMLElem; const AName: string;\r\n ARecurse: Boolean = False): TJvSimpleXMLElem; virtual;\r\n procedure TranslateComponent(const Component: TComponent; const Elem: TJvSimpleXMLElem); virtual;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n // Call SkipClass to register a class to skip when reading/writing\r\n procedure SkipClass(AClass: TClass);\r\n // Call UnskipClass to unregister a class so it won't be skip when reading/writing\r\n procedure UnskipClass(AClass: TClass);\r\n // Call SkipProperty to register a class property to skip when reading/writing\r\n // If UnskipClass has already been called for this class, does nothing\r\n procedure SkipProperty(AClass: TClass; const PropName: string);\r\n // Call UnskipProperty to unregister a class property so it won't be skipped when reading/writing\r\n // If SkipClass has already been called for this class, does nothing\r\n procedure UnskipProperty(AClass: TClass; const PropName: string);\r\n // Returns True if the specifed class/object/property is in the skip list\r\n function InSkipList(AClass: TClass): Boolean; overload;\r\n function InSkipList(Obj: TObject): Boolean; overload;\r\n function InSkipList(AClass: TClass; const PropName: string): Boolean; overload;\r\n function InSkipList(Obj: TObject; const PropName: string): Boolean; overload;\r\n procedure ClearSkipList;\r\n // ComponentToXML converts a TComponent and, optionally, it's owned components to an XML string\r\n // and returns it\r\n function ComponentToXML(const AComponent: TComponent; Recurse: Boolean): string;\r\n // Translate the entire Application using the file Filename\r\n procedure Translate(const FileName: string); overload;\r\n // Translate the entire Application using a stream\r\n procedure Translate(const Stream: TStream); overload;\r\n // Translate the entire Application using a string\r\n procedure TranslateString(const S: string); overload;\r\n // Translate a form using the file Filename\r\n procedure Translate(const FileName: string; const Form: TCustomForm); overload;\r\n // Translate a form using a stream\r\n procedure Translate(const Stream: TStream; const Form: TCustomForm); overload;\r\n // Translate a form using a string\r\n procedure TranslateString(const S: string; const Form: TCustomForm); overload;\r\n // Translate a form using the currently loaded XML (wherever it came from)\r\n procedure Translate(const Form: TCustomForm); overload;\r\n // Translates all form instances owned by the global screen object using the file Filename\r\n procedure TranslateScreen(const FileName: string); overload;\r\n // Translates all form instances owned by the global screen object using a stream\r\n procedure TranslateScreen(const Stream: TStream); overload;\r\n // Translates all form instances owned by the global screen object using a string\r\n procedure TranslateScreenString(const S: string);\r\n // Returns the value of a node or a property value of a node based on certain search criteria.\r\n // To find the value, the method first searches the root for a subnode with the name in Category.\r\n // If found, Category is searched for a subnode with the name in Item. If found, either the value\r\n // of Item or the value of a property named \"Value\" in Item is returned.\r\n // Structurally it should look something like this:\r\n // \r\n // \r\n // Value\r\n // \r\n // ....\r\n // This method returns either Value or, if not found, PropValue or, if not found, an empty string\r\n function Translate(const Category, Item: string): string; overload;\r\n property XML: TJvSimpleXml read FXML;\r\n end;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64 or pidOSX32)]\r\n {$ENDIF RTL230_UP}\r\n TJvTranslatorStrings = class(TJvComponent)\r\n private\r\n FList: THashedStringList;\r\n function GetString(Index: Integer): string;\r\n procedure SetString(Index: Integer; const Value: string);\r\n function GetCount: Integer;\r\n function GetValue(Index: Integer): string;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n function IndexOf(const Name: string): Integer;\r\n function Add(const Name: string; var Value: string): Integer;\r\n // (p3) this is weird: GetString returns the *Name* but SetString sets the *Value*...\r\n property Strings[Index: Integer]: string read GetString write SetString; default;\r\n property Value[Index: Integer]: string read GetValue;\r\n property Count: Integer read GetCount;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvTranslator.pas $';\r\n Revision: '$Revision: 13415 $';\r\n Date: '$Date: 2012-09-10 11:51:54 +0200 (lun. 10 sept. 2012) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n TypInfo,\r\n {$IFDEF SUPPORTS_INLINE}\r\n Windows,\r\n {$ENDIF SUPPORTS_INLINE}\r\n JclStreams,\r\n JvConsts;\r\n\r\nconst\r\n cName = 'Name';\r\n cItem = 'Item';\r\n cIndex = 'Index';\r\n cColumn = 'Column';\r\n cValue = 'Value';\r\n cVariables = 'Variables';\r\n cTTreeNodes = 'TTreeNodes';\r\n cTListItems = 'TListItems';\r\n cTStrings = 'TStrings';\r\n cTCollection = 'TCollection';\r\n cTComponent = 'TComponent';\r\n cTJvTranslatorStrings = 'TJvTranslatorStrings';\r\n cNewline = '\\n';\r\n\r\ntype\r\n PSkipPropRec = ^TSkipPropRec;\r\n TSkipPropRec = record\r\n AClass: TClass;\r\n AProps: TStringList;\r\n end;\r\n\r\nfunction InternalGetWideStrProp(Instance: TObject; const PropName: string): WideString; overload;\r\nbegin\r\n Result := {$IFDEF RTL240_UP}GetStrProp{$ELSE}GetWideStrProp{$ENDIF RTL240_UP}(Instance, PropName);\r\nend;\r\n\r\nfunction InternalGetPropList(AObject: TObject; out PropList: PPropList): Integer;\r\nbegin\r\n Result := GetPropList(AObject, PropList);\r\nend;\r\n\r\n//=== { TJvTranslator } ======================================================\r\n\r\nconstructor TJvTranslator.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FXML := TJvSimpleXml.Create(nil);\r\n SkipProperty(TComponent, cName);\r\nend;\r\n\r\ndestructor TJvTranslator.Destroy;\r\nbegin\r\n FXML.Free;\r\n ClearSkipList;\r\n FreeAndNil(FSkipList);\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJvTranslator.FindItemNamed(Root: TJvSimpleXMLElem; const AName: string; ARecurse: Boolean): TJvSimpleXMLElem;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := nil;\r\n if Root = nil then\r\n Root := FXML.Root;\r\n if AnsiSameText(Root.Name, AName) then\r\n Result := Root\r\n else\r\n if not ARecurse then\r\n Result := Root.Items.ItemNamed[AName]\r\n else\r\n for I := 0 to Root.Items.Count - 1 do\r\n begin\r\n Result := FindItemNamed(Root.Items[I], AName, True);\r\n if Result <> nil then\r\n Break;\r\n end;\r\nend;\r\n\r\nfunction TJvTranslator.IsObject(const Obj: TClass; const ClassName: string): Boolean;\r\nbegin\r\n if Obj = nil then\r\n Result := False\r\n else\r\n Result := SameText(Obj.ClassName, ClassName) or (IsObject(Obj.ClassParent, ClassName));\r\nend;\r\n\r\nfunction TJvTranslator.ComponentToXML(const AComponent: TComponent; Recurse: Boolean): string;\r\nvar\r\n AName: string;\r\n AElem: TJvSimpleXMLElem;\r\n\r\n procedure CollectionToXML(Collection: TCollection; Elem: TJvSimpleXMLElem; Recurse:Boolean); forward;\r\n\r\n procedure TreeNodesToXML(Nodes: TTreeNodes; Elem: TJvSimpleXMLElem);\r\n var\r\n N: TTreeNode;\r\n AElem: TJvSimpleXMLElem;\r\n begin\r\n // format: \r\n // \r\n // TODO\r\n if InSkipList(Nodes) then\r\n Exit;\r\n N := Nodes.GetFirstNode;\r\n while Assigned(N) do\r\n begin\r\n if not InSkipList(N) then\r\n begin\r\n AElem := Elem.Items.Add(cItem);\r\n AElem.Properties.Add(cIndex, N.Index);\r\n AElem.Properties.Add(cValue, N.Text);\r\n end;\r\n {\r\n AElem.Properties.Add('ImageIndex',N.ImageIndex);\r\n AElem.Properties.Add('SelectedIndex',N.SelectedIndex);\r\n }\r\n N := N.GetNext;\r\n end;\r\n end;\r\n\r\n procedure ListItemsToXML(Items: TListItems; Elem: TJvSimpleXMLElem);\r\n var\r\n I, J: Integer;\r\n AElem: TJvSimpleXMLElem;\r\n begin\r\n // format: \r\n // \r\n // TODO\r\n if InSkipList(Items) then\r\n Exit;\r\n for I := 0 to Items.Count - 1 do\r\n begin\r\n if not InSkipList(Items[I]) then\r\n begin\r\n AElem := Elem.Items.Add(cItem);\r\n AElem.Properties.Add(cIndex, I);\r\n AElem.Properties.Add(cColumn, 0);\r\n AElem.Properties.Add(cValue, Items[I].Caption);\r\n for J := 0 to Items[I].SubItems.Count - 1 do\r\n begin\r\n AElem := Elem.Items.Add(cItem);\r\n AElem.Properties.Add(cIndex, I);\r\n AElem.Properties.Add(cColumn, J + 1);\r\n AElem.Properties.Add(cValue, Items[I].SubItems[J]);\r\n end;\r\n end;\r\n end;\r\n end;\r\n\r\n procedure StringsToXML(Strings: TStrings; Elem: TJvSimpleXMLElem);\r\n var\r\n I: Integer;\r\n AElem: TJvSimpleXMLElem;\r\n begin\r\n // format: \r\n // \r\n if InSkipList(Strings) then\r\n Exit;\r\n for I := 0 to Strings.Count - 1 do\r\n begin\r\n AElem := Elem.Items.Add(cItem);\r\n AElem.Properties.Add(cIndex, I);\r\n AElem.Properties.Add(cValue, Strings[I]);\r\n end;\r\n end;\r\n\r\n procedure TranslatorStringsToXML(AStrings: TJvTranslatorStrings; Elem: TJvSimpleXMLElem);\r\n var\r\n I: Integer;\r\n AElem: TJvSimpleXMLElem;\r\n begin\r\n // I'm not sure how to create a translation template for this component, so this is just a guess...\r\n // format:\r\n // \r\n // \r\n // \r\n if InSkipList(AStrings) then\r\n Exit;\r\n Elem.Name := cVariables;\r\n for I := 0 to AStrings.Count - 1 do\r\n begin\r\n AElem := Elem.Items.Add(cItem);\r\n AElem.Properties.Add(cName, AStrings[I]);\r\n AElem.Properties.Add(cValue, AStrings.Value[I]);\r\n end;\r\n end;\r\n(*\r\n procedure ObjectToXML(AnObject: TObject; Elem: TJvSimpleXMLElem);\r\n var\r\n J, Count: Integer;\r\n PropList: PPropList;\r\n PropName: string;\r\n PropInfo: PPropInfo;\r\n AnObj: TObject;\r\n begin\r\n if (AnObject <> nil) and not InSkipList(AnObject) then\r\n begin\r\n Count := InternalGetPropList(AnObject, PropList);\r\n for J := 0 to Count - 1 do\r\n begin\r\n PropInfo := PropList[J];\r\n PropName := PropInfo^.Name;\r\n try\r\n if (PropInfo^.SetProc = nil) or InSkipList(AnObject, PropName) then\r\n Continue;\r\n case PropInfo^.PropType^.Kind of\r\n tkInteger:\r\n Elem.Properties.Add(PropName, GetOrdProp(AnObject, PropName));\r\n tkEnumeration:\r\n Elem.Properties.Add(PropName, GetEnumProp(AnObject, PropName));\r\n tkSet:\r\n Elem.Properties.Add(PropName, GetSetProp(AnObject, PropName));\r\n {$IFDEF UNICODE} tkUString, {$ENDIF}\r\n tkString, tkLString:\r\n Elem.Properties.Add(PropName, GetStrProp(AnObject, PropName));\r\n tkClass:\r\n begin\r\n AnObj := GetObjectProp(AnObject, PropName);\r\n if IsObject(AnObj.ClassType, cTTreeNodes) then\r\n TreeNodesToXML(TTreeNodes(AnObj), Elem.Items.Add(PropName))\r\n else\r\n if IsObject(AnObj.ClassType, cTListItems) then\r\n ListItemsToXML(TListItems(AnObj), Elem.Items.Add(PropName))\r\n else\r\n if IsObject(AnObj.ClassType, cTStrings) then\r\n StringsToXML(TStrings(AnObj), Elem.Items.Add(PropName))\r\n else\r\n if IsObject(AnObj.ClassType, cTCollection) then\r\n CollectionToXML(TCollection(AnObj), Elem.Items.Add(PropName))\r\n else\r\n if not IsObject(AnObj.ClassType, cTComponent) then\r\n // NB! TComponents are excluded because most of the time, a published TComponent\r\n // property references another component on the form. In some cases, however, a TComponent\r\n // *can* be an internal component and this code won't list it.\r\n // No known solution yet (no, HasParent/GetParentComponent doesn't work here)\r\n ObjectToXML(AnObj, Elem.Items.Add(PropName));\r\n end;\r\n end;\r\n except\r\n //\r\n end;\r\n end;\r\n end;\r\n end;\r\n*)\r\n procedure InnerComponentToXML(AComponent: TObject; Elem: TJvSimpleXMLElem; Recurse: Boolean);\r\n var\r\n I, Count: Integer;\r\n PropList: PPropList;\r\n PropName: string;\r\n PropInfo: PPropInfo;\r\n AnObj: TObject;\r\n begin\r\n if AComponent = nil then\r\n Exit;\r\n if not InSkipList(AComponent) then\r\n begin\r\n if IsObject(AComponent.ClassType, cTJvTranslatorStrings) then\r\n begin\r\n TranslatorStringsToXML(TJvTranslatorStrings(AComponent), Elem);\r\n Exit;\r\n end;\r\n Count := InternalGetPropList(AComponent, PropList);\r\n for I := 0 to Count - 1 do\r\n begin\r\n PropInfo := PropList[I];\r\n PropName := {$IFDEF SUPPORTS_UNICODE}UTF8ToString{$ENDIF SUPPORTS_UNICODE}(PropInfo^.Name);\r\n\r\n if InSkipList(AComponent, PropName) or (PropInfo^.SetProc = nil) then\r\n Continue;\r\n case PropInfo^.PropType^.Kind of\r\n tkInteger:\r\n Elem.Properties.Add(PropName, GetOrdProp(AComponent, PropName));\r\n tkEnumeration:\r\n Elem.Properties.Add(PropName, GetEnumProp(AComponent, PropName));\r\n tkSet:\r\n Elem.Properties.Add(PropName, GetSetProp(AComponent, PropName));\r\n {$IFDEF UNICODE} tkUString, {$ENDIF}\r\n tkString, tkLString, tkWString:\r\n Elem.Properties.Add(PropName, XMLEncode(InternalGetWideStrProp(AComponent, PropName)));\r\n tkClass:\r\n begin\r\n AnObj := GetObjectProp(AComponent, PropName);\r\n\r\n // The property may not be assigned (action, popupmenu...), in\r\n // this case, we can't do anything with it.\r\n if not Assigned(AnObj) then\r\n Continue;\r\n\r\n if IsObject(AnObj.ClassType, cTTreeNodes) then\r\n TreeNodesToXML(TTreeNodes(AnObj), Elem.Items.Add(PropName))\r\n else\r\n if IsObject(AnObj.ClassType, cTListItems) then\r\n ListItemsToXML(TListItems(AnObj), Elem.Items.Add(PropName))\r\n else\r\n if IsObject(AnObj.ClassType, cTStrings) then\r\n StringsToXML(TStrings(AnObj), Elem.Items.Add(PropName))\r\n else\r\n if IsObject(AnObj.ClassType, cTCollection) then\r\n CollectionToXML(TCollection(AnObj), Elem.Items.Add(PropName), Recurse)\r\n else\r\n if not IsObject(AnObj.ClassType, cTComponent) then\r\n // NB! TComponents are excluded because most of the time, a published TComponent\r\n // property references another component on the form. In some cases, however, a TComponent\r\n // *can* be an internal component and this code won't list it.\r\n // No known solution yet (no, HasParent/GetparentComponent doesn't work here)\r\n InnerComponentToXML(AnObj, Elem.Items.Add(PropName), Recurse);\r\n end;\r\n end;\r\n end;\r\n end;\r\n if Recurse and (AComponent is TComponent) then\r\n for I := 0 to TComponent(AComponent).ComponentCount - 1 do\r\n if TComponent(AComponent).Components[I].Name <> '' then\r\n InnerComponentToXML(TComponent(AComponent).Components[I], Elem.Items.Add(TComponent(AComponent).Components[I].Name), True);\r\n end;\r\n procedure CollectionToXML(Collection: TCollection; Elem: TJvSimpleXMLElem; Recurse:Boolean);\r\n var\r\n I: Integer;\r\n begin\r\n if not InSkipList(Collection) then\r\n for I := 0 to Collection.Count - 1 do\r\n if not InSkipList(Collection.Items[I]) then\r\n InnerComponentToXML(Collection.Items[I], Elem.Items.Add(Collection.Items[I].DisplayName), Recurse);\r\n end;\r\n\r\nbegin\r\n Result := '';\r\n FXML.Root.Clear;\r\n if AComponent = nil then\r\n Exit;\r\n if AComponent is TApplication then\r\n begin\r\n AName := TApplication(AComponent).Title;\r\n FXML.Root.Name := 'Translation'; // DO NOT LOCALIZE\r\n AElem := FXML.Root.Items.Add(AName);\r\n end\r\n else\r\n begin\r\n AName := TComponent(AComponent).Name;\r\n AElem := FXML.Root;\r\n FXML.Root.Name := AName;\r\n end;\r\n if AName <> '' then\r\n begin\r\n InnerComponentToXML(AComponent, AElem, Recurse);\r\n Result := FXML.Root.SaveToString;\r\n end;\r\nend;\r\n\r\nprocedure TJvTranslator.Translate(const FileName: string);\r\nbegin\r\n try\r\n FXML.LoadFromFile(FileName);\r\n TranslateComponent(Application, FXML.Root);\r\n except\r\n end;\r\nend;\r\n\r\nprocedure TJvTranslator.Translate(const Stream: TStream);\r\nbegin\r\n try\r\n FXML.LoadFromStream(Stream);\r\n TranslateComponent(Application, FXML.Root);\r\n except\r\n end;\r\nend;\r\n\r\nprocedure TJvTranslator.TranslateScreen(const FileName: string);\r\nvar\r\n I: Integer;\r\nbegin\r\n try\r\n FXML.LoadFromFile(FileName);\r\n for I := 0 to Screen.FormCount - 1 do\r\n Translate(Screen.Forms[I]);\r\n except\r\n end;\r\nend;\r\n\r\nprocedure TJvTranslator.TranslateScreen(const Stream: TStream);\r\nvar\r\n I: Integer;\r\nbegin\r\n try\r\n FXML.LoadFromStream(Stream);\r\n for I := 0 to Screen.FormCount - 1 do\r\n Translate(Screen.Forms[I]);\r\n except\r\n end;\r\nend;\r\n\r\nprocedure TJvTranslator.Translate(const FileName: string; const Form: TCustomForm);\r\nbegin\r\n try\r\n FXML.LoadFromFile(FileName);\r\n Translate(Form);\r\n except\r\n end;\r\nend;\r\n\r\nprocedure TJvTranslator.TranslateComponent(const Component: TComponent;\r\n const Elem: TJvSimpleXMLElem);\r\nvar\r\n I, J: Integer;\r\n PropInfo: PPropInfo;\r\n Obj: TObject;\r\n Ok: Boolean;\r\n S: string;\r\n\r\n procedure TransObject(const Obj: TObject; const Elem: TJvSimpleXMLElem); forward;\r\n\r\n function AnalyseCRLF(Value: string): string;\r\n begin\r\n Result := StringReplace(Value, cNewline, sLineBreak, [rfReplaceAll]);\r\n end;\r\n\r\n procedure TransStrings(const Obj: TObject; const Elem: TJvSimpleXMLElem);\r\n var\r\n I, J: Integer;\r\n begin\r\n if (Elem.Items.Count > 0) and (Elem.Items[0] is TJvSimpleXmlElemCData) then\r\n TStrings(Obj).Text := Elem.Items[0].Value\r\n else\r\n for I := 0 to Elem.Items.Count - 1 do\r\n begin\r\n J := Elem.Items[I].Properties.IntValue(cIndex, MaxInt);\r\n if J < TStrings(Obj).Count then\r\n TStrings(Obj).Strings[J] := Elem.Items[I].Properties.Value(cValue);\r\n end;\r\n end;\r\n\r\n procedure TransTreeNodes(const Obj: TObject; const Elem: TJvSimpleXMLElem);\r\n var\r\n I, J: Integer;\r\n begin\r\n for I := 0 to Elem.Items.Count - 1 do\r\n begin\r\n J := Elem.Items[I].Properties.IntValue(cIndex, MaxInt);\r\n if J < TTreeNodes(Obj).Count then\r\n TTreeNodes(Obj).Item[J].Text := Elem.Items[I].Properties.Value(cValue);\r\n end;\r\n end;\r\n\r\n procedure TransVars;\r\n var\r\n I, J: Integer;\r\n begin\r\n with TJvTranslatorStrings(Component) do\r\n for I := 0 to Elem.Items.Count - 1 do\r\n begin\r\n J := TJvTranslatorStrings(Component).IndexOf(Elem.Items[I].Properties.Value(cName));\r\n if J <> -1 then\r\n TJvTranslatorStrings(Component).Strings[J] := AnalyseCRLF(Elem.Items[I].Properties.Value(cValue));\r\n end;\r\n end;\r\n\r\n procedure TransListItems(const Obj: TObject; const Elem: TJvSimpleXMLElem);\r\n var\r\n I, J: Integer;\r\n begin\r\n for I := 0 to Elem.Items.Count - 1 do\r\n begin\r\n J := Elem.Items[I].Properties.IntValue(cIndex, MaxInt);\r\n if J < TListItems(Obj).Count then\r\n with TListItems(Obj).Item[J] do\r\n begin\r\n J := Elem.Items[I].Properties.IntValue(cColumn, MaxInt);\r\n if J = 0 then\r\n Caption := Elem.Items[I].Properties.Value(cValue)\r\n else\r\n begin\r\n Dec(J);\r\n if J < SubItems.Count then\r\n SubItems[J] := Elem.Items[I].Properties.Value(cValue);\r\n end;\r\n end;\r\n end;\r\n end;\r\n\r\n procedure TransProperties(const Obj: TObject; const Elem: TJvSimpleXMLElem);\r\n var\r\n I, J: Integer;\r\n PropInfo: PPropInfo;\r\n S: string;\r\n begin\r\n if Obj = nil then\r\n Exit;\r\n for I := 0 to Elem.Properties.Count - 1 do\r\n try\r\n PropInfo := GetPropInfo(Obj, Elem.Properties[I].Name, [tkInteger, tkEnumeration, tkSet] + tkStrings);\r\n if (PropInfo <> nil) and (PropInfo^.SetProc <> nil) and not InSkipList(Obj, Elem.Properties[I].Name) then\r\n case PropInfo^.PropType^.Kind of\r\n {$IFDEF UNICODE} tkUString, {$ENDIF}\r\n tkString, tkLString, tkWString:\r\n SetStrProp(Obj, PropInfo, StringReplace(Elem.Properties[I].Value, cNewline, sLineBreak, []));\r\n tkSet:\r\n SetSetProp(Obj, PropInfo, Elem.Properties[I].Value);\r\n tkEnumeration:\r\n begin\r\n S := Elem.Properties[I].Value;\r\n if (StrToIntDef(S, 0) = 0) and (S <> '0') then\r\n begin\r\n try\r\n J := GetEnumValue(PropInfo.PropType^, S);\r\n except\r\n J := 0;\r\n end;\r\n end\r\n else\r\n J := StrToIntDef(S, 0);\r\n SetOrdProp(Obj, PropInfo, J);\r\n end;\r\n tkInteger:\r\n if PropInfo^.Name = 'ShortCut' then\r\n SetOrdProp(Obj, PropInfo, TextToShortcut(Elem.Properties[I].Value))\r\n else\r\n SetOrdProp(Obj, PropInfo, Elem.Properties[I].IntValue);\r\n end;\r\n except\r\n end;\r\n end;\r\n\r\n procedure TranslateCollection(const Collection: TCollection; const Elem: TJvSimpleXMLElem);\r\n var\r\n I, J: Integer;\r\n begin\r\n if Obj = nil then\r\n Exit;\r\n for I := 0 to Elem.Items.Count - 1 do\r\n begin\r\n J := Elem.Items[I].Properties.IntValue(cIndex, -1);\r\n if J = -1 then\r\n Continue;\r\n if J < Collection.Count then\r\n begin\r\n TransProperties(Collection.Items[J], Elem.Items[I]);\r\n TransObject(Collection.Items[J], Elem.Items[I]);\r\n end;\r\n end;\r\n end;\r\n\r\n procedure TransObject(const Obj: TObject; const Elem: TJvSimpleXMLElem);\r\n var\r\n I, J: Integer;\r\n PropInfo: PPropInfo;\r\n S: string;\r\n lObj: TObject;\r\n begin\r\n if Obj = nil then\r\n Exit;\r\n if IsObject(Obj.ClassType, cTCollection) then\r\n TranslateCollection(TCollection(Obj), Elem)\r\n else\r\n for I := 0 to Elem.Items.Count - 1 do\r\n try\r\n PropInfo := GetPropInfo(Obj, Elem.Items[I].Name, [tkInteger, tkEnumeration, tkSet] + tkStrings);\r\n if (PropInfo <> nil) and (PropInfo^.SetProc <> nil) and not InSkipList(Obj, Elem.Items[I].Name) then\r\n case PropInfo^.PropType^.Kind of\r\n {$IFDEF UNICODE} tkUString, {$ENDIF}\r\n tkString, tkLString, tkWString:\r\n SetStrProp(Obj, PropInfo, StringReplace(Elem.Items[I].Value, cNewline, sLineBreak, []));\r\n tkSet:\r\n SetSetProp(Obj, PropInfo, Elem.Items[I].Value);\r\n tkEnumeration:\r\n begin\r\n S := Elem.Items[I].Value;\r\n if (StrToIntDef(S, 0) = 0) and (S <> '0') then\r\n begin\r\n try\r\n J := GetEnumValue(PropInfo.PropType^, S);\r\n except\r\n J := 0;\r\n end;\r\n end\r\n else\r\n J := StrToIntDef(S, 0);\r\n SetOrdProp(Obj, PropInfo, J);\r\n end;\r\n tkInteger:\r\n SetOrdProp(Obj, PropInfo, Elem.Items[I].IntValue);\r\n tkClass:\r\n begin\r\n lObj := GetObjectProp(Obj, Elem.Items[I].Name);\r\n TransProperties(lObj, Elem.Items[I]);\r\n TransObject(lObj, Elem.Items[I]);\r\n end;\r\n end;\r\n except\r\n end;\r\n end;\r\n\r\nbegin\r\n if IsObject(Component.ClassType, cTJvTranslatorStrings) then\r\n begin\r\n TransVars;\r\n Exit;\r\n end;\r\n\r\n try\r\n //Transform properties\r\n if not InSkipList(Component) then\r\n TransProperties(Component, Elem);\r\n\r\n //Transform childs\r\n with Component do\r\n for I := 0 to Elem.Items.Count - 1 do\r\n begin\r\n Ok := False;\r\n for J := 0 to ComponentCount - 1 do\r\n begin\r\n S := LowerCase(Elem.Items[I].Name);\r\n if AnsiSameText(Components[J].Name, S) then\r\n begin\r\n TranslateComponent(Components[J], Elem.Items[I]);\r\n Ok := True;\r\n Break;\r\n end;\r\n end;\r\n if not Ok then\r\n begin\r\n PropInfo := GetPropInfo(Component, Elem.Items[I].Name, [tkUnknown, tkInteger, tkChar, tkEnumeration, tkFloat,\r\n tkSet, tkClass, tkMethod, tkWChar, tkVariant, tkArray, tkRecord,\r\n tkInterface, tkInt64, tkDynArray] + tkStrings);\r\n if (PropInfo <> nil) and (PropInfo^.SetProc <> nil) and not InSkipList(Component, Elem.Items[I].Name) then\r\n begin\r\n Obj := GetObjectProp(Component, Elem.Items[I].Name);\r\n if IsObject(Obj.ClassType, cTStrings) then\r\n TransStrings(Obj, Elem.Items[I])\r\n else\r\n if IsObject(Obj.ClassType, cTTreeNodes) then\r\n TransTreeNodes(Obj, Elem.Items[I])\r\n else\r\n if IsObject(Obj.ClassType, cTListItems) then\r\n TransListItems(Obj, Elem.Items[I])\r\n else\r\n begin\r\n TransProperties(Obj, Elem.Items[I]);\r\n TransObject(Obj, Elem.Items[I]);\r\n end;\r\n end;\r\n end;\r\n end;\r\n except\r\n end;\r\nend;\r\n\r\nprocedure TJvTranslator.Translate(const Form: TCustomForm);\r\nvar\r\n J: Integer;\r\n S: string;\r\n lElem: TJvSimpleXMLElem;\r\nbegin\r\n J := Pos('_', Form.Name);\r\n if J = 0 then\r\n S := Form.Name\r\n else\r\n S := Copy(Form.Name, 1, J - 1);\r\n lElem := FindItemNamed(nil, S, True);\r\n if lElem <> nil then\r\n TranslateComponent(Form, lElem)\r\nend;\r\n\r\nfunction TJvTranslator.Translate(const Category, Item: string): string;\r\nvar\r\n lElem: TJvSimpleXMLElem;\r\nbegin\r\n Result := '';\r\n lElem := FindItemNamed(nil, Category, True);\r\n if lElem <> nil then\r\n begin\r\n lElem := FindItemNamed(lElem, Item, True);\r\n if lElem <> nil then\r\n begin\r\n Result := lElem.Value;\r\n if Result = '' then\r\n Result := lElem.Properties.Value(cValue);\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvTranslator.SkipClass(AClass: TClass);\r\nbegin\r\n SkipProperty(AClass, '');\r\nend;\r\n\r\nprocedure TJvTranslator.UnskipClass(AClass: TClass);\r\nbegin\r\n UnskipProperty(AClass, '');\r\nend;\r\n\r\nfunction TJvTranslator.InSkipList(AClass: TClass): Boolean;\r\nbegin\r\n Result := InSkipList(AClass, '');\r\nend;\r\n\r\nfunction TJvTranslator.InSkipList(Obj: TObject): Boolean;\r\nbegin\r\n if Obj = nil then\r\n Result := InSkipList(TObject(nil))\r\n else\r\n Result := InSkipList(Obj.ClassType);\r\nend;\r\n\r\nfunction TJvTranslator.InSkipList(Obj: TObject; const PropName: string): Boolean;\r\nbegin\r\n if Obj = nil then\r\n Result := InSkipList(TObject(nil), PropName)\r\n else\r\n Result := InSkipList(Obj.ClassType, PropName);\r\nend;\r\n\r\nfunction TJvTranslator.InSkipList(AClass: TClass; const PropName: string): Boolean;\r\nvar\r\n I: Integer;\r\n P: PSkipPropRec;\r\nbegin\r\n Result := False;\r\n if FSkipList <> nil then\r\n for I := 0 to FSkipList.Count - 1 do\r\n begin\r\n P := PSkipPropRec(FSkipList[I]);\r\n if (P^.AClass = AClass) or AClass.InheritsFrom(P^.AClass) then\r\n begin\r\n if ((PropName = '') and (P^.AProps.Count = 0)) or (P^.AProps.IndexOf(PropName) > -1) then\r\n begin\r\n Result := True;\r\n if PropName = '' then\r\n // move item to beginning of list since it is very likely that we want to access this class very soon\r\n FSkipList.Move(I, 0);\r\n Break;\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvTranslator.Translate(const Stream: TStream; const Form: TCustomForm);\r\nbegin\r\n FXML.LoadFromStream(Stream);\r\n Translate(Form);\r\nend;\r\n\r\nprocedure TJvTranslator.TranslateString(const S: string);\r\nvar\r\n Stream: TStringStream;\r\nbegin\r\n Stream := TStringStream.Create(S);\r\n try\r\n Translate(Stream);\r\n finally\r\n Stream.Free;\r\n end;\r\nend;\r\n\r\nprocedure TJvTranslator.TranslateString(const S: string; const Form: TCustomForm);\r\nvar\r\n Stream: TStringStream;\r\nbegin\r\n Stream := TStringStream.Create(S);\r\n try\r\n Translate(Stream, Form);\r\n finally\r\n Stream.Free;\r\n end;\r\nend;\r\n\r\nprocedure TJvTranslator.TranslateScreenString(const S: string);\r\nvar\r\n Stream: TStringStream;\r\nbegin\r\n Stream := TStringStream.Create(S);\r\n try\r\n TranslateScreen(Stream);\r\n finally\r\n Stream.Free;\r\n end;\r\nend;\r\n\r\n//=== { TJvTranslatorStrings } ===============================================\r\n\r\nconstructor TJvTranslatorStrings.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FList := THashedStringList.Create;\r\nend;\r\n\r\ndestructor TJvTranslatorStrings.Destroy;\r\nbegin\r\n FList.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJvTranslatorStrings.Add(const Name: string; var Value: string): Integer;\r\nbegin\r\n // (rom) AddObject? Strange.\r\n Result := FList.AddObject(Name, TObject(@Value));\r\nend;\r\n\r\nfunction TJvTranslatorStrings.GetString(Index: Integer): string;\r\nbegin\r\n Result := FList[Index];\r\nend;\r\n\r\nfunction TJvTranslatorStrings.IndexOf(const Name: string): Integer;\r\nbegin\r\n Result := FList.IndexOf(Name);\r\nend;\r\n\r\nprocedure TJvTranslatorStrings.SetString(Index: Integer; const Value: string);\r\nbegin\r\n PString(FList.Objects[Index])^ := Value;\r\nend;\r\n\r\nfunction TJvTranslatorStrings.GetCount: Integer;\r\nbegin\r\n Result := FList.Count;\r\nend;\r\n\r\nfunction TJvTranslatorStrings.GetValue(Index: Integer): string;\r\nbegin\r\n if (Index >= 0) and (Index < Count) and (FList.Objects[Index] <> nil) then\r\n Result := PString(FList.Objects[Index])^\r\n else\r\n Result := '';\r\nend;\r\n\r\nprocedure TJvTranslator.SkipProperty(AClass: TClass; const PropName: string);\r\nvar\r\n I: Integer;\r\n P: PSkipPropRec;\r\nbegin\r\n if FSkipList = nil then\r\n FSkipList := TList.Create;\r\n for I := 0 to FSkipList.Count - 1 do\r\n if PSkipPropRec(FSkipList[I])^.AClass = AClass then\r\n begin\r\n P := PSkipPropRec(FSkipList[I]);\r\n if PropName = '' then\r\n P^.AProps.Clear // skip entire class\r\n else\r\n if P^.AProps.Count > 0 then // only add if the class is not skipped as a whole\r\n P^.AProps.Add(PropName); // the list is sorted, so property name will only be added once\r\n Exit;\r\n end;\r\n // class not found, so add new class record to list\r\n New(P);\r\n P^.AClass := AClass;\r\n P^.AProps := TStringList.Create;\r\n P^.AProps.Sorted := True;\r\n if PropName <> '' then\r\n P^.AProps.Add(PropName); // skip this property only\r\n FSkipList.Add(P);\r\n if AClass.InheritsFrom(TPersistent) then\r\n Classes.RegisterClass(TPersistentClass(AClass));\r\nend;\r\n\r\nprocedure TJvTranslator.UnskipProperty(AClass: TClass; const PropName: string);\r\nvar\r\n I, J: Integer;\r\n P: PSkipPropRec;\r\nbegin\r\n if FSkipList <> nil then\r\n begin\r\n for I := 0 to FSkipList.Count - 1 do\r\n if PSkipPropRec(FSkipList[I])^.AClass = AClass then\r\n begin\r\n P := PSkipPropRec(FSkipList[I]);\r\n if PropName <> '' then\r\n J := P^.AProps.IndexOf(PropName)\r\n else\r\n begin\r\n J := -1;\r\n P^.AProps.Clear;\r\n end;\r\n if J > -1 then\r\n P^.AProps.Delete(J);\r\n if P^.AProps.Count = 0 then\r\n // remove the entry when there are no properties skipped or if this is a UnskipClass call\r\n begin\r\n P^.AProps.Free;\r\n FSkipList.Delete(I);\r\n Dispose(P);\r\n end;\r\n if FSkipList.Count = 0 then\r\n FreeAndNil(FSkipList);\r\n Break;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvTranslator.ClearSkipList;\r\nvar\r\n I: Integer;\r\nbegin\r\n if FSkipList <> nil then\r\n begin\r\n for I := 0 to FSkipList.Count - 1 do\r\n begin\r\n PSkipPropRec(FSkipList[I]).AProps.Free;\r\n Dispose(PSkipPropRec(FSkipList[I]));\r\n end;\r\n FreeAndNil(FSkipList);\r\n end;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvTransparentButton.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvTransparentButton.PAS, released on 2002-05-26.\r\n\r\nThe Initial Developer of the Original Code is Peter Thrnqvist [peter3 at sourceforge dot net]\r\nPortions created by Peter Thrnqvist are Copyright (C) 2002 Peter Thrnqvist.\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\n Andreas Hausladen (refactored)\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvTransparentButton.pas 13415 2012-09-10 09:51:54Z obones $\r\n\r\nunit JvTransparentButton;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n SysUtils, Classes,\r\n Windows, Messages, Graphics, Controls,\r\n ExtCtrls, Menus, Forms, ImgList, ActnList, Buttons,\r\n CommCtrl,\r\n {$IFDEF HAS_UNIT_SYSTEM_UITYPES}\r\n System.UITypes,\r\n {$ENDIF HAS_UNIT_SYSTEM_UITYPES}\r\n JvJCLUtils, JvButton;\r\n\r\ntype\r\n TJvFrameStyle =\r\n (fsRegular, fsIndent, fsExplorer, fsNone, fsLight, fsDark, fsMono);\r\n TJvTextAlign = (ttaTopLeft, ttaTop, ttaTopRight, ttaRight, ttaBottomRight,\r\n ttaBottom, ttaBottomLeft, ttaLeft, ttaCenter);\r\n\r\ntype\r\n TJvTransparentButtonActionLink = class(TControlActionLink)\r\n protected\r\n FClient: TJvCustomGraphicButton;\r\n procedure AssignClient(AClient: TObject); override;\r\n function IsCheckedLinked: Boolean; override;\r\n function IsGroupIndexLinked: Boolean; override;\r\n procedure SetGroupIndex(Value: Integer); override;\r\n procedure SetChecked(Value: Boolean); override;\r\n procedure SetImageIndex(Value: Integer); override;\r\n end;\r\n\r\n TJvTransparentButton = class;\r\n\r\n TJvTransparentButtonImages = class(TPersistent)\r\n private\r\n FButton: TJvTransparentButton;\r\n\r\n FGrayList: TCustomImageList;\r\n FActiveList: TCustomImageList;\r\n FDisabledList: TCustomImageList;\r\n FDownList: TCustomImageList;\r\n FHotList: TCustomImageList;\r\n FGrayLink: TChangeLink;\r\n FActiveLink: TChangeLink;\r\n FDisabledLink: TChangeLink;\r\n FDownLink: TChangeLink;\r\n FHotLink: TChangeLink;\r\n FGrayIndex: TImageIndex;\r\n FActiveIndex: TImageIndex;\r\n FDisabledIndex: TImageIndex;\r\n FDownIndex: TImageIndex;\r\n FHotIndex: TImageIndex;\r\n procedure SetGrayList(Value: TCustomImageList);\r\n procedure SetActiveList(Value: TCustomImageList);\r\n procedure SetDisabledList(Value: TCustomImageList);\r\n procedure SetDownList(Value: TCustomImageList);\r\n procedure SetHotList(Value: TCustomImageList);\r\n procedure SetGrayIndex(Value: TImageIndex);\r\n procedure SetActiveIndex(Value: TImageIndex);\r\n procedure SetDisabledIndex(Value: TImageIndex);\r\n procedure SetDownIndex(Value: TImageIndex);\r\n procedure SetHotIndex(Value: TImageIndex);\r\n protected\r\n procedure AddGlyphs;\r\n procedure SetImageList(var List: TCustomImageList; Link: TChangeLink;\r\n Value: TCustomImageList);\r\n public\r\n constructor Create(AButton: TJvTransparentButton);\r\n destructor Destroy; override;\r\n procedure Assign(Source: TPersistent); override;\r\n published\r\n property ActiveImage: TCustomImageList read FActiveList write SetActiveList;\r\n property ActiveIndex: TImageIndex read FActiveIndex write SetActiveIndex default -1;\r\n property GrayImage: TCustomImageList read FGrayList write SetGrayList;\r\n property GrayIndex: TImageIndex read FGrayIndex write SetGrayIndex default -1;\r\n property DisabledImage: TCustomImageList read FDisabledList write SetDisabledList;\r\n property DisabledIndex: TImageIndex read FDisabledIndex write SetDisabledIndex default -1;\r\n property DownImage: TCustomImageList read FDownList write SetDownList;\r\n property DownIndex: TImageIndex read FDownIndex write SetDownIndex default -1;\r\n property HotImage: TCustomImageList read FHotList write SetHotList;\r\n property HotIndex: TImageIndex read FHotIndex write SetHotIndex default -1;\r\n end;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvTransparentButton = class(TJvCustomGraphicButton)\r\n private\r\n FTextAlign: TJvTextAlign;\r\n FAutoGray: Boolean;\r\n FTransparent: Boolean;\r\n FShowPressed: Boolean;\r\n FPressOffset: Integer;\r\n FSpacing: Integer;\r\n FBorderSize: Cardinal;\r\n FImList: TCustomImageList;\r\n FOutline: TJvFrameStyle;\r\n FWordWrap: Boolean;\r\n\r\n FGlyph: TBitmap;\r\n FGrayGlyph: TBitmap;\r\n FDisabledGlyph: TBitmap;\r\n FNumGlyphs: TNumGlyphs;\r\n FKeepMouseLeavePressed: Boolean;\r\n FImages: TJvTransparentButtonImages;\r\n FGlyphStretched: Boolean;\r\n procedure SetGlyph(Bmp: TBitmap);\r\n procedure SetNumGlyphs(Value: TNumGlyphs);\r\n procedure CalcGlyphCount;\r\n procedure SetImages(Value: TJvTransparentButtonImages);\r\n\r\n procedure SetWordWrap(Value: Boolean);\r\n procedure SetSpacing(Value: Integer);\r\n procedure SetAutoGray(Value: Boolean);\r\n procedure SetTextAlign(Value: TJvTextAlign);\r\n procedure SetFrameStyle(Value: TJvFrameStyle);\r\n procedure SetTransparent(Value: Boolean);\r\n procedure SetBorderWidth(Value: Cardinal);\r\n function GetUseImages: Boolean;\r\n procedure SetGlyphStretched(const Value: Boolean);\r\n protected\r\n procedure PaintButton(Canvas: TCanvas); override;\r\n procedure PaintFrame(Canvas: TCanvas); override;\r\n procedure DrawTheText(ARect: TRect; Canvas: TCanvas); virtual;\r\n procedure DrawTheBitmap(ARect: TRect; Canvas: TCanvas); virtual;\r\n function GetActionLinkClass: TControlActionLinkClass; override;\r\n procedure GlyphChanged(Sender: TObject);\r\n\r\n procedure AddGlyphGlyphs(AGlyph: TBitmap; AColor: TColor; Value: Integer);\r\n procedure ActionChange(Sender: TObject; CheckDefaults: Boolean); override;\r\n\r\n procedure Notification(AComponent: TComponent; Operation: TOperation); override;\r\n procedure AddImageGlyphs;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n\r\n property InternalList: TCustomImageList read FImList;\r\n property Canvas;\r\n property UseImages: Boolean read GetUseImages;\r\n published\r\n property Action;\r\n property AllowAllUp;\r\n property Align;\r\n property Anchors;\r\n property Constraints;\r\n\r\n property AutoGray: Boolean read FAutoGray write SetAutoGray default True;\r\n property BorderWidth: Cardinal read FBorderSize write SetBorderWidth default 1;\r\n property Caption;\r\n property Color;\r\n property DropDownMenu;\r\n property DropArrow;\r\n property Down;\r\n property Enabled;\r\n property Font;\r\n property GroupIndex;\r\n property HotTrack;\r\n property HotTrackFont;\r\n property HotTrackFontOptions;\r\n\r\n property FrameStyle: TJvFrameStyle read FOutline write SetFrameStyle default fsExplorer;\r\n property ParentFont;\r\n property ParentShowHint;\r\n property PopupMenu;\r\n property ShowHint;\r\n property ShowPressed: Boolean read FShowPressed write FShowPressed default True;\r\n property PressOffset: Integer read FPressOffset write FPressOffset default 1;\r\n property Spacing: Integer read FSpacing write SetSpacing default 2;\r\n property TextAlign: TJvTextAlign read FTextAlign write SetTextAlign default ttaCenter;\r\n property Transparent: Boolean read FTransparent write SetTransparent default True;\r\n property Visible;\r\n property WordWrap: Boolean read FWordWrap write SetWordWrap default False;\r\n\r\n property OnClick;\r\n property OnDragDrop;\r\n property OnDropDownMenu;\r\n property OnDragOver;\r\n property OnEndDrag;\r\n property OnMouseDown;\r\n property OnMouseMove;\r\n property OnMouseUp;\r\n property OnMouseEnter;\r\n property OnMouseLeave;\r\n property OnParentColorChange;\r\n property OnStartDrag;\r\n\r\n property Glyph: TBitmap read FGlyph write SetGlyph;\r\n property GlyphStretched: Boolean read FGlyphStretched write SetGlyphStretched default False;\r\n property NumGlyphs: TNumGlyphs read FNumGlyphs write SetNumGlyphs default 1;\r\n property KeepMouseLeavePressed: Boolean read FKeepMouseLeavePressed write FKeepMouseLeavePressed default False;\r\n property Images: TJvTransparentButtonImages read FImages write SetImages;\r\n end;\r\n\r\n{ SLOW! don't use in realtime! }\r\nprocedure GrayBitmap(Bmp: TBitmap; R, G, B: Integer);\r\nprocedure DisabledBitmap(Bmp: TBitmap);\r\nprocedure MonoBitmap(Bmp: TBitmap; R, G, B: Integer);\r\nprocedure BWBitmap(Bmp: TBitmap);\r\n\r\nfunction DrawDisabledText(DC: HDC; Caption: TCaption; nCount: Integer;\r\n var lpRect: TRect; uFormat: Integer): Integer;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvTransparentButton.pas $';\r\n Revision: '$Revision: 13415 $';\r\n Date: '$Date: 2012-09-10 11:51:54 +0200 (lun. 10 sept. 2012) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n JvConsts;\r\n\r\n{ create a grayed version of a color bitmap }\r\n{ SLOW! don't use in realtime! }\r\n\r\nprocedure GrayBitmap(Bmp: TBitmap; R, G, B: Integer);\r\nvar\r\n I, J: Integer;\r\n Col: Longint;\r\n DC: HDC;\r\nbegin\r\n if Bmp.Empty then\r\n Exit;\r\n DC := Bmp.Canvas.Handle;\r\n for I := 0 to Bmp.Width do\r\n for J := 0 to Bmp.Height do\r\n begin\r\n //Col := Bmp.Canvas.Pixels[I, J];\r\n Col := GetPixel(DC, I, J);\r\n Col := (GetRValue(Col) * R + GetGValue(Col) * G + GetBValue(Col) * B) div (R + G + B);\r\n //Bmp.Canvas.Pixels[I, J] := RGB(Col, Col, Col);\r\n SetPixel(DC, I, J, RGB(Col, Col, Col));\r\n end;\r\nend;\r\n\r\n{ create a grayed version of a color bitmap }\r\n{ SLOW! don't use in realtime! }\r\n\r\nprocedure MonoBitmap(Bmp: TBitmap; R, G, B: Integer);\r\nvar\r\n I, J: Integer;\r\n Col: Longint;\r\n DC: HDC;\r\nbegin\r\n if Bmp.Empty then\r\n Exit;\r\n DC := Bmp.Canvas.Handle;\r\n for I := 0 to Bmp.Width do\r\n for J := 0 to Bmp.Height do\r\n begin\r\n //Col := Bmp.Canvas.Pixels[I, J];\r\n Col := GetPixel(DC, I, J);\r\n Col := (GetRValue(Col) * R + GetGValue(Col) * G + GetBValue(Col) * B) div (R + G + B);\r\n //Bmp.Canvas.Pixels[I, J] := RGB(Col, Col, Col);\r\n SetPixel(DC, I, J, RGB(Col, Col, Col));\r\n end;\r\nend;\r\n\r\n{ create a disabled bitmap from a regular one, works best when bitmap has been\r\n reduced to a few colors. Used by BWBitmap }\r\n\r\nprocedure DisabledBitmap(Bmp: TBitmap);\r\nvar\r\n MonoBmp, TmpImage: TBitmap;\r\n W, H: Integer;\r\nbegin\r\n if Bmp.Empty then\r\n Exit;\r\n MonoBmp := TBitmap.Create;\r\n TmpImage := TBitmap.Create;\r\n W := Bmp.Width;\r\n H := Bmp.Height;\r\n\r\n with TmpImage do\r\n begin\r\n Width := W;\r\n Height := H;\r\n Canvas.Brush.Color := clBtnFace;\r\n end;\r\n\r\n try\r\n with MonoBmp do\r\n begin\r\n Assign(Bmp);\r\n Canvas.Font.Color := clWhite;\r\n Canvas.Brush.Color := clBlack;\r\n Monochrome := True;\r\n end;\r\n\r\n with TmpImage.Canvas do\r\n begin\r\n Brush.Color := clBtnFace;\r\n FillRect(Rect(0, 0, W, H));\r\n Brush.Color := clBtnHighlight;\r\n SetTextColor(Handle, clBlack);\r\n SetBkColor(Handle, clWhite);\r\n BitBlt(Handle, 1, 1, W + 1, H + 1, MonoBmp.Canvas.Handle, 0, 0, ROP_DSPDxax);\r\n Brush.Color := clBtnShadow;\r\n SetTextColor(Handle, clBlack);\r\n SetBkColor(Handle, clWhite);\r\n BitBlt(Handle, 0, 0, W, H, MonoBmp.Canvas.Handle, 0, 0, ROP_DSPDxax);\r\n end;\r\n Bmp.Assign(TmpImage);\r\n finally\r\n MonoBmp.Free;\r\n TmpImage.Free;\r\n end;\r\nend;\r\n\r\n{ create a disabled bitmap by changing all colors to either black or TopLeftCol and then\r\n running it through DisabledBitmap }\r\n{ SLOW! don't use in realtime! }\r\n\r\nprocedure BWBitmap(Bmp: TBitmap);\r\nvar\r\n I, J, W, H: Integer;\r\n TopLeftCol: TColor;\r\n Col: Longint;\r\n DC: HDC;\r\nbegin\r\n if Bmp.Empty then\r\n Exit;\r\n\r\n W := Bmp.Width;\r\n H := Bmp.Height;\r\n TopLeftCol := Bmp.Canvas.Pixels[0, 0];\r\n\r\n DC := Bmp.Canvas.Handle;\r\n for I := 0 to W do\r\n for J := 0 to H do\r\n begin\r\n //Col := Bmp.Canvas.Pixels[I, J];\r\n Col := GetPixel(DC, I, J);\r\n if (Col <> clWhite) and (Col <> TopLeftCol) then\r\n Col := clBlack\r\n else\r\n Col := TopLeftCol;\r\n //Bmp.Canvas.Pixels[I, J] := Col;\r\n SetPixel(DC, I, J, Col);\r\n end;\r\n DisabledBitmap(Bmp);\r\nend;\r\n\r\n{ just like DrawText, but draws disabled instead }\r\n\r\nfunction DrawDisabledText(DC: HDC; Caption: TCaption; nCount: Integer;\r\n var lpRect: TRect; uFormat: Integer): Integer;\r\nvar\r\n OldCol: Integer;\r\nbegin\r\n OldCol := SetTextColor(DC, ColorToRGB(clBtnHighlight));\r\n OffsetRect(lpRect, 1, 1);\r\n DrawText(DC, Caption, nCount, lpRect, uFormat);\r\n OffsetRect(lpRect, -1, -1);\r\n SetTextColor(DC, ColorToRGB(clBtnShadow));\r\n Result := DrawText(DC, Caption, nCount, lpRect, uFormat);\r\n SetTextColor(DC, OldCol);\r\nend;\r\n\r\n//=== { TJvTransparentButtonActionLink } =====================================\r\n\r\nprocedure TJvTransparentButtonActionLink.AssignClient(AClient: TObject);\r\nbegin\r\n inherited AssignClient(AClient);\r\n FClient := AClient as TJvCustomGraphicButton;\r\nend;\r\n\r\nfunction TJvTransparentButtonActionLink.IsCheckedLinked: Boolean;\r\nbegin\r\n if FClient is TJvTransparentButton then\r\n Result := inherited IsCheckedLinked and (TJvTransparentButton(FClient).Down = (Action as TCustomAction).Checked)\r\n else\r\n Result := False;\r\nend;\r\n\r\nfunction TJvTransparentButtonActionLink.IsGroupIndexLinked: Boolean;\r\nbegin\r\n Result := False;\r\nend;\r\n\r\nprocedure TJvTransparentButtonActionLink.SetGroupIndex(Value: Integer);\r\nbegin\r\nend;\r\n\r\nprocedure TJvTransparentButtonActionLink.SetChecked(Value: Boolean);\r\nbegin\r\n if IsCheckedLinked and (FClient is TJvTransparentButton) then\r\n TJvTransparentButton(FClient).Down := Value;\r\nend;\r\n\r\nprocedure TJvTransparentButtonActionLink.SetImageIndex(Value: Integer);\r\nbegin\r\n // Force updating the image indexes when the action changes its own value\r\n if (FClient is TJvTransparentButton) then\r\n begin\r\n TJvTransparentButton(FClient).Images.ActiveIndex := Value;\r\n TJvTransparentButton(FClient).Images.GrayIndex := Value;\r\n TJvTransparentButton(FClient).Images.DisabledIndex := Value;\r\n TJvTransparentButton(FClient).Images.DownIndex := Value;\r\n TJvTransparentButton(FClient).Images.HotIndex := Value;\r\n end;\r\nend;\r\n\r\n//=== { TJvTransparentButtonImages } =========================================\r\n\r\nconstructor TJvTransparentButtonImages.Create(AButton: TJvTransparentButton);\r\nbegin\r\n inherited Create;\r\n FButton := AButton;\r\n\r\n FGrayLink := TChangeLink.Create;\r\n FGrayLink.OnChange := AButton.GlyphChanged;\r\n\r\n FActiveLink := TChangeLink.Create;\r\n FActiveLink.OnChange := AButton.GlyphChanged;\r\n\r\n FDisabledLink := TChangeLink.Create;\r\n FDisabledLink.OnChange := AButton.GlyphChanged;\r\n\r\n FDownLink := TChangeLink.Create;\r\n FDownLink.OnChange := AButton.GlyphChanged;\r\n\r\n FHotLink := TChangeLink.Create;\r\n FHotLink.OnChange := AButton.GlyphChanged;\r\n\r\n FActiveIndex := -1;\r\n FDisabledIndex := -1;\r\n FDownIndex := -1;\r\n FGrayIndex := -1;\r\n FHotIndex := -1;\r\nend;\r\n\r\ndestructor TJvTransparentButtonImages.Destroy;\r\nbegin\r\n FGrayLink.Free;\r\n FActiveLink.Free;\r\n FDisabledLink.Free;\r\n FDownLink.Free;\r\n FHotLink.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvTransparentButtonImages.Assign(Source: TPersistent);\r\nvar\r\n Src: TJvTransparentButtonImages;\r\nbegin\r\n if Source is TJvTransparentButtonImages then\r\n begin\r\n Src := TJvTransparentButtonImages(Source);\r\n\r\n ActiveImage := Src.ActiveImage;\r\n GrayImage := Src.GrayImage;\r\n DisabledImage := Src.DisabledImage;\r\n DownImage := Src.DownImage;\r\n HotImage := Src.HotImage;\r\n\r\n ActiveIndex := Src.ActiveIndex;\r\n GrayIndex := Src.GrayIndex;\r\n DisabledIndex := Src.DisabledIndex;\r\n DownIndex := Src.DownIndex;\r\n HotIndex := Src.HotIndex;\r\n end\r\n else\r\n inherited Assign(Source);\r\nend;\r\n\r\nprocedure TJvTransparentButtonImages.AddGlyphs;\r\nbegin\r\n FButton.AddImageGlyphs;\r\nend;\r\n\r\nprocedure TJvTransparentButtonImages.SetImageList(var List: TCustomImageList; Link: TChangeLink;\r\n Value: TCustomImageList);\r\nbegin\r\n if Value <> List then\r\n begin\r\n if Assigned(List) then\r\n List.UnRegisterChanges(Link);\r\n List := Value;\r\n if Assigned(List) then\r\n List.RegisterChanges(Link);\r\n AddGlyphs;\r\n end;\r\nend;\r\n\r\nprocedure TJvTransparentButtonImages.SetGrayList(Value: TCustomImageList);\r\nbegin\r\n SetImageList(FGrayList, FGrayLink, Value);\r\nend;\r\n\r\nprocedure TJvTransparentButtonImages.SetActiveList(Value: TCustomImageList);\r\nbegin\r\n SetImageList(FActiveList, FActiveLink, Value);\r\nend;\r\n\r\nprocedure TJvTransparentButtonImages.SetDisabledList(Value: TCustomImageList);\r\nbegin\r\n SetImageList(FDisabledList, FDisabledLink, Value);\r\nend;\r\n\r\nprocedure TJvTransparentButtonImages.SetDownList(Value: TCustomImageList);\r\nbegin\r\n SetImageList(FDownList, FDownLink, Value);\r\nend;\r\n\r\nprocedure TJvTransparentButtonImages.SetHotList(Value: TCustomImageList);\r\nbegin\r\n SetImageList(FHotList, FHotLink, Value);\r\nend;\r\n\r\nprocedure TJvTransparentButtonImages.SetGrayIndex(Value: TImageIndex);\r\nbegin\r\n if FGrayIndex <> Value then\r\n begin\r\n FGrayIndex := Value;\r\n AddGlyphs;\r\n end;\r\nend;\r\n\r\nprocedure TJvTransparentButtonImages.SetActiveIndex(Value: TImageIndex);\r\nbegin\r\n if FActiveIndex <> Value then\r\n begin\r\n FActiveIndex := Value;\r\n AddGlyphs;\r\n end;\r\nend;\r\n\r\nprocedure TJvTransparentButtonImages.SetDisabledIndex(Value: TImageIndex);\r\nbegin\r\n if FDisabledIndex <> Value then\r\n begin\r\n FDisabledIndex := Value;\r\n AddGlyphs;\r\n end;\r\nend;\r\n\r\nprocedure TJvTransparentButtonImages.SetDownIndex(Value: TImageIndex);\r\nbegin\r\n if FDownIndex <> Value then\r\n begin\r\n FDownIndex := Value;\r\n AddGlyphs;\r\n end;\r\nend;\r\n\r\nprocedure TJvTransparentButtonImages.SetHotIndex(Value: TImageIndex);\r\nbegin\r\n if FHotIndex <> Value then\r\n begin\r\n FHotIndex := Value;\r\n AddGlyphs;\r\n end;\r\nend;\r\n\r\n//=== { TJvTransparentButton } ===============================================\r\n\r\nconstructor TJvTransparentButton.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FAutoGray := True;\r\n FShowPressed := True;\r\n FBorderSize := 1;\r\n FTransparent := True;\r\n\r\n FImList := TImageList.Create(Self);\r\n FPressOffset := 1;\r\n FSpacing := 2;\r\n FTextAlign := ttaCenter;\r\n FWordWrap := False;\r\n FOutline := fsExplorer;\r\n\r\n FImages := TJvTransparentButtonImages.Create(Self);\r\n\r\n FNumGlyphs := 1;\r\n FGlyph := TBitmap.Create;\r\n FGrayGlyph := TBitmap.Create;\r\n FDisabledGlyph := TBitmap.Create;\r\n FGlyph.OnChange := GlyphChanged;\r\n FNumGlyphs := 1;\r\n\r\n // obones: removed, it goes against the default values set in the ancestor\r\n // and will force them to be true when loading from a DFM.\r\n //AllowAllUp := True;\r\n //Flat := True;\r\nend;\r\n\r\ndestructor TJvTransparentButton.Destroy;\r\nbegin\r\n FreeAndNil(FGlyph);\r\n FreeAndNil(FGrayGlyph);\r\n FreeAndNil(FDisabledGlyph);\r\n FreeAndNil(FImages);\r\n // FImList.Free; // owner-destroyed\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvTransparentButton.Notification(AComponent: TComponent; Operation: TOperation);\r\nbegin\r\n inherited Notification(AComponent, Operation);\r\n if (Operation = opRemove) and (FImages <> nil) then\r\n begin\r\n if AComponent = FImages.FGrayList then\r\n FImages.GrayImage := nil;\r\n if AComponent = FImages.FActiveList then\r\n FImages.ActiveImage := nil;\r\n if AComponent = FImages.FDisabledList then\r\n FImages.DisabledImage := nil;\r\n if AComponent = FImages.FDownList then\r\n FImages.DownImage := nil;\r\n if AComponent = FImages.FHotList then\r\n FImages.HotImage := nil;\r\n end;\r\nend;\r\n\r\nfunction TJvTransparentButton.GetActionLinkClass: TControlActionLinkClass;\r\nbegin\r\n Result := TJvTransparentButtonActionLink;\r\nend;\r\n\r\nprocedure TJvTransparentButton.SetFrameStyle(Value: TJvFrameStyle);\r\nbegin\r\n if FOutline <> Value then\r\n begin\r\n FOutline := Value;\r\n Flat := FTransparent;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvTransparentButton.SetTransparent(Value: Boolean);\r\nbegin\r\n if FTransparent <> Value then\r\n begin\r\n FTransparent := Value;\r\n Flat := FTransparent;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvTransparentButton.SetBorderWidth(Value: Cardinal);\r\nbegin\r\n if FBorderSize <> Value then\r\n begin\r\n FBorderSize := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvTransparentButton.SetWordWrap(Value: Boolean);\r\nbegin\r\n if FWordWrap <> Value then\r\n begin\r\n FWordWrap := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvTransparentButton.SetSpacing(Value: Integer);\r\nbegin\r\n if FSpacing <> Value then\r\n begin\r\n FSpacing := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvTransparentButton.SetAutoGray(Value: Boolean);\r\nbegin\r\n if FAutoGray <> Value then\r\n begin\r\n FAutoGray := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvTransparentButton.SetTextAlign(Value: TJvTextAlign);\r\nbegin\r\n if FTextAlign <> Value then\r\n begin\r\n FTextAlign := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\n{ paint everything but bitmap and text }\r\n\r\nprocedure TJvTransparentButton.PaintFrame(Canvas: TCanvas);\r\nvar\r\n TmpRect: TRect;\r\n DrawIt: Boolean;\r\nbegin\r\n TmpRect := Rect(0, 0, Width, Height);\r\n { draw the outline }\r\n with Canvas do\r\n begin\r\n Brush.Color := Color;\r\n Pen.Color := clBlack;\r\n Pen.Width := BorderWidth;\r\n\r\n case FrameStyle of\r\n fsNone:\r\n begin\r\n if not Transparent then\r\n FillRect(Rect(0, 0, Width, Height));\r\n if csDesigning in ComponentState then\r\n Frame3D(Canvas, TmpRect, clBlack, clBlack, 1);\r\n end;\r\n fsExplorer:\r\n begin\r\n if not Transparent then\r\n FillRect(Rect(0, 0, Width, Height));\r\n Frame3D(Canvas, TmpRect, clBtnHighlight, clBtnShadow, 1);\r\n end;\r\n fsRegular:\r\n begin\r\n { draw outline }\r\n Pen.Color := clBlack;\r\n if not Transparent then\r\n Rectangle(1, 1, Width, Height)\r\n else\r\n begin\r\n TmpRect := Rect(1, 1, Width, Height);\r\n Frame3D(Canvas, TmpRect, clBlack, clBlack, BorderWidth);\r\n end;\r\n end;\r\n fsIndent:\r\n begin\r\n { draw outline }\r\n Pen.Color := clBtnShadow;\r\n if not Transparent then\r\n Rectangle(0, 0, Width - 1, Height - 1)\r\n else\r\n begin\r\n TmpRect := Rect(0, 0, Width - 1, Height - 1);\r\n Frame3D(Canvas, TmpRect, clBtnShadow, clBtnShadow, BorderWidth)\r\n end;\r\n TmpRect := Rect(1, 1, Width, Height);\r\n Frame3D(Canvas, TmpRect, clBtnHighlight, clBtnHighlight, BorderWidth);\r\n end;\r\n fsLight:\r\n begin\r\n if not Transparent then\r\n FillRect(Rect(0, 0, Width, Height));\r\n if csDesigning in ComponentState then\r\n Frame3D(Canvas, TmpRect, clBtnHighlight, clBtnShadow, 1);\r\n end;\r\n fsDark:\r\n begin\r\n if not Transparent then\r\n FillRect(Rect(0, 0, Width, Height));\r\n if csDesigning in ComponentState then\r\n Frame3D(Canvas, TmpRect, clBtnFace, cl3DDkShadow, 1);\r\n end;\r\n fsMono:\r\n begin\r\n if not Transparent then\r\n FillRect(Rect(0, 0, Width, Height));\r\n if csDesigning in ComponentState then\r\n Frame3D(Canvas, TmpRect, clBtnHighlight, cl3DDkShadow, 1);\r\n end;\r\n end;\r\n\r\n TmpRect := Rect(1, 1, Width - 1, Height - 1);\r\n\r\n if (bsMouseDown in MouseStates) or Down then\r\n begin\r\n if FrameStyle <> fsNone then\r\n begin\r\n InflateRect(TmpRect, 1, 1);\r\n case FrameStyle of\r\n fsRegular:\r\n if ShowPressed then\r\n begin\r\n Frame3D(Canvas, TmpRect, clBlack, clBtnHighlight, BorderWidth);\r\n Frame3D(Canvas, TmpRect, clBtnShadow, clBtnFace, BorderWidth);\r\n end;\r\n fsExplorer:\r\n if (bsMouseInside in MouseStates) or Down then\r\n begin\r\n if ShowPressed then\r\n Frame3D(Canvas, TmpRect, clBtnShadow, clBtnHighlight, BorderWidth)\r\n else\r\n Frame3D(Canvas, TmpRect, clBtnHighlight, clBtnShadow, BorderWidth);\r\n end;\r\n fsIndent:\r\n if ShowPressed then\r\n begin\r\n Frame3D(Canvas, TmpRect, clBlack, clBtnHighlight, BorderWidth);\r\n Frame3D(Canvas, TmpRect, clBtnShadow, clBtnFace, BorderWidth);\r\n end;\r\n fsLight:\r\n if ShowPressed then\r\n Frame3D(Canvas, TmpRect, clBtnShadow, clBtnHighlight, 1);\r\n fsDark:\r\n if ShowPressed then\r\n Frame3D(Canvas, TmpRect, cl3DDkShadow, clBtnFace, 1);\r\n fsMono:\r\n if ShowPressed then\r\n Frame3D(Canvas, TmpRect, cl3DDkShadow, clBtnHighlight, 1);\r\n end;\r\n end;\r\n end\r\n else\r\n begin\r\n DrawIt := ((bsMouseInside in MouseStates) and Transparent) or not Transparent or (csDesigning in ComponentState);\r\n InflateRect(TmpRect, 1, 1);\r\n case FrameStyle of\r\n fsNone:\r\n if csDesigning in ComponentState then\r\n Frame3D(Canvas, TmpRect, clBlack, clBlack, 1);\r\n fsRegular:\r\n if DrawIt then\r\n begin\r\n Frame3D(Canvas, TmpRect, clBtnHighlight, clBlack, BorderWidth);\r\n Frame3D(Canvas, TmpRect, RGB(223, 223, 223), clBtnShadow, BorderWidth);\r\n end;\r\n fsExplorer:\r\n if (bsMouseInside in MouseStates) or (csDesigning in ComponentState) then\r\n Frame3D(Canvas, TmpRect, clBtnHighlight, clBtnShadow, BorderWidth);\r\n fsIndent:\r\n if DrawIt then\r\n begin\r\n Frame3D(Canvas, TmpRect, clBtnShadow, clBtnHighlight, BorderWidth);\r\n Frame3D(Canvas, TmpRect, clBtnHighlight, clBtnShadow, BorderWidth);\r\n end;\r\n fsLight:\r\n if DrawIt then\r\n Frame3D(Canvas, TmpRect, clBtnHighlight, clBtnShadow, 1);\r\n fsDark:\r\n if DrawIt then\r\n Frame3D(Canvas, TmpRect, clBtnFace, cl3DDkShadow, 1);\r\n fsMono:\r\n if DrawIt then\r\n Frame3D(Canvas, TmpRect, clBtnHighlight, cl3DDkShadow, 1);\r\n end;\r\n end;\r\n\r\n if (HotTrackFont <> Font) and (Caption <> '') then\r\n begin\r\n InflateRect(TmpRect, 1, 1);\r\n DrawTheText(TmpRect, Canvas);\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvTransparentButton.PaintButton(Canvas: TCanvas);\r\nvar\r\n Dest: TRect;\r\n TmpWidth: Integer;\r\nbegin\r\n with Canvas do\r\n begin\r\n { find glyph bounding rect - adjust according to textalignment}\r\n TmpWidth := FImList.Width;\r\n if TmpWidth <= 0 then\r\n TmpWidth := FImList.Width;\r\n\r\n { do top }\r\n if Self.TextAlign in [ttaBottomLeft, ttaBottom, ttaBottomRight] then\r\n Dest.Top := Spacing\r\n else\r\n if Self.TextAlign in [ttaTopLeft, ttaTop, ttaTopRight] then\r\n Dest.Top := Height - FImList.Height - Spacing\r\n else\r\n Dest.Top := (Height - FImList.Height) div 2;\r\n\r\n { do left }\r\n if Self.TextAlign = ttaLeft then\r\n Dest.Left := Width - TmpWidth - Spacing\r\n else\r\n if Self.TextAlign = ttaRight then\r\n Dest.Left := Spacing\r\n else { left, center, right }\r\n Dest.Left := (Width - TmpWidth) div 2;\r\n {\r\n if Dest.Top < Spacing then Dest.Top := Spacing;\r\n if Dest.Left < Spacing then Dest.Left := Spacing;\r\n }\r\n Dest.Bottom := Dest.Top + FImList.Height;\r\n Dest.Right := Dest.Left + TmpWidth;\r\n {\r\n if Dest.Bottom > Height - Spacing then\r\n Dest.Top := Height - FGlyph.Height - Spacing;\r\n }\r\n if FImList.Count > 0 then\r\n DrawTheBitmap(Dest, Canvas);\r\n { finally, do the caption }\r\n if Caption <> '' then\r\n DrawTheText(Dest, Canvas);\r\n end;\r\nend;\r\n\r\n{ ARect contains the bitmap bounds }\r\n\r\nprocedure TJvTransparentButton.DrawTheText(ARect: TRect; Canvas: TCanvas);\r\nvar\r\n Flags, MidX, MidY: Integer;\r\n DC: HDC; { Col: TColor; }\r\n TmpRect: TRect;\r\nbegin\r\n if (bsMouseInside in MouseStates) and HotTrack then\r\n Canvas.Font := HotTrackFont\r\n else\r\n Canvas.Font := Self.Font;\r\n DC := Canvas.Handle; { reduce calls to GetHandle }\r\n\r\n if FWordWrap then\r\n Flags := DT_WORDBREAK\r\n else\r\n Flags := DT_SINGLELINE;\r\n\r\n TmpRect := Rect(0, 0, Width, Height);\r\n\r\n { calculate width and height of text: }\r\n DrawText(DC, Caption, Length(Caption), TmpRect, Flags or DT_CALCRECT);\r\n{\r\n if FWordWrap then\r\n Canvas.TextExtent(Caption, TmpRect, WordBreak)\r\n else\r\n Canvas.TextExtent(Caption, TmpRect, 0);\r\n}\r\n MidY := TmpRect.Bottom - TmpRect.Top;\r\n MidX := TmpRect.Right - TmpRect.Left;\r\n Flags := DT_CENTER;\r\n { div 2 and shr 1 generates the exact same assembler code... }\r\n case Self.TextAlign of\r\n ttaTop:\r\n OffsetRect(TmpRect, Width div 2 - MidX div 2, ARect.Top - MidY - Spacing);\r\n ttaTopLeft:\r\n OffsetRect(TmpRect, Spacing, ARect.Top - MidY - Spacing);\r\n ttaTopRight:\r\n OffsetRect(TmpRect, Width - TmpRect.Right - Spacing, ARect.Top - MidY - Spacing);\r\n ttaBottom:\r\n OffsetRect(TmpRect, Width div 2 - MidX div 2, ARect.Bottom + Spacing);\r\n ttaBottomLeft:\r\n OffsetRect(TmpRect, Spacing, ARect.Bottom + Spacing);\r\n ttaBottomRight:\r\n OffsetRect(TmpRect, Width - MidX - Spacing, ARect.Bottom + Spacing);\r\n ttaCenter:\r\n OffsetRect(TmpRect, Width div 2 - MidX div 2, Height div 2 - MidY div 2);\r\n ttaRight:\r\n OffsetRect(TmpRect, Width - MidX - Spacing, Height div 2 - MidY div 2);\r\n ttaLeft:\r\n OffsetRect(TmpRect, Spacing, Height div 2 - MidY div 2);\r\n end;\r\n if FWordWrap then\r\n Flags := Flags or DT_WORDBREAK or DT_NOCLIP\r\n else\r\n Flags := Flags or DT_SINGLELINE or DT_NOCLIP;\r\n\r\n if ((bsMouseDown in MouseStates) or Down) and FShowPressed then\r\n OffsetRect(TmpRect, FPressOffset, FPressOffset);\r\n\r\n SetBkMode(DC, Windows.TRANSPARENT);\r\n if not Enabled then\r\n DrawDisabledText(DC, Caption, -1, TmpRect, Flags)\r\n else\r\n begin\r\n if (bsMouseInside in MouseStates) and HotTrack then\r\n SetTextColor(DC, ColorToRGB(HotTrackFont.Color))\r\n else\r\n SetTextColor(DC, ColorToRGB(Self.Font.Color));\r\n DrawText(DC, Caption, -1, TmpRect, Flags);\r\n end;\r\nend;\r\n\r\nprocedure TJvTransparentButton.SetImages(Value: TJvTransparentButtonImages);\r\nbegin\r\n if Value <> FImages then\r\n FImages.Assign(Value);\r\nend;\r\n\r\nprocedure TJvTransparentButton.CalcGlyphCount;\r\nvar\r\n GlyphNum: Integer;\r\nbegin\r\n if not Glyph.Empty then\r\n begin\r\n if Glyph.Width mod Glyph.Height = 0 then\r\n begin\r\n GlyphNum := Glyph.Width div Glyph.Height;\r\n if GlyphNum > 4 then\r\n GlyphNum := 1;\r\n SetNumGlyphs(GlyphNum);\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvTransparentButton.AddGlyphGlyphs(AGlyph: TBitmap; AColor: TColor; Value: Integer);\r\nvar\r\n Bmp: TBitmap;\r\n I, TmpWidth: Integer;\r\n Dest, Source: TRect;\r\nbegin\r\n if UseImages then\r\n Exit;\r\n\r\n FImList.Clear;\r\n Bmp := TBitmap.Create;\r\n try\r\n if not AGlyph.Empty then\r\n begin\r\n { destroy old list }\r\n TmpWidth := AGlyph.Width div FNumGlyphs;\r\n FImList.Width := TmpWidth;\r\n FImList.Height := AGlyph.Height;\r\n Bmp.Width := FImList.Width;\r\n Bmp.Height := FImList.Height;\r\n Dest := Rect(0, 0, Bmp.Width, Bmp.Height);\r\n { create the imagelist }\r\n for I := 0 to FNumGlyphs - 1 do\r\n begin\r\n Source := Rect(I * Bmp.Width, 0, I * Bmp.Width + Bmp.Width, Bmp.Height);\r\n Bmp.Canvas.CopyRect(Dest, AGlyph.Canvas, Source);\r\n if I = 0 then { first picture }\r\n begin\r\n { create the disabled and grayed bitmaps too }\r\n FGrayGlyph.Assign(Bmp);\r\n MonoBitmap(FGrayGlyph, 11, 59, 30);\r\n FDisabledGlyph.Assign(Bmp);\r\n BWBitmap(FDisabledGlyph);\r\n end;\r\n FImList.AddMasked(Bmp, Bmp.TransparentColor);\r\n end;\r\n { add last }\r\n FImList.AddMasked(FGrayGlyph, FGrayGlyph.TransparentColor);\r\n FImList.AddMasked(FDisabledGlyph, FDisabledGlyph.TransparentColor);\r\n end;\r\n finally\r\n Bmp.Free;\r\n end;\r\n Invalidate;\r\n FGlyph.Dormant;\r\nend;\r\n\r\nprocedure TJvTransparentButton.SetGlyph(Bmp: TBitmap);\r\nbegin\r\n FGlyph.Assign(Bmp);\r\n if UseImages then\r\n AddImageGlyphs;\r\n CalcGlyphCount;\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvTransparentButton.SetGlyphStretched(const Value: Boolean);\r\nbegin\r\n if FGlyphStretched <> Value then\r\n begin\r\n FGlyphStretched := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvTransparentButton.SetNumGlyphs(Value: TNumGlyphs);\r\nbegin\r\n if FNumGlyphs <> Value then\r\n begin\r\n FNumGlyphs := Value;\r\n if not UseImages then\r\n begin\r\n GlyphChanged(Self);\r\n Invalidate;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvTransparentButton.DrawTheBitmap(ARect: TRect; Canvas: TCanvas);\r\nvar\r\n Index: TImageIndex;\r\n HelpRect: TRect;\r\n Icon: TIcon;\r\n Bitmap: TBitmap;\r\nbegin\r\n if FImList.Count = 0 then\r\n Exit;\r\n Index := 0;\r\n\r\n // Important: Draw parent image to keep transparency chain working\r\n\r\n // This line should be added, but currently it introduces some mess in this component.\r\n // Mainly, the frame around the button is not displayed.\r\n // That needs to be fixed before being added again.\r\n\r\n //CopyParentImage(Self, Canvas);\r\n\r\n\r\n if UseImages then\r\n begin\r\n // Images\r\n with FImList do\r\n begin\r\n if not Enabled then\r\n Index := 1 { disabled }\r\n else\r\n if ((bsMouseDown in MouseStates) and\r\n (KeepMouseLeavePressed or (bsMouseInside in MouseStates))) or Down then\r\n Index := 2 { down }\r\n else\r\n if (FrameStyle = fsExplorer) and FAutoGray and (MouseStates = []) then\r\n Index := 3 { autogray }\r\n else\r\n if (bsMouseInside in MouseStates) and HotTrack then\r\n Index := 4 { hot }\r\n else\r\n Index := 0; { normal/active }\r\n end;\r\n end\r\n else\r\n begin\r\n // Glyph\r\n case FNumGlyphs of {normal,disabled,down,down }\r\n 2:\r\n if not Enabled then\r\n Index := 1;\r\n 3:\r\n if not Enabled then\r\n Index := 1\r\n else\r\n if (bsMouseDown in MouseStates) or Down then\r\n Index := 2;\r\n 4:\r\n if not Enabled then\r\n Index := 1\r\n else\r\n if (bsMouseDown in MouseStates) or Down then\r\n Index := 2;\r\n else\r\n Index := 0;\r\n end;\r\n\r\n { do we need the grayed bitmap ? }\r\n if (Flat or (FrameStyle = fsExplorer)) and FAutoGray and not (bsMouseInside in MouseStates) and not Down then\r\n Index := FImList.Count - 2;\r\n\r\n { do we need the disabled bitmap ? }\r\n if not Enabled and (FNumGlyphs = 1) then\r\n Index := FImList.Count - 1;\r\n end;\r\n\r\n if ((bsMouseDown in MouseStates) or Down) and FShowPressed then\r\n OffsetRect(ARect, FPressOffset, FPressOffset);\r\n\r\n // Mantis 3641: Do not draw the rectangle if we are transparent, it's of no use.\r\n if (bsMouseInside in MouseStates) and ((bsMouseDown in MouseStates) or Down) and\r\n not Transparent then\r\n begin\r\n HelpRect := ClientRect;\r\n InflateRect(HelpRect, -BorderWidth - 1, -BorderWidth - 1);\r\n Canvas.Brush.Bitmap := Pattern;\r\n Self.Canvas.FillRect(HelpRect);\r\n end;\r\n\r\n if GlyphStretched then\r\n begin\r\n Bitmap := TBitmap.Create;\r\n try\r\n FImList.GetBitmap(Index, Bitmap);\r\n Canvas.StretchDraw(ClientRect, Bitmap);\r\n finally\r\n Bitmap.Free;\r\n end;\r\n end\r\n else\r\n begin\r\n // Use a TIcon instead of FImList.Draw to avoid triggering Mantis 3851\r\n Icon := TIcon.Create;\r\n try\r\n FImList.GetIcon(Index, Icon);\r\n Canvas.Draw(ARect.Left, ARect.Top, Icon);\r\n finally\r\n Icon.Free;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJvTransparentButton.GetUseImages: Boolean;\r\nbegin\r\n Result := not Assigned(Glyph) or Glyph.Empty;\r\nend;\r\n\r\nprocedure TJvTransparentButton.GlyphChanged(Sender: TObject);\r\nbegin\r\n if UseImages then\r\n AddImageGlyphs\r\n else\r\n AddGlyphGlyphs(Glyph, Glyph.TransparentColor, NumGlyphs);\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvTransparentButton.ActionChange(Sender: TObject; CheckDefaults: Boolean);\r\n\r\n {procedure CopyImage(ImageList: TCustomImageList; Index: TImageIndex);\r\n begin\r\n with Glyph do\r\n begin\r\n Width := ImageList.Width;\r\n Height := ImageList.Height;\r\n Self.Canvas.Brush.Color := clFuchsia; //! for lack of a better color\r\n Self.Canvas.FillRect(Rect(0,0, Width, Height));\r\n ImageList.Draw(Self.Canvas, 0, 0, Index);\r\n end;\r\n GlyphChanged(Glyph);\r\n end;}\r\n\r\nbegin\r\n inherited ActionChange(Sender, CheckDefaults);\r\n if Sender is TCustomAction then\r\n begin\r\n with TCustomAction(Sender) do\r\n begin\r\n if not CheckDefaults then\r\n Self.Down := Checked;\r\n {if UseImages then\r\n begin}\r\n // action uses ActiveImage\r\n Glyph.Width := 0;\r\n Glyph.Height := 0;\r\n\r\n if not CheckDefaults or ((Images <> nil) and (Self.Images.ActiveIndex = -1)) then\r\n begin\r\n Self.Images.ActiveImage := ActionList.Images;\r\n Self.Images.ActiveIndex := ImageIndex;\r\n end;\r\n {end\r\n else\r\n begin\r\n // Copy image from action's imagelist\r\n if (Glyph.Empty) and (ActionList <> nil) and (ActionList.Images <> nil) and\r\n (ImageIndex >= 0) and (ImageIndex < ActionList.Images.Count) then\r\n CopyImage(ActionList.Images, ImageIndex);\r\n end;}\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvTransparentButton.AddImageGlyphs;\r\nvar\r\n Bmp: TBitmap; // creating a Bitmap is time consuming in Qt, so use one for all\r\n\r\n function AddGlyph(Images: TCustomImageList; Index: TImageIndex): Boolean;\r\n var\r\n Icon: HICON;\r\n begin\r\n Result := (Images <> nil) and (Index >= 0);\r\n if Result then\r\n begin\r\n Icon := ImageList_GetIcon(Images.Handle, Index, ILD_TRANSPARENT);\r\n ImageList_AddIcon(FImList.Handle, Icon);\r\n DestroyIcon(Icon);\r\n end;\r\n end;\r\n\r\nbegin\r\n if not UseImages then\r\n Exit;\r\n\r\n Bmp := TBitmap.Create;\r\n try\r\n { get imagelist properties (width, height, ...) }\r\n FImList.BkColor := clNone;\r\n { destroy old list }\r\n FImList.Clear;\r\n { create the imagelist }\r\n with Images do\r\n begin\r\n if Assigned(FActiveList) and (FActiveIndex > -1) then\r\n begin\r\n FImList.Height := FActiveList.Height;\r\n FImList.Width := FActiveList.Width;\r\n\r\n { copy some properties }\r\n FImList.Masked := FActiveList.Masked;\r\n FImList.ImageType := FActiveList.ImageType;\r\n FImList.DrawingStyle := FActiveList.DrawingStyle;\r\n FImList.BlendColor := FActiveList.BlendColor;\r\n\r\n AddGlyph(FActiveList, FActiveIndex);\r\n end\r\n else\r\n Exit; // without an active image the component cannot do anything\r\n\r\n Bmp.Height := FImList.Height;\r\n Bmp.Width := FImList.Width;\r\n\r\n if not AddGlyph(FDisabledList, FDisabledIndex) then\r\n begin\r\n FActiveList.GetBitmap(FActiveIndex, Bmp);\r\n DisabledBitmap(Bmp);\r\n FImList.AddMasked(Bmp, Bmp.TransparentColor);\r\n end;\r\n\r\n if not AddGlyph(FDownList, FDownIndex) then\r\n AddGlyph(FActiveList, FActiveIndex);\r\n\r\n if not AddGlyph(FGrayList, FGrayIndex) then\r\n begin\r\n FActiveList.GetBitmap(FActiveIndex, Bmp);\r\n GrayBitmap(Bmp, 11, 59, 30);\r\n FImList.AddMasked(Bmp, Bmp.TransparentColor);\r\n end;\r\n\r\n if not AddGlyph(FHotList, FHotIndex) then\r\n AddGlyph(FActiveList, FActiveIndex);\r\n end;\r\n finally\r\n Bmp.Free;\r\n Repaint;\r\n end;\r\nend;\r\n\r\ninitialization\r\n{$IFDEF UNITVERSIONING}\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nfinalization\r\n{$IFDEF UNITVERSIONING}\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvTrayIcon.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvTrayIcon.PAS, released on 2001-02-28.\r\n\r\nThe Initial Developer of the Original Code is Sbastien Buysse [sbuysse att buypin dott com]\r\nPortions created by Sbastien Buysse are Copyright (C) 2001 Sbastien Buysse.\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\n Michael Beck [mbeck att bigfoot dott com].\r\n Feng Mingyu(Winston Feng), [winstonf att tom dott com]\r\n Hans-Eric Grnlund\r\n Vlad S\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nHistory:\r\n 2004-03-23\r\n Added code to hide balloon correctly under W2k, as suggested by VladS\r\n 2004-02-29\r\n VladS separate click and dblclick\r\n 2003-09-28 by Winston Feng\r\n Add WM_SESSIONEND message handler, TaskbarRestart message handler to:\r\n Clean the trayicon when session ends.\r\n Restore the trayicon when session restart.\r\n Remove the old unsuccessful DoCheckCrash method.\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvTrayIcon.pas 13350 2012-06-13 14:54:41Z obones $\r\n\r\nunit JvTrayIcon;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,\r\n Menus, ShellAPI, ImgList, DateUtils,\r\n JvComponentBase;\r\n\r\ntype\r\n TBalloonType = (btNone, btError, btInfo, btWarning);\r\n\r\n TNotifyIconDataXP = record\r\n cbSize: DWORD;\r\n Wnd: THandle;\r\n uID: UINT;\r\n uFlags: UINT;\r\n uCallbackMessage: UINT;\r\n hIcon: HICON;\r\n szTip: array [0..127] of Char; // 0..64 for pre 5.0 shell versions\r\n dwState: DWORD;\r\n dwStateMask: DWORD;\r\n szInfo: array [0..255] of Char;\r\n uTimeOut: DWORD;\r\n szInfoTitle: array [0..63] of Char;\r\n dwInfoFlags: DWORD;\r\n end;\r\n\r\n TAnimateEvent = procedure(Sender: TObject; const ImageIndex: Integer) of object;\r\n\r\n { (rb) Change tvVisibleTaskBar to tvStartHidden or something; tvVisibleTaskBar\r\n is mainly used to indicate whether the application should start hidden\r\n with a trayicon; Functionality of tvVisibleTaskBar is available at\r\n run-time by using ShowApplication/HideApplication, at design-time it has\r\n no use, except to indicate whether the application should start hidden.\r\n Did not do the change because it changes the functionality of\r\n the trayicon, and could not come up with a backwards compatible way\r\n right-away }\r\n TTrayVisibility = (tvVisibleTaskBar, tvVisibleTaskList, tvAutoHide, tvAutoHideIcon, tvVisibleDesign,\r\n tvRestoreClick, tvRestoreDbClick, tvMinimizeClick, tvMinimizeDbClick, tvAnimateToTray,\r\n tvNoRetryOnFailure);\r\n TTrayVisibilities = set of TTrayVisibility;\r\n\r\n TJvTrayIconState = (tisTrayIconVisible, tisAnimating, tisHooked, tisHintChanged,\r\n tisWaitingForDoubleClick, tisAppHiddenButNotMinimized, tisClicked);\r\n TJvTrayIconStates = set of TJvTrayIconState;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvTrayIcon = class(TJvComponent)\r\n private\r\n FCurrentIcon: TIcon;\r\n FState: TJvTrayIconStates;\r\n FStreamedActive: Boolean;\r\n\r\n function GetApplicationVisible: Boolean;\r\n procedure SetApplicationVisible(const Value: Boolean);\r\n function GetIconVisible: Boolean;\r\n procedure SetDropDownMenu(const Value: TPopupMenu);\r\n procedure SetIconVisible(const Value: Boolean);\r\n procedure SetPopupMenu(const Value: TPopupMenu);\r\n protected\r\n FActive: Boolean;\r\n FIcon: TIcon;\r\n FIconData: TNotifyIconDataXP;\r\n FHandle: THandle;\r\n FHint: string;\r\n FPopupMenu: TPopupMenu;\r\n FOnClick: TMouseEvent;\r\n FOnDblClick: TMouseEvent;\r\n\r\n // Under Windows 2000, in order to hide a balloon hint, BalloonHint must be\r\n // called with empty strings as many times it was called with real messages.\r\n // So we keep a counter of the number of times ballon hint was called to\r\n // track this and be sure to call a the right number of times when trying\r\n // to hide the balloon\r\n FBalloonCount: Integer;\r\n\r\n { Vlad S}\r\n {\r\n distinguish single-click and a double-click\r\n Create a timer which is started on the first click, set the timeout value to\r\n something a bit longer than the double-click, then connect the timeout() signal\r\n to a slot of your own. When a double click event is received you simply stop\r\n the timer. If the custom slot is visited you know that a single click was\r\n done.\r\n }\r\n FClickedButton: TMouseButton;\r\n FClickedShift: TShiftState;\r\n FClickedX: Integer;\r\n FClickedY: Integer;\r\n { Vlad S end.}\r\n\r\n FOnMouseMove: TMouseMoveEvent;\r\n FOnMouseDown: TMouseEvent;\r\n FOnMouseUp: TMouseEvent;\r\n FOnContextPopup: TContextPopupEvent;\r\n FAnimated: Boolean;\r\n FDelay: Cardinal;\r\n FIcons: TCustomImageList;\r\n FIconIndex: Integer;\r\n FDropDownMenu: TPopupMenu;\r\n FTask: Boolean;\r\n FOnBalloonHide: TNotifyEvent;\r\n FOnBalloonShow: TNotifyEvent;\r\n FOnBalloonClick: TNotifyEvent;\r\n FTime: TDateTime;\r\n FTimeDelay: Integer;\r\n FOnAnimate: TAnimateEvent;\r\n FVisibility: TTrayVisibilities;\r\n FSnap: Boolean;\r\n FSwingDirectionState: Integer;\r\n FSwingForthAndBack: Boolean;\r\n function GetSystemMinimumBalloonDelay: Cardinal;\r\n procedure DoAnimation;\r\n procedure DoCloseBalloon;\r\n procedure DoTimerDblClick; { Vlad S}\r\n procedure IconChanged(Sender: TObject);\r\n procedure SetActive(Value: Boolean);\r\n procedure SetAnimated(const Value: Boolean);\r\n procedure SetDelay(const Value: Cardinal);\r\n procedure SetHint(Value: string);\r\n procedure SetIcon(Value: TIcon);\r\n procedure SetIconIndex(const Value: Integer);\r\n procedure SetIcons(const Value: TCustomImageList);\r\n procedure SetTask(const Value: Boolean);\r\n procedure SetVisibility(const Value: TTrayVisibilities);\r\n procedure StopTimer(ID: Integer);\r\n procedure Hook;\r\n procedure Unhook;\r\n procedure WndProc(var Mesg: TMessage);\r\n procedure DoContextPopup(X, Y: Integer);\r\n procedure DoMouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);\r\n procedure DoMouseMove(Shift: TShiftState; X, Y: Integer);\r\n procedure DoMouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);\r\n procedure DoDoubleClick(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);\r\n procedure DoClick(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);\r\n function ApplicationHook(var Msg: TMessage): Boolean;\r\n function NotifyIcon(uFlags: UINT; dwMessage: DWORD): Boolean;\r\n procedure SetCurrentIcon(Value: TIcon); //HEG: New\r\n procedure IconPropertyChanged; //HEG: New\r\n procedure Loaded; override; //HEG: New\r\n\r\n procedure InitIconData;\r\n\r\n procedure ShowTrayIcon;\r\n procedure HideTrayIcon;\r\n\r\n procedure StartAnimation;\r\n procedure EndAnimation;\r\n\r\n procedure Notification(AComponent: TComponent; Operation: TOperation); override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n property CurrentIcon: TIcon read FCurrentIcon write SetCurrentIcon;\r\n procedure HideApplication; virtual;\r\n procedure ShowApplication; virtual;\r\n procedure BalloonHint(Title, Value: string; BalloonType:\r\n TBalloonType = btNone; ADelay: Cardinal = 5000; CancelPrevious: Boolean = False);\r\n function AcceptBalloons: Boolean;\r\n procedure HideBalloon;\r\n function GetIconRect(var IconRect: TRect): Boolean;\r\n\r\n property ApplicationVisible: Boolean read GetApplicationVisible write SetApplicationVisible;\r\n property VisibleInTaskList: Boolean read FTask write SetTask default True;\r\n property IconVisible: Boolean read GetIconVisible write SetIconVisible;\r\n published\r\n property Active: Boolean read FActive write SetActive default False;\r\n property Animated: Boolean read FAnimated write SetAnimated default False;\r\n property Icon: TIcon read FIcon write SetIcon;\r\n property IconIndex: Integer read FIconIndex write SetIconIndex;\r\n property Icons: TCustomImageList read FIcons write SetIcons;\r\n property Hint: string read FHint write SetHint;\r\n property DropDownMenu: TPopupMenu read FDropDownMenu write SetDropDownMenu;\r\n property PopupMenu: TPopupMenu read FPopupMenu write SetPopupMenu;\r\n property Delay: Cardinal read FDelay write SetDelay default 100;\r\n property Snap: Boolean read FSnap write FSnap default False;\r\n property SwingForthAndBack: Boolean read FSwingForthAndBack write FSwingForthAndBack default False;\r\n property Visibility: TTrayVisibilities read FVisibility write SetVisibility\r\n default [tvVisibleTaskBar, tvVisibleTaskList, tvAutoHide];\r\n property OnAnimate: TAnimateEvent read FOnAnimate write FOnAnimate;\r\n property OnClick: TMouseEvent read FOnClick write FOnClick;\r\n property OnDblClick: TMouseEvent read FOnDblClick write FOnDblClick;\r\n property OnMouseMove: TMouseMoveEvent read FOnMouseMove write FOnMouseMove;\r\n property OnMouseDown: TMouseEvent read FOnMouseDown write FOnMouseDown;\r\n property OnMouseUp: TMouseEvent read FOnMouseUp write FOnMouseUp;\r\n property OnBalloonShow: TNotifyEvent read FOnBalloonShow write FOnBalloonShow;\r\n property OnBalloonHide: TNotifyEvent read FOnBalloonHide write FOnBalloonHide;\r\n property OnBalloonClick: TNotifyEvent read FOnBalloonClick write FOnBalloonClick;\r\n property OnContextPopup: TContextPopupEvent read FOnContextPopup write FOnContextPopup;\r\n end;\r\n\r\nprocedure RefreshTray;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvTrayIcon.pas $';\r\n Revision: '$Revision: 13350 $';\r\n Date: '$Date: 2012-06-13 16:54:41 +0200 (mer. 13 juin 2012) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n JvJCLUtils, JvJVCLUtils, CommCtrl;\r\n\r\nvar\r\n WM_TaskbarRestartMsg: Cardinal;\r\n\r\ntype\r\n TRegisterServiceProcess = function(dwProcessID, dwType: Integer): Integer; stdcall;\r\n\r\n TExtraData = packed record\r\n Wnd: THandle;\r\n uID: UINT;\r\n end;\r\n\r\n TTrayIconEnumerator = class\r\n private\r\n FToolbarHandle: THandle;\r\n FProcess: THandle;\r\n FCount: Integer;\r\n FData: Pointer;\r\n FIndex: Integer;\r\n FButton: TTBButton;\r\n FExtraData: TExtraData;\r\n procedure Init(const DataSize: Integer);\r\n public\r\n constructor Create; overload;\r\n constructor Create(DataSize: Integer); overload;\r\n destructor Destroy; override;\r\n function MoveNext: Boolean;\r\n\r\n function ReadProcessMemory(const Address: Pointer; Count: {$IFDEF RTL230_UP}NativeUInt{$ELSE}DWORD{$ENDIF}; var Buffer): Boolean;\r\n\r\n property CurrentButton: TTBButton read FButton;\r\n property CurrentWnd: THandle read FExtraData.Wnd;\r\n property CurrentID: UINT read FExtraData.uID;\r\n\r\n property ToolbarHandle: THandle read FToolbarHandle;\r\n property Index: Integer read FIndex;\r\n property Data: Pointer read FData;\r\n end;\r\n\r\nconst\r\n AnimationTimer = 1;\r\n CloseBalloonTimer = 2;\r\n DblClickTimer = 3;\r\n\r\n cTaskbarIconIdentifier = 1;\r\n\r\n // The hint size is 64 for pre IE 5.0 Shell32 versions, 128 for newer versions.\r\n cHintSize: array [Boolean] of Cardinal = (64 - 1, 128 - 1); // -1 for trailing #0\r\n\r\n Shell32VersionIE5 = $00050000;\r\n\r\n WM_CALLBACKMESSAGE = WM_USER + 1;\r\n\r\n // WIN32_IE >= = $0500\r\n NIN_SELECT = (WM_USER + 0);\r\n NINF_KEY = $1;\r\n NIN_KEYSELECT = (NIN_SELECT or NINF_KEY);\r\n\r\n // WIN32_IE >= = $0501\r\n NIN_BALLOONSHOW = (WM_USER + 2);\r\n NIN_BALLOONHIDE = (WM_USER + 3);\r\n NIN_BALLOONTIMEOUT = (WM_USER + 4);\r\n NIN_BALLOONUSERCLICK = (WM_USER + 5);\r\n\r\n NIM_ADD = $00000000;\r\n NIM_MODIFY = $00000001;\r\n NIM_DELETE = $00000002;\r\n // WIN32_IE >= = $0500\r\n NIM_SETFOCUS = $00000003;\r\n NIM_SETVERSION = $00000004;\r\n NOTIFYICON_VERSION = 3;\r\n\r\n NIF_MESSAGE = $00000001;\r\n NIF_ICON = $00000002;\r\n NIF_TIP = $00000004;\r\n // WIN32_IE >= = $0500\r\n NIF_STATE = $00000008;\r\n NIF_INFO = $00000010;\r\n // WIN32_IE >= = $600\r\n NIF_GUID = $00000020;\r\n\r\n // WIN32_IE >= = $0500\r\n NIS_HIDDEN = $00000001;\r\n NIS_SHAREDICON = $00000002;\r\n\r\n // says this is the source of a shared icon\r\n\r\n // Notify Icon Infotip flags\r\n NIIF_NONE = $00000000;\r\n // icon flags are mutually exclusive\r\n // and take only the lowest 2 bits\r\n NIIF_INFO = $00000001;\r\n NIIF_WARNING = $00000002;\r\n NIIF_ERROR = $00000003;\r\n NIIF_ICON_MASK = $0000000F;\r\n // WIN32_IE >= = $0501\r\n NIIF_NOSOUND = $00000010;\r\n\r\n RegisterServiceProcessName = 'RegisterServiceProcess';\r\n\r\nvar\r\n RegisterServiceProcess: TRegisterServiceProcess = nil;\r\n\r\n{ We get the following messages while clicking:\r\n\r\n Shell version < 5.0 | Shell version >= 5.0\r\n |\r\n Single click Double click | Single click Double click\r\n |\r\n WM_BUTTONDOWN WM_BUTTONDOWN | WM_BUTTONDOWN WM_BUTTONDOWN\r\n WM_BUTTONUP WM_BUTTONUP | WM_BUTTONUP WM_BUTTONUP\r\n WM_BUTTONDBLCLK | WM_CONTEXTMENU (*) WM_CONTEXTMENU (*)\r\n WM_BUTTONUP | WM_BUTTONDBLCLK\r\n | WM_BUTTONUP\r\n | WM_CONTEXTMENU (*)\r\n (*) if clicked with the right mouse button.\r\n\r\n o We use the tisClicked flag to indicate that we received a WM_BUTTONDOWN;\r\n if we receive a WM_BUTTONUP we can then make a difference between button ups\r\n from double click and from single clicks. DoClick is thus not called twice\r\n for double clicks.\r\n (similar to csClicked flag in TControl.ControlState)\r\n o Normal behaviour for window controls is to call both DoClick and DoDoubleClick\r\n when the user double clicks the control. For the tray icon we don't want that.\r\n We use the tisWaitingForDoubleClick flag to indicate that we received a\r\n WM_BUTTONDOWN and WM_BUTTONUP and thus want to call DoClick. But instead of\r\n calling DoClick we start a timer; if we receive a WM_BUTTONDBLCLK before the\r\n timer ends, the user double clicked the icon otherwise it was a single click.\r\n o For Shell32.dll versions before 5.0 we call DoContextPopup in WM_BUTTONUP\r\n to simulate WM_CONTEXTMENU messages.\r\n\r\n Thus the result is:\r\n\r\n Shell version < 5.0 | Shell version >= 5.0\r\n |\r\n Single click Double click | Single click Double click\r\n |\r\n WM_BUTTONDOWN WM_BUTTONDOWN | WM_BUTTONDOWN WM_BUTTONDOWN\r\n OnMouseDown OnMouseDown | OnMouseDown OnMouseDown\r\n WM_BUTTONUP WM_BUTTONUP | WM_BUTTONUP WM_BUTTONUP\r\n Start Timer Start Timer | Start Timer Start Timer\r\n OnMouseUp OnMouseUp | OnMouseUp OnMouseUp\r\n OnContextPopup (*) OnContextPopup (*)| WM_CONTEXTMENU (*) WM_CONTEXTMENU (*)\r\n WM_TIMER WM_BUTTONDBLCLK | OnContextPopup OnContextPopup\r\n OnClick (**) Stop Timer | WM_TIMER WM_BUTTONDBLCLK\r\n OnDoubleClick | OnClick (**) Stop Timer\r\n WM_BUTTONUP | OnDoubleClick\r\n OnMouseUp | WM_BUTTONUP\r\n OnContextPopup | OnMouseUp\r\n | WM_CONTEXTMENU (*)\r\n | OnContextPopup\r\n\r\n (*) if clicked with the right mouse button.\r\n (**) OnClick comes after the OnMouseUp. Another design decision could\r\n be to also delay OnMouseUp.\r\n}\r\n\r\nfunction GetHandleOnTaskBar: THandle;\r\nbegin\r\n {$IFDEF COMPILER11_UP}\r\n if Application.MainFormOnTaskBar and Assigned(Application.MainForm) then\r\n Result := Application.MainForm.Handle\r\n else\r\n {$ENDIF COMPILER11_UP}\r\n Result := Application.Handle;\r\nend;\r\n\r\nfunction IsApplicationMinimized: Boolean;\r\nbegin\r\n Result := IsIconic(GetHandleOnTaskBar);\r\nend;\r\n\r\nfunction GetTrayHandle: THandle;\r\nvar\r\n ShellTrayHandle: THandle;\r\nbegin\r\n ShellTrayHandle := FindWindow('Shell_TrayWnd', nil);\r\n if ShellTrayHandle <> 0 then\r\n Result := FindWindowEx(ShellTrayHandle, 0, 'TrayNotifyWnd', nil)\r\n else\r\n Result := 0;\r\nend;\r\n\r\nprocedure AnimateToTray(AHandle: THandle);\r\nvar\r\n SourceRect, DestRect: TRect;\r\n TrayHandle: THandle;\r\nbegin\r\n TrayHandle := GetTrayHandle;\r\n if TrayHandle <> 0 then\r\n begin\r\n GetWindowRect(AHandle, SourceRect);\r\n GetWindowRect(TrayHandle, DestRect);\r\n\r\n DrawAnimatedRects(AHandle, IDANI_CAPTION, SourceRect, DestRect);\r\n end;\r\nend;\r\n\r\nprocedure AnimateFromTray(AHandle: THandle);\r\nvar\r\n SourceRect, DestRect: TRect;\r\n TrayHandle: THandle;\r\nbegin\r\n TrayHandle := GetTrayHandle;\r\n if TrayHandle <> 0 then\r\n begin\r\n GetWindowRect(TrayHandle, SourceRect);\r\n GetWindowRect(AHandle, DestRect);\r\n\r\n DrawAnimatedRects(AHandle, IDANI_CAPTION, SourceRect, DestRect);\r\n end;\r\nend;\r\n\r\nfunction FindToolbar(Window: THandle; var ToolbarHandle: THandle): BOOL; stdcall;\r\nvar\r\n Buf: array[Byte] of Char;\r\nbegin\r\n GetClassName(Window, Buf, Length(Buf) - 1);\r\n // Set result to false when we have found a toolbar\r\n Result := StrIComp(Buf, TOOLBARCLASSNAME) <> 0;\r\n if not Result then\r\n ToolbarHandle := Window;\r\nend;\r\n\r\nfunction GetToolbarHandle: THandle;\r\nvar\r\n TrayHandle: THandle;\r\nbegin\r\n Result := 0;\r\n TrayHandle := GetTrayHandle;\r\n if TrayHandle <> 0 then\r\n EnumChildWindows(TrayHandle, @FindToolbar, LPARAM(@Result));\r\nend;\r\n\r\nfunction GetIconRect(const AWnd: THandle; const AID: UINT; var IconRect: TRect): Boolean;\r\nbegin\r\n Result := False;\r\n\r\n with TTrayIconEnumerator.Create(SizeOf(IconRect)) do\r\n try\r\n while MoveNext do\r\n if (CurrentWnd = AWnd) and (CurrentID = AID) then\r\n begin\r\n // Button can be hidden in XP\r\n if (CurrentButton.fsState and TBSTATE_HIDDEN) <> 0 then\r\n Exit;\r\n\r\n // Retrieve the button rectangle..\r\n SendMessage(ToolbarHandle, TB_GETITEMRECT, Index, LPARAM(Data));\r\n // ..and copy it to the current process. If it fails no need to continue\r\n if not ReadProcessMemory(FData, SizeOf(IconRect), IconRect) then\r\n Exit;\r\n\r\n // Convert it to the desktop coordinate space\r\n MapWindowPoints(ToolbarHandle, HWND_DESKTOP, IconRect.TopLeft, 2);\r\n\r\n Result := True;\r\n Exit;\r\n end;\r\n finally\r\n Free;\r\n end;\r\nend;\r\n\r\nprocedure RefreshTray;\r\nvar\r\n IconData: TNotifyIconData;\r\nbegin\r\n FillChar(IconData, SizeOf(IconData), #0);\r\n IconData.cbSize := SizeOf(IconData);\r\n\r\n with TTrayIconEnumerator.Create do\r\n try\r\n while MoveNext do\r\n if not IsWindow(CurrentWnd) then\r\n begin\r\n IconData.Wnd := CurrentWnd;\r\n IconData.uID := CurrentID;\r\n Shell_NotifyIcon(NIM_DELETE, @IconData);\r\n end;\r\n finally\r\n Free;\r\n end;\r\nend;\r\n\r\n//=== { TJvTrayIcon } ========================================================\r\n\r\nconstructor TJvTrayIcon.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FIcon := TIcon.Create;\r\n FIcon.OnChange := IconChanged;\r\n FCurrentIcon := TIcon.Create;\r\n FSnap := False;\r\n FHandle := AllocateHWndEx(WndProc);\r\n\r\n FState := [];\r\n FVisibility := [tvVisibleTaskBar, tvVisibleTaskList, tvAutoHide];\r\n FAnimated := False;\r\n FDelay := 100;\r\n FIconIndex := 0;\r\n FBalloonCount := 0;\r\n FActive := False;\r\n FTask := True;\r\n FSwingDirectionState := 1;\r\nend;\r\n\r\ndestructor TJvTrayIcon.Destroy;\r\nbegin\r\n StopTimer(DblClickTimer); { Vlad S}\r\n StopTimer(CloseBalloonTimer);\r\n\r\n SetActive(False);\r\n\r\n if not (csDestroying in Application.ComponentState) then\r\n SetTask(False);\r\n\r\n FIcon.Free;\r\n FCurrentIcon.Free;\r\n DeallocateHWndEx(FHandle);\r\n\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJvTrayIcon.AcceptBalloons: Boolean;\r\nbegin\r\n // Balloons are only accepted with shell32.dll 5.0+\r\n Result := GetShellVersion >= Shell32VersionIE5;\r\nend;\r\n\r\nfunction TJvTrayIcon.ApplicationHook(var Msg: TMessage): Boolean;\r\nbegin\r\n if (Msg.Msg = WM_SYSCOMMAND) and (Msg.WParam = SC_MINIMIZE) and\r\n (tvAutoHide in Visibility) and Active then\r\n HideApplication;\r\n Result := False;\r\nend;\r\n\r\nprocedure TJvTrayIcon.BalloonHint(Title, Value: string;\r\n BalloonType: TBalloonType; ADelay: Cardinal; CancelPrevious: Boolean);\r\n//http://msdn.microsoft.com/library/default.asp?url=/library/en-us/shellcc/platform/Shell/reference/functions/shell_notifyicon.asp\r\nconst\r\n cInfoFlagValues: array [TBalloonType] of DWORD =\r\n (NIIF_NONE, NIIF_ERROR, NIIF_INFO, NIIF_WARNING);\r\nbegin\r\n if (tisTrayIconVisible in FState) and AcceptBalloons then\r\n begin\r\n FTime := Now;\r\n FTimeDelay := ADelay div 1000;\r\n\r\n // if we must cancel an existing balloon\r\n if CancelPrevious then\r\n HideBalloon;\r\n\r\n with FIconData do\r\n StrPLCopy(szInfoTitle, Title, Length(szInfoTitle) - 1);\r\n with FIconData do\r\n StrPLCopy(szInfo, Value, Length(szInfo) - 1);\r\n\r\n FIconData.uTimeOut := ADelay;\r\n FIconData.dwInfoFlags := cInfoFlagValues[BalloonType];\r\n\r\n if NotifyIcon(NIF_INFO, NIM_MODIFY) then\r\n begin\r\n if (Title = '') and (Value = '') then\r\n begin\r\n Dec(FBalloonCount);\r\n if FBalloonCount < 0 then\r\n FBalloonCount := 0;\r\n end\r\n else\r\n Inc(FBalloonCount);\r\n\r\n // if the delay is less than the system's minimum and the balloon\r\n // was really shown (title and value are not both empty)\r\n // (rb) XP: if Value = '' then balloon is not shown\r\n if (ADelay < GetSystemMinimumBalloonDelay) and ((Title <> '') or (Value <> '')) then\r\n // then we enable the ballon closer timer which will cancel\r\n // the balloon when the delay is elapsed\r\n SetTimer(FHandle, CloseBalloonTimer, ADelay, nil);\r\n\r\n if Assigned(FOnBalloonShow) then\r\n FOnBalloonShow(Self);\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvTrayIcon.DoAnimation;\r\nbegin\r\n if (tisTrayIconVisible in FState) and (FIcons <> nil) and (FIcons.Count > 1) then\r\n begin\r\n if IconIndex < 0 then\r\n IconIndex := 0\r\n else\r\n if SwingForthAndBack then\r\n begin\r\n if IconIndex = FIcons.Count - 1 then\r\n FSwingDirectionState := -1\r\n else\r\n if IconIndex = 0 then\r\n FSwingDirectionState := 1;\r\n IconIndex := (IconIndex + FSwingDirectionState) mod FIcons.Count;\r\n end\r\n else\r\n IconIndex := (IconIndex + 1) mod FIcons.Count;\r\n\r\n if Assigned(FOnAnimate) then\r\n FOnAnimate(Self, IconIndex);\r\n end\r\n else\r\n IconIndex := 0;\r\nend;\r\n\r\nprocedure TJvTrayIcon.DoClick(Button: TMouseButton; Shift: TShiftState;\r\n X, Y: Integer);\r\nbegin\r\n if Assigned(FOnClick) then\r\n FOnClick(Self, Button, Shift, X, Y);\r\n if Button = mbLeft then\r\n begin\r\n if FDropDownMenu <> nil then\r\n begin\r\n SetForegroundWindow(FHandle);\r\n FDropDownMenu.Popup(X, Y);\r\n PostMessage(FHandle, WM_NULL, 0, 0);\r\n end;\r\n if ApplicationVisible then\r\n begin\r\n if tvMinimizeClick in Visibility then\r\n { (rb) Call Application.Minimize instead of HideApplication\r\n if tvAutoHide not in Visibility ? }\r\n HideApplication;\r\n end\r\n else\r\n if tvRestoreClick in Visibility then\r\n ShowApplication;\r\n end;\r\nend;\r\n\r\nprocedure TJvTrayIcon.DoCloseBalloon;\r\nbegin\r\n // we stop the timer and hide the balloon\r\n StopTimer(CloseBalloonTimer);\r\n HideBalloon;\r\nend;\r\n\r\nprocedure TJvTrayIcon.DoContextPopup(X, Y: Integer);\r\nvar\r\n Handled: Boolean;\r\nbegin\r\n Handled := False;\r\n if Assigned(FOnContextPopup) then\r\n FOnContextPopup(Self, Point(X, Y), Handled);\r\n if not Handled and Assigned(FPopupMenu) then\r\n begin\r\n SetForegroundWindow(FHandle);\r\n FPopupMenu.Popup(X, Y);\r\n PostMessage(FHandle, WM_NULL, 0, 0);\r\n end;\r\nend;\r\n\r\nprocedure TJvTrayIcon.DoDoubleClick(Button: TMouseButton;\r\n Shift: TShiftState; X, Y: Integer);\r\nvar\r\n I: Integer;\r\nbegin\r\n if tisWaitingForDoubleClick in FState then\r\n begin\r\n Exclude(FState, tisWaitingForDoubleClick); { Vlad S}\r\n StopTimer(DblClickTimer); { Vlad S}\r\n end;\r\n\r\n if Assigned(FOnDblClick) then\r\n FOnDblClick(Self, Button, Shift, X, Y)\r\n else\r\n if Button = mbLeft then\r\n begin\r\n if FPopupMenu <> nil then\r\n for I := 0 to FPopupMenu.Items.Count - 1 do\r\n if FPopupMenu.Items[I].Default then\r\n begin\r\n FPopupMenu.Items[I].Click;\r\n Break;\r\n end;\r\n if ApplicationVisible then\r\n begin\r\n if tvMinimizeDbClick in Visibility then\r\n { (rb) Call Application.Minimize instead of HideApplication\r\n if tvAutoHide not in Visibility ? }\r\n HideApplication;\r\n end\r\n else\r\n if tvRestoreDbClick in Visibility then\r\n ShowApplication;\r\n end;\r\nend;\r\n\r\nprocedure TJvTrayIcon.DoMouseDown(Button: TMouseButton; Shift: TShiftState;\r\n X, Y: Integer);\r\nbegin\r\n Include(FState, tisClicked);\r\n if Assigned(FOnMouseDown) then\r\n FOnMouseDown(Self, Button, Shift, X, Y);\r\nend;\r\n\r\nprocedure TJvTrayIcon.DoMouseMove(Shift: TShiftState; X, Y: Integer);\r\nbegin\r\n if tisHintChanged in FState then\r\n begin\r\n Exclude(FState, tisHintChanged);\r\n\r\n with FIconData do\r\n StrPLCopy(szTip, GetShortHint(FHint), cHintSize[GetShellVersion >= Shell32VersionIE5]);\r\n\r\n if tisTrayIconVisible in FState then\r\n NotifyIcon(NIF_TIP, NIM_MODIFY);\r\n end;\r\n if Assigned(FOnMouseMove) then\r\n FOnMouseMove(Self, Shift, X, Y);\r\nend;\r\n\r\nprocedure TJvTrayIcon.DoMouseUp(Button: TMouseButton; Shift: TShiftState;\r\n X, Y: Integer);\r\n\r\n function HasSingleClickFunctionality: Boolean;\r\n begin\r\n Result :=\r\n Assigned(FOnClick) or\r\n ((Button = mbLeft) and (Assigned(FDropDownMenu) or\r\n ([tvRestoreClick, tvMinimizeClick] * Visibility <> [])));\r\n end;\r\n function HasDoubleClickFunctionality: Boolean;\r\n begin\r\n Result :=\r\n Assigned(FOnDblClick) or\r\n ([tvRestoreDbClick, tvMinimizeDbClick] * Visibility <> []);\r\n end;\r\nbegin\r\n if tisClicked in FState then\r\n begin\r\n Exclude(FState, tisClicked);\r\n if HasSingleClickFunctionality then\r\n begin\r\n if HasDoubleClickFunctionality then\r\n begin\r\n // Delay DoClick\r\n FClickedButton := Button;\r\n FClickedShift := Shift;\r\n FClickedX := X;\r\n FClickedY := Y;\r\n\r\n if not (tisWaitingForDoubleClick in FState) then\r\n begin\r\n Include(FState, tisWaitingForDoubleClick);\r\n SetTimer(FHandle, DblClickTimer, GetDoubleClickTime, nil);\r\n end;\r\n end\r\n else\r\n DoClick(Button, Shift, X, Y);\r\n end;\r\n //else\r\n // DoClick(Button, Shift, X, Y);\r\n end;\r\n\r\n if Assigned(FOnMouseUp) then\r\n FOnMouseUp(Self, Button, Shift, X, Y);\r\n if (Button = mbRight) and (GetShellVersion < Shell32VersionIE5) then\r\n DoContextPopup(X, Y);\r\nend;\r\n\r\nprocedure TJvTrayIcon.DoTimerDblClick;\r\nbegin\r\n StopTimer(DblClickTimer);\r\n\r\n if tisWaitingForDoubleClick in FState then\r\n begin\r\n Exclude(FState, tisWaitingForDoubleClick);\r\n // Double-clicking a mouse button actually generates four messages:\r\n // WM_XBUTTONDOWN, WM_XBUTTONUP, WM_XBUTTONDBLCLK, and WM_XBUTTONUP again\r\n DoClick(FClickedButton, FClickedShift, FClickedX, FClickedY);\r\n end;\r\nend;\r\n\r\nprocedure TJvTrayIcon.EndAnimation;\r\nbegin\r\n // reentrance check\r\n if tisAnimating in FState then\r\n begin\r\n Exclude(FState, tisAnimating);\r\n StopTimer(AnimationTimer);\r\n end;\r\nend;\r\n\r\nfunction TJvTrayIcon.GetApplicationVisible: Boolean;\r\nbegin\r\n Result := not (tisAppHiddenButNotMinimized in FState) and not IsApplicationMinimized;\r\n {$IFDEF COMPILER11_UP}\r\n if Result and (Snap or (tvAnimateToTray in Visibility)) and\r\n Application.MainFormOnTaskBar and not IsWindowVisible(Application.MainFormHandle) then\r\n Result := False;\r\n {$ENDIF COMPILER11_UP}\r\nend;\r\n\r\nfunction TJvTrayIcon.GetIconRect(var IconRect: TRect): Boolean;\r\nbegin\r\n Result := JvTrayIcon.GetIconRect(Self.FHandle, cTaskbarIconIdentifier, IconRect);\r\nend;\r\n\r\nfunction TJvTrayIcon.GetIconVisible: Boolean;\r\nbegin\r\n Result := tisTrayIconVisible in FState;\r\nend;\r\n\r\nfunction TJvTrayIcon.GetSystemMinimumBalloonDelay: Cardinal;\r\nbegin\r\n // from Microsoft's documentation, a balloon is shown for at\r\n // least 10 seconds, but it is a system settings which must\r\n // be somewhere in the registry. The only question is : Where ?\r\n Result := 10000;\r\nend;\r\n\r\nprocedure TJvTrayIcon.HideApplication;\r\nbegin\r\n // Note: some actions will show/hide the taskbar button of the application,\r\n // so we have to do them in a certain order.\r\n\r\n if ApplicationVisible then\r\n begin\r\n // Custom animation?\r\n if Snap or (tvAnimateToTray in Visibility) then\r\n begin\r\n if Assigned(Application.MainForm) then\r\n begin\r\n if tvAnimateToTray in Visibility then\r\n AnimateToTray(Application.MainForm.Handle);\r\n // To prevent another animation we have to set both\r\n // ShowMainForm and MainForm.Visible to false\r\n Application.MainForm.Visible := False;\r\n end;\r\n Application.ShowMainForm := False;\r\n end;\r\n // This will show the taskbar button\r\n Application.Minimize;\r\n end;\r\n\r\n // ..and hide the taskbar button of the application\r\n ShowWindow(GetHandleOnTaskBar, SW_HIDE);\r\n Exclude(FVisibility, tvVisibleTaskBar);\r\n\r\n if tvAutoHideIcon in Visibility then\r\n ShowTrayIcon;\r\nend;\r\n\r\nprocedure TJvTrayIcon.HideBalloon;\r\nvar\r\n I: Integer;\r\nbegin\r\n // We call BalloonHint with title and info set to\r\n // empty strings which surprisingly will cancel any existing\r\n // balloon for the icon. This is clearly not documented by\r\n // Microsoft and may not work in later releases of Windows\r\n // Under Windows XP, you only need to do this once. But under\r\n // Windows 2000, it seems one must do this one time more than\r\n // there were calls to BalloonHint with real messages\r\n\r\n // (rb) A bit confusing because calling BalloonHint changes FBalloonCount\r\n for I := 0 to FBalloonCount do\r\n BalloonHint('', '');\r\nend;\r\n\r\nprocedure TJvTrayIcon.HideTrayIcon;\r\nbegin\r\n // reentrance check\r\n if tisTrayIconVisible in FState then\r\n begin\r\n EndAnimation;\r\n\r\n if NotifyIcon(0, NIM_DELETE) then\r\n Exclude(FState, tisTrayIconVisible);\r\n end;\r\nend;\r\n\r\nprocedure TJvTrayIcon.Hook;\r\nbegin\r\n // reentrance check; also no hooking while designing\r\n if (tisHooked in FState) or (csDesigning in ComponentState) then\r\n Exit;\r\n Include(FState, tisHooked);\r\n Application.HookMainWindow(ApplicationHook);\r\nend;\r\n\r\nprocedure TJvTrayIcon.IconChanged(Sender: TObject);\r\nbegin\r\n IconPropertyChanged;\r\nend;\r\n\r\n//HEG: New\r\n\r\nprocedure TJvTrayIcon.IconPropertyChanged;\r\nvar\r\n Ico: TIcon;\r\nbegin\r\n if not (csLoading in ComponentState) then\r\n begin\r\n if (FIcons <> nil) and (FIconIndex >= 0) and (FIconIndex < FIcons.Count) then\r\n begin\r\n Ico := TIcon.Create;\r\n try\r\n FIcons.GetIcon(FIconIndex, Ico);\r\n SetCurrentIcon(Ico);\r\n finally\r\n Ico.Free;\r\n end;\r\n end\r\n else\r\n if Assigned(Icon) and (not Icon.Empty) then\r\n SetCurrentIcon(Icon)\r\n else\r\n SetCurrentIcon(Application.Icon);\r\n end;\r\nend;\r\n\r\nprocedure TJvTrayIcon.InitIconData;\r\nbegin\r\n // http://msdn.microsoft.com/library/default.asp?url=/library/en-us/shellcc/platform/Shell/Structures/NOTIFYICONDATA.asp\r\n with FIconData do\r\n begin\r\n if GetShellVersion >= Shell32VersionIE5 then\r\n begin\r\n cbSize := SizeOf(FIconData);\r\n FIconData.uTimeOut := NOTIFYICON_VERSION;\r\n end\r\n else\r\n cbSize := SizeOf(TNotifyIconData);\r\n Wnd := FHandle;\r\n // We have only 1 icon per FHandle, so no need to uniquely identify\r\n uID := cTaskbarIconIdentifier;\r\n uCallbackMessage := WM_CALLBACKMESSAGE;\r\n if not CurrentIcon.Empty then\r\n hIcon := CurrentIcon.Handle\r\n else\r\n CurrentIcon := Application.Icon;\r\n StrPLCopy(szTip, GetShortHint(FHint), cHintSize[GetShellVersion >= Shell32VersionIE5]);\r\n uFlags := 0;\r\n end;\r\nend;\r\n\r\nprocedure TJvTrayIcon.Loaded;\r\nbegin\r\n inherited Loaded;\r\n\r\n IconPropertyChanged;\r\n\r\n if FStreamedActive then\r\n begin\r\n SetActive(True);\r\n\r\n if not (csDesigning in ComponentState) then\r\n begin\r\n if not (tvVisibleTaskBar in Visibility) then\r\n begin\r\n // Start hidden\r\n Application.ShowMainForm := False;\r\n // Note that the application is not really minimized\r\n // (ie IsIconic(Application.Handle) = False), just hidden.\r\n // Calling Application.Minimize or something would show the\r\n // application's button on the taskbar for a short time.\r\n // So we use the tisHiddenNotMinized flag as work-around, to indicate that\r\n // the application is minimized.\r\n\r\n Application.NormalizeTopMosts;\r\n SetActiveWindow(GetHandleOnTaskBar);\r\n ShowWinNoAnimate(GetHandleOnTaskBar, SW_HIDE);\r\n Include(FState, tisAppHiddenButNotMinimized);\r\n end;\r\n\r\n if not (tvVisibleTaskList in Visibility) then\r\n SetTask(False);\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvTrayIcon.Notification(AComponent: TComponent; Operation: TOperation);\r\nbegin\r\n inherited Notification(AComponent, Operation);\r\n if Operation = opRemove then\r\n begin\r\n if AComponent = DropDownMenu then\r\n DropDownMenu := nil;\r\n if AComponent = PopupMenu then\r\n PopupMenu := nil;\r\n if AComponent = Icons then\r\n Icons := nil;\r\n end;\r\nend;\r\n\r\nfunction TJvTrayIcon.NotifyIcon(uFlags: UINT; dwMessage: DWORD): Boolean;\r\nconst\r\n cMaxRetryCount = 30; // arbitrary\r\n cDelay = 1000; // arbitrary\r\nvar\r\n ErrorCode: Integer;\r\n RetryCount: Integer;\r\nbegin\r\n FIconData.uFlags := uFlags;\r\n Result := Shell_NotifyIcon(dwMessage, @FIconData);\r\n if not Result and not (tvNoRetryOnFailure in Visibility) then\r\n begin\r\n { Calling Shell_NotifyIcon can fail on XP when the shell is busy\r\n See http://support.microsoft.com/default.aspx?scid=kb;ja;418138\r\n\r\n Shell_NotifyIcon has a timeout of 4 sec. to complete. If that fails\r\n because the shell is busy, then False is returned and GetLastError\r\n returns ERROR_TIMEOUT (but testing shows that it can also return 0)\r\n Solution is to wait a bit and retry.\r\n\r\n However, even when GetLastError() returns ERROR_TIMEOUT,\r\n the icon can often be actually added(or deleted).\r\n\r\n If NIM_ADD times out and Shell_NotifyIcon(NIM_MODIFY) returns true,\r\n the addition of the icon was actually successful.\r\n Similarly, if NIM_DELETE times out and Shell_NotifyIcon(NIM_MODIFY) returns\r\n false, the deletion of the icon was actually successful. (See Mantis #3747)\r\n\r\n http://qc.borland.com/wc/qcmain.aspx?d=29306 provides steps to\r\n reproduce this problem.\r\n }\r\n ErrorCode := GetLastError;\r\n if (ErrorCode = 0) or (ErrorCode = ERROR_TIMEOUT) then\r\n begin\r\n RetryCount := 0;\r\n repeat\r\n Sleep(cDelay);\r\n\r\n case dwMessage of\r\n NIM_ADD: Result := Shell_NotifyIcon(NIM_MODIFY, @FIconData);\r\n NIM_DELETE: Result := not Shell_NotifyIcon(NIM_MODIFY, @FIconData);\r\n end;\r\n\r\n if Result then\r\n Exit;\r\n\r\n Inc(RetryCount);\r\n Result := Shell_NotifyIcon(dwMessage, @FIconData);\r\n until Result or (RetryCount > cMaxRetryCount);\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvTrayIcon.SetActive(Value: Boolean);\r\nbegin\r\n if csLoading in ComponentState then\r\n FStreamedActive := Value\r\n else\r\n if FActive <> Value then\r\n begin\r\n FActive := Value;\r\n if FActive then\r\n begin\r\n InitIconData;\r\n Hook;\r\n ShowTrayIcon;\r\n end\r\n else\r\n begin\r\n EndAnimation;\r\n Unhook;\r\n HideTrayIcon;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvTrayIcon.SetAnimated(const Value: Boolean);\r\nbegin\r\n if Value <> FAnimated then\r\n begin\r\n FAnimated := Value;\r\n if FAnimated then\r\n StartAnimation\r\n else\r\n EndAnimation;\r\n end;\r\nend;\r\n\r\nprocedure TJvTrayIcon.SetApplicationVisible(const Value: Boolean);\r\nbegin\r\n if Value then\r\n ShowApplication\r\n else\r\n HideApplication;\r\nend;\r\n\r\n//HEG: New\r\n\r\nprocedure TJvTrayIcon.SetCurrentIcon(Value: TIcon);\r\nbegin\r\n FCurrentIcon.Assign(Value);\r\n FIconData.hIcon := FCurrentIcon.Handle;\r\n if tisTrayIconVisible in FState then\r\n // if FIconData.hIcon = 0 then\r\n // HideTrayIcon\r\n // else\r\n NotifyIcon(NIF_ICON, NIM_MODIFY);\r\nend;\r\n\r\nprocedure TJvTrayIcon.SetDelay(const Value: Cardinal);\r\nvar\r\n WasAnimated: Boolean;\r\nbegin\r\n if FDelay <> Value then\r\n begin\r\n WasAnimated := Animated;\r\n try\r\n Animated := False;\r\n FDelay := Value;\r\n finally\r\n Animated := WasAnimated;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvTrayIcon.SetDropDownMenu(const Value: TPopupMenu);\r\nbegin\r\n ReplaceComponentReference(Self, Value, TComponent(FDropDownMenu));\r\nend;\r\n\r\nprocedure TJvTrayIcon.SetHint(Value: string);\r\nbegin\r\n //Remove sLineBreak on w98/me as they are not supported\r\n if GetShellVersion < Shell32VersionIE5 then\r\n Value := StringReplace(Value, sLineBreak, ' - ', [rfReplaceAll]);\r\n\r\n if FHint <> Value then\r\n begin\r\n { (rb) No idea why this isn't applied immediately }\r\n Include(FState, tisHintChanged);\r\n FHint := Value;\r\n end;\r\nend;\r\n\r\nprocedure TJvTrayIcon.SetIcon(Value: TIcon);\r\nbegin\r\n // triggers IconPropertyChanged\r\n FIcon.Assign(Value);\r\nend;\r\n\r\nprocedure TJvTrayIcon.SetIconIndex(const Value: Integer);\r\nbegin\r\n if FIconIndex <> Value then\r\n begin\r\n FIconIndex := Value;\r\n IconPropertyChanged;\r\n end;\r\nend;\r\n\r\nprocedure TJvTrayIcon.SetIcons(const Value: TCustomImageList);\r\nbegin\r\n if ReplaceComponentReference(Self, Value, TComponent(FIcons)) then\r\n IconPropertyChanged; //HEG: New\r\nend;\r\n\r\nprocedure TJvTrayIcon.SetIconVisible(const Value: Boolean);\r\nbegin\r\n if Value then\r\n ShowTrayIcon\r\n else\r\n HideTrayIcon;\r\nend;\r\n\r\nprocedure TJvTrayIcon.SetPopupMenu(const Value: TPopupMenu);\r\nbegin\r\n ReplaceComponentReference(Self, Value, TComponent(FPopupMenu));\r\nend;\r\n\r\nprocedure TJvTrayIcon.SetTask(const Value: Boolean);\r\nbegin\r\n if FTask <> Value then\r\n begin\r\n FTask := Value;\r\n if not (csDesigning in ComponentState) then\r\n begin\r\n if not Assigned(RegisterServiceProcess) then\r\n RegisterServiceProcess := GetProcAddress(GetModuleHandle(kernel32), RegisterServiceProcessName);\r\n\r\n if Assigned(RegisterServiceProcess) then\r\n if FTask then\r\n RegisterServiceProcess(GetCurrentProcessID, 0)\r\n else\r\n RegisterServiceProcess(GetCurrentProcessID, 1);\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvTrayIcon.SetVisibility(const Value: TTrayVisibilities);\r\nvar\r\n ToBeSet, ToBeCleared: TTrayVisibilities;\r\nbegin\r\n if Value <> FVisibility then\r\n begin\r\n ToBeSet := Value - FVisibility;\r\n ToBeCleared := FVisibility - Value;\r\n FVisibility := Value;\r\n\r\n if not Active then\r\n Exit;\r\n\r\n if csDesigning in ComponentState then\r\n begin\r\n if tvVisibleDesign in ToBeSet then\r\n ShowTrayIcon\r\n else\r\n if tvVisibleDesign in ToBeCleared then\r\n HideTrayIcon;\r\n end\r\n else\r\n begin\r\n VisibleInTaskList := tvVisibleTaskList in FVisibility;\r\n\r\n if tvAutoHide in ToBeSet then\r\n begin\r\n if not ApplicationVisible then\r\n HideApplication;\r\n end;\r\n\r\n if tvVisibleTaskBar in ToBeSet then\r\n ShowApplication\r\n else\r\n if tvVisibleTaskBar in ToBeCleared then\r\n HideApplication;\r\n\r\n if (tvAutoHideIcon in ToBeSet) and not IsApplicationMinimized then\r\n HideTrayIcon;\r\n if (tvAutoHideIcon in ToBeCleared) and not IsApplicationMinimized then\r\n ShowTrayIcon;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvTrayIcon.ShowApplication;\r\nbegin\r\n // Note: some actions will show/hide the taskbar button of the application,\r\n // so we have to do them in a certain order.\r\n\r\n if tisAppHiddenButNotMinimized in FState then\r\n begin\r\n // Make the application not iconic; this will show the taskbar button\r\n ShowWinNoAnimate(GetHandleOnTaskBar, SW_MINIMIZE);\r\n // If we set ShowMainForm to true we get an animation when we call\r\n // Application.Restore\r\n if not Snap and not (tvAnimateToTray in Visibility) then\r\n Application.ShowMainForm := True;\r\n end;\r\n\r\n // Show the taskbar button of the application..\r\n Include(FVisibility, tvVisibleTaskBar);\r\n ShowWindow(GetHandleOnTaskBar, SW_SHOW);\r\n\r\n if not ApplicationVisible then\r\n begin\r\n if (tvAnimateToTray in Visibility) and Assigned(Application.MainForm) then\r\n AnimateFromTray(Application.MainForm.Handle);\r\n {$IFDEF COMPILER11_UP}\r\n // Application.Restore checks the IsIconic state of the app window\r\n if Application.MainFormOnTaskBar and not IsIconic(Application.Handle) then\r\n ShowWinNoAnimate(Application.Handle, SW_SHOWMINNOACTIVE);\r\n {$ENDIF COMPILER11_UP}\r\n // ..and restore the application\r\n Application.Restore;\r\n {$IFDEF COMPILER11_UP}\r\n // Without this Application.Restore would only work the first time\r\n if Application.MainFormOnTaskBar and IsIconic(Application.Handle) then\r\n ShowWinNoAnimate(Application.Handle, SW_SHOWNOACTIVATE);\r\n {$ENDIF COMPILER11_UP}\r\n if Application.MainForm <> nil then\r\n Application.MainForm.Visible := True;\r\n end;\r\n\r\n Exclude(FState, tisAppHiddenButNotMinimized);\r\n if tvAutoHideIcon in Visibility then\r\n HideTrayIcon;\r\nend;\r\n\r\nprocedure TJvTrayIcon.ShowTrayIcon;\r\nbegin\r\n // reentrance check\r\n if tisTrayIconVisible in FState then\r\n Exit;\r\n\r\n if not Active then\r\n Exit;\r\n\r\n if csDesigning in ComponentState then\r\n begin\r\n if not (tvVisibleDesign in Visibility) then\r\n Exit;\r\n end\r\n else\r\n if (tvAutoHideIcon in Visibility) and ApplicationVisible then\r\n Exit;\r\n\r\n // All checks passed, make the trayicon visible:\r\n\r\n if NotifyIcon(NIF_MESSAGE or NIF_ICON or NIF_TIP, NIM_ADD) then\r\n begin\r\n Include(FState, tisTrayIconVisible);\r\n\r\n // If we call NIM_SETVERSION, we must call it *after* NIM_ADD.\r\n if GetShellVersion >= Shell32VersionIE5 then\r\n NotifyIcon(0, NIM_SETVERSION);\r\n\r\n if Animated then\r\n StartAnimation;\r\n end;\r\nend;\r\n\r\nprocedure TJvTrayIcon.StartAnimation;\r\nbegin\r\n // reentrance check, and trayicon needs to be visible\r\n if [tisAnimating, tisTrayIconVisible] * FState = [tisTrayIconVisible] then\r\n begin\r\n Include(FState, tisAnimating);\r\n SetTimer(FHandle, AnimationTimer, FDelay, nil)\r\n end;\r\nend;\r\n\r\nprocedure TJvTrayIcon.StopTimer(ID: Integer);\r\nbegin\r\n if FHandle <> 0 then\r\n KillTimer(FHandle, ID);\r\nend;\r\n\r\nprocedure TJvTrayIcon.Unhook;\r\nbegin\r\n // reentrance check\r\n if tisHooked in FState then\r\n begin\r\n Exclude(FState, tisHooked);\r\n Application.UnhookMainWindow(ApplicationHook);\r\n end;\r\nend;\r\n\r\nprocedure TJvTrayIcon.WndProc(var Mesg: TMessage);\r\nvar\r\n I: Integer;\r\n Pt: TPoint;\r\n ShState: TShiftState;\r\nbegin\r\n try\r\n with Mesg do\r\n case Msg of\r\n WM_CALLBACKMESSAGE:\r\n if not (csDesigning in ComponentState) then\r\n begin\r\n GetCursorPos(Pt);\r\n ShState := [];\r\n if GetKeyState(VK_SHIFT) < 0 then\r\n Include(ShState, ssShift);\r\n if GetKeyState(VK_CONTROL) < 0 then\r\n Include(ShState, ssCtrl);\r\n if GetKeyState(VK_LBUTTON) < 0 then\r\n Include(ShState, ssLeft);\r\n if GetKeyState(VK_RBUTTON) < 0 then\r\n Include(ShState, ssRight);\r\n if GetKeyState(VK_MBUTTON) < 0 then\r\n Include(ShState, ssMiddle);\r\n if GetKeyState(VK_MENU) < 0 then\r\n Include(ShState, ssAlt);\r\n case LParam of\r\n WM_MOUSEMOVE:\r\n DoMouseMove(ShState, Pt.X, Pt.Y);\r\n WM_LBUTTONDOWN:\r\n DoMouseDown(mbLeft, ShState, Pt.X, Pt.Y);\r\n WM_RBUTTONDOWN:\r\n DoMouseDown(mbRight, ShState, Pt.X, Pt.Y);\r\n WM_MBUTTONDOWN:\r\n DoMouseDown(mbMiddle, ShState, Pt.X, Pt.Y);\r\n WM_LBUTTONUP:\r\n DoMouseUp(mbLeft, ShState, Pt.X, Pt.Y);\r\n WM_MBUTTONUP:\r\n DoMouseUp(mbMiddle, ShState, Pt.X, Pt.Y);\r\n WM_RBUTTONUP:\r\n DoMouseUp(mbRight, ShState, Pt.X, Pt.Y);\r\n WM_CONTEXTMENU, NIN_KEYSELECT:\r\n // WM_CONTEXTMENU: press Shift+F10 while trayicon has focus.\r\n // NIN_KEYSELECT: press Enter or Space while trayicon has focus.\r\n // Windows moves the mouse pointer to the trayicon before these messages,\r\n // so Pt is valid.\r\n DoContextPopup(Pt.X, Pt.Y);\r\n WM_LBUTTONDBLCLK:\r\n DoDoubleClick(mbLeft, ShState, Pt.X, Pt.Y);\r\n WM_RBUTTONDBLCLK:\r\n DoDoubleClick(mbRight, ShState, Pt.X, Pt.Y);\r\n WM_MBUTTONDBLCLK:\r\n DoDoubleClick(mbMiddle, ShState, Pt.X, Pt.Y);\r\n NIN_BALLOONHIDE: //sb\r\n begin\r\n { (rb) Double try..except }\r\n try\r\n if Assigned(FOnBalloonHide) then\r\n FOnBalloonHide(Self);\r\n except\r\n end;\r\n Result := Ord(True);\r\n end;\r\n NIN_BALLOONTIMEOUT: //sb\r\n begin\r\n I := SecondsBetween(Now, FTime);\r\n if I > FTimeDelay then\r\n HideBalloon;\r\n Result := Ord(True);\r\n end;\r\n NIN_BALLOONUSERCLICK: //sb\r\n begin\r\n { (rb) Double try..except }\r\n try\r\n if Assigned(FOnBalloonClick) then\r\n FOnBalloonClick(Self);\r\n except\r\n end;\r\n Result := Ord(True);\r\n //Result := DefWindowProc(FHandle, Msg, WParam, LParam);\r\n HideBalloon;\r\n end;\r\n end;\r\n end;\r\n {$IFNDEF DELPHI2009_UP}\r\n // Add by Winston Feng 2003-9-28\r\n // Handle the QueryEndSession and TaskbarCreated message, so trayicon\r\n // will be deleted and restored correctly.\r\n // For D2009 and upper, we must let the default window proc handle it.\r\n WM_QUERYENDSESSION:\r\n Result := 1;\r\n {$ENDIF ~DELPHI2009_UP}\r\n WM_ENDSESSION:\r\n // (rb) Is it really necessairy to respond to WM_ENDSESSION?\r\n if TWMEndSession(Mesg).EndSession then\r\n HideTrayIcon\r\n else\r\n if Active then\r\n ShowTrayIcon;\r\n WM_TIMER:\r\n case TWMTimer(Mesg).TimerID of\r\n AnimationTimer:\r\n DoAnimation;\r\n CloseBalloonTimer:\r\n DoCloseBalloon;\r\n DblClickTimer:\r\n DoTimerDblClick;\r\n end;\r\n else\r\n if Msg = WM_TaskbarRestartMsg then\r\n begin\r\n { You can test this on XP:\r\n - Click Start, then click Turn Off Computer\r\n - Press CTRL + Shift + Alt + Click Cancel (all at once)\r\n this will dump explorer.exe\r\n - Press CTRL + Alt + Delete\r\n - Click New Task...\r\n - Enter 'explorer.exe' and click OK.\r\n this will restart explorer.exe\r\n }\r\n\r\n // Ensure tisTrayIconVisible is not in FState:\r\n HideTrayIcon;\r\n if Active then\r\n ShowTrayIcon;\r\n end\r\n else\r\n Result := DefWindowProc(FHandle, Msg, WParam, LParam);\r\n end; // case\r\n except\r\n Application.HandleException(Self);\r\n end;\r\nend;\r\n\r\n//=== { TTrayIconEnumerator } ================================================\r\n\r\nconstructor TTrayIconEnumerator.Create(DataSize: Integer);\r\nbegin\r\n inherited Create;\r\n if DataSize < SizeOf(TTBButton) then\r\n DataSize := SizeOf(TTBButton);\r\n Init(DataSize);\r\n FIndex := FCount;\r\nend;\r\n\r\nconstructor TTrayIconEnumerator.Create;\r\nbegin\r\n inherited Create;\r\n Init(SizeOf(TTBButton));\r\n FIndex := FCount;\r\nend;\r\n\r\ndestructor TTrayIconEnumerator.Destroy;\r\nbegin\r\n if FData <> nil then\r\n VirtualFreeEx(FProcess, FData, 0, MEM_RELEASE);\r\n if FProcess <> 0 then\r\n CloseHandle(FProcess);\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TTrayIconEnumerator.Init(const DataSize: Integer);\r\n{ Taken from http://www.thecodeproject.com/shell/ctrayiconposition.asp }\r\nvar\r\n ProcessID: DWORD;\r\nbegin\r\n // The trayicons are actually buttons on a toolbar\r\n FToolbarHandle := GetToolbarHandle;\r\n if FToolbarHandle = 0 then\r\n Exit;\r\n\r\n FCount := SendMessage(FToolbarHandle, TB_BUTTONCOUNT, 0, 0);\r\n if FCount < 1 then\r\n Exit;\r\n\r\n // We want to get data from another process - it's not possible\r\n // to just send messages like TB_GETBUTTON with a locally\r\n // allocated buffer for return data. Pointer to locally allocated\r\n // data has no usefull meaning in a context of another\r\n // process (since Win95) - so we need\r\n // to allocate some memory inside Tray process.\r\n \r\n if GetWindowThreadProcessId(FToolbarHandle, ProcessID) = 0 then\r\n Exit;\r\n\r\n FProcess := OpenProcess(PROCESS_ALL_ACCESS, False, ProcessID);\r\n if FProcess = 0 then\r\n Exit;\r\n\r\n // Allocate needed memory in the context of the tray process. We reuse\r\n // Data to read multiple parts so we set it to the biggest chunk we need\r\n // (TTBButton)\r\n FData := VirtualAllocEx(FProcess, nil, DataSize, MEM_COMMIT, PAGE_READWRITE);\r\nend;\r\n\r\nfunction TTrayIconEnumerator.MoveNext: Boolean;\r\nbegin\r\n Result := False;\r\n\r\n if (FProcess = 0) or not Assigned(FData) then\r\n Exit;\r\n\r\n Dec(FIndex);\r\n\r\n while FIndex >= 0 do\r\n begin\r\n SendMessage(FToolbarHandle, TB_GETBUTTON, FIndex, LPARAM(FData));\r\n\r\n // Read the data from the tray process into the current process.\r\n if ReadProcessMemory(FData, SizeOf(FButton), FButton) then\r\n begin\r\n // Read the extra data, Button.dwData points to its location\r\n if ReadProcessMemory(Pointer(FButton.dwData), SizeOf(FExtraData), FExtraData) then\r\n begin\r\n Result := True;\r\n Exit;\r\n end;\r\n end;\r\n\r\n Dec(FIndex);\r\n end;\r\nend;\r\n\r\nfunction TTrayIconEnumerator.ReadProcessMemory(const Address: Pointer;\r\n Count: {$IFDEF RTL230_UP}NativeUInt{$ELSE}DWORD{$ENDIF}; var Buffer): Boolean;\r\nvar\r\n BytesRead: {$IFDEF RTL230_UP}NativeUInt{$ELSE}DWORD{$ENDIF};\r\nbegin\r\n Result := Windows.ReadProcessMemory(FProcess, Address, @Buffer, Count, BytesRead) and\r\n (BytesRead = Count);\r\nend;\r\n\r\ninitialization\r\n {$IFDEF UNITVERSIONING}\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n {$ENDIF UNITVERSIONING}\r\n WM_TaskbarRestartMsg := RegisterWindowMessage('TaskbarCreated');\r\n\r\nfinalization\r\n RegisterServiceProcess := nil;\r\n {$IFDEF UNITVERSIONING}\r\n UnregisterUnitVersion(HInstance);\r\n {$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvTurtle.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvTurtle.PAS, released on 2002-06-15.\r\n\r\nThe Initial Developer of the Original Code is Jan Verhoeven [jan1 dott verhoeven att wxs dott nl]\r\nPortions created by Jan Verhoeven are Copyright (C) 2002 Jan Verhoeven.\r\nAll Rights Reserved.\r\n\r\nContributor(s): Robert Love [rlove att slcdug dott org].\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvTurtle.pas 13104 2011-09-07 06:50:43Z obones $\r\n\r\nunit JvTurtle;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n SysUtils, Classes, Windows, Messages, Graphics, Controls,\r\n Math;\r\n\r\ntype\r\n TRequestBackgroundEvent = procedure(Sender: TObject; Background: string) of object;\r\n TRequestFilterEvent = procedure(Sender: TObject; Filter: string) of object;\r\n TRequestImageSizeEvent = procedure(Sender: TObject; var ARect: TRect) of object;\r\n\r\ntype\r\n TStack = array of Integer;\r\n TNStack = array of Integer;\r\n \r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvTurtle = class(TComponent)\r\n private\r\n FPosition: TPoint;\r\n FHeading: Real;\r\n FCanvas: TCanvas;\r\n FPenDown: Boolean;\r\n FMark: TPoint;\r\n FArea: TRect;\r\n FBackground: string;\r\n FFilter: string;\r\n FScript: string;\r\n FIP: Integer;\r\n FIPMax: Integer;\r\n FSP: Integer;\r\n FNSP: Integer;\r\n FStack: TStack;\r\n FNStack: TNStack;\r\n FVariables: TStringList;\r\n FAngleMark: Integer;\r\n FImageRect: TRect;\r\n FOnRepaintRequest: TNotifyEvent;\r\n FOnRequestBackground: TRequestBackgroundEvent;\r\n FOnRequestImageSize: TRequestImageSizeEvent;\r\n FOnRequestFilter: TRequestFilterEvent;\r\n function GetToken(var Token: string): Boolean;\r\n function GetNum(var Num: Integer): Boolean;\r\n function InVariables(Token: string; var Num: Integer): Boolean;\r\n function GetTex(var Tex: string): Boolean;\r\n function GetCol(var Col: TColor): Boolean;\r\n // function SkipBlock: Boolean;\r\n function Push(Num: Integer): Boolean;\r\n function Pop(var Num: Integer): Boolean;\r\n function NPush(var Msg: string; Num: Integer): Boolean;\r\n function NPop(var Msg: string; var Num: Integer): Boolean;\r\n function IsNum(Tex: string): Boolean;\r\n function IsCol(Tex: string): Boolean;\r\n function IsVar(Tex: string): Boolean;\r\n procedure SetPosition(const Value: TPoint);\r\n procedure SetHeading(const Value: Real);\r\n procedure SetCanvas(const Value: TCanvas);\r\n procedure SetPenDown(const Value: Boolean);\r\n procedure SetPenWidth(const Value: Integer);\r\n function GetWidth: Integer;\r\n procedure DoGo(Dest: TPoint);\r\n function txUser(Sym: string): string;\r\n function txComment: string;\r\n function txIn: string;\r\n function txInAdd: string;\r\n function txInSub: string;\r\n function txInMult: string;\r\n function txInDiv: string;\r\n function txInInc: string;\r\n function txInDec: string;\r\n function txBlock: string;\r\n function txReturn: string;\r\n function txPos: string;\r\n function txDefault: string;\r\n function txMove: string;\r\n function txLineTo: string;\r\n function txAngle: string;\r\n function txDown: string;\r\n function txUp: string;\r\n function txPenSize: string;\r\n function txPenColor: string;\r\n function txAddPenColor: string;\r\n function txAddBrushColor: string;\r\n function txTurn: string;\r\n function txLeft: string;\r\n function txRight: string;\r\n function txGo: string;\r\n function txText: string;\r\n function txTextOut: string;\r\n function txTextFont: string;\r\n function txTextSize: string;\r\n function txTextColor: string;\r\n function txTextBold: string;\r\n function txTextItalic: string;\r\n function txTextUnderline: string;\r\n function txTextNormal: string;\r\n function txBsSolid: string;\r\n function txBsClear: string;\r\n function txBrushColor: string;\r\n function txRectangle: string;\r\n function txRoundRect: string;\r\n function txEllipse: string;\r\n function txDiamond: string;\r\n function txPolygon: string;\r\n function txStar: string;\r\n function txCurve: string;\r\n function txMark: string;\r\n function txGoMark: string;\r\n function txMarkAngle: string;\r\n function txGoMarkAngle: string;\r\n function txArea: string;\r\n function txCopy: string;\r\n function txPenMode: string;\r\n function txCopyMode: string;\r\n function txFlood: string;\r\n function txDo: string;\r\n function txLoop: string;\r\n function txGoLeft: string;\r\n function txGoTop: string;\r\n function txGoRight: string;\r\n function txGoBottom: string;\r\n function txGoCenter: string;\r\n function txAdd: string;\r\n function txSub: string;\r\n function txMul: string;\r\n function txDiv: string;\r\n function txDup: string;\r\n function txDrop: string;\r\n function tx_PosX: string;\r\n function tx_PosY: string;\r\n function tx_PenColor: string;\r\n function tx_BrushColor: string;\r\n function tx_TextColor: string;\r\n function tx_PenSize: string;\r\n function tx_TextSize: string;\r\n function tx_Angle: string;\r\n function tx_MarkX: string;\r\n function tx_MarkY: string;\r\n function tx_Loop: string;\r\n function tx_Right: string;\r\n function tx_Left: string;\r\n function tx_Top: string;\r\n function tx_Bottom: string;\r\n function txIf: string;\r\n function txGt: string;\r\n function txGe: string;\r\n function txLt: string;\r\n function txLe: string;\r\n function txEq: string;\r\n function txNe: string;\r\n function txNot: string;\r\n function txAnd: string;\r\n function txOr: string;\r\n function txNeg: string;\r\n function txAbs: string;\r\n function txSwap: string;\r\n function txMax: string;\r\n function txMin: string;\r\n function txSqr: string;\r\n function txSqrt: string;\r\n function txInc: string;\r\n function txDec: string;\r\n function txBackground: string;\r\n function txFilter: string;\r\n function StrToPenMode(var Pm: TPenMode; S: string): Boolean;\r\n function StrToCopyMode(var Cm: TCopyMode; S: string): Boolean;\r\n procedure TextRotate(X, Y, Angle: Integer; AText: string; AFont: TFont);\r\n procedure SetOnRepaintRequest(const Value: TNotifyEvent);\r\n procedure SetMark(const Value: TPoint);\r\n procedure SetArea(const Value: TRect);\r\n procedure SetOnRequestBackground(const Value: TRequestBackgroundEvent);\r\n procedure SetOnRequestImageSize(const Value: TRequestImageSizeEvent);\r\n procedure SetOnRequestFilter(const Value: TRequestFilterEvent);\r\n protected\r\n procedure DoRepaintRequest; virtual;\r\n procedure DoRequestBackground; virtual;\r\n procedure DoRequestFilter; virtual;\r\n function DoRequestImageSize: Boolean; virtual;\r\n public\r\n property Canvas: TCanvas read FCanvas write SetCanvas;\r\n property Position: TPoint read FPosition write SetPosition;\r\n property Mark: TPoint read FMark write SetMark;\r\n property Area: TRect read FArea write SetArea;\r\n property Heading: Real read FHeading write SetHeading;\r\n property PenDown: Boolean read FPenDown write SetPenDown;\r\n property PenWidth: Integer read GetWidth write SetPenWidth;\r\n function DoCom: string;\r\n procedure Turn(AAngle: Real);\r\n procedure Right(AAngle: Real);\r\n procedure MoveForward(ADistance: Real);\r\n procedure MoveBackward(ADistance: Real);\r\n function Interpret(var ALine, ACol: Integer; const S: TStrings): string;\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n published\r\n property OnRepaintRequest: TNotifyEvent read FOnRepaintRequest write SetOnRepaintRequest;\r\n property OnRequestBackground: TRequestBackgroundEvent read FOnRequestBackground write SetOnRequestBackground;\r\n property OnRequestFilter: TRequestFilterEvent read FOnRequestFilter write SetOnRequestFilter;\r\n property OnRequestImageSize: TRequestImageSizeEvent read FOnRequestImageSize write SetOnRequestImageSize;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvTurtle.pas $';\r\n Revision: '$Revision: 13104 $';\r\n Date: '$Date: 2011-09-07 08:50:43 +0200 (mer. 07 sept. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n {$IFNDEF COMPILER12_UP}\r\n JvJCLUtils,\r\n {$ENDIF ~COMPILER12_UP}\r\n JvConsts, JvTypes, JvResources;\r\n\r\nconstructor TJvTurtle.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FVariables := TStringList.Create;\r\n FVariables.Sorted := True;\r\n SetLength(FStack, 256);\r\n SetLength(FNStack, 256);\r\n txDefault;\r\nend;\r\n\r\ndestructor TJvTurtle.Destroy;\r\nbegin\r\n FVariables.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJvTurtle.DoCom: string;\r\nconst\r\n // sorted for binary search\r\n Mapper: array [0..101] of PChar =\r\n (\r\n '-',\r\n '*',\r\n '.and',\r\n '.eq',\r\n '.ge',\r\n '.gt',\r\n '.le',\r\n '.lt',\r\n '.ne',\r\n '.not',\r\n '.or',\r\n '/',\r\n '[',\r\n ']',\r\n '{',\r\n '+',\r\n '=angle',\r\n '=bottom',\r\n '=brushcolor',\r\n '=left',\r\n '=loop',\r\n '=markx',\r\n '=marky',\r\n '=pencolor',\r\n '=pensize',\r\n '=posx',\r\n '=posy',\r\n '=right',\r\n '=textcolor',\r\n '=textsize',\r\n '=top',\r\n 'abs',\r\n 'addbrushcolor',\r\n 'addpencolor',\r\n 'angle',\r\n 'area',\r\n 'background',\r\n 'bold',\r\n 'brushcolor',\r\n 'bsclear',\r\n 'bssolid',\r\n 'copy',\r\n 'copymode',\r\n 'curve',\r\n 'dec',\r\n 'default',\r\n 'diamond',\r\n 'do',\r\n 'down',\r\n 'drop',\r\n 'dup',\r\n 'ellipse',\r\n 'filter',\r\n 'flood',\r\n 'go',\r\n 'gobottom',\r\n 'gocenter',\r\n 'goleft',\r\n 'gomark',\r\n 'gomarkangle',\r\n 'goright',\r\n 'gotop',\r\n 'if',\r\n 'in',\r\n 'inadd',\r\n 'inc',\r\n 'indec',\r\n 'indiv',\r\n 'ininc',\r\n 'inmul',\r\n 'insub',\r\n 'italic',\r\n 'left',\r\n 'lineto',\r\n 'loop',\r\n 'mark',\r\n 'markangle',\r\n 'max',\r\n 'min',\r\n 'move',\r\n 'neg',\r\n 'normal',\r\n 'pencolor',\r\n 'penmode',\r\n 'pensize',\r\n 'polygon',\r\n 'pos',\r\n 'rectangle',\r\n 'right',\r\n 'roundrect',\r\n 'sqr',\r\n 'sqrt',\r\n 'star',\r\n 'swap',\r\n 'text',\r\n 'textcolor',\r\n 'textfont',\r\n 'textout',\r\n 'textsize',\r\n 'turn',\r\n 'underline',\r\n 'up'\r\n );\r\nvar\r\n Com: string;\r\n Lo, Mid, Hi: Integer;\r\nbegin\r\n Result := 'ready';\r\n if not GetToken(Com) then\r\n Exit;\r\n\r\n Lo := Low(Mapper);\r\n Hi := High(Mapper)+1;\r\n repeat\r\n Mid := Lo + (Hi - Lo) div 2;\r\n if Com > Mapper[Mid] then\r\n Lo := Mid+1\r\n else\r\n Hi := Mid;\r\n until Lo >= Hi;\r\n if (Hi > High(Mapper)) or (Com <> Mapper[Hi]) then\r\n Hi := -1;\r\n\r\n case Hi of\r\n 0:\r\n Result := txSub;\r\n 1:\r\n Result := txMul;\r\n 2:\r\n Result := txAnd;\r\n 3:\r\n Result := txEq;\r\n 4:\r\n Result := txGe;\r\n 5:\r\n Result := txGt;\r\n 6:\r\n Result := txLe;\r\n 7:\r\n Result := txLt;\r\n 8:\r\n Result := txNe;\r\n 9:\r\n Result := txNot;\r\n 10:\r\n Result := txOr;\r\n 11:\r\n Result := txDiv;\r\n 12:\r\n Result := txBlock;\r\n 13:\r\n Result := txReturn;\r\n 14:\r\n Result := txComment;\r\n 15:\r\n Result := txAdd;\r\n 16:\r\n Result := tx_Angle;\r\n 17:\r\n Result := tx_Bottom;\r\n 18:\r\n Result := tx_BrushColor;\r\n 19:\r\n Result := tx_Left;\r\n 20:\r\n Result := tx_Loop;\r\n 21:\r\n Result := tx_MarkX;\r\n 22:\r\n Result := tx_MarkY;\r\n 23:\r\n Result := tx_PenColor;\r\n 24:\r\n Result := tx_PenSize;\r\n 25:\r\n Result := tx_PosX;\r\n 26:\r\n Result := tx_PosY;\r\n 27:\r\n Result := tx_Right;\r\n 28:\r\n Result := tx_TextColor;\r\n 29:\r\n Result := tx_TextSize;\r\n 30:\r\n Result := tx_Top;\r\n 31:\r\n Result := txAbs;\r\n 32:\r\n Result := txAddBrushColor;\r\n 33:\r\n Result := txAddPenColor;\r\n 34:\r\n Result := txAngle;\r\n 35:\r\n Result := txArea;\r\n 36:\r\n Result := txBackground;\r\n 37:\r\n Result := txTextBold;\r\n 38:\r\n Result := txBrushColor;\r\n 39:\r\n Result := txBsClear;\r\n 40:\r\n Result := txBsSolid;\r\n 41:\r\n Result := txCopy;\r\n 42:\r\n Result := txCopyMode;\r\n 43:\r\n Result := txCurve;\r\n 44:\r\n Result := txDec;\r\n 45:\r\n Result := txDefault;\r\n 46:\r\n Result := txDiamond;\r\n 47:\r\n Result := txDo;\r\n 48:\r\n Result := txDown;\r\n 49:\r\n Result := txDrop;\r\n 50:\r\n Result := txDup;\r\n 51:\r\n Result := txEllipse;\r\n 52:\r\n Result := txFilter;\r\n 53:\r\n Result := txFlood;\r\n 54:\r\n Result := txGo;\r\n 55:\r\n Result := txGoBottom;\r\n 56:\r\n Result := txGoCenter;\r\n 57:\r\n Result := txGoLeft;\r\n 58:\r\n Result := txGoMark;\r\n 59:\r\n Result := txGoMarkAngle;\r\n 60:\r\n Result := txGoRight;\r\n 61:\r\n Result := txGoTop;\r\n 62:\r\n Result := txIf;\r\n 63:\r\n Result := txIn;\r\n 64:\r\n Result := txInAdd;\r\n 65:\r\n Result := txInc;\r\n 66:\r\n Result := txInDec;\r\n 67:\r\n Result := txInDiv;\r\n 68:\r\n Result := txInInc;\r\n 69:\r\n Result := txInMult;\r\n 70:\r\n Result := txInSub;\r\n 71:\r\n Result := txTextItalic;\r\n 72:\r\n Result := txLeft;\r\n 73:\r\n Result := txLineTo;\r\n 74:\r\n Result := txLoop;\r\n 75:\r\n Result := txMark;\r\n 76:\r\n Result := txMarkAngle;\r\n 77:\r\n Result := txMax;\r\n 78:\r\n Result := txMin;\r\n 79:\r\n Result := txMove;\r\n 80:\r\n Result := txNeg;\r\n 81:\r\n Result := txTextNormal;\r\n 82:\r\n Result := txPenColor;\r\n 83:\r\n Result := txPenMode;\r\n 84:\r\n Result := txPenSize;\r\n 85:\r\n Result := txPolygon;\r\n 86:\r\n Result := txPos;\r\n 87:\r\n Result := txRectangle;\r\n 88:\r\n Result := txRight;\r\n 89:\r\n Result := txRoundRect;\r\n 90:\r\n Result := txSqr;\r\n 91:\r\n Result := txSqrt;\r\n 92:\r\n Result := txStar;\r\n 93:\r\n Result := txSwap;\r\n 94:\r\n Result := txText;\r\n 95:\r\n Result := txTextColor;\r\n 96:\r\n Result := txTextFont;\r\n 97:\r\n Result := txTextOut;\r\n 98:\r\n Result := txTextSize;\r\n 99:\r\n Result := txTurn;\r\n 100:\r\n Result := txTextUnderline;\r\n 101:\r\n Result := txUp;\r\n else\r\n if IsNum(Com) then\r\n Result := ''\r\n else\r\n if IsCol(Com) then\r\n Result := ''\r\n else\r\n if IsVar(Com) then\r\n Result := ''\r\n else\r\n Result := txUser(Com);\r\n end;\r\nend;\r\n\r\nprocedure TJvTurtle.DoRepaintRequest;\r\nbegin\r\n if Assigned(FOnRepaintRequest) then\r\n FOnRepaintRequest(Self);\r\nend;\r\n\r\nfunction TJvTurtle.GetCol(var Col: TColor): Boolean;\r\nvar\r\n Token, Msg: string;\r\n Num: Integer;\r\nbegin\r\n Result := False;\r\n if GetToken(Token) then\r\n if Token = '=' then\r\n begin\r\n Result := True;\r\n if NPop(Msg, Num) then\r\n Col := Num\r\n else\r\n Result := False;\r\n end\r\n else\r\n try\r\n Col := StringToColor(Variant(Token));\r\n Result := True;\r\n except\r\n Result := False;\r\n end;\r\nend;\r\n\r\nfunction TJvTurtle.InVariables(Token: string; var Num: Integer): Boolean;\r\nvar\r\n N: Integer;\r\nbegin\r\n Result := FVariables.Find(Token, N);\r\n if Result then\r\n Num := Integer(FVariables.Objects[N]);\r\nend;\r\n\r\nfunction TJvTurtle.GetNum(var Num: Integer): Boolean;\r\nvar\r\n Token, Msg: string;\r\nbegin\r\n Result := False;\r\n if GetToken(Token) then\r\n if Token = '=' then\r\n Result := NPop(Msg, Num)\r\n else\r\n if InVariables(Token, Num) then\r\n Result := True\r\n else\r\n try\r\n Num := StrToInt(Token);\r\n Result := True;\r\n except\r\n Result := False;\r\n end;\r\nend;\r\n\r\nfunction TJvTurtle.GetTex(var Tex: string): Boolean;\r\nbegin\r\n Tex := '';\r\n Result := False;\r\n while (FIP <= FIPMax) and (FScript[FIP] <> '\"') do\r\n Inc(FIP);\r\n if FIP > FIPMax then\r\n Exit;\r\n Inc(FIP);\r\n while (FIP <= FIPMax) and (FScript[FIP] <> '\"') do\r\n begin\r\n Tex := Tex + FScript[FIP];\r\n Inc(FIP);\r\n end;\r\n if FIP > FIPMax then\r\n Exit;\r\n Inc(FIP);\r\n Result := Tex <> '';\r\nend;\r\n\r\nfunction TJvTurtle.GetToken(var Token: string): Boolean;\r\nconst\r\n Delimiters = [' ', Tab, Cr, Lf];\r\nbegin\r\n Token := '';\r\n while (FIP <= FIPMax) and CharInSet(FScript[FIP], Delimiters) do\r\n Inc(FIP);\r\n while (FIP <= FIPMax) and not CharInSet(FScript[FIP], Delimiters) do\r\n begin\r\n Token := Token + FScript[FIP];\r\n Inc(FIP);\r\n end;\r\n Token := LowerCase(Token);\r\n Result := Token <> '';\r\nend;\r\n\r\nfunction TJvTurtle.GetWidth: Integer;\r\nbegin\r\n if Assigned(FCanvas) then\r\n Result := FCanvas.Pen.Width\r\n else\r\n Result := 1;\r\nend;\r\n\r\nfunction TJvTurtle.Interpret(var ALine, ACol: Integer; const S: TStrings): string;\r\nvar\r\n I: Integer;\r\n Msg: string;\r\nbegin\r\n ALine := 0;\r\n ACol := 0;\r\n Result := RsErrorCanvasNotAssigned;\r\n if not Assigned(FCanvas) then\r\n Exit;\r\n txDefault;\r\n FScript := S.Text;\r\n FSP := 0;\r\n FIP := 1;\r\n FIPMax := Length(FScript);\r\n if FIPMax > 0 then\r\n begin\r\n FVariables.Clear;\r\n repeat\r\n Msg := DoCom;\r\n until Msg <> '';\r\n Result := Msg;\r\n ALine := 0;\r\n ACol := 0;\r\n for I := 1 to FIP-1 do\r\n begin\r\n Inc(ACol);\r\n if (FScript[I] = Cr) or (FScript[I] = Lf) then\r\n begin\r\n Inc(ALine);\r\n ACol := 0;\r\n end;\r\n if (I > 1) and (FScript[I] = Lf) and (FScript[I-1] = Cr) then\r\n begin\r\n Dec(ALine);\r\n Dec(ACol);\r\n end;\r\n end;\r\n if ACol < 0 then\r\n ACol := 0;\r\n end\r\n else\r\n Result := RsEmptyScript;\r\nend;\r\n\r\nprocedure TJvTurtle.DoGo(Dest: TPoint);\r\nbegin\r\n Canvas.MoveTo(Position.X, Position.Y);\r\n if PenDown then\r\n Canvas.LineTo(Dest.X, Dest.Y)\r\n else\r\n Canvas.MoveTo(Dest.X, Dest.Y);\r\n Position := Dest;\r\nend;\r\n\r\nprocedure TJvTurtle.Turn(AAngle: Real);\r\nbegin\r\n Heading := Heading + AAngle;\r\nend;\r\n\r\nprocedure TJvTurtle.MoveBackward(ADistance: Real);\r\nvar\r\n RAngle: Real;\r\n dX, dY: Real;\r\n NewPoint: TPoint;\r\nbegin\r\n if not Assigned(FCanvas) then\r\n Exit;\r\n RAngle := Heading * 2 * Pi / 360;\r\n dX := ADistance * Cos(RAngle);\r\n dY := ADistance * Sin(RAngle);\r\n NewPoint := Point(Variant(Position.X - dX), Variant(Position.Y + dY));\r\n DoGo(NewPoint);\r\nend;\r\n\r\nprocedure TJvTurtle.MoveForward(ADistance: Real);\r\nvar\r\n RAngle: Real;\r\n dX, dY: Real;\r\n NewPoint: TPoint;\r\nbegin\r\n if not Assigned(FCanvas) then\r\n Exit;\r\n RAngle := Heading * 2 * Pi / 360;\r\n dX := ADistance * Cos(RAngle);\r\n dY := ADistance * Sin(RAngle);\r\n NewPoint := Point(Variant(Position.X + dX), Variant(Position.Y - dY));\r\n DoGo(NewPoint);\r\nend;\r\n\r\nfunction TJvTurtle.Pop(var Num: Integer): Boolean;\r\nbegin\r\n Result := FSP > 0;\r\n if Result then\r\n begin\r\n Dec(FSP);\r\n Num := FStack[FSP];\r\n end;\r\nend;\r\n\r\nfunction TJvTurtle.Push(Num: Integer): Boolean;\r\nbegin\r\n try\r\n if FSP >= Length(FStack) then\r\n SetLength(FStack, Length(FStack) + 256);\r\n FStack[FSP] := Num;\r\n Inc(FSP);\r\n Result := True;\r\n except\r\n Result := False;\r\n end;\r\nend;\r\n\r\nprocedure TJvTurtle.Right(AAngle: Real);\r\nbegin\r\n Heading := Heading - AAngle;\r\nend;\r\n\r\nprocedure TJvTurtle.SetArea(const Value: TRect);\r\nbegin\r\n FArea := Value;\r\nend;\r\n\r\nprocedure TJvTurtle.SetCanvas(const Value: TCanvas);\r\nbegin\r\n FCanvas := Value;\r\nend;\r\n\r\nprocedure TJvTurtle.SetHeading(const Value: Real);\r\nbegin\r\n FHeading := Value;\r\nend;\r\n\r\nprocedure TJvTurtle.SetMark(const Value: TPoint);\r\nbegin\r\n FMark := Value;\r\nend;\r\n\r\nprocedure TJvTurtle.SetOnRepaintRequest(const Value: TNotifyEvent);\r\nbegin\r\n FOnRepaintRequest := Value;\r\nend;\r\n\r\nprocedure TJvTurtle.SetPenDown(const Value: Boolean);\r\nbegin\r\n FPenDown := Value;\r\nend;\r\n\r\nprocedure TJvTurtle.SetPosition(const Value: TPoint);\r\nbegin\r\n FPosition := Value;\r\nend;\r\n\r\nprocedure TJvTurtle.SetPenWidth(const Value: Integer);\r\nbegin\r\n if Assigned(FCanvas) then\r\n FCanvas.Pen.Width := Value;\r\nend;\r\n\r\nfunction TJvTurtle.StrToCopyMode(var Cm: TCopyMode; S: string): Boolean;\r\ntype\r\n TMapper = record\r\n Name: PChar;\r\n Val: TCopyMode;\r\n end;\r\nconst\r\n // sorted for binary search\r\n Mapper: array [0..14] of TMapper =\r\n (\r\n (Name: 'cmblackness'; Val: cmBlackness),\r\n (Name: 'cmdstinvert'; Val: cmDstInvert),\r\n (Name: 'cmmergecopy'; Val: cmMergeCopy),\r\n (Name: 'cmmergepaint'; Val: cmMergePaint),\r\n (Name: 'cmnotsrccopy'; Val: cmNotSrcCopy),\r\n (Name: 'cmnotsrcerase'; Val: cmNotSrcErase),\r\n (Name: 'cmpatcopy'; Val: cmPatCopy),\r\n (Name: 'cmpatinvert'; Val: cmPatInvert),\r\n (Name: 'cmpatpaint'; Val: cmPatPaint),\r\n (Name: 'cmscrpaint'; Val: cmSrcPaint),\r\n (Name: 'cmsrcand'; Val: cmSrcAnd),\r\n (Name: 'cmsrccopy'; Val: cmSrcCopy),\r\n (Name: 'cmsrcerase'; Val: cmSrcErase),\r\n (Name: 'cmsrcinvert'; Val: cmSrcInvert),\r\n (Name: 'cmwhiteness'; Val: cmWhiteness)\r\n );\r\nvar\r\n Lo, Mid, Hi: Integer;\r\nbegin\r\n Lo := Low(Mapper);\r\n Hi := High(Mapper)+1;\r\n repeat\r\n Mid := Lo + (Hi - Lo) div 2;\r\n if S > Mapper[Mid].Name then\r\n Lo := Mid+1\r\n else\r\n Hi := Mid;\r\n until Lo >= Hi;\r\n Result := (Hi <= High(Mapper)) and (S = Mapper[Hi].Name);\r\n if Result then\r\n Cm := Mapper[Mid].Val;\r\nend;\r\n\r\nfunction TJvTurtle.StrToPenMode(var Pm: TPenMode; S: string): Boolean;\r\ntype\r\n TMapper = record\r\n Name: PChar;\r\n Val: TPenMode;\r\n end;\r\nconst\r\n // sorted for binary search\r\n Mapper: array [0..15] of TMapper =\r\n (\r\n (Name: 'pmblack'; Val: pmBlack),\r\n (Name: 'pmcopy'; Val: pmCopy),\r\n (Name: 'pmmask'; Val: pmMask),\r\n (Name: 'pmmasknotpen'; Val: pmMaskNotPen),\r\n (Name: 'pmmaskpennot'; Val: pmMaskPenNot),\r\n (Name: 'pmmerge'; Val: pmMerge),\r\n (Name: 'pmmergenotpen'; Val: pmMergeNotPen),\r\n (Name: 'pmmergepennot'; Val: pmMergePenNot),\r\n (Name: 'pmnop'; Val: pmNop),\r\n (Name: 'pmnot'; Val: pmNot),\r\n (Name: 'pmnotcopy'; Val: pmNotCopy),\r\n (Name: 'pmnotmask'; Val: pmNotMask),\r\n (Name: 'pmnotmerge'; Val: pmNotMerge),\r\n (Name: 'pmnotxor'; Val: pmNotXor),\r\n (Name: 'pmwhite'; Val: pmWhite),\r\n (Name: 'pmxor'; Val: pmXor)\r\n );\r\nvar\r\n Lo, Mid, Hi: Integer;\r\nbegin\r\n Lo := Low(Mapper);\r\n Hi := High(Mapper)+1;\r\n repeat\r\n Mid := Lo + (Hi - Lo) div 2;\r\n if S > Mapper[Mid].Name then\r\n Lo := Mid+1\r\n else\r\n Hi := Mid;\r\n until Lo >= Hi;\r\n Result := (Hi <= High(Mapper)) and (S = Mapper[Hi].Name);\r\n if Result then\r\n Pm := Mapper[Mid].Val;\r\nend;\r\n\r\nprocedure TJvTurtle.TextRotate(X, Y, Angle: Integer; AText: string;\r\n AFont: TFont);\r\n\r\nvar\r\n DC: HDC;\r\n Fnt: LOGFONT;\r\n HFnt, HFntPrev: HFONT;\r\n I: Integer;\r\n FontName: string;\r\n\r\nbegin\r\n if AText = '' then\r\n Exit;\r\n Fnt.lfEscapement := Angle * 10;\r\n Fnt.lfOrientation := Angle * 10;\r\n if fsBold in AFont.Style then\r\n Fnt.lfWeight := FW_BOLD\r\n else\r\n Fnt.lfWeight := FW_NORMAL;\r\n if fsItalic in AFont.Style then\r\n Fnt.lfItalic := 1\r\n else\r\n Fnt.lfItalic := 0;\r\n if fsUnderline in AFont.Style then\r\n Fnt.lfUnderline := 1\r\n else\r\n Fnt.lfUnderline := 0;\r\n Fnt.lfStrikeOut := 0;\r\n Fnt.lfHeight := Abs(AFont.Height);\r\n FontName := AFont.Name;\r\n for I := 1 to Length(FontName) do\r\n Fnt.lfFaceName[I - 1] := FontName[I];\r\n Fnt.lfFaceName[Length(FontName)] := #0;\r\n HFnt := CreateFontIndirect(Fnt);\r\n DC := Canvas.Handle;\r\n SetBkMode(DC, Transparent);\r\n SetTextColor(DC, AFont.Color);\r\n HFntPrev := SelectObject(DC, HFnt);\r\n TextOut(DC, X, Y, PChar(AText), Length(AText));\r\n SelectObject(DC, HFntPrev);\r\n DeleteObject(HFnt);\r\nend;\r\n\r\nfunction TJvTurtle.txAngle: string;\r\nvar\r\n X: Integer;\r\nbegin\r\n if GetNum(X) then\r\n begin\r\n SetHeading(X);\r\n Result := '';\r\n end\r\n else\r\n Result := Format(RsInvalidIntegerIns, ['angle']);\r\nend;\r\n\r\nfunction TJvTurtle.txArea: string;\r\nvar\r\n X1, Y1, X2, Y2: Integer;\r\nbegin\r\n if GetNum(X1) and GetNum(Y1) and GetNum(X2) and GetNum(Y2) then\r\n begin\r\n Area := Rect(X1, Y1, X2, Y2);\r\n Result := '';\r\n end\r\n else\r\n Result := Format(RsInvalidIntegerIns, ['area']);\r\nend;\r\n\r\nfunction TJvTurtle.txBrushColor: string;\r\nvar\r\n Col: TColor;\r\nbegin\r\n if GetCol(Col) then\r\n begin\r\n Canvas.Brush.Color := Col;\r\n Result := '';\r\n end\r\n else\r\n Result := Format(RsInvalidColorIns, ['brushcolor']);\r\nend;\r\n\r\nfunction TJvTurtle.txBsClear: string;\r\nbegin\r\n Canvas.Brush.Style := bsClear;\r\n Result := '';\r\nend;\r\n\r\nfunction TJvTurtle.txBsSolid: string;\r\nbegin\r\n Canvas.Brush.Style := bsSolid;\r\n Result := '';\r\nend;\r\n\r\nfunction TJvTurtle.txCopy: string;\r\nvar\r\n X, Y: Integer;\r\nbegin\r\n X := Position.X;\r\n Y := Position.Y;\r\n Canvas.CopyRect(Rect(X, Y, X + Area.Right - Area.Left, Y + Area.Bottom - Area.Top), Canvas, Area);\r\n Result := '';\r\nend;\r\n\r\nfunction TJvTurtle.txCopyMode: string;\r\nvar\r\n S: string;\r\n CopyMode: TCopyMode;\r\nbegin\r\n Result := RsInvalidCopyMode;\r\n if GetToken(S) then\r\n begin\r\n S := 'cm' + S;\r\n if StrToCopyMode(CopyMode, S) then\r\n begin\r\n Canvas.CopyMode := CopyMode;\r\n Result := '';\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJvTurtle.txDown: string;\r\nbegin\r\n PenDown := True;\r\n Result := '';\r\nend;\r\n\r\nfunction TJvTurtle.txEllipse: string;\r\nvar\r\n X2, Y2: Integer;\r\nbegin\r\n if GetNum(X2) and GetNum(Y2) then\r\n begin\r\n X2 := Position.X + X2;\r\n Y2 := Position.Y + Y2;\r\n Canvas.Ellipse(Position.X, Position.Y, X2, Y2);\r\n Result := '';\r\n end\r\n else\r\n Result := Format(RsInvalidIntegerIns, ['ellipse']);\r\nend;\r\n\r\nfunction TJvTurtle.txGo: string;\r\nvar\r\n X: Integer;\r\nbegin\r\n if GetNum(X) then\r\n begin\r\n MoveForward(X);\r\n Result := '';\r\n end\r\n else\r\n Result := Format(RsInvalidIntegerIns, ['go']);\r\nend;\r\n\r\nfunction TJvTurtle.txGoMark: string;\r\nbegin\r\n DoGo(Mark);\r\n Result := '';\r\nend;\r\n\r\nfunction TJvTurtle.txTurn: string;\r\nvar\r\n X: Integer;\r\nbegin\r\n if GetNum(X) then\r\n begin\r\n Turn(X);\r\n Result := '';\r\n end\r\n else\r\n Result := Format(RsInvalidIntegerIns, ['turn']);\r\nend;\r\n\r\nfunction TJvTurtle.txLeft: string;\r\nvar\r\n X: Integer;\r\nbegin\r\n if GetNum(X) then\r\n begin\r\n Heading := Heading + X;\r\n Result := '';\r\n end\r\n else\r\n Result := Format(RsInvalidIntegerIns, ['left']);\r\nend;\r\n\r\nfunction TJvTurtle.txRight: string;\r\nvar\r\n X: Integer;\r\nbegin\r\n if GetNum(X) then\r\n begin\r\n Heading := Heading - X;\r\n Result := '';\r\n end\r\n else\r\n Result := Format(RsInvalidIntegerIns, ['right']);\r\nend;\r\n\r\nfunction TJvTurtle.txMark: string;\r\nbegin\r\n Mark := Position;\r\n Result := '';\r\nend;\r\n\r\nfunction TJvTurtle.txPenColor: string;\r\nvar\r\n Col: TColor;\r\nbegin\r\n if GetCol(Col) then\r\n begin\r\n Canvas.Pen.Color := Col;\r\n Result := '';\r\n end\r\n else\r\n Result := Format(RsInvalidColorIns, ['pencolor']);\r\nend;\r\n\r\nfunction TJvTurtle.txPenMode: string;\r\nvar\r\n S: string;\r\n PenMode: TPenMode;\r\nbegin\r\n Result := RsInvalidPenMode;\r\n if GetToken(S) then\r\n begin\r\n S := 'pm' + S;\r\n if StrToPenMode(PenMode, S) then\r\n begin\r\n Canvas.Pen.Mode := PenMode;\r\n Result := '';\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJvTurtle.txPenSize: string;\r\nvar\r\n Width: Integer;\r\nbegin\r\n if GetNum(Width) then\r\n begin\r\n Canvas.Pen.Width := Width;\r\n Result := '';\r\n end\r\n else\r\n Result := Format(RsInvalidIntegerIns, ['pensize']);\r\nend;\r\n\r\nfunction TJvTurtle.txPos: string;\r\nvar\r\n X, Y: Integer;\r\nbegin\r\n if GetNum(X) and GetNum(Y) then\r\n begin\r\n Position := Point(X, Y);\r\n Result := '';\r\n end\r\n else\r\n Result := Format(RsInvalidIntegerIns, ['pos']);\r\nend;\r\n\r\nfunction TJvTurtle.txRectangle: string;\r\nvar\r\n X2, Y2: Integer;\r\nbegin\r\n if GetNum(X2) and GetNum(Y2) then\r\n begin\r\n X2 := Position.X + X2;\r\n Y2 := Position.Y + Y2;\r\n Canvas.Rectangle(Position.X, Position.Y, X2, Y2);\r\n Result := '';\r\n end\r\n else\r\n Result := Format(RsInvalidIntegerIns, ['rectangle']);\r\nend;\r\n\r\nfunction TJvTurtle.txText: string;\r\nvar\r\n S: string;\r\n A: Integer;\r\nbegin\r\n if GetTex(S) then\r\n begin\r\n A := Variant(Heading);\r\n TextRotate(Position.X, Position.Y, A, S, Canvas.Font);\r\n Result := '';\r\n DoRepaintRequest;\r\n end\r\n else\r\n Result := Format(RsInvalidTextIns, ['text']);\r\nend;\r\n\r\nfunction TJvTurtle.txTextBold: string;\r\nbegin\r\n Canvas.Font.Style := Canvas.Font.Style + [fsBold];\r\n Result := '';\r\nend;\r\n\r\nfunction TJvTurtle.txTextColor: string;\r\nvar\r\n Col: TColor;\r\nbegin\r\n if GetCol(Col) then\r\n begin\r\n Canvas.Font.Color := Col;\r\n Result := '';\r\n end\r\n else\r\n Result := Format(RsInvalidColorIns, ['textcolor']);\r\nend;\r\n\r\nfunction TJvTurtle.txTextFont: string;\r\nvar\r\n FontName: string;\r\nbegin\r\n if GetTex(FontName) then\r\n begin\r\n Canvas.Font.Name := FontName;\r\n Result := '';\r\n end\r\n else\r\n Result := RsMissingFontname;\r\nend;\r\n\r\nfunction TJvTurtle.txTextItalic: string;\r\nbegin\r\n Canvas.Font.Style := Canvas.Font.Style + [fsItalic];\r\n Result := '';\r\nend;\r\n\r\nfunction TJvTurtle.txTextNormal: string;\r\nbegin\r\n Canvas.Font.Style := [];\r\n Result := '';\r\nend;\r\n\r\nfunction TJvTurtle.txTextSize: string;\r\nvar\r\n FontSize: Integer;\r\nbegin\r\n if GetNum(FontSize) then\r\n begin\r\n Canvas.Font.Size := FontSize;\r\n Result := '';\r\n end\r\n else\r\n Result := Format(RsInvalidIntegerIns, ['fontsize']);\r\nend;\r\n\r\nfunction TJvTurtle.txTextUnderline: string;\r\nbegin\r\n Canvas.Font.Style := Canvas.Font.Style + [fsUnderline];\r\n Result := '';\r\nend;\r\n\r\nfunction TJvTurtle.txUp: string;\r\nbegin\r\n PenDown := False;\r\n Result := '';\r\nend;\r\n\r\nfunction TJvTurtle.txDo: string;\r\nvar\r\n Num: Integer;\r\nbegin\r\n if GetNum(Num) then\r\n begin\r\n Result := RsStackOverflow;\r\n if Push(FIP) then\r\n if not Push(Num) then\r\n Result := '';\r\n end\r\n else\r\n Result := Format(RsNumberExpectedIns, ['do']);\r\nend;\r\n\r\nfunction TJvTurtle.txLoop: string;\r\nvar\r\n Reps, Ret: Integer;\r\nbegin\r\n if Pop(Reps) and Pop(Ret) then\r\n begin\r\n Dec(Reps);\r\n if Reps <> 0 then\r\n begin\r\n FIP := Ret;\r\n Push(Ret);\r\n Push(Reps);\r\n end;\r\n Result := '';\r\n end\r\n else\r\n Result := RsStackUnderflow;\r\nend;\r\n\r\n\r\nfunction TJvTurtle.txFlood: string;\r\nvar\r\n X, Y, XF, YF: Integer;\r\nbegin\r\n if GetNum(X) and GetNum(Y) then\r\n begin\r\n XF := Position.X + X;\r\n YF := Position.Y + Y;\r\n Canvas.FloodFill(XF, YF, Canvas.Pixels[XF, YF], fsSurface);\r\n Result := '';\r\n end\r\n else\r\n Result := Format(RsInvalidIntegerIns, ['flood']);\r\nend;\r\n\r\n\r\nprocedure TJvTurtle.SetOnRequestBackground(const Value: TRequestBackgroundEvent);\r\nbegin\r\n FOnRequestBackground := Value;\r\nend;\r\n\r\nprocedure TJvTurtle.DoRequestBackground;\r\nbegin\r\n if Assigned(FOnRequestBackground) then\r\n FOnRequestBackground(Self, FBackground);\r\nend;\r\n\r\nfunction TJvTurtle.txBackground: string;\r\nvar\r\n Name: string;\r\nbegin\r\n if GetTex(Name) then\r\n begin\r\n FBackground := Name;\r\n DoRequestBackground;\r\n Result := '';\r\n end\r\n else\r\n Result := Format(RsInvalidTextIns, ['background']);\r\nend;\r\n\r\nfunction TJvTurtle.txTextOut: string;\r\nvar\r\n Text: string;\r\nbegin\r\n if GetTex(Text) then\r\n begin\r\n Canvas.TextOut(Position.X, Position.Y, Text);\r\n Result := '';\r\n end\r\n else\r\n Result := Format(RsInvalidTextIns, ['text']);\r\nend;\r\n\r\nfunction TJvTurtle.txAddBrushColor: string;\r\nvar\r\n Color: TColor;\r\nbegin\r\n if GetCol(Color) then\r\n begin\r\n Canvas.Brush.Color := Canvas.Brush.Color + Color;\r\n Result := '';\r\n end\r\n else\r\n Result := Format(RsInvalidColorIns, ['addbrushcolor']);\r\nend;\r\n\r\nfunction TJvTurtle.txAddPenColor: string;\r\nvar\r\n Color: TColor;\r\nbegin\r\n if GetCol(Color) then\r\n begin\r\n Canvas.Pen.Color := Canvas.Pen.Color + Color;\r\n Result := '';\r\n end\r\n else\r\n Result := Format(RsInvalidColorIns, ['addbrushcolor']);\r\nend;\r\n\r\nfunction TJvTurtle.txGoMarkAngle: string;\r\nbegin\r\n Heading := FAngleMark;\r\n Result := '';\r\nend;\r\n\r\nfunction TJvTurtle.txMarkAngle: string;\r\nbegin\r\n FAngleMark := Variant(Heading);\r\n Result := '';\r\nend;\r\n\r\nfunction TJvTurtle.IsCol(Tex: string): Boolean;\r\nvar\r\n Msg: string;\r\nbegin\r\n try\r\n Result := NPush(Msg, StringToColor(Tex));\r\n except\r\n Result := False;\r\n end;\r\nend;\r\n\r\nfunction TJvTurtle.IsNum(Tex: string): Boolean;\r\nvar\r\n Msg: string;\r\nbegin\r\n try\r\n Result := NPush(Msg, StrToInt(Tex));\r\n except\r\n Result := False;\r\n end;\r\nend;\r\n\r\nfunction TJvTurtle.NPop(var Msg: string; var Num: Integer): Boolean;\r\nbegin\r\n Result := FNSP > 0;\r\n if Result then\r\n begin\r\n Dec(FNSP);\r\n Num := FNStack[FNSP];\r\n Msg := '';\r\n end\r\n else\r\n Msg := RsNumberStackUnderflow;\r\nend;\r\n\r\nfunction TJvTurtle.NPush(var Msg: string; Num: Integer): Boolean;\r\nbegin\r\n try\r\n if FNSP >= Length(FNStack) then\r\n SetLength(FNStack, Length(FNStack) + 256);\r\n FNStack[FNSP] := Num;\r\n Inc(FNSP);\r\n Msg := '';\r\n Result := True;\r\n except\r\n Msg := RsNumberStackOverflow;\r\n Result := False;\r\n end;\r\nend;\r\n\r\nfunction TJvTurtle.txComment: string;\r\nbegin\r\n while (FIP <= FIPMax) and (FScript[FIP] <> '}') do\r\n Inc(FIP);\r\n if FIP <= FIPMax then\r\n begin\r\n Inc(FIP);\r\n Result := '';\r\n end\r\n else\r\n Result := RsMissingAfterComment;\r\nend;\r\n(*)\r\n\r\nfunction TJvTurtle.SkipBlock: Boolean;\r\nbegin\r\n Result := False;\r\n while (FIP <= FIPMax) and (FScript[FIP] <> '[') do\r\n Inc(FIP);\r\n if FIP > FIPMax then\r\n Exit;\r\n Inc(FIP);\r\n while (FIP <= FIPMax) and (FScript[FIP] <> ']') do\r\n Inc(FIP);\r\n if FIP > FIPMax then\r\n Exit;\r\n Inc(FIP);\r\n Result := True;\r\nend;\r\n(*)\r\n\r\nprocedure TJvTurtle.SetOnRequestImageSize(const Value: TRequestImageSizeEvent);\r\nbegin\r\n FOnRequestImageSize := Value;\r\nend;\r\n\r\nfunction TJvTurtle.DoRequestImageSize: Boolean;\r\nbegin\r\n Result := Assigned(FOnRequestImageSize);\r\n if Result then\r\n FOnRequestImageSize(Self, FImageRect);\r\nend;\r\n\r\nfunction TJvTurtle.txGoBottom: string;\r\nvar\r\n NewPoint: TPoint;\r\nbegin\r\n if DoRequestImageSize then\r\n begin\r\n NewPoint := Point(Position.X, FImageRect.Bottom);\r\n DoGo(NewPoint);\r\n Result := '';\r\n end\r\n else\r\n Result := Format(RsErrorIns, ['gobottom']);\r\nend;\r\n\r\nfunction TJvTurtle.txGoLeft: string;\r\nvar\r\n NewPoint: TPoint;\r\nbegin\r\n if DoRequestImageSize then\r\n begin\r\n NewPoint := Point(FImageRect.Left, Position.Y);\r\n DoGo(NewPoint);\r\n Result := '';\r\n end\r\n else\r\n Result := Format(RsErrorIns, ['goleft']);\r\nend;\r\n\r\nfunction TJvTurtle.txGoRight: string;\r\nvar\r\n NewPoint: TPoint;\r\nbegin\r\n if DoRequestImageSize then\r\n begin\r\n NewPoint := Point(FImageRect.Right, Position.Y);\r\n DoGo(NewPoint);\r\n Result := '';\r\n end\r\n else\r\n Result := Format(RsErrorIns, ['goright']);\r\nend;\r\n\r\nfunction TJvTurtle.txGoTop: string;\r\nvar\r\n NewPoint: TPoint;\r\nbegin\r\n if DoRequestImageSize then\r\n begin\r\n NewPoint := Point(Position.X, FImageRect.Top);\r\n DoGo(NewPoint);\r\n Result := '';\r\n end\r\n else\r\n Result := Format(RsErrorIns, ['gotop']);\r\nend;\r\n\r\nfunction TJvTurtle.txDiv: string;\r\nvar\r\n A, B: Integer;\r\nbegin\r\n if NPop(Result, B) and NPop(Result, A) then\r\n if B <> 0 then\r\n NPush(Result, A div B)\r\n else\r\n Result := RsDivisionByZero;\r\nend;\r\n\r\nfunction TJvTurtle.txDrop: string;\r\nvar\r\n A: Integer;\r\nbegin\r\n NPop(Result, A);\r\nend;\r\n\r\nfunction TJvTurtle.txDup: string;\r\nvar\r\n A: Integer;\r\nbegin\r\n if NPop(Result, A) then\r\n begin\r\n NPush(Result, A);\r\n NPush(Result, A);\r\n end;\r\nend;\r\n\r\nfunction TJvTurtle.txMul: string;\r\nvar\r\n A, B: Integer;\r\nbegin\r\n if NPop(Result, B) and NPop(Result, A) then\r\n NPush(Result, A * B);\r\nend;\r\n\r\nfunction TJvTurtle.txSub: string;\r\nvar\r\n A, B: Integer;\r\nbegin\r\n if NPop(Result, B) and NPop(Result, A) then\r\n NPush(Result, A - B);\r\nend;\r\n\r\nfunction TJvTurtle.txAdd: string;\r\nvar\r\n A, B: Integer;\r\nbegin\r\n if NPop(Result, B) and NPop(Result, A) then\r\n NPush(Result, A + B);\r\nend;\r\n\r\nfunction TJvTurtle.txGoCenter: string;\r\nvar\r\n CX, CY: Integer;\r\nbegin\r\n if DoRequestImageSize then\r\n begin\r\n CX := (FImageRect.Right - FImageRect.Left) div 2;\r\n CY := (FImageRect.Bottom - FImageRect.Top) div 2;\r\n DoGo(Point(CX, CY));\r\n Result := '';\r\n end\r\n else\r\n Result := Format(RsErrorIns, ['gocenter']);\r\nend;\r\n\r\nfunction TJvTurtle.txDiamond: string;\r\nvar\r\n I, X: Integer;\r\n OldDown: Boolean;\r\nbegin\r\n Result := Format(RsInvalidIntegerIns, ['diamond']);\r\n if GetNum(X) then\r\n begin\r\n OldDown := PenDown;\r\n PenDown := True;\r\n Turn(45);\r\n for I := 1 to 4 do\r\n begin\r\n MoveForward(X);\r\n Turn(-90);\r\n end;\r\n Turn(-45);\r\n PenDown := OldDown;\r\n Result := '';\r\n end;\r\nend;\r\n\r\nfunction TJvTurtle.txCurve: string;\r\nvar\r\n Pts: array [0..3] of TPoint;\r\n I: Integer;\r\nbegin\r\n if GetNum(Pts[1].X) and GetNum(Pts[1].Y) and\r\n GetNum(Pts[2].X) and GetNum(Pts[2].Y) and\r\n GetNum(Pts[3].X) and GetNum(Pts[3].Y) then\r\n begin\r\n Pts[0].X := Position.X;\r\n Pts[0].Y := Position.Y;\r\n for I := 1 to 3 do\r\n begin\r\n Pts[I].X := Position.X + Pts[I].X;\r\n Pts[I].Y := Position.Y + Pts[I].Y;\r\n end;\r\n Canvas.PolyBezier(Pts);\r\n Position := Pts[3];\r\n Result := '';\r\n end\r\n else\r\n Result := Format(RsInvalidParameterIns, ['curve']);\r\nend;\r\n\r\nfunction TJvTurtle.txMove: string;\r\nvar\r\n X, Y: Integer;\r\nbegin\r\n if GetNum(X) and GetNum(Y) then\r\n begin\r\n Position := Point(Position.X + X, Position.Y + Y);\r\n Result := '';\r\n end\r\n else\r\n Result := Format(RsInvalidIntegerIns, ['move']);\r\nend;\r\n\r\nprocedure TJvTurtle.SetOnRequestFilter(const Value: TRequestFilterEvent);\r\nbegin\r\n FOnRequestFilter := Value;\r\nend;\r\n\r\nprocedure TJvTurtle.DoRequestFilter;\r\nbegin\r\n if Assigned(FOnRequestFilter) then\r\n FOnRequestFilter(Self, FFilter);\r\nend;\r\n\r\nfunction TJvTurtle.txFilter: string;\r\nvar\r\n AName: string;\r\nbegin\r\n if GetTex(AName) then\r\n begin\r\n FFilter := AName;\r\n DoRequestFilter;\r\n Result := '';\r\n end\r\n else\r\n Result := Format(RsInvalidTextIns, ['filter']);\r\nend;\r\n\r\nfunction TJvTurtle.txUser(Sym: string): string;\r\nvar\r\n P: Integer;\r\nbegin\r\n P := Pos(Sym, FScript);\r\n if P <> 0 then\r\n begin\r\n if Push(FIP) then\r\n begin\r\n FIP := P + Length(Sym);\r\n Result := '';\r\n end\r\n else\r\n Result := RsStackOverflow;\r\n end\r\n else\r\n Result := Format(RsSymbolsIsNotDefined, [Sym]);\r\nend;\r\n\r\nfunction TJvTurtle.txBlock: string;\r\nbegin\r\n while (FIP <= FIPMax) and (FScript[FIP] <> ']') do\r\n Inc(FIP);\r\n if FIP <= FIPMax then\r\n begin\r\n Inc(FIP);\r\n Result := '';\r\n end\r\n else\r\n Result := RsMissingAfterBlock;\r\nend;\r\n\r\nfunction TJvTurtle.txReturn: string;\r\nvar\r\n Num: Integer;\r\nbegin\r\n if Pop(Num) then\r\n begin\r\n FIP := Num;\r\n Result := '';\r\n end\r\n else\r\n Result := RsStackUnderflow;\r\nend;\r\n\r\nfunction TJvTurtle.tx_Angle: string;\r\nvar\r\n Num: Integer;\r\nbegin\r\n Num := Variant(Heading);\r\n NPush(Result, Num);\r\nend;\r\n\r\nfunction TJvTurtle.tx_Bottom: string;\r\nbegin\r\n if DoRequestImageSize then\r\n NPush(Result, FImageRect.Bottom)\r\n else\r\n Result := Format(RsErrorIns, ['=bottom']);\r\nend;\r\n\r\nfunction TJvTurtle.tx_BrushColor: string;\r\nbegin\r\n NPush(Result, Canvas.Brush.Color);\r\nend;\r\n\r\nfunction TJvTurtle.tx_Left: string;\r\nbegin\r\n if DoRequestImageSize then\r\n NPush(Result, FImageRect.Left)\r\n else\r\n Result := Format(RsErrorIns, ['=left']);\r\nend;\r\n\r\nfunction TJvTurtle.tx_Loop: string;\r\nvar\r\n Num: Integer;\r\nbegin\r\n if Pop(Num) then\r\n begin\r\n Push(Num);\r\n NPush(Result, Num);\r\n end\r\n else\r\n Result := Format(RsStackUnderflowIns, ['=loop']);\r\nend;\r\n\r\nfunction TJvTurtle.tx_MarkX: string;\r\nbegin\r\n NPush(Result, Mark.X);\r\nend;\r\n\r\nfunction TJvTurtle.tx_MarkY: string;\r\nbegin\r\n NPush(Result, Mark.Y);\r\nend;\r\n\r\nfunction TJvTurtle.tx_PenColor: string;\r\nbegin\r\n NPush(Result, Canvas.Pen.Color);\r\nend;\r\n\r\nfunction TJvTurtle.tx_PosX: string;\r\nbegin\r\n NPush(Result, Position.X);\r\nend;\r\n\r\nfunction TJvTurtle.tx_PosY: string;\r\nbegin\r\n NPush(Result, Position.Y);\r\nend;\r\n\r\nfunction TJvTurtle.tx_Right: string;\r\nbegin\r\n if DoRequestImageSize then\r\n NPush(Result, FImageRect.Right)\r\n else\r\n Result := Format(RsErrorIns, ['=right']);\r\nend;\r\n\r\nfunction TJvTurtle.tx_Top: string;\r\nbegin\r\n if DoRequestImageSize then\r\n NPush(Result, FImageRect.Top)\r\n else\r\n Result := Format(RsErrorIns, ['=top']);\r\nend;\r\n\r\nfunction TJvTurtle.tx_PenSize: string;\r\nbegin\r\n NPush(Result, Canvas.Pen.Width);\r\nend;\r\n\r\nfunction TJvTurtle.tx_TextColor: string;\r\nbegin\r\n NPush(Result, Canvas.Font.Color);\r\nend;\r\n\r\nfunction TJvTurtle.tx_TextSize: string;\r\nbegin\r\n NPush(Result, Canvas.Font.Size);\r\nend;\r\n\r\nfunction TJvTurtle.txIf: string;\r\nvar\r\n Num: Integer;\r\n Token: string;\r\nbegin\r\n if NPop(Result, Num) then\r\n if Num = 0 then\r\n if GetToken(Token) then\r\n Result := ''\r\n else\r\n Result := RsSymbolExpectedAfterIf;\r\nend;\r\n\r\nfunction TJvTurtle.txAnd: string;\r\nvar\r\n A, B: Integer;\r\nbegin\r\n if NPop(Result, B) and NPop(Result, A) then\r\n NPush(Result, Ord((A <> 0) and (B <> 0)));\r\nend;\r\n\r\nfunction TJvTurtle.txEq: string;\r\nvar\r\n A, B: Integer;\r\nbegin\r\n if NPop(Result, B) and NPop(Result, A) then\r\n NPush(Result, Ord(A = B));\r\nend;\r\n\r\nfunction TJvTurtle.txGe: string;\r\nvar\r\n A, B: Integer;\r\nbegin\r\n if NPop(Result, B) and NPop(Result, A) then\r\n NPush(Result, Ord(A >= B));\r\nend;\r\n\r\nfunction TJvTurtle.txGt: string;\r\nvar\r\n A, B: Integer;\r\nbegin\r\n if NPop(Result, B) and NPop(Result, A) then\r\n NPush(Result, Ord(A > B));\r\nend;\r\n\r\nfunction TJvTurtle.txLe: string;\r\nvar\r\n A, B: Integer;\r\nbegin\r\n if NPop(Result, B) and NPop(Result, A) then\r\n NPush(Result, Ord(A <= B));\r\nend;\r\n\r\nfunction TJvTurtle.txLt: string;\r\nvar\r\n A, B: Integer;\r\nbegin\r\n if NPop(Result, B) and NPop(Result, A) then\r\n NPush(Result, Ord(A < B));\r\nend;\r\n\r\nfunction TJvTurtle.txNe: string;\r\nvar\r\n A, B: Integer;\r\nbegin\r\n if NPop(Result, B) and NPop(Result, A) then\r\n NPush(Result, Ord(A <> B));\r\nend;\r\n\r\nfunction TJvTurtle.txNot: string;\r\nvar\r\n A: Integer;\r\nbegin\r\n if NPop(Result, A) then\r\n NPush(Result, Ord(A = 0))\r\nend;\r\n\r\nfunction TJvTurtle.txOr: string;\r\nvar\r\n A, B: Integer;\r\nbegin\r\n if NPop(Result, B) and NPop(Result, A) then\r\n NPush(Result, Ord((A <> 0) or (B <> 0)));\r\nend;\r\n\r\nfunction TJvTurtle.txAbs: string;\r\nvar\r\n A: Integer;\r\nbegin\r\n if NPop(Result, A) then\r\n NPush(Result, Abs(A))\r\nend;\r\n\r\nfunction TJvTurtle.txNeg: string;\r\nvar\r\n A: Integer;\r\nbegin\r\n if NPop(Result, A) then\r\n NPush(Result, -A);\r\nend;\r\n\r\nfunction TJvTurtle.txSwap: string;\r\nvar\r\n A, B: Integer;\r\nbegin\r\n if NPop(Result, B) and NPop(Result, A) then\r\n begin\r\n NPush(Result, B);\r\n NPush(Result, A);\r\n end;\r\nend;\r\n\r\nfunction TJvTurtle.txMax: string;\r\nvar\r\n A, B: Integer;\r\nbegin\r\n if NPop(Result, B) and NPop(Result, A) then\r\n NPush(Result, Max(A, B));\r\nend;\r\n\r\nfunction TJvTurtle.txMin: string;\r\nvar\r\n A, B: Integer;\r\nbegin\r\n if NPop(Result, B) and NPop(Result, A) then\r\n NPush(Result, Min(A, B));\r\nend;\r\n\r\nfunction TJvTurtle.txSqr: string;\r\nvar\r\n A: Integer;\r\nbegin\r\n if NPop(Result, A) then\r\n NPush(Result, Variant(Sqr(A)));\r\nend;\r\n\r\nfunction TJvTurtle.txSqrt: string;\r\nvar\r\n A: Integer;\r\nbegin\r\n if NPop(Result, A) then\r\n if A <> 0 then\r\n NPush(Result, Variant(Sqrt(A)))\r\n else\r\n Result := RsCanNotTakeSqrtOf;\r\nend;\r\n\r\nfunction TJvTurtle.txDec: string;\r\nvar\r\n A: Integer;\r\nbegin\r\n if NPop(Result, A) then\r\n NPush(Result, A-1);\r\nend;\r\n\r\nfunction TJvTurtle.txInc: string;\r\nvar\r\n A: Integer;\r\nbegin\r\n if NPop(Result, A) then\r\n NPush(Result, A+1);\r\nend;\r\n\r\nfunction TJvTurtle.txPolygon: string;\r\nvar\r\n I, S, N: Integer;\r\n OldDown: Boolean;\r\n OldHeading, A: Real;\r\n Pt: TPoint;\r\nbegin\r\n Result := Format(RsInvalidIntegerIns, ['polygon']);\r\n if not (GetNum(N) and GetNum(S)) then\r\n Exit;\r\n Result := Format(RsNotAllowedIns, ['polygon']);\r\n if (N = 0) or (S = 0) then\r\n Exit;\r\n Result := Format(RsNeedMinimumOfSidesIns, ['polygon']);\r\n if N < 3 then\r\n Exit;\r\n OldHeading := Heading;\r\n Pt := Position;\r\n OldDown := PenDown;\r\n PenDown := True;\r\n A := 360 / N;\r\n for I := 1 to N - 1 do\r\n begin\r\n MoveForward(S);\r\n Turn(A);\r\n end;\r\n Canvas.LineTo(Pt.X, Pt.Y);\r\n PenDown := OldDown;\r\n Heading := OldHeading;\r\n Position := Pt;\r\n Result := '';\r\nend;\r\n\r\nfunction TJvTurtle.txStar: string;\r\nvar\r\n I, S, N: Integer;\r\n OldDown: Boolean;\r\n A, OldHeading: Real;\r\n Pt: TPoint;\r\nbegin\r\n Result := Format(RsInvalidIntegerIns, ['star']);\r\n if not (GetNum(N) and GetNum(S)) then\r\n Exit;\r\n Result := Format(RsNotAllowedIns, ['star']);\r\n if (N = 0) or (S = 0) then\r\n Exit;\r\n Result := Format(RsNeedMinimumOfSidesIns, ['star']);\r\n if N < 3 then\r\n Exit;\r\n Result := Format(RsMaximumSidesExceededIns, ['star']);\r\n if N > 12 then\r\n Exit;\r\n OldHeading := Heading;\r\n Pt := Position;\r\n OldDown := PenDown;\r\n PenDown := True;\r\n A := (N div 2) * 360 / N;\r\n for I := 1 to N - 1 do\r\n begin\r\n MoveForward(S);\r\n Turn(A);\r\n end;\r\n Canvas.LineTo(Pt.X, Pt.Y);\r\n PenDown := OldDown;\r\n Heading := OldHeading;\r\n Position := Pt;\r\n Result := '';\r\nend;\r\n\r\nfunction TJvTurtle.txLineTo: string;\r\nvar\r\n X, Y: Integer;\r\nbegin\r\n if GetNum(X) and GetNum(Y) then\r\n begin\r\n Canvas.MoveTo(Position.X, Position.Y);\r\n Canvas.LineTo(Position.X + X, Position.Y + Y);\r\n Position := Point(Position.X + X, Position.Y + Y);\r\n Result := '';\r\n end\r\n else\r\n Result := Format(RsInvalidIntegerIns, ['lineto']);\r\nend;\r\n\r\nfunction TJvTurtle.txRoundRect: string;\r\nvar\r\n X2, Y2, RX, RY: Integer;\r\nbegin\r\n if GetNum(X2) and GetNum(Y2) and GetNum(RX) and GetNum(RY) then\r\n begin\r\n X2 := Position.X + X2;\r\n Y2 := Position.Y + Y2;\r\n Canvas.RoundRect(Position.X, Position.Y, X2, Y2, RX, RY);\r\n Result := '';\r\n end\r\n else\r\n Result := Format(RsInvalidIntegerIns, ['roundrect']);\r\nend;\r\n\r\nfunction TJvTurtle.txDefault: string;\r\nbegin\r\n Result := '';\r\n Heading := 0;\r\n Position := Point(0, 0);\r\n PenDown := False;\r\n if Assigned(Canvas) then\r\n begin\r\n Canvas.Pen.Color := clWindowText; // (rom) from clBlack\r\n Canvas.Brush.Color := clWindow; // (rom) from clWhite\r\n Canvas.Font.Color := clWindowText; // (rom) added\r\n Canvas.CopyMode := cmSrcCopy;\r\n end;\r\n Mark := Position;\r\n Area := Rect(0, 0, 0, 0);\r\nend;\r\n\r\nfunction TJvTurtle.txIn: string;\r\nvar\r\n Token: string;\r\n Num: Integer;\r\n N: Integer;\r\nbegin\r\n if NPop(Result, Num) then\r\n if GetToken(Token) then\r\n begin\r\n if not FVariables.Find(Token, N) then\r\n N := FVariables.Add(Token);\r\n FVariables.Objects[N] := TObject(Num);\r\n Result := '';\r\n end\r\n else\r\n Result := RsTokenExpected;\r\nend;\r\n\r\nfunction TJvTurtle.IsVar(Tex: string): Boolean;\r\nvar\r\n N: Integer;\r\n Msg: string;\r\nbegin\r\n Result := FVariables.Find(Tex, N);\r\n if Result then\r\n Result := NPush(Msg, Integer(FVariables.Objects[N]));\r\nend;\r\n\r\nfunction TJvTurtle.txInAdd: string;\r\nvar\r\n Token: string;\r\n N, Num: Integer;\r\nbegin\r\n if NPop(Result, Num) then\r\n if GetToken(Token) then\r\n begin\r\n if FVariables.Find(Token, N) then\r\n begin\r\n FVariables.Objects[N] := TObject(Integer(FVariables.Objects[N]) + Num);\r\n Result := '';\r\n end\r\n else\r\n Result := Format(RssDoesNotExist, [Token]);\r\n end\r\n else\r\n Result := RsTokenExpected;\r\nend;\r\n\r\nfunction TJvTurtle.txInSub: string;\r\nvar\r\n Token: string;\r\n N, Num: Integer;\r\nbegin\r\n if NPop(Result, Num) then\r\n if GetToken(Token) then\r\n begin\r\n if FVariables.Find(Token, N) then\r\n begin\r\n FVariables.Objects[N] := TObject(Integer(FVariables.Objects[N]) - Num);\r\n Result := '';\r\n end\r\n else\r\n Result := Format(RssDoesNotExist, [Token]);\r\n end\r\n else\r\n Result := RsTokenExpected;\r\nend;\r\n\r\nfunction TJvTurtle.txInMult: string;\r\nvar\r\n Token: string;\r\n N, Num: Integer;\r\nbegin\r\n if NPop(Result, Num) then\r\n if GetToken(Token) then\r\n begin\r\n if FVariables.Find(Token, N) then\r\n begin\r\n FVariables.Objects[N] := TObject(Integer(FVariables.Objects[N]) * Num);\r\n Result := '';\r\n end\r\n else\r\n Result := Format(RssDoesNotExist, [Token]);\r\n end\r\n else\r\n Result := RsTokenExpected;\r\nend;\r\n\r\nfunction TJvTurtle.txInDiv: string;\r\nvar\r\n Token: string;\r\n N, Num: Integer;\r\nbegin\r\n if NPop(Result, Num) then\r\n if Num = 0 then\r\n Result := RsDivisionByZeroNotAllowedInIn\r\n else\r\n if GetToken(Token) then\r\n begin\r\n if FVariables.Find(Token, N) then\r\n begin\r\n FVariables.Objects[N] := TObject(Integer(FVariables.Objects[N]) div Num);\r\n Result := '';\r\n end\r\n else\r\n Result := Format(RssDoesNotExist, [Token]);\r\n end\r\n else\r\n Result := RsTokenExpected;\r\nend;\r\n\r\nfunction TJvTurtle.txInDec: string;\r\nvar\r\n Token: string;\r\n N: Integer;\r\nbegin\r\n if GetToken(Token) then\r\n begin\r\n if FVariables.Find(Token, N) then\r\n begin\r\n FVariables.Objects[N] := TObject(Integer(FVariables.Objects[N]) - 1);\r\n Result := '';\r\n end\r\n else\r\n Result := Format(RssDoesNotExist, [Token]);\r\n end\r\n else\r\n Result := RsTokenExpected;\r\nend;\r\n\r\nfunction TJvTurtle.txInInc: string;\r\nvar\r\n Token: string;\r\n N: Integer;\r\nbegin\r\n if GetToken(Token) then\r\n begin\r\n if FVariables.Find(Token, N) then\r\n begin\r\n FVariables.Objects[N] := TObject(Integer(FVariables.Objects[N]) + 1);\r\n Result := '';\r\n end\r\n else\r\n Result := Format(RssDoesNotExist, [Token]);\r\n end\r\n else\r\n Result := RsTokenExpected;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvTypes.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvTypes.PAS, released on 2001-02-28.\r\n\r\nThe Initial Developer of the Original Code is Sbastien Buysse [sbuysse att buypin dott com]\r\nPortions created by Sbastien Buysse are Copyright (C) 2001 Sbastien Buysse.\r\nAll Rights Reserved.\r\n\r\nContributor(s): Michael Beck [mbeck att bigfoot dott com].\r\n Peter Thornqvist\r\n Oliver Giesen\r\n Gustavo Bianconi\r\n dejoy\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvTypes.pas 13173 2011-11-19 12:43:58Z ahuser $\r\n\r\nunit JvTypes;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n SysUtils, Classes,\r\n Windows, Messages, Controls, Forms, Graphics,\r\n JvResources;\r\n\r\nconst\r\n MaxPixelCount = 32767;\r\n\r\n{$IFNDEF COMPILER12_UP}\r\n{$HPPEMIT '#ifndef TDate'}\r\n{$HPPEMIT '#define TDate Controls::TDate'}\r\n{$HPPEMIT '#define TTime Controls::TTime'}\r\n{$HPPEMIT '#endif'}\r\n{$ENDIF !COMPILER12_UP}\r\n\r\ntype\r\n TJvBytes = Pointer;\r\n IntPtr = Pointer;\r\n\r\ntype\r\n {$IFNDEF COMPILER9_UP}\r\n TVerticalAlignment = (taAlignTop, taAlignBottom, taVerticalCenter);\r\n TTopBottom = taAlignTop..taAlignBottom;\r\n {$ENDIF ~COMPILER9_UP}\r\n\r\n PCaptionChar = PChar;\r\n\r\n {$IFDEF COMPILER12_UP}\r\n THintInfo = Controls.THintInfo;\r\n {$EXTERNALSYM THintInfo}\r\n PHintInfo = Controls.PHintInfo;\r\n {$EXTERNALSYM PHintInfo}\r\n {$ENDIF}\r\n\r\n // used in JvSpeedButton, JvArrowButton, JvButton CM_JVBUTTONPRESSED\r\n // asn: can also be used with CM_BUTTONPRESSED\r\n TCMButtonPressed = record\r\n Msg: Cardinal;\r\n Index: Integer;\r\n {$IFDEF COMPILER16_UP}\r\n WParamFiller: TDWordFiller;\r\n {$ENDIF COMPILER16_UP}\r\n Control: TControl;\r\n Result: LRESULT;\r\n end;\r\n\r\n THintString = string;\r\n THintStringList = TStringList;\r\n\r\n { JvExVCL classes }\r\n TInputKey = (ikAll, ikArrows, ikChars, ikButton, ikTabs, ikEdit, ikNative{, ikNav, ikEsc});\r\n TInputKeys = set of TInputKey;\r\n\r\n TJvRGBTriple = packed record\r\n rgbBlue: Byte;\r\n rgbGreen: Byte;\r\n rgbRed: Byte;\r\n end;\r\n\r\nconst\r\n NullHandle = 0;\r\n // (rom) deleted fbs constants. They are already in JvConsts.pas.\r\n\r\ntype\r\n TTimerProc = procedure(hwnd: THandle; Msg: Cardinal; idEvent: Cardinal; dwTime: Cardinal);\r\n\r\ntype\r\n // Base class for persistent properties that can show events.\r\n // By default, Delphi and BCB don't show the events of a class\r\n // derived from TPersistent unless it also derives from\r\n // TComponent. \r\n // The design time editor associated with TJvPersistent will display\r\n // the events, thus mimicking a Sub Component.\r\n TJvPersistent = class(TComponent)\r\n private\r\n FOwner: TPersistent;\r\n function _GetOwner: TPersistent;\r\n protected\r\n function GetOwner: TPersistent; override;\r\n public\r\n constructor Create(AOwner: TPersistent); reintroduce; virtual;\r\n\r\n function GetNamePath: string; override;\r\n property Owner: TPersistent read _GetOwner;\r\n end;\r\n\r\n // Added by dejoy (2005-04-20)\r\n // A lot of TJVxxx control persistent properties used TPersistent,\r\n // So and a TJvPersistentProperty to do this job. make to support batch-update mode\r\n // and property change notify.\r\n TJvPropertyChangeEvent = procedure(Sender: TObject; const PropName: string) of object;\r\n\r\n TJvPersistentProperty = class(TJvPersistent)//TPersistent => TJvPersistent\r\n private\r\n FUpdateCount: Integer;\r\n FOnChanging: TNotifyEvent;\r\n FOnChanged: TNotifyEvent;\r\n FOnChangingProperty: TJvPropertyChangeEvent;\r\n FOnChangedProperty: TJvPropertyChangeEvent;\r\n protected\r\n procedure Changed; virtual;\r\n procedure Changing; virtual;\r\n procedure ChangedProperty(const PropName: string); virtual;\r\n procedure ChangingProperty(const PropName: string); virtual;\r\n procedure SetUpdateState(Updating: Boolean); virtual;\r\n property UpdateCount: Integer read FUpdateCount;\r\n public\r\n procedure BeginUpdate; virtual;\r\n procedure EndUpdate; virtual;\r\n property OnChanged: TNotifyEvent read FOnChanged write FOnChanged;\r\n property OnChanging: TNotifyEvent read FOnChanging write FOnChanging;\r\n property OnChangedProperty: TJvPropertyChangeEvent read FOnChangedProperty write FOnChangedProperty;\r\n property OnChangingProperty: TJvPropertyChangeEvent read FOnChangingProperty write FOnChangingProperty;\r\n end;\r\n\r\n TJvRegKey = (hkClassesRoot, hkCurrentUser, hkLocalMachine, hkUsers,\r\n hkPerformanceData, hkCurrentConfig, hkDynData);\r\n TJvRegKeys = set of TJvRegKey;\r\n\r\n // base JVCL Exception class to derive from\r\n EJVCLException = class(Exception);\r\n\r\n TJvLinkClickEvent = procedure(Sender: TObject; Link: string) of object;\r\n // TOnRegistryChangeKey = procedure(Sender: TObject; RootKey: HKEY; Path: string) of object;\r\n // TAngle = 0..360;\r\n TJvOutputMode = (omFile, omStream);\r\n // TLabelDirection = (sdLeftToRight, sdRightToLeft); // JvScrollingLabel\r\n\r\n TJvDoneFileEvent = procedure(Sender: TObject; FileName: string; FileSize: Integer; Url: string) of object;\r\n TJvDoneStreamEvent = procedure(Sender: TObject; Stream: TStream; StreamSize: Integer; Url: string) of object;\r\n TJvHTTPProgressEvent = procedure(Sender: TObject; UserData, Position: Integer; TotalSize: Integer; Url: string; var Continue: Boolean) of object;\r\n TJvFTPProgressEvent = procedure(Sender: TObject; Position: Integer; Url: string) of object;\r\n\r\n // from JvComponent.pas\r\n TJvClipboardCommand = (caCopy, caCut, caPaste, caClear, caUndo);\r\n TJvClipboardCommands = set of TJvClipboardCommand;\r\n\r\n // used in JvButton\r\n TCMForceSize = record\r\n Msg: Cardinal;\r\n NewSize: TSmallPoint;\r\n Sender: TControl;\r\n Result: Longint;\r\n end;\r\n\r\n PJvRGBArray = ^TJvRGBArray;\r\n TJvRGBArray = array [0..MaxPixelCount] of TJvRGBTriple;\r\n PRGBQuadArray = ^TRGBQuadArray;\r\n TRGBQuadArray = array [0..MaxPixelCount] of TRGBQuad;\r\n PRGBPalette = ^TRGBPalette;\r\n TRGBPalette = array [Byte] of TRGBQuad;\r\n\r\n { (rom) unused\r\n TJvPoint = class(TPersistent)\r\n protected\r\n FX: Integer;\r\n FY: Integer;\r\n published\r\n property X: Integer read FX write FX;\r\n property Y: Integer read FY write FY;\r\n end;\r\n }\r\n\r\n TJvErrorEvent = procedure(Sender: TObject; ErrorMsg: string) of object;\r\n TJvWaveLocation = (frFile, frResource, frRAM);\r\n\r\n TJvPopupPosition = (ppNone, ppForm, ppApplication);\r\n // TJvDirMask = (dmFileNameChange, dmDirnameChange, dmAttributesChange, dmSizeChange, dmLastWriteChange, dmSecurityChange); //JvDirectorySpy\r\n // TJvDirMasks = set of TJvDirMask;\r\n // EJvDirectoryError = class(EJVCLException); // JvDirectorySpy\r\n // TListEvent = procedure(Sender: TObject; Title: string; Handle: THandle) of object; // JvWindowsTitle\r\n\r\n TJvProgressEvent = procedure(Sender: TObject; Current, Total: Integer) of object;\r\n TJvNextPageEvent = procedure(Sender: TObject; PageNumber: Integer) of object;\r\n TJvBitmapStyle = (bsNormal, bsCentered, bsStretched);\r\n\r\n // TOnOpened = procedure(Sender: TObject; Value: string) of object; // archive\r\n // TOnOpenCanceled = procedure(Sender: TObject) of object; // archive\r\n\r\n TJvGradientStyle = (grFilled, grEllipse, grHorizontal, grVertical, grPyramid, grMount);\r\n // TOnDelete = procedure(Sender: TObject; Path: string) of object;\r\n TJvParentEvent = procedure(Sender: TObject; ParentWindow: THandle) of object;\r\n // TOnImage = procedure(Sender: TObject; Image: TBitmap) of object; // JvClipboardViewer\r\n // TOnText = procedure(Sender: TObject; Text: string) of object;\r\n // TJvRestart = (rsLogoff, rsShutdown, rsReboot, rsRestart, rsRebootSystem, rsExitAndExecApp);\r\n // TJvRunOption = (roNoBrowse, roNoDefault, roCalcDirectory, roNoLabel, roNoSeparateMem); // JvRunDlg\r\n // TJvRunOptions = set of TJvRunOption; // JvRunDlg\r\n // TJvFileKind = (ftFile, ftPrinter); // JvObjectPropertiesDlg\r\n\r\n // TSHFormatDrive = function(Handle: THandle; Drive, ID, Options: Word): LongInt; stdcall; // JvFormatDrive\r\n // TFormatOption = (shQuickFormat, shFull, shSystemFilesOnly); // JvFormatDrive\r\n // TButtonStyle = (bsAbortRetryIgnore, bsOk, bsOkCancel, bsRetryCancel, bsYesNo, bsYesNoCancel); // JvMessageBox\r\n // TButtonDisplay = (bdIconExclamation, bdIconWarning, bdIconInformation, bdIconAsterisk, bdIconQuestion, bdIconStop, bdIconError, bdIconHand); // JvMessageBox\r\n\r\n // TDefault = (dbButton1, dbButton2, dbButton3, dbButton4); // JvMessageBox\r\n // TModality = (bmApplModal, bmSystemModal, bmTaskModal); // JvMessageBox\r\n // TButtonOption = (boDefaultDesktopOnly, boHelp, boRight, boRtlReading, boSetForeground, boTopMost); // JvMessageBox\r\n // TButtonOptions = set of TButtonOption; // JvMessageBox\r\n // TButtonResult = (brAbort, brCancel, brIgnore, brNo, brOk, brRetry, brYes); // JvMessageBox\r\n // TMsgStyle = (msBeep, msIconAsterisk, msIconExclamation, msIconHand, msIconQuestion, msOk); // JvMessageBeep\r\n TJvDiskRes = (dsSuccess, dsCancel, dsSkipfile, dsError);\r\n TJvDiskStyle = (idfCheckFirst, idfNoBeep, idfNoBrowse, idfNoCompressed, idfNoDetails,\r\n idfNoForeground, idfNoSkip, idfOemDisk, idfWarnIfSkip);\r\n TJvDiskStyles = set of TJvDiskStyle;\r\n TJvDeleteStyle = (idNoBeep, idNoForeground);\r\n TJvDeleteStyles = set of TJvDeleteStyle;\r\n // TOnOk = procedure(Sender: TObject; Password: string; var Accept: Boolean) of object; // JvPasswordForm\r\n\r\n // TCoordChanged = procedure(Sender: TObject; Coord: string) of object;\r\n TJvNotifyParamsEvent = procedure(Sender: TObject; Params: Pointer) of object;\r\n\r\n TJvFileInfoRec = record\r\n Attributes: DWORD;\r\n DisplayName: string;\r\n ExeType: Integer;\r\n Icon: HICON;\r\n Location: string;\r\n TypeName: string;\r\n SysIconIndex: Integer;\r\n end;\r\n\r\n TJvAnimation = (anLeftRight, anRightLeft, anRightAndLeft, anLeftVumeter, anRightVumeter);\r\n TJvAnimations = set of TJvAnimation;\r\n // TOnFound = procedure(Sender: TObject; Path: string) of object; // JvSearchFile\r\n // TOnChangedDir = procedure(Sender: TObject; Directory: string) of object; // JvSearchFile\r\n // TOnAlarm = procedure(Sender: TObject; Keyword: string) of object; // JvAlarm\r\n { TAlarm = record\r\n Keyword: string;\r\n DateTime: TDateTime;\r\n end;\r\n } // JvAlarm\r\n\r\n // Bianconi - Moved from JvAlarms.pas\r\n TJvTriggerKind =\r\n (tkOneShot, tkEachSecond, tkEachMinute, tkEachHour, tkEachDay, tkEachMonth, tkEachYear);\r\n // End of Bianconi\r\n\r\n TJvFourCC = array [0..3] of AnsiChar;\r\n PJvAniTag = ^TJvAniTag;\r\n TJvAniTag = packed record\r\n ckID: TJvFourCC;\r\n ckSize: Longint;\r\n end;\r\n\r\n TJvAniHeader = packed record\r\n dwSizeof: Longint;\r\n dwFrames: Longint;\r\n dwSteps: Longint;\r\n dwCX: Longint;\r\n dwCY: Longint;\r\n dwBitCount: Longint;\r\n dwPlanes: Longint;\r\n dwJIFRate: Longint;\r\n dwFlags: Longint;\r\n end;\r\n\r\n TJvChangeColorEvent = procedure(Sender: TObject; Foreground, Background: TColor) of object;\r\n\r\n TJvLayout = (lTop, lCenter, lBottom);\r\n TJvBevelStyle = (bsShape, bsLowered, bsRaised);\r\n\r\n {for OnLoseFocus the AFocusControl argument will point at the control that\r\n receives focus while for OnGetFocus it is the control that lost the focus}\r\n TJvFocusChangeEvent = procedure(const ASender: TObject;\r\n const AFocusControl: TWinControl) of object;\r\n\r\n // JvJCLUtils\r\n TTickCount = Cardinal;\r\n\r\n {**** string handling routines}\r\n TSetOfChar = TSysCharSet;\r\n TCharSet = TSysCharSet;\r\n\r\n TDateOrder = (doMDY, doDMY, doYMD);\r\n TDayOfWeekName = (Sun, Mon, Tue, Wed, Thu, Fri, Sat);\r\n TDaysOfWeek = set of TDayOfWeekName;\r\n\r\nconst\r\n DefaultDateOrder = doDMY;\r\n\r\n CenturyOffset: Byte = 60;\r\n NullDate: TDateTime = 0; {-693594}\r\n\r\ntype\r\n // JvDriveCtrls / JvLookOut\r\n TJvImageSize = (isSmall, isLarge);\r\n TJvImageAlign = (iaLeft, iaCentered);\r\n\r\n TJvDriveType = (dtUnknown, dtRemovable, dtFixed, dtRemote, dtCDROM, dtRamDisk);\r\n TJvDriveTypes = set of TJvDriveType;\r\n\r\n // Defines how a property (like a HotTrackFont) follows changes in the component's normal Font\r\n TJvTrackFontOption = (\r\n hoFollowFont, // makes HotTrackFont follow changes to the normal Font\r\n hoPreserveCharSet, // don't change HotTrackFont.Charset\r\n hoPreserveColor, // don't change HotTrackFont.Color\r\n hoPreserveHeight, // don't change HotTrackFont.Height (affects Size as well)\r\n hoPreserveName, // don't change HotTrackFont.Name\r\n hoPreservePitch, // don't change HotTrackFont.Pitch\r\n hoPreserveStyle); // don't change HotTrackFont.Style\r\n TJvTrackFontOptions = set of TJvTrackFontOption;\r\n\r\nconst\r\n DefaultTrackFontOptions = [hoFollowFont, hoPreserveColor, hoPreserveStyle];\r\n DefaultHotTrackColor = $00D2BDB6;\r\n DefaultHotTrackFrameColor = $006A240A;\r\n\r\ntype\r\n // from JvListView.pas\r\n TJvSortMethod = (smAutomatic, smAlphabetic, smNonCaseSensitive, smNumeric, smDate, smTime, smDateTime, smCurrency);\r\n TJvListViewColumnSortEvent = procedure(Sender: TObject; Column: Integer; var AMethod: TJvSortMethod) of object;\r\n\r\n // from JvOfficeColorPanel.pas\r\n TJvAddInControlSiteInfo = record\r\n AddInControl: TControl;\r\n BoundsRect: TRect;\r\n SiteInfoData: TObject;\r\n end;\r\n\r\n TJvClickColorType =\r\n (cctColors, cctNoneColor, cctDefaultColor, cctCustomColor, cctAddInControl, cctNone);\r\n TJvHoldCustomColorEvent = procedure(Sender: TObject; AColor: TColor) of object;\r\n TJvColorQuadLayOut = (cqlNone, cqlLeft, cqlRight, cqlClient);\r\n TJvGetAddInControlSiteInfoEvent = procedure(Sender: TControl; var ASiteInfo: TJvAddInControlSiteInfo) of object;\r\n\r\n // from JvColorProvider.pas\r\n TColorType = (ctStandard, ctSystem, ctCustom);\r\n\r\n TDefColorItem = record\r\n Value: TColor;\r\n Constant: string;\r\n Description: string;\r\n end;\r\n\r\nconst\r\n ColCount = 20;\r\n StandardColCount = 40;\r\n SysColCount = 30;\r\n {$IFDEF COMPILER6}\r\n {$IF not declared(clHotLight)}\r\n {$MESSAGE ERROR 'You do not have Delphi 6 Runtime Library Update 2 installed. Please install it before installing the JVCL. http://downloads.codegear.com/default.aspx?productid=300'}\r\n {$IFEND}\r\n {$ENDIF COMPILER6}\r\n\r\n ColorValues: array [0 .. ColCount - 1] of TDefColorItem = (\r\n (Value: clBlack; Constant: 'clBlack'; Description: RsClBlack),\r\n (Value: clMaroon; Constant: 'clMaroon'; Description: RsClMaroon),\r\n (Value: clGreen; Constant: 'clGreen'; Description: RsClGreen),\r\n (Value: clOlive; Constant: 'clOlive'; Description: RsClOlive),\r\n (Value: clNavy; Constant: 'clNavy'; Description: RsClNavy),\r\n (Value: clPurple; Constant: 'clPurple'; Description: RsClPurple),\r\n (Value: clTeal; Constant: 'clTeal'; Description: RsClTeal),\r\n (Value: clGray; Constant: 'clGray'; Description: RsClGray),\r\n (Value: clSilver; Constant: 'clSilver'; Description: RsClSilver),\r\n (Value: clRed; Constant: 'clRed'; Description: RsClRed),\r\n (Value: clLime; Constant: 'clLime'; Description: RsClLime),\r\n (Value: clYellow; Constant: 'clYellow'; Description: RsClYellow),\r\n (Value: clBlue; Constant: 'clBlue'; Description: RsClBlue),\r\n (Value: clFuchsia; Constant: 'clFuchsia'; Description: RsClFuchsia),\r\n (Value: clAqua; Constant: 'clAqua'; Description: RsClAqua),\r\n (Value: clWhite; Constant: 'clWhite'; Description: RsClWhite),\r\n (Value: clMoneyGreen; Constant: 'clMoneyGreen'; Description: RsClMoneyGreen),\r\n (Value: clSkyBlue; Constant: 'clSkyBlue'; Description: RsClSkyBlue),\r\n (Value: clCream; Constant: 'clCream'; Description: RsClCream),\r\n (Value: clMedGray; Constant: 'clMedGray'; Description: RsClMedGray)\r\n );\r\n\r\n //added by dejoy (2005-04-20)\r\n StandardColorValues: array [0 .. StandardColCount - 1] of TDefColorItem = (\r\n (Value: $00000000; Constant: 'clBlack'; Description: RsClBlack),\r\n (Value: $00003399; Constant: 'clBrown'; Description: RsClBrown),\r\n (Value: $00003333; Constant: 'clOliveGreen'; Description: RsClOliveGreen),\r\n (Value: $00003300; Constant: 'clDarkGreen'; Description: RsClDarkGreen),\r\n (Value: $00663300; Constant: 'clDarkTeal'; Description: RsClDarkTeal),\r\n (Value: $00800000; Constant: 'clDarkBlue'; Description: RsClDarkBlue),\r\n (Value: $00993333; Constant: 'clIndigo'; Description: RsClIndigo),\r\n (Value: $00333333; Constant: 'clGray80'; Description: RsClGray80),\r\n\r\n (Value: $00000080; Constant: 'clDarkRed'; Description: RsClDarkRed),\r\n (Value: $000066FF; Constant: 'clOrange'; Description: RsClOrange),\r\n (Value: $00008080; Constant: 'clDarkYellow'; Description: RsClDarkYellow),\r\n (Value: $00008000; Constant: 'clGreen'; Description: RsClGreen),\r\n (Value: $00808000; Constant: 'clTeal'; Description: RsClTeal),\r\n (Value: $00FF0000; Constant: 'clBlue'; Description: RsClBlue),\r\n (Value: $00996666; Constant: 'clBlueGray'; Description: RsClBlueGray),\r\n (Value: $00808080; Constant: 'clGray50'; Description: RsClGray50),\r\n\r\n (Value: $000000FF; Constant: 'clRed'; Description: RsClRed),\r\n (Value: $000099FF; Constant: 'clLightOrange'; Description: RsClLightOrange),\r\n (Value: $0000CC99; Constant: 'clLime'; Description: RsClLime),\r\n (Value: $00669933; Constant: 'clSeaGreen'; Description: RsClSeaGreen),\r\n (Value: $00999933; Constant: 'clAqua'; Description: RsClAqua),\r\n (Value: $00FF6633; Constant: 'clLightBlue'; Description: RsClLightBlue),\r\n (Value: $00800080; Constant: 'clViolet'; Description: RsClViolet),\r\n (Value: $00999999; Constant: 'clGray40'; Description: RsClGray40),\r\n\r\n (Value: $00FF00FF; Constant: 'clPink'; Description: RsClPink),\r\n (Value: $0000CCFF; Constant: 'clGold'; Description: RsClGold),\r\n (Value: $0000FFFF; Constant: 'clYellow'; Description: RsClYellow),\r\n (Value: $0000FF00; Constant: 'clBrightGreen'; Description: RsClBrightGreen),\r\n (Value: $00FFFF00; Constant: 'clTurquoise'; Description: RsClTurquoise),\r\n (Value: $00F0CAA6; Constant: 'clSkyBlue'; Description: RsClSkyBlue),\r\n (Value: $00663399; Constant: 'clPlum'; Description: RsClPlum),\r\n (Value: $00C0C0C0; Constant: 'clGray25'; Description: RsClGray25),\r\n\r\n (Value: $00CC99FF; Constant: 'clRose'; Description: RsClRose),\r\n (Value: $0099CCFF; Constant: 'clTan'; Description: RsClTan),\r\n (Value: $0099FFFF; Constant: 'clLightYellow'; Description: RsClLightYellow),\r\n (Value: $00CCFFCC; Constant: 'clLightGreen'; Description: RsClLightGreen),\r\n (Value: $00FFFFCC; Constant: 'clLightTurquoise'; Description: RsClLightTurquoise),\r\n (Value: $00FFCC99; Constant: 'clPaleBlue'; Description: RsClPaleBlue),\r\n (Value: $00FF99CC; Constant: 'clLavender'; Description: RsClLavender),\r\n (Value: $00FFFFFF; Constant: 'clWhite'; Description: RsClWhite)\r\n );\r\n\r\n SysColorValues: array [0 .. SysColCount - 1] of TDefColorItem = (\r\n (Value: clScrollBar; Constant: 'clScrollBar'; Description: RsClScrollBar),\r\n (Value: clBackground; Constant: 'clBackground'; Description: RsClBackground),\r\n (Value: clActiveCaption; Constant: 'clActiveCaption'; Description: RsClActiveCaption),\r\n (Value: clInactiveCaption; Constant: 'clInactiveCaption'; Description: RsClInactiveCaption),\r\n (Value: clMenu; Constant: 'clMenu'; Description: RsClMenu),\r\n (Value: clWindow; Constant: 'clWindow'; Description: RsClWindow),\r\n (Value: clWindowFrame; Constant: 'clWindowFrame'; Description: RsClWindowFrame),\r\n (Value: clMenuText; Constant: 'clMenuText'; Description: RsClMenuText),\r\n (Value: clWindowText; Constant: 'clWindowText'; Description: RsClWindowText),\r\n (Value: clCaptionText; Constant: 'clCaptionText'; Description: RsClCaptionText),\r\n (Value: clActiveBorder; Constant: 'clActiveBorder'; Description: RsClActiveBorder),\r\n (Value: clInactiveBorder; Constant: 'clInactiveBorder'; Description: RsClInactiveBorder),\r\n (Value: clAppWorkSpace; Constant: 'clAppWorkSpace'; Description: RsClAppWorkSpace),\r\n (Value: clHighlight; Constant: 'clHighlight'; Description: RsClHighlight),\r\n (Value: clHighlightText; Constant: 'clHighlightText'; Description: RsClHighlightText),\r\n (Value: clBtnFace; Constant: 'clBtnFace'; Description: RsClBtnFace),\r\n (Value: clBtnShadow; Constant: 'clBtnShadow'; Description: RsClBtnShadow),\r\n (Value: clGrayText; Constant: 'clGrayText'; Description: RsClGrayText),\r\n (Value: clBtnText; Constant: 'clBtnText'; Description: RsClBtnText),\r\n (Value: clInactiveCaptionText; Constant: 'clInactiveCaptionText'; Description: RsClInactiveCaptionText),\r\n (Value: clBtnHighlight; Constant: 'clBtnHighlight'; Description: RsClBtnHighlight),\r\n (Value: cl3DDkShadow; Constant: 'cl3DDkShadow'; Description: RsCl3DDkShadow),\r\n (Value: cl3DLight; Constant: 'cl3DLight'; Description: RsCl3DLight),\r\n (Value: clInfoText; Constant: 'clInfoText'; Description: RsClInfoText),\r\n (Value: clInfoBk; Constant: 'clInfoBk'; Description: RsClInfoBk),\r\n\r\n (Value: clGradientActiveCaption; Constant: 'clGradientActiveCaption'; Description: RsGradientActiveCaption),\r\n (Value: clGradientInactiveCaption; Constant: 'clGradientInactiveCaption';Description: RsGradientInactiveCaption),\r\n (Value: clHotLight; Constant: 'clHotLight'; Description: RsHotLight),\r\n (Value: clMenuBar; Constant: 'clMenuBar'; Description: RsMenuBar),\r\n (Value: clMenuHighlight; Constant: 'clMenuHighlight'; Description: RsMenuHighlight)\r\n );\r\n\r\ntype\r\n TJvCustomThread = class(TThread)\r\n private\r\n FThreadName: String;\r\n function GetThreadName: String; virtual;\r\n procedure SetThreadName(const Value: String); virtual;\r\n public\r\n {$IFNDEF DELPHI2010_UP}\r\n procedure NameThreadForDebugging(AThreadName: AnsiString; AThreadID: LongWord = $FFFFFFFF);\r\n {$ENDIF}\r\n procedure NameThread(AThreadName: AnsiString; AThreadID: LongWord = $FFFFFFFF); {$IFDEF SUPPORTS_UNICODE_STRING} overload; {$ENDIF} virtual;\r\n {$IFDEF SUPPORTS_UNICODE_STRING}\r\n procedure NameThread(AThreadName: String; AThreadID: LongWord = $FFFFFFFF); overload;\r\n {$ENDIF}\r\n property ThreadName: String read GetThreadName write SetThreadName;\r\n end;\r\n\r\n// Using this variable you can enhance the NameThread procedure system wide by inserting a procedure\r\n// which executes for example a MadExcept TraceOut to enhance the MadExcept call stack results.\r\n// The procedure for MadExcept could look like:\r\n//\r\n// procedure NameThreadMadExcept(AThreadName: AnsiString; AThreadID: LongWord);\r\n// begin\r\n// MadExcept.NameThread(AThreadID, AThreadName);\r\n// end;\r\n//\r\n// And the initialization of the unit should look like:\r\n//\r\n// initialization\r\n// JvTypes.JvCustomThreadNamingProc := NameThreadMadExcept;\r\n//\r\nvar\r\n JvCustomThreadNamingProc: procedure (AThreadName: AnsiString; AThreadID: LongWord);\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvTypes.pas $';\r\n Revision: '$Revision: 13173 $';\r\n Date: '$Date: 2011-11-19 13:43:58 +0100 (sam. 19 nov. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\n{ TJvPersistent }\r\nconstructor TJvPersistent.Create(AOwner: TPersistent);\r\nbegin\r\n if AOwner is TComponent then\r\n inherited Create(AOwner as TComponent)\r\n else\r\n inherited Create(nil);\r\n SetSubComponent(True);\r\n\r\n FOwner := AOwner;\r\nend;\r\n\r\ntype\r\n TPersistentAccessProtected = class(TPersistent);\r\n\r\nfunction TJvPersistent.GetNamePath: string;\r\nvar\r\n S: string;\r\n lOwner: TPersistent;\r\nbegin\r\n Result := inherited GetNamePath;\r\n lOwner := GetOwner; //Resturn Nested NamePath\r\n if (lOwner <> nil)\r\n and ( (csSubComponent in TComponent(lOwner).ComponentStyle)\r\n or (TPersistentAccessProtected(lOwner).GetOwner <> nil)\r\n )\r\n then\r\n begin\r\n S := lOwner.GetNamePath;\r\n if S <> '' then\r\n Result := S + '.' + Result;\r\n end;\r\nend;\r\n\r\nfunction TJvPersistent.GetOwner: TPersistent;\r\nbegin\r\n Result := FOwner;\r\nend;\r\n\r\nfunction TJvPersistent._GetOwner: TPersistent;\r\nbegin\r\n Result := GetOwner;\r\nend;\r\n\r\n{ TJvPersistentProperty }\r\n\r\nprocedure TJvPersistentProperty.BeginUpdate;\r\nbegin\r\n if FUpdateCount = 0 then\r\n SetUpdateState(True);\r\n Inc(FUpdateCount);\r\nend;\r\n\r\nprocedure TJvPersistentProperty.Changed;\r\nbegin\r\n if (FUpdateCount = 0) and Assigned(FOnChanged) then\r\n FOnChanged(Self);\r\nend;\r\n\r\nprocedure TJvPersistentProperty.ChangedProperty(const PropName: string);\r\nbegin\r\n if Assigned(FOnChangedProperty) then\r\n FOnChangedProperty(Self, PropName);\r\nend;\r\n\r\nprocedure TJvPersistentProperty.Changing;\r\nbegin\r\n if (FUpdateCount = 0) and Assigned(FOnChanging) then\r\n FOnChanging(Self);\r\nend;\r\n\r\nprocedure TJvPersistentProperty.ChangingProperty(const PropName: string);\r\nbegin\r\n if Assigned(FOnChangingProperty) then\r\n FOnChangingProperty(Self, PropName);\r\nend;\r\n\r\nprocedure TJvPersistentProperty.EndUpdate;\r\nbegin\r\n Dec(FUpdateCount);\r\n if FUpdateCount = 0 then\r\n SetUpdateState(False);\r\nend;\r\n\r\nprocedure TJvPersistentProperty.SetUpdateState(Updating: Boolean);\r\nbegin\r\n if Updating then\r\n Changing\r\n else\r\n Changed;\r\nend;\r\n\r\n{$IFNDEF DELPHI2010_UP}\r\nprocedure TJvCustomThread.NameThreadForDebugging(AThreadName: AnsiString; AThreadID: LongWord = $FFFFFFFF);\r\ntype\r\n TThreadNameInfo = record\r\n FType: LongWord; // must be 0x1000\r\n FName: PAnsiChar; // pointer to name (in user address space)\r\n FThreadID: LongWord; // thread ID (-1 indicates caller thread)\r\n FFlags: LongWord; // reserved for future use, must be zero\r\n end;\r\nvar\r\n ThreadNameInfo: TThreadNameInfo;\r\nbegin\r\n //if IsDebuggerPresent then\r\n begin\r\n ThreadNameInfo.FType := $1000;\r\n ThreadNameInfo.FName := PAnsiChar(AThreadName);\r\n ThreadNameInfo.FThreadID := AThreadID;\r\n ThreadNameInfo.FFlags := 0;\r\n\r\n try\r\n RaiseException($406D1388, 0, sizeof(ThreadNameInfo) div sizeof(LongWord), @ThreadNameInfo);\r\n except\r\n end;\r\n end;\r\nend;\r\n{$ENDIF DELPHI2010_UP}\r\n\r\nfunction TJvCustomThread.GetThreadName: String;\r\nbegin\r\n if FThreadName = '' then\r\n Result := ClassName\r\n else\r\n Result := FThreadName+' {'+ClassName+'}';\r\nend;\r\n\r\nprocedure TJvCustomThread.NameThread(AThreadName: AnsiString; AThreadID: LongWord = $FFFFFFFF);\r\nbegin\r\n if AThreadID = $FFFFFFFF then\r\n AThreadID := ThreadID;\r\n NameThreadForDebugging(aThreadName, AThreadID);\r\n if Assigned(JvCustomThreadNamingProc) then\r\n JvCustomThreadNamingProc(aThreadName, AThreadID);\r\nend;\r\n\r\n{$IFDEF SUPPORTS_UNICODE_STRING}\r\nprocedure TJvCustomThread.NameThread(AThreadName: String; AThreadID: LongWord = $FFFFFFFF);\r\nbegin\r\n NameThread(AnsiString(AThreadName), AThreadId);\r\nend;\r\n{$ENDIF}\r\n\r\nprocedure TJvCustomThread.SetThreadName(const Value: String);\r\nbegin\r\n FThreadName := Value;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n\r\n" }, { "path": "External/Jedi/Jvcl/run/JvUniDacQuery.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvUniDacQuery.PAS, released on 2002-05-26.\r\n\r\nThe Initial Developer of the Original Code is Jens Fudickar\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nDescription:\r\n Oracle Dataset with Threaded Functions\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvUniDacQuery.pas 13371 2012-06-23 15:46:57Z jfudickar $\r\n\r\nunit JvUniDacQuery;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\n{$IFDEF USE_3RDPARTY_DEVART_UNIDAC}\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n SysUtils, Classes, Forms, Controls, DB,\r\n Uni, DBaccess,\r\n JvBaseDBThreadedDataset;\r\n{$ENDIF USE_3RDPARTY_DEVART_UNIDAC}\r\n\r\n{$IFDEF USE_3RDPARTY_DEVART_UNIDAC}\r\ntype\r\n TJvUniDacThreadedDatasetAllowedContinueRecordFetchOptions = class(TJvBaseThreadedDatasetAllowedContinueRecordFetchOptions)\r\n public\r\n constructor Create; override;\r\n published\r\n property All;\r\n End;\r\n\r\n TJvUniDacThreadedDatasetEnhancedOptions = Class(TJvBaseThreadedDatasetEnhancedOptions)\r\n private\r\n function GetAllowedContinueRecordFetchOptions: TJvUniDacThreadedDatasetAllowedContinueRecordFetchOptions;\r\n procedure SetAllowedContinueRecordFetchOptions(\r\n const Value: TJvUniDacThreadedDatasetAllowedContinueRecordFetchOptions);\r\n protected\r\n function CreateAllowedContinueRecordFetchOptions: TJvBaseThreadedDatasetAllowedContinueRecordFetchOptions;\r\n override;\r\n published\r\n property AllowedContinueRecordFetchOptions: TJvUniDacThreadedDatasetAllowedContinueRecordFetchOptions read\r\n GetAllowedContinueRecordFetchOptions write SetAllowedContinueRecordFetchOptions;\r\n end;\r\n\r\n TJvUniDacDatasetThreadHandler = class(TJvBaseDatasetThreadHandler)\r\n private\r\n FRefreshKeyFields: string;\r\n FRefreshKeyValues: Variant;\r\n protected\r\n function CreateEnhancedOptions: TJvBaseThreadedDatasetEnhancedOptions; override;\r\n property RefreshKeyFields: string read FRefreshKeyFields write\r\n FRefreshKeyFields;\r\n property RefreshKeyValues: Variant read FRefreshKeyValues write\r\n FRefreshKeyValues;\r\n public\r\n constructor Create(AOwner: TComponent; ADataset: TDataSet); reintroduce;\r\n override;\r\n procedure AfterRefresh; override;\r\n procedure BeforeRefresh; override;\r\n procedure RestoreRefreshKeyFields;\r\n procedure SaveRefreshKeyFields;\r\n End;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvUniDacUniQuery = class(TUniQuery, IJvThreadedDatasetInterface)\r\n procedure BreakExecution;\r\n procedure BringThreadDialogToFront;\r\n function DoGetInheritedNextRecord: Boolean;\r\n procedure DoInheritedAfterOpen;\r\n procedure DoInheritedAfterRefresh;\r\n procedure DoInheritedAfterScroll;\r\n procedure DoInheritedBeforeOpen;\r\n procedure DoInheritedBeforeRefresh;\r\n procedure DoInheritedInternalLast;\r\n procedure DoInheritedInternalRefresh;\r\n procedure DoInheritedSetActive(Active: Boolean);\r\n procedure DoInternalOpen;\r\n function GetDatasetFetchAllRecords: Boolean;\r\n function IsThreadAllowed: Boolean;\r\n procedure SetDatasetFetchAllRecords(const Value: Boolean);\r\n strict private\r\n private\r\n FBeforeFetch: TBeforeFetchEvent;\r\n FThreadHandler: TJvBaseDatasetThreadHandler;\r\n function GetAfterOpenFetch: TDataSetNotifyEvent;\r\n function GetAfterOpenFetch1: TDataSetNotifyEvent;\r\n function GetAfterThreadExecution: TJvThreadedDatasetThreadEvent;\r\n function GetBeforeThreadExecution: TJvThreadedDatasetThreadEvent;\r\n function GetDialogOptions: TJvThreadedDatasetDialogOptions;\r\n function GetEnhancedOptions: TJvUniDacThreadedDatasetEnhancedOptions;\r\n function GetThreadOptions: TJvThreadedDatasetThreadOptions;\r\n procedure SetAfterOpenFetch(const Value: TDataSetNotifyEvent);\r\n procedure SetAfterOpenFetch1(const Value: TDataSetNotifyEvent);\r\n procedure SetAfterThreadExecution(const Value: TJvThreadedDatasetThreadEvent);\r\n procedure SetBeforeThreadExecution(const Value: TJvThreadedDatasetThreadEvent);\r\n procedure SetDialogOptions(Value: TJvThreadedDatasetDialogOptions);\r\n procedure SetEnhancedOptions(const Value:\r\n TJvUniDacThreadedDatasetEnhancedOptions);\r\n procedure SetThreadOptions(const Value: TJvThreadedDatasetThreadOptions);\r\n property ThreadHandler: TJvBaseDatasetThreadHandler read FThreadHandler;\r\n protected\r\n procedure DoAfterOpen; override;\r\n procedure DoAfterRefresh; override;\r\n procedure DoAfterScroll; override;\r\n procedure DoBeforeOpen; override;\r\n procedure DoBeforeRefresh; override;\r\n function GetNextRecord: Boolean; override;\r\n function GetOnThreadException: TJvThreadedDatasetThreadExceptionEvent;\r\n procedure InternalLast; override;\r\n procedure InternalRefresh; override;\r\n procedure ReplaceBeforeFetch(Dataset: TCustomDADataSet; var Cancel: Boolean);\r\n procedure SetActive(Value: Boolean); override;\r\n procedure SetOnThreadException(const Value:\r\n TJvThreadedDatasetThreadExceptionEvent);\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n function CurrentFetchDuration: TDateTime;\r\n function CurrentOpenDuration: TDateTime;\r\n function EofReached: Boolean;\r\n function ErrorException: Exception;\r\n function ErrorMessage: string;\r\n function ThreadIsActive: Boolean;\r\n published\r\n property AfterOpenFetch: TDataSetNotifyEvent read GetAfterOpenFetch1 write\r\n SetAfterOpenFetch1;\r\n property AfterThreadExecution: TJvThreadedDatasetThreadEvent read\r\n GetAfterThreadExecution write SetAfterThreadExecution;\r\n property BeforeFetch: TBeforeFetchEvent read FBeforeFetch write FBeforeFetch;\r\n property BeforeThreadExecution: TJvThreadedDatasetThreadEvent read\r\n GetBeforeThreadExecution write SetBeforeThreadExecution;\r\n property DialogOptions: TJvThreadedDatasetDialogOptions read GetDialogOptions write SetDialogOptions;\r\n property EnhancedOptions: TJvUniDacThreadedDatasetEnhancedOptions read GetEnhancedOptions write SetEnhancedOptions;\r\n property ThreadOptions: TJvThreadedDatasetThreadOptions read GetThreadOptions write SetThreadOptions;\r\n property OnThreadException: TJvThreadedDatasetThreadExceptionEvent read\r\n GetOnThreadException write SetOnThreadException;\r\n end;\r\n\r\ntype\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvUniDacUniTable = class(TUniTable, IJvThreadedDatasetInterface)\r\n procedure BreakExecution;\r\n procedure BringThreadDialogToFront;\r\n function DoGetInheritedNextRecord: Boolean;\r\n procedure DoInheritedAfterOpen;\r\n procedure DoInheritedAfterRefresh;\r\n procedure DoInheritedAfterScroll;\r\n procedure DoInheritedBeforeOpen;\r\n procedure DoInheritedBeforeRefresh;\r\n procedure DoInheritedInternalLast;\r\n procedure DoInheritedInternalRefresh;\r\n procedure DoInheritedSetActive(Active: Boolean);\r\n procedure DoInternalOpen;\r\n function GetDatasetFetchAllRecords: Boolean;\r\n function IsThreadAllowed: Boolean;\r\n private\r\n FBeforeFetch: TBeforeFetchEvent;\r\n FThreadHandler: TJvBaseDatasetThreadHandler;\r\n function GetAfterOpenFetch: TDataSetNotifyEvent;\r\n function GetAfterThreadExecution: TJvThreadedDatasetThreadEvent;\r\n function GetBeforeThreadExecution: TJvThreadedDatasetThreadEvent;\r\n function GetDialogOptions: TJvThreadedDatasetDialogOptions;\r\n function GetEnhancedOptions: TJvUniDacThreadedDatasetEnhancedOptions;\r\n function GetThreadOptions: TJvThreadedDatasetThreadOptions;\r\n procedure SetAfterOpenFetch(const Value: TDataSetNotifyEvent);\r\n procedure SetAfterThreadExecution(const Value: TJvThreadedDatasetThreadEvent);\r\n procedure SetBeforeThreadExecution(const Value: TJvThreadedDatasetThreadEvent);\r\n procedure SetDatasetFetchAllRecords(const Value: Boolean);\r\n procedure SetDialogOptions(Value: TJvThreadedDatasetDialogOptions);\r\n procedure SetEnhancedOptions(const Value:\r\n TJvUniDacThreadedDatasetEnhancedOptions);\r\n procedure SetThreadOptions(const Value: TJvThreadedDatasetThreadOptions);\r\n property ThreadHandler: TJvBaseDatasetThreadHandler read FThreadHandler;\r\n protected\r\n procedure DoAfterOpen; override;\r\n procedure DoAfterRefresh; override;\r\n procedure DoAfterScroll; override;\r\n procedure DoBeforeOpen; override;\r\n procedure DoBeforeRefresh; override;\r\n function GetNextRecord: Boolean; override;\r\n function GetOnThreadException: TJvThreadedDatasetThreadExceptionEvent;\r\n procedure InternalLast; override;\r\n procedure InternalRefresh; override;\r\n procedure ReplaceBeforeFetch(Dataset: TCustomDADataSet; var Cancel: Boolean);\r\n procedure SetActive(Value: Boolean); override;\r\n procedure SetOnThreadException(const Value: TJvThreadedDatasetThreadExceptionEvent);\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n function CurrentFetchDuration: TDateTime;\r\n function CurrentOpenDuration: TDateTime;\r\n function EofReached: Boolean;\r\n function ErrorException: Exception;\r\n function ErrorMessage: string;\r\n function ThreadIsActive: Boolean;\r\n published\r\n property AfterOpenFetch: TDataSetNotifyEvent read GetAfterOpenFetch write SetAfterOpenFetch;\r\n property AfterThreadExecution: TJvThreadedDatasetThreadEvent read GetAfterThreadExecution write SetAfterThreadExecution;\r\n property BeforeFetch: TBeforeFetchEvent read FBeforeFetch write FBeforeFetch;\r\n property BeforeThreadExecution: TJvThreadedDatasetThreadEvent read GetBeforeThreadExecution write\r\n SetBeforeThreadExecution;\r\n property DialogOptions: TJvThreadedDatasetDialogOptions read GetDialogOptions write SetDialogOptions;\r\n property EnhancedOptions: TJvUniDacThreadedDatasetEnhancedOptions read GetEnhancedOptions write SetEnhancedOptions;\r\n property ThreadOptions: TJvThreadedDatasetThreadOptions read GetThreadOptions write SetThreadOptions;\r\n property OnThreadException: TJvThreadedDatasetThreadExceptionEvent read GetOnThreadException write SetOnThreadException;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/trunk/jvcl/run/JvUniDacQuery.pas $';\r\n Revision: '$Revision: 13371 $';\r\n Date: '$Date: 2012-06-23 17:46:57 +0200 (Sa, 23 Jun 2012) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n{$ENDIF USE_3RDPARTY_DEVART_UNIDAC}\r\n\r\nimplementation\r\n\r\n{$IFDEF USE_3RDPARTY_DEVART_UNIDAC}\r\nuses Variants, MemData;\r\n\r\nconstructor TJvUniDacDatasetThreadHandler.Create(AOwner: TComponent; ADataset:\r\n TDataSet);\r\nbegin\r\n inherited Create(AOwner, ADataset);\r\nend;\r\n\r\nprocedure TJvUniDacDatasetThreadHandler.AfterRefresh;\r\nbegin\r\n inherited AfterRefresh;\r\n if EnhancedOptions.RefreshLastPosition then\r\n RestoreRefreshKeyFields;\r\nend;\r\n\r\nprocedure TJvUniDacDatasetThreadHandler.BeforeRefresh;\r\nbegin\r\n if EnhancedOptions.RefreshLastPosition then\r\n SaveRefreshKeyFields;\r\n inherited BeforeRefresh;\r\nend;\r\n\r\n//=== { TJvUniDacDatasetThreadHandler } ========================================\r\n\r\nfunction TJvUniDacDatasetThreadHandler.CreateEnhancedOptions: TJvBaseThreadedDatasetEnhancedOptions;\r\nbegin\r\n Result := TJvUniDacThreadedDatasetEnhancedOptions.Create;\r\nend;\r\n\r\nprocedure TJvUniDacDatasetThreadHandler.RestoreRefreshKeyFields;\r\nbegin\r\n if Not (Dataset.Active and (Dataset is TCustomUniDataSet) and\r\n (TCustomUniDataSet(Dataset).KeyFields <> '') and (RefreshKeyFields <> '')) then\r\n Exit;\r\n TCustomUniDataSet(Dataset).LocateEx(RefreshKeyFields, RefreshKeyValues, [lxNearest])\r\nend;\r\n\r\nprocedure TJvUniDacDatasetThreadHandler.SaveRefreshKeyFields;\r\nvar KeyFields : String;\r\n Fields:TStringList;\r\n Key : string;\r\n p: Integer;\r\n Field: TField;\r\n i: Integer;\r\nbegin\r\n RefreshKeyFields := '';\r\n if Not (Dataset.Active and (Dataset is TCustomUniDataSet) and (TCustomUniDataSet(Dataset).KeyFields <> '')) then\r\n Exit;\r\n Fields := tStringList.create;\r\n try\r\n KeyFields := trim(TCustomUniDataSet(Dataset).KeyFields);\r\n while KeyFields <> '' do\r\n begin\r\n p := Pos(';', KeyFields);\r\n if p > 0 then\r\n begin\r\n key := trim(Copy (KeyFields, 1, p-1));\r\n KeyFields := trim(Copy(KeyFields, p+1, Length(KeyFields)-p));\r\n end\r\n else\r\n begin\r\n key := KeyFields;\r\n KeyFields := '';\r\n end;\r\n if (Key <> '') and Assigned(Dataset.FindField(Key)) then\r\n Fields.Add(Key);\r\n end;\r\n FRefreshKeyValues := VarArrayCreate([0,Fields.Count-1], varVariant );\r\n for i := 0 to Fields.Count - 1 do\r\n begin\r\n Field := Dataset.FindField(Fields[i]);\r\n if Assigned (Field) then\r\n begin\r\n RefreshKeyFields := RefreshKeyFields+Key+';';\r\n FRefreshKeyValues[i] := Field.AsVariant;\r\n end;\r\n end;\r\n finally\r\n Fields.Free;\r\n end;\r\nend;\r\n\r\n//=== { TJvUniDacThreadedDatasetAllowedContinueRecordFetchOptions } ============\r\n\r\nconstructor TJvUniDacThreadedDatasetAllowedContinueRecordFetchOptions.Create;\r\nbegin\r\n inherited Create;\r\n All := True;\r\nend;\r\n\r\nfunction\r\n TJvUniDacThreadedDatasetEnhancedOptions.CreateAllowedContinueRecordFetchOptions:\r\n TJvBaseThreadedDatasetAllowedContinueRecordFetchOptions;\r\nbegin\r\n Result := TJvUniDacThreadedDatasetAllowedContinueRecordFetchOptions.Create;\r\nend;\r\n\r\nfunction\r\n TJvUniDacThreadedDatasetEnhancedOptions.GetAllowedContinueRecordFetchOptions:\r\n TJvUniDacThreadedDatasetAllowedContinueRecordFetchOptions;\r\nbegin\r\n Result := TJvUniDacThreadedDatasetAllowedContinueRecordFetchOptions(inherited AllowedContinueRecordFetchOptions);\r\nend;\r\n\r\nprocedure\r\n TJvUniDacThreadedDatasetEnhancedOptions.SetAllowedContinueRecordFetchOptions(\r\n const Value: TJvUniDacThreadedDatasetAllowedContinueRecordFetchOptions);\r\nbegin\r\n inherited AllowedContinueRecordFetchOptions := Value;\r\nend;\r\n\r\n//=== { TJvUniDacSmartQuery } ==================================================\r\n\r\nconstructor TJvUniDacUniQuery.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FThreadHandler := TJvUniDacDatasetThreadHandler.Create(Self, Self);\r\n inherited BeforeFetch := ReplaceBeforeFetch;\r\nend;\r\n\r\ndestructor TJvUniDacUniQuery.Destroy;\r\nbegin\r\n FreeAndNil(FThreadHandler);\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvUniDacUniQuery.BreakExecution;\r\nbegin\r\n BreakExec;\r\nend;\r\n\r\nprocedure TJvUniDacUniQuery.BringThreadDialogToFront;\r\nbegin\r\n if Assigned(ThreadHandler) then\r\n ThreadHandler.BringDialogToFront;\r\nend;\r\n\r\nfunction TJvUniDacUniQuery.CurrentFetchDuration: TDateTime;\r\nbegin\r\n if Assigned(ThreadHandler) then\r\n Result := ThreadHandler.CurrentFetchDuration\r\n else\r\n Result := 0;\r\nend;\r\n\r\nfunction TJvUniDacUniQuery.CurrentOpenDuration: TDateTime;\r\nbegin\r\n if Assigned(ThreadHandler) then\r\n Result := ThreadHandler.CurrentOpenDuration\r\n else\r\n Result := 0;\r\nend;\r\n\r\nprocedure TJvUniDacUniQuery.DoAfterOpen;\r\nbegin\r\n ThreadHandler.AfterOpen;\r\nend;\r\n\r\nprocedure TJvUniDacUniQuery.DoAfterRefresh;\r\nbegin\r\n ThreadHandler.AfterRefresh;\r\nend;\r\n\r\nprocedure TJvUniDacUniQuery.DoAfterScroll;\r\nbegin\r\n ThreadHandler.AfterScroll;\r\nend;\r\n\r\nprocedure TJvUniDacUniQuery.DoBeforeOpen;\r\nbegin\r\n ThreadHandler.BeforeOpen;\r\nend;\r\n\r\nprocedure TJvUniDacUniQuery.DoBeforeRefresh;\r\nbegin\r\n ThreadHandler.BeforeRefresh;\r\nend;\r\n\r\nfunction TJvUniDacUniQuery.DoGetInheritedNextRecord: Boolean;\r\nbegin\r\n Result := Inherited GetNextRecord;\r\nend;\r\n\r\nprocedure TJvUniDacUniQuery.DoInheritedAfterOpen;\r\nbegin\r\n inherited DoAfterOpen;\r\nend;\r\n\r\nprocedure TJvUniDacUniQuery.DoInheritedAfterRefresh;\r\nbegin\r\n inherited DoAfterRefresh;\r\nend;\r\n\r\nprocedure TJvUniDacUniQuery.DoInheritedAfterScroll;\r\nbegin\r\n inherited DoAfterScroll;\r\nend;\r\n\r\nprocedure TJvUniDacUniQuery.DoInheritedBeforeOpen;\r\nbegin\r\n inherited DoBeforeOpen;\r\nend;\r\n\r\nprocedure TJvUniDacUniQuery.DoInheritedBeforeRefresh;\r\nbegin\r\n inherited DoBeforeRefresh;\r\nend;\r\n\r\nprocedure TJvUniDacUniQuery.DoInheritedInternalLast;\r\nbegin\r\n inherited InternalLast;\r\nend;\r\n\r\nprocedure TJvUniDacUniQuery.DoInheritedInternalRefresh;\r\nbegin\r\n inherited InternalRefresh;\r\nend;\r\n\r\nprocedure TJvUniDacUniQuery.DoInheritedSetActive(Active: Boolean);\r\nbegin\r\n inherited SetActive(Active);\r\nend;\r\n\r\nprocedure TJvUniDacUniQuery.DoInternalOpen;\r\nbegin\r\n InternalOpen;\r\nend;\r\n\r\nfunction TJvUniDacUniQuery.EofReached: Boolean;\r\nbegin\r\n if Assigned(ThreadHandler) then\r\n Result := ThreadHandler.EofReached\r\n else\r\n Result := False;\r\nend;\r\n\r\nfunction TJvUniDacUniQuery.ErrorException: Exception;\r\nbegin\r\n if Assigned(ThreadHandler) then\r\n Result := ThreadHandler.ErrorException\r\n else\r\n Result := Nil;\r\nend;\r\n\r\nfunction TJvUniDacUniQuery.ErrorMessage: string;\r\nbegin\r\n if Assigned(ThreadHandler) then\r\n Result := ThreadHandler.ErrorMessage\r\n else\r\n Result := '';\r\nend;\r\n\r\nfunction TJvUniDacUniQuery.GetAfterOpenFetch: TDataSetNotifyEvent;\r\nbegin\r\n if Assigned(ThreadHandler) then\r\n Result := ThreadHandler.AfterOpenFetch\r\n else\r\n Result := nil;\r\nend;\r\n\r\nfunction TJvUniDacUniQuery.GetAfterOpenFetch1: TDataSetNotifyEvent;\r\nbegin\r\n if Assigned(ThreadHandler) then\r\n Result := ThreadHandler.AfterOpenFetch\r\n else\r\n Result := nil;\r\nend;\r\n\r\nfunction TJvUniDacUniQuery.GetAfterThreadExecution:\r\n TJvThreadedDatasetThreadEvent;\r\nbegin\r\n if Assigned(ThreadHandler) then\r\n Result := ThreadHandler.AfterThreadExecution\r\n else\r\n Result := nil;\r\nend;\r\n\r\nfunction TJvUniDacUniQuery.GetBeforeThreadExecution:\r\n TJvThreadedDatasetThreadEvent;\r\nbegin\r\n if Assigned(ThreadHandler) then\r\n Result := ThreadHandler.BeforeThreadExecution\r\n else\r\n Result := nil;\r\nend;\r\n\r\nfunction TJvUniDacUniQuery.GetDatasetFetchAllRecords: Boolean;\r\nbegin\r\n Result := FetchAll;\r\nend;\r\n\r\nfunction TJvUniDacUniQuery.GetDialogOptions: TJvThreadedDatasetDialogOptions;\r\nbegin\r\n if Assigned(ThreadHandler) then\r\n Result := ThreadHandler.DialogOptions\r\n else\r\n Result := nil;\r\nend;\r\n\r\nfunction TJvUniDacUniQuery.GetEnhancedOptions:\r\n TJvUniDacThreadedDatasetEnhancedOptions;\r\nbegin\r\n if Assigned(ThreadHandler) then\r\n Result := TJvUniDacThreadedDatasetEnhancedOptions(ThreadHandler.EnhancedOptions)\r\n else\r\n Result := nil;\r\nend;\r\n\r\nfunction TJvUniDacUniQuery.GetNextRecord: Boolean;\r\nbegin\r\n if Assigned(ThreadHandler) then\r\n Result := ThreadHandler.GetNextRecord\r\n else\r\n Result := inherited GetNextRecord;\r\nend;\r\n\r\nfunction TJvUniDacUniQuery.GetOnThreadException:\r\n TJvThreadedDatasetThreadExceptionEvent;\r\nbegin\r\n if Assigned(ThreadHandler) then\r\n Result := ThreadHandler.OnThreadException\r\n else\r\n Result := nil;\r\nend;\r\n\r\nfunction TJvUniDacUniQuery.GetThreadOptions: TJvThreadedDatasetThreadOptions;\r\nbegin\r\n if Assigned(ThreadHandler) then\r\n Result := ThreadHandler.ThreadOptions\r\n else\r\n Result := nil;\r\nend;\r\n\r\nprocedure TJvUniDacUniQuery.InternalLast;\r\nbegin\r\n if Assigned(ThreadHandler) then\r\n ThreadHandler.InternalLast;\r\nend;\r\n\r\nprocedure TJvUniDacUniQuery.InternalRefresh;\r\nbegin\r\n if Assigned(ThreadHandler) then\r\n ThreadHandler.InternalRefresh;\r\nend;\r\n\r\nfunction TJvUniDacUniQuery.IsThreadAllowed: Boolean;\r\nvar ThreadedDatasetInterface : IJvThreadedDatasetInterface;\r\nbegin\r\n if Assigned(MasterSource) and Assigned(MasterSource.Dataset)\r\n and Supports(MasterSource.DataSet, IJvThreadedDatasetInterface, ThreadedDatasetInterface) then\r\n Result := not ThreadedDatasetInterface.ThreadIsActive\r\n else\r\n Result := True;\r\nend;\r\n\r\nprocedure TJvUniDacUniQuery.ReplaceBeforeFetch(Dataset: TCustomDADataSet; var\r\n Cancel: Boolean);\r\nbegin\r\n if Assigned(ThreadHandler) then\r\n Cancel := ThreadHandler.CheckContinueRecordFetch <> tdccrContinue;\r\n if Assigned(BeforeFetch) and not Cancel then\r\n BeforeFetch(Dataset, Cancel);\r\nend;\r\n\r\nprocedure TJvUniDacUniQuery.SetActive(Value: Boolean);\r\nbegin\r\n if Assigned(ThreadHandler) then\r\n ThreadHandler.SetActive(Value);\r\nend;\r\n\r\nprocedure TJvUniDacUniQuery.SetAfterOpenFetch(const Value: TDataSetNotifyEvent);\r\nbegin\r\n if Assigned(ThreadHandler) then\r\n ThreadHandler.AfterOpenFetch := Value;\r\nend;\r\n\r\nprocedure TJvUniDacUniQuery.SetAfterOpenFetch1(const Value: TDataSetNotifyEvent);\r\nbegin\r\n if Assigned(ThreadHandler) then\r\n ThreadHandler.AfterOpenFetch := Value;\r\nend;\r\n\r\nprocedure TJvUniDacUniQuery.SetAfterThreadExecution(const Value:\r\n TJvThreadedDatasetThreadEvent);\r\nbegin\r\n if Assigned(ThreadHandler) then\r\n ThreadHandler.AfterThreadExecution := Value;\r\nend;\r\n\r\nprocedure TJvUniDacUniQuery.SetBeforeThreadExecution(const Value:\r\n TJvThreadedDatasetThreadEvent);\r\nbegin\r\n if Assigned(ThreadHandler) then\r\n ThreadHandler.BeforeThreadExecution := Value;\r\nend;\r\n\r\nprocedure TJvUniDacUniQuery.SetDatasetFetchAllRecords(const Value: Boolean);\r\nbegin\r\n FetchAll := Value;\r\nend;\r\n\r\nprocedure TJvUniDacUniQuery.SetDialogOptions(Value:\r\n TJvThreadedDatasetDialogOptions);\r\nbegin\r\n if Assigned(ThreadHandler) then\r\n ThreadHandler.DialogOptions.Assign(Value);\r\nend;\r\n\r\nprocedure TJvUniDacUniQuery.SetEnhancedOptions(const Value:\r\n TJvUniDacThreadedDatasetEnhancedOptions);\r\nbegin\r\n if Assigned(ThreadHandler) then\r\n ThreadHandler.EnhancedOptions.Assign(Value);\r\nend;\r\n\r\nprocedure TJvUniDacUniQuery.SetOnThreadException(const Value:\r\n TJvThreadedDatasetThreadExceptionEvent);\r\nbegin\r\n if Assigned(ThreadHandler) then\r\n ThreadHandler.OnThreadException := Value;\r\nend;\r\n\r\nprocedure TJvUniDacUniQuery.SetThreadOptions(const Value:\r\n TJvThreadedDatasetThreadOptions);\r\nbegin\r\n if Assigned(ThreadHandler) then\r\n ThreadHandler.ThreadOptions.Assign(Value);\r\nend;\r\n\r\nfunction TJvUniDacUniQuery.ThreadIsActive: Boolean;\r\nbegin\r\n if Assigned(ThreadHandler) then\r\n Result := ThreadHandler.ThreadIsActive\r\n else\r\n Result := False;\r\nend;\r\n\r\n//=== { TJvUniDacSmartQuery } ==================================================\r\n\r\nconstructor TJvUniDacUniTable.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FThreadHandler := TJvUniDacDatasetThreadHandler.Create(Self, Self);\r\n inherited BeforeFetch := ReplaceBeforeFetch;\r\nend;\r\n\r\ndestructor TJvUniDacUniTable.Destroy;\r\nbegin\r\n FreeAndNil(FThreadHandler);\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvUniDacUniTable.BreakExecution;\r\nbegin\r\n BreakExec;\r\nend;\r\n\r\nprocedure TJvUniDacUniTable.BringThreadDialogToFront;\r\nbegin\r\n if Assigned(ThreadHandler) then\r\n ThreadHandler.BringDialogToFront;\r\nend;\r\n\r\nfunction TJvUniDacUniTable.CurrentFetchDuration: TDateTime;\r\nbegin\r\n if Assigned(ThreadHandler) then\r\n Result := ThreadHandler.CurrentFetchDuration\r\n else\r\n Result := 0;\r\nend;\r\n\r\nfunction TJvUniDacUniTable.CurrentOpenDuration: TDateTime;\r\nbegin\r\n if Assigned(ThreadHandler) then\r\n Result := ThreadHandler.CurrentOpenDuration\r\n else\r\n Result := 0;\r\nend;\r\n\r\nprocedure TJvUniDacUniTable.DoAfterOpen;\r\nbegin\r\n ThreadHandler.AfterOpen;\r\nend;\r\n\r\nprocedure TJvUniDacUniTable.DoAfterRefresh;\r\nbegin\r\n ThreadHandler.AfterRefresh;\r\nend;\r\n\r\nprocedure TJvUniDacUniTable.DoAfterScroll;\r\nbegin\r\n ThreadHandler.AfterScroll;\r\nend;\r\n\r\nprocedure TJvUniDacUniTable.DoBeforeOpen;\r\nbegin\r\n ThreadHandler.BeforeOpen;\r\nend;\r\n\r\nprocedure TJvUniDacUniTable.DoBeforeRefresh;\r\nbegin\r\n ThreadHandler.BeforeRefresh;\r\nend;\r\n\r\nfunction TJvUniDacUniTable.DoGetInheritedNextRecord: Boolean;\r\nbegin\r\n Result := Inherited GetNextRecord;\r\nend;\r\n\r\nprocedure TJvUniDacUniTable.DoInheritedAfterOpen;\r\nbegin\r\n inherited DoAfterOpen;\r\nend;\r\n\r\nprocedure TJvUniDacUniTable.DoInheritedAfterRefresh;\r\nbegin\r\n inherited DoAfterRefresh;\r\nend;\r\n\r\nprocedure TJvUniDacUniTable.DoInheritedAfterScroll;\r\nbegin\r\n inherited DoAfterScroll;\r\nend;\r\n\r\nprocedure TJvUniDacUniTable.DoInheritedBeforeOpen;\r\nbegin\r\n inherited DoBeforeOpen;\r\nend;\r\n\r\nprocedure TJvUniDacUniTable.DoInheritedBeforeRefresh;\r\nbegin\r\n inherited DoBeforeRefresh;\r\nend;\r\n\r\nprocedure TJvUniDacUniTable.DoInheritedInternalLast;\r\nbegin\r\n inherited InternalLast;\r\nend;\r\n\r\nprocedure TJvUniDacUniTable.DoInheritedInternalRefresh;\r\nbegin\r\n inherited InternalRefresh;\r\nend;\r\n\r\nprocedure TJvUniDacUniTable.DoInheritedSetActive(Active: Boolean);\r\nbegin\r\n inherited SetActive(Active);\r\nend;\r\n\r\nprocedure TJvUniDacUniTable.DoInternalOpen;\r\nbegin\r\n InternalOpen;\r\nend;\r\n\r\nfunction TJvUniDacUniTable.EofReached: Boolean;\r\nbegin\r\n if Assigned(ThreadHandler) then\r\n Result := ThreadHandler.EofReached\r\n else\r\n Result := False;\r\nend;\r\n\r\nfunction TJvUniDacUniTable.ErrorException: Exception;\r\nbegin\r\n if Assigned(ThreadHandler) then\r\n Result := ThreadHandler.ErrorException\r\n else\r\n Result := Nil;\r\nend;\r\n\r\nfunction TJvUniDacUniTable.ErrorMessage: string;\r\nbegin\r\n if Assigned(ThreadHandler) then\r\n Result := ThreadHandler.ErrorMessage\r\n else\r\n Result := '';\r\nend;\r\n\r\nfunction TJvUniDacUniTable.GetAfterOpenFetch: TDataSetNotifyEvent;\r\nbegin\r\n if Assigned(ThreadHandler) then\r\n Result := ThreadHandler.AfterOpenFetch\r\n else\r\n Result := nil;\r\nend;\r\n\r\nfunction TJvUniDacUniTable.GetAfterThreadExecution: TJvThreadedDatasetThreadEvent;\r\nbegin\r\n if Assigned(ThreadHandler) then\r\n Result := ThreadHandler.AfterThreadExecution\r\n else\r\n Result := nil;\r\nend;\r\n\r\nfunction TJvUniDacUniTable.GetBeforeThreadExecution: TJvThreadedDatasetThreadEvent;\r\nbegin\r\n if Assigned(ThreadHandler) then\r\n Result := ThreadHandler.BeforeThreadExecution\r\n else\r\n Result := nil;\r\nend;\r\n\r\nfunction TJvUniDacUniTable.GetDatasetFetchAllRecords: Boolean;\r\nbegin\r\n Result := FetchAll;\r\nend;\r\n\r\nfunction TJvUniDacUniTable.GetDialogOptions: TJvThreadedDatasetDialogOptions;\r\nbegin\r\n if Assigned(ThreadHandler) then\r\n Result := ThreadHandler.DialogOptions\r\n else\r\n Result := nil;\r\nend;\r\n\r\nfunction TJvUniDacUniTable.GetEnhancedOptions:\r\n TJvUniDacThreadedDatasetEnhancedOptions;\r\nbegin\r\n if Assigned(ThreadHandler) then\r\n Result := TJvUniDacThreadedDatasetEnhancedOptions(ThreadHandler.EnhancedOptions)\r\n else\r\n Result := nil;\r\nend;\r\n\r\nfunction TJvUniDacUniTable.GetNextRecord: Boolean;\r\nbegin\r\n if Assigned(ThreadHandler) then\r\n Result := ThreadHandler.GetNextRecord\r\n else\r\n Result := inherited GetNextRecord;\r\nend;\r\n\r\nfunction TJvUniDacUniTable.GetOnThreadException: TJvThreadedDatasetThreadExceptionEvent;\r\nbegin\r\n if Assigned(ThreadHandler) then\r\n Result := ThreadHandler.OnThreadException\r\n else\r\n Result := nil;\r\nend;\r\n\r\nfunction TJvUniDacUniTable.GetThreadOptions: TJvThreadedDatasetThreadOptions;\r\nbegin\r\n if Assigned(ThreadHandler) then\r\n Result := ThreadHandler.ThreadOptions\r\n else\r\n Result := nil;\r\nend;\r\n\r\nprocedure TJvUniDacUniTable.InternalLast;\r\nbegin\r\n if Assigned(ThreadHandler) then\r\n ThreadHandler.InternalLast;\r\nend;\r\n\r\nprocedure TJvUniDacUniTable.InternalRefresh;\r\nbegin\r\n if Assigned(ThreadHandler) then\r\n ThreadHandler.InternalRefresh;\r\nend;\r\n\r\nfunction TJvUniDacUniTable.IsThreadAllowed: Boolean;\r\nvar ThreadedDatasetInterface : IJvThreadedDatasetInterface;\r\nbegin\r\n if Assigned(MasterSource) and Assigned(MasterSource.Dataset)\r\n and Supports(MasterSource.DataSet, IJvThreadedDatasetInterface, ThreadedDatasetInterface) then\r\n Result := not ThreadedDatasetInterface.ThreadIsActive\r\n else\r\n Result := True;\r\nend;\r\n\r\nprocedure TJvUniDacUniTable.ReplaceBeforeFetch(Dataset: TCustomDADataSet; var\r\n Cancel: Boolean);\r\nbegin\r\n if Assigned(ThreadHandler) then\r\n Cancel := ThreadHandler.CheckContinueRecordFetch <> tdccrContinue;\r\n if Assigned(BeforeFetch) and not Cancel then\r\n BeforeFetch(Dataset, Cancel);\r\nend;\r\n\r\nprocedure TJvUniDacUniTable.SetActive(Value: Boolean);\r\nbegin\r\n if Assigned(ThreadHandler) then\r\n ThreadHandler.SetActive(Value);\r\nend;\r\n\r\nprocedure TJvUniDacUniTable.SetAfterOpenFetch(const Value: TDataSetNotifyEvent);\r\nbegin\r\n if Assigned(ThreadHandler) then\r\n ThreadHandler.AfterOpenFetch := Value;\r\nend;\r\n\r\nprocedure TJvUniDacUniTable.SetAfterThreadExecution(const Value: TJvThreadedDatasetThreadEvent);\r\nbegin\r\n if Assigned(ThreadHandler) then\r\n ThreadHandler.AfterThreadExecution := Value;\r\nend;\r\n\r\nprocedure TJvUniDacUniTable.SetBeforeThreadExecution(const Value: TJvThreadedDatasetThreadEvent);\r\nbegin\r\n if Assigned(ThreadHandler) then\r\n ThreadHandler.BeforeThreadExecution := Value;\r\nend;\r\n\r\nprocedure TJvUniDacUniTable.SetDatasetFetchAllRecords(const Value: Boolean);\r\nbegin\r\n FetchAll := Value;\r\nend;\r\n\r\nprocedure TJvUniDacUniTable.SetDialogOptions(Value:\r\n TJvThreadedDatasetDialogOptions);\r\nbegin\r\n if Assigned(ThreadHandler) then\r\n ThreadHandler.DialogOptions.Assign(Value);\r\nend;\r\n\r\nprocedure TJvUniDacUniTable.SetEnhancedOptions(const Value:\r\n TJvUniDacThreadedDatasetEnhancedOptions);\r\nbegin\r\n if Assigned(ThreadHandler) then\r\n ThreadHandler.EnhancedOptions.Assign(Value);\r\nend;\r\n\r\nprocedure TJvUniDacUniTable.SetOnThreadException(const Value: TJvThreadedDatasetThreadExceptionEvent);\r\nbegin\r\n if Assigned(ThreadHandler) then\r\n ThreadHandler.OnThreadException := Value;\r\nend;\r\n\r\nprocedure TJvUniDacUniTable.SetThreadOptions(const Value:\r\n TJvThreadedDatasetThreadOptions);\r\nbegin\r\n if Assigned(ThreadHandler) then\r\n ThreadHandler.ThreadOptions.Assign(Value);\r\nend;\r\n\r\nfunction TJvUniDacUniTable.ThreadIsActive: Boolean;\r\nbegin\r\n if Assigned(ThreadHandler) then\r\n Result := ThreadHandler.ThreadIsActive\r\n else\r\n Result := False;\r\nend;\r\n\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n{$ENDIF USE_3RDPARTY_DEVART_UNIDAC}\r\nend.\r\n\r\n" }, { "path": "External/Jedi/Jvcl/run/JvUnicodeCanvas.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvUnicodeCanvas.PAS, released on 2003-09-21\r\n\r\nThe Initial Developers of the Original Code are: Andreas Hausladen \r\nCopyright (c) 2003 Andreas Hausladen\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvUnicodeCanvas.pas 12461 2009-08-14 17:21:33Z obones $\r\n\r\nunit JvUnicodeCanvas;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n SysUtils, Classes, Windows, Graphics,\r\n JvJCLUtils;\r\n\r\ntype\r\n TJvExtTextOutOptionsKind = (etoClipped, etoOpaque);\r\n TJvExtTextOutOptions = set of TJvExtTextOutOptionsKind;\r\n\r\n { This Canvas has no new fields and can be type-casted form every TCanvas\r\n derived class. }\r\n TJvUnicodeCanvas = class(TCanvas)\r\n public\r\n function TextExtentW(const Text: WideString): TSize;\r\n function TextWidthW(const Text: WideString): Integer;\r\n function TextHeightW(const Text: WideString): Integer;\r\n procedure TextOutW(X, Y: Integer; const Text: WideString);\r\n procedure TextRectW(Rect: TRect; X, Y: Integer; const Text: WideString);\r\n function ExtTextOutW(X, Y: Integer; Options: TJvExtTextOutOptions;\r\n Rect: PRect; const Text: WideString; lpDx: Pointer): Boolean;\r\n\r\n function ExtTextOut(X, Y: Integer; Options: TJvExtTextOutOptions;\r\n Rect: PRect; const Text: string; lpDx: Pointer): Boolean;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvUnicodeCanvas.pas $';\r\n Revision: '$Revision: 12461 $';\r\n Date: '$Date: 2009-08-14 19:21:33 +0200 (ven. 14 août 2009) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\n\r\nfunction ExtTextOutOptionsToInt(Options: TJvExtTextOutOptions): Integer;\r\nbegin\r\n Result := 0;\r\n if etoClipped in Options then\r\n Result := Result or ETO_CLIPPED;\r\n if etoOpaque in Options then\r\n Result := Result or ETO_OPAQUE;\r\nend;\r\n\r\nfunction TJvUnicodeCanvas.TextExtentW(const Text: WideString): TSize;\r\nbegin\r\n Result.cx := 0;\r\n Result.cy := 0;\r\n Windows.GetTextExtentPoint32W(Handle, PWideChar(Text), Length(Text), Result);\r\nend;\r\n\r\nprocedure TJvUnicodeCanvas.TextOutW(X, Y: Integer; const Text: WideString);\r\nvar\r\n W: Integer;\r\nbegin\r\n Changing;\r\n W := TextWidthW(Text);\r\n if CanvasOrientation = coRightToLeft then\r\n Inc(X, W + 1);\r\n Windows.ExtTextOutW(Handle, X, Y, TextFlags, nil, PWideChar(Text), Length(Text), nil);\r\n MoveTo(X + W, Y);\r\n Changed;\r\nend;\r\n\r\nprocedure TJvUnicodeCanvas.TextRectW(Rect: TRect; X, Y: Integer; const Text: WideString);\r\nvar\r\n Options: Longint;\r\nbegin\r\n Changing;\r\n Options := ETO_CLIPPED or TextFlags;\r\n if Brush.Style <> bsClear then\r\n Options := Options or ETO_OPAQUE;\r\n if ((TextFlags and ETO_RTLREADING) <> 0) and (CanvasOrientation = coRightToLeft) then\r\n Inc(X, TextWidthW(Text) + 1);\r\n Windows.ExtTextOutW(Handle, X, Y, Options, @Rect, PWideChar(Text), Length(Text), nil);\r\n Changed;\r\nend;\r\n\r\nfunction TJvUnicodeCanvas.TextWidthW(const Text: WideString): Integer;\r\nbegin\r\n Result := TextExtentW(Text).cx;\r\nend;\r\n\r\nfunction TJvUnicodeCanvas.TextHeightW(const Text: WideString): Integer;\r\nbegin\r\n Result := TextExtentW(Text).cy;\r\nend;\r\n\r\nfunction TJvUnicodeCanvas.ExtTextOut(X, Y: Integer; Options: TJvExtTextOutOptions;\r\n Rect: PRect; const Text: string; lpDx: Pointer): Boolean;\r\nbegin\r\n Result := Windows.ExtTextOut(Handle, X, Y, ExtTextOutOptionsToInt(Options),\r\n Rect, PChar(Text), Length(Text), lpDx);\r\nend;\r\n\r\nfunction TJvUnicodeCanvas.ExtTextOutW(X, Y: Integer; Options: TJvExtTextOutOptions;\r\n Rect: PRect; const Text: WideString; lpDx: Pointer): Boolean;\r\nbegin\r\n Result := Windows.ExtTextOutW(Handle, X, Y, ExtTextOutOptionsToInt(Options),\r\n Rect, PWideChar(Text), Length(Text), lpDx);\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend." }, { "path": "External/Jedi/Jvcl/run/JvUnicodeEditor.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvUnicodeEditor.PAS, released on 2004-01-25.\r\n\r\nThe Initial Developers of the Original Code are: Andrei Prygounkov \r\nCopyright (c) 1999, 2002 Andrei Prygounkov\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\nBurov Dmitry, translation of russian text.\r\nAndreas Hausladen\r\nPeter Thrnqvist\r\nRemko Bonte\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\ncomponent : TJvEditor\r\ndescription : 'Delphi IDE'-like Editor (unicode)\r\n\r\nKnown Issues:\r\n Some russian comments were translated to english; these comments are marked\r\n with [translated]\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvUnicodeEditor.pas 13407 2012-08-28 19:29:35Z ahuser $\r\n\r\nunit JvUnicodeEditor;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, Messages, Classes, Controls,\r\n JclWideStrings,\r\n JvEditorCommon;\r\n\r\ntype\r\n TJvCustomWideEditor = class;\r\n\r\n TJvEditorWideStrings = class(TWStringList)\r\n private\r\n FJvEditor: TJvCustomWideEditor;\r\n procedure StringsChanged(Sender: TObject);\r\n procedure SetInternal(Index: Integer; const Value: WideString);\r\n procedure ReLine;\r\n procedure SetLockText(const Text: WideString);\r\n protected\r\n procedure Put(Index: Integer; const S: {$IFDEF SUPPORTS_UNICODE}string{$ELSE}WideString{$ENDIF SUPPORTS_UNICODE}); override;\r\n procedure InternalPut(Index: Integer; const Value: WideString);\r\n\r\n property Internal[Index: Integer]: WideString write SetInternal;\r\n property JvEditor: TJvCustomWideEditor read FJvEditor;\r\n public\r\n constructor Create;\r\n destructor Destroy; override;\r\n procedure Assign(Source: TPersistent); override;\r\n procedure AddStrings(Strings: TWStrings); override;\r\n procedure SetTextStr(const Value: {$IFDEF SUPPORTS_UNICODE}string{$ELSE}WideString{$ENDIF SUPPORTS_UNICODE}); override;\r\n function Add(const S: {$IFDEF SUPPORTS_UNICODE}string{$ELSE}WideString{$ENDIF SUPPORTS_UNICODE}): Integer; override;\r\n procedure Insert(Index: Integer; const S: {$IFDEF SUPPORTS_UNICODE}string{$ELSE}WideString{$ENDIF SUPPORTS_UNICODE}); override;\r\n procedure Delete(Index: Integer); override;\r\n procedure DeleteText(BegX, BegY, EndX, EndY: Integer);\r\n procedure InsertText(X, Y: Integer; const Text: WideString);\r\n procedure DeleteColumnText(BegX, BegY, EndX, EndY: Integer);\r\n procedure InsertColumnText(X, Y: Integer; const Text: WideString);\r\n end;\r\n\r\n TJvWideCompletion = class;\r\n TOnCompletionApplyW = procedure(Sender: TObject; const OldString: WideString;\r\n var NewString: WideString) of object;\r\n TJvGetLineAttrEventW = procedure(Sender: TObject; var Line: WideString; Index: Integer;\r\n var Attrs: TLineAttrs) of object;\r\n\r\n TJvCustomWideEditor = class(TJvCustomEditorBase)\r\n private\r\n {$IFNDEF SUPPORTS_UNICODE}\r\n FCodePage: Cardinal;\r\n {$ENDIF ~SUPPORTS_UNICODE}\r\n { internal objects }\r\n FLines: TJvEditorWideStrings;\r\n\r\n { events }\r\n FOnGetLineAttr: TJvGetLineAttrEventW;\r\n FOnCompletionApply: TOnCompletionApplyW;\r\n\r\n {$IFNDEF SUPPORTS_UNICODE}\r\n procedure WMInputLangChange(var Msg: TMessage); message WM_INPUTLANGCHANGE;\r\n {$ENDIF ~SUPPORTS_UNICODE}\r\n\r\n { get/set for properties }\r\n function GetLines: TWStrings;\r\n procedure SetLines(ALines: TWStrings);\r\n function GetCompletion: TJvWideCompletion;\r\n procedure SetCompletion(const Value: TJvWideCompletion);\r\n protected\r\n function GetLineCount: Integer; override;\r\n function GetLineLength(Index: Integer): Integer; override;\r\n function FindNotBlankCharPosInLine(Line: Integer): Integer; override;\r\n\r\n function GetTextLine(Y: Integer; out Text: string): Boolean; override;\r\n function InternGetWordOnCaret: string; override;\r\n\r\n procedure ReLine; override;\r\n function GetTabStop(X, Y: Integer; Next: Boolean): Integer; override;\r\n function GetBackStop(X, Y: Integer): Integer; override;\r\n procedure TextAllChangedInternal(Unselect: Boolean); override;\r\n protected\r\n procedure PaintLineText(Line: Integer; ColBeg, ColEnd: Integer;\r\n var ColPainted: Integer); override;\r\n procedure InsertChar(const Value: Word); override;\r\n protected\r\n procedure SetLockText(const Text: WideString);\r\n function ExpandTabs(const S: WideString): WideString;\r\n function GetAutoIndentStop(Y: Integer): Integer; override;\r\n\r\n { triggers for descendants }\r\n procedure GetLineAttr(var Str: WideString; Line, ColBeg, ColEnd: Integer); virtual;\r\n function DoCommand(ACommand: TEditCommand; var X, Y: Integer;\r\n var CaretUndo: Boolean): Boolean; override;\r\n { TextModified is called when the editor content has changed. }\r\n procedure TextModified(ACaretX, ACaretY: Integer; Action: TModifiedAction;\r\n const Text: WideString); dynamic;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n\r\n procedure ClipboardCopy; override;\r\n procedure ClipboardPaste; override;\r\n procedure DeleteSelected; override;\r\n procedure Clear;\r\n\r\n function GetSelText: WideString;\r\n procedure SetSelText(const AValue: WideString);\r\n function GetWordOnCaret: WideString;\r\n procedure SelectWordOnCaret; override;\r\n function GetText: string; override;\r\n\r\n procedure InsertText(const Text: WideString);\r\n procedure InsertColumnText(X, Y: Integer; const Text: WideString);\r\n procedure ReplaceWord(const NewString: WideString);\r\n procedure ReplaceWord2(const NewString: WideString);\r\n procedure IndentColumns(X: Integer; BegY, EndY: Integer); override;\r\n procedure UnIndentColumns(X: Integer; BegY, EndY: Integer); override;\r\n\r\n property SelText: WideString read GetSelText write SetSelText;\r\n public\r\n { published in descendants }\r\n property Lines: TWStrings read GetLines write SetLines;\r\n property Completion: TJvWideCompletion read GetCompletion write SetCompletion;\r\n property OnGetLineAttr: TJvGetLineAttrEventW read FOnGetLineAttr write FOnGetLineAttr;\r\n property OnCompletionApply: TOnCompletionApplyW read FOnCompletionApply write FOnCompletionApply;\r\n end;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvWideEditor = class(TJvCustomWideEditor)\r\n published\r\n property BeepOnError;\r\n property BorderStyle;\r\n property Lines;\r\n property ScrollBars;\r\n property GutterWidth;\r\n property GutterColor;\r\n property RightMarginVisible;\r\n property RightMargin;\r\n property RightMarginColor;\r\n property InsertMode;\r\n property ReadOnly;\r\n property DoubleClickLine;\r\n property HideCaret;\r\n property Completion;\r\n property TabStops;\r\n property SmartTab;\r\n property BackSpaceUnindents;\r\n property AutoIndent;\r\n property KeepTrailingBlanks;\r\n property CursorBeyondEOF;\r\n property CursorBeyondEOL;\r\n property BracketHighlighting;\r\n property SelForeColor;\r\n property SelBackColor;\r\n property SelBlockFormat;\r\n\r\n property OnGetLineAttr;\r\n property OnChangeStatus;\r\n property OnScroll;\r\n property OnResize;\r\n property OnKeyDown;\r\n property OnKeyPress;\r\n property OnKeyUp;\r\n property OnChange;\r\n property OnCaretChanged;\r\n property OnSelectionChange;\r\n property OnMouseDown;\r\n property OnMouseMove;\r\n property OnMouseUp;\r\n property OnDblClick;\r\n property OnPaintGutter;\r\n property OnCompletionIdentifier;\r\n property OnCompletionTemplate;\r\n property OnCompletionDrawItem;\r\n property OnCompletionMeasureItem;\r\n property OnCompletionApply;\r\n\r\n { TCustomControl }\r\n property Align;\r\n property Enabled;\r\n property Color;\r\n property Font;\r\n property ParentColor;\r\n property ParentFont;\r\n property ParentShowHint;\r\n property PopupMenu;\r\n property ShowHint;\r\n property TabStop;\r\n property Visible;\r\n property Anchors;\r\n property AutoSize;\r\n property BiDiMode;\r\n property Constraints;\r\n property UseDockManager;\r\n property DockSite;\r\n property DragKind;\r\n property ParentBiDiMode;\r\n property OnCanResize;\r\n property OnConstrainedResize;\r\n property OnDockDrop;\r\n property OnDockOver;\r\n property OnEndDock;\r\n property OnGetSiteInfo;\r\n property OnStartDock;\r\n property OnUnDock;\r\n property OnEnter;\r\n property OnExit;\r\n end;\r\n\r\n TJvWideCompletion = class(TJvCompletionBase)\r\n private\r\n FIdentifiers: TWStrings;\r\n FTemplates: TWStrings;\r\n FCaretChar: WideChar;\r\n FCRLF: WideString;\r\n FSeparator: WideString;\r\n function GetStrings(Index: Integer): TWStrings;\r\n procedure SetStrings(Index: Integer; AValue: TWStrings);\r\n procedure ReplaceWord(const NewString: WideString);\r\n protected\r\n procedure FindSelItem(var Eq: Boolean); override;\r\n procedure MakeItems; override;\r\n procedure ReplaceWordItemIndex(SubStrStart: Integer); override;\r\n function GetTemplateCount: Integer; override;\r\n function GetIdentifierCount: Integer; override;\r\n function GetSeparator: string; override;\r\n public\r\n constructor Create(AJvEditor: TJvCustomWideEditor);\r\n destructor Destroy; override;\r\n published\r\n property Identifiers: TWStrings index 0 read GetStrings write SetStrings;\r\n property Templates: TWStrings index 1 read GetStrings write SetStrings;\r\n property CaretChar: WideChar read FCaretChar write FCaretChar default '|';\r\n property CRLF: WideString read FCRLF write FCRLF;\r\n property Separator: WideString read FSeparator write FSeparator;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvUnicodeEditor.pas $';\r\n Revision: '$Revision: 13407 $';\r\n Date: '$Date: 2012-08-28 21:29:35 +0200 (mar. 28 août 2012) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n SysUtils, Math, Graphics, Clipbrd,\r\n JvUnicodeCanvas, JvJCLUtils, JvConsts, JvResources;\r\n\r\ntype\r\n TJvInsertUndo = class(TJvCaretUndo)\r\n private\r\n FText: WideString;\r\n function GetEditor: TJvCustomWideEditor;\r\n public\r\n constructor Create(AJvEditor: TJvCustomWideEditor; ACaretX, ACaretY: Integer;\r\n const AText: WideString);\r\n procedure Undo; override;\r\n end;\r\n\r\n TJvOverwriteUndo = class(TJvCaretUndo)\r\n private\r\n FOldText: WideString;\r\n FNewText: WideString;\r\n function GetEditor: TJvCustomWideEditor;\r\n public\r\n constructor Create(AJvEditor: TJvCustomWideEditor; ACaretX, ACaretY: Integer;\r\n const AOldText, ANewText: WideString);\r\n procedure Undo; override;\r\n end;\r\n\r\n TJvReLineUndo = class(TJvInsertUndo, IJvUndoCompound);\r\n\r\n TJvInsertTabUndo = class(TJvInsertUndo);\r\n\r\n TJvInsertColumnUndo = class(TJvInsertUndo)\r\n public\r\n procedure Undo; override;\r\n end;\r\n\r\n TJvDeleteUndo = class(TJvInsertUndo)\r\n public\r\n procedure Undo; override;\r\n end;\r\n\r\n TJvDeleteLineUndo = class(TJvInsertUndo)\r\n private\r\n FLastLineDelete: Boolean;\r\n public\r\n constructor Create(AJvEditor: TJvCustomWideEditor; ACaretX, ACaretY: Integer;\r\n const AText: WideString; ALastLineDelete: Boolean);\r\n procedure Undo; override;\r\n //procedure Redo; override;\r\n end;\r\n\r\n TJvDeleteTrailUndo = class(TJvDeleteUndo, IJvUndoCompound);\r\n\r\n TJvBackspaceUndo = class(TJvDeleteUndo, IJvBackspaceUndo)\r\n public\r\n procedure Undo; override;\r\n end;\r\n\r\n TJvBackspaceUnindentUndo = class(TJvDeleteUndo, IJvBackspaceUnindentUndo)\r\n public\r\n procedure Undo; override;\r\n end;\r\n\r\n TJvReplaceUndo = class(TJvCaretUndo)\r\n private\r\n FBegX: Integer;\r\n FBegY: Integer;\r\n FText: WideString;\r\n FNewText: WideString;\r\n function GetEditor: TJvCustomWideEditor;\r\n public\r\n constructor Create(AJvEditor: TJvCustomWideEditor; ACaretX, ACaretY: Integer;\r\n ABegX, ABegY: Integer; const AText, ANewText: WideString);\r\n procedure Undo; override;\r\n end;\r\n\r\n TJvDeleteSelectedUndo = class(TJvDeleteUndo)\r\n public\r\n constructor Create(AJvEditor: TJvCustomWideEditor; ACaretX, ACaretY: Integer;\r\n const AText: WideString);\r\n procedure Undo; override;\r\n end;\r\n\r\n(* // (ahuser) make Delphi 5 compiler happy\r\n TJvIndentColumnUndo = class(TJvInsertColumnUndo)\r\n private\r\n FNewCaretX: Integer;\r\n FNewCaretY: Integer;\r\n public\r\n constructor Create(AJvEditor: TJvCustomWideEditor; ACaretX, ACaretY: Integer;\r\n ABegX, ABegY: Integer; const AText: WideString);\r\n procedure Undo; override;\r\n end;\r\n*)\r\n\r\n TJvUnindentColumnUndo = class(TJvInsertUndo)\r\n private\r\n FBegX: Integer;\r\n FBegY: Integer;\r\n public\r\n constructor Create(AJvEditor: TJvCustomWideEditor; ACaretX, ACaretY,\r\n ABegX, ABegY: Integer; const AText: WideString);\r\n procedure Undo; override;\r\n end;\r\n\r\n TJvUndoBufferAccessProtected = class(TJvUndoBuffer);\r\n\r\n//=== { TJvEditorWideStrings } ===============================================\r\n\r\nconstructor TJvEditorWideStrings.Create;\r\nbegin\r\n inherited Create;\r\n OnChange := StringsChanged;\r\nend;\r\n\r\ndestructor TJvEditorWideStrings.Destroy;\r\nbegin\r\n OnChange := nil;\r\n OnChanging := nil;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvEditorWideStrings.Assign(Source: TPersistent);\r\nbegin\r\n JvEditor.BeginUpdate;\r\n try\r\n inherited Assign(Source);\r\n JvEditor.NotUndoable;\r\n JvEditor.TextAllChanged;\r\n finally\r\n JvEditor.EndUpdate;\r\n end;\r\nend;\r\n\r\nprocedure TJvEditorWideStrings.AddStrings(Strings: TWStrings);\r\nbegin\r\n JvEditor.BeginUpdate;\r\n try\r\n inherited AddStrings(Strings);\r\n JvEditor.NotUndoable;\r\n finally\r\n JvEditor.EndUpdate;\r\n end;\r\nend;\r\n\r\nprocedure TJvEditorWideStrings.SetTextStr(const Value: {$IFDEF SUPPORTS_UNICODE}string{$ELSE}WideString{$ENDIF SUPPORTS_UNICODE});\r\nbegin\r\n inherited SetTextStr(JvEditor.ExpandTabs(Value));\r\n if JvEditor.UpdateLock = 0 then\r\n JvEditor.NotUndoable;\r\n JvEditor.TextAllChanged;\r\nend;\r\n\r\nprocedure TJvEditorWideStrings.StringsChanged(Sender: TObject);\r\nbegin\r\n if JvEditor.UpdateLock = 0 then\r\n JvEditor.TextAllChanged;\r\nend;\r\n\r\nprocedure TJvEditorWideStrings.SetLockText(const Text: WideString);\r\nbegin\r\n JvEditor.LockUpdate;\r\n try\r\n inherited SetTextStr(Text)\r\n finally\r\n JvEditor.UnlockUpdate;\r\n end;\r\nend;\r\n\r\nprocedure TJvEditorWideStrings.SetInternal(Index: Integer; const Value: WideString);\r\nbegin\r\n JvEditor.LockUpdate;\r\n try\r\n InternalPut(Index, Value);\r\n finally\r\n JvEditor.UnlockUpdate;\r\n end;\r\nend;\r\n\r\nfunction TJvEditorWideStrings.Add(const S: {$IFDEF SUPPORTS_UNICODE}string{$ELSE}WideString{$ENDIF SUPPORTS_UNICODE}): Integer;\r\nbegin\r\n Result := inherited Add(JvEditor.ExpandTabs(S));\r\nend;\r\n\r\nprocedure TJvEditorWideStrings.Insert(Index: Integer; const S: {$IFDEF SUPPORTS_UNICODE}string{$ELSE}WideString{$ENDIF SUPPORTS_UNICODE});\r\nbegin\r\n inherited Insert(Index, JvEditor.ExpandTabs(S));\r\n JvEditor.LineInserted(Index);\r\nend;\r\n\r\nprocedure TJvEditorWideStrings.Delete(Index: Integer);\r\nbegin\r\n inherited Delete(Index);\r\n JvEditor.LineDeleted(Index);\r\nend;\r\n\r\nprocedure TJvEditorWideStrings.Put(Index: Integer; const S: {$IFDEF SUPPORTS_UNICODE}string{$ELSE}WideString{$ENDIF SUPPORTS_UNICODE});\r\nvar\r\n L: Integer;\r\nbegin\r\n if JvEditor.KeepTrailingBlanks then\r\n inherited Put(Index, S)\r\n else\r\n begin\r\n L := Length(S) - TrimRightLengthW(S);\r\n if L = 0 then\r\n inherited Put(Index, S)\r\n else\r\n begin\r\n {--- UNDO ---}\r\n TJvDeleteTrailUndo.Create(JvEditor, Length(S), Index, SpacesW(L));\r\n {--- /UNDO ---}\r\n inherited Put(Index, TrimRightW(S));\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvEditorWideStrings.ReLine;\r\nvar\r\n L: Integer;\r\n S: WideString;\r\nbegin\r\n JvEditor.LockUpdate;\r\n try\r\n if Count = 0 then\r\n L := JvEditor.CaretX\r\n else\r\n L := Length(Strings[Count - 1]);\r\n while JvEditor.CaretY > Count - 1 do\r\n begin\r\n {--- UNDO ---}\r\n TJvReLineUndo.Create(JvEditor, L, JvEditor.CaretY, sLineBreakStr);\r\n {--- /UNDO ---}\r\n L := 0;\r\n Add('');\r\n end;\r\n S := Strings[JvEditor.CaretY];\r\n if JvEditor.CaretX > Length(S) then\r\n begin\r\n L := JvEditor.CaretX - Length(S);\r\n {--- UNDO ---}\r\n{ TJvReLineUndo.Create(JvEditor, Length(S),\r\n JvEditor.CaretY, SpacesW(L)); } {disabled: moves the caret to wrong undo position }\r\n {--- /UNDO ---}\r\n inherited Put(JvEditor.CaretY, S + SpacesW(L));\r\n end;\r\n finally\r\n JvEditor.UnlockUpdate;\r\n end;\r\nend;\r\n\r\nprocedure TJvEditorWideStrings.InternalPut(Index: Integer; const Value: WideString);\r\nbegin\r\n if JvEditor.KeepTrailingBlanks then\r\n inherited Put(Index, JvEditor.ExpandTabs(Value))\r\n else\r\n inherited Put(Index, TrimRightW(JvEditor.ExpandTabs(Value)));\r\nend;\r\n\r\nprocedure TJvEditorWideStrings.DeleteText(BegX, BegY, EndX, EndY: Integer);\r\n{ delete text from [BegX..EndY] [BegY..EndY] all inclusive.\r\n BegX,EndX: [0..Max_X] }\r\nvar\r\n BegLine, EndLine: WideString;\r\n I, L: Integer;\r\nbegin\r\n if BegY < 0 then\r\n begin\r\n BegY := 0;\r\n BegX := 0;\r\n end;\r\n if BegY >= Count then\r\n Exit; // nothing to delete\r\n if EndY >= Count then\r\n begin\r\n EndY := Count - 1;\r\n EndX := MaxInt - 1;\r\n end;\r\n if BegX < 0 then\r\n BegX := 0;\r\n\r\n JvEditor.LockUpdate;\r\n BeginUpdate;\r\n try\r\n BegLine := Strings[BegY];\r\n // expand BegLine if necessary\r\n L := (BegX + 1) - Length(BegLine) - 1;\r\n if L > 0 then\r\n BegLine := BegLine + SpacesW(L);\r\n\r\n EndLine := Strings[EndY];\r\n\r\n // delete lines between and end line\r\n for I := EndY downto BegY + 1 do\r\n Delete(I);\r\n\r\n System.Delete(BegLine, BegX + 1, MaxInt);\r\n System.Delete(EndLine, 1, EndX + 1);\r\n\r\n Internal[BegY] := BegLine + EndLine;\r\n finally\r\n EndUpdate;\r\n JvEditor.UnlockUpdate;\r\n end;\r\nend;\r\n\r\nprocedure TJvEditorWideStrings.InsertText(X, Y: Integer; const Text: WideString);\r\n{ insert text on X:[0..Max_X], Y }\r\nvar\r\n BegLine, EndLine: WideString;\r\n YStart: Integer;\r\n F, P: PWideChar;\r\n S, FirstLine: WideString;\r\n Len: Integer;\r\nbegin\r\n Inc(X); // increment for WideString functions\r\n if Y < 0 then\r\n Y := 0;\r\n while Y >= Count do\r\n Add('');\r\n\r\n BegLine := Strings[Y];\r\n EndLine := System.Copy(BegLine, X, MaxInt);\r\n System.Delete(BegLine, X, MaxInt);\r\n\r\n // line is too small -> expand it with spaces\r\n Len := Length(BegLine);\r\n if Len < X then\r\n begin\r\n SetLength(BegLine, X - 1);\r\n P := PWideChar(BegLine) + Len;\r\n Len := X - Len - 1;\r\n while Len > 0 do\r\n begin\r\n P^ := ' ';\r\n Inc(P);\r\n Dec(Len);\r\n end;\r\n end;\r\n\r\n JvEditor.LockUpdate;\r\n BeginUpdate;\r\n try\r\n P := PWideChar(Text);\r\n F := P;\r\n while (P[0] <> #0) and (P[0] <> Lf) and (P[0] <> Cr) do\r\n Inc(P);\r\n\r\n SetString(S, F, P - F);\r\n\r\n YStart := Y;\r\n FirstLine := BegLine + S; // set Internal[YStart] later so we keep the trailing spaces for concat EndLine\r\n\r\n while P[0] <> #0 do\r\n begin\r\n if P[0] = Cr then\r\n Inc(P);\r\n if P[0] = Lf then\r\n Inc(P);\r\n F := P;\r\n\r\n while (P[0] <> #0) and (P[0] <> Lf) and (P[0] <> Cr) do\r\n Inc(P);\r\n SetString(S, F, P - F);\r\n Inc(Y);\r\n Insert(Y, S);\r\n end;\r\n\r\n if Y = YStart then\r\n Internal[YStart] := FirstLine + EndLine\r\n else\r\n begin\r\n Internal[YStart] := FirstLine;\r\n Internal[Y] := Strings[Y] + EndLine;\r\n end;\r\n finally\r\n EndUpdate;\r\n JvEditor.UnlockUpdate;\r\n end;\r\nend;\r\n\r\nprocedure TJvEditorWideStrings.DeleteColumnText(BegX, BegY, EndX, EndY: Integer);\r\n{ delete column text from [BegX..EndY] [BegY..EndY] all inclusive.\r\n BegX,EndX: [0..Max_X] }\r\nvar\r\n S: WideString;\r\n I: Integer;\r\nbegin\r\n if BegY < 0 then\r\n begin\r\n BegY := 0;\r\n BegX := 0;\r\n end;\r\n if BegY >= Count then\r\n Exit; // nothing to delete\r\n if EndY >= Count then\r\n begin\r\n EndY := Count - 1;\r\n EndX := MaxInt - 1;\r\n end;\r\n if BegX < 0 then\r\n BegX := 0;\r\n\r\n JvEditor.LockUpdate;\r\n BeginUpdate;\r\n try\r\n for I := BegY to EndY do\r\n begin\r\n S := JvEditor.FLines[I];\r\n System.Delete(S, BegX + 1, EndX - BegX + 1);\r\n JvEditor.FLines.Internal[I] := S;\r\n end;\r\n finally\r\n EndUpdate;\r\n JvEditor.UnlockUpdate;\r\n end;\r\nend;\r\n\r\nprocedure TJvEditorWideStrings.InsertColumnText(X, Y: Integer; const Text: WideString);\r\n{ insert column text on X:[0..Max_X], Y }\r\nvar\r\n S, Line: WideString;\r\n P, F: PWideChar;\r\n L: Integer;\r\nbegin\r\n Inc(X); // increment for WideString functions\r\n if Y < 0 then\r\n Y := 0;\r\n\r\n JvEditor.LockUpdate;\r\n BeginUpdate;\r\n try\r\n P := PWideChar(Text);\r\n F := P;\r\n while P[0] <> #0 do\r\n begin\r\n while (P[0] <> #0) and (P[0] <> Lf) and (P[0] <> Cr) do\r\n Inc(P);\r\n SetString(S, F, P - F);\r\n\r\n while Y >= Count do\r\n Add('');\r\n Line := Strings[Y];\r\n L := (X - 1) - Length(Line);\r\n if L > 0 then\r\n Line := Line + SpacesW(L);\r\n System.Insert(S, Line, X);\r\n Internal[Y] := Line;\r\n\r\n if P[0] = Cr then\r\n Inc(P);\r\n if P[0] = Lf then\r\n Inc(P);\r\n F := P;\r\n Inc(Y);\r\n end;\r\n finally\r\n EndUpdate;\r\n JvEditor.UnlockUpdate;\r\n end;\r\nend;\r\n\r\n//=== { TJvCustomWideEditor } ================================================\r\n\r\nconstructor TJvCustomWideEditor.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FLines := TJvEditorWideStrings.Create;\r\n FLines.FJvEditor := Self;\r\n FLines.OnChange := DoLinesChange;\r\n Completion := TJvWideCompletion.Create(Self);\r\n {$IFNDEF SUPPORTS_UNICODE}\r\n FCodePage := CP_ACP;\r\n {$ENDIF ~SUPPORTS_UNICODE}\r\nend;\r\n\r\ndestructor TJvCustomWideEditor.Destroy;\r\nbegin\r\n FLines.Free;\r\n Completion.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvCustomWideEditor.PaintLineText(Line: Integer; ColBeg, ColEnd: Integer;\r\n var ColPainted: Integer);\r\nvar\r\n Ch: WideString;\r\n iC, jC, SL, MX: Integer;\r\n R: TRect;\r\n S: WideString;\r\n LA: TLineAttr;\r\n jCStart, Len: Integer;\r\n MyDi: TDynIntArray;\r\nbegin\r\n with EditorClient do\r\n begin\r\n S := FLines[Line];\r\n\r\n Len := Max(Length(S), Max_X) + 1;\r\n if Len > Length(LineAttrs) then\r\n SetLength(LineAttrs, Len)\r\n else\r\n if Len + 128 < Length(LineAttrs) then\r\n SetLength(LineAttrs, Len);\r\n\r\n GetLineAttr(S, Line, ColBeg, ColEnd);\r\n\r\n {left line}\r\n if Canvas.Brush.Color <> LineAttrs[LeftCol + 1].BC then // change GDI object only if necessary\r\n Canvas.Brush.Color := LineAttrs[LeftCol + 1].BC;\r\n\r\n Canvas.FillRect(Bounds(EditorClient.Left, (Line - TopRow) *\r\n CellRect.Height, 1, CellRect.Height));\r\n {optimized, paint group of chars with identical attributes}\r\n SL := Length(S);\r\n MX := ColEnd;\r\n\r\n if Length(FMyDi) < MX then\r\n begin\r\n SetLength(MyDi, MX);\r\n for iC := 0 to High(MyDi) do\r\n MyDi[iC] := CellRect.Width;\r\n end\r\n else\r\n MyDi := FMyDi;\r\n\r\n while ColPainted < MX do\r\n begin\r\n with Canvas do\r\n begin\r\n iC := ColPainted + 1;\r\n LA := LineAttrs[iC];\r\n jC := iC + 1;\r\n if iC <= SL then\r\n Ch := S[iC]\r\n else\r\n Ch := ' ';\r\n jCStart := jC;\r\n while (jC <= MX + 1) and\r\n CompareMem(@LA, @LineAttrs[jC], SizeOf(LineAttrs[1])) do\r\n Inc(jC);\r\n Ch := Copy(S, jCStart - 1, jC - jCStart + 1);\r\n if jC > SL + 1 then\r\n Ch := Ch + Spaces(jC - SL - 1);\r\n\r\n if Brush.Color <> LA.BC then // change GDI object only if necessary\r\n Brush.Color := LA.BC;\r\n Font.Assign(FontCacheFind(LA));\r\n\r\n R := CalcCellRect(ColPainted - LeftCol, Line - TopRow);\r\n {bottom line}\r\n FillRect(Bounds(R.Left, R.Bottom - 1, CellRect.Width * Length(Ch), 1));\r\n\r\n TJvUnicodeCanvas(Canvas).ExtTextOutW(R.Left, R.Top, [etoOpaque, etoClipped], nil, Ch, @FMyDi[0]);\r\n ErrorHighlighting.PaintError(Canvas, ColPainted + 1, Line, R, Length(Ch), MyDi);\r\n\r\n if LA.Border <> clNone then\r\n begin\r\n Pen.Color := LA.Border;\r\n R.Right := R.Left + CellRect.Width * Length(Ch);\r\n Dec(R.Left);\r\n Brush.Style := bsClear;\r\n Rectangle(R);\r\n Brush.Style := bsSolid;\r\n end;\r\n\r\n ColPainted := jC - 1;\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomWideEditor.GetLineAttr(var Str: WideString; Line, ColBeg, ColEnd: Integer);\r\nvar\r\n I: Integer;\r\nbegin\r\n if ColBeg < 0 then\r\n ColBeg := 0;\r\n if ColEnd > Max_X then\r\n ColEnd := Max_X;\r\n\r\n SetLength(LineAttrs, Max(Length(LineAttrs), Max_X + 1));\r\n\r\n LineAttrs[ColBeg].Style := Font.Style;\r\n LineAttrs[ColBeg].FC := Font.Color;\r\n LineAttrs[ColBeg].BC := Color;\r\n LineAttrs[ColBeg].Border := clNone;\r\n\r\n{ for I := ColBeg + 1 to ColEnd do\r\n Move(LineAttrs[ColBeg], LineAttrs[I], SizeOf(LineAttrs[1]));}\r\n for I := ColBeg + 1 to ColEnd do\r\n LineAttrs[I] := LineAttrs[ColBeg];\r\n\r\n GetAttr(Line, ColBeg, ColEnd);\r\n if Assigned(FOnGetLineAttr) then\r\n FOnGetLineAttr(Self, Str, Line, LineAttrs);\r\n ChangeAttr(Line, ColBeg, ColEnd);\r\nend;\r\n\r\nfunction TJvCustomWideEditor.GetTextLine(Y: Integer; out Text: string): Boolean;\r\nbegin\r\n if (Y >= 0) and (Y < Lines.Count) then\r\n begin\r\n Text := Lines[Y];\r\n Result := True;\r\n end\r\n else\r\n begin\r\n Text := '';\r\n Result := False;\r\n end;\r\nend;\r\n\r\nfunction TJvCustomWideEditor.InternGetWordOnCaret: string;\r\nbegin\r\n Result := GetWordOnCaret;\r\nend;\r\n\r\nprocedure TJvCustomWideEditor.ReLine;\r\nbegin\r\n FLines.ReLine;\r\nend;\r\n\r\n{$IFNDEF SUPPORTS_UNICODE}\r\nprocedure TJvCustomWideEditor.WMInputLangChange(var Msg: TMessage);\r\nvar\r\n Buffer: array[0..6] of Char;\r\nbegin\r\n inherited;\r\n GetLocaleInfo(Msg.LParamLo, LOCALE_IDEFAULTANSICODEPAGE, Buffer, Length(Buffer));\r\n FCodePage := StrToIntDef(Buffer, CP_ACP);\r\nend;\r\n{$ENDIF ~SUPPORTS_UNICODE}\r\n\r\nprocedure TJvCustomWideEditor.InsertChar(const Value: Word);\r\nvar\r\n S: WideString;\r\n X, Y, iBeg: Integer;\r\n WasSelected: Boolean;\r\n Key: WideChar;\r\nbegin\r\n {$IFDEF SUPPORTS_UNICODE}\r\n Key := WideChar(Value);\r\n {$ELSE}\r\n MultiByteToWideChar(FCodePage, 0, @Value, 1, @Key, 1);\r\n {$ENDIF SUPPORTS_UNICODE}\r\n\r\n WasSelected := (FSelection.IsSelected) and (not PersistentBlocks);\r\n if Value >= 32 then\r\n //if Key in [#32..#255] then\r\n begin\r\n if (Value < 256) and not HasChar(Char(Key), JvEditorCompletionChars) then\r\n Completion.DoKeyPress(Char(Key));\r\n\r\n RemoveSelectedBlock;\r\n\r\n ReLine; // need ReLine after DeleteSelection\r\n S := FLines[CaretY];\r\n if InsertMode then\r\n begin\r\n {--- UNDO ---}\r\n TJvInsertUndo.Create(Self, CaretX, CaretY, Key);\r\n {--- /UNDO ---}\r\n Insert(Key, S, CaretX + 1);\r\n\r\n AdjustPersistentBlockSelection(CaretX, CaretY, amInsert, [1]);\r\n end\r\n else\r\n begin\r\n {--- UNDO ---}\r\n if CaretX + 1 <= Length(S) then\r\n TJvOverwriteUndo.Create(Self, CaretX, CaretY, S[CaretX + 1], Key)\r\n else\r\n TJvOverwriteUndo.Create(Self, CaretX, CaretY, '', Key);\r\n {--- /UNDO ---}\r\n if CaretX + 1 <= Length(S) then\r\n S[CaretX + 1] := WideChar(Key)\r\n else\r\n S := S + Key\r\n end;\r\n FLines.Internal[CaretY] := S;\r\n SetCaretInternal(CaretX + 1, CaretY);\r\n TextModified(CaretX, CaretY, maInsert, Key);\r\n PaintLine(CaretY, -1, -1);\r\n Changed;\r\n\r\n if (Value < 256) and HasChar(Char(Key), JvEditorCompletionChars) then\r\n Completion.DoKeyPress(Char(Key));\r\n end\r\n else\r\n case Key of\r\n Cr:\r\n begin\r\n if InsertMode then\r\n begin\r\n if WasSelected then // compound only on selection deletion\r\n BeginCompound;\r\n LockUpdate;\r\n try\r\n RemoveSelectedBlock; // adjusts CaretX, CaretY\r\n X := CaretX;\r\n Y := CaretY;\r\n { --- UNDO --- }\r\n TJvInsertUndo.Create(Self, CaretX, CaretY, sLineBreakStr);\r\n { --- /UNDO --- }\r\n if FLines.Count = 0 then\r\n FLines.Add('');\r\n ReLine;\r\n\r\n S := Copy(FLines[Y], X + 1, MaxInt);\r\n FLines.Insert(Y + 1, S);\r\n FLines.Internal[Y] := Copy(FLines[Y], 1, X);\r\n Inc(Y);\r\n { auto indent }\r\n if AutoIndent and\r\n (((Length(FLines[CaretY]) > 0) and\r\n (FLines[CaretY][1] = ' ')) or\r\n ((TrimW(FLines[CaretY]) = '') and (X > 0))) then\r\n begin\r\n X := GetAutoIndentStop(Y);\r\n if X > 0 then\r\n begin\r\n { --- UNDO --- }\r\n TJvInsertUndo.Create(Self, 0, Y, SpacesW(X));\r\n { --- /UNDO --- }\r\n FLines.Internal[Y] := SpacesW(X) + FLines[Y];\r\n end;\r\n end\r\n else\r\n X := 0;\r\n\r\n // persistent blocks: adjust selection\r\n AdjustPersistentBlockSelection(CaretX, CaretY, amLineBreak, []);\r\n\r\n UpdateEditorSize;\r\n TextModified(CaretX - 1, CaretY, maInsert, sLineBreakStr);\r\n finally\r\n UnlockUpdate;\r\n if WasSelected then\r\n EndCompound;\r\n end;\r\n Invalidate;\r\n Changed;\r\n end\r\n else // Overwrite-mode\r\n begin\r\n if WasSelected then // compound only on selection deletion\r\n BeginCompound;\r\n try\r\n RemoveSelectedBlock;\r\n X := CaretX;\r\n Y := CaretY;\r\n Inc(Y);\r\n if Y >= FLines.Count then\r\n begin\r\n LockUpdate;\r\n try\r\n { --- UNDO --- }\r\n TJvInsertUndo.Create(Self, CaretX, CaretY, sLineBreakStr);\r\n { --- /UNDO --- }\r\n FLines.Add('');\r\n finally\r\n UnlockUpdate;\r\n end;\r\n TextModified(0, Y - 1, maInsert, sLineBreakStr);\r\n UpdateEditorSize;\r\n Invalidate;\r\n Changed;\r\n end;\r\n if Y < FLines.Count then\r\n begin\r\n S := FLines[Y];\r\n if Length(S) > 0 then\r\n begin\r\n iBeg := FindNotBlankCharPos(S) - 1;\r\n if iBeg < X then\r\n X := iBeg;\r\n end;\r\n end;\r\n finally\r\n if WasSelected then\r\n EndCompound;\r\n end;\r\n end;\r\n SetCaretInternal(X, Y);\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomWideEditor.SelectWordOnCaret;\r\nvar\r\n iBeg, iEnd: Integer;\r\nbegin\r\n if (CaretY >= 0) and (CaretY < LineCount) and (TrimW(FLines[CaretY]) <> '') then\r\n begin\r\n iEnd := Length(TrimRightW(FLines[CaretY]));\r\n if FCaretX < iEnd then\r\n while FLines[FCaretY][FCaretX + 1] <= ' ' do\r\n Inc(FCaretX)\r\n else\r\n begin\r\n FCaretX := iEnd - 1;\r\n while FLines[FCaretY][FCaretX + 1] <= ' ' do\r\n Dec(FCaretX);\r\n end;\r\n if GetWordOnPosEx(FLines[FCaretY] + ' ', FCaretX + 1, iBeg, iEnd) <> '' then\r\n begin\r\n PaintCaret(False);\r\n SetSel(iBeg - 1, FCaretY);\r\n SetSel(iEnd - 1, FCaretY);\r\n SetCaret(iEnd - 1, FCaretY);\r\n PaintCaret(True);\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJvCustomWideEditor.DoCommand(ACommand: TEditCommand; var X, Y: Integer;\r\n var CaretUndo: Boolean): Boolean;\r\n\r\ntype\r\n TPr = procedure of object;\r\n\r\n procedure DoAndCorrectXY(Pr: TPr);\r\n begin\r\n Pr;\r\n X := CaretX;\r\n Y := CaretY;\r\n CaretUndo := False;\r\n end;\r\n\r\n procedure SetSel1(X, Y: Integer);\r\n begin\r\n SetSel(X, Y);\r\n CaretUndo := False;\r\n end;\r\n\r\n procedure SetSelText1(const S: WideString);\r\n begin\r\n SelText := S;\r\n CaretUndo := False;\r\n end;\r\n\r\nvar\r\n F: Integer;\r\n S, S2: WideString;\r\n B: Boolean;\r\n iBeg, iEnd: Integer;\r\nbegin\r\n Result := True;\r\n X := CaretX;\r\n Y := CaretY;\r\n case ACommand of\r\n { caret movements }\r\n ecPrevWord, ecSelPrevWord, ecBackspaceWord:\r\n begin\r\n if (ACommand = ecSelPrevWord) and IsNewSelection then\r\n SetSel1(CaretX, CaretY);\r\n if Y >= FLines.Count then\r\n Exit;\r\n\r\n S := FLines[Y];\r\n B := False;\r\n if CaretX > Length(S) then\r\n begin\r\n X := Length(S);\r\n SetSel1(X, Y);\r\n end\r\n else\r\n begin\r\n for F := X - 1 downto 0 do\r\n begin\r\n if B then\r\n begin\r\n if CharInSetW(S[F + 1], Separators) then\r\n begin\r\n X := F + 1;\r\n Break;\r\n end;\r\n end\r\n else\r\n if not CharInSetW(S[F + 1], Separators) then\r\n B := True;\r\n end;\r\n\r\n if X = CaretX then\r\n X := 0;\r\n if ACommand <> ecBackspaceWord then\r\n begin\r\n { Jump to previous line and last word ending }\r\n if (X = 0) and (Y > 0) then\r\n begin\r\n if (Y > FLines.Count) or (CaretX = 0) or (FLines[Y] = '') or\r\n CharInSetW(FLines[Y][1], Separators) then\r\n begin\r\n Y := Y - 1;\r\n X := Length(FLines[Y]);\r\n end;\r\n end;\r\n end;\r\n\r\n if ACommand = ecSelPrevWord then\r\n SetSel1(X, Y)\r\n else\r\n PersistentBlocksSetUnSelected;\r\n\r\n if (ACommand = ecBackspaceWord) and (Y >= 0) and (X <> CaretX) then\r\n begin\r\n if not ReadOnly then\r\n begin\r\n BeginCompound;\r\n try\r\n SelectRange(X, CaretY, CaretX, CaretY);\r\n DeleteSelected;\r\n finally\r\n EndCompound;\r\n end;\r\n ReLine;\r\n end;\r\n end;\r\n end;\r\n end;\r\n ecNextWord, ecSelNextWord:\r\n begin\r\n if (ACommand = ecSelNextWord) and IsNewSelection then\r\n SetSel1(CaretX, CaretY);\r\n if Y >= FLines.Count then\r\n begin\r\n Y := FLines.Count - 1;\r\n if Y < 0 then\r\n Exit;\r\n X := Length(FLines[Y]);\r\n end;\r\n S := FLines[Y];\r\n B := False;\r\n if CaretX >= Length(S) then\r\n begin\r\n if Y < FLines.Count - 1 then\r\n begin\r\n Y := CaretY + 1;\r\n X := 0;\r\n if Y < FLines.Count then\r\n while (X < Length(FLines[Y])) and (CharInSetW(FLines[Y][X + 1], Separators)) do\r\n Inc(X);\r\n if ACommand = ecSelNextWord then // this code is copied from [ecPrevWord, ecSelPrevWord]\r\n SetSel1(X, Y)\r\n else\r\n PersistentBlocksSetUnSelected;\r\n end;\r\n end\r\n else\r\n begin\r\n for F := X to Length(S) - 1 do\r\n if B then\r\n begin\r\n if not CharInSetW(S[F + 1], Separators) then\r\n begin\r\n X := F;\r\n Break;\r\n end\r\n end\r\n else\r\n if CharInSetW(S[F + 1], Separators) then\r\n B := True;\r\n if X = CaretX then\r\n X := Length(S);\r\n if ACommand = ecSelNextWord then\r\n SetSel1(X, Y)\r\n else\r\n PersistentBlocksSetUnSelected;\r\n end;\r\n end;\r\n ecSelWord:\r\n if IsNewSelection and (GetWordOnPosEx(FLines[Y] + ' ', X + 1, iBeg,\r\n iEnd) <> '') then\r\n begin\r\n SetSel1(iBeg - 1, Y);\r\n SetSel1(iEnd - 1, Y);\r\n X := iEnd - 1;\r\n end;\r\n ecBackspace:\r\n if not ReadOnly then\r\n if X > 0 then\r\n begin\r\n // in the middle of line\r\n if (not PersistentBlocks) and FSelection.IsSelected then\r\n DoAndCorrectXY(RemoveSelectedBlock)\r\n else\r\n begin\r\n ReLine;\r\n if BackSpaceUnindents then\r\n X := GetBackStop(CaretX, CaretY)\r\n else\r\n X := CaretX - 1;\r\n\r\n S := Copy(FLines[CaretY], X + 1, CaretX - X);\r\n\r\n { --- UNDO --- }\r\n if X = CaretX - 1 then\r\n TJvBackspaceUndo.Create(Self, CaretX, CaretY, S)\r\n else\r\n TJvBackspaceUnindentUndo.Create(Self, CaretX, CaretY, S);\r\n CaretUndo := False;\r\n { --- /UNDO --- }\r\n\r\n // persistent blocks: adjust selection\r\n AdjustPersistentBlockSelection(CaretX, CaretY, amDelete, [1]);\r\n\r\n FLines.DeleteText(X, Y, CaretX - 1, Y);\r\n\r\n TextModified(CaretX, CaretY, maDelete, S);\r\n PaintLine(Y, -1, -1);\r\n end;\r\n Changed;\r\n end\r\n else\r\n if Y > 0 then\r\n begin\r\n // at the start of line\r\n if FSelection.IsSelected then\r\n begin\r\n BeginCompound;\r\n try\r\n DoAndCorrectXY(RemoveSelectedBlock);\r\n ReLine;\r\n finally\r\n EndCompound;\r\n end;\r\n end\r\n else\r\n begin\r\n LockUpdate;\r\n try\r\n X := Length(FLines[Y - 1]);\r\n\r\n { --- UNDO --- }\r\n TJvBackspaceUndo.Create(Self, X + 1, CaretY - 1, Lf);\r\n CaretUndo := False;\r\n { --- /UNDO --- }\r\n\r\n // persistent blocks: adjust selection\r\n AdjustPersistentBlockSelection(CaretX, CaretY, amLineConcat, [X, CaretY - 1]);\r\n\r\n FLines.DeleteText(X, Y - 1, -1, Y);\r\n Dec(Y);\r\n finally\r\n UnlockUpdate;\r\n end;\r\n UpdateEditorSize;\r\n TextModified(X, Y, maDelete, sLineBreakStr);\r\n Invalidate;\r\n Changed;\r\n end;\r\n end\r\n else\r\n if not PersistentBlocks and FSelection.IsSelected then\r\n DoCommand(ecDelete, X, Y, CaretUndo);\r\n ecDelete:\r\n if not ReadOnly then\r\n begin\r\n LockUpdate;\r\n try\r\n if FLines.Count = 0 then\r\n FLines.Add('');\r\n finally\r\n UnlockUpdate;\r\n end;\r\n if not PersistentBlocks and FSelection.IsSelected then\r\n DoAndCorrectXY(RemoveSelectedBlock)\r\n else\r\n if X < Length(FLines[Y]) then\r\n begin\r\n //{ inside line - }\r\n { --- UNDO --- }\r\n TJvDeleteUndo.Create(Self, CaretX, CaretY, FLines[Y][X + 1]);\r\n CaretUndo := False;\r\n { --- /UNDO --- }\r\n\r\n // persistent blocks: adjust selection (before DeleteText)\r\n AdjustPersistentBlockSelection(CaretX + 1, CaretY, amDelete, [1]);\r\n\r\n S := FLines[Y][X + 1];\r\n FLines.DeleteText(X, Y, X, Y);\r\n\r\n TextModified(CaretX, CaretY, maDelete, S);\r\n PaintLine(CaretY, -1, -1);\r\n Changed;\r\n end\r\n else\r\n if (Y >= 0) and (Y <= FLines.Count - 2) then\r\n begin\r\n //{ at the end of line - }\r\n { --- UNDO --- }\r\n TJvDeleteUndo.Create(Self, CaretX, CaretY, sLineBreakStr);\r\n CaretUndo := False;\r\n { --- /UNDO --- }\r\n // persistent blocks: adjust selection (before DeleteText)\r\n AdjustPersistentBlockSelection(0, CaretY + 1, amLineConcat, [CaretX, CaretY]);\r\n\r\n FLines.DeleteText(X, Y, -1, Y + 1);\r\n\r\n UpdateEditorSize;\r\n TextModified(CaretX, CaretY, maDelete, sLineBreakStr);\r\n Invalidate;\r\n Changed;\r\n end;\r\n end;\r\n ecTab, ecBackTab:\r\n begin\r\n X := GetTabStop(CaretX, CaretY, ACommand = ecTab);\r\n if not ReadOnly then\r\n begin\r\n if FSelection.IsSelected then\r\n if (ACommand = ecTab) and InsertMode then\r\n DeleteSelected;\r\n ReLine;\r\n if (ACommand = ecTab) and InsertMode then\r\n begin\r\n S := FLines[CaretY];\r\n S2 := SpacesW(X - CaretX);\r\n { --- UNDO --- }\r\n TJvInsertTabUndo.Create(Self, CaretX, CaretY, S2);\r\n CaretUndo := False;\r\n { --- /UNDO --- }\r\n FLines.InsertText(CaretX, CaretY, S2);\r\n\r\n TextModified(CaretX, CaretY, maInsert, S2);\r\n PaintLine(CaretY, -1, -1);\r\n Changed;\r\n end;\r\n end;\r\n { else }\r\n { move cursor - oh yes!, it's already moved: X := GetTabStop(..); }\r\n end;\r\n ecDeleteLine:\r\n if not ReadOnly then\r\n begin\r\n if (CaretY >= 0) and (CaretY < FLines.Count) then\r\n begin\r\n S := FLines[CaretY];\r\n if (CaretY >= FLines.Count - 1) and (S = '') then\r\n Exit;\r\n\r\n LockUpdate;\r\n try\r\n { --- UNDO --- }\r\n TJvDeleteLineUndo.Create(Self, CaretX, CaretY, S, CaretY >= FLines.Count - 1);\r\n { --- /UNDO --- }\r\n if CaretY < FLines.Count - 1 then\r\n FLines.Delete(CaretY)\r\n else\r\n FLines[CaretY] := '';\r\n SetCaretInternal(0, CaretY); // set caret to 0/Y when in last line\r\n finally\r\n UnlockUpdate;\r\n end;\r\n AdjustPersistentBlockSelection(CaretX, CaretY, amDeleteLine, []);\r\n TextModified(0, CaretY, maDelete, S);\r\n Invalidate;\r\n Changed;\r\n end;\r\n Exit;\r\n end;\r\n ecToUpperCase:\r\n if not ReadOnly then\r\n SelText := AnsiUpperCase(SelText);\r\n ecToLowerCase:\r\n if not ReadOnly then\r\n SelText := AnsiLowerCase(SelText);\r\n ecChangeCase:\r\n if not ReadOnly then\r\n SelText := AnsiChangeCase(SelText);\r\n end;\r\n Result := False;\r\nend;\r\n\r\nfunction TJvCustomWideEditor.GetSelText: WideString;\r\nvar\r\n S: WideString;\r\n I: Integer;\r\n Len, CLen: Integer;\r\n P: PWideChar;\r\nbegin\r\n with FSelection do\r\n begin\r\n Len := GetSelLength; // memory size to allocate\r\n Result := '';\r\n if Len = 0 then\r\n Exit;\r\n SetLength(Result, Len);\r\n\r\n if SelBlockFormat = bfColumn then\r\n begin\r\n if Len > 0 then\r\n begin\r\n P := Pointer(Result);\r\n for I := SelBegY to SelEndY do\r\n begin\r\n S := FLines[I];\r\n CLen := Length(S) - SelBegX;\r\n if CLen < 0 then\r\n CLen := 0;\r\n if CLen > SelEndX - SelBegX + 1 then\r\n CLen := SelEndX - SelBegX + 1;\r\n if CLen <> 0 then\r\n begin\r\n MoveWideChar(S[SelBegX + 1], P^, CLen);\r\n Inc(P, CLen);\r\n end;\r\n\r\n if I < SelEndY then\r\n begin\r\n MoveWideChar(sLineBreakStr[1], P^, sLineBreakLen);\r\n Inc(P, sLineBreakLen);\r\n end;\r\n end;\r\n end;\r\n end\r\n else\r\n begin\r\n if SelBegY = SelEndY then\r\n MoveWideChar(FLines[SelEndY][SelBegX + 1], Result[1], Len)\r\n else\r\n begin\r\n P := PWideChar(Result);\r\n\r\n // first line\r\n S := FLines[SelBegY];\r\n CLen := Length(S) - SelBegX;\r\n if CLen > 0 then\r\n begin\r\n MoveWideChar(S[SelBegX + 1], P^, CLen);\r\n Inc(P, CLen);\r\n end;\r\n\r\n // line break\r\n MoveWideChar(sLineBreakStr[1], P^, sLineBreakLen);\r\n Inc(P, sLineBreakLen);\r\n\r\n // lines between\r\n for I := SelBegY + 1 to SelEndY - 1 do\r\n begin\r\n // line\r\n S := FLines[I];\r\n MoveWideChar(S[1], P^, Length(S));\r\n Inc(P, Length(S));\r\n\r\n // line break\r\n MoveWideChar(sLineBreakStr[1], P^, sLineBreakLen);\r\n Inc(P, sLineBreakLen);\r\n end;\r\n\r\n // last line\r\n S := FLines[SelEndY];\r\n CLen := SelEndX + Ord(SelBlockFormat = bfInclusive);\r\n if CLen > Length(S) then\r\n CLen := Length(S);\r\n if CLen > 0 then\r\n MoveWideChar(S[1], P^, CLen);\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomWideEditor.SetSelText(const AValue: WideString);\r\nbegin\r\n BeginUpdate;\r\n BeginCompound;\r\n try\r\n with FSelection do\r\n begin\r\n if IsSelected then\r\n DeleteSelected\r\n else\r\n begin\r\n SelBegX := CaretX;\r\n SelBegY := CaretY;\r\n end;\r\n if FSelection.SelBlockFormat = bfColumn then\r\n InsertColumnText(FSelection.SelBegX, FSelection.SelBegY, AValue)\r\n else\r\n InsertText(AValue);\r\n\r\n IsSelected := Length(AValue) > 0;\r\n Selecting := False;\r\n GetEndPosCaretW(AValue, SelBegX, SelBegY, SelEndX, SelEndY);\r\n if IsSelected then\r\n Inc(SelEndX);\r\n SetSelUpdateRegion(SelBegY, SelEndY);\r\n end;\r\n finally\r\n EndCompound;\r\n EndUpdate;\r\n end;\r\nend;\r\n\r\nfunction TJvCustomWideEditor.GetText: string;\r\nbegin\r\n Result := FLines.Text;\r\nend;\r\n\r\nprocedure TJvCustomWideEditor.ClipboardCopy;\r\nvar\r\n S: string;\r\nbegin\r\n S := GetSelText; // convert to ANSI\r\n Clipboard.SetTextBuf(PChar(S));\r\n SetClipboardBlockFormat(SelBlockFormat);\r\nend;\r\n\r\nprocedure TJvCustomWideEditor.InsertText(const Text: WideString);\r\nvar\r\n X, Y: Integer;\r\nbegin\r\n PaintCaret(False);\r\n try\r\n { --- UNDO --- }\r\n TJvInsertUndo.Create(Self, CaretX, CaretY, Text);\r\n { --- /UNDO --- }\r\n FLines.InsertText(CaretX, CaretY, Text);\r\n TextModified(CaretX, CaretY, maInsert, Text);\r\n\r\n GetEndPosCaretW(Text, CaretX, CaretY, X, Y); // get new caret position\r\n SetCaretInternal(X + 1, Y);\r\n\r\n Changed;\r\n finally\r\n PaintCaret(True);\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomWideEditor.InsertColumnText(X, Y: Integer; const Text: WideString);\r\nbegin\r\n if X < 0 then\r\n X := 0;\r\n if Y < 0 then\r\n Y := 0;\r\n { --- UNDO --- }\r\n TJvInsertColumnUndo.Create(Self, X, Y, Text);\r\n { --- /UNDO --- }\r\n FLines.InsertColumnText(X, Y, Text);\r\n TextModified(X, Y, maInsertColumn, Text);\r\nend;\r\n\r\n// Substitutes a word in a cursor position on NewString\r\n// WideString NewString should not contain Cr, Lf [translated]\r\n\r\nprocedure TJvCustomWideEditor.ReplaceWord(const NewString: WideString);\r\nvar\r\n iBeg, iEnd: Integer;\r\n S, W: WideString;\r\n X: Integer;\r\nbegin\r\n BeginUpdate;\r\n PaintCaret(False);\r\n try\r\n S := FLines[CaretY];\r\n while CaretX > Length(S) do\r\n S := S + ' ';\r\n W := TrimW(GetWordOnPos2W(S, CaretX, iBeg, iEnd));\r\n if W = '' then\r\n begin\r\n iBeg := CaretX + 1;\r\n iEnd := CaretX\r\n end;\r\n { --- UNDO --- }\r\n NotUndoable;\r\n //TJvReplaceUndo.Create(Self, CaretX, CaretY, iBegSX - 1, CaretY, W, NewString);\r\n { --- /UNDO --- }\r\n Delete(S, iBeg, iEnd - iBeg);\r\n Insert(NewString, S, iBeg);\r\n FLines.Internal[CaretY] := S;\r\n X := iBeg + Length(NewString) - 1;\r\n TextModified(CaretX, CaretY, maInsert, NewString);\r\n PaintLine(CaretY, -1, -1);\r\n SetCaretInternal(X, CaretY);\r\n Changed;\r\n finally\r\n PaintCaret(True);\r\n EndUpdate;\r\n end;\r\nend;\r\n\r\n{ Substitutes a word on the cursor position by NewString [translated] }\r\n\r\nprocedure TJvCustomWideEditor.ReplaceWord2(const NewString: WideString);\r\nvar\r\n S, W: WideString;\r\n iBegSX, iEndSX: Integer; { [1..Length] }\r\n X, Y: Integer;\r\nbegin\r\n S := '';\r\n if CaretY < FLines.Count then\r\n S := FLines[CaretY];\r\n\r\n W := TrimW(GetWordOnPosExW(S, CaretX + 1, iBegSX, iEndSX));\r\n if W <> NewString then\r\n begin\r\n PaintCaret(False);\r\n try\r\n BeginCompound;\r\n try\r\n ReLine;\r\n if Length(W) = 0 then\r\n begin\r\n iBegSX := CaretX + 1;\r\n iEndSX := CaretX;\r\n end;\r\n { --- UNDO --- }\r\n TJvReplaceUndo.Create(Self, CaretX, CaretY, iBegSX - 1, CaretY, W, NewString);\r\n { --- /UNDO --- }\r\n\r\n if iBegSX <= iEndSX then\r\n FLines.DeleteText(iBegSX - 1, CaretY, iEndSX - 1, CaretY);\r\n FLines.InsertText(iBegSX - 1, CaretY, NewString);\r\n TextModified(iBegSX - 1, CaretY, maReplace, NewString);\r\n\r\n GetEndPosCaretW(NewString, iBegSX - 1, CaretY, X, Y); // get end caret position\r\n SetCaretInternal(X + 1, Y);\r\n finally\r\n EndCompound;\r\n end;\r\n Changed;\r\n finally\r\n PaintCaret(True);\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomWideEditor.IndentColumns(X, BegY, EndY: Integer);\r\nvar\r\n Y: Integer;\r\n S: WideString;\r\nbegin\r\n if BegY < 0 then\r\n BegY := 0;\r\n if BegY >= FLines.Count then\r\n BegY := FLines.Count - 1;\r\n if EndY < 0 then\r\n EndY := 0;\r\n if EndY >= FLines.Count then\r\n EndY := FLines.Count - 1;\r\n if EndY < BegY then\r\n Exit;\r\n if X < 0 then\r\n X := 0;\r\n\r\n S := SpacesW(2);\r\n for Y := BegY to EndY - 1 do\r\n S := S + sLineBreakStr + SpacesW(2);\r\n\r\n InsertColumnText(X, BegY, S);\r\n\r\n Changed;\r\n if UpdateLock = 0 then\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvCustomWideEditor.UnIndentColumns(X: Integer; BegY, EndY: Integer);\r\nvar\r\n S, UnindentedText: WideString;\r\n Y: Integer;\r\n Len, L: Integer;\r\nbegin\r\n if BegY < 0 then\r\n BegY := 0;\r\n if BegY >= FLines.Count then\r\n BegY := FLines.Count - 1;\r\n if EndY < 0 then\r\n EndY := 0;\r\n if EndY >= FLines.Count then\r\n EndY := FLines.Count - 1;\r\n if EndY < BegY then\r\n Exit;\r\n if X < 0 then\r\n X := 0;\r\n\r\n Inc(X); // for WideString operations\r\n\r\n LockUpdate;\r\n try\r\n UnindentedText := '';\r\n for Y := BegY to EndY do\r\n begin\r\n S := FLines[Y];\r\n Len := Length(S);\r\n\r\n // how many spaces to delete\r\n L := 0;\r\n while (X + L <= Len) and (L < 2) and (S[X + L] = ' ') do\r\n Inc(L);\r\n\r\n if L > 0 then\r\n begin\r\n UnindentedText := UnindentedText + SpacesW(L);\r\n Delete(S, X, L);\r\n FLines.Internal[Y] := S;\r\n end;\r\n if Y < EndY then\r\n UnindentedText := UnindentedText + sLineBreakStr;\r\n end;\r\n finally\r\n UnlockUpdate;\r\n end;\r\n\r\n Dec(X); // for caret operations\r\n if Length(UnindentedText) > 0 then\r\n begin\r\n { --- UNDO --- }\r\n TJvUnindentColumnUndo.Create(Self, CaretX, CaretY, X, BegY, UnindentedText);\r\n { --- /UNDO --- }\r\n TextModified(X, BegY, maDelete, UnindentedText);\r\n\r\n Changed;\r\n if UpdateLock = 0 then\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomWideEditor.ClipboardPaste;\r\nvar\r\n ClipS: string;\r\n Len: Integer;\r\n H: THandle;\r\n X, Y, EndX, EndY: Integer;\r\nbegin\r\n if (CaretY > FLines.Count - 1) and (FLines.Count > 0) then\r\n if BeepOnError then\r\n Beep;\r\n H := Clipboard.GetAsHandle(CF_TEXT);\r\n Len := GlobalSize(H);\r\n if Len = 0 then\r\n Exit;\r\n\r\n BeginUpdate;\r\n try\r\n SetLength(ClipS, Len);\r\n SetLength(ClipS, Clipboard.GetTextBuf(PChar(ClipS), Len));\r\n ClipS := ExpandTabs(AdjustLineBreaks(ClipS));\r\n PaintCaret(False);\r\n\r\n ReLine;\r\n with FSelection do\r\n begin\r\n X := CaretX;\r\n Y := CaretY;\r\n BeginCompound;\r\n try\r\n if IsSelected then\r\n begin\r\n if BlockOverwrite and not PersistentBlocks then\r\n begin\r\n X := SelBegX;\r\n Y := SelBegY;\r\n end;\r\n RemoveSelectedBlock;\r\n end;\r\n if FLines.Count > 0 then\r\n ReLine;\r\n\r\n SelBlockFormat := GetClipboardBlockFormat;\r\n if SelBlockFormat in [bfInclusive, bfNonInclusive, bfLine] then\r\n begin\r\n // special line block mode handling\r\n if SelBlockFormat = bfLine then\r\n begin\r\n X := 0;\r\n if (ClipS = '') or (ClipS[Length(ClipS)] <> Lf) then\r\n ClipS := ClipS + sLineBreakStr;\r\n end;\r\n\r\n { --- UNDO --- }\r\n TJvInsertUndo.Create(Self, X, Y, ClipS);\r\n { --- /UNDO --- }\r\n\r\n FLines.InsertText(X, Y, ClipS);\r\n TextModified(X, Y, maInsert, ClipS);\r\n\r\n // get new caret position\r\n GetEndPosCaretW(ClipS, X, Y, EndX, EndY);\r\n Inc(EndX);\r\n\r\n if PersistentBlocks then\r\n begin\r\n SelBegX := X;\r\n SelBegY := Y;\r\n // special line block mode handling\r\n if SelBlockFormat = bfLine then\r\n begin\r\n Dec(EndY);\r\n SelEndX := Max_X;\r\n end\r\n else\r\n SelEndX := EndX;\r\n\r\n SelEndY := EndY;\r\n IsSelected := True;\r\n Selecting := False;\r\n SetSelUpdateRegion(SelBegY, SelEndY);\r\n end;\r\n X := EndX;\r\n Y := EndY;\r\n end\r\n else\r\n if SelBlockFormat = bfColumn then\r\n begin\r\n InsertColumnText(X, Y, ClipS);\r\n GetEndPosCaretW(ClipS, X, Y, X, Y);\r\n X := CaretX - 1;\r\n Inc(X);\r\n end;\r\n finally\r\n EndCompound;\r\n end;\r\n end; // with\r\n\r\n SetCaretInternal(X, Y);\r\n\r\n Changed;\r\n finally\r\n PaintCaret(True);\r\n EndUpdate; {!!! Causes copying all [translated] }\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomWideEditor.DeleteSelected;\r\nvar\r\n S: WideString;\r\n X, Y: Integer;\r\nbegin\r\n with FSelection do\r\n begin\r\n X := SelBegX;\r\n Y := SelBegY;\r\n if IsSelected then\r\n begin\r\n BeginUpdate;\r\n PaintCaret(False);\r\n try\r\n S := GetSelText;\r\n {--- UNDO ---}\r\n TJvDeleteSelectedUndo.Create(Self, CaretX, CaretY, S);\r\n {--- /UNDO ---}\r\n IsSelected := False;\r\n Selecting := False;\r\n if SelBlockFormat in [bfInclusive, bfNonInclusive, bfLine] then\r\n begin\r\n FLines.DeleteText(X, Y, SelEndX - 1 + Ord(SelBlockFormat = bfInclusive), SelEndY);\r\n TextModified(SelBegX, SelBegY, maDelete, S);\r\n end\r\n else\r\n if SelBlockFormat = bfColumn then\r\n begin\r\n Y := CaretY;\r\n FLines.DeleteColumnText(SelBegX, SelBegY, SelEndX, SelEndY);\r\n TextModified(SelBegX, SelBegY, maDeleteColumn, S);\r\n end;\r\n SetCaretInternal(X, Y);\r\n Changed;\r\n finally\r\n PaintCaret(True);\r\n EndUpdate;\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomWideEditor.Clear;\r\nbegin\r\n FLines.Clear;\r\nend;\r\n\r\nfunction TJvCustomWideEditor.GetLines: TWStrings;\r\nbegin\r\n Result := FLines;\r\nend;\r\n\r\nprocedure TJvCustomWideEditor.SetLines(ALines: TWStrings);\r\nbegin\r\n if ALines <> nil then\r\n FLines.Assign(ALines);\r\n {--- UNDO ---}\r\n NotUndoable;\r\n {--- /UNDO ---}\r\nend;\r\n\r\nprocedure TJvCustomWideEditor.TextAllChangedInternal(Unselect: Boolean);\r\nbegin\r\n inherited TextAllChangedInternal(Unselect);\r\n TextModified(0, 0, maAll, '');\r\n UpdateEditorView;\r\nend;\r\n\r\nfunction TJvCustomWideEditor.ExpandTabs(const S: WideString): WideString;\r\nvar\r\n ps, I: Integer;\r\n Sp: WideString;\r\n Tabs, LenSp: Integer;\r\n P: PWideChar;\r\nbegin\r\n ps := Pos(Tab, S);\r\n if ps > 0 then\r\n begin\r\n // How many Tab chars?\r\n Tabs := 1;\r\n for I := ps + 1 to Length(S) do\r\n if S[I] = Tab then\r\n Inc(Tabs);\r\n\r\n Sp := SpacesW(GetDefTabStop(0, True));\r\n LenSp := Length(Sp);\r\n\r\n // needed memory\r\n SetLength(Result, Length(S) - Tabs + Tabs * LenSp);\r\n P := PWideChar(Result);\r\n\r\n // copy the chars before the Tab\r\n if ps > 1 then\r\n begin\r\n MoveWideChar(S[1], P[0], ps);\r\n Inc(P, ps);\r\n end;\r\n\r\n for I := ps to Length(S) do\r\n begin\r\n if S[I] <> Tab then\r\n begin\r\n P[0] := S[I];\r\n Inc(P);\r\n end\r\n else\r\n if LenSp > 0 then\r\n begin\r\n MoveWideChar(Sp[1], P[0], LenSp);\r\n Inc(P, LenSp);\r\n end;\r\n end;\r\n end\r\n else\r\n Result := S;\r\nend;\r\n\r\nprocedure TJvCustomWideEditor.TextModified(ACaretX, ACaretY: Integer; Action: TModifiedAction; const Text: WideString);\r\nbegin\r\nend;\r\n\r\nfunction TJvCustomWideEditor.GetLineCount: Integer;\r\nbegin\r\n Result := FLines.Count;\r\nend;\r\n\r\nfunction TJvCustomWideEditor.GetLineLength(Index: Integer): Integer;\r\nbegin\r\n Result := Length(FLines[Index]);\r\nend;\r\n\r\nfunction TJvCustomWideEditor.FindNotBlankCharPosInLine(Line: Integer): Integer;\r\nbegin\r\n Result := FindNotBlankCharPos(FLines[Line]);\r\nend;\r\n\r\nprocedure TJvCustomWideEditor.SetLockText(const Text: WideString);\r\nbegin\r\n FLines.SetLockText(Text);\r\nend;\r\n\r\nfunction TJvCustomWideEditor.GetWordOnCaret: WideString;\r\nbegin\r\n if CaretY < FLines.Count then\r\n Result := GetWordOnPos(FLines[CaretY], CaretX + 1)\r\n else\r\n Result := '';\r\nend;\r\n\r\nfunction TJvCustomWideEditor.GetAutoIndentStop(Y: Integer): Integer;\r\nvar\r\n I, Len: Integer;\r\n S: WideString;\r\nbegin\r\n Result := 0;\r\n\r\n // find non-empty line\r\n Dec(Y);\r\n while Y > 0 do\r\n begin\r\n S := FLines[Y];\r\n if Length(TrimW(S)) > 0 then\r\n Break;\r\n Dec(Y);\r\n end;\r\n if Y < 0 then\r\n Exit;\r\n\r\n Len := Length(S);\r\n I := 1;\r\n while (I <= Len) and (S[I] = ' ') do\r\n Inc(I);\r\n Result := I - 1;\r\nend;\r\n\r\nfunction TJvCustomWideEditor.GetTabStop(X, Y: Integer; Next: Boolean): Integer;\r\nvar\r\n I: Integer;\r\n\r\n procedure UpdateTabStops;\r\n var\r\n S: WideString;\r\n J, I: Integer;\r\n begin\r\n FillChar(FTabPos, SizeOf(FTabPos), False);\r\n if SmartTab then\r\n begin\r\n J := 1;\r\n I := 1;\r\n while Y - J >= 0 do\r\n begin\r\n S := TrimRightW(FLines[Y - J]);\r\n if Length(S) > I then\r\n FTabPos[Length(S)] := True;\r\n while I <= Length(S) do\r\n begin\r\n if CharInSetW(S[I], IdentifierSymbols) then\r\n begin\r\n FTabPos[I - 1] := True;\r\n while (I <= Length(S)) and CharInSetW(S[I], IdentifierSymbols) do\r\n Inc(I);\r\n end;\r\n Inc(I);\r\n end; { for }\r\n\r\n if I >= Max_X_Scroll then\r\n Break;\r\n if J >= VisibleRowCount * 2 then\r\n Break;\r\n Inc(J);\r\n end;\r\n end;\r\n end;\r\n\r\nbegin\r\n UpdateTabStops;\r\n Result := X;\r\n if Next then\r\n begin\r\n for I := X + 1 to High(FTabPos) do\r\n if FTabPos[I] then\r\n begin\r\n Result := I;\r\n Exit;\r\n end;\r\n if Result = X then\r\n Result := GetDefTabStop(X, True);\r\n end\r\n else\r\n begin\r\n if Result = X then\r\n Result := GetDefTabStop(X, False);\r\n end;\r\nend;\r\n\r\nfunction TJvCustomWideEditor.GetBackStop(X, Y: Integer): Integer;\r\nvar\r\n I: Integer;\r\n S: WideString;\r\n\r\n procedure UpdateBackStops;\r\n var\r\n S: WideString;\r\n J, I, K: Integer;\r\n begin\r\n J := 1;\r\n I := X - 1;\r\n FillChar(FTabPos, SizeOf(FTabPos), False);\r\n FTabPos[0] := True;\r\n while Y - J >= 0 do\r\n begin\r\n S := FLines[Y - J];\r\n for K := 1 to Min(Length(S), I) do\r\n if S[K] <> ' ' then\r\n begin\r\n I := K;\r\n FTabPos[I - 1] := True;\r\n Break;\r\n end;\r\n if I = 1 then\r\n Break;\r\n if J >= VisibleRowCount * 2 then\r\n Break;\r\n Inc(J);\r\n end;\r\n end;\r\n\r\nbegin\r\n Result := X - 1;\r\n S := TrimRightW(FLines[Y]);\r\n if (TrimW(Copy(S, 1, X)) = '') and\r\n ((X + 1 > Length(S)) or (S[X + 1] <> ' ')) then\r\n begin\r\n UpdateBackStops;\r\n for I := X downto 0 do\r\n if FTabPos[I] then\r\n begin\r\n Result := I;\r\n Exit;\r\n end;\r\n end;\r\nend;\r\n\r\n//=== { TJvInsertUndo } ======================================================\r\n\r\nconstructor TJvInsertUndo.Create(AJvEditor: TJvCustomWideEditor;\r\n ACaretX, ACaretY: Integer; const AText: WideString);\r\nbegin\r\n inherited Create(AJvEditor, ACaretX, ACaretY);\r\n FText := AText;\r\n if JvEditor.PersistentBlocks then\r\n SaveSelection;\r\nend;\r\n\r\nfunction TJvInsertUndo.GetEditor: TJvCustomWideEditor;\r\nbegin\r\n Result := TJvCustomWideEditor(FJvEditor);\r\nend;\r\n\r\nprocedure TJvInsertUndo.Undo;\r\nvar\r\n Text: WideString;\r\n EndX, EndY: Integer;\r\n du: TJvInsertUndo;\r\nbegin\r\n Text := '';\r\n with TJvUndoBufferAccessProtected(UndoBuffer) do\r\n begin\r\n while (FPtr >= 0) and not IsNewGroup(Self) do\r\n begin\r\n Text := TJvInsertUndo(LastUndo).FText + Text;\r\n Dec(FPtr);\r\n if not JvEditor.GroupUndo then\r\n Break;\r\n end;\r\n Inc(FPtr);\r\n\r\n du := TJvInsertUndo(Items[FPtr]);\r\n end;\r\n\r\n GetEndPosCaretW(Text, du.CaretX, du.CaretY, EndX, EndY); // get end caret position\r\n TJvCustomWideEditor(JvEditor).FLines.DeleteText(du.CaretX, du.CaretY, EndX, EndY);\r\n TJvCustomWideEditor(JvEditor).TextModified(du.CaretX, du.CaretY, maDelete, Text);\r\n\r\n TJvCustomWideEditor(JvEditor).SetCaretInternal(du.CaretX, du.CaretY);\r\nend;\r\n\r\n//=== { TJvOverwriteUndo } ===================================================\r\n\r\nconstructor TJvOverwriteUndo.Create(AJvEditor: TJvCustomWideEditor;\r\n ACaretX, ACaretY: Integer; const AOldText, ANewText: WideString);\r\nbegin\r\n inherited Create(AJvEditor, ACaretX, ACaretY);\r\n FOldText := AOldText;\r\n FNewText := ANewText;\r\nend;\r\n\r\nfunction TJvOverwriteUndo.GetEditor: TJvCustomWideEditor;\r\nbegin\r\n Result := TJvCustomWideEditor(FJvEditor);\r\nend;\r\n\r\nprocedure TJvOverwriteUndo.Undo;\r\nvar\r\n OldText, NewText: WideString;\r\n EndX, EndY: Integer;\r\n OverwriteUndo: TJvOverwriteUndo;\r\nbegin\r\n OldText := '';\r\n NewText := '';\r\n with TJvUndoBufferAccessProtected(UndoBuffer) do\r\n begin\r\n while (FPtr >= 0) and not IsNewGroup(Self) do\r\n begin\r\n OldText := TJvOverwriteUndo(LastUndo).FOldText + OldText;\r\n NewText := TJvOverwriteUndo(LastUndo).FNewText + NewText;\r\n Dec(FPtr);\r\n if not GetEditor.GroupUndo then\r\n Break;\r\n end;\r\n Inc(FPtr);\r\n OverwriteUndo := TJvOverwriteUndo(Items[FPtr]);\r\n end;\r\n with OverwriteUndo do\r\n begin\r\n GetEndPosCaretW(NewText, CaretX, CaretY, EndX, EndY); // get end caret position\r\n GetEditor.FLines.DeleteText(CaretX, CaretY, EndX, EndY);\r\n GetEditor.FLines.InsertText(CaretX, CaretY, OldText);\r\n GetEditor.TextModified(CaretX, CaretY, maReplace, OldText);\r\n\r\n GetEditor.SetCaretInternal(CaretX, CaretY);\r\n end;\r\nend;\r\n\r\n//=== { TJvInsertColumnUndo } ================================================\r\n\r\nprocedure TJvInsertColumnUndo.Undo;\r\nvar\r\n I: Integer;\r\n SS: TWStringList;\r\n S: WideString;\r\nbegin\r\n { Do not call GetEditor.FLines.DeleteColumnText() here because it has not\r\n the functionality needed in this context. It deletes the columns from\r\n [BegX..EndX] even if the inserted line was not as long as EndX-BegX+1. }\r\n\r\n SS := TWStringList.Create;\r\n try\r\n SS.Text := FText;\r\n for I := 0 to SS.Count - 1 do\r\n begin\r\n S := GetEditor.FLines[CaretY + I];\r\n Delete(S, CaretX + 1, Length(SS[I]));\r\n GetEditor.FLines.Internal[CaretY + I] := S;\r\n end;\r\n finally\r\n SS.Free;\r\n end;\r\n GetEditor.TextModified(CaretX, CaretY, maDelete, FText);\r\n\r\n GetEditor.SetCaretInternal(CaretX, CaretY);\r\nend;\r\n\r\n//=== { TJvUnindentColumnUndo } ==============================================\r\n\r\nconstructor TJvUnindentColumnUndo.Create(AJvEditor: TJvCustomWideEditor;\r\n ACaretX, ACaretY, ABegX, ABegY: Integer; const AText: WideString);\r\nbegin\r\n inherited Create(AJvEditor, ACaretX, ACaretY, AText);\r\n SaveSelection;\r\n FBegX := ABegX;\r\n FBegY := ABegY;\r\nend;\r\n\r\nprocedure TJvUnindentColumnUndo.Undo;\r\nvar\r\n BegX, BegY: Integer;\r\nbegin\r\n BegX := FBegX;\r\n BegY := FBegY;\r\n with TJvUndoBufferAccessProtected(UndoBuffer) do\r\n begin\r\n while (FPtr >= 0) and not IsNewGroup(Self) do\r\n begin\r\n with TJvUnindentColumnUndo(LastUndo) do\r\n begin\r\n GetEditor.FLines.InsertColumnText(FBegX, FBegY, FText);\r\n if BegX > FBegX then\r\n BegX := FBegX;\r\n if BegY > FBegY then\r\n BegY := FBegY;\r\n end;\r\n Dec(FPtr);\r\n if not GetEditor.GroupUndo then\r\n Break;\r\n end;\r\n Inc(FPtr);\r\n end;\r\n GetEditor.TextModified(BegX, BegY, maInsert, GetEditor.FLines[BegY]);\r\n\r\n RestoreSelection;\r\n with TJvUnindentColumnUndo(TJvUndoBufferAccessProtected(UndoBuffer).LastUndo) do\r\n GetEditor.SetCaretInternal(CaretX, CaretY);\r\nend;\r\n\r\n//=== { TJvDeleteUndo } ======================================================\r\n\r\nprocedure TJvDeleteUndo.Undo;\r\nvar\r\n Text: WideString;\r\nbegin\r\n Text := '';\r\n with TJvUndoBufferAccessProtected(UndoBuffer) do\r\n begin\r\n while (FPtr >= 0) and not IsNewGroup(Self) do\r\n begin\r\n Text := TJvDeleteUndo(LastUndo).FText + Text;\r\n Dec(FPtr);\r\n if not GetEditor.GroupUndo then\r\n Break;\r\n end;\r\n Inc(FPtr);\r\n\r\n with TJvDeleteUndo(Items[FPtr]) do\r\n begin\r\n GetEditor.FLines.InsertText(CaretX, CaretY, Text);\r\n GetEditor.TextModified(CaretX, CaretY, maInsert, Text);\r\n\r\n GetEditor.SetCaretInternal(CaretX, CaretY);\r\n end;\r\n end;\r\nend;\r\n\r\n\r\n//=== { TJvDeleteLineUndo } ==================================================\r\n\r\n{procedure TJvDeleteLineUndo.Redo;\r\nbegin\r\n GetEditor.FLines.Insert(CaretY, FText);\r\nend;}\r\n\r\nconstructor TJvDeleteLineUndo.Create(AJvEditor: TJvCustomWideEditor; ACaretX, ACaretY: Integer;\r\n const AText: WideString; ALastLineDelete: Boolean);\r\nbegin\r\n inherited Create(AJvEditor, ACaretX, ACaretY, AText);\r\n FLastLineDelete := ALastLineDelete;\r\nend;\r\n\r\nprocedure TJvDeleteLineUndo.Undo;\r\nbegin\r\n GetEditor.LockUpdate;\r\n try\r\n if FLastLineDelete then\r\n begin\r\n GetEditor.FLines[CaretY] := FText;\r\n GetEditor.TextModified(CaretX, CaretY, maReplace, FText);\r\n end\r\n else\r\n begin\r\n GetEditor.FLines.Insert(CaretY, FText);\r\n GetEditor.TextModified(CaretX, CaretY, maInsert, FText);\r\n end;\r\n finally\r\n GetEditor.UnlockUpdate;\r\n end;\r\n GetEditor.SetCaretInternal(CaretX, CaretY);\r\nend;\r\n\r\n//=== { TJvBackspaceUndo } ===================================================\r\n\r\nprocedure TJvBackspaceUndo.Undo;\r\nvar\r\n Text: WideString;\r\n StartPtr: Integer;\r\nbegin\r\n Text := '';\r\n with TJvUndoBufferAccessProtected(UndoBuffer) do\r\n begin\r\n StartPtr := FPtr;\r\n while (FPtr >= 0) and not IsNewGroup(Self) do\r\n begin\r\n Text := Text + TJvDeleteUndo(LastUndo).FText;\r\n Dec(FPtr);\r\n if not GetEditor.GroupUndo then\r\n Break;\r\n end;\r\n Inc(FPtr);\r\n end;\r\n\r\n with TJvDeleteUndo(UndoBuffer.Items[StartPtr]) do\r\n begin\r\n GetEditor.FLines.InsertText(CaretX - 1, CaretY, Text);\r\n GetEditor.TextModified(CaretX - 1, CaretY, maInsert, Text);\r\n end;\r\n\r\n // set caret on last backspace undo's position\r\n with TJvDeleteUndo(UndoBuffer.Items[TJvUndoBufferAccessProtected(UndoBuffer).FPtr]) do\r\n if (FText = Lf) or (FText = Cr) then // a line was removed by backspace\r\n GetEditor.SetCaretInternal(0, CaretY + 1)\r\n else\r\n GetEditor.SetCaretInternal(CaretX, CaretY);\r\nend;\r\n\r\nprocedure TJvBackspaceUnindentUndo.Undo;\r\nvar\r\n Text: WideString;\r\nbegin\r\n Text := '';\r\n with TJvUndoBufferAccessProtected(UndoBuffer) do\r\n begin\r\n while (FPtr >= 0) and not IsNewGroup(Self) do\r\n begin\r\n Text := Text + TJvDeleteUndo(LastUndo).FText;\r\n Dec(FPtr);\r\n if not GetEditor.GroupUndo then\r\n Break;\r\n end;\r\n Inc(FPtr);\r\n\r\n with TJvDeleteUndo(Items[FPtr]) do\r\n begin\r\n GetEditor.FLines.InsertText(CaretX - Length(Text), CaretY, Text);\r\n GetEditor.TextModified(CaretX - Length(Text), CaretY, maInsert, Text);\r\n // set caret on last backspace undo's position\r\n GetEditor.SetCaretInternal(CaretX, CaretY);\r\n end;\r\n end;\r\nend;\r\n\r\n//=== { TJvReplaceUndo } =====================================================\r\n\r\nconstructor TJvReplaceUndo.Create(AJvEditor: TJvCustomWideEditor;\r\n ACaretX, ACaretY: Integer; ABegX, ABegY: Integer; const AText, ANewText: WideString);\r\nbegin\r\n inherited Create(AJvEditor, ACaretX, ACaretY);\r\n FBegX := ABegX;\r\n FBegY := ABegY;\r\n FText := AText;\r\n FNewText := ANewText;\r\nend;\r\n\r\nfunction TJvReplaceUndo.GetEditor: TJvCustomWideEditor;\r\nbegin\r\n Result := TJvCustomWideEditor(FJvEditor);\r\nend;\r\n\r\nprocedure TJvReplaceUndo.Undo;\r\nvar\r\n EndX, EndY: Integer;\r\nbegin\r\n GetEndPosCaretW(FNewText, FBegX, FBegY, EndX, EndY);\r\n GetEditor.FLines.DeleteText(FBegX, FBegY, EndX, EndY);\r\n GetEditor.FLines.InsertText(FBegX, FBegY, FText);\r\n GetEditor.TextModified(FBegX, FBegY, maReplace, FText);\r\n\r\n GetEditor.SetCaretInternal(CaretX, CaretY);\r\nend;\r\n\r\n//=== { TJvDeleteSelectedUndo } ==============================================\r\n\r\nconstructor TJvDeleteSelectedUndo.Create(AJvEditor: TJvCustomWideEditor;\r\n ACaretX, ACaretY: Integer; const AText: WideString);\r\nbegin\r\n inherited Create(AJvEditor, ACaretX, ACaretY, AText);\r\n SaveSelection;\r\nend;\r\n\r\nprocedure TJvDeleteSelectedUndo.Undo;\r\nvar\r\n S: WideString;\r\n I: Integer;\r\nbegin\r\n with FSelection^ do\r\n begin\r\n if SelBlockFormat in [bfInclusive, bfNonInclusive, bfLine] then\r\n begin\r\n GetEditor.FLines.InsertText(SelBegX, SelBegY, FText);\r\n GetEditor.TextModified(SelBegX, SelBegY, maInsert, FText);\r\n end\r\n else\r\n if SelBlockFormat = bfColumn then\r\n begin\r\n for I := SelBegY to SelEndY do\r\n begin\r\n S := GetEditor.FLines[I];\r\n Insert(SubStrBySeparatorW(FText, I - SelBegY, sLineBreakStr), S, SelBegX + 1);\r\n GetEditor.FLines.Internal[I] := S;\r\n end;\r\n GetEditor.TextModified(SelBegX, SelBegY, maInsertColumn, FText);\r\n end;\r\n\r\n RestoreSelection;\r\n GetEditor.SetCaretInternal(CaretX, CaretY);\r\n end; // with\r\nend;\r\n\r\n//=== { TJvEditorCompletion } ================================================\r\n\r\nconstructor TJvWideCompletion.Create(AJvEditor: TJvCustomWideEditor);\r\nbegin\r\n inherited Create(AJvEditor);\r\n FIdentifiers := TWStringList.Create;\r\n FTemplates := TWStringList.Create;\r\n FCaretChar := '|';\r\n FCRLF := '/n';\r\n FSeparator := '=';\r\nend;\r\n\r\ndestructor TJvWideCompletion.Destroy;\r\nbegin\r\n inherited Destroy;\r\n FIdentifiers.Free;\r\n FTemplates.Free;\r\nend;\r\n\r\n{ Substitutes word on the cursor position by NewString [translated] }\r\n\r\nprocedure TJvWideCompletion.ReplaceWord(const NewString: WideString);\r\nvar\r\n S, W: WideString;\r\n X, Y: Integer;\r\n iBegSX, iEndSX: Integer;\r\n NewCaret: Integer;\r\nbegin\r\n with TJvCustomWideEditor(JvEditor) do\r\n begin\r\n if CaretY < FLines.Count then\r\n S := FLines[CaretY];\r\n W := GetNextWordPosExW(S, CaretX, iBegSX, iEndSX);\r\n if W <> NewString then\r\n begin\r\n BeginUpdate;\r\n PaintCaret(False);\r\n try\r\n BeginCompound;\r\n try\r\n Deselect;\r\n ReLine;\r\n\r\n if Length(W) = 0 then\r\n begin\r\n iBegSX := CaretX + 1;\r\n iEndSX := CaretX;\r\n end;\r\n case Mode of\r\n cmIdentifiers:\r\n begin\r\n S := NewString;\r\n if Assigned(FOnCompletionApply) then\r\n FOnCompletionApply(Self, W, S);\r\n NewCaret := -1;\r\n end;\r\n cmTemplates:\r\n begin\r\n S := ReplaceString(NewString, FCRLF, sLineBreakStr + SpacesW(CaretX -\r\n Length(W)));\r\n S := ReplaceString(S, FCaretChar, '');\r\n NewCaret := Pos(FCaretChar, ReplaceString(NewString, FCRLF, sLineBreakStr)) - 1;\r\n end;\r\n else\r\n raise EJvEditorError.CreateRes(@RsEInvalidCompletionMode);\r\n end;\r\n {--- UNDO ---}\r\n TJvReplaceUndo.Create(TJvCustomWideEditor(JvEditor), CaretX, CaretY,\r\n iBegSX - 1, CaretY, W, S);\r\n {--- /UNDO ---}\r\n if iBegSX <= iEndSX then\r\n FLines.DeleteText(iBegSX - 1, CaretY, iEndSX - 1, CaretY);\r\n FLines.InsertText(iBegSX - 1, CaretY, S);\r\n TextModified(iBegSX - 1, CaretY, maReplace, S);\r\n\r\n if NewCaret >= 0 then\r\n SetLength(S, NewCaret); // truncate S to the new caret position\r\n GetEndPosCaretW(S, iBegSX - 1, CaretY, X, Y);\r\n SetCaretInternal(X + 1, Y);\r\n finally\r\n EndCompound;\r\n end;\r\n Changed;\r\n finally\r\n PaintCaret(True);\r\n EndUpdate;\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvWideCompletion.MakeItems;\r\nvar\r\n I: Integer;\r\n S: WideString;\r\nbegin\r\n Items.Clear;\r\n case Mode of\r\n cmIdentifiers:\r\n for I := 0 to FIdentifiers.Count - 1 do\r\n Items.Add(FIdentifiers[I]);\r\n cmTemplates:\r\n begin\r\n with TJvCustomWideEditor(JvEditor) do\r\n if FLines.Count > CaretY then\r\n S := GetWordOnPosW(FLines[CaretY], CaretX)\r\n else\r\n S := '';\r\n for I := 0 to FTemplates.Count - 1 do\r\n if StrLICompW(PWideChar(FTemplates[I]), PWideChar(S), Length(S)) = 0 then\r\n Items.Add(FTemplates[I]);\r\n if Items.Count = 0 then\r\n Items.Assign(FTemplates);\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvWideCompletion.FindSelItem(var Eq: Boolean);\r\nvar\r\n S: WideString;\r\n\r\n function FindFirst(SS: TStrings; S: string): Integer;\r\n var\r\n I: Integer;\r\n begin\r\n for I := 0 to SS.Count - 1 do\r\n if StrLIComp(PChar(SS[I]), PChar(S), Length(S)) = 0 then\r\n begin\r\n Result := I;\r\n Exit;\r\n end;\r\n Result := -1;\r\n end;\r\n\r\nbegin\r\n with TJvCustomWideEditor(JvEditor) do\r\n if FLines.Count > 0 then\r\n S := GetWordOnPosW(FLines[CaretY], CaretX)\r\n else\r\n S := '';\r\n if TrimW(S) = '' then\r\n ItemIndex := -1\r\n else\r\n ItemIndex := FindFirst(Items, S);\r\n Eq := (ItemIndex > -1) and SameText(TrimW(SubStrBySeparatorW(Items[ItemIndex], 0, FSeparator)), S);\r\nend;\r\n\r\nfunction TJvWideCompletion.GetStrings(Index: Integer): TWStrings;\r\nbegin\r\n case Index of\r\n 0:\r\n Result := FIdentifiers;\r\n 1:\r\n Result := FTemplates;\r\n else\r\n Result := nil;\r\n end;\r\nend;\r\n\r\nprocedure TJvWideCompletion.SetStrings(Index: Integer; AValue: TWStrings);\r\nbegin\r\n case Index of\r\n 0:\r\n FIdentifiers.Assign(AValue);\r\n 1:\r\n FTemplates.Assign(AValue);\r\n end;\r\nend;\r\n\r\nfunction TJvWideCompletion.GetIdentifierCount: Integer;\r\nbegin\r\n Result := FIdentifiers.Count;\r\nend;\r\n\r\nfunction TJvWideCompletion.GetTemplateCount: Integer;\r\nbegin\r\n Result := FTemplates.Count;\r\nend;\r\n\r\nprocedure TJvWideCompletion.ReplaceWordItemIndex(SubStrStart: Integer);\r\nbegin\r\n ReplaceWord(SubStrBySeparatorW(Items[ItemIndex], SubStrStart, FSeparator));\r\nend;\r\n\r\nfunction TJvCustomWideEditor.GetCompletion: TJvWideCompletion;\r\nbegin\r\n Result := TJvWideCompletion(inherited Completion);\r\nend;\r\n\r\nprocedure TJvCustomWideEditor.SetCompletion(const Value: TJvWideCompletion);\r\nbegin\r\n inherited Completion := Value;\r\nend;\r\n\r\nfunction TJvWideCompletion.GetSeparator: string;\r\nbegin\r\n Result := FSeparator;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvUnicodeHLEditor.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvUnicodeHLEditor.PAS, released on 2002-07-04.\r\n\r\nThe Initial Developers of the Original Code are: Andrei Prygounkov \r\nCopyright (c) 1999, 2002 Andrei Prygounkov\r\nAll Rights Reserved.\r\n\r\nContributor(s): Eswar Prakash R [eswar dott prakash att gmail.com]\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\ncomponent : TJvWideHLEditor\r\ndescription : JvEditor with built-in highlighting for:\r\n pascal, cbuilder, sql, python, jscript,\r\n vbscript, perl, ini, html, not quite c\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvUnicodeHLEditor.pas 13288 2012-04-27 08:32:34Z ahuser $\r\n\r\nunit JvUnicodeHLEditor;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n Windows,\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n SysUtils, Classes, Graphics,\r\n JclWideStrings,\r\n JvEditorCommon, JvUnicodeEditor, JvHLParser;\r\n\r\ntype\r\n TJvWideHLEditor = class;\r\n\r\n TOnReservedWord = procedure(Sender: TObject; Token: WideString;\r\n var Reserved: Boolean) of object;\r\n\r\n TJvWideEditorHighlighter = class(TComponent)\r\n protected\r\n procedure GetAttr(Editor: TJvWideHLEditor; Lines: TWStrings; Line, ColBeg, ColEnd: Integer;\r\n LongToken: TLongTokenType; var LineAttrs: TLineAttrs); virtual; abstract;\r\n procedure ScanLongTokens(Editor: TJvWideHLEditor; Lines: TWStrings; Line: Integer;\r\n var FLong: TLongTokenType); virtual; abstract;\r\n function GetRescanLongKeys(Editor: TJvWideHLEditor; Action: TModifiedAction;\r\n ACaretX, ACaretY: Integer; const Text: WideString): Boolean; virtual; abstract;\r\n end;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvWideHLEditor = class(TJvWideEditor, IJvHLEditor)\r\n private\r\n Parser: TJvIParserW;\r\n FHighlighter: TJvHighlighter;\r\n FColors: TJvColors;\r\n FLine: WideString;\r\n FLineNum: Integer;\r\n FLong: TLongTokenType;\r\n FLongTokens: Boolean;\r\n FLongDesc: array {[0..Max_Line]} of TLongTokenType;\r\n FSyntaxHighlighting: Boolean;\r\n FSyntaxHighlighter: TJvWideEditorHighlighter;\r\n FOnReservedWord: TOnReservedWord;\r\n\r\n // Coco/R\r\n ProductionsLine: Integer;\r\n function RescanLong(iLine: Integer): Boolean;\r\n procedure CheckInLong;\r\n function FindLongEnd: Integer;\r\n procedure SetHighlighter(const Value: TJvHighlighter);\r\n function GetDelphiColors: Boolean;\r\n procedure SetDelphiColors(Value: Boolean);\r\n function GetColors: TJvColors;\r\n procedure SetColors(const Value: TJvColors);\r\n function GetSyntaxHighlighting: Boolean;\r\n procedure SetSyntaxHighlighting(Value: Boolean);\r\n function GetHighlighter: TJvHighlighter;\r\n protected\r\n procedure Loaded; override;\r\n procedure Notification(AComponent: TComponent; Operation: TOperation); override;\r\n procedure GetAttr(Line, ColBeg, ColEnd: Integer); override;\r\n procedure TextModified(ACaretX, ACaretY: Integer; Action: TModifiedAction;\r\n const Text: WideString); override;\r\n function GetReservedWord(const Token: WideString; var Reserved: Boolean): Boolean; virtual;\r\n function UserReservedWords: Boolean; virtual;\r\n procedure SetSyntaxHighlighter(const Value: TJvWideEditorHighlighter);\r\n procedure AssignTo(Source: TPersistent); override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n procedure Assign(Source: TPersistent); override;\r\n published\r\n property Highlighter: TJvHighlighter read GetHighlighter write SetHighlighter default hlPascal;\r\n property Colors: TJvColors read GetColors write SetColors;\r\n property DelphiColors: Boolean read GetDelphiColors write SetDelphiColors stored False;\r\n property LongTokens: Boolean read FLongTokens write FLongTokens default True;\r\n property OnReservedWord: TOnReservedWord read FOnReservedWord write FOnReservedWord;\r\n property SyntaxHighlighting: Boolean read GetSyntaxHighlighting write SetSyntaxHighlighting stored False;\r\n property SyntaxHighlighter: TJvWideEditorHighlighter read FSyntaxHighlighter write SetSyntaxHighlighter;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvUnicodeHLEditor.pas $';\r\n Revision: '$Revision: 13288 $';\r\n Date: '$Date: 2012-04-27 10:32:34 +0200 (ven. 27 avr. 2012) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n Math,\r\n JvHLEditor, // for Assign\r\n JvJCLUtils, JvConsts, JvJVCLUtils;\r\n\r\nfunction LastNonSpaceChar(const S: WideString): WideChar;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := #0;\r\n I := Length(S);\r\n while (I > 0) and (S[I] = ' ') do\r\n Dec(I);\r\n if I > 0 then\r\n Result := S[I];\r\nend;\r\n\r\nfunction GetTrimChar(const S: WideString; Index: Integer): WideChar;\r\nvar\r\n LS, L: Integer;\r\nbegin\r\n LS := Length(S);\r\n if LS <> 0 then\r\n begin\r\n L := 1;\r\n while (L <= LS) and (S[L] = ' ') do\r\n Inc(L);\r\n if L <= LS then\r\n Result := S[L - 1 + Index]\r\n else\r\n Result := S[Index];\r\n end\r\n else\r\n Result := #0;\r\nend;\r\n\r\nfunction HasStringOpenEnd(Lines: TWStrings; iLine: Integer): Boolean;\r\n{ find C/C++ \"line breaker\" '\\' }\r\nvar\r\n I: Integer;\r\n IsOpen: Boolean;\r\n P, F: PWideChar;\r\n S: WideString;\r\nbegin\r\n Result := False;\r\n if (iLine < 0) or (iLine >= Lines.Count) then\r\n Exit;\r\n I := iLine - 1;\r\n IsOpen := False;\r\n if (I >= 0) and (LastNonSpaceChar(Lines[I]) = '\\') then // check prior lines\r\n IsOpen := HasStringOpenEnd(Lines, I);\r\n S := Lines[iLine];\r\n F := PWideChar(S);\r\n P := F;\r\n repeat\r\n P := StrScanW(P, WideChar('\"'));\r\n if P <> nil then\r\n begin\r\n if (P = F) or (P[-1] <> '\\') then\r\n IsOpen := not IsOpen\r\n else\r\n begin\r\n // count the backslashes\r\n I := 1;\r\n while (P-1-I > F) and (P[-1-I] = '\\') do\r\n Inc(I);\r\n if I mod 2 = 0 then\r\n IsOpen := not IsOpen;\r\n end;\r\n Inc(P);\r\n end;\r\n until P = nil;\r\n Result := IsOpen;\r\nend;\r\n\r\nfunction StrScanW(P: PWideChar; Ch: WideChar): PWideChar;\r\nbegin\r\n Result := P;\r\n while True do\r\n begin\r\n if Result[0] = Ch then\r\n Exit\r\n else\r\n if Result[0] = #0 then\r\n begin\r\n Result := nil;\r\n Exit;\r\n end;\r\n Inc(Result);\r\n end;\r\nend;\r\n\r\n//=== { TJvWideHLEditor } ====================================================\r\n\r\nconstructor TJvWideHLEditor.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n Parser := TJvIParserW.Create;\r\n Parser.ReturnComments := True;\r\n FHighlighter := hlPascal;\r\n FColors := TJvColors.Create;\r\n FLongTokens := True;\r\n FSyntaxHighlighting := True;\r\n ProductionsLine := High(Integer);\r\nend;\r\n\r\ndestructor TJvWideHLEditor.Destroy;\r\nbegin\r\n Parser.Free;\r\n FColors.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvWideHLEditor.Notification(AComponent: TComponent;\r\n Operation: TOperation);\r\nbegin\r\n inherited Notification(AComponent, Operation);\r\n if (Operation = opRemove) and (AComponent = FSyntaxHighlighter) then\r\n SyntaxHighlighter := nil;\r\nend;\r\n\r\nprocedure TJvWideHLEditor.Loaded;\r\nbegin\r\n inherited Loaded;\r\n RescanLong(0);\r\nend;\r\n\r\nprocedure TJvWideHLEditor.SetHighlighter(const Value: TJvHighlighter);\r\nbegin\r\n if FHighlighter <> Value then\r\n begin\r\n FHighlighter := Value;\r\n case FHighlighter of\r\n hlPascal:\r\n Parser.Style := psPascal;\r\n hlCBuilder, hlJava, hlNQC, hlCSharp:\r\n Parser.Style := psCpp;\r\n hlSql:\r\n Parser.Style := psSql;\r\n hlPython:\r\n Parser.Style := psPython;\r\n hlVB:\r\n Parser.Style := psVB;\r\n hlHtml:\r\n Parser.Style := psHtml;\r\n hlPerl:\r\n Parser.Style := psPerl;\r\n hlIni:\r\n Parser.Style := psPascal;\r\n hlCocoR:\r\n Parser.Style := psCocoR;\r\n hlPhp:\r\n Parser.Style := psPhp;\r\n end;\r\n RescanLong(0);\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvWideHLEditor.GetAttr(Line, ColBeg, ColEnd: Integer);\r\nconst\r\n Symbols = [',', ':', ';', '.', '[', ']', '(', ')', '=', '+',\r\n '-', '/', '<', '>', '%', '*', '~', '''', '\\', '^', '@', '{', '}',\r\n '#', '|', '&'];\r\n\r\nconst\r\n DelphiKeyWords =\r\n ' constructor destructor string record procedure with of' +\r\n ' repeat until try finally except for to downto case' +\r\n ' type interface implementation initialization finalization' +\r\n ' default private public protected published automated property' +\r\n ' program read write override object nil raise' +\r\n ' on set xor shr shl begin end args if then else' +\r\n ' endif goto while do var or and not mod div unit' +\r\n ' function uses external const class inherited' +\r\n ' register stdcall cdecl safecall pascal is as package program' +\r\n ' external overload platform deprecated implements export contains' +\r\n ' requires resourcestring message dispid assembler asm abstract absolute' +\r\n ' dispinterface file threadvar library' +\r\n // TurboPascal\r\n ' interrupt inline near far' +\r\n // Delphi 8\r\n ' operator strict final unsafe sealed static ';\r\n\r\n BuilderKeyWords =\r\n ' __asm _asm asm auto __automated break bool case catch __cdecl' +\r\n ' _cdecl cdecl char class __classid __closure const const_cast' +\r\n ' continue __declspec default delete __dispid do double dynamic_cast' +\r\n ' else enum __except explicit _export __export extern false __fastcall' +\r\n ' _fastcall __finally float for friend goto if __import _import inline' +\r\n ' int __int8 __int16 __int32 __int64 long mutable namespace new operator' +\r\n ' __pascal _pascal pascal private protected __property public __published' +\r\n ' register reinterpret_cast return __rtti short signed sizeof static static_cast' +\r\n ' __stdcall _stdcall struct switch template this __thread throw true __try' +\r\n ' try typedef typename typeid union using unsigned virtual void volatile' +\r\n ' wchar_t while ';\r\n\r\n NQCKeyWords = {Not Quite C - a C similar language for programming LEGO MindStorm(R) robots }\r\n ' __event_src __type acquire break __sensor abs asm case catch const' +\r\n ' continue default do else false for if inline' +\r\n ' int monitor repeat return signed start stop sub switch task true' +\r\n ' until void while ';\r\n\r\n // Support for REPLACE keyword\r\n SQLKeyWords =\r\n ' active as add asc after ascending all at alter auto' +\r\n ' and autoddl any avg based between basename blob' +\r\n ' base_name blobedit before buffer begin by cache compiletime' +\r\n ' cast computed char close character conditional character_length connect' +\r\n ' char_length constraint check containing check_point_len continue check_point_length count' +\r\n ' collate create collation cstring column current commit cursor' +\r\n ' committed database descending date describe db_key descriptor debug disconnect' +\r\n ' dec display decimal distinct declare do default domain' +\r\n ' delete double desc drop echo exception edit execute' +\r\n ' else exists end exit entry_point extern escape external' +\r\n ' event extract fetch foreign file found filter from' +\r\n ' float full for function gdscode grant generator group' +\r\n ' gen_id commit_group_wait global group_commit_wait_time goto' +\r\n ' having help if input_type immediate insert in int' +\r\n ' inactive integer index into indicator is init isolation' +\r\n ' inner isql input join key' +\r\n ' lc_messages like lc_type logfile left log_buffer_size length log_buf_size' +\r\n ' lev long level manual merge max message' +\r\n ' maximum min maximum_segment minimum max_segment module_name names not' +\r\n ' national null natural numeric nchar num_log_bufs no num_log_buffers' +\r\n ' noauto octet_length or of order on outer only output' +\r\n ' open output_type option overflow page post_event pagelength precision' +\r\n ' pages prepare page_size procedure parameter protected password primary' +\r\n ' plan privileges position public quit' +\r\n ' raw_partitions retain rdb db_key return read replace returning_values real returns' +\r\n ' record_version revoke references right release rollback reserv runtime' +\r\n ' reserving schema sql segment sqlcode select sqlerror set sqlwarning' +\r\n ' shadow stability shared starting shell starts show statement' +\r\n ' singular static size statistics smallint sub_type snapshot sum' +\r\n ' some suspend sort table translate terminator translation then trigger to trim' +\r\n ' transaction uncommitted upper union user unique using update' +\r\n ' value varying values version varchar view variable' +\r\n ' wait while when with whenever work where write' +\r\n ' term new old ';\r\n\r\n PythonKeyWords =\r\n ' and del for is raise' +\r\n ' assert elif from lambda return' +\r\n ' break else global not try' +\r\n ' class except if or while' +\r\n ' continue exec import pass' +\r\n ' def finally in print ';\r\n\r\n JavaKeyWords =\r\n ' abstract delegate if boolean do implements break double import' +\r\n ' byte else instanceof case extends int catch false interface' +\r\n ' char final long class finally multicast continue float' +\r\n ' default for native short transient new static true' +\r\n ' null super try package switch void private synchronized volatile' +\r\n ' protected this while public throw return throws ';\r\n\r\n VBKeyWords =\r\n ' as and base binary byref byval call case class compare const date debug declare deftype dim do each else elseif ' +\r\n ' empty end endif enum eqv erase error event execute exit explicit false for friend function get' +\r\n ' global gosub goto if imp implements input is kill len let line load lock loop lset me mid mod name new next not nothing null on open option optional' +\r\n ' or paramarray preserve print private property public raiseevent randomize redim rem' +\r\n ' resume return seek select set static step' +\r\n ' string sub then time to true unlock until wend while with withevents xor ';\r\n\r\n VBStatements =\r\n ' access alias any beep ccur cdbl chdir chdrive choose' +\r\n ' chr cint clear clng clone close cls command compare' +\r\n ' cos csng cstr curdir currency cvar cvdate ' +\r\n ' defcur defdbl defint deflng defsng defstr deftype defvar delete deletesetting' +\r\n ' doevents double dynaset edit environ eof erl err exp fix format ' +\r\n ' hex int integer isdate isempty isnull isnumeric lbound lcase' +\r\n ' lib like loc local lof long mkdir oct output pset put' +\r\n ' random read refresh reset restore rmdir rnd rset savesetting ' +\r\n ' sendkeys shared single stop system text type typeof ubound unload ' +\r\n ' using variant vartype write';\r\n\r\n HTMLTags =\r\n ' doctype a address applet area b base basefont bgsound big blink ' +\r\n ' blockquote body br caption center cite code col colgroup comment ' +\r\n ' dfn dir li div dl dt dd em embed font form frame frameset h align ' +\r\n ' h1 h2 h3 h4 h5 h6 head hr html i iframe img input isindex kbd link ' +\r\n ' listing map marquee menu meta multicol nextid nobr noframes noscript ' +\r\n ' object ol option p plaintext pre s samp script select small sound ' +\r\n ' spacer span strike strong style sub sup table tbody td textarea tfoot' +\r\n ' th thead title tr tt u ul var wbr xmp ';\r\n\r\n HTMLSpecChars =\r\n ' Aacute aacute acirc Acirc acute AElig aelig agrave Agrave alefsym ' +\r\n ' alpha Alpha AMP amp and ang Aring aring asymp atilde Atilde Auml ' +\r\n ' auml bdquo beta Beta brvbar bull cap Ccedil ccedil cedil cent chi ' +\r\n ' Chi circ clubs cong copy COPY crarr cup curren dagger Dagger dArr ' +\r\n ' darr deg Delta delta diams divide eacute Eacute ecirc Ecirc Egrave ' +\r\n ' egrave empty emsp ensp Epsilon epsilon equiv eta Eta ETH eth Euml ' +\r\n ' euml euro exist fnof forall frac12 frac14 frac34 frasl Gamma gamma ' +\r\n ' ge gt GT harr hArr hearts hellip iacute Iacute Icirc icirc iexcl Igrave ' +\r\n ' igrave image infin int Iota iota iquest isin Iuml iuml kappa Kappa Lambda ' +\r\n ' lambda lang laquo larr lArr lceil ldquo le lfloor lowast loz lrm lsaquo ' +\r\n ' lsquo lt LT macr mdash micro middot minus mu Mu nabla nbsp ndash ne ' +\r\n ' ni not notin nsub Ntilde ntilde Nu nu oacute Oacute ocirc Ocirc oelig ' +\r\n ' OElig ograve Ograve oline Omega omega omicron Omicron oplus or ordf ' +\r\n ' ordm Oslash oslash Otilde otilde otimes ouml Ouml para part permil ' +\r\n ' perp phi Phi Pi pi piv plusmn pound Prime prime prod prop psi Psi quot ' +\r\n ' QUOT radic rang raquo rArr rarr rceil rdquo real REG reg rfloor Rho ' +\r\n ' rho rlm rsaquo rsquo sbquo scaron Scaron sdot sect shy Sigma sigma ' +\r\n ' sigmaf sim spades sub sube sum sup sup1 sup2 sup3 supe szlig Tau ' +\r\n ' tau there4 Theta theta thetasym thinsp THORN thorn tilde times trade ' +\r\n ' Uacute uacute uArr uarr ucirc Ucirc ugrave Ugrave uml upsih upsilon ' +\r\n ' Upsilon uuml Uuml weierp xi Xi Yacute yacute yen yuml Yuml zeta Zeta ' +\r\n ' zwj zwnj ';\r\n\r\n PerlKeyWords =\r\n ' sub if else unless foreach next local ' +\r\n ' return defined until while do elsif eq ';\r\n\r\n PerlStatements =\r\n ' stat die open print push close defined chdir last read chop ' +\r\n ' keys sort bind unlink select length ';\r\n\r\n CocoKeyWords = DelphiKeyWords +\r\n ' compiler productions delphi end_delphi ignore case characters ' +\r\n ' tokens create destroy errors comments from nested chr any ' +\r\n ' description ';\r\n\r\n CSharpKeyWords =\r\n ' abstract as base bool break byte case catch char checked class ' +\r\n ' const continue decimal default delegate do double else enum event ' +\r\n ' explicit extern false finally fixed float for foreach goto if ' +\r\n ' implicit in int interface internal is lock long namespace new null ' +\r\n ' object operator out override params private protected public readonly ' +\r\n ' ref return sbyte sealed short sizeof stackalloc static string struct ' +\r\n ' switch this throw true try typeof uint ulong unchecked unsafe ushort ' +\r\n ' using virtual void volatile while ';\r\n\r\n\r\n function PosI(const S1, S2: WideString): Boolean;\r\n var\r\n F, P: PWideChar;\r\n Len: Integer;\r\n begin\r\n Len := Length(S1);\r\n Result := True;\r\n P := PWideChar(S2);\r\n while P[0] <> #0 do\r\n begin\r\n while P[0] = ' ' do\r\n Inc(P);\r\n F := P;\r\n while not (P[0] <= #32) do\r\n Inc(P);\r\n if (P - F) = Len then\r\n if StrLICompW2(PWideChar(S1), F, Len) = 0 then\r\n Exit;\r\n end;\r\n Result := False;\r\n end;\r\n\r\n function PosNI(const S1, S2: WideString): Boolean;\r\n var\r\n F, P: PWideChar;\r\n Len: Integer;\r\n begin\r\n Len := Length(S1);\r\n Result := True;\r\n P := PWideChar(S2);\r\n while P[0] <> #0 do\r\n begin\r\n while P[0] = ' ' do\r\n Inc(P);\r\n F := P;\r\n while not (P[0] <= #32) do\r\n Inc(P);\r\n if (P - F) = Len then\r\n if StrLCompW(PWideChar(S1), F, Len) = 0 then\r\n Exit;\r\n end;\r\n Result := False;\r\n end;\r\n\r\n function IsDelphiKeyWord(const St: WideString): Boolean;\r\n begin\r\n Result := PosI(St, DelphiKeyWords);\r\n end;\r\n\r\n function IsBuilderKeyWord(const St: WideString): Boolean;\r\n begin\r\n Result := PosNI(St, BuilderKeyWords);\r\n end;\r\n\r\n function IsNQCKeyWord(const St: WideString): Boolean;\r\n begin\r\n Result := PosNI(St, NQCKeyWords);\r\n end;\r\n\r\n function IsJavaKeyWord(const St: WideString): Boolean;\r\n begin\r\n Result := PosNI(St, JavaKeyWords);\r\n end;\r\n\r\n function IsVBKeyWord(const St: WideString): Boolean;\r\n begin\r\n Result := PosI(St, VBKeyWords);\r\n end;\r\n\r\n function IsVBStatement(const St: WideString): Boolean;\r\n begin\r\n Result := PosI(St, VBStatements);\r\n end;\r\n\r\n function IsSQLKeyWord(const St: WideString): Boolean;\r\n begin\r\n Result := PosI(St, SQLKeyWords);\r\n end;\r\n\r\n function IsPythonKeyWord(const St: WideString): Boolean;\r\n begin\r\n Result := PosNI(St, PythonKeyWords);\r\n end;\r\n\r\n function IsHtmlTag(const St: WideString): Boolean;\r\n begin\r\n Result := PosI(St, HTMLTags);\r\n end;\r\n\r\n function IsHtmlSpecChar(const St: WideString): Boolean;\r\n begin\r\n Result := PosI(St, HTMLSpecChars);\r\n end;\r\n\r\n function IsPerlKeyWord(const St: WideString): Boolean;\r\n begin\r\n Result := PosNI(St, PerlKeyWords);\r\n end;\r\n\r\n function IsPerlStatement(const St: WideString): Boolean;\r\n begin\r\n Result := PosNI(St, PerlStatements);\r\n end;\r\n\r\n function IsCocoKeyWord(const St: WideString): Boolean;\r\n begin\r\n Result := PosI(St, CocoKeyWords);\r\n end;\r\n\r\n function IsPhpKeyWord(const St: WideString): Boolean;\r\n begin\r\n Result := PosNI(St, PerlKeyWords);\r\n end;\r\n\r\n function IsCSharpKeyWord(const St: WideString): Boolean;\r\n begin\r\n Result := PosNI(St, CSharpKeyWords);\r\n end;\r\n\r\n function IsComment(const St: WideString): Boolean;\r\n var\r\n LS: Integer;\r\n begin\r\n LS := Length(St);\r\n case Highlighter of\r\n hlPascal:\r\n Result := ((LS > 0) and (St[1] = '{')) or\r\n ((LS > 1) and (((St[1] = '(') and (St[2] = '*')) or\r\n ((St[1] = '/') and (St[2] = '/'))));\r\n hlCBuilder, hlJava, hlPhp, hlNQC:\r\n Result := (LS > 1) and (St[1] = '/') and\r\n ((St[2] = '*') or (St[2] = '/'));\r\n // Support for SQL comment line beginning with --\r\n hlSql:\r\n Result := (LS > 1) and (((St[1] = '-') and\r\n (St[2] = '-')) or\r\n ((St[1] = '/') and (St[2] = '*')));\r\n // HTML multi line comment support\r\n hlHtml:\r\n Result := (LS > 3) and (St[1] = '<') and (St[2] = '!') and\r\n (St[3] = '-') and (St[4] = '-');\r\n hlVB:\r\n Result := (LS > 0) and (St[1] = '''');\r\n hlPython, hlPerl:\r\n Result := (LS > 0) and (St[1] = '#');\r\n hlIni:\r\n Result := (LS > 0) and ((St[1] = '#') or (St[1] = ';'));\r\n hlCocoR:\r\n Result := (LS > 1) and (((St[1] = '/') and (St[2] = '/')) or\r\n ((St[1] = '(') and (St[2] = '*')) or\r\n ((St[1] = '/') and (St[2] = '*'))\r\n );\r\n else\r\n Result := False;\r\n end;\r\n end;\r\n\r\n function IsPreproc(const St: WideString): Boolean;\r\n var\r\n LS: Integer;\r\n begin\r\n LS := Length(St);\r\n case Highlighter of\r\n hlPascal:\r\n Result := ((LS > 0) and ((St[1] = '{') and (St[2] = '$'))) or\r\n ((LS > 1) and (((St[1] = '(') and (St[2] = '*') and (St[3] = '$'))));\r\n {hlCBuilder, hlSql, hlJava, hlPhp, hlNQC:\r\n hlVB:\r\n hlPython, hlPerl:\r\n hlIni:\r\n hlCocoR:}\r\n else\r\n Result := False;\r\n end;\r\n end;\r\n\r\n function IsStringConstant(const St: WideString): Boolean;\r\n var\r\n LS: Integer;\r\n begin\r\n LS := Length(St);\r\n case FHighlighter of\r\n hlPascal, hlCBuilder, hlSql, hlPython, hlJava, hlPerl, hlCocoR, hlPhp, hlNQC:\r\n Result := (LS > 0) and ((St[1] = '''') or (St[1] = '\"'));\r\n hlVB:\r\n Result := (LS > 0) and (St[1] = '\"');\r\n hlHtml:\r\n Result := False;\r\n else\r\n Result := False; { unknown Highlighter ? }\r\n end;\r\n end;\r\n\r\n procedure SetBlockColor(iBeg, iEnd: Integer; Color: TJvSymbolColor);\r\n var\r\n I: Integer;\r\n begin\r\n if iEnd > Max_X then\r\n iEnd := Max_X;\r\n for I := iBeg to iEnd do\r\n with LineAttrs[I] do\r\n begin\r\n FC := Color.ForeColor;\r\n BC := Color.BackColor;\r\n Style := Color.Style;\r\n Border := clNone;\r\n end;\r\n end;\r\n\r\n procedure SetColor(Color: TJvSymbolColor);\r\n begin\r\n SetBlockColor(Parser.PosBeg[0] + 1, Parser.PosEnd[0], Color);\r\n end;\r\n\r\n function NextSymbol: WideString;\r\n var\r\n I: Integer;\r\n begin\r\n I := 0;\r\n while (Parser.pcPos[I] <> #0) and CharInSetW(Parser.pcPos[I], [' ', Tab, Lf, Cr]) do\r\n Inc(I);\r\n Result := Parser.pcPos[I];\r\n end;\r\n\r\n procedure TestHtmlSpecChars(const Token: WideString);\r\n var\r\n I, J, iBeg, iEnd: Integer;\r\n S1: WideString;\r\n F1: Integer;\r\n begin\r\n I := 1;\r\n F1 := Parser.PosBeg[0];\r\n while I <= Length(Token) do\r\n begin\r\n if Token[I] = '&' then\r\n begin\r\n iBeg := I;\r\n iEnd := iBeg;\r\n Inc(I);\r\n while I <= Length(Token) do\r\n begin\r\n if Token[I] = ';' then\r\n begin\r\n iEnd := I;\r\n Break;\r\n end;\r\n Inc(I);\r\n end;\r\n if iEnd > iBeg + 1 then\r\n begin\r\n S1 := Copy(Token, iBeg + 1, iEnd - iBeg - 1);\r\n if IsHtmlSpecChar(S1) then\r\n for J := iBeg to iEnd do\r\n with LineAttrs[F1 + J] do\r\n begin\r\n FC := Colors.Preproc.ForeColor;\r\n BC := Colors.Preproc.BackColor;\r\n Style := Colors.Preproc.Style;\r\n Border := clNone;\r\n end;\r\n end;\r\n end;\r\n Inc(I);\r\n end;\r\n end;\r\n\r\n procedure SetIniColors(const S: WideString);\r\n var\r\n EquPos: Integer;\r\n LS: Integer;\r\n begin\r\n LS := Length(S);\r\n if (LS > 0) and (S[1] = '[') and (S[LS] = ']') then\r\n SetBlockColor(0, LS, Colors.Declaration)\r\n else\r\n begin\r\n EquPos := Pos(WideString('='), S);\r\n if EquPos > 0 then\r\n begin\r\n SetBlockColor(0, EquPos, Colors.Identifier);\r\n SetBlockColor(EquPos, EquPos, Colors.Symbol);\r\n SetBlockColor(EquPos + 1, LS, Colors.Strings);\r\n end;\r\n end;\r\n end;\r\n\r\n // for Coco/R\r\n\r\n procedure HighlightGrammarName(S: WideString);\r\n var\r\n P: Integer;\r\n begin\r\n P := Pos(WideString('-->Grammar<--'), S);\r\n if P > 0 then\r\n SetBlockColor(P, P + Length('-->Grammar<--') - 1, Colors.Preproc);\r\n end;\r\n\r\n// (rom) const, var, local function sequence not cleaned up yet\r\nvar\r\n F: Boolean;\r\n C: TJvSymbolColor;\r\n Reserved: Boolean;\r\n PrevToken: WideString;\r\n PrevToken2: WideString;\r\n NextToken: WideString;\r\n Ch: WideChar;\r\n InTag: Boolean;\r\n N: Integer;\r\n\r\nvar\r\n S: WideString;\r\n LS: Integer;\r\n Token: WideString;\r\n I: Integer;\r\n\r\nbegin\r\n if not FSyntaxHighlighting then\r\n Exit;\r\n S := Lines[Line];\r\n if (FHighlighter = hlNone) and not UserReservedWords then\r\n C := Colors.PlainText\r\n else\r\n begin\r\n FLine := S;\r\n FLineNum := Line;\r\n CheckInLong;\r\n\r\n if (FHighlighter = hlSyntaxHighlighter) and (FSyntaxHighlighter <> nil) then\r\n begin\r\n // user defined syntax highlighting\r\n FSyntaxHighlighter.GetAttr(Self, Lines, Line, ColBeg, ColEnd, FLong, LineAttrs);\r\n Exit;\r\n end;\r\n\r\n Parser.pcProgram := PWideChar(S);\r\n Parser.pcPos := Parser.pcProgram;\r\n\r\n LS := Length(S);\r\n Ch := GetTrimChar(S, 1);\r\n if (Highlighter in [hlCBuilder, hlNQC]) and (LS > 0) and\r\n (((Ch = '#') and (FLong = 0)) or (FLong = lgPreproc)) then\r\n C := Colors.Preproc\r\n else\r\n if ((FHighlighter in [hlPython, hlPerl]) and (LS > 0) and\r\n (Ch = '#') and (FLong = 0)) or\r\n ((Highlighter = hlIni) and (LS > 0) and ((Ch = '#') or (Ch = ';'))) then\r\n C := Colors.Comment\r\n else\r\n C := Colors.PlainText;\r\n if (FLong <> 0) {(FHighlighter <> hlHtml)} then\r\n begin\r\n Parser.pcPos := Parser.pcProgram + FindLongEnd + 1;\r\n if Parser.pcPos > Parser.pcProgram + Length(S) then\r\n Parser.pcPos := Parser.pcProgram + Length(S); // => #0\r\n case Highlighter of\r\n hlCBuilder, hlPython, hlPerl, hlNQC, hlCSharp:\r\n case FLong of\r\n lgString:\r\n C := Colors.Strings;\r\n lgComment1, lgComment2:\r\n C := Colors.Comment;\r\n lgPreproc:\r\n C := Colors.Preproc;\r\n end;\r\n hlPascal:\r\n case FLong of\r\n lgComment1, lgComment2:\r\n C := Colors.Comment;\r\n lgPreproc1, lgPreproc2:\r\n C := Colors.Preproc;\r\n end;\r\n else\r\n C := Colors.Comment;\r\n end;\r\n end;\r\n end;\r\n\r\n LineAttrs[1].FC := C.ForeColor;\r\n LineAttrs[1].Style := C.Style;\r\n LineAttrs[1].BC := C.BackColor;\r\n LineAttrs[1].Border := clNone;\r\n N := Min(Max_X, Length(S));\r\n for I := 2 to N do\r\n Move(LineAttrs[1], LineAttrs[I], SizeOf(LineAttrs[1]));\r\n if Length(S) < Max_X then\r\n begin\r\n LineAttrs[N + 1].FC := Font.Color;\r\n LineAttrs[N + 1].Style := Font.Style;\r\n LineAttrs[N + 1].BC := Color;\r\n LineAttrs[N + 1].Border := clNone;\r\n for I := N + 1 + 1 to Max_X do\r\n Move(LineAttrs[N + 1], LineAttrs[I], SizeOf(LineAttrs[1]));\r\n end;\r\n\r\n if (FHighlighter = hlNone) and not UserReservedWords then\r\n Exit;\r\n if (Length(S) > 0) then\r\n begin\r\n Ch := GetTrimChar(S, 1);\r\n if ((Ch = '#') and (FHighlighter in [hlCBuilder, hlPython, hlPerl, hlNQC])) or\r\n (((Ch = '#') or (Ch = ';')) and (FHighlighter = hlIni)) then\r\n Exit;\r\n end;\r\n\r\n if FHighlighter = hlIni then\r\n SetIniColors(S)\r\n else\r\n try\r\n InTag := FLong = lgTag;\r\n PrevToken := '';\r\n PrevToken2 := '';\r\n Token := Parser.Token;\r\n while Token <> '' do\r\n begin\r\n F := True;\r\n if GetReservedWord(Token, Reserved) then\r\n begin\r\n if Reserved then\r\n SetColor(Colors.Reserved)\r\n else\r\n F := False;\r\n end\r\n else\r\n case FHighlighter of\r\n hlPascal:\r\n if IsDelphiKeyWord(Token) then\r\n SetColor(Colors.Reserved)\r\n else\r\n F := False;\r\n hlCBuilder:\r\n if IsBuilderKeyWord(Token) then\r\n SetColor(Colors.Reserved)\r\n else\r\n F := False;\r\n hlNQC:\r\n if IsNQCKeyWord(Token) then\r\n SetColor(Colors.Reserved)\r\n else\r\n F := False;\r\n hlSql:\r\n if IsSQLKeyWord(Token) then\r\n SetColor(Colors.Reserved)\r\n else\r\n F := False;\r\n hlPython:\r\n if IsPythonKeyWord(Token) then\r\n SetColor(Colors.Reserved)\r\n else\r\n if Token = 'None' then\r\n SetColor(Colors.Number)\r\n else\r\n if (PrevToken = 'def') or (PrevToken = 'class') then\r\n SetColor(Colors.Declaration)\r\n else\r\n if (NextSymbol = '(') and IsIdentifierW(Token) then\r\n SetColor(Colors.FunctionCall)\r\n else\r\n F := False;\r\n hlJava:\r\n if IsJavaKeyWord(Token) then\r\n SetColor(Colors.Reserved)\r\n else\r\n if PrevToken = 'function' then\r\n SetColor(Colors.Declaration)\r\n else\r\n F := False;\r\n hlVB:\r\n if IsVBKeyWord(Token) then\r\n SetColor(Colors.Reserved)\r\n else\r\n if IsVBStatement(Token) then\r\n SetColor(Colors.Statement)\r\n else\r\n if SameText(PrevToken, 'function') or SameText(PrevToken, 'sub') or\r\n SameText(PrevToken, 'class') then\r\n SetColor(Colors.Declaration)\r\n else\r\n F := False;\r\n hlHtml:\r\n if not InTag then\r\n begin\r\n { Check for the comment starting\r\n with ' then\r\n begin\r\n InTag := False;\r\n SetColor(Colors.Reserved);\r\n F := False;\r\n end\r\n else\r\n if Token = '>' then\r\n begin\r\n InTag := False;\r\n SetColor(Colors.Reserved)\r\n end\r\n else\r\n if (Token = '/') and (PrevToken = '<') then\r\n SetColor(Colors.Reserved)\r\n else\r\n if (NextSymbol = '=') and IsIdentifierW(Token) then\r\n SetColor(Colors.Identifier)\r\n else\r\n if PrevToken = '=' then\r\n SetColor(Colors.Strings)\r\n else\r\n if IsHtmlTag(Token) then\r\n SetColor(Colors.Reserved)\r\n else\r\n if (PrevToken = '<') or ((PrevToken = '/') and (PrevToken2 = '<')) then\r\n SetColor(Colors.Statement)\r\n else\r\n F := False;\r\n end;\r\n hlPerl:\r\n if IsPerlKeyWord(Token) then\r\n SetColor(Colors.Reserved)\r\n else\r\n if IsPerlStatement(Token) then\r\n SetColor(Colors.Statement)\r\n else\r\n if CharInSetW(Token[1], ['$', '@', '%', '&']) then\r\n SetColor(Colors.FunctionCall)\r\n else\r\n F := False;\r\n hlCocoR:\r\n if IsCocoKeyWord(Token) then\r\n SetColor(Colors.Reserved)\r\n else\r\n if (Parser.PosBeg[0] = 0) and (Line > ProductionsLine) and\r\n IsIdentifierW(Token) then\r\n begin\r\n NextToken := Parser.Token;\r\n Parser.RollBack(1);\r\n SetColor(Colors.Declaration)\r\n end\r\n else\r\n F := False;\r\n hlPhp:\r\n if IsPhpKeyWord(Token) then\r\n SetColor(Colors.Reserved)\r\n else\r\n F := False;\r\n hlCSharp:\r\n if IsCSharpKeyWord(Token) then\r\n SetColor(Colors.Reserved)\r\n else\r\n F := False;\r\n else\r\n F := False;\r\n end;\r\n if F then\r\n {Ok}\r\n else\r\n if IsPreproc(Token) then\r\n SetColor(Colors.Preproc)\r\n else\r\n if IsComment(Token) then\r\n SetColor(Colors.Comment)\r\n else\r\n if IsStringConstant(Token) then\r\n SetColor(Colors.Strings)\r\n else\r\n if (Length(Token) = 1) and CharInSetW(Token[1], Symbols) then\r\n SetColor(Colors.Symbol)\r\n else\r\n if IsIntConstantW(Token) or IsRealConstantW(Token) then\r\n SetColor(Colors.Number)\r\n else\r\n if (FHighlighter in [hlCBuilder, hlJava, hlPython, hlPhp, hlNQC, hlCSharp]) and\r\n (PrevToken = '0') and ((Token[1] = 'x') or (Token[1] = 'X')) then\r\n SetColor(Colors.Number)\r\n else\r\n if FHighlighter = hlHtml then\r\n SetColor(Colors.PlainText)\r\n else\r\n SetColor(Colors.Identifier);\r\n if FHighlighter = hlHtml then\r\n { found special chars starting with '&' and ending with ';' }\r\n TestHtmlSpecChars(Token);\r\n PrevToken2 := PrevToken;\r\n PrevToken := Token;\r\n Token := Parser.Token;\r\n end;\r\n\r\n if Highlighter = hlCocoR then\r\n HighlightGrammarName(S);\r\n except\r\n end;\r\nend;\r\n\r\nprocedure TJvWideHLEditor.CheckInLong;\r\nbegin\r\n if not FLongTokens then\r\n begin\r\n FLong := lgNone;\r\n Exit;\r\n end;\r\n if FLineNum < Length(FLongDesc) then\r\n begin\r\n FLong := FLongDesc[FLineNum];\r\n if FLong = lgUndefined then\r\n begin\r\n RescanLong(FLineNum); // scan the line\r\n FLong := FLongDesc[FLineNum];\r\n end;\r\n end\r\n else\r\n RescanLong(-1);\r\nend;\r\n\r\nfunction TJvWideHLEditor.RescanLong(iLine: Integer): Boolean;\r\nconst\r\n MaxScanLinesAtOnce = 5000;\r\nvar\r\n P, F: PWideChar;\r\n MaxLine, MaxScanLine: Integer;\r\n S: WideString;\r\n I, i1, L1: Integer;\r\nbegin\r\n FLong := lgNone;\r\n Result := False; // no Invalidate\r\n\r\n if (not FSyntaxHighlighting) or\r\n (not FLongTokens or (FHighlighter in [hlNone, hlIni])) or\r\n (Lines.Count = 0) then\r\n Exit;\r\n if Lines.Count >= Length(FLongDesc) then\r\n SetLength(FLongDesc, (Lines.Count div (64*1024) + 1) * (64*1024));\r\n\r\n ProductionsLine := High(Integer);\r\n MaxLine := Lines.Count - 1;\r\n if MaxLine > High(FLongDesc) then\r\n MaxLine := High(FLongDesc);\r\n if iLine > MaxLine then\r\n Exit;\r\n\r\n MaxScanLine := MaxLine;\r\n FLong := lgNone;\r\n if iLine < 0 then\r\n begin\r\n FillChar(FLongDesc[0], SizeOf(FLongDesc[0]) * (1 + MaxLine), lgUndefined);\r\n FLongDesc[0] := lgNone;\r\n iLine := 0;\r\n end\r\n else\r\n begin\r\n FLong := FLongDesc[iLine];\r\n if FLong = lgUndefined then\r\n begin\r\n if (iLine > 0) and (FLongDesc[iLine - 1] = lgUndefined) then\r\n begin\r\n iLine := 0; // scan all\r\n FLong := lgNone;\r\n end\r\n else\r\n begin\r\n Dec(iLine);\r\n FLong := FLongDesc[iLine];\r\n MaxScanLine := Min(iLine + MaxScanLinesAtOnce, MaxLine);\r\n end;\r\n end\r\n else\r\n MaxScanLine := Min(iLine + MaxScanLinesAtOnce, MaxLine);\r\n end;\r\n\r\n while iLine < MaxScanLine do\r\n begin\r\n if (FHighlighter = hlSyntaxHighlighter) and (FSyntaxHighlighter <> nil) then\r\n FSyntaxHighlighter.ScanLongTokens(Self, Lines, iLine, FLong)\r\n else\r\n begin\r\n S := Lines[iLine];\r\n P := Pointer(S);\r\n F := P;\r\n L1 := Length(S);\r\n if (L1 = 0) then\r\n begin\r\n case Highlighter of\r\n hlPascal:\r\n if FLong in [lgString] then\r\n FLong := lgNone;\r\n hlCBuilder, hlPython, hlPerl, hlNQC:\r\n if FLong in [lgPreproc] then\r\n FLong := lgNone;\r\n else\r\n if FLong in [lgPreproc1, lgPreproc2, lgString] then\r\n FLong := lgNone;\r\n end;\r\n end;\r\n I := 1;\r\n while I <= L1 do\r\n begin\r\n case FHighlighter of\r\n hlPascal:\r\n case FLong of\r\n lgNone: // not in comment\r\n case S[I] of\r\n '/':\r\n begin\r\n if S[I + 1] = '/' then\r\n Break;\r\n end;\r\n '{':\r\n begin\r\n P := StrScanW(F + I, WideChar('}'));\r\n if P = nil then\r\n begin\r\n if S[I + 1] = '$' then\r\n FLong := lgPreproc1\r\n else\r\n FLong := lgComment1;\r\n Break;\r\n end\r\n else\r\n I := P - F + 1;\r\n end;\r\n '(':\r\n if {S[I + 1]} F[I] = '*' then\r\n begin\r\n if {S[I + 2]} F[I + 1] = '$' then\r\n FLong := lgPreproc2\r\n else\r\n FLong := lgComment2;\r\n P := StrScanW(F + I + 2, WideChar(')'));\r\n if P = nil then\r\n Break\r\n else\r\n begin\r\n if P[-1] = '*' then\r\n FLong := lgNone;\r\n I := P - F + 1;\r\n end;\r\n end;\r\n '''':\r\n begin\r\n P := StrScanW(F + I + 1, WideChar(''''));\r\n if P <> nil then\r\n begin\r\n i1 := P - F;\r\n if P[1] <> '''' then\r\n I := i1\r\n else\r\n { ?? }\r\n end\r\n else\r\n I := L1 + 1;\r\n end;\r\n end;\r\n lgPreproc1, lgComment1:\r\n begin // {\r\n P := StrScanW(F + I - 1, WideChar('}'));\r\n if P <> nil then\r\n begin\r\n FLong := lgNone;\r\n I := P - F + 1;\r\n end\r\n else\r\n I := L1 + 1;\r\n end;\r\n lgPreproc2, lgComment2:\r\n begin // (*\r\n P := StrScanW(F + I, WideChar(')'));\r\n if P = nil then\r\n Break\r\n else\r\n begin\r\n if P[-1] = '*' then\r\n FLong := lgNone;\r\n I := P - F + 1;\r\n end;\r\n end;\r\n end;\r\n hlCBuilder, hlSql, hlJava, hlPhp, hlNQC:\r\n case FLong of\r\n lgNone: // not in comment\r\n case S[I] of\r\n '/':\r\n if {S[I + 1]} F[I] = '*' then\r\n begin\r\n FLong := lgComment2;\r\n P := StrScanW(F + I + 2, WideChar('/'));\r\n if P = nil then\r\n Break\r\n else\r\n begin\r\n if P[-1] = '*' then\r\n FLong := lgNone;\r\n I := P - F + 1;\r\n end;\r\n end;\r\n '\"':\r\n begin\r\n P := StrScanW(F + I + 1, WideChar('\"'));\r\n if P <> nil then\r\n begin\r\n i1 := P - F;\r\n if P[1] <> '\"' then\r\n I := i1\r\n else\r\n { ?? }\r\n end\r\n else\r\n if FHighlighter in [hlCBuilder, hlJava, hlNQC] then\r\n begin\r\n if (LastNonSpaceChar(S) = '\\') and (HasStringOpenEnd(Lines, iLine)) then\r\n FLong := lgString;\r\n I := L1 + 1;\r\n end\r\n else\r\n I := L1 + 1;\r\n end;\r\n '#':\r\n begin\r\n if (GetTrimChar(S, 1) = '#') and (LastNonSpaceChar(S) = '\\') then\r\n begin\r\n FLong := lgPreproc;\r\n Break;\r\n end;\r\n end;\r\n end;\r\n lgComment2:\r\n begin // /*\r\n P := StrScanW(F + I, WideChar('/'));\r\n if P = nil then\r\n Break\r\n else\r\n begin\r\n if P[-1] = '*' then\r\n FLong := lgNone;\r\n I := P - F + 1;\r\n end;\r\n end;\r\n lgString:\r\n begin\r\n P := StrScanW(F + I + 1, WideChar('\"'));\r\n if P <> nil then\r\n begin\r\n i1 := P - F;\r\n if P[1] <> '\"' then\r\n I := i1\r\n else\r\n { ?? }\r\n end\r\n else\r\n begin\r\n if FHighlighter in [hlCBuilder, hlJava, hlNQC] then\r\n begin\r\n if (LastNonSpaceChar(S) <> '\\') or (not HasStringOpenEnd(Lines, iLine)) then\r\n FLong := lgNone;\r\n end;\r\n I := L1 + 1;\r\n end;\r\n end;\r\n lgPreproc:\r\n begin\r\n if LastNonSpaceChar(S) <> '\\' then\r\n FLong := lgNone;\r\n end;\r\n end;\r\n hlPython, hlPerl:\r\n case FLong of\r\n lgNone: // not in comment\r\n case S[I] of\r\n '#':\r\n I := L1;\r\n '\"':\r\n begin\r\n P := StrScanW(F + I, WideChar('\"'));\r\n if P = nil then\r\n begin\r\n FLong := lgString;\r\n Break;\r\n end\r\n else\r\n I := P - F + 1;\r\n end;\r\n end;\r\n lgString: // python and perl long string\r\n begin\r\n P := StrScanW(F + I - 1, WideChar('\"'));\r\n if P <> nil then\r\n begin\r\n FLong := lgNone;\r\n I := P - F + 1;\r\n end\r\n else\r\n I := L1 + 1;\r\n end;\r\n end;\r\n hlHtml:\r\n case FLong of\r\n lgNone: // not in comment\r\n case S[I] of\r\n '<':\r\n begin\r\n P := StrScanW(F + I, WideChar('>'));\r\n if P = nil then\r\n begin\r\n // Multiline comments in HTML\r\n if S[2] = '!' then\r\n FLong := lgComment1\r\n else\r\n FLong := lgTag;\r\n\r\n Break;\r\n end\r\n else\r\n I := P - F + 1;\r\n end;\r\n end;\r\n // Multiline comments in HTML\r\n lgComment1:\r\n begin\r\n P := StrScanW(F + I - 1, WideChar('>'));\r\n if P = nil then\r\n Break\r\n else\r\n if (P[-2] = '-') and (P[-1] = '-') then\r\n FLong := lgNone;\r\n I := P - F + 1;\r\n end;\r\n lgTag: // html tag\r\n begin\r\n P := StrScanW(F + I - 1, WideChar('>'));\r\n if P <> nil then\r\n begin\r\n FLong := lgNone;\r\n I := P - F + 1;\r\n end\r\n else\r\n I := L1 + 1;\r\n end;\r\n end;\r\n hlCocoR:\r\n case FLong of\r\n lgNone: // not in comment\r\n case S[I] of\r\n '(':\r\n if {S[I + 1]} F[I] = '*' then\r\n begin\r\n FLong := lgComment2;\r\n P := StrScanW(F + I + 2, WideChar(')'));\r\n if P = nil then\r\n Break\r\n else\r\n begin\r\n if P[-1] = '*' then\r\n FLong := lgNone;\r\n I := P - F + 1;\r\n end;\r\n end;\r\n '\"':\r\n begin\r\n P := StrScanW(F + I + 1, WideChar('\"'));\r\n if P <> nil then\r\n begin\r\n i1 := P - F;\r\n if P[1] <> '\"' then\r\n I := i1\r\n else\r\n { ?? }\r\n end\r\n else\r\n I := L1 + 1;\r\n end;\r\n '''':\r\n begin\r\n P := StrScanW(F + I + 1, WideChar(''''));\r\n if P <> nil then\r\n begin\r\n i1 := P - F;\r\n if P[1] <> '''' then\r\n I := i1\r\n else\r\n { ?? }\r\n end\r\n else\r\n I := L1 + 1;\r\n end;\r\n '/':\r\n if {S[I + 1]} F[I] = '*' then\r\n begin\r\n FLong := lgComment2;\r\n P := StrScanW(F + I + 2, WideChar('/'));\r\n if P = nil then\r\n Break\r\n else\r\n begin\r\n if P[-1] = '*' then\r\n FLong := lgNone;\r\n I := P - F + 1;\r\n end;\r\n end;\r\n end;\r\n lgComment2:\r\n begin // (*\r\n P := StrScanW(F + I, WideChar(')'));\r\n if P = nil then\r\n Break\r\n else\r\n begin\r\n if P[-1] = '*' then\r\n FLong := lgNone;\r\n I := P - F + 1;\r\n end;\r\n end;\r\n end;\r\n end;\r\n Inc(I);\r\n end;\r\n\r\n if (FHighlighter = hlCocoR) and\r\n (StrLICompW2(PWideChar(S), 'productions', Length('productions')) = 0) then\r\n begin\r\n ProductionsLine := iLine;\r\n end;\r\n end;\r\n\r\n Inc(iLine);\r\n if FLongDesc[iLine] <> FLong then\r\n begin\r\n FLongDesc[iLine] := FLong;\r\n Result := True; // Invalidate\r\n end;\r\n end;\r\n // undefine following lines\r\n if MaxScanLine < MaxLine then\r\n FillChar(FLongDesc[MaxScanLine + 1], SizeOf(FLongDesc[0]) * (MaxLine - MaxScanLine), lgUndefined);\r\nend;\r\n\r\nfunction TJvWideHLEditor.FindLongEnd: Integer;\r\nvar\r\n P, F: PWideChar;\r\n I: Integer;\r\nbegin\r\n P := PWideChar(FLine);\r\n Result := Length(FLine);\r\n case FHighlighter of\r\n hlPascal:\r\n case FLong of\r\n lgPreproc1, lgComment1:\r\n begin\r\n P := StrScanW(P, WideChar('}'));\r\n if P <> nil then\r\n Result := P - PWideChar(FLine);\r\n end;\r\n lgPreproc2, lgComment2:\r\n begin\r\n F := P;\r\n while True do\r\n begin\r\n F := StrScanW(F, WideChar('*'));\r\n if F = nil then\r\n Exit;\r\n if F[1] = ')' then\r\n Break;\r\n Inc(F);\r\n end;\r\n P := F + 1;\r\n Result := P - PWideChar(FLine);\r\n end;\r\n end;\r\n hlCBuilder, hlSql, hlJava, hlPhp, hlNQC:\r\n begin\r\n case FLong of\r\n lgComment2:\r\n begin\r\n F := P;\r\n while True do\r\n begin\r\n F := StrScanW(F, WideChar('*'));\r\n if F = nil then\r\n Exit;\r\n if F[1] = '/' then\r\n Break;\r\n Inc(F);\r\n end;\r\n P := F + 1;\r\n Result := P - PWideChar(FLine);\r\n end;\r\n lgString:\r\n begin\r\n F := P;\r\n repeat\r\n P := StrScanW(P, WideChar('\"'));\r\n if P <> nil then\r\n begin\r\n if (P = F) or (P[-1] <> '\\') then\r\n begin\r\n Result := P - F;\r\n Break;\r\n end\r\n else\r\n begin\r\n // count the backslashes\r\n I := 1;\r\n while (P - 1 - I > F) and (P[-1 - I] = '\\') do\r\n Inc(I);\r\n if I and $01 = 0 then {faster than: if I mod 2 = 0 then}\r\n begin\r\n Result := P - F;\r\n Break;\r\n end;\r\n end;\r\n Inc(P);\r\n end;\r\n until P = nil;\r\n end;\r\n end; // case\r\n end;\r\n hlPython, hlPerl:\r\n case FLong of\r\n lgString:\r\n begin\r\n P := StrScanW(P, WideChar('\"'));\r\n if P <> nil then\r\n Result := P - PWideChar(FLine);\r\n end;\r\n end;\r\n hlHtml:\r\n case FLong of\r\n // HTML multiline comments\r\n lgComment1:\r\n begin\r\n P := StrScanW(P, WideChar('>'));\r\n if P <> nil then\r\n // check if the previous characters are\r\n // --\r\n if (P[-1] = '-') and (P[-2] = '-') then\r\n Result := P - PWideChar(FLine);\r\n end;\r\n lgTag:\r\n begin\r\n P := StrScanW(P, WideChar('>'));\r\n if P <> nil then\r\n Result := P - PWideChar(FLine);\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvWideHLEditor.TextModified(ACaretX, ACaretY: Integer; Action: TModifiedAction;\r\n const Text: WideString);\r\nvar\r\n S: WideString;\r\n L: Integer;\r\n{ LP, I: Integer;\r\n P: PChar;\r\n OldProductionsLine: Integer; }\r\nbegin\r\n if not FLongTokens then\r\n Exit;\r\n case FHighlighter of\r\n hlPascal:\r\n S := #13'{}*()/ ';\r\n hlCBuilder, hlJava, hlSql, hlPhp, hlNQC:\r\n S := #13'*/\\ ';\r\n hlVB:\r\n S := #13'''';\r\n hlPython, hlPerl:\r\n S := #13'#\"';\r\n hlHtml:\r\n S := #13'<>';\r\n hlCocoR:\r\n S := #13'*()/ ';\r\n hlSyntaxHighlighter:\r\n if FSyntaxHighlighter <> nil then\r\n begin\r\n if FSyntaxHighlighter.GetRescanLongKeys(Self, Action, ACaretX, ACaretY, Text) then\r\n begin\r\n if RescanLong(ACaretY) then\r\n Invalidate;\r\n end;\r\n Exit;\r\n end\r\n else\r\n S := #13;\r\n else\r\n S := #13; { unknown Highlighter ? }\r\n end;\r\n\r\n if Action = maAll then\r\n ACaretY := -1; // rescan all lines\r\n\r\n if (Action in [maAll, maReplace]) or HasAnyChar(S, Text) then\r\n begin\r\n if RescanLong(ACaretY) then\r\n Invalidate;\r\n end\r\n else\r\n begin\r\n if (Highlighter = hlPascal) and (Cardinal(ACaretY) < Cardinal(Length(FLongDesc))) then\r\n begin\r\n // comment <-> preproc\r\n S := Lines[ACaretY];\r\n L := Length(S);\r\n // [Backspace, \"insert\"]\r\n if ((ACaretX > 1) and (ACaretX <= L + 1) and (S[ACaretX - 1] = '{')) or\r\n ((ACaretX > 2) and (ACaretX <= L + 2) and (S[ACaretX - 2] = '(') and (S[ACaretX - 1] = '*')) or\r\n // [Delete]\r\n ((ACaretX > 0) and (ACaretX <= L) and (S[ACaretX] = '{')) or\r\n ((ACaretX > 1) and (ACaretX <= L + 1) and (S[ACaretX - 1] = '(') and (S[ACaretX] = '*')) then\r\n begin\r\n if RescanLong(ACaretY) then\r\n Invalidate;\r\n end;\r\n end;\r\n end;\r\n {\r\n if (FHighlighter = hlCocoR) and (HasAnyChar('productions'#13, Text)) then\r\n begin\r\n LP := Length('productions');\r\n OldProductionsLine := ProductionsLine;\r\n ProductionsLine := High(Integer);\r\n for I := 0 to Lines.Count - 1 do\r\n begin\r\n P := PWideChar(Lines[I]);\r\n if (StrLICompW2(P, 'productions', LP) = 0) and\r\n ((Length(P) = LP) or (P[LP] = ' ')) then\r\n begin\r\n ProductionsLine := I;\r\n Break;\r\n end;\r\n end;\r\n if ProductionsLine <> OldProductionsLine then\r\n Invalidate;\r\n end; }\r\nend;\r\n\r\nfunction TJvWideHLEditor.GetReservedWord(const Token: WideString;\r\n var Reserved: Boolean): Boolean;\r\nbegin\r\n Result := Assigned(FOnReservedWord);\r\n if Result then\r\n begin\r\n Reserved := False;\r\n FOnReservedWord(Self, Token, Reserved);\r\n end\r\nend;\r\n\r\nfunction TJvWideHLEditor.UserReservedWords: Boolean;\r\nbegin\r\n Result := Assigned(FOnReservedWord);\r\nend;\r\n\r\nprocedure TJvWideHLEditor.Assign(Source: TPersistent);\r\nbegin\r\n inherited Assign(Source);\r\n if Source is TJvWideHLEditor then\r\n begin\r\n FHighlighter := TJvWideHLEditor(Source).Highlighter;\r\n Colors.Assign(TJvWideHLEditor(Source).Colors);\r\n //FSyntaxHighlighting := TJvWideHLEditor(Source).SyntaxHighlighting;\r\n Invalidate;\r\n end\r\n else\r\n if Source is TJvHLEditor then\r\n begin\r\n FHighlighter := TJvHLEditor(Source).Highlighter;\r\n Colors.Assign(TJvHLEditor(Source).Colors);\r\n //FSyntaxHighlighting := TJvHLEditor(Source).SyntaxHighlighting;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvWideHLEditor.AssignTo(Source: TPersistent);\r\nbegin\r\n if Source is TJvHLEditor then\r\n begin\r\n TJvHLEditor(Source).BeginUpdate;\r\n try\r\n TJvHLEditor(Source).Assign(TJvCustomEditorBase(Self));\r\n\r\n TJvHLEditor(Source).Highlighter := Highlighter;\r\n TJvHLEditor(Source).Colors.Assign(Colors);\r\n TJvHLEditor(Source).SyntaxHighlighting := SyntaxHighlighting;\r\n finally\r\n TJvHLEditor(Source).EndUpdate;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJvWideHLEditor.GetDelphiColors: Boolean;\r\n function CompareColor(Symbol: TJvSymbolColor; const DelphiColor: TDelphiColor): Boolean;\r\n begin\r\n Result :=\r\n (Symbol.ForeColor = DelphiColor.ForeColor) and\r\n (Symbol.BackColor = DelphiColor.BackColor) and\r\n (Symbol.Style = DelphiColor.Style);\r\n end;\r\nbegin\r\n Result := False;\r\n if not CompareColor(Colors.Comment, DelphiColor_Comment) then\r\n Exit;\r\n if not CompareColor(Colors.Preproc, DelphiColor_Preproc) then\r\n Exit;\r\n if not CompareColor(Colors.Number, DelphiColor_Number) then\r\n Exit;\r\n if not CompareColor(Colors.Strings, DelphiColor_Strings) then\r\n Exit;\r\n if not CompareColor(Colors.Symbol, DelphiColor_Symbol) then\r\n Exit;\r\n if not CompareColor(Colors.Reserved, DelphiColor_Reserved) then\r\n Exit;\r\n if not CompareColor(Colors.Identifier, DelphiColor_Identifier) then\r\n Exit;\r\n if not CompareColor(Colors.PlainText, DelphiColor_PlainText) then\r\n Exit;\r\n Result := True;\r\nend;\r\n\r\nprocedure TJvWideHLEditor.SetDelphiColors(Value: Boolean);\r\n\r\n procedure SetColor(Symbol: TJvSymbolColor; const DelphiColor: TDelphiColor);\r\n begin\r\n with DelphiColor do\r\n Symbol.SetColor(ForeColor, BackColor, Style);\r\n end;\r\n\r\nbegin\r\n if Value then\r\n begin\r\n SetColor(Colors.Comment, DelphiColor_Comment);\r\n SetColor(Colors.Preproc, DelphiColor_Preproc);\r\n SetColor(Colors.Number, DelphiColor_Number);\r\n SetColor(Colors.Strings, DelphiColor_Strings);\r\n SetColor(Colors.Symbol, DelphiColor_Symbol);\r\n SetColor(Colors.Reserved, DelphiColor_Reserved);\r\n SetColor(Colors.Identifier, DelphiColor_Identifier);\r\n SetColor(Colors.PlainText, DelphiColor_PlainText);\r\n end;\r\nend;\r\n\r\nprocedure TJvWideHLEditor.SetSyntaxHighlighter(const Value: TJvWideEditorHighlighter);\r\nbegin\r\n if Value <> FSyntaxHighlighter then\r\n begin\r\n if Value <> nil then\r\n FHighlighter := hlSyntaxHighlighter\r\n else\r\n if FHighlighter = hlSyntaxHighlighter then\r\n FHighlighter := hlNone;\r\n\r\n ReplaceComponentReference(Self, Value, TComponent(FSyntaxHighlighter));\r\n RescanLong(0);\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nfunction TJvWideHLEditor.GetColors: TJvColors;\r\nbegin\r\n Result := FColors;\r\nend;\r\n\r\nprocedure TJvWideHLEditor.SetColors(const Value: TJvColors);\r\nbegin\r\n FColors.Assign(Value);\r\nend;\r\n\r\nfunction TJvWideHLEditor.GetSyntaxHighlighting: Boolean;\r\nbegin\r\n Result := FSyntaxHighlighting;\r\nend;\r\n\r\nprocedure TJvWideHLEditor.SetSyntaxHighlighting(Value: Boolean);\r\nbegin\r\n FSyntaxHighlighting := Value;\r\n Invalidate;\r\nend;\r\n\r\nfunction TJvWideHLEditor.GetHighlighter: TJvHighlighter;\r\nbegin\r\n Result := FHighlighter;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvUninstallControls.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvUninstallControls.PAS, released on 2002-05-26.\r\n\r\nThe Initial Developer of the Original Code is Peter Thrnqvist [peter3 at sourceforge dot net]\r\nPortions created by Peter Thrnqvist are Copyright (C) 2002 Peter Thrnqvist.\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvUninstallControls.pas 13138 2011-10-26 23:17:50Z jfudickar $\r\n\r\nunit JvUninstallControls;\r\n\r\n{$I jvcl.inc}\r\n{$I windowsonly.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, SysUtils, Classes, Graphics, Controls, StdCtrls;\r\n\r\ntype\r\n TJvUCBDisplayMode = (hkCurrentUser, hkLocalMachine); // subset of TJvRegKey\r\n TJvUCBDisplayModes = set of TJvUCBDisplayMode;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvUninstallComboBox = class(TCustomComboBox)\r\n private\r\n FDisplayMode: TJvUCBDisplayModes;\r\n FShowAll: Boolean;\r\n FShowEmptyValues: Boolean;\r\n function GetItems: TStrings;\r\n function GetDisplayName: string;\r\n function GetSection: string;\r\n function GetUninstallString: string;\r\n procedure SetShowAll(const Value: Boolean);\r\n procedure SetShowEmptyValues(const Value: Boolean);\r\n procedure SetDisplayMode(const Value: TJvUCBDisplayModes);\r\n procedure Rebuild;\r\n function GetProperties: TStrings;\r\n function GetHKey: HKEY;\r\n function GetHKeyName: string;\r\n procedure SetSorted(const Value: Boolean);\r\n protected\r\n procedure CreateHandle; override;\r\n public\r\n constructor Create(AComponent: TComponent); override;\r\n destructor Destroy; override;\r\n procedure Clear; override;\r\n procedure RefreshItem;\r\n property Items: TStrings read GetItems;\r\n property Section: string read GetSection;\r\n property HKey: HKEY read GetHKey;\r\n property HKeyName: string read GetHKeyName;\r\n property UninstallString: string read GetUninstallString;\r\n property DisplayName: string read GetDisplayName;\r\n property Properties: TStrings read GetProperties;\r\n published\r\n property DisplayMode: TJvUCBDisplayModes read FDisplayMode write SetDisplayMode default [hkCurrentUser, hkLocalMachine];\r\n property ShowAll: Boolean read FShowAll write SetShowAll default False;\r\n property ShowEmptyValues: Boolean read FShowEmptyValues write SetShowEmptyValues default False;\r\n property Color;\r\n property DragCursor;\r\n property DragMode;\r\n property ImeMode;\r\n property ImeName;\r\n property BiDiMode;\r\n property ParentBiDiMode;\r\n property OnEndDock;\r\n property OnStartDock;\r\n property DragKind;\r\n property DropDownCount;\r\n property Enabled;\r\n property Font;\r\n property ItemHeight;\r\n property ParentColor;\r\n property ParentFont;\r\n property ParentShowHint;\r\n property PopupMenu;\r\n property ShowHint;\r\n property Sorted write SetSorted;\r\n property Style;\r\n property TabOrder;\r\n property TabStop;\r\n property Visible;\r\n property OnChange;\r\n property OnClick;\r\n property OnDblClick;\r\n property OnDragDrop;\r\n property OnDragOver;\r\n property OnDrawItem;\r\n property OnDropDown;\r\n property OnEndDrag;\r\n property OnEnter;\r\n property OnExit;\r\n property OnKeyDown;\r\n property OnKeyPress;\r\n property OnKeyUp;\r\n property OnMeasureItem;\r\n property OnStartDrag;\r\n property Anchors;\r\n property Constraints;\r\n end;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvUninstallListBox = class(TCustomListBox)\r\n private\r\n FShowAll: Boolean;\r\n FDisplayMode: TJvUCBDisplayModes;\r\n FShowEmptyValues: Boolean;\r\n function GetItems: TStrings;\r\n function GetDisplayName: string;\r\n function GetSection: string;\r\n function GetUninstallString: string;\r\n procedure SetShowAll(const Value: Boolean);\r\n procedure SetShowEmptyValues(const Value: Boolean);\r\n procedure SetDisplayMode(const Value: TJvUCBDisplayModes);\r\n function GetProperties: TStrings;\r\n function GetHKey: HKEY;\r\n function GetHKeyName: string;\r\n procedure SetSorted(const Value: Boolean);\r\n protected\r\n procedure CreateHandle; override;\r\n public\r\n constructor Create(AComponent: TComponent); override;\r\n destructor Destroy; override;\r\n procedure Clear; override;\r\n procedure RefreshItem;\r\n procedure Rebuild;\r\n property Items: TStrings read GetItems;\r\n property Section: string read GetSection;\r\n property UninstallString: string read GetUninstallString;\r\n property DisplayName: string read GetDisplayName;\r\n property Properties: TStrings read GetProperties;\r\n property HKey: HKEY read GetHKey;\r\n property HKeyName: string read GetHKeyName;\r\n published\r\n property Align;\r\n property DisplayMode: TJvUCBDisplayModes read FDisplayMode write SetDisplayMode default [hkCurrentUser, hkLocalMachine];\r\n property ShowAll: Boolean read FShowAll write SetShowAll default False;\r\n property ShowEmptyValues: Boolean read FShowEmptyValues write SetShowEmptyValues default False;\r\n property Color;\r\n property DragCursor;\r\n property DragMode;\r\n property ImeMode;\r\n property ImeName;\r\n property BiDiMode;\r\n property DragKind;\r\n property ParentBiDiMode;\r\n property OnEndDock;\r\n property OnStartDock;\r\n property Enabled;\r\n property Font;\r\n property ItemHeight;\r\n property ParentColor;\r\n property ParentFont;\r\n property ParentShowHint;\r\n property PopupMenu;\r\n property ShowHint;\r\n property Sorted write SetSorted;\r\n property TabOrder;\r\n property TabStop;\r\n property Visible;\r\n property OnClick;\r\n property OnDblClick;\r\n property OnDragDrop;\r\n property OnDragOver;\r\n property OnDrawItem;\r\n property OnEndDrag;\r\n property OnEnter;\r\n property OnExit;\r\n property OnKeyDown;\r\n property OnKeyPress;\r\n property OnKeyUp;\r\n property OnMeasureItem;\r\n property OnStartDrag;\r\n property Anchors;\r\n property Constraints;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvUninstallControls.pas $';\r\n Revision: '$Revision: 13138 $';\r\n Date: '$Date: 2011-10-27 01:17:50 +0200 (jeu. 27 oct. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n Math, Registry;\r\n\r\nconst\r\n cUninstallPath = 'Software\\Microsoft\\Windows\\CurrentVersion\\Uninstall';\r\n cUninstallString = 'UninstallString';\r\n cDisplayName = 'DisplayName';\r\n\r\n FKey: array [TJvUCBDisplayMode] of HKEY =\r\n (HKEY_CURRENT_USER, HKEY_LOCAL_MACHINE);\r\n\r\ntype\r\n TJvUninstallInfo = class(TObject)\r\n private\r\n FSection: string;\r\n FHKey: HKEY;\r\n FProperties: TStringList;\r\n FHKeyName: string;\r\n function GetProperties: TStrings;\r\n// procedure SetProperties(const Value: TStrings); make Delphi 5 compiler happy // andreas\r\n public\r\n destructor Destroy; override;\r\n property HKey: HKEY read FHKey write FHKey;\r\n property HKeyName: string read FHKeyName write FHKeyName;\r\n property Section: string read FSection write FSection;\r\n property Properties: TStrings read GetProperties {write SetProperties // make Delphi 5 compiler happy // andreas};\r\n end;\r\n\r\n TSafeRegIniFile = class(TRegIniFile)\r\n public\r\n function ReadString(const Section, Ident, Default: string): string;\r\n end;\r\n\r\n//=== { TJvUninstallInfo } ===================================================\r\n\r\ndestructor TJvUninstallInfo.Destroy;\r\nbegin\r\n FProperties.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJvUninstallInfo.GetProperties: TStrings;\r\nbegin\r\n if FProperties = nil then\r\n FProperties := TStringList.Create;\r\n Result := FProperties;\r\nend;\r\n\r\n{ make Delphi 5 compiler happy // andreas\r\nprocedure TJvUninstallInfo.SetProperties(const Value: TStrings);\r\nbegin\r\n if FProperties = nil then\r\n FProperties := TStringlist.Create;\r\n FProperties.Assign(Value);\r\nend;}\r\n\r\n//=== { TSafeRegIniFile } ====================================================\r\n\r\nfunction TSafeRegIniFile.ReadString(const Section, Ident, Default: string): string;\r\nvar\r\n Key, OldKey: HKEY;\r\n Len: Integer;\r\n RegData: TRegDataType;\r\n Buffer: array [0..4095] of Byte;\r\n\r\n function BufToStr(Buffer: array of Byte; BufSize: Integer): string;\r\n var\r\n I: Integer;\r\n begin\r\n Result := '';\r\n for I := 0 to Min(SizeOf(Buffer), BufSize) - 1 do\r\n Result := Result + ' ' + IntToHex(Buffer[I], 2);\r\n end;\r\n\r\n function ExpandEnvVar(const S: string): string;\r\n begin\r\n SetLength(Result, ExpandEnvironmentStrings(PChar(S), nil, 0));\r\n ExpandEnvironmentStrings(PChar(S), PChar(Result), Length(Result));\r\n end;\r\n\r\nbegin\r\n Key := GetKey(Section);\r\n if Key <> 0 then\r\n try\r\n OldKey := CurrentKey;\r\n SetCurrentKey(Key);\r\n try\r\n if ValueExists(Ident) then\r\n begin\r\n RegData := GetDataType(Ident);\r\n case RegData of\r\n rdString, rdExpandString:\r\n begin\r\n Len := GetDataSize(Ident);\r\n if Len > 0 then\r\n begin\r\n SetString(Result, nil, Len);\r\n GetData(Ident, PChar(Result), Len, RegData);\r\n SetLength(Result, StrLen(PChar(Result)));\r\n if RegData = rdExpandString then\r\n Result := ExpandEnvVar(Result);\r\n end\r\n else\r\n Result := '';\r\n end;\r\n rdInteger:\r\n begin\r\n GetData(Ident, @Len, SizeOf(Len), RegData);\r\n Result := IntToStr(Len);\r\n end;\r\n rdBinary:\r\n begin\r\n Len := GetDataSize(Ident);\r\n if Len > 0 then\r\n begin\r\n GetData(Ident, @Buffer, SizeOf(Buffer), RegData);\r\n Result := BufToStr(Buffer, Min(Len, SizeOf(Buffer)));\r\n end\r\n else\r\n Result := '';\r\n end;\r\n end;\r\n end\r\n else\r\n Result := Default;\r\n finally\r\n SetCurrentKey(OldKey);\r\n end;\r\n finally\r\n RegCloseKey(Key);\r\n end\r\n else\r\n Result := Default;\r\nend;\r\n\r\nprocedure GetUninstallApps(DisplayModes: TJvUCBDisplayModes; Strings: TStrings; ShowAll, ShowEmptyValues: Boolean);\r\nvar\r\n I: Integer;\r\n FFolders, FItems: TStringList;\r\n Tmp: string;\r\n Reg: TSafeRegIniFile;\r\n Dm: TJvUCBDisplayMode;\r\n UI: TJvUninstallInfo;\r\n\r\n function BufToStr(Buffer: array of Byte; BufSize: Integer): string;\r\n var\r\n I: Integer;\r\n begin\r\n Result := '';\r\n for I := 0 to BufSize - 1 do\r\n Result := Result + ' ' + IntToHex(Buffer[I], 2);\r\n end;\r\n\r\n function ExpandEnvVar(const S: string): string;\r\n begin\r\n SetLength(Result, ExpandEnvironmentStrings(PChar(S), nil, 0));\r\n ExpandEnvironmentStrings(PChar(S), PChar(Result), Length(Result));\r\n end;\r\n\r\n procedure ReadProperties(Reg: TSafeRegIniFile; const Section: string; ShowEmptyValues: Boolean; Items, Props: TStrings);\r\n var\r\n I: Integer;\r\n Tmp: string;\r\n begin\r\n Reg.OpenKeyReadOnly(Section);\r\n for I := 0 to Items.Count - 1 do\r\n begin\r\n Tmp := Reg.ReadString('', Items[I], '');\r\n if (Tmp <> '') or ShowEmptyValues then\r\n Props.Add(Format('%s=%s', [Items[I], Tmp]));\r\n end;\r\n Reg.CloseKey;\r\n end;\r\n\r\n function DMToStr(Dm: TJvUCBDisplayMode): string;\r\n begin\r\n case Dm of\r\n hkCurrentUser:\r\n Result := 'HKEY_CURRENT_USER';\r\n hkLocalMachine:\r\n Result := 'HKEY_LOCAL_MACHINE';\r\n end;\r\n end;\r\n\r\nbegin\r\n FFolders := TStringList.Create;\r\n FItems := TStringList.Create;\r\n Strings.BeginUpdate;\r\n Reg := TSafeRegIniFile.Create('');\r\n// FFolders.Sorted := True;\r\n with Reg do\r\n try\r\n for Dm := Low(FKey) to High(FKey) do\r\n if Dm in DisplayModes then\r\n begin\r\n RootKey := FKey[Dm];\r\n if OpenKeyReadOnly(cUninstallPath) then\r\n begin\r\n ReadSections(FFolders);\r\n for I := FFolders.Count - 1 downto 0 do\r\n begin\r\n Tmp := ReadString(FFolders[I], cDisplayName, '');\r\n if (Tmp = '') and not ShowAll then\r\n FFolders.Delete(I)\r\n else\r\n begin\r\n UI := TJvUninstallInfo.Create;\r\n if Tmp = '' then\r\n Tmp := FFolders[I];\r\n UI.HKey := RootKey;\r\n UI.HKeyName := DMToStr(Dm);\r\n UI.Section := cUninstallPath + FFolders[I];\r\n ReadSection(FFolders[I], FItems);\r\n ReadProperties(Reg, FFolders[I], ShowEmptyValues, FItems, UI.Properties);\r\n Strings.AddObject(Tmp, UI);\r\n OpenKeyReadOnly(cUninstallPath);\r\n end;\r\n end;\r\n end;\r\n end;\r\n finally\r\n Free;\r\n FFolders.Free;\r\n FItems.Free;\r\n Strings.EndUpdate;\r\n end;\r\nend;\r\n\r\n//=== { TJvUninstallComboBox } ===============================================\r\n\r\nconstructor TJvUninstallComboBox.Create(AComponent: TComponent);\r\nbegin\r\n inherited Create(AComponent);\r\n Style := csDropDownList;\r\n FDisplayMode := [hkCurrentUser, hkLocalMachine];\r\nend;\r\n\r\ndestructor TJvUninstallComboBox.Destroy;\r\nbegin\r\n Clear;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvUninstallComboBox.Rebuild;\r\nvar\r\n I: Integer;\r\nbegin\r\n if ([csLoading, csDestroying] * ComponentState) <> [] then\r\n Exit;\r\n I := ItemIndex;\r\n Clear;\r\n GetUninstallApps(DisplayMode, Items, ShowAll, ShowEmptyValues);\r\n ItemIndex := I;\r\n if (Items.Count > 0) and (ItemIndex < 0) then\r\n ItemIndex := 0;\r\nend;\r\n\r\nfunction TJvUninstallComboBox.GetDisplayName: string;\r\nbegin\r\n if ItemIndex > -1 then\r\n Result := TJvUninstallInfo(Items.Objects[ItemIndex]).Properties.Values[cDisplayName]\r\n else\r\n Result := '';\r\nend;\r\n\r\nfunction TJvUninstallComboBox.GetItems: TStrings;\r\nbegin\r\n Result := inherited Items;\r\nend;\r\n\r\nfunction TJvUninstallComboBox.GetSection: string;\r\nbegin\r\n if ItemIndex > -1 then\r\n Result := TJvUninstallInfo(Items.Objects[ItemIndex]).Section\r\n else\r\n Result := '';\r\nend;\r\n\r\nfunction TJvUninstallComboBox.GetUninstallString: string;\r\nbegin\r\n if ItemIndex > -1 then\r\n Result := TJvUninstallInfo(Items.Objects[ItemIndex]).Properties.Values[cUninstallString]\r\n else\r\n Result := '';\r\nend;\r\n\r\nprocedure TJvUninstallComboBox.SetDisplayMode(const Value: TJvUCBDisplayModes);\r\nbegin\r\n if FDisplayMode <> Value then\r\n begin\r\n FDisplayMode := Value;\r\n Rebuild;\r\n end;\r\nend;\r\n\r\nprocedure TJvUninstallComboBox.SetShowAll(const Value: Boolean);\r\nbegin\r\n if FShowAll <> Value then\r\n begin\r\n FShowAll := Value;\r\n Rebuild;\r\n end;\r\nend;\r\n\r\nprocedure TJvUninstallComboBox.SetShowEmptyValues(const Value: Boolean);\r\nbegin\r\n if FShowEmptyValues <> Value then\r\n begin\r\n FShowEmptyValues := Value;\r\n Rebuild;\r\n end;\r\nend;\r\n\r\nprocedure TJvUninstallComboBox.Clear;\r\nvar\r\n I: Integer;\r\nbegin\r\n if Parent = nil then\r\n Exit;\r\n for I := 0 to Items.Count - 1 do\r\n Items.Objects[I].Free;\r\n inherited Clear;\r\nend;\r\n\r\nprocedure TJvUninstallComboBox.CreateHandle;\r\nbegin\r\n inherited CreateHandle;\r\n if ItemIndex < 0 then\r\n Rebuild;\r\nend;\r\n\r\nfunction TJvUninstallComboBox.GetProperties: TStrings;\r\nbegin\r\n Result := nil;\r\n if ItemIndex > -1 then\r\n Result := TJvUninstallInfo(Items.Objects[ItemIndex]).Properties;\r\nend;\r\n\r\nfunction TJvUninstallComboBox.GetHKey: HKEY;\r\nbegin\r\n Result := 0;\r\n if ItemIndex > -1 then\r\n Result := TJvUninstallInfo(Items.Objects[ItemIndex]).HKey;\r\nend;\r\n\r\nfunction TJvUninstallComboBox.GetHKeyName: string;\r\nbegin\r\n Result := '';\r\n if ItemIndex > -1 then\r\n Result := TJvUninstallInfo(Items.Objects[ItemIndex]).HKeyName;\r\nend;\r\n\r\nprocedure TJvUninstallComboBox.SetSorted(const Value: Boolean);\r\nvar\r\n S: string;\r\nbegin\r\n if Value <> inherited Sorted then\r\n begin\r\n if ItemIndex > -1 then\r\n S := Items[ItemIndex]\r\n else\r\n S := '';\r\n inherited Sorted := Value;\r\n if not Value then\r\n Rebuild;\r\n if S <> '' then\r\n ItemIndex := Items.IndexOf(S);\r\n end;\r\nend;\r\n\r\n//=== { TJvUninstallListBox } ================================================\r\n\r\nconstructor TJvUninstallListBox.Create(AComponent: TComponent);\r\nbegin\r\n inherited Create(AComponent);\r\n FDisplayMode := [hkCurrentUser, hkLocalMachine];\r\nend;\r\n\r\ndestructor TJvUninstallListBox.Destroy;\r\nbegin\r\n Clear;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJvUninstallListBox.GetDisplayName: string;\r\nbegin\r\n if ItemIndex > -1 then\r\n Result := TJvUninstallInfo(Items.Objects[ItemIndex]).Properties.Values[cDisplayName]\r\n else\r\n Result := '';\r\nend;\r\n\r\nfunction TJvUninstallListBox.GetUninstallString: string;\r\nbegin\r\n if ItemIndex > -1 then\r\n Result := TJvUninstallInfo(Items.Objects[ItemIndex]).Properties.Values[cUninstallString]\r\n else\r\n Result := '';\r\nend;\r\n\r\nfunction TJvUninstallListBox.GetItems: TStrings;\r\nbegin\r\n Result := inherited Items;\r\nend;\r\n\r\nfunction TJvUninstallListBox.GetSection: string;\r\nbegin\r\n if ItemIndex > -1 then\r\n Result := TJvUninstallInfo(Items.Objects[ItemIndex]).Section\r\n else\r\n Result := '';\r\nend;\r\n\r\nprocedure TJvUninstallListBox.SetDisplayMode(const Value: TJvUCBDisplayModes);\r\nbegin\r\n if FDisplayMode <> Value then\r\n begin\r\n FDisplayMode := Value;\r\n Rebuild;\r\n end;\r\nend;\r\n\r\nprocedure TJvUninstallListBox.SetShowAll(const Value: Boolean);\r\nbegin\r\n if FShowAll <> Value then\r\n begin\r\n FShowAll := Value;\r\n Rebuild;\r\n end;\r\nend;\r\n\r\nprocedure TJvUninstallListBox.SetShowEmptyValues(const Value: Boolean);\r\nbegin\r\n if FShowEmptyValues <> Value then\r\n begin\r\n FShowEmptyValues := Value;\r\n Rebuild;\r\n end;\r\nend;\r\n\r\nprocedure TJvUninstallListBox.Clear;\r\nvar\r\n I: Integer;\r\nbegin\r\n if Parent = nil then\r\n Exit;\r\n for I := 0 to Items.Count - 1 do\r\n Items.Objects[I].Free;\r\n Items.Clear;\r\n inherited Clear;\r\nend;\r\n\r\nprocedure TJvUninstallListBox.Rebuild;\r\nvar\r\n I: Integer;\r\nbegin\r\n if ([csLoading, csDestroying] * ComponentState) <> [] then\r\n Exit;\r\n I := ItemIndex;\r\n Clear;\r\n GetUninstallApps(DisplayMode, Items, ShowAll, ShowEmptyValues);\r\n ItemIndex := I;\r\n if (Items.Count > 0) and (ItemIndex < 0) then\r\n ItemIndex := 0;\r\nend;\r\n\r\nprocedure TJvUninstallListBox.CreateHandle;\r\nbegin\r\n inherited CreateHandle;\r\n if ItemIndex < 0 then\r\n Rebuild;\r\nend;\r\n\r\nfunction TJvUninstallListBox.GetProperties: TStrings;\r\nbegin\r\n Result := nil;\r\n if ItemIndex > -1 then\r\n Result := TJvUninstallInfo(Items.Objects[ItemIndex]).Properties;\r\nend;\r\n\r\nfunction TJvUninstallListBox.GetHKey: HKEY;\r\nbegin\r\n Result := 0;\r\n if ItemIndex > -1 then\r\n Result := TJvUninstallInfo(Items.Objects[ItemIndex]).HKey;\r\nend;\r\n\r\nfunction TJvUninstallListBox.GetHKeyName: string;\r\nbegin\r\n Result := '';\r\n if ItemIndex > -1 then\r\n Result := TJvUninstallInfo(Items.Objects[ItemIndex]).HKeyName;\r\nend;\r\n\r\nprocedure TJvUninstallListBox.SetSorted(const Value: Boolean);\r\nvar\r\n S: string;\r\nbegin\r\n if Value <> inherited Sorted then\r\n begin\r\n if ItemIndex > -1 then\r\n S := Items[ItemIndex]\r\n else\r\n S := '';\r\n inherited Sorted := Value;\r\n if not Value then\r\n Rebuild;\r\n if S <> '' then\r\n ItemIndex := Items.IndexOf(S);\r\n end;\r\nend;\r\n\r\nprocedure TJvUninstallComboBox.RefreshItem;\r\nbegin\r\n Click;\r\n Change;\r\nend;\r\n\r\nprocedure TJvUninstallListBox.RefreshItem;\r\nbegin\r\n Click;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvUpDown.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvUpDown.PAS, released on 2001-02-28.\r\n\r\nThe Initial Developer of the Original Code is Peter Below <100113 dott 1101 att compuserve dott com>\r\nPortions created by Peter Below are Copyright (C) 2000 Peter Below.\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\nSebastien Buysse [sbuysse att buypin dott com].\r\nPeter Thrnqvist [peter3 at sourceforge dot net] - TJvDomainUpDown\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nDescription:\r\n TJvDomainUpDown works just like a TJvUpDown but instead of scrolling\r\n a range of integer value, it scrolls a list of strings (as defined by Items)\r\n\r\nKnown Issues:\r\n- Can't set Position of TJvDomainUpDown at design-time. SOLVED 2003-05-30\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvUpDown.pas 13155 2011-11-06 12:31:20Z ahuser $\r\n\r\nunit JvUpDown;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,\r\n StdCtrls, ComCtrls, CommCtrl,\r\n JvExComCtrls;\r\n\r\ntype\r\n TJvAlignButton = (abLeft, abRight, abNone);\r\n TJvUpDownFormat = (ufInt, ufHex);\r\n\r\n TJvCustomUpDown = class(TJvExCustomUpDown)\r\n private\r\n FIncrement: Integer;\r\n FMin: Integer;\r\n FMax: Integer;\r\n FPosition: Integer;\r\n FAssociate: TWinControl;\r\n FHotTrack: Boolean;\r\n FAlignButton: TJvAlignButton;\r\n FFormat: TJvUpDownFormat;\r\n FAcceptsInteger: Boolean;\r\n FFirstTime: Boolean;\r\n function GetPosition: Integer;\r\n procedure SetIncrement(const Value: Integer);\r\n procedure SetMax(const Value: Integer);\r\n procedure SetMin(const Value: Integer);\r\n procedure SetPosition(const Value: Integer);\r\n procedure CNNotify(var Msg: TWMNotify); message CN_NOTIFY;\r\n procedure SetAssociate(const Value: TWinControl);\r\n procedure SetHotTrack(const Value: Boolean);\r\n procedure SetAlignButton(const Value: TJvAlignButton);\r\n procedure SetFormat(const Value: TJvUpDownFormat);\r\n procedure UndoAutoResizing(Value: TWinControl);\r\n protected\r\n procedure UpdateAssociate; virtual;\r\n procedure CreateWnd; override;\r\n procedure CreateParams(var Params: TCreateParams); override;\r\n function AcceptPosition(Value: Integer): Boolean; virtual;\r\n function CanChange: Boolean; override;\r\n procedure Notification(AComponent: TComponent; Operation: TOperation); override;\r\n property AlignButton: TJvAlignButton read FAlignButton write SetAlignButton default abRight;\r\n property Associate: TWinControl read FAssociate write SetAssociate;\r\n property Format: TJvUpDownFormat read FFormat write SetFormat default ufInt;\r\n property HotTrack: Boolean read FHotTrack write SetHotTrack default False;\r\n property Increment: Integer read FIncrement write SetIncrement default 1;\r\n property Max: Integer read FMax write SetMax default 100;\r\n property Min: Integer read FMin write SetMin default 0;\r\n property Position: Integer read GetPosition write SetPosition default 0;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n function AcceptInteger: Boolean;\r\n end;\r\n\r\n TJvCustomDomainUpDown = class(TJvCustomUpDown)\r\n private\r\n FItems: TStringList;\r\n FCurrentText: string;\r\n function GetText: string;\r\n function GetItems: TStrings;\r\n procedure SetItems(const Value: TStrings);\r\n procedure SetText(const Value: string);\r\n protected\r\n procedure DoItemsChange(Sender: TObject);\r\n procedure CreateParams(var Params: TCreateParams); override;\r\n procedure UpdateAssociate; override;\r\n procedure Click(Button: TUDBtnType); override;\r\n function AcceptPosition(Value: Integer): Boolean; override;\r\n property Thousands default False;\r\n property Items: TStrings read GetItems write SetItems;\r\n property Text: string read GetText write SetText;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n end;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvUpDown = class(TJvCustomUpDown)\r\n protected\r\n procedure UpdateAssociate; override;\r\n published\r\n property AlignButton;\r\n property Anchors;\r\n property Associate;\r\n property ArrowKeys;\r\n property Color;\r\n property Enabled;\r\n property Format;\r\n property Hint;\r\n property HintColor;\r\n property HotTrack;\r\n property Min;\r\n property Max;\r\n property Increment;\r\n property Constraints;\r\n property Orientation;\r\n property ParentShowHint;\r\n property PopupMenu;\r\n property Position;\r\n property ShowHint;\r\n property TabOrder;\r\n property TabStop;\r\n property Thousands;\r\n property Visible;\r\n property Wrap;\r\n\r\n property OnMouseEnter;\r\n property OnMouseLeave;\r\n property OnParentColorChange;\r\n property OnChanging;\r\n property OnChangingEx;\r\n property OnContextPopup;\r\n property OnClick;\r\n property OnEnter;\r\n property OnExit;\r\n property OnMouseDown;\r\n property OnMouseMove;\r\n property OnMouseUp;\r\n end;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvDomainUpDown = class(TJvCustomDomainUpDown)\r\n published\r\n property Associate;\r\n property Items;\r\n property Position;\r\n property Text;\r\n\r\n property AlignButton;\r\n property Anchors;\r\n property ArrowKeys;\r\n property Enabled;\r\n property Hint;\r\n property HintColor;\r\n property HotTrack;\r\n property Constraints;\r\n property Orientation;\r\n property ParentShowHint;\r\n property PopupMenu;\r\n property ShowHint;\r\n property TabOrder;\r\n property TabStop;\r\n property Visible;\r\n property Wrap;\r\n\r\n property OnChanging;\r\n property OnChangingEx;\r\n property OnContextPopup;\r\n property OnClick;\r\n property OnEnter;\r\n property OnExit;\r\n property OnMouseDown;\r\n property OnMouseMove;\r\n property OnMouseUp;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvUpDown.pas $';\r\n Revision: '$Revision: 13155 $';\r\n Date: '$Date: 2011-11-06 13:31:20 +0100 (dim. 06 nov. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\n\r\nconst\r\n UDM_SETPOS32 = WM_USER + 113;\r\n UDM_GETPOS32 = WM_USER + 114;\r\n UDS_HOTTRACK = $0100;\r\n\r\n//=== { TJvCustomUpDown } ====================================================\r\n\r\nconstructor TJvCustomUpDown.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FMin := 0;\r\n FMax := 100;\r\n FPosition := 0;\r\n FHotTrack := False;\r\n FIncrement := 1;\r\n FAlignButton := abRight;\r\n FFormat := ufInt;\r\n FFirstTime := True;\r\nend;\r\n\r\nfunction TJvCustomUpDown.GetPosition: Integer;\r\nbegin\r\n if HandleAllocated then\r\n begin\r\n if AcceptInteger then\r\n Result := SendMessage(Handle, UDM_GETPOS32, 0, 0)\r\n else\r\n Result := SendMessage(Handle, UDM_GETPOS, 0, 0);\r\n FPosition := Result;\r\n end\r\n else\r\n Result := FPosition;\r\nend;\r\n\r\nprocedure TJvCustomUpDown.SetIncrement(const Value: Integer);\r\nvar\r\n AccelArray: array [0..0] of TUDAccel;\r\nbegin\r\n if Value <> FIncrement then\r\n begin\r\n FIncrement := Value;\r\n if HandleAllocated then\r\n begin\r\n SendMessage(Handle, UDM_GETACCEL, 1, LPARAM(@AccelArray[0]));\r\n AccelArray[0].nInc := Value;\r\n SendMessage(Handle, UDM_SETACCEL, 1, LPARAM(@AccelArray[0]));\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomUpDown.SetMax(const Value: Integer);\r\nbegin\r\n if Value <> FMax then\r\n begin\r\n inherited Max := Value;\r\n \r\n FMax := Value;\r\n if HandleAllocated then\r\n SendMessage(Handle, UDM_SETRANGE32, FMin, FMax);\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomUpDown.SetMin(const Value: Integer);\r\nbegin\r\n if Value <> FMin then\r\n begin\r\n inherited Min := Value;\r\n \r\n FMin := Value;\r\n if HandleAllocated then\r\n SendMessage(Handle, UDM_SETRANGE32, FMin, FMax);\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomUpDown.SetPosition(const Value: Integer);\r\nbegin\r\n if Value <> FPosition then\r\n begin\r\n if AcceptPosition(Value) then\r\n begin\r\n FPosition := Value;\r\n if HandleAllocated then\r\n begin\r\n if AcceptInteger then\r\n SendMessage(Handle, UDM_SETPOS32, 0, FPosition)\r\n else\r\n SendMessage(Handle, UDM_SETPOS, 0, FPosition);\r\n end;\r\n end;\r\n end;\r\n UpdateAssociate;\r\nend;\r\n\r\nprocedure TJvCustomUpDown.CNNotify(var Msg: TWMNotify);\r\nbegin\r\n // Call the inherited handler to allow for inherited events to be triggered\r\n // (Mantis 3513)\r\n inherited;\r\n\r\n with Msg do\r\n if NMHdr^.code = UDN_DELTAPOS then\r\n if AcceptPosition(PNMUpDown(NMHdr).iPos + PNMUpDown(NMHdr).iDelta) then\r\n begin\r\n FPosition := PNMUpDown(NMHdr).iPos + PNMUpDown(NMHdr).iDelta;\r\n UpdateAssociate;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomUpDown.SetAssociate(const Value: TWinControl);\r\nbegin\r\n FAssociate := Value;\r\n if HandleAllocated then\r\n begin\r\n if Value = nil then\r\n SendMessage(Handle, UDM_SETBUDDY, 0, 0)\r\n else\r\n begin\r\n UndoAutoResizing(Value);\r\n SendMessage(Handle, UDM_SETBUDDY, Value.Handle, 0);\r\n end;\r\n UpdateAssociate;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomUpDown.UndoAutoResizing(Value: TWinControl);\r\nvar\r\n OrigWidth, NewWidth, DeltaWidth: Integer;\r\n OrigLeft, NewLeft, DeltaLeft: Integer;\r\nbegin\r\n { undo Window's auto-resizing }\r\n OrigWidth := Value.Width;\r\n OrigLeft := Value.Left;\r\n SendMessage(Handle, UDM_SETBUDDY, Value.Handle, 0);\r\n NewWidth := Value.Width;\r\n NewLeft := Value.Left;\r\n DeltaWidth := OrigWidth - NewWidth;\r\n DeltaLeft := NewLeft - OrigLeft;\r\n Value.Width := OrigWidth + DeltaWidth;\r\n Value.Left := OrigLeft - DeltaLeft;\r\nend;\r\n\r\nprocedure TJvCustomUpDown.CreateWnd;\r\nconst\r\n cBase: array [TJvUpDownFormat] of Integer = (10, 16);\r\nvar\r\n OrigWidth: Integer;\r\n AccelArray: array [0..0] of TUDAccel;\r\nbegin\r\n OrigWidth := Width;\r\n inherited CreateWnd;\r\n Width := OrigWidth;\r\n if FAssociate <> nil then\r\n begin\r\n UndoAutoResizing(Associate);\r\n SendMessage(Handle, UDM_SETBUDDY, FAssociate.Handle, 0);\r\n end;\r\n SendMessage(Handle, UDM_SETRANGE32, FMin, FMax);\r\n SendMessage(Handle, UDM_SETBASE, cBase[Format], 0);\r\n SendMessage(Handle, UDM_GETACCEL, 1, LPARAM(@AccelArray));\r\n AccelArray[0].nInc := FIncrement;\r\n SendMessage(Handle, UDM_SETACCEL, 1, LPARAM(@AccelArray));\r\n SetPosition(Position);\r\n SetAssociate(FAssociate);\r\nend;\r\n\r\nfunction TJvCustomUpDown.AcceptPosition(Value: Integer): Boolean;\r\nbegin\r\n Result := (Value >= Min) and ((Value <= Max) or (Max = 0));\r\nend;\r\n\r\nprocedure TJvCustomUpDown.CreateParams(var Params: TCreateParams);\r\nbegin\r\n inherited CreateParams(Params);\r\n with Params do\r\n begin\r\n if FHotTrack then\r\n Style := Style or UDS_HOTTRACK;\r\n if (Style and UDS_ALIGNRIGHT) = UDS_ALIGNRIGHT then\r\n Style := Style and not UDS_ALIGNRIGHT;\r\n if (Style and UDS_ALIGNLEFT) = UDS_ALIGNLEFT then\r\n Style := Style and not UDS_ALIGNLEFT;\r\n case FAlignButton of\r\n abLeft:\r\n Style := Style or UDS_ALIGNLEFT;\r\n abRight:\r\n Style := Style or UDS_ALIGNRIGHT;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomUpDown.SetHotTrack(const Value: Boolean);\r\nbegin\r\n FHotTrack := Value;\r\n RecreateWnd;\r\nend;\r\n\r\nprocedure TJvCustomUpDown.SetAlignButton(const Value: TJvAlignButton);\r\nbegin\r\n FAlignButton := Value;\r\n RecreateWnd;\r\nend;\r\n\r\nfunction TJvCustomUpDown.CanChange: Boolean;\r\nbegin\r\n Result := inherited CanChange;\r\n if Result then\r\n if Assigned(Associate) and (Associate is TCustomEdit) and\r\n Assigned(Associate.Parent) then\r\n PostMessage(Associate.Parent.Handle,\r\n WM_COMMAND, MakeWParam(0, EN_CHANGE), Associate.Handle);\r\nend;\r\n\r\nfunction TJvCustomUpDown.AcceptInteger: Boolean;\r\nvar\r\n Info: Pointer;\r\n InfoSize: DWORD;\r\n FileInfo: PVSFixedFileInfo;\r\n FileInfoSize: DWORD;\r\n Tmp: DWORD;\r\n Major, Minor: Integer;\r\nbegin\r\n // SETPOS32 is only supported with comctl32.dll version 5.80 or later\r\n if FFirstTime then\r\n begin\r\n Result := False;\r\n try\r\n InfoSize := GetFileVersionInfoSize('comctl32.dll', Tmp);\r\n if InfoSize = 0 then\r\n Exit;\r\n GetMem(Info, InfoSize);\r\n try\r\n GetFileVersionInfo('comctl32.dll', 0, InfoSize, Info);\r\n VerQueryValue(Info, '\\', Pointer(FileInfo), FileInfoSize);\r\n Major := FileInfo^.dwFileVersionMS shr 16;\r\n Minor := FileInfo^.dwFileVersionMS and $FFFF;\r\n Result := (Major > 5) or ((Major = 5) and (Minor > 80));\r\n finally\r\n FreeMem(Info);\r\n end;\r\n except\r\n end;\r\n FAcceptsInteger := Result;\r\n FFirstTime := False;\r\n end\r\n else\r\n Result := FAcceptsInteger;\r\nend;\r\n\r\nprocedure TJvCustomUpDown.SetFormat(const Value: TJvUpDownFormat);\r\nconst\r\n cBase: array [TJvUpDownFormat] of Integer = (10, 16);\r\nbegin\r\n if FFormat <> Value then\r\n begin\r\n if HandleAllocated then\r\n SendMessage(Handle, UDM_SETBASE, cBase[Value], 0);\r\n FFormat := Value;\r\n UpdateAssociate;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomUpDown.UpdateAssociate;\r\nbegin\r\n // do nothing\r\nend;\r\n\r\n//=== { TJvUpDown } ==========================================================\r\n\r\nprocedure TJvUpDown.UpdateAssociate;\r\nbegin\r\n inherited UpdateAssociate;\r\n if FAssociate is TCustomEdit then\r\n if Format = ufHex then\r\n TCustomEdit(FAssociate).Text := '0x' + IntToHex(Position, 4)\r\n else\r\n TCustomEdit(FAssociate).Text := IntToStr(Position);\r\nend;\r\n\r\n//=== { TJvCustomDomainUpDown } ==============================================\r\n\r\nconstructor TJvCustomDomainUpDown.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FItems := TStringList.Create;\r\n FItems.OnChange := DoItemsChange;\r\nend;\r\n\r\ndestructor TJvCustomDomainUpDown.Destroy;\r\nbegin\r\n FItems.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvCustomDomainUpDown.CreateParams(var Params: TCreateParams);\r\nbegin\r\n inherited CreateParams(Params);\r\n Params.Style := Params.Style and (not UDS_SETBUDDYINT) or UDS_NOTHOUSANDS;\r\nend;\r\n\r\nprocedure TJvCustomDomainUpDown.DoItemsChange(Sender: TObject);\r\nbegin\r\n // switch min and max around to scroll in the right direction\r\n Min := Items.Count - 1;\r\n Max := 0;\r\nend;\r\n\r\nfunction TJvCustomDomainUpDown.GetText: string;\r\nbegin\r\n if (Position >= 0) and (Position < Items.Count) then\r\n begin\r\n Result := Items[Position];\r\n FCurrentText := Result;\r\n end\r\n else\r\n Result := FCurrentText;\r\nend;\r\n\r\nfunction TJvCustomDomainUpDown.GetItems: TStrings;\r\nbegin\r\n Result := FItems;\r\nend;\r\n\r\nprocedure TJvCustomDomainUpDown.SetItems(const Value: TStrings);\r\nbegin\r\n FItems.Assign(Value);\r\nend;\r\n\r\nprocedure TJvCustomDomainUpDown.UpdateAssociate;\r\nbegin\r\n if FAssociate is TCustomEdit then\r\n TCustomEdit(FAssociate).Text := Text;\r\n// if (Associate <> nil) and Associate.HandleAllocated then\r\n// SendMessage(Associate.Handle, WM_SETTEXT, 0, LPARAM(PChar(Text)));\r\nend;\r\n\r\nprocedure TJvCustomDomainUpDown.SetText(const Value: string);\r\nbegin\r\n Position := FItems.IndexOf(Value);\r\n FCurrentText := Value;\r\nend;\r\n\r\nprocedure TJvCustomDomainUpDown.Click(Button: TUDBtnType);\r\nbegin\r\n inherited Click(Button);\r\n UpdateAssociate;\r\nend;\r\n\r\nprocedure TJvCustomUpDown.Notification(AComponent: TComponent;\r\n Operation: TOperation);\r\nbegin\r\n inherited Notification(AComponent, Operation);\r\n if (Operation = opRemove) and (AComponent = Associate) then\r\n Associate := nil;\r\nend;\r\n\r\nfunction TJvCustomDomainUpDown.AcceptPosition(Value: Integer): Boolean;\r\nbegin\r\n Result := (Value >= 0) and (Value < Items.Count);\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvUrlGrabbers.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvUrlGrabbers.Pas, released on 2003-08-04.\r\n\r\nThe Initial Developer of the Original Code is Olivier Sannier [obones att altern dott org]\r\nPortions created by Olivier Sannier are Copyright (C) 2003 Olivier Sannier.\r\nAll Rights Reserved.\r\n\r\nContributor(s): -\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvUrlGrabbers.pas 13397 2012-08-16 17:23:19Z ahuser $\r\n\r\nunit JvUrlGrabbers;\r\n\r\n{$I jvcl.inc}\r\n{$I windowsonly.inc}\r\n\r\n{$HPPEMIT '#pragma link \"wininet.lib\"'}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, Classes, SysUtils,\r\n JvUrlListGrabber, JvTypes;\r\n\r\ntype\r\n // A grabber than can use a proxy. Note that this class is not registered,\r\n // it is just a base class for other grabbers\r\n // see http://msdn.microsoft.com/library/default.asp?url=/library/en-us/wininet/wininet/enabling_internet_functionality.asp\r\n // for details on the values to give to the proxy properties (address and ignorelist)\r\n TJvProxyMode = (pmNoProxy, pmSysConfig, pmManual);\r\n\r\n TJvProxyingUrlGrabber = class (TJvCustomUrlGrabber)\r\n protected\r\n FProxyAddresses: string;\r\n FProxyMode: TJvProxyMode;\r\n FProxyIgnoreList: string;\r\n FProxyUserName: string;\r\n FProxyPassword: string;\r\n property ProxyMode: TJvProxyMode read FProxyMode write FProxyMode default pmSysConfig;\r\n property ProxyAddresses: string read FProxyAddresses write FProxyAddresses;\r\n property ProxyIgnoreList: string read FProxyIgnoreList write FProxyIgnoreList;\r\n property ProxyUserName: string read FProxyUserName write FProxyUserName;\r\n property ProxyPassword: string read FProxyPassword write FProxyPassword;\r\n public\r\n constructor Create(AOwner: TComponent); overload; override;\r\n constructor Create(AOwner: TComponent; AUrl: string; DefaultProperties: TJvCustomUrlGrabberDefaultProperties); overload;\r\n end;\r\n\r\n TJvProxyingUrlGrabberDefaultProperties = class(TJvCustomUrlGrabberDefaultProperties)\r\n protected\r\n FProxyAddresses: string;\r\n FProxyMode: TJvProxyMode;\r\n FProxyIgnoreList: string;\r\n FProxyUserName: string;\r\n FProxyPassword: string;\r\n property ProxyMode: TJvProxyMode read FProxyMode write FProxyMode default pmSysConfig;\r\n property ProxyAddresses: string read FProxyAddresses write FProxyAddresses;\r\n property ProxyIgnoreList: string read FProxyIgnoreList write FProxyIgnoreList;\r\n property ProxyUserName: string read FProxyUserName write FProxyUserName;\r\n property ProxyPassword: string read FProxyPassword write FProxyPassword;\r\n public\r\n constructor Create(AOwner: TJvUrlGrabberDefaultPropertiesList); override;\r\n end;\r\n\r\n // A grabber for FTP URLs\r\n TJvFtpDownloadMode = (hmBinary, hmAscii);\r\n\r\n TJvFtpUrlGrabberDefaultProperties = class(TJvProxyingUrlGrabberDefaultProperties)\r\n protected\r\n FPassive: Boolean;\r\n FMode: TJvFtpDownloadMode;\r\n function GetSupportedURLName: string; override;\r\n public\r\n procedure Assign(Source: TPersistent); override;\r\n constructor Create(AOwner: TJvUrlGrabberDefaultPropertiesList); override;\r\n published\r\n property Agent;\r\n property UserName;\r\n property Password;\r\n property ProxyMode;\r\n property ProxyAddresses;\r\n property ProxyIgnoreList;\r\n property ProxyUserName;\r\n property ProxyPassword;\r\n property Port default 21;\r\n property Passive: Boolean read FPassive write FPassive default True;\r\n property Mode: TJvFtpDownloadMode read FMode write FMode default hmBinary;\r\n end;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvFtpUrlGrabber = class(TJvProxyingUrlGrabber)\r\n protected\r\n FPassive: Boolean;\r\n FMode: TJvFtpDownloadMode;\r\n function GetGrabberThreadClass: TJvCustomUrlGrabberThreadClass; override;\r\n procedure DoStatus; override;\r\n public\r\n constructor Create(AOwner: TComponent); overload; override;\r\n constructor Create(AOwner: TComponent; AUrl: string; DefaultProperties: TJvCustomUrlGrabberDefaultProperties); overload;\r\n class function CanGrab(const Url: string): Boolean; override;\r\n class function GetDefaultPropertiesClass: TJvCustomUrlGrabberDefaultPropertiesClass; override;\r\n class function GetSupportedProtocolMarker: string; override;\r\n class function GetSupportedURLName: string; override;\r\n published\r\n property Passive: Boolean read FPassive write FPassive default True;\r\n property Mode: TJvFtpDownloadMode read FMode write FMode default hmBinary;\r\n property UserName;\r\n property Password;\r\n property FileName;\r\n property OutputMode;\r\n property Agent;\r\n property Url;\r\n property ProxyMode;\r\n property ProxyAddresses;\r\n property ProxyIgnoreList;\r\n property ProxyUserName;\r\n property ProxyPassword;\r\n property Port default 21;\r\n property OnDoneFile;\r\n property OnDoneStream;\r\n property OnError;\r\n property OnProgress;\r\n property OnResolvingName;\r\n property OnNameResolved;\r\n property OnConnectingToServer;\r\n property OnConnectedToServer;\r\n property OnSendingRequest;\r\n property OnRequestSent;\r\n property OnRequestComplete;\r\n property OnReceivingResponse;\r\n property OnResponseReceived;\r\n property OnClosingConnection;\r\n property OnConnectionClosed;\r\n property OnRedirect;\r\n property OnStatusChange;\r\n end;\r\n\r\n TJvFtpUrlGrabberThread = class(TJvCustomUrlGrabberThread)\r\n protected\r\n function GetGrabber: TJvFtpUrlGrabber;\r\n procedure Grab; override;\r\n public\r\n property Grabber: TJvFtpUrlGrabber read GetGrabber;\r\n end;\r\n\r\n // A grabber for HTTP URLs\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvHttpUrlGrabber = class(TJvProxyingUrlGrabber)\r\n private\r\n FReferer: string;\r\n FHTTPStatus: string;\r\n protected\r\n function GetGrabberThreadClass: TJvCustomUrlGrabberThreadClass; override;\r\n procedure DoStatus; override;\r\n public\r\n constructor Create(AOwner: TComponent; AUrl: string; DefaultProperties: TJvCustomUrlGrabberDefaultProperties);\r\n class function CanGrab(const Url: string): Boolean; override;\r\n class function GetDefaultPropertiesClass: TJvCustomUrlGrabberDefaultPropertiesClass; override;\r\n class function GetSupportedProtocolMarker: string; override;\r\n class function GetSupportedURLName: string; override;\r\n\r\n // The status (200, 404, 301) as returned by the HTTP server.\r\n property HTTPStatus: string read FHTTPStatus;\r\n published\r\n property Referer: string read FReferer write FReferer;\r\n property UserName;\r\n property Password;\r\n property FileName;\r\n property OutputMode;\r\n property Agent;\r\n property Url;\r\n property Port default 80;\r\n property ProxyMode;\r\n property ProxyAddresses;\r\n property ProxyIgnoreList;\r\n property ProxyUserName;\r\n property ProxyPassword;\r\n property OnDoneFile;\r\n property OnDoneStream;\r\n property OnError;\r\n property OnProgress;\r\n property OnResolvingName;\r\n property OnNameResolved;\r\n property OnConnectingToServer;\r\n property OnConnectedToServer;\r\n property OnSendingRequest;\r\n property OnRequestSent;\r\n property OnRequestComplete;\r\n property OnReceivingResponse;\r\n property OnResponseReceived;\r\n property OnClosingConnection;\r\n property OnConnectionClosed;\r\n property OnRedirect;\r\n property OnStatusChange;\r\n end;\r\n\r\n TJvHttpUrlGrabberDefaultProperties = class(TJvProxyingUrlGrabberDefaultProperties)\r\n private\r\n FReferer: string;\r\n protected\r\n function GetSupportedURLName: string; override;\r\n public\r\n constructor Create(AOwner: TJvUrlGrabberDefaultPropertiesList); override;\r\n published\r\n property Referer: string read FReferer write FReferer;\r\n property Agent;\r\n property UserName;\r\n property Password;\r\n property Port default 80;\r\n property ProxyMode;\r\n property ProxyAddresses;\r\n property ProxyIgnoreList;\r\n property ProxyUserName;\r\n property ProxyPassword;\r\n end;\r\n\r\n TJvHttpUrlGrabberThread = class(TJvCustomUrlGrabberThread)\r\n protected\r\n function GetGrabber: TJvHttpUrlGrabber;\r\n procedure Grab; override;\r\n public\r\n property Grabber: TJvHttpUrlGrabber read GetGrabber;\r\n end;\r\n\r\n // A grabber for Secure HTTP URLs\r\n TJvHttpsUrlGrabber = class(TJvHttpUrlGrabber)\r\n public\r\n class function CanGrab(const Url: string): Boolean; override;\r\n class function GetDefaultPropertiesClass: TJvCustomUrlGrabberDefaultPropertiesClass; override;\r\n class function GetSupportedProtocolMarker: string; override;\r\n class function GetSupportedURLName: string; override;\r\n end;\r\n\r\n TJvHttpsUrlGrabberDefaultProperties = class(TJvHttpUrlGrabberDefaultProperties)\r\n protected\r\n function GetSupportedURLName: string; override;\r\n end;\r\n\r\n // A grabber for local and UNC files\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64 or pidOSX32)]\r\n {$ENDIF RTL230_UP}\r\n TJvLocalFileUrlGrabber = class(TJvCustomUrlGrabber)\r\n private\r\n FPreserveAttributes: Boolean;\r\n protected\r\n function GetGrabberThreadClass: TJvCustomUrlGrabberThreadClass; override;\r\n public\r\n constructor Create(AOwner: TComponent); overload; override;\r\n constructor Create(AOwner: TComponent; AUrl: string; DefaultProperties: TJvCustomUrlGrabberDefaultProperties); overload;\r\n class function CanGrab(const Url: string): Boolean; override;\r\n class function GetDefaultPropertiesClass: TJvCustomUrlGrabberDefaultPropertiesClass; override;\r\n class function GetSupportedProtocolMarker: string; override;\r\n class function GetSupportedURLName: string; override;\r\n class procedure ParseUrl(Url: string; Protocol: string; var Host: string; var FileName: string;\r\n var UserName: string; var Password: string; var Port: Cardinal); overload; override;\r\n class procedure ParseUrl(const Url: string; var FileName: string); reintroduce; overload;\r\n published\r\n property PreserveAttributes: Boolean read FPreserveAttributes write FPreserveAttributes default True;\r\n property UserName;\r\n property Password;\r\n property FileName;\r\n property OutputMode;\r\n property Agent;\r\n property Url;\r\n property OnDoneFile;\r\n property OnDoneStream;\r\n property OnError;\r\n property OnProgress;\r\n property OnResolvingName;\r\n property OnNameResolved;\r\n property OnConnectingToServer;\r\n property OnConnectedToServer;\r\n property OnSendingRequest;\r\n property OnRequestSent;\r\n property OnRequestComplete;\r\n property OnReceivingResponse;\r\n property OnResponseReceived;\r\n property OnClosingConnection;\r\n property OnConnectionClosed;\r\n property OnRedirect;\r\n property OnStatusChange;\r\n end;\r\n\r\n TJvLocalFileUrlGrabberThread = class(TJvCustomUrlGrabberThread)\r\n protected\r\n function GetGrabber: TJvLocalFileUrlGrabber;\r\n procedure Grab; override;\r\n public\r\n property Grabber: TJvLocalFileUrlGrabber read GetGrabber;\r\n end;\r\n\r\n TJvLocalFileUrlGrabberProperties = class(TJvCustomUrlGrabberDefaultProperties)\r\n private\r\n FPreserveAttributes: Boolean;\r\n protected\r\n function GetSupportedURLName: string; override;\r\n public\r\n constructor Create(AOwner: TJvUrlGrabberDefaultPropertiesList); override;\r\n procedure Assign(Source: TPersistent); override;\r\n published\r\n property PreserveAttributes: Boolean read FPreserveAttributes write FPreserveAttributes default True;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvUrlGrabbers.pas $';\r\n Revision: '$Revision: 13397 $';\r\n Date: '$Date: 2012-08-16 19:23:19 +0200 (jeu. 16 août 2012) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n WinInet,\r\n JclBase, // DWORD_PTR\r\n JvResources;\r\n\r\nconst\r\n cFilePrefix = 'file://';\r\n cHTTPPrefix = 'http://';\r\n cHTTPsPrefix = 'https://';\r\n cFTPPrefix = 'ftp://';\r\n\r\nprocedure RegisterUrlGrabberClasses;\r\nbegin\r\n // register the classes\r\n JvUrlGrabberClassList.Add(TJvFtpUrlGrabber);\r\n JvUrlGrabberClassList.Add(TJvHttpUrlGrabber);\r\n JvUrlGrabberClassList.Add(TJvHttpsUrlGrabber);\r\n JvUrlGrabberClassList.Add(TJvLocalFileUrlGrabber);\r\nend;\r\n\r\n// global download callback\r\nprocedure DownloadCallBack(Handle: HINTERNET; Context: DWORD;\r\n AStatus: DWORD; Info: Pointer; StatLen: DWORD); stdcall;\r\nbegin\r\n with TJvCustomUrlGrabberThread(Context) do\r\n begin\r\n Status := AStatus;\r\n DoProgress;\r\n DoStatus;\r\n end;\r\nend;\r\n\r\n// helper function to get the last error message from the internet functions\r\n\r\nfunction GetLastInternetError: string;\r\nvar\r\n dwIndex: DWORD;\r\n dwBufLen: DWORD;\r\n Buffer: PChar;\r\nbegin\r\n dwIndex := 0;\r\n dwBufLen := 1024;\r\n GetMem(Buffer, dwBufLen * SizeOf(Char));\r\n try\r\n InternetGetLastResponseInfo(dwIndex, Buffer, dwBufLen);\r\n Result := StrPas(Buffer);\r\n finally\r\n FreeMem(Buffer);\r\n end;\r\nend;\r\n\r\n// helper procedure to trigger various events depending on the\r\n// value of the given status.\r\n\r\nprocedure TriggerEventsFromStatus(Grabber: TJvCustomUrlGrabber; InternetStatusValue: DWORD);\r\nbegin\r\n with Grabber do\r\n case InternetStatusValue of\r\n INTERNET_STATUS_RESOLVING_NAME:\r\n if Assigned(OnResolvingName) then\r\n OnResolvingName(Grabber);\r\n INTERNET_STATUS_NAME_RESOLVED:\r\n if Assigned(OnNameResolved) then\r\n OnNameResolved(Grabber);\r\n INTERNET_STATUS_CONNECTING_TO_SERVER:\r\n if Assigned(OnConnectingToServer) then\r\n OnConnectingToServer(Grabber);\r\n INTERNET_STATUS_CONNECTED_TO_SERVER:\r\n if Assigned(OnConnectedToServer) then\r\n OnConnectedToServer(Grabber);\r\n INTERNET_STATUS_SENDING_REQUEST:\r\n if Assigned(OnSendingRequest) then\r\n OnSendingRequest(Grabber);\r\n INTERNET_STATUS_REQUEST_SENT:\r\n if Assigned(OnRequestSent) then\r\n OnRequestSent(Grabber);\r\n INTERNET_STATUS_RECEIVING_RESPONSE:\r\n if Assigned(OnReceivingResponse) then\r\n OnReceivingResponse(Grabber);\r\n INTERNET_STATUS_RESPONSE_RECEIVED:\r\n if Assigned(OnResponseReceived) then\r\n OnResponseReceived(Grabber);\r\n INTERNET_STATUS_CLOSING_CONNECTION:\r\n if Assigned(OnClosingConnection) then\r\n OnClosingConnection(Grabber);\r\n INTERNET_STATUS_CONNECTION_CLOSED:\r\n if Assigned(OnConnectionClosed) then\r\n OnConnectionClosed(Grabber);\r\n INTERNET_STATUS_REQUEST_COMPLETE:\r\n if Assigned(OnRequestComplete) then\r\n OnRequestComplete(Grabber);\r\n INTERNET_STATUS_REDIRECT:\r\n if Assigned(OnRedirect) then\r\n OnRedirect(Grabber);\r\n INTERNET_STATUS_STATE_CHANGE:\r\n if Assigned(OnStatusChange) then\r\n OnStatusChange(Grabber);\r\n end;\r\nend;\r\n\r\n//=== { TJvProxyingUrlGrabber } ==============================================\r\n\r\nconstructor TJvProxyingUrlGrabber.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n\r\n FProxyMode := pmSysConfig;\r\n FProxyAddresses := 'proxyserver';\r\n FProxyIgnoreList := '';\r\nend;\r\n\r\nconstructor TJvProxyingUrlGrabber.Create(AOwner: TComponent; AUrl: string;\r\n DefaultProperties: TJvCustomUrlGrabberDefaultProperties);\r\nbegin\r\n inherited Create(AOwner, AUrl, DefaultProperties);\r\n\r\n // TODO add else (probably exception).\r\n if DefaultProperties is TJvFtpUrlGrabberDefaultProperties then\r\n begin\r\n ProxyMode := TJvProxyingUrlGrabberDefaultProperties(DefaultProperties).ProxyMode;\r\n ProxyAddresses := TJvProxyingUrlGrabberDefaultProperties(DefaultProperties).ProxyAddresses;\r\n ProxyIgnoreList := TJvProxyingUrlGrabberDefaultProperties(DefaultProperties).ProxyIgnoreList;\r\n end;\r\nend;\r\n\r\n//=== { TJvProxyingUrlGrabberDefaultProperties } =============================\r\n\r\nconstructor TJvProxyingUrlGrabberDefaultProperties.Create(\r\n AOwner: TJvUrlGrabberDefaultPropertiesList);\r\nbegin\r\n inherited Create(AOwner);\r\n\r\n FProxyMode := pmSysConfig;\r\n FProxyAddresses := 'proxyserver';\r\n FProxyIgnoreList := '';\r\nend;\r\n\r\n//=== { TJvHttpUrlGrabber } ==================================================\r\n\r\nconstructor TJvHttpUrlGrabber.Create(AOwner: TComponent; AUrl: string;\r\n DefaultProperties: TJvCustomUrlGrabberDefaultProperties);\r\nbegin\r\n inherited Create(AOwner, AUrl, DefaultProperties);\r\n Port := 80;\r\nend;\r\n\r\nclass function TJvHttpUrlGrabber.CanGrab(const Url: string): Boolean;\r\nbegin\r\n Result := LowerCase(Copy(Url, 1, 7)) = cHTTPPrefix;\r\nend;\r\n\r\nclass function TJvHttpUrlGrabber.GetDefaultPropertiesClass: TJvCustomUrlGrabberDefaultPropertiesClass;\r\nbegin\r\n Result := TJvHttpUrlGrabberDefaultProperties;\r\nend;\r\n\r\nfunction TJvHttpUrlGrabber.GetGrabberThreadClass: TJvCustomUrlGrabberThreadClass;\r\nbegin\r\n Result := TJvHttpUrlGrabberThread;\r\nend;\r\n\r\nclass function TJvHttpUrlGrabber.GetSupportedProtocolMarker: string;\r\nbegin\r\n Result := cHTTPPrefix;\r\nend;\r\n\r\nclass function TJvHttpUrlGrabber.GetSupportedURLName: string;\r\nbegin\r\n Result := 'HTTP';\r\nend;\r\n\r\nprocedure TJvHttpUrlGrabber.DoStatus;\r\nbegin\r\n inherited DoStatus;\r\n TriggerEventsFromStatus(Self, UrlGrabberThread.Status);\r\nend;\r\n\r\n//=== { TJvFtpUrlGrabber } ===================================================\r\n\r\nconstructor TJvFtpUrlGrabber.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n Port := 21;\r\n Passive := True;\r\n Mode := hmBinary;\r\nend;\r\n\r\nconstructor TJvFtpUrlGrabber.Create(AOwner: TComponent; AUrl: string;\r\n DefaultProperties: TJvCustomUrlGrabberDefaultProperties);\r\nbegin\r\n inherited Create(AOwner, AUrl, DefaultProperties);\r\n // (rom) added check. TODO add else (probably exception).\r\n if DefaultProperties is TJvFtpUrlGrabberDefaultProperties then\r\n begin\r\n Passive := TJvFtpUrlGrabberDefaultProperties(DefaultProperties).Passive;\r\n Mode := TJvFtpUrlGrabberDefaultProperties(DefaultProperties).Mode;\r\n end;\r\nend;\r\n\r\nclass function TJvFtpUrlGrabber.CanGrab(const Url: string): Boolean;\r\nbegin\r\n Result := LowerCase(Copy(Url, 1, 6)) = cFTPPrefix;\r\nend;\r\n\r\nclass function TJvFtpUrlGrabber.GetDefaultPropertiesClass: TJvCustomUrlGrabberDefaultPropertiesClass;\r\nbegin\r\n Result := TJvFtpUrlGrabberDefaultProperties;\r\nend;\r\n\r\nfunction TJvFtpUrlGrabber.GetGrabberThreadClass: TJvCustomUrlGrabberThreadClass;\r\nbegin\r\n Result := TJvFtpUrlGrabberThread;\r\nend;\r\n\r\nclass function TJvFtpUrlGrabber.GetSupportedProtocolMarker: string;\r\nbegin\r\n Result := cFTPPrefix;\r\nend;\r\n\r\nclass function TJvFtpUrlGrabber.GetSupportedURLName: string;\r\nbegin\r\n Result := 'FTP';\r\nend;\r\n\r\nprocedure TJvFtpUrlGrabber.DoStatus;\r\nbegin\r\n inherited DoStatus;\r\n TriggerEventsFromStatus(Self, UrlGrabberThread.Status);\r\nend;\r\n\r\n//=== { TJvFtpUrlGrabberDefaultProperties } ==================================\r\n\r\nconstructor TJvFtpUrlGrabberDefaultProperties.Create(AOwner: TJvUrlGrabberDefaultPropertiesList);\r\nbegin\r\n inherited Create(AOwner);\r\n FPassive := True;\r\n FMode := hmBinary;\r\n Port := 21;\r\nend;\r\n\r\nprocedure TJvFtpUrlGrabberDefaultProperties.Assign(Source: TPersistent);\r\nbegin\r\n inherited Assign(Source);\r\n if Source is TJvFtpUrlGrabberDefaultProperties then\r\n with Source as TJvFtpUrlGrabberDefaultProperties do\r\n begin\r\n Self.Mode := Mode;\r\n Self.Passive := Passive;\r\n end;\r\nend;\r\n\r\nfunction TJvFtpUrlGrabberDefaultProperties.GetSupportedURLName: string;\r\nbegin\r\n Result := TJvFtpUrlGrabber.GetSupportedURLName;\r\nend;\r\n\r\n//=== { TJvFtpUrlGrabberThread } =============================================\r\n\r\nprocedure TJvFtpUrlGrabberThread.Grab;\r\nconst\r\n cPassive: array [Boolean] of DWORD = (0, INTERNET_FLAG_PASSIVE);\r\nvar\r\n hSession, hHostConnection, hDownload: HINTERNET;\r\n HostName, FileName, strUserName, strPassword: string;\r\n UserName, Password: PChar;\r\n Port: Cardinal;\r\n LocalBytesRead, TotalBytes: DWORD;\r\n Buf: array [0..1023] of Byte;\r\n dwFileSizeHigh: DWORD;\r\nbegin\r\n hSession := nil;\r\n hHostConnection := nil;\r\n hDownload := nil;\r\n try\r\n try\r\n ErrorText := '';\r\n Grabber.ParseUrl(Grabber.Url, Grabber.GetSupportedProtocolMarker,\r\n HostName, FileName, strUserName, strPassword, Port);\r\n if strUserName = '' then\r\n strUserName := Grabber.UserName;\r\n if strPassword = '' then\r\n strPassword := Grabber.Password;\r\n if Port = 0 then\r\n Port := Grabber.Port;\r\n\r\n // Setup the PChars for the call to InternetConnect\r\n if strUserName = '' then\r\n UserName := nil\r\n else\r\n UserName := PChar(strUserName);\r\n if strPassword = '' then\r\n Password := nil\r\n else\r\n Password := PChar(strPassword);\r\n\r\n // Connect to the web\r\n SetGrabberStatus(gsConnecting);\r\n case Grabber.ProxyMode of\r\n pmNoProxy:\r\n hSession := InternetOpen(PChar(Grabber.Agent), INTERNET_OPEN_TYPE_DIRECT, nil, nil, 0);\r\n pmSysConfig:\r\n hSession := InternetOpen(PChar(Grabber.Agent), INTERNET_OPEN_TYPE_PRECONFIG, nil, nil, 0);\r\n pmManual:\r\n hSession := InternetOpen(PChar(Grabber.Agent), INTERNET_OPEN_TYPE_PROXY, PChar(Grabber.ProxyAddresses), PChar(Grabber.ProxyIgnoreList), 0);\r\n end;\r\n if hSession = nil then\r\n begin\r\n ErrorText := GetLastInternetError;\r\n Synchronize(Error);\r\n Exit;\r\n end;\r\n if Grabber.ProxyMode = pmManual then\r\n begin\r\n // if manual mode and valid session, we set proxy user name and password\r\n InternetSetOption(hSession, INTERNET_OPTION_PROXY_USERNAME, PChar(Grabber.ProxyUserName), Length(Grabber.ProxyUserName)+1);\r\n InternetSetOption(hSession, INTERNET_OPTION_PROXY_PASSWORD, PChar(Grabber.ProxyPassword), Length(Grabber.ProxyPassword)+1);\r\n end;\r\n\r\n// InternetSetStatusCallback(hSession, PFNInternetStatusCallback(@DownloadCallBack));\r\n\r\n // Connect to the hostname\r\n hHostConnection := InternetConnect(hSession, PChar(HostName), Port,\r\n UserName, Password, INTERNET_SERVICE_FTP, cPassive[Grabber.Passive], 0);\r\n if hHostConnection = nil then\r\n begin\r\n ErrorText := GetLastInternetError;\r\n Synchronize(Error);\r\n Exit;\r\n end;\r\n\r\n InternetSetStatusCallback(hHostConnection, PFNInternetStatusCallback(@DownloadCallBack));\r\n\r\n // Request the file\r\n if Grabber.FMode = hmBinary then\r\n hDownload := FtpOpenFile(hHostConnection, PChar(FileName), GENERIC_READ,\r\n FTP_TRANSFER_TYPE_BINARY or INTERNET_FLAG_DONT_CACHE or INTERNET_FLAG_RELOAD, 0)\r\n else\r\n hDownload := FtpOpenFile(hHostConnection, PChar(FileName), GENERIC_READ,\r\n FTP_TRANSFER_TYPE_ASCII or INTERNET_FLAG_DONT_CACHE or INTERNET_FLAG_RELOAD, 0);\r\n\r\n if Terminated then\r\n Exit;\r\n\r\n if hDownload = nil then\r\n begin\r\n ErrorText := GetLastInternetError;\r\n Synchronize(Error);\r\n Exit;\r\n end;\r\n Grabber.SetSize(FtpGetFileSize(hDownload, @dwFileSizeHigh)); // acp\r\n\r\n if Terminated then\r\n Exit;\r\n\r\n Grabber.Stream := TMemoryStream.Create;\r\n\r\n TotalBytes := 0;\r\n LocalBytesRead := 1;\r\n SetGrabberStatus(gsGrabbing);\r\n while (LocalBytesRead <> 0) and not Terminated and Continue do // acp\r\n begin\r\n if not InternetReadFile(hDownload, @Buf, SizeOf(Buf), LocalBytesRead) then\r\n LocalBytesRead := 0\r\n else\r\n begin\r\n Inc(TotalBytes, LocalBytesRead);\r\n Grabber.SetBytesRead(TotalBytes);\r\n Grabber.Stream.Write(Buf, LocalBytesRead);\r\n DoProgress;\r\n end;\r\n\r\n // Be CPU friendly.\r\n SleepEx(0, True);\r\n end;\r\n\r\n SetGrabberStatus(gsStopping);\r\n if not Terminated and Continue then // acp\r\n Synchronize(Ended);\r\n except\r\n end;\r\n finally\r\n //Release all handles\r\n // (rom) now all connections get closed and Closed is always signalled\r\n if (hDownload <> nil) and not InternetCloseHandle(hDownload) then\r\n begin\r\n ErrorText := GetLastInternetError;\r\n Synchronize(Error);\r\n end;\r\n if (hHostConnection <> nil) and not InternetCloseHandle(hHostConnection) then\r\n begin\r\n ErrorText := GetLastInternetError;\r\n Synchronize(Error);\r\n end;\r\n if (hSession <> nil) and not InternetCloseHandle(hSession) then\r\n begin\r\n ErrorText := GetLastInternetError;\r\n Synchronize(Error);\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJvFtpUrlGrabberThread.GetGrabber: TJvFtpUrlGrabber;\r\nbegin\r\n Result := TJvFtpUrlGrabber(FGrabber);\r\nend;\r\n\r\n//=== { TJvHttpUrlGrabberThread } ============================================\r\n\r\nprocedure TJvHttpUrlGrabberThread.Grab;\r\nvar\r\n hSession, hHostConnection, hDownload: HINTERNET;\r\n HostName, FileName, strUserName, strPassword: string;\r\n UserName, Password: PChar;\r\n Port: Cardinal;\r\n Buffer: PChar;\r\n dwBufLen, dwIndex, dwBytesRead, dwTotalBytes: DWORD;\r\n HasSize: Boolean;\r\n Buf: array [0..1024] of Byte;\r\nbegin\r\n Buffer := nil;\r\n\r\n Continue := True;\r\n hSession := nil;\r\n hHostConnection := nil;\r\n hDownload := nil;\r\n try\r\n try\r\n Grabber.ParseUrl(Grabber.Url, Grabber.GetSupportedProtocolMarker,\r\n HostName, FileName, strUserName, strPassword, Port);\r\n if strUserName = '' then\r\n strUserName := Grabber.UserName;\r\n if strPassword = '' then\r\n strPassword := Grabber.Password;\r\n if Port = 0 then\r\n Port := Grabber.Port;\r\n\r\n // Setup the PChars for the call to InternetConnect\r\n if strUserName = '' then\r\n UserName := nil\r\n else\r\n UserName := PChar(strUserName);\r\n if strPassword = '' then\r\n Password := nil\r\n else\r\n Password := PChar(strPassword);\r\n\r\n ErrorText := '';\r\n\r\n //Connect to the web\r\n SetGrabberStatus(gsConnecting);\r\n case Grabber.ProxyMode of\r\n pmNoProxy:\r\n hSession := InternetOpen(PChar(Grabber.Agent), INTERNET_OPEN_TYPE_DIRECT, nil, nil, 0);\r\n pmSysConfig:\r\n hSession := InternetOpen(PChar(Grabber.Agent), INTERNET_OPEN_TYPE_PRECONFIG, nil, nil, 0);\r\n pmManual:\r\n hSession := InternetOpen(PChar(Grabber.Agent), INTERNET_OPEN_TYPE_PROXY, PChar(Grabber.ProxyAddresses), PChar(Grabber.ProxyIgnoreList), 0);\r\n end;\r\n if hSession = nil then\r\n begin\r\n ErrorText := SysErrorMessage(GetLastError);\r\n Synchronize(Error);\r\n Exit;\r\n end;\r\n InternetSetStatusCallback(hSession, PFNInternetStatusCallback(@DownloadCallBack));\r\n\r\n // Connect to the host\r\n hHostConnection := InternetConnect(hSession, PChar(HostName), Port,\r\n UserName, Password, INTERNET_SERVICE_HTTP, 0, DWORD_PTR(Self));\r\n\r\n if Terminated then\r\n Exit;\r\n\r\n if hHostConnection = nil then\r\n begin\r\n ErrorText := GetLastInternetError;\r\n Buffer := nil;\r\n Synchronize(Error);\r\n Exit;\r\n end;\r\n\r\n// InternetSetStatusCallback(hHostConnection, PFNInternetStatusCallback(@DownloadCallBack));\r\n //Request the file\r\n hDownload := HttpOpenRequest(hHostConnection, 'GET', PChar(FileName), 'HTTP/1.0',\r\n PChar(Grabber.Referer), nil, INTERNET_FLAG_RELOAD or INTERNET_FLAG_PRAGMA_NOCACHE, 0);\r\n\r\n if hDownload = nil then\r\n begin\r\n ErrorText := GetLastInternetError;\r\n Synchronize(Error);\r\n Exit;\r\n end;\r\n// InternetSetStatusCallback(hDownload, PFNInternetStatusCallback(@DownloadCallBack));\r\n\r\n if Grabber.ProxyMode in [pmManual, pmSysConfig] then\r\n begin\r\n // if manual mode and valid session, we set proxy user name and password\r\n InternetSetOption(hDownload,\r\n INTERNET_OPTION_PROXY_USERNAME,\r\n PChar(Grabber.ProxyUserName),\r\n Length(Grabber.ProxyUserName)+1);\r\n InternetSetOption(hDownload,\r\n INTERNET_OPTION_PROXY_PASSWORD,\r\n PChar(Grabber.ProxyPassword),\r\n Length(Grabber.ProxyPassword)+1);\r\n end;\r\n\r\n //Send the request\r\n HttpSendRequest(hDownload, nil, 0, nil, 0);\r\n\r\n if Terminated then\r\n Exit;\r\n\r\n Grabber.Stream := TMemoryStream.Create;\r\n\r\n dwIndex := 0;\r\n dwBufLen := 1024;\r\n GetMem(Buffer, dwBufLen * SizeOf(Char));\r\n\r\n HttpQueryInfo(hDownload, HTTP_QUERY_STATUS_CODE , Buffer, dwBufLen, dwIndex);\r\n Grabber.FHTTPStatus := Buffer;\r\n\r\n dwIndex := 0;\r\n dwBufLen := 1024;\r\n HasSize := HttpQueryInfo(hDownload, HTTP_QUERY_CONTENT_LENGTH, Buffer, dwBufLen, dwIndex);\r\n if Terminated then\r\n Exit;\r\n\r\n if HasSize then\r\n Grabber.SetSize(StrToInt(StrPas(Buffer)))\r\n else\r\n Grabber.SetSize(0);\r\n\r\n dwTotalBytes := 0;\r\n SetGrabberStatus(gsGrabbing);\r\n if HasSize then\r\n begin\r\n dwBytesRead := 1;\r\n while (dwBytesRead > 0) and not Terminated and Continue do\r\n begin\r\n if not InternetReadFile(hDownload, @Buf, SizeOf(Buf), dwBytesRead) then\r\n dwBytesRead := 0\r\n else\r\n begin\r\n Inc(dwTotalBytes, dwBytesRead);\r\n Grabber.SetBytesRead(dwTotalBytes);\r\n Grabber.Stream.Write(Buf, dwBytesRead);\r\n DoProgress;\r\n end;\r\n\r\n // Be CPU friendly.\r\n SleepEx(0, True);\r\n end;\r\n\r\n SetGrabberStatus(gsStopping);\r\n if Continue and not Terminated then\r\n Synchronize(Ended);\r\n end\r\n else\r\n begin\r\n while InternetReadFile(hDownload, @Buf, SizeOf(Buf), dwBytesRead) and not Terminated do\r\n begin\r\n if dwBytesRead = 0 then\r\n Break;\r\n Grabber.Stream.Write(Buf, dwBytesRead);\r\n Synchronize(UpdateGrabberProgress);\r\n\r\n // Be CPU friendly.\r\n SleepEx(0, True);\r\n end;\r\n\r\n SetGrabberStatus(gsStopping);\r\n if Continue and not Terminated then\r\n Synchronize(Ended);\r\n end;\r\n except\r\n end;\r\n finally\r\n // Free all stuff's\r\n if Buffer <> nil then\r\n FreeMem(Buffer);\r\n\r\n // Release all handles\r\n if (hDownload <> nil) and not InternetCloseHandle(hDownload) then\r\n begin\r\n ErrorText := GetLastInternetError;\r\n Synchronize(Error);\r\n end;\r\n if (hHostConnection <> nil) and not InternetCloseHandle(hHostConnection) then\r\n begin\r\n ErrorText := GetLastInternetError;\r\n Synchronize(Error);\r\n end;\r\n if (hSession <> nil) and not InternetCloseHandle(hSession) then\r\n begin\r\n ErrorText := GetLastInternetError;\r\n Synchronize(Error);\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJvHttpUrlGrabberThread.GetGrabber: TJvHttpUrlGrabber;\r\nbegin\r\n Result := TJvHttpUrlGrabber(FGrabber);\r\nend;\r\n\r\n//=== { TJvHttpUrlGrabberDefaultProperties } =================================\r\n\r\nconstructor TJvHttpUrlGrabberDefaultProperties.Create(AOwner: TJvUrlGrabberDefaultPropertiesList);\r\nbegin\r\n inherited Create(AOwner);\r\n Port := 80;\r\nend;\r\n\r\nfunction TJvHttpUrlGrabberDefaultProperties.GetSupportedURLName: string;\r\nbegin\r\n Result := TJvHttpUrlGrabber.GetSupportedURLName;\r\nend;\r\n\r\n//=== { TJvHttpsUrlGrabber } =============================================\r\n\r\nclass function TJvHttpsUrlGrabber.CanGrab(const Url: string): Boolean;\r\nbegin\r\n Result := LowerCase(Copy(Url, 1, 7)) = cHTTPsPrefix;\r\nend;\r\n\r\nclass function TJvHttpsUrlGrabber.GetDefaultPropertiesClass: TJvCustomUrlGrabberDefaultPropertiesClass;\r\nbegin\r\n Result := TJvHttpsUrlGrabberDefaultProperties;\r\nend;\r\n\r\nclass function TJvHttpsUrlGrabber.GetSupportedProtocolMarker: string;\r\nbegin\r\n Result := cHTTPsPrefix;\r\nend;\r\n\r\nclass function TJvHttpsUrlGrabber.GetSupportedURLName: string;\r\nbegin\r\n Result := 'Secure HTTP';\r\nend;\r\n\r\n//=== { TJvHttpsUrlGrabberDefaultProperties } =============================================\r\n\r\nfunction TJvHttpsUrlGrabberDefaultProperties.GetSupportedURLName: string;\r\nbegin\r\n Result := TJvHttpsUrlGrabber.GetSupportedURLName;\r\nend;\r\n\r\n//=== { TJvLocalFileUrlGrabber } =============================================\r\n\r\nconstructor TJvLocalFileUrlGrabber.Create(AOwner: TComponent; AUrl: string;\r\n DefaultProperties: TJvCustomUrlGrabberDefaultProperties);\r\nbegin\r\n inherited Create(AOwner, AUrl, DefaultProperties);\r\n FPreserveAttributes := TJvLocalFileUrlGrabberProperties(DefaultProperties).PreserveAttributes;\r\nend;\r\n\r\nconstructor TJvLocalFileUrlGrabber.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FPreserveAttributes := True;\r\nend;\r\n\r\nclass function TJvLocalFileUrlGrabber.CanGrab(const Url: string): Boolean;\r\nbegin\r\n // accepts \"file://\", UNC and local path and existing files\r\n Result := (LowerCase(Copy(Url, 1, 7)) = cFilePrefix) or (Copy(Url,1,2) = '//') or\r\n (Copy(Url, 2,2) = ':\\') or FileExists(Url);\r\nend;\r\n\r\nclass function TJvLocalFileUrlGrabber.GetDefaultPropertiesClass: TJvCustomUrlGrabberDefaultPropertiesClass;\r\nbegin\r\n Result := TJvLocalFileUrlGrabberProperties;\r\nend;\r\n\r\nfunction TJvLocalFileUrlGrabber.GetGrabberThreadClass: TJvCustomUrlGrabberThreadClass;\r\nbegin\r\n Result := TJvLocalFileUrlGrabberThread;\r\nend;\r\n\r\nclass function TJvLocalFileUrlGrabber.GetSupportedProtocolMarker: string;\r\nbegin\r\n Result := cFilePrefix;\r\nend;\r\n\r\nclass function TJvLocalFileUrlGrabber.GetSupportedURLName: string;\r\nbegin\r\n Result := 'LocalFile';\r\nend;\r\n\r\nclass procedure TJvLocalFileUrlGrabber.ParseUrl(Url, Protocol: string;\r\n var Host, FileName, UserName, Password: string; var Port: Cardinal);\r\nbegin\r\n ParseUrl(Url, FileName);\r\nend;\r\n\r\nclass procedure TJvLocalFileUrlGrabber.ParseUrl(const Url: string;\r\n var FileName: string);\r\nbegin\r\n FileName := StringReplace(Url, '/', '\\', [rfReplaceAll]);\r\n if AnsiSameText(Copy(Url, 1, 7), cFilePrefix) then\r\n FileName := Copy(FileName, 8, MaxInt)\r\n else\r\n FileName := ExpandUNCFilename(FileName);\r\nend;\r\n\r\n//=== { TJvLocalFileUrlGrabberThread } =======================================\r\n\r\nprocedure TJvLocalFileUrlGrabberThread.Grab;\r\nvar\r\n FileName: string;\r\n BytesRead, TotalBytes: DWORD;\r\n Buf: array [0..1023] of Byte;\r\n AFileStream: TFileStream;\r\n Attrs: Integer;\r\nbegin\r\n Grabber.ParseUrl(Grabber.Url, FileName);\r\n if not FileExists(FileName) then\r\n begin\r\n ErrorText := Format(RsFileNotFoundFmt, [FileName]);\r\n Synchronize(Error);\r\n Exit;\r\n end;\r\n\r\n if Grabber.PreserveAttributes then\r\n Attrs := GetFileAttributes(PChar(FileName))\r\n else\r\n Attrs := 0;\r\n try\r\n ErrorText := '';\r\n SetGrabberStatus(gsConnecting);\r\n Grabber.Stream := TMemoryStream.Create;\r\n AFileStream := TFileStream.Create(FileName, fmOpenRead or fmShareDenyNone);\r\n try\r\n Grabber.SetSize(AFileStream.Size);\r\n Grabber.SetBytesRead(0);\r\n Status := 0;\r\n DoProgress;\r\n TotalBytes := 0;\r\n BytesRead := 1;\r\n SetGrabberStatus(gsGrabbing);\r\n while (BytesRead <> 0) and not Terminated and Continue do\r\n begin\r\n BytesRead := AFileStream.Read(Buf, SizeOf(Buf));\r\n Inc(TotalBytes, BytesRead);\r\n Grabber.SetBytesRead(TotalBytes);\r\n Status := Grabber.BytesRead;\r\n if BytesRead > 0 then\r\n Grabber.Stream.Write(Buf, BytesRead);\r\n DoProgress;\r\n\r\n // Be CPU friendly.\r\n SleepEx(0, True);\r\n end;\r\n SetGrabberStatus(gsStopping);\r\n if not Terminated and Continue then // acp\r\n Synchronize(Ended);\r\n if Grabber.PreserveAttributes and FileExists(Grabber.FileName) then\r\n SetFileAttributes(PChar(Grabber.FileName), Attrs);\r\n finally\r\n AFileStream.Free;\r\n end;\r\n except\r\n// Application.HandleException(Self);\r\n end;\r\nend;\r\n\r\nfunction TJvLocalFileUrlGrabberThread.GetGrabber: TJvLocalFileUrlGrabber;\r\nbegin\r\n Result := TJvLocalFileUrlGrabber(FGrabber);\r\nend;\r\n\r\n//=== { TJvLocalFileUrlGrabberProperties } ===================================\r\n\r\nconstructor TJvLocalFileUrlGrabberProperties.Create(AOwner: TJvUrlGrabberDefaultPropertiesList);\r\nbegin\r\n inherited Create(AOwner);\r\n FPreserveAttributes := True;\r\nend;\r\n\r\nprocedure TJvLocalFileUrlGrabberProperties.Assign(Source: TPersistent);\r\nbegin\r\n inherited Assign(Source);\r\n if Source is TJvLocalFileUrlGrabberProperties then\r\n with Source as TJvLocalFileUrlGrabberProperties do\r\n Self.PreserveAttributes := PreserveAttributes;\r\nend;\r\n\r\nfunction TJvLocalFileUrlGrabberProperties.GetSupportedURLName: string;\r\nbegin\r\n Result := TJvLocalFileUrlGrabber.GetSupportedURLName;\r\nend;\r\n\r\ninitialization\r\n {$IFDEF UNITVERSIONING}\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n {$ENDIF UNITVERSIONING}\r\n RegisterUrlGrabberClasses;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvUrlListGrabber.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvUrlListGrabber.Pas, released on 2003-08-04.\r\n\r\nThe Initial Developer of the Original Code is Olivier Sannier [obones att altern dott org]\r\nPortions created by Olivier Sannier are Copyright (C) 2003 Olivier Sannier.\r\nAll Rights Reserved.\r\n\r\nContributor(s): -\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvUrlListGrabber.pas 13414 2012-09-09 12:00:18Z ahuser $\r\n\r\nunit JvUrlListGrabber;\r\n\r\ninterface\r\n\r\n{$I jvcl.inc}\r\n\r\n{$HPPEMIT '#pragma link \"wininet.lib\"'}\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, Classes, SysUtils, Contnrs,\r\n JvComponentBase, JvTypes;\r\n\r\ntype\r\n // early declarations\r\n TJvUrlListGrabber = class;\r\n TJvCustomUrlGrabber = class;\r\n TJvUrlGrabberList = class;\r\n TJvUrlGrabberDefaultPropertiesList = class;\r\n\r\n // A Grabber index, defined as a new type to allow to give it\r\n // a specific property editor\r\n TJvUrlGrabberIndex = type Integer;\r\n\r\n // The event triggered when a new grabber are created/added\r\n TJvGrabberCreatedEvent = procedure(Sender: TJvUrlListGrabber; Grabber: TJvCustomUrlGrabber) of object;\r\n TJvGrabberAddedEvent = procedure(Sender: TJvUrlListGrabber; Grabber: TJvCustomUrlGrabber; Index: Integer) of object;\r\n\r\n // The type of the events triggered when one of the grabbers\r\n // has triggered its own event to indicate a change in its state\r\n TJvGrabberNotifyEvent = procedure(Sender: TJvUrlListGrabber; Grabber: TJvCustomUrlGrabber) of object;\r\n\r\n // Set of type of events triggered by TJvUrlListGrabber to indicate that\r\n // one of its grabbers has triggered the corresponding event\r\n TJvGrabberDoneFileEvent = procedure(Sender: TJvUrlListGrabber; Grabber: TJvCustomUrlGrabber; FileName: string;\r\n FileSize: Integer; Url: string) of object;\r\n TJvGrabberDoneStreamEvent = procedure(Sender: TJvUrlListGrabber; Grabber: TJvCustomUrlGrabber; Stream: TStream;\r\n StreamSize: Integer; Url: string) of object;\r\n TJvGrabberProgressEvent = procedure(Sender: TJvUrlListGrabber; Grabber: TJvCustomUrlGrabber; Position, TotalSize:\r\n Int64; Url: string; var Continue: Boolean) of object;\r\n TJvGrabberErrorEvent = procedure(Sender: TJvUrlListGrabber; Grabber: TJvCustomUrlGrabber; ErrorMsg: string) of object;\r\n\r\n // The exception raised by TJvUrlListGrabber when no grabber claimed it was capable\r\n // of handling a given URL. This is only raised if DefaultGrabberIndex is -1\r\n ENoGrabberForUrl = class(Exception);\r\n\r\n // The exception triggered if someone tries to set the URLs property while at\r\n // least one grabber is running\r\n EAtLeastOneGrabberRunning = class(Exception);\r\n\r\n // This component allows the user to specify a list of URLs to be\r\n // grabbed and then start grabbing. All the grab operations will be done\r\n // in parallel in the background, leaving the user's application free\r\n // to continue its operations\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvUrlListGrabber = class(TJvComponent)\r\n private\r\n FOnDoneFile: TJvGrabberDoneFileEvent;\r\n FOnDoneStream: TJvGrabberDoneStreamEvent;\r\n FOnError: TJvGrabberErrorEvent;\r\n FOnProgress: TJvGrabberProgressEvent;\r\n FOnConnectionClosed: TJvGrabberNotifyEvent;\r\n FOnReceivingResponse: TJvGrabberNotifyEvent;\r\n FOnRequestComplete: TJvGrabberNotifyEvent;\r\n FOnResponseReceived: TJvGrabberNotifyEvent;\r\n FOnConnectingToServer: TJvGrabberNotifyEvent;\r\n FOnResolvingName: TJvGrabberNotifyEvent;\r\n FOnClosingConnection: TJvGrabberNotifyEvent;\r\n FOnConnectedToServer: TJvGrabberNotifyEvent;\r\n FOnRedirect: TJvGrabberNotifyEvent;\r\n FOnNameResolved: TJvGrabberNotifyEvent;\r\n FOnSendingRequest: TJvGrabberNotifyEvent;\r\n FOnRequestSent: TJvGrabberNotifyEvent;\r\n FOnStatusChange: TJvGrabberNotifyEvent;\r\n FOnGrabberCreated: TJvGrabberCreatedEvent;\r\n\r\n FCleanupThreshold: Cardinal;\r\n FCleanupList: TObjectList;\r\n FGrabbers: TJvUrlGrabberList;\r\n FURLs: TStringList;\r\n FDefaultGrabberIndex: TJvUrlGrabberIndex;\r\n FDefaultGrabbersProperties: TJvUrlGrabberDefaultPropertiesList;\r\n FMaxSimultaneousGrabbers: Integer;\r\n FNextURLIndex: Integer;\r\n FOnGrabberAdded: TJvGrabberAddedEvent;\r\n\r\n // gets/sets the URLs property, assigning the given strings\r\n // to the internal FURLs field\r\n function GetURLs: TStrings;\r\n procedure SetURLs(const Value: TStrings);\r\n\r\n // sets the Default Grabber value, ensuring that it doesn't go\r\n // below -1 or above the number of registered grabber classes\r\n // if you try to set the value above the last index in the\r\n // JvUrlGrabberClassList, then the value will be set to -1.\r\n // The same goes if you set a value below -1.\r\n procedure SetDefaultGrabberIndex(const Value: TJvUrlGrabberIndex);\r\n\r\n // returns the grabber associated with the given index\r\n function GetGrabbers(const Index: Integer): TJvCustomUrlGrabber;\r\n\r\n // Called whenever the list of Urls is about to change\r\n procedure URLsChanging(Sender: TObject);\r\n\r\n // The event handlers for the grabbers, to propagate them to the\r\n // user through the events of this class\r\n procedure GrabberDoneFile(Grabber: TObject; FileName: string; FileSize: Integer; Url: string);\r\n procedure GrabberDoneStream(Grabber: TObject; Stream: TStream; StreamSize: Integer; Url: string);\r\n procedure GrabberProgress(Grabber: TObject; Position, TotalSize: Int64; Url: string; var Continue: Boolean);\r\n procedure GrabberError(Grabber: TObject; ErrorMsg: string);\r\n procedure GrabberConnectionClosed(Grabber: TObject);\r\n procedure GrabberReceivingResponse(Grabber: TObject);\r\n procedure GrabberRequestComplete(Grabber: TObject);\r\n procedure GrabberResponseReceived(Grabber: TObject);\r\n procedure GrabberConnectingToServer(Grabber: TObject);\r\n procedure GrabberResolvingName(Grabber: TObject);\r\n procedure GrabberClosingConnection(Grabber: TObject);\r\n procedure GrabberConnectedToServer(Grabber: TObject);\r\n procedure GrabberRedirect(Grabber: TObject);\r\n procedure GrabberNameResolved(Grabber: TObject);\r\n procedure GrabberSendingRequest(Grabber: TObject);\r\n procedure GrabberRequestSent(Grabber: TObject);\r\n procedure GrabberStatusChange(Grabber: TObject);\r\n function GetGrabberCount: Integer;\r\n procedure SetMaxSimultaneousGrabbers(const Value: Integer);\r\n protected\r\n // Sets the events of the given grabber to call the internal\r\n // event handlers indicated below. This way, the events of\r\n // TJvUrlListGrabber will be triggered properly\r\n procedure SetGrabberEvents(Grabber: TJvCustomUrlGrabber);\r\n\r\n // Returns a new grabber for the given URL or raises an exception if\r\n // no grabber could be found for the URL.\r\n // Note: The events of the returned grabber are not set.\r\n function GetGrabberForUrl(const URL: string): TJvCustomUrlGrabber;\r\n\r\n procedure DoGrabberCreated(Grabber: TJvCustomUrlGrabber);\r\n procedure DoGrabberAdded(Grabber: TJvCustomUrlGrabber; Index: Integer);\r\n\r\n procedure StartNextGrabber;\r\n\r\n procedure DefineProperties(Filer: TFiler); override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n\r\n // cleans up the internal list of grabbers\r\n procedure Cleanup;\r\n\r\n // starts all the grabbers. Deprecated, use Start instead.\r\n procedure StartAll; {$IFDEF SUPPORTS_DEPRECATED}deprecated;{$ENDIF SUPPORTS_DEPRECATED}\r\n // stops all the grabbers. Deprecated, use Stop instead.\r\n procedure StopAll; {$IFDEF SUPPORTS_DEPRECATED}deprecated;{$ENDIF SUPPORTS_DEPRECATED}\r\n\r\n procedure Start;\r\n procedure Stop;\r\n\r\n // The Grabber objects associated with the Urls. This array contains up\r\n // to FUrls.Count if MaxSimultaneousGrabbers is 0, else up to the value\r\n // of MaxSimultaneousGrabbers. Note that this array only contains elements\r\n // if at least one URL is being grabbed. Hence, before you call StartAll,\r\n // it is always empty.\r\n property Grabbers[const Index: Integer]: TJvCustomUrlGrabber read GetGrabbers;\r\n property GrabberCount: Integer read GetGrabberCount;\r\n property NexUrlIndex: Integer read FNextUrlIndex;\r\n published\r\n // the index of the default grabber to use, if any\r\n property DefaultGrabberIndex: TJvUrlGrabberIndex read FDefaultGrabberIndex write SetDefaultGrabberIndex default -1;\r\n\r\n // The cleanup threshold. When a grabber has finished grabbing it is placed\r\n // in the \"Cleanup\" list. The grabber cannot be destroyed immediately as\r\n // events may still be trigerred for it. Hence it is placed in the list\r\n // and this list is not emptied every time but only when it contains more\r\n // elements than the value of CleanupThreshold.\r\n property CleanupThreshold: Cardinal read FCleanupThreshold write FCleanupThreshold default 10;\r\n\r\n // Maximum number of grabbers running simultaneously. 0 means no limit.\r\n property MaxSimultaneousGrabbers: Integer read FMaxSimultaneousGrabbers write SetMaxSimultaneousGrabbers default 0;\r\n\r\n // The Urls to grab\r\n property URLs: TStrings read GetURLs write SetURLs;\r\n // The default properties for each family of grabber\r\n property DefaultGrabbersProperties: TJvUrlGrabberDefaultPropertiesList read FDefaultGrabbersProperties;\r\n\r\n // Events from Grabbers\r\n property OnDoneFile: TJvGrabberDoneFileEvent read FOnDoneFile write FOnDoneFile;\r\n property OnDoneStream: TJvGrabberDoneStreamEvent read FOnDoneStream write FOnDoneStream;\r\n property OnError: TJvGrabberErrorEvent read FOnError write FOnError;\r\n property OnProgress: TJvGrabberProgressEvent read FOnProgress write FOnProgress;\r\n property OnResolvingName: TJvGrabberNotifyEvent read FOnResolvingName write FOnResolvingName;\r\n property OnNameResolved: TJvGrabberNotifyEvent read FOnNameResolved write FOnNameResolved;\r\n property OnConnectingToServer: TJvGrabberNotifyEvent read FOnConnectingToServer write FOnConnectingToServer;\r\n property OnConnectedToServer: TJvGrabberNotifyEvent read FOnConnectedToServer write FOnConnectedToServer;\r\n property OnSendingRequest: TJvGrabberNotifyEvent read FOnSendingRequest write FOnSendingRequest;\r\n property OnRequestSent: TJvGrabberNotifyEvent read FOnRequestSent write FOnRequestSent;\r\n property OnRequestComplete: TJvGrabberNotifyEvent read FOnRequestComplete write FOnRequestComplete;\r\n property OnReceivingResponse: TJvGrabberNotifyEvent read FOnReceivingResponse write FOnReceivingResponse;\r\n property OnResponseReceived: TJvGrabberNotifyEvent read FOnResponseReceived write FOnResponseReceived;\r\n property OnClosingConnection: TJvGrabberNotifyEvent read FOnClosingConnection write FOnClosingConnection;\r\n property OnConnectionClosed: TJvGrabberNotifyEvent read FOnConnectionClosed write FOnConnectionClosed;\r\n property OnRedirect: TJvGrabberNotifyEvent read FOnRedirect write FOnRedirect;\r\n property OnStatusChange: TJvGrabberNotifyEvent read FOnStatusChange write FOnStatusChange;\r\n\r\n // Events for component\r\n property OnGrabberCreated: TJvGrabberCreatedEvent read FOnGrabberCreated write FOnGrabberCreated;\r\n property OnGrabberAdded: TJvGrabberAddedEvent read FOnGrabberAdded write FOnGrabberAdded;\r\n end;\r\n\r\n // forward declarations\r\n TJvCustomUrlGrabberThread = class;\r\n TJvCustomUrlGrabberThreadClass = class of TJvCustomUrlGrabberThread;\r\n TJvCustomUrlGrabberDefaultProperties = class;\r\n\r\n // a trick for the Delphi editor that allows to have a sub object\r\n // for each member of the a TJvUrlGrabberDefaultPropertiesList\r\n // Because an indexed property cannot be published, the editor\r\n // for TJvUrlGrabberDefaultPropertiesList enumerates all the\r\n // items in the list, and passes the EditorTrick property of\r\n // each of its TJvUrlGrabberDefaultProperties members. The\r\n // trick contains only one published property that gets displayed\r\n // and this property points to the TJvUrlGrabberDefaultPropertiesList\r\n // object to which the trick belongs, thus allowing to publish\r\n // the indexed property. The only drawback is that the name\r\n // in the property editor for each object is the same, DefaultProperties\r\n // Hence, the need for an editor for TJvUrlGrabberDefPropEdTrick that\r\n // displays a meaningful name instead\r\n TJvUrlGrabberDefPropEdTrick = class(TPersistent)\r\n private\r\n FDefaultProperties: TJvCustomUrlGrabberDefaultProperties;\r\n public\r\n constructor Create(GrabberDefaults: TJvCustomUrlGrabberDefaultProperties); reintroduce; virtual;\r\n published\r\n property DefaultProperties: TJvCustomUrlGrabberDefaultProperties read FDefaultProperties;\r\n end;\r\n\r\n // A container for Default properties, and a list of such\r\n // containers\r\n TJvCustomUrlGrabberDefaultProperties = class(TPersistent)\r\n private\r\n FEditorTrick: TJvUrlGrabberDefPropEdTrick;\r\n // agent to impersonate\r\n FAgent: string;\r\n // Port to connect to\r\n FPort: Cardinal;\r\n // user information\r\n FUserName: string;\r\n FPassword: string;\r\n // filename to use\r\n FFileName: TFileName;\r\n // output mode (stream or file)\r\n FOutputMode: TJvOutputMode;\r\n protected\r\n // The user-friendly name of the supported URL type\r\n function GetSupportedURLName: string; virtual; abstract;\r\n // The agent to impersonate\r\n property Agent: string read FAgent write FAgent;\r\n // The port to connect to\r\n property Port: Cardinal read FPort write FPort;\r\n // the user name and password to use for authentication\r\n property UserName: string read FUserName write FUserName;\r\n property Password: string read FPassword write FPassword;\r\n public\r\n constructor Create(AOwner: TJvUrlGrabberDefaultPropertiesList); reintroduce; virtual;\r\n destructor Destroy; override;\r\n // for some odd reason, Assign needs to be overriden\r\n procedure Assign(Source: TPersistent); override;\r\n property EditorTrick: TJvUrlGrabberDefPropEdTrick read FEditorTrick;\r\n property SupportedURLName: string read GetSupportedURLName;\r\n published\r\n // the name of the file to write to if OutputMode is omFile\r\n property FileName: TFileName read FFileName write FFileName;\r\n // The output mode\r\n property OutputMode: TJvOutputMode read FOutputMode write FOutputMode default omStream;\r\n end;\r\n\r\n TJvCustomUrlGrabberDefaultPropertiesClass = class of TJvCustomUrlGrabberDefaultProperties;\r\n\r\n TJvUrlGrabberDefaultPropertiesList = class(TPersistent)\r\n private\r\n FItems: TObjectList;\r\n function GetItemsNamed(Name: string): TJvCustomUrlGrabberDefaultProperties;\r\n function GetCount: Integer;\r\n function GetItems(Index: Integer): TJvCustomUrlGrabberDefaultProperties;\r\n procedure SetItems(Index: Integer; const Value: TJvCustomUrlGrabberDefaultProperties);\r\n public\r\n constructor Create(AOwner: TJvUrlListGrabber); reintroduce; virtual;\r\n destructor Destroy; override;\r\n procedure Read(Reader: TReader);\r\n procedure Write(Writer: TWriter);\r\n procedure Clear;\r\n procedure Add(Item: TJvCustomUrlGrabberDefaultProperties);\r\n property Count: Integer read GetCount;\r\n property Items[Index: Integer]: TJvCustomUrlGrabberDefaultProperties read GetItems write SetItems;\r\n property ItemsNamed[Name: string]: TJvCustomUrlGrabberDefaultProperties read GetItemsNamed; default;\r\n end;\r\n\r\n // the status of a grabber\r\n TJvGrabberStatus = (gsStopped, gsConnecting, gsGrabbing, gsStopping);\r\n\r\n // The exception triggered if someone tries to set the Url property while the\r\n // grabber is not stopped\r\n EGrabberNotStopped = class(Exception);\r\n\r\n // The event type used when a grabbing has had some progress\r\n TJvUrlGrabberProgressEvent = procedure(Sender: TObject; Position, TotalSize: Int64;\r\n Url: string; var Continue: Boolean) of object;\r\n\r\n // The ancestor of all the Url Grabbers that declares the required\r\n // methods that a grabber must provide.\r\n // Do not instanciate a TJvCustomUrlGrabber directly, simply use one\r\n // of its descendants. This family of classes is used by\r\n // TJvUrlListGrabber to allow downloading a list of URLs but can\r\n // also be used on their own to grad one URL of a given type.\r\n TJvCustomUrlGrabber = class(TJvComponent)\r\n private\r\n FId: Integer;\r\n // the thread that will grab for us\r\n FUrlGrabberThread: TJvCustomUrlGrabberThread;\r\n // events\r\n FOnDoneFile: TJvDoneFileEvent; // file is done\r\n FOnDoneStream: TJvDoneStreamEvent; // stream is done\r\n FOnError: TJvErrorEvent; // error occured\r\n FOnProgress: TJvUrlGrabberProgressEvent; // download progressed a bit\r\n FOnClosed: TNotifyEvent; // connection is closed\r\n FOnReceiving: TNotifyEvent; // beginning to receive\r\n FOnReceived: TNotifyEvent; // end of reception\r\n FOnConnecting: TNotifyEvent; // beginning of connection\r\n FOnResolving: TNotifyEvent; // beginning of resolving URL\r\n FOnRedirect: TNotifyEvent; // redirection happened\r\n FOnConnected: TNotifyEvent; // now connected to host\r\n //FOnStateChange: TNotifyEvent; // state of connection changed\r\n FOnResolved: TNotifyEvent; // name has been resolved\r\n FOnClosing: TNotifyEvent; // beginning of close of connection\r\n FOnRequest: TNotifyEvent; // sending a request\r\n FOnSent: TNotifyEvent; // data sent\r\n FOnSending: TNotifyEvent; // beginning to send data\r\n FOnStatusChange: TNotifyEvent; // Status changed\r\n // current status of the grabber\r\n FStatus: TJvGrabberStatus;\r\n // URL to grab\r\n FUrl: string;\r\n // the stream to grab into.\r\n FStream: TMemoryStream;\r\n // agent to impersonate\r\n FAgent: string;\r\n // port to connect to\r\n FPort: Cardinal;\r\n // user information\r\n FUserName: string;\r\n FPassword: string;\r\n // filename to use\r\n FFileName: TFileName;\r\n // output mode (stream or file)\r\n FOutputMode: TJvOutputMode;\r\n // size of the file to grab\r\n FSize: Int64;\r\n // What has been read so far\r\n FBytesRead: Int64;\r\n protected\r\n // Event callers\r\n procedure DoError(ErrorMsg: string);\r\n procedure DoProgress(Position: Integer; var Continue: Boolean);\r\n procedure DoStatus; virtual;\r\n procedure DoEnded;\r\n procedure DoClosed;\r\n procedure SetSize(Value: Int64);\r\n procedure SetBytesRead(Value: Int64);\r\n function GetGrabberThreadClass: TJvCustomUrlGrabberThreadClass; virtual; abstract;\r\n procedure SetUrl(Value: string); virtual;\r\n property UrlGrabberThread: TJvCustomUrlGrabberThread read FUrlGrabberThread;\r\n property Stream: TMemoryStream read FStream write FStream;\r\n public\r\n constructor Create(AOwner: TComponent); overload; override;\r\n constructor Create(AOwner: TComponent; AUrl: string;\r\n DefaultProperties: TJvCustomUrlGrabberDefaultProperties); reintroduce; overload;\r\n destructor Destroy; override;\r\n // this function must return True if the given URL can be grabbed\r\n // by the class being asked. It returns False otherwise\r\n // It MUST be overriden in the derived classes but cannot be abstract\r\n // because of BCB compatibility issues (no support for abstract\r\n // - pure virtual - class functions in the C++ language)\r\n class function CanGrab(const Url: string): Boolean; virtual;\r\n // This function returns the class of a property holder to\r\n // be displayed in the object inspector. This property holder\r\n // will be used by TJvUrlListGrabber to let the user specify default\r\n // properties and will be passed to this class when created to\r\n // handle a specific URL.\r\n // It MUST be overriden in the derived classes but cannot be abstract\r\n // because of BCB compatibility issues (no support for abstract\r\n // - pure virtual - class functions in the C++ language)\r\n class function GetDefaultPropertiesClass: TJvCustomUrlGrabberDefaultPropertiesClass; virtual;\r\n // This function returns the marker that indicates the protocol in a URL.\r\n // For instance, for an HTTP grabber, this would return 'http://'\r\n // It MUST be overriden in the derived classes but cannot be abstract\r\n // because of BCB compatibility issues (no support for abstract\r\n // - pure virtual - class functions in the C++ language)\r\n class function GetSupportedProtocolMarker: string; virtual;\r\n // this function must return a user displayable string indicating\r\n // the type of URL that class of grabber supports.\r\n // It MUST be overriden in the derived classes but cannot be abstract\r\n // because of BCB compatibility issues (no support for abstract\r\n // - pure virtual - class functions in the C++ language)\r\n class function GetSupportedURLName: string; virtual;\r\n // Splits the given URL into its various parts, if indicated\r\n // A URL respects this format:\r\n // protocol [username[:password]@] host [:port] [/filename]\r\n // When a non compulsory part is missing the exit value of the\r\n // associated parameter will be an empty string or 0\r\n class procedure ParseUrl(URL: string; Protocol: string; var Host: string; var FileName: string;\r\n var UserName: string; var Password: string; var Port: Cardinal); virtual;\r\n\r\n class function GetFormattedUrl(const URL: string): string;\r\n\r\n // Asks to Start to grab the URL\r\n procedure Start; virtual;\r\n // Asks to Stop to grab the URL\r\n procedure Stop; virtual;\r\n // The status of the grab\r\n property Status: TJvGrabberStatus read FStatus;\r\n // The size of the file being grabbed\r\n property Size: Int64 read FSize;\r\n // What has been read so far\r\n property BytesRead: Int64 read FBytesRead;\r\n // the Url being grabbed\r\n property Url: string read FUrl write SetUrl;\r\n // The port to connect to\r\n property Port: Cardinal read FPort write FPort;\r\n // the user name and password to use for authentication\r\n property UserName: string read FUserName write FUserName;\r\n property Password: string read FPassword write FPassword;\r\n // the name of the file to write to if OutputMode is omFile\r\n property FileName: TFileName read FFileName write FFileName;\r\n // The output mode\r\n property OutputMode: TJvOutputMode read FOutputMode write FOutputMode default omFile;\r\n // The agent to impersonate\r\n property Agent: string read FAgent write FAgent;\r\n // A numerical Id, to be freely used by the user of the component\r\n property Id: Integer read FId write FId;\r\n // Events\r\n property OnDoneFile: TJvDoneFileEvent read FOnDoneFile write FOnDoneFile;\r\n property OnDoneStream: TJvDoneStreamEvent read FOnDoneStream write FOnDoneStream;\r\n property OnError: TJvErrorEvent read FOnError write FOnError;\r\n property OnProgress: TJvUrlGrabberProgressEvent read FOnProgress write FOnProgress;\r\n property OnResolvingName: TNotifyEvent read FOnResolving write FOnResolving;\r\n property OnNameResolved: TNotifyEvent read FOnResolved write FOnResolved;\r\n property OnConnectingToServer: TNotifyEvent read FOnConnecting write FOnConnecting;\r\n property OnConnectedToServer: TNotifyEvent read FOnConnected write FOnConnected;\r\n property OnSendingRequest: TNotifyEvent read FOnSending write FOnSending;\r\n property OnRequestSent: TNotifyEvent read FOnSent write FOnSent;\r\n property OnRequestComplete: TNotifyEvent read FOnRequest write FOnRequest;\r\n property OnReceivingResponse: TNotifyEvent read FOnReceiving write FOnReceiving;\r\n property OnResponseReceived: TNotifyEvent read FOnReceived write FOnReceived;\r\n property OnClosingConnection: TNotifyEvent read FOnClosing write FOnClosing;\r\n property OnConnectionClosed: TNotifyEvent read FOnClosed write FOnClosed;\r\n property OnRedirect: TNotifyEvent read FOnRedirect write FOnRedirect;\r\n property OnStatusChange: TNotifyEvent read FOnStatusChange write FOnStatusChange;\r\n end;\r\n\r\n // A thread that will grab the given URL in the background\r\n // this is the ancestor of all the grabber threads, and there\r\n // should be as many descendants as there are TJvCustomUrlGrabber\r\n // descendants.\r\n TJvCustomUrlGrabberThread = class(TJvCustomThread)\r\n private\r\n FErrorText: string; // the error string received from the server\r\n FStatus: DWORD;\r\n FContinue: Boolean;\r\n protected\r\n FGrabber: TJvCustomUrlGrabber;\r\n\r\n procedure Execute; override;\r\n\r\n // Derived classes must not override Execute. They must instead override\r\n // Grab which is called by this class' Execute. This is done to ensure\r\n // that all derived classes will always set the status back to gsStopped\r\n // and trigger the OnConnectionClosed event at the end.\r\n procedure Grab; virtual; abstract;\r\n\r\n procedure Error;\r\n procedure Ended;\r\n procedure Closed;\r\n\r\n procedure UpdateGrabberProgress;\r\n procedure UpdateGrabberStatus;\r\n\r\n // Procedure used by derived classes to set the value of FStatus\r\n // which is a private member of TJvCustomUrlGrabber\r\n procedure SetGrabberStatus(Status: TJvGrabberStatus);\r\n\r\n property ErrorText: string read FErrorText write FErrorText;\r\n property Continue: Boolean read FContinue write FContinue;\r\n public\r\n constructor Create(Grabber: TJvCustomUrlGrabber); virtual;\r\n procedure DoProgress;\r\n procedure DoStatus;\r\n property Status: DWORD read FStatus write FStatus;\r\n end;\r\n\r\n // A list of instances of TJvUrlGrabber descendants\r\n // This is used internally by TJvUrlListGrabber to keep track of\r\n // the objects in charge of every URLs it has to grab\r\n TJvUrlGrabberList = class(TObjectList)\r\n private\r\n function GetItem(Index: Integer): TJvCustomUrlGrabber;\r\n procedure SetItem(Index: Integer; const AGrabber: TJvCustomUrlGrabber);\r\n public\r\n function Add(AGrabber: TJvCustomUrlGrabber): Integer;\r\n procedure Insert(Index: Integer; AGrabber: TJvCustomUrlGrabber);\r\n property Items[Index: Integer]: TJvCustomUrlGrabber read GetItem write SetItem; default;\r\n end;\r\n\r\n TJvCustomUrlGrabberClass = class of TJvCustomUrlGrabber;\r\n\r\n // A list of classes inheriting from TJvCustomUrlGrabber\r\n // This is the type of list used by the JvUrlGrabberClassList\r\n // function that returns all the registered classes.\r\n // This list is then used by TJvUrlListGrabber to determine which\r\n // class is best suited for handling a given URL\r\n TJvUrlGrabberClassList = class(TClassList)\r\n private\r\n function GetItem(Index: Integer): TJvCustomUrlGrabberClass;\r\n procedure SetItem(Index: Integer; const AGrabberClass: TJvCustomUrlGrabberClass);\r\n public\r\n procedure Populate(DefaultPropertiesList: TJvUrlGrabberDefaultPropertiesList);\r\n function Add(AGrabberClass: TJvCustomUrlGrabberClass): Integer;\r\n procedure Insert(Index: Integer; AGrabberClass: TJvCustomUrlGrabberClass);\r\n function CreateFor(Owner: TComponent; Url: string; DefaultPropertiesList: TJvUrlGrabberDefaultPropertiesList):\r\n TJvCustomUrlGrabber;\r\n property Items[Index: Integer]: TJvCustomUrlGrabberClass read GetItem write SetItem; default;\r\n end;\r\n\r\nfunction JvUrlGrabberClassList: TJvUrlGrabberClassList;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvUrlListGrabber.pas $';\r\n Revision: '$Revision: 13414 $';\r\n Date: '$Date: 2012-09-09 14:00:18 +0200 (dim. 09 sept. 2012) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n JvResources,\r\n // JvUrlGrabbers MUST be included here so that the grabbers\r\n // it contains are registered before any JvUrlListGrabber\r\n // component reads its properties.\r\n JvUrlGrabbers;\r\n\r\nvar\r\n // the global object to contain the list of registered\r\n // url grabber classes\r\n GJvUrlGrabberClassList: TJvUrlGrabberClassList = nil;\r\n\r\nfunction JvUrlGrabberClassList: TJvUrlGrabberClassList;\r\nbegin\r\n if not Assigned(GJvUrlGrabberClassList) then\r\n GJvUrlGrabberClassList := TJvUrlGrabberClassList.Create;\r\n Result := GJvUrlGrabberClassList;\r\nend;\r\n\r\n//=== { TJvUrlListGrabber } ==================================================\r\n\r\nconstructor TJvUrlListGrabber.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n\r\n FCleanupThreshold := 10;\r\n FCleanupList := TObjectList.Create(True);\r\n FDefaultGrabbersProperties := TJvUrlGrabberDefaultPropertiesList.Create(Self);\r\n FGrabbers := TJvUrlGrabberList.Create(True);\r\n FURLs := TStringList.Create;\r\n FURLs.OnChanging := URLsChanging;\r\n FDefaultGrabberIndex := -1;\r\nend;\r\n\r\ndestructor TJvUrlListGrabber.Destroy;\r\nbegin\r\n FURLs.Free;\r\n FGrabbers.Free;\r\n FDefaultGrabbersProperties.Free;\r\n FCleanupList.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvUrlListGrabber.Cleanup;\r\n{var\r\n I: Integer;}\r\nbegin\r\n{ // try to find each created grabber in the string list\r\n // if not found, mark the object as nil which in turn\r\n // will delete it\r\n for I := 0 to FGrabbers.Count - 1 do\r\n if FURLs.IndexOfObject(FGrabbers[I]) = -1 then\r\n FGrabbers[I] := nil;\r\n // pack the list\r\n FGrabbers.Pack;}\r\n FCleanupList.Clear;\r\nend;\r\n\r\nfunction TJvUrlListGrabber.GetGrabbers(const Index: Integer): TJvCustomUrlGrabber;\r\nbegin\r\n Result := FGrabbers[Index];\r\nend;\r\n\r\nprocedure TJvUrlListGrabber.SetDefaultGrabberIndex(const Value: TJvUrlGrabberIndex);\r\nbegin\r\n if Value < -1 then\r\n FDefaultGrabberIndex := -1\r\n else\r\n if Value > JvUrlGrabberClassList.Count - 1 then\r\n FDefaultGrabberIndex := -1\r\n else\r\n FDefaultGrabberIndex := Value;\r\nend;\r\n\r\nfunction TJvUrlListGrabber.GetURLs: TStrings;\r\nbegin\r\n Result := FURLs;\r\nend;\r\n\r\nprocedure TJvUrlListGrabber.SetURLs(const Value: TStrings);\r\nbegin\r\n FURLs.Assign(Value);\r\nend;\r\n\r\nprocedure TJvUrlListGrabber.DoGrabberCreated(Grabber: TJvCustomUrlGrabber);\r\nbegin\r\n if Assigned(OnGrabberCreated) then\r\n OnGrabberCreated(Self, Grabber);\r\nend;\r\n\r\nprocedure TJvUrlListGrabber.DoGrabberAdded(Grabber: TJvCustomUrlGrabber; Index: Integer);\r\nbegin\r\n if Assigned(OnGrabberAdded) then\r\n OnGrabberAdded(Self, Grabber, Index);\r\nend;\r\n\r\nfunction TJvUrlListGrabber.GetGrabberForUrl(const URL: string): TJvCustomUrlGrabber;\r\nbegin\r\n Result := JvUrlGrabberClassList.CreateFor(Self, URL, FDefaultGrabbersProperties);\r\n if not Assigned(Result) then\r\n if DefaultGrabberIndex > -1 then\r\n Result := JvUrlGrabberClassList[DefaultGrabberIndex].Create(Self, URL,\r\n FDefaultGrabbersProperties.Items[DefaultGrabberIndex])\r\n else\r\n raise ENoGrabberForUrl.CreateResFmt(@RsENoGrabberForUrl, [URL]);\r\n\r\n DoGrabberCreated(Result);\r\nend;\r\n\r\nprocedure TJvUrlListGrabber.StartNextGrabber;\r\nvar\r\n NewGrabber: TJvCustomUrlGrabber;\r\nbegin\r\n NewGrabber := GetGrabberForUrl(FURLs[FNextUrlIndex]);\r\n Inc(FNextUrlIndex); // Inc everytime to be thread safe\r\n SetGrabberEvents(NewGrabber);\r\n DoGrabberAdded(NewGrabber, FGrabbers.Add(NewGrabber));\r\n NewGrabber.Start;\r\nend;\r\n\r\nprocedure TJvUrlListGrabber.Start;\r\nvar\r\n I: Integer;\r\n MaxNewGrabbers: Integer;\r\nbegin\r\n // If at least one grabber is running, then do not start\r\n if GrabberCount > 0 then\r\n Exit;\r\n\r\n FGrabbers.Clear;\r\n\r\n if (MaxSimultaneousGrabbers = 0) or (FURLs.Count < MaxSimultaneousGrabbers) then\r\n MaxNewGrabbers := FURLs.Count\r\n else\r\n MaxNewGrabbers := MaxSimultaneousGrabbers;\r\n\r\n\r\n FNextUrlIndex := 0;\r\n for I := 0 to MaxNewGrabbers - 1 do\r\n StartNextGrabber;\r\nend;\r\n\r\n{$WARNINGS OFF} // hide deprecated warning when compiling the JVCL\r\nprocedure TJvUrlListGrabber.StartAll;\r\n{$WARNINGS ON}\r\nbegin\r\n Start;\r\nend;\r\n\r\nprocedure TJvUrlListGrabber.Stop;\r\nvar\r\n I: Integer;\r\nbegin\r\n FNextUrlIndex := FURLs.Count; // Prevent from creating new grabbers\r\n for I := 0 to GrabberCount - 1 do\r\n Grabbers[I].Stop;\r\nend;\r\n\r\n{$WARNINGS OFF} // hide deprecated warning when compiling the JVCL\r\nprocedure TJvUrlListGrabber.StopAll;\r\n{$WARNINGS ON}\r\nbegin\r\n Stop;\r\nend;\r\n\r\nprocedure TJvUrlListGrabber.URLsChanging(Sender: TObject);\r\nbegin\r\n // Prevent changing the URLs while at least one grabber is running\r\n if GrabberCount > 0 then\r\n raise EAtLeastOneGrabberRunning.CreateRes(@RsEAtLeastOneGrabberRunning);\r\nend;\r\n\r\nfunction TJvUrlListGrabber.GetGrabberCount: Integer;\r\nbegin\r\n Result := FGrabbers.Count;\r\nend;\r\n\r\nprocedure TJvUrlListGrabber.DefineProperties(Filer: TFiler);\r\nbegin\r\n inherited DefineProperties(Filer);\r\n Filer.DefineProperty('DefaultGrabbersPropertiesList',\r\n DefaultGrabbersProperties.Read, DefaultGrabbersProperties.Write, True);\r\nend;\r\n\r\nprocedure TJvUrlListGrabber.SetGrabberEvents(Grabber: TJvCustomUrlGrabber);\r\nbegin\r\n Grabber.OnClosingConnection := GrabberClosingConnection;\r\n Grabber.OnConnectedToServer := GrabberConnectedToServer;\r\n Grabber.OnConnectingToServer := GrabberConnectingToServer;\r\n Grabber.OnConnectionClosed := GrabberConnectionClosed;\r\n Grabber.OnNameResolved := GrabberNameResolved;\r\n Grabber.OnReceivingResponse := GrabberReceivingResponse;\r\n Grabber.OnRedirect := GrabberRedirect;\r\n Grabber.OnRequestComplete := GrabberRequestComplete;\r\n Grabber.OnRequestSent := GrabberRequestSent;\r\n Grabber.OnResolvingName := GrabberResolvingName;\r\n Grabber.OnResponseReceived := GrabberResponseReceived;\r\n Grabber.OnSendingRequest := GrabberSendingRequest;\r\n Grabber.OnStatusChange := GrabberStatusChange;\r\n Grabber.OnError := GrabberError;\r\n Grabber.OnProgress := GrabberProgress;\r\n Grabber.OnDoneFile := GrabberDoneFile;\r\n Grabber.OnDoneStream := GrabberDoneStream;\r\nend;\r\n\r\nprocedure TJvUrlListGrabber.GrabberClosingConnection(Grabber: TObject);\r\nbegin\r\n if Assigned(OnClosingConnection) then\r\n OnClosingConnection(Self, TJvCustomUrlGrabber(Grabber));\r\nend;\r\n\r\nprocedure TJvUrlListGrabber.GrabberConnectedToServer(Grabber: TObject);\r\nbegin\r\n if Assigned(OnConnectedToServer) then\r\n OnConnectedToServer(Self, TJvCustomUrlGrabber(Grabber));\r\nend;\r\n\r\nprocedure TJvUrlListGrabber.GrabberConnectingToServer(Grabber: TObject);\r\nbegin\r\n if Assigned(OnConnectingToServer) then\r\n OnConnectingToServer(Self, TJvCustomUrlGrabber(Grabber));\r\nend;\r\n\r\nprocedure TJvUrlListGrabber.GrabberConnectionClosed(Grabber: TObject);\r\nbegin\r\n // Grabber has closed connection, meaning that it has finished, hence we check\r\n // the cleanup threshold, move the finished grabber to the cleanup list and\r\n // start a new grabber if there are URLs left\r\n if Cardinal(FCleanupList.Count) = CleanupThreshold then\r\n FCleanupList.Clear;\r\n\r\n FCleanupList.Add(FGrabbers.Extract(Grabber));\r\n\r\n if FNextUrlIndex < FURLs.Count then\r\n StartNextGrabber;\r\n\r\n if Assigned(OnConnectionClosed) then\r\n OnConnectionClosed(Self, TJvCustomUrlGrabber(Grabber));\r\nend;\r\n\r\nprocedure TJvUrlListGrabber.GrabberNameResolved(Grabber: TObject);\r\nbegin\r\n if Assigned(OnNameResolved) then\r\n OnNameResolved(Self, TJvCustomUrlGrabber(Grabber));\r\nend;\r\n\r\nprocedure TJvUrlListGrabber.GrabberReceivingResponse(Grabber: TObject);\r\nbegin\r\n if Assigned(OnReceivingResponse) then\r\n OnReceivingResponse(Self, TJvCustomUrlGrabber(Grabber));\r\nend;\r\n\r\nprocedure TJvUrlListGrabber.GrabberRedirect(Grabber: TObject);\r\nbegin\r\n if Assigned(OnRedirect) then\r\n OnRedirect(Self, TJvCustomUrlGrabber(Grabber));\r\nend;\r\n\r\nprocedure TJvUrlListGrabber.GrabberRequestComplete(Grabber: TObject);\r\nbegin\r\n if Assigned(OnRequestComplete) then\r\n OnRequestComplete(Self, TJvCustomUrlGrabber(Grabber));\r\nend;\r\n\r\nprocedure TJvUrlListGrabber.GrabberRequestSent(Grabber: TObject);\r\nbegin\r\n if Assigned(OnRequestSent) then\r\n OnRequestSent(Self, TJvCustomUrlGrabber(Grabber));\r\nend;\r\n\r\nprocedure TJvUrlListGrabber.GrabberResolvingName(Grabber: TObject);\r\nbegin\r\n if Assigned(OnResolvingName) then\r\n OnResolvingName(Self, TJvCustomUrlGrabber(Grabber));\r\nend;\r\n\r\nprocedure TJvUrlListGrabber.GrabberResponseReceived(Grabber: TObject);\r\nbegin\r\n if Assigned(OnResponseReceived) then\r\n OnResponseReceived(Self, TJvCustomUrlGrabber(Grabber));\r\nend;\r\n\r\nprocedure TJvUrlListGrabber.GrabberSendingRequest(Grabber: TObject);\r\nbegin\r\n if Assigned(OnSendingRequest) then\r\n OnSendingRequest(Self, TJvCustomUrlGrabber(Grabber));\r\nend;\r\n\r\nprocedure TJvUrlListGrabber.GrabberStatusChange(Grabber: TObject);\r\nbegin\r\n if Assigned(OnStatusChange) then\r\n OnStatusChange(Self, TJvCustomUrlGrabber(Grabber));\r\nend;\r\n\r\nprocedure TJvUrlListGrabber.GrabberDoneFile(Grabber: TObject; FileName: string;\r\n FileSize: Integer; Url: string);\r\nbegin\r\n if Assigned(OnDoneFile) then\r\n OnDoneFile(Self, TJvCustomUrlGrabber(Grabber), FileName, FileSize, Url);\r\nend;\r\n\r\nprocedure TJvUrlListGrabber.GrabberDoneStream(Grabber: TObject; Stream: TStream;\r\n StreamSize: Integer; Url: string);\r\nbegin\r\n if Assigned(OnDoneStream) then\r\n OnDoneStream(Self, TJvCustomUrlGrabber(Grabber), Stream, StreamSize, Url);\r\nend;\r\n\r\nprocedure TJvUrlListGrabber.GrabberError(Grabber: TObject; ErrorMsg: string);\r\nbegin\r\n if Assigned(OnError) then\r\n OnError(Self, TJvCustomUrlGrabber(Grabber), ErrorMsg);\r\nend;\r\n\r\nprocedure TJvUrlListGrabber.GrabberProgress(Grabber: TObject; Position, TotalSize: Int64;\r\n Url: string; var Continue: Boolean);\r\nbegin\r\n if Assigned(OnProgress) then\r\n OnProgress(Self, TJvCustomUrlGrabber(Grabber), Position, TotalSize, Url, Continue);\r\nend;\r\n\r\n//=== { TJvCustomUrlGrabber } ================================================\r\n\r\nconstructor TJvCustomUrlGrabber.Create(AOwner: TComponent; AUrl: string;\r\n DefaultProperties: TJvCustomUrlGrabberDefaultProperties);\r\nbegin\r\n inherited Create(AOwner);\r\n FUrlGrabberThread := nil;\r\n\r\n // get values from the default properties\r\n Agent := DefaultProperties.Agent;\r\n UserName := DefaultProperties.UserName;\r\n Password := DefaultProperties.Password;\r\n FileName := DefaultProperties.FileName;\r\n OutputMode := DefaultProperties.OutputMode;\r\n Port := DefaultProperties.Port;\r\n\r\n // Set the URL at the end so that the SetUrl method is called\r\n // and might setup the various other properties automatically\r\n Url := AUrl;\r\nend;\r\n\r\nconstructor TJvCustomUrlGrabber.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n\r\n // Set default properties\r\n Agent := RsJediAgent;\r\n Port := 0;\r\n UserName := '';\r\n Password := '';\r\n FileName := RsDefaultOutputFileName;\r\n OutputMode := omFile;\r\nend;\r\n\r\ndestructor TJvCustomUrlGrabber.Destroy;\r\nbegin\r\n Stop; // Stop grabbing\r\n inherited Destroy;\r\nend;\r\n\r\nclass function TJvCustomUrlGrabber.CanGrab(const Url: string): Boolean;\r\nbegin\r\n // useless implementation required for BCB compatibility as\r\n // C++ doesn't support abstract virtual class methods\r\n Result := False;\r\nend;\r\n\r\nprocedure TJvCustomUrlGrabber.SetUrl(Value: string);\r\nvar\r\n ProtocolMarker: string;\r\n TmpHostName: string;\r\n TmpFileName: string;\r\n TmpUserName: string;\r\n TmpPassword: string;\r\n TmpPort: Cardinal;\r\nbegin\r\n if Status = gsStopped then\r\n begin\r\n // if the given URL contains Port, UserName and Password informations, we set the\r\n // different properties of the grabber automatically\r\n ProtocolMarker := GetSupportedProtocolMarker;\r\n ParseUrl(Value, ProtocolMarker, TmpHostName, TmpFileName, TmpUserName, TmpPassword, TmpPort);\r\n if TmpUserName <> '' then\r\n UserName := TmpUserName;\r\n if TmpPassword <> '' then\r\n Password := TmpPassword;\r\n if TmpPort <> 0 then\r\n Port := TmpPort;\r\n\r\n FUrl := GetFormattedUrl(Value);\r\n end\r\n else\r\n raise EGrabberNotStopped.CreateRes(@RsEGrabberNotStopped);\r\nend;\r\n\r\nprocedure TJvCustomUrlGrabber.DoClosed;\r\nbegin\r\n if Assigned(FOnClosed) then\r\n FOnClosed(Self);\r\nend;\r\n\r\nprocedure TJvCustomUrlGrabber.DoEnded;\r\nbegin\r\n Stream.Position := 0;\r\n if FOutputMode = omStream then\r\n begin\r\n if Assigned(FOnDoneStream) then\r\n FOnDoneStream(Self, Stream, Stream.Size, FUrl);\r\n end\r\n else\r\n begin\r\n Stream.SaveToFile(FFileName);\r\n if Assigned(FOnDoneFile) then\r\n FOnDoneFile(Self, FFileName, Stream.Size, FUrl);\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomUrlGrabber.DoError(ErrorMsg: string);\r\nbegin\r\n if Assigned(FOnError) then\r\n FOnError(Self, ErrorMsg);\r\nend;\r\n\r\nprocedure TJvCustomUrlGrabber.DoProgress(Position: Integer; var Continue: Boolean);\r\nbegin\r\n if Assigned(FOnProgress) then\r\n FOnProgress(Self, Position, FSize, Url, Continue);\r\nend;\r\n\r\nprocedure TJvCustomUrlGrabber.DoStatus;\r\nbegin\r\n if Assigned(FOnStatusChange) then\r\n FOnStatusChange(Self);\r\nend;\r\n\r\nclass function TJvCustomUrlGrabber.GetDefaultPropertiesClass: TJvCustomUrlGrabberDefaultPropertiesClass;\r\nbegin\r\n // useless implementation for BCB Compatibility\r\n Result := nil;\r\nend;\r\n\r\nprocedure TJvCustomUrlGrabber.Start;\r\nbegin\r\n // Stop the grabbing before restarting\r\n Stop;\r\n\r\n // Create a new thread\r\n FUrlGrabberThread := GetGrabberThreadClass.Create(Self);\r\n FUrlGrabberThread.{$IFDEF COMPILER14_UP}Start{$ELSE}Resume{$ENDIF COMPILER14_UP};\r\nend;\r\n\r\nprocedure TJvCustomUrlGrabber.Stop;\r\nbegin\r\n if Assigned(FUrlGrabberThread) then\r\n begin\r\n // If there is a thread, ask it to terminate and then free it.\r\n // This will ensure that everything is cleanly destroyed (Mantis 3824).\r\n FUrlGrabberThread.Terminate;\r\n FUrlGrabberThread.Free;\r\n FUrlGrabberThread := nil; // To avoid crashing if calling \"Stop\" twice or more.\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomUrlGrabber.SetSize(Value: Int64);\r\nbegin\r\n FSize := Value;\r\nend;\r\n\r\nprocedure TJvCustomUrlGrabber.SetBytesRead(Value: Int64);\r\nbegin\r\n FBytesRead := Value;\r\nend;\r\n\r\nclass function TJvCustomUrlGrabber.GetSupportedProtocolMarker: string;\r\nbegin\r\n // Useless implementation for BCB compatibility\r\n Result := '';\r\nend;\r\n\r\nclass function TJvCustomUrlGrabber.GetSupportedURLName: string;\r\nbegin\r\n // Useless implementation for BCB compatibility\r\n Result := '';\r\nend;\r\n\r\nclass function TJvCustomUrlGrabber.GetFormattedUrl(const URL: string): string;\r\nvar\r\n ProtocolMarker: string;\r\n TmpHostName: string;\r\n TmpFileName: string;\r\n TmpUserName: string;\r\n TmpPassword: string;\r\n TmpPort: Cardinal;\r\nbegin\r\n ProtocolMarker := GetSupportedProtocolMarker;\r\n ParseUrl(URL, ProtocolMarker, TmpHostName, TmpFileName, TmpUserName, TmpPassword, TmpPort);\r\n\r\n Result := ProtocolMarker;\r\n if TmpHostName <> '' then\r\n Result := Result + TmpHostName + '/';\r\n if TmpFileName <> '' then\r\n Result := Result + TmpFileName;\r\nend;\r\n\r\nclass procedure TJvCustomUrlGrabber.ParseUrl(URL: string; Protocol: string;\r\n var Host: string; var FileName: string; var UserName: string;\r\n var Password: string; var Port: Cardinal);\r\nvar\r\n Ps: Integer;\r\nbegin\r\n // Default return values\r\n Host := '';\r\n FileName := '';\r\n UserName := '';\r\n Password := '';\r\n Port := 0;\r\n\r\n // Remove the protocol part from the given Value\r\n if Pos(UpperCase(Protocol), UpperCase(URL)) <> 0 then\r\n URL := Copy(URL, Length(Protocol) + 1, Length(URL));\r\n\r\n // Get the filename, if any\r\n if Pos('/', URL) <> 0 then\r\n begin\r\n Ps := Pos('/', URL);\r\n Host := Copy(URL, 1, Ps - 1);\r\n FileName := Copy(URL, Ps + 1, Length(URL));\r\n end\r\n else\r\n Host := URL;\r\n\r\n // Get the username password couple\r\n Ps := Pos('@', Host);\r\n if Ps <> 0 then\r\n begin\r\n UserName := Copy(Host, 1, Ps - 1);\r\n Host := Copy(Host, Ps + 1, Length(Host));\r\n // now, figure out if there is a password\r\n Ps := Pos(':', UserName);\r\n if Ps <> 0 then\r\n begin\r\n Password := Copy(UserName, Ps + 1, Length(UserName));\r\n UserName := Copy(UserName, 1, Ps - 1);\r\n end;\r\n end;\r\n\r\n // Get the port\r\n Ps := Pos(':', Host);\r\n if Ps <> 0 then\r\n begin\r\n Port := StrToIntDef(Copy(Host, Ps + 1, Length(Host)), 0);\r\n Host := Copy(Host, 1, Ps - 1);\r\n end;\r\nend;\r\n\r\n//=== { TJvUrlGrabberList } ==================================================\r\n\r\nfunction TJvUrlGrabberList.Add(AGrabber: TJvCustomUrlGrabber): Integer;\r\nbegin\r\n Result := inherited Add(AGrabber);\r\nend;\r\n\r\nfunction TJvUrlGrabberList.GetItem(Index: Integer): TJvCustomUrlGrabber;\r\nbegin\r\n Result := TJvCustomUrlGrabber(inherited Items[Index]);\r\nend;\r\n\r\nprocedure TJvUrlGrabberList.Insert(Index: Integer; AGrabber: TJvCustomUrlGrabber);\r\nbegin\r\n inherited Insert(Index, AGrabber);\r\nend;\r\n\r\nprocedure TJvUrlGrabberList.SetItem(Index: Integer; const AGrabber: TJvCustomUrlGrabber);\r\nbegin\r\n inherited Items[Index] := AGrabber;\r\nend;\r\n\r\n//=== { TJvCustomUrlGrabberClassList } =======================================\r\n\r\nfunction TJvUrlGrabberClassList.Add(AGrabberClass: TJvCustomUrlGrabberClass): Integer;\r\nbegin\r\n Result := inherited Add(AGrabberClass);\r\nend;\r\n\r\nfunction TJvUrlGrabberClassList.CreateFor(Owner: TComponent; Url: string;\r\n DefaultPropertiesList: TJvUrlGrabberDefaultPropertiesList): TJvCustomUrlGrabber;\r\nvar\r\n I: Integer;\r\nbegin\r\n I := 0;\r\n Result := nil;\r\n while (I < Count) and not Assigned(Result) do\r\n begin\r\n if Items[I].CanGrab(Url) then\r\n Result := Items[I].Create(Owner, Url, DefaultPropertiesList.Items[I]);\r\n Inc(I);\r\n end;\r\nend;\r\n\r\nfunction TJvUrlGrabberClassList.GetItem(Index: Integer): TJvCustomUrlGrabberClass;\r\nbegin\r\n Result := TJvCustomUrlGrabberClass(inherited Items[Index]);\r\nend;\r\n\r\nprocedure TJvUrlGrabberClassList.Insert(Index: Integer;\r\n AGrabberClass: TJvCustomUrlGrabberClass);\r\nbegin\r\n inherited Insert(Index, AGrabberClass);\r\nend;\r\n\r\nprocedure TJvUrlGrabberClassList.Populate(DefaultPropertiesList: TJvUrlGrabberDefaultPropertiesList);\r\nvar\r\n I: Integer;\r\nbegin\r\n DefaultPropertiesList.Clear;\r\n for I := 0 to Count - 1 do\r\n DefaultPropertiesList.Add(Items[I].GetDefaultPropertiesClass.Create(DefaultPropertiesList));\r\nend;\r\n\r\nprocedure TJvUrlGrabberClassList.SetItem(Index: Integer;\r\n const AGrabberClass: TJvCustomUrlGrabberClass);\r\nbegin\r\n inherited Items[Index] := AGrabberClass;\r\nend;\r\n\r\n//=== { TJvCustomUrlGrabberThread } ==========================================\r\n\r\nprocedure TJvCustomUrlGrabberThread.Closed;\r\nbegin\r\n FGrabber.DoClosed;\r\nend;\r\n\r\nconstructor TJvCustomUrlGrabberThread.Create(Grabber: TJvCustomUrlGrabber);\r\nbegin\r\n inherited Create(True);\r\n FContinue := True;\r\n FGrabber := Grabber;\r\n ThreadName := Format('%s: %s',[ClassName, Grabber.Name]);\r\nend;\r\n\r\nprocedure TJvCustomUrlGrabberThread.DoProgress;\r\nbegin\r\n Synchronize(UpdateGrabberProgress);\r\nend;\r\n\r\nprocedure TJvCustomUrlGrabberThread.DoStatus;\r\nbegin\r\n Synchronize(UpdateGrabberStatus);\r\nend;\r\n\r\nprocedure TJvCustomUrlGrabberThread.Ended;\r\nbegin\r\n FGrabber.DoEnded;\r\nend;\r\n\r\nprocedure TJvCustomUrlGrabberThread.Error;\r\nbegin\r\n FGrabber.FStatus := gsStopped;\r\n FGrabber.DoError(FErrorText);\r\nend;\r\n\r\nprocedure TJvCustomUrlGrabberThread.Execute;\r\nbegin\r\n NameThread(ThreadName);\r\n SetGrabberStatus(gsStopped);\r\n FGrabber.Stream := nil;\r\n try\r\n Grab;\r\n finally\r\n //Free all stuff's\r\n FGrabber.Stream.Free;\r\n FGrabber.Stream := nil;\r\n\r\n // Signal Closed, after having changed the state of the grabber\r\n SetGrabberStatus(gsStopped);\r\n Synchronize(Closed);\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomUrlGrabberThread.SetGrabberStatus(\r\n Status: TJvGrabberStatus);\r\nbegin\r\n FGrabber.FStatus := Status;\r\nend;\r\n\r\nprocedure TJvCustomUrlGrabberThread.UpdateGrabberProgress;\r\nbegin\r\n FGrabber.DoProgress(FGrabber.BytesRead, FContinue);\r\nend;\r\n\r\nprocedure TJvCustomUrlGrabberThread.UpdateGrabberStatus;\r\nbegin\r\n FGrabber.DoStatus;\r\nend;\r\n\r\n//=== { TJvUrlGrabberDefaultPropertiesList } =================================\r\n\r\nconstructor TJvUrlGrabberDefaultPropertiesList.Create(AOwner: TJvUrlListGrabber);\r\nbegin\r\n inherited Create;\r\n FItems := TObjectList.Create(True);\r\n JvUrlGrabberClassList.Populate(Self);\r\nend;\r\n\r\ndestructor TJvUrlGrabberDefaultPropertiesList.Destroy;\r\nbegin\r\n FItems.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvUrlGrabberDefaultPropertiesList.Add(Item: TJvCustomUrlGrabberDefaultProperties);\r\nbegin\r\n FItems.Add(Item);\r\nend;\r\n\r\nprocedure TJvUrlGrabberDefaultPropertiesList.Clear;\r\nbegin\r\n FItems.Clear;\r\nend;\r\n\r\nfunction TJvUrlGrabberDefaultPropertiesList.GetCount: Integer;\r\nbegin\r\n Result := FItems.Count;\r\nend;\r\n\r\nfunction TJvUrlGrabberDefaultPropertiesList.GetItems(Index: Integer): TJvCustomUrlGrabberDefaultProperties;\r\nbegin\r\n Result := TJvCustomUrlGrabberDefaultProperties(FItems[Index]);\r\nend;\r\n\r\nprocedure TJvUrlGrabberDefaultPropertiesList.SetItems(Index: Integer;\r\n const Value: TJvCustomUrlGrabberDefaultProperties);\r\nbegin\r\n FItems[Index] := Value;\r\nend;\r\n\r\nfunction TJvUrlGrabberDefaultPropertiesList.GetItemsNamed(Name: string): TJvCustomUrlGrabberDefaultProperties;\r\nvar\r\n I: Integer;\r\nbegin\r\n I := 0;\r\n Result := nil;\r\n while (I < Count) and (Result = nil) do\r\n begin\r\n if Items[I].SupportedURLName = Name then\r\n Result := Items[I];\r\n Inc(I);\r\n end;\r\nend;\r\n\r\n//=== { TJvUrlGrabberDefPropEdTrick } ========================================\r\n\r\nconstructor TJvUrlGrabberDefPropEdTrick.Create(GrabberDefaults: TJvCustomUrlGrabberDefaultProperties);\r\nbegin\r\n if Assigned(GrabberDefaults) then\r\n FDefaultProperties := GrabberDefaults;\r\nend;\r\n\r\n//=== { TDFMPropertiesCollection } ===========================================\r\n\r\ntype\r\n // In order to store the Default Properties for every possible\r\n // grabber class, we have to deal with it ourselves. This is not\r\n // an easy task because the types of the default property holders\r\n // are not known while writing this class. Moreover, the streaming\r\n // system used by Delphi is not really well documented and the\r\n // only (not so) elegant way I found to stream the list of default\r\n // properties holder is to use WriteCollection and ReadCollection.\r\n // To do this, we need a collection but having TJvUrlGrabberDefaultPropertiesList\r\n // as a TCollection is too problematic because its members are\r\n // always descendents of TJvCustomUrlGrabberDefaultProperties.\r\n // So what I do here is to have a TCollection/TCollectionItem couple\r\n // that will be used to read and write the list from the DFM.\r\n // It works quite well and shouldn't need much improvement.\r\n TDFMPropertiesCollectionItem = class(TCollectionItem)\r\n private\r\n FOwnValue: Boolean;\r\n FValue: TJvCustomUrlGrabberDefaultProperties;\r\n FUrlType: string;\r\n procedure SetValue(const Value: TJvCustomUrlGrabberDefaultProperties);\r\n procedure SetUrlType(const Value: string);\r\n public\r\n destructor Destroy; override;\r\n constructor Create(Collection: TCollection); override;\r\n published\r\n property UrlType: string read FUrlType write SetUrlType;\r\n property Value: TJvCustomUrlGrabberDefaultProperties read FValue write SetValue;\r\n end;\r\n\r\n TDFMPropertiesCollection = class(TCollection)\r\n public\r\n constructor Create; reintroduce; overload;\r\n constructor Create(List: TJvUrlGrabberDefaultPropertiesList); reintroduce; overload;\r\n end;\r\n\r\nconstructor TDFMPropertiesCollection.Create;\r\nbegin\r\n inherited Create(TDFMPropertiesCollectionItem);\r\nend;\r\n\r\nconstructor TDFMPropertiesCollection.Create(List: TJvUrlGrabberDefaultPropertiesList);\r\nvar\r\n I: Integer;\r\nbegin\r\n inherited Create(TDFMPropertiesCollectionItem);\r\n for I := 0 to List.Count - 1 do\r\n begin\r\n Add;\r\n TDFMPropertiesCollectionItem(Items[Count - 1]).Value := List.Items[I];\r\n end;\r\nend;\r\n\r\n//=== { TDFMPropertiesCollectionItem } =======================================\r\n\r\nconstructor TDFMPropertiesCollectionItem.Create(Collection: TCollection);\r\nbegin\r\n inherited Create(Collection);\r\nend;\r\n\r\ndestructor TDFMPropertiesCollectionItem.Destroy;\r\nbegin\r\n if FOwnValue then\r\n FValue.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TDFMPropertiesCollectionItem.SetValue(const Value: TJvCustomUrlGrabberDefaultProperties);\r\nbegin\r\n FValue := Value;\r\n FOwnValue := False;\r\n if Assigned(FValue) then\r\n FUrlType := FValue.GetSupportedURLName;\r\nend;\r\n\r\nprocedure TDFMPropertiesCollectionItem.SetUrlType(const Value: string);\r\nvar\r\n I: Integer;\r\nbegin\r\n FUrlType := Value;\r\n if not Assigned(FValue) then\r\n begin\r\n for I := 0 to JvUrlGrabberClassList.Count - 1 do\r\n if JvUrlGrabberClassList[I].GetSupportedURLName = Value then\r\n begin\r\n FOwnValue := True;\r\n FValue := JvUrlGrabberClassList[I].GetDefaultPropertiesClass.Create(nil);\r\n end;\r\n end;\r\nend;\r\n\r\n//=== { TJvCustomUrlGrabberDefaultProperties } ===============================\r\n\r\nconstructor TJvCustomUrlGrabberDefaultProperties.Create(AOwner: TJvUrlGrabberDefaultPropertiesList);\r\nbegin\r\n inherited Create;\r\n FEditorTrick := TJvUrlGrabberDefPropEdTrick.Create(Self);\r\n\r\n FAgent := RsJediAgent;\r\n FUserName := '';\r\n FPassword := '';\r\n FFileName := RsDefaultOutputFileName;\r\n FOutputMode := omFile;\r\nend;\r\n\r\ndestructor TJvCustomUrlGrabberDefaultProperties.Destroy;\r\nbegin\r\n FEditorTrick.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvCustomUrlGrabberDefaultProperties.Assign(Source: TPersistent);\r\nbegin\r\n if Source is TJvCustomUrlGrabberDefaultProperties then\r\n with Source as TJvCustomUrlGrabberDefaultProperties do\r\n begin\r\n Self.Agent := Agent;\r\n Self.Port := Port;\r\n Self.Password := Password;\r\n Self.UserName := UserName;\r\n Self.FileName := FileName;\r\n Self.OutputMode := OutputMode;\r\n end\r\n else\r\n inherited Assign(Source);\r\nend;\r\n\r\nprocedure TJvUrlGrabberDefaultPropertiesList.Read(Reader: TReader);\r\nvar\r\n I, J: Integer;\r\n TmpColl: TDFMPropertiesCollection;\r\nbegin\r\n // WARNING: The call to ReadValue is essential for the collection to\r\n // be read correctly. Somehow, WriteCollection writes something that\r\n // ReadCollection won't read on its own.\r\n Reader.ReadValue;\r\n\r\n TmpColl := TDFMPropertiesCollection.Create;\r\n try\r\n Reader.ReadCollection(TmpColl);\r\n for I := 0 to TmpColl.Count - 1 do\r\n begin\r\n for J := 0 to Count - 1 do\r\n if TDFMPropertiesCollectionItem(TmpColl.Items[I]).Value.GetSupportedURLName = Items[I].GetSupportedURLName then\r\n Items[I].Assign(TDFMPropertiesCollectionItem(TmpColl.Items[I]).Value);\r\n end;\r\n finally\r\n TmpColl.Free;\r\n end;\r\nend;\r\n\r\nprocedure TJvUrlGrabberDefaultPropertiesList.Write(Writer: TWriter);\r\nvar\r\n TmpColl: TDFMPropertiesCollection;\r\nbegin\r\n TmpColl := TDFMPropertiesCollection.Create(Self);\r\n try\r\n Writer.WriteCollection(TmpColl);\r\n finally\r\n TmpColl.Free;\r\n end;\r\nend;\r\n\r\nprocedure TJvUrlListGrabber.SetMaxSimultaneousGrabbers(\r\n const Value: Integer);\r\nbegin\r\n if FMaxSimultaneousGrabbers <> Value then\r\n begin\r\n FMaxSimultaneousGrabbers := Value;\r\n if FMaxSimultaneousGrabbers < 0 then\r\n FMaxSimultaneousGrabbers := 0;\r\n end;\r\nend;\r\n\r\ninitialization\r\n {$IFDEF UNITVERSIONING}\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n {$ENDIF UNITVERSIONING}\r\n\r\nfinalization\r\n FreeAndNil(GJvUrlGrabberClassList);\r\n {$IFDEF UNITVERSIONING}\r\n UnregisterUnitVersion(HInstance);\r\n {$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvValidateEdit.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is JvValidateEdit, released on 20 February 2003,\r\n by Christopher Latta\r\nPortions created by Christopher Latta are Copyright (C) 2003 Christopher Latta.\r\nAll Rights Reserved.\r\n\r\nContributor(s): Peter Thornqvist\r\n Peter Schraut (http://www.console-dev.de)\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL\r\nhome page, located at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\nTJvValidateFormat uses the SysUtils.Format function to format numeric values.\r\nWhile this uses the Windows regional settings for the currency symbol, decimal\r\nseparator and thousands separator, it does not format using the negative symbol,\r\nnegative number format, negative currency format and positive currency format.\r\nThis could be rectified by a custom-written formatting routine.\r\n\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvValidateEdit.pas 13415 2012-09-10 09:51:54Z obones $\r\n\r\nunit JvValidateEdit;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, Messages, Controls, Graphics,\r\n SysUtils, Classes,\r\n JvEdit, JvDataSourceIntf;\r\n\r\ntype\r\n TJvValidateEditDisplayFormat = (dfAlphabetic, dfAlphaNumeric, dfBinary,\r\n dfCheckChars, dfCurrency, dfCustom, dfFloat, dfFloatGeneral, dfHex, dfInteger,\r\n dfNonCheckChars, dfNone, dfOctal, dfPercent, dfScientific, dfYear, dfDecimal,\r\n dfIdentifier, dfFloatFixed);\r\n\r\n TJvValidateEditCriticalPointsCheck = (cpNone, cpMinValue, cpMaxValue, cpBoth);\r\n\r\n TJvCustomValidateEdit = class;\r\n\r\n TJvValidateEditDataConnector = class(TJvFieldDataConnector)\r\n private\r\n FEdit: TJvCustomValidateEdit;\r\n FNullValue: Variant;\r\n procedure SetNullValue(const Value: Variant);\r\n function IsNullValueStored: Boolean;\r\n protected\r\n procedure RecordChanged; override;\r\n procedure UpdateData; override;\r\n public\r\n constructor Create(AEdit: TJvCustomValidateEdit);\r\n procedure Assign(Source: TPersistent); override;\r\n property Control: TJvCustomValidateEdit read FEdit;\r\n published\r\n property NullValue: Variant read FNullValue write SetNullValue stored IsNullValueStored;\r\n end;\r\n\r\n TJvValidateEditCriticalPoints = class(TPersistent)\r\n private\r\n FCheckPoints: TJvValidateEditCriticalPointsCheck;\r\n FColorAbove: TColor;\r\n FColorBelow: TColor;\r\n FMaxValue: Double;\r\n FMinValue: Double;\r\n FMaxValueIncluded: Boolean;\r\n FMinValueIncluded: Boolean;\r\n FOnChange: TNotifyEvent;\r\n FDefCheckPoints: TJvValidateEditCriticalPointsCheck;\r\n FDefColorAbove: TColor;\r\n FDefColorBelow: TColor;\r\n procedure DoChanged;\r\n procedure SetMinValue(NewValue: Double);\r\n procedure SetMaxValue(NewValue: Double);\r\n procedure SetColorAbove(NewValue: TColor);\r\n procedure SetColorBelow(NewValue: TColor);\r\n procedure SetCheckPoints(NewValue: TJvValidateEditCriticalPointsCheck);\r\n function IsCheckPointsStored: Boolean;\r\n function IsColorAboveStored: Boolean;\r\n function IsColorBelowStored: Boolean;\r\n public\r\n procedure Assign(Source: TPersistent); override;\r\n procedure SetDefaults(ACheckPoints: TJvValidateEditCriticalPointsCheck;\r\n AColorAbove, AColorBelow: TColor);\r\n constructor Create;\r\n published\r\n property CheckPoints: TJvValidateEditCriticalPointsCheck read FCheckPoints\r\n write SetCheckPoints stored IsCheckPointsStored;\r\n property ColorAbove: TColor read FColorAbove write SetColorAbove stored IsColorAboveStored;\r\n property ColorBelow: TColor read FColorBelow write SetColorBelow stored IsColorBelowStored;\r\n property MaxValue: Double read FMaxValue write SetMaxValue;\r\n property MinValue: Double read FMinValue write SetMinValue;\r\n property MaxValueIncluded: Boolean read FMaxValueIncluded write FMaxValueIncluded;\r\n property MinValueIncluded: Boolean read FMinValueIncluded write FMinValueIncluded;\r\n property OnChange: TNotifyEvent read FOnChange write FOnChange;\r\n end;\r\n\r\n TJvCustomTextValidateEvent = procedure(Sender: TObject; Key: Char;\r\n const AText: string; const Pos: Integer; var IsValid: Boolean) of object;\r\n TJvCustomIsValidEvent = procedure(Sender: TObject; var IsValid: Boolean) of object;\r\n TJvCustomDecimalRoundingEvent = procedure(Sender: TObject; var DecimalRoundedValue: Double;\r\n const Value: Double) of object;\r\n\r\n TJvCustomValidateEdit = class(TJvCustomEdit)\r\n private\r\n FSelfChange: Boolean;\r\n FCheckChars: string;\r\n FDecimalPlaces: Cardinal;\r\n FDisplayFormat: TJvValidateEditDisplayFormat;\r\n FEditText: string;\r\n FHasMaxValue: Boolean;\r\n FHasMinValue: Boolean;\r\n FMaxValue: Double;\r\n FMinValue: Double;\r\n FOnCustomValidate: TJvCustomTextValidateEvent;\r\n FOnValueChanged: TNotifyEvent;\r\n FZeroEmpty: Boolean;\r\n FEnterText: string;\r\n FDisplayPrefix: string;\r\n FDisplaySuffix: string;\r\n FCriticalPoints: TJvValidateEditCriticalPoints;\r\n FStandardFontColor: TColor;\r\n FAutoAlignment: Boolean;\r\n FTrimDecimals: Boolean;\r\n FOldFontChange: TNotifyEvent;\r\n FOnIsValid: TJvCustomIsValidEvent;\r\n FOnDecimalRounding: TJvCustomDecimalRoundingEvent;\r\n FAllowEmpty: Boolean;\r\n FEnforcingMinMaxValue: Boolean;\r\n FForceDecimalSeparatorInput: Boolean;\r\n FLastDownKey: Word;\r\n procedure DisplayText;\r\n function ScientificStrToFloat(SciString: string): Double;\r\n procedure SetHasMaxValue(NewValue: Boolean);\r\n procedure SetHasMinValue(NewValue: Boolean);\r\n procedure SetMaxValue(NewValue: Double);\r\n procedure SetMinValue(NewValue: Double);\r\n procedure SetDecimalPlaces(NewValue: Cardinal);\r\n procedure SetDisplayFormat(NewValue: TJvValidateEditDisplayFormat);\r\n procedure SetZeroEmpty(NewValue: Boolean);\r\n function GetAsInteger: Int64;\r\n procedure SetAsInteger(NewValue: Int64);\r\n function GetAsCurrency: Currency;\r\n procedure SetAsCurrency(NewValue: Currency);\r\n function GetAsFloat: Double;\r\n procedure SetAsFloat(NewValue: Double);\r\n function GetValue: Variant;\r\n procedure SetValue(NewValue: Variant);\r\n procedure SetCheckChars(const NewValue: string);\r\n function IsCheckCharsStored: Boolean;\r\n function CurrRangeValue(CheckValue: Currency): Currency; overload;\r\n function FloatRangeValue(CheckValue: Double): Double; overload;\r\n function IntRangeValue(CheckValue: Int64): Int64; overload;\r\n function GetEditText: string;\r\n procedure SetEditText(const NewValue: string);\r\n procedure ChangeText(const NewValue: string);\r\n function BaseToInt(const BaseValue: string; Base: Byte): Int64;\r\n function IntToBase(NewValue: Int64; Base: Byte): string;\r\n procedure DoValueChanged;\r\n procedure SetDisplayPrefix(const NewValue: string);\r\n procedure SetDisplaySuffix(const NewValue: string);\r\n procedure CriticalPointsChange(Sender: TObject);\r\n procedure SetFontColor;\r\n procedure FontChange(Sender: TObject);\r\n procedure EnforceMaxValue;\r\n procedure EnforceMinValue;\r\n procedure SetTrimDecimals(const Value: Boolean);\r\n function GetUnprefixedUnsuffixedText(const Value: string): string;\r\n protected\r\n function IsValidChar(const S: string; var Key: Char; Posn: Integer): Boolean; virtual;\r\n function MakeValid(const ParseString: string): string;virtual;\r\n procedure Change; override;\r\n procedure FocusKilled(NextWnd: THandle); override;\r\n procedure FocusSet(PrevWnd: THandle); override;\r\n procedure WMPaste(var Msg: TMessage); message WM_PASTE;\r\n procedure SetText(const NewValue: TCaption); override;\r\n property CheckChars: string read FCheckChars write SetCheckChars\r\n stored IsCheckCharsStored;\r\n property TrimDecimals: Boolean read FTrimDecimals write SetTrimDecimals;\r\n property DecimalPlaces: Cardinal read FDecimalPlaces write SetDecimalPlaces;\r\n property DisplayFormat: TJvValidateEditDisplayFormat read FDisplayFormat\r\n write SetDisplayFormat;\r\n property EditText: string read GetEditText write SetEditText;\r\n property HasMaxValue: Boolean read FHasMaxValue write SetHasMaxValue;\r\n property HasMinValue: Boolean read FHasMinValue write SetHasMinValue;\r\n property MaxValue: Double read FMaxValue write SetMaxValue;\r\n property MinValue: Double read FMinValue write SetMinValue;\r\n property OnCustomValidate: TJvCustomTextValidateEvent\r\n read FOnCustomValidate write FOnCustomValidate;\r\n property OnValueChanged: TNotifyEvent read FOnValueChanged write FOnValueChanged;\r\n property OnDecimalRounding: TJvCustomDecimalRoundingEvent read FOnDecimalRounding write FOnDecimalRounding;\r\n property Value: Variant read GetValue write SetValue stored False;\r\n property AllowEmpty: Boolean read FAllowEmpty write FAllowEmpty;\r\n property ZeroEmpty: Boolean read FZeroEmpty write SetZeroEmpty;\r\n property DisplayPrefix: string read FDisplayPrefix write SetDisplayPrefix;\r\n property DisplaySuffix: string read FDisplaySuffix write SetDisplaySuffix;\r\n property CriticalPoints: TJvValidateEditCriticalPoints read FCriticalPoints\r\n write FCriticalPoints;\r\n property AutoAlignment: Boolean read FAutoAlignment write FAutoAlignment;\r\n procedure KeyDown(var Key: Word; Shift: TShiftState); override;\r\n procedure KeyPress(var Key: Char); override;\r\n procedure KeyUp(var Key: Word; Shift: TShiftState); override;\r\n function DoValidate(const Key: Char; const AText: string;\r\n const Posn: Integer): Boolean;\r\n procedure Loaded; override;\r\n\r\n function CreateDataConnector: TJvFieldDataConnector; override;\r\n\r\n property OnIsValid: TJvCustomIsValidEvent read FOnIsValid write FOnIsValid;\r\n\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n\r\n function IsValid: Boolean; virtual; // fires OnIsValid if assigned\r\n\r\n // When the DecimalSeparator variable has changed, one should call\r\n // RecalcCheckChars to ensure that it contains the new value (Mantis 4682)\r\n procedure RecalcCheckChars;\r\n\r\n procedure Assign(Source: TPersistent); override;\r\n property AsInteger: Int64 read GetAsInteger write SetAsInteger;\r\n property AsCurrency: Currency read GetAsCurrency write SetAsCurrency;\r\n property AsFloat: Double read GetAsFloat write SetAsFloat;\r\n\r\n // If true and the user presses the VK_DECIMAL key, the key read in KeyPress\r\n // will always be replaced by the value of DecimalSeparator. This is made\r\n // to overcome the problem where some keyboard layouts send \".\" instead of\r\n // the decimal separator when using the decimal key on the numerical keypad.\r\n // The most commonly encountered layout is the French AZERTY one.\r\n // Note that this property will be set automatically to True by the\r\n // constructor when the conversion of VK_DECIMAL into a character does not\r\n // return the DecimalSeparator value\r\n property ForceDecimalSeparatorInput: Boolean read FForceDecimalSeparatorInput write FForceDecimalSeparatorInput;\r\n end;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvValidateEdit = class(TJvCustomValidateEdit)\r\n published\r\n property AllowEmpty default False;\r\n property Align;\r\n property Alignment default taRightJustify;\r\n property Anchors;\r\n property AutoAlignment default True;\r\n\r\n property AutoSelect;\r\n property AutoSize;\r\n property BiDiMode;\r\n property DragCursor;\r\n property DragKind;\r\n property Flat;\r\n property ImeMode;\r\n property ImeName;\r\n property OEMConvert;\r\n property ParentBiDiMode;\r\n property ParentFlat;\r\n property OnEndDock;\r\n property OnStartDock;\r\n property BevelEdges;\r\n property BevelInner;\r\n property BevelKind default bkNone;\r\n property BevelOuter;\r\n property BorderStyle;\r\n property Caret;\r\n property CheckChars;\r\n property CharCase;\r\n property ClipboardCommands;\r\n property Color;\r\n property Constraints;\r\n property CriticalPoints;\r\n property DisabledColor;\r\n property DisabledTextColor;\r\n property TrimDecimals default False;\r\n property DisplayFormat default dfInteger;\r\n property DecimalPlaces default 0;\r\n property DisplayPrefix;\r\n property DisplaySuffix;\r\n property DragMode;\r\n property EditText;\r\n property Enabled;\r\n property Font;\r\n property HasMaxValue default False;\r\n property HasMinValue default False;\r\n property HideSelection;\r\n property MaxLength;\r\n property MaxValue;\r\n property MinValue;\r\n property ParentColor;\r\n property ParentFont;\r\n property ParentShowHint;\r\n property PasswordChar;\r\n property PopupMenu;\r\n property ReadOnly;\r\n property ShowHint;\r\n property TabOrder;\r\n property TabStop;\r\n property Text stored False;\r\n property Value;\r\n property Visible;\r\n property ZeroEmpty default False;\r\n property OnChange;\r\n property OnClick;\r\n property OnContextPopup;\r\n property OnCustomValidate;\r\n property OnDblClick;\r\n property OnDragDrop;\r\n property OnDragOver;\r\n property OnEndDrag;\r\n property OnEnter;\r\n property OnExit;\r\n property OnKeyDown;\r\n property OnKeyPress;\r\n property OnKeyUp;\r\n property OnMouseDown;\r\n property OnMouseEnter;\r\n property OnMouseLeave;\r\n property OnMouseMove;\r\n property OnMouseUp;\r\n property OnStartDrag;\r\n property OnValueChanged;\r\n property OnIsValid;\r\n property OnDecimalRounding;\r\n property DataConnector;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile:\r\n '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvValidateEdit.pas $';\r\n Revision: '$Revision: 13415 $';\r\n Date: '$Date: 2012-09-10 11:51:54 +0200 (lun. 10 sept. 2012) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n Math,\r\n VarUtils, Variants,\r\n JclStrings, JvJCLUtils, JvResources, JclSysUtils;\r\n\r\nfunction IsGreater(Value, MaxValue: Double; MaxValueIncluded: Boolean): Boolean;\r\nbegin\r\n if MaxValueIncluded then\r\n Result := Value >= MaxValue\r\n else\r\n Result := Value > MaxValue;\r\nend;\r\n\r\nfunction IsLower(Value, MinValue: Double; MinValueIncluded: Boolean): Boolean;\r\nbegin\r\n if MinValueIncluded then\r\n Result := Value <= MinValue\r\n else\r\n Result := Value < MinValue;\r\nend;\r\n\r\n//=== { TJvValidateEditDataConnector } =======================================\r\n\r\nprocedure TJvValidateEditDataConnector.Assign(Source: TPersistent);\r\nbegin\r\n inherited Assign(Source);\r\n if Source is TJvFieldDataConnector then\r\n begin\r\n NullValue := TJvValidateEditDataConnector(Source).NullValue;\r\n end;\r\nend;\r\n\r\nconstructor TJvValidateEditDataConnector.Create(AEdit: TJvCustomValidateEdit);\r\nbegin\r\n inherited Create;\r\n FEdit := AEdit;\r\n VarClear(FNullValue);\r\nend;\r\n\r\nfunction TJvValidateEditDataConnector.IsNullValueStored: Boolean;\r\nbegin\r\n Result := not VarIsClear(NullValue);\r\nend;\r\n\r\nprocedure TJvValidateEditDataConnector.RecordChanged;\r\nbegin\r\n if Field.IsValid then\r\n begin\r\n FEdit.ReadOnly := not Field.CanModify;\r\n if not Field.IsNull then\r\n FEdit.Value := Field.Value\r\n else\r\n if NullValue <> Null then\r\n FEdit.Value := NullValue\r\n else\r\n FEdit.Text := '';\r\n end\r\n else\r\n begin\r\n FEdit.Text := '';\r\n FEdit.ReadOnly := False;\r\n end;\r\nend;\r\n\r\nprocedure TJvValidateEditDataConnector.SetNullValue(const Value: Variant);\r\nbegin\r\n if Value <> FNullValue then\r\n begin\r\n FNullValue := Value;\r\n Reset;\r\n end;\r\nend;\r\n\r\nprocedure TJvValidateEditDataConnector.UpdateData;\r\nbegin\r\n if Field.CanModify and Field.IsValid then\r\n begin\r\n if FEdit.Value <> Null then\r\n Field.Value := FEdit.Value\r\n else\r\n if NullValue <> Null then\r\n Field.Value := FNullValue\r\n else\r\n RecordChanged;\r\n end;\r\nend;\r\n\r\n//=== { TJvCustomValidateEdit } ==============================================\r\n\r\nconstructor TJvCustomValidateEdit.Create(AOwner: TComponent);\r\nvar\r\n MappedDecimal: Cardinal;\r\nconst\r\n MAPVK_VK_TO_CHAR = 2;\r\nbegin\r\n inherited Create(AOwner);\r\n FSelfChange := False;\r\n FAutoAlignment := True;\r\n FCriticalPoints := TJvValidateEditCriticalPoints.Create;\r\n FCriticalPoints.OnChange := CriticalPointsChange;\r\n FDisplayFormat := dfInteger;\r\n FCheckChars := '01234567890';\r\n Alignment := taRightJustify;\r\n FEditText := '';\r\n Text := ''; // doesn't trigger OnChange because FEnterText = ''. That's what we want.\r\n AutoSize := True;\r\n FMinValue := 0;\r\n FMaxValue := 0;\r\n FHasMinValue := False;\r\n FHasMaxValue := False;\r\n FZeroEmpty := False;\r\n FStandardFontColor := Font.Color;\r\n FOldFontChange := Font.OnChange;\r\n Font.OnChange := FontChange;\r\n\r\n MappedDecimal := MapVirtualKey(VK_DECIMAL, MAPVK_VK_TO_CHAR);\r\n if MappedDecimal <> 0 then\r\n FForceDecimalSeparatorInput := Char(MappedDecimal) <> JclFormatSettings.DecimalSeparator;\r\nend;\r\n\r\ndestructor TJvCustomValidateEdit.Destroy;\r\nbegin\r\n FreeAndNil(FCriticalPoints);\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvCustomValidateEdit.Assign(Source: TPersistent);\r\nvar\r\n lcSource: TJvCustomValidateEdit;\r\nbegin\r\n if Source is TJvCustomValidateEdit then\r\n begin\r\n lcSource := TJvCustomValidateEdit(Source);\r\n CriticalPoints.Assign(lcSource.CriticalPoints);\r\n DisplayFormat := lcSource.DisplayFormat;\r\n DecimalPlaces := lcSource.DecimalPlaces;\r\n MinValue := lcSource.MinValue;\r\n MaxValue := lcSource.MaxValue;\r\n HasMinValue := lcSource.HasMinValue;\r\n HasMaxValue := lcSource.HasMaxValue;\r\n ZeroEmpty := lcSource.ZeroEmpty;\r\n AllowEmpty := lcSource.AllowEmpty;\r\n end\r\n else\r\n inherited Assign(Source);\r\nend;\r\n\r\nprocedure TJvCustomValidateEdit.Loaded;\r\nbegin\r\n // (obones) Why is this necessary? It overrides DecimalPlaces set to 0 by the user\r\n{ if DisplayFormat = dfCurrency then\r\n if FDecimalPlaces = 0 then\r\n FDecimalPlaces := CurrencyDecimals;}\r\n DataConnector.Active := False;\r\n try\r\n EditText := FEditText;\r\n finally\r\n DataConnector.Active := True;\r\n end;\r\n inherited Loaded;\r\nend;\r\n\r\nfunction TJvCustomValidateEdit.CreateDataConnector: TJvFieldDataConnector;\r\nbegin\r\n Result := TJvValidateEditDataConnector.Create(Self);\r\nend;\r\n\r\nprocedure TJvCustomValidateEdit.SetHasMaxValue(NewValue: Boolean);\r\nbegin\r\n if FHasMaxValue <> NewValue then\r\n begin\r\n FHasMaxValue := NewValue;\r\n if not (csLoading in ComponentState) then\r\n EnforceMaxValue;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomValidateEdit.SetHasMinValue(NewValue: Boolean);\r\nbegin\r\n if FHasMinValue <> NewValue then\r\n begin\r\n FHasMinValue := NewValue;\r\n if not (csLoading in ComponentState) then\r\n EnforceMinValue;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomValidateEdit.SetMaxValue(NewValue: Double);\r\nbegin\r\n if FMaxValue <> NewValue then\r\n begin\r\n FMaxValue := NewValue;\r\n { make MinValue consistent }\r\n if FMinValue > FMaxValue then\r\n FMinValue := FMaxValue;\r\n if not (csLoading in ComponentState) then\r\n EnforceMaxValue;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomValidateEdit.SetMinValue(NewValue: Double);\r\nbegin\r\n if FMinValue <> NewValue then\r\n begin\r\n FMinValue := NewValue;\r\n { make MaxValue consistent }\r\n if FMaxValue < FMinValue then\r\n FMaxValue := FMinValue;\r\n if not (csLoading in ComponentState) then\r\n EnforceMinValue;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomValidateEdit.SetTrimDecimals(const Value: Boolean);\r\nbegin\r\n if Value <> FTrimDecimals then\r\n begin\r\n FTrimDecimals := Value;\r\n if not (csLoading in ComponentState) then\r\n EditText := FEditText;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomValidateEdit.SetDecimalPlaces(NewValue: Cardinal);\r\nbegin\r\n if ControlState = [csReadingState] then\r\n FDecimalPlaces := NewValue\r\n else\r\n if FDisplayFormat in [dfCurrency, dfFloat, dfFloatGeneral, dfScientific, dfPercent, dfFloatFixed] then\r\n FDecimalPlaces := NewValue;\r\n if not (csLoading in ComponentState) then\r\n EditText := FEditText;\r\nend;\r\n\r\nprocedure TJvCustomValidateEdit.SetDisplayFormat(NewValue: TJvValidateEditDisplayFormat);\r\nvar\r\n OldFormat: TJvValidateEditDisplayFormat;\r\nbegin\r\n if FDisplayFormat <> NewValue then\r\n begin\r\n OldFormat := FDisplayFormat;\r\n FDisplayFormat := NewValue;\r\n\r\n RecalcCheckChars;\r\n\r\n case FDisplayFormat of\r\n dfAlphabetic, dfAlphaNumeric, dfIdentifier,\r\n dfCheckChars, dfNonCheckChars, dfCustom, dfNone:\r\n if FAutoAlignment then\r\n Alignment := taLeftJustify;\r\n dfCurrency:\r\n begin\r\n if FAutoAlignment then\r\n Alignment := taRightJustify;\r\n if not (csLoading in ComponentState) then\r\n if FDecimalPlaces = 0 then\r\n FDecimalPlaces := JclFormatSettings.CurrencyDecimals;\r\n end;\r\n dfBinary, dfFloat, dfFloatGeneral, dfPercent, dfDecimal, dfHex,\r\n dfInteger, dfOctal, dfScientific, dfFloatFixed:\r\n if FAutoAlignment then\r\n Alignment := taRightJustify;\r\n dfYear:\r\n begin\r\n if FAutoAlignment then\r\n Alignment := taRightJustify;\r\n MaxLength := 4;\r\n end;\r\n end;\r\n\r\n if OldFormat = dfYear then\r\n MaxLength := 0;\r\n\r\n // Convert non-base 10 numbers to base 10 and base-10 numbers to non-base 10\r\n if (OldFormat = dfBinary) and\r\n (NewValue in [dfCurrency, dfFloat, dfFloatGeneral, dfDecimal, dfHex, dfInteger, dfOctal, dfPercent, dfScientific, dfYear, dfFloatFixed]) then\r\n SetAsInteger(BaseToInt(FEditText, 2))\r\n else\r\n if (OldFormat in [dfCurrency, dfFloat, dfFloatGeneral, dfDecimal, dfPercent, dfFloatFixed]) and\r\n (NewValue in [dfBinary, dfHex, dfOctal]) then\r\n SetAsFloat(JvSafeStrToFloatDef(FEditText, 0))\r\n else\r\n if (OldFormat = dfHex) and\r\n (NewValue in [dfBinary, dfCurrency, dfFloat, dfFloatGeneral, dfDecimal, dfInteger, dfOctal, dfPercent, dfScientific, dfYear, dfFloatFixed]) then\r\n SetAsInteger(BaseToInt(FEditText, 16))\r\n else\r\n if (OldFormat in [dfInteger, dfYear]) and\r\n (NewValue in [dfBinary, dfHex, dfOctal]) then\r\n SetAsInteger(StrToIntDef(FEditText, 0))\r\n else\r\n if (OldFormat = dfOctal) and\r\n (NewValue in [dfBinary, dfCurrency, dfFloat, dfFloatGeneral, dfDecimal, dfHex, dfInteger, dfPercent, dfScientific, dfYear, dfFloatFixed]) then\r\n SetAsInteger(BaseToInt(FEditText, 8))\r\n else\r\n begin\r\n // ...or just display the value\r\n if not (csLoading in ComponentState) then\r\n EditText := FEditText;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomValidateEdit.SetZeroEmpty(NewValue: Boolean);\r\nbegin\r\n if FZeroEmpty <> NewValue then\r\n begin\r\n FZeroEmpty := NewValue;\r\n if not (csLoading in ComponentState) then\r\n EditText := FEditText;\r\n end;\r\nend;\r\n\r\nfunction TJvCustomValidateEdit.GetAsInteger: Int64;\r\nbegin\r\n case FDisplayFormat of\r\n dfBinary:\r\n Result := BaseToInt(FEditText, 2);\r\n dfHex:\r\n Result := BaseToInt(FEditText, 16);\r\n dfOctal:\r\n Result := BaseToInt(FEditText, 8);\r\n else\r\n Result := StrToInt64Def(FEditText, 0);\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomValidateEdit.SetAsInteger(NewValue: Int64);\r\nbegin\r\n case FDisplayFormat of\r\n dfAlphabetic, dfAlphaNumeric, dfCheckChars, dfIdentifier, dfCustom,\r\n dfNonCheckChars, dfNone:\r\n EditText := IntToStr(NewValue);\r\n dfBinary:\r\n EditText := IntToBase(NewValue, 2);\r\n dfHex:\r\n EditText := IntToBase(NewValue, 16);\r\n dfOctal:\r\n EditText := IntToBase(NewValue, 8);\r\n dfCurrency, dfFloat, dfFloatGeneral, dfDecimal, dfInteger, dfPercent, dfScientific, dfYear, dfFloatFixed:\r\n EditText := IntToStr(IntRangeValue(NewValue));\r\n end;\r\nend;\r\n\r\nfunction TJvCustomValidateEdit.GetAsCurrency: Currency;\r\nbegin\r\n case FDisplayFormat of\r\n dfBinary:\r\n Result := BaseToInt(FEditText, 2);\r\n dfHex:\r\n Result := BaseToInt(FEditText, 16);\r\n dfOctal:\r\n Result := BaseToInt(FEditText, 8);\r\n else\r\n Result := StrToCurrDef(FEditText, 0);\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomValidateEdit.SetAsCurrency(NewValue: Currency);\r\nbegin\r\n case FDisplayFormat of\r\n dfAlphabetic, dfAlphaNumeric, dfCheckChars, dfIdentifier, dfCustom,\r\n dfNonCheckChars, dfNone:\r\n EditText := CurrToStr(NewValue);\r\n dfBinary:\r\n EditText := IntToBase(Trunc(NewValue), 2);\r\n dfHex:\r\n EditText := IntToBase(Trunc(NewValue), 16);\r\n dfOctal:\r\n EditText := IntToBase(Trunc(NewValue), 8);\r\n dfCurrency, dfFloat, dfFloatGeneral, dfDecimal, dfInteger, dfPercent, dfScientific, dfYear, dfFloatFixed:\r\n EditText := CurrToStr(CurrRangeValue(NewValue));\r\n end;\r\nend;\r\n\r\nfunction TJvCustomValidateEdit.GetAsFloat: Double;\r\nvar\r\n Cur: Currency;\r\nbegin\r\n case FDisplayFormat of\r\n dfBinary:\r\n Result := BaseToInt(FEditText, 2);\r\n dfHex:\r\n Result := BaseToInt(FEditText, 16);\r\n dfOctal:\r\n Result := BaseToInt(FEditText, 8);\r\n dfScientific:\r\n Result := ScientificStrToFloat(FEditText);\r\n dfCurrency:\r\n begin\r\n // Mantis 3494: The Edit text may contain extra characters such as\r\n // parenthesis that indicate the amount is negative. Using StrToFloatDef\r\n // would not catch the negative part, hence the need to use a function\r\n // that knows how to do the conversion.\r\n\r\n VarCyFromStr({$IFDEF RTL240_UP}PChar{$ENDIF RTL240_UP}(FEditText), LOCALE_USER_DEFAULT, 0, Cur);\r\n Result := Cur;\r\n end;\r\n else\r\n Result := JvSafeStrToFloatDef(FEditText, 0);\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomValidateEdit.SetAsFloat(NewValue: Double);\r\nbegin\r\n case FDisplayFormat of\r\n dfAlphabetic, dfAlphaNumeric, dfCheckChars, dfIdentifier, dfCustom,\r\n dfNonCheckChars, dfNone:\r\n EditText := FloatToStr(NewValue);\r\n dfBinary:\r\n EditText := IntToBase(Trunc(NewValue), 2);\r\n dfHex:\r\n EditText := IntToBase(Trunc(NewValue), 16);\r\n dfOctal: EditText := IntToBase(Trunc(NewValue), 8);\r\n dfInteger, dfYear:\r\n EditText := IntToStr(IntRangeValue(Trunc(NewValue)));\r\n dfCurrency:\r\n EditText := Format('%.*m', [FDecimalPlaces, FloatRangeValue(NewValue)]);\r\n dfFloat, dfPercent:\r\n EditText := Format('%.*n', [FDecimalPlaces, FloatRangeValue(NewValue)]);\r\n dfFloatGeneral:\r\n EditText := Format('%.*g', [FDecimalPlaces, FloatRangeValue(NewValue)]);\r\n dfFloatFixed:\r\n EditText := Format('%.*f', [FDecimalPlaces, FloatRangeValue(NewValue)]);\r\n dfDecimal:\r\n EditText := FloatToStr(FloatRangeValue(NewValue));\r\n dfScientific:\r\n EditText := Format('%e', [FloatRangeValue(NewValue)]);\r\n end;\r\nend;\r\n\r\nfunction TJvCustomValidateEdit.GetValue: Variant;\r\nvar\r\n DisplayedText: string;\r\n Cur: Currency;\r\nbegin\r\n case FDisplayFormat of\r\n dfCurrency:\r\n begin\r\n // Mantis 3494: The Edit text may contain extra characters such as\r\n // parenthesis that indicate the amount is negative. Using StrToFloatDef\r\n // would not catch the negative part, hence the need to use a function\r\n // that knows how to do the conversion.\r\n VarCyFromStr({$IFDEF RTL240_UP}PChar{$ENDIF RTL240_UP}(FEditText), LOCALE_USER_DEFAULT, 0, Cur);\r\n Result := Cur;\r\n end;\r\n dfFloat, dfFloatGeneral, dfDecimal, dfPercent, dfScientific, dfFloatFixed:\r\n Result := JvSafeStrToFloatDef(FEditText, 0);\r\n dfInteger, dfYear:\r\n Result := StrToIntDef(FEditText, 0);\r\n dfHex:\r\n Result := StrToIntDef('$' + FEditText, 0);\r\n else\r\n begin\r\n DisplayedText := inherited Text;\r\n\r\n // Remove DisplayPrefix and DisplaySuffix\r\n DisplayedText := StrEnsureNoPrefix(DisplayPrefix, DisplayedText);\r\n DisplayedText := StrEnsureNoSuffix(DisplaySuffix, DisplayedText);\r\n Result := DisplayedText;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomValidateEdit.SetValue(NewValue: Variant);\r\nbegin\r\n if AllowEmpty and (VarIsNull(NewValue) or VarIsEmpty(NewValue)) then\r\n Clear\r\n else\r\n case FDisplayFormat of\r\n dfAlphabetic, dfAlphaNumeric, dfCheckChars, dfNonCheckChars, dfIdentifier, dfNone, dfCustom:\r\n EditText := NewValue;\r\n dfBinary, dfHex, dfInteger, dfOctal, dfYear:\r\n SetAsInteger(NewValue);\r\n dfCurrency, dfFloat, dfDecimal, dfFloatGeneral, dfPercent, dfScientific, dfFloatFixed:\r\n SetAsFloat(NewValue);\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomValidateEdit.SetCheckChars(const NewValue: string);\r\nbegin\r\n if (csLoading in ComponentState) or\r\n ((FDisplayFormat in [dfNone, dfCheckChars, dfNonCheckChars]) and\r\n (FCheckChars <> NewValue)) then\r\n begin\r\n FCheckChars := NewValue;\r\n EditText := MakeValid(FEditText);\r\n end;\r\nend;\r\n\r\nfunction TJvCustomValidateEdit.IsCheckCharsStored: Boolean;\r\nbegin\r\n Result := (FDisplayFormat in [dfNone, dfCheckChars, dfNonCheckChars]);\r\nend;\r\n\r\nprocedure TJvCustomValidateEdit.KeyPress(var Key: Char);\r\nvar\r\n StrippedText: string;\r\nbegin\r\n // Mantis 4952:\r\n // - Must not take the prefix/suffix into account when checking a character's validity\r\n // - Must not take into account the CurrencyString into account when checking a character's validity\r\n StrippedText := GetUnprefixedUnsuffixedText(Text);\r\n\r\n if not IsValidChar(StrippedText, Key, SelStart + 1) and (Key >= #32) then\r\n Key := #0;\r\n inherited KeyPress(Key);\r\nend;\r\n\r\nprocedure TJvCustomValidateEdit.KeyUp(var Key: Word; Shift: TShiftState);\r\nbegin\r\n FLastDownKey := 0;\r\n inherited KeyUp(Key, Shift);\r\nend;\r\n\r\nprocedure TJvCustomValidateEdit.WMPaste(var Msg: TMessage);\r\nbegin\r\n inherited;\r\n EditText := MakeValid(GetUnprefixedUnsuffixedText(inherited Text));\r\nend;\r\n\r\nfunction TJvCustomValidateEdit.MakeValid(const ParseString: string): string;\r\nvar\r\n C: Char;\r\n I: Integer;\r\n L: Integer;\r\nbegin\r\n SetLength(Result, Length(ParseString));\r\n L := 0;\r\n for I := 1 to Length(ParseString) do\r\n begin\r\n C := ParseString[I];\r\n if IsValidChar(Copy(ParseString, 1, I - 1), C, I) then\r\n begin\r\n Result[L + 1] := C;\r\n Inc(L);\r\n end;\r\n end;\r\n SetLength(Result, L);\r\nend;\r\n\r\nprocedure TJvCustomValidateEdit.RecalcCheckChars;\r\nconst\r\n Alphabet = 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz';\r\n Numbers = '0123456789';\r\nbegin\r\n case FDisplayFormat of\r\n dfAlphabetic:\r\n FCheckChars := Alphabet;\r\n dfAlphaNumeric:\r\n FCheckChars := Alphabet + Numbers;\r\n dfIdentifier:\r\n FCheckChars := Alphabet + Numbers + '_';\r\n dfBinary:\r\n FCheckChars := '01';\r\n dfCustom, dfNone:\r\n if (FDisplayFormat = dfCustom) or not (csLoading in ComponentState) then\r\n FCheckChars := '';\r\n dfCurrency,\r\n dfFloat, dfFloatGeneral, dfPercent, dfDecimal, dfFloatFixed:\r\n FCheckChars := Numbers + JclFormatSettings.DecimalSeparator;\r\n dfHex:\r\n FCheckChars := Numbers + 'ABCDEFabcdef';\r\n dfInteger, dfYear:\r\n FCheckChars := Numbers;\r\n dfOctal:\r\n FCheckChars := '01234567';\r\n dfScientific:\r\n FCheckChars := Numbers + 'Ee' + JclFormatSettings.DecimalSeparator;\r\n end;\r\nend;\r\n\r\nfunction TJvCustomValidateEdit.IsValidChar(const S: string;\r\n var Key: Char; Posn: Integer): Boolean;\r\nvar\r\n iPosE: Integer;\r\n ExpectedNegPos: Integer;\r\n ExpectedNegChar: Char;\r\nbegin\r\n if (FLastDownKey = VK_DECIMAL) and ForceDecimalSeparatorInput then\r\n Key := JclFormatSettings.DecimalSeparator;\r\n\r\n case FDisplayFormat of\r\n dfBinary, dfCheckChars, dfHex, dfOctal, dfYear:\r\n Result := Pos(Key, FCheckChars) > 0;\r\n dfAlphabetic:\r\n Result := IsCharAlpha(Key);\r\n dfAlphaNumeric:\r\n Result := IsCharAlphaNumeric(Key);\r\n dfCustom:\r\n Result := DoValidate(Key, S, Posn);\r\n dfInteger:\r\n Result := (Pos(Key, FCheckChars) > 0) or\r\n ((Key = '+') and (Posn = 1) and ((Pos('+', S) = 0) or (SelLength > 0))) or\r\n ((Key = '-') and (Posn = 1) and ((Pos('-', S) = 0) or (SelLength > 0)));\r\n dfFloat, dfFloatGeneral, dfDecimal, dfPercent, dfFloatFixed:\r\n Result := ((Pos(Key, FCheckChars) > 0) and \r\n (((Key = JclFormatSettings.DecimalSeparator) and (Pos(JclFormatSettings.DecimalSeparator, S) = 0)) or (Key <> JclFormatSettings.DecimalSeparator))) or\r\n ((Key = '+') and (Posn = 1) and ((Pos('+', S) = 0) or (SelLength > 0))) or\r\n ((Key = '-') and (Posn = 1) and ((Pos('-', S) = 0) or (SelLength > 0)));\r\n dfCurrency:\r\n begin\r\n // The currency negative format can be quite complicated. The current\r\n // one is indicated by the value of NegCurrFormat, and can have any\r\n // value from 0 to 15 according to the MSDN and Delphi's help.\r\n // So we must take into account that some format require the negative\r\n // sign to be at the end, while some others replace it by parenthesis.\r\n // See http://www.delphibasics.co.uk/RTL.asp?Name=NegCurrFormat for\r\n // an online version of Delphi's help.\r\n // If we were not to use this, it would trigger Mantis 3494, where\r\n // the number would go from negative to positive simply by focusing out\r\n // of the control.\r\n ExpectedNegChar := '-';\r\n ExpectedNegPos := 1;\r\n case JclFormatSettings.NegCurrFormat of\r\n 0, 4, 14, 15:\r\n begin\r\n ExpectedNegPos := 1;\r\n ExpectedNegChar := '(';\r\n end;\r\n 1, 5, 8, 9:\r\n ExpectedNegPos := 1;\r\n 2:\r\n ExpectedNegPos := 2;\r\n 3, 7, 10, 11:\r\n ExpectedNegPos := Length(S);\r\n 6:\r\n ExpectedNegPos := Length(S) - 1;\r\n 12:\r\n ExpectedNegPos := 3;\r\n 13:\r\n ExpectedNegPos := Length(S) - 2;\r\n end;\r\n\r\n if (Key = '(') and (Posn = 1) and (JclFormatSettings.NegCurrFormat in [0, 4, 14, 15]) then\r\n Key := '-';\r\n\r\n Result := ((Pos(Key, FCheckChars) > 0) and \r\n (((Key = JclFormatSettings.DecimalSeparator) and (Pos(JclFormatSettings.DecimalSeparator, S) = 0)) or (Key <> JclFormatSettings.DecimalSeparator))) or\r\n ((Key = '+') and (Posn = 1) and ((Pos('+', S) = 0) or (SelLength > 0))) or\r\n ((Key = '-') and (Posn = ExpectedNegPos) and ((Pos(ExpectedNegChar, S) = 0) or (SelLength > 0)));\r\n end;\r\n dfNonCheckChars:\r\n Result := Pos(Key, FCheckChars) = 0;\r\n dfNone:\r\n Result := True;\r\n dfScientific:\r\n begin\r\n Result := (Pos(Key, FCheckChars) > 0) or CharInSet(Key, ['+', '-']);\r\n if Result then\r\n begin\r\n iPosE := Pos('e', LowerCase(S));\r\n if Key = JclFormatSettings.DecimalSeparator then\r\n begin\r\n if iPosE = 0 then\r\n Result := (Pos(JclFormatSettings.DecimalSeparator, S) = 0)\r\n else\r\n Result := ((Posn <= iPosE) and (Pos(JclFormatSettings.DecimalSeparator, Copy(S, 1, iPosE - 1)) = 0));\r\n //or ((Posn > iPosE) and (Pos(DecimalSeparator, Copy(S, iPosE + 1, Length(S))) = 0));\r\n // (outchy) XXXeY,YY are not valid scientific numbers, Y must be an integer value\r\n end\r\n else\r\n if CharInSet(Key, ['E', 'e']) then\r\n Result := (iPosE = 0) and (Posn > 1)\r\n else\r\n if Key = '+' then\r\n Result := (Posn = 1) or (Posn = iPosE + 1)\r\n else\r\n if Key = '-' then\r\n Result := (Posn = 1) or (Posn = iPosE + 1);\r\n end;\r\n end;\r\n dfIdentifier:\r\n begin\r\n if Posn = 1 then\r\n Result := (Key = '_') or (IsCharAlpha(Key))\r\n else\r\n Result := Pos(Key, FCheckChars) > 0;\r\n end\r\n else\r\n Result := False;\r\n end;\r\nend;\r\n\r\nfunction TJvCustomValidateEdit.DoValidate(const Key: Char;\r\n const AText: string; const Posn: Integer): Boolean;\r\nbegin\r\n Result := True;\r\n if Assigned(FOnCustomValidate) then\r\n FOnCustomValidate(Self, Key, AText, Posn, Result);\r\nend;\r\n\r\nprocedure TJvCustomValidateEdit.KeyDown(var Key: Word; Shift: TShiftState);\r\nbegin\r\n FLastDownKey := Key;\r\n// if Key = VK_DELETE then EditText := MakeValid(inherited Text);\r\n if Key = VK_ESCAPE then\r\n begin\r\n Key := 0;\r\n EditText := FEnterText;\r\n SelStart := 0;\r\n SelLength := Length(FEditText);\r\n end;\r\n inherited KeyDown(Key, Shift);\r\nend;\r\n\r\nfunction TJvCustomValidateEdit.CurrRangeValue(CheckValue: Currency): Currency;\r\nbegin\r\n Result := CheckValue;\r\n if FHasMaxValue and (CheckValue > FMaxValue) then\r\n Result := FMaxValue\r\n else\r\n if FHasMinValue and (CheckValue < FMinValue) then\r\n Result := FMinValue;\r\nend;\r\n\r\nfunction TJvCustomValidateEdit.FloatRangeValue(CheckValue: Double): Double;\r\nbegin\r\n Result := CheckValue;\r\n if FHasMaxValue and (CheckValue > FMaxValue) then\r\n Result := FMaxValue\r\n else\r\n if FHasMinValue and (CheckValue < FMinValue) then\r\n Result := FMinValue;\r\nend;\r\n\r\nfunction TJvCustomValidateEdit.IntRangeValue(CheckValue: Int64): Int64;\r\nbegin\r\n Result := CheckValue;\r\n if FHasMaxValue and (CheckValue > FMaxValue) then\r\n Result := Trunc(FMaxValue)\r\n else\r\n if FHasMinValue and (CheckValue < FMinValue) then\r\n Result := Trunc(FMinValue);\r\nend;\r\n\r\nfunction TJvCustomValidateEdit.GetEditText: string;\r\nbegin\r\n Result := FEditText;\r\nend;\r\n\r\nfunction TJvCustomValidateEdit.GetUnprefixedUnsuffixedText(\r\n const Value: string): string;\r\nbegin\r\n Result := StrEnsureNoPrefix(DisplayPrefix, StrEnsureNoSuffix(DisplaySuffix, Value));\r\n Result := StrEnsureNoPrefix(JclFormatSettings.CurrencyString, StrEnsureNoSuffix(JclFormatSettings.CurrencyString, Result));\r\nend;\r\n\r\nprocedure TJvCustomValidateEdit.SetEditText(const NewValue: string);\r\nbegin\r\n FEditText := MakeValid(GetUnprefixedUnsuffixedText(NewValue));\r\n if (FDisplayFormat = dfYear) and ((not FHasMaxValue) or\r\n (FHasMaxValue and (FMaxValue > 2000 + JclFormatSettings.TwoDigitYearCenturyWindow))) and\r\n ((MaxLength = 0) or (MaxLength > 3)) then\r\n FEditText := IntToStr(MakeYear4Digit(StrToIntDef(FEditText, 0), JclFormatSettings.TwoDigitYearCenturyWindow));\r\n if (FDisplayFormat in [dfBinary, dfCurrency, dfFloat, dfFloatGeneral, dfDecimal, dfHex, dfInteger,\r\n dfOctal, dfPercent, dfScientific, dfYear, dfFloatFixed]) then\r\n begin\r\n EnforceMaxValue;\r\n EnforceMinValue;\r\n end;\r\n// ChangeText(FEditText);\r\n DisplayText;\r\n DoValueChanged;\r\nend;\r\n\r\nprocedure TJvCustomValidateEdit.FocusSet(PrevWnd: THandle);\r\nbegin\r\n DisplayText;\r\n inherited FocusSet(PrevWnd);\r\nend;\r\n\r\nprocedure TJvCustomValidateEdit.FocusKilled(NextWnd: THandle);\r\nvar\r\n DisplayedText: string;\r\nbegin\r\n if not (csDestroying in ComponentState) then\r\n begin\r\n DisplayedText := inherited Text;\r\n EditText := GetUnprefixedUnsuffixedText(DisplayedText);\r\n end;\r\n inherited FocusKilled(NextWnd);\r\nend;\r\n\r\nprocedure TJvCustomValidateEdit.ChangeText(const NewValue: string);\r\nvar\r\n S, Exponent: string;\r\n Ps, I: Integer;\r\nbegin\r\n FSelfChange := True;\r\n try\r\n Ps := 0;\r\n if TrimDecimals then\r\n begin\r\n I := Pos('e', LowerCase(NewValue));\r\n if (DisplayFormat = dfScientific) and (I <> 0) then\r\n begin\r\n Exponent := Copy(NewValue, I, Length(NewValue));\r\n Dec(I);\r\n end\r\n else\r\n begin\r\n Exponent := '';\r\n I := Length(NewValue);\r\n end;\r\n Ps := Pos(JclFormatSettings.DecimalSeparator, NewValue);\r\n if Ps > 0 then\r\n begin\r\n while (I > Ps) and (NewValue[I] = '0') do\r\n Dec(I);\r\n if Ps = I then\r\n Dec(I); // skip decimal separator (Ivo Bauer)\r\n S := FDisplayPrefix + Copy(NewValue, 1, I) + Exponent + FDisplaySuffix;\r\n end;\r\n end;\r\n if Ps = 0 then\r\n S := FDisplayPrefix + NewValue + FDisplaySuffix;\r\n if S <> inherited Text then\r\n inherited SetText(S);\r\n finally\r\n FSelfChange := False;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomValidateEdit.DisplayText;\r\n function FormatedValue(Value: Double): Double;\r\n begin\r\n if Assigned(FOnDecimalRounding) then\r\n FOnDecimalRounding(Self, Result, Value)\r\n else\r\n Result := Value;\r\n end;\r\nbegin\r\n // The number types need to be formatted\r\n if FAllowEmpty and (FEditText = '') then\r\n ChangeText('')\r\n else\r\n if (FDisplayFormat in [dfBinary, dfCurrency, dfFloat, dfFloatGeneral, dfDecimal, dfInteger, dfOctal, dfPercent, dfScientific, dfYear, dfFloatFixed]) and\r\n (AsFloat = 0) and FZeroEmpty then\r\n ChangeText('')\r\n else\r\n begin\r\n case FDisplayFormat of\r\n dfCurrency:\r\n ChangeText(Format('%.*m', [FDecimalPlaces, AsCurrency]));\r\n dfInteger:\r\n ChangeText(IntToStr(AsInteger));\r\n dfFloat:\r\n ChangeText(Format('%.*n', [FDecimalPlaces, FormatedValue(AsFloat)]));\r\n dfFloatGeneral:\r\n ChangeText(Format('%.*g', [FDecimalPlaces, FormatedValue(AsFloat)]));\r\n dfFloatFixed:\r\n ChangeText(Format('%.*f', [FDecimalPlaces, FormatedValue(AsFloat)]));\r\n dfScientific:\r\n ChangeText(Format('%.*e', [FDecimalPlaces, FormatedValue(AsFloat)]));\r\n dfPercent:\r\n ChangeText(Format('%.*n%', [FDecimalPlaces, FormatedValue(AsFloat)]));\r\n else\r\n ChangeText(FEditText);\r\n end;\r\n\r\n // This needs to be done AFTER the text has been changed so that the color\r\n // is directly shown correctly. (Mantis 3493)\r\n if (FCriticalPoints.CheckPoints <> cpNone) and\r\n (FDisplayFormat in [dfBinary, dfCurrency, dfFloat, dfFloatGeneral, dfDecimal, dfHex, dfInteger, dfOctal, dfPercent, dfScientific, dfYear, dfFloatFixed]) then\r\n SetFontColor;\r\n end;\r\nend;\r\n\r\nfunction TJvCustomValidateEdit.ScientificStrToFloat(SciString: string): Double;\r\nvar\r\n I: Cardinal;\r\n sMantissa, sExponent: string;\r\n bInExp: Boolean;\r\nbegin\r\n if Pos('E', UpperCase(SciString)) = 0 then\r\n Result := JvSafeStrToFloatDef(SciString, 0)\r\n else\r\n begin\r\n sMantissa := '';\r\n sExponent := '';\r\n bInExp := False;\r\n for I := 1 to Length(SciString) do\r\n begin\r\n if UpperCase(SciString[I]) = 'E' then\r\n bInExp := True\r\n else\r\n begin\r\n if bInExp then\r\n sExponent := sExponent + SciString[I]\r\n else\r\n sMantissa := sMantissa + SciString[I];\r\n end;\r\n end;\r\n // NOTE: StrToFloatDefIgnoreInvalidCharacters now called JvSafeStrToFloatDef:\r\n Result := JvSafeStrToFloatDef(sMantissa, 0) * Power(10, JvSafeStrToFloatDef(sExponent, 0));\r\n end;\r\nend;\r\n\r\nfunction TJvCustomValidateEdit.BaseToInt(const BaseValue: string; Base: Byte): Int64;\r\nbegin\r\n Assert(Base <= 36, RsEBaseTooBig);\r\n Assert(Base > 1, RsEBaseTooSmall);\r\n Result := Numb2Dec(BaseValue, Base);\r\nend;\r\n\r\nfunction TJvCustomValidateEdit.IntToBase(NewValue: Int64; Base: Byte): string;\r\nbegin\r\n Assert(Base <= 36, RsEBaseTooBig);\r\n Assert(Base > 1, RsEBaseTooSmall);\r\n Result := Dec2Numb(NewValue, 0, Base);\r\nend;\r\n\r\nprocedure TJvCustomValidateEdit.DoValueChanged;\r\nbegin\r\n try\r\n if Assigned(FOnValueChanged) and not (csLoading in ComponentState) and (FEnterText <> FEditText) then\r\n FOnValueChanged(Self);\r\n finally\r\n FEnterText := FEditText;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomValidateEdit.Change;\r\nvar\r\n DisplayedText: string;\r\nbegin\r\n // Update FEditText for User changes, so that the AsInteger, etc,\r\n // functions work while editing\r\n if not FSelfChange then\r\n begin\r\n DisplayedText := inherited Text;\r\n FEditText := GetUnprefixedUnsuffixedText(DisplayedText);\r\n end;\r\n inherited Change;\r\nend;\r\n\r\nprocedure TJvCustomValidateEdit.SetText(const NewValue: TCaption);\r\nbegin\r\n // If we are actually changing our value ourselves, there is no need\r\n // to do it again. This may even trigger an infinite recursion, especially\r\n // when in a derived component the display format is set in the constructor.\r\n // In that case, the recursion would kill Delphi almost instantly.\r\n if not FSelfChange then\r\n begin\r\n EditText := NewValue;\r\n DoValueChanged;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomValidateEdit.SetDisplayPrefix(const NewValue: string);\r\nbegin\r\n FDisplayPrefix := NewValue;\r\n DisplayText;\r\nend;\r\n\r\nprocedure TJvCustomValidateEdit.SetDisplaySuffix(const NewValue: string);\r\nbegin\r\n FDisplaySuffix := NewValue;\r\n DisplayText;\r\nend;\r\n\r\nprocedure TJvCustomValidateEdit.CriticalPointsChange(Sender: TObject);\r\nbegin\r\n SetFontColor;\r\n Invalidate;\r\nend;\r\n\r\nfunction TJvCustomValidateEdit.IsValid: Boolean;\r\nbegin\r\n Result := True;\r\n case FCriticalPoints.CheckPoints of\r\n cpMaxValue:\r\n Result := IsLower(AsFloat, FCriticalPoints.MaxValue, FCriticalPoints.MaxValueIncluded);\r\n cpMinValue:\r\n Result := IsGreater(AsFloat, FCriticalPoints.MinValue, FCriticalPoints.MinValueIncluded);\r\n cpBoth:\r\n Result := IsLower(AsFloat, FCriticalPoints.MaxValue, FCriticalPoints.MaxValueIncluded) and\r\n IsGreater(AsFloat, FCriticalPoints.MinValue, FCriticalPoints.MinValueIncluded);\r\n end;\r\n if Assigned(FOnIsValid) then\r\n FOnIsValid(Self, Result);\r\nend;\r\n\r\nprocedure TJvCustomValidateEdit.SetFontColor;\r\nbegin\r\n if not (csDesigning in ComponentState) and not (csLoading in ComponentState) then\r\n begin\r\n Font.OnChange := nil;\r\n case FCriticalPoints.CheckPoints of\r\n cpNone:\r\n Font.Color := FStandardFontColor;\r\n cpMinValue:\r\n if IsLower(AsFloat, FCriticalPoints.MinValue, not FCriticalPoints.MinValueIncluded) then\r\n Font.Color := FCriticalPoints.ColorBelow\r\n else\r\n Font.Color := FStandardFontColor;\r\n cpMaxValue:\r\n if IsGreater(AsFloat, FCriticalPoints.MaxValue, not FCriticalPoints.MaxValueIncluded) then\r\n Font.Color := FCriticalPoints.ColorAbove\r\n else\r\n Font.Color := FStandardFontColor;\r\n cpBoth:\r\n if IsGreater(AsFloat, FCriticalPoints.MaxValue, not FCriticalPoints.MaxValueIncluded) then\r\n Font.Color := FCriticalPoints.ColorAbove\r\n else if IsLower(AsFloat, FCriticalPoints.MinValue, not FCriticalPoints.MinValueIncluded) then\r\n Font.Color := FCriticalPoints.ColorBelow\r\n else\r\n Font.Color := FStandardFontColor;\r\n end;\r\n Font.OnChange := FontChange;\r\n end;\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvCustomValidateEdit.FontChange(Sender: TObject);\r\nbegin\r\n FStandardFontColor := Font.Color;\r\n if Assigned(FOldFontChange) then\r\n FOldFontChange(Sender);\r\nend;\r\n\r\nprocedure TJvCustomValidateEdit.EnforceMaxValue;\r\nbegin\r\n { Check the Value is within this range }\r\n if FHasMaxValue and (FDisplayFormat in [dfBinary, dfCurrency, dfFloat, dfFloatGeneral,\r\n dfDecimal, dfHex, dfInteger, dfOctal, dfPercent, dfScientific, dfYear, dfFloatFixed]) and\r\n (AsFloat > FMaxValue) and not FEnforcingMinMaxValue then\r\n begin\r\n FEnforcingMinMaxValue := True;\r\n try\r\n SetAsFloat(FMaxValue);\r\n finally\r\n FEnforcingMinMaxValue := False;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomValidateEdit.EnforceMinValue;\r\nbegin\r\n { Check the Value is within this range }\r\n if FHasMinValue and (FDisplayFormat in [dfBinary, dfCurrency, dfFloat, dfFloatGeneral,\r\n dfDecimal, dfHex, dfInteger, dfOctal, dfPercent, dfScientific, dfYear, dfFloatFixed]) and\r\n (AsFloat < FMinValue) and not FEnforcingMinMaxValue then\r\n begin\r\n FEnforcingMinMaxValue := True;\r\n try\r\n SetAsFloat(FMinValue);\r\n finally\r\n FEnforcingMinMaxValue := False;\r\n end;\r\n end;\r\nend;\r\n\r\n//=== { TJvValidateEditCriticalPoints } ======================================\r\n\r\nconstructor TJvValidateEditCriticalPoints.Create;\r\nbegin\r\n inherited Create;\r\n SetDefaults(cpNone, clBlue, clRed);\r\n FMaxValueIncluded := False;\r\n FMinValueIncluded := False;\r\nend;\r\n\r\nprocedure TJvValidateEditCriticalPoints.SetCheckPoints(NewValue: TJvValidateEditCriticalPointsCheck);\r\nbegin\r\n if FCheckPoints <> NewValue then\r\n begin\r\n FCheckPoints := NewValue;\r\n DoChanged;\r\n end;\r\nend;\r\n\r\nprocedure TJvValidateEditCriticalPoints.SetColorAbove(NewValue: TColor);\r\nbegin\r\n if FColorAbove <> NewValue then\r\n begin\r\n FColorAbove := NewValue;\r\n DoChanged;\r\n end;\r\nend;\r\n\r\nprocedure TJvValidateEditCriticalPoints.SetColorBelow(NewValue: TColor);\r\nbegin\r\n if FColorBelow <> NewValue then\r\n begin\r\n FColorBelow := NewValue;\r\n DoChanged;\r\n end;\r\nend;\r\n\r\nprocedure TJvValidateEditCriticalPoints.SetMaxValue(NewValue: Double);\r\nbegin\r\n if FMaxValue <> NewValue then\r\n begin\r\n FMaxValue := NewValue;\r\n DoChanged;\r\n end;\r\nend;\r\n\r\nprocedure TJvValidateEditCriticalPoints.SetMinValue(NewValue: Double);\r\nbegin\r\n if FMinValue <> NewValue then\r\n begin\r\n FMinValue := NewValue;\r\n DoChanged;\r\n end;\r\nend;\r\n\r\nprocedure TJvValidateEditCriticalPoints.DoChanged;\r\nbegin\r\n if Assigned(FOnChange) then\r\n FOnChange(Self);\r\nend;\r\n\r\nprocedure TJvValidateEditCriticalPoints.Assign(Source: TPersistent);\r\nvar\r\n LocalSource: TJvValidateEditCriticalPoints;\r\nbegin\r\n if Source is TJvValidateEditCriticalPoints then\r\n begin\r\n LocalSource := TJvValidateEditCriticalPoints(Source);\r\n CheckPoints := LocalSource.CheckPoints;\r\n ColorAbove := LocalSource.ColorAbove;\r\n ColorBelow := LocalSource.ColorBelow;\r\n MaxValue := LocalSource.MaxValue;\r\n MinValue := LocalSource.MinValue;\r\n end\r\n else\r\n inherited Assign(Source);\r\nend;\r\n\r\nfunction TJvValidateEditCriticalPoints.IsCheckPointsStored: Boolean;\r\nbegin\r\n Result := (FCheckPoints <> FDefCheckPoints);\r\nend;\r\n\r\nfunction TJvValidateEditCriticalPoints.IsColorAboveStored: Boolean;\r\nbegin\r\n Result := (FColorAbove <> FDefColorAbove);\r\nend;\r\n\r\nfunction TJvValidateEditCriticalPoints.IsColorBelowStored: Boolean;\r\nbegin\r\n Result := (FColorBelow <> FDefColorBelow);\r\nend;\r\n\r\nprocedure TJvValidateEditCriticalPoints.SetDefaults(ACheckPoints: TJvValidateEditCriticalPointsCheck;\r\n AColorAbove, AColorBelow: TColor);\r\nbegin\r\n FDefCheckPoints := ACheckPoints;\r\n FCheckPoints := ACheckPoints;\r\n FDefColorAbove := AColorAbove;\r\n FColorAbove := AColorAbove;\r\n FDefColorBelow := AColorBelow;\r\n FColorBelow := AColorBelow;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvValidators.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvValidators.PAS, released on 2003-01-01.\r\n\r\nThe Initial Developer of the Original Code is Peter Thrnqvist [peter3 at sourceforge dot net] .\r\nPortions created by Peter Thrnqvist are Copyright (C) 2003 Peter Thrnqvist.\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvValidators.pas 13361 2012-06-18 12:15:20Z obones $\r\n\r\nunit JvValidators;\r\n\r\n{$I jvcl.inc}\r\n// NB: this is here so a user can disable DB support if he wants to\r\n// NB2: this need not be defined in the design package because GetDataLink is\r\n// defined differently depending on this define\r\n{.$DEFINE JVVALIDATORS_SUPPORTS_DBCONTROLS}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF JVVALIDATORS_SUPPORTS_DBCONTROLS}\r\n DB,\r\n {$ENDIF JVVALIDATORS_SUPPORTS_DBCONTROLS}\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, SysUtils, Classes, Controls, Forms,\r\n JvComponentBase, JvErrorIndicator;\r\n\r\ntype\r\n EValidatorError = class(Exception);\r\n\r\n // Implemented by classes that can return the value to validate against.\r\n // The validator classes first check if the ControlToValidate supports this interface\r\n // and if it does, uses the value returned from GetValidationPropertyValue instead of\r\n // extracting it from RTTI (using ControlToValidate and PropertyToValidate)\r\n // The good thing about implementing this interface is that the value to validate do\r\n // not need to be a published property but can be anything, even a calculated value\r\n IJvValidationProperty = interface\r\n ['{564FD9F5-BE57-4559-A6AF-B0624C956E50}']\r\n function GetValidationPropertyValue: Variant;\r\n function GetValidationPropertyName: WideString;\r\n end;\r\n\r\n IJvValidationSummary = interface\r\n ['{F2E4F4E5-E831-4514-93C9-0E2ACA941DCF}']\r\n procedure BeginUpdate;\r\n procedure EndUpdate;\r\n procedure AddError(const ErrorMessage: string);\r\n procedure RemoveError(const ErrorMessage: string);\r\n end;\r\n\r\n TJvBaseValidator = class;\r\n TJvValidators = class;\r\n TJvBaseValidatorClass = class of TJvBaseValidator;\r\n\r\n TJvBaseValidator = class(TJvComponent)\r\n private\r\n FEnabled: Boolean;\r\n FValid: Boolean;\r\n FPropertyToValidate: string;\r\n FErrorMessage: string;\r\n FGroupName: string;\r\n FControlToValidate: TControl;\r\n FErrorControl: TControl;\r\n FValidator: TJvValidators;\r\n FOnValidateFailed: TNotifyEvent;\r\n\r\n procedure SetControlToValidate(Value: TControl);\r\n procedure SetErrorControl(Value: TControl);\r\n protected\r\n function GetValidationPropertyValue: Variant; virtual;\r\n procedure SetValid(const Value: Boolean); virtual;\r\n function GetValid: Boolean; virtual;\r\n procedure DoValidateFailed; dynamic;\r\n procedure Validate; virtual; abstract;\r\n procedure Notification(AComponent: TComponent; Operation: TOperation); override;\r\n procedure SetParentComponent(Value: TComponent); override;\r\n procedure ReadState(Reader: TReader); override;\r\n\r\n // get the number of registered base validator classes\r\n class function BaseValidatorsCount: Integer;\r\n // get info on a registered class\r\n class procedure GetBaseValidatorInfo(Index: Integer; var DisplayName: string;\r\n var ABaseValidatorClass: TJvBaseValidatorClass);\r\n\r\n public\r\n {$IFDEF JVVALIDATORS_SUPPORTS_DBCONTROLS}\r\n // return a TDataLink if the control is a DB control or nil if is not\r\n function GetDataLink(AControl:TControl):TDataLink;virtual;\r\n {$ELSE}\r\n function GetDataLink(AControl:TControl):TObject;virtual;\r\n {$ENDIF JVVALIDATORS_SUPPORTS_DBCONTROLS}\r\n // register a new base validator class. DisplayName is used by the design-time editor.\r\n // A class with an empty DisplayName will not sshow up in the editor\r\n class procedure RegisterBaseValidator(const DisplayName: string; AValidatorClass: TJvBaseValidatorClass);\r\n class procedure UnregisterBaseValidator(AValidatorClass: TJvBaseValidatorClass);\r\n\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n\r\n function GetParentComponent: TComponent; override;\r\n function HasParent: Boolean; override;\r\n property Value: Variant read GetValidationPropertyValue;\r\n published\r\n property Valid: Boolean read GetValid write SetValid default true;\r\n // the control that is used to align the error indicator (nil means that the ControlToValidate should be used)\r\n property ErrorControl: TControl read FErrorControl write SetErrorControl;\r\n // the control to validate\r\n property ControlToValidate: TControl read FControlToValidate write SetControlToValidate;\r\n // the property in ControlToValidate to validate against\r\n property PropertyToValidate: string read FPropertyToValidate write FPropertyToValidate;\r\n // make this validator a part of a group so it can be validated separately using Validate(GroupName)\r\n property GroupName:string read FGroupName write FGroupName;\r\n property Enabled: Boolean read FEnabled write FEnabled default true;\r\n // the message to display in case of error\r\n property ErrorMessage: string read FErrorMessage write FErrorMessage;\r\n // triggered when Valid is set to False\r\n property OnValidateFailed: TNotifyEvent read FOnValidateFailed write FOnValidateFailed;\r\n end;\r\n\r\n TJvRequiredFieldValidator = class(TJvBaseValidator)\r\n private\r\n FAllowBlank: Boolean;\r\n protected\r\n procedure Validate; override;\r\n published\r\n property AllowBlank: Boolean read FAllowBlank write FAllowBlank default true;\r\n end;\r\n\r\n TJvValidateCompareOperator = (vcoLessThan, vcoLessOrEqual, vcoEqual, vcoGreaterOrEqual, vcoGreaterThan, vcoNotEqual);\r\n\r\n TJvCompareValidator = class(TJvBaseValidator)\r\n private\r\n FValueToCompare: Variant;\r\n FOperator: TJvValidateCompareOperator;\r\n protected\r\n procedure Validate; override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n published\r\n property ValueToCompare: Variant read FValueToCompare write FValueToCompare;\r\n property Operator: TJvValidateCompareOperator read FOperator write FOperator default vcoEqual;\r\n end;\r\n\r\n TJvRangeValidator = class(TJvBaseValidator)\r\n private\r\n FMinimumValue: Variant;\r\n FMaximumValue: Variant;\r\n protected\r\n procedure Validate; override;\r\n published\r\n property MinimumValue: Variant read FMinimumValue write FMinimumValue;\r\n property MaximumValue: Variant read FMaximumValue write FMaximumValue;\r\n end;\r\n\r\n TJvRegularExpressionValidator = class(TJvBaseValidator)\r\n private\r\n FValidationExpression: string;\r\n protected\r\n procedure Validate; override;\r\n published\r\n property ValidationExpression: string read FValidationExpression write FValidationExpression;\r\n end;\r\n\r\n TJvCustomValidateEvent = procedure(Sender: TObject; ValueToValidate: Variant; var Valid: Boolean) of object;\r\n\r\n TJvCustomValidator = class(TJvBaseValidator)\r\n private\r\n FOnValidate: TJvCustomValidateEvent;\r\n protected\r\n function DoValidate: Boolean; virtual;\r\n procedure Validate; override;\r\n published\r\n property OnValidate: TJvCustomValidateEvent read FOnValidate write FOnValidate;\r\n end;\r\n \r\n // compares the properties of two controls\r\n // if CompareToControl implements the IJvValidationProperty interface, the value\r\n // to compare is taken from GetValidationPropertyValue, otherwise RTTI is used to get the\r\n // property value\r\n TJvControlsCompareValidator = class(TJvBaseValidator)\r\n private\r\n FCompareToControl: TControl;\r\n FCompareToProperty: string;\r\n FOperator: TJvValidateCompareOperator;\r\n FAllowNull: Boolean;\r\n procedure SetCompareToControl(const Value: TControl);\r\n protected\r\n procedure Validate; override;\r\n function GetPropertyValueToCompare: Variant;\r\n procedure Notification(AComponent: TComponent; Operation: TOperation); override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n\r\n published\r\n property CompareToControl: TControl read FCompareToControl write SetCompareToControl;\r\n property CompareToProperty: string read FCompareToProperty write FCompareToProperty;\r\n property Operator: TJvValidateCompareOperator read FOperator write FOperator default vcoEqual;\r\n property AllowNull: Boolean read FAllowNull write FAllowNull default True;\r\n end;\r\n\r\n TJvValidateFailEvent = procedure(Sender: TObject; BaseValidator: TJvBaseValidator; var Continue: Boolean) of object;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64 or pidOSX32)]\r\n {$ENDIF RTL230_UP}\r\n TJvValidators = class(TJvComponent)\r\n private\r\n FOnValidateFailed: TJvValidateFailEvent;\r\n FItems: TList;\r\n FValidationSummary: IJvValidationSummary;\r\n FErrorIndicator: IJvErrorIndicator;\r\n procedure SetValidationSummary(const Value: IJvValidationSummary);\r\n procedure SetErrorIndicator(const Value: IJvErrorIndicator);\r\n function GetCount: Integer;\r\n function GetItem(Index: Integer): TJvBaseValidator;\r\n protected\r\n procedure Notification(AComponent: TComponent; Operation: TOperation); override;\r\n procedure GetChildren(Proc: TGetChildProc; Root: TComponent); override;\r\n function DoValidateFailed(const ABaseValidator: TJvBaseValidator): Boolean; dynamic;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n procedure Insert(AValidator: TJvBaseValidator);\r\n procedure Remove(AValidator: TJvBaseValidator);\r\n procedure Exchange(Index1, Index2: Integer);\r\n function Validate: Boolean; overload;\r\n function Validate(const GroupName:string): Boolean; overload;\r\n property Items[Index: Integer]: TJvBaseValidator read GetItem; default;\r\n property Count: Integer read GetCount;\r\n published\r\n property ValidationSummary: IJvValidationSummary read FValidationSummary write SetValidationSummary;\r\n property ErrorIndicator: IJvErrorIndicator read FErrorIndicator write SetErrorIndicator;\r\n property OnValidateFailed: TJvValidateFailEvent read FOnValidateFailed write FOnValidateFailed;\r\n end;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64 or pidOSX32)]\r\n {$ENDIF RTL230_UP}\r\n TJvValidationSummary = class(TJvComponent, IUnknown, IJvValidationSummary)\r\n private\r\n FUpdateCount: Integer;\r\n FPendingUpdates: Integer;\r\n FSummaries: TStringList;\r\n FOnChange: TNotifyEvent;\r\n FOnRemoveError: TNotifyEvent;\r\n FOnAddError: TNotifyEvent;\r\n function GetSummaries: TStrings;\r\n protected\r\n { IJvValidationSummary }\r\n procedure AddError(const ErrorMessage: string);\r\n procedure RemoveError(const ErrorMessage: string);\r\n procedure BeginUpdate;\r\n procedure EndUpdate;\r\n\r\n procedure Change; virtual;\r\n public\r\n destructor Destroy; override;\r\n property Summaries: TStrings read GetSummaries;\r\n published\r\n property OnChange: TNotifyEvent read FOnChange write FOnChange;\r\n property OnAddError: TNotifyEvent read FOnAddError write FOnAddError;\r\n property OnRemoveError: TNotifyEvent read FOnRemoveError write FOnRemoveError;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvValidators.pas $';\r\n Revision: '$Revision: 13361 $';\r\n Date: '$Date: 2012-06-18 14:15:20 +0200 (lun. 18 juin 2012) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nconst\r\n cValidatorsDBValue = '(DBValue)';\r\n\r\nimplementation\r\n\r\nuses\r\n {$IFDEF JVVALIDATORS_SUPPORTS_DBCONTROLS}\r\n DBCtrls,\r\n {$ENDIF JVVALIDATORS_SUPPORTS_DBCONTROLS}\r\n Masks,\r\n Variants,\r\n TypInfo,\r\n// JclUnicode, // for reg exp support\r\n JvTypes, JvResources, JvJVCLUtils;\r\n\r\nvar\r\n GlobalValidatorsList: TStringList = nil;\r\n\r\nprocedure RegisterBaseValidators; forward;\r\n\r\nfunction ValidatorsList: TStringList;\r\nbegin\r\n if not Assigned(GlobalValidatorsList) then\r\n begin\r\n GlobalValidatorsList := TStringList.Create;\r\n // register\r\n //RegisterBaseValidators; is registered in initialization\r\n end;\r\n Result := GlobalValidatorsList;\r\nend;\r\n\r\nprocedure Debug(const Msg: string); overload;\r\nbegin\r\n// Application.MessageBox(PChar(Msg),PChar('Debug'),MB_OK or MB_TASKMODAL)\r\nend;\r\n\r\nprocedure Debug(const Msg: string; const Fmt: array of const); overload;\r\nbegin\r\n Debug(Format(Msg, Fmt));\r\nend;\r\n\r\nfunction ComponentName(Comp: TComponent): string;\r\nbegin\r\n if Comp = nil then\r\n Result := 'nil'\r\n else\r\n if Comp.Name <> '' then\r\n Result := Comp.Name\r\n else\r\n Result := Comp.ClassName;\r\nend;\r\n\r\n//=== { TJvBaseValidator } ===================================================\r\n\r\nconstructor TJvBaseValidator.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FValid := True;\r\n FEnabled := True;\r\nend;\r\n\r\ndestructor TJvBaseValidator.Destroy;\r\nbegin\r\n Debug('TJvBaseValidator.Destroy: FValidator is %s', [ComponentName(FValidator)]);\r\n ErrorControl := nil;\r\n ControlToValidate := nil;\r\n if FValidator <> nil then\r\n begin\r\n FValidator.Remove(Self);\r\n FValidator := nil;\r\n end;\r\n inherited Destroy;\r\nend;\r\n\r\nclass procedure TJvBaseValidator.RegisterBaseValidator(const DisplayName: string; AValidatorClass:\r\n TJvBaseValidatorClass);\r\nbegin\r\n if ValidatorsList.IndexOfObject(Pointer(AValidatorClass)) < 0 then\r\n begin\r\n Classes.RegisterClass(TPersistentClass(AValidatorClass));\r\n ValidatorsList.AddObject(DisplayName, Pointer(AValidatorClass));\r\n end;\r\nend;\r\n\r\nclass procedure TJvBaseValidator.UnregisterBaseValidator(AValidatorClass: TJvBaseValidatorClass);\r\nvar\r\n ClassIndex: Integer;\r\nbegin\r\n ClassIndex := ValidatorsList.IndexOfObject(Pointer(AValidatorClass));\r\n if ClassIndex >= 0 then\r\n begin\r\n Classes.UnregisterClass(TPersistentClass(AValidatorClass));\r\n ValidatorsList.Delete(ClassIndex);\r\n end;\r\nend;\r\n\r\nclass function TJvBaseValidator.BaseValidatorsCount: Integer;\r\nbegin\r\n Result := ValidatorsList.Count;\r\nend;\r\n\r\nclass procedure TJvBaseValidator.GetBaseValidatorInfo(Index: Integer;\r\n var DisplayName: string; var ABaseValidatorClass: TJvBaseValidatorClass);\r\nbegin\r\n if (Index < 0) or (Index >= ValidatorsList.Count) then\r\n raise EJVCLException.CreateResFmt(@RsEInvalidIndexd, [Index]);\r\n DisplayName := ValidatorsList[Index];\r\n ABaseValidatorClass := TJvBaseValidatorClass(ValidatorsList.Objects[Index]);\r\nend;\r\n\r\nfunction TJvBaseValidator.GetValid: Boolean;\r\nbegin\r\n Result := FValid;\r\nend;\r\n\r\nfunction TJvBaseValidator.GetParentComponent: TComponent;\r\nbegin\r\n Debug('TJvBaseValidator.GetParentComponent: Parent is %s', [ComponentName(FValidator)]);\r\n Result := FValidator;\r\nend;\r\n\r\nfunction TJvBaseValidator.GetValidationPropertyValue: Variant;\r\nvar\r\n ValProp: IJvValidationProperty;\r\n PropInfo: PPropInfo;\r\n {$IFDEF JVVALIDATORS_SUPPORTS_DBCONTROLS}\r\n DataLink:TDataLink;\r\n {$ENDIF JVVALIDATORS_SUPPORTS_DBCONTROLS}\r\nbegin\r\n Result := Null;\r\n if FControlToValidate <> nil then\r\n begin\r\n if Supports(FControlToValidate, IJvValidationProperty, ValProp) then\r\n Result := ValProp.GetValidationPropertyValue\r\n {$IFDEF JVVALIDATORS_SUPPORTS_DBCONTROLS}\r\n else if AnsiSameText(FPropertyToValidate,cValidatorsDBValue) then\r\n begin\r\n DataLink := GetDataLink(FControlToValidate);\r\n if (DataLink is TFieldDataLink) and (TFieldDataLink(DataLink).Field <> nil) then\r\n Result := TFieldDataLink(DataLink).Field.DisplayText;\r\n end\r\n {$ENDIF JVVALIDATORS_SUPPORTS_DBCONTROLS}\r\n else if FPropertyToValidate <> '' then\r\n begin\r\n PropInfo := GetPropInfo(FControlToValidate, FPropertyToValidate);\r\n if (PropInfo <> nil) and (PropInfo^.GetProc <> nil) then\r\n begin\r\n Result := GetPropValue(FControlToValidate, FPropertyToValidate, False);\r\n if (PropInfo.PropType^ = TypeInfo(TDateTime)) or\r\n (PropInfo.PropType^ = TypeInfo(TDate)) or\r\n (PropInfo.PropType^ = TypeInfo(TTime)) then\r\n Result := VarAsType(Result, varDate);\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJvBaseValidator.HasParent: Boolean;\r\nbegin\r\n Debug('TJvBaseValidator.HasParent');\r\n Result := True;\r\nend;\r\n\r\nprocedure TJvBaseValidator.Notification(AComponent: TComponent;\r\n Operation: TOperation);\r\nbegin\r\n inherited Notification(AComponent, Operation);\r\n if Operation = opRemove then\r\n begin\r\n if AComponent = ControlToValidate then\r\n ControlToValidate := nil;\r\n if AComponent = ErrorControl then\r\n ErrorControl := nil;\r\n end;\r\nend;\r\n\r\nprocedure TJvBaseValidator.SetValid(const Value: Boolean);\r\nbegin\r\n FValid := Value;\r\n if not FValid then\r\n DoValidateFailed;\r\nend;\r\n\r\nprocedure TJvBaseValidator.SetControlToValidate(Value: TControl);\r\nvar\r\n Obj: IJvValidationProperty;\r\nbegin\r\n if ReplaceComponentReference(Self, Value, TComponent(FControlToValidate)) then\r\n if FControlToValidate <> nil then\r\n if not (csLoading in ComponentState) then\r\n begin\r\n if Supports(FControlToValidate, IJvValidationProperty, Obj) then\r\n PropertyToValidate := Obj.GetValidationPropertyName\r\n else\r\n PropertyToValidate := '';\r\n end;\r\nend;\r\n\r\nprocedure TJvBaseValidator.SetErrorControl(Value: TControl);\r\nbegin\r\n ReplaceComponentReference(Self, Value, TComponent(FErrorControl));\r\nend;\r\n\r\nprocedure TJvBaseValidator.SetParentComponent(Value: TComponent);\r\nbegin\r\n if not (csLoading in ComponentState) then\r\n begin\r\n Debug('TJvBaseValidator.SetParentComponent: Parent is %s, changing to %s',\r\n [ComponentName(FValidator), ComponentName(Value)]);\r\n if FValidator <> nil then\r\n begin\r\n Debug('FValidator.Remove');\r\n FValidator.Remove(Self);\r\n end;\r\n if (Value <> nil) and (Value is TJvValidators) then\r\n begin\r\n Debug('FValidator.Insert');\r\n TJvValidators(Value).Insert(Self);\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvBaseValidator.ReadState(Reader: TReader);\r\nbegin\r\n inherited ReadState(Reader);\r\n Debug('TJvBaseValidator.ReadState: Reader.Parent is %s', [ComponentName(Reader.Parent)]);\r\n if Reader.Parent is TJvValidators then\r\n begin\r\n if FValidator <> nil then\r\n FValidator.Remove(Self);\r\n FValidator := TJvValidators(Reader.Parent);\r\n FValidator.Insert(Self);\r\n end;\r\nend;\r\n\r\nprocedure TJvBaseValidator.DoValidateFailed;\r\nbegin\r\n if Assigned(FOnValidateFailed) then\r\n FOnValidateFailed(Self);\r\nend;\r\n\r\n{$IFDEF JVVALIDATORS_SUPPORTS_DBCONTROLS}\r\nfunction TJvBaseValidator.GetDataLink(AControl:TControl): TDataLink;\r\nbegin\r\n if AControl <> nil then\r\n Result := TDataLink(AControl.Perform(CM_GETDATALINK, 0, 0))\r\n else\r\n Result := nil;\r\nend;\r\n{$ELSE}\r\nfunction TJvBaseValidator.GetDataLink(AControl:TControl):TObject;\r\nbegin\r\n Result := nil;\r\nend;\r\n{$ENDIF JVVALIDATORS_SUPPORTS_DBCONTROLS}\r\n\r\n\r\n//=== { TJvRequiredFieldValidator } ==========================================\r\n\r\nprocedure TJvRequiredFieldValidator.Validate;\r\nvar\r\n R: Variant;\r\nbegin\r\n R := GetValidationPropertyValue;\r\n case VarType(R) of\r\n varDate:\r\n Valid := VarCompareValue(R, 0) <> vrEqual; // zero is the invalid value for dates\r\n varSmallint,\r\n varInteger,\r\n varSingle,\r\n varDouble,\r\n varCurrency,\r\n varBoolean,\r\n varByte:\r\n ; // nothing to do because all values are valid\r\n else\r\n if FAllowBlank then\r\n Valid := VarCompareValue(R, '') <> vrEqual\r\n else\r\n Valid := Trim(VarToStr(R)) <> '';\r\n end;\r\nend;\r\n\r\n//=== { TJvCustomValidator } =================================================\r\n\r\nfunction TJvCustomValidator.DoValidate: Boolean;\r\nbegin\r\n Result := Valid;\r\n if Assigned(FOnValidate) then\r\n FOnValidate(Self, GetValidationPropertyValue, Result);\r\nend;\r\n\r\nprocedure TJvCustomValidator.Validate;\r\nbegin\r\n Valid := DoValidate;\r\nend;\r\n\r\n//=== { TJvRegularExpressionValidator } ======================================\r\n\r\nfunction MatchesMask(const Filename, Mask: string{;\r\n const SearchFlags: TSearchFlags = [sfCaseSensitive]}): Boolean;\r\n{var\r\n URE: TURESearch;\r\n SL: TWideStringList;}\r\nbegin\r\n Result := Masks.MatchesMask(Filename, Mask);\r\n (*\r\n // use the regexp engine in JclUnicode\r\n SL := TWideStringList.Create;\r\n try\r\n URE := TURESearch.Create(SL);\r\n try\r\n URE.FindPrepare(Mask, SearchFlags);\r\n // this could be overkill for long strings and many matches,\r\n // but it's a lot simpler than calling FindFirst...\r\n Result := URE.FindAll(Filename);\r\n finally\r\n URE.Free;\r\n end;\r\n finally\r\n SL.Free;\r\n end;\r\n *)\r\nend;\r\n\r\nprocedure TJvRegularExpressionValidator.Validate;\r\nvar\r\n R: string;\r\nbegin\r\n R := VarToStr(GetValidationPropertyValue);\r\n Valid := (R = ValidationExpression) or MatchesMask(R, ValidationExpression);\r\nend;\r\n\r\n//=== { TJvCompareValidator } ================================================\r\n\r\nconstructor TJvCompareValidator.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FOperator := vcoEqual;\r\nend;\r\n\r\nprocedure TJvCompareValidator.Validate;\r\nvar\r\n VR: TVariantRelationship;\r\nbegin\r\n VR := VarCompareValue(GetValidationPropertyValue, ValueToCompare);\r\n case Operator of\r\n vcoLessThan:\r\n Valid := VR = vrLessThan;\r\n vcoLessOrEqual:\r\n Valid := (VR = vrLessThan) or (VR = vrEqual);\r\n vcoEqual:\r\n Valid := (VR = vrEqual);\r\n vcoGreaterOrEqual:\r\n Valid := (VR = vrGreaterThan) or (VR = vrEqual);\r\n vcoGreaterThan:\r\n Valid := (VR = vrGreaterThan);\r\n vcoNotEqual:\r\n Valid := VR <> vrEqual;\r\n end;\r\nend;\r\n\r\n//=== { TJvRangeValidator } ==================================================\r\n\r\nprocedure TJvRangeValidator.Validate;\r\nvar\r\n VR: TVariantRelationship;\r\nbegin\r\n VR := VarCompareValue(GetValidationPropertyValue, MinimumValue);\r\n Valid := (VR = vrGreaterThan) or (VR = vrEqual);\r\n if Valid then\r\n begin\r\n VR := VarCompareValue(GetValidationPropertyValue, MaximumValue);\r\n Valid := (VR = vrLessThan) or (VR = vrEqual);\r\n end;\r\nend;\r\n\r\n//=== { TJvControlsCompareValidator } ========================================\r\n\r\nconstructor TJvControlsCompareValidator.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FAllowNull := True;\r\n FOperator := vcoEqual;\r\nend;\r\n\r\nfunction TJvControlsCompareValidator.GetPropertyValueToCompare: Variant;\r\nvar\r\n ValProp: IJvValidationProperty;\r\n PropInfo: PPropInfo;\r\nbegin\r\n Result := Null;\r\n if FCompareToControl <> nil then\r\n begin\r\n if Supports(FCompareToControl, IJvValidationProperty, ValProp) then\r\n Result := ValProp.GetValidationPropertyValue\r\n else\r\n if FCompareToProperty <> '' then\r\n begin\r\n PropInfo := GetPropInfo(FCompareToControl, FCompareToProperty);\r\n if (PropInfo <> nil) and (PropInfo^.GetProc <> nil) then\r\n Result := GetPropValue(FCompareToControl, FCompareToProperty, False);\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvControlsCompareValidator.Notification(AComponent: TComponent;\r\n Operation: TOperation);\r\nbegin\r\n inherited Notification(AComponent, Operation);\r\n if (Operation = opRemove) and (AComponent = CompareToControl) then\r\n CompareToControl := nil;\r\nend;\r\n\r\nprocedure TJvControlsCompareValidator.SetCompareToControl(const Value: TControl);\r\nvar\r\n Obj: IJvValidationProperty;\r\nbegin\r\n if ReplaceComponentReference(Self, Value, TComponent(FCompareToControl)) then\r\n if FCompareToControl <> nil then\r\n begin\r\n if not (csLoading in ComponentState) then\r\n begin\r\n if Supports(FCompareToControl, IJvValidationProperty, Obj) then\r\n CompareToProperty := Obj.GetValidationPropertyName\r\n else\r\n CompareToProperty := '';\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvControlsCompareValidator.Validate;\r\nvar\r\n Val1, Val2: Variant;\r\n VR: TVariantRelationship;\r\nbegin\r\n Val1 := GetValidationPropertyValue;\r\n Val2 := GetPropertyValueToCompare;\r\n if not AllowNull and\r\n ((TVarData(Val1).VType in [varEmpty, varNull]) or (TVarData(Val2).VType in [varEmpty, varNull])) then\r\n begin\r\n Valid := False;\r\n Exit;\r\n end;\r\n VR := VarCompareValue(Val1, Val2);\r\n case Operator of\r\n vcoLessThan:\r\n Valid := VR = vrLessThan;\r\n vcoLessOrEqual:\r\n Valid := (VR = vrLessThan) or (VR = vrEqual);\r\n vcoEqual:\r\n Valid := (VR = vrEqual);\r\n vcoGreaterOrEqual:\r\n Valid := (VR = vrGreaterThan) or (VR = vrEqual);\r\n vcoGreaterThan:\r\n Valid := (VR = vrGreaterThan);\r\n vcoNotEqual:\r\n Valid := (VR <> vrEqual);\r\n end;\r\nend;\r\n\r\n//=== { TJvValidators } ======================================================\r\n\r\nconstructor TJvValidators.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FItems := TList.Create;\r\nend;\r\n\r\ndestructor TJvValidators.Destroy;\r\nvar\r\n V: TJvBaseValidator;\r\nbegin\r\n Debug('TJvValidators.Destroy: Count is %d', [FItems.Count]);\r\n while FItems.Count > 0 do\r\n begin\r\n V := TJvBaseValidator(FItems.Last);\r\n V.FValidator := nil;\r\n V.Free;\r\n FItems.Delete(FItems.Count - 1);\r\n end;\r\n FItems.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJvValidators.DoValidateFailed(const ABaseValidator: TJvBaseValidator): Boolean;\r\nbegin\r\n Result := True;\r\n if Assigned(FOnValidateFailed) then\r\n FOnValidateFailed(Self, ABaseValidator, Result);\r\nend;\r\n\r\nfunction TJvValidators.Validate(const GroupName:string): Boolean;\r\nvar\r\n I: Integer;\r\n Controls: TList;\r\n ErrCtrl: TControl;\r\nbegin\r\n Result := True;\r\n if ValidationSummary <> nil then\r\n FValidationSummary.BeginUpdate;\r\n try\r\n Controls := TList.Create;\r\n if FErrorIndicator <> nil then\r\n FErrorIndicator.BeginUpdate;\r\n try\r\n { Get all controls that should be validated }\r\n if FErrorIndicator <> nil then\r\n for I := 0 to Count - 1 do\r\n begin\r\n ErrCtrl := Items[i].ErrorControl;\r\n if ErrCtrl = nil then\r\n ErrCtrl := Items[i].ControlToValidate;\r\n if ErrCtrl <> nil then\r\n if Controls.IndexOf(ErrCtrl) = -1 then\r\n Controls.Add(ErrCtrl);\r\n end;\r\n\r\n for I := 0 to Count - 1 do\r\n begin\r\n if Items[I].Enabled and ((Items[I].GroupName = '') or AnsiSameText(GroupName, Items[I].GroupName)) then\r\n begin\r\n Items[I].Validate;\r\n if not Items[I].Valid then\r\n begin\r\n if (Items[I].ErrorMessage <> '') and (Items[I].ControlToValidate <> nil) then\r\n begin\r\n ErrCtrl := Items[I].ErrorControl;\r\n if ErrCtrl = nil then\r\n ErrCtrl := Items[i].ControlToValidate;\r\n\r\n if ValidationSummary <> nil then\r\n FValidationSummary.AddError(Items[I].ErrorMessage);\r\n if ErrorIndicator <> nil then\r\n FErrorIndicator.SetError(ErrCtrl, Items[I].ErrorMessage);\r\n if FErrorIndicator <> nil then\r\n Controls.Remove(ErrCtrl); { control is not valid }\r\n end;\r\n Result := False;\r\n if not DoValidateFailed(Items[I]) then\r\n Exit;\r\n end;\r\n end;\r\n end;\r\n { Clear ErrorIndicators for controls that are valid }\r\n if FErrorIndicator <> nil then\r\n for I := 0 to Controls.Count - 1 do\r\n FErrorIndicator.SetError(Controls[I], ''); // clear error indicator\r\n finally\r\n if FErrorIndicator <> nil then\r\n FErrorIndicator.EndUpdate;\r\n Controls.Free;\r\n end;\r\n finally\r\n if ValidationSummary <> nil then\r\n FValidationSummary.EndUpdate;\r\n end;\r\nend;\r\n\r\nfunction TJvValidators.Validate: Boolean;\r\nbegin\r\n Result := Validate('');\r\nend;\r\n\r\nprocedure TJvValidators.Notification(AComponent: TComponent;\r\n Operation: TOperation);\r\nbegin\r\n inherited Notification(AComponent, Operation);\r\n if Operation = opRemove then\r\n begin\r\n if Assigned(ValidationSummary) and AComponent.IsImplementorOf(ValidationSummary) then\r\n ValidationSummary := nil;\r\n if Assigned(ErrorIndicator) and AComponent.IsImplementorOf(ErrorIndicator) then\r\n ErrorIndicator := nil;\r\n end;\r\nend;\r\n\r\nprocedure TJvValidators.GetChildren(Proc: TGetChildProc; Root: TComponent);\r\nvar\r\n I: Integer;\r\nbegin\r\n Debug('TJvValidators.GetChildren: Count is %d, Root is %s', [Count, ComponentName(Root)]);\r\n for I := 0 to Count - 1 do\r\n Proc(Items[I]);\r\nend;\r\n\r\nprocedure TJvValidators.SetValidationSummary(const Value: IJvValidationSummary);\r\nbegin\r\n ReferenceInterface(FValidationSummary, opRemove);\r\n FValidationSummary := Value;\r\n ReferenceInterface(FValidationSummary, opInsert);\r\nend;\r\n\r\nprocedure TJvValidators.Insert(AValidator: TJvBaseValidator);\r\nbegin\r\n Debug('TJvValidators.Insert: inserting %s', [ComponentName(AValidator)]);\r\n Assert(AValidator <> nil, RsEInsertNilValidator);\r\n AValidator.FValidator := Self;\r\n if FItems.IndexOf(AValidator) < 0 then\r\n FItems.Add(AValidator);\r\nend;\r\n\r\nprocedure TJvValidators.Remove(AValidator: TJvBaseValidator);\r\nbegin\r\n Debug('TJvValidators.Remove: removing %s', [ComponentName(AValidator)]);\r\n Assert(AValidator <> nil, RsERemoveNilValidator);\r\n Assert(AValidator.FValidator = Self, RsEValidatorNotChild);\r\n AValidator.FValidator := nil;\r\n FItems.Remove(AValidator);\r\nend;\r\n\r\nfunction TJvValidators.GetCount: Integer;\r\nbegin\r\n Result := FItems.Count;\r\nend;\r\n\r\nfunction TJvValidators.GetItem(Index: Integer): TJvBaseValidator;\r\nbegin\r\n Result := TJvBaseValidator(FItems[Index]);\r\nend;\r\n\r\nprocedure TJvValidators.Exchange(Index1, Index2: Integer);\r\nbegin\r\n FItems.Exchange(Index1, Index2);\r\nend;\r\n\r\nprocedure TJvValidators.SetErrorIndicator(const Value: IJvErrorIndicator);\r\nbegin\r\n ReferenceInterface(FErrorIndicator, opRemove);\r\n FErrorIndicator := Value;\r\n ReferenceInterface(FErrorIndicator, opInsert);\r\nend;\r\n\r\n//=== { TJvValidationSummary } ===============================================\r\n\r\ndestructor TJvValidationSummary.Destroy;\r\nbegin\r\n FSummaries.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvValidationSummary.AddError(const ErrorMessage: string);\r\nbegin\r\n if Summaries.IndexOf(ErrorMessage) < 0 then\r\n begin\r\n Summaries.Add(ErrorMessage);\r\n if (FUpdateCount = 0) and Assigned(FOnAddError) then\r\n FOnAddError(Self);\r\n Change;\r\n end;\r\nend;\r\n\r\nprocedure TJvValidationSummary.RemoveError(const ErrorMessage: string);\r\nvar\r\n I: Integer;\r\nbegin\r\n I := Summaries.IndexOf(ErrorMessage);\r\n if I > -1 then\r\n begin\r\n Summaries.Delete(I);\r\n if (FUpdateCount = 0) and Assigned(FOnRemoveError) then\r\n FOnRemoveError(Self);\r\n Change;\r\n end;\r\nend;\r\n\r\nfunction TJvValidationSummary.GetSummaries: TStrings;\r\nbegin\r\n if FSummaries = nil then\r\n FSummaries := TStringList.Create;\r\n Result := FSummaries;\r\nend;\r\n\r\nprocedure TJvValidationSummary.Change;\r\nbegin\r\n if FUpdateCount <> 0 then\r\n begin\r\n Inc(FPendingUpdates);\r\n Exit;\r\n end;\r\n if Assigned(FOnChange) then\r\n FOnChange(Self);\r\nend;\r\n\r\nprocedure TJvValidationSummary.BeginUpdate;\r\nbegin\r\n Inc(FUpdateCount);\r\nend;\r\n\r\nprocedure TJvValidationSummary.EndUpdate;\r\nbegin\r\n Dec(FUpdateCount);\r\n if FUpdateCount < 0 then\r\n FUpdateCount := 0;\r\n if (FUpdateCount = 0) and (FPendingUpdates > 0) then\r\n begin\r\n Change;\r\n FPendingUpdates := 0;\r\n end;\r\nend;\r\n\r\nprocedure RegisterBaseValidators;\r\nbegin\r\n TJvBaseValidator.RegisterBaseValidator('Required Field Validator', TJvRequiredFieldValidator);\r\n TJvBaseValidator.RegisterBaseValidator('Compare Validator', TJvCompareValidator);\r\n TJvBaseValidator.RegisterBaseValidator('Range Validator', TJvRangeValidator);\r\n TJvBaseValidator.RegisterBaseValidator('Regular Expression Validator', TJvRegularExpressionValidator);\r\n TJvBaseValidator.RegisterBaseValidator('Custom Validator', TJvCustomValidator);\r\n TJvBaseValidator.RegisterBaseValidator('Controls Compare Validator', TJvControlsCompareValidator);\r\nend;\r\n\r\n\r\ninitialization\r\n {$IFDEF UNITVERSIONING}\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n {$ENDIF UNITVERSIONING}\r\n\r\n // (p3) do NOT touch! This is required to make the registration work on formulars!!!\r\n RegisterBaseValidators;\r\n\r\nfinalization\r\n FreeAndNil(GlobalValidatorsList);\r\n\r\n {$IFDEF UNITVERSIONING}\r\n UnregisterUnitVersion(HInstance);\r\n {$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvVersionControlActions.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvVersionControlActions.Pas, released on 2008-07-13.\r\n\r\nThe Initial Developer of the Original Code is Jens Fudickar [jens dott fudicker att oratool dott de]\r\nPortions created by Jens Fudickar are Copyright (C) 2002 Jens Fudickar.\r\nAll Rights Reserved.\r\n\r\nContributor(s): -\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvVersionControlActions.pas 13138 2011-10-26 23:17:50Z jfudickar $\r\n\r\nunit JvVersionControlActions;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nUses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, ActnList, Graphics, Classes, JvActionsEngine,\r\n JvVersionControlActionsEngine, JclVersionControl;\r\n\r\ntype\r\n TJvChangeVersionControlComponent = procedure(VersionControlComponent: TComponent) of object;\r\n TJvVersionControlActionCheckEnabledEvent = procedure(aDataComponent : TComponent; aDatabaseControlEngine:\r\n TjvVersionControlActionEngine; var aEnabled : Boolean) of object;\r\n TJvVersionControlActionExecuteEvent = procedure(Sender: TObject; ControlEngine: TjvVersionControlActionEngine;\r\n DataComponent: TComponent) of object;\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64 or pidOSX32)]\r\n {$ENDIF RTL230_UP}\r\n TJvVersionControlActionList = class(TActionList)\r\n private\r\n FDisableActions: Boolean;\r\n FHideActions: Boolean;\r\n FIconType: Integer;\r\n FOnChangeVersionControlComponent: TJvChangeVersionControlComponent;\r\n FVersionControlComponent: TComponent;\r\n FVersionControlFilename: string;\r\n procedure SetDisableActions(const Value: Boolean);\r\n procedure SetHideActions(const Value: Boolean);\r\n procedure SetIconType(const Value: Integer);\r\n procedure SetVersionControlFilename(const Value: string);\r\n protected\r\n procedure SetVersionControlComponent(Value: TComponent);\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n procedure Notification(AComponent: TComponent; Operation: TOperation); override;\r\n published\r\n property DisableActions: Boolean read FDisableActions write SetDisableActions default true;\r\n property HideActions: Boolean read FHideActions write SetHideActions default false;\r\n property IconType: Integer read FIconType write SetIconType default -1;\r\n property VersionControlComponent: TComponent read FVersionControlComponent write SetVersionControlComponent;\r\n property VersionControlFilename: string read FVersionControlFilename write SetVersionControlFilename;\r\n property OnChangeVersionControlComponent: TJvChangeVersionControlComponent read FOnChangeVersionControlComponent\r\n write FOnChangeVersionControlComponent;\r\n end;\r\n\r\ntype\r\n TJvVersionControlBaseAction = class(TJvActionEngineBaseAction)\r\n private\r\n FActionType: TJclVersionControlActionType;\r\n FAfterExecute: TJvVersionControlActionExecuteEvent;\r\n FDisableAction: Boolean;\r\n FHideAction: Boolean;\r\n FIconType: Integer;\r\n FOnChangeVersionControlComponent: TJvChangeVersionControlComponent;\r\n FOnCheckEnabled: TJvVersionControlActionCheckEnabledEvent;\r\n FOnExecute: TJvVersionControlActionExecuteEvent;\r\n FVersionControlActionEngine: TjvVersionControlActionEngine;\r\n FVersionControlFilename: string;\r\n function GetCurrentCache: TJclVersionControlCache;\r\n function GetCurrentPlugin: TJclVersionControlPlugin;\r\n function GetCurrentVersionControlFilename: string;\r\n procedure SetActionType(const Value: TJclVersionControlActionType);\r\n protected\r\n //1 This Procedure is called when the ActionComponent is changed\r\n procedure ChangeActionComponent(const AActionComponent: TComponent); override;\r\n procedure CheckEnabled(var AEnabled: Boolean); override;\r\n function GetEngineList: TJvActionEngineList; override;\r\n function GetVersionControlComponent: TComponent;\r\n procedure SetVersionControlComponent(Value: TComponent);\r\n property ActionType: TJclVersionControlActionType read FActionType write SetActionType;\r\n property VersionControlActionEngine: TjvVersionControlActionEngine read FVersionControlActionEngine;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n function Execute: Boolean; override;\r\n procedure ExecuteTarget(Target: TObject); override;\r\n function HandlesTarget(Target: TObject): Boolean; override;\r\n procedure SetParentComponent(AParent: TComponent); override;\r\n procedure UpdateTarget(Target: TObject); override;\r\n property CurrentCache: TJclVersionControlCache read GetCurrentCache;\r\n property CurrentPlugin: TJclVersionControlPlugin read GetCurrentPlugin;\r\n property CurrentVersionControlFilename: string read GetCurrentVersionControlFilename;\r\n property DisableAction: Boolean read FDisableAction write FDisableAction default true;\r\n property HideAction: Boolean read FHideAction write FHideAction default false;\r\n property VersionControlFilename: string read FVersionControlFilename write FVersionControlFilename;\r\n published\r\n property IconType: Integer read FIconType write FIconType default -1;\r\n property VersionControlComponent: TComponent read GetVersionControlComponent write SetVersionControlComponent;\r\n property AfterExecute: TJvVersionControlActionExecuteEvent read FAfterExecute write FAfterExecute;\r\n property OnChangeVersionControlComponent: TJvChangeVersionControlComponent read FOnChangeVersionControlComponent\r\n write FOnChangeVersionControlComponent;\r\n property OnCheckEnabled: TJvVersionControlActionCheckEnabledEvent read FOnCheckEnabled write FOnCheckEnabled;\r\n property OnExecute: TJvVersionControlActionExecuteEvent read FOnExecute write FOnExecute;\r\n end;\r\n\r\n TJvVersionControlCommonAction = class(TJvVersionControlBaseAction)\r\n published\r\n property ActionType;\r\n end;\r\n\r\n TJvVersionControlAddAction = class(TJvVersionControlBaseAction)\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n end;\r\n\r\ntype\r\n TJvVersionControlAddSandboxAction = class(TJvVersionControlBaseAction)\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n end;\r\n\r\ntype\r\n TJvVersionControlExploreAction = class(TJvVersionControlBaseAction)\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n end;\r\n\r\ntype\r\n TJvVersionControlDiffAction = class(TJvVersionControlBaseAction)\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n end;\r\n\r\ntype\r\n TJvVersionControlContextMenuAction = class(TJvVersionControlBaseAction)\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n end;\r\n\r\ntype\r\n TJvVersionControlCommitSandboxAction = class(TJvVersionControlBaseAction)\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n end;\r\n\r\ntype\r\n TJvVersionControlCommitAction = class(TJvVersionControlBaseAction)\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n end;\r\n\r\ntype\r\n TJvVersionControlCheckoutSandboxAction = class(TJvVersionControlBaseAction)\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n end;\r\n\r\ntype\r\n TJvVersionControlBranchSandboxAction = class(TJvVersionControlBaseAction)\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n end;\r\n\r\ntype\r\n TJvVersionControlBranchAction = class(TJvVersionControlBaseAction)\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n end;\r\n\r\ntype\r\n TJvVersionControlBlameAction = class(TJvVersionControlBaseAction)\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n end;\r\n\r\ntype\r\n TJvVersionControlGraphAction = class(TJvVersionControlBaseAction)\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n end;\r\n\r\ntype\r\n TJvVersionControlLogAction = class(TJvVersionControlBaseAction)\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n end;\r\n\r\ntype\r\n TJvVersionControlLogSandboxAction = class(TJvVersionControlBaseAction)\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n end;\r\n\r\ntype\r\n TJvVersionControlExploreSandboxAction = class(TJvVersionControlBaseAction)\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n end;\r\n\r\ntype\r\n TJvVersionControlLockAction = class(TJvVersionControlBaseAction)\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n end;\r\n\r\ntype\r\n TJvVersionControlRenameAction = class(TJvVersionControlBaseAction)\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n end;\r\n\r\ntype\r\n TJvVersionControlRepoBrowserAction = class(TJvVersionControlBaseAction)\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n end;\r\n\r\ntype\r\n TJvVersionControlRevertAction = class(TJvVersionControlBaseAction)\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n end;\r\n\r\ntype\r\n TJvVersionControlStatusAction = class(TJvVersionControlBaseAction)\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n end;\r\n\r\ntype\r\n TJvVersionControlTagAction = class(TJvVersionControlBaseAction)\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n end;\r\n\r\ntype\r\n TJvVersionControlUnlockAction = class(TJvVersionControlBaseAction)\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n end;\r\n\r\ntype\r\n TJvVersionControlUpdateToAction = class(TJvVersionControlBaseAction)\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n end;\r\n\r\ntype\r\n TJvVersionControlUpdateAction = class(TJvVersionControlBaseAction)\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n end;\r\n\r\ntype\r\n TJvVersionControlMergeAction = class(TJvVersionControlBaseAction)\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n end;\r\n\r\ntype\r\n TJvVersionControlPropertiesAction = class(TJvVersionControlBaseAction)\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n end;\r\n\r\ntype\r\n TJvVersionControlLockSandboxAction = class(TJvVersionControlBaseAction)\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n end;\r\n\r\ntype\r\n TJvVersionControlMergeSandboxAction = class(TJvVersionControlBaseAction)\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n end;\r\n\r\ntype\r\n TJvVersionControlPropertiesSandboxAction = class(TJvVersionControlBaseAction)\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n end;\r\n\r\ntype\r\n TJvVersionControlRenameSandboxAction = class(TJvVersionControlBaseAction)\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n end;\r\n\r\ntype\r\n TJvVersionControlRevertSandboxAction = class(TJvVersionControlBaseAction)\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n end;\r\n\r\ntype\r\n TJvVersionControlStatusSandboxAction = class(TJvVersionControlBaseAction)\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n end;\r\n\r\ntype\r\n TJvVersionControlTagSandboxAction = class(TJvVersionControlBaseAction)\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n end;\r\n\r\ntype\r\n TJvVersionControlUpdateSandboxAction = class(TJvVersionControlBaseAction)\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n end;\r\n\r\ntype\r\n TJvVersionControlUnlockSandboxAction = class(TJvVersionControlBaseAction)\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n end;\r\n\r\ntype\r\n TJvVersionControlUpdateSandboxToAction = class(TJvVersionControlBaseAction)\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n end;\r\n\r\n\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvVersionControlActions.pas $';\r\n Revision: '$Revision: 13138 $';\r\n Date: '$Date: 2011-10-27 01:17:50 +0200 (jeu. 27 oct. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\n \r\nimplementation\r\n\r\nuses\r\n JvJVCLUtils;\r\n\r\nconstructor TJvVersionControlActionList.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FHideActions := false;\r\n FDisableActions := True;\r\n FIconType := -1;\r\nend;\r\n\r\nprocedure TJvVersionControlActionList.Notification(AComponent: TComponent; Operation: TOperation);\r\nbegin\r\n inherited Notification(AComponent, Operation);\r\n if Operation = opRemove then\r\n if AComponent = FVersionControlComponent then\r\n VersionControlComponent := nil;\r\nend;\r\n\r\nprocedure TJvVersionControlActionList.SetDisableActions(const Value: Boolean);\r\nvar\r\n I: Integer;\r\nbegin\r\n FDisableActions := Value;\r\n for I := 0 to ActionCount - 1 do\r\n if Actions[I] is TJvVersionControlBaseAction then\r\n TJvVersionControlBaseAction(Actions[I]).DisableAction := Value;\r\nend;\r\n\r\nprocedure TJvVersionControlActionList.SetHideActions(const Value: Boolean);\r\nvar\r\n I: Integer;\r\nbegin\r\n FHideActions := Value;\r\n for I := 0 to ActionCount - 1 do\r\n if Actions[I] is TJvVersionControlBaseAction then\r\n TJvVersionControlBaseAction(Actions[I]).HideAction := Value;\r\nend;\r\n\r\nprocedure TJvVersionControlActionList.SetIconType(const Value: Integer);\r\nvar\r\n I: Integer;\r\nbegin\r\n FIconType := Value;\r\n for I := 0 to ActionCount - 1 do\r\n if Actions[I] is TJvVersionControlBaseAction then\r\n TJvVersionControlBaseAction(Actions[I]).IconType := Value;\r\nend;\r\n\r\n//=== { TJvVersionControlActionList } ==============================================\r\n\r\nprocedure TJvVersionControlActionList.SetVersionControlComponent(Value: TComponent);\r\nvar\r\n I: Integer;\r\nbegin\r\n if ReplaceComponentReference(Self, Value, TComponent(FVersionControlComponent)) then\r\n begin\r\n for I := 0 to ActionCount - 1 do\r\n if Actions[I] is TJvVersionControlBaseAction then\r\n TJvVersionControlBaseAction(Actions[I]).VersionControlComponent := Value;\r\n if Assigned(OnChangeVersionControlComponent) then\r\n OnChangeVersionControlComponent(Value);\r\n end;\r\nend;\r\n\r\nprocedure TJvVersionControlActionList.SetVersionControlFilename(const Value: string);\r\nvar\r\n I: Integer;\r\nbegin\r\n if FVersionControlFilename <> Value then\r\n begin\r\n FVersionControlFilename := Value;\r\n for I := 0 to ActionCount - 1 do\r\n if Actions[I] is TJvVersionControlBaseAction then\r\n TJvVersionControlBaseAction(Actions[I]).VersionControlFilename:= Value;\r\n end;\r\nend;\r\n\r\n//=== { TJvVersionControlBaseAction } ==============================================\r\n\r\nconstructor TJvVersionControlBaseAction.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n if Assigned(AOwner) and (AOwner is TJvVersionControlActionList) then\r\n VersionControlComponent := TJvVersionControlActionList(AOwner).VersionControlComponent;\r\n FVersionControlActionEngine := Nil;\r\n if AOwner is TJvVersionControlActionList then\r\n begin\r\n FDisableAction := TJvVersionControlActionList(AOwner).DisableActions;\r\n FHideAction := TJvVersionControlActionList(AOwner).HideActions;\r\n FIconType := TJvVersionControlActionList(AOwner).IconType;\r\n end\r\n else\r\n begin\r\n FDisableAction := true;\r\n FHideAction := false;\r\n FIconType := -1;\r\n end;\r\nend;\r\n\r\n//=== { TJvActionEngineBaseAction } ========================================\r\n\r\nprocedure TJvVersionControlBaseAction.ChangeActionComponent(const AActionComponent:\r\n TComponent);\r\nbegin\r\n inherited ChangeActionComponent(AActionComponent);\r\n if Assigned(ControlEngine) and (ControlEngine is TjvVersionControlActionEngine) then\r\n FVersionControlActionEngine := TjvVersionControlActionEngine(ControlEngine)\r\n else\r\n FVersionControlActionEngine := Nil;\r\nend;\r\n\r\nprocedure TJvVersionControlBaseAction.CheckEnabled(var AEnabled: Boolean);\r\nbegin\r\n// if Assigned(fOnCheckEnabled) then\r\n// fOnCheckEnabled (DataSet, VersionControlComponent, VersionControlActionEngine, aEnabled);\r\nend;\r\n\r\nfunction TJvVersionControlBaseAction.Execute: Boolean;\r\nvar\r\n Index: Integer;\r\n APlugin: TJclVersionControlPlugin;\r\n AFileName: string;\r\n AFileCache: TJclVersionControlCache;\r\nbegin\r\n Result := False;\r\n if VersionControlActionInfo(ActionType).Sandbox then\r\n begin\r\n AFileCache := CurrentCache;\r\n if not Assigned(AFileCache) or VersionControlActionInfo(ActionType).AllPlugins then\r\n Exit;\r\n// if ActOnTopSandbox then\r\n// begin\r\n// for Index := AFileCache.SandboxCount - 1 downto 0 do\r\n// if ActionType in AFileCache.SandboxActions[Index] then\r\n// begin\r\n// if VersionControlActionInfo(ActionType).SaveFile and Assigned (VersionControlActionEngine) and\r\n// VersionControlActionEngine.SupportsSaveFile(VersionControlComponent) then\r\n// if not VersionControlActionEngine.SupportsNeedsSaveFile(VersionControlComponent) or\r\n// VersionControlActionEngine.NeedsSaveFile(VersionControlComponent) then\r\n// VersionControlActionEngine.SaveFile(VersionControlComponent, CurrentVersionControlFilename);\r\n// if VersionControlActionInfo(ActionType).SaveFile then\r\n// SaveModules(AFileCache.SandBoxes[Index], True);\r\n// AFileCache.Plugin.ExecuteAction(AFileCache.SandBoxes[Index], ActionType);\r\n// Exit;\r\n// end;\r\n// end\r\n// else\r\n begin\r\n for Index := 0 to AFileCache.SandboxCount - 1 do\r\n if ActionType in AFileCache.SandboxActions[Index] then\r\n begin\r\n if VersionControlActionInfo(ActionType).SaveFile and Assigned (VersionControlActionEngine) and\r\n VersionControlActionEngine.SupportsSaveFile(VersionControlComponent) then\r\n if not VersionControlActionEngine.SupportsNeedsSaveFile(VersionControlComponent) or\r\n VersionControlActionEngine.NeedsSaveFile(VersionControlComponent) then\r\n VersionControlActionEngine.SaveFile(VersionControlComponent, CurrentVersionControlFilename);\r\n AFileCache.Plugin.ExecuteAction(AFileCache.SandBoxes[Index], ActionType);\r\n Exit;\r\n end;\r\n end;\r\n end\r\n else\r\n begin\r\n AFileName := CurrentVersionControlFilename;\r\n if VersionControlActionInfo(ActionType).SaveFile and Assigned (VersionControlActionEngine) and\r\n VersionControlActionEngine.SupportsSaveFile(VersionControlComponent) then\r\n if not VersionControlActionEngine.SupportsNeedsSaveFile(VersionControlComponent) or\r\n VersionControlActionEngine.NeedsSaveFile(VersionControlComponent) then\r\n VersionControlActionEngine.SaveFile(VersionControlComponent, CurrentVersionControlFilename);\r\n\r\n if VersionControlActionInfo(ActionType).AllPlugins then\r\n begin\r\n for Index := 0 to VersionControlPluginList.Count - 1 do\r\n begin\r\n AFileCache := VersionControlPluginList.GetFileCache(AFileName,\r\n TJclVersionControlPlugin(VersionControlPluginList.Plugins[Index]));\r\n\r\n if ActionType in AFileCache.Actions then\r\n begin\r\n AFileCache.Plugin.ExecuteAction(AFileName, ActionType);\r\n Exit;\r\n end;\r\n end;\r\n end\r\n else\r\n begin\r\n APlugin := CurrentPlugin;\r\n if Assigned(APlugin) then\r\n APlugin.ExecuteAction(AFileName, ActionType);\r\n end;\r\n end;\r\n if Result and Assigned(FAfterExecute) then\r\n FAfterExecute(Self, VersionControlActionEngine, VersionControlComponent)\r\nend;\r\n\r\nprocedure TJvVersionControlBaseAction.ExecuteTarget(Target: TObject);\r\nbegin\r\n if Assigned(FOnExecute) then\r\n FOnExecute(Self, VersionControlActionEngine, VersionControlComponent)\r\n else\r\n inherited ExecuteTarget(Target);\r\nend;\r\n\r\nfunction TJvVersionControlBaseAction.GetCurrentCache: TJclVersionControlCache;\r\nvar\r\n Index: Integer;\r\n AFileName: string;\r\n APlugin: TJclVersionControlPlugin;\r\nbegin\r\n AFileName := CurrentVersionControlFilename;\r\n for Index := 0 to VersionControlPluginList.Count - 1 do\r\n begin\r\n APlugin := TJclVersionControlPlugin(VersionControlPluginList.Plugins[Index]);\r\n Result := VersionControlPluginList.GetFileCache(AFileName, APlugin);\r\n if Result.Supported then\r\n Exit;\r\n end;\r\n Result := nil;\r\nend;\r\n\r\nfunction TJvVersionControlBaseAction.GetCurrentPlugin: TJclVersionControlPlugin;\r\nvar\r\n Index: Integer;\r\n AFileCacheInfo: TJclVersionControlCache;\r\n AFileName: string;\r\nbegin\r\n AFileName := CurrentVersionControlFilename;\r\n for Index := 0 to VersionControlPluginList.Count - 1 do\r\n begin\r\n Result := TJclVersionControlPlugin(VersionControlPluginList.Plugins[Index]);\r\n AFileCacheInfo := VersionControlPluginList.GetFileCache(AFileName, Result);\r\n if AFileCacheInfo.Supported then\r\n Exit;\r\n end;\r\n Result := nil;\r\nend;\r\n\r\nfunction TJvVersionControlBaseAction.GetCurrentVersionControlFilename: string;\r\nbegin\r\n if VersionControlFileName <> '' then\r\n Result := VersionControlFileName\r\n else\r\n if Assigned(VersionControlActionEngine) and VersionControlActionEngine.SupportsGetFileName (VersionControlComponent) then\r\n Result := VersionControlActionEngine.GetFilename (VersionControlComponent)\r\n else\r\n Result := '';\r\nend;\r\n\r\nfunction TJvVersionControlBaseAction.GetEngineList: TJvActionEngineList;\r\nbegin\r\n Result := RegisteredVersionControlActionEngineList;\r\nend;\r\n\r\nfunction TJvVersionControlBaseAction.GetVersionControlComponent: TComponent;\r\nbegin\r\n Result := ActionComponent;\r\nend;\r\n\r\nfunction TJvVersionControlBaseAction.HandlesTarget(Target: TObject): Boolean;\r\nbegin\r\n if VersionControlFilename <> '' then\r\n Result := True\r\n else\r\n Result := Inherited HandlesTarget(Target);\r\nend;\r\n\r\nprocedure TJvVersionControlBaseAction.SetActionType(const Value: TJclVersionControlActionType);\r\nbegin\r\n FActionType := Value;\r\n if Caption = '' then\r\n Caption := LoadResString(VersionControlActionInfo(Value).Caption);\r\n if Name = '' then\r\n Name := VersionControlActionInfo(Value).ActionName;\r\nend;\r\n\r\nprocedure TJvVersionControlBaseAction.SetParentComponent(AParent: TComponent);\r\nbegin\r\n Inherited SetParentComponent(AParent);\r\n if AParent is TJvVersionControlActionList then\r\n begin\r\n FDisableAction := TJvVersionControlActionList(AParent).DisableActions;\r\n FHideAction := TJvVersionControlActionList(AParent).HideActions;\r\n FIconType := TJvVersionControlActionList(AParent).IconType;\r\n end;\r\nend;\r\n\r\nprocedure TJvVersionControlBaseAction.SetVersionControlComponent(Value: TComponent);\r\nbegin\r\n ActionComponent := Value;\r\nend;\r\n\r\nprocedure TJvVersionControlBaseAction.UpdateTarget(Target: TObject);\r\nvar\r\n IndexSandbox, IndexPlugin: Integer;\r\n AFileCache: TJclVersionControlCache;\r\n AFileName: string;\r\nbegin\r\n AFileCache := CurrentCache;\r\n\r\n if HideAction and not VersionControlActionInfo(ActionType).AllPlugins then\r\n SetVisible (Assigned(AFileCache) and Assigned(AFileCache.Plugin)\r\n and (ActionType in AFileCache.Plugin.SupportedActionTypes))\r\n else\r\n SetVisible (True);\r\n\r\n if DisableAction then\r\n begin\r\n if VersionControlActionInfo(ActionType).Sandbox then\r\n begin\r\n if VersionControlActionInfo(ActionType).AllPlugins then\r\n begin\r\n AFileName := CurrentVersionControlFilename;\r\n for IndexPlugin := 0 to VersionControlPluginList.Count - 1 do\r\n begin\r\n AFileCache := VersionControlPluginList.GetFileCache(AFileName,\r\n VersionControlPluginList.Plugins[IndexPlugin]);\r\n for IndexSandbox := 0 to AFileCache.SandBoxCount - 1 do\r\n if ActionType in AFileCache.SandBoxActions[IndexSandbox] then\r\n begin\r\n SetEnabled(True);\r\n Exit;\r\n end;\r\n SetEnabled(False);\r\n Exit;\r\n end;\r\n end\r\n else // work for all plugin\r\n begin\r\n if Assigned(AFileCache) then\r\n begin\r\n for IndexSandbox := 0 to AFileCache.SandBoxCount - 1 do\r\n if ActionType in AFileCache.SandBoxActions[IndexSandbox] then\r\n begin\r\n SetEnabled(True);\r\n Exit;\r\n end;\r\n SetEnabled(False);\r\n Exit;\r\n end\r\n else\r\n SetEnabled(False);\r\n end;\r\n Exit;\r\n end\r\n else // file\r\n begin\r\n if VersionControlActionInfo(ActionType).AllPlugins then\r\n begin\r\n AFileName := CurrentVersionControlFilename;\r\n for IndexPlugin := 0 to VersionControlPluginList.Count - 1 do\r\n begin\r\n AFileCache := VersionControlPluginList.GetFileCache(AFileName,\r\n VersionControlPluginList.Plugins[IndexPlugin]);\r\n if ActionType in AFileCache.Actions then\r\n begin\r\n SetEnabled(True);\r\n Exit;\r\n end;\r\n end;\r\n SetEnabled(False);\r\n Exit;\r\n end\r\n else // only the current plugin\r\n begin\r\n AFileCache := CurrentCache;\r\n SetEnabled(Assigned(AFileCache) and (ActionType in AFileCache.Actions));\r\n end;\r\n end;\r\n end\r\n else\r\n SetEnabled(True);\r\nend;\r\n\r\n//=== { TJvVersionControlAddAction } ==============================================\r\n\r\nconstructor TJvVersionControlAddAction.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n ActionType := vcaAdd;\r\nend;\r\n\r\n//=== { TJvVersionControlAddSandboxAction } ==============================================\r\n\r\nconstructor TJvVersionControlAddSandboxAction.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n ActionType := vcaAddSandbox;\r\nend;\r\n\r\n//=== { TJvVersionControlExploreAction } ==============================================\r\n\r\nconstructor TJvVersionControlExploreAction.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n ActionType := vcaExplore;\r\nend;\r\n\r\n//=== { TJvVersionControlDiffAction } ==============================================\r\n\r\nconstructor TJvVersionControlDiffAction.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n ActionType := vcaDiff;\r\nend;\r\n\r\n//=== { TJvVersionControlContextMenuAction } ==============================================\r\n\r\nconstructor TJvVersionControlContextMenuAction.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n ActionType := vcaContextMenu;\r\nend;\r\n\r\n//=== { TJvVersionControlCommitSandboxAction } ==============================================\r\n\r\nconstructor TJvVersionControlCommitSandboxAction.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n ActionType := vcaCommitSandbox;\r\nend;\r\n\r\n//=== { TJvVersionControlCommitAction } ==============================================\r\n\r\nconstructor TJvVersionControlCommitAction.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n ActionType := vcaCommit;\r\nend;\r\n\r\n//=== { TJvVersionControlCheckoutSandboxAction } ==============================================\r\n\r\nconstructor TJvVersionControlCheckoutSandboxAction.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n ActionType := vcaCheckoutSandbox;\r\nend;\r\n\r\n//=== { TJvVersionControlBranchSandboxAction } ==============================================\r\n\r\nconstructor TJvVersionControlBranchSandboxAction.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n ActionType := vcaBranchSandbox;\r\nend;\r\n\r\n//=== { TJvVersionControlBranchAction } ==============================================\r\n\r\nconstructor TJvVersionControlBranchAction.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n ActionType := vcaBranch;\r\nend;\r\n\r\n//=== { TJvVersionControlBlameAction } ==============================================\r\n\r\nconstructor TJvVersionControlBlameAction.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n ActionType := vcaBlame;\r\nend;\r\n\r\n//=== { TJvVersionControlGraphAction } ==============================================\r\n\r\nconstructor TJvVersionControlGraphAction.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n ActionType := vcaGraph;\r\nend;\r\n\r\n//=== { TJvVersionControlLogAction } ==============================================\r\n\r\nconstructor TJvVersionControlLogAction.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n ActionType := vcaLog;\r\nend;\r\n\r\n//=== { TJvVersionControlLogSandboxAction } ==============================================\r\n\r\nconstructor TJvVersionControlLogSandboxAction.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n ActionType := vcaLogSandbox;\r\nend;\r\n\r\n//=== { TJvVersionControlExploreSandboxAction } ==============================================\r\n\r\nconstructor TJvVersionControlExploreSandboxAction.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n ActionType := vcaExploreSandbox;\r\nend;\r\n\r\n//=== { TJvVersionControlLockAction } ==============================================\r\n\r\nconstructor TJvVersionControlLockAction.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n ActionType := vcaLock;\r\nend;\r\n\r\n//=== { TJvVersionControlRenameAction } ==============================================\r\n\r\nconstructor TJvVersionControlRenameAction.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n ActionType := vcaRename;\r\nend;\r\n\r\n//=== { TJvVersionControlRepoBrowserAction } ==============================================\r\n\r\nconstructor TJvVersionControlRepoBrowserAction.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n ActionType := vcaRepoBrowser;\r\nend;\r\n\r\n//=== { TJvVersionControlRevertAction } ==============================================\r\n\r\nconstructor TJvVersionControlRevertAction.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n ActionType := vcaRevert;\r\nend;\r\n\r\n//=== { TJvVersionControlStatusAction } ==============================================\r\n\r\nconstructor TJvVersionControlStatusAction.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n ActionType := vcaStatus;\r\nend;\r\n\r\n//=== { TJvVersionControlTagAction } ==============================================\r\n\r\nconstructor TJvVersionControlTagAction.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n ActionType := vcaTag;\r\nend;\r\n\r\n//=== { TJvVersionControlUnlockAction } ==============================================\r\n\r\nconstructor TJvVersionControlUnlockAction.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n ActionType := vcaUnlock;\r\nend;\r\n\r\n//=== { TJvVersionControlUpdateToAction } ==============================================\r\n\r\nconstructor TJvVersionControlUpdateToAction.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n ActionType := vcaUpdateTo;\r\nend;\r\n\r\n//=== { TJvVersionControlUpdateAction } ==============================================\r\n\r\nconstructor TJvVersionControlUpdateAction.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n ActionType := vcaUpdate;\r\nend;\r\n\r\n//=== { TJvVersionControlMergeAction } ==============================================\r\n\r\nconstructor TJvVersionControlMergeAction.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n ActionType := vcaMerge;\r\nend;\r\n\r\n//=== { TJvVersionControlPropertiesAction } ==============================================\r\n\r\nconstructor TJvVersionControlPropertiesAction.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n ActionType := vcaProperties;\r\nend;\r\n\r\n//=== { TJvVersionControlLockSandboxAction } ==============================================\r\n\r\nconstructor TJvVersionControlLockSandboxAction.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n ActionType := vcaLockSandbox;\r\nend;\r\n\r\n//=== { TJvVersionControlMergeSandboxAction } ==============================================\r\n\r\nconstructor TJvVersionControlMergeSandboxAction.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n ActionType := vcaMergeSandbox;\r\nend;\r\n\r\n//=== { TJvVersionControlPropertiesSandboxAction } ==============================================\r\n\r\nconstructor TJvVersionControlPropertiesSandboxAction.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n ActionType := vcaPropertiesSandbox;\r\nend;\r\n\r\n//=== { TJvVersionControlRenameSandboxAction } ==============================================\r\n\r\nconstructor TJvVersionControlRenameSandboxAction.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n ActionType := vcaRenameSandbox;\r\nend;\r\n\r\n//=== { TJvVersionControlRevertSandboxAction } ==============================================\r\n\r\nconstructor TJvVersionControlRevertSandboxAction.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n ActionType := vcaRevertSandbox;\r\nend;\r\n\r\n//=== { TJvVersionControlStatusSandboxAction } ==============================================\r\n\r\nconstructor TJvVersionControlStatusSandboxAction.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n ActionType := vcaStatusSandbox;\r\nend;\r\n\r\n//=== { TJvVersionControlTagSandboxAction } ==============================================\r\n\r\nconstructor TJvVersionControlTagSandboxAction.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n ActionType := vcaTagSandbox;\r\nend;\r\n\r\n//=== { TJvVersionControlUpdateSandboxAction } ==============================================\r\n\r\nconstructor TJvVersionControlUpdateSandboxAction.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n ActionType := vcaUpdateSandbox;\r\nend;\r\n\r\n//=== { TJvVersionControlUnlockSandboxAction } ==============================================\r\n\r\nconstructor TJvVersionControlUnlockSandboxAction.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n ActionType := vcaUnlockSandbox;\r\nend;\r\n\r\n//=== { TJvVersionControlUpdateSandboxToAction } ==============================================\r\n\r\nconstructor TJvVersionControlUpdateSandboxToAction.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n ActionType := vcaUpdateSandboxTo;\r\nend;\r\n\r\ninitialization\r\n {$IFDEF UNITVERSIONING}\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n {$ENDIF UNITVERSIONING}\r\n\r\nfinalization\r\n {$IFDEF UNITVERSIONING}\r\n UnregisterUnitVersion(HInstance);\r\n {$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvVersionControlActionsEngine.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvDBActions.Pas, released on 2007-03-11.\r\n\r\nThe Initial Developer of the Original Code is Jens Fudickar [jens dott fudicker att oratool dott de]\r\nPortions created by Jens Fudickar are Copyright (C) 2002 Jens Fudickar.\r\nAll Rights Reserved.\r\n\r\nContributor(s): -\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvVersionControlActionsEngine.pas 13138 2011-10-26 23:17:50Z jfudickar $\r\n\r\nunit JvVersionControlActionsEngine;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, Graphics,\r\n Forms, Controls, Classes, JvActionsEngine;\r\n\r\ntype\r\n TjvVersionControlActionEngine = class(TJvActionBaseEngine)\r\n private\r\n FOnChangeActionComponent: TJvChangeActionComponent;\r\n protected\r\n function GetEngineList: TJvActionEngineList; virtual; abstract;\r\n property EngineList: TJvActionEngineList read GetEngineList;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n function GetFilename(aActionComponent: TComponent): string; virtual;\r\n function SaveFile(aActionComponent: TComponent;const aFilename: string): Boolean; virtual;\r\n function NeedsSaveFile(aActionComponent: TComponent): Boolean; virtual;\r\n function SupportsAction(AAction: TJvActionEngineBaseAction): Boolean; override;\r\n function SupportsGetFileName(aActionComponent: TComponent): Boolean; virtual;\r\n function SupportsSaveFile(aActionComponent: TComponent): Boolean; virtual;\r\n function SupportsNeedsSaveFile(aActionComponent: TComponent): Boolean; virtual;\r\n property OnChangeActionComponent: TJvChangeActionComponent read FOnChangeActionComponent write FOnChangeActionComponent;\r\n end;\r\n\r\n TjvVersionControlActionEngineClass = class of TjvVersionControlActionEngine;\r\n TjvVersionControlActionEngineList = class(TJvActionEngineList)\r\n public\r\n procedure RegisterEngine(AEngineClass: TjvVersionControlActionEngineClass);\r\n end;\r\n\r\nprocedure RegisterVersionControlActionEngine(AEngineClass: TjvVersionControlActionEngineClass);\r\n\r\nfunction RegisteredVersionControlActionEngineList: TjvVersionControlActionEngineList;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvVersionControlActionsEngine.pas $';\r\n Revision: '$Revision: 13138 $';\r\n Date: '$Date: 2011-10-27 01:17:50 +0200 (jeu. 27 oct. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n SysUtils,\r\n Variants, Dialogs,\r\n JvVersionControlActions;\r\n\r\n\r\nvar\r\n IntRegisteredActionEngineList: TjvVersionControlActionEngineList;\r\n\r\nprocedure RegisterVersionControlActionEngine(AEngineClass: TjvVersionControlActionEngineClass);\r\nbegin\r\n if Assigned(IntRegisteredActionEngineList) then\r\n IntRegisteredActionEngineList.RegisterEngine(AEngineClass);\r\nend;\r\n\r\nfunction RegisteredVersionControlActionEngineList: TjvVersionControlActionEngineList;\r\nbegin\r\n Result := IntRegisteredActionEngineList;\r\nend;\r\n\r\nprocedure CreateActionEngineList;\r\nbegin\r\n IntRegisteredActionEngineList := TjvVersionControlActionEngineList.Create;\r\nend;\r\n\r\nprocedure DestroyActionEngineList;\r\nbegin\r\n IntRegisteredActionEngineList.Free;\r\n IntRegisteredActionEngineList := nil;\r\nend;\r\n\r\nprocedure InitActionEngineList;\r\nbegin\r\n CreateActionEngineList;\r\nend;\r\n\r\nconstructor TjvVersionControlActionEngine.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\nend;\r\n\r\nfunction TjvVersionControlActionEngine.GetFilename(aActionComponent:\r\n TComponent): string;\r\nbegin\r\n Result := '';\r\nend;\r\n\r\nfunction TjvVersionControlActionEngine.SaveFile(aActionComponent: TComponent;const aFilename: string): Boolean;\r\nbegin\r\n Result := True;\r\nend;\r\n\r\nfunction TjvVersionControlActionEngine.NeedsSaveFile(aActionComponent: TComponent): Boolean;\r\nbegin\r\n Result := False;\r\nend;\r\n\r\nfunction TjvVersionControlActionEngine.SupportsAction(AAction: TJvActionEngineBaseAction): Boolean;\r\nbegin\r\n Result := (AAction is TJvVersionControlBaseAction) ;\r\nend;\r\n\r\nfunction TjvVersionControlActionEngine.SupportsGetFileName(aActionComponent: TComponent): Boolean;\r\nbegin\r\n Result := False;\r\nend;\r\n\r\nfunction TjvVersionControlActionEngine.SupportsSaveFile(aActionComponent: TComponent): Boolean;\r\nbegin\r\n Result := False;\r\nend;\r\n\r\nfunction TjvVersionControlActionEngine.SupportsNeedsSaveFile(aActionComponent: TComponent): Boolean;\r\nbegin\r\n Result := False;\r\nend;\r\n\r\n\r\nprocedure TjvVersionControlActionEngineList.RegisterEngine(AEngineClass: TjvVersionControlActionEngineClass);\r\nbegin\r\n Add(AEngineClass.Create(nil));\r\nend;\r\n\r\n\r\ninitialization\r\n {$IFDEF UNITVERSIONING}\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n {$ENDIF UNITVERSIONING}\r\n InitActionEngineList;\r\n\r\nfinalization\r\n DestroyActionEngineList;\r\n {$IFDEF UNITVERSIONING}\r\n UnregisterUnitVersion(HInstance);\r\n {$ENDIF UNITVERSIONING}\r\n\r\nend." }, { "path": "External/Jedi/Jvcl/run/JvVersionControlActionsEngineFileListBox.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvVersionControlActionsEngineFileListBox.Pas, released on 2008-07-13.\r\n\r\nThe Initial Developer of the Original Code is Jens Fudickar [jens dott fudicker att oratool dott de]\r\nPortions created by Jens Fudickar are Copyright (C) 2002 Jens Fudickar.\r\nAll Rights Reserved.\r\n\r\nContributor(s): -\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvVersionControlActionsEngineFileListBox.pas 13138 2011-10-26 23:17:50Z jfudickar $\r\n\r\nunit JvVersionControlActionsEngineFileListBox;\r\n\r\n{$I jvcl.inc}\r\n{$I windowsonly.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n {$IFDEF MSWINDOWS}\r\n Windows, Graphics,\r\n {$ENDIF MSWINDOWS}\r\n Forms, Controls, Classes, JvVersionControlActionsEngine;\r\n\r\ntype\r\n\r\n\r\n TjvVersionControlActionFileListBoxEngine = class(TjvVersionControlActionEngine)\r\n private\r\n protected\r\n public\r\n function GetFilename(aActionComponent: TComponent): string; override;\r\n function SupportsComponent(aActionComponent: TComponent): Boolean; override;\r\n function SupportsGetFileName(aActionComponent: TComponent): Boolean; override;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvVersionControlActionsEngineFileListBox.pas $';\r\n Revision: '$Revision: 13138 $';\r\n Date: '$Date: 2011-10-27 01:17:50 +0200 (jeu. 27 oct. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n SysUtils, Variants,\r\n Dialogs, FileCtrl;\r\n\r\n\r\nprocedure InitActionEngineList;\r\nbegin\r\n RegisterVersionControlActionEngine (TjvVersionControlActionFileListBoxEngine);\r\nend;\r\n\r\nfunction TjvVersionControlActionFileListBoxEngine.SupportsComponent(aActionComponent:\r\n TComponent): Boolean;\r\nbegin\r\n Result := aActionComponent is TFilelistBox;\r\nend;\r\n\r\nfunction TjvVersionControlActionFileListBoxEngine.GetFilename(aActionComponent:\r\n TComponent): string;\r\nbegin\r\n Result := TFilelistBox(aActionComponent).FileName;\r\nend;\r\n\r\nfunction TjvVersionControlActionFileListBoxEngine.SupportsGetFileName(\r\n aActionComponent: TComponent): Boolean;\r\nbegin\r\n Result := True;\r\nend;\r\n\r\ninitialization\r\n {$IFDEF UNITVERSIONING}\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n {$ENDIF UNITVERSIONING}\r\n InitActionEngineList;\r\n\r\nfinalization\r\n {$IFDEF UNITVERSIONING}\r\n UnregisterUnitVersion(HInstance);\r\n {$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvVersionInfo.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvVerInf.PAS, released on 2002-07-04.\r\n\r\nThe Initial Developers of the Original Code are: Fedor Koshevnikov, Igor Pavluk and Serge Korolev\r\nCopyright (c) 1997, 1998 Fedor Koshevnikov, Igor Pavluk and Serge Korolev\r\nCopyright (c) 2001,2002 SGB Software\r\nAll Rights Reserved.\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvVersionInfo.pas 13303 2012-06-02 20:25:06Z jfudickar $\r\n\r\nunit JvVersionInfo;\r\n\r\n{$I jvcl.inc}\r\n{$I windowsonly.inc}\r\n\r\n{$IFDEF SUPPORTS_WEAKPACKAGEUNIT}\r\n{$WEAKPACKAGEUNIT ON} // prevents this unit from UnitVersioning\r\n{$ENDIF SUPPORTS_WEAKPACKAGEUNIT}\r\n\r\ninterface\r\n\r\nuses\r\n Windows, SysUtils;\r\n\r\ntype\r\n TVersionLanguage =\r\n (vlArabic, vlBulgarian, vlCatalan, vlTraditionalChinese,\r\n vlCzech, vlDanish, vlGerman, vlGreek, vlUSEnglish, vlCastilianSpanish,\r\n vlFinnish, vlFrench, vlHebrew, vlHungarian, vlIcelandic, vlItalian,\r\n vlJapanese, vlKorean, vlDutch, vlNorwegianBokmel, vlPolish,\r\n vlBrazilianPortuguese, vlRhaetoRomanic, vlRomanian, vlRussian,\r\n vlCroatoSerbian, vlSlovak, vlAlbanian, vlSwedish, vlThai, vlTurkish,\r\n vlUrdu, vlBahasa, vlSimplifiedChinese, vlSwissGerman, vlUKEnglish,\r\n vlMexicanSpanish, vlBelgianFrench, vlSwissItalian, vlBelgianDutch,\r\n vlNorwegianNynorsk, vlPortuguese, vlSerboCroatian, vlCanadianFrench,\r\n vlSwissFrench, vlUnknown);\r\n\r\n TVersionCharSet =\r\n (vcsASCII, vcsJapan, vcsKorea, vcsTaiwan, vcsUnicode,\r\n vcsEasternEuropean, vcsCyrillic, vcsMultilingual, vcsGreek, vcsTurkish,\r\n vcsHebrew, vcsArabic, vcsUnknown);\r\n\r\n TLongVersion = record\r\n case Integer of\r\n 0:\r\n (All: array [1..4] of Word);\r\n 1:\r\n (MS, LS: Longint);\r\n end;\r\n\r\n TJvVersionInfo = class(TObject)\r\n private\r\n FFileName: TFileName;\r\n FValid: Boolean;\r\n FBuffer: Pointer;\r\n procedure ReadVersionInfo;\r\n procedure SetFileName(const Value: TFileName);\r\n function GetTranslation: Pointer;\r\n function GetFixedFileInfo: PVSFixedFileInfo;\r\n function GetFileLongVersion: TLongVersion;\r\n function GetProductLongVersion: TLongVersion;\r\n function GetTranslationString: string;\r\n function GetComments: string;\r\n function GetCompanyName: string;\r\n function GetFileDescription: string;\r\n function GetFileVersion: string;\r\n function GetVersionNum: Longint;\r\n function GetInternalName: string;\r\n function GetLegalCopyright: string;\r\n function GetLegalTrademarks: string;\r\n function GetOriginalFilename: string;\r\n function GetProductVersion: string;\r\n function GetProductName: string;\r\n function GetSpecialBuild: string;\r\n function GetPrivateBuild: string;\r\n function GetVersionLanguage: TVersionLanguage;\r\n function GetVersionCharSet: TVersionCharSet;\r\n function GetVerFileDate: TDateTime;\r\n public\r\n constructor Create(const AFileName: string);\r\n destructor Destroy; override;\r\n function GetVerValue(const VerName: string): string;\r\n property FileName: TFileName read FFileName write SetFileName;\r\n property Valid: Boolean read FValid;\r\n property FixedFileInfo: PVSFixedFileInfo read GetFixedFileInfo;\r\n property FileLongVersion: TLongVersion read GetFileLongVersion;\r\n property ProductLongVersion: TLongVersion read GetProductLongVersion;\r\n property Translation: Pointer read GetTranslation;\r\n property VersionLanguage: TVersionLanguage read GetVersionLanguage;\r\n property VersionCharSet: TVersionCharSet read GetVersionCharSet;\r\n property VersionNum: Longint read GetVersionNum;\r\n property Comments: string read GetComments;\r\n property CompanyName: string read GetCompanyName;\r\n property FileDescription: string read GetFileDescription;\r\n property FileVersion: string read GetFileVersion;\r\n property InternalName: string read GetInternalName;\r\n property LegalCopyright: string read GetLegalCopyright;\r\n property LegalTrademarks: string read GetLegalTrademarks;\r\n property OriginalFilename: string read GetOriginalFilename;\r\n property ProductVersion: string read GetProductVersion;\r\n property ProductName: string read GetProductName;\r\n property SpecialBuild: string read GetSpecialBuild;\r\n property PrivateBuild: string read GetPrivateBuild;\r\n property Values[const Name: string]: string read GetVerValue;\r\n property VerFileDate: TDateTime read GetVerFileDate;\r\n end;\r\n\r\nfunction LongVersionToString(const Version: TLongVersion): string;\r\nfunction StringToLongVersion(const Str: string): TLongVersion;\r\nfunction AppFileName: string;\r\nfunction AppVerInfo: TJvVersionInfo;\r\n\r\n{ Installation utility routine }\r\n\r\nfunction OkToWriteModule(ModuleName: string; NewVer: Longint): Boolean;\r\n\r\nconst\r\n LanguageValues: array [TVersionLanguage] of Word =\r\n ($0401, $0402, $0403, $0404, $0405, $0406, $0407, $0408, $0409, $040A,\r\n $040B, $040C, $040D, $040E, $040F, $0410, $0411, $0412, $0413, $0414,\r\n $0415, $0416, $0417, $0418, $0419, $041A, $041B, $041C, $041D, $041E,\r\n $041F, $0420, $0421, $0804, $0807, $0809, $080A, $080C, $0810, $0813,\r\n $0814, $0816, $081A, $0C0C, $100C, $0000);\r\n\r\nconst\r\n CharacterSetValues: array [TVersionCharSet] of Integer =\r\n (0, 932, 949, 950, 1200, 1250, 1251, 1252, 1253, 1254, 1255, 1256, -1);\r\n\r\nimplementation\r\n\r\nuses\r\n JclFileUtils, JvJCLUtils;\r\n\r\nconstructor TJvVersionInfo.Create(const AFileName: string);\r\nbegin\r\n inherited Create;\r\n FFileName := AFileName;\r\n FBuffer := nil;\r\n ReadVersionInfo;\r\nend;\r\n\r\ndestructor TJvVersionInfo.Destroy;\r\nbegin\r\n if FBuffer <> nil then\r\n FreeMem(FBuffer);\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvVersionInfo.ReadVersionInfo;\r\nvar\r\n Handle: DWORD;\r\n Size: DWORD;\r\nbegin\r\n FValid := False;\r\n Size := GetFileVersionInfoSize(PChar(FFileName), Handle);\r\n if Size > 0 then\r\n try\r\n GetMem(FBuffer, Size);\r\n FValid := GetFileVersionInfo(PChar(FFileName), Handle, Size, FBuffer);\r\n except\r\n FValid := False;\r\n raise;\r\n end;\r\nend;\r\n\r\nprocedure TJvVersionInfo.SetFileName(const Value: TFileName);\r\nbegin\r\n if FBuffer <> nil then\r\n FreeMem(FBuffer);\r\n FBuffer := nil;\r\n FFileName := Value;\r\n ReadVersionInfo;\r\nend;\r\n\r\nfunction TJvVersionInfo.GetTranslation: Pointer;\r\nvar\r\n Len: UINT;\r\nbegin\r\n if Valid then\r\n VerQueryValue(FBuffer, '\\VarFileInfo\\Translation', Result, Len)\r\n else\r\n Result := nil;\r\nend;\r\n\r\nfunction TJvVersionInfo.GetTranslationString: string;\r\nvar\r\n P: Pointer;\r\nbegin\r\n P := GetTranslation;\r\n if P <> nil then\r\n Result := IntToHex(MakeLong(HiWord(Longint(P^)), LoWord(Longint(P^))), 8)\r\n else\r\n Result := '';\r\nend;\r\n\r\nfunction TJvVersionInfo.GetVersionLanguage: TVersionLanguage;\r\nvar\r\n P: Pointer;\r\nbegin\r\n P := GetTranslation;\r\n if P <> nil then\r\n begin\r\n for Result := vlArabic to vlUnknown do\r\n if LoWord(Longint(P^)) = LanguageValues[Result] then\r\n Break;\r\n end\r\n else\r\n Result := vlUnknown;\r\nend;\r\n\r\nfunction TJvVersionInfo.GetVersionCharSet: TVersionCharSet;\r\nvar\r\n P: Pointer;\r\nbegin\r\n P := GetTranslation;\r\n if P <> nil then\r\n begin\r\n for Result := vcsASCII to vcsUnknown do\r\n if HiWord(Longint(P^)) = CharacterSetValues[Result] then\r\n Break;\r\n end\r\n else\r\n Result := vcsUnknown;\r\nend;\r\n\r\nfunction TJvVersionInfo.GetFixedFileInfo: PVSFixedFileInfo;\r\nvar\r\n Len: UINT;\r\nbegin\r\n if Valid then\r\n VerQueryValue(FBuffer, '\\', Pointer(Result), Len)\r\n else\r\n Result := nil;\r\nend;\r\n\r\nfunction TJvVersionInfo.GetProductLongVersion: TLongVersion;\r\nbegin\r\n if Valid then\r\n begin\r\n Result.MS := FixedFileInfo^.dwProductVersionMS;\r\n Result.LS := FixedFileInfo^.dwProductVersionLS;\r\n end\r\n else\r\n FillChar(Result, SizeOf(Result), 0);\r\nend;\r\n\r\nfunction TJvVersionInfo.GetFileLongVersion: TLongVersion;\r\nbegin\r\n if Valid then\r\n begin\r\n Result.MS := FixedFileInfo^.dwFileVersionMS;\r\n Result.LS := FixedFileInfo^.dwFileVersionLS;\r\n end\r\n else\r\n FillChar(Result, SizeOf(Result), 0);\r\nend;\r\n\r\nfunction TJvVersionInfo.GetVersionNum: Longint;\r\nbegin\r\n if Valid then\r\n Result := FixedFileInfo^.dwFileVersionMS\r\n else\r\n Result := 0;\r\nend;\r\n\r\nfunction TJvVersionInfo.GetVerValue(const VerName: string): string;\r\nvar\r\n szName: array [0..255] of Char;\r\n Value: Pointer;\r\n Len: UINT;\r\nbegin\r\n Result := '';\r\n if Valid then\r\n begin\r\n StrPCopy(szName, '\\StringFileInfo\\' + GetTranslationString + '\\' + VerName);\r\n if VerQueryValue(FBuffer, szName, Value, Len) then\r\n Result := PChar(Value);\r\n end;\r\nend;\r\n\r\nfunction TJvVersionInfo.GetComments: string;\r\nbegin\r\n Result := GetVerValue('Comments');\r\nend;\r\n\r\nfunction TJvVersionInfo.GetCompanyName: string;\r\nbegin\r\n Result := GetVerValue('CompanyName');\r\nend;\r\n\r\nfunction TJvVersionInfo.GetFileDescription: string;\r\nbegin\r\n Result := GetVerValue('FileDescription');\r\nend;\r\n\r\nfunction TJvVersionInfo.GetFileVersion: string;\r\nbegin\r\n Result := GetVerValue('FileVersion');\r\n if (Result = '') and Valid then\r\n Result := LongVersionToString(FileLongVersion);\r\nend;\r\n\r\nfunction TJvVersionInfo.GetInternalName: string;\r\nbegin\r\n Result := GetVerValue('InternalName');\r\nend;\r\n\r\nfunction TJvVersionInfo.GetLegalCopyright: string;\r\nbegin\r\n Result := GetVerValue('LegalCopyright');\r\nend;\r\n\r\nfunction TJvVersionInfo.GetLegalTrademarks: string;\r\nbegin\r\n Result := GetVerValue('LegalTrademarks');\r\nend;\r\n\r\nfunction TJvVersionInfo.GetOriginalFilename: string;\r\nbegin\r\n Result := GetVerValue('OriginalFilename');\r\nend;\r\n\r\nfunction TJvVersionInfo.GetProductVersion: string;\r\nbegin\r\n Result := GetVerValue('ProductVersion');\r\n if (Result = '') and Valid then\r\n Result := LongVersionToString(ProductLongVersion);\r\nend;\r\n\r\nfunction TJvVersionInfo.GetProductName: string;\r\nbegin\r\n Result := GetVerValue('ProductName');\r\nend;\r\n\r\nfunction TJvVersionInfo.GetSpecialBuild: string;\r\nbegin\r\n Result := GetVerValue('SpecialBuild');\r\nend;\r\n\r\nfunction TJvVersionInfo.GetPrivateBuild: string;\r\nbegin\r\n Result := GetVerValue('PrivateBuild');\r\nend;\r\n\r\nfunction TJvVersionInfo.GetVerFileDate: TDateTime;\r\nbegin\r\n if FileExists(FileName) then\r\n Result := FileDateTime(FileName)\r\n else\r\n Result := NullDate;\r\nend;\r\n\r\n{ Long version string routines }\r\n\r\nfunction LongVersionToString(const Version: TLongVersion): string;\r\nbegin\r\n with Version do\r\n Result := Format('%d.%d.%d.%d', [All[2], All[1], All[4], All[3]]);\r\nend;\r\n\r\nfunction StringToLongVersion(const Str: string): TLongVersion;\r\nvar\r\n Sep: Integer;\r\n Tmp, Fragment: string;\r\n I: Word;\r\nbegin\r\n Tmp := Str;\r\n for I := 1 to 4 do\r\n begin\r\n Sep := Pos('.', Tmp);\r\n if Sep = 0 then\r\n Sep := Pos(',', Tmp);\r\n if Sep = 0 then\r\n Fragment := Tmp\r\n else\r\n begin\r\n Fragment := Copy(Tmp, 1, Sep - 1);\r\n Tmp := Copy(Tmp, Sep + 1, MaxInt);\r\n end;\r\n if Fragment = '' then\r\n Result.All[I] := 0\r\n else\r\n Result.All[I] := StrToInt(Fragment);\r\n end;\r\n I := Result.All[1];\r\n Result.All[1] := Result.All[2];\r\n Result.All[2] := I;\r\n I := Result.All[3];\r\n Result.All[3] := Result.All[4];\r\n Result.All[4] := I;\r\nend;\r\n\r\nfunction AppFileName: string;\r\nvar\r\n FileName: array [0..MAX_PATH] of Char;\r\nbegin\r\n if IsLibrary then\r\n begin\r\n GetModuleFileName(HInstance, FileName, SizeOf(FileName) - 1);\r\n Result := FileName;\r\n end\r\n else\r\n Result := ParamStr(0);\r\nend;\r\n\r\nfunction AppVerInfo: TJvVersionInfo;\r\nbegin\r\n Result := TJvVersionInfo.Create(AppFileName);\r\nend;\r\n\r\n{ Installation utility routines }\r\n\r\nfunction OkToWriteModule(ModuleName: string; NewVer: Longint): Boolean;\r\n{ Return True if it's ok to overwrite ModuleName with NewVer }\r\nbegin\r\n {Assume we should overwrite}\r\n Result := True;\r\n with TJvVersionInfo.Create(ModuleName) do\r\n begin\r\n try\r\n if Valid then {Should we overwrite?}\r\n Result := NewVer > VersionNum;\r\n finally\r\n Free;\r\n end;\r\n end;\r\nend;\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvVirtualKeySelectionFrame.dfm", "content": "object JvVirtualKeySelectionFrame: TJvVirtualKeySelectionFrame\r\n Left = 0\r\n Top = 0\r\n Width = 213\r\n Height = 50\r\n TabOrder = 0\r\n object lblVirtualKey: TLabel\r\n Left = 0\r\n Top = 4\r\n Width = 69\r\n Height = 13\r\n Alignment = taRightJustify\r\n AutoSize = False\r\n Caption = 'Virtual key'\r\n end\r\n object lblModifiers: TLabel\r\n Left = 0\r\n Top = 32\r\n Width = 69\r\n Height = 13\r\n Alignment = taRightJustify\r\n AutoSize = False\r\n Caption = 'Modifiers'\r\n end\r\n object cmbVirtualKey: TComboBox\r\n Left = 80\r\n Top = 0\r\n Width = 133\r\n Height = 21\r\n ItemHeight = 13\r\n Sorted = True\r\n TabOrder = 0\r\n end\r\n object chkShift: TCheckBox\r\n Left = 88\r\n Top = 32\r\n Width = 57\r\n Height = 17\r\n Caption = 'Shift'\r\n TabOrder = 1\r\n end\r\n object chkCtrl: TCheckBox\r\n Left = 156\r\n Top = 32\r\n Width = 57\r\n Height = 17\r\n Caption = 'Ctrl'\r\n TabOrder = 2\r\n end\r\nend\r\n" }, { "path": "External/Jedi/Jvcl/run/JvVirtualKeySelectionFrame.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvVirtualKeySelection.PAS, released 2003-07-05.\r\n\r\nThe Initial Developer of the Original Code is Olivier Sannier \r\nPortions created by Olivier Sannier are Copyright (C) 2003 Olivier Sannier.\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\n\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nDescription:\r\n This unit defines a frame that you can use to select a key code.\r\n The primary use for that frame is un conjunction with a TJvAVICapture\r\n component.\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvVirtualKeySelectionFrame.pas 12461 2009-08-14 17:21:33Z obones $\r\n\r\nunit JvVirtualKeySelectionFrame;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,\r\n {$IFDEF USE_DXGETTEXT}\r\n JvGnugettext,\r\n {$ENDIF USE_DXGETTEXT}\r\n StdCtrls;\r\n\r\ntype\r\n TJvVirtualKeySelectionFrame = class(TFrame)\r\n cmbVirtualKey: TComboBox;\r\n lblVirtualKey: TLabel;\r\n chkShift: TCheckBox;\r\n chkCtrl: TCheckBox;\r\n lblModifiers: TLabel;\r\n protected\r\n function GetKeyCode: Word;\r\n function GetShiftState: TShiftState;\r\n function GetCombinedKeyCode: Word;\r\n procedure SetCombinedKeyCode(const Value: Word);\r\n procedure EnumKeys;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n property CombinedKeyCode: Word read GetCombinedKeyCode write SetCombinedKeyCode;\r\n property KeyCode: Word read GetKeyCode;\r\n property ShiftState: TShiftState read GetShiftState;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvVirtualKeySelectionFrame.pas $';\r\n Revision: '$Revision: 12461 $';\r\n Date: '$Date: 2009-08-14 19:21:33 +0200 (ven. 14 août 2009) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n JvResources;\r\n\r\n{$R *.dfm}\r\n\r\nconstructor TJvVirtualKeySelectionFrame.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n {$IFDEF USE_DXGETTEXT}\r\n TranslateComponent(Self);\r\n {$ENDIF USE_DXGETTEXT}\r\n EnumKeys;\r\nend;\r\n\r\nprocedure TJvVirtualKeySelectionFrame.EnumKeys;\r\ntype\r\n TKeyElem = record\r\n Name: PChar;\r\n Value: Word;\r\n end;\r\nconst\r\n VirtualKeys: array [0..100] of TKeyElem =\r\n (\r\n (Name: 'VK_LBUTTON'; Value: VK_LBUTTON),\r\n (Name: 'VK_RBUTTON'; Value: VK_RBUTTON),\r\n (Name: 'VK_CANCEL'; Value: VK_CANCEL),\r\n (Name: 'VK_MBUTTON'; Value: VK_MBUTTON),\r\n (Name: 'VK_BACK'; Value: VK_BACK),\r\n (Name: 'VK_TAB'; Value: VK_TAB),\r\n (Name: 'VK_CLEAR'; Value: VK_CLEAR),\r\n (Name: 'VK_RETURN'; Value: VK_RETURN),\r\n (Name: 'VK_SHIFT'; Value: VK_SHIFT),\r\n (Name: 'VK_CONTROL'; Value: VK_CONTROL),\r\n (Name: 'VK_MENU'; Value: VK_MENU),\r\n (Name: 'VK_PAUSE'; Value: VK_PAUSE),\r\n (Name: 'VK_CAPITAL'; Value: VK_CAPITAL),\r\n (Name: 'VK_KANA'; Value: VK_KANA),\r\n (Name: 'VK_HANGUL'; Value: VK_HANGUL),\r\n (Name: 'VK_JUNJA'; Value: VK_JUNJA),\r\n (Name: 'VK_FINAL'; Value: VK_FINAL),\r\n (Name: 'VK_HANJA'; Value: VK_HANJA),\r\n (Name: 'VK_KANJI'; Value: VK_KANJI),\r\n (Name: 'VK_CONVERT'; Value: VK_CONVERT),\r\n (Name: 'VK_NONCONVERT'; Value: VK_NONCONVERT),\r\n (Name: 'VK_ACCEPT'; Value: VK_ACCEPT),\r\n (Name: 'VK_MODECHANGE'; Value: VK_MODECHANGE),\r\n (Name: 'VK_ESCAPE'; Value: VK_ESCAPE),\r\n (Name: 'VK_SPACE'; Value: VK_SPACE),\r\n (Name: 'VK_PRIOR'; Value: VK_PRIOR),\r\n (Name: 'VK_NEXT'; Value: VK_NEXT),\r\n (Name: 'VK_END'; Value: VK_END),\r\n (Name: 'VK_HOME'; Value: VK_HOME),\r\n (Name: 'VK_LEFT'; Value: VK_LEFT),\r\n (Name: 'VK_UP'; Value: VK_UP),\r\n (Name: 'VK_RIGHT'; Value: VK_RIGHT),\r\n (Name: 'VK_DOWN'; Value: VK_DOWN),\r\n (Name: 'VK_SELECT'; Value: VK_SELECT),\r\n (Name: 'VK_PRINT'; Value: VK_PRINT),\r\n (Name: 'VK_EXECUTE'; Value: VK_EXECUTE),\r\n (Name: 'VK_SNAPSHOT'; Value: VK_SNAPSHOT),\r\n (Name: 'VK_INSERT'; Value: VK_INSERT),\r\n (Name: 'VK_DELETE'; Value: VK_DELETE),\r\n (Name: 'VK_HELP'; Value: VK_HELP),\r\n (Name: 'VK_LWIN'; Value: VK_LWIN),\r\n (Name: 'VK_RWIN'; Value: VK_RWIN),\r\n (Name: 'VK_APPS'; Value: VK_APPS),\r\n (Name: 'VK_NUMPAD0'; Value: VK_NUMPAD0),\r\n (Name: 'VK_NUMPAD1'; Value: VK_NUMPAD1),\r\n (Name: 'VK_NUMPAD2'; Value: VK_NUMPAD2),\r\n (Name: 'VK_NUMPAD3'; Value: VK_NUMPAD3),\r\n (Name: 'VK_NUMPAD4'; Value: VK_NUMPAD4),\r\n (Name: 'VK_NUMPAD5'; Value: VK_NUMPAD5),\r\n (Name: 'VK_NUMPAD6'; Value: VK_NUMPAD6),\r\n (Name: 'VK_NUMPAD7'; Value: VK_NUMPAD7),\r\n (Name: 'VK_NUMPAD8'; Value: VK_NUMPAD8),\r\n (Name: 'VK_NUMPAD9'; Value: VK_NUMPAD9),\r\n (Name: 'VK_MULTIPLY'; Value: VK_MULTIPLY),\r\n (Name: 'VK_ADD'; Value: VK_ADD),\r\n (Name: 'VK_SEPARATOR'; Value: VK_SEPARATOR),\r\n (Name: 'VK_SUBTRACT'; Value: VK_SUBTRACT),\r\n (Name: 'VK_DECIMAL'; Value: VK_DECIMAL),\r\n (Name: 'VK_DIVIDE'; Value: VK_DIVIDE),\r\n (Name: 'VK_F1'; Value: VK_F1),\r\n (Name: 'VK_F2'; Value: VK_F2),\r\n (Name: 'VK_F3'; Value: VK_F3),\r\n (Name: 'VK_F4'; Value: VK_F4),\r\n (Name: 'VK_F5'; Value: VK_F5),\r\n (Name: 'VK_F6'; Value: VK_F6),\r\n (Name: 'VK_F7'; Value: VK_F7),\r\n (Name: 'VK_F8'; Value: VK_F8),\r\n (Name: 'VK_F9'; Value: VK_F9),\r\n (Name: 'VK_F10'; Value: VK_F10),\r\n (Name: 'VK_F11'; Value: VK_F11),\r\n (Name: 'VK_F12'; Value: VK_F12),\r\n (Name: 'VK_F13'; Value: VK_F13),\r\n (Name: 'VK_F14'; Value: VK_F14),\r\n (Name: 'VK_F15'; Value: VK_F15),\r\n (Name: 'VK_F16'; Value: VK_F16),\r\n (Name: 'VK_F17'; Value: VK_F17),\r\n (Name: 'VK_F18'; Value: VK_F18),\r\n (Name: 'VK_F19'; Value: VK_F19),\r\n (Name: 'VK_F20'; Value: VK_F20),\r\n (Name: 'VK_F21'; Value: VK_F21),\r\n (Name: 'VK_F22'; Value: VK_F22),\r\n (Name: 'VK_F23'; Value: VK_F23),\r\n (Name: 'VK_F24'; Value: VK_F24),\r\n (Name: 'VK_NUMLOCK'; Value: VK_NUMLOCK),\r\n (Name: 'VK_SCROLL'; Value: VK_SCROLL),\r\n (Name: 'VK_LSHIFT'; Value: VK_LSHIFT),\r\n (Name: 'VK_RSHIFT'; Value: VK_RSHIFT),\r\n (Name: 'VK_LCONTROL'; Value: VK_LCONTROL),\r\n (Name: 'VK_RCONTROL'; Value: VK_RCONTROL),\r\n (Name: 'VK_LMENU'; Value: VK_LMENU),\r\n (Name: 'VK_RMENU'; Value: VK_RMENU),\r\n (Name: 'VK_PROCESSKEY'; Value: VK_PROCESSKEY),\r\n (Name: 'VK_ATTN'; Value: VK_ATTN),\r\n (Name: 'VK_CRSEL'; Value: VK_CRSEL),\r\n (Name: 'VK_EXSEL'; Value: VK_EXSEL),\r\n (Name: 'VK_EREOF'; Value: VK_EREOF),\r\n (Name: 'VK_PLAY'; Value: VK_PLAY),\r\n (Name: 'VK_ZOOM'; Value: VK_ZOOM),\r\n (Name: 'VK_NONAME'; Value: VK_NONAME),\r\n (Name: 'VK_PA1'; Value: VK_PA1),\r\n (Name: 'VK_OEM_CLEAR'; Value: VK_OEM_CLEAR)\r\n );\r\nvar\r\n I: Integer;\r\nbegin\r\n with cmbVirtualKey.Items do\r\n begin\r\n // add the easy ones\r\n for I := Ord('0') to Ord('9') do\r\n AddObject('VK_' + Chr(I), TObject(I));\r\n for I := Ord('A') to Ord('Z') do\r\n AddObject('VK_' + Chr(I), TObject(I));\r\n\r\n // then add the others...\r\n for I := Low(VirtualKeys) to High(VirtualKeys) do\r\n AddObject(VirtualKeys[I].Name, TObject(VirtualKeys[I].Value));\r\n end;\r\nend;\r\n\r\nfunction TJvVirtualKeySelectionFrame.GetCombinedKeyCode: Word;\r\nbegin\r\n Result := GetKeyCode;\r\n if chkShift.Checked then\r\n Result := Result or $4000;\r\n if chkCtrl.Checked then\r\n Result := Result or $8000;\r\nend;\r\n\r\nfunction TJvVirtualKeySelectionFrame.GetKeyCode: Word;\r\nbegin\r\n if cmbVirtualKey.ItemIndex = -1 then\r\n begin\r\n // Signal an error, but not sure how...\r\n Application.MessageBox(PChar(RsNoValidKeyCode), PChar(RsInvalidKeyCode), MB_ICONERROR);\r\n // in any case, return 0\r\n Result := 0;\r\n end\r\n else\r\n Result := Word(cmbVirtualKey.Items.Objects[cmbVirtualKey.ItemIndex]);\r\nend;\r\n\r\nfunction TJvVirtualKeySelectionFrame.GetShiftState: TShiftState;\r\nbegin\r\n Result := [];\r\n if chkShift.Checked then\r\n Result := Result + [ssShift];\r\n if chkCtrl.Checked then\r\n Result := Result + [ssCtrl];\r\nend;\r\n\r\nprocedure TJvVirtualKeySelectionFrame.SetCombinedKeyCode(const Value: Word);\r\nbegin\r\n chkShift.Checked := (Value and $4000) <> 0;\r\n chkCtrl.Checked := (Value and $8000) <> 0;\r\n cmbVirtualKey.ItemIndex := cmbVirtualKey.Items.IndexOfObject(TObject(Value and $FF));\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend." }, { "path": "External/Jedi/Jvcl/run/JvWaitingGradient.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvWaitingGradient.PAS, released on 2001-02-28.\r\n\r\nThe Initial Developer of the Original Code is Sbastien Buysse [sbuysse att buypin dott com]\r\nPortions created by Sbastien Buysse are Copyright (C) 2001 Sbastien Buysse.\r\nAll Rights Reserved.\r\n\r\nContributor(s): Michael Beck [mbeck att bigfoot dott com].\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvWaitingGradient.pas 13104 2011-09-07 06:50:43Z obones $\r\n\r\nunit JvWaitingGradient;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n SysUtils, Classes,\r\n Windows, Graphics, Controls,\r\n JvImageDrawThread, JvComponent;\r\n\r\ntype\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvWaitingGradient = class(TJvGraphicControl)\r\n private\r\n FFromLeftToRight: Boolean; { Indicates direction }\r\n FBitmap: TBitmap;\r\n FLeftOffset: Integer;\r\n FGradientWidth: Integer;\r\n FStartColor: TColor;\r\n FEndColor: TColor;\r\n FSourceRect: TRect;\r\n FDestRect: TRect;\r\n FScroll: TJvImageDrawThread;\r\n FAlwaysRestart: Boolean;\r\n procedure Deplace(Sender: TObject);\r\n procedure UpdateBitmap;\r\n function GetActive: Boolean;\r\n function GetInterval: Cardinal;\r\n procedure SetGradientWidth(const Value: Integer);\r\n procedure SetEndColor(const Value: TColor);\r\n procedure SetStartColor(const Value: TColor);\r\n procedure SetInterval(const Value: Cardinal);\r\n procedure SetActive(const Value: Boolean);\r\n protected\r\n procedure Paint; override;\r\n procedure Resize; override;\r\n procedure Loaded; override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n procedure Restart;\r\n published\r\n // (rom) renamed Active\r\n property Active: Boolean read GetActive write SetActive default False;\r\n property Align;\r\n property Anchors;\r\n property Constraints;\r\n property Color;\r\n property Cursor;\r\n property DragCursor;\r\n property DragKind;\r\n property OnEndDock;\r\n property OnStartDock;\r\n property DragMode;\r\n property GradientWidth: Integer read FGradientWidth write SetGradientWidth;\r\n property Enabled;\r\n property EndColor: TColor read FEndColor write SetEndColor default clBlack;\r\n property Height default 10;\r\n\r\n property Interval: Cardinal read GetInterval write SetInterval default 50;\r\n property ParentColor;\r\n property ParentShowHint;\r\n property PopupMenu;\r\n property ShowHint;\r\n property AlwaysRestart: Boolean read FAlwaysRestart write FAlwaysRestart default False;\r\n property StartColor: TColor read FStartColor write SetStartColor default clBtnFace;\r\n property Visible;\r\n property Width default 100;\r\n\r\n property OnClick;\r\n property OnDragDrop;\r\n property OnDragOver;\r\n property OnEndDrag;\r\n property OnMouseDown;\r\n property OnMouseUp;\r\n property OnMouseMove;\r\n property OnStartDrag;\r\n property OnMouseEnter;\r\n property OnMouseLeave;\r\n\r\n property OnDblClick;\r\n property OnContextPopup;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvWaitingGradient.pas $';\r\n Revision: '$Revision: 13104 $';\r\n Date: '$Date: 2011-09-07 08:50:43 +0200 (mer. 07 sept. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n JvTypes;\r\n\r\nconstructor TJvWaitingGradient.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n {(rb) csOpaque included }\r\n ControlStyle := ControlStyle + [csOpaque];\r\n\r\n FBitmap := TBitmap.Create;\r\n\r\n FStartColor := clBtnFace;\r\n FEndColor := clBlack;\r\n FGradientWidth := 50;\r\n FLeftOffset := -FGradientWidth;\r\n FSourceRect := Rect(0, 0, FGradientWidth, Height);\r\n FDestRect := Rect(0, 0, FGradientWidth, Height);\r\n FFromLeftToRight := True;\r\n\r\n FScroll := TJvImageDrawThread.Create(True);\r\n FScroll.FreeOnTerminate := False;\r\n FScroll.Delay := 50;\r\n FScroll.OnDraw := Deplace;\r\n // (p3) don't set color: it will set ParentColor to False\r\n// Color := clBtnFace;\r\n\r\n { (rb) Set the size properties last; will trigger Resize }\r\n // (rom) also always set the default values\r\n Height := 10;\r\n Width := 100;\r\nend;\r\n\r\ndestructor TJvWaitingGradient.Destroy;\r\nbegin\r\n FScroll.OnDraw := nil;\r\n FScroll.Terminate;\r\n // FScroll.WaitFor;\r\n FreeAndNil(FScroll);\r\n\r\n FBitmap.Free;\r\n FBitmap := nil;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvWaitingGradient.Loaded;\r\nbegin\r\n inherited Loaded;\r\n UpdateBitmap;\r\n if Active then\r\n FScroll.Paused := False;\r\nend;\r\n\r\nprocedure TJvWaitingGradient.UpdateBitmap;\r\nvar\r\n I: Integer;\r\n J: Real;\r\n Deltas: array [0..2] of Single; //R,G,B\r\n Rect: TRect;\r\n Steps: Integer;\r\n LStartColor, LEndColor: Longint;\r\nbegin\r\n if not Assigned(FBitmap) then\r\n Exit;\r\n if csLoading in ComponentState then\r\n Exit;\r\n\r\n if FFromLeftToRight then\r\n begin\r\n LStartColor := ColorToRGB(FStartColor);\r\n LEndColor := ColorToRGB(FEndColor);\r\n end\r\n else\r\n begin\r\n LStartColor := ColorToRGB(FEndColor);\r\n LEndColor := ColorToRGB(FStartColor);\r\n end;\r\n\r\n FBitmap.Width := FGradientWidth;\r\n FBitmap.Height := Height;\r\n\r\n Steps := FGradientWidth;\r\n if Steps > Width then\r\n Steps := Width;\r\n if Steps <= 0 then\r\n Exit;\r\n\r\n Deltas[0] := (GetRValue(LEndColor) - GetRValue(LStartColor)) / Steps;\r\n Deltas[1] := (GetGValue(LEndColor) - GetGValue(LStartColor)) / Steps;\r\n Deltas[2] := (GetBValue(LEndColor) - GetBValue(LStartColor)) / Steps;\r\n FBitmap.Canvas.Brush.Style := bsSolid;\r\n J := FGradientWidth / Steps;\r\n for I := 0 to Steps do\r\n begin\r\n Rect.Top := 0;\r\n Rect.Bottom := Height;\r\n Rect.Left := Round(I * J);\r\n Rect.Right := Round((I + 1) * J);\r\n FBitmap.Canvas.Brush.Color :=\r\n RGB(\r\n Round(GetRValue(LStartColor) + I * Deltas[0]),\r\n Round(GetGValue(LStartColor) + I * Deltas[1]),\r\n Round(GetBValue(LStartColor) + I * Deltas[2]));\r\n FBitmap.Canvas.FillRect(Rect);\r\n end;\r\nend;\r\n\r\nprocedure TJvWaitingGradient.Deplace(Sender: TObject);\r\nbegin\r\n // Must exit because we are \"Synchronized\" and our parent is already\r\n // partly destroyed. If we did not exit, we would get an AV.\r\n if csDestroying in ComponentState then\r\n Exit;\r\n\r\n if FFromLeftToRight then\r\n begin\r\n if FLeftOffset + FGradientWidth >= Width then\r\n begin\r\n FFromLeftToRight := False;\r\n UpdateBitmap;\r\n FLeftOffset := Width;\r\n end\r\n else\r\n FLeftOffset := FLeftOffset + 2;\r\n end\r\n else\r\n begin\r\n if FLeftOffset <= 0 then\r\n begin\r\n FFromLeftToRight := True;\r\n UpdateBitmap;\r\n FLeftOffset := -FGradientWidth;\r\n end\r\n else\r\n FLeftOffset := FLeftOffset - 2;\r\n end;\r\n FDestRect.Left := FLeftOffset;\r\n FDestRect.Right := FLeftOffset + FGradientWidth;\r\n\r\n Repaint;\r\nend;\r\n\r\nprocedure TJvWaitingGradient.Paint;\r\nbegin\r\n Canvas.Brush.Style := bsSolid;\r\n Canvas.Brush.Color := Color;\r\n Canvas.FillRect(Rect(0, 0, FLeftOffset, Height));\r\n if not Assigned(FBitmap) then\r\n Exit;\r\n Canvas.FillRect(Rect(FLeftOffset + FBitmap.Width, 0, Width, Height));\r\n Canvas.CopyRect(FDestRect, FBitmap.Canvas, FSourceRect);\r\nend;\r\n\r\nprocedure TJvWaitingGradient.Resize;\r\nbegin\r\n inherited Resize;\r\n FSourceRect := Rect(0, 0, FGradientWidth, Height);\r\n FDestRect := Rect(0, 0, FGradientWidth, Height);\r\n UpdateBitmap;\r\nend;\r\n\r\nfunction TJvWaitingGradient.GetActive: Boolean;\r\nbegin\r\n Result := not FScroll.Paused;\r\nend;\r\n\r\nprocedure TJvWaitingGradient.SetActive(const Value: Boolean);\r\nbegin\r\n// if csLoading in ComponentState then\r\n// Exit;\r\n if FScroll = nil then\r\n Exit;\r\n if Value then\r\n begin\r\n FScroll.Paused := False;\r\n if AlwaysRestart then\r\n Restart;\r\n end\r\n else\r\n begin\r\n FScroll.Paused := True;\r\n end;\r\nend;\r\n\r\nprocedure TJvWaitingGradient.SetEndColor(const Value: TColor);\r\nbegin\r\n if FEndColor <> Value then\r\n begin\r\n FEndColor := Value;\r\n UpdateBitmap;\r\n end;\r\nend;\r\n\r\nfunction TJvWaitingGradient.GetInterval: Cardinal;\r\nbegin\r\n Result := FScroll.Delay;\r\nend;\r\n\r\nprocedure TJvWaitingGradient.SetInterval(const Value: Cardinal);\r\nbegin\r\n FScroll.Delay := Value;\r\nend;\r\n\r\nprocedure TJvWaitingGradient.SetStartColor(const Value: TColor);\r\nbegin\r\n if Value <> FStartColor then\r\n begin\r\n FStartColor := Value;\r\n UpdateBitmap;\r\n end;\r\nend;\r\n\r\nprocedure TJvWaitingGradient.SetGradientWidth(const Value: Integer);\r\nbegin\r\n if Value > 0 then\r\n begin\r\n FGradientWidth := Value;\r\n FLeftOffset := -FGradientWidth;\r\n FSourceRect := Rect(0, 0, FGradientWidth, Height);\r\n FDestRect := Rect(0, 0, FGradientWidth, Height);\r\n UpdateBitmap;\r\n end;\r\nend;\r\n\r\nprocedure TJvWaitingGradient.Restart;\r\nbegin\r\n FLeftOffset := -FGradientWidth;\r\n UpdateBitmap;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvWaitingProgress.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvWaitingProgress.PAS, released on 2001-02-28.\r\n\r\nThe Initial Developer of the Original Code is Sbastien Buysse [sbuysse att buypin dott com]\r\nPortions created by Sbastien Buysse are Copyright (C) 2001 Sbastien Buysse.\r\nAll Rights Reserved.\r\n\r\nContributor(s): Michael Beck [mbeck att bigfoot dott com].\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvWaitingProgress.pas 13104 2011-09-07 06:50:43Z obones $\r\n\r\nunit JvWaitingProgress;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n SysUtils, Classes,\r\n Messages, Graphics, Controls, Forms,\r\n JvSpecialProgress, JvImageDrawThread, JvComponent;\r\n\r\nconst\r\n WM_DELAYED_INTERNAL_ACTIVATE = WM_APP + 245;\r\n WM_DELAYED_DO_ENDED = WM_APP + 246;\r\n\r\ntype\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvWaitingProgress = class(TJvWinControl)\r\n private\r\n FActive: Boolean;\r\n FRefreshInterval: Cardinal;\r\n FLength: Cardinal;\r\n FOnEnded: TNotifyEvent;\r\n FWait: TJvImageDrawThread;\r\n FProgress: TJvSpecialProgress;\r\n FInOnScroll: Boolean;\r\n\r\n function GetProgressColor: TColor;\r\n procedure InternalActivate;\r\n procedure SetActive(const Value: Boolean);\r\n procedure SetLength(const Value: Cardinal);\r\n procedure SetRefreshInterval(const Value: Cardinal);\r\n procedure SetProgressColor(const Value: TColor);\r\n procedure OnScroll(Sender: TObject);\r\n procedure DoEnded;\r\n //function GetBColor: TColor;\r\n //procedure SetBColor(const Value: TColor);\r\n protected\r\n procedure BoundsChanged; override;\r\n procedure ColorChanged; override;\r\n procedure Loaded; override;\r\n\r\n procedure WmDelayedInternalActivate(var Msg: TMessage); message WM_DELAYED_INTERNAL_ACTIVATE;\r\n procedure WmDelayedDoEnded(var Msg: TMessage); message WM_DELAYED_DO_ENDED;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n published\r\n property Active: Boolean read FActive write SetActive default False;\r\n property Length: Cardinal read FLength write SetLength default 30000;\r\n property RefreshInterval: Cardinal read FRefreshInterval write SetRefreshInterval default 500;\r\n property ProgressColor: TColor read GetProgressColor write SetProgressColor default clBlack;\r\n {(rb) no need to override Color property }\r\n //property Color: TColor read GetBColor write SetBColor;\r\n property Color;\r\n property ParentColor;\r\n property Height default 10;\r\n property Width default 100;\r\n property OnEnded: TNotifyEvent read FOnEnded write FOnEnded;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvWaitingProgress.pas $';\r\n Revision: '$Revision: 13104 $';\r\n Date: '$Date: 2011-09-07 08:50:43 +0200 (mer. 07 sept. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n Windows;\r\n\r\nconstructor TJvWaitingProgress.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FActive := False;\r\n FLength := 30000;\r\n FRefreshInterval := 500;\r\n // (rom) always set default values also\r\n Height := 10;\r\n Width := 100;\r\n\r\n FWait := TJvImageDrawThread.Create(True);\r\n FWait.FreeOnTerminate := False;\r\n FWait.Delay := FRefreshInterval;\r\n FWait.OnDraw := OnScroll;\r\n\r\n FProgress := TJvSpecialProgress.Create(Self);\r\n FProgress.Parent := Self;\r\n FProgress.Maximum := FLength;\r\n FProgress.Position := 0;\r\n FProgress.StartColor := clBlack;\r\n FProgress.EndColor := clBlack;\r\n FProgress.Solid := True;\r\n\r\n FProgress.Left := 0;\r\n FProgress.Top := 0;\r\n FProgress.Width := Width;\r\n FProgress.Height := Height;\r\n\r\n //inherited Color := FProgress.Color;\r\nend;\r\n\r\ndestructor TJvWaitingProgress.Destroy;\r\nbegin\r\n FWait.OnDraw := nil;\r\n FWait.Terminate;\r\n // FWait.WaitFor;\r\n FreeAndNil(FWait);\r\n FProgress.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvWaitingProgress.DoEnded;\r\nbegin\r\n if Assigned(FOnEnded) then\r\n FOnEnded(Self);\r\nend;\r\n\r\nprocedure TJvWaitingProgress.Loaded;\r\nbegin\r\n inherited Loaded;\r\n if FActive then\r\n InternalActivate;\r\nend;\r\n\r\n{function TJvWaitingProgress.GetBColor: TColor;\r\nbegin\r\n Result := FProgress.Color;\r\nend;}\r\n\r\nfunction TJvWaitingProgress.GetProgressColor: TColor;\r\nbegin\r\n Result := FProgress.StartColor;\r\nend;\r\n\r\nprocedure TJvWaitingProgress.OnScroll(Sender: TObject);\r\nbegin\r\n // Must exit because we are \"Synchronized\" and our parent is already\r\n // partly destroyed. If we did not exit, we would get an AV.\r\n if csDestroying in ComponentState then\r\n Exit;\r\n\r\n //Step\r\n FInOnScroll := True;\r\n try\r\n if Integer(FProgress.Position) + Integer(FRefreshInterval) > Integer(FLength) then\r\n begin\r\n FProgress.Position := FLength;\r\n SetActive(False);\r\n PostMessage(Handle, WM_DELAYED_DO_ENDED, 0, 0);\r\n end\r\n else\r\n FProgress.Position := FProgress.Position + Integer(FRefreshInterval);\r\n finally\r\n FInOnScroll := False;\r\n end;\r\nend;\r\n\r\nprocedure TJvWaitingProgress.InternalActivate;\r\nbegin\r\n if FActive then\r\n begin\r\n FProgress.Position := 0;\r\n FWait.Paused := False;\r\n end\r\n else\r\n FWait.Paused := True;\r\nend;\r\n\r\nprocedure TJvWaitingProgress.SetActive(const Value: Boolean);\r\nbegin\r\n if FActive <> Value then\r\n begin\r\n FActive := Value;\r\n if not (csLoading in ComponentState) then\r\n if FInOnScroll then // OnScroll is \"Synchronized\", we must thus finish it before locking the thread\r\n PostMessage(Handle, WM_DELAYED_INTERNAL_ACTIVATE, 0, 0)\r\n else\r\n InternalActivate;\r\n end;\r\nend;\r\n\r\n{procedure TJvWaitingProgress.SetBColor(const Value: TColor);\r\nbegin\r\n if FProgress.Color <> Value then\r\n begin\r\n FProgress.Color := Value;\r\n inherited Color := Value;\r\n end;\r\nend;}\r\n\r\nprocedure TJvWaitingProgress.SetProgressColor(const Value: TColor);\r\nbegin\r\n FProgress.StartColor := Value;\r\n FProgress.EndColor := Value;\r\nend;\r\n\r\nprocedure TJvWaitingProgress.SetLength(const Value: Cardinal);\r\nbegin\r\n FLength := Value;\r\n FProgress.Position := 0;\r\n FProgress.Maximum := FLength;\r\nend;\r\n\r\nprocedure TJvWaitingProgress.SetRefreshInterval(const Value: Cardinal);\r\nbegin\r\n FRefreshInterval := Value;\r\n FWait.Delay := FRefreshInterval;\r\nend;\r\n\r\nprocedure TJvWaitingProgress.WmDelayedDoEnded(var Msg: TMessage);\r\nbegin\r\n DoEnded;\r\nend;\r\n\r\nprocedure TJvWaitingProgress.WmDelayedInternalActivate(var Msg: TMessage);\r\nbegin\r\n InternalActivate;\r\nend;\r\n\r\nprocedure TJvWaitingProgress.BoundsChanged;\r\nbegin\r\n inherited BoundsChanged;\r\n FProgress.Width := Width;\r\n FProgress.Height := Height;\r\nend;\r\n\r\nprocedure TJvWaitingProgress.ColorChanged;\r\nbegin\r\n inherited ColorChanged;\r\n FProgress.Color := Color;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvWallpaperEditForm.dfm", "content": "object FoWallpaperChooser: TFoWallpaperChooser\r\n Left = 401\r\n Top = 250\r\n ClientWidth = 392\r\n ClientHeight = 272\r\n BorderIcons = [biSystemMenu]\r\n Caption = 'Wallpaper Chooser'\r\n Color = clBtnFace\r\n Font.Charset = DEFAULT_CHARSET\r\n Font.Color = clWindowText\r\n Font.Height = -11\r\n Font.Name = 'MS Sans Serif'\r\n Font.Style = []\r\n OldCreateOrder = False\r\n Position = poScreenCenter\r\n OnCreate = FormCreate\r\n OnDestroy = FormDestroy\r\n PixelsPerInch = 96\r\n TextHeight = 13\r\n object Button1: TButton\r\n Left = 6\r\n Top = 245\r\n Width = 75\r\n Height = 25\r\n Anchors = [akLeft, akBottom]\r\n Caption = '&OK'\r\n ModalResult = 1\r\n TabOrder = 2\r\n end\r\n object Button2: TButton\r\n Left = 84\r\n Top = 245\r\n Width = 75\r\n Height = 25\r\n Anchors = [akLeft, akBottom]\r\n Caption = '&Cancel'\r\n ModalResult = 2\r\n TabOrder = 3\r\n end\r\n object Button3: TButton\r\n Left = 309\r\n Top = 245\r\n Width = 75\r\n Height = 25\r\n Anchors = [akRight, akBottom]\r\n Caption = '&Clear'\r\n TabOrder = 4\r\n OnClick = Button3Click\r\n end\r\n object GroupBox1: TGroupBox\r\n Left = 6\r\n Top = 6\r\n Width = 382\r\n Height = 39\r\n Anchors = [akLeft, akTop, akRight]\r\n TabOrder = 0\r\n object Label1: TLabel\r\n Left = 8\r\n Top = 16\r\n Width = 42\r\n Height = 13\r\n Caption = 'Directory'\r\n end\r\n object DirectoryBox1: TJvDirectoryEdit\r\n Left = 58\r\n Top = 12\r\n Width = 318\r\n Height = 21\r\n OnAfterDialog = DirectoryBox1AfterDialog\r\n DialogKind = dkWin32\r\n ButtonFlat = False\r\n Anchors = [akLeft, akTop, akRight]\r\n TabOrder = 0\r\n end\r\n end\r\n object ScrollBox1: TScrollBox\r\n Left = 6\r\n Top = 48\r\n Width = 382\r\n Height = 186\r\n Anchors = [akLeft, akTop, akRight, akBottom]\r\n TabOrder = 1\r\n end\r\n object SearchFiles1: TJvSearchFiles\r\n DirOption = doExcludeSubDirs\r\n FileParams.SearchTypes = [stFileMask]\r\n FileParams.FileMasks.Strings = (\r\n '*.bmp')\r\n OnFindFile = SearchFile1Found\r\n Left = 112\r\n Top = 64\r\n end\r\nend\r\n" }, { "path": "External/Jedi/Jvcl/run/JvWallpaperEditForm.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvWallpaperEditForm.PAS, released on 2001-02-28.\r\n\r\nThe Initial Developer of the Original Code is Sbastien Buysse [sbuysse att buypin dott com]\r\nPortions created by Sbastien Buysse are Copyright (C) 2001 Sbastien Buysse.\r\nAll Rights Reserved.\r\n\r\nContributor(s): Michael Beck [mbeck att bigfoot dott com].\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvWallpaperEditForm.pas 12461 2009-08-14 17:21:33Z obones $\r\n\r\nunit JvWallpaperEditForm;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n SysUtils, Classes, Graphics, Controls, Forms, Buttons, StdCtrls, Mask,\r\n JvToolEdit, JvComponent, JvSearchFiles, JvButton, JvExMask;\r\n\r\ntype\r\n TFoWallpaperChooser = class(TJvForm)\r\n GroupBox1: TGroupBox;\r\n Button1: TButton;\r\n Button2: TButton;\r\n Button3: TButton;\r\n DirectoryBox1: TJvDirectoryEdit;\r\n Label1: TLabel;\r\n ScrollBox1: TScrollBox;\r\n SearchFiles1: TJvSearchFiles;\r\n procedure FormCreate(Sender: TObject);\r\n procedure FormDestroy(Sender: TObject);\r\n procedure SearchFile1Found(Sender: TObject; Path: string);\r\n procedure Button3Click(Sender: TObject);\r\n procedure DirectoryBox1AfterDialog(Sender: TObject; var Name: string;\r\n var Action: Boolean);\r\n private\r\n FList: TList;\r\n FLastBtn: TSpeedButton;\r\n FMaxHeight: Integer;\r\n procedure GlyphClick(Sender: TObject);\r\n public\r\n Image: TPicture;\r\n OnGlyph: TNotifyEvent;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvWallpaperEditForm.pas $';\r\n Revision: '$Revision: 12461 $';\r\n Date: '$Date: 2009-08-14 19:21:33 +0200 (ven. 14 août 2009) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\n\r\n{$R *.dfm}\r\n\r\nprocedure TFoWallpaperChooser.FormCreate(Sender: TObject);\r\nbegin\r\n Image := TPicture.Create;\r\n FList := TList.Create;\r\nend;\r\n\r\nprocedure TFoWallpaperChooser.FormDestroy(Sender: TObject);\r\nbegin\r\n Image.Free;\r\n FList.Free;\r\nend;\r\n\r\nprocedure TFoWallpaperChooser.SearchFile1Found(Sender: TObject; Path: string);\r\nvar\r\n Btn: TSpeedButton;\r\nbegin\r\n Btn := TSpeedButton.Create(ScrollBox1);\r\n Btn.Parent := ScrollBox1;\r\n Btn.Flat := True;\r\n Btn.ShowHint := True;\r\n Btn.Hint := ChangeFileExt(ExtractFileName(Path), '');\r\n try\r\n Btn.Glyph.LoadFromFile(Path);\r\n Btn.Width := Btn.Glyph.Width + 2;\r\n Btn.Height := Btn.Glyph.Height + 2;\r\n except\r\n Btn.Free;\r\n Exit;\r\n end;\r\n if FLastBtn = nil then\r\n begin\r\n Btn.Left := 0;\r\n Btn.Top := 0;\r\n FMaxHeight := 0;\r\n end\r\n else\r\n begin\r\n if FLastBtn.Left + FLastBtn.Width + Btn.Width + 20 > ScrollBox1.Width then\r\n begin\r\n Btn.Left := 0;\r\n Btn.Top := FLastBtn.Top + FMaxHeight;\r\n FMaxHeight := 0;\r\n end\r\n else\r\n begin\r\n Btn.Left := FLastBtn.Left + FLastBtn.Width;\r\n Btn.Top := FLastBtn.Top;\r\n end;\r\n end;\r\n FLastBtn := Btn;\r\n Btn.OnClick := GlyphClick;\r\n FList.Add(Btn);\r\n if Btn.Height > FMaxHeight then\r\n FMaxHeight := Btn.Height;\r\nend;\r\n\r\nprocedure TFoWallpaperChooser.GlyphClick(Sender: TObject);\r\nbegin\r\n Image.Bitmap.Assign((Sender as TSpeedButton).Glyph);\r\n if Assigned(OnGlyph) then\r\n OnGlyph(Image.Bitmap);\r\nend;\r\n\r\nprocedure TFoWallpaperChooser.Button3Click(Sender: TObject);\r\nbegin\r\n Image.Assign(nil);\r\n if Assigned(OnGlyph) then\r\n OnGlyph(nil);\r\nend;\r\n\r\nprocedure TFoWallpaperChooser.DirectoryBox1AfterDialog(Sender: TObject;\r\n var Name: string; var Action: Boolean);\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := 0 to FList.Count - 1 do\r\n TSpeedButton(FList.Items[I]).Free;\r\n FList.Clear;\r\n FLastBtn := nil;\r\n { TODO : Test if this works }\r\n SearchFiles1.RootDirectory := Name;\r\n SearchFiles1.Search;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend." }, { "path": "External/Jedi/Jvcl/run/JvWavePlayer.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvWavePlayer.PAS, released on 2001-02-28.\r\n\r\nThe Initial Developer of the Original Code is Sbastien Buysse [sbuysse att buypin dott com]\r\nPortions created by Sbastien Buysse are Copyright (C) 2001 Sbastien Buysse.\r\nAll Rights Reserved.\r\n\r\nContributor(s): Michael Beck [mbeck att bigfoot dott com].\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvWavePlayer.pas 13104 2011-09-07 06:50:43Z obones $\r\n\r\nunit JvWavePlayer;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, SysUtils, Classes, MMSystem,\r\n JvTypes, JvComponentBase;\r\n\r\ntype\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvWavePlayer = class(TJvComponent)\r\n private\r\n FAsynchronous: Boolean;\r\n FLoop: Boolean;\r\n FFileName: TFileName;\r\n FWavePointer: Pointer;\r\n FSourceType: TJvWaveLocation;\r\n FBeforePlaying: TNotifyEvent;\r\n FAfterPlaying: TNotifyEvent;\r\n procedure SetAsynchronous(Value: Boolean);\r\n procedure SetLoop(Value: Boolean);\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n function Play: Boolean;\r\n procedure Stop;\r\n procedure Silence;\r\n property WavePointer: Pointer read FWavePointer write FWavePointer;\r\n published\r\n property Asynchronous: Boolean read FAsynchronous write SetAsynchronous default True;\r\n property Loop: Boolean read FLoop write SetLoop default False;\r\n property SourceType: TJvWaveLocation read FSourceType write FSourceType default frFile;\r\n property FileName: TFileName read FFileName write FFileName;\r\n property BeforePlaying: TNotifyEvent read FBeforePlaying write FBeforePlaying;\r\n property AfterPlaying: TNotifyEvent read FAfterPlaying write FAfterPlaying;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvWavePlayer.pas $';\r\n Revision: '$Revision: 13104 $';\r\n Date: '$Date: 2011-09-07 08:50:43 +0200 (mer. 07 sept. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\n\r\nconst\r\n CSourceTypes: array [TJvWaveLocation] of DWORD =\r\n (SND_FILENAME, SND_RESOURCE, SND_MEMORY);\r\n\r\nconstructor TJvWavePlayer.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FAsynchronous := True;\r\n Loop := False;\r\n FSourceType := frFile;\r\nend;\r\n\r\ndestructor TJvWavePlayer.Destroy;\r\nbegin\r\n Stop;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJvWavePlayer.Play: Boolean;\r\nconst\r\n CLoops: array [Boolean] of DWORD = (0, SND_LOOP);\r\n CAsynchronous: array [Boolean] of DWORD = (SND_SYNC, SND_ASYNC);\r\nvar\r\n Flags: DWORD;\r\nbegin\r\n Result := False;\r\n case SourceType of\r\n frRAM:\r\n if WavePointer = nil then\r\n Exit;\r\n frFile, frResource:\r\n if FileName = '' then\r\n Exit;\r\n else\r\n Exit;\r\n end;\r\n\r\n if Assigned(FBeforePlaying) then\r\n FBeforePlaying(Self);\r\n\r\n Flags := CSourceTypes[SourceType] or CLoops[Loop] or CAsynchronous[Asynchronous];\r\n\r\n if FSourceType = frRAM then\r\n Result := PlaySound(WavePointer, 0, Flags)\r\n else\r\n Result := PlaySound(PChar(FileName), 0, Flags);\r\n\r\n if Assigned(FAfterPlaying) and not (Loop or Asynchronous) then\r\n FAfterPlaying(Self);\r\nend;\r\n\r\nprocedure TJvWavePlayer.SetAsynchronous(Value: Boolean);\r\nbegin\r\n FAsynchronous := Value;\r\n if not FAsynchronous then\r\n FLoop := False;\r\nend;\r\n\r\nprocedure TJvWavePlayer.SetLoop(Value: Boolean);\r\nbegin\r\n if (FLoop <> Value) and Asynchronous then\r\n FLoop := Value;\r\nend;\r\n\r\nprocedure TJvWavePlayer.Stop;\r\nbegin\r\n PlaySound(nil, 0, CSourceTypes[FSourceType]);\r\n if Assigned(FAfterPlaying) and (Loop or Asynchronous) and\r\n not (csDestroying in ComponentState) then\r\n FAfterPlaying(Self);\r\nend;\r\n\r\nprocedure TJvWavePlayer.Silence;\r\nbegin\r\n // Immediately stops the WAV from playing and purges any remaining WAV audio from the queue.\r\n PlaySound(nil, 0, SND_PURGE);\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvWin32.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvWin32.pas, released on 2005-10-29.\r\n\r\nThe Initial Developer of the Original Code is:\r\nRobert Marquardt (robert_marquardt att gmx dott de)\r\nCopyright (c) 2005 Robert Marquardt\r\nAll Rights Reserved.\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvWin32.pas 12461 2009-08-14 17:21:33Z obones $\r\n\r\nunit JvWin32;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n CommCtrl, Windows;\r\n\r\nconst\r\n SC_DRAGMOVE = $F012;\r\n\r\n {$IFNDEF COMPILER7_UP}\r\n SPI_GETFLATMENU = $1022;\r\n {$EXTERNALSYM SPI_GETFLATMENU}\r\n {$ENDIF ~COMPILER7_UP}\r\n\r\n {$IFNDEF COMPILER7_UP}\r\n SM_XVIRTUALSCREEN = 76;\r\n {$EXTERNALSYM SM_XVIRTUALSCREEN}\r\n SM_YVIRTUALSCREEN = 77;\r\n {$EXTERNALSYM SM_YVIRTUALSCREEN}\r\n SM_CXVIRTUALSCREEN = 78;\r\n {$EXTERNALSYM SM_CXVIRTUALSCREEN}\r\n SM_CYVIRTUALSCREEN = 79;\r\n {$EXTERNALSYM SM_CYVIRTUALSCREEN}\r\n {$ENDIF !COMPILER7_UP}\r\n\r\n CS_DROPSHADOW = $00020000;\r\n {$IFDEF DELPHI11_UP}\r\n {$EXTERNALSYM CS_DROPSHADOW}\r\n {$ENDIF DELPHI11_UP}\r\n\r\n //==========================================================================\r\n {$IFDEF VCL}\r\n TVM_SETLINECOLOR = TV_FIRST + 40;\r\n {$EXTERNALSYM TVM_SETLINECOLOR}\r\n TVM_GETLINECOLOR = TV_FIRST + 41;\r\n {$EXTERNALSYM TVM_GETLINECOLOR}\r\n {$ENDIF VCL}\r\n\r\n //==========================================================================\r\n { Taken from WinNT.h }\r\n FILE_ATTRIBUTE_SPARSE_FILE = $200;\r\n {$EXTERNALSYM FILE_ATTRIBUTE_SPARSE_FILE}\r\n\r\n FILE_ATTRIBUTE_REPARSE_POINT = $400;\r\n {$EXTERNALSYM FILE_ATTRIBUTE_REPARSE_POINT}\r\n\r\n FILE_ATTRIBUTE_NOT_CONTENT_INDEXED = $2000;\r\n {$EXTERNALSYM FILE_ATTRIBUTE_NOT_CONTENT_INDEXED}\r\n\r\n FILE_ATTRIBUTE_ENCRYPTED = $4000;\r\n {$EXTERNALSYM FILE_ATTRIBUTE_ENCRYPTED}\r\n\r\n //==========================================================================\r\n FOF_NOCOPYSECURITYATTRIBS = $800;\r\n {$EXTERNALSYM FOF_NOCOPYSECURITYATTRIBS}\r\n FOF_NORECURSION = $1000;\r\n {$EXTERNALSYM FOF_NORECURSION}\r\n // IE 5 and up\r\n FOF_NO_CONNECTED_ELEMENTS = $2000;\r\n {$EXTERNALSYM FOF_NO_CONNECTED_ELEMENTS}\r\n // IE 5.01 and up\r\n FOF_NORECURSEREPARSE = $8000;\r\n {$EXTERNALSYM FOF_NORECURSEREPARSE}\r\n FOF_WANTNUKEWARNING = $4000;\r\n {$EXTERNALSYM FOF_WANTNUKEWARNING}\r\n\r\n //==========================================================================\r\n HSHELL_WINDOWCREATED = 1;\r\n {$EXTERNALSYM HSHELL_WINDOWCREATED}\r\n HSHELL_WINDOWDESTROYED = 2;\r\n {$EXTERNALSYM HSHELL_WINDOWDESTROYED}\r\n HSHELL_ACTIVATESHELLWINDOW = 3;\r\n {$EXTERNALSYM HSHELL_ACTIVATESHELLWINDOW}\r\n\r\n HSHELL_WINDOWACTIVATED = 4;\r\n {$EXTERNALSYM HSHELL_WINDOWACTIVATED}\r\n HSHELL_GETMINRECT = 5;\r\n {$EXTERNALSYM HSHELL_GETMINRECT}\r\n HSHELL_REDRAW = 6;\r\n {$EXTERNALSYM HSHELL_REDRAW}\r\n HSHELL_TASKMAN = 7;\r\n {$EXTERNALSYM HSHELL_TASKMAN}\r\n HSHELL_LANGUAGE = 8;\r\n {$EXTERNALSYM HSHELL_LANGUAGE}\r\n HSHELL_SYSMENU = 9;\r\n {$EXTERNALSYM HSHELL_SYSMENU}\r\n HSHELL_ENDTASK = 10;\r\n {$EXTERNALSYM HSHELL_ENDTASK}\r\n HSHELL_ACCESSIBILITYSTATE = 11;\r\n {$EXTERNALSYM HSHELL_ACCESSIBILITYSTATE}\r\n HSHELL_APPCOMMAND = 12;\r\n {$EXTERNALSYM HSHELL_APPCOMMAND}\r\n HSHELL_WINDOWREPLACED = 13;\r\n {$EXTERNALSYM HSHELL_WINDOWREPLACED}\r\n HSHELL_WINDOWREPLACING = 14;\r\n {$EXTERNALSYM HSHELL_WINDOWREPLACING}\r\n\r\n HSHELL_HIGHBIT = $8000;\r\n {$EXTERNALSYM HSHELL_HIGHBIT}\r\n HSHELL_FLASH = (HSHELL_REDRAW or HSHELL_HIGHBIT);\r\n {$EXTERNALSYM HSHELL_FLASH}\r\n HSHELL_RUDEAPPACTIVATED = (HSHELL_WINDOWACTIVATED or HSHELL_HIGHBIT);\r\n {$EXTERNALSYM HSHELL_RUDEAPPACTIVATED}\r\n\r\n (* wparam for HSHELL_ACCESSIBILITYSTATE *)\r\n ACCESS_STICKYKEYS = $0001;\r\n {$EXTERNALSYM ACCESS_STICKYKEYS}\r\n ACCESS_FILTERKEYS = $0002;\r\n {$EXTERNALSYM ACCESS_FILTERKEYS}\r\n ACCESS_MOUSEKEYS = $0003;\r\n {$EXTERNALSYM ACCESS_MOUSEKEYS}\r\n\r\n (* cmd for HSHELL_APPCOMMAND and WM_APPCOMMAND *)\r\n APPCOMMAND_BROWSER_BACKWARD = 1;\r\n {$EXTERNALSYM APPCOMMAND_BROWSER_BACKWARD}\r\n APPCOMMAND_BROWSER_FORWARD = 2;\r\n {$EXTERNALSYM APPCOMMAND_BROWSER_FORWARD}\r\n APPCOMMAND_BROWSER_REFRESH = 3;\r\n {$EXTERNALSYM APPCOMMAND_BROWSER_REFRESH}\r\n APPCOMMAND_BROWSER_STOP = 4;\r\n {$EXTERNALSYM APPCOMMAND_BROWSER_STOP}\r\n APPCOMMAND_BROWSER_SEARCH = 5;\r\n {$EXTERNALSYM APPCOMMAND_BROWSER_SEARCH}\r\n APPCOMMAND_BROWSER_FAVORITES = 6;\r\n {$EXTERNALSYM APPCOMMAND_BROWSER_FAVORITES}\r\n APPCOMMAND_BROWSER_HOME = 7;\r\n {$EXTERNALSYM APPCOMMAND_BROWSER_HOME}\r\n APPCOMMAND_VOLUME_MUTE = 8;\r\n {$EXTERNALSYM APPCOMMAND_VOLUME_MUTE}\r\n APPCOMMAND_VOLUME_DOWN = 9;\r\n {$EXTERNALSYM APPCOMMAND_VOLUME_DOWN}\r\n APPCOMMAND_VOLUME_UP = 10;\r\n {$EXTERNALSYM APPCOMMAND_VOLUME_UP}\r\n APPCOMMAND_MEDIA_NEXTTRACK = 11;\r\n {$EXTERNALSYM APPCOMMAND_MEDIA_NEXTTRACK}\r\n APPCOMMAND_MEDIA_PREVIOUSTRACK = 12;\r\n {$EXTERNALSYM APPCOMMAND_MEDIA_PREVIOUSTRACK}\r\n APPCOMMAND_MEDIA_STOP = 13;\r\n {$EXTERNALSYM APPCOMMAND_MEDIA_STOP}\r\n APPCOMMAND_MEDIA_PLAY_PAUSE = 14;\r\n {$EXTERNALSYM APPCOMMAND_MEDIA_PLAY_PAUSE}\r\n APPCOMMAND_LAUNCH_MAIL = 15;\r\n {$EXTERNALSYM APPCOMMAND_LAUNCH_MAIL}\r\n APPCOMMAND_LAUNCH_MEDIA_SELECT = 16;\r\n {$EXTERNALSYM APPCOMMAND_LAUNCH_MEDIA_SELECT}\r\n APPCOMMAND_LAUNCH_APP1 = 17;\r\n {$EXTERNALSYM APPCOMMAND_LAUNCH_APP1}\r\n APPCOMMAND_LAUNCH_APP2 = 18;\r\n {$EXTERNALSYM APPCOMMAND_LAUNCH_APP2}\r\n APPCOMMAND_BASS_DOWN = 19;\r\n {$EXTERNALSYM APPCOMMAND_BASS_DOWN}\r\n APPCOMMAND_BASS_BOOST = 20;\r\n {$EXTERNALSYM APPCOMMAND_BASS_BOOST}\r\n APPCOMMAND_BASS_UP = 21;\r\n {$EXTERNALSYM APPCOMMAND_BASS_UP}\r\n APPCOMMAND_TREBLE_DOWN = 22;\r\n {$EXTERNALSYM APPCOMMAND_TREBLE_DOWN}\r\n APPCOMMAND_TREBLE_UP = 23;\r\n {$EXTERNALSYM APPCOMMAND_TREBLE_UP}\r\n APPCOMMAND_MICROPHONE_VOLUME_MUTE = 24;\r\n {$EXTERNALSYM APPCOMMAND_MICROPHONE_VOLUME_MUTE}\r\n APPCOMMAND_MICROPHONE_VOLUME_DOWN = 25;\r\n {$EXTERNALSYM APPCOMMAND_MICROPHONE_VOLUME_DOWN}\r\n APPCOMMAND_MICROPHONE_VOLUME_UP = 26;\r\n {$EXTERNALSYM APPCOMMAND_MICROPHONE_VOLUME_UP}\r\n APPCOMMAND_HELP = 27;\r\n {$EXTERNALSYM APPCOMMAND_HELP}\r\n APPCOMMAND_FIND = 28;\r\n {$EXTERNALSYM APPCOMMAND_FIND}\r\n APPCOMMAND_NEW = 29;\r\n {$EXTERNALSYM APPCOMMAND_NEW}\r\n APPCOMMAND_OPEN = 30;\r\n {$EXTERNALSYM APPCOMMAND_OPEN}\r\n APPCOMMAND_CLOSE = 31;\r\n {$EXTERNALSYM APPCOMMAND_CLOSE}\r\n APPCOMMAND_SAVE = 32;\r\n {$EXTERNALSYM APPCOMMAND_SAVE}\r\n APPCOMMAND_PRINT = 33;\r\n {$EXTERNALSYM APPCOMMAND_PRINT}\r\n APPCOMMAND_UNDO = 34;\r\n {$EXTERNALSYM APPCOMMAND_UNDO}\r\n APPCOMMAND_REDO = 35;\r\n {$EXTERNALSYM APPCOMMAND_REDO}\r\n APPCOMMAND_COPY = 36;\r\n {$EXTERNALSYM APPCOMMAND_COPY}\r\n APPCOMMAND_CUT = 37;\r\n {$EXTERNALSYM APPCOMMAND_CUT}\r\n APPCOMMAND_PASTE = 38;\r\n {$EXTERNALSYM APPCOMMAND_PASTE}\r\n APPCOMMAND_REPLY_TO_MAIL = 39;\r\n {$EXTERNALSYM APPCOMMAND_REPLY_TO_MAIL}\r\n APPCOMMAND_FORWARD_MAIL = 40;\r\n {$EXTERNALSYM APPCOMMAND_FORWARD_MAIL}\r\n APPCOMMAND_SEND_MAIL = 41;\r\n {$EXTERNALSYM APPCOMMAND_SEND_MAIL}\r\n APPCOMMAND_SPELL_CHECK = 42;\r\n {$EXTERNALSYM APPCOMMAND_SPELL_CHECK}\r\n APPCOMMAND_DICTATE_OR_COMMAND_CONTROL_TOGGLE = 43;\r\n {$EXTERNALSYM APPCOMMAND_DICTATE_OR_COMMAND_CONTROL_TOGGLE}\r\n APPCOMMAND_MIC_ON_OFF_TOGGLE = 44;\r\n {$EXTERNALSYM APPCOMMAND_MIC_ON_OFF_TOGGLE}\r\n APPCOMMAND_CORRECTION_LIST = 45;\r\n {$EXTERNALSYM APPCOMMAND_CORRECTION_LIST}\r\n APPCOMMAND_MEDIA_PLAY = 46;\r\n {$EXTERNALSYM APPCOMMAND_MEDIA_PLAY}\r\n APPCOMMAND_MEDIA_PAUSE = 47;\r\n {$EXTERNALSYM APPCOMMAND_MEDIA_PAUSE}\r\n APPCOMMAND_MEDIA_RECORD = 48;\r\n {$EXTERNALSYM APPCOMMAND_MEDIA_RECORD}\r\n APPCOMMAND_MEDIA_FAST_FORWARD = 49;\r\n {$EXTERNALSYM APPCOMMAND_MEDIA_FAST_FORWARD}\r\n APPCOMMAND_MEDIA_REWIND = 50;\r\n {$EXTERNALSYM APPCOMMAND_MEDIA_REWIND}\r\n APPCOMMAND_MEDIA_CHANNEL_UP = 51;\r\n {$EXTERNALSYM APPCOMMAND_MEDIA_CHANNEL_UP}\r\n APPCOMMAND_MEDIA_CHANNEL_DOWN = 52;\r\n {$EXTERNALSYM APPCOMMAND_MEDIA_CHANNEL_DOWN}\r\n\r\n FAPPCOMMAND_MOUSE = $8000;\r\n {$EXTERNALSYM FAPPCOMMAND_MOUSE}\r\n FAPPCOMMAND_KEY = 0;\r\n {$EXTERNALSYM FAPPCOMMAND_KEY}\r\n FAPPCOMMAND_OEM = $1000;\r\n {$EXTERNALSYM FAPPCOMMAND_OEM}\r\n FAPPCOMMAND_MASK = $F000;\r\n {$EXTERNALSYM FAPPCOMMAND_MASK}\r\n\r\nfunction GET_APPCOMMAND_LPARAM(lParam: Integer): Word;\r\n{$EXTERNALSYM GET_APPCOMMAND_LPARAM}\r\nfunction GET_DEVICE_LPARAM(lParam: Integer): Word;\r\n{$EXTERNALSYM GET_DEVICE_LPARAM}\r\nfunction GET_MOUSEORKEY_LPARAM(lParam: Integer): Integer;\r\n{$EXTERNALSYM GET_MOUSEORKEY_LPARAM}\r\nfunction GET_FLAGS_LPARAM(lParam: Integer): Word;\r\n{$EXTERNALSYM GET_FLAGS_LPARAM}\r\nfunction GET_KEYSTATE_LPARAM(lParam: Integer): Word;\r\n{$EXTERNALSYM GET_KEYSTATE_LPARAM}\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvWin32.pas $';\r\n Revision: '$Revision: 12461 $';\r\n Date: '$Date: 2009-08-14 19:21:33 +0200 (ven. 14 août 2009) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\n// converted macros\r\n\r\nfunction GET_APPCOMMAND_LPARAM(lParam: Integer): Word;\r\nbegin\r\n Result := HiWord(lParam) and not FAPPCOMMAND_MASK;\r\nend;\r\n\r\nfunction GET_DEVICE_LPARAM(lParam: Integer): Word;\r\nbegin\r\n Result := HiWord(lParam) and FAPPCOMMAND_MASK;\r\nend;\r\n\r\nfunction GET_MOUSEORKEY_LPARAM(lParam: Integer): Integer;\r\nbegin\r\n Result := GET_DEVICE_LPARAM(lParam);\r\nend;\r\n\r\nfunction GET_FLAGS_LPARAM(lParam: Integer): Word;\r\nbegin\r\n Result := LoWord(lParam);\r\nend;\r\n\r\nfunction GET_KEYSTATE_LPARAM(lParam: Integer): Word;\r\nbegin\r\n Result := GET_FLAGS_LPARAM(lParam);\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvWinDialogs.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvWinDialogs.PAS, released on 2002-05-13.\r\n\r\nThe Initial Developer of the Original Code is Serhiy Perevoznyk.\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\nMichael Beck\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvWinDialogs.pas 13397 2012-08-16 17:23:19Z ahuser $\r\n\r\nunit JvWinDialogs;\r\n\r\n{$I jvcl.inc}\r\n{$I windowsonly.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, ShellAPI, ShlObj, ComObj, ActiveX, CommDlg, UrlMon,\r\n SysUtils, Classes,\r\n Graphics, Controls, Forms, Dialogs,\r\n JvBaseDlg, JvJCLUtils; // For OSCheck\r\n\r\n{$HPPEMIT '#include \"dbt.h\"'}\r\n\r\ntype\r\n EShellOleError = class(Exception);\r\n EWinDialogError = class(Exception);\r\n\r\n TShellLinkInfo = record\r\n PathName: string;\r\n Arguments: string;\r\n Description: string;\r\n WorkingDirectory: string;\r\n IconLocation: string;\r\n IconIndex: Integer;\r\n ShowCmd: Integer;\r\n HotKey: Word;\r\n end;\r\n\r\n TSpecialFolderInfo = record\r\n Name: string;\r\n ID: Integer;\r\n end;\r\n\r\nconst\r\n OFN_EX_NOPLACESBAR = 1; // for new style of standard Windows dialogs\r\n {$EXTERNALSYM OFN_EX_NOPLACESBAR}\r\n\r\n SpecialFolders: array [0..29] of TSpecialFolderInfo = (\r\n (Name: 'Alt Startup'; ID: CSIDL_ALTSTARTUP),\r\n (Name: 'Application Data'; ID: CSIDL_APPDATA),\r\n (Name: 'Recycle Bin'; ID: CSIDL_BITBUCKET),\r\n (Name: 'Common Alt Startup'; ID: CSIDL_COMMON_ALTSTARTUP),\r\n (Name: 'Common Desktop'; ID: CSIDL_COMMON_DESKTOPDIRECTORY),\r\n (Name: 'Common Favorites'; ID: CSIDL_COMMON_FAVORITES),\r\n (Name: 'Common Programs'; ID: CSIDL_COMMON_PROGRAMS),\r\n (Name: 'Common Start Menu'; ID: CSIDL_COMMON_STARTMENU),\r\n (Name: 'Common Startup'; ID: CSIDL_COMMON_STARTUP),\r\n (Name: 'Controls'; ID: CSIDL_CONTROLS),\r\n (Name: 'Cookies'; ID: CSIDL_COOKIES),\r\n (Name: 'Desktop'; ID: CSIDL_DESKTOP),\r\n (Name: 'Desktop Directory'; ID: CSIDL_DESKTOPDIRECTORY),\r\n (Name: 'Drives'; ID: CSIDL_DRIVES),\r\n (Name: 'Favorites'; ID: CSIDL_FAVORITES),\r\n (Name: 'Fonts'; ID: CSIDL_FONTS),\r\n (Name: 'History'; ID: CSIDL_HISTORY),\r\n (Name: 'Internet'; ID: CSIDL_INTERNET),\r\n (Name: 'Internet Cache'; ID: CSIDL_INTERNET_CACHE),\r\n (Name: 'Network Neighborhood'; ID: CSIDL_NETHOOD),\r\n (Name: 'Network Top'; ID: CSIDL_NETWORK),\r\n (Name: 'Personal'; ID: CSIDL_PERSONAL),\r\n (Name: 'Printers'; ID: CSIDL_PRINTERS),\r\n (Name: 'Printer Links'; ID: CSIDL_PRINTHOOD),\r\n (Name: 'Programs'; ID: CSIDL_PROGRAMS),\r\n (Name: 'Recent Documents'; ID: CSIDL_RECENT),\r\n (Name: 'Send To'; ID: CSIDL_SENDTO),\r\n (Name: 'Start Menu'; ID: CSIDL_STARTMENU),\r\n (Name: 'Startup'; ID: CSIDL_STARTUP),\r\n (Name: 'Templates'; ID: CSIDL_TEMPLATES));\r\n\r\n {SHObjectProperties Flags}\r\n OPF_PRINTERNAME = $01;\r\n OPF_PATHNAME = $02;\r\n\r\ntype\r\n TOpenFileNameExA = record\r\n lStructSize: DWORD; // Size of the structure in bytes.\r\n hWndOwner: HWND; // Handle that is the parent of the dialog.\r\n hInstance: HINST; // Application instance handle.\r\n lpstrFilter: PAnsiChar; // String containing filter information.\r\n lpstrCustomFilter: PAnsiChar; // Will hold the filter chosen by the user.\r\n nMaxCustFilter: DWORD; // Size of lpstrCustomFilter, in bytes.\r\n nFilterIndex: DWORD; // Index of the filter to be shown.\r\n lpstrFile: PAnsiChar; // File name to start with (and retrieve).\r\n nMaxFile: DWORD; // Size of lpstrFile, in bytes.\r\n lpstrFileTitle: PAnsiChar; // File name without path will be returned.\r\n nMaxFileTitle: DWORD; // Size of lpstrFileTitle, in bytes.\r\n lpstrInitialDir: PAnsiChar; // Starting directory.\r\n lpstrTitle: PAnsiChar; // Title of the open dialog.\r\n Flags: DWORD; // Controls user selection Options.\r\n nFileOffset: Word; // Offset of file name in filepath=lpstrFile.\r\n nFileExtension: Word; // Offset of extension in filepath=lpstrFile.\r\n lpstrDefExt: PAnsiChar; // Default extension if no extension typed.\r\n lCustData: LPARAM; // Custom data to be passed to hook.\r\n lpfnHook: function(Wnd: THandle; Msg: UINT; wParam: WPARAM;\r\n lParam: LPARAM): UINT stdcall; // Hook.\r\n lpTemplateName: PAnsiChar; // Template dialog, if applicable.\r\n // Extended structure starts here.\r\n pvReserved: Pointer; // Reserved, use nil.\r\n dwReserved: DWORD; // Reserved, use 0.\r\n FlagsEx: DWORD; // Extended Flags.\r\n end;\r\n\r\n TOpenFileNameExW = record\r\n lStructSize: DWORD; // Size of the structure in bytes.\r\n hWndOwner: HWND; // Handle that is the parent of the dialog.\r\n hInstance: HINST; // Application instance handle.\r\n lpstrFilter: PWideChar; // String containing filter information.\r\n lpstrCustomFilter: PWideChar; // Will hold the filter chosen by the user.\r\n nMaxCustFilter: DWORD; // Size of lpstrCustomFilter, in bytes.\r\n nFilterIndex: DWORD; // Index of the filter to be shown.\r\n lpstrFile: PWideChar; // File name to start with (and retrieve).\r\n nMaxFile: DWORD; // Size of lpstrFile, in bytes.\r\n lpstrFileTitle: PWideChar; // File name without path will be returned.\r\n nMaxFileTitle: DWORD; // Size of lpstrFileTitle, in bytes.\r\n lpstrInitialDir: PWideChar; // Starting directory.\r\n lpstrTitle: PWideChar; // Title of the open dialog.\r\n Flags: DWORD; // Controls user selection Options.\r\n nFileOffset: Word; // Offset of file name in filepath=lpstrFile.\r\n nFileExtension: Word; // Offset of extension in filepath=lpstrFile.\r\n lpstrDefExt: PWideChar; // Default extension if no extension typed.\r\n lCustData: LPARAM; // Custom data to be passed to hook.\r\n lpfnHook: function(Wnd: THandle; Msg: UINT; wParam: WPARAM;\r\n lParam: LPARAM): UINT stdcall; // Hook.\r\n lpTemplateName: PWideChar; // Template dialog, if applicable.\r\n // Extended structure starts here.\r\n pvReserved: Pointer; // Reserved, use nil.\r\n dwReserved: DWORD; // Reserved, use 0.\r\n FlagsEx: DWORD; // Extended Flags.\r\n end;\r\n\r\n {$IFDEF UNICODE}\r\n TOpenFileNameEx = TOpenFileNameExW;\r\n {$ELSE}\r\n TOpenFileNameEx = TOpenFileNameExA;\r\n {$ENDIF UNICODE}\r\n\r\n TShellObjectType = (sdPathObject, sdPrinterObject);\r\n TShellObjectTypes = set of TShellObjectType;\r\n\r\n TJvFormatDriveKind = (ftQuick, ftStandard, ftBootable);\r\n TJvDriveCapacity = (dcDefault, dcSize360kB, dcSize720kB);\r\n TJvFormatDriveError = (errParams, errSysError, errAborted, errCannotFormat, errOther);\r\n TJvFormatDriveErrorEvent = procedure(Sender: TObject; Error: TJvFormatDriveError) of object;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvFormatDriveDialog = class(TJvCommonDialog)\r\n private\r\n FDrive: Char;\r\n FFormatType: TJvFormatDriveKind;\r\n FCapacity: TJvDriveCapacity;\r\n FOnError: TJvFormatDriveErrorEvent;\r\n procedure SetDrive(Value: Char);\r\n protected\r\n procedure DoError(ErrValue: Integer);\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n function Execute(ParentWnd: HWND): Boolean; override;\r\n published\r\n property Drive: Char read FDrive write SetDrive default 'A';\r\n property FormatType: TJvFormatDriveKind read FFormatType write FFormatType;\r\n property Capacity: TJvDriveCapacity read FCapacity write FCapacity;\r\n property OnError: TJvFormatDriveErrorEvent read FOnError write FOnError;\r\n end;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvOrganizeFavoritesDialog = class(TJvCommonDialog)\r\n public\r\n function Execute(ParentWnd: HWND): Boolean; overload; override;\r\n end;\r\n\r\n TJvCplInfo = record\r\n Icon: TIcon;\r\n Name: string;\r\n Info: string;\r\n lData: Longint;\r\n end;\r\n\r\n // the signature of procedures in CPL's that implements Control Panel functionality\r\n TCplApplet = function(hwndCPl: THandle; uMsg: UINT; lParam1, lParam2: LPARAM): Longint; stdcall;\r\n\r\n // (rom) largely reimplemented\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvAppletDialog = class(TJvCommonDialog)\r\n private\r\n FAppletName: string;\r\n FAppletIndex: Integer;\r\n FModule: HMODULE;\r\n FCount: Integer;\r\n FAppletFunc: TCplApplet;\r\n FAppletInfo: array of TJvCplInfo;\r\n function GetAppletInfo(Index: Integer): TJvCplInfo;\r\n procedure SetAppletName(const AAppletName: string);\r\n procedure Unload;\r\n procedure Load;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n function ValidApplet: Boolean;\r\n // (p3) NOTE: if AppletName or AppletIndex is invalid, shows the control\r\n // panel explorer window instead and returns FALSE\r\n function Execute(ParentWnd: HWND): Boolean; overload; override;\r\n property Count: Integer read FCount;\r\n property AppletInfo[Index: Integer]: TJvCplInfo read GetAppletInfo;\r\n published\r\n property AppletName: string read FAppletName write SetAppletName;\r\n property AppletIndex: Integer read FAppletIndex write FAppletIndex default 0;\r\n end;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvComputerNameDialog = class(TJvCommonDialog)\r\n private\r\n FComputerName: string;\r\n FCaption: string;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n function Execute(ParentWnd: HWND): Boolean; overload; override;\r\n property ComputerName: string read FComputerName;\r\n published\r\n property Caption: string read FCaption write FCaption;\r\n end;\r\n\r\n // (p3) could be removed - a more complete implementation is in JvBrowseFolder\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvBrowseFolderDialog = class(TJvCommonDialog)\r\n private\r\n FFolderName: string;\r\n FCaption: string;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n function Execute(ParentWnd: HWND): Boolean; overload; override;\r\n property FolderName: string read FFolderName;\r\n published\r\n property Caption: string read FCaption write FCaption;\r\n end;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvOutOfMemoryDialog = class(TJvCommonDialog)\r\n private\r\n FCaption: string;\r\n public\r\n function Execute(ParentWnd: HWND): Boolean; overload; override;\r\n published\r\n property Caption: string read FCaption write FCaption;\r\n end;\r\n\r\n // (rom) changed to new TJvCommonDialog to get better Execute\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvChangeIconDialog = class(TJvCommonDialog)\r\n private\r\n FIconIndex: Integer;\r\n FFileName: TFileName;\r\n public\r\n function Execute(ParentWnd: HWND): Boolean; overload; override;\r\n published\r\n property IconIndex: Integer read FIconIndex write FIconIndex;\r\n property FileName: TFileName read FFileName write FFileName;\r\n end;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvShellAboutDialog = class(TJvCommonDialog)\r\n private\r\n FCaption: string;\r\n FIcon: TIcon;\r\n FOtherText: string;\r\n FProduct: string;\r\n procedure SetIcon(NewValue: TIcon);\r\n function StoreIcon: Boolean;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n public\r\n function Execute(ParentWnd: HWND): Boolean; overload; override;\r\n published\r\n property Caption: string read FCaption write FCaption;\r\n property Icon: TIcon read FIcon write SetIcon stored StoreIcon;\r\n property OtherText: string read FOtherText write FOtherText;\r\n property Product: string read FProduct write FProduct;\r\n end;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvRunDialog = class(TJvCommonDialog)\r\n private\r\n FCaption: string;\r\n FDescription: string;\r\n FIcon: TIcon;\r\n procedure SetIcon(const Value: TIcon);\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n function Execute(ParentWnd: HWND): Boolean; overload; override;\r\n published\r\n property Caption: string read FCaption write FCaption;\r\n property Description: string read FDescription write FDescription;\r\n property Icon: TIcon read FIcon write SetIcon;\r\n end;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvObjectPropertiesDialog = class(TJvCommonDialog)\r\n private\r\n FObjectName: TFileName;\r\n FObjectType: TShellObjectType;\r\n FInitialTab: string;\r\n public\r\n function Execute(ParentWnd: HWND): Boolean; overload; override;\r\n published\r\n property ObjectName: TFileName read FObjectName write FObjectName;\r\n property ObjectType: TShellObjectType read FObjectType write FObjectType;\r\n property InitialTab: string read FInitialTab write FInitialTab;\r\n end;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvNewLinkDialog = class(TJvCommonDialog)\r\n private\r\n FDestinationFolder: string;\r\n public\r\n function Execute(ParentWnd: HWND): Boolean; overload; override;\r\n published\r\n property DestinationFolder: string read FDestinationFolder write FDestinationFolder;\r\n end;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvAddHardwareDialog = class(TJvCommonDialog)\r\n public\r\n function Execute(ParentWnd: HWND): Boolean; overload; override;\r\n end;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvOpenWithDialog = class(TJvCommonDialog)\r\n private\r\n FFileName: TFileName;\r\n public\r\n function Execute(ParentWnd: HWND): Boolean; overload; override;\r\n published\r\n property FileName: TFileName read FFileName write FFileName;\r\n end;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvDiskFullDialog = class(TJvCommonDialog)\r\n private\r\n FDriveChar: Char;\r\n procedure SetDriveChar(Value: Char);\r\n function GetDrive: UINT;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n function Execute(ParentWnd: HWND): Boolean; overload; override;\r\n published\r\n property DriveChar: Char read FDriveChar write SetDriveChar default 'C';\r\n end;\r\n\r\n TJvExitWindowsKind = (\r\n ekXPDialog = 0, // Show XP style shutdown dialog\r\n ekVistaLogoff = 1, // Vista Logoff without dialog\r\n ekVistaShutdown = 2 // Vista Shutdown without dialog\r\n );\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvExitWindowsDialog = class(TJvCommonDialog)\r\n private\r\n FKind: TJvExitWindowsKind;\r\n public\r\n function Execute(ParentWnd: HWND): Boolean; overload; override;\r\n published\r\n property Kind: TJvExitWindowsKind read FKind write FKind default ekXPDialog;\r\n end;\r\n\r\n // (p3) this extension (PlacesBar) is already in TJvOpenDialog\r\n TJvOpenDialog2000 = class(TOpenDialog)\r\n public\r\n function Execute{$IFDEF RTL180_UP}(ParentWnd: HWND){$ENDIF RTL180_UP}: Boolean; overload; override;\r\n end;\r\n\r\n // (p3) this extension (PlacesBar) is already in TJvSaveDialog\r\n TJvSaveDialog2000 = class(TSaveDialog)\r\n public\r\n function Execute{$IFDEF RTL180_UP}(ParentWnd: HWND){$ENDIF RTL180_UP}: Boolean; overload; override;\r\n end;\r\n\r\n\r\n TJvURLAssociationDialogOption = (uaDefaultName, uaRegisterAssoc);\r\n TJvURLAssociationDialogOptions = set of TJvURLAssociationDialogOption;\r\n\r\n TJvURLAssociationDialog = class(TJvCommonDialog)\r\n private\r\n FURL: string;\r\n FAssociatedApp: string;\r\n FFileName: TFileName;\r\n FOptions: TJvURLAssociationDialogOptions;\r\n FDefaultProtocol: string;\r\n FReturnValue: HRESULT;\r\n public\r\n // Returns false if user cancelled or if the user\r\n // elected not to register the association. To find out if the user made\r\n // a one-time choice, check the AssociatedApp property: if it is empty,\r\n // the user cancelled\r\n function Execute(ParentWnd: HWND): Boolean; overload; override;\r\n constructor Create(AOwner: TComponent); override;\r\n // After Execute, contains the path and filename to the associated application (if user didn't cancel)\r\n property AssociatedApp: string read FAssociatedApp;\r\n // Value returned by the function called by Execute.\r\n // Possible return values:\r\n // S_OK - content type succesfully associated with the extnesion\r\n // S_FALSE - nothing was registered (f ex a one time registration)\r\n property ReturnValue: HRESULT read FReturnValue;\r\n published\r\n // The file (type) to associate with the Protocol\r\n // NB! FileName *must* contain an extension!\r\n property FileName: TFileName read FFileName write FFileName;\r\n // The URL with the protocol to assoiacte with FileName\r\n // NB! if URL has no protocol (i.e \"http://\", \"mailto:\", \"home-made:\", etc),\r\n // the function fails even before the dialog is displayed!\r\n property URL: string read FURL write FURL;\r\n // DefaultProtocol to prepend to URL if it doesn't have a protocol\r\n property DefaultProtocol: string read FDefaultProtocol write FDefaultProtocol;\r\n // Options for the dialog\r\n property Options: TJvURLAssociationDialogOptions read FOptions write FOptions default [];\r\n end;\r\n\r\n TJvMIMEAssociationOption = (maRegisterAssoc);\r\n TJvMIMEAssociationOptions = set of TJvMIMEAssociationOption;\r\n\r\n TJvMIMEAssociationDialog = class(TJvCommonDialog)\r\n private\r\n FContentType: string;\r\n FAssociatedApp: string;\r\n FFileName: TFileName;\r\n FOptions: TJvMIMEAssociationOptions;\r\n FReturnValue: HRESULT;\r\n public\r\n function Execute(ParentWnd: HWND): Boolean; overload; override;\r\n // After Execute, contains the path and filename to the associated application (if user didn't cancel)\r\n property AssociatedApp: string read FAssociatedApp;\r\n // Value returned by the function called by Execute.\r\n // Possible return values:\r\n // S_OK - content type succesfully associated with the extnesion\r\n // S_FALSE - nothing was registered\r\n // E_ABORT - user cancelled\r\n // E_FLAGS - invalid flag combination\r\n // E_OUTOFMEMORY - out of memory\r\n // E_POINTER - one of the input pointers are invalid\r\n property ReturnValue: HRESULT read FReturnValue;\r\n published\r\n // The file (type) to associate with the Protocol\r\n // NB! FileName *must* contain an extension!\r\n property FileName: TFileName read FFileName write FFileName;\r\n // The MIME contentype of FileName\r\n property ContentType: string read FContentType write FContentType;\r\n property Options: TJvMIMEAssociationOptions read FOptions write FOptions default [];\r\n end;\r\n\r\nconst\r\n SOFTDIST_FLAG_USAGE_EMAIL = $0001;\r\n {$EXTERNALSYM SOFTDIST_FLAG_USAGE_EMAIL}\r\n SOFTDIST_FLAG_USAGE_PRECACHE = $0002;\r\n {$EXTERNALSYM SOFTDIST_FLAG_USAGE_PRECACHE}\r\n SOFTDIST_FLAG_USAGE_AUTOINSTALL = $0003;\r\n {$EXTERNALSYM SOFTDIST_FLAG_USAGE_AUTOINSTALL}\r\n SOFTDIST_FLAG_DELETE_SUBSCRIPTION = $0004;\r\n {$EXTERNALSYM SOFTDIST_FLAG_DELETE_SUBSCRIPTION}\r\n\r\ntype\r\n _tagSOFTDISTINFO = packed record\r\n cbSize: ULONG;\r\n dwFlags: DWORD;\r\n dwAdState: DWORD;\r\n lpszTitle: LPWSTR;\r\n lpszAbstract: LPWSTR;\r\n lpszHREF: LPWSTR;\r\n dwInstalledVersionMS: DWORD;\r\n dwInstalledVersionLS: DWORD;\r\n dwUpdateVersionMS: DWORD;\r\n dwUpdateVersionLS: DWORD;\r\n dwAdvertisedVersionMS: DWORD;\r\n dwAdvertisedVersionLS: DWORD;\r\n cbReserved: DWORD;\r\n end;\r\n {$EXTERNALSYM _tagSOFTDISTINFO}\r\n {$EXTERNALSYM SOFTDISTINFO}\r\n SOFTDISTINFO = _tagSOFTDISTINFO;\r\n {$EXTERNALSYM SOFTDISTINFO}\r\n LPSOFTDISTINFO = ^_tagSOFTDISTINFO;\r\n {$EXTERNALSYM LPSOFTDISTINFO}\r\n TSoftDistInfo = SOFTDISTINFO;\r\n\r\n TJvSoftwareUpdateAdState = (asNone, asAvailable, asDownloaded, asInstalled);\r\n TJvSoftwareUpdateFlags = (ufEmail, ufPreCache, ufAutoInstall, ufDeleteSubscription);\r\n\r\n TJvSoftwareUpdateInfo = class(TPersistent)\r\n private\r\n FInstalledVersionMS: DWORD;\r\n FUpdateVersionLS: DWORD;\r\n FUpdateVersionMS: DWORD;\r\n FAdvertisedVersionMS: DWORD;\r\n FAdvertisedVersionLS: DWORD;\r\n FInstalledVersionLS: DWORD;\r\n FDescription: string;\r\n FTitle: string;\r\n FHREF: string;\r\n FAdState: TJvSoftwareUpdateAdState;\r\n FFlags: TJvSoftwareUpdateFlags;\r\n function GetSoftDistInfo: TSoftDistInfo;\r\n procedure SetSoftDistInfo(const Value: TSoftDistInfo);\r\n public\r\n property SoftDistInfo: TSoftDistInfo read GetSoftDistInfo write SetSoftDistInfo;\r\n published\r\n property AdState: TJvSoftwareUpdateAdState read FAdState write FAdState;\r\n property Flags: TJvSoftwareUpdateFlags read FFlags write FFlags;\r\n property Title: string read FTitle write FTitle;\r\n property HREF: string read FHREF write FHREF;\r\n property Description: string read FDescription write FDescription;\r\n property InstalledVersionMS: DWORD read FInstalledVersionMS write FInstalledVersionMS;\r\n property InstalledVersionLS: DWORD read FInstalledVersionLS write FInstalledVersionLS;\r\n property UpdateVersionMS: DWORD read FUpdateVersionMS write FUpdateVersionMS;\r\n property UpdateVersionLS: DWORD read FUpdateVersionLS write FUpdateVersionLS;\r\n property AdvertisedVersionMS: DWORD read FAdvertisedVersionMS write FAdvertisedVersionMS;\r\n property AdvertisedVersionLS: DWORD read FAdvertisedVersionLS write FAdvertisedVersionLS;\r\n end;\r\n\r\n // (p3) encapsulation of the SoftwareUpdateMessageBox ( for CDF file updating)\r\n TJvSoftwareUpdateDialog = class(TJvCommonDialog)\r\n private\r\n FReturnValue: Cardinal;\r\n FDistributionUnit: string;\r\n FDistInfo: TJvSoftwareUpdateInfo;\r\n public\r\n function Execute(ParentWnd: HWND): Boolean; overload; override;\r\n property ReturnValue: Cardinal read FReturnValue;\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n published\r\n property DistributionUnit: string read FDistributionUnit write FDistributionUnit;\r\n property DistInfo: TJvSoftwareUpdateInfo read FDistInfo write FDistInfo;\r\n end;\r\n\r\n// Tools routines\r\nfunction GetSpecialFolderPath(const FolderName: string; CanCreate: Boolean): string;\r\nprocedure AddToRecentDocs(const FileName: string);\r\nprocedure ClearRecentDocs;\r\nfunction ExtractIconFromFile(FileName: string; Index: Integer): HICON;\r\nfunction CreateShellLink(const AppName, Desc: string; Dest: string): string;\r\nprocedure GetShellLinkInfo(const LinkFile: WideString; var SLI: TShellLinkInfo);\r\nprocedure SetShellLinkInfo(const LinkFile: WideString; const SLI: TShellLinkInfo);\r\nfunction RecycleFile(FileToRecycle: string): Boolean;\r\nfunction CopyFile(FromFile, ToDir: string): Boolean;\r\nfunction ShellObjectTypeEnumToConst(ShellObjectType: TShellObjectType): UINT;\r\nfunction ShellObjectTypeConstToEnum(ShellObjectType: UINT): TShellObjectType;\r\n\r\ntype\r\n FreePIDLProc = procedure(PIDL: PItemIDList); stdcall;\r\n SHChangeIconProc = function(Wnd: THandle; szFileName: PChar; Reserved: Integer;\r\n var lpIconIndex: Integer): DWORD; stdcall;\r\n SHChangeIconProcW = function(Wnd: THandle; szFileName: PWideChar;\r\n Reserved: Integer; var lpIconIndex: Integer): DWORD; stdcall;\r\n SHFormatDriveProc = function(Wnd: THandle; Drive: UINT; fmtID: UINT;\r\n Options: UINT): DWORD; stdcall;\r\n SHShutDownDialogProc = procedure(Wnd: THandle); stdcall;\r\n SHShutDownDialog6Proc = procedure(Wnd: THandle; Kind: Integer); stdcall; // Vista or newer\r\n SHRunDialogProc = function(Wnd: THandle; Unknown1: Integer; Unknown2: Pointer;\r\n szTitle: PChar; szPrompt: PChar; uiFlages: Integer): DWORD; stdcall;\r\n SHFindFilesProc = function(Root: PItemIDList; SavedSearchFile: PItemIDList): LongBool; stdcall;\r\n SHFindComputerProc = function(Reserved1: PItemIDList; Reserved2: PItemIDList): LongBool; stdcall;\r\n SHObjectPropertiesProc = function(Owner: THandle; Flags: UINT;\r\n ObjectName: Pointer; InitialTabName: Pointer): LongBool; stdcall;\r\n SHNetConnectionDialogProc = function(Owner: THandle; ResourceName: Pointer;\r\n ResourceType: DWORD): DWORD; stdcall;\r\n SHStartNetConnectionDialogProc = function(Owner: THandle;\r\n ResourceName: PWideChar; ResourceType: DWORD): DWORD; stdcall;\r\n SHOutOfMemoryMessageBoxProc = function(Owner: THandle; Caption: Pointer;\r\n Style: UINT): Integer; stdcall;\r\n SHHandleDiskFullProc = procedure(Owner: THandle; uDrive: UINT); stdcall;\r\n NewLinkHereProc = procedure(HWND: THandle; HInstance: THandle; CmdLine: PChar;\r\n CmdShow: Integer); stdcall;\r\n SHOpenWithProc = procedure(HWND: THandle; HInstance: THandle; CmdLine: PChar;\r\n CmdShow: Integer); stdcall;\r\n GetOpenFileNameExProc = function(var OpenFile: TOpenFileNameEx): BOOL; stdcall;\r\n GetSaveFileNameExProc = function(var SaveFile: TOpenFileNameEx): BOOL; stdcall;\r\n \r\n URLAssociationDialogProcA = function(hwndParent: THandle; dwInFlags: DWORD; const pcszFile: PAnsiChar; const pcszURL: PAnsiChar;\r\n pszBuff: PAnsiChar; ucAppBufLen: UINT): HRESULT; stdcall;\r\n URLAssociationDialogProcW = function(hwndParent: THandle; dwInFlags: DWORD; const pcszFile: PWideChar; const pcszURL:\r\n PWideChar; pszBuff: PWideChar; ucAppBufLen: UINT): HRESULT; stdcall;\r\n\r\n URLAssociationDialogProc = {$IFDEF UNICODE}URLAssociationDialogProcW{$ELSE}URLAssociationDialogProcA{$ENDIF UNICODE};\r\n\r\n MIMEAssociationDialogProcA = function(hwndParent: THandle; dwInFlags: DWORD;\r\n const pcszFile: PAnsiChar; const pcszMIMEContentType: PAnsiChar; pszAppBuf: PAnsiChar; ucAppBufLen: UINT): HRESULT; stdcall;\r\n MIMEAssociationDialogProcW = function(hwndParent: THandle; dwInFlags: DWORD;\r\n const pcszFile: PWideChar; const pcszMIMEContentType: PWideChar; pszAppBuf: PWideChar;\r\n ucAppBufLen: UINT): HRESULT; stdcall;\r\n\r\n MIMEAssociationDialogProc = {$IFDEF UNICODE}MIMEAssociationDialogProcW{$ELSE}MIMEAssociationDialogProcA{$ENDIF UNICODE};\r\n\r\n SoftwareUpdateMessageBoxProc = function(hWnd: THandle; szDistUnit: LPCWSTR; dwFlags: DWORD;\r\n var psdi: TSoftDistInfo): DWORD; stdcall;\r\n\r\nvar\r\n FreePIDL: FreePIDLProc = nil;\r\n GetOpenFileNameEx: GetOpenFileNameExProc = nil;\r\n GetSaveFileNameEx: GetSaveFileNameExProc = nil;\r\n SHFormatDrive: SHFormatDriveProc = nil;\r\n SHShutDownDialog: SHShutDownDialogProc = nil;\r\n SHShutDownDialog6: SHShutDownDialog6Proc = nil;\r\n SHRunDialog: SHRunDialogProc = nil;\r\n SHFindFiles: SHFindFilesProc = nil;\r\n SHFindComputer: SHFindComputerProc = nil;\r\n SHObjectProperties: SHObjectPropertiesProc = nil;\r\n SHNetConnectionDialog: SHNetConnectionDialogProc = nil;\r\n SHStartNetConnectionDialog: SHStartNetConnectionDialogProc = nil;\r\n SHOutOfMemoryMessageBox: SHOutOfMemoryMessageBoxProc = nil;\r\n SHHandleDiskFull: SHHandleDiskFullProc = nil;\r\n NewLinkHere: NewLinkHereProc = nil;\r\n SHOpenWith: SHOpenWithProc = nil;\r\n SHChangeIcon: SHChangeIconProc = nil;\r\n SHChangeIconW: SHChangeIconProcW = nil;\r\n URLAssociationDialog: URLAssociationDialogProc = nil;\r\n MIMEAssociationDialog: MIMEAssociationDialogProc = nil;\r\n SoftwareUpdateMessageBox: SoftwareUpdateMessageBoxProc = nil;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvWinDialogs.pas $';\r\n Revision: '$Revision: 13397 $';\r\n Date: '$Date: 2012-08-16 19:23:19 +0200 (jeu. 16 août 2012) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n JvResources;\r\n\r\nconst\r\n Shell32 = 'shell32.dll';\r\n URLASSOCDLG_FL_USE_DEFAULT_NAME = $0001;\r\n URLASSOCDLG_FL_REGISTER_ASSOC = $0002;\r\n MIMEASSOCDLG_FL_REGISTER_ASSOC = $0001;\r\n\r\nvar\r\n ShellHandle: THandle = 0;\r\n CommHandle: THandle = 0;\r\n AppWizHandle: THandle = 0;\r\n URLHandle: THandle = 0;\r\n SHDocvwHandle: THandle = 0;\r\n\r\nprocedure LoadJvDialogs;\r\nbegin\r\n ShellHandle := SafeLoadLibrary(Shell32);\r\n if ShellHandle <> 0 then\r\n begin\r\n if Win32Platform = VER_PLATFORM_WIN32_NT then\r\n @SHChangeIconW := GetProcAddress(ShellHandle, PAnsiChar(62))\r\n else\r\n @SHChangeIcon := GetProcAddress(ShellHandle, PAnsiChar(62));\r\n @SHFormatDrive := GetProcAddress(ShellHandle, PAnsiChar('SHFormatDrive'));\r\n @FreePIDL := GetProcAddress(ShellHandle, PAnsiChar(155));\r\n if CheckWin32Version(6, 0) then\r\n @SHShutDownDialog6 := GetProcAddress(ShellHandle, PAnsiChar(60))\r\n else\r\n @SHShutDownDialog := GetProcAddress(ShellHandle, PAnsiChar(60));\r\n @SHRunDialog := GetProcAddress(ShellHandle, PAnsiChar(61));\r\n @SHFindFiles := GetProcAddress(ShellHandle, PAnsiChar(90));\r\n @SHFindComputer := GetProcAddress(ShellHandle, PAnsiChar(91));\r\n @SHObjectProperties := GetProcAddress(ShellHandle, PAnsiChar(178));\r\n @SHNetConnectionDialog := GetProcAddress(ShellHandle, PAnsiChar(160));\r\n @SHOutOfMemoryMessageBox := GetProcAddress(ShellHandle, PAnsiChar(126));\r\n @SHHandleDiskFull := GetProcAddress(ShellHandle, PAnsiChar(185));\r\n @SHStartNetConnectionDialog := GetProcAddress(ShellHandle, PAnsiChar(215));\r\n\r\n @SHOpenWith := GetProcAddress(ShellHandle, {$IFDEF UNICODE}'OpenAs_RunDLLW'{$ELSE}'OpenAs_RunDLLA'{$ENDIF UNICODE});\r\n end;\r\n\r\n CommHandle := SafeLoadLibrary('comdlg32.dll');\r\n if CommHandle <> 0 then\r\n begin\r\n @GetOpenFileNameEx := GetProcAddress(CommHandle, {$IFDEF UNICODE}'GetOpenFileNameW'{$ELSE}'GetOpenFileNameA'{$ENDIF UNICODE});\r\n @GetSaveFileNameEx := GetProcAddress(CommHandle, {$IFDEF UNICODE}'GetSaveFileNameW'{$ELSE}'GetSaveFileNameA'{$ENDIF UNICODE});\r\n end;\r\n\r\n AppWizHandle := SafeLoadLibrary('appwiz.cpl');\r\n if AppWizHandle <> 0 then\r\n @NewLinkHere := GetProcAddress(AppWizHandle, {$IFDEF UNICODE}'NewLinkHereW'{$ELSE}'NewLinkHereA'{$ENDIF UNICODE});\r\n URLHandle := SafeLoadLibrary('url.dll');\r\n if URLHandle <> 0 then\r\n begin\r\n @URLAssociationDialog := GetProcAddress(URLHandle, {$IFDEF UNICODE}'URLAssociationDialogW'{$ELSE}'URLAssociationDialogA'{$ENDIF UNICODE});\r\n @MIMEAssociationDialog := GetProcAddress(URLHandle, {$IFDEF UNICODE}'MIMEAssociationDialogW'{$ELSE}'MIMEAssociationDialogA'{$ENDIF UNICODE});\r\n end;\r\n SHDocvwHandle := SafeLoadLibrary('shdocvw.dll');\r\n if SHDocvwHandle <> 0 then\r\n @SoftwareUpdateMessageBox := GetProcAddress(SHDocvwHandle, 'SoftwareUpdateMessageBox');\r\nend;\r\n\r\nprocedure UnloadJvDialogs;\r\nbegin\r\n if ShellHandle > 0 then\r\n FreeLibrary(ShellHandle);\r\n if CommHandle > 0 then\r\n FreeLibrary(CommHandle);\r\n if AppWizHandle > 0 then\r\n FreeLibrary(AppWizHandle);\r\n if URLHandle > 0 then\r\n FreeLibrary(URLHandle);\r\n if SHDocvwHandle > 0 then\r\n FreeLibrary(SHDocvwHandle);\r\n ShellHandle := 0;\r\n CommHandle := 0;\r\n AppWizHandle := 0;\r\n URLHandle := 0;\r\n SHDocvwHandle := 0;\r\nend;\r\n\r\n{ Although most Win32 applications do not need to be able\r\n to format disks, some do. Windows 95 and Windows NT provide\r\n an API function called SHFormatDrive, which presents the\r\n same dialog box as the Windows 95 and Windows NT shells,\r\n formats the specified diskette.\r\n\r\n The SHFormatDrive API provides access to the Shell's format\r\n dialog box. This allows applications that want to format disks to bring\r\n up the same dialog box that the Shell uses for disk formatting.\r\n\r\n PARAMETERS\r\n hwnd = The window handle of the window that will own the\r\n dialog. NOTE that hwnd == NULL does not cause this\r\n dialog to come up as a \"top level application\"\r\n window. This parameter should always be non-null,\r\n this dialog box is only designed to be the child of\r\n another window, not a stand-alone application.\r\n\r\n Drive = The 0 based (A: == 0) Drive number of the Drive\r\n to format.\r\n\r\n fmtID = Currently must be set to SHFMT_ID_DEFAULT.\r\n\r\n Options = There are currently only two option bits defined.\r\n\r\n SHFMT_OPT_FULL\r\n SHFMT_OPT_SYSONLY\r\n\r\n SHFMT_OPT_FULL specifies that the \"Quick Format\"\r\n setting should be cleared by default. If the user\r\n leaves the \"Quick Format\" setting cleared, then a\r\n full format will be applied (this is useful for\r\n users that detect \"unformatted\" disks and want\r\n to bring up the format dialog box).\r\n\r\n If Options is set to zero (0), then the \"Quick Format\"\r\n setting is set by default. In addition, if the user leaves\r\n it set, a quick format is performed. Under Windows NT 4.0,\r\n this flag is ignored and the \"Quick Format\" box is always\r\n checked when the dialog box first appears. The user can\r\n still change it. This is by design.\r\n\r\n The SHFMT_OPT_SYSONLY initializes the dialog to\r\n default to just sys the disk.\r\n\r\n All other bits are Reserved for future expansion\r\n and must be 0.\r\n\r\n Please note that this is a bit field and not a\r\n value, treat it accordingly.\r\n\r\n RETURN\r\n The return is either one of the SHFMT_* values, or if\r\n the returned DWORD value is not == to one of these\r\n values, then the return is the physical format ID of the\r\n last successful format. The LOWORD of this value can be\r\n passed on subsequent calls as the fmtID parameter to\r\n \"format the same type you did last time\".\r\n}\r\n\r\nconst\r\n SHFMT_ID_DEFAULT = $FFFF;\r\n SHFMT_OPT_FULL = $0001;\r\n SHFMT_OPT_SYSONLY = $0002;\r\n // Special return values. PLEASE NOTE that these are DWORD values.\r\n SHFMT_ERROR = $FFFFFFFF; // Error on last format\r\n // drive may be formatable\r\n SHFMT_CANCEL = $FFFFFFFE; // Last format wascanceled\r\n SHFMT_NOFORMAT = $FFFFFFFD; // Drive is not formatable\r\n\r\ntype\r\n LPFNORGFAV = function(Wnd: hWnd; Str: LPCSTR): Integer; stdcall;\r\n\r\nfunction ExtractIconFromFile(FileName: string; Index: Integer): HICON;\r\nvar\r\n iNumberOfIcons: Integer;\r\nbegin\r\n Result := 0;\r\n if FileExists(FileName) then\r\n begin\r\n iNumberOfIcons := ExtractIcon(hInstance, PChar(FileName), Cardinal(-1));\r\n if (Index >= 0) and (Index < iNumberOfIcons) and (iNumberOfIcons > 0) then\r\n Result := ExtractIcon(hInstance, PChar(FileName), Index);\r\n end;\r\nend;\r\n\r\n//=== { TJvOrganizeFavoritesDialog } =========================================\r\n\r\nfunction TJvOrganizeFavoritesDialog.Execute(ParentWnd: HWND): Boolean;\r\nvar\r\n Path: AnsiString;\r\n lpfnDoOrganizeFavDlg: LPFNORGFAV;\r\nbegin\r\n Result := False;\r\n if SHDocvwHandle <> 0 then\r\n begin\r\n Path := AnsiString(GetSpecialFolderPath('Favorites', True)) + #0#0;\r\n lpfnDoOrganizeFavDlg := LPFNORGFAV(GetProcAddress(SHDocvwHandle, 'DoOrganizeFavDlg'));\r\n if not Assigned(lpfnDoOrganizeFavDlg) then\r\n raise EWinDialogError.CreateRes(@RsEFunctionNotSupported);\r\n lpfnDoOrganizeFavDlg(ParentWnd, PAnsiChar(Path));\r\n Result := True;\r\n end;\r\nend;\r\n\r\n//=== { TJvAppletDialog } ====================================================\r\n\r\nconst\r\n CPL_INIT = 1;\r\n CPL_GETCOUNT = 2;\r\n CPL_INQUIRE = 3;\r\n CPL_SELECT = 4;\r\n CPL_DBLCLK = 5;\r\n CPL_STOP = 6;\r\n CPL_EXIT = 7;\r\n CPL_NEWINQUIRE = 8;\r\n\r\ntype\r\n PCPLInfo = ^TCplInfo;\r\n TCplInfo = record\r\n idIcon: Integer;\r\n idName: Integer;\r\n idInfo: Integer;\r\n lData: Longint;\r\n end;\r\n\r\nconstructor TJvAppletDialog.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FAppletName := '';\r\n FAppletIndex := 0;\r\n FModule := HINSTANCE_ERROR;\r\n FCount := 0;\r\n FAppletFunc := nil;\r\n SetLength(FAppletInfo, 0);\r\nend;\r\n\r\ndestructor TJvAppletDialog.Destroy;\r\nbegin\r\n Unload;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvAppletDialog.Unload;\r\nvar\r\n I: Integer;\r\nbegin\r\n if (FModule > HINSTANCE_ERROR) and Assigned(FAppletFunc) then\r\n begin\r\n FAppletFunc(GetForegroundWindow, CPL_EXIT, AppletIndex, AppletInfo[AppletIndex].lData);\r\n FreeLibrary(FModule);\r\n end;\r\n for I := 0 to Count - 1 do\r\n begin\r\n FAppletInfo[I].Icon.Free;\r\n FAppletInfo[I].Name := '';\r\n FAppletInfo[I].Info := '';\r\n end;\r\n FModule := HINSTANCE_ERROR;\r\n FCount := 0;\r\n FAppletFunc := nil;\r\n SetLength(FAppletInfo, 0);\r\nend;\r\n\r\nprocedure TJvAppletDialog.Load;\r\nvar\r\n I: Integer;\r\n AplInfo: TCplInfo;\r\n Buffer: array [0..1023] of Char;\r\nbegin\r\n Unload;\r\n if AppletName <> '' then\r\n begin\r\n FModule := SafeLoadLibrary(AppletName);\r\n if FModule <> 0 then\r\n begin\r\n FAppletFunc := TCplApplet(GetProcAddress(FModule, 'CPlApplet'));\r\n if Assigned(FAppletFunc) and (FAppletFunc(GetForegroundWindow, CPL_INIT, 0, 0) <> 0) then\r\n begin\r\n FCount := FAppletFunc(GetForegroundWindow, CPL_GETCOUNT, 0, 0);\r\n SetLength(FAppletInfo, FCount);\r\n for I := 0 to Count - 1 do\r\n begin\r\n FAppletFunc(GetForegroundWindow, CPL_INQUIRE, I, LPARAM(@AplInfo));\r\n with FAppletInfo[I] do\r\n begin\r\n Icon := TIcon.Create;\r\n Icon.Handle := LoadIcon(FModule, MakeIntResource(AplInfo.idIcon));\r\n LoadString(FModule, AplInfo.idName, Buffer, SizeOf(Buffer));\r\n Name := Buffer;\r\n LoadString(FModule, AplInfo.idInfo, Buffer, SizeOf(Buffer));\r\n Info := Buffer;\r\n end;\r\n end;\r\n end\r\n else\r\n begin\r\n FreeLibrary(FModule);\r\n FModule := HINSTANCE_ERROR;\r\n end;\r\n end;\r\n end;\r\n if AppletIndex >= Count then\r\n AppletIndex := 0;\r\nend;\r\n\r\nfunction TJvAppletDialog.GetAppletInfo(Index: Integer): TJvCplInfo;\r\nbegin\r\n FillChar(Result, SizeOf(Result), #0);\r\n if (Index >= 0) and (Index < Count) then\r\n Result := FAppletInfo[Index];\r\nend;\r\n\r\nprocedure TJvAppletDialog.SetAppletName(const AAppletName: string);\r\nbegin\r\n Unload;\r\n FAppletName := AAppletName;\r\n Load;\r\nend;\r\n\r\nfunction TJvAppletDialog.Execute(ParentWnd: HWND): Boolean;\r\nbegin\r\n Result := ValidApplet;\r\n if Result then\r\n FAppletFunc(ParentWnd, CPL_DBLCLK, AppletIndex, AppletInfo[AppletIndex].lData)\r\n else\r\n ShellExecute(ParentWnd, 'open', 'Control.exe', nil, nil, SW_SHOWDEFAULT);\r\nend;\r\n\r\nfunction TJvAppletDialog.ValidApplet: Boolean;\r\nbegin\r\n Result := Assigned(FAppletFunc) and (AppletIndex >= 0) and (AppletIndex < Count);\r\nend;\r\n\r\n\r\n\r\n//=== { TJvComputerNameDialog } ==============================================\r\n\r\nconstructor TJvComputerNameDialog.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FComputerName := '';\r\nend;\r\n\r\nfunction TJvComputerNameDialog.Execute(ParentWnd: HWND): Boolean;\r\nvar\r\n BrowseInfo: TBrowseInfo;\r\n ItemIDList: PItemIDList;\r\n NameBuffer: array [0..MAX_PATH] of Char;\r\n WindowList: Pointer;\r\nbegin\r\n Result := False;\r\n\r\n if Failed(SHGetSpecialFolderLocation(ParentWnd, CSIDL_NETWORK,\r\n ItemIDList)) then\r\n Exit;\r\n\r\n FillChar(BrowseInfo, SizeOf(BrowseInfo), 0);\r\n BrowseInfo.hwndOwner := ParentWnd;\r\n BrowseInfo.pidlRoot := ItemIDList;\r\n BrowseInfo.pszDisplayName := NameBuffer;\r\n BrowseInfo.lpszTitle := PChar(FCaption);\r\n BrowseInfo.ulFlags := BIF_BROWSEFORCOMPUTER;\r\n WindowList := DisableTaskWindows(0);\r\n try\r\n Result := SHBrowseForFolder(BrowseInfo) <> nil;\r\n finally\r\n EnableTaskWindows(WindowList);\r\n FreePIDL(BrowseInfo.pidlRoot);\r\n end;\r\n if Result then\r\n FComputerName := NameBuffer;\r\nend;\r\n\r\n//=== { TJvBrowseFolderDialog } ==============================================\r\n\r\nconstructor TJvBrowseFolderDialog.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FFolderName := '';\r\nend;\r\n\r\nfunction TJvBrowseFolderDialog.Execute(ParentWnd: HWND): Boolean;\r\nvar\r\n BrowseInfo: TBrowseInfo;\r\n ItemIDList: PItemIDList;\r\n ItemSelected: PItemIDList;\r\n NameBuffer: array [0..MAX_PATH] of Char;\r\n WindowList: Pointer;\r\nbegin\r\n ItemIDList := nil;\r\n FillChar(BrowseInfo, SizeOf(BrowseInfo), 0);\r\n BrowseInfo.hwndOwner := ParentWnd;\r\n BrowseInfo.pidlRoot := ItemIDList;\r\n BrowseInfo.pszDisplayName := NameBuffer;\r\n BrowseInfo.lpszTitle := PChar(FCaption);\r\n BrowseInfo.ulFlags := BIF_RETURNONLYFSDIRS;\r\n WindowList := DisableTaskWindows(0);\r\n try\r\n ItemSelected := SHBrowseForFolder(BrowseInfo);\r\n Result := ItemSelected <> nil;\r\n finally\r\n EnableTaskWindows(WindowList);\r\n end;\r\n\r\n if Result then\r\n begin\r\n SHGetPathFromIDList(ItemSelected, NameBuffer);\r\n FFolderName := NameBuffer;\r\n end;\r\n FreePIDL(BrowseInfo.pidlRoot);\r\nend;\r\n\r\n//=== { TJvFormatDialog } ====================================================\r\n\r\nconstructor TJvFormatDriveDialog.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FDrive := 'A';\r\nend;\r\n\r\nfunction TJvFormatDriveDialog.Execute(ParentWnd: HWND): Boolean;\r\nvar\r\n iDrive, iCapacity, iFormatType, RetVal: Integer;\r\nbegin\r\n iDrive := Ord(FDrive) - Ord('A');\r\n if Win32Platform = VER_PLATFORM_WIN32_NT then\r\n begin\r\n iCapacity := 0; // other styles not supported\r\n if FFormatType = ftQuick then\r\n iFormatType := 1\r\n else\r\n iFormatType := 0;\r\n end\r\n else\r\n begin\r\n case FCapacity of\r\n dcSize360kB:\r\n iCapacity := 3;\r\n dcSize720kB:\r\n iCapacity := 5;\r\n else\r\n iCapacity := 0;\r\n end;\r\n iFormatType := Ord(FFormatType);\r\n end;\r\n\r\n RetVal := SHFormatDrive(ParentWnd, iDrive, iCapacity, iFormatType);\r\n if Win32Platform = VER_PLATFORM_WIN32_NT then\r\n Result := RetVal = 0\r\n else\r\n Result := RetVal = 6;\r\n if not Result then\r\n DoError(RetVal);\r\nend;\r\n\r\nprocedure TJvFormatDriveDialog.DoError(ErrValue: Integer);\r\nvar\r\n Err: TJvFormatDriveError;\r\nbegin\r\n if Assigned(FOnError) then\r\n begin\r\n if Win32Platform = VER_PLATFORM_WIN32_NT then\r\n Err := errOther\r\n else\r\n case ErrValue of\r\n 0:\r\n Err := errParams;\r\n -1:\r\n Err := errSysError;\r\n -2:\r\n Err := errAborted;\r\n -3:\r\n Err := errCannotFormat;\r\n else\r\n Err := errOther;\r\n end;\r\n FOnError(Self, Err);\r\n end;\r\nend;\r\n\r\nprocedure TJvFormatDriveDialog.SetDrive(Value: Char);\r\nbegin\r\n // (rom) secured\r\n Value := UpCase(Value);\r\n if CharInSet(Value, ['A'..'Z']) then\r\n FDrive := Value;\r\nend;\r\n\r\nfunction GetSpecialFolderPath(const FolderName: string; CanCreate: Boolean): string;\r\nvar\r\n Folder: Integer;\r\n Found: Boolean;\r\n I: Integer;\r\n PIDL: PItemIDList;\r\n Buf: array [0..MAX_PATH] of Char;\r\nbegin\r\n Found := False;\r\n Folder := 0;\r\n Result := '';\r\n for I := Low(SpecialFolders) to High(SpecialFolders) do\r\n begin\r\n if SameFileName(FolderName, SpecialFolders[I].Name) then\r\n begin\r\n Folder := SpecialFolders[I].ID;\r\n Found := True;\r\n Break;\r\n end;\r\n end;\r\n if not Found then\r\n Exit;\r\n { Get path of selected location }\r\n {JPR}\r\n if Succeeded(SHGetSpecialFolderLocation(0, Folder, PIDL)) then\r\n begin\r\n if SHGetPathFromIDList(PIDL, Buf) then\r\n Result := Buf;\r\n CoTaskMemFree(PIDL);\r\n end;\r\n {JPR}\r\nend;\r\n\r\nprocedure AddToRecentDocs(const FileName: string);\r\nbegin\r\n SHAddToRecentDocs(SHARD_PATH, PChar(FileName));\r\nend;\r\n\r\nprocedure ClearRecentDocs;\r\nbegin\r\n SHAddToRecentDocs(SHARD_PATH, nil);\r\nend;\r\n\r\n//=== { TJvOutOfMemoryDialog } ===============================================\r\n\r\nfunction TJvOutOfMemoryDialog.Execute(ParentWnd: HWND): Boolean;\r\nvar\r\n CaptionBuffer: Pointer;\r\nbegin\r\n CaptionBuffer := nil;\r\n if FCaption <> '' then\r\n GetMem(CaptionBuffer, (Length(FCaption) + 1) * SizeOf(WideChar));\r\n\r\n if Win32Platform = VER_PLATFORM_WIN32_NT then\r\n begin\r\n if CaptionBuffer <> nil then\r\n StringToWideChar(FCaption, PWideChar(CaptionBuffer), Length(FCaption) + 1);\r\n end\r\n else\r\n begin\r\n if CaptionBuffer <> nil then\r\n StrPCopy(PChar(CaptionBuffer), FCaption);\r\n end;\r\n if Assigned(SHOutOfMemoryMessageBox) then\r\n Result := Boolean(SHOutOfMemoryMessageBox(ParentWnd, CaptionBuffer,\r\n MB_OK or MB_ICONHAND))\r\n else\r\n raise EWinDialogError.CreateRes(@RsENotSupported);\r\nend;\r\n\r\n//=== { TJvShellAboutDialog } ================================================\r\n\r\nconstructor TJvShellAboutDialog.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FIcon := TIcon.Create;\r\nend;\r\n\r\ndestructor TJvShellAboutDialog.Destroy;\r\nbegin\r\n FIcon.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvShellAboutDialog.SetIcon(NewValue: TIcon);\r\nbegin\r\n FIcon.Assign(NewValue);\r\nend;\r\n\r\nfunction TJvShellAboutDialog.StoreIcon: Boolean;\r\nbegin\r\n Result := (not FIcon.Empty);\r\nend;\r\n\r\nfunction TJvShellAboutDialog.Execute(ParentWnd: HWND): Boolean;\r\nconst\r\n AboutText = 'JvDialogs 2.0';\r\n CaptionSeparator = '#';\r\nvar\r\n CaptionText: string;\r\nbegin\r\n if Caption = '' then\r\n CaptionText := AboutText\r\n else\r\n CaptionText := Caption;\r\n\r\n CaptionText := CaptionText + CaptionSeparator + Product;\r\n\r\n OSCheck(LongBool(ShellAbout(ParentWnd,\r\n PChar(CaptionText), PChar(OtherText), FIcon.Handle)));\r\n Result := True;\r\nend;\r\n\r\n//=== { TJvRunDialog } =======================================================\r\n\r\nconstructor TJvRunDialog.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FCaption := '';\r\n FDescription := '';\r\n FIcon := TIcon.Create;\r\nend;\r\n\r\ndestructor TJvRunDialog.Destroy;\r\nbegin\r\n FIcon.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJvRunDialog.Execute(ParentWnd: HWND): Boolean;\r\nvar\r\n CaptionBuffer: Pointer;\r\n DescriptionBuffer: Pointer;\r\nbegin\r\n CaptionBuffer := nil;\r\n DescriptionBuffer := nil;\r\n\r\n if FCaption <> '' then\r\n GetMem(CaptionBuffer, (Length(FCaption) + 1) * SizeOf(WideChar));\r\n\r\n if FDescription <> '' then\r\n GetMem(DescriptionBuffer, (Length(FDescription) + 1) * SizeOf(WideChar));\r\n\r\n if Win32Platform = VER_PLATFORM_WIN32_NT then\r\n begin\r\n if CaptionBuffer <> nil then\r\n StringToWideChar(FCaption, PWideChar(CaptionBuffer), Length(FCaption) + 1);\r\n if DescriptionBuffer <> nil then\r\n StringToWideChar(FDescription, PWideChar(DescriptionBuffer),\r\n Length(FDescription) + 1);\r\n end\r\n else\r\n begin\r\n if CaptionBuffer <> nil then\r\n StrPCopy(PChar(CaptionBuffer), FCaption);\r\n if DescriptionBuffer <> nil then\r\n StrPCopy(PChar(DescriptionBuffer), FDescription);\r\n end;\r\n\r\n if Assigned(SHRunDialog) then\r\n Result := SHRunDialog(ParentWnd, FIcon.Handle, nil, CaptionBuffer,\r\n DescriptionBuffer, 0) = 0\r\n else\r\n raise EWinDialogError.CreateRes(@RsENotSupported);\r\nend;\r\n\r\nprocedure TJvRunDialog.SetIcon(const Value: TIcon);\r\nbegin\r\n FIcon.Assign(Value);\r\nend;\r\n\r\n//=== { TJvObjectPropertiesDialog } ==========================================\r\n\r\nfunction TJvObjectPropertiesDialog.Execute(ParentWnd: HWND): Boolean;\r\nvar\r\n ObjectNameBuffer: Pointer;\r\n TabNameBuffer: Pointer;\r\nbegin\r\n GetMem(ObjectNameBuffer, (Length(ObjectName) + 1) * SizeOf(WideChar));\r\n try\r\n if SysUtils.Win32Platform = VER_PLATFORM_WIN32_NT then\r\n begin\r\n StringToWideChar(ObjectName, PWideChar(ObjectNameBuffer),\r\n Length(ObjectName) + 1);\r\n end\r\n else\r\n begin\r\n StrPCopy(PChar(ObjectNameBuffer), ObjectName);\r\n end;\r\n\r\n GetMem(TabNameBuffer, (Length(InitialTab) + 1) * SizeOf(WideChar));\r\n try\r\n if SysUtils.Win32Platform = VER_PLATFORM_WIN32_NT then\r\n begin\r\n StringToWideChar(InitialTab, PWideChar(TabNameBuffer),\r\n Length(InitialTab) + 1);\r\n end\r\n else\r\n begin\r\n StrPCopy(PChar(TabNameBuffer), InitialTab);\r\n end;\r\n Result := SHObjectProperties(ParentWnd,\r\n ShellObjectTypeEnumToConst(ObjectType), ObjectNameBuffer,\r\n TabNameBuffer);\r\n finally\r\n FreeMem(TabNameBuffer);\r\n end;\r\n finally\r\n FreeMem(ObjectNameBuffer);\r\n end;\r\nend;\r\n\r\nfunction ShellObjectTypeEnumToConst(ShellObjectType: TShellObjectType): UINT;\r\nbegin\r\n case ShellObjectType of\r\n sdPathObject:\r\n Result := OPF_PATHNAME;\r\n sdPrinterObject:\r\n Result := OPF_PRINTERNAME;\r\n else\r\n Result := 0;\r\n end;\r\nend;\r\n\r\nfunction ShellObjectTypeConstToEnum(ShellObjectType: UINT): TShellObjectType;\r\nbegin\r\n case ShellObjectType of\r\n OPF_PATHNAME:\r\n Result := sdPathObject;\r\n OPF_PRINTERNAME:\r\n Result := sdPrinterObject;\r\n else\r\n Result := sdPathObject;\r\n end;\r\nend;\r\n\r\n//=== { TJvNewLinkDialog } ===================================================\r\n\r\nfunction TJvNewLinkDialog.Execute(ParentWnd: HWND): Boolean;\r\nbegin\r\n NewLinkHere(0, 0, PChar(DestinationFolder), 0);\r\n Result := True; // No way to know it worked\r\nend;\r\n\r\n//=== { TJvAddHardwareDialog } ===============================================\r\n\r\nfunction TJvAddHardwareDialog.Execute(ParentWnd: HWND): Boolean;\r\nvar\r\n APModule: THandle;\r\n Applet: TCplApplet;\r\nbegin\r\n Result := False;\r\n APModule := SafeLoadLibrary('hdwwiz.cpl');\r\n if APModule <= HINSTANCE_ERROR then\r\n Exit;\r\n Applet := TCplApplet(GetProcAddress(APModule, 'CPlApplet'));\r\n Applet(0, CPL_DBLCLK, 0, 0);\r\n FreeLibrary(APModule);\r\n Result := True;\r\nend;\r\n\r\nfunction CreateShellLink(const AppName, Desc: string; Dest: string): string;\r\n{ Creates a shell link for application or document specified in }\r\n{ AppName with description Desc. Link will be located in folder }\r\n{ specified by Dest, which is one of the string constants shown }\r\n{ at the top of this unit. Returns the full path name of the }\r\n{ link file. }\r\nvar\r\n SL: IShellLink;\r\n PF: IPersistFile;\r\n LnkName: WideString;\r\nbegin\r\n OleCheck(CoCreateInstance(CLSID_ShellLink, nil, CLSCTX_INPROC_SERVER,\r\n IShellLink, SL));\r\n { The IShellLink implementer must also support the IPersistFile }\r\n { interface. Get an interface pointer to it. }\r\n PF := SL as IPersistFile;\r\n OleCheck(SL.SetPath(PChar(AppName))); // set link path to proper file\r\n if Desc <> '' then\r\n OleCheck(SL.SetDescription(PChar(Desc))); // set description\r\n { create a path location and filename for link file }\r\n LnkName := GetSpecialFolderPath(Dest, True) + '\\' +\r\n ChangeFileExt(AppName, 'lnk');\r\n PF.Save(PWideChar(LnkName), True); // save link file\r\n Result := LnkName;\r\nend;\r\n\r\nprocedure GetShellLinkInfo(const LinkFile: WideString; var SLI: TShellLinkInfo);\r\n{ Retrieves information on an existing shell link }\r\nvar\r\n SL: IShellLink;\r\n PF: IPersistFile;\r\n FindData: TWin32FindData;\r\n AStr: array [0..MAX_PATH] of Char;\r\nbegin\r\n OleCheck(CoCreateInstance(CLSID_ShellLink, nil, CLSCTX_INPROC_SERVER,\r\n IShellLink, SL));\r\n { The IShellLink implementer must also support the IPersistFile }\r\n { interface. Get an interface pointer to it. }\r\n PF := SL as IPersistFile;\r\n { Load file into IPersistFile object }\r\n OleCheck(PF.Load(PWideChar(LinkFile), STGM_READ));\r\n { Resolve the link by calling the Resolve interface function. }\r\n OleCheck(SL.Resolve(0, SLR_ANY_MATCH or SLR_NO_UI));\r\n { Get all the info! }\r\n with SLI do\r\n begin\r\n OleCheck(SL.GetPath(AStr, MAX_PATH, FindData, SLGP_SHORTPATH));\r\n PathName := AStr;\r\n OleCheck(SL.GetArguments(AStr, MAX_PATH));\r\n Arguments := AStr;\r\n OleCheck(SL.GetDescription(AStr, MAX_PATH));\r\n Description := AStr;\r\n OleCheck(SL.GetWorkingDirectory(AStr, MAX_PATH));\r\n WorkingDirectory := AStr;\r\n OleCheck(SL.GetIconLocation(AStr, MAX_PATH, IconIndex));\r\n IconLocation := AStr;\r\n OleCheck(SL.GetShowCmd(ShowCmd));\r\n OleCheck(SL.GetHotKey(HotKey));\r\n end;\r\nend;\r\n\r\nprocedure SetShellLinkInfo(const LinkFile: WideString;\r\n const SLI: TShellLinkInfo);\r\n{ Sets information for an existing shell link }\r\nvar\r\n SL: IShellLink;\r\n PF: IPersistFile;\r\nbegin\r\n OleCheck(CoCreateInstance(CLSID_ShellLink, nil, CLSCTX_INPROC_SERVER,\r\n IShellLink, SL));\r\n { The IShellLink implementer must also support the IPersistFile }\r\n { interface. Get an interface pointer to it. }\r\n PF := SL as IPersistFile;\r\n { Load file into IPersistFile object }\r\n OleCheck(PF.Load(PWideChar(LinkFile), STGM_SHARE_DENY_WRITE));\r\n { Resolve the link by calling the Resolve interface function. }\r\n OleCheck(SL.Resolve(0, SLR_ANY_MATCH or SLR_UPDATE or SLR_NO_UI));\r\n { Set all the info! }\r\n with SLI, SL do\r\n begin\r\n OleCheck(SetPath(PChar(PathName)));\r\n OleCheck(SetArguments(PChar(Arguments)));\r\n OleCheck(SetDescription(PChar(Description)));\r\n OleCheck(SetWorkingDirectory(PChar(WorkingDirectory)));\r\n OleCheck(SetIconLocation(PChar(IconLocation), IconIndex));\r\n OleCheck(SetShowCmd(ShowCmd));\r\n OleCheck(SetHotKey(HotKey));\r\n end;\r\n PF.Save(PWideChar(LinkFile), True); // save file\r\nend;\r\n\r\nfunction RecycleFile(FileToRecycle: string): Boolean;\r\nvar\r\n OpStruct: TSHFileOpStruct;\r\n PFromC: PChar;\r\n ResultVal: Integer;\r\nbegin\r\n if not FileExists(FileToRecycle) then\r\n begin\r\n RecycleFile := False;\r\n Exit;\r\n end\r\n else\r\n begin\r\n PFromC := PChar(ExpandFileName(FileToRecycle) + #0#0);\r\n OpStruct.Wnd := 0;\r\n OpStruct.wFunc := FO_DELETE;\r\n OpStruct.pFrom := PFromC;\r\n OpStruct.pTo := nil;\r\n OpStruct.fFlags := FOF_ALLOWUNDO;\r\n OpStruct.fAnyOperationsAborted := False;\r\n OpStruct.hNameMappings := nil;\r\n ResultVal := ShFileOperation(OpStruct);\r\n RecycleFile := (ResultVal = 0);\r\n end;\r\nend;\r\n\r\nfunction CopyFile(FromFile, ToDir: string): Boolean;\r\nvar\r\n F: TSHFileOpStruct;\r\nbegin\r\n F.Wnd := 0;\r\n F.wFunc := FO_COPY;\r\n FromFile := FromFile + #0;\r\n F.pFrom := PChar(FromFile);\r\n ToDir := ToDir + #0;\r\n F.pTo := PChar(ToDir);\r\n F.fFlags := FOF_ALLOWUNDO or FOF_NOCONFIRMATION;\r\n Result := ShFileOperation(F) = 0;\r\nend;\r\n\r\n// (rom) ExecuteApplet function removed\r\n\r\n//=== { TJvOpenWithDialog } ==================================================\r\n\r\nfunction TJvOpenWithDialog.Execute(ParentWnd: HWND): Boolean;\r\nbegin\r\n SHOpenWith(ParentWnd, 0, PChar(FileName), SW_SHOW);\r\n Result := True; // No way to know it worked\r\nend;\r\n\r\n//=== { TJvDiskFullDialog } ==================================================\r\n\r\nconstructor TJvDiskFullDialog.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n DriveChar := 'C';\r\nend;\r\n\r\nfunction TJvDiskFullDialog.GetDrive: UINT;\r\nbegin\r\n Result := Ord(FDriveChar) - Ord('A');\r\nend;\r\n\r\nfunction TJvDiskFullDialog.Execute(ParentWnd: HWND): Boolean;\r\nbegin\r\n if not Assigned(SHHandleDiskFull) then\r\n raise EWinDialogError.CreateRes(@RsENotSupported);\r\n Result := GetDriveType(PChar(DriveChar + ':\\')) = 3;\r\n if Result then\r\n SHHandleDiskFull(ParentWnd, GetDrive);\r\nend;\r\n\r\nprocedure TJvDiskFullDialog.SetDriveChar(Value: Char);\r\nbegin\r\n Value := UpCase(Value);\r\n if not CharInSet(Value, ['A'..'Z']) then\r\n raise EWinDialogError.CreateResFmt(@RsEInvalidDriveChar, [Value]);\r\n FDriveChar := Value;\r\nend;\r\n\r\n//=== { TJvExitWindowsDialog } ===============================================\r\n\r\nfunction TJvExitWindowsDialog.Execute(ParentWnd: HWND): Boolean;\r\nbegin\r\n if not Assigned(SHShutDownDialog) and not Assigned(SHShutDownDialog6) then\r\n raise EWinDialogError.CreateRes(@RsENotSupported);\r\n if Assigned(SHShutDownDialog6) then\r\n SHShutDownDialog6(ParentWnd, Integer(Kind)) // Vista or newer\r\n else\r\n SHShutDownDialog(ParentWnd);\r\n Result := True;\r\nend;\r\n\r\n//=== { TJvChangeIconDialog } ================================================\r\n\r\nfunction TJvChangeIconDialog.Execute(ParentWnd: HWND): Boolean;\r\nvar\r\n Buf: array [0..MAX_PATH] of Char;\r\n BufW: array [0..MAX_PATH] of WideChar;\r\nbegin\r\n if Assigned(SHChangeIconW) then\r\n begin\r\n StringToWideChar(FileName, BufW, SizeOf(BufW));\r\n Result := SHChangeIconW(ParentWnd, BufW, SizeOf(BufW), FIconIndex) = 1;\r\n if Result then\r\n FileName := BufW;\r\n end\r\n else\r\n if Assigned(SHChangeIcon) then\r\n begin\r\n StrPCopy(Buf, FileName);\r\n Result := SHChangeIcon(ParentWnd, Buf, SizeOf(Buf), FIconIndex) = 1;\r\n if Result then\r\n FileName := Buf;\r\n end\r\n else\r\n raise EWinDialogError.CreateRes(@RsENotSupported);\r\nend;\r\n\r\nfunction OpenInterceptor(var DialogData: TOpenFileName): BOOL; stdcall;\r\nvar\r\n DialogDataEx: TOpenFileNameEx;\r\nbegin\r\n Move(DialogData, DialogDataEx, SizeOf(DialogData));\r\n DialogDataEx.FlagsEx := 0;\r\n DialogDataEx.lStructSize := SizeOf(TOpenFileNameEx);\r\n Result := GetOpenFileNameEx(DialogDataEx);\r\nend;\r\n\r\nfunction SaveInterceptor(var DialogData: TOpenFileName): BOOL; stdcall;\r\nvar\r\n DialogDataEx: TOpenFileNameEx;\r\nbegin\r\n Move(DialogData, DialogDataEx, SizeOf(DialogData));\r\n DialogDataEx.FlagsEx := 0;\r\n DialogDataEx.lStructSize := SizeOf(TOpenFileNameEx);\r\n Result := GetSaveFileNameEx(DialogDataEx);\r\nend;\r\n\r\n\r\n\r\n//=== { TJvOpenDialog2000 } ==================================================\r\n\r\nfunction TJvOpenDialog2000.Execute{$IFDEF RTL180_UP}(ParentWnd: HWND){$ENDIF RTL180_UP}: Boolean;\r\nbegin\r\n if CheckWin32Version(5, 0) and (Win32Platform = VER_PLATFORM_WIN32_NT) then\r\n Result := DoExecute(@OpenInterceptor)\r\n else\r\n Result := inherited Execute{$IFDEF RTL180_UP}(ParentWnd){$ENDIF RTL180_UP};\r\nend;\r\n\r\n//=== { TJvSaveDialog2000 } ==================================================\r\n\r\nfunction TJvSaveDialog2000.Execute{$IFDEF RTL180_UP}(ParentWnd: HWND){$ENDIF RTL180_UP}: Boolean;\r\nbegin\r\n if CheckWin32Version(5, 0) and (Win32Platform = VER_PLATFORM_WIN32_NT) then\r\n Result := DoExecute(@SaveInterceptor)\r\n else\r\n Result := inherited Execute{$IFDEF RTL180_UP}(ParentWnd){$ENDIF RTL180_UP};\r\nend;\r\n\r\n//=== { TJvURLAssociationDialog } ============================================\r\n\r\nconstructor TJvURLAssociationDialog.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FOptions := [];\r\n FDefaultProtocol := 'http://'; // the URL property needs a protocol or the function call fails\r\nend;\r\n\r\nfunction TJvURLAssociationDialog.Execute(ParentWnd: HWND): Boolean;\r\nvar\r\n dwFlags: DWORD;\r\n Buf: array [0..MAX_PATH] of Char;\r\nbegin\r\n Result := False;\r\n FReturnValue := S_FALSE;\r\n FAssociatedApp := '';\r\n if Pos(':', URL) < 1 then\r\n FURL := FDefaultProtocol + FURL;\r\n if Assigned(URLAssociationDialog) then\r\n begin\r\n dwFlags := 0;\r\n FillChar(Buf[0], SizeOf(Buf), 0);\r\n if uaDefaultName in Options then\r\n dwFlags := dwFlags or URLASSOCDLG_FL_USE_DEFAULT_NAME;\r\n if uaRegisterAssoc in Options then\r\n dwFlags := dwFlags or URLASSOCDLG_FL_REGISTER_ASSOC;\r\n FReturnValue := URLAssociationDialog(ParentWnd, dwFlags,\r\n PChar(FileName), PChar(URL), Buf, SizeOf(Buf));\r\n Result := ReturnValue = S_OK;\r\n FAssociatedApp := Buf;\r\n end;\r\nend;\r\n\r\n//=== { TJvMIMEAssociationDialog } ===========================================\r\n\r\nfunction TJvMIMEAssociationDialog.Execute(ParentWnd: HWND): Boolean;\r\nvar\r\n dwFlags: Cardinal;\r\n Buf: array [0..MAX_PATH] of Char;\r\nbegin\r\n Result := False;\r\n FReturnValue := S_FALSE;\r\n if Assigned(MIMEAssociationDialog) then\r\n begin\r\n FillChar(Buf[0], SizeOf(Buf), 0);\r\n FAssociatedApp := '';\r\n if maRegisterAssoc in Options then\r\n dwFlags := MIMEASSOCDLG_FL_REGISTER_ASSOC\r\n else\r\n dwFlags := 0;\r\n FReturnValue := MIMEAssociationDialog(ParentWnd, dwFlags,\r\n PChar(FileName), PChar(ContentType), Buf, SizeOf(Buf));\r\n Result := ReturnValue = 0;\r\n FAssociatedApp := Buf;\r\n end;\r\nend;\r\n\r\n//=== { TJvSoftwareUpdateDialog } ============================================\r\n\r\nconstructor TJvSoftwareUpdateDialog.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FDistInfo := TJvSoftwareUpdateInfo.Create;\r\nend;\r\n\r\ndestructor TJvSoftwareUpdateDialog.Destroy;\r\nbegin\r\n FDistInfo.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJvSoftwareUpdateDialog.Execute(ParentWnd: HWND): Boolean;\r\nvar\r\n psdi: TSoftDistInfo;\r\nbegin\r\n Result := False;\r\n FReturnValue := IDCANCEL;\r\n if Assigned(SoftwareUpdateMessageBox) then\r\n begin\r\n psdi := FDistInfo.SoftDistInfo;\r\n FReturnValue := SoftwareUpdateMessageBox(ParentWnd, '', 0, psdi);\r\n Result := ReturnValue = IDYES;\r\n if ReturnValue <> IDABORT then\r\n FDistInfo.SoftDistInfo := psdi;\r\n end;\r\nend;\r\n\r\n//=== { TJvSoftwareUpdateInfo } ==============================================\r\n\r\nfunction TJvSoftwareUpdateInfo.GetSoftDistInfo: TSoftDistInfo;\r\nconst\r\n cAdState: array [TJvSoftwareUpdateAdState] of DWORD =\r\n (SOFTDIST_ADSTATE_NONE, SOFTDIST_ADSTATE_AVAILABLE,\r\n SOFTDIST_ADSTATE_DOWNLOADED, SOFTDIST_ADSTATE_INSTALLED);\r\n cFlags: array [TJvSoftwareUpdateFlags] of DWORD =\r\n (SOFTDIST_FLAG_USAGE_EMAIL, SOFTDIST_FLAG_USAGE_PRECACHE,\r\n SOFTDIST_FLAG_USAGE_AUTOINSTALL, SOFTDIST_FLAG_DELETE_SUBSCRIPTION);\r\nbegin\r\n FillChar(Result, SizeOf(Result), 0);\r\n Result.cbSize := SizeOf(Result);\r\n with Result do\r\n begin\r\n dwAdState := cAdState[AdState];\r\n dwFlags := cFlags[Flags];\r\n // (p3)_ does result from StringToOLEStr need to be freed?\r\n lpszTitle := StringToOleStr(Title);\r\n lpszAbstract := StringToOleStr(Description);\r\n lpszHREF := StringToOleStr(HREF);\r\n dwInstalledVersionMS := InstalledVersionMS;\r\n dwInstalledVersionLS := InstalledVersionLS;\r\n dwUpdateVersionMS := UpdateVersionMS;\r\n dwUpdateVersionLS := UpdateVersionLS;\r\n dwAdvertisedVersionMS := AdvertisedVersionMS;\r\n dwAdvertisedVersionLS := AdvertisedVersionLS;\r\n end;\r\nend;\r\n\r\nprocedure TJvSoftwareUpdateInfo.SetSoftDistInfo(const Value: TSoftDistInfo);\r\nbegin\r\n with Value do\r\n begin\r\n case dwAdState of\r\n SOFTDIST_ADSTATE_NONE:\r\n AdState := asNone;\r\n SOFTDIST_ADSTATE_AVAILABLE:\r\n AdState := asAvailable;\r\n SOFTDIST_ADSTATE_DOWNLOADED:\r\n AdState := asDownloaded;\r\n SOFTDIST_ADSTATE_INSTALLED:\r\n AdState := asInstalled;\r\n end;\r\n case dwFlags of\r\n SOFTDIST_FLAG_USAGE_EMAIL:\r\n Flags := ufEmail;\r\n SOFTDIST_FLAG_USAGE_PRECACHE:\r\n Flags := ufPreCache;\r\n SOFTDIST_FLAG_USAGE_AUTOINSTALL:\r\n Flags := ufAutoInstall;\r\n SOFTDIST_FLAG_DELETE_SUBSCRIPTION:\r\n Flags := ufDeleteSubscription;\r\n end;\r\n\r\n Title := lpszTitle;\r\n Description := lpszAbstract;\r\n HREF := lpszHREF;\r\n InstalledVersionMS := dwInstalledVersionMS;\r\n InstalledVersionLS := dwInstalledVersionLS;\r\n UpdateVersionMS := dwUpdateVersionMS;\r\n UpdateVersionLS := dwUpdateVersionLS;\r\n AdvertisedVersionMS := dwAdvertisedVersionMS;\r\n AdvertisedVersionLS := dwAdvertisedVersionLS;\r\n end;\r\nend;\r\n\r\ninitialization\r\n {$IFDEF UNITVERSIONING}\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n {$ENDIF UNITVERSIONING}\r\n LoadJvDialogs;\r\n\r\nfinalization\r\n UnloadJvDialogs;\r\n {$IFDEF UNITVERSIONING}\r\n UnregisterUnitVersion(HInstance);\r\n {$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvWinHelp.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvWinHelp.PAS, released on 2001-02-28.\r\n\r\nThe Initial Developer of the Original Code is Sbastien Buysse [sbuysse att buypin dott com]\r\nPortions created by Sbastien Buysse are Copyright (C) 2001 Sbastien Buysse.\r\nAll Rights Reserved.\r\n\r\nContributor(s): Michael Beck [mbeck att bigfoot dott com].\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvWinHelp.pas 13104 2011-09-07 06:50:43Z obones $\r\n\r\nunit JvWinHelp;\r\n\r\n{$I jvcl.inc}\r\n{$I windowsonly.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n SysUtils, Classes,\r\n {$IFDEF MSWINDOWS}\r\n Windows,\r\n {$ENDIF MSWINDOWS}\r\n Controls, Forms, Menus,\r\n JvTypes, JvComponentBase;\r\n\r\ntype\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64 or pidOSX32)]\r\n {$ENDIF RTL230_UP}\r\n TJvWinHelp = class(TJvComponent)\r\n private\r\n FHelpFile: string;\r\n FOwner: TComponent;\r\n function GetHelpFile: PChar;\r\n protected\r\n function GetOwnerHandle: THandle;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n function ShowContextualHelp(Control: TWinControl): Boolean;\r\n function ExecuteCommand(MacroCommand: string): Boolean;\r\n function ShowHelp(Control: TWinControl): Boolean;\r\n function ShowContents: Boolean;\r\n function ShowHelpOnHelp: Boolean;\r\n function ShowIndex: Boolean;\r\n function ShowKeyword(Keyword: string): Boolean;\r\n function ShowPartialKeyWord(Keyword: string): Boolean;\r\n function SetWindowPos(Left, Top, Width, Height: Integer; Visibility: Integer): Boolean;\r\n published\r\n property HelpFile: string read FHelpFile write FHelpFile;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvWinHelp.pas $';\r\n Revision: '$Revision: 13104 $';\r\n Date: '$Date: 2011-09-07 08:50:43 +0200 (mer. 07 sept. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n JvResources;\r\n\r\nconstructor TJvWinHelp.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FHelpFile := '';\r\n FOwner := AOwner;\r\n while FOwner.GetParentComponent <> nil do\r\n FOwner := FOwner.GetParentComponent;\r\n if not (FOwner is TCustomForm) then\r\n raise EJVCLException.CreateRes(@RsEOwnerForm);\r\nend;\r\n\r\ndestructor TJvWinHelp.Destroy;\r\nbegin\r\n WinHelp(GetOwnerHandle, GetHelpFile, HELP_QUIT, 0);\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJvWinHelp.ExecuteCommand(MacroCommand: string): Boolean;\r\nbegin\r\n Result := WinHelp(GetOwnerHandle, GetHelpFile, HELP_COMMAND, LPARAM(PChar(MacroCommand)));\r\nend;\r\n\r\nfunction TJvWinHelp.GetHelpFile: PChar;\r\nbegin\r\n if (FHelpFile = '') and (FOwner is TForm) and not (csDestroying in TForm(FOwner).ComponentState) then\r\n Result := PChar(TForm(FOwner).HelpFile)\r\n else\r\n Result := PChar(FHelpFile);\r\nend;\r\n\r\nfunction TJvWinHelp.GetOwnerHandle: THandle;\r\nbegin\r\n Result := 0;\r\n if (FOwner is TWinControl) and not (csDestroying in TWinControl(FOwner).ComponentState) then\r\n Result := TWinControl(FOwner).Handle\r\n else\r\n if Application <> nil then\r\n begin\r\n if (Screen <> nil) and (Screen.ActiveForm <> nil) then\r\n Result := Screen.ActiveForm.Handle\r\n else\r\n if Application.MainForm <> nil then\r\n Result := Application.MainForm.Handle\r\n else\r\n if not (csDestroying in Application.ComponentState) then\r\n Result := Application.Handle;\r\n end;\r\nend;\r\n\r\nfunction TJvWinHelp.SetWindowPos(Left, Top, Width, Height, Visibility: Integer): Boolean;\r\nvar\r\n HelpInfo: HELPWININFO;\r\nbegin\r\n HelpInfo.wStructSize := SizeOf(HELPWININFO);\r\n HelpInfo.x := Left;\r\n HelpInfo.y := Top;\r\n HelpInfo.dx := Width;\r\n HelpInfo.dy := Height;\r\n HelpInfo.wMax := Visibility;\r\n Result := WinHelp(GetOwnerHandle, GetHelpFile, HELP_SETWINPOS, LPARAM(@HelpInfo));\r\nend;\r\n\r\nfunction TJvWinHelp.ShowContents: Boolean;\r\nbegin\r\n Result := WinHelp(GetOwnerHandle, GetHelpFile, HELP_CONTENTS, 0);\r\nend;\r\n\r\nfunction TJvWinHelp.ShowContextualHelp(Control: TWinControl): Boolean;\r\nbegin\r\n Result := WinHelp(GetOwnerHandle, GetHelpFile, HELP_CONTEXTPOPUP, Control.HelpContext);\r\nend;\r\n\r\nfunction TJvWinHelp.ShowHelp(Control: TWinControl): Boolean;\r\nbegin\r\n Result := WinHelp(GetOwnerHandle, GetHelpFile, HELP_CONTEXT, Control.HelpContext);\r\nend;\r\n\r\nfunction TJvWinHelp.ShowHelpOnHelp: Boolean;\r\nbegin\r\n Result := WinHelp(GetOwnerHandle, GetHelpFile, HELP_HELPONHELP, 0);\r\nend;\r\n\r\nfunction TJvWinHelp.ShowIndex: Boolean;\r\nbegin\r\n Result := WinHelp(GetOwnerHandle, GetHelpFile, HELP_INDEX, 0);\r\nend;\r\n\r\nfunction TJvWinHelp.ShowKeyword(Keyword: string): Boolean;\r\nbegin\r\n Result := WinHelp(GetOwnerHandle, GetHelpFile, HELP_KEY, LPARAM(PChar(Keyword)));\r\nend;\r\n\r\nfunction TJvWinHelp.ShowPartialKeyWord(Keyword: string): Boolean;\r\nbegin\r\n Result := WinHelp(GetOwnerHandle, GetHelpFile, HELP_PARTIALKEY, LPARAM(PChar(Keyword)));\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvWinampLabel.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvWinampLabel.PAS, released on 2001-02-28.\r\n\r\nThe Initial Developer of the Original Code is Sbastien Buysse [sbuysse att buypin dott com]\r\nPortions created by Sbastien Buysse are Copyright (C) 2001 Sbastien Buysse.\r\nAll Rights Reserved.\r\n\r\nContributor(s): Michael Beck [mbeck att bigfoot dott com].\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvWinampLabel.pas 13104 2011-09-07 06:50:43Z obones $\r\n\r\nunit JvWinampLabel;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n SysUtils, Classes, Windows, Messages, Graphics, Controls, StdCtrls,\r\n JvExStdCtrls, JvThread;\r\n\r\ntype\r\n TJvWinampThread = class(TJvPausableThread)\r\n protected\r\n procedure Draw;\r\n procedure Execute; override;\r\n public\r\n FDelay: Cardinal;\r\n FOnDraw: TNotifyEvent;\r\n end;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvWinampLabel = class(TJvExCustomLabel)\r\n private\r\n FBitmap: TBitmap;\r\n FPicture: TPicture;\r\n FTimer: TJvWinampThread;\r\n FScrollInterval: Cardinal;\r\n FActive: Boolean;\r\n FStretch: Boolean;\r\n FScrollTextBy: Integer;\r\n FCurPos: Integer;\r\n FWait: Integer;\r\n FWaiting: Boolean;\r\n FScale: Real;\r\n // (p3) renamed\r\n FText: TCaption;\r\n FCharHeight: Integer;\r\n FCharWidth: Integer;\r\n function GetScrollTextBy: Integer;\r\n procedure SetActive(Value: Boolean);\r\n procedure SetStretch(Value: Boolean);\r\n procedure SetInterval(Value: Cardinal);\r\n procedure SetPicture(Value: TPicture);\r\n procedure FillBitmap;\r\n procedure Activate;\r\n procedure Deactivate;\r\n procedure UpdatePos;\r\n procedure DoOnTimer(Sender: TObject);\r\n function GetCol(Ch: Char): Word;\r\n function GetRow(Ch: Char): Word;\r\n procedure SetText(const Value: TCaption);\r\n protected\r\n procedure ColorChanged; override;\r\n procedure Paint; override;\r\n // (rom) made protected property\r\n property CharHeight: Integer read FCharHeight;\r\n property CharWidth: Integer read FCharWidth;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n published\r\n property Active: Boolean read FActive write SetActive;\r\n property Stretch: Boolean read FStretch write SetStretch;\r\n property ScrollTextBy: Integer read GetScrollTextBy write FScrollTextBy;\r\n property ScrollInterval: Cardinal read FScrollInterval write SetInterval;\r\n property WaitOnEnd: Integer read FWait write FWait;\r\n property Skin: TPicture read FPicture write SetPicture;\r\n property Color;\r\n property Text: TCaption read FText write SetText;\r\n property Align;\r\n property Alignment;\r\n property FocusControl;\r\n property DragCursor;\r\n property DragMode;\r\n property ParentColor;\r\n property ShowHint;\r\n property ParentShowHint;\r\n property Layout;\r\n property Left;\r\n property Transparent;\r\n property PopupMenu;\r\n property Visible;\r\n property Top;\r\n property Height;\r\n property Width;\r\n property Cursor;\r\n property Enabled;\r\n property Hint;\r\n property OnClick;\r\n property OnDblClick;\r\n property OnDragDrop;\r\n property OnDragOver;\r\n property OnEndDrag;\r\n property OnMouseMove;\r\n property OnMouseDown;\r\n property OnMouseUp;\r\n property OnStartDrag;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvWinampLabel.pas $';\r\n Revision: '$Revision: 13104 $';\r\n Date: '$Date: 2011-09-07 08:50:43 +0200 (mer. 07 sept. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n JvTypes, JvResources;\r\n\r\n{$R JvWinampLabel.res}\r\n\r\nconst\r\n // (p3) fixed as suggested by Remko Bonte\r\n Row1: string = 'ABCDEFGHIJKLMNOPQRSTUVWXYZ\"@ ';\r\n Row2: string = '0123456789._:()-''!_+\\/[]^&%.=$#';\r\n Row3: string = '?* ';\r\n\r\n//=== { TJvWinampThread } ====================================================\r\n\r\nprocedure TJvWinampThread.Draw;\r\nbegin\r\n if Assigned(FOnDraw) then\r\n FOnDraw(Self);\r\nend;\r\n\r\nprocedure TJvWinampThread.Execute;\r\nbegin\r\n NameThread(ThreadName);\r\n // (rom) secure thread against exceptions\r\n try\r\n while not Terminated do\r\n begin\r\n EnterUnpauseableSection;\r\n try\r\n if Terminated then\r\n Exit;\r\n\r\n Synchronize(Draw);\r\n finally\r\n LeaveUnpauseableSection;\r\n end;\r\n Sleep(FDelay);\r\n end;\r\n except\r\n end;\r\nend;\r\n\r\n//=== { TJvWinampLabel } =====================================================\r\n\r\nconstructor TJvWinampLabel.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n AutoSize := False;\r\n FScrollInterval := 100;\r\n FCharWidth := 5;\r\n FCharHeight := 6;\r\n FPicture := TPicture.Create;\r\n FPicture.Bitmap.LoadFromResourceName(HInstance, 'JvWinampLabelPICTURE');\r\n FBitmap := TBitmap.Create;\r\n with FBitmap do\r\n begin\r\n PixelFormat := pf24bit;\r\n Width := 10;\r\n Height := 10;\r\n end;\r\n FTimer := TJvWinampThread.Create(True);\r\n with FTimer do\r\n begin\r\n FreeOnTerminate := False;\r\n FDelay := FScrollInterval;\r\n FOnDraw := DoOnTimer;\r\n end;\r\n Width := 100;\r\n Height := CharHeight * 2;\r\n FActive := False;\r\n Activate;\r\n FStretch := True;\r\n FScrollTextBy := 2;\r\n FWait := 1000;\r\n Color := clBlack;\r\nend;\r\n\r\ndestructor TJvWinampLabel.Destroy;\r\nbegin\r\n FTimer.Free;\r\n FBitmap.Free;\r\n FPicture.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJvWinampLabel.GetScrollTextBy: Integer;\r\nbegin\r\n Result := Abs(FScrollTextBy);\r\nend;\r\n\r\nprocedure TJvWinampLabel.SetPicture(Value: TPicture);\r\nbegin\r\n FPicture.Assign(Value);\r\n if (FPicture.Bitmap.Width <> 155) or (FPicture.Bitmap.Height <> 18) then\r\n raise EJVCLException.CreateRes(@RsEInvalidSkin);\r\n FText := '';\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvWinampLabel.SetActive(Value: Boolean);\r\nbegin\r\n if Value <> FActive then\r\n begin\r\n FActive := Value;\r\n if FActive then\r\n Activate\r\n else\r\n Deactivate;\r\n FWaiting := False;\r\n end;\r\nend;\r\n\r\nprocedure TJvWinampLabel.SetStretch(Value: Boolean);\r\nvar\r\n Rec: TRect;\r\nbegin\r\n if Value <> FStretch then\r\n begin\r\n FStretch := Value;\r\n Rec.Top := 0;\r\n Rec.Left := 0;\r\n Rec.Bottom := Height;\r\n Rec.Right := Width;\r\n Canvas.Brush.Color := Color;\r\n Canvas.Brush.Style := bsSolid;\r\n Canvas.FillRect(Rec);\r\n Repaint;\r\n end;\r\n if not FStretch then\r\n FScale := 1;\r\nend;\r\n\r\nprocedure TJvWinampLabel.SetInterval(Value: Cardinal);\r\nbegin\r\n if Value <> FScrollInterval then\r\n begin\r\n FScrollInterval := Value;\r\n FTimer.FDelay := Value;\r\n end;\r\nend;\r\n\r\nprocedure TJvWinampLabel.Activate;\r\nbegin\r\n FActive := True;\r\n if not (csDesigning in ComponentState) then\r\n FTimer.Paused := False;\r\n FTimer.FDelay := FScrollInterval;\r\n FWaiting := False;\r\n\r\n FCurPos := 0;\r\n FScrollTextBy := Abs(FScrollTextBy);\r\n FillBitmap;\r\nend;\r\n\r\nprocedure TJvWinampLabel.Deactivate;\r\nbegin\r\n if not (csDesigning in ComponentState) then\r\n FTimer.Paused := True;\r\n FActive := False;\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvWinampLabel.DoOnTimer(Sender: TObject);\r\nbegin\r\n // Must exit because we are \"Synchronized\" and our parent is already\r\n // partly destroyed. If we did not exit, we would get an AV.\r\n if csDestroying in ComponentState then\r\n Exit;\r\n\r\n if FWaiting then\r\n begin\r\n FTimer.FDelay := FScrollInterval;\r\n FWaiting := False;\r\n end;\r\n UpdatePos;\r\n Repaint;\r\nend;\r\n\r\n\r\n\r\n\r\nfunction TJvWinampLabel.GetCol(Ch: Char): Word;\r\n\r\n\r\nvar\r\n Index: Integer;\r\nbegin\r\n Ch := UpCase(Ch);\r\n Index := Pos(Ch, Row1);\r\n // (p3) Pos returns 0 on failure, not -1\r\n if Index = 0 then\r\n Index := Pos(Ch, Row2);\r\n if Index = 0 then\r\n Index := Pos(Ch, Row3);\r\n if Index = 0 then\r\n Result := GetCol(' ')\r\n else\r\n // (p3) fixed as suggested by Remko Bonte\r\n Result := (Index - 1) * CharWidth;\r\nend;\r\n\r\n\r\nfunction TJvWinampLabel.GetRow(Ch: Char): Word;\r\n\r\n\r\nbegin\r\n Ch := UpCase(Ch);\r\n Result := 0;\r\n if Pos(Ch, Row2) <> 0 then\r\n Result := CharHeight\r\n else\r\n if Pos(Ch, Row3) <> 0 then\r\n Result := 2 * CharHeight;\r\nend;\r\n\r\nprocedure TJvWinampLabel.FillBitmap;\r\nvar\r\n Rec, SourceRect, DestRect: TRect;\r\n T: Word;\r\nbegin\r\n try\r\n with FBitmap do\r\n begin\r\n TransparentMode := tmAuto;\r\n if Text <> '' then\r\n Width := Length(Text) * CharWidth\r\n else\r\n Width := Self.Width;\r\n Height := CharHeight;\r\n if Width < Self.Width then\r\n Width := Self.Width;\r\n Rec.Top := 0;\r\n Rec.Left := 0;\r\n Rec.Bottom := Height;\r\n Rec.Right := Width;\r\n Canvas.Brush.Color := Color;\r\n Canvas.Brush.Style := bsSolid;\r\n Canvas.FillRect(Rec);\r\n if Self.Text <> '' then\r\n for T := 0 to Length(Text) - 1 do\r\n begin\r\n // (p3) fixed as suggested by Remko Bonte\r\n SourceRect := Bounds(GetCol(Text[T + 1]),\r\n GetRow(Text[T + 1]), CharWidth, CharHeight);\r\n DestRect := Bounds(T * CharWidth, 0, CharWidth, CharHeight);\r\n Canvas.CopyRect(DestRect, FPicture.Bitmap.Canvas, SourceRect);\r\n end;\r\n end;\r\n except\r\n end;\r\nend;\r\n\r\nprocedure TJvWinampLabel.UpdatePos;\r\nbegin\r\n try\r\n if (Length(Text) * CharWidth) * FScale > Width then\r\n begin\r\n FCurPos := FCurPos + FScrollTextBy;\r\n if FCurPos <= 0 then\r\n begin\r\n FScrollTextBy := Abs(FScrollTextBy);\r\n if FWait <> 0 then\r\n begin\r\n FWaiting := True;\r\n FTimer.FDelay := FWait;\r\n end;\r\n end;\r\n if (Length(Text) * CharWidth - (FCurPos)) <= (Width / FScale) then\r\n begin\r\n FScrollTextBy := Abs(FScrollTextBy) * -1;\r\n if FWait <> 0 then\r\n begin\r\n FWaiting := True;\r\n FTimer.FDelay := FWait;\r\n end;\r\n end;\r\n end\r\n else\r\n FCurPos := 0;\r\n except\r\n end;\r\nend;\r\n\r\nprocedure TJvWinampLabel.Paint;\r\nvar\r\n Rec: TRect;\r\nbegin\r\n try\r\n if not FStretch then\r\n begin\r\n Rec := ClientRect;\r\n Rec.Top := Rec.Top + CharHeight;\r\n Canvas.FillRect(Rec);\r\n if FActive then\r\n BitBlt(Canvas.Handle, 0, 0, Width, CharHeight, FBitmap.Canvas.Handle, FCurPos, 0, SRCCOPY)\r\n else\r\n begin\r\n Rec := ClientRect;\r\n Rec.Bottom := Rec.Bottom + CharHeight;\r\n Rec.Left := Rec.Left + (CharWidth * Length(Text));\r\n Canvas.FillRect(Rec);\r\n BitBlt(Canvas.Handle, 0, 0, Width, CharHeight, FBitmap.Canvas.Handle, 0, 0, SRCCOPY);\r\n end;\r\n end\r\n else\r\n begin\r\n FScale := Height / CharHeight;\r\n if FActive then\r\n StretchBlt(Canvas.Handle, 0, 0, Width, Height, FBitmap.Canvas.Handle, FCurPos, 0, Round(Width / FScale),\r\n CharHeight, SRCCOPY)\r\n else\r\n StretchBlt(Canvas.Handle, 0, 0, Width, Height, FBitmap.Canvas.Handle, 0, 0, Round(Width / FScale), CharHeight,\r\n SRCCOPY);\r\n end;\r\n except\r\n end;\r\nend;\r\n\r\n\r\n\r\nprocedure TJvWinampLabel.SetText(const Value: TCaption);\r\nvar\r\n Rec: TRect;\r\nbegin\r\n if Value <> FText then\r\n begin\r\n FText := Value;\r\n FillBitmap;\r\n Rec.Top := 0;\r\n Rec.Left := 0;\r\n Rec.Bottom := Height;\r\n Rec.Right := Width;\r\n Canvas.Brush.Color := Color;\r\n Canvas.Brush.Style := bsSolid;\r\n Canvas.FillRect(Rec);\r\n FCurPos := 0;\r\n FScrollTextBy := Abs(FScrollTextBy);\r\n end;\r\nend;\r\n\r\nprocedure TJvWinampLabel.ColorChanged;\r\nbegin\r\n FText := '';\r\n inherited ColorChanged;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvWizard.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvWizard.PAS, released on 2001-12-30.\r\n\r\nThe Initial Developer of the Original Code is William Yu Wei.\r\nPortions created by William Yu Wei are Copyright (C) 2001 William Yu Wei.\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\nPeter Thrnqvist - converted to JVCL naming conventions on 2003-07-11\r\nAndreas Hausladen - fixed some bugs, refactoring of the Wizard button classes on 2004-02-29\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvWizard.pas 13139 2011-10-28 19:59:40Z jfudickar $\r\n\r\n{+---------------------------------------------------------------------------+\r\n | CONTRIBUTORS: |\r\n +---------------------------------------------------------------------------+\r\n | Steve Forbes |\r\n | Chris Macksey |\r\n | Wayne Niddery |\r\n | Raymond J. Schappe |\r\n | Theodore |\r\n | Max Evans |\r\n +---------------------------------------------------------------------------+\r\n | HISTORY COMMENTS |\r\n +---------------------------------------------------------------------------+\r\n | 02/18/2002 OnStartButtonClick, OnLastButtonClick, OnNextButtonClick, |\r\n | OnBackButtonClick, OnFinishButtonClick, OnCancelButtonClick, |\r\n | is added for TJvWizardCustomPage with a Stop parameter. |\r\n | |\r\n | Note: these page click events is called before the wizard |\r\n | button click events. |\r\n | |\r\n | 02/16/2002 Suggested by : |\r\n | 1) ModalResult property is added for TJvWizardButton |\r\n | 2) Width property is added for TJvWizardButton |\r\n | |\r\n | 02/12/2002 1) Suggested by : |\r\n | Having the next/finish buttons to be the default |\r\n | button when a page shows. |\r\n | 2) Having the cancel button to be the default cancel button. |\r\n | |\r\n | 02/11/2002 1) CanDisplay function is added for TJvWizardRouteMapControl.|\r\n | 2) OnDisplaying event is added for TJvWizardRouteMapControl, |\r\n | so the route map can decide if it could display the page |\r\n | item or not. |\r\n | |\r\n | 02/10/2002 1) Introduce TJvWizardImage class. |\r\n | 2) Clean up the code (TJvWizardGraphicObject, |\r\n | TJvWizardPageObject, ..., etc) |\r\n | 3) Now the TJvWizardPageTitle is inherited from |\r\n | TJvWizardGraphicObject(known as TJvWizardPersistent |\r\n | in former). |\r\n | 4) Suggested by : |\r\n | Controls in the wizard page with aligned set to |\r\n | something should be aligned properly without covering |\r\n | the page header as well as the watermark. Hint: |\r\n | overrided AdjustClientRect method is added for |\r\n | both TJvWizardCustomPage and TJvWizardWelcomePage. |\r\n | |\r\n | 02/09/2002 1) Finish button can be displayed separatly. |\r\n | 2) Bug fixed: Changing the value of EnabledButtons property |\r\n | of TJvWizardCustomPage at run time doesn't refresh the |\r\n | buttons' status on the screen. |\r\n | |\r\n | 02/08/2002 Bug fixed: the OnEnterPage event is not triggled properly, |\r\n | they would be called at the time the wizard is loading |\r\n | them. 'not (csLoading in ComponentState)' added as the |\r\n | part of checking condition in SetActivePage method |\r\n | of TJvWizard. |\r\n | |\r\n | 02/07/2002 VERSION 1.6 RELEASED |\r\n | |\r\n | 1) New property EnabledButtons and VisibleButtons added for |\r\n | TJvWizardCustomPage, so the developers can customize |\r\n | buttons for each page at design time and run time. |\r\n | 2) Remove Enabled and Visible properties from |\r\n | TJvWizardButton of TJvWizard. |\r\n | |\r\n | 02/06/2002 1) Bug fixed: change TJvWizardWelcomePage's color from |\r\n | clWindow to other colors or change |\r\n | TJvWizardInteriorPage's color from other colors to |\r\n | clWindow, the pages won't display in correct color. |\r\n | Hint: |\r\n | By assigning default value of Color property in |\r\n | published section of TJvWizardCustomPage and |\r\n | TJvWizardWelcomePage class. |\r\n | 2) Suggested by : |\r\n | ShowDivider added for TJvWizardPageHeader to enable |\r\n | or disable drawing the page header divider. |\r\n | 3) Use Object.Free instead of FreeAndNil, |\r\n | Rectangle(ARect.Left, ...) instead of Rectangle(ARect), |\r\n | so we can support Delphi 4. |\r\n | |\r\n | 02/05/2002 1) Added by : |\r\n | ButtonHelp added for TJvWizard. |\r\n | 2) RepositionButtons method of TJvWizard is improved. |\r\n | |\r\n | 02/04/2002 function IsForward added, return true if FromPage is |\r\n | forward to ToPage, return false if FromPage is backward |\r\n | to ToPage. |\r\n | |\r\n | 02/03/2002 1) Bug fixed by : SelectPriorPage calls |\r\n | OnSelectFirstPage event rather the OnSelectPriorPage. |\r\n | 2) Suggested by : |\r\n | FromPage parameters added for OnEnterPage event, |\r\n | so the developers can detect from where it enters. |\r\n | 3) Suggested by : |\r\n | ToPage paramters added for OnExitPage event, so the |\r\n | developers can detect to where it exits. |\r\n | 4) Suggested by : |\r\n | OnExitPage event now is called just BEFORE (not after) |\r\n | the page is hidden and BEFORE the new page is actived. |\r\n | It provides the last chance to the developers to stop |\r\n | changing to the new page by raising a message. |\r\n | |\r\n | 02/02/2002 VERSION 1.5 RELEASED |\r\n | |\r\n | 1) DoAddPage, DoDeletePage, DoUpdatePage, DoMovePage added |\r\n | for TJvWizardRouteMapControl |\r\n | 2) Overrided SetParent added for TJvWizardRouteMapControl |\r\n | to detect if the parent is TJvWizard or its descentants.|\r\n | 01/31/2002 1) Improved the RepositionButtons method of TJvWizard, |\r\n | so all the buttons can be positioned properly regardless |\r\n | how their neighbors are. |\r\n | 2) CM_VisibleChanged message handler added for |\r\n | TJvWizardButtonControl, so when the button is visible or |\r\n | invisible, it can make the rest buttons in proper |\r\n | position. |\r\n | |\r\n | 01/30/2002 1) Rename the methods of TJvWizardRouteMapControl |\r\n | 2) WizardPageMoved method added for TJvWizardRouteMapControl |\r\n | which fired after the order of the page changed. |\r\n | 3) OnPaintPage event added for TJvWizardCustomPage, so |\r\n | the developers can custom draw the page. |\r\n | 4) A TJvWizardCustomPage parameter added for IsFirstPage, |\r\n | IsLastPage of TJvWizard to test if the specific page is |\r\n | the first page or the last page. |\r\n | 5) Buttons property added for TJvWizardCustomPage, it can |\r\n | easily access all navigation buttons of TJvWizard. |\r\n | 6) Improved the process to handle the button visible |\r\n | property in more efficent way. |\r\n | see UpdateButtonsStatus method of TJvWizard |\r\n | |\r\n | 01/29/2002 1) Pages property added for TJvWizard. |\r\n | 2) PageCount property added for TJvWizard. |\r\n | 3) Page List Property Editor added for Pages property |\r\n | of TJvWizard. From this property editor, we can |\r\n | |\r\n | a) Add new wizard pages. |\r\n | b) Remove selected pages. |\r\n | c) Drag drop selected page item to change pages' order. |\r\n | |\r\n | 01/28/2002 1) Bug fixed: if the current active page set to disabled, |\r\n | the wizard would not go to next page. |\r\n | 2) Page screen flicker problem solved by setting |\r\n | the DoubleBuffered property of TJvWizardCustomPage |\r\n | to True. |\r\n | 3) ParentFont property added for TJvWizardPageHeader. |\r\n | |\r\n | 01/27/2002 VERSION 1.5 BETA RELEASED |\r\n | |\r\n | 1) JvWizard About form added by |\r\n | Thanks for his great job !!!! |\r\n | 2) Improve the design time button function, press Back |\r\n | button at first page will forward to the last page. |\r\n | While press Next button at last page will forward to |\r\n | the first page. (See FindNextPage method in TJvWizard) |\r\n | 3) Fixed AV when delete only one page in the wizard at |\r\n | design time. (see RemovePage method in TJvWizard) |\r\n | 4) NumGlyphs property added for TJvWizardNavigateButton by |\r\n | , to solve the problem where the |\r\n | NumGlyphs property of the actual button always reset |\r\n | to 1 when it is created dynamically. |\r\n | 5) Layout property added for TJvWizardNavigateButton. |\r\n | 6) Set ImageAlign property's default value of |\r\n | TJvWizardPageHeader to waRight. |\r\n | |\r\n | 01/26/2002 1) Suggested by : |\r\n | Anchors, AnchorPlacement, Indent property added for |\r\n | the text in TJvWizardPageTitle. Remove Left, Top, |\r\n | Width, Height properties from TJvWizardPageTitle. so |\r\n | it is much easiler to operate the title and subtitle. |\r\n | 2) Image property added for TJvWizardCustomPage, |\r\n | both Welcome page and Interior page can display a |\r\n | background image. |\r\n | 3) Image property added for the TJvWizardWaterMark. |\r\n | 4) ImageIndex, ImageAlign, ImageOffset property added for |\r\n | TJvWizardPageHeader. the PageHeader use ImageIndex |\r\n | to retreive image from the header image list of |\r\n | TJvWizard. |\r\n | |\r\n | 01/25/2002 VERSION 1.2 RELEASED |\r\n | |\r\n | Finally, JvWizard has its offical icon!!! It is very cool! |\r\n | Thanks for his great job !!!! |\r\n | |\r\n | 1) Move OnEnterPage, OnPage, OnExitPage event from TJvWizard |\r\n | into TJvWizardCustomPage. |\r\n | 2) TJvWizardPagePanel added, suggested by . |\r\n | 3) Glyph property added for TJvWizardNavigateButton. |\r\n | 4) HeaderImages property added for TJvWizard, it is an |\r\n | image list, which stores all the page header images. |\r\n | |\r\n | 01/24/2002 1) Rename TJvWizardTitle to TJvWizardPageTitle. |\r\n | 2) PaintTo method added for TJvWizardWaterMark. |\r\n | PaintTo method added for TJvWizardPageHeader. |\r\n | PainTo method added for TJvWizardPageTitle. |\r\n | 3) Remove the DisplayPageHeader method from |\r\n | TJvWizardCustomPage. |\r\n | 4) OnPage event added for TJvWizard, fired after the page |\r\n | shows up. |\r\n | 5) Pages, PageCount, PageIndex property, and default code |\r\n | added for all virtual method for TJvWizardRouteMapControl.|\r\n | 6) Compiler directive added, suggested |\r\n | by . |\r\n | 7) Handle Design time package and Run time package, |\r\n | package file name convenstion suggested by |\r\n | : |\r\n | Design time package: JvWizardD?.dpk (bpl, dcp, ...) |\r\n | Run time package: JvWizardD?R.dbp (bpl, dcp, ...) |\r\n | here the ? = Delphi Version (5, 6, ..., etc) |\r\n | |\r\n | 01/23/2002 1) Start Page, Last Page buttons added for TJvWizard, |\r\n | default they are invisible. |\r\n | 2) Visible property added for TJvWizardNavigateButton. |\r\n | |\r\n | 01/22/2002 BorderWidth property added for TJvWizardWaterMark, suggested |\r\n | by |\r\n | |\r\n | 1) Remove the TJvWizardButtonBar, now all the navigate |\r\n | buttons are located in the Wizard. Hint: |\r\n | Add overrided AdjustClientRect for TJvWizard. |\r\n | 2) Bug fixed: Add csAcceptsControls control style into |\r\n | TJvWizard, otherwise it won't accept other controls |\r\n | like JvWizardRouteMap. |\r\n | 3) Bug fixed: TJvWizard.GetChildren procedure, it won't |\r\n | display another controls (include JvWizardRouteMap |\r\n | Control) even if the control is in the wizard. |\r\n | 4) Align property added for TJvWizardRouteMap, so the |\r\n | JvWizardRouteMap can display at either left or right |\r\n | side of the Wizard. |\r\n | 5) Align property added for TKWaterMark, so it can be |\r\n | displayed at either left or right side of Welcome Page. |\r\n | |\r\n | 01/21/2002 VERSION 1.1 RELEASED |\r\n | |\r\n | Suggested by : |\r\n | |\r\n | 1) Add OnSelectNextPage, OnSelectPriorPage, |\r\n | OnSelectFirstPage, OnSelectLastPage events, so user can |\r\n | redirect the page try to go to. |\r\n | 2) Add OnEnterPage, triggled before the page shows up. |\r\n | Add OnExitPage, triggled after the page is hidded. |\r\n | |\r\n | 01/14/2002 1) Add ShowRouteMap property for the TJvWizard. |\r\n | 2) Add destructor in the TJvWizardRouteMap class to fix |\r\n | AV when browse pages after destroy the TJvWizardRouteMap |\r\n | component. |\r\n | |\r\n | 01/13/2002 Make the TJvWizardRouteMap as a separat new component |\r\n | so the user can design its own routemap and communicate |\r\n | with TJvWizard smoothly. |\r\n | |\r\n | 01/12/2002 VERSION 1.0 RELEASED |\r\n | |\r\n | 1) Fixed by : |\r\n | Under certain circumstance, the Wizard did not always |\r\n | default to the first page. Add overrided |\r\n | Loaded method in the TJvWizard class. |\r\n | 2) Restructure: add TJvWizardHeader and TJvWizardWaterMark, |\r\n | I hate to list all properites like: HeaderColor, |\r\n | HeaderWidth, HeaderVisible, ... etc. Instead, I group |\r\n | them together into particular class, and it can make |\r\n | the whole component has a very clean property |\r\n | structure. |\r\n | |\r\n | 01/11/2002 1) Add word break feature when display title and subtitle. |\r\n | 2) At Design time, display page name in the wizard page. |\r\n | 3) Let the TWizardCustomPage paint and fill its area first |\r\n | and let TWizardWelcomePage and TWizardInteriorPage |\r\n | do the rest. |\r\n | |\r\n | 01/10/2002 BETA VERSION RELEASED |\r\n | |\r\n | 1) Delete BackButton, NextButton, FinishButton, |\r\n | CancelButton property, instead of a Button array. |\r\n | 2) Introduce TJvWizardBackButton, TJvWizardNextButton, |\r\n | TJvWizardFinishButton and TJvWizardCancelButton Control |\r\n | 3) Add TJvWizardTitle class, HeaderColor, HeaderHeight, |\r\n | HeaderVisible property for TJvWizardCustomPage. |\r\n | 4) Add WaterMarkColor, WaterMarkWidth, WaterMarkVisible |\r\n | property for TJvWizardWelcomePage. |\r\n | 5) Paint method of TJvWizardWelcomPage improved, |\r\n | TJvWizardInteriorPage, so they can display header |\r\n | as well as title and subtitle. |\r\n | |\r\n | 01/06/2002 1) Add TJvWizardRouteMap, Improve all existing functions |\r\n | and class. |\r\n | 2) Add TJvWizardCustomPage. |\r\n | |\r\n | 01/05/2002 1) Add TJvWizardNavigateButton class. |\r\n | 2) Add BackButton, NextButton, FinishButton, |\r\n | CancelButton property for TJvWizard. |\r\n | |\r\n | 01/04/2002 1) Add ShowDivider property for TJvWizard. |\r\n | 2) Add GetButtonClick, SetButtonClick for TJvWizardButtonBar.|\r\n | 3) Draw divider in fsGroove frame style. |\r\n | |\r\n | 12/30/2001 Initial create. |\r\n +---------------------------------------------------------------------------+\r\n | TODO LIST |\r\n +---------------------------------------------------------------------------+\r\n | Wizard page can be transparent |\r\n +---------------------------------------------------------------------------+}\r\n\r\nunit JvWizard;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n SysUtils, Classes,\r\n Windows, Messages, Controls, Forms, Graphics, Buttons, ImgList, Types,\r\n JvComponent, JvThemes, JvWizardCommon;\r\n\r\ntype\r\n TJvWizardButtonKind = (bkStart, bkLast, bkBack, bkNext, bkFinish, bkCancel, bkHelp);\r\n TJvWizardButtonSet = set of TJvWizardButtonKind;\r\n\r\nconst\r\n bkAllButtons = [bkStart, bkLast, bkBack, bkFinish, bkNext, bkCancel, bkHelp];\r\n\r\ntype\r\n TJvWizardAlign = alTop..alRight;\r\n TJvWizardLeftRight = alLeft..alRight;\r\n TJvWizardImage = class;\r\n TJvWizardCustomPage = class;\r\n TJvWizard = class;\r\n TJvWizardPageHeader = class;\r\n\r\n TJvWizardButtonControl = class(TBitBtn)\r\n private\r\n FWizard: TJvWizard;\r\n FAlignment: TJvWizardLeftRight;\r\n procedure CMVisibleChanged(var Msg: TMessage); message CM_VISIBLECHANGED;\r\n procedure CMDesignHitTest(var Msg: TCMDesignHitTest); message CM_DESIGNHITTEST;\r\n protected\r\n property Wizard: TJvWizard read FWizard write FWizard;\r\n property Alignment: TJvWizardLeftRight read FAlignment write FAlignment;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n end;\r\n\r\n TJvWizardButtonControlClass = class of TJvWizardButtonControl;\r\n\r\n { The wrapper of the TJvWizardButtonControl }\r\n TJvWizardNavigateButton = class(TPersistent)\r\n private\r\n FControl: TJvWizardButtonControl;\r\n procedure SetCaption(const Value: string);\r\n function GetCaption: string;\r\n function GetGlyph: TBitmap;\r\n procedure SetGlyph(const Value: TBitmap);\r\n function GetNumGlyphs: Integer;\r\n procedure SetNumGlyphs(const Value: Integer);\r\n function GetLayout: TButtonLayout;\r\n procedure SetLayout(const Value: TButtonLayout);\r\n function GetModalResult: TModalResult;\r\n procedure SetModalResult(const Value: TModalResult);\r\n function GetButtonWidth: Integer;\r\n procedure SetButtonWidth(const Value: Integer);\r\n protected\r\n property Control: TJvWizardButtonControl read FControl write FControl;\r\n published\r\n property Glyph: TBitmap read GetGlyph write SetGlyph;\r\n property Caption: string read GetCaption write SetCaption;\r\n property NumGlyphs: Integer read GetNumGlyphs write SetNumGlyphs;\r\n property Layout: TButtonLayout read GetLayout write SetLayout default blGlyphLeft;\r\n property ModalResult: TModalResult read GetModalResult write SetModalResult default mrNone;\r\n property Width: Integer read GetButtonWidth write SetButtonWidth;\r\n end;\r\n\r\n TJvWizardRouteMapDisplayEvent = procedure(Sender: TObject;\r\n const Page: TJvWizardCustomPage; var AllowDisplay: Boolean) of object;\r\n\r\n { TJvWizardRouteMap base class }\r\n TJvWizardRouteMapControl = class(TCustomControl)\r\n private\r\n FWizard: TJvWizard;\r\n FAlign: TJvWizardAlign;\r\n FPages: TList;\r\n FPageIndex: Integer;\r\n FImage: TJvWizardImage;\r\n FOnDisplaying: TJvWizardRouteMapDisplayEvent;\r\n function GetPage(Index: Integer): TJvWizardCustomPage;\r\n function GetPageCount: Integer;\r\n procedure SetAlign(Value: TJvWizardAlign);\r\n procedure SetPageIndex(Value: Integer);\r\n procedure SetImage(const Value: TJvWizardImage);\r\n procedure CMDesignHitTest(var Msg: TCMDesignHitTest); message CM_DESIGNHITTEST;\r\n procedure DoAddPage(const APage: TJvWizardCustomPage);\r\n procedure DoDeletePage(const APage: TJvWizardCustomPage);\r\n procedure DoUpdatePage(const APage: TJvWizardCustomPage);\r\n procedure DoActivatePage(const APage: TJvWizardCustomPage);\r\n procedure DoMovePage(const APage: TJvWizardCustomPage; const OldIndex: Integer);\r\n procedure DoImageChange(Sender: TObject);\r\n protected\r\n function HasPicture: Boolean;\r\n procedure SetParent(AParent: TWinControl); override;\r\n procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;\r\n function PageAtPos(Pt: TPoint): TJvWizardCustomPage; virtual;\r\n procedure WizardPageAdded(const APage: TJvWizardCustomPage); virtual;\r\n procedure WizardPageDeleted(const APage: TJvWizardCustomPage); virtual;\r\n procedure WizardPageUpdated(const APage: TJvWizardCustomPage); virtual;\r\n procedure WizardPageActivated(const APage: TJvWizardCustomPage); virtual;\r\n procedure WizardPageMoved(const APage: TJvWizardCustomPage; const OldIndex: Integer); virtual;\r\n function CanDisplay(const APage: TJvWizardCustomPage): Boolean; virtual;\r\n property Wizard: TJvWizard read FWizard write FWizard;\r\n property Align: TJvWizardAlign read FAlign write SetAlign default alLeft;\r\n property Image: TJvWizardImage read FImage write SetImage;\r\n property OnDisplaying: TJvWizardRouteMapDisplayEvent read FOnDisplaying write FOnDisplaying;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n property Pages[Index: Integer]: TJvWizardCustomPage read GetPage;\r\n property PageCount: Integer read GetPageCount;\r\n property PageIndex: Integer read FPageIndex write SetPageIndex;\r\n published\r\n property Enabled;\r\n property Visible;\r\n end;\r\n\r\n TJvWizardImage = class(TPersistent)\r\n private\r\n FPicture: TPicture;\r\n FAlignment: TJvWizardImageAlignment;\r\n FLayout: TJvWizardImageLayout;\r\n FOnChange: TNotifyEvent;\r\n FTransparent: Boolean;\r\n procedure SetPicture(Value: TPicture);\r\n procedure SetAlignment(Value: TJvWizardImageAlignment);\r\n procedure SetLayout(Value: TJvWizardImageLayout);\r\n function GetTransparent: Boolean;\r\n procedure SetTransparent(Value: Boolean);\r\n procedure DoChange;\r\n procedure DoPictureChange(Sender: TObject);\r\n public\r\n constructor Create;\r\n destructor Destroy; override;\r\n procedure PaintTo(const ACanvas: TCanvas; ARect: TRect);\r\n property OnChange: TNotifyEvent read FOnChange write FOnChange;\r\n published\r\n property Picture: TPicture read FPicture write SetPicture;\r\n property Alignment: TJvWizardImageAlignment read FAlignment write SetAlignment default iaStretch;\r\n property Layout: TJvWizardImageLayout read FLayout write SetLayout default ilStretch;\r\n property Transparent: Boolean read GetTransparent write SetTransparent default False;\r\n end;\r\n\r\n TJvWizardGraphicObject = class(TPersistent)\r\n private\r\n FColor: TColor;\r\n FVisible: Boolean;\r\n procedure SetColor(Value: TColor);\r\n procedure SetVisible(Value: Boolean);\r\n protected\r\n procedure VisibleChanged; virtual;\r\n procedure ColorChanged; virtual;\r\n procedure DoChange; virtual; abstract;\r\n public\r\n constructor Create; virtual;\r\n procedure PaintTo(ACanvas: TCanvas; var ARect: TRect); virtual; abstract;\r\n published\r\n property Color: TColor read FColor write SetColor default clBtnFace;\r\n property Visible: Boolean read FVisible write SetVisible default True;\r\n end;\r\n\r\n { Wizard Page Title class }\r\n TJvWizardPageTitle = class(TJvWizardGraphicObject)\r\n private\r\n FWizardPageHeader: TJvWizardPageHeader;\r\n FText: string;\r\n FAlignment: TAlignment;\r\n FAnchorPlacement: Integer;\r\n FAnchors: TAnchors;\r\n FIndent: Integer;\r\n FFont: TFont;\r\n procedure SetText(const Value: string);\r\n procedure SetAlignment(Value: TAlignment);\r\n procedure SetAnchors(Value: TAnchors);\r\n procedure SetAnchorPlacement(Value: Integer);\r\n procedure SetIndent(Value: Integer);\r\n procedure SetFont(Value: TFont);\r\n procedure SetWizardPageHeader(Value: TJvWizardPageHeader);\r\n procedure AdjustFont(const AFont: TFont);\r\n procedure FontChange(Sender: TObject);\r\n procedure WriteText(Writer: TWriter);\r\n protected\r\n { Get the area where the title text should be painted on. }\r\n function GetTextRect(const ACanvas: TCanvas; const ARect: TRect): TRect; virtual;\r\n procedure DoChange; override;\r\n procedure DefineProperties(Filer: TFiler); override;\r\n property WizardPageHeader: TJvWizardPageHeader read FWizardPageHeader write SetWizardPageHeader;\r\n public\r\n constructor Create; override;\r\n destructor Destroy; override;\r\n procedure Assign(Source: TPersistent); override;\r\n procedure PaintTo(ACanvas: TCanvas; var ARect: TRect); override;\r\n published\r\n property Text: string read FText write SetText;\r\n property Anchors: TAnchors read FAnchors write SetAnchors default [akLeft, akTop];\r\n property AnchorPlacement: Integer read FAnchorPlacement write SetAnchorPlacement default 4;\r\n property Indent: Integer read FIndent write SetIndent default 0;\r\n property Alignment: TAlignment read FAlignment write SetAlignment default taLeftJustify;\r\n property Font: TFont read FFont write SetFont;\r\n end;\r\n\r\n TJvWizardPageObject = class(TJvWizardGraphicObject)\r\n private\r\n FWizardPage: TJvWizardCustomPage;\r\n procedure SetWizardPage(Value: TJvWizardCustomPage);\r\n protected\r\n procedure Initialize; virtual;\r\n procedure DoChange; override;\r\n property WizardPage: TJvWizardCustomPage read FWizardPage write SetWizardPage;\r\n end;\r\n\r\n { Wizard Page Header class }\r\n TJvWizardPageHeader = class(TJvWizardPageObject)\r\n private\r\n FHeight: Integer;\r\n FParentFont: Boolean;\r\n FTitle: TJvWizardPageTitle;\r\n FSubtitle: TJvWizardPageTitle;\r\n FImageIndex: Integer;\r\n FImageOffset: Integer;\r\n FImageAlignment: TJvWizardImageLeftRight;\r\n FShowDivider: Boolean;\r\n procedure SetHeight(Value: Integer);\r\n procedure SetImageIndex(Value: Integer);\r\n procedure SetImageOffset(Value: Integer);\r\n procedure SetImageAlignment(Value: TJvWizardImageLeftRight);\r\n procedure SetParentFont(Value: Boolean);\r\n procedure SetShowDivider(Value: Boolean);\r\n procedure AdjustTitleFont;\r\n procedure SetSubtitle(const Value: TJvWizardPageTitle);\r\n procedure SetTitle(const Value: TJvWizardPageTitle);\r\n protected\r\n procedure VisibleChanged; override;\r\n procedure Initialize; override;\r\n { the return value of ARect is the area where the title should be\r\n painted on. The result of GetImageRect is the image area. }\r\n function GetImageRect(const AImages: TCustomImageList; var ARect: TRect): TRect; virtual;\r\n public\r\n constructor Create; override;\r\n destructor Destroy; override;\r\n procedure PaintTo(ACanvas: TCanvas; var ARect: TRect); override;\r\n published\r\n property ImageIndex: Integer read FImageIndex write SetImageIndex default -1;\r\n property ImageOffset: Integer read FImageOffset write SetImageOffset default 0;\r\n property ImageAlignment: TJvWizardImageLeftRight read FImageAlignment write SetImageAlignment default iaRight;\r\n property Height: Integer read FHeight write SetHeight default 70;\r\n property ParentFont: Boolean read FParentFont write SetParentFont default True;\r\n property Title: TJvWizardPageTitle read FTitle write SetTitle;\r\n property Subtitle: TJvWizardPageTitle read FSubtitle write SetSubtitle;\r\n property ShowDivider: Boolean read FShowDivider write SetShowDivider default True;\r\n property Color default clWindow;\r\n property Visible;\r\n end;\r\n\r\n { Welcome Page's watermark class }\r\n TJvWizardWaterMark = class(TJvWizardPageObject)\r\n private\r\n FAlign: TJvWizardLeftRight;\r\n FWidth: Integer;\r\n FBorderWidth: Integer;\r\n FImage: TJvWizardImage;\r\n procedure SetWidth(Value: Integer);\r\n procedure SetBorderWidth(Value: Integer);\r\n procedure SetAlign(Value: TJvWizardLeftRight);\r\n procedure ImageChanged(Sender: TObject);\r\n protected\r\n procedure VisibleChanged; override;\r\n public\r\n constructor Create; override;\r\n destructor Destroy; override;\r\n procedure PaintTo(ACanvas: TCanvas; var ARect: TRect); override;\r\n published\r\n property Align: TJvWizardLeftRight read FAlign write SetAlign default alLeft;\r\n property BorderWidth: Integer read FBorderWidth write SetBorderWidth default 1;\r\n property Image: TJvWizardImage read FImage write FImage;\r\n property Width: Integer read FWidth write SetWidth default 164;\r\n property Color default clActiveCaption;\r\n property Visible;\r\n end;\r\n\r\n { Wizard Page Panel class used by Wizard Custom Page }\r\n TJvWizardPagePanel = class(TJvWizardPageObject)\r\n private\r\n FBorderWidth: Word;\r\n procedure SetBorderWidth(Value: Word);\r\n public\r\n constructor Create; override;\r\n procedure PaintTo(ACanvas: TCanvas; var ARect: TRect); override;\r\n published\r\n property BorderWidth: Word read FBorderWidth write SetBorderWidth default 7;\r\n property Color default clBtnFace;\r\n property Visible default False;\r\n end;\r\n\r\n TJvWizardPageClickEvent = procedure(Sender: TObject; var Stop: Boolean) of object;\r\n TJvWizardPaintPageEvent = procedure(Sender: TObject; ACanvas: TCanvas; var ARect: TRect) of object;\r\n TJvWizardChangePageEvent = procedure(Sender: TObject; const FromPage: TJvWizardCustomPage) of object;\r\n TJvWizardChangingPageEvent = procedure(Sender: TObject; var ToPage: TJvWizardCustomPage) of object;\r\n\r\n { Wizard Custom Page }\r\n TJvWizardCustomPage = class(TCustomControl)\r\n private\r\n FWizard: TJvWizard;\r\n FHeader: TJvWizardPageHeader;\r\n FPanel: TJvWizardPagePanel;\r\n FImage: TJvWizardImage;\r\n FEnabledButtons: TJvWizardButtonSet;\r\n FVisibleButtons: TJvWizardButtonSet;\r\n FDrawing: Boolean;\r\n FEnableJumpToPage: Boolean;\r\n FOnPaintPage: TJvWizardPaintPageEvent;\r\n FOnEnterPage: TJvWizardChangePageEvent;\r\n FOnPage: TNotifyEvent;\r\n FOnExitPage: TJvWizardChangePageEvent;\r\n FOnStartButtonClick: TJvWizardPageClickEvent;\r\n FOnLastButtonClick: TJvWizardPageClickEvent;\r\n FOnNextButtonClick: TJvWizardPageClickEvent;\r\n FOnBackButtonClick: TJvWizardPageClickEvent;\r\n FOnCancelButtonClick: TJvWizardPageClickEvent;\r\n FOnFinishButtonClick: TJvWizardPageClickEvent;\r\n FOnHelpButtonClick: TJvWizardPageClickEvent;\r\n function GetPageIndex: Integer;\r\n procedure SetPageIndex(const Value: Integer);\r\n procedure SetWizard(AWizard: TJvWizard);\r\n procedure SetEnabledButtons(Value: TJvWizardButtonSet);\r\n procedure SetVisibleButtons(Value: TJvWizardButtonSet);\r\n procedure ImageChanged(Sender: TObject);\r\n procedure WMEraseBkgnd(var Msg: TWMEraseBkgnd); message WM_ERASEBKGND;\r\n procedure CMFontChanged(var Msg: TMessage); message CM_FONTCHANGED;\r\n procedure CMTextChanged(var Msg: TMessage); message CM_TEXTCHANGED;\r\n procedure CMEnabledChanged(var Msg: TMessage); message CM_ENABLEDCHANGED;\r\n function GetSubtitle: TJvWizardPageTitle;\r\n function GetTitle: TJvWizardPageTitle;\r\n procedure SetSubtitle(const Value: TJvWizardPageTitle);\r\n procedure SetTitle(const Value: TJvWizardPageTitle);\r\n protected\r\n procedure CreateParams(var Params: TCreateParams); override;\r\n procedure ReadState(Reader: TReader); override;\r\n procedure AdjustClientRect(var Rect: TRect); override;\r\n procedure Paint; override;\r\n { DrawPage is called by paint method. all the derived page controls\r\n should call this method to paint itsself rather than the overrided\r\n paint method. }\r\n procedure DrawPage(ACanvas: TCanvas; var ARect: TRect); virtual;\r\n { called before the page shows up. Page: From page }\r\n procedure Enter(const FromPage: TJvWizardCustomPage); virtual;\r\n { called after the page shows up. }\r\n procedure Done; virtual;\r\n { called just before the page is hidden. Page: To page }\r\n procedure ExitPage(const ToPage: TJvWizardCustomPage); virtual; // renamed from Exit() to ExitPage\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n procedure EnableButton(AButton: TJvWizardButtonKind; AEnabled: Boolean); virtual;\r\n property Wizard: TJvWizard read FWizard write SetWizard;\r\n property PageIndex: Integer read GetPageIndex write SetPageIndex stored False;\r\n published\r\n property Header: TJvWizardPageHeader read FHeader write FHeader;\r\n property Subtitle: TJvWizardPageTitle read GetSubtitle write SetSubtitle stored False;\r\n property Title: TJvWizardPageTitle read GetTitle write SetTitle stored False;\r\n property Image: TJvWizardImage read FImage write FImage;\r\n property Panel: TJvWizardPagePanel read FPanel write FPanel;\r\n property EnabledButtons: TJvWizardButtonSet read FEnabledButtons write SetEnabledButtons default bkAllButtons;\r\n property VisibleButtons: TJvWizardButtonSet read FVisibleButtons write SetVisibleButtons default [bkBack, bkNext, bkCancel];\r\n property EnableJumpToPage: Boolean read FEnableJumpToPage write FEnableJumpToPage default True;\r\n property Color default clBtnFace;\r\n property Caption;\r\n property Enabled;\r\n property Font;\r\n property Left stored False;\r\n property Height stored False;\r\n property PopupMenu;\r\n property ShowHint;\r\n property Top stored False;\r\n property Width stored False;\r\n property OnEnterPage: TJvWizardChangePageEvent read FOnEnterPage write FOnEnterPage;\r\n property OnPage: TNotifyEvent read FOnPage write FOnPage;\r\n property OnExitPage: TJvWizardChangePageEvent read FOnExitPage write FOnExitPage;\r\n property OnPaintPage: TJvWizardPaintPageEvent read FOnPaintPage write FOnPaintPage;\r\n property OnStartButtonClick: TJvWizardPageClickEvent read FOnStartButtonClick write FOnStartButtonClick;\r\n property OnLastButtonClick: TJvWizardPageClickEvent read FOnLastButtonClick write FOnLastButtonClick;\r\n property OnNextButtonClick: TJvWizardPageClickEvent read FOnNextButtonClick write FOnNextButtonClick;\r\n property OnBackButtonClick: TJvWizardPageClickEvent read FOnBackButtonClick write FOnBackButtonClick;\r\n property OnCancelButtonClick: TJvWizardPageClickEvent read FOnCancelButtonClick write FOnCancelButtonClick;\r\n property OnFinishButtonClick: TJvWizardPageClickEvent read FOnFinishButtonClick write FOnFinishButtonClick;\r\n property OnHelpButtonClick: TJvWizardPageClickEvent read FOnHelpButtonClick write FOnHelpButtonClick;\r\n end;\r\n\r\n { Wizard Welcome Page }\r\n TJvWizardWelcomePage = class(TJvWizardCustomPage)\r\n private\r\n FWaterMark: TJvWizardWaterMark;\r\n protected\r\n procedure AdjustClientRect(var Rect: TRect); override;\r\n procedure DrawPage(ACanvas: TCanvas; var ARect: TRect); override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n published\r\n property Color default clWindow;\r\n property WaterMark: TJvWizardWaterMark read FWaterMark write FWaterMark;\r\n end;\r\n\r\n { Wizard Interior Page }\r\n TJvWizardInteriorPage = class(TJvWizardCustomPage)\r\n protected\r\n procedure DrawPage(ACanvas: TCanvas; var ARect: TRect); override;\r\n end;\r\n\r\n TJvWizardSelectPageEvent = procedure(Sender: TObject; FromPage: TJvWizardCustomPage;\r\n var ToPage: TJvWizardCustomPage) of object;\r\n\r\n { JvWizard Page List }\r\n TJvWizardPageList = class(TList)\r\n private\r\n FWizard: TJvWizard;\r\n function GetItems(Index: Integer): TJvWizardCustomPage;\r\n protected\r\n procedure Notify(Ptr: Pointer; Action: TListNotification); override;\r\n property Wizard: TJvWizard read FWizard write FWizard;\r\n public\r\n destructor Destroy; override;\r\n property Items[Index: Integer]: TJvWizardCustomPage read GetItems; default;\r\n end;\r\n\r\n { JvWizard Control }\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvWizard = class(TJvCustomControl)\r\n private\r\n FPages: TJvWizardPageList;\r\n FActivePage: TJvWizardCustomPage;\r\n FRouteMap: TJvWizardRouteMapControl;\r\n FNavigateButtons: array[TJvWizardButtonKind] of TJvWizardNavigateButton;\r\n FButtonBarHeight: Integer;\r\n FShowDivider: Boolean;\r\n FOnSelectNextPage: TJvWizardSelectPageEvent;\r\n FOnSelectPriorPage: TJvWizardSelectPageEvent;\r\n FOnSelectFirstPage: TJvWizardSelectPageEvent;\r\n FOnSelectLastPage: TJvWizardSelectPageEvent;\r\n FOnActivePageChanged: TNotifyEvent;\r\n FOnActivePageChanging: TJvWizardChangingPageEvent;\r\n FHeaderImages: TCustomImageList;\r\n FImageChangeLink: TChangeLink;\r\n FAutoHideButtonBar: Boolean;\r\n FDefaultButtons: Boolean;\r\n procedure SetShowDivider(Value: Boolean);\r\n function GetShowRouteMap: Boolean;\r\n procedure SetShowRouteMap(Value: Boolean);\r\n procedure SetButtonBarHeight(Value: Integer);\r\n procedure SetActivePage(Page: TJvWizardCustomPage);\r\n procedure SetHeaderImages(Value: TCustomImageList);\r\n function GetButtonClick(Index: Integer): TNotifyEvent;\r\n procedure SetButtonClick(Index: Integer; const Value: TNotifyEvent);\r\n procedure ImageListChange(Sender: TObject);\r\n procedure CreateNavigateButtons;\r\n procedure DestroyNavigateButtons;\r\n procedure ChangeActivePage(Page: TJvWizardCustomPage);\r\n function GetActivePageIndex: Integer;\r\n procedure SetActivePageIndex(Value: Integer);\r\n function GetPageCount: Integer;\r\n procedure RepositionButtons;\r\n procedure UpdateButtonsStatus;\r\n procedure WMEraseBkgnd(var Msg: TWMEraseBkgnd); message WM_ERASEBKGND;\r\n procedure WMGetDlgCode(var Msg: TWMGetDlgCode); message WM_GETDLGCODE;\r\n procedure CMDesignHitTest(var Msg: TCMDesignHitTest); message CM_DESIGNHITTEST;\r\n function FindNextEnabledPage(PageIndex: Integer; const Step: Integer = 1;\r\n CheckDisable: Boolean = True): TJvWizardCustomPage;\r\n procedure SetAutoHideButtonBar(const Value: Boolean);\r\n function GetWizardPages(Index: Integer): TJvWizardCustomPage;\r\n procedure SetDefaultButtons(const Value: Boolean);\r\n function GetNavigateButtons(Index: Integer): TJvWizardNavigateButton;\r\n procedure SetNavigateButtons(Index: Integer; Value: TJvWizardNavigateButton);\r\n protected\r\n procedure Loaded; override;\r\n procedure AdjustClientRect(var Rect: TRect); override;\r\n procedure ShowControl(AControl: TControl); override;\r\n procedure Paint; override;\r\n procedure Resize; override;\r\n procedure InsertPage(Page: TJvWizardCustomPage);\r\n procedure RemovePage(Page: TJvWizardCustomPage);\r\n procedure Notification(AComponent: TComponent; Operation: TOperation); override;\r\n function GetButtonControlClass(AKind: TJvWizardButtonKind): TJvWizardButtonControlClass; virtual;\r\n procedure DoActivePageChanging(var ToPage: TJvWizardCustomPage); dynamic;\r\n procedure DoActivePageChanged; dynamic;\r\n {$IFDEF COMPILER12_UP}\r\n public\r\n {$ENDIF COMPILER12_UP}\r\n procedure GetChildren(Proc: TGetChildProc; Root: TComponent); override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n procedure SelectPriorPage;\r\n procedure SelectNextPage;\r\n procedure SelectFirstPage;\r\n procedure SelectLastPage;\r\n function IsFirstPage(const APage: TJvWizardCustomPage; CheckDisable: Boolean = True): Boolean;\r\n function IsLastPage(const APage: TJvWizardCustomPage; CheckDisable: Boolean = True): Boolean;\r\n function FindNextPage(PageIndex: Integer; const Step: Integer = 1;\r\n CheckDisable: Boolean = True): TJvWizardCustomPage;\r\n function IsForward(const FromPage, ToPage: TJvWizardCustomPage): Boolean;\r\n property ActivePageIndex: Integer read GetActivePageIndex write SetActivePageIndex;\r\n property PageCount: Integer read GetPageCount;\r\n property WizardPages[Index: Integer]: TJvWizardCustomPage read GetWizardPages;\r\n published\r\n property Pages: TJvWizardPageList read FPages;\r\n property ActivePage: TJvWizardCustomPage read FActivePage write SetActivePage;\r\n property AutoHideButtonBar: Boolean read FAutoHideButtonBar write SetAutoHideButtonBar default True;\r\n property ButtonBarHeight: Integer read FButtonBarHeight write SetButtonBarHeight;\r\n property ButtonStart: TJvWizardNavigateButton index Integer(bkStart) read GetNavigateButtons write SetNavigateButtons;\r\n property ButtonLast: TJvWizardNavigateButton index Integer(bkLast) read GetNavigateButtons write SetNavigateButtons;\r\n property ButtonBack: TJvWizardNavigateButton index Integer(bkBack) read GetNavigateButtons write SetNavigateButtons;\r\n property ButtonNext: TJvWizardNavigateButton index Integer(bkNext) read GetNavigateButtons write SetNavigateButtons;\r\n property ButtonFinish: TJvWizardNavigateButton index Integer(bkFinish) read GetNavigateButtons write SetNavigateButtons;\r\n property ButtonCancel: TJvWizardNavigateButton index Integer(bkCancel) read GetNavigateButtons write SetNavigateButtons;\r\n property ButtonHelp: TJvWizardNavigateButton index Integer(bkHelp) read GetNavigateButtons write SetNavigateButtons;\r\n property DefaultButtons: Boolean read FDefaultButtons write SetDefaultButtons default True;\r\n property ShowDivider: Boolean read FShowDivider write SetShowDivider default True;\r\n property ShowRouteMap: Boolean read GetShowRouteMap write SetShowRouteMap;\r\n property HeaderImages: TCustomImageList read FHeaderImages write SetHeaderImages;\r\n property OnSelectFirstPage: TJvWizardSelectPageEvent read FOnSelectFirstPage write FOnSelectFirstPage;\r\n property OnSelectLastPage: TJvWizardSelectPageEvent read FOnSelectLastPage write FOnSelectLastPage;\r\n property OnSelectNextPage: TJvWizardSelectPageEvent read FOnSelectNextPage write FOnSelectNextPage;\r\n property OnSelectPriorPage: TJvWizardSelectPageEvent read FOnSelectPriorPage write FOnSelectPriorPage;\r\n\r\n // BCB cannot handle enum types as index\r\n property OnStartButtonClick: TNotifyEvent index Integer(bkStart) read GetButtonClick write SetButtonClick;\r\n property OnLastButtonClick: TNotifyEvent index Integer(bkLast) read GetButtonClick write SetButtonClick;\r\n property OnBackButtonClick: TNotifyEvent index Integer(bkBack) read GetButtonClick write SetButtonClick;\r\n property OnNextButtonClick: TNotifyEvent index Integer(bkNext) read GetButtonClick write SetButtonClick;\r\n property OnFinishButtonClick: TNotifyEvent index Integer(bkFinish) read GetButtonClick write SetButtonClick;\r\n property OnCancelButtonClick: TNotifyEvent index Integer(bkCancel) read GetButtonClick write SetButtonClick;\r\n property OnHelpButtonClick: TNotifyEvent index Integer(bkHelp) read GetButtonClick write SetButtonClick;\r\n\r\n property OnActivePageChanged: TNotifyEvent read FOnActivePageChanged write FOnActivePageChanged;\r\n property OnActivePageChanging: TJvWizardChangingPageEvent read FOnActivePageChanging write FOnActivePageChanging;\r\n\r\n property Color;\r\n property Font;\r\n property Enabled;\r\n property Visible;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvWizard.pas $';\r\n Revision: '$Revision: 13139 $';\r\n Date: '$Date: 2011-10-28 21:59:40 +0200 (ven. 28 oct. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n Consts,\r\n JvResources, JvJVCLUtils;\r\n\r\nconst\r\n ciButtonWidth = 75;\r\n ciButtonHeight = 25;\r\n ciButtonBarHeight = 42;\r\n ciButtonPlacement = (ciButtonBarHeight - ciButtonHeight) div 2;\r\n\r\ntype\r\n TJvWizardBaseButton = class(TJvWizardButtonControl)\r\n protected\r\n procedure ButtonClick(Page: TJvWizardCustomPage; var Stop: Boolean); virtual; abstract;\r\n procedure SelectPage; virtual;\r\n public\r\n procedure Click; override;\r\n end;\r\n\r\n { First Button }\r\n TJvWizardStartButton = class(TJvWizardBaseButton)\r\n protected\r\n procedure ButtonClick(Page: TJvWizardCustomPage; var Stop: Boolean); override;\r\n procedure SelectPage; override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n end;\r\n\r\n { Last Button }\r\n TJvWizardLastButton = class(TJvWizardBaseButton)\r\n protected\r\n procedure ButtonClick(Page: TJvWizardCustomPage; var Stop: Boolean); override;\r\n procedure SelectPage; override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n end;\r\n\r\n { Back Button }\r\n TJvWizardBackButton = class(TJvWizardBaseButton)\r\n protected\r\n procedure ButtonClick(Page: TJvWizardCustomPage; var Stop: Boolean); override;\r\n procedure SelectPage; override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n end;\r\n\r\n { Next Button }\r\n TJvWizardNextButton = class(TJvWizardBaseButton)\r\n protected\r\n procedure ButtonClick(Page: TJvWizardCustomPage; var Stop: Boolean); override;\r\n procedure SelectPage; override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n end;\r\n\r\n { Finish Button }\r\n TJvWizardFinishButton = class(TJvWizardBaseButton)\r\n protected\r\n procedure ButtonClick(Page: TJvWizardCustomPage; var Stop: Boolean); override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n end;\r\n\r\n { Cancel Button }\r\n TJvWizardCancelButton = class(TJvWizardBaseButton)\r\n protected\r\n procedure ButtonClick(Page: TJvWizardCustomPage; var Stop: Boolean); override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n end;\r\n\r\n { Help Button }\r\n TJvWizardHelpButton = class(TJvWizardBaseButton)\r\n protected\r\n procedure ButtonClick(Page: TJvWizardCustomPage; var Stop: Boolean); override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n procedure Click; override;\r\n end;\r\n\r\n//=== { TJvWizardButtonControl } =============================================\r\n\r\nconstructor TJvWizardButtonControl.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n if csDesigning in ComponentState then\r\n begin\r\n { !!! Add csClickEvents in order to fire the Click method\r\n at design time. It does NOT need at run time, otherwise it cause\r\n the OnClick event to be called twice. }\r\n ControlStyle := ControlStyle + [csClickEvents];\r\n ControlStyle := ControlStyle + [csNoDesignVisible];\r\n end;\r\n Kind := bkCustom;\r\n Anchors := [akRight, akBottom];\r\nend;\r\n\r\nprocedure TJvWizardButtonControl.CMDesignHitTest(var Msg: TCMDesignHitTest);\r\nbegin\r\n inherited;\r\n if Enabled then\r\n Msg.Result := 1;\r\nend;\r\n\r\nprocedure TJvWizardButtonControl.CMVisibleChanged(var Msg: TMessage);\r\nbegin\r\n inherited;\r\n if Assigned(FWizard) then\r\n FWizard.RepositionButtons;\r\nend;\r\n\r\n//=== { TJvWizardBaseButton } ================================================\r\n\r\nprocedure TJvWizardBaseButton.Click;\r\nvar\r\n Stop: Boolean;\r\n Page: TJvWizardCustomPage;\r\nbegin\r\n if Assigned(FWizard) then\r\n begin\r\n if not (csDesigning in ComponentState) then\r\n begin\r\n Stop := False;\r\n Page := FWizard.FActivePage;\r\n if Assigned(Page) then\r\n ButtonClick(Page, Stop);\r\n if Stop then\r\n Exit;\r\n inherited Click;\r\n end;\r\n SelectPage;\r\n end;\r\nend;\r\n\r\nprocedure TJvWizardBaseButton.SelectPage;\r\nbegin\r\n // default action: do nothing\r\nend;\r\n\r\n//=== { TJvWizardStartButton } ===============================================\r\n\r\nconstructor TJvWizardStartButton.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n Caption := RsFirstButtonCaption;\r\n Visible := False;\r\n Anchors := [akLeft, akBottom];\r\n Width := ciButtonWidth + 10;\r\n Alignment := alLeft;\r\nend;\r\n\r\nprocedure TJvWizardStartButton.ButtonClick(Page: TJvWizardCustomPage; var Stop: Boolean);\r\nbegin\r\n if Assigned(Page.FOnStartButtonClick) then\r\n Page.FOnStartButtonClick(Page, Stop);\r\nend;\r\n\r\nprocedure TJvWizardStartButton.SelectPage;\r\nbegin\r\n FWizard.SelectFirstPage;\r\nend;\r\n\r\n//=== { TJvWizardLastButton } ================================================\r\n\r\nconstructor TJvWizardLastButton.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n Caption := RsLastButtonCaption;\r\n Visible := False;\r\n Anchors := [akLeft, akBottom];\r\n Width := ciButtonWidth + 10;\r\n Alignment := alLeft;\r\nend;\r\n\r\nprocedure TJvWizardLastButton.ButtonClick(Page: TJvWizardCustomPage; var Stop: Boolean);\r\nbegin\r\n if Assigned(Page.FOnLastButtonClick) then\r\n Page.FOnLastButtonClick(Page, Stop);\r\nend;\r\n\r\nprocedure TJvWizardLastButton.SelectPage;\r\nbegin\r\n FWizard.SelectLastPage;\r\nend;\r\n\r\n//=== { TJvWizardBackButton } ================================================\r\n\r\nconstructor TJvWizardBackButton.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n Caption := RsBackButtonCaption;\r\n Enabled := False;\r\n Visible := True;\r\n Width := ciButtonWidth;\r\n Alignment := alRight;\r\nend;\r\n\r\nprocedure TJvWizardBackButton.ButtonClick(Page: TJvWizardCustomPage; var Stop: Boolean);\r\nbegin\r\n if Assigned(Page.FOnBackButtonClick) then\r\n Page.FOnBackButtonClick(Page, Stop);\r\nend;\r\n\r\nprocedure TJvWizardBackButton.SelectPage;\r\nbegin\r\n FWizard.SelectPriorPage;\r\nend;\r\n\r\n//=== { TJvWizardNextButton } ================================================\r\n\r\nconstructor TJvWizardNextButton.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n Caption := RsNextButtonCaption;\r\n Enabled := False;\r\n Visible := True;\r\n Width := ciButtonWidth;\r\n Alignment := alRight;\r\nend;\r\n\r\nprocedure TJvWizardNextButton.ButtonClick(Page: TJvWizardCustomPage; var Stop: Boolean);\r\nbegin\r\n if Assigned(Page.FOnNextButtonClick) then\r\n Page.FOnNextButtonClick(Page, Stop);\r\nend;\r\n\r\nprocedure TJvWizardNextButton.SelectPage;\r\nbegin\r\n FWizard.SelectNextPage;\r\nend;\r\n\r\n//=== { TJvWizardFinishButton } ==============================================\r\n\r\nconstructor TJvWizardFinishButton.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n Caption := RsFinishButtonCaption;\r\n Visible := False;\r\n Width := ciButtonWidth;\r\n Alignment := alRight;\r\nend;\r\n\r\nprocedure TJvWizardFinishButton.ButtonClick(Page: TJvWizardCustomPage; var Stop: Boolean);\r\nbegin\r\n if Assigned(Page.FOnFinishButtonClick) then\r\n Page.FOnFinishButtonClick(Page, Stop);\r\nend;\r\n\r\n//=== { TJvWizardCancelButton } ==============================================\r\n\r\nconstructor TJvWizardCancelButton.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n Caption := SCancelButton;\r\n Visible := True;\r\n Cancel := True;\r\n Width := ciButtonWidth;\r\n Alignment := alRight;\r\n ModalResult := mrCancel;\r\nend;\r\n\r\nprocedure TJvWizardCancelButton.ButtonClick(Page: TJvWizardCustomPage; var Stop: Boolean);\r\nbegin\r\n if Assigned(Page.FOnCancelButtonClick) then\r\n Page.FOnCancelButtonClick(Page, Stop);\r\nend;\r\n\r\n//=== { TJvWizardHelpButton } ================================================\r\n\r\nconstructor TJvWizardHelpButton.Create(AOwner: TComponent); // Added by Theodore\r\nbegin\r\n inherited Create(AOwner);\r\n Caption := SHelpButton;\r\n Visible := False;\r\n Anchors := [akLeft, akBottom];\r\n Width := ciButtonWidth;\r\n Alignment := alLeft;\r\nend;\r\n\r\nprocedure TJvWizardHelpButton.Click;\r\nvar\r\n ID: THelpContext;\r\nbegin\r\n if not (csDesigning in ComponentState) then\r\n begin\r\n ID := 0;\r\n if Assigned(OnClick) then\r\n inherited Click\r\n else\r\n if Assigned(FWizard) and Assigned(FWizard.ActivePage) then\r\n begin\r\n if Assigned(FWizard.ActivePage.OnHelpButtonClick) then\r\n inherited Click\r\n else\r\n ID := FWizard.ActivePage.HelpContext;\r\n end\r\n else\r\n ID := GetParentForm(Self).HelpContext;\r\n\r\n if ID <> 0 then\r\n Application.HelpContext(ID);\r\n end;\r\nend;\r\n\r\nprocedure TJvWizardHelpButton.ButtonClick(Page: TJvWizardCustomPage; var Stop: Boolean);\r\nbegin\r\n if Assigned(Page.FOnHelpButtonClick) then\r\n Page.FOnHelpButtonClick(Page, Stop);\r\nend;\r\n\r\n//=== { TJvWizardNavigateButton } ============================================\r\n\r\nfunction TJvWizardNavigateButton.GetCaption: string;\r\nbegin\r\n if Assigned(FControl) then\r\n Result := FControl.Caption\r\n else\r\n Result := '';\r\nend;\r\n\r\nfunction TJvWizardNavigateButton.GetGlyph: TBitmap;\r\nbegin\r\n if Assigned(FControl) then\r\n Result := FControl.Glyph\r\n else\r\n Result := nil;\r\nend;\r\n\r\nfunction TJvWizardNavigateButton.GetLayout: TButtonLayout;\r\nbegin\r\n if Assigned(FControl) then\r\n Result := FControl.Layout\r\n else\r\n Result := blGlyphLeft;\r\nend;\r\n\r\nfunction TJvWizardNavigateButton.GetNumGlyphs: Integer;\r\nbegin\r\n if Assigned(FControl) then\r\n Result := FControl.NumGlyphs\r\n else\r\n Result := 0;\r\nend;\r\n\r\nprocedure TJvWizardNavigateButton.SetCaption(const Value: string);\r\nbegin\r\n if Assigned(FControl) then\r\n FControl.Caption := Value;\r\nend;\r\n\r\nprocedure TJvWizardNavigateButton.SetGlyph(const Value: TBitmap);\r\nbegin\r\n if Assigned(FControl) then\r\n FControl.Glyph := Value;\r\nend;\r\n\r\nprocedure TJvWizardNavigateButton.SetNumGlyphs(const Value: Integer);\r\nbegin\r\n if Assigned(FControl) then\r\n FControl.NumGlyphs := Value;\r\nend;\r\n\r\nprocedure TJvWizardNavigateButton.SetLayout(const Value: TButtonLayout);\r\nbegin\r\n if Assigned(FControl) then\r\n FControl.Layout := Value;\r\nend;\r\n\r\nfunction TJvWizardNavigateButton.GetModalResult: TModalResult;\r\nbegin\r\n if Assigned(FControl) then\r\n Result := FControl.ModalResult\r\n else\r\n Result := mrNone;\r\nend;\r\n\r\nprocedure TJvWizardNavigateButton.SetModalResult(const Value: TModalResult);\r\nbegin\r\n if Assigned(FControl) then\r\n FControl.ModalResult := Value;\r\nend;\r\n\r\nfunction TJvWizardNavigateButton.GetButtonWidth: Integer;\r\nbegin\r\n if Assigned(FControl) then\r\n Result := FControl.Width\r\n else\r\n Result := 0;\r\nend;\r\n\r\nprocedure TJvWizardNavigateButton.SetButtonWidth(const Value: Integer);\r\nbegin\r\n if Assigned(FControl) and (FControl.Width <> Value) then\r\n begin\r\n FControl.Width := Value;\r\n if Assigned(FControl.FWizard) then\r\n FControl.FWizard.RepositionButtons;\r\n end;\r\nend;\r\n\r\n//=== { TJvWizardRouteMapControl } ===========================================\r\n\r\nconstructor TJvWizardRouteMapControl.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FImage := TJvWizardImage.Create;\r\n FImage.OnChange := DoImageChange;\r\n { !!! Add csNoDesignVisible in order to make it visible and invisible\r\n at design Time. }\r\n if csDesigning in ComponentState then\r\n ControlStyle := ControlStyle + [csNoDesignVisible];\r\n FAlign := alLeft;\r\n inherited Align := alLeft;\r\n TabStop := False;\r\n Width := 145;\r\n Visible := True;\r\n FPages := TList.Create;\r\n DoubleBuffered := True;\r\nend;\r\n\r\ndestructor TJvWizardRouteMapControl.Destroy;\r\nbegin\r\n if Assigned(Wizard) then\r\n Wizard.FRouteMap := nil;\r\n FPages.Free;\r\n FImage.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvWizardRouteMapControl.DoImageChange(Sender: TObject);\r\nbegin\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvWizardRouteMapControl.DoAddPage(const APage: TJvWizardCustomPage);\r\nbegin\r\n if Assigned(FWizard) then\r\n begin\r\n if Assigned(APage) and (FPages.IndexOf(APage) < 0) then\r\n FPages.Add(APage);\r\n WizardPageAdded(APage);\r\n end;\r\nend;\r\n\r\nprocedure TJvWizardRouteMapControl.DoDeletePage(const APage: TJvWizardCustomPage);\r\nvar\r\n I: Integer;\r\nbegin\r\n if Assigned(FWizard) then\r\n begin\r\n if Assigned(APage) then\r\n begin\r\n I := FPages.Remove(APage);\r\n if FPageIndex = I then\r\n FPageIndex := -1;\r\n end;\r\n WizardPageDeleted(APage);\r\n end;\r\nend;\r\n\r\nprocedure TJvWizardRouteMapControl.DoActivatePage(const APage: TJvWizardCustomPage);\r\nbegin\r\n if Assigned(FWizard) then\r\n begin\r\n if Assigned(APage) then\r\n FPageIndex := FPages.IndexOf(APage);\r\n WizardPageActivated(APage);\r\n end;\r\nend;\r\n\r\nprocedure TJvWizardRouteMapControl.DoUpdatePage(const APage: TJvWizardCustomPage);\r\nbegin\r\n if Assigned(FWizard) then\r\n WizardPageUpdated(APage);\r\nend;\r\n\r\nprocedure TJvWizardRouteMapControl.DoMovePage(const APage: TJvWizardCustomPage;\r\n const OldIndex: Integer);\r\nbegin\r\n if Assigned(FWizard) then\r\n begin\r\n if Assigned(APage) then\r\n begin\r\n FPages.Move(OldIndex, APage.PageIndex);\r\n if OldIndex = FPageIndex then\r\n FPageIndex := APage.PageIndex;\r\n end;\r\n WizardPageMoved(APage, OldIndex);\r\n end;\r\nend;\r\n\r\nprocedure TJvWizardRouteMapControl.SetAlign(Value: TJvWizardAlign);\r\nbegin\r\n if FAlign <> Value then\r\n begin\r\n FAlign := Value;\r\n inherited Align := FAlign;\r\n end;\r\nend;\r\n\r\nfunction TJvWizardRouteMapControl.GetPage(Index: Integer): TJvWizardCustomPage;\r\nbegin\r\n if (Index >= 0) and (Index < FPages.Count) then\r\n Result := TJvWizardCustomPage(FPages[Index])\r\n else\r\n Result := nil;\r\nend;\r\n\r\nfunction TJvWizardRouteMapControl.GetPageCount: Integer;\r\nbegin\r\n Result := FPages.Count;\r\nend;\r\n\r\nprocedure TJvWizardRouteMapControl.SetImage(const Value: TJvWizardImage);\r\nbegin\r\n FImage.Assign(Value);\r\nend;\r\n\r\nfunction TJvWizardRouteMapControl.HasPicture: Boolean;\r\nbegin\r\n Result := (FImage.Picture.Graphic <> nil) and not FImage.Picture.Graphic.Empty;\r\nend;\r\n\r\nprocedure TJvWizardRouteMapControl.SetPageIndex(Value: Integer);\r\nbegin\r\n if (FPageIndex <> Value) and (Value >= 0) and (Value < PageCount) then\r\n begin\r\n if Assigned(FWizard) and (Pages[Value].Wizard = FWizard) then\r\n begin\r\n FWizard.SetActivePage(Pages[Value]);\r\n // read PageIndex from Wizard because the OnChanging event could have stopped it from switching to the page\r\n FPageIndex := FWizard.ActivePageIndex;\r\n end\r\n else\r\n FPageIndex := Value;\r\n end;\r\nend;\r\n\r\nprocedure TJvWizardRouteMapControl.CMDesignHitTest(var Msg: TCMDesignHitTest);\r\nbegin\r\n if PageAtPos(Point(Msg.XPos, Msg.YPos)) <> nil then\r\n Msg.Result := 1\r\n else\r\n inherited;\r\nend;\r\n\r\nfunction TJvWizardRouteMapControl.PageAtPos(Pt: TPoint): TJvWizardCustomPage;\r\nbegin\r\n { Return the page object at the particular point in the route\r\n map control. Return NIL if no page at this particular point. }\r\n Result := nil;\r\nend;\r\n\r\nprocedure TJvWizardRouteMapControl.MouseDown(Button: TMouseButton; Shift: TShiftState;\r\n X, Y: Integer);\r\nvar\r\n APage: TJvWizardCustomPage;\r\nbegin\r\n if Button = mbLeft then\r\n begin\r\n APage := PageAtPos(Point(X, Y));\r\n if Assigned(APage) and ((csDesigning in ComponentState) or\r\n (APage.Enabled and APage.EnableJumpToPage)) then\r\n begin\r\n if APage.PageIndex = PageIndex + 1 then\r\n Wizard.SelectNextPage\r\n else\r\n if APage.PageIndex = PageIndex - 1 then\r\n Wizard.SelectPriorPage\r\n else\r\n Wizard.ActivePage := APage;\r\n end;\r\n end;\r\n inherited MouseDown(Button, Shift, X, Y);\r\nend;\r\n\r\nprocedure TJvWizardRouteMapControl.SetParent(AParent: TWinControl);\r\nvar\r\n I: Integer;\r\nbegin\r\n if Assigned(AParent) then\r\n begin\r\n if not ((AParent is TJvWizard) or (AParent is TJvWizardCustomPage)) then\r\n raise EJvWizardError.CreateRes(@RsEInvalidParentControl);\r\n if AParent is TJvWizardCustomPage then\r\n AParent := TJvWizardCustomPage(AParent).Wizard;\r\n end;\r\n inherited SetParent(AParent);\r\n if Assigned(AParent) then\r\n begin\r\n FWizard := TJvWizard(AParent);\r\n FWizard.FRouteMap := Self;\r\n FPages.Clear;\r\n for I := 0 to FWizard.PageCount - 1 do\r\n FPages.Add(FWizard.FPages[I]);\r\n\r\n if Assigned(FWizard.FActivePage) then\r\n FPageIndex := FWizard.FActivePage.PageIndex\r\n else\r\n FPageIndex := -1;\r\n end;\r\nend;\r\n\r\nprocedure TJvWizardRouteMapControl.WizardPageActivated(const APage: TJvWizardCustomPage);\r\nbegin\r\n { Called after the page becomes the current active page of the wizard. }\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvWizardRouteMapControl.WizardPageAdded(const APage: TJvWizardCustomPage);\r\nbegin\r\n { Called after the new page was added into the wizard. }\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvWizardRouteMapControl.WizardPageDeleted(const APage: TJvWizardCustomPage);\r\nbegin\r\n { Called after the page is removed from the wizard.\r\n Note: do NOT free this page. }\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvWizardRouteMapControl.WizardPageMoved(const APage: TJvWizardCustomPage;\r\n const OldIndex: Integer);\r\nbegin\r\n { Called after the page has changed its page order. }\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvWizardRouteMapControl.WizardPageUpdated(const APage: TJvWizardCustomPage);\r\nbegin\r\n { Called when the page changed its status or caption. }\r\n Invalidate;\r\nend;\r\n\r\nfunction TJvWizardRouteMapControl.CanDisplay(const APage: TJvWizardCustomPage): Boolean;\r\nbegin\r\n Result := Assigned(APage) and ((csDesigning in ComponentState) or APage.Enabled);\r\n if not (csDesigning in ComponentState) and Assigned(FOnDisplaying) then\r\n FOnDisplaying(Self, APage, Result);\r\nend;\r\n\r\n//=== { TJvWizardImage } =====================================================\r\n\r\nconstructor TJvWizardImage.Create;\r\nbegin\r\n inherited Create;\r\n FPicture := TPicture.Create;\r\n FPicture.OnChange := DoPictureChange;\r\n FAlignment := iaStretch;\r\n FLayout := ilStretch;\r\nend;\r\n\r\ndestructor TJvWizardImage.Destroy;\r\nbegin\r\n FPicture.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvWizardImage.DoChange;\r\nbegin\r\n if Assigned(FOnChange) then\r\n FOnChange(Self);\r\nend;\r\n\r\nprocedure TJvWizardImage.PaintTo(const ACanvas: TCanvas; ARect: TRect);\r\nbegin\r\n if Assigned(FPicture.Graphic) then\r\n JvWizardDrawImage(ACanvas, FPicture.Graphic, ARect, FAlignment, FLayout);\r\nend;\r\n\r\nprocedure TJvWizardImage.SetAlignment(Value: TJvWizardImageAlignment);\r\nbegin\r\n if FAlignment <> Value then\r\n begin\r\n FAlignment := Value;\r\n DoChange;\r\n end;\r\nend;\r\n\r\nprocedure TJvWizardImage.SetPicture(Value: TPicture);\r\nbegin\r\n FPicture.Assign(Value);\r\n if FPicture.Graphic <> nil then\r\n FPicture.Graphic.Transparent := FTransparent;\r\nend;\r\n\r\nprocedure TJvWizardImage.SetLayout(Value: TJvWizardImageLayout);\r\nbegin\r\n if FLayout <> Value then\r\n begin\r\n FLayout := Value;\r\n DoChange;\r\n end;\r\nend;\r\n\r\nfunction TJvWizardImage.GetTransparent: Boolean;\r\nvar\r\n AGraphic: TGraphic;\r\nbegin\r\n AGraphic := FPicture.Graphic;\r\n if Assigned(AGraphic) then\r\n Result := AGraphic.Transparent\r\n else\r\n Result := FTransparent;\r\nend;\r\n\r\nprocedure TJvWizardImage.SetTransparent(Value: Boolean);\r\nvar\r\n AGraphic: TGraphic;\r\nbegin\r\n AGraphic := FPicture.Graphic;\r\n FTransparent := Value;\r\n if Assigned(AGraphic) and\r\n not ( (AGraphic is TMetaFile) or (AGraphic is TIcon)) then\r\n AGraphic.Transparent := Value;\r\nend;\r\n\r\nprocedure TJvWizardImage.DoPictureChange(Sender: TObject);\r\nbegin\r\n DoChange;\r\nend;\r\n\r\n//=== { TJvWizardGraphicObject } =============================================\r\n\r\nconstructor TJvWizardGraphicObject.Create;\r\nbegin\r\n inherited Create;\r\n FColor := clBtnFace;\r\n FVisible := True;\r\nend;\r\n\r\nprocedure TJvWizardGraphicObject.SetColor(Value: TColor);\r\nbegin\r\n if FColor <> Value then\r\n begin\r\n FColor := Value;\r\n ColorChanged;\r\n end;\r\nend;\r\n\r\nprocedure TJvWizardGraphicObject.SetVisible(Value: Boolean);\r\nbegin\r\n if FVisible <> Value then\r\n begin\r\n FVisible := Value;\r\n VisibleChanged;\r\n end;\r\nend;\r\n\r\nprocedure TJvWizardGraphicObject.ColorChanged;\r\nbegin\r\n DoChange;\r\nend;\r\n\r\nprocedure TJvWizardGraphicObject.VisibleChanged;\r\nbegin\r\n DoChange;\r\nend;\r\n\r\n//=== { TJvWizardPageTitle } =================================================\r\n\r\nconstructor TJvWizardPageTitle.Create;\r\nbegin\r\n inherited Create;\r\n FAnchorPlacement := 4;\r\n FIndent := 0;\r\n FAnchors := [akLeft, akTop];\r\n FAlignment := taLeftJustify;\r\n FFont := TFont.Create;\r\n Color := clNone; // Transparent\r\nend;\r\n\r\ndestructor TJvWizardPageTitle.Destroy;\r\nbegin\r\n FFont.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvWizardPageTitle.DoChange;\r\nbegin\r\n if Assigned(FWizardPageHeader) then\r\n FWizardPageHeader.DoChange;\r\nend;\r\n\r\nprocedure TJvWizardPageTitle.WriteText(Writer: TWriter);\r\nbegin\r\n Writer.WriteString(FText);\r\nend;\r\n\r\nprocedure TJvWizardPageTitle.DefineProperties(Filer: TFiler);\r\nbegin\r\n inherited DefineProperties(Filer);\r\n { Write empty Text to DFM because the default value differs from '' }\r\n if Filer is TWriter then\r\n Filer.DefineProperty('Text', nil, WriteText, FText = '');\r\nend;\r\n\r\nprocedure TJvWizardPageTitle.SetWizardPageHeader(Value: TJvWizardPageHeader);\r\nbegin\r\n if FWizardPageHeader <> Value then\r\n begin\r\n FWizardPageHeader := Value;\r\n if Assigned(FWizardPageHeader) and Assigned(FWizardPageHeader.WizardPage) then\r\n AdjustFont(FWizardPageHeader.WizardPage.Font);\r\n FFont.OnChange := FontChange;\r\n end;\r\nend;\r\n\r\nfunction TJvWizardPageTitle.GetTextRect(const ACanvas: TCanvas;\r\n const ARect: TRect): TRect;\r\nvar\r\n ATextSize: TSize;\r\nbegin\r\n ATextSize := ACanvas.TextExtent(FText);\r\n Result := Bounds(ARect.Left, ARect.Top, ATextSize.cx, ATextSize.cy);\r\n if akLeft in FAnchors then\r\n OffsetRect(Result, FAnchorPlacement, 0);\r\n if akTop in FAnchors then\r\n OffsetRect(Result, 0, FAnchorPlacement);\r\n if akRight in FAnchors then\r\n Result.Right := ARect.Right - FAnchorPlacement;\r\n if akBottom in FAnchors then\r\n Result.Bottom := ARect.Bottom - FAnchorPlacement;\r\n InflateRect(Result, -FIndent, 0);\r\n if Result.Bottom > ARect.Bottom then\r\n Result.Bottom := ARect.Bottom;\r\n if Result.Right > ARect.Right then\r\n Result.Right := ARect.Right;\r\nend;\r\n\r\nprocedure TJvWizardPageTitle.PaintTo(ACanvas: TCanvas; var ARect: TRect);\r\nconst\r\n Alignments: array [TAlignment] of Integer = (DT_LEFT, DT_RIGHT, DT_CENTER);\r\n cOutlineColor = TColor($00FFD8CE);\r\nvar\r\n ATextRect: TRect;\r\nbegin\r\n if FVisible and Assigned(FWizardPageHeader) and\r\n Assigned(FWizardPageHeader.WizardPage) then\r\n begin\r\n ACanvas.Font.Assign(FFont);\r\n ATextRect := GetTextRect(ACanvas, ARect);\r\n if FColor <> clNone then\r\n begin\r\n ACanvas.Brush.Style := bsSolid;\r\n ACanvas.Brush.Color := FColor;\r\n ACanvas.FillRect(ATextRect);\r\n end;\r\n with ACanvas do\r\n begin\r\n Brush.Style := bsClear;\r\n DrawText(ACanvas.Handle, PChar(FText), -1, ATextRect, DT_WORDBREAK or Alignments[FAlignment]);\r\n { Draw outline at design time. }\r\n if csDesigning in FWizardPageHeader.WizardPage.ComponentState then\r\n begin\r\n Pen.Style := psDot;\r\n Pen.Mode := pmXor;\r\n Pen.Color := cOutlineColor;\r\n Brush.Style := bsClear;\r\n Rectangle(ATextRect.Left, ATextRect.Top, ATextRect.Right,\r\n ATextRect.Bottom);\r\n end;\r\n end;\r\n ARect.Top := ATextRect.Bottom;\r\n end;\r\nend;\r\n\r\nprocedure TJvWizardPageTitle.SetAlignment(Value: TAlignment);\r\nbegin\r\n if FAlignment <> Value then\r\n begin\r\n FAlignment := Value;\r\n DoChange;\r\n end;\r\nend;\r\n\r\nprocedure TJvWizardPageTitle.SetAnchors(Value: TAnchors);\r\nbegin\r\n if FAnchors <> Value then\r\n begin\r\n FAnchors := Value;\r\n DoChange;\r\n end;\r\nend;\r\n\r\nprocedure TJvWizardPageTitle.SetIndent(Value: Integer);\r\nbegin\r\n if FIndent <> Value then\r\n begin\r\n FIndent := Value;\r\n DoChange;\r\n end;\r\nend;\r\n\r\nprocedure TJvWizardPageTitle.SetFont(Value: TFont);\r\nbegin\r\n if (FFont <> Value) then\r\n begin\r\n FFont.Assign(Value);\r\n end;\r\nend;\r\n\r\nprocedure TJvWizardPageTitle.SetText(const Value: string);\r\nbegin\r\n if FText <> Value then\r\n begin\r\n FText := Value;\r\n DoChange;\r\n if Assigned(FWizardPageHeader) and\r\n Assigned(FWizardPageHeader.WizardPage) and\r\n Assigned(FWizardPageHeader.WizardPage.Wizard) and\r\n Assigned(FWizardPageHeader.WizardPage.Wizard.FRouteMap) then\r\n begin\r\n FWizardPageHeader.WizardPage.Wizard.FRouteMap.DoUpdatePage(FWizardPageHeader.WizardPage);\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvWizardPageTitle.SetAnchorPlacement(Value: Integer);\r\nbegin\r\n if FAnchorPlacement <> Value then\r\n begin\r\n FAnchorPlacement := Value;\r\n DoChange;\r\n end;\r\nend;\r\n\r\nprocedure TJvWizardPageTitle.AdjustFont(const AFont: TFont);\r\nbegin\r\n if Assigned(AFont) then\r\n begin\r\n FFont.Name := AFont.Name;\r\n FFont.Charset := AFont.Charset;\r\n end;\r\nend;\r\n\r\nprocedure TJvWizardPageTitle.FontChange(Sender: TObject);\r\nbegin\r\n // Font has changed, set the ParentFont property to False.\r\n if Assigned(FWizardPageHeader) then\r\n FWizardPageHeader.ParentFont := False;\r\n DoChange;\r\nend;\r\n\r\nprocedure TJvWizardPageTitle.Assign(Source: TPersistent);\r\nbegin\r\n if Source is TJvWizardPageTitle then\r\n begin\r\n if Source <> Self then\r\n begin\r\n FText := TJvWizardPageTitle(Source).Text;\r\n FAnchors := TJvWizardPageTitle(Source).Anchors;\r\n FAnchorPlacement := TJvWizardPageTitle(Source).AnchorPlacement;\r\n FIndent := TJvWizardPageTitle(Source).Indent;\r\n FAlignment := TJvWizardPageTitle(Source).Alignment;\r\n Font := TJvWizardPageTitle(Source).Font;\r\n DoChange\r\n end\r\n end\r\n else\r\n inherited Assign(Source);\r\nend;\r\n\r\n//=== { TJvWizardPageObject } ================================================\r\n\r\nprocedure TJvWizardPageObject.DoChange;\r\nbegin\r\n if Assigned(FWizardPage) then\r\n FWizardPage.Invalidate;\r\nend;\r\n\r\nprocedure TJvWizardPageObject.Initialize;\r\nbegin\r\nend;\r\n\r\nprocedure TJvWizardPageObject.SetWizardPage(Value: TJvWizardCustomPage);\r\nbegin\r\n FWizardPage := Value;\r\n Initialize;\r\nend;\r\n\r\n//=== { TJvWizardPageHeader } ================================================\r\n\r\nconstructor TJvWizardPageHeader.Create;\r\nbegin\r\n inherited Create;\r\n Color := clWindow;\r\n FHeight := 70;\r\n FParentFont := True;\r\n { Set up Title }\r\n FTitle := TJvWizardPageTitle.Create;\r\n FTitle.FText := RsTitle;\r\n FTitle.FAnchors := [akLeft, akTop, akRight];\r\n FTitle.FFont.Size := 12;\r\n FTitle.FFont.Style := [fsBold];\r\n { Set up Subtitle }\r\n FSubtitle := TJvWizardPageTitle.Create;\r\n FSubtitle.FAnchors := [akLeft, akTop, akRight, akBottom];\r\n FSubtitle.FText := RsSubtitle;\r\n FImageAlignment := iaRight;\r\n FImageOffset := 0;\r\n FImageIndex := -1;\r\n FShowDivider := True;\r\nend;\r\n\r\ndestructor TJvWizardPageHeader.Destroy;\r\nbegin\r\n FTitle.Free;\r\n FSubtitle.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvWizardPageHeader.Initialize;\r\nbegin\r\n FTitle.WizardPageHeader := Self;\r\n FSubtitle.WizardPageHeader := Self;\r\nend;\r\n\r\nprocedure TJvWizardPageHeader.SetHeight(Value: Integer);\r\nbegin\r\n if FHeight <> Value then\r\n begin\r\n FHeight := Value;\r\n DoChange;\r\n end;\r\nend;\r\n\r\nprocedure TJvWizardPageHeader.SetImageIndex(Value: Integer);\r\nbegin\r\n if FImageIndex <> Value then\r\n begin\r\n FImageIndex := Value;\r\n DoChange;\r\n end;\r\nend;\r\n\r\nprocedure TJvWizardPageHeader.SetImageOffset(Value: Integer);\r\nbegin\r\n if FImageOffset <> Value then\r\n begin\r\n FImageOffset := Value;\r\n DoChange;\r\n end;\r\nend;\r\n\r\nprocedure TJvWizardPageHeader.SetImageAlignment(Value: TJvWizardImageLeftRight);\r\nbegin\r\n if FImageAlignment <> Value then\r\n begin\r\n FImageAlignment := Value;\r\n DoChange;\r\n end;\r\nend;\r\n\r\nprocedure TJvWizardPageHeader.SetShowDivider(Value: Boolean);\r\nbegin\r\n if FShowDivider <> Value then\r\n begin\r\n FShowDivider := Value;\r\n DoChange;\r\n end;\r\nend;\r\n\r\nfunction TJvWizardPageHeader.GetImageRect(const AImages: TCustomImageList;\r\n var ARect: TRect): TRect;\r\nbegin\r\n Result := Bounds(ARect.Left, ARect.Top, AImages.Width, AImages.Height);\r\n OffsetRect(Result, 0, ((ARect.Bottom - ARect.Top) - AImages.Height) div 2);\r\n if FImageAlignment = iaRight then\r\n OffsetRect(Result, ARect.Right - ARect.Left - AImages.Width - 4, 0);\r\n\r\n if FImageAlignment = iaLeft then\r\n begin\r\n OffsetRect(Result, FImageOffset, 0);\r\n { if right side of the image area still in the page header area\r\n then adjust the left side of title area. }\r\n if Result.Right > ARect.Left then\r\n ARect.Left := Result.Right;\r\n end\r\n else // must be iaRight\r\n begin\r\n OffsetRect(Result, -FImageOffset, 0);\r\n { if left side of the image area still in the page header area\r\n then adjust the ride side of title area. }\r\n if Result.Left < ARect.Right then\r\n ARect.Right := Result.Left;\r\n end;\r\nend;\r\n\r\nprocedure TJvWizardPageHeader.SetSubtitle(const Value: TJvWizardPageTitle);\r\nbegin\r\n FSubtitle.Assign(Value);\r\nend;\r\n\r\nprocedure TJvWizardPageHeader.SetTitle(const Value: TJvWizardPageTitle);\r\nbegin\r\n FTitle.Assign(Value);\r\nend;\r\n\r\nprocedure TJvWizardPageHeader.PaintTo(ACanvas: TCanvas; var ARect: TRect);\r\nvar\r\n R, ImageRect: TRect;\r\n AImages: TCustomImageList;\r\nbegin\r\n if Visible then\r\n begin\r\n R := ARect;\r\n R.Bottom := R.Top + FHeight;\r\n with ACanvas do\r\n begin\r\n Brush.Style := bsSolid;\r\n Brush.Color := Color;\r\n FillRect(R);\r\n end;\r\n if Assigned(WizardPage) then\r\n begin\r\n { Show Header Divider }\r\n if {(csDesigning in WizardPage.ComponentState) or} FShowDivider then\r\n JvWizardDrawBorderEdges(ACanvas, R, fsGroove, [beBottom]);\r\n\r\n { Draw Header Image first }\r\n if Assigned(WizardPage.Wizard) then\r\n begin\r\n AImages := WizardPage.Wizard.HeaderImages;\r\n if Assigned(AImages) and (FImageIndex >= 0) and\r\n (FImageIndex < AImages.Count) then\r\n begin\r\n ImageRect := GetImageRect(AImages, R);\r\n { R is the area where the title and subtitle paint to. }\r\n AImages.Draw(ACanvas, ImageRect.Left, ImageRect.Top, FImageIndex , True );\r\n end;\r\n end;\r\n { Draw Title }\r\n FTitle.PaintTo(ACanvas, R);\r\n { Draw Subtitle }\r\n FSubtitle.PaintTo(ACanvas, R);\r\n end;\r\n Inc(ARect.Top, FHeight);\r\n end;\r\nend;\r\n\r\nprocedure TJvWizardPageHeader.AdjustTitleFont;\r\nbegin\r\n if Assigned(FWizardPage) and FParentFont then\r\n begin\r\n if Assigned(FTitle) then\r\n FTitle.AdjustFont(FWizardPage.Font);\r\n if Assigned(FSubtitle) then\r\n FSubtitle.AdjustFont(FWizardPage.Font);\r\n end;\r\nend;\r\n\r\nprocedure TJvWizardPageHeader.SetParentFont(Value: Boolean);\r\nbegin\r\n if FParentFont <> Value then\r\n begin\r\n FParentFont := Value;\r\n AdjustTitleFont;\r\n\r\n // Setting back the value as AdjustTitleFont might change the font, thus\r\n // trigerring this handler again.\r\n FParentFont := Value;\r\n end;\r\nend;\r\n\r\nprocedure TJvWizardPageHeader.VisibleChanged;\r\nbegin\r\n inherited VisibleChanged;\r\n if Assigned(WizardPage) then\r\n WizardPage.Realign;\r\nend;\r\n\r\n//=== { TJvWizardWaterMark } =================================================\r\n\r\nconstructor TJvWizardWaterMark.Create;\r\nbegin\r\n inherited Create;\r\n FAlign := alLeft;\r\n Color := clActiveCaption;\r\n FWidth := 164;\r\n FBorderWidth := 1;\r\n FImage := TJvWizardImage.Create;\r\n FImage.OnChange := ImageChanged;\r\nend;\r\n\r\ndestructor TJvWizardWaterMark.Destroy;\r\nbegin\r\n FImage.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvWizardWaterMark.SetBorderWidth(Value: Integer);\r\nbegin\r\n if FBorderWidth <> Value then\r\n begin\r\n FBorderWidth := Value;\r\n DoChange;\r\n end;\r\nend;\r\n\r\nprocedure TJvWizardWaterMark.SetAlign(Value: TJvWizardLeftRight);\r\nbegin\r\n if FAlign <> Value then\r\n begin\r\n FAlign := Value;\r\n DoChange;\r\n if Assigned(WizardPage) then\r\n WizardPage.Realign;\r\n end;\r\nend;\r\n\r\nprocedure TJvWizardWaterMark.SetWidth(Value: Integer);\r\nbegin\r\n if FWidth <> Value then\r\n begin\r\n FWidth := Value;\r\n DoChange;\r\n end;\r\nend;\r\n\r\nprocedure TJvWizardWaterMark.PaintTo(ACanvas: TCanvas; var ARect: TRect);\r\nvar\r\n R: TRect;\r\n AHeight: Integer;\r\nbegin\r\n if Visible then\r\n begin\r\n AHeight := ARect.Bottom - ARect.Top;\r\n if FAlign = alLeft then\r\n begin\r\n R := Bounds(ARect.Left, ARect.Top, FWidth, AHeight);\r\n Inc(ARect.Left, FWidth);\r\n end\r\n else // must be alRight\r\n begin\r\n R := Bounds(ARect.Right - FWidth, ARect.Top, FWidth, AHeight);\r\n Dec(ARect.Right, FWidth);\r\n end;\r\n InflateRect(R, -FBorderWidth, -FBorderWidth);\r\n with ACanvas do\r\n begin\r\n Brush.Style := bsSolid;\r\n Brush.Color := Color;\r\n FillRect(R);\r\n end;\r\n FImage.PaintTo(ACanvas, R);\r\n end;\r\nend;\r\n\r\nprocedure TJvWizardWaterMark.ImageChanged(Sender: TObject);\r\nbegin\r\n DoChange;\r\nend;\r\n\r\nprocedure TJvWizardWaterMark.VisibleChanged;\r\nbegin\r\n inherited VisibleChanged;\r\n if Assigned(WizardPage) then\r\n WizardPage.Realign;\r\nend;\r\n\r\n//=== { TJvWizardPagePanel } =================================================\r\n\r\nconstructor TJvWizardPagePanel.Create;\r\nbegin\r\n inherited Create;\r\n FBorderWidth := 7;\r\n Color := clBtnFace;\r\n Visible := False;\r\nend;\r\n\r\nprocedure TJvWizardPagePanel.PaintTo(ACanvas: TCanvas; var ARect: TRect);\r\nbegin\r\n if Visible and (FBorderWidth > 0) then\r\n begin\r\n InflateRect(ARect, -FBorderWidth, -FBorderWidth);\r\n JvWizardDrawBorderEdges(ACanvas, ARect, fsGroove, beAllEdges);\r\n if Color <> clNone then // clNone means transparent\r\n begin\r\n InflateRect(ARect, -2, -2);\r\n with ACanvas do\r\n begin\r\n Brush.Style := bsSolid;\r\n Brush.Color := Color;\r\n FillRect(ARect);\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvWizardPagePanel.SetBorderWidth(Value: Word);\r\nbegin\r\n if FBorderWidth <> Value then\r\n begin\r\n FBorderWidth := Value;\r\n DoChange;\r\n end;\r\nend;\r\n\r\n//=== { TJvWizardCustomPage } ================================================\r\n\r\nconstructor TJvWizardCustomPage.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n Align := alClient;\r\n ControlStyle := ControlStyle + [csAcceptsControls, csNoDesignVisible];\r\n Visible := False;\r\n Color := clBtnFace;\r\n FHeader := TJvWizardPageHeader.Create;\r\n FHeader.WizardPage := Self;\r\n FImage := TJvWizardImage.Create;\r\n FImage.OnChange := ImageChanged;\r\n FPanel := TJvWizardPagePanel.Create;\r\n FPanel.WizardPage := Self;\r\n { try to avoid screen flicker, it paints its image\r\n into memory, then move image memory to the screen at once. }\r\n FEnabledButtons := bkAllButtons;\r\n FVisibleButtons := [bkBack, bkNext, bkCancel];\r\n DoubleBuffered := True;\r\n FEnableJumpToPage := True;\r\nend;\r\n\r\ndestructor TJvWizardCustomPage.Destroy;\r\nbegin\r\n if Assigned(FWizard) then\r\n FWizard.RemovePage(Self);\r\n FPanel.Free;\r\n FImage.Free;\r\n FHeader.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvWizardCustomPage.CreateParams(var Params: TCreateParams);\r\nbegin\r\n inherited CreateParams(Params);\r\n with Params.WindowClass do\r\n Style := Style and not (CS_HREDRAW or CS_VREDRAW);\r\nend;\r\n\r\nprocedure TJvWizardCustomPage.AdjustClientRect(var Rect: TRect);\r\nbegin\r\n inherited AdjustClientRect(Rect);\r\n if FHeader.Visible then\r\n Rect.Top := Rect.Top + FHeader.Height;\r\nend;\r\n\r\nprocedure TJvWizardCustomPage.EnableButton(AButton: TJvWizardButtonKind; AEnabled: Boolean);\r\nvar\r\n IsEnabled: Boolean;\r\n ButtonSet: TJvWizardButtonSet;\r\nbegin\r\n ButtonSet := [AButton];\r\n IsEnabled := (ButtonSet * EnabledButtons) <> [];\r\n if AEnabled <> IsEnabled then\r\n begin\r\n if AEnabled then\r\n EnabledButtons := EnabledButtons + ButtonSet\r\n else\r\n EnabledButtons := EnabledButtons - ButtonSet;\r\n end;\r\nend;\r\n\r\nprocedure TJvWizardCustomPage.CMEnabledChanged(var Msg: TMessage);\r\nvar\r\n NextPage: TJvWizardCustomPage;\r\nbegin\r\n inherited;\r\n if Assigned(FWizard) then\r\n begin\r\n if Assigned(FWizard.FRouteMap) then\r\n FWizard.FRouteMap.DoUpdatePage(Self);\r\n if not ((csDesigning in ComponentState) or Enabled) and\r\n (FWizard.ActivePage = Self) then\r\n begin\r\n NextPage := FWizard.FindNextPage(PageIndex, 1,\r\n not (csDesigning in ComponentState));\r\n if not Assigned(NextPage) then\r\n NextPage := FWizard.FindNextPage(PageIndex, -1, not (csDesigning in ComponentState));\r\n FWizard.SetActivePage(NextPage);\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvWizardCustomPage.CMTextChanged(var Msg: TMessage);\r\nbegin\r\n Invalidate;\r\n if Assigned(FWizard) and Assigned(FWizard.FRouteMap) then\r\n FWizard.FRouteMap.DoUpdatePage(Self);\r\nend;\r\n\r\nprocedure TJvWizardCustomPage.CMFontChanged(var Msg: TMessage);\r\nbegin\r\n FHeader.AdjustTitleFont;\r\n inherited;\r\nend;\r\n\r\nprocedure TJvWizardCustomPage.SetWizard(AWizard: TJvWizard);\r\nbegin\r\n if FWizard <> AWizard then\r\n begin\r\n if Assigned(FWizard) then\r\n FWizard.RemovePage(Self);\r\n Parent := AWizard;\r\n if Assigned(AWizard) then\r\n AWizard.InsertPage(Self);\r\n end;\r\nend;\r\n\r\nfunction TJvWizardCustomPage.GetPageIndex: Integer;\r\nbegin\r\n if Assigned(FWizard) then\r\n Result := FWizard.FPages.IndexOf(Self)\r\n else\r\n Result := -1;\r\nend;\r\n\r\nprocedure TJvWizardCustomPage.ReadState(Reader: TReader);\r\nbegin\r\n inherited ReadState(Reader);\r\n if Reader.Parent is TJvWizard then\r\n Wizard := TJvWizard(Reader.Parent);\r\nend;\r\n\r\nprocedure TJvWizardCustomPage.SetPageIndex(const Value: Integer);\r\nvar\r\n OldIndex: Integer;\r\nbegin\r\n if Assigned(FWizard) and (Value >= 0) and (Value < FWizard.FPages.Count) then\r\n begin\r\n OldIndex := PageIndex;\r\n FWizard.FPages.Move(OldIndex, Value);\r\n if Assigned(FWizard.FRouteMap) then\r\n FWizard.FRouteMap.DoMovePage(Self, OldIndex);\r\n end;\r\nend;\r\n\r\nprocedure TJvWizardCustomPage.WMEraseBkgnd(var Msg: TWMEraseBkgnd);\r\nbegin\r\n {$IFDEF JVCLThemesEnabledD6}\r\n if ThemeServices.ThemesEnabled then\r\n inherited;\r\n {$ENDIF JVCLThemesEnabledD6}\r\n {$IFDEF COMPILER9_UP}\r\n inherited;\r\n Msg.Result := 0;\r\n {$ELSE}\r\n Msg.Result := 1;\r\n {$ENDIF COMPILER9_UP}\r\nend;\r\n\r\nprocedure TJvWizardCustomPage.Paint;\r\nvar\r\n ARect: TRect;\r\nbegin\r\n if FDrawing then\r\n Exit;\r\n FDrawing := True;\r\n try\r\n ARect := ClientRect;\r\n with Canvas do\r\n begin\r\n Brush.Style := bsSolid;\r\n Brush.Color := Color;\r\n FillRect(ARect);\r\n end;\r\n DrawPage(Canvas, ARect);\r\n if Assigned(FOnPaintPage) and not (csDesigning in ComponentState) then\r\n FOnPaintPage(Self, Canvas, ARect)\r\n else\r\n begin\r\n { Paint the image first to prevent the image from covering\r\n the panel. }\r\n FImage.PaintTo(Canvas, ARect);\r\n FPanel.PaintTo(Canvas, ARect);\r\n end;\r\n { display page caption at design time. }\r\n if csDesigning in ComponentState then\r\n begin\r\n Canvas.Brush.Style := bsClear;\r\n Canvas.Font.Assign(Font);\r\n DrawText(Canvas.Handle, PChar(Caption), -1, ARect,\r\n DT_SINGLELINE + DT_CENTER + DT_VCENTER);\r\n end;\r\n finally\r\n FDrawing := False;\r\n end;\r\nend;\r\n\r\nprocedure TJvWizardCustomPage.DrawPage(ACanvas: TCanvas; var ARect: TRect);\r\nbegin\r\n { all derived page control should call this method to paint itsself\r\n rather than call the overrided paint method. }\r\nend;\r\n\r\nprocedure TJvWizardCustomPage.Done;\r\nbegin\r\n Refresh; // !!! Force the page to repaint itself immediately.\r\n if Assigned(FOnPage) and Enabled and not (csDesigning in ComponentState) then\r\n FOnPage(Self);\r\nend;\r\n\r\nprocedure TJvWizardCustomPage.Enter(const FromPage: TJvWizardCustomPage);\r\nbegin\r\n if Assigned(FOnEnterPage) and Enabled and not (csDesigning in ComponentState) then\r\n FOnEnterPage(Self, FromPage);\r\nend;\r\n\r\nprocedure TJvWizardCustomPage.ExitPage(const ToPage: TJvWizardCustomPage);\r\nbegin\r\n if Assigned(FOnExitPage) and Enabled and not (csDesigning in ComponentState) then\r\n FOnExitPage(Self, ToPage);\r\nend;\r\n\r\nprocedure TJvWizardCustomPage.ImageChanged(Sender: TObject);\r\nbegin\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvWizardCustomPage.SetEnabledButtons(Value: TJvWizardButtonSet);\r\nbegin\r\n if FEnabledButtons <> Value then\r\n begin\r\n FEnabledButtons := Value;\r\n if Assigned(FWizard) and (FWizard.FActivePage = Self) then\r\n FWizard.UpdateButtonsStatus;\r\n end;\r\nend;\r\n\r\nprocedure TJvWizardCustomPage.SetVisibleButtons(Value: TJvWizardButtonSet);\r\nbegin\r\n if FVisibleButtons <> Value then\r\n begin\r\n FVisibleButtons := Value;\r\n if Assigned(FWizard) and (FWizard.FActivePage = Self) then\r\n begin\r\n { if there is no buttons are visible, then we don't need\r\n to display the button bar. }\r\n if FWizard.AutoHideButtonBar then\r\n begin\r\n if FVisibleButtons = [] then\r\n FWizard.ButtonBarHeight := 0\r\n else\r\n FWizard.ButtonBarHeight := ciButtonBarHeight;\r\n end;\r\n Invalidate;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJvWizardCustomPage.GetSubtitle: TJvWizardPageTitle;\r\nbegin\r\n Result := Header.Subtitle;\r\nend;\r\n\r\nfunction TJvWizardCustomPage.GetTitle: TJvWizardPageTitle;\r\nbegin\r\n Result := Header.Title;\r\nend;\r\n\r\nprocedure TJvWizardCustomPage.SetSubtitle(const Value: TJvWizardPageTitle);\r\nbegin\r\n Header.Subtitle := Value;\r\nend;\r\n\r\nprocedure TJvWizardCustomPage.SetTitle(const Value: TJvWizardPageTitle);\r\nbegin\r\n Header.Title := Value;\r\nend;\r\n\r\n//=== { TJvWizardWelcomePage } ===============================================\r\n\r\nconstructor TJvWizardWelcomePage.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FWaterMark := TJvWizardWaterMark.Create;\r\n FWaterMark.WizardPage := Self;\r\n FHeader.FTitle.FText := RsWelcome;\r\n // welcome pages don't have dividers by default\r\n// FHeader.ShowDivider := False;\r\n Color := clWindow;\r\nend;\r\n\r\ndestructor TJvWizardWelcomePage.Destroy;\r\nbegin\r\n FWaterMark.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvWizardWelcomePage.AdjustClientRect(var Rect: TRect);\r\nbegin\r\n inherited AdjustClientRect(Rect); // !!! must call\r\n if FWaterMark.Visible then\r\n begin\r\n if FWaterMark.Align = alLeft then\r\n Rect.Left := Rect.Left + FWaterMark.Width\r\n else\r\n Rect.Right := Rect.Right - FWaterMark.Width;\r\n end;\r\nend;\r\n\r\nprocedure TJvWizardWelcomePage.DrawPage(ACanvas: TCanvas; var ARect: TRect);\r\nbegin\r\n FWaterMark.PaintTo(ACanvas, ARect);\r\n FHeader.PaintTo(ACanvas, ARect);\r\nend;\r\n\r\n//=== { TJvWizardInteriorPage } ==============================================\r\n\r\nprocedure TJvWizardInteriorPage.DrawPage(ACanvas: TCanvas; var ARect: TRect);\r\nbegin\r\n FHeader.PaintTo(ACanvas, ARect);\r\nend;\r\n\r\n//=== { TJvWizardPageList } ==================================================\r\n\r\ndestructor TJvWizardPageList.Destroy;\r\nbegin\r\n FWizard := nil;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJvWizardPageList.GetItems(Index: Integer): TJvWizardCustomPage;\r\nbegin\r\n Result := TJvWizardCustomPage(inherited Items[Index]);\r\nend;\r\n\r\nprocedure TJvWizardPageList.Notify(Ptr: Pointer; Action: TListNotification);\r\nbegin\r\n case Action of\r\n lnAdded:\r\n TJvWizardCustomPage(Ptr).FWizard := FWizard;\r\n lnDeleted:\r\n TJvWizardCustomPage(Ptr).FWizard := nil;\r\n end;\r\nend;\r\n\r\n//=== { TJvWizard } ==========================================================\r\n\r\nconstructor TJvWizard.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n { In order to accept TJvWizardRouteMap control, we need to add\r\n csAcceptsControls ControlStyle }\r\n ControlStyle := ControlStyle + [csAcceptsControls];\r\n FPages := TJvWizardPageList.Create;\r\n FPages.Wizard := Self;\r\n Align := alClient;\r\n FShowDivider := True;\r\n FButtonBarHeight := ciButtonBarHeight;\r\n FImageChangeLink := TChangeLink.Create;\r\n FImageChangeLink.OnChange := ImageListChange;\r\n FAutoHideButtonBar := True;\r\n CreateNavigateButtons;\r\n FDefaultButtons := True;\r\nend;\r\n\r\ndestructor TJvWizard.Destroy;\r\nvar\r\n I: Integer;\r\nbegin\r\n DestroyNavigateButtons;\r\n { !!! Reset wizard property value of all wizard pages FIRST,\r\n so that when the actual wizard page control is freed, the page won't\r\n call Wizard.RemovePage, otherwise it will cause AV, because at that\r\n time FPages has already been destroyed. }\r\n for I := 0 to FPages.Count - 1 do\r\n TJvWizardCustomPage(FPages[I]).FWizard := nil;\r\n FImageChangeLink.Free;\r\n FPages.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvWizard.Loaded;\r\nbegin\r\n inherited Loaded;\r\n RepositionButtons;\r\n { When the wizard shows up, by default we display the first page. }\r\n if FPages.Count > 0 then\r\n SelectFirstPage;\r\nend;\r\n\r\nfunction TJvWizard.GetButtonControlClass(AKind: TJvWizardButtonKind): TJvWizardButtonControlClass;\r\nbegin\r\n case AKind of\r\n bkStart:\r\n Result := TJvWizardStartButton;\r\n bkLast:\r\n Result := TJvWizardLastButton;\r\n bkBack:\r\n Result := TJvWizardBackButton;\r\n bkNext:\r\n Result := TJvWizardNextButton;\r\n bkFinish:\r\n Result := TJvWizardFinishButton;\r\n bkCancel:\r\n Result := TJvWizardCancelButton;\r\n bkHelp:\r\n Result := TJvWizardHelpButton;\r\n else\r\n Result := TJvWizardButtonControl;\r\n end;\r\nend;\r\n\r\nprocedure TJvWizard.CreateNavigateButtons;\r\nvar\r\n AKind: TJvWizardButtonKind;\r\n AButton: TJvWizardButtonControl;\r\nbegin\r\n for AKind := Low(TJvWizardButtonKind) to High(TJvWizardButtonKind) do\r\n begin\r\n { Don't need to set width property }\r\n AButton := GetButtonControlClass(AKind).Create(Self);\r\n try\r\n AButton.Parent := Self;\r\n AButton.Height := ciButtonHeight;\r\n AButton.Wizard := Self;\r\n finally\r\n FNavigateButtons[AKind] := TJvWizardNavigateButton.Create;\r\n FNavigateButtons[AKind].Control := AButton;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvWizard.DestroyNavigateButtons;\r\nvar\r\n AKind: TJvWizardButtonKind;\r\nbegin\r\n for AKind := Low(TJvWizardButtonKind) to High(TJvWizardButtonKind) do\r\n FNavigateButtons[AKind].Free;\r\nend;\r\n\r\nfunction TJvWizard.FindNextPage(PageIndex: Integer; const Step: Integer;\r\n CheckDisable: Boolean): TJvWizardCustomPage;\r\nbegin\r\n { !!! Only the Enabled property of the page can tell if it should be\r\n ignore or skip. we can not use Visible property, because all pages are\r\n invisible at startup until they are actived. }\r\n Result := nil;\r\n Assert(Step <> 0);\r\n repeat\r\n Inc(PageIndex, Step);\r\n until (PageIndex < 0) or (PageIndex >= FPages.Count) or\r\n TJvWizardCustomPage(FPages[PageIndex]).Enabled or not CheckDisable;\r\n if csDesigning in ComponentState then\r\n begin\r\n if PageIndex < 0 then\r\n PageIndex := FPages.Count - 1\r\n else\r\n if PageIndex >= FPages.Count then\r\n PageIndex := 0;\r\n end;\r\n if (PageIndex >= 0) and (PageIndex < FPages.Count) and\r\n (TJvWizardCustomPage(FPages[PageIndex]).Enabled or not CheckDisable) then\r\n Result := TJvWizardCustomPage(FPages[PageIndex]);\r\nend;\r\n\r\nfunction TJvWizard.FindNextEnabledPage(PageIndex: Integer; const Step: Integer;\r\n CheckDisable: Boolean): TJvWizardCustomPage;\r\nbegin\r\n Result := FindNextPage(PageIndex, Step, CheckDisable);\r\n while (Result <> nil) and not Result.EnableJumpToPage do\r\n Result := FindNextPage(Result.PageIndex, Step, CheckDisable);\r\nend;\r\n\r\nprocedure TJvWizard.SelectFirstPage;\r\nvar\r\n AFirstPage: TJvWizardCustomPage;\r\nbegin\r\n AFirstPage := FindNextEnabledPage(-1, 1, not (csDesigning in ComponentState));\r\n if Assigned(AFirstPage) then\r\n begin\r\n if not (csDesigning in ComponentState) and Assigned(FOnSelectFirstPage) then\r\n FOnSelectFirstPage(Self, FActivePage, AFirstPage);\r\n if Assigned(AFirstPage) then\r\n SetActivePage(AFirstPage);\r\n end;\r\nend;\r\n\r\nprocedure TJvWizard.SelectLastPage;\r\nvar\r\n ALastPage: TJvWizardCustomPage;\r\nbegin\r\n ALastPage := FindNextEnabledPage(FPages.Count, -1, not (csDesigning in ComponentState));\r\n if Assigned(ALastPage) then\r\n begin\r\n if not (csDesigning in ComponentState) and Assigned(FOnSelectLastPage) then\r\n FOnSelectLastPage(Self, FActivePage, ALastPage);\r\n if Assigned(ALastPage) then\r\n SetActivePage(ALastPage);\r\n end;\r\nend;\r\n\r\nprocedure TJvWizard.SelectNextPage;\r\nvar\r\n ANextPage: TJvWizardCustomPage;\r\nbegin\r\n ANextPage := FindNextEnabledPage(GetActivePageIndex, 1, not (csDesigning in ComponentState));\r\n if Assigned(ANextPage) then\r\n begin\r\n if not (csDesigning in ComponentState) and Assigned(FOnSelectNextPage) then\r\n FOnSelectNextPage(Self, FActivePage, ANextPage);\r\n if Assigned(ANextPage) then\r\n SetActivePage(ANextPage);\r\n end;\r\nend;\r\n\r\nprocedure TJvWizard.SelectPriorPage;\r\nvar\r\n APriorPage: TJvWizardCustomPage;\r\nbegin\r\n APriorPage := FindNextEnabledPage(GetActivePageIndex, -1, not (csDesigning in ComponentState));\r\n if Assigned(APriorPage) then\r\n begin\r\n if not (csDesigning in ComponentState) and Assigned(FOnSelectPriorPage) then\r\n FOnSelectPriorPage(Self, FActivePage, APriorPage);\r\n if Assigned(APriorPage) then\r\n SetActivePage(APriorPage);\r\n end;\r\nend;\r\n\r\nfunction TJvWizard.IsFirstPage(const APage: TJvWizardCustomPage; CheckDisable: Boolean): Boolean;\r\nvar\r\n AFirstPage: TJvWizardCustomPage;\r\nbegin\r\n AFirstPage := FindNextPage(-1, 1, CheckDisable);\r\n Result := not Assigned(AFirstPage) or (APage = AFirstPage);\r\nend;\r\n\r\nfunction TJvWizard.IsLastPage(const APage: TJvWizardCustomPage; CheckDisable: Boolean): Boolean;\r\nvar\r\n ALastPage: TJvWizardCustomPage;\r\nbegin\r\n ALastPage := FindNextPage(FPages.Count, -1, CheckDisable);\r\n Result := not Assigned(ALastPage) or (APage = ALastPage);\r\nend;\r\n\r\nprocedure TJvWizard.SetActivePage(Page: TJvWizardCustomPage);\r\nbegin\r\n if not (csLoading in ComponentState) and\r\n (not Assigned(Page) or ((Page.Wizard = Self) and\r\n ((csDesigning in ComponentState) or Page.Enabled))) then\r\n begin\r\n ChangeActivePage(Page);\r\n end;\r\nend;\r\n\r\nprocedure TJvWizard.ChangeActivePage(Page: TJvWizardCustomPage);\r\nvar\r\n ParentForm: TCustomForm;\r\nbegin\r\n if FActivePage <> Page then\r\n begin\r\n DoActivePageChanging(Page);\r\n if Page = FActivePage then\r\n Exit;\r\n\r\n ParentForm := GetParentForm(Self);\r\n if Assigned(ParentForm) and Assigned(FActivePage) and\r\n FActivePage.ContainsControl(ParentForm.ActiveControl) and FActivePage.CanFocus then\r\n begin\r\n ParentForm.ActiveControl := FActivePage;\r\n end;\r\n\r\n if Assigned(FActivePage) then\r\n begin\r\n { FActivePage.Exit, called just before the page is hidden. }\r\n FActivePage.ExitPage(Page);\r\n FActivePage.Visible := False;\r\n end;\r\n\r\n { Just in case the new page is changed to be disabled again after\r\n the above OnExitPage event is called. }\r\n if Assigned(Page) and not (Page.Enabled or (csDesigning in ComponentState)) then\r\n begin\r\n if IsForward(FActivePage, Page) then\r\n Page := FindNextPage(GetActivePageIndex) // try go forward\r\n else\r\n Page := FindNextPage(GetActivePageIndex, -1); // try go backward\r\n end;\r\n\r\n if Assigned(Page) then\r\n begin\r\n { FActivePage.Enter, called before the page shows up. }\r\n Page.Enter(FActivePage);\r\n Page.BringToFront;\r\n Page.Visible := True;\r\n if Assigned(ParentForm) then\r\n begin\r\n if Page.CanFocus then\r\n ParentForm.ActiveControl := Page\r\n else\r\n if CanFocus then\r\n ParentForm.ActiveControl := Self;\r\n end;\r\n end;\r\n\r\n FActivePage := Page;\r\n if Assigned(FRouteMap) then\r\n FRouteMap.DoActivatePage(FActivePage);\r\n if AutoHideButtonBar then\r\n begin\r\n if Assigned(FActivePage) and (FActivePage.FVisibleButtons = []) then\r\n ButtonBarHeight := 0\r\n else\r\n ButtonBarHeight := ciButtonBarHeight;\r\n end;\r\n { At design time, if the Page's Enabled property set to False,\r\n the following if block never gets called. }\r\n if Assigned(ParentForm) and Assigned(FActivePage) and\r\n (ParentForm.ActiveControl = FActivePage) then\r\n begin\r\n FActivePage.SelectFirst;\r\n FActivePage.Done;\r\n end;\r\n\r\n DoActivePageChanged;\r\n end;\r\nend;\r\n\r\nprocedure TJvWizard.InsertPage(Page: TJvWizardCustomPage);\r\nbegin\r\n FPages.Add(Page);\r\n if Assigned(FRouteMap) then\r\n FRouteMap.DoAddPage(Page);\r\nend;\r\n\r\nprocedure TJvWizard.RemovePage(Page: TJvWizardCustomPage);\r\nvar\r\n NextPage: TJvWizardCustomPage;\r\nbegin\r\n if ActivePage = Page then\r\n NextPage := FindNextPage(Page.PageIndex, 1, not (csDesigning in ComponentState))\r\n else\r\n NextPage := ActivePage;\r\n\r\n if NextPage = Page then\r\n NextPage := nil;\r\n if Assigned(FRouteMap) then\r\n FRouteMap.DoDeletePage(Page);\r\n FPages.Remove(Page);\r\n SetActivePage(NextPage);\r\n { !!! We must not call Page.Free, because page is the child\r\n control of the wizard now, so when the wizard being destroy, this page\r\n will be destroyed as well. }\r\nend;\r\n\r\nfunction TJvWizard.GetActivePageIndex: Integer;\r\nbegin\r\n if Assigned(ActivePage) then\r\n Result := ActivePage.PageIndex\r\n else\r\n Result := -1;\r\nend;\r\n\r\nprocedure TJvWizard.SetActivePageIndex(Value: Integer);\r\nbegin\r\n if (Value >= 0) and (Value < PageCount) then\r\n ActivePage := TJvWizardCustomPage(FPages[Value])\r\n else\r\n ActivePage := nil;\r\nend;\r\n\r\nprocedure TJvWizard.WMEraseBkgnd(var Msg: TWMEraseBkgnd);\r\nbegin\r\n {$IFDEF JVCLThemesEnabledD6}\r\n if ThemeServices.ThemesEnabled then\r\n inherited;\r\n {$ENDIF JVCLThemesEnabledD6}\r\n Msg.Result := 1;\r\nend;\r\n\r\nprocedure TJvWizard.Paint;\r\nvar\r\n R: TRect;\r\nbegin\r\n R := ClientRect;\r\n if Color <> clNone then\r\n begin\r\n Canvas.Brush.Color := Color;\r\n Canvas.Brush.Style := bsSolid;\r\n Canvas.FillRect(R);\r\n end;\r\n if (FButtonBarHeight > ciButtonHeight) and FShowDivider then\r\n begin\r\n R.Top := R.Bottom - FButtonBarHeight;\r\n JvWizardDrawBorderEdges(Canvas, R, fsGroove, [beTop]);\r\n end;\r\nend;\r\n\r\nprocedure TJvWizard.SetShowDivider(Value: Boolean);\r\nbegin\r\n if FShowDivider <> Value then\r\n begin\r\n FShowDivider := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nfunction TJvWizard.GetShowRouteMap: Boolean;\r\nbegin\r\n if Assigned(FRouteMap) then\r\n Result := FRouteMap.Visible\r\n else\r\n Result := False;\r\nend;\r\n\r\nprocedure TJvWizard.SetShowRouteMap(Value: Boolean);\r\nbegin\r\n if Assigned(FRouteMap) then\r\n FRouteMap.Visible := Value;\r\nend;\r\n\r\nprocedure TJvWizard.SetButtonBarHeight(Value: Integer);\r\nbegin\r\n if FButtonBarHeight <> Value then\r\n begin\r\n FButtonBarHeight := Value;\r\n Realign;\r\n RepositionButtons;\r\n Invalidate;\r\n end;\r\n { Whatever the ButtonBarHeight is changed or not, we need to\r\n call UpdateButtonsStatus method anyway. }\r\n UpdateButtonsStatus;\r\nend;\r\n\r\nprocedure TJvWizard.SetHeaderImages(Value: TCustomImageList);\r\nbegin\r\n ReplaceImageListReference(Self, Value, FHeaderImages, FImageChangeLink);\r\n if Assigned(FActivePage) then\r\n FActivePage.Invalidate;\r\nend;\r\n\r\nfunction TJvWizard.GetButtonClick(Index: Integer): TNotifyEvent;\r\nbegin\r\n if Assigned(FNavigateButtons[TJvWizardButtonKind(Index)].Control) then\r\n Result := FNavigateButtons[TJvWizardButtonKind(Index)].Control.OnClick\r\n else\r\n Result := nil;\r\nend;\r\n\r\nprocedure TJvWizard.SetButtonClick(Index: Integer; const Value: TNotifyEvent);\r\nbegin\r\n if Assigned(FNavigateButtons[TJvWizardButtonKind(Index)].Control) then\r\n FNavigateButtons[TJvWizardButtonKind(Index)].Control.OnClick := Value;\r\nend;\r\n\r\nfunction TJvWizard.GetPageCount: Integer;\r\nbegin\r\n Result := FPages.Count;\r\nend;\r\n\r\nprocedure TJvWizard.CMDesignHitTest(var Msg: TCMDesignHitTest);\r\nvar\r\n Pt: TPoint;\r\nbegin\r\n Pt := SmallPointToPoint(Msg.Pos);\r\n if Assigned(FActivePage) and PtInRect(FActivePage.BoundsRect, Pt) then\r\n Msg.Result := 1;\r\nend;\r\n\r\nprocedure TJvWizard.AdjustClientRect(var Rect: TRect);\r\nbegin\r\n { All wizard's child controls (Pages, RouteMap, etc) whose align\r\n property set to (alTop, alLeft, alTop, alBottom, alClient) will call\r\n this procedure to adjust their bounds. All navigation buttons would not\r\n call it because they do not have align set, so they can display at\r\n the bottom of the wizard. }\r\n inherited AdjustClientRect(Rect);\r\n if FButtonBarHeight > ciButtonHeight then\r\n Rect.Bottom := Rect.Bottom - FButtonBarHeight;\r\nend;\r\n\r\nprocedure TJvWizard.WMGetDlgCode(var Msg: TWMGetDlgCode);\r\nbegin\r\n Msg.Result := DLGC_WANTALLKEYS or DLGC_WANTARROWS;\r\nend;\r\n\r\nprocedure TJvWizard.UpdateButtonsStatus;\r\nvar\r\n AKind: TJvWizardButtonKind;\r\n AEnabledButtonSet: TJvWizardButtonSet;\r\n AVisibleButtonSet: TJvWizardButtonSet;\r\nbegin\r\n if not Assigned(Parent) then\r\n Exit;\r\n AEnabledButtonSet := [bkCancel];\r\n AVisibleButtonSet := [bkBack, bkNext, bkCancel];\r\n if Assigned(FActivePage) then\r\n begin\r\n { By default, the Back button should be disabled for the first\r\n page at run time }\r\n if not (csDesigning in ComponentState) and IsFirstPage(FActivePage) then\r\n Exclude(FActivePage.FEnabledButtons, bkBack);\r\n AEnabledButtonSet := FActivePage.FEnabledButtons;\r\n AVisibleButtonSet := FActivePage.FVisibleButtons;\r\n if csDesigning in ComponentState then\r\n begin\r\n Include(AEnabledButtonSet, bkBack);\r\n Include(AEnabledButtonSet, bkNext);\r\n Include(AVisibleButtonSet, bkBack);\r\n Include(AVisibleButtonSet, bkNext);\r\n Exclude(AVisibleButtonSet, bkFinish);\r\n end;\r\n end;\r\n { Change Buttons' status. }\r\n for AKind := Low(TJvWizardButtonKind) to High(TJvWizardButtonKind) do\r\n begin\r\n FNavigateButtons[AKind].Control.Visible := AKind in AVisibleButtonSet;\r\n FNavigateButtons[AKind].Control.Enabled := AKind in AEnabledButtonSet;\r\n end;\r\n { Set Default Button, Next Button has the higher priority than\r\n the Finish Button. }\r\n if (bkNext in AVisibleButtonSet) and (bkNext in AEnabledButtonSet) then\r\n FNavigateButtons[bkNext].Control.Default := DefaultButtons\r\n else\r\n if (bkFinish in AVisibleButtonSet) and (bkFinish in AEnabledButtonSet) then\r\n FNavigateButtons[bkFinish].Control.Default := DefaultButtons;\r\nend;\r\n\r\nprocedure TJvWizard.RepositionButtons;\r\nvar\r\n ATop: Integer;\r\n ALeft: Integer;\r\n AButtonSet: TJvWizardButtonSet;\r\n AButtonKind: TJvWizardButtonKind;\r\n\r\n procedure LocateButton(const AKind: TJvWizardButtonKind; const AOffset: Integer);\r\n begin\r\n if AKind in AButtonSet then\r\n begin\r\n with FNavigateButtons[AKind] do\r\n begin\r\n if FControl.Alignment = alRight then\r\n ALeft := ALeft - FControl.Width;\r\n FControl.SetBounds(ALeft, ATop, FControl.Width, ciButtonHeight);\r\n if FControl.Alignment = alLeft then\r\n ALeft := ALeft + FControl.Width;\r\n end;\r\n ALeft := ALeft + AOffset;\r\n end;\r\n end;\r\n\r\nbegin\r\n if not Assigned(Parent) then\r\n Exit;\r\n if FButtonBarHeight > ciButtonHeight then\r\n begin\r\n AButtonSet := [bkBack, bkNext, bkCancel];\r\n if Assigned(FActivePage) then\r\n begin\r\n AButtonSet := FActivePage.FVisibleButtons;\r\n if csDesigning in ComponentState then\r\n begin\r\n Include(AButtonSet, bkBack);\r\n Include(AButtonSet, bkNext);\r\n Exclude(AButtonSet, bkFinish);\r\n end;\r\n end;\r\n ATop := ClientRect.Bottom - FButtonBarHeight + ciButtonPlacement + 2;\r\n { Position left side buttons }\r\n ALeft := ClientRect.Left + ciButtonPlacement;\r\n LocateButton(bkHelp, ciButtonPlacement + 2);\r\n LocateButton(bkStart, 1);\r\n LocateButton(bkLast, 0);\r\n { Position right side buttons }\r\n ALeft := ClientRect.Right - ciButtonPlacement;\r\n if [bkNext, bkFinish] * AButtonSet = [bkNext, bkFinish] then\r\n begin\r\n LocateButton(bkCancel, -1);\r\n LocateButton(bkFinish, -ciButtonPlacement - 2);\r\n end\r\n else\r\n begin\r\n LocateButton(bkCancel, -ciButtonPlacement - 2);\r\n LocateButton(bkFinish, -1);\r\n end;\r\n LocateButton(bkNext, -2);\r\n LocateButton(bkBack, 0);\r\n end\r\n else // Hide all buttons\r\n begin\r\n for AButtonKind := Low(TJvWizardButtonKind) to High(TJvWizardButtonKind) do\r\n with FNavigateButtons[AButtonKind] do\r\n FControl.SetBounds(0, 0, FControl.Width, 0); // Must keep the width\r\n end;\r\nend;\r\n\r\nprocedure TJvWizard.GetChildren(Proc: TGetChildProc; Root: TComponent);\r\nvar\r\n I: Integer;\r\n Control: TControl;\r\nbegin\r\n { Force the wizard to load its pages in page order. }\r\n for I := 0 to FPages.Count - 1 do\r\n Proc(TComponent(FPages[I]));\r\n { Load other controls, otherwise, those controls won't show up in\r\n the wizard. }\r\n for I := 0 to ControlCount - 1 do\r\n begin\r\n Control := Controls[I];\r\n { Because all the pages are already loaded, so here we do NOT need to\r\n load them again, otherwise it will cause 'duplicate component name'\r\n error. }\r\n if not (Control is TJvWizardCustomPage) and (Control.Owner = Root) then\r\n Proc(Control);\r\n end;\r\nend;\r\n\r\nprocedure TJvWizard.Notification(AComponent: TComponent; Operation: TOperation);\r\nbegin\r\n inherited Notification(AComponent, Operation);\r\n if (Operation = opRemove) and (AComponent = FHeaderImages) then\r\n SetHeaderImages(nil);\r\nend;\r\n\r\nprocedure TJvWizard.ImageListChange;\r\nbegin\r\n if HandleAllocated and (Sender = FHeaderImages) and Assigned(FActivePage) then\r\n FActivePage.Invalidate;\r\nend;\r\n\r\nprocedure TJvWizard.ShowControl(AControl: TControl);\r\nbegin\r\n if (AControl is TJvWizardCustomPage) and (TJvWizardCustomPage(AControl).Wizard = Self) then\r\n SetActivePage(TJvWizardCustomPage(AControl));\r\n inherited ShowControl(AControl);\r\nend;\r\n\r\nprocedure TJvWizard.Resize;\r\nbegin\r\n RepositionButtons;\r\n inherited Resize;\r\nend;\r\n\r\nfunction TJvWizard.IsForward(const FromPage, ToPage: TJvWizardCustomPage): Boolean;\r\nbegin\r\n if Assigned(FromPage) and Assigned(ToPage) and (FromPage.Wizard <> ToPage.Wizard) then\r\n raise EJvWizardError.CreateRes(@RsEInvalidWizardPage);\r\n Result := not Assigned(FromPage) or (Assigned(ToPage) and (FromPage.PageIndex < ToPage.PageIndex));\r\nend;\r\n\r\nprocedure TJvWizard.SetAutoHideButtonBar(const Value: Boolean);\r\nbegin\r\n if FAutoHideButtonBar <> Value then\r\n begin\r\n FAutoHideButtonBar := Value;\r\n RepositionButtons;\r\n UpdateButtonsStatus;\r\n end;\r\nend;\r\n\r\nfunction TJvWizard.GetWizardPages(Index: Integer): TJvWizardCustomPage;\r\nbegin\r\n Result := TJvWizardCustomPage(Pages[Index]);\r\nend;\r\n\r\nprocedure TJvWizard.DoActivePageChanged;\r\nbegin\r\n if Assigned(FOnActivePageChanged) then\r\n FOnActivePageChanged(Self);\r\nend;\r\n\r\nprocedure TJvWizard.DoActivePageChanging(var ToPage: TJvWizardCustomPage);\r\nbegin\r\n if Assigned(FOnActivePageChanging) then\r\n FOnActivePageChanging(Self, ToPage);\r\nend;\r\n\r\nprocedure TJvWizard.SetDefaultButtons(const Value: Boolean);\r\nbegin\r\n if Value <> FDefaultButtons then\r\n begin\r\n FDefaultButtons := Value;\r\n UpdateButtonsStatus;\r\n end;\r\nend;\r\n\r\nfunction TJvWizard.GetNavigateButtons(Index: Integer): TJvWizardNavigateButton;\r\nbegin\r\n Result := FNavigateButtons[TJvWizardButtonKind(Index)];\r\nend;\r\n\r\nprocedure TJvWizard.SetNavigateButtons(Index: Integer; Value: TJvWizardNavigateButton);\r\nbegin\r\n FNavigateButtons[TJvWizardButtonKind(Index)] := Value;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvWizardCommon.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvWizardCommom.PAS, released on 2001-12-23.\r\n\r\nThe Initial Developer of the Original Code is William Yu Wei.\r\nPortions created by William Yu Wei are Copyright (C) 2001 William Yu Wei.\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\nPeter Thrnqvist - converted to JVCL naming conventions on 2003-07-11\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nPurpose:\r\n All common functions and procedures which used by all components\r\n\r\nHistory:\r\n 12/23/2001 First Create, introduce TKSide, TKSides, TJvWizardFrameStyle,\r\n beAllSides, TKDeleteItemEvent\r\n function KDrawSides, KDrawBevel, KDrawFrame\r\n 12/25/2001 introduced TKMessageLevel\r\n 01/04/2001 Add function KDrawBorderSides\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvWizardCommon.pas 13104 2011-09-07 06:50:43Z obones $\r\n\r\nunit JvWizardCommon;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, Controls, Graphics, Types, Classes, SysUtils;\r\n\r\nconst\r\n beAllEdges = [beLeft, beTop, beRight, beBottom];\r\n\r\ntype\r\n TJvWizardFrameStyle =\r\n (fsWindows, fsNone, fsFlat, fsGroove, fsBump, fsLowered, fsRaised);\r\n TJvWizardImageAlignment = (iaLeft, iaRight, iaCenter, iaStretch);\r\n TJvWizardImageLeftRight = iaLeft..iaRight;\r\n TJvWizardImageLayout = (ilTop, ilBottom, ilCenter, ilStretch, ilTile);\r\n EJvWizardError = class(Exception);\r\n\r\nfunction JvWizardDrawEdges(ACanvas: TCanvas; ABounds: TRect;\r\n ULColor, LRColor: TColor; AEdges: TBevelEdges): TRect;\r\n\r\nfunction JvWizardDrawBorderEdges(ACanvas: TCanvas; ABounds: TRect;\r\n AStyle: TJvWizardFrameStyle; AEdges: TBevelEdges): TRect;\r\n\r\nprocedure JvWizardDrawImage(ACanvas: TCanvas; AGraphic: TGraphic; ARect: TRect;\r\n Align: TJvWizardImageAlignment; ALayout: TJvWizardImageLayout);\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvWizardCommon.pas $';\r\n Revision: '$Revision: 13104 $';\r\n Date: '$Date: 2011-09-07 08:50:43 +0200 (mer. 07 sept. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n {$IFDEF HAS_UNIT_SYSTEM_UITYPES}\r\n System.UITypes,\r\n {$ENDIF HAS_UNIT_SYSTEM_UITYPES}\r\n JvResources;\r\n\r\nconst\r\n { Frame Style Color constant arrays }\r\n KULFrameColor: array [TJvWizardFrameStyle] of TColor = (clNone, clWindow,\r\n clWindowFrame, clBtnShadow, clBtnHighlight, clBtnShadow, clBlack);\r\n\r\n KLRFrameColor: array [TJvWizardFrameStyle] of TColor = (clNone, clBtnFace,\r\n clWindowFrame, clBtnHighlight, clBtnShadow, clBtnHighlight, clBtnFace);\r\n\r\n{-----------------------------------------------------------------------------\r\n Procedure: JvWizardDrawEdges\r\n Author: yuwei\r\n Date: December 23, 2001\r\n Time: 17:22:42\r\n Purpose: Draw a frame with specified the borders on the specified bounds\r\n of the canvas.\r\n Arguments:\r\n ACanvas: TCanvas;\r\n the canvas where it draws the sides.\r\n ABounds: TRect;\r\n the bounds of the canvas for drawing.\r\n ULColor: TColor;\r\n the left and top side color.\r\n LRColor: TColor;\r\n the right and bottom side color.\r\n ASides: TBevelEdges;\r\n which sides it can draw on the canvas.\r\n Result:\r\n TRect:\r\n The bounds within the sides after drawing.\r\n See also:\r\n\r\n History:\r\n ---------------------------------------------------------------------------\r\n Date(mm/dd/yy) Comments\r\n ---------------------------------------------------------------------------\r\n 12/23/2001 First Release\r\n-----------------------------------------------------------------------------}\r\n\r\nfunction JvWizardDrawEdges(ACanvas: TCanvas; ABounds: TRect;\r\n ULColor, LRColor: TColor; AEdges: TBevelEdges): TRect;\r\nbegin\r\n with ACanvas do\r\n begin\r\n Pen.Style := psSolid;\r\n Pen.Mode := pmCopy;\r\n Pen.Color := ULColor;\r\n if beLeft in AEdges then\r\n begin\r\n MoveTo(ABounds.Left, ABounds.Top);\r\n LineTo(ABounds.Left, ABounds.Bottom);\r\n end;\r\n if beTop in AEdges then\r\n begin\r\n MoveTo(ABounds.Left, ABounds.Top);\r\n LineTo(ABounds.Right, ABounds.Top);\r\n end;\r\n Pen.Color := LRColor;\r\n if beRight in AEdges then\r\n begin\r\n MoveTo(ABounds.Right - 1, ABounds.Top);\r\n LineTo(ABounds.Right - 1, ABounds.Bottom);\r\n end;\r\n if beBottom in AEdges then\r\n begin\r\n MoveTo(ABounds.Left, ABounds.Bottom - 1);\r\n LineTo(ABounds.Right, ABounds.Bottom - 1);\r\n end;\r\n end;\r\n if beLeft in AEdges then\r\n Inc(ABounds.Left);\r\n if beTop in AEdges then\r\n Inc(ABounds.Top);\r\n if beRight in AEdges then\r\n Dec(ABounds.Right);\r\n if beBottom in AEdges then\r\n Dec(ABounds.Bottom);\r\n Result := ABounds;\r\nend;\r\n\r\nfunction JvWizardDrawBorderEdges(ACanvas: TCanvas; ABounds: TRect;\r\n AStyle: TJvWizardFrameStyle; AEdges: TBevelEdges): TRect;\r\nvar\r\n ULColor, LRColor: TColor;\r\n R: TRect;\r\nbegin\r\n { Draw the Frame }\r\n if not (AStyle in [fsNone, fsWindows]) then\r\n begin\r\n ULColor := KULFrameColor[AStyle];\r\n LRColor := KLRFrameColor[AStyle];\r\n if AStyle in [fsFlat] then\r\n ABounds := JvWizardDrawEdges(ACanvas, ABounds, ULColor, LRColor, AEdges)\r\n else\r\n begin\r\n R := ABounds;\r\n Inc(R.Left);\r\n Inc(R.Top);\r\n JvWizardDrawEdges(ACanvas, R, LRColor, LRColor, AEdges);\r\n OffsetRect(R, -1, -1);\r\n JvWizardDrawEdges(ACanvas, R, ULColor, ULColor, AEdges);\r\n if beLeft in AEdges then\r\n Inc(ABounds.Left, 2);\r\n if beTop in AEdges then\r\n Inc(ABounds.Top, 2);\r\n if beRight in AEdges then\r\n Dec(ABounds.Right, 2);\r\n if beBottom in AEdges then\r\n Dec(ABounds.Bottom, 2);\r\n end;\r\n end;\r\n Result := ABounds;\r\nend;\r\n\r\nprocedure JvWizardDrawTiled(ACanvas: TCanvas; AGraphic: TGraphic; ARect: TRect);\r\nvar\r\n AWidth, AHeight: Integer;\r\n Bmp: Graphics.TBitmap;\r\nbegin\r\n\r\n if not Assigned(AGraphic) or (AGraphic.Width = 0) or (AGraphic.Height = 0) then\r\n raise EJvWizardError.CreateRes(@RsETilingError);\r\n // Create a temporary bitmap to draw into. This is both to speed things up a bit\r\n // and also to clip the image to the ARect param (using Draw doesn't clip the image,\r\n // but it does support auto-detecting transparency)\r\n Bmp := {Graphics.}TBitmap.Create;\r\n try\r\n Bmp.Width := ARect.Right - ARect.Left;\r\n Bmp.Height := ARect.Bottom - ARect.Top;\r\n Bmp.Canvas.Brush.Color := ACanvas.Brush.Color;\r\n Bmp.Canvas.FillRect(Bmp.Canvas.ClipRect);\r\n AWidth := 0;\r\n while AWidth <= Bmp.Width do\r\n begin\r\n AHeight := 0;\r\n while AHeight <= Bmp.Height do\r\n begin\r\n Bmp.Canvas.Draw(AWidth, AHeight, AGraphic);\r\n Inc(AHeight, AGraphic.Height);\r\n end;\r\n Inc(AWidth, AGraphic.Width);\r\n end;\r\n BitBlt(ACanvas.Handle, ARect.Left, ARect.Top, Bmp.Width, Bmp.Height,\r\n Bmp.Canvas.Handle, 0, 0, SRCCOPY);\r\n finally\r\n Bmp.Free;\r\n end;\r\nend;\r\n\r\nprocedure JvWizardDrawImage(ACanvas: TCanvas; AGraphic: TGraphic; ARect: TRect;\r\n Align: TJvWizardImageAlignment; ALayout: TJvWizardImageLayout);\r\nvar\r\n Offset: TPoint;\r\n AWidth, AHeight: Integer;\r\nbegin\r\n if Assigned(AGraphic) then\r\n begin\r\n if ALayout = ilTile then\r\n begin\r\n JvWizardDrawTiled(ACanvas, AGraphic, ARect);\r\n Exit;\r\n end;\r\n Offset := Point(0, 0);\r\n AWidth := ARect.Right - ARect.Left;\r\n AHeight := ARect.Bottom - ARect.Top;\r\n if (Align in [iaCenter, iaRight]) and (AWidth > AGraphic.Width) then\r\n begin\r\n Offset.X := AWidth - AGraphic.Width;\r\n if Align = iaCenter then\r\n begin\r\n Offset.X := Offset.X div 2;\r\n ARect.Right := ARect.Right - Offset.X;\r\n end;\r\n end;\r\n if (ALayout in [ilCenter, ilBottom]) and (AHeight > AGraphic.Height) then\r\n begin\r\n Offset.Y := AHeight - AGraphic.Height;\r\n if ALayout = ilCenter then\r\n begin\r\n Offset.Y := Offset.Y div 2;\r\n ARect.Bottom := ARect.Bottom - Offset.Y;\r\n end;\r\n end;\r\n if (ALayout = ilTop) and (AHeight > AGraphic.Height) then\r\n ARect.Bottom := ARect.Top + AGraphic.Height;\r\n if (Align = iaLeft) and (AWidth > AGraphic.Width) then\r\n ARect.Right := ARect.Left + AGraphic.Width;\r\n ARect.Left := ARect.Left + Offset.X;\r\n ARect.Top := ARect.Top + Offset.Y;\r\n if (Align = iaStretch) or (ALayout = ilStretch) then\r\n ACanvas.StretchDraw(ARect, AGraphic)\r\n else\r\n ACanvas.Draw(ARect.Left, ARect.Top, AGraphic);\r\n end;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvWizardRouteMapList.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvWizardRouteMapList.PAS, released on 2004-02-14.\r\n\r\nThe Initial Developer of the Original Code is Peter Thornqvist.\r\nPortions created by Peter Thornqvist are Copyright (C) 2004 Peter Thornqvist\r\n\r\nContributor(s):\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nPurpose:\r\n Route map that displays pages as a list\r\n\r\nHistory:\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvWizardRouteMapList.pas 13138 2011-10-26 23:17:50Z jfudickar $\r\n\r\nunit JvWizardRouteMapList;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n SysUtils, Classes,\r\n Windows, Messages, Graphics, Controls, Forms,\r\n JvTypes, JvJVCLUtils,\r\n JvWizard;\r\n\r\ntype\r\n TJvWizardDrawRouteMapListItem = procedure(Sender: TObject; ACanvas: TCanvas;\r\n ARect: TRect; MousePos: TPoint; PageIndex: Integer; var DefaultDraw: Boolean) of object;\r\n TRouteMapListItemText = (itNone, itCaption, itTitle, itSubtitle);\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvWizardRouteMapList = class(TJvWizardRouteMapControl)\r\n private\r\n FItemHeight: Integer;\r\n FVertOffset: Integer;\r\n FHorzOffset: Integer;\r\n FClickable: Boolean;\r\n FIncludeDisabled: Boolean;\r\n FHotTrackFont: TFont;\r\n FActiveFont: TFont;\r\n FHotTrackCursor, FOldCursor: TCursor;\r\n FOnDrawItem: TJvWizardDrawRouteMapListItem;\r\n FAlignment: TAlignment;\r\n FTextOffset: Integer;\r\n FShowImages: Boolean;\r\n FItemColor: TColor;\r\n FRounded: Boolean;\r\n FItemText: TRouteMapListItemText;\r\n FHotTrack: Boolean;\r\n FCurvature: Integer;\r\n FHotTrackBorder: Integer;\r\n FBorderColor: TColor;\r\n FTextOnly: Boolean;\r\n FHotTrackFontOptions: TJvTrackFontOptions;\r\n FActiveFontOptions: TJvTrackFontOptions;\r\n procedure SetItemHeight(const Value: Integer);\r\n procedure SetHorzOffset(const Value: Integer);\r\n procedure SetVertOffset(const Value: Integer);\r\n procedure SetIncludeDisabled(const Value: Boolean);\r\n procedure SetActiveFont(const Value: TFont);\r\n procedure SetHotTrackFont(const Value: TFont);\r\n procedure DoFontChange(Sender: TObject);\r\n procedure SetAlignment(const Value: TAlignment);\r\n procedure SetTextOffset(const Value: Integer);\r\n procedure SetShowImages(const Value: Boolean);\r\n procedure SetItemColor(const Value: TColor);\r\n procedure SetRounded(const Value: Boolean);\r\n procedure SetItemText(const Value: TRouteMapListItemText);\r\n procedure SetCurvature(const Value: Integer);\r\n procedure SetTextOnly(const Value: Boolean);\r\n procedure SetBorderColor(Value: TColor);\r\n procedure SetActiveFontOptions(const Value: TJvTrackFontOptions);\r\n procedure SetHotTrackFontOptions(const Value: TJvTrackFontOptions);\r\n protected\r\n procedure DrawPageItem(ACanvas: TCanvas; ARect: TRect; MousePos: TPoint; PageIndex: Integer); virtual;\r\n procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;\r\n function PageAtPos(Pt: TPoint): TJvWizardCustomPage; override;\r\n procedure Paint; override;\r\n procedure Loaded; override;\r\n procedure CMCursorChanged(var Msg: TMessage); message CM_CURSORCHANGED;\r\n procedure CMFontChanged(var Msg: TMessage); message CM_FONTCHANGED;\r\n procedure CursorChanged;\r\n procedure FontChanged;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n published\r\n property ActiveFont: TFont read FActiveFont write SetActiveFont;\r\n property ActiveFontOptions: TJvTrackFontOptions read FActiveFontOptions write SetActiveFontOptions default\r\n DefaultTrackFontOptions;\r\n property Alignment: TAlignment read FAlignment write SetAlignment default taCenter;\r\n property Clickable: Boolean read FClickable write FClickable default True;\r\n property Color default $00C08000;\r\n property Curvature: Integer read FCurvature write SetCurvature default 9;\r\n property Font;\r\n property HorzOffset: Integer read FHorzOffset write SetHorzOffset default 8;\r\n property HotTrackBorder: Integer read FHotTrackBorder write FHotTrackBorder default 2;\r\n property HotTrackCursor: TCursor read FHotTrackCursor write FHotTrackCursor default crHandPoint;\r\n property HotTrack: Boolean read FHotTrack write FHotTrack default True;\r\n\r\n property HotTrackFont: TFont read FHotTrackFont write SetHotTrackFont;\r\n property HotTrackFontOptions: TJvTrackFontOptions read FHotTrackFontOptions write SetHotTrackFontOptions default\r\n DefaultTrackFontOptions;\r\n property Image;\r\n property TextOnly: Boolean read FTextOnly write SetTextOnly default False;\r\n property IncludeDisabled: Boolean read FIncludeDisabled write SetIncludeDisabled default False;\r\n property BorderColor: TColor read FBorderColor write SetBorderColor default clNavy;\r\n property ItemColor: TColor read FItemColor write SetItemColor default clCream;\r\n property ItemHeight: Integer read FItemHeight write SetItemHeight default 25;\r\n property ItemText: TRouteMapListItemText read FItemText write SetItemText default itCaption;\r\n property Rounded: Boolean read FRounded write SetRounded default False;\r\n property ShowImages: Boolean read FShowImages write SetShowImages default False;\r\n property TextOffset: Integer read FTextOffset write SetTextOffset default 8;\r\n property VertOffset: Integer read FVertOffset write SetVertOffset default 8;\r\n property OnDrawItem: TJvWizardDrawRouteMapListItem read FOnDrawItem write FOnDrawItem;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvWizardRouteMapList.pas $';\r\n Revision: '$Revision: 13138 $';\r\n Date: '$Date: 2011-10-27 01:17:50 +0200 (jeu. 27 oct. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nconstructor TJvWizardRouteMapList.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FActiveFont := TFont.Create;\r\n FActiveFont.Style := [fsBold];\r\n FActiveFont.OnChange := DoFontChange;\r\n FHotTrackFont := TFont.Create;\r\n FHotTrackFont.Color := clNavy;\r\n FHotTrackFont.Style := [fsUnderline];\r\n FHotTrackFont.OnChange := DoFontChange;\r\n FActiveFontOptions := DefaultTrackFontOptions;\r\n FHotTrackFontOptions := DefaultTrackFontOptions;\r\n Color := $00C08000;\r\n FHotTrackCursor := crHandPoint;\r\n FVertOffset := 8;\r\n FHorzOffset := 8;\r\n FItemHeight := 25;\r\n FClickable := True;\r\n FAlignment := taCenter;\r\n FTextOffset := 8;\r\n FBorderColor := clNavy;\r\n FItemColor := clCream;\r\n FItemText := itCaption;\r\n FHotTrack := True;\r\n FCurvature := 9;\r\n FHotTrackBorder := 2;\r\n FTextOnly := False;\r\nend;\r\n\r\ndestructor TJvWizardRouteMapList.Destroy;\r\nbegin\r\n FHotTrackFont.Free;\r\n FActiveFont.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvWizardRouteMapList.Loaded;\r\nbegin\r\n inherited Loaded;\r\n FOldCursor := Cursor;\r\nend;\r\n\r\nprocedure TJvWizardRouteMapList.MouseMove(Shift: TShiftState;\r\n X, Y: Integer);\r\nvar\r\n P: TJvWizardCustomPage;\r\nbegin\r\n inherited MouseMove(Shift, X, Y);\r\n if Clickable and HotTrack then\r\n begin\r\n P := PageAtPos(Point(X, Y));\r\n if (P <> nil) and P.Enabled then\r\n begin\r\n if Cursor <> FHotTrackCursor then\r\n FOldCursor := Cursor;\r\n Cursor := FHotTrackCursor;\r\n Refresh;\r\n end\r\n else\r\n if Cursor <> FOldCursor then\r\n begin\r\n Cursor := FOldCursor;\r\n Refresh;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJvWizardRouteMapList.PageAtPos(Pt: TPoint): TJvWizardCustomPage;\r\nvar\r\n R: TRect;\r\n I: Integer;\r\nbegin\r\n Result := nil;\r\n if not Clickable then\r\n Exit;\r\n R := ClientRect;\r\n InflateRect(R, -HorzOffset, -VertOffset);\r\n R.Bottom := R.Top + ItemHeight;\r\n for I := 0 to PageCount - 1 do\r\n begin\r\n if Pages[I].Enabled or IncludeDisabled then\r\n begin\r\n if PtInRect(R, Pt) then\r\n begin\r\n Result := Pages[I];\r\n Exit;\r\n end;\r\n OffsetRect(R, 0, ItemHeight);\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvWizardRouteMapList.Paint;\r\nvar\r\n I: Integer;\r\n R: TRect;\r\n P: TPoint;\r\nbegin\r\n Canvas.Brush.Style := bsSolid;\r\n Canvas.Brush.Color := Color;\r\n if BorderColor = clNone then\r\n Canvas.Pen.Color := Color\r\n else\r\n Canvas.Pen.Color := BorderColor;\r\n GetCursorPos(P);\r\n P := ScreenToClient(P);\r\n R := ClientRect;\r\n if not HasPicture then\r\n Canvas.Rectangle(R)\r\n else\r\n Image.PaintTo(Canvas, R);\r\n if ItemHeight <= 0 then\r\n Exit;\r\n InflateRect(R, -HorzOffset, -VertOffset);\r\n R.Bottom := R.Top + ItemHeight;\r\n for I := 0 to PageCount - 1 do\r\n if Pages[I].Enabled or IncludeDisabled then\r\n begin\r\n DrawPageItem(Canvas, R, P, I);\r\n OffsetRect(R, 0, ItemHeight);\r\n if R.Bottom >= ClientHeight - 2 then\r\n Break;\r\n end;\r\nend;\r\n\r\nprocedure TJvWizardRouteMapList.DrawPageItem(ACanvas: TCanvas; ARect: TRect; MousePos: TPoint; PageIndex: Integer);\r\nconst\r\n cAlignment: array [TAlignment] of Cardinal = (DT_LEFT, DT_RIGHT, DT_CENTER);\r\n cWordWrap: array [Boolean] of Cardinal = (DT_SINGLELINE, DT_WORDBREAK);\r\nvar\r\n DefaultDraw: Boolean;\r\n ATop, ALeft: Integer;\r\n AOrigRect: TRect;\r\n BkColor: TColor;\r\n S: string;\r\nbegin\r\n ACanvas.Lock;\r\n try\r\n AOrigRect := ARect;\r\n ACanvas.Font := Font;\r\n if Assigned(Wizard) and (Pages[PageIndex] = Wizard.ActivePage) then\r\n ACanvas.Font := ActiveFont\r\n else\r\n if PtInRect(ARect, MousePos) and Pages[PageIndex].Enabled and HotTrack and Clickable then\r\n ACanvas.Font := HotTrackFont\r\n else\r\n if not Pages[PageIndex].Enabled then\r\n ACanvas.Font.Color := clGrayText;\r\n\r\n ACanvas.Brush.Color := ItemColor;\r\n ACanvas.Pen.Color := Color;\r\n DefaultDraw := True;\r\n if Assigned(FOnDrawItem) then\r\n FOnDrawItem(Self, ACanvas, ARect, MousePos, PageIndex, DefaultDraw);\r\n if DefaultDraw then\r\n begin\r\n case ItemText of\r\n itCaption:\r\n S := Pages[PageIndex].Caption;\r\n itTitle:\r\n S := Pages[PageIndex].Title.Text;\r\n itSubtitle:\r\n S := Pages[PageIndex].Subtitle.Text;\r\n end;\r\n\r\n if not TextOnly then\r\n begin\r\n if ItemColor = clNone then\r\n ACanvas.Brush.Style := bsClear;\r\n if Rounded then\r\n ACanvas.RoundRect(ARect.Left, ARect.Top, ARect.Right, ARect.Bottom, Curvature, Curvature)\r\n else\r\n ACanvas.Rectangle(ARect);\r\n if ShowImages and Assigned(Wizard) and Assigned(Wizard.HeaderImages) then\r\n begin\r\n ATop := ((ARect.Bottom - ARect.Top) - Wizard.HeaderImages.Height) div 2;\r\n BkColor := ACanvas.Brush.Color;\r\n case Alignment of\r\n taLeftJustify:\r\n begin\r\n Wizard.HeaderImages.Draw(ACanvas, ARect.Left + 4, ARect.Top + ATop, Pages[PageIndex].Header.ImageIndex, Pages[PageIndex].Enabled);\r\n Inc(ARect.Left, Wizard.HeaderImages.Width + 4);\r\n end;\r\n taRightJustify:\r\n begin\r\n Wizard.HeaderImages.Draw(ACanvas, ARect.Right - Wizard.HeaderImages.Width - 4, ARect.Top + ATop,\r\n Pages[PageIndex].Header.ImageIndex, Pages[PageIndex].Enabled);\r\n Dec(ARect.Right, Wizard.HeaderImages.Width + 4);\r\n end;\r\n taCenter:\r\n begin\r\n ALeft := ((ARect.Right - ARect.Left) - Wizard.HeaderImages.Width) div 2;\r\n Inc(ARect.Top, 4);\r\n Wizard.HeaderImages.Draw(ACanvas, ARect.Left + ALeft, ARect.Top + 8,\r\n Pages[PageIndex].Header.ImageIndex, Pages[PageIndex].Enabled);\r\n Inc(ARect.Top, Wizard.HeaderImages.Height);\r\n // if ItemText = itSubtitle then\r\n // Inc(ARect.Top, 16);\r\n end;\r\n end;\r\n if not Pages[PageIndex].Enabled then\r\n begin\r\n // (p3) TImageList changes the canvas colors when drawing disabled images, so we reset them explicitly\r\n SetBkColor(ACanvas.Handle, BkColor);\r\n SetTextColor(ACanvas.Handle, ColorToRGB(clGrayText));\r\n end;\r\n end;\r\n end\r\n else\r\n ACanvas.Brush.Style := bsClear;\r\n\r\n case Alignment of\r\n taLeftJustify:\r\n Inc(ARect.Left, TextOffset);\r\n taRightJustify:\r\n Dec(ARect.Right, TextOffset);\r\n taCenter:\r\n InflateRect(ARect, -TextOffset div 2, -TextOffset div 2);\r\n end;\r\n if ItemText = itSubtitle then\r\n begin\r\n Inc(ARect.Top, TextOffset);\r\n InflateRect(ARect, -TextOffset, 0);\r\n end;\r\n if (ItemText <> itNone) and ((ARect.Bottom - ARect.Top) > abs(ACanvas.Font.Height)) then\r\n DrawText(ACanvas.Handle, PChar(S), Length(S), ARect,\r\n cAlignment[Alignment] or cWordWrap[ItemText = itSubtitle] or DT_VCENTER or DT_EDITCONTROL or DT_EXTERNALLEADING or DT_END_ELLIPSIS);\r\n if not TextOnly and HotTrack and (HotTrackBorder > 0) and PtInRect(AOrigRect, MousePos) then\r\n begin\r\n ACanvas.Brush.Style := bsClear;\r\n ACanvas.Pen.Color := HotTrackFont.Color;\r\n ACanvas.Pen.Width := HotTrackBorder;\r\n if Rounded then\r\n ACanvas.RoundRect(AOrigRect.Left, AOrigRect.Top, AOrigRect.Right, AOrigRect.Bottom, Curvature, Curvature)\r\n else\r\n ACanvas.Rectangle(AOrigRect);\r\n ACanvas.Brush.Style := bsSolid;\r\n ACanvas.Pen.Width := 1;\r\n end;\r\n end;\r\n finally\r\n ACanvas.Unlock;\r\n end;\r\nend;\r\n\r\nprocedure TJvWizardRouteMapList.SetHorzOffset(const Value: Integer);\r\nbegin\r\n if FHorzOffset <> Value then\r\n begin\r\n FHorzOffset := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvWizardRouteMapList.SetItemHeight(const Value: Integer);\r\nbegin\r\n if FItemHeight <> Value then\r\n begin\r\n FItemHeight := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvWizardRouteMapList.SetVertOffset(const Value: Integer);\r\nbegin\r\n if FVertOffset <> Value then\r\n begin\r\n FVertOffset := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvWizardRouteMapList.SetIncludeDisabled(const Value: Boolean);\r\nbegin\r\n if FIncludeDisabled <> Value then\r\n begin\r\n FIncludeDisabled := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvWizardRouteMapList.SetActiveFont(const Value: TFont);\r\nbegin\r\n FActiveFont.Assign(Value);\r\nend;\r\n\r\nprocedure TJvWizardRouteMapList.SetHotTrackFont(const Value: TFont);\r\nbegin\r\n FHotTrackFont.Assign(Value);\r\nend;\r\n\r\nprocedure TJvWizardRouteMapList.DoFontChange(Sender: TObject);\r\nbegin\r\n Invalidate;\r\nend;\r\n\r\n\r\n\r\nprocedure TJvWizardRouteMapList.CMCursorChanged(var Msg: TMessage);\r\nbegin\r\n inherited;\r\n CursorChanged;\r\nend;\r\n\r\nprocedure TJvWizardRouteMapList.CMFontChanged(var Msg: TMessage);\r\nbegin\r\n inherited;\r\n FontChanged;\r\nend;\r\n\r\n\r\n\r\nprocedure TJvWizardRouteMapList.SetAlignment(const Value: TAlignment);\r\nbegin\r\n if FAlignment <> Value then\r\n begin\r\n FAlignment := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvWizardRouteMapList.SetTextOffset(const Value: Integer);\r\nbegin\r\n if FTextOffset <> Value then\r\n begin\r\n FTextOffset := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvWizardRouteMapList.SetShowImages(const Value: Boolean);\r\nbegin\r\n if FShowImages <> Value then\r\n begin\r\n FShowImages := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvWizardRouteMapList.SetItemColor(const Value: TColor);\r\nbegin\r\n if FItemColor <> Value then\r\n begin\r\n FItemColor := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvWizardRouteMapList.SetRounded(const Value: Boolean);\r\nbegin\r\n if FRounded <> Value then\r\n begin\r\n FRounded := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvWizardRouteMapList.SetItemText(const Value: TRouteMapListItemText);\r\nbegin\r\n if FItemText <> Value then\r\n begin\r\n FItemText := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvWizardRouteMapList.SetCurvature(const Value: Integer);\r\nbegin\r\n if FCurvature <> Value then\r\n begin\r\n FCurvature := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvWizardRouteMapList.SetActiveFontOptions(const Value: TJvTrackFontOptions);\r\nbegin\r\n if FActiveFontOptions <> Value then\r\n begin\r\n FActiveFontOptions := Value;\r\n UpdateTrackFont(ActiveFont, Font, FActiveFontOptions);\r\n end;\r\nend;\r\n\r\nprocedure TJvWizardRouteMapList.SetHotTrackFontOptions(const Value: TJvTrackFontOptions);\r\nbegin\r\n if FHotTrackFontOptions <> Value then\r\n begin\r\n FHotTrackFontOptions := Value;\r\n UpdateTrackFont(HotTrackFont, Font, FHotTrackFontOptions);\r\n end;\r\nend;\r\n\r\nprocedure TJvWizardRouteMapList.SetBorderColor(Value: TColor);\r\nbegin\r\n if Value <> FBorderColor then\r\n begin\r\n FBorderColor := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvWizardRouteMapList.SetTextOnly(const Value: Boolean);\r\nbegin\r\n if Value <> FTextOnly then\r\n begin\r\n FTextOnly := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvWizardRouteMapList.CursorChanged;\r\nbegin\r\n if (Cursor <> FHotTrackCursor) and (Cursor <> FOldCursor) then\r\n FOldCursor := Cursor;\r\nend;\r\n\r\nprocedure TJvWizardRouteMapList.FontChanged;\r\nbegin\r\n UpdateTrackFont(HotTrackFont, Font, FHotTrackFontOptions);\r\n UpdateTrackFont(ActiveFont, Font, FActiveFontOptions);\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvWizardRouteMapNodes.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvWizardRouteMapNodes.PAS, released on 2002-02-05.\r\n\r\nThe Initial Developer of the Original Code is Steve Forbes.\r\nPortions created by Steve Forbes are Copyright (C) 2002 Steve Forbes.\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\nPeter Thrnqvist - converted to JVCL naming conventions on 2003-07-11\r\nS Steed. - added AllowClickableNodes property\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nDescription:\r\n Nodes style route map for TJvWizardRouteMap\r\n\r\nHistory:\r\n10/14/2003\r\n Added option to allow user to turn off the clicking of the nodes\r\n during runtime. S Steed.\r\n05/02/2002\r\n Initial create\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvWizardRouteMapNodes.pas 13138 2011-10-26 23:17:50Z jfudickar $\r\n\r\nunit JvWizardRouteMapNodes;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Classes, Windows, Messages, Graphics,\r\n JvWizard;\r\n\r\ntype\r\n TJvWizardRouteMapNodes = class;\r\n\r\n TJvWizardRouteMapNodeColors = class(TPersistent)\r\n private\r\n FSelected: TColor;\r\n FUnselected: TColor;\r\n FDisabled: TColor;\r\n FLine: TColor;\r\n FRouteMap: TJvWizardRouteMapNodes;\r\n protected\r\n procedure SetLine(Value: TColor);\r\n procedure SetSelected(Value: TColor);\r\n procedure SetUnselected(Value: TColor);\r\n procedure SetDisabled(Value: TColor);\r\n procedure Changed;\r\n public\r\n constructor Create(ARouteMap: TJvWizardRouteMapNodes);\r\n published\r\n property Selected: TColor read FSelected write SetSelected default clLime;\r\n property Unselected: TColor read FUnselected write SetUnselected default clWhite;\r\n property Line: TColor read FLine write SetLine default clBtnShadow;\r\n property Disabled: TColor read FDisabled write SetDisabled default clBtnFace;\r\n end;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvWizardRouteMapNodes = class(TJvWizardRouteMapControl)\r\n private\r\n FItemHeight: Integer;\r\n FUsePageTitle: Boolean;\r\n FNodeColors: TJvWizardRouteMapNodeColors;\r\n FIndent: Integer;\r\n FAllowClickableNodes: Boolean;\r\n procedure SetItemHeight(Value: Integer);\r\n procedure SetUsePageTitle(Value: Boolean);\r\n procedure SetIndent(Value: Integer);\r\n procedure SetAllowClickableNodes(const Value: Boolean);\r\n protected\r\n function PageAtPos(Pt: TPoint): TJvWizardCustomPage; override;\r\n procedure Paint; override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n published\r\n property ItemHeight: Integer read FItemHeight write SetItemHeight default 20;\r\n property AllowClickableNodes: Boolean read FAllowClickableNodes write SetAllowClickableNodes default True; // ss 10/14/2003\r\n property Align;\r\n property Color default clBackground;\r\n property Font;\r\n property Image;\r\n property Indent: Integer read FIndent write SetIndent default 8;\r\n property NodeColors: TJvWizardRouteMapNodeColors read FNodeColors write FNodeColors;\r\n property UsePageTitle: Boolean read FUsePageTitle write SetUsePageTitle default True;\r\n property OnDisplaying;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvWizardRouteMapNodes.pas $';\r\n Revision: '$Revision: 13138 $';\r\n Date: '$Date: 2011-10-27 01:17:50 +0200 (jeu. 27 oct. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\n//=== { TJvWizardRouteMapNodeColors } ========================================\r\n\r\nconstructor TJvWizardRouteMapNodeColors.Create(ARouteMap: TJvWizardRouteMapNodes);\r\nbegin\r\n inherited Create;\r\n FRouteMap := ARouteMap;\r\n FSelected := clLime;\r\n FUnselected := clWhite;\r\n FLine := clBtnShadow;\r\n FDisabled := clBtnFace;\r\nend;\r\n\r\nprocedure TJvWizardRouteMapNodeColors.Changed;\r\nbegin\r\n if Assigned(FRouteMap) then\r\n FRouteMap.Invalidate;\r\nend;\r\n\r\nprocedure TJvWizardRouteMapNodeColors.SetDisabled(Value: TColor);\r\nbegin\r\n if FDisabled <> Value then\r\n begin\r\n FDisabled := Value;\r\n Changed;\r\n end;\r\nend;\r\n\r\nprocedure TJvWizardRouteMapNodeColors.SetLine(Value: TColor);\r\nbegin\r\n if FLine <> Value then\r\n begin\r\n FLine := Value;\r\n Changed;\r\n end;\r\nend;\r\n\r\nprocedure TJvWizardRouteMapNodeColors.SetSelected(Value: TColor);\r\nbegin\r\n if FSelected <> Value then\r\n begin\r\n FSelected := Value;\r\n Changed;\r\n end;\r\nend;\r\n\r\nprocedure TJvWizardRouteMapNodeColors.SetUnselected(Value: TColor);\r\nbegin\r\n if FUnselected <> Value then\r\n begin\r\n FUnselected := Value;\r\n Changed;\r\n end;\r\nend;\r\n\r\n//=== { TJvWizardRouteMapNodes } =============================================\r\n\r\nconstructor TJvWizardRouteMapNodes.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FItemHeight := 20;\r\n Color := clBackground;\r\n Font.Color := clWhite;\r\n FUsePageTitle := True;\r\n FIndent := 8;\r\n FAllowClickableNodes := True; // ss 10/14/2003\r\n FNodeColors := TJvWizardRouteMapNodeColors.Create(Self);\r\nend;\r\n\r\ndestructor TJvWizardRouteMapNodes.Destroy;\r\nbegin\r\n FNodeColors.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJvWizardRouteMapNodes.PageAtPos(Pt: TPoint): TJvWizardCustomPage;\r\nvar\r\n I, Count: Integer;\r\n ARect: TRect;\r\nbegin\r\n if AllowClickableNodes then // ss 10/14/2003\r\n begin\r\n ARect := ClientRect;\r\n InflateRect(ARect, -1, -1);\r\n if PtInRect(ARect, Pt) then\r\n begin\r\n Count := PageCount;\r\n ARect := Bounds(ARect.Left, ARect.Top + Trunc((FItemHeight - 12) / 2),\r\n ARect.Right - ARect.Left, FItemHeight);\r\n I := 0;\r\n while I < Count do\r\n begin\r\n if CanDisplay(Pages[I]) then\r\n begin\r\n if PtInRect(ARect, Pt) then\r\n begin\r\n Result := Pages[I];\r\n Exit;\r\n end;\r\n OffsetRect(ARect, 0, FItemHeight);\r\n end;\r\n Inc(I);\r\n end;\r\n end;\r\n end;\r\n Result := nil;\r\nend;\r\n\r\nprocedure TJvWizardRouteMapNodes.Paint;\r\nvar\r\n ARect, ATextRect, NodeRect: TRect;\r\n I: Integer;\r\n AColor: TColor;\r\n AFont: TFont;\r\n IsFirstPage, IsLastPage: Boolean;\r\nbegin\r\n ARect := ClientRect;\r\n with Canvas do\r\n begin\r\n Brush.Color := Color;\r\n Brush.Style := bsSolid;\r\n Pen.Color := clBtnShadow;\r\n Pen.Width := 1;\r\n Pen.Style := psSolid;\r\n if not HasPicture then\r\n Rectangle(ARect.Left, ARect.Top, ARect.Right, ARect.Bottom)\r\n else\r\n Image.PaintTo(Canvas, ARect);\r\n InflateRect(ARect, -1, -1);\r\n AFont := TFont.Create;\r\n try\r\n AFont.Assign(Self.Font);\r\n ARect := Bounds(ARect.Left + FIndent, ARect.Top + FIndent,\r\n ARect.Right - ARect.Left - FIndent, FItemHeight);\r\n for I := 0 to PageCount - 1 do\r\n begin\r\n IsFirstPage := Wizard.IsFirstPage(Pages[I], not (csDesigning in ComponentState));\r\n IsLastPage := Wizard.IsLastPage(Pages[I], not (csDesigning in ComponentState));\r\n if CanDisplay(Pages[I]) then\r\n begin\r\n AColor := Color;\r\n if I = PageIndex then\r\n begin\r\n AFont.Color := Self.Font.Color;\r\n AFont.Style := AFont.Style + [fsBold]\r\n end\r\n else\r\n if not Pages[I].Enabled then\r\n begin\r\n AFont.Color := clBtnShadow;\r\n AFont.Style := AFont.Style - [fsBold];\r\n end\r\n else\r\n if not Pages[I].EnableJumpToPage then // Nonn...\r\n begin\r\n AFont.Color := NodeColors.Disabled;\r\n AFont.Style := AFont.Style - [fsBold]; // ... Nonn\r\n end\r\n else\r\n begin\r\n AFont.Color := Self.Font.Color;\r\n AFont.Style := AFont.Style - [fsBold]\r\n end;\r\n\r\n ATextRect := ARect;\r\n if not (IsFirstPage or IsLastPage) then\r\n ATextRect.Left := ATextRect.Left + 18;\r\n\r\n NodeRect := ATextRect;\r\n NodeRect.Right := NodeRect.Left + 12;\r\n NodeRect.Top := NodeRect.Top + Trunc((FItemHeight - 12) / 2);\r\n NodeRect.Bottom := NodeRect.Top + 12;\r\n\r\n if not (IsFirstPage or IsLastPage) then\r\n ATextRect.Left := ATextRect.Left + 20\r\n else\r\n ATextRect.Left := ATextRect.Left + 18 + 20;\r\n\r\n try\r\n Pen.Color := FNodeColors.Line;\r\n if I = PageIndex then\r\n Brush.Color := FNodeColors.Selected\r\n else\r\n if not Pages[I].EnableJumpToPage then // Nonn\r\n Brush.Color := FNodeColors.Disabled // Nonn\r\n else\r\n if Pages[I].Enabled then\r\n Brush.Color := FNodeColors.Unselected\r\n else\r\n Brush.Color := FNodeColors.Disabled;\r\n Rectangle(NodeRect.Left, NodeRect.Top, NodeRect.Right,\r\n NodeRect.Bottom);\r\n\r\n Brush.Color := FNodeColors.Line;\r\n if IsFirstPage or IsLastPage then\r\n begin\r\n MoveTo(NodeRect.Right, NodeRect.Top + 5);\r\n LineTo(NodeRect.Right + 13, NodeRect.Top + 5);\r\n MoveTo(NodeRect.Right, NodeRect.Top + 6);\r\n LineTo(NodeRect.Right + 13, NodeRect.Top + 6);\r\n if IsFirstPage then\r\n begin\r\n MoveTo(NodeRect.Right + 11, NodeRect.Top + 6);\r\n LineTo(NodeRect.Right + 11, ATextRect.Bottom);\r\n MoveTo(NodeRect.Right + 12, NodeRect.Top + 6);\r\n LineTo(NodeRect.Right + 12, ATextRect.Bottom);\r\n end\r\n else\r\n begin\r\n MoveTo(NodeRect.Right + 11, NodeRect.Top + 5);\r\n LineTo(NodeRect.Right + 11, ATextRect.Top);\r\n MoveTo(NodeRect.Right + 12, NodeRect.Top + 5);\r\n LineTo(NodeRect.Right + 12, ATextRect.Top);\r\n end;\r\n end\r\n else\r\n begin\r\n MoveTo(NodeRect.Left + 5, NodeRect.Top);\r\n LineTo(NodeRect.Left + 5, ATextRect.Top - 1);\r\n MoveTo(NodeRect.Left + 6, NodeRect.Top);\r\n LineTo(NodeRect.Left + 6, ATextRect.Top - 1);\r\n MoveTo(NodeRect.Left + 5, NodeRect.Bottom);\r\n LineTo(NodeRect.Left + 5, ATextRect.Bottom + 1);\r\n MoveTo(NodeRect.Left + 6, NodeRect.Bottom);\r\n LineTo(NodeRect.Left + 6, ATextRect.Bottom + 1);\r\n end;\r\n\r\n Brush.Color := AColor;\r\n if not HasPicture then\r\n FillRect(ATextRect)\r\n else\r\n SetBkMode(Canvas.Handle, Windows.TRANSPARENT);\r\n Brush.Style := bsClear;\r\n Font.Assign(AFont);\r\n\r\n if FUsePageTitle then\r\n DrawText(Canvas.Handle,\r\n PChar((Pages[I] as TJvWizardCustomPage).Header.Title.Text), -1,\r\n ATextRect, DT_LEFT or DT_SINGLELINE or DT_VCENTER)\r\n else\r\n DrawText(Canvas.Handle, PChar(Pages[I].Caption), -1, ATextRect,\r\n DT_LEFT or DT_SINGLELINE or DT_VCENTER);\r\n\r\n finally\r\n OffsetRect(ARect, 0, FItemHeight);\r\n end;\r\n end;\r\n end;\r\n finally\r\n AFont.Free;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvWizardRouteMapNodes.SetItemHeight(Value: Integer);\r\nbegin\r\n if FItemHeight <> Value then\r\n begin\r\n FItemHeight := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvWizardRouteMapNodes.SetUsePageTitle(Value: Boolean);\r\nbegin\r\n if FUsePageTitle <> Value then\r\n begin\r\n FUsePageTitle := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvWizardRouteMapNodes.SetIndent(Value: Integer);\r\nbegin\r\n if FIndent <> Value then\r\n begin\r\n FIndent := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvWizardRouteMapNodes.SetAllowClickableNodes(\r\n const Value: Boolean);\r\nbegin\r\n if FAllowClickableNodes <> Value then\r\n begin\r\n FAllowClickableNodes := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvWizardRouteMapSteps.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvWizardRouteMapSteps.PAS, released on 2002-02-11.\r\n\r\nThe Initial Developer of the Original Code is Max Evans.\r\nPortions created by Max Evans are Copyright (C) 2002 Max Evans\r\n\r\nContributor(s):\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nPurpose:\r\n Step style route map for TJvWizardRouteMap\r\n\r\nHistory:\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvWizardRouteMapSteps.pas 13104 2011-09-07 06:50:43Z obones $\r\n\r\nunit JvWizardRouteMapSteps;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, Messages, Types, SysUtils, Classes, Graphics, Controls, Forms,\r\n JvWizard;\r\n\r\ntype\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvWizardRouteMapSteps = class(TJvWizardRouteMapControl)\r\n private\r\n FIndent: Integer;\r\n FNextStepText: string;\r\n FActiveStepFormat: string;\r\n FPreviousStepText: string;\r\n FShowDivider: Boolean;\r\n FShowNavigators: Boolean;\r\n FShowNavigation: Boolean;\r\n FMultiline: Boolean;\r\n function GetActiveStepRect: TRect;\r\n function GetPreviousStepRect: TRect;\r\n function GetNextStepRect: TRect;\r\n function GetPreviousArrowRect: TRect;\r\n function GetNextArrowRect: TRect;\r\n procedure SetIndent(const Value: Integer);\r\n procedure SetNextStepText(const Value: string);\r\n procedure SetActiveStepFormat(const Value: string);\r\n procedure SetPreviousStepText(const Value: string);\r\n procedure SetShowDivider(const Value: Boolean);\r\n procedure SetShowNavigators(const Value: Boolean);\r\n function DetectPageCount(var ActivePageIndex: Integer): Integer; // Add by Yu Wei\r\n function DetectPage(const Pt: TPoint): TJvWizardCustomPage; // Add by Yu Wei\r\n function StoreActiveStepFormat: Boolean;\r\n function StoreNextStepText: Boolean;\r\n function StorePreviousStepText: Boolean;\r\n procedure SetShowNavigation(const Value: Boolean);\r\n procedure SetMultiline(const Value: Boolean);\r\n protected\r\n procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;\r\n function PageAtPos(Pt: TPoint): TJvWizardCustomPage; override;\r\n procedure Paint; override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n published\r\n property Color default clBackground;\r\n property Font;\r\n property Image;\r\n property Indent: Integer read FIndent write SetIndent default 5;\r\n property PreviousStepText: string read FPreviousStepText write SetPreviousStepText stored StorePreviousStepText;\r\n property ActiveStepFormat: string read FActiveStepFormat write SetActiveStepFormat stored StoreActiveStepFormat;\r\n property Multiline: Boolean read FMultiline write SetMultiline default False;\r\n property NextStepText: string read FNextStepText write SetNextStepText stored StoreNextStepText;\r\n property ShowDivider: Boolean read FShowDivider write SetShowDivider default True;\r\n property ShowNavigators: Boolean read FShowNavigators write SetShowNavigators default True;\r\n property ShowNavigation: Boolean read FShowNavigation write SetShowNavigation default True;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvWizardRouteMapSteps.pas $';\r\n Revision: '$Revision: 13104 $';\r\n Date: '$Date: 2011-09-07 08:50:43 +0200 (mer. 07 sept. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n JvResources;\r\n\r\nconstructor TJvWizardRouteMapSteps.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FIndent := 5;\r\n Color := clBackground;\r\n Font.Color := clWhite;\r\n FPreviousStepText := RsBackTo;\r\n FActiveStepFormat := RsActiveStepFormat;\r\n FNextStepText := RsNextStep;\r\n FShowDivider := True;\r\n FShowNavigators := True;\r\n FShowNavigation := True;\r\nend;\r\n\r\nfunction TJvWizardRouteMapSteps.DetectPage(const Pt: TPoint): TJvWizardCustomPage;\r\nbegin\r\n if FShowNavigators then\r\n begin\r\n // Ignore all disabled pages at run time.\r\n if PtInRect(GetPreviousArrowRect, Pt) then\r\n begin\r\n if (PageIndex < Wizard.PageCount) and (PageIndex > 0) and\r\n not ((csDesigning in ComponentState) or (bkBack in Wizard.WizardPages[PageIndex].EnabledButtons)) then\r\n Result := nil\r\n else\r\n Result := Wizard.FindNextPage(PageIndex, -1, not (csDesigning in ComponentState));\r\n end\r\n else\r\n if PtInRect(GetNextArrowRect, Pt) then\r\n begin\r\n if (PageIndex < Wizard.PageCount) and (PageIndex > 0) and\r\n not ((csDesigning in ComponentState) or (bkNext in Wizard.WizardPages[PageIndex].EnabledButtons)) then\r\n Result := nil\r\n else\r\n Result := Wizard.FindNextPage(PageIndex, 1, not (csDesigning in ComponentState));\r\n end\r\n else\r\n Result := nil;\r\n end\r\n else\r\n begin\r\n Result := nil;\r\n end;\r\nend;\r\n\r\nfunction TJvWizardRouteMapSteps.GetActiveStepRect: TRect;\r\nbegin\r\n Result := Rect(Left + FIndent, (ClientHeight div 2 - Canvas.TextHeight('Wq')),\r\n Width, ClientHeight div 2);\r\nend;\r\n\r\nfunction TJvWizardRouteMapSteps.GetNextArrowRect: TRect;\r\nbegin\r\n Result := Rect(Left + FIndent, Height - Indent - 32, Left + FIndent + 16,\r\n (Height - FIndent) - 16);\r\nend;\r\n\r\nfunction TJvWizardRouteMapSteps.GetNextStepRect: TRect;\r\nbegin\r\n Result := Rect(Left + FIndent, Height - FIndent - 32, Width,\r\n Height - FIndent - 32 + Canvas.TextHeight('Wq'));\r\nend;\r\n\r\nfunction TJvWizardRouteMapSteps.DetectPageCount(var ActivePageIndex: Integer): Integer;\r\nvar\r\n I: Integer;\r\nbegin\r\n // Ignore all disabled pages at run time.\r\n ActivePageIndex := 0;\r\n Result := 0;\r\n for I := 0 to PageCount - 1 do\r\n begin\r\n if (csDesigning in ComponentState) or Pages[I].Enabled then\r\n begin\r\n if I <= PageIndex then\r\n Inc(ActivePageIndex);\r\n Inc(Result);\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJvWizardRouteMapSteps.GetPreviousArrowRect: TRect;\r\nbegin\r\n Result := Rect(Left + FIndent, Top + FIndent, Left + FIndent + 16,\r\n Top + FIndent + 16);\r\nend;\r\n\r\nfunction TJvWizardRouteMapSteps.GetPreviousStepRect: TRect;\r\nbegin\r\n Result := Rect(Left + FIndent, Top + FIndent, Width,\r\n Top + FIndent + Canvas.TextHeight('Wq'));\r\nend;\r\n\r\nprocedure TJvWizardRouteMapSteps.MouseMove(Shift: TShiftState; X, Y: Integer);\r\nvar\r\n Pt: TPoint;\r\n APage: TJvWizardCustomPage;\r\nbegin\r\n inherited MouseMove(Shift, X, Y);\r\n if ShowNavigators and not (csDesigning in ComponentState) then\r\n begin\r\n Pt := Point(X, Y);\r\n if PtInRect(ClientRect, Pt) then\r\n begin\r\n APage := DetectPage(Pt);\r\n if Assigned(APage) then\r\n Screen.Cursor := crHandPoint\r\n else\r\n Screen.Cursor := crDefault;\r\n end\r\n else\r\n if Screen.Cursor = crHandPoint then\r\n Screen.Cursor := crDefault;\r\n end;\r\nend;\r\n\r\nfunction TJvWizardRouteMapSteps.PageAtPos(Pt: TPoint): TJvWizardCustomPage;\r\nbegin\r\n Result := DetectPage(Pt);\r\nend;\r\n\r\nprocedure TJvWizardRouteMapSteps.Paint;\r\nvar\r\n LRect, TextRect, ArrowRect, DividerRect: TRect;\r\n ActivePageIndex, TotalPageCount: Integer;\r\n StepHeight: Integer;\r\n APage: TJvWizardCustomPage;\r\n S: string;\r\n LDrawProperties: Cardinal;\r\nbegin\r\n LRect := ClientRect;\r\n TotalPageCount := DetectPageCount(ActivePageIndex);\r\n Canvas.Brush.Color := Color;\r\n if HasPicture then\r\n Image.PaintTo(Canvas, LRect);\r\n\r\n TextRect := GetActiveStepRect;\r\n LRect := Classes.Rect(TextRect.TopLeft, TextRect.BottomRight);\r\n Canvas.Font.Assign(Font);\r\n Canvas.Font.Style := [fsBold];\r\n Canvas.Brush.Style := bsClear;\r\n\r\n if Multiline then\r\n begin\r\n S := Pages[PageIndex].Caption;\r\n Canvas.Font.Style := [];\r\n StepHeight := DrawText(Canvas.Handle, PChar(S), Length(S), TextRect,\r\n DT_CALCRECT or DT_LEFT or DT_WORDBREAK);\r\n TextRect.Right := LRect.Right;\r\n OffsetRect(TextRect, 0, Round((-0.5) * StepHeight + Canvas.TextHeight('Wq')));\r\n end;\r\n\r\n Canvas.Font.Style := [fsBold];\r\n S := Format(ActiveStepFormat, [ActivePageIndex, TotalPageCount]);\r\n if Multiline then\r\n begin\r\n LDrawProperties := DT_LEFT or DT_WORDBREAK;\r\n end\r\n else\r\n begin\r\n LDrawProperties := DT_LEFT or DT_SINGLELINE or DT_END_ELLIPSIS or DT_VCENTER;\r\n end;\r\n StepHeight := DrawText(Canvas.Handle, PChar(S), Length(S), TextRect,\r\n LDrawProperties);\r\n\r\n // Display Active Page Description\r\n Canvas.Font.Style := [];\r\n OffsetRect(TextRect, 0, StepHeight);\r\n S := Pages[PageIndex].Caption;\r\n if Multiline then\r\n begin\r\n LDrawProperties := DT_LEFT or DT_WORDBREAK;\r\n end\r\n else\r\n begin\r\n LDrawProperties := DT_LEFT or DT_SINGLELINE or DT_END_ELLIPSIS or DT_VCENTER;\r\n end;\r\n DrawText(Canvas.Handle, PChar(S), Length(S), TextRect, LDrawProperties);\r\n\r\n Canvas.Font.Style := [];\r\n if Self.ShowDivider then\r\n begin\r\n SetRect(DividerRect, Left + Indent, TextRect.Bottom + 5, Width - Indent,\r\n TextRect.Bottom + 6);\r\n Windows.DrawEdge(Canvas.Handle, DividerRect, EDGE_RAISED, BF_FLAT or BF_BOTTOM);\r\n end;\r\n\r\n { do the previous step }\r\n\r\n // YW - Ignore all disabled pages at run time\r\n APage := Wizard.FindNextPage(PageIndex, -1, not (csDesigning in ComponentState));\r\n if Assigned(APage) and (PageIndex <> -1) and ShowNavigation then\r\n begin\r\n TextRect := GetPreviousStepRect;\r\n ArrowRect := GetPreviousArrowRect;\r\n Canvas.Font.Style := [];\r\n if ShowNavigators then\r\n begin\r\n if TextRect.Left + Indent + ArrowRect.Right - ArrowRect.Left < Width then\r\n OffsetRect(TextRect, ArrowRect.Right, 0);\r\n if (csDesigning in ComponentState) or (bkBack in Wizard.WizardPages[PageIndex].EnabledButtons) then\r\n DrawFrameControl(Canvas.Handle, ArrowRect, DFC_SCROLL,\r\n DFCS_SCROLLLEFT or DFCS_FLAT);\r\n end;\r\n\r\n S := PreviousStepText;\r\n StepHeight := DrawText(Canvas.Handle, PChar(S), Length(S), TextRect,\r\n DT_LEFT or DT_WORDBREAK or DT_END_ELLIPSIS);\r\n\r\n OffsetRect(TextRect, 0, StepHeight);\r\n S := APage.Caption;\r\n if Multiline then\r\n begin\r\n DrawText(Canvas.Handle, PChar(S), Length(S), TextRect,\r\n DT_CALCRECT or DT_LEFT or DT_WORDBREAK);\r\n TextRect.Right := LRect.Right;\r\n\r\n LDrawProperties := DT_LEFT or DT_WORDBREAK;\r\n end\r\n else\r\n begin\r\n LDrawProperties := DT_SINGLELINE or DT_LEFT or DT_END_ELLIPSIS or DT_VCENTER;\r\n end;\r\n DrawText(Canvas.Handle, PChar(S), Length(S), TextRect, LDrawProperties);\r\n end;\r\n\r\n { do the next step }\r\n\r\n // YW - Ignore all disabled pages at run time\r\n APage := Wizard.FindNextPage(PageIndex, 1, not (csDesigning in ComponentState));\r\n if Assigned(APage) and (PageIndex <> -1) and ShowNavigation then\r\n begin\r\n TextRect := GetNextStepRect;\r\n ArrowRect := GetNextArrowRect;\r\n Canvas.Font.Style := [];\r\n if ShowNavigators then\r\n begin\r\n OffsetRect(TextRect, ArrowRect.Right, 0);\r\n if (csDesigning in ComponentState) or (bkNext in Wizard.WizardPages[PageIndex].EnabledButtons) then\r\n DrawFrameControl(Canvas.Handle, ArrowRect, DFC_SCROLL,\r\n DFCS_SCROLLRIGHT or DFCS_FLAT);\r\n end;\r\n\r\n if Multiline then\r\n begin\r\n S := APage.Caption;\r\n StepHeight := DrawText(Canvas.Handle, PChar(S), Length(S), TextRect,\r\n DT_CALCRECT or DT_LEFT or DT_WORDBREAK);\r\n TextRect.Right := LRect.Right;\r\n OffsetRect(TextRect, 0, (-1) * StepHeight + Canvas.TextHeight('Wq'));\r\n end;\r\n\r\n S := NextStepText;\r\n StepHeight := DrawText(Canvas.Handle, PChar(S), Length(S), TextRect,\r\n DT_LEFT or DT_WORDBREAK);\r\n\r\n OffsetRect(TextRect, 0, StepHeight);\r\n S := APage.Caption;\r\n if Multiline then\r\n begin\r\n DrawText(Canvas.Handle, PChar(S), Length(S), TextRect,\r\n DT_CALCRECT or DT_LEFT or DT_WORDBREAK);\r\n TextRect.Right := LRect.Right;\r\n\r\n LDrawProperties := DT_LEFT or DT_WORDBREAK;\r\n end\r\n else\r\n begin\r\n LDrawProperties := DT_SINGLELINE or DT_LEFT or DT_END_ELLIPSIS or DT_VCENTER;\r\n end;\r\n DrawText(Canvas.Handle, PChar(S), Length(S), TextRect, LDrawProperties);\r\n end;\r\nend;\r\n\r\nprocedure TJvWizardRouteMapSteps.SetShowDivider(const Value: Boolean);\r\nbegin\r\n if FShowDivider <> Value then\r\n begin\r\n FShowDivider := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvWizardRouteMapSteps.SetIndent(const Value: Integer);\r\nbegin\r\n if FIndent <> Value then\r\n begin\r\n FIndent := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvWizardRouteMapSteps.SetMultiline(const Value: Boolean);\r\nbegin\r\n if FMultiline <> Value then\r\n begin\r\n FMultiline := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvWizardRouteMapSteps.SetNextStepText(const Value: string);\r\nbegin\r\n if FNextStepText <> Value then\r\n begin\r\n FNextStepText := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvWizardRouteMapSteps.SetActiveStepFormat(const Value: string);\r\nbegin\r\n if FActiveStepFormat <> Value then\r\n begin\r\n FActiveStepFormat := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvWizardRouteMapSteps.SetPreviousStepText(const Value: string);\r\nbegin\r\n if FPreviousStepText <> Value then\r\n begin\r\n FPreviousStepText := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvWizardRouteMapSteps.SetShowNavigators(const Value: Boolean);\r\nbegin\r\n if FShowNavigators <> Value then\r\n begin\r\n if Screen.Cursor = crHandPoint then\r\n Screen.Cursor := crDefault;\r\n FShowNavigators := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvWizardRouteMapSteps.SetShowNavigation(const Value: Boolean);\r\nbegin\r\n if Value <> FShowNavigation then\r\n begin\r\n FShowNavigation := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nfunction TJvWizardRouteMapSteps.StoreActiveStepFormat: Boolean;\r\nbegin\r\n Result := ActiveStepFormat <> RsActiveStepFormat;\r\nend;\r\n\r\nfunction TJvWizardRouteMapSteps.StoreNextStepText: Boolean;\r\nbegin\r\n Result := NextStepText <> RsNextStep;\r\nend;\r\n\r\nfunction TJvWizardRouteMapSteps.StorePreviousStepText: Boolean;\r\nbegin\r\n Result := PreviousStepText <> RsBackTo;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\n\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvWndProcHook.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvWndProcHook.PAS, released on 2002-11-01.\r\n\r\nThe Initial Developer of the Original Code is Peter Thrnqvist [peter3 at sourceforge dot net]\r\nPortions created by Peter Thrnqvist are Copyright (C) 2002 Peter Thrnqvist.\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\nRemko Bonte \r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n * (rb) object naming could be improved, for example\r\n TJvWndProcHook -> TJvHookController\r\n TJvWndProcHook.FHookInfos -> TJvHookController.Items\r\n TJvHookInfos -> TJvHookItem, TJvHookInfo, TJvHook\r\n TJvHookInfo -> TJvHookData\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvWndProcHook.pas 13173 2011-11-19 12:43:58Z ahuser $\r\n\r\nunit JvWndProcHook;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, Messages, SysUtils, Controls, Forms, Classes,\r\n JvComponentBase;\r\n\r\ntype\r\n TJvControlHook = function(var Msg: TMessage): Boolean of object;\r\n TJvHookMessageEvent = procedure(Sender: TObject; var Msg: TMessage;\r\n var Handled: Boolean) of object;\r\n\r\n TJvHookOrder = (hoBeforeMsg, hoAfterMsg);\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvWindowHook = class(TJvComponent)\r\n private\r\n FActive: Boolean;\r\n FControl: TControl;\r\n FBeforeMessage: TJvHookMessageEvent;\r\n FAfterMessage: TJvHookMessageEvent;\r\n procedure SetActive(Value: Boolean);\r\n procedure SetControl(Value: TControl);\r\n function IsForm: Boolean;\r\n function NotIsForm: Boolean;\r\n procedure ReadForm(Reader: TReader);\r\n procedure WriteForm(Writer: TWriter);\r\n procedure SetAfterMessage(const Value: TJvHookMessageEvent);\r\n procedure SetBeforeMessage(const Value: TJvHookMessageEvent);\r\n protected\r\n procedure DefineProperties(Filer: TFiler); override;\r\n function DoAfterMessage(var Msg: TMessage): Boolean; dynamic;\r\n function DoBeforeMessage(var Msg: TMessage): Boolean; dynamic;\r\n procedure Notification(AComponent: TComponent; Operation: TOperation); override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n procedure HookControl;\r\n procedure UnHookControl;\r\n published\r\n property Active: Boolean read FActive write SetActive default True;\r\n property Control: TControl read FControl write SetControl stored NotIsForm;\r\n property BeforeMessage: TJvHookMessageEvent read FBeforeMessage write SetBeforeMessage;\r\n property AfterMessage: TJvHookMessageEvent read FAfterMessage write SetAfterMessage;\r\n end;\r\n\r\nfunction RegisterWndProcHook(AControl: TControl; Hook: TJvControlHook;\r\n const Order: TJvHookOrder): Boolean; overload;\r\nfunction RegisterWndProcHook(AHandle: THandle; Hook: TJvControlHook;\r\n const Order: TJvHookOrder): Boolean; overload;\r\nfunction UnRegisterWndProcHook(AControl: TControl; Hook: TJvControlHook;\r\n const Order: TJvHookOrder): Boolean; overload;\r\nfunction UnRegisterWndProcHook(AHandle: THandle; Hook: TJvControlHook;\r\n const Order: TJvHookOrder): Boolean; overload;\r\nprocedure ReleaseObj(AObject: TObject);\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvWndProcHook.pas $';\r\n Revision: '$Revision: 13173 $';\r\n Date: '$Date: 2011-11-19 13:43:58 +0100 (sam. 19 nov. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\n{$IFNDEF COMPILER12_UP}\r\nuses\r\n JvJCLUtils; // SetWindowLongPtr\r\n{$ENDIF ~COMPILER12_UP}\r\n\r\ntype\r\n PJvHookInfo = ^TJvHookInfo;\r\n TJvHookInfo = record\r\n Hook: TJvControlHook;\r\n Next: PJvHookInfo;\r\n end;\r\n\r\n PHookInfoList = ^THookInfoList;\r\n THookInfoList = array [0..MaxInt div SizeOf(Pointer) - 1] of PJvHookInfo;\r\n\r\n TJvWndProcHook = class;\r\n\r\n TJvHookInfos = class(TObject)\r\n private\r\n FFirst: array [TJvHookOrder] of PJvHookInfo;\r\n FLast: array [TJvHookOrder] of PJvHookInfo;\r\n { FStack is filled with HookInfos that are being processed in WindowProc\r\n procedures. On entrance of the WindowProc the size increases, on exit it\r\n decreases. Thus when a message is send inside a hook handler, the stack\r\n size increases.\r\n\r\n We use a stack to be able to register and unregister hooks inside hook\r\n handlers, see \\dev\\DUnit for some examples.\r\n\r\n The odd members in the stack are hoBeforeMsg hooks, the even members in\r\n the list are hoAfterMsg hooks\r\n }\r\n FStack: PHookInfoList;\r\n FStackCapacity: Integer;\r\n FStackCount: Integer;\r\n FHandle: THandle;\r\n FControl: TControl;\r\n FControlDestroyed: Boolean;\r\n FOldWndProc: TWndMethod;\r\n FOldWndProcHandle: TFarProc;\r\n FHooked: Boolean;\r\n FController: TJvWndProcHook;\r\n procedure SetController(const Value: TJvWndProcHook);\r\n protected\r\n procedure WindowProc(var Msg: TMessage);\r\n procedure HookControl;\r\n procedure UnHookControl;\r\n procedure IncDepth;\r\n procedure DecDepth;\r\n public\r\n constructor Create(AControl: TControl); overload;\r\n constructor Create(AHandle: THandle); overload;\r\n destructor Destroy; override;\r\n procedure Add(const Order: TJvHookOrder; Hook: TJvControlHook);\r\n procedure Delete(const Order: TJvHookOrder; Hook: TJvControlHook);\r\n procedure ControlDestroyed;\r\n property Control: TControl read FControl;\r\n { Prevent calls to WndProcHook by using property Controller;\r\n TJvHookInfos may live longer than WndProcHook }\r\n property Controller: TJvWndProcHook read FController write SetController;\r\n property Handle: THandle read FHandle;\r\n end;\r\n\r\n TJvWndProcHook = class(TComponent)\r\n private\r\n FHookInfos: TList;\r\n protected\r\n procedure Notification(AComponent: TComponent; Operation: TOperation); override;\r\n function IndexOf(AControl: TControl): Integer; overload;\r\n function IndexOf(AHandle: THandle): Integer; overload;\r\n function Find(AControl: TControl): TJvHookInfos; overload;\r\n function Find(AHandle: THandle): TJvHookInfos; overload;\r\n\r\n procedure Remove(AHookInfos: TJvHookInfos);\r\n procedure Add(AHookInfos: TJvHookInfos);\r\n public\r\n destructor Destroy; override;\r\n function RegisterWndProc(AControl: TControl; Hook: TJvControlHook;\r\n const Order: TJvHookOrder): Boolean; overload;\r\n function RegisterWndProc(AHandle: THandle; Hook: TJvControlHook;\r\n const Order: TJvHookOrder): Boolean; overload;\r\n function UnRegisterWndProc(AControl: TControl; Hook: TJvControlHook;\r\n const Order: TJvHookOrder): Boolean; overload;\r\n function UnRegisterWndProc(AHandle: THandle; Hook: TJvControlHook;\r\n const Order: TJvHookOrder): Boolean; overload;\r\n end;\r\n\r\n TJvReleaser = class(TObject)\r\n private\r\n FHandle: THandle;\r\n FReleasing: TList;\r\n function GetHandle: THandle;\r\n procedure CMRelease(var Msg: TMessage); message CM_RELEASE;\r\n procedure WndProc(var Msg: TMessage);\r\n public\r\n constructor Create; virtual;\r\n destructor Destroy; override;\r\n procedure DefaultHandler(var Msg); override;\r\n class function Instance: TJvReleaser;\r\n procedure Release(AObject: TObject);\r\n property Handle: THandle read GetHandle;\r\n end;\r\n\r\nvar\r\n GJvWndProcHook: TJvWndProcHook = nil;\r\n GReleaser: TJvReleaser = nil;\r\n\r\nfunction WndProcHook: TJvWndProcHook;\r\nbegin\r\n if GJvWndProcHook = nil then\r\n GJvWndProcHook := TJvWndProcHook.Create(nil);\r\n Result := GJvWndProcHook;\r\nend;\r\n\r\nfunction RegisterWndProcHook(AControl: TControl; Hook: TJvControlHook;\r\n const Order: TJvHookOrder): Boolean;\r\nbegin\r\n Result := WndProcHook.RegisterWndProc(AControl, Hook, Order);\r\nend;\r\n\r\nfunction RegisterWndProcHook(AHandle: THandle; Hook: TJvControlHook;\r\n const Order: TJvHookOrder): Boolean;\r\nbegin\r\n Result := WndProcHook.RegisterWndProc(AHandle, Hook, Order);\r\nend;\r\n\r\nfunction UnRegisterWndProcHook(AControl: TControl; Hook: TJvControlHook;\r\n const Order: TJvHookOrder): Boolean;\r\nbegin\r\n Result := WndProcHook.UnRegisterWndProc(AControl, Hook, Order);\r\nend;\r\n\r\nfunction UnRegisterWndProcHook(AHandle: THandle; Hook: TJvControlHook;\r\n const Order: TJvHookOrder): Boolean;\r\nbegin\r\n Result := WndProcHook.UnRegisterWndProc(AHandle, Hook, Order);\r\nend;\r\n\r\nprocedure ReleaseObj(AObject: TObject);\r\nbegin\r\n TJvReleaser.Instance.Release(AObject);\r\nend;\r\n\r\n//=== { TJvWndProcHook } =====================================================\r\n\r\nprocedure TJvWndProcHook.Add(AHookInfos: TJvHookInfos);\r\nvar\r\n I: Integer;\r\nbegin\r\n I := FHookInfos.IndexOf(AHookInfos);\r\n if I < 0 then\r\n FHookInfos.Add(AHookInfos);\r\nend;\r\n\r\ndestructor TJvWndProcHook.Destroy;\r\nbegin\r\n if FHookInfos <> nil then\r\n begin\r\n while FHookInfos.Count > 0 do\r\n { If you free a hook info, it will remove itself from the list }\r\n TJvHookInfos(FHookInfos[0]).Free;\r\n\r\n FHookInfos.Free;\r\n end;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJvWndProcHook.Find(AHandle: THandle): TJvHookInfos;\r\nvar\r\n I: Integer;\r\nbegin\r\n I := IndexOf(AHandle);\r\n if I < 0 then\r\n Result := nil\r\n else\r\n Result := TJvHookInfos(FHookInfos[I]);\r\nend;\r\n\r\nfunction TJvWndProcHook.Find(AControl: TControl): TJvHookInfos;\r\nvar\r\n I: Integer;\r\nbegin\r\n I := IndexOf(AControl);\r\n if I < 0 then\r\n Result := nil\r\n else\r\n Result := TJvHookInfos(FHookInfos[I]);\r\nend;\r\n\r\nfunction TJvWndProcHook.IndexOf(AHandle: THandle): Integer;\r\nbegin\r\n { The following code introduces a problem:\r\n\r\n The handle of a control may change (by a call to RecreateWnd for example)\r\n thus you may find a Ctrl by calling FindControl(AHandle) in RegisterWndProcHook\r\n and then it's possible to _not_ find the same control in UnRegisterWndProcHook,\r\n thus hooks may be left open unwanted.\r\n\r\n Maybe there is a better way to identify hooks than (Handle x Hook x Order) or\r\n ( Ctrl x Hook x Order ) (?)\r\n }\r\n\r\n {Ctrl := FindControl(AHandle);\r\n if Ctrl <> nil then\r\n begin\r\n Result := IndexOf(Ctrl);\r\n if Result >= 0 then\r\n Exit;\r\n end;}\r\n\r\n Result := 0;\r\n while (Result < FHookInfos.Count) and\r\n (TJvHookInfos(FHookInfos[Result]).Handle <> AHandle) do\r\n Inc(Result);\r\n if Result = FHookInfos.Count then\r\n Result := -1;\r\nend;\r\n\r\nfunction TJvWndProcHook.IndexOf(AControl: TControl): Integer;\r\nbegin\r\n Result := 0;\r\n while (Result < FHookInfos.Count) and\r\n (TJvHookInfos(FHookInfos[Result]).Control <> AControl) do\r\n Inc(Result);\r\n if Result = FHookInfos.Count then\r\n Result := -1;\r\nend;\r\n\r\nprocedure TJvWndProcHook.Notification(AComponent: TComponent;\r\n Operation: TOperation);\r\nvar\r\n I: Integer;\r\nbegin\r\n inherited Notification(AComponent, Operation);\r\n if (Operation = opRemove) and (FHookInfos <> nil) and (AComponent is TControl) then\r\n begin\r\n I := IndexOf(TControl(AComponent));\r\n if I >= 0 then\r\n { Be careful because the TJvHookInfos object might be in it's\r\n WindowProc procedure, for example when hooking a form and handling\r\n a CM_RELEASE message. The TJvHookInfos object can't be destroyed then.\r\n\r\n General rule must be that only TJvHookInfos can destroy itself, and\r\n remove it from the TJvWndProcHook.FHookInfos list.\r\n }\r\n TJvHookInfos(FHookInfos[I]).ControlDestroyed;\r\n end;\r\nend;\r\n\r\nfunction TJvWndProcHook.RegisterWndProc(AControl: TControl;\r\n Hook: TJvControlHook; const Order: TJvHookOrder): Boolean;\r\nvar\r\n HookInfos: TJvHookInfos;\r\nbegin\r\n Result := False;\r\n if not Assigned(AControl) or\r\n (csDestroying in AControl.ComponentState) or not Assigned(Hook) then\r\n Exit;\r\n\r\n if FHookInfos = nil then\r\n FHookInfos := TList.Create;\r\n\r\n // find the control:\r\n HookInfos := Find(AControl);\r\n if not Assigned(HookInfos) then\r\n begin\r\n HookInfos := TJvHookInfos.Create(AControl);\r\n HookInfos.Controller := Self;\r\n AControl.FreeNotification(Self);\r\n end;\r\n HookInfos.Add(Order, Hook);\r\n\r\n Result := True;\r\nend;\r\n\r\nfunction TJvWndProcHook.RegisterWndProc(AHandle: THandle;\r\n Hook: TJvControlHook; const Order: TJvHookOrder): Boolean;\r\nvar\r\n HookInfos: TJvHookInfos;\r\nbegin\r\n Result := False;\r\n if not Assigned(Hook) then\r\n Exit;\r\n if FHookInfos = nil then\r\n FHookInfos := TList.Create;\r\n\r\n // find the control:\r\n HookInfos := Find(AHandle);\r\n if not Assigned(HookInfos) then\r\n begin\r\n HookInfos := TJvHookInfos.Create(AHandle);\r\n HookInfos.Controller := Self;\r\n end;\r\n HookInfos.Add(Order, Hook);\r\n\r\n Result := True;\r\nend;\r\n\r\nprocedure TJvWndProcHook.Remove(AHookInfos: TJvHookInfos);\r\nvar\r\n I: Integer;\r\nbegin\r\n I := FHookInfos.IndexOf(AHookInfos);\r\n if I >= 0 then\r\n FHookInfos.Delete(I);\r\nend;\r\n\r\nfunction TJvWndProcHook.UnRegisterWndProc(AHandle: THandle;\r\n Hook: TJvControlHook; const Order: TJvHookOrder): Boolean;\r\nvar\r\n HookInfos: TJvHookInfos;\r\nbegin\r\n Result := False;\r\n if not Assigned(Hook) or not Assigned(FHookInfos) then\r\n Exit;\r\n // find the control:\r\n HookInfos := Find(AHandle);\r\n Result := Assigned(HookInfos);\r\n if Result then\r\n // Maybe delete HookInfos if HookInfos.FFirst.. = nil?\r\n HookInfos.Delete(Order, Hook);\r\nend;\r\n\r\nfunction TJvWndProcHook.UnRegisterWndProc(AControl: TControl;\r\n Hook: TJvControlHook; const Order: TJvHookOrder): Boolean;\r\nvar\r\n HookInfos: TJvHookInfos;\r\nbegin\r\n Result := False;\r\n if not Assigned(AControl) or not Assigned(Hook) or not Assigned(FHookInfos) then\r\n Exit;\r\n // find the control:\r\n HookInfos := Find(AControl);\r\n Result := Assigned(HookInfos);\r\n if Result then\r\n // Maybe delete HookInfos if HookInfos.FFirst.. = nil?\r\n HookInfos.Delete(Order, Hook);\r\nend;\r\n\r\n//=== { TJvHookInfos } =======================================================\r\n\r\nprocedure TJvHookInfos.Add(const Order: TJvHookOrder; Hook: TJvControlHook);\r\nvar\r\n HookInfo: PJvHookInfo;\r\n I: Integer;\r\nbegin\r\n New(HookInfo);\r\n HookInfo.Hook := Hook;\r\n HookInfo.Next := nil;\r\n\r\n { Some bookkeeping }\r\n if FFirst[Order] = nil then\r\n FFirst[Order] := HookInfo;\r\n\r\n if FLast[Order] <> nil then\r\n FLast[Order].Next := HookInfo;\r\n\r\n FLast[Order] := HookInfo;\r\n\r\n { Update the stack }\r\n if Order = hoBeforeMsg then\r\n I := 0\r\n else\r\n I := 1;\r\n while I < FStackCount * 2 do\r\n begin\r\n if FStack[I] = nil then\r\n FStack[I] := HookInfo;\r\n Inc(I, 2);\r\n end;\r\n\r\n HookControl;\r\nend;\r\n\r\nprocedure TJvHookInfos.ControlDestroyed;\r\nbegin\r\n if FControlDestroyed then\r\n Exit;\r\n\r\n { This procedure is called when we get notified that the control we are hooking\r\n is destroyed. We can get this notification from TJvWindowHook.Notification\r\n or in TJvHookInfos.WindowProc.\r\n\r\n Problem is that the control might be destroyed when we are in the\r\n TJvHookInfos.WindowProc. This can occur for example with the CM_RELEASE\r\n message for a TCustomForm. In this case we have to be extra careful to not\r\n call destroyed components via HookInfo.Hook(Msg) etc. Also in that case\r\n we can't free the TJvHookInfos yet, thus we use ReleaseObj.\r\n }\r\n\r\n FControlDestroyed := True;\r\n FOldWndProc := nil;\r\n FOldWndProcHandle := nil;\r\n\r\n { Remove this TJvHookInfos object from the HookInfo list of Controller }\r\n Controller := nil;\r\n ReleaseObj(Self);\r\nend;\r\n\r\nconstructor TJvHookInfos.Create(AControl: TControl);\r\nbegin\r\n inherited Create;\r\n FControl := AControl;\r\n FillChar(FFirst, SizeOf(FFirst), 0);\r\n FillChar(FLast, SizeOf(FLast), 0);\r\n //FillChar(FStack, SizeOf(FStack), 0);\r\n //FillChar(FStackCapacity, SizeOf(FStackCapacity), 0);\r\n //FillChar(FStackCount, SizeOf(FStackCount), 0);\r\nend;\r\n\r\nconstructor TJvHookInfos.Create(AHandle: THandle);\r\nbegin\r\n inherited Create;\r\n FHandle := AHandle;\r\n FillChar(FFirst, SizeOf(FFirst), 0);\r\n FillChar(FLast, SizeOf(FLast), 0);\r\n //FillChar(FStack, SizeOf(FStack), 0);\r\n //FillChar(FStackCapacity, SizeOf(FStackCapacity), 0);\r\n //FillChar(FStackCount, SizeOf(FStackCount), 0);\r\nend;\r\n\r\nprocedure TJvHookInfos.DecDepth;\r\nbegin\r\n if FStackCount > 0 then\r\n Dec(FStackCount);\r\nend;\r\n\r\nprocedure TJvHookInfos.Delete(const Order: TJvHookOrder; Hook: TJvControlHook);\r\nvar\r\n HookInfo: PJvHookInfo;\r\n PrevHookInfo: PJvHookInfo;\r\n I: Integer;\r\nbegin\r\n HookInfo := FFirst[Order];\r\n PrevHookInfo := nil;\r\n while (HookInfo <> nil) and\r\n ((TMethod(HookInfo.Hook).Code <> TMethod(Hook).Code) or\r\n (TMethod(HookInfo.Hook).Data <> TMethod(Hook).Data)) do\r\n { This is unique: Code = the object whereto the method belongs\r\n Data = identifies the method in the object }\r\n begin\r\n PrevHookInfo := HookInfo;\r\n HookInfo := HookInfo.Next;\r\n end;\r\n\r\n if not Assigned(HookInfo) then\r\n Exit;\r\n\r\n // patch up the hole (this is the reason for this entire unit!)\r\n if PrevHookInfo <> nil then\r\n PrevHookInfo.Next := HookInfo.Next;\r\n\r\n { Bookkeeping }\r\n if FLast[Order] = HookInfo then\r\n FLast[Order] := PrevHookInfo;\r\n if FFirst[Order] = HookInfo then\r\n FFirst[Order] := HookInfo.Next;\r\n\r\n { Update the stack }\r\n if Order = hoBeforeMsg then\r\n I := 0\r\n else\r\n I := 1;\r\n while I < FStackCount * 2 do\r\n begin\r\n if FStack[I] = HookInfo then\r\n FStack[I] := HookInfo.Next;\r\n Inc(I, 2);\r\n end;\r\n\r\n Dispose(HookInfo);\r\n\r\n if (FFirst[hoBeforeMsg] = nil) and (FFirst[hoAfterMsg] = nil) then\r\n { Could also call ReleaseObj(Self). Now this object stays in memory until\r\n the Control it was hooking will be destroyed. }\r\n UnHookControl;\r\nend;\r\n\r\ndestructor TJvHookInfos.Destroy;\r\nvar\r\n HookInfo: PJvHookInfo;\r\n Order: TJvHookOrder;\r\nbegin\r\n { Remove this TJvHookInfos object from the list of Controller,\r\n Controller might already be set to nil (in ControlDestroyed) }\r\n Controller := nil;\r\n\r\n UnHookControl;\r\n\r\n for Order := Low(TJvHookOrder) to High(TJvHookOrder) do\r\n while FFirst[Order] <> nil do\r\n begin\r\n HookInfo := FFirst[Order];\r\n FFirst[Order] := HookInfo.Next;\r\n Dispose(HookInfo);\r\n end;\r\n FreeMem(FStack);\r\n\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvHookInfos.HookControl;\r\nbegin\r\n if FHooked or FControlDestroyed then\r\n Exit;\r\n if FControl <> nil then\r\n begin\r\n FOldWndProc := FControl.WindowProc;\r\n FOldWndProcHandle := nil;\r\n FControl.WindowProc := WindowProc;\r\n FHooked := True;\r\n end\r\n else\r\n begin\r\n FOldWndProc := nil;\r\n FOldWndProcHandle := TFarProc(SetWindowLongPtr(FHandle, GWL_WNDPROC, LONG_PTR(MakeObjectInstance(WindowProc))));\r\n FHooked := True;\r\n end;\r\nend;\r\n\r\nprocedure TJvHookInfos.IncDepth;\r\nbegin\r\n if FStackCount >= FStackCapacity then\r\n begin\r\n { Upsize the stack }\r\n Inc(FStackCapacity);\r\n FStackCapacity := FStackCapacity * 2;\r\n ReallocMem(FStack, 2 * FStackCapacity * SizeOf(Pointer));\r\n end;\r\n Inc(FStackCount);\r\nend;\r\n\r\nprocedure TJvHookInfos.SetController(const Value: TJvWndProcHook);\r\nbegin\r\n if Value <> FController then\r\n begin\r\n if Assigned(FController) then\r\n FController.Remove(Self);\r\n\r\n FController := Value;\r\n\r\n if Assigned(FController) then\r\n FController.Add(Self);\r\n end;\r\nend;\r\n\r\nprocedure TJvHookInfos.UnHookControl;\r\nvar\r\n Ptr: TFarProc;\r\nbegin\r\n if not FHooked or FControlDestroyed then\r\n Exit;\r\n if FControl <> nil then\r\n begin\r\n FControl.WindowProc := FOldWndProc;\r\n FHooked := False;\r\n end\r\n else\r\n begin\r\n Ptr := TFarProc(SetWindowLongPtr(FHandle, GWL_WNDPROC, LONG_PTR(FOldWndProcHandle)));\r\n FreeObjectInstance(Ptr);\r\n FHooked := False;\r\n end;\r\nend;\r\n\r\nprocedure TJvHookInfos.WindowProc(var Msg: TMessage);\r\nvar\r\n TmpHookInfo: PJvHookInfo;\r\n { FStack[Index] is used to travel through the hook infos;\r\n FStack[Index] points to the current hook info (and might be nil)\r\n Note that the address of FStack may change due to ReallocMem calls in\r\n IncDepth; thus we can't assign FStack[Index] to a local var.\r\n }\r\n Index: Integer;\r\nbegin\r\n { An object can now report for every possible message that he has\r\n handled that message, thus preventing the original control from\r\n handling the message; this is probably not a good idea in the case\r\n of WM_DESTROY, WM_CLOSE etc. But that's the users responsibility,\r\n I think }\r\n\r\n Msg.Result := 0;\r\n\r\n IncDepth;\r\n // (rb) Don't know what the performance impact of a try..finally is.\r\n try\r\n { The even members in the stack are hoBeforeMsg hooks }\r\n Index := 2 * (FStackCount - 1);\r\n FStack[Index] := FFirst[hoBeforeMsg];\r\n while Assigned(FStack[Index]) do\r\n begin\r\n { We retrieve the next hook info *before* the call to Hook(), because,\r\n see (I) }\r\n TmpHookInfo := FStack[Index];\r\n FStack[Index] := FStack[Index].Next;\r\n if TmpHookInfo.Hook(Msg) or FControlDestroyed then\r\n Exit;\r\n { FStack[Index] may now be changed because of register/unregister calls\r\n inside HookInfo.Hook(Msg). }\r\n end;\r\n\r\n { Maybe only exit here (before the original control handles the message),\r\n thus enabling all hooks to respond to the message? Otherwise if you\r\n have 2 components of the same class, that hook a control, then only 1 will\r\n get the message }\r\n\r\n if Assigned(FOldWndProc) then\r\n FOldWndProc(Msg)\r\n else\r\n if FOldWndProcHandle <> nil then\r\n Msg.Result := CallWindowProc(FOldWndProcHandle, Handle, Msg.Msg,\r\n Msg.WParam, Msg.LParam);\r\n\r\n if FControlDestroyed then\r\n Exit;\r\n\r\n { The odd members in the list are hoAftermsg hooks }\r\n Index := 2 * FStackCount - 1;\r\n FStack[Index] := FFirst[hoAfterMsg];\r\n while Assigned(FStack[Index]) do\r\n begin\r\n TmpHookInfo := FStack[Index];\r\n FStack[Index] := FStack[Index].Next;\r\n if TmpHookInfo.Hook(Msg) or FControlDestroyed then\r\n Exit;\r\n end;\r\n finally\r\n DecDepth;\r\n if (Control = nil) and (Msg.Msg = WM_DESTROY) then\r\n // Handle is being destroyed: remove all hooks on this window\r\n ControlDestroyed;\r\n end;\r\n\r\n { (I)\r\n HookInfos before HookInfos after\r\n call to Hook() call to Hook()\r\n\r\n |----------| If FStack[Index] point to A |----------|\r\n -->| hook A | (arrow) and hook A deletes itself | hook B |<--\r\n |----------| then after the call to Hook, |----------|\r\n | hook B | FStack[Index] points to B. If we | hook C |\r\n |----------| then call Next, FStack[Index] |----------|\r\n | hook C | points to C (should be B)\r\n |----------|\r\n }\r\nend;\r\n\r\n//=== { TJvWindowHook } ======================================================\r\n\r\nconstructor TJvWindowHook.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FActive := True;\r\nend;\r\n\r\nprocedure TJvWindowHook.DefineProperties(Filer: TFiler);\r\n\r\n function DoWrite: Boolean;\r\n begin\r\n if Assigned(Filer.Ancestor) then\r\n Result := IsForm <> TJvWindowHook(Filer.Ancestor).IsForm\r\n else\r\n Result := IsForm;\r\n end;\r\n\r\nbegin\r\n inherited DefineProperties(Filer);\r\n Filer.DefineProperty('IsForm', ReadForm, WriteForm, DoWrite);\r\nend;\r\n\r\ndestructor TJvWindowHook.Destroy;\r\nbegin\r\n Active := False;\r\n Control := nil;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJvWindowHook.DoAfterMessage(var Msg: TMessage): Boolean;\r\nbegin\r\n Result := False;\r\n if Assigned(FAfterMessage) then\r\n FAfterMessage(Self, Msg, Result);\r\nend;\r\n\r\nfunction TJvWindowHook.DoBeforeMessage(var Msg: TMessage): Boolean;\r\nbegin\r\n Result := False;\r\n if Assigned(FBeforeMessage) then\r\n FBeforeMessage(Self, Msg, Result);\r\nend;\r\n\r\nprocedure TJvWindowHook.HookControl;\r\nbegin\r\n SetActive(True);\r\nend;\r\n\r\nfunction TJvWindowHook.IsForm: Boolean;\r\nbegin\r\n Result := (Control <> nil) and ((Control = Owner) and (Owner is TCustomForm));\r\nend;\r\n\r\nprocedure TJvWindowHook.Notification(AComponent: TComponent;\r\n Operation: TOperation);\r\nbegin\r\n inherited Notification(AComponent, Operation);\r\n if Operation = opRemove then\r\n begin\r\n if AComponent = Control then\r\n Control := nil\r\n { Correct? }\r\n else\r\n if (Owner = AComponent) or (Owner = nil) then\r\n Control := nil;\r\n end;\r\nend;\r\n\r\nfunction TJvWindowHook.NotIsForm: Boolean;\r\nbegin\r\n { Correct? }\r\n Result := (Control <> nil) and not (Control is TCustomForm);\r\nend;\r\n\r\nprocedure TJvWindowHook.ReadForm(Reader: TReader);\r\nbegin\r\n if Reader.ReadBoolean then\r\n if Owner is TCustomForm then\r\n Control := TControl(Owner);\r\nend;\r\n\r\nprocedure TJvWindowHook.SetActive(Value: Boolean);\r\nbegin\r\n if FActive = Value then\r\n Exit;\r\n\r\n if not (csDesigning in ComponentState) then\r\n begin\r\n if Value then\r\n begin\r\n { Only register if assigned, to prevent unnecessarily overhead }\r\n if Assigned(FAfterMessage) then\r\n WndProcHook.RegisterWndProc(FControl, DoAfterMessage, hoAfterMsg);\r\n if Assigned(FBeforeMessage) then\r\n WndProcHook.RegisterWndProc(FControl, DoBeforeMessage, hoBeforeMsg);\r\n end\r\n else\r\n begin\r\n if Assigned(FAfterMessage) then\r\n WndProcHook.UnRegisterWndProc(FControl, DoAfterMessage, hoAfterMsg);\r\n if Assigned(FBeforeMessage) then\r\n WndProcHook.UnRegisterWndProc(FControl, DoBeforeMessage, hoBeforeMsg);\r\n end;\r\n end;\r\n FActive := Value;\r\nend;\r\n\r\nprocedure TJvWindowHook.SetAfterMessage(const Value: TJvHookMessageEvent);\r\nbegin\r\n if Active and not (csDesigning in ComponentState) then\r\n begin\r\n { Only register if assigned, to prevent unnecessarily overhead }\r\n if Assigned(Value) and not Assigned(FAfterMessage) then\r\n WndProcHook.RegisterWndProc(FControl, DoAfterMessage, hoAfterMsg)\r\n else\r\n if not Assigned(Value) and Assigned(FAfterMessage) then\r\n WndProcHook.UnRegisterWndProc(FControl, DoAfterMessage, hoAfterMsg);\r\n end;\r\n FAfterMessage := Value;\r\nend;\r\n\r\nprocedure TJvWindowHook.SetBeforeMessage(const Value: TJvHookMessageEvent);\r\nbegin\r\n if Active and not (csDesigning in ComponentState) then\r\n begin\r\n { Only register if assigned, to prevent unnecessarily overhead }\r\n if Assigned(Value) and not Assigned(FBeforeMessage) then\r\n WndProcHook.RegisterWndProc(FControl, DoBeforeMessage, hoBeforeMsg)\r\n else\r\n if not Assigned(Value) and Assigned(FBeforeMessage) then\r\n WndProcHook.UnRegisterWndProc(FControl, DoBeforeMessage, hoBeforeMsg);\r\n end;\r\n FBeforeMessage := Value;\r\nend;\r\n\r\nprocedure TJvWindowHook.SetControl(Value: TControl);\r\nvar\r\n SavedActive: Boolean;\r\nbegin\r\n if Value <> Control then\r\n begin\r\n SavedActive := Active;\r\n Active := False;\r\n if FControl <> nil then\r\n FControl.RemoveFreeNotification(Self);\r\n\r\n if Assigned(Value) and (csDestroying in Value.ComponentState) then\r\n { (rb) this should not happen in calls made by Jv components }\r\n FControl := nil\r\n else\r\n begin\r\n FControl := Value;\r\n\r\n if FControl <> nil then\r\n FControl.FreeNotification(Self);\r\n\r\n Active := SavedActive;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvWindowHook.UnHookControl;\r\nbegin\r\n SetActive(False);\r\nend;\r\n\r\nprocedure TJvWindowHook.WriteForm(Writer: TWriter);\r\nbegin\r\n Writer.WriteBoolean(IsForm);\r\nend;\r\n\r\n//=== { TJvReleaser } ========================================================\r\n\r\nprocedure TJvReleaser.CMRelease(var Msg: TMessage);\r\nvar\r\n Obj: TObject;\r\n Index: Integer;\r\nbegin\r\n Obj := TObject(Msg.WParam);\r\n Index := FReleasing.IndexOf(Obj);\r\n if Index >= 0 then\r\n FReleasing.Delete(Index);\r\n Obj.Free;\r\nend;\r\n\r\nconstructor TJvReleaser.Create;\r\nbegin\r\n inherited Create;\r\n FReleasing := TList.Create;\r\nend;\r\n\r\nprocedure TJvReleaser.DefaultHandler(var Msg);\r\nbegin\r\n with TMessage(Msg) do\r\n if FHandle <> 0 then\r\n Result := CallWindowProc(@DefWindowProc, FHandle, Msg, WParam, LParam);\r\nend;\r\n\r\ndestructor TJvReleaser.Destroy;\r\nbegin\r\n while FReleasing.Count > 0 do\r\n begin\r\n TObject(FReleasing[0]).Free;\r\n FReleasing.Delete(0);\r\n end;\r\n\r\n FReleasing.Free;\r\n if FHandle <> 0 then\r\n DeallocateHWnd(FHandle);\r\n\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJvReleaser.GetHandle: THandle;\r\nbegin\r\n if FHandle = 0 then\r\n FHandle := AllocateHWnd(WndProc);\r\n Result := FHandle;\r\nend;\r\n\r\nclass function TJvReleaser.Instance: TJvReleaser;\r\nbegin\r\n if GReleaser = nil then\r\n GReleaser := TJvReleaser.Create;\r\n Result := GReleaser;\r\nend;\r\n\r\nprocedure TJvReleaser.Release(AObject: TObject);\r\nbegin\r\n { Make sure we're not already releasing this object }\r\n if FReleasing.IndexOf(AObject) < 0 then\r\n begin\r\n FReleasing.Add(AObject);\r\n PostMessage(Handle, CM_RELEASE, WPARAM(AObject), 0);\r\n end;\r\nend;\r\n\r\nprocedure TJvReleaser.WndProc(var Msg: TMessage);\r\nbegin\r\n try\r\n Dispatch(Msg);\r\n except\r\n if Assigned(ApplicationHandleException) then\r\n ApplicationHandleException(Self);\r\n end;\r\nend;\r\n\r\ninitialization\r\n {$IFDEF UNITVERSIONING}\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n {$ENDIF UNITVERSIONING}\r\n\r\nfinalization\r\n { Don't call FreeAndNil for GReleaser, it's (hypothetically) possible that\r\n objects need access to the GReleaser var (via call to ReleaseObj) during\r\n GReleaser.Destroy }\r\n GReleaser.Free;\r\n FreeAndNil(GJvWndProcHook);\r\n GReleaser := nil;\r\n {$IFDEF UNITVERSIONING}\r\n UnregisterUnitVersion(HInstance);\r\n {$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvXPBar.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvXPBar.PAS, released on 2004-01-01.\r\n\r\nThe Initial Developer of the Original Code is Marc Hoffman.\r\nPortions created by Marc Hoffman are Copyright (C) 2002 APRIORI business solutions AG.\r\nPortions created by APRIORI business solutions AG are Copyright (C) 2002 APRIORI business solutions AG\r\nAll Rights Reserved.\r\n\r\nContributor(s): dejoy\r\n //dejoy 2004-4-20\r\n --add GroupIndex,AutoCheck,Checked property in TJvXPBarItem.\r\n --add GetItemClass in TJvXPBarItems.\r\n --add GetBarItemsClass in TJvXPCustomWinXPBar.\r\n\r\nContributor(s): dierk schmid\r\n //dierk 2004-4-23\r\n --add property RoundedItemFrame in TJvXPCustomWinXPBar (Integer>0 is the edge radius)\r\n --add property ItemFrameColor in TJvXPBarColors\r\n //dejoy 2004-4-25\r\n -- splitt ItemFrameColor to CheckedFrameColor , FocusedFrameColor in TJvXPBarColors.\r\n\r\nContributors(s): matej golob\r\n //matej 2004-5-3\r\n --add property BorderColor in TJvXPBarColors.\r\n --add property HeaderRounded\r\n --add property TopSpace\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvXPBar.pas 13415 2012-09-10 09:51:54Z obones $\r\n\r\nunit JvXPBar;\r\n\r\n{$I jvcl.inc}\r\n\r\n// XP_TRANSPARENCY_FIX:\r\n// WinXPSP2/WinServer2003 transparency workaround:\r\n// Define to add calls to BitmapBgPaint to pre-paint\r\n// bitmap using XPBar.Colors.BodyColor, to fix\r\n// transparency issues. Note that this is a real\r\n// bug in Windows XP and 2003 and once all machines\r\n// \"OUT THERE\" have been updated, this should be removed\r\n// from the code.\r\n//{ $ DEFINE XP_TRANSPARENCY_FIX}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, Classes, SysUtils,\r\n Graphics, Controls, Forms, ImgList, ActnList, Messages,\r\n {$IFDEF HAS_UNIT_SYSTEM_UITYPES}\r\n System.UITypes,\r\n {$ENDIF HAS_UNIT_SYSTEM_UITYPES}\r\n JvXPCore, JvXPCoreUtils, JvJVCLUtils, JvTypes;\r\n\r\ntype\r\n TJvXPBarRollDirection = (rdExpand, rdCollapse);\r\n\r\n TJvXPBarRollMode = (rmFixed, rmShrink); // rmFixed is default\r\n\r\n TJvXPBarHitTest =\r\n (\r\n htNone, // mouse is inside non-supported rect\r\n htHeader, // mouse is inside header\r\n htRollButton // mouse is inside rollbutton\r\n );\r\n\r\n TJvXPBarRollDelay = 1..200;\r\n TJvXPBarRollStep = 1..50;\r\n\r\nconst\r\n WM_XPBARAFTERCOLLAPSE = WM_USER + 303; // Ord('J') + Ord('V') + Ord('C') + Ord('L')\r\n WM_XPBARAFTEREXPAND = WM_XPBARAFTERCOLLAPSE + 1;\r\n\r\n { color constants.\r\n }\r\n\r\n// dxColor_CheckedColorXP := TColor($00c9b4e2);\r\n// dxColor_CheckedColorXP := TColor($00d9c1bb);\r\n// dxColor_CheckedColorXP := TColor($00e8ccae);\r\n\r\n dxColor_FocusedColorXP = TColor($00D8ACB0);\r\n dxColor_CheckedColorXP = TColor($00D9C1BB);\r\n dxColor_BodyColorXP = TColor($00F7DFD6);\r\n\r\n dxColor_FocusedFrameColorXP = clHotLight;\r\n dxColor_CheckedFrameColorXP = clHighlight;\r\n\r\ntype\r\n TJvXPBarItem = class;\r\n TJvXPBarItems = class;\r\n TJvXPCustomWinXPBar = class;\r\n\r\n TJvXPBarOnCanChangeEvent = procedure(Sender: TObject; Item: TJvXPBarItem;\r\n var AllowChange: Boolean) of object;\r\n\r\n TJvXPBarOnCollapsedChangeEvent = procedure(Sender: TObject;\r\n Collapsing: Boolean) of object;\r\n\r\n TJvXPBarOnDrawItemEvent = procedure(Sender: TObject; ACanvas: TCanvas;\r\n Rect: TRect; State: TJvXPDrawState; Item: TJvXPBarItem; Bitmap: TJvBitmap) of object;\r\n TJvXPBarOwnerDrawEvent = procedure(Sender: TObject; ACanvas: TCanvas; var ARect: TRect) of object;\r\n\r\n TJvXPBarOnItemClickEvent = procedure(Sender: TObject; Item: TJvXPBarItem) of object;\r\n\r\n TJvXPBarItemActionLink = class(TActionLink)\r\n private\r\n FClient: TJvXPBarItem;\r\n protected\r\n procedure AssignClient(AClient: TObject); override;\r\n function IsCaptionLinked: Boolean; override;\r\n function IsCheckedLinked: Boolean; override;\r\n function IsEnabledLinked: Boolean; override;\r\n function IsHintLinked: Boolean; override;\r\n function IsImageIndexLinked: Boolean; override;\r\n function IsVisibleLinked: Boolean; override;\r\n function IsOnExecuteLinked: Boolean; override;\r\n procedure SetCaption(const Value: string); override;\r\n procedure SetHint(const Value: string); override;\r\n function DoShowHint(var HintStr: string): Boolean; virtual;\r\n function IsAutoCheckLinked: Boolean; virtual;\r\n procedure SetAutoCheck(Value: Boolean); override;\r\n procedure SetChecked(Value: Boolean); override;\r\n procedure SetEnabled(Value: Boolean); override;\r\n procedure SetImageIndex(Value: Integer); override;\r\n procedure SetVisible(Value: Boolean); override;\r\n procedure SetOnExecute(Value: TNotifyEvent); override;\r\n property Client: TJvXPBarItem read FClient write FClient;\r\n end;\r\n\r\n TJvXPBarItemActionLinkClass = class of TJvXPBarItemActionLink;\r\n\r\n TJvXPBarItemClass = class of TJvXPBarItem;\r\n\r\n TJvXPBarItem = class(TCollectionItem)\r\n private\r\n FActionLink: TJvXPBarItemActionLink;\r\n FCollection: TJvXPBarItems;\r\n FCaption: TCaption;\r\n FData: Pointer;\r\n FDataObject: TObject;\r\n FEnabled: Boolean;\r\n FHint: string;\r\n FImageIndex: TImageIndex;\r\n FImageList: TCustomImageList;\r\n FName: string;\r\n FWinXPBar: TJvXPCustomWinXPBar;\r\n FTag: Integer;\r\n FVisible: Boolean;\r\n FOnClick: TNotifyEvent;\r\n FOnDblClick: TNotifyEvent;\r\n FGroupIndex: Integer;\r\n FChecked: Boolean;\r\n FAutoCheck: Boolean;\r\n function IsAutoCheckStored: Boolean;\r\n function IsCaptionStored: Boolean;\r\n function IsEnabledStored: Boolean;\r\n function IsHintStored: Boolean;\r\n function IsImageIndexStored: Boolean;\r\n function IsVisibleStored: Boolean;\r\n function IsOnClickStored: Boolean;\r\n function IsCheckedStored: Boolean;\r\n function GetImages: TCustomImageList;\r\n procedure DoActionChange(Sender: TObject);\r\n procedure SetAction(Value: TBasicAction);\r\n procedure SetCaption(Value: TCaption);\r\n procedure SetEnabled(Value: Boolean);\r\n procedure SetImageIndex(Value: TImageIndex);\r\n procedure SetImageList(Value: TCustomImageList);\r\n procedure SetName(const Value: string);\r\n procedure SetVisible(Value: Boolean);\r\n procedure SetGroupIndex(const Value: Integer);\r\n procedure SetChecked(const Value: Boolean);\r\n procedure TurnSiblingsOff;\r\n protected\r\n function GetActionLinkClass: TJvXPBarItemActionLinkClass; dynamic;\r\n function GetAction: TBasicAction; virtual;\r\n function GetDisplayName: string; override;\r\n procedure Notification(AComponent: TComponent); virtual;\r\n procedure ActionChange(Sender: TObject; CheckDefaults: Boolean); dynamic;\r\n\r\n procedure DrawItem(AWinXPBar: TJvXPCustomWinXPBar; ACanvas: TCanvas;\r\n Rect: TRect; State: TJvXPDrawState; ShowItemFrame: Boolean; Bitmap: TBitmap); virtual;\r\n property ActionLink: TJvXPBarItemActionLink read FActionLink write FActionLink;\r\n public\r\n constructor Create(Collection: TCollection); override;\r\n destructor Destroy; override;\r\n procedure Assign(Source: TPersistent); override;\r\n property Data: Pointer read FData write FData;\r\n property DataObject: TObject read FDataObject write FDataObject;\r\n property Images: TCustomImageList read GetImages;\r\n property WinXPBar: TJvXPCustomWinXPBar read FWinXPBar;\r\n published\r\n property Action: TBasicAction read GetAction write SetAction;\r\n property AutoCheck: Boolean read FAutoCheck write FAutoCheck stored IsAutoCheckStored default False;\r\n property Caption: TCaption read FCaption write SetCaption stored IsCaptionStored;\r\n property Checked: Boolean read FChecked write SetChecked stored IsCheckedStored default False;\r\n property Enabled: Boolean read FEnabled write SetEnabled stored IsEnabledStored default True;\r\n property GroupIndex: Integer read FGroupIndex write SetGroupIndex default 0;\r\n property Hint: string read FHint write FHint stored IsHintStored;\r\n property ImageIndex: TImageIndex read FImageIndex write SetImageIndex stored IsImageIndexStored default -1;\r\n property ImageList: TCustomImageList read FImageList write SetImageList;\r\n property Name: string read FName write SetName;\r\n property Tag: Integer read FTag write FTag default 0;\r\n property Visible: Boolean read FVisible write SetVisible stored IsVisibleStored default True;\r\n property OnClick: TNotifyEvent read FOnClick write FOnClick stored IsOnClickStored;\r\n property OnDblClick: TNotifyEvent read FOnDblClick write FOnDblClick;\r\n end;\r\n\r\n TJvXPBarItemsClass = class of TJvXPBarItems;\r\n\r\n TJvXPBarItems = class(TCollection)\r\n private\r\n FWinXPBar: TJvXPCustomWinXPBar;\r\n function GetItem(Index: Integer): TJvXPBarItem;\r\n procedure SetItem(Index: Integer; Value: TJvXPBarItem);\r\n protected\r\n procedure Update(Item: TCollectionItem); override;\r\n function GetOwner: TPersistent; override;\r\n class function GetItemClass: TJvXPBarItemClass; virtual;\r\n public\r\n constructor Create(WinXPBar: TJvXPCustomWinXPBar);\r\n function Add: TJvXPBarItem; overload;\r\n function Add(Action: TBasicAction): TJvXPBarItem; overload;\r\n function Add(DataObject: TObject): TJvXPBarItem; overload;\r\n function Insert(Index: Integer): TJvXPBarItem; overload;\r\n function Insert(Index: Integer; Action: TBasicAction): TJvXPBarItem; overload;\r\n function Insert(Index: Integer; DataObject: TObject): TJvXPBarItem; overload;\r\n function Find(const AName: string): TJvXPBarItem; overload;\r\n function Find(const Action: TBasicAction): TJvXPBarItem; overload;\r\n function Find(const DataObject: TObject): TJvXPBarItem; overload;\r\n property Items[Index: Integer]: TJvXPBarItem read GetItem write SetItem; default;\r\n end;\r\n\r\n TJvXPBarVisibleItems = class(TPersistent)\r\n private\r\n FItems: TList;\r\n FWinXPBar: TJvXPCustomWinXPBar;\r\n function Exists(Item: TJvXPBarItem): Boolean;\r\n function GetItem(Index: Integer): TJvXPBarItem;\r\n procedure Add(Item: TJvXPBarItem);\r\n procedure Delete(Item: TJvXPBarItem);\r\n public\r\n constructor Create(WinXPBar: TJvXPCustomWinXPBar);\r\n destructor Destroy; override;\r\n function Count: Integer;\r\n property Items[Index: Integer]: TJvXPBarItem read GetItem; default;\r\n end;\r\n\r\n TJvXPFadeThread = class(TJvCustomThread)\r\n private\r\n FWinXPBar: TJvXPCustomWinXPBar;\r\n FRollDirection: TJvXPBarRollDirection;\r\n FWinXPBarNewOffSet: Integer;\r\n protected\r\n procedure DoWinXPBarSetRollOffset;\r\n procedure DoWinXPBarInternalRedraw;\r\n procedure Execute; override;\r\n public\r\n constructor Create(WinXPBar: TJvXPCustomWinXPBar; RollDirection: TJvXPBarRollDirection);\r\n end;\r\n\r\n TJvXPBarColors = class(TPersistent)\r\n private\r\n FCheckedFrameColor: TColor;\r\n FFocusedFrameColor: TColor;\r\n FCheckedColor: TColor;\r\n FFocusedColor: TColor;\r\n FBodyColor: TColor;\r\n FBodyBorderColor: TColor;\r\n FGradientTo: TColor;\r\n FGradientFrom: TColor;\r\n FSeparatorColor: TColor;\r\n FBorderColor: TColor;\r\n FOnChange: TNotifyEvent;\r\n procedure SetBorderColor(const Value: TColor);\r\n procedure SetBodyColor(const Value: TColor);\r\n procedure SetGradientFrom(const Value: TColor);\r\n procedure SetGradientTo(const Value: TColor);\r\n procedure SetSeparatorColor(const Value: TColor);\r\n procedure SetCheckedColor(const Value: TColor);\r\n procedure SetFocusedColor(const Value: TColor);\r\n procedure SetCheckedFrameColor(const Value: TColor);\r\n procedure SetFocusedFrameColor(const Value: TColor);\r\n procedure SetBodyBorderColor(const Value: TColor);\r\n public\r\n constructor Create;\r\n procedure Assign(Source: TPersistent); override;\r\n procedure Change;\r\n published\r\n property BorderColor: TColor read FBorderColor write SetBorderColor default clWhite;\r\n property CheckedColor: TColor read FCheckedColor write SetCheckedColor default dxColor_CheckedColorXP;\r\n property FocusedColor: TColor read FFocusedColor write SetFocusedColor default dxColor_FocusedColorXP;\r\n property CheckedFrameColor: TColor read FCheckedFrameColor write SetCheckedFrameColor\r\n default dxColor_CheckedFrameColorXP;\r\n property FocusedFrameColor: TColor read FFocusedFrameColor write SetFocusedFrameColor\r\n default dxColor_FocusedFrameColorXP;\r\n property BodyColor: TColor read FBodyColor write SetBodyColor default dxColor_BodyColorXP;\r\n property BodyBorderColor: TColor read FBodyBorderColor write SetBodyBorderColor default dxColor_BodyColorXP;\r\n property GradientFrom: TColor read FGradientFrom write SetGradientFrom default clWhite;\r\n property GradientTo: TColor read FGradientTo write SetGradientTo default TColor($00F7D7C6);\r\n property SeparatorColor: TColor read FSeparatorColor write SetSeparatorColor default TColor($00F7D7C6);\r\n property OnChange: TNotifyEvent read FOnChange write FOnChange;\r\n end;\r\n\r\n TJvXPBarOptions = class(TPersistent)\r\n end;\r\n\r\n TJvXPCustomWinXPBar = class(TJvXPCustomControl)\r\n private\r\n FCollapsed: Boolean;\r\n FFadeThread: TJvXPFadeThread;\r\n FFont: TFont;\r\n FFontChanging: Boolean;\r\n FGradient: TBitmap;\r\n FGradientWidth: Integer;\r\n FHeaderFont: TFont;\r\n FHeaderRounded: Boolean;\r\n FHitTest: TJvXPBarHitTest;\r\n FHotTrack: Boolean;\r\n FHoverIndex: Integer;\r\n FIcon: TIcon;\r\n FImageList: TCustomImageList;\r\n FItemHeight: Integer;\r\n FItems: TJvXPBarItems;\r\n FRollDelay: TJvXPBarRollDelay;\r\n FRolling: Boolean;\r\n FRollMode: TJvXPBarRollMode;\r\n FRollOffset: Integer;\r\n FRollStep: TJvXPBarRollStep;\r\n FShowLinkCursor: Boolean;\r\n FShowRollButton: Boolean;\r\n FHotTrackColor: TColor;\r\n FVisibleItems: TJvXPBarVisibleItems;\r\n FAfterCollapsedChange: TJvXPBarOnCollapsedChangeEvent;\r\n FBeforeCollapsedChange: TJvXPBarOnCollapsedChangeEvent;\r\n FOnCollapsedChange: TJvXPBarOnCollapsedChangeEvent;\r\n FOnCanChange: TJvXPBarOnCanChangeEvent;\r\n FOnDrawItem: TJvXPBarOnDrawItemEvent;\r\n FOnItemClick: TJvXPBarOnItemClickEvent;\r\n FColors: TJvXPBarColors;\r\n FRollImages: TCustomImageList;\r\n FImageChangeLink: TChangeLink;\r\n FRollChangeLink: TChangeLink;\r\n FGrouped: Boolean;\r\n FHeaderHeight: Integer;\r\n FStoredHint: string;\r\n FShowItemFrame: Boolean;\r\n FRoundedItemFrame: Integer; // DS\r\n FTopSpace: Integer;\r\n FOwnerDraw: Boolean;\r\n FOnDrawBackground: TJvXPBarOwnerDrawEvent;\r\n FOnDrawHeader: TJvXPBarOwnerDrawEvent;\r\n function IsFontStored: Boolean;\r\n procedure FontChange(Sender: TObject);\r\n procedure SetCollapsed(Value: Boolean);\r\n procedure SetFont(Value: TFont);\r\n procedure SetHeaderFont(Value: TFont);\r\n procedure SetHotTrack(Value: Boolean);\r\n procedure SetHotTrackColor(Value: TColor);\r\n procedure SetIcon(Value: TIcon);\r\n procedure SetImageList(Value: TCustomImageList);\r\n procedure SetItemHeight(Value: Integer);\r\n procedure SetItems(Value: TJvXPBarItems);\r\n procedure SetRollOffset(const Value: Integer);\r\n procedure SetShowRollButton(Value: Boolean);\r\n procedure ResizeToMaxHeight;\r\n procedure SetColors(const Value: TJvXPBarColors);\r\n procedure SetRollImages(const Value: TCustomImageList);\r\n procedure SetGrouped(const Value: Boolean);\r\n procedure GroupMessage;\r\n procedure SetHeaderHeight(const Value: Integer);\r\n function GetRollHeight: Integer;\r\n function GetRollWidth: Integer;\r\n procedure SetHeaderRounded(const Value: Boolean);\r\n procedure SetTopSpace(const Value: Integer);\r\n procedure SetOwnerDraw(const Value: Boolean);\r\n protected\r\n procedure CMDialogChar(var Msg: TCMDialogChar); message CM_DIALOGCHAR;\r\n class function GetBarItemsClass: TJvXPBarItemsClass; virtual;\r\n function GetHitTestRect(const HitTest: TJvXPBarHitTest): TRect;\r\n function GetItemRect(Index: Integer): TRect; virtual;\r\n procedure ItemVisibilityChanged(Item: TJvXPBarItem); dynamic;\r\n procedure Notification(AComponent: TComponent; Operation: TOperation); override;\r\n procedure HookMouseDown; override;\r\n procedure HookMouseEnter; override;\r\n procedure HookMouseLeave; override;\r\n procedure HookMouseMove(X: Integer = 0; Y: Integer = 0); override;\r\n procedure HookParentFontChanged; override;\r\n procedure HookResized; override;\r\n procedure SortVisibleItems(const Redraw: Boolean);\r\n procedure DoColorsChange(Sender: TObject);\r\n procedure DoDrawItem(const Index: Integer; State: TJvXPDrawState); virtual;\r\n procedure Paint; override;\r\n procedure EndUpdate; override;\r\n procedure WMAfterXPBarCollapse(var Msg: TMessage); message WM_XPBARAFTERCOLLAPSE;\r\n procedure WMAfterXPBarExpand(var Msg: TMessage); message WM_XPBARAFTEREXPAND;\r\n procedure WMWindowposchanging(var Msg: TWMWindowPosChanging); message WM_WINDOWPOSCHANGING;\r\n procedure Loaded; override;\r\n procedure CreateWnd; override;\r\n property Collapsed: Boolean read FCollapsed write SetCollapsed default False;\r\n property Colors: TJvXPBarColors read FColors write SetColors;\r\n property RollImages: TCustomImageList read FRollImages write SetRollImages;\r\n property Font: TFont read FFont write SetFont stored IsFontStored;\r\n property Grouped: Boolean read FGrouped write SetGrouped default False;\r\n property HeaderFont: TFont read FHeaderFont write SetHeaderFont stored IsFontStored;\r\n property HeaderHeight: Integer read FHeaderHeight write SetHeaderHeight default 28;\r\n property HeaderRounded: Boolean read FHeaderRounded write SetHeaderRounded default True;\r\n property OwnerDraw: Boolean read FOwnerDraw write SetOwnerDraw;\r\n property HotTrack: Boolean read FHotTrack write SetHotTrack default True;\r\n property HotTrackColor: TColor read FHotTrackColor write SetHotTrackColor default $00FF7C35;\r\n property Icon: TIcon read FIcon write SetIcon;\r\n property ImageList: TCustomImageList read FImageList write SetImageList;\r\n property ItemHeight: Integer read FItemHeight write SetItemHeight default 20;\r\n property Items: TJvXPBarItems read FItems write SetItems;\r\n property RollDelay: TJvXPBarRollDelay read FRollDelay write FRollDelay default 25;\r\n property Rolling: Boolean read FRolling default False;\r\n property RollMode: TJvXPBarRollMode read FRollMode write FRollMode default rmShrink;\r\n property RollOffset: Integer read FRollOffset write SetRollOffset;\r\n property RollStep: TJvXPBarRollStep read FRollStep write FRollStep default 3;\r\n property ShowLinkCursor: Boolean read FShowLinkCursor write FShowLinkCursor default True;\r\n property ShowRollButton: Boolean read FShowRollButton write SetShowRollButton default True;\r\n property ShowItemFrame: Boolean read FShowItemFrame write FShowItemFrame;\r\n property RoundedItemFrame: Integer read FRoundedItemFrame write FRoundedItemFrame default 1; //DS\r\n property TopSpace: Integer read FTopSpace write SetTopSpace default 5;\r\n property AfterCollapsedChange: TJvXPBarOnCollapsedChangeEvent read FAfterCollapsedChange\r\n write FAfterCollapsedChange;\r\n property BeforeCollapsedChange: TJvXPBarOnCollapsedChangeEvent read FBeforeCollapsedChange\r\n write FBeforeCollapsedChange;\r\n property OnCollapsedChange: TJvXPBarOnCollapsedChangeEvent read FOnCollapsedChange write FOnCollapsedChange;\r\n property OnCanChange: TJvXPBarOnCanChangeEvent read FOnCanChange write FOnCanChange;\r\n property OnDrawItem: TJvXPBarOnDrawItemEvent read FOnDrawItem write FOnDrawItem;\r\n property OnDrawBackground: TJvXPBarOwnerDrawEvent read FOnDrawBackground write FOnDrawBackground;\r\n property OnDrawHeader: TJvXPBarOwnerDrawEvent read FOnDrawHeader write FOnDrawHeader;\r\n property OnItemClick: TJvXPBarOnItemClickEvent read FOnItemClick write FOnItemClick;\r\n procedure AdjustClientRect(var Rect: TRect); override;\r\n // show hints for individual items in the list\r\n function HintShow(var HintInfo: {$IFDEF RTL200_UP}Controls.{$ENDIF RTL200_UP}THintInfo): Boolean; override;\r\n procedure DblClick; override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n function GetHitTestAt(X, Y: Integer): TJvXPBarHitTest;\r\n function GetItemAt(X, Y: Integer): Integer;\r\n procedure Click; override;\r\n property Height default 46;\r\n property VisibleItems: TJvXPBarVisibleItems read FVisibleItems;\r\n property Width default 153;\r\n procedure InitiateAction; override;\r\n end;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvXPBar = class(TJvXPCustomWinXPBar)\r\n published\r\n property Caption;\r\n property Collapsed;\r\n property Colors;\r\n property Items;\r\n property RollImages;\r\n property Font;\r\n property Grouped;\r\n property HeaderFont;\r\n property HeaderHeight;\r\n property HeaderRounded;\r\n property HotTrack;\r\n property HotTrackColor;\r\n property OwnerDraw;\r\n property Icon;\r\n property ImageList;\r\n property ItemHeight;\r\n property RollDelay;\r\n property RollMode;\r\n property RollStep;\r\n property ShowLinkCursor;\r\n property ShowRollButton;\r\n property ShowItemFrame;\r\n property RoundedItemFrame;\r\n property TopSpace;\r\n\r\n property AfterCollapsedChange;\r\n property BeforeCollapsedChange;\r\n property OnCollapsedChange;\r\n property OnCanChange;\r\n property OnDrawItem;\r\n property OnDrawBackground;\r\n property OnDrawHeader;\r\n property OnItemClick;\r\n\r\n //property BevelInner;\r\n //property BevelOuter;\r\n //property BevelWidth;\r\n property BiDiMode;\r\n //property Ctl3D;\r\n //property DockSite;\r\n property ParentBiDiMode;\r\n //property ParentCtl3D;\r\n //property TabOrder;\r\n //property TabStop;\r\n //property UseDockManager default True;\r\n property Align;\r\n property Anchors;\r\n //property AutoSize;\r\n property Constraints;\r\n property DragCursor;\r\n property DragKind;\r\n property OnCanResize;\r\n property DragMode;\r\n //property Enabled;\r\n property ParentFont;\r\n property ParentShowHint;\r\n property PopupMenu;\r\n property ShowHint;\r\n property Visible;\r\n //property OnDockDrop;\r\n //property OnDockOver;\r\n //property OnEndDock;\r\n //property OnGetSiteInfo;\r\n //property OnStartDock;\r\n //property OnUnDock;\r\n property OnClick;\r\n property OnDblClick;\r\n property OnConstrainedResize;\r\n property OnContextPopup;\r\n property OnDragDrop;\r\n property OnDragOver;\r\n property OnEndDrag;\r\n property OnEnter;\r\n property OnExit;\r\n property OnKeyDown;\r\n property OnKeyPress;\r\n property OnKeyUp;\r\n property OnMouseDown;\r\n property OnMouseEnter;\r\n property OnMouseLeave;\r\n property OnMouseMove;\r\n property OnMouseUp;\r\n property OnStartDrag;\r\n end;\r\n\r\nprocedure RoundedFrame(Canvas: TCanvas; ARect: TRect; AColor: TColor; R: Integer);\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvXPBar.pas $';\r\n Revision: '$Revision: 13415 $';\r\n Date: '$Date: 2012-09-10 11:51:54 +0200 (lun. 10 sept. 2012) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n Types,\r\n {$IFDEF JVCLThemesEnabled}\r\n UxTheme,\r\n {$IFNDEF COMPILER7_UP}\r\n TmSchema,\r\n {$ENDIF !COMPILER7_UP}\r\n JvThemes,\r\n {$ENDIF JVCLThemesEnabled}\r\n JvJCLUtils, JvResources,\r\n Menus;\r\n\r\n{$R JvXPBar.res}\r\n\r\nconst\r\n FC_HEADER_MARGIN = 6;\r\n FC_ITEM_MARGIN = 8;\r\n\r\nfunction SortByIndex(Item1, Item2: Pointer): Integer;\r\nvar\r\n Idx1, Idx2: Integer;\r\nbegin\r\n Idx1 := TCollectionItem(Item1).Index;\r\n Idx2 := TCollectionItem(Item2).Index;\r\n if Idx1 < Idx2 then\r\n Result := -1\r\n else\r\n if Idx1 = Idx2 then\r\n Result := 0\r\n else\r\n Result := 1;\r\nend;\r\n\r\n{$IFDEF XP_TRANSPARENCY_FIX}\r\n{ BitmapBgPaint:\r\n\r\n This fixes a bug in the Delphi 7 VCL on systems\r\n running Windows XP SP2 or Windows Server 2003,\r\n where transparency in the VCL TImageList.Draw\r\n function is broken.\r\n\r\n -WPostma. }\r\n\r\nprocedure BitmapBgPaint(Bitmap: TBitmap; BgColor: TColor);\r\nvar\r\n R: TRect;\r\nbegin\r\n R.Left := 0;\r\n R.Top := 0;\r\n R.Right := Bitmap.Width;\r\n R.Bottom := Bitmap.Height;\r\n Bitmap.Canvas.Brush.Color := BgColor;\r\n Bitmap.Canvas.FillRect(R);\r\nend;\r\n{$ENDIF XP_TRANSPARENCY_FIX}\r\n\r\n//=== { TJvXPBarItemActionLink } =============================================\r\n\r\nprocedure TJvXPBarItemActionLink.AssignClient(AClient: TObject);\r\nbegin\r\n Client := AClient as TJvXPBarItem;\r\nend;\r\n\r\nfunction TJvXPBarItemActionLink.IsAutoCheckLinked: Boolean;\r\nbegin\r\n Result := (Client.AutoCheck = (Action as TCustomAction).AutoCheck);\r\nend;\r\n\r\nfunction TJvXPBarItemActionLink.IsCaptionLinked: Boolean;\r\nbegin\r\n Result := inherited IsCaptionLinked and\r\n (Client.Caption = (Action as TCustomAction).Caption);\r\nend;\r\n\r\nfunction TJvXPBarItemActionLink.IsCheckedLinked: Boolean;\r\nbegin\r\n Result := inherited IsCheckedLinked and\r\n (Client.Checked = (Action as TCustomAction).Checked);\r\nend;\r\n\r\nfunction TJvXPBarItemActionLink.IsEnabledLinked: Boolean;\r\nbegin\r\n Result := inherited IsEnabledLinked and\r\n (Client.Enabled = (Action as TCustomAction).Enabled);\r\nend;\r\n\r\nfunction TJvXPBarItemActionLink.IsHintLinked: Boolean;\r\nbegin\r\n Result := inherited IsHintLinked and\r\n (Client.Hint = (Action as TCustomAction).Hint);\r\nend;\r\n\r\nfunction TJvXPBarItemActionLink.IsImageIndexLinked: Boolean;\r\nbegin\r\n Result := inherited IsImageIndexLinked and\r\n (Client.ImageIndex = (Action as TCustomAction).ImageIndex);\r\nend;\r\n\r\nfunction TJvXPBarItemActionLink.IsVisibleLinked: Boolean;\r\nbegin\r\n Result := inherited IsVisibleLinked and\r\n (Client.Visible = (Action as TCustomAction).Visible);\r\nend;\r\n\r\nfunction TJvXPBarItemActionLink.IsOnExecuteLinked: Boolean;\r\nbegin\r\n Result := inherited IsOnExecuteLinked and\r\n JvXPMethodsEqual(TMethod(Client.OnClick), TMethod(Action.OnExecute));\r\nend;\r\n\r\nprocedure TJvXPBarItemActionLink.SetAutoCheck(Value: Boolean);\r\nbegin\r\n if IsAutoCheckLinked then\r\n Client.AutoCheck := Value;\r\nend;\r\n\r\nprocedure TJvXPBarItemActionLink.SetCaption(const Value: string);\r\nbegin\r\n if IsCaptionLinked then\r\n Client.Caption := Value;\r\nend;\r\n\r\nprocedure TJvXPBarItemActionLink.SetEnabled(Value: Boolean);\r\nbegin\r\n if IsEnabledLinked then\r\n Client.Enabled := Value;\r\nend;\r\n\r\nprocedure TJvXPBarItemActionLink.SetChecked(Value: Boolean);\r\nbegin\r\n if IsCheckedLinked then\r\n Client.Checked := Value;\r\nend;\r\n\r\nprocedure TJvXPBarItemActionLink.SetHint(const Value: string);\r\nbegin\r\n if IsHintLinked then\r\n Client.Hint := Value;\r\nend;\r\n\r\nprocedure TJvXPBarItemActionLink.SetImageIndex(Value: Integer);\r\nbegin\r\n if IsImageIndexLinked then\r\n Client.ImageIndex := Value;\r\nend;\r\n\r\nprocedure TJvXPBarItemActionLink.SetVisible(Value: Boolean);\r\nbegin\r\n if IsVisibleLinked then\r\n Client.Visible := Value;\r\nend;\r\n\r\nprocedure TJvXPBarItemActionLink.SetOnExecute(Value: TNotifyEvent);\r\nbegin\r\n if IsOnExecuteLinked then\r\n Client.OnClick := Value;\r\nend;\r\n\r\n//===TJvXPBarItem ============================================================\r\n\r\nconstructor TJvXPBarItem.Create(Collection: TCollection);\r\nbegin\r\n inherited Create(Collection);\r\n FCollection := TJvXPBarItems(Collection);\r\n FCaption := '';\r\n FData := nil;\r\n FDataObject := nil;\r\n FEnabled := True;\r\n FImageIndex := -1;\r\n FImageList := nil;\r\n FHint := '';\r\n FName := '';\r\n FWinXPBar := FCollection.FWinXPBar;\r\n FTag := 0;\r\n FVisible := True;\r\n FAutoCheck := False;\r\n FChecked := False;\r\n FGroupIndex := 0;\r\n FWinXPBar.ItemVisibilityChanged(Self);\r\n FWinXPBar.ResizeToMaxHeight;\r\nend;\r\n\r\ndestructor TJvXPBarItem.Destroy;\r\nbegin\r\n FVisible := False; // required to remove from visible list!\r\n FWinXPBar.ItemVisibilityChanged(Self);\r\n FActionLink.Free;\r\n FActionLink := nil;\r\n\r\n inherited Destroy;\r\n FWinXPBar.ResizeToMaxHeight;\r\nend;\r\n\r\nprocedure TJvXPBarItem.Notification(AComponent: TComponent);\r\nbegin\r\n if AComponent = Action then\r\n Action := nil;\r\n if AComponent = FImageList then\r\n FImageList := nil;\r\nend;\r\n\r\nfunction TJvXPBarItem.GetDisplayName: string;\r\nvar\r\n DisplayName, ItemName: string;\r\nbegin\r\n DisplayName := FCaption;\r\n if DisplayName = '' then\r\n DisplayName := RsUntitled;\r\n ItemName := FName;\r\n if ItemName <> '' then\r\n DisplayName := DisplayName + ' [' + ItemName + ']';\r\n if not FVisible then\r\n DisplayName := DisplayName + '*';\r\n Result := DisplayName;\r\nend;\r\n\r\nfunction TJvXPBarItem.GetImages: TCustomImageList;\r\nbegin\r\n Result := nil;\r\n if Assigned(FImageList) then\r\n Result := FImageList\r\n else\r\n if Assigned(Action) and Assigned(TAction(Action).ActionList.Images) then\r\n Result := TAction(Action).ActionList.Images\r\n else\r\n if Assigned(FWinXPBar.FImageList) then\r\n Result := FWinXPBar.FImageList;\r\nend;\r\n\r\nprocedure TJvXPBarItem.ActionChange(Sender: TObject; CheckDefaults: Boolean);\r\nbegin\r\n if Sender is TCustomAction then\r\n with TCustomAction(Sender) do\r\n begin\r\n if not (csLoading in ComponentState) then\r\n Update;\r\n if not CheckDefaults or not Self.AutoCheck then\r\n Self.AutoCheck := AutoCheck;\r\n if not CheckDefaults or (Self.Caption = '') or (Self.Caption = Self.Name) then\r\n Self.Caption := Caption;\r\n if not CheckDefaults or not Self.Checked then\r\n Self.Checked := Checked;\r\n if not CheckDefaults or Self.Enabled then\r\n Self.Enabled := Enabled;\r\n if not CheckDefaults or (Self.Hint = '') then\r\n Self.Hint := Hint;\r\n if not CheckDefaults or (Self.ImageIndex = -1) then\r\n Self.ImageIndex := ImageIndex;\r\n if not CheckDefaults or Self.Visible then\r\n Self.Visible := Visible;\r\n if not CheckDefaults or not Assigned(Self.OnClick) then\r\n Self.OnClick := OnExecute;\r\n end;\r\nend;\r\n\r\nprocedure TJvXPBarItem.DrawItem(AWinXPBar: TJvXPCustomWinXPBar; ACanvas: TCanvas;\r\n Rect: TRect; State: TJvXPDrawState; ShowItemFrame: Boolean; Bitmap: TBitmap);\r\nvar\r\n ItemCaption: TCaption;\r\n HasImages: Boolean;\r\n LBar: TJvXPCustomWinXPBar;\r\nbegin\r\n LBar := (AWinXPBar as TJvXPCustomWinXPBar);\r\n HasImages := Self.Images <> nil;\r\n with ACanvas do\r\n begin\r\n Font.Assign(LBar.Font);\r\n Brush.Color := LBar.Colors.BodyColor;\r\n if not ShowItemFrame then\r\n FillRect(Rect);\r\n if not Self.Enabled then\r\n Font.Color := clGray\r\n else\r\n begin\r\n if dsFocused in State then\r\n begin\r\n if LBar.HotTrack then\r\n begin\r\n if LBar.FHotTrackColor <> clNone then\r\n Font.Color := LBar.FHotTrackColor;\r\n Font.Style := Font.Style + [fsUnderline];\r\n end;\r\n if ShowItemFrame then\r\n begin\r\n Brush.Color := LBar.Colors.FocusedColor;\r\n if LBar.RoundedItemFrame > 0 then\r\n RoundedFrame(ACanvas, Rect, LBar.Colors.FocusedFrameColor, LBar.RoundedItemFrame)\r\n else\r\n begin\r\n FillRect(Rect);\r\n JvXPFrame3D(ACanvas, Rect, LBar.Colors.FocusedFrameColor, LBar.Colors.FocusedFrameColor);\r\n end;\r\n end;\r\n end\r\n else\r\n if dsClicked in State then\r\n begin\r\n if ShowItemFrame then\r\n begin\r\n Brush.Color := LBar.Colors.CheckedColor;\r\n if LBar.RoundedItemFrame > 0 then\r\n RoundedFrame(ACanvas, Rect, LBar.Colors.CheckedFrameColor, LBar.RoundedItemFrame)\r\n else\r\n begin\r\n FillRect(Rect);\r\n JvXPFrame3D(ACanvas, Rect, LBar.Colors.CheckedFrameColor, LBar.Colors.CheckedFrameColor);\r\n end;\r\n end;\r\n end\r\n else\r\n FillRect(Rect);\r\n end;\r\n if HasImages then\r\n begin\r\n Draw(Rect.Left + 1, Rect.Top + (LBar.FItemHeight - Bitmap.Height) div 2, Bitmap);\r\n Inc(Rect.Left, Self.Images.Width + 4);\r\n end\r\n else\r\n Inc(Rect.Left, 4);\r\n ItemCaption := Self.Caption;\r\n if (ItemCaption = '') and ((csDesigning in LBar.ComponentState) or (LBar.ControlCount = 0)) then\r\n ItemCaption := Format(RsUntitledFmt, [RsUntitled, Index]);\r\n SetBkMode(ACanvas.Handle, Windows.TRANSPARENT);\r\n if LBar.BiDiMode = bdRightToLeft then\r\n begin\r\n Dec(Rect.Right, 4);\r\n DrawText(ACanvas, ItemCaption, -1, Rect,\r\n DT_SINGLELINE or DT_VCENTER or DT_END_ELLIPSIS or DT_RTLREADING or DT_RIGHT);\r\n end\r\n else\r\n DrawText(ACanvas, ItemCaption, -1, Rect,\r\n DT_SINGLELINE or DT_VCENTER or DT_END_ELLIPSIS);\r\n end;\r\nend;\r\n\r\nfunction TJvXPBarItem.GetActionLinkClass: TJvXPBarItemActionLinkClass;\r\nbegin\r\n Result := TJvXPBarItemActionLink;\r\nend;\r\n\r\nprocedure TJvXPBarItem.Assign(Source: TPersistent);\r\nbegin\r\n if Source is TJvXPBarItem then\r\n with TJvXPBarItem(Source) do\r\n begin\r\n Self.Action := Action;\r\n Self.Caption := Caption;\r\n Self.Data := Data;\r\n Self.DataObject := DataObject;\r\n Self.Enabled := Enabled;\r\n Self.Hint := Hint;\r\n Self.ImageList := ImageList;\r\n Self.ImageIndex := ImageIndex;\r\n Self.Name := Name;\r\n Self.Tag := Tag;\r\n Self.Visible := Visible;\r\n Self.OnClick := OnClick;\r\n Self.AutoCheck := AutoCheck;\r\n Self.Checked := Checked;\r\n Self.GroupIndex := GroupIndex;\r\n Self.OnDblClick := OnDblClick;\r\n end\r\n else\r\n inherited Assign(Source);\r\nend;\r\n\r\nfunction TJvXPBarItem.IsAutoCheckStored: Boolean;\r\nbegin\r\n Result := (ActionLink = nil) or not FActionLink.IsAutoCheckLinked;\r\nend;\r\n\r\nfunction TJvXPBarItem.IsCaptionStored: Boolean;\r\nbegin\r\n Result := (ActionLink = nil) or not FActionLink.IsCaptionLinked;\r\nend;\r\n\r\nfunction TJvXPBarItem.IsEnabledStored: Boolean;\r\nbegin\r\n Result := (ActionLink = nil) or not FActionLink.IsEnabledLinked;\r\nend;\r\n\r\nfunction TJvXPBarItem.IsHintStored: Boolean;\r\nbegin\r\n Result := (ActionLink = nil) or not FActionLink.IsHintLinked;\r\nend;\r\n\r\nfunction TJvXPBarItem.IsImageIndexStored: Boolean;\r\nbegin\r\n Result := (ActionLink = nil) or not FActionLink.IsImageIndexLinked;\r\nend;\r\n\r\nfunction TJvXPBarItem.IsVisibleStored: Boolean;\r\nbegin\r\n Result := (ActionLink = nil) or not FActionLink.IsVisibleLinked;\r\nend;\r\n\r\nfunction TJvXPBarItem.IsOnClickStored: Boolean;\r\nbegin\r\n Result := (ActionLink = nil) or not FActionLink.IsOnExecuteLinked;\r\nend;\r\n\r\nfunction TJvXPBarItem.IsCheckedStored: Boolean;\r\nbegin\r\n Result := (ActionLink = nil) or not FActionLink.IsCheckedLinked;\r\nend;\r\n\r\nprocedure TJvXPBarItem.DoActionChange(Sender: TObject);\r\nbegin\r\n if Sender = Action then\r\n ActionChange(Sender, False);\r\nend;\r\n\r\nfunction TJvXPBarItem.GetAction: TBasicAction;\r\nbegin\r\n if FActionLink <> nil then\r\n Result := FActionLink.Action\r\n else\r\n Result := nil;\r\nend;\r\n\r\nprocedure TJvXPBarItem.SetAction(Value: TBasicAction);\r\nbegin\r\n if (FActionLink <> nil) and (FActionLink.Action <> nil) then\r\n FActionLink.Action.RemoveFreeNotification(FWinXPBar);\r\n if Value = nil then\r\n begin\r\n FActionLink.Free;\r\n FActionLink := nil;\r\n FWinXPBar.InternalRedraw; // redraw image\r\n end\r\n else\r\n begin\r\n if FActionLink = nil then\r\n FActionLink := GetActionLinkClass.Create(Self);\r\n FActionLink.Action := Value;\r\n FActionLink.OnChange := DoActionChange;\r\n ActionChange(Value, csLoading in Value.ComponentState);\r\n Value.FreeNotification(FWinXPBar); // deligates notification to WinXPBar!\r\n end;\r\nend;\r\n\r\nprocedure TJvXPBarItem.SetCaption(Value: TCaption);\r\nbegin\r\n if Value <> FCaption then\r\n begin\r\n FCaption := Value;\r\n FWinXPBar.InternalRedraw;\r\n end;\r\nend;\r\n\r\nprocedure TJvXPBarItem.SetEnabled(Value: Boolean);\r\nbegin\r\n if Value <> FEnabled then\r\n begin\r\n FEnabled := Value;\r\n FWinXPBar.InternalRedraw;\r\n end;\r\nend;\r\n\r\nprocedure TJvXPBarItem.SetImageIndex(Value: TImageIndex);\r\nbegin\r\n if Value <> FImageIndex then\r\n begin\r\n FImageIndex := Value;\r\n FWinXPBar.InternalRedraw;\r\n end;\r\nend;\r\n\r\nprocedure TJvXPBarItem.SetImageList(Value: TCustomImageList);\r\nbegin\r\n if Value <> FImageList then\r\n begin\r\n FImageList := Value;\r\n FWinXPBar.InternalRedraw;\r\n end;\r\nend;\r\n\r\nprocedure TJvXPBarItem.SetName(const Value: string);\r\nbegin\r\n if (Value <> FName) and (FCollection.Find(Value) = nil) then\r\n FName := Value;\r\nend;\r\n\r\nprocedure TJvXPBarItem.SetVisible(Value: Boolean);\r\nbegin\r\n if Value <> FVisible then\r\n begin\r\n FVisible := Value;\r\n FWinXPBar.ItemVisibilityChanged(Self);\r\n FWinXPBar.ResizeToMaxHeight;\r\n end;\r\nend;\r\n\r\nprocedure TJvXPBarItem.SetGroupIndex(const Value: Integer);\r\nbegin\r\n if FGroupIndex <> Value then\r\n begin\r\n FGroupIndex := Value;\r\n if Checked then\r\n TurnSiblingsOff;\r\n end;\r\nend;\r\n\r\nprocedure TJvXPBarItem.SetChecked(const Value: Boolean);\r\nbegin\r\n if FChecked <> Value then\r\n begin\r\n FChecked := Value;\r\n// Change(False);\r\n if Value then\r\n TurnSiblingsOff;\r\n end;\r\nend;\r\n\r\nprocedure TJvXPBarItem.TurnSiblingsOff;\r\nvar\r\n I: Integer;\r\n Item: TJvXPBarItem;\r\nbegin\r\n if (GroupIndex <> 0) and Assigned(FWinXPBar) then\r\n begin\r\n for I := 0 to FWinXPBar.Items.Count - 1 do\r\n begin\r\n Item := FWinXPBar.Items[I];\r\n if (Item <> Self) and (Item.GroupIndex = GroupIndex) then\r\n Item.Checked := False;\r\n end;\r\n end;\r\nend;\r\n\r\n//=== { TJvXPBarItems } ======================================================\r\n\r\nconstructor TJvXPBarItems.Create(WinXPBar: TJvXPCustomWinXPBar);\r\nbegin\r\n inherited Create(GetItemClass);\r\n FWinXPBar := WinXPBar;\r\nend;\r\n\r\nfunction TJvXPBarItems.Add: TJvXPBarItem;\r\nbegin\r\n Result := TJvXPBarItem(inherited Add);\r\nend;\r\n\r\nfunction TJvXPBarItems.Add(Action: TBasicAction): TJvXPBarItem;\r\nbegin\r\n Result := Add;\r\n Result.Action := Action;\r\nend;\r\n\r\nfunction TJvXPBarItems.Add(DataObject: TObject): TJvXPBarItem;\r\nbegin\r\n Result := Add;\r\n Result.DataObject := DataObject;\r\nend;\r\n\r\nfunction TJvXPBarItems.Insert(Index: Integer): TJvXPBarItem;\r\nbegin\r\n Result := TJvXPBarItem(inherited Insert(Index));\r\nend;\r\n\r\nfunction TJvXPBarItems.Insert(Index: Integer; Action: TBasicAction): TJvXPBarItem;\r\nbegin\r\n Result := Insert(Index);\r\n Result.Action := Action;\r\nend;\r\n\r\nfunction TJvXPBarItems.Insert(Index: Integer; DataObject: TObject): TJvXPBarItem;\r\nbegin\r\n Result := Insert(Index);\r\n Result.DataObject := DataObject;\r\nend;\r\n\r\nfunction TJvXPBarItems.GetOwner: TPersistent;\r\nbegin\r\n Result := FWinXPBar;\r\nend;\r\n\r\nclass function TJvXPBarItems.GetItemClass: TJvXPBarItemClass;\r\nbegin\r\n Result := TJvXPBarItem;\r\nend;\r\n\r\nfunction TJvXPBarItems.GetItem(Index: Integer): TJvXPBarItem;\r\nbegin\r\n Result := TJvXPBarItem(inherited GetItem(Index));\r\nend;\r\n\r\nprocedure TJvXPBarItems.SetItem(Index: Integer; Value: TJvXPBarItem);\r\nbegin\r\n inherited SetItem(Index, Value);\r\nend;\r\n\r\nprocedure TJvXPBarItems.Update(Item: TCollectionItem);\r\nbegin\r\n FWinXPBar.SortVisibleItems(True);\r\nend;\r\n\r\nfunction TJvXPBarItems.Find(const AName: string): TJvXPBarItem;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := nil;\r\n for I := 0 to Count - 1 do\r\n if Items[I].Name = AName then\r\n begin\r\n Result := Items[I];\r\n Break;\r\n end;\r\nend;\r\n\r\nfunction TJvXPBarItems.Find(const Action: TBasicAction): TJvXPBarItem;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := nil;\r\n for I := 0 to Count - 1 do\r\n if Items[I].Action = Action then\r\n begin\r\n Result := Items[I];\r\n Break;\r\n end;\r\nend;\r\n\r\nfunction TJvXPBarItems.Find(const DataObject: TObject): TJvXPBarItem;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := nil;\r\n for I := 0 to Count - 1 do\r\n if Items[I].DataObject = DataObject then\r\n begin\r\n Result := Items[I];\r\n Break;\r\n end;\r\nend;\r\n\r\n//=== { TJvXPBarVisibleItems } ===============================================\r\n\r\nconstructor TJvXPBarVisibleItems.Create(WinXPBar: TJvXPCustomWinXPBar);\r\nbegin\r\n inherited Create;\r\n FItems := TList.Create;\r\n FWinXPBar := WinXPBar;\r\nend;\r\n\r\ndestructor TJvXPBarVisibleItems.Destroy;\r\nbegin\r\n FItems.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJvXPBarVisibleItems.GetItem(Index: Integer): TJvXPBarItem;\r\nbegin\r\n Result := nil;\r\n if Index < FItems.Count then\r\n Result := FItems[Index];\r\nend;\r\n\r\nfunction TJvXPBarVisibleItems.Count: Integer;\r\nbegin\r\n Result := FItems.Count;\r\nend;\r\n\r\nfunction TJvXPBarVisibleItems.Exists(Item: TJvXPBarItem): Boolean;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := False;\r\n for I := 0 to Count - 1 do\r\n if Items[I] = Item then\r\n begin\r\n Result := True;\r\n Break;\r\n end;\r\nend;\r\n\r\nprocedure TJvXPBarVisibleItems.Add(Item: TJvXPBarItem);\r\nbegin\r\n if not Exists(Item) then\r\n begin\r\n FItems.Add(Item);\r\n FWinXPBar.SortVisibleItems(False);\r\n end;\r\nend;\r\n\r\nprocedure TJvXPBarVisibleItems.Delete(Item: TJvXPBarItem);\r\nbegin\r\n if Exists(Item) then\r\n FItems.Delete(FItems.IndexOf(Item));\r\nend;\r\n\r\n//=== { TJvXPFadeThread } ====================================================\r\n\r\nconstructor TJvXPFadeThread.Create(WinXPBar: TJvXPCustomWinXPBar;\r\n RollDirection: TJvXPBarRollDirection);\r\nbegin\r\n inherited Create(False);\r\n FWinXPBar := WinXPBar;\r\n FRollDirection := RollDirection;\r\n FreeOnTerminate := True;\r\n ThreadName := Format('%s: %s',[ClassName, WinXPBar.Name]);\r\nend;\r\n\r\nprocedure TJvXPFadeThread.DoWinXPBarInternalRedraw;\r\nbegin\r\n FWinXPBar.InternalRedraw;\r\nend;\r\n\r\nprocedure TJvXPFadeThread.DoWinXPBarSetRollOffset;\r\nbegin\r\n FWinXPBar.RollOffset := FWinXPBarNewOffSet;\r\nend;\r\n\r\nprocedure TJvXPFadeThread.Execute;\r\nvar\r\n NewOffset: Integer;\r\nbegin\r\n NameThread(ThreadName);\r\n while not Terminated do\r\n try\r\n FWinXPBar.FRolling := True;\r\n\r\n { calculate new roll offset }\r\n if FRollDirection = rdCollapse then\r\n NewOffset := FWinXPBar.RollOffset - FWinXPBar.FRollStep\r\n else\r\n NewOffset := FWinXPBar.RollOffset + FWinXPBar.FRollStep;\r\n\r\n { validate offset ranges }\r\n if NewOffset < 0 then\r\n NewOffset := 0;\r\n if NewOffset > FWinXPBar.FItemHeight then\r\n NewOffset := FWinXPBar.FItemHeight;\r\n\r\n FWinXPBarNewOffSet := NewOffset;\r\n Synchronize(DoWinXPBarSetRollOffset);\r\n\r\n\r\n { terminate on 'out-of-range' }\r\n if ((FRollDirection = rdCollapse) and (NewOffset = 0)) or\r\n ((FRollDirection = rdExpand) and (NewOffset = FWinXPBar.FItemHeight)) then\r\n Terminate;\r\n\r\n { idle process }\r\n Sleep(FWinXPBar.FRollDelay);\r\n finally\r\n FWinXPBar.FRolling := False;\r\n end;\r\n\r\n { redraw button state }\r\n FWinXPBar.FCollapsed := FRollDirection = rdCollapse;\r\n if FWinXPBar.FShowRollButton then\r\n Synchronize(DoWinXPBarInternalRedraw);\r\n\r\n { update inspector }\r\n if csDesigning in FWinXPBar.ComponentState then\r\n TCustomForm(FWinXPBar.Owner).Designer.Modified\r\n else\r\n PostMessage(FWinXPBar.Handle, WM_XPBARAFTERCOLLAPSE,\r\n Ord(FRollDirection = rdCollapse), 0);\r\nend;\r\n\r\n//=== { TJvXPBarColors } =====================================================\r\n\r\nconstructor TJvXPBarColors.Create;\r\n{$IFDEF JVCLThemesEnabled}\r\nvar\r\n Details: TThemedElementDetails;\r\n AColor: COLORREF;\r\n{$ENDIF JVCLThemesEnabled}\r\nbegin\r\n inherited Create;\r\n // (rom) needs local color constants\r\n FBodyColor := dxColor_BodyColorXP;\r\n FBodyBorderColor := dxColor_BodyColorXP;\r\n FBorderColor := clWhite;\r\n FGradientFrom := clWhite;\r\n FGradientTo := TColor($00F7D7C6);\r\n FSeparatorColor := TColor($00F7D7C6);\r\n FCheckedColor := dxColor_CheckedColorXP;\r\n FFocusedColor := dxColor_FocusedColorXP;\r\n FCheckedFrameColor := dxColor_CheckedFrameColorXP;\r\n FFocusedFrameColor := dxColor_FocusedFrameColorXP;\r\n {$IFDEF JVCLThemesEnabled}\r\n if ThemeServices.{$IFDEF RTL230_UP}Enabled{$ELSE}ThemesEnabled{$ENDIF RTL230_UP} then\r\n begin\r\n Details := ThemeServices.GetElementDetails(tebHeaderBackgroundNormal);\r\n with Details do\r\n begin\r\n if GetThemeColor(ThemeServices.Theme[Element], Part, State,\r\n TMT_FILLCOLOR, AColor) = 0 then\r\n FBodyColor := AColor;\r\n if GetThemeColor(ThemeServices.Theme[Element], Part, State,\r\n TMT_GRADIENTCOLOR1, AColor) = 0 then\r\n FGradientFrom := AColor;\r\n if GetThemeColor(ThemeServices.Theme[Element], Part, State,\r\n TMT_GRADIENTCOLOR2, AColor) = 0 then\r\n FGradientTo := AColor;\r\n if GetThemeColor(ThemeServices.Theme[Element], Part, State,\r\n TMT_EDGEFILLCOLOR, AColor) = 0 then\r\n FSeparatorColor := AColor;\r\n end;\r\n end;\r\n {$ENDIF JVCLThemesEnabled}\r\nend;\r\n\r\nprocedure TJvXPBarColors.Assign(Source: TPersistent);\r\nbegin\r\n if Source is TJvXPBarColors then\r\n with TJvXPBarColors(Source) do\r\n begin\r\n Self.CheckedColor := CheckedColor;\r\n Self.FocusedColor := FocusedColor;\r\n Self.CheckedFrameColor := CheckedFrameColor;\r\n Self.FocusedFrameColor := FocusedFrameColor;\r\n Self.BodyColor := BodyColor;\r\n Self.GradientTo := GradientTo;\r\n Self.GradientFrom := GradientFrom;\r\n Self.SeparatorColor := SeparatorColor;\r\n end\r\n else\r\n inherited Assign(Source);\r\nend;\r\n\r\nprocedure TJvXPBarColors.Change;\r\nbegin\r\n if Assigned(FOnChange) then\r\n FOnChange(Self);\r\nend;\r\n\r\nprocedure TJvXPBarColors.SetBodyColor(const Value: TColor);\r\nbegin\r\n if FBodyColor <> Value then\r\n begin\r\n FBodyColor := Value;\r\n Change;\r\n end;\r\nend;\r\n\r\nprocedure TJvXPBarColors.SetGradientFrom(const Value: TColor);\r\nbegin\r\n if FGradientFrom <> Value then\r\n begin\r\n FGradientFrom := Value;\r\n Change;\r\n end;\r\nend;\r\n\r\nprocedure TJvXPBarColors.SetGradientTo(const Value: TColor);\r\nbegin\r\n if FGradientTo <> Value then\r\n begin\r\n FGradientTo := Value;\r\n Change;\r\n end;\r\nend;\r\n\r\nprocedure TJvXPBarColors.SetSeparatorColor(const Value: TColor);\r\nbegin\r\n if FSeparatorColor <> Value then\r\n begin\r\n FSeparatorColor := Value;\r\n Change;\r\n end;\r\nend;\r\n\r\nprocedure TJvXPBarColors.SetCheckedColor(const Value: TColor);\r\nbegin\r\n if FCheckedColor <> Value then\r\n begin\r\n FCheckedColor := Value;\r\n Change;\r\n end;\r\nend;\r\n\r\nprocedure TJvXPBarColors.SetBorderColor(const Value: TColor);\r\nbegin\r\n if FBorderColor <> Value then\r\n begin\r\n FBorderColor := Value;\r\n Change;\r\n end;\r\nend;\r\n\r\nprocedure TJvXPBarColors.SetFocusedColor(const Value: TColor);\r\nbegin\r\n if FFocusedColor <> Value then\r\n begin\r\n FFocusedColor := Value;\r\n Change;\r\n end;\r\nend;\r\n\r\nprocedure TJvXPBarColors.SetCheckedFrameColor(const Value: TColor);\r\nbegin\r\n if FCheckedFrameColor <> Value then\r\n begin\r\n FCheckedFrameColor := Value;\r\n Change;\r\n end;\r\nend;\r\n\r\nprocedure TJvXPBarColors.SetFocusedFrameColor(const Value: TColor);\r\nbegin\r\n if FFocusedFrameColor <> Value then\r\n begin\r\n FFocusedFrameColor := Value;\r\n Change;\r\n end;\r\nend;\r\n\r\nprocedure TJvXPBarColors.SetBodyBorderColor(const Value: TColor);\r\nbegin\r\n if FBodyBorderColor <> Value then\r\n begin\r\n FBodyBorderColor := Value;\r\n Change;\r\n end;\r\nend;\r\n\r\n//=== { TJvXPCustomWinXPBar } ================================================\r\n\r\nconstructor TJvXPCustomWinXPBar.Create(AOwner: TComponent);\r\nconst\r\n MouseEvents: TJvXPControlStyle = [csRedrawMouseEnter, csRedrawMouseLeave];\r\nbegin\r\n inherited Create(AOwner);\r\n FStoredHint := '|'; // no one in their right mind uses a pipe as the only character in a hint...\r\n ControlStyle := ControlStyle {- [csDoubleClicks]} + [csAcceptsControls, csActionClient];\r\n ExControlStyle := [csRedrawCaptionChanged];\r\n ExControlStyle := ExControlStyle + MouseEvents;\r\n Height := 46;\r\n HotTrack := True; // initialize mouse events\r\n Width := 153;\r\n FColors := TJvXPBarColors.Create;\r\n FColors.OnChange := DoColorsChange;\r\n FCollapsed := False;\r\n FFadeThread := nil;\r\n FImageChangeLink := TChangeLink.Create;\r\n FImageChangeLink.OnChange := DoColorsChange;\r\n FRollChangeLink := TChangeLink.Create;\r\n FRollChangeLink.OnChange := DoColorsChange;\r\n FTopSpace := 5;\r\n\r\n FFont := TFont.Create;\r\n FFont.Color := $00840000;\r\n FFont.Size := 8;\r\n FFont.OnChange := FontChange;\r\n FGradient := TBitmap.Create;\r\n FHeaderHeight := 28;\r\n FHeaderRounded := True;\r\n FGradientWidth := 0;\r\n FHeaderFont := TFont.Create;\r\n FHeaderFont.Color := $00840000;\r\n FHeaderFont.Size := 8;\r\n FHeaderFont.Style := [fsBold];\r\n FHeaderFont.OnChange := FontChange;\r\n\r\n FHitTest := htNone;\r\n\r\n FHotTrackColor := $00FF7C35;\r\n FHoverIndex := -1;\r\n FIcon := TIcon.Create;\r\n FItemHeight := 20;\r\n FItems := GetBarItemsClass.Create(Self);\r\n FRollDelay := 25;\r\n FRolling := False;\r\n FRollMode := rmShrink;\r\n FRollOffset := FItemHeight;\r\n FRollStep := 3;\r\n FShowLinkCursor := True;\r\n FShowRollButton := True;\r\n FVisibleItems := TJvXPBarVisibleItems.Create(Self);\r\nend;\r\n\r\ndestructor TJvXPCustomWinXPBar.Destroy;\r\nbegin\r\n FFont.Free;\r\n FHeaderFont.Free;\r\n FGradient.Free;\r\n FIcon.Free;\r\n FItems.Free;\r\n FVisibleItems.Free;\r\n FColors.Free;\r\n FImageChangeLink.Free;\r\n FRollChangeLink.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvXPCustomWinXPBar.Notification(AComponent: TComponent;\r\n Operation: TOperation);\r\nvar\r\n I: Integer;\r\nbegin\r\n if not (csDestroying in ComponentState) and (Operation = opRemove) then\r\n begin\r\n if AComponent = FImageList then\r\n ImageList := nil;\r\n if AComponent = FRollImages then\r\n RollImages := nil;\r\n for I := 0 to FItems.Count - 1 do\r\n FItems[I].Notification(AComponent);\r\n end;\r\n inherited Notification(AComponent, Operation);\r\nend;\r\n\r\nfunction TJvXPCustomWinXPBar.IsFontStored: Boolean;\r\nbegin\r\n Result := not ParentFont and not DesktopFont ;\r\nend;\r\n\r\nprocedure TJvXPCustomWinXPBar.FontChange(Sender: TObject);\r\nbegin\r\n if (not FFontChanging) and not (csLoading in ComponentState) then\r\n ParentFont := False;\r\n InternalRedraw;\r\nend;\r\n\r\nprocedure TJvXPCustomWinXPBar.ResizeToMaxHeight;\r\nvar\r\n NewHeight: Integer;\r\nbegin\r\n { TODO: Check this!!! }\r\n if IsLocked or (csLoading in ComponentState) then\r\n Exit;\r\n NewHeight := FC_HEADER_MARGIN + HeaderHeight + FVisibleItems.Count * FRollOffset + FC_ITEM_MARGIN + 1;\r\n { full collapsing }\r\n if ((FRolling and not FCollapsed) or (not FRolling and FCollapsed) or\r\n (FVisibleItems.Count = 0)) then\r\n Dec(NewHeight, FC_ITEM_MARGIN);\r\n// if Height <> NewHeight then\r\n Height := NewHeight - 5 + FTopSpace;\r\nend;\r\n\r\nprocedure TJvXPCustomWinXPBar.WMWindowposchanging(var Msg: TWMWindowPosChanging);\r\nvar\r\n NewHeight: Integer;\r\nbegin\r\n if Msg.WindowPos.flags and SWP_NOSIZE = 0 then\r\n begin\r\n NewHeight := FC_HEADER_MARGIN + HeaderHeight + FVisibleItems.Count * FRollOffset + FC_ITEM_MARGIN + 1;\r\n { full collapsing }\r\n if ((FRolling and not FCollapsed) or (not FRolling and FCollapsed) or\r\n (FVisibleItems.Count = 0)) then\r\n Dec(NewHeight, FC_ITEM_MARGIN);\r\n\r\n Msg.WindowPos.cy := NewHeight - 5 + FTopSpace;\r\n end;\r\n inherited;\r\nend;\r\n\r\nfunction TJvXPCustomWinXPBar.GetHitTestAt(X, Y: Integer): TJvXPBarHitTest;\r\nbegin\r\n Result := htNone;\r\n if PtInRect(GetHitTestRect(htHeader), Point(X, Y)) then\r\n Result := htHeader;\r\n if PtInRect(GetHitTestRect(htRollButton), Point(X, Y)) then\r\n Result := htRollButton;\r\nend;\r\n\r\nfunction TJvXPCustomWinXPBar.GetItemRect(Index: Integer): TRect;\r\nbegin\r\n Result.Left := 3;\r\n Result.Right := Width - 3;\r\n if FRollMode = rmShrink then\r\n Result.Top := FC_HEADER_MARGIN + HeaderHeight + FC_ITEM_MARGIN div 2 +\r\n Index * FRollOffset - 4 + FTopSpace\r\n else\r\n Result.Top := FC_HEADER_MARGIN + HeaderHeight + FC_ITEM_MARGIN div 2 +\r\n Index * FItemHeight - 4 + FTopSpace;\r\n Result.Bottom := Result.Top + FItemHeight;\r\nend;\r\n\r\nfunction TJvXPCustomWinXPBar.GetRollHeight: Integer;\r\nbegin\r\n if Assigned(FRollImages) then\r\n Result := FRollImages.Height\r\n else\r\n Result := 18;\r\nend;\r\n\r\nfunction TJvXPCustomWinXPBar.GetRollWidth: Integer;\r\nbegin\r\n if Assigned(FRollImages) then\r\n Result := FRollImages.Width\r\n else\r\n Result := 18;\r\nend;\r\n\r\nfunction TJvXPCustomWinXPBar.GetHitTestRect(const HitTest: TJvXPBarHitTest): TRect;\r\n\r\nbegin\r\n case HitTest of\r\n htHeader:\r\n Result := Bounds(0, FTopSpace, Width, FHeaderHeight);\r\n htRollButton:\r\n Result := Bounds(Width - 24, FTopSpace + (FHeaderHeight - GetRollHeight) div 2, GetRollWidth, GetRollHeight);\r\n end;\r\nend;\r\n\r\nprocedure TJvXPCustomWinXPBar.SortVisibleItems(const Redraw: Boolean);\r\nbegin\r\n if (csLoading in ComponentState) or (csDestroying in ComponentState) then\r\n Exit;\r\n FVisibleItems.FItems.Sort(SortByIndex);\r\n if Redraw then\r\n InternalRedraw;\r\nend;\r\n\r\nprocedure TJvXPCustomWinXPBar.ItemVisibilityChanged(Item: TJvXPBarItem);\r\nbegin\r\n // update visible-item list\r\n if Item.Visible then\r\n FVisibleItems.Add(Item)\r\n else\r\n FVisibleItems.Delete(Item);\r\nend;\r\n\r\nprocedure TJvXPCustomWinXPBar.Loaded;\r\nbegin\r\n inherited Loaded;\r\n ResizeToMaxHeight;\r\nend;\r\n\r\nprocedure TJvXPCustomWinXPBar.CreateWnd;\r\nbegin\r\n inherited CreateWnd; // sends WM_SIZE but no WM_WINDOWPOSCHANGING\r\n ResizeToMaxHeight;\r\nend;\r\n\r\nprocedure TJvXPCustomWinXPBar.HookMouseDown;\r\nvar\r\n Rect: TRect;\r\nbegin\r\n inherited HookMouseDown; // update drawstate\r\n if FHitTest = htRollButton then\r\n begin\r\n Rect := GetHitTestRect(htRollButton);\r\n Windows.InvalidateRect(Handle, @Rect, False);\r\n end;\r\nend;\r\n\r\nprocedure TJvXPCustomWinXPBar.HookMouseEnter;\r\nbegin\r\n inherited HookMouseEnter;\r\n if FHoverIndex <> -1 then\r\n DoDrawItem(FHoverIndex, [dsFocused]);\r\nend;\r\n\r\nprocedure TJvXPCustomWinXPBar.HookMouseLeave;\r\nbegin\r\n inherited HookMouseLeave;\r\n if (FHoverIndex <> -1) and (FVisibleItems[FHoverIndex] <> nil) and\r\n (not FVisibleItems[FHoverIndex].Checked) then\r\n DoDrawItem(FHoverIndex, []);\r\n\r\n // Mantis 4867: Must reset hover index when leaving the bar\r\n FHoverIndex := -1;\r\nend;\r\n\r\n\r\nfunction TJvXPCustomWinXPBar.GetItemAt(X, Y: Integer): Integer;\r\nvar\r\n Header: Integer;\r\nbegin\r\n Header := FC_HEADER_MARGIN div 2 + HeaderHeight + FC_ITEM_MARGIN div 2 + FTopSpace;\r\n if (Y < Header) or (Y > Height - FC_ITEM_MARGIN div 2) then\r\n Result := -1\r\n else\r\n Result := (Y - Header) div ItemHeight;\r\nend;\r\n\r\nprocedure TJvXPCustomWinXPBar.HookMouseMove(X, Y: Integer);\r\nconst\r\n cPipe = '|';\r\nvar\r\n Rect: TRect;\r\n OldHitTest: TJvXPBarHitTest;\r\n NewIndex: Integer;\r\nbegin\r\n OldHitTest := FHitTest;\r\n FHitTest := GetHitTestAt(X, Y);\r\n if FHitTest <> OldHitTest then\r\n begin\r\n Rect := Bounds(0, FTopSpace, Width, FHeaderHeight); // header\r\n Windows.InvalidateRect(Handle, @Rect, False);\r\n if FShowLinkCursor then\r\n if FHitTest <> htNone then\r\n Cursor := crHandPoint\r\n else\r\n Cursor := crDefault;\r\n end;\r\n\r\n NewIndex := GetItemAt(X, Y);\r\n\r\n if (NewIndex >= 0) and (NewIndex < VisibleItems.Count) then\r\n begin\r\n if FStoredHint = cPipe then\r\n FStoredHint := Hint;\r\n if Action is TCustomAction then\r\n inherited Hint := TCustomAction(Action).Hint\r\n else\r\n inherited Hint := VisibleItems[NewIndex].Hint;\r\n end\r\n else\r\n begin\r\n NewIndex := -1;\r\n if FStoredHint <> cPipe then\r\n inherited Hint := FStoredHint;\r\n FStoredHint := cPipe;\r\n end;\r\n\r\n if NewIndex <> FHoverIndex then\r\n begin\r\n if (FHoverIndex <> -1) and (FVisibleItems[FHoverIndex] <> nil) then\r\n if FVisibleItems[FHoverIndex].Checked then\r\n DoDrawItem(FHoverIndex, [dsClicked])\r\n else\r\n DoDrawItem(FHoverIndex, []);\r\n FHoverIndex := NewIndex;\r\n if (FHoverIndex <> -1) and (FVisibleItems[FHoverIndex] <> nil) and\r\n (FVisibleItems[FHoverIndex].Enabled) then\r\n begin\r\n DoDrawItem(FHoverIndex, [dsFocused]);\r\n if FShowLinkCursor then\r\n Cursor := crHandPoint;\r\n end\r\n else\r\n if FShowLinkCursor then\r\n Cursor := crDefault;\r\n end;\r\n\r\n inherited HookMouseMove(X, Y);\r\nend;\r\n\r\nprocedure TJvXPCustomWinXPBar.HookParentFontChanged;\r\nbegin\r\n if ParentFont then\r\n begin\r\n FFontChanging := True;\r\n try\r\n FFont.Color := $00E75100;\r\n FFont.Name := inherited Font.Name;\r\n FFont.Size := 8;\r\n FFont.Style := inherited Font.Style;\r\n FHeaderFont.Color := $00E75100;\r\n FHeaderFont.Name := Font.Name;\r\n FHeaderFont.Size := 8;\r\n FHeaderFont.Style := [fsBold];\r\n finally\r\n FFontChanging := False;\r\n end;\r\n inherited HookParentFontChanged;\r\n end;\r\nend;\r\n\r\nprocedure TJvXPCustomWinXPBar.HookResized;\r\nbegin\r\n // perform actions only on 'width'-change\r\n if FGradientWidth <> Width then\r\n begin\r\n FGradientWidth := Width;\r\n // recreate gradient rect\r\n JvXPCreateGradientRect(Width, FHeaderHeight,\r\n clWhite, $00F7D7C6, 32, gsLeft, False, FGradient);\r\n end;\r\n\r\n // resize to maximum height\r\n //ResizeToMaxHeight; done in WM_WINDOWPOSCHANGING\r\n inherited HookResized;\r\nend;\r\n\r\nprocedure TJvXPCustomWinXPBar.SetCollapsed(Value: Boolean);\r\nbegin\r\n if Value <> FCollapsed then\r\n begin\r\n // Using fading while loading is useless.\r\n // Using the fading thread at design time is NOT safe. See Mantis 3547.\r\n if ComponentState * [csLoading, csDesigning] = [] then\r\n begin\r\n if Assigned(FBeforeCollapsedChange) then\r\n FBeforeCollapsedChange(Self, Value);\r\n if Value then\r\n FFadeThread := TJvXPFadeThread.Create(Self, rdCollapse)\r\n else\r\n FFadeThread := TJvXPFadeThread.Create(Self, rdExpand);\r\n if Assigned(FOnCollapsedChange) then\r\n FOnCollapsedChange(Self, Value);\r\n end\r\n else\r\n begin\r\n FCollapsed := Value;\r\n FRolling := True;\r\n if Value then\r\n RollOffset := 0\r\n else\r\n RollOffset := FItemHeight;\r\n FRolling := False;\r\n if Grouped and not Value then\r\n GroupMessage;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvXPCustomWinXPBar.SetFont(Value: TFont);\r\nbegin\r\n FFont.Assign(Value);\r\n InternalRedraw;\r\nend;\r\n\r\nprocedure TJvXPCustomWinXPBar.SetHeaderFont(Value: TFont);\r\nbegin\r\n FHeaderFont.Assign(Value);\r\n InternalRedraw;\r\nend;\r\n\r\nprocedure TJvXPCustomWinXPBar.SetHotTrack(Value: Boolean);\r\nconst\r\n MouseEvents: TJvXPControlStyle = [csRedrawMouseEnter, csRedrawMouseLeave];\r\nbegin\r\n if Value <> FHotTrack then\r\n begin\r\n FHotTrack := Value;\r\n// if FHotTrack then\r\n// ExControlStyle := ExControlStyle + MouseEvents\r\n// else\r\n// ExControlStyle := ExControlStyle - MouseEvents;\r\n if not (csLoading in ComponentState) then\r\n InternalRedraw;\r\n end;\r\nend;\r\n\r\nprocedure TJvXPCustomWinXPBar.SetHotTrackColor(Value: TColor);\r\nbegin\r\n if Value <> FHotTrackColor then\r\n begin\r\n FHotTrackColor := Value;\r\n InternalRedraw;\r\n end;\r\nend;\r\n\r\nprocedure TJvXPCustomWinXPBar.SetIcon(Value: TIcon);\r\nbegin\r\n if Value <> FIcon then\r\n begin\r\n FIcon.Assign(Value);\r\n InternalRedraw;\r\n end;\r\nend;\r\n\r\nprocedure TJvXPCustomWinXPBar.SetImageList(Value: TCustomImageList);\r\nbegin\r\n if ReplaceImageListReference(Self, Value, FImageList, FImageChangeLink) then\r\n InternalRedraw;\r\nend;\r\n\r\nprocedure TJvXPCustomWinXPBar.SetItemHeight(Value: Integer);\r\nbegin\r\n if Value <> FItemHeight then\r\n begin\r\n FItemHeight := Value;\r\n if not FCollapsed then\r\n RollOffset := FItemHeight\r\n else\r\n ResizeToMaxHeight;\r\n end;\r\nend;\r\n\r\nprocedure TJvXPCustomWinXPBar.SetItems(Value: TJvXPBarItems);\r\nbegin\r\n FItems.Assign(Value);\r\nend;\r\n\r\nprocedure TJvXPCustomWinXPBar.SetRollOffset(const Value: Integer);\r\nbegin\r\n if Value <> FRollOffset then\r\n begin\r\n FRollOffset := Value;\r\n ResizeToMaxHeight;\r\n end;\r\nend;\r\n\r\nprocedure TJvXPCustomWinXPBar.SetShowRollButton(Value: Boolean);\r\nbegin\r\n if Value <> FShowRollButton then\r\n begin\r\n FShowRollButton := Value;\r\n InternalRedraw;\r\n end;\r\nend;\r\n\r\nprocedure TJvXPCustomWinXPBar.EndUpdate;\r\nbegin\r\n inherited EndUpdate;\r\n ResizeToMaxHeight;\r\nend;\r\n\r\nprocedure TJvXPCustomWinXPBar.Click;\r\nvar\r\n AllowChange, CallInherited: Boolean;\r\n LItem: TJvXPBarItem;\r\nbegin\r\n CallInherited := True;\r\n if FShowRollButton and (FHitTest <> htNone) then\r\n Collapsed := not Collapsed;\r\n if (FHoverIndex <> -1) and (FVisibleItems[FHoverIndex] <> nil) and\r\n FVisibleItems[FHoverIndex].Enabled then\r\n begin\r\n AllowChange := True;\r\n if Assigned(FOnCanChange) then\r\n FOnCanChange(Self, FVisibleItems[FHoverIndex], AllowChange);\r\n if not AllowChange then\r\n Exit;\r\n\r\n //dejoy add\r\n LItem := FVisibleItems[FHoverIndex];\r\n with LItem do\r\n begin\r\n if (not Assigned(ActionLink) and AutoCheck) or\r\n (Assigned(ActionLink) and not ActionLink.IsAutoCheckLinked and AutoCheck) then\r\n LItem.Checked := not LItem.Checked;\r\n end;\r\n if FVisibleItems[FHoverIndex].Checked then\r\n DrawState := DrawState + [dsClicked]\r\n else\r\n DrawState := DrawState - [dsClicked];\r\n\r\n if Assigned(FOnItemClick) then\r\n begin\r\n FOnItemClick(Self, FVisibleItems[FHoverIndex]);\r\n CallInherited := False;\r\n end;\r\n\r\n // OnItemClick might steer focus away, thus removing the hovering item\r\n if (FHoverIndex > -1) and Assigned(FVisibleItems[FHoverIndex].FOnClick) then\r\n begin\r\n { set linked 'action' as Sender }\r\n if Assigned(FVisibleItems[FHoverIndex].Action) and\r\n (@FVisibleItems[FHoverIndex].FOnClick <> @FVisibleItems[FHoverIndex].Action.OnExecute) then\r\n FVisibleItems[FHoverIndex].FOnClick(FVisibleItems[FHoverIndex])\r\n else\r\n if not (csDesigning in ComponentState) and Assigned(FVisibleItems[FHoverIndex].ActionLink) then\r\n FVisibleItems[FHoverIndex].ActionLink.Execute(Self)\r\n else\r\n if Assigned(FVisibleItems[FHoverIndex].FOnClick) then\r\n FVisibleItems[FHoverIndex].FOnClick(FVisibleItems[FHoverIndex]);\r\n\r\n CallInherited := False;\r\n end;\r\n Collapsed := False;\r\n InternalRedraw; //dejoy\r\n end;\r\n if CallInherited then\r\n inherited Click;\r\nend;\r\n\r\nprocedure TJvXPCustomWinXPBar.DoDrawItem(const Index: Integer; State: TJvXPDrawState);\r\nvar\r\n Bitmap: TJvBitmap;\r\n ItemRect: TRect;\r\n HasImages: Boolean;\r\nbegin\r\n Bitmap := TJvBitmap.Create;\r\n with Canvas do\r\n try\r\n Bitmap.Assign(nil);\r\n ItemRect := GetItemRect(Index);\r\n HasImages := FVisibleItems[Index].Images <> nil;\r\n if HasImages then\r\n begin\r\n {$IFDEF XP_TRANSPARENCY_FIX}\r\n BitmapBgPaint(Bitmap, {WinXPBar.}Colors.BodyColor);\r\n {$ENDIF XP_TRANSPARENCY_FIX}\r\n FVisibleItems[Index].Images.GetBitmap(FVisibleItems[Index].ImageIndex, Bitmap);\r\n end;\r\n Bitmap.Transparent := True;\r\n if OwnerDraw then\r\n begin\r\n if Assigned(FOnDrawItem) then\r\n FOnDrawItem(Self, Canvas, ItemRect, State, FVisibleItems[Index], Bitmap);\r\n end\r\n else\r\n FVisibleItems[Index].DrawItem(Self, Canvas, ItemRect, State, ShowItemFrame, Bitmap);\r\n finally\r\n Bitmap.Free;\r\n end;\r\nend;\r\n\r\nprocedure TJvXPCustomWinXPBar.Paint;\r\n // (rom) Do as prefix for a local function is not ideal\r\n procedure DoDrawBackground(ACanvas: TCanvas; var R: TRect);\r\n begin\r\n ACanvas.Brush.Color := FColors.BodyColor; //$00F7DFD6;\r\n Inc(R.Top, FTopSpace + FHeaderHeight);\r\n if OwnerDraw then\r\n begin\r\n if Assigned(FOnDrawBackground) then\r\n FOnDrawBackground(Self, ACanvas, R);\r\n end\r\n else\r\n begin\r\n if not FCollapsed and (FColors.FBodyColor <> FColors.FBodyBorderColor) then\r\n begin\r\n ACanvas.Pen.Color := FColors.FBodyBorderColor;\r\n ACanvas.Rectangle(R.Left, R.Top, R.Right, R.Bottom - 1);\r\n end\r\n else\r\n ACanvas.FillRect(R);\r\n end;\r\n end;\r\n\r\n procedure DoDrawHeader(ACanvas: TCanvas; var R: TRect);\r\n var\r\n Index: Integer;\r\n OwnColor: TColor;\r\n Bitmap: TBitmap;\r\n begin\r\n Dec(R.Top, FHeaderHeight);\r\n R.Bottom := R.Top + FHeaderHeight;\r\n if OwnerDraw then\r\n begin\r\n ACanvas.Brush.Color := FColors.FBorderColor;\r\n if Assigned(FOnDrawHeader) then\r\n FOnDrawHeader(Self, ACanvas, R);\r\n end\r\n else\r\n begin\r\n JvXPCreateGradientRect(Width, FHeaderHeight, FColors.GradientFrom,\r\n FColors.GradientTo, 32, gsLeft, True, FGradient);\r\n ACanvas.Draw(0, R.Top, FGradient);\r\n\r\n { draw frame... }\r\n ACanvas.Brush.Color := FColors.FBorderColor;\r\n ACanvas.FrameRect(R);\r\n\r\n if FHeaderRounded then\r\n begin\r\n OwnColor := TJvXPWinControl(Parent).Color;\r\n ACanvas.Pixels[0, R.Top] := OwnColor;\r\n ACanvas.Pixels[0, R.Top + 1] := OwnColor;\r\n ACanvas.Pixels[1, R.Top] := OwnColor;\r\n ACanvas.Pixels[1, R.Top + 1] := FColors.FBorderColor;\r\n ACanvas.Pixels[Width - 1, R.Top] := OwnColor;\r\n ACanvas.Pixels[Width - 2, R.Top] := OwnColor;\r\n ACanvas.Pixels[Width - 1, R.Top + 1] := OwnColor;\r\n ACanvas.Pixels[Width - 2, R.Top + 1] := FColors.FBorderColor;\r\n end;\r\n\r\n // Paint rollover button: (expanded/collapsed state button images)\r\n if FShowRollButton and (Width >= 115) then\r\n begin\r\n Bitmap := TBitmap.Create;\r\n try\r\n if Assigned(FRollImages) then\r\n begin\r\n // format:\r\n // 0 - normal collapsed\r\n // 1 - normal expanded\r\n // 2 - hot collapsed\r\n // 3 - hot expanded\r\n // 4 - down collapsed\r\n // 5 - down expanded\r\n Index := 0; // normal\r\n if FHitTest = htRollButton then\r\n begin\r\n if dsHighlight in DrawState then\r\n Index := 2; // hot\r\n if (dsClicked in DrawState) and (dsHighlight in DrawState) then\r\n Index := 4; // down\r\n end;\r\n if not FCollapsed then\r\n Inc(Index);\r\n if Index >= FRollImages.Count then\r\n Index := Ord(not FCollapsed);\r\n FRollImages.GetBitmap(Index, Bitmap);\r\n end\r\n else\r\n begin\r\n Index := 0;\r\n if FHitTest = htRollButton then\r\n begin\r\n if dsHighlight in DrawState then\r\n Index := 1; // hot\r\n if (dsClicked in DrawState) and (dsHighlight in DrawState) then\r\n Index := 2; // down\r\n end;\r\n Bitmap.Assign(nil); // fixes GDI resource leak\r\n if FCollapsed then\r\n Bitmap.LoadFromResourceName(HInstance, 'JvXPCustomWinXPBarEXPAND' + IntToStr(Index))\r\n else\r\n Bitmap.LoadFromResourceName(HInstance, 'JvXPCustomWinXPBarCOLLAPSE' + IntToStr(Index));\r\n end;\r\n // Transparency fix not needed Here! -WPostma\r\n Bitmap.Transparent := True;\r\n if BiDiMode = bdRightToLeft then\r\n begin\r\n ACanvas.Draw(R.Left + 5, R.Top + (HeaderHeight - GetRollHeight) div 2, Bitmap);\r\n Inc(R.Left, Bitmap.Width + 7);\r\n end\r\n else\r\n begin\r\n ACanvas.Draw(R.Right - Bitmap.Width - 7, R.Top + (HeaderHeight - GetRollHeight) div 2, Bitmap);\r\n Dec(R.Right, Bitmap.Width + 7);\r\n end;\r\n finally\r\n Bitmap.Free;\r\n end;\r\n end;\r\n ACanvas.Pen.Color := FColors.SeparatorColor;\r\n JvXPDrawLine(ACanvas, 1, R.Top + FHeaderHeight, Width - 1, R.Top + FHeaderHeight);\r\n end;\r\n\r\n { draw seperator line }\r\n ACanvas.Pen.Color := FColors.SeparatorColor;\r\n JvXPDrawLine(ACanvas, 1, R.Top + FHeaderHeight, Width - 1, R.Top + FHeaderHeight);\r\n\r\n { draw icon }\r\n\r\n if not FIcon.Empty then\r\n begin\r\n if BiDiMode = bdRightToLeft then\r\n begin\r\n ACanvas.Draw(R.Right-FICon.Width-2, 0, FIcon);\r\n Dec(R.Right, FIcon.Width+6);\r\n end\r\n else\r\n begin\r\n ACanvas.Draw(2, 1, FIcon);\r\n Inc(R.Left, FIcon.Width+6);\r\n end;\r\n\r\n end;\r\n SetBkMode(ACanvas.Handle, TRANSPARENT);\r\n ACanvas.Font.Assign(FHeaderFont);\r\n if FHotTrack and (dsHighlight in DrawState) and (FHitTest <> htNone) and (FHotTrackColor <> clNone) then\r\n ACanvas.Font.Color := FHotTrackColor;\r\n R.Bottom := R.Top + FHeaderHeight;\r\n if BiDiMode = bdRightToLeft then\r\n DrawText(ACanvas, Caption, -1, R,\r\n DT_SINGLELINE or DT_RTLREADING or DT_RIGHT or DT_VCENTER or DT_END_ELLIPSIS or DT_NOPREFIX)\r\n else\r\n DrawText(ACanvas, Caption, -1, R,\r\n DT_SINGLELINE or DT_LEFT or DT_VCENTER or DT_END_ELLIPSIS or DT_NOPREFIX);\r\n end;\r\n\r\nvar\r\n ARect: TRect;\r\n I: Integer;\r\nbegin\r\n { get client rect }\r\n ARect := GetClientRect;\r\n DoDrawBackground(Canvas, ARect);\r\n { draw header }\r\n DoDrawHeader(Canvas, ARect);\r\n { draw visible items }\r\n Canvas.Brush.Color := FColors.BodyColor;\r\n if not FCollapsed or FRolling then\r\n for I := 0 to FVisibleItems.Count - 1 do\r\n if FVisibleItems[I].Checked then\r\n DoDrawItem(I, [dsClicked])\r\n else\r\n DoDrawItem(I, []);\r\nend;\r\n\r\nprocedure TJvXPCustomWinXPBar.WMAfterXPBarCollapse(var Msg: TMessage);\r\nbegin\r\n if Assigned(FAfterCollapsedChange) then\r\n FAfterCollapsedChange(Self, Msg.WParam <> 0);\r\n if Grouped and not FCollapsed then\r\n GroupMessage;\r\nend;\r\n\r\nprocedure TJvXPCustomWinXPBar.DoColorsChange(Sender: TObject);\r\nbegin\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvXPCustomWinXPBar.SetColors(const Value: TJvXPBarColors);\r\nbegin\r\n FColors.Assign(Value);\r\nend;\r\n\r\nprocedure TJvXPCustomWinXPBar.SetRollImages(const Value: TCustomImageList);\r\nbegin\r\n if ReplaceImageListReference(Self, Value, FRollImages, FImageChangeLink) then\r\n InternalRedraw;\r\nend;\r\n\r\nprocedure TJvXPCustomWinXPBar.GroupMessage;\r\nvar\r\n Msg: TMessage;\r\nbegin\r\n if Parent <> nil then\r\n begin\r\n Msg.Msg := WM_XPBARAFTEREXPAND;\r\n Msg.WParam := WPARAM(Self);\r\n Msg.Result := 0;\r\n Parent.Broadcast(Msg);\r\n end;\r\nend;\r\n\r\nprocedure TJvXPCustomWinXPBar.WMAfterXPBarExpand(var Msg: TMessage);\r\nbegin\r\n if Grouped and (TObject(Msg.WParam) <> Self) then\r\n Collapsed := True;\r\nend;\r\n\r\nprocedure TJvXPCustomWinXPBar.SetGrouped(const Value: Boolean);\r\nbegin\r\n if FGrouped <> Value then\r\n begin\r\n FGrouped := Value;\r\n if FGrouped and not Collapsed then\r\n Collapsed := True;\r\n end;\r\nend;\r\n\r\nprocedure TJvXPCustomWinXPBar.AdjustClientRect(var Rect: TRect);\r\nbegin\r\n inherited AdjustClientRect(Rect);\r\n if ControlCount > 0 then\r\n begin\r\n Inc(Rect.Top, FHeaderHeight + 4);\r\n InflateRect(Rect, -4, -4);\r\n end;\r\nend;\r\n\r\nprocedure TJvXPCustomWinXPBar.SetHeaderHeight(const Value: Integer);\r\nbegin\r\n if FHeaderHeight <> Value then\r\n begin\r\n FHeaderHeight := Value;\r\n ResizeToMaxHeight;\r\n// InternalRedraw;\r\n end;\r\nend;\r\n\r\nfunction TJvXPCustomWinXPBar.HintShow(var HintInfo: {$IFDEF RTL200_UP}Controls.{$ENDIF RTL200_UP}THintInfo): Boolean;\r\nbegin\r\n // draw the item hint (if available)\r\n if (FHoverIndex > -1) and (FVisibleItems[FHoverIndex] <> nil) then\r\n begin\r\n HintInfo.CursorRect := GetItemRect(FHoverIndex);\r\n with VisibleItems[FHoverIndex] do\r\n begin\r\n if Action is TCustomAction then\r\n HintInfo.HintStr := TCustomAction(Action).Hint\r\n else\r\n HintInfo.HintStr := VisibleItems[FHoverIndex].Hint;\r\n end;\r\n end\r\n else\r\n if (VisibleItems.Count > 0) and not Collapsed then\r\n HintInfo.CursorRect := GetHitTestRect(htHeader);\r\n\r\n if HintInfo.HintStr = '' then\r\n HintInfo.HintStr := Hint;\r\n Result := False; // use default hint window\r\nend;\r\n\r\nfunction TJvXPBarItemActionLink.DoShowHint(var HintStr: string): Boolean;\r\nbegin\r\n Result := True;\r\n if Action is TCustomAction then\r\n begin\r\n Result := TCustomAction(Action).DoHint(HintStr);\r\n if Result and Application.HintShortCuts and (TCustomAction(Action).ShortCut <> scNone) then\r\n if HintStr <> '' then\r\n HintStr := Format(RsHintShortcutFmt, [HintStr, ShortCutToText(TCustomAction(Action).ShortCut)]);\r\n end;\r\nend;\r\n\r\nprocedure TJvXPCustomWinXPBar.InitiateAction;\r\nvar\r\n I: Integer;\r\nbegin\r\n inherited InitiateAction;\r\n // go through each item and update\r\n // Note: Do not call ActionChange as it would trigger Mantis 3244 and it is\r\n // basically wrong as the point of InitiateAction is to call Update (see in\r\n // the inherited code).\r\n for I := 0 to Items.Count - 1 do\r\n if Assigned(Items[I].ActionLink) then\r\n Items[I].ActionLink.Update;\r\nend;\r\n\r\n\r\nprocedure TJvXPCustomWinXPBar.CMDialogChar(var Msg: TCMDialogChar);\r\nvar\r\n I: Integer;\r\nbegin\r\n if CanFocus then\r\n begin\r\n if IsAccel(Msg.CharCode, Caption) then\r\n begin\r\n Collapsed := not Collapsed;\r\n Msg.Result := 1;\r\n end\r\n else\r\n if not Collapsed then\r\n for I := 0 to VisibleItems.Count - 1 do\r\n if IsAccel(Msg.CharCode, VisibleItems[I].Caption) and VisibleItems[I].Enabled then\r\n begin\r\n Msg.Result := 1;\r\n FHitTest := htNone;\r\n FHoverIndex := I;\r\n Click;\r\n Exit;\r\n end;\r\n end;\r\n inherited;\r\nend;\r\n\r\nclass function TJvXPCustomWinXPBar.GetBarItemsClass: TJvXPBarItemsClass;\r\nbegin\r\n Result := TJvXPBarItems;\r\nend;\r\n\r\nprocedure TJvXPCustomWinXPBar.DblClick;\r\nvar\r\n LItem: TJvXPBarItem;\r\nbegin\r\n if (FHoverIndex <> -1) and (FVisibleItems[FHoverIndex] <> nil) and\r\n FVisibleItems[FHoverIndex].Enabled then\r\n begin\r\n LItem := FVisibleItems[FHoverIndex];\r\n if Assigned(LItem.FOnDblClick) then\r\n LItem.FOnDblClick(LItem);\r\n end;\r\n inherited DblClick;\r\nend;\r\n\r\nprocedure RoundedFrame(Canvas: TCanvas; ARect: TRect; AColor: TColor; R: Integer);\r\nbegin\r\n // Draw Frame with round edges\r\n Canvas.Pen.Color := AColor;\r\n Dec(ARect.Right);\r\n Dec(ARect.Bottom);\r\n Canvas.Polygon(\r\n [Point(ARect.Left + R, ARect.Top),\r\n Point(ARect.Right - R, ARect.Top),\r\n Point(ARect.Right, ARect.Top + R),\r\n Point(ARect.Right, ARect.Bottom - R),\r\n Point(ARect.Right - R, ARect.Bottom),\r\n Point(ARect.Left + R, ARect.Bottom),\r\n Point(ARect.Left, ARect.Bottom - R),\r\n Point(ARect.Left, ARect.Top + R),\r\n Point(ARect.Left + R, ARect.Top)]);\r\n Inc(ARect.Right);\r\n Inc(ARect.Bottom);\r\nend;\r\n\r\nprocedure TJvXPCustomWinXPBar.SetHeaderRounded(const Value: Boolean);\r\nbegin\r\n if FHeaderRounded <> Value then\r\n begin\r\n FHeaderRounded := Value;\r\n InternalRedraw;\r\n end;\r\nend;\r\n\r\nprocedure TJvXPCustomWinXPBar.SetTopSpace(const Value: Integer);\r\nbegin\r\n if Value <> FTopSpace then\r\n begin\r\n FTopSpace := Value;\r\n if FTopSpace < 0 then\r\n FTopSpace := 0;\r\n ResizeToMaxHeight;\r\n InternalRedraw;\r\n end;\r\nend;\r\n\r\nprocedure TJvXPCustomWinXPBar.SetOwnerDraw(const Value: Boolean);\r\nbegin\r\n if FOwnerDraw <> Value then\r\n begin\r\n FOwnerDraw := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvXPButtons.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvXPButtons.PAS, released on 2004-01-01.\r\n\r\nThe Initial Developer of the Original Code is Marc Hoffman.\r\nPortions created by Marc Hoffman are Copyright (C) 2002 APRIORI business solutions AG.\r\nPortions created by APRIORI business solutions AG are Copyright (C) 2002 APRIORI business solutions AG\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvXPButtons.pas 13415 2012-09-10 09:51:54Z obones $\r\n\r\nunit JvXPButtons;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n JvJVCLUtils,\r\n Classes, TypInfo,\r\n Windows, Messages, Graphics, Controls, Forms, ActnList, ImgList, Menus,\r\n {$IFDEF HAS_UNIT_SYSTEM_UITYPES}\r\n System.UITypes,\r\n {$ENDIF HAS_UNIT_SYSTEM_UITYPES}\r\n JvXPCore, JvXPCoreUtils;\r\n\r\ntype\r\n TJvXPCustomButtonActionLink = class(TWinControlActionLink)\r\n protected\r\n function IsImageIndexLinked: Boolean; override;\r\n procedure AssignClient(AClient: TObject); override;\r\n procedure SetImageIndex(Value: Integer); override;\r\n public\r\n destructor Destroy; override;\r\n end;\r\n\r\n TJvXPLayout = (blGlyphLeft, blGlyphRight, blGlyphTop, blGlyphBottom);\r\n\r\n TJvXPCustomButton = class(TJvXPCustomStyleControl)\r\n private\r\n FAutoGray: Boolean;\r\n FBgGradient: TBitmap;\r\n FCancel: Boolean;\r\n FCkGradient: TBitmap;\r\n FDefault: Boolean;\r\n FFcGradient: TBitmap;\r\n FGlyph: TJvPicture;\r\n FHlGradient: TBitmap;\r\n FImageChangeLink: TChangeLink;\r\n FImageIndex: Integer;\r\n FLayout: TJvXPLayout;\r\n FShowAccelChar: Boolean;\r\n FShowFocusRect: Boolean;\r\n FSmoothEdges: Boolean;\r\n FSpacing: Byte;\r\n FWordWrap: Boolean;\r\n FDown: Boolean;\r\n procedure CMDialogKey(var Msg: TCMDialogKey); message CM_DIALOGKEY;\r\n procedure ImageListChange(Sender: TObject);\r\n procedure GlyphChange(Sender: TObject);\r\n procedure SetDown(const Value: Boolean);\r\n protected\r\n function GetActionLinkClass: TControlActionLinkClass; override;\r\n function IsSpecialDrawState(IgnoreDefault: Boolean = False): Boolean;\r\n procedure ActionChange(Sender: TObject; CheckDefaults: Boolean); override;\r\n procedure KeyDown(var Key: Word; Shift: TShiftState); override;\r\n procedure KeyUp(var Key: Word; Shift: TShiftState); override;\r\n procedure SetAutoGray(Value: Boolean); virtual;\r\n procedure SetDefault(Value: Boolean); virtual;\r\n procedure SetGlyph(Value: TJvPicture); virtual;\r\n procedure SetLayout(Value: TJvXPLayout); virtual;\r\n procedure SetShowAccelChar(Value: Boolean); virtual;\r\n procedure SetShowFocusRect(Value: Boolean); virtual;\r\n procedure SetSmoothEdges(Value: Boolean); virtual;\r\n procedure SetSpacing(Value: Byte); virtual;\r\n procedure SetWordWrap(Value: Boolean); virtual;\r\n procedure Paint; override;\r\n procedure HookResized; override;\r\n // advanced properties.\r\n property AutoGray: Boolean read FAutoGray write SetAutoGray default True;\r\n property Cancel: Boolean read FCancel write FCancel default False;\r\n property Default: Boolean read FDefault write SetDefault default False;\r\n property Down: Boolean read FDown write SetDown default False;\r\n property Glyph: TJvPicture read FGlyph write SetGlyph;\r\n property Layout: TJvXPLayout read FLayout write SetLayout default blGlyphLeft;\r\n property ShowAccelChar: Boolean read FShowAccelChar write SetShowAccelChar default True;\r\n property ShowFocusRect: Boolean read FShowFocusRect write SetShowFocusRect default False;\r\n property SmoothEdges: Boolean read FSmoothEdges write SetSmoothEdges default True;\r\n property Spacing: Byte read FSpacing write SetSpacing default 3;\r\n property WordWrap: Boolean read FWordWrap write SetWordWrap default True;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n\r\n procedure Click; override;\r\n end;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvXPButton = class(TJvXPCustomButton)\r\n published\r\n // common properties.\r\n property Action;\r\n property Caption;\r\n property Enabled;\r\n property TabOrder;\r\n property TabStop default True;\r\n property Height default 21;\r\n property Width default 73;\r\n\r\n // advanced properties.\r\n property AutoGray;\r\n property Cancel;\r\n property Default;\r\n property Down;\r\n property Glyph;\r\n property Layout;\r\n property ModalResult;\r\n property ShowAccelChar;\r\n property ShowFocusRect;\r\n property SmoothEdges;\r\n property Spacing;\r\n property WordWrap;\r\n\r\n //property BevelInner;\r\n //property BevelOuter;\r\n //property BevelWidth;\r\n //property BiDiMode;\r\n //property Ctl3D;\r\n //property DockSite;\r\n //property ParentBiDiMode;\r\n //property ParentCtl3D;\r\n //property TabOrder;\r\n //property TabStop;\r\n //property UseDockManager default True;\r\n property Align;\r\n property Anchors;\r\n //property AutoSize;\r\n property Constraints;\r\n property DragCursor;\r\n property DragKind;\r\n property OnCanResize;\r\n property DragMode;\r\n //property Enabled;\r\n property Font;\r\n property ParentFont;\r\n property ParentShowHint;\r\n property PopupMenu;\r\n property ShowHint;\r\n property Style;\r\n property StyleManager;\r\n property Visible;\r\n //property OnDockDrop;\r\n //property OnDockOver;\r\n //property OnEndDock;\r\n //property OnGetSiteInfo;\r\n //property OnStartDock;\r\n //property OnUnDock;\r\n property OnClick;\r\n property OnConstrainedResize;\r\n property OnContextPopup;\r\n property OnDragDrop;\r\n property OnDragOver;\r\n property OnEndDrag;\r\n property OnEnter;\r\n property OnExit;\r\n property OnKeyDown;\r\n property OnKeyPress;\r\n property OnKeyUp;\r\n property OnMouseDown;\r\n property OnMouseEnter;\r\n property OnMouseLeave;\r\n property OnMouseMove;\r\n property OnMouseUp;\r\n property OnStartDrag;\r\n end;\r\n\r\n TJvXPToolType =\r\n (ttArrowLeft, ttArrowRight, ttClose, ttMaximize, ttMinimize, ttPopup, ttRestore, ttImage);\r\n\r\n TJvXPCustomToolButton = class(TJvXPCustomStyleControl)\r\n private\r\n FToolType: TJvXPToolType;\r\n FDropDownMenu: TPopupMenu;\r\n FChangeLink: TChangeLink;\r\n FImages: TCustomImageList;\r\n FImageIndex: TImageIndex;\r\n procedure SetImages(const Value: TCustomImageList);\r\n procedure SetImageIndex(const Value: TImageIndex);\r\n procedure SetDropDownMenu(const Value: TPopupMenu);\r\n procedure DoImagesChange(Sender: TObject);\r\n protected\r\n procedure Notification(AComponent: TComponent; Operation: TOperation); override;\r\n procedure MouseDown(Button: TMouseButton; Shift: TShiftState;\r\n X: Integer; Y: Integer); override;\r\n procedure SetToolType(Value: TJvXPToolType); virtual;\r\n procedure Paint; override;\r\n procedure HookResized; override;\r\n\r\n property ToolType: TJvXPToolType read FToolType write SetToolType default ttClose;\r\n property DropDownMenu: TPopupMenu read FDropDownMenu write SetDropDownMenu;\r\n property Images: TCustomImageList read FImages write SetImages;\r\n property ImageIndex: TImageIndex read FImageIndex write SetImageIndex;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n end;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvXPToolButton = class(TJvXPCustomToolButton)\r\n published\r\n property Enabled;\r\n property Color default clBlack;\r\n property Height default 15;\r\n property ToolType;\r\n property Width default 15;\r\n\r\n //property BevelInner;\r\n //property BevelOuter;\r\n //property BevelWidth;\r\n //property BiDiMode;\r\n //property Ctl3D;\r\n //property DockSite;\r\n //property ParentBiDiMode;\r\n //property ParentCtl3D;\r\n //property TabOrder;\r\n //property TabStop;\r\n //property UseDockManager default True;\r\n property Align;\r\n property Anchors;\r\n //property AutoSize;\r\n property Constraints;\r\n property DragCursor;\r\n property DragKind;\r\n property OnCanResize;\r\n property DragMode;\r\n property DropDownMenu;\r\n property Images;\r\n property ImageIndex;\r\n\r\n //property Enabled;\r\n property Font;\r\n property ParentFont;\r\n property ParentShowHint;\r\n property PopupMenu;\r\n property ShowHint;\r\n property Style;\r\n property StyleManager;\r\n property Visible;\r\n //property OnDockDrop;\r\n //property OnDockOver;\r\n //property OnEndDock;\r\n //property OnGetSiteInfo;\r\n //property OnStartDock;\r\n //property OnUnDock;\r\n property OnClick;\r\n property OnConstrainedResize;\r\n property OnContextPopup;\r\n property OnDragDrop;\r\n property OnDragOver;\r\n property OnEndDrag;\r\n property OnEnter;\r\n property OnExit;\r\n property OnKeyDown;\r\n property OnKeyPress;\r\n property OnKeyUp;\r\n property OnMouseDown;\r\n property OnMouseEnter;\r\n property OnMouseLeave;\r\n property OnMouseMove;\r\n property OnMouseUp;\r\n property OnStartDrag;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvXPButtons.pas $';\r\n Revision: '$Revision: 13415 $';\r\n Date: '$Date: 2012-09-10 11:51:54 +0200 (lun. 10 sept. 2012) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n Types;\r\n\r\n//=== { TJvXPCustomButtonActionLink } ========================================\r\n\r\ndestructor TJvXPCustomButtonActionLink.Destroy;\r\nbegin\r\n TJvXPCustomButton(FClient).Invalidate;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvXPCustomButtonActionLink.AssignClient(AClient: TObject);\r\nbegin\r\n inherited AssignClient(AClient);\r\n FClient := AClient as TJvXPCustomButton;\r\nend;\r\n\r\nfunction TJvXPCustomButtonActionLink.IsImageIndexLinked: Boolean;\r\nbegin\r\n Result := True;\r\nend;\r\n\r\nprocedure TJvXPCustomButtonActionLink.SetImageIndex(Value: Integer);\r\nbegin\r\n inherited SetImageIndex(Value);\r\n (FClient as TJvXPCustomButton).FImageIndex := Value;\r\n (FClient as TJvXPCustomButton).Invalidate;\r\nend;\r\n\r\n//=== { TJvXPCustomButton } ==================================================\r\n\r\nconstructor TJvXPCustomButton.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n\r\n // set default properties.\r\n ControlStyle := ControlStyle - [csDoubleClicks];\r\n Height := 21;\r\n Width := 73;\r\n TabStop := True;\r\n\r\n // set custom properties.\r\n FAutoGray := True;\r\n FCancel := False;\r\n FDefault := False;\r\n FImageIndex := -1;\r\n FImageChangeLink := TChangeLink.Create;\r\n FImageChangeLink.OnChange := ImageListChange;\r\n FGlyph := TJvPicture.Create;\r\n FGlyph.OnChange := GlyphChange;\r\n FLayout := blGlyphLeft;\r\n FShowAccelChar := True;\r\n FShowFocusRect := False;\r\n FSmoothEdges := True;\r\n FSpacing := 3;\r\n FWordWrap := True;\r\n\r\n // create ...\r\n FBgGradient := TBitmap.Create; // background gradient\r\n FCkGradient := TBitmap.Create; // clicked gradient\r\n FFcGradient := TBitmap.Create; // focused gradient\r\n FHlGradient := TBitmap.Create; // Highlight gradient\r\nend;\r\n\r\ndestructor TJvXPCustomButton.Destroy;\r\nbegin\r\n FBgGradient.Free;\r\n FCkGradient.Free;\r\n FFcGradient.Free;\r\n FHlGradient.Free;\r\n FGlyph.Free;\r\n FImageChangeLink.OnChange := nil;\r\n FImageChangeLink.Free;\r\n FImageChangeLink := nil;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvXPCustomButton.Click;\r\nbegin\r\n // Only there to make it public (Mantis 4015)\r\n inherited Click;\r\nend;\r\n\r\nfunction TJvXPCustomButton.GetActionLinkClass: TControlActionLinkClass;\r\nbegin\r\n Result := TJvXPCustomButtonActionLink;\r\nend;\r\n\r\nprocedure TJvXPCustomButton.CMDialogKey(var Msg: TCMDialogKey);\r\nbegin\r\n inherited;\r\n with Msg do\r\n if (((CharCode = VK_RETURN) and (Focused or (FDefault and not IsSibling))) or\r\n ((CharCode = VK_ESCAPE) and FCancel) and (KeyDataToShiftState(KeyData) = [])) and\r\n CanFocus then\r\n begin\r\n Click;\r\n Result := 1;\r\n end\r\n else\r\n inherited;\r\nend;\r\n\r\nprocedure TJvXPCustomButton.SetAutoGray(Value: Boolean);\r\nbegin\r\n if Value <> FAutoGray then\r\n begin\r\n FAutoGray := Value;\r\n LockedInvalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvXPCustomButton.SetDefault(Value: Boolean);\r\nbegin\r\n if Value <> FDefault then\r\n begin\r\n FDefault := Value;\r\n if GetParentForm(Self) <> nil then\r\n with GetParentForm(Self) do\r\n Perform(CM_FOCUSCHANGED, 0, LPARAM(ActiveControl));\r\n end;\r\nend;\r\n\r\nprocedure TJvXPCustomButton.SetDown(const Value: Boolean);\r\nbegin\r\n if Value <> FDown then\r\n begin\r\n FDown := Value;\r\n LockedInvalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvXPCustomButton.SetGlyph(Value: TJvPicture);\r\nbegin\r\n if Value <> FGlyph then\r\n begin\r\n FGlyph.Assign(Value);\r\n LockedInvalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvXPCustomButton.SetLayout(Value: TJvXPLayout);\r\nbegin\r\n if Value <> FLayout then\r\n begin\r\n FLayout := Value;\r\n LockedInvalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvXPCustomButton.SetShowAccelChar(Value: Boolean);\r\nbegin\r\n if Value <> FShowAccelChar then\r\n begin\r\n FShowAccelChar := Value;\r\n LockedInvalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvXPCustomButton.SetShowFocusRect(Value: Boolean);\r\nbegin\r\n if Value <> FShowFocusRect then\r\n begin\r\n FShowFocusRect := Value;\r\n LockedInvalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvXPCustomButton.SetSmoothEdges(Value: Boolean);\r\nbegin\r\n if Value <> FSmoothEdges then\r\n begin\r\n FSmoothEdges := Value;\r\n LockedInvalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvXPCustomButton.SetSpacing(Value: Byte);\r\nbegin\r\n if Value <> FSpacing then\r\n begin\r\n FSpacing := Value;\r\n LockedInvalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvXPCustomButton.SetWordWrap(Value: Boolean);\r\nbegin\r\n if Value <> FWordWrap then\r\n begin\r\n FWordWrap := Value;\r\n LockedInvalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvXPCustomButton.ImageListChange(Sender: TObject);\r\nbegin\r\n if Assigned(Action) and (Sender is TCustomImageList) and\r\n Assigned(TAction(Action).ActionList.Images) and\r\n ((TAction(Action).ImageIndex < (TAction(Action).ActionList.Images.Count))) then\r\n FImageIndex := TAction(Action).ImageIndex\r\n else\r\n FImageIndex := -1;\r\n LockedInvalidate;\r\nend;\r\n\r\nprocedure TJvXPCustomButton.GlyphChange(Sender: TObject);\r\nbegin\r\n LockedInvalidate;\r\nend;\r\n\r\nprocedure TJvXPCustomButton.KeyDown(var Key: Word; Shift: TShiftState);\r\nbegin\r\n if (Shift = []) and (Key = VK_SPACE) then\r\n begin\r\n DrawState := DrawState + [dsHighlight];\r\n HookMouseDown;\r\n end;\r\n inherited KeyDown(Key, Shift);\r\nend;\r\n\r\nprocedure TJvXPCustomButton.KeyUp(var Key: Word; Shift: TShiftState);\r\nvar\r\n Pos: TPoint;\r\nbegin\r\n //\r\n // it's not possible to call the 'HookMouseUp' or 'HookMouseLeave' methods,\r\n // because we don't want to call their event handlers.\r\n //\r\n if dsClicked in DrawState then\r\n begin\r\n GetCursorPos(Pos);\r\n Pos := ScreenToClient(Pos);\r\n if not PtInRect(Bounds(0, 0, Width, Height), Pos) then\r\n DrawState := DrawState - [dsHighlight];\r\n DrawState := DrawState - [dsClicked];\r\n LockedInvalidate;\r\n Click;\r\n end;\r\n inherited KeyUp(Key, Shift);\r\nend;\r\n\r\nfunction TJvXPCustomButton.IsSpecialDrawState(IgnoreDefault: Boolean = False): Boolean;\r\nbegin\r\n if (dsClicked in DrawState) or Down then\r\n Result := not ((dsHighlight in DrawState) or Down)\r\n else\r\n Result := (dsHighlight in DrawState) or (dsFocused in DrawState);\r\n if not IgnoreDefault then\r\n Result := Result or (FDefault and CanFocus) and not IsSibling;\r\nend;\r\n\r\nprocedure TJvXPCustomButton.ActionChange(Sender: TObject; CheckDefaults: Boolean);\r\nbegin\r\n inherited ActionChange(Sender, CheckDefaults);\r\n if Sender is TCustomAction then\r\n with TCustomAction(Sender) do\r\n begin\r\n if Assigned(TCustomAction(Sender).ActionList.Images) and\r\n (FImageChangeLink.Sender <> TCustomAction(Sender).ActionList.Images) then\r\n TCustomAction(Sender).ActionList.Images.RegisterChanges(FImageChangeLink);\r\n if (ActionList <> nil) and (ActionList.Images <> nil) and\r\n (ImageIndex >= 0) and (ImageIndex < ActionList.Images.Count) then\r\n FImageIndex := ImageIndex;\r\n LockedInvalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvXPCustomButton.HookResized;\r\nconst\r\n ColSteps = 64;\r\n Dithering = True;\r\nvar\r\n Offset: Integer;\r\nbegin\r\n inherited HookResized;\r\n\r\n // calculate offset.\r\n Offset := 4 * (Integer(IsSpecialDrawState(True)));\r\n\r\n //\r\n // create gradient rectangles for...\r\n //\r\n\r\n // background.\r\n JvXPCreateGradientRect(Width - (2 + Offset), Height - (2 + Offset),\r\n dxColor_Btn_Enb_BgFrom_WXP, dxColor_Btn_Enb_BgTo_WXP, ColSteps, gsTop, Dithering,\r\n FBgGradient);\r\n\r\n // clicked.\r\n JvXPCreateGradientRect(Width - 2, Height - 2, dxColor_Btn_Enb_CkFrom_WXP,\r\n dxColor_Btn_Enb_CkTo_WXP, ColSteps, gsTop, Dithering, FCkGradient);\r\n\r\n // focused.\r\n JvXPCreateGradientRect(Width - 2, Height - 2, dxColor_Btn_Enb_FcFrom_WXP,\r\n dxColor_Btn_Enb_FcTo_WXP, ColSteps, gsTop, Dithering, FFcGradient);\r\n\r\n // highlight.\r\n JvXPCreateGradientRect(Width - 2, Height - 2, dxColor_Btn_Enb_HlFrom_WXP,\r\n dxColor_Btn_Enb_HlTo_WXP, ColSteps, gsTop, Dithering, FHlGradient);\r\n\r\n LockedInvalidate;\r\nend;\r\n\r\nprocedure TJvXPCustomButton.Paint;\r\nvar\r\n Rect: TRect;\r\n Offset, Flags: Integer;\r\n DrawPressed: Boolean;\r\n Image: TPicture;\r\n Bitmap: TBitmap;\r\nbegin\r\n with Canvas do\r\n begin\r\n // clear background.\r\n Rect := GetClientRect;\r\n Brush.Color := Self.Color;\r\n FillRect(Rect);\r\n // draw gradient borders.\r\n if IsSpecialDrawState then\r\n begin\r\n Bitmap := TBitmap.Create;\r\n try\r\n if (dsHighlight in DrawState) then\r\n Bitmap.Assign(FHlGradient)\r\n else\r\n Bitmap.Assign(FFcGradient);\r\n BitBlt(Handle, 1, 1, Width, Height, Bitmap.Canvas.Handle, 0, 0, SRCCOPY);\r\n finally\r\n Bitmap.Free;\r\n end;\r\n end;\r\n\r\n // draw background gradient...\r\n if not (Down or ((dsHighlight in DrawState) and (dsClicked in DrawState))) then\r\n begin\r\n Offset := 2 * Integer(IsSpecialDrawState);\r\n BitBlt(Handle, 1 + Offset, 1 + Offset, Width - 3 * Offset, Height - 3 * Offset,\r\n FBgGradient.Canvas.Handle, 0, 0, SRCCOPY);\r\n end\r\n // ...or click gradient.\r\n else\r\n BitBlt(Handle, 1, 1, Width, Height, FCkGradient.Canvas.Handle, 0, 0, SRCCOPY);\r\n\r\n // draw border lines.\r\n if Enabled then\r\n Pen.Color := dxColor_Btn_Enb_Border_WXP\r\n else\r\n Pen.Color := dxColor_Btn_Dis_Border_WXP;\r\n Brush.Style := bsClear;\r\n RoundRect(0, 0, Width, Height, 5, 5);\r\n // draw border edges.\r\n if FSmoothEdges then\r\n begin\r\n if Enabled then\r\n Pen.Color := dxColor_Btn_Enb_Edges_WXP\r\n else\r\n Pen.Color := dxColor_Btn_Dis_Edges_WXP;\r\n JvXPDrawLine(Canvas, 0, 1, 2, 0);\r\n JvXPDrawLine(Canvas, Width - 2, 0, Width, 2);\r\n JvXPDrawLine(Canvas, 0, Height - 2, 2, Height);\r\n JvXPDrawLine(Canvas, Width - 3, Height, Width, Height - 3);\r\n end;\r\n\r\n // set drawing flags.\r\n Flags := {DT_VCENTER or } DT_END_ELLIPSIS;\r\n if FWordWrap then\r\n Flags := Flags or DT_WORDBREAK;\r\n\r\n // draw image & caption.\r\n Image := TPicture.Create;\r\n try\r\n // get image from action or glyph property.\r\n if Assigned(Action) and Assigned(TAction(Action).ActionList.Images) and\r\n (FImageIndex > -1) and (FImageIndex < TAction(Action).ActionList.Images.Count) then\r\n begin\r\n TAction(Action).ActionList.Images.GetBitmap(FImageIndex, Image.Bitmap)\r\n end\r\n else\r\n begin\r\n // Mantis 4044: We need to access the width and height of the graphic but\r\n // when it is a TIcon, they are only valid once the handle is created.\r\n // And that only happens after the icon has been painted, hence at the\r\n // first run here, we do not get the real size but the value from system\r\n // metrics (see TIcon.GetWidth for instance). Ideally, we would like\r\n // to call TIcon.HandleNeeded but it is private. So we access the Handle\r\n // property and despite us not storing its value in anything it does\r\n // call the getter anyway.\r\n if FGlyph.Graphic is TIcon then\r\n TIcon(FGlyph.Graphic).Handle;\r\n Image.Assign(FGlyph);\r\n end;\r\n\r\n // autogray image (if allowed).\r\n if FAutoGray and not Enabled then\r\n JvXPConvertToGray2(Image.Bitmap);\r\n\r\n // assign canvas font (change HotTrack-Color, if necessary).\r\n Font.Assign(Self.Font);\r\n\r\n // calculate textrect.\r\n if Assigned(Image.Graphic) and not Image.Graphic.Empty then\r\n if Length(Caption) > 0 then\r\n begin\r\n case FLayout of\r\n blGlyphLeft:\r\n Inc(Rect.Left, Image.Width + FSpacing);\r\n blGlyphRight:\r\n begin\r\n Dec(Rect.Left, Image.Width + FSpacing);\r\n Dec(Rect.Right, (Image.Width + FSpacing) * 2);\r\n Flags := Flags or DT_RIGHT;\r\n end;\r\n blGlyphTop:\r\n Inc(Rect.Top, Image.Height + FSpacing);\r\n blGlyphBottom:\r\n Dec(Rect.Top, Image.Height + FSpacing);\r\n end;\r\n end;\r\n\r\n if Length(Caption) > 0 then\r\n begin\r\n JvXPRenderText(Self, Canvas, Caption, Font, Enabled, FShowAccelChar, Rect, Flags or DT_CALCRECT);\r\n OffsetRect(Rect, (Width - Rect.Right) div 2, (Height - Rect.Bottom) div 2);\r\n end;\r\n\r\n // should we draw the pressed state?\r\n DrawPressed := Down or ((dsHighlight in DrawState) and (dsClicked in DrawState));\r\n if DrawPressed then\r\n OffsetRect(Rect, 1, 1);\r\n\r\n // draw image - if available.\r\n if Assigned(Image.Graphic) and not Image.Graphic.Empty then\r\n begin\r\n Image.Graphic.Transparent := True;\r\n if Length(Caption) > 0 then\r\n case FLayout of\r\n blGlyphLeft:\r\n Draw(Rect.Left - (Image.Width + FSpacing), (Height - Image.Height) div 2 +\r\n Integer(DrawPressed), Image.Graphic);\r\n blGlyphRight:\r\n Draw(Rect.Right + FSpacing, (Height - Image.Height) div 2 +\r\n Integer(DrawPressed), Image.Graphic);\r\n blGlyphTop:\r\n Draw((Width - Image.Width) div 2 + Integer(DrawPressed),\r\n Rect.Top - (Image.Height + FSpacing), Image.Graphic);\r\n blGlyphBottom:\r\n Draw((Width - Image.Width) div 2 + Integer(DrawPressed),\r\n Rect.Bottom + FSpacing, Image.Graphic);\r\n end\r\n else\r\n // draw the glyph into the center\r\n Draw((Width - Image.Width) div 2 + Integer(DrawPressed),\r\n (Height - Image.Height) div 2 + Integer(DrawPressed), Image.Graphic);\r\n end;\r\n\r\n // draw focusrect (if enabled).\r\n if (dsFocused in DrawState) and (FShowFocusRect) then\r\n begin\r\n Brush.Style := bsSolid;\r\n DrawFocusRect(Bounds(3, 3, Width - 6, Height - 6));\r\n end;\r\n\r\n // draw caption.\r\n SetBkMode(Handle, Transparent);\r\n JvXPRenderText(Self, Canvas, Caption, Font, Enabled, FShowAccelChar, Rect, Flags);\r\n finally\r\n Image.Free;\r\n end;\r\n end;\r\nend;\r\n\r\n// TJvXPCustomToolButton =====================================================\r\n\r\nconstructor TJvXPCustomToolButton.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n ControlStyle := ControlStyle - [csDoubleClicks];\r\n Color := clBlack;\r\n FToolType := ttClose;\r\n FChangeLink := TChangeLink.Create;\r\n FChangeLink.OnChange := DoImagesChange;\r\n HookResized;\r\nend;\r\n\r\ndestructor TJvXPCustomToolButton.Destroy;\r\nbegin\r\n FChangeLink.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvXPCustomToolButton.HookResized;\r\nbegin\r\n if ToolType <> ttImage then\r\n begin\r\n Height := 15;\r\n Width := 15;\r\n end;\r\nend;\r\n\r\nprocedure TJvXPCustomToolButton.SetToolType(Value: TJvXPToolType);\r\nbegin\r\n if Value <> FToolType then\r\n begin\r\n FToolType := Value;\r\n LockedInvalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvXPCustomToolButton.Paint;\r\nvar\r\n Rect: TRect;\r\n Bitmap: TBitmap;\r\n Theme: TJvXPTheme;\r\n Shifted: Boolean;\r\nbegin\r\n with Canvas do\r\n begin\r\n Rect := GetClientRect;\r\n Brush.Color := TJvXPWinControl(Parent).Color;\r\n Brush.Style := bsSolid;\r\n FillRect(Rect);\r\n if csDesigning in ComponentState then\r\n DrawFocusRect(Rect);\r\n Brush.Style := bsClear;\r\n Theme := Style.GetTheme;\r\n if (Theme = WindowsXP) and (dsClicked in DrawState) and\r\n not (dsHighlight in DrawState) then\r\n JvXPFrame3d(Self.Canvas, Rect, clWhite, clBlack);\r\n if dsHighlight in DrawState then\r\n begin\r\n if Theme = WindowsXP then\r\n JvXPFrame3d(Self.Canvas, Rect, clWhite, clBlack, dsClicked in DrawState)\r\n else\r\n begin\r\n Pen.Color := dxColor_BorderLineOXP;\r\n Rectangle(Rect);\r\n InflateRect(Rect, -1, -1);\r\n if dsClicked in DrawState then\r\n Brush.Color := dxColor_BgCkOXP\r\n else\r\n Brush.Color := dxColor_BgOXP;\r\n FillRect(Rect);\r\n end;\r\n end;\r\n Shifted := (Theme = WindowsXP) and (dsClicked in DrawState);\r\n if ToolType = ttImage then\r\n begin\r\n if (Images = nil) or (ImageIndex < 0) or (ImageIndex >= Images.Count) then\r\n Exit;\r\n Images.Draw(Canvas,\r\n (Width - Images.Width) div 2 + Integer(Shifted),\r\n (Height - Images.Height) div 2 + Integer(Shifted),\r\n ImageIndex, dsTransparent, itImage, Enabled);\r\n end\r\n else\r\n begin\r\n Bitmap := TBitmap.Create;\r\n try\r\n Bitmap.Assign(nil); // fixes GDI resource leak\r\n Bitmap.LoadFromResourceName(HInstance,\r\n PChar('JvXPCustomToolButton' + Copy(GetEnumName(TypeInfo(TJvXPToolType),\r\n Ord(FToolType)), 3, MaxInt)));\r\n if (dsClicked in DrawState) and (dsHighlight in DrawState) then\r\n JvXPColorizeBitmap(Bitmap, clWhite)\r\n else\r\n if not Enabled then\r\n JvXPColorizeBitmap(Bitmap, clGray)\r\n else\r\n if Color <> clBlack then\r\n JvXPColorizeBitmap(Bitmap, Color);\r\n Bitmap.Transparent := True;\r\n Draw((Width - Bitmap.Width) div 2 + Integer(Shifted),\r\n (Height - Bitmap.Height) div 2 + Integer(Shifted), Bitmap);\r\n finally\r\n Bitmap.Free;\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvXPCustomToolButton.Notification(AComponent: TComponent;\r\n Operation: TOperation);\r\nbegin\r\n inherited Notification(AComponent, Operation);\r\n if Operation = opRemove then\r\n begin\r\n if AComponent = DropDownMenu then\r\n DropDownMenu := nil\r\n else\r\n if AComponent = Images then\r\n Images := nil;\r\n end;\r\nend;\r\n\r\nprocedure TJvXPCustomToolButton.MouseDown(Button: TMouseButton;\r\n Shift: TShiftState; X, Y: Integer);\r\nvar\r\n P: TPoint;\r\n Msg: TMsg;\r\nbegin\r\n inherited MouseDown(Button, Shift, X, Y);\r\n if Assigned(DropDownMenu) then\r\n begin\r\n P := ClientToScreen(Point(0, Height));\r\n DropDownMenu.Popup(P.X, P.Y);\r\n while PeekMessage(Msg, HWND_DESKTOP, WM_MOUSEFIRST, WM_MOUSELAST, PM_REMOVE) do\r\n {nothing};\r\n if GetCapture <> 0 then\r\n SendMessage(GetCapture, WM_CANCELMODE, 0, 0);\r\n end;\r\nend;\r\n\r\nprocedure TJvXPCustomToolButton.SetImages(const Value: TCustomImageList);\r\nbegin\r\n if ReplaceImageListReference(Self, Value, FImages, FChangeLink) then\r\n LockedInvalidate;\r\nend;\r\n\r\nprocedure TJvXPCustomToolButton.SetImageIndex(const Value: TImageIndex);\r\nbegin\r\n if FImageIndex <> Value then\r\n begin\r\n FImageIndex := Value;\r\n LockedInvalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvXPCustomToolButton.SetDropDownMenu(const Value: TPopupMenu);\r\nbegin\r\n if ReplaceComponentReference(Self, Value, TComponent(FDropDownMenu)) then\r\n LockedInvalidate;\r\nend;\r\n\r\nprocedure TJvXPCustomToolButton.DoImagesChange(Sender: TObject);\r\nbegin\r\n LockedInvalidate;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvXPCheckCtrls.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvXPCheckCtrls.PAS, released on 2004-01-01.\r\n\r\nThe Initial Developer of the Original Code is Marc Hoffman.\r\nPortions created by Marc Hoffman are Copyright (C) 2002 APRIORI business solutions AG.\r\nPortions created by APRIORI business solutions AG are Copyright (C) 2002 APRIORI business solutions AG\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\n ZENSan : State and AllowGrayed properties\r\n Anudedeus (Alexandre Pranke) : State and AllowGrayed properties\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvXPCheckCtrls.pas 13104 2011-09-07 06:50:43Z obones $\r\n\r\nunit JvXPCheckCtrls;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Classes, Windows, Graphics, Controls, StdCtrls,\r\n JvXPCore, JvXPCoreUtils;\r\n\r\ntype\r\n TJvXPCustomCheckControl = class(TJvXPCustomStyleControl)\r\n private\r\n FBgGradient: TBitmap;\r\n FBoundLines: TJvXPBoundLines;\r\n FChecked: Boolean;\r\n FCheckSize: Byte;\r\n FCkGradient: TBitmap;\r\n FHlGradient: TBitmap;\r\n FSpacing: Byte;\r\n FState: TCheckBoxState;\r\n FAllowGrayed: Boolean;\r\n procedure SetState(const Value: TCheckBoxState);\r\n procedure SetAllowGrayed(const Value: Boolean);\r\n protected\r\n procedure SetBoundLines(Value: TJvXPBoundLines); virtual;\r\n procedure SetChecked(Value: Boolean); virtual;\r\n procedure SetSpacing(Value: Byte); virtual;\r\n procedure DrawCheckSymbol(const R: TRect); virtual; abstract;\r\n procedure Click; override;\r\n procedure Paint; override;\r\n procedure HookResized; override;\r\n procedure KeyDown(var Key: Word; Shift: TShiftState); override;\r\n property BoundLines: TJvXPBoundLines read FBoundLines write SetBoundLines default [];\r\n property AllowGrayed: Boolean read FAllowGrayed write SetAllowGrayed default False;\r\n property Checked: Boolean read FChecked write SetChecked default False;\r\n property Spacing: Byte read FSpacing write SetSpacing default 3;\r\n property State: TCheckBoxState read FState write SetState default cbUnchecked;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n end;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvXPCheckbox = class(TJvXPCustomCheckControl)\r\n protected\r\n procedure DrawCheckSymbol(const R: TRect); override;\r\n published\r\n // common properties.\r\n property Caption;\r\n property AllowGrayed;\r\n property Enabled;\r\n property TabOrder;\r\n property TabStop default True;\r\n // advanced properties.\r\n property BoundLines;\r\n property Checked;\r\n property Spacing;\r\n property ParentColor;\r\n property State;\r\n property Color;\r\n //property BevelInner;\r\n //property BevelOuter;\r\n //property BevelWidth;\r\n //property BiDiMode;\r\n //property Ctl3D;\r\n //property DockSite;\r\n //property ParentBiDiMode;\r\n //property ParentCtl3D;\r\n //property TabOrder;\r\n //property TabStop;\r\n //property UseDockManager default True;\r\n property Align;\r\n property Anchors;\r\n //property AutoSize;\r\n property Constraints;\r\n property BiDiMode;\r\n property DragCursor;\r\n property DragKind;\r\n property OnCanResize;\r\n property DragMode;\r\n //property Enabled;\r\n property Font;\r\n property ParentFont;\r\n property ParentShowHint;\r\n property PopupMenu;\r\n property ShowHint;\r\n property Style;\r\n property StyleManager;\r\n property Visible;\r\n //property OnDockDrop;\r\n //property OnDockOver;\r\n //property OnEndDock;\r\n //property OnGetSiteInfo;\r\n //property OnStartDock;\r\n //property OnUnDock;\r\n property OnClick;\r\n property OnConstrainedResize;\r\n property OnContextPopup;\r\n property OnDragDrop;\r\n property OnDragOver;\r\n property OnEndDrag;\r\n property OnEnter;\r\n property OnExit;\r\n property OnKeyDown;\r\n property OnKeyPress;\r\n property OnKeyUp;\r\n property OnMouseDown;\r\n property OnMouseEnter;\r\n property OnMouseLeave;\r\n property OnMouseMove;\r\n property OnMouseUp;\r\n property OnStartDrag;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvXPCheckCtrls.pas $';\r\n Revision: '$Revision: 13104 $';\r\n Date: '$Date: 2011-09-07 08:50:43 +0200 (mer. 07 sept. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\n//=== { TJvXPCustomCheckControl } ============================================\r\n\r\nconstructor TJvXPCustomCheckControl.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n\r\n // set default properties.\r\n ControlStyle := ControlStyle - [csDoubleClicks];\r\n Height := 17;\r\n TabStop := True;\r\n Width := 161;\r\n\r\n // set custom properties.\r\n FBoundLines := [];\r\n FChecked := False;\r\n FCheckSize := 13;\r\n FSpacing := 3;\r\n\r\n // create ...\r\n FBgGradient := TBitmap.Create; // background gradient\r\n FCkGradient := TBitmap.Create; // clicked gradient\r\n FHlGradient := TBitmap.Create; // Highlight gradient\r\nend;\r\n\r\ndestructor TJvXPCustomCheckControl.Destroy;\r\nbegin\r\n FBgGradient.Free;\r\n FCkGradient.Free;\r\n FHlGradient.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvXPCustomCheckControl.Click;\r\nbegin\r\n if not AllowGrayed then\r\n Checked := not Checked\r\n else\r\n State := TCheckBoxState((Byte(State) + 1) mod 3);\r\n inherited Click;\r\nend;\r\n\r\nprocedure TJvXPCustomCheckControl.HookResized;\r\nbegin\r\n // create gradient rectangles for...\r\n\r\n // background.\r\n JvXPCreateGradientRect(FCheckSize - 2, FCheckSize - 2, dxColor_Btn_Enb_BgFrom_WXP,\r\n dxColor_Btn_Enb_BgTo_WXP, 16, gsTop, False, FBgGradient);\r\n\r\n // clicked.\r\n JvXPCreateGradientRect(FCheckSize - 2, FCheckSize - 2, dxColor_Btn_Enb_CkFrom_WXP,\r\n dxColor_Btn_Enb_CkTo_WXP, 16, gsTop, True, FCkGradient);\r\n\r\n // highlight.\r\n JvXPCreateGradientRect(FCheckSize - 2, FCheckSize - 2, dxColor_Btn_Enb_HlFrom_WXP,\r\n dxColor_Btn_Enb_HlTo_WXP, 16, gsTop, True, FHlGradient);\r\n\r\n LockedInvalidate;\r\nend;\r\n\r\nprocedure TJvXPCustomCheckControl.KeyDown(var Key: Word; Shift: TShiftState);\r\nbegin\r\n case Key of\r\n VK_SPACE:\r\n Checked := not Checked;\r\n end;\r\n inherited KeyDown(Key, Shift);\r\nend;\r\n\r\nprocedure TJvXPCustomCheckControl.SetAllowGrayed(const Value: Boolean);\r\nbegin\r\n FAllowGrayed := Value;\r\n if Value = False then\r\n if FState = cbGrayed then\r\n begin\r\n State := cbUnchecked;\r\n LockedInvalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvXPCustomCheckControl.SetBoundLines(Value: TJvXPBoundLines);\r\nbegin\r\n if Value <> FBoundLines then\r\n begin\r\n FBoundLines := Value;\r\n LockedInvalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvXPCustomCheckControl.SetChecked(Value: Boolean);\r\nbegin\r\n if Value <> FChecked then\r\n begin\r\n FChecked := Value;\r\n if Value then\r\n FState := cbChecked\r\n else\r\n FState := cbUnchecked;\r\n LockedInvalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvXPCustomCheckControl.SetSpacing(Value: Byte);\r\nbegin\r\n if Value <> FSpacing then\r\n begin\r\n FSpacing := Value;\r\n LockedInvalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvXPCustomCheckControl.SetState(const Value: TCheckBoxState);\r\nbegin\r\n // will not change FState if FAllowGrayed = false and passed Value is cbGrayed\r\n if (FState <> Value) and (FAllowGrayed or (Value <> cbGrayed)) then\r\n begin\r\n FState := Value;\r\n if FState = cbChecked then\r\n FChecked := True\r\n else\r\n FChecked := False;\r\n LockedInvalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvXPCustomCheckControl.Paint;\r\nvar\r\n Rect: TRect;\r\n BoundColor: TColor;\r\nbegin\r\n with Canvas do\r\n begin\r\n // clear background.\r\n Rect := GetClientRect;\r\n Brush.Color := Color;\r\n FillRect(Rect);\r\n // draw designtime rect.\r\n if csDesigning in ComponentState then\r\n DrawFocusRect(Rect);\r\n\r\n // draw boundlines.\r\n if BoundLines <> [] then\r\n begin\r\n if Style.GetTheme = WindowsXP then\r\n BoundColor := dxColor_Btn_Enb_Border_WXP\r\n else\r\n BoundColor := dxColor_DotNetFrame;\r\n JvXPDrawBoundLines(Self.Canvas, BoundLines, BoundColor, Rect);\r\n end;\r\n\r\n // draw focusrect.\r\n if dsFocused in DrawState then\r\n begin\r\n Brush.Style := bsSolid;\r\n DrawFocusRect(Rect);\r\n end;\r\n\r\n // draw check symbol.\r\n DrawCheckSymbol(Rect);\r\n\r\n // draw caption.\r\n SetBkMode(Handle, Transparent);\r\n Font.Assign(Self.Font);\r\n if BiDiMode = bdRightToLeft then\r\n begin\r\n Dec(Rect.Right, FCheckSize + 4 + Spacing);\r\n JvXPPlaceText(Self, Canvas, Caption, Font, Enabled, True, taRightJustify, True, Rect)\r\n end\r\n else\r\n begin\r\n Inc(Rect.Left, FCheckSize + 4 + Spacing);\r\n JvXPPlaceText(Self, Canvas, Caption, Font, Enabled, True, taLeftJustify, True, Rect);\r\n end;\r\n end;\r\nend;\r\n\r\n//=== { TJvXPCheckbox } ======================================================\r\n\r\nprocedure TJvXPCheckbox.DrawCheckSymbol(const R: TRect);\r\nvar\r\n ClipW: Integer;\r\n Bitmap: TBitmap;\r\n Theme: TJvXPTheme;\r\n\r\n procedure DrawGradient(const Bitmap: TBitmap);\r\n begin\r\n if BiDiMode = bdRightToLeft then\r\n BitBlt(Canvas.Handle, R.Right - 1 - FCheckSize, (ClientHeight - FCheckSize) div 2 + 1,\r\n FCheckSize - 2, FCheckSize - 2, Bitmap.Canvas.Handle, 0, 0, SRCCOPY)\r\n else\r\n BitBlt(Canvas.Handle, R.Left + 3, (ClientHeight - FCheckSize) div 2 + 1,\r\n FCheckSize - 2, FCheckSize - 2, Bitmap.Canvas.Handle, 0, 0, SRCCOPY);\r\n end;\r\n\r\nbegin\r\n // get current theme.\r\n Theme := Style.GetTheme;\r\n\r\n with Canvas do\r\n begin\r\n // check for highlight.\r\n ClipW := Ord(dsHighlight in DrawState);\r\n\r\n // draw border.\r\n if (Theme = WindowsXP) or ((Theme = OfficeXP) and (ClipW = 0)) then\r\n Pen.Color := dxColor_Chk_Enb_Border_WXP\r\n else\r\n Pen.Color := dxColor_BorderLineOXP;\r\n if BiDiMode = bdRightToLeft then\r\n Rectangle(Bounds(R.Right - 2 - FCheckSize , (ClientHeight - FCheckSize) div 2,FCheckSize, FCheckSize))\r\n else\r\n Rectangle(Bounds(R.Left + 2, (ClientHeight - FCheckSize) div 2,FCheckSize, FCheckSize));\r\n\r\n // draw background.\r\n case Theme of\r\n WindowsXP:\r\n begin\r\n if not ((ClipW <> 0) and (dsClicked in DrawState)) then\r\n begin\r\n if ClipW <> 0 then\r\n DrawGradient(FHlGradient);\r\n if BiDiMode = bdRightToLeft then\r\n BitBlt(Handle, R.Right - 1 - FCheckSize + ClipW, (ClientHeight - FCheckSize) div 2 + 1 +\r\n ClipW, FCheckSize - 2 - ClipW * 2, FCheckSize - 2 - ClipW * 2,\r\n FBgGradient.Canvas.Handle, 0, 0, SRCCOPY)\r\n else\r\n BitBlt(Handle, R.Left + 3 + ClipW, (ClientHeight - FCheckSize) div 2 + 1 +\r\n ClipW, FCheckSize - 2 - ClipW * 2, FCheckSize - 2 - ClipW * 2,\r\n FBgGradient.Canvas.Handle, 0, 0, SRCCOPY);\r\n end\r\n else\r\n DrawGradient(FCkGradient);\r\n end;\r\n OfficeXP:\r\n begin\r\n if ClipW <> 0 then\r\n begin\r\n if not (dsClicked in DrawState) then\r\n Brush.Color := dxColor_BgOXP\r\n else\r\n Brush.Color := dxColor_BgCkOXP;\r\n if BiDiMode = bdRightToLeft then\r\n FillRect(Bounds(R.Right - 1, (ClientHeight - FCheckSize) div 2 + 1,\r\n FCheckSize - 2, FCheckSize - 2))\r\n else\r\n FillRect(Bounds(R.Left + 3, (ClientHeight - FCheckSize) div 2 + 1,\r\n FCheckSize - 2, FCheckSize - 2))\r\n end;\r\n end;\r\n end;\r\n\r\n // draw checked or grayed symbols:\r\n if FState in [cbChecked, cbGrayed] then\r\n begin\r\n Brush.Color := clSilver;\r\n Pen.Color := dxColor_Btn_Enb_Border_WXP;\r\n Bitmap := TBitmap.Create;\r\n try\r\n Bitmap.Transparent := True;\r\n Bitmap.Assign(nil); // fixes GDI resource leak\r\n if FState = cbChecked then\r\n begin\r\n Bitmap.LoadFromResourceName(HInstance, 'JvXPCheckboxCHECKBOX')\r\n end\r\n else\r\n begin\r\n Bitmap.Transparent := false;\r\n Bitmap.LoadFromResourceName(HInstance, 'JvXPCheckboxCHECKBOXGRAY');\r\n end;\r\n if Theme = WindowsXP then\r\n begin\r\n if FState = cbChecked then\r\n JvXPColorizeBitmap(Bitmap, dxColor_Chk_Enb_NmSymb_WXP)\r\n else\r\n JvXPColorizeBitmap(Bitmap, dxColor_Chk_Enb_GraSymb_WXP);\r\n end\r\n else\r\n if (dsClicked in DrawState) and (dsHighlight in DrawState) then\r\n begin\r\n JvXPColorizeBitmap(Bitmap, clWhite);\r\n end;\r\n if BiDiMode = bdRightToLeft then\r\n Draw(R.Right - FCheckSize + 1, (ClientHeight - FCheckSize) div 2 + 3, Bitmap)\r\n else\r\n Draw(FCheckSize div 2 - 1, (ClientHeight - FCheckSize) div 2 + 3, Bitmap);\r\n finally\r\n Bitmap.Free;\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n\r\n" }, { "path": "External/Jedi/Jvcl/run/JvXPContainer.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvXPContainer.PAS, released on 2004-01-01.\r\n\r\nThe Initial Developer of the Original Code is Marc Hoffman.\r\nPortions created by Marc Hoffman are Copyright (C) 2002 APRIORI business solutions AG.\r\nPortions created by APRIORI business solutions AG are Copyright (C) 2002 APRIORI business solutions AG\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvXPContainer.pas 13138 2011-10-26 23:17:50Z jfudickar $\r\n\r\nunit JvXPContainer;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Classes,\r\n Windows, Controls, Graphics, StdCtrls,\r\n JvJCLUtils,\r\n JvXPCore, JvXPCoreUtils;\r\n\r\ntype\r\n TJvXPPaintEvent = procedure(Sender: TObject; Rect: TRect; ACanvas: TCanvas;\r\n AFont: TFont) of object;\r\n\r\n TJvXPEnabledMode = (emAffectChilds, emNormal);\r\n\r\n TJvXPCustomContainer = class(TJvXPCustomControl)\r\n private\r\n FAlignment: TAlignment;\r\n FBorderWidth: TBorderWidth;\r\n FBoundColor: TColor;\r\n FBoundLines: TJvXPBoundLines;\r\n FEnabledMode: TJvXPEnabledMode;\r\n FFocusable: Boolean;\r\n FGlyph: TBitmap;\r\n FGlyphLayout: TJvXPGlyphLayout;\r\n FLayout: TTextLayout;\r\n FShowBoundLines: Boolean;\r\n FShowCaption: Boolean;\r\n FSpacing: Byte;\r\n FWordWrap: Boolean;\r\n FOnEnabledChanged: TNotifyEvent;\r\n FOnPaint: TJvXPPaintEvent;\r\n procedure SetAlignment(Value: TAlignment);\r\n procedure SetBorderWidth(Value: TBorderWidth);\r\n procedure SetBoundColor(Value: TColor);\r\n procedure SetBoundLines(Value: TJvXPBoundLines);\r\n procedure SetEnabledMode(Value: TJvXPEnabledMode);\r\n procedure SetGlyph(Value: TBitmap);\r\n procedure SetGlyphLayout(Value: TJvXPGlyphLayout);\r\n procedure SetLayout(Value: TTextLayout);\r\n procedure SetShowBoundLines(Value: Boolean);\r\n procedure SetShowCaption(Value: Boolean);\r\n procedure SetSpacing(Value: Byte);\r\n procedure SetWordWrap(Value: Boolean);\r\n protected\r\n procedure CreateParams(var Params: TCreateParams); override;\r\n procedure AdjustClientRect(var Rect: TRect); override;\r\n procedure HookEnabledChanged; override;\r\n procedure HookMouseDown; override;\r\n procedure HookPosChanged; override;\r\n procedure Paint; override;\r\n property Alignment: TAlignment read FAlignment write SetAlignment default taCenter;\r\n property BorderWidth: TBorderWidth read FBorderWidth write SetBorderWidth default 0;\r\n property BoundColor: TColor read FBoundColor write SetBoundColor default clGray;\r\n property BoundLines: TJvXPBoundLines read FBoundLines write SetBoundLines default [];\r\n property EnabledMode: TJvXPEnabledMode read FEnabledMode write SetEnabledMode default emNormal;\r\n property Focusable: Boolean read FFocusable write FFocusable default False;\r\n property Glyph: TBitmap read FGlyph write SetGlyph;\r\n property GlyphLayout: TJvXPGlyphLayout read FGlyphLayout write SetGlyphLayout\r\n default glCenter;\r\n property Layout: TTextLayout read FLayout write SetLayout default tlCenter;\r\n property Height default 41;\r\n property ShowBoundLines: Boolean read FShowBoundLines write SetShowBoundLines\r\n default True;\r\n property ShowCaption: Boolean read FShowCaption write SetShowCaption\r\n default False;\r\n property Spacing: Byte read FSpacing write SetSpacing default 5;\r\n property Width default 185;\r\n property WordWrap: Boolean read FWordWrap write SetWordWrap default False;\r\n property OnEnabledChanged: TNotifyEvent read FOnEnabledChanged write FOnEnabledChanged;\r\n property OnPaint: TJvXPPaintEvent read FOnPaint write FOnPaint;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n end;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvXPContainer = class(TJvXPCustomContainer)\r\n published\r\n property Alignment;\r\n property AutoSize;\r\n property BorderWidth;\r\n property BoundColor;\r\n property BoundLines;\r\n property Caption;\r\n property Color;\r\n property Enabled;\r\n property EnabledMode;\r\n property Focusable;\r\n property Glyph;\r\n property GlyphLayout;\r\n property Layout;\r\n property ParentColor;\r\n property ShowBoundLines;\r\n property ShowCaption;\r\n property Spacing;\r\n property WordWrap;\r\n property OnEnabledChanged;\r\n property OnDblClick;\r\n property OnPaint;\r\n property OnResize;\r\n\r\n //property BevelInner;\r\n //property BevelOuter;\r\n //property BevelWidth;\r\n //property BiDiMode;\r\n //property Ctl3D;\r\n //property DockSite;\r\n //property ParentBiDiMode;\r\n //property ParentCtl3D;\r\n //property TabOrder;\r\n //property TabStop;\r\n //property UseDockManager default True;\r\n property Align;\r\n property Anchors;\r\n //property AutoSize;\r\n property Constraints;\r\n property DragCursor;\r\n property DragKind;\r\n property OnCanResize;\r\n property DragMode;\r\n //property Enabled;\r\n property Font;\r\n property ParentFont;\r\n property ParentShowHint;\r\n property PopupMenu;\r\n property ShowHint;\r\n property Visible;\r\n //property OnDockDrop;\r\n //property OnDockOver;\r\n //property OnEndDock;\r\n //property OnGetSiteInfo;\r\n //property OnStartDock;\r\n //property OnUnDock;\r\n property OnClick;\r\n property OnConstrainedResize;\r\n property OnContextPopup;\r\n property OnDragDrop;\r\n property OnDragOver;\r\n property OnEndDrag;\r\n property OnEnter;\r\n property OnExit;\r\n property OnKeyDown;\r\n property OnKeyPress;\r\n property OnKeyUp;\r\n property OnMouseDown;\r\n property OnMouseEnter;\r\n property OnMouseLeave;\r\n property OnMouseMove;\r\n property OnMouseUp;\r\n property OnStartDrag;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvXPContainer.pas $';\r\n Revision: '$Revision: 13138 $';\r\n Date: '$Date: 2011-10-27 01:17:50 +0200 (jeu. 27 oct. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\n//=== { TJvXPCustomContainer } ===============================================\r\n\r\nconstructor TJvXPCustomContainer.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n ControlStyle := ControlStyle + [csAcceptsControls];\r\n Height := 41;\r\n Width := 185;\r\n FAlignment := taCenter;\r\n FBoundColor := clGray;\r\n FBoundLines := [];\r\n FEnabledMode := emNormal;\r\n FFocusable := False;\r\n FGlyph := TBitmap.Create;\r\n FGlyph.Assign(nil);\r\n FGlyphLayout := glCenter;\r\n FLayout := tlCenter;\r\n FShowBoundLines := True;\r\n FShowCaption := False;\r\n FSpacing := 5;\r\n FWordWrap := False;\r\nend;\r\n\r\ndestructor TJvXPCustomContainer.Destroy;\r\nbegin\r\n FGlyph.Free;\r\n inherited Destroy;\r\nend;\r\n\r\n\r\nprocedure TJvXPCustomContainer.CreateParams(var Params: TCreateParams);\r\nbegin\r\n inherited CreateParams(Params);\r\n with Params do\r\n WindowClass.Style := WindowClass.Style and not (CS_HREDRAW or CS_VREDRAW);\r\nend;\r\n\r\n\r\nprocedure TJvXPCustomContainer.HookEnabledChanged;\r\nvar\r\n I: Integer;\r\nbegin\r\n inherited HookEnabledChanged;\r\n if FEnabledMode = emAffectChilds then\r\n for I := 0 to ControlCount - 1 do\r\n Controls[I].Enabled := Enabled;\r\n if Assigned(FOnEnabledChanged) then\r\n FOnEnabledChanged(Self);\r\nend;\r\n\r\nprocedure TJvXPCustomContainer.HookMouseDown;\r\nbegin\r\n if FFocusable then\r\n inherited HookMouseDown\r\n else\r\n begin\r\n DrawState := DrawState + [dsClicked];\r\n InternalRedraw;\r\n end;\r\nend;\r\n\r\nprocedure TJvXPCustomContainer.HookPosChanged;\r\nbegin\r\n inherited HookPosChanged;\r\n InternalRedraw;\r\nend;\r\n\r\nprocedure TJvXPCustomContainer.AdjustClientRect(var Rect: TRect);\r\nbegin\r\n inherited AdjustClientRect(Rect);\r\n JvXPAdjustBoundRect(BorderWidth, FShowBoundLines, FBoundLines, Rect);\r\n if not FGlyph.Empty then\r\n Inc(Rect.Left, FGlyph.Width);\r\nend;\r\n\r\nprocedure TJvXPCustomContainer.SetAlignment(Value: TAlignment);\r\nbegin\r\n if Value <> FAlignment then\r\n begin\r\n FAlignment := Value;\r\n InternalRedraw;\r\n end;\r\nend;\r\n\r\nprocedure TJvXPCustomContainer.SetBoundColor(Value: TColor);\r\nbegin\r\n if Value <> FBoundColor then\r\n begin\r\n FBoundColor := Value;\r\n InternalRedraw;\r\n end;\r\nend;\r\n\r\nprocedure TJvXPCustomContainer.SetBoundLines(Value: TJvXPBoundLines);\r\nbegin\r\n if Value <> FBoundLines then\r\n begin\r\n FBoundLines := Value;\r\n Realign;\r\n InternalRedraw;\r\n end;\r\nend;\r\n\r\nprocedure TJvXPCustomContainer.SetBorderWidth(Value: TBorderWidth);\r\nbegin\r\n if Value <> FBorderWidth then\r\n begin\r\n FBorderWidth := Value;\r\n Realign;\r\n InternalRedraw;\r\n end;\r\nend;\r\n\r\nprocedure TJvXPCustomContainer.SetEnabledMode(Value: TJvXPEnabledMode);\r\nbegin\r\n if Value <> FEnabledMode then\r\n begin\r\n FEnabledMode := Value;\r\n HookEnabledChanged;\r\n end;\r\nend;\r\n\r\nprocedure TJvXPCustomContainer.SetGlyph(Value: TBitmap);\r\nbegin\r\n if Value <> FGlyph then\r\n begin\r\n FGlyph.Assign(Value);\r\n Realign;\r\n InternalRedraw;\r\n end;\r\nend;\r\n\r\nprocedure TJvXPCustomContainer.SetGlyphLayout(Value: TJvXPGlyphLayout);\r\nbegin\r\n if FGlyphLayout <> Value then\r\n begin\r\n FGlyphLayout := Value;\r\n InternalRedraw;\r\n end;\r\nend;\r\n\r\nprocedure TJvXPCustomContainer.SetLayout(Value: TTextLayout);\r\nbegin\r\n if FLayout <> Value then\r\n begin\r\n FLayout := Value;\r\n InternalRedraw;\r\n end;\r\nend;\r\n\r\nprocedure TJvXPCustomContainer.SetShowBoundLines(Value: Boolean);\r\nbegin\r\n if Value <> FShowBoundLines then\r\n begin\r\n FShowBoundLines := Value;\r\n Realign;\r\n InternalRedraw;\r\n end;\r\nend;\r\n\r\nprocedure TJvXPCustomContainer.SetShowCaption(Value: Boolean);\r\nbegin\r\n if Value <> FShowCaption then\r\n begin\r\n FShowCaption := Value;\r\n InternalRedraw;\r\n end;\r\nend;\r\n\r\nprocedure TJvXPCustomContainer.SetSpacing(Value: Byte);\r\nbegin\r\n if Value <> FSpacing then\r\n begin\r\n FSpacing := Value;\r\n InternalRedraw;\r\n end;\r\nend;\r\n\r\nprocedure TJvXPCustomContainer.SetWordWrap(Value: Boolean);\r\nbegin\r\n if Value <> FWordWrap then\r\n begin\r\n FWordWrap := Value;\r\n InternalRedraw;\r\n end;\r\nend;\r\n\r\nprocedure DxDrawText(AParent: TJvXPCustomControl; ACaption: TCaption; AFont: TFont;\r\n AAlignment: TAlignment; ALayout: TTextLayout; AWordWrap: Boolean; var ARect: TRect);\r\nconst\r\n Alignments: array [TAlignment] of Word = (DT_LEFT, DT_RIGHT, DT_CENTER);\r\n WordWraps: array [Boolean] of Word = (0, DT_WORDBREAK);\r\nvar\r\n DrawStyle: Longint;\r\n CalcRect: TRect;\r\n\r\n procedure DoDrawText(ACanvas: TCanvas; const ACaption: TCaption; var ARect: TRect;\r\n AFlags: Integer);\r\n begin\r\n DrawText(ACanvas, ACaption, -1, ARect, AFlags);\r\n end;\r\n\r\nbegin\r\n with AParent, Canvas do\r\n begin\r\n DrawStyle := Alignments[AAlignment];\r\n if (DrawStyle <> DT_LEFT) and (ARect.Right - ARect.Left < TextWidth(ACaption)) then\r\n DrawStyle := DT_LEFT;\r\n DrawStyle := DrawStyle or DT_EXPANDTABS or WordWraps[AWordWrap] or DT_END_ELLIPSIS;\r\n if ALayout <> tlTop then\r\n begin\r\n CalcRect := ARect;\r\n DoDrawText(Canvas, ACaption, CalcRect, DrawStyle or DT_CALCRECT);\r\n if ALayout = tlBottom then\r\n OffsetRect(ARect, 0, ARect.Bottom - CalcRect.Bottom)\r\n else\r\n OffsetRect(ARect, 0, (ARect.Bottom - CalcRect.Bottom) div 2);\r\n end;\r\n DoDrawText(Canvas, ACaption, ARect, DrawStyle);\r\n end;\r\nend;\r\n\r\nprocedure TJvXPCustomContainer.Paint;\r\nvar\r\n Rect: TRect;\r\nbegin\r\n with Canvas do\r\n begin\r\n Rect := GetClientRect;\r\n Brush.Color := Self.Color;\r\n FillRect(Rect);\r\n if csDesigning in ComponentState then\r\n DrawFocusRect(Rect);\r\n Brush.Style := bsClear;\r\n if (FShowBoundLines) and (FBoundLines <> []) then\r\n JvXPDrawBoundLines(Self.Canvas, FBoundLines, FBoundColor, Rect);\r\n JvXPAdjustBoundRect(BorderWidth, FShowBoundLines, FBoundLines, Rect);\r\n if Assigned(FOnPaint) then\r\n FOnPaint(Self, Rect, Self.Canvas, Font);\r\n if not FGlyph.Empty then\r\n begin\r\n FGlyph.Transparent := True;\r\n if FGlyphLayout = glBottom then\r\n Draw(Rect.Left, Rect.Bottom - FGlyph.Height, FGlyph);\r\n if FGlyphLayout = glCenter then\r\n Draw(Rect.Left, ((Rect.Bottom - Rect.Top) - FGlyph.Height) div 2 + 1, FGlyph);\r\n if FGlyphLayout = glTop then\r\n Draw(Rect.Left, Rect.Top, FGlyph);\r\n Inc(Rect.Left, FGlyph.Width);\r\n end;\r\n if FShowCaption then\r\n begin\r\n Font.Assign(Self.Font);\r\n InflateRect(Rect, -FSpacing, -1);\r\n if csDesigning in ComponentState then\r\n begin\r\n Pen.Color := clGray;\r\n Pen.Style := psSolid;\r\n MoveTo(Rect.Left, Rect.Top);\r\n LineTo(Rect.Left, Rect.Bottom);\r\n MoveTo(Rect.Right, Rect.Top);\r\n LineTo(Rect.Right, Rect.Bottom);\r\n end;\r\n DxDrawText(Self, Caption, Font, FAlignment, FLayout, FWordWrap, Rect);\r\n //JvXPPlaceText(Self, Canvas, Caption, Font, Enabled, False, FAlignment,\r\n // FWordWrap, Rect);\r\n end;\r\n end;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend." }, { "path": "External/Jedi/Jvcl/run/JvXPCore.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvXPCore.PAS, released on 2004-01-01.\r\n\r\nThe Initial Developer of the Original Code is Marc Hoffman.\r\nPortions created by Marc Hoffman are Copyright (C) 2002 APRIORI business solutions AG.\r\nPortions created by APRIORI business solutions AG are Copyright (C) 2002 APRIORI business solutions AG\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvXPCore.pas 13145 2011-11-02 21:15:19Z ahuser $\r\n\r\nunit JvXPCore;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, Controls, Graphics, Forms, Messages, // asn: messages after controls for clx\r\n JvComponentBase, JvComponent,\r\n Classes;\r\n\r\nconst\r\n { color constants.\r\n\r\n these constants are used as default colors for descendant controls\r\n and may be replaced with other (common) values.\r\n\r\n syntax: JvXPColor_[Control]_[Enabled: Enb, Dis]_[Type]_[Theme: WXP, OXP] }\r\n\r\n { button colors - WindowsXP }\r\n dxColor_Btn_Enb_Border_WXP = TColor($00733800); // border line\r\n dxColor_Btn_Dis_Border_WXP = TColor($00BDC7CE); // border line (disabled)\r\n dxColor_Btn_Enb_Edges_WXP = TColor($00AD9E7B); // border edges\r\n dxColor_Btn_Dis_Edges_WXP = TColor($00BDC7CE); // border edges (disabled)\r\n dxColor_Btn_Enb_BgFrom_WXP = TColor($00FFFFFF); // background from\r\n dxColor_Btn_Enb_BgTo_WXP = TColor($00E7EBEF); // background to\r\n dxColor_Btn_Enb_CkFrom_WXP = TColor($00C6CFD6); // clicked from\r\n dxColor_Btn_Enb_CkTo_WXP = TColor($00EBF3F7); // clicked to\r\n dxColor_Btn_Enb_FcFrom_WXP = TColor($00FFE7CE); // focused from\r\n dxColor_Btn_Enb_FcTo_WXP = TColor($00EF846D); // focused to\r\n dxColor_Btn_Enb_HlFrom_WXP = TColor($00CEF3FF); // highlight from\r\n dxColor_Btn_Enb_HlTo_WXP = TColor($000096E7); // highlight to\r\n\r\n { checkbox colors - WindowsXP }\r\n dxColor_Chk_Enb_Border_WXP = TColor($00845118); // border line\r\n dxColor_Chk_Enb_NmSymb_WXP = TColor($0021A621); // symbol normal\r\n dxColor_Chk_Enb_GraSymb_WXP = TColor($0071C671); // symbol grayed\r\n\r\n { misc colors - WindowsXP }\r\n dxColor_Msc_Dis_Caption_WXP = TColor($0094A6A5); // caption color (disabled)\r\n\r\n dxColor_DotNetFrame = TColor($00F7FBFF); // $00E7EBEF;\r\n dxColor_BorderLineOXP = TColor($00663300);\r\n dxColor_BgOXP = TColor($00D6BEB5);\r\n dxColor_BgCkOXP = TColor($00CC9999);\r\n\r\ntype\r\n TJvXPCustomStyleControl = class;\r\n\r\n TJvXPBoundLines = set of\r\n (\r\n blLeft, // left line\r\n blTop, // top line\r\n blRight, // right line\r\n blBottom // bottom line\r\n );\r\n\r\n TJvXPControlStyle = set of\r\n (\r\n csRedrawCaptionChanged, // (default)\r\n csRedrawBorderChanged, //\r\n csRedrawEnabledChanged, // (default)\r\n csRedrawFocusedChanged, // (default)\r\n csRedrawMouseDown, // (default)\r\n csRedrawMouseEnter, // (default)\r\n csRedrawMouseLeave, // (default)\r\n csRedrawMouseMove, //\r\n csRedrawMouseUp, // (default)\r\n csRedrawParentColorChanged, // (default)\r\n csRedrawParentFontChanged, //\r\n csRedrawPosChanged, //\r\n csRedrawResized //\r\n );\r\n\r\n TJvXPDrawState = set of\r\n (\r\n dsDefault, // default\r\n dsHighlight, // highlighted\r\n dsClicked, // clicked\r\n dsFocused // focused\r\n );\r\n\r\n TJvXPGlyphLayout =\r\n (\r\n glBottom, // bottom glyph\r\n glCenter, // centered glyph\r\n glTop // top glyph\r\n );\r\n\r\n TJvXPTheme =\r\n (\r\n WindowsXP, // WindowsXP theme\r\n OfficeXP // OfficeXP theme\r\n );\r\n\r\n { baseclass for non-focusable component descendants. }\r\n TJvXPCustomComponent = class(TJvComponent);\r\n\r\n TJvXPWinControl = class(TJvWinControl)\r\n published\r\n property Color;\r\n end;\r\n { baseclass for focusable control descendants. }\r\n\r\n TJvXPCustomControl = class(TJvCustomControl)\r\n private\r\n FClicking: Boolean;\r\n FDrawState: TJvXPDrawState;\r\n FIsLocked: Integer;\r\n FIsSibling: Boolean;\r\n FModalResult: TModalResult;\r\n FOnMouseLeave: TNotifyEvent;\r\n FOnMouseEnter: TNotifyEvent;\r\n procedure CMFocusChanged(var Msg: TMessage); message CM_FOCUSCHANGED;\r\n procedure CMDialogChar(var Msg: TCMDialogChar); message CM_DIALOGCHAR;\r\n procedure CMBorderChanged(var Msg: TMessage); message CM_BORDERCHANGED;\r\n procedure CMEnabledChanged(var Msg: TMessage); message CM_ENABLEDCHANGED;\r\n procedure CMMouseEnter(var Msg: TMessage); message CM_MOUSEENTER;\r\n procedure CMMouseLeave(var Msg: TMessage); message CM_MOUSELEAVE;\r\n procedure CMParentColorChanged(var Msg: TMessage); message CM_PARENTCOLORCHANGED;\r\n procedure CMParentFontChanged(var Msg: TMessage); message CM_PARENTFONTCHANGED;\r\n procedure CMTextChanged(var Msg: TMessage); message CM_TEXTCHANGED;\r\n procedure WMMouseMove(var Msg: TWMMouse); message WM_MOUSEMOVE;\r\n procedure WMSize(var Msg: TWMSize); message WM_SIZE;\r\n procedure WMWindowPosChanged(var Msg: TWMWindowPosChanged); message WM_WINDOWPOSCHANGED;\r\n function GetIsLocked: Boolean;\r\n protected\r\n ExControlStyle: TJvXPControlStyle;\r\n procedure InternalRedraw; virtual;\r\n procedure HookBorderChanged; virtual;\r\n procedure HookEnabledChanged; virtual;\r\n procedure HookFocusedChanged; virtual;\r\n procedure HookMouseDown; virtual;\r\n procedure HookMouseEnter; virtual;\r\n procedure HookMouseLeave; virtual;\r\n procedure HookMouseMove(X: Integer = 0; Y: Integer = 0); virtual;\r\n procedure HookMouseUp; virtual;\r\n procedure HookParentColorChanged; virtual;\r\n procedure HookParentFontChanged; virtual;\r\n procedure HookPosChanged; virtual;\r\n procedure HookResized; virtual;\r\n procedure HookTextChanged; virtual;\r\n procedure BeginUpdate; virtual;\r\n procedure EndUpdate; virtual;\r\n procedure LockedInvalidate; virtual;\r\n procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;\r\n procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;\r\n procedure Click; override;\r\n property ModalResult: TModalResult read FModalResult write FModalResult default 0;\r\n property OnMouseEnter: TNotifyEvent read FOnMouseEnter write FOnMouseEnter;\r\n property OnMouseLeave: TNotifyEvent read FOnMouseLeave write FOnMouseLeave;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n property Canvas;\r\n property DrawState: TJvXPDrawState read FDrawState write FDrawState;\r\n property IsLocked: Boolean read GetIsLocked {write FIsLocked}; // AHUser: Use BeginUpdate/EndUpdate\r\n property IsSibling: Boolean read FIsSibling write FIsSibling;\r\n end;\r\n\r\n TJvXPUnlimitedControl = class(TJvXPCustomControl)\r\n published\r\n //property BevelInner;\r\n //property BevelOuter;\r\n //property BevelWidth;\r\n //property BiDiMode;\r\n //property Ctl3D;\r\n //property DockSite;\r\n //property ParentBiDiMode;\r\n //property ParentCtl3D;\r\n //property TabOrder;\r\n //property TabStop;\r\n //property UseDockManager default True;\r\n property Align;\r\n property Anchors;\r\n //property AutoSize;\r\n property Constraints;\r\n property DragCursor;\r\n property DragKind;\r\n property OnCanResize;\r\n property DragMode;\r\n //property Enabled;\r\n property Font;\r\n property ParentFont;\r\n property ParentShowHint;\r\n property PopupMenu;\r\n property ShowHint;\r\n property Visible;\r\n //property OnDockDrop;\r\n //property OnDockOver;\r\n //property OnEndDock;\r\n //property OnGetSiteInfo;\r\n //property OnStartDock;\r\n //property OnUnDock;\r\n property OnClick;\r\n property OnConstrainedResize;\r\n property OnContextPopup;\r\n property OnDragDrop;\r\n property OnDragOver;\r\n property OnEndDrag;\r\n property OnEnter;\r\n property OnExit;\r\n property OnKeyDown;\r\n property OnKeyPress;\r\n property OnKeyUp;\r\n property OnMouseDown;\r\n property OnMouseEnter;\r\n property OnMouseLeave;\r\n property OnMouseMove;\r\n property OnMouseUp;\r\n property OnStartDrag;\r\n end;\r\n\r\n TJvXPStyle = class(TPersistent)\r\n private\r\n FTheme: TJvXPTheme;\r\n FUseStyleManager: Boolean;\r\n protected\r\n Parent: TJvXPCustomStyleControl;\r\n procedure SetTheme(Value: TJvXPTheme); virtual;\r\n procedure SetUseStyleManager(Value: Boolean); virtual;\r\n public\r\n constructor Create(AOwner: TComponent);\r\n function GetTheme: TJvXPTheme;\r\n published\r\n property Theme: TJvXPTheme read FTheme write SetTheme default WindowsXP;\r\n property UseStyleManager: Boolean read FUseStyleManager write SetUseStyleManager default True;\r\n end;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvXPStyleManager = class(TJvXPCustomComponent)\r\n private\r\n FControls: TList;\r\n FTheme: TJvXPTheme;\r\n FOnThemeChanged: TNotifyEvent;\r\n procedure InvalidateControls;\r\n protected\r\n procedure SetTheme(Value: TJvXPTheme); virtual;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n procedure RegisterControls(const AControls: array of TJvXPCustomControl);\r\n procedure UnregisterControls(const AControls: array of TJvXPCustomControl);\r\n published\r\n property Theme: TJvXPTheme read FTheme write SetTheme default WindowsXP;\r\n property OnThemeChanged: TNotifyEvent read FOnThemeChanged write FOnThemeChanged;\r\n end;\r\n\r\n TJvXPCustomStyleControl = class(TJvXPCustomControl)\r\n private\r\n FStyle: TJvXPStyle;\r\n FStyleManager: TJvXPStyleManager;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n protected\r\n procedure SetStyleManager(Value: TJvXPStyleManager); virtual;\r\n procedure Notification(AComponent: TComponent; Operation: TOperation); override;\r\n property Style: TJvXPStyle read FStyle write FStyle;\r\n property StyleManager: TJvXPStyleManager read FStyleManager write SetStyleManager;\r\n end;\r\n\r\n TJvXPGradientColors = 2..255;\r\n\r\n TJvXPGradientStyle = (gsLeft, gsTop, gsRight, gsBottom);\r\n\r\n TJvXPGradient = class(TPersistent)\r\n private\r\n FColors: TJvXPGradientColors;\r\n FDithered: Boolean;\r\n FEnabled: Boolean;\r\n FEndColor: TColor;\r\n FStartColor: TColor;\r\n FGradientStyle: TJvXPGradientStyle;\r\n protected\r\n Parent: TJvXPCustomControl;\r\n procedure SetDithered(Value: Boolean); virtual;\r\n procedure SetColors(Value: TJvXPGradientColors); virtual;\r\n procedure SetEnabled(Value: Boolean); virtual;\r\n procedure SetEndColor(Value: TColor); virtual;\r\n procedure SetGradientStyle(Value: TJvXPGradientStyle); virtual;\r\n procedure SetStartColor(Value: TColor); virtual;\r\n public\r\n Bitmap: TBitmap;\r\n constructor Create(AOwner: TControl);\r\n destructor Destroy; override;\r\n procedure RecreateBands; virtual;\r\n published\r\n property Dithered: Boolean read FDithered write SetDithered default True;\r\n property Colors: TJvXPGradientColors read FColors write SetColors default 16;\r\n property Enabled: Boolean read FEnabled write SetEnabled default False;\r\n property EndColor: TColor read FEndColor write SetEndColor default clSilver;\r\n property StartColor: TColor read FStartColor write SetStartColor default clGray;\r\n property Style: TJvXPGradientStyle read FGradientStyle write SetGradientStyle default gsLeft;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvXPCore.pas $';\r\n Revision: '$Revision: 13145 $';\r\n Date: '$Date: 2011-11-02 22:15:19 +0100 (mer. 02 nov. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n JvXPCoreUtils, JvJVCLUtils;\r\n\r\n{$R JvXPCore.res}\r\n\r\n//=== { TJvXPCustomControl } =================================================\r\n\r\nconstructor TJvXPCustomControl.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n ControlStyle := ControlStyle + [csOpaque, csReplicatable];\r\n DoubleBuffered := True;\r\n ExControlStyle := [csRedrawEnabledChanged, csRedrawFocusedChanged,\r\n csRedrawMouseDown, csRedrawMouseEnter, csRedrawMouseLeave, csRedrawMouseUp,\r\n csRedrawParentColorChanged, csRedrawCaptionChanged];\r\n FDrawState := [dsDefault];\r\n FModalResult := 0;\r\nend;\r\n\r\nprocedure TJvXPCustomControl.BeginUpdate;\r\nbegin\r\n Inc(FIsLocked);\r\nend;\r\n\r\nprocedure TJvXPCustomControl.EndUpdate;\r\nbegin\r\n Assert(FIsLocked > 0, 'Unpaired call to TJvXPCustomControl.EndUpdate'); // do not localize\r\n Dec(FIsLocked);\r\n InternalRedraw;\r\nend;\r\n\r\nfunction TJvXPCustomControl.GetIsLocked: Boolean;\r\nbegin\r\n Result := FIsLocked > 0;\r\nend;\r\n\r\nprocedure TJvXPCustomControl.LockedInvalidate;\r\nbegin\r\n if not IsLocked then\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvXPCustomControl.InternalRedraw;\r\nbegin\r\n if not IsLocked then\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvXPCustomControl.CMDialogChar(var Msg: TCMDialogChar);\r\nbegin\r\n with Msg do\r\n if IsAccel(CharCode, Caption) and CanFocus and\r\n (Focused or ((GetKeyState(VK_MENU) and $8000) <> 0)) then\r\n begin\r\n Click;\r\n Result := 1;\r\n end\r\n else\r\n inherited;\r\nend;\r\n\r\nprocedure TJvXPCustomControl.CMBorderChanged(var Msg: TMessage);\r\nbegin\r\n // delegate message \"BorderChanged\" to hook.\r\n inherited;\r\n HookBorderChanged;\r\nend;\r\n\r\nprocedure TJvXPCustomControl.CMEnabledChanged(var Msg: TMessage);\r\nbegin\r\n // delegate message \"EnabledChanged\" to hook.\r\n inherited;\r\n HookEnabledChanged;\r\nend;\r\n\r\n\r\nprocedure TJvXPCustomControl.CMFocusChanged(var Msg: TMessage);\r\nbegin\r\n // delegate message \"FocusChanged\" to hook.\r\n inherited;\r\n HookFocusedChanged;\r\nend;\r\n\r\n\r\nprocedure TJvXPCustomControl.CMMouseEnter(var Msg: TMessage);\r\nbegin\r\n // delegate message \"MouseEnter\" to hook.\r\n inherited;\r\n HookMouseEnter;\r\nend;\r\n\r\nprocedure TJvXPCustomControl.CMMouseLeave(var Msg: TMessage);\r\nbegin\r\n // delegate message \"MouseLeave\" to hook.\r\n inherited;\r\n HookMouseLeave;\r\nend;\r\n\r\nprocedure TJvXPCustomControl.CMParentColorChanged(var Msg: TMessage);\r\nbegin\r\n // delegate message \"ParentColorChanged\" to hook.\r\n inherited;\r\n HookParentColorChanged;\r\nend;\r\n\r\nprocedure TJvXPCustomControl.CMParentFontChanged(var Msg: TMessage);\r\nbegin\r\n // delegate message \"ParentFontChanged\" to hook.\r\n inherited;\r\n HookParentFontChanged;\r\nend;\r\n\r\nprocedure TJvXPCustomControl.CMTextChanged(var Msg: TMessage);\r\nbegin\r\n // delegate message \"TextChanged\" to hook.\r\n inherited;\r\n HookTextChanged;\r\nend;\r\n\r\nprocedure TJvXPCustomControl.WMMouseMove(var Msg: TWMMouse);\r\nbegin\r\n // delegate message \"MouseMove\" to hook.\r\n inherited;\r\n HookMouseMove(Msg.XPos, Msg.YPos);\r\nend;\r\n\r\nprocedure TJvXPCustomControl.WMSize(var Msg: TWMSize);\r\nbegin\r\n // delegate message \"Size\" to hook.\r\n inherited;\r\n HookResized;\r\nend;\r\n\r\nprocedure TJvXPCustomControl.WMWindowPosChanged(var Msg: TWMWindowPosChanged);\r\nbegin\r\n // delegate message \"WindowPosChanged\" to hook.\r\n inherited;\r\n HookPosChanged;\r\nend;\r\n\r\nprocedure TJvXPCustomControl.MouseDown(Button: TMouseButton;\r\n Shift: TShiftState; X, Y: Integer);\r\nbegin\r\n // delegate message \"MouseDown\" to hook.\r\n inherited MouseDown(Button, Shift, X, Y);\r\n if Button = mbLeft then\r\n begin\r\n FClicking := True;\r\n HookMouseDown;\r\n end;\r\nend;\r\n\r\nprocedure TJvXPCustomControl.MouseUp(Button: TMouseButton;\r\n Shift: TShiftState; X, Y: Integer);\r\nbegin\r\n // delegate message \"MouseUp\" to hook.\r\n inherited MouseUp(Button, Shift, X, Y);\r\n if FClicking then\r\n begin\r\n FClicking := False;\r\n HookMouseUp;\r\n end;\r\nend;\r\n\r\nprocedure TJvXPCustomControl.Click;\r\nvar\r\n Form: TCustomForm;\r\nbegin\r\n { Prevent the Click event to be triggered twice, when the user keeps the mouse\r\n pressed and then uses the ENTER or SPACE key to execute the \"click\".\r\n Mantis #4181 is fixed by this. } \r\n ControlState := ControlState - [csClicked];\r\n\r\n Form := GetParentForm(Self);\r\n if Form <> nil then\r\n Form.ModalResult := ModalResult;\r\n inherited Click;\r\nend;\r\n\r\n//\r\n// hooks are used to interrupt default windows messages in an easier\r\n// way - it's possible to override them in descendant classes.\r\n// Beware of multiple redraw calls - if you know that the calling\r\n// hooks always redraws the component, use the lock i.e. unlock methods\r\n// (rom) or LockedInvalidate.\r\n\r\nprocedure TJvXPCustomControl.HookBorderChanged;\r\nbegin\r\n // this hook is called, if the border property was changed.\r\n // in that case we normaly have to redraw the control.\r\n if csRedrawBorderChanged in ExControlStyle then\r\n InternalRedraw;\r\nend;\r\n\r\nprocedure TJvXPCustomControl.HookEnabledChanged;\r\nbegin\r\n // this hook is called, if the enabled property was switched.\r\n // in that case we normaly have to redraw the control.\r\n if csRedrawEnabledChanged in ExControlStyle then\r\n InternalRedraw;\r\nend;\r\n\r\nprocedure TJvXPCustomControl.HookFocusedChanged;\r\nbegin\r\n // this hook is called, if the currently focused control was changed.\r\n if Focused then\r\n Include(FDrawState, dsFocused)\r\n else\r\n begin\r\n Exclude(FDrawState, dsFocused);\r\n Exclude(FDrawState, dsClicked);\r\n end;\r\n FIsSibling := GetParentForm(Self).ActiveControl is TJvXPCustomControl;\r\n if csRedrawFocusedChanged in ExControlStyle then\r\n InternalRedraw;\r\nend;\r\n\r\nprocedure TJvXPCustomControl.HookMouseEnter;\r\nbegin\r\n // this hook is called, if the user moves (hover) the mouse over the control.\r\n if not (csDesigning in ComponentState) then\r\n begin\r\n Include(FDrawState, dsHighlight);\r\n if csRedrawMouseEnter in ExControlStyle then\r\n InternalRedraw;\r\n end;\r\n if Assigned(FOnMouseEnter) then\r\n FOnMouseEnter(Self);\r\nend;\r\n\r\nprocedure TJvXPCustomControl.HookMouseLeave;\r\nbegin\r\n // this hook is called, if the user moves the mouse away (unhover) from\r\n // the control.\r\n if not (csDesigning in ComponentState) then\r\n begin\r\n Exclude(FDrawState, dsHighlight);\r\n if csRedrawMouseLeave in ExControlStyle then\r\n InternalRedraw;\r\n end;\r\n if Assigned(FOnMouseLeave) then\r\n FOnMouseLeave(Self);\r\nend;\r\n\r\nprocedure TJvXPCustomControl.HookMouseMove(X: Integer = 0; Y: Integer = 0);\r\nbegin\r\n // this hook is called if the user moves the mouse inside the control.\r\n if not (csDesigning in ComponentState) then\r\n if csRedrawMouseMove in ExControlStyle then\r\n InternalRedraw;\r\nend;\r\n\r\nprocedure TJvXPCustomControl.HookMouseDown;\r\nbegin\r\n // this hook is called, if the user presses the left mouse button over the\r\n // controls.\r\n if not Focused and CanFocus then\r\n SetFocus;\r\n Include(FDrawState, dsClicked);\r\n if csRedrawMouseDown in ExControlStyle then\r\n InternalRedraw;\r\nend;\r\n\r\nprocedure TJvXPCustomControl.HookMouseUp;\r\nvar\r\n CurrentPos: TPoint;\r\n NewControl: TWinControl;\r\nbegin\r\n // this hook is called, if the user releases the left mouse button.\r\n begin\r\n Exclude(FDrawState, dsClicked);\r\n if csRedrawMouseUp in ExControlStyle then\r\n InternalRedraw;\r\n\r\n // does the cursor is over another supported control?\r\n GetCursorPos(CurrentPos);\r\n NewControl := FindVCLWindow(CurrentPos);\r\n if (NewControl <> nil) and (NewControl <> Self) and\r\n (NewControl.InheritsFrom(TJvXPCustomControl)) then\r\n TJvXPCustomControl(NewControl).HookMouseEnter;\r\n end;\r\nend;\r\n\r\nprocedure TJvXPCustomControl.HookParentColorChanged;\r\nbegin\r\n // this hook is called if, the parent color was changed.\r\n if csRedrawParentColorChanged in ExControlStyle then\r\n InternalRedraw;\r\nend;\r\n\r\nprocedure TJvXPCustomControl.HookParentFontChanged;\r\nbegin\r\n // this hook is called if, the parent font was changed.\r\n if csRedrawParentFontChanged in ExControlStyle then\r\n InternalRedraw;\r\nend;\r\n\r\nprocedure TJvXPCustomControl.HookPosChanged;\r\nbegin\r\n // this hook is called, if the window position was changed.\r\n if csRedrawPosChanged in ExControlStyle then\r\n InternalRedraw;\r\nend;\r\n\r\nprocedure TJvXPCustomControl.HookResized;\r\nbegin\r\n // this hook is called, if the control was resized.\r\n if csRedrawResized in ExControlStyle then\r\n InternalRedraw;\r\nend;\r\n\r\nprocedure TJvXPCustomControl.HookTextChanged;\r\nbegin\r\n // this hook is called, if the caption was changed.\r\n if csRedrawCaptionChanged in ExControlStyle then\r\n InternalRedraw;\r\nend;\r\n\r\n//=== { TJvXPStyle } =========================================================\r\n\r\nconstructor TJvXPStyle.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create;\r\n Parent := TJvXPCustomStyleControl(AOwner);\r\n FTheme := WindowsXP;\r\n FUseStyleManager := True;\r\nend;\r\n\r\nprocedure TJvXPStyle.SetTheme(Value: TJvXPTheme);\r\nbegin\r\n if Value <> FTheme then\r\n begin\r\n FTheme := Value;\r\n Parent.InternalRedraw;\r\n end;\r\nend;\r\n\r\nfunction TJvXPStyle.GetTheme: TJvXPTheme;\r\nbegin\r\n Result := FTheme;\r\n if FUseStyleManager and Assigned(Parent.StyleManager) then\r\n Result := Parent.StyleManager.Theme;\r\nend;\r\n\r\nprocedure TJvXPStyle.SetUseStyleManager(Value: Boolean);\r\nbegin\r\n if Value <> FUseStyleManager then\r\n begin\r\n FUseStyleManager := Value;\r\n Parent.InternalRedraw;\r\n end;\r\nend;\r\n\r\n//=== { TJvXPStyleManager } ==================================================\r\n\r\nconstructor TJvXPStyleManager.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FControls := TList.Create;\r\n FTheme := WindowsXP;\r\nend;\r\n\r\ndestructor TJvXPStyleManager.Destroy;\r\nbegin\r\n InvalidateControls;\r\n FControls.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvXPStyleManager.InvalidateControls;\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := 0 to FControls.Count - 1 do\r\n with TJvXPCustomControl(FControls[I]) do\r\n InternalRedraw;\r\nend;\r\n\r\nprocedure TJvXPStyleManager.SetTheme(Value: TJvXPTheme);\r\nbegin\r\n if Value <> FTheme then\r\n begin\r\n FTheme := Value;\r\n if Assigned(FOnThemeChanged) then\r\n FOnThemeChanged(Self);\r\n InvalidateControls;\r\n end;\r\nend;\r\n\r\nprocedure TJvXPStyleManager.RegisterControls(const AControls: array of TJvXPCustomControl);\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := Low(AControls) to High(AControls) do\r\n if FControls.IndexOf(AControls[I]) = -1 then\r\n FControls.Add(AControls[I]);\r\nend;\r\n\r\nprocedure TJvXPStyleManager.UnregisterControls(const AControls: array of TJvXPCustomControl);\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := Low(AControls) to High(AControls) do\r\n if FControls.IndexOf(AControls[I]) <> -1 then\r\n FControls.Delete(FControls.IndexOf(AControls[I]));\r\nend;\r\n\r\n//=== { TJvXPCustomStyleControl } ============================================\r\n\r\nconstructor TJvXPCustomStyleControl.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FStyle := TJvXPStyle.Create(Self);\r\n FStyleManager := nil;\r\nend;\r\n\r\ndestructor TJvXPCustomStyleControl.Destroy;\r\nbegin\r\n if FStyleManager <> nil then\r\n FStyleManager.UnregisterControls([Self]);\r\n FStyle.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvXPCustomStyleControl.Notification(AComponent: TComponent;\r\n Operation: TOperation);\r\nbegin\r\n inherited Notification(AComponent, Operation);\r\n if (AComponent is TJvXPStyleManager) and (Operation = opRemove) then\r\n FStyleManager := nil;\r\nend;\r\n\r\nprocedure TJvXPCustomStyleControl.SetStyleManager(Value: TJvXPStyleManager);\r\nbegin\r\n if Value <> FStyleManager then\r\n begin\r\n if Value <> nil then\r\n Value.RegisterControls([Self])\r\n else if Assigned(FStyleManager) then\r\n FStyleManager.UnregisterControls([Self]);\r\n ReplaceComponentReference(Self, Value, TComponent(FStyleManager));\r\n InternalRedraw;\r\n end;\r\nend;\r\n\r\n//=== { TJvXPGradient } ======================================================\r\n\r\nconstructor TJvXPGradient.Create(AOwner: TControl);\r\nbegin\r\n inherited Create;\r\n Parent := TJvXPCustomControl(AOwner);\r\n Bitmap := TBitmap.Create;\r\n FColors := 16;\r\n FDithered := True;\r\n FEnabled := False;\r\n FEndColor := clSilver;\r\n FGradientStyle := gsLeft;\r\n FStartColor := clGray;\r\nend;\r\n\r\ndestructor TJvXPGradient.Destroy;\r\nbegin\r\n Bitmap.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvXPGradient.RecreateBands;\r\nbegin\r\n if Assigned(Bitmap) then\r\n JvXPCreateGradientRect(Parent.Width, Parent.Height, FStartColor, FEndColor,\r\n FColors, FGradientStyle, FDithered, Bitmap);\r\nend;\r\n\r\nprocedure TJvXPGradient.SetDithered(Value: Boolean);\r\nbegin\r\n if FDithered <> Value then\r\n begin\r\n FDithered := Value;\r\n RecreateBands;\r\n Parent.InternalRedraw;\r\n end;\r\nend;\r\n\r\nprocedure TJvXPGradient.SetColors(Value: TJvXPGradientColors);\r\nbegin\r\n if FColors <> Value then\r\n begin\r\n FColors := Value;\r\n RecreateBands;\r\n Parent.InternalRedraw;\r\n end;\r\nend;\r\n\r\nprocedure TJvXPGradient.SetEnabled(Value: Boolean);\r\nbegin\r\n if FEnabled <> Value then\r\n begin\r\n FEnabled := Value;\r\n Parent.InternalRedraw;\r\n end;\r\nend;\r\n\r\nprocedure TJvXPGradient.SetEndColor(Value: TColor);\r\nbegin\r\n if FEndColor <> Value then\r\n begin\r\n FEndColor := Value;\r\n RecreateBands;\r\n Parent.InternalRedraw;\r\n end;\r\nend;\r\n\r\nprocedure TJvXPGradient.SetGradientStyle(Value: TJvXPGradientStyle);\r\nbegin\r\n if FGradientStyle <> Value then\r\n begin\r\n FGradientStyle := Value;\r\n RecreateBands;\r\n Parent.InternalRedraw;\r\n end;\r\nend;\r\n\r\nprocedure TJvXPGradient.SetStartColor(Value: TColor);\r\nbegin\r\n if FStartColor <> Value then\r\n begin\r\n FStartColor := Value;\r\n RecreateBands;\r\n Parent.InternalRedraw;\r\n end;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvXPCoreUtils.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvXPCoreUtils.PAS, released on 2004-01-01.\r\n\r\nThe Initial Developer of the Original Code is Marc Hoffman.\r\nPortions created by Marc Hoffman are Copyright (C) 2002 APRIORI business solutions AG.\r\nPortions created by APRIORI business solutions AG are Copyright (C) 2002 APRIORI business solutions AG\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvXPCoreUtils.pas 13415 2012-09-10 09:51:54Z obones $\r\n\r\nunit JvXPCoreUtils;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n SysUtils, Classes, Windows, Graphics, Controls,\r\n JvJCLUtils, JvXPCore;\r\n\r\nfunction JvXPMethodsEqual(const Method1, Method2: TMethod): Boolean;\r\nprocedure JvXPDrawLine(const ACanvas: TCanvas; const X1, Y1, X2, Y2: Integer);\r\nprocedure JvXPCreateGradientRect(const AWidth, AHeight: Integer; const StartColor,\r\n EndColor: TColor; const Colors: TJvXPGradientColors; const Style: TJvXPGradientStyle;\r\n const Dithered: Boolean; var Bitmap: TBitmap);\r\nprocedure JvXPAdjustBoundRect(const BorderWidth: Byte;\r\n const ShowBoundLines: Boolean; const BoundLines: TJvXPBoundLines; var Rect: TRect);\r\nprocedure JvXPDrawBoundLines(const ACanvas: TCanvas; const BoundLines: TJvXPBoundLines;\r\n const AColor: TColor; const Rect: TRect);\r\n\r\n//\r\n// attic!\r\n//\r\n\r\nprocedure JvXPConvertToGray2(Bitmap: TBitmap);\r\nprocedure JvXPRenderText(const AParent: TControl; const ACanvas: TCanvas;\r\n ACaption: TCaption; const AFont: TFont; const AEnabled, AShowAccelChar: Boolean;\r\n var ARect: TRect; AFlags: Integer);\r\nprocedure JvXPFrame3D(const ACanvas: TCanvas; const Rect: TRect;\r\n const TopColor, BottomColor: TColor; const Swapped: Boolean = False);\r\nprocedure JvXPColorizeBitmap(Bitmap: TBitmap; const AColor: TColor);\r\nprocedure JvXPSetDrawFlags(const AAlignment: TAlignment; const AWordWrap: Boolean;\r\n var Flags: Integer);\r\nprocedure JvXPPlaceText(const AParent: TControl; const ACanvas: TCanvas;\r\n const AText: TCaption; const AFont: TFont; const AEnabled, AShowAccelChar: Boolean;\r\n const AAlignment: TAlignment; const AWordWrap: Boolean; var Rect: TRect);\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvXPCoreUtils.pas $';\r\n Revision: '$Revision: 13415 $';\r\n Date: '$Date: 2012-09-10 11:51:54 +0200 (lun. 10 sept. 2012) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n Types;\r\n\r\nfunction JvXPMethodsEqual(const Method1, Method2: TMethod): Boolean;\r\nbegin\r\n Result := (Method1.Code = Method2.Code) and (Method1.Data = Method2.Data);\r\nend;\r\n\r\nprocedure JvXPCreateGradientRect(const AWidth, AHeight: Integer; const StartColor,\r\n EndColor: TColor; const Colors: TJvXPGradientColors; const Style: TJvXPGradientStyle;\r\n const Dithered: Boolean; var Bitmap: TBitmap);\r\nconst\r\n PixelCountMax = 32768;\r\n DitherDepth = 16;\r\ntype\r\n TGradientBand = array [0..255] of TColor;\r\n TRGBMap = packed record\r\n case Boolean of\r\n True:\r\n (RGBVal: DWord);\r\n False:\r\n (R, G, B, D: Byte);\r\n end;\r\n PRGBTripleArray = ^TRGBTripleArray;\r\n TRGBTripleArray = array [0..PixelCountMax-1] of TRGBTriple;\r\nvar\r\n iLoop, xLoop, yLoop, XX, YY: Integer;\r\n iBndS, iBndE: Integer;\r\n GBand: TGradientBand;\r\n Row: PRGBTripleArray;\r\n\r\n procedure CalculateGradientBand;\r\n var\r\n rR, rG, rB: Real;\r\n lCol, hCol: TRGBMap;\r\n iStp: Integer;\r\n begin\r\n if Style in [gsLeft, gsTop] then\r\n begin\r\n lCol.RGBVal := ColorToRGB(StartColor);\r\n hCol.RGBVal := ColorToRGB(EndColor);\r\n end\r\n else\r\n begin\r\n lCol.RGBVal := ColorToRGB(EndColor);\r\n hCol.RGBVal := ColorToRGB(StartColor);\r\n end;\r\n rR := (hCol.R - lCol.R) / (Colors - 1);\r\n rG := (hCol.G - lCol.G) / (Colors - 1);\r\n rB := (hCol.B - lCol.B) / (Colors - 1);\r\n for iStp := 0 to (Colors - 1) do\r\n GBand[iStp] := RGB(\r\n lCol.R + Round(rR * iStp),\r\n lCol.G + Round(rG * iStp),\r\n lCol.B + Round(rB * iStp));\r\n end;\r\n\r\nbegin\r\n // Exit if Height or Width are not positive. If not, the calls would lead to\r\n // GDI errors about \"Invalid parameter\" and/or \"Out Of Resources\".\r\n if (AHeight <= 0) or (AWidth <= 0) then\r\n Exit;\r\n\r\n Bitmap.Height := AHeight;\r\n Bitmap.Width := AWidth;\r\n\r\n Bitmap.PixelFormat := pf24bit;\r\n\r\n CalculateGradientBand;\r\n\r\n with Bitmap.Canvas do\r\n begin\r\n {$IFDEF LINUX}\r\n Start; // required for Linux, but causes AV under windows\r\n {$ENDIF LINUX}\r\n Brush.Color := StartColor;\r\n FillRect(Bounds(0, 0, AWidth, AHeight));\r\n if Style in [gsLeft, gsRight] then\r\n begin\r\n for iLoop := 0 to Colors - 1 do\r\n begin\r\n iBndS := MulDiv(iLoop, AWidth, Colors);\r\n iBndE := MulDiv(iLoop + 1, AWidth, Colors);\r\n Brush.Color := GBand[iLoop];\r\n PatBlt(Handle, iBndS, 0, iBndE, AHeight, PATCOPY);\r\n if (iLoop > 0) and Dithered then\r\n for yLoop := 0 to DitherDepth - 1 do\r\n if yLoop < AHeight then\r\n begin\r\n Row := Bitmap.ScanLine[yLoop];\r\n for xLoop := 0 to AWidth div (Colors - 1) do\r\n begin\r\n XX := iBndS + Random(xLoop);\r\n if (XX < AWidth) and (XX > -1) then\r\n with Row[XX] do\r\n begin\r\n rgbtRed := GetRValue(GBand[iLoop - 1]);\r\n rgbtGreen := GetGValue(GBand[iLoop - 1]);\r\n rgbtBlue := GetBValue(GBand[iLoop - 1]);\r\n end;\r\n end;\r\n end;\r\n end;\r\n for yLoop := 1 to AHeight div DitherDepth do\r\n CopyRect(Bounds(0, yLoop * DitherDepth, AWidth, DitherDepth),\r\n Bitmap.Canvas, Bounds(0, 0, AWidth, DitherDepth));\r\n end\r\n else\r\n begin\r\n for iLoop := 0 to Colors - 1 do\r\n begin\r\n iBndS := MulDiv(iLoop, AHeight, Colors);\r\n iBndE := MulDiv(iLoop + 1, AHeight, Colors);\r\n Brush.Color := GBand[iLoop];\r\n PatBlt(Handle, 0, iBndS, AWidth, iBndE, PATCOPY);\r\n if (iLoop > 0) and Dithered then\r\n for yLoop := 0 to AHeight div (Colors - 1) do\r\n begin\r\n YY := iBndS + Random(yLoop);\r\n if (YY < AHeight) and (YY > -1) then\r\n begin\r\n Row := Bitmap.ScanLine[YY];\r\n for xLoop := 0 to DitherDepth - 1 do\r\n if xLoop < AWidth then\r\n with Row[xLoop] do\r\n begin\r\n rgbtRed := GetRValue(GBand[iLoop - 1]);\r\n rgbtGreen := GetGValue(GBand[iLoop - 1]);\r\n rgbtBlue := GetBValue(GBand[iLoop - 1]);\r\n end;\r\n end;\r\n end;\r\n end;\r\n for xLoop := 0 to AWidth div DitherDepth do\r\n CopyRect(Bounds(xLoop * DitherDepth, 0, DitherDepth, AHeight),\r\n Bitmap.Canvas, Bounds(0, 0, DitherDepth, AHeight));\r\n end;\r\n {$IFDEF LINUX}\r\n Stop; // required for Linux, but causes AV under windows\r\n {$ENDIF LINUX}\r\n end;\r\nend;\r\n\r\nprocedure JvXPDrawLine(const ACanvas: TCanvas; const X1, Y1, X2, Y2: Integer);\r\nbegin\r\n with ACanvas do\r\n begin\r\n MoveTo(X1, Y1);\r\n LineTo(X2, Y2);\r\n end;\r\nend;\r\n\r\nprocedure JvXPAdjustBoundRect(const BorderWidth: Byte;\r\n const ShowBoundLines: Boolean; const BoundLines: TJvXPBoundLines;\r\n var Rect: TRect);\r\nbegin\r\n InflateRect(Rect, -BorderWidth, -BorderWidth);\r\n if not ShowBoundLines then\r\n Exit;\r\n if blLeft in BoundLines then\r\n Inc(Rect.Left);\r\n if blRight in BoundLines then\r\n Dec(Rect.Right);\r\n if blTop in BoundLines then\r\n Inc(Rect.Top);\r\n if blBottom in BoundLines then\r\n Dec(Rect.Bottom);\r\nend;\r\n\r\nprocedure JvXPDrawBoundLines(const ACanvas: TCanvas; const BoundLines: TJvXPBoundLines;\r\n const AColor: TColor; const Rect: TRect);\r\nbegin\r\n with ACanvas do\r\n begin\r\n Pen.Color := AColor;\r\n Pen.Style := psSolid;\r\n if blLeft in BoundLines then\r\n JvXPDrawLine(ACanvas, Rect.Left, Rect.Top, Rect.Left, Rect.Bottom - 1);\r\n if blTop in BoundLines then\r\n JvXPDrawLine(ACanvas, Rect.Left, Rect.Top, Rect.Right, Rect.Top);\r\n if blRight in BoundLines then\r\n JvXPDrawLine(ACanvas, Rect.Right - 1, Rect.Top, Rect.Right - 1, Rect.Bottom - 1);\r\n if blBottom in BoundLines then\r\n JvXPDrawLine(ACanvas, Rect.Top, Rect.Bottom - 1, Rect.Right, Rect.Bottom - 1);\r\n end;\r\nend;\r\n\r\n//\r\n// attic\r\n//\r\n\r\nprocedure JvXPConvertToGray2(Bitmap: TBitmap);\r\nvar\r\n x, y, c: Integer;\r\n PxlColor: TColor;\r\nbegin\r\n for x := 0 to Bitmap.Width - 1 do\r\n for y := 0 to Bitmap.Height - 1 do\r\n begin\r\n PxlColor := ColorToRGB(Bitmap.Canvas.Pixels[x, y]);\r\n c := (PxlColor shr 16 + ((PxlColor shr 8) and $00FF) + PxlColor and $0000FF) div 3 + 100;\r\n if c > 255 then\r\n c := 255;\r\n Bitmap.Canvas.Pixels[x, y] := RGB(c, c, c);\r\n end;\r\nend;\r\n\r\nprocedure JvXPRenderText(const AParent: TControl; const ACanvas: TCanvas;\r\n ACaption: TCaption; const AFont: TFont; const AEnabled, AShowAccelChar: Boolean;\r\n var ARect: TRect; AFlags: Integer);\r\n\r\n procedure DoDrawText;\r\n begin\r\n DrawText(ACanvas, ACaption, -1, ARect, AFlags);\r\n end;\r\n\r\nbegin\r\n if (AFlags and DT_CALCRECT <> 0) and ((ACaption = '') or AShowAccelChar and\r\n (ACaption[1] = '&') and (ACaption[2] = #0)) then\r\n ACaption := ACaption + ' ';\r\n if not AShowAccelChar then\r\n AFlags := AFlags or DT_NOPREFIX;\r\n AFlags := AParent.DrawTextBiDiModeFlags(AFlags);\r\n with ACanvas do\r\n begin\r\n Font.Assign(AFont);\r\n if not AEnabled then\r\n Font.Color := dxColor_Msc_Dis_Caption_WXP;\r\n if not AEnabled then\r\n begin\r\n OffsetRect(ARect, 1, 1);\r\n Font.Color := clBtnHighlight;\r\n DoDrawText;\r\n OffsetRect(ARect, -1, -1);\r\n Font.Color := clBtnShadow;\r\n DoDrawText;\r\n end\r\n else\r\n DoDrawText;\r\n end;\r\nend;\r\n\r\nprocedure JvXPFrame3D(const ACanvas: TCanvas; const Rect: TRect;\r\n const TopColor, BottomColor: TColor; const Swapped: Boolean = False);\r\nvar\r\n ATopColor, ABottomColor: TColor;\r\nbegin\r\n ATopColor := TopColor;\r\n ABottomColor := BottomColor;\r\n if Swapped then\r\n begin\r\n ATopColor := BottomColor;\r\n ABottomColor := TopColor;\r\n end;\r\n with ACanvas do\r\n begin\r\n Pen.Color := ATopColor;\r\n Polyline([Point(Rect.Left, Rect.Bottom - 1),\r\n Point(Rect.Left, Rect.Top), Point(Rect.Right - 1, Rect.Top)]);\r\n Pen.Color := ABottomColor;\r\n Polyline([Point(Rect.Right - 1, Rect.Top + 1),\r\n Point(Rect.Right - 1 , Rect.Bottom - 1), Point(Rect.Left, Rect.Bottom - 1)]);\r\n end;\r\nend;\r\n\r\nprocedure JvXPColorizeBitmap(Bitmap: TBitmap; const AColor: TColor);\r\nvar\r\n ColorMap: TBitmap;\r\n Rect: TRect;\r\nbegin\r\n Rect := Bounds(0, 0, Bitmap.Width, Bitmap.Height);\r\n ColorMap := TBitmap.Create;\r\n try\r\n ColorMap.Assign(Bitmap);\r\n Bitmap.Dormant;\r\n Bitmap.FreeImage;\r\n with ColorMap.Canvas do\r\n begin\r\n Brush.Color := AColor;\r\n BrushCopy( Rect, Bitmap, Rect, clBlack);\r\n end;\r\n Bitmap.Assign(ColorMap);\r\n finally\r\n ColorMap.Free;\r\n end;\r\nend;\r\n\r\nprocedure JvXPSetDrawFlags(const AAlignment: TAlignment; const AWordWrap: Boolean;\r\n var Flags: Integer);\r\nbegin\r\n Flags := DT_END_ELLIPSIS;\r\n case AAlignment of\r\n taLeftJustify:\r\n Flags := Flags or DT_LEFT;\r\n taCenter:\r\n Flags := Flags or DT_CENTER;\r\n taRightJustify:\r\n Flags := Flags or DT_RIGHT;\r\n end;\r\n if not AWordWrap then\r\n Flags := Flags or DT_SINGLELINE\r\n else\r\n Flags := Flags or DT_WORDBREAK;\r\nend;\r\n\r\nprocedure JvXPPlaceText(const AParent: TControl; const ACanvas: TCanvas; const AText: TCaption;\r\n const AFont: TFont; const AEnabled, AShowAccelChar: Boolean; const AAlignment: TAlignment;\r\n const AWordWrap: Boolean; var Rect: TRect);\r\nvar\r\n Flags, DX, OH, OW: Integer;\r\nbegin\r\n OH := Rect.Bottom - Rect.Top;\r\n OW := Rect.Right - Rect.Left;\r\n JvXPSetDrawFlags(AAlignment, AWordWrap, Flags);\r\n JvXPRenderText(AParent, ACanvas, AText, AFont, AEnabled, AShowAccelChar, Rect,\r\n Flags or DT_CALCRECT);\r\n if AAlignment = taRightJustify then\r\n DX := OW - (Rect.Right + Rect.Left)\r\n else\r\n if AAlignment = taCenter then\r\n DX := (OW - Rect.Right) div 2\r\n else\r\n DX := 0;\r\n OffsetRect(Rect, DX, (OH - Rect.Bottom) div 2);\r\n JvXPRenderText(AParent, ACanvas, AText, AFont, AEnabled, AShowAccelChar, Rect, Flags);\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvXPProgressBar.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvXPProgress.PAS, released on 2004-04-05.\r\n\r\nThe Initial Developer of the Original Code is Stefano Pessina [stefano dott pessina sanbiagiomonza dott it]\r\nPortions created by Stefano Pessina are Copyright (C) 2004 Stefano Pessina.\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\n\r\nLast Modified: 2004-04-07\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n\r\n{$I jvcl.inc}\r\n\r\nunit JvXPProgressBar;\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, SysUtils, Classes, Graphics,\r\n JvProgressBar;\r\n\r\ntype\r\n TJvCustomXPProgressBar = class(TJvBaseGradientProgressBar)\r\n private\r\n procedure DrawBlock(ACanvas: TCanvas; ARect: TRect);\r\n protected\r\n procedure DrawLine(ACanvas: TCanvas; X1, Y1, X2, Y2, AColor: TColor);\r\n procedure DrawBar(ACanvas: TCanvas; BarSize: Integer); override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n end;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvXPProgressBar = class(TJvCustomXPProgressBar)\r\n published\r\n property BarColorFrom default $31D329;\r\n property BarColorTo default $ADEFAD;\r\n property Max;\r\n property Min;\r\n property Orientation;\r\n property Position;\r\n property Smooth;\r\n\r\n property Align;\r\n property Anchors;\r\n property Color default clWindow;\r\n property Constraints;\r\n property DragCursor;\r\n property DragKind;\r\n property OnCanResize;\r\n property OnEndDock;\r\n property OnStartDock;\r\n property DragMode;\r\n property Enabled;\r\n property Hint;\r\n property ParentColor default False;\r\n property PopupMenu;\r\n property ParentShowHint;\r\n property ShowHint;\r\n property Visible;\r\n\r\n property OnClick;\r\n property OnConstrainedResize;\r\n property OnContextPopup;\r\n property OnDblClick;\r\n property OnDragDrop;\r\n property OnDragOver;\r\n property OnEndDrag;\r\n property OnMouseDown;\r\n property OnMouseMove;\r\n property OnMouseUp;\r\n property OnMouseWheel;\r\n property OnMouseWheelDown;\r\n property OnMouseWheelUp;\r\n property OnStartDrag;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvXPProgressBar.pas $';\r\n Revision: '$Revision: 13104 $';\r\n Date: '$Date: 2011-09-07 08:50:43 +0200 (mer. 07 sept. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n Controls, Forms, ComCtrls,\r\n JvJVCLUtils, JvJCLUtils;\r\n\r\n//=== { TJvXPProgressBar } ===================================================\r\n\r\nconstructor TJvCustomXPProgressBar.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n Steps := 7;\r\n ParentColor := False;\r\n Color := clWindow;\r\n BarColorFrom := $31D329;\r\n BarColorTo := $ADEFAD;\r\nend;\r\n\r\nprocedure TJvCustomXPProgressBar.DrawLine(ACanvas: TCanvas; X1, Y1, X2, Y2, AColor: TColor);\r\nbegin\r\n ACanvas.Pen.Color := AColor;\r\n ACanvas.MoveTo(X1, Y1);\r\n ACanvas.LineTo(X2, Y2);\r\nend;\r\n\r\nprocedure TJvCustomXPProgressBar.DrawBlock(ACanvas: TCanvas; ARect: TRect);\r\nvar\r\n ARect2: TRect;\r\nbegin\r\n ARect2 := ARect;\r\n if Orientation = pbHorizontal then\r\n begin\r\n Inc(ARect2.Top, RectHeight(ARect) div 2);\r\n Dec(ARect.Bottom, RectHeight(ARect) div 2);\r\n GradientFillRect(ACanvas, ARect, BarColorFrom, BarColorTo, fdBottomToTop, 255);\r\n GradientFillRect(ACanvas, ARect2, BarColorTo, BarColorFrom, fdBottomToTop, 255);\r\n end\r\n else\r\n begin\r\n Inc(ARect2.Left, RectWidth(ARect) div 2);\r\n Dec(ARect.Right, RectWidth(ARect) div 2);\r\n GradientFillRect(ACanvas, ARect, BarColorFrom, BarColorTo, fdRightToLeft, 255);\r\n GradientFillRect(ACanvas, ARect2, BarColorTo, BarColorFrom, fdRightToLeft, 255);\r\n end;\r\nend;\r\n\r\ntype\r\n TWinControlAccessProtected = class(TWinControl);\r\n\r\nprocedure TJvCustomXPProgressBar.DrawBar(ACanvas: TCanvas; BarSize: Integer);\r\nconst\r\n cColor1 = $BEBEBE;\r\n cColor2 = $686868;\r\n cColor3 = $EFEFEF;\r\nvar\r\n X, Y: Integer;\r\n R: TRect;\r\n Bmp: TBitmap;\r\n AColor: TColor;\r\n LBlockSize: Integer;\r\nbegin\r\n if Parent <> nil then\r\n AColor := TWinControlAccessProtected(Parent).Color\r\n else\r\n if GetParentForm(Self) <> nil then\r\n AColor := GetParentForm(Self).Color\r\n else\r\n AColor := clBtnFace;\r\n Bmp := TBitmap.Create;\r\n try\r\n Bmp.Width := Width;\r\n Bmp.Height := Height;\r\n Bmp.Canvas.Brush.Color := clFuchsia;\r\n R := ClientRect;\r\n Bmp.Canvas.FillRect(R);\r\n InflateRect(R, -3, -2);\r\n Bmp.Canvas.Brush.Color := Color;\r\n Bmp.Canvas.FillRect(R);\r\n\r\n // draw the frame\r\n // left side\r\n X := 0;\r\n DrawLine(Bmp.Canvas, X, 1, X, Height - 1, cColor1);\r\n DrawLine(Bmp.Canvas, X, 2, X, Height - 2, cColor2);\r\n\r\n // right side\r\n X := Width - 1;\r\n DrawLine(Bmp.Canvas, X, 1, X, Height - 1, cColor1);\r\n DrawLine(Bmp.Canvas, X, 2, X, Height - 2, cColor2);\r\n\r\n // left side\r\n X := 0;\r\n DrawLine(Bmp.Canvas, X, 1, X, Height - 1, cColor1);\r\n DrawLine(Bmp.Canvas, X, 2, X, Height - 2, cColor2);\r\n // right side\r\n X := Width - 1;\r\n DrawLine(Bmp.Canvas, X, 1, X, Height - 1, cColor1);\r\n DrawLine(Bmp.Canvas, X, 2, X, Height - 2, cColor2);\r\n\r\n // left side\r\n X := 1;\r\n DrawLine(Bmp.Canvas, X, 0, X, Height, cColor1);\r\n DrawLine(Bmp.Canvas, X, 1, X, Height - 1, cColor2);\r\n DrawLine(Bmp.Canvas, X, 2, X, Height - 2, cColor1);\r\n // right side\r\n X := Width - 2;\r\n DrawLine(Bmp.Canvas, X, 0, X, Height, cColor1);\r\n DrawLine(Bmp.Canvas, X, 1, X, Height - 1, cColor2);\r\n DrawLine(Bmp.Canvas, X, 2, X, Height - 2, cColor1);\r\n\r\n // left side\r\n X := 2;\r\n DrawLine(Bmp.Canvas, X, 0, X, Height, cColor2);\r\n DrawLine(Bmp.Canvas, X, 1, X, Height - 1, cColor1);\r\n DrawLine(Bmp.Canvas, X, 3, X, Height - 1, cColor3);\r\n // right side\r\n X := Width - 3;\r\n DrawLine(Bmp.Canvas, X, 0, X, Height, cColor2);\r\n DrawLine(Bmp.Canvas, X, 1, X, Height - 1, cColor1);\r\n DrawLine(Bmp.Canvas, X, 3, X, Height - 1, cColor3);\r\n\r\n // top side\r\n Y := 0;\r\n DrawLine(Bmp.Canvas, 3, Y, Width - 3, Y, cColor2);\r\n DrawLine(Bmp.Canvas, 3, Y + 1, Width - 3, Y + 1, cColor1);\r\n DrawLine(Bmp.Canvas, 3, Y + 2, Width - 3, Y + 2, cColor3);\r\n\r\n // bottom side\r\n Y := Height - 1;\r\n DrawLine(Bmp.Canvas, 3, Y, Width - 2, Y, cColor2);\r\n DrawLine(Bmp.Canvas, 3, Y - 1, Width - 3, Y - 1, cColor3);\r\n\r\n // draw the blocks\r\n LBlockSize := BlockSize - 3;\r\n if Orientation = pbHorizontal then\r\n begin\r\n if Smooth then\r\n begin\r\n R.Right := R.Left + BarSize;\r\n InflateRect(R, -1, -1);\r\n if R.Right > Width - 3 then\r\n R.Right := Width - 3;\r\n if R.Right > R.Left then\r\n DrawBlock(Bmp.Canvas, R);\r\n end\r\n else\r\n begin\r\n R := Rect(2, 2, LBlockSize + 1, Height - 4);\r\n OffsetRect(R, 2, 1);\r\n while BarSize > 2 do\r\n begin\r\n if R.Right > Width - 3 then\r\n R.Right := Width - 3;\r\n if R.Right - R.Left > 0 then\r\n DrawBlock(Bmp.Canvas, R);\r\n OffsetRect(R, LBlockSize + 1, 0);\r\n Dec(BarSize, LBlockSize + 1);\r\n end;\r\n end;\r\n end\r\n else\r\n begin\r\n if Smooth then\r\n begin\r\n R.Top := R.Bottom - BarSize;\r\n if R.Top < 3 then\r\n R.Top := 3;\r\n InflateRect(R, -1, -1);\r\n DrawBlock(Bmp.Canvas, R);\r\n end\r\n else\r\n begin\r\n R := Rect(2, 2, Width - 4, LBlockSize + 1);\r\n OffsetRect(R, 1, 0);\r\n OffsetRect(R, 0, Height - LBlockSize - 4);\r\n while BarSize > 2 do\r\n begin\r\n if R.Top < 3 then\r\n R.Top := 3;\r\n if R.Bottom - R.Top > 0 then\r\n DrawBlock(Bmp.Canvas, R);\r\n OffsetRect(R, 0, -LBlockSize - 1);\r\n Dec(BarSize, LBlockSize + 1);\r\n end;\r\n end;\r\n end;\r\n ACanvas.Brush.Color := AColor;\r\n with ACanvas do\r\n BrushCopy( ClientRect, Bmp, ClientRect, clFuchsia);\r\n finally\r\n Bmp.Free;\r\n end;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvXmlDatabase.pas", "content": "\r\n\r\n{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvXMLDatabase.PAS, released on 2003-06-22.\r\n\r\nThe Initial Developer of the Original Code is S?stien Buysse [sbuysse att buypin dott com]\r\nPortions created by S?stien Buysse are Copyright (C) 2003 S?stien Buysse.\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n -You have to place the columns you test in the where clause in the select clause too\r\n -Where conditions *MUST* be enclosed between parenthesis as ... WHERE (Col = 5) AND (Col2 < Col3) ...\r\n -Update statements are limited to simple operations like ... SET Col1 = Col1 + 1, Col2 = 4 ...\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvXmlDatabase.pas 13104 2011-09-07 06:50:43Z obones $\r\n\r\nunit JvXmlDatabase;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n SysUtils, Classes, Contnrs, Math, DateUtils,\r\n JvTypes, JvComponentBase, JvSimpleXml;\r\n\r\ntype\r\n TJvXMLDatabase = class;\r\n TJvXMLQuery = class;\r\n TJvXMLQueryParser = class;\r\n TJvXMLDatabaseException = class(EJVCLException);\r\n\r\n TJvXMLTable = class(TObject)\r\n public\r\n XML: TJvSimpleXML;\r\n Locked: Boolean;\r\n FileName: string;\r\n end;\r\n\r\n TJvXMLQueryTable = class(TObject)\r\n public\r\n Name: string;\r\n Alias: string;\r\n constructor Create(const AValue: string);\r\n end;\r\n\r\n TJvXMLQueryColumn = class(TObject)\r\n public\r\n Name: string;\r\n Table: string;\r\n constructor Create(const AValue: string);\r\n end;\r\n\r\n TJvXMLOrderConvertion = (ocNone, ocDate, ocInteger, ocFloat);\r\n\r\n TJvXMLQueryOrder = class(TObject)\r\n public\r\n Column: string;\r\n Ascending: Boolean;\r\n Convertion: TJvXMLOrderConvertion;\r\n constructor Create(const AValue: string);\r\n end;\r\n\r\n TJvXMLSQLOperator = (opEquals, opGreater, opSmaller, opGreaterEquals,\r\n opSmallerEquals, opLike, opNot, opOr, opAnd, opXor, opLeftParenthesis,\r\n opRightParenthesis, opConstant, opColumn, opNull, opNone);\r\n\r\n TJvXMLQueryCondition = class(TObject)\r\n public\r\n Condition: string;\r\n SQLOperator: TJvXMLSQLOperator;\r\n constructor Create(AOperator: TJvXMLSQLOperator; const ACondition: string = '');\r\n end;\r\n\r\n TJvXMLSetKind = (skConstant, skColumn);\r\n TJvXMLSetOperator = (soNone, soAdd, soMultiply, soDivide, soSubstract);\r\n\r\n TJvXMLQueryAssignement = class(TObject)\r\n public\r\n Column: string;\r\n ValueKind: TJvXMLSetKind;\r\n SecondKind: TJvXMLSetKind;\r\n SetOperator: TJvXMLSetOperator;\r\n Value: string;\r\n SecondValue: string;\r\n constructor Create(AValue: string);\r\n procedure UpdateElem(AElement: TJvSimpleXMLElem);\r\n end;\r\n\r\n TJvXMLInstruction = (xiSelect, xiUpdate, xiInsert, xiDelete);\r\n TJvXMLQueryParser = class(TObject)\r\n private\r\n FQuery: string;\r\n FTables: TObjectList;\r\n FColumns: TObjectList;\r\n FConditions: TObjectList;\r\n FOrders: TObjectList;\r\n FInstruction: TJvXMLInstruction;\r\n FInstructionStr: string;\r\n FTablesStr: string;\r\n FWhereStr: string;\r\n FColumnsStr: string;\r\n FLimitStr: string;\r\n FLimitBegin: Integer;\r\n FLimitCount: Integer;\r\n FOrderStr: string;\r\n FSetStr: string;\r\n FOrderTable: TJvSimpleXMLElem;\r\n FUpdates: TObjectList;\r\n FValuesStr: string;\r\n FValues: TStringList;\r\n function GetColumn(const AIndex: Integer): TJvXMLQueryColumn;\r\n function GetTable(const AIndex: Integer): TJvXMLQueryTable;\r\n function GetColumnsCount: Integer;\r\n function GetTablesCount: Integer;\r\n function GetCondition(const AIndex: Integer): TJvXMLQueryCondition;\r\n function GetConditionsCount: Integer;\r\n function OrderCallBack(Elems: TJvSimpleXMLElems; Index1, Index2: Integer): Integer;\r\n function GetValue(const AIndex: Integer): string;\r\n function GetValuesCount: Integer;\r\n protected\r\n function ReadToken: string;\r\n function ReadColumns(const AEndStatement: array of string; ACanTerminate: Boolean): string;\r\n function ReadTables(const AEndStatement: array of string): string;\r\n function ReadWhere(const AEndStatement: array of string): string;\r\n function ReadLimit(const AEndStatement: array of string): string;\r\n function ReadOrderBy(const AEndStatement: array of string): string;\r\n function ReadSet(const AEndStatement: array of string): string;\r\n function ReadValues(const AEndStatement: array of string): string;\r\n function ReadStatement(const AEndStatement: array of string;\r\n ACanTerminate: Boolean; var AValue: string): string;\r\n procedure DoValidateInstruction;\r\n procedure DoValidateColumns;\r\n procedure DoValidateTables;\r\n procedure DoValidateWhere;\r\n procedure DoValidateOrderBy;\r\n procedure DoValidateSet;\r\n procedure DoValidateValues;\r\n public\r\n constructor Create;\r\n destructor Destroy; override;\r\n procedure Parse(const AQuery: string);\r\n function CheckConditions(AXMLElem: TJvSimpleXMLElem): Boolean;\r\n procedure LimitTable(var ATable: TJvSimpleXMLElem);\r\n procedure OrderTable(var ATable: TJvSimpleXMLElem);\r\n procedure UpdateRow(ARow: TJvSimpleXMLElem);\r\n property Instruction: TJvXMLInstruction read FInstruction write FInstruction;\r\n property Tables[const AIndex: Integer]: TJvXMLQueryTable read GetTable;\r\n property TablesCount: Integer read GetTablesCount;\r\n property Columns[const AIndex: Integer]: TJvXMLQueryColumn read GetColumn;\r\n property ColumnsCount: Integer read GetColumnsCount;\r\n property Condition[const AIndex: Integer]: TJvXMLQueryCondition read GetCondition;\r\n property ConditionsCount: Integer read GetConditionsCount;\r\n property Value[const AIndex: Integer]: string read GetValue;\r\n property ValuesCount: Integer read GetValuesCount;\r\n end;\r\n\r\n TJvXMLQuery = class(TObject)\r\n private\r\n FParser: TJvXMLQueryParser;\r\n FDatabase: TJvXMLDatabase;\r\n FResults: TJvSimpleXMLElem;\r\n FTables: TList;\r\n FLastId: Integer;\r\n protected\r\n procedure Query(const AQuery: string);\r\n public\r\n constructor Create(AOwner: TJvXMLDatabase);\r\n destructor Destroy; override;\r\n\r\n property Results: TJvSimpleXMLElem read FResults;\r\n property LastId: Integer read FLastId;\r\n end;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64 or pidOSX32)]\r\n {$ENDIF RTL230_UP}\r\n TJvXMLDatabase = class(TJvComponent)\r\n private\r\n FTablesPath: string;\r\n FTables: TObjectList;\r\n protected\r\n function GetTable(const AName: string): TJvSimpleXML;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n published\r\n procedure SaveTables;\r\n function Query(const AQuery: string): TJvXMLQuery;\r\n property TablesPath: string read FTablesPath write FTablesPath;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvXmlDatabase.pas $';\r\n Revision: '$Revision: 13104 $';\r\n Date: '$Date: 2011-09-07 08:50:43 +0200 (mer. 07 sept. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n {$IFDEF SUPPORTS_INLINE}\r\n Windows,\r\n {$ENDIF SUPPORTS_INLINE}\r\n JvJCLUtils, JvResources;\r\n\r\n//=== { TJvXMLDatabase } =====================================================\r\n\r\nconstructor TJvXMLDatabase.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FTables := TObjectList.Create;\r\nend;\r\n\r\ndestructor TJvXMLDatabase.Destroy;\r\nbegin\r\n FTables.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJvXMLDatabase.GetTable(const AName: string): TJvSimpleXML;\r\nvar\r\n I: Integer;\r\n St: string;\r\n LTable: TJvXMLTable;\r\nbegin\r\n St := TablesPath + AName;\r\n for I := 0 to FTables.Count-1 do\r\n if TJvXMLTable(FTables[I]).FileName = St then\r\n begin\r\n Result := TJvXMLTable(FTables[I]).XML;\r\n Exit;\r\n end;\r\n\r\n LTable := TJvXMLTable.Create;\r\n LTable.XML := TJvSimpleXML.Create(nil);\r\n LTable.XML.LoadFromFile(St);\r\n LTable.Locked := False;\r\n LTable.FileName := St;\r\n FTables.Add(LTable);\r\n Result := LTable.XML;\r\nend;\r\n\r\nfunction TJvXMLDatabase.Query(const AQuery: string): TJvXMLQuery;\r\nbegin\r\n Result := TJvXMLQuery.Create(Self);\r\n Result.Query(AQuery);\r\nend;\r\n\r\nprocedure TJvXMLDatabase.SaveTables;\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := 0 to FTables.Count-1 do\r\n TJvXMLTable(FTables[I]).XML.SaveToFile(TJvXMLTable(FTables[I]).FileName);\r\nend;\r\n\r\n//=== { TJvXMLQuery } ========================================================\r\n\r\nconstructor TJvXMLQuery.Create(AOwner: TJvXMLDatabase);\r\nbegin\r\n inherited Create;\r\n FDatabase := AOwner;\r\n FParser := TJvXMLQueryParser.Create;\r\n FResults := TJvSimpleXMLElemClassic.Create(nil);\r\n FTables := TList.Create;\r\nend;\r\n\r\ndestructor TJvXMLQuery.Destroy;\r\nbegin\r\n FParser.Free;\r\n FResults.Free;\r\n FTables.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvXMLQuery.Query(const AQuery: string);\r\nvar\r\n I, J, lMax: Integer;\r\n LElem: TJvSimpleXMLElemClassic;\r\n LValue: string;\r\n\r\n function IsColumnSelected(const ATable, AColumn: string): Boolean;\r\n var\r\n I: Integer;\r\n begin\r\n Result := False;\r\n for I := 0 to FParser.ColumnsCount-1 do\r\n if (FParser.Columns[I].Name = '*') or ((FParser.Columns[I].Name = AColumn) and\r\n ((FParser.Columns[I].Table = '') or (FParser.Columns[I].Table = ATable))) then\r\n begin\r\n Result := True;\r\n Break;\r\n end;\r\n end;\r\n\r\n procedure ConstructTable(AIndex: Integer; var AElem: TJvSimpleXMLElemClassic);\r\n var\r\n I, J: Integer;\r\n LElem: TJvSimpleXMLElemClassic;\r\n begin\r\n if AIndex >= FTables.Count then\r\n begin\r\n if FParser.CheckConditions(AElem) then\r\n FResults.Items.Add(AElem)\r\n else\r\n AElem.Free;\r\n end\r\n else\r\n with TJvSimpleXML(FTables[AIndex]) do\r\n for I := 0 to Root.Items.Count-1 do\r\n begin\r\n LElem := TJvSimpleXMLElemClassic.Create(nil);\r\n LElem.Assign(AElem);\r\n\r\n //Select columns to add\r\n for J := 0 to Root.Items[I].Properties.Count-1 do\r\n if IsColumnSelected(FParser.Tables[AIndex].Alias, Root.Items[I].Properties[J].Name) then\r\n LElem.Properties.Add(Root.Items[I].Properties[J].Name, Root.Items[I].Properties[J].Value);\r\n\r\n ConstructTable(AIndex + 1, LElem);\r\n end;\r\n end;\r\n\r\n procedure DeleteRows;\r\n var\r\n I, J: Integer;\r\n begin\r\n for I := 0 to FTables.Count-1 do\r\n for J := TJvSimpleXML(FTables[I]).Root.Items.Count-1 downto 0 do\r\n if FParser.CheckConditions(TJvSimpleXML(FTables[I]).Root.Items[J]) then\r\n TJvSimpleXML(FTables[I]).Root.Items.Delete(J);\r\n end;\r\n\r\n procedure UpdateRows;\r\n var\r\n I, J: Integer;\r\n begin\r\n for I := 0 to FTables.Count-1 do\r\n for J := TJvSimpleXML(FTables[I]).Root.Items.Count - 1 downto 0 do\r\n if FParser.CheckConditions(TJvSimpleXML(FTables[I]).Root.Items[J]) then\r\n FParser.UpdateRow(TJvSimpleXML(FTables[I]).Root.Items[J]);\r\n end;\r\n\r\nbegin\r\n //Parse\r\n FParser.Parse(AQuery);\r\n\r\n //Get all tables\r\n for I := 0 to FParser.TablesCount-1 do\r\n FTables.Add(FDatabase.GetTable(FParser.Tables[I].Name));\r\n\r\n //Execute\r\n case FParser.Instruction of\r\n xiSelect:\r\n begin\r\n LElem := TJvSimpleXMLElemClassic.Create(nil);\r\n LElem.Name := 'Item';\r\n FResults.Name := 'Results';\r\n ConstructTable(0, LElem);\r\n end;\r\n xiDelete:\r\n begin\r\n DeleteRows;\r\n FDatabase.SaveTables;\r\n end;\r\n xiUpdate:\r\n begin\r\n UpdateRows;\r\n FDatabase.SaveTables;\r\n end;\r\n xiInsert:\r\n begin\r\n if FTables.Count = 1 then\r\n with TJvSimpleXML(FTables[0]).Root.Items.Add('item') do\r\n for I := 0 to FParser.ColumnsCount-1 do\r\n if I < FParser.ValuesCount then\r\n begin\r\n LValue := FParser.Value[I];\r\n if LValue = 'NULL' then\r\n begin\r\n lMax := 0;\r\n for J := 0 to TJvSimpleXML(FTables[0]).Root.Items.Count-1 do\r\n lMax := Max(lMax, TJvSimpleXML(FTables[0]).Root.Items[J].Properties.IntValue(FParser.Columns[I].Name, 0));\r\n Inc(lMax);\r\n LValue := IntToStr(lMax);\r\n FLastId := lMax;\r\n end\r\n else\r\n if LValue = 'NOW' then\r\n LValue := DateTimeToStr(Now)\r\n else\r\n if LValue = 'DATE' then\r\n LValue := DateToStr(Now)\r\n else\r\n if LValue = 'TIME' then\r\n LValue := TimeToStr(Now);\r\n Properties.Add(FParser.Columns[I].Name, LValue);\r\n end;\r\n FDatabase.SaveTables;\r\n end;\r\n end;\r\n\r\n FParser.OrderTable(FResults);\r\n FParser.LimitTable(FResults);\r\nend;\r\n\r\n//=== { TJvXMLQueryParser } ==================================================\r\n\r\nconstructor TJvXMLQueryParser.Create;\r\nbegin\r\n inherited Create;\r\n FTables := TObjectList.Create;\r\n FColumns := TObjectList.Create;\r\n FConditions := TObjectList.Create;\r\n FOrders := TObjectList.Create;\r\n FUpdates := TObjectList.Create;\r\n FValues := TStringList.Create;\r\n FLimitBegin := 0;\r\n FLimitCount := MaxInt;\r\nend;\r\n\r\ndestructor TJvXMLQueryParser.Destroy;\r\nbegin\r\n FTables.Free;\r\n FColumns.Free;\r\n FConditions.Free;\r\n FOrders.Free;\r\n FUpdates.Free;\r\n FValues.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJvXMLQueryParser.CheckConditions(AXMLElem: TJvSimpleXMLElem): Boolean;\r\nvar\r\n I: Integer;\r\n\r\n function CheckCondition(var AIndex: Integer): Boolean;\r\n var\r\n LComp: TJvXMLSQLOperator;\r\n LValue, LValue2: string;\r\n LDate: TDateTime;\r\n begin\r\n Result := True;\r\n while AIndex < FConditions.Count do\r\n begin\r\n with TJvXMLQueryCondition(FConditions[AIndex]) do\r\n case SQLOperator of\r\n opLeftParenthesis:\r\n begin\r\n Inc(AIndex);\r\n Result := Result and (CheckCondition(AIndex));\r\n end;\r\n opRightParenthesis:\r\n Exit;\r\n opNot:\r\n begin\r\n Inc(AIndex);\r\n Result := Result and (not CheckCondition(AIndex));\r\n end;\r\n opColumn, opConstant:\r\n begin\r\n if SQLOperator = opConstant then\r\n LValue := Condition\r\n else\r\n begin\r\n if Condition = 'daysbetweennow' then\r\n begin\r\n Inc(AIndex, 2);\r\n LValue := AXMLElem.Properties.Value(TJvXMLQueryCondition(FConditions[AIndex]).Condition);\r\n Inc(AIndex);\r\n LDate := StrToDateTimeDef(LValue, 0);\r\n LValue := IntToStr(DaysBetween(Now, LDate));\r\n if LDate < Now then\r\n LValue := '-' + LValue;\r\n end\r\n else\r\n LValue := AXMLElem.Properties.Value(Condition);\r\n end;\r\n Inc(AIndex, 2);\r\n if AIndex >= FConditions.Count then\r\n begin\r\n Result := False;\r\n Exit;\r\n end;\r\n LComp := TJvXMLQueryCondition(FConditions[AIndex-1]).SQLOperator;\r\n\r\n if TJvXMLQueryCondition(FConditions[AIndex]).SQLOperator = opConstant then\r\n LValue2 := TJvXMLQueryCondition(FConditions[AIndex]).Condition\r\n else\r\n if TJvXMLQueryCondition(FConditions[AIndex]).SQLOperator = opColumn then\r\n begin\r\n LValue2 := TJvXMLQueryCondition(FConditions[AIndex]).Condition;\r\n if AXMLElem.Properties.ItemNamed[LValue2] <> nil then\r\n LValue2 := AXMLElem.Properties.Value(LValue2);\r\n end\r\n else\r\n if (TJvXMLQueryCondition(FConditions[AIndex]).SQLOperator = opNull) and (LComp = opEquals) then\r\n begin\r\n Result := Result and (LValue = '');\r\n LComp := opNone;\r\n end\r\n else\r\n begin\r\n Result := False;\r\n LComp := opNone;\r\n end;\r\n\r\n try\r\n case LComp of\r\n opEquals:\r\n Result := Result and (LValue = LValue2);\r\n opGreater:\r\n Result := Result and (StrToFloat(LValue) > StrToFloat(LValue2));\r\n opSmaller:\r\n Result := Result and (StrToFloat(LValue) < StrToFloat(LValue2));\r\n opGreaterEquals:\r\n Result := Result and (StrToFloat(LValue) >= StrToFloat(LValue2));\r\n opSmallerEquals:\r\n Result := Result and (StrToFloat(LValue) <= StrToFloat(LValue2));\r\n opLike:\r\n begin\r\n //Not implemented yet\r\n end;\r\n end;\r\n except\r\n Result := False;\r\n end;\r\n end;\r\n opOr:\r\n begin\r\n Inc(AIndex);\r\n Result := Result or CheckCondition(AIndex);\r\n end;\r\n opAnd:\r\n begin\r\n Inc(AIndex);\r\n Result := Result and CheckCondition(AIndex);\r\n end;\r\n opXor:\r\n begin\r\n Inc(AIndex);\r\n Result := Result xor CheckCondition(AIndex);\r\n end;\r\n end;\r\n Inc(AIndex);\r\n end;\r\n end;\r\n\r\nbegin\r\n I := 0;\r\n Result := CheckCondition(I);\r\nend;\r\n\r\nprocedure TJvXMLQueryParser.DoValidateColumns;\r\nvar\r\n I: Integer;\r\n LColumn: TJvXMLQueryColumn;\r\nbegin\r\n I := Pos(',', FColumnsStr);\r\n repeat\r\n if I <> 0 then\r\n begin\r\n LColumn := TJvXMLQueryColumn.Create(Trim(Copy(FColumnsStr, 1, I - 1)));\r\n FColumns.Add(LColumn);\r\n FColumnsStr := Trim(Copy(FColumnsStr, I + 1, MaxInt));\r\n I := Pos(',', FColumnsStr);\r\n end\r\n else\r\n if FColumnsStr <> '' then\r\n begin\r\n LColumn := TJvXMLQueryColumn.Create(Trim(FColumnsStr));\r\n FColumns.Add(LColumn);\r\n FColumnsStr := '';\r\n end;\r\n until FColumnsStr = '';\r\nend;\r\n\r\nprocedure TJvXMLQueryParser.DoValidateInstruction;\r\nbegin\r\n FInstructionStr := UpperCase(FInstructionStr);\r\n\r\n if FInstructionStr = 'SELECT' then\r\n FInstruction := xiSelect\r\n else\r\n if FInstructionStr = 'UPDATE' then\r\n FInstruction := xiUpdate\r\n else\r\n if FInstructionStr = 'INSERT' then\r\n FInstruction := xiInsert\r\n else\r\n if FInstructionStr = 'DELETE' then\r\n FInstruction := xiDelete\r\n else\r\n raise TJvXMLDatabaseException.CreateResFmt(@RsEUnknownInstruction, [FInstructionStr]);\r\nend;\r\n\r\nprocedure TJvXMLQueryParser.DoValidateOrderBy;\r\nvar\r\n I: Integer;\r\n LOrder: TJvXMLQueryOrder;\r\nbegin\r\n FOrderStr := Trim(UpperCase(FOrderStr));\r\n I := Pos(' ', FOrderStr);\r\n if I <> 0 then\r\n FOrderStr := Trim(Copy(FOrderStr, I + 1, MaxInt));\r\n\r\n I := Pos(',', FOrderStr);\r\n repeat\r\n if I <> 0 then\r\n begin\r\n LOrder := TJvXMLQueryOrder.Create(Trim(Copy(FOrderStr, 1, I - 1)));\r\n FOrders.Add(LOrder);\r\n FOrderStr := Trim(Copy(FOrderStr, I + 1, MaxInt));\r\n I := Pos(',', FOrderStr);\r\n end\r\n else\r\n if FOrderStr <> '' then\r\n begin\r\n LOrder := TJvXMLQueryOrder.Create(Trim(FOrderStr));\r\n FOrders.Add(LOrder);\r\n FOrderStr := '';\r\n end;\r\n until FOrderStr = '';\r\nend;\r\n\r\nprocedure TJvXMLQueryParser.DoValidateSet;\r\nvar\r\n I: Integer;\r\n LSet: TJvXMLQueryAssignement;\r\nbegin\r\n FSetStr := Trim(FSetStr);\r\n I := Pos(',', FSetStr);\r\n repeat\r\n if I <> 0 then\r\n begin\r\n LSet := TJvXMLQueryAssignement.Create(Trim(Copy(FSetStr, 1, I - 1)));\r\n FUpdates.Add(LSet);\r\n FSetStr := Trim(Copy(FSetStr, I + 1, MaxInt));\r\n I := Pos(',', FSetStr);\r\n end\r\n else\r\n if FSetStr <> '' then\r\n begin\r\n LSet := TJvXMLQueryAssignement.Create(Trim(FSetStr));\r\n FUpdates.Add(LSet);\r\n FSetStr := '';\r\n end;\r\n until FSetStr = '';\r\nend;\r\n\r\nprocedure TJvXMLQueryParser.DoValidateTables;\r\nvar\r\n I: Integer;\r\n LTable: TJvXMLQueryTable;\r\nbegin\r\n I := Pos(',', FTablesStr);\r\n repeat\r\n if I <> 0 then\r\n begin\r\n LTable := TJvXMLQueryTable.Create(Trim(Copy(FTablesStr, 1, I - 1)));\r\n FTables.Add(LTable);\r\n FTablesStr := Trim(Copy(FTablesStr, I + 1, MaxInt));\r\n I := Pos(',', FTablesStr);\r\n end\r\n else\r\n if FTablesStr <> '' then\r\n begin\r\n LTable := TJvXMLQueryTable.Create(Trim(FTablesStr));\r\n FTables.Add(LTable);\r\n FTablesStr := '';\r\n end;\r\n until FTablesStr = '';\r\nend;\r\n\r\nprocedure TJvXMLQueryParser.DoValidateValues;\r\nvar\r\n I: Integer;\r\n\r\n function ParseValue(const AValue: string): string;\r\n begin\r\n Result := Trim(AValue);\r\n\r\n //Escape quotes\r\n if (Result <> '') and ((Result[1] = '''') or (Result[1] = '\"')) then // do not use 'in' because of D2009\r\n Result := Copy(Result, 2, Length(Result) - 2);\r\n\r\n if SameText(Result, 'now') then\r\n Result := DateTimeToStr(Now);\r\n end;\r\n\r\nbegin\r\n I := Pos(',', FValuesStr);\r\n repeat\r\n if I <> 0 then\r\n begin\r\n FValues.Add(ParseValue(Trim(Copy(FValuesStr,1,I - 1))));\r\n FValuesStr := Trim(Copy(FValuesStr, I + 1, MaxInt));\r\n I := Pos(',', FValuesStr);\r\n end\r\n else\r\n if FValuesStr<>'' then\r\n begin\r\n FValues.Add(ParseValue(Trim(FValuesStr)));\r\n FValuesStr := '';\r\n end;\r\n until FValuesStr = '';\r\nend;\r\n\r\nprocedure TJvXMLQueryParser.DoValidateWhere;\r\nvar\r\n LToken: string;\r\n I, WhereStrLen: Integer;\r\n LChar: Char;\r\n\r\n procedure AddToken(const AToken: string);\r\n begin\r\n LToken := LowerCase(LToken);\r\n\r\n if LToken = 'and' then\r\n FConditions.Add(TJvXMLQueryCondition.Create(opAnd))\r\n else\r\n if LToken = 'or' then\r\n FConditions.Add(TJvXMLQueryCondition.Create(opOr))\r\n else\r\n if LToken = 'like' then\r\n FConditions.Add(TJvXMLQueryCondition.Create(opLike))\r\n else\r\n if LToken = 'xor' then\r\n FConditions.Add(TJvXMLQueryCondition.Create(opXor))\r\n else\r\n if LToken = 'is' then\r\n FConditions.Add(TJvXMLQueryCondition.Create(opEquals))\r\n else\r\n if LToken = 'null' then\r\n FConditions.Add(TJvXMLQueryCondition.Create(opNull))\r\n else\r\n FConditions.Add(TJvXMLQueryCondition.Create(opColumn,LToken));\r\n end;\r\n\r\nbegin\r\n FWhereStr := FWhereStr + ' ';\r\n WhereStrLen := Length(FWhereStr);\r\n I := 1;\r\n LToken := '';\r\n while I < WhereStrLen do\r\n begin\r\n case FWhereStr[I] of\r\n '(':\r\n begin\r\n if LToken<>'' then\r\n begin\r\n AddToken(LToken);\r\n LToken := '';\r\n end;\r\n FConditions.Add(TJvXMLQueryCondition.Create(opLeftParenthesis));\r\n end;\r\n ')':\r\n begin\r\n if LToken<>'' then\r\n begin\r\n AddToken(LToken);\r\n LToken := '';\r\n end;\r\n FConditions.Add(TJvXMLQueryCondition.Create(opRightParenthesis));\r\n end;\r\n 'a'..'z', 'A'..'Z', '0'..'9', '_':\r\n LToken := LToken + FWhereStr[I];\r\n ' ':\r\n if LToken <> '' then\r\n begin\r\n AddToken(LToken);\r\n LToken := '';\r\n end;\r\n '=':\r\n FConditions.Add(TJvXMLQueryCondition.Create(opEquals));\r\n '>':\r\n begin\r\n Inc(I);\r\n if I < WhereStrLen then\r\n begin\r\n if FWhereStr[I] = '=' then\r\n FConditions.Add(TJvXMLQueryCondition.Create(opGreaterEquals))\r\n else\r\n begin\r\n FConditions.Add(TJvXMLQueryCondition.Create(opGreater));\r\n Dec(I);\r\n end;\r\n end;\r\n end;\r\n '<':\r\n begin\r\n Inc(I);\r\n if I < WhereStrLen then\r\n begin\r\n if FWhereStr[I] = '=' then\r\n FConditions.Add(TJvXMLQueryCondition.Create(opSmallerEquals))\r\n else\r\n begin\r\n FConditions.Add(TJvXMLQueryCondition.Create(opSmaller));\r\n Dec(I);\r\n end;\r\n end;\r\n end;\r\n '''', '\"':\r\n begin\r\n LChar := FWhereStr[I];\r\n Inc(I);\r\n LToken := '';\r\n while (I < WhereStrLen) and (FWhereStr[I] <> LChar) do\r\n begin\r\n LToken := LToken + FWhereStr[I];\r\n Inc(I);\r\n end;\r\n FConditions.Add(TJvXMLQueryCondition.Create(opConstant,LToken));\r\n LToken := '';\r\n end;\r\n end;\r\n Inc(I);\r\n end;\r\nend;\r\n\r\nfunction TJvXMLQueryParser.GetColumn(const AIndex: Integer): TJvXMLQueryColumn;\r\nbegin\r\n Result := TJvXMLQueryColumn(FColumns[AIndex]);\r\nend;\r\n\r\nfunction TJvXMLQueryParser.GetColumnsCount: Integer;\r\nbegin\r\n Result := FColumns.Count;\r\nend;\r\n\r\nfunction TJvXMLQueryParser.GetCondition(const AIndex: Integer): TJvXMLQueryCondition;\r\nbegin\r\n Result := TJvXMLQueryCondition(FConditions[AIndex]);\r\nend;\r\n\r\nfunction TJvXMLQueryParser.GetConditionsCount: Integer;\r\nbegin\r\n Result := FConditions.Count;\r\nend;\r\n\r\nfunction TJvXMLQueryParser.GetTable(const AIndex: Integer): TJvXMLQueryTable;\r\nbegin\r\n Result := TJvXMLQueryTable(FTables[AIndex]);\r\nend;\r\n\r\nfunction TJvXMLQueryParser.GetTablesCount: Integer;\r\nbegin\r\n Result := FTables.Count;\r\nend;\r\n\r\nfunction TJvXMLQueryParser.GetValue(const AIndex: Integer): string;\r\nbegin\r\n Result := FValues[AIndex];\r\nend;\r\n\r\nfunction TJvXMLQueryParser.GetValuesCount: Integer;\r\nbegin\r\n Result := FValues.Count;\r\nend;\r\n\r\nprocedure TJvXMLQueryParser.LimitTable(var ATable: TJvSimpleXMLElem);\r\nbegin\r\n while (FLimitBegin > 0) and (ATable.Items.Count > 0) do\r\n begin\r\n ATable.Items.Delete(0);\r\n Dec(FLimitBegin);\r\n end;\r\n while (ATable.Items.Count > FLimitCount) do\r\n ATable.Items.Delete(ATable.Items.Count - 1);\r\nend;\r\n\r\nfunction TJvXMLQueryParser.OrderCallBack(Elems: TJvSimpleXMLElems;\r\n Index1, Index2: Integer): Integer;\r\nvar\r\n I: Integer;\r\n LStr1, LStr2: string;\r\n LFloat1, LFloat2: Double;\r\nbegin\r\n Result := 0;\r\n\r\n for I := 0 to FOrders.Count-1 do\r\n begin\r\n LStr1 := FOrderTable.Items[Index1].Properties.Value(TJvXMLQueryOrder(FOrders[I]).Column);\r\n LStr2 := FOrderTable.Items[Index2].Properties.Value(TJvXMLQueryOrder(FOrders[I]).Column);\r\n if LStr1 <> LStr2 then\r\n begin\r\n //convert to date/int\r\n case TJvXMLQueryOrder(FOrders[I]).Convertion of\r\n ocNone:\r\n Result := AnsiCompareStr(LStr1, LStr2);\r\n ocDate:\r\n Result := CompareDateTime(StrToDateTimeDef(LStr1, 0), StrToDateTimeDef(LStr2, 0));\r\n ocInteger:\r\n Result := StrToIntDef(LStr1, 0) - StrToIntDef(LStr2, 0);\r\n ocFloat:\r\n begin\r\n // NOTE: StrToFloatDefIgnoreInvalidCharacters now called JvSafeStrToFloatDef:\r\n LFloat1 := JvSafeStrToFloatDef(LStr1, 0);\r\n LFloat2 := JvSafeStrToFloatDef(LStr2, 0);\r\n if LFloat1 > LFloat2 then\r\n Result := 1\r\n else\r\n if LFloat1 < LFloat2 then\r\n Result := -1;\r\n end;\r\n end;\r\n\r\n if not TJvXMLQueryOrder(FOrders[I]).Ascending then\r\n Result := - Result;\r\n Exit;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvXMLQueryParser.OrderTable(var ATable: TJvSimpleXMLElem);\r\nbegin\r\n FOrderTable := ATable;\r\n ATable.Items.CustomSort(OrderCallBack);\r\nend;\r\n\r\nprocedure TJvXMLQueryParser.Parse(const AQuery: string);\r\nvar\r\n St: string;\r\n LStatements: array of string;\r\n I, J: Integer;\r\nbegin\r\n FQuery := AQuery;\r\n\r\n FInstructionStr := ReadToken;\r\n DoValidateInstruction;\r\n\r\n case Instruction of\r\n xiSelect:\r\n begin\r\n St := ReadColumns(['FROM', 'WHERE', 'ORDER', 'LIMIT'], False);\r\n SetLength(LStatements, 4);\r\n LStatements[0] := 'FROM';\r\n LStatements[1] := 'WHERE';\r\n LStatements[2] := 'ORDER';\r\n LStatements[3] := 'LIMIT';\r\n end;\r\n xiDelete:\r\n begin\r\n ReadToken; //pass the FROM keyword\r\n St := 'FROM';\r\n SetLength(LStatements, 2);\r\n LStatements[0] := 'FROM';\r\n LStatements[1] := 'WHERE';\r\n end;\r\n xiUpdate:\r\n begin\r\n St := 'FROM';\r\n SetLength(LStatements, 3);\r\n LStatements[0] := 'FROM';\r\n LStatements[1] := 'SET';\r\n LStatements[2] := 'WHERE';\r\n end;\r\n xiInsert:\r\n begin\r\n St := 'FROM';\r\n SetLength(LStatements, 3);\r\n LStatements[0] := 'FROM';\r\n LStatements[1] := 'VALUES';\r\n LStatements[2] := 'COLUMNS';\r\n ReadToken; // Pass the into statement\r\n\r\n //Modify query for lightness of parser\r\n //INSERT INTO file.XML(Col1, Col2) VALUES(val1, val2)\r\n // into\r\n //INSERT INTO file.XML COLUMNS col1, col2 VALUES val1, val2\r\n FQuery := StringReplace(FQuery, '()', '', [rfReplaceAll]);\r\n FQuery := StringReplace(FQuery, ')', ' ', [rfReplaceAll]);\r\n FQuery := StringReplace(FQuery, '(', ' COLUMNS ', []);\r\n FQuery := StringReplace(FQuery, '(', ' ', []);\r\n end;\r\n end;\r\n\r\n while St <> '' do\r\n begin\r\n J := -1;\r\n for I := 0 to Length(LStatements) - 1 do\r\n if LStatements[I] = St then\r\n begin\r\n LStatements[I] := ''; //Do not accept it anymore\r\n J := I;\r\n Break;\r\n end;\r\n if J = -1 then\r\n raise TJvXMLDatabaseException.CreateResFmt(@RsEUnexpectedStatement, [St]);\r\n\r\n if St = 'FROM' then\r\n St := ReadTables(LStatements)\r\n else\r\n if St = 'WHERE' then\r\n St := ReadWhere(LStatements)\r\n else\r\n if St = 'LIMIT' then\r\n St := ReadLimit(LStatements)\r\n else\r\n if St = 'ORDER' then\r\n St := ReadOrderBy(LStatements)\r\n else\r\n if St = 'SET' then\r\n St := ReadSet(LStatements)\r\n else\r\n if St = 'VALUES' then\r\n St := ReadValues(LStatements)\r\n else\r\n if St = 'COLUMNS' then\r\n St := ReadColumns(LStatements, False);\r\n end;\r\nend;\r\n\r\nfunction TJvXMLQueryParser.ReadColumns(const AEndStatement: array of string;\r\n ACanTerminate: Boolean): string;\r\nbegin\r\n Result := ReadStatement(AEndStatement, ACanTerminate, FColumnsStr);\r\n DoValidateColumns;\r\nend;\r\n\r\nfunction TJvXMLQueryParser.ReadLimit(const AEndStatement: array of string): string;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := ReadStatement(AEndStatement, True, FLimitStr);\r\n I := Pos(',', FLimitStr);\r\n if I = 0 then\r\n FLimitCount := StrToIntDef(FLimitStr, MaxInt)\r\n else\r\n begin\r\n FLimitCount := StrToIntDef(Trim(Copy(FLimitStr, I + 1, MaxInt)), MaxInt);\r\n FLimitBegin := StrToIntDef(Trim(Copy(FLimitStr, 1, I - 1)), 0);\r\n end;\r\nend;\r\n\r\nfunction TJvXMLQueryParser.ReadOrderBy(const AEndStatement: array of string): string;\r\nbegin\r\n Result := ReadStatement(AEndStatement, True, FOrderStr);\r\n DoValidateOrderBy;\r\nend;\r\n\r\nfunction TJvXMLQueryParser.ReadSet(const AEndStatement: array of string): string;\r\nbegin\r\n Result := ReadStatement(AEndStatement, True, FSetStr);\r\n DoValidateSet;\r\nend;\r\n\r\nfunction TJvXMLQueryParser.ReadStatement(const AEndStatement: array of string;\r\n ACanTerminate: Boolean; var AValue: string): string;\r\nvar\r\n St, UpSt: string;\r\n LFound: Boolean;\r\n I: Integer;\r\nbegin\r\n AValue := '';\r\n LFound := False;\r\n Result := '';\r\n while not LFound do\r\n if (FQuery = '') and ACanTerminate then\r\n LFound := True\r\n else\r\n begin\r\n St := ReadToken;\r\n if St <> '' then\r\n begin\r\n UpSt := UpperCase(St);\r\n for I := 0 to Length(AEndStatement) - 1 do\r\n if UpSt = AEndStatement[I] then\r\n begin\r\n LFound := True;\r\n Break;\r\n end;\r\n end;\r\n\r\n if not LFound then\r\n AValue := AValue + ' ' + St\r\n else\r\n Result := St;\r\n end;\r\nend;\r\n\r\nfunction TJvXMLQueryParser.ReadTables(const AEndStatement: array of string): string;\r\nbegin\r\n Result := ReadStatement(AEndStatement, True, FTablesStr);\r\n DoValidateTables;\r\nend;\r\n\r\nfunction TJvXMLQueryParser.ReadToken: string;\r\nvar\r\n I: Integer;\r\nbegin\r\n if FQuery = '' then\r\n raise TJvXMLDatabaseException.CreateRes(@RsEUnexpectedEndOfQuery);\r\n\r\n FQuery := TrimLeft(FQuery);\r\n I := 1;\r\n while (I < Length(FQuery)) and (FQuery[I] <> ' ') do {,'(',')'}\r\n Inc(I);\r\n if I >= Length(FQuery) then\r\n begin\r\n Result := Trim(FQuery);\r\n FQuery := '';\r\n end\r\n else\r\n begin\r\n Result := Copy(FQuery, 1, I - 1);\r\n FQuery := Copy(FQuery, I + 1, MaxInt);\r\n end;\r\nend;\r\n\r\nfunction TJvXMLQueryParser.ReadValues(const AEndStatement: array of string): string;\r\nbegin\r\n Result := ReadStatement(AEndStatement, True, FValuesStr);\r\n DoValidateValues;\r\nend;\r\n\r\nfunction TJvXMLQueryParser.ReadWhere(const AEndStatement: array of string): string;\r\nbegin\r\n Result := ReadStatement(AEndStatement, True, FWhereStr);\r\n DoValidateWhere;\r\nend;\r\n\r\nprocedure TJvXMLQueryParser.UpdateRow(ARow: TJvSimpleXMLElem);\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := 0 to FUpdates.Count - 1 do\r\n TJvXMLQueryAssignement(FUpdates[I]).UpdateElem(ARow);\r\nend;\r\n\r\n//=== { TJvXMLQueryColumn } ==================================================\r\n\r\nconstructor TJvXMLQueryColumn.Create(const AValue: string);\r\nvar\r\n I: Integer;\r\nbegin\r\n inherited Create;\r\n I := Pos('.', AValue);\r\n if I <> 0 then\r\n begin\r\n Name := Copy(AValue, I + 1, MaxInt);\r\n Table := Copy(AValue, 1, I - 1);\r\n end\r\n else\r\n Name := AValue;\r\nend;\r\n\r\n//=== { TJvXMLQueryTable } ===================================================\r\n\r\nconstructor TJvXMLQueryTable.Create(const AValue: string);\r\nvar\r\n I: Integer;\r\nbegin\r\n inherited Create;\r\n I := Pos(' ', AValue);\r\n if I <> 0 then\r\n begin\r\n Name := Copy(AValue, 1, I - 1);\r\n Alias := Trim(Copy(AValue, I + 1, MaxInt));\r\n end\r\n else\r\n Name := AValue;\r\nend;\r\n\r\n//=== { TJvXMLQueryCondition } ===============================================\r\n\r\nconstructor TJvXMLQueryCondition.Create(AOperator: TJvXMLSQLOperator;\r\n const ACondition: string);\r\nbegin\r\n inherited Create;\r\n Self.SQLOperator := AOperator;\r\n Self.Condition := ACondition;\r\nend;\r\n\r\n//=== { TJvXMLQueryOrder } ===================================================\r\n\r\nconstructor TJvXMLQueryOrder.Create(const AValue: string);\r\nvar\r\n I: Integer;\r\n St: string;\r\nbegin\r\n inherited Create;\r\n Column := Trim(AValue);\r\n Ascending := True;\r\n Convertion := ocNone;\r\n\r\n I := Pos(' ', Column);\r\n if I <> 0 then\r\n begin\r\n SetLength(Column, I - 1);\r\n Ascending := Pos('ASC', UpperCase(AValue)) <> 0;\r\n end;\r\n\r\n I := Pos('(', Column);\r\n if I <> 0 then\r\n begin\r\n St := UpperCase(Copy(Column, 1, I - 1));\r\n Column := Copy(Column, I + 1, MaxInt);\r\n SetLength(Column, Length(Column) - 1);\r\n\r\n if St = 'DATE' then\r\n Convertion := ocDate\r\n else\r\n if (St = 'Integer') or (St = 'INT') then\r\n Convertion := ocInteger\r\n else\r\n if St = 'FLOAT' then\r\n Convertion := ocFloat;\r\n end;\r\nend;\r\n\r\n//=== { TJvXMLQueryAssignement } =============================================\r\n\r\nconstructor TJvXMLQueryAssignement.Create(AValue: string);\r\nvar\r\n I, J: Integer;\r\n LDelimiter: Char;\r\nbegin\r\n inherited Create;\r\n I := Pos('=', AValue);\r\n if I = 0 then\r\n // (rom) this definitely neds to be improved\r\n raise Exception.Create('')\r\n else\r\n begin\r\n Column := Trim(Copy(AValue, 1, I - 1));\r\n AValue := Trim(Copy(AValue, I + 1, MaxInt));\r\n\r\n if AValue = '' then\r\n raise Exception.Create('');\r\n\r\n //Determine if column or constant\r\n if (AValue[1] = '\"') or (AValue[1] = '''') then\r\n begin\r\n LDelimiter := AValue[1];\r\n ValueKind := skConstant;\r\n AValue := Copy(AValue, 2, MaxInt);\r\n I := 0;\r\n for J := 1 to Length(AValue) do\r\n if AValue[J] = LDelimiter then\r\n if (J=1) or (AValue[J-1] <> '\\') then\r\n begin\r\n I := J;\r\n Break;\r\n end;\r\n if I <> 0 then\r\n begin\r\n Value := Copy(AValue, 1, I - 1);\r\n Value := StringReplace(Value, '\\' + LDelimiter, LDelimiter, [rfReplaceAll]);\r\n AValue := Trim(Copy(AValue, I + 1, MaxInt));\r\n end\r\n else\r\n raise Exception.Create('');\r\n end\r\n else\r\n begin\r\n ValueKind := skColumn;\r\n I := Pos(' ', AValue);\r\n if I = 0 then\r\n begin\r\n Value := AValue;\r\n AValue := '';\r\n end\r\n else\r\n begin\r\n Value := Copy(AValue, 1, I - 1);\r\n AValue := Trim(Copy(AValue, I + 1, MaxInt));\r\n end;\r\n end;\r\n\r\n //Second kind and second value?\r\n if AValue = '' then\r\n SetOperator := soNone\r\n else\r\n begin\r\n case AValue[1] of\r\n '+':\r\n SetOperator := soAdd;\r\n '-':\r\n SetOperator := soSubstract;\r\n '*':\r\n SetOperator := soMultiply;\r\n '/':\r\n SetOperator := soDivide;\r\n else\r\n raise Exception.Create('');\r\n end;\r\n\r\n SecondValue := Trim(Copy(AValue, 2, MaxInt));\r\n if (SecondValue <> '') and ((SecondValue[1] = '''') or (SecondValue[1] = '\"')) then // do not use 'in' to make D2009 happy\r\n begin\r\n SecondValue := Copy(SecondValue, 2, Length(SecondValue) - 2);\r\n SecondKind := skConstant;\r\n end\r\n else\r\n SecondKind := skColumn;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvXMLQueryAssignement.UpdateElem(AElement: TJvSimpleXMLElem);\r\nvar\r\n LValue, LValue2: string;\r\n\r\n function ParseValue(const AValue: string): string;\r\n begin\r\n if SameText(AValue, 'now()') then\r\n Result := DateTimeToStr(Now)\r\n else\r\n Result := AValue;\r\n end;\r\n\r\nbegin\r\n if ValueKind = skConstant then\r\n LValue := Value\r\n else\r\n LValue := AElement.Properties.Value(Value, ParseValue(Value));\r\n\r\n if SetOperator <> soNone then\r\n begin\r\n if SecondKind = skConstant then\r\n LValue2 := SecondValue\r\n else\r\n LValue2 := AElement.Properties.Value(SecondValue, ParseValue(SecondValue));\r\n\r\n // NOTE: StrToFloatDefIgnoreInvalidCharacters now called JvSafeStrToFloatDef:\r\n case SetOperator of\r\n soAdd:\r\n LValue := FloatToStr(JvSafeStrToFloatDef(LValue,0) + JvSafeStrToFloatDef(LValue2,0));\r\n soMultiply:\r\n LValue := FloatToStr(JvSafeStrToFloatDef(LValue,0) * JvSafeStrToFloatDef(LValue2,0));\r\n soDivide:\r\n LValue := FloatToStr(JvSafeStrToFloatDef(LValue,0) / JvSafeStrToFloatDef(LValue2,0));\r\n soSubstract:\r\n LValue := FloatToStr(JvSafeStrToFloatDef(LValue,0) - JvSafeStrToFloatDef(LValue2,0));\r\n end;\r\n end;\r\n\r\n AElement.Properties.Delete(Column);\r\n AElement.Properties.Add(Column, LValue);\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvXmlTree.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvXMLTree.PAS, released on 2002-06-15.\r\n\r\nThe Initial Developer of the Original Code is Jan Verhoeven [jan1 dott verhoeven att wxs dott nl]\r\nPortions created by Jan Verhoeven are Copyright (C) 2002 Jan Verhoeven.\r\nAll Rights Reserved.\r\n\r\nContributor(s): Robert Love [rlove att slcdug dott org].\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvXmlTree.pas 12461 2009-08-14 17:21:33Z obones $\r\n\r\nunit JvXmlTree;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n SysUtils, Classes, Variants,\r\n JvStrings;\r\n\r\ntype\r\n TJvXMLValueType = (xvtString, xvtCDATA);\r\n TJvXMLFilterOperator = (xfoNOP, xfoEQ, xfoIEQ, xfoNE, xfoINE, xfoGE,\r\n xfoIGE, xfoLE, xfoILE, xfoGT, xfoIGT, xfoLT, xfoILT);\r\n\r\n TJvXMLTree = class;\r\n\r\n TJvXMLFilterAtom = class(TObject)\r\n private\r\n FValue: string;\r\n FName: string;\r\n FOperator: TJvXMLFilterOperator;\r\n FAttributeFilter: Boolean;\r\n public\r\n property Name: string read FName write FName;\r\n property Operator: TJvXMLFilterOperator read FOperator write FOperator;\r\n property Value: string read FValue write FValue;\r\n property AttributeFilter: Boolean read FAttributeFilter write FAttributeFilter;\r\n end;\r\n\r\n TJvXMLFilter = class(TObject)\r\n private\r\n FName: string;\r\n FFilters: TList;\r\n procedure Initialize(FilterStr: string);\r\n public\r\n constructor Create(const FilterStr: string);\r\n destructor Destroy; override;\r\n property Name: string read FName write FName;\r\n property Filters: TList read FFilters write FFilters;\r\n end;\r\n\r\n TJvXMLNode = class;\r\n\r\n TJvXMLAttribute = class(TObject)\r\n private\r\n FName: string;\r\n FValue: Variant;\r\n FParent: TJvXMLNode;\r\n public\r\n constructor Create(AParent: TJvXMLNode; const AName: string; AValue: Variant);\r\n function Document: string;\r\n property Name: string read FName write FName;\r\n property Value: Variant read FValue write FValue;\r\n property Parent: TJvXMLNode read FParent write FParent;\r\n end;\r\n\r\n TJvXMLNode = class(TObject)\r\n private\r\n FName: string;\r\n FValue: Variant;\r\n FNodes: TList;\r\n FAttributes: TList;\r\n FParentNode: TJvXMLNode;\r\n FValueType: TJvXMLValueType;\r\n public\r\n constructor Create(const AName: string; AValue: Variant; AParent: TJvXMLNode);\r\n destructor Destroy; override;\r\n // added 29-July-2000\r\n function GetNamePathNode(const APath: string): TJvXMLNode;\r\n procedure DeleteNamePathNode(const APath: string);\r\n function ForceNamePathNode(const APath: string): TJvXMLNode;\r\n function GetNamePathNodeAttribute(const APath, AName: string): TJvXMLAttribute;\r\n procedure DeleteNamePathNodeAttribute(const APath, AName: string);\r\n function ForceNamePathNodeAttribute(const APath, AName: string; AValue: Variant): TJvXMLAttribute;\r\n function AddNode(const AName: string; AValue: Variant): TJvXMLNode;\r\n function AddNodeEx(const AName: string; AValue: Variant): TJvXMLNode;\r\n procedure DeleteNode(Index: Integer);\r\n procedure ClearNodes;\r\n function AddAttribute(const AName: string; AValue: Variant): TJvXMLAttribute;\r\n function GetAttributeValue(const AName: string): Variant;\r\n procedure DeleteAttribute(Index: Integer);\r\n procedure ClearAttributes;\r\n function Document(ALevel: Integer): string;\r\n function GetNodePath: string;\r\n function GetNamedNode(const AName: string): TJvXMLNode;\r\n function SelectSingleNode(const APattern: string): TJvXMLNode;\r\n procedure SelectNodes(APattern: string; AList: TList);\r\n function TransformNode(AStyleSheet: TJvXMLNode): string;\r\n function Process(ALevel: Integer; ANode: TJvXMLNode): string;\r\n function FindNamedNode(const AName: string): TJvXMLNode;\r\n procedure FindNamedNodes(const AName: string; AList: TList);\r\n procedure GetAllNodes(AList: TList);\r\n function GetNamedAttribute(const AName: string): TJvXMLAttribute;\r\n procedure FindNamedAttributes(const AName: string; AList: TList);\r\n function MatchFilter(AObjFilter: TJvXMLFilter): Boolean;\r\n procedure MatchPattern(const APattern: string; AList: TList);\r\n procedure GetNodeNames(AList: TStrings);\r\n procedure GetAttributeNames(AList: TStrings);\r\n function GetNameSpace: string;\r\n function HasChildNodes: Boolean;\r\n function CloneNode: TJvXMLNode;\r\n function FirstChild: TJvXMLNode;\r\n function LastChild: TJvXMLNode;\r\n function PreviousSibling: TJvXMLNode;\r\n function NextSibling: TJvXMLNode;\r\n function MoveAddNode(Dest: TJvXMLNode): TJvXMLNode;\r\n function MoveInsertNode(Dest: TJvXMLNode): TJvXMLNode;\r\n function RemoveChildNode(ANode: TJvXMLNode): TJvXMLNode;\r\n property Name: string read FName write FName;\r\n property Value: Variant read FValue write FValue;\r\n property ValueType: TJvXMLValueType read FValueType write FValueType;\r\n property Nodes: TList read FNodes write FNodes;\r\n property ParentNode: TJvXMLNode read FParentNode write FParentNode;\r\n property Attributes: TList read FAttributes write FAttributes;\r\n end;\r\n\r\n TJvXMLTree = class(TJvXMLNode)\r\n private\r\n FLines: TStringList;\r\n FNodeCount: Integer;\r\n function GetLines: TStrings;\r\n procedure SetLines(const Value: TStrings);\r\n function GetText: string;\r\n procedure SetText(const Value: string);\r\n public\r\n constructor Create(const AName: string; AValue: Variant; AParent: TJvXMLNode);\r\n destructor Destroy; override;\r\n procedure ParseXML;\r\n procedure LoadFromFile(const FileName: string);\r\n procedure LoadFromStream(Stream: TStream);\r\n procedure SaveToFile(const FileName: string);\r\n procedure SaveToStream(Stream: TStream);\r\n function AsText: string;\r\n property Lines: TStrings read GetLines write SetLines;\r\n property NodeCount: Integer read FNodeCount;\r\n property Text: string read GetText write SetText;\r\n end;\r\n\r\nprocedure PreProcessXML(AList: TStrings);\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvXmlTree.pas $';\r\n Revision: '$Revision: 12461 $';\r\n Date: '$Date: 2009-08-14 19:21:33 +0200 (ven. 14 août 2009) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n JvConsts;\r\n\r\nprocedure PreProcessXML(AList: TStrings);\r\nvar\r\n OList: TStringList;\r\n S, xTag, xText, xData: string;\r\n P1, P2, C: Integer;\r\n //Level: Integer;\r\n\r\n function Clean(const AText: string): string;\r\n begin\r\n Result := StringReplace(AText, sLineBreak, ' ', [rfReplaceAll]);\r\n Result := StringReplace(Result, Tab, ' ', [rfReplaceAll]);\r\n Result := Trim(Result);\r\n end;\r\n\r\n function CleanCDATA(const AText: string): string;\r\n begin\r\n Result := StringReplace(AText, sLineBreak, '\\n ', [rfReplaceAll]);\r\n Result := StringReplace(Result, Tab, '\\t ', [rfReplaceAll]);\r\n end;\r\n\r\nbegin\r\n OList := TStringList.Create;\r\n try\r\n S := AList.Text;\r\n xText := '';\r\n xTag := '';\r\n P1 := 1;\r\n C := Length(S);\r\n //Level := 0;\r\n repeat\r\n P2 := PosStr('<', S, P1);\r\n if P2 > 0 then\r\n begin\r\n xText := Trim(Copy(S, P1, P2 - P1));\r\n if xText <> '' then\r\n OList.Add('TX:' + Clean(xText));\r\n P1 := P2;\r\n // check for CDATA\r\n if UpperCase(Copy(S, P1, 9)) = '', S, P1);\r\n xData := Copy(S, P1 + 9, P2 - P1 - 9);\r\n OList.Add('CD:' + CleanCDATA(xData));\r\n P1 := P2 + 2;\r\n end\r\n else\r\n begin\r\n P2 := PosStr('>', S, P1);\r\n if P2 > 0 then\r\n begin\r\n xTag := Copy(S, P1 + 1, P2 - P1 - 1);\r\n P1 := P2;\r\n if xTag[1] = '/' then\r\n begin\r\n Delete(xTag, 1, 1);\r\n OList.Add('CT:' + Clean(xTag));\r\n //Dec(Level);\r\n end\r\n else\r\n if xTag[Length(xTag)] = '/' then\r\n OList.Add('ET:' + Clean(xTag))\r\n else\r\n begin\r\n //Inc(Level);\r\n OList.Add('OT:' + Clean(xTag));\r\n end;\r\n end;\r\n end;\r\n end\r\n else\r\n begin\r\n xText := Trim(Copy(S, P1, Length(S)));\r\n if xText <> '' then\r\n begin\r\n OList.Add('TX:' + Clean(xText));\r\n end;\r\n P1 := C;\r\n end;\r\n Inc(P1);\r\n until P1 > C;\r\n AList.Assign(OList);\r\n finally\r\n OList.Free;\r\n end;\r\nend;\r\n\r\n//=== { TJvXMLNode } =========================================================\r\n\r\nconstructor TJvXMLNode.Create(const AName: string; AValue: Variant; AParent: TJvXMLNode);\r\nbegin\r\n inherited Create;\r\n FNodes := TList.Create;\r\n FName := AName;\r\n FValue := AValue;\r\n FValueType := xvtString;\r\n FParentNode := AParent;\r\n FAttributes := TList.Create;\r\nend;\r\n\r\ndestructor TJvXMLNode.Destroy;\r\nbegin\r\n ClearNodes;\r\n FNodes.Free;\r\n ClearAttributes;\r\n FAttributes.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJvXMLNode.AddAttribute(const AName: string; AValue: Variant): TJvXMLAttribute;\r\nbegin\r\n Result := TJvXMLAttribute.Create(Self, AName, AValue);\r\n Attributes.Add(Result);\r\nend;\r\n\r\nfunction TJvXMLNode.AddNode(const AName: string; AValue: Variant): TJvXMLNode;\r\nbegin\r\n Result := TJvXMLNode.Create(AName, AValue, Self);\r\n Nodes.Add(Result);\r\nend;\r\n\r\n// adds node and parses any attributes;\r\n\r\nfunction TJvXMLNode.AddNodeEx(const AName: string; AValue: Variant): TJvXMLNode;\r\nvar\r\n S, SN, SV: string;\r\n C, P1, P2: Integer;\r\nbegin\r\n Result := TJvXMLNode.Create(AName, AValue, Self);\r\n Self.Nodes.Add(Result);\r\n C := Length(AName);\r\n //first parse Name\r\n P1 := PosStr(' ', AName, 1);\r\n if P1 = 0 then\r\n Exit;\r\n S := Copy(AName, 1, P1 - 1);\r\n Result.Name := S;\r\n repeat\r\n // find '='\r\n P2 := PosStr('=', AName, P1);\r\n if P2 = 0 then\r\n Break;\r\n SN := Trim(Copy(AName, P1, P2 - P1));\r\n P1 := P2;\r\n // find begin of value\r\n P1 := PosStr('\"', AName, P1);\r\n if P1 = 0 then\r\n Break;\r\n P2 := PosStr('\"', AName, P1 + 1);\r\n if P2 = 0 then\r\n Exit;\r\n SV := Copy(AName, P1 + 1, P2 - P1 - 1);\r\n Result.AddAttribute(SN, SV);\r\n P1 := P2 + 1;\r\n until P1 > C;\r\nend;\r\n\r\nfunction TJvXMLNode.GetNamedAttribute(const AName: string): TJvXMLAttribute;\r\nvar\r\n I: Integer;\r\n N: TJvXMLAttribute;\r\nbegin\r\n Result := nil;\r\n for I := 0 to Attributes.Count - 1 do\r\n begin\r\n N := TJvXMLAttribute(Attributes[I]);\r\n if N.Name = AName then\r\n begin\r\n Result := N;\r\n Break;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvXMLNode.ClearAttributes;\r\nvar\r\n I: Integer;\r\nbegin\r\n if Attributes.Count <> 0 then\r\n begin\r\n for I := 0 to Attributes.Count - 1 do\r\n TJvXMLAttribute(Attributes[I]).Free;\r\n Attributes.Clear;\r\n end;\r\nend;\r\n\r\nprocedure TJvXMLNode.ClearNodes;\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := 0 to Nodes.Count - 1 do\r\n TJvXMLNode(Nodes[I]).Free;\r\n Nodes.Clear;\r\nend;\r\n\r\nprocedure TJvXMLNode.DeleteAttribute(Index: Integer);\r\nbegin\r\n if (Attributes.Count > 0) and (Index < Attributes.Count) then\r\n begin\r\n TJvXMLAttribute(Attributes[Index]).Free;\r\n Attributes.Delete(Index);\r\n end;\r\nend;\r\n\r\nprocedure TJvXMLNode.DeleteNode(Index: Integer);\r\nbegin\r\n if (Nodes.Count > 0) and (Index < Nodes.Count) then\r\n begin\r\n TJvXMLNode(Nodes[Index]).Free;\r\n Nodes.Delete(Index);\r\n end;\r\nend;\r\n\r\nfunction TJvXMLNode.Document(ALevel: Integer): string;\r\nvar\r\n I: Integer;\r\n Indent: string;\r\n\r\n function ExpandCDATA(const AValue: string): string;\r\n begin\r\n Result := StringReplace(AValue, '\\n ', sLineBreak, [rfReplaceAll]);\r\n Result := StringReplace(Result, '\\t ', Tab, [rfReplaceAll]);\r\n end;\r\n\r\nbegin\r\n if ALevel > 0 then\r\n Indent := StringOfChar(' ', ALevel * 2)\r\n else\r\n Indent := '';\r\n Result := Indent + '<' + Name;\r\n if Attributes.Count > 0 then\r\n for I := 0 to Attributes.Count - 1 do\r\n Result := Result + TJvXMLAttribute(Attributes[I]).Document;\r\n if (Nodes.Count = 0) and (Value = '') then\r\n begin\r\n Result := Result + ' />' + sLineBreak;\r\n Exit;\r\n end\r\n else\r\n Result := Result + '>' + sLineBreak;\r\n if Value <> '' then\r\n begin\r\n if ValueType = xvtString then\r\n Result := Result + Indent + ' ' + Value + sLineBreak\r\n else\r\n if ValueType = xvtCDATA then\r\n Result := Result + Indent + ' ' + '' + sLineBreak;\r\n end;\r\n if Nodes.Count <> 0 then\r\n for I := 0 to Nodes.Count - 1 do\r\n Result := Result + TJvXMLNode(Nodes[I]).Document(ALevel + 1);\r\n Result := Result + Indent + '' + sLineBreak;\r\nend;\r\n\r\n// duplicates a node recursively\r\n\r\nfunction TJvXMLNode.CloneNode: TJvXMLNode;\r\nvar\r\n I: Integer;\r\n N: TJvXMLNode;\r\nbegin\r\n Result := TJvXMLNode.Create(Name, Value, nil);\r\n Result.Name := Name;\r\n Result.Value := Value;\r\n if Attributes.Count > 0 then\r\n for I := 0 to Attributes.Count - 1 do\r\n Result.AddAttribute(TJvXMLAttribute(Attributes[I]).Name, TJvXMLAttribute(Attributes[I]).Value);\r\n if Nodes.Count > 0 then\r\n for I := 0 to Nodes.Count - 1 do\r\n begin\r\n N := TJvXMLNode(Nodes[I]).CloneNode;\r\n Result.Nodes.Add(N);\r\n end;\r\nend;\r\n\r\nfunction TJvXMLNode.GetNamedNode(const AName: string): TJvXMLNode;\r\nvar\r\n I: Integer;\r\n N: TJvXMLNode;\r\nbegin\r\n Result := nil;\r\n for I := 0 to Nodes.Count - 1 do\r\n begin\r\n N := TJvXMLNode(Nodes[I]);\r\n if N.Name = AName then\r\n begin\r\n Result := N;\r\n Exit;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJvXMLNode.FirstChild: TJvXMLNode;\r\nbegin\r\n if Nodes.Count > 0 then\r\n Result := TJvXMLNode(Nodes[0])\r\n else\r\n Result := nil;\r\nend;\r\n\r\nfunction TJvXMLNode.LastChild: TJvXMLNode;\r\nbegin\r\n if Nodes.Count > 0 then\r\n Result := TJvXMLNode(Nodes[Nodes.Count - 1])\r\n else\r\n Result := nil;\r\nend;\r\n\r\nfunction TJvXMLNode.NextSibling: TJvXMLNode;\r\nvar\r\n Index: Integer;\r\nbegin\r\n Result := nil;\r\n if ParentNode = nil then\r\n Exit;\r\n Index := ParentNode.Nodes.IndexOf(Self);\r\n if Index = -1 then\r\n Exit;\r\n if Index < ParentNode.Nodes.Count - 1 then\r\n Result := TJvXMLNode(ParentNode.Nodes[Index + 1]);\r\nend;\r\n\r\nfunction TJvXMLNode.PreviousSibling: TJvXMLNode;\r\nvar\r\n Index: Integer;\r\nbegin\r\n Result := nil;\r\n if ParentNode = nil then\r\n Exit;\r\n Index := ParentNode.Nodes.IndexOf(Self);\r\n if Index = -1 then\r\n Exit;\r\n if Index > 0 then\r\n Result := TJvXMLNode(ParentNode.Nodes[Index - 1]);\r\nend;\r\n// moves a node to a new location\r\n\r\nfunction TJvXMLNode.MoveInsertNode(Dest: TJvXMLNode): TJvXMLNode;\r\nvar\r\n Index1, Index2: Integer;\r\nbegin\r\n Result := nil;\r\n if Dest.ParentNode = nil then\r\n Exit; // can not move to root\r\n Index1 := Self.ParentNode.Nodes.IndexOf(Self);\r\n if Index1 = -1 then\r\n Exit;\r\n Index2 := Dest.ParentNode.Nodes.IndexOf(Dest);\r\n if Index2 = -1 then\r\n Exit;\r\n Dest.ParentNode.Nodes.Insert(Index2, Self);\r\n Self.ParentNode.Nodes.Delete(Index1);\r\n Self.ParentNode := Dest.ParentNode;\r\n Result := Self;\r\nend;\r\n\r\nfunction TJvXMLNode.MoveAddNode(Dest: TJvXMLNode): TJvXMLNode;\r\nvar\r\n Index: Integer;\r\nbegin\r\n Result := nil;\r\n if Dest = nil then\r\n Exit; // can not move to root\r\n Index := Self.ParentNode.Nodes.IndexOf(Self);\r\n if Index = -1 then\r\n Exit;\r\n Dest.Nodes.Add(Self);\r\n Self.ParentNode.Nodes.Delete(Index);\r\n Self.ParentNode := Dest;\r\n Result := Self;\r\nend;\r\n\r\n// removes and Frees the childnode recursively.\r\n// returns Self when done, or nil in case of error\r\n\r\nfunction TJvXMLNode.RemoveChildNode(ANode: TJvXMLNode): TJvXMLNode;\r\nvar\r\n Index: Integer;\r\nbegin\r\n Result := nil;\r\n Index := Nodes.IndexOf(ANode);\r\n if Index = -1 then\r\n Exit;\r\n Nodes.Delete(Index);\r\n ANode.Free;\r\n Result := Self;\r\nend;\r\n\r\nfunction TJvXMLNode.HasChildNodes: Boolean;\r\nbegin\r\n Result := Nodes.Count > 0;\r\nend;\r\n\r\nprocedure TJvXMLNode.GetAttributeNames(AList: TStrings);\r\nvar\r\n I: Integer;\r\nbegin\r\n AList.Clear;\r\n for I := 0 to Attributes.Count - 1 do\r\n AList.Add(TJvXMLAttribute(Attributes[I]).Name);\r\nend;\r\n\r\nprocedure TJvXMLNode.GetNodeNames(AList: TStrings);\r\nvar\r\n I, C: Integer;\r\nbegin\r\n AList.Clear;\r\n C := Nodes.Count;\r\n for I := 0 to C - 1 do\r\n AList.Add(TJvXMLNode(Nodes[I]).Name);\r\nend;\r\n\r\nfunction TJvXMLNode.GetNodePath: string;\r\nvar\r\n N: TJvXMLNode;\r\nbegin\r\n N := Self;\r\n Result := Name;\r\n while N.ParentNode <> nil do\r\n begin\r\n N := N.ParentNode;\r\n Result := N.Name + '/' + Result;\r\n end;\r\nend;\r\n\r\n// search recursively for a named node\r\n\r\nfunction TJvXMLNode.FindNamedNode(const AName: string): TJvXMLNode;\r\nvar\r\n I: Integer;\r\n N: TJvXMLNode;\r\nbegin\r\n Result := nil;\r\n for I := 0 to Nodes.Count - 1 do\r\n begin\r\n N := TJvXMLNode(Nodes[I]);\r\n if N.Name = AName then\r\n begin\r\n Result := N;\r\n Break;\r\n end\r\n else\r\n begin // Recurse\r\n Result := N.FindNamedNode(AName);\r\n if Result <> nil then\r\n Break;\r\n end;\r\n end;\r\nend;\r\n\r\n// add all found named Nodes to AList\r\n\r\nprocedure TJvXMLNode.FindNamedNodes(const AName: string; AList: TList);\r\nvar\r\n I: Integer;\r\n N: TJvXMLNode;\r\nbegin\r\n for I := 0 to Nodes.Count - 1 do\r\n begin\r\n N := TJvXMLNode(Nodes[I]);\r\n if N.Name = AName then\r\n AList.Add(N);\r\n // Recurse\r\n N.FindNamedNodes(AName, AList);\r\n end;\r\nend;\r\n\r\n// add recursively all Nodes to AList\r\n// the list only contains pointers to the Nodes\r\n// typecast to use, e.g. N:=TJvXMLNode(AList[0]);\r\n\r\nprocedure TJvXMLNode.GetAllNodes(AList: TList);\r\nvar\r\n I: Integer;\r\n N: TJvXMLNode;\r\nbegin\r\n for I := 0 to Nodes.Count - 1 do\r\n begin\r\n N := TJvXMLNode(Nodes[I]);\r\n AList.Add(N);\r\n // Recurse\r\n N.GetAllNodes(AList);\r\n end;\r\nend;\r\n\r\n// add recursively all Nodes with matching named attribute to AList\r\n// the list only contains pointers to the Nodes\r\n// typecast to use, e.g. N:=TJvXMLNode(AList[0]);\r\n\r\nprocedure TJvXMLNode.FindNamedAttributes(const AName: string; AList: TList);\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := 0 to Attributes.Count - 1 do\r\n if TJvXMLAttribute(Attributes[I]).Name = AName then\r\n begin\r\n AList.Add(Self);\r\n Break;\r\n end;\r\n for I := 0 to Nodes.Count - 1 do\r\n TJvXMLNode(Nodes[I]).FindNamedAttributes(AName, AList);\r\nend;\r\n\r\n{\r\nthis procedure adds the node to AList when it matches the pattern\r\nthis will be the key procedure for XSL implementation\r\nonly basic matching is provided in the first release\r\npath operators\r\n / child path\r\n // recursive descent\r\n . curren context or node\r\n @ attribute\r\n * wildcar\r\nsome examples\r\n / the root node only\r\n book/author elements that are children of elements\r\n // the root node and all Nodes below\r\n //* all element Nodes below the root node\r\n book//author elements that are descendants of elements\r\n .//author elements\r\n book//* elements that are descendants of elements\r\n book/*/author elements that are grandchildren of elements\r\n book/@print_date print_date attributes that are attached to elements\r\n */@print_date print_date atrtributes that are attached to any elements\r\n\r\nIndex can be used to specify a particular node within a matching set\r\n /booklist/book[0] First node in root element\r\n /booklist/book[2] Third node in root element\r\n /booklist/book[end()] Last node in root element\r\n}\r\n\r\nprocedure TJvXMLNode.MatchPattern(const APattern: string; AList: TList);\r\nbegin\r\n // to be implemented\r\nend;\r\n\r\n{select a node based on path info\r\n e.g. booklist/book/category will find the first\r\n that is a child of that is a child of \r\n }\r\n\r\nfunction TJvXMLNode.SelectSingleNode(const APattern: string): TJvXMLNode;\r\nvar\r\n NPattern, LFilter: string;\r\n P, I: Integer;\r\n N: TJvXMLNode;\r\n ObjFilter: TJvXMLFilter;\r\nbegin\r\n Result := nil;\r\n if Nodes.Count = 0 then\r\n Exit;\r\n ObjFilter := nil;\r\n try\r\n P := Pos('/', APattern);\r\n if P = 0 then\r\n begin\r\n ObjFilter := TJvXMLFilter.Create(APattern);\r\n for I := 0 to Nodes.Count - 1 do\r\n begin\r\n N := TJvXMLNode(Nodes[I]);\r\n if N.MatchFilter(ObjFilter) then\r\n begin\r\n Result := N;\r\n Exit;\r\n end;\r\n end;\r\n // not found;\r\n end\r\n else\r\n begin\r\n LFilter := Copy(APattern, 1, P - 1);\r\n NPattern := Copy(APattern, P + 1, Length(APattern));\r\n ObjFilter := TJvXMLFilter.Create(LFilter);\r\n for I := 0 to Nodes.Count - 1 do\r\n begin\r\n N := TJvXMLNode(Nodes[I]);\r\n if N.MatchFilter(ObjFilter) then\r\n begin\r\n Result := N.SelectSingleNode(NPattern);\r\n if Result <> nil then\r\n Exit;\r\n end;\r\n end;\r\n end;\r\n finally\r\n ObjFilter.Free;\r\n end;\r\nend;\r\n\r\n// filter contains Name + any filters between []\r\n\r\nfunction TJvXMLNode.MatchFilter(AObjFilter: TJvXMLFilter): Boolean;\r\nvar\r\n I, J: Integer;\r\n A: TJvXMLAttribute;\r\n N: TJvXMLNode;\r\n AttName: string;\r\n Atom: TJvXMLFilterAtom;\r\n AttResult: Boolean;\r\n\r\n function EvalAtom(const AValue: string): Boolean;\r\n begin\r\n Result := False;\r\n case Atom.Operator of\r\n xfoNOP:\r\n Result := True;\r\n xfoEQ:\r\n Result := AValue = Atom.Value;\r\n xfoIEQ:\r\n Result := AnsiCompareText(AValue, Atom.Value) = 0;\r\n xfoNE:\r\n Result := AValue <> Atom.Value;\r\n xfoINE:\r\n Result := AnsiCompareText(AValue, Atom.Value) <> 0;\r\n xfoGT:\r\n try\r\n Result := StrToFloat(AValue) > StrToFloat(Atom.Value);\r\n except\r\n end;\r\n xfoIGT:\r\n Result := AnsiCompareText(AValue, Atom.Value) > 0;\r\n xfoLT:\r\n try\r\n Result := StrToFloat(AValue) < StrToFloat(Atom.Value);\r\n except\r\n end;\r\n xfoILT:\r\n Result := AnsiCompareText(AValue, Atom.Value) < 0;\r\n xfoGE:\r\n try\r\n Result := StrToFloat(AValue) >= StrToFloat(Atom.Value);\r\n except\r\n end;\r\n xfoIGE:\r\n Result := AnsiCompareText(AValue, Atom.Value) >= 0;\r\n xfoLE:\r\n try\r\n Result := StrToFloat(AValue) <= StrToFloat(Atom.Value);\r\n except\r\n end;\r\n xfoILE:\r\n Result := AnsiCompareText(AValue, Atom.Value) <= 0;\r\n end;\r\n end;\r\n\r\nbegin\r\n Result := False;\r\n AttResult := False;\r\n if AObjFilter.Filters.Count = 0 then\r\n begin // just filter on Name\r\n Result := AObjFilter.Name = Name;\r\n Exit;\r\n end;\r\n for I := 0 to AObjFilter.Filters.Count - 1 do\r\n begin\r\n Atom := TJvXMLFilterAtom(AObjFilter.Filters[I]);\r\n if Atom.AttributeFilter then\r\n begin\r\n AttName := Atom.Name;\r\n if AttName = '*' then\r\n begin // match any attribute\r\n if Attributes.Count = 0 then\r\n Exit;\r\n for J := 0 to Attributes.Count - 1 do\r\n begin\r\n A := TJvXMLAttribute(Attributes[J]);\r\n AttResult := EvalAtom(A.Value);\r\n if AttResult then\r\n Break;\r\n end;\r\n if not AttResult then\r\n Exit;\r\n end\r\n else\r\n begin\r\n A := GetNamedAttribute(AttName);\r\n if (A = nil) or not EvalAtom(A.Value) then\r\n Exit;\r\n end;\r\n end\r\n else\r\n begin\r\n AttName := Atom.Name;\r\n N := GetNamedNode(AttName);\r\n if (N = nil) or not EvalAtom(N.Value) then\r\n Exit;\r\n end;\r\n end;\r\n Result := True;\r\nend;\r\n\r\nprocedure TJvXMLNode.SelectNodes(APattern: string; AList: TList);\r\nvar\r\n NPattern: string;\r\n P, I: Integer;\r\n N: TJvXMLNode;\r\n LFilter: string;\r\n ObjFilter: TJvXMLFilter;\r\n Recurse: Boolean;\r\nbegin\r\n if Nodes.Count = 0 then\r\n Exit;\r\n if Copy(APattern, 1, 2) = '//' then\r\n begin //recursive\r\n Delete(APattern, 1, 2);\r\n Recurse := True;\r\n end\r\n else\r\n Recurse := False;\r\n P := Pos('/', APattern);\r\n if P = 0 then\r\n begin\r\n LFilter := APattern;\r\n ObjFilter := TJvXMLFilter.Create(LFilter);\r\n for I := 0 to Nodes.Count - 1 do\r\n begin\r\n N := TJvXMLNode(Nodes[I]);\r\n if N.MatchFilter(ObjFilter) then\r\n AList.Add(N)\r\n else\r\n if Recurse then\r\n N.SelectNodes('//' + APattern, AList);\r\n end;\r\n ObjFilter.Free;\r\n end\r\n else\r\n begin\r\n LFilter := Copy(APattern, 1, P - 1);\r\n if Copy(APattern, P, 2) = '//' then\r\n NPattern := Copy(APattern, P, Length(APattern))\r\n else\r\n NPattern := Copy(APattern, P + 1, Length(APattern));\r\n ObjFilter := TJvXMLFilter.Create(LFilter);\r\n for I := 0 to Nodes.Count - 1 do\r\n begin\r\n N := TJvXMLNode(Nodes[I]);\r\n if N.MatchFilter(ObjFilter) then\r\n N.SelectNodes(NPattern, AList)\r\n else\r\n if Recurse then\r\n N.SelectNodes('//' + APattern, AList);\r\n end;\r\n ObjFilter.Free;\r\n end;\r\nend;\r\n\r\n// the XSL implementation\r\n// although this function returns a string, the string itself can be parsed to Create a DOM\r\n\r\nfunction TJvXMLNode.TransformNode(AStyleSheet: TJvXMLNode): string;\r\nbegin\r\n // to be implemented;\r\n Result := AStyleSheet.Process(0, Self);\r\nend;\r\n\r\n// used in conjunction with the TransformNode function.\r\n// basically works like the Document function except for Nodes with processing instructions\r\n\r\nfunction TJvXMLNode.Process(ALevel: Integer; ANode: TJvXMLNode): string;\r\nvar\r\n I: Integer;\r\n Indent: string;\r\n\r\n function ExpandCDATA(const AValue: string): string;\r\n begin\r\n Result := StringReplace(AValue, '\\n ', sLineBreak, [rfReplaceAll]);\r\n Result := StringReplace(Result, '\\t ', Tab, [rfReplaceAll]);\r\n end;\r\n\r\nbegin\r\n if ParentNode = nil then\r\n begin\r\n for I := 0 to Nodes.Count - 1 do\r\n Result := Result + TJvXMLNode(Nodes[I]).Process(ALevel + 1, ANode);\r\n Exit;\r\n end;\r\n if ALevel > 0 then\r\n Indent := StringOfChar(' ', ALevel * 2)\r\n else\r\n Indent := '';\r\n Result := Indent + '<' + Name;\r\n for I := 0 to Attributes.Count - 1 do\r\n Result := Result + TJvXMLAttribute(Attributes[I]).Document;\r\n if (Nodes.Count = 0) and (Value = '') then\r\n begin\r\n Result := Result + ' />' + sLineBreak;\r\n Exit;\r\n end\r\n else\r\n Result := Result + '>' + sLineBreak;\r\n if Value <> '' then\r\n begin\r\n if ValueType = xvtString then\r\n Result := Result + Indent + ' ' + Value + sLineBreak\r\n else\r\n if ValueType = xvtCDATA then\r\n Result := Result + Indent + ' ' + '' + sLineBreak;\r\n end;\r\n for I := 0 to Nodes.Count - 1 do\r\n Result := Result + TJvXMLNode(Nodes[I]).Process(ALevel + 1, ANode);\r\n Result := Result + Indent + '' + sLineBreak;\r\nend;\r\n\r\nfunction TJvXMLNode.GetNameSpace: string;\r\nvar\r\n P: Integer;\r\nbegin\r\n P := Pos(':', FName);\r\n if P > 0 then\r\n Result := Copy(FName, 1, P - 1)\r\n else\r\n Result := '';\r\nend;\r\n\r\n// find the node with a path like customers/regional/jansoft\r\n\r\nfunction TJvXMLNode.GetNamePathNode(const APath: string): TJvXMLNode;\r\nvar\r\n AName, NewPath, SIndex: string;\r\n I, P, Index, IndexC: Integer;\r\n N: TJvXMLNode;\r\nbegin\r\n Result := nil;\r\n if Nodes.Count = 0 then\r\n Exit;\r\n if APath = '' then\r\n begin\r\n Result := Self;\r\n Exit;\r\n end;\r\n P := PosStr('/', APath, 1);\r\n if P = 0 then\r\n begin\r\n AName := APath;\r\n NewPath := '';\r\n end\r\n else\r\n begin\r\n AName := Copy(APath, 1, P - 1);\r\n NewPath := Copy(APath, P + 1, Length(APath));\r\n end;\r\n // now check for any Index []\r\n P := PosStr('[', AName, 1);\r\n Index := 0; // search first by default\r\n IndexC := 0;\r\n if P > 0 then\r\n begin\r\n SIndex := Copy(AName, P + 1, Length(AName) - P - 1);\r\n AName := Copy(AName, 1, P - 1);\r\n if SIndex = 'end' then\r\n Index := -1\r\n else\r\n try\r\n Index := StrToInt(SIndex);\r\n if Index >= Nodes.Count then\r\n Exit;\r\n except\r\n Exit;\r\n end;\r\n end;\r\n if Index = -1 then // search end from end\r\n for I := Nodes.Count - 1 downto 0 do\r\n begin\r\n N := TJvXMLNode(Nodes[I]);\r\n if N.Name = AName then\r\n if NewPath = '' then\r\n begin\r\n Result := N;\r\n Exit;\r\n end\r\n else\r\n begin\r\n Result := N.GetNamePathNode(NewPath);\r\n Exit;\r\n end;\r\n end\r\n else // search from beginning indexed\r\n for I := 0 to Nodes.Count - 1 do\r\n begin\r\n N := TJvXMLNode(Nodes[I]);\r\n if N.Name = AName then\r\n if Index = IndexC then\r\n begin\r\n if NewPath = '' then\r\n begin\r\n Result := N;\r\n Exit;\r\n end\r\n else\r\n begin\r\n Result := N.GetNamePathNode(NewPath);\r\n Exit;\r\n end;\r\n end\r\n else\r\n Inc(IndexC);\r\n end;\r\nend;\r\n\r\nfunction TJvXMLNode.ForceNamePathNode(const APath: string): TJvXMLNode;\r\nvar\r\n AName, NewPath: string;\r\n I, P: Integer;\r\n N: TJvXMLNode;\r\n DoAppend: Boolean;\r\nbegin\r\n // Result:=nil;\r\n P := PosStr('/', APath, 1);\r\n if P = 0 then\r\n begin\r\n AName := APath;\r\n NewPath := '';\r\n end\r\n else\r\n begin\r\n AName := Copy(APath, 1, P - 1);\r\n NewPath := Copy(APath, P + 1, Length(APath));\r\n end;\r\n P := PosStr('+', AName, 1);\r\n if P > 0 then\r\n Delete(AName, P, 1);\r\n DoAppend := P > 0;\r\n if not DoAppend then\r\n for I := 0 to Nodes.Count - 1 do\r\n begin\r\n N := TJvXMLNode(Nodes[I]);\r\n if N.Name = AName then\r\n if NewPath = '' then\r\n begin\r\n Result := N;\r\n Exit;\r\n end\r\n else\r\n begin\r\n Result := N.ForceNamePathNode(NewPath);\r\n Exit;\r\n end;\r\n end;\r\n // we dont have it , so force it;\r\n N := TJvXMLNode.Create(AName, '', Self);\r\n Nodes.Add(N);\r\n if NewPath = '' then\r\n Result := N\r\n else\r\n Result := N.ForceNamePathNode(NewPath);\r\nend;\r\n\r\nfunction TJvXMLNode.ForceNamePathNodeAttribute(const APath, AName: string;\r\n AValue: Variant): TJvXMLAttribute;\r\nvar\r\n N: TJvXMLNode;\r\n A: TJvXMLAttribute;\r\nbegin\r\n Result := nil;\r\n N := ForceNamePathNode(APath);\r\n if N = nil then\r\n Exit;\r\n A := N.GetNamedAttribute(AName);\r\n if A <> nil then\r\n begin\r\n A.Value := AValue;\r\n Result := A;\r\n end\r\n else\r\n Result := N.AddAttribute(AName, AValue);\r\nend;\r\n\r\nfunction TJvXMLNode.GetNamePathNodeAttribute(const APath, AName: string): TJvXMLAttribute;\r\nvar\r\n N: TJvXMLNode;\r\nbegin\r\n Result := nil;\r\n N := GetNamePathNode(APath);\r\n if N = nil then\r\n Exit;\r\n Result := N.GetNamedAttribute(AName);\r\nend;\r\n\r\nprocedure TJvXMLNode.DeleteNamePathNode(const APath: string);\r\nvar\r\n N, PN: TJvXMLNode;\r\n I: Integer;\r\nbegin\r\n if APath = '' then\r\n Exit;\r\n N := GetNamePathNode(APath);\r\n if N = nil then\r\n Exit;\r\n PN := N.ParentNode;\r\n for I := 0 to PN.Nodes.Count - 1 do\r\n if TJvXMLNode(PN.Nodes[I]) = N then\r\n begin\r\n PN.DeleteNode(I);\r\n Exit;\r\n end;\r\nend;\r\n\r\nprocedure TJvXMLNode.DeleteNamePathNodeAttribute(const APath, AName: string);\r\nvar\r\n A: TJvXMLAttribute;\r\n PN: TJvXMLNode;\r\n I: Integer;\r\nbegin\r\n A := GetNamePathNodeAttribute(APath, AName);\r\n if A = nil then\r\n Exit;\r\n PN := A.Parent;\r\n for I := 0 to PN.Attributes.Count - 1 do\r\n if TJvXMLAttribute(PN.Attributes[I]) = A then\r\n begin\r\n PN.DeleteAttribute(I);\r\n Exit;\r\n end;\r\nend;\r\n\r\nfunction TJvXMLNode.GetAttributeValue(const AName: string): Variant;\r\nvar\r\n I: Integer;\r\n A: TJvXMLAttribute;\r\nbegin\r\n Result := Null;\r\n for I := 0 to Attributes.Count - 1 do\r\n begin\r\n A := TJvXMLAttribute(Attributes[I]);\r\n if A.Name = AName then\r\n begin\r\n Result := A.Value;\r\n Exit;\r\n end;\r\n end;\r\nend;\r\n\r\n//=== { TJvXMLTree } =========================================================\r\n\r\nconstructor TJvXMLTree.Create(const AName: string; AValue: Variant; AParent: TJvXMLNode);\r\nbegin\r\n inherited Create(AName, AValue, AParent);\r\n FLines := TStringList.Create;\r\nend;\r\n\r\ndestructor TJvXMLTree.Destroy;\r\nbegin\r\n FLines.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJvXMLTree.AsText: string;\r\nvar\r\n I: Integer;\r\nbegin\r\n if Nodes.Count = 0 then\r\n Exit;\r\n Result := '<' + Name;\r\n if Attributes.Count > 0 then\r\n for I := 0 to Attributes.Count - 1 do\r\n Result := Result + TJvXMLAttribute(Attributes[I]).Document;\r\n Result := Result + '>' + sLineBreak;\r\n for I := 0 to Nodes.Count - 1 do\r\n Result := Result + TJvXMLNode(Nodes[I]).Document(1);\r\n Result := Result + '' + sLineBreak;\r\nend;\r\n\r\nprocedure TJvXMLTree.SaveToFile(const FileName: string);\r\nbegin\r\n Lines.Text := Text;\r\n Lines.SaveToFile(FileName);\r\nend;\r\n\r\nfunction TJvXMLTree.GetLines: TStrings;\r\nbegin\r\n Result := FLines;\r\nend;\r\n\r\nprocedure TJvXMLTree.SetLines(const Value: TStrings);\r\nbegin\r\n FLines.Assign(Value);\r\nend;\r\n\r\nprocedure TJvXMLTree.LoadFromStream(Stream: TStream);\r\nbegin\r\n ClearNodes;\r\n ClearAttributes;\r\n Lines.LoadFromStream(Stream);\r\n PreProcessXML(Lines);\r\n ParseXML;\r\nend;\r\n\r\nprocedure TJvXMLTree.SaveToStream(Stream: TStream);\r\nbegin\r\n Lines.Text := AsText;\r\n Lines.SaveToStream(Stream);\r\nend;\r\n\r\nfunction TJvXMLTree.GetText: string;\r\nvar\r\n I: Integer;\r\nbegin\r\n // Result:='<'+Name;\r\n // if Attributes.Count>0 then\r\n // for I:=0 to Attributes.Count-1 do\r\n // Result:=Result+TJvXMLAttribute(Attributes[I]).Document;\r\n // Result:=Result+'>'+sLineBreak;\r\n Result := '';\r\n for I := 0 to Nodes.Count - 1 do\r\n Result := Result + TJvXMLNode(Nodes[I]).Document(0);\r\n // Result:=Result+''+sLineBreak;\r\nend;\r\n\r\nprocedure TJvXMLTree.SetText(const Value: string);\r\nbegin\r\n ClearNodes;\r\n ClearAttributes;\r\n Lines.Text := Value;\r\n PreProcessXML(Lines);\r\n ParseXML;\r\nend;\r\n\r\n//=== { TJvXMLAttribute } ====================================================\r\n\r\nconstructor TJvXMLAttribute.Create(AParent: TJvXMLNode; const AName: string; AValue: Variant);\r\nbegin\r\n inherited Create;\r\n FName := AName;\r\n FValue := AValue;\r\n FParent := AParent;\r\nend;\r\n\r\nfunction TJvXMLAttribute.Document: string;\r\nvar\r\n S: string;\r\nbegin\r\n S := Value;\r\n Result := ' ' + Name + '=\"' + S + '\"';\r\nend;\r\n\r\n//=== { TJvXMLTree } =========================================================\r\n\r\nprocedure TJvXMLTree.ParseXML;\r\nvar\r\n I, C: Integer;\r\n S, Token, AName: string;\r\n N: TJvXMLNode;\r\nbegin\r\n FNodeCount := 0;\r\n ClearNodes;\r\n ClearAttributes;\r\n Name := 'root';\r\n N := Self;\r\n C := Lines.Count - 1;\r\n I := 0;\r\n while I <= C do\r\n begin\r\n S := Lines[I];\r\n Token := Copy(S, 1, 3);\r\n AName := Copy(S, 4, Length(S));\r\n if Token = 'OT:' then\r\n begin\r\n N := N.AddNodeEx(AName, '');\r\n Inc(FNodeCount);\r\n end\r\n else\r\n if Token = 'CT:' then\r\n N := N.ParentNode\r\n else\r\n if Token = 'ET:' then\r\n N.AddNodeEx(AName, '')\r\n else\r\n if Token = 'TX:' then\r\n begin\r\n N.Value := AName;\r\n N.ValueType := xvtString;\r\n end\r\n else\r\n if Token = 'CD:' then\r\n begin\r\n N.Value := AName;\r\n N.ValueType := xvtCDATA;\r\n end;\r\n Inc(I);\r\n end;\r\nend;\r\n\r\nprocedure TJvXMLTree.LoadFromFile(const FileName: string);\r\nbegin\r\n ClearNodes;\r\n ClearAttributes;\r\n Lines.LoadFromFile(FileName);\r\n PreProcessXML(Lines);\r\n ParseXML;\r\nend;\r\n\r\n//=== { TJvXMLFilter } =======================================================\r\n\r\nconstructor TJvXMLFilter.Create(const FilterStr: string);\r\nbegin\r\n inherited Create;\r\n Filters := TList.Create;\r\n Initialize(FilterStr);\r\nend;\r\n\r\ndestructor TJvXMLFilter.Destroy;\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := 0 to Filters.Count - 1 do\r\n TJvXMLFilterAtom(Filters[I]).Free;\r\n Filters.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvXMLFilter.Initialize(FilterStr: string);\r\nvar\r\n LFilter: string;\r\n P1, P2: Integer;\r\n AttName, AttValue: string;\r\n AttOperator: TJvXMLFilterOperator;\r\n Atom: TJvXMLFilterAtom;\r\n // A: TJvXMLAttribute;\r\n // N: TJvXMLNode;\r\n\r\n function TrimQuotes(const S: string): string;\r\n var\r\n L: Integer;\r\n begin\r\n Result := Trim(S);\r\n if S = '' then\r\n Exit;\r\n if (S[1] = '\"') or (S[1] = '''') then\r\n Delete(Result, 1, 1);\r\n if S = '' then\r\n Exit;\r\n L := Length(Result);\r\n if (Result[L] = '\"') or (Result[L] = '''') then\r\n Delete(Result, L, 1);\r\n end;\r\n\r\n function SplitNameValue(const S: string): Boolean;\r\n var\r\n PP: Integer;\r\n begin\r\n // (rom) inefficient implementation\r\n // Result:=False;\r\n PP := PosStr(' $ne$ ', S, 1);\r\n if PP > 0 then\r\n begin\r\n AttOperator := xfoNE;\r\n AttName := Trim(Copy(S, 1, PP - 1));\r\n AttValue := TrimQuotes(Copy(S, PP + 6, Length(S)));\r\n Result := (AttName <> '') and (AttValue <> '');\r\n Exit;\r\n end;\r\n PP := PosStr(' $ine$ ', S, 1);\r\n if PP > 0 then\r\n begin\r\n AttOperator := xfoINE;\r\n AttName := Trim(Copy(S, 1, PP - 1));\r\n AttValue := TrimQuotes(Copy(S, PP + 7, Length(S)));\r\n Result := (AttName <> '') and (AttValue <> '');\r\n Exit;\r\n end;\r\n PP := PosStr(' $ge$ ', S, 1);\r\n if PP > 0 then\r\n begin\r\n AttOperator := xfoGE;\r\n AttName := Trim(Copy(S, 1, PP - 1));\r\n AttValue := TrimQuotes(Copy(S, PP + 6, Length(S)));\r\n Result := (AttName <> '') and (AttValue <> '');\r\n Exit;\r\n end;\r\n PP := PosStr(' $ige$ ', S, 1);\r\n if PP > 0 then\r\n begin\r\n AttOperator := xfoIGE;\r\n AttName := Trim(Copy(S, 1, PP - 1));\r\n AttValue := TrimQuotes(Copy(S, PP + 7, Length(S)));\r\n Result := (AttName <> '') and (AttValue <> '');\r\n Exit;\r\n end;\r\n PP := PosStr(' $gt$ ', S, 1);\r\n if PP > 0 then\r\n begin\r\n AttOperator := xfoGT;\r\n AttName := Trim(Copy(S, 1, PP - 1));\r\n AttValue := TrimQuotes(Copy(S, PP + 6, Length(S)));\r\n Result := (AttName <> '') and (AttValue <> '');\r\n Exit;\r\n end;\r\n PP := PosStr(' $igt$ ', S, 1);\r\n if PP > 0 then\r\n begin\r\n AttOperator := xfoIGT;\r\n AttName := Trim(Copy(S, 1, PP - 1));\r\n AttValue := TrimQuotes(Copy(S, PP + 7, Length(S)));\r\n Result := (AttName <> '') and (AttValue <> '');\r\n Exit;\r\n end;\r\n PP := PosStr(' $le$ ', S, 1);\r\n if PP > 0 then\r\n begin\r\n AttOperator := xfoLE;\r\n AttName := Trim(Copy(S, 1, PP - 1));\r\n AttValue := TrimQuotes(Copy(S, PP + 6, Length(S)));\r\n Result := (AttName <> '') and (AttValue <> '');\r\n Exit;\r\n end;\r\n PP := PosStr(' $ile$ ', S, 1);\r\n if PP > 0 then\r\n begin\r\n AttOperator := xfoILE;\r\n AttName := Trim(Copy(S, 1, PP - 1));\r\n AttValue := TrimQuotes(Copy(S, PP + 7, Length(S)));\r\n Result := (AttName <> '') and (AttValue <> '');\r\n Exit;\r\n end;\r\n PP := PosStr(' $lt$ ', S, 1);\r\n if PP > 0 then\r\n begin\r\n AttOperator := xfoLT;\r\n AttName := Trim(Copy(S, 1, PP - 1));\r\n AttValue := TrimQuotes(Copy(S, PP + 6, Length(S)));\r\n Result := (AttName <> '') and (AttValue <> '');\r\n Exit;\r\n end;\r\n PP := PosStr(' $ilt$ ', S, 1);\r\n if PP > 0 then\r\n begin\r\n AttOperator := xfoILT;\r\n AttName := Trim(Copy(S, 1, PP - 1));\r\n AttValue := TrimQuotes(Copy(S, PP + 7, Length(S)));\r\n Result := (AttName <> '') and (AttValue <> '');\r\n Exit;\r\n end;\r\n PP := PosStr(' $eq$ ', S, 1);\r\n if PP > 0 then\r\n begin\r\n AttOperator := xfoEQ;\r\n AttName := Trim(Copy(S, 1, PP - 1));\r\n AttValue := TrimQuotes(Copy(S, PP + 6, Length(S)));\r\n Result := (AttName <> '') and (AttValue <> '');\r\n Exit;\r\n end;\r\n PP := PosStr(' $ieq$ ', S, 1);\r\n if PP > 0 then\r\n begin\r\n AttOperator := xfoIEQ;\r\n AttName := Trim(Copy(S, 1, PP - 1));\r\n AttValue := TrimQuotes(Copy(S, PP + 7, Length(S)));\r\n Result := (AttName <> '') and (AttValue <> '');\r\n Exit;\r\n end;\r\n PP := PosStr(' = ', S, 1);\r\n if PP > 0 then\r\n begin\r\n AttOperator := xfoEQ;\r\n AttName := Trim(Copy(S, 1, PP - 1));\r\n AttValue := TrimQuotes(Copy(S, PP + 3, Length(S)));\r\n Result := (AttName <> '') and (AttValue <> '');\r\n Exit;\r\n end;\r\n AttOperator := xfoNOP;\r\n AttName := S;\r\n AttValue := '';\r\n Result := True;\r\n Exit;\r\n end;\r\n\r\nbegin\r\n P1 := PosStr('[', FilterStr, 1);\r\n if P1 = 0 then\r\n begin // just a Name filter on Name\r\n Name := FilterStr;\r\n Exit;\r\n end\r\n else\r\n begin\r\n Name := Copy(FilterStr, 1, P1 - 1);\r\n Delete(FilterStr, 1, P1 - 1);\r\n end;\r\n repeat\r\n FilterStr := Trim(FilterStr);\r\n P1 := PosStr('[', FilterStr, 1);\r\n if P1 = 0 then\r\n Exit;\r\n P2 := PosStr(']', FilterStr, P1 + 1);\r\n if P2 = 0 then\r\n Exit;\r\n LFilter := Copy(FilterStr, P1 + 1, P2 - P1 - 1);\r\n Delete(FilterStr, 1, P2);\r\n if LFilter = '' then\r\n Exit;\r\n // check for attribute filter\r\n if LFilter[1] = '@' then\r\n begin\r\n if not SplitNameValue(Copy(LFilter, 2, Length(LFilter))) then\r\n Exit;\r\n Atom := TJvXMLFilterAtom.Create;\r\n Atom.Name := AttName;\r\n Atom.Operator := AttOperator;\r\n Atom.Value := AttValue;\r\n Atom.AttributeFilter := True;\r\n Filters.Add(Atom);\r\n end\r\n else\r\n begin // childfilter\r\n if not SplitNameValue(LFilter) then\r\n Exit;\r\n Atom := TJvXMLFilterAtom.Create;\r\n Atom.Name := AttName;\r\n Atom.Operator := AttOperator;\r\n Atom.Value := AttValue;\r\n Atom.AttributeFilter := False;\r\n Filters.Add(Atom);\r\n end;\r\n until FilterStr = '';\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvYearGrid.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvYearGrid.PAS, released on 2002-06-15.\r\n\r\nThe Initial Developer of the Original Code is Jan Verhoeven [jan1 dott verhoeven att wxs dott nl]\r\nPortions created by Jan Verhoeven are Copyright (C) 2002 Jan Verhoeven.\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\n Robert Love [rlove at slcdug dot org].\r\n Olivier Sannier [obones at users dot sourceforge dot net]\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvYearGrid.pas 13415 2012-09-10 09:51:54Z obones $\r\n\r\nunit JvYearGrid;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n {$IFDEF MSWINDOWS}\r\n ShellAPI,\r\n {$ENDIF MSWINDOWS}\r\n Windows, Messages, Graphics, Controls, Forms, Dialogs, Grids, Menus, Clipbrd,\r\n SysUtils, StdCtrls, Classes,\r\n {$IFDEF HAS_UNIT_SYSTEM_UITYPES}\r\n System.UITypes,\r\n {$ENDIF HAS_UNIT_SYSTEM_UITYPES}\r\n JvJVCLUtils, JvTypes;\r\n\r\n{$DEFINE USECUSTOMGRID}\r\n\r\nconst\r\n JvDefaultBorderColor = TColor($EEF5FF);\r\n\r\ntype\r\n TYearData = record\r\n DisplayText: string;\r\n InfoText: string;\r\n DayInMonth: Integer;\r\n DefaultColor: TColor;\r\n CustomColor: TColor;\r\n Custom: Boolean;\r\n BookMark: Boolean; // this is not saved\r\n end;\r\n\r\n TJvYearGridOrientation = (yoHorizontal, yoVertical);\r\n TJvWeekDay = (wdMonday, wdTuesday, wdWednesday, wdThursday, wdFriday, wdSaturday, wdSunday);\r\n TJvWeekDaySet = set of TJvWeekDay;\r\n TJvAutoSizeOptions = set of (aoGrid, aoFirstColumn, aoFirstRow, aoColumns, aoRows);\r\n\r\n TOnYearChanged = procedure(Sender: TObject; AYear: Integer) of object;\r\n TOnSelectDate = procedure(Sender: TObject; ADate: TDate; InfoText: string; InfoColor: TColor) of object;\r\n TOnInfoChanging = procedure(Sender: TObject; var InfoText: string; var CanChange: Boolean) of object;\r\n\r\n TDays = array [1..12] of Integer;\r\n TYearDatas = array [0..37, 0..12] of TYearData;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n {$IFDEF USECUSTOMGRID}\r\n TJvYearGrid = class(TCustomDrawGrid)\r\n {$ELSE}\r\n TJvYearGrid = class(TDrawGrid)\r\n {$ENDIF USECUSTOMGRID}\r\n private\r\n FGridPop: TPopupMenu;\r\n FCurrentYear: Word;\r\n FCurrentMonth: Word;\r\n FCurrentDay: Word;\r\n FHTMLBorder: Boolean;\r\n FOnYearChanged: TOnYearChanged;\r\n FHTMLFontName: string;\r\n FOnSelectDate: TOnSelectDate;\r\n FBorderColor: TColor;\r\n FOnInfoChanging: TOnInfoChanging;\r\n FBookMarkColor: TColor;\r\n FAutoSize: Boolean;\r\n\r\n DaysInMonth: TDays;\r\n StartDays: TDays;\r\n\r\n FYearData: TYearDatas;\r\n FYearFile: string;\r\n\r\n FOrientation: TJvYearGridOrientation;\r\n\r\n FSavedScrollBars: TScrollStyle;\r\n\r\n {$IFNDEF USECUSTOMGRID}\r\n procedure MouseToCell(X, Y: Integer; var ACol, ARow: Longint);\r\n {$ENDIF !USECUSTOMGRID}\r\n\r\n procedure DoShowHint(var HintStr: THintString; var CanShow: Boolean;\r\n var HintInfo: THintInfo);\r\n procedure MakeHTML(AList: TStringList; Border, Filter: Boolean);\r\n procedure SetHTMLBorder(const Value: Boolean);\r\n\r\n procedure SetYearChanged(const Value: TOnYearChanged);\r\n procedure SetYear(const Value: Integer);\r\n\r\n procedure SetupYearData;\r\n procedure SetupMonths;\r\n function GetCellData(var S: string): Boolean;\r\n function SetCellData(S: string): Boolean;\r\n procedure Copy1Click(Sender: TObject);\r\n procedure Cut1Click(Sender: TObject);\r\n procedure Delete1Click(Sender: TObject);\r\n procedure Paste1Click(Sender: TObject);\r\n procedure CreatePopup;\r\n procedure Edit1Click(Sender: TObject);\r\n procedure Year1Click(Sender: TObject);\r\n procedure Color1Click(Sender: TObject);\r\n procedure NoColor1Click(Sender: TObject);\r\n procedure SetupGridPop(Sender: TObject);\r\n procedure SaveAsHTML(Sender: TObject);\r\n procedure Launch(AFile: string);\r\n procedure SetHTMLFontName(const Value: string);\r\n procedure SetSelectDate(const Value: TOnSelectDate);\r\n procedure SetBorderColor(const Value: TColor);\r\n procedure BorderColor1Click(Sender: TObject);\r\n procedure SetInfoChanging(const Value: TOnInfoChanging);\r\n function DateToCell(ADate: TDate; var ACol, ARow: Integer): Boolean;\r\n procedure ClearBookMarks;\r\n procedure SetBookMarkColor(const Value: TColor);\r\n procedure BookMarkColor1Click(Sender: TObject);\r\n procedure Find1Click(Sender: TObject);\r\n procedure ClearFind1Click(Sender: TObject);\r\n procedure SaveFound(Sender: TObject);\r\n procedure SetOrientation(const Value: TJvYearGridOrientation);\r\n function IsCurrentYear: Boolean;\r\n private\r\n FFirstDayOfWeek: TJvWeekDay;\r\n FWeekendDays: TJvWeekDaySet;\r\n FAutoSizeOptions: TJvAutoSizeOptions;\r\n\r\n FCellMargins: TJvRect;\r\n {$IFNDEF USECUSTOMGRID}\r\n FOnSelectCell: TSelectCellEvent;\r\n FOnDrawCell: TDrawCellEvent;\r\n {$ENDIF !USECUSTOMGRID}\r\n FDaysAlignment: TAlignment;\r\n FDayNamesAlignment: TAlignment;\r\n FMonthNamesAlignment: TAlignment;\r\n FYearAlignment: TAlignment;\r\n FYear: Integer;\r\n\r\n procedure CellMarginsChange(Sender: TObject);\r\n procedure SetFirstDayOfWeek(const Value: TJvWeekDay);\r\n function GetDefaultColWidth: Integer;\r\n function GetDefaultRowHeight: Integer;\r\n procedure SetDefaultColWidth(const Value: Integer);\r\n procedure SetDefaultRowHeihgt(const Value: Integer);\r\n procedure SetFirstColWidth(const Value: Integer);\r\n procedure SetFirstRowHeight(const Value: Integer);\r\n procedure SetWeekendDays(const Value: TJvWeekDaySet);\r\n procedure SetAutoSizeOptions(const Value: TJvAutoSizeOptions);\r\n procedure SetCellMargins(const Value: TJvRect);\r\n procedure SetDayNamesAlignment(const Value: TAlignment);\r\n procedure SetDaysAlignment(const Value: TAlignment);\r\n procedure SetMonthNamesAlignment(const Value: TAlignment);\r\n procedure SetYearAlignment(const Value: TAlignment);\r\n function GetFirstColWidth: Integer;\r\n function GetFirstRowHeight: Integer;\r\n procedure ColRowToDayMonthIndex(ACol, ARow: Integer; var DayIndex, MonthIndex: Integer);\r\n procedure DayMonthIndexToColRow(DayIndex: Integer; MonthIndex: Integer; var ACol, ARow: Integer);\r\n protected\r\n procedure DrawCell(ACol, ARow: Integer; Rect: TRect; State: TGridDrawState); override;\r\n function SelectCell(ACol, ARow: Integer): Boolean; override;\r\n procedure DblClick; override;\r\n procedure SetAutoSize(Value: Boolean); {$IFDEF USECUSTOMGRID} override; {$ENDIF}\r\n procedure UpdateAllSizes;\r\n procedure AdjustBounds;\r\n procedure Loaded; override;\r\n procedure SetParent( AParent: TWinControl); override;\r\n\r\n // Those three methods are used to provide support for reading\r\n // the GridYear property from DFM files that were using\r\n // this component before its rewrite. The writer does nothing\r\n // because the value is now stored as Year.\r\n procedure ReadGridYear(Reader: TReader);\r\n procedure WriteGridYear(Writer: TWriter);\r\n procedure DefineProperties(Filer: TFiler); override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n\r\n procedure LoadYear(FileName: string = '');\r\n procedure SaveYear(FileName: string = '');\r\n\r\n function GetSelDateText: string;\r\n procedure SetSelDateText(AText: string);\r\n\r\n function GetDateInfo(ADate: TDate; var AText: string): Boolean;\r\n function SetDateInfo(ADate: TDate; AText: string): Boolean;\r\n\r\n // This procedure does the default drawing for a given cell\r\n // It is made public so that you can call it in your OnDrawCell event\r\n procedure DefaultDrawCell(ACol, ARow: Integer; Rect: TRect; State: TGridDrawState);\r\n\r\n // Converts a (col, row) couple to a (day, month) couple taking\r\n // into account the orientation. If no day is in the indicated cell\r\n // then the value of ADay is 0 on exit.\r\n procedure ColRowToDayMonth(ACol, ARow: Integer; var ADay, AMonth: Integer);\r\n\r\n // Converts a (day, month) couple to a (col, row) couple taking\r\n // into account the orientation. If the day doesn't exist in the month\r\n // the indicated cell may be outside the grid\r\n procedure DayMonthToColRow(ADay, AMonth: Integer; var ACol, ARow: Integer);\r\n\r\n procedure Find;\r\n published\r\n property HTMLBorder: Boolean read FHTMLBorder write SetHTMLBorder;\r\n property HTMLFontName: string read FHTMLFontName write SetHTMLFontName;\r\n property BorderColor: TColor read FBorderColor write SetBorderColor default JvDefaultBorderColor;\r\n property BookMarkColor: TColor read FBookMarkColor write SetBookMarkColor default clYellow;\r\n property Orientation: TJvYearGridOrientation read FOrientation write SetOrientation default yoHorizontal;\r\n property FirstDayOfWeek: TJvWeekDay read FFirstDayOfWeek write SetFirstDayOfWeek default wdMonday;\r\n\r\n property Year: Integer read FYear write SetYear;\r\n property YearFile: string read FYearFile write FYearFile;\r\n\r\n property AutoSize: Boolean read FAutoSize write SetAutoSize default True;\r\n property AutoSizeOptions: TJvAutoSizeOptions read FAutoSizeOptions write SetAutoSizeOptions;\r\n\r\n property FirstColWidth: Integer read GetFirstColWidth write SetFirstColWidth;\r\n property FirstRowHeight: Integer read GetFirstRowHeight write SetFirstRowHeight;\r\n property CellMargins: TJvRect read FCellMargins write SetCellMargins;\r\n\r\n property WeekendDays: TJvWeekDaySet read FWeekendDays write SetWeekendDays;\r\n\r\n property MonthNamesAlignment: TAlignment read FMonthNamesAlignment write SetMonthNamesAlignment default taLeftJustify;\r\n property DayNamesAlignment: TAlignment read FDayNamesAlignment write SetDayNamesAlignment default taLeftJustify;\r\n property DaysAlignment: TAlignment read FDaysAlignment write SetDaysAlignment default taLeftJustify;\r\n property YearAlignment: TAlignment read FYearAlignment write SetYearAlignment default taLeftJustify;\r\n\r\n {$IFDEF USECUSTOMGRID}\r\n property OnSelectCell;\r\n property OnDrawCell;\r\n {$ELSE}\r\n property OnSelectCell: TSelectCellEvent read FOnSelectCell write FOnSelectCell;\r\n property OnDrawCell: TDrawCellEvent read FOnDrawCell write FOnDrawCell;\r\n {$ENDIF USECUSTOMGRID}\r\n\r\n property OnYearChanged: TOnYearChanged read FOnYearChanged write SetYearChanged;\r\n property OnSelectDate: TOnSelectDate read FOnSelectDate write SetSelectDate;\r\n property OnInfoChanging: TOnInfoChanging read FOnInfoChanging write SetInfoChanging;\r\n property OnDblClick;\r\n property OnClick;\r\n\r\n property DefaultColWidth: Integer read GetDefaultColWidth write SetDefaultColWidth default 16;\r\n property DefaultRowHeight: Integer read GetDefaultRowHeight write SetDefaultRowHeihgt default 18;\r\n\r\n property ScrollBars;\r\n end;\r\n\r\n{.$HPPEMIT '#undef TDate'}\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvYearGrid.pas $';\r\n Revision: '$Revision: 13415 $';\r\n Date: '$Date: 2012-09-10 11:51:54 +0200 (lun. 10 sept. 2012) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n JvConsts, JvResources,\r\n JvYearGridEditForm, JclSysUtils;\r\n\r\nconst\r\n TodayFontColor = clWhite;\r\n TodayBrushColor = clRed;\r\n\r\nconstructor TJvYearGrid.Create(AOwner: TComponent);\r\nvar\r\n AYear, AMonth, ADay: Word;\r\nbegin\r\n inherited Create(AOwner);\r\n\r\n FCellMargins := TJvRect.Create;\r\n FCellMargins.Top := 1;\r\n FCellMargins.Left := 1;\r\n FCellMargins.Bottom := 1;\r\n FCellMargins.Right := 1;\r\n FCellMargins.OnChange := CellMarginsChange; // Must be set last\r\n\r\n FOrientation := yoHorizontal;\r\n\r\n FFirstDayOfWeek := wdMonday;\r\n FWeekendDays := [wdSaturday, wdSunday];\r\n\r\n FAutoSizeOptions := [aoGrid, aoFirstColumn, aoFirstRow, aoColumns, aoRows];\r\n\r\n FBorderColor := JvDefaultBorderColor;\r\n FBookMarkColor := clYellow;\r\n ShowHint := True;\r\n CreatePopup;\r\n PopupMenu := FGridPop;\r\n FGridPop.OnPopup := SetupGridPop;\r\n\r\n // Those two must be set before setting DefaultColWidth and DefaultRowHeight\r\n FirstRowHeight := 18;\r\n FirstColWidth := 70;\r\n\r\n DefaultColWidth := 16;\r\n DefaultRowHeight := 18;//FFirstRowHeight;\r\n\r\n ColCount := 38;\r\n RowCount := 13;\r\n Width := 512;\r\n Height := 213;\r\n\r\n // THIS IS WRONG, VERY WRONG! (obones)\r\n Application.ShowHint := True;\r\n Application.OnShowHint := DoShowHint;\r\n Application.HintHidePause := 5000;\r\n\r\n DecodeDate(Now, FCurrentYear, FCurrentMonth, FCurrentDay);\r\n HTMLFontName := 'Arial';\r\n\r\n DecodeDate(Now, AYear, AMonth, ADay);\r\n FYear := AYear;\r\n SetupYearData;\r\n\r\n FAutoSize := True;\r\n FSavedScrollBars := ScrollBars;\r\n Invalidate;\r\nend;\r\n\r\ndestructor TJvYearGrid.Destroy;\r\nbegin\r\n// SaveYear;\r\n FGridPop.Free;\r\n FCellMargins.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvYearGrid.DrawCell(ACol, ARow: Integer;\r\n Rect: TRect; State: TGridDrawState);\r\nbegin\r\n if Assigned(OnDrawCell) then\r\n OnDrawCell(Self, ACol, ARow, Rect, State)\r\n else\r\n begin\r\n DefaultDrawCell(ACol, ARow, Rect, State);\r\n end;\r\nend;\r\n\r\nprocedure TJvYearGrid.DoShowHint(var HintStr: THintString; var CanShow: Boolean;\r\n var HintInfo: THintInfo);\r\nvar\r\n ACol, ARow, X, Y: Integer;\r\n S, DS: string;\r\nbegin\r\n if HintInfo.HintControl = Self then\r\n begin\r\n X := HintInfo.CursorPos.X;\r\n Y := HintInfo.CursorPos.Y;\r\n MouseToCell(X, Y, ACol, ARow);\r\n if (ACol < 0) or (ARow < 0) then\r\n Exit;\r\n DS := FYearData[ACol, ARow].DisplayText;\r\n if IsCurrentYear and (ARow = FCurrentMonth) and (DS = IntToStr(FCurrentDay)) then\r\n S := RsToday;\r\n CanShow := False;\r\n if (ACol >= 0) and (ARow >= 0) then\r\n begin\r\n S := S + FYearData[ACol, ARow].InfoText;\r\n if S <> '' then\r\n begin\r\n HintInfo.CursorRect := CellRect(ACol, ARow);\r\n HintStr := S;\r\n CanShow := True;\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvYearGrid.MakeHTML(AList: TStringList; Border, Filter: Boolean);\r\nvar\r\n ACol, ARow, W: Integer;\r\n DS, Tbs, Infs: string;\r\n Month, Day: Word;\r\n ADate: TDate;\r\n CanAdd: Boolean;\r\nbegin\r\n AList.Clear;\r\n if Border then\r\n Tbs := '1'\r\n else\r\n Tbs := '0';\r\n AList.Append('Year ' + IntToStr(Year) + '');\r\n AList.Append('');\r\n AList.Append('');\r\n AList.Append('

    Year ' + IntToStr(Year) + '

    ');\r\n AList.Append('');\r\n for ARow := 1 to 12 do\r\n for ACol := 1 to 37 do\r\n begin\r\n CanAdd := FYearData[ACol, ARow].DisplayText <> '';\r\n if CanAdd then\r\n CanAdd := FYearData[ACol, ARow].InfoText <> '';\r\n if CanAdd and Filter then\r\n CanAdd := FYearData[ACol, ARow].BookMark;\r\n if CanAdd then\r\n begin\r\n Month := ARow;\r\n Day := StrToInt(FYearData[ACol, ARow].DisplayText);\r\n ADate := EncodeDate(Year, Month, Day);\r\n DS := FormatDateTime('d-mmm-yyyy', ADate);\r\n W := DayOfWeek(ADate);\r\n DS := JclFormatSettings.ShortDayNames[W] + ' ' + DS;\r\n AList.Append('');\r\n AList.Append('');\r\n Infs := FYearData[ACol, ARow].InfoText;\r\n Infs := StringReplace(Infs, Cr, '
    ', [rfReplaceAll]);\r\n AList.Append('');\r\n AList.Append('');\r\n end;\r\n end;\r\n AList.Append('
    ' + DS + '' + Infs + '
    ');\r\n AList.Append('    ');\r\nend;\r\n\r\nprocedure TJvYearGrid.SaveAsHTML(Sender: TObject);\r\nvar\r\n List: TStringList;\r\n FileName: string;\r\nbegin\r\n List := TStringList.Create;\r\n MakeHTML(List, HTMLBorder, False);\r\n FileName := ChangeFileExt(FYearFile, '.htm');\r\n List.SaveToFile(FileName);\r\n List.Free;\r\n Launch(FileName);\r\nend;\r\n\r\nprocedure TJvYearGrid.SetHTMLBorder(const Value: Boolean);\r\nbegin\r\n FHTMLBorder := Value;\r\nend;\r\n\r\nprocedure TJvYearGrid.SetYearChanged(const Value: TOnYearChanged);\r\nbegin\r\n FOnYearChanged := Value;\r\nend;\r\n\r\nprocedure TJvYearGrid.SetYear(const Value: Integer);\r\nvar\r\n AYear, AMonth, ADay: Word;\r\nbegin\r\n if Value <> FYear then\r\n begin\r\n FYear := Value;\r\n\r\n if Value = 0 then\r\n begin\r\n DecodeDate(Now, AYear, AMonth, ADay);\r\n FYear := AYear;\r\n end\r\n else\r\n FYear := Value;\r\n SetupYearData;\r\n\r\n if Assigned(FOnYearChanged) then\r\n FOnYearChanged(Self, FYear);\r\n end;\r\nend;\r\n\r\nprocedure TJvYearGrid.SaveYear(FileName: string);\r\nvar\r\n MonthIndex, DayIndex: Integer;\r\n YList, DList: TStringList;\r\n S: string;\r\nbegin\r\n YList := TStringList.Create;\r\n DList := TStringList.Create;\r\n\r\n for MonthIndex := 0 to 12 do\r\n begin\r\n for DayIndex := 0 to 37 do\r\n begin\r\n DList.Clear;\r\n DList.Append(FYearData[DayIndex, MonthIndex].DisplayText);\r\n S := FYearData[DayIndex, MonthIndex].InfoText;\r\n S := StringReplace(S, Cr, '||', [rfReplaceAll]);\r\n DList.Append(S);\r\n DList.Append(ColorToString(FYearData[DayIndex, MonthIndex].DefaultColor));\r\n DList.Append(ColorToString(FYearData[DayIndex, MonthIndex].CustomColor));\r\n if FYearData[DayIndex, MonthIndex].Custom then\r\n S := 'true'\r\n else\r\n S := 'false';\r\n DList.Append(S);\r\n YList.Append(DList.CommaText);\r\n end;\r\n end;\r\n if FileName = '' then\r\n YList.SaveToFile(FYearFile)\r\n else\r\n YList.SaveToFile(FileName);\r\n\r\n DList.Free;\r\n YList.Free;\r\nend;\r\n\r\nprocedure TJvYearGrid.LoadYear(FileName: string);\r\nvar\r\n MonthIndex, DayIndex, Index: Integer;\r\n YList, DList: TStringList;\r\n S: string;\r\nbegin\r\n YList := TStringList.Create;\r\n DList := TStringList.Create;\r\n if FileName = '' then\r\n YList.LoadFromFile(FYearFile)\r\n else\r\n YList.LoadFromFile(FileName);\r\n\r\n Index := 0;\r\n for MonthIndex := 0 to 12 do\r\n begin\r\n for DayIndex := 0 to 37 do\r\n begin\r\n DList.CommaText := YList[Index];\r\n Inc(Index);\r\n FYearData[DayIndex, MonthIndex].DisplayText := DList[0];\r\n S := DList[1];\r\n S := StringReplace(S, '||', Cr, [rfReplaceAll]);\r\n FYearData[DayIndex, MonthIndex].InfoText := S;\r\n FYearData[DayIndex, MonthIndex].DefaultColor := StringToColor(DList[2]);\r\n FYearData[DayIndex, MonthIndex].CustomColor := StringToColor(DList[3]);\r\n FYearData[DayIndex, MonthIndex].Custom := (DList[4] = 'true');\r\n end;\r\n end;\r\n DList.Free;\r\n YList.Free;\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvYearGrid.SetupYearData;\r\nvar\r\n S, D: string;\r\n DayOfWeekIndex, DayIndex, MonthIndex: Integer;\r\n AColor: TColor;\r\nbegin\r\n SetupMonths;\r\n for MonthIndex := 0 to 12 do\r\n for DayIndex := 0 to 37 do\r\n begin\r\n S := '';\r\n if DayIndex > 0 then\r\n begin\r\n // This gives a value from 1 to 7, with 1 being the first day\r\n // of the week.\r\n DayOfWeekIndex := ((DayIndex - 1) mod 7) + 1;\r\n\r\n // As ShortDayNames considers the first day to be a Sunday,\r\n // we have to offset the value of DayOfTheWeekIndex to match the\r\n // desired first day of the week\r\n Inc(DayOfWeekIndex, Integer(FFirstDayOfWeek)+1);\r\n If DayOfWeekIndex > 7 then\r\n DayOfWeekIndex := DayOfWeekIndex - 7;\r\n D := JclFormatSettings.ShortDayNames[DayOfWeekIndex][1];\r\n end;\r\n\r\n // By default, there is no day in the current cell\r\n FYearData[DayIndex, MonthIndex].DayInMonth := 0;\r\n\r\n if (MonthIndex = 0) and (DayIndex = 0) then\r\n S := IntToStr(Year);\r\n if (MonthIndex = 0) and (DayIndex > 0) then\r\n S := D;\r\n if (MonthIndex <> 0) and (DayIndex = 0) then\r\n S := JclFormatSettings.LongMonthNames[MonthIndex];\r\n if (MonthIndex <> 0) and (DayIndex > 0) then\r\n begin\r\n if (DayIndex >= StartDays[MonthIndex]) and (DayIndex < StartDays[MonthIndex] + DaysInMonth[MonthIndex]) then\r\n begin\r\n FYearData[DayIndex, MonthIndex].DayInMonth := DayIndex - StartDays[MonthIndex] + 1;\r\n S := IntToStr(FYearData[DayIndex, MonthIndex].DayInMonth);\r\n end;\r\n end;\r\n\r\n // AColor might have not been initialized with the following code.\r\n //if ((ACol>0)and (D='S')) then\r\n // AColor:=clsilver;\r\n //if ((ACol>0)and (D<>'S')) then\r\n // AColor:=clwhite;\r\n // Change to:\r\n if (DayIndex > 0) and (D = 'S') then\r\n AColor := clSilver\r\n else\r\n AColor := clWhite;\r\n FYearData[DayIndex, MonthIndex].DisplayText := S;\r\n FYearData[DayIndex, MonthIndex].InfoText := '';\r\n FYearData[DayIndex, MonthIndex].DefaultColor := AColor;\r\n FYearData[DayIndex, MonthIndex].CustomColor := AColor;\r\n FYearData[DayIndex, MonthIndex].Custom := False;\r\n FYearData[DayIndex, MonthIndex].BookMark := False;\r\n end;\r\n AdjustBounds;\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvYearGrid.ClearBookMarks;\r\nvar\r\n ACol, ARow: Integer;\r\n Cleared: Boolean;\r\nbegin\r\n Cleared := False;\r\n for ARow := 0 to 12 do\r\n for ACol := 0 to 37 do\r\n begin\r\n Cleared := Cleared or FYearData[ACol, ARow].BookMark;\r\n FYearData[ACol, ARow].BookMark := False;\r\n end;\r\n if Cleared then\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvYearGrid.SetupMonths;\r\nvar\r\n AYear, AMonth, ADay: Word;\r\n ADate: TDate;\r\n I: Integer;\r\nbegin\r\n for I := 1 to 12 do\r\n begin\r\n AYear := Self.Year;\r\n AMonth := I + 1;\r\n if AMonth = 13 then\r\n begin\r\n AYear := AYear + 1;\r\n AMonth := 1;\r\n end;\r\n ADay := 1;\r\n ADate := EncodeDate(AYear, AMonth, ADay);\r\n ADate := ADate - 1;\r\n DecodeDate(ADate, AYear, AMonth, ADay);\r\n DaysInMonth[I] := ADay;\r\n AYear := Self.Year;\r\n AMonth := I;\r\n ADay := 1;\r\n ADate := EncodeDate(AYear, AMonth, ADay);\r\n StartDays[I] := DayOfWeek(ADate);\r\n Dec(StartDays[I], Integer(FFirstDayOfWeek)+1);\r\n If StartDays[I] < 1 then\r\n StartDays[I] := StartDays[I] + 7;\r\n end;\r\nend;\r\n\r\nfunction TJvYearGrid.GetCellData(var S: string): Boolean;\r\nvar\r\n ACol, ARow: Integer;\r\nbegin\r\n ACol := Col;\r\n ARow := Row;\r\n Result := False;\r\n if (ACol > 0) and (ARow > 0) then\r\n if FYearData[ACol, ARow].DisplayText <> '' then\r\n begin\r\n S := FYearData[ACol, ARow].InfoText;\r\n Result := True;\r\n end;\r\nend;\r\n\r\nfunction TJvYearGrid.SetCellData(S: string): Boolean;\r\nvar\r\n ACol, ARow: Integer;\r\nbegin\r\n ACol := Col;\r\n ARow := Row;\r\n Result := False;\r\n if (ACol > 0) and (ARow > 0) then\r\n if FYearData[ACol, ARow].DisplayText <> '' then\r\n begin\r\n FYearData[ACol, ARow].InfoText := S;\r\n Result := True;\r\n end;\r\nend;\r\n\r\nprocedure TJvYearGrid.Copy1Click(Sender: TObject);\r\nvar\r\n S: string;\r\nbegin\r\n if GetCellData(S) then\r\n Clipboard.AsText := S;\r\nend;\r\n\r\nprocedure TJvYearGrid.Cut1Click(Sender: TObject);\r\nvar\r\n S: string;\r\nbegin\r\n if GetCellData(S) then\r\n begin\r\n Clipboard.AsText := S;\r\n SetCellData('');\r\n end;\r\nend;\r\n\r\nprocedure TJvYearGrid.Year1Click(Sender: TObject);\r\nvar\r\n S: string;\r\n AYear: Word;\r\nbegin\r\n S := InputBox(RsYearGrid, RsEnterYear, IntToStr(Self.Year));\r\n try\r\n if S = '' then\r\n Exit;\r\n AYear := StrToInt(S);\r\n if (AYear < 1999) or (AYear > 2050) then\r\n Exit;\r\n Self.Year := AYear;\r\n except\r\n ShowMessage(RsInvalidYear);\r\n end;\r\nend;\r\n\r\nprocedure TJvYearGrid.Paste1Click(Sender: TObject);\r\nvar\r\n S: string;\r\nbegin\r\n if GetCellData(S) then\r\n if Clipboard.HasFormat(CF_TEXT) then\r\n SetCellData(Clipboard.AsText);\r\nend;\r\n\r\nprocedure TJvYearGrid.Delete1Click(Sender: TObject);\r\nvar\r\n S: string;\r\nbegin\r\n if GetCellData(S) then\r\n SetCellData('');\r\nend;\r\n\r\nprocedure TJvYearGrid.CreatePopup;\r\nconst\r\n cMenuBreakCaption = '-';\r\nvar\r\n G: TPopupMenu;\r\n M: TMenuItem;\r\nbegin\r\n FGridPop := TPopupMenu.Create(Self);\r\n G := FGridPop;\r\n M := TMenuItem.Create(G);\r\n M.Caption := RsYear;\r\n M.OnClick := Year1Click;\r\n M.Tag := 1;\r\n G.Items.Add(M);\r\n M := TMenuItem.Create(G);\r\n M.Caption := cMenuBreakCaption;\r\n G.Items.Add(M);\r\n M := TMenuItem.Create(G);\r\n M.Caption := RsEdit;\r\n M.OnClick := Edit1Click;\r\n G.Items.Add(M);\r\n M := TMenuItem.Create(G);\r\n M.Caption := RsColor;\r\n M.OnClick := Color1Click;\r\n G.Items.Add(M);\r\n M := TMenuItem.Create(G);\r\n M.Caption := RsNoColor;\r\n M.OnClick := NoColor1Click;\r\n G.Items.Add(M);\r\n M := TMenuItem.Create(G);\r\n M.Caption := cMenuBreakCaption;\r\n G.Items.Add(M);\r\n M := TMenuItem.Create(G);\r\n M.Caption := RsCopyItem;\r\n M.OnClick := Copy1Click;\r\n G.Items.Add(M);\r\n M := TMenuItem.Create(G);\r\n M.Caption := RsCutItem;\r\n M.OnClick := Cut1Click;\r\n G.Items.Add(M);\r\n M := TMenuItem.Create(G);\r\n M.Caption := RsPasteItem;\r\n M.OnClick := Paste1Click;\r\n G.Items.Add(M);\r\n M := TMenuItem.Create(G);\r\n M.Caption := RsDeleteItem;\r\n M.OnClick := Delete1Click;\r\n G.Items.Add(M);\r\n M := TMenuItem.Create(G);\r\n M.Caption := cMenuBreakCaption;\r\n G.Items.Add(M);\r\n M := TMenuItem.Create(G);\r\n M.Caption := RsSaveAllInfo;\r\n M.OnClick := SaveAsHTML;\r\n M.Tag := 1;\r\n G.Items.Add(M);\r\n M := TMenuItem.Create(G);\r\n M.Caption := RsSaveFoundInfo;\r\n M.OnClick := SaveFound;\r\n M.Tag := 1;\r\n G.Items.Add(M);\r\n M := TMenuItem.Create(G);\r\n M.Caption := cMenuBreakCaption;\r\n G.Items.Add(M);\r\n M := TMenuItem.Create(G);\r\n M.Caption := RsBorderColor;\r\n M.OnClick := BorderColor1Click;\r\n M.Tag := 1;\r\n G.Items.Add(M);\r\n M := TMenuItem.Create(G);\r\n M.Caption := RsBookMarkColor;\r\n M.OnClick := BookMarkColor1Click;\r\n M.Tag := 1;\r\n G.Items.Add(M);\r\n M := TMenuItem.Create(G);\r\n M.Caption := cMenuBreakCaption;\r\n G.Items.Add(M);\r\n M := TMenuItem.Create(G);\r\n M.Caption := RsFindItem;\r\n M.OnClick := Find1Click;\r\n M.Tag := 1;\r\n G.Items.Add(M);\r\n M := TMenuItem.Create(G);\r\n M.Caption := RsClearFind;\r\n M.OnClick := ClearFind1Click;\r\n M.Tag := 1;\r\n G.Items.Add(M);\r\nend;\r\n\r\nprocedure TJvYearGrid.Edit1Click(Sender: TObject);\r\nvar\r\n DS: string;\r\n ACol, ARow: Integer;\r\n F: TYearGridEditForm;\r\n CanChange: Boolean;\r\n InfoText: string;\r\nbegin\r\n ACol := Col;\r\n ARow := Row;\r\n if (ACol < 1) or (ARow < 1) then\r\n Exit;\r\n DS := FYearData[Col, Row].DisplayText;\r\n if DS = '' then\r\n Exit;\r\n F := TYearGridEditForm.Create(Application);\r\n InfoText := FYearData[ACol, ARow].InfoText;\r\n F.MemoText.Text := InfoText;\r\n if F.ShowModal = mrOk then\r\n begin\r\n InfoText := F.MemoText.Text;\r\n CanChange := True;\r\n if Assigned(FOnInfoChanging) then\r\n FOnInfoChanging(Self, InfoText, CanChange);\r\n if CanChange then\r\n begin\r\n FYearData[Col, Row].InfoText := InfoText;\r\n if InfoText = '' then\r\n FYearData[Col, Row].Custom := False\r\n else\r\n if not FYearData[Col, Row].Custom then\r\n begin\r\n FYearData[Col, Row].Custom := True;\r\n FYearData[Col, Row].CustomColor := RGB(206, 250, 253);\r\n end;\r\n end;\r\n end;\r\n F.Free;\r\nend;\r\n\r\nprocedure TJvYearGrid.Color1Click(Sender: TObject);\r\nvar\r\n CD: TColorDialog;\r\nbegin\r\n if (Col < 1) or (Row < 1) or (FYearData[Col, Row].DisplayText = '') then\r\n Exit;\r\n CD := TColorDialog.Create(Application);\r\n CD.Options := [cdFullOpen, cdAnyColor];\r\n if CD.Execute then\r\n begin\r\n FYearData[Col, Row].CustomColor := CD.Color;\r\n FYearData[Col, Row].Custom := True;\r\n Invalidate;\r\n end;\r\n CD.Free;\r\nend;\r\n\r\nprocedure TJvYearGrid.NoColor1Click(Sender: TObject);\r\nbegin\r\n if (Col < 1) or (Row < 1) or (FYearData[Col, Row].DisplayText = '') then\r\n Exit;\r\n FYearData[Col, Row].Custom := False;\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvYearGrid.SetupGridPop(Sender: TObject);\r\nvar\r\n I: Integer;\r\nbegin\r\n if (Col > 0) and (Row > 0) and (FYearData[Col, Row].DisplayText <> '') then\r\n for I := 0 to FGridPop.Items.Count - 1 do\r\n FGridPop.Items[I].Enabled := True\r\n else\r\n for I := 0 to FGridPop.Items.Count - 1 do\r\n FGridPop.Items[I].Enabled := (FGridPop.Items[I].Tag = 1);\r\nend;\r\n\r\nprocedure TJvYearGrid.Launch(AFile: string);\r\nvar\r\n Command, Params, WorkDir: string;\r\nbegin\r\n Command := AFile;\r\n Params := '';\r\n WorkDir := '';\r\n ShellExecute(GetForegroundWindow, 'open', PChar(Command),\r\n PChar(Params), PChar(WorkDir), SW_SHOWNORMAL);\r\nend;\r\n\r\nprocedure TJvYearGrid.SetHTMLFontName(const Value: string);\r\nbegin\r\n FHTMLFontName := Value;\r\nend;\r\n\r\nfunction TJvYearGrid.GetSelDateText: string;\r\nvar\r\n DS: string;\r\nbegin\r\n if (Col < 1) or (Row < 1) then\r\n Exit;\r\n DS := FYearData[Col, Row].DisplayText;\r\n if DS = '' then\r\n Exit;\r\n Result := FYearData[Col, Row].InfoText;\r\nend;\r\n\r\nprocedure TJvYearGrid.SetSelDateText(AText: string);\r\nvar\r\n DS, S: string;\r\nbegin\r\n if (Col < 1) or (Row < 1) then\r\n Exit;\r\n DS := FYearData[Col, Row].DisplayText;\r\n if DS = '' then\r\n Exit;\r\n FYearData[Col, Row].InfoText := S;\r\nend;\r\n\r\nprocedure TJvYearGrid.SetSelectDate(const Value: TOnSelectDate);\r\nbegin\r\n FOnSelectDate := Value;\r\nend;\r\n\r\nfunction TJvYearGrid.SelectCell(ACol, ARow: Longint): Boolean;\r\nvar\r\n DS: string;\r\n ADate: TDate;\r\n InfoText: string;\r\n InfoColor: TColor;\r\n// Month, Day: Word;\r\n MonthIndex, DayIndex: Integer;\r\n CanSelect: Boolean;\r\nbegin\r\n CanSelect := True;\r\n if Assigned(OnSelectCell) then\r\n OnSelectCell(Self, ACol, ARow, CanSelect);\r\n if not CanSelect then\r\n begin\r\n Result := False;\r\n Exit;\r\n end;\r\n Result := False;\r\n if (ACol < 1) or (ARow < 1) then\r\n Exit;\r\n\r\n ColRowToDayMonthIndex(ACol, ARow, DayIndex, MonthIndex);\r\n\r\n DS := FYearData[DayIndex, MonthIndex].DisplayText;\r\n if DS = '' then\r\n Exit;\r\n// Month := ARow;\r\n// Day := StrToInt(FYearData[ACol, ARow].DisplayText);\r\n ADate := EncodeDate(Year, MonthIndex, FYearData[DayIndex, MonthIndex].DayInMonth);\r\n InfoText := FYearData[DayIndex, MonthIndex].InfoText;\r\n if FYearData[DayIndex, MonthIndex].Custom then\r\n InfoColor := FYearData[DayIndex, MonthIndex].CustomColor\r\n else\r\n InfoColor := FYearData[DayIndex, MonthIndex].DefaultColor;\r\n if Assigned(FOnSelectDate) then\r\n FOnSelectDate(Self, ADate, InfoText, InfoColor);\r\n Result := True;\r\nend;\r\n\r\nprocedure TJvYearGrid.DblClick;\r\nbegin\r\n if Assigned(OnDblClick) then\r\n OnDblClick(Self)\r\n else\r\n if (Col > 0) and (Row > 0) and (FYearData[Col, Row].DisplayText <> '') then\r\n Edit1Click(nil);\r\nend;\r\n\r\nprocedure TJvYearGrid.SetBorderColor(const Value: TColor);\r\nbegin\r\n if Value <> FBorderColor then\r\n begin\r\n FBorderColor := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvYearGrid.BorderColor1Click(Sender: TObject);\r\nvar\r\n CD: TColorDialog;\r\nbegin\r\n CD := TColorDialog.Create(Application);\r\n CD.Options := [cdFullOpen, cdAnyColor];\r\n if CD.Execute then\r\n BorderColor := CD.Color;\r\n CD.Free;\r\nend;\r\n\r\nprocedure TJvYearGrid.BookMarkColor1Click(Sender: TObject);\r\nvar\r\n CD: TColorDialog;\r\nbegin\r\n CD := TColorDialog.Create(Application);\r\n CD.Options := [cdFullOpen, cdAnyColor];\r\n if CD.Execute then\r\n BookMarkColor := CD.Color;\r\n CD.Free;\r\nend;\r\n\r\nprocedure TJvYearGrid.SetInfoChanging(const Value: TOnInfoChanging);\r\nbegin\r\n FOnInfoChanging := Value;\r\nend;\r\n\r\nfunction TJvYearGrid.DateToCell(ADate: TDate; var ACol, ARow: Integer): Boolean;\r\nvar\r\n AYear, AMonth, ADay: Word;\r\n WD: Integer;\r\nbegin\r\n Result := False;\r\n DecodeDate(ADate, AYear, AMonth, ADay);\r\n if AYear <> Self.Year then\r\n Exit;\r\n WD := DayOfWeek(EncodeDate(AYear, AMonth, 1));\r\n Inc(WD, Integer(FirstDayOfWeek));\r\n if WD > 7 then\r\n Dec(WD, 7);\r\n DayMonthIndexToColRow(WD + ADay - 1, AMonth, ACol, ARow);\r\n Result := True;\r\nend;\r\n\r\nfunction TJvYearGrid.GetDateInfo(ADate: TDate; var AText: string): Boolean;\r\nvar\r\n Col, Row: Integer;\r\nbegin\r\n Result := DateToCell(ADate, Col, Row);\r\n if Result then\r\n AText := FYearData[Col, Row].InfoText;\r\nend;\r\n\r\nfunction TJvYearGrid.SetDateInfo(ADate: TDate; AText: string): Boolean;\r\nvar\r\n Col, Row: Integer;\r\nbegin\r\n Result := DateToCell(ADate, Col, Row);\r\n if Result then\r\n FYearData[Col, Row].InfoText := AText;\r\nend;\r\n\r\nprocedure TJvYearGrid.SetBookMarkColor(const Value: TColor);\r\nbegin\r\n if Value <> FBookMarkColor then\r\n begin\r\n FBookMarkColor := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvYearGrid.Find1Click(Sender: TObject);\r\nvar\r\n S: string;\r\n Col, Row: Integer;\r\nbegin\r\n ClearBookMarks;\r\n S := InputBox(RsYearGridFind, RsEnterSeachText, '');\r\n if S = '' then\r\n Exit;\r\n S := LowerCase(S);\r\n for Row := 0 to 12 do\r\n for Col := 0 to 37 do\r\n if Pos(S, LowerCase(FYearData[Col, Row].InfoText)) > 0 then\r\n FYearData[Col, Row].BookMark := True;\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvYearGrid.ClearFind1Click(Sender: TObject);\r\nbegin\r\n ClearBookMarks;\r\nend;\r\n\r\nprocedure TJvYearGrid.Find;\r\nbegin\r\n Find1Click(nil);\r\nend;\r\n\r\nprocedure TJvYearGrid.SaveFound(Sender: TObject);\r\nvar\r\n List: TStringList;\r\n FileName: string;\r\nbegin\r\n List := TStringList.Create;\r\n MakeHTML(List, HTMLBorder, True);\r\n FileName := Format(RsFounds, [ChangeFileExt(FYearFile, '.htm')]);\r\n List.SaveToFile(FileName);\r\n List.Free;\r\n Launch(FileName);\r\nend;\r\n\r\nprocedure TJvYearGrid.SetOrientation(const Value: TJvYearGridOrientation);\r\nbegin\r\n if FOrientation <> Value then\r\n begin\r\n FOrientation := Value;\r\n if FOrientation = yoHorizontal then\r\n begin\r\n ColCount := 38;\r\n RowCount := 13;\r\n end\r\n else\r\n begin\r\n ColCount := 13;\r\n RowCount := 38;\r\n end;\r\n AdjustBounds;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvYearGrid.SetFirstDayOfWeek(const Value: TJvWeekDay);\r\nbegin\r\n if FFirstDayOfWeek <> Value then\r\n begin\r\n FFirstDayOfWeek := Value;\r\n SetupYearData;\r\n end;\r\nend;\r\n\r\nprocedure TJvYearGrid.SetAutoSize(Value: Boolean);\r\nbegin\r\n if Value then\r\n begin\r\n if (aoGrid in AutoSizeOptions) then\r\n begin\r\n FSavedScrollBars := ScrollBars;\r\n ScrollBars := ssNone;\r\n end;\r\n end\r\n else\r\n ScrollBars := FSavedScrollBars;\r\n\r\n FAutoSize := Value;\r\n AdjustBounds;\r\nend;\r\n\r\nfunction TJvYearGrid.GetDefaultColWidth: Integer;\r\nbegin\r\n Result := inherited DefaultColWidth;\r\nend;\r\n\r\nfunction TJvYearGrid.GetDefaultRowHeight: Integer;\r\nbegin\r\n Result := inherited DefaultRowHeight;\r\nend;\r\n\r\nprocedure TJvYearGrid.SetDefaultColWidth(const Value: Integer);\r\nvar\r\n SavedFirstColWidth: Integer;\r\nbegin\r\n SavedFirstColWidth := ColWidths[0];\r\n inherited DefaultColWidth := Value;\r\n ColWidths[0] := SavedFirstColWidth;\r\nend;\r\n\r\nprocedure TJvYearGrid.SetDefaultRowHeihgt(const Value: Integer);\r\nvar\r\n SavedFirstRowHeight: Integer;\r\nbegin\r\n SavedFirstRowHeight := RowHeights[0];\r\n inherited DefaultRowHeight := Value;\r\n RowHeights[0] := SavedFirstRowHeight;\r\nend;\r\n\r\nprocedure TJvYearGrid.SetFirstColWidth(const Value: Integer);\r\nbegin\r\n ColWidths[0] := Value;\r\nend;\r\n\r\nprocedure TJvYearGrid.SetFirstRowHeight(const Value: Integer);\r\nbegin\r\n RowHeights[0] := Value;\r\nend;\r\n\r\nprocedure TJvYearGrid.SetWeekendDays(const Value: TJvWeekDaySet);\r\nbegin\r\n FWeekendDays := Value;\r\nend;\r\n\r\nprocedure TJvYearGrid.SetAutoSizeOptions(const Value: TJvAutoSizeOptions);\r\nbegin\r\n FAutoSizeOptions := Value;\r\nend;\r\n\r\nprocedure TJvYearGrid.UpdateAllSizes;\r\nvar\r\n I: Integer;\r\n CurValue: Integer;\r\n MaxValue: Integer;\r\n\r\n function GetHighestTextInRow(Row: Integer): Integer;\r\n var\r\n I: Integer;\r\n CurValue: Integer;\r\n begin\r\n // find the highest text in the row.\r\n Result := 0;\r\n for I := 0 to ColCount-1 do\r\n begin\r\n if Orientation = yoHorizontal then\r\n CurValue := Canvas.TextHeight(FYearData[I,Row].DisplayText)\r\n else\r\n CurValue := Canvas.TextHeight(FYearData[Row,I].DisplayText);\r\n if CurValue > Result then\r\n Result := CurValue;\r\n end;\r\n end;\r\n\r\n function GetLargestTextInColumn(Column: Integer): Integer;\r\n var\r\n I: Integer;\r\n CurValue: Integer;\r\n begin\r\n // find the largest text in the column\r\n Result := 0;\r\n for I := 0 to RowCount-1 do\r\n begin\r\n if Orientation = yoHorizontal then\r\n CurValue := Canvas.TextWidth(FYearData[Column,I].DisplayText)\r\n else\r\n CurValue := Canvas.TextWidth(FYearData[I,Column].DisplayText);\r\n if CurValue > Result then\r\n Result := CurValue;\r\n end;\r\n end;\r\nbegin\r\n if AutoSize then\r\n begin\r\n if aoFirstRow in AutoSizeOptions then\r\n RowHeights[0] := GetHighestTextInRow(0) + CellMargins.Top + CellMargins.Bottom;\r\n\r\n if aoFirstColumn in AutoSizeOptions then\r\n ColWidths[0] := GetLargestTextInColumn(0) + CellMargins.Left + CellMargins.Right;\r\n\r\n if aoRows in AutoSizeOptions then\r\n begin\r\n // find the highest text in each row and only use the\r\n // highest value among those found\r\n MaxValue := 0;\r\n for I := 1 to RowCount-1 do\r\n begin\r\n CurValue := GetHighestTextInRow(I);\r\n if CurValue > MaxValue then\r\n MaxValue := CurValue;\r\n end;\r\n\r\n for I := 1 to RowCount-1 do\r\n RowHeights[I] := MaxValue+ CellMargins.Top + CellMargins.Bottom;\r\n end;\r\n\r\n if aoColumns in AutoSizeOptions then\r\n begin\r\n // find the largest text in each column and only use\r\n // the highest value among those found\r\n MaxValue := 0;\r\n for I := 1 to ColCount-1 do\r\n begin\r\n CurValue := GetLargestTextInColumn(I);\r\n if CurValue > MaxValue then\r\n MaxValue := CurValue;\r\n end;\r\n\r\n for I := 1 to ColCount-1 do\r\n ColWidths[I] := MaxValue + CellMargins.Left + CellMargins.Top;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvYearGrid.SetCellMargins(const Value: TJvRect);\r\nbegin\r\n FCellMargins.Assign(Value);\r\n AdjustBounds;\r\nend;\r\n\r\nprocedure TJvYearGrid.AdjustBounds;\r\nvar\r\n I: Integer;\r\n NewWidth, NewHeight: Integer;\r\nbegin\r\n if not (csReading in ComponentState) and FAutoSize then\r\n begin\r\n UpdateAllSizes;\r\n if aoGrid in AutoSizeOptions then\r\n begin\r\n NewWidth := GridLineWidth + {GetSystemMetrics(SM_CXVSCROLL) +} 4;\r\n for I := 0 to ColCount-1 do\r\n Inc(NewWidth, ColWidths[I]+GridLineWidth);\r\n NewHeight := GridLineWidth + {GetSystemMetrics(SM_CYHSCROLL) +} 4;\r\n for I := 0 to RowCount-1 do\r\n Inc(NewHeight, RowHeights[I]+GridLineWidth);\r\n SetBounds(Left, Top, NewWidth, NewHeight);\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvYearGrid.Loaded;\r\nbegin\r\n inherited Loaded;\r\n AdjustBounds;\r\nend;\r\n\r\nprocedure TJvYearGrid.SetParent( AParent: TWinControl);\r\nbegin\r\n inherited SetParent(AParent);\r\n if Parent <> nil then\r\n AdjustBounds;\r\nend;\r\n\r\nprocedure TJvYearGrid.CellMarginsChange(Sender: TObject);\r\nbegin\r\n AdjustBounds;\r\nend;\r\n\r\nprocedure TJvYearGrid.SetDayNamesAlignment(const Value: TAlignment);\r\nbegin\r\n if FDayNamesAlignment <> Value then\r\n begin\r\n FDayNamesAlignment := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvYearGrid.SetDaysAlignment(const Value: TAlignment);\r\nbegin\r\n if FDaysAlignment <> Value then\r\n begin\r\n FDaysAlignment := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvYearGrid.SetMonthNamesAlignment(const Value: TAlignment);\r\nbegin\r\n if FMonthNamesAlignment <> Value then\r\n begin\r\n FMonthNamesAlignment := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvYearGrid.SetYearAlignment(const Value: TAlignment);\r\nbegin\r\n if FYearAlignment <> Value then\r\n begin\r\n FYearAlignment := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nfunction TJvYearGrid.GetFirstColWidth: Integer;\r\nbegin\r\n Result := ColWidths[0];\r\nend;\r\n\r\nfunction TJvYearGrid.GetFirstRowHeight: Integer;\r\nbegin\r\n Result := RowHeights[0];\r\nend;\r\n\r\nfunction TJvYearGrid.IsCurrentYear: Boolean;\r\nbegin\r\n Result := Year = FCurrentYear;\r\nend;\r\n\r\n{$IFNDEF USECUSTOMGRID}\r\nprocedure TJvYearGrid.MouseToCell(X, Y: Integer; var ACol, ARow: Integer);\r\nvar\r\n Coord: TGridCoord;\r\nbegin\r\n Coord := MouseCoord(X, Y);\r\n ACol := Coord.X;\r\n ARow := Coord.Y;\r\nend;\r\n{$ENDIF !USECUSTOMGRID}\r\n\r\nprocedure TJvYearGrid.ReadGridYear(Reader: TReader);\r\nbegin\r\n Year := Reader.ReadInteger;\r\nend;\r\n\r\nprocedure TJvYearGrid.WriteGridYear(Writer: TWriter);\r\nbegin\r\n // Do nothing, we only provide read support for legacy reasons\r\nend;\r\n\r\nprocedure TJvYearGrid.DefineProperties(Filer: TFiler);\r\nbegin\r\n inherited;\r\n Filer.DefineProperty('GridYear', ReadGridYear, WriteGridYear, False);\r\nend;\r\n\r\nprocedure TJvYearGrid.ColRowToDayMonthIndex(ACol, ARow: Integer;\r\n var DayIndex, MonthIndex: Integer);\r\nbegin\r\n if Orientation = yoHorizontal then\r\n begin\r\n DayIndex := ACol;\r\n MonthIndex := ARow;\r\n end\r\n else\r\n begin\r\n DayIndex := ARow;\r\n MonthIndex := ACol;\r\n end;\r\nend;\r\n\r\nprocedure TJvYearGrid.DayMonthIndexToColRow(DayIndex, MonthIndex: Integer;\r\n var ACol, ARow: Integer);\r\nbegin\r\n if Orientation = yoHorizontal then\r\n begin\r\n ACol := DayIndex;\r\n ARow := MonthIndex;\r\n end\r\n else\r\n begin\r\n ARow := DayIndex;\r\n ACol := MonthIndex;\r\n end;\r\nend;\r\n\r\nprocedure TJvYearGrid.ColRowToDayMonth(ACol, ARow: Integer; var ADay,\r\n AMonth: Integer);\r\nvar\r\n DayIndex, MonthIndex: Integer;\r\nbegin\r\n ColRowToDayMonthIndex(ACol, ARow, DayIndex, MonthIndex);\r\n AMonth := MonthIndex;\r\n ADay := FYearData[MonthIndex, DayIndex].DayInMonth;\r\nend;\r\n\r\nprocedure TJvYearGrid.DayMonthToColRow(ADay, AMonth: Integer; var ACol,\r\n ARow: Integer);\r\nbegin\r\n DayMonthIndexToColRow(ADay, AMonth, ACol, ARow);\r\nend;\r\n\r\nprocedure TJvYearGrid.DefaultDrawCell(ACol, ARow: Integer; Rect: TRect;\r\n State: TGridDrawState);\r\nvar\r\n S: string;\r\n MonthIndex: Integer;\r\n DayIndex: Integer;\r\n SWidth: Integer;\r\n TextLeft: Integer;\r\n\r\n function GetTextLeft(Alignment: TAlignment): Integer;\r\n begin\r\n case Alignment of\r\n taRightJustify:\r\n Result := Rect.Right - SWidth - CellMargins.Right;\r\n taCenter:\r\n Result := Rect.Left + (Rect.Right-Rect.Left - SWidth - CellMargins.Left - CellMargins.Right + 2) div 2;\r\n else\r\n Result := Rect.Left + CellMargins.Left;\r\n end;\r\n end;\r\n\r\nbegin\r\n ColRowToDayMonthIndex(ACol, ARow, DayIndex, MonthIndex);\r\n\r\n S := FYearData[DayIndex, MonthIndex].DisplayText;\r\n TextLeft := Rect.Left;\r\n with Canvas do\r\n begin\r\n SWidth := TextWidth(S);\r\n Font.Color := clBlack;\r\n Font.Style := Font.Style - [fsBold];\r\n if (DayIndex = 0) then\r\n begin\r\n Brush.Color := BorderColor;\r\n TextLeft := GetTextLeft(MonthNamesAlignment);\r\n end;\r\n\r\n if (MonthIndex = 0) then\r\n begin\r\n if (FYearData[DayIndex, MonthIndex].DefaultColor = clWhite) then\r\n Brush.Color := BorderColor;\r\n\r\n if DayIndex = 0 then\r\n TextLeft := GetTextLeft(YearAlignment)\r\n else\r\n TextLeft := GetTextLeft(DayNamesAlignment);\r\n end;\r\n\r\n if (DayIndex > 0) and (MonthIndex > 0) then\r\n begin\r\n TextLeft := GetTextLeft(DaysAlignment);\r\n if IsCurrentYear and (MonthIndex = FCurrentMonth) and (S = IntToStr(FCurrentDay)) then\r\n begin\r\n Font.Color := TodayFontColor;\r\n Brush.Color := TodayBrushColor;\r\n Font.Style := Font.Style + [fsBold];\r\n end\r\n else\r\n if FYearData[DayIndex, MonthIndex].Custom then\r\n Brush.Color := FYearData[DayIndex, MonthIndex].CustomColor\r\n else\r\n Brush.Color := FYearData[DayIndex, MonthIndex].DefaultColor;\r\n end;\r\n if FYearData[DayIndex, MonthIndex].BookMark then\r\n Brush.Color := BookMarkColor;\r\n TextRect(Rect, TextLeft, Rect.Top, S);\r\n end;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend." }, { "path": "External/Jedi/Jvcl/run/JvYearGridEditForm.dfm", "content": "object YearGridEditForm: TYearGridEditForm\r\n Left = 303\r\n Top = 154\r\n BorderStyle = bsDialog\r\n Caption = 'YearGrid Edit'\r\n ClientHeight = 364\r\n ClientWidth = 313\r\n Color = clBtnFace\r\n Font.Charset = DEFAULT_CHARSET\r\n Font.Color = clWindowText\r\n Font.Height = -11\r\n Font.Name = 'MS Sans Serif'\r\n Font.Style = []\r\n OldCreateOrder = True\r\n Position = poScreenCenter\r\n OnShow = FormShow\r\n PixelsPerInch = 96\r\n TextHeight = 13\r\n object Panel1: TPanel\r\n Left = 0\r\n Top = 331\r\n Width = 313\r\n Height = 33\r\n Align = alBottom\r\n TabOrder = 0\r\n object BitBtn1: TBitBtn\r\n Left = 160\r\n Top = 7\r\n Width = 65\r\n Height = 22\r\n TabOrder = 0\r\n Kind = bkOK\r\n end\r\n object BitBtn2: TBitBtn\r\n Left = 233\r\n Top = 7\r\n Width = 77\r\n Height = 22\r\n TabOrder = 1\r\n Kind = bkCancel\r\n end\r\n object BtnLoad: TButton\r\n Left = 5\r\n Top = 7\r\n Width = 60\r\n Height = 22\r\n Caption = '&Load...'\r\n TabOrder = 2\r\n OnClick = BtnLoadClick\r\n end\r\n object BtnSave: TButton\r\n Left = 70\r\n Top = 7\r\n Width = 59\r\n Height = 22\r\n Caption = '&Save...'\r\n TabOrder = 3\r\n OnClick = BtnSaveClick\r\n end\r\n end\r\n object MemoText: TMemo\r\n Left = 0\r\n Top = 0\r\n Width = 313\r\n Height = 331\r\n Align = alClient\r\n TabOrder = 1\r\n end\r\n object OpenDialog: TOpenDialog\r\n Filter = 'Text Files|*.txt|All Files|*.*'\r\n Left = 88\r\n Top = 104\r\n end\r\n object SaveDialog: TSaveDialog\r\n DefaultExt = 'txt'\r\n Filter = 'Text Files|*.txt|All Files|*.*'\r\n Left = 120\r\n Top = 104\r\n end\r\nend\r\n" }, { "path": "External/Jedi/Jvcl/run/JvYearGridEditForm.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvYearGridEdit.PAS, released on 2002-06-15.\r\n\r\nThe Initial Developer of the Original Code is Jan Verhoeven [jan1 dott verhoeven att wxs dott nl]\r\nPortions created by Jan Verhoeven are Copyright (C) 2002 Jan Verhoeven.\r\nAll Rights Reserved.\r\n\r\nContributor(s): Robert Love [rlove att slcdug dott org].\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvYearGridEditForm.pas 12461 2009-08-14 17:21:33Z obones $\r\n\r\nunit JvYearGridEditForm;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n SysUtils, Classes, Windows, Messages, Graphics, Controls,\r\n Forms, Dialogs, StdCtrls, Buttons, ExtCtrls,\r\n JvComponent;\r\n\r\ntype\r\n TYearGridEditForm = class(TJvForm)\r\n Panel1: TPanel;\r\n BitBtn1: TBitBtn;\r\n BitBtn2: TBitBtn;\r\n MemoText: TMemo;\r\n BtnLoad: TButton;\r\n BtnSave: TButton;\r\n OpenDialog: TOpenDialog;\r\n SaveDialog: TSaveDialog;\r\n procedure BtnLoadClick(Sender: TObject);\r\n procedure BtnSaveClick(Sender: TObject);\r\n procedure FormShow(Sender: TObject);\r\n public\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvYearGridEditForm.pas $';\r\n Revision: '$Revision: 12461 $';\r\n Date: '$Date: 2009-08-14 19:21:33 +0200 (ven. 14 août 2009) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\n\r\n{$R *.dfm}\r\n\r\nprocedure TYearGridEditForm.BtnLoadClick(Sender: TObject);\r\nbegin\r\n if OpenDialog.Execute then\r\n MemoText.Lines.LoadFromFile(OpenDialog.FileName);\r\n MemoText.SetFocus;\r\nend;\r\n\r\nprocedure TYearGridEditForm.BtnSaveClick(Sender: TObject);\r\nbegin\r\n if SaveDialog.Execute then\r\n MemoText.Lines.SaveToFile(SaveDialog.FileName);\r\n MemoText.SetFocus;\r\nend;\r\n\r\nprocedure TYearGridEditForm.FormShow(Sender: TObject);\r\nbegin\r\n MemoText.SetFocus;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend." }, { "path": "External/Jedi/Jvcl/run/JvZlibMultiple.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvZlibMultiple.PAS, released on 2001-02-28.\r\n\r\nThe Initial Developer of the Original Code is S?stien Buysse [sbuysse att buypin dott com]\r\nPortions created by S?stien Buysse are Copyright (C) 2001 S?stien Buysse.\r\nAll Rights Reserved.\r\n\r\nContributor(s): Michael Beck [mbeck att bigfoot dott com].\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n 2004-07-27 - Read the 'ALL USERS READ THIS' section below.\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvZlibMultiple.pas 13104 2011-09-07 06:50:43Z obones $\r\n\r\n{$I jvcl.inc}\r\n\r\nunit JvZlibMultiple;\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n {$IFDEF MSWINDOWS}\r\n Windows, // inline\r\n {$ENDIF MSWINDOWS}\r\n SysUtils, Classes, Graphics, Controls, Dialogs,\r\n JclCompression,\r\n JvComponentBase;\r\n\r\n// ----------------------------------------------------------------------------}\r\n// 2004-07-27 *** ALL USERS READ THIS: (wpostma) ***\r\n//\r\n// I have added support for selective extraction and listing archive contents without\r\n// writing any files to disk. To do this we had to add some parameters to the component events.\r\n//\r\n// This will break existing applications that use these events, until they update their\r\n// event declarations, to add the new parameters to your events.\r\n//\r\n// This is something the Delphi IDE should do automatically, but does not do. \r\n//\r\n// The old events for OnDecompressingFile, and OnDecompressedFile\r\n// look like this:\r\n// procedure <>(Sender: TObject; const FileName: string)\r\n//\r\n// The new events have an additional parameter each:\r\n//\r\n// OnDecompressingFile -> (Sender: TObject; const FileName: string;\r\n// {NEW!} var WriteFile: Boolean )\r\n// OnDecompressedFile -> (Sender: TObject; const FileName: string;\r\n// {NEW!} const FileSize: Longword )\r\n//\r\n// -----------------------------------------------------------------------------}\r\n\r\n{ November 11, 2005 - yozey\r\n\r\n NOTE #1\r\n Added new procedures to pause and terminate the compression process.\r\n These would be very useful in a threaded environment.\r\n\r\n NOTE #2 December 22, 2005 - Johann Campbell\r\n - Added new procedure to list files stored in the zlib file ( basic rewrite of the decompression procedure )\r\n - Exposed the Pause and Terminate procedures\r\n\r\n See below.\r\n}\r\n\r\ntype\r\n {NEW:}\r\n TFileBeforeWriteEvent = procedure(Sender: TObject; const FileName: string; var WriteFile: Boolean) of object;\r\n TFileAfterWriteEvent = procedure(Sender: TObject; const FileName: string; const FileSize: Longword) of object;\r\n\r\n TFileSkipEvent = procedure (Sender:Tobject;const Filename,errortype,errormessage:String);\r\n\r\n TFileEvent = procedure(Sender: TObject; const FileName: string) of object;\r\n TProgressEvent = procedure(Sender: TObject; Position, Total: Integer) of object;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64 or pidOSX32)]\r\n {$ENDIF RTL230_UP}\r\n TJvZlibMultiple = class(TJvComponent)\r\n private\r\n FStorePaths: Boolean;\r\n FIgnoreExclusive: Boolean; // November 7, 2004 - USE WITH CAUTION !!!!!\r\n FCompressionLevel: TJclCompressionLevel;\r\n FOnProgress: TProgressEvent;\r\n FOnCompressingFile: TFileEvent;\r\n FOnCompressedFile: TFileEvent;\r\n FOnCompletedAction: TNotifyEvent;\r\n FOnFileSkip : TFileSkipEvent;\r\n \r\n // July 26, 2004: New improved event types for decompression: Allow user to\r\n // skip writing of files they want skipped on extraction, and if they\r\n // extract nothing, they can use this \"nil extraction\" to scan the contents\r\n // of the file, returning the file names and sizes inside.\r\n FOnDecompressingFile: TFileBeforeWriteEvent;\r\n FOnDecompressedFile: TFileAfterWriteEvent;\r\n FTerminateCompress: Boolean; // Note #1\r\n FTerminateDecompress: Boolean; // Note #1\r\n FCompressionPause: Boolean; // Note #1\r\n FDecompressionPause: Boolean; // Note #1\r\n FForceDirectoriesFlag: Boolean;\r\n procedure SetForceDirectoriesFlag(const Value: Boolean); // set true to force directories\r\n protected\r\n procedure AddFile(const FileName, Directory, FilePath: string; DestStream: TStream);\r\n procedure DoProgress(Position, Total: Integer); virtual;\r\n procedure DoStopCompression; // Note #1\r\n procedure DoStopDecompression; // Note #1\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n // compresses a list of files (can contain wildcards)\r\n // NOTE: caller must free returned stream!\r\n function CompressFiles(Files: TStrings): TStream; overload;\r\n // compresses a list of files (can contain wildcards)\r\n // and saves the compressed result to FileName\r\n procedure CompressFiles(Files: TStrings; const FileName: string); overload;\r\n // compresses a Directory (recursing if Recursive is true)\r\n // NOTE: caller must free returned stream!\r\n function CompressDirectory(Directory: string; Recursive: Boolean): TStream; overload;\r\n // compresses a Directory (recursing if Recursive is true)\r\n // and saves the compressed result to FileName\r\n procedure CompressDirectory(const Directory: string; Recursive: Boolean; const FileName: string); overload;\r\n // decompresses FileName into Directory. If Overwrite is true, overwrites any existing files with\r\n // the same name as those in the compressed archive.\r\n // If RelativePaths is true, the paths in the compressed file are stripped from their drive letter\r\n procedure DecompressFile(const FileName, Directory: string; Overwrite: Boolean;\r\n const RelativePaths: Boolean = True);\r\n // decompresses Stream into Directory optionally overwriting any existing files\r\n // If RelativePaths is true, any paths in the stream are stripped from their drive letter\r\n procedure ListStoredFiles(const FileName: string; FileList: TStrings); // Note #2\r\n procedure DecompressStream(Stream: TStream; Directory: string; Overwrite: Boolean;\r\n const RelativePaths: Boolean = True);\r\n procedure StopCompression; // Note #1\r\n procedure StopDecompression; // Note #1\r\n property CompressionPaused: Boolean read FCompressionPause write FCompressionPause; // Note #1\r\n property DecompressionPaused: Boolean read FDecompressionPause write FDecompressionPause; // Note #1\r\n\r\n property OnFileSkip :TFileSkipEvent read FOnFileSkip write FOnFileSkip;\r\n\r\n published\r\n property StorePaths: Boolean read FStorePaths write FStorePaths default True;\r\n // NOTE : This property allows you to override already opened files - USE WITH CAUTION!!! opened files may still be writing data\r\n // causing stored files to be different from the final file.\r\n property IgnoreExclusive: Boolean read FIgnoreExclusive write FIgnoreExclusive default False;\r\n property CompressionLevel: TJclCompressionLevel read FCompressionLevel write FCompressionLevel default -1;\r\n property ForceDirectoriesFlag: Boolean read FForceDirectoriesFlag write SetForceDirectoriesFlag default True; // NEW MARCH 2007!\r\n // NOTE: Changed decompression event parameters. July 26 2004. -WPostma.\r\n property OnDecompressingFile: TFileBeforeWriteEvent read FOnDecompressingFile write FOnDecompressingFile;\r\n property OnDecompressedFile: TFileAfterWriteEvent read FOnDecompressedFile write FOnDecompressedFile;\r\n property OnProgress: TProgressEvent read FOnProgress write FOnProgress;\r\n property OnCompressingFile: TFileEvent read FOnCompressingFile write FOnCompressingFile;\r\n property OnCompressedFile: TFileEvent read FOnCompressedFile write FOnCompressedFile;\r\n property OnCompletedAction: TNotifyEvent read FOnCompletedAction write FOnCompletedAction;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvZlibMultiple.pas $';\r\n Revision: '$Revision: 13104 $';\r\n Date: '$Date: 2011-09-07 08:50:43 +0200 (mer. 07 sept. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n JvJCLUtils;\r\n\r\n{*******************************************************}\r\n{ Format of the File: }\r\n{ File Header }\r\n{ 1 Byte Size of the directory variable }\r\n{ x bytes Directory of the file }\r\n{ 1 Byte Size of the filename }\r\n{ x bytes Filename }\r\n{ 4 bytes Size of the file (uncompressed) }\r\n{ 4 bytes Size of the file (compressed) }\r\n{ Data chunk }\r\n{ x bytes the compressed chunk }\r\n{*******************************************************}\r\n\r\nconstructor TJvZlibMultiple.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FStorePaths := True;\r\n FIgnoreExclusive := False;\r\n FCompressionLevel := -1;\r\n FForceDirectoriesFlag := true;\r\nend;\r\n\r\nfunction TJvZlibMultiple.CompressDirectory(Directory: string; Recursive: Boolean): TStream;\r\n\r\n procedure SearchDirectory(const SDirectory: string);\r\n var\r\n SearchRec: TSearchRec;\r\n Res: Integer;\r\n fn:String;\r\n begin\r\n // (rom) this may not work for network drives and compressed files\r\n // (rom) because of faAnyFile\r\n Res := FindFirst(Directory + SDirectory + AllFilesMask, faAnyFile, SearchRec);\r\n try\r\n while Res = 0 do\r\n begin\r\n if (SearchRec.Name <> '.') and (SearchRec.Name <> '..') then\r\n begin\r\n if (SearchRec.Attr and faDirectory) = 0 then begin\r\n try\r\n fn := Directory + SDirectory + SearchRec.Name;\r\n AddFile(SearchRec.Name, SDirectory, fn, Result)\r\n except\r\n on E:EFOpenError do begin\r\n if Assigned(FOnFileSkip) then begin\r\n FOnFileSkip(Self, fn, String(E.ClassName) ,E.Message );\r\n end;\r\n end;\r\n\r\n\r\n end;\r\n end\r\n else\r\n if Recursive then\r\n SearchDirectory(SDirectory + SearchRec.Name + PathDelim);\r\n end;\r\n Res := FindNext(SearchRec);\r\n end;\r\n finally\r\n FindClose(SearchRec);\r\n end;\r\n end;\r\n\r\nbegin\r\n { (RB) Letting this function create a stream is not a good idea;\r\n see other CompressDirectory function that causes a memory leak }\r\n Result := TMemoryStream.Create;\r\n if Directory <> '' then // do not start with '\\' if the caller specifies ''.\r\n Directory := IncludeTrailingPathDelimiter(Directory);\r\n SearchDirectory('');\r\n Result.Position := 0;\r\nend;\r\n\r\nprocedure TJvZlibMultiple.AddFile(const FileName, Directory, FilePath: string;\r\n DestStream: TStream);\r\nvar\r\n Stream: TStream;\r\n FileStream: TFileStream;\r\n ZStream: TJclZLibCompressStream;\r\n Buffer: array [0..1023] of Byte;\r\n Count: Integer;\r\n FileStreamPos, FileStreamSize: Int64;\r\n\r\n procedure WriteFileRecord(const Directory, FileName: string; FileSize: Integer; CompressedSize: Integer);\r\n var\r\n B: Byte;\r\n AnsiStr: AnsiString;\r\n begin\r\n AnsiStr := AnsiString(Directory);\r\n if Length(AnsiStr) > 255 then\r\n SetLength(AnsiStr, 255);\r\n B := Length(AnsiStr);\r\n DestStream.Write(B, SizeOf(B));\r\n DestStream.Write(PAnsiChar(AnsiStr)^, B);\r\n\r\n AnsiStr := AnsiString(FileName);\r\n if Length(AnsiStr) > 255 then\r\n SetLength(AnsiStr, 255);\r\n B := Length(AnsiStr);\r\n DestStream.Write(B, SizeOf(B));\r\n DestStream.Write(PAnsiChar(AnsiStr)^, B);\r\n\r\n DestStream.Write(FileSize, SizeOf(FileSize));\r\n DestStream.Write(CompressedSize, SizeOf(CompressedSize));\r\n end;\r\n\r\nbegin\r\n Stream := TMemoryStream.Create;\r\n if not IgnoreExclusive then\r\n FileStream := TFileStream.Create(FilePath, fmOpenRead or fmShareDenyWrite)\r\n else\r\n FileStream := TFileStream.Create(FilePath, fmOpenRead or fmShareDenyNone);\r\n\r\n\r\n if FileStream.Size=0 then begin\r\n Stream.Free;\r\n FileStream.Free;\r\n exit;\r\n end;\r\n\r\n try\r\n ZStream := TJclZLibCompressStream.Create(Stream, CompressionLevel);\r\n try\r\n if Assigned(FOnCompressingFile) then\r\n FOnCompressingFile(Self, FilePath);\r\n\r\n FileStreamPos := FileStream.Position;\r\n FileStreamSize := FileStream.Size;\r\n { (RB) ZStream has an OnProgress event, thus CopyFrom can be used }\r\n repeat\r\n Count := FileStream.Read(Buffer, SizeOf(Buffer));\r\n Inc(FileStreamPos, Count);\r\n if Count > 0 then\r\n ZStream.Write(Buffer, Count);\r\n DoProgress(FileStreamPos, FileStreamSize);\r\n while CompressionPaused do\r\n Sleep(1);\r\n until (Count = 0) or FTerminateCompress;\r\n ZStream.Flush; // Warren added.\r\n finally\r\n ZStream.Free;\r\n end;\r\n\r\n if Assigned(FOnCompressedFile) then\r\n FOnCompressedFile(Self, FilePath);\r\n\r\n if StorePaths then\r\n WriteFileRecord(Directory, FileName, FileStreamSize, Stream.Size)\r\n else\r\n WriteFileRecord('', FileName, FileStreamSize, Stream.Size);\r\n\r\n DestStream.CopyFrom(Stream, 0);\r\n finally\r\n FileStream.Free;\r\n Stream.Free;\r\n end;\r\nend;\r\n\r\nprocedure TJvZlibMultiple.CompressDirectory(const Directory: string;\r\n Recursive: Boolean; const FileName: string);\r\nvar\r\n TmpStream: TStream;\r\nbegin\r\n // don't create file until we save it so we don't accidentally\r\n // try to compress ourselves!\r\n DeleteFile(FileName); // make sure we don't compress a previous archive into ourselves\r\n TmpStream := CompressDirectory(Directory, Recursive);\r\n try\r\n TMemoryStream(TmpStream).SaveToFile(FileName);\r\n finally\r\n TmpStream.Free;\r\n end;\r\nend;\r\n\r\nfunction TJvZlibMultiple.CompressFiles(Files: TStrings): TStream;\r\nvar\r\n I: Integer;\r\n S1, S2, Common: string;\r\nbegin\r\n FTerminateCompress := False;\r\n { (RB) Letting this function create a stream is not a good idea;\r\n see other CompressFiles function that causes a memory leak }\r\n Result := TMemoryStream.Create;\r\n if Files.Count = 0 then\r\n Exit;\r\n\r\n //Find the biggest Common part of all files\r\n S1 := UpperCase(Files[0]);\r\n for I := 1 to Files.Count - 1 do\r\n begin\r\n S2 := Files[I];\r\n while (Pos(S1, S2) = 0) and (S1 <> '') do\r\n S1 := Copy(S1, 1, Length(S1) - 1);\r\n end;\r\n { (RB) This should be Common := S1 (?) }\r\n Common := S2;\r\n\r\n //Add the files to the stream\r\n for I := 0 to Files.Count - 1 do\r\n begin\r\n S1 := ExtractFileName(Files[I]);\r\n S2 := ExtractFilePath(Files[I]);\r\n S2 := Copy(S2, 1, Length(Common));\r\n AddFile(S1, S2, Files[I], Result);\r\n end;\r\n\r\n Result.Position := 0;\r\nend;\r\n\r\nprocedure TJvZlibMultiple.CompressFiles(Files: TStrings; const FileName: string);\r\nvar\r\n TmpStream: TStream;\r\nbegin\r\n TmpStream := CompressFiles(Files);\r\n try\r\n TMemoryStream(TmpStream).SaveToFile(FileName);\r\n finally\r\n TmpStream.Free;\r\n end;\r\n if Assigned(FOnCompletedAction) then\r\n FOnCompletedAction(Self);\r\nend;\r\n\r\nprocedure TJvZlibMultiple.DecompressStream(Stream: TStream;\r\n Directory: string; Overwrite: Boolean; const RelativePaths: Boolean);\r\nvar\r\n FileStream: TFileStream;\r\n ZStream: TJclZLibDecompressStream;\r\n CStream: TMemoryStream;\r\n B, LastPos: Byte;\r\n AnsiS: AnsiString;\r\n S: string;\r\n Count, FileSize, I: Integer;\r\n Buffer: array [0..1023] of Byte;\r\n TotalByteCount: Longword;\r\n WriteMe: Boolean; // Allow skipping of files instead of writing them.\r\n FileStreamSize, StreamSize: Int64;\r\n fd: string; // name of directory to be made if it doesn't exist (unless we're skipping it)\r\nbegin\r\n if Directory <> '' then\r\n Directory := IncludeTrailingPathDelimiter(Directory);\r\n\r\n StreamSize := Stream.Size; // cache, to not FileSeek on every iteration\r\n while Stream.Position < StreamSize do\r\n begin\r\n //Read and force the directory\r\n Stream.Read(B, SizeOf(B));\r\n SetLength(AnsiS, B);\r\n if B > 0 then\r\n Stream.Read(AnsiS[1], B);\r\n S := string(AnsiS);\r\n\r\n fd := Directory + S;\r\n if (fd <> '') and (ForceDirectoriesFlag) then\r\n ForceDirectories(fd);\r\n\r\n if S <> '' then\r\n S := IncludeTrailingPathDelimiter(S);\r\n\r\n //This make files decompress either on Directory or Directory+SavedRelativePath\r\n if not RelativePaths then\r\n S := '';\r\n\r\n //Read filename\r\n Stream.Read(B, SizeOf(B));\r\n if B > 0 then\r\n begin\r\n AnsiS := AnsiString(S);\r\n LastPos := Length(AnsiS);\r\n SetLength(AnsiS, LastPos + B);\r\n Stream.Read(AnsiS[LastPos + 1], B);\r\n S := string(AnsiS);\r\n end;\r\n\r\n Stream.Read(FileSize, SizeOf(FileSize));\r\n Stream.Read(I, SizeOf(I));\r\n CStream := TMemoryStream.Create;\r\n\r\n try\r\n CStream.CopyFrom(Stream, I);\r\n CStream.Position := 0;\r\n\r\n //Decompress the file\r\n S := Directory + S;\r\n if Overwrite or not FileExists(S) then\r\n begin\r\n //This fails if Directory isn't empty\r\n WriteMe := True;\r\n if Assigned(FOnDecompressingFile) then\r\n FOnDecompressingFile(Self, S, WriteMe);\r\n\r\n if WriteMe then\r\n FileStream := TFileStream.Create(S, fmCreate or fmShareExclusive)\r\n else\r\n FileStream := nil; // skip it!\r\n\r\n ZStream := TJclZLibDecompressStream.Create(CStream);\r\n try\r\n TotalByteCount := 0;\r\n\r\n { (RB) ZStream has an OnProgress event, thus copyfrom can be used }\r\n FileStreamSize := 0;\r\n repeat\r\n Count := ZStream.Read(Buffer, SizeOf(Buffer));\r\n if Assigned(FileStream) then\r\n begin\r\n Inc(FileStreamSize, FileStream.Write(Buffer, Count));\r\n DoProgress(FileStreamSize, FileSize);\r\n while DecompressionPaused do\r\n Sleep(1);\r\n end;\r\n Inc(TotalByteCount, Count);\r\n until (Count = 0) or FTerminateDecompress;\r\n if Assigned(FOnDecompressedFile) then\r\n FOnDecompressedFile(Self, S, TotalByteCount);\r\n finally\r\n FreeAndNil(FileStream);\r\n ZStream.Free;\r\n end;\r\n end;\r\n finally\r\n CStream.Free;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvZlibMultiple.DecompressFile(const FileName, Directory: string;\r\n Overwrite: Boolean; const RelativePaths: Boolean);\r\nvar\r\n Stream: TFileStream;\r\nbegin\r\n Stream := TFileStream.Create(FileName, fmOpenRead or fmShareDenyWrite);\r\n try\r\n Stream.Position := 0;\r\n DecompressStream(Stream, Directory, Overwrite, RelativePaths);\r\n finally\r\n Stream.Free;\r\n end;\r\n if Assigned(FOnCompletedAction) then\r\n FOnCompletedAction(Self);\r\nend;\r\n\r\nprocedure TJvZlibMultiple.DoProgress(Position, Total: Integer);\r\nbegin\r\n if Assigned(FOnProgress) then\r\n FOnProgress(Self, Position, Total);\r\nend;\r\n\r\nprocedure TJvZlibMultiple.DoStopCompression;\r\nbegin\r\n FTerminateCompress := True;\r\nend;\r\n\r\nprocedure TJvZlibMultiple.DoStopDecompression;\r\nbegin\r\n FTerminateDecompress := True;\r\nend;\r\n\r\nprocedure TJvZlibMultiple.SetForceDirectoriesFlag(const Value: Boolean);\r\nbegin\r\n FForceDirectoriesFlag := Value;\r\nend;\r\n\r\nprocedure TJvZlibMultiple.StopCompression;\r\nbegin\r\n DoStopCompression;\r\nend;\r\n\r\nprocedure TJvZlibMultiple.StopDecompression;\r\nbegin\r\n DoStopDecompression;\r\nend;\r\n\r\nprocedure TJvZLibMultiple.ListStoredFiles(const FileName: string; FileList: TStrings);\r\nvar\r\n ZStream: TFileStream;\r\n FHByte: Byte;\r\n FilePos, HeaderPos, CompressedSize, UnCompressedSize: Integer;\r\n AnsiFileInfo: AnsiString;\r\n FileInfo: string;\r\n ZStreamSize: Int64;\r\nbegin\r\n ZStream := TFileStream.Create(FileName, fmOpenRead or fmShareDenyWrite);\r\n try\r\n ZStreamSize := ZStream.Size;\r\n while ZStream.Position < ZStreamSize do\r\n begin\r\n ZStream.Read(FHByte, SizeOf(FHByte));\r\n SetLength(AnsiFileInfo, FHByte);\r\n if FHByte > 0 then\r\n ZStream.Read(AnsiFileInfo[1], FHByte);\r\n FileInfo := string(AnsiFileInfo);\r\n\r\n if FileInfo <> '' then\r\n FileInfo := IncludeTrailingPathDelimiter(FileInfo);\r\n ZStream.Read(FHByte, SizeOf(FHByte));\r\n if FHByte > 0 then\r\n begin\r\n AnsiFileInfo := AnsiString(FileInfo);\r\n HeaderPos := Length(AnsiFileInfo);\r\n SetLength(AnsiFileInfo, HeaderPos + FHByte);\r\n ZStream.Read(AnsiFileInfo[HeaderPos + 1], FHByte);\r\n FileInfo := string(AnsiFileInfo);\r\n end;\r\n\r\n FileList.Add(FileInfo);\r\n ZStream.Read(UncompressedSize, SizeOf(UncompressedSize));\r\n ZStream.Read(CompressedSize, SizeOf(CompressedSize));\r\n FilePos := ZStream.Position + CompressedSize;\r\n ZStream.Position := FilePos;\r\n end;\r\n finally\r\n ZStream.Free;\r\n end;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvZoom.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvZoom.PAS, released on 2001-02-28.\r\n2002-12-08 : added crosshair options and OnContentsChanged event (Antoine Potten)\r\n\r\nThe Initial Developer of the Original Code is Sbastien Buysse [sbuysse att buypin dott com]\r\nPortions created by Sbastien Buysse are Copyright (C) 2001 Sbastien Buysse.\r\nAll Rights Reserved.\r\n\r\nContributor(s): Michael Beck [mbeck att bigfoot dott com], Antoine Potten [jvcl att antp dott be]\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvZoom.pas 13104 2011-09-07 06:50:43Z obones $\r\n\r\nunit JvZoom;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n SysUtils, Classes,\r\n Windows, Messages, Graphics, Controls, Forms, ExtCtrls,\r\n JvComponent;\r\n\r\ntype\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvZoom = class(TJvCustomControl)\r\n private\r\n FTimer: TTimer;\r\n FActive: Boolean;\r\n FZoomLevel: Integer;\r\n FDelay: Cardinal;\r\n FLastPoint: TPoint;\r\n FCrossHair: Boolean;\r\n FCrosshairColor: TColor;\r\n FCrosshairSize: Integer;\r\n FOnContentsChanged: TNotifyEvent;\r\n FCacheOnDeactivate: Boolean;\r\n FCacheBitmap: TBitmap;\r\n FCrossHairPicture: TPicture;\r\n procedure SetActive(const Value: Boolean);\r\n procedure SetDelay(const Value: Cardinal);\r\n procedure SetZoomLevel(const Value: Integer);\r\n procedure SetCacheOnDeactivate(const Value: Boolean);\r\n procedure SetCrossHairPicture(const Value: TPicture);\r\n function GetZoomPercentage: Integer;\r\n procedure SetZoomPercentage(const Value: Integer);\r\n procedure PaintMe(Sender: TObject);\r\n procedure SetCrossHair(const Value: Boolean);\r\n protected\r\n procedure Resize; override;\r\n procedure Paint; override;\r\n procedure PaintZoom;\r\n procedure Loaded; override;\r\n procedure Cache;\r\n procedure FlushCache;\r\n procedure DoContentsChanged;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n procedure ForceUpdate;\r\n procedure ZoomInAt(X, Y: Integer);\r\n published\r\n property Anchors;\r\n property Align;\r\n property Constraints;\r\n property Color;\r\n property Enabled;\r\n property Visible;\r\n property Active: Boolean read FActive write SetActive default True;\r\n property ZoomLevel: Integer read FZoomLevel write SetZoomLevel default 100;\r\n property ZoomPercentage: Integer read GetZoomPercentage write SetZoomPercentage stored False;\r\n property Delay: Cardinal read FDelay write SetDelay default 100;\r\n property Crosshair: Boolean read FCrossHair write SetCrossHair default False;\r\n property CrossHairPicture: TPicture read FCrossHairPicture write SetCrossHairPicture;\r\n property CrosshairColor: TColor read FCrosshairColor write FCrosshairColor default clBlack;\r\n property CrosshairSize: Integer read FCrosshairSize write FCrosshairSize default 20;\r\n property CacheOnDeactivate: Boolean read FCacheOnDeactivate write SetCacheOnDeactivate default True;\r\n property OnContentsChanged: TNotifyEvent read FOnContentsChanged write FOnContentsChanged;\r\n property OnMouseDown;\r\n property OnClick;\r\n property OnDblClick;\r\n property OnMouseUp;\r\n property OnResize;\r\n property OnKeyPress;\r\n property OnKeyDown;\r\n property OnKeyUp;\r\n property OnMouseWheel;\r\n property OnMouseWheelUp;\r\n property OnMouseWheelDown;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvZoom.pas $';\r\n Revision: '$Revision: 13104 $';\r\n Date: '$Date: 2011-09-07 08:50:43 +0200 (mer. 07 sept. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n JvJVCLUtils;\r\n\r\nconstructor TJvZoom.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FCrossHairPicture := TPicture.Create;\r\n FCrossHairPicture.OnChange := PaintMe;\r\n Height := 100;\r\n Width := 100;\r\n FDelay := 100;\r\n FZoomLevel := 100;\r\n FCrosshairSize := 20;\r\n FCrosshairColor := clBlack;\r\n FCacheOnDeactivate := True;\r\n FActive := True;\r\n FTimer := TTimer.Create(Self);\r\n FTimer.OnTimer := PaintMe;\r\n FTimer.Interval := 100;\r\nend;\r\n\r\ndestructor TJvZoom.Destroy;\r\nbegin\r\n FCacheBitmap.Free;\r\n FCacheBitmap := nil;\r\n FCrossHairPicture.OnChange := nil;\r\n FCrossHairPicture.Free;\r\n { Timer is automatically freed }\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvZoom.Cache;\r\nbegin\r\n if not Assigned(FCacheBitmap) then\r\n FCacheBitmap := TBitmap.Create;\r\n\r\n FCacheBitmap.Width := Width;\r\n FCacheBitmap.Height := Height;\r\n FCacheBitmap.Canvas.CopyRect(ClientRect, Canvas, ClientRect);\r\nend;\r\n\r\nprocedure TJvZoom.FlushCache;\r\nbegin\r\n FreeAndNil(FCacheBitmap);\r\nend;\r\n\r\nprocedure TJvZoom.Loaded;\r\nbegin\r\n inherited Loaded;\r\n FTimer.Enabled := FActive;\r\nend;\r\n\r\nprocedure TJvZoom.Paint;\r\nbegin\r\n if Active then\r\n PaintZoom\r\n else\r\n begin\r\n if Assigned(FCacheBitmap) then\r\n Canvas.Draw(0, 0, FCacheBitmap)\r\n else\r\n begin\r\n Canvas.Brush.Color := Color;\r\n Canvas.FillRect(Rect(0, 0, Width, Height));\r\n end;\r\n end;\r\n if csDesigning in ComponentState then\r\n with Canvas do\r\n begin\r\n Pen.Style := psDash;\r\n Pen.Color := clBlack;\r\n Brush.Style := bsClear;\r\n Rectangle(0, 0, Width, Height);\r\n end;\r\nend;\r\n\r\nprocedure TJvZoom.PaintMe(Sender: TObject);\r\n\r\nbegin\r\n { Reading Canvas.Handle will implicitly set the canvas handle to the\r\n control's device context\r\n Calling PaintWindow will lock the canvas and call Paint\r\n }\r\n PaintWindow(Canvas.Handle);\r\nend;\r\n\r\nprocedure TJvZoom.PaintZoom;\r\nvar\r\n P: TPoint;\r\n X, Y, Dx, Dy: Integer;\r\n SourceRect: TRect;\r\n DesktopCanvas: TJvDesktopCanvas;\r\nbegin\r\n if Enabled then\r\n begin\r\n GetCursorPos(P);\r\n //Only draw if on a different position\r\n if (P.X = FLastPoint.X) and (P.Y = FLastPoint.Y) then\r\n Exit;\r\n end\r\n else\r\n P := FLastPoint;\r\n\r\n //Analyse the point\r\n FLastPoint := P;\r\n\r\n //Create the area to Copy\r\n X := (Width div 2) * FZoomLevel div 100;\r\n Y := (Height div 2) * FZoomLevel div 100;\r\n\r\n Dx := 0;\r\n Dy := 0;\r\n\r\n if P.X < X then\r\n begin\r\n Dx := (P.X - X - 1) * 100 div FZoomLevel;\r\n P.X := X;\r\n end\r\n else\r\n if P.X + X > Screen.Width then\r\n begin\r\n Dx := (X - (Screen.Width - P.X) + 1) * 100 div FZoomLevel;\r\n P.X := Screen.Width - X;\r\n end;\r\n if P.Y < Y then\r\n begin\r\n Dy := (P.Y - Y - 1) * 100 div FZoomLevel;\r\n P.Y := Y;\r\n end\r\n else\r\n if P.Y + Y > Screen.Height then\r\n begin\r\n Dy := (Y - (Screen.Height - P.Y) + 1) * 100 div FZoomLevel;\r\n P.Y := Screen.Height - Y;\r\n end;\r\n\r\n SourceRect.Left := P.X - X;\r\n SourceRect.Top := P.Y - Y;\r\n SourceRect.Right := P.X + X;\r\n SourceRect.Bottom := P.Y + Y;\r\n\r\n //Draw the area around the mouse\r\n DesktopCanvas := TJvDesktopCanvas.Create;\r\n Canvas.CopyRect(Rect(0, 0, Width, Height), DesktopCanvas, SourceRect);\r\n DesktopCanvas.Free;\r\n\r\n if FCrossHair then\r\n begin\r\n if (FCrossHairPicture.Graphic <> nil) and not FCrossHairPicture.Graphic.Empty then\r\n begin\r\n FCrossHairPicture.Graphic.Transparent := True;\r\n Canvas.Draw((Width - FCrossHairPicture.Graphic.Width) div 2 + Dx,\r\n (Height - FCrossHairPicture.Graphic.Height) div 2 + Dy,FCrossHairPicture.Graphic);\r\n end\r\n else\r\n with Canvas do\r\n begin\r\n Pen.Color := FCrosshairColor;\r\n Pen.Style := psSolid;\r\n MoveTo(Width div 2 + Dx, Height div 2 - FCrosshairSize div 2 + Dy);\r\n LineTo(Width div 2 + Dx, Height div 2 + FCrosshairSize div 2 + Dy);\r\n MoveTo(Width div 2 - FCrosshairSize div 2 + Dx, Height div 2 + Dy);\r\n LineTo(Width div 2 + FCrosshairSize div 2 + Dx, Height div 2 + Dy);\r\n end;\r\n end;\r\n if Enabled then\r\n DoContentsChanged;\r\nend;\r\n\r\nprocedure TJvZoom.SetActive(const Value: Boolean);\r\nbegin\r\n if FActive = Value then\r\n Exit;\r\n\r\n FActive := Value;\r\n\r\n if not (csReading in ComponentState) then\r\n FTimer.Enabled := FActive;\r\n\r\n if not FActive then\r\n begin\r\n if FCacheOnDeactivate then\r\n Cache\r\n else\r\n Invalidate;\r\n end\r\n else\r\n if not Enabled then\r\n FLastPoint := Point(MaxLongint, MaxLongint);\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvZoom.SetCacheOnDeactivate(const Value: Boolean);\r\nbegin\r\n if Value <> FCacheOnDeactivate then\r\n begin\r\n FCacheOnDeactivate := Value;\r\n\r\n if not Value then\r\n begin\r\n FlushCache;\r\n if not Active then\r\n Invalidate;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvZoom.SetDelay(const Value: Cardinal);\r\nbegin\r\n FDelay := Value;\r\n FTimer.Interval := Value;\r\nend;\r\n\r\nprocedure TJvZoom.SetZoomLevel(const Value: Integer);\r\nbegin\r\n if (FZoomLevel <> Value) and (Value > 0) then\r\n begin\r\n FZoomLevel := Value;\r\n { Forget the old point; thus force repaint }\r\n if Enabled then\r\n FLastPoint := Point(MaxLongint, MaxLongint);\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvZoom.SetCrossHair(const Value: Boolean);\r\nbegin\r\n if FCrossHair <> Value then\r\n begin\r\n FCrossHair := Value;\r\n { Forget the old point; thus force repaint }\r\n ForceUpdate;\r\n end;\r\nend;\r\n\r\nprocedure TJvZoom.Resize;\r\nbegin\r\n //On resize, refresh it\r\n inherited Resize;\r\n { Forget the old point; thus force repaint }\r\n if Enabled then\r\n FLastPoint := Point(MaxLongint, MaxLongint);\r\n PaintMe(Self);\r\nend;\r\n\r\nfunction TJvZoom.GetZoomPercentage: Integer;\r\nbegin\r\n if ZoomLevel <> 0 then\r\n Result := Trunc((100.0 / ZoomLevel) * 100.0)\r\n else\r\n Result := 0;\r\nend;\r\n\r\nprocedure TJvZoom.SetZoomPercentage(const Value: Integer);\r\nbegin\r\n if Value <> 0 then\r\n ZoomLevel := Trunc((100.0 / Value) * 100.0);\r\nend;\r\n\r\nprocedure TJvZoom.SetCrossHairPicture(const Value: TPicture);\r\nbegin\r\n FCrossHairPicture.Assign(Value);\r\nend;\r\n\r\nprocedure TJvZoom.ZoomInAt(X, Y: Integer);\r\nbegin\r\n if Enabled then\r\n SetCursorPos(X,Y)\r\n else\r\n begin\r\n if (FLastPoint.X <> X) or (FLastPoint.Y <> Y) then\r\n begin\r\n FLastPoint.X := X;\r\n FLastPoint.Y := Y;\r\n DoContentsChanged;\r\n end;\r\n end;\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvZoom.ForceUpdate;\r\nbegin\r\n if Enabled then\r\n FLastPoint := Point(MaxLongint, MaxLongint);\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvZoom.DoContentsChanged;\r\nbegin\r\n if Assigned(FOnContentsChanged) then\r\n FOnContentsChanged(Self);\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvaScrollText.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvaScrollText.PAS, released on 2002-07-04.\r\n\r\nThe Initial Developers of the Original Code are: Andrei Prygounkov     \r\nCopyright (c) 1999, 2002 Andrei Prygounkov\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n Some russian comments were translated to english; these comments are marked\r\n with [translated]\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvaScrollText.pas 13104 2011-09-07 06:50:43Z obones $\r\n\r\nunit JvaScrollText;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Classes, Windows, Controls, ExtCtrls, Graphics,\r\n JvComponent;\r\n\r\ntype\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvaScrollText = class(TJvCustomControl)\r\n private\r\n FForeImage: TImage;\r\n FBackImage: TImage;\r\n FFontMaskImage: TImage;\r\n FFontImage: TImage;\r\n FScrollImage: TImage;\r\n FStrings: TStringList;\r\n FStop: Boolean;\r\n FScrollBottom: Integer;\r\n FScrollTop: Integer;\r\n FLeftMargin: Integer;\r\n FRightMargin: Integer;\r\n FMaxFontSize: Integer;\r\n FSpeed: Integer;\r\n FPics: Integer;\r\n procedure SetForeImage(Value: TPicture);\r\n procedure SetBackImage(Value: TPicture);\r\n function GetForeImage: TPicture;\r\n function GetBackImage: TPicture;\r\n function GetStrings: TStrings;\r\n procedure SetStrings(Value: TStrings);\r\n protected\r\n procedure Loaded; override;\r\n procedure Paint; override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n procedure Scroll;\r\n procedure Stop;\r\n published\r\n property ForeImage: TPicture read GetForeImage write SetForeImage;\r\n property BackImage: TPicture read GetBackImage write SetBackImage;\r\n property Height default 150;\r\n property Lines: TStrings read GetStrings write SetStrings;\r\n property ScrollBottom: Integer read FScrollBottom write FScrollBottom default -1;\r\n property ScrollTop: Integer read FScrollTop write FScrollTop default -1;\r\n property LeftMargin: Integer read FLeftMargin write FLeftMargin default -1;\r\n property RightMargin: Integer read FRightMargin write FRightMargin default -1;\r\n property MaxFontSize: Integer read FMaxFontSize write FMaxFontSize default 48;\r\n property Font;\r\n property Speed: Integer read FSpeed write FSpeed default 25;\r\n property Width default 150;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvaScrollText.pas $';\r\n Revision: '$Revision: 13104 $';\r\n Date: '$Date: 2011-09-07 08:50:43 +0200 (mer. 07 sept. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n SysUtils, Forms, StrUtils,\r\n JvJCLUtils, JvDsgnIntf, JvThemes;\r\n\r\nconst\r\n cDelayIncrement = 50;\r\n cIntToStyle: array [0..3] of TFontStyles =\r\n ([], [fsBold], [fsItalic], [fsBold, fsItalic]);\r\n\r\nconstructor TJvaScrollText.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n IncludeThemeStyle(Self, [csParentBackground]);\r\n FForeImage := TImage.Create(nil);\r\n FBackImage := TImage.Create(nil);\r\n FFontMaskImage := TImage.Create(nil);\r\n FFontImage := TImage.Create(nil);\r\n FScrollImage := TImage.Create(nil);\r\n FStrings := TStringList.Create;\r\n FScrollBottom := -1;\r\n FScrollTop := -1;\r\n FLeftMargin := -1;\r\n FRightMargin := -1;\r\n FMaxFontSize := 48;\r\n Speed := 25;\r\n Width := 150;\r\n Height := 150;\r\nend;\r\n\r\ndestructor TJvaScrollText.Destroy;\r\nbegin\r\n FForeImage.Free;\r\n FBackImage.Free;\r\n FFontMaskImage.Free;\r\n FFontImage.Free;\r\n FScrollImage.Free;\r\n FStrings.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJvaScrollText.GetForeImage: TPicture;\r\nbegin\r\n Result := FForeImage.Picture;\r\nend;\r\n\r\nfunction TJvaScrollText.GetBackImage: TPicture;\r\nbegin\r\n Result := FBackImage.Picture;\r\nend;\r\n\r\nprocedure TJvaScrollText.SetForeImage(Value: TPicture);\r\nbegin\r\n FForeImage.Picture.Assign(Value);\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvaScrollText.SetBackImage(Value: TPicture);\r\nbegin\r\n FBackImage.Picture.Assign(Value);\r\n Invalidate;\r\nend;\r\n\r\nfunction TJvaScrollText.GetStrings: TStrings;\r\nbegin\r\n Result := FStrings;\r\nend;\r\n\r\nprocedure TJvaScrollText.SetStrings(Value: TStrings);\r\nbegin\r\n FStrings.Assign(Value);\r\nend;\r\n\r\nprocedure TJvaScrollText.Paint;\r\nbegin\r\n inherited Paint;\r\n if csDesigning in ComponentState then\r\n begin\r\n DrawDesignFrame(Canvas, ClientRect);\r\n Canvas.Draw(0, 0, FForeImage.Picture.Graphic);\r\n end\r\n else\r\n Canvas.Draw(0, 0, FScrollImage.Picture.Graphic);\r\nend;\r\n\r\nprocedure TJvaScrollText.Scroll;\r\nvar\r\n J: Integer;\r\n H: Integer;\r\n RecTmp: TRect;\r\n DelayMsec: Longword;\r\n DelayPause: Longword;\r\n DelayPause2: Longword;\r\n Pixels: 1..4;\r\n Pixels2: 1..4;\r\n Pix: array [1..4] of Integer;\r\n // DrawInfo: Boolean;\r\n Line: Integer;\r\n H2, Popr, LastLine: Integer;\r\n Dest: TRect;\r\n Source: TRect;\r\n SourceFon: TRect;\r\n FontHeight: Integer;\r\n\r\n // (rom) the Delay implementation is crude. Better use a Timer\r\n\r\n procedure Delay(MSecs: Longword);\r\n var\r\n DelayM: Longword;\r\n begin\r\n DelayM := GetTickCount;\r\n repeat\r\n Application.ProcessMessages;\r\n if FStop then\r\n Exit;\r\n until GetTickCount - DelayM > MSecs;\r\n end;\r\n\r\n function ChangeFont(S: string): Boolean;\r\n var\r\n msec: string;\r\n begin\r\n Result := True;\r\n if AnsiStartsStr('$Font:', S) then\r\n with FFontImage.Canvas.Font do\r\n begin\r\n S := Copy(S, 7, MaxInt);\r\n Name := SubStrBySeparator(S, 0, ';');\r\n Size := StrToInt(SubStrBySeparator(S, 1, ';'));\r\n Style := cIntToStyle[StrToInt(SubStrBySeparator(S, 2, ';'))];\r\n end\r\n else\r\n if AnsiStartsStr('$Pause', S) then\r\n begin\r\n msec := Copy(S, 7, 16);\r\n Delay(StrToIntDef(msec, 0));\r\n end\r\n else\r\n Result := False;\r\n FontHeight := abs(FFontImage.Canvas.Font.Height) + 3;\r\n end;\r\n\r\n procedure InitAll;\r\n begin\r\n FStop := False;\r\n Pixels := 1;\r\n DelayPause := Speed;\r\n Pixels2 := 1;\r\n DelayPause2 := Speed;\r\n // DrawInfo := False;\r\n FScrollImage.Picture.Assign(FForeImage.Picture);\r\n FFontMaskImage.Picture.Assign(FForeImage.Picture);\r\n FFontImage.Picture.Assign(FForeImage.Picture);\r\n FScrollImage.BoundsRect := BoundsRect;\r\n FForeImage.BoundsRect := BoundsRect;\r\n FFontMaskImage.BoundsRect := BoundsRect;\r\n FFontImage.BoundsRect := BoundsRect;\r\n Canvas.Font.Size := MaxFontSize;\r\n FFontImage.Picture.Bitmap.Height := Height + Canvas.TextHeight('W');\r\n\r\n FScrollImage.Picture.Assign(FForeImage.Picture);\r\n SourceFon.Top := 0;\r\n SourceFon.Left := 0;\r\n SourceFon.Right := FForeImage.Width - 1;\r\n SourceFon.Bottom := FForeImage.Height - 1;\r\n Source.Top := 0;\r\n Source.Left := 0;\r\n Source.Right := FScrollImage.Picture.Width - 1;\r\n Dest := Source;\r\n FFontImage.Canvas.Brush.Color := clBlack;\r\n Source.Bottom := FFontImage.Picture.Height - 1;\r\n FFontImage.Canvas.FillRect(Source);\r\n FFontImage.Canvas.Font.Color := clWhite;\r\n FFontMaskImage.Canvas.Brush.Color := clWhite;\r\n FFontMaskImage.Canvas.FillRect(SourceFon);\r\n\r\n FStop := False;\r\n // ChangeFont('$Font:Times New Roman;12;0');\r\n FFontImage.Canvas.Font := Font;\r\n FFontImage.Canvas.Font.Color := clWhite;\r\n FontHeight := FFontImage.Canvas.TextHeight('W') + 3;\r\n\r\n if ScrollTop < 0 then\r\n ScrollTop := 2;\r\n if ScrollBottom < 0 then\r\n ScrollBottom := Height - 2;\r\n if LeftMargin < 0 then\r\n LeftMargin := 2;\r\n if RightMargin < 0 then\r\n RightMargin := Width - 2;\r\n H2 := ScrollBottom;\r\n Popr := 0;\r\n LastLine := 0;\r\n Line := -1;\r\n end;\r\n\r\n // (rom) the Delay implementation is crude. Better use a Timer or multimedia timer\r\n\r\n procedure DelayBegin;\r\n begin\r\n DelayMsec := GetTickCount;\r\n end;\r\n\r\n procedure DelayEnd;\r\n var\r\n DelayFact: Longword;\r\n begin\r\n DelayFact := GetTickCount - DelayMsec;\r\n repeat\r\n Application.ProcessMessages;\r\n if FStop then\r\n Exit;\r\n until GetTickCount - DelayMsec > DelayPause;\r\n {************* Correction of speed [translated] *************}\r\n Inc(FPics);\r\n if FPics > 11 then\r\n begin\r\n { To recorrect speed - to make by the jerks [translated] }\r\n Pixels := 1;\r\n if Pix[2] > Pix[Pixels] then\r\n Pixels := 2;\r\n if Pix[3] > Pix[Pixels] then\r\n Pixels := 3;\r\n if Pix[4] > Pix[Pixels] then\r\n Pixels := 4;\r\n DelayPause := Speed + (Pixels - 1) * cDelayIncrement;\r\n DelayPause2 := DelayPause;\r\n Pixels2 := Pixels;\r\n Pix[1] := 0;\r\n Pix[2] := 0;\r\n Pix[3] := 0;\r\n Pix[4] := 0;\r\n FPics := 0;\r\n end\r\n else\r\n begin\r\n if (DelayFact > DelayPause2) and (Pixels2 < 4) then\r\n begin\r\n { To recorrect speed - to make by the jerks [translated] }\r\n Inc(Pixels2);\r\n Inc(DelayPause2, cDelayIncrement);\r\n end\r\n else\r\n if Pixels2 > 1 then\r\n begin\r\n { To recorrect speed - to make more smoothly - the computer has time [translated] }\r\n Dec(Pixels2);\r\n Dec(DelayPause2, cDelayIncrement);\r\n end;\r\n end;\r\n Inc(Pix[Pixels2]);\r\n { if DrawInfo then\r\n lblInfo.Caption := 'P='+IntToStr(Pixels)\r\n +' P2='+IntToStr(Pixels2)+' D='+IntToStr(DelayFact)\r\n +' DP='+IntToStr(DelayPause)+' DP2='+IntToStr(DelayPause2); }\r\n {############# Correction of speed [translated] #############}\r\n end;\r\n\r\n procedure CopyAll;\r\n begin\r\n FFontMaskImage.Canvas.FillRect(SourceFon);\r\n { To transfer the text [translated] }\r\n FFontMaskImage.Canvas.CopyMode := cmNotSrcCopy;\r\n FFontMaskImage.Canvas.CopyRect(Dest, FFontImage.Canvas, Source);\r\n { Adjustment of a high bound [translated] }\r\n RecTmp := SourceFon;\r\n RecTmp.Bottom := ScrollTop;\r\n FFontMaskImage.Canvas.FillRect(RecTmp);\r\n { Adjustment of the right boundary [translated] }\r\n RecTmp := SourceFon;\r\n RecTmp.Left := RightMargin;\r\n FFontMaskImage.Canvas.FillRect(RecTmp);\r\n { To put a mask on a background [translated] }\r\n FScrollImage.Canvas.CopyMode := cmSrcCopy;\r\n FScrollImage.Canvas.CopyRect(SourceFon, FForeImage.Canvas, SourceFon);\r\n FScrollImage.Canvas.CopyMode := cmSrcAnd;\r\n FScrollImage.Canvas.CopyRect(SourceFon, FFontMaskImage.Canvas, SourceFon);\r\n { To put the mask [translated] }\r\n FFontMaskImage.Canvas.CopyMode := cmSrcErase;\r\n FFontMaskImage.Canvas.CopyRect(SourceFon, FBackImage.Canvas, SourceFon);\r\n { To put text on the background [translated] }\r\n FScrollImage.Canvas.CopyMode := cmSrcPaint;\r\n FScrollImage.Canvas.CopyRect(SourceFon, FFontMaskImage.Canvas, SourceFon);\r\n end;\r\n\r\nbegin\r\n InitAll;\r\n while True do\r\n begin\r\n Inc(Line);\r\n if Line = FStrings.Count then\r\n Line := 0;\r\n { To output the line [translated] }\r\n if ChangeFont(FStrings[Line]) then\r\n Continue;\r\n H := LastLine - Popr;\r\n LastLine := LastLine + FontHeight;\r\n {H := Line * FontHeight - Popr;}\r\n FFontImage.Canvas.TextOut(LeftMargin, H, FStrings[Line]);\r\n { To scroll line [translated] }\r\n for J := 1 to FontHeight do\r\n begin\r\n Dec(H2);\r\n if (J mod Pixels) <> 0 then\r\n Continue;\r\n Source.Bottom := H + J; {H1}\r\n Source.Left := LeftMargin;\r\n SourceFon.Left := LeftMargin;\r\n Dest.Left := LeftMargin;\r\n Dest.Top := H2;\r\n Dest.Bottom := H2 + H + J; {H2+H1}\r\n DelayBegin;\r\n CopyAll;\r\n Canvas.Draw(0, 0, FScrollImage.Picture.Graphic);\r\n DelayEnd;\r\n if FStop then\r\n Exit;\r\n end;\r\n if (Source.Bottom - FScrollImage.Height) > FontHeight then\r\n begin\r\n Inc(H2, FontHeight);\r\n Inc(Popr, FontHeight);\r\n Dest.Top := 0;\r\n Dest.Bottom := FFontImage.Picture.Height - 1 - FontHeight;\r\n Source.Top := FontHeight;\r\n Source.Bottom := FFontImage.Picture.Height - 1;\r\n FFontImage.Canvas.CopyRect(Dest, FFontImage.Canvas, Source);\r\n Source.Top := 0;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvaScrollText.Loaded;\r\nbegin\r\n inherited Loaded;\r\n FScrollImage.BoundsRect := BoundsRect;\r\n FScrollImage.Picture.Assign(FForeImage.Picture);\r\nend;\r\n\r\nprocedure TJvaScrollText.Stop;\r\nbegin\r\n FStop := True;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/Jvg3DColors.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: Jvg3DColors.PAS, released on 2003-01-15.\r\n\r\nThe Initial Developer of the Original Code is Andrey V. Chudin, [chudin att yandex dott ru]\r\nPortions created by Andrey V. Chudin are Copyright (C) 2003 Andrey V. Chudin.\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\nMichael Beck [mbeck att bigfoot dott com].\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: Jvg3DColors.pas 12845 2010-09-16 20:22:55Z jfudickar $\r\n\r\nunit Jvg3DColors;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms;\r\n\r\ntype\r\n TJvg3DLocalColors = class(TComponent)\r\n private\r\n FDkShadow: TColor;\r\n FHighlight: TColor;\r\n FShadow: TColor;\r\n FColorShadowShift: Byte;\r\n FColorHighlightShift: Byte;\r\n OldPointer: Pointer;\r\n procedure SetDefaults;\r\n procedure SetDkShadow(Value: TColor);\r\n procedure SetHighlight(Value: TColor);\r\n procedure SetShadow(Value: TColor);\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n procedure CreateAuto3DColors(BaseColor: TColor);\r\n procedure MakeGlobal;\r\n procedure MakeLocal;\r\n property ColorShadowShift: Byte read FColorShadowShift write FColorShadowShift default 60;\r\n property ColorHighlightShift: Byte read FColorHighlightShift write FColorHighlightShift default 60;\r\n published\r\n property DkShadow: TColor read FDkShadow write SetDkShadow default cl3DDkShadow;\r\n property Highlight: TColor read FHighlight write SetHighlight default clBtnHighlight;\r\n property Shadow: TColor read FShadow write SetShadow default clBtnShadow;\r\n end;\r\n\r\n TJvg3DColors = class(TJvg3DLocalColors)\r\n protected\r\n procedure Notification(Component: TComponent; Operation: TOperation); override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/Jvg3DColors.pas $';\r\n Revision: '$Revision: 12845 $';\r\n Date: '$Date: 2010-09-16 22:22:55 +0200 (jeu. 16 sept. 2010) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n Math,\r\n JvConsts, JvResources,\r\n JvgUtils, JvgTypes;\r\n\r\n//=== { TJvg3DLocalColors } ==================================================\r\n\r\nconstructor TJvg3DLocalColors.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n SetDefaults;\r\nend;\r\n\r\ndestructor TJvg3DLocalColors.Destroy;\r\nbegin\r\n glGlobalData.lp3DColors := nil;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvg3DLocalColors.SetDefaults;\r\nbegin\r\n FDkShadow := cl3DDkShadow;\r\n FHighlight := clBtnHighlight;\r\n FShadow := clBtnShadow;\r\n FColorShadowShift := 60;\r\n FColorHighlightShift := 60;\r\nend;\r\n\r\nprocedure TJvg3DLocalColors.CreateAuto3DColors(BaseColor: TColor);\r\nvar\r\n R, G, B: Byte;\r\nbegin\r\n if (BaseColor and $80000000) <> 0 then\r\n BaseColor := GetSysColor(BaseColor and $FF);\r\n B := GetRValue(BaseColor);\r\n G := GetGValue(BaseColor);\r\n R := GetBValue(BaseColor);\r\n FShadow := RGB(Max(R - ColorShadowShift, 0),\r\n Max(G - ColorShadowShift, 0), Max(B - ColorShadowShift, 0));\r\n FHighlight := RGB(Min(R + ColorHighlightShift, 255),\r\n Min(G + ColorHighlightShift, 255), Min(B + ColorHighlightShift, 255));\r\nend;\r\n\r\nprocedure TJvg3DLocalColors.MakeGlobal;\r\nbegin\r\n OldPointer := glGlobalData.lp3DColors;\r\n glGlobalData.lp3DColors := Self;\r\nend;\r\n\r\nprocedure TJvg3DLocalColors.MakeLocal;\r\nbegin\r\n glGlobalData.lp3DColors := OldPointer;\r\nend;\r\n\r\nprocedure TJvg3DLocalColors.SetDkShadow(Value: TColor);\r\nbegin\r\n FDkShadow := Value; {TWinControl(Owner).Invalidate;}\r\nend;\r\n\r\nprocedure TJvg3DLocalColors.SetHighlight(Value: TColor);\r\nbegin\r\n FHighlight := Value; {TWinControl(Owner).Invalidate;}\r\nend;\r\n\r\nprocedure TJvg3DLocalColors.SetShadow(Value: TColor);\r\nbegin\r\n FShadow := Value; {TWinControl(Owner).Invalidate;}\r\nend;\r\n\r\n//=== { TJvg3DColors } =======================================================\r\n\r\nconstructor TJvg3DColors.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n SetDefaults;\r\n glGlobalData.lp3DColors := Self;\r\nend;\r\n\r\nprocedure TJvg3DColors.Notification(Component: TComponent; Operation: TOperation);\r\nbegin\r\n inherited Notification(Component, Operation);\r\n if (Component <> Self) and (Operation = opInsert) and (Component is TJvg3DLocalColors) then\r\n raise Exception.CreateRes(@RsEOnlyOneInstanceOfTJvg3DLocalColors);\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvgAlignFunction.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvgAlignFunction.PAS, released on 2003-01-15.\r\n\r\nThe Initial Developer of the Original Code is Andrey V. Chudin, [chudin att yandex dott ru]\r\nPortions created by Andrey V. Chudin are Copyright (C) 2003 Andrey V. Chudin.\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\nMichael Beck [mbeck att bigfoot dott com].\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvgAlignFunction.pas 12461 2009-08-14 17:21:33Z obones $\r\n\r\nunit JvgAlignFunction;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Controls,\r\n JvgTypes;\r\n\r\ntype\r\n TJvgNeedAlign = function(Control: TControl): Boolean;\r\n\r\nprocedure AlignControlsInWindow(Wnd: TWinControl; NeedAlign: TJvgNeedAlign;\r\n HCAlign: TglHComponentAlign; VCAlign: TglVComponentAlign);\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvgAlignFunction.pas $';\r\n Revision: '$Revision: 12461 $';\r\n Date: '$Date: 2009-08-14 19:21:33 +0200 (ven. 14 août 2009) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n Windows, Classes, Math,\r\n JvgUtils;\r\n\r\nprocedure AlignControlsInWindow(Wnd: TWinControl; NeedAlign: TJvgNeedAlign;\r\n HCAlign: TglHComponentAlign; VCAlign: TglVComponentAlign);\r\nvar\r\n I, TotalControls, ControlNo: Integer;\r\n R: TRect;\r\n TotalSize, AccumulatedSize: TSize;\r\n ControlsList: TList;\r\n Control: TControl;\r\n\r\n procedure Sort(AHorizSort: Boolean);\r\n var\r\n I: Integer;\r\n Sorted: Boolean;\r\n Control2: TControl;\r\n begin\r\n repeat\r\n Sorted := True;\r\n for I := 0 to ControlsList.Count - 2 do\r\n begin\r\n Control := ControlsList[I];\r\n Control2 := ControlsList[I + 1];\r\n if AHorizSort then\r\n begin\r\n if Control.Left > Control2.Left then\r\n begin\r\n ControlsList.Exchange(I, I + 1);\r\n Sorted := False;\r\n end;\r\n end\r\n else\r\n if Control.Top > Control2.Top then\r\n begin\r\n ControlsList.Exchange(I, I + 1);\r\n Sorted := False;\r\n end;\r\n end;\r\n until Sorted;\r\n end;\r\n\r\nbegin\r\n if not Assigned(Wnd) then\r\n Exit;\r\n ControlsList := TList.Create;\r\n try\r\n R := Rect(MaxInt, MaxInt, 0, 0);\r\n TotalSize.cx := 0;\r\n TotalSize.cy := 0;\r\n AccumulatedSize.cx := 0;\r\n AccumulatedSize.cy := 0;\r\n TotalControls := -1;\r\n ControlNo := 0;\r\n with Wnd do //...calc sizes and sort controls\r\n for I := 0 to ControlCount - 1 do\r\n if NeedAlign(Controls[I]) then\r\n with Controls[I] do\r\n begin\r\n R.Left := Min(R.Left, Left);\r\n R.Top := Min(R.Top, Top);\r\n R.Right := Max(R.Right, Left + Width);\r\n R.Bottom := Max(R.Bottom, Top + Height);\r\n Inc(TotalSize.cx, Width);\r\n Inc(TotalSize.cy, Height);\r\n Inc(TotalControls);\r\n ControlsList.Add(Controls[I]);\r\n end;\r\n Sort(True);\r\n\r\n //..h aligning\r\n for I := 0 to ControlsList.Count - 1 do\r\n with Control do\r\n begin\r\n Control := ControlsList[I];\r\n case HCAlign of\r\n haLeft:\r\n Left := R.Left;\r\n haCenters:\r\n Left := R.Left + (R.Right - R.Left - Width) div 2;\r\n haRight:\r\n Left := R.Right - Width;\r\n haSpaceEqually:\r\n if ControlNo <> TotalControls then\r\n Left := R.Left + AccumulatedSize.cx +\r\n Trunc((R.Right - R.Left - TotalSize.cx) / TotalControls * ControlNo);\r\n haCenterWindow:\r\n Left := (Wnd.Width - Width) div 2;\r\n haClose:\r\n Left := R.Left + AccumulatedSize.cx;\r\n end;\r\n Inc(AccumulatedSize.cx, Width);\r\n Inc(ControlNo);\r\n end;\r\n ControlNo := 0;\r\n Sort(False);\r\n\r\n //..v aligning\r\n for I := 0 to ControlsList.Count - 1 do\r\n with Control do\r\n begin\r\n Control := ControlsList[I];\r\n case VCAlign of\r\n vaTops:\r\n Top := R.Top;\r\n vaCenters:\r\n Top := R.Top + (R.Bottom - R.Top - Height) div 2;\r\n vaBottoms:\r\n Top := R.Bottom - Height;\r\n vaSpaceEqually:\r\n if ControlNo <> TotalControls then\r\n Top := R.Top + AccumulatedSize.cy +\r\n Trunc((R.Bottom - R.Top - TotalSize.cy) / TotalControls * ControlNo);\r\n vaCenterWindow:\r\n Top := (Wnd.Height - Height) div 2;\r\n vaClose:\r\n Top := R.Top + AccumulatedSize.cy;\r\n end;\r\n Inc(AccumulatedSize.cy, Height);\r\n Inc(ControlNo);\r\n end;\r\n finally\r\n ControlsList.Free;\r\n end;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvgAskListBox.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvgAskListBox.PAS, released on 2003-01-15.\r\n\r\nThe Initial Developer of the Original Code is Andrey V. Chudin, [chudin att yandex dott ru]\r\nPortions created by Andrey V. Chudin are Copyright (C) 2003 Andrey V. Chudin.\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\nMichael Beck [mbeck att bigfoot dott com].\r\nRob den Braasem [rbraasem att xs4all dott nl]\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nDescription:\r\n ListBox-based component that provides convenient interface for\r\n realization of the different tests for users. Component is very\r\n useful during setup and install processes.\r\n Items captions align in one of 9 positions. Component can display\r\n glyphs on own items and fill background with bitmap. You can set\r\n different fonts for selected item and for other list items.\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvgAskListBox.pas 13400 2012-08-19 08:16:20Z ahuser $\r\n\r\nunit JvgAskListBox;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,\r\n Dialogs, StdCtrls, CommCtrl, ExtCtrls,\r\n JVCLVer,\r\n JvgTypes, JvgCommClasses;\r\n\r\ntype\r\n TglAskLBOption = (aloAutoScroll, aloIgnoreMouse, aloShowFocus,\r\n aloTransparentButtons, aloWordWrap);\r\n TglAskLBOptions = set of TglAskLBOption;\r\n\r\n TJvgAskListBox = class(TCustomListBox)\r\n private\r\n FAboutJVCL: TJVCLAboutInfo;\r\n FAutoTransparentColor: TglAutoTransparentColor;\r\n FWallpaper: TBitmap;\r\n FWallpaperImage: TImage;\r\n FWallpaperOption: TglWallpaperOption;\r\n FNumGlyphs: Word;\r\n FGlyphsAlign: TJvg2DAlign;\r\n FTextAlign: TJvg2DAlign;\r\n FCaptionsAlign: TJvg2DAlign;\r\n FTransparentColor: TColor;\r\n FItemStyle: TJvgAskListBoxItemStyle;\r\n FItemSelStyle: TJvgAskListBoxItemStyle;\r\n FGlyphs: TImageList;\r\n FShowWallpaper: Boolean;\r\n FShowGlyphs: Boolean;\r\n FItemHeight: Word;\r\n FTextAlign_: UINT;\r\n FCaptionsAlign_: UINT;\r\n FShowText: Boolean;\r\n FSegment1Width: Word;\r\n FPushedButton: array of Byte;\r\n FOnButtonClicked: TNotifyEvent;\r\n FSelectedItem: Word;\r\n FButtons: TStringList;\r\n FButtonWidth: Word;\r\n FOptions: TglAskLBOptions;\r\n WallpaperBmp: TBitmap;\r\n TmpBitmap: TBitmap;\r\n BtnRect: TRect;\r\n BtnTxtRect: TRect;\r\n MouseClickPoint: TPoint;\r\n procedure SetAutoTransparentColor(Value: TglAutoTransparentColor);\r\n procedure SetWallpaper(Value: TBitmap);\r\n function GetWallpaper: TBitmap;\r\n procedure SetWallpaperImage(Value: TImage);\r\n procedure SetWallpaperOption(Value: TglWallpaperOption);\r\n procedure SetNumGlyphs(Value: Word);\r\n procedure SetGlyphs(Value: TImageList);\r\n procedure SetItemHeight(Value: Word);\r\n procedure SetShowText(Value: Boolean);\r\n procedure SetTransparentColor(Value: TColor);\r\n procedure SetSelectedItem(Value: Word);\r\n function GetButtons: TStrings;\r\n procedure SetButtons(Value: TStrings);\r\n procedure SetButtonWidth(Value: Word);\r\n procedure SetOptions(Value: TglAskLBOptions);\r\n procedure DrawWallpaper(R: TRect);\r\n procedure DrawGlyph(R: TRect; Index: Word; Shift: Word);\r\n procedure SetAlign(Align: TJvg2DAlign; var Align_: UINT);\r\n procedure ButtonClicked;\r\n procedure RecalcHeights;\r\n procedure SmthChanged(Sender: TObject);\r\n procedure WMLButtonDown(var Msg: TWMLButtonDown); message WM_LBUTTONDOWN;\r\n procedure WMSize(var Msg: TWMSize); message WM_SIZE;\r\n procedure CNDrawItem(var Msg: TWMDrawItem); message CN_DRAWITEM;\r\n procedure CNMeasureItem(var Msg: TWMMeasureItem); message CN_MEASUREITEM;\r\n protected\r\n procedure Loaded; override;\r\n procedure Notification(AComponent: TComponent; Operation: TOperation); override;\r\n procedure InitState(var State: TOwnerDrawState; ByteState: Byte);\r\n public\r\n function IsFilled: Boolean;\r\n function CountPushedButtonsInColon(Colon: Integer): Integer;\r\n function GetPushedButtonInLine(Index: Word): Integer;\r\n function SetPushedButtonInLine(Index: Word; Value: Word): Boolean;\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n published\r\n property AboutJVCL: TJVCLAboutInfo read FAboutJVCL write FAboutJVCL stored False;\r\n property Align;\r\n property BorderStyle;\r\n property Color;\r\n property DragCursor;\r\n property DragMode;\r\n property Enabled;\r\n property IntegralHeight;\r\n property Items;\r\n property ParentColor;\r\n // property ParentFont;\r\n property ParentShowHint;\r\n property PopupMenu;\r\n property ShowHint;\r\n property Sorted;\r\n property TabOrder;\r\n property TabStop;\r\n property Visible;\r\n property OnClick;\r\n property OnDblClick;\r\n property OnDragDrop;\r\n property OnDragOver;\r\n // property AfterItemWasDrown;\r\n property OnEndDrag;\r\n property OnEnter;\r\n property OnExit;\r\n property OnKeyDown;\r\n property OnKeyPress;\r\n property OnKeyUp;\r\n property OnMouseDown;\r\n property OnMouseMove;\r\n property OnMouseUp;\r\n property OnStartDrag;\r\n property AutoTransparentColor: TglAutoTransparentColor\r\n read FAutoTransparentColor write SetAutoTransparentColor default ftcLeftBottomPixel;\r\n property Wallpaper: TBitmap read GetWallpaper write SetWallpaper;\r\n property WallpaperImage: TImage read FWallpaperImage write SetWallpaperImage;\r\n property WallpaperOption: TglWallpaperOption read FWallpaperOption write\r\n SetWallpaperOption default fwoNone;\r\n property NumGlyphs: Word read FNumGlyphs write SetNumGlyphs default 1;\r\n property GlyphsAlign: TJvg2DAlign read FGlyphsAlign write FGlyphsAlign;\r\n property ItemStyle: TJvgAskListBoxItemStyle read FItemStyle write FItemStyle;\r\n property ItemSelStyle: TJvgAskListBoxItemStyle read FItemSelStyle write FItemSelStyle;\r\n property Glyphs: TImageList read FGlyphs write SetGlyphs;\r\n property TextAlign: TJvg2DAlign read FTextAlign write FTextAlign;\r\n property ItemHeight: Word read FItemHeight write SetItemHeight default 12;\r\n property ShowText: Boolean read FShowText write SetShowText default True;\r\n property TransparentColor: TColor read FTransparentColor write SetTransparentColor;\r\n property OnButtonClicked: TNotifyEvent read FOnButtonClicked write FOnButtonClicked;\r\n property SelectedItem: Word read FSelectedItem write SetSelectedItem default 0;\r\n property Buttons: TStrings read GetButtons write SetButtons;\r\n property ButtonWidth: Word read FButtonWidth write SetButtonWidth default 30;\r\n property Options: TglAskLBOptions read FOptions write SetOptions;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvgAskListBox.pas $';\r\n Revision: '$Revision: 13400 $';\r\n Date: '$Date: 2012-08-19 10:16:20 +0200 (dim. 19 août 2012) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n JvConsts, JvJCLUtils, JvJVCLUtils, JvResources,\r\n JvgUtils;\r\n\r\nconstructor TJvgAskListBox.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n Style := lbOwnerDrawVariable;\r\n FGlyphsAlign := TJvg2DAlign.Create;\r\n FTextAlign := TJvg2DAlign.Create;\r\n FCaptionsAlign := TJvg2DAlign.Create;\r\n FButtons := TStringList.Create;\r\n FItemStyle := TJvgAskListBoxItemStyle.Create;\r\n FItemSelStyle := TJvgAskListBoxItemStyle.Create;\r\n\r\n TmpBitmap := TBitmap.Create;\r\n FButtons.Add(RsYes);\r\n FButtons.Add(RsNo);\r\n FAutoTransparentColor := ftcLeftBottomPixel;\r\n FWallpaperOption := fwoNone;\r\n FShowWallpaper := True;\r\n FShowGlyphs := True;\r\n if csDesigning in ComponentState then\r\n begin\r\n with FItemStyle do\r\n begin\r\n // Style := idsRaised;\r\n Color := clBtnFace;\r\n BtnColor := clBtnFace;\r\n TextStyle := fstRaised;\r\n BtnTextStyle := fstPushed;\r\n end;\r\n with FItemSelStyle do\r\n begin\r\n // Style := idsRaised;\r\n Color := clBtnShadow;\r\n BtnColor := clBtnFace;\r\n TextStyle := fstRaised;\r\n BtnTextStyle := fstPushed;\r\n end;\r\n end;\r\n NumGlyphs := 1;\r\n FTransparentColor := clOlive;\r\n FItemHeight := 12;\r\n FTextAlign_ := DT_LEFT or DT_WORDBREAK or DT_VCENTER; // or DT_SINGLELINE;\r\n FCaptionsAlign_ := DT_CENTER or DT_VCENTER or DT_SINGLELINE;\r\n FShowText := True;\r\n FButtonWidth := 30;\r\n FSelectedItem := 0;\r\n FOptions := [aloWordWrap];\r\n FItemStyle.OnChanged := SmthChanged;\r\n FItemSelStyle.OnChanged := SmthChanged;\r\n FGlyphsAlign.OnChanged := SmthChanged;\r\n FTextAlign.OnChanged := SmthChanged;\r\n FCaptionsAlign.OnChanged := SmthChanged;\r\n\r\n FWallpaper := nil;\r\nend;\r\n\r\ndestructor TJvgAskListBox.Destroy;\r\nbegin\r\n FWallpaper.Free;\r\n TmpBitmap.Free;\r\n FGlyphsAlign.Free;\r\n FTextAlign.Free;\r\n FCaptionsAlign.Free;\r\n FButtons.Free;\r\n FItemStyle.Free;\r\n FItemSelStyle.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvgAskListBox.Loaded;\r\nbegin\r\n inherited Loaded;\r\n RecalcHeights;\r\nend;\r\n\r\nprocedure TJvgAskListBox.CNMeasureItem(var Msg: TWMMeasureItem);\r\nvar\r\n R: TRect;\r\nbegin\r\n R.Left := 3;\r\n R.Top := 0;\r\n R.Bottom := 0;\r\n R.Right := FSegment1Width;\r\n if FShowGlyphs and (FGlyphs <> nil) then\r\n Inc(R.Left, FGlyphs.Width);\r\n Dec(R.Right, 5);\r\n with Msg.MeasureItemStruct^ do\r\n begin\r\n DrawText(Canvas, Items[itemID],\r\n Length(Items[itemID]), R, DT_CALCRECT or DT_WORDBREAK);\r\n itemHeight := R.Bottom - R.Top + 6;\r\n if itemHeight < FItemHeight then\r\n itemHeight := FItemHeight;\r\n end;\r\nend;\r\n\r\nprocedure TJvgAskListBox.CNDrawItem(var Msg: TWMDrawItem);\r\nconst\r\n w = 1;\r\nvar\r\n Index: Integer;\r\n Rect: TRect;\r\n State: TOwnerDrawState;\r\n fSelected: Boolean;\r\n Shift, OldPushedBtn, I: Integer;\r\n Rect1: TRect;\r\n ItemStyle: TJvgAskListBoxItemStyle;\r\n // TS: TglTextStyle;\r\n // TA: UINT;\r\n\r\n procedure DrawLBItem(ItemSt: TglItemsDrawStyle; R: TRect);\r\n begin\r\n case ItemSt of\r\n idsRecessed:\r\n begin\r\n Shift := 0;\r\n Frame3D(Canvas, R, clBtnShadow, clBtnHighlight, 1);\r\n end;\r\n idsRaised:\r\n begin\r\n Shift := 2;\r\n Frame3D(Canvas, R, clBtnHighlight, clBtnShadow, 1);\r\n end;\r\n end;\r\n end;\r\n\r\n procedure DrawTextInRect(Rect: TRect; Align: Word; StrListNum: Integer);\r\n var\r\n FontColor: TColor;\r\n S: string;\r\n Len: Integer;\r\n TextStyle: TglTextStyle;\r\n begin\r\n Dec(Rect.Right, 2);\r\n if StrListNum = -1 then\r\n S := Items[Index]\r\n else\r\n S := Buttons[StrListNum - 1];\r\n\r\n Len := Length(S);\r\n\r\n if StrListNum = -1 then\r\n begin\r\n Canvas.Font := ItemStyle.Font;\r\n TextStyle := ItemStyle.TextStyle;\r\n end\r\n else\r\n begin\r\n Canvas.Font := ItemStyle.BtnFont;\r\n if FPushedButton[Index] = StrListNum then\r\n TextStyle := fstNone\r\n else\r\n TextStyle := ItemStyle.BtnTextStyle;\r\n end;\r\n\r\n FontColor := Canvas.Font.Color;\r\n SetBkMode(Canvas.Handle, TRANSPARENT);\r\n InflateRect(Rect, -1, -1);\r\n if StrListNum <> -1 then\r\n Inc(Rect.Top, 2);\r\n\r\n case TextStyle of\r\n fstRaised:\r\n begin\r\n Canvas.Font.Color := clBtnHighlight;\r\n OffsetRect(Rect, -1, -1);\r\n DrawText(Canvas, PChar(S), Len, Rect, Align);\r\n Canvas.Font.Color := clBtnShadow;\r\n OffsetRect(Rect, 2, 2);\r\n DrawText(Canvas, PChar(S), Len, Rect, Align);\r\n Canvas.Font.Color := FontColor;\r\n OffsetRect(Rect, -1, -1);\r\n DrawText(Canvas, PChar(S), Len, Rect, Align);\r\n end;\r\n fstRecessed:\r\n begin\r\n Canvas.Font.Color := clBtnShadow;\r\n OffsetRect(Rect, -1, -1);\r\n DrawText(Canvas, PChar(S), Len, Rect, Align);\r\n Canvas.Font.Color := clBtnHighlight;\r\n OffsetRect(Rect, 2, 2);\r\n DrawText(Canvas, PChar(S), Len, Rect, Align);\r\n Canvas.Font.Color := FontColor;\r\n OffsetRect(Rect, -1, -1);\r\n DrawText(Canvas, PChar(S), Len, Rect, Align);\r\n end;\r\n fstPushed:\r\n begin\r\n Canvas.Font.Color := clBtnHighlight;\r\n DrawText(Canvas, PChar(S), Len, Rect, Align);\r\n OffsetRect(Rect, -1, -1);\r\n Canvas.Font.Color := clBtnShadow;\r\n DrawText(Canvas, PChar(S), Len, Rect, Align);\r\n end;\r\n fstShadow:\r\n begin\r\n Canvas.Font.Color := clBtnShadow;\r\n OffsetRect(Rect, 2, 2);\r\n DrawText(Canvas, PChar(S), Len, Rect, Align);\r\n Canvas.Font.Color := FontColor;\r\n OffsetRect(Rect, -2, -2);\r\n DrawText(Canvas, PChar(S), Len, Rect, Align);\r\n end;\r\n else\r\n begin\r\n Canvas.Font.Color := FontColor;\r\n DrawText(Canvas, PChar(S), Len, Rect, Align);\r\n end;\r\n end;\r\n end;\r\n\r\nbegin\r\n with Msg.DrawItemStruct^ do\r\n begin\r\n Index := itemID;\r\n if Index = -1 then\r\n Exit;\r\n InitState(State, WordRec(LongRec(ItemState).Lo).Lo);\r\n // State := TOwnerDrawState(WordRec(LongRec(ItemState).Lo).Lo);\r\n Canvas.Handle := hDC;\r\n Rect := rcItem;\r\n end;\r\n\r\n if Length(FPushedButton) <> Items.Count then\r\n SetLength(FPushedButton, Items.Count);\r\n\r\n Canvas.Brush := Brush;\r\n // if State = [odSelected,odFocused] then Exit;\r\n Canvas.FrameRect(Rect);\r\n Inc(Rect.Top);\r\n Inc(Rect.Left);\r\n fSelected := (State = [odSelected, odFocused]) or (State = [odSelected]);\r\n\r\n if fSelected then\r\n begin\r\n ItemStyle := FItemSelStyle;\r\n Shift := 2;\r\n end\r\n else\r\n begin\r\n ItemStyle := FItemStyle;\r\n Shift := 0;\r\n end;\r\n Canvas.Brush.Color := ItemStyle.Color;\r\n\r\n Rect1 := Rect;\r\n Rect1.Right := FSegment1Width;\r\n\r\n if IsItAFilledBitmap(WallpaperBmp) then\r\n begin\r\n if aloTransparentButtons in Options then\r\n DrawWallpaper(Rect)\r\n else\r\n DrawWallpaper(Rect1);\r\n end\r\n else\r\n Canvas.FillRect(Rect1);\r\n\r\n //DrawLBItem( idsRecessed, Rect1 );\r\n DrawBoxEx(Canvas.Handle, Rect1, ItemStyle.Bevel.Sides, ItemStyle.Bevel.Inner,\r\n ItemStyle.Bevel.Outer, ItemStyle.Bevel.Bold, 0, True);\r\n if fSelected then\r\n begin\r\n InflateRect(Rect1, -1, -1);\r\n Canvas.FillRect(Rect1);\r\n InflateRect(Rect1, 1, 1);\r\n end;\r\n\r\n OldPushedBtn := FPushedButton[Index];\r\n\r\n BtnRect := Rect;\r\n BtnRect.Left := Rect1.Right + 2;\r\n BtnRect.Right := BtnRect.Left + FButtonWidth;\r\n\r\n Canvas.Brush.Color := ItemStyle.BtnColor;\r\n for I := 1 to Buttons.Count do // draw buttons\r\n begin\r\n if PtInRectExclusive(BtnRect, MouseClickPoint) then\r\n begin\r\n if I = FPushedButton[Index] then\r\n FPushedButton[Index] := 0 //...none pushed\r\n else\r\n FPushedButton[Index] := I;\r\n end;\r\n if not (aloTransparentButtons in Options) or\r\n (not IsItAFilledBitmap(WallpaperBmp)) then\r\n Canvas.FillRect(BtnRect);\r\n BtnTxtRect := BtnRect;\r\n if FPushedButton[Index] = I then\r\n begin\r\n DrawLBItem(idsRecessed, BtnRect);\r\n OffsetRect(BtnTxtRect, 1, 1);\r\n end\r\n else\r\n DrawLBItem(idsRaised, BtnRect);\r\n //...button text\r\n if FPushedButton[Index] = I then\r\n ItemStyle.BtnFont.Style := [fsBold]\r\n else\r\n ItemStyle.BtnFont.Style := [];\r\n DrawTextInRect(BtnTxtRect, FCaptionsAlign_ or DT_SINGLELINE, I);\r\n Inc(BtnRect.Left, FButtonWidth + 1);\r\n Inc(BtnRect.Right, FButtonWidth + 1);\r\n end;\r\n\r\n MouseClickPoint.X := -1;\r\n MouseClickPoint.Y := 0;\r\n\r\n Rect1.Left := 3;\r\n Rect1.Right := FSegment1Width;\r\n\r\n Inc(Rect1.Top);\r\n Inc(Rect.Left);\r\n Dec(Rect1.Bottom);\r\n Dec(Rect.Right);\r\n\r\n if (FShowGlyphs) and (FGlyphs <> nil) and\r\n (FGlyphs.Width > 0) and (FGlyphs.Height > 0) then\r\n begin\r\n DrawGlyph(Rect, Index, Shift);\r\n Rect1.Left := Rect1.Left + FGlyphs.Width;\r\n end;\r\n //...text\r\n DrawTextInRect(Rect1, FTextAlign_, -1);\r\n\r\n with Msg.DrawItemStruct^ do\r\n if (odFocused in State) and (aloShowFocus in Options) then\r\n DrawFocusRect(hDC, rcItem);\r\n\r\n FSelectedItem := Index;\r\n if OldPushedBtn <> FPushedButton[Index] then\r\n ButtonClicked;\r\n Canvas.Handle := 0;\r\nend;\r\n\r\nprocedure TJvgAskListBox.DrawWallpaper(R: TRect);\r\nvar\r\n X, Y, SaveIndex: Integer;\r\n UpdateRgn: HRGN;\r\nbegin\r\n X := 0;\r\n Y := 0;\r\n SaveIndex := SaveDC(Canvas.Handle);\r\n UpdateRgn := CreateRectRgn(R.Left, R.Top, R.Right, R.Bottom);\r\n\r\n SelectClipRgn(Canvas.Handle, UpdateRgn);\r\n case WallpaperOption of\r\n fwoStretch:\r\n Canvas.StretchDraw(R, WallpaperBmp);\r\n fwoTile:\r\n while X < R.Right - R.Left do\r\n begin\r\n while Y < R.Bottom - R.Top do\r\n begin\r\n Canvas.Draw(R.Left + X, R.Top + Y, WallpaperBmp);\r\n Inc(Y, WallpaperBmp.Height);\r\n end;\r\n Inc(X, WallpaperBmp.Width);\r\n Y := 0;\r\n end;\r\n else\r\n Canvas.Draw(R.Left, R.Top, WallpaperBmp);\r\n end;\r\n DeleteObject(UpdateRgn);\r\n RestoreDC(Canvas.Handle, SaveIndex);\r\nend;\r\n\r\nprocedure TJvgAskListBox.DrawGlyph(R: TRect; Index: Word; Shift: Word);\r\nvar\r\n I: Integer;\r\n OldRect: TRect;\r\nbegin\r\n if (FGlyphs = nil) or (FGlyphs.Count = 0) then\r\n Exit;\r\n R.Right := R.Left + FSegment1Width - 4;\r\n OldRect := R;\r\n Inc(R.Top);\r\n Inc(R.Left);\r\n case FGlyphsAlign.Horizontal of\r\n fhaCenter:\r\n OffsetRect(R, (R.Right - R.Left - Glyphs.Width) div 2, 0);\r\n fhaRight:\r\n OffsetRect(R, R.Right - R.Left - Glyphs.Width - Shift, 0);\r\n end;\r\n case FGlyphsAlign.Vertical of\r\n fvaCenter:\r\n OffsetRect(R, 0, (R.Bottom - R.Top - Glyphs.Height) div 2);\r\n fvaBottom:\r\n OffsetRect(R, 0, R.Bottom - R.Top - Glyphs.Height - Shift);\r\n end;\r\n\r\n I := -1;\r\n if NumGlyphs = 1 then\r\n I := 0\r\n else\r\n if Index < NumGlyphs then\r\n I := Index;\r\n if I >= 0 then\r\n begin\r\n FGlyphs.GetBitmap(I, TmpBitmap);\r\n if FAutoTransparentColor = ftcUser then\r\n CreateBitmapExt(Canvas.Handle, TmpBitmap, Rect(0, 0, 100, 100), R.Left,\r\n R.Top, fwoNone, fdsDefault, True, FTransparentColor, clBlack)\r\n else\r\n CreateBitmapExt(Canvas.Handle, TmpBitmap, Rect(0, 0, 100, 100), R.Left,\r\n R.Top, fwoNone, fdsDefault, True,\r\n GetTransparentColor(TmpBitmap, FAutoTransparentColor), clBlack);\r\n end;\r\nend;\r\n\r\nprocedure TJvgAskListBox.SetAutoTransparentColor(Value: TglAutoTransparentColor);\r\nbegin\r\n if FAutoTransparentColor = Value then\r\n Exit;\r\n FAutoTransparentColor := Value;\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvgAskListBox.SetWallpaper(Value: TBitmap);\r\nbegin\r\n if Assigned(FWallpaper) then\r\n FWallpaper.Free;\r\n FWallpaper := TBitmap.Create;\r\n FWallpaper.Assign(Value);\r\n if (not Assigned(Value)) and Assigned(WallpaperImage) then\r\n if Assigned(FWallpaper) then\r\n WallpaperBmp := FWallpaper\r\n else\r\n if Assigned(FWallpaperImage) then\r\n WallpaperBmp := FWallpaperImage.Picture.Bitmap\r\n else\r\n WallpaperBmp := nil;\r\n\r\n if FShowWallpaper then\r\n Invalidate;\r\nend;\r\n\r\nfunction TJvgAskListBox.GetWallpaper: TBitmap;\r\nbegin\r\n if not Assigned(FWallpaper) then\r\n FWallpaper := TBitmap.Create;\r\n WallpaperBmp := FWallpaper;\r\n Result := FWallpaper;\r\nend;\r\n\r\nprocedure TJvgAskListBox.SetWallpaperImage(Value: TImage);\r\nbegin\r\n ReplaceComponentReference(Self, Value, TComponent(FWallpaperImage));\r\n if (not IsItAFilledBitmap(FWallpaper)) and Assigned(Value) then\r\n begin\r\n WallpaperBmp := Value.Picture.Bitmap;\r\n if FShowWallpaper then\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvgAskListBox.SetWallpaperOption(Value: TglWallpaperOption);\r\nbegin\r\n FWallpaperOption := Value;\r\n if FShowWallpaper then\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvgAskListBox.SetNumGlyphs(Value: Word);\r\nbegin\r\n if Value < 1 then\r\n Exit;\r\n FNumGlyphs := Value;\r\n if FShowGlyphs then\r\n Invalidate;\r\nend;\r\n\r\n{procedure TJvgAskListBox.SetItemStyle( Value: TItemsDrawStyle );\r\nbegin\r\n if FItemStyle = Value then Exit;\r\n FItemStyle := Value;\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvgAskListBox.SetSelItemStyle( Value: TItemsDrawStyle );\r\nbegin\r\n if FSelItemStyle = Value then Exit;\r\n FSelItemStyle := Value;\r\n Invalidate;\r\nend;\r\n}\r\n\r\nprocedure TJvgAskListBox.SetGlyphs(Value: TImageList);\r\nbegin\r\n //if (Value=nil)or(Value.Width<=0)or(Value.Height<=0) then Exit;\r\n ReplaceComponentReference(Self, Value, TComponent(FGlyphs));\r\n if FShowGlyphs then\r\n Invalidate;\r\nend;\r\n\r\n{procedure TJvgAskListBox.SetSelFont( Value: TFont );\r\nbegin\r\n if Value=nil then Exit;\r\n FSelFont.Assign( Value );\r\n Invalidate;\r\nend;\r\n}\r\n\r\n{\r\nprocedure TJvgAskListBox.SetColor(Value: TColor);\r\nbegin\r\n if FColor = Value then Exit;\r\n FColor := Value; Canvas.Brush.Color:=Value; Invalidate;\r\nend;\r\n\r\nprocedure TJvgAskListBox.SetSelColor(Value: TColor);\r\nbegin\r\n if FColor = Value then Exit;\r\n FSelColor := Value; Canvas.Brush.Color:=Value; Invalidate;\r\nend;\r\n}\r\n\r\nprocedure TJvgAskListBox.SetItemHeight(Value: Word);\r\nbegin\r\n if (Value > 6) and (FItemHeight <> Value) then\r\n begin\r\n FItemHeight := Value;\r\n //inherited ItemHeight:=FItemHeight;\r\n RecalcHeights;\r\n end;\r\nend;\r\n\r\nprocedure TJvgAskListBox.SetAlign(Align: TJvg2DAlign; var Align_: UINT);\r\nbegin\r\n case Align.Horizontal of\r\n fhaLeft:\r\n Align_ := Align_ or DT_LEFT;\r\n fhaCenter:\r\n Align_ := Align_ or DT_CENTER;\r\n else\r\n Align_ := Align_ or DT_RIGHT;\r\n end;\r\n case Align.Vertical of\r\n fvaTop:\r\n Align_ := Align_ or DT_TOP;\r\n fvaCenter:\r\n Align_ := Align_ or DT_VCENTER;\r\n else\r\n Align_ := Align_ or DT_BOTTOM;\r\n end;\r\nend;\r\n\r\n{\r\nprocedure TJvgAskListBox.SetTextStyle(Value: TglTextStyle);\r\nbegin\r\n if FTextStyle = Value then Exit;\r\n FTextStyle := Value; if FShowText then Invalidate;\r\nend;\r\n\r\nprocedure TJvgAskListBox.SetButtonsTextStyle(Value: TglTextStyle);\r\nbegin\r\n if FButtonsTextStyle = Value then Exit;\r\n FButtonsTextStyle := Value; if FShowText then Invalidate;\r\nend;\r\n}\r\n\r\nprocedure TJvgAskListBox.SetShowText(Value: Boolean);\r\nbegin\r\n if FShowText <> Value then\r\n begin\r\n FShowText := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvgAskListBox.SetTransparentColor(Value: TColor);\r\nbegin\r\n if FTransparentColor <> Value then\r\n begin\r\n FTransparentColor := Value;\r\n if FShowGlyphs then\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvgAskListBox.SetButtonWidth(Value: Word);\r\nbegin\r\n if FButtonWidth <> Value then\r\n begin\r\n FButtonWidth := Value;\r\n RecalcHeights;\r\n end;\r\nend;\r\n\r\nprocedure TJvgAskListBox.SetOptions(Value: TglAskLBOptions);\r\nbegin\r\n if FOptions <> Value then\r\n begin\r\n FOptions := Value;\r\n RecalcHeights;\r\n end;\r\nend;\r\n\r\nfunction TJvgAskListBox.IsFilled: Boolean;\r\nvar\r\n I: Word;\r\nbegin\r\n Result := False;\r\n if Length(FPushedButton) <> Items.Count then\r\n SetLength(FPushedButton, Items.Count);\r\n for I := 0 to Items.Count - 1 do\r\n if FPushedButton[I] = 0 then\r\n Exit;\r\n Result := True;\r\nend;\r\n\r\nfunction TJvgAskListBox.CountPushedButtonsInColon(Colon: Integer): Integer;\r\nvar\r\n I: Word;\r\nbegin\r\n Result := 0;\r\n if Length(FPushedButton) <> Items.Count then\r\n SetLength(FPushedButton, Items.Count);\r\n if Colon = 0 then\r\n begin\r\n for I := 0 to Items.Count - 1 do\r\n if FPushedButton[I] <> 0 then\r\n Inc(Result);\r\n end\r\n else\r\n for I := 0 to Items.Count - 1 do\r\n if FPushedButton[I] = Colon then\r\n Inc(Result);\r\nend;\r\n\r\nprocedure TJvgAskListBox.SetSelectedItem(Value: Word);\r\nbegin\r\n if Value >= Items.Count then\r\n Exit;\r\n SendMessage(Handle, LB_SETCURSEL, Value, 0);\r\nend;\r\n\r\nfunction TJvgAskListBox.GetButtons: TStrings;\r\nbegin\r\n Result := FButtons;\r\nend;\r\n\r\nprocedure TJvgAskListBox.SetButtons(Value: TStrings);\r\nbegin\r\n if (Value <> nil) and (Value.Count <> 0) then\r\n begin\r\n FButtons.Assign(Value);\r\n RecalcHeights;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nfunction TJvgAskListBox.GetPushedButtonInLine(Index: Word): Integer;\r\nbegin\r\n if Index >= Items.Count then\r\n Result := -1\r\n else\r\n begin\r\n if Length(FPushedButton) <> Items.Count then\r\n SetLength(FPushedButton, Items.Count);\r\n Result := FPushedButton[Index];\r\n end;\r\nend;\r\n\r\nfunction TJvgAskListBox.SetPushedButtonInLine(Index: Word; Value: Word): Boolean;\r\nvar\r\n R: TRect;\r\nbegin\r\n if (Index < Items.Count) and (Value <= FButtons.Count) then\r\n begin\r\n Result := True;\r\n if Length(FPushedButton) <> Items.Count then\r\n SetLength(FPushedButton, Items.Count);\r\n if FPushedButton[Index] = Value then\r\n Exit;\r\n FPushedButton[Index] := Value;\r\n SendMessage(Handle, LB_GETITEMRECT, Index, LPARAM(@R));\r\n R.Left := FSegment1Width;\r\n Windows.InvalidateRect(Handle, @R, True);\r\n //ButtonClicked;\r\n if (aloAutoScroll in Options) and (Value <> 0) then\r\n SendMessage(Handle, LB_SETCURSEL, Index, 0);\r\n end\r\n else\r\n Result := False;\r\nend;\r\n\r\nprocedure TJvgAskListBox.WMLButtonDown(var Msg: TWMLButtonDown);\r\nvar\r\n R: TRect;\r\n ItemN: Integer;\r\nbegin\r\n inherited;\r\n if aloIgnoreMouse in Options then\r\n Exit;\r\n MouseClickPoint.X := Msg.XPos;\r\n MouseClickPoint.Y := Msg.YPos;\r\n if Msg.XPos > Integer(FSegment1Width) then\r\n begin\r\n ItemN := ItemAtPos(SmallPointToPoint(Msg.Pos), True);\r\n SendMessage(Handle, LB_GETITEMRECT, ItemN, LPARAM(@R));\r\n Inc(R.Left, FSegment1Width);\r\n Windows.InvalidateRect(Handle, @R, False);\r\n //if aloAutoScroll in Options then\r\n // SendMessage( Handle, LB_SETCURSEL, FSelectedItem + 1, 0);\r\n end;\r\nend;\r\n\r\nprocedure TJvgAskListBox.WMSize(var Msg: TWMSize);\r\nbegin\r\n inherited;\r\n RecalcHeights;\r\nend;\r\n\r\nprocedure TJvgAskListBox.ButtonClicked;\r\nbegin\r\n if Assigned(FOnButtonClicked) then\r\n FOnButtonClicked(Self);\r\nend;\r\n\r\nprocedure TJvgAskListBox.RecalcHeights;\r\nvar\r\n I: Integer;\r\n R: TRect;\r\nbegin\r\n if Items.Count = 0 then\r\n Exit;\r\n\r\n SendMessage(Handle, LB_GETITEMRECT, Items.Count - 1, LPARAM(@R));\r\n FSegment1Width := Word((R.Right - R.Left) - (FButtonWidth + 1) * (Buttons.Count) - 1);\r\n\r\n Items.BeginUpdate;\r\n for I := 0 to Items.Count - 1 do\r\n begin\r\n Items.InsertObject(I, Items[I], Items.Objects[I]);\r\n Items.Delete(I + 1);\r\n end;\r\n Items.EndUpdate;\r\nend;\r\n\r\nprocedure TJvgAskListBox.SmthChanged(Sender: TObject);\r\nbegin\r\n FTextAlign_ := DT_WORDBREAK;\r\n FCaptionsAlign_ := DT_SINGLELINE;\r\n SetAlign(FTextAlign, FTextAlign_);\r\n SetAlign(FCaptionsAlign, FCaptionsAlign_);\r\n FCaptionsAlign_ := DT_CENTER or DT_VCENTER or DT_SINGLELINE;\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvgAskListBox.InitState(var State: TOwnerDrawState; ByteState: Byte);\r\nbegin\r\n State := [];\r\n if ByteState and ODS_CHECKED <> 0 then\r\n Include(State, odChecked); //TOwnerDrawState\r\n if ByteState and ODS_COMBOBOXEDIT <> 0 then\r\n Include(State, odComboBoxEdit);\r\n if ByteState and ODS_DEFAULT <> 0 then\r\n Include(State, odDefault);\r\n if ByteState and ODS_DISABLED <> 0 then\r\n Include(State, odDisabled);\r\n if ByteState and ODS_FOCUS <> 0 then\r\n Include(State, odFocused);\r\n if ByteState and ODS_GRAYED <> 0 then\r\n Include(State, odGrayed);\r\n if ByteState and ODS_SELECTED <> 0 then\r\n Include(State, odSelected);\r\nend;\r\n\r\nprocedure TJvgAskListBox.Notification(AComponent: TComponent; Operation: TOperation);\r\nbegin\r\n inherited Notification(AComponent, Operation);\r\n if (AComponent = WallpaperImage) and (Operation = opRemove) then\r\n WallpaperImage := nil;\r\n if (AComponent = FGlyphs) and (Operation = opRemove) then\r\n Glyphs := nil;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvgButton.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvgButton.PAS, released on 2003-01-15.\r\n\r\nThe Initial Developer of the Original Code is Andrey V. Chudin, [chudin att yandex dott ru]\r\nPortions created by Andrey V. Chudin are Copyright (C) 2003 Andrey V. Chudin.\r\nAll Rights Reserved.\r\n\r\nContributor(S):\r\nMichael Beck [mbeck att bigfoot dott com].\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI'S JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvgButton.pas 13075 2011-06-27 22:56:21Z jfudickar $\r\n\r\nunit JvgButton;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, Messages, SysUtils, Classes, Graphics,\r\n Controls, Forms, Dialogs, ExtCtrls, ImgList,\r\n JvComponent,\r\n JvgTypes, JvgUtils, JvgCommClasses;\r\n\r\ntype\r\n TDrawMode = (dmUseImageList, dmAutoCtrl3D, dmAutoFlat, dmAutoShadow);\r\n\r\n TglButtonOption = (boBlinkWhenActive, boBlinkWhenInactive,\r\n boBlinkWhenPushed, boChangeColorWhenActive,\r\n boChangeColorWhenPushed, boDelicateInactive,\r\n boDrawPushedAsFlat, boRaisedInactive,\r\n boRefreshOnActivate, boRefreshOnPush,\r\n boShadowSurround, boShiftMouseOnPush);\r\n\r\n TglButtonOptions = set of TglButtonOption;\r\n\r\n TglBtnState = (fbsOriginal, fbsInactive, fbsActive, fbsPushed, fbsDisabled);\r\n\r\n TJvgGlyphsIndexes = class(TPersistent)\r\n private\r\n FInactive: Integer;\r\n FPushed: Integer;\r\n FActive: Integer;\r\n FDisabled: Integer;\r\n FMask: Integer;\r\n FOnChanged: TNotifyEvent;\r\n procedure SetInactive(Value: Integer);\r\n procedure SetPushed(Value: Integer);\r\n procedure SetActive(Value: Integer);\r\n procedure SetDisabled(Value: Integer);\r\n procedure SetMask(Value: Integer);\r\n protected\r\n procedure DoChanged; virtual;\r\n public\r\n constructor Create;\r\n property OnChanged: TNotifyEvent read FOnChanged write FOnChanged stored False;\r\n published\r\n property Inactive: Integer read FInactive write SetInactive default 0;\r\n property Pushed: Integer read FPushed write SetPushed default 1;\r\n property Active: Integer read FActive write SetActive default 2;\r\n property Disabled: Integer read FDisabled write SetDisabled default -1;\r\n property Mask: Integer read FMask write SetMask default 3;\r\n end;\r\n\r\n TJvgBtnGlyphs = class(TPersistent)\r\n private\r\n FGlyphInactive: TBitmap;\r\n FGlyphMask: TBitmap;\r\n FGlyphPushed: TBitmap;\r\n FGlyphActive: TBitmap;\r\n FGlyphDisabled: TBitmap;\r\n procedure SetGlyphInactive(Value: TBitmap);\r\n procedure SetGlyphMask(Value: TBitmap);\r\n procedure SetGlyphPushed(Value: TBitmap);\r\n procedure SetGlyphActive(Value: TBitmap);\r\n procedure SetGlyphDisabled(Value: TBitmap);\r\n public\r\n constructor Create;\r\n destructor Destroy; override;\r\n published\r\n property GlyphInactive: TBitmap read FGlyphInactive write SetGlyphInactive;\r\n property GlyphMask: TBitmap read FGlyphMask write SetGlyphMask;\r\n property GlyphPushed: TBitmap read FGlyphPushed write SetGlyphPushed;\r\n property GlyphActive: TBitmap read FGlyphActive write SetGlyphActive;\r\n property GlyphDisabled: TBitmap read FGlyphDisabled write SetGlyphDisabled;\r\n end;\r\n\r\n TJvgButton = class(TJvGraphicControl)\r\n private\r\n FGlyph: TBitmap;\r\n FGlyphs: TJvgBtnGlyphs;\r\n FDrawMode: TDrawMode;\r\n FGlyphsList: TImageList;\r\n FTransparentColor: TColor;\r\n FNumGlyphs: Integer;\r\n FShiftMaskWhenPushed: TJvgPointClass;\r\n FEnabled: Boolean;\r\n FOptions: TglButtonOptions;\r\n FShadowDepth: Word;\r\n FGlyphsIndexes: TJvgGlyphsIndexes;\r\n FColorHighlight: TColor;\r\n FColorShadow: TColor;\r\n FColorDarkShadow: TColor;\r\n FDisabledMaskColor: TColor;\r\n FChangeColorOnActivate: TJvgTwainColors;\r\n FChangeColorOnPush: TJvgTwainColors;\r\n FAutoTrColor: TglAutoTransparentColor;\r\n FBlinkTimer: TTimer;\r\n FOnClick: TNotifyEvent;\r\n\r\n TmpBMP: TBitmap;\r\n Img: TBitmap;\r\n DefaultGlyphsList: TImageList;\r\n FBitmapsCreated: Boolean;\r\n FMouseInControl: Boolean;\r\n FPushed: Boolean;\r\n FShowingAsPushedNow: Boolean;\r\n FActiveNow: Boolean;\r\n FLoaded: Boolean;\r\n FBlinked: Boolean;\r\n FNeedBlink: Boolean;\r\n MShift: TPoint;\r\n FTestMode: Boolean;\r\n\r\n procedure SetGlyph(Value: TBitmap);\r\n procedure SetDrawMode(Value: TDrawMode);\r\n procedure SetGlyphsList(Value: TImageList);\r\n procedure SetNumGlyphs(Value: Integer);\r\n procedure SetTransparentColor(Value: TColor);\r\n procedure SetShadowDepth(Value: Word);\r\n procedure SetColorHighlight(Value: TColor);\r\n procedure SetColorShadow(Value: TColor);\r\n procedure SetColorDarkShadow(Value: TColor);\r\n procedure SetDisabledMaskColor(Value: TColor);\r\n procedure SetOptions(Value: TglButtonOptions);\r\n procedure SetAutoTrColor(Value: TglAutoTransparentColor);\r\n procedure SetBlinkTimer(Value: TTimer);\r\n function GetBlinkTimer: TTimer;\r\n procedure SetTestMode(Value: Boolean);\r\n\r\n function IsMouseInControl: Boolean;\r\n procedure GetBitmaps;\r\n procedure CreateBitmaps; //...based on Inactive Glyph\r\n procedure GetBitmap_(Index: Integer; var Bmp: TBitmap);\r\n procedure SmthChanged(Sender: TObject);\r\n procedure ApplicateGlyph(var TargetBMP: TBitmap; State: TglBtnState;\r\n DrawState: TglDrawState; S: Integer);\r\n protected\r\n procedure SetEnabled(Value: Boolean); override;\r\n procedure Paint; override;\r\n procedure Paint_;\r\n procedure Loaded; override;\r\n procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;\r\n procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;\r\n procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;\r\n procedure MouseLeave(Control: TControl); override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n procedure OnBlinkTimer(Sender: TObject);\r\n published\r\n property ShowHint default True;\r\n property Glyphs: TJvgBtnGlyphs read FGlyphs write FGlyphs;\r\n property DrawMode: TDrawMode read FDrawMode write SetDrawMode;\r\n property GlyphsList: TImageList read FGlyphsList write SetGlyphsList;\r\n property Glyph: TBitmap read FGlyph write SetGlyph;\r\n property NumGlyphs: Integer read FNumGlyphs write SetNumGlyphs;\r\n property TransparentColor: TColor read FTransparentColor write SetTransparentColor default clOlive;\r\n property ShiftMaskWhenPushed: TJvgPointClass read FShiftMaskWhenPushed write FShiftMaskWhenPushed;\r\n property Enabled: Boolean read FEnabled write SetEnabled default True;\r\n property GlyphsIndexes: TJvgGlyphsIndexes read FGlyphsIndexes write FGlyphsIndexes;\r\n property ShadowDepth: Word read FShadowDepth write SetShadowDepth default 5;\r\n property ColorHighlight: TColor read FColorHighlight write SetColorHighlight default clBtnHighlight;\r\n property ColorShadow: TColor read FColorShadow write SetColorShadow default clBtnShadow;\r\n property ColorDarkShadow: TColor read FColorDarkShadow write SetColorDarkShadow default clBlack;\r\n property DisabledMaskColor: TColor read FDisabledMaskColor write SetDisabledMaskColor default clBlack;\r\n property Options: TglButtonOptions read FOptions write SetOptions;\r\n property ChangeColorOnActivate: TJvgTwainColors read FChangeColorOnActivate write FChangeColorOnActivate;\r\n property ChangeColorOnPush: TJvgTwainColors read FChangeColorOnPush write FChangeColorOnPush;\r\n property AutoTransparentColor: TglAutoTransparentColor read FAutoTrColor write SetAutoTrColor default ftcUser;\r\n property BlinkTimer: TTimer read GetBlinkTimer write SetBlinkTimer;\r\n property TestMode: Boolean read FTestMode write SetTestMode default False;\r\n property HintColor;\r\n property OnParentColorChange;\r\n property OnMouseEnter;\r\n property OnMouseLeave;\r\n property OnClick: TNotifyEvent read FOnClick write FOnClick;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvgButton.pas $';\r\n Revision: '$Revision: 13075 $';\r\n Date: '$Date: 2011-06-28 00:56:21 +0200 (mar. 28 juin 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n JvConsts, JvJCLUtils, JvResources, JvThemes;\r\n\r\n{$R JvgButton.res}\r\n\r\n//=== { TJvgBtnGlyphs } ======================================================\r\n\r\nconstructor TJvgBtnGlyphs.Create;\r\nbegin\r\n inherited Create;\r\n FGlyphInactive := TBitmap.Create;\r\n FGlyphMask := TBitmap.Create;\r\n FGlyphPushed := TBitmap.Create;\r\n FGlyphActive := TBitmap.Create;\r\n FGlyphDisabled := TBitmap.Create;\r\nend;\r\n\r\ndestructor TJvgBtnGlyphs.Destroy;\r\nbegin\r\n FGlyphInactive.Free;\r\n FGlyphMask.Free;\r\n FGlyphPushed.Free;\r\n FGlyphActive.Free;\r\n FGlyphDisabled.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvgBtnGlyphs.SetGlyphInactive(Value: TBitmap);\r\nbegin\r\n GlyphInactive.Assign(Value);\r\nend;\r\n\r\nprocedure TJvgBtnGlyphs.SetGlyphMask(Value: TBitmap);\r\nbegin\r\n GlyphMask.Assign(Value);\r\nend;\r\n\r\nprocedure TJvgBtnGlyphs.SetGlyphPushed(Value: TBitmap);\r\nbegin\r\n GlyphPushed.Assign(Value);\r\nend;\r\n\r\nprocedure TJvgBtnGlyphs.SetGlyphActive(Value: TBitmap);\r\nbegin\r\n GlyphActive.Assign(Value);\r\nend;\r\n\r\nprocedure TJvgBtnGlyphs.SetGlyphDisabled(Value: TBitmap);\r\nbegin\r\n GlyphDisabled.Assign(Value);\r\nend;\r\n\r\n//=== { TJvgButton } =========================================================\r\n\r\nconstructor TJvgButton.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n ControlStyle := [csCaptureMouse, csOpaque, csDoubleClicks];\r\n IncludeThemeStyle(Self, [csParentBackground]);\r\n FGlyph := TBitmap.Create;\r\n FGlyphs := TJvgBtnGlyphs.Create;\r\n DefaultGlyphsList := TImageList.CreateSize(30, 30);\r\n Img := TBitmap.Create;\r\n TmpBMP := TBitmap.Create;\r\n FShiftMaskWhenPushed := TJvgPointClass.Create;\r\n FGlyphsIndexes := TJvgGlyphsIndexes.Create;\r\n FChangeColorOnActivate := TJvgTwainColors.Create;\r\n FChangeColorOnPush := TJvgTwainColors.Create;\r\n FGlyphsIndexes.OnChanged := SmthChanged;\r\n //...set defaults\r\n FShiftMaskWhenPushed.X := 0;\r\n FShiftMaskWhenPushed.Y := 0;\r\n FEnabled := True;\r\n FGlyphsList := nil;\r\n FNumGlyphs := 3;\r\n FDrawMode := dmUseImageList;\r\n FShadowDepth := 5;\r\n FColorHighlight := clBtnHighlight;\r\n FColorShadow := clBtnShadow;\r\n FColorDarkShadow := clBlack;\r\n FDisabledMaskColor := clBlack;\r\n FTestMode := False;\r\n ShowHint := True;\r\n FOptions := [boRaisedInactive, boShadowSurround, boShiftMouseOnPush,\r\n boChangeColorWhenActive, boChangeColorWhenPushed,\r\n boBlinkWhenActive];\r\n if DefaultGlyphsList.ResourceLoad(rtBitmap, 'JvgButtonDEFAULT', clNone) then\r\n begin\r\n FGlyphsList := DefaultGlyphsList;\r\n GetBitmaps;\r\n end;\r\n FPushed := False;\r\n FChangeColorOnActivate.FromColor := clBlack;\r\n FChangeColorOnActivate.ToColor := clBlack;\r\n FChangeColorOnPush.FromColor := clBlack;\r\n FChangeColorOnPush.ToColor := clBlack;\r\n FTransparentColor := clOlive;\r\n FAutoTrColor := {ftcLeftBottomPixel;} ftcUser;\r\n Width := 20;\r\n Height := 20;\r\n FLoaded := False;\r\nend;\r\n\r\ndestructor TJvgButton.Destroy;\r\nbegin\r\n FGlyphsList := nil;\r\n FGlyphs.Free;\r\n FGlyph.Free;\r\n DefaultGlyphsList.Free;\r\n Img.Free;\r\n TmpBMP.Free;\r\n FShiftMaskWhenPushed.Free;\r\n FGlyphsIndexes.Free;\r\n FChangeColorOnActivate.Free;\r\n FChangeColorOnPush.Free;\r\n if not (csDestroying in Owner.ComponentState) then\r\n SetBlinkTimer(nil);\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvgButton.Loaded;\r\nbegin\r\n inherited Loaded;\r\n FLoaded := True;\r\nend;\r\n\r\nprocedure TJvgButton.Paint;\r\nvar\r\n DrawState: TglDrawState;\r\n I: Word;\r\nbegin\r\n with Glyphs do\r\n begin\r\n if not FLoaded then\r\n begin\r\n FLoaded := True;\r\n GetBitmaps;\r\n end;\r\n Width := FGlyphInactive.Width + 1;\r\n Height := FGlyphInactive.Height + 1;\r\n FShowingAsPushedNow := FPushed and FMouseInControl;\r\n FActiveNow := True;\r\n\r\n with Img do\r\n begin\r\n Width := Self.Width;\r\n Height := Self.Height;\r\n Canvas.Brush.Color := clBtnFace;\r\n Canvas.Brush.Style := bsSolid;\r\n Canvas.FillRect(ClientRect);\r\n end;\r\n GetParentImageRect(Self, Bounds(Left, Top, Width, Height),\r\n Img.Canvas.Handle);\r\n\r\n if boDelicateInactive in FOptions then\r\n DrawState := fdsDelicate\r\n else\r\n DrawState := fdsDefault;\r\n\r\n if FEnabled then\r\n begin\r\n if FMouseInControl then\r\n begin\r\n if FPushed then\r\n begin\r\n if (boDrawPushedAsFlat in FOptions) and (FDrawMode <>\r\n dmUseImageList) then\r\n ApplicateGlyph(Img, fbsOriginal {fbsPushed}, fdsDefault, 3)\r\n else\r\n begin\r\n if FDrawMode = dmAutoFlat then\r\n I := 2\r\n else\r\n I := 0;\r\n ApplicateGlyph(Img, fbsPushed, fdsDefault, I);\r\n end;\r\n end\r\n else\r\n begin\r\n FActiveNow := False;\r\n if (FDrawMode = dmAutoFlat) then\r\n I := 1\r\n else\r\n I := 0;\r\n ApplicateGlyph(Img, fbsActive, fdsDefault, I);\r\n end;\r\n end\r\n else\r\n begin\r\n if (FDrawMode = dmAutoFlat) and\r\n ({FPushed or }(not (boRaisedInactive in FOptions))) then\r\n ApplicateGlyph(Img, fbsOriginal, DrawState, 2)\r\n else\r\n begin\r\n if (FDrawMode = dmAutoFlat) then\r\n I := 1\r\n else\r\n I := 0;\r\n ApplicateGlyph(Img, fbsInactive, DrawState, I);\r\n end;\r\n end;\r\n end\r\n else\r\n begin\r\n if (FDrawMode = dmAutoFlat) and (boRaisedInactive in Options) then\r\n I := 1\r\n else\r\n I := 0;\r\n if DrawMode <> dmUseImageList then //...auto disabled\r\n ApplicateGlyph(Img, fbsDisabled, fdsDisabled, I)\r\n else\r\n begin //...user'S disabled\r\n if FGlyphsIndexes.Disabled = -1 then\r\n CreateBitmapExt(Img.Canvas.Handle, FGlyphInactive, ClientRect, 0,\r\n 0,\r\n fwoNone, fdsDisabled, True, FTransparentColor,\r\n DisabledMaskColor)\r\n else\r\n CreateBitmapExt(Img.Canvas.Handle, FGlyphDisabled, ClientRect, 0,\r\n 0,\r\n fwoNone, fdsDefault, True, FTransparentColor,\r\n DisabledMaskColor);\r\n end;\r\n end;\r\n Img.Transparent := True;\r\n Img.TransparentColor := clBtnFace;\r\n Canvas.Draw(0, 0, Img);\r\n end;\r\nend;\r\n\r\nprocedure TJvgButton.Paint_;\r\nbegin\r\n if not Enabled then\r\n Exit;\r\n if FChangeColorOnActivate.FromColor <> FChangeColorOnActivate.ToColor then\r\n begin\r\n Repaint;\r\n Exit;\r\n end;\r\n if ((FDrawMode = dmAutoCtrl3D) or (FDrawMode = dmAutoShadow)) and\r\n (not FShowingAsPushedNow) and (not FPushed) and (not (boDelicateInactive in FOptions)) then\r\n Exit;\r\n if (FDrawMode = dmAutoFlat) and (not FShowingAsPushedNow) and (not FPushed) and\r\n (boRaisedInactive in FOptions) and (not (boDelicateInactive in FOptions)) then\r\n Exit;\r\n\r\n Repaint;\r\n Exit;\r\n\r\n // (rom) unused code\r\n if (FDrawMode = dmAutoFlat) and\r\n (FShowingAsPushedNow or (not (boRaisedInactive in FOptions))) then\r\n begin\r\n Repaint;\r\n Exit;\r\n end;\r\n if FPushed then\r\n begin\r\n if (boRefreshOnPush in FOptions) or (FDrawMode = dmAutoShadow) then\r\n Repaint\r\n else\r\n Paint;\r\n end\r\n else\r\n if boRefreshOnActivate in FOptions then\r\n Repaint\r\n else\r\n Paint;\r\nend;\r\n\r\nprocedure TJvgButton.ApplicateGlyph(var TargetBMP: TBitmap; State: TglBtnState;\r\n DrawState: TglDrawState; S: Integer);\r\nvar\r\n I, J: Integer;\r\n fChangeColor, fCanBlink: Boolean;\r\n DrawState2: TglDrawState;\r\nbegin\r\n with Glyphs do\r\n begin\r\n I := 1;\r\n J := 1;\r\n fChangeColor := False;\r\n fCanBlink := False;\r\n if DrawState = fdsDisabled then\r\n begin\r\n DrawState := fdsDefault;\r\n DrawState2 := fdsDisabled //DrawState;\r\n end\r\n else\r\n DrawState2 := DrawState;\r\n case FDrawMode of\r\n dmAutoCtrl3D:\r\n if State = fbsPushed then\r\n begin\r\n I := 2;\r\n J := 2;\r\n end;\r\n dmUseImageList:\r\n begin\r\n I := 0;\r\n J := 0;\r\n S := 0;\r\n end;\r\n end;\r\n\r\n case State of\r\n fbsOriginal:\r\n begin\r\n CreateBitmapExt(TargetBMP.Canvas.Handle, FGlyph, ClientRect, S,\r\n S,\r\n fwoNone, DrawState, True, FTransparentColor,\r\n DisabledMaskColor);\r\n Exit;\r\n end;\r\n fbsInactive, fbsDisabled:\r\n begin\r\n if (DrawMode = dmAutoFlat) and (boRaisedInactive in FOptions) then\r\n CreateBitmapExt(TargetBMP.Canvas.Handle, FGlyphActive,\r\n ClientRect, S, S,\r\n fwoNone, DrawState, True, FTransparentColor,\r\n DisabledMaskColor)\r\n else\r\n CreateBitmapExt(TargetBMP.Canvas.Handle, FGlyphInactive,\r\n ClientRect, 0, 0,\r\n fwoNone, DrawState, True, FTransparentColor,\r\n DisabledMaskColor);\r\n\r\n if State = fbsDisabled then\r\n begin\r\n I := 0;\r\n J := 0;\r\n end;\r\n fCanBlink := boBlinkWhenInactive in Options;\r\n end;\r\n fbsActive:\r\n begin\r\n if (FDrawMode = dmAutoCtrl3D) or (DrawMode = dmAutoShadow) then\r\n CreateBitmapExt(TargetBMP.Canvas.Handle, FGlyphInactive,\r\n ClientRect, S, S,\r\n fwoNone, DrawState, True, FTransparentColor,\r\n DisabledMaskColor)\r\n else\r\n CreateBitmapExt(TargetBMP.Canvas.Handle, FGlyphActive,\r\n ClientRect, S, S,\r\n fwoNone, DrawState, True, FTransparentColor,\r\n DisabledMaskColor);\r\n fChangeColor := boChangeColorWhenActive in Options;\r\n fCanBlink := boBlinkWhenActive in Options;\r\n end;\r\n fbsPushed:\r\n begin\r\n CreateBitmapExt(TargetBMP.Canvas.Handle, FGlyphPushed,\r\n ClientRect, S, S,\r\n fwoNone, DrawState, True, FTransparentColor,\r\n DisabledMaskColor);\r\n fChangeColor := boChangeColorWhenPushed in Options;\r\n fCanBlink := boBlinkWhenPushed in Options;\r\n end;\r\n end;\r\n GetBitmap_(FGlyphsIndexes.Inactive, TmpBMP);\r\n fCanBlink := fCanBlink and FNeedBlink;\r\n if fCanBlink then\r\n FBlinked := not FBlinked\r\n else\r\n if State = fbsActive then\r\n FBlinked := FChangeColorOnActivate.FromColor <> FChangeColorOnActivate.ToColor\r\n else\r\n FBlinked := FChangeColorOnPush.FromColor <> FChangeColorOnPush.ToColor;\r\n\r\n if fCanBlink then\r\n begin\r\n if FBlinked then\r\n if State = fbsPushed then\r\n with FChangeColorOnPush do\r\n JvgUtils.ChangeBitmapColor(TmpBMP, FromColor, ToColor)\r\n else\r\n with FChangeColorOnActivate do\r\n JvgUtils.ChangeBitmapColor(TmpBMP, FromColor, ToColor);\r\n end\r\n else\r\n if fChangeColor and (FDrawMode <> dmUseImageList) then\r\n if State = fbsActive then\r\n with FChangeColorOnActivate do\r\n JvgUtils.ChangeBitmapColor(TmpBMP, FromColor, ToColor)\r\n else\r\n with FChangeColorOnPush do\r\n JvgUtils.ChangeBitmapColor(TmpBMP, FromColor, ToColor);\r\n FNeedBlink := False;\r\n if (DrawMode = dmAutoShadow) and (State = fbsPushed) or\r\n (FDrawMode = dmUseImageList) then\r\n Exit;\r\n\r\n if DrawState2 = fdsDisabled then\r\n begin\r\n TmpBMP.Canvas.Brush.Color := FTransparentColor;\r\n TmpBMP.Canvas.Font.Color := clBtnFace;\r\n // SetBkColor(TmpBMP.Canvas.Handle, FTransparentColor);\r\n TmpBMP.Monochrome := True;\r\n TmpBMP.Monochrome := False;\r\n CreateBitmapExt(TargetBMP.Canvas.Handle, TmpBMP, Rect(0, 0,\r\n TmpBMP.Width, TmpBMP.Height),\r\n I + S, J + S, fwoNone, fdsDefault, True, FTransparentColor,\r\n FDisabledMaskColor);\r\n GetBitmap_(FGlyphsIndexes.Inactive, TmpBMP);\r\n end;\r\n\r\n CreateBitmapExt(TargetBMP.Canvas.Handle, TmpBMP, Rect(0, 0, TmpBMP.Width,\r\n TmpBMP.Height),\r\n I + S, J + S, fwoNone, DrawState2, True, FTransparentColor,\r\n FDisabledMaskColor);\r\n end;\r\nend;\r\n\r\nprocedure TJvgButton.MouseMove(Shift: TShiftState; X, Y: Integer);\r\nvar\r\n Pt: TPoint;\r\n MouseInControl: Boolean;\r\nbegin\r\n inherited MouseMove(Shift, X, Y);\r\n Pt.X := X;\r\n Pt.Y := Y;\r\n if PtInRectExclusive(ClientRect, Pt) then\r\n begin\r\n MouseInControl := IsMouseInControl;\r\n if MouseInControl <> FMouseInControl then\r\n begin\r\n if FMouseInControl then\r\n if Assigned(OnMouseEnter) then\r\n OnMouseEnter(Self)\r\n else\r\n if Assigned(OnMouseLeave) then\r\n OnMouseLeave(Self);\r\n FMouseInControl := MouseInControl;\r\n Paint_;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvgButton.MouseLeave(Control: TControl);\r\nbegin\r\n if MouseOver then\r\n begin\r\n inherited MouseLeave(Control);\r\n FMouseInControl := False;\r\n Paint_;\r\n end;\r\nend;\r\n\r\nprocedure TJvgButton.MouseDown(Button: TMouseButton; Shift: TShiftState;\r\n X, Y: Integer);\r\nvar\r\n Pt: TPoint;\r\nbegin\r\n inherited MouseDown(Button, Shift, X, Y);\r\n if (Button <> mbLeft) or (not Enabled) or (not IsMouseInControl) then\r\n Exit;\r\n\r\n if boShiftMouseOnPush in FOptions then\r\n begin\r\n GetCursorPos(Pt);\r\n SetCursorPos(Pt.X + MShift.X, Pt.Y + MShift.Y);\r\n end;\r\n FPushed := True;\r\n Paint_;\r\nend;\r\n\r\nprocedure TJvgButton.MouseUp(Button: TMouseButton; Shift: TShiftState;\r\n X, Y: Integer);\r\nvar\r\n Pt: TPoint;\r\nbegin\r\n inherited MouseUp(Button, Shift, X, Y);\r\n if FShowingAsPushedNow and Assigned(FOnClick) then\r\n FOnClick(Self);\r\n if (boShiftMouseOnPush in FOptions) and IsMouseInControl then\r\n begin\r\n GetCursorPos(Pt);\r\n SetCursorPos(Pt.X - MShift.X, Pt.Y - MShift.Y);\r\n end;\r\n FPushed := False;\r\n Paint_;\r\nend;\r\n\r\nprocedure TJvgButton.GetBitmaps;\r\nbegin\r\n if not FLoaded then\r\n Exit;\r\n with Glyphs do\r\n begin\r\n FGlyphInactive.Width := 0;\r\n FGlyphPushed.Width := 0;\r\n FGlyphActive.Width := 0;\r\n FGlyphDisabled.Width := 0;\r\n FGlyphMask.Width := 0;\r\n if FDrawMode = dmUseImageList then\r\n begin\r\n if not Assigned(FGlyphsList) then\r\n Exit;\r\n with FGlyphsList, FGlyphsIndexes do\r\n begin\r\n if (Inactive < 0) and (Inactive > Count - 1) then\r\n Inactive := 0;\r\n if (Pushed < 0) and (Pushed > Count - 1) then\r\n Pushed := 1;\r\n if Active > Count - 1 then\r\n Active := -1;\r\n if Mask > Count - 1 then\r\n Mask := -1;\r\n\r\n if Inactive <> -1 then\r\n GetBitmap_(Inactive, FGlyphInactive);\r\n if Pushed <> -1 then\r\n GetBitmap_(Pushed, FGlyphPushed);\r\n if Active <> -1 then\r\n GetBitmap_(Active, FGlyphActive); //...optional bitmap\r\n if Disabled <> -1 then\r\n GetBitmap_(Disabled, FGlyphDisabled); //...optional bitmap\r\n if Mask <> -1 then\r\n GetBitmap_(Mask, FGlyphMask); //...optional bitmap\r\n FNumGlyphs := Count;\r\n FBitmapsCreated := not (FGlyphInactive.Empty or FGlyphPushed.Empty);\r\n end;\r\n end\r\n else\r\n CreateBitmaps;\r\n FBitmapsCreated := True;\r\n\r\n case FDrawMode of\r\n dmAutoShadow:\r\n if boDrawPushedAsFlat in FOptions then\r\n begin\r\n MShift.X := 1;\r\n MShift.Y := 1;\r\n end\r\n else\r\n begin\r\n MShift.X := FShadowDepth - 1;\r\n MShift.Y := FShadowDepth - 1;\r\n end;\r\n dmAutoCtrl3D:\r\n begin\r\n MShift.X := 2;\r\n MShift.Y := 2;\r\n end;\r\n dmAutoFlat:\r\n begin\r\n MShift.X := 1;\r\n MShift.Y := 1;\r\n end;\r\n else\r\n begin\r\n MShift.X := FShiftMaskWhenPushed.X;\r\n MShift.Y := FShiftMaskWhenPushed.Y;\r\n end;\r\n end;\r\n\r\n Width := FGlyphInactive.Width;\r\n Height := FGlyphInactive.Height;\r\n end;\r\nend;\r\n\r\nprocedure TJvgButton.CreateBitmaps; //...based on Inactive Glyph\r\nvar\r\n MonoBMP, OldMonoBMP: HBITMAP;\r\n MonoDC: HDC;\r\n I: Word;\r\n\r\n procedure RemakeTmpBMP;\r\n begin\r\n SetBkColor(TmpBMP.Canvas.Handle, ColorToRGB(FTransparentColor));\r\n BitBlt(TmpBMP.Canvas.Handle, 0, 0, TmpBMP.Width, TmpBMP.Height, MonoDC, 0,\r\n 0, SRCCOPY);\r\n end;\r\n\r\nbegin\r\n with FGlyphs, FGlyphsList, FGlyphsIndexes do\r\n begin\r\n FInactive := 0;\r\n FPushed := -1;\r\n FActive := -1;\r\n FDisabled := -1;\r\n FMask := -1;\r\n GetBitmap_(Inactive, TmpBMP);\r\n\r\n MonoDC := CreateCompatibleDC(TmpBMP.Canvas.Handle);\r\n MonoBMP := CreateBitmap(TmpBMP.Width, TmpBMP.Height, 1, 1, nil);\r\n OldMonoBMP := SelectObject(MonoDC, MonoBMP);\r\n // SetMapMode( MonoDC, GetMapMode(TmpBMP.Canvas.Handle) );\r\n SetBkColor(TmpBMP.Canvas.Handle, ColorToRGB(FTransparentColor));\r\n BitBlt(MonoDC, 0, 0, TmpBMP.Width, TmpBMP.Height,\r\n TmpBMP.Canvas.Handle, 0, 0, SRCCOPY);\r\n //SetBkColor(TmpBMP.Canvas.Handle, OldBkColor);\r\n try\r\n if FDrawMode = dmAutoShadow then\r\n begin\r\n with FGlyphInactive do\r\n begin\r\n Width := TmpBMP.Width + FShadowDepth;\r\n Height := TmpBMP.Height + FShadowDepth;\r\n Canvas.Brush.Style := bsSolid;\r\n Canvas.Brush.Color := FTransparentColor;\r\n Canvas.FillRect(Rect(0, 0, Width, Height));\r\n end;\r\n with FGlyphPushed do\r\n begin\r\n Width := TmpBMP.Width + FShadowDepth;\r\n Height := TmpBMP.Height + FShadowDepth;\r\n Canvas.Brush.Style := bsSolid;\r\n Canvas.Brush.Color := FTransparentColor;\r\n Canvas.FillRect(Rect(0, 0, Width, Height));\r\n end;\r\n\r\n BitBlt(FGlyphPushed.Canvas.Handle, FShadowDepth, FShadowDepth,\r\n TmpBMP.Width, TmpBMP.Height, TmpBMP.Canvas.Handle, 0, 0,\r\n SRCCOPY);\r\n\r\n RemakeTmpBMP;\r\n JvgUtils.ChangeBitmapColor(TmpBMP, clBlack, FColorShadow);\r\n CreateBitmapExt(FGlyphInactive.Canvas.Handle, TmpBMP, Rect(0, 0,\r\n TmpBMP.Width, TmpBMP.Height),\r\n FShadowDepth, FShadowDepth, fwoNone, fdsDefault, True,\r\n FTransparentColor, FDisabledMaskColor);\r\n Exit;\r\n end;\r\n\r\n if FDrawMode = dmAutoCtrl3D then\r\n I := 3\r\n else\r\n I := 3;\r\n with FGlyphInactive do\r\n begin\r\n Width := TmpBMP.Width + I;\r\n Height := TmpBMP.Height + I;\r\n Canvas.Brush.Style := bsSolid;\r\n Canvas.Brush.Color := FTransparentColor;\r\n Canvas.FillRect(Rect(0, 0, Width, Height));\r\n end;\r\n if not (boDrawPushedAsFlat in FOptions) then\r\n with FGlyphPushed do\r\n begin\r\n Width := TmpBMP.Width + I;\r\n Height := TmpBMP.Height + I;\r\n Canvas.Brush.Style := bsSolid;\r\n Canvas.Brush.Color := FTransparentColor;\r\n Canvas.FillRect(Rect(0, 0, Width, Height));\r\n end;\r\n with FGlyphActive do\r\n begin\r\n Width := TmpBMP.Width + I;\r\n Height := TmpBMP.Height + I;\r\n Canvas.Brush.Style := bsSolid;\r\n Canvas.Brush.Color := FTransparentColor;\r\n Canvas.FillRect(Rect(0, 0, Width, Height));\r\n end;\r\n\r\n if FDrawMode = dmAutoCtrl3D then //...add 3d border to inactive\r\n begin\r\n RemakeTmpBMP;\r\n if clBlack <> FColorDarkShadow then\r\n JvgUtils.ChangeBitmapColor(TmpBMP, clBlack, FColorDarkShadow);\r\n if boShadowSurround in FOptions then\r\n begin\r\n CreateBitmapExt(FGlyphInactive.Canvas.Handle, TmpBMP, Rect(0, 0,\r\n TmpBMP.Width, TmpBMP.Height),\r\n 0, 3, fwoNone, fdsDefault, True, FTransparentColor,\r\n FDisabledMaskColor);\r\n CreateBitmapExt(FGlyphInactive.Canvas.Handle, TmpBMP, Rect(0, 0,\r\n TmpBMP.Width, TmpBMP.Height),\r\n 3, 0, fwoNone, fdsDefault, True, FTransparentColor,\r\n FDisabledMaskColor);\r\n end;\r\n CreateBitmapExt(FGlyphInactive.Canvas.Handle, TmpBMP, Rect(0, 0,\r\n TmpBMP.Width, TmpBMP.Height),\r\n 3, 3, fwoNone, fdsDefault, True, FTransparentColor,\r\n FDisabledMaskColor);\r\n\r\n RemakeTmpBMP;\r\n JvgUtils.ChangeBitmapColor(TmpBMP, clBlack, FColorHighlight);\r\n CreateBitmapExt(FGlyphInactive.Canvas.Handle, TmpBMP, Rect(0, 0,\r\n TmpBMP.Width, TmpBMP.Height),\r\n 0, 0, fwoNone, fdsDefault, True, FTransparentColor,\r\n FDisabledMaskColor);\r\n if boShadowSurround in FOptions then\r\n begin\r\n CreateBitmapExt(FGlyphInactive.Canvas.Handle, TmpBMP, Rect(0, 0,\r\n TmpBMP.Width, TmpBMP.Height),\r\n 2, 0, fwoNone, fdsDefault, True, FTransparentColor,\r\n FDisabledMaskColor);\r\n CreateBitmapExt(FGlyphInactive.Canvas.Handle, TmpBMP, Rect(0, 0,\r\n TmpBMP.Width, TmpBMP.Height),\r\n 0, 2, fwoNone, fdsDefault, True, FTransparentColor,\r\n FDisabledMaskColor);\r\n end;\r\n RemakeTmpBMP;\r\n JvgUtils.ChangeBitmapColor(TmpBMP, clBlack, FColorShadow);\r\n if boShadowSurround in FOptions then\r\n begin\r\n CreateBitmapExt(FGlyphInactive.Canvas.Handle, TmpBMP, Rect(0, 0,\r\n TmpBMP.Width, TmpBMP.Height),\r\n 1, 2, fwoNone, fdsDefault, True, FTransparentColor,\r\n FDisabledMaskColor);\r\n CreateBitmapExt(FGlyphInactive.Canvas.Handle, TmpBMP, Rect(0, 0,\r\n TmpBMP.Width, TmpBMP.Height),\r\n 2, 1, fwoNone, fdsDefault, True, FTransparentColor,\r\n FDisabledMaskColor);\r\n end;\r\n CreateBitmapExt(FGlyphInactive.Canvas.Handle, TmpBMP, Rect(0, 0,\r\n TmpBMP.Width, TmpBMP.Height),\r\n 2, 2, fwoNone, fdsDefault, True, FTransparentColor,\r\n FDisabledMaskColor);\r\n if boDrawPushedAsFlat in FOptions then\r\n Exit;\r\n RemakeTmpBMP;\r\n JvgUtils.ChangeBitmapColor(TmpBMP, clBlack, FColorHighlight);\r\n if boShadowSurround in FOptions then\r\n begin\r\n CreateBitmapExt(FGlyphPushed.Canvas.Handle, TmpBMP, Rect(0, 0,\r\n TmpBMP.Width, TmpBMP.Height),\r\n 0, 3, fwoNone, fdsDefault, True, FTransparentColor,\r\n FDisabledMaskColor);\r\n CreateBitmapExt(FGlyphPushed.Canvas.Handle, TmpBMP, Rect(0, 0,\r\n TmpBMP.Width, TmpBMP.Height),\r\n 3, 0, fwoNone, fdsDefault, True, FTransparentColor,\r\n FDisabledMaskColor);\r\n end;\r\n CreateBitmapExt(FGlyphPushed.Canvas.Handle, TmpBMP, Rect(0, 0,\r\n TmpBMP.Width, TmpBMP.Height),\r\n 3, 3, fwoNone, fdsDefault, True, FTransparentColor,\r\n FDisabledMaskColor);\r\n\r\n RemakeTmpBMP;\r\n if clBlack <> FColorDarkShadow then\r\n JvgUtils.ChangeBitmapColor(TmpBMP, clBlack, FColorDarkShadow);\r\n\r\n CreateBitmapExt(FGlyphPushed.Canvas.Handle, TmpBMP, Rect(0, 0,\r\n TmpBMP.Width, TmpBMP.Height),\r\n 0, 0, fwoNone, fdsDefault, True, FTransparentColor,\r\n FDisabledMaskColor);\r\n if boShadowSurround in FOptions then\r\n begin\r\n CreateBitmapExt(FGlyphPushed.Canvas.Handle, TmpBMP, Rect(0, 0,\r\n TmpBMP.Width, TmpBMP.Height),\r\n 2, 0, fwoNone, fdsDefault, True, FTransparentColor,\r\n FDisabledMaskColor);\r\n CreateBitmapExt(FGlyphPushed.Canvas.Handle, TmpBMP, Rect(0, 0,\r\n TmpBMP.Width, TmpBMP.Height),\r\n 0, 2, fwoNone, fdsDefault, True, FTransparentColor,\r\n FDisabledMaskColor);\r\n end;\r\n RemakeTmpBMP;\r\n JvgUtils.ChangeBitmapColor(TmpBMP, clBlack, FColorShadow);\r\n if boShadowSurround in FOptions then\r\n begin\r\n CreateBitmapExt(FGlyphPushed.Canvas.Handle, TmpBMP, Rect(0, 0,\r\n TmpBMP.Width, TmpBMP.Height),\r\n 1, 2, fwoNone, fdsDefault, True, FTransparentColor,\r\n FDisabledMaskColor);\r\n CreateBitmapExt(FGlyphPushed.Canvas.Handle, TmpBMP, Rect(0, 0,\r\n TmpBMP.Width, TmpBMP.Height),\r\n 2, 1, fwoNone, fdsDefault, True, FTransparentColor,\r\n FDisabledMaskColor);\r\n end;\r\n CreateBitmapExt(FGlyphPushed.Canvas.Handle, TmpBMP, Rect(0, 0,\r\n TmpBMP.Width, TmpBMP.Height),\r\n 1, 1, fwoNone, fdsDefault, True, FTransparentColor,\r\n FDisabledMaskColor);\r\n RemakeTmpBMP;\r\n Exit;\r\n end;\r\n\r\n if FDrawMode = dmAutoFlat then\r\n begin\r\n CreateBitmapExt(FGlyphInactive.Canvas.Handle, TmpBMP, Rect(0, 0,\r\n TmpBMP.Width, TmpBMP.Height),\r\n 0, 0, fwoNone, fdsDefault, True, FTransparentColor,\r\n FDisabledMaskColor);\r\n RemakeTmpBMP;\r\n JvgUtils.ChangeBitmapColor(TmpBMP, clBlack, FColorShadow);\r\n if boShadowSurround in FOptions then\r\n begin\r\n CreateBitmapExt(FGlyphActive.Canvas.Handle, TmpBMP, Rect(0, 0,\r\n TmpBMP.Width, TmpBMP.Height),\r\n 0, 2, fwoNone, fdsDefault, True, FTransparentColor,\r\n FDisabledMaskColor);\r\n CreateBitmapExt(FGlyphActive.Canvas.Handle, TmpBMP, Rect(0, 0,\r\n TmpBMP.Width, TmpBMP.Height),\r\n 2, 0, fwoNone, fdsDefault, True, FTransparentColor,\r\n FDisabledMaskColor);\r\n end;\r\n CreateBitmapExt(FGlyphActive.Canvas.Handle, TmpBMP, Rect(0, 0,\r\n TmpBMP.Width, TmpBMP.Height),\r\n 2, 2, fwoNone, fdsDefault, True, FTransparentColor,\r\n FDisabledMaskColor);\r\n RemakeTmpBMP;\r\n JvgUtils.ChangeBitmapColor(TmpBMP, clBlack, FColorHighlight);\r\n CreateBitmapExt(FGlyphActive.Canvas.Handle, TmpBMP, Rect(0, 0,\r\n TmpBMP.Width, TmpBMP.Height),\r\n 0, 0, fwoNone, fdsDefault, True, FTransparentColor,\r\n FDisabledMaskColor);\r\n if boShadowSurround in FOptions then\r\n begin\r\n CreateBitmapExt(FGlyphActive.Canvas.Handle, TmpBMP, Rect(0, 0,\r\n TmpBMP.Width, TmpBMP.Height),\r\n 1, 0, fwoNone, fdsDefault, True, FTransparentColor,\r\n FDisabledMaskColor);\r\n CreateBitmapExt(FGlyphActive.Canvas.Handle, TmpBMP, Rect(0, 0,\r\n TmpBMP.Width, TmpBMP.Height),\r\n 0, 1, fwoNone, fdsDefault, True, FTransparentColor,\r\n FDisabledMaskColor);\r\n end;\r\n RemakeTmpBMP;\r\n end;\r\n if boDrawPushedAsFlat in FOptions then\r\n Exit;\r\n RemakeTmpBMP;\r\n JvgUtils.ChangeBitmapColor(TmpBMP, clBlack, FColorHighlight);\r\n if boShadowSurround in FOptions then\r\n begin\r\n CreateBitmapExt(FGlyphPushed.Canvas.Handle, TmpBMP, Rect(0, 0,\r\n TmpBMP.Width, TmpBMP.Height),\r\n 0, 2, fwoNone, fdsDefault, True, FTransparentColor,\r\n FDisabledMaskColor);\r\n CreateBitmapExt(FGlyphPushed.Canvas.Handle, TmpBMP, Rect(0, 0,\r\n TmpBMP.Width, TmpBMP.Height),\r\n 2, 0, fwoNone, fdsDefault, True, FTransparentColor,\r\n FDisabledMaskColor);\r\n end;\r\n CreateBitmapExt(FGlyphPushed.Canvas.Handle, TmpBMP, Rect(0, 0,\r\n TmpBMP.Width, TmpBMP.Height),\r\n 2, 2, fwoNone, fdsDefault, True, FTransparentColor,\r\n FDisabledMaskColor);\r\n RemakeTmpBMP;\r\n if clBlack <> FColorShadow then\r\n JvgUtils.ChangeBitmapColor(TmpBMP, clBlack, FColorShadow);\r\n\r\n CreateBitmapExt(FGlyphPushed.Canvas.Handle, TmpBMP, Rect(0, 0,\r\n TmpBMP.Width, TmpBMP.Height),\r\n 0, 0, fwoNone, fdsDefault, True, FTransparentColor,\r\n FDisabledMaskColor);\r\n if boShadowSurround in FOptions then\r\n begin\r\n CreateBitmapExt(FGlyphPushed.Canvas.Handle, TmpBMP, Rect(0, 0,\r\n TmpBMP.Width, TmpBMP.Height),\r\n 1, 0, fwoNone, fdsDefault, True, FTransparentColor,\r\n FDisabledMaskColor);\r\n CreateBitmapExt(FGlyphPushed.Canvas.Handle, TmpBMP, Rect(0, 0,\r\n TmpBMP.Width, TmpBMP.Height),\r\n 0, 1, fwoNone, fdsDefault, True, FTransparentColor,\r\n FDisabledMaskColor);\r\n end;\r\n RemakeTmpBMP;\r\n finally\r\n DeleteObject(SelectObject(MonoDC, OldMonoBMP));\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TJvgButton.IsMouseInControl: Boolean;\r\nvar\r\n Pt: TPoint;\r\n PixelColor: TColorRef;\r\nbegin\r\n GetCursorPos(Pt);\r\n Pt := ScreenToClient(Pt);\r\n if FShowingAsPushedNow and FPushed then\r\n begin\r\n Dec(Pt.X, FShiftMaskWhenPushed.X);\r\n Dec(Pt.Y, FShiftMaskWhenPushed.Y);\r\n end\r\n else\r\n if FDrawMode = dmAutoShadow then\r\n begin\r\n Inc(Pt.X, FShadowDepth);\r\n Inc(Pt.Y, FShadowDepth);\r\n end;\r\n\r\n Dec(Pt.X);\r\n Dec(Pt.Y);\r\n\r\n if FGlyphsIndexes.Mask = -1 then //...__mask is absent_\r\n begin\r\n with FGlyphs do\r\n case FDrawMode of\r\n dmAutoShadow:\r\n PixelColor := GetPixel(FGlyphPushed.Canvas.Handle, Pt.X, Pt.Y);\r\n dmAutoFlat:\r\n PixelColor := GetPixel(FGlyphActive.Canvas.Handle, Pt.X, Pt.Y);\r\n else\r\n PixelColor := GetPixel(FGlyphInactive.Canvas.Handle, Pt.X, Pt.Y);\r\n end;\r\n Result := (PixelColor <> TColorRef(FTransparentColor)) and (PixelColor <> DWORD(-1));\r\n end\r\n else //...__use mask_\r\n begin\r\n with FGlyphs do\r\n PixelColor := GetPixel(FGlyphMask.Canvas.Handle, Pt.X, Pt.Y);\r\n Result := (PixelColor = TColorRef(clWhite)) and (PixelColor <> DWORD(-1));\r\n end;\r\nend;\r\n\r\nprocedure TJvgButton.SmthChanged(Sender: TObject);\r\nbegin\r\n GetBitmaps;\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvgButton.GetBitmap_(Index: Integer; var Bmp: TBitmap);\r\nbegin\r\n try\r\n if FDrawMode = dmUseImageList then\r\n FGlyphsList.GetBitmap(Index, Bmp)\r\n else\r\n begin\r\n if Assigned(Bmp) then\r\n begin\r\n Bmp.Free;\r\n Bmp := TBitmap.Create;\r\n end;\r\n Bmp.Assign(Glyph);\r\n end;\r\n except\r\n MessageDlg(RsEErrorDuringAccessGlyphsListOrGlyphP, mtError, [mbOk], 0);\r\n raise;\r\n end;\r\nend;\r\n\r\nprocedure TJvgButton.OnBlinkTimer(Sender: TObject);\r\nvar\r\n ParentForm: TForm;\r\n I: Integer;\r\n\r\n procedure Blink(FreeButton: TJvgButton);\r\n begin\r\n with FreeButton do\r\n begin\r\n FNeedBlink := False;\r\n if FShowingAsPushedNow then\r\n with FChangeColorOnPush do\r\n if (boBlinkWhenPushed in Options) and (FromColor <> ToColor) then\r\n begin\r\n FNeedBlink := True;\r\n Repaint;\r\n Exit;\r\n end\r\n else\r\n Exit;\r\n if FMouseInControl then\r\n with FChangeColorOnActivate do\r\n if (boBlinkWhenActive in Options) and (FromColor <> ToColor) then\r\n begin\r\n FNeedBlink := True;\r\n Repaint;\r\n Exit;\r\n end\r\n else\r\n Exit;\r\n if not FMouseInControl then\r\n with FChangeColorOnActivate do\r\n if (boBlinkWhenInactive in Options) and (FromColor <> ToColor) then\r\n begin\r\n FNeedBlink := True;\r\n Repaint;\r\n Exit;\r\n end\r\n else\r\n Exit;\r\n end;\r\n end;\r\n\r\nbegin\r\n if (not TestMode) and (csDesigning in ComponentState) then\r\n Exit;\r\n ParentForm := GetParentForm(Self);\r\n for I := 0 to ParentForm.ComponentCount - 1 do\r\n if (ParentForm.Components[I] is TJvgButton) and\r\n (TJvgButton(ParentForm.Components[I]).BlinkTimer = FBlinkTimer) then\r\n with ParentForm.Components[I] as TJvgButton do\r\n Blink(TJvgButton(ParentForm.Components[I]));\r\nend;\r\n\r\nprocedure TJvgButton.SetDrawMode(Value: TDrawMode);\r\nbegin\r\n if FDrawMode <> Value then\r\n begin\r\n FDrawMode := Value;\r\n GetBitmaps;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvgButton.SetGlyphsList(Value: TImageList);\r\nbegin\r\n if Assigned(Value) then\r\n begin\r\n FGlyphsList := Value;\r\n GetBitmaps;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvgButton.SetGlyph(Value: TBitmap);\r\nbegin\r\n if Assigned(FGlyph) then\r\n begin\r\n FGlyph.Free;\r\n FGlyph := TBitmap.Create;\r\n end;\r\n FGlyph.Assign(Value);\r\n GetBitmaps;\r\n Invalidate;\r\n AutoTransparentColor := AutoTransparentColor;\r\nend;\r\n\r\nprocedure TJvgButton.SetNumGlyphs(Value: Integer);\r\nbegin\r\n if (Value >= 2) or (Value <= 4) then\r\n FNumGlyphs := Value;\r\nend;\r\n\r\nprocedure TJvgButton.SetTransparentColor(Value: TColor);\r\nbegin\r\n if (FAutoTrColor <> ftcUser) or (FTransparentColor = Value) then\r\n Exit;\r\n FTransparentColor := Value;\r\n GetBitmaps;\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvgButton.SetEnabled(Value: Boolean);\r\nbegin\r\n if FEnabled <> Value then\r\n begin\r\n FEnabled := Value;\r\n Repaint;\r\n end;\r\nend;\r\n\r\nprocedure TJvgButton.SetShadowDepth(Value: Word);\r\nbegin\r\n if FShadowDepth <> Value then\r\n begin\r\n FShadowDepth := Value;\r\n if FDrawMode = dmAutoShadow then\r\n begin\r\n GetBitmaps;\r\n Invalidate;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvgButton.SetColorHighlight(Value: TColor);\r\nbegin\r\n if FColorHighlight <> Value then\r\n begin\r\n FColorHighlight := Value;\r\n if FDrawMode <> dmUseImageList then\r\n begin\r\n GetBitmaps;\r\n Invalidate;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvgButton.SetColorShadow(Value: TColor);\r\nbegin\r\n if FColorShadow <> Value then\r\n begin\r\n FColorShadow := Value;\r\n if FDrawMode <> dmUseImageList then\r\n begin\r\n GetBitmaps;\r\n Invalidate;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvgButton.SetColorDarkShadow(Value: TColor);\r\nbegin\r\n if FColorDarkShadow <> Value then\r\n begin\r\n FColorDarkShadow := Value;\r\n if FDrawMode <> dmUseImageList then\r\n begin\r\n GetBitmaps;\r\n Invalidate;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvgButton.SetDisabledMaskColor(Value: TColor);\r\nbegin\r\n if FDisabledMaskColor <> Value then\r\n begin\r\n FDisabledMaskColor := Value;\r\n if FDrawMode <> dmUseImageList then\r\n begin\r\n GetBitmaps;\r\n Invalidate;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvgButton.SetOptions(Value: TglButtonOptions);\r\nbegin\r\n if FOptions <> Value then\r\n begin\r\n FOptions := Value;\r\n if FDrawMode <> dmUseImageList then\r\n begin\r\n GetBitmaps;\r\n Invalidate;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvgButton.SetAutoTrColor(Value: TglAutoTransparentColor);\r\nvar\r\n X, Y: Integer;\r\n TmpBmp_: TBitmap;\r\nbegin\r\n FAutoTrColor := Value;\r\n TmpBmp_ := nil;\r\n if {(FAutoTrColor=ftcUser)or}(FGlyph.Width = 0) or (FGlyph.Height = 0) then\r\n Exit;\r\n try\r\n with FGlyph do\r\n case FAutoTrColor of\r\n ftcLeftTopPixel:\r\n begin\r\n X := 0;\r\n Y := 0;\r\n end;\r\n ftcLeftBottomPixel:\r\n begin\r\n X := 0;\r\n Y := Height - 1;\r\n end;\r\n ftcRightTopPixel:\r\n begin\r\n X := Width - 1;\r\n Y := 0;\r\n end;\r\n ftcRightBottomPixel:\r\n begin\r\n X := Width - 1;\r\n Y := Height - 1;\r\n end;\r\n else\r\n Exit;\r\n end;\r\n TmpBmp_ := TBitmap.Create;\r\n TmpBmp_.Assign(FGlyph);\r\n FTransparentColor := GetPixel(TmpBmp_.Canvas.Handle, X, Y);\r\n finally\r\n TmpBmp_.Free;\r\n GetBitmaps;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvgButton.SetBlinkTimer(Value: TTimer);\r\nvar\r\n ParentForm: TForm;\r\n I: Integer;\r\n p1, p2: TNotifyEvent;\r\n Timer: TTimer;\r\nbegin\r\n if FBlinkTimer = Value then\r\n Exit;\r\n if Assigned(FBlinkTimer) then\r\n begin\r\n p1 := FBlinkTimer.OnTimer;\r\n p2 := OnBlinkTimer;\r\n if @FBlinkTimer.OnTimer = @p2 then //...points at me\r\n begin\r\n ParentForm := GetParentForm(Self);\r\n for I := 0 to ParentForm.ComponentCount - 1 do\r\n if (ParentForm.Components[I] is TJvgButton) and\r\n (TJvgButton(ParentForm.Components[I]) <> Self) and\r\n (TJvgButton(ParentForm.Components[I]).BlinkTimer = FBlinkTimer) then\r\n begin\r\n Timer := FBlinkTimer;\r\n FBlinkTimer := nil;\r\n Timer.OnTimer := TJvgButton(ParentForm.Components[I]).OnBlinkTimer;\r\n Break;\r\n end;\r\n if Assigned(FBlinkTimer) and (@FBlinkTimer.OnTimer = @p2) then\r\n FBlinkTimer.OnTimer := nil;\r\n end;\r\n end\r\n else\r\n FBlinkTimer := nil;\r\n\r\n FBlinkTimer := Value;\r\n if Assigned(FBlinkTimer) then\r\n FBlinkTimer.OnTimer := OnBlinkTimer;\r\nend;\r\n\r\nfunction TJvgButton.GetBlinkTimer: TTimer;\r\nbegin\r\n Result := nil;\r\n try\r\n if Assigned(FBlinkTimer) then\r\n if Owner.Components[FBlinkTimer.ComponentIndex] = FBlinkTimer then\r\n Result := FBlinkTimer;\r\n except\r\n end;\r\nend;\r\n\r\nprocedure TJvgButton.SetTestMode(Value: Boolean);\r\nvar\r\n ParentForm: TForm;\r\n I: Integer;\r\nbegin\r\n ParentForm := GetParentForm(Self);\r\n for I := 0 to ParentForm.ComponentCount - 1 do\r\n if (ParentForm.Components[I] is TJvgButton) then\r\n TJvgButton(ParentForm.Components[I]).FTestMode := Value;\r\nend;\r\n\r\n//=== { TJvgGlyphsIndexes } ==================================================\r\n\r\nconstructor TJvgGlyphsIndexes.Create;\r\nbegin\r\n inherited Create;\r\n FInactive := 0;\r\n FPushed := 1;\r\n FActive := 2;\r\n FDisabled := -1;\r\n FMask := 3;\r\nend;\r\n\r\nprocedure TJvgGlyphsIndexes.DoChanged;\r\nbegin\r\n if Assigned(FOnChanged) then\r\n FOnChanged(Self);\r\nend;\r\n\r\nprocedure TJvgGlyphsIndexes.SetInactive(Value: Integer);\r\nbegin\r\n FInactive := Value;\r\n DoChanged;\r\nend;\r\n\r\nprocedure TJvgGlyphsIndexes.SetPushed(Value: Integer);\r\nbegin\r\n FPushed := Value;\r\n DoChanged;\r\nend;\r\n\r\nprocedure TJvgGlyphsIndexes.SetActive(Value: Integer);\r\nbegin\r\n FActive := Value;\r\n DoChanged;\r\nend;\r\n\r\nprocedure TJvgGlyphsIndexes.SetDisabled(Value: Integer);\r\nbegin\r\n FDisabled := Value;\r\n DoChanged;\r\nend;\r\n\r\nprocedure TJvgGlyphsIndexes.SetMask(Value: Integer);\r\nbegin\r\n FMask := Value;\r\n DoChanged;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvgCaption.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvgCaption.PAS, released on 2003-01-15.\r\n\r\nThe Initial Developer of the Original Code is Andrey V. Chudin, [chudin att yandex dott ru]\r\nPortions created by Andrey V. Chudin are Copyright (C) 2003 Andrey V. Chudin.\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\nMichael Beck [mbeck att bigfoot dott com].\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvgCaption.pas 13173 2011-11-19 12:43:58Z ahuser $\r\n\r\nunit JvgCaption;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,\r\n StdCtrls, ExtCtrls,\r\n JvComponentBase, JvJVCLUtils,\r\n JvgTypes, JvgUtils, JvgCommClasses;\r\n\r\ntype\r\n TJvgCaption = class(TJvComponent)\r\n private\r\n FExcludeButtons: Boolean;\r\n FExcludeIcon: Boolean;\r\n FCaptBox: TJvgBevelOptions;\r\n FTextBox: TJvgBevelOptions;\r\n FIconBox: TJvgBevelOptions;\r\n FPrevWndProc: Pointer;\r\n FNewWndProc: Pointer;\r\n // FParent: TForm;\r\n FCaptionColor: TColor;\r\n FTextStyle: TglTextStyle;\r\n FFont: TFont;\r\n FTexture: TBitmap;\r\n FBmp: TBitmap;\r\n FImage: TImage;\r\n FTextureTransparent: Boolean;\r\n FAutoTransparentColor: TglAutoTransparentColor;\r\n FTransparentColor: TColor;\r\n\r\n FGlyphClose: TBitmap;\r\n FOwnerWidth: Integer;\r\n FBtnCount: Integer;\r\n {$IFDEF GL_CAPT_BUTTONS}\r\n FCloseRect: TRect;\r\n {$ENDIF GL_CAPT_BUTTONS}\r\n FCYCaption: Integer;\r\n FCXFrame: Integer;\r\n FCYFrame: Integer;\r\n FCXSMIcon: Integer;\r\n FCYSMIcon: Integer;\r\n FCXIcon: Integer;\r\n FCYIcon: Integer;\r\n procedure SetExcludeIcon(Value: Boolean);\r\n procedure SetExcludeButtons(Value: Boolean);\r\n procedure SetCaptionColor(Value: TColor);\r\n procedure SetTextStyle(Value: TglTextStyle);\r\n procedure SetFont(Value: TFont);\r\n procedure SetTexture(Value: TBitmap);\r\n procedure SetImage(Value: TImage);\r\n function GetTexture: TBitmap;\r\n procedure SetTextureTransparent(Value: Boolean);\r\n procedure SetAutoTransparentColor(Value: TglAutoTransparentColor);\r\n procedure SetTransparentColor(Value: TColor);\r\n procedure Repaint;\r\n procedure DrawIcon(DC: HDC; R: TRect);\r\n function DrawCaption(DrawAll: Boolean): TRect;\r\n procedure ParentWindowHookProc(var Msg: TMessage);\r\n procedure SetParentWindowHook;\r\n procedure FreeParentWindowHook;\r\n function CountCaptionButtons: Integer;\r\n procedure SmthChanged(Sender: TObject);\r\n protected\r\n // procedure WndProc(var Message: TMessage);override;\r\n procedure Loaded; override;\r\n procedure Notification(Component: TComponent; Operation: TOperation); override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n published\r\n // property Parent: TForm read FParent write SetParent;\r\n property ExcludeButtons: Boolean\r\n read FExcludeButtons write SetExcludeButtons default True;\r\n property ExcludeIcon: Boolean\r\n read FExcludeIcon write SetExcludeIcon default False;\r\n property CaptionColor: TColor\r\n read FCaptionColor write SetCaptionColor default clBtnFace;\r\n property TextStyle: TglTextStyle\r\n read FTextStyle write SetTextStyle default fstRaised;\r\n property Font: TFont read FFont write SetFont;\r\n property CaptBox: TJvgBevelOptions read FCaptBox write FCaptBox;\r\n property TextBox: TJvgBevelOptions read FTextBox write FTextBox;\r\n property IconBox: TJvgBevelOptions read FIconBox write FIconBox;\r\n property Texture: TBitmap read GetTexture write SetTexture;\r\n property Image: TImage read FImage write SetImage;\r\n property TextureTransparent: Boolean\r\n read FTextureTransparent write SetTextureTransparent default False;\r\n property AutoTransparentColor: TglAutoTransparentColor\r\n read FAutoTransparentColor write SetAutoTransparentColor default ftcLeftBottomPixel;\r\n property TransparentColor: TColor\r\n read FTransparentColor write SetTransparentColor default clBlack;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvgCaption.pas $';\r\n Revision: '$Revision: 13173 $';\r\n Date: '$Date: 2011-11-19 13:43:58 +0100 (sam. 19 nov. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n Math,\r\n {$IFNDEF COMPILER12_UP}\r\n JvJCLUtils, // SetWindowLongPtr\r\n {$ENDIF ~COMPILER12_UP}\r\n JvResources;\r\n\r\n{$R JvgCaption.res}\r\n\r\nconstructor TJvgCaption.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FCaptBox := TJvgBevelOptions.Create;\r\n FTextBox := TJvgBevelOptions.Create;\r\n FIconBox := TJvgBevelOptions.Create;\r\n FFont := TFont.Create;\r\n FExcludeButtons := True;\r\n FExcludeIcon := False;\r\n FCaptionColor := clBtnFace;\r\n FTextStyle := fstRaised;\r\n FTextBox.Inner := bvRaised;\r\n FIconBox.Inner := bvNone;\r\n FIconBox.Outer := bvNone;\r\n FTextureTransparent := False;\r\n FAutoTransparentColor := ftcLeftBottomPixel;\r\n FCaptBox.OnChanged := SmthChanged;\r\n FTextBox.OnChanged := SmthChanged;\r\n FIconBox.OnChanged := SmthChanged;\r\n\r\n // FParent := nil;\r\n if not (AOwner is TForm) then\r\n Exit; //FParent:=TForm(AOwner) else Exit;\r\n\r\n //if (csDesigning in ComponentState)and not (csLoading in ComponentState) then\r\n begin\r\n FGlyphClose := TBitmap.Create;\r\n FGlyphClose.LoadFromResourceName(HInstance, 'JvgCaptionCLOSE');\r\n end;\r\n\r\n FCYCaption := GetSystemMetrics(SM_CYCAPTION);\r\n FCYFrame := GetSystemMetrics(SM_CYFRAME);\r\n FCXFrame := GetSystemMetrics(SM_CXFRAME);\r\n FCXSMIcon := GetSystemMetrics(SM_CXSMICON);\r\n FCYSMIcon := GetSystemMetrics(SM_CYSMICON);\r\n FCXIcon := GetSystemMetrics(SM_CXICON);\r\n FCYIcon := GetSystemMetrics(SM_CYICON);\r\n\r\n SetParentWindowHook;\r\nend;\r\n\r\ndestructor TJvgCaption.Destroy;\r\nbegin\r\n FFont.Free;\r\n FCaptBox.Free;\r\n FTextBox.Free;\r\n FIconBox.Free;\r\n FTexture.Free;\r\n FGlyphClose.Free;\r\n FreeParentWindowHook;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvgCaption.Loaded;\r\nbegin\r\n inherited Loaded;\r\n if Assigned(FTexture) and not FTexture.Empty then\r\n FBmp := FTexture;\r\nend;\r\n\r\nprocedure TJvgCaption.Notification(Component: TComponent;\r\n Operation: TOperation);\r\nbegin\r\n inherited Notification(Component, Operation);\r\n if (Component <> Self) and (Operation = opInsert) and (Component is TJvgCaption) then\r\n raise Exception.CreateRes(@RsEOnlyOneInstanceOfTJvgCaption);\r\nend;\r\n\r\nprocedure TJvgCaption.SetParentWindowHook;\r\nvar\r\n P: Pointer;\r\nbegin\r\n P := Pointer(GetWindowLongPtr(TForm(Owner).Handle, GWL_WNDPROC));\r\n if P <> FNewWndProc then\r\n begin\r\n FPrevWndProc := P;\r\n FNewWndProc := JvMakeObjectInstance(ParentWindowHookProc);\r\n SetWindowLongPtr(TForm(Owner).Handle, GWL_WNDPROC, LONG_PTR(FNewWndProc));\r\n end;\r\nend;\r\n\r\nprocedure TJvgCaption.FreeParentWindowHook;\r\nbegin\r\n if (FNewWndProc <> nil) and (FPrevWndProc <> nil) and\r\n (Pointer(GetWindowLongPtr(TForm(Owner).Handle, GWL_WNDPROC)) = FNewWndProc) then\r\n begin\r\n //Repaint;\r\n SetWindowLongPtr(TForm(Owner).Handle, GWL_WNDPROC, LONG_PTR(FPrevWndProc));\r\n // (rom) JvFreeObjectInstance call added\r\n JvFreeObjectInstance(FNewWndProc);\r\n FNewWndProc := nil;\r\n end;\r\nend;\r\n\r\nprocedure TJvgCaption.ParentWindowHookProc(var Msg: TMessage);\r\n\r\n procedure DefaultProc;\r\n begin\r\n Msg.Result := CallWindowProc(FPrevWndProc, TForm(Owner).Handle, Msg.Msg,\r\n Msg.WParam, Msg.LParam);\r\n end;\r\n\r\n{$IFDEF GL_CAPT_BUTTONS}\r\nvar\r\n Pt: TPoint;\r\n{$ENDIF GL_CAPT_BUTTONS}\r\nbegin\r\n FOwnerWidth := TForm(Owner).Width;\r\n case Msg.Msg of\r\n // WM_CREATE: if TForm(Owner)<>nil then FreeParentWindowHook;\r\n WM_NCPAINT, // WM_MOUSEMOVE,\r\n WM_MOUSEACTIVATE, WM_NCACTIVATE, WM_SYSCOLORCHANGE, // WM_NCLBUTTONUP,\r\n WM_NCLBUTTONDBLCLK, WM_SIZE:\r\n begin\r\n DefaultProc;\r\n DrawCaption(True);\r\n end;\r\n WM_NCLBUTTONDOWN:\r\n begin\r\n DefaultProc;\r\n DrawCaption(False);\r\n end;\r\n WM_LBUTTONUP:\r\n begin\r\n DefaultProc;\r\n {$IFDEF GL_CAPT_BUTTONS}\r\n GetCursorPos(Pt);\r\n Dec(Pt.X, TForm(Owner).Left);\r\n Dec(Pt.Y, TForm(Owner).Top);\r\n if PtInRect(FCloseRect, Pt) then\r\n SendMessage(TForm(Owner).Handle, WM_CLOSE, 0, 0);\r\n {$ENDIF GL_CAPT_BUTTONS}\r\n end;\r\n WM_NCHITTEST:\r\n begin\r\n {$IFDEF GL_CAPT_BUTTONS}\r\n Pt := {TForm(Owner).ScreenToClient}(Point(LoWord(Msg.LParam) -\r\n TForm(Owner).Left, HiWord(Msg.LParam) - TForm(Owner).Top));\r\n if PtInRect(FCloseRect, Pt) then\r\n begin\r\n Msg.Result := HTCLIENT;\r\n Exit;\r\n end;\r\n {$ENDIF GL_CAPT_BUTTONS}\r\n DefaultProc;\r\n if (Msg.Result = HTLEFT) or (Msg.Result = HTRIGHT) or (Msg.Result = HTTOP) or\r\n (Msg.Result = HTBOTTOM) or (Msg.Result = HTBOTTOMLEFT) or\r\n (Msg.Result = HTBOTTOMRIGHT) or (Msg.Result = HTTOPLEFT) or\r\n (Msg.Result = HTTOPRIGHT) then\r\n DrawCaption(False);\r\n end;\r\n // WM_SETTEXT: DrawCaption( False );\r\n // WM_ACTIVATE: DrawCaption;\r\n WM_DESTROY:\r\n begin\r\n FreeParentWindowHook;\r\n DefaultProc;\r\n end;\r\n else\r\n DefaultProc;\r\n end;\r\nend;\r\n\r\nprocedure TJvgCaption.DrawIcon(DC: HDC; R: TRect);\r\nvar\r\n IconHandle: HICON;\r\n IconDC: HDC;\r\n OldIconBMP, IconBMP: HBITMAP;\r\n Brush, OldBrush: HBRUSH;\r\nbegin\r\n\r\n with TForm(Owner) do\r\n if Icon.Handle <> 0 then\r\n IconHandle := Icon.Handle\r\n else\r\n if Application.Icon.Handle <> 0 then\r\n IconHandle := Application.Icon.Handle\r\n else\r\n IconHandle := LoadIcon(0, IDI_APPLICATION);\r\n\r\n IconDC := CreateCompatibleDC(DC);\r\n IconBMP := CreateCompatibleBitmap(DC, FCXIcon, FCYIcon);\r\n OldIconBMP := SelectObject(IconDC, IconBMP);\r\n Brush := CreateSolidBrush(ColorToRGB(CaptionColor));\r\n OldBrush := SelectObject(IconDC, Brush);\r\n // FillRect( IconDC, R, Brush );\r\n PatBlt(IconDC, 0, 0, FCXIcon, FCYIcon, PATCOPY);\r\n\r\n Windows.DrawIcon(IconDC, 0, 0, IconHandle);\r\n StretchBlt(DC, R.Left, R.Top, R.Bottom - R.Top, R.Bottom - R.Top, IconDC,\r\n 0, 0, FCXIcon, FCYIcon, SRCCOPY);\r\n\r\n DeleteObject(SelectObject(IconDC, OldIconBMP));\r\n DeleteObject(SelectObject(IconDC, OldBrush));\r\n DeleteDC(IconDC);\r\nend;\r\n\r\nfunction TJvgCaption.DrawCaption(DrawAll: Boolean): TRect;\r\nvar\r\n DC: HDC;\r\n R, IconR: TRect;\r\n X, Y, X1, Y1, IWidth, IHeight: Integer;\r\nbegin\r\n DC := GetWindowDC(TForm(Owner).Handle);\r\n try\r\n GetWindowRect(TForm(Owner).Handle, R);\r\n FOwnerWidth := R.Right - R.Left;\r\n\r\n R.Left := FCXFrame - 1;\r\n R.Top := FCYFrame - 1;\r\n R.Right := FOwnerWidth - FCXFrame;\r\n R.Bottom := R.Top + FCYCaption - 1;\r\n\r\n FBtnCount := CountCaptionButtons;\r\n if (FBtnCount = 0) and (not DrawAll) then\r\n Exit;\r\n R := DrawBoxEx(DC, R, FCaptBox.Sides, FCaptBox.Inner, FCaptBox.Outer,\r\n FCaptBox.Bold, CaptionColor, True);\r\n if not DrawAll then\r\n Exit;\r\n\r\n if (not FExcludeIcon) and (biSystemMenu in TForm(Owner).BorderIcons) then\r\n begin\r\n IconR := Rect(R.Left, R.Top, R.Left + FCXSMIcon + 3, R.Top + FCYSMIcon);\r\n IconR := DrawBoxEx(DC, IconR, FIconBox.Sides, FIconBox.Inner,\r\n FIconBox.Outer, FIconBox.Bold, CaptionColor, False);\r\n DrawIcon(DC, IconR);\r\n Inc(R.Left, FCXSMIcon + 4);\r\n end;\r\n\r\n Dec(R.Right, FBtnCount * (FCXSMIcon + 1));\r\n if FBtnCount <> 0 then\r\n Dec(R.Right, 4);\r\n R := DrawBoxEx(DC, R, FTextBox.Sides, FTextBox.Inner, FTextBox.Outer,\r\n FTextBox.Bold, CaptionColor, True);\r\n\r\n with TForm(Owner).Canvas do\r\n begin\r\n Inc(R.Right);\r\n Inc(R.Bottom);\r\n Brush.Color := CaptionColor {clActiveCaption};\r\n Brush.Style := bsSolid;\r\n Windows.FillRect(DC, R, Brush.Handle);\r\n end;\r\n Inc(R.Left, 2);\r\n\r\n if IsItAFilledBitmap(FBmp) then\r\n begin\r\n X := R.Left - 2;\r\n Y := R.Top;\r\n IHeight := R.Bottom - R.Top;\r\n IWidth := R.Right - R.Left;\r\n X1 := X;\r\n Y1 := Y;\r\n { while X < IWidth do\r\n begin\r\n while Y < IHeight do\r\n begin\r\n BitBlt(DC, X, Y, Min( IWidth, FBmp.Width ), Min( IHeight, FBmp.Height ), FBmp.Canvas.Handle, 0,0, SRCCOPY );\r\n Inc(Y, Min( IHeight, FBmp.Height ));\r\n end;\r\n Inc(X, Min( IWidth, FBmp.Width ));\r\n Y:=0;\r\n end;}\r\n while X1 < R.Right do\r\n begin\r\n //IWidth:=SavedIWidth; SavedIWidth:=IWidth;\r\n if X1 + IWidth > R.Right then\r\n IWidth := R.Right - X1;\r\n while Y1 < R.Bottom do\r\n begin\r\n // IHeight := SavedIHeight; SavedIHeight:=IHeight;\r\n if Y1 + IHeight > R.Bottom then\r\n IHeight := R.Bottom - Y1;\r\n BitBlt(DC, X1, Y1, Min(IWidth, FBmp.Width), Min(IHeight,\r\n FBmp.Height), FBmp.Canvas.Handle, 0, 0, SRCCOPY);\r\n Inc(Y1, Min(IHeight, FBmp.Height));\r\n end;\r\n Inc(X1, Min(IWidth, FBmp.Width));\r\n Y1 := Y;\r\n end;\r\n end;\r\n //...draw close button\r\n {$IFDEF GL_CAPT_BUTTONS}\r\n if (FBtnCount = 0) and (Tag = 1) then\r\n begin\r\n FCloseRect := Bounds(R.Right - FGlyphClose.Width - 2, R.Top,\r\n FGlyphClose.Width, FGlyphClose.Height);\r\n // BitBlt( DC, R.Right-FGlyphClose.Width-2, R.Top, FGlyphClose.Width, FGlyphClose.Height, FGlyphClose.Canvas.Handle, 0,0, SRCCOPY );\r\n CreateBitmapExt(DC, FGlyphClose, R, R.Right - FGlyphClose.Width - 8,\r\n R.Top - 3,\r\n fwoNone, fdsDefault, True,\r\n GetPixel(FGlyphClose.Canvas.Handle, 0, FGlyphClose.Height - 1)\r\n {TransparentColor},\r\n 0);\r\n end\r\n else\r\n FCloseRect := Rect(0, 0, 0, 0);\r\n {$ENDIF GL_CAPT_BUTTONS}\r\n\r\n DrawTextInRect(DC, R, TForm(Owner).Caption, FTextStyle, FFont,\r\n DT_SINGLELINE or DT_VCENTER or DT_LEFT);\r\n finally\r\n ReleaseDC(TForm(Owner).Handle, DC);\r\n end;\r\n Result := R;\r\nend;\r\n\r\nfunction TJvgCaption.CountCaptionButtons: Integer;\r\nbegin\r\n if not (biSystemMenu in TForm(Owner).BorderIcons) then\r\n begin\r\n Result := 0;\r\n Exit;\r\n end;\r\n Result := 1;\r\n if not (TForm(Owner).BorderStyle in [bsToolWindow, bsSizeToolWin, bsDialog]) then\r\n begin\r\n if (biMinimize in TForm(Owner).BorderIcons) or\r\n (biMaximize in TForm(Owner).BorderIcons) then\r\n Inc(Result, 2)\r\n else\r\n if biHelp in TForm(Owner).BorderIcons then\r\n Inc(Result);\r\n end;\r\nend;\r\n\r\nprocedure TJvgCaption.SmthChanged(Sender: TObject);\r\nbegin\r\n Repaint;\r\nend;\r\n\r\nprocedure TJvgCaption.Repaint;\r\nvar\r\n RGN: HRGN;\r\nbegin\r\n RGN := CreateRectRgn(0, 0, TForm(Owner).Width, FCYCaption);\r\n SendMessage(THandle(TForm(Owner).Handle), WM_NCPAINT, HRGN(RGN), 0);\r\n DeleteObject(RGN);\r\nend;\r\n\r\nprocedure TJvgCaption.SetExcludeIcon(Value: Boolean);\r\nbegin\r\n FExcludeIcon := Value;\r\n if not (csLoading in ComponentState) then\r\n DrawCaption(True);\r\nend;\r\n\r\nprocedure TJvgCaption.SetExcludeButtons(Value: Boolean);\r\nbegin\r\n FExcludeButtons := Value;\r\n if not (csLoading in ComponentState) then\r\n DrawCaption(True);\r\nend;\r\n\r\nprocedure TJvgCaption.SetCaptionColor(Value: TColor);\r\nbegin\r\n FCaptionColor := Value;\r\n if not (csLoading in ComponentState) then\r\n DrawCaption(True);\r\nend;\r\n\r\nprocedure TJvgCaption.SetTextStyle(Value: TglTextStyle);\r\nbegin\r\n FTextStyle := Value;\r\n if not (csLoading in ComponentState) then\r\n DrawCaption(True);\r\nend;\r\n\r\nprocedure TJvgCaption.SetFont(Value: TFont);\r\nbegin\r\n if not Assigned(Value) then\r\n Exit;\r\n FFont.Assign(Value);\r\n Repaint;\r\n if not (csLoading in ComponentState) then\r\n DrawCaption(True);\r\nend;\r\n\r\nprocedure TJvgCaption.SetAutoTransparentColor(Value: TglAutoTransparentColor);\r\nbegin\r\n FAutoTransparentColor := Value;\r\n FTransparentColor := GetTransparentColor(FTexture, Value);\r\n if not (csLoading in ComponentState) then\r\n DrawCaption(True);\r\nend;\r\n\r\nprocedure TJvgCaption.SetTextureTransparent(Value: Boolean);\r\nbegin\r\n if FTextureTransparent = Value then\r\n Exit;\r\n FTextureTransparent := Value;\r\n if not (csLoading in ComponentState) then\r\n DrawCaption(True);\r\nend;\r\n\r\nprocedure TJvgCaption.SetTransparentColor(Value: TColor);\r\nbegin\r\n if FTransparentColor = Value then\r\n Exit;\r\n FTransparentColor := Value;\r\n if not (csLoading in ComponentState) then\r\n DrawCaption(True);\r\nend;\r\n\r\n{procedure TJvgCaption.SetTexture( Value: TBitmap );\r\nbegin\r\n if Assigned(FTexture) then FTexture.Free;\r\n FTexture := TBitmap.Create;\r\n FTexture.Assign(Value);\r\nend;}\r\n\r\nfunction TJvgCaption.GetTexture: TBitmap;\r\nbegin\r\n if not Assigned(FTexture) then\r\n FTexture := TBitmap.Create;\r\n Result := FTexture;\r\nend;\r\n\r\nprocedure TJvgCaption.SetTexture(Value: TBitmap);\r\nbegin\r\n FTexture.Free;\r\n FTexture := TBitmap.Create;\r\n FTexture.Assign(Value);\r\n if Assigned(Value) then\r\n FBmp := FTexture\r\n else\r\n if Assigned(FImage) and Assigned(FImage.Picture) and\r\n Assigned(FImage.Picture.Bitmap) then\r\n FBmp := FImage.Picture.Bitmap\r\n else\r\n FBmp := nil;\r\n if not (csLoading in ComponentState) then\r\n DrawCaption(True);\r\nend;\r\n\r\nprocedure TJvgCaption.SetImage(Value: TImage);\r\nbegin\r\n FImage := Value;\r\n if Assigned(FImage) and Assigned(FImage.Picture) and\r\n Assigned(FImage.Picture.Bitmap) then\r\n FBmp := FImage.Picture.Bitmap\r\n else\r\n if Assigned(FTexture) then\r\n FBmp := FTexture\r\n else\r\n FBmp := nil;\r\n if not (csLoading in ComponentState) then\r\n DrawCaption(True);\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvgCheckBox.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvgCheckBox.PAS, released on 2003-01-15.\r\n\r\nThe Initial Developer of the Original Code is Andrey V. Chudin, [chudin att yandex dott ru]\r\nPortions created by Andrey V. Chudin are Copyright (C) 2003 Andrey V. Chudin.\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\nMichael Beck [mbeck att bigfoot dott com].\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvgCheckBox.pas 13173 2011-11-19 12:43:58Z ahuser $\r\n\r\nunit JvgCheckBox;\r\n\r\n{$I jvcl.inc}\r\n{$I windowsonly.inc} // (ahuser) uses WndProc and Wnd hooks\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,\r\n Dialogs, StdCtrls, ExtCtrls,\r\n JvComponent, JvJVCLUtils,\r\n JvgTypes, JvgCommClasses, JvgUtils;\r\n\r\ntype\r\n TJvgCheckBox = class(TJvGraphicControl)\r\n private\r\n FChecked: Boolean;\r\n FColors: TJvgLabelColors;\r\n FIllumination: TJvgIllumination;\r\n FGlyph: TBitmap;\r\n FGlyphOn: TBitmap;\r\n FGlyphOff: TBitmap;\r\n FGlyphDisabled: TBitmap;\r\n FGradient: TJvgGradient;\r\n FGroupIndex: Integer;\r\n FGlyphShift: TJvgPointClass;\r\n FOptions: TglCheckBoxOptions;\r\n FTransparent: Boolean;\r\n FTextStyles: TJvgLabelTextStyles;\r\n FDisabledMaskColor: TColor;\r\n FInterspace: Integer;\r\n FFocusControl: TWinControl;\r\n FFocusControlMethod: TFocusControlMethod;\r\n FAfterPaint: TNotifyEvent;\r\n FGlyphKind: TglGlyphKind;\r\n FPrevWndProc: Pointer;\r\n FNewWndProc: Pointer;\r\n FActiveNow: Boolean;\r\n FShowAsActiveWhileControlFocused: Boolean;\r\n FImg: TBitmap;\r\n FNeedUpdateOnlyMainText: Boolean;\r\n FSuppressCMFontChanged: Boolean;\r\n FOnlyTextStyleChanged: Boolean;\r\n FAlignment: TLeftRight;\r\n FNeedRebuildBackground: Boolean;\r\n FInitialPainted: Boolean; // set to True after the first call to Paint(), this is only a workaround\r\n function IsCustomGlyph: Boolean;\r\n procedure SetChecked(Value: Boolean);\r\n procedure SetGlyph(Value: TBitmap);\r\n procedure SetGlyphOn(Value: TBitmap);\r\n procedure SetGlyphOff(Value: TBitmap);\r\n procedure SetGlyphDisabled(Value: TBitmap);\r\n procedure SetGroupIndex(Value: Integer);\r\n procedure SetOptions(Value: TglCheckBoxOptions);\r\n procedure SetTransparent(Value: Boolean);\r\n procedure SetDisabledMaskColor(Value: TColor);\r\n procedure SetInterspace(Value: Integer);\r\n procedure SetFocusControl(Value: TWinControl);\r\n procedure SetGlyphKind(Value: TglGlyphKind);\r\n\r\n procedure GradientChanged(Sender: TObject);\r\n procedure IlluminationChanged(Sender: TObject);\r\n procedure WMLButtonUp(var Msg: TMessage); message WM_LBUTTONUP;\r\n procedure WMLButtonDown(var Msg: TMessage); message WM_LBUTTONDOWN;\r\n procedure SetAlignment(const Value: TLeftRight);\r\n protected\r\n procedure MouseEnter(Control: TControl); override;\r\n procedure MouseLeave(Control: TControl); override;\r\n procedure FontChanged; override;\r\n procedure TextChanged; override;\r\n procedure Paint; override;\r\n procedure HookFocusControlWndProc;\r\n procedure UnhookFocusControlWndProc;\r\n procedure FocusControlWndHookProc(var Msg: TMessage);\r\n procedure Notification(AComponent: TComponent; Operation: TOperation); override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n\r\n function GetCheckedItemInGroup: TJvgCheckBox;\r\n procedure SetCheckedItemInGroup(TagNo: Integer);\r\n published\r\n property Anchors;\r\n property Align;\r\n property Caption;\r\n property Enabled;\r\n property ParentShowHint;\r\n property ShowHint;\r\n property Visible;\r\n property OnClick;\r\n property OnDblClick;\r\n property OnDragDrop;\r\n property OnDragOver;\r\n property OnEndDrag;\r\n property OnMouseDown;\r\n property OnMouseMove;\r\n property OnMouseUp;\r\n property OnStartDrag;\r\n property DragCursor;\r\n property DragMode;\r\n property Font;\r\n\r\n property Alignment: TLeftRight read FAlignment write SetAlignment default taRightJustify;\r\n property GlyphKind: TglGlyphKind read FGlyphKind write SetGlyphKind default fgkDefault; // must be above \"GlyphOn/Off/Disabled\"\r\n property Checked: Boolean read FChecked write SetChecked default False;\r\n property Glyph: TBitmap read FGlyph write SetGlyph;\r\n property GlyphOn: TBitmap read FGlyphOn write SetGlyphOn stored IsCustomGlyph;\r\n property GlyphOff: TBitmap read FGlyphOff write SetGlyphOff stored IsCustomGlyph;\r\n property GlyphDisabled: TBitmap read FGlyphDisabled write SetGlyphDisabled stored IsCustomGlyph;\r\n property GroupIndex: Integer read FGroupIndex write SetGroupIndex default 0;\r\n property GlyphShift: TJvgPointClass read FGlyphShift write FGlyphShift;\r\n property Transparent: Boolean read FTransparent write SetTransparent default False;\r\n property TextStyles: TJvgLabelTextStyles read FTextStyles write FTextStyles;\r\n property Colors: TJvgLabelColors read FColors write FColors;\r\n property Options: TglCheckBoxOptions read FOptions write SetOptions;\r\n property Gradient: TJvgGradient read FGradient write FGradient;\r\n property Illumination: TJvgIllumination read FIllumination write FIllumination;\r\n property DisabledMaskColor: TColor read FDisabledMaskColor write SetDisabledMaskColor default clBlack;\r\n property Interspace: Integer read FInterspace write SetInterspace default 0;\r\n property FocusControl: TWinControl read FFocusControl write SetFocusControl;\r\n property FocusControlMethod: TFocusControlMethod read FFocusControlMethod write FFocusControlMethod default fcmOnMouseDown;\r\n\r\n property OnMouseEnter;\r\n property OnMouseLeave;\r\n property AfterPaint: TNotifyEvent read FAfterPaint write FAfterPaint;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvgCheckBox.pas $';\r\n Revision: '$Revision: 13173 $';\r\n Date: '$Date: 2011-11-19 13:43:58 +0100 (sam. 19 nov. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n Math,\r\n {$IFNDEF COMPILER12_UP}\r\n JvJCLUtils, // SetWindowLongPtr\r\n {$ENDIF ~COMPILER12_UP}\r\n JvThemes;\r\n\r\n{$R JvgCheckBox.res}\r\n\r\nconstructor TJvgCheckBox.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n ControlStyle :=\r\n [csCaptureMouse, csOpaque, csClickEvents, csSetCaption, csReplicatable];\r\n // ControlStyle := ControlStyle + [csOpaque, csReplicatable];\r\n IncludeThemeStyle(Self, [csParentBackground]);\r\n\r\n FGlyphOn := TBitmap.Create;\r\n FGlyphOff := TBitmap.Create;\r\n FGlyphDisabled := TBitmap.Create;\r\n FGlyph := TBitmap.Create;\r\n FImg := TBitmap.Create;\r\n\r\n TextStyles := TJvgLabelTextStyles.Create;\r\n Colors := TJvgLabelColors.Create;\r\n Gradient := TJvgGradient.Create;\r\n FIllumination := TJvgIllumination.Create;\r\n FGlyphShift := TJvgPointClass.Create;\r\n\r\n //..defaults\r\n Width := 80;\r\n Height := 17;\r\n FAlignment := taRightJustify;\r\n FChecked := False;\r\n FTransparent := False;\r\n FGradient.OnChanged := GradientChanged;\r\n FIllumination.OnChanged := IlluminationChanged;\r\n TextStyles.OnChanged := IlluminationChanged;\r\n Colors.OnChanged := IlluminationChanged;\r\n FGlyphShift.OnChanged := GradientChanged;\r\n FOptions := [fcoFastDraw];\r\n FGroupIndex := 0;\r\n FInterspace := 0;\r\n FFocusControlMethod := fcmOnMouseDown;\r\n FNeedRebuildBackground := True;\r\n\r\n FImg.Canvas.Brush.Color := clBtnFace;\r\n FImg.Canvas.Brush.Style := bsSolid;\r\n // FNeedUpdateOnlyMainText := False;\r\n {$IFDEF FR_RUS}\r\n Font.CharSet := RUSSIAN_CHARSET;\r\n {$ENDIF FR_RUS}\r\n GlyphKind := fgkDefault;\r\nend;\r\n\r\ndestructor TJvgCheckBox.Destroy;\r\nbegin\r\n FGlyphOn.Free;\r\n FGlyphOff.Free;\r\n FGlyph.Free;\r\n FGlyphDisabled.Free;\r\n FImg.Free;\r\n FTextStyles.Free;\r\n FColors.Free;\r\n FGradient.Free;\r\n FIllumination.Free;\r\n FGlyphShift.Free;\r\n SetFocusControl(nil);\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvgCheckBox.FontChanged;\r\nbegin\r\n if not FSuppressCMFontChanged then\r\n begin\r\n FImg.Canvas.Font.Assign(Font);\r\n Invalidate;\r\n inherited FontChanged;\r\n end;\r\nend;\r\n\r\nprocedure TJvgCheckBox.MouseEnter(Control: TControl);\r\nbegin\r\n if (csDesigning in ComponentState) or not FInitialPainted then\r\n Exit;\r\n if not Enabled or (fcoIgnoreMouse in Options) or FShowAsActiveWhileControlFocused then\r\n Exit;\r\n if Assigned(FocusControl) and (FocusControlMethod = fcmOnMouseEnter) then\r\n FocusControl.SetFocus;\r\n FNeedRebuildBackground := True;\r\n FActiveNow := True;\r\n with TextStyles, Colors do\r\n if (Passive <> Active) or (fcoUnderlinedActive in Options) then\r\n Repaint\r\n else\r\n if (fcoDelineatedText in Options) and (DelineateActive <> Delineate) then\r\n Repaint\r\n else\r\n if (not Transparent) and (Colors.Background <> Colors.BackgroundActive) then\r\n Repaint\r\n else\r\n if (TextActive <> Text) or (fcoUnderlinedActive in Options) then\r\n begin\r\n FNeedUpdateOnlyMainText := True;\r\n Repaint;\r\n end;\r\n inherited MouseEnter(Control);\r\nend;\r\n\r\nprocedure TJvgCheckBox.MouseLeave(Control: TControl);\r\nbegin\r\n if (csDesigning in ComponentState) or not FInitialPainted then\r\n Exit;\r\n if not Enabled or (fcoIgnoreMouse in Options) or FShowAsActiveWhileControlFocused then\r\n Exit;\r\n FNeedRebuildBackground := True;\r\n FActiveNow := False;\r\n with TextStyles, Colors do\r\n if (Passive <> Active) or (fcoUnderlinedActive in Options) then\r\n Repaint\r\n else\r\n if (fcoDelineatedText in Options) and (DelineateActive <> Delineate) then\r\n Repaint\r\n else\r\n if (not Transparent) and (Colors.Background <> Colors.BackgroundActive) then\r\n Repaint\r\n else\r\n if TextActive <> Text then\r\n begin\r\n FNeedUpdateOnlyMainText := True;\r\n Repaint;\r\n end;\r\n inherited MouseLeave(Control);\r\nend;\r\n\r\nprocedure TJvgCheckBox.TextChanged;\r\nbegin\r\n inherited TextChanged;\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvgCheckBox.WMLButtonUp(var Msg: TMessage);\r\nvar\r\n pt: TPoint;\r\nbegin\r\n if not Enabled or (fcoIgnoreMouse in Options) then\r\n Exit;\r\n GetCursorPos(pt);\r\n pt := ScreenToClient(pt);\r\n if PtInRect(ClientRect, pt) then\r\n SetChecked(not FChecked);\r\n if Assigned(FocusControl) then\r\n begin\r\n if fcoEnabledFocusControlWhileChecked in Options then\r\n FocusControl.Enabled := FChecked;\r\n if (FocusControlMethod = fcmOnMouseUp) and FocusControl.CanFocus then\r\n FocusControl.SetFocus;\r\n end;\r\n inherited;\r\nend;\r\n\r\nprocedure TJvgCheckBox.WMLButtonDown(var Msg: TMessage);\r\nbegin\r\n if not Enabled or (fcoIgnoreMouse in Options) then\r\n Exit;\r\n inherited;\r\n if (FocusControlMethod = fcmOnMouseDown) and Assigned(FocusControl) and FocusControl.CanFocus then\r\n FocusControl.SetFocus;\r\nend;\r\n\r\nprocedure TJvgCheckBox.Paint;\r\nvar\r\n X, Y: Integer;\r\n DrawState: TglDrawState;\r\n Bitmap: TBitmap;\r\n FontColor: TColor;\r\n CurrTextStyle: TglTextStyle;\r\n CurrDelinColor: TColor;\r\n isGradientActive: Boolean;\r\n Size: TSize;\r\n R: TRect;\r\n BackBrush: HBRUSH;\r\nbegin\r\n FInitialPainted := True;\r\n\r\n //FNeedUpdateOnlyMainText := False;\r\n //FNeedRebuildBackground := False;\r\n FSuppressCMFontChanged := True;\r\n if fcoBoldChecked in Options then\r\n if Checked then\r\n Font.Style := Font.Style + [fsBold]\r\n else\r\n Font.Style := Font.Style - [fsBold];\r\n\r\n if Enabled then\r\n begin\r\n if Checked then\r\n Bitmap := FGlyphOn\r\n else\r\n Bitmap := FGlyphOff;\r\n DrawState := fdsDefault;\r\n end\r\n else\r\n begin\r\n if FGlyphDisabled.Handle <> 0 then\r\n begin\r\n Bitmap := FGlyphDisabled;\r\n DrawState := fdsDefault;\r\n end\r\n else\r\n begin\r\n if Checked then\r\n Bitmap := FGlyphOn\r\n else\r\n Bitmap := FGlyphOff;\r\n DrawState := fdsDefault;\r\n end;\r\n end;\r\n\r\n //...CAPTION\r\n SetBkMode(Canvas.Handle, Integer(Transparent));\r\n with TextStyles, Colors do\r\n begin\r\n if FActiveNow then\r\n begin\r\n CurrTextStyle := Active;\r\n CurrDelinColor := DelineateActive;\r\n FontColor := TextActive;\r\n end\r\n else\r\n if Enabled then\r\n begin\r\n CurrTextStyle := Passive;\r\n CurrDelinColor := Delineate;\r\n FontColor := Text;\r\n end\r\n else\r\n begin\r\n CurrTextStyle := Disabled;\r\n CurrDelinColor := Delineate;\r\n FontColor := TextDisabled;\r\n end;\r\n\r\n if fcoUnderlinedActive in Options then\r\n if FActiveNow then\r\n Font.Style := Font.Style + [fsUnderline]\r\n else\r\n Font.Style := Font.Style - [fsUnderline];\r\n end;\r\n GetTextExtentPoint32(FImg.Canvas.Handle, PChar(Caption), Length(Caption), Size);\r\n Y := Max(0, (Height - Size.cy) div 2);\r\n X := 0;\r\n if Assigned(FGlyphOn) then\r\n X := Max(X, FGlyphOn.Width);\r\n if Assigned(FGlyphOff) then\r\n X := Max(X, FGlyphOff.Width);\r\n if Assigned(FGlyphDisabled) then\r\n X := Max(X, FGlyphDisabled.Width);\r\n if Assigned(FGlyph) then\r\n X := Max(X, FGlyph.Width);\r\n\r\n FImg.Width := Width;\r\n FImg.Height := Height;\r\n\r\n if not FNeedUpdateOnlyMainText {and not Transparent} then\r\n begin\r\n R := GetClientRect;\r\n if FActiveNow then\r\n BackBrush := CreateSolidBrush(ColorToRGB(Colors.BackgroundActive))\r\n else\r\n BackBrush := CreateSolidBrush(ColorToRGB(Colors.Background));\r\n FillRect(FImg.Canvas.Handle, R, BackBrush);\r\n DeleteObject(BackBrush);\r\n end;\r\n\r\n if FTransparent and not FNeedUpdateOnlyMainText then\r\n if not (fcoFastDraw in Options) or FNeedRebuildBackground or\r\n (csDesigning in ComponentState) then\r\n GetParentImageRect(Self, Bounds(Left, Top, Width, Height), FImg.Canvas.Handle);\r\n\r\n if Alignment = taLeftJustify then\r\n begin\r\n X := 0;\r\n if FGlyph <> nil then\r\n Inc(X, FGlyph.Width);\r\n end\r\n else\r\n Inc(X, Interspace);\r\n\r\n //...Supress Gradient if needed\r\n isGradientActive := Gradient.Active;\r\n if FActiveNow and (Colors.TextActive <> Colors.Text) then\r\n Gradient.Active := False;\r\n\r\n ExtTextOutExt(FImg.Canvas.Handle, X, Y, GetClientRect, Caption,\r\n CurrTextStyle, fcoDelineatedText in Options,\r\n FNeedUpdateOnlyMainText, FontColor, CurrDelinColor,\r\n Colors.Highlight, Colors.Shadow,\r\n Illumination, Gradient, Font);\r\n\r\n Gradient.Active := isGradientActive;\r\n\r\n if not FNeedUpdateOnlyMainText then\r\n begin\r\n if (not (fcoFastDraw in Options)) or FNeedRebuildBackground or (csDesigning\r\n in ComponentState) then\r\n begin\r\n if FGlyph <> nil then //...TransparentColor -> Left Bottom Pixel\r\n begin\r\n if not Transparent then\r\n JvgUtils.ChangeBitmapColor(FGlyph, GetPixel(FGlyph.Canvas.Handle, 0, FGlyph.Height - 1),\r\n clBtnFace);\r\n\r\n // glyph always left\r\n CreateBitmapExt(FImg.Canvas.Handle, FGlyph, ClientRect, 0,\r\n Max(0, (Height - FGlyph.Height) div 2),\r\n fwoNone, DrawState, Transparent,\r\n GetPixel(FGlyph.Canvas.Handle, 0, FGlyph.Height - 1)\r\n {TransparentColor},\r\n DisabledMaskColor);\r\n end;\r\n FNeedRebuildBackground := False;\r\n end;\r\n if not Transparent then\r\n if FActiveNow then\r\n JvgUtils.ChangeBitmapColor(Bitmap, GetPixel(Bitmap.Canvas.Handle, 0, Bitmap.Height - 1),\r\n Colors.BackgroundActive)\r\n else\r\n JvgUtils.ChangeBitmapColor(Bitmap, GetPixel(Bitmap.Canvas.Handle, 0, Bitmap.Height - 1),\r\n Colors.Background);\r\n\r\n if Alignment = taRightJustify then\r\n X := GlyphShift.X\r\n else\r\n X := Width - Bitmap.Width;\r\n\r\n if Assigned(Bitmap) then\r\n CreateBitmapExt(FImg.Canvas.Handle, Bitmap, ClientRect, X,\r\n Integer(GlyphShift.Y + Max(0, (Height - Bitmap.Height) div 2)),\r\n fwoNone, DrawState, Transparent,\r\n GetPixel(Bitmap.Canvas.Handle, 0, Bitmap.Height - 1),\r\n DisabledMaskColor);\r\n end;\r\n\r\n{ BitBlt(Canvas.Handle, 0, 0, Img.Width, Img.Height, Img.Canvas.Handle, 0, 0,\r\n SRCCOPY);}\r\n FImg.Transparent := True;\r\n FImg.TransparentMode := tmAuto;\r\n Canvas.Draw(0, 0, FImg);\r\n\r\n FSuppressCMFontChanged := False;\r\n FOnlyTextStyleChanged := False;\r\n FNeedUpdateOnlyMainText := False;\r\n if Assigned(FAfterPaint) then\r\n FAfterPaint(Self);\r\nend;\r\n\r\nprocedure TJvgCheckBox.Notification(AComponent: TComponent; Operation:\r\n TOperation);\r\nbegin\r\n inherited Notification(AComponent, Operation);\r\n if (AComponent = FocusControl) and (Operation = opRemove) then\r\n begin {UnhookFocusControlWndProc;}\r\n FFocusControl := nil;\r\n end;\r\nend;\r\n\r\nprocedure TJvgCheckBox.HookFocusControlWndProc;\r\nvar\r\n P: Pointer;\r\nbegin\r\n P := Pointer(GetWindowLongPtr(FocusControl.Handle, GWL_WNDPROC));\r\n if (P <> FNewWndProc) then\r\n begin\r\n FPrevWndProc := P;\r\n FNewWndProc := JvMakeObjectInstance(FocusControlWndHookProc);\r\n SetWindowLongPtr(FocusControl.Handle, GWL_WNDPROC, LONG_PTR(FNewWndProc));\r\n end;\r\nend;\r\n\r\nprocedure TJvgCheckBox.UnhookFocusControlWndProc;\r\nbegin\r\n // if not(csDesigning in ComponentState) then Exit;\r\n if (FNewWndProc <> nil) and (FPrevWndProc <> nil) and\r\n (Pointer(GetWindowLongPtr(FocusControl.Handle, GWL_WNDPROC)) = FNewWndProc) then\r\n begin\r\n SetWindowLongPtr(FocusControl.Handle, GWL_WNDPROC, LONG_PTR(FPrevWndProc));\r\n // (rom) JvFreeObjectInstance call added\r\n JvFreeObjectInstance(FNewWndProc);\r\n FNewWndProc := nil;\r\n end;\r\nend;\r\n\r\nprocedure TJvgCheckBox.FocusControlWndHookProc(var Msg: TMessage);\r\nbegin\r\n case Msg.Msg of\r\n WM_SETFOCUS:\r\n begin\r\n MouseEnter(Self);\r\n FShowAsActiveWhileControlFocused := True;\r\n end;\r\n WM_KILLFOCUS:\r\n begin\r\n FShowAsActiveWhileControlFocused := False;\r\n MouseLeave(Self);\r\n end;\r\n WM_DESTROY: {fNeedRehookFocusControl := True};\r\n end;\r\n with Msg do\r\n Result := CallWindowProc(FPrevWndProc, TForm(Owner).Handle, Msg, WParam, LParam);\r\nend;\r\n\r\nprocedure TJvgCheckBox.SetFocusControl(Value: TWinControl);\r\nbegin\r\n if FFocusControl <> Value then\r\n begin\r\n if (fcoActiveWhileControlFocused in Options) and Assigned(FFocusControl) then\r\n UnhookFocusControlWndProc;\r\n ReplaceComponentReference(Self, Value, TComponent(FFocusControl));\r\n if (fcoActiveWhileControlFocused in Options) and Assigned(FFocusControl) then\r\n HookFocusControlWndProc;\r\n end;\r\nend;\r\n\r\nprocedure TJvgCheckBox.GradientChanged(Sender: TObject);\r\nbegin\r\n if not (csLoading in ComponentState) then\r\n FNeedUpdateOnlyMainText := True;\r\n Repaint;\r\nend;\r\n\r\nprocedure TJvgCheckBox.IlluminationChanged(Sender: TObject);\r\nbegin\r\n CalcShadowAndHighlightColors((Parent as TWinControl).Brush.Color, Colors);\r\n Repaint;\r\nend;\r\n\r\nfunction TJvgCheckBox.IsCustomGlyph: Boolean;\r\nbegin\r\n Result := FGlyphKind = fgkCustom;\r\nend;\r\n\r\nfunction TJvgCheckBox.GetCheckedItemInGroup: TJvgCheckBox;\r\nvar\r\n I: Integer;\r\nbegin\r\n if FChecked then\r\n Result := Self\r\n else\r\n begin\r\n Result := nil;\r\n if GroupIndex <> 0 then\r\n begin\r\n for I := 0 to Owner.ComponentCount - 1 do\r\n if (Owner.Components[I] is TJvgCheckBox) and\r\n (TJvgCheckBox(Owner.Components[I]).GroupIndex = GroupIndex) and\r\n (TJvgCheckBox(Owner.Components[I]).Checked) then\r\n begin\r\n Result := TJvgCheckBox(Owner.Components[I]);\r\n Break;\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvgCheckBox.SetCheckedItemInGroup(TagNo: Integer);\r\nvar\r\n I: Integer;\r\nbegin\r\n if GroupIndex <> 0 then\r\n begin\r\n for I := 0 to Owner.ComponentCount - 1 do\r\n if (Owner.Components[I] is TJvgCheckBox) and\r\n (TJvgCheckBox(Owner.Components[I]).GroupIndex = GroupIndex) and\r\n (TJvgCheckBox(Owner.Components[I]).Tag = TagNo) then\r\n begin\r\n TJvgCheckBox(Owner.Components[I]).Checked := True;\r\n Break;\r\n end;\r\n end;\r\nend;\r\n//...______________________________________________PROPERTIES METHODS\r\n\r\nprocedure TJvgCheckBox.SetChecked(Value: Boolean);\r\nvar\r\n I: Integer;\r\nbegin\r\n if FChecked <> Value then\r\n begin\r\n FNeedRebuildBackground := True;\r\n if GroupIndex <> 0 then\r\n begin\r\n if not FChecked then\r\n begin\r\n for I := 0 to Owner.ComponentCount - 1 do\r\n if (Owner.Components[I] is TJvgCheckBox) and\r\n (TJvgCheckBox(Owner.Components[I]).GroupIndex = GroupIndex) and\r\n (TJvgCheckBox(Owner.Components[I]).Checked) and\r\n (Owner.Components[I] <> Self) then\r\n begin\r\n TJvgCheckBox(Owner.Components[I]).FChecked := False;\r\n TJvgCheckBox(Owner.Components[I]).FNeedRebuildBackground := True;\r\n TJvgCheckBox(Owner.Components[I]).Invalidate;\r\n end;\r\n FChecked := True;\r\n end;\r\n end\r\n else\r\n FChecked := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvgCheckBox.SetGlyph(Value: TBitmap);\r\nbegin\r\n FGlyph.Assign(Value);\r\n FNeedRebuildBackground := True;\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvgCheckBox.SetGlyphOn(Value: TBitmap);\r\nbegin\r\n FGlyphKind := fgkCustom;\r\n FGlyphOn.Assign(Value);\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvgCheckBox.SetGlyphOff(Value: TBitmap);\r\nbegin\r\n FGlyphKind := fgkCustom;\r\n FGlyphOff.Assign(Value);\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvgCheckBox.SetGlyphDisabled(Value: TBitmap);\r\nbegin\r\n FGlyphDisabled.Assign(Value);\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvgCheckBox.SetGroupIndex(Value: Integer);\r\nbegin\r\n if FGroupIndex <> Value then\r\n begin\r\n FGroupIndex := Value;\r\n if FChecked and (Value <> 0) then\r\n begin\r\n FChecked := False;\r\n // SetChecked( True );\r\n FChecked := True;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvgCheckBox.SetOptions(Value: TglCheckBoxOptions);\r\nbegin\r\n if FOptions <> Value then\r\n begin\r\n FOptions := Value;\r\n CalcShadowAndHighlightColors((Parent as TWinControl).Brush.Color, Colors);\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvgCheckBox.SetTransparent(Value: Boolean);\r\nbegin\r\n if FTransparent <> Value then\r\n begin\r\n FTransparent := Value;\r\n if FTransparent then\r\n ExcludeThemeStyle(Self, [csParentBackground])\r\n else\r\n IncludeThemeStyle(Self, [csParentBackground]);\r\n Repaint;\r\n end;\r\nend;\r\n\r\nprocedure TJvgCheckBox.SetDisabledMaskColor(Value: TColor);\r\nbegin\r\n if FDisabledMaskColor <> Value then\r\n begin\r\n FDisabledMaskColor := Value;\r\n FNeedRebuildBackground := True;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvgCheckBox.SetInterspace(Value: Integer);\r\nbegin\r\n if FInterspace <> Value then\r\n begin\r\n FInterspace := Value;\r\n FNeedRebuildBackground := True;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvgCheckBox.SetGlyphKind(Value: TglGlyphKind);\r\nbegin\r\n if Value <> FGlyphKind then\r\n begin\r\n FGlyphKind := Value;\r\n\r\n if (FGlyphKind = fgkCustom) and (csReading in ComponentState) then\r\n begin\r\n FGlyphOn.Assign(nil);\r\n FGlyphOff.Assign(nil);\r\n FGlyphDisabled.Assign(nil);\r\n end\r\n else\r\n //if (csDesigning in ComponentState){and not(csLoading in ComponentState)}then\r\n begin\r\n FGlyphOn.Assign(nil); // fixes GDI resource leak\r\n FGlyphOff.Assign(nil); // fixes GDI resource leak\r\n FGlyphDisabled.Assign(nil); // fixes GDI resource leak\r\n FGlyphOn.LoadFromResourceName(HInstance, 'JvgON');\r\n FGlyphOff.LoadFromResourceName(HInstance, 'JvgOFF');\r\n FGlyphDisabled.LoadFromResourceName(HInstance, 'JvgDISABLED');\r\n\r\n FGlyphOn.Transparent := True;\r\n FGlyphOn.TransparentMode := tmAuto;\r\n FGlyphOff.Transparent := True;\r\n FGlyphOff.TransparentMode := tmAuto;\r\n FGlyphDisabled.Transparent := True;\r\n FGlyphDisabled.TransparentMode := tmAuto;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvgCheckBox.SetAlignment(const Value: TLeftRight);\r\nbegin\r\n if Value <> FAlignment then\r\n begin\r\n FAlignment := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvgCommClasses.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing Rights and limitations under the License.\r\n\r\nThe Original Code is: JvgCommClasses.PAS, released on 2003-01-15.\r\n\r\nThe Initial Developer of the Original Code is Andrey V. Chudin, [chudin att yandex dott ru]\r\nPortions created by Andrey V. Chudin are CopyRight (C) 2003 Andrey V. Chudin.\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\nMichael Beck [mbeck att bigfoot dott com].\r\nRob den Braasem [rbraasem att xs4all dott nl]\r\nBurov Dmitry, translation of russian text.\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvgCommClasses.pas 13104 2011-09-07 06:50:43Z obones $\r\n\r\nunit JvgCommClasses;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, Graphics, Controls, Classes, ExtCtrls,\r\n JvgTypes;\r\n\r\ntype\r\n TJvgTwainColors = class;\r\n TJvgCustomGradient = class;\r\n TJvgGradient = class;\r\n TJvg3DGradient = class;\r\n TJvg2DAlign = class;\r\n TJvgPointClass = class;\r\n TJvgBevelOptions = class;\r\n TJvgExtBevelOptions = class;\r\n TJvgIllumination = class;\r\n TJvgLabelTextStyles = class;\r\n TJvgCustomTextColors = class;\r\n TJvgSimleLabelColors = class;\r\n TJvgCustomLabelColors = class;\r\n TJvgLabelColors = class;\r\n TJvgGroupBoxColors = class;\r\n TJvgListBoxItemStyle = class;\r\n TJvgAskListBoxItemStyle = class;\r\n TJvgCustomBoxStyle = class;\r\n TJvgCustomTextBoxStyle = class;\r\n TJvgTextBoxStyle = class;\r\n TJvgBevelLines = class;\r\n\r\n TJvgTwainColors = class(TPersistent)\r\n private\r\n FFromColor: TColor;\r\n FToColor: TColor;\r\n FRGBFromColor: Longint;\r\n FRGBToColor: Longint;\r\n FOnChanged: TNotifyEvent;\r\n procedure SetFromColor(Value: TColor);\r\n procedure SetToColor(Value: TColor);\r\n protected\r\n procedure Changed; virtual;\r\n public\r\n constructor Create; virtual;\r\n procedure Assign(Source: TPersistent); override;\r\n property RGBFromColor: Longint read FRGBFromColor write FRGBFromColor;\r\n property RGBToColor: Longint read FRGBToColor write FRGBToColor;\r\n property OnChanged: TNotifyEvent read FOnChanged write FOnChanged;\r\n published\r\n property FromColor: TColor read FFromColor write SetFromColor default clGray;\r\n property ToColor: TColor read FToColor write SetToColor default 0;\r\n end;\r\n\r\n TJvgCustomGradient = class(TJvgTwainColors)\r\n private\r\n FBufferedDraw: Boolean;\r\n FSteps: Integer;\r\n FPercentFilling: Integer;\r\n FBrushStyle: TBrushStyle;\r\n FOrientation: TglGradientDir; //...public!\r\n FActive: Boolean;\r\n FReverse: Boolean;\r\n procedure SetActive(Value: Boolean);\r\n procedure SetOrientation(Value: TglGradientDir);\r\n procedure SetSteps(Value: Integer);\r\n procedure SetPercentFilling(Value: Integer);\r\n procedure SetBrushStyle(Value: TBrushStyle);\r\n protected\r\n property Active: Boolean read FActive write SetActive;\r\n property BufferedDraw: Boolean read FBufferedDraw write FBufferedDraw default False;\r\n property Orientation: TglGradientDir read FOrientation write SetOrientation;\r\n property Steps: Integer read FSteps write SetSteps default 255;\r\n property PercentFilling: Integer read FPercentFilling write SetPercentFilling default 100;\r\n property BrushStyle: TBrushStyle read FBrushStyle write SetBrushStyle default bsSolid;\r\n public\r\n constructor Create; override;\r\n procedure Assign(Source: TPersistent); override;\r\n procedure TextOut(DC: HDC; const Str: string; TextR: TRect; X, Y: Integer);\r\n function GetColorFromGradientLine(GradientLineWidth, Position: Word): COLORREF;\r\n end;\r\n\r\n TJvgGradient = class(TJvgCustomGradient)\r\n public\r\n procedure Draw(DC: HDC; r: TRect; PenStyle, PenWidth: Integer);\r\n published\r\n property Active;\r\n property BufferedDraw;\r\n property Orientation;\r\n property Steps;\r\n property PercentFilling;\r\n property BrushStyle;\r\n end;\r\n\r\n TJvg3DGradient = class(TJvgCustomGradient)\r\n private\r\n FDepth: Word;\r\n FGType: TThreeDGradientType;\r\n procedure SetDepth(Value: Word);\r\n procedure SetGType(Value: TThreeDGradientType);\r\n public\r\n constructor Create; override;\r\n procedure Assign(Source: TPersistent); override;\r\n published\r\n property Depth: Word read FDepth write SetDepth default 16;\r\n property GType: TThreeDGradientType read FGType write SetGType default fgtFlat;\r\n end;\r\n\r\n TJvg2DAlign = class(TPersistent)\r\n private\r\n FHorizontal: TglHorAlign;\r\n FVertical: TglVertAlign;\r\n FOnChanged: TNotifyEvent;\r\n procedure SetHorizontal(Value: TglHorAlign);\r\n procedure SetVertical(Value: TglVertAlign);\r\n protected\r\n procedure Changed; virtual;\r\n public\r\n constructor Create;\r\n procedure Assign(Source: TPersistent); override;\r\n property OnChanged: TNotifyEvent read FOnChanged write FOnChanged;\r\n published\r\n property Horizontal: TglHorAlign read FHorizontal write SetHorizontal\r\n default fhaLeft;\r\n property Vertical: TglVertAlign read FVertical write SetVertical\r\n default fvaTop;\r\n end;\r\n\r\n TJvgPointClass = class(TPersistent)\r\n private\r\n FX: Integer;\r\n FY: Integer;\r\n FOnChanged: TNotifyEvent;\r\n procedure SetX(Value: Integer);\r\n procedure SetY(Value: Integer);\r\n protected\r\n procedure Changed; virtual;\r\n public\r\n procedure Assign(Source: TPersistent); override;\r\n property OnChanged: TNotifyEvent read FOnChanged write FOnChanged;\r\n published\r\n property X: Integer read FX write SetX;\r\n property Y: Integer read FY write SetY;\r\n end;\r\n\r\n TJvgBevelOptions = class(TPersistent)\r\n private\r\n FInner: TPanelBevel;\r\n FOuter: TPanelBevel;\r\n FSides: TglSides;\r\n FBold: Boolean;\r\n FOnChanged: TNotifyEvent;\r\n procedure SetInner(Value: TPanelBevel);\r\n procedure SetOuter(Value: TPanelBevel);\r\n procedure SetSides(Value: TglSides);\r\n procedure SetBold(Value: Boolean);\r\n protected\r\n procedure Changed; virtual;\r\n public\r\n constructor Create; virtual;\r\n procedure Assign(Source: TPersistent); override;\r\n function BordersHeight: Integer;\r\n function BordersWidth: Integer;\r\n property OnChanged: TNotifyEvent read FOnChanged write FOnChanged;\r\n published\r\n property Inner: TPanelBevel read FInner write SetInner stored True; // default bvLowered;\r\n property Outer: TPanelBevel read FOuter write SetOuter stored True; // default bvNone;\r\n property Sides: TglSides read FSides write SetSides stored True default ALLGLSIDES;\r\n property Bold: Boolean read FBold write SetBold stored True; // default False;\r\n end;\r\n\r\n TJvgExtBevelOptions = class(TJvgBevelOptions)\r\n private\r\n FActive: Boolean;\r\n FBevelPenStyle: TPenStyle;\r\n FBevelPenWidth: Word;\r\n FInteriorOffset: Word;\r\n procedure SetActive(Value: Boolean);\r\n procedure SetBevelPenStyle(Value: TPenStyle);\r\n procedure SetBevelPenWidth(Value: Word);\r\n procedure SetInteriorOffset(Value: Word);\r\n public\r\n constructor Create; override;\r\n procedure Assign(Source: TPersistent); override;\r\n published\r\n property Active: Boolean read FActive write SetActive default True;\r\n property BevelPenStyle: TPenStyle read FBevelPenStyle write SetBevelPenStyle default psSolid;\r\n property BevelPenWidth: Word read FBevelPenWidth write SetBevelPenWidth default 1;\r\n property InteriorOffset: Word read FInteriorOffset write SetInteriorOffset default 0;\r\n end;\r\n\r\n TJvgIllumination = class(TJvg2DAlign)\r\n private\r\n FShadowDepth: Integer;\r\n procedure SetShadowDepth(Value: Integer);\r\n public\r\n constructor Create;\r\n procedure Assign(Source: TPersistent); override;\r\n published\r\n property ShadowDepth: Integer read FShadowDepth write SetShadowDepth default 2;\r\n end;\r\n\r\n TJvgLabelTextStyles = class(TPersistent)\r\n private\r\n FPassive: TglTextStyle;\r\n FActive: TglTextStyle;\r\n FDisabled: TglTextStyle;\r\n FOnChanged: TNotifyEvent;\r\n procedure SetPassive(Value: TglTextStyle);\r\n procedure SetActive(Value: TglTextStyle);\r\n procedure SetDisabled(Value: TglTextStyle);\r\n protected\r\n procedure Changed; virtual;\r\n public\r\n constructor Create;\r\n procedure Assign(Source: TPersistent); override;\r\n property OnChanged: TNotifyEvent read FOnChanged write FOnChanged;\r\n published\r\n property Passive: TglTextStyle read FPassive write SetPassive default fstRaised;\r\n property Active: TglTextStyle read FActive write SetActive default fstRaised;\r\n property Disabled: TglTextStyle read FDisabled write SetDisabled default fstPushed;\r\n end;\r\n\r\n TJvgCustomTextColors = class(TPersistent)\r\n private\r\n FOnChanged: TNotifyEvent;\r\n FText: TColor;\r\n FTextDisabled: TColor;\r\n FDelineate: TColor;\r\n FBackground: TColor;\r\n FHighlight: TColor;\r\n FShadow: TColor;\r\n private\r\n procedure SetText(Value: TColor);\r\n procedure SetTextDisabled(Value: TColor);\r\n procedure SetDelineate(Value: TColor);\r\n procedure SetBackground(Value: TColor);\r\n procedure SetHighlight(Value: TColor);\r\n procedure SetShadow(Value: TColor);\r\n protected\r\n procedure Changed; virtual;\r\n public\r\n constructor Create; virtual;\r\n procedure Assign(Source: TPersistent); override;\r\n property OnChanged: TNotifyEvent read FOnChanged write FOnChanged;\r\n protected\r\n property Text: TColor read FText write SetText default clBlack;\r\n property TextDisabled: TColor read FTextDisabled write SetTextDisabled default clGray;\r\n property Delineate: TColor read FDelineate write SetDelineate default clWhite;\r\n property Shadow: TColor read FShadow write SetShadow default clBtnShadow;\r\n property Highlight: TColor read FHighlight write SetHighlight default clBtnHighlight;\r\n property Background: TColor read FBackground write SetBackground default clBtnFace;\r\n end;\r\n\r\n TJvgSimleLabelColors = class(TJvgCustomTextColors)\r\n published\r\n // property Text stored True;\r\n property Delineate stored True;\r\n property Shadow stored True;\r\n property Highlight;\r\n property Background stored True;\r\n end;\r\n\r\n TJvgCustomLabelColors = class(TJvgCustomTextColors)\r\n private\r\n FTextActive: TColor;\r\n FDelineateActive: TColor;\r\n FAutoHighlight: Boolean;\r\n FAutoShadow: Boolean;\r\n FBackgroundActive: TColor;\r\n FColorHighlightShift: Integer;\r\n FColorShadowShift: Integer;\r\n private\r\n procedure SetTextActive(Value: TColor);\r\n procedure SetDelineateActive(Value: TColor);\r\n procedure SetBackgroundActive(Value: TColor);\r\n procedure SetAutoHighlight(Value: Boolean);\r\n procedure SetAutoShadow(Value: Boolean);\r\n procedure SetColorHighlightShift(Value: Integer);\r\n procedure SetColorShadowShift(Value: Integer);\r\n public\r\n constructor Create; override;\r\n procedure Assign(Source: TPersistent); override;\r\n protected\r\n property TextActive: TColor read FTextActive write SetTextActive default clBlack;\r\n property DelineateActive: TColor read FDelineateActive write SetDelineateActive default clWhite;\r\n property AutoHighlight: Boolean read FAutoHighlight write SetAutoHighlight default False;\r\n property AutoShadow: Boolean read FAutoShadow write SetAutoShadow default False;\r\n property ColorHighlightShift: Integer read FColorHighlightShift write SetColorHighlightShift default 40;\r\n property ColorShadowShift: Integer read FColorShadowShift write SetColorShadowShift default 60;\r\n property BackgroundActive: TColor read FBackgroundActive write SetBackgroundActive default clBtnFace;\r\n end;\r\n\r\n TJvgLabelColors = class(TJvgCustomLabelColors)\r\n published\r\n property Text;\r\n property TextDisabled;\r\n property Delineate;\r\n property Shadow;\r\n property Highlight;\r\n property Background;\r\n property TextActive;\r\n property DelineateActive;\r\n property AutoHighlight;\r\n property AutoShadow;\r\n property ColorHighlightShift;\r\n property ColorShadowShift;\r\n property BackgroundActive;\r\n end;\r\n\r\n TJvgGroupBoxColors = class(TJvgCustomLabelColors)\r\n private\r\n FCaption: TColor;\r\n FCaptionActive: TColor;\r\n FClient: TColor;\r\n FClientActive: TColor;\r\n procedure SetCaption(Value: TColor);\r\n procedure SetCaptionActive(Value: TColor);\r\n procedure SetClient(Value: TColor);\r\n procedure SetClientActive(Value: TColor);\r\n public\r\n constructor Create; override;\r\n procedure Assign(Source: TPersistent); override;\r\n published\r\n property Text;\r\n property Delineate;\r\n property Shadow;\r\n property Highlight;\r\n // property Background;\r\n property TextActive;\r\n property DelineateActive;\r\n // property AutoHighlight;\r\n // property AutoShadow;\r\n // property ColorHighlightShift;\r\n // property ColorShadowShift;\r\n // property BackgroundActive;\r\n property Caption: TColor read FCaption write SetCaption;\r\n property CaptionActive: TColor read FCaptionActive write SetCaptionActive;\r\n property Client: TColor read FClient write SetClient;\r\n property ClientActive: TColor read FClientActive write SetClientActive;\r\n end;\r\n\r\n TJvgCustomListBoxItemStyle = class(TPersistent)\r\n private\r\n FColor: TColor;\r\n FDelineateColor: TColor;\r\n FFont: TFont;\r\n FBevel: TJvgBevelOptions;\r\n FTextStyle: TglTextStyle;\r\n FOnChanged: TNotifyEvent;\r\n procedure SetColor(Value: TColor);\r\n procedure SetDelineateColor(Value: TColor);\r\n procedure SetFont(Value: TFont);\r\n procedure SetBevel(Value: TJvgBevelOptions);\r\n procedure SetTextStyle(Value: TglTextStyle);\r\n protected\r\n procedure SetOnChanged(Value: TNotifyEvent); virtual;\r\n procedure Changed;\r\n public\r\n constructor Create; virtual;\r\n destructor Destroy; override;\r\n procedure Assign(Source: TPersistent); override;\r\n function HighlightColor: TColor;\r\n function ShadowColor: TColor;\r\n property OnChanged: TNotifyEvent read FOnChanged write SetOnChanged;\r\n property Color: TColor read FColor write SetColor;\r\n property DelineateColor: TColor read FDelineateColor write SetDelineateColor;\r\n property Font: TFont read FFont write SetFont;\r\n property Bevel: TJvgBevelOptions read FBevel write SetBevel;\r\n property TextStyle: TglTextStyle read FTextStyle write SetTextStyle;\r\n end;\r\n\r\n TJvgListBoxItemStyle = class(TJvgCustomListBoxItemStyle)\r\n private\r\n FGradient: TJvgGradient;\r\n FTextGradient: TJvgGradient;\r\n procedure SetGradient(Value: TJvgGradient);\r\n procedure SetTextGradient(Value: TJvgGradient);\r\n protected\r\n property TextGradient: TJvgGradient read FTextGradient write SetTextGradient;\r\n procedure SetOnChanged(Value: TNotifyEvent); override;\r\n public\r\n constructor Create; override;\r\n destructor Destroy; override;\r\n procedure Assign(Source: TPersistent); override;\r\n published\r\n property Gradient: TJvgGradient read FGradient write SetGradient;\r\n property Color;\r\n property DelineateColor;\r\n property Font;\r\n property Bevel;\r\n property TextStyle;\r\n end;\r\n\r\n TJvgHintStyle = class(TJvgListBoxItemStyle);\r\n\r\n TJvgSpeedButtonStyle = class(TJvgListBoxItemStyle)\r\n published\r\n property TextGradient;\r\n end;\r\n\r\n TJvgAskListBoxItemStyle = class(TJvgCustomListBoxItemStyle)\r\n private\r\n FBtnColor: TColor;\r\n FBtnFont: TFont;\r\n FBtnTextStyle: TglTextStyle;\r\n procedure SetBtnColor(Value: TColor);\r\n procedure SetBtnFont(Value: TFont);\r\n procedure SetBtnTextStyle(Value: TglTextStyle);\r\n public\r\n constructor Create; override;\r\n destructor Destroy; override;\r\n procedure Assign(Source: TPersistent); override;\r\n published\r\n property BtnColor: TColor read FBtnColor write SetBtnColor;\r\n property BtnFont: TFont read FBtnFont write SetBtnFont;\r\n property BtnTextStyle: TglTextStyle read FBtnTextStyle write SetBtnTextStyle;\r\n property Color;\r\n property DelineateColor;\r\n property Font;\r\n property Bevel;\r\n property TextStyle;\r\n end;\r\n\r\n TJvgCustomBoxStyle = class(TJvgBevelOptions)\r\n private\r\n FPenStyle: TPenStyle;\r\n FHighlightColor: TColor;\r\n FShadowColor: TColor;\r\n procedure SetPenStyle(Value: TPenStyle);\r\n procedure SetHighlightColor(Value: TColor);\r\n procedure SetShadowColor(Value: TColor);\r\n protected\r\n property PenStyle: TPenStyle read FPenStyle write SetPenStyle default psSolid;\r\n property HighlightColor: TColor read FHighlightColor write SetHighlightColor default clBtnHighlight;\r\n property ShadowColor: TColor read FShadowColor write SetShadowColor default clBtnShadow;\r\n public\r\n constructor Create; override;\r\n procedure Assign(Source: TPersistent); override;\r\n end;\r\n\r\n TJvgCustomTextBoxStyle = class(TJvgCustomBoxStyle)\r\n private\r\n FTextColor: TColor;\r\n FBackgroundColor: TColor;\r\n procedure SetTextColor(Value: TColor);\r\n procedure SetBackgroundColor(Value: TColor);\r\n protected\r\n property TextColor: TColor read FTextColor write SetTextColor default clBlack;\r\n property BackgroundColor: TColor read FBackgroundColor write SetBackgroundColor default clWindow;\r\n public\r\n constructor Create; override;\r\n procedure Assign(Source: TPersistent); override;\r\n end;\r\n\r\n TJvgTextBoxStyle = class(TJvgCustomTextBoxStyle)\r\n published\r\n property Inner;\r\n property Outer;\r\n property Sides;\r\n property Bold;\r\n property PenStyle;\r\n property TextColor;\r\n property BackgroundColor;\r\n property HighlightColor;\r\n property ShadowColor;\r\n end;\r\n\r\n TJvgBevelLines = class(TPersistent)\r\n private\r\n FCount: Cardinal;\r\n FStep: Cardinal;\r\n FOrigin: TglOrigin;\r\n FStyle: TPanelBevel;\r\n FBold: Boolean;\r\n FThickness: Byte;\r\n FIgnoreBorder: Boolean;\r\n FOnChanged: TNotifyEvent;\r\n procedure SetCount(Value: Cardinal);\r\n procedure SetStep(Value: Cardinal);\r\n procedure SetOrigin(Value: TglOrigin);\r\n procedure SetStyle(Value: TPanelBevel);\r\n procedure SetBold(Value: Boolean);\r\n procedure SetThickness(Value: Byte);\r\n procedure SetIgnoreBorder(Value: Boolean);\r\n protected\r\n procedure Changed; virtual;\r\n public\r\n constructor Create;\r\n procedure Assign(Source: TPersistent); override;\r\n property OnChanged: TNotifyEvent read FOnChanged write FOnChanged;\r\n published\r\n property Count: Cardinal read FCount write SetCount default 0;\r\n property Step: Cardinal read FStep write SetStep default 0;\r\n property Origin: TglOrigin read FOrigin write SetOrigin default forLeftTop;\r\n property Style: TPanelBevel read FStyle write SetStyle default bvLowered;\r\n property Bold: Boolean read FBold write SetBold default False;\r\n property Thickness: Byte read FThickness write SetThickness default 1;\r\n property IgnoreBorder: Boolean read FIgnoreBorder write SetIgnoreBorder default False;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvgCommClasses.pas $';\r\n Revision: '$Revision: 13104 $';\r\n Date: '$Date: 2011-09-07 08:50:43 +0200 (mer. 07 sept. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n Math,\r\n JvgUtils;\r\n\r\n//=== { TJvgTwainColors } ====================================================\r\n\r\nconstructor TJvgTwainColors.Create;\r\nbegin\r\n inherited Create;\r\n //...set defaults\r\n FFromColor := clGray;\r\n FRGBFromColor := ColorToRGB(FFromColor);\r\n FToColor := clBlack;\r\n FRGBToColor := ColorToRGB(FToColor);\r\nend;\r\n\r\nprocedure TJvgTwainColors.Assign(Source: TPersistent);\r\nvar\r\n Src: TJvgTwainColors;\r\nbegin\r\n if Source is TJvgTwainColors then\r\n begin\r\n if Source = Self then\r\n Exit;\r\n Src := TJvgTwainColors(Source);\r\n FromColor := Src.FromColor;\r\n ToColor := Src.ToColor;\r\n end\r\n else\r\n inherited Assign(Source);\r\nend;\r\n\r\nprocedure TJvgTwainColors.Changed;\r\nbegin\r\n if Assigned(FOnChanged) then\r\n FOnChanged(Self);\r\nend;\r\n\r\nprocedure TJvgTwainColors.SetFromColor(Value: TColor);\r\nbegin\r\n if FFromColor <> Value then\r\n begin\r\n FFromColor := Value;\r\n FRGBFromColor := ColorToRGB(Value);\r\n Changed;\r\n end;\r\nend;\r\n\r\nprocedure TJvgTwainColors.SetToColor(Value: TColor);\r\nbegin\r\n if FToColor <> Value then\r\n begin\r\n FToColor := Value;\r\n FRGBToColor := ColorToRGB(Value);\r\n Changed;\r\n end;\r\nend;\r\n\r\n//=== { TJvgCustomGradient } =================================================\r\n\r\nconstructor TJvgCustomGradient.Create;\r\nbegin\r\n inherited Create;\r\n //...set defaults\r\n FActive := False;\r\n FBufferedDraw := False;\r\n FOrientation := fgdHorizontal;\r\n FSteps := 255;\r\n FPercentFilling := 100;\r\n FBrushStyle := bsSolid;\r\nend;\r\n\r\nprocedure TJvgCustomGradient.Assign(Source: TPersistent);\r\nvar\r\n sourceGradient: TJvgCustomGradient;\r\nbegin\r\n // always call inherited, because TJvgTwainColors copies some data as well\r\n inherited Assign(Source);\r\n if Source is TJvgCustomGradient then\r\n begin\r\n if Source = Self then\r\n Exit;\r\n sourceGradient := TJvgCustomGradient(Source);\r\n FActive := sourceGradient.Active;\r\n FBufferedDraw := sourceGradient.BufferedDraw;\r\n FOrientation := sourceGradient.Orientation;\r\n FSteps := sourceGradient.Steps;\r\n FPercentFilling := sourceGradient.PercentFilling;\r\n FBrushStyle := sourceGradient.BrushStyle;\r\n Changed;\r\n end;\r\nend;\r\n\r\nprocedure TJvgCustomGradient.SetActive(Value: Boolean);\r\nbegin\r\n if FActive <> Value then\r\n begin\r\n FActive := Value;\r\n Changed;\r\n end;\r\nend;\r\n\r\nprocedure TJvgCustomGradient.SetOrientation(Value: TglGradientDir);\r\nbegin\r\n if FOrientation <> Value then\r\n begin\r\n FOrientation := Value;\r\n Changed;\r\n end;\r\nend;\r\n\r\nprocedure TJvgCustomGradient.SetSteps(Value: Integer);\r\nbegin\r\n if Value > 255 then\r\n Value := 255\r\n else\r\n if Value < 1 then\r\n Value := 1;\r\n if FSteps <> Value then\r\n begin\r\n FSteps := Value;\r\n Changed;\r\n end;\r\nend;\r\n\r\nprocedure TJvgCustomGradient.SetPercentFilling(Value: Integer);\r\nbegin\r\n if (FPercentFilling <> Value) and (Value >= 0) and (Value <= 100) then\r\n begin\r\n FPercentFilling := Value;\r\n Changed;\r\n end;\r\nend;\r\n\r\nprocedure TJvgCustomGradient.SetBrushStyle(Value: TBrushStyle);\r\nbegin\r\n if Value <> FBrushStyle then\r\n begin\r\n FBrushStyle := Value;\r\n Changed;\r\n end;\r\nend;\r\n\r\nfunction TJvgCustomGradient.GetColorFromGradientLine(GradientLineWidth, Position: Word): COLORREF;\r\nvar\r\n c1F, c2F, c3F: Byte;\r\n c1T, c2T, c3T: Byte;\r\n Step1, Step2, Step3: Single;\r\nbegin\r\n c1F := Byte(Self.FRGBFromColor);\r\n c2F := Byte(Word(Self.FRGBFromColor) shr 8);\r\n c3F := Byte(Self.FRGBFromColor shr 16);\r\n c1T := Byte(Self.FRGBToColor);\r\n c2T := Byte(Word(Self.FRGBToColor) shr 8);\r\n c3T := Byte(Self.FRGBToColor shr 16);\r\n\r\n Step1 := (c1T - c1F) / GradientLineWidth;\r\n Step2 := (c2T - c2F) / GradientLineWidth;\r\n Step3 := (c3T - c3F) / GradientLineWidth;\r\n\r\n Result := RGB(Trunc(c1F + Step1 * Position),\r\n Trunc(c2F + Step2 * Position),\r\n Trunc(c3F + Step3 * Position));\r\nend;\r\n\r\nprocedure TJvgCustomGradient.TextOut(DC: HDC; const Str: string; TextR: TRect; X, Y: Integer);\r\nvar\r\n I, Steps: Integer;\r\n r: TRect;\r\n c1F, c2F, c3F: Byte;\r\n c1T, c2T, c3T: Byte;\r\n c1, c2, c3: Single;\r\n Step1, Step2, Step3: Single;\r\n OldTextColor: TCOLORREF;\r\nbegin\r\n if (not Active) or (GetDeviceCaps(DC, BITSPIXEL) < 16) then\r\n begin\r\n Windows.TextOut(DC, X, Y, PChar(Str), Length(Str));\r\n Exit;\r\n end;\r\n r := TextR;\r\n c1F := Byte(FRGBFromColor);\r\n c2F := Byte(Word(FRGBFromColor) shr 8);\r\n c3F := Byte(FRGBFromColor shr 16);\r\n c1T := Byte(FRGBToColor);\r\n c2T := Byte(Word(FRGBToColor) shr 8);\r\n c3T := Byte(FRGBToColor shr 16);\r\n\r\n c1 := c1F;\r\n c2 := c2F;\r\n c3 := c3F;\r\n if FOrientation = fgdVertical then\r\n Steps := r.Right - r.Left\r\n else\r\n Steps := r.Bottom - r.Top;\r\n Step1 := (c1T - c1F) / Steps;\r\n Step2 := (c2T - c2F) / Steps;\r\n Step3 := (c3T - c3F) / Steps;\r\n\r\n OldTextColor := SetTextColor(DC, 0);\r\n Steps := MulDiv(Steps, PercentFilling, 100);\r\n for I := 0 to Steps do\r\n begin\r\n SetTextColor(DC, RGB(Trunc(c1), Trunc(c2), Trunc(c3)));\r\n\r\n if FOrientation = fgdVertical then\r\n begin\r\n r.Left := I;\r\n r.Right := r.Left + 1;\r\n end\r\n else\r\n begin\r\n r.Top := I;\r\n r.Bottom := r.Top + 1;\r\n end;\r\n\r\n Windows.ExtTextOut(DC, X, Y, ETO_CLIPPED, @r,\r\n PChar(Str), Length(Str), nil);\r\n c1 := c1 + Step1;\r\n c2 := c2 + Step2;\r\n c3 := c3 + Step3;\r\n end;\r\n SetTextColor(DC, OldTextColor);\r\nend;\r\n\r\n//=== { TJvg3DGradient } =====================================================\r\n\r\nconstructor TJvg3DGradient.Create;\r\nbegin\r\n inherited Create;\r\n Depth := 16;\r\n FGType := fgtFlat;\r\n FActive := True;\r\nend;\r\n\r\nprocedure TJvg3DGradient.Assign(Source: TPersistent);\r\nvar\r\n Src: TJvg3DGradient;\r\nbegin\r\n inherited Assign(Source);\r\n if Source is TJvg3DGradient then\r\n begin\r\n if Source = Self then\r\n Exit;\r\n Src := TJvg3DGradient(Source);\r\n FDepth := Src.Depth;\r\n FGType := Src.GType;\r\n Changed;\r\n end;\r\nend;\r\n\r\nprocedure TJvg3DGradient.SetGType(Value: TThreeDGradientType);\r\nbegin\r\n if FGType <> Value then\r\n begin\r\n FGType := Value;\r\n Changed;\r\n end;\r\nend;\r\n\r\nprocedure TJvg3DGradient.SetDepth(Value: Word);\r\nbegin\r\n if FDepth <> Value then\r\n begin\r\n FDepth := Value;\r\n Changed;\r\n end;\r\nend;\r\n\r\n//=== { TJvg2DAlign } ========================================================\r\n\r\nconstructor TJvg2DAlign.Create;\r\nbegin\r\n inherited Create;\r\n //...set defaults\r\n FHorizontal := fhaLeft;\r\n FVertical := fvaTop;\r\nend;\r\n\r\nprocedure TJvg2DAlign.Assign(Source: TPersistent);\r\nvar\r\n Src: TJvg2DAlign;\r\nbegin\r\n if Source is TJvg2DAlign then\r\n begin\r\n if Source = Self then\r\n Exit;\r\n Src := TJvg2DAlign(Source);\r\n FHorizontal := Src.Horizontal;\r\n FVertical := Src.Vertical;\r\n Changed;\r\n end\r\n else\r\n inherited Assign(Source);\r\nend;\r\n\r\nprocedure TJvg2DAlign.Changed;\r\nbegin\r\n if Assigned(FOnChanged) then\r\n FOnChanged(Self);\r\nend;\r\n\r\nprocedure TJvg2DAlign.SetHorizontal(Value: TglHorAlign);\r\nbegin\r\n if FHorizontal <> Value then\r\n begin\r\n FHorizontal := Value;\r\n Changed;\r\n end;\r\nend;\r\n\r\nprocedure TJvg2DAlign.SetVertical(Value: TglVertAlign);\r\nbegin\r\n if FVertical <> Value then\r\n begin\r\n FVertical := Value;\r\n Changed;\r\n end;\r\nend;\r\n\r\n//=== { TJvgPointClass } =====================================================\r\n\r\nprocedure TJvgPointClass.Assign(Source: TPersistent);\r\nvar\r\n Src: TJvgPointClass;\r\nbegin\r\n if Source is TJvgPointClass then\r\n begin\r\n if Source = Self then\r\n Exit;\r\n Src := TJvgPointClass(Source);\r\n FX := Src.X;\r\n FY := Src.Y;\r\n Changed;\r\n end\r\n else\r\n inherited Assign(Source);\r\nend;\r\n\r\nprocedure TJvgPointClass.Changed;\r\nbegin\r\n if Assigned(FOnChanged) then\r\n FOnChanged(Self);\r\nend;\r\n\r\nprocedure TJvgPointClass.SetX(Value: Integer);\r\nbegin\r\n if FX <> Value then\r\n begin\r\n FX := Value;\r\n Changed;\r\n end;\r\nend;\r\n\r\nprocedure TJvgPointClass.SetY(Value: Integer);\r\nbegin\r\n if FY <> Value then\r\n begin\r\n FY := Value;\r\n Changed;\r\n end;\r\nend;\r\n\r\n//=== { TJvgBevelOptions } ===================================================\r\n\r\nconstructor TJvgBevelOptions.Create;\r\nbegin\r\n inherited Create;\r\n FSides := ALLGLSIDES;\r\nend;\r\n\r\nprocedure TJvgBevelOptions.Assign(Source: TPersistent);\r\nvar\r\n Src: TJvgBevelOptions;\r\nbegin\r\n if Source is TJvgBevelOptions then\r\n begin\r\n if Source = Self then\r\n Exit;\r\n Src := TJvgBevelOptions(Source);\r\n FInner := Src.Inner;\r\n FOuter := Src.Outer;\r\n FSides := Src.Sides;\r\n FBold := Src.Bold;\r\n Changed;\r\n end\r\n else\r\n inherited Assign(Source);\r\nend;\r\n\r\nprocedure TJvgBevelOptions.Changed;\r\nbegin\r\n if Assigned(FOnChanged) then\r\n FOnChanged(Self);\r\nend;\r\n\r\nprocedure TJvgBevelOptions.SetOuter(Value: TPanelBevel);\r\nbegin\r\n if FOuter <> Value then\r\n begin\r\n FOuter := Value;\r\n Changed;\r\n end;\r\nend;\r\n\r\nprocedure TJvgBevelOptions.SetInner(Value: TPanelBevel);\r\nbegin\r\n if FInner <> Value then\r\n begin\r\n FInner := Value;\r\n Changed;\r\n end;\r\nend;\r\n\r\nprocedure TJvgBevelOptions.SetSides(Value: TglSides);\r\nbegin\r\n if FSides <> Value then\r\n begin\r\n FSides := Value;\r\n Changed;\r\n end;\r\nend;\r\n\r\nprocedure TJvgBevelOptions.SetBold(Value: Boolean);\r\nbegin\r\n if FBold <> Value then\r\n begin\r\n FBold := Value;\r\n Changed;\r\n end;\r\nend;\r\n\r\nfunction TJvgBevelOptions.BordersHeight: Integer;\r\nbegin\r\n Result := 0;\r\n if Inner <> bvNone then\r\n begin\r\n if fsdTop in Sides then\r\n Inc(Result);\r\n if fsdBottom in Sides then\r\n if Bold then\r\n Inc(Result, 1)\r\n else\r\n Inc(Result);\r\n end;\r\n if Outer <> bvNone then\r\n begin\r\n if fsdTop in Sides then\r\n Inc(Result);\r\n if fsdBottom in Sides then\r\n if Bold then\r\n Inc(Result, 1)\r\n else\r\n Inc(Result);\r\n end;\r\nend;\r\n\r\nfunction TJvgBevelOptions.BordersWidth: Integer;\r\nbegin\r\n Result := 0;\r\n if Inner <> bvNone then\r\n begin\r\n if fsdLeft in Sides then\r\n Inc(Result);\r\n if fsdRight in Sides then\r\n if Bold then\r\n Inc(Result, 1)\r\n else\r\n Inc(Result);\r\n end;\r\n if Outer <> bvNone then\r\n begin\r\n if fsdLeft in Sides then\r\n Inc(Result);\r\n if fsdRight in Sides then\r\n if Bold then\r\n Inc(Result, 1)\r\n else\r\n Inc(Result);\r\n end;\r\nend;\r\n\r\n//=== { TJvgIllumination } ===================================================\r\n\r\nconstructor TJvgIllumination.Create;\r\nbegin\r\n inherited Create;\r\n FShadowDepth := 2;\r\nend;\r\n\r\nprocedure TJvgIllumination.Assign(Source: TPersistent);\r\nvar\r\n Src: TJvgIllumination;\r\nbegin\r\n inherited Assign(Source);\r\n if Source is TJvgIllumination then\r\n begin\r\n if Source = Self then\r\n Exit;\r\n Src := TJvgIllumination(Source);\r\n FShadowDepth := Src.ShadowDepth;\r\n Changed;\r\n end;\r\nend;\r\n\r\nprocedure TJvgIllumination.SetShadowDepth(Value: Integer);\r\nbegin\r\n if Value < 0 then\r\n Value := 0;\r\n if FShadowDepth <> Value then\r\n begin\r\n FShadowDepth := Value;\r\n Changed;\r\n end;\r\nend;\r\n\r\n//=== { TJvgLabelTextStyles } ================================================\r\n\r\nconstructor TJvgLabelTextStyles.Create;\r\nbegin\r\n inherited Create;\r\n FActive := fstRaised;\r\n FPassive := fstRaised;\r\n FDisabled := fstPushed;\r\nend;\r\n\r\nprocedure TJvgLabelTextStyles.Assign(Source: TPersistent);\r\nvar\r\n Src: TJvgLabelTextStyles;\r\nbegin\r\n if Source is TJvgLabelTextStyles then\r\n begin\r\n if Source = Self then\r\n Exit;\r\n Src := TJvgLabelTextStyles(Source);\r\n FPassive := Src.Passive;\r\n FActive := Src.Active;\r\n FDisabled := Src.Disabled;\r\n Changed;\r\n end\r\n else\r\n inherited Assign(Source);\r\nend;\r\n\r\nprocedure TJvgLabelTextStyles.Changed;\r\nbegin\r\n if Assigned(FOnChanged) then\r\n FOnChanged(Self);\r\nend;\r\n\r\nprocedure TJvgLabelTextStyles.SetPassive(Value: TglTextStyle);\r\nbegin\r\n if FPassive <> Value then\r\n begin\r\n FPassive := Value;\r\n Changed;\r\n end;\r\nend;\r\n\r\nprocedure TJvgLabelTextStyles.SetActive(Value: TglTextStyle);\r\nbegin\r\n if FActive <> Value then\r\n begin\r\n FActive := Value;\r\n Changed;\r\n end;\r\nend;\r\n\r\nprocedure TJvgLabelTextStyles.SetDisabled(Value: TglTextStyle);\r\nbegin\r\n if FDisabled <> Value then\r\n begin\r\n FDisabled := Value;\r\n Changed;\r\n end;\r\nend;\r\n\r\n//=== { TJvgCustomTextColors } ===============================================\r\n\r\nconstructor TJvgCustomTextColors.Create;\r\nbegin\r\n inherited Create;\r\n FText := clBlack;\r\n FTextDisabled := clGray;\r\n FDelineate := clWhite;\r\n FHighlight := clBtnHighlight;\r\n FShadow := clBtnShadow;\r\n FBackground := clBtnFace;\r\nend;\r\n\r\nprocedure TJvgCustomTextColors.Assign(Source: TPersistent);\r\nvar\r\n Src: TJvgCustomTextColors;\r\nbegin\r\n if Source is TJvgCustomTextColors then\r\n begin\r\n if Source = Self then\r\n Exit;\r\n Src := TJvgCustomTextColors(Source);\r\n FText := Src.Text;\r\n FTextDisabled := Src.TextDisabled;\r\n FDelineate := Src.Delineate;\r\n FShadow := Src.Shadow;\r\n FHighlight := Src.Highlight;\r\n FBackground := Src.Background;\r\n Changed;\r\n end\r\n else\r\n inherited Assign(Source);\r\nend;\r\n\r\nprocedure TJvgCustomTextColors.Changed;\r\nbegin\r\n if Assigned(FOnChanged) then\r\n FOnChanged(Self);\r\nend;\r\n\r\nprocedure TJvgCustomTextColors.SetText(Value: TColor);\r\nbegin\r\n if FText <> Value then\r\n begin\r\n FText := Value;\r\n Changed;\r\n end;\r\nend;\r\n\r\nprocedure TJvgCustomTextColors.SetTextDisabled(Value: TColor);\r\nbegin\r\n if FTextDisabled <> Value then\r\n begin\r\n FTextDisabled := Value;\r\n Changed;\r\n end;\r\nend;\r\n\r\nprocedure TJvgCustomTextColors.SetDelineate(Value: TColor);\r\nbegin\r\n if FDelineate <> Value then\r\n begin\r\n FDelineate := Value;\r\n Changed;\r\n end;\r\nend;\r\n\r\nprocedure TJvgCustomTextColors.SetHighlight(Value: TColor);\r\nbegin\r\n if FHighlight <> Value then\r\n begin\r\n FHighlight := Value;\r\n Changed;\r\n end;\r\nend;\r\n\r\nprocedure TJvgCustomTextColors.SetShadow(Value: TColor);\r\nbegin\r\n if FShadow <> Value then\r\n begin\r\n FShadow := Value;\r\n Changed;\r\n end;\r\nend;\r\n\r\nprocedure TJvgCustomTextColors.SetBackground(Value: TColor);\r\nbegin\r\n if FBackground <> Value then\r\n begin\r\n FBackground := Value;\r\n Changed;\r\n end;\r\nend;\r\n\r\n//=== { TJvgCustomLabelColors } ==============================================\r\n\r\nconstructor TJvgCustomLabelColors.Create;\r\nbegin\r\n inherited Create;\r\n FTextActive := clBlack;\r\n FDelineateActive := clWhite;\r\n FAutoHighlight := False;\r\n FAutoShadow := False;\r\n FColorHighlightShift := 40;\r\n FColorShadowShift := 60;\r\n FBackgroundActive := clBtnFace;\r\nend;\r\n\r\nprocedure TJvgCustomLabelColors.Assign(Source: TPersistent);\r\nvar\r\n Src: TJvgCustomLabelColors;\r\nbegin\r\n inherited Assign(Source);\r\n if Source is TJvgCustomLabelColors then\r\n begin\r\n if Source = Self then\r\n Exit;\r\n Src := TJvgCustomLabelColors(Source);\r\n FTextActive := Src.TextActive;\r\n FDelineateActive := Src.DelineateActive;\r\n FAutoHighlight := Src.AutoHighlight;\r\n FAutoShadow := Src.AutoShadow;\r\n FColorHighlightShift := Src.ColorHighlightShift;\r\n FColorShadowShift := Src.ColorShadowShift;\r\n FBackgroundActive := Src.BackgroundActive;\r\n Changed;\r\n end;\r\nend;\r\n\r\nprocedure TJvgCustomLabelColors.SetTextActive(Value: TColor);\r\nbegin\r\n if FTextActive <> Value then\r\n begin\r\n FTextActive := Value;\r\n Changed;\r\n end;\r\nend;\r\n\r\nprocedure TJvgCustomLabelColors.SetDelineateActive(Value: TColor);\r\nbegin\r\n if FDelineateActive <> Value then\r\n begin\r\n FDelineateActive := Value;\r\n Changed;\r\n end;\r\nend;\r\n\r\nprocedure TJvgCustomLabelColors.SetAutoHighlight(Value: Boolean);\r\nbegin\r\n if FAutoHighlight <> Value then\r\n begin\r\n FAutoHighlight := Value;\r\n Changed;\r\n end;\r\nend;\r\n\r\nprocedure TJvgCustomLabelColors.SetAutoShadow(Value: Boolean);\r\nbegin\r\n if FAutoShadow <> Value then\r\n begin\r\n FAutoShadow := Value;\r\n Changed;\r\n end;\r\nend;\r\n\r\nprocedure TJvgCustomLabelColors.SetColorHighlightShift(Value: Integer);\r\nbegin\r\n if FColorHighlightShift <> Value then\r\n begin\r\n FColorHighlightShift := Value;\r\n Changed;\r\n end;\r\nend;\r\n\r\nprocedure TJvgCustomLabelColors.SetColorShadowShift(Value: Integer);\r\nbegin\r\n if FColorShadowShift <> Value then\r\n begin\r\n FColorShadowShift := Value;\r\n Changed;\r\n end;\r\nend;\r\n\r\nprocedure TJvgCustomLabelColors.SetBackgroundActive(Value: TColor);\r\nbegin\r\n if FBackgroundActive <> Value then\r\n begin\r\n FBackgroundActive := Value;\r\n Changed;\r\n end;\r\nend;\r\n\r\n//=== { TJvgGroupBoxColors } =================================================\r\n\r\nconstructor TJvgGroupBoxColors.Create;\r\nbegin\r\n inherited Create;\r\n FCaption := clBtnFace;\r\n FCaptionActive := clBtnFace;\r\n FClient := clBtnFace;\r\n FClientActive := clBtnFace;\r\nend;\r\n\r\nprocedure TJvgGroupBoxColors.Assign(Source: TPersistent);\r\nvar\r\n Src: TJvgGroupBoxColors;\r\nbegin\r\n inherited Assign(Source);\r\n if Source is TJvgGroupBoxColors then\r\n begin\r\n if Source = Self then\r\n Exit;\r\n Src := TJvgGroupBoxColors(Source);\r\n FCaption := Src.Caption;\r\n FCaptionActive := Src.CaptionActive;\r\n FClient := Src.Client;\r\n FClientActive := Src.ClientActive;\r\n Changed;\r\n end;\r\nend;\r\n\r\nprocedure TJvgGroupBoxColors.SetCaption(Value: TColor);\r\nbegin\r\n if Value <> FCaption then\r\n begin\r\n FCaption := Value;\r\n Changed;\r\n end;\r\nend;\r\n\r\nprocedure TJvgGroupBoxColors.SetCaptionActive(Value: TColor);\r\nbegin\r\n if Value <> FCaptionActive then\r\n begin\r\n FCaptionActive := Value;\r\n Changed;\r\n end;\r\nend;\r\n\r\nprocedure TJvgGroupBoxColors.SetClient(Value: TColor);\r\nbegin\r\n if Value <> FClient then\r\n begin\r\n FClient := Value;\r\n Changed;\r\n end;\r\nend;\r\n\r\nprocedure TJvgGroupBoxColors.SetClientActive(Value: TColor);\r\nbegin\r\n if Value <> FClientActive then\r\n begin\r\n FClientActive := Value;\r\n Changed;\r\n end;\r\nend;\r\n\r\n//=== { TJvgExtBevelOptions } ================================================\r\n\r\nconstructor TJvgExtBevelOptions.Create;\r\nbegin\r\n inherited Create;\r\n FActive := True;\r\n FBevelPenStyle := psSolid;\r\n FBevelPenWidth := 1;\r\nend;\r\n\r\nprocedure TJvgExtBevelOptions.Assign(Source: TPersistent);\r\nvar\r\n Src: TJvgExtBevelOptions;\r\nbegin\r\n inherited Assign(Source);\r\n if Source is TJvgExtBevelOptions then\r\n begin\r\n if Source = Self then\r\n Exit;\r\n Src := TJvgExtBevelOptions(Source);\r\n FActive := Src.Active;\r\n FBevelPenStyle := Src.BevelPenStyle;\r\n FBevelPenWidth := Src.BevelPenWidth;\r\n FInteriorOffset := Src.InteriorOffset;\r\n Changed;\r\n end;\r\nend;\r\n\r\nprocedure TJvgExtBevelOptions.SetActive(Value: Boolean);\r\nbegin\r\n if FActive <> Value then\r\n begin\r\n FActive := Value;\r\n Changed;\r\n end;\r\nend;\r\n\r\nprocedure TJvgExtBevelOptions.SetBevelPenStyle(Value: TPenStyle);\r\nbegin\r\n if FBevelPenStyle <> Value then\r\n begin\r\n FBevelPenStyle := Value;\r\n Changed;\r\n end;\r\nend;\r\n\r\nprocedure TJvgExtBevelOptions.SetBevelPenWidth(Value: Word);\r\nbegin\r\n if FBevelPenWidth <> Value then\r\n begin\r\n FBevelPenWidth := Value;\r\n Changed;\r\n end;\r\nend;\r\n\r\nprocedure TJvgExtBevelOptions.SetInteriorOffset(Value: Word);\r\nbegin\r\n if FInteriorOffset <> Value then\r\n begin\r\n FInteriorOffset := Value;\r\n Changed;\r\n end;\r\nend;\r\n\r\n//=== { TJvgCustomListBoxItemStyle } =========================================\r\n\r\nconstructor TJvgCustomListBoxItemStyle.Create;\r\nbegin\r\n inherited Create;\r\n FBevel := TJvgBevelOptions.Create;\r\n FFont := TFont.Create;\r\nend;\r\n\r\ndestructor TJvgCustomListBoxItemStyle.Destroy;\r\nbegin\r\n FFont.Free;\r\n FBevel.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvgCustomListBoxItemStyle.Assign(Source: TPersistent);\r\nvar\r\n Src: TJvgCustomListBoxItemStyle;\r\nbegin\r\n if Source is TJvgCustomListBoxItemStyle then\r\n begin\r\n if Source = Self then\r\n Exit;\r\n Src := TJvgCustomListBoxItemStyle(Source);\r\n FColor := Src.Color;\r\n FDelineateColor := Src.DelineateColor;\r\n FTextStyle := Src.TextStyle;\r\n Font := Src.Font;\r\n Bevel := Src.Bevel; // invokes OnChanged\r\n end\r\n else\r\n inherited Assign(Source);\r\nend;\r\n\r\nprocedure TJvgCustomListBoxItemStyle.SetOnChanged(Value: TNotifyEvent);\r\nbegin\r\n FOnChanged := Value;\r\n FBevel.OnChanged := Value;\r\nend;\r\n\r\nprocedure TJvgCustomListBoxItemStyle.Changed;\r\nbegin\r\n if Assigned(FOnChanged) then\r\n FOnChanged(Self);\r\nend;\r\n\r\nprocedure TJvgCustomListBoxItemStyle.SetColor(Value: TColor);\r\nbegin\r\n if FColor <> Value then\r\n begin\r\n FColor := Value;\r\n Changed;\r\n end;\r\nend;\r\n\r\nprocedure TJvgCustomListBoxItemStyle.SetDelineateColor(Value: TColor);\r\nbegin\r\n if FDelineateColor <> Value then\r\n begin\r\n FDelineateColor := Value;\r\n Changed;\r\n end;\r\nend;\r\n\r\nprocedure TJvgCustomListBoxItemStyle.SetFont(Value: TFont);\r\nbegin\r\n if Value <> FFont then\r\n begin\r\n FFont.Assign(Value);\r\n Changed;\r\n end;\r\nend;\r\n\r\nprocedure TJvgCustomListBoxItemStyle.SetBevel(Value: TJvgBevelOptions);\r\nbegin\r\n FBevel.Assign(Value);\r\nend;\r\n\r\nprocedure TJvgCustomListBoxItemStyle.SetTextStyle(Value: TglTextStyle);\r\nbegin\r\n if Value <> FTextStyle then\r\n begin\r\n FTextStyle := Value;\r\n Changed;\r\n end;\r\nend;\r\n\r\nfunction TJvgCustomListBoxItemStyle.HighlightColor: TColor;\r\nbegin\r\n Result := IncColor(Color, 60);\r\nend;\r\n\r\nfunction TJvgCustomListBoxItemStyle.ShadowColor: TColor;\r\nbegin\r\n Result := DecColor(Color, 60);\r\nend;\r\n\r\n//=== { TJvgListBoxItemStyle } ===============================================\r\n\r\nconstructor TJvgListBoxItemStyle.Create;\r\nbegin\r\n inherited Create;\r\n FGradient := TJvgGradient.Create;\r\n FTextGradient := TJvgGradient.Create;\r\nend;\r\n\r\ndestructor TJvgListBoxItemStyle.Destroy;\r\nbegin\r\n FGradient.Free;\r\n FTextGradient.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvgListBoxItemStyle.Assign(Source: TPersistent);\r\nvar\r\n Src: TJvgListBoxItemStyle;\r\nbegin\r\n inherited Assign(Source);\r\n if Source is TJvgListBoxItemStyle then\r\n begin\r\n if Source = Self then\r\n Exit;\r\n Src := TJvgListBoxItemStyle(Source);\r\n TextGradient := Src.TextGradient;\r\n Gradient := Src.Gradient;\r\n end\r\nend;\r\n\r\nprocedure TJvgListBoxItemStyle.SetOnChanged(Value: TNotifyEvent);\r\nbegin\r\n inherited SetOnChanged(Value);\r\n FGradient.OnChanged := Value;\r\n FTextGradient.OnChanged := Value;\r\nend;\r\n\r\nprocedure TJvgListBoxItemStyle.SetGradient(Value: TJvgGradient);\r\nbegin\r\n FGradient.Assign(Value);\r\nend;\r\n\r\nprocedure TJvgListBoxItemStyle.SetTextGradient(Value: TJvgGradient);\r\nbegin\r\n FTextGradient.Assign(Value);\r\nend;\r\n\r\n//=== { TJvgAskListBoxItemStyle } ============================================\r\n\r\nconstructor TJvgAskListBoxItemStyle.Create;\r\nbegin\r\n inherited Create;\r\n FBtnFont := TFont.Create;\r\nend;\r\n\r\ndestructor TJvgAskListBoxItemStyle.Destroy;\r\nbegin\r\n FBtnFont.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvgAskListBoxItemStyle.Assign(Source: TPersistent);\r\nvar\r\n Src: TJvgAskListBoxItemStyle;\r\nbegin\r\n inherited Assign(Source);\r\n if Source is TJvgAskListBoxItemStyle then\r\n begin\r\n if Source = Self then\r\n Exit;\r\n Src := TJvgAskListBoxItemStyle(Source);\r\n FBtnColor := Src.BtnColor;\r\n FBtnTextStyle := Src.BtnTextStyle;\r\n BtnFont := Src.BtnFont; // calls Changed\r\n end;\r\nend;\r\n\r\nprocedure TJvgAskListBoxItemStyle.SetBtnColor(Value: TColor);\r\nbegin\r\n if FBtnColor <> Value then\r\n begin\r\n FBtnColor := Value;\r\n Changed;\r\n end;\r\nend;\r\n\r\nprocedure TJvgAskListBoxItemStyle.SetBtnFont(Value: TFont);\r\nbegin\r\n if Value <> FBtnFont then\r\n begin\r\n FBtnFont.Assign(Value);\r\n Changed;\r\n end;\r\nend;\r\n\r\nprocedure TJvgAskListBoxItemStyle.SetBtnTextStyle(Value: TglTextStyle);\r\nbegin\r\n if Value <> FBtnTextStyle then\r\n begin\r\n FBtnTextStyle := Value;\r\n Changed;\r\n end;\r\nend;\r\n\r\n//=== { TJvgCustomBoxStyle } =================================================\r\n\r\nconstructor TJvgCustomBoxStyle.Create;\r\nbegin\r\n inherited Create;\r\n FPenStyle := psSolid;\r\n FHighlightColor := clBtnHighlight;\r\n FShadowColor := clBtnShadow;\r\nend;\r\n\r\nprocedure TJvgCustomBoxStyle.Assign(Source: TPersistent);\r\nvar\r\n Src: TJvgCustomBoxStyle;\r\nbegin\r\n inherited Assign(Source);\r\n if Source is TJvgCustomBoxStyle then\r\n begin\r\n if Source = Self then\r\n Exit;\r\n Src := TJvgCustomBoxStyle(Source);\r\n FPenStyle := Src.PenStyle;\r\n FHighlightColor := Src.HighlightColor;\r\n FShadowColor := Src.ShadowColor;\r\n Changed;\r\n end;\r\nend;\r\n\r\nprocedure TJvgCustomBoxStyle.SetPenStyle(Value: TPenStyle);\r\nbegin\r\n if Value <> FPenStyle then\r\n begin\r\n FPenStyle := Value;\r\n Changed;\r\n end;\r\nend;\r\n\r\nprocedure TJvgCustomBoxStyle.SetHighlightColor(Value: TColor);\r\nbegin\r\n if Value <> FHighlightColor then\r\n begin\r\n FHighlightColor := Value;\r\n Changed;\r\n end;\r\nend;\r\n\r\nprocedure TJvgCustomBoxStyle.SetShadowColor(Value: TColor);\r\nbegin\r\n if Value <> FShadowColor then\r\n begin\r\n FShadowColor := Value;\r\n Changed;\r\n end;\r\nend;\r\n\r\n//=== { TJvgCustomTextBoxStyle } =============================================\r\n\r\nconstructor TJvgCustomTextBoxStyle.Create;\r\nbegin\r\n inherited Create;\r\n FTextColor := clBlack;\r\n FBackgroundColor := clWindow;\r\nend;\r\n\r\nprocedure TJvgCustomTextBoxStyle.Assign(Source: TPersistent);\r\nvar\r\n Src: TJvgCustomTextBoxStyle;\r\nbegin\r\n inherited Assign(Source);\r\n if Source is TJvgCustomTextBoxStyle then\r\n begin\r\n if Source = Self then\r\n Exit;\r\n Src := TJvgCustomTextBoxStyle(Source);\r\n FTextColor := Src.TextColor;\r\n FBackgroundColor := Src.BackgroundColor;\r\n Changed;\r\n end;\r\nend;\r\n\r\nprocedure TJvgCustomTextBoxStyle.SetTextColor(Value: TColor);\r\nbegin\r\n if Value <> FTextColor then\r\n begin\r\n FTextColor := Value;\r\n Changed;\r\n end;\r\nend;\r\n\r\nprocedure TJvgCustomTextBoxStyle.SetBackgroundColor(Value: TColor);\r\nbegin\r\n if Value <> FBackgroundColor then\r\n begin\r\n FBackgroundColor := Value;\r\n Changed;\r\n end;\r\nend;\r\n\r\n//=== { TJvgBevelLines } =====================================================\r\n\r\nconstructor TJvgBevelLines.Create;\r\nbegin\r\n inherited Create;\r\n FStyle := bvLowered;\r\n FThickness := 1;\r\nend;\r\n\r\nprocedure TJvgBevelLines.Assign(Source: TPersistent);\r\nvar\r\n Src: TJvgBevelLines;\r\nbegin\r\n if Source is TJvgBevelLines then\r\n begin\r\n if Source = Self then\r\n Exit;\r\n Src := TJvgBevelLines(Source);\r\n FCount := Src.Count;\r\n FStep := Src.Step;\r\n FOrigin := Src.Origin;\r\n FStyle := Src.Style;\r\n FBold := Src.Bold;\r\n FThickness := Src.Thickness;\r\n FIgnoreBorder := Src.IgnoreBorder;\r\n Changed;\r\n end\r\n else\r\n inherited Assign(Source);\r\nend;\r\n\r\nprocedure TJvgBevelLines.Changed;\r\nbegin\r\n if Assigned(FOnChanged) then\r\n FOnChanged(Self);\r\nend;\r\n\r\nprocedure TJvgBevelLines.SetCount(Value: Cardinal);\r\nbegin\r\n if Value <> FCount then\r\n begin\r\n FCount := Value;\r\n Changed;\r\n end;\r\nend;\r\n\r\nprocedure TJvgBevelLines.SetStep(Value: Cardinal);\r\nbegin\r\n if Value <> FStep then\r\n begin\r\n FStep := Value;\r\n Changed;\r\n end;\r\nend;\r\n\r\nprocedure TJvgBevelLines.SetOrigin(Value: TglOrigin);\r\nbegin\r\n if Value <> FOrigin then\r\n begin\r\n FOrigin := Value;\r\n Changed;\r\n end;\r\nend;\r\n\r\nprocedure TJvgBevelLines.SetStyle(Value: TPanelBevel);\r\nbegin\r\n if Value <> FStyle then\r\n begin\r\n FStyle := Value;\r\n Changed;\r\n end;\r\nend;\r\n\r\nprocedure TJvgBevelLines.SetBold(Value: Boolean);\r\nbegin\r\n if Value <> FBold then\r\n begin\r\n FBold := Value;\r\n Changed;\r\n end;\r\nend;\r\n\r\nprocedure TJvgBevelLines.SetThickness(Value: Byte);\r\nbegin\r\n if Value <> FThickness then\r\n begin\r\n FThickness := Value;\r\n Changed;\r\n end;\r\nend;\r\n\r\nprocedure TJvgBevelLines.SetIgnoreBorder(Value: Boolean);\r\nbegin\r\n if Value <> FIgnoreBorder then\r\n begin\r\n FIgnoreBorder := Value;\r\n Changed;\r\n end;\r\nend;\r\n\r\n//=== { TJvgGradient } =======================================================\r\n\r\n// { paints the gradient; }\r\n\r\nprocedure TJvgGradient.Draw(DC: HDC; r: TRect; PenStyle, PenWidth: Integer);\r\nvar\r\n I, J, X, Y, x2, y2, h, w, NumberOfColors: Integer;\r\n c1F, c2F, c3F: Byte;\r\n c1T, c2T, c3T: Byte;\r\n c1D, c2D, c3D: Integer;\r\n _R, _G, _B: Byte;\r\n Pen, OldPen: HPen;\r\n FillBrush: HBRUSH;\r\n BufferBmp, OldBMP: HBITMAP;\r\n BufferDC, TargetDC: HDC;\r\n ColorR: TRect;\r\n LOGBRUSH: TLOGBRUSH;\r\n\r\n procedure SwapColors;\r\n var\r\n TempColor: Longint;\r\n begin\r\n TempColor := FRGBFromColor;\r\n FRGBFromColor := FRGBToColor;\r\n FRGBToColor := TempColor;\r\n end;\r\n\r\nbegin\r\n if (not Active) or glGlobalData.fSuppressGradient then\r\n Exit;\r\n if (Steps = 1) or (GetDeviceCaps(DC, BITSPIXEL) < 16) then\r\n begin\r\n Exit;\r\n FillBrush := CreateSolidBrush(ColorToRGB(FromColor));\r\n FillRect(DC, r, FillBrush);\r\n DeleteObject(FillBrush);\r\n Exit;\r\n end;\r\n X := r.Left;\r\n Y := r.Top;\r\n h := r.Bottom - r.Top;\r\n w := r.Right - r.Left;\r\n x2 := 0;\r\n y2 := 0;\r\n Pen := 0;\r\n OldPen := 0;\r\n BufferDC := 0;\r\n\r\n if Orientation = fgdHorzConvergent then\r\n begin\r\n FOrientation := fgdHorizontal;\r\n Draw(DC, Rect(r.Left, r.Top, r.Right, r.Bottom - h div 2), PenStyle, PenWidth);\r\n SwapColors;\r\n Draw(DC, Rect(r.Left, r.Top + h div 2, r.Right, r.Bottom), PenStyle, PenWidth);\r\n SwapColors;\r\n FOrientation := fgdHorzConvergent;\r\n Exit;\r\n end;\r\n if Orientation = fgdVertConvergent then\r\n begin\r\n FOrientation := fgdVertical;\r\n Draw(DC, Rect(r.Left, r.Top, r.Right - w div 2, r.Bottom), PenStyle, PenWidth);\r\n SwapColors;\r\n Draw(DC, Rect(r.Left + w div 2, r.Top, r.Right, r.Bottom), PenStyle, PenWidth);\r\n SwapColors;\r\n FOrientation := fgdVertConvergent;\r\n Exit;\r\n end;\r\n\r\n //...r._ data no more useful\r\n c1F := Byte(FRGBFromColor);\r\n c2F := Byte(Word(FRGBFromColor) shr 8);\r\n c3F := Byte(FRGBFromColor shr 16);\r\n c1T := Byte(FRGBToColor);\r\n c2T := Byte(Word(FRGBToColor) shr 8);\r\n c3T := Byte(FRGBToColor shr 16);\r\n c1D := c1T - c1F;\r\n c2D := c2T - c2F;\r\n c3D := c3T - c3F;\r\n\r\n OldBMP := 0;\r\n if BufferedDraw then\r\n begin\r\n BufferDC := CreateCompatibleDC(DC);\r\n BufferBmp := CreateBitmap(w, h, GetDeviceCaps(DC, Planes), GetDeviceCaps(DC, BITSPIXEL), nil);\r\n OldBMP := SelectObject(BufferDC, BufferBmp);\r\n SetMapMode(BufferDC, GetMapMode(DC));\r\n TargetDC := BufferDC;\r\n end\r\n else\r\n TargetDC := DC;\r\n\r\n case Orientation of\r\n fgdHorizontal:\r\n begin\r\n NumberOfColors := Min(Steps, h);\r\n ColorR.Left := r.Left;\r\n ColorR.Right := r.Right;\r\n end;\r\n fgdVertical:\r\n begin\r\n NumberOfColors := Min(Steps, w);\r\n ColorR.Top := r.Top;\r\n ColorR.Bottom := r.Bottom;\r\n end;\r\n fgdLeftBias, fgdRightBias:\r\n begin\r\n NumberOfColors := Min(Steps, w + h);\r\n if PenStyle = 0 then\r\n PenStyle := PS_SOLID;\r\n if PenWidth = 0 then\r\n PenWidth := 1;\r\n Pen := CreatePen(PenStyle, PenWidth, 0);\r\n OldPen := SelectObject(TargetDC, Pen);\r\n y2 := Y;\r\n if Orientation = fgdLeftBias then\r\n x2 := X\r\n else\r\n begin\r\n X := r.Right;\r\n x2 := r.Right;\r\n end;\r\n end;\r\n else {fgdRectangle}\r\n begin\r\n h := h div 2;\r\n w := w div 2;\r\n NumberOfColors := Min(Steps, Min(w, h));\r\n end;\r\n end;\r\n LOGBRUSH.lbStyle := BS_HATCHED;\r\n LOGBRUSH.lbHatch := Ord(BrushStyle) - Ord(bsHorizontal);\r\n for I := 0 to NumberOfColors - 1 do\r\n begin\r\n _R := c1F + MulDiv(I, c1D, NumberOfColors - 1);\r\n _G := c2F + MulDiv(I, c2D, NumberOfColors - 1);\r\n _B := c3F + MulDiv(I, c3D, NumberOfColors - 1);\r\n\r\n case Orientation of\r\n fgdHorizontal, fgdVertical, fgdRectangle:\r\n begin\r\n if BrushStyle = bsSolid then\r\n FillBrush := CreateSolidBrush(RGB(_R, _G, _B))\r\n else\r\n begin\r\n LOGBRUSH.lbColor := RGB(_R, _G, _B);\r\n FillBrush := CreateBrushIndirect(LOGBRUSH);\r\n end;\r\n\r\n case Orientation of\r\n fgdHorizontal:\r\n begin\r\n if FReverse then\r\n begin\r\n ColorR.Top := r.Bottom - MulDiv(I, h, NumberOfColors);\r\n ColorR.Bottom := r.Bottom - MulDiv(I + 1, h, NumberOfColors);\r\n end\r\n else\r\n begin\r\n ColorR.Top := r.Top + MulDiv(I, h, NumberOfColors);\r\n ColorR.Bottom := r.Top + MulDiv(I + 1, h, NumberOfColors);\r\n end;\r\n end;\r\n fgdVertical:\r\n begin\r\n if FReverse then\r\n begin\r\n ColorR.Left := r.Right - MulDiv(I, w, NumberOfColors);\r\n ColorR.Right := r.Right - MulDiv(I + 1, w, NumberOfColors);\r\n end\r\n else\r\n begin\r\n ColorR.Left := r.Left + MulDiv(I, w, NumberOfColors);\r\n ColorR.Right := r.Left + MulDiv(I + 1, w, NumberOfColors);\r\n end;\r\n end;\r\n fgdRectangle:\r\n begin\r\n ColorR.Top := r.Top + MulDiv(I, h, NumberOfColors);\r\n ColorR.Bottom := r.Bottom - MulDiv(I, h, NumberOfColors);\r\n ColorR.Left := r.Left + MulDiv(I, w, NumberOfColors);\r\n ColorR.Right := r.Right - MulDiv(I, w, NumberOfColors);\r\n end;\r\n end;\r\n FillRect(TargetDC, ColorR, FillBrush);\r\n DeleteObject(FillBrush);\r\n end;\r\n else {fgdLeftBias, fgdRightBias:}\r\n begin\r\n if Pen <> 0 then\r\n DeleteObject(SelectObject(TargetDC, OldPen)); //...cant delete selected!\r\n\r\n Pen := CreatePen(PenStyle, PenWidth, RGB(_R, _G, _B));\r\n\r\n OldPen := SelectObject(TargetDC, Pen);\r\n for J := 1 to MulDiv(I + 1, h + w, NumberOfColors) - MulDiv(I, h + w, NumberOfColors) do\r\n begin\r\n case Orientation of\r\n fgdLeftBias:\r\n begin\r\n if Y >= r.Bottom then\r\n Inc(X, PenWidth)\r\n else\r\n Y := Y + PenWidth;\r\n if x2 >= r.Right then\r\n Inc(y2, PenWidth)\r\n else\r\n x2 := x2 + PenWidth;\r\n MoveToEx(TargetDC, X, Y, nil);\r\n LineTo(TargetDC, x2, y2);\r\n end;\r\n else {fgdRightBias:}\r\n begin\r\n if X <= r.Left then\r\n Inc(Y, PenWidth)\r\n else\r\n X := X - PenWidth;\r\n if y2 >= r.Bottom then\r\n dec(x2, PenWidth)\r\n else\r\n y2 := y2 + PenWidth;\r\n MoveToEx(TargetDC, X, Y, nil);\r\n LineTo(TargetDC, x2, y2);\r\n end;\r\n end;\r\n end;\r\n DeleteObject(SelectObject(TargetDC, OldPen));\r\n end;\r\n end;\r\n // if NumberOfColors=0 then exit;\r\n if I / NumberOfColors * 100 > PercentFilling then\r\n Break;\r\n end;\r\n\r\n if BufferedDraw then\r\n begin\r\n BitBlt(DC, 0, 0, r.Right - r.Left, r.Bottom - r.Top, BufferDC, 0, 0, SRCCOPY);\r\n DeleteObject(SelectObject(BufferDC, OldBMP));\r\n DeleteDC(BufferDC);\r\n end;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvgCrossTable.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvgCrossTable.PAS, released on 2003-01-15.\r\n\r\nThe Initial Developer of the Original Code is Andrey V. Chudin, [chudin att yandex dott ru]\r\nPortions created by Andrey V. Chudin are Copyright (C) 2003 Andrey V. Chudin.\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\nMichael Beck [mbeck att bigfoot dott com].\r\nBurov Dmitry, translation of russian text.\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvgCrossTable.pas 13104 2011-09-07 06:50:43Z obones $\r\n\r\n// Cross Tables, \r\n// , .\r\n//\r\n// (DataSet)\r\n// : ColumnFieldName, RowFieldName ValueFieldName, \r\n// , \r\n// Cross Table.\r\n//\r\n// \r\n// CaptColWidthInSantim, CaptRowHeightInSantim, ColWidthInSantim RowHeightInSantim.\r\n//\r\n// IndentsInSantim.\r\n//\r\n// , \r\n// Colors Fonts.\r\n//\r\n// Title \r\n// TitleAlignment . \r\n// OnPrintTableElement.\r\n//\r\n// DataSet Filter;\r\n//--------------\r\n// Optons: TPCTOptions;\r\n//\r\n// TPCTOptions = set of ( fcoIntermediateColResults, fcoIntermediateRowResults,\r\n// fcoColResults, fcoRowResults,\r\n// fcoIntermediateColCaptions, fcoIntermediateRowCaptions,\r\n// fcoIntermediateLeftIndent, fcoIntermediateTopIndent,\r\n// fcoIntermediateRightIndent, fcoIntermediateBottomIndent,\r\n// fcoShowPageNumbers, fcoVertColCaptionsFont );\r\n//\r\n// fcoIntermediateColResults - ;\r\n// fcoIntermediateRowResults - ;\r\n// fcoColResults - ;\r\n// fcoRowResults - ;\r\n// fcoIntermediateColCaptions - ;\r\n// fcoIntermediateRowCaptions - ;\r\n// fcoIntermediateLeftIndent - ;\r\n// fcoIntermediateTopIndent - -;\r\n// fcoIntermediateRightIndent - -;\r\n// fcoIntermediateBottomIndent - -;\r\n// fcoShowPageNumbers - ;\r\n// fcoVertColCaptionsFont - ;\r\n//\r\n//--------------\r\n//\r\n//______\r\n//\r\n// OnPrintQuery - - ;\r\n// ;\r\n//\r\n// OnPrintNewPage - ; ;\r\n//\r\n// OnPrintTableElement - ( , );\r\n// , ,\r\n// , ;\r\n// TableElement: TPCTableElement = ( teTitle, teCell, teColCapt, teRowCapt, TeColIRes, teRowIRes, teColRes,\r\n// teRowRes ); .\r\n//\r\n// OnCalcResult - , . \r\n// . OnCalcResult , \r\n// , , Single \r\n// .\r\n//\r\n// OnDuplicateCellValue - , - .\r\n//\r\n//______\r\n//\r\n// procedure Print; - .\r\n// procedure PreviewTo( Canvas: TCanvas; PageWidth, PageHeight: Integer ); - (Canvas) \r\n// .\r\n{ [Translation]\r\n\r\n Component allows printing so-called Cross-Tables, splitting large tables\r\n into several sheets in both height and width.\r\n\r\n Source DataSet, and 3 fields (ColumnFieldName, RowFieldName and ValueFieldName)\r\n need to be specified to build the table. The table is filled with value of\r\n ValueFieldName in rows and columns determined by RowFieldName and ColumnFieldName.\r\n\r\n The properties CaptColWidthInSantim, CaptRowHeightInSantim, ColWidthInSantim\r\n and RowHeightInSantim specify sizes of table in cm.\r\n\r\n Property IndentsInSantim determines indents (margins?) when printing pages.\r\n\r\n Colors and fonts of titles(headers), cells, and aggregates of the table are\r\n specified with Colors and Fonts properties.\r\n\r\n Report's header and the adjustment of the latter are specified with\r\n Title and TitleAdjustment properties.\r\n\r\n One can control printing of header on each page by writing an\r\n OnPrintTableElement event handler.\r\n\r\n DataSet with assigned .Filter can be passed to the component.\r\n\r\n Properties\r\n ----------\r\n\r\n Options: TPCTOptions;\r\n\r\n TPCTOptions = set of ( fcoIntermediateColResults, fcoIntermediateRowResults,\r\n fcoColResults, fcoRowResults, fcoIntermediateColCaptions, fcoIntermediateRowCaptions,\r\n fcoIntermediateLeftIndent, fcoIntermediateTopIndent, fcoIntermediateRightIndent,\r\n fcoIntermediateBottomIndent, fcoShowPageNumbers, fcoVertColCaptionsFont );\r\n\r\n fcoIntermediateColResults - Showing intermediate results (summaries, totals, agregates) by columns\r\n fcoIntermediateRowResults - Showing intermediate results by rows\r\n fcoColResults - Showing results (summaries, totals, agregates) by columns\r\n fcoRowResults - Showing results by rows\r\n fcoIntermediateColCaptions - showing Column Headers(Titles) on each page or the 1st only.\r\n fcoIntermediateRowCaptions - showing Row Headers on each page.\r\n fcoIntermediateLeftIndent - Use left indent(margin) on each page.\r\n fcoIntermediateTopIndent - Use top indent(margin) on each page.\r\n fcoIntermediateRightIndent - Use right indent(margin) on each page.\r\n fcoIntermediateBottomIndent - Use bottom indent(margin) on each page.\r\n fcoShowPageNumbers - Showing pages numbers according to splitting ( of the whole report to pages)\r\n fcoVertColCaptionsFont - Showing column headers by vertical font (text? alignment?)\r\n\r\n Events\r\n ------\r\n\r\n OnPrintQuery - Tells (informs of) required pages number(count) for\r\n printing the table. Allows to cancel printing\r\n OnPrintNewPage - Notifies about every new page starting printing (and\r\n allows to cancel printing)\r\n OnPrintTableElement - Notifies about every new table element (Caption(header,\r\n title), each cell) (and allows to cancel printing).\r\n Allows to change cell's value, or assign specific color\r\n and font to it, to set(customise) parameters of text\r\n alignment, to cancel the printing.\r\n Parameter TableElement: TPCTableElement = (teTitle, teCell,\r\n teColCapt, teRowCapt, TeColIRes, teRowIRes, teRowRes)\r\n specifies type of element being printed.\r\n OnCalcResult - If the event is assigned, it is You to process calculation\r\n of totals(agregates). Event gives You values of current\r\n cell and totals for column and row. If event is not\r\n assigned, the component proceeds it, assuming cell value\r\n can be casted to Single, and calculating totals as sums\r\n of all cells in the row/column\r\n OnDuplicateCellValue - Event is fired if some pair [Column & Row] value matches\r\n another pairs value.\r\n\r\n Methods\r\n -------\r\n\r\n procedure Print;\r\n No comment needed.\r\n procedure PreviewTo( Canvas: TCanvas; PageWidth, PageHeight: Integer );\r\n Rendering the table to the given canvas, specifying size of conditional(virtual,\r\n conventional) table in pixels.\r\n}\r\n\r\nunit JvgCrossTable;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, Messages, Classes, Controls, Graphics, Buttons, Dialogs,\r\n StdCtrls, ExtCtrls, SysUtils, Forms, DB, DBCtrls, Menus, Printers,\r\n JvComponentBase, JvJVCLUtils,\r\n JvgTypes, JvgCommClasses, JvgUtils;\r\n\r\nconst\r\n JvDefaultCaptionsColor = TColor($00FFF2D2);\r\n JvDefaultResultsColor = TColor($00C5DEC5);\r\n JvDefaultIntermediateResultsColor = TColor($00ABCCF1);\r\n\r\ntype\r\n TglPrintingStatus = (fpsContinue, fpsResume, fpsAbort);\r\n\r\n TPrintQueryEvent = procedure(Sender: TObject;\r\n ColPageCount, RowPageCount: Cardinal; var CanPrint: Boolean) of object;\r\n\r\n TPrintNewPageEvent = procedure(Sender: TObject; ColPageNo, RowPageNo: Cardinal;\r\n var PrintingStatus: TglPrintingStatus) of object;\r\n\r\n TDrawCellEvent = procedure(Sender: TObject; ColNo, RowNo: Cardinal;\r\n Value: string; var CanPrint: Boolean) of object;\r\n\r\n TCalcResultEvent = procedure(Sender: TObject; ColNo, RowNo: Cardinal; CellValue: string;\r\n IntermediateColResult, IntermediateRowResult, ColResult, RowResult: Single) of object;\r\n\r\n TDuplicateCellValueEvent = procedure(Sender: TObject; ColNo, RowNo: Cardinal;\r\n Value: string; var UseDuplicateValue: Boolean) of object;\r\n\r\n TPCTOptions = set of (fcoIntermediateColResults, fcoIntermediateRowResults,\r\n fcoColResults, fcoRowResults,\r\n fcoIntermediateColCaptions, fcoIntermediateRowCaptions,\r\n fcoIntermediateLeftIndent, fcoIntermediateTopIndent,\r\n fcoIntermediateRightIndent, fcoIntermediateBottomIndent,\r\n fcoShowPageNumbers, fcoVertColCaptionsFont);\r\n\r\n TPCTableElement = (teTitle, teCell, teColCapt, teRowCapt, teColIRes,\r\n teRowIRes, teColRes, teRowRes);\r\n\r\n TPrintTableElement = procedure(Sender: TObject; var Text: string;\r\n ColNo, RowNo: Integer; TableElement: TPCTableElement;\r\n var Font: TFont; var Color: TColor; var AlignFlags: Word;\r\n var CanPrint: Boolean) of object;\r\n\r\n TJvgPrintCrossTableColors = class(TPersistent)\r\n private\r\n FCaptions: TColor;\r\n FCells: TColor;\r\n FResults: TColor;\r\n FIntermediateResults: TColor;\r\n published\r\n property Captions: TColor read FCaptions write FCaptions;\r\n property Cells: TColor read FCells write FCells;\r\n property Results: TColor read FResults write FResults;\r\n property IntermediateResults: TColor read FIntermediateResults write\r\n FIntermediateResults;\r\n end;\r\n\r\n TJvgPrintCrossTableFonts = class(TPersistent)\r\n private\r\n FColCaptions: TFont;\r\n FRowCaptions: TFont;\r\n FCells: TFont;\r\n FResults: TFont;\r\n FIntermediateResults: TFont;\r\n FTitles: TFont;\r\n procedure SetColCaptions(Value: TFont);\r\n procedure SetRowCaptions(Value: TFont);\r\n procedure SetCells(Value: TFont);\r\n procedure SetResults(Value: TFont);\r\n procedure SetIntermediateResults(Value: TFont);\r\n procedure SetTitles(Value: TFont);\r\n public\r\n constructor Create;\r\n destructor Destroy; override;\r\n published\r\n property Titles: TFont read FTitles write SetTitles;\r\n property ColCaptions: TFont read FColCaptions write SetColCaptions;\r\n property RowCaptions: TFont read FRowCaptions write SetRowCaptions;\r\n property Cells: TFont read FCells write SetCells;\r\n property Results: TFont read FResults write SetResults;\r\n property IntermediateResults: TFont read FIntermediateResults write\r\n SetIntermediateResults;\r\n end;\r\n\r\n TJvgPrintCrossTableIndents = class(TPersistent)\r\n private\r\n FLeft: Single;\r\n FTop: Single;\r\n FRight: Single;\r\n FBottom: Single;\r\n public\r\n // constructor Create;\r\n // destructor Destroy; override;\r\n published\r\n property _Left: Single read FLeft write FLeft;\r\n property _Top: Single read FTop write FTop;\r\n property _Right: Single read FRight write FRight;\r\n property _Bottom: Single read FBottom write FBottom;\r\n end;\r\n\r\n TJvgPrintCrossTable = class(TJvComponent)\r\n private\r\n FDataSet: TDataSet;\r\n FColumnFieldName: string;\r\n FRowFieldName: string;\r\n FValueFieldName: string;\r\n FVerticalGrid: Boolean;\r\n FHorizontalGrid: Boolean;\r\n FOptions: TPCTOptions;\r\n FPageWidth: Integer;\r\n FPageHeight: Integer;\r\n FColWidthInSantim: Single;\r\n FRowHeightInSantim: Single;\r\n FIndentsInSantim: TJvgPrintCrossTableIndents;\r\n FCaptColWidthInSantim: Single;\r\n FCaptRowHeightInSantim: Single;\r\n FFonts: TJvgPrintCrossTableFonts;\r\n FColors: TJvgPrintCrossTableColors;\r\n FTitle: string;\r\n FTitleAlignment: TAlignment;\r\n\r\n FOnPrintQuery: TPrintQueryEvent;\r\n FOnPrintNewPage: TPrintNewPageEvent;\r\n FOnPrintTableElement: TPrintTableElement;\r\n FOnCalcResult: TCalcResultEvent;\r\n FOnDuplicateCellValue: TDuplicateCellValueEvent;\r\n\r\n Font_: TFont;\r\n Color_: TColor;\r\n ColsSum: array of Single;\r\n RowsSum: array of Single;\r\n FinalColsSum: array of Single;\r\n FinalRowsSum: array of Single;\r\n ColumnsList: TStringList;\r\n RowsList: TStringList;\r\n ColsOnPage: Integer;\r\n RowsOnPage: Integer;\r\n TotalCols: Integer;\r\n TotalRows: Integer;\r\n ColsOnPage1: Integer;\r\n RowsOnPage1: Integer;\r\n ColsOnPageX: Integer;\r\n RowsOnPageX: Integer;\r\n RowPageCount: Integer;\r\n ColPageCount: Integer;\r\n // LOGPIXELSX_, LOGPIXELSY_: Integer;\r\n CaptColWidth: Integer;\r\n CaptRowHeight: Integer;\r\n LeftIndent: Integer;\r\n TopIndent: Integer;\r\n RightIndent: Integer;\r\n BottomIndent: Integer;\r\n ColWidth: Integer;\r\n RowHeight: Integer;\r\n ColsOnCurrPage: Integer;\r\n RowsOnCurrPage: Integer;\r\n\r\n procedure PrintTable(Canvas: TCanvas);\r\n procedure CalcResults(const Str: string; ColNo, RowNo: Integer);\r\n\r\n procedure SetColumnFieldName(const Value: string);\r\n procedure SetRowFieldName(const Value: string);\r\n procedure SetValueFieldName(const Value: string);\r\n procedure SetDataSet(Value: TDataSet);\r\n procedure SetOptions(Value: TPCTOptions);\r\n\r\n procedure DrawGrid(Canvas: TCanvas;\r\n ColPageNo, RowPageNo, ColsOnThisPage, RowsOnThisPage: Integer);\r\n procedure DrawCell(Canvas: TCanvas;\r\n ColPageNo, RowPageNo, ColNo, RowNo: Integer; Str: string; Element: TPCTableElement);\r\n procedure DrawTitle(Canvas: TCanvas; RowPageNo: Integer);\r\n function CalcColNo(ColPageNo: Integer): Integer;\r\n function CalcRowNo(RowPageNo: Integer): Integer;\r\n protected\r\n procedure Loaded; override;\r\n procedure Notification(AComponent: TComponent; Operation: TOperation); override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n procedure Print;\r\n procedure PreviewTo(Canvas: TCanvas; PageWidth, PageHeight: Integer);\r\n published\r\n property DataSet: TDataSet read FDataSet write SetDataSet;\r\n property ColumnFieldName: string read FColumnFieldName write SetColumnFieldName;\r\n property RowFieldName: string read FRowFieldName write SetRowFieldName;\r\n property ValueFieldName: string read FValueFieldName write SetValueFieldName;\r\n property Options: TPCTOptions read FOptions write SetOptions;\r\n property PageWidth: Integer read FPageWidth write FPageWidth;\r\n property PageHeight: Integer read FPageHeight write FPageHeight;\r\n property ColWidthInSantim: Single read FColWidthInSantim write FColWidthInSantim;\r\n property RowHeightInSantim: Single read FRowHeightInSantim write FRowHeightInSantim;\r\n property IndentsInSantim: TJvgPrintCrossTableIndents read FIndentsInSantim\r\n write FIndentsInSantim;\r\n property CaptColWidthInSantim: Single read FCaptColWidthInSantim write FCaptColWidthInSantim;\r\n property CaptRowHeightInSantim: Single read FCaptRowHeightInSantim write FCaptRowHeightInSantim;\r\n property Fonts: TJvgPrintCrossTableFonts read FFonts write FFonts;\r\n property Colors: TJvgPrintCrossTableColors read FColors write FColors;\r\n property OnPrintQuery: TPrintQueryEvent read FOnPrintQuery write FOnPrintQuery;\r\n property OnPrintNewPage: TPrintNewPageEvent read FOnPrintNewPage write FOnPrintNewPage;\r\n property OnPrintTableElement: TPrintTableElement read FOnPrintTableElement\r\n write FOnPrintTableElement;\r\n property OnCalcResult: TCalcResultEvent read FOnCalcResult write FOnCalcResult;\r\n property OnDuplicateCellValue: TDuplicateCellValueEvent read\r\n FOnDuplicateCellValue write FOnDuplicateCellValue;\r\n property Title: string read FTitle write FTitle;\r\n property TitleAlignment: TAlignment read FTitleAlignment write FTitleAlignment;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvgCrossTable.pas $';\r\n Revision: '$Revision: 13104 $';\r\n Date: '$Date: 2011-09-07 08:50:43 +0200 (mer. 07 sept. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n Math;\r\n\r\nconst\r\n MAX_COLS = 1024;\r\n MAX_ROWS = 1024;\r\n\r\n//=== { TJvgPrintCrossTableFonts } ===========================================\r\n\r\nconstructor TJvgPrintCrossTableFonts.Create;\r\nbegin\r\n inherited Create;\r\n FTitles := TFont.Create;\r\n FColCaptions := TFont.Create;\r\n FRowCaptions := TFont.Create;\r\n FCells := TFont.Create;\r\n FResults := TFont.Create;\r\n FIntermediateResults := TFont.Create;\r\nend;\r\n\r\ndestructor TJvgPrintCrossTableFonts.Destroy;\r\nbegin\r\n FTitles.Free;\r\n FColCaptions.Free;\r\n FRowCaptions.Free;\r\n FCells.Free;\r\n FResults.Free;\r\n FIntermediateResults.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvgPrintCrossTableFonts.SetTitles(Value: TFont);\r\nbegin\r\n FTitles.Assign(Value);\r\nend;\r\n\r\nprocedure TJvgPrintCrossTableFonts.SetColCaptions(Value: TFont);\r\nbegin\r\n FColCaptions.Assign(Value);\r\nend;\r\n\r\nprocedure TJvgPrintCrossTableFonts.SetRowCaptions(Value: TFont);\r\nbegin\r\n FRowCaptions.Assign(Value);\r\nend;\r\n\r\nprocedure TJvgPrintCrossTableFonts.SetCells(Value: TFont);\r\nbegin\r\n FCells.Assign(Value);\r\nend;\r\n\r\nprocedure TJvgPrintCrossTableFonts.SetResults(Value: TFont);\r\nbegin\r\n FResults.Assign(Value);\r\nend;\r\n\r\nprocedure TJvgPrintCrossTableFonts.SetIntermediateResults(Value: TFont);\r\nbegin\r\n FIntermediateResults.Assign(Value);\r\nend;\r\n\r\n//=== { TJvgPrintCrossTable } ================================================\r\n\r\nconstructor TJvgPrintCrossTable.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n SetLength(ColsSum, MAX_COLS+1);\r\n SetLength(RowsSum, MAX_ROWS+1);\r\n SetLength(FinalColsSum, MAX_COLS+1);\r\n SetLength(FinalRowsSum, MAX_ROWS+1);\r\n ColumnsList := TStringList.Create;\r\n RowsList := TStringList.Create;\r\n Colors := TJvgPrintCrossTableColors.Create;\r\n Fonts := TJvgPrintCrossTableFonts.Create;\r\n Font_ := TFont.Create;\r\n // Fonts.Cells.Name := 'Arial';\r\n {$IFDEF FR_RUS}\r\n with Fonts do\r\n begin\r\n Titles.CharSet := RUSSIAN_CHARSET;\r\n ColCaptions.CharSet := RUSSIAN_CHARSET;\r\n RowCaptions.CharSet := RUSSIAN_CHARSET;\r\n Cells.CharSet := RUSSIAN_CHARSET;\r\n Results.CharSet := RUSSIAN_CHARSET;\r\n IntermediateResults.CharSet := RUSSIAN_CHARSET;\r\n end;\r\n {$ENDIF FR_RUS}\r\n FIndentsInSantim := TJvgPrintCrossTableIndents.Create;\r\n\r\n with FIndentsInSantim do\r\n begin\r\n _Left := 1;\r\n _Top := 1;\r\n _Right := 1;\r\n _Bottom := 1;\r\n end;\r\n\r\n ColWidthInSantim := 0.9;\r\n RowHeightInSantim := 0.5;\r\n\r\n FVerticalGrid := True;\r\n FHorizontalGrid := True;\r\n\r\n Colors.Captions := JvDefaultCaptionsColor;\r\n Colors.Cells := clWhite;\r\n Colors.Results := JvDefaultResultsColor;\r\n Colors.IntermediateResults := JvDefaultIntermediateResultsColor;\r\n\r\n Options := [fcoIntermediateColResults, fcoIntermediateRowResults,\r\n fcoColResults, fcoRowResults, fcoShowPageNumbers];\r\nend;\r\n\r\ndestructor TJvgPrintCrossTable.Destroy;\r\nbegin\r\n ColumnsList.Free;\r\n RowsList.Free;\r\n Fonts.Free;\r\n Colors.Free;\r\n FIndentsInSantim.Free;\r\n Font_.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvgPrintCrossTable.Loaded;\r\nbegin\r\n inherited Loaded;\r\n if fcoVertColCaptionsFont in Options then\r\n FFonts.ColCaptions.Handle := CreateRotatedFont(Fonts.ColCaptions, 900)\r\n else\r\n FFonts.ColCaptions.Handle := CreateRotatedFont(Fonts.ColCaptions, 0);\r\nend;\r\n\r\nprocedure TJvgPrintCrossTable.Notification(AComponent: TComponent;\r\n Operation: TOperation);\r\nbegin\r\n inherited Notification(AComponent, Operation);\r\n if (Operation = opRemove) and (AComponent = DataSet) then\r\n DataSet := nil;\r\nend;\r\n\r\nprocedure TJvgPrintCrossTable.DrawGrid(Canvas: TCanvas;\r\n ColPageNo, RowPageNo, ColsOnThisPage, RowsOnThisPage: Integer);\r\nvar\r\n Col, Row: Integer;\r\nbegin\r\n // (rom) Huh?\r\n Exit;\r\n if ColPageNo = ColPageCount - 1 then\r\n Inc(ColsOnThisPage);\r\n if RowPageNo = RowPageCount - 1 then\r\n Inc(RowsOnThisPage);\r\n if FVerticalGrid then\r\n for Col := 0 to ColsOnThisPage + 1 do\r\n with Canvas do\r\n begin\r\n MoveToEx(Handle, CaptColWidth + Col * ColWidth + LeftIndent,\r\n TopIndent, nil);\r\n Windows.LineTo(Handle, CaptColWidth + Col * ColWidth + LeftIndent,\r\n TopIndent + (RowsOnThisPage + 2) * RowHeight);\r\n end;\r\n if FHorizontalGrid then\r\n for Row := 0 to RowsOnThisPage + 1 do\r\n with Canvas do\r\n begin\r\n MoveToEx(Handle, LeftIndent, CaptRowHeight + Row * RowHeight +\r\n TopIndent, nil);\r\n Windows.LineTo(Handle, LeftIndent + (ColsOnThisPage + 2) * ColWidth,\r\n CaptRowHeight + Row * RowHeight + TopIndent);\r\n end;\r\nend;\r\n\r\nfunction TJvgPrintCrossTable.CalcColNo(ColPageNo: Integer): Integer;\r\nbegin\r\n if ColPageNo > 0 then\r\n Result := ColsOnPage1\r\n else\r\n Result := 0;\r\n if ColPageNo > 1 then\r\n Inc(Result, ColsOnPageX * (ColPageNo - 1));\r\nend;\r\n\r\nfunction TJvgPrintCrossTable.CalcRowNo(RowPageNo: Integer): Integer;\r\nbegin\r\n if RowPageNo > 0 then\r\n Result := RowsOnPage1\r\n else\r\n Result := 0;\r\n if RowPageNo > 1 then\r\n Inc(Result, RowsOnPageX * (RowPageNo - 1));\r\nend;\r\n\r\nprocedure TJvgPrintCrossTable.DrawCell(Canvas: TCanvas; ColPageNo, RowPageNo,\r\n ColNo, RowNo: Integer; Str: string; Element: TPCTableElement);\r\nvar\r\n R, R_: TRect;\r\n I, J: Integer;\r\n AlignFlags: Word;\r\n CanPrint: Boolean;\r\nconst\r\n SingleLine: array [Boolean] of Integer = (DT_WORDBREAK, DT_SINGLELINE);\r\nbegin\r\n with Canvas do\r\n begin\r\n if (ColNo = -1) or (RowNo = -1) then //...Draw Caption\r\n begin\r\n I := Max(0, ColNo);\r\n J := Max(0, RowNo);\r\n if (RowNo = -1) then\r\n begin\r\n R.Left := I * ColWidth;\r\n R.Top := 0;\r\n if (ColPageNo = 0) or (fcoIntermediateLeftIndent in Options) then\r\n Inc(R.Left, LeftIndent);\r\n if (RowPageNo = 0) or (fcoIntermediateTopIndent in Options) then\r\n Inc(R.Top, TopIndent);\r\n if (ColPageNo = 0) or (fcoIntermediateRowCaptions in Options) then\r\n Inc(R.Left, CaptColWidth);\r\n R.Right := R.Left + ColWidth;\r\n R.Bottom := R.Top + CaptRowHeight;\r\n end\r\n else\r\n begin\r\n R.Left := 0;\r\n R.Top := J * RowHeight;\r\n if (ColPageNo = 0) or (fcoIntermediateLeftIndent in Options) then\r\n Inc(R.Left, LeftIndent);\r\n if (RowPageNo = 0) or (fcoIntermediateTopIndent in Options) then\r\n Inc(R.Top, TopIndent);\r\n if (RowPageNo = 0) or (fcoIntermediateColCaptions in Options) then\r\n Inc(R.Top, CaptRowHeight);\r\n R.Right := R.Left + CaptColWidth;\r\n R.Bottom := R.Top + RowHeight;\r\n end;\r\n end\r\n else //...Draw Cell\r\n begin\r\n I := CalcColNo(ColPageNo);\r\n J := CalcRowNo(RowPageNo);\r\n\r\n R.Left := (ColNo - I + 1) * ColWidth - ColWidth;\r\n R.Top := (RowNo - J + 1) * RowHeight - RowHeight;\r\n\r\n if (ColPageNo = 0) or (fcoIntermediateLeftIndent in Options) then\r\n Inc(R.Left, LeftIndent);\r\n if (RowPageNo = 0) or (fcoIntermediateTopIndent in Options) then\r\n Inc(R.Top, TopIndent);\r\n\r\n if (RowPageNo = 0) or (fcoIntermediateColCaptions in Options) then\r\n Inc(R.Top, CaptRowHeight);\r\n if (ColPageNo = 0) or (fcoIntermediateRowCaptions in Options) then\r\n Inc(R.Left, CaptColWidth);\r\n\r\n R.Right := R.Left + ColWidth;\r\n R.Bottom := R.Top + RowHeight;\r\n Inc(R.Bottom);\r\n Inc(R.Right);\r\n end;\r\n\r\n InflateRect(R, -2, -2);\r\n\r\n with Fonts, Brush do\r\n case Element of\r\n teCell:\r\n begin\r\n Font.Assign(Cells);\r\n Color := Colors.Cells;\r\n end;\r\n teColCapt:\r\n begin\r\n Font.Assign(ColCaptions);\r\n Color := Colors.Captions;\r\n end;\r\n teRowCapt:\r\n begin\r\n Font.Assign(RowCaptions);\r\n Color := Colors.Captions;\r\n end;\r\n teColIRes,\r\n teRowIRes:\r\n begin\r\n Font.Assign(IntermediateResults);\r\n Color := Colors.IntermediateResults;\r\n end;\r\n teColRes,\r\n teRowRes:\r\n begin\r\n Font.Assign(Results);\r\n Color := Colors.Results;\r\n end;\r\n end;\r\n\r\n AlignFlags := SingleLine[(ColNo <> -1) and (RowNo <> -1)] or\r\n DT_CENTER or DT_VCENTER;\r\n\r\n CanPrint := True;\r\n if Assigned(FOnPrintTableElement) then\r\n begin\r\n Color_ := Brush.Color;\r\n Font_.Assign(Font);\r\n FOnPrintTableElement(Self, Str, I + 1, J + 1, Element, Font_, Color_,\r\n AlignFlags, CanPrint);\r\n Font.Assign(Font_);\r\n end;\r\n\r\n if not CanPrint then\r\n Exit;\r\n\r\n Canvas.FillRect(R);\r\n Brush.Color := 0;\r\n InflateRect(R, 1, 1);\r\n Canvas.FrameRect(R);\r\n SetBkMode(Handle, TRANSPARENT);\r\n\r\n if (fcoVertColCaptionsFont in Options) and (RowNo = -1) then\r\n ExtTextOut(Handle, R.Left + 5, R.Bottom - 2, ETO_CLIPPED, @R,\r\n PChar(Str), Length(Str), nil)\r\n else\r\n begin\r\n R_ := R;\r\n Windows.DrawText(Handle, PChar(Str), -1, R_, DT_CENTER or DT_WORDBREAK or\r\n DT_CALCRECT);\r\n R.Top := R.Top + Max(0, (R.Bottom - R_.Bottom) div 2);\r\n Windows.DrawText(Handle, PChar(Str), -1, R, DT_CENTER or DT_WORDBREAK);\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvgPrintCrossTable.DrawTitle(Canvas: TCanvas; RowPageNo: Integer);\r\nvar\r\n CanPrint: Boolean;\r\n Str: string;\r\n AlignFlags: Word;\r\n R: TRect;\r\nconst\r\n Alignments: array [TAlignment] of Word = (DT_LEFT, DT_RIGHT, DT_CENTER);\r\nbegin\r\n with Canvas do\r\n begin\r\n Font.Assign(Fonts.Titles);\r\n if TopIndent < TextHeight('ky') then\r\n Exit;\r\n if not ((RowPageNo = 0) or (fcoIntermediateTopIndent in Options)) then\r\n Exit;\r\n\r\n CanPrint := True;\r\n AlignFlags := (DT_SINGLELINE or DT_EXPANDTABS) or\r\n Alignments[FTitleAlignment];\r\n Str := FTitle;\r\n if Assigned(FOnPrintTableElement) then\r\n begin\r\n Color_ := Brush.Color;\r\n Font_.Assign(Font);\r\n FOnPrintTableElement(Self, Str, -1, -1, teTitle, Font_, Color_,\r\n AlignFlags, CanPrint);\r\n Font.Assign(Font_);\r\n end;\r\n if not CanPrint then\r\n Exit;\r\n R := Rect(LeftIndent, 10, PageWidth - RightIndent, PageHeight -\r\n BottomIndent);\r\n SetBkMode(Handle, TRANSPARENT);\r\n Windows.DrawText(Handle, PChar(Str), -1, R, AlignFlags);\r\n end;\r\nend;\r\n\r\nprocedure TJvgPrintCrossTable.Print;\r\nbegin\r\n PrintTable(nil);\r\nend;\r\n\r\nprocedure TJvgPrintCrossTable.PreviewTo(Canvas: TCanvas;\r\n PageWidth, PageHeight: Integer);\r\nbegin\r\n Self.PageWidth := PageWidth;\r\n Self.PageHeight := PageHeight;\r\n PrintTable(Canvas);\r\nend;\r\n\r\nprocedure TJvgPrintCrossTable.PrintTable(Canvas: TCanvas);\r\nvar\r\n I, J: Integer;\r\n fPrint, CanPrint, fUseDuplicateValue: Boolean;\r\n ClientSize: TSize;\r\n PrintingStatus: TglPrintingStatus;\r\n Str: string;\r\n TargetCanvas: TCanvas;\r\n ColumnField, RowField, ValueField: TField;\r\n ColPageNo, RowPageNo, ColNo, RowNo: Integer;\r\n ClientR, CaptR, DataR: TRect;\r\n FilledRowNo: array[0..MAX_ROWS] of Boolean;\r\n OldFilter: string;\r\n OldFiltered: Boolean;\r\nbegin\r\n if not Assigned(FDataSet) then\r\n Exit;\r\n FillChar(FinalColsSum, SizeOf(FinalColsSum), 0);\r\n FillChar(FinalRowsSum, SizeOf(FinalRowsSum), 0);\r\n OldFiltered := False;\r\n with IndentsInSantim do\r\n try\r\n with FDataSet do\r\n begin\r\n\r\n OldFilter := Filter;\r\n OldFiltered := Filtered;\r\n\r\n Filtered := False;\r\n ColumnField := FieldByName(ColumnFieldName);\r\n RowField := FieldByName(RowFieldName);\r\n ValueField := FieldByName(ValueFieldName);\r\n end;\r\n\r\n fPrint := not Assigned(Canvas);\r\n if fPrint then\r\n begin\r\n TargetCanvas := Printer.Canvas;\r\n PageWidth := Printer.PageWidth;\r\n PageHeight := Printer.PageHeight;\r\n end\r\n else\r\n begin\r\n TargetCanvas := Canvas;\r\n end;\r\n if fPrint then\r\n Printer.BeginDoc;\r\n with TargetCanvas do\r\n begin\r\n // LOGPIXELSX_ := GetDeviceCaps(Canvas.Handle,LOGPIXELSX);\r\n // LOGPIXELSY_ := GetDeviceCaps(Canvas.Handle,LOGPIXELSY);\r\n\r\n ColWidth := CentimetersToPixels(Handle, ColWidthInSantim, True);\r\n RowHeight := CentimetersToPixels(Handle, RowHeightInSantim, False);\r\n LeftIndent := CentimetersToPixels(Handle, _Left, True);\r\n TopIndent := CentimetersToPixels(Handle, _Top, False);\r\n RightIndent := CentimetersToPixels(Handle, _Right, True);\r\n BottomIndent := CentimetersToPixels(Handle, _Bottom, False);\r\n CaptColWidth := CentimetersToPixels(Handle, CaptColWidthInSantim, True);\r\n CaptRowHeight := CentimetersToPixels(Handle, CaptRowHeightInSantim, False);\r\n\r\n end;\r\n // CaptR := Rect( LeftIndent, TopIndent, PageWidth-RightIndent, PageHeight-BottomIndent );\r\n // DataR := CaptR; InflateRect( DataR, -ColWidth, -RowHeight );\r\n //---------\r\n with FDataSet do\r\n begin\r\n ColumnsList.Clear;\r\n RowsList.Clear;\r\n\r\n First;\r\n while not EOF do\r\n begin\r\n ColumnsList.Add(ColumnField.AsString);\r\n RowsList.Add(RowField.AsString);\r\n Next;\r\n end;\r\n end;\r\n ColumnsList.Sort;\r\n RowsList.Sort;\r\n ColumnsList.Sorted := True;\r\n RowsList.Sorted := True;\r\n for I := ColumnsList.Count - 1 downto 1 do\r\n if ColumnsList[I - 1] = ColumnsList[I] then\r\n ColumnsList.Delete(I);\r\n\r\n for I := RowsList.Count - 1 downto 1 do\r\n if RowsList[I - 1] = RowsList[I] then\r\n RowsList.Delete(I);\r\n\r\n TotalCols := ColumnsList.Count + 1; //...+1 - final results\r\n TotalRows := RowsList.Count + 1;\r\n\r\n ClientSize.cx := PageWidth - LeftIndent - RightIndent;\r\n ClientSize.cy := PageHeight - TopIndent - BottomIndent;\r\n\r\n ColsOnPage1 := (ClientSize.cx - CaptColWidth) div ColWidth -\r\n Integer(fcoIntermediateColResults in Options);\r\n RowsOnPage1 := (ClientSize.cy - CaptRowHeight) div RowHeight -\r\n Integer(fcoIntermediateRowResults in Options);\r\n\r\n ClientSize.cx := PageWidth;\r\n ClientSize.cy := PageHeight;\r\n\r\n if (fcoIntermediateColCaptions in Options) then\r\n Dec(ClientSize.cy, CaptRowHeight);\r\n if (fcoIntermediateRowCaptions in Options) then\r\n Dec(ClientSize.cx, CaptColWidth);\r\n if (fcoIntermediateLeftIndent in Options) then\r\n Dec(ClientSize.cx, LeftIndent);\r\n if (fcoIntermediateTopIndent in Options) then\r\n Dec(ClientSize.cy, TopIndent);\r\n if (fcoIntermediateRightIndent in Options) then\r\n Dec(ClientSize.cx, RightIndent);\r\n if (fcoIntermediateBottomIndent in Options) then\r\n Dec(ClientSize.cy, BottomIndent);\r\n\r\n ColsOnPageX := (ClientSize.cx) div ColWidth -\r\n Integer(fcoIntermediateColResults in Options);\r\n RowsOnPageX := (ClientSize.cy) div RowHeight -\r\n Integer(fcoIntermediateRowResults in Options);\r\n\r\n RowPageCount := Max(Trunc(TotalRows / (RowsOnPageX + 1)), 1);\r\n ColPageCount := Max(Trunc(TotalCols / (ColsOnPageX + 1)), 1);\r\n\r\n //...EVENT OnPrintQuery\r\n CanPrint := True;\r\n if Assigned(FOnPrintQuery) then\r\n FOnPrintQuery(Self, ColPageCount, RowPageCount, CanPrint);\r\n if not CanPrint then\r\n begin\r\n if fPrint then\r\n Printer.Abort;\r\n Exit;\r\n end;\r\n //...\r\n TargetCanvas.Font := Fonts.Cells;\r\n TargetCanvas.Brush.Color := 0;\r\n TargetCanvas.Font.Color := 0;\r\n SetBkMode(TargetCanvas.Handle, TRANSPARENT);\r\n\r\n for RowPageNo := 0 to RowPageCount - 1 do\r\n begin\r\n for ColPageNo := 0 to ColPageCount - 1 do\r\n with TargetCanvas do\r\n begin\r\n\r\n if ColPageNo = 0 then\r\n ColsOnPage := ColsOnPage1\r\n else\r\n ColsOnPage := ColsOnPageX;\r\n if RowPageNo = 0 then\r\n RowsOnPage := RowsOnPage1\r\n else\r\n RowsOnPage := RowsOnPageX;\r\n\r\n FillChar(ColsSum, SizeOf(ColsSum), 0);\r\n FillChar(RowsSum, SizeOf(RowsSum), 0);\r\n\r\n ColsOnCurrPage := min(ColsOnPage, TotalCols - ColPageNo *\r\n ColsOnPage);\r\n RowsOnCurrPage := min(RowsOnPage, TotalRows - RowPageNo *\r\n RowsOnPage);\r\n\r\n if ColPageNo = ColPageCount - 1 then\r\n Dec(ColsOnCurrPage);\r\n if RowPageNo = RowPageCount - 1 then\r\n Dec(RowsOnCurrPage);\r\n //...EVENT OnPrintNewPage\r\n PrintingStatus := fpsContinue;\r\n if Assigned(OnPrintNewPage) then\r\n OnPrintNewPage(Self, ColPageNo, RowPageNo, PrintingStatus);\r\n if PrintingStatus = fpsAbort then\r\n begin\r\n if fPrint then\r\n Printer.Abort;\r\n Exit;\r\n end;\r\n if PrintingStatus = fpsResume then\r\n begin\r\n if fPrint then\r\n Printer.EndDoc;\r\n Exit;\r\n end;\r\n //...\r\n ClientR := Rect(0, 0, PageWidth, PageHeight);\r\n Brush.Color := clWhite;\r\n FillRect(ClientR);\r\n Brush.Color := 0;\r\n // FrameRect(ClientR);\r\n DrawTitle(TargetCanvas, RowPageNo);\r\n CaptR := Rect(LeftIndent, TopIndent, LeftIndent + (ColsOnCurrPage\r\n + 2) * (ColWidth) + CaptColWidth,\r\n TopIndent + (RowsOnCurrPage + 2) * (RowHeight) +\r\n CaptRowHeight);\r\n DataR := CaptR;\r\n InflateRect(DataR, -CaptColWidth, -CaptRowHeight);\r\n\r\n Brush.Color := clWhite;\r\n FillRect(CaptR);\r\n Brush.Color := 0;\r\n // Brush.Color := $0080FFFF; if not fPrint then FillRect(DataR); Brush.Color := 0;\r\n // FrameRect(CaptR);\r\n SetBkMode(TargetCanvas.Handle, TRANSPARENT);\r\n if fcoShowPageNumbers in Options then\r\n TextOut(10, 10, '[ ' + IntToStr(RowPageNo + 1) + ' / ' +\r\n IntToStr(ColPageNo + 1) + ' ]');\r\n\r\n DrawGrid(TargetCanvas, ColPageNo, RowPageNo, ColsOnCurrPage,\r\n RowsOnCurrPage);\r\n SetBkMode(TargetCanvas.Handle, TRANSPARENT);\r\n if (RowPageNo = 0) or (fcoIntermediateColCaptions in Options) then\r\n for I := 0 to ColsOnCurrPage - 1 do //...captions_________________________\r\n try\r\n Str := ColumnsList[CalcColNo(ColPageNo) + I];\r\n DrawCell(TargetCanvas, ColPageNo, RowPageNo, I, -1, Str,\r\n teColCapt);\r\n except\r\n Break;\r\n end;\r\n\r\n if (ColPageNo = 0) or (fcoIntermediateRowCaptions in Options) then\r\n for I := 0 to RowsOnCurrPage - 1 do //...captions_________________________\r\n try\r\n Str := RowsList[CalcRowNo(RowPageNo) + I];\r\n DrawCell(TargetCanvas, ColPageNo, RowPageNo, -1, I, Str,\r\n teRowCapt);\r\n except\r\n Break;\r\n end;\r\n\r\n I := CalcColNo(ColPageNo);\r\n with FDataSet do\r\n for ColNo := I to I + ColsOnCurrPage - 1 do\r\n begin\r\n\r\n if ColNo >= ColumnsList.Count then\r\n Break;\r\n if ColumnsList[ColNo] = '' then\r\n Continue;\r\n Filtered := False;\r\n Filter := '[' + ColumnFieldName + ']=''' +\r\n ColumnsList[ColNo] + '''' + OldFilter;\r\n Filtered := True;\r\n First;\r\n\r\n FillChar(FilledRowNo, SizeOf(FilledRowNo), 0);\r\n for I := 0 to RecordCount - 1 do\r\n begin\r\n\r\n if not RowsList.Find(RowField.AsString, RowNo) then\r\n begin\r\n Next;\r\n Continue;\r\n end;\r\n\r\n if (RowNo < CalcRowNo(RowPageNo)) or (RowNo >=\r\n CalcRowNo(RowPageNo) + RowsOnCurrPage) then\r\n begin\r\n Next;\r\n Continue;\r\n end;\r\n // if not((RowNo >= RowPageNo*(RowsOnCurrPage))and(RowNo <= (RowPageNo+1)*(RowsOnPage)-1))then\r\n // begin Next; Continue; end;\r\n\r\n fUseDuplicateValue := False;\r\n if FilledRowNo[RowNo] then //...duplicate\r\n begin\r\n if Assigned(OnDuplicateCellValue) then\r\n OnDuplicateCellValue(Self, ColNo, RowNo,\r\n ValueField.AsString, fUseDuplicateValue);\r\n end;\r\n\r\n if (not FilledRowNo[RowNo]) or fUseDuplicateValue then\r\n begin\r\n FilledRowNo[RowNo] := True;\r\n Str := ValueField.AsString;\r\n DrawCell(TargetCanvas, ColPageNo, RowPageNo,\r\n ColNo, RowNo, Str, teCell);\r\n CalcResults(Str, ColNo, RowNo);\r\n end;\r\n\r\n Next;\r\n end;\r\n end;\r\n //...sums\r\n I := CalcColNo(ColPageNo);\r\n J := CalcRowNo(RowPageNo);\r\n if fcoIntermediateColResults in Options then\r\n for ColNo := I to I + ColsOnCurrPage - 1 do\r\n begin\r\n Str := FloatToStr(ColsSum[ColNo]);\r\n DrawCell(TargetCanvas, ColPageNo, RowPageNo, ColNo, J +\r\n RowsOnCurrPage, Str, teColIRes);\r\n end;\r\n if fcoIntermediateRowResults in Options then\r\n for RowNo := J to J + RowsOnCurrPage - 1 do\r\n begin\r\n Str := FloatToStr(RowsSum[RowNo]);\r\n DrawCell(TargetCanvas, ColPageNo, RowPageNo, I +\r\n ColsOnCurrPage, RowNo, Str, teRowIRes);\r\n end;\r\n //...sums\r\n\r\n if RowPageNo = RowPageCount - 1 then\r\n for ColNo := I to I + ColsOnCurrPage - 1 do\r\n begin\r\n Str := FloatToStr(FinalColsSum[ColNo]);\r\n DrawCell(TargetCanvas, ColPageNo, RowPageNo, ColNo, J +\r\n RowsOnCurrPage + Integer(fcoIntermediateRowResults in\r\n Options), Str, teColRes);\r\n end;\r\n if ColPageNo = ColPageCount - 1 then\r\n for RowNo := J to J + RowsOnCurrPage - 1 do\r\n begin\r\n Str := FloatToStr(FinalRowsSum[RowNo]);\r\n DrawCell(TargetCanvas, ColPageNo, RowPageNo, I +\r\n ColsOnCurrPage + Integer(fcoIntermediateColResults in\r\n Options), RowNo, Str, teRowRes);\r\n end;\r\n //...\r\n if fPrint and\r\n ((ColPageNo <> ColPageCount - 1) or\r\n (RowPageNo <> RowPageCount - 1)) then\r\n Printer.NewPage;\r\n end;\r\n end;\r\n finally\r\n DataSet.Filter := OldFilter;\r\n DataSet.Filtered := OldFiltered;\r\n end;\r\n //...\r\n if fPrint then\r\n Printer.EndDoc;\r\nend;\r\n\r\n{procedure TJvgPrintCrossTable.SetDataSource(Value: TDataSource);\r\nbegin\r\n FDataSource := Value;\r\nend;}\r\n\r\nprocedure TJvgPrintCrossTable.CalcResults(const Str: string; ColNo, RowNo: Integer);\r\nbegin\r\n //...if event is assigned then user should calculates results himself\r\n if Assigned(FOnCalcResult) then\r\n begin\r\n FOnCalcResult(Self, ColNo, RowNo,\r\n Str, {CellValue}\r\n ColsSum[ColNo], {IntermediateColResult}\r\n RowsSum[RowNo], {IntermediateRowResult}\r\n FinalColsSum[ColNo], {ColResult}\r\n FinalRowsSum[RowNo] {RowResult});\r\n end\r\n else\r\n begin\r\n try\r\n ColsSum[ColNo] := ColsSum[ColNo] + StrToFloat(Str);\r\n except\r\n end;\r\n try\r\n FinalColsSum[ColNo] := FinalColsSum[ColNo] + StrToFloat(Str);\r\n except\r\n end;\r\n try\r\n RowsSum[RowNo] := RowsSum[RowNo] + StrToFloat(Str);\r\n except\r\n end;\r\n try\r\n FinalRowsSum[RowNo] := FinalRowsSum[RowNo] + StrToFloat(Str);\r\n except\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvgPrintCrossTable.SetDataSet(Value: TDataSet);\r\nbegin\r\n ReplaceComponentReference(Self, Value, TComponent(FDataSet));\r\nend;\r\n\r\nprocedure TJvgPrintCrossTable.SetColumnFieldName(const Value: string);\r\nbegin\r\n FColumnFieldName := Value;\r\nend;\r\n\r\nprocedure TJvgPrintCrossTable.SetRowFieldName(const Value: string);\r\nbegin\r\n FRowFieldName := Value;\r\nend;\r\n\r\nprocedure TJvgPrintCrossTable.SetValueFieldName(const Value: string);\r\nbegin\r\n FValueFieldName := Value;\r\nend;\r\n\r\nprocedure TJvgPrintCrossTable.SetOptions(Value: TPCTOptions);\r\nbegin\r\n FOptions := Value;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvgDigits.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvgDigits.PAS, released on 2003-01-15.\r\n\r\nThe Initial Developer of the Original Code is Andrey V. Chudin, [chudin att yandex dott ru]\r\nPortions created by Andrey V. Chudin are Copyright (C) 2003 Andrey V. Chudin.\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\nMichael Beck [mbeck att bigfoot dott com].\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvgDigits.pas 12461 2009-08-14 17:21:33Z obones $\r\n\r\nunit JvgDigits;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, Messages, SysUtils, Classes, Graphics, Controls,\r\n Forms, Dialogs, ExtCtrls,\r\n JvComponent,\r\n JvgTypes, JvgUtils, JvgCommClasses;\r\n\r\nconst\r\n JvDefaultPassiveColor = TColor($00202020);\r\n\r\ntype\r\n TJvgSpecialSymbol = (ssyNone, ssyColon, ssySlash, ssyBackslash);\r\n\r\n TJvgDigits = class(TJvGraphicControl)\r\n private\r\n FValue: Double;\r\n FDSize: TJvgPointClass;\r\n FActiveColor: TColor;\r\n FPassiveColor: TColor;\r\n FBackgroundColor: TColor;\r\n FInsertSpecialSymbolAt: Integer;\r\n FPositions: Word;\r\n FPenWidth: Word;\r\n FGap: Word;\r\n FInterspace: Word;\r\n FTransparent: Boolean;\r\n FAlignment: TAlignment;\r\n FInteriorOffset: Word;\r\n FPenStyle: TPenStyle;\r\n FSpecialSymbol: TJvgSpecialSymbol;\r\n FBevel: TJvgExtBevelOptions;\r\n FGradient: TJvgGradient;\r\n FDigitCount: Integer;\r\n FOldStrWidth: Integer;\r\n FOldDotPos: Integer;\r\n FNeedBackgroundPaint: Boolean;\r\n procedure WMSize(var Msg: TWMSize); message WM_SIZE;\r\n procedure SetValue(NewValue: Double);\r\n procedure SetActiveColor(Value: TColor);\r\n procedure SetPassiveColor(Value: TColor);\r\n procedure SetBackgroundColor(Value: TColor);\r\n procedure SetPositions(Value: Word);\r\n procedure SetPenWidth(Value: Word);\r\n procedure SetInterspace(Value: Word);\r\n procedure SetGap(Value: Word);\r\n procedure SetTransparent(Value: Boolean);\r\n procedure SetAlignment(Value: TAlignment);\r\n procedure SetInteriorOffset(Value: Word);\r\n procedure SetInsertSpecialSymbolAt(Value: Integer);\r\n procedure SetPenStyle(Value: TPenStyle);\r\n procedure SetSpecialSymbol(Value: TJvgSpecialSymbol);\r\n procedure SetDigitCount(Value: Integer);\r\n procedure SmthChanged(Sender: TObject);\r\n public\r\n procedure Paint; override;\r\n procedure PaintTo(Canvas: TCanvas);\r\n property Canvas;\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n published\r\n property Value: Double read FValue write SetValue;\r\n property DigitSize: TJvgPointClass read FDSize write FDSize;\r\n property ActiveColor: TColor read FActiveColor write SetActiveColor default clWhite;\r\n property PassiveColor: TColor read FPassiveColor write SetPassiveColor default JvDefaultPassiveColor;\r\n property BackgroundColor: TColor read FBackgroundColor write SetBackgroundColor default clBlack;\r\n property Positions: Word read FPositions write SetPositions default 0;\r\n property PenWidth: Word read FPenWidth write SetPenWidth default 1;\r\n property Gap: Word read FGap write SetGap default 1;\r\n property Interspace: Word read FInterspace write SetInterspace default 3;\r\n property Transparent: Boolean read FTransparent write SetTransparent default False;\r\n property Alignment: TAlignment read FAlignment write SetAlignment default taCenter;\r\n property InteriorOffset: Word read FInteriorOffset write SetInteriorOffset default 0;\r\n property InsertSpecialSymbolAt: Integer read FInsertSpecialSymbolAt write SetInsertSpecialSymbolAt default -1;\r\n property PenStyle: TPenStyle read FPenStyle write SetPenStyle default psSolid;\r\n property SpecialSymbol: TJvgSpecialSymbol read FSpecialSymbol write SetSpecialSymbol default ssyNone;\r\n property Bevel: TJvgExtBevelOptions read FBevel write FBevel;\r\n property Gradient: TJvgGradient read FGradient write FGradient;\r\n property DigitCount: Integer read FDigitCount write SetDigitCount default -1;\r\n property Width default 160;\r\n property Height default 28;\r\n property OnClick;\r\n property OnMouseDown;\r\n property OnMouseUp;\r\n property OnMouseMove;\r\n end;\r\n\r\n TJvgGraphDigitsElem =\r\n (dlT, dlC, dlB, dlTL, dlTR, dlBL, dlBR, dlDOT);\r\n TJvgGraphDigitsElemSet = set of TJvgGraphDigitsElem;\r\n\r\nconst\r\n DigitsSet: array [0..11] of TJvgGraphDigitsElemSet =\r\n (\r\n [dlT, dlB, dlTL, dlTR, dlBL, dlBR], // 0\r\n [dlTR, dlBR], // 1\r\n [dlT, dlC, dlB, dlTR, dlBL], // 2\r\n [dlT, dlC, dlB, dlTR, dlBR], // 3\r\n [dlC, dlTL, dlTR, dlBR], // 4\r\n [dlT, dlC, dlB, dlTL, dlBR], // 5\r\n [dlT, dlC, dlB, dlTL, dlBL, dlBR], // 6\r\n [dlT, dlTR, dlBR], // 7\r\n [dlT, dlC, dlB, dlTL, dlTR, dlBL, dlBR], // 8\r\n [dlT, dlC, dlB, dlTL, dlTR, dlBR], // 9\r\n [], // ' '\r\n [dlDOT] // ','\r\n );\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvgDigits.pas $';\r\n Revision: '$Revision: 12461 $';\r\n Date: '$Date: 2009-08-14 19:21:33 +0200 (ven. 14 août 2009) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nconstructor TJvgDigits.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FDSize := TJvgPointClass.Create;\r\n //...set defaults\r\n Width := 160;\r\n Height := 28;\r\n // if csDesigning in ComponentState then FValue:=1.1234567890;\r\n FDSize.X := 10;\r\n FDSize.Y := 21;\r\n FDSize.OnChanged := SmthChanged;\r\n FActiveColor := clWhite;\r\n FPassiveColor := JvDefaultPassiveColor;\r\n FBackgroundColor := clBlack;\r\n FPositions := 0;\r\n FPenWidth := 1;\r\n FGap := 1;\r\n FInterspace := 3;\r\n FTransparent := False;\r\n FInteriorOffset := 0;\r\n FInsertSpecialSymbolAt := -1;\r\n FDigitCount := -1;\r\n FPenStyle := psSolid;\r\n FNeedBackgroundPaint := True;\r\n Color := FBackgroundColor;\r\n FAlignment := taCenter;\r\n FSpecialSymbol := ssyNone;\r\n FBevel := TJvgExtBevelOptions.Create;\r\n FBevel.OnChanged := SmthChanged;\r\n FGradient := TJvgGradient.Create;\r\n FGradient.OnChanged := SmthChanged;\r\nend;\r\n\r\ndestructor TJvgDigits.Destroy;\r\nbegin\r\n FDSize.Free;\r\n FBevel.Free;\r\n FGradient.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvgDigits.Paint;\r\nbegin\r\n try\r\n if Canvas.Handle <> 0 then\r\n PaintTo(Canvas);\r\n except\r\n end;\r\nend;\r\n\r\nprocedure TJvgDigits.PaintTo(Canvas: TCanvas);\r\nvar\r\n Pt, OldPt: TPoint;\r\n XPos, YPos, D, CenterY, S, I, IWidth: Integer;\r\n Str, SChar: string;\r\n R: TRect;\r\n SPassive: Boolean;\r\n ClientR: TRect;\r\n\r\n procedure FillBackground;\r\n begin\r\n if FTransparent or FGradient.Active then\r\n Exit;\r\n Canvas.Brush.Style := bsSolid;\r\n Canvas.Brush.Color := FBackgroundColor;\r\n Canvas.FillRect(ClientR);\r\n end;\r\n\r\n function DrawDigit(Pt: TPoint; CActive, CPassive: TColor): Integer;\r\n label\r\n deC_L, deB_L, deTL_L, deTR_L, deBL_L, deBR_L, deEND_L;\r\n begin\r\n with Canvas do\r\n begin\r\n if FInsertSpecialSymbolAt = I then\r\n begin\r\n case FSpecialSymbol of\r\n ssyColon:\r\n begin\r\n Pt.X := Pt.X + FInterspace;\r\n Windows.SetPixel(Handle, Pt.X, Pt.Y + FDSize.Y div 3,\r\n ColorToRGB(CActive));\r\n Windows.SetPixel(Handle, Pt.X, Pt.Y + FDSize.Y - FDSize.Y div 3,\r\n ColorToRGB(CActive));\r\n Pt.X := Pt.X + FInterspace * 2;\r\n end;\r\n ssySlash:\r\n begin\r\n Windows.MoveToEx(Handle, Pt.X + FDSize.X, Pt.Y + 1, @OldPt);\r\n Windows.LineTo(Handle, Pt.X, Pt.Y + FDSize.Y);\r\n Pt.X := Pt.X + FDSize.X + FInterspace;\r\n end;\r\n ssyBackslash:\r\n begin\r\n Windows.MoveToEx(Handle, Pt.X, Pt.Y + 1, @OldPt);\r\n Windows.LineTo(Handle, Pt.X + FDSize.X, Pt.Y + FDSize.Y);\r\n Pt.X := Pt.X + FDSize.X + FInterspace;\r\n end;\r\n end;\r\n end;\r\n //OldColonpt.X:=Pt.X;\r\n if Pen.Width = 1 then\r\n S := 1\r\n else\r\n S := 0;\r\n R := Rect(Pt.X, Pt.Y, Pt.X + FDSize.X, FDSize.Y + Pt.Y);\r\n CenterY := R.Top + (FDSize.Y - Pen.Width) div 2;\r\n\r\n SChar := Str[I];\r\n if SChar = ' ' then\r\n D := 10\r\n else\r\n if (SChar = ',') or (SChar = '.') then\r\n D := 11\r\n else\r\n D := StrToInt(SChar);\r\n\r\n //...Draw Dot\r\n if Pt.X <= Width then\r\n if dlDOT in DigitsSet[D] then\r\n begin\r\n FOldDotPos := I;\r\n Windows.SetPixel(Handle, Pt.X, R.Bottom,\r\n ColorToRGB(CActive));\r\n Pt.X := Pt.X + FInterspace;\r\n end\r\n else\r\n begin ///...Draw Digit\r\n if dlT in DigitsSet[D] then\r\n Pen.Color := CActive\r\n else\r\n if SPassive then\r\n Pen.Color := CPassive\r\n else\r\n goto deC_L;\r\n MoveTo(R.Left + FGap, R.Top);\r\n LineTo(R.Right - FGap + S, R.Top);\r\n deC_L:\r\n if dlC in DigitsSet[D] then\r\n Pen.Color := CActive\r\n else\r\n if SPassive then\r\n Pen.Color := CPassive\r\n else\r\n goto deB_L;\r\n MoveTo(R.Left + FGap, CenterY);\r\n LineTo(R.Right - FGap + S, CenterY);\r\n deB_L:\r\n if dlB in DigitsSet[D] then\r\n Pen.Color := CActive\r\n else\r\n if SPassive then\r\n Pen.Color := CPassive\r\n else\r\n goto deTL_L;\r\n MoveTo(R.Left + FGap, R.Bottom);\r\n LineTo(R.Right - FGap + S, R.Bottom);\r\n deTL_L:\r\n if dlTL in DigitsSet[D] then\r\n Pen.Color := CActive\r\n else\r\n if SPassive then\r\n Pen.Color := CPassive\r\n else\r\n goto deTR_L;\r\n MoveTo(R.Left, R.Top + FGap);\r\n LineTo(R.Left, CenterY - FGap + S);\r\n deTR_L:\r\n if dlTR in DigitsSet[D] then\r\n Pen.Color := CActive\r\n else\r\n if SPassive then\r\n Pen.Color := CPassive\r\n else\r\n goto deBL_L;\r\n MoveTo(R.Right, R.Top + FGap);\r\n LineTo(R.Right, CenterY - FGap + S);\r\n deBL_L:\r\n if dlBL in DigitsSet[D] then\r\n Pen.Color := CActive\r\n else\r\n if SPassive then\r\n Pen.Color := CPassive\r\n else\r\n goto deBR_L;\r\n MoveTo(R.Left, R.Bottom - FGap);\r\n LineTo(R.Left, CenterY + Pen.Width - S + FGap);\r\n deBR_L:\r\n if dlBR in DigitsSet[D] then\r\n Pen.Color := CActive\r\n else\r\n if SPassive then\r\n Pen.Color := CPassive\r\n else\r\n goto deEND_L;\r\n MoveTo(R.Right, R.Bottom - FGap);\r\n LineTo(R.Right, CenterY + Pen.Width - S + FGap);\r\n deEND_L:\r\n Pt.X := Pt.X + FDSize.X + FInterspace;\r\n end;\r\n end;\r\n Result := Pt.X;\r\n end;\r\n\r\nbegin\r\n ClientR := GetClientRect;\r\n //--- gradient and Bevels\r\n if FGradient.Active then\r\n with FBevel, FGradient do\r\n begin\r\n InflateRect(ClientR, -FInteriorOffset, -FInteriorOffset);\r\n GradientBox(Canvas.Handle, ClientR, Gradient,\r\n Integer(BevelPenStyle), BevelPenWidth);\r\n end;\r\n if FBevel.Active then\r\n with FBevel do\r\n begin\r\n ClientR := ClientRect;\r\n Dec(ClientR.Right);\r\n Dec(ClientR.Bottom);\r\n Canvas.Pen.Width := BevelPenWidth;\r\n Canvas.Pen.Style := BevelPenStyle;\r\n ClientR := DrawBoxEx(Canvas.Handle, ClientR,\r\n Sides, Inner, Outer, Bold, 0, True);\r\n Inc(ClientR.Right);\r\n Inc(ClientR.Bottom);\r\n end;\r\n //InflateRect(ClientR,-InteriorOffset,-InteriorOffset);\r\n R := ClientR; //Dec( R.Right ); Dec( R.Bottom );\r\n Str := FloatToStr(FValue);\r\n if (DigitCount <> -1) and (DigitCount > Length(Str)) then\r\n for I := 1 to DigitCount - Length(Str) do\r\n Str := Str + '0';\r\n if FPositions > 0 then\r\n Str := Spaces(FPositions - Length(Str)) + Str;\r\n\r\n IWidth := 0;\r\n for I := 1 to Length(Str) do\r\n if Str[I] <> ',' then\r\n Inc(IWidth, FDSize.X + Interspace)\r\n else\r\n Inc(IWidth, Interspace);\r\n Inc(IWidth, Interspace);\r\n\r\n if (FInsertSpecialSymbolAt > 0) and (FInsertSpecialSymbolAt <= Length(Str)) then\r\n if FSpecialSymbol = ssyColon then\r\n Inc(IWidth, Interspace * 3)\r\n else\r\n Inc(IWidth, FDSize.X + Interspace);\r\n //else Inc( IWidth ,6 );\r\n case Alignment of\r\n taLeftJustify:\r\n XPos := Interspace;\r\n taCenter:\r\n XPos := (ClientR.Right - ClientR.Left - IWidth) div 2 + Interspace;\r\n else //taRightJustify\r\n XPos := ClientR.Right - ClientR.Left - IWidth + Interspace;\r\n end;\r\n YPos := (Height - FDSize.Y) div 2;\r\n I := Pos(',', Str);\r\n if (I <> 0) and (I <> FOldDotPos) then\r\n FNeedBackgroundPaint := True;\r\n //if (FInsertSpecialSymbolAt>0)and(OldSpSymbolxPos<>XPos) then FNeedBackgroundPaint:=True;\r\n with Canvas do\r\n begin\r\n if FNeedBackgroundPaint then\r\n FillBackground;\r\n Pen.Color := FActiveColor;\r\n Pen.Style := PenStyle;\r\n Pen.Width := FPenWidth;\r\n\r\n Pt.X := XPos;\r\n Pt.Y := YPos;\r\n SPassive := not FGradient.Active;\r\n for I := 1 to Length(Str) do\r\n Pt.X := DrawDigit(Pt, FActiveColor, FPassiveColor);\r\n end;\r\n FNeedBackgroundPaint := True;\r\nend;\r\n\r\nprocedure TJvgDigits.WMSize(var Msg: TWMSize);\r\nbegin\r\n FNeedBackgroundPaint := True;\r\nend;\r\n\r\nprocedure TJvgDigits.SmthChanged(Sender: TObject);\r\nbegin\r\n Repaint;\r\nend;\r\n\r\nprocedure TJvgDigits.SetValue(NewValue: Double);\r\nbegin\r\n try\r\n if FValue <> NewValue then\r\n begin\r\n FValue := NewValue;\r\n FNeedBackgroundPaint := FOldStrWidth <> Length(FloatToStr(FValue));\r\n if FNeedBackgroundPaint then\r\n FOldStrWidth := Length(FloatToStr(FValue));\r\n Repaint;\r\n end;\r\n except\r\n end;\r\nend;\r\n\r\nprocedure TJvgDigits.SetActiveColor(Value: TColor);\r\nbegin\r\n if FActiveColor <> Value then\r\n begin\r\n FActiveColor := Value;\r\n FNeedBackgroundPaint := False;\r\n Repaint;\r\n end;\r\nend;\r\n\r\nprocedure TJvgDigits.SetPassiveColor(Value: TColor);\r\nbegin\r\n if FPassiveColor <> Value then\r\n begin\r\n FPassiveColor := Value;\r\n FNeedBackgroundPaint := False;\r\n Repaint;\r\n end;\r\nend;\r\n\r\nprocedure TJvgDigits.SetBackgroundColor(Value: TColor);\r\nbegin\r\n if FBackgroundColor <> Value then\r\n begin\r\n FBackgroundColor := Value;\r\n FNeedBackgroundPaint := True;\r\n Repaint;\r\n end;\r\nend;\r\n\r\nprocedure TJvgDigits.SetPositions(Value: Word);\r\nbegin\r\n if FPositions <> Value then\r\n begin\r\n FPositions := Value;\r\n FNeedBackgroundPaint := True;\r\n Repaint;\r\n end;\r\nend;\r\n\r\nprocedure TJvgDigits.SetPenWidth(Value: Word);\r\nbegin\r\n if FPenWidth <> Value then\r\n begin\r\n FPenWidth := Value;\r\n FNeedBackgroundPaint := True;\r\n Repaint;\r\n end;\r\nend;\r\n\r\nprocedure TJvgDigits.SetInterspace(Value: Word);\r\nbegin\r\n if FInterspace <> Value then\r\n begin\r\n FInterspace := Value;\r\n FNeedBackgroundPaint := True;\r\n Repaint;\r\n end;\r\nend;\r\n\r\nprocedure TJvgDigits.SetGap(Value: Word);\r\nbegin\r\n if FGap <> Value then\r\n begin\r\n FGap := Value;\r\n FNeedBackgroundPaint := True;\r\n Repaint;\r\n end;\r\nend;\r\n\r\nprocedure TJvgDigits.SetTransparent(Value: Boolean);\r\nbegin\r\n if FTransparent <> Value then\r\n begin\r\n FTransparent := Value;\r\n FNeedBackgroundPaint := True;\r\n Repaint;\r\n end;\r\nend;\r\n\r\nprocedure TJvgDigits.SetAlignment(Value: TAlignment);\r\nbegin\r\n if FAlignment <> Value then\r\n begin\r\n FAlignment := Value;\r\n FNeedBackgroundPaint := True;\r\n Repaint;\r\n end;\r\nend;\r\n\r\nprocedure TJvgDigits.SetInteriorOffset(Value: Word);\r\nbegin\r\n if FInteriorOffset <> Value then\r\n begin\r\n FInteriorOffset := Value;\r\n FNeedBackgroundPaint := True;\r\n Repaint;\r\n end;\r\nend;\r\n\r\nprocedure TJvgDigits.SetInsertSpecialSymbolAt(Value: Integer);\r\nbegin\r\n if FInsertSpecialSymbolAt <> Value then\r\n begin\r\n FInsertSpecialSymbolAt := Value;\r\n FNeedBackgroundPaint := True;\r\n Repaint;\r\n end;\r\nend;\r\n\r\nprocedure TJvgDigits.SetPenStyle(Value: TPenStyle);\r\nbegin\r\n if FPenStyle <> Value then\r\n begin\r\n FPenStyle := Value;\r\n FNeedBackgroundPaint := False;\r\n Repaint;\r\n end;\r\nend;\r\n\r\nprocedure TJvgDigits.SetSpecialSymbol(Value: TJvgSpecialSymbol);\r\nbegin\r\n if FSpecialSymbol <> Value then\r\n begin\r\n FSpecialSymbol := Value;\r\n if Value = ssyNone then\r\n FInsertSpecialSymbolAt := -1;\r\n FNeedBackgroundPaint := True;\r\n Repaint;\r\n end;\r\nend;\r\n\r\nprocedure TJvgDigits.SetDigitCount(Value: Integer);\r\nbegin\r\n if FDigitCount <> Value then\r\n begin\r\n FDigitCount := Value;\r\n FNeedBackgroundPaint := True;\r\n Repaint;\r\n end;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvgDrawTab.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvgDrawTab.PAS, released on 2003-01-15.\r\n\r\nThe Initial Developer of the Original Code is Andrey V. Chudin, [chudin att yandex dott ru]\r\nPortions created by Andrey V. Chudin are Copyright (C) 2003 Andrey V. Chudin.\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\nMichael Beck [mbeck att bigfoot dott com].\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvgDrawTab.pas 13104 2011-09-07 06:50:43Z obones $\r\n\r\nunit JvgDrawTab;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, CommCtrl, Graphics, Classes, ExtCtrls,\r\n JvgTypes, JvgUtils, JvgTabComm;\r\n\r\nprocedure DrawOwnTab(DrawTabStr: TDRAWTABSTRUCT);\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvgDrawTab.pas $';\r\n Revision: '$Revision: 13104 $';\r\n Date: '$Date: 2011-09-07 08:50:43 +0200 (mer. 07 sept. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nprocedure DrawOwnTab(DrawTabStr: TDRAWTABSTRUCT);\r\nconst\r\n cWordWrap: array [Boolean] of UINT = (DT_SINGLELINE, DT_WORDBREAK);\r\nvar\r\n HndPen: HPEN;\r\n hOldPen: HPEN;\r\n R, R1, AddR, ItemR: TRect;\r\n TransparentColor: TCOLORREF;\r\n X, Y: Integer;\r\n Selected, Vert, Hor: Boolean;\r\n BWallpaper: Boolean;\r\n WallpaperOption: TglWallpaperOption;\r\n Size: TSIZE;\r\n OldFont: Windows.HFont;\r\n// GrFromColor, GrToColor: TColor;\r\nbegin\r\n if not Assigned(DrawTabStr.lpDrawItemStr) then\r\n Exit;\r\n with DrawTabStr, DrawTabStr.lpDrawItemStr^, DrawTabStr.BoxStyle do\r\n begin\r\n Selected := (itemState and ODS_SELECTED) <> 0;\r\n // WALLPAPER WORKS\r\n WallpaperOption := fwoNone;\r\n BWallpaper := IsItAFilledBitmap(Wallpaper.Bmp);\r\n if BWallpaper then\r\n begin\r\n if Wallpaper.Tile then\r\n WallpaperOption := fwoTile;\r\n //...calc and fill tabs background\r\n if (ItemID = UINT(TabsCount - 1)) and Wallpaper.FillCaptionBakgr then\r\n begin\r\n AddR := ClientR;\r\n ItemR := rcItem;\r\n AddR.Top := 0;\r\n AddR.Left := ItemR.Right;\r\n AddR.Bottom := ItemR.Bottom;\r\n if fButton then\r\n Inc(AddR.Bottom, 3)\r\n else\r\n Inc(AddR.Bottom, 2); //if Selected then AddR.Bottom:=AddR.Bottom-2;\r\n CreateBitmapExt(HDC, Wallpaper.Bmp, AddR, 0, 0,\r\n WallpaperOption, fdsDefault, False, 0, clBlack);\r\n end;\r\n //...calc client area exclude tabs and user-client area\r\n R := ClientR;\r\n case Position of\r\n fsdTop:\r\n begin\r\n R.Top := R.Top + rcItem.Bottom - rcItem.Top;\r\n if fButton then\r\n Inc(R.Top, 4)\r\n else\r\n if Selected then\r\n Dec(R.Top)\r\n else\r\n Inc(R.Top, 5);\r\n Dec(R.Right);\r\n Dec(R.Bottom);\r\n Inc(R.Left);\r\n end;\r\n fsdBottom:\r\n begin\r\n R.Bottom := R.Bottom - (rcItem.Bottom - rcItem.Top);\r\n if fButton then\r\n Dec(R.Bottom, 4)\r\n else\r\n if Selected then\r\n Dec(R.Bottom)\r\n else\r\n Dec(R.Bottom, 5);\r\n Dec(R.Right);\r\n Inc(R.Top);\r\n Inc(R.Left);\r\n end;\r\n fsdLeft:\r\n begin\r\n R.Left := R.Left + (rcItem.Right - rcItem.Left);\r\n if fButton then\r\n Inc(R.Left, 3)\r\n else\r\n if Selected then\r\n Dec(R.Left)\r\n else\r\n Inc(R.Left, 5);\r\n Dec(R.Right);\r\n Dec(R.Bottom);\r\n Inc(R.Top);\r\n end;\r\n fsdRight:\r\n begin\r\n R.Right := R.Right - (rcItem.Right - rcItem.Left);\r\n if fButton then\r\n Dec(R.Right, 4)\r\n else\r\n if Selected then\r\n Dec(R.Right)\r\n else\r\n Dec(R.Right, 5);\r\n Inc(R.Left);\r\n Dec(R.Bottom);\r\n Inc(R.Top);\r\n end;\r\n end;\r\n //...fill client exclude tabs\r\n if Wallpaper.FillClient then\r\n CreateBitmapExt(HDC, Wallpaper.Bmp, R, 0, 0,\r\n WallpaperOption, fdsDefault, False, 0, clBlack);\r\n //...calc tab to fill\r\n if Wallpaper.FillCaptions and Wallpaper.IncludeBevels then\r\n begin\r\n R := rcItem;\r\n if not fButton then\r\n case Position of\r\n fsdTop:\r\n Dec(R.Bottom);\r\n fsdLeft:\r\n Dec(R.Right);\r\n fsdRight:\r\n if not Selected then\r\n Dec(R.Left);\r\n end;\r\n CreateBitmapExt(HDC, Wallpaper.Bmp, R, 0, 0,\r\n WallpaperOption, fdsDefault, False, 0, clBlack);\r\n end;\r\n end;\r\n // CORRECT TAB RECT to draw bevels\r\n R := rcItem;\r\n if fButton then\r\n begin\r\n if not Selected then\r\n OffsetRect(R, -1, -1);\r\n end\r\n else\r\n begin\r\n if Selected then\r\n begin\r\n // InflateRect(R, 4, 4);\r\n HndPen := CreatePen(PS_SOLID, 1, ColorToRGB(clBtnFace));\r\n hOldPen := SelectObject(HDC, HndPen);\r\n case Position of\r\n fsdTop:\r\n begin {\r\n MoveToEx( HDC, rcItem.Left, rcItem.Bottom-2, nil );\r\n LineTo( HDC, rcItem.Right, rcItem.Bottom-2 );}\r\n R.Left := R.Left + 3;\r\n R.Right := R.Right - 4;\r\n R.Top := R.Top + 2;\r\n //if FInteriorOffset then InflateRect(R,1,0);\r\n end;\r\n fsdBottom:\r\n begin\r\n MoveToEx(HDC, rcItem.Left, rcItem.Top + 1, nil);\r\n LineTo(HDC, rcItem.Right - 2, rcItem.Top + 1);\r\n MoveToEx(HDC, rcItem.Left, rcItem.Top, nil);\r\n LineTo(HDC, rcItem.Right - 2, rcItem.Top);\r\n R.Left := R.Left + 3;\r\n R.Right := R.Right - 4;\r\n Dec(R.Bottom);\r\n //if FInteriorOffset then InflateRect(R,1,0);\r\n end;\r\n fsdLeft:\r\n begin\r\n Inc(R.Left, 2);\r\n Dec(R.Right, 2);\r\n Inc(R.Top, 2);\r\n Dec(R.Bottom, 2);\r\n //if FInteriorOffset then Inc(R.Bottom);\r\n end;\r\n fsdRight:\r\n begin\r\n MoveToEx(HDC, rcItem.Left, rcItem.Top, nil);\r\n LineTo(HDC, rcItem.Left, rcItem.Bottom - 2);\r\n MoveToEx(HDC, rcItem.Left + 1, rcItem.Top, nil);\r\n LineTo(HDC, rcItem.Left + 1, rcItem.Bottom - 2);\r\n Inc(R.Left, 0);\r\n Dec(R.Right, 4);\r\n Inc(R.Top, 2);\r\n Dec(R.Bottom, 2);\r\n //if FInteriorOffset then Inc(R.Bottom);\r\n end;\r\n end;\r\n DeleteObject(SelectObject(HDC, hOldPen));\r\n end\r\n else\r\n begin\r\n case Position of\r\n fsdTop:\r\n begin\r\n Inc(R.Left);\r\n Dec(R.Right, 2);\r\n OffsetRect(R, 0, 2);\r\n //if FInteriorOffset then InflateRect(R,1,0);\r\n end;\r\n fsdBottom:\r\n begin\r\n Inc(R.Left);\r\n Dec(R.Right, 2);\r\n if not Selected then\r\n OffsetRect(R, 0, -1);\r\n if not (fsdTop in Borders) then\r\n Dec(R.Top);\r\n //if FInteriorOffset then InflateRect(R,1,0);\r\n end;\r\n fsdLeft:\r\n begin\r\n Inc(R.Left, 2); {if FInteriorOffset then Inc(R.Bottom);}\r\n end;\r\n fsdRight:\r\n begin\r\n Dec(R.Right, 4); {if FInteriorOffset then Inc(R.Bottom);}\r\n end;\r\n end;\r\n end;\r\n Dec(R.Bottom, 2);\r\n end;\r\n // DRAW BEVELS\r\n if Assigned(Gradient) and Gradient.Active then\r\n begin\r\n // GrFromColor := Gradient.FRGBFromColor;\r\n // GrToColor := Gradient.FRGBToColor;\r\n // if BackgrColor_ > 0 then\r\n // begin\r\n // if ftoTabColorAsGradientFrom in Options then Gradient.FRGBFromColor := BackgrColor_;\r\n // if ftoTabColorAsGradientTo in Options then Gradient.FRGBToColor := BackgrColor_;\r\n // end;\r\n GradientBox(HDC, R, Gradient, Integer(psSolid), 1);\r\n // Gradient.FRGBFromColor := GrFromColor;\r\n // Gradient.FRGBToColor := GrToColor;\r\n end;\r\n\r\n if DrawTabStr.FlatButtons then\r\n InflateRect(R, 3, 3);\r\n R := DrawBoxEx(HDC, R, Borders, BevelInner, BevelOuter, Bold, BackgrColor_,\r\n (Wallpaper.FillCaptions and BWallpaper) or Gradient.Active);\r\n if DrawTabStr.FlatButtons then\r\n InflateRect(R, -3, -3);\r\n // DRAW caption BACKGROUND\r\n if Wallpaper.FillCaptions and not Wallpaper.IncludeBevels then\r\n CreateBitmapExt(HDC, Wallpaper.Bmp, R, 0, 0,\r\n WallpaperOption, fdsDefault, False, 0, clBlack);\r\n Inc(R.Bottom); //Inc(R.Right);\r\n // DRAW GLYPH\r\n R1 := R;\r\n Hor := (Position = fsdTop) or (Position = fsdBottom);\r\n Vert := not Hor;\r\n if IsItAFilledBitmap(Glyph) and not (ftoHideGlyphs in Options) then\r\n begin\r\n //if GlyphOption = fwoNone then ?\r\n case GlyphHAlign of\r\n fhaLeft:\r\n begin\r\n X := 1;\r\n if Hor then\r\n Inc(R1.Left, Glyph.Width + 1)\r\n end;\r\n fhaCenter:\r\n X := (R.Right - R.Left - Glyph.Width) div 2;\r\n else {fhaRight}\r\n X := R.Right - R.Left - Glyph.Width - 1;\r\n if Hor then\r\n Dec(R1.Right, Glyph.Width + 1);\r\n end;\r\n case GlyphVAlign of\r\n fvaTop:\r\n begin\r\n Y := 0;\r\n if Vert then\r\n Inc(R1.Top, Glyph.Height + 1);\r\n end;\r\n fvaCenter:\r\n Y := (R.Bottom - R.Top - Glyph.Height) div 2;\r\n else {fvaBottom}\r\n Y := R.Bottom - R.Top - Glyph.Height;\r\n if Vert then\r\n Dec(R1.Bottom, Glyph.Height + 1);\r\n end;\r\n TransparentColor := GetPixel(Glyph.Canvas.Handle, 0, Glyph.Height - 1);\r\n // MoveToEx( hDC, R1.Left+X, R1.Top+Y, nil );\r\n // LineTo( hDC, R1.Right, R1.Bottom );\r\n CreateBitmapExt(HDC, Glyph,\r\n R, X, Y, GlyphOption, fdsDefault,\r\n True, TransparentColor, clBlack);\r\n if GlyphOption <> fwoNone then\r\n R1 := R\r\n else\r\n R1.Left := R1.Left + 1;\r\n end; //...end draw glyph_\r\n\r\n // case Position of\r\n // fsdTop, fsdBottom: begin Inc(R1.Left,2); Dec(R1.Right,2); end;\r\n // end;\r\n\r\n if not (ftoExcludeGlyphs in Options) then\r\n R1 := R;\r\n SetBkMode(HDC, TRANSPARENT);\r\n OldFont := SelectObject(HDC, Font_.Handle);\r\n SetTextColor(HDC, ColorToRGB(Font_.Color));\r\n GetTextExtentPoint32(HDC, PChar(Caption), Length(Caption), Size);\r\n SelectObject(HDC, OldFont);\r\n X := 0;\r\n Y := 0;\r\n case FontDirection of\r\n fldLeftRight:\r\n begin\r\n DrawTextInRectWithAlign(HDC, R1, Caption,\r\n CaptionHAlign, CaptionVAlign,\r\n TextStyle, Font_, cWordWrap[ftoWordWrap in Options]);\r\n Exit;\r\n end;\r\n fldRightLeft:\r\n begin\r\n case DrawTabStr.BoxStyle.CaptionHAlign of\r\n fhaLeft:\r\n X := R1.Right;\r\n fhaCenter:\r\n X := R1.Left + (R1.Right - R1.Left + Size.cx) div 2;\r\n fhaRight:\r\n Y := R1.Left + Size.cx;\r\n end;\r\n case CaptionVAlign of\r\n fvaTop:\r\n Y := R1.Bottom;\r\n fvaCenter:\r\n Y := R1.Top + (R1.Bottom - R1.Top + Size.cy) div 2;\r\n fvaBottom:\r\n Y := R1.Top + Size.cy;\r\n end;\r\n end;\r\n fldDownUp:\r\n begin\r\n X := R1.Left;\r\n Y := R1.Bottom - 4;\r\n case CaptionHAlign of\r\n fhaCenter:\r\n Dec(Y, (R1.Bottom - R1.Top - Size.cx) div 2);\r\n fhaRight:\r\n Y := R1.Top + Size.cx + 3;\r\n end;\r\n case CaptionVAlign of\r\n fvaCenter:\r\n Inc(X, (R1.Right - R1.Left - Size.cy) div 2);\r\n fvaBottom:\r\n X := R1.Right - Size.cy - 1;\r\n end;\r\n end;\r\n else {fldUpDown}\r\n X := R1.Right;\r\n Y := R1.Top + 4;\r\n case CaptionHAlign of\r\n fhaCenter:\r\n Inc(Y, (R1.Bottom - R1.Top - Size.cx) div 2);\r\n fhaRight:\r\n Y := R1.Bottom - Size.cx - 3;\r\n end;\r\n case CaptionVAlign of\r\n fvaCenter:\r\n Dec(X, (R1.Right - R1.Left - Size.cy) div 2);\r\n fvaBottom:\r\n X := R1.Left + Size.cy;\r\n end;\r\n end;\r\n ExtTextOutExt(HDC, X, Y, R1, PChar(Caption), TextStyle, False, False, Font.Color, 0 {DelinColor},\r\n clBtnHighlight, clBtnShadow, nil, nil, Font_);\r\n end;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvgExport.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvgExport.PAS, released on 2003-01-15.\r\n\r\nThe Initial Developer of the Original Code is Andrey V. Chudin, [chudin att yandex dott ru]\r\nPortions created by Andrey V. Chudin are Copyright (C) 2003 Andrey V. Chudin.\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\nMichael Beck [mbeck att bigfoot dott com].\r\nBurov Dmitry, translation of russian text.\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvgExport.pas 12461 2009-08-14 17:21:33Z obones $\r\n\r\nunit JvgExport;\r\n\r\n{$I jvcl.inc}\r\n{$I windowsonly.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, Messages, Graphics, ExtCtrls, SysUtils, Classes, Controls, Forms,\r\n DB,\r\n {$IFDEF JVCL_USEQuickReport}\r\n QuickRpt, QRExport,\r\n {$ENDIF JVCL_USEQuickReport}\r\n JvgTypes;\r\n\r\ntype\r\n TOnExportProgress = procedure(Progress: Integer) of object;\r\n\r\n{$IFDEF JVCL_UseQuickReport}\r\nprocedure ExportToExcel(QuickRep: TCustomQuickRep);\r\n{$ENDIF JVCL_UseQuickReport}\r\nprocedure ExportDataSetToExcel(DataSet: TDataSet; OnExportProgress: TOnExportProgress);\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvgExport.pas $';\r\n Revision: '$Revision: 12461 $';\r\n Date: '$Date: 2009-08-14 19:21:33 +0200 (ven. 14 août 2009) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n ComObj,\r\n JclFileUtils,\r\n JvgUtils;\r\n\r\nconst\r\n cExcelApplication = 'Excel.Application';\r\n cReport = 'Report';\r\n\r\n{$IFDEF JVCL_UseQuickReport}\r\nprocedure ExportToExcel(QuickRep: TCustomQuickRep);\r\nvar\r\n P: PChar;\r\n XL: Variant;\r\n Sheet: Variant;\r\n I, J, RecNo: Integer;\r\n SL1, SL2: TStringList;\r\n AExportFilter: TQRCommaSeparatedFilter;\r\n MemStream: TMemoryStream;\r\n TempFileName: string;\r\n\r\n function DeleteEOLs(const Str: string): string;\r\n var\r\n I: Integer;\r\n begin\r\n Result := Str;\r\n for I := 1 to Length(Result) do\r\n if Result[I] = #13 then\r\n Result[I] := ' ';\r\n end;\r\n\r\nbegin\r\n try\r\n XL := GetActiveOleObject(cExcelApplication);\r\n except\r\n XL := CreateOleObject(cExcelApplication);\r\n end;\r\n\r\n TempFileName := PathGetTempPath + 'JvgExportToExcelTemp.txt';\r\n AExportFilter := TQRCommaSeparatedFilter.Create(TempFileName);\r\n try\r\n QuickRep.ExportToFilter(AExportFilter);\r\n finally\r\n AExportFilter.Free;\r\n end;\r\n\r\n XL.Visible := True;\r\n XL.WorkBooks.Add;\r\n XL.WorkBooks[XL.WorkBooks.Count].WorkSheets[1].Name := cReport;\r\n Sheet := XL.WorkBooks[XL.WorkBooks.Count].WorkSheets[cReport];\r\n\r\n SL1 := TStringList.Create;\r\n SL2 := TStringList.Create;\r\n try\r\n // Sheet.SetBackgroundPicture(FileName:=ExtractFilePath(ParamStr(0))+'data\\bg.JPG');\r\n // Sheet.Cells[1, 1] := 'Biblio'; Sheet.Cells[1, 1].Font.Color := $FFFFFF;\r\n // Sheet.Cells[2, 1] := 'Globus'; Sheet.Cells[2, 1].Font.Color := $FFFFFF;\r\n // Sheet.Columns[1].ColumnWidth := 11;\r\n\r\n RecNo := 1;\r\n Sheet.Cells[RecNo, 1] := 'Report created on ' + DateToStr(Date);\r\n Sheet.Cells[RecNo, 1].Font.Italic := True;\r\n Inc(RecNo);\r\n Sheet.Cells[RecNo, 1] := 'User ' + UserName;\r\n Sheet.Cells[RecNo, 1].Font.Italic := True;\r\n\r\n Inc(RecNo, 2);\r\n Sheet.Cells[RecNo, 1] := '';\r\n Sheet.Cells[RecNo, 1].Font.Bold := True;\r\n Sheet.Cells[RecNo, 1].Font.Size := 14;\r\n\r\n Inc(RecNo, 2);\r\n\r\n MemStream := TMemoryStream.Create;\r\n MemStream.LoadFromFile(TempFileName);\r\n P := MemStream.Memory;\r\n for I := 0 to MemStream.Size - 1 do\r\n if P[I] = Chr(0) then\r\n P[I] := ',';\r\n\r\n SL1.LoadFromStream(MemStream);\r\n MemStream.Free;\r\n for I := 0 to SL1.Count - 1 do\r\n begin\r\n SL2.CommaText := SL1[I];\r\n for J := 0 to SL2.Count - 1 do\r\n Sheet.Cells[RecNo, 1 + J] := SL2[J];\r\n Inc(RecNo);\r\n end;\r\n finally\r\n SL1.Free;\r\n SL2.Free;\r\n if FileExists(TempFileName) then\r\n DeleteFile(TempFileName);\r\n end;\r\nend;\r\n{$ENDIF JVCL_UseQuickReport}\r\n\r\nprocedure ExportDataSetToExcel(DataSet: TDataSet; OnExportProgress: TOnExportProgress);\r\nvar\r\n XL: Variant;\r\n Sheet: Variant;\r\n I, RecNo, ColIndex: Integer;\r\nbegin\r\n try\r\n XL := GetActiveOleObject(cExcelApplication);\r\n except\r\n XL := CreateOleObject(cExcelApplication);\r\n end;\r\n\r\n XL.Visible := True;\r\n XL.WorkBooks.Add;\r\n XL.WorkBooks[XL.WorkBooks.Count].WorkSheets[1].Name := cReport;\r\n Sheet := XL.WorkBooks[XL.WorkBooks.Count].WorkSheets[cReport];\r\n // Sheet.SetBackgroundPicture(FileName:=ExtractFilePath(ParamStr(0))+'bg.JPG');\r\n\r\n // Sheet.Cells[1, 1] := 'Biblio'; Sheet.Cells[1, 1].Font.Bold := True; Sheet.Cells[1, 1].Font.Color := clWhite;\r\n // Sheet.Cells[2, 1] := 'Globus'; Sheet.Cells[2, 1].Font.Bold := True; Sheet.Cells[2, 1].Font.Color := clWhite;\r\n\r\n RecNo := 1;\r\n Sheet.Cells[RecNo, 2] := 'Document created on ' + DateToStr(Date) + ' ' + TimeToStr(Time);\r\n Sheet.Cells[RecNo, 2].Font.Italic := True;\r\n Inc(RecNo);\r\n Sheet.Cells[RecNo, 2] := 'User: ' + ComputerName + ' / ' + UserName;\r\n Sheet.Cells[RecNo, 2].Font.Italic := True;\r\n Inc(RecNo);\r\n Sheet.Cells[RecNo, 2] := 'Program: ' + ExtractFileName(ParamStr(0));\r\n Sheet.Cells[RecNo, 2].Font.Italic := True;\r\n\r\n // \r\n { Header [translated] }\r\n Inc(RecNo, 3);\r\n ColIndex := 0;\r\n for I := 0 to DataSet.FieldCount - 1 do\r\n if DataSet.Fields[I].Visible then\r\n begin\r\n if DataSet.Fields[I].DisplayLabel <> '' then\r\n Sheet.Cells[RecNo, 2 + ColIndex] := DataSet.Fields[I].DisplayLabel\r\n else\r\n Sheet.Cells[RecNo, 2 + ColIndex] := DataSet.Fields[I].FieldName;\r\n Sheet.Cells[RecNo, 2 + ColIndex].Font.Bold := True;\r\n Sheet.Cells[RecNo, 2 + ColIndex].Font.Size := 10;\r\n Inc(ColIndex);\r\n end;\r\n\r\n // \r\n { Data has begun to pass in [translated] }\r\n DataSet.First;\r\n Inc(RecNo, 3);\r\n while not DataSet.Eof do\r\n begin\r\n ColIndex := 0;\r\n for I := 0 to DataSet.FieldCount - 1 do\r\n if DataSet.Fields[I].Visible then\r\n begin\r\n Sheet.Cells[RecNo, 2 + ColIndex] := DataSet.Fields[I].AsString;\r\n Inc(ColIndex);\r\n end;\r\n DataSet.Next;\r\n if Assigned(OnExportProgress) then\r\n OnExportProgress(Round((DataSet.RecNo * 100.0) / DataSet.RecordCount));\r\n Inc(RecNo);\r\n end;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvgExportComponents.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvgExportComponents.PAS, released on 2003-01-15.\r\n\r\nThe Initial Developer of the Original Code is Andrey V. Chudin, [chudin att yandex dott ru]\r\nPortions created by Andrey V. Chudin are Copyright (C) 2003 Andrey V. Chudin.\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\nMichael Beck [mbeck att bigfoot dott com].\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvgExportComponents.pas 13198 2012-02-17 08:50:31Z outchy $\r\n\r\nunit JvgExportComponents;\r\n\r\n{$I jvcl.inc}\r\n{$I windowsonly.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, Messages, SysUtils, Classes, Graphics,\r\n Controls, Forms, Dialogs, DB,\r\n JvComponentBase;\r\n\r\ntype\r\n TJvExportCaptions = (fecDisplayLabels, fecFieldNames, fecNone);\r\n TJvExportGetValue = procedure(Sender: TObject; const Field: TField; var Caption: string) of object;\r\n // RDB Added TDataSet to Signature\r\n TJvExportRecordEvent = procedure(Sender: TObject; const DataSet: TDataSet;\r\n var AllowExport: Boolean) of object;\r\n // RDB Added TField to Signature\r\n TJvExportFieldEvent = procedure(Sender: TObject; const Field: TField; var\r\n FieldValue: string) of object;\r\n\r\n TJvExportProgressEvent = procedure(Sender: TObject; Min, Max, Position: Integer;\r\n const Msg: string) of object;\r\n\r\n TJvGetLineFontEvent = procedure(Sender: TObject; LineNo: Integer;\r\n const Value: string; Font: TFont) of object;\r\n\r\n EJvgExportException = class(Exception);\r\n\r\n TJvgExportOptions = set of (jeoOutputInvisibleColumns, jeoOutputFormattedStrings);\r\n\r\n TJvgCommonExport = class(TJvComponent)\r\n private\r\n FOptions: TJvgExportOptions;\r\n FSaveToFileName: string;\r\n FDataSet: TDataSet;\r\n FOnExportField: TJvExportFieldEvent;\r\n FOnExportRecord: TJvExportRecordEvent;\r\n FOnGetCaption: TJvExportGetValue;\r\n FCaptions: TJvExportCaptions;\r\n FTransliterateRusToEng: Boolean;\r\n FMaxFieldSize: Integer;\r\n FOnGetTableName: TJvExportGetValue;\r\n FOnProgress: TJvExportProgressEvent;\r\n procedure SetCaptions(const Value: TJvExportCaptions);\r\n procedure SetDataSet(const Value: TDataSet);\r\n procedure SetSaveToFileName(const Value: string);\r\n procedure SetMaxFieldSize(const Value: Integer);\r\n procedure SetTransliterateRusToEng(const Value: Boolean);\r\n protected\r\n function GetFieldValue(const Field: TField): string;\r\n procedure DoGetTableName(var ATableName: string); virtual;\r\n procedure DoProgress(Min, Max, Position: Integer; const Msg: string); virtual;\r\n public\r\n procedure Execute; virtual;\r\n protected\r\n property DataSet: TDataSet read FDataSet write SetDataSet;\r\n property Captions: TJvExportCaptions read FCaptions write SetCaptions;\r\n property SaveToFileName: string read FSaveToFileName write SetSaveToFileName;\r\n property TransliterateRusToEng: Boolean read FTransliterateRusToEng write SetTransliterateRusToEng;\r\n property MaxFieldSize: Integer read FMaxFieldSize write SetMaxFieldSize;\r\n property Options: TJvgExportOptions read FOptions write FOptions default [];\r\n\r\n property OnGetCaption: TJvExportGetValue read FOnGetCaption write FOnGetCaption;\r\n property OnExportRecord: TJvExportRecordEvent read FOnExportRecord write FOnExportRecord;\r\n property OnExportField: TJvExportFieldEvent read FOnExportField write FOnExportField;\r\n property OnProgress: TJvExportProgressEvent read FOnProgress write FOnProgress;\r\n property OnGetTableName: TJvExportGetValue read FOnGetTableName write FOnGetTableName;\r\n end;\r\n\r\n TJvgExportExcel = class(TJvgCommonExport)\r\n private\r\n FHeader: TStringList;\r\n FFooter: TStringList;\r\n FBackgroundPicture: TFileName;\r\n FAutoColumnFit: Boolean;\r\n FExcelVisible: Boolean;\r\n FCloseExcel: Boolean;\r\n FOnGetFooterLineFont: TJvGetLineFontEvent;\r\n FOnGetHeaderLineFont: TJvGetLineFontEvent;\r\n FSubHeader: TStringList;\r\n FSubHeaderFont: TFont;\r\n FHeaderFont: TFont;\r\n FFooterFont: TFont;\r\n FForceTextFormat: Boolean;\r\n FOnGetSubHeaderLineFont: TJvGetLineFontEvent;\r\n function GetHeader: TStrings;\r\n function GetFooter: TStrings;\r\n function GetSubHeader: TStrings;\r\n procedure SetHeader(const Value: TStrings);\r\n procedure SetFooter(const Value: TStrings);\r\n procedure SetBackgroundPicture(const Value: TFileName);\r\n procedure SetAutoColumnFit(const Value: Boolean);\r\n procedure SetExcelVisible(const Value: Boolean);\r\n procedure SetCloseExcel(const Value: Boolean);\r\n procedure SetSubHeader(const Value: TStrings);\r\n procedure SetFooterFont(const Value: TFont);\r\n procedure SetHeaderFont(const Value: TFont);\r\n procedure SetSubHeaderFont(const Value: TFont);\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n procedure Execute; override;\r\n published\r\n property DataSet;\r\n property Captions;\r\n property SaveToFileName;\r\n property TransliterateRusToEng;\r\n property MaxFieldSize;\r\n property Header: TStrings read GetHeader write SetHeader;\r\n property SubHeader: TStrings read GetSubHeader write SetSubHeader;\r\n property Footer: TStrings read GetFooter write SetFooter;\r\n property HeaderFont: TFont read FHeaderFont write SetHeaderFont;\r\n property SubHeaderFont: TFont read FSubHeaderFont write SetSubHeaderFont;\r\n property FooterFont: TFont read FFooterFont write SetFooterFont;\r\n property AutoColumnFit: Boolean read FAutoColumnFit write SetAutoColumnFit default True;\r\n property BackgroundPicture: TFileName read FBackgroundPicture write\r\n SetBackgroundPicture;\r\n property ExcelVisible: Boolean read FExcelVisible write SetExcelVisible;\r\n property ForceTextFormat: Boolean read FForceTextFormat write FForceTextFormat default False;\r\n property CloseExcel: Boolean read FCloseExcel write SetCloseExcel;\r\n\r\n property Options;\r\n\r\n property OnGetHeaderLineFont: TJvGetLineFontEvent read FOnGetHeaderLineFont write FOnGetHeaderLineFont;\r\n property OnGetSubHeaderLineFont: TJvGetLineFontEvent read FOnGetSubHeaderLineFont write FOnGetSubHeaderLineFont;\r\n property OnGetFooterLineFont: TJvGetLineFontEvent read FOnGetFooterLineFont write FOnGetFooterLineFont;\r\n property OnGetCaption;\r\n property OnExportRecord;\r\n property OnExportField;\r\n end;\r\n\r\n TJvCreateDataset = procedure(Sender: TObject; var DataSet: TDataSet) of object;\r\n\r\n TJvgExportDataset = class(TJvgCommonExport)\r\n private\r\n FOnCreateDest: TJvCreateDataset;\r\n FOnSaveDest: TJvCreateDataset;\r\n public\r\n procedure Execute; override;\r\n published\r\n property DataSet;\r\n property Captions;\r\n property Options;\r\n property MaxFieldSize;\r\n property OnGetCaption;\r\n property OnExportRecord;\r\n property OnExportField;\r\n property OnCreateDest: TJvCreateDataset read FOnCreateDest write FOnCreateDest;\r\n property OnSaveDest: TJvCreateDataset read FOnSaveDest write FOnSaveDest;\r\n end;\r\n\r\n TJvgExportXML = class(TJvgCommonExport)\r\n public\r\n procedure Execute; override;\r\n published\r\n property DataSet;\r\n property Captions;\r\n property SaveToFileName;\r\n property Options;\r\n property TransliterateRusToEng;\r\n property MaxFieldSize;\r\n property OnGetCaption;\r\n property OnExportRecord;\r\n property OnExportField;\r\n property OnProgress;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvgExportComponents.pas $';\r\n Revision: '$Revision: 13198 $';\r\n Date: '$Date: 2012-02-17 09:50:31 +0100 (ven. 17 févr. 2012) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n ComObj, FileCtrl,\r\n JvResources,\r\n JvConsts, JvSimpleXml,\r\n JvgUtils;\r\n\r\nfunction DeleteFileEx(const FileName: string): Boolean;\r\nconst\r\n cSuffix = '_del_';\r\nbegin\r\n if FileExists(FileName) then\r\n begin\r\n Result := RenameFile(FileName, FileName + cSuffix);\r\n if Result then\r\n Result := DeleteFile(FileName + cSuffix);\r\n end\r\n else\r\n Result := False;\r\nend;\r\n\r\n//=== { TJvgCommonExport } ===================================================\r\n\r\nprocedure TJvgCommonExport.Execute;\r\nbegin\r\n if not Assigned(DataSet) then\r\n raise EJvgExportException.CreateRes(@RsEDataSetIsUnassigned);\r\n DataSet.Active := True;\r\n if SaveToFileName <> '' then\r\n {$IFDEF RTL220_UP}SysUtils.{$ENDIF RTL220_UP}ForceDirectories(ExtractFilePath(SaveToFileName));\r\nend;\r\n\r\nprocedure TJvgCommonExport.SetCaptions(const Value: TJvExportCaptions);\r\nbegin\r\n FCaptions := Value;\r\nend;\r\n\r\nprocedure TJvgCommonExport.SetDataSet(const Value: TDataSet);\r\nbegin\r\n FDataSet := Value;\r\nend;\r\n\r\nprocedure TJvgCommonExport.SetMaxFieldSize(const Value: Integer);\r\nbegin\r\n FMaxFieldSize := Value;\r\nend;\r\n\r\nprocedure TJvgCommonExport.SetSaveToFileName(const Value: string);\r\nbegin\r\n FSaveToFileName := Trim(Value);\r\nend;\r\n\r\nprocedure TJvgCommonExport.SetTransliterateRusToEng(const Value: Boolean);\r\nbegin\r\n FTransliterateRusToEng := Value;\r\nend;\r\n\r\nprocedure TJvgCommonExport.DoProgress(Min, Max, Position: Integer; const Msg: string);\r\nbegin\r\n if Assigned(FOnProgress) then\r\n FOnProgress(Self, Min, Max, Position, Msg);\r\nend;\r\n\r\nfunction TJvgCommonExport.GetFieldValue(const Field: TField): string;\r\nbegin\r\n if jeoOutputFormattedStrings in Options then\r\n Result := Field.DisplayText\r\n else\r\n Result := Field.AsString;\r\n if Assigned(FOnExportField) then\r\n FOnExportField(Self, Field, Result);\r\n\r\n if FTransliterateRusToEng then\r\n Result := Transliterate(Result, True);\r\n\r\n if (FMaxFieldSize > 0) and (Field.DataType in [ftString, ftMemo, ftFmtMemo]) then\r\n if Length(Result) > FMaxFieldSize then\r\n Result := Copy(Result, 1, FMaxFieldSize) + '...';\r\nend;\r\n\r\nprocedure TJvgCommonExport.DoGetTableName(var ATableName: string);\r\nbegin\r\n if Assigned(FOnGetTableName) then\r\n FOnGetTableName(Self, nil, ATableName);\r\nend;\r\n\r\n//=== { TJvgExportExcel } ====================================================\r\n\r\nconstructor TJvgExportExcel.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FFooter := TStringList.Create;\r\n FHeader := TStringList.Create;\r\n FSubHeader := TStringList.Create;\r\n FHeaderFont := TFont.Create;\r\n FSubHeaderFont := TFont.Create;\r\n FFooterFont := TFont.Create;\r\n //...defaults\r\n FHeaderFont.Size := 12;\r\n FHeaderFont.Style := [fsBold];\r\n FSubHeaderFont.Size := 10;\r\n FAutoColumnFit := True;\r\n FOptions := [];\r\nend;\r\n\r\ndestructor TJvgExportExcel.Destroy;\r\nbegin\r\n FFooter.Free;\r\n FHeader.Free;\r\n FSubHeader.Free;\r\n FHeaderFont.Free;\r\n FSubHeaderFont.Free;\r\n FFooterFont.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvgExportExcel.Execute;\r\nvar\r\n XL: Variant;\r\n Sheet: Variant;\r\n AllowExportRecord: Boolean;\r\n I, RecCount, RecNo, ColNo, OldRecNo: Integer;\r\n CellFont: TFont;\r\n\r\n procedure InsertStrings(Strings: TStrings; Font: TFont; GetLineFontEvent:\r\n TJvGetLineFontEvent);\r\n var\r\n I: Integer;\r\n begin\r\n for I := 0 to Strings.Count - 1 do\r\n begin\r\n Sheet.Cells[RecNo, ColNo] := Strings[I];\r\n CellFont.Assign(Font);\r\n if Assigned(GetLineFontEvent) then\r\n GetLineFontEvent(Self, I, Strings[I], CellFont);\r\n\r\n Sheet.Cells[RecNo, ColNo].Font.Size := CellFont.Size;\r\n Sheet.Cells[RecNo, ColNo].Font.Color := CellFont.Color;\r\n if fsBold in CellFont.Style then\r\n Sheet.Cells[RecNo, ColNo].Font.Bold := True;\r\n if fsItalic in CellFont.Style then\r\n Sheet.Cells[RecNo, ColNo].Font.Italic := True;\r\n Inc(RecNo);\r\n end;\r\n end;\r\n\r\nbegin\r\n inherited Execute;\r\n\r\n try\r\n XL := GetActiveOleObject('Excel.Application');\r\n except\r\n try\r\n XL := CreateOleObject('Excel.Application');\r\n except\r\n raise EJvgExportException.CreateRes(@RsEExcelNotAvailable);\r\n end;\r\n end;\r\n\r\n XL.Visible := FExcelVisible;\r\n XL.WorkBooks.Add;\r\n XL.WorkBooks[XL.WorkBooks.Count].WorkSheets[1].Name := 'Report';\r\n Sheet := XL.WorkBooks[XL.WorkBooks.Count].WorkSheets['Report'];\r\n if (BackgroundPicture <> '') and FileExists(BackgroundPicture) then\r\n // (rom) This is correct Delphi. See \"positional parameters\" in the Delphi help.\r\n Sheet.SetBackgroundPicture(FileName := BackgroundPicture);\r\n\r\n CellFont := TFont.Create;\r\n try\r\n RecNo := 1;\r\n ColNo := 1;\r\n\r\n Inc(RecNo, Header.Count + SubHeader.Count);\r\n\r\n // HEADERS\r\n if FCaptions <> fecNone then\r\n for I := 0 to DataSet.FieldCount - 1 do\r\n begin\r\n if not DataSet.Fields[I].Visible and not (jeoOutputInvisibleColumns in Options) then\r\n begin\r\n Dec(ColNo);\r\n Continue;\r\n end;\r\n\r\n case FCaptions of\r\n fecDisplayLabels:\r\n if DataSet.Fields[I].DisplayLabel <> '' then\r\n Sheet.Cells[RecNo, ColNo + I] := DataSet.Fields[I].DisplayLabel\r\n else\r\n Sheet.Cells[RecNo, ColNo + I] := DataSet.Fields[I].FieldName;\r\n fecFieldNames:\r\n Sheet.Cells[RecNo, ColNo + I] := DataSet.Fields[I].FieldName;\r\n end;\r\n Sheet.Cells[RecNo, ColNo + I].Font.Bold := True;\r\n Sheet.Cells[RecNo, ColNo + I].Font.Size := 10;\r\n end;\r\n\r\n Inc(RecNo);\r\n DataSet.First;\r\n RecCount := DataSet.RecordCount;\r\n while not DataSet.Eof do\r\n begin\r\n ColNo := 1;\r\n AllowExportRecord := True;\r\n if Assigned(FOnExportRecord) then\r\n FOnExportRecord(Self, DataSet, AllowExportRecord);\r\n\r\n if AllowExportRecord then\r\n begin\r\n // DATA\r\n for I := 0 to DataSet.FieldCount - 1 do\r\n begin\r\n if not DataSet.Fields[I].Visible and not (jeoOutputInvisibleColumns in Options) then\r\n begin\r\n Dec(ColNo);\r\n Continue;\r\n end;\r\n\r\n if not (DataSet.Fields[I].DataType in [ftBlob, ftGraphic,\r\n ftParadoxOle, ftDBaseOle, ftTypedBinary,\r\n ftReference, ftDataSet, ftOraBlob, ftOraClob, ftInterface,\r\n ftIDispatch]) then\r\n begin\r\n if ForceTextFormat then\r\n Sheet.Cells.NumberFormat := '@';\r\n Sheet.Cells[RecNo, ColNo + I] := GetFieldValue(DataSet.Fields[I]);\r\n end;\r\n end;\r\n end;\r\n DoProgress(0, RecCount, RecNo, '');\r\n Inc(RecNo);\r\n DataSet.Next;\r\n end;\r\n\r\n if FAutoColumnFit then\r\n for I := 0 to DataSet.FieldCount - 1 + ColNo - 1 do\r\n Sheet.Columns[I + 1].EntireColumn.AutoFit;\r\n\r\n ColNo := 1;\r\n OldRecNo := RecNo;\r\n RecNo := 1;\r\n InsertStrings(Header, HeaderFont, FOnGetHeaderLineFont);\r\n InsertStrings(SubHeader, SubHeaderFont, FOnGetSubHeaderLineFont);\r\n RecNo := OldRecNo + 1;\r\n InsertStrings(Footer, SubHeaderFont, FOnGetSubHeaderLineFont);\r\n\r\n if Length(FSaveToFileName) > 0 then\r\n begin\r\n if ExtractFileExt(FSaveToFileName) = '' then\r\n FSaveToFileName := ChangeFileExt(FSaveToFileName, '.xls');\r\n DeleteFileEx(FSaveToFileName);\r\n\r\n if FSaveToFileName <> '' then\r\n XL.WorkBooks[XL.WorkBooks.Count].SaveAs(FSaveToFileName);\r\n end;\r\n finally\r\n try\r\n if CloseExcel then\r\n XL.Quit;\r\n except;\r\n end;\r\n CellFont.Free;\r\n end;\r\nend;\r\n\r\nprocedure TJvgExportExcel.SetAutoColumnFit(const Value: Boolean);\r\nbegin\r\n FAutoColumnFit := Value;\r\nend;\r\n\r\nprocedure TJvgExportExcel.SetBackgroundPicture(const Value: TFileName);\r\nbegin\r\n FBackgroundPicture := Value;\r\nend;\r\n\r\nprocedure TJvgExportExcel.SetCloseExcel(const Value: Boolean);\r\nbegin\r\n FCloseExcel := Value;\r\nend;\r\n\r\nprocedure TJvgExportExcel.SetExcelVisible(const Value: Boolean);\r\nbegin\r\n FExcelVisible := Value;\r\nend;\r\n\r\nfunction TJvgExportExcel.GetFooter: TStrings;\r\nbegin\r\n Result := FFooter;\r\nend;\r\n\r\nprocedure TJvgExportExcel.SetFooter(const Value: TStrings);\r\nbegin\r\n FFooter.Assign(Value);\r\nend;\r\n\r\nprocedure TJvgExportExcel.SetFooterFont(const Value: TFont);\r\nbegin\r\n FFooterFont.Assign(Value);\r\nend;\r\n\r\nfunction TJvgExportExcel.GetHeader: TStrings;\r\nbegin\r\n Result := FHeader;\r\nend;\r\n\r\nprocedure TJvgExportExcel.SetHeader(const Value: TStrings);\r\nbegin\r\n FHeader.Assign(Value);\r\nend;\r\n\r\nprocedure TJvgExportExcel.SetHeaderFont(const Value: TFont);\r\nbegin\r\n FHeaderFont.Assign(Value);\r\nend;\r\n\r\nfunction TJvgExportExcel.GetSubHeader: TStrings;\r\nbegin\r\n Result := FSubHeader;\r\nend;\r\n\r\nprocedure TJvgExportExcel.SetSubHeader(const Value: TStrings);\r\nbegin\r\n FSubHeader.Assign(Value);\r\nend;\r\n\r\nprocedure TJvgExportExcel.SetSubHeaderFont(const Value: TFont);\r\nbegin\r\n FSubHeaderFont.Assign(Value);\r\nend;\r\n\r\n//=== { TJvgExportDataset } ==================================================\r\n\r\nprocedure TJvgExportDataset.Execute;\r\nvar\r\n I, RecNo, RecCount: Integer;\r\n Dest: TDataSet;\r\n AllowExportRecord: Boolean;\r\n FieldType: TFieldType;\r\nbegin\r\n inherited Execute;\r\n\r\n Dest := nil;\r\n if Assigned(FOnCreateDest) then\r\n FOnCreateDest(Self, Dest);\r\n if Dest = nil then\r\n Exit;\r\n Dest.Close;\r\n for I := 0 to DataSet.FieldCount - 1 do\r\n begin\r\n FieldType := DataSet.Fields[I].DataType;\r\n if FieldType = ftAutoInc then\r\n FieldType := ftInteger;\r\n if not DataSet.DefaultFields then\r\n Dest.FieldDefs.Add(DataSet.Fields[I].Name, FieldType,\r\n DataSet.Fields[I].Size, DataSet.Fields[I].Required);\r\n end;\r\n\r\n Dest.Open;\r\n try\r\n DataSet.First;\r\n RecCount := DataSet.RecordCount;\r\n RecNo := 0;\r\n while not DataSet.Eof do\r\n begin\r\n AllowExportRecord := True;\r\n if Assigned(FOnExportRecord) then\r\n FOnExportRecord(Self, DataSet, AllowExportRecord);\r\n if AllowExportRecord then\r\n begin\r\n Dest.Append;\r\n for I := 0 to DataSet.FieldCount - 1 do\r\n if DataSet.Fields[I].DataType in [ftString, ftMemo] then\r\n Dest.Fields[I].Value := GetFieldValue(DataSet.Fields[I])\r\n else\r\n Dest.Fields[I].Value := DataSet.Fields[I].Value;\r\n Dest.Post;\r\n end;\r\n DoProgress(0, RecCount, RecNo, '');\r\n Inc(RecNo);\r\n DataSet.Next;\r\n end;\r\n DoProgress(0, RecCount, RecCount, '');\r\n if Assigned(FOnSaveDest) then\r\n FOnSaveDest(Self, Dest);\r\n finally\r\n if Dest <> nil then\r\n Dest.Close;\r\n FreeAndNil(Dest);\r\n end;\r\nend;\r\n\r\nprocedure TJvgExportXML.Execute;\r\nvar\r\n RecNo, RecCount: Integer;\r\n XML: TJvSimpleXML;\r\n Header: TJvSimpleXMLElemClassic;\r\n Table: TJvSimpleXMLElemClassic;\r\n Field: TJvSimpleXMLElemClassic;\r\n Records: TJvSimpleXMLElemClassic;\r\n XMLRecord: TJvSimpleXMLElemClassic;\r\n AllowExportRecord: Boolean;\r\n FieldValue: string;\r\n I: Integer;\r\n\r\n function CreateNode(const Name: string; Base: TJvSimpleXMLElemClassic):\r\n TJvSimpleXMLElemClassic;\r\n begin\r\n Result := TJvSimpleXMLElemClassic.Create;\r\n Base.Items.Add(Result);\r\n Result.Name := Name;\r\n end;\r\n\r\n procedure AddFieldName(Field: TJvSimpleXMLElemClassic);\r\n var\r\n Caption: string;\r\n begin\r\n Caption := '';\r\n if Self.FCaptions = fecDisplayLabels then\r\n Caption := DataSet.Fields[I].DisplayName;\r\n if Self.FCaptions = fecFieldNames then\r\n Caption := DataSet.Fields[I].FullName;\r\n if Self.FCaptions = fecNone then\r\n (* empty *);\r\n\r\n if Assigned(FOnGetCaption) then\r\n FOnGetCaption(Self, DataSet.Fields[I], Caption);\r\n Field.Properties.Add('Name', Caption);\r\n end;\r\n\r\nbegin\r\n XML := TJvSimpleXML.Create(Self);\r\n XML.Root.Name := 'Database';\r\n XML.IndentString := ' ';\r\n\r\n Header := CreateNode('Header', XML.Root);\r\n Table := CreateNode('Table', Header);\r\n DataSet.Open;\r\n RecCount := DataSet.RecordCount;\r\n for I := 0 to DataSet.FieldCount - 1 do\r\n begin\r\n Field := CreateNode('Field', Table);\r\n\r\n AddFieldName(Field);\r\n Field.Properties.Add('Size', DataSet.Fields[I].Size);\r\n Field.Properties.Add('DataType', FieldTypeNames[DataSet.Fields[I].DataType]);\r\n Field.Properties.Add('Blob', BoolToStr(DataSet.Fields[I].IsBlob, True));\r\n Field.Properties.Add('Required', BoolToStr(DataSet.Fields[I].Required, True));\r\n end;\r\n Records := CreateNode('Records', XML.Root);\r\n DataSet.First;\r\n RecNo := 0;\r\n while not DataSet.Eof do\r\n begin\r\n Inc(RecNo);\r\n XMLRecord := CreateNode('Record', Records);\r\n XMLRecord.Properties.Add('Nr', RecNo);\r\n AllowExportRecord := True;\r\n if Assigned(FOnExportRecord) then\r\n FOnExportRecord(Self, DataSet, AllowExportRecord);\r\n if AllowExportRecord then\r\n for I := 0 to DataSet.FieldCount - 1 do\r\n if not (DataSet.Fields[I].DataType in [ftBlob, ftGraphic,\r\n ftParadoxOle, ftDBaseOle, ftTypedBinary,\r\n ftReference, ftDataSet, ftOraBlob, ftOraClob, ftInterface,\r\n ftIDispatch]) then\r\n begin\r\n Field := CreateNode('RecordField', XMLRecord);\r\n AddFieldName(Field);\r\n FieldValue := DataSet.Fields[I].AsString;\r\n if Assigned(FOnExportField) then\r\n FOnExportField(Self, DataSet.Fields[I], FieldValue);\r\n Field.Value := FieldValue;\r\n end;\r\n DoProgress(0, RecCount, RecNo, '');\r\n DataSet.Next;\r\n end;\r\n DoProgress(0, RecCount, RecCount, '');\r\n\r\n XML.SaveToFile(Self.FSaveToFileName);\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvgFileIterator.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvgFileIterator.PAS, released on 2003-01-15.\r\n\r\nThe Initial Developer of the Original Code is Andrey V. Chudin, [chudin att yandex dott ru]\r\nPortions created by Andrey V. Chudin are Copyright (C) 2003 Andrey V. Chudin.\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\nMichael Beck [mbeck att bigfoot dott com].\r\nBurov Dmitry, translation of russian text.\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nDescription:\r\n ???? ?????FindFirst/Next ???????\r\n Iterator, searching files by FindFirst/Next including subdirs [translated]\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvgFileIterator.pas 12461 2009-08-14 17:21:33Z obones $\r\n\r\nunit JvgFileIterator;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, Classes, SysUtils;\r\n\r\ntype\r\n PSearchData = ^TSearchData;\r\n TSearchData = record\r\n sr: TSearchRec;\r\n Path: string;\r\n end;\r\n\r\n TJvgFileIterator = class(TObject)\r\n private\r\n // FileExt: string;\r\n FPath: string;\r\n FAttr: Integer;\r\n FRecurse: Boolean;\r\n FPCurrentItem: PSearchData;\r\n FLSearchRecs: TList;\r\n FSLFileExt: TStringList;\r\n FLastSearchResult: Integer;\r\n FFindOpened: Boolean;\r\n function CheckResult(Value: Integer): Boolean;\r\n procedure FindClose(Destroying: Boolean = False);\r\n function GetCurrentItem: TSearchRec;\r\n function GetPath: string;\r\n function CheckFileExt(const FileName: string): Boolean;\r\n public\r\n constructor Create;\r\n destructor Destroy; override;\r\n { Last result of search [translated] }\r\n property CurrentItem: TSearchRec read GetCurrentItem; // ??? ?????\r\n { Path to search in [translated] }\r\n property Path: string read GetPath; // ???????\r\n { And attributes [translated] }\r\n property Attr: Integer read FAttr; // ??\r\n property Recurse: Boolean read FRecurse;\r\n\r\n { Windows Error Code [translated] }\r\n property ErrorCode: Integer read FLastSearchResult; // ? ?? Windows\r\n procedure First(const FilePath, FileExt: string; FileAttr: Integer; RecurseSearch: Boolean);\r\n procedure Next;\r\n function IsDone: Boolean;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvgFileIterator.pas $';\r\n Revision: '$Revision: 12461 $';\r\n Date: '$Date: 2009-08-14 19:21:33 +0200 (ven. 14 août 2009) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n JvJCLUtils;\r\n\r\nconstructor TJvgFileIterator.Create;\r\nbegin\r\n inherited Create;\r\n FLSearchRecs := TList.Create;\r\n FSLFileExt := TStringList.Create;\r\nend;\r\n\r\ndestructor TJvgFileIterator.Destroy;\r\nbegin\r\n while FLSearchRecs.Count > 0 do\r\n FindClose(True);\r\n FLSearchRecs.Free;\r\n FSLFileExt.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvgFileIterator.First(const FilePath, FileExt: string; FileAttr: Integer; RecurseSearch: Boolean);\r\nbegin\r\n if FileExt <> '' then\r\n FSLFileExt.CommaText := LowerCase(FileExt);\r\n\r\n FPath := ExtractFilePath(FilePath);\r\n FAttr := FileAttr;\r\n FRecurse := RecurseSearch;\r\n\r\n New(FPCurrentItem);\r\n FLSearchRecs.Add(FPCurrentItem);\r\n\r\n FPCurrentItem^.Path := ExtractFilePath(FilePath);\r\n try\r\n FLastSearchResult := SysUtils.FindFirst(FPath + '*.*', FileAttr, FPCurrentItem^.sr);\r\n FFindOpened := CheckResult(FLastSearchResult);\r\n if not FFindOpened then\r\n FindClose\r\n else\r\n if not CheckFileExt(FPCurrentItem^.sr.Name) then\r\n Next;\r\n except\r\n FindClose;\r\n end;\r\n\r\nend;\r\n\r\nfunction TJvgFileIterator.CheckResult(Value: Integer): Boolean;\r\nbegin\r\n Result := True;\r\n case Value of\r\n 0:\r\n Result := True;\r\n ERROR_NO_MORE_FILES:\r\n begin\r\n FindClose;\r\n Result := False;\r\n end;\r\n else\r\n RaiseLastOSError;\r\n end;\r\nend;\r\n\r\nfunction TJvgFileIterator.IsDone: Boolean;\r\nbegin\r\n Result := FLastSearchResult <> 0;\r\nend;\r\n\r\nprocedure TJvgFileIterator.Next;\r\nbegin\r\n //if FFindOpened then\r\n begin\r\n FLastSearchResult := FindNext(FPCurrentItem^.sr);\r\n FFindOpened := CheckResult(FLastSearchResult);\r\n\r\n if not FFindOpened then\r\n Exit;\r\n\r\n if FRecurse and (FPCurrentItem^.sr.Attr and faDirectory = faDirectory) and\r\n (FPCurrentItem^.sr.Name <> '.') and (FPCurrentItem^.sr.Name <> '..') then\r\n First(ExtractFilePath(FPCurrentItem^.Path) + FPCurrentItem^.sr.Name + '\\', '', FAttr, True)\r\n else\r\n if not CheckFileExt(FPCurrentItem^.sr.Name) then\r\n Next;\r\n\r\n end;\r\n // else\r\n // raise Exception.Create('Call Next method after First method');\r\nend;\r\n\r\nfunction TJvgFileIterator.CheckFileExt(const FileName: string): Boolean;\r\nbegin\r\n Result := not ((FileName = '.') or (FileName = '..'));\r\n if Result then\r\n Result := (Trim(FSLFileExt.Text) = '*') or\r\n (FSLFileExt.IndexOf(LowerCase(ExtractFileExt(FileName))) <> -1);\r\nend;\r\n\r\nprocedure TJvgFileIterator.FindClose(Destroying: Boolean = False);\r\nbegin\r\n if FLSearchRecs.Count = 0 then\r\n Exit;\r\n SysUtils.FindClose(FPCurrentItem^.sr);\r\n Dispose(FLSearchRecs[FLSearchRecs.Count - 1]);\r\n\r\n FLSearchRecs.Count := FLSearchRecs.Count - 1;\r\n\r\n if not Destroying and (FLSearchRecs.Count > 0) then\r\n begin\r\n FPCurrentItem := FLSearchRecs[FLSearchRecs.Count - 1];\r\n Next;\r\n end;\r\nend;\r\n\r\nfunction TJvgFileIterator.GetCurrentItem: TSearchRec;\r\nbegin\r\n Result := FPCurrentItem^.sr;\r\nend;\r\n\r\nfunction TJvgFileIterator.GetPath: string;\r\nbegin\r\n Result := PSearchData(FLSearchRecs[FLSearchRecs.Count - 1])^.Path;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvgGraph.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvgGraph.PAS, released on 2003-01-15.\r\n\r\nThe Initial Developer of the Original Code is Andrey V. Chudin, [chudin att yandex dott ru]\r\nPortions created by Andrey V. Chudin are Copyright (C) 2003 Andrey V. Chudin.\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\nMichael Beck [mbeck att bigfoot dott com].\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvgGraph.pas 12461 2009-08-14 17:21:33Z obones $\r\n\r\nunit JvgGraph;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, Messages, Classes, Controls, Graphics, ExtCtrls,\r\n JvComponent,\r\n JvgTypes, JvgCommClasses, JvgUtils;\r\n\r\nconst\r\n MaxPointsCount = 30;\r\n\r\ntype\r\n TJvgGraph = class(TJvGraphicControl)\r\n protected\r\n procedure Paint; override;\r\n public\r\n PenWidth: Integer;\r\n MaxValue: Integer;\r\n PointsCount: Integer;\r\n DrawPointsCount: Integer;\r\n YPoints: array [0..MaxPointsCount] of Integer;\r\n constructor Create(AOwner: TComponent); override;\r\n published\r\n property Color;\r\n property Height default 50;\r\n property Width default 50;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvgGraph.pas $';\r\n Revision: '$Revision: 12461 $';\r\n Date: '$Date: 2009-08-14 19:21:33 +0200 (ven. 14 août 2009) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nconstructor TJvgGraph.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n Width := 50;\r\n Height := 50;\r\n MaxValue := 100;\r\n PointsCount := MaxPointsCount;\r\n DrawPointsCount := MaxPointsCount;\r\nend;\r\n\r\nprocedure TJvgGraph.Paint;\r\nvar\r\n R: TRect;\r\n I: Integer;\r\n Points: array [0..MaxPointsCount] of TPoint;\r\n ShadowPoints: array [0..MaxPointsCount] of TPoint;\r\n\r\n procedure OffsetPoints(X, Y: Integer);\r\n var\r\n I: Integer;\r\n begin\r\n for I := 0 to PointsCount do\r\n begin\r\n Inc(Points[I].X, X);\r\n Inc(Points[I].Y, Y);\r\n end;\r\n end;\r\n\r\nbegin\r\n inherited Paint;\r\n R := ClientRect;\r\n InflateRect(R, -2, -2);\r\n\r\n for I := 0 to PointsCount do\r\n begin\r\n Points[I].X := MulDiv(I, Width, PointsCount);\r\n Points[I].Y := Height - MulDiv(YPoints[I], Height, MaxValue);\r\n ShadowPoints[I].X := Points[I].X + 6;\r\n ShadowPoints[I].Y := Points[I].Y + 6;\r\n end;\r\n\r\n Canvas.Pen.Width := PenWidth;\r\n // Canvas.Pen.Color := clBtnShadow;\r\n // Canvas.Polyline( ShadowPoints );\r\n\r\n //..3D shadow\r\n Canvas.Pen.Color := DecColor(Color, 100);\r\n Canvas.Polyline(Slice(Points, DrawPointsCount + 1));\r\n\r\n OffsetPoints(-2, -2);\r\n Canvas.Pen.Color := IncColor(Color, 200);\r\n Canvas.Polyline(Slice(Points, DrawPointsCount + 1));\r\n\r\n OffsetPoints(1, 1);\r\n Canvas.Pen.Color := Color;\r\n Canvas.Polyline(Slice(Points, DrawPointsCount + 1));\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvgGroupBox.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvgGroupBox.PAS, released on 2003-01-15.\r\n\r\nThe Initial Developer of the Original Code is Andrey V. Chudin, [chudin att yandex dott ru]\r\nPortions created by Andrey V. Chudin are Copyright (C) 2003 Andrey V. Chudin.\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\nMichael Beck [mbeck att bigfoot dott com].\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvgGroupBox.pas 12590 2009-10-31 13:04:44Z jfudickar $\r\n\r\nunit JvgGroupBox;\r\n\r\n{$I jvcl.inc}\r\n\r\n// Illumination - fake :)\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, Messages, SysUtils, Classes, Graphics, Controls,\r\n Forms, Dialogs, StdCtrls, ExtCtrls,\r\n JVCLVer,\r\n JvgTypes, JvgCommClasses;\r\n\r\ntype\r\n TCaptionAlignment = (fcaNone, fcaLeft, fcaRight, fcaCenter, fcaWidth);\r\n TJvgGroupBox = class(TCustomGroupBox)\r\n private\r\n FAboutJVCL: TJVCLAboutInfo;\r\n FBorder: TJvgBevelOptions;\r\n FCaptionBorder: TJvgBevelOptions;\r\n FGradient: TJvgGradient;\r\n FCaptionGradient: TJvgGradient;\r\n FCaptionShift: TJvgPointClass;\r\n FCaptionTextStyle: TglTextStyle;\r\n FCaptionAlignment: TCaptionAlignment;\r\n FColors: TJvgGroupBoxColors;\r\n FIllumination: TJvgIllumination;\r\n FTransparent: Boolean;\r\n FTransparentCaption: Boolean;\r\n FOptions: TglGroupBoxOptions;\r\n FCollapsed: Boolean;\r\n FAfterPaint: TNotifyEvent;\r\n FOnCollapsed: TNotifyEvent;\r\n FOnExpanded: TNotifyEvent;\r\n FGroupIndex: Integer;\r\n FGlyphCollapsed: TBitmap;\r\n FGlyphExpanded: TBitmap;\r\n\r\n ChildFocusedControl: TWinControl;\r\n// FImage: TBitmap;\r\n FullHeight: Integer;\r\n CaptionRect: TRect;\r\n ptScroll: TPoint;\r\n fScrolling: Boolean;\r\n procedure SetCaptionAlignment(Value: TCaptionAlignment);\r\n procedure SetCaptionTextStyle(Value: TglTextStyle);\r\n procedure SetCollapsed(Value: Boolean);\r\n procedure SetOptions(Value: TglGroupBoxOptions);\r\n procedure SetTransparent(Value: Boolean);\r\n procedure SetTransparentCaption(Value: Boolean);\r\n procedure SetGroupIndex(Value: Integer);\r\n function GetGlyphCollapsed: TBitmap;\r\n procedure SetGlyphCollapsed(Value: TBitmap);\r\n function GetGlyphExpanded: TBitmap;\r\n procedure SetGlyphExpanded(Value: TBitmap);\r\n\r\n procedure Collapse_(fCollapse: Boolean);\r\n procedure SmthChanged(Sender: TObject);\r\n function GetCaption: string;\r\n procedure SetCaption(const Value: string);\r\n procedure ReadFullHeight(Reader: TReader);\r\n procedure WriteFullHeight(Writer: TWriter);\r\n // procedure WMLButtonDown(var Msg: TWMLButtonDown); message WM_LBUTTONDOWN;\r\n\r\n procedure WMLButtonDown(var Msg: TWMLButtonDown); message WM_LBUTTONDOWN;\r\n procedure WMMouseMove(var Msg: TWMMouseMove); message WM_MOUSEMOVE;\r\n procedure WMLButtonUp(var Msg: TWMLButtonUp); message WM_LBUTTONUP;\r\n procedure CMEnabledChanged(var Msg: TMessage); message CM_ENABLEDCHANGED;\r\n protected\r\n procedure Paint; override;\r\n procedure CreateParams(var Params: TCreateParams); override;\r\n procedure AdjustClientRect(var Rect: TRect); override;\r\n procedure ComputeCaptionRect;\r\n public\r\n procedure Collapse(fCollapse: Boolean);\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n procedure DefineProperties(Filer: TFiler); override;\r\n published\r\n property AboutJVCL: TJVCLAboutInfo read FAboutJVCL write FAboutJVCL stored False;\r\n property Anchors;\r\n property Align;\r\n property Caption: string read GetCaption write SetCaption;\r\n property Color;\r\n property DragCursor;\r\n property DragMode;\r\n property Font;\r\n property ParentColor;\r\n property ParentFont;\r\n property ParentShowHint;\r\n property PopupMenu;\r\n property ShowHint;\r\n property TabOrder;\r\n property TabStop;\r\n property Visible;\r\n property OnClick;\r\n property OnDblClick;\r\n property OnDragDrop;\r\n property OnDragOver;\r\n property OnEndDrag;\r\n property OnEnter;\r\n property OnExit;\r\n property OnMouseDown;\r\n property OnMouseMove;\r\n property OnMouseUp;\r\n property OnStartDrag;\r\n property Enabled;\r\n property BevelEdges;\r\n {$IFDEF DELPHI2006_UP}\r\n property Padding;\r\n {$ENDIF DELPHI2006_UP}\r\n {$IFDEF DELPHI2009_UP}\r\n property DoubleBuffered;\r\n {$ENDIF DELPHI2009_UP}\r\n {$IFDEF DELPHI2010_UP}\r\n property Touch;\r\n {$ENDIF DELPHI2010_UP}\r\n property Border: TJvgBevelOptions read FBorder write FBorder;\r\n property CaptionAlignment: TCaptionAlignment\r\n read FCaptionAlignment write SetCaptionAlignment default fcaNone;\r\n property CaptionBorder: TJvgBevelOptions read FCaptionBorder write FCaptionBorder;\r\n property CaptionGradient: TJvgGradient read FCaptionGradient write FCaptionGradient;\r\n property CaptionShift: TJvgPointClass read FCaptionShift write FCaptionShift;\r\n property CaptionTextStyle: TglTextStyle read FCaptionTextStyle write SetCaptionTextStyle default fstNone;\r\n property Collapsed: Boolean read FCollapsed write SetCollapsed default False;\r\n property Colors: TJvgGroupBoxColors read FColors write FColors;\r\n property Gradient: TJvgGradient read FGradient write FGradient;\r\n property Illumination: TJvgIllumination read FIllumination write FIllumination stored False;\r\n property Options: TglGroupBoxOptions read FOptions write SetOptions;\r\n property Transparent: Boolean read FTransparent write SetTransparent default False;\r\n property TransparentCaption: Boolean read FTransparentCaption write SetTransparentCaption default False;\r\n property GroupIndex: Integer read FGroupIndex write SetGroupIndex default 0;\r\n property GlyphCollapsed: TBitmap read GetGlyphCollapsed write SetGlyphCollapsed;\r\n property GlyphExpanded: TBitmap read GetGlyphExpanded write SetGlyphExpanded;\r\n property AfterPaint: TNotifyEvent read FAfterPaint write FAfterPaint;\r\n property OnCollapsed: TNotifyEvent read FOnCollapsed write FOnCollapsed;\r\n property OnExpanded: TNotifyEvent read FOnExpanded write FOnExpanded;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvgGroupBox.pas $';\r\n Revision: '$Revision: 12590 $';\r\n Date: '$Date: 2009-10-31 14:04:44 +0100 (sam. 31 oct. 2009) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n Math,\r\n JvgUtils;\r\n\r\nconstructor TJvgGroupBox.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n // ControlStyle := ControlStyle + [csOpaque];\r\n FBorder := TJvgBevelOptions.Create;\r\n FCaptionBorder := TJvgBevelOptions.Create;\r\n FGradient := TJvgGradient.Create;\r\n FCaptionGradient := TJvgGradient.Create;\r\n FColors := TJvgGroupBoxColors.Create;\r\n FIllumination := TJvgIllumination.Create;\r\n FCaptionShift := TJvgPointClass.Create;\r\n //...defaults\r\n\r\n FColors.Caption := clBtnShadow;\r\n FColors.CaptionActive := clBtnShadow;\r\n FColors.Text := clHighlightText;\r\n FColors.TextActive := clHighlightText;\r\n FBorder.Outer := bvNone;\r\n FBorder.Inner := bvSpace;\r\n FCaptionBorder.Outer := bvNone;\r\n FCaptionBorder.Inner := bvSpace;\r\n FGradient.FromColor := clBlack;\r\n FGradient.ToColor := clGray;\r\n FCaptionShift.X := 8;\r\n FCaptionShift.Y := 0;\r\n FCaptionTextStyle := fstNone;\r\n FCaptionAlignment := fcaNone;\r\n FOptions := [fgoCanCollapse, fgoFilledCaption, fgoFluentlyCollapse,\r\n fgoFluentlyExpand, fgoHideChildrenWhenCollapsed, fgoSaveChildFocus];\r\n {$IFDEF GL_RUS}\r\n Font.CharSet := RUSSIAN_CHARSET;\r\n {$ENDIF GL_RUS}\r\n FBorder.OnChanged := SmthChanged;\r\n FCaptionBorder.OnChanged := SmthChanged;\r\n FGradient.OnChanged := SmthChanged;\r\n FCaptionGradient.OnChanged := SmthChanged;\r\n FCaptionShift.OnChanged := SmthChanged;\r\n FColors.OnChanged := SmthChanged;\r\n FIllumination.OnChanged := SmthChanged;\r\n ControlStyle := ControlStyle + [csOpaque];\r\nend;\r\n\r\ndestructor TJvgGroupBox.Destroy;\r\nbegin\r\n FBorder.Free;\r\n FCaptionBorder.Free;\r\n FGradient.Free;\r\n FCaptionGradient.Free;\r\n FCaptionShift.Free;\r\n FColors.Free;\r\n FIllumination.Free;\r\n// FImage.Free;\r\n FGlyphExpanded.Free;\r\n FGlyphCollapsed.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvgGroupBox.DefineProperties(Filer: TFiler);\r\nbegin\r\n inherited DefineProperties(Filer);\r\n Filer.DefineProperty('FullHeight', ReadFullHeight, WriteFullHeight, True);\r\nend;\r\n\r\nprocedure TJvgGroupBox.CreateParams(var Params: TCreateParams);\r\nbegin\r\n inherited CreateParams(Params);\r\n if Transparent or TransparentCaption then\r\n Params.ExStyle := Params.ExStyle or WS_EX_Transparent;\r\nend;\r\n\r\nprocedure TJvgGroupBox.AdjustClientRect(var Rect: TRect);\r\nbegin\r\n inherited AdjustClientRect(Rect);\r\n Inc(Rect.Top, 1);\r\nend;\r\n\r\nprocedure TJvgGroupBox.WMLButtonDown(var Msg: TWMLButtonDown);\r\nvar\r\n pt: TPoint;\r\nbegin\r\n inherited;\r\n if fgoIgnoreMouse in Options then\r\n Exit;\r\n pt.X := Msg.Pos.X;\r\n pt.Y := Msg.Pos.Y;\r\n if (fgoCanCollapse in Options) and PtInRect(CaptionRect, pt) then\r\n Collapse(not Collapsed)\r\n else\r\n begin\r\n Screen.Cursor := crHandPoint;\r\n {ptScroll.X := pt.X;} ptScroll.Y := pt.Y;\r\n fScrolling := True;\r\n end;\r\n\r\nend;\r\n\r\nprocedure TJvgGroupBox.WMMouseMove(var Msg: TWMMouseMove);\r\nbegin\r\n if fScrolling and (Parent is TScrollBox) then\r\n (Parent as TScrollBox).VertScrollBar.Position := (Parent as\r\n TScrollBox).VertScrollBar.Position + ptScroll.Y - Msg.Pos.Y;\r\n inherited;\r\nend;\r\n\r\nprocedure TJvgGroupBox.WMLButtonUp(var Msg: TWMLButtonUp);\r\nbegin\r\n inherited;\r\n if fgoIgnoreMouse in Options then\r\n Exit;\r\n fScrolling := False;\r\n Screen.Cursor := crDefault;\r\nend;\r\n\r\nprocedure TJvgGroupBox.CMEnabledChanged(var Msg: TMessage);\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := 0 to ControlCount - 1 do\r\n Controls[I].Enabled := Enabled;\r\nend;\r\n\r\nprocedure TJvgGroupBox.ReadFullHeight(Reader: TReader);\r\nbegin\r\n FullHeight := Reader.ReadInteger;\r\nend;\r\n\r\nprocedure TJvgGroupBox.WriteFullHeight(Writer: TWriter);\r\nbegin\r\n Writer.WriteInteger(FullHeight);\r\nend;\r\n\r\nprocedure TJvgGroupBox.Paint;\r\ntype\r\n TgbColor = record\r\n Text: TColor;\r\n Caption: TColor;\r\n Background: TColor;\r\n Client: TColor;\r\n Delineate: TColor;\r\n end;\r\nvar\r\n H, GlyphWidth: Integer;\r\n R, NewR: TRect;\r\n Glyph: TBitmap;\r\n DrawState: TglDrawState;\r\n Interspace: Integer;\r\n Color: TgbColor;\r\n OldDC: Integer;\r\nbegin\r\n if Transparent then\r\n begin\r\n OldDC := SaveDC(Canvas.Handle);\r\n try\r\n MoveWindowOrg(Canvas.Handle, -Left, -Top);\r\n Canvas.Lock;\r\n try\r\n Parent.Perform(WM_ERASEBKGND, WPARAM(Canvas.Handle), LPARAM(Canvas.Handle));\r\n {$IFDEF COMPILER7_UP}\r\n Parent.Perform(WM_PRINTCLIENT, WPARAM(Canvas.Handle), PRF_CLIENT);\r\n {$ELSE}\r\n Parent.Perform(WM_PAINT, WPARAM(Canvas.Handle), 0);\r\n {$ENDIF COMPILER7_UP}\r\n finally\r\n Canvas.Unlock;\r\n end;\r\n finally\r\n RestoreDC(Canvas.Handle, OldDC);\r\n end;\r\n end;\r\n\r\n //inherited;\r\n //Exit;\r\n Interspace := 2;\r\n if Collapsed then\r\n begin\r\n Color.Text := Colors.Text;\r\n Color.Caption := Colors.Caption;\r\n // Color.Background := Colors.Background;\r\n Color.Client := Colors.Client;\r\n Color.Delineate := Colors.Delineate;\r\n end\r\n else\r\n begin\r\n Color.Text := Colors.TextActive;\r\n Color.Caption := Colors.CaptionActive;\r\n // Color.Background := Colors.BackgroundActive;\r\n Color.Client := Colors.ClientActive;\r\n Color.Delineate := Colors.DelineateActive;\r\n end;\r\n\r\n with Canvas do\r\n begin\r\n Canvas.Font.Assign(Self.Font);\r\n R := GetClientRect;\r\n //Font := Self.Font;\r\n// if CaptionHeight = 0 then H := TextHeight('0') - FCaptionShift.Y\r\n// else H := CaptionHeight - FCaptionShift.Y\r\n H := TextHeight(Text) - FCaptionShift.Y;\r\n R := Rect(0, H div 2 { - 1}, Width, Height);\r\n if FGradient.Active then\r\n GradientBox(Handle, R, FGradient, PS_SOLID, 1);\r\n\r\n Dec(R.Right);\r\n Dec(R.Bottom);\r\n DrawBoxEx(Canvas.Handle, R,\r\n Border.Sides, Border.Inner, Border.Outer,\r\n Border.Bold, Color.Client, FGradient.Active or Transparent);\r\n\r\n if Text <> '' then\r\n begin\r\n if Assigned(FGlyphExpanded) then\r\n GlyphWidth := FGlyphExpanded.Width\r\n else\r\n GlyphWidth := 0;\r\n if Assigned(FGlyphCollapsed) then\r\n GlyphWidth := max(FGlyphCollapsed.Width, GlyphWidth);\r\n\r\n if Collapsed then\r\n Glyph := FGlyphCollapsed\r\n else\r\n Glyph := FGlyphExpanded;\r\n\r\n ComputeCaptionRect;\r\n R := CaptionRect;\r\n\r\n if not TransparentCaption then\r\n begin\r\n Canvas.Brush.Color := Colors.Caption;\r\n Windows.FillRect(Canvas.Handle, R, Canvas.Brush.Handle);\r\n end;\r\n GradientBox(Canvas.Handle, R, FCaptionGradient, PS_SOLID, 1);\r\n\r\n NewR := DrawBoxEx(Canvas.Handle, R, CaptionBorder.Sides,\r\n CaptionBorder.Inner, CaptionBorder.Outer,\r\n CaptionBorder.Bold, Color.Caption,\r\n TransparentCaption or not (fgoFilledCaption in Options));\r\n // Brush.Color := Color;\r\n\r\n if Transparent then\r\n SetBkMode(Handle, Integer(TRANSPARENT));\r\n\r\n if Assigned(Glyph) then\r\n begin\r\n if Enabled then\r\n DrawState := fdsDefault\r\n else\r\n DrawState := fdsDisabled;\r\n CreateBitmapExt(Handle, Glyph, NewR, 0, max(0, (NewR.Bottom -\r\n NewR.Top - Glyph.Height) div 2),\r\n fwoNone, DrawState, True,\r\n GetPixel(Glyph.Canvas.Handle, 0, Glyph.Height - 1)\r\n {TransparentColor},\r\n {DisabledMaskColor} 0);\r\n end;\r\n\r\n ExtTextOutExt((Handle), (NewR.Left + GlyphWidth + Interspace),\r\n (NewR.Top), NewR, Caption,\r\n IIF(Enabled, FCaptionTextStyle, fstPushed), fgoDelineatedText in\r\n Options,\r\n {fNeedUpdateOnlyMainText} False, Color.Text, Color.Delineate,\r\n Colors.Highlight, Colors.Shadow,\r\n FIllumination, nil {Gradient}, Font);\r\n\r\n end;\r\n end;\r\n if Assigned(AfterPaint) then\r\n AfterPaint(Self);\r\nend;\r\n\r\nprocedure TJvgGroupBox.Collapse(fCollapse: Boolean);\r\nvar\r\n I: Integer;\r\n AnotherExpandedWasFound: Boolean;\r\nbegin\r\n if csLoading in ComponentState then\r\n Exit;\r\n\r\n if fCollapse then\r\n begin\r\n if Align = alClient then\r\n Exit;\r\n if (FGroupIndex <> 0) and (fgoOneAlwaysExpanded in Options) then\r\n begin //...One Stay Always Expanded in group\r\n AnotherExpandedWasFound := False;\r\n for I := 0 to Owner.ComponentCount - 1 do\r\n with TControl(Owner) do\r\n if (Components[I] is TJvgGroupBox) and\r\n (TJvgGroupBox(Components[I]).GroupIndex = FGroupIndex) then\r\n if (not TJvgGroupBox(Components[I]).Collapsed) and\r\n (Components[I] <> Self) then\r\n begin\r\n AnotherExpandedWasFound := True;\r\n Break;\r\n end; //...are another expanded controls in group\r\n if not AnotherExpandedWasFound then\r\n Exit; //..i'm last- can't collapse\r\n end;\r\n end\r\n else\r\n if (FGroupIndex <> 0) and (fgoCollapseOther in Options) then\r\n for I := 0 to Owner.ComponentCount - 1 do\r\n with TControl(Owner) do\r\n if (Components[I] is TJvgGroupBox) and\r\n (TJvgGroupBox(Components[I]).GroupIndex = FGroupIndex) and\r\n (Components[I] <> Self) then\r\n TJvgGroupBox(Components[I]).Collapsed := True;\r\n\r\n Collapse_(fCollapse);\r\n if fCollapse and Assigned(FOnCollapsed) then\r\n FOnCollapsed(Self);\r\n if not fCollapse and Assigned(FOnExpanded) then\r\n FOnExpanded(Self);\r\nend;\r\n\r\nprocedure TJvgGroupBox.Collapse_(fCollapse: Boolean);\r\nvar\r\n I {, Step}: Integer;\r\n { DC: HDC;\r\n pt: TPoint;\r\n R, CR: TRect;\r\n Scroll: HRGN;\r\n SpaceBrush: HBRUSH;\r\n fFirst: Boolean;\r\n LastTickCount: Integer;}\r\nbegin\r\n if Align = alClient then\r\n Exit;\r\n\r\n FCollapsed := fCollapse;\r\n if fCollapse then\r\n begin\r\n FullHeight := Height;\r\n if fgoResizeParent in Options then\r\n Parent.Height := Parent.Height - (FullHeight - CaptionRect.Bottom);\r\n Height := CaptionRect.Bottom + 1;\r\n\r\n //...set all Children invisible\r\n if (fgoHideChildrenWhenCollapsed in Options) or (fgoSaveChildFocus in Options) then\r\n for I := 0 to Owner.ComponentCount - 1 do\r\n with TControl(Owner) do\r\n if (Components[I] is TControl) and\r\n (TControl(Components[I]).Parent = Self) then\r\n begin\r\n if (fgoSaveChildFocus in Options) and (Components[I] is TWinControl) and\r\n TWinControl(Components[I]).Focused then\r\n ChildFocusedControl := TWinControl(Components[I]);\r\n if fgoHideChildrenWhenCollapsed in Options then //...hide\r\n TControl(Components[I]).Visible := False;\r\n end;\r\n end\r\n else\r\n begin\r\n if fgoResizeParent in Options then\r\n Parent.Height := Parent.Height + (FullHeight - CaptionRect.Bottom);\r\n Height := FullHeight;\r\n\r\n //...set all Children visible\r\n if fgoHideChildrenWhenCollapsed in Options then\r\n for I := 0 to Owner.ComponentCount - 1 do\r\n with TControl(Owner) do\r\n if (Components[I] is TControl) and\r\n (TControl(Components[I]).Parent = Self) then\r\n TControl(Components[I]).Visible := True;\r\n\r\n if ChildFocusedControl <> nil then\r\n try\r\n ChildFocusedControl.SetFocus;\r\n except\r\n end;\r\n end;\r\n\r\n Exit; { patch for win 98 }\r\n\r\n (*\r\n if fCollapse then\r\n begin\r\n //...prepare image\r\n\r\n if FImage=nil then FImage := TBitmap.Create;\r\n FImage.Height := Height;\r\n FImage.Width := Width;\r\n GetWindowImage( Self, True{fDrawSelf}, True{fDrawChildWindows}, FImage.Canvas.Handle );\r\n\r\n DC := GetDC(HWND_DESKTOP);\r\n CR := ClientRect; Dec(CR.Bottom,CaptionRect.Bottom);\r\n pt.X := 0; pt.Y := CaptionRect.Bottom+1;//16;\r\n pt := ClientToScreen(pt);\r\n offsetRect( CR, pt.X, pt.Y );\r\n R := CR;\r\n Scroll := CreateRectRgn( R.Left, R.Top, R.Right-R.Left, R.Bottom-R.Top );\r\n Inc( R.Top );\r\n I := Height-Canvas.TextHeight('0y');\r\n // Step := 1;//max( Height div 100, 1 );\r\n\r\n SpaceBrush := CreateSolidBrush( ColorToRGB(TGroupBox(Parent).Color) );\r\n // fFirst := True; LastTickCount := GetTickCount;\r\n FullHeight := Height;\r\n if fgoFluentlyCollapse in Options then\r\n while Height > CaptionRect.Bottom+1 do\r\n begin\r\n Application.ProcessMessages;\r\n// ScrollDC( DC, 0, -Step, R, CR, Scroll, nil);\r\n //if fFirst then\r\n// begin\r\n// FillRect( DC, Rect( R.Left, R.Bottom-Step, R.Right, R.Bottom ), SpaceBrush );\r\n// fFirst := False;\r\n// end;\r\n Height := max(CaptionRect.Bottom, Height - Height * 30 div 100);\r\n ValidateRect(Handle, @CaptionRect);\r\n// while GetTickCount - LastTickCount <= 0 do;\r\n// Step := GetTickCount - LastTickCount; if Step > 20 then Step := 20;\r\n// LastTickCount := GetTickCount;\r\n end;\r\n DeleteObject(SpaceBrush);\r\n// FullHeight := Height;\r\n Height := CaptionRect.Bottom+1;//max( Canvas.TextHeight(Caption), 16 );\r\n DeleteObject( Scroll );\r\n ReleaseDC(HWND_DESKTOP, DC);\r\n\r\n end\r\n else\r\n begin//..expanded\r\n\r\n if fgoFluentlyExpand in Options then\r\n while Height < FullHeight do\r\n begin\r\n Application.ProcessMessages;\r\n Height := Height + 1;\r\n ValidateRect(Handle, @CaptionRect);\r\n end;\r\n Height := FullHeight;\r\n end;\r\n InValidateRect(Handle, @CaptionRect, False);\r\n FCollapsed := fCollapse;\r\n *)\r\nend;\r\n\r\nprocedure TJvgGroupBox.SmthChanged(Sender: TObject);\r\nbegin\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvgGroupBox.SetCaptionAlignment(Value: TCaptionAlignment);\r\nbegin\r\n if FCaptionAlignment <> Value then\r\n begin\r\n FCaptionAlignment := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvgGroupBox.SetCaptionTextStyle(Value: TglTextStyle);\r\nbegin\r\n if FCaptionTextStyle <> Value then\r\n begin\r\n FCaptionTextStyle := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvgGroupBox.SetCollapsed(Value: Boolean);\r\nbegin\r\n if FCollapsed <> Value then\r\n begin\r\n if not (fgoCanCollapse in Options) and Value then\r\n Exit;\r\n FCollapsed := Value;\r\n if csLoading in ComponentState then\r\n Exit;\r\n Collapse_(Value);\r\n end;\r\nend;\r\n\r\nprocedure TJvgGroupBox.SetOptions(Value: TglGroupBoxOptions);\r\nbegin\r\n if FOptions <> Value then\r\n begin\r\n FOptions := Value;\r\n // if not(fgoCanCollapse in Options) then Collapsed := False;\r\n if Assigned(Parent) then\r\n CalcShadowAndHighlightColors((Parent as TWinControl).Brush.Color,\r\n TJvgLabelColors(Colors));\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvgGroupBox.SetTransparent(Value: Boolean);\r\nbegin\r\n if FTransparent <> Value then\r\n begin\r\n FTransparent := Value;\r\n RecreateWnd;\r\n end;\r\nend;\r\n\r\nprocedure TJvgGroupBox.SetTransparentCaption(Value: Boolean);\r\nbegin\r\n if FTransparentCaption <> Value then\r\n begin\r\n FTransparentCaption := Value;\r\n RecreateWnd;\r\n end;\r\nend;\r\n\r\nprocedure TJvgGroupBox.SetGroupIndex(Value: Integer);\r\nvar\r\n I: Integer;\r\nbegin\r\n if FGroupIndex = Value then\r\n Exit;\r\n FGroupIndex := Value;\r\n if csLoading in ComponentState then\r\n Exit;\r\n if (not Collapsed) and (FGroupIndex <> 0) then\r\n for I := 0 to Owner.ComponentCount - 1 do\r\n with TControl(Owner) do\r\n if (Components[I] is TJvgGroupBox) and\r\n (TJvgGroupBox(Components[I]).GroupIndex = FGroupIndex) and\r\n (Components[I] <> Self) then\r\n TJvgGroupBox(Components[I]).Collapsed := True;\r\nend;\r\n\r\nfunction TJvgGroupBox.GetGlyphCollapsed: TBitmap;\r\nbegin\r\n if FGlyphCollapsed = nil then\r\n FGlyphCollapsed := TBitmap.Create;\r\n Result := FGlyphCollapsed;\r\nend;\r\n\r\nprocedure TJvgGroupBox.SetGlyphCollapsed(Value: TBitmap);\r\nbegin\r\n GlyphCollapsed.Assign(Value);\r\n Invalidate;\r\nend;\r\n\r\nfunction TJvgGroupBox.GetGlyphExpanded: TBitmap;\r\nbegin\r\n if FGlyphExpanded = nil then\r\n FGlyphExpanded := TBitmap.Create;\r\n Result := FGlyphExpanded;\r\nend;\r\n\r\nprocedure TJvgGroupBox.SetGlyphExpanded(Value: TBitmap);\r\nbegin\r\n GlyphExpanded.Assign(Value);\r\n Invalidate;\r\nend;\r\n\r\nfunction TJvgGroupBox.GetCaption: string;\r\nbegin\r\n Result := inherited Caption;\r\nend;\r\n\r\nprocedure TJvgGroupBox.SetCaption(const Value: string);\r\nbegin\r\n inherited Caption := Value;\r\n // (obones) force the computation of CaptionRect so that\r\n // we don't need to paint to have the correct values.\r\n ComputeCaptionRect;\r\nend;\r\n\r\nprocedure TJvgGroupBox.ComputeCaptionRect;\r\nvar\r\n R: TRect;\r\n I, RW, GlyphWidth: Integer;\r\n Interspace: Integer;\r\nbegin\r\n Canvas.Font.Assign(Self.Font);\r\n\r\n Interspace := 2;\r\n R := Rect(FCaptionShift.X, 0, 0, Canvas.TextHeight(Text) - FCaptionShift.Y);\r\n\r\n if Assigned(FGlyphExpanded) then\r\n GlyphWidth := FGlyphExpanded.Width\r\n else\r\n GlyphWidth := 0;\r\n if Assigned(FGlyphCollapsed) then\r\n GlyphWidth := Max(FGlyphCollapsed.Width, GlyphWidth);\r\n\r\n Windows.DrawText(Canvas.Handle, PChar(Text), Length(Text), R, DT_LEFT or DT_SINGLELINE or DT_CALCRECT);\r\n\r\n Inc(R.Right, Interspace + GlyphWidth);\r\n with CaptionBorder do\r\n begin\r\n I := 0;\r\n if Inner <> bvNone then\r\n begin\r\n Inc(I, 2);\r\n if Bold then\r\n Inc(I);\r\n end;\r\n if Outer <> bvNone then\r\n begin\r\n Inc(I, 2);\r\n if Bold then\r\n Inc(I);\r\n end;\r\n\r\n Inc(R.Right, I);\r\n Inc(R.Bottom, I);\r\n end;\r\n\r\n RW := R.Right - R.Left;\r\n case FCaptionAlignment of\r\n fcaLeft:\r\n begin\r\n R.Right := RW;\r\n R.Left := 0;\r\n end;\r\n fcaRight:\r\n begin\r\n R.Left := Width - RW - 1;\r\n R.Right := R.Left + RW;\r\n end;\r\n fcaCenter:\r\n begin\r\n R.Left := (Width - RW) div 2;\r\n R.Right := R.Left + RW;\r\n end;\r\n fcaWidth:\r\n begin\r\n R.Left := 0;\r\n R.Right := Width - 1;\r\n end;\r\n end;\r\n if fgoDelineatedText in Options then\r\n Inc(R.Bottom, 2);\r\n if CaptionTextStyle = fstShadow then\r\n begin\r\n if fgoDelineatedText in Options then\r\n Inc(R.Bottom, FIllumination.ShadowDepth - 2)\r\n else\r\n Inc(R.Bottom, FIllumination.ShadowDepth);\r\n end\r\n else\r\n if CaptionTextStyle <> fstNone then\r\n Inc(R.Bottom, 2);\r\n\r\n CaptionRect := R;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvgHTTPVersionInfo.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvgHTTPVersionInfo.PAS, released on 2003-01-15.\r\n\r\nThe Initial Developer of the Original Code is Andrey V. Chudin, [chudin att yandex dott ru]\r\nPortions created by Andrey V. Chudin are Copyright (C) 2003 Andrey V. Chudin.\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\nMichael Beck [mbeck att bigfoot dott com].\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvgHTTPVersionInfo.pas 13401 2012-08-19 08:35:09Z ahuser $\r\n\r\nunit JvgHTTPVersionInfo;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, Messages, SysUtils, Classes, Graphics,\r\n Controls, Forms, Dialogs, SHDocVw,\r\n JvComponentBase;\r\n\r\ntype\r\n TJvgHTTPVersionInfo = class(TJvComponent)\r\n private\r\n FVersionInfo: TStringList;\r\n FWebBrowser: TWebBrowser;\r\n FVersionDataURL: string;\r\n function GetVersionInfoProperty: TStrings;\r\n protected\r\n function GetVersion: string;\r\n function GetDate: string;\r\n function GetProgramURL: string;\r\n function GetComments: string;\r\n procedure OnLoadVersionInfo(Sender: TObject; const PDisp: IDispatch;\r\n {$IFDEF COMPILER16_UP}const{$ELSE}var{$ENDIF} URL: OleVariant);\r\n public\r\n property VersionInfo: TStrings read GetVersionInfoProperty;\r\n function GetVersionInfo(WinControl: TWinControl): Boolean;\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n published\r\n property Version: string read GetVersion;\r\n property Date: string read GetDate;\r\n property ProgramURL: string read GetProgramURL;\r\n property Comments: string read GetComments;\r\n property VersionDataURL: string read FVersionDataURL write FVersionDataURL;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvgHTTPVersionInfo.pas $';\r\n Revision: '$Revision: 13401 $';\r\n Date: '$Date: 2012-08-19 10:35:09 +0200 (dim. 19 août 2012) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n JvResources, JvConsts;\r\n\r\nconstructor TJvgHTTPVersionInfo.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FVersionInfo := TStringList.Create;\r\nend;\r\n\r\ndestructor TJvgHTTPVersionInfo.Destroy;\r\nbegin\r\n FVersionInfo.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJvgHTTPVersionInfo.GetVersionInfoProperty: TStrings;\r\nbegin\r\n Result := FVersionInfo;\r\nend;\r\n\r\nfunction TJvgHTTPVersionInfo.GetComments: string;\r\nbegin\r\n Result := VersionInfo.Values['comments'];\r\nend;\r\n\r\nfunction TJvgHTTPVersionInfo.GetDate: string;\r\nbegin\r\n Result := VersionInfo.Values['date'];\r\nend;\r\n\r\nfunction TJvgHTTPVersionInfo.GetProgramURL: string;\r\nbegin\r\n Result := VersionInfo.Values['url'];\r\nend;\r\n\r\nfunction TJvgHTTPVersionInfo.GetVersion: string;\r\nbegin\r\n Result := VersionInfo.Values['version'];\r\nend;\r\n\r\nfunction TJvgHTTPVersionInfo.GetVersionInfo(WinControl: TWinControl): Boolean;\r\nbegin\r\n if Trim(VersionDataURL) = '' then\r\n raise Exception.CreateRes(@RsEUnknownURLPropertyVersionDataURLIs);\r\n\r\n FWebBrowser := TWebBrowser.Create(nil);\r\n FWebBrowser.Visible := False;\r\n FWebBrowser.Left := -10;\r\n FWebBrowser.Width := 1;\r\n FWebBrowser.Height := 1;\r\n TWinControl(FWebBrowser).Parent := WinControl;\r\n\r\n try\r\n FWebBrowser.OnDocumentComplete := OnLoadVersionInfo;\r\n FWebBrowser.Navigate(VersionDataURL);\r\n repeat\r\n Application.ProcessMessages;\r\n until not FWebBrowser.Busy;\r\n finally\r\n FWebBrowser.Free;\r\n end;\r\n Result := (Version <> '') or (Date <> '') or (ProgramURL <> '');\r\nend;\r\n\r\nprocedure TJvgHTTPVersionInfo.OnLoadVersionInfo(Sender: TObject;\r\n const PDisp: IDispatch; {$IFDEF COMPILER16_UP}const{$ELSE}var{$ENDIF} URL: OleVariant);\r\nvar\r\n Doc: Variant;\r\nbegin\r\n Doc := FWebBrowser.Document;\r\n VersionInfo.Text := Doc.Body.InnerText;\r\n //for i := 0 to VersionInfo.Count-1 do\r\n // VersionInfo.Names[i] := LowerCase(VersionInfo.Names[i]);\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvgHint.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvgHint.PAS, released on 2003-01-15.\r\n\r\nThe Initial Developer of the Original Code is Andrey V. Chudin, [chudin att yandex dott ru]\r\nPortions created by Andrey V. Chudin are Copyright (C) 2003 Andrey V. Chudin.\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\nMichael Beck [mbeck att bigfoot dott com].\r\nRob den Braasem [rbraasem att xs4all dott nl].\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvgHint.pas 12845 2010-09-16 20:22:55Z jfudickar $\r\n\r\nunit JvgHint;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, Messages, SysUtils, Graphics, Controls, Classes, Forms,\r\n JvComponentBase,\r\n JvgCommClasses;\r\n\r\ntype\r\n TJvgHint = class(TJvComponent)\r\n private\r\n FOnShowHint: TShowHintEvent;\r\n FOnHint: TNotifyEvent;\r\n FActive: Boolean;\r\n FOnHintOld: TNotifyEvent;\r\n FOnShowHintOld: TShowHintEvent;\r\n FShowHint: Boolean;\r\n FHintWindow: THintWindow;\r\n FHintControl: TControl;\r\n FGlyph: TBitmap;\r\n FHintStyle: TJvgHintStyle;\r\n FSpacing: Integer;\r\n FGlyphAlign: TJvg2DAlign;\r\n FAlignment: TAlignment;\r\n procedure SetGlyph(const Value: TBitmap);\r\n procedure NewHint(Sender: TObject);\r\n procedure NewShowHint(var HintStr: string; var CanShow: Boolean; var HintInfo: {$IFDEF RTL200_UP}Controls.{$ENDIF RTL200_UP}THintInfo);\r\n protected\r\n procedure Notification(Component: TComponent; Operation: TOperation); override;\r\n procedure Loaded; override;\r\n procedure InitHint;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n procedure ShowHintAt(X, Y: Integer; const Caption: string);\r\n published\r\n property Active: Boolean read FActive write FActive default False;\r\n property ShowHint: Boolean read FShowHint write FShowHint default False;\r\n property Glyph: TBitmap read FGlyph write SetGlyph;\r\n property Style: TJvgHintStyle read FHintStyle write FHintStyle;\r\n property Spacing: Integer read FSpacing write FSpacing default 0;\r\n property GlyphAlign: TJvg2DAlign read FGlyphAlign write FGlyphAlign;\r\n property Alignment: TAlignment read FAlignment write FAlignment default taLeftJustify;\r\n property OnShowHint: TShowHintEvent read FOnShowHint write FOnShowHint;\r\n property OnHint: TNotifyEvent read FOnHint write FOnHint;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvgHint.pas $';\r\n Revision: '$Revision: 12845 $';\r\n Date: '$Date: 2010-09-16 22:22:55 +0200 (jeu. 16 sept. 2010) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n Math, ExtCtrls,\r\n JvResources, JvConsts,\r\n JvgTypes, JvgUtils;\r\n\r\n{$R JvgHint.res}\r\n\r\ntype\r\n TJvgHintWindow = class(THintWindow)\r\n private\r\n FHintComponent: TJvgHint;\r\n protected\r\n procedure CreateParams(var Params: TCreateParams); override;\r\n procedure WMKillFocus(var Msg: TMessage); message WM_ACTIVATE;\r\n procedure Paint; override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n procedure ActivateHint(Rect: TRect; const AHint: string); override;\r\n function CalcHintRect(MaxWidth: Integer; const AHint: string; AData: Pointer): TRect; override;\r\n end;\r\n\r\nvar\r\n lpFrHintComponent: TJvgHint;\r\n\r\n//=== { TJvgHint } ===========================================================\r\n\r\nconstructor TJvgHint.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FGlyph := TBitmap.Create;\r\n FHintStyle := TJvgHintStyle.Create;\r\n FGlyphAlign := TJvg2DAlign.Create;\r\n FActive := False;\r\n FShowHint := False;\r\n FSpacing := 0;\r\n FAlignment := taLeftJustify;\r\n FHintStyle.Color := clWindow;\r\n FHintStyle.Bevel.Inner := bvRaised;\r\n FHintStyle.Bevel.Outer := bvLowered;\r\n if not (csDesigning in ComponentState) then\r\n InitHint;\r\n Application.ShowHint := False;\r\n Application.ShowHint := True;\r\nend;\r\n\r\ndestructor TJvgHint.Destroy;\r\nbegin\r\n FGlyph.Free;\r\n FHintStyle.Free;\r\n FGlyphAlign.Free;\r\n if Assigned(FOnHintOld) then\r\n begin\r\n Application.OnShowHint := FOnShowHintOld;\r\n Application.OnHint := FOnHintOld;\r\n end;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvgHint.Notification(Component: TComponent; Operation: TOperation);\r\nbegin\r\n inherited Notification(Component, Operation);\r\n if (Component <> Self) and (Operation = opInsert) and (Component is TJvgHint) then\r\n raise Exception.CreateRes(@RsEOnlyOneInstanceOfTJvgHint);\r\nend;\r\n\r\nprocedure TJvgHint.InitHint;\r\nbegin\r\n with Application do\r\n begin\r\n FOnHintOld := OnHint;\r\n FOnShowHintOld := OnShowHint;\r\n OnShowHint := NewShowHint;\r\n OnHint := NewHint;\r\n HintWindowClass := TJvgHintWindow;\r\n lpFrHintComponent := Self;\r\n end;\r\n FShowHint := True;\r\nend;\r\n\r\nprocedure TJvgHint.Loaded;\r\nbegin\r\n inherited Loaded;\r\n if not (csDesigning in ComponentState) and Active then\r\n begin\r\n InitHint;\r\n Application.ShowHint := False;\r\n Application.ShowHint := ShowHint;\r\n end;\r\n if Glyph.Empty then\r\n begin\r\n Glyph.Assign(nil); // fixes GDI resource leak\r\n Glyph.LoadFromResourceName(HInstance, 'JvgHintHELP');\r\n end;\r\nend;\r\n\r\nprocedure TJvgHint.NewHint(Sender: TObject);\r\nbegin\r\n if Assigned(FOnHint) then\r\n FOnHint(Sender);\r\nend;\r\n\r\nprocedure TJvgHint.NewShowHint(var HintStr: string;\r\n var CanShow: Boolean; var HintInfo: {$IFDEF RTL200_UP}Controls.{$ENDIF RTL200_UP}THintInfo);\r\nbegin\r\n FHintControl := HintInfo.HintControl;\r\n if Assigned(FOnShowHint) then\r\n FOnShowHint(HintStr, CanShow, HintInfo);\r\n if CanShow then\r\n Self.ShowHintAt(HintInfo.CursorPos.X, HintInfo.CursorPos.Y, HintStr);\r\nend;\r\n\r\nprocedure TJvgHint.ShowHintAt(X, Y: Integer; const Caption: string);\r\nvar\r\n R: TRect;\r\n HW: TJvgHintWindow;\r\nbegin\r\n HW := TJvgHintWindow.Create(Application);\r\n R := Bounds(X, Y, 10, 10);\r\n\r\n Windows.DrawText(HW.Canvas.Handle, PChar(Caption), Length(Caption), R, DT_WORDBREAK or DT_CALCRECT);\r\n HW.ActivateHint(R, Caption);\r\nend;\r\n\r\n//=== { TJvgHintWindow } =====================================================\r\n\r\nconstructor TJvgHintWindow.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FHintComponent := TJvgHint(lpFrHintComponent);\r\n try\r\n if Assigned(FHintComponent) then\r\n FHintComponent.FHintWindow := Self;\r\n with Canvas do\r\n begin\r\n Font.Assign(FHintComponent.Style.Font);\r\n {$IFDEF GL_RUS}\r\n Font.CharSet := RUSSIAN_CHARSET;\r\n {$ENDIF GL_RUS}\r\n end;\r\n except\r\n end;\r\nend;\r\n\r\nprocedure TJvgHintWindow.CreateParams(var Params: TCreateParams);\r\nbegin\r\n inherited CreateParams(Params);\r\n Params.Style := Params.Style and not WS_BORDER;\r\nend;\r\n\r\nprocedure TJvgHintWindow.ActivateHint(Rect: TRect; const AHint: string);\r\nbegin\r\n Caption := AHint;\r\n BoundsRect := Rect;\r\n Tag := 1;\r\n Width := Width + 20;\r\n Height := Height + 1;\r\n if Rect.Top + Height > Screen.Height then\r\n Rect.Top := Screen.Height - Height;\r\n if Rect.Left + Width > Screen.Width then\r\n Rect.Left := Screen.Width - Width;\r\n if Rect.Left < 0 then\r\n Rect.Left := 0;\r\n if Rect.Bottom < 0 then\r\n Rect.Bottom := 0;\r\n SetWindowPos(Handle, HWND_TOPMOST, Rect.Left, Rect.Top, Width, Height,\r\n SWP_SHOWWINDOW or SWP_NOACTIVATE);\r\nend;\r\n\r\nprocedure TJvgHintWindow.Paint;\r\nconst\r\n cAlignments: array [TAlignment] of Longint = (DT_LEFT, DT_RIGHT, DT_CENTER);\r\nvar\r\n R: TRect;\r\n GlyphX, GlyphY: Integer;\r\nbegin\r\n R := ClientRect;\r\n Dec(R.Right);\r\n Dec(R.Bottom);\r\n Canvas.Brush.Color := clWhite;\r\n Canvas.Pen.Color := 0;\r\n GlyphX := 0;\r\n GlyphY := 0;\r\n\r\n with FHintComponent.Style do\r\n begin\r\n R := DrawBoxEx(Canvas.Handle, R, Bevel.Sides, Bevel.Inner, Bevel.Outer, Bevel.Bold, Color, Gradient.Active);\r\n if Gradient.Active then\r\n begin\r\n Inc(R.Right);\r\n Inc(R.Bottom);\r\n Gradient.Draw(Canvas.Handle, R, Integer(psSolid), 1);\r\n Dec(R.Right);\r\n Dec(R.Bottom);\r\n end;\r\n end;\r\n\r\n if Assigned(FHintComponent) then\r\n begin\r\n case FHintComponent.GlyphAlign.Vertical of\r\n fvaTop:\r\n GlyphY := R.Top;\r\n fvaCenter:\r\n GlyphY := (R.Bottom - R.Top - FHintComponent.Glyph.Height) div 2;\r\n fvaBottom:\r\n GlyphY := R.Bottom - FHintComponent.Glyph.Height;\r\n end;\r\n case FHintComponent.GlyphAlign.Horizontal of\r\n fhaLeft:\r\n GlyphX := R.Left + 1;\r\n fhaCenter:\r\n GlyphX := (R.Right - R.Left - FHintComponent.Glyph.Width) div 2;\r\n fhaRight:\r\n GlyphX := R.Right - FHintComponent.Glyph.Width - 2;\r\n end;\r\n\r\n CreateBitmapExt(Canvas.Handle, FHintComponent.Glyph, R,\r\n GlyphX, GlyphY, fwoNone, fdsDefault, True,\r\n GetTransparentColor(FHintComponent.Glyph, ftcLeftBottomPixel), 0);\r\n case FHintComponent.GlyphAlign.Horizontal of\r\n fhaLeft:\r\n Inc(R.Left, FHintComponent.Glyph.Width + FHintComponent.Spacing);\r\n fhaCenter:\r\n { nothing };\r\n fhaRight:\r\n Dec(R.Right, FHintComponent.Glyph.Width + FHintComponent.Spacing);\r\n end;\r\n\r\n end;\r\n\r\n SetBkMode(Canvas.Handle, TRANSPARENT);\r\n\r\n Canvas.Font.Assign(FHintComponent.Style.Font);\r\n InflateRect(R, -1, -1);\r\n if ClientRect.Bottom - ClientRect.Top > Canvas.TextHeight('Y') * 2 then\r\n Windows.DrawText(Canvas.Handle, PChar(Caption), Length(Caption), R,\r\n DT_VCENTER or DT_WORDBREAK or cAlignments[FHintComponent.Alignment])\r\n else\r\n Windows.DrawText(Canvas.Handle, PChar(Caption), Length(Caption), R,\r\n DT_VCENTER or DT_SINGLELINE or cAlignments[FHintComponent.Alignment]);\r\nend;\r\n\r\nprocedure TJvgHintWindow.WMKillFocus(var Msg: TMessage);\r\nbegin\r\n Hide;\r\nend;\r\n\r\nfunction TJvgHintWindow.CalcHintRect(MaxWidth: Integer; const AHint: string;\r\n AData: Pointer): TRect;\r\nbegin\r\n Canvas.Font.Assign(FHintComponent.Style.Font);\r\n Result := inherited CalcHintRect(MaxWidth, AHint, AData);\r\n if Assigned(FHintComponent.Glyph) and not FHintComponent.Glyph.Empty then\r\n begin\r\n Result.Bottom := Max(Result.Bottom, FHintComponent.Glyph.Height);\r\n Inc(Result.Right, FHintComponent.Glyph.Width + FHintComponent.Spacing);\r\n end;\r\n Inc(Result.Bottom, FHintComponent.Style.Bevel.BordersHeight);\r\n Inc(Result.Right, FHintComponent.Style.Bevel.BordersWidth);\r\nend;\r\n\r\nprocedure TJvgHint.SetGlyph(const Value: TBitmap);\r\nbegin\r\n FGlyph.Assign(Value);\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvgHoleShape.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvgHoleShape.PAS, released on 2003-01-15.\r\n\r\nThe Initial Developer of the Original Code is Andrey V. Chudin, [chudin att yandex dott ru]\r\nPortions created by Andrey V. Chudin are Copyright (C) 2003 Andrey V. Chudin.\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\nMichael Beck [mbeck att bigfoot dott com].\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvgHoleShape.pas 12461 2009-08-14 17:21:33Z obones $\r\n\r\nunit JvgHoleShape;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,\r\n Dialogs, ExtCtrls,\r\n JvComponent,\r\n JvgTypes, JvgCommClasses;\r\n\r\ntype\r\n TRGNCombineMode = (cmAND, cmCOPY, cmDIFF, cmOR, cmXOR);\r\n THoleShapeType = (stRectangle, stSquare, stRoundRect, stRoundSquare,\r\n stEllipse, stCircle);\r\n\r\n TJvgHoleShape = class(TJvGraphicControl)\r\n private\r\n FCombineMode: TRGNCombineMode;\r\n FEnabledAllInDesignTime: Boolean;\r\n FEnabled: Boolean;\r\n FShape: THoleShapeType;\r\n FShapeBitmap: TBitmap;\r\n FBevelInner: TPanelBevel;\r\n FBevelOuter: TPanelBevel;\r\n FBevelInnerBold: Boolean;\r\n FBevelOuterBold: Boolean;\r\n FRectEllipse: TJvgPointClass;\r\n FBevelOffset: Integer;\r\n FNeedUpdateRgn: Boolean;\r\n FNeedRebuildBitmapShape: Boolean;\r\n FRGNInner: HRGN;\r\n FRGNOuter: HRGN;\r\n FOldX: Integer;\r\n FOldY: Integer;\r\n FOldW: Integer;\r\n FOldH: Integer;\r\n procedure SetEnabledAllInDesignTime(Value: Boolean);\r\n procedure SetShape(Value: THoleShapeType);\r\n procedure SetShapeBitmap(Value: TBitmap);\r\n procedure SetBevelInner(Value: TPanelBevel);\r\n procedure SetBevelOuter(Value: TPanelBevel);\r\n procedure SetBevelInnerBold(Value: Boolean);\r\n procedure SetBevelOuterBold(Value: Boolean);\r\n procedure SetCombineMode(Value: TRGNCombineMode);\r\n procedure SetBevelOffset(Value: Integer);\r\n procedure InternalUpdate;\r\n procedure CalcRGNs;\r\n procedure SmthChanged(Sender: TObject);\r\n procedure SayAllDTEnabledState(EnabledDT: Boolean);\r\n protected\r\n procedure SetEnabled(Value: Boolean); override;\r\n procedure Paint; override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n procedure UpdateRGN;\r\n procedure Loaded; override;\r\n property RGNInner: HRGN read FRGNInner write FRGNInner;\r\n property RGNOuter: HRGN read FRGNOuter write FRGNOuter;\r\n published\r\n property Enabled: Boolean read FEnabled write SetEnabled default True;\r\n property EnabledAllInDesignTime: Boolean read FEnabledAllInDesignTime\r\n write SetEnabledAllInDesignTime default True;\r\n property Shape: THoleShapeType read FShape write SetShape default stEllipse;\r\n property BevelInner: TPanelBevel read FBevelInner write SetBevelInner default bvNone;\r\n property BevelOuter: TPanelBevel read FBevelOuter write SetBevelOuter default bvLowered;\r\n property BevelInnerBold: Boolean read FBevelInnerBold write SetBevelInnerBold default True;\r\n property BevelOuterBold: Boolean read FBevelOuterBold write SetBevelOuterBold default True;\r\n property CombineMode: TRGNCombineMode read FCombineMode write SetCombineMode default cmDIFF;\r\n property BevelOffset: Integer read FBevelOffset write SetBevelOffset default 0;\r\n property RectEllipse: TJvgPointClass read FRectEllipse write FRectEllipse;\r\n property ShapeBitmap: TBitmap read FShapeBitmap write SetShapeBitmap;\r\n property Align;\r\n property ShowHint;\r\n property ParentShowHint;\r\n property PopupMenu;\r\n // property Visible;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvgHoleShape.pas $';\r\n Revision: '$Revision: 12461 $';\r\n Date: '$Date: 2009-08-14 19:21:33 +0200 (ven. 14 août 2009) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n Math,\r\n JvgUtils;\r\n\r\nconstructor TJvgHoleShape.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FShapeBitmap := TBitmap.Create;\r\n FEnabled := (Owner is TWinControl);\r\n\r\n ControlStyle := ControlStyle - [csOpaque];\r\n FEnabledAllInDesignTime := FEnabled;\r\n FRectEllipse := TJvgPointClass.Create;\r\n FRectEllipse.X := 30;\r\n FRectEllipse.Y := 30;\r\n FRectEllipse.OnChanged := SmthChanged;\r\n FShape := stEllipse;\r\n FBevelOuter := bvLowered;\r\n FBevelInner := bvNone;\r\n FCombineMode := cmDIFF;\r\n FBevelInnerBold := True;\r\n FBevelOuterBold := True;\r\n FRectEllipse.Y := 45;\r\n FRectEllipse.X := 45;\r\n FBevelOffset := 0;\r\n Width := 112;\r\n Height := 112;\r\n FNeedUpdateRgn := False;\r\nend;\r\n\r\ndestructor TJvgHoleShape.Destroy;\r\nbegin\r\n FShapeBitmap.Free;\r\n FRectEllipse.Free;\r\n if not (csDestroying in Owner.ComponentState) then\r\n begin\r\n FEnabledAllInDesignTime := False;\r\n FEnabled := False;\r\n UpdateRGN;\r\n end;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvgHoleShape.Loaded;\r\nbegin\r\n inherited Loaded;\r\n FNeedRebuildBitmapShape := True;\r\n UpdateRGN;\r\n Refresh;\r\nend;\r\n\r\nprocedure TJvgHoleShape.Paint;\r\nvar\r\n R: TRect;\r\n H, W, EH, EW, I: Integer;\r\n\r\n procedure DrawShape(Bevel: TPanelBevel; ABold, ARect: Boolean);\r\n\r\n procedure SetPenAndBrush(C: TColor);\r\n begin\r\n Canvas.Pen.Color := C;\r\n if ARect and ((EW and EH) = 0) then\r\n Canvas.Brush.Style := bsClear\r\n else\r\n Canvas.Brush.Color := C;\r\n end;\r\n\r\n begin\r\n Canvas.Brush.Style := bsClear; //bsSolid;//bsClear;\r\n I := Integer(ABold);\r\n with Canvas do\r\n case Bevel of\r\n bvLowered:\r\n begin\r\n SetPenAndBrush(clBtnHighlight);\r\n if ARect then\r\n RoundRect(R.Left, R.Top, R.Right, R.Bottom, EW, EH)\r\n else\r\n Ellipse(R.Left, R.Top, R.Right, R.Bottom);\r\n SetPenAndBrush(clBtnShadow);\r\n if ARect then\r\n RoundRect(R.Left, R.Top, R.Right - 1, R.Bottom - 1, EW, EH)\r\n else\r\n Ellipse(R.Left, R.Top, R.Right - 1, R.Bottom - 1);\r\n if ABold then\r\n begin\r\n SetPenAndBrush(cl3DDkShadow);\r\n if ARect then\r\n RoundRect(R.Left + 1, R.Top + 1, R.Right - 1, R.Bottom - 1, EW, EH)\r\n else\r\n Ellipse(R.Left + 1, R.Top + 1, R.Right - 1, R.Bottom - 1);\r\n end;\r\n InflateRect(R, -1, -1);\r\n Inc(R.Left, I);\r\n Inc(R.Top, I);\r\n end;\r\n bvRaised:\r\n begin\r\n SetPenAndBrush(clBtnHighlight);\r\n if ARect then\r\n RoundRect(R.Left, R.Top, R.Right, R.Bottom, EW, EH)\r\n else\r\n Ellipse(R.Left, R.Top, R.Right, R.Bottom);\r\n if ABold then\r\n begin\r\n SetPenAndBrush(cl3DDkShadow);\r\n if ARect then\r\n RoundRect(R.Left + 1, R.Top + 1, R.Right, R.Bottom, EW, EH)\r\n else\r\n Ellipse(R.Left + 1, R.Top + 1, R.Right, R.Bottom);\r\n end;\r\n SetPenAndBrush(clBtnShadow);\r\n if ARect then\r\n RoundRect(R.Left + 1, R.Top + 1, R.Right - I, R.Bottom - I, EW, EH)\r\n else\r\n Ellipse(R.Left + 1, R.Top + 1, R.Right - I, R.Bottom - I);\r\n InflateRect(R, -1, -1);\r\n Dec(R.Right, I);\r\n Dec(R.Bottom, I);\r\n end;\r\n else\r\n begin\r\n //Brush.Color:=clBlack;\r\n //FrameRect( Rect(Left, Top, Left+W, Top+H) );\r\n end;\r\n end;\r\n SetPenAndBrush(clBtnFace);\r\n end;\r\n\r\nbegin\r\n FNeedUpdateRgn := FNeedUpdateRgn or (FOldX <> Left) or (FOldY <> Top) or\r\n (FOldW <> Width) or (FOldH <> Height);\r\n\r\n if FNeedUpdateRgn then\r\n UpdateRGN;\r\n FOldX := Left;\r\n FOldY := Top;\r\n FOldW := Width;\r\n FOldH := Height;\r\n\r\n if IsItAFilledBitmap(FShapeBitmap) then\r\n begin\r\n BitBlt(Canvas.Handle, -1, -1, Width, Height, FShapeBitmap.Canvas.Handle,\r\n 0, 0, SRCCopy);\r\n Exit;\r\n end;\r\n\r\n case FShape of\r\n stRectangle, stRoundRect, stEllipse:\r\n begin\r\n H := Height;\r\n W := Width;\r\n end;\r\n else\r\n H := Min(Height, Width);\r\n W := H;\r\n end;\r\n R := Bounds(0, 0, W, H);\r\n with Canvas do\r\n case FShape of\r\n stRectangle, stSquare, stRoundRect, stRoundSquare:\r\n begin\r\n if (FShape = stRectangle) or (FShape = stSquare) then\r\n begin\r\n EW := 0;\r\n EH := 0;\r\n end;\r\n if (FShape = stRoundRect) or (FShape = stRoundSquare) then\r\n begin\r\n EW := FRectEllipse.X;\r\n EH := FRectEllipse.Y;\r\n end;\r\n\r\n DrawShape(FBevelOuter, FBevelOuterBold, True);\r\n InflateRect(R, -FBevelOffset, -FBevelOffset);\r\n DrawShape(FBevelInner, FBevelInnerBold, True);\r\n\r\n //Pen.Color:=clBtnFace;\r\n //Rect( R.Left, R.Top, R.Right, R.Bottom );\r\n end;\r\n stEllipse, stCircle:\r\n begin\r\n DrawShape(FBevelOuter, FBevelOuterBold, False);\r\n InflateRect(R, -FBevelOffset, -FBevelOffset);\r\n DrawShape(FBevelInner, FBevelInnerBold, False);\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvgHoleShape.CalcRGNs;\r\nvar\r\n H, W, xOffs, yOffs: Integer;\r\n R: TRect;\r\n BmpInfo: Windows.TBitmap;\r\n BorderStyle: TFormBorderStyle;\r\n\r\n procedure CalcShape(Bevel: TPanelBevel; ABold: Boolean);\r\n var\r\n I: Integer;\r\n begin\r\n I := Integer(ABold);\r\n case Bevel of\r\n bvLowered:\r\n begin\r\n InflateRect(R, -1, -1);\r\n Inc(R.Left, I);\r\n Inc(R.Top, I);\r\n end;\r\n bvRaised:\r\n begin\r\n InflateRect(R, -1, -1);\r\n Dec(R.Right, I);\r\n Dec(R.Bottom, I);\r\n end;\r\n end;\r\n end;\r\n\r\n procedure CalcBmpRgn(var Rgn: HRGN);\r\n var\r\n I, J: Integer;\r\n Rgn2: HRGN;\r\n TransparentColor: TColor;\r\n begin\r\n TransparentColor := FShapeBitmap.Canvas.Pixels[0, FShapeBitmap.Height - 1];\r\n for J := 0 to FShapeBitmap.Height do\r\n for I := 0 to FShapeBitmap.Width do\r\n if FShapeBitmap.Canvas.Pixels[I, J] = TransparentColor then\r\n begin\r\n Rgn2 := CreateRectRgn(I, J, I + 1, J + 1);\r\n CombineRgn(Rgn, Rgn2, Rgn, RGN_OR);\r\n DeleteObject(Rgn2);\r\n end;\r\n end;\r\n\r\nbegin\r\n if not FShapeBitmap.Empty then\r\n begin\r\n {if FNeedRebuildBitmapShape then}\r\n with FShapeBitmap do\r\n begin\r\n GetObject(FShapeBitmap.Handle, SizeOf(Windows.TBitmap), @BmpInfo);\r\n DeleteObject(RGNOuter);\r\n DeleteObject(RGNInner);\r\n RGNInner := CreateRectRgn(0, 0, 0, 0);\r\n CalcBmpRgn(FRGNInner);\r\n FNeedRebuildBitmapShape := False;\r\n end;\r\n end\r\n else\r\n begin\r\n case FShape of\r\n stRectangle, stRoundRect, stEllipse:\r\n begin\r\n H := Height;\r\n W := Width;\r\n end\r\n else\r\n H := Min(Height, Width);\r\n W := H;\r\n end;\r\n R := Bounds(0, 0, W, H);\r\n DeleteObject(RGNOuter);\r\n DeleteObject(RGNInner);\r\n\r\n if FBevelOffset <> 0 then\r\n begin\r\n CalcShape(FBevelOuter, FBevelOuterBold);\r\n OffsetRect(R, 1, 1);\r\n end;\r\n case FShape of\r\n stRectangle, stSquare:\r\n RGNOuter := CreateRectRgn(R.Left, R.Top, R.Right, R.Bottom);\r\n stRoundRect, stRoundSquare:\r\n RGNOuter := CreateRoundRectRgn(R.Left, R.Top, R.Right, R.Bottom,\r\n FRectEllipse.X, FRectEllipse.Y);\r\n stEllipse, stCircle:\r\n RGNOuter := CreateEllipticRgn(R.Left, R.Top, R.Right, R.Bottom);\r\n end;\r\n if FBevelOffset = 0 then\r\n CalcShape(FBevelOuter, FBevelOuterBold);\r\n InflateRect(R, -FBevelOffset, -FBevelOffset);\r\n if FBevelOffset = 0 then\r\n CalcShape(FBevelInner, FBevelInnerBold)\r\n else\r\n OffsetRect(R, -1, -1);\r\n case FShape of\r\n stRectangle, stSquare:\r\n RGNInner := CreateRectRgn(R.Left + 1, R.Top + 1, R.Right + 1,\r\n R.Bottom + 1);\r\n stRoundRect, stRoundSquare:\r\n RGNInner := CreateRoundRectRgn(R.Left + 1, R.Top + 1, R.Right + 2,\r\n R.Bottom + 2, FRectEllipse.X, FRectEllipse.Y);\r\n stEllipse, stCircle:\r\n RGNInner := CreateEllipticRgn(R.Left + 1, R.Top + 1, R.Right + 2,\r\n R.Bottom + 2);\r\n end;\r\n end;\r\n\r\n { calc offsets }\r\n if Owner is TForm then\r\n begin\r\n if csDesigning in ComponentState then\r\n BorderStyle := bsSizeable\r\n else\r\n BorderStyle := TForm(Owner).BorderStyle;\r\n case BorderStyle of\r\n bsSizeable:\r\n begin\r\n xOffs := GetSystemMetrics(SM_CXFRAME) - 1;\r\n yOffs := GetSystemMetrics(SM_CYFRAME) - 1;\r\n Inc(yOffs, GetSystemMetrics(SM_CYCAPTION));\r\n end;\r\n bsDialog:\r\n begin\r\n xOffs := GetSystemMetrics(SM_CXDLGFRAME) - 1;\r\n yOffs := GetSystemMetrics(SM_CYDLGFRAME) - 1;\r\n Inc(yOffs, GetSystemMetrics(SM_CYCAPTION));\r\n end;\r\n bsSingle:\r\n begin\r\n xOffs := GetSystemMetrics(SM_CXBORDER);\r\n yOffs := GetSystemMetrics(SM_CYBORDER);\r\n Inc(yOffs, GetSystemMetrics(SM_CYCAPTION));\r\n end;\r\n bsToolWindow:\r\n begin\r\n xOffs := GetSystemMetrics(SM_CXBORDER);\r\n yOffs := GetSystemMetrics(SM_CYBORDER);\r\n Inc(yOffs, GetSystemMetrics(SM_CYSMCAPTION));\r\n end;\r\n bsSizeToolWin:\r\n begin\r\n xOffs := GetSystemMetrics(SM_CXSIZEFRAME);\r\n yOffs := GetSystemMetrics(SM_CYSIZEFRAME);\r\n Inc(yOffs, GetSystemMetrics(SM_CYSMCAPTION));\r\n end;\r\n else\r\n begin\r\n xOffs := -1;\r\n yOffs := -1;\r\n end;\r\n end;\r\n\r\n OffsetRgn(RGNInner, Left + xOffs, Top + yOffs);\r\n OffsetRgn(RGNOuter, Left + xOffs, Top + yOffs);\r\n end;\r\nend;\r\n\r\n//...set all enabled/disabled in design time\r\n\r\nprocedure TJvgHoleShape.SayAllDTEnabledState(EnabledDT: Boolean);\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := 0 to TWinControl(Owner).ControlCount - 1 do\r\n with TWinControl(Owner) do\r\n if Controls[I] is TJvgHoleShape then\r\n TJvgHoleShape(Controls[I]).FEnabledAllInDesignTime := EnabledDT;\r\nend;\r\n\r\nprocedure TJvgHoleShape.UpdateRGN;\r\nconst\r\n cCombMode: array [0..4] of Integer =\r\n (RGN_AND, RGN_COPY, RGN_DIFF, RGN_OR, RGN_XOR);\r\nvar\r\n I: Integer;\r\n NewRGN: HRGN;\r\nbegin\r\n if not (Owner is TWinControl) then\r\n Exit;\r\n NewRGN := CreateRectRgn(0, 0, 2000, 1000);\r\n\r\n for I := 0 to TWinControl(Owner).ControlCount - 1 do\r\n with TWinControl(Owner) do\r\n if Controls[I] is TJvgHoleShape then\r\n with TJvgHoleShape(Controls[I]) do\r\n if ((csDesigning in ComponentState) and FEnabledAllInDesignTime) or\r\n ((not (csDesigning in ComponentState)) and FEnabled) then\r\n begin\r\n CalcRGNs;\r\n CombineRgn(NewRGN, NewRGN, RGNInner, cCombMode[Integer(FCombineMode)]);\r\n end;\r\n\r\n SetWindowRgn(TWinControl(Owner).Handle, NewRGN, True);\r\n FNeedUpdateRgn := False;\r\nend;\r\n\r\nprocedure TJvgHoleShape.InternalUpdate;\r\nbegin\r\n if not (csLoading in ComponentState) then\r\n begin\r\n UpdateRGN;\r\n Refresh;\r\n end;\r\nend;\r\n\r\nprocedure TJvgHoleShape.SmthChanged(Sender: TObject);\r\nbegin\r\n InternalUpdate;\r\nend;\r\n\r\nprocedure TJvgHoleShape.SetEnabled(Value: Boolean);\r\nbegin\r\n if (FEnabled <> Value) and (Owner is TWinControl) then\r\n begin\r\n FEnabled := Value;\r\n InternalUpdate;\r\n end;\r\nend;\r\n\r\nprocedure TJvgHoleShape.SetEnabledAllInDesignTime(Value: Boolean);\r\nbegin\r\n if (FEnabledAllInDesignTime <> Value) and (Owner is TWinControl) then\r\n begin\r\n FEnabledAllInDesignTime := Value;\r\n SayAllDTEnabledState(FEnabledAllInDesignTime);\r\n InternalUpdate;\r\n end;\r\nend;\r\n\r\nprocedure TJvgHoleShape.SetShape(Value: THoleShapeType);\r\nbegin\r\n if FShape <> Value then\r\n begin\r\n FShape := Value;\r\n InternalUpdate;\r\n end;\r\nend;\r\n\r\nprocedure TJvgHoleShape.SetShapeBitmap(Value: TBitmap);\r\nbegin\r\n if FShapeBitmap <> Value then\r\n begin\r\n FNeedRebuildBitmapShape := True;\r\n FShapeBitmap.Assign(Value);\r\n if Assigned(FShapeBitmap) then\r\n begin\r\n Width := FShapeBitmap.Width;\r\n Height := FShapeBitmap.Width;\r\n end;\r\n InternalUpdate;\r\n end;\r\nend;\r\n\r\nprocedure TJvgHoleShape.SetBevelInner(Value: TPanelBevel);\r\nbegin\r\n if FBevelInner <> Value then\r\n begin\r\n FBevelInner := Value;\r\n InternalUpdate;\r\n end;\r\nend;\r\n\r\nprocedure TJvgHoleShape.SetBevelOuter(Value: TPanelBevel);\r\nbegin\r\n if FBevelOuter <> Value then\r\n begin\r\n FBevelOuter := Value;\r\n InternalUpdate;\r\n end;\r\nend;\r\n\r\nprocedure TJvgHoleShape.SetBevelInnerBold(Value: Boolean);\r\nbegin\r\n if FBevelInnerBold <> Value then\r\n begin\r\n FBevelInnerBold := Value;\r\n InternalUpdate;\r\n end;\r\nend;\r\n\r\nprocedure TJvgHoleShape.SetBevelOuterBold(Value: Boolean);\r\nbegin\r\n if FBevelOuterBold <> Value then\r\n begin\r\n FBevelOuterBold := Value;\r\n InternalUpdate;\r\n end;\r\nend;\r\n\r\nprocedure TJvgHoleShape.SetCombineMode(Value: TRGNCombineMode);\r\nbegin\r\n if FCombineMode <> Value then\r\n begin\r\n FCombineMode := Value;\r\n InternalUpdate;\r\n end;\r\nend;\r\n\r\nprocedure TJvgHoleShape.SetBevelOffset(Value: Integer);\r\nbegin\r\n if (FBevelOffset <> Value) and (Value >= 0) then\r\n begin\r\n if (Value > Width - 2) or (Value > Height - 2) then\r\n Value := Min(Width, Height) - 2;\r\n FBevelOffset := Value;\r\n InternalUpdate;\r\n end;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvgImage.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvgImage.PAS, released on 2003-01-15.\r\n\r\nThe Initial Developer of the Original Code is Andrey V. Chudin, [chudin att yandex dott ru]\r\nPortions created by Andrey V. Chudin are Copyright (C) 2003 Andrey V. Chudin.\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\nMichael Beck [mbeck att bigfoot dott com].\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvgImage.pas 12864 2010-10-11 08:19:42Z obones $\r\n\r\nunit JvgImage;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,\r\n Dialogs, ExtCtrls,\r\n JvComponent, JvJVCLUtils,\r\n JvgTypes, JvgUtils, JvgCommClasses;\r\n\r\ntype\r\n TJvgBitmapImage = class(TJvGraphicControl)\r\n private\r\n FAutoSize: Boolean;\r\n FImageAlign: TJvg2DAlign;\r\n FBitmapOption: TglWallpaperOption;\r\n FDrawState: TglDrawState;\r\n FTransparent: Boolean;\r\n FTransparentColor: TColor;\r\n FMasked: Boolean;\r\n FMaskedColor: TColor;\r\n FMaskedToColor: TColor;\r\n FDisabledMaskColor: TColor;\r\n FBitmap: TBitmap;\r\n FImage: TImage;\r\n FAutoTransparentColor: TglAutoTransparentColor;\r\n FFastDraw: Boolean;\r\n FBmp: TBitmap;\r\n FChanged: Boolean;\r\n FOnChangeParams: TNotifyEvent;\r\n // FOldClientRect: TRect;\r\n FOldWidth: Integer;\r\n FOldHeight: Integer;\r\n procedure CreateResBitmap;\r\n procedure Changed;\r\n procedure SmthChanged(Sender: TObject);\r\n function CalcAlignOffset: TPoint;\r\n function GetBitmap: TBitmap;\r\n procedure SetBitmap(Value: TBitmap);\r\n procedure SetImage(Value: TImage);\r\n procedure SetBitmapOption(Value: TglWallpaperOption);\r\n procedure SetDrawState(Value: TglDrawState);\r\n procedure SetTransparent(Value: Boolean);\r\n procedure SetTransparentColor(Value: TColor);\r\n procedure SetMasked(Value: Boolean);\r\n procedure SetMaskedColor(Value: TColor);\r\n procedure SetMaskedToColor(Value: TColor);\r\n procedure SetDisabledMaskColor(Value: TColor);\r\n procedure SetAutoTransparentColor(Value: TglAutoTransparentColor);\r\n procedure SetFastDraw(Value: Boolean);\r\n protected\r\n procedure SetAutoSize(Value: Boolean); override;\r\n procedure Loaded; override;\r\n procedure Notification(AComponent: TComponent; Operation: TOperation); override;\r\n public\r\n FResBitmap: TBitmap; //...you can use it!\r\n // procedure PaintTo(Canvas: TCanvas);\r\n procedure Paint; override;\r\n property Canvas;\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n procedure RemakeBackground; //...for users\r\n // procedure RepaintBackground; //...for users\r\n published\r\n property AutoSize: Boolean read FAutoSize write SetAutoSize default False;\r\n property Bitmap: TBitmap read GetBitmap write SetBitmap;\r\n property Image: TImage read FImage write SetImage;\r\n property ImageAlign: TJvg2DAlign read FImageAlign write FImageAlign;\r\n property BitmapOption: TglWallpaperOption read FBitmapOption write SetBitmapOption default fwoNone;\r\n property DrawState: TglDrawState read FDrawState write SetDrawState default fdsDefault;\r\n property Transparent: Boolean read FTransparent write SetTransparent default False;\r\n property TransparentColor: TColor read FTransparentColor write SetTransparentColor default clOlive;\r\n property Masked: Boolean read FMasked write SetMasked default False;\r\n property MaskedColor: TColor read FMaskedColor write SetMaskedColor default clOlive;\r\n property MaskedToColor: TColor read FMaskedToColor write SetMaskedToColor default clBtnFace;\r\n property DisabledMaskColor: TColor read FDisabledMaskColor write SetDisabledMaskColor default clBlack;\r\n property AutoTransparentColor: TglAutoTransparentColor read FAutoTransparentColor\r\n write SetAutoTransparentColor default ftcLeftBottomPixel;\r\n property FastDraw: Boolean read FFastDraw write SetFastDraw default False;\r\n property Anchors;\r\n property Align;\r\n property Color;\r\n property DragCursor;\r\n property DragMode;\r\n property Enabled;\r\n property Font;\r\n property ParentColor;\r\n property ParentFont;\r\n property ParentShowHint;\r\n property PopupMenu;\r\n property ShowHint;\r\n property Visible;\r\n property OnClick;\r\n property OnDblClick;\r\n property OnDragDrop;\r\n property OnDragOver;\r\n property OnEndDrag;\r\n property OnMouseDown;\r\n property OnMouseMove;\r\n property OnMouseUp;\r\n property OnStartDrag;\r\n property OnChangeParams: TNotifyEvent read FOnChangeParams write FOnChangeParams;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvgImage.pas $';\r\n Revision: '$Revision: 12864 $';\r\n Date: '$Date: 2010-10-11 10:19:42 +0200 (lun. 11 oct. 2010) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n Math;\r\n\r\nconstructor TJvgBitmapImage.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n Width := 105;\r\n Height := 105;\r\n\r\n FResBitmap := TBitmap.Create;\r\n FImageAlign := TJvg2DAlign.Create;\r\n FImageAlign.OnChanged := SmthChanged;\r\n FChanged := True;\r\n // FOldClientRect := Rect(left, top, left + Width, top + Height);\r\n //...defaults\r\n FAutoSize := False;\r\n FBitmapOption := fwoNone;\r\n FDrawState := fdsDefault;\r\n FTransparent := False;\r\n FTransparentColor := clOlive;\r\n FMasked := False;\r\n FMaskedColor := clOlive;\r\n FMaskedToColor := clBtnFace;\r\n FDisabledMaskColor := clBlack;\r\n FAutoTransparentColor := ftcLeftBottomPixel;\r\n FFastDraw := False;\r\n OnChangeParams := nil;\r\nend;\r\n\r\ndestructor TJvgBitmapImage.Destroy;\r\nbegin\r\n FResBitmap.Free;\r\n FBitmap.Free;\r\n FImageAlign.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvgBitmapImage.Loaded;\r\nbegin\r\n inherited Loaded;\r\n if Assigned(FBitmap) and not FBitmap.Empty then\r\n FBmp := FBitmap;\r\n SetAutoTransparentColor(FAutoTransparentColor);\r\nend;\r\n\r\nprocedure TJvgBitmapImage.Notification(AComponent: TComponent; Operation: TOperation);\r\nbegin\r\n inherited Notification(AComponent, Operation);\r\n if (AComponent = Image) and (Operation = opRemove) then\r\n Image := nil;\r\nend;\r\n\r\nprocedure TJvgBitmapImage.Paint;\r\nvar\r\n //R, IntersectR: TRect;\r\n Pt: TPoint;\r\nbegin\r\n if Assigned(Bitmap) then\r\n FBmp := Bitmap;\r\n if Assigned(Image) then\r\n FBmp := Image.Picture.Bitmap;\r\n\r\n if Assigned(FBmp) and (FBmp.Handle <> 0) then\r\n begin\r\n if (FOldWidth <> Width) or (FOldHeight <> Height) then\r\n begin\r\n FChanged := True;\r\n {if (OldLeft=Left)and(OldTop=Top) then\r\n begin\r\n R:=Rect( left, top, left+Width, top+Height );\r\n IntersectRect( IntersectR, FOldClientRect, R );\r\n InvalidateRect( Parent.Handle, @R, False );\r\n ValidateRect( Parent.Handle, @IntersectR );\r\n FOldClientRect := R;\r\n end;}\r\n end;\r\n //OldLeft := Left; OldTop := Top;\r\n FOldWidth := Width;\r\n FOldHeight := Height;\r\n\r\n if FChanged or not FFastDraw then\r\n begin\r\n CreateResBitmap;\r\n FChanged := False;\r\n end;\r\n Pt := CalcAlignOffset;\r\n BitBlt(Canvas.Handle, Pt.X, Pt.Y, FResBitmap.Width, FResBitmap.Height,\r\n FResBitmap.Canvas.Handle, 0, 0, SRCCOPY);\r\n end;\r\n if (csDesigning in ComponentState) and (Tag <> 9999) then\r\n with Canvas do\r\n begin\r\n Pen.Color := clBlack;\r\n Pen.Style := psDash;\r\n Brush.Style := bsClear;\r\n Rectangle(0, 0, Width, Height);\r\n end;\r\nend;\r\n\r\nprocedure TJvgBitmapImage.RemakeBackground;\r\nbegin\r\n FChanged := True;\r\n Repaint;\r\nend;\r\n\r\n//procedure TJvgBitmapImage.WMSize(var Message: TWMSize);\r\n//var R,IntersectR: TRect;\r\n//begin\r\n{ Exit;\r\n if FAutoSize then\r\n begin Width:=FResBitmap.Width; Height:=FResBitmap.Height; end;\r\n if not FTransparent then\r\n begin\r\n R:=Rect( left, top, left+Width, top+Height );\r\n IntersectRect( IntersectR, FOldClientRect, R );\r\n InvalidateRect( Parent.Handle, @R, False );\r\n ValidateRect( Parent.Handle, @IntersectR );\r\n FOldClientRect := R;\r\n end\r\n else\r\n Invalidate;\r\n Changed;}\r\n//end;\r\n\r\nprocedure TJvgBitmapImage.CreateResBitmap;\r\nvar\r\n Pt: TPoint;\r\n // BmpInfo: Windows.TBitmap;\r\nbegin\r\n if (FBitmapOption = fwoStretch) or (FBitmapOption = fwoPropStretch) or\r\n (FBitmapOption = fwoTile) then\r\n begin\r\n FResBitmap.Width := Width;\r\n FResBitmap.Height := Height;\r\n end\r\n else\r\n begin\r\n FResBitmap.Width := FBmp.Width;\r\n FResBitmap.Height := FBmp.Height;\r\n end;\r\n\r\n with FResBitmap do\r\n begin\r\n // if FTransparent then Canvas.Brush.Color := FTransparentColor\r\n Canvas.Brush.Color := clBtnFace;\r\n Canvas.Brush.Style := bsSolid;\r\n Canvas.FillRect(Bounds(0, 0, Width, Height));\r\n end;\r\n\r\n Pt := CalcAlignOffset;\r\n if FTransparent then\r\n GetParentImageRect(Self, Bounds(Left + Pt.X, Top + Pt.Y, FResBitmap.Width,\r\n FResBitmap.Height),\r\n FResBitmap.Canvas.Handle);\r\n //BringParentWindowToTop(parent);\r\n// BitBlt( FResBitmap.Canvas.Handle, 0,0, Width, Height, Canvas.Handle, 0, 0, SRCCOPY);\r\n\r\n CreateBitmapExt(FResBitmap.Canvas.Handle, FBmp, ClientRect, 0, 0,\r\n FBitmapOption, FDrawState,\r\n FTransparent, FTransparentColor, FDisabledMaskColor);\r\n\r\n if FMasked then\r\n JvgUtils.ChangeBitmapColor(FResBitmap, FMaskedColor, FMaskedToColor);\r\n\r\n { GetObject( FResBitmap.Handle, SizeOf(Windows.TBitmap), @BmpInfo );\r\n if BmpInfo.bmBitsPixel >= 8 then\r\n with FResBitmap,BmpInfo do\r\n begin\r\n for i := 1 to bmWidth*bmHeight*(bmBitsPixel div 8)-1 do\r\n begin\r\n asm\r\n inc BmpInfo.bmBits\r\n end;\r\n Byte(bmBits^):=1;\r\n end;\r\n end;}\r\nend;\r\n\r\nprocedure TJvgBitmapImage.Changed;\r\nbegin\r\n FChanged := True;\r\n if Assigned(OnChangeParams) then\r\n OnChangeParams(Self);\r\nend;\r\n\r\nprocedure TJvgBitmapImage.SmthChanged(Sender: TObject);\r\nbegin\r\n Changed;\r\n Invalidate;\r\nend;\r\n\r\nfunction TJvgBitmapImage.CalcAlignOffset: TPoint;\r\nvar\r\n D, D1: Double;\r\n Pt: TPoint;\r\nbegin\r\n Result.X := 0;\r\n Result.Y := 0;\r\n if (FBitmapOption = fwoNone) or (FBitmapOption = fwoPropStretch) then\r\n begin\r\n Pt.X := FBmp.Width;\r\n Pt.Y := FBmp.Height;\r\n if FBitmapOption = fwoPropStretch then\r\n begin\r\n D1 := Width / Pt.X;\r\n D := Height / Pt.Y;\r\n if D > D1 then\r\n D := D1; //...D == Min\r\n Pt.X := Trunc(Pt.X * D);\r\n Pt.Y := Trunc(Pt.Y * D);\r\n end;\r\n case ImageAlign.Horizontal of\r\n fhaCenter:\r\n Result.X := Max(0, (Width - Pt.X) div 2);\r\n fhaRight:\r\n Result.X := Max(0, Width - Pt.X);\r\n end;\r\n case ImageAlign.Vertical of\r\n fvaCenter:\r\n Result.Y := Max(0, (Height - Pt.Y) div 2);\r\n fvaBottom:\r\n Result.Y := Max(0, Height - Pt.Y);\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvgBitmapImage.SetAutoSize(Value: Boolean);\r\nbegin\r\n if (FAutoSize = Value) or not Assigned(FBmp) then\r\n Exit;\r\n FAutoSize := Value;\r\n if FAutoSize and (FBitmapOption = fwoNone) and\r\n // (rom) strange this evaluates to FBmp.Width <> FBmp.Height\r\n ((FBmp.Width and FBmp.Height) <> 0) then\r\n begin\r\n Width := FBmp.Width;\r\n Height := FBmp.Height;\r\n Changed;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nfunction TJvgBitmapImage.GetBitmap: TBitmap;\r\nbegin\r\n if not Assigned(FBitmap) then\r\n FBitmap := TBitmap.Create;\r\n Result := FBitmap;\r\nend;\r\n\r\nprocedure TJvgBitmapImage.SetBitmap(Value: TBitmap);\r\nbegin\r\n FBitmap.Free;\r\n FBitmap := TBitmap.Create;\r\n FBitmap.Assign(Value);\r\n if Assigned(Value) then\r\n FBmp := FBitmap\r\n else\r\n if Assigned(FImage) and Assigned(FImage.Picture) and\r\n Assigned(FImage.Picture.Bitmap) then\r\n FBmp := FImage.Picture.Bitmap\r\n else\r\n FBmp := nil;\r\n SetAutoTransparentColor(FAutoTransparentColor);\r\n Changed;\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvgBitmapImage.SetImage(Value: TImage);\r\nbegin\r\n ReplaceComponentReference(Self, Value, TComponent(FImage));\r\n if Assigned(FImage) and Assigned(FImage.Picture) and\r\n Assigned(FImage.Picture.Bitmap) then\r\n FBmp := FImage.Picture.Bitmap\r\n else\r\n if Assigned(FBitmap) then\r\n FBmp := FBitmap\r\n else\r\n FBmp := nil;\r\n SetAutoTransparentColor(FAutoTransparentColor);\r\n Changed;\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvgBitmapImage.SetBitmapOption(Value: TglWallpaperOption);\r\nbegin\r\n if FBitmapOption <> Value then\r\n begin\r\n FBitmapOption := Value;\r\n Changed;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvgBitmapImage.SetDrawState(Value: TglDrawState);\r\nbegin\r\n if FDrawState <> Value then\r\n begin\r\n FDrawState := Value;\r\n Changed;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvgBitmapImage.SetTransparent(Value: Boolean);\r\nbegin\r\n if FTransparent <> Value then\r\n begin\r\n FTransparent := Value;\r\n Changed;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvgBitmapImage.SetTransparentColor(Value: TColor);\r\nbegin\r\n if (FAutoTransparentColor <> ftcUser) or (FTransparentColor = Value) then\r\n Exit;\r\n FTransparentColor := Value;\r\n Changed;\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvgBitmapImage.SetMasked(Value: Boolean);\r\nbegin\r\n if FMasked <> Value then\r\n begin\r\n FMasked := Value;\r\n Changed;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvgBitmapImage.SetMaskedColor(Value: TColor);\r\nbegin\r\n if FMaskedColor <> Value then\r\n begin\r\n FMaskedColor := Value;\r\n Changed;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvgBitmapImage.SetMaskedToColor(Value: TColor);\r\nbegin\r\n if FMaskedToColor <> Value then\r\n begin\r\n FMaskedToColor := Value;\r\n Changed;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvgBitmapImage.SetDisabledMaskColor(Value: TColor);\r\nbegin\r\n if FDisabledMaskColor <> Value then\r\n begin\r\n FDisabledMaskColor := Value;\r\n Changed;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvgBitmapImage.SetAutoTransparentColor(Value: TglAutoTransparentColor);\r\nbegin\r\n FAutoTransparentColor := Value;\r\n if not Assigned(FBmp) then\r\n Exit;\r\n if Value <> ftcUser then\r\n FTransparentColor := GetTransparentColor(FBmp, Value);\r\n Changed;\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvgBitmapImage.SetFastDraw(Value: Boolean);\r\nbegin\r\n if FFastDraw <> Value then\r\n begin\r\n FFastDraw := Value;\r\n Changed;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvgImageGroup.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvgImageGroup.PAS, released on 2003-01-15.\r\n\r\nThe Initial Developer of the Original Code is Andrey V. Chudin, [chudin att yandex dott ru]\r\nPortions created by Andrey V. Chudin are Copyright (C) 2003 Andrey V. Chudin.\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\nMichael Beck [mbeck att bigfoot dott com].\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvgImageGroup.pas 12537 2009-10-03 09:55:35Z ahuser $\r\n\r\nunit JvgImageGroup;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,\r\n ExtCtrls,\r\n JvComponent,\r\n JvgTypes, JvgUtils, JvgCommClasses;\r\n\r\ntype\r\n TJvgImageGroup = class(TJvGraphicControl)\r\n private\r\n FImageList: TImageList;\r\n // FPassiveMask: TBitmap;\r\n // FActiveMask: TBitmap;\r\n // FSelectedMask: TBitmap;\r\n // FSingleSelected: Boolean;\r\n FTransparent: Boolean;\r\n FTransparentColor: TColor;\r\n FMasked: Boolean;\r\n FMaskedColor: TColor;\r\n FDisabledMaskColor: TColor;\r\n FAutoTrColor: TglAutoTransparentColor;\r\n FFastDraw: Boolean;\r\n FNeedRemakeBackground: Boolean;\r\n FImage: TBitmap;\r\n // OldWidth, OldHeight,\r\n // OldLeft, OldTop: Integer;\r\n // procedure SmthChanged(Sender: TObject);\r\n procedure SetImageList(Value: TImageList);\r\n procedure SetTransparent(Value: Boolean);\r\n procedure SetTransparentColor(Value: TColor);\r\n procedure SetMasked(Value: Boolean);\r\n procedure SetMaskedColor(Value: TColor);\r\n procedure SetDisabledMaskColor(Value: TColor);\r\n procedure SetAutoTrColor(Value: TglAutoTransparentColor);\r\n procedure SetFastDraw(Value: Boolean);\r\n protected\r\n procedure Paint; override;\r\n procedure WMSize(var Msg: TMessage);\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n procedure CreateResBitmap;\r\n procedure RemakeBackground;\r\n published\r\n property Images: TImageList read FImageList write SetImageList;\r\n property Transparent: Boolean read FTransparent write SetTransparent default False;\r\n property TransparentColor: TColor read FTransparentColor write SetTransparentColor default clOlive;\r\n property Masked: Boolean read FMasked write SetMasked default False;\r\n property MaskedColor: TColor read FMaskedColor write SetMaskedColor default clOlive;\r\n property DisabledMaskColor: TColor read FDisabledMaskColor write SetDisabledMaskColor default clBlack;\r\n property AutoTransparentColor: TglAutoTransparentColor read FAutoTrColor write SetAutoTrColor default ftcLeftBottomPixel;\r\n property FastDraw: Boolean read FFastDraw write SetFastDraw default False;\r\n property Align;\r\n property DragCursor;\r\n property DragMode;\r\n property Enabled;\r\n property ParentShowHint;\r\n property PopupMenu;\r\n property ShowHint;\r\n property Visible;\r\n property OnClick;\r\n property OnDblClick;\r\n property OnDragDrop;\r\n property OnDragOver;\r\n property OnEndDrag;\r\n property OnMouseDown;\r\n property OnMouseMove;\r\n property OnMouseUp;\r\n property OnStartDrag;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvgImageGroup.pas $';\r\n Revision: '$Revision: 12537 $';\r\n Date: '$Date: 2009-10-03 11:55:35 +0200 (sam. 03 oct. 2009) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n Math;\r\n\r\nconstructor TJvgImageGroup.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n // ControlStyle := ControlStyle + [{csReplicatable,}csOpaque];\r\n Width := 105;\r\n Height := 105;\r\n\r\n FImage := TBitmap.Create;\r\n //...defaults\r\n FTransparent := False;\r\n FTransparentColor := clOlive;\r\n FMasked := False;\r\n FMaskedColor := clOlive;\r\n FDisabledMaskColor := clBlack;\r\n FAutoTrColor := ftcLeftBottomPixel;\r\n FFastDraw := False;\r\nend;\r\n\r\ndestructor TJvgImageGroup.Destroy;\r\nbegin\r\n FImage.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvgImageGroup.WMSize(var Msg: TMessage);\r\nbegin\r\n if csDesigning in ComponentState then\r\n CreateResBitmap;\r\nend;\r\n\r\nprocedure TJvgImageGroup.Paint;\r\nbegin\r\n // if fNeedRebuildImage then\r\n CreateResBitmap;\r\n BitBlt(Canvas.Handle, 0, 0, Width, Height, FImage.Canvas.Handle, 0, 0, SRCCOPY);\r\nend;\r\n\r\nprocedure TJvgImageGroup.RemakeBackground;\r\nbegin\r\n FNeedRemakeBackground := True;\r\n Repaint;\r\nend;\r\n\r\nprocedure TJvgImageGroup.CreateResBitmap;\r\nvar\r\n I: Integer;\r\n Bitmap: TBitmap;\r\nbegin\r\n if (FImageList = nil) or (FImageList.Count = 0) then\r\n Exit;\r\n\r\n Bitmap := TBitmap.Create;\r\n\r\n FImage.Width := FImageList.Width * FImageList.Count;\r\n FImage.Height := FImageList.Height;\r\n Width := Max(FImage.Width, Width);\r\n Height := Max(FImage.Height, Height);\r\n with FImage do\r\n begin\r\n Canvas.Brush.Color := clBtnFace;\r\n Canvas.Brush.Style := bsSolid;\r\n Canvas.FillRect(Bounds(0, 0, Width, Height));\r\n end;\r\n\r\n if FTransparent then\r\n GetParentImageRect(Self, Bounds(Left, Top, FImage.Width, FImage.Height),\r\n FImage.Canvas.Handle);\r\n\r\n for I := 0 to FImageList.Count - 1 do\r\n begin\r\n FImageList.GetBitmap(I, Bitmap);\r\n\r\n if FMasked then\r\n JvgUtils.ChangeBitmapColor(FImage, FMaskedColor, clBtnFace);\r\n\r\n CreateBitmapExt(FImage.Canvas.Handle, Bitmap, ClientRect,\r\n I * FImageList.Width, 0,\r\n fwoNone, fdsDefault,\r\n FTransparent, FTransparentColor, FDisabledMaskColor);\r\n end;\r\n Bitmap.Free;\r\nend;\r\n\r\n{\r\nprocedure TJvgImageGroup.SmthChanged(Sender: TObject);\r\nbegin\r\n Invalidate;\r\nend;\r\n}\r\n\r\nprocedure TJvgImageGroup.SetImageList(Value: TImageList);\r\nbegin\r\n FImageList := Value;\r\n // SetAutoTrColor( FAutoTrColor );\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvgImageGroup.SetTransparent(Value: Boolean);\r\nbegin\r\n if FTransparent <> Value then\r\n begin\r\n FTransparent := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvgImageGroup.SetTransparentColor(Value: TColor);\r\nbegin\r\n if FTransparentColor <> Value then\r\n begin\r\n // FAutoTrColor:=ftcUser;\r\n FTransparentColor := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvgImageGroup.SetMasked(Value: Boolean);\r\nbegin\r\n if FMasked <> Value then\r\n begin\r\n FMasked := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvgImageGroup.SetMaskedColor(Value: TColor);\r\nbegin\r\n if FMaskedColor <> Value then\r\n begin\r\n FMaskedColor := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvgImageGroup.SetDisabledMaskColor(Value: TColor);\r\nbegin\r\n if FDisabledMaskColor <> Value then\r\n begin\r\n FDisabledMaskColor := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvgImageGroup.SetAutoTrColor(Value: TglAutoTransparentColor);\r\n//var x, y : Integer;\r\nbegin {\r\n FAutoTrColor := Value;\r\n if (FAutoTrColor=ftcUser)or((FBitmap.Width or FBitmap.Height)=0)then\r\n Exit;\r\n case FAutoTrColor of\r\n ftcLeftTopPixel: begin x:=0; y:=0; end;\r\n ftcLeftBottomPixel: begin x:=0; y:=FBitmap.Height-1; end;\r\n ftcRightTopPixel: begin x:=FBitmap.Width-1; y:=0; end;\r\n ftcRightBottomPixel: begin x:=FBitmap.Width-1; y:=FBitmap.Height-1; end;\r\n end;\r\n FTransparentColor := GetPixel(FBitmap.Canvas.Handle,x,y);\r\n Invalidate;}\r\nend;\r\n\r\nprocedure TJvgImageGroup.SetFastDraw(Value: Boolean);\r\nbegin\r\n FFastDraw := Value;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvgLabel.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvgLabel.PAS, released on 2003-01-15.\r\n\r\nThe Initial Developer of the Original Code is Andrey V. Chudin, [chudin att yandex dott ru]\r\nPortions created by Andrey V. Chudin are Copyright (C) 2003 Andrey V. Chudin.\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\nMichael Beck [mbeck att bigfoot dott com].\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvgLabel.pas 13173 2011-11-19 12:43:58Z ahuser $\r\n\r\nunit JvgLabel;\r\n\r\n{$I jvcl.inc}\r\n{$I windowsonly.inc} // (ahuser) uses WndProc and Wnd hooks\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,\r\n Dialogs, StdCtrls, ExtCtrls,\r\n JvComponent, JvJVCLUtils,\r\n JvgTypes, JvgCommClasses, JvgUtils;\r\n\r\nconst\r\n FTextAlign = DT_LEFT or DT_SINGLELINE;\r\n RadianEscapments: array [TglLabelDir] of Integer = (0, -1800, -900, 900);\r\n\r\ntype\r\n TFontWeight = (fwDONTCARE, fwTHIN, fwEXTRALIGHT, fwLIGHT, fwNORMAL, fwMEDIUM,\r\n fwSEMIBOLD, fwBOLD, fwEXTRABOLD, fwHEAVY);\r\n\r\n TJvgCustomLabel = class(TJvGraphicControl)\r\n private\r\n FAutoSize: Boolean;\r\n FFocusControl: TWinControl;\r\n FFocusControlMethod: TFocusControlMethod;\r\n FTransparent: Boolean;\r\n FPrevWndProc: Pointer;\r\n FNewWndProc: Pointer;\r\n procedure SetFocusControl(Value: TWinControl);\r\n procedure SetTransparent(Value: Boolean);\r\n procedure WMLMouseUp(var Msg: TMessage); message WM_LBUTTONUP;\r\n procedure WMLMouseDown(var Msg: TMessage); message WM_LBUTTONDOWN;\r\n protected\r\n FActiveNow: Boolean;\r\n FShowAsActiveWhileControlFocused: Boolean;\r\n ActiveWhileControlFocused: Boolean;\r\n FNeedRehookFocusControl: Boolean;\r\n FExternalCanvas: TCanvas;\r\n procedure HookFocusControlWndProc;\r\n procedure UnhookFocusControlWndProc;\r\n procedure FocusControlWndHookProc(var Msg: TMessage);\r\n procedure Notification(AComponent: TComponent; Operation: TOperation); override;\r\n procedure MouseEnter(Control: TControl); override;\r\n procedure TextChanged; override;\r\n\r\n property AutoSize: Boolean read FAutoSize write FAutoSize default True;\r\n property FocusControl: TWinControl read FFocusControl write SetFocusControl;\r\n property FocusControlMethod: TFocusControlMethod read FFocusControlMethod\r\n write FFocusControlMethod default fcmOnMouseDown;\r\n property Transparent: Boolean read FTransparent write SetTransparent default True;\r\n property ExternalCanvas: TCanvas read FExternalCanvas write FExternalCanvas;\r\n procedure Paint; override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n end;\r\n\r\n TJvgLabel = class(TJvgCustomLabel)\r\n private\r\n FDirection: TglLabelDir;\r\n FTextStyles: TJvgLabelTextStyles;\r\n FColors: TJvgLabelColors;\r\n FFontWeight: TFontWeight;\r\n // FActiveTextColor: TColor;\r\n FOptions: TglLabelOptions;\r\n FSupressPaint: Boolean;\r\n FGradient: TJvgGradient;\r\n FIllumination: TJvgIllumination;\r\n FTexture: TBitmap;\r\n FBackground: TBitmap;\r\n FTextureImage: TImage;\r\n FBackgroundImage: TImage;\r\n FAlignment: TAlignment;\r\n FUFontWeight: Word;\r\n FRunOnce: Boolean;\r\n FFirstCreate: Boolean;\r\n FNeedUpdateOnlyMainText: Boolean;\r\n FNeedRemakeTextureMask: Boolean;\r\n FImg: TBitmap;\r\n FTextureMask: TBitmap;\r\n FBackgroundBmp: TBitmap;\r\n FTextureBmp: TBitmap;\r\n FTargetCanvas: TCanvas;\r\n procedure SetDirection(Value: TglLabelDir);\r\n procedure SetFontWeight(Value: TFontWeight);\r\n procedure SetOptions(Value: TglLabelOptions);\r\n procedure SetTexture(Value: TBitmap);\r\n procedure SetBackground(Value: TBitmap);\r\n function GetTexture: TBitmap;\r\n function GetBackground: TBitmap;\r\n procedure SetTextureImage(Value: TImage);\r\n procedure SetBackgroundImage(Value: TImage);\r\n procedure SetAlignment(Value: TAlignment);\r\n procedure OnGradientChanged(Sender: TObject);\r\n procedure OnIlluminationChanged(Sender: TObject);\r\n procedure CreateLabelFont;\r\n procedure InvalidateLabel(UpdateBackgr: Boolean);\r\n protected\r\n procedure MouseEnter(Control: TControl); override;\r\n procedure MouseLeave(Control: TControl); override;\r\n procedure FontChanged; override;\r\n procedure Notification(AComponent: TComponent; Operation: TOperation); override;\r\n procedure Loaded; override;\r\n public\r\n FreeFont: TFont;\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n procedure Paint; override;\r\n property SupressPaint: Boolean read FSupressPaint write FSupressPaint;\r\n property Canvas;\r\n property ExternalCanvas;\r\n published\r\n property Anchors;\r\n property Align;\r\n property Caption;\r\n property DragCursor;\r\n property DragMode;\r\n property Enabled;\r\n property Font;\r\n property ParentColor;\r\n property ParentFont;\r\n property ParentShowHint;\r\n property PopupMenu;\r\n // property ShowAccelChar;\r\n property ShowHint;\r\n property Visible;\r\n property OnClick;\r\n property OnDblClick;\r\n property OnDragDrop;\r\n property OnDragOver;\r\n property OnEndDrag;\r\n property OnMouseDown;\r\n property OnMouseMove;\r\n property OnMouseUp;\r\n property OnStartDrag;\r\n property OnMouseEnter;\r\n property OnMouseLeave;\r\n property FocusControl;\r\n property FocusControlMethod;\r\n property AutoSize;\r\n property Transparent;\r\n property Direction: TglLabelDir read FDirection write SetDirection default fldLeftRight;\r\n property TextStyles: TJvgLabelTextStyles read FTextStyles write FTextStyles;\r\n property Colors: TJvgLabelColors read FColors write FColors;\r\n property FontWeight: TFontWeight read FFontWeight write SetFontWeight;\r\n property Options: TglLabelOptions read FOptions write SetOptions;\r\n property Gradient: TJvgGradient read FGradient write FGradient;\r\n property Illumination: TJvgIllumination read FIllumination write FIllumination;\r\n property Texture: TBitmap read GetTexture write SetTexture;\r\n property Background: TBitmap read GetBackground write SetBackground;\r\n property TextureImage: TImage read FTextureImage write SetTextureImage;\r\n property BackgroundImage: TImage read FBackgroundImage write SetBackgroundImage;\r\n property Alignment: TAlignment read FAlignment write SetAlignment;\r\n end;\r\n\r\n TJvgStaticTextLabel = class(TJvgCustomLabel)\r\n private\r\n FActiveColor: TColor;\r\n FAlignment: TglAlignment;\r\n FOptions: TglStaticTextOptions;\r\n FWordWrap: Boolean;\r\n procedure DrawTextBroadwise(Canvas: TCanvas);\r\n procedure AdjustBounds;\r\n procedure SetAlignment(Value: TglAlignment);\r\n procedure SetOptions(Value: TglStaticTextOptions);\r\n procedure SetWordWrap(Value: Boolean);\r\n function GetAutoSize: Boolean;\r\n protected\r\n procedure SetAutoSize(Value: Boolean); override;\r\n procedure MouseEnter(Control: TControl); override;\r\n procedure MouseLeave(Control: TControl); override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n procedure Paint; override;\r\n property Canvas;\r\n property ExternalCanvas;\r\n published\r\n property Anchors;\r\n property Align;\r\n property Caption;\r\n property Color;\r\n property DragCursor;\r\n property DragMode;\r\n property Enabled;\r\n property Font;\r\n property ParentColor;\r\n property ParentFont;\r\n property ParentShowHint;\r\n property PopupMenu;\r\n property ShowHint;\r\n property Visible;\r\n property OnClick;\r\n property OnDblClick;\r\n property OnDragDrop;\r\n property OnDragOver;\r\n property OnEndDrag;\r\n property OnMouseDown;\r\n property OnMouseMove;\r\n property OnMouseUp;\r\n property OnStartDrag;\r\n property OnMouseEnter;\r\n property OnMouseLeave;\r\n property FocusControl;\r\n property FocusControlMethod;\r\n property Transparent;\r\n property ActiveColor: TColor read FActiveColor write FActiveColor default clWhite;\r\n property Alignment: TglAlignment read FAlignment write SetAlignment default ftaBroadwise;\r\n property AutoSize: Boolean read GetAutoSize write SetAutoSize;\r\n property Options: TglStaticTextOptions read FOptions write SetOptions;\r\n property WordWrap: Boolean read FWordWrap write SetWordWrap default True;\r\n end;\r\n\r\n TJvgGlyphLabel = class(TJvgLabel)\r\n private\r\n FGlyphOn: TBitmap;\r\n FGlyphOff: TBitmap;\r\n FGlyphDisabled: TBitmap;\r\n FGlyphKind: TglGlyphKind;\r\n function IsCustomGlyph: Boolean;\r\n procedure SetGlyphOn(Value: TBitmap);\r\n function GetGlyphOn: TBitmap;\r\n procedure SetGlyphOff(Value: TBitmap);\r\n function GetGlyphOff: TBitmap;\r\n procedure SetGlyphDisabled(Value: TBitmap);\r\n function GetGlyphDisabled: TBitmap;\r\n procedure SetGlyphKind(Value: TglGlyphKind);\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n published\r\n property GlyphKind: TglGlyphKind read FGlyphKind write SetGlyphKind default fgkDefault;\r\n property GlyphOn: TBitmap read GetGlyphOn write SetGlyphOn stored True;\r\n property GlyphOff: TBitmap read GetGlyphOff write SetGlyphOff stored True;\r\n property GlyphDisabled: TBitmap read GetGlyphDisabled write\r\n SetGlyphDisabled stored IsCustomGlyph;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvgLabel.pas $';\r\n Revision: '$Revision: 13173 $';\r\n Date: '$Date: 2011-11-19 13:43:58 +0100 (sam. 19 nov. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n {$IFNDEF COMPILER12_UP}\r\n JvJCLUtils, // SetWindowLongPtr\r\n {$ENDIF ~COMPILER12_UP}\r\n Math;\r\n\r\n//=== { TJvgCustomLabel } ====================================================\r\n\r\nconstructor TJvgCustomLabel.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n ControlStyle := ControlStyle + [csOpaque, csReplicatable];\r\n ActiveWhileControlFocused := True;\r\n FAutoSize := True;\r\n FTransparent := True;\r\n FFocusControlMethod := fcmOnMouseDown;\r\nend;\r\n\r\ndestructor TJvgCustomLabel.Destroy;\r\nbegin\r\n SetFocusControl(nil);\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvgCustomLabel.Paint;\r\nbegin\r\n //...if FocusControl have changed his parent in Run-Time...\r\n if FNeedRehookFocusControl then\r\n HookFocusControlWndProc;\r\n //don't inherited;\r\nend;\r\n\r\nprocedure TJvgCustomLabel.Notification(AComponent: TComponent; Operation: TOperation);\r\nbegin\r\n inherited Notification(AComponent, Operation);\r\n if (AComponent = FocusControl) and (Operation = opRemove) then\r\n begin\r\n {UnhookFocusControlWndProc;}\r\n FFocusControl := nil;\r\n end;\r\nend;\r\n\r\nprocedure TJvgCustomLabel.MouseEnter(Control: TControl);\r\nbegin\r\n if csDesigning in ComponentState then\r\n Exit;\r\n inherited MouseEnter(Control);\r\n if Assigned(FocusControl) and (FocusControlMethod = fcmOnMouseEnter) then\r\n FocusControl.SetFocus;\r\nend;\r\n\r\nprocedure TJvgCustomLabel.WMLMouseUp(var Msg: TMessage);\r\nbegin\r\n inherited;\r\n if Enabled and (FocusControlMethod = fcmOnMouseUp) and\r\n Assigned(FocusControl) and FocusControl.CanFocus then\r\n FocusControl.SetFocus;\r\nend;\r\n\r\nprocedure TJvgCustomLabel.WMLMouseDown(var Msg: TMessage);\r\nbegin\r\n inherited;\r\n if Enabled and (FocusControlMethod = fcmOnMouseDown) and\r\n Assigned(FocusControl) and FocusControl.CanFocus then\r\n FocusControl.SetFocus;\r\nend;\r\n\r\nprocedure TJvgCustomLabel.TextChanged;\r\nbegin\r\n inherited TextChanged;\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvgCustomLabel.HookFocusControlWndProc;\r\nvar\r\n P: Pointer;\r\nbegin\r\n P := Pointer(GetWindowLongPtr(FocusControl.Handle, GWL_WNDPROC));\r\n if P <> FNewWndProc then\r\n begin\r\n FPrevWndProc := P;\r\n FNewWndProc := JvMakeObjectInstance(FocusControlWndHookProc);\r\n SetWindowLongPtr(FocusControl.Handle, GWL_WNDPROC, LONG_PTR(FNewWndProc));\r\n end;\r\nend;\r\n\r\nprocedure TJvgCustomLabel.UnhookFocusControlWndProc;\r\nbegin\r\n // if not(csDesigning in ComponentState) then Exit;\r\n if (FNewWndProc <> nil) and (FPrevWndProc <> nil) and\r\n (Pointer(GetWindowLongPtr(FocusControl.Handle, GWL_WNDPROC)) = FNewWndProc) then\r\n begin\r\n SetWindowLongPtr(FocusControl.Handle, GWL_WNDPROC, LONG_PTR(FPrevWndProc));\r\n // (rom) JvFreeObjectInstance call added\r\n JvFreeObjectInstance(FNewWndProc);\r\n FNewWndProc := nil;\r\n end;\r\nend;\r\n\r\nprocedure TJvgCustomLabel.FocusControlWndHookProc(var Msg: TMessage);\r\nbegin\r\n case Msg.Msg of\r\n WM_SETFOCUS:\r\n begin\r\n MouseEnter(Self);\r\n FShowAsActiveWhileControlFocused := True;\r\n end;\r\n WM_KILLFOCUS:\r\n begin\r\n FShowAsActiveWhileControlFocused := False;\r\n MouseLeave(Self);\r\n end;\r\n WM_DESTROY:\r\n FNeedRehookFocusControl := True;\r\n end;\r\n Msg.Result := CallWindowProc(FPrevWndProc, TForm(Owner).Handle,\r\n Msg.Msg, Msg.WParam, Msg.LParam);\r\nend;\r\n\r\nprocedure TJvgCustomLabel.SetFocusControl(Value: TWinControl);\r\nbegin\r\n if FFocusControl = Value then\r\n Exit;\r\n if ActiveWhileControlFocused and Assigned(FFocusControl) then\r\n UnhookFocusControlWndProc;\r\n ReplaceComponentReference(Self, Value, TComponent(FFocusControl));\r\n if ActiveWhileControlFocused and Assigned(FFocusControl) then\r\n HookFocusControlWndProc;\r\nend;\r\n\r\nprocedure TJvgCustomLabel.SetTransparent(Value: Boolean);\r\nbegin\r\n FTransparent := Value;\r\n Invalidate;\r\nend;\r\n\r\n//=== { TJvgLabel } ==========================================================\r\n\r\nconstructor TJvgLabel.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n TextStyles := TJvgLabelTextStyles.Create;\r\n Colors := TJvgLabelColors.Create;\r\n Gradient := TJvgGradient.Create;\r\n FIllumination := TJvgIllumination.Create;\r\n FImg := TBitmap.Create;\r\n\r\n FFirstCreate := True;\r\n FreeFont := TFont.Create;\r\n if csDesigning in ComponentState then\r\n Self.Font.Name := 'Arial';\r\n AutoSize := True;\r\n // FRunOnce:=False;\r\n // FActiveNow := False;\r\n\r\n FDirection := fldLeftRight;\r\n FFontWeight := fwDONTCARE;\r\n // FSupressPaint := False;\r\n FUFontWeight := Word(fwDONTCARE);\r\n // FNeedUpdateOnlyMainText:=False;\r\n FGradient.OnChanged := OnGradientChanged;\r\n FIllumination.OnChanged := OnIlluminationChanged;\r\n TextStyles.OnChanged := OnIlluminationChanged;\r\n Colors.OnChanged := OnIlluminationChanged;\r\n FOptions := [floActiveWhileControlFocused];\r\n FTargetCanvas := Canvas;\r\n FTransparent := True;\r\n Width := 100;\r\n Height := 16;\r\nend;\r\n\r\ndestructor TJvgLabel.Destroy;\r\nbegin\r\n TextStyles.Free;\r\n Colors.Free;\r\n Gradient.Free;\r\n FIllumination.Free;\r\n FTexture.Free;\r\n FBackground.Free;\r\n FTextureMask.Free;\r\n FImg.Free;\r\n inherited Destroy;\r\n DeleteObject(FreeFont.Handle);\r\n FreeFont.Free;\r\nend;\r\n\r\nprocedure TJvgLabel.Notification(AComponent: TComponent; Operation: TOperation);\r\nbegin\r\n inherited Notification(AComponent, Operation);\r\n if (AComponent = BackgroundImage) and (Operation = opRemove) then\r\n BackgroundImage := nil\r\n else\r\n if (AComponent = TextureImage) and (Operation = opRemove) then\r\n TextureImage := nil;\r\nend;\r\n\r\nprocedure TJvgLabel.FontChanged;\r\nbegin\r\n inherited FontChanged;\r\n CreateLabelFont;\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvgLabel.MouseEnter(Control: TControl);\r\nbegin\r\n if csDesigning in ComponentState then\r\n Exit;\r\n\r\n if not Enabled or (floIgnoreMouse in Options) or\r\n FShowAsActiveWhileControlFocused then\r\n Exit;\r\n //inherited;\r\n FActiveNow := True;\r\n with TextStyles, Colors do\r\n if (Passive <> Active) or\r\n ((Background <> BackgroundActive) and not Transparent) then\r\n begin\r\n if floBufferedDraw in Options then\r\n Repaint\r\n else\r\n InvalidateLabel(True);\r\n end\r\n else\r\n if (floDelineatedText in Options) and (DelineateActive <> Delineate) then\r\n Repaint\r\n else\r\n if TextActive <> Text then\r\n begin\r\n FNeedUpdateOnlyMainText := True;\r\n Repaint;\r\n end;\r\n inherited MouseEnter(Control);\r\nend;\r\n\r\nprocedure TJvgLabel.MouseLeave(Control: TControl);\r\nbegin\r\n if csDesigning in ComponentState then\r\n Exit;\r\n if not Enabled or (floIgnoreMouse in Options) or\r\n FShowAsActiveWhileControlFocused then\r\n Exit;\r\n //inherited;\r\n FActiveNow := False;\r\n with TextStyles, Colors do\r\n if (Passive <> Active) or\r\n ((Background <> BackgroundActive) and not Transparent) then\r\n begin\r\n if floBufferedDraw in Options then\r\n Repaint\r\n else\r\n InvalidateLabel(True);\r\n end\r\n else\r\n if (floDelineatedText in Options) and (DelineateActive <> Delineate) then\r\n Repaint\r\n else\r\n if TextActive <> Text then\r\n begin\r\n FNeedUpdateOnlyMainText := True;\r\n Repaint;\r\n end;\r\n inherited MouseLeave(Control);\r\nend;\r\n\r\nprocedure TJvgLabel.Loaded;\r\nbegin\r\n inherited Loaded;\r\n if FTexture <> nil then\r\n FTextureBmp := FTexture\r\n else\r\n if Assigned(FTextureImage) then\r\n FTextureBmp := FTextureImage.Picture.Bitmap\r\n else\r\n FTextureBmp := nil;\r\n if Assigned(FBackground) then\r\n FBackgroundBmp := FBackground\r\n else\r\n if Assigned(FBackgroundImage) then\r\n FBackgroundBmp := FBackgroundImage.Picture.Bitmap\r\n else\r\n FBackgroundBmp := nil;\r\nend;\r\n\r\nprocedure TJvgLabel.Paint;\r\nvar\r\n R: TRect;\r\n X, Y, X1, Y1, TX, TY: Integer;\r\n Size, TextSize: TSize;\r\n FontColor: TColor;\r\n CurrTextStyle: TglTextStyle;\r\n CurrDelinColor: TColor;\r\n OldGradientFActive, LUseBackgroundBmp, LUseTextureBmp, LBufferedDraw: Boolean;\r\nbegin\r\n inherited Paint;\r\n if FSupressPaint or (Length(Caption) = 0) then\r\n Exit;\r\n if floTransparentFont in Options then\r\n LBufferedDraw := True\r\n else\r\n LBufferedDraw := (floBufferedDraw in Options) and\r\n not (csDesigning in ComponentState);\r\n if LBufferedDraw then\r\n FTargetCanvas := FImg.Canvas\r\n else\r\n if Assigned(ExternalCanvas) then\r\n FTargetCanvas := ExternalCanvas\r\n else\r\n FTargetCanvas := Canvas;\r\n FNeedUpdateOnlyMainText := FNeedUpdateOnlyMainText and not LBufferedDraw and\r\n (not IsItAFilledBitmap(FBackgroundBmp));\r\n if not FRunOnce then\r\n begin\r\n FNeedUpdateOnlyMainText := False;\r\n FRunOnce := True;\r\n end;\r\n FTargetCanvas.Font := FreeFont;\r\n //...CALC POSITION\r\n GetTextExtentPoint32(FTargetCanvas.Handle, PChar(Caption), Length(Caption), Size);\r\n with TextStyles, Colors do\r\n if FActiveNow then\r\n begin\r\n CurrTextStyle := Active;\r\n CurrDelinColor := DelineateActive;\r\n FontColor := TextActive;\r\n end\r\n else\r\n if Enabled then\r\n begin\r\n CurrTextStyle := Passive;\r\n CurrDelinColor := Delineate;\r\n FontColor := Text;\r\n end\r\n else\r\n begin\r\n CurrTextStyle := Disabled;\r\n CurrDelinColor := Delineate;\r\n FontColor := TextDisabled;\r\n end;\r\n X := 0;\r\n Y := 0;\r\n Size.cx := Size.cx + 2 + Trunc(Size.cx * 0.01);\r\n // Size.cy:=Size.cy+Trunc(Size.cy*0.1);\r\n Size.cy := Size.cy + 2;\r\n TextSize := Size;\r\n if (CurrTextStyle = fstShadow) or (CurrTextStyle = fstVolumetric) then\r\n begin\r\n Inc(Size.cy, Illumination.ShadowDepth);\r\n Inc(Size.cx, Illumination.ShadowDepth);\r\n end;\r\n if floDelineatedText in Options then\r\n begin\r\n Inc(Size.cy, 2);\r\n Inc(Size.cx, 2);\r\n end;\r\n\r\n if (Align = alNone) and AutoSize then\r\n case FDirection of\r\n fldLeftRight, fldRightLeft:\r\n begin\r\n Width := Size.cx;\r\n Height := Size.cy;\r\n end;\r\n else {fldDownUp,fldUpDown:}\r\n begin\r\n Width := Size.cy;\r\n Height := Size.cx;\r\n end;\r\n end;\r\n\r\n // pt := CalcAlignedTextPosition( FTargetCanvas.Handle, Caption, Size );\r\n // X := pt.X; Y := pt.Y;\r\n //CalcAlignedTextPosition( FTargetCanvas.Handle, Caption, Size );\r\n\r\n case FDirection of\r\n fldLeftRight:\r\n begin //if Align = alNone then begin Width:=Max(w,Size.cx);Height:=Max(h,Size.cy); end;\r\n case Alignment of\r\n taCenter:\r\n X := (Width - Size.cx) div 2;\r\n taRightJustify:\r\n X := Width - Size.cx;\r\n end;\r\n end;\r\n fldRightLeft:\r\n begin //if Align = alNone then begin Width:=Max(w,Size.cx);Height:=Max(h,Size.cy);X:=Width;Y:=Height; end;\r\n case Alignment of\r\n taCenter:\r\n X := (Width + Size.cx) div 2;\r\n taLeftJustify:\r\n X := Width - (Size.cx - TextSize.cx) - 2;\r\n else\r\n X := TextSize.cx;\r\n end;\r\n Y := TextSize.cy;\r\n end;\r\n fldDownUp:\r\n begin //if Align = alNone then begin Height:=Max(h,Size.cx);Width:=Max(w,Size.cy);Y:=Height-2; end;\r\n case Alignment of\r\n taCenter:\r\n Y := (Height + TextSize.cx - (Size.cy - TextSize.cy)) div 2;\r\n taRightJustify:\r\n Y := TextSize.cx - 4;\r\n else\r\n Y := Height - (Size.cy - TextSize.cy) - 2;\r\n end;\r\n end;\r\n fldUpDown:\r\n begin //if Align = alNone then begin Height:=Max(h,Size.cx);Width:=Max(w,Size.cy);X:=Width; end;\r\n case Alignment of\r\n taCenter:\r\n Y := (Height - Size.cx) div 2;\r\n taRightJustify:\r\n Y := Height - Size.cx;\r\n else\r\n Y := 1;\r\n end;\r\n X := TextSize.cy;\r\n end;\r\n end;\r\n\r\n //...CALC POSITION end\r\n\r\n R := GetClientRect;\r\n if FTargetCanvas = FImg.Canvas then\r\n begin\r\n FImg.Width := Width;\r\n FImg.Height := Height;\r\n end;\r\n\r\n SetBkMode(FTargetCanvas.Handle, Windows.TRANSPARENT);\r\n if not Transparent then\r\n begin\r\n FTargetCanvas.Brush.Style := bsSolid;\r\n if FActiveNow then\r\n FTargetCanvas.Brush.Color := Colors.BackgroundActive\r\n else\r\n FTargetCanvas.Brush.Color := Colors.Background;\r\n FTargetCanvas.FillRect(R);\r\n end;\r\n\r\n try\r\n LUseBackgroundBmp := IsItAFilledBitmap(FBackgroundBmp);\r\n except\r\n // raise;\r\n LUseBackgroundBmp := False;\r\n FBackgroundBmp := nil;\r\n FBackgroundImage := nil;\r\n end;\r\n\r\n try\r\n LUseTextureBmp := IsItAFilledBitmap(FTextureBmp);\r\n except\r\n LUseTextureBmp := False;\r\n FTextureBmp := nil;\r\n FTextureImage := nil;\r\n end;\r\n\r\n // ShadowColor_ := Colors.Shadow;\r\n // HighlightColor_ := Colors.Highlight;\r\n if LUseBackgroundBmp then\r\n begin //...FillBackground\r\n TX := 0;\r\n TY := 0;\r\n while TX < Width do\r\n begin\r\n while TY < Height do\r\n begin\r\n BitBlt(FTargetCanvas.Handle, TX, TY,\r\n FBackgroundBmp.Width, FBackgroundBmp.Height,\r\n FBackgroundBmp.Canvas.Handle, 0, 0, SRCCOPY);\r\n Inc(TY, FBackgroundBmp.Height);\r\n end;\r\n Inc(TX, FBackgroundBmp.Width);\r\n TY := 0;\r\n end;\r\n end\r\n else\r\n if LBufferedDraw then\r\n with FTargetCanvas do\r\n begin\r\n if Transparent or (floTransparentFont in Options) then\r\n try\r\n Brush.Color := Parent.Brush.Color;\r\n Brush.Style := bsSolid;\r\n FillRect(R);\r\n Brush.Style := bsClear;\r\n GetParentImageRect(Self, Bounds(Left, Top, Width, Height),\r\n FTargetCanvas.Handle);\r\n except\r\n end;\r\n end;\r\n\r\n OldGradientFActive := Gradient.Active;\r\n //...Supress Gradient if needed\r\n with Colors do\r\n if (FActiveNow and (TextActive <> Text)) or not Enabled then\r\n Gradient.Active := False;\r\n if floDelineatedText in Options then\r\n begin\r\n X1 := 4;\r\n Y1 := 4;\r\n end\r\n else\r\n begin\r\n X1 := 2;\r\n Y1 := 2;\r\n end;\r\n\r\n if CurrTextStyle = fstNone then\r\n begin\r\n X1 := X1 div 2 - 1;\r\n Y1 := Y1 div 2 - 1;\r\n end;\r\n if CurrTextStyle = fstShadow then\r\n begin\r\n X1 := X1 div 2 - 1;\r\n Y1 := Y1 div 2 - 1;\r\n end;\r\n if {FNeedRemakeTextureMask and} LUseTextureBmp or\r\n (floTransparentFont in Options) then\r\n begin\r\n if not Assigned(FTextureMask) then\r\n FTextureMask := TBitmap.Create;\r\n with FTextureMask do\r\n begin\r\n Width := Self.Width;\r\n Height := Self.Height;\r\n Canvas.Brush.Color := clBlack;\r\n Canvas.Brush.Style := bsSolid;\r\n Canvas.FillRect(GetClientRect);\r\n Canvas.Font := FreeFont;\r\n Canvas.Font.Color := clWhite;\r\n if (CurrTextStyle = fstNone) or (CurrTextStyle = fstShadow) then\r\n Canvas.TextOut(X + X1, Y + Y1, Caption)\r\n else\r\n Canvas.TextOut(X + X1 div 2, Y + Y1 div 2, Caption);\r\n TX := 0;\r\n TY := 0;\r\n\r\n if not Self.Transparent then\r\n begin\r\n BitBlt(Canvas.Handle, TX, TY, Width, Height, FTargetCanvas.Handle, 0,\r\n 0, SRCAND);\r\n if FActiveNow then\r\n JvgUtils.ChangeBitmapColor(FTextureMask, clBlack, Colors.BackgroundActive)\r\n else\r\n JvgUtils.ChangeBitmapColor(FTextureMask, clBlack, Colors.Background);\r\n BitBlt(Self.Canvas.Handle, 0, 0, Width, Height, Canvas.Handle, 0, 0,\r\n SRCCOPY);\r\n Exit;\r\n end;\r\n\r\n if floTransparentFont in Options then\r\n BitBlt(Canvas.Handle, TX, TY, Width, Height, FTargetCanvas.Handle, 0,\r\n 0, SRCAND)\r\n else\r\n if LUseTextureBmp then //...fill mask with texture\r\n while TX < Width do\r\n begin\r\n while TY < Height do\r\n begin\r\n BitBlt(Canvas.Handle, TX, TY, FTextureBmp.Width,\r\n FTextureBmp.Height, FTextureBmp.Canvas.Handle, 0, 0, SRCAND);\r\n Inc(TY, FTextureBmp.Height);\r\n end;\r\n Inc(TX, FTextureBmp.Width);\r\n TY := 0;\r\n end;\r\n end;\r\n end;\r\n\r\n if IsItAFilledBitmap(FTextureBmp) then\r\n FontColor := 0;\r\n ExtTextOutExt(FTargetCanvas.Handle, X, Y, GetClientRect, Caption,\r\n CurrTextStyle, floDelineatedText in Options,\r\n FNeedUpdateOnlyMainText, FontColor, CurrDelinColor,\r\n Colors.Highlight, Colors.Shadow,\r\n Illumination, Gradient, FreeFont);\r\n\r\n // SetBkMode( FTargetCanvas.Handle, iOldBkMode );\r\n FNeedUpdateOnlyMainText := False;\r\n Gradient.Active := OldGradientFActive;\r\n\r\n if (Assigned(FTextureBmp) or (floTransparentFont in Options)) and\r\n (CurrTextStyle <> fstPushed) then\r\n if Assigned(FTextureMask) then {fix access violation! WPostma.}\r\n BitBlt(FTargetCanvas.Handle, 0, 0, FTextureMask.Width, FTextureMask.Height,\r\n FTextureMask.Canvas.Handle, 0, 0, SRCPAINT);\r\n\r\n if FImg.Canvas = FTargetCanvas then\r\n BitBlt(Canvas.Handle, 0, 0, FImg.Width, FImg.Height,\r\n FTargetCanvas.Handle, 0, 0, SRCCOPY);\r\n\r\n //R:=Rect(Left,Top,Left+Width,Top+Height);\r\n //ValidateRect( Parent.Handle, @R );\r\nend;\r\n\r\nprocedure TJvgLabel.CreateLabelFont;\r\nbegin\r\n if not FFirstCreate then\r\n DeleteObject(FreeFont.Handle);\r\n FreeFont.Handle := CreateRotatedFont(Font, RadianEscapments[FDirection]);\r\n FFirstCreate := False;\r\nend;\r\n\r\nprocedure TJvgLabel.InvalidateLabel(UpdateBackgr: Boolean);\r\nvar\r\n R: TRect;\r\nbegin\r\n R := Bounds(Left, Top, Width, Height);\r\n if not (csDestroying in ComponentState) then\r\n InvalidateRect(Parent.Handle, @R, UpdateBackgr);\r\nend;\r\n\r\nprocedure TJvgLabel.OnGradientChanged(Sender: TObject);\r\nbegin\r\n FNeedUpdateOnlyMainText := True;\r\n Repaint;\r\n //InvalidateLabel(False);\r\nend;\r\n\r\nprocedure TJvgLabel.OnIlluminationChanged(Sender: TObject);\r\nbegin\r\n CalcShadowAndHighlightColors((Parent as TWinControl).Brush.Color, Colors);\r\n InvalidateLabel(True);\r\nend;\r\n\r\nprocedure TJvgLabel.SetDirection(Value: TglLabelDir);\r\nbegin\r\n FDirection := Value;\r\n CreateLabelFont;\r\n FNeedRemakeTextureMask := True;\r\n InvalidateLabel(True);\r\nend;\r\n\r\nprocedure TJvgLabel.SetFontWeight(Value: TFontWeight);\r\nbegin\r\n if FFontWeight = Value then\r\n Exit;\r\n FFontWeight := Value;\r\n FUFontWeight := Word(Value) * 100;\r\n CreateLabelFont;\r\n FNeedRemakeTextureMask := True;\r\n InvalidateLabel(True);\r\nend;\r\n\r\nprocedure TJvgLabel.SetOptions(Value: TglLabelOptions);\r\nbegin\r\n if FOptions = Value then\r\n Exit;\r\n FOptions := Value;\r\n ActiveWhileControlFocused := floActiveWhileControlFocused in Options;\r\n if floTransparentFont in Options then\r\n Options := Options + [floBufferedDraw];\r\n CalcShadowAndHighlightColors((Parent as TWinControl).Brush.Color, Colors);\r\n FNeedRemakeTextureMask := True;\r\n InvalidateLabel(True);\r\nend;\r\n\r\nprocedure TJvgLabel.SetTexture(Value: TBitmap);\r\nbegin\r\n if Assigned(FTexture) then\r\n FTexture.Free;\r\n FTexture := nil;\r\n if (Value <> nil) and (Value.Handle <> 0) then\r\n begin\r\n FTexture := TBitmap.Create;\r\n FTexture.Assign(Value);\r\n FTextureBmp := FTexture;\r\n end\r\n else\r\n if Assigned(FTextureImage) then\r\n FTextureBmp := FTextureImage.Picture.Bitmap\r\n else\r\n FTextureBmp := nil;\r\n FNeedRemakeTextureMask := True;\r\n InvalidateLabel(True);\r\nend;\r\n\r\nprocedure TJvgLabel.SetBackground(Value: TBitmap);\r\nbegin\r\n if Assigned(FBackground) then\r\n FBackground.Free;\r\n FBackground := nil;\r\n if (Value <> nil) and (Value.Handle <> 0) then\r\n begin\r\n FBackground := TBitmap.Create;\r\n FBackground.Assign(Value);\r\n FBackgroundBmp := FBackground;\r\n end\r\n else\r\n if FBackgroundImage <> nil then\r\n FBackgroundBmp := FBackgroundImage.Picture.Bitmap\r\n else\r\n FBackgroundBmp := nil;\r\n InvalidateLabel(True);\r\nend;\r\n\r\nfunction TJvgLabel.GetTexture: TBitmap;\r\nbegin\r\n if not Assigned(FTexture) then\r\n FTexture := TBitmap.Create;\r\n Result := FTexture;\r\nend;\r\n\r\nfunction TJvgLabel.GetBackground: TBitmap;\r\nbegin\r\n if not Assigned(FBackground) then\r\n FBackground := TBitmap.Create;\r\n Result := FBackground;\r\nend;\r\n\r\nprocedure TJvgLabel.SetTextureImage(Value: TImage);\r\nbegin\r\n FTextureImage := Value;\r\n //mb if (not IsItAFilledBitmap(FTexture)) and Assigned(Value) then\r\n if Value <> nil then\r\n begin\r\n FTextureBmp := FTextureImage.Picture.Bitmap;\r\n end\r\n else\r\n if FTexture <> nil then\r\n FTextureBmp := FTexture\r\n else\r\n FTextureBmp := nil;\r\n InvalidateLabel(True);\r\nend;\r\n\r\nprocedure TJvgLabel.SetBackgroundImage(Value: TImage);\r\nbegin\r\n FBackgroundImage := Value;\r\n //mb if (not IsItAFilledBitmap(FBackground)) and Assigned(Value) then\r\n if Value <> nil then\r\n begin\r\n FBackgroundBmp := FBackgroundImage.Picture.Bitmap;\r\n InvalidateLabel(True);\r\n end\r\n else\r\n if FBackground <> nil then\r\n FBackgroundBmp := FBackground\r\n else\r\n FBackgroundBmp := nil;\r\n InvalidateLabel(True);\r\nend;\r\n\r\nprocedure TJvgLabel.SetAlignment(Value: TAlignment);\r\nbegin\r\n FAlignment := Value;\r\n Invalidate;\r\nend;\r\n\r\n//=== { TJvgStaticTextLabel } ================================================\r\n\r\nconstructor TJvgStaticTextLabel.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FActiveColor := clWhite;\r\n FAlignment := ftaBroadwise;\r\n FOptions := [ftoActiveWhileControlFocused];\r\n FWordWrap := True;\r\n Width := 100;\r\n Height := 16;\r\nend;\r\n\r\nprocedure TJvgStaticTextLabel.MouseEnter(Control: TControl);\r\nbegin\r\n if (ftoIgnoreMouse in Options) or FShowAsActiveWhileControlFocused then\r\n Exit;\r\n FActiveNow := True;\r\n Repaint;\r\n inherited MouseEnter(Control);\r\nend;\r\n\r\nprocedure TJvgStaticTextLabel.MouseLeave(Control: TControl);\r\nbegin\r\n if (ftoIgnoreMouse in Options) or FShowAsActiveWhileControlFocused then\r\n Exit;\r\n FActiveNow := False;\r\n if ftoUnderlinedActive in Options then\r\n Invalidate\r\n else\r\n Repaint;\r\n inherited MouseLeave(Control);\r\nend;\r\n\r\nprocedure TJvgStaticTextLabel.Paint;\r\nconst\r\n Alignments: array [TglAlignment] of Word =\r\n (DT_LEFT, DT_RIGHT, DT_CENTER, 0);\r\n WordWraps: array [Boolean] of Word = (0, DT_WORDBREAK);\r\nvar\r\n LAlignment: TglAlignment;\r\n FTargetCanvas: TCanvas;\r\n Rect: TRect;\r\nbegin\r\n //inherited;\r\n if Caption = '' then\r\n Exit;\r\n\r\n if Assigned(ExternalCanvas) then\r\n FTargetCanvas := ExternalCanvas\r\n else\r\n FTargetCanvas := Canvas;\r\n FTargetCanvas.Font.Assign(Font);\r\n LAlignment := FAlignment;\r\n SetBkMode(FTargetCanvas.Handle, Integer(FTransparent));\r\n\r\n { if FActiveNow and(ftoUnderlinedActive in Options) then\r\n FTargetCanvas.Font.Style := Font.Style + [fsUnderline]\r\n else\r\n FTargetCanvas.Font.Style := Font.Style - [fsUnderline];\r\n }\r\n if FActiveNow then\r\n SetTextColor(FTargetCanvas.Handle, ColorToRGB(ActiveColor))\r\n else\r\n SetTextColor(FTargetCanvas.Handle, ColorToRGB(Font.Color));\r\n\r\n // TextOut( FTargetCanvas.Handle, 0, 0, 'lpszString', 10);\r\n // BitBlt( FTargetCanvas.Handle, 0, 0, Width, Height, Image.FTargetCanvas.Handle, Width, Height, SRCCOPY );\r\n if Alignment = ftaBroadwise then\r\n begin\r\n if FWordWrap then\r\n begin\r\n DrawTextBroadwise(FTargetCanvas);\r\n Exit;\r\n end\r\n else\r\n LAlignment := ftaLeftJustify;\r\n end;\r\n Rect := ClientRect;\r\n Windows.DrawText(FTargetCanvas.Handle, PChar(Caption), Length(Caption), Rect,\r\n DT_EXPANDTABS or WordWraps[FWordWrap] or Alignments[LAlignment]);\r\nend;\r\n\r\nprocedure TJvgStaticTextLabel.DrawTextBroadwise(Canvas: TCanvas);\r\nvar\r\n DrawPos, Pos1, Pos2, LineWidth, LineNo, LexemCount, TextHeight: Integer;\r\n Lexem: string;\r\n Size: TSize;\r\n LStop, LBroadwiseLine: Boolean;\r\n\r\n function GetNextLexem(var Pos1, Pos2: Integer; ATrimLeft: Boolean): string;\r\n var\r\n Pos: Integer;\r\n begin\r\n Pos := Pos1;\r\n if Caption[Pos] = ' ' then\r\n repeat\r\n Inc(Pos);\r\n until (Pos > Length(Caption)) or (Caption[Pos] <> ' ');\r\n Pos2 := Pos;\r\n if ATrimLeft and (LineNo > 0) then\r\n Pos1 := Pos;\r\n repeat\r\n Inc(Pos2);\r\n until (Pos2 > Length(Caption)) or (Caption[Pos2] = ' ');\r\n\r\n Result := Copy(Caption, Pos1, Pos2 - Pos1);\r\n end;\r\n\r\n procedure DrawLine(AdditSpace: Cardinal);\r\n var\r\n I, DrawPos1, DrawPos2: Integer;\r\n Lexem: string;\r\n Size: TSize;\r\n X, X1: Single;\r\n begin\r\n DrawPos1 := DrawPos;\r\n DrawPos2 := DrawPos;\r\n X := 0;\r\n X1 := 0;\r\n LineWidth := 0;\r\n for I := 1 to LexemCount do\r\n begin\r\n Lexem := GetNextLexem(DrawPos1, DrawPos2, I = 1);\r\n // if LexemCount=1 then Lexem:=Lexem+' ';\r\n GetTextExtentPoint32(Canvas.Handle, PChar(Lexem), Length(Lexem), Size);\r\n Inc(LineWidth, Trunc(X));\r\n X := X + Size.cx;\r\n if (Trunc(X) > Width) and (LexemCount > 1) then\r\n Exit;\r\n\r\n if (LexemCount > 1) and LBroadwiseLine then\r\n X := X + AdditSpace / (LexemCount - 1);\r\n TextOut(Canvas.Handle, Trunc(X1), LineNo * TextHeight, PChar(Lexem),\r\n Length(Lexem));\r\n X1 := X;\r\n DrawPos1 := DrawPos2;\r\n end;\r\n end;\r\n\r\nbegin\r\n if Text = '' then\r\n Exit;\r\n LineWidth := 0;\r\n LineNo := 0;\r\n DrawPos := 1;\r\n Pos1 := 1;\r\n Pos2 := 1;\r\n LexemCount := 0;\r\n TextHeight := 0;\r\n LStop := False;\r\n LBroadwiseLine := True;\r\n repeat\r\n Lexem := GetNextLexem(Pos1, Pos2, LexemCount = 0);\r\n // if LexemCount=0 then Lexem:=Lexem+' ';\r\n GetTextExtentPoint32(Canvas.Handle, PChar(Lexem), Length(Lexem), Size);\r\n Inc(LineWidth, Size.cx);\r\n Inc(LexemCount);\r\n if TextHeight < Size.cy then\r\n TextHeight := Size.cy;\r\n if (LineWidth > Width) or (Pos2 >= Length(Caption)) then\r\n begin\r\n if LineWidth > Width then\r\n begin\r\n if LexemCount = 1 then\r\n Pos1 := Pos2;\r\n if LexemCount > 1 then\r\n Dec(LexemCount);\r\n DrawLine(Width - (LineWidth - Size.cx));\r\n DrawPos := Pos1;\r\n Inc(LineNo);\r\n LexemCount := 0;\r\n LineWidth := 0;\r\n LStop := Pos1 > Length(Caption);\r\n end\r\n else\r\n begin\r\n LBroadwiseLine := ftoBroadwiseLastLine in Options;\r\n DrawLine(Width - LineWidth);\r\n Inc(LineNo);\r\n LStop := True;\r\n end;\r\n end\r\n else\r\n Pos1 := Pos2;\r\n until LStop;\r\n if FAutoSize then\r\n Height := Max(12, LineNo * TextHeight);\r\nend;\r\n\r\nprocedure TJvgStaticTextLabel.AdjustBounds;\r\nconst\r\n WordWraps: array [Boolean] of Word = (0, DT_WORDBREAK);\r\nvar\r\n DC: HDC;\r\n X: Integer;\r\n Rect: TRect;\r\nbegin\r\n if not (csReading in ComponentState) and FAutoSize then\r\n begin\r\n Rect := ClientRect;\r\n DC := GetDC(HWND_DESKTOP);\r\n Canvas.Handle := DC;\r\n Windows.DrawText(Canvas.Handle, PChar(Caption), Length(Caption), Rect,\r\n DT_EXPANDTABS or DT_CALCRECT or WordWraps[FWordWrap]);\r\n Canvas.Handle := 0;\r\n ReleaseDC(HWND_DESKTOP, DC);\r\n X := Left;\r\n if FAlignment = ftaRightJustify then\r\n Inc(X, Width - Rect.Right);\r\n SetBounds(X, Top, Rect.Right, Rect.Bottom);\r\n end;\r\nend;\r\n\r\nprocedure TJvgStaticTextLabel.SetAlignment(Value: TglAlignment);\r\nbegin\r\n FAlignment := Value;\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvgStaticTextLabel.SetOptions(Value: TglStaticTextOptions);\r\nbegin\r\n FOptions := Value;\r\n ActiveWhileControlFocused := ftoActiveWhileControlFocused in Options;\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvgStaticTextLabel.SetWordWrap(Value: Boolean);\r\nbegin\r\n FWordWrap := Value;\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvgStaticTextLabel.SetAutoSize(Value: Boolean);\r\nbegin\r\n inherited AutoSize := Value;\r\n AdjustBounds;\r\nend;\r\n\r\nfunction TJvgStaticTextLabel.GetAutoSize: Boolean;\r\nbegin\r\n Result := inherited AutoSize;\r\nend;\r\n\r\n//=== { TJvgGlyphLabel } =====================================================\r\n\r\n// (rom) Glyph handling is a mess\r\n\r\nconstructor TJvgGlyphLabel.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n ControlStyle := [csCaptureMouse, csOpaque,\r\n csClickEvents, csSetCaption, csReplicatable];\r\nend;\r\n\r\ndestructor TJvgGlyphLabel.Destroy;\r\nbegin\r\n FGlyphOn.Free;\r\n FGlyphOff.Free;\r\n FGlyphDisabled.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TJvgGlyphLabel.IsCustomGlyph: Boolean;\r\nbegin\r\n Result := FGlyphKind = fgkCustom;\r\nend;\r\n\r\nprocedure TJvgGlyphLabel.SetGlyphOn(Value: TBitmap);\r\nbegin\r\n if Assigned(FGlyphOn) then\r\n FGlyphOn.Free;\r\n FGlyphOn := TBitmap.Create;\r\n FGlyphKind := fgkCustom;\r\n FGlyphOn.Assign(Value);\r\n Invalidate;\r\nend;\r\n\r\nfunction TJvgGlyphLabel.GetGlyphOn: TBitmap;\r\nbegin\r\n if not Assigned(FGlyphOn) then\r\n FGlyphOn := TBitmap.Create;\r\n Result := FGlyphOn;\r\nend;\r\n\r\nprocedure TJvgGlyphLabel.SetGlyphOff(Value: TBitmap);\r\nbegin\r\n if Assigned(FGlyphOff) then\r\n FGlyphOff.Free;\r\n FGlyphOff := TBitmap.Create;\r\n FGlyphKind := fgkCustom;\r\n FGlyphOff.Assign(Value);\r\n Invalidate;\r\nend;\r\n\r\nfunction TJvgGlyphLabel.GetGlyphOff: TBitmap;\r\nbegin\r\n if not Assigned(FGlyphOff) then\r\n FGlyphOff := TBitmap.Create;\r\n Result := FGlyphOff;\r\nend;\r\n\r\nprocedure TJvgGlyphLabel.SetGlyphDisabled(Value: TBitmap);\r\nbegin\r\n if Assigned(FGlyphDisabled) then\r\n FGlyphDisabled.Free;\r\n FGlyphDisabled := TBitmap.Create;\r\n FGlyphDisabled.Assign(Value);\r\n Invalidate;\r\nend;\r\n\r\nfunction TJvgGlyphLabel.GetGlyphDisabled: TBitmap;\r\nbegin\r\n if not Assigned(FGlyphDisabled) then\r\n FGlyphDisabled := TBitmap.Create;\r\n Result := FGlyphDisabled;\r\nend;\r\n\r\nprocedure TJvgGlyphLabel.SetGlyphKind(Value: TglGlyphKind);\r\nbegin\r\n if FGlyphKind <> Value then\r\n FGlyphKind := Value;\r\n if (FGlyphKind = fgkCustom) and (csReading in ComponentState) then\r\n begin\r\n GlyphOn := nil;\r\n GlyphOff := nil;\r\n GlyphDisabled := nil;\r\n end\r\n else\r\n begin\r\n FGlyphOn.Assign(nil); // fixes GDI resource leak\r\n FGlyphOff.Assign(nil); // fixes GDI resource leak\r\n FGlyphOn.LoadFromResourceName(HInstance, 'JvgON');\r\n FGlyphOff.LoadFromResourceName(HInstance, 'JvgOFF');\r\n FGlyphDisabled := TBitmap.Create;\r\n FGlyphDisabled.LoadFromResourceName(HInstance, 'JvgDISABLED');\r\n end;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvgListBox.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvgListBox.PAS, released on 2003-01-15.\r\n\r\nThe Initial Developer of the Original Code is Andrey V. Chudin, [chudin att yandex dott ru]\r\nPortions created by Andrey V. Chudin are Copyright (C) 2003 Andrey V. Chudin.\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\nMichael Beck [mbeck att bigfoot dott com].\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nDescription:\r\n Enhanced ListBox component that can display its items in three\r\n dimensional styles. Items captions align in one of 9 positions.\r\n Component can display glyphs on own items and fill background with\r\n bitmap. You can set different fonts for selected item and for\r\n other list items.\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvgListBox.pas 12741 2010-04-02 10:43:13Z ahuser $\r\n\r\nunit JvgListBox;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, Messages, SysUtils, Classes, Graphics, Controls,\r\n Forms, Dialogs, StdCtrls, CommCtrl, ExtCtrls, ImgList,\r\n JVCLVer, JvJVCLUtils,\r\n JvgTypes, JvgCommClasses, Jvg3DColors;\r\n\r\nconst\r\n WordWraps: array [Boolean] of Word = (0, DT_WORDBREAK);\r\n\r\ntype\r\n TglLBWallpaperOption = (fwlNone, fwlStretch, fwlTile, fwlGlobal);\r\n TglLBChangeEvent = procedure(Sender: TObject;\r\n FOldSelItemIndex, FSelItemIndex: Integer) of object;\r\n TglLBOnDrawEvent = procedure(Sender: TObject; Msg: TWMDrawItem) of object;\r\n TglOnGetDragImageEvent = procedure(Sender: TObject; Bitmap: TJvBitmap;\r\n var TransparentColor: TColor; var HotSpotX, HotSpotY: Integer) of object;\r\n\r\n TJvgListBox = class(TCustomListBox)\r\n private\r\n FAboutJVCL: TJVCLAboutInfo;\r\n FAutoTransparentColor: TglAutoTransparentColor;\r\n FWallpaper: TBitmap;\r\n FWallpaperImage: TImage;\r\n FWallpaperOption: TglLBWallpaperOption;\r\n FNumGlyphs: Word;\r\n FGlyphsAlign: TJvg2DAlign;\r\n FTextAlign: TJvg2DAlign;\r\n FTransparentColor: TColor;\r\n FHotTrackColor: TColor;\r\n FItemStyle: TJvgListBoxItemStyle;\r\n FItemSelStyle: TJvgListBoxItemStyle;\r\n FGlyphs: TImageList;\r\n FItemHeight: Word;\r\n FTextAlign_: UINT;\r\n HotTrackingItemIndex: Integer;\r\n FOptions: TglListBoxOptions;\r\n FChangeGlyphColor: TJvgTwainColors;\r\n FDragImage: TImageList;\r\n FOnDrawItem: TglLBOnDrawEvent;\r\n FOnChange: TglLBChangeEvent;\r\n FOnGetItemColor: TglOnGetItemColorEvent;\r\n FOnGetItemFontColor: TglOnGetItemColorEvent;\r\n FOnGetDragImage: TglOnGetDragImageEvent;\r\n ThreeDColors: TJvg3DLocalColors;\r\n FWallpaperBmp: TBitmap;\r\n FTmpBitmap: TBitmap;\r\n FOldSelItemIndex: Integer;\r\n FSelItemIndex: Integer;\r\n FUseWallpaper: Boolean;\r\n procedure SetAutoTransparentColor(Value: TglAutoTransparentColor);\r\n procedure SetWallpaper(Value: TBitmap);\r\n function GetWallpaper: TBitmap;\r\n procedure SetWallpaperImage(Value: TImage);\r\n procedure SetWOpt(Value: TglLBWallpaperOption);\r\n procedure SetNumGlyphs(Value: Word);\r\n procedure SetGlyphs(Value: TImageList);\r\n procedure SetItemHeight(Value: Word);\r\n procedure SetTransparentColor(Value: TColor);\r\n procedure SetHotTrackColor(Value: TColor);\r\n procedure SetAlign;\r\n procedure SetOptions(Value: TglListBoxOptions);\r\n function GetSelectedObject: Pointer;\r\n procedure RecalcHeights;\r\n procedure SmthChanged(Sender: TObject);\r\n procedure CNDrawItem(var Msg: TWMDrawItem); message CN_DRAWITEM;\r\n procedure CNMeasureItem(var Msg: TWMMeasureItem); message CN_MEASUREITEM;\r\n procedure CMMouseLeave(var Msg: TMessage); message CM_MOUSELEAVE;\r\n procedure WMMouseMove(var Msg: TMessage); message WM_MOUSEMOVE;\r\n protected\r\n function GetSelCount: Integer; override;\r\n procedure Loaded; override;\r\n procedure Notification(AComponent: TComponent; Operation: TOperation); override;\r\n procedure DestroyWnd; override;\r\n procedure CreateDragImage;\r\n procedure DoStartDrag(var DragObject: TDragObject); override;\r\n procedure InitState(var State: TOwnerDrawState; ByteState: Byte);\r\n public\r\n FLeftIndent: Integer;\r\n FreeObjectsOnDestroy: Boolean;\r\n IndentLeft: Integer;\r\n IndentRight: Integer;\r\n TextIndent: Integer;\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n function GetDragImages: TDragImageList; override;\r\n property SelectedObject: Pointer read GetSelectedObject;\r\n property SelCount: Integer read GetSelCount;\r\n published\r\n property AboutJVCL: TJVCLAboutInfo read FAboutJVCL write FAboutJVCL stored False;\r\n property Anchors;\r\n property Align;\r\n property BorderStyle;\r\n property Color;\r\n property DragCursor;\r\n property DragMode;\r\n property Enabled;\r\n property MultiSelect;\r\n // property IntegralHeight;\r\n property Items;\r\n property ParentColor;\r\n property ParentShowHint;\r\n property PopupMenu;\r\n property ShowHint;\r\n property Sorted;\r\n property TabOrder;\r\n property TabStop;\r\n property Visible;\r\n property OnClick;\r\n property OnDblClick;\r\n property OnDragDrop;\r\n property OnDragOver;\r\n property OnEndDrag;\r\n property OnEnter;\r\n property OnExit;\r\n property OnKeyDown;\r\n property OnKeyPress;\r\n property OnKeyUp;\r\n property OnMouseDown;\r\n property OnMouseMove;\r\n property OnMouseUp;\r\n property OnStartDrag;\r\n property AutoTransparentColor: TglAutoTransparentColor\r\n read FAutoTransparentColor write SetAutoTransparentColor default ftcLeftBottomPixel;\r\n property Wallpaper: TBitmap read GetWallpaper write SetWallpaper;\r\n property WallpaperImage: TImage read FWallpaperImage write SetWallpaperImage;\r\n property WallpaperOption: TglLBWallpaperOption read FWallpaperOption write SetWOpt default fwlNone;\r\n property NumGlyphs: Word read FNumGlyphs write SetNumGlyphs default 1;\r\n property GlyphsAlign: TJvg2DAlign read FGlyphsAlign write FGlyphsAlign;\r\n property ItemStyle: TJvgListBoxItemStyle read FItemStyle write FItemStyle;\r\n property ItemSelStyle: TJvgListBoxItemStyle read FItemSelStyle write FItemSelStyle;\r\n property Glyphs: TImageList read FGlyphs write SetGlyphs;\r\n property TextAlign: TJvg2DAlign read FTextAlign write FTextAlign;\r\n property ItemHeight: Word read FItemHeight write SetItemHeight default 0;\r\n property TransparentColor: TColor read FTransparentColor write SetTransparentColor;\r\n property HotTrackColor: TColor read FHotTrackColor write SetHotTrackColor default clBlue;\r\n property Options: TglListBoxOptions read FOptions write SetOptions;\r\n property ChangeGlyphColor: TJvgTwainColors read FChangeGlyphColor write FChangeGlyphColor;\r\n property OnDrawItem: TglLBOnDrawEvent read FOnDrawItem write FOnDrawItem;\r\n property OnChange: TglLBChangeEvent read FOnChange write FOnChange;\r\n property OnGetItemColor: TglOnGetItemColorEvent read FOnGetItemColor write FOnGetItemColor;\r\n property OnGetItemFontColor: TglOnGetItemColorEvent read FOnGetItemFontColor write FOnGetItemFontColor;\r\n property OnGetDragImage: TglOnGetDragImageEvent read FOnGetDragImage write FOnGetDragImage;\r\n end;\r\n\r\n TJvgCheckListBox = class(TJvgListBox)\r\n private\r\n FCheckWidth: Integer;\r\n FCheckHeight: Integer;\r\n function GetState(Index: Integer): TCheckBoxState;\r\n procedure SetChecked(Index: Integer; State: TCheckBoxState);\r\n function GetChecked(Index: Integer): TCheckBoxState;\r\n // procedure ToggleClickCheck( Index: Integer );\r\n // procedure InvalidateCheck( Index: Integer );\r\n procedure CNDrawItem(var Msg: TWMDrawItem); message CN_DRAWITEM;\r\n procedure DrawCheck(R: TRect; AState: TCheckBoxState);\r\n protected\r\n procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;\r\n public\r\n property Checked[Index: Integer]: TCheckBoxState read GetChecked write SetChecked;\r\n constructor Create(AOwner: TComponent); override;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvgListBox.pas $';\r\n Revision: '$Revision: 12741 $';\r\n Date: '$Date: 2010-04-02 12:43:13 +0200 (ven. 02 avr. 2010) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n Math,\r\n JvgUtils;\r\n\r\n//=== { TJvgListBox } ========================================================\r\n\r\nconstructor TJvgListBox.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n ControlStyle := ControlStyle + [csDisplayDragImage];\r\n Style := lbOwnerDrawVariable;\r\n ThreeDColors := TJvg3DLocalColors.Create(Self);\r\n FWallpaper := TBitmap.Create;\r\n FTmpBitmap := TBitmap.Create;\r\n FGlyphsAlign := TJvg2DAlign.Create;\r\n FTextAlign := TJvg2DAlign.Create;\r\n FItemStyle := TJvgListBoxItemStyle.Create;\r\n FItemSelStyle := TJvgListBoxItemStyle.Create;\r\n FChangeGlyphColor := TJvgTwainColors.Create;\r\n FDragImage := TImageList.CreateSize(32, 32);\r\n HotTrackingItemIndex := -1;\r\n FHotTrackColor := clBlue;\r\n FLeftIndent := 0;\r\n //...defaults\r\n if csDesigning in ComponentState then\r\n begin\r\n FItemStyle.Color := clBtnFace;\r\n FItemStyle.TextStyle := fstNone;\r\n FItemSelStyle.Color := clBtnShadow;\r\n FItemSelStyle.TextStyle := fstNone;\r\n end;\r\n FWallpaperOption := fwlNone;\r\n NumGlyphs := 1;\r\n FTransparentColor := clOlive;\r\n FAutoTransparentColor := ftcLeftBottomPixel;\r\n FOptions := [fboHotTrack, fboWordWrap, fboExcludeGlyphs];\r\n FChangeGlyphColor.FromColor := clBlack;\r\n FChangeGlyphColor.ToColor := clWhite;\r\n FGlyphsAlign.OnChanged := SmthChanged;\r\n FTextAlign.OnChanged := SmthChanged;\r\n FItemStyle.OnChanged := SmthChanged;\r\n FItemSelStyle.OnChanged := SmthChanged;\r\n FChangeGlyphColor.OnChanged := SmthChanged;\r\nend;\r\n\r\ndestructor TJvgListBox.Destroy;\r\nbegin\r\n FWallpaper.Free;\r\n ThreeDColors.Free;\r\n FGlyphsAlign.Free;\r\n FTextAlign.Free;\r\n FTmpBitmap.Free;\r\n FItemStyle.Free;\r\n FItemSelStyle.Free;\r\n FChangeGlyphColor.Free;\r\n FDragImage.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvgListBox.Loaded;\r\nbegin\r\n inherited Loaded;\r\n Font := ItemStyle.Font;\r\n Canvas.Font := ItemStyle.Font;\r\n SetAlign;\r\n RecalcHeights;\r\n\r\n if fboTransparent in FOptions then\r\n begin\r\n if not Assigned(FWallpaper) then\r\n FWallpaper := TBitmap.Create;\r\n FWallpaper.Width := Width;\r\n FWallpaper.Height := Height;\r\n GetParentImageRect(Self, Bounds(Left, Top, Width, Height),\r\n FWallpaper.Canvas.Handle);\r\n FWallpaperBmp := FWallpaper;\r\n FUseWallpaper := True;\r\n end\r\n else\r\n begin\r\n if Assigned(FWallpaper) and not FWallpaper.Empty then\r\n FWallpaperBmp := FWallpaper;\r\n FUseWallpaper := IsItAFilledBitmap(FWallpaperBmp);\r\n end;\r\nend;\r\n\r\nprocedure TJvgListBox.Notification(AComponent: TComponent;\r\n Operation: TOperation);\r\nbegin\r\n inherited Notification(AComponent, Operation);\r\n if (AComponent = WallpaperImage) and (Operation = opRemove) then\r\n WallpaperImage := nil;\r\nend;\r\n\r\nprocedure TJvgListBox.DestroyWnd;\r\nvar\r\n I: Integer;\r\nbegin\r\n if FreeObjectsOnDestroy then\r\n for I := 0 to Items.Count do\r\n try\r\n Items.Objects[I].Free;\r\n Items.Objects[I] := nil;\r\n except\r\n end;\r\n inherited DestroyWnd;\r\nend;\r\n\r\nprocedure TJvgListBox.CNMeasureItem(var Msg: TWMMeasureItem);\r\nvar\r\n R: TRect;\r\n Shift: Integer;\r\nconst\r\n WordBreak: array [Boolean] of Integer = (0, DT_WORDBREAK);\r\nbegin\r\n if csReading in ComponentState then\r\n Exit;\r\n R := Rect(0, 0, Width - FLeftIndent, 0);\r\n Shift := 0;\r\n if (fboExcludeGlyphs in Options) and Assigned(FGlyphs) then\r\n if FGlyphsAlign.Horizontal = fhaLeft then\r\n R.Left := FGlyphs.Width\r\n else\r\n if FGlyphsAlign.Horizontal = fhaRight then\r\n R.Right := R.Right - FGlyphs.Width;\r\n with Msg.MeasureItemStruct^ do\r\n begin\r\n Windows.DrawText(Canvas.Handle, PChar(Items[itemID]),\r\n Length(Items[itemID]), R, DT_CALCRECT or WordBreak[fboWordWrap in Options]);\r\n if R.Bottom = 0 then\r\n R.Bottom := 14;\r\n Msg.MeasureItemStruct^.itemHeight := R.Bottom - R.Top;\r\n if (ItemStyle.Bevel.Inner <> bvNone) or (ItemSelStyle.Bevel.Inner <> bvNone) then\r\n if (ItemStyle.Bevel.Bold) or (ItemSelStyle.Bevel.Bold) then\r\n Inc(Shift, 2)\r\n else\r\n Inc(Shift);\r\n if (ItemStyle.Bevel.Outer <> bvNone) or (ItemSelStyle.Bevel.Outer <> bvNone) then\r\n if (ItemStyle.Bevel.Bold) or (ItemSelStyle.Bevel.Bold) then\r\n Inc(Shift, 2)\r\n else\r\n Inc(Shift);\r\n if (ItemStyle.TextStyle <> fstNone) or (ItemSelStyle.TextStyle <> fstNone) then\r\n Inc(Shift, 2);\r\n if Assigned(FGlyphs) and (FGlyphs.Height > Integer(itemHeight)) then\r\n itemHeight := FGlyphs.Height;\r\n Inc(Msg.MeasureItemStruct^.itemHeight, Shift);\r\n if FItemHeight > 0 then\r\n Msg.MeasureItemStruct^.itemHeight := FItemHeight;\r\n end;\r\n // Msg.MeasureItemStruct^.itemHeight:=13;\r\nend;\r\n\r\nprocedure TJvgListBox.CNDrawItem(var Msg: TWMDrawItem);\r\nvar\r\n Index: Integer;\r\n R, TxtRect: TRect;\r\n State: TOwnerDrawState;\r\n ItemStyle: TJvgListBoxItemStyle;\r\n LSelected, LDrawWallpaper: Boolean;\r\n DC: HDC;\r\n Image: TBitmap;\r\n TargetCanvas: TCanvas;\r\n ItemColor, FontColor, GrFromColor, GrToColor: TColor;\r\n\r\n procedure DrawGlyph(R: TRect);\r\n var\r\n I, FTranspColor: Integer;\r\n OldRect: TRect;\r\n begin\r\n if (FGlyphs = nil) or (FGlyphs.Count = 0) then\r\n Exit;\r\n OldRect := R;\r\n Inc(R.Top);\r\n Inc(R.Left);\r\n case FGlyphsAlign.Horizontal of\r\n fhaCenter:\r\n OffsetRect(R, (R.Right - R.Left - Glyphs.Width) div 2, 0);\r\n fhaRight:\r\n OffsetRect(R, R.Right - R.Left - Glyphs.Width - 1, 0);\r\n end;\r\n case GlyphsAlign.Vertical of\r\n fvaCenter:\r\n OffsetRect(R, 0, (R.Bottom - R.Top - Glyphs.Height) div 2);\r\n fvaBottom:\r\n OffsetRect(R, 0, R.Bottom - R.Top - Glyphs.Height - 1);\r\n end;\r\n\r\n if fboSingleGlyph in Options then\r\n I := 0\r\n else\r\n if Index < NumGlyphs then\r\n I := Index\r\n else\r\n I := -1;\r\n\r\n if I >= 0 then\r\n begin\r\n FGlyphs.GetBitmap(I, FTmpBitmap);\r\n if LSelected and (fboChangeGlyphColor in Options) then\r\n JvgUtils.ChangeBitmapColor(FTmpBitmap, FChangeGlyphColor.FromColor,\r\n FChangeGlyphColor.ToColor);\r\n\r\n if FAutoTransparentColor = ftcUser then\r\n FTranspColor := FTransparentColor\r\n else\r\n FTranspColor := GetTransparentColor(FTmpBitmap, FAutoTransparentColor);\r\n\r\n // if LDrawWallpaper then\r\n CreateBitmapExt(DC, FTmpBitmap, Rect(0, 0, 100, 100), R.Left, R.Top,\r\n fwoNone, fdsDefault, True, FTranspColor, clBlack);\r\n // else\r\n // begin\r\n // JvgUtils.ChangeBitmapColor( FTmpBitmap, FTranspColor, ItemStyle.Color );\r\n // BitBlt( DC, R.Left, R.Top, FTmpBitmap.Width, FTmpBitmap.Height, FTmpBitmap.Canvas.Handle,\r\n // 0, 0, SRCCOPY );\r\n // end;\r\n end;\r\n end;\r\n\r\n procedure DrawWallpaper;\r\n\r\n procedure FillTiled(R: TRect; YOffset: Integer);\r\n var\r\n Y, X1, Y1, IWidth, IHeight: Integer;\r\n begin\r\n IWidth := Min(R.Right - R.Left + 1, FWallpaperBmp.Width);\r\n IHeight := Min(R.Bottom - R.Top, FWallpaperBmp.Height);\r\n X1 := R.Left;\r\n Y1 := R.Top;\r\n Y := Y1;\r\n while X1 < R.Right do\r\n begin\r\n if X1 + IWidth > R.Right then\r\n IWidth := R.Right - X1;\r\n while Y1 < R.Bottom do\r\n begin\r\n //if Y1+IHeight > R.Bottom then IHeight:=R.Bottom-Y1;\r\n BitBlt(DC, X1, Y1, IWidth, IHeight, FWallpaperBmp.Canvas.Handle,\r\n 0, YOffset, SRCCOPY);\r\n Inc(Y1, IHeight);\r\n YOffset := 0;\r\n end;\r\n Inc(X1, IWidth);\r\n Y1 := Y;\r\n end;\r\n end;\r\n\r\n begin\r\n if Assigned(FWallpaperBmp) then\r\n begin\r\n case WallpaperOption of\r\n fwlStretch:\r\n Canvas.StretchDraw(R, FWallpaperBmp);\r\n fwlTile:\r\n FillTiled(R, 0);\r\n fwlGlobal:\r\n begin {\r\n if fboBufferedDraw in Options then with Msg.DrawItemStruct^ do\r\n Y := R.Top + rcItem.Top else Y := R.Top;\r\n\r\n Y := Y-trunc((Y div FWallpaperBmp.Height)*FWallpaperBmp.Height);\r\n FillTiled( R, Y );\r\n\r\n if Msg.DrawItemStruct^.itemID = UINT(Items.Count-1) then\r\n begin\r\n if fboBufferedDraw in Options then with Msg.DrawItemStruct^ do\r\n Y := R.Bottom + rcItem.Top else Y := R.Bottom;\r\n R2 := Rect ( R.Left-1, R.Bottom+2, R.Right+1, Height );\r\n Y := Y-trunc((Y div FWallpaperBmp.Height)*FWallpaperBmp.Height);\r\n FillTiled( R2, Y );\r\n end;}\r\n BitBlt(DC, R.Left + 1, R.Top, R.Right - R.Left - 1, R.Bottom -\r\n R.Top, FWallpaperBmp.Canvas.Handle, 0, R.Top, SRCCOPY);\r\n\r\n with Msg.DrawItemStruct^ do\r\n if itemID = UINT(Items.Count - 1) then\r\n BitBlt(DC, rcItem.Left, rcItem.Bottom, rcItem.Right -\r\n rcItem.Left, Height, FWallpaperBmp.Canvas.Handle,\r\n rcItem.Left, rcItem.Bottom, SRCCOPY);\r\n end;\r\n else\r\n BitBlt(DC, R.Left, R.Top, Min(FWallpaperBmp.Width, R.Right - R.Left),\r\n Min(FWallpaperBmp.Height, R.Bottom - R.Top),\r\n FWallpaperBmp.Canvas.Handle, 0, 0, SRCCOPY);\r\n end;\r\n end;\r\n end;\r\n\r\nbegin\r\n if Items.Count = 0 then\r\n Exit;\r\n\r\n if not FWallpaper.Empty then\r\n FWallpaperBmp := FWallpaper\r\n else\r\n if Assigned(FWallpaperImage) and Assigned(FWallpaperImage.Picture) and\r\n Assigned(FWallpaperImage.Picture.Bitmap) then\r\n FWallpaperBmp := FWallpaperImage.Picture.Bitmap\r\n else\r\n FWallpaperBmp := nil;\r\n\r\n FUseWallpaper := IsItAFilledBitmap(FWallpaperBmp);\r\n\r\n with Msg.DrawItemStruct^ do\r\n begin\r\n Index := UINT(itemID);\r\n if Index = -1 then\r\n begin\r\n if IsItAFilledBitmap(FWallpaperBmp) then\r\n BitBlt(hDC, 0, 0, Width, Height, FWallpaperBmp.Canvas.Handle, 0, 0, SRCCOPY);\r\n Exit;\r\n end;\r\n\r\n InitState(State, WordRec(LongRec(ItemState).Lo).Lo);\r\n\r\n Canvas.Handle := hDC;\r\n R := rcItem;\r\n end;\r\n Inc(R.Left, IndentLeft);\r\n Dec(R.Right, IndentRight);\r\n if fboBufferedDraw in Options then\r\n begin\r\n Image := TBitmap.Create;\r\n Image.Width := R.Right - R.Left;\r\n Image.Height := R.Bottom - R.Top;\r\n TargetCanvas := Image.Canvas;\r\n Dec(R.Bottom, R.Top);\r\n R.Top := 0;\r\n end\r\n else\r\n begin\r\n Image := nil;\r\n TargetCanvas := Canvas;\r\n end;\r\n DC := TargetCanvas.Handle;\r\n\r\n LSelected := (State = [odSelected, odFocused]) or (State = [odSelected]);\r\n if LSelected then\r\n ItemStyle := FItemSelStyle\r\n else\r\n ItemStyle := FItemStyle;\r\n\r\n LDrawWallpaper := (not (LSelected and (FItemStyle.Color <> FItemSelStyle.Color))) and FUseWallpaper;\r\n\r\n //...DrawLBItem\r\n Inc(R.Left);\r\n Dec(R.Right);\r\n Dec(R.Bottom);\r\n ItemColor := ItemStyle.Color;\r\n if Assigned(FOnGetItemColor) then\r\n FOnGetItemColor(Self, Index, ItemColor);\r\n if fboAutoCtl3DColors in Options then\r\n begin\r\n ThreeDColors.CreateAuto3DColors(ItemColor);\r\n ThreeDColors.MakeGlobal;\r\n end;\r\n R := DrawBoxEx(DC, R, ItemStyle.Bevel.Sides, ItemStyle.Bevel.Inner,\r\n ItemStyle.Bevel.Outer, ItemStyle.Bevel.Bold, ItemColor, LDrawWallpaper);\r\n if fboAutoCtl3DColors in Options then\r\n ThreeDColors.MakeLocal;\r\n\r\n Dec(R.Left);\r\n Inc(R.Right);\r\n Inc(R.Bottom);\r\n if ItemStyle.Gradient.Active then\r\n with ItemStyle do\r\n begin\r\n GrFromColor := Gradient.RGBFromColor;\r\n GrToColor := Gradient.RGBToColor;\r\n if ItemColor > 0 then\r\n begin\r\n if fboItemColorAsGradientFrom in Options then\r\n Gradient.RGBFromColor := ItemColor;\r\n if fboItemColorAsGradientTo in Options then\r\n Gradient.RGBToColor := ItemColor;\r\n end;\r\n GradientBox(DC, R, Gradient, Integer(psSolid), 1);\r\n Gradient.RGBFromColor := GrFromColor;\r\n Gradient.RGBToColor := GrToColor;\r\n end;\r\n\r\n if LDrawWallpaper then\r\n DrawWallpaper;\r\n\r\n if Assigned(FGlyphs) then\r\n begin\r\n DrawGlyph(R);\r\n if fboExcludeGlyphs in Options then\r\n if FGlyphsAlign.Horizontal = fhaLeft then\r\n R.Left := R.Left + FGlyphs.Width\r\n else\r\n if FGlyphsAlign.Horizontal = fhaRight then\r\n R.Right := R.Right - FGlyphs.Width\r\n end;\r\n Inc(R.Left, FLeftIndent);\r\n SetBkMode(DC, TRANSPARENT);\r\n Inc(R.Left);\r\n Dec(R.Right, 2);\r\n\r\n TxtRect := R;\r\n Inc(TxtRect.Left, TextIndent);\r\n if not (fboHideText in Options) then\r\n begin\r\n if Assigned(OnGetItemFontColor) then\r\n begin\r\n ItemColor := ItemStyle.Font.Color;\r\n OnGetItemFontColor(Self, Index, ItemColor);\r\n ItemStyle.Font.Color := ItemColor;\r\n end;\r\n FontColor := ItemStyle.Font.Color;\r\n if HotTrackingItemIndex = Index then\r\n begin\r\n ItemStyle.Font.Color := FHotTrackColor;\r\n // if LSelected then ItemStyle.Font.Color := clWhite;\r\n end;\r\n DrawTextInRect(TargetCanvas.Handle, TxtRect, Items[Index],\r\n ItemStyle.TextStyle, ItemStyle.Font, FTextAlign_);\r\n ItemStyle.Font.Color := FontColor;\r\n end;\r\n if TargetCanvas <> Canvas then\r\n BitBlt(Msg.DrawItemStruct^.hDC, Msg.DrawItemStruct^.rcItem.Left,\r\n Msg.DrawItemStruct^.rcItem.Top,\r\n Image.Width, Image.Height, Image.Canvas.Handle, 0, 0, SRCCOPY);\r\n\r\n with Msg.DrawItemStruct^ do\r\n if (odFocused in State) and (fboShowFocus in Options) then\r\n DrawFocusRect(hDC, rcItem);\r\n\r\n Image.Free;\r\n if Assigned(FOnDrawItem) then\r\n FOnDrawItem(Self, Msg);\r\n if Assigned(FOnChange) then\r\n begin\r\n FOldSelItemIndex := FSelItemIndex;\r\n FSelItemIndex := ItemIndex;\r\n if FOldSelItemIndex <> FSelItemIndex then\r\n FOnChange(Self, FOldSelItemIndex, FSelItemIndex);\r\n end;\r\nend;\r\n\r\nprocedure TJvgListBox.CMMouseLeave(var Msg: TMessage);\r\nvar\r\n R: TRect;\r\nbegin\r\n inherited;\r\n if HotTrackingItemIndex <> -1 then\r\n begin\r\n R := ItemRect(HotTrackingItemIndex);\r\n HotTrackingItemIndex := -1;\r\n InvalidateRect(Handle, @R, False);\r\n end;\r\nend;\r\n\r\nprocedure TJvgListBox.WMMouseMove(var Msg: TMessage);\r\nvar\r\n Pt: TPoint;\r\n R: TRect;\r\n ItemIndex: Integer;\r\nbegin\r\n inherited;\r\n if not (fboHotTrack in Options) and not (fboHotTrackSelect in Options) then\r\n Exit;\r\n Pt.X := LOWORD(Msg.lParam);\r\n Pt.Y := HiWord(Msg.lParam);\r\n ItemIndex := ItemAtPos(Pt, True);\r\n\r\n if ItemIndex = HotTrackingItemIndex then\r\n Exit;\r\n\r\n if fboHotTrackSelect in Options then\r\n begin\r\n Self.ItemIndex := ItemIndex;\r\n InvalidateRect(Handle, nil, False);\r\n Exit;\r\n end;\r\n\r\n if HotTrackingItemIndex <> -1 then\r\n begin\r\n R := ItemRect(HotTrackingItemIndex);\r\n InvalidateRect(Handle, @R, False);\r\n end;\r\n HotTrackingItemIndex := ItemIndex;\r\n if HotTrackingItemIndex <> -1 then\r\n begin\r\n R := ItemRect(HotTrackingItemIndex);\r\n InvalidateRect(Handle, @R, False);\r\n end;\r\nend;\r\n\r\nfunction TJvgListBox.GetDragImages: TDragImageList;\r\nbegin\r\n if FDragImage.Count > 0 then\r\n Result := FDragImage\r\n else\r\n Result := nil;\r\nend;\r\n\r\nprocedure TJvgListBox.CreateDragImage;\r\nvar\r\n HotSpotX, HotSpotY: Integer;\r\n TranspColor: TColor;\r\n Bmp: TJvBitmap;\r\n Pt: TPoint;\r\n R: TRect;\r\nbegin\r\n FDragImage.Clear;\r\n if ItemIndex = -1 then\r\n Exit;\r\n R := ItemRect(ItemIndex);\r\n\r\n Bmp := TJvBitmap.Create;\r\n with Bmp do\r\n try\r\n GetCursorPos(Pt);\r\n with ScreenToClient(Pt) do\r\n begin\r\n HotSpotX := X - R.Left;\r\n HotSpotY := Y - R.Top\r\n end;\r\n if Assigned(FOnGetDragImage) then\r\n FOnGetDragImage(Self, Bmp, TranspColor, HotSpotX, HotSpotY)\r\n else\r\n begin\r\n Width := R.Right - R.Left;\r\n Height := R.Bottom - R.Top;\r\n Canvas.Font := ItemSelStyle.Font;\r\n Canvas.DrawFocusRect(Rect(0, 0, Width, Height));\r\n Canvas.Brush.Style := bsClear;\r\n Canvas.TextOut(1, 1, Items[ItemIndex]);\r\n TranspColor := clWhite;\r\n end;\r\n FDragImage.Width := Width;\r\n FDragImage.Height := Height;\r\n FDragImage.AddMasked(Bmp, TranspColor);\r\n FDragImage.SetDragImage(0, HotSpotX, HotSpotY);\r\n finally\r\n Bmp.Free;\r\n end;\r\nend;\r\n\r\nprocedure TJvgListBox.DoStartDrag(var DragObject: TDragObject);\r\nbegin\r\n inherited DoStartDrag(DragObject);\r\n CreateDragImage;\r\nend;\r\n\r\nprocedure TJvgListBox.SetAutoTransparentColor(Value: TglAutoTransparentColor);\r\nbegin\r\n if FAutoTransparentColor <> Value then\r\n begin\r\n FAutoTransparentColor := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nfunction TJvgListBox.GetWallpaper: TBitmap;\r\nbegin\r\n if not Assigned(FWallpaper) then\r\n FWallpaper := TBitmap.Create;\r\n Result := FWallpaper;\r\nend;\r\n\r\nprocedure TJvgListBox.SetWallpaper(Value: TBitmap);\r\nbegin\r\n Wallpaper.Assign(Value);\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvgListBox.SetWallpaperImage(Value: TImage);\r\nbegin\r\n ReplaceComponentReference(Self, Value, TComponent(FWallpaperImage));\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvgListBox.SetWOpt(Value: TglLBWallpaperOption);\r\nbegin\r\n FWallpaperOption := Value;\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvgListBox.SetNumGlyphs(Value: Word);\r\nbegin\r\n if Value >= 1 then\r\n begin\r\n FNumGlyphs := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvgListBox.SetGlyphs(Value: TImageList);\r\nbegin\r\n FGlyphs := Value;\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvgListBox.SetItemHeight(Value: Word);\r\nbegin\r\n FItemHeight := Value;\r\n RecalcHeights;\r\nend;\r\n\r\nprocedure TJvgListBox.SetAlign;\r\nbegin\r\n if fboWordWrap in Options then\r\n FTextAlign_ := DT_WORDBREAK or DT_NOPREFIX\r\n else\r\n FTextAlign_ := DT_SINGLELINE or DT_NOPREFIX;\r\n case FTextAlign.Horizontal of\r\n fhaLeft:\r\n FTextAlign_ := FTextAlign_ or DT_LEFT;\r\n fhaCenter:\r\n FTextAlign_ := FTextAlign_ or DT_CENTER;\r\n else\r\n FTextAlign_ := FTextAlign_ or DT_RIGHT;\r\n end;\r\n case FTextAlign.Vertical of\r\n fvaTop:\r\n FTextAlign_ := FTextAlign_ or DT_TOP;\r\n fvaCenter:\r\n FTextAlign_ := FTextAlign_ or DT_VCENTER;\r\n else\r\n FTextAlign_ := FTextAlign_ or DT_BOTTOM;\r\n end;\r\nend;\r\n\r\nprocedure TJvgListBox.SetTransparentColor(Value: TColor);\r\nbegin\r\n FTransparentColor := Value;\r\n if FAutoTransparentColor <> ftcUser then\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvgListBox.SetHotTrackColor(Value: TColor);\r\nvar\r\n R: TRect;\r\nbegin\r\n if FHotTrackColor = Value then\r\n Exit;\r\n FHotTrackColor := Value;\r\n if HotTrackingItemIndex <> -1 then //...user can program hottrack blinking effect!\r\n begin\r\n R := ItemRect(HotTrackingItemIndex);\r\n InvalidateRect(Handle, @R, False);\r\n end;\r\nend;\r\n\r\nprocedure TJvgListBox.SetOptions(Value: TglListBoxOptions);\r\nbegin\r\n if FOptions = Value then\r\n Exit;\r\n if not (csLoading in ComponentState) then\r\n { if (fboTransparent in Value) and not (fboTransparent in FOptions)then\r\n begin\r\n FWallpaper.Width := Width; FWallpaper.Height := Height;\r\n GetParentImageRect( Self, Bounds(Left,Top,Width,Height),\r\n FWallpaper.Canvas.Handle );\r\n FWallpaperBmp := FWallpaper;\r\n FUseWallpaper := True;\r\n end; }\r\n FOptions := Value;\r\n SetAlign;\r\n RecalcHeights;\r\n Invalidate;\r\nend;\r\n\r\nfunction TJvgListBox.GetSelectedObject: Pointer;\r\nbegin\r\n if ItemIndex >= 0 then\r\n Result := Items.Objects[ItemIndex]\r\n else\r\n Result := nil;\r\nend;\r\n\r\nfunction TJvgListBox.GetSelCount: Integer;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := 0;\r\n for I := 0 to Items.Count - 1 do\r\n if Selected[I] then\r\n Inc(Result);\r\nend;\r\n\r\nprocedure TJvgListBox.RecalcHeights;\r\nvar\r\n I: Integer;\r\nbegin\r\n Items.BeginUpdate;\r\n for I := 0 to Items.Count - 1 do\r\n begin\r\n if Assigned(Items.Objects[I]) then\r\n Items.InsertObject(I, Items.Strings[I], Items.Objects[I])\r\n else\r\n Items.Insert(I, Items.Strings[I]);\r\n Items.Delete(I + 1);\r\n end;\r\n Items.EndUpdate;\r\nend;\r\n\r\nprocedure TJvgListBox.SmthChanged(Sender: TObject);\r\nbegin\r\n if not (csLoading in ComponentState) then\r\n begin\r\n RecalcHeights;\r\n SetAlign;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\n//=== { TJvgCheckListBox } ===================================================\r\n\r\nconstructor TJvgCheckListBox.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FCheckWidth := 14;\r\n FCheckHeight := 14;\r\n FLeftIndent := 22;\r\nend;\r\n\r\nprocedure TJvgCheckListBox.CNDrawItem(var Msg: TWMDrawItem);\r\nvar\r\n R: TRect;\r\n Index: Integer;\r\n State: TOwnerDrawState;\r\nbegin\r\n inherited;\r\n with Msg.DrawItemStruct^ do\r\n begin\r\n InitState(State, WordRec(LongRec(ItemState).Lo).Lo);\r\n\r\n Canvas.Handle := hDC;\r\n R := rcItem;\r\n Index := itemID;\r\n end;\r\n if Index < Items.Count then\r\n begin\r\n R.Right := R.Left + FCheckWidth + 5;\r\n DrawCheck(R, GetState(Index));\r\n end;\r\nend;\r\n\r\nfunction TJvgCheckListBox.GetState(Index: Integer): TCheckBoxState;\r\nbegin\r\n if Index > -1 then\r\n Result := TCheckBoxState(Items.Objects[Index])\r\n else\r\n Result := cbUnchecked;\r\nend;\r\n\r\nprocedure TJvgCheckListBox.DrawCheck(R: TRect; AState: TCheckBoxState);\r\nvar\r\n DrawState: Integer;\r\n DrawRect: TRect;\r\nbegin\r\n case AState of\r\n cbChecked:\r\n DrawState := DFCS_BUTTONCHECK or DFCS_CHECKED;\r\n cbUnchecked:\r\n DrawState := DFCS_BUTTONCHECK;\r\n else // cbGrayed\r\n DrawState := DFCS_BUTTON3STATE or DFCS_CHECKED;\r\n end;\r\n DrawRect.Left := R.Left + (R.Right - R.Left - FCheckWidth) div 2;\r\n DrawRect.Top := R.Top + (R.Bottom - R.Top - FCheckWidth) div 2;\r\n DrawRect.Right := DrawRect.Left + FCheckWidth;\r\n DrawRect.Bottom := DrawRect.Top + FCheckHeight;\r\n\r\n DrawFrameControl(Canvas.Handle, DrawRect, DFC_BUTTON, DrawState);\r\nend;\r\n\r\nprocedure TJvgListBox.InitState(var State: TOwnerDrawState; ByteState: Byte);\r\nbegin\r\n State := [];\r\n if ByteState and ODS_CHECKED <> 0 then\r\n Include(State, odChecked); //TOwnerDrawState\r\n if ByteState and ODS_COMBOBOXEDIT <> 0 then\r\n Include(State, odComboBoxEdit);\r\n if ByteState and ODS_DEFAULT <> 0 then\r\n Include(State, odDefault);\r\n if ByteState and ODS_DISABLED <> 0 then\r\n Include(State, odDisabled);\r\n if ByteState and ODS_FOCUS <> 0 then\r\n Include(State, odFocused);\r\n if ByteState and ODS_GRAYED <> 0 then\r\n Include(State, odGrayed);\r\n if ByteState and ODS_SELECTED <> 0 then\r\n Include(State, odSelected);\r\nend;\r\n\r\nfunction TJvgCheckListBox.GetChecked(Index: Integer): TCheckBoxState;\r\nbegin\r\n Result := TCheckBoxState(Items.Objects[Index]);\r\nend;\r\n\r\nprocedure TJvgCheckListBox.SetChecked(Index: Integer; State: TCheckBoxState);\r\nbegin\r\n Items.Objects[Index] := Pointer(State);\r\nend;\r\n\r\nprocedure TJvgCheckListBox.MouseDown(Button: TMouseButton; Shift: TShiftState;\r\n X, Y: Integer);\r\nvar\r\n APoint: TPoint;\r\n Index: Integer;\r\nbegin\r\n inherited MouseDown(Button, Shift, X, Y);\r\n if Button = mbLeft then\r\n begin\r\n APoint.X := X;\r\n APoint.Y := Y;\r\n Index := ItemAtPos(APoint, True);\r\n if Index > -1 then begin\r\n case TCheckBoxState(Items.Objects[Index]) of\r\n cbUnchecked:\r\n Items.Objects[Index] := Pointer(cbChecked);\r\n cbChecked:\r\n Items.Objects[Index] := Pointer(cbUnchecked);\r\n cbGrayed:\r\n ;\r\n end;\r\n Invalidate;\r\n end;\r\n end;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvgLogics.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvgLogics.PAS, released on 2003-01-15.\r\n\r\nThe Initial Developer of the Original Code is Andrey V. Chudin, [chudin att yandex dott ru]\r\nPortions created by Andrey V. Chudin are Copyright (C) 2003 Andrey V. Chudin.\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\nMichael Beck [mbeck att bigfoot dott com].\r\nBurov Dmitry, translation of russian text.\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvgLogics.pas 12461 2009-08-14 17:21:33Z obones $\r\n\r\nunit JvgLogics;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Classes, SysUtils, Graphics,\r\n JvComponentBase, JvResources;\r\n\r\ntype\r\n TLogicRule = (lrEqual, lrBeginWith, lrEndWith, lrContains, lrContainsIn,\r\n ltNotEmpty);\r\n\r\nconst\r\n LogicRuleLabels: array [TLogicRule] of string = (RsEqualTo,\r\n RsStartingWith, RsEndsWith, RsContains, RsIsContainedWithin, RsNotEmpty);\r\n\r\ntype\r\n TJvgLogics = class;\r\n TJvgLogicElement = class;\r\n TJvgCommentAreas = class;\r\n TJvgLogicVariants = class;\r\n TJvgLogicVariant = class;\r\n TJvgLogicProducer = class;\r\n\r\n TOnTraceMessage = procedure(Sender: TJvgLogics; AStepResult: Boolean;\r\n const StepResult, ParsedResult, Msg: string) of object;\r\n\r\n TJvgLogicProducer = class(TJvComponent)\r\n private\r\n FLogics: TJvgLogics;\r\n FCommentAreas: TJvgCommentAreas;\r\n // FIgnoreSpaces: Boolean;\r\n procedure SetLogics(const Value: TJvgLogics);\r\n procedure SetDictionary(const Value: TStrings);\r\n function GetDictionary: TStrings;\r\n procedure SetCommentAreas(const Value: TJvgCommentAreas);\r\n procedure SetIgnoreSpaces(const Value: Boolean);\r\n function GetIgnoreSpaces: Boolean;\r\n procedure SetOnTraceMessage(const Value: TOnTraceMessage);\r\n function GetOnTraceMessage: TOnTraceMessage;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n procedure Loaded; override;\r\n published\r\n property Logics: TJvgLogics read FLogics write SetLogics;\r\n property CommentAreas: TJvgCommentAreas read FCommentAreas write SetCommentAreas;\r\n property Dictionary: TStrings read GetDictionary write SetDictionary;\r\n property IgnoreSpaces: Boolean read GetIgnoreSpaces write SetIgnoreSpaces;\r\n property OnTraceMessage: TOnTraceMessage read GetOnTraceMessage write SetOnTraceMessage;\r\n end;\r\n\r\n TJvgLogicElement = class(TCollectionItem)\r\n private\r\n FNextElementID: Integer;\r\n FNextFalseElementID: Integer;\r\n // FNextElement: TJvgLogicElement;\r\n // FNextFalseElement: TJvgLogicElement;\r\n FLeft: Integer;\r\n FTop: Integer;\r\n FCaption: string;\r\n FIsFirst: Boolean;\r\n FValue: string;\r\n FExpression: string;\r\n FRule: TLogicRule;\r\n FTrueResult: string;\r\n FFalseResult: string;\r\n FLogicVariants: TJvgLogicVariants;\r\n FIsTrue: Boolean;\r\n function GetNextElement: TJvgLogicElement;\r\n function GetNextFalseElement: TJvgLogicElement;\r\n procedure SetCaption(const Value: string);\r\n procedure SetIsFirst(const Value: Boolean);\r\n procedure SetNextElement(const Value: TJvgLogicElement);\r\n procedure SetNextFalseElement(const Value: TJvgLogicElement);\r\n procedure SetExpression(const Value: string);\r\n procedure SetRule(const Value: TLogicRule);\r\n procedure SetValue(const Value: string);\r\n procedure SetFalseResult(const Value: string);\r\n procedure SetTrueResult(const Value: string);\r\n procedure SetLogicVariants(const Value: TJvgLogicVariants);\r\n public\r\n constructor Create(Collection: TCollection); override;\r\n destructor Destroy; override;\r\n procedure Loaded;\r\n property NextElement: TJvgLogicElement read GetNextElement write SetNextElement;\r\n property NextFalseElement: TJvgLogicElement read GetNextFalseElement write SetNextFalseElement;\r\n property IsTrue: Boolean read FIsTrue write FIsTrue;\r\n published\r\n property ID;\r\n property NextElementID: Integer read FNextElementID write FNextElementID default -1;\r\n property NextFalseElementID: Integer read FNextFalseElementID write FNextFalseElementID default -1;\r\n property Left: Integer read FLeft write FLeft;\r\n property Top: Integer read FTop write FTop;\r\n property Caption: string read FCaption write SetCaption;\r\n property IsFirst: Boolean read FIsFirst write SetIsFirst;\r\n property Expression: string read FExpression write SetExpression;\r\n property Rule: TLogicRule read FRule write SetRule;\r\n property Value: string read FValue write SetValue;\r\n property TrueResult: string read FTrueResult write SetTrueResult;\r\n property FalseResult: string read FFalseResult write SetFalseResult;\r\n property LogicVariants: TJvgLogicVariants read FLogicVariants write SetLogicVariants;\r\n end;\r\n\r\n TJvgLogics = class(TOwnedCollection)\r\n private\r\n FResult: string;\r\n FDictionary: TStringList;\r\n FIgnoreSpaces: Boolean;\r\n FOnTraceMessage: TOnTraceMessage;\r\n FTraceItem: TJvgLogicElement;\r\n function GetItem(Index: Integer): TJvgLogicElement;\r\n procedure SetItem(Index: Integer; Value: TJvgLogicElement);\r\n function GetItemResult(Item: TJvgLogicElement; var LogicVariant: TJvgLogicVariant): Boolean;\r\n function GetDictionary: TStrings;\r\n procedure SetDictionary(const Value: TStrings);\r\n function ParseExpression(const Value: string): string;\r\n public\r\n constructor Create(AOwner: TPersistent; ItemClass: TCollectionItemClass);\r\n destructor Destroy; override;\r\n procedure Loaded;\r\n procedure Analyze;\r\n procedure AnalyzeStep;\r\n procedure StartAnalyze;\r\n // procedure Assign(StylePairs: TJvgLogics);\r\n function Add: TJvgLogicElement;\r\n function Insert(Index: Integer): TJvgLogicElement;\r\n property Items[Index: Integer]: TJvgLogicElement read GetItem write SetItem; default;\r\n property Result: string read FResult write FResult;\r\n property TraceItem: TJvgLogicElement read FTraceItem write FTraceItem;\r\n published\r\n property Dictionary: TStrings read GetDictionary write SetDictionary;\r\n property IgnoreSpaces: Boolean read FIgnoreSpaces write FIgnoreSpaces;\r\n property OnTraceMessage: TOnTraceMessage read FOnTraceMessage write FOnTraceMessage;\r\n end;\r\n\r\n TJvgLogicVariant = class(TCollectionItem)\r\n private\r\n // FExpression: string;\r\n FValue: string;\r\n FTrueResult: string;\r\n FFalseResult: string;\r\n published\r\n // property Expression: string read FExpression write FExpression;\r\n property Value: string read FValue write FValue;\r\n property TrueResult: string read FTrueResult write FTrueResult;\r\n property FalseResult: string read FFalseResult write FFalseResult;\r\n end;\r\n\r\n TJvgLogicVariants = class(TOwnedCollection)\r\n private\r\n function GetItem(Index: Integer): TJvgLogicVariant;\r\n procedure SetItem(Index: Integer; Value: TJvgLogicVariant);\r\n public\r\n function Add: TJvgLogicVariant;\r\n function Insert(Index: Integer): TJvgLogicVariant;\r\n property Items[Index: Integer]: TJvgLogicVariant read GetItem write SetItem; default;\r\n end;\r\n\r\n TJvgCommentArea = class(TCollectionItem)\r\n private\r\n FLeft: Integer;\r\n FTop: Integer;\r\n FWidth: Integer;\r\n FHeight: Integer;\r\n FText: string;\r\n FColor: TColor;\r\n published\r\n property Left: Integer read FLeft write FLeft;\r\n property Top: Integer read FTop write FTop;\r\n property Width: Integer read FWidth write FWidth;\r\n property Height: Integer read FHeight write FHeight;\r\n property Text: string read FText write FText;\r\n property Color: TColor read FColor write FColor;\r\n end;\r\n\r\n TJvgCommentAreas = class(TOwnedCollection)\r\n private\r\n function GetItem(Index: Integer): TJvgCommentArea;\r\n procedure SetItem(Index: Integer; Value: TJvgCommentArea);\r\n public\r\n function Add: TJvgCommentArea;\r\n function Insert(Index: Integer): TJvgCommentArea;\r\n property Items[Index: Integer]: TJvgCommentArea read GetItem write SetItem; default;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvgLogics.pas $';\r\n Revision: '$Revision: 12461 $';\r\n Date: '$Date: 2009-08-14 19:21:33 +0200 (ven. 14 août 2009) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n JvConsts,\r\n JvgUtils;\r\n\r\n//=== { TJvgLogicElement } ===================================================\r\n\r\nconstructor TJvgLogicElement.Create(Collection: TCollection);\r\nbegin\r\n inherited Create(Collection);\r\n Caption := RsStep + IntToStr(ID);\r\n FNextElementID := -1;\r\n FNextFalseElementID := -1;\r\n FLogicVariants := TJvgLogicVariants.Create(Collection, TJvgLogicVariant);\r\nend;\r\n\r\ndestructor TJvgLogicElement.Destroy;\r\nbegin\r\n FLogicVariants.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvgLogicElement.Loaded;\r\nbegin\r\n if FLogicVariants.Count = 0 then\r\n with FLogicVariants.Add do\r\n begin\r\n // FExpression := Self.FExpression;\r\n FValue := Self.Value;\r\n FTrueResult := Self.TrueResult;\r\n FFalseResult := Self.FalseResult;\r\n end;\r\nend;\r\n\r\nfunction TJvgLogicElement.GetNextElement: TJvgLogicElement;\r\nbegin\r\n Result := TJvgLogicElement(Collection.FindItemID(FNextElementID));\r\nend;\r\n\r\nfunction TJvgLogicElement.GetNextFalseElement: TJvgLogicElement;\r\nbegin\r\n Result := TJvgLogicElement(Collection.FindItemID(FNextFalseElementID));\r\nend;\r\n\r\nprocedure TJvgLogicElement.SetCaption(const Value: string);\r\nbegin\r\n FCaption := Value;\r\nend;\r\n\r\nprocedure TJvgLogicElement.SetExpression(const Value: string);\r\nbegin\r\n FExpression := Value;\r\nend;\r\n\r\nprocedure TJvgLogicElement.SetFalseResult(const Value: string);\r\nbegin\r\n FFalseResult := Value;\r\nend;\r\n\r\nprocedure TJvgLogicElement.SetIsFirst(const Value: Boolean);\r\nbegin\r\n FIsFirst := Value;\r\nend;\r\n\r\nprocedure TJvgLogicElement.SetLogicVariants(const Value: TJvgLogicVariants);\r\nbegin\r\n FLogicVariants.Assign(Value);\r\nend;\r\n\r\nprocedure TJvgLogicElement.SetNextElement(const Value: TJvgLogicElement);\r\nbegin\r\n if Value = nil then\r\n FNextElementID := -1\r\n else\r\n FNextElementID := Value.ID;\r\nend;\r\n\r\nprocedure TJvgLogicElement.SetNextFalseElement(const Value: TJvgLogicElement);\r\nbegin\r\n if Value = nil then\r\n FNextFalseElementID := -1\r\n else\r\n FNextFalseElementID := Value.ID;\r\nend;\r\n\r\nprocedure TJvgLogicElement.SetRule(const Value: TLogicRule);\r\nbegin\r\n FRule := Value;\r\nend;\r\n\r\nprocedure TJvgLogicElement.SetTrueResult(const Value: string);\r\nbegin\r\n FTrueResult := Value;\r\nend;\r\n\r\nprocedure TJvgLogicElement.SetValue(const Value: string);\r\nbegin\r\n FValue := Value;\r\nend;\r\n\r\n//=== { TJvgLogics } =========================================================\r\n\r\nconstructor TJvgLogics.Create(AOwner: TPersistent; ItemClass: TCollectionItemClass);\r\nbegin\r\n inherited Create(AOwner, ItemClass);\r\n FDictionary := TStringList.Create;\r\nend;\r\n\r\ndestructor TJvgLogics.Destroy;\r\nbegin\r\n FDictionary.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvgLogics.Loaded;\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := 0 to Count - 1 do\r\n Items[I].Loaded;\r\nend;\r\n\r\nfunction TJvgLogics.GetItem(Index: Integer): TJvgLogicElement;\r\nbegin\r\n Result := TJvgLogicElement(inherited Items[Index]);\r\nend;\r\n\r\nprocedure TJvgLogics.SetItem(Index: Integer; Value: TJvgLogicElement);\r\nbegin\r\n Items[Index].Assign(Value);\r\nend;\r\n\r\nfunction TJvgLogics.Add: TJvgLogicElement;\r\nbegin\r\n Result := TJvgLogicElement(inherited Add);\r\nend;\r\n\r\nfunction TJvgLogics.Insert(Index: Integer): TJvgLogicElement;\r\nbegin\r\n Result := TJvgLogicElement(inherited Insert(Index));\r\nend;\r\n\r\nprocedure TJvgLogics.StartAnalyze;\r\nbegin\r\n if Count > 0 then\r\n TraceItem := Items[0]\r\n else\r\n TraceItem := nil;\r\nend;\r\n\r\nprocedure TJvgLogics.AnalyzeStep;\r\nvar\r\n LogicVariant: TJvgLogicVariant;\r\nbegin\r\n LogicVariant := nil;\r\n if Assigned(TraceItem) then\r\n begin\r\n TraceItem.IsTrue := True;\r\n if GetItemResult(TraceItem, LogicVariant) then\r\n begin\r\n Result := Result + ParseExpression(LogicVariant.TrueResult);\r\n TraceItem := TraceItem.NextElement;\r\n end\r\n else\r\n begin\r\n Result := Result + ParseExpression(LogicVariant.FalseResult);\r\n TraceItem := TraceItem.NextFalseElement;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvgLogics.Analyze;\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := 0 to Count - 1 do\r\n Items[I].IsTrue := False;\r\n\r\n Result := '';\r\n I := 0;\r\n TraceItem := Items[0];\r\n while Assigned(TraceItem) and (I < 1000) do\r\n begin\r\n AnalyzeStep;\r\n Inc(I);\r\n end;\r\nend;\r\n\r\nfunction TJvgLogics.GetItemResult(Item: TJvgLogicElement;\r\n var LogicVariant: TJvgLogicVariant): Boolean;\r\nvar\r\n Expr, Value: string;\r\n I: Integer;\r\nbegin\r\n Result := False;\r\n Expr := ParseExpression(Item.Expression);\r\n if IgnoreSpaces then\r\n Expr := Trim(Expr);\r\n\r\n for I := 0 to Item.LogicVariants.Count - 1 do\r\n begin\r\n Value := ParseExpression(Item.LogicVariants[I].Value);\r\n\r\n case Item.Rule of\r\n lrEqual:\r\n Result := Expr = Value;\r\n lrBeginWith:\r\n Result := Pos(Value, Expr) = 1;\r\n lrEndWith:\r\n Result := Copy(Expr, Length(Expr) - Length(Value) + 1, Length(Value)) = Value;\r\n lrContains:\r\n Result := Pos(Expr, Value) <> 1;\r\n lrContainsIn:\r\n Result := Pos(Value, Expr) <> 1;\r\n ltNotEmpty:\r\n Result := Length(Expr) > 0;\r\n end;\r\n\r\n LogicVariant := Item.LogicVariants[I];\r\n if Result and (Item.LogicVariants[I].TrueResult > '') then\r\n Break;\r\n if not Result and (Item.LogicVariants[I].FalseResult > '') then\r\n Break;\r\n end;\r\n\r\n if Assigned(FOnTraceMessage) then\r\n FOnTraceMessage(Self, Result,\r\n IIF(Result, Item.TrueResult, Item.FalseResult),\r\n ParseExpression(IIF(Result, Item.TrueResult, Item.FalseResult)),\r\n Item.Caption + ' : ' + IIF(Result, 'TRUE', 'FALSE') +\r\n ' : ' + IIF(Result, Item.TrueResult, Item.FalseResult));\r\nend;\r\n\r\nfunction TJvgLogics.ParseExpression(const Value: string): string;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := Value;\r\n Result := StringReplace(Result, '[RESULT]', Self.Result,\r\n [rfReplaceAll, rfIgnoreCase]);\r\n for I := 0 to Dictionary.Count - 1 do\r\n Result := StringReplace(Result, '[' + Dictionary.Names[I] + ']',\r\n Dictionary.Values[Dictionary.Names[I]], [rfReplaceAll, rfIgnoreCase]);\r\n\r\n I := 1;\r\n while I <= Length(Result) do\r\n begin\r\n if Result[I] = '[' then\r\n begin\r\n repeat\r\n Result[I] := '[';\r\n Inc(I);\r\n until (I > Length(Result)) or (Result[I] = ']');\r\n if (I <= Length(Result)) and (Result[I] = ']') then\r\n Result[I] := '[';\r\n end;\r\n Inc(I);\r\n end;\r\n Result := StringReplace(Result, '[', '', [rfReplaceAll]);\r\nend;\r\n\r\nfunction TJvgLogics.GetDictionary: TStrings;\r\nbegin\r\n Result := FDictionary;\r\nend;\r\n\r\nprocedure TJvgLogics.SetDictionary(const Value: TStrings);\r\nbegin\r\n FDictionary.Assign(Value);\r\nend;\r\n\r\n//=== { TJvgLogicProducer } ==================================================\r\n\r\nconstructor TJvgLogicProducer.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FLogics := TJvgLogics.Create(Self, TJvgLogicElement);\r\n FCommentAreas := TJvgCommentAreas.Create(Self, TJvgCommentArea);\r\nend;\r\n\r\ndestructor TJvgLogicProducer.Destroy;\r\nbegin\r\n FLogics.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvgLogicProducer.Loaded;\r\nbegin\r\n inherited Loaded;\r\n Logics.Loaded;\r\nend;\r\n\r\nfunction TJvgLogicProducer.GetDictionary: TStrings;\r\nbegin\r\n Result := Logics.Dictionary;\r\nend;\r\n\r\nprocedure TJvgLogicProducer.SetCommentAreas(const Value: TJvgCommentAreas);\r\nbegin\r\n FCommentAreas.Assign(Value);\r\nend;\r\n\r\nprocedure TJvgLogicProducer.SetDictionary(const Value: TStrings);\r\nbegin\r\n Logics.Dictionary.Assign(Value);\r\nend;\r\n\r\nprocedure TJvgLogicProducer.SetIgnoreSpaces(const Value: Boolean);\r\nbegin\r\n Logics.IgnoreSpaces := Value;\r\nend;\r\n\r\nfunction TJvgLogicProducer.GetIgnoreSpaces: Boolean;\r\nbegin\r\n Result := Logics.IgnoreSpaces;\r\nend;\r\n\r\nprocedure TJvgLogicProducer.SetLogics(const Value: TJvgLogics);\r\nbegin\r\n FLogics := Value;\r\nend;\r\n\r\nprocedure TJvgLogicProducer.SetOnTraceMessage(const Value: TOnTraceMessage);\r\nbegin\r\n Logics.OnTraceMessage := Value;\r\nend;\r\n\r\nfunction TJvgLogicProducer.GetOnTraceMessage: TOnTraceMessage;\r\nbegin\r\n Result := Logics.OnTraceMessage;\r\nend;\r\n\r\n//=== { TJvgCommentAreas } ===================================================\r\n\r\nfunction TJvgCommentAreas.Add: TJvgCommentArea;\r\nbegin\r\n Result := TJvgCommentArea(inherited Add);\r\n Result.Text := RsComments;\r\nend;\r\n\r\nfunction TJvgCommentAreas.GetItem(Index: Integer): TJvgCommentArea;\r\nbegin\r\n Result := TJvgCommentArea(inherited Items[Index]);\r\nend;\r\n\r\nfunction TJvgCommentAreas.Insert(Index: Integer): TJvgCommentArea;\r\nbegin\r\n Result := TJvgCommentArea(inherited Insert(Index));\r\nend;\r\n\r\nprocedure TJvgCommentAreas.SetItem(Index: Integer; Value: TJvgCommentArea);\r\nbegin\r\n Items[Index].Assign(Value);\r\nend;\r\n\r\n//=== { TJvgLogicVariants } ==================================================\r\n\r\nfunction TJvgLogicVariants.Add: TJvgLogicVariant;\r\nbegin\r\n Result := TJvgLogicVariant(inherited Add);\r\nend;\r\n\r\nfunction TJvgLogicVariants.GetItem(Index: Integer): TJvgLogicVariant;\r\nbegin\r\n Result := TJvgLogicVariant(inherited Items[Index]);\r\nend;\r\n\r\nfunction TJvgLogicVariants.Insert(Index: Integer): TJvgLogicVariant;\r\nbegin\r\n Result := TJvgLogicVariant(inherited Insert(Index));\r\nend;\r\n\r\nprocedure TJvgLogicVariants.SetItem(Index: Integer; Value: TJvgLogicVariant);\r\nbegin\r\n Items[Index].Assign(Value);\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvgPage.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvgPage.PAS, released on 2003-01-15.\r\n\r\nThe Initial Developer of the Original Code is Andrey V. Chudin, [chudin att yandex dott ru]\r\nPortions created by Andrey V. Chudin are Copyright (C) 2003 Andrey V. Chudin.\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\nMichael Beck [mbeck att bigfoot dott com].\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nDescription:\r\n PageControl component that can display its pages captions in\r\n 3D styles with 3D borders. Component can display glyphs on own\r\n captions and fill background with bitmap. You can set different\r\n fonts for selected page caption and for other captions.\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvgPage.pas 13104 2011-09-07 06:50:43Z obones $\r\n\r\nunit JvgPage;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,\r\n ComCtrls, CommCtrl, ImgList, ExtCtrls,\r\n JVCLVer,\r\n JvgTypes, JvgDrawTab, JvgTabComm, JvgCommClasses;\r\n\r\n// (rom) disabled unused\r\n//const\r\n// TCM_SETTEXTCOLOR = TCM_FIRST + 36;\r\n\r\ntype\r\n TJvgPageControl = class(TPageControl)\r\n private\r\n FAboutJVCL: TJVCLAboutInfo;\r\n FGlyphs: TImageList;\r\n FSingleGlyph: Boolean;\r\n FTabStyle: TJvgTabStyle;\r\n FTabSelectedStyle: TJvgTabStyle;\r\n FWallpaper: TJvgTabsWallpaper;\r\n FDrawGlyphsOption: TglWallpaperOption;\r\n FLookLikeButtons: Boolean;\r\n FTabsPosition: TglSide;\r\n FOptions: TglTabOptions;\r\n FFontDirection: TglLabelDir;\r\n FOnGetItemColor: TglOnGetItemColorEvent;\r\n FOnGetItemFontColor: TglOnGetItemColorEvent;\r\n FOnGetGradientColors: TglOnGetGradientColors;\r\n FGlyphsChangeLink: TChangeLink;\r\n FDrawTabStr: TDRAWTABSTRUCT;\r\n FGlyphTmpBitmap: TBitmap;\r\n FFontNormal: TFont;\r\n FFontSelected: TFont;\r\n FNotFirst: Boolean;\r\n FTabColors: array [0..100] of TColor;\r\n FSuppressDraw: Boolean;\r\n function GetGlyphIndex(Index: Integer): Integer;\r\n procedure SetGlyphIndex(Index: Integer; ImgIndex: Integer);\r\n procedure SetGlyphs(Value: TImageList);\r\n procedure SetSingleGlyph(Value: Boolean);\r\n procedure SetDrawGlyphsOption(Value: TglWallpaperOption);\r\n procedure SetLookLikeButtons(Value: Boolean);\r\n procedure SetTabsPosition(Value: TglSide);\r\n procedure SetOptions(Value: TglTabOptions);\r\n procedure SetFontDirection(Value: TglLabelDir);\r\n function GetFont: TFont;\r\n procedure SetFont(Value: TFont);\r\n function GetTabColor(Index: Integer): TColor;\r\n procedure SetTabColor(Index: Integer; Value: TColor);\r\n procedure SmthChanged(Sender: TObject);\r\n procedure FontsChanged(Sender: TObject);\r\n procedure DrawItem(lpDrawItemStr: PDrawItemStruct);\r\n procedure CNDrawItem(var Msg: TWMDrawItem); message CN_DRAWITEM;\r\n procedure CMFontChanged(var Msg: TMessage); message CM_FONTCHANGED;\r\n procedure SetTabStyle(const Value: TJvgTabStyle);\r\n procedure SetTabSelectedStyle(const Value: TJvgTabStyle);\r\n protected\r\n procedure GlyphsListChanged(Sender: TObject);\r\n procedure WndProc(var Mesg: TMessage); override;\r\n procedure CreateParams(var Params: TCreateParams); override;\r\n procedure Loaded; override;\r\n procedure Notification(AComponent: TComponent; Operation: TOperation); override;\r\n public\r\n procedure RemakeFonts;\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n property GlyphIndex[Index: Integer]: Integer read GetGlyphIndex write SetGlyphIndex;\r\n property TabColor[Index: Integer]: TColor read GetTabColor write SetTabColor;\r\n // property GlyphState[Index: Integer]: Integer read GetGlyphState write SetGlyphState;\r\n published\r\n property AboutJVCL: TJVCLAboutInfo read FAboutJVCL write FAboutJVCL stored False;\r\n property Glyphs: TImageList read FGlyphs write SetGlyphs;\r\n property SingleGlyph: Boolean read FSingleGlyph write SetSingleGlyph default False;\r\n property TabStyle: TJvgTabStyle read FTabStyle write SetTabStyle;\r\n property TabSelectedStyle: TJvgTabStyle read FTabSelectedStyle write SetTabSelectedStyle;\r\n property Wallpaper: TJvgTabsWallpaper read FWallpaper write FWallpaper;\r\n property DrawGlyphsOption: TglWallpaperOption read FDrawGlyphsOption\r\n write SetDrawGlyphsOption default fwoNone;\r\n property LookLikeButtons: Boolean read FLookLikeButtons write SetLookLikeButtons default False;\r\n property TabsPosition: TglSide read FTabsPosition write SetTabsPosition default fsdTop;\r\n property Options: TglTabOptions read FOptions write SetOptions;\r\n property FontDirection: TglLabelDir read FFontDirection\r\n write SetFontDirection default fldLeftRight;\r\n property Font: TFont read GetFont write SetFont;\r\n property OnGetItemColor: TglOnGetItemColorEvent read FOnGetItemColor write FOnGetItemColor;\r\n property OnGetItemFontColor: TglOnGetItemColorEvent read FOnGetItemFontColor\r\n write FOnGetItemFontColor;\r\n property OnGetGradientColors: TglOnGetGradientColors read FOnGetGradientColors\r\n write FOnGetGradientColors;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvgPage.pas $';\r\n Revision: '$Revision: 13104 $';\r\n Date: '$Date: 2011-09-07 08:50:43 +0200 (mer. 07 sept. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n Math, JvJVCLUtils,\r\n JvgUtils;\r\n\r\nconst\r\n FontDirs: array [TglSide] of TglLabelDir =\r\n (fldDownUp, fldLeftRight, fldUpDown, fldLeftRight);\r\n\r\nconstructor TJvgPageControl.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n\r\n TabStop := False;\r\n FTabStyle := TJvgTabStyle.Create(Self);\r\n with FTabStyle do\r\n begin\r\n BackgrColor := clBtnShadow;\r\n Font.Color := clBtnHighlight;\r\n CaptionHAlign := fhaCenter;\r\n end;\r\n FTabSelectedStyle := TJvgTabStyle.Create(Self);\r\n with FTabSelectedStyle do\r\n begin\r\n BackgrColor := clBtnFace;\r\n Font.Color := clBtnText;\r\n CaptionHAlign := fhaCenter;\r\n end;\r\n\r\n FWallpaper := TJvgTabsWallpaper.Create;\r\n FFontNormal := TFont.Create;\r\n FFontSelected := TFont.Create;\r\n FDrawTabStr.Font_ := TFont.Create;\r\n\r\n FTabStyle.Font.Name := 'Arial';\r\n FTabSelectedStyle.Font.Name := 'Arial';\r\n\r\n FGlyphTmpBitmap := TBitmap.Create;\r\n FGlyphsChangeLink := TChangeLink.Create;\r\n FGlyphsChangeLink.OnChange := GlyphsListChanged;\r\n FDrawTabStr.Gradient := TJvgGradient.Create;\r\n //...set defaults\r\n FSingleGlyph := False;\r\n FDrawGlyphsOption := fwoNone;\r\n FTabsPosition := fsdTop;\r\n FOptions := [ftoAutoFontDirection, ftoExcludeGlyphs];\r\n FFontDirection := fldLeftRight;\r\n FTabStyle.OnChanged := SmthChanged;\r\n FTabSelectedStyle.OnChanged := SmthChanged;\r\n FTabStyle.OnFontChanged := FontsChanged;\r\n FTabSelectedStyle.OnFontChanged := FontsChanged;\r\n FWallpaper.OnChanged := SmthChanged;\r\n FillChar(FTabColors, SizeOf(FTabColors), $FF);\r\nend;\r\n\r\ndestructor TJvgPageControl.Destroy;\r\nbegin\r\n FTabStyle.Free;\r\n FTabSelectedStyle.Free;\r\n FGlyphTmpBitmap.Free;\r\n FWallpaper.Free;\r\n FGlyphsChangeLink.Free;\r\n FFontNormal.Free;\r\n FFontSelected.Free;\r\n FDrawTabStr.Font_.Free;\r\n if Assigned(FDrawTabStr.Gradient) then\r\n FDrawTabStr.Gradient.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvgPageControl.SmthChanged;\r\nbegin\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvgPageControl.FontsChanged;\r\nbegin\r\n RemakeFonts;\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvgPageControl.CreateParams(var Params: TCreateParams);\r\nconst\r\n PosStyles: array [TglSide] of DWORD =\r\n (TCS_VERTICAL, 0, TCS_VERTICAL or TCS_RIGHT, TCS_BOTTOM);\r\n //or TCS_SCROLLOPPOSITE or TCS_BUTTONS\r\nbegin\r\n inherited CreateParams(Params);\r\n with Params do\r\n begin\r\n if LookLikeButtons then\r\n Style := Style or TCS_BUTTONS;\r\n Style := Style or TCS_OWNERDRAWFIXED or PosStyles[FTabsPosition];\r\n end;\r\nend;\r\n\r\nprocedure TJvgPageControl.Loaded;\r\nbegin\r\n inherited Loaded;\r\n RemakeFonts;\r\n if Assigned(Wallpaper.Bitmap) and (not Wallpaper.Bitmap.Empty) then\r\n Wallpaper.Bmp := Wallpaper.Bitmap;\r\nend;\r\n\r\nprocedure TJvgPageControl.Notification(AComponent: TComponent;\r\n Operation: TOperation);\r\nbegin\r\n inherited Notification(AComponent, Operation);\r\n if (Operation = opRemove) then\r\n if Assigned(Wallpaper) and (AComponent = Wallpaper.Image) then\r\n Wallpaper.Image := nil\r\n else if (AComponent = Glyphs) then\r\n Glyphs := nil;\r\n\r\nend;\r\n\r\nprocedure TJvgPageControl.CNDrawItem(var Msg: TWMDrawItem);\r\nbegin\r\n DrawItem(Msg.DrawItemStruct);\r\nend;\r\n\r\nprocedure TJvgPageControl.WndProc(var Mesg: TMessage);\r\nvar\r\n GlyphID: Integer;\r\nbegin\r\n inherited WndProc(Mesg);\r\n with Mesg do\r\n case Msg of\r\n TCM_INSERTITEM:\r\n begin\r\n Result := 0;\r\n if not Assigned(FGlyphs) then\r\n Exit;\r\n GlyphID := -1;\r\n if FSingleGlyph then\r\n GlyphID := 0\r\n else\r\n if WParam < Windows.WPARAM(FGlyphs.Count) then\r\n GlyphID := WParam;\r\n if GlyphID = -1 then\r\n Exit;\r\n TTCItem(Pointer(Mesg.LParam)^).iImage := GlyphID;\r\n TTCItem(Pointer(Mesg.LParam)^).mask := TCIF_IMAGE;\r\n SendMessage(Handle, TCM_SETITEM, WParam, LParam);\r\n end;\r\n TCM_DELETEITEM:\r\n ;\r\n TCM_DELETEALLITEMS:\r\n ;\r\n end;\r\nend;\r\n\r\nprocedure TJvgPageControl.GlyphsListChanged(Sender: TObject);\r\nbegin\r\n if HandleAllocated then\r\n SendMessage(Handle, TCM_SETIMAGELIST, 0, LPARAM(TImageList(Sender).Handle));\r\nend;\r\n\r\nprocedure TJvgPageControl.DrawItem(lpDrawItemStr: PDrawItemStruct);\r\nvar\r\n FontColor: TColor;\r\nbegin\r\n if FSuppressDraw then\r\n Exit;\r\n with lpDrawItemStr^ do\r\n if CtlType = ODT_TAB then\r\n begin\r\n //fLoaded:=True; Options:=NewOptions;\r\n FDrawTabStr.lpDrawItemStr := lpDrawItemStr;\r\n FDrawTabStr.Caption := Tabs[ItemID];\r\n\r\n if GlyphIndex[ItemID] <> -1 then\r\n begin\r\n FGlyphs.GetBitmap(GlyphIndex[ItemID], FGlyphTmpBitmap);\r\n FDrawTabStr.Glyph := FGlyphTmpBitmap;\r\n end\r\n else\r\n FDrawTabStr.Glyph := nil;\r\n\r\n if (itemState and ODS_DISABLED) <> 0 then\r\n begin\r\n FDrawTabStr.BoxStyle := FTabStyle;\r\n FDrawTabStr.Font_.Assign(FFontNormal);\r\n end\r\n else\r\n if (itemState and ODS_SELECTED) <> 0 then\r\n begin\r\n FDrawTabStr.BoxStyle := FTabSelectedStyle;\r\n FDrawTabStr.Font_.Assign(FFontSelected);\r\n end\r\n else\r\n begin\r\n FDrawTabStr.BoxStyle := FTabStyle;\r\n FDrawTabStr.Font_.Assign(FFontNormal);\r\n end;\r\n\r\n if Assigned(OnGetItemFontColor) then\r\n begin\r\n OnGetItemFontColor(Self, ItemID, FontColor);\r\n FDrawTabStr.Font_.Color := FontColor;\r\n end;\r\n\r\n FDrawTabStr.GlyphOption := FDrawGlyphsOption;\r\n FDrawTabStr.Wallpaper := FWallpaper;\r\n FDrawTabStr.ClientR := ClientRect;\r\n FDrawTabStr.TabsCount := Tabs.Count;\r\n FDrawTabStr.fButton := LookLikeButtons;\r\n FDrawTabStr.Position := TabsPosition;\r\n FDrawTabStr.Options := Options;\r\n FDrawTabStr.FontDirection := FontDirection;\r\n\r\n if Assigned(OnGetGradientColors) then\r\n OnGetGradientColors(Self, ItemID, FDrawTabStr.Gradient);\r\n\r\n if Assigned(OnGetItemColor) then\r\n OnGetItemColor(Self, ItemID, FDrawTabStr.BackgrColor_)\r\n else\r\n if FTabColors[ItemID] <> -1 then\r\n FDrawTabStr.BackgrColor_ := FTabColors[ItemID]\r\n else\r\n FDrawTabStr.BackgrColor_ := FDrawTabStr.BoxStyle.BackgrColor;\r\n\r\n if Style = tsFlatButtons then\r\n FDrawTabStr.FlatButtons := True;\r\n\r\n DrawOwnTab(FDrawTabStr); //FWallpaper.IncludeBevels\r\n end;\r\nend;\r\n\r\nprocedure TJvgPageControl.CMFontChanged(var Msg: TMessage);\r\nbegin\r\n inherited;\r\n if ftoInheriteTabFonts in Options then\r\n begin\r\n FTabStyle.Font.Assign(inherited Font);\r\n FTabSelectedStyle.Font.Assign(inherited Font);\r\n // Disabled.Assign(inherited Font);\r\n RemakeFonts;\r\n end;\r\nend;\r\n\r\nprocedure TJvgPageControl.RemakeFonts;\r\nconst\r\n RadianEscapments: array [TglLabelDir] of Integer =\r\n (0, -1800, -900, 900);\r\nbegin\r\n if csReading in ComponentState then\r\n Exit;\r\n if FNotFirst then\r\n DeleteObject(FTabStyle.Font.Handle);\r\n FNotFirst := True;\r\n\r\n FFontNormal.Handle := CreateRotatedFont(FTabStyle.Font,\r\n RadianEscapments[FFontDirection]);\r\n FFontNormal.Color := FTabStyle.Font.Color;\r\n FFontSelected.Handle := CreateRotatedFont(FTabSelectedStyle.Font,\r\n RadianEscapments[FFontDirection]);\r\n FFontSelected.Color := FTabSelectedStyle.Font.Color;\r\nend;\r\n\r\nprocedure TJvgPageControl.SetGlyphs(Value: TImageList);\r\nvar\r\n I: Integer;\r\n B: Boolean;\r\nbegin\r\n ReplaceImageListReference(Self, Value, TCustomImageList(FGlyphs), FGlyphsChangeLink);\r\n if Assigned(FGlyphs) then\r\n begin\r\n SendMessage(Handle, TCM_SETIMAGELIST, 0, LPARAM(FGlyphs.Handle));\r\n B := True;\r\n for I := 0 to Min(Tabs.Count - 1, FGlyphs.Count - 1) do\r\n if GlyphIndex[I] <> -1 then\r\n begin\r\n B := False;\r\n Break;\r\n end;\r\n if B then\r\n SetSingleGlyph(FSingleGlyph);\r\n end\r\n else\r\n SendMessage(Handle, TCM_SETIMAGELIST, 0, 0);\r\nend;\r\n\r\nprocedure TJvgPageControl.SetGlyphIndex(Index: Integer; ImgIndex: Integer);\r\nvar\r\n R: TRect;\r\n Item: TTCItem;\r\nbegin\r\n Item.iImage := ImgIndex;\r\n Item.mask := TCIF_IMAGE;\r\n SendMessage(Handle, TCM_SETITEM, Index, LPARAM(@Item));\r\n SendMessage(Handle, TCM_GETITEMRECT, Index, LPARAM(@R));\r\n InvalidateRect(Handle, @R, True);\r\nend;\r\n\r\nfunction TJvgPageControl.GetGlyphIndex(Index: Integer): Integer;\r\nvar\r\n ImgItem: TTCItem;\r\nbegin\r\n if Assigned(FGlyphs) then\r\n begin\r\n ImgItem.mask := TCIF_IMAGE;\r\n SendMessage(Handle, TCM_GETITEM, Index, LPARAM(@ImgItem));\r\n Result := ImgItem.iImage;\r\n end\r\n else\r\n Result := -1;\r\nend;\r\n\r\nprocedure TJvgPageControl.SetSingleGlyph(Value: Boolean);\r\nvar\r\n I: Integer;\r\nbegin\r\n FSingleGlyph := Value;\r\n if (Tabs = nil) or (FGlyphs = nil) then\r\n Exit;\r\n if FSingleGlyph then\r\n for I := 0 to Tabs.Count - 1 do\r\n GlyphIndex[I] := 0\r\n else\r\n for I := 0 to Tabs.Count - 1 do\r\n if FGlyphs.Count >= I then\r\n GlyphIndex[I] := I\r\n else\r\n Break;\r\nend;\r\n\r\nprocedure TJvgPageControl.SetDrawGlyphsOption(Value: TglWallpaperOption);\r\nbegin\r\n if FDrawGlyphsOption <> Value then\r\n begin\r\n FDrawGlyphsOption := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvgPageControl.SetLookLikeButtons(Value: Boolean);\r\nbegin\r\n if FLookLikeButtons <> Value then\r\n begin\r\n FLookLikeButtons := Value;\r\n RecreateWnd;\r\n end;\r\nend;\r\n\r\nprocedure TJvgPageControl.SetTabsPosition(Value: TglSide);\r\nbegin\r\n if FTabsPosition <> Value then\r\n begin\r\n FTabsPosition := Value;\r\n RecreateWnd;\r\n if (ftoAutoFontDirection in FOptions) and not (csLoading in ComponentState) then\r\n FontDirection := FontDirs[TabsPosition];\r\n end;\r\nend;\r\n\r\nprocedure TJvgPageControl.SetOptions(Value: TglTabOptions);\r\nbegin\r\n if FOptions <> Value then\r\n begin\r\n FOptions := Value;\r\n if ftoAutoFontDirection in FOptions then\r\n FontDirection := FontDirs[TabsPosition];\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvgPageControl.SetFontDirection(Value: TglLabelDir);\r\nbegin\r\n if FFontDirection <> Value then\r\n begin\r\n FFontDirection := Value;\r\n RemakeFonts;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nfunction TJvgPageControl.GetFont: TFont;\r\nbegin\r\n Result := inherited Font;\r\nend;\r\n\r\nprocedure TJvgPageControl.SetFont(Value: TFont);\r\nbegin\r\n inherited Font := Value;\r\n if ftoInheriteTabFonts in Options then\r\n begin\r\n FTabStyle.Font.Assign(inherited Font);\r\n FTabSelectedStyle.Font.Assign(inherited Font);\r\n end;\r\nend;\r\n\r\nfunction TJvgPageControl.GetTabColor(Index: Integer): TColor;\r\nbegin\r\n if Index < 100 then\r\n Result := FTabColors[Index]\r\n else\r\n Result := -1;\r\nend;\r\n\r\nprocedure TJvgPageControl.SetTabColor(Index: Integer; Value: TColor);\r\nvar\r\n TCItem: TTCItem;\r\nbegin\r\n if (Index < 100) and (TabColor[Index] <> Value) then\r\n FTabColors[Index] := Value\r\n else\r\n Exit;\r\n if not FSuppressDraw then\r\n begin\r\n // Repaint;\r\n TCItem.mask := TCIF_TEXT;\r\n TCItem.pszText := PChar(Tabs[Index]);\r\n SendMessage(Handle, TCM_SETITEM, Index, LPARAM(@TCItem));\r\n end;\r\nend;\r\n\r\nprocedure TJvgPageControl.SetTabStyle(const Value: TJvgTabStyle);\r\nbegin\r\n FTabStyle := Value;\r\n RemakeFonts;\r\nend;\r\n\r\nprocedure TJvgPageControl.SetTabSelectedStyle(const Value: TJvgTabStyle);\r\nbegin\r\n FTabSelectedStyle := Value;\r\n RemakeFonts;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvgProgress.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvgProgress.PAS, released on 2003-01-15.\r\n\r\nThe Initial Developer of the Original Code is Andrey V. Chudin, [chudin att yandex dott ru]\r\nPortions created by Andrey V. Chudin are Copyright (C) 2003 Andrey V. Chudin.\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\nMichael Beck [mbeck att bigfoot dott com].\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvgProgress.pas 13104 2011-09-07 06:50:43Z obones $\r\n\r\nunit JvgProgress;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, Messages, Classes, Controls, Graphics, SysUtils, ExtCtrls, ImgList,\r\n JvComponent, JvThemes,\r\n JvgTypes, JvgCommClasses, JvgUtils, JvExControls;\r\n\r\ntype\r\n TJvgProgress = class(TJvGraphicControl, IJvDenySubClassing)\r\n private\r\n FBevelInner: TPanelBevel;\r\n FBevelOuter: TPanelBevel;\r\n FBevelBold: Boolean;\r\n FColors: TJvgSimleLabelColors;\r\n FGradient: TJvgGradient;\r\n FGradientBack: TJvgGradient;\r\n FPercent: Integer;\r\n FCaptionAlignment: TAlignment;\r\n FCaptionDirection: TglLabelDir;\r\n FCaptionStyle: TglTextStyle;\r\n FStep: Integer;\r\n FInterspace: Integer;\r\n FOptions: TglProgressOptions;\r\n FImage: TBitmap;\r\n FBackImage: TBitmap;\r\n FNeedRebuildBackground: Boolean;\r\n procedure SetBevelInner(Value: TPanelBevel);\r\n procedure SetBevelOuter(Value: TPanelBevel);\r\n procedure SetBevelBold(Value: Boolean);\r\n procedure SetPercent(Value: Integer);\r\n procedure SetCaptionAlignment(Value: TAlignment);\r\n procedure SetCaptionDirection(Value: TglLabelDir);\r\n procedure SetCaptionStyle(Value: TglTextStyle);\r\n procedure SetStep(Value: Integer);\r\n procedure SetInterspace(Value: Integer);\r\n procedure SetOptions(Value: TglProgressOptions);\r\n procedure OnSmthChanged(Sender: TObject);\r\n protected\r\n procedure TextChanged; override;\r\n procedure Loaded; override;\r\n procedure Paint; override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n published\r\n property BevelInner: TPanelBevel read FBevelInner write SetBevelInner default bvLowered;\r\n property BevelOuter: TPanelBevel read FBevelOuter write SetBevelOuter default bvNone;\r\n property BevelBold: Boolean read FBevelBold write SetBevelBold default False;\r\n property Colors: TJvgSimleLabelColors read FColors write FColors;\r\n property Gradient: TJvgGradient read FGradient write FGradient;\r\n property GradientBack: TJvgGradient read FGradientBack write FGradientBack;\r\n property Percent: Integer read FPercent write SetPercent;\r\n property CaptionAlignment: TAlignment read FCaptionAlignment write SetCaptionAlignment default taLeftJustify;\r\n property CaptionDirection: TglLabelDir read FCaptionDirection write SetCaptionDirection default fldLeftRight;\r\n property CaptionStyle: TglTextStyle read FCaptionStyle write SetCaptionStyle default fstShadow;\r\n property Step: Integer read FStep write SetStep default 3;\r\n property Interspace: Integer read FInterspace write SetInterspace default 1;\r\n property Options: TglProgressOptions read FOptions write SetOptions;\r\n property Anchors;\r\n property Align;\r\n property Caption;\r\n property Color default clBlack;\r\n property DragCursor;\r\n property DragMode;\r\n property Font;\r\n property Height default 15;\r\n property ParentShowHint;\r\n property ShowHint;\r\n property Visible;\r\n property Width default 150;\r\n property OnClick;\r\n property OnDblClick;\r\n property OnDragDrop;\r\n property OnDragOver;\r\n property OnEndDrag;\r\n property OnMouseDown;\r\n property OnMouseMove;\r\n property OnMouseUp;\r\n property OnStartDrag;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvgProgress.pas $';\r\n Revision: '$Revision: 13104 $';\r\n Date: '$Date: 2011-09-07 08:50:43 +0200 (mer. 07 sept. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n JvResources;\r\n\r\nconstructor TJvgProgress.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n ControlStyle := [csOpaque, csDoubleClicks];\r\n FColors := TJvgSimleLabelColors.Create;\r\n FGradientBack := TJvgGradient.Create;\r\n FGradient := TJvgGradient.Create;\r\n if csDesigning in ComponentState then\r\n with FColors do\r\n begin\r\n FGradient.Orientation := fgdVertical;\r\n FGradientBack.Orientation := fgdVertical;\r\n FGradient.Active := True;\r\n FGradientBack.Active := True;\r\n FGradient.FromColor := clGreen;\r\n FGradient.ToColor := clYellow;\r\n FGradientBack.FromColor := 0;\r\n FGradientBack.ToColor := clGreen;\r\n FGradient.PercentFilling := FPercent;\r\n Delineate := clGray;\r\n Shadow := 0;\r\n Background := 0;\r\n Caption := RsProgressCaption;\r\n end;\r\n FColors.OnChanged := OnSmthChanged;\r\n FGradientBack.OnChanged := OnSmthChanged;\r\n FGradient.OnChanged := OnSmthChanged;\r\n FImage := TBitmap.Create;\r\n FBackImage := TBitmap.Create;\r\n Width := 150;\r\n Height := 15;\r\n FCaptionDirection := fldLeftRight;\r\n FCaptionAlignment := taLeftJustify;\r\n FStep := 3;\r\n FInterspace := 1;\r\n FCaptionStyle := fstShadow;\r\n FCaptionAlignment := taCenter;\r\n Font.Color := clWhite;\r\n FBevelInner := bvLowered;\r\n FBevelOuter := bvNone;\r\n Color := clBlack;\r\nend;\r\n\r\ndestructor TJvgProgress.Destroy;\r\nbegin\r\n FGradient.Free;\r\n FGradientBack.Free;\r\n FColors.Free;\r\n FBackImage.Free;\r\n FImage.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvgProgress.Loaded;\r\nbegin\r\n inherited Loaded;\r\n { FImage.Width := Width;\r\n FImage.Height := Height;\r\n FBackImage.Width := Width;\r\n FBackImage.Height := Height;\r\n if fpoTransparent in Options then\r\n GetParentImageRect(Self, Bounds(Left, Top, Width, Height),\r\n FImage.Canvas.Handle );}\r\nend;\r\n\r\nprocedure TJvgProgress.TextChanged;\r\nbegin\r\n Repaint;\r\nend;\r\n\r\nprocedure TJvgProgress.Paint;\r\nconst\r\n ShadowDepth = 2;\r\nvar\r\n R: TRect;\r\n I, X, X2, Y: Integer;\r\n Size, TextSize: TSize;\r\n Capt: string;\r\nbegin\r\n if (FImage.Width <> Width) or (FImage.Height <> Height) then\r\n begin\r\n FImage.Width := Width;\r\n FImage.Height := Height;\r\n FBackImage.Width := Width;\r\n FBackImage.Height := Height;\r\n FNeedRebuildBackground := True;\r\n end;\r\n R := ClientRect;\r\n if (fpoTransparent in Options) and FNeedRebuildBackground then\r\n begin\r\n (*{$IFDEF JVCLThemesEnabled}\r\n if ThemeServices.ThemesEnabled then\r\n PerformEraseBackground(Self, FBackImage.Canvas.Handle)\r\n else\r\n {$ENDIF JVCLThemesEnabled}\r\n GetParentImageRect(Self, Bounds(Left, Top, Width, Height),\r\n FBackImage.Canvas.Handle);*)\r\n\r\n FBackImage.Canvas.Brush.Color := Parent.Brush.Color;\r\n FBackImage.Canvas.FillRect(R);\r\n FNeedRebuildBackground := False;\r\n end;\r\n BitBlt(FImage.Canvas.Handle, 0, 0, Width, Height,\r\n FBackImage.Canvas.Handle, 0, 0, SRCCOPY);\r\n with FImage.Canvas do\r\n begin\r\n Dec(R.Bottom);\r\n Dec(R.Right);\r\n R := DrawBoxEx(Handle, R, [fsdLeft, fsdTop, fsdRight, fsdBottom],\r\n FBevelInner, FBevelOuter,\r\n FBevelBold, Colors.Background, fpoTransparent in Options);\r\n // PercentWidth := Round(Width * Percent / 100);\r\n // PercentWidth := Width;\r\n Brush.Color := Colors.Background;\r\n Inc(R.Top);\r\n if Percent > 0 then\r\n begin\r\n GradientBox(Handle, R, FGradientBack, Integer(psSolid), 1);\r\n GradientBox(Handle, R, FGradient, Integer(psSolid), 1);\r\n X := R.Left;\r\n if not (fpoTransparent in Options) then\r\n for I := R.Left to Width div (FStep + FInterspace) + 1 do\r\n begin\r\n X2 := X + FInterspace;\r\n if X2 > R.Right then\r\n if X < R.Right then\r\n X2 := R.Right\r\n else\r\n Break;\r\n FillRect(Rect(X, R.Top, X2, R.Bottom));\r\n Inc(X, FStep + FInterspace);\r\n end;\r\n end;\r\n //...CALC POSITION\r\n try\r\n Capt := Format(Caption, [Percent]);\r\n except\r\n Capt := Caption;\r\n end;\r\n GetTextExtentPoint32(Self.Canvas.Handle, PChar(Capt), Length(Capt), Size);\r\n\r\n X := 2;\r\n Y := 0;\r\n // Size.cx:=Size.cx+2+trunc(Size.cx*0.01);\r\n // Size.cy := Size.cy+2;\r\n TextSize := Size;\r\n if (FCaptionStyle = fstShadow) or (FCaptionStyle = fstVolumetric) then\r\n begin\r\n Inc(Size.cy, ShadowDepth);\r\n Inc(Size.cx, ShadowDepth);\r\n end;\r\n if fpoDelineatedText in FOptions then\r\n begin\r\n Inc(Size.cy, 2);\r\n Inc(Size.cx, 2);\r\n end;\r\n\r\n case FCaptionDirection of\r\n fldLeftRight:\r\n begin\r\n case FCaptionAlignment of\r\n taCenter:\r\n X := (Width - Size.cx) div 2;\r\n taRightJustify:\r\n X := Width - Size.cx;\r\n end;\r\n Y := (Height - Size.cy) div 2;\r\n end;\r\n fldRightLeft:\r\n begin\r\n case FCaptionAlignment of\r\n taCenter:\r\n X := (Width + Size.cx) div 2;\r\n taLeftJustify:\r\n X := Width - (Size.cx - TextSize.cx) - 2;\r\n else\r\n X := TextSize.cx;\r\n end;\r\n Y := TextSize.cy;\r\n end;\r\n fldDownUp:\r\n case FCaptionAlignment of\r\n taCenter:\r\n Y := (Height + TextSize.cx - (Size.cy - TextSize.cy)) div 2;\r\n taRightJustify:\r\n Y := TextSize.cx - 4;\r\n else\r\n Y := Height - (Size.cy - TextSize.cy) - 2;\r\n end;\r\n fldUpDown:\r\n begin\r\n case FCaptionAlignment of\r\n taCenter:\r\n Y := (Height - Size.cx) div 2;\r\n taRightJustify:\r\n Y := Height - Size.cx;\r\n else\r\n Y := 1;\r\n end;\r\n X := TextSize.cy;\r\n end;\r\n end;\r\n //...CALC POSITION end\r\n\r\n ExtTextOutExt(Handle, X, Y, GetClientRect, Capt,\r\n FCaptionStyle, fpoDelineatedText in FOptions,\r\n False, Self.Font.Color, FColors.Delineate,\r\n FColors.Highlight, FColors.Shadow,\r\n nil, nil, Self.Font);\r\n end;\r\n FImage.Transparent := fpoTransparent in FOptions;\r\n FImage.TransparentColor := Parent.Brush.Color;\r\n Canvas.Draw(0, 0, FImage);\r\n {$IFDEF JVCLThemesEnabled}\r\n if BevelBold and ((BevelInner <> bvNone) or (BevelOuter <> bvNone)) and\r\n ThemeServices.{$IFDEF RTL230_UP}Enabled{$ELSE}ThemesEnabled{$ENDIF RTL230_UP} then\r\n DrawThemedBorder(Self);\r\n {$ENDIF JVCLThemesEnabled}\r\nend;\r\n\r\nprocedure TJvgProgress.OnSmthChanged(Sender: TObject);\r\nbegin\r\n Repaint;\r\nend;\r\n\r\nprocedure TJvgProgress.SetBevelOuter(Value: TPanelBevel);\r\nbegin\r\n FBevelOuter := Value;\r\n Repaint;\r\nend;\r\n\r\nprocedure TJvgProgress.SetBevelInner(Value: TPanelBevel);\r\nbegin\r\n FBevelInner := Value;\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvgProgress.SetBevelBold(Value: Boolean);\r\nbegin\r\n FBevelBold := Value;\r\n Repaint;\r\nend;\r\n\r\nprocedure TJvgProgress.SetPercent(Value: Integer);\r\nbegin\r\n if (FPercent <> Value) and (Value >= 0) and (Value <= 100) then\r\n begin\r\n FPercent := Value;\r\n FGradient.PercentFilling := FPercent;\r\n end;\r\nend;\r\n\r\nprocedure TJvgProgress.SetCaptionAlignment(Value: TAlignment);\r\nbegin\r\n if FCaptionAlignment <> Value then\r\n begin\r\n FCaptionAlignment := Value;\r\n Repaint;\r\n end;\r\nend;\r\n\r\nprocedure TJvgProgress.SetCaptionDirection(Value: TglLabelDir);\r\nbegin\r\n if FCaptionDirection <> Value then\r\n begin\r\n FCaptionDirection := Value;\r\n Repaint;\r\n end;\r\nend;\r\n\r\nprocedure TJvgProgress.SetCaptionStyle(Value: TglTextStyle);\r\nbegin\r\n if FCaptionStyle <> Value then\r\n begin\r\n FCaptionStyle := Value;\r\n Repaint;\r\n end;\r\nend;\r\n\r\nprocedure TJvgProgress.SetStep(Value: Integer);\r\nbegin\r\n if FStep <> Value then\r\n begin\r\n FStep := Value;\r\n Repaint;\r\n end;\r\nend;\r\n\r\nprocedure TJvgProgress.SetInterspace(Value: Integer);\r\nbegin\r\n if FInterspace <> Value then\r\n begin\r\n FInterspace := Value;\r\n Repaint;\r\n end;\r\nend;\r\n\r\nprocedure TJvgProgress.SetOptions(Value: TglProgressOptions);\r\nbegin\r\n FOptions := Value;\r\n if fpoTransparent in FOptions then\r\n begin\r\n ControlStyle := ControlStyle - [csOpaque];\r\n IncludeThemeStyle(Self, [csParentBackground]);\r\n end\r\n else\r\n begin\r\n ControlStyle := ControlStyle + [csOpaque];\r\n ExcludeThemeStyle(Self, [csParentBackground]);\r\n end;\r\n Repaint;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvgQPrintPreviewForm.dfm", "content": "object JvgPrintPreview: TJvgPrintPreview\r\n Left = 292\r\n Top = 149\r\n ClientWidth = 495\r\n ClientHeight = 451\r\n Caption = 'fPrintPreview'\r\n Color = clBtnFace\r\n Font.Charset = DEFAULT_CHARSET\r\n Font.Color = clWindowText\r\n Font.Height = -11\r\n Font.Name = 'MS Sans Serif'\r\n Font.Style = []\r\n OldCreateOrder = False\r\n Position = poScreenCenter\r\n WindowState = wsMaximized\r\n OnCreate = FormCreate\r\n PixelsPerInch = 96\r\n TextHeight = 13\r\n object Panel2: TPanel\r\n Left = 0\r\n Top = 0\r\n Width = 495\r\n Height = 26\r\n Align = alTop\r\n BevelOuter = bvNone\r\n Caption = 'Panel2'\r\n TabOrder = 0\r\n object Shape1: TShape\r\n Left = 0\r\n Top = 25\r\n Width = 495\r\n Height = 1\r\n Align = alBottom\r\n Pen.Color = clBtnShadow\r\n end\r\n object ToolBar1: TToolBar\r\n Left = 0\r\n Top = 0\r\n Width = 404\r\n Height = 25\r\n Align = alClient\r\n ButtonHeight = 24\r\n ButtonWidth = 27\r\n Caption = 'ToolBar1'\r\n EdgeBorders = [ebLeft, ebTop, ebRight, ebBottom]\r\n EdgeInner = esNone\r\n EdgeOuter = esNone\r\n Flat = True\r\n Images = ImageList4\r\n TabOrder = 0\r\n Transparent = True\r\n object tbFirst: TToolButton\r\n Left = 0\r\n Top = 0\r\n Cursor = crHandPoint\r\n Hint = 'First page'\r\n Caption = 'tbFirst'\r\n ImageIndex = 2\r\n ParentShowHint = False\r\n ShowHint = True\r\n OnClick = tbFirstClick\r\n end\r\n object ToolButton1: TToolButton\r\n Left = 27\r\n Top = 0\r\n Width = 23\r\n Caption = 'ToolButton1'\r\n ImageIndex = 3\r\n Style = tbsSeparator\r\n end\r\n object tbPrior: TToolButton\r\n Left = 50\r\n Top = 0\r\n Cursor = crHandPoint\r\n Hint = 'Previous page'\r\n Caption = 'tbPrior'\r\n Enabled = False\r\n ImageIndex = 0\r\n ParentShowHint = False\r\n ShowHint = True\r\n OnClick = tbPriorClick\r\n end\r\n object tbNext: TToolButton\r\n Left = 77\r\n Top = 0\r\n Cursor = crHandPoint\r\n Hint = 'Next page'\r\n Caption = 'tbNext'\r\n ImageIndex = 1\r\n ParentShowHint = False\r\n ShowHint = True\r\n OnClick = tbNextClick\r\n end\r\n object ToolButton2: TToolButton\r\n Left = 104\r\n Top = 0\r\n Width = 24\r\n Caption = 'ToolButton2'\r\n ImageIndex = 2\r\n Style = tbsSeparator\r\n end\r\n object ToolButton4: TToolButton\r\n Left = 128\r\n Top = 0\r\n Cursor = crHandPoint\r\n Hint = 'Last page'\r\n Caption = 'ToolButton4'\r\n ImageIndex = 3\r\n ParentShowHint = False\r\n ShowHint = True\r\n OnClick = ToolButton4Click\r\n end\r\n object ToolButton5: TToolButton\r\n Left = 155\r\n Top = 0\r\n Width = 21\r\n Caption = 'ToolButton5'\r\n ImageIndex = 4\r\n Style = tbsSeparator\r\n end\r\n object tbPrinterSetup: TToolButton\r\n Left = 176\r\n Top = 0\r\n Cursor = crHandPoint\r\n Hint = 'Printer setup'\r\n Caption = 'tbPrinterSetup'\r\n ImageIndex = 4\r\n ParentShowHint = False\r\n ShowHint = True\r\n OnClick = tbPrinterSetupClick\r\n end\r\n object tbPrintRange: TToolButton\r\n Left = 203\r\n Top = 0\r\n Cursor = crHandPoint\r\n Hint = 'Print current page'\r\n Caption = 'tbPrintRange'\r\n ImageIndex = 5\r\n ParentShowHint = False\r\n ShowHint = True\r\n OnClick = tbPrintRangeClick\r\n end\r\n object tbPrint: TToolButton\r\n Left = 230\r\n Top = 0\r\n Cursor = crHandPoint\r\n Hint = 'Print all pages'\r\n Caption = 'tbPrint'\r\n ImageIndex = 6\r\n ParentShowHint = False\r\n ShowHint = True\r\n OnClick = tbPrintClick\r\n end\r\n object ToolButton8: TToolButton\r\n Left = 0\r\n Top = 0\r\n Width = 26\r\n Caption = 'ToolButton8'\r\n ImageIndex = 6\r\n Wrap = True\r\n Style = tbsSeparator\r\n end\r\n object tbLoad: TToolButton\r\n Left = 0\r\n Top = 50\r\n Cursor = crHandPoint\r\n Hint = 'Load report from file'\r\n Caption = 'tbLoad'\r\n ImageIndex = 7\r\n ParentShowHint = False\r\n ShowHint = True\r\n OnClick = tbLoadClick\r\n end\r\n object tbSave: TToolButton\r\n Left = 27\r\n Top = 50\r\n Cursor = crHandPoint\r\n Hint = 'Save report to file'\r\n Caption = 'tbSave'\r\n ImageIndex = 8\r\n ParentShowHint = False\r\n ShowHint = True\r\n OnClick = tbSaveClick\r\n end\r\n object tbExportExcel: TToolButton\r\n Left = 54\r\n Top = 50\r\n Cursor = crHandPoint\r\n Hint = 'Export report to MS Excel'\r\n Caption = 'tbExportExcel'\r\n ImageIndex = 9\r\n ParentShowHint = False\r\n ShowHint = True\r\n OnClick = tbExportExcelClick\r\n end\r\n object cbDuplex: TCheckBox\r\n Left = 81\r\n Top = 50\r\n Width = 130\r\n Height = 24\r\n Alignment = taLeftJustify\r\n Caption = 'Print double-sided'\r\n TabOrder = 0\r\n OnClick = cbDuplexClick\r\n end\r\n end\r\n object Panel1: TPanel\r\n Left = 404\r\n Top = 0\r\n Width = 91\r\n Height = 25\r\n Align = alRight\r\n BevelOuter = bvNone\r\n TabOrder = 1\r\n end\r\n end\r\n object SB: TStatusBar\r\n Left = 0\r\n Top = 431\r\n Width = 495\r\n Height = 19\r\n Panels = <\r\n item\r\n Width = 100\r\n end>\r\n SimplePanel = False\r\n end\r\n object PB: TProgressBar\r\n Left = 0\r\n Top = 406\r\n Width = 471\r\n Height = 17\r\n Anchors = [akLeft, akRight, akBottom]\r\n Min = 0\r\n Max = 100\r\n \r\n Visible = False\r\n end\r\n object QRPreview1: TQRPreview\r\n Left = 0\r\n Top = 26\r\n Width = 495\r\n Height = 405\r\n HorzScrollBar.Tracking = True\r\n VertScrollBar.Tracking = True\r\n Align = alClient\r\n TabOrder = 3\r\n PageNumber = 1\r\n Zoom = 100\r\n end\r\n object ImageList4: TImageList\r\n Left = 8\r\n Top = 32\r\n Bitmap = {\r\n 494C01010A000E00040010001000FFFFFFFFFF10FFFFFFFFFFFFFFFF424D3600\r\n 0000000000003600000028000000400000004000000001002000000000000040\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000009C9C00009C\r\n 9C00000000000000000000000000000000000000000000000000CECECE00CECE\r\n CE0000000000009C9C0000000000000000000000000000000000000000000000\r\n 00000000000000000000CECECE00CECECE000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000009C9C00009C\r\n 9C00000000000000000000000000000000000000000000000000CECECE00CECE\r\n CE0000000000009C9C0000000000000000000000000000000000000000000000\r\n 0000CECECE0000000000CECECE00FFFFFF00CECECE00CECECE00000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000009C9C00009C\r\n 9C00000000000000000000000000000000000000000000000000CECECE00CECE\r\n CE0000000000009C9C0000000000000000000000000000000000CECECE000000\r\n 0000CECECE00000000009C9C9C00009C9C009C9C9C00CECECE00CECECE000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000009C9C00009C\r\n 9C00000000000000000000000000000000000000000000000000000000000000\r\n 000000000000009C9C0000000000000000000000000000000000CECECE000000\r\n 0000CECECE0000000000CECECE0000009C00000000009C9C9C00CECECE000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000009C9C00009C\r\n 9C00009C9C00009C9C00009C9C00009C9C00009C9C00009C9C00009C9C00009C\r\n 9C00009C9C00009C9C0000000000000000000000000000000000CECECE000000\r\n 0000CECECE0000000000FFFFFF00CECECE009C9C9C00009C9C00000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000009C9C00009C\r\n 9C00000000000000000000000000000000000000000000000000000000000000\r\n 0000009C9C00009C9C0000000000000000000000000000000000CECECE000000\r\n 0000CECECE0000000000CECECE00CECECE00CECECE009C0000009C9C00000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000009C9C000000\r\n 0000CECECE00CECECE00CECECE00CECECE00CECECE00CECECE00CECECE00CECE\r\n CE0000000000009C9C0000000000000000000000000000000000CECECE000000\r\n 0000CECECE0000000000CECECE00CECECE00CECECE00CECECE009C0000009C9C\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000009C9C000000\r\n 0000CECECE00CECECE00CECECE00CECECE00CECECE00CECECE00CECECE00CECE\r\n CE0000000000009C9C00000000000000000000000000000000009C9C9C000000\r\n 0000CECECE0000000000CECECE00FFFFFF00CECECE00CECECE00FFFFFF009C00\r\n 00009C9C00000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000009C9C000000\r\n 0000CECECE00CECECE00CECECE00CECECE00CECECE00CECECE00CECECE00CECE\r\n CE0000000000009C9C0000000000000000000000000000000000CECECE000000\r\n 0000CECECE00CECECE0000000000000000009C9C9C00CECECE00000000000000\r\n 00009C0000009C9C000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000009C9C000000\r\n 0000CECECE00CECECE00CECECE00CECECE00CECECE00CECECE00CECECE00CECE\r\n CE0000000000009C9C00000000000000000000000000000000009C9C9C009C9C\r\n 9C000000000000000000FFFFFF009C9C9C000000000000000000000000000000\r\n 0000000000009C0000009C9C0000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000009C9C000000\r\n 0000CECECE00CECECE00CECECE00CECECE00CECECE00CECECE00CECECE00CECE\r\n CE00000000000000000000000000000000000000000000000000000000000000\r\n 00009C9C9C009C9C9C0000000000000000000000000000000000000000000000\r\n 000000000000000000009C000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000009C9C000000\r\n 0000CECECE00CECECE00CECECE00CECECE00CECECE00CECECE00CECECE00CECE\r\n CE0000000000CECECE0000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000009C9C000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000FFFF00009C9C00000000000000000000FFFF000000\r\n 000000000000009C9C00009C9C00000000000000000000000000000000009C00\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000CECECE00CECE\r\n CE00CECECE00CECECE00CECECE00CECECE00CECECE00CECECE00CECECE000000\r\n 0000CECECE000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 000000000000000000000000000000FFFF00009C9C00009C9C00FFFFFF000000\r\n 0000009C9C0000FFFF0000000000000000000000000000000000000000009C00\r\n 00009C000000000000000000000000000000009C9C00009C9C00009C9C00009C\r\n 9C00009C9C000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 000000000000CECECE0000000000000000000000000000000000009C9C00009C\r\n 9C00009C9C00009C9C00009C9C00009C9C00009C9C00009C9C00009C9C000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 00000000000000000000009C9C000000000000FFFF00FFFFFF0000FFFF00FFFF\r\n FF0000FFFF0000000000009C9C00000000009C0000009C0000009C0000009C00\r\n 00009C0000009C00000000000000000000000000000000000000000000000000\r\n 00000000000000000000009C9C000000000000000000CECECE00CECECE00CECE\r\n CE00CECECE00CECECE00CECECE0000FFFF0000FFFF0000FFFF00CECECE00CECE\r\n CE00000000000000000000000000000000000000000000FFFF0000000000009C\r\n 9C00009C9C00009C9C00009C9C00009C9C00009C9C00009C9C00009C9C00009C\r\n 9C00000000000000000000000000000000000000000000000000000000000000\r\n 00000000000000000000009C9C0000FFFF00FFFFFF0000000000000000000000\r\n 0000FFFFFF0000FFFF00009C9C00000000000000000000000000000000009C00\r\n 00009C000000000000000000000000000000FFFFFF00CECECE00FFFFFF00CECE\r\n CE00FFFFFF00CECECE00000000000000000000000000CECECE00CECECE00CECE\r\n CE00CECECE00CECECE00CECECE009C9C9C009C9C9C009C9C9C00CECECE00CECE\r\n CE0000000000CECECE00000000000000000000000000FFFFFF0000FFFF000000\r\n 0000009C9C00009C9C00009C9C00009C9C00009C9C00009C9C00009C9C00009C\r\n 9C00009C9C000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000009C9C000000000000000000FFFFFF000000\r\n 000000000000FFFFFF0000000000000000000000000000000000000000009C00\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 000000000000CECECE009C9C9C00000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 000000000000CECECE00CECECE00000000000000000000FFFF00FFFFFF0000FF\r\n FF0000000000009C9C00009C9C00009C9C00009C9C00009C9C00009C9C00009C\r\n 9C00009C9C00009C9C00000000000000000000000000FFFFFF009C9C9C000000\r\n 0000000000009C9C9C000000000000FFFF00009C9C009C9C9C00FFFFFF000000\r\n 000000FFFF00009C9C0000000000000000000000000000000000000000000000\r\n 00000000000000000000000000000000000000000000FFFFFF00FFFFFF00FFFF\r\n FF00FFFFFF0000000000000000000000000000000000CECECE00CECECE00CECE\r\n CE00CECECE00CECECE00CECECE00CECECE00CECECE00CECECE00CECECE000000\r\n 0000CECECE0000000000CECECE000000000000000000FFFFFF0000FFFF00FFFF\r\n FF0000FFFF000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000CECECE009C9C\r\n 9C009C9C9C00FFFFFF0000000000009C9C000000000000000000FFFFFF000000\r\n 00000000000000FFFF0000000000000000000000000000000000000000000000\r\n 00000000000000000000000000000000000000000000FFFFFF009C9C9C009C9C\r\n 9C00FFFFFF000000000000000000000000000000000000000000000000000000\r\n 000000000000000000000000000000000000000000000000000000000000CECE\r\n CE0000000000CECECE0000000000000000000000000000FFFF00FFFFFF0000FF\r\n FF00FFFFFF0000FFFF00FFFFFF0000FFFF00FFFFFF0000FFFF00000000000000\r\n 000000000000000000000000000000000000000000009C9C9C0000000000FFFF\r\n FF009C9C9C00FFFFFF00FFFFFF0000000000FFFFFF00CECECE009C9C9C000000\r\n 000000000000000000000000000000000000000000000000000000000000FFFF\r\n FF00FFFFFF00FFFFFF0000000000000000000000000000000000FFFFFF00FFFF\r\n FF00FFFFFF00FFFFFF000000000000000000000000000000000000000000FFFF\r\n FF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF000000\r\n 0000CECECE0000000000CECECE000000000000000000FFFFFF0000FFFF00FFFF\r\n FF0000FFFF00FFFFFF0000FFFF00FFFFFF0000FFFF00FFFFFF00000000000000\r\n 00000000000000000000000000000000000000000000CECECE00FFFFFF00FFFF\r\n FF00000000000000000000000000FFFFFF00FFFFFF00FFFFFF00000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 000000000000FFFFFF0000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000FFFFFF000000000000000000000000000000000000000000FFFFFF000000\r\n 0000000000000000000000000000000000000000000000FFFF00FFFFFF0000FF\r\n FF00000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000009C9C9C00000000009C9C9C000000\r\n 000000000000FFFFFF0000000000000000009C9C9C0000000000000000000000\r\n 00000000000000000000000000000000000000000000FFFFFF00FFFFFF00FFFF\r\n FF0000000000FFFFFF0000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFF\r\n FF00000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000FFFFFF00FFFF\r\n FF0000000000FFFFFF0000000000FFFFFF00CECECE0000000000000000000000\r\n 00000000000000000000000000000000000000000000FFFFFF009C9C9C00FFFF\r\n FF00000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 000000000000FFFFFF000000000000000000000000000000000000000000FFFF\r\n FF00000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 000000000000000000000000000000000000000000009C9C9C00CECECE000000\r\n 0000FFFFFF009C9C9C000000000000000000FFFFFF0000000000000000000000\r\n 00000000000000000000000000000000000000000000FFFFFF009C9C9C00FFFF\r\n FF00000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 000000000000FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFF\r\n FF00FFFFFF000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 00000000000000000000000000000000000000000000000000009C9C9C000000\r\n 000000000000FFFFFF0000000000000000000000000000000000000000000000\r\n 00000000000000000000000000000000000000000000FFFFFF00FFFFFF000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000009C9C9C0000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 000000000000FF9C310000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000FF6331000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 000000000000FF9C3100000000000000000000000000FF9C3100000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 00000000000000000000FF633100000000000000000000000000FF6331000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000FF9C3100FF9C310000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000FF9C3100FF63\r\n 3100000000000000000000000000000000000000000000000000000000000000\r\n 0000FF9C3100FF9C31000000000000000000FF9C3100FF9C3100000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 00000000000000000000FF9C3100FF6331000000000000000000FF9C3100FF63\r\n 310000000000000000000000000000000000000000000000000000000000FF9C\r\n 3100FFCE3100FF9C3100FF9C3100FF9C3100FF9C3100FF9C3100FF9C3100FF9C\r\n 3100FF9C31000000000000000000000000000000000000000000FF633100FF9C\r\n 3100FF9C3100FF9C3100FF9C3100FF9C3100FF9C3100FF9C3100FF9C3100FFCE\r\n 3100FF633100000000000000000000000000000000000000000000000000FF9C\r\n 3100FFCE3100FF9C3100FF9C3100FF9C3100FFCE3100FF9C3100FF9C3100FF9C\r\n 3100FF9C31000000000000000000000000000000000000000000FF633100FF9C\r\n 3100FF9C3100FF9C3100FF9C3100FFCE3100FF633100FF9C3100FF9C3100FFCE\r\n 3100FF6331000000000000000000000000000000000000000000FF633100FFFF\r\n 9C00FFFF9C00FFFF9C00FFFF9C00FFFF9C00FFFF9C00FFFF9C00FFFF9C00FFFF\r\n 9C00FF9C31000000000000000000000000000000000000000000FF633100FFFF\r\n CE00FFFFCE00FFFFCE00FFFFCE00FFFFCE00FFFFCE00FFFFCE00FFFFCE00FFFF\r\n 9C00FFCE31000000000000000000000000000000000000000000FF633100FFFF\r\n 9C00FFFF9C00FFFF9C00FFFF9C00FFFF9C00FFFF9C00FFFF9C00FFFF9C00FFFF\r\n 9C00FF9C31000000000000000000000000000000000000000000FF633100FFFF\r\n CE00FFFFCE00FFFFCE00FFFFCE00FFFF9C00FFCE3100FFFFCE00FFFFCE00FFFF\r\n 9C00FFCE3100000000000000000000000000000000000000000000000000FF63\r\n 3100FFFF9C00FFFF9C0000000000FF633100FF633100FF633100FF633100FF63\r\n 3100FF6331000000000000000000000000000000000000000000FF633100FF63\r\n 3100FF633100FF633100FF633100FF633100FF633100FF633100FFFFCE00FFCE\r\n 310000000000000000000000000000000000000000000000000000000000FF63\r\n 3100FFFF9C00FFFF9C0000000000FF633100FFFF9C00FFFF9C0000000000FF63\r\n 3100FF6331000000000000000000000000000000000000000000FF633100FF63\r\n 3100FF633100FF633100FFFFCE00FFCE310000000000FF633100FFFFCE00FFCE\r\n 3100000000000000000000000000000000000000000000000000000000000000\r\n 0000FF633100FFFF9C0000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 00000000000000000000000000000000000000000000FF633100FFCE31000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000FF633100FFFF9C000000000000000000FF633100FFFF9C00000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 000000000000FF633100FFCE31000000000000000000FF633100FFCE31000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 000000000000FF63310000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 00000000000000000000000000000000000000000000FF633100000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 000000000000FF633100000000000000000000000000FF633100000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 000000000000FF633100000000000000000000000000FF633100000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 00000000000000000000000000000000000000000000FF633100000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 000000000000FF633100000000000000000000000000FF633100000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 000000000000000000000000000000000000424D3E000000000000003E000000\r\n 2800000040000000400000000100010000000000000200000000000000000000\r\n 000000000000000000000000FFFFFF0000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 00000000000000000000000000000000FFFFFFFF00000000C001F8FF00000000\r\n 8001E03F000000008001800F000000008001800F000000008001800F00000000\r\n 8001800F000000008001800F0000000080018007000000008001800300000000\r\n 800180110000000080018038000000008001C0FC000000008001F1FF00000000\r\n 8001FFFF00000000FFFFFFFF00000000FF8FFFFFFFFFFFFFFC89FF03C007FFFF\r\n F800EE018003001FFC01E6000001000FF800020000010007F800E60000010003\r\n 9000EE00000000010001FF01000000008001C1038000001F001BC181C000001F\r\n 001F01C1E001001F001F01FFE0078FF1803F01FFF007FFF9803F03FFF003FF75\r\n D17F07FFF803FF8FFBFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFDFFFFBFFDDFFBBFF9FFFF9FF99FF99FF1FFFF8FF11FF88F\r\n E003C007E003C007C003C003C003C003C003C003C003C003E003C007E003C007\r\n F1FFFF8FF11FF88FF9FFFF9FF99FF99FFDFFFFBFFDDFFBBFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF00000000000000000000000000000000\r\n 000000000000}\r\n end\r\n object PrinterSetupDialog: TPrinterSetupDialog\r\n Left = 40\r\n Top = 98\r\n end\r\n object PrintDialog: TPrintDialog\r\n FromPage = 1\r\n MaxPage = 99999\r\n Options = [poPageNums, poSelection, poWarning]\r\n ToPage = 1\r\n Left = 8\r\n Top = 98\r\n end\r\n object OpenDialog: TOpenDialog\r\n Filter = 'Quick Report Files|*.qrp'\r\n Options = [ofReadOnly, ofHideReadOnly, ofFileMustExist, ofEnableSizing]\r\n Left = 8\r\n Top = 66\r\n end\r\n object SaveDialog: TSaveDialog\r\n DefaultExt = 'qrp'\r\n Left = 40\r\n Top = 66\r\n end\r\nend\r\n" }, { "path": "External/Jedi/Jvcl/run/JvgQPrintPreviewForm.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvgQPrintPreview.PAS, released on 2003-01-15.\r\n\r\nThe Initial Developer of the Original Code is Andrey V. Chudin, [chudin att yandex dott ru]\r\nPortions created by Andrey V. Chudin are Copyright (C) 2003 Andrey V. Chudin.\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\nMichael Beck [mbeck att bigfoot dott com].\r\nBurov Dmitry, translation of russian text.\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvgQPrintPreviewForm.pas 12665 2010-01-07 21:10:15Z ahuser $\r\n\r\nunit JvgQPrintPreviewForm;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,\r\n Dialogs, ExtCtrls,\r\n QuickRpt, QRCtrls, QRPrntr,\r\n ComCtrls, ToolWin, ImgList, ShellAPI, StdCtrls,\r\n JvComponent, JvExControls,\r\n JvgQRLabel;\r\n\r\ntype\r\n TJvgPrintPreview = class(TJvForm)\r\n Panel2: TPanel;\r\n ToolBar1: TToolBar;\r\n tbPrior: TToolButton;\r\n tbNext: TToolButton;\r\n tbFirst: TToolButton;\r\n ImageList4: TImageList;\r\n Panel1: TPanel;\r\n Shape1: TShape;\r\n ToolButton1: TToolButton;\r\n ToolButton2: TToolButton;\r\n ToolButton4: TToolButton;\r\n ToolButton5: TToolButton;\r\n tbPrinterSetup: TToolButton;\r\n tbPrintRange: TToolButton;\r\n ToolButton8: TToolButton;\r\n tbPrint: TToolButton;\r\n tbLoad: TToolButton;\r\n tbSave: TToolButton;\r\n SB: TStatusBar;\r\n tbExportExcel: TToolButton;\r\n PrinterSetupDialog: TPrinterSetupDialog;\r\n PrintDialog: TPrintDialog;\r\n cbDuplex: TCheckBox;\r\n OpenDialog: TOpenDialog;\r\n SaveDialog: TSaveDialog;\r\n PB: TProgressBar;\r\n QRPreview1: TQRPreview;\r\n procedure FormCreate(Sender: TObject);\r\n procedure qrPreview(Sender: TObject);\r\n procedure tbPriorClick(Sender: TObject);\r\n procedure tbFirstClick(Sender: TObject);\r\n procedure tbNextClick(Sender: TObject);\r\n procedure glLabel1MouseDown(Sender: TObject; Button: TMouseButton;\r\n Shift: TShiftState; X, Y: Integer);\r\n procedure tbPrintClick(Sender: TObject);\r\n procedure ToolButton4Click(Sender: TObject);\r\n procedure tbExportExcelClick(Sender: TObject);\r\n procedure tbPrinterSetupClick(Sender: TObject);\r\n procedure tbPrintRangeClick(Sender: TObject);\r\n procedure cbDuplexClick(Sender: TObject);\r\n procedure tbLoadClick(Sender: TObject);\r\n procedure tbSaveClick(Sender: TObject);\r\n private\r\n QR: TCustomQuickRep;\r\n procedure UpdateStatus;\r\n procedure InitPrintDialog;\r\n procedure SavePrintDialog;\r\n procedure QuickRep1StartPage(Sender: TCustomQuickRep);\r\n public\r\n procedure Execute(QR: TCustomQuickRep);\r\n end;\r\n\r\n TJvgMyQRPreview = class(TQRPreview);\r\n\r\nvar\r\n fPrintPreview: TJvgPrintPreview;\r\n l: TJvgQRLabel;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvgQPrintPreviewForm.pas $';\r\n Revision: '$Revision: 12665 $';\r\n Date: '$Date: 2010-01-07 22:10:15 +0100 (jeu. 07 janv. 2010) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n Printers,\r\n JvResources, JvConsts,\r\n JvgTypes, JvgExport, JvgQPrintSetupForm;\r\n\r\n{$R *.dfm}\r\n\r\nprocedure TJvgPrintPreview.FormCreate(Sender: TObject);\r\nbegin\r\n { l := TJvgQRLabel.Create(Self);\r\n l.Caption := 'FormCreate(Sender: TObject)';\r\n l.Top := 40;\r\n l.Left := 40;\r\n l.Direction := fldDownUp;\r\n l.Parent := Band;}\r\nend;\r\n\r\nprocedure TJvgPrintPreview.qrPreview(Sender: TObject);\r\nbegin\r\n QRPreview1.QRPrinter := QR.QRPrinter;\r\n // QRPreview1.UpdateImage;\r\nend;\r\n\r\nprocedure TJvgPrintPreview.tbPriorClick(Sender: TObject);\r\nbegin\r\n QRPreview1.PageNumber := QRPreview1.PageNumber - 1;\r\n QRPreview1.UpdateZoom;\r\n tbNext.Enabled := QRPreview1.PageNumber < QRPreview1.QRPrinter.PageCount;\r\n tbPrior.Enabled := QRPreview1.PageNumber > 1;\r\n UpdateStatus;\r\nend;\r\n\r\nprocedure TJvgPrintPreview.tbFirstClick(Sender: TObject);\r\nbegin\r\n QRPreview1.PageNumber := 1;\r\n QRPreview1.UpdateZoom;\r\n tbPrior.Enabled := False;\r\n tbNext.Enabled := QRPreview1.PageNumber < QRPreview1.QRPrinter.PageCount;\r\n UpdateStatus;\r\nend;\r\n\r\nprocedure TJvgPrintPreview.tbNextClick(Sender: TObject);\r\nbegin\r\n QRPreview1.PageNumber := QRPreview1.PageNumber + 1;\r\n QRPreview1.UpdateZoom;\r\n tbNext.Enabled := QRPreview1.PageNumber <> QRPreview1.QRPrinter.PageCount;\r\n tbPrior.Enabled := QRPreview1.PageNumber > 0;\r\n UpdateStatus;\r\nend;\r\n\r\nprocedure TJvgPrintPreview.glLabel1MouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);\r\nbegin\r\n // (rom) should be removed\r\n //ShellExecute(0, nil, 'http://shop.biblio-globus.ru/cpr/', nil, nil, SW_SHOW);\r\nend;\r\n\r\nprocedure TJvgPrintPreview.ToolButton4Click(Sender: TObject);\r\nbegin\r\n QRPreview1.PageNumber := QRPreview1.QRPrinter.PageCount;\r\n QRPreview1.UpdateZoom;\r\n tbNext.Enabled := QRPreview1.PageNumber < QRPreview1.QRPrinter.PageCount;\r\n tbPrior.Enabled := QRPreview1.PageNumber > 1;\r\n UpdateStatus;\r\nend;\r\n\r\nprocedure TJvgPrintPreview.UpdateStatus;\r\nbegin\r\n SB.Panels[0].Text := Format(RsPageOfPages, [QRPreview1.PageNumber, QRPreview1.QRPrinter.PageCount]);\r\n try\r\n PB.Max := QRPreview1.QRPrinter.PageCount;\r\n PB.Min := QRPreview1.PageNumber;\r\n except\r\n end;\r\nend;\r\n\r\nprocedure TJvgPrintPreview.tbExportExcelClick(Sender: TObject);\r\nbegin\r\n ExportToExcel(QR);\r\nend;\r\n\r\nprocedure TJvgPrintPreview.InitPrintDialog;\r\nbegin\r\n Printer.Orientation := QR.Page.Orientation;\r\n PrintDialog.PrintRange := prAllPages;\r\n PrintDialog.Copies := QR.PrinterSettings.Copies;\r\n PrintDialog.FromPage := 0;\r\n PrintDialog.ToPage := 0;\r\nend;\r\n\r\nprocedure TJvgPrintPreview.SavePrintDialog;\r\nbegin\r\n QR.Page.Orientation := Printer.Orientation;\r\n QR.PrinterSettings.Copies := PrintDialog.Copies;\r\n QR.PrinterSettings.FirstPage := PrintDialog.FromPage;\r\n QR.PrinterSettings.LastPage := PrintDialog.ToPage;\r\n // QR.Printer.FirstPage := PrintDialog.FromPage;\r\n // QR.Printer.LastPage := PrintDialog.ToPage;\r\nend;\r\n\r\nprocedure TJvgPrintPreview.tbPrinterSetupClick(Sender: TObject);\r\nbegin\r\n Printer.Orientation := QR.Page.Orientation;\r\n // Printer.Paper\r\n PrinterSetupDialog.Execute;\r\n QR.Page.Orientation := Printer.Orientation;\r\n QR.PrinterSettings.Orientation := Printer.Orientation;\r\n\r\n QR.Prepare;\r\n QRPreview1.QRPrinter := QR.QRPrinter;\r\n QRPreview1.UpdateZoom;\r\n UpdateStatus;\r\nend;\r\n\r\nprocedure TJvgPrintPreview.tbPrintRangeClick(Sender: TObject);\r\nbegin\r\n // InitPrintDialog;\r\n // PrintDialog.FromPage := QRPreview1.PageNumber;\r\n // PrintDialog.ToPage := QRPreview1.PageNumber;\r\n // PrintDialog.PrintRange := prPageNums;\r\n // if not PrintDialog.Execute then exit;\r\n // SavePrintDialog;\r\n QR.PrinterSettings.FirstPage := QRPreview1.PageNumber;\r\n QR.PrinterSettings.LastPage := QRPreview1.PageNumber;\r\n\r\n QRPreview1.Zoom := 100;\r\n QR.Print;\r\nend;\r\n\r\nprocedure TJvgPrintPreview.tbPrintClick(Sender: TObject);\r\nbegin\r\n InitPrintDialog;\r\n if PrintDialog.Execute then\r\n begin\r\n SavePrintDialog;\r\n QRPreview1.Zoom := 100;\r\n QR.Print;\r\n end;\r\nend;\r\n\r\nprocedure TJvgPrintPreview.cbDuplexClick(Sender: TObject);\r\nbegin\r\n QR.PrinterSettings.Duplex := cbDuplex.Checked;\r\nend;\r\n\r\nprocedure TJvgPrintPreview.tbLoadClick(Sender: TObject);\r\nbegin\r\n if OpenDialog.Execute then\r\n begin\r\n QR.QRPrinter.Load(OpenDialog.FileName);\r\n QRPreview1.QRPrinter := QR.QRPrinter;\r\n QR.Update;\r\n end;\r\nend;\r\n\r\nprocedure TJvgPrintPreview.tbSaveClick(Sender: TObject);\r\nbegin\r\n if OpenDialog.Execute then\r\n QR.QRPrinter.Save(SaveDialog.FileName);\r\nend;\r\n\r\nprocedure TJvgPrintPreview.QuickRep1StartPage(Sender: TCustomQuickRep);\r\nbegin\r\n PB.Position := QRPreview1.PageNumber;\r\nend;\r\n\r\nprocedure TJvgPrintPreview.Execute(QR: TCustomQuickRep);\r\nbegin\r\n Self.QR := QR;\r\n QR.OnStartPage := nil;\r\n QR.Prepare;\r\n QRPreview1.QRPrinter := QR.QRPrinter;\r\n QRPreview1.UpdateZoom;\r\n UpdateStatus;\r\n\r\n QR.OnStartPage := QuickRep1StartPage;\r\n\r\n cbDuplex.Checked := QR.PrinterSettings.Duplex;\r\n ShowModal;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend." }, { "path": "External/Jedi/Jvcl/run/JvgQPrintSetupForm.dfm", "content": "object JvgPrintSetup: TJvgPrintSetup\r\n Left = 520\r\n Top = 121\r\n BorderIcons = [biSystemMenu]\r\n BorderStyle = bsSingle\r\n Caption = 'Print Setup'\r\n ClientHeight = 59\r\n ClientWidth = 424\r\n Color = clBtnFace\r\n Font.Charset = DEFAULT_CHARSET\r\n Font.Color = clWindowText\r\n Font.Height = -11\r\n Font.Name = 'MS Sans Serif'\r\n Font.Style = []\r\n OldCreateOrder = False\r\n Position = poOwnerFormCenter\r\n PixelsPerInch = 96\r\n TextHeight = 13\r\n object rgOrientation: TRadioGroup\r\n Left = 8\r\n Top = 0\r\n Width = 200\r\n Height = 56\r\n Caption = 'Orientation'\r\n ItemIndex = 0\r\n Items.Strings = (\r\n 'Portrait'\r\n 'Landscape')\r\n TabOrder = 0\r\n end\r\n object rgRadioGroup2: TRadioGroup\r\n Left = 216\r\n Top = 0\r\n Width = 200\r\n Height = 56\r\n Caption = 'Printing'\r\n ItemIndex = 0\r\n Items.Strings = (\r\n 'Single-sided'\r\n 'Double-sided')\r\n TabOrder = 1\r\n end\r\nend\r\n" }, { "path": "External/Jedi/Jvcl/run/JvgQPrintSetupForm.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvgQPrintSetup.PAS, released on 2003-01-15.\r\n\r\nThe Initial Developer of the Original Code is Andrey V. Chudin, [chudin att yandex dott ru]\r\nPortions created by Andrey V. Chudin are Copyright (C) 2003 Andrey V. Chudin.\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\nMichael Beck [mbeck att bigfoot dott com].\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvgQPrintSetupForm.pas 12553 2009-10-05 13:22:42Z obones $\r\n\r\nunit JvgQPrintSetupForm;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, Controls, Forms, StdCtrls, ExtCtrls, Classes, JvComponent;\r\n\r\ntype\r\n TJvgPrintSetup = class(TJvForm)\r\n rgOrientation: TRadioGroup;\r\n rgRadioGroup2: TRadioGroup;\r\n public\r\n end;\r\n\r\nvar\r\n JvgPrintSetup: TJvgPrintSetup;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvgQPrintSetupForm.pas $';\r\n Revision: '$Revision: 12553 $';\r\n Date: '$Date: 2009-10-05 15:22:42 +0200 (lun. 05 oct. 2009) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\n{$R *.dfm}\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend." }, { "path": "External/Jedi/Jvcl/run/JvgQRLabel.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvgQRLabel.PAS, released on 2003-01-15.\r\n\r\nThe Initial Developer of the Original Code is Andrey V. Chudin, [chudin att yandex dott ru]\r\nPortions created by Andrey V. Chudin are Copyright (C) 2003 Andrey V. Chudin.\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\nMichael Beck [mbeck att bigfoot dott com].\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvgQRLabel.pas 12461 2009-08-14 17:21:33Z obones $\r\n\r\nunit JvgQRLabel;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, Classes, Graphics, QRCtrls, DB,\r\n JvgTypes;\r\n\r\ntype\r\n TJvgQRLabel = class(TQRCustomLabel)\r\n private\r\n FDirection: TglLabelDir;\r\n FEscapment: Integer;\r\n FAlignment: TAlignment;\r\n FPrinting: Boolean;\r\n procedure SetDirection(Value: TglLabelDir);\r\n procedure SetEscapment(Value: Integer);\r\n protected\r\n procedure SetAlignment(Value: TAlignment); override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n protected\r\n procedure Paint; override;\r\n procedure Print(OfsX, OfsY: Integer); override;\r\n procedure PaintLabel(const Caption: string; Canvas: TCanvas; OfsX, OfsY: Integer);\r\n published\r\n property Direction: TglLabelDir read FDirection write SetDirection\r\n default fldLeftRight;\r\n property Escapment: Integer read FEscapment write SetEscapment default 0;\r\n property Alignment: TAlignment read FAlignment write SetAlignment default taLeftJustify;\r\n property Align;\r\n property AutoSize;\r\n property AlignToBand;\r\n property AutoStretch;\r\n property Color;\r\n property Caption;\r\n property Font;\r\n property Transparent;\r\n property Visible;\r\n property Enabled;\r\n end;\r\n\r\n TJvgQRDBText = class(TJvgQRLabel)\r\n private\r\n FDataSet: TDataSet;\r\n FDataField: string;\r\n procedure SetDataField(const Value: string);\r\n protected\r\n procedure Paint; override;\r\n procedure Print(OfsX, OfsY: Integer); override;\r\n published\r\n property DataSet: TDataSet read FDataSet write FDataSet;\r\n property DataField: string read FDataField write SetDataField;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvgQRLabel.pas $';\r\n Revision: '$Revision: 12461 $';\r\n Date: '$Date: 2009-08-14 19:21:33 +0200 (ven. 14 août 2009) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n SysUtils, Controls,\r\n JvgUtils;\r\n\r\n//=== { TJvgQRLabel } ========================================================\r\n\r\nconstructor TJvgQRLabel.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n AutoSize := True;\r\n FAlignment := taLeftJustify;\r\n FEscapment := 0;\r\nend;\r\n\r\nprocedure TJvgQRLabel.Paint;\r\nbegin\r\n FPrinting := False;\r\n PaintLabel(Caption, Canvas, 0, 0);\r\nend;\r\n\r\nprocedure TJvgQRLabel.PaintLabel(const Caption: string; Canvas: TCanvas; OfsX, OfsY: Integer);\r\nvar\r\n FreeFontHandle: THandle;\r\n R: TRect;\r\n X, Y: Integer;\r\n Size, TextSize: TSize;\r\n PixFactor: Single;\r\nbegin\r\n X := 0;\r\n Y := 0;\r\n\r\n Canvas.Font := Font;\r\n Canvas.Font.Size := Round(Font.Size * Zoom / 100);\r\n\r\n FreeFontHandle := CreateRotatedFont(Canvas.Font, Escapment);\r\n Canvas.Font.Handle := FreeFontHandle;\r\n\r\n GetTextExtentPoint32(Canvas.Handle, PChar(Caption), Length(Caption), Size);\r\n Inc(Size.cx);\r\n Inc(Size.cy);\r\n TextSize := Size;\r\n\r\n if (Align = alNone) and AutoSize then\r\n case FDirection of\r\n fldLeftRight, fldRightLeft:\r\n begin\r\n Width := Size.cx;\r\n Height := Size.cy;\r\n end;\r\n else {fldDownUp, fldUpDown:}\r\n Width := Size.cy;\r\n Height := Size.cx;\r\n end;\r\n case FDirection of\r\n fldLeftRight:\r\n begin //if Align = alNone then begin Width:=max(w,Size.cx);Height:=max(h,Size.cy); end;\r\n case Alignment of\r\n taCenter:\r\n X := (Width - Size.cx) div 2;\r\n taRightJustify:\r\n X := Width - Size.cx;\r\n end;\r\n end;\r\n fldRightLeft:\r\n begin //if Align = alNone then begin Width:=max(w,Size.cx);Height:=max(h,Size.cy);X:=Width;Y:=Height; end;\r\n case Alignment of\r\n taCenter:\r\n X := (Width + Size.cx) div 2;\r\n taLeftJustify:\r\n X := Width - (Size.cx - TextSize.cx) - 2;\r\n else\r\n X := TextSize.cx;\r\n end;\r\n Y := TextSize.cy;\r\n end;\r\n fldDownUp:\r\n begin //if Align = alNone then begin Height:=max(h,Size.cx);Width:=max(w,Size.cy);Y:=Height-2; end;\r\n case Alignment of\r\n taCenter:\r\n Y := (Height + TextSize.cx - (Size.cy - TextSize.cy)) div 2;\r\n taRightJustify:\r\n Y := TextSize.cx - 4;\r\n else\r\n Y := Height - (Size.cy - TextSize.cy) - 2;\r\n end;\r\n end;\r\n fldUpDown:\r\n begin //if Align = alNone then begin Height:=max(h,Size.cx);Width:=max(w,Size.cy);X:=Width; end;\r\n case Alignment of\r\n taCenter:\r\n Y := (Height - Size.cx) div 2;\r\n taRightJustify:\r\n Y := Height - Size.cx;\r\n else\r\n Y := 1;\r\n end;\r\n X := TextSize.cy;\r\n end;\r\n end;\r\n\r\n PixFactor := (Height / Self.Size.Height);\r\n if Assigned(QRPrinter) then\r\n begin\r\n X := QRPrinter.XPos(OfsX {+ Self.Size.Left} + Round(X / PixFactor));\r\n Y := QRPrinter.YPos(OfsY {+ Self.Size.Top} + Round(Y / PixFactor));\r\n end;\r\n\r\n if Transparent then\r\n SetBkMode(Canvas.Handle, Windows.TRANSPARENT)\r\n else\r\n SetBkMode(Canvas.Handle, OPAQUE);\r\n SetTextColor(Canvas.Handle, ColorToRGB(Font.Color));\r\n\r\n if FPrinting then\r\n begin\r\n // with QRPrinter do R := Bounds(XPos(OfsX), YPos(OfsY), {XPos}trunc(Width * Zoom / 100), trunc(Height*Zoom / 100));\r\n with QRPrinter do\r\n R := Rect(XPos(OfsX {+ Self.Size.Left}), YPos(OfsY {+ Self.Size.Top}), XPos(OfsX + Self.Size.Left +\r\n Self.Size.Width), YPos(OfsY + Self.Size.Top + Self.Size.Height));\r\n ExtTextOut(Canvas.Handle, X {QRPrinter.XPos(OfsX)+X}, Y {QRPrinter.YPos(OfsY)+Y}, ETO_CLIPPED, @R, PChar(Caption),\r\n Length(Caption), nil);\r\n end\r\n else\r\n Canvas.TextOut(OfsX + X, OfsY + Y, Caption);\r\n // ExtTextOut(Canvas.Handle, OfsX+X,OfsY+Y, ETO_CLIPPED, @R, PChar(Caption), Length(Caption), nil);\r\n DeleteObject(FreeFontHandle);\r\n // QRPrinter.Canvas.Font.Assign(OldFont);\r\n (*\r\n SaveIndex := SaveDC(Canvas.Handle);\r\n SetViewportOrgEx(Canvas.Handle, OfsX, OfsY, nil);\r\n gLabel.ExternalCanvas := Canvas;\r\n gLabel.Paint;\r\n RestoreDC(Canvas.Handle, SaveIndex);\r\n *)\r\nend;\r\n\r\nprocedure TJvgQRLabel.Print(OfsX, OfsY: Integer);\r\nbegin\r\n // JvgLabel.Direction := fldDownUp;\r\n if ParentReport.FinalPass then\r\n begin\r\n FPrinting := True;\r\n PaintLabel(Caption, QRPrinter.Canvas, Round(Size.Left + OfsX), Round(Size.Top + OfsY));\r\n end;\r\nend;\r\n\r\nprocedure TJvgQRLabel.SetDirection(Value: TglLabelDir);\r\nconst\r\n RadianEscapments: array [TglLabelDir] of Integer =\r\n (0, -1800, -900, 900);\r\nbegin\r\n if FDirection <> Value then\r\n begin\r\n FDirection := Value;\r\n FEscapment := RadianEscapments[FDirection];\r\n Repaint;\r\n //CreateLabelFont;\r\n end;\r\nend;\r\n\r\nprocedure TJvgQRLabel.SetEscapment(Value: Integer);\r\nbegin\r\n if FEscapment <> Value then\r\n begin\r\n FEscapment := Value;\r\n Repaint;\r\n //CreateLabelFont;\r\n end;\r\nend;\r\n\r\nprocedure TJvgQRLabel.SetAlignment(Value: TAlignment);\r\nbegin\r\n if FAlignment <> Value then\r\n begin\r\n FAlignment := Value;\r\n Repaint;\r\n end;\r\nend;\r\n\r\n//=== { TJvgQRDBText } =======================================================\r\n\r\nprocedure TJvgQRDBText.Paint;\r\nbegin\r\n FPrinting := False;\r\n // if DataField <> '' then Caption := DataField;\r\n PaintLabel(Caption, Canvas, 0, 0);\r\nend;\r\n\r\nprocedure TJvgQRDBText.Print(OfsX, OfsY: Integer);\r\nbegin\r\n if ParentReport.FinalPass then\r\n begin\r\n FPrinting := True;\r\n if (DataField <> '') and Assigned(DataSet) and (DataSet.FindField(DataField) <> nil) then\r\n Caption := DataSet.FindField(DataField).AsString;\r\n PaintLabel(Caption, QRPrinter.Canvas, Round(Size.Left + OfsX), Round(Size.Top + OfsY));\r\n end;\r\nend;\r\n\r\nprocedure TJvgQRDBText.SetDataField(const Value: string);\r\nbegin\r\n if FDataField <> Value then\r\n begin\r\n FDataField := Value;\r\n Caption := FDataField;\r\n Repaint;\r\n end;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvgReport.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvgReport.PAS, released on 2003-01-15.\r\n\r\nThe Initial Developer of the Original Code is Andrey V. Chudin, [chudin att yandex dott ru]\r\nPortions created by Andrey V. Chudin are Copyright (C) 2003 Andrey V. Chudin.\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\nMichael Beck [mbeck att bigfoot dott com].\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvgReport.pas 12461 2009-08-14 17:21:33Z obones $\r\n\r\nunit JvgReport;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, Messages, Classes, Controls, Graphics,\r\n Forms, OleCtnrs, ExtCtrls, SysUtils, Printers,\r\n JvComponentBase, JvComponent,\r\n JvgUtils, JvgTypes, JvgCommClasses;\r\n\r\ntype\r\n TJvgReport = class;\r\n\r\n TJvgReportParamKind = (gptUnknown, gptEdit, gptRadio, gptCheck);\r\n\r\n TJvgReportScrollBox = class(TScrollBox)\r\n private\r\n FGridImage: TBitmap;\r\n FOnDraw: TNotifyEvent;\r\n procedure WMEraseBkgnd(var Msg: TWMEraseBkgnd); message WM_ERASEBKGND;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n property OnDraw: TNotifyEvent read FOnDraw write FOnDraw;\r\n end;\r\n\r\n TJvgReportItem = class(TJvGraphicControl)\r\n private\r\n FSelected: Boolean;\r\n FBkColor: Integer;\r\n FBvColor: Integer;\r\n FTransparent: Integer;\r\n FAlignment: Word; //..1-left,2-right,3-center,4-boadwise\r\n FSideLeft, FSideTop, FSideRight, FSideBottom: Word;\r\n FPenStyle: Integer;\r\n FPenWidth: Word;\r\n FText: string;\r\n PrintText: string;\r\n FCompName: string;\r\n FFName: string;\r\n FFSize, FFColor, FFStyle: Integer;\r\n FContainOLE: Boolean;\r\n FFixed: Word;\r\n FOLELinkToFile: string;\r\n FOLESizeMode: Word;\r\n // fRepaintOnlyBorder,\r\n fSizing: Boolean;\r\n R: array [1..8] of TRect;\r\n DownPos: TPoint;\r\n SizeDirection: Integer;\r\n FExternalCanvas: TCanvas;\r\n Cursors: array [1..8] of TCursor;\r\n Bmp: TBitmap;\r\n Report: TJvgReport;\r\n procedure SetSelected(Value: Boolean);\r\n procedure SetBkColor(Value: Integer);\r\n procedure SetBvColor(Value: Integer);\r\n procedure SetTransparent(Value: Integer);\r\n procedure SetAlignment(Value: Word);\r\n procedure SetSideLeft(Value: Word);\r\n procedure SetSideTop(Value: Word);\r\n procedure SetSideRight(Value: Word);\r\n procedure SetSideBottom(Value: Word);\r\n procedure SetPenStyle(Value: Integer);\r\n procedure SetPenWidth(Value: Word);\r\n procedure SetText(const Value: string);\r\n procedure SetFName(const Value: string);\r\n procedure SetFSize(Value: Integer);\r\n procedure SetFColor(Value: Integer);\r\n procedure SetFStyle(Value: Integer);\r\n procedure SetContainOLE(Value: Boolean);\r\n procedure SetOLELinkToFile(const Value: string);\r\n procedure SetOLESizeMode(Value: Word);\r\n procedure SetFixed(Value: Word);\r\n function IsContainOLE: Boolean;\r\n procedure WMMouseMove(var Msg: TWMMouse); message WM_MOUSEMOVE;\r\n procedure WMLMouseDown(var Msg: TWMMouse); message WM_LBUTTONDOWN;\r\n procedure WMLMouseUp(var Msg: TWMMouse); message WM_LBUTTONUP;\r\n procedure WMSize(var Msg: TWMSize); message WM_SIZE;\r\n protected\r\n procedure MouseEnter(Control: TControl); override;\r\n procedure MouseLeave(Control: TControl); override;\r\n procedure FontChanged; override;\r\n public\r\n procedure Paint; override;\r\n procedure PaintTo(Canvas: TCanvas);\r\n protected\r\n procedure SetParent(Value: TWinControl); override;\r\n public\r\n ResText: string;\r\n OLEContainer: TOLEContainer;\r\n property Selected: Boolean read FSelected write SetSelected default False;\r\n property Visible;\r\n property OnClick;\r\n property OnDblClick;\r\n property OnMouseDown;\r\n property OnMouseMove;\r\n property OnMouseUp;\r\n // property OnResize;\r\n property ExternalCanvas: TCanvas read FExternalCanvas write FExternalCanvas;\r\n // procedure RepaintBorder;\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n published\r\n property BkColor: Integer read FBkColor write SetBkColor default clWhite;\r\n property BvColor: Integer read FBvColor write SetBvColor default clBlack;\r\n property Transparent: Integer read FTransparent write SetTransparent default 0;\r\n property Alignment: Word read FAlignment write SetAlignment default 1;\r\n property SideLeft: Word read FSideLeft write SetSideLeft default 1;\r\n property SideTop: Word read FSideTop write SetSideTop default 1;\r\n property SideRight: Word read FSideRight write SetSideRight default 1;\r\n property SideBottom: Word read FSideBottom write SetSideBottom default 1;\r\n property PenStyle: Integer read FPenStyle write SetPenStyle default Integer(psSolid);\r\n property PenWidth: Word read FPenWidth write SetPenWidth default 1;\r\n property Text: string read FText write SetText;\r\n property CompName: string read FCompName write FCompName;\r\n property FName: string read FFName write SetFName;\r\n property FSize: Integer read FFSize write SetFSize;\r\n property FColor: Integer read FFColor write SetFColor;\r\n property FStyle: Integer read FFStyle write SetFStyle;\r\n property ContainOLE: Boolean read FContainOLE write SetContainOLE default False;\r\n property OLELinkToFile: string read FOLELinkToFile write SetOLELinkToFile stored IsContainOLE;\r\n property OLESizeMode: Word read FOLESizeMode write SetOLESizeMode stored IsContainOLE default 2;\r\n property Fixed: Word read FFixed write SetFixed default 0;\r\n end;\r\n\r\n TJvgReportBeforePrintEvent = procedure(Sender: TJvgReport) of object;\r\n\r\n TJvgReport = class(TJvComponent)\r\n private\r\n procedure ValidateWnds;\r\n function GetReportText: TStringList;\r\n procedure SetReportText(Value: TStringList);\r\n public\r\n OwnerWnd, ParentWnd: TWinControl;\r\n ParamNames: TStringList;\r\n ParamValues: TStringList;\r\n ParamMasks: TStringList;\r\n ParamTypes: TList;\r\n FReportList: TStringList;\r\n ComponentList: TList;\r\n FBeforePrint: TJvgReportBeforePrintEvent;\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n procedure Save;\r\n procedure LoadFromFile(const FileName: string);\r\n procedure SaveToFile(const FileName: string);\r\n procedure PaintTo(Canvas: TCanvas);\r\n procedure PreviewTo(Window: TWinControl);\r\n procedure Print;\r\n procedure CreateReport(ParentWnd: TWinControl; fNeedClearOwner: Boolean);\r\n function SetParam(const sParamName, sParamValue: string): Boolean;\r\n function GetParam(const sParamName: string; var sParamValue: string): Boolean;\r\n function AddComponent: TJvgReportItem;\r\n procedure AnalyzeParams(Item: TJvgReportItem; const DefName: string);\r\n private\r\n procedure SetUnicalName(laBevel: TJvgReportItem);\r\n protected\r\n procedure Loaded; override;\r\n procedure ClearReport;\r\n published\r\n property Report: TStringList read FReportList;\r\n property ReportText: TStringList read GetReportText write SetReportText;\r\n property BeforePrint: TJvgReportBeforePrintEvent read FBeforePrint write FBeforePrint;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvgReport.pas $';\r\n Revision: '$Revision: 12461 $';\r\n Date: '$Date: 2009-08-14 19:21:33 +0200 (ven. 14 août 2009) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n Math,\r\n JvResources, JvConsts;\r\n\r\nconst\r\n S = 2;\r\n DS = 2 * S + 1;\r\n\r\n//=== { TJvgReportScrollBox } ================================================\r\n\r\nconstructor TJvgReportScrollBox.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FGridImage := TBitmap.Create;\r\n FGridImage.Width := 8;\r\n FGridImage.Height := 8;\r\n FGridImage.Canvas.Brush.Color := clWhite; //clWindow;\r\n FGridImage.Canvas.FillRect(Rect(0, 0, 8, 8));\r\n FGridImage.Canvas.Pixels[7, 7] := 0;\r\nend;\r\n\r\ndestructor TJvgReportScrollBox.Destroy;\r\nbegin\r\n FGridImage.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvgReportScrollBox.WMEraseBkgnd(var Msg: TWMEraseBkgnd);\r\nbegin\r\n Msg.Result := 1;\r\n if csDestroying in ComponentState then\r\n Exit;\r\n with TCanvas.Create do\r\n try\r\n Handle := Msg.DC;\r\n // Pen.Color := clWindow;\r\n // Brush.Color := clWindow;\r\n // Brush.Style := bsCross;\r\n Brush.Bitmap := FGridImage;\r\n FillRect(ClientRect);\r\n Handle := 0;\r\n finally\r\n Free;\r\n end;\r\n if Assigned(FOnDraw) then\r\n FOnDraw(Self);\r\nend;\r\n\r\n//=== { TJvgReportItem } =====================================================\r\n\r\nconstructor TJvgReportItem.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n //..defaults\r\n Width := 50;\r\n Height := 50;\r\n Color := clWhite;\r\n FBkColor := clWhite;\r\n FBvColor := clBlack;\r\n FAlignment := 1;\r\n FSideLeft := 1;\r\n FSideTop := 1;\r\n FSideRight := 1;\r\n FSideBottom := 1;\r\n FPenStyle := Integer(psSolid);\r\n FPenWidth := 1;\r\n FOLESizeMode := 2;\r\n Cursors[1] := crSizeNWSE;\r\n Cursors[2] := crSizeNS;\r\n Cursors[3] := crSizeNESW;\r\n\r\n Cursors[4] := crSizeNESW;\r\n Cursors[5] := crSizeNS;\r\n Cursors[6] := crSizeNWSE;\r\n\r\n Cursors[7] := crSizeWE;\r\n Cursors[8] := crSizeWE;\r\n ParentFont := False;\r\n {$IFDEF GL_RUS}\r\n Font.CharSet := RUSSIAN_CHARSET;\r\n {$ENDIF GL_RUS}\r\n FontChanged;\r\nend;\r\n\r\ndestructor TJvgReportItem.Destroy;\r\nbegin\r\n if Assigned(Bmp) then\r\n Bmp.Free;\r\n if Assigned(OLEContainer) then\r\n begin\r\n OLEContainer.DestroyObject;\r\n if not (csDestroying in ComponentState) then\r\n begin\r\n OLEContainer.Free;\r\n OLEContainer := nil;\r\n end;\r\n end;\r\n inherited;\r\nend;\r\n\r\n{procedure TJvgReportItem.RepaintBorder;\r\nvar\r\n R: TRect;\r\nbegin\r\n R := ClientRect;\r\n OffsetRect( R, Left, Top );\r\n InvalidateRect( Parent.Handle, @R, False );\r\n InflateRect( R, -DS, -DS );\r\n// ValidateRect( Parent.Handle, @R );\r\n fRepaintOnlyBorder := True;\r\n Paint;\r\n //fRepaintOnlyBorder := False;\r\nend;\r\n}\r\n\r\nprocedure TJvgReportItem.Paint;\r\nbegin\r\n PaintTo(Canvas);\r\nend;\r\n\r\nprocedure TJvgReportItem.PaintTo(Canvas: TCanvas);\r\nconst\r\n Alignments: array[1..4] of TglAlignment = (ftaLeftJustify,\r\n ftaRightJustify, ftaCenter, ftaBroadwise);\r\n // SysAlignments: array[TglAlignment] of Word = (DT_LEFT, DT_RIGHT, DT_CENTER, 0);\r\nvar\r\n I, L, T: Integer;\r\n sPrintText: string;\r\n R_, Client_Rect, RCalc: TRect;\r\nbegin\r\n FFColor := 0;\r\n with Canvas do\r\n begin\r\n\r\n if Canvas = Self.Canvas then\r\n Client_Rect := Rect(0, 0, Width, Height)\r\n else\r\n begin\r\n Client_Rect := Bounds(Left, Top, Width, Height);\r\n Canvas.Font := Self.Canvas.Font;\r\n Canvas.Font.Color := 0;\r\n end;\r\n R_ := Client_Rect;\r\n L := Client_Rect.Left;\r\n T := Client_Rect.Top;\r\n InflateRect(R_, -DS, -S);\r\n RCalc := R_;\r\n\r\n if Transparent = 0 then\r\n begin\r\n Brush.Color := BkColor;\r\n FillRect(Client_Rect);\r\n end;\r\n\r\n if Canvas = Self.Canvas then\r\n begin\r\n Pen.Style := psDot;\r\n Pen.Width := 1;\r\n Pen.Color := clSilver;\r\n Brush.Style := bsClear;\r\n Rectangle(L, T, L + Width, T + Height);\r\n sPrintText := Text;\r\n end\r\n else\r\n sPrintText := PrintText;\r\n if sPrintText = '' then\r\n sPrintText := Text;\r\n\r\n Pen.Style := TPenStyle(PenStyle);\r\n Pen.Width := PenWidth;\r\n Pen.Color := BvColor;\r\n if SideLeft <> 0 then\r\n begin\r\n MoveTo(L + PenWidth div 2, T + Height - 1);\r\n LineTo(L + PenWidth div 2, T);\r\n end;\r\n if SideTop <> 0 then\r\n begin\r\n MoveTo(L + PenWidth div 2, T + PenWidth div 2);\r\n LineTo(L + Width - PenWidth, T + PenWidth div 2);\r\n end;\r\n if SideRight <> 0 then\r\n begin\r\n MoveTo(L + Width - 1, T);\r\n LineTo(L + Width - 1, T + Height - 1);\r\n end;\r\n if SideBottom <> 0 then\r\n begin\r\n MoveTo(L + Width - 1, T + Height - 1);\r\n LineTo(L, T + Height - 1);\r\n end;\r\n\r\n if not ContainOLE then\r\n begin\r\n SetBkMode(Canvas.Handle, TRANSPARENT);\r\n SetTextColor(Canvas.Handle, FColor);\r\n Windows.DrawText(Canvas.Handle, PChar(sPrintText), Length(sPrintText), RCalc,\r\n DT_CALCRECT or DT_WordBREAK);\r\n R_.Top := R_.Top + max(0, (R_.Bottom - R_.Top - (RCalc.Bottom -\r\n RCalc.Top)) div 2);\r\n DrawTextExtAligned(Canvas, sPrintText, R_, Alignments[Alignment],\r\n True);\r\n end\r\n else\r\n if (OLELinkToFile <> '') and (ExtractFileExt(OLELinkToFile) = '.bmp') then\r\n begin\r\n if Assigned(OLEContainer) then\r\n OLEContainer.Visible := False;\r\n if Bmp = nil then\r\n begin\r\n Bmp := TBitmap.Create;\r\n Bmp.LoadFromFile(OLELinkToFile);\r\n end;\r\n BitBlt(Canvas.Handle, L, T, Bmp.Width, Bmp.Height, Bmp.Canvas.Handle,\r\n 0, 0, SRCCOPY);\r\n end;\r\n\r\n if Selected then\r\n begin\r\n Pen.Style := psSolid;\r\n Pen.Width := 1;\r\n Pen.Color := 0;\r\n Brush.Style := bsSolid;\r\n if Fixed <> 0 then\r\n Brush.Color := clBtnFace\r\n else\r\n Brush.Color := clWhite;\r\n R[1] := Rect(0, 0, DS, DS); //...top-left\r\n R[2] := Rect(Width div 2 - S, 0, Width div 2 + S + 1, DS); //...top-center\r\n R[3] := Rect(Width - DS, 0, Width, DS); //...top-right\r\n\r\n R[4] := Rect(0, Height - DS, DS, Height); //...bottom-left\r\n R[5] := Rect(Width div 2 - S, Height - DS, Width div 2 + S + 1, Height); //...bottom-center\r\n R[6] := Rect(Width - DS, Height - DS, Width, Height); //...bottom-right\r\n\r\n R[7] := Rect(0, Height div 2 - S, DS, Height div 2 + S + 1); //...left-center\r\n R[8] := Rect(Width - DS, Height div 2 - S, Width, Height div 2 + S + 1); //...right-center\r\n\r\n for I := 1 to 8 do\r\n Rectangle(R[I].Left, R[I].Top, R[I].Right, R[I].Bottom);\r\n end;\r\n end;\r\n if Assigned(OLEContainer) then\r\n OLEContainer.SetBounds(Left + DS, Top + DS, Width - 2 * DS, Height - 2 *\r\n DS);\r\nend;\r\n\r\nprocedure TJvgReportItem.SetParent(Value: TWinControl);\r\nbegin\r\n inherited;\r\n if Assigned(OLEContainer) and Assigned(Value) then\r\n OLEContainer.Parent := Value;\r\nend;\r\n\r\nprocedure TJvgReportItem.MouseEnter(Control: TControl);\r\nbegin\r\n inherited MouseEnter(Control);\r\n if csDesigning in ComponentState then\r\n Exit;\r\n //Cursor := crCross;\r\n// SetCursor( Screen.Cursors[crCross] );\r\nend;\r\n\r\nprocedure TJvgReportItem.MouseLeave(Control: TControl);\r\nbegin\r\n if csDesigning in ComponentState then\r\n Exit;\r\n Cursor := crDefault;\r\n inherited MouseLeave(Control);\r\n // SetCursor( Screen.Cursors[crDefault] );\r\nend;\r\n\r\nprocedure TJvgReportItem.WMMouseMove(var Msg: TWMMouse);\r\nvar\r\n I, dX, dY, nLeft, nTop, nWidth, nHeight: Integer;\r\n pt: TPoint;\r\nbegin\r\n inherited;\r\n if Fixed = 0 then\r\n with Msg do\r\n begin\r\n pt.x := Pos.x;\r\n pt.y := Pos.y;\r\n if fSizing then\r\n begin\r\n dX := Pos.x - DownPos.x;\r\n dY := Pos.y - DownPos.y;\r\n Inc(Pos.x, 4);\r\n Inc(Pos.y, 4);\r\n nLeft := Left;\r\n nTop := Top;\r\n nWidth := Width;\r\n nHeight := Height;\r\n case SizeDirection of\r\n 1:\r\n begin\r\n nLeft := Left + dX;\r\n nWidth := Width - dX;\r\n nTop := Top + dY;\r\n nHeight := Height - dY;\r\n end;\r\n 2:\r\n begin\r\n nTop := Top + dY;\r\n nHeight := Height - dY;\r\n end;\r\n 3:\r\n begin\r\n nWidth := Pos.x;\r\n nTop := Top + dY;\r\n nHeight := Height - dY;\r\n end;\r\n\r\n 4:\r\n begin\r\n nLeft := Left + dX;\r\n nWidth := Width - dX;\r\n nHeight := Pos.y;\r\n end;\r\n\r\n 5:\r\n begin\r\n nHeight := Pos.y;\r\n end;\r\n\r\n 6:\r\n begin\r\n nWidth := Pos.x;\r\n nHeight := Pos.y;\r\n end;\r\n 7:\r\n begin\r\n nLeft := Left + dX;\r\n nWidth := Width - dX;\r\n end;\r\n 8:\r\n begin\r\n nWidth := Pos.x;\r\n end;\r\n end;\r\n Left := min(nLeft, nLeft + nWidth);\r\n Top := min(nTop, nTop + nHeight);\r\n Width := abs(nWidth);\r\n Height := abs(nHeight);\r\n if nWidth < 0 then\r\n begin\r\n case SizeDirection of\r\n 1: SizeDirection := 3;\r\n 3: SizeDirection := 1;\r\n 4: SizeDirection := 6;\r\n 6: SizeDirection := 4;\r\n 8: SizeDirection := 7;\r\n 7: SizeDirection := 8;\r\n end;\r\n DownPos.x := Pos.x;\r\n end;\r\n if nHeight < 0 then\r\n begin\r\n case SizeDirection of\r\n 1: SizeDirection := 4;\r\n 2: SizeDirection := 5;\r\n 3: SizeDirection := 6;\r\n 4: SizeDirection := 1;\r\n 5: SizeDirection := 2;\r\n 6: SizeDirection := 3;\r\n end;\r\n DownPos.y := Pos.y;\r\n end;\r\n end\r\n else\r\n for I := 1 to 8 do\r\n if PtInRect(R[I], pt) then\r\n begin\r\n Cursor := Cursors[I];\r\n SizeDirection := I;\r\n Exit;\r\n end;\r\n end;\r\n Cursor := crDefault;\r\n // SetCursor( Screen.Cursors[crDefault] );\r\nend;\r\n\r\nprocedure TJvgReportItem.WMLMouseDown(var Msg: TWMMouse);\r\nbegin\r\n DownPos.x := Msg.Pos.x;\r\n DownPos.y := Msg.Pos.y;\r\n //DownPos := ClientToScreen(DownPos);\r\n fSizing := Cursor <> crDefault;\r\n inherited;\r\nend;\r\n\r\n{procedure TJvgReportItem.WMRMouseDown(var Msg: TWMMouse);\r\nbegin\r\n DownPos.x := Msg.Pos.x;\r\n DownPos.y := Msg.Pos.y;\r\n if Assigned(PopupMenu)\r\n inherited;\r\nend;}\r\n\r\nprocedure TJvgReportItem.WMLMouseUp(var Msg: TWMMouse);\r\nbegin\r\n fSizing := False;\r\n inherited;\r\nend;\r\n\r\nprocedure TJvgReportItem.FontChanged;\r\nbegin\r\n inherited FontChanged;\r\n FName := Font.Name;\r\n FFSize := Font.Size;\r\n FFColor := Font.Color;\r\n FFStyle := 0;\r\n if fsBold in Font.Style then\r\n FFStyle := FFStyle or 1;\r\n if fsItalic in Font.Style then\r\n FFStyle := FFStyle or (1 shl 1);\r\n if fsUnderline in Font.Style then\r\n FFStyle := FFStyle or (1 shl 2);\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvgReportItem.WMSize(var Msg: TWMSize);\r\nbegin\r\n inherited;\r\n // if Assigned(OnResize) then OnResize(Self);\r\nend;\r\n\r\nprocedure TJvgReportItem.SetSelected(Value: Boolean);\r\nbegin\r\n FSelected := Value;\r\n Repaint;\r\nend;\r\n\r\nprocedure TJvgReportItem.SetBkColor(Value: Integer);\r\nbegin\r\n FBkColor := Value;\r\n Color := BkColor;\r\n Repaint;\r\nend;\r\n\r\nprocedure TJvgReportItem.SetBvColor(Value: Integer);\r\nbegin\r\n FBvColor := Value;\r\n Repaint;\r\nend;\r\n\r\nprocedure TJvgReportItem.SetTransparent(Value: Integer);\r\nbegin\r\n FTransparent := Value;\r\n Repaint;\r\nend;\r\n\r\nprocedure TJvgReportItem.SetAlignment(Value: Word);\r\nbegin\r\n FAlignment := Value;\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvgReportItem.SetSideLeft(Value: Word);\r\nbegin\r\n FSideLeft := Value;\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvgReportItem.SetSideTop(Value: Word);\r\nbegin\r\n FSideTop := Value;\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvgReportItem.SetSideRight(Value: Word);\r\nbegin\r\n FSideRight := Value;\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvgReportItem.SetSideBottom(Value: Word);\r\nbegin\r\n FSideBottom := Value;\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvgReportItem.SetPenStyle(Value: Integer);\r\nbegin\r\n FPenStyle := Value;\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvgReportItem.SetPenWidth(Value: Word);\r\nbegin\r\n FPenWidth := Value;\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvgReportItem.SetText(const Value: string);\r\nbegin\r\n if FText <> Value then\r\n begin\r\n FText := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvgReportItem.SetFName(const Value: string);\r\nbegin\r\n FFName := Value;\r\n Canvas.Font.Name := Value;\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvgReportItem.SetFSize(Value: Integer);\r\nbegin\r\n FFSize := Value;\r\n Canvas.Font.Size := Value;\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvgReportItem.SetFColor(Value: Integer);\r\nbegin\r\n FFColor := Value;\r\n Canvas.Font.Color := Value;\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvgReportItem.SetFStyle(Value: Integer);\r\nbegin\r\n FFStyle := Value;\r\n with Canvas.Font do\r\n begin\r\n if (Value and 1) <> 0 then\r\n Style := Style + [fsBold]\r\n else\r\n Style := Style - [fsBold];\r\n if (Value and (1 shl 1)) <> 0 then\r\n Style := Style + [fsItalic]\r\n else\r\n Style := Style - [fsItalic];\r\n if (Value and (1 shl 2)) <> 0 then\r\n Style := Style + [fsUnderline]\r\n else\r\n Style := Style - [fsUnderline];\r\n end;\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvgReportItem.SetContainOLE(Value: Boolean);\r\nbegin\r\n FContainOLE := Value;\r\n if FContainOLE and (not Assigned(OLEContainer)) then\r\n begin\r\n if not Assigned(Parent) then\r\n Exit;\r\n OLEContainer := TOLEContainer.Create(Parent.Parent);\r\n OLEContainer.AutoVerbMenu := False;\r\n OLEContainer.BorderStyle := bsNone;\r\n OLEContainer.Color := clWhite;\r\n OLEContainer.SizeMode := smScale;\r\n OLEContainer.Parent := Parent;\r\n if (OLEContainer.State = osEmpty) and (OLELinkToFile <> '') then\r\n SetOLELinkToFile(OLELinkToFile);\r\n end;\r\nend;\r\n\r\nprocedure TJvgReportItem.SetOLELinkToFile(const Value: string);\r\nbegin\r\n FOLELinkToFile := Value;\r\n if Assigned(OLEContainer) then\r\n begin\r\n OLEContainer.CreateLinkToFile(Value, False);\r\n //OLEContainer.LoadFromFile( Value );\r\n end;\r\nend;\r\n\r\nprocedure TJvgReportItem.SetFixed(Value: Word);\r\nbegin\r\n FFixed := Value;\r\n Repaint;\r\nend;\r\n\r\nprocedure TJvgReportItem.SetOLESizeMode(Value: Word);\r\nbegin\r\n if FOLESizeMode = Value then\r\n Exit;\r\n FOLESizeMode := Value;\r\n if Assigned(OLEContainer) then\r\n OLEContainer.SizeMode := TSizeMode(Value);\r\nend;\r\n\r\nfunction TJvgReportItem.IsContainOLE: Boolean;\r\nbegin\r\n Result := FContainOLE;\r\nend;\r\n\r\n//=== { TJvgReport } =========================================================\r\n\r\nconstructor TJvgReport.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n ParamNames := TStringList.Create;\r\n ParamValues := TStringList.Create;\r\n ParamMasks := TStringList.Create;\r\n FReportList := TStringList.Create;\r\n ParamTypes := TList.Create;\r\n ComponentList := TList.Create;\r\nend;\r\n\r\ndestructor TJvgReport.Destroy;\r\nbegin\r\n FReportList.Free;\r\n ParamNames.Free;\r\n ParamValues.Free;\r\n ParamMasks.Free;\r\n ParamTypes.Free;\r\n ClearReport;\r\n ComponentList.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvgReport.Loaded;\r\nbegin\r\n inherited Loaded;\r\n CreateReport(nil, False);\r\nend;\r\n\r\nprocedure TJvgReport.Save;\r\nvar\r\n msS, msT: TMemoryStream;\r\nbegin\r\n ValidateWnds;\r\n msS := TMemoryStream.Create;\r\n msT := TMemoryStream.Create;\r\n try\r\n msS.WriteComponent(ParentWnd);\r\n msS.Position := 0;\r\n ObjectBinaryToText(msS, msT);\r\n msT.Position := 0;\r\n FReportList.LoadFromStream(msT);\r\n finally\r\n msS.Free;\r\n msT.Free;\r\n end;\r\nend;\r\n\r\nprocedure TJvgReport.SaveToFile(const FileName: string);\r\nvar\r\n fs: TFileStream;\r\nbegin\r\n ValidateWnds;\r\n fs := TFileStream.Create(FileName, fmCreate or fmOpenWrite);\r\n try\r\n fs.WriteComponent(ParentWnd);\r\n finally\r\n fs.Free;\r\n end;\r\nend;\r\n\r\nprocedure TJvgReport.LoadFromFile(const FileName: string);\r\nvar\r\n fs: TFileStream;\r\n ms: TMemoryStream;\r\nbegin\r\n fs := TFileStream.Create(FileName, fmOpenRead);\r\n ms := TMemoryStream.Create;\r\n try\r\n ObjectBinaryToText(fs, ms);\r\n ms.Position := 0;\r\n FReportList.LoadFromStream(ms);\r\n finally\r\n fs.Free;\r\n ms.Free;\r\n end;\r\nend;\r\n\r\n{procedure TJvgReport.Edit;\r\nbegin\r\n CreateReport(True);\r\nend;}\r\n\r\nprocedure TJvgReport.PaintTo(Canvas: TCanvas);\r\nvar\r\n I: Integer;\r\nbegin\r\n OwnerWnd := nil;\r\n ParentWnd := nil;\r\n // ParamNames.Clear;\r\n // ParamMasks.Clear;\r\n // ParamValues.Clear;\r\n // ParamTypes.Clear;\r\n ComponentList.Clear;\r\n CreateReport(ParentWnd, False);\r\n for I := 0 to ComponentList.Count - 1 do\r\n TJvgReportItem(ComponentList[I]).PaintTo(Canvas);\r\nend;\r\n\r\nprocedure TJvgReport.PreviewTo(Window: TWinControl);\r\nbegin\r\n OwnerWnd := Window;\r\n ParentWnd := OwnerWnd;\r\n ParamNames.Clear;\r\n ParamMasks.Clear;\r\n ParamValues.Clear;\r\n ParamTypes.Clear;\r\n ComponentList.Clear;\r\n CreateReport(ParentWnd, False);\r\n // ProcessParams;\r\nend;\r\n\r\nprocedure TJvgReport.Print;\r\nvar\r\n I: Integer;\r\n ScreenDC: HDC;\r\n HS, WS, HP, WP: Integer;\r\nbegin\r\n if Assigned(BeforePrint) then\r\n BeforePrint(Self);\r\n OwnerWnd := TForm(TJvForm).Create(nil); // ahuser: what was the intention here???\r\n TForm(OwnerWnd).WindowState := wsMaximized;\r\n ParentWnd := OwnerWnd;\r\n //OwnerWnd.Show;\r\n try\r\n CreateReport(ParentWnd, True);\r\n if ComponentList.Count = 0 then\r\n Exit;\r\n\r\n Printer.BeginDoc;\r\n ScreenDC := GetDC(HWND_DESKTOP);\r\n\r\n HS := CentimetersToPixels(ScreenDC, 21, True);\r\n WS := CentimetersToPixels(ScreenDC, 21, False);\r\n HP := CentimetersToPixels(Printer.Canvas.Handle, 21, True);\r\n WP := CentimetersToPixels(Printer.Canvas.Handle, 21, False);\r\n\r\n ReleaseDC(HWND_DESKTOP, ScreenDC);\r\n\r\n for I := 0 to ComponentList.Count - 1 do\r\n begin\r\n TJvgReportItem(ComponentList[I]).Left :=\r\n MulDiv(TJvgReportItem(ComponentList[I]).Left, WP, WS);\r\n TJvgReportItem(ComponentList[I]).Top :=\r\n MulDiv(TJvgReportItem(ComponentList[I]).Top, HP, HS);\r\n TJvgReportItem(ComponentList[I]).Width :=\r\n MulDiv(TJvgReportItem(ComponentList[I]).Width, WP, WS);\r\n TJvgReportItem(ComponentList[I]).Height :=\r\n MulDiv(TJvgReportItem(ComponentList[I]).Height, HP, HS);\r\n TJvgReportItem(ComponentList[I]).PenWidth :=\r\n MulDiv(TJvgReportItem(ComponentList[I]).PenWidth, HP, HS);\r\n end;\r\n\r\n for I := 0 to ComponentList.Count - 1 do\r\n with TJvgReportItem(ComponentList[I]) do\r\n begin\r\n PaintTo(Printer.Canvas);\r\n if ContainOLE then\r\n OLEContainer.PaintTo(Printer.Canvas.Handle, Left, Top);\r\n end;\r\n Printer.EndDoc;\r\n\r\n repeat Application.ProcessMessages;\r\n until not TForm(OwnerWnd).Active;\r\n finally\r\n OwnerWnd.Free;\r\n end;\r\nend;\r\n\r\nprocedure TJvgReport.ClearReport;\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := 0 to ComponentList.Count - 1 do\r\n TJvgReportItem(ComponentList[I]).Free;\r\n ComponentList.Count := 0;\r\nend;\r\n\r\nprocedure TJvgReport.CreateReport(ParentWnd: TWinControl; fNeedClearOwner:\r\n Boolean);\r\nvar\r\n ms: TMemoryStream;\r\n P: TParser;\r\n c: Char;\r\n Compon: TComponent;\r\n sName, sClassName: string;\r\n S1, S2: string;\r\n\r\n procedure N2T;\r\n begin\r\n P.NextToken;\r\n P.NextToken;\r\n end;\r\n\r\n procedure Create_Object(const sClassName, sName: string);\r\n var\r\n B: TJvgReportItem;\r\n begin\r\n B := nil;\r\n if sClassName = 'TJvgReportItem' then //...process only TJvgReportItem class\r\n begin\r\n B := TJvgReportItem.Create(OwnerWnd);\r\n B.Report := Self;\r\n end;\r\n if B = nil then\r\n Exit;\r\n ComponentList.Add(B);\r\n c := P.NextToken;\r\n while not P.TokenSymbolIs('end') do\r\n with P do\r\n begin\r\n case c of\r\n '+':\r\n begin\r\n P.NextToken;\r\n B.Text := B.Text + TokenString;\r\n end;\r\n toSymbol:\r\n begin\r\n if TokenString = 'Left' then\r\n begin\r\n N2T;\r\n B.Left := TokenInt;\r\n end;\r\n if TokenString = 'Top' then\r\n begin\r\n N2T;\r\n B.Top := TokenInt;\r\n end;\r\n if TokenString = 'Width' then\r\n begin\r\n N2T;\r\n B.Width := TokenInt;\r\n end;\r\n if TokenString = 'Height' then\r\n begin\r\n N2T;\r\n B.Height := TokenInt;\r\n end;\r\n if TokenString = 'Text' then\r\n begin\r\n N2T;\r\n B.Text := TokenString;\r\n end;\r\n if TokenString = 'BkColor' then\r\n begin\r\n N2T;\r\n B.BkColor := TokenInt;\r\n end;\r\n if TokenString = 'BvColor' then\r\n begin\r\n N2T;\r\n B.BvColor := TokenInt;\r\n end;\r\n if TokenString = 'Transparent' then\r\n begin\r\n N2T;\r\n B.Transparent := TokenInt;\r\n end;\r\n if TokenString = 'Alignment' then\r\n begin\r\n N2T;\r\n B.Alignment := TokenInt;\r\n end;\r\n if TokenString = 'SideLeft' then\r\n begin\r\n N2T;\r\n B.SideLeft := TokenInt;\r\n end;\r\n if TokenString = 'SideTop' then\r\n begin\r\n N2T;\r\n B.SideTop := TokenInt;\r\n end;\r\n if TokenString = 'SideRight' then\r\n begin\r\n N2T;\r\n B.SideRight := TokenInt;\r\n end;\r\n if TokenString = 'SideBottom' then\r\n begin\r\n N2T;\r\n B.SideBottom := TokenInt;\r\n end;\r\n if TokenString = 'PenStyle' then\r\n begin\r\n N2T;\r\n B.PenStyle := TokenInt;\r\n end;\r\n if TokenString = 'PenWidth' then\r\n begin\r\n N2T;\r\n B.PenWidth := TokenInt;\r\n end;\r\n if TokenString = 'CompName' then\r\n begin\r\n N2T;\r\n B.CompName := TokenString;\r\n end;\r\n if TokenString = 'FName' then\r\n begin\r\n N2T;\r\n B.FName := TokenString;\r\n end;\r\n if TokenString = 'FSize' then\r\n begin\r\n N2T;\r\n B.FSize := TokenInt;\r\n end;\r\n if TokenString = 'FColor' then\r\n begin\r\n N2T;\r\n B.FColor := TokenInt;\r\n end;\r\n if TokenString = 'FStyle' then\r\n begin\r\n N2T;\r\n B.FStyle := TokenInt;\r\n end;\r\n if TokenString = 'OLELinkToFile' then\r\n begin\r\n N2T;\r\n B.OLELinkToFile := TokenString;\r\n end;\r\n if TokenString = 'OLESizeMode' then\r\n begin\r\n N2T;\r\n B.OLESizeMode := TokenInt;\r\n end;\r\n if TokenString = 'Fixed' then\r\n begin\r\n N2T;\r\n B.Fixed := TokenInt;\r\n end;\r\n end;\r\n end;\r\n c := NextToken;\r\n end;\r\n\r\n B.Parent := ParentWnd;\r\n try\r\n B.ContainOLE := B.OLELinkToFile <> '';\r\n except\r\n S1 := RsOLELinkedObjectNotFound;\r\n S2 := RsErrorText;\r\n Application.MessageBox(PChar(S1), PChar(S2),\r\n MB_APPLMODAL or MB_OK or MB_ICONSTOP);\r\n end;\r\n B.Name := sName;\r\n if B.CompName = '' then\r\n SetUnicalName(B);\r\n AnalyzeParams(B, B.CompName);\r\n end;\r\n\r\n procedure ClearOwner;\r\n var\r\n I: Integer;\r\n begin\r\n // ParamNames.Clear;\r\n // ParamMasks.Clear;\r\n // ParamValues.Clear;\r\n // ParamTypes.Clear;\r\n ComponentList.Clear;\r\n if Assigned(ParentWnd) then\r\n begin\r\n with ParentWnd do\r\n for I := ControlCount - 1 downto 0 do\r\n if Controls[I] is TJvgReportItem then\r\n RemoveControl(Controls[I]);\r\n with OwnerWnd do\r\n for I := ComponentCount - 1 downto 0 do\r\n begin\r\n if Components[I] is TJvgReportItem then\r\n begin\r\n Compon := Components[I];\r\n RemoveComponent(Compon);\r\n Compon.Free;\r\n end;\r\n end;\r\n end;\r\n end;\r\n\r\nbegin\r\n ValidateWnds;\r\n if fNeedClearOwner then\r\n ClearOwner\r\n else\r\n ClearReport;\r\n ms := TMemoryStream.Create;\r\n FReportList.SaveToStream(ms);\r\n ms.Position := 0;\r\n P := TParser.Create(ms);\r\n c := P.Token;\r\n with P do\r\n repeat\r\n if TokenSymbolIs('object') then //...only noname objects!\r\n begin\r\n NextToken;\r\n sClassName := TokenString;\r\n try\r\n Create_Object(sClassName, sName);\r\n except\r\n S1 := RsErrorReadingComponent;\r\n S2 := RsErrorText;\r\n Application.MessageBox(PChar(S1), PChar(S2),\r\n MB_APPLMODAL or MB_OK or MB_ICONSTOP);\r\n end;\r\n end;\r\n c := NextToken;\r\n until c = toEOF;\r\n\r\n P.Free;\r\n ms.Free;\r\nend;\r\n\r\nfunction TJvgReport.AddComponent: TJvgReportItem;\r\nbegin\r\n //AnalyzeParams( ReportComponent );\r\n ValidateWnds;\r\n Result := TJvgReportItem.Create(OwnerWnd);\r\n Result.Report := Self;\r\n SetUnicalName(Result);\r\n Result.Parent := ParentWnd;\r\n ComponentList.Add(Result);\r\nend;\r\n\r\nprocedure TJvgReport.SetUnicalName(laBevel: TJvgReportItem);\r\nvar\r\n I: Integer;\r\n\r\n function ComponentExists(No: Integer): Boolean;\r\n var\r\n I: Integer;\r\n begin\r\n Result := False;\r\n for I := 0 to OwnerWnd.ComponentCount - 1 do\r\n if OwnerWnd.Components[I] is TJvgReportItem then\r\n if TJvgReportItem(OwnerWnd.Components[I]).CompName = 'Component' +\r\n IntToStr(No) then\r\n begin\r\n Result := True;\r\n Break;\r\n end;\r\n end;\r\nbegin\r\n I := 0;\r\n repeat\r\n Inc(I);\r\n until not ComponentExists(I);\r\n laBevel.CompName := 'Component' + IntToStr(I);\r\nend;\r\n\r\nprocedure TJvgReport.AnalyzeParams(Item: TJvgReportItem; const DefName: string);\r\nvar\r\n LastPos: Integer;\r\n SList: TStringList;\r\n ParamType: TJvgReportParamKind;\r\n ParamText, ParamName, ParamMask, ParamValue: string;\r\n\r\n function ExtractParam(Item: TJvgReportItem; var SrchPos: Integer;\r\n var ParamName: string; var ParamType: TJvgReportParamKind): Boolean;\r\n var\r\n I, J: Integer;\r\n f: Boolean;\r\n Text: string;\r\n begin\r\n Result := False;\r\n Text := Item.Text;\r\n if Length(Text) = 0 then\r\n Exit;\r\n f := False;\r\n for I := SrchPos to Length(Text) - 1 do\r\n if Text[I] = '#' then\r\n begin\r\n f := True;\r\n Break;\r\n end;\r\n\r\n if not f then\r\n Exit;\r\n if Text[I - 1] = '{' then\r\n ParamType := gptEdit\r\n else\r\n if Text[I - 1] = '<' then\r\n ParamType := gptRadio\r\n else\r\n if Text[I - 1] = '[' then\r\n ParamType := gptCheck\r\n else\r\n ParamType := gptUnknown;\r\n\r\n if not f or (ParamType = gptUnknown) then\r\n Exit;\r\n SrchPos := I + 1;\r\n f := False;\r\n for I := SrchPos to Length(Text) do\r\n if (Text[I] = '}') or (Text[I] = ']') or (Text[I] = '>') then\r\n begin\r\n f := True;\r\n Break;\r\n end;\r\n if not f then\r\n Exit;\r\n ParamName := Copy(Text, SrchPos, I - SrchPos);\r\n\r\n J := ParamNames.IndexOf(ParamName);\r\n if J <> -1 then\r\n Item.PrintText := Copy(Text, 0, SrchPos - 3) + ParamValues[J] +\r\n Copy(Text, I + 1, 255);\r\n\r\n Result := True;\r\n end;\r\n\r\nbegin\r\n LastPos := 0;\r\n SList := TStringList.Create;\r\n try\r\n repeat\r\n if ExtractParam(Item, LastPos, ParamText, ParamType) then\r\n begin\r\n ParamMask := '';\r\n ParamValue := '';\r\n ParamTypes.Add(Pointer(ParamType));\r\n if ParamType = gptEdit then\r\n begin\r\n if ParamText = '' then\r\n ParamText := DefName;\r\n SList.CommaText := ParamText;\r\n if SList.Count = 0 then\r\n continue;\r\n ParamName := SList[0];\r\n if SList.Count > 1 then\r\n ParamMask := SList[1];\r\n if SList.Count > 2 then\r\n ParamValue := SList[2];\r\n end\r\n else\r\n ParamName := ParamText;\r\n if ParamNames.IndexOf(ParamName) <> -1 then\r\n continue; //...already exists\r\n ParamNames.Add(ParamName);\r\n ParamMasks.Add(ParamMask);\r\n ParamValues.Add(ParamValue);\r\n // else ParamValues[ParamIndex] := sParamValue;\r\n end\r\n else\r\n Break;\r\n until False;\r\n finally\r\n SList.Free;\r\n end;\r\nend;\r\n\r\nfunction TJvgReport.SetParam(const sParamName, sParamValue: string): Boolean;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := False;\r\n I := ParamNames.IndexOf(sParamName);\r\n if I <> -1 then\r\n begin\r\n Result := True;\r\n ParamValues[I] := sParamValue;\r\n end;\r\nend;\r\n\r\nfunction TJvgReport.GetParam(const sParamName: string; var sParamValue: string):\r\n Boolean;\r\nvar\r\n ParamIndex: Integer;\r\nbegin\r\n ParamIndex := ParamNames.IndexOf(sParamName);\r\n if ParamIndex = -1 then\r\n Result := False\r\n else\r\n begin\r\n Result := True;\r\n sParamValue := ParamValues[ParamIndex];\r\n end;\r\nend;\r\n\r\nprocedure TJvgReport.ValidateWnds;\r\nbegin\r\n OwnerWnd := ParentWnd;\r\n // if (OwnerWnd=nil)or(ParentWnd=nil) then raise Exception.Create('TJvgReport: Unassigned Owner or Parent window.');\r\nend;\r\n\r\nfunction TJvgReport.GetReportText: TStringList;\r\nbegin\r\n Result := FReportList;\r\nend;\r\n\r\nprocedure TJvgReport.SetReportText(Value: TStringList);\r\nbegin\r\n FReportList.Assign(Value);\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvgReportParamsEditor.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvgReportParamsEditor.PAS, released on 2003-01-15.\r\n\r\nThe Initial Developer of the Original Code is Andrey V. Chudin, [chudin att yandex dott ru]\r\nPortions created by Andrey V. Chudin are Copyright (C) 2003 Andrey V. Chudin.\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\nMichael Beck [mbeck att bigfoot dott com].\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvgReportParamsEditor.pas 12741 2010-04-02 10:43:13Z ahuser $\r\n\r\nunit JvgReportParamsEditor;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,\r\n Dialogs, Grids, StdCtrls, Buttons, ExtCtrls, Mask,\r\n JvgStringGrid, JvgReport;\r\n\r\ntype\r\n TJvgReportParamsEditor = class(TComponent)\r\n private\r\n FReport: TJvgReport;\r\n procedure SetReport(const Value: TJvgReport);\r\n protected\r\n procedure Notification(AComponent: TComponent; Operation: TOperation); override;\r\n public\r\n procedure Edit;\r\n published\r\n property Report: TJvgReport read FReport write SetReport;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvgReportParamsEditor.pas $';\r\n Revision: '$Revision: 12741 $';\r\n Date: '$Date: 2010-04-02 12:43:13 +0200 (ven. 02 avr. 2010) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n JvJVCLUtils;\r\n\r\nprocedure TJvgReportParamsEditor.Notification(AComponent: TComponent;\r\n Operation: TOperation);\r\nbegin\r\n inherited Notification(AComponent, Operation);\r\n if (AComponent = Report) and (Operation = opRemove) then\r\n Report := nil;\r\nend;\r\n\r\nprocedure TJvgReportParamsEditor.Edit;\r\n// var\r\n// Form: TJvgReportParamsForm;\r\n// Label_: TLabel;\r\n// Edit_: TCustomEdit;\r\n// Check_: TCheckBox;\r\n// Radio_: TRadioGroup;\r\n// SList: TStringList;\r\n// y, x, i, j, EditLeft, LastHeight: Integer;\r\nbegin //temporary commented\r\n {\r\n if Report = nil then\r\n Exit;\r\n\r\n if Report.ParamNames.Count = 0 then\r\n for i := 0 to Report.ReportText.Count - 1 do\r\n Report.AnalyzeParams(Report.ReportText[i], '');\r\n\r\n Form := TJvgReportParamsForm.Create(nil);\r\n y := 4;\r\n EditLeft := 0;\r\n SList := nil;\r\n try\r\n for i := 0 to Report.ParamNames.Count-1 do\r\n with Report do\r\n begin\r\n case TglRepParamType(ParamTypes[i]) of\r\n gptEdit:\r\n begin\r\n Label_ := TLabel.Create(Form);\r\n try\r\n if StrToInt(ParamMasks[i]) > 50 then\r\n Edit_ := TMemo.Create(Form);\r\n TMemo(Edit_).Height := Form.Canvas.TextHeight('x') * StrToInt(ParamMasks[i]) div 50;\r\n except\r\n Edit_ := TMaskEdit.Create(Form);\r\n end;\r\n Label_.Parent := Form.SB;\r\n Label_.Left := 3;\r\n Label_.Top := y;\r\n Label_.Caption := ParamNames[i];\r\n x := Form.Canvas.TextWidth(ParamNames[i]);\r\n Edit_.Parent := Form.SB;\r\n Edit_.Left := x + 6;\r\n Edit_.Top := y;\r\n Edit_.Text := ParamValues[i];\r\n try\r\n if StrToInt(ParamMasks[i])>50 then\r\n Edit_.Width := Form.Canvas.TextWidth('x')* 50\r\n else\r\n Edit_.Width := Form.Canvas.TextWidth('x')*StrToInt(ParamMasks[i]);\r\n except\r\n TMaskEdit(Edit_).EditMask := ParamMasks[i];\r\n if Edit_.Width < Form.Canvas.TextWidth('x')*Length(ParamMasks[i]) then\r\n Edit_.Width := Form.Canvas.TextWidth('x')*Length(ParamMasks[i]);\r\n end;\r\n if Edit_.Left > EditLeft then\r\n EditLeft := Edit_.Left;\r\n Inc(x, Edit_.Width);\r\n LastHeight := Edit_.Height;\r\n end;\r\n gptRadio:\r\n begin\r\n Radio_ := TRadioGroup.Create(Form);\r\n Radio_.Parent := Form.SB;\r\n Radio_.Left := 3;\r\n Radio_.Top := y;\r\n if not Assigned(SList) then\r\n SList := TStringList.Create;\r\n SList.CommaText := ParamNames[i];\r\n Radio_.Caption := SList[0];\r\n for j := 1 to SList.Count-1 do\r\n Radio_.Items.Add(SList[j]);\r\n\r\n Radio_.Height := (Form.Canvas.TextHeight('ly')+3) * SList.Count-1;\r\n LastHeight := Radio_.Height;\r\n end;\r\n gptCheck:\r\n begin\r\n Check_ := TCheckBox.Create(Form);\r\n Check_.Parent := Form.SB;\r\n Check_.Left := 3;\r\n Check_.Top := y;\r\n Check_.Caption := ParamNames[i];\r\n LastHeight := Check_.Height;\r\n end;\r\n end;\r\n\r\n if x+10 >= Form.ClientWidth then\r\n Form.ClientWidth := x + 10;\r\n Inc(y, LastHeight);\r\n end;\r\n\r\n for i := 0 to Form.SB.ControlCount-1 do\r\n if Form.SB.Controls[i] is TMaskEdit then\r\n TMaskEdit(Form.SB.Controls[i]).Left := EditLeft;\r\n\r\n Form.ClientHeight := Form.Panel1.Height + y + 10;\r\n\r\n Form.ShowModal;\r\n finally\r\n SList.Free;\r\n Form.Free;\r\n end;\r\n }\r\nend;\r\n\r\nprocedure TJvgReportParamsEditor.SetReport(const Value: TJvgReport);\r\nbegin\r\n ReplaceComponentReference(Self, Value, TComponent(FReport));\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend." }, { "path": "External/Jedi/Jvcl/run/JvgShade.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvgShade.PAS, released on 2003-01-15.\r\n\r\nThe Initial Developer of the Original Code is Andrey V. Chudin, [chudin att yandex dott ru]\r\nPortions created by Andrey V. Chudin are Copyright (C) 2003 Andrey V. Chudin.\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\nMichael Beck [mbeck att bigfoot dott com].\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvgShade.pas 13104 2011-09-07 06:50:43Z obones $\r\n\r\nunit JvgShade;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, Messages, SysUtils, Classes, Graphics, Controls,\r\n Forms, Dialogs, ExtCtrls,\r\n JvExtComponent,\r\n JvgTypes, JvgUtils, JvgCommClasses;\r\n\r\ntype\r\n TJvgShade = class(TJvCustomPanel)\r\n private\r\n FImage: TBitmap;\r\n FLoaded: Boolean;\r\n FNeedRebuildImage: Boolean;\r\n procedure WMSize(var Msg: TMessage); message WM_SIZE;\r\n protected\r\n property Color;\r\n procedure Paint; override;\r\n public\r\n property Canvas;\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n procedure RemakeBackground;\r\n published\r\n property Align;\r\n property Enabled;\r\n property Height default 105;\r\n property Image: TBitmap read FImage write FImage;\r\n property Visible;\r\n property Width default 105;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvgShade.pas $';\r\n Revision: '$Revision: 13104 $';\r\n Date: '$Date: 2011-09-07 08:50:43 +0200 (mer. 07 sept. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\n{$IFDEF HAS_UNIT_SYSTEM_UITYPES}\r\nuses\r\n System.UITypes;\r\n{$ENDIF HAS_UNIT_SYSTEM_UITYPES}\r\n\r\nconstructor TJvgShade.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n Width := 105;\r\n Height := 105;\r\n FImage := TBitmap.Create;\r\n FLoaded := True;\r\n FNeedRebuildImage := (csDesigning in ComponentState) and\r\n not (csLoading in ComponentState);\r\nend;\r\n\r\ndestructor TJvgShade.Destroy;\r\nbegin\r\n FImage.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvgShade.WMSize(var Msg: TMessage);\r\nbegin\r\n if (csDesigning in ComponentState) and not (csLoading in ComponentState) then\r\n RemakeBackground;\r\nend;\r\n\r\nprocedure TJvgShade.Paint;\r\nvar\r\n I, J: Integer;\r\n// N: Integer;\r\nconst\r\n cShiftColor = TColor($003939);\r\nbegin\r\n// N := 0;\r\n if FNeedRebuildImage then\r\n begin\r\n Image.Width := Width;\r\n Image.Height := Height;\r\n //..prepare tabula rasa :)\r\n Image.Canvas.Brush.Color := Parent.Brush.Color;\r\n Image.Canvas.Brush.Style := bsSolid;\r\n Image.Canvas.FillRect(ClientRect);\r\n GetParentImageRect(Self, Bounds(Left, Top, Width, Height),\r\n Image.Canvas.Handle);\r\n for J := 0 to Height-1 do\r\n for I := 0 to Width-1 do\r\n // if Image.Canvas.Pixels[I, J] > cShiftColor then\r\n begin\r\n// if N <> Image.Canvas.Pixels[I, J] then\r\n begin\r\n //N := Image.Canvas.Pixels[I, J];\r\n //Form1.Memo1.Lines.Add(Format('%x', [N]));\r\n end;\r\n // if Image.Canvas.Pixels[I, J] = $C8B8A0 then\r\n// RGB := Image.Canvas.Pixels[I, J];\r\n// R := Byte(RGB shr 16);\r\n// G := Byte(RGB shr 8);\r\n// B := Byte(RGB);\r\n // RShift := $\r\n Image.Canvas.Pixels[I, J] := Image.Canvas.Pixels[I, J] + cShiftColor;\r\n end;\r\n FNeedRebuildImage := False;\r\n end;\r\n\r\n BitBlt(Canvas.Handle, 0, 0, Width, Height, Image.Canvas.Handle, 0, 0, SRCCOPY);\r\n\r\n if csDesigning in ComponentState then\r\n with Canvas do\r\n begin\r\n Pen.Color := clBlack;\r\n Pen.Style := psDash;\r\n Brush.Style := bsClear;\r\n Rectangle(0, 0, Width, Height);\r\n end;\r\nend;\r\n\r\nprocedure TJvgShade.RemakeBackground;\r\nbegin\r\n FNeedRebuildImage := True;\r\n Invalidate;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvgShadow.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvgShadow.PAS, released on 2003-01-15.\r\n\r\nThe Initial Developer of the Original Code is Andrey V. Chudin, [chudin att yandex dott ru]\r\nPortions created by Andrey V. Chudin are Copyright (C) 2003 Andrey V. Chudin.\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\nMichael Beck [mbeck att bigfoot dott com].\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvgShadow.pas 12741 2010-04-02 10:43:13Z ahuser $\r\n\r\nunit JvgShadow;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, Messages, Classes, Controls, Graphics, Forms, Dialogs,\r\n StdCtrls, ExtCtrls, SysUtils, Mask,\r\n JvComponent,\r\n JvgCommClasses, JvgTypes, Jvg3DColors;\r\n\r\ntype\r\n TJvgShadow = class(TJvGraphicControl)\r\n private\r\n FControl: TControl;\r\n FStyle: TJvgTextBoxStyle;\r\n FStyleActive: TJvgTextBoxStyle;\r\n FShadowed: Boolean;\r\n FShadowDepth: Word;\r\n FShadowImage: TBitmap;\r\n FShadowImageBuff: TBitmap;\r\n FAutoTransparentColor: TglAutoTransparentColor;\r\n FTransparentShadow: Boolean;\r\n FMaskedShadow: Boolean;\r\n FTransparentColor: TColor;\r\n FMaskedFromColor: TColor;\r\n FMaskedToColor: TColor;\r\n FAfterPaint: TNotifyEvent;\r\n FOnEnter: TNotifyEvent;\r\n FOnExit: TNotifyEvent;\r\n FThreeDColors: TJvg3DLocalColors;\r\n FDontUseDefaultImage: Boolean;\r\n FNeedRecreateShadowImageBuff: Boolean;\r\n procedure CreateShadowImageBuff(R: TRect);\r\n procedure CreateDefaultShadowImage;\r\n procedure SetControl(Value: TControl);\r\n procedure SetShadowed(Value: Boolean);\r\n procedure SetShadowDepth(Value: Word);\r\n procedure SetShadowImage(Value: TBitmap);\r\n function GetShadowImage: TBitmap;\r\n procedure SetAutoTransparentColor(Value: TglAutoTransparentColor);\r\n procedure SetTransparentShadow(Value: Boolean);\r\n procedure SetMaskedShadow(Value: Boolean);\r\n procedure SetTransparentColor(Value: TColor);\r\n procedure SetMaskedFromColor(Value: TColor);\r\n procedure SetMaskedToColor(Value: TColor);\r\n procedure CMFontChanged(var Msg: TMessage); message CM_FONTCHANGED;\r\n procedure ControlEnter(Sender: TObject);\r\n procedure ControlExit(Sender: TObject);\r\n procedure SmthChanged(Sender: TObject);\r\n // procedure SetDigitsOnly(Value: Boolean);\r\n protected\r\n procedure Loaded; override;\r\n procedure Paint; override;\r\n procedure SetParent(Value: TWinControl); override;\r\n procedure Notification(AComponent: TComponent; Operation: TOperation); override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n published\r\n property Anchors;\r\n property Align;\r\n property Control: TControl read FControl write SetControl;\r\n property Visible;\r\n property Style: TJvgTextBoxStyle read FStyle write FStyle;\r\n property StyleActive: TJvgTextBoxStyle read FStyleActive write FStyleActive;\r\n // property DigitsOnly: Boolean read FDigitsOnly write SetDigitsOnly default False;\r\n property Shadowed: Boolean read FShadowed write SetShadowed default True;\r\n property ShadowDepth: Word read FShadowDepth write SetShadowDepth default 6;\r\n property ShadowImage: TBitmap read GetShadowImage write SetShadowImage stored FDontUseDefaultImage;\r\n property AutoTransparentColor: TglAutoTransparentColor\r\n read FAutoTransparentColor write SetAutoTransparentColor default ftcRightTopPixel;\r\n property TransparentShadow: Boolean read FTransparentShadow\r\n write SetTransparentShadow default True;\r\n property MaskedShadow: Boolean read FMaskedShadow write SetMaskedShadow\r\n default False;\r\n property TransparentColor: TColor read FTransparentColor\r\n write SetTransparentColor default clOlive;\r\n property MaskedFromColor: TColor read FMaskedFromColor\r\n write SetMaskedFromColor default clOlive;\r\n property MaskedToColor: TColor read FMaskedToColor\r\n write SetMaskedToColor default clBtnFace;\r\n property AfterPaint: TNotifyEvent read FAfterPaint write FAfterPaint;\r\n property OnControlEnter: TNotifyEvent read FOnEnter write FOnEnter;\r\n property OnControlExit: TNotifyEvent read FOnExit write FOnExit;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvgShadow.pas $';\r\n Revision: '$Revision: 12741 $';\r\n Date: '$Date: 2010-04-02 12:43:13 +0200 (ven. 02 avr. 2010) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n JvgUtils, JvJVCLUtils;\r\n\r\nconstructor TJvgShadow.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FThreeDColors := TJvg3DLocalColors.Create(Self);\r\n FStyle := TJvgTextBoxStyle.Create;\r\n FStyleActive := TJvgTextBoxStyle.Create;\r\n FTransparentColor := clOlive;\r\n if (csDesigning in ComponentState) and not (csLoading in ComponentState) then\r\n CreateDefaultShadowImage;\r\n // FStyle.Inner := bvRaised;\r\n // FStyleActive.Inner := bvRaised;\r\n // FStyleActive.Bold := True;\r\n // FStyleActive.HighlightColor := clWhite;\r\n\r\n Height := 23;\r\n Width := 120;\r\n FShadowed := True;\r\n FShadowDepth := 6;\r\n FAutoTransparentColor := ftcRightTopPixel;\r\n FTransparentShadow := True;\r\n FTransparentColor := clOlive;\r\n FMaskedFromColor := clOlive;\r\n FMaskedToColor := clBtnFace;\r\n FStyle.OnChanged := SmthChanged;\r\n FStyleActive.OnChanged := SmthChanged;\r\n\r\n FNeedRecreateShadowImageBuff := True;\r\nend;\r\n\r\ndestructor TJvgShadow.Destroy;\r\nbegin\r\n FStyle.Free;\r\n FStyleActive.Free;\r\n FThreeDColors.Free;\r\n FShadowImage.Free;\r\n FShadowImageBuff.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvgShadow.Loaded;\r\nbegin\r\n inherited Loaded;\r\n if FShadowed then\r\n begin\r\n FShadowImageBuff := TBitmap.Create;\r\n if FShadowImage = nil then\r\n CreateDefaultShadowImage;\r\n end;\r\nend;\r\n\r\nprocedure TJvgShadow.Paint;\r\nvar\r\n R: TRect;\r\n CurrStyle: TJvgTextBoxStyle;\r\n OldPointer: Pointer;\r\nbegin\r\n R := ClientRect;\r\n if Shadowed then\r\n begin\r\n Inc(R.Left, FShadowDepth);\r\n Inc(R.Top, FShadowDepth);\r\n if (csDesigning in ComponentState) or FNeedRecreateShadowImageBuff then\r\n begin\r\n CreateShadowImageBuff(R);\r\n FNeedRecreateShadowImageBuff := False;\r\n end;\r\n BitBlt(Canvas.Handle, R.Left, R.Top, R.Right - R.Left, R.Bottom - R.Top,\r\n FShadowImageBuff.Canvas.Handle, 0, 0, SRCCOPY);\r\n OffsetRect(R, -FShadowDepth, -FShadowDepth);\r\n end\r\n else\r\n begin\r\n Dec(R.Right);\r\n Dec(R.Bottom);\r\n end;\r\n\r\n if Assigned(Control) and (Control is TWinControl) and\r\n TWinControl(Control).Focused then\r\n CurrStyle := FStyleActive\r\n else\r\n CurrStyle := FStyle;\r\n\r\n with CurrStyle do\r\n begin\r\n FThreeDColors.Highlight := HighlightColor;\r\n FThreeDColors.Shadow := ShadowColor;\r\n OldPointer := glGlobalData.lp3DColors;\r\n glGlobalData.lp3DColors := FThreeDColors;\r\n R := DrawBoxEx(Canvas.Handle, R, Sides, Inner, Outer,\r\n Bold, Style.BackgroundColor, False);\r\n glGlobalData.lp3DColors := OldPointer;\r\n end;\r\n\r\n if Assigned(Control) then\r\n begin\r\n OffsetRect(R, Left, Top);\r\n if Control.Left <> R.Left then\r\n Control.Left := R.Left;\r\n if Control.Top <> R.Top then\r\n Control.Top := R.Top;\r\n if not EqualRect(Control.ClientRect, Bounds(0, 0, R.Right - R.Left + 1,\r\n R.Bottom - R.Top + 1)) then\r\n Control.SetBounds(R.Left, R.Top, R.Right - R.Left + 1, R.Bottom - R.Top + 1);\r\n end;\r\n if Assigned(FAfterPaint) then\r\n FAfterPaint(Self);\r\nend;\r\n\r\nprocedure TJvgShadow.SetParent(Value: TWinControl);\r\nbegin\r\n inherited SetParent(Value);\r\n if Assigned(Control) then\r\n if not (csDestroying in ComponentState) then\r\n Control.Parent := Value;\r\nend;\r\n\r\nprocedure TJvgShadow.Notification(AComponent: TComponent;\r\n Operation: TOperation);\r\nbegin\r\n inherited Notification(AComponent, Operation);\r\n if (AComponent = Control) and (Operation = opRemove) then\r\n Control := nil;\r\nend;\r\n\r\nprocedure TJvgShadow.CMFontChanged(var Msg: TMessage);\r\nbegin\r\n if Assigned(Control) and (Control is TControl) then\r\n TJvgPublicWinControl(Control).Font := Font;\r\nend;\r\n\r\n{procedure TJvgShadow.OnKeyPress_(Sender: TObject; var Key: Char);\r\nbegin\r\n if FDigitsOnly then\r\n begin\r\n if Key = #8 then exit\r\n // if Length(ACodeEdit.Text)>=CodeDigitsCount then Key := #0\r\n else\r\n if (Key<'0')or(Key>'9') then Key := #0;\r\n end;\r\n if Assigned(FOnKeyPress) then FOnKeyPress(Self, Key);\r\nend;\r\n}\r\n\r\nprocedure TJvgShadow.ControlEnter(Sender: TObject);\r\nbegin\r\n if Assigned(FOnEnter) then\r\n FOnEnter(Self);\r\n if Assigned(Control) then\r\n begin\r\n TJvgPublicWinControl(Control).Font.Color := StyleActive.TextColor;\r\n TJvgPublicWinControl(Control).Color := StyleActive.BackgroundColor;\r\n Repaint;\r\n end;\r\nend;\r\n\r\nprocedure TJvgShadow.ControlExit(Sender: TObject);\r\nbegin\r\n if Assigned(FOnExit) then\r\n FOnExit(Self);\r\n if Assigned(Control) then\r\n begin\r\n TJvgPublicWinControl(Control).Font.Color := Style.TextColor;\r\n TJvgPublicWinControl(Control).Color := Style.BackgroundColor;\r\n Repaint;\r\n end;\r\nend;\r\n\r\nprocedure TJvgShadow.SmthChanged(Sender: TObject);\r\nbegin\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvgShadow.CreateShadowImageBuff(R: TRect);\r\nbegin\r\n CreateDefaultShadowImage;\r\n with FShadowImageBuff do\r\n begin\r\n Width := R.Right - R.Left;\r\n Height := R.Bottom - R.Top;\r\n Canvas.Brush.Color := clBtnFace;\r\n Canvas.Brush.Style := bsSolid;\r\n Canvas.FillRect(Bounds(0, 0, Width, Height));\r\n end;\r\n if FTransparentShadow then\r\n GetParentImageRect(Self, Bounds(Left + R.Left, Top + R.Top,\r\n FShadowImageBuff.Width, FShadowImageBuff.Height),\r\n FShadowImageBuff.Canvas.Handle);\r\n\r\n CreateBitmapExt(FShadowImageBuff.Canvas.Handle, FShadowImage,\r\n Rect(0, 0, FShadowImageBuff.Width, FShadowImageBuff.Height), 0, 0,\r\n fwoTile, fdsDefault, FTransparentShadow, FTransparentColor, 0);\r\n if FMaskedShadow then\r\n JvgUtils.ChangeBitmapColor(FShadowImageBuff, FMaskedFromColor, FMaskedToColor);\r\nend;\r\n\r\nprocedure TJvgShadow.CreateDefaultShadowImage;\r\nconst\r\n cSize = 8;\r\nvar\r\n I, J: Byte;\r\nbegin\r\n if Assigned(FShadowImage) then\r\n FShadowImage.Free;\r\n if Assigned(FShadowImageBuff) then\r\n FShadowImageBuff.Free;\r\n FShadowImage := TBitmap.Create;\r\n FShadowImageBuff := TBitmap.Create;\r\n FShadowImage.Width := cSize;\r\n FShadowImage.Height := cSize;\r\n I := 0;\r\n J := 0;\r\n FShadowImage.Canvas.FillRect(Rect(0, 0, cSize, cSize));\r\n while J < cSize do\r\n begin\r\n while I < cSize do\r\n begin\r\n FShadowImage.Canvas.Pixels[I, J] := 0;\r\n Inc(I, 2);\r\n end;\r\n Inc(J);\r\n if I = 8 then\r\n I := 1\r\n else\r\n I := 0;\r\n end;\r\n FTransparentColor := clWhite;\r\n FDontUseDefaultImage := False;\r\nend;\r\n\r\nprocedure TJvgShadow.SetControl(Value: TControl);\r\nbegin\r\n ReplaceComponentReference(Self, Value, TComponent(fControl));\r\n if FControl is TWinControl then\r\n begin\r\n TJvgPublicWinControl(FControl).OnEnter := ControlEnter;\r\n TJvgPublicWinControl(FControl).OnExit := ControlExit;\r\n end;\r\n Invalidate;\r\nend;\r\n\r\n{\r\nprocedure TJvgShadow.SetText( Value: string );\r\nvar\r\n I: Integer;\r\n fIsDigit: Boolean;\r\nbegin\r\n if DigitsOnly then\r\n begin\r\n Value := trim( Value );\r\n fIsDigit := True;\r\n try\r\n I := StrToInt( Value );\r\n except\r\n fIsDigit := False;\r\n end;\r\n if fIsDigit then\r\n Control.Text := Value;\r\n end\r\n else Control.Text := Value;\r\n\r\nend;\r\n}\r\n\r\n(*\r\nprocedure TJvgShadow.SetDigitsOnly(Value: Boolean);\r\n//var\r\n// I: Integer;\r\nbegin //{$O-}\r\n { if DigitsOnly = Value then\r\n exit;\r\n FDigitsOnly := Value;\r\n if DigitsOnly then\r\n begin\r\n Control.Text := trim( Control.Text );\r\n try\r\n I := StrToInt( Control.Text );\r\n except\r\n Control.Text := '';\r\n end;\r\n end;}\r\n // {$O+}\r\nend;\r\n*)\r\n\r\nprocedure TJvgShadow.SetShadowed(Value: Boolean);\r\nbegin\r\n if FShadowed <> Value then\r\n begin\r\n FShadowed := Value;\r\n if FShadowed and (FShadowImage = nil) then\r\n CreateDefaultShadowImage;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvgShadow.SetShadowDepth(Value: Word);\r\nbegin\r\n if FShadowDepth <> Value then\r\n begin\r\n FShadowDepth := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvgShadow.SetShadowImage(Value: TBitmap);\r\nbegin\r\n if not Assigned(FShadowImage) then\r\n FShadowImage := TBitmap.Create;\r\n FShadowImage.Assign(Value);\r\n FDontUseDefaultImage := True;\r\n Repaint;\r\nend;\r\n\r\nfunction TJvgShadow.GetShadowImage: TBitmap;\r\nbegin\r\n if not Assigned(FShadowImage) then\r\n FShadowImage := TBitmap.Create;\r\n Result := FShadowImage;\r\nend;\r\n\r\nprocedure TJvgShadow.SetAutoTransparentColor(Value: TglAutoTransparentColor);\r\nbegin\r\n if FAutoTransparentColor <> Value then\r\n begin\r\n FAutoTransparentColor := Value;\r\n FTransparentColor := GetTransparentColor(FShadowImage, Value);\r\n FNeedRecreateShadowImageBuff := True;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvgShadow.SetTransparentShadow(Value: Boolean);\r\nbegin\r\n if FTransparentShadow <> Value then\r\n begin\r\n FTransparentShadow := Value;\r\n FNeedRecreateShadowImageBuff := True;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvgShadow.SetMaskedShadow(Value: Boolean);\r\nbegin\r\n if FMaskedShadow <> Value then\r\n begin\r\n FMaskedShadow := Value;\r\n FNeedRecreateShadowImageBuff := True;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvgShadow.SetTransparentColor(Value: TColor);\r\nbegin\r\n if FTransparentColor <> Value then\r\n begin\r\n FTransparentColor := Value;\r\n FNeedRecreateShadowImageBuff := FTransparentShadow;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvgShadow.SetMaskedFromColor(Value: TColor);\r\nbegin\r\n if FMaskedFromColor <> Value then\r\n begin\r\n FMaskedFromColor := Value;\r\n FNeedRecreateShadowImageBuff := FMaskedShadow;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvgShadow.SetMaskedToColor(Value: TColor);\r\nbegin\r\n if FMaskedToColor <> Value then\r\n begin\r\n FMaskedToColor := Value;\r\n FNeedRecreateShadowImageBuff := FMaskedShadow;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvgSpeedButton.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvgSpeedButton.PAS, released on 2003-01-15.\r\n\r\nThe Initial Developer of the Original Code is Andrey V. Chudin, [chudin att yandex dott ru]\r\nPortions created by Andrey V. Chudin are Copyright (C) 2003 Andrey V. Chudin.\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\nMichael Beck [mbeck att bigfoot dott com].\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvgSpeedButton.pas 12461 2009-08-14 17:21:33Z obones $\r\n\r\nunit JvgSpeedButton;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, Messages, Classes, Controls, Graphics,\r\n ExtCtrls, Buttons, StdCtrls, Forms,\r\n JVCLVer,\r\n JvgTypes, JvgCommClasses, JvgUtils;\r\n\r\ntype\r\n TJvgSpeedButton = class(TSpeedButton)\r\n private\r\n FAboutJVCL: TJVCLAboutInfo;\r\n FMouseEnter: Boolean;\r\n FColor: TColor;\r\n FIsDown: Boolean;\r\n FControl: TControl;\r\n FFrame: Boolean;\r\n FCaptionLabel: TLabel;\r\n FDefaultStyle: Boolean;\r\n FModalResult: TModalResult;\r\n FFrameColor: TColor;\r\n FActiveColor: TColor;\r\n procedure CMMouseEnter(var Msg: TMessage); message CM_MOUSEENTER;\r\n procedure CMMouseLeave(var Msg: TMessage); message CM_MOUSELEAVE;\r\n procedure SetControl(const Value: TControl);\r\n procedure SetFrame(const Value: Boolean);\r\n procedure SetCaptionLabel(const Value: TLabel);\r\n procedure SetDefaultStyle(const Value: Boolean);\r\n procedure SetColor(const Value: TColor);\r\n procedure SetFrameColor(const Value: TColor);\r\n protected\r\n procedure MouseEnter(Control: TControl); dynamic;\r\n procedure MouseLeave(Control: TControl); dynamic;\r\n { (rb) Better respond to CM_ENABLEDCHANGED, but don't know if that works on D5,D6 }\r\n procedure SetEnabled(Value: Boolean); override;\r\n function GetEnabled: Boolean; override;\r\n procedure Paint; override;\r\n procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;\r\n procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n procedure Click; override;\r\n property Canvas;\r\n published\r\n property AboutJVCL: TJVCLAboutInfo read FAboutJVCL write FAboutJVCL stored False;\r\n property Color: TColor read FColor write SetColor;\r\n property ActiveColor: TColor read FActiveColor write FActiveColor;\r\n property Control: TControl read FControl write SetControl;\r\n property CaptionLabel: TLabel read FCaptionLabel write SetCaptionLabel;\r\n property Frame: Boolean read FFrame write SetFrame default True;\r\n property FrameColor: TColor read FFrameColor write SetFrameColor;\r\n property DefaultStyle: Boolean read FDefaultStyle write SetDefaultStyle;\r\n property Enabled: Boolean read GetEnabled write SetEnabled;\r\n property ModalResult: TModalResult read FModalResult write FModalResult;\r\n end;\r\n\r\n TJvgExtSpeedButton = class(TJvgSpeedButton)\r\n private\r\n FStyle: TJvgSpeedButtonStyle;\r\n FStyleActive: TJvgSpeedButtonStyle;\r\n FStylePushed: TJvgSpeedButtonStyle;\r\n procedure SetColor(const Value: TColor);\r\n procedure SetActiveColor(const Value: TColor);\r\n function GetFont: TFont;\r\n procedure SetFont(const Value: TFont);\r\n function GetActiveColor: TColor;\r\n function GetColor: TColor;\r\n procedure SetStyle(Value: TJvgSpeedButtonStyle);\r\n procedure SetStyleActive(Value: TJvgSpeedButtonStyle);\r\n procedure SetStylePushed(Value: TJvgSpeedButtonStyle);\r\n procedure ButtonChanged(Sender: TObject);\r\n protected\r\n procedure MouseEnter(Control: TControl); override;\r\n procedure MouseLeave(Control: TControl); override;\r\n procedure Paint; override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n published\r\n property ActiveColor: TColor read GetActiveColor write SetActiveColor stored False;\r\n property Color: TColor read GetColor write SetColor stored False;\r\n property Style: TJvgSpeedButtonStyle read FStyle write SetStyle;\r\n property StyleActive: TJvgSpeedButtonStyle read FStyleActive write SetStyleActive;\r\n property StylePushed: TJvgSpeedButtonStyle read FStylePushed write SetStylePushed;\r\n property Font: TFont read GetFont write SetFont;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvgSpeedButton.pas $';\r\n Revision: '$Revision: 12461 $';\r\n Date: '$Date: 2009-08-14 19:21:33 +0200 (ven. 14 août 2009) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\n//=== { TJvgSpeedButton } ====================================================\r\n\r\nconstructor TJvgSpeedButton.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n //..defaults\r\n FColor := IncColor(GetSysColor(COLOR_BTNFACE), 30);\r\n FActiveColor := IncColor(FColor, 10);\r\n FFrame := True;\r\nend;\r\n\r\nprocedure TJvgSpeedButton.Paint;\r\nvar\r\n R: TRect;\r\n BevelOuter: TPanelBevel;\r\nbegin\r\n if csDestroying in ComponentState then\r\n Exit;\r\n if DefaultStyle then\r\n begin\r\n inherited Paint;\r\n Exit;\r\n end;\r\n if SystemColorDepth < 16 then\r\n FColor := GetNearestColor(Canvas.Handle, FColor);\r\n\r\n R := ClientRect;\r\n\r\n if Down or (FIsDown and FMouseEnter) then\r\n BevelOuter := bvLowered\r\n else\r\n BevelOuter := bvRaised;\r\n if Flat and not FIsDown then\r\n BevelOuter := bvNone;\r\n\r\n if FFrame then\r\n InflateRect(R, -1, -1);\r\n Dec(R.Right);\r\n Dec(R.Bottom);\r\n DrawBoxEx(Canvas.Handle, R, ALLGLSIDES, bvNone, BevelOuter, False,\r\n IIF(FMouseEnter, ActiveColor, Color), False);\r\n\r\n if Transparent then\r\n SetBkMode(Canvas.Handle, Windows.TRANSPARENT)\r\n else\r\n SetBkMode(Canvas.Handle, Windows.OPAQUE);\r\n\r\n Canvas.Font.Assign(Font);\r\n if not Enabled then\r\n Canvas.Font.Color := clGrayText;\r\n if Assigned(Glyph) then\r\n Inc(R.Left, Glyph.Width);\r\n\r\n if FIsDown then\r\n OffsetRect(R, 1, 1);\r\n Windows.DrawText(Canvas.Handle, PChar(Caption), Length(Caption), R,\r\n DT_SINGLELINE or DT_CENTER or DT_VCENTER);\r\n\r\n R := ClientRect;\r\n Canvas.Brush.Color := clBlack;\r\n if FFrame then\r\n begin\r\n Canvas.Font.Color := FFrameColor;\r\n Canvas.FrameRect(R);\r\n end;\r\n\r\n if Assigned(Glyph) then\r\n CreateBitmapExt(Canvas.Handle, Glyph, ClientRect, (Width - Glyph.Width -\r\n Canvas.TextWidth(Caption)) div 2 + Integer(FIsDown) - 1 - Spacing, 1 +\r\n (Height - Glyph.Height) div 2 + Integer(FIsDown),\r\n fwoNone, fdsDefault,\r\n True, GetTransparentColor(Glyph, ftcLeftBottomPixel), 0);\r\nend;\r\n\r\nprocedure TJvgSpeedButton.CMMouseEnter(var Msg: TMessage);\r\nbegin\r\n inherited;\r\n MouseEnter(TControl(Msg.LParam));\r\nend;\r\n\r\nprocedure TJvgSpeedButton.CMMouseLeave(var Msg: TMessage);\r\nbegin\r\n inherited;\r\n MouseLeave(TControl(Msg.LParam));\r\nend;\r\n\r\nprocedure TJvgSpeedButton.MouseEnter(Control: TControl);\r\nbegin\r\n if csDesigning in ComponentState then\r\n Exit;\r\n FMouseEnter := True;\r\n if FIsDown or (Color <> ActiveColor) then\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvgSpeedButton.MouseLeave(Control: TControl);\r\nbegin\r\n if csDesigning in ComponentState then\r\n Exit;\r\n FMouseEnter := False;\r\n if FIsDown or (Color <> ActiveColor) then\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvgSpeedButton.MouseDown(Button: TMouseButton; Shift: TShiftState;\r\n X, Y: Integer);\r\nbegin\r\n inherited MouseDown(Button, Shift, X, Y);\r\n FIsDown := True;\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvgSpeedButton.MouseUp(Button: TMouseButton; Shift: TShiftState;\r\n X, Y: Integer);\r\nbegin\r\n inherited MouseUp(Button, Shift, X, Y);\r\n FIsDown := False;\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvgSpeedButton.Click;\r\nvar\r\n Form: TCustomForm;\r\nbegin\r\n inherited Click;\r\n if ModalResult = mrNone then\r\n Exit;\r\n Form := GetParentForm(Self);\r\n if Form <> nil then\r\n Form.ModalResult := ModalResult;\r\nend;\r\n\r\nprocedure TJvgSpeedButton.SetControl(const Value: TControl);\r\nbegin\r\n FControl := Value;\r\nend;\r\n\r\nprocedure TJvgSpeedButton.SetFrame(const Value: Boolean);\r\nbegin\r\n if FFrame <> Value then\r\n begin\r\n FFrame := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvgSpeedButton.SetCaptionLabel(const Value: TLabel);\r\nbegin\r\n if FCaptionLabel <> Value then\r\n begin\r\n FCaptionLabel := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvgSpeedButton.SetDefaultStyle(const Value: Boolean);\r\nbegin\r\n if FDefaultStyle <> Value then\r\n begin\r\n FDefaultStyle := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvgSpeedButton.SetEnabled(Value: Boolean);\r\nbegin\r\n inherited SetEnabled(Value);\r\n if Assigned(FControl) then\r\n FControl.Enabled := Value;\r\nend;\r\n\r\nfunction TJvgSpeedButton.GetEnabled: Boolean;\r\nbegin\r\n Result := inherited GetEnabled;\r\nend;\r\n\r\nprocedure TJvgSpeedButton.SetColor(const Value: TColor);\r\nbegin\r\n if FColor <> Value then\r\n begin\r\n FColor := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvgSpeedButton.SetFrameColor(const Value: TColor);\r\nbegin\r\n if FFrameColor <> Value then\r\n begin\r\n FFrameColor := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\n//=== { TJvgExtSpeedButton } =================================================\r\n\r\nconstructor TJvgExtSpeedButton.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FStyle := TJvgSpeedButtonStyle.Create;\r\n FStyleActive := TJvgSpeedButtonStyle.Create;\r\n FStylePushed := TJvgSpeedButtonStyle.Create;\r\n\r\n FStyle.OnChanged := ButtonChanged;\r\n FStyleActive.OnChanged := ButtonChanged;\r\n FStylePushed.OnChanged := ButtonChanged;\r\n //..defaults\r\n FStyle.Color := IncColor(clBtnFace, 30);\r\n FStyleActive.Color := IncColor(FStyle.Color, 10);\r\n FStylePushed.Color := DecColor(FStyle.Color, 10);\r\n FStyle.Bevel.Inner := bvRaised;\r\n FStyleActive.Bevel.Inner := bvRaised;\r\n FStylePushed.Bevel.Inner := bvLowered;\r\nend;\r\n\r\ndestructor TJvgExtSpeedButton.Destroy;\r\nbegin\r\n FStyle.Free;\r\n FStyleActive.Free;\r\n FStylePushed.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvgExtSpeedButton.Paint;\r\nvar\r\n R: TRect;\r\n Offset: Integer;\r\n LStyle: TJvgSpeedButtonStyle;\r\n\r\n function TextStyle: TglTextStyle;\r\n begin\r\n if Enabled then\r\n Result := LStyle.TextStyle\r\n else\r\n Result := fstPushed;\r\n end;\r\n\r\nbegin\r\n if DefaultStyle then\r\n begin\r\n inherited Paint;\r\n Exit;\r\n end;\r\n R := ClientRect;\r\n\r\n if Down or (FIsDown and FMouseEnter) then\r\n LStyle := StylePushed\r\n else\r\n if FMouseEnter then\r\n LStyle := StyleActive\r\n else\r\n LStyle := Style;\r\n\r\n if FFrame then\r\n InflateRect(R, -1, -1);\r\n Dec(R.Right);\r\n Dec(R.Bottom);\r\n\r\n with LStyle do\r\n begin\r\n R := DrawBoxEx(Canvas.Handle, R, Bevel.Sides, Bevel.Inner, Bevel.Outer, Bevel.Bold, Color, Gradient.Active);\r\n if Gradient.Active then\r\n begin\r\n Inc(R.Right);\r\n Inc(R.Bottom);\r\n Gradient.Draw(Canvas.Handle, R, Integer(psSolid), 1);\r\n Dec(R.Right);\r\n Dec(R.Bottom);\r\n end;\r\n end;\r\n\r\n if not Glyph.Empty then\r\n Inc(R.Left, Glyph.Width);\r\n\r\n Canvas.Font.Assign(LStyle.Font);\r\n if FIsDown then\r\n Offset := 1\r\n else\r\n Offset := 0;\r\n ExtTextOutExt(Canvas.Handle, R.Left + Offset + (R.Right - R.Left - Canvas.TextWidth(Caption)) div 2, R.Top + Offset +\r\n (R.Bottom - R.Top - Canvas.TextHeight(Caption)) div 2, R, Caption,\r\n TextStyle, False { fcoDelineatedText in Options},\r\n False, LStyle.Font.Color, LStyle.DelineateColor,\r\n LStyle.HighlightColor, LStyle.ShadowColor,\r\n nil, LStyle.TextGradient, LStyle.Font);\r\n\r\n R := ClientRect;\r\n Canvas.Brush.Color := 0;\r\n if FFrame then\r\n begin\r\n Canvas.Font.Color := FFrameColor;\r\n Canvas.FrameRect(R);\r\n end;\r\n\r\n if Assigned(Glyph) then\r\n CreateBitmapExt(Canvas.Handle, Glyph, ClientRect, (Width - Glyph.Width - Canvas.TextWidth(Caption)) div 2 +\r\n Integer(FIsDown) - 1 - Spacing, 1 + (Height - Glyph.Height) div 2 + Integer(FIsDown),\r\n fwoNone, fdsDefault,\r\n True, GetTransparentColor(Glyph, ftcLeftBottomPixel), 0);\r\nend;\r\n\r\nprocedure TJvgExtSpeedButton.MouseEnter(Control: TControl);\r\nbegin\r\n if csDesigning in ComponentState then\r\n Exit;\r\n inherited MouseEnter(Control);\r\n if Enabled then\r\n begin\r\n FMouseEnter := True;\r\n Repaint;\r\n end;\r\nend;\r\n\r\nprocedure TJvgExtSpeedButton.MouseLeave(Control: TControl);\r\nbegin\r\n if csDesigning in ComponentState then\r\n Exit;\r\n inherited MouseLeave(Control);\r\n if Enabled then\r\n begin\r\n FMouseEnter := False;\r\n Repaint;\r\n end;\r\nend;\r\n\r\nprocedure TJvgExtSpeedButton.ButtonChanged(Sender: TObject);\r\nbegin\r\n if not (csLoading in ComponentState) then\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvgExtSpeedButton.SetColor(const Value: TColor);\r\nbegin\r\n if Style.Color <> Value then\r\n begin\r\n Style.Color := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvgExtSpeedButton.SetActiveColor(const Value: TColor);\r\nbegin\r\n if StyleActive.Color <> Value then\r\n begin\r\n StyleActive.Color := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nfunction TJvgExtSpeedButton.GetActiveColor: TColor;\r\nbegin\r\n Result := StyleActive.Color;\r\nend;\r\n\r\nfunction TJvgExtSpeedButton.GetColor: TColor;\r\nbegin\r\n Result := Style.Color;\r\nend;\r\n\r\nfunction TJvgExtSpeedButton.GetFont: TFont;\r\nbegin\r\n Result := inherited Font;\r\nend;\r\n\r\nprocedure TJvgExtSpeedButton.SetFont(const Value: TFont);\r\nbegin\r\n inherited Font.Assign(Font);\r\n Style.Font.Assign(Font);\r\nend;\r\n\r\nprocedure TJvgExtSpeedButton.SetStyle(Value: TJvgSpeedButtonStyle);\r\nbegin\r\n FStyle.Assign(Value);\r\nend;\r\n\r\nprocedure TJvgExtSpeedButton.SetStyleActive(Value: TJvgSpeedButtonStyle);\r\nbegin\r\n FStyleActive.Assign(Value);\r\nend;\r\n\r\nprocedure TJvgExtSpeedButton.SetStylePushed(Value: TJvgSpeedButtonStyle);\r\nbegin\r\n FStylePushed.Assign(Value);\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvgStringGrid.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvgStringGrid.PAS, released on 2003-01-15.\r\n\r\nThe Initial Developer of the Original Code is Andrey V. Chudin, [chudin att yandex dott ru]\r\nPortions created by Andrey V. Chudin are Copyright (C) 2003 Andrey V. Chudin.\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\nMichael Beck [mbeck att bigfoot dott com].\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvgStringGrid.pas 12461 2009-08-14 17:21:33Z obones $\r\n\r\nunit JvgStringGrid;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, Messages, Classes, Controls, Graphics, ExtCtrls,\r\n Grids, StdCtrls, Forms,\r\n JVCLVer,\r\n JvgTypes, JvgCommClasses, JvgUtils;\r\n\r\nconst\r\n JvDefaultEditorColor = $00FEE392;\r\n\r\ntype\r\n TglStringGridExtOption = (fsgVertCaptions, fsgHottrack, fsgMemoEditor,\r\n fsgWordWrap, fsgCellHeightAutoSize, fsgTabThroughCells);\r\n TglStringGridExtOptions = set of TglStringGridExtOption;\r\n\r\n TglGridCellStyle = record\r\n Hottracking: Boolean;\r\n GradientFilling: Boolean;\r\n Default_Drawing: Boolean;\r\n R: TRect;\r\n CellBorders: TglSides;\r\n BevelInner: TPanelBevel;\r\n BevelOuter: TPanelBevel;\r\n BevelBold: Boolean;\r\n FontStyle: TFontStyles;\r\n FontColor: TColor;\r\n BackgrColor: TColor;\r\n Interspace: Integer\r\n end;\r\n\r\n TglOnGetCellStyleEvent = procedure(Sender: TObject; ACol, ARow: Longint;\r\n var Style: TglGridCellStyle) of object;\r\n TglOnGetCellGradientParamsEvent = procedure(Sender: TObject;\r\n ACol, ARow: Longint; var CellRect: TRect; var Gradient: TJvgGradient) of object;\r\n\r\n TJvgStringGrid = class(TStringGrid)\r\n private\r\n FAboutJVCL: TJVCLAboutInfo;\r\n FCaptionTextAlignment: TAlignment;\r\n FCaptionFont: TFont;\r\n FBitmap: TBitmap;\r\n FBmp: TBitmap;\r\n FImage: TImage;\r\n FCaptions: TStringList;\r\n FHottrackThrought: Boolean;\r\n AHottrackCol: Longint;\r\n AHottrackRow: Longint;\r\n Memo: TMemo;\r\n MemoCell: TGridCoord;\r\n Gradient: TJvgGradient;\r\n FOnGetCellStyle: TglOnGetCellStyleEvent;\r\n FOnGetCellGradientParams: TglOnGetCellGradientParamsEvent;\r\n FExtOptions: TglStringGridExtOptions;\r\n FTextAlignment: TAlignment;\r\n FEditorColor: TColor;\r\n FEditorFont: TFont;\r\n MemoUpdateTimer: TTimer;\r\n procedure SetCaptionTextAlignment(Value: TAlignment);\r\n procedure SetCaptionFont(Value: TFont);\r\n function GetBitmap: TBitmap;\r\n procedure SetBitmap(Value: TBitmap);\r\n procedure SetImage(Value: TImage);\r\n function GetCaptions: TStrings;\r\n procedure SetCaptions(Value: TStrings);\r\n procedure SetVertCaptions(Value: Boolean);\r\n procedure OnMemoChange(Sender: TObject);\r\n procedure OnMemoExit(Sender: TObject);\r\n procedure ShowEditorAtCell(X, Y: Longint);\r\n procedure UpdateCaptions(Sender: TObject);\r\n procedure SetHottrack(const Value: Boolean);\r\n procedure SetMemoEditor(const Value: Boolean);\r\n procedure SetWordWrap(const Value: Boolean);\r\n procedure SetExtOptions(const Value: TglStringGridExtOptions);\r\n procedure SetTextAlignment(const Value: TAlignment);\r\n protected\r\n // function CreateEditor: TInplaceEdit; override;\r\n function CanEditShow: Boolean; override;\r\n\r\n procedure Loaded; override;\r\n procedure DrawCell(ACol, ARow: Longint; ARect: TRect; AState:\r\n TGridDrawState); override;\r\n procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;\r\n procedure CMMouseLeave(var Msg: TMessage); message CM_MOUSELEAVE;\r\n procedure CMChildKey(var Msg: TMessage); message CM_CHILDKEY;\r\n procedure WMSize(var Msg: TWMSize); message WM_SIZE;\r\n\r\n procedure MouseDown(Button: TMouseButton; Shift: TShiftState;\r\n X, Y: Integer); override;\r\n // procedure DblClick; dynamic;\r\n\r\n procedure GetCellStyle(Sender: TObject; var ACol, ARow: Integer; var\r\n Style: TglGridCellStyle); virtual;\r\n procedure GetCellGradientParams(Sender: TObject; ACol, ARow: Longint; var\r\n CellRect: TRect; var Gradient: TJvgGradient); virtual;\r\n public\r\n // property InplaceEditor;\r\n AlignAll: Boolean;\r\n ColsBold: Integer;\r\n RowsBold: Integer;\r\n HottrackColor: TColor;\r\n\r\n property VertCaptions: Boolean write SetVertCaptions default False;\r\n property Hottrack: Boolean write SetHottrack default False;\r\n property MemoEditor: Boolean write SetMemoEditor default False;\r\n property WordWrap: Boolean write SetWordWrap default False;\r\n\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n\r\n procedure GetPriorCell(var X, Y: Longint);\r\n procedure GetNextCell(var X, Y: Longint);\r\n procedure ClearSelection;\r\n published\r\n property AboutJVCL: TJVCLAboutInfo read FAboutJVCL write FAboutJVCL stored False;\r\n property CaptionTextAlignment: TAlignment read FCaptionTextAlignment write\r\n SetCaptionTextAlignment default taCenter;\r\n property TextAlignment: TAlignment read FTextAlignment write\r\n SetTextAlignment default taLeftJustify;\r\n property CaptionFont: TFont read FCaptionFont write SetCaptionFont;\r\n property Captions: TStrings read GetCaptions write SetCaptions;\r\n property Bitmap: TBitmap read GetBitmap write SetBitmap;\r\n property Image: TImage read FImage write SetImage;\r\n property ExtOptions: TglStringGridExtOptions read FExtOptions write SetExtOptions;\r\n property EditorColor: TColor read FEditorColor write FEditorColor default JvDefaultEditorColor;\r\n property EditorFont: TFont read FEditorFont write FEditorFont;\r\n property OnGetCellStyle: TglOnGetCellStyleEvent read FOnGetCellStyle write FOnGetCellStyle;\r\n property OnGetCellGradientParams: TglOnGetCellGradientParamsEvent read\r\n FOnGetCellGradientParams write FOnGetCellGradientParams;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvgStringGrid.pas $';\r\n Revision: '$Revision: 12461 $';\r\n Date: '$Date: 2009-08-14 19:21:33 +0200 (ven. 14 août 2009) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n Math;\r\n\r\nconstructor TJvgStringGrid.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner); //FHottrackThrought := True;\r\n\r\n FCaptionFont := TFont.Create;\r\n FEditorFont := TFont.Create;\r\n MemoUpdateTimer := TTimer.Create(nil);\r\n MemoUpdateTimer.Enabled := False;\r\n MemoUpdateTimer.Interval := 200;\r\n MemoUpdateTimer.OnTimer := OnMemoChange;\r\n FCaptionTextAlignment := taCenter;\r\n FCaptions := TStringList.Create;\r\n FCaptions.OnChange := UpdateCaptions;\r\n AHottrackCol := -1;\r\n HottrackColor := clHighlight;\r\n FEditorColor := JvDefaultEditorColor;\r\n FExtOptions := [fsgHottrack, fsgMemoEditor, fsgWordWrap,\r\n fsgCellHeightAutoSize, fsgTabThroughCells];\r\n Options := Options + [goEditing];\r\n\r\n if csDesigning in ComponentState then\r\n Exit;\r\n Memo := TMemo.Create(Self);\r\n Memo.Visible := False;\r\n Memo.BorderStyle := bsNone;\r\n Memo.Parent := Self;\r\n Memo.OnChange := OnMemoChange;\r\n Memo.OnExit := OnMemoExit;\r\n // Memo.OnKeyDown := OnMemoKeyDown;\r\n DefaultDrawing := False;\r\nend;\r\n\r\ndestructor TJvgStringGrid.Destroy;\r\nbegin\r\n FCaptionFont.Free;\r\n FCaptions.Free;\r\n FEditorFont.Free;\r\n MemoUpdateTimer.Free;\r\n if Assigned(Memo) then\r\n Memo.Free;\r\n if Assigned(FBitmap) then\r\n FBitmap.Free;\r\n if Assigned(Gradient) then\r\n Gradient.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvgStringGrid.Loaded;\r\nbegin\r\n inherited Loaded;\r\n if Assigned(FBitmap) and (not FBitmap.Empty) then\r\n FBmp := FBitmap;\r\n VertCaptions := fsgVertCaptions in FExtOptions;\r\nend;\r\n\r\nprocedure TJvgStringGrid.DrawCell(ACol, ARow: Longint; ARect: TRect; AState:\r\n TGridDrawState);\r\nconst\r\n aAlignments: array[TAlignment] of Longint = (DT_LEFT,\r\n DT_RIGHT, DT_CENTER);\r\n aWordWrap: array[Boolean] of Longint = (0, DT_WORDBREAK);\r\nvar\r\n R: TRect;\r\n doHottracking, isFixedCell: Boolean;\r\n X, X1, Y, Y1, IHeight, IWidth, l, t, I, Interspace: Integer;\r\n Style: TglGridCellStyle;\r\n CellTextAlignment: TAlignment;\r\nbegin\r\n /// dec(ARect.Bottom);\r\n\r\n isFixedCell := (ACol < FixedCols) or (ARow < FixedRows);\r\n\r\n Interspace := 2;\r\n if Assigned(OnDrawCell) then\r\n OnDrawCell(Self, ACol, ARow, ARect, AState);\r\n if ACol < ColsBold then\r\n Canvas.Font.Style := Canvas.Font.Style + [fsBold];\r\n if ARow < RowsBold then\r\n Canvas.Font.Style := Canvas.Font.Style + [fsBold];\r\n R := ARect;\r\n\r\n if isFixedCell then\r\n if IsItAFilledBitmap(FBmp) then\r\n begin\r\n X := R.Left;\r\n Y := R.Top;\r\n IHeight := R.Bottom - R.Top;\r\n IWidth := R.Right - R.Left - 4;\r\n X1 := X;\r\n Y1 := Y;\r\n l := 0;\r\n t := DefaultRowHeight * ARow mod FBmp.Height;\r\n while X1 < R.Right do\r\n begin\r\n if X1 + IWidth > R.Right then\r\n IWidth := R.Right - X1;\r\n while Y1 < R.Bottom do\r\n begin\r\n if Y1 + IHeight > R.Bottom then\r\n IHeight := R.Bottom - Y1;\r\n BitBlt(Canvas.Handle, X1, Y1, Min(IWidth, FBmp.Width - l),\r\n Min(IHeight, FBmp.Height - t), FBmp.Canvas.Handle, l, t, SRCCOPY);\r\n Inc(Y1, Min(IHeight, FBmp.Height));\r\n end;\r\n Inc(X1, Min(IWidth, FBmp.Width));\r\n Y1 := Y;\r\n end;\r\n end;\r\n\r\n if True then\r\n begin\r\n if FHottrackThrought then\r\n doHottracking := (AHottrackCol = ACol) or (AHottrackRow = ARow)\r\n else\r\n if fsgHottrack in FExtOptions then\r\n doHottracking := (AHottrackCol = ACol) and (AHottrackRow = ARow) and\r\n ((ACol < FixedCols) or (ARow < FixedRows))\r\n else\r\n doHottracking := False;\r\n\r\n if isFixedCell then\r\n begin\r\n Canvas.Font.Assign(FCaptionFont);\r\n CellTextAlignment := CaptionTextAlignment;\r\n Style.BevelOuter := bvRaised;\r\n Style.BackgrColor := clBtnFace;\r\n end\r\n else\r\n begin\r\n Canvas.Font.Assign(Font);\r\n CellTextAlignment := TextAlignment;\r\n Style.BevelOuter := bvNone;\r\n if gdSelected in AState then\r\n Style.BackgrColor := clHighlight\r\n else\r\n Style.BackgrColor := Color;\r\n end;\r\n\r\n if doHottracking then\r\n Style.FontColor := HottrackColor\r\n else\r\n Style.FontColor := Canvas.Font.Color;\r\n\r\n if gdSelected in AState then\r\n Style.FontColor := clHighlightText;\r\n\r\n Style.Hottracking := doHottracking;\r\n Style.GradientFilling := False;\r\n Style.Default_Drawing := True;\r\n Style.R := R;\r\n Style.CellBorders := ALLGLSIDES;\r\n Style.BevelInner := bvNone;\r\n\r\n Style.BevelBold := False;\r\n Style.FontStyle := Canvas.Font.Style;\r\n Style.Interspace := Interspace;\r\n GetCellStyle(Self, ACol, ARow, Style);\r\n Canvas.Font.Style := Style.FontStyle;\r\n R := Style.R;\r\n if not Style.Default_Drawing then\r\n Exit;\r\n\r\n if Style.GradientFilling then\r\n begin\r\n if Gradient = nil then\r\n Gradient := TJvgGradient.Create;\r\n Gradient.Active := True;\r\n ARect := R;\r\n GetCellGradientParams(Self, ACol, ARow, ARect, Gradient);\r\n GradientBox(Canvas.Handle, ARect, Gradient, Integer(psSolid), 1);\r\n end;\r\n\r\n DrawBoxEx(Canvas.Handle, R, Style.CellBorders, Style.BevelInner,\r\n Style.BevelOuter, Style.BevelBold,\r\n Style.BackgrColor, {(BackgrColor = clBtnFace)or}\r\n Style.GradientFilling);\r\n ARect := R;\r\n Inc(ARect.Left, Style.Interspace);\r\n SetTextColor(Canvas.Handle, ColorToRGB(Style.FontColor));\r\n SetBkMode(Canvas.Handle, TRANSPARENT);\r\n Windows.DrawText(Canvas.Handle, PChar(Cells[ACol, ARow]), Length(Cells[ACol,\r\n ARow]), R, aAlignments[CellTextAlignment] or DT_WORDBREAK or\r\n DT_CALCRECT);\r\n\r\n if (fsgCellHeightAutoSize in ExtOptions) and not isFixedCell then\r\n begin\r\n I := R.Bottom - R.Top;\r\n if (I > DefaultRowHeight) and (RowHeights[ARow] < I) then\r\n begin\r\n ///RowHeights[ARow] := I;\r\n Exit;\r\n end;\r\n end;\r\n\r\n ARect.Top := ARect.Top + Max(0, (ARect.Bottom - R.Bottom) div 2);\r\n Windows.DrawText(Canvas.Handle, PChar(Cells[ACol, ARow]), length(Cells[ACol,\r\n ARow]), ARect, aAlignments[CellTextAlignment] or aWordWrap[fsgWordWrap in\r\n FExtOptions]);\r\n SetTextColor(Canvas.Handle, ColorToRGB(Font.Color));\r\n end\r\n else // if AlignAll then\r\n begin\r\n Canvas.Brush.Color := Color;\r\n Canvas.FillRect(ARect);\r\n Inc(ARect.Left, 2);\r\n R := ARect;\r\n Windows.DrawText(Canvas.Handle, PChar(Cells[ACol, ARow]), length(Cells[ACol,\r\n ARow]), R, DT_LEFT or DT_WORDBREAK or DT_CALCRECT);\r\n ARect.Top := ARect.Top + Max(0, (ARect.Bottom - R.Bottom) div 2);\r\n Windows.DrawText(Canvas.Handle, PChar(Cells[ACol, ARow]), length(Cells[ACol,\r\n ARow]), ARect, DT_LEFT or DT_WORDBREAK)\r\n end; // else inherited;\r\n // DefaultDrawing := True;\r\nend;\r\n\r\nprocedure TJvgStringGrid.SetCaptionTextAlignment(Value: TAlignment);\r\nbegin\r\n FCaptionTextAlignment := Value;\r\n Repaint;\r\nend;\r\n\r\nprocedure TJvgStringGrid.SetCaptionFont(Value: TFont);\r\nbegin\r\n FCaptionFont.Assign(Value);\r\n Repaint;\r\nend;\r\n\r\nfunction TJvgStringGrid.GetBitmap: TBitmap;\r\nbegin\r\n if not Assigned(FBitmap) then\r\n FBitmap := TBitmap.Create;\r\n Result := FBitmap;\r\nend;\r\n\r\nprocedure TJvgStringGrid.SetBitmap(Value: TBitmap);\r\nbegin\r\n if Assigned(FBitmap) then\r\n FBitmap.Free;\r\n FBitmap := TBitmap.Create;\r\n FBitmap.Assign(Value);\r\n if Assigned(Value) then\r\n FBmp := FBitmap\r\n else\r\n if Assigned(FImage) and Assigned(FImage.Picture) and\r\n Assigned(FImage.Picture.Bitmap) then\r\n FBmp := FImage.Picture.Bitmap\r\n else\r\n FBmp := nil;\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvgStringGrid.SetImage(Value: TImage);\r\nbegin\r\n FImage := Value;\r\n if Assigned(FImage) and Assigned(FImage.Picture) and\r\n Assigned(FImage.Picture.Bitmap) then\r\n FBmp := FImage.Picture.Bitmap\r\n else\r\n if Assigned(FBitmap) then\r\n FBmp := FBitmap\r\n else\r\n FBmp := nil;\r\n Invalidate;\r\nend;\r\n\r\nfunction TJvgStringGrid.GetCaptions: TStrings;\r\nbegin\r\n Result := FCaptions;\r\nend;\r\n\r\nprocedure TJvgStringGrid.SetCaptions(Value: TStrings);\r\nbegin\r\n FCaptions.Assign(Value);\r\n VertCaptions := fsgVertCaptions in FExtOptions;\r\nend;\r\n\r\n//-------------------------------------------------------------------------------\r\n\r\nprocedure TJvgStringGrid.MouseMove(Shift: TShiftState; X, Y: Integer);\r\nvar\r\n R: TRect;\r\n ACol, ARow: Longint;\r\nbegin\r\n inherited MouseMove(Shift, X, Y);\r\n if not (fsgHottrack in FExtOptions) then\r\n Exit;\r\n MouseToCell(X, Y, ACol, ARow);\r\n if (ACol >= FixedCols) and (ARow >= FixedRows) then\r\n begin\r\n SetCursor(Screen.Cursors[crCross]);\r\n Exit;\r\n end;\r\n SetCursor(Screen.Cursors[crDefault]);\r\n\r\n if ((ACol <> AHottrackCol) or (ARow <> AHottrackRow)) then\r\n begin\r\n if (AHottrackCol < FixedCols) or (AHottrackRow < FixedRows) then\r\n begin\r\n R := CellRect(AHottrackCol, AHottrackRow);\r\n InvalidateRect(Handle, @R, False); //DefaultDrawing := False;\r\n end\r\n else\r\n if FHottrackThrought then\r\n begin\r\n if (ACol <> AHottrackCol) and (FixedCols > 0) then\r\n begin\r\n R := CellRect(AHottrackCol, 0); //DefaultDrawing := False;\r\n InvalidateRect(Handle, @R, False);\r\n end;\r\n if (ARow <> AHottrackRow) and (FixedRows > 0) then\r\n begin\r\n R := CellRect(0, AHottrackRow); //DefaultDrawing := False;\r\n InvalidateRect(Handle, @R, False);\r\n end;\r\n end;\r\n\r\n if (ACol < FixedCols) or (ARow < FixedCols) then\r\n begin\r\n R := CellRect(ACol, ARow); //DefaultDrawing := False;\r\n InvalidateRect(Handle, @R, False);\r\n end\r\n else\r\n if FHottrackThrought then\r\n begin\r\n if (ACol <> AHottrackCol) and (FixedCols > 0) then\r\n begin\r\n R := CellRect(ACol, 0); //DefaultDrawing := False;\r\n InvalidateRect(Handle, @R, False);\r\n end;\r\n if (ARow <> AHottrackRow) and (FixedRows > 0) then\r\n begin\r\n R := CellRect(0, ARow); //DefaultDrawing := False;\r\n InvalidateRect(Handle, @R, False);\r\n end;\r\n end;\r\n AHottrackCol := ACol;\r\n AHottrackRow := ARow;\r\n end;\r\nend;\r\n\r\nprocedure TJvgStringGrid.CMMouseLeave(var Msg: TMessage);\r\nvar\r\n R: TRect;\r\nbegin\r\n inherited;\r\n if not (fsgHottrack in FExtOptions) then\r\n Exit;\r\n R := CellRect(AHottrackCol, AHottrackRow);\r\n AHottrackCol := -1;\r\n //DefaultDrawing := False;\r\n InvalidateRect(Handle, @R, False);\r\nend;\r\n\r\nprocedure TJvgStringGrid.MouseDown(Button: TMouseButton; Shift: TShiftState;\r\n X, Y: Integer);\r\nvar\r\n GridCoord: TGridCoord;\r\nbegin\r\n inherited MouseDown(Button, Shift, X, Y);\r\n if (not (goEditing in Options)) or (csDesigning in ComponentState) then\r\n Exit;\r\n\r\n if Assigned(OnMouseDown) then\r\n OnMouseDown(Self, Button, Shift, X, Y);\r\n if Memo.Focused then\r\n Cells[MemoCell.X, MemoCell.Y] := Memo.Text;\r\n GridCoord := MouseCoord(X, Y);\r\n if (GridCoord.X = 1) and Assigned(OnDrawCell) then\r\n OnDrawCell(Self, GridCoord.X, GridCoord.Y, CellRect(GridCoord.X,\r\n GridCoord.Y), [gdFocused]);\r\n // ClearSelection;\r\n ShowEditorAtCell(GridCoord.X, GridCoord.Y);\r\nend;\r\n\r\nprocedure TJvgStringGrid.ShowEditorAtCell(X, Y: Longint);\r\nvar\r\n R: TRect;\r\n GridRect: TGridRect;\r\nbegin\r\n if not (fsgMemoEditor in FExtOptions) then\r\n Exit;\r\n if (X >= FixedCols) and (Y >= FixedRows) then\r\n begin\r\n\r\n if (GridRect.Left <> X) or (GridRect.Top <> Y) then\r\n begin\r\n GridRect.Left := X;\r\n GridRect.Top := Y;\r\n GridRect.Right := X;\r\n GridRect.Bottom := Y;\r\n Selection := GridRect;\r\n end;\r\n Application.ProcessMessages;\r\n R := CellRect(X, Y);\r\n Memo.SetBounds(R.Left, R.Top, R.Right - R.Left, R.Bottom - R.Top);\r\n MemoCell.X := X;\r\n MemoCell.Y := Y;\r\n Memo.Text := Cells[MemoCell.X, MemoCell.Y];\r\n Memo.Visible := True;\r\n Memo.SetFocus;\r\n Memo.OnChange := OnMemoChange;\r\n Memo.Color := EditorColor;\r\n Memo.Font.Assign(EditorFont);\r\n end;\r\nend;\r\n\r\nprocedure TJvgStringGrid.OnMemoChange(Sender: TObject);\r\nvar\r\n R: TRect;\r\n maxHeight, h, I: Integer;\r\nbegin\r\n /// need handle it -> if Assigned(OnSetEditText) then ...\r\n if (MemoCell.X < FixedCols) or (MemoCell.Y < FixedRows) then\r\n Exit;\r\n\r\n MemoUpdateTimer.Enabled := False;\r\n Cells[MemoCell.X, MemoCell.Y] := Memo.Text;\r\n\r\n if (fsgCellHeightAutoSize in ExtOptions) and (MemoCell.Y <> 0) then\r\n begin\r\n Canvas.Font.Assign(Font);\r\n maxHeight := DefaultRowHeight;\r\n for I := FixedCols to ColCount - 1 do\r\n begin\r\n R := CellRect(I, MemoCell.Y);\r\n if length(Cells[I, MemoCell.Y]) = 0 then\r\n continue;\r\n\r\n Windows.DrawText(Canvas.Handle, PChar(Cells[I, MemoCell.Y]), length(Cells[I,\r\n MemoCell.Y]), R, DT_WORDBREAK or DT_CALCRECT);\r\n h := R.Bottom - R.Top;\r\n if h > maxHeight then\r\n maxHeight {RowHeights[MemoCell.Y]} := h;\r\n end;\r\n RowHeights[MemoCell.Y] := maxHeight;\r\n Memo.Height := maxHeight;\r\n end;\r\nend;\r\n\r\nprocedure TJvgStringGrid.OnMemoExit(Sender: TObject);\r\nbegin\r\n // Cells[MemoCell.X, MemoCell.Y] := Memo.Text;\r\n Memo.Visible := False;\r\nend;\r\n\r\nprocedure TJvgStringGrid.ClearSelection;\r\nvar\r\n GR: TGridRect;\r\nbegin\r\n GR.Left := 0;\r\n GR.Top := 0;\r\n GR.Right := 1;\r\n GR.Bottom := 1;\r\n Selection := GR;\r\nend;\r\n\r\nprocedure TJvgStringGrid.CMChildKey(var Msg: TMessage);\r\nbegin\r\n if Msg.WParam = VK_TAB then\r\n begin\r\n if fsgTabThroughCells in ExtOptions then\r\n begin\r\n if Memo.Focused then\r\n Cells[MemoCell.X, MemoCell.Y] := Memo.Text;\r\n GetNextCell(MemoCell.X, MemoCell.Y);\r\n ShowEditorAtCell(MemoCell.X, MemoCell.Y);\r\n Msg.Result := 1;\r\n end\r\n else\r\n inherited;\r\n end\r\n else\r\n begin\r\n inherited;\r\n Application.ProcessMessages;\r\n if Msg.WParam > VK_ESCAPE then\r\n begin\r\n if not (goEditing in Options) then\r\n Exit;\r\n\r\n if (MemoCell.X < FixedCols) or (MemoCell.Y < FixedRows) then // show editor first time\r\n ShowEditorAtCell(Selection.Left, Selection.Top);\r\n\r\n MemoUpdateTimer.Enabled := True;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvgStringGrid.GetNextCell(var X, Y: Longint);\r\nbegin\r\n if X < ColCount - 1 then\r\n Inc(X)\r\n else\r\n begin\r\n X := FixedCols;\r\n if Y < RowCount - 1 then\r\n Inc(Y)\r\n else\r\n Y := FixedRows;\r\n end;\r\nend;\r\n\r\nprocedure TJvgStringGrid.GetPriorCell(var X, Y: Longint);\r\nbegin\r\n if X > 0 then\r\n dec(X)\r\n else\r\n begin\r\n X := ColCount - 1;\r\n if Y > 0 then\r\n dec(Y)\r\n else\r\n Y := RowCount - 1;\r\n end;\r\nend;\r\n\r\nprocedure TJvgStringGrid.WMSize(var Msg: TWMSize);\r\nvar\r\n I, W: Integer;\r\nbegin\r\n inherited;\r\n W := 0;\r\n for I := 0 to ColCount - 2 do\r\n Inc(W, ColWidths[I]);\r\n ColWidths[ColCount - 1] := Width - W;\r\nend;\r\n\r\nprocedure TJvgStringGrid.GetCellGradientParams(Sender: TObject; ACol,\r\n ARow: Integer; var CellRect: TRect; var Gradient: TJvgGradient);\r\nbegin\r\n if Assigned(OnGetCellGradientParams) then\r\n OnGetCellGradientParams(Self, ACol, ARow, CellRect, Gradient);\r\nend;\r\n\r\nprocedure TJvgStringGrid.GetCellStyle(Sender: TObject; var ACol, ARow: Integer;\r\n var Style: TglGridCellStyle);\r\nbegin\r\n if Assigned(OnGetCellStyle) then\r\n OnGetCellStyle(Self, ACol, ARow, Style);\r\nend;\r\n\r\nprocedure TJvgStringGrid.UpdateCaptions(Sender: TObject);\r\nbegin\r\n SetVertCaptions(fsgVertCaptions in FExtOptions);\r\nend;\r\n\r\nprocedure TJvgStringGrid.SetHottrack(const Value: Boolean);\r\nbegin\r\n if Value then\r\n Include(FExtOptions, fsgHottrack)\r\n else\r\n Exclude(FExtOptions, fsgHottrack);\r\nend;\r\n\r\nprocedure TJvgStringGrid.SetMemoEditor(const Value: Boolean);\r\nbegin\r\n if Value then\r\n Include(FExtOptions, fsgMemoEditor)\r\n else\r\n Exclude(FExtOptions, fsgMemoEditor);\r\nend;\r\n\r\nprocedure TJvgStringGrid.SetWordWrap(const Value: Boolean);\r\nbegin\r\n if Value then\r\n Include(FExtOptions, fsgWordWrap)\r\n else\r\n Exclude(FExtOptions, fsgWordWrap);\r\nend;\r\n\r\nprocedure TJvgStringGrid.SetVertCaptions(Value: Boolean);\r\nvar\r\n I: Integer;\r\nbegin\r\n if Value then\r\n Include(FExtOptions, fsgVertCaptions)\r\n else\r\n Exclude(FExtOptions, fsgVertCaptions);\r\n try\r\n for I := 0 to Captions.Count - 1 do\r\n if fsgVertCaptions in FExtOptions then\r\n Cells[0, I] := Captions[I]\r\n else\r\n Cells[I, 0] := Captions[I];\r\n except\r\n end;\r\nend;\r\n\r\nprocedure TJvgStringGrid.SetExtOptions(const Value: TglStringGridExtOptions);\r\nbegin\r\n FExtOptions := Value;\r\nend;\r\n\r\nprocedure TJvgStringGrid.SetTextAlignment(const Value: TAlignment);\r\nbegin\r\n FTextAlignment := Value;\r\n Repaint;\r\nend;\r\n\r\n{ disallow default editor }\r\n\r\nfunction TJvgStringGrid.CanEditShow: Boolean;\r\nbegin\r\n Result := inherited CanEditShow;\r\n if fsgMemoEditor in FExtOptions then\r\n Result := False;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvgTab.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvgTab.PAS, released on 2003-01-15.\r\n\r\nThe Initial Developer of the Original Code is Andrey V. Chudin, [chudin att yandex dott ru]\r\nPortions created by Andrey V. Chudin are Copyright (C) 2003 Andrey V. Chudin.\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\nMichael Beck [mbeck att bigfoot dott com].\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nDescription:\r\n TabControl component that can display its pages captions in\r\n 3D styles with 3D borders. Component can display glyphs on own\r\n captions and fill background with bitmap. You can set different\r\n fonts for selected page caption and for other captions.\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvgTab.pas 13104 2011-09-07 06:50:43Z obones $\r\n\r\nunit JvgTab;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,\r\n ComCtrls, CommCtrl, ExtCtrls, ImgList,\r\n JVCLVer,\r\n JvgTypes, JvgUtils, JvgDrawTab, JvgTabComm, JvgCommClasses;\r\n\r\n// (rom) disabled unused\r\n//const\r\n// TCM_SETTEXTCOLOR = TCM_FIRST + 36;\r\n\r\ntype\r\n TJvgTabControl = class(TTabControl)\r\n private\r\n FAboutJVCL: TJVCLAboutInfo;\r\n FGlyphs: TImageList;\r\n FSingleGlyph: Boolean;\r\n FTabStyle: TJvgTabStyle;\r\n FTabSelectedStyle: TJvgTabStyle;\r\n FWallpaper: TJvgTabsWallpaper;\r\n FDrawGlyphsOption: TglWallpaperOption;\r\n FLookLikeButtons: Boolean;\r\n FTabsPosition: TglSide;\r\n FOptions: TglTabOptions;\r\n FFontDirection: TglLabelDir;\r\n FOnGetItemColor: TglOnGetItemColorEvent;\r\n FOnGetItemFontColor: TglOnGetItemColorEvent;\r\n FSuppressDraw: Boolean;\r\n FGlyphsChangeLink: TChangeLink;\r\n FDrawTabStr: TDRAWTABSTRUCT;\r\n FGlyphTmpBitmap: TBitmap;\r\n FFontNormal: TFont;\r\n FFontSelected: TFont;\r\n FNotFirst: Boolean;\r\n FTabColors: array [0..100] of TColor;\r\n function GetGlyphIndex(Index: Integer): Integer;\r\n procedure SetGlyphIndex(Index: Integer; ImgIndex: Integer);\r\n procedure SetGlyphs(Value: TImageList);\r\n procedure SetSingleGlyph(Value: Boolean);\r\n procedure SetDrawGlyphsOption(Value: TglWallpaperOption);\r\n procedure SetLookLikeButtons(Value: Boolean);\r\n procedure SetTabsPosition(Value: TglSide);\r\n procedure SetOptions(Value: TglTabOptions);\r\n procedure SetFontDirection(Value: TglLabelDir);\r\n function GetFont: TFont;\r\n procedure SetFont(Value: TFont);\r\n function GetTabColor(Index: Integer): TColor;\r\n procedure SetTabColor(Index: Integer; Value: TColor);\r\n procedure SmthChanged(Sender: TObject);\r\n procedure FontsChanged(Sender: TObject);\r\n procedure DrawItem(lpDrawItemStr: PDrawItemStruct);\r\n procedure CNDrawItem(var Msg: TWMDrawItem); message CN_DRAWITEM;\r\n procedure CMFontChanged(var Msg: TMessage); message CM_FONTCHANGED;\r\n protected\r\n procedure GlyphsListChanged(Sender: TObject);\r\n procedure WndProc(var Mesg: TMessage); override;\r\n procedure CreateParams(var Params: TCreateParams); override;\r\n procedure Loaded; override;\r\n procedure Notification(AComponent: TComponent; Operation: TOperation); override;\r\n public\r\n procedure RemakeFonts;\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n property GlyphIndex[Index: Integer]: Integer read GetGlyphIndex write SetGlyphIndex;\r\n property TabColor[Index: Integer]: TColor read GetTabColor write SetTabColor;\r\n // property GlyphState[Index: Integer]: Integer read GetGlyphState write SetGlyphState;\r\n property SuppressDraw: Boolean read FSuppressDraw write FSuppressDraw;\r\n published\r\n property AboutJVCL: TJVCLAboutInfo read FAboutJVCL write FAboutJVCL stored False;\r\n property Glyphs: TImageList read FGlyphs write SetGlyphs;\r\n property SingleGlyph: Boolean read FSingleGlyph write SetSingleGlyph default False;\r\n property TabStyle: TJvgTabStyle read FTabStyle write FTabStyle;\r\n property TabSelectedStyle: TJvgTabStyle read FTabSelectedStyle write FTabSelectedStyle;\r\n property Wallpaper: TJvgTabsWallpaper read FWallpaper write FWallpaper;\r\n property DrawGlyphsOption: TglWallpaperOption\r\n read FDrawGlyphsOption write SetDrawGlyphsOption default fwoNone;\r\n property LookLikeButtons: Boolean read FLookLikeButtons write SetLookLikeButtons\r\n default False;\r\n property TabsPosition: TglSide read FTabsPosition write SetTabsPosition default fsdTop;\r\n property Options: TglTabOptions read FOptions write SetOptions;\r\n property FontDirection: TglLabelDir read FFontDirection write SetFontDirection default fldLeftRight;\r\n property Font: TFont read GetFont write SetFont;\r\n property OnGetItemColor: TglOnGetItemColorEvent read FOnGetItemColor write FOnGetItemColor;\r\n property OnGetItemFontColor: TglOnGetItemColorEvent read FOnGetItemFontColor write FOnGetItemFontColor;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvgTab.pas $';\r\n Revision: '$Revision: 13104 $';\r\n Date: '$Date: 2011-09-07 08:50:43 +0200 (mer. 07 sept. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n Math, JvJVCLUtils;\r\n\r\nconst\r\n FontDirs: array [TglSide] of TglLabelDir =\r\n (fldDownUp, fldLeftRight, fldUpDown, fldLeftRight);\r\n\r\nconstructor TJvgTabControl.Create(AOwner: TComponent);\r\nconst\r\n cFontName = 'Arial';\r\nbegin\r\n inherited Create(AOwner);\r\n TabStop := False;\r\n FTabStyle := TJvgTabStyle.Create(Self);\r\n FTabSelectedStyle := TJvgTabStyle.Create(Self);\r\n FWallpaper := TJvgTabsWallpaper.Create;\r\n FFontNormal := TFont.Create;\r\n FFontSelected := TFont.Create;\r\n FDrawTabStr.Font_ := TFont.Create;\r\n\r\n FTabStyle.Font.Name := cFontName;\r\n FTabSelectedStyle.Font.Name := cFontName;\r\n\r\n // if csDesigning in ComponentState then\r\n // FTabSelectedStyle.BackgrColor := clbtnHighlight;\r\n\r\n FGlyphTmpBitmap := TBitmap.Create;\r\n FGlyphsChangeLink := TChangeLink.Create;\r\n FGlyphsChangeLink.OnChange := GlyphsListChanged;\r\n\r\n //...set defaults\r\n FSingleGlyph := False;\r\n\r\n FDrawGlyphsOption := fwoNone;\r\n FTabsPosition := fsdTop;\r\n FOptions := [ftoAutoFontDirection, ftoExcludeGlyphs];\r\n FFontDirection := fldLeftRight;\r\n\r\n FTabStyle.OnChanged := SmthChanged;\r\n FTabSelectedStyle.OnChanged := SmthChanged;\r\n FTabStyle.OnFontChanged := FontsChanged;\r\n FTabSelectedStyle.OnFontChanged := FontsChanged;\r\n FWallpaper.OnChanged := SmthChanged;\r\n FillChar(FTabColors, SizeOf(FTabColors), $FF);\r\nend;\r\n\r\ndestructor TJvgTabControl.Destroy;\r\nbegin\r\n FTabStyle.Free;\r\n FTabSelectedStyle.Free;\r\n FGlyphTmpBitmap.Free;\r\n FWallpaper.Free;\r\n FGlyphsChangeLink.Free;\r\n FFontNormal.Free;\r\n FFontSelected.Free;\r\n FDrawTabStr.Font_.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvgTabControl.SmthChanged;\r\nbegin\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvgTabControl.FontsChanged;\r\nbegin\r\n RemakeFonts;\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvgTabControl.CreateParams(var Params: TCreateParams);\r\nconst\r\n PosStyles: array [TglSide] of DWORD =\r\n (TCS_VERTICAL, 0, TCS_VERTICAL or TCS_RIGHT, TCS_BOTTOM);\r\n // or TCS_SCROLLOPPOSITE or TCS_BUTTONS\r\nbegin\r\n inherited CreateParams(Params);\r\n with Params do\r\n begin\r\n if LookLikeButtons then\r\n Style := Style or TCS_BUTTONS;\r\n Style := Style or TCS_OWNERDRAWFIXED or PosStyles[FTabsPosition];\r\n end;\r\nend;\r\n\r\nprocedure TJvgTabControl.Loaded;\r\nbegin\r\n inherited Loaded;\r\n RemakeFonts;\r\n if Assigned(Wallpaper.Bitmap) and (not Wallpaper.Bitmap.Empty) then\r\n Wallpaper.Bmp := Wallpaper.Bitmap;\r\nend;\r\n\r\nprocedure TJvgTabControl.Notification(AComponent: TComponent;\r\n Operation: TOperation);\r\nbegin\r\n inherited Notification(AComponent, Operation);\r\n if (Operation = opRemove) then\r\n if Assigned(Wallpaper) and (AComponent = Wallpaper.Image) then\r\n Wallpaper.Image := nil\r\n else if (AComponent = Glyphs) then\r\n Glyphs := nil;\r\nend;\r\n\r\nprocedure TJvgTabControl.CNDrawItem(var Msg: TWMDrawItem);\r\nbegin\r\n DrawItem(Pointer(Msg.DrawItemStruct));\r\nend;\r\n\r\nprocedure TJvgTabControl.WndProc(var Mesg: TMessage);\r\nvar\r\n GlyphID: Integer;\r\nbegin\r\n inherited WndProc(Mesg);\r\n with Mesg do\r\n case Msg of\r\n TCM_INSERTITEM:\r\n begin\r\n Result := 0;\r\n if not Assigned(FGlyphs) then\r\n Exit;\r\n GlyphID := -1;\r\n if FSingleGlyph then\r\n GlyphID := 0\r\n else\r\n if WParam < Windows.WPARAM(FGlyphs.Count) then\r\n GlyphID := WParam;\r\n if GlyphID = -1 then\r\n Exit;\r\n TTCItem(Pointer(Mesg.LParam)^).iImage := GlyphID;\r\n TTCItem(Pointer(Mesg.LParam)^).mask := TCIF_IMAGE;\r\n SendMessage(Handle, TCM_SETITEM, WParam, LParam);\r\n end;\r\n TCM_DELETEITEM:\r\n begin\r\n end;\r\n TCM_DELETEALLITEMS:\r\n begin\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvgTabControl.GlyphsListChanged(Sender: TObject);\r\nbegin\r\n if HandleAllocated then\r\n SendMessage(Handle, TCM_SETIMAGELIST, 0, LPARAM(TImageList(Sender).Handle));\r\nend;\r\n\r\nprocedure TJvgTabControl.DrawItem(lpDrawItemStr: PDrawItemStruct);\r\nvar\r\n FontColor: TColor;\r\nbegin\r\n if SuppressDraw then\r\n Exit;\r\n with lpDrawItemStr^ do\r\n if CtlType = ODT_TAB then\r\n begin\r\n //fLoaded:=True; Options:=NewOptions;\r\n FDrawTabStr.lpDrawItemStr := lpDrawItemStr;\r\n FDrawTabStr.Caption := Tabs[ItemID];\r\n\r\n if GlyphIndex[ItemID] <> -1 then\r\n begin\r\n FGlyphs.GetBitmap(GlyphIndex[ItemID], FGlyphTmpBitmap);\r\n FDrawTabStr.Glyph := FGlyphTmpBitmap;\r\n end\r\n else\r\n FDrawTabStr.Glyph := nil;\r\n\r\n if (itemState and ODS_DISABLED) <> 0 then\r\n begin\r\n FDrawTabStr.BoxStyle := FTabStyle;\r\n FDrawTabStr.Font_.Assign(FFontNormal);\r\n end\r\n else\r\n if (itemState and ODS_SELECTED) <> 0 then\r\n begin\r\n FDrawTabStr.BoxStyle := FTabSelectedStyle;\r\n FDrawTabStr.Font_.Assign(FFontSelected);\r\n end\r\n else\r\n begin\r\n FDrawTabStr.BoxStyle := FTabStyle;\r\n FDrawTabStr.Font_.Assign(FFontNormal);\r\n end;\r\n\r\n if Assigned(OnGetItemFontColor) then\r\n begin\r\n OnGetItemFontColor(Self, ItemID, FontColor);\r\n FDrawTabStr.Font_.Color := FontColor;\r\n end;\r\n\r\n FDrawTabStr.GlyphOption := FDrawGlyphsOption;\r\n FDrawTabStr.Wallpaper := FWallpaper;\r\n FDrawTabStr.ClientR := ClientRect;\r\n FDrawTabStr.TabsCount := Tabs.Count;\r\n FDrawTabStr.fButton := LookLikeButtons;\r\n FDrawTabStr.Position := TabsPosition;\r\n FDrawTabStr.Options := Options;\r\n FDrawTabStr.FontDirection := FontDirection;\r\n if Assigned(FOnGetItemColor) then\r\n FOnGetItemColor(Self, ItemID, FDrawTabStr.BackgrColor_)\r\n else\r\n if FTabColors[ItemID] <> -1 then\r\n FDrawTabStr.BackgrColor_ := FTabColors[ItemID]\r\n else\r\n FDrawTabStr.BackgrColor_ := FDrawTabStr.BoxStyle.BackgrColor;\r\n DrawOwnTab(FDrawTabStr); //FWallpaper.IncludeBevels\r\n end;\r\nend;\r\n\r\nprocedure TJvgTabControl.CMFontChanged(var Msg: TMessage);\r\nbegin\r\n inherited;\r\n if ftoInheriteTabFonts in Options then\r\n begin\r\n FTabStyle.Font.Assign(inherited Font);\r\n FTabSelectedStyle.Font.Assign(inherited Font);\r\n // Disabled.Assign(inherited Font);\r\n RemakeFonts;\r\n end;\r\nend;\r\n\r\nprocedure TJvgTabControl.RemakeFonts;\r\nconst\r\n RadianEscapments: array [TglLabelDir] of Integer =\r\n (0, -1800, -900, 900);\r\nbegin\r\n if csReading in ComponentState then\r\n Exit;\r\n if FNotFirst then\r\n DeleteObject(FTabStyle.Font.Handle);\r\n FNotFirst := True;\r\n\r\n FFontNormal.Handle := CreateRotatedFont(FTabStyle.Font,\r\n RadianEscapments[FFontDirection]);\r\n FFontNormal.Color := FTabStyle.Font.Color;\r\n FFontSelected.Handle := CreateRotatedFont(FTabSelectedStyle.Font,\r\n RadianEscapments[FFontDirection]);\r\n FFontSelected.Color := FTabSelectedStyle.Font.Color;\r\n\r\nend;\r\n\r\nprocedure TJvgTabControl.SetGlyphs(Value: TImageList);\r\nvar\r\n I: Word;\r\n B: Boolean;\r\nbegin\r\n ReplaceImageListReference(Self, Value, TCustomImageList(FGlyphs), FGlyphsChangeLink);\r\n if Assigned(FGlyphs) then\r\n begin\r\n SendMessage(Handle, TCM_SETIMAGELIST, 0, LPARAM(FGlyphs.Handle));\r\n B := True;\r\n for I := 0 to Min(Tabs.Count - 1, FGlyphs.Count - 1) do\r\n if GlyphIndex[I] <> -1 then\r\n begin\r\n B := False;\r\n Break;\r\n end;\r\n if B then\r\n SetSingleGlyph(FSingleGlyph);\r\n end\r\n else\r\n SendMessage(Handle, TCM_SETIMAGELIST, 0, 0);\r\nend;\r\n\r\nprocedure TJvgTabControl.SetGlyphIndex(Index: Integer; ImgIndex: Integer);\r\nvar\r\n R: TRect;\r\n Item: TTCItem;\r\nbegin\r\n Item.iImage := ImgIndex;\r\n Item.mask := TCIF_IMAGE;\r\n SendMessage(Handle, TCM_SETITEM, Index, LPARAM(@Item));\r\n SendMessage(Handle, TCM_GETITEMRECT, Index, LPARAM(@R));\r\n InvalidateRect(Handle, @R, True);\r\nend;\r\n\r\nfunction TJvgTabControl.GetGlyphIndex(Index: Integer): Integer;\r\nvar\r\n ImgItem: TTCItem;\r\nbegin\r\n if Assigned(FGlyphs) then\r\n begin\r\n ImgItem.mask := TCIF_IMAGE;\r\n SendMessage(Handle, TCM_GETITEM, Index, LPARAM(@ImgItem));\r\n Result := ImgItem.iImage;\r\n end\r\n else\r\n Result := -1;\r\nend;\r\n\r\nprocedure TJvgTabControl.SetSingleGlyph(Value: Boolean);\r\nvar\r\n I: Word;\r\nbegin\r\n FSingleGlyph := Value;\r\n if (Tabs = nil) or (FGlyphs = nil) then\r\n Exit;\r\n if FSingleGlyph then\r\n for I := 0 to Tabs.Count - 1 do\r\n GlyphIndex[I] := 0\r\n else\r\n for I := 0 to Tabs.Count - 1 do\r\n if FGlyphs.Count >= I then\r\n GlyphIndex[I] := I\r\n else\r\n Break;\r\nend;\r\n\r\nprocedure TJvgTabControl.SetDrawGlyphsOption(Value: TglWallpaperOption);\r\nbegin\r\n if FDrawGlyphsOption <> Value then\r\n begin\r\n FDrawGlyphsOption := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvgTabControl.SetLookLikeButtons(Value: Boolean);\r\nbegin\r\n if FLookLikeButtons <> Value then\r\n begin\r\n FLookLikeButtons := Value;\r\n RecreateWnd;\r\n end;\r\nend;\r\n\r\nprocedure TJvgTabControl.SetTabsPosition(Value: TglSide);\r\nbegin\r\n if FTabsPosition <> Value then\r\n begin\r\n FTabsPosition := Value;\r\n RecreateWnd;\r\n if (ftoAutoFontDirection in FOptions) and not (csLoading in ComponentState) then\r\n FontDirection := FontDirs[TabsPosition];\r\n end;\r\nend;\r\n\r\nprocedure TJvgTabControl.SetOptions(Value: TglTabOptions);\r\nbegin\r\n if FOptions <> Value then\r\n begin\r\n FOptions := Value;\r\n if ftoAutoFontDirection in FOptions then\r\n FontDirection := FontDirs[TabsPosition];\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvgTabControl.SetFontDirection(Value: TglLabelDir);\r\nbegin\r\n if FFontDirection <> Value then\r\n begin\r\n FFontDirection := Value;\r\n RemakeFonts;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nfunction TJvgTabControl.GetFont: TFont;\r\nbegin\r\n Result := inherited Font;\r\nend;\r\n\r\nprocedure TJvgTabControl.SetFont(Value: TFont);\r\nbegin\r\n inherited Font := Value;\r\n if ftoInheriteTabFonts in Options then\r\n begin\r\n FTabStyle.Font.Assign(inherited Font);\r\n FTabSelectedStyle.Font.Assign(inherited Font);\r\n end;\r\nend;\r\n\r\nfunction TJvgTabControl.GetTabColor(Index: Integer): TColor;\r\nbegin\r\n if Index < 100 then\r\n Result := FTabColors[Index]\r\n else\r\n Result := -1;\r\nend;\r\n\r\nprocedure TJvgTabControl.SetTabColor(Index: Integer; Value: TColor);\r\nvar\r\n TCItem: TTCItem;\r\nbegin\r\n if (Index < 100) and (TabColor[Index] <> Value) then\r\n FTabColors[Index] := Value\r\n else\r\n Exit;\r\n if not SuppressDraw then\r\n begin\r\n // Repaint;\r\n TCItem.mask := TCIF_TEXT;\r\n TCItem.pszText := PChar(Tabs[Index]);\r\n SendMessage(Handle, TCM_SETITEM, Index, LPARAM(@TCItem));\r\n end;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvgTabComm.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvgTabComm.PAS, released on 2003-01-15.\r\n\r\nThe Initial Developer of the Original Code is Andrey V. Chudin, [chudin att yandex dott ru]\r\nPortions created by Andrey V. Chudin are Copyright (C) 2003 Andrey V. Chudin.\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\nMichael Beck [mbeck att bigfoot dott com].\r\nBurov Dmitry, translation of russian text.\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nDescription:\r\n ...common for JvgTab and JvgPage classes declaration\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvgTabComm.pas 12461 2009-08-14 17:21:33Z obones $\r\n\r\nunit JvgTabComm;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, Graphics, Controls, Classes, ExtCtrls, ComCtrls,\r\n JvgTypes, JvgCommClasses;\r\n\r\nconst\r\n TCS_SCROLLOPPOSITE = $0001; // ; multipage tab [translated]\r\n {$EXTERNALSYM TCS_SCROLLOPPOSITE}\r\n TCS_BOTTOM = $0002;\r\n {$EXTERNALSYM TCS_BOTTOM}\r\n TCS_RIGHT = $0002; // TCS_VERTICAL; used with TCS_VERTICAL [translated]\r\n {$EXTERNALSYM TCS_RIGHT}\r\n TCS_HOTTRACK = $0040;\r\n {$EXTERNALSYM TCS_HOTTRACK}\r\n TCS_VERTICAL = $0080; // ; Only for multi-line mode [translated]\r\n {$EXTERNALSYM TCS_VERTICAL}\r\n\r\ntype\r\n TglOnGetGradientColors = procedure(Sender: TObject; Index: Integer; var Gradient: TJvgGradient) of object;\r\n TJvgTabStyle = class;\r\n TJvgTabsWallpaper = class;\r\n\r\n TDRAWTABSTRUCT = record\r\n lpDrawItemStr: PDrawItemStruct;\r\n ClientR: TRect;\r\n TabsCount: Integer;\r\n Caption: string;\r\n Wallpaper: TJvgTabsWallpaper;\r\n Glyph: TBitmap;\r\n GlyphOption: TglWallpaperOption;\r\n BoxStyle: TJvgTabStyle;\r\n Font_: TFont;\r\n fButton: Boolean;\r\n Position: TglSide;\r\n Options: TglTabOptions;\r\n FontDirection: TglLabelDir;\r\n BackgrColor_: TColor;\r\n FlatButtons: Boolean;\r\n Gradient: TJvgGradient;\r\n end;\r\n\r\n TJvgTabStyle = class(TPersistent)\r\n private\r\n FBorders: TglSides;\r\n FBevelInner: TPanelBevel;\r\n FBevelOuter: TPanelBevel;\r\n FBold: Boolean;\r\n FBackgrColor: TColor;\r\n FFont: TFont;\r\n FTextStyle: TglTextStyle;\r\n FCaptionHAlign: TglHorAlign;\r\n FCaptionVAlign: TglVertAlign;\r\n FGlyphHAlign: TglHorAlign;\r\n FGlyphVAlign: TglVertAlign;\r\n FGradient: TJvgGradient;\r\n FParent: TWinControl;\r\n FOnChanged: TNotifyEvent;\r\n FOnFontChanged: TNotifyEvent;\r\n procedure SetBorders(Value: TglSides);\r\n procedure SetBevelInner(Value: TPanelBevel);\r\n procedure SetBevelOuter(Value: TPanelBevel);\r\n procedure SetBold(Value: Boolean);\r\n procedure SetBackgrColor(Value: TColor);\r\n // procedure SetFillBackgr(Value: Boolean);\r\n procedure SetFont(Value: TFont);\r\n procedure SetTextStyle(Value: TglTextStyle);\r\n procedure SetCaptionHAlign(Value: TglHorAlign);\r\n procedure SetCaptionVAlign(Value: TglVertAlign);\r\n procedure SetGlyphHAlign(Value: TglHorAlign);\r\n procedure SetGlyphVAlign(Value: TglVertAlign);\r\n procedure SetChanged(Value: TNotifyEvent);\r\n protected\r\n procedure Changed;\r\n procedure FontChanged;\r\n public\r\n constructor Create(AOwner: TWinControl);\r\n destructor Destroy; override;\r\n property OnChanged: TNotifyEvent read FOnChanged write SetChanged;\r\n property OnFontChanged: TNotifyEvent read FOnFontChanged write FOnFontChanged;\r\n published\r\n property Borders: TglSides read FBorders write SetBorders;\r\n property BevelInner: TPanelBevel read FBevelInner write SetBevelInner;\r\n property BevelOuter: TPanelBevel read FBevelOuter write SetBevelOuter;\r\n property Bold: Boolean read FBold write SetBold;\r\n property BackgrColor: TColor read FBackgrColor write SetBackgrColor; // default clBtnFace;\r\n // property FillBackgr: Boolean read FFillBackgr write SetFillBackgr default clBtnFace;\r\n property Font: TFont read FFont write SetFont;\r\n property TextStyle: TglTextStyle read FTextStyle write SetTextStyle default fstNone;\r\n property CaptionHAlign: TglHorAlign read FCaptionHAlign write SetCaptionHAlign default fhaLeft;\r\n property CaptionVAlign: TglVertAlign read FCaptionVAlign write SetCaptionVAlign default fvaCenter;\r\n property GlyphHAlign: TglHorAlign read FGlyphHAlign write SetGlyphHAlign default fhaLeft;\r\n property GlyphVAlign: TglVertAlign read FGlyphVAlign write SetGlyphVAlign default fvaCenter;\r\n property Gradient: TJvgGradient read FGradient write FGradient;\r\n end;\r\n\r\n TJvgTabsWallpaper = class(TPersistent)\r\n private\r\n FBitmap: TBitmap;\r\n FImage: TImage;\r\n FFillCaptionBakgr: Boolean;\r\n FFillCaptions: Boolean;\r\n FFillClient: Boolean;\r\n FTile: Boolean;\r\n FIncludeBevels: Boolean;\r\n FOnChanged: TNotifyEvent;\r\n FBmp: TBitmap;\r\n procedure SetBitmap(Value: TBitmap);\r\n procedure SetImage(Value: TImage);\r\n procedure SetFillCaptionBakgr(Value: Boolean);\r\n procedure SetFillCaptions(Value: Boolean);\r\n procedure SetFillClient(Value: Boolean);\r\n procedure SetTile(Value: Boolean);\r\n procedure SetIncludeBevels(Value: Boolean);\r\n protected\r\n procedure Changed;\r\n public\r\n constructor Create;\r\n destructor Destroy; override;\r\n property OnChanged: TNotifyEvent read FOnChanged write FOnChanged;\r\n property Bmp: TBitmap read FBmp write FBmp;\r\n published\r\n property Bitmap: TBitmap read FBitmap write SetBitmap;\r\n property Image: TImage read FImage write SetImage;\r\n property FillCaptions: Boolean read FFillCaptions write SetFillCaptions default True;\r\n property FillCaptionBakgr: Boolean read FFillCaptionBakgr write SetFillCaptionBakgr default False;\r\n property FillClient: Boolean read FFillClient write SetFillClient default False;\r\n property Tile: Boolean read FTile write SetTile default True;\r\n property IncludeBevels: Boolean read FIncludeBevels write SetIncludeBevels default True;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvgTabComm.pas $';\r\n Revision: '$Revision: 12461 $';\r\n Date: '$Date: 2009-08-14 19:21:33 +0200 (ven. 14 août 2009) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\ntype\r\n TControlAccessProtected = class(TControl);\r\n\r\n//=== { TJvgTabStyle } =======================================================\r\n\r\nconstructor TJvgTabStyle.Create(AOwner: TWinControl);\r\nbegin\r\n inherited Create;\r\n FGradient := TJvgGradient.Create;\r\n //...set defaults\r\n // FBevelInner := bvRaised;\r\n // FBevelOuter := bvLowered;\r\n FBorders := [fsdLeft, fsdTop, fsdRight, fsdBottom];\r\n FBold := False;\r\n FBackgrColor := clBtnFace;\r\n // FFillBackgr := False;\r\n FParent := TWinControl(AOwner);\r\n FFont := TFont.Create;\r\n Font.Assign(TControlAccessProtected(FParent).Font);\r\n FTextStyle := fstNone;\r\n FCaptionHAlign := fhaLeft;\r\n FCaptionVAlign := fvaCenter;\r\n FGlyphHAlign := fhaLeft;\r\n FGlyphVAlign := fvaCenter;\r\nend;\r\n\r\ndestructor TJvgTabStyle.Destroy;\r\nbegin\r\n FFont.Free;\r\n FGradient.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvgTabStyle.Changed;\r\nbegin\r\n if Assigned(FOnChanged) then\r\n FOnChanged(Self);\r\nend;\r\n\r\nprocedure TJvgTabStyle.SetBorders(Value: TglSides);\r\nbegin\r\n if FBorders <> Value then\r\n begin\r\n FBorders := Value;\r\n Changed;\r\n end;\r\nend;\r\n\r\nprocedure TJvgTabStyle.SetBevelInner(Value: TPanelBevel);\r\nbegin\r\n if FBevelInner <> Value then\r\n begin\r\n FBevelInner := Value;\r\n Changed;\r\n end;\r\nend;\r\n\r\nprocedure TJvgTabStyle.SetBevelOuter(Value: TPanelBevel);\r\nbegin\r\n if FBevelOuter <> Value then\r\n begin\r\n FBevelOuter := Value;\r\n Changed;\r\n end;\r\nend;\r\n\r\nprocedure TJvgTabStyle.SetBold(Value: Boolean);\r\nbegin\r\n if FBold <> Value then\r\n begin\r\n FBold := Value;\r\n Changed;\r\n end;\r\nend;\r\n\r\nprocedure TJvgTabStyle.SetBackgrColor(Value: TColor);\r\nbegin\r\n if FBackgrColor <> Value then\r\n begin\r\n FBackgrColor := Value;\r\n Changed;\r\n end;\r\nend;\r\n\r\n{procedure TJvgTabStyle.SetFillBackgr(Value: Boolean);\r\nbegin\r\n if FFillBackgr = Value then\r\n Exit;\r\n FFillBackgr := Value;\r\n if Assigned(OnChanged) then\r\n OnChanged(Self);\r\nend;\r\n}\r\n\r\nprocedure TJvgTabStyle.SetFont(Value: TFont);\r\nbegin\r\n if Assigned(Value) then\r\n FFont.Assign(Value);\r\n if TTabControl(FParent).Font.Size < Value.Size then\r\n TTabControl(FParent).Font.Assign(Value);\r\n FontChanged;\r\nend;\r\n\r\nprocedure TJvgTabStyle.FontChanged;\r\nbegin\r\n if Assigned(FOnFontChanged) then\r\n FOnFontChanged(Self);\r\nend;\r\n\r\nprocedure TJvgTabStyle.SetTextStyle(Value: TglTextStyle);\r\nbegin\r\n if FTextStyle <> Value then\r\n begin\r\n FTextStyle := Value;\r\n Changed;\r\n end;\r\nend;\r\n\r\nprocedure TJvgTabStyle.SetCaptionHAlign(Value: TglHorAlign);\r\nbegin\r\n if FCaptionHAlign <> Value then\r\n begin\r\n FCaptionHAlign := Value;\r\n Changed;\r\n end;\r\nend;\r\n\r\nprocedure TJvgTabStyle.SetCaptionVAlign(Value: TglVertAlign);\r\nbegin\r\n if FCaptionVAlign <> Value then\r\n begin\r\n FCaptionVAlign := Value;\r\n Changed;\r\n end;\r\nend;\r\n\r\nprocedure TJvgTabStyle.SetGlyphHAlign(Value: TglHorAlign);\r\nbegin\r\n if FGlyphHAlign <> Value then\r\n begin\r\n FGlyphHAlign := Value;\r\n Changed;\r\n end;\r\nend;\r\n\r\nprocedure TJvgTabStyle.SetGlyphVAlign(Value: TglVertAlign);\r\nbegin\r\n if FGlyphVAlign <> Value then\r\n begin\r\n FGlyphVAlign := Value;\r\n Changed;\r\n end;\r\nend;\r\n\r\nprocedure TJvgTabStyle.SetChanged(Value: TNotifyEvent);\r\nbegin\r\n FOnChanged := Value;\r\n FGradient.OnChanged := Value;\r\nend;\r\n\r\n//=== { TJvgTabsWallpaper } ==================================================\r\n\r\nconstructor TJvgTabsWallpaper.Create;\r\nbegin\r\n inherited Create;\r\n FBitmap := TBitmap.Create;\r\n //...set defaults\r\n FFillCaptionBakgr := False;\r\n FFillCaptions := True;\r\n FFillClient := False;\r\n FIncludeBevels := True;\r\n FTile := True;\r\nend;\r\n\r\ndestructor TJvgTabsWallpaper.Destroy;\r\nbegin\r\n FBitmap.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvgTabsWallpaper.Changed;\r\nbegin\r\n if Assigned(FOnChanged) then\r\n FOnChanged(Self);\r\nend;\r\n\r\nprocedure TJvgTabsWallpaper.SetBitmap(Value: TBitmap);\r\nbegin\r\n FBitmap.Assign(Value);\r\n if Assigned(Value) then\r\n FBmp := FBitmap\r\n else\r\n if Assigned(FImage) and Assigned(FImage.Picture) and Assigned(FImage.Picture.Bitmap) then\r\n FBmp := FImage.Picture.Bitmap\r\n else\r\n FBmp := nil;\r\nend;\r\n\r\nprocedure TJvgTabsWallpaper.SetImage(Value: TImage);\r\nbegin\r\n FImage := Value;\r\n if Assigned(FImage) and Assigned(FImage.Picture) and Assigned(FImage.Picture.Bitmap) then\r\n FBmp := FImage.Picture.Bitmap\r\n else\r\n if Assigned(FBitmap) then\r\n FBmp := FBitmap\r\n else\r\n FBmp := nil;\r\n Changed;\r\nend;\r\n\r\nprocedure TJvgTabsWallpaper.SetFillCaptionBakgr(Value: Boolean);\r\nbegin\r\n if FFillCaptionBakgr <> Value then\r\n begin\r\n FFillCaptionBakgr := Value;\r\n Changed;\r\n end;\r\nend;\r\n\r\nprocedure TJvgTabsWallpaper.SetFillCaptions(Value: Boolean);\r\nbegin\r\n if FFillCaptions <> Value then\r\n begin\r\n FFillCaptions := Value;\r\n Changed;\r\n end;\r\nend;\r\n\r\nprocedure TJvgTabsWallpaper.SetFillClient(Value: Boolean);\r\nbegin\r\n if FFillClient <> Value then\r\n begin\r\n FFillClient := Value;\r\n Changed;\r\n end;\r\nend;\r\n\r\nprocedure TJvgTabsWallpaper.SetTile(Value: Boolean);\r\nbegin\r\n if FTile <> Value then\r\n begin\r\n FTile := Value;\r\n Changed;\r\n end;\r\nend;\r\n\r\nprocedure TJvgTabsWallpaper.SetIncludeBevels(Value: Boolean);\r\nbegin\r\n if FIncludeBevels <> Value then\r\n begin\r\n FIncludeBevels := Value;\r\n Changed;\r\n end;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvgTypes.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvgTypes.PAS, released on 2003-01-15.\r\n\r\nThe Initial Developer of the Original Code is Andrey V. Chudin, [chudin att yandex dott ru]\r\nPortions created by Andrey V. Chudin are Copyright (C) 2003 Andrey V. Chudin.\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\nMichael Beck [mbeck att bigfoot dott com].\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvgTypes.pas 12461 2009-08-14 17:21:33Z obones $\r\n\r\nunit JvgTypes;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Graphics;\r\n\r\n{$IFDEF MSWINDOWS}\r\n\r\nconst\r\n { OEM Resource Ordinal Numbers }\r\n OBM_CLOSE = 32754;\r\n OBM_UPARROW = 32753;\r\n OBM_DNARROW = 32752;\r\n OBM_RGARROW = 32751;\r\n OBM_LFARROW = 32750;\r\n OBM_REDUCE = 32749;\r\n OBM_ZOOM = 32748;\r\n OBM_RESTORE = 32747;\r\n OBM_REDUCED = 32746;\r\n OBM_ZOOMD = 32745;\r\n OBM_RESTORED = 32744;\r\n OBM_UPARROWD = 32743;\r\n OBM_DNARROWD = 32742;\r\n OBM_RGARROWD = 32741;\r\n OBM_LFARROWD = 32740;\r\n OBM_MNARROW = 32739;\r\n OBM_COMBO = 32738;\r\n OBM_UPARROWI = 32737;\r\n OBM_DNARROWI = 32736;\r\n OBM_RGARROWI = 32735;\r\n OBM_LFARROWI = 32734;\r\n OBM_OLD_CLOSE = 32767;\r\n OBM_SIZE = 32766;\r\n OBM_OLD_UPARROW = 32765;\r\n OBM_OLD_DNARROW = 32764;\r\n OBM_OLD_RGARROW = 32763;\r\n OBM_OLD_LFARROW = 32762;\r\n OBM_BTSIZE = 32761;\r\n OBM_CHECK = 32760;\r\n OBM_CHECKBOXES = 32759;\r\n OBM_BTNCORNERS = 32758;\r\n OBM_OLD_REDUCE = 32757;\r\n OBM_OLD_ZOOM = 32756;\r\n OBM_OLD_RESTORE = 32755;\r\n\r\n{$ENDIF MSWINDOWS}\r\n\r\ntype\r\n TglItemsDrawStyle = (idsNone, idsRecessed, idsRaised);\r\n TglWallpaperOption = (fwoNone, fwoStretch, fwoPropStretch, fwoTile);\r\n TglDrawState = (fdsDefault, fdsDisabled, fdsDelicate);\r\n TglVertAlign = (fvaTop, fvaCenter, fvaBottom);\r\n TglHorAlign = (fhaLeft, fhaCenter, fhaRight);\r\n TglSizingDir = (fsdIncrease, fsdDecrease);\r\n TglScalingDir = (fsdRaising, fsdRecessing);\r\n TglTextStyle = (fstNone, fstRaised, fstRecessed, fstPushed, fstShadow,\r\n fstVolumetric);\r\n TglAutoTransparentColor = (ftcUser, ftcLeftTopPixel, ftcLeftBottomPixel,\r\n ftcRightTopPixel, ftcRightBottomPixel);\r\n TglGradientDir = (fgdHorizontal, fgdVertical, fgdLeftBias, fgdRightBias,\r\n fgdRectangle, fgdHorzConvergent, fgdVertConvergent);\r\n TglLinesDir = (fldHorizontal, fldVertical, fldLeftBias, fldRightBias);\r\n TThreeDGradientType = (fgtFlat, fgt3D);\r\n // TglGgradientColorOnStep = ( fgcIncrease, fgcDecrease );\r\n TglLabelDir = (fldLeftRight, fldRightLeft, fldUpDown, fldDownUp);\r\n TglAlignment = (ftaLeftJustify, ftaRightJustify, ftaCenter, ftaBroadwise);\r\n TglGlyphKind = (fgkCustom, fgkDefault);\r\n TglFileType = (fftUndefined, fftGif, fftJpeg, fftBmp);\r\n // TglProgressBorderStyle = (fbsFlat, fbsCtl3D, fbsStatusControl,\r\n // fbsRaised, fbsRaisedFrame, fbsRecessedFrame);\r\n TglLabelOption = (floActiveWhileControlFocused, floBufferedDraw,\r\n floDelineatedText, floIgnoreMouse, {floQuality3D,} floTransparentFont);\r\n TglLabelOptions = set of TglLabelOption;\r\n TglStaticTextOption = (ftoActiveWhileControlFocused, ftoBroadwiseLastLine,\r\n ftoIgnoreMouse, ftoUnderlinedActive);\r\n TglStaticTextOptions = set of TglStaticTextOption;\r\n TglCheckBoxOption = (fcoActiveWhileControlFocused, fcoBoldChecked,\r\n fcoEnabledFocusControlWhileChecked, fcoIgnoreMouse, fcoDelineatedText,\r\n {fcoQuality3D,} fcoFastDraw, fcoUnderlinedActive);\r\n TglCheckBoxOptions = set of TglCheckBoxOption;\r\n TglGroupBoxOption = (fgoCanCollapse, fgoCollapseOther, fgoFilledCaption,\r\n fgoFluentlyCollapse, fgoFluentlyExpand, fgoResizeParent,\r\n fgoHideChildrenWhenCollapsed, fgoIgnoreMouse, fgoDelineatedText,\r\n {fgoQuality3D,} fgoBufferedDraw, fgoOneAlwaysExpanded, fgoSaveChildFocus);\r\n TglGroupBoxOptions = set of TglGroupBoxOption;\r\n TglListBoxOption = (fboAutoCtl3DColors, fboBufferedDraw,\r\n fboChangeGlyphColor, fboDelineatedText, fboExcludeGlyphs, fboHideText,\r\n fboHotTrack, fboHotTrackSelect, fboItemColorAsGradientFrom,\r\n fboItemColorAsGradientTo, fboMouseMoveSentensive, fboShowFocus,\r\n fboSingleGlyph, fboTransparent, fboWordWrap);\r\n TglListBoxOptions = set of TglListBoxOption;\r\n TglProgressOption = (fpoDelineatedText, fpoTransparent);\r\n TglProgressOptions = set of TglProgressOption;\r\n TglTabOption = (ftoAutoFontDirection, ftoExcludeGlyphs, ftoHideGlyphs,\r\n ftoInheriteTabFonts, ftoTabColorAsGradientFrom, ftoTabColorAsGradientTo,\r\n ftoWordWrap);\r\n TglTabOptions = set of TglTabOption;\r\n\r\n TglTreeViewOption = (ftvFlatScroll);\r\n TglTreeViewOptions = set of TglTreeViewOption;\r\n\r\n TFocusControlMethod = (fcmOnMouseEnter, fcmOnMouseDown, fcmOnMouseUp);\r\n TglOnGetItemColorEvent = procedure(Sender: TObject; Index: Integer; var Color: TColor) of object;\r\n\r\n // TglDrawGlyphsOption = ( fgoDefaultEnabled, fgoDefaultDisabled );\r\n // TglDrawGlyphsOptions = set of TglGlyphsOptions;\r\n TglBoxStyle = (fbsFlat, fbsCtl3D, fbsStatusControl, fbsRecessed, fbsRaised,\r\n fbsRaisedFrame, fbsRecessedFrame);\r\n TglSide = (fsdLeft, fsdTop, fsdRight, fsdBottom);\r\n // TBorders = set of TBorder;\r\n TglSides = set of TglSide;\r\n TglOrigin = (forLeftTop, forRightBottom);\r\n TglAlign = record\r\n Horizontal: TglHorAlign;\r\n Vertical: TglVertAlign;\r\n end;\r\n\r\n TglHComponentAlign = (haNoChange, haLeft, haCenters, haRight, haSpaceEqually,\r\n haCenterWindow, haClose);\r\n TglVComponentAlign = (vaNoChange, vaTops, vaCenters, vaBottoms,\r\n vaSpaceEqually, vaCenterWindow, vaClose);\r\n\r\n TglCheckKind = (fckCheckBoxes, fckRadioButtons);\r\n\r\n TglGlobalData = record\r\n fSuppressGradient: Boolean;\r\n lp3DColors: Pointer;\r\n end;\r\n\r\nconst\r\n ALLGLSIDES = [fsdLeft, fsdTop, fsdRight, fsdBottom];\r\n\r\n// (rom) not very elegant should be removed\r\n\r\nvar //...global variables\r\n glGlobalData: TglGlobalData = (\r\n fSuppressGradient: False;\r\n lp3DColors: nil\r\n );\r\n\r\n // fgcSUPRESSGRADIENTFILLING = $10000000;\r\n // fgcUSEFR3DCOLORSDATACOMPONENT = $20000000;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvgTypes.pas $';\r\n Revision: '$Revision: 12461 $';\r\n Date: '$Date: 2009-08-14 19:21:33 +0200 (ven. 14 août 2009) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvgUtils.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvgUtils.PAS, released on 2003-01-15.\r\n\r\nThe Initial Developer of the Original Code is Andrey V. Chudin, [chudin att yandex dott ru]\r\nPortions created by Andrey V. Chudin are Copyright (C) 2003 Andrey V. Chudin.\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\nMichael Beck [mbeck att bigfoot dott com].\r\nBurov Dmitry, translation of russian text.\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvgUtils.pas 13104 2011-09-07 06:50:43Z obones $\r\n\r\nunit JvgUtils;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, Messages, Graphics, ExtCtrls,\r\n SysUtils, Classes, Controls, Forms, MMSystem,\r\n JvgTypes, JvgCommClasses, Jvg3DColors;\r\n\r\ntype\r\n TJvgPublicWinControl = class(TWinControl)\r\n public\r\n procedure PaintWindow(DC: HDC); override;\r\n procedure RecreateWnd;\r\n property Font;\r\n property OnEnter;\r\n property OnExit;\r\n property Color;\r\n end;\r\n\r\nfunction IsEven(I: Integer): Boolean;\r\nfunction InchesToPixels(DC: HDC; Value: Single; IsHorizontal: Boolean): Integer;\r\nfunction CentimetersToPixels(DC: HDC; Value: Single; IsHorizontal: Boolean): Integer;\r\n\r\nprocedure SwapInt(var I1, I2: Integer);\r\nfunction Spaces(Count: Integer): string;\r\nfunction DupStr(const Str: string; Count: Integer): string;\r\nfunction DupChar(C: Char; Count: Integer): string;\r\nprocedure Msg(const AMsg: string);\r\nfunction RectW(R: TRect): Integer;\r\nfunction RectH(R: TRect): Integer;\r\nfunction IncColor(AColor: Longint; AOffset: Byte): Longint;\r\nfunction DecColor(AColor: Longint; AOffset: Byte): Longint;\r\nfunction IsItAFilledBitmap(Bmp: TBitmap): Boolean;\r\nprocedure DrawTextInRectWithAlign(DC: HDC; R: TRect; const Text: string;\r\n HAlign: TglHorAlign; VAlign: TglVertAlign;\r\n Style: TglTextStyle; Fnt: TFont; Flags: UINT);\r\n\r\nprocedure DrawTextInRect(DC: HDC; R: TRect; const Text: string;\r\n Style: TglTextStyle; Fnt: TFont; Flags: UINT);\r\n\r\nprocedure ExtTextOutExt(DC: HDC; X, Y: Integer; R: TRect; const Text: string;\r\n Style: TglTextStyle; ADelineated, ASupress3D: Boolean;\r\n FontColor, DelinColor, HighlightColor, ShadowColor: TColor;\r\n Illumination: TJvgIllumination; Gradient: TJvgGradient; Font: TFont);\r\n\r\nprocedure DrawBox(DC: HDC; var R: TRect; Style: TglBoxStyle;\r\n BackgrColor: Longint; ATransparent: Boolean);\r\n\r\nfunction DrawBoxEx(DC: HDC; ARect: TRect; Borders: TglSides;\r\n BevelInner, BevelOuter: TPanelBevel; Bold: Boolean; BackgrColor: Longint;\r\n ATransparent: Boolean): TRect;\r\n\r\nprocedure GradientBox(DC: HDC; R: TRect; Gradient: TJvgGradient;\r\n PenStyle, PenWidth: Integer);\r\n\r\nprocedure ChangeBitmapColor(Bitmap: TBitmap; FromColor, ToColor: TColor);\r\n\r\nprocedure DrawBitmapExt(DC: HDC; { DC - background & result}\r\n SourceBitmap: TBitmap; R: TRect;\r\n X, Y: Integer; //...X,Y _in_ rect!\r\n BitmapOption: TglWallpaperOption; DrawState: TglDrawState;\r\n ATransparent: Boolean; TransparentColor: TColor; DisabledMaskColor: TColor);\r\n\r\nprocedure CreateBitmapExt(DC: HDC; { DC - background & result}\r\n SourceBitmap: TBitmap; R: TRect;\r\n X, Y: Integer; //...X,Y _in_ rect!\r\n BitmapOption: TglWallpaperOption; DrawState: TglDrawState;\r\n ATransparent: Boolean; TransparentColor: TColor; DisabledMaskColor: TColor);\r\n\r\nprocedure BringParentWindowToTop(Wnd: TWinControl);\r\nfunction GetParentForm(Control: TControl): TForm;\r\nprocedure GetWindowImageFrom(Control: TWinControl; X, Y: Integer; ADrawSelf, ADrawChildWindows: Boolean; DC: HDC);\r\nprocedure GetWindowImage(Control: TWinControl; ADrawSelf, ADrawChildWindows: Boolean; DC: HDC);\r\nprocedure GetParentImageRect(Control: TControl; Rect: TRect; DC: HDC);\r\nfunction CreateRotatedFont(F: TFont; Escapement: Integer): HFONT;\r\nfunction FindMainWindow(const AWndClass, AWndTitle: string): THandle;\r\nprocedure CalcShadowAndHighlightColors(BaseColor: TColor; Colors: TJvgLabelColors);\r\n\r\nfunction CalcMathString(AExpression: string): Single;\r\n\r\nfunction IIF(AExpression: Boolean; IfTrue, IfFalse: Variant): Variant; overload;\r\nfunction IIF(AExpression: Boolean; const IfTrue, IfFalse: string): string; overload;\r\n\r\nfunction GetTransparentColor(Bitmap: TBitmap; AutoTrColor: TglAutoTransparentColor): TColor;\r\nprocedure TypeStringOnKeyboard(const S: string);\r\n//function NextStringGridCell( Grid: TStringGrid ): Boolean;\r\nprocedure DrawTextExtAligned(Canvas: TCanvas; const Text: string; R: TRect; Alignment: TglAlignment; WordWrap: Boolean);\r\nprocedure LoadComponentFromTextFile(Component: TComponent; const FileName: string);\r\nprocedure SaveComponentToTextFile(Component: TComponent; const FileName: string);\r\nfunction ComponentToString(Component: TComponent): string;\r\nprocedure StringToComponent(Component: TComponent; const Value: string);\r\nfunction PlayWaveResource(const ResName: string): Boolean;\r\nfunction UserName: string;\r\nfunction ComputerName: string;\r\nfunction CreateIniFileName: string;\r\nfunction ExpandString(const Str: string; Len: Integer): string;\r\nfunction Transliterate(const Str: string; RusToLat: Boolean): string;\r\nfunction IsSmallFonts: Boolean;\r\nfunction SystemColorDepth: Integer;\r\nfunction GetFileType(const FileName: string): TglFileType;\r\nfunction FindControlAtPt(Control: TWinControl; Pt: TPoint; MinClass: TClass): TControl;\r\nfunction StrPosExt(const Str1, Str2: PChar; Str2Len: DWORD): PChar;\r\n\r\n{$IFDEF glDEBUG}\r\nfunction DeleteObject(P1: HGDIOBJ): BOOL; stdcall;\r\n{$ENDIF glDEBUG}\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvgUtils.pas $';\r\n Revision: '$Revision: 13104 $';\r\n Date: '$Date: 2011-09-07 08:50:43 +0200 (mer. 07 sept. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n JvJCLUtils,\r\n ShlObj, Math,\r\n JvResources, JvConsts;\r\n\r\n{ debug func }\r\n{$IFDEF glDEBUG}\r\nfunction DeleteObject(P1: HGDIOBJ): BOOL; stdcall;\r\nbegin\r\n Result := Windows.DeleteObject(P1);\r\n if not Result then\r\n raise Exception.CreateRes(@RsEObjectMemoryLeak);\r\nend;\r\n{$ENDIF glDEBUG}\r\n\r\nprocedure TJvgPublicWinControl.PaintWindow(DC: HDC);\r\nbegin\r\n inherited PaintWindow(DC);\r\nend;\r\n\r\nprocedure TJvgPublicWinControl.RecreateWnd;\r\nbegin\r\n inherited RecreateWnd;\r\nend;\r\n\r\nfunction IsEven(I: Integer): Boolean;\r\nbegin\r\n Result := not Odd(I);\r\nend;\r\n\r\nprocedure SwapInt(var I1, I2: Integer);\r\nvar\r\n Tmp: Integer;\r\nbegin\r\n Tmp := I1;\r\n I1 := I2;\r\n I2 := Tmp;\r\nend;\r\n\r\nfunction Spaces(Count: Integer): string;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := '';\r\n for I := 1 to Count do\r\n Result := Result + ' ';\r\nend;\r\n\r\nfunction DupChar(C: Char; Count: Integer): string;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := '';\r\n for I := 1 to Count do\r\n Result := Result + C;\r\nend;\r\n\r\nfunction DupStr(const Str: string; Count: Integer): string;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := '';\r\n for I := 1 to Count do\r\n Result := Result + Str;\r\nend;\r\n\r\n{ Modal window with (i) icon and single OK button }\r\n\r\nprocedure Msg(const AMsg: string);\r\nbegin\r\n MessageBox(GetForegroundWindow, PChar(AMsg), '',\r\n MB_APPLMODAL or MB_ICONINFORMATION or MB_OK);\r\nend;\r\n\r\n{ Checks if point is inside rect. Rect's borders are not part of rect }\r\n{ // (andreas) make Delphi 5 compiler happy\r\nfunction IsPointInRect(P: TPoint; R: TRect): Boolean;\r\nbegin\r\n Result := PtInRect(R, P);\r\n// Result := (P.X > R.Left) and (P.X < R.Right) and (P.Y > R.Top) and (P.Y < R.Bottom);\r\nend;\r\n}\r\n\r\n{ Rect's width }\r\n\r\nfunction RectW(R: TRect): Integer;\r\nbegin\r\n Result := R.Right - R.Left;\r\nend;\r\n\r\n{ Rect's height }\r\n\r\nfunction RectH(R: TRect): Integer;\r\nbegin\r\n Result := R.Bottom - R.Top;\r\nend;\r\n\r\n{ Increases components of the colour with given offset }\r\n\r\nfunction IncColor(AColor: Longint; AOffset: Byte): Longint;\r\nvar\r\n R, G, B: Byte;\r\nbegin\r\n if AColor < 0 then\r\n AColor := GetSysColor(AColor and $FF);\r\n R := Min(255, GetRValue(AColor) + AOffset);\r\n G := Min(255, GetGValue(AColor) + AOffset);\r\n B := Min(255, GetBValue(AColor) + AOffset);\r\n Result := RGB(R, G, B);\r\nend;\r\n\r\n{ Decreases components of the colour with given offset }\r\n\r\nfunction DecColor(AColor: Longint; AOffset: Byte): Longint;\r\nvar\r\n R, G, B: Byte;\r\nbegin\r\n if AColor < 0 then\r\n AColor := GetSysColor(AColor and $FF);\r\n R := Max(0, GetRValue(AColor) - AOffset);\r\n G := Max(0, GetGValue(AColor) - AOffset);\r\n B := Max(0, GetBValue(AColor) - AOffset);\r\n Result := RGB(R, G, B);\r\nend;\r\n\r\nfunction InchesToPixels(DC: HDC; Value: Single; IsHorizontal: Boolean): Integer;\r\nconst\r\n LogPixels: array [Boolean] of Integer = (LOGPIXELSY, LOGPIXELSX);\r\nbegin\r\n Result := Round(Value * GetDeviceCaps(DC, LogPixels[IsHorizontal]));// * 1.541 / 10);\r\nend;\r\n\r\nfunction CentimetersToPixels(DC: HDC; Value: Single; IsHorizontal: Boolean): Integer;\r\nconst\r\n LogPixels: array [Boolean] of Integer = (LOGPIXELSY, LOGPIXELSX);\r\nbegin\r\n Result := Round(Value * GetDeviceCaps(DC, LogPixels[IsHorizontal])/2.54);// * 1.541 / 2.54 / 10);\r\nend;\r\n\r\n{ Checks wheter bitmap object is created and is having size }\r\n\r\nfunction IsItAFilledBitmap(Bmp: TBitmap): Boolean;\r\nbegin\r\n with Bmp do\r\n Result := Assigned(Bmp) and (Width <> 0) and (Height <> 0);\r\nend;\r\n\r\n\r\n{\r\n Renders text wth alignment, given style and given font\r\n\r\n DC - Handle of canvas\r\n HAlign, VAlign - Alingment horizontal and vertical\r\n Style - Style (embossed, with shadow, etc)\r\n Flags - Extra parameters for Windows.DrawText\r\n}\r\n\r\nprocedure DrawTextInRectWithAlign(DC: HDC; R: TRect; const Text: string;\r\n HAlign: TglHorAlign; VAlign: TglVertAlign;\r\n Style: TglTextStyle; Fnt: TFont; Flags: UINT);\r\nbegin\r\n case HAlign of\r\n fhaLeft:\r\n Flags := Flags or DT_LEFT;\r\n fhaCenter:\r\n Flags := Flags or DT_CENTER;\r\n fhaRight:\r\n Flags := Flags or DT_RIGHT;\r\n end;\r\n case VAlign of\r\n fvaTop:\r\n Flags := Flags or DT_TOP;\r\n fvaCenter:\r\n Flags := Flags or DT_VCENTER;\r\n fvaBottom:\r\n Flags := Flags or DT_BOTTOM;\r\n end;\r\n\r\n DrawTextInRect(DC, R, Text, Style, Fnt, Flags);\r\nend;\r\n\r\n\r\n{\r\n Renders text with alignment, given style and given font\r\n\r\n DC - Handle of canvas\r\n Style - Style (embossed, with shadow, etc)\r\n Flags - Extra parameters for Windows.DrawText\r\n}\r\n\r\nprocedure DrawTextInRect(DC: HDC; R: TRect; const Text: string; Style: TglTextStyle;\r\n Fnt: TFont; Flags: UINT);\r\nvar\r\n OldBkMode: Integer;\r\n OldFont: Windows.HFONT;\r\n FontColor: TColor;\r\n ShadowColor, HighlightColor: TColor;\r\nbegin\r\n if not Assigned(Fnt) then\r\n Exit;\r\n if Flags = 0 then\r\n Flags := DT_LEFT or DT_VCENTER or DT_SINGLELINE;\r\n OldBkMode := SetBkMode(DC, Ord(Transparent));\r\n FontColor := Fnt.Color;\r\n\r\n ShadowColor := clBtnShadow;\r\n HighlightColor := clBtnHighlight;\r\n\r\n OldFont := SelectObject(DC, Fnt.Handle);\r\n case Style of\r\n fstRaised:\r\n begin\r\n SetTextColor(DC, ColorToRGB(HighlightColor));\r\n OffsetRect(R, -1, -1);\r\n Windows.DrawText(DC, PChar(Text), Length(Text), R, Flags);\r\n SetTextColor(DC, ColorToRGB(ShadowColor));\r\n OffsetRect(R, 2, 2);\r\n Windows.DrawText(DC, PChar(Text), Length(Text), R, Flags);\r\n SetTextColor(DC, ColorToRGB(FontColor));\r\n OffsetRect(R, -1, -1);\r\n Windows.DrawText(DC, PChar(Text), Length(Text), R, Flags);\r\n end;\r\n fstRecessed:\r\n begin\r\n SetTextColor(DC, ColorToRGB(ShadowColor));\r\n OffsetRect(R, -1, -1);\r\n Windows.DrawText(DC, PChar(Text), Length(Text), R, Flags);\r\n SetTextColor(DC, ColorToRGB(HighlightColor));\r\n OffsetRect(R, 2, 2);\r\n Windows.DrawText(DC, PChar(Text), Length(Text), R, Flags);\r\n SetTextColor(DC, ColorToRGB(FontColor));\r\n OffsetRect(R, -1, -1);\r\n Windows.DrawText(DC, PChar(Text), Length(Text), R, Flags);\r\n end;\r\n fstPushed:\r\n begin\r\n SetTextColor(DC, ColorToRGB(HighlightColor));\r\n Windows.DrawText(DC, PChar(Text), Length(Text), R, Flags);\r\n SetTextColor(DC, ColorToRGB(ShadowColor));\r\n OffsetRect(R, -1, -1);\r\n Windows.DrawText(DC, PChar(Text), Length(Text), R, Flags);\r\n end;\r\n fstShadow:\r\n begin\r\n SetTextColor(DC, ColorToRGB(ShadowColor));\r\n OffsetRect(R, 2, 2);\r\n Windows.DrawText(DC, PChar(Text), Length(Text), R, Flags);\r\n SetTextColor(DC, ColorToRGB(FontColor));\r\n OffsetRect(R, -2, -2);\r\n Windows.DrawText(DC, PChar(Text), Length(Text), R, Flags);\r\n end;\r\n else\r\n begin\r\n SetTextColor(DC, ColorToRGB(FontColor));\r\n Windows.DrawText(DC, PChar(Text), Length(Text), R, Flags);\r\n end;\r\n end;\r\n SelectObject(DC, OldFont);\r\n SetBkMode(DC, OldBkMode);\r\nend;\r\n\r\n{\r\n Renders text wth given style, countouring option and given colours fo 3D effects\r\n\r\n DC - Handle of canvas\r\n Style - Style (embossed, with shadow, etc)\r\n ADelineated - Contour of color of DelinColor\r\n FontColor, DelinColor, HighlightColor, ShadowColor -\r\n Colors of font and 3D effects\r\n Illumination - Not used\r\n Gradient - Gradient for filling letters of text\r\n}\r\n\r\nprocedure ExtTextOutExt(DC: HDC; X, Y: Integer; R: TRect; const Text: string;\r\n Style: TglTextStyle; ADelineated, ASupress3D: Boolean;\r\n FontColor, DelinColor, HighlightColor, ShadowColor: TColor;\r\n Illumination: TJvgIllumination; Gradient: TJvgGradient; Font: TFont);\r\nvar\r\n OldBkMode, X1, Y1, I, ShadowDepth: Integer;\r\n OldFont: Windows.HFONT;\r\n\r\n procedure DrawMain(ADelineated: Boolean; S: Integer);\r\n begin\r\n if ADelineated then\r\n begin\r\n if not ASupress3D then\r\n begin\r\n SetTextColor(DC, ColorToRGB(DelinColor));\r\n ExtTextOut(DC, X + S, Y + S, ETO_CLIPPED, @R, PChar(Text), Length(Text), nil);\r\n ExtTextOut(DC, X + 2 + S, Y + 2 + S, ETO_CLIPPED, @R, PChar(Text), Length(Text), nil);\r\n ExtTextOut(DC, X + S, Y + S + 2, ETO_CLIPPED, @R, PChar(Text), Length(Text), nil);\r\n ExtTextOut(DC, X + S + 2, Y + S, ETO_CLIPPED, @R, PChar(Text), Length(Text), nil);\r\n end;\r\n SetTextColor(DC, ColorToRGB(FontColor));\r\n if Assigned(Gradient) then\r\n Gradient.TextOut(DC, Text, R, X + S + 1, Y + S + 1)\r\n else\r\n ExtTextOut(DC, X + S + 1, Y + S + 1, ETO_CLIPPED, @R, PChar(Text), Length(Text), nil);\r\n end\r\n else\r\n begin\r\n SetTextColor(DC, ColorToRGB(FontColor));\r\n if Assigned(Gradient) then\r\n Gradient.TextOut(DC, Text, R, X + S, Y + S)\r\n else\r\n ExtTextOut(DC, X + S, Y + S, ETO_CLIPPED, @R, PChar(Text), Length(Text), nil);\r\n end;\r\n end;\r\nbegin\r\n if not Assigned(Font) then\r\n Exit;\r\n OldFont := SelectObject(DC, Font.Handle);\r\n OldBkMode := SetBkMode(DC, TRANSPARENT);\r\n\r\n if ADelineated then\r\n begin\r\n X1 := 4;\r\n Y1 := 4;\r\n end\r\n else\r\n begin\r\n X1 := 2;\r\n Y1 := 2;\r\n end;\r\n if Style = fstNone then\r\n begin\r\n X1 := X1 div 2 - 1;\r\n Y1 := Y1 div 2 - 1;\r\n end;\r\n if Style = fstShadow then\r\n begin\r\n X1 := X1 div 2 - 1;\r\n Y1 := Y1 div 2 - 1;\r\n end;\r\n if Assigned(Illumination) then\r\n ShadowDepth := Illumination.ShadowDepth\r\n else\r\n ShadowDepth := 2;\r\n case Style of\r\n fstRaised:\r\n begin\r\n if not ASupress3D then\r\n begin\r\n SetTextColor(DC, ColorToRGB(HighlightColor));\r\n ExtTextOut(DC, X, Y, ETO_CLIPPED, @R, PChar(Text), Length(Text), nil);\r\n SetTextColor(DC, ColorToRGB(ShadowColor));\r\n ExtTextOut(DC, X + X1, Y + Y1, ETO_CLIPPED, @R, PChar(Text), Length(Text), nil);\r\n end;\r\n DrawMain(ADelineated, 1);\r\n end;\r\n fstRecessed:\r\n begin\r\n if not ASupress3D then\r\n begin\r\n SetTextColor(DC, ColorToRGB(ShadowColor));\r\n ExtTextOut(DC, X, Y, ETO_CLIPPED, @R, PChar(Text), Length(Text), nil);\r\n SetTextColor(DC, ColorToRGB(HighlightColor));\r\n ExtTextOut(DC, X + X1, Y + Y1, ETO_CLIPPED, @R, PChar(Text), Length(Text), nil);\r\n end;\r\n DrawMain(ADelineated, 1);\r\n end;\r\n fstPushed:\r\n begin\r\n SetTextColor(DC, ColorToRGB(HighlightColor));\r\n ExtTextOut(DC, X + 1, Y + 1, ETO_CLIPPED, @R, PChar(Text), Length(Text), nil);\r\n SetTextColor(DC, ColorToRGB(ShadowColor));\r\n ExtTextOut(DC, X, Y, ETO_CLIPPED, @R, PChar(Text), Length(Text), nil);\r\n end;\r\n fstShadow:\r\n begin\r\n if not ASupress3D then\r\n begin\r\n SetTextColor(DC, ColorToRGB(ShadowColor));\r\n ExtTextOut(DC, X + X1 + ShadowDepth, Y + Y1 + ShadowDepth, ETO_CLIPPED, @R, PChar(Text), Length(Text), nil);\r\n end;\r\n DrawMain(ADelineated, 0);\r\n end;\r\n fstVolumetric:\r\n begin\r\n if not ASupress3D then\r\n begin\r\n SetTextColor(DC, ColorToRGB(ShadowColor));\r\n for I := 1 to ShadowDepth do\r\n ExtTextOut(DC, X + I, Y + I, ETO_CLIPPED, @R, PChar(Text), Length(Text), nil);\r\n end;\r\n DrawMain(ADelineated, 0);\r\n end;\r\n else\r\n DrawMain(ADelineated, 0);\r\n // SetTextColor( DC , ColorToRGB(FontColor) );\r\n // ExtTextOut( DC, X, Y, ETO_CLIPPED, @R, PChar(Text), Length(Text), nil);\r\n end;\r\n SelectObject(DC, OldFont);\r\n SetBkMode(DC, OldBkMode);\r\nend;\r\n\r\n{\r\n Draws rect with given 3D style\r\n\r\n DC - Handle of canvas\r\n Style - Style (fbsFlat, fbsCtl3D, fbsStatusControl, fbsRecessed, fbsRaised, fbsRaisedFrame, fbsRecessedFrame)\r\n BackgrColor - Background Color if FTransparen is False\r\n}\r\n\r\n\r\nprocedure DrawBox(DC: HDC; var R: TRect; Style: TglBoxStyle;\r\n BackgrColor: Longint; ATransparent: Boolean);\r\nconst\r\n FBorderWidth = 1;\r\nbegin\r\n\r\n case Style of\r\n fbsFlat:\r\n begin\r\n end;\r\n fbsCtl3D:\r\n begin\r\n R.Top := R.Top + 2;\r\n R.Left := R.Left + 2;\r\n R.Right := R.Right - 2;\r\n R.Bottom := R.Bottom - 1;\r\n // Frame3D(Canvas, R,clBtnShadow,clBtnHighlight,1);\r\n end;\r\n // fbsStatusControl:\r\n fbsRaised:\r\n begin\r\n InflateRect(R, -2, -2);\r\n DrawEdge(DC, R, BDR_RAISEDOUTER, BF_BOTTOMRIGHT); // black\r\n Dec(R.Bottom);\r\n Dec(R.Right);\r\n DrawEdge(DC, R, BDR_RAISEDINNER, BF_TOPLEFT); // btnhilite\r\n Inc(R.Top);\r\n Inc(R.Left);\r\n DrawEdge(DC, R, BDR_RAISEDINNER, BF_BOTTOMRIGHT or BF_MIDDLE); // btnshadow\r\n end;\r\n fbsRecessed:\r\n begin\r\n R.Bottom := R.Bottom - 1;\r\n DrawEdge(DC, R, BDR_SUNKENINNER, BF_TOPLEFT); // black\r\n DrawEdge(DC, R, BDR_SUNKENOUTER, BF_BOTTOMRIGHT); // btnhilite\r\n Dec(R.Bottom);\r\n Dec(R.Right);\r\n Inc(R.Top);\r\n Inc(R.Left);\r\n DrawEdge(DC, R, BDR_SUNKENOUTER, BF_TOPLEFT or BF_MIDDLE); // btnshadow\r\n Inc(R.Top);\r\n Inc(R.Left);\r\n end;\r\n fbsRaisedFrame:\r\n begin\r\n DrawEdge(DC, R, BDR_RAISEDOUTER, BF_BOTTOMRIGHT); // black\r\n Dec(R.Bottom);\r\n Dec(R.Right);\r\n DrawEdge(DC, R, BDR_RAISEDINNER, BF_TOPLEFT); // btnhilite\r\n Inc(R.Top);\r\n Inc(R.Left);\r\n DrawEdge(DC, R, BDR_RAISEDINNER, BF_BOTTOMRIGHT or BF_MIDDLE); // btnshadow\r\n\r\n InflateRect(R, -FBorderWidth, -FBorderWidth);\r\n\r\n DrawEdge(DC, R, BDR_SUNKENINNER, BF_TOPLEFT); // black\r\n DrawEdge(DC, R, BDR_SUNKENOUTER, BF_BOTTOMRIGHT); // btnhilite\r\n Dec(R.Bottom);\r\n Dec(R.Right);\r\n Inc(R.Top);\r\n Inc(R.Left);\r\n DrawEdge(DC, R, BDR_SUNKENOUTER, BF_TOPLEFT or BF_MIDDLE); // btnshadow\r\n Inc(R.Top);\r\n Inc(R.Left);\r\n end;\r\n fbsRecessedFrame:\r\n begin\r\n DrawEdge(DC, R, BDR_SUNKENINNER, BF_TOPLEFT); // black\r\n DrawEdge(DC, R, BDR_SUNKENOUTER, BF_BOTTOMRIGHT); // btnhilite\r\n Dec(R.Bottom);\r\n Dec(R.Right);\r\n Inc(R.Top);\r\n Inc(R.Left);\r\n DrawEdge(DC, R, BDR_SUNKENOUTER, BF_TOPLEFT or BF_MIDDLE); // btnshadow\r\n Inc(R.Top);\r\n Inc(R.Left);\r\n\r\n InflateRect(R, -FBorderWidth, -FBorderWidth);\r\n\r\n DrawEdge(DC, R, BDR_RAISEDOUTER, BF_BOTTOMRIGHT); // black\r\n Dec(R.Bottom);\r\n Dec(R.Right);\r\n DrawEdge(DC, R, BDR_RAISEDINNER, BF_TOPLEFT); // btnhilite\r\n Inc(R.Top);\r\n Inc(R.Left);\r\n DrawEdge(DC, R, BDR_RAISEDINNER, BF_BOTTOMRIGHT or BF_MIDDLE); // btnshadow\r\n end;\r\n end;\r\nend;\r\n\r\n{\r\n Draws rect with given 3D style and specifing borders\r\n\r\n DC - Handle of canvas\r\n Borders - Borders for drawing\r\n BevelInner, BevelOuter - Borders' styles\r\n Bold - Bold border(frame)\r\n BackgrColor - Background Color if ATransparent is False\r\n}\r\n\r\nfunction DrawBoxEx(DC: HDC; ARect: TRect; Borders: TglSides;\r\n BevelInner, BevelOuter: TPanelBevel; Bold: Boolean; BackgrColor: Longint;\r\n ATransparent: Boolean): TRect;\r\nvar\r\n I: Word;\r\n BPen, LPen, SPen, OldPen: HPEN;\r\n HBackgrBrush, HOldBrush: HBRUSH;\r\n R, R1: TRect;\r\n BColor, HColor, SColor: Longint;\r\n LogOldPen: TLOGPEN;\r\n PenWidth: UINT;\r\n\r\n procedure SetDefColors;\r\n begin\r\n BColor := GetSysColor(COLOR_3DDKSHADOW);\r\n HColor := GetSysColor(COLOR_3DHILIGHT);\r\n SColor := GetSysColor(COLOR_3DSHADOW);\r\n end;\r\n\r\n procedure DrawBevel(Bevel: TPanelBevel);\r\n begin\r\n if fsdLeft in Borders then\r\n begin\r\n case Bevel of\r\n bvRaised:\r\n begin\r\n SelectObject(DC, LPen);\r\n MoveToEx(DC, R.Left, R.Top, nil);\r\n LineTo(DC, R.Left, R.Bottom + 1);\r\n Inc(R1.Left);\r\n //.if Bold then Inc(R1.Left);\r\n end;\r\n bvLowered:\r\n if Bold then\r\n begin\r\n SelectObject(DC, BPen);\r\n MoveToEx(DC, R.Left, R.Top, nil);\r\n LineTo(DC, R.Left, R.Bottom);\r\n Inc(R1.Left);\r\n SelectObject(DC, SPen);\r\n if fsdBottom in Borders then\r\n I := 0\r\n else\r\n I := 1;\r\n MoveToEx(DC, R.Left + 1, R.Top + 1, nil);\r\n LineTo(DC, R.Left + 1, R.Bottom + I);\r\n //SetPixel(DC, R.Left, R.Bottom-1, SColor);\r\n Inc(R1.Left);\r\n end\r\n else\r\n begin\r\n SelectObject(DC, SPen);\r\n MoveToEx(DC, R.Left, R.Top, nil);\r\n LineTo(DC, R.Left, R.Bottom);\r\n Inc(R1.Left);\r\n end;\r\n bvSpace:\r\n begin\r\n SelectObject(DC, SPen);\r\n MoveToEx(DC, R.Left, R.Top, nil);\r\n LineTo(DC, R.Left, R.Bottom);\r\n Inc(R1.Left);\r\n end;\r\n end;\r\n end;\r\n if fsdTop in Borders then\r\n begin\r\n case Bevel of\r\n bvRaised:\r\n begin\r\n SelectObject(DC, LPen);\r\n MoveToEx(DC, R.Left, R.Top, nil);\r\n LineTo(DC, R.Right, R.Top);\r\n Inc(R1.Top);\r\n //.if Bold then Inc(R1.Top);\r\n end;\r\n bvLowered:\r\n if Bold then\r\n begin\r\n SelectObject(DC, BPen);\r\n MoveToEx(DC, R.Left, R.Top, nil);\r\n LineTo(DC, R.Right, R.Top);\r\n Inc(R1.Top);\r\n SelectObject(DC, SPen);\r\n MoveToEx(DC, R.Left + 1, R.Top + 1, nil);\r\n LineTo(DC, R.Right, R.Top + 1);\r\n //SetPixel(DC, R.Right-1, R.Top+1, SColor);\r\n Inc(R1.Top);\r\n end\r\n else\r\n begin\r\n SelectObject(DC, SPen);\r\n MoveToEx(DC, R.Left, R.Top, nil);\r\n LineTo(DC, R.Right, R.Top);\r\n Inc(R1.Top);\r\n end;\r\n bvSpace:\r\n begin\r\n SelectObject(DC, SPen);\r\n MoveToEx(DC, R.Left, R.Top, nil);\r\n LineTo(DC, R.Right, R.Top);\r\n Inc(R1.Top);\r\n end;\r\n end;\r\n end;\r\n if fsdRight in Borders then\r\n begin\r\n case Bevel of\r\n bvRaised:\r\n if Bold then\r\n begin\r\n SelectObject(DC, BPen);\r\n MoveToEx(DC, R.Right, R.Top, nil);\r\n LineTo(DC, R.Right, R.Bottom + 1);\r\n Dec(R1.Right);\r\n SelectObject(DC, SPen);\r\n MoveToEx(DC, R.Right - 1, R.Top + 1, nil);\r\n LineTo(DC, R.Right - 1, R.Bottom + 1);\r\n //SetPixel(DC, R.Right-1, R.Bottom-1, SColor);\r\n Dec(R1.Right);\r\n end\r\n else\r\n begin\r\n SelectObject(DC, SPen);\r\n MoveToEx(DC, R.Right, R.Top, nil);\r\n LineTo(DC, R.Right, R.Bottom + 1);\r\n Dec(R1.Right);\r\n end;\r\n bvLowered:\r\n begin\r\n SelectObject(DC, LPen);\r\n MoveToEx(DC, R.Right, R.Top, nil);\r\n LineTo(DC, R.Right, R.Bottom);\r\n Dec(R1.Right);\r\n //. if Bold then Dec(R1.Right);\r\n end;\r\n bvSpace:\r\n begin\r\n SelectObject(DC, SPen);\r\n MoveToEx(DC, R.Right, R.Top, nil);\r\n LineTo(DC, R.Right, R.Bottom);\r\n Dec(R1.Right);\r\n end;\r\n end;\r\n end;\r\n if fsdBottom in Borders then\r\n begin\r\n case Bevel of\r\n bvRaised:\r\n if Bold then\r\n begin\r\n SelectObject(DC, BPen);\r\n if fsdLeft in Borders then\r\n I := 1\r\n else\r\n I := 0;\r\n MoveToEx(DC, R.Left {+1}, R.Bottom, nil);\r\n LineTo(DC, R.Right, R.Bottom);\r\n Dec(R1.Bottom);\r\n SelectObject(DC, SPen);\r\n MoveToEx(DC, R.Left + I {+I}, R.Bottom - 1, nil);\r\n LineTo(DC, R.Right, R.Bottom - 1);\r\n //SetPixel(DC, R.Right-1+I, R.Bottom-1, SColor);\r\n Dec(R1.Bottom);\r\n end\r\n else\r\n begin\r\n SelectObject(DC, SPen);\r\n MoveToEx(DC, R.Left, R.Bottom, nil);\r\n LineTo(DC, R.Right, R.Bottom);\r\n Dec(R1.Bottom);\r\n end;\r\n bvLowered:\r\n begin\r\n SelectObject(DC, LPen);\r\n // if Borders.Left then I:=1 else I:=0;\r\n MoveToEx(DC, R.Left, R.Bottom {-1}, nil);\r\n LineTo(DC, R.Right + 1, R.Bottom {-1});\r\n Dec(R1.Bottom);\r\n //. if Bold then Dec(R1.Bottom);\r\n //Dec(R1.Bottom);\r\n end;\r\n bvSpace:\r\n begin\r\n SelectObject(DC, SPen);\r\n MoveToEx(DC, R.Left, R.Bottom {-1}, nil);\r\n LineTo(DC, R.Right + 1, R.Bottom {-1});\r\n Dec(R1.Bottom);\r\n end;\r\n end;\r\n end;\r\n end;\r\n\r\nbegin\r\n try\r\n if Assigned(glGlobalData.lp3DColors) then\r\n with TJvg3DColors(glGlobalData.lp3DColors) do\r\n begin\r\n BColor := ColorToRGB(DkShadow);\r\n HColor := ColorToRGB(Highlight);\r\n SColor := ColorToRGB(Shadow);\r\n end\r\n else\r\n SetDefColors;\r\n except\r\n end;\r\n\r\n LPen := CreatePen(PS_SOLID, 1, HColor);\r\n OldPen := SelectObject(DC, LPen);\r\n DeleteObject(SelectObject(DC, OldPen));\r\n\r\n FillChar(LogOldPen, SizeOf(LogOldPen), 0);\r\n GetObject(OldPen, SizeOf(LogOldPen), @LogOldPen);\r\n if LogOldPen.lopnWidth.X = 0 then\r\n PenWidth := 1\r\n else\r\n PenWidth := LogOldPen.lopnWidth.X;\r\n BPen := CreatePen(LogOldPen.lopnStyle, PenWidth, BColor);\r\n LPen := CreatePen(LogOldPen.lopnStyle, PenWidth, HColor);\r\n SPen := CreatePen(LogOldPen.lopnStyle, PenWidth, SColor);\r\n SelectObject(DC, LPen);\r\n R1 := ARect;\r\n R := ARect;\r\n if BevelOuter <> bvNone then\r\n DrawBevel(BevelOuter);\r\n R := R1;\r\n // if (BevelOuter = bvRaised)and(BevelInner = bvLowered)and Bold then\r\n // begin Dec(R.Top); Dec(R.Left); end;\r\n\r\n if BevelInner <> bvNone then\r\n DrawBevel(BevelInner);\r\n\r\n SelectObject(DC, OldPen);\r\n DeleteObject(BPen);\r\n DeleteObject(LPen);\r\n DeleteObject(SPen);\r\n\r\n if not ATransparent then\r\n begin\r\n HBackgrBrush := CreateSolidBrush(ColorToRGB(BackgrColor));\r\n HOldBrush := SelectObject(DC, HBackgrBrush);\r\n R := R1; {Dec(R.Top);Dec(R.Left);}\r\n Inc(R.Right);\r\n Inc(R.Bottom);\r\n FillRect(DC, R, HBackgrBrush);\r\n DeleteObject(SelectObject(DC, HOldBrush));\r\n end;\r\n\r\n Result := R1;\r\nend;\r\n\r\n{ Draws TJvgGradient gradient }\r\n\r\nprocedure GradientBox(DC: HDC; R: TRect; Gradient: TJvgGradient; PenStyle, PenWidth: Integer);\r\nbegin\r\n Gradient.Draw(DC, R, PenStyle, PenWidth);\r\nend;\r\n\r\n{ Replaces bitmap's color }\r\n\r\nprocedure ChangeBitmapColor(Bitmap: TBitmap; FromColor, ToColor: TColor);\r\nvar\r\n IWidth, IHeight: Integer;\r\n DRect, SRect: TRect;\r\n MonoBMP, OldBMP: HBITMAP;\r\n MonoDC: HDC;\r\nbegin\r\n if (Bitmap.Width or Bitmap.Height) = 0 then\r\n Exit;\r\n IWidth := Bitmap.Width;\r\n IHeight := Bitmap.Height;\r\n DRect := Rect(0, 0, IWidth, IHeight);\r\n SRect := DRect;\r\n\r\n MonoDC := CreateCompatibleDC(Bitmap.Canvas.Handle);\r\n MonoBMP := CreateBitmap(IWidth, IHeight, 1, 1, nil);\r\n OldBMP := SelectObject(MonoDC, MonoBMP);\r\n\r\n try\r\n with Bitmap.Canvas do { Convert FromColor to ToColor }\r\n begin\r\n Bitmap.Canvas.Brush.Color := FromColor;\r\n {copy Bitmap to MonoBMP}\r\n BitBlt(MonoDC, 0, 0, IWidth, IHeight, Handle, 0, 0, cmSrcCopy);\r\n Brush.Color := ToColor;\r\n SetTextColor(Handle, clBlack);\r\n SetBkColor(Handle, clWhite);\r\n BitBlt(Handle, 0, 0, IWidth, IHeight, MonoDC, 0, 0, ROP_DSPDxax);\r\n end;\r\n finally\r\n DeleteObject(SelectObject(MonoDC, OldBMP));\r\n DeleteDC(MonoDC);\r\n end;\r\nend;\r\n\r\n{ Paints bitmap. Transparent, disabled, multiplied, etc }\r\n\r\nprocedure DrawBitmapExt(DC: HDC; { DC - background & result}\r\n SourceBitmap: TBitmap; R: TRect;\r\n X, Y: Integer; //...X,Y _in_ rect!\r\n BitmapOption: TglWallpaperOption; DrawState: TglDrawState;\r\n ATransparent: Boolean; TransparentColor: TColor; DisabledMaskColor: TColor);\r\nbegin\r\n CreateBitmapExt(DC, SourceBitmap, R, X, Y, BitmapOption,\r\n DrawState, ATransparent, TransparentColor, DisabledMaskColor);\r\nend;\r\n\r\n//..DrawBitmap algorithm borrow from Delphi2 VCL Sources\r\n{ create bimap based on SourceBitmap and write new bitmap to DC }\r\n\r\nprocedure CreateBitmapExt(DC: HDC; {target DC}\r\n SourceBitmap: TBitmap; R: TRect;\r\n X, Y: Integer; //...X,Y _in_ rect!\r\n BitmapOption: TglWallpaperOption; DrawState: TglDrawState;\r\n ATransparent: Boolean; TransparentColor: TColor; DisabledMaskColor: TColor);\r\nconst\r\n ROP_DSPDxax = $00E20746;\r\nvar\r\n X1, Y1, H, W: Integer;\r\n D, D1: Double;\r\n TmpImage, MonoBMP: TBitmap;\r\n IWidth, IHeight: Integer;\r\n IRect, ORect: TRect;\r\n // DestDC: HDC;\r\n BmpInfo: Windows.TBitmap;\r\n PtSize, PtOrg: TPoint;\r\n MemDC, ImageDC: HDC;\r\n OldBMP, OldMonoBMP, OldScreenImageBMP, OldMemBMP: HBITMAP;\r\n HMonoBMP, ScreenImageBMP, MemBMP: HBITMAP;\r\n MonoDC, ScreenImageDC: HDC;\r\n OldBkColor: COLORREF;\r\n SavedIHeight: Integer;\r\n\r\n procedure BitBltWorks;\r\n begin\r\n if ATransparent then\r\n begin\r\n { create copy of drawing image }\r\n BitBlt(MemDC, 0, 0, IWidth, IHeight, ImageDC, 0, 0, SRCCOPY);\r\n if DrawState = fdsDisabled then\r\n TransparentColor := clBtnFace;\r\n OldBkColor := SetBkColor(MemDC, ColorToRGB(TransparentColor));\r\n { create monohrome mask: TransparentColor -> white, other color -> black }\r\n BitBlt(MonoDC, 0, 0, IWidth, IHeight, MemDC, 0, 0, SRCCOPY);\r\n SetBkColor(MemDC, OldBkColor);\r\n {create copy of screen image}\r\n BitBlt(ScreenImageDC, 0, 0, IWidth, IHeight, DC, X1, Y1, SRCCOPY);\r\n { put monochrome mask }\r\n BitBlt(ScreenImageDC, 0, 0, IWidth, IHeight, MonoDC, 0, 0, SRCAND);\r\n BitBlt(MonoDC, 0, 0, IWidth, IHeight, MonoDC, 0, 0, NOTSRCCOPY);\r\n { put inverse monochrome mask }\r\n BitBlt(MemDC, 0, 0, IWidth, IHeight, MonoDC, 0, 0, SRCAND);\r\n { merge Screen screen image(MemDC) and Screen image(ScreenImageDC) }\r\n BitBlt(MemDC, 0, 0, IWidth, IHeight, ScreenImageDC, 0, 0, SRCPAINT);\r\n { to screen }\r\n // DSTINVERT MERGEPAINT\r\n BitBlt(DC, X1, Y1, IWidth, IHeight, MemDC, 0, 0, SRCCOPY);\r\n end\r\n else\r\n BitBlt(DC, X1, Y1, IWidth, IHeight, ImageDC, 0, 0, SRCCOPY);\r\n end;\r\n\r\nbegin\r\n if (SourceBitmap.Width = 0) or (SourceBitmap.Height = 0) then\r\n Exit;\r\n\r\n X := X + R.Left;\r\n Y := Y + R.Top;\r\n X1 := X;\r\n Y1 := Y;\r\n OldBMP := 0;\r\n OldMemBMP := 0;\r\n OldMonoBMP := 0;\r\n OldScreenImageBMP := 0;\r\n MemDC := 0;\r\n ImageDC := 0;\r\n // MonoBMP := 0;\r\n // ScreenImageBMP := 0;\r\n // MemBMP := 0;\r\n MonoDC := 0;\r\n ScreenImageDC := 0;\r\n\r\n IWidth := SourceBitmap.Width; //Min( SourceBitmap.Width, R.Right-R.Left );\r\n IHeight := SourceBitmap.Height; //Min( SourceBitmap.Height, R.Bottom-R.Top );\r\n TmpImage := TBitmap.Create;\r\n try\r\n TmpImage.Width := IWidth;\r\n TmpImage.Height := IHeight;\r\n IRect := Rect(0, 0, IWidth, IHeight);\r\n ORect := Rect(0, 0, IWidth, IHeight);\r\n\r\n TmpImage.Canvas.Brush.Color := TransparentColor;\r\n TmpImage.Canvas.FillRect(Rect(0, 0, IWidth, IHeight));\r\n\r\n case DrawState of\r\n fdsDefault:\r\n BitBlt(TmpImage.Canvas.Handle, 0, 0, IWidth, IHeight,\r\n SourceBitmap.Canvas.Handle, 0, 0, SRCCOPY);\r\n fdsDelicate:\r\n begin\r\n with TmpImage.Canvas do\r\n BitBlt(Handle, 0, 0, IWidth, IHeight,\r\n SourceBitmap.Canvas.Handle, 0, 0, SRCCOPY);\r\n { Convert white to clBtnHighlight }\r\n ChangeBitmapColor(TmpImage, clWhite, clBtnHighlight);\r\n { Convert gray to clBtnShadow }\r\n ChangeBitmapColor(TmpImage, clGray, clBtnShadow);\r\n { Convert transparent color to clBtnFace }\r\n // ChangeBitmapColor(TmpImage,ColorToRGB(}TransparentColor),clBtnFace);\r\n end;\r\n fdsDisabled:\r\n begin\r\n if DisabledMaskColor <> 0 then\r\n ChangeBitmapColor(TmpImage, DisabledMaskColor, clBlack);\r\n MonoBMP := TBitmap.Create;\r\n try { Create a disabled version }\r\n with MonoBMP do\r\n begin\r\n Assign(SourceBitmap);\r\n Canvas.Brush.Color := 0;\r\n Width := IWidth;\r\n if Monochrome then\r\n begin\r\n Canvas.Font.Color := clWhite;\r\n Monochrome := False;\r\n Canvas.Brush.Color := clWhite;\r\n end;\r\n Monochrome := True;\r\n end;\r\n with TmpImage.Canvas do\r\n begin\r\n Brush.Color := clBtnFace;\r\n FillRect(IRect);\r\n Brush.Color := clBtnHighlight;\r\n SetTextColor(Handle, 0);\r\n SetBkColor(Handle, clWhite);\r\n BitBlt(Handle, 1, 1, IWidth, IHeight,\r\n MonoBMP.Canvas.Handle, 0, 0, ROP_DSPDxax);\r\n Brush.Color := clBtnShadow;\r\n SetTextColor(Handle, 0);\r\n SetBkColor(Handle, clWhite);\r\n BitBlt(Handle, 0, 0, IWidth, IHeight,\r\n MonoBMP.Canvas.Handle, 0, 0, ROP_DSPDxax);\r\n end;\r\n finally\r\n MonoBMP.Free;\r\n end;\r\n end;\r\n end;\r\n\r\n with TmpImage.Canvas do\r\n if (BitmapOption = fwoStretch) or (BitmapOption = fwoPropStretch) then\r\n begin\r\n MemDC := CreateCompatibleDC(DC);\r\n MemBMP := CreateCompatibleBitmap(TmpImage.Canvas.Handle, R.Right - R.Left, R.Bottom - R.Top);\r\n OldMemBMP := SelectObject(MemDC, MemBMP);\r\n W := R.Right - R.Left;\r\n H := R.Bottom - R.Top;\r\n if BitmapOption = fwoPropStretch then\r\n begin\r\n D1 := W / IWidth;\r\n D := H / IHeight;\r\n if D > D1 then\r\n D := D1; //...D == Min\r\n W := Trunc(IWidth * D);\r\n H := Trunc(IHeight * D);\r\n end;\r\n StretchBlt(MemDC, 0, 0, W, H, Handle, 0, 0, IWidth, IHeight, SRCCOPY);\r\n\r\n IWidth := W;\r\n IHeight := H;\r\n TmpImage.Width := W;\r\n TmpImage.Height := H;\r\n BitBlt(Handle, 0, 0, IWidth, IHeight, MemDC, 0, 0, SRCCOPY);\r\n\r\n DeleteObject(SelectObject(MemDC, OldMemBMP));\r\n DeleteDC(MemDC);\r\n end;\r\n\r\n ImageDC := CreateCompatibleDC(DC);\r\n\r\n if ATransparent then\r\n begin\r\n MemDC := CreateCompatibleDC(DC);\r\n ScreenImageDC := CreateCompatibleDC(DC);\r\n MonoDC := CreateCompatibleDC(DC);\r\n\r\n HMonoBMP := CreateBitmap(IWidth, IHeight, 1, 1, nil);\r\n ScreenImageBMP := CreateCompatibleBitmap(TmpImage.Canvas.Handle, IWidth, IHeight);\r\n MemBMP := CreateCompatibleBitmap(TmpImage.Canvas.Handle, IWidth, IHeight);\r\n\r\n OldMonoBMP := SelectObject(MonoDC, HMonoBMP);\r\n OldScreenImageBMP := SelectObject(ScreenImageDC, ScreenImageBMP);\r\n OldMemBMP := SelectObject(MemDC, MemBMP);\r\n end;\r\n OldBMP := SelectObject(ImageDC, TmpImage.Handle);\r\n\r\n if OldBMP <> 0 then\r\n begin\r\n SetMapMode(ImageDC, GetMapMode(DC));\r\n GetObject(TmpImage.Handle, SizeOf(Windows.TBitmap), @BmpInfo);\r\n PtSize.X := BmpInfo.bmWidth;\r\n PtOrg.X := 0;\r\n PtSize.Y := BmpInfo.bmHeight;\r\n PtOrg.Y := 0;\r\n if ATransparent then\r\n begin\r\n DPtoLP(DC, PtSize, 1);\r\n DPtoLP(MemDC, PtOrg.Y, 1);\r\n end;\r\n if BitmapOption = fwoTile then\r\n begin\r\n //SavedIWidth:=IWidth;\r\n SavedIHeight := IHeight;\r\n while X1 < R.Right do\r\n begin\r\n //IWidth:=SavedIWidth; //SavedIWidth:=IWidth;\r\n if X1 + IWidth > R.Right then\r\n IWidth := R.Right - X1;\r\n while Y1 < R.Bottom do\r\n begin\r\n IHeight := SavedIHeight; // SavedIHeight:=IHeight;\r\n if Y1 + IHeight > R.Bottom then\r\n IHeight := R.Bottom - Y1;\r\n BitBltWorks;\r\n Inc(Y1, IHeight);\r\n end;\r\n Inc(X1, IWidth);\r\n Y1 := Y;\r\n end;\r\n end\r\n else\r\n BitBltWorks;\r\n end;\r\n finally\r\n DeleteObject(SelectObject(ImageDC, OldBMP));\r\n DeleteDC(ImageDC);\r\n if ATransparent then\r\n begin\r\n DeleteObject(SelectObject(MonoDC, OldMonoBMP));\r\n DeleteObject(SelectObject(ScreenImageDC, OldScreenImageBMP));\r\n DeleteObject(SelectObject(MemDC, OldMemBMP));\r\n DeleteDC(MonoDC);\r\n DeleteDC(ScreenImageDC);\r\n DeleteDC(MemDC);\r\n end;\r\n TmpImage.Free;\r\n end;\r\n\r\nend;\r\n\r\n{ Brings parent window to front }\r\n\r\nprocedure BringParentWindowToTop(Wnd: TWinControl);\r\nbegin\r\n if Wnd is TForm then\r\n BringWindowToTop(Wnd.Handle)\r\n else\r\n if Wnd.Parent is TWinControl then\r\n BringParentWindowToTop(Wnd.Parent);\r\nend;\r\n\r\n{ Gives parent window of TForm class }\r\n\r\nfunction GetParentForm(Control: TControl): TForm;\r\nbegin\r\n if Control is TForm then\r\n Result := TForm(Control)\r\n else\r\n if Control.Parent is TWinControl then\r\n Result := GetParentForm(Control.Parent)\r\n else\r\n Result := nil;\r\nend;\r\n\r\n\r\n{ Paints TWinControl with all its content onto DC with offset(shift) X,Y\r\n ...from rxLib... :( very sorry }\r\n\r\nprocedure GetWindowImageFrom(Control: TWinControl; X, Y: Integer; ADrawSelf, ADrawChildWindows: Boolean; DC: HDC);\r\nvar\r\n I, Count, SaveIndex: Integer;\r\nbegin\r\n if Control = nil then\r\n Exit;\r\n Count := Control.ControlCount;\r\n\r\n { Copy self image }\r\n if ADrawSelf then\r\n begin\r\n SaveIndex := SaveDC(DC);\r\n SetViewportOrgEx(DC, X, Y, nil);\r\n TJvgPublicWinControl(Control).PaintWindow(DC);\r\n RestoreDC(DC, SaveIndex);\r\n end;\r\n { Copy images of graphic controls }\r\n for I := 0 to Count - 1 do\r\n begin\r\n if Control.Controls[I] <> nil then\r\n begin\r\n if Control.Controls[I] = Control then\r\n Break;\r\n if (Control.Controls[I] is TWinControl) and ADrawChildWindows then\r\n GetWindowImageFrom(TWinControl(Control.Controls[I]),\r\n TWinControl(Control.Controls[I]).Left,\r\n TWinControl(Control.Controls[I]).Top,\r\n True {ADrawSelf}, ADrawChildWindows, DC)\r\n else\r\n with Control.Controls[I] do\r\n if Visible then\r\n begin\r\n SaveIndex := SaveDC(DC);\r\n SetViewportOrgEx(DC, Left + X, Top + Y, nil);\r\n Perform(WM_PAINT, WPARAM(DC), 0);\r\n RestoreDC(DC, SaveIndex);\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\n{ Paints(renders) TWinControl with all its content onto DC with offset (0,0) }\r\n\r\nprocedure GetWindowImage(Control: TWinControl; ADrawSelf, ADrawChildWindows: Boolean; DC: HDC);\r\nbegin\r\n GetWindowImageFrom(Control, 0, 0, ADrawSelf, ADrawChildWindows, DC);\r\nend;\r\n\r\n{ Paints parent TWinControl with all its contents onto DC with limit of Rect }\r\n\r\nprocedure GetParentImageRect(Control: TControl; Rect: TRect; DC: HDC);\r\nvar\r\n I, Count, X, Y, SaveIndex: Integer;\r\n R, SelfR, CtlR: TRect;\r\nbegin\r\n if Control.Parent = nil then\r\n Exit;\r\n Count := Control.Parent.ControlCount;\r\n SelfR := Bounds(Control.Left, Control.Top, Control.Width, Control.Height);\r\n // OffsetRect( Rect, Control.Left, Control.Top );\r\n IntersectRect(SelfR, SelfR, Rect);\r\n\r\n X := -Rect.Left;\r\n Y := -Rect.Top;\r\n { Copy parent control image }\r\n SaveIndex := SaveDC(DC);\r\n SetViewportOrgEx(DC, X, Y, nil);\r\n IntersectClipRect(DC, 0, 0, Rect.Right, Rect.Bottom);\r\n TJvgPublicWinControl(Control.Parent).PaintWindow(DC);\r\n RestoreDC(DC, SaveIndex);\r\n { Copy images of graphic controls }\r\n for I := 0 to Count - 1 do\r\n begin\r\n if (Control.Parent.Controls[I] <> nil) and\r\n not (Control.Parent.Controls[I] is TWinControl) then\r\n begin\r\n if Control.Parent.Controls[I] = Control then\r\n Break;\r\n with Control.Parent.Controls[I] do\r\n begin\r\n CtlR := Bounds(Left, Top, Width, Height);\r\n if IntersectRect(R, SelfR, CtlR) and Visible then\r\n begin\r\n SaveIndex := SaveDC(DC);\r\n SetViewportOrgEx(DC, Left + X, Top + Y, nil);\r\n IntersectClipRect(DC, 0, 0, Width, Height);\r\n Perform(WM_PAINT, WPARAM(DC), 0);\r\n RestoreDC(DC, SaveIndex);\r\n end;\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\n{-create a rotated font based on the font object F}\r\n\r\nfunction CreateRotatedFont(F: TFont; Escapement: Integer): HFONT;\r\nvar\r\n LF: TLogFont;\r\nbegin\r\n FillChar(LF, SizeOf(LF), #0);\r\n with LF do\r\n begin\r\n lfHeight := F.Height;\r\n // lfWidth := 8;//FHeight div 4;\r\n lfEscapement := Escapement;\r\n lfOrientation := 0;\r\n if fsBold in F.Style then\r\n lfWeight := FW_BOLD\r\n else\r\n lfWeight := FW_NORMAL;\r\n // if FFontWeight <> fwDONTCARE then lfWeight:=uFontWeight;\r\n lfItalic := Ord(fsItalic in F.Style);\r\n lfUnderline := Ord(fsUnderline in F.Style);\r\n lfStrikeOut := Ord(fsStrikeOut in F.Style);\r\n lfCharSet := F.CHARSET;\r\n StrPCopy(lfFaceName, F.Name);\r\n lfQuality := DEFAULT_QUALITY;\r\n {everything else as default}\r\n lfOutPrecision := OUT_DEFAULT_PRECIS;\r\n lfClipPrecision := CLIP_DEFAULT_PRECIS;\r\n case F.Pitch of\r\n fpVariable:\r\n lfPitchAndFamily := VARIABLE_PITCH;\r\n fpFixed:\r\n lfPitchAndFamily := FIXED_PITCH;\r\n else\r\n lfPitchAndFamily := DEFAULT_PITCH;\r\n end;\r\n end;\r\n Result := CreateFontIndirect(LF);\r\nend;\r\n\r\n{ Returns main window of application }\r\n\r\nfunction FindMainWindow(const AWndClass, AWndTitle: string): THandle;\r\nbegin\r\n Result := 0;\r\n if (AWndClass <> '') or (AWndTitle <> '') then\r\n Result := FindWindow(PChar(AWndClass), PChar(AWndTitle));\r\nend;\r\n\r\n{ Calculates colors of shadow and lighted border for given base color. }\r\n\r\nprocedure CalcShadowAndHighlightColors(BaseColor: TColor; Colors: TJvgLabelColors);\r\nvar\r\n R, G, B: Byte;\r\nbegin\r\n with Colors do\r\n begin\r\n if (BaseColor and $80000000) <> 0 then\r\n BaseColor := GetSysColor(BaseColor and $FF);\r\n B := (BaseColor and $00FF0000) shr 16;\r\n G := (BaseColor and $0000FF00) shr 8;\r\n R := BaseColor and $000000FF;\r\n if AutoShadow then\r\n begin\r\n {if RG then limit:=R else limit:=G; if B>limit then limit:=B;//...Max\r\n if (255-limit)= '0') and (CurrChar <= '9') then\r\n begin\r\n while (CurrChar >= '0') and (CurrChar <= '9') do\r\n begin\r\n Result := Result * 10 + Ord(CurrChar) - Ord('0');\r\n NextChar;\r\n if Point then\r\n Inc(PointDepth);\r\n if (CurrChar = '.') or (CurrChar = ',') then\r\n begin\r\n NextChar;\r\n Point := True;\r\n end;\r\n end;\r\n if PointDepth <> 0 then\r\n Result := Result / (10.0 * PointDepth);\r\n end\r\n else\r\n begin\r\n case CurrChar of\r\n '-':\r\n begin\r\n NextChar;\r\n Result := -1.0 * Result;\r\n end;\r\n '(':\r\n begin\r\n Inc(BracketsCount);\r\n NextChar;\r\n Result := Expression;\r\n while CurrChar = ' ' do\r\n NextChar;\r\n if CurrChar <> ')' then\r\n raise Exception.CreateRes(@RsERightBracketsNotFound)\r\n else\r\n NextChar;\r\n end;\r\n // '.': Point := True;\r\n // ',': Point := True;\r\n end;\r\n end;\r\n if CurrChar = ')' then\r\n begin\r\n Dec(BracketsCount);\r\n if BracketsCount < 0 then\r\n raise Exception.CreateResFmt(@RsERightBracketHavntALeftOnePosd, [ExpressionPtr - 1]);\r\n end;\r\n end;\r\n\r\n function TestForMulDiv: Single;\r\n var\r\n Denominator: Single;\r\n begin\r\n Result := DigitsToValue; // . . .test For digits, signs And brackets\r\n while True do\r\n begin\r\n case CurrChar of\r\n // Case \"-\": NextChar\r\n '*':\r\n begin\r\n NextChar;\r\n Result := Result * DigitsToValue;\r\n end;\r\n '/':\r\n begin\r\n NextChar;\r\n Denominator := DigitsToValue;\r\n if Denominator <> 0 then\r\n Result := Result / Denominator\r\n else\r\n begin\r\n CalcResult := False;\r\n raise Exception.CreateRes(@RsEDivideBy);\r\n end;\r\n end;\r\n else\r\n Break;\r\n end;\r\n end;\r\n end;\r\n\r\n function Expression: Single;\r\n begin\r\n Result := TestForMulDiv; //...test for '*' and '/'\r\n while True do\r\n case CurrChar of //...TestFor_AddSub\r\n ' ':\r\n NextChar;\r\n '+':\r\n begin\r\n NextChar;\r\n if CharInSet(CurrChar, ['+', '-', '/', '*']) then\r\n raise Exception.CreateResFmt(@RsEDuplicateSignsAtPos , [ExpressionPtr - 1]);\r\n Result := Result + TestForMulDiv;\r\n end;\r\n '-':\r\n begin\r\n NextChar;\r\n if CharInSet(CurrChar, ['+', '-', '/', '*']) then\r\n raise Exception.CreateResFmt(@RsEDuplicateSignsAtPos, [ExpressionPtr - 1]);\r\n Result := Result - TestForMulDiv;\r\n end;\r\n else\r\n Break;\r\n end;\r\n end;\r\n\r\nbegin\r\n ExpressionPtr := 0;\r\n BracketsCount := 0;\r\n AExpression := Trim(AExpression);\r\n\r\n ExpressionLength := Length(AExpression);\r\n if ExpressionLength = 0 then\r\n raise Exception.CreateRes(@RsEExpressionStringIsEmpty);\r\n CalcResult := True;\r\n NextChar;\r\n Result := Expression;\r\nend;\r\n\r\n{ Ternary operator: X ? Y : Z }\r\n\r\nfunction IIF(AExpression: Boolean; IfTrue, IfFalse: Variant): Variant; overload;\r\nbegin\r\n if AExpression then\r\n Result := IfTrue\r\n else\r\n Result := IfFalse;\r\nend;\r\n\r\nfunction IIF(AExpression: Boolean; const IfTrue, IfFalse: string): string; overload;\r\nbegin\r\n if AExpression then\r\n Result := IfTrue\r\n else\r\n Result := IfFalse;\r\nend;\r\n\r\n{ Returns colour of Leftmost/Rightmost Top/Bottom pixel of bitmap }\r\n\r\nfunction GetTransparentColor(Bitmap: TBitmap; AutoTrColor: TglAutoTransparentColor): TColor;\r\nvar\r\n X, Y: Integer;\r\nbegin\r\n if (AutoTrColor = ftcUser) or not IsItAFilledBitmap(Bitmap) then\r\n Result := 0\r\n else\r\n begin\r\n case AutoTrColor of\r\n ftcLeftTopPixel:\r\n begin\r\n X := 0;\r\n Y := 0;\r\n end;\r\n ftcLeftBottomPixel:\r\n begin\r\n X := 0;\r\n Y := Bitmap.Height - 1;\r\n end;\r\n ftcRightTopPixel:\r\n begin\r\n X := Bitmap.Width - 1;\r\n Y := 0;\r\n end;\r\n else {ftcRightBottomPixel}\r\n begin\r\n X := Bitmap.Width - 1;\r\n Y := Bitmap.Height - 1;\r\n end;\r\n end;\r\n Result := GetPixel(Bitmap.Canvas.Handle, X, Y);\r\n end;\r\nend;\r\n\r\nprocedure TypeStringOnKeyboard(const S: string);\r\nvar\r\n I: Integer;\r\n VK: Byte;\r\nbegin\r\n for I := 1 to Length(S) do\r\n begin\r\n if Ord(S[I]) > 32 then\r\n VK := Ord(S[I]) - 32\r\n else\r\n VK := Ord(S[I]);\r\n keybd_event(VK, 0, 0, 0);\r\n keybd_event(VK, 0, KEYEVENTF_KEYUP, 0);\r\n end;\r\nend;\r\n\r\n{function NextStringGridCell( Grid: TStringGrid ): Boolean;\r\nvar\r\n R: TRect;\r\n I: Integer;\r\nbegin\r\n with Grid do\r\n begin\r\n if Cols[Selection.Left][Selection.Top]='' then\r\n begin Result := True; Exit; end;\r\n Result := not ((Grid.Selection.Top = RowCount-1)and(Grid.Selection.Left =\r\n if Result then\r\n if Selection.Top = RowCount-1 then\r\n begin\r\n Perform( wM_KEYDOWN, VK_TAB, 1);\r\n for I:=1 to RowCount-FixedRows-1 do Perform( wM_KEYDOWN, VK_UP, 1);\r\n end\r\n else\r\n begin Perform( wM_KEYDOWN, VK_DOWN, 1); end;\r\n// Grid.SetFocus;\r\n Grid.EditorMode:=False;\r\n Grid.EditorMode:=True;\r\n end;\r\nend;\r\n}\r\n\r\nprocedure DrawTextExtAligned(Canvas: TCanvas; const Text: string; R: TRect; Alignment: TglAlignment; WordWrap: Boolean);\r\nconst\r\n Alignments: array [TglAlignment] of Word = (DT_LEFT, DT_RIGHT, DT_CENTER, 0);\r\n WordWraps: array [Boolean] of Word = (0, DT_WORDBREAK);\r\nvar\r\n DrawPos, Pos1, Pos2, LineWidth, LineNo, LexemCount, TextHeight: Integer;\r\n Width: Integer;\r\n Lexem: string;\r\n Size: TSize;\r\n Stop, BroadwiseLine: Boolean;\r\n\r\n function GetNextLexem(var Pos1, Pos2: Integer; TrimLeft: Boolean): string;\r\n var\r\n Pos: Integer;\r\n begin\r\n Pos := Pos1;\r\n if Text[Pos] = ' ' then\r\n repeat\r\n Inc(Pos);\r\n until (Pos > Length(Text)) or (Text[Pos] <> ' ');\r\n Pos2 := Pos;\r\n if TrimLeft and (LineNo > 0) then\r\n Pos1 := Pos;\r\n repeat\r\n Inc(Pos2);\r\n until (Pos2 > Length(Text)) or (Text[Pos2] = ' ');\r\n\r\n Result := Copy(Text, Pos1, Pos2 - Pos1);\r\n end;\r\n\r\n procedure DrawLine(AdditSpace: Cardinal);\r\n var\r\n I, DrawPos1, DrawPos2: Integer;\r\n Lexem: string;\r\n Size: TSize;\r\n X, X1: Single;\r\n begin\r\n DrawPos1 := DrawPos;\r\n DrawPos2 := DrawPos;\r\n X := 0;\r\n X1 := 0;\r\n LineWidth := 0;\r\n for I := 1 to LexemCount do\r\n begin\r\n Lexem := GetNextLexem(DrawPos1, DrawPos2, I = 1);\r\n // if LexemCount=1 then Lexem:=Lexem+' ';\r\n GetTextExtentPoint32(Canvas.Handle, PChar(Lexem), Length(Lexem), Size);\r\n Inc(LineWidth, Trunc(X));\r\n X := X + Size.cx;\r\n if (Trunc(X) > Width) and (LexemCount > 1) then\r\n Exit;\r\n\r\n if (LexemCount > 1) and BroadwiseLine then\r\n X := X + AdditSpace / (LexemCount - 1);\r\n TextOut(Canvas.Handle, R.Left + Trunc(X1), R.Top + LineNo * TextHeight, PChar(Lexem), Length(Lexem));\r\n X1 := X;\r\n DrawPos1 := DrawPos2;\r\n end;\r\n end;\r\n\r\nbegin\r\n if Text = '' then\r\n Exit;\r\n if Alignment <> ftaBroadwise then\r\n begin\r\n Windows.DrawText(Canvas.Handle, PChar(Text), Length(Text), R,\r\n DT_EXPANDTABS or WordWraps[WordWrap] or Alignments[Alignment]);\r\n Exit;\r\n end;\r\n Width := R.Right - R.Left; {Height := R.Bottom - R.Top;}\r\n LineWidth := 0;\r\n LineNo := 0;\r\n DrawPos := 1;\r\n Pos1 := 1;\r\n Pos2 := 1;\r\n LexemCount := 0;\r\n TextHeight := 0;\r\n Stop := False;\r\n BroadwiseLine := True;\r\n repeat\r\n Lexem := GetNextLexem(Pos1, Pos2, LexemCount = 0);\r\n // if LexemCount=0 then Lexem:=Lexem+' ';\r\n GetTextExtentPoint32(Canvas.Handle, PChar(Lexem), Length(Lexem), Size);\r\n Inc(LineWidth, Size.cx);\r\n Inc(LexemCount);\r\n if TextHeight < Size.cy then\r\n TextHeight := Size.cy;\r\n if (LineWidth > Width) or (Pos2 >= Length(Text)) then\r\n begin\r\n if LineWidth > Width then\r\n begin\r\n if LexemCount = 1 then\r\n Pos1 := Pos2;\r\n if LexemCount > 1 then\r\n Dec(LexemCount);\r\n DrawLine(Width - (LineWidth - Size.cx));\r\n DrawPos := Pos1;\r\n Inc(LineNo);\r\n LexemCount := 0;\r\n LineWidth := 0;\r\n Stop := Pos1 > Length(Text);\r\n end\r\n else\r\n begin\r\n BroadwiseLine := False; //ftoBroadwiseLastLine;\r\n DrawLine(Width - LineWidth);\r\n Inc(LineNo);\r\n Stop := True;\r\n end;\r\n end\r\n else\r\n Pos1 := Pos2;\r\n until Stop;\r\n // if FAutoSize then Height := Max( 12, LineNo*TextHeight );\r\nend;\r\n\r\n{ Deserialization: loading component from text file }\r\n\r\nprocedure LoadComponentFromTextFile(Component: TComponent; const FileName: string);\r\nvar\r\n MemStream: TMemoryStream;\r\n FileStream: TFileStream;\r\nbegin\r\n MemStream := TMemoryStream.Create;\r\n FileStream := TFileStream.Create(FileName, fmOpenRead);\r\n try\r\n ObjectTextToBinary(FileStream, MemStream);\r\n MemStream.Position := 0;\r\n MemStream.ReadComponent(Component);\r\n finally\r\n MemStream.Free;\r\n FileStream.Free;\r\n end;\r\nend;\r\n\r\n{ Serializing component to string }\r\n\r\nfunction ComponentToString(Component: TComponent): string;\r\nvar\r\n MemStream: TMemoryStream;\r\n StringStream: TStringStream;\r\nbegin\r\n StringStream := TStringStream.Create(' ');\r\n MemStream := TMemoryStream.Create;\r\n try\r\n MemStream.WriteComponent(Component);\r\n MemStream.Position := 0;\r\n ObjectBinaryToText(MemStream, StringStream);\r\n StringStream.Position := 0;\r\n Result := StringStream.DataString;\r\n finally\r\n MemStream.Free;\r\n StringStream.Free;\r\n end;\r\nend;\r\n\r\n{ Serialization: writing component to text file }\r\n\r\nprocedure SaveComponentToTextFile(Component: TComponent; const FileName: string);\r\nvar\r\n MemStream: TMemoryStream;\r\n FileStream: TFileStream;\r\nbegin\r\n FileStream := TFileStream.Create(FileName, fmCreate or fmOpenWrite);\r\n try\r\n MemStream := TMemoryStream.Create;\r\n try\r\n MemStream.WriteComponent(Component);\r\n MemStream.Position := 0;\r\n ObjectBinaryToText(MemStream, FileStream);\r\n finally\r\n MemStream.Free;\r\n end;\r\n finally\r\n FileStream.Free;\r\n end;\r\nend;\r\n\r\n{ Deserializing component from string }\r\n\r\nprocedure StringToComponent(Component: TComponent; const Value: string);\r\nvar\r\n StrStream: TStringStream;\r\n MemStream: TMemoryStream;\r\nbegin\r\n StrStream := TStringStream.Create(Value);\r\n try\r\n MemStream := TMemoryStream.Create;\r\n try\r\n ObjectTextToBinary(StrStream, MemStream);\r\n\r\n MemStream.Position := 0;\r\n MemStream.ReadComponent(Component);\r\n // Result := BinStream.ReadComponent(nil);\r\n finally\r\n MemStream.Free;\r\n end;\r\n finally\r\n StrStream.Free;\r\n end;\r\nend;\r\n\r\n{ Plays WAV resource }\r\n\r\nfunction PlayWaveResource(const ResName: string): Boolean;\r\nvar\r\n WaveHandle: THandle;\r\n WavePointer: Pointer;\r\nbegin\r\n Result := False;\r\n WaveHandle := FindResource(HInstance, PChar(ResName), RT_RCDATA);\r\n if WaveHandle <> 0 then\r\n begin\r\n WaveHandle := LoadResource(HInstance, WaveHandle);\r\n if WaveHandle <> 0 then\r\n begin\r\n WavePointer := LockResource(WaveHandle);\r\n Result := sndPlaySound(WavePointer, SND_MEMORY or SND_ASYNC);\r\n UnlockResource(WaveHandle);\r\n FreeResource(WaveHandle);\r\n end;\r\n end;\r\nend;\r\n\r\n{ User name for current thread }\r\n\r\n// JVCL4: Should go to JvJCLUtils.pas as \"GetUserName: string\"\r\nfunction UserName: string;\r\nvar\r\n Name: array [0..127] of Char;\r\n Len: DWORD;\r\nbegin\r\n Len := SizeOf(Name);\r\n GetUserName(Name, Len);\r\n Result := Name;\r\nend;\r\n\r\n{ PC name }\r\n\r\n// JVCL4: Should go to JvJCLUtils.pas as \"GetComputerName: string\"\r\nfunction ComputerName: string;\r\nbegin\r\n Result := JvJCLUtils.GetComputerName;\r\nend;\r\n\r\n{ Creates ini-file with the same name to project's file - use ChangeFileExt }\r\n\r\nfunction CreateIniFileName: string;\r\nbegin\r\n Result := ParamStr(0);\r\n SetLength(Result, Length(Result) - Length(ExtractFileExt(Result)));\r\n Result := Result + '.ini';\r\nend;\r\n\r\n{ Expands string with spaces up to given Length }\r\n\r\nfunction ExpandString(const Str: string; Len: Integer): string;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := Str;\r\n if Length(Result) >= Len then\r\n Exit;\r\n SetLength(Result, Len);\r\n\r\n for I := 1 to Length(Result) do\r\n if I <= Length(Str) then\r\n Result[I] := Str[I]\r\n else\r\n Result[I] := ' ';\r\nend;\r\n\r\n{ Transliterating string Rus <-> Lat }\r\n\r\nfunction Transliterate(const Str: string; RusToLat: Boolean): string;\r\nconst\r\n LAT: string = 'ABVGDEGZIIKLMNOPRSTUFHC___\"Y''EUYabvgdegziiklmnoprstufhc___\"y''euy+';\r\n RUS: string = '+';\r\n LATRUS: array [1..52, 1..2] of Char =\r\n (\r\n ('A', ''), ('B', ''), ('C', ''), ('D', ''), ('E', ''),\r\n ('F', ''), ('G', ''), ('H', ''), ('I', ''), ('J', ''),\r\n ('K', ''), ('L', ''), ('M', ''), ('N', ''), ('O', ''),\r\n ('P', ''), ('Q', #0), ('R', ''), ('S', ''), ('T', ''),\r\n ('U', ''), ('V', ''), ('W', #0), ('X', #0), ('Y', ''), ('Z', ''),\r\n ('a', ''), ('b', ''), ('c', ''), ('d', ''), ('e', ''),\r\n ('f', ''), ('g', ''), ('h', ''), ('i', ''), ('j', ''),\r\n ('k', ''), ('l', ''), ('m', ''), ('n', ''), ('o', ''),\r\n ('p', ''), ('q', #0), ('r', ''), ('s', ''), ('t', ''),\r\n ('u', ''), ('v', ''), ('w', #0), ('x', #0), ('y', ''), ('z', '')\r\n );\r\n\r\n TRANS_PAIRCOUNT = 14;\r\n TRANS_PAIR: array [1..TRANS_PAIRCOUNT, Boolean] of string =\r\n (('', 'kh'), ('', 'ts'), ('', 'ch'), ('', 'sh'), ('', 'shch'), ('', 'iu'), ('', 'ia'),\r\n ('', 'Kh'), ('', 'Ts'), ('', 'h'), ('', 'Sh'), ('', 'Shch'), ('', 'Iu'), ('', 'Ia'));\r\nvar\r\n I, J: Integer;\r\nbegin\r\n Result := Str;\r\n for I := 1 to TRANS_PAIRCOUNT do\r\n Result := StringReplace(Result, TRANS_PAIR[I, not RusToLat], TRANS_PAIR[I, RusToLat], [rfReplaceAll]);\r\n\r\n if RusToLat then\r\n begin\r\n for I := 1 to Length(Result) do\r\n if CharInSet(Result[I], [''..'']) then\r\n Result[I] := LAT[Ord(Result[I]) - Ord('') + 1];\r\n end\r\n else\r\n for I := 1 to Length(Result) do\r\n if CharInSet(Result[I], ['A'..'z']) then\r\n for J := 1 to 52 do\r\n if Result[I] = LATRUS[J, 1] then\r\n begin\r\n Result[I] := LATRUS[J, 2];\r\n Break;\r\n end;\r\nend;\r\n\r\n{ Function returns True, if font is small }\r\n\r\nfunction IsSmallFonts: Boolean;\r\nvar\r\n DC: HDC;\r\nbegin\r\n DC := GetDC(HWND_DESKTOP);\r\n Result := (GetDeviceCaps(DC, LOGPIXELSX) = 96);\r\n { For large font it would be 120 }\r\n ReleaseDC(HWND_DESKTOP, DC);\r\nend;\r\n\r\n{ Color depth in system: 8, 16 or 32 bits }\r\n\r\nfunction SystemColorDepth: Integer;\r\nvar\r\n DC: HDC;\r\nbegin\r\n DC := GetDC(HWND_DESKTOP);\r\n Result := GetDeviceCaps(DC, BITSPIXEL);\r\n ReleaseDC(HWND_DESKTOP, DC);\r\nend;\r\n\r\nfunction GetFileType(const FileName: string): TglFileType;\r\nvar\r\n Ext: string;\r\n I: Integer;\r\nconst\r\n Extensions: array [0..3] of string = ('.gif', '.jpeg', '.jpg', '.bmp');\r\n Types: array [0..4] of TglFileType = (fftGif, fftJpeg, fftJpeg, fftBmp, fftUndefined);\r\nbegin\r\n Result := fftUndefined;\r\n Ext := ExtractFileExt(FileName);\r\n for I := Low(Extensions) to High(Extensions) do\r\n if SameFileName(Ext, Extensions[I]) then\r\n begin\r\n Result := Types[I];\r\n Break;\r\n end;\r\nend;\r\n\r\n{ Looks for upper(topmost) control at given point }\r\n\r\nfunction FindControlAtPt(Control: TWinControl; Pt: TPoint; MinClass: TClass): TControl;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := nil;\r\n for I := Control.ControlCount - 1 downto 0 do\r\n if (Control.Controls[I] is MinClass) and PtInRect(Control.Controls[I].BoundsRect, Pt) then\r\n begin\r\n Result := Control.Controls[I];\r\n Break;\r\n end;\r\nend;\r\n\r\n{ StrPosExt - Looks for position of one string inside another with given length }\r\nfunction StrPosExt(const Str1, Str2: PChar; Str2Len: DWORD): PChar;\r\nvar\r\n StartCh: Char;\r\nbegin\r\n if (Str1 <> nil) and (Str2 <> nil) then\r\n begin\r\n StartCh := Str2^;\r\n Result := StrScan(Str1, StartCh);\r\n while Result <> nil do\r\n begin\r\n if StrLComp(Result + 1, Str2 + 1, Str2Len - 1) = 0 then\r\n Exit;\r\n Result := StrScan(Result + 1, StartCh);\r\n end;\r\n end;\r\n Result := nil;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvgWebDocumentIterator.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvgWebDocumentIterator.PAS, released on 2003-01-15.\r\n\r\nThe Initial Developer of the Original Code is Andrey V. Chudin, [chudin att yandex dott ru]\r\nPortions created by Andrey V. Chudin are Copyright (C) 2003 Andrey V. Chudin.\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\nMichael Beck [mbeck att bigfoot dott com].\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvgWebDocumentIterator.pas 12461 2009-08-14 17:21:33Z obones $\r\n\r\nunit JvgWebDocumentIterator;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, Classes, SysUtils, Graphics, Controls, Menus, ExtCtrls, SHDocVw,\r\n JvgCommClasses, JvgTypes;\r\n\r\ntype\r\n { TJvgIterator = class(TObject)\r\n protected\r\n procedure First; virtual; abstract;\r\n procedure Next; virtual; abstract;\r\n function IsDone: Boolean; virtual; abstract;\r\n end;}\r\n\r\n TJvgWebDocumentIterator = class(TObject) // TJvgIterator\r\n private\r\n FWebBrowser: TWebBrowser;\r\n FDoc: Variant;\r\n FItem: Variant;\r\n FItemIndex: Integer;\r\n FDocLocationHRef: string;\r\n FCurrentItem: TFileName;\r\n public\r\n constructor Create(WebBrowser: TWebBrowser);\r\n procedure First;\r\n procedure Next;\r\n function IsDone: Boolean;\r\n property CurrentItem: TFileName read FCurrentItem;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvgWebDocumentIterator.pas $';\r\n Revision: '$Revision: 12461 $';\r\n Date: '$Date: 2009-08-14 19:21:33 +0200 (ven. 14 août 2009) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nconstructor TJvgWebDocumentIterator.Create(WebBrowser: TWebBrowser);\r\nbegin\r\n inherited Create;\r\n FWebBrowser := WebBrowser;\r\n FDoc := WebBrowser.Document;\r\n FDocLocationHRef := FDoc.Location.HRef;\r\n FDocLocationHRef := StringReplace(FDocLocationHRef, '#', ' ', [rfReplaceAll]);\r\n FDocLocationHRef := StringReplace(FDocLocationHRef, 'file:///', '', [rfReplaceAll, rfIgnoreCase]);\r\n FDocLocationHRef := StringReplace(FDocLocationHRef, '/', '\\', [rfReplaceAll]);\r\nend;\r\n\r\nprocedure TJvgWebDocumentIterator.First;\r\nbegin\r\n FItemIndex := -1;\r\n Next;\r\nend;\r\n\r\nfunction TJvgWebDocumentIterator.IsDone: Boolean;\r\nbegin\r\n Result := FItemIndex > FDoc.Images.Length + {FDoc.All.Length +} FDoc.Links.Length;\r\nend;\r\n\r\nprocedure TJvgWebDocumentIterator.Next;\r\nbegin\r\n Inc(FItemIndex);\r\n FCurrentItem := '';\r\n if IsDone then\r\n Exit;\r\n\r\n try\r\n if FItemIndex <= FDoc.Images.Length - 1 then\r\n begin\r\n FItem := FDoc.Images.Item(FItemIndex);\r\n FCurrentItem := FItem.Src;\r\n end\r\n else\r\n if FItemIndex - FDoc.Images.Length <= FDoc.Links.Length - 1 then\r\n begin\r\n FItem := FDoc.Links.Item(FItemIndex - FDoc.Images.Length);\r\n FCurrentItem := FItem.HRef;\r\n end\r\n else\r\n if FItemIndex - FDoc.Images.Length - FDoc.Links.Length <= FDoc.All.Length - 1 then\r\n begin\r\n FItem := FDoc.All.Item(FItemIndex - FDoc.Images.Length - FDoc.Links.Length).Style;\r\n FCurrentItem := FItem.BackgroundImage;\r\n end;\r\n except\r\n Next;\r\n Exit;\r\n end;\r\n\r\n FCurrentItem := LowerCase(Trim(FCurrentItem));\r\n if (FCurrentItem = '') and not IsDone then\r\n Next;\r\n\r\n if Pos('#', FCurrentItem) > 0 then\r\n FCurrentItem := Copy(FCurrentItem, 1, Pos('#', FCurrentItem) - 1);\r\n\r\n FCurrentItem := StringReplace(FCurrentItem, 'file:///', '', [rfReplaceAll, rfIgnoreCase]);\r\n FCurrentItem := StringReplace(FCurrentItem, '/', '\\', [rfReplaceAll]);\r\n\r\n if (FDocLocationHRef = FCurrentItem) or\r\n (Pos('http:\\\\', FCurrentItem) = 1) or\r\n (Pos('mailto:', FCurrentItem) = 1) then\r\n Next\r\n else\r\n begin\r\n FCurrentItem := StringReplace(FCurrentItem, 'url(', '', [rfReplaceAll]);\r\n FCurrentItem := StringReplace(FCurrentItem, ')', '', [rfReplaceAll]);\r\n FCurrentItem := StringReplace(FCurrentItem, '%20', ' ', [rfReplaceAll]);\r\n end;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvgXMLSerializer.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvgXMLSerializer.PAS, released on 2003-01-15.\r\n\r\nThe Initial Developer of the Original Code is Andrey V. Chudin, [chudin att yandex dott ru]\r\nPortions created by Andrey V. Chudin are Copyright (C) 2003 Andrey V. Chudin.\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\nMichael Beck [mbeck att bigfoot dott com].\r\nBurov Dmitry, translation of russian text.\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nDescription:\r\n The component converts given component to XML and back according to\r\n published interface of its class.\r\n\r\n XML is made of tags pairs with values put inside. Tags can have no attributes\r\n\r\n Topmost tag matches class of the object. Inner tags match properties' names.\r\n For TCollectionItem containing tag matches the name of the class\r\n\r\n Tags' nesting is unlimited and repeats(reproduces) the whole published\r\n interface of class of the given object\r\n\r\n The following types are supported: integer numbers, floats, enumerations,\r\n sets, strings and chars, variants, classes, stringlists and collections.\r\n\r\n Interface:\r\n procedure Serialize(Component: TObject; Stream: TStream);\r\n - Serialization TPersistent -> XML\r\n procedure DeSerialize(Component: TObject; Stream: TStream);\r\n - Loading XML -> TPersistent\r\n\r\n property GenerateFormattedXML - Generate Formatted XML\r\n property ExcludeEmptyValues - Skip properties with empty values\r\n property ExcludeDefaultValues - Skip properties with default values\r\n property StrongConformity - Requires XML to has all the corresponding\r\n tags for all class types\r\n property IgnoreUnknownTags - ignore unknown tags when loading XML\r\n property OnGetXMLHeader - Allows to specifies one's own XML header //AFAIR - topmost XML tag\r\n\r\n WrapCollections - Wrap collections in individual(dedicated) tags\r\n\r\n Limitations:\r\n Each object can have only one collection per collection item class\r\n TStrings derivatives must have no published properties\r\n Procedure types are not supported\r\n\r\n To generate DTD it needs object to has all class-properties, with names same\r\n to properties of agregated objects, of single(the same, \"one\") class\r\n\r\n Preconditions:\r\n Object for de-serializatino into, is to be created prior to procedure's call.\r\n\r\n Is StringConformity then loading XML must contain tags for all the class-types.\r\n Presence of other tags is not checked.\r\n\r\n Extra:\r\n When loading TCollection from XML, it is not voided (?) so you can load\r\n TCollection as a merge of different XML sources.\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvgXMLSerializer.pas 12955 2010-12-29 12:27:53Z jfudickar $\r\n\r\nunit JvgXMLSerializer;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,\r\n Dialogs, ComCtrls, TypInfo,\r\n JvComponentBase;\r\n\r\ntype\r\n TOnGetXMLHeader = procedure(Sender: TObject; var Value: string) of object;\r\n TBeforeParsingEvent = procedure(Sender: TObject; Buffer: PChar) of object;\r\n\r\n EJvgXMLSerializerException = class(Exception);\r\n XMLSerializerException = class(Exception);\r\n EJvgXMLOpenTagNotFoundException = class(XMLSerializerException);\r\n EJvgXMLCloseTagNotFoundException = class(XMLSerializerException);\r\n EJvgXMLUnknownPropertyException = class(XMLSerializerException);\r\n\r\n TJvgXMLSerializerException = class of XMLSerializerException;\r\n\r\n TJvgXMLSerializer = class(TJvComponent)\r\n private\r\n Buffer: PChar;\r\n BufferEnd: PChar;\r\n BufferLength: DWORD;\r\n TokenPtr {, MaxTokenPtr}: PChar;\r\n OutStream: TStream;\r\n FOnGetXMLHeader: TOnGetXMLHeader;\r\n FGenerateFormattedXML: Boolean;\r\n FExcludeEmptyValues: Boolean;\r\n FExcludeDefaultValues: Boolean;\r\n FReplaceReservedSymbols: Boolean;\r\n FStrongConformity: Boolean;\r\n FBeforeParsing: TBeforeParsingEvent;\r\n FWrapCollections: Boolean;\r\n FIgnoreUnknownTags: Boolean;\r\n procedure Check(Expr: Boolean; const Msg: string; E: TJvgXMLSerializerException);\r\n procedure WriteOutStream(const Value: string);\r\n protected\r\n procedure SerializeInternal(Component: TObject; Level: Integer = 1);\r\n procedure DeSerializeInternal(Component: TObject;\r\n ComponentTagName: string; ParentBlockEnd: PChar = nil);\r\n procedure GenerateDTDInternal(Component: TObject; DTDList: TStrings;\r\n Stream: TStream; const ComponentTagName: string);\r\n procedure SetPropertyValue(Component: TObject; PropInfo: PPropInfo; Value,\r\n ValueEnd: PChar; ParentBlockEnd: PChar);\r\n public\r\n DefaultXMLHeader: string;\r\n tickCounter: DWORD;\r\n tickCount: DWORD;\r\n constructor Create(AOwner: TComponent); override;\r\n //{ XML }\r\n { Serialization of object to XML [translated] }\r\n procedure Serialize(Component: TObject; Stream: TStream);\r\n //{ XML }\r\n { Loading XML into object [translated] }\r\n procedure DeSerialize(Component: TObject; Stream: TStream);\r\n //{ DTD }\r\n { Genereating DTD [translated] }\r\n procedure GenerateDTD(Component: TObject; Stream: TStream);\r\n published\r\n property GenerateFormattedXML: Boolean read FGenerateFormattedXML write FGenerateFormattedXML default True;\r\n property ExcludeEmptyValues: Boolean read FExcludeEmptyValues write FExcludeEmptyValues;\r\n property ExcludeDefaultValues: Boolean read FExcludeDefaultValues write FExcludeDefaultValues;\r\n property ReplaceReservedSymbols: Boolean read FReplaceReservedSymbols write FReplaceReservedSymbols;\r\n property StrongConformity: Boolean read FStrongConformity write FStrongConformity default True;\r\n property IgnoreUnknownTags: Boolean read FIgnoreUnknownTags write FIgnoreUnknownTags;\r\n property WrapCollections: Boolean read FWrapCollections write FWrapCollections default True;\r\n property OnGetXMLHeader: TOnGetXMLHeader read FOnGetXMLHeader write FOnGetXMLHeader;\r\n property BeforeParsing: TBeforeParsingEvent read FBeforeParsing write FBeforeParsing;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvgXMLSerializer.pas $';\r\n Revision: '$Revision: 12955 $';\r\n Date: '$Date: 2010-12-29 13:27:53 +0100 (mer. 29 déc. 2010) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n JvResources, JvgUtils, JclSysUtils;\r\n\r\nconst\r\n ORDINAL_TYPES = [tkInteger, tkChar, tkEnumeration, tkSet];\r\n\r\nvar\r\n TAB: string;\r\n CR: string;\r\n\r\nconstructor TJvgXMLSerializer.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n //...defaults\r\n FGenerateFormattedXML := True;\r\n FStrongConformity := True;\r\n FWrapCollections := True;\r\nend;\r\n\r\n//{ . - }\r\n{ writes string to output stream. Used for serialization. [translated] }\r\n\r\nprocedure TJvgXMLSerializer.WriteOutStream(const Value: string);\r\nvar\r\n AnsiValue: AnsiString;\r\nbegin\r\n if Value <> '' then\r\n begin\r\n AnsiValue := AnsiString(Value);\r\n OutStream.Write(AnsiValue[1], Length(AnsiValue));\r\n end;\r\nend;\r\n\r\n// XML- \r\n// published .\r\n// :\r\n// Component - \r\n// :\r\n// XML Stream\r\n\r\n{\r\n Converts component to XML, according to published interface of its class\r\n Input:\r\n Component - Component to be converted\r\n Output:\r\n XML text into Stream\r\n}\r\n\r\nprocedure TJvgXMLSerializer.Serialize(Component: TObject; Stream: TStream);\r\nvar\r\n Result: string;\r\nbegin\r\n TAB := IIF(GenerateFormattedXML, #9, '');\r\n CR := IIF(GenerateFormattedXML, #13#10, '');\r\n\r\n Result := '';\r\n //{ XML }\r\n { Retrieving XML header [translated] }\r\n if Assigned(OnGetXMLHeader) then\r\n OnGetXMLHeader(Self, Result);\r\n if Result = '' then\r\n Result := DefaultXMLHeader;\r\n\r\n OutStream := Stream;\r\n\r\n WriteOutStream(Result);\r\n\r\n WriteOutStream(CR + '<' + Component.ClassName + '>');\r\n SerializeInternal(Component);\r\n WriteOutStream(CR + '');\r\nend;\r\n\r\n// XML\r\n// :\r\n// Serialize()\r\n// :\r\n// Component - \r\n// Level - \r\n// :\r\n// XML WriteOutStream()\r\n\r\n{\r\n Internal procedure Object->XML\r\n Is called from:\r\n Serialize()\r\n Input:\r\n Component - Component to be converted\r\n Level - Level of nesting (for formatted output)\r\n Output:\r\n XML string into output Stream via .WriteOutStream() method\r\n}\r\n\r\nprocedure TJvgXMLSerializer.SerializeInternal(Component: TObject; Level: Integer = 1);\r\nvar\r\n PropInfo: PPropInfo;\r\n TypeInf, PropTypeInf: PTypeInfo;\r\n TypeData: PTypeData;\r\n I, J: Integer;\r\n AName, PropName, sPropValue: string;\r\n PropList: PPropList;\r\n NumProps: Word;\r\n PropObject: TObject;\r\n\r\n //{ }\r\n { Adds opening tag with given name [translated] }\r\n\r\n procedure addOpenTag(const Value: string);\r\n begin\r\n WriteOutStream(CR + DupStr(TAB, Level) + '<' + Value + '>');\r\n Inc(Level);\r\n end;\r\n\r\n //{ }\r\n { Adds closing tag with given name [translated] }\r\n\r\n procedure addCloseTag(const Value: string; AddBreak: Boolean = False);\r\n begin\r\n Dec(Level);\r\n if AddBreak then\r\n WriteOutStream(CR + DupStr(TAB, Level));\r\n WriteOutStream('');\r\n end;\r\n\r\n //{ }\r\n { Adds value [in]to result string [translated] }\r\n\r\n procedure addValue(const Value: string);\r\n begin\r\n WriteOutStream(Value);\r\n end;\r\n\r\nbegin\r\n // Result := '';\r\n\r\n { Playing with RTTI }\r\n TypeInf := Component.ClassInfo;\r\n AName := {$IFDEF SUPPORTS_UNICODE}UTF8ToString{$ENDIF SUPPORTS_UNICODE}(TypeInf^.Name);\r\n TypeData := GetTypeData(TypeInf);\r\n NumProps := TypeData^.PropCount;\r\n\r\n GetMem(PropList, NumProps * SizeOf(Pointer));\r\n try\r\n //{ }\r\n { Getting list of properties [translated] }\r\n GetPropInfos(TypeInf, PropList);\r\n\r\n for I := 0 to NumProps - 1 do\r\n begin\r\n PropName := {$IFDEF SUPPORTS_UNICODE}UTF8ToString{$ENDIF SUPPORTS_UNICODE}(PropList^[I]^.Name);\r\n\r\n PropTypeInf := PropList^[I]^.PropType^;\r\n PropInfo := PropList^[I];\r\n\r\n //{ , ? }\r\n { Does the property wish to be saved? [translated] }\r\n if not IsStoredProp(Component, PropInfo) then\r\n Continue;\r\n\r\n case PropTypeInf^.Kind of\r\n tkInteger, tkChar, tkEnumeration, tkFloat, tkString, tkSet,\r\n {$IFDEF UNICODE} tkUString, {$ENDIF}\r\n tkWChar, tkLString, tkWString, tkVariant:\r\n begin\r\n //{ }\r\n { Getting property's value [translated] }\r\n sPropValue := GetPropValue(Component, PropName, True);\r\n\r\n //{ }\r\n { Checking if value is empty or is default [translated] }\r\n if ExcludeEmptyValues and (sPropValue = '') then\r\n Continue;\r\n if ExcludeDefaultValues and (PropTypeInf^.Kind in ORDINAL_TYPES) and\r\n (sPropValue = IntToStr(PropInfo.Default)) then\r\n Continue;\r\n\r\n //{ }\r\n { special characters placeholders [translated] }\r\n if FReplaceReservedSymbols then\r\n begin\r\n sPropValue := StringReplace(sPropValue, '<', '<',\r\n [rfReplaceAll]);\r\n sPropValue := StringReplace(sPropValue, '>', '>',\r\n [rfReplaceAll]);\r\n // sPropValue := StringReplace(sPropValue, '&', '&', [rfReplaceAll]);\r\n end;\r\n\r\n //{ XML }\r\n { converting to XML [translated] }\r\n addOpenTag(PropName);\r\n //{ }\r\n { adds property's value to result [translated] }\r\n addValue(sPropValue);\r\n addCloseTag(PropName);\r\n end;\r\n tkClass:\r\n //{ }\r\n { make recursive call for class-types [translated] }\r\n begin\r\n PropObject := GetObjectProp(Component, PropInfo);\r\n if Assigned(PropObject) then\r\n begin\r\n //{ - - }\r\n { make recursive call for children class-types [translated] }\r\n\r\n //{ }\r\n { Specific handlers for some certain classes [translated] }\r\n if PropObject is TStrings then\r\n //{ }\r\n { text lists [translated] }\r\n begin\r\n addOpenTag(PropName);\r\n WriteOutStream(TStrings(PropObject).CommaText);\r\n addCloseTag(PropName, True);\r\n end\r\n else\r\n if PropObject is TCollection then\r\n //{ }\r\n { collections [translated] }\r\n begin\r\n if WrapCollections then\r\n addOpenTag(PropName);\r\n\r\n SerializeInternal(PropObject, Level);\r\n for J := 0 to (PropObject as TCollection).Count - 1 do\r\n begin\r\n //{ }\r\n { Container-tag with name of the class [translated] }\r\n addOpenTag(TCollection(PropObject).Items[J].ClassName);\r\n SerializeInternal(TCollection(PropObject).Items[J],\r\n Level);\r\n addCloseTag(TCollection(PropObject).Items[J].ClassName, True);\r\n end;\r\n\r\n if WrapCollections then\r\n addCloseTag(PropName, True);\r\n end\r\n else\r\n if PropObject is TPersistent then\r\n begin\r\n addOpenTag(PropName);\r\n SerializeInternal(PropObject, Level);\r\n addCloseTag(PropName, True);\r\n end;\r\n\r\n //{ : TTreeNodes, TListItems }\r\n { Here one can add handling of other classes like TreeNodes, TListItems [translated] }\r\n end;\r\n //{ }\r\n { Closing object's tag after proceeded its properties [translated] }\r\n end;\r\n end;\r\n end;\r\n finally\r\n FreeMem(PropList, NumProps * SizeOf(Pointer));\r\n end;\r\nend;\r\n\r\n// XML-.\r\n// :\r\n// Component - \r\n// Stream - XML\r\n// :\r\n// Component \r\n\r\n{\r\n Loads component's properties (\"data\") from stream, containing XML stream\r\n Input:\r\n Component - Component to be convertes.\r\n Stream - Stream containing XML to load\r\n Preconditions:\r\n Components object was created prior to procedure's call\r\n}\r\n\r\nprocedure TJvgXMLSerializer.DeSerialize(Component: TObject; Stream: TStream);\r\nvar\r\n Buf: AnsiString;\r\n S: string;\r\nbegin\r\n SetLength(Buf, Stream.Size + 1);\r\n //{ }\r\n { Retrievign data from stream [translated] }\r\n if Buf <> '' then\r\n Stream.Read(Buf[1], Length(Buf));\r\n S := string(Buf);\r\n Buf := ''; // release unused memory\r\n Buffer := PChar(S);\r\n\r\n if Assigned(BeforeParsing) then\r\n BeforeParsing(Self, Buffer);\r\n\r\n //{ }\r\n { Setting current pointer of reading data [translated] }\r\n TokenPtr := Buffer;\r\n BufferLength := Length(S);\r\n BufferEnd := Buffer + BufferLength;\r\n //{ }\r\n { Calling loader [translated] }\r\n DeSerializeInternal(Component, Component.ClassName);\r\nend;\r\n\r\n// XML\r\n// :\r\n// Serialize()\r\n// :\r\n// Component - \r\n// ComponentTagName - XML \r\n// ParentBlockEnd - XML \r\n\r\n{\r\n Recursive procedure for loading of object from text buffer, containing XML\r\n Called from::\r\n Serialize()\r\n Input:\r\n Component - Component to be converted,\r\n ComponentTagName - Name of XML tag for object (Arioch: may differ from\r\n ClassName for CollectionItems, for XML header),\r\n ParentBlockEnd - Pointer to the end of XML-description of the parent tag.\r\n}\r\n\r\nprocedure TJvgXMLSerializer.DeSerializeInternal(Component: TObject;\r\n ComponentTagName: string; ParentBlockEnd: PChar = nil);\r\nvar\r\n BlockStart, BlockEnd, TagStart, TagEnd: PChar;\r\n TagName, TagValue, TagValueEnd: PChar;\r\n TypeInf: PTypeInfo;\r\n TypeData: PTypeData;\r\n PropIndex: Integer;\r\n AName: string;\r\n PropList: PPropList;\r\n NumProps: Word;\r\n\r\n //{ }\r\n { Searching object for property with given name [translated] }\r\n\r\n function FindProperty(TagName: PChar): Integer;\r\n var\r\n I: Integer;\r\n begin\r\n Result := -1;\r\n for I := 0 to NumProps - 1 do\r\n if CompareStr({$IFDEF SUPPORTS_UNICODE}UTF8ToString{$ENDIF SUPPORTS_UNICODE}(PropList^[I]^.Name), TagName) = 0 then\r\n begin\r\n Result := I;\r\n Break;\r\n end;\r\n end;\r\n\r\n procedure SkipSpaces(var TagEnd: PChar);\r\n begin\r\n while TagEnd[0] <= #33 do\r\n Inc(TagEnd);\r\n end;\r\n\r\nbegin\r\n { Playing with RTTI }\r\n TypeInf := Component.ClassInfo;\r\n AName := {$IFDEF SUPPORTS_UNICODE}UTF8ToString{$ENDIF SUPPORTS_UNICODE}(TypeInf^.Name);\r\n TypeData := GetTypeData(TypeInf);\r\n NumProps := TypeData^.PropCount;\r\n\r\n if not WrapCollections and (Component is TCollection) then\r\n ComponentTagName := TCollection(Component).ItemClass.ClassName;\r\n\r\n GetMem(PropList, NumProps * SizeOf(Pointer));\r\n try\r\n GetPropInfos(TypeInf, PropList);\r\n\r\n //{ }\r\n { Looking for opening tag [translated] }\r\n BlockStart := StrPosExt(TokenPtr, PChar('<' + ComponentTagName + '>'),\r\n BufferEnd - TokenPtr { = BufferLength});\r\n\r\n //{ , }\r\n { If tag is not found and is not required - skip it [translated] }\r\n if (BlockStart = nil) and not StrongConformity then\r\n exit;\r\n\r\n //{ }\r\n { Otherwise Check its presence [translated] }\r\n Check(BlockStart <> nil, Format(RsOpenXMLTagNotFound,\r\n [ComponentTagName]), EJvgXMLOpenTagNotFoundException);\r\n Inc(BlockStart, Length(ComponentTagName) + 2);\r\n\r\n //{ }\r\n { Looking for closing tag [translated] }\r\n BlockEnd := StrPosExt(BlockStart, PChar(''),\r\n BufferEnd - BlockStart + 3 + Length(ComponentTagName) {BufferLength});\r\n Check(BlockEnd <> nil, Format(RsCloseXMLTagNotFound,\r\n [ComponentTagName]), EJvgXMLCloseTagNotFoundException);\r\n\r\n //{ . }\r\n { Checking the closing tag to be nested within parent tag [translated] }\r\n Check((ParentBlockEnd = nil) or (BlockEnd < ParentBlockEnd),\r\n Format(RsCloseXMLTagNotFound, [ComponentTagName]),\r\n EJvgXMLCloseTagNotFoundException);\r\n\r\n TagEnd := BlockStart;\r\n SkipSpaces(TagEnd);\r\n\r\n //{ XML }\r\n { XML parser [translated] }\r\n while (TagEnd < BlockEnd) { and (TagEnd >= TokenPtr)} do\r\n begin\r\n //{ }\r\n { fast search for \"<\" and \">\" [translated] }\r\n TagStart := TagEnd;\r\n while (TagStart^ <> '<') do\r\n Inc(TagStart);\r\n TagEnd := TagStart + 1;\r\n while (TagEnd^ <> '>') do\r\n Inc(TagEnd);\r\n\r\n GetMem(TagName, (TagEnd - TagStart + 1) * SizeOf(Char));\r\n try\r\n //{ TagName - }\r\n { Tag Name - Tag Name [translated] }\r\n StrLCopy(TagName, TagStart + 1, TagEnd - TagStart - 1);\r\n\r\n //{ TagEnd - }\r\n { TagEnd - Closing tag [translated] }\r\n TagEnd := StrPosExt(TagEnd, PChar(''),\r\n BufferEnd - TagEnd + 3 + Length(TagName) { = BufferLength});\r\n\r\n //Inc(TagStart, Length('')-1);\r\n\r\n //{ }\r\n { Beginning of the next nested(\"children\") tag [translated] }\r\n TagValue := TagStart + Length('') - 1;\r\n TagValueEnd := TagEnd;\r\n\r\n //{ , }\r\n { Looking for property matching the tag [translated] }\r\n PropIndex := FindProperty(TagName);\r\n\r\n if not WrapCollections and (PropIndex = -1) then\r\n PropIndex := FindProperty(PChar(string(TagName) + 's'))\r\n else\r\n TokenPtr := TagStart;\r\n\r\n if not IgnoreUnknownTags then\r\n Check(PropIndex <> -1, Format(RsUnknownProperty, [TagName]),\r\n EJvgXMLUnknownPropertyException);\r\n\r\n if PropIndex <> -1 then\r\n SetPropertyValue(Component, PropList^[PropIndex], TagValue,\r\n TagValueEnd, BlockEnd);\r\n\r\n Inc(TagEnd, Length(''));\r\n SkipSpaces(TagEnd);\r\n finally\r\n FreeMem(TagName);\r\n end;\r\n end;\r\n finally\r\n FreeMem(PropList);//, NumProps * SizeOf(Pointer));\r\n end;\r\nend;\r\n\r\n// \r\n// :\r\n// DeSerializeInternal()\r\n// :\r\n// Component - \r\n// PropInfo - \r\n// Value - \r\n// ParentBlockEnd - XML \r\n// \r\n\r\n{\r\n Initialisation of the object's property\r\n Called from:\r\n DeSerializeInternal()\r\n Input:\r\n Component - Component to be initialized\r\n PropInfo - Information about type of property to set\r\n Value - Value of the property\r\n ParentBlockEnd - Pointer to the end of XML description of parent tag. Used for recursion.\r\n}\r\n\r\nprocedure TJvgXMLSerializer.SetPropertyValue(Component: TObject; PropInfo:\r\n PPropInfo; Value, ValueEnd: PChar; ParentBlockEnd: PChar);\r\nvar\r\n PropTypeInf: PTypeInfo;\r\n PropObject: TObject;\r\n CollectionItem: TCollectionItem;\r\n SValue: string;\r\n TmpChar: Char;\r\nbegin\r\n PropTypeInf := PropInfo.PropType^;\r\n\r\n case PropTypeInf^.Kind of\r\n tkInteger, tkChar, tkEnumeration, tkFloat, tkString, tkSet,\r\n {$IFDEF UNICODE} tkUString, {$ENDIF}\r\n tkWChar, tkLString, tkWString, tkVariant:\r\n begin\r\n //{ zero terminated string }\r\n { simulates zero terminated string [translated] }\r\n TmpChar := ValueEnd[0];\r\n ValueEnd[0] := #0;\r\n SValue := StrPas(Value);\r\n ValueEnd[0] := TmpChar;\r\n\r\n // . XML,\r\n // \r\n { Replacing specific characters (compatible only with that very component) [translated] }\r\n if FReplaceReservedSymbols then\r\n begin\r\n SValue := StringReplace(SValue, '<', '<', [rfReplaceAll]);\r\n SValue := StringReplace(SValue, '>', '>', [rfReplaceAll]);\r\n // SValue := StringReplace(SValue, '&', '&', [rfReplaceAll]);\r\n end;\r\n\r\n //{ }\r\n { Changing delimiter to system-wide [translated] }\r\n if PropTypeInf^.Kind = tkFloat then\r\n if JclFormatSettings.DecimalSeparator = ',' then\r\n SValue := StringReplace(SValue, '.', JclFormatSettings.DecimalSeparator, [rfReplaceAll])\r\n else\r\n SValue := StringReplace(SValue, ',', JclFormatSettings.DecimalSeparator, [rfReplaceAll]);\r\n\r\n //{ tkSet }\r\n { tkSet parser needs \"<\" and \">\" for correct transformation [translated] }\r\n if PropTypeInf^.Kind = tkSet then\r\n SValue := '[' + SValue + ']';\r\n SetPropValue(Component, {$IFDEF SUPPORTS_UNICODE}UTF8ToString{$ENDIF SUPPORTS_UNICODE}(PropInfo^.Name), SValue);\r\n end;\r\n tkClass:\r\n begin\r\n PropObject := GetObjectProp(Component, PropInfo);\r\n if Assigned(PropObject) then\r\n begin\r\n //{ }\r\n { Specific(individual) handling of some specific classes [translated] }\r\n if PropObject is TStrings then\r\n //{ }\r\n { text lists [translated] }\r\n begin\r\n TmpChar := ValueEnd[0];\r\n ValueEnd[0] := #0;\r\n SValue := StrPas(Value);\r\n ValueEnd[0] := TmpChar;\r\n TStrings(PropObject).CommaText := SValue;\r\n end\r\n else\r\n if PropObject is TCollection then\r\n //{ }\r\n { collections [translated] }\r\n begin\r\n while True do\r\n //{ }\r\n { we can't foretell number of element in TCollection [translated] }\r\n begin\r\n CollectionItem := (PropObject as TCollection).Add;\r\n try\r\n DeSerializeInternal(CollectionItem,\r\n CollectionItem.ClassName, ParentBlockEnd);\r\n except\r\n //{ , }\r\n { Exception if next element is not found [translated] }\r\n on E: Exception do\r\n begin\r\n // Application.MessageBox(PChar(E.Message), '', MB_OK); - debug string\r\n CollectionItem.Free;\r\n // raise; - debug string\r\n Break;\r\n end;\r\n end;\r\n end;\r\n end\r\n else\r\n //{ - }\r\n { Other classes are just processed recursevly [translated] }\r\n DeSerializeInternal(PropObject, {$IFDEF SUPPORTS_UNICODE}UTF8ToString{$ENDIF SUPPORTS_UNICODE}(PropInfo^.Name),\r\n ParentBlockEnd);\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\n// DTD \r\n// published .\r\n// :\r\n// Component - \r\n// :\r\n// DTD Stream\r\n\r\n{\r\n This procedure generates DTD for given object according to its published interface\r\n Input:\r\n Component - Object\r\n Output:\r\n text of DTD into Stream\r\n}\r\n\r\nprocedure TJvgXMLSerializer.GenerateDTD(Component: TObject; Stream: TStream);\r\nvar\r\n DTDList: TStringList;\r\nbegin\r\n DTDList := TStringList.Create;\r\n try\r\n GenerateDTDInternal(Component, DTDList, Stream, Component.ClassName);\r\n finally\r\n DTDList.Free;\r\n end;\r\nend;\r\n\r\n// DTD .\r\n// :\r\n// Component - \r\n// DTDList - DTD\r\n// .\r\n// :\r\n// DTD Stream\r\n\r\n{\r\n Inner recursive procedure that generates DTD for given object\r\n Input:\r\n Component - Object\r\n DTDList - list of already determined describedDTD elements\r\n to avoid duplicating\r\n Output:\r\n DTD text into Stream\r\n}\r\n\r\nprocedure TJvgXMLSerializer.GenerateDTDInternal(Component: TObject; DTDList:\r\n TStrings; Stream: TStream; const ComponentTagName: string);\r\nvar\r\n PropInfo: PPropInfo;\r\n TypeInf, PropTypeInf: PTypeInfo;\r\n TypeData: PTypeData;\r\n I: Integer;\r\n AName, PropName, TagContent: string;\r\n PropList: PPropList;\r\n NumProps: Word;\r\n PropObject: TObject;\r\nconst\r\n PCDATA = '#PCDATA';\r\n\r\n procedure addElement(const ElementName: string; Data: string);\r\n var\r\n S: string;\r\n UTF8S: UTF8String;\r\n begin\r\n if DTDList.IndexOf(ElementName) <> -1 then\r\n exit;\r\n DTDList.Add(ElementName);\r\n S := ''#13#10;\r\n UTF8S := UTF8Encode(S);\r\n Stream.Write(UTF8S[1], Length(UTF8S));\r\n end;\r\n\r\nbegin\r\n { Playing with RTTI }\r\n TypeInf := Component.ClassInfo;\r\n AName := {$IFDEF SUPPORTS_UNICODE}UTF8ToString{$ENDIF SUPPORTS_UNICODE}(TypeInf^.Name);\r\n TypeData := GetTypeData(TypeInf);\r\n NumProps := TypeData^.PropCount;\r\n\r\n GetMem(PropList, NumProps * SizeOf(Pointer));\r\n try\r\n //{ }\r\n { Getting list of properties [translated] }\r\n GetPropInfos(TypeInf, PropList);\r\n TagContent := '';\r\n\r\n for I := 0 to NumProps - 1 do\r\n begin\r\n PropName := {$IFDEF SUPPORTS_UNICODE}UTF8ToString{$ENDIF SUPPORTS_UNICODE}(PropList^[I]^.Name);\r\n\r\n PropTypeInf := PropList^[I]^.PropType^;\r\n PropInfo := PropList^[I];\r\n\r\n //{ }\r\n { Skip types that are not supported [translated] }\r\n if not (PropTypeInf^.Kind in [tkDynArray, tkArray, tkRecord,\r\n tkInterface, tkMethod]) then\r\n begin\r\n if TagContent <> '' then\r\n TagContent := TagContent + '|';\r\n TagContent := TagContent + PropName;\r\n end;\r\n\r\n case PropTypeInf^.Kind of\r\n tkInteger, tkChar, tkFloat, tkString,\r\n {$IFDEF UNICODE} tkUString, {$ENDIF}\r\n tkWChar, tkLString, tkWString, tkVariant, tkEnumeration, tkSet:\r\n //{ DTD. - #PCDATA }\r\n { conversion to DTD. Theese types will have #PCDATA model of content [translated] }\r\n addElement(PropName, PCDATA);\r\n //{ }\r\n { Code might be useful when using attributes [translated] }\r\n {\r\n tkEnumeration:\r\n begin\r\n TypeData:= GetTypeData(GetTypeData(PropTypeInf)^.BaseType^);\r\n S := '';\r\n for J := TypeData^.MinValue to TypeData^.MaxValue do\r\n begin\r\n if S <> '' then S := S + '|';\r\n S := S + GetEnumName(PropTypeInf, J);\r\n end;\r\n addElement(PropName, S);\r\n end;\r\n }\r\n tkClass:\r\n //{ }\r\n { make recursive call for class-types [translated] }\r\n begin\r\n PropObject := GetObjectProp(Component, PropInfo);\r\n if Assigned(PropObject) then\r\n begin\r\n //{ - - }\r\n { Specific(individual) handling of some specific classes [translated] }\r\n if PropObject is TPersistent then\r\n GenerateDTDInternal(PropObject, DTDList, Stream, PropName);\r\n end;\r\n end;\r\n end;\r\n end;\r\n\r\n //{ }\r\n //{ }\r\n { Collections require item(\"element\") type(class) to be included into\r\n content model [translated] }\r\n if Component is TCollection then\r\n begin\r\n if TagContent <> '' then\r\n TagContent := TagContent + '|';\r\n TagContent := TagContent + (Component as TCollection).ItemClass.ClassName + '*';\r\n end;\r\n\r\n //{ }\r\n { Adding content model for the element(item) [translated] }\r\n addElement(ComponentTagName, TagContent);\r\n finally\r\n FreeMem(PropList, NumProps * SizeOf(Pointer));\r\n end;\r\nend;\r\n\r\nprocedure TJvgXMLSerializer.Check(Expr: Boolean; const Msg: string;\r\n E: TJvgXMLSerializerException);\r\nbegin\r\n if not Expr then\r\n raise E.Create('XMLSerializerException'#13#10#13#10 + Msg);\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvxCheckListBox.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvxCheckListBox.pas, released on 2003-10-19.\r\n\r\nThe Initial Developers of the Original Code are: Fedor Koshevnikov, Igor Pavluk and Serge Korolev\r\nCopyright (c) 1997, 1998 Fedor Koshevnikov, Igor Pavluk and Serge Korolev\r\nCopyright (c) 2001,2002 SGB Software\r\nAll Rights Reserved.\r\n\r\nContributor(s):\r\n Polaris Software\r\n Peter Thornqvist [peter3 at sourceforge dot net]\r\n Andreas Hausladen (XP theming)\r\n\r\nChanges:\r\n2003-10-19:\r\n * Moved TJvxCustomListBox and TJvxCheckListBox from JvxCtrls to this unit\r\n\r\n2004-10-07:\r\n * Changed by hofi\r\n TJvxCheckListBox\r\n procedure DrawCheck(R: TRect; AState: TCheckBoxState; Enabled: Boolean);\r\n now protected to support possible call from derived classes.\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvxCheckListBox.pas 13415 2012-09-10 09:51:54Z obones $\r\n\r\nunit JvxCheckListBox;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n Windows, Messages, Classes, Controls, Graphics, StdCtrls, Forms,\r\n Types, RTLConsts,\r\n JvAppStorage, JvFormPlacement, JvComponent;\r\n\r\ntype\r\n TGetItemWidthEvent = procedure(Control: TWinControl; Index: Integer;\r\n var Width: Integer) of object;\r\n\r\n TJvxCustomListBox = class(TJvWinControl)\r\n private\r\n FItems: TStrings;\r\n FBorderStyle: TBorderStyle;\r\n FCanvas: TControlCanvas;\r\n FColumns: Integer;\r\n FItemHeight: Integer;\r\n FStyle: TListBoxStyle;\r\n FIntegralHeight: Boolean;\r\n FMultiSelect: Boolean;\r\n FSorted: Boolean;\r\n FExtendedSelect: Boolean;\r\n FTabWidth: Integer;\r\n FSaveItems: TStringList;\r\n FSaveTopIndex: Integer;\r\n FSaveItemIndex: Integer;\r\n FAutoScroll: Boolean;\r\n FGraySelection: Boolean;\r\n FMaxItemWidth: Integer;\r\n FOnDrawItem: TDrawItemEvent;\r\n FOnMeasureItem: TMeasureItemEvent;\r\n FOnGetItemWidth: TGetItemWidthEvent;\r\n procedure ResetHorizontalExtent;\r\n procedure SetHorizontalExtent;\r\n function GetCanvas: TCanvas;\r\n function GetAutoScroll: Boolean;\r\n function GetItemHeight: Integer; virtual;\r\n function GetItemIndex: Integer;\r\n function GetSelCount: Integer;\r\n function GetSelected(Index: Integer): Boolean;\r\n function GetTopIndex: Integer;\r\n procedure SetAutoScroll(Value: Boolean);\r\n procedure SetBorderStyle(Value: TBorderStyle);\r\n procedure SetColumnWidth;\r\n procedure SetColumns(Value: Integer);\r\n procedure SetExtendedSelect(Value: Boolean);\r\n procedure SetIntegralHeight(Value: Boolean);\r\n procedure SetItemHeight(Value: Integer);\r\n procedure SetItemIndex(Value: Integer);\r\n procedure SetMultiSelect(Value: Boolean);\r\n procedure SetSelected(Index: Integer; Value: Boolean);\r\n procedure SetSorted(Value: Boolean);\r\n procedure SetStyle(Value: TListBoxStyle);\r\n procedure SetTabWidth(Value: Integer);\r\n procedure SetTopIndex(Value: Integer);\r\n procedure SetGraySelection(Value: Boolean);\r\n procedure SetOnDrawItem(Value: TDrawItemEvent);\r\n procedure SetOnGetItemWidth(Value: TGetItemWidthEvent);\r\n procedure WMPaint(var Msg: TWMPaint); message WM_PAINT;\r\n procedure CNCommand(var Msg: TWMCommand); message CN_COMMAND;\r\n procedure CNDrawItem(var Msg: TWMDrawItem); message CN_DRAWITEM;\r\n procedure CNMeasureItem(var Msg: TWMMeasureItem); message CN_MEASUREITEM;\r\n procedure WMLButtonDown(var Msg: TWMLButtonDown); message WM_LBUTTONDOWN;\r\n procedure WMNCHitTest(var Msg: TWMNCHitTest); message WM_NCHITTEST;\r\n procedure CMCtl3DChanged(var Msg: TMessage); message CM_CTL3DCHANGED;\r\n protected\r\n procedure BoundsChanged; override;\r\n procedure FocusKilled(NextWnd: THandle); override;\r\n procedure FocusSet(PrevWnd: THandle); override;\r\n procedure CreateParams(var Params: TCreateParams); override;\r\n procedure CreateWnd; override;\r\n procedure DestroyWnd; override;\r\n function CreateItemList: TStrings; virtual;\r\n function GetItemWidth(Index: Integer): Integer; virtual;\r\n procedure WndProc(var Msg: TMessage); override;\r\n procedure DragCanceled; override;\r\n procedure DrawItem(Index: Integer; Rect: TRect;\r\n State: TOwnerDrawState); virtual;\r\n procedure MeasureItem(Index: Integer; var Height: Integer); virtual;\r\n function GetItemData(Index: Integer): Longint; dynamic;\r\n procedure SetItemData(Index: Integer; AData: Longint); dynamic;\r\n function GetItems: TStrings; virtual;\r\n procedure SetItems(Value: TStrings); virtual;\r\n procedure ResetContent; dynamic;\r\n procedure DeleteString(Index: Integer); dynamic;\r\n property AutoScroll: Boolean read GetAutoScroll write SetAutoScroll default False;\r\n property BorderStyle: TBorderStyle read FBorderStyle write SetBorderStyle default bsSingle;\r\n property Columns: Integer read FColumns write SetColumns default 0;\r\n property ExtendedSelect: Boolean read FExtendedSelect write SetExtendedSelect default True;\r\n property GraySelection: Boolean read FGraySelection write SetGraySelection default False;\r\n property IntegralHeight: Boolean read FIntegralHeight write SetIntegralHeight default False;\r\n property ItemHeight: Integer read GetItemHeight write SetItemHeight;\r\n property MultiSelect: Boolean read FMultiSelect write SetMultiSelect default False;\r\n property ParentColor default False;\r\n property Sorted: Boolean read FSorted write SetSorted default False;\r\n property Style: TListBoxStyle read FStyle write SetStyle default lbStandard;\r\n property TabWidth: Integer read FTabWidth write SetTabWidth default 0;\r\n property OnDrawItem: TDrawItemEvent read FOnDrawItem write SetOnDrawItem;\r\n property OnMeasureItem: TMeasureItemEvent read FOnMeasureItem write FOnMeasureItem;\r\n property OnGetItemWidth: TGetItemWidthEvent read FOnGetItemWidth write SetOnGetItemWidth;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n procedure Clear;\r\n procedure DefaultDrawText(X, Y: Integer; const S: string);\r\n function ItemAtPos(Pos: TPoint; Existing: Boolean): Integer;\r\n function ItemRect(Index: Integer): TRect;\r\n property Canvas: TCanvas read GetCanvas;\r\n property Items: TStrings read GetItems write SetItems;\r\n property ItemIndex: Integer read GetItemIndex write SetItemIndex;\r\n property SelCount: Integer read GetSelCount;\r\n property Selected[Index: Integer]: Boolean read GetSelected write SetSelected;\r\n property TopIndex: Integer read GetTopIndex write SetTopIndex;\r\n end;\r\n\r\n TCheckKind = (ckCheckBoxes, ckRadioButtons, ckCheckMarks);\r\n TChangeStateEvent = procedure(Sender: TObject; Index: Integer) of object;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvxCheckListBox = class(TJvxCustomListBox)\r\n private\r\n FAllowGrayed: Boolean;\r\n FCheckKind: TCheckKind;\r\n FSaveStates: TList;\r\n FDrawBitmap: TBitmap;\r\n FCheckWidth, FCheckHeight: Integer;\r\n FReserved: Integer;\r\n FInUpdateStates: Boolean;\r\n FIniLink: TJvIniLink;\r\n FOnClickCheck: TNotifyEvent;\r\n FOnStateChange: TChangeStateEvent;\r\n procedure ResetItemHeight;\r\n function GetItemHeight: Integer; override;\r\n procedure SetCheckKind(Value: TCheckKind);\r\n procedure SetChecked(Index: Integer; AChecked: Boolean);\r\n function GetChecked(Index: Integer): Boolean;\r\n procedure SetState(Index: Integer; AState: TCheckBoxState);\r\n function GetState(Index: Integer): TCheckBoxState;\r\n procedure SetItemEnabled(Index: Integer; Value: Boolean);\r\n function GetItemEnabled(Index: Integer): Boolean;\r\n function GetAllowGrayed: Boolean;\r\n procedure ToggleClickCheck(Index: Integer);\r\n procedure InvalidateCheck(Index: Integer);\r\n procedure InvalidateItem(Index: Integer);\r\n function CreateCheckObject(Index: Integer): TObject;\r\n function FindCheckObject(Index: Integer): TObject;\r\n function GetCheckObject(Index: Integer): TObject;\r\n function IsCheckObject(Index: Integer): Boolean;\r\n procedure ReadVersion(Reader: TReader);\r\n procedure WriteVersion(Writer: TWriter);\r\n procedure ReadCheckData(Reader: TReader);\r\n procedure WriteCheckData(Writer: TWriter);\r\n function GetStorage: TJvFormPlacement;\r\n procedure SetStorage(Value: TJvFormPlacement);\r\n procedure IniSave(Sender: TObject);\r\n procedure IniLoad(Sender: TObject);\r\n procedure UpdateCheckStates;\r\n function GetCheckedIndex: Integer;\r\n procedure SetCheckedIndex(Value: Integer);\r\n procedure CNDrawItem(var Msg: TWMDrawItem); message CN_DRAWITEM;\r\n protected\r\n procedure FontChanged; override;\r\n function CreateItemList: TStrings; override;\r\n procedure DrawItem(Index: Integer; Rect: TRect;\r\n State: TOwnerDrawState); override;\r\n procedure DefineProperties(Filer: TFiler); override;\r\n function GetItemWidth(Index: Integer): Integer; override;\r\n function GetItemData(Index: Integer): Longint; override;\r\n procedure SetItemData(Index: Integer; AData: Longint); override;\r\n procedure KeyPress(var Key: Char); override;\r\n procedure Loaded; override;\r\n procedure DrawCheck(R: TRect; AState: TCheckBoxState; Enabled: Boolean);\r\n procedure MouseDown(Button: TMouseButton; Shift: TShiftState;\r\n X, Y: Integer); override;\r\n procedure ResetContent; override;\r\n procedure DeleteString(Index: Integer); override;\r\n procedure ClickCheck; dynamic;\r\n procedure ChangeItemState(Index: Integer); dynamic;\r\n procedure CreateParams(var Params: TCreateParams); override;\r\n procedure CreateWnd; override;\r\n procedure DestroyWnd; override;\r\n procedure WMDestroy(var Msg: TWMDestroy); message WM_DESTROY;\r\n function GetCheckWidth: Integer;\r\n procedure SetItems(Value: TStrings); override;\r\n procedure InternalLoad(const Section: string);\r\n procedure InternalSave(const Section: string);\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n procedure LoadFromAppStorage(const AppStorage: TJvCustomAppStorage; const Path: string);\r\n procedure SaveToAppStorage(const AppStorage: TJvCustomAppStorage; const Path: string);\r\n procedure Load;\r\n procedure Save;\r\n procedure ApplyState(AState: TCheckBoxState; EnabledOnly: Boolean);\r\n property Checked[Index: Integer]: Boolean read GetChecked write SetChecked;\r\n property State[Index: Integer]: TCheckBoxState read GetState write SetState;\r\n property EnabledItem[Index: Integer]: Boolean read GetItemEnabled write SetItemEnabled;\r\n published\r\n property AllowGrayed: Boolean read GetAllowGrayed write FAllowGrayed default False;\r\n property CheckKind: TCheckKind read FCheckKind write SetCheckKind default ckCheckBoxes;\r\n property CheckedIndex: Integer read GetCheckedIndex write SetCheckedIndex default -1;\r\n property IniStorage: TJvFormPlacement read GetStorage write SetStorage;\r\n property Align;\r\n property AutoScroll default True;\r\n property BorderStyle;\r\n property Color;\r\n property Columns;\r\n property DragCursor;\r\n property DragMode;\r\n property Enabled;\r\n property ExtendedSelect;\r\n property Font;\r\n property GraySelection;\r\n property Anchors;\r\n property BiDiMode;\r\n property Constraints;\r\n property DragKind;\r\n property ParentBiDiMode;\r\n property ImeMode;\r\n property ImeName;\r\n property IntegralHeight;\r\n property ItemHeight;\r\n property Items stored False;\r\n property MultiSelect;\r\n property ParentColor;\r\n property ParentFont;\r\n property ParentShowHint;\r\n property PopupMenu;\r\n property ShowHint;\r\n property Sorted;\r\n property Style;\r\n property TabOrder;\r\n property TabStop default True;\r\n property TabWidth;\r\n property Visible;\r\n property OnStateChange: TChangeStateEvent read FOnStateChange write FOnStateChange;\r\n property OnClickCheck: TNotifyEvent read FOnClickCheck write FOnClickCheck;\r\n property OnClick;\r\n property OnDblClick;\r\n property OnDragDrop;\r\n property OnDragOver;\r\n property OnDrawItem;\r\n property OnEndDrag;\r\n property OnEnter;\r\n property OnExit;\r\n property OnGetItemWidth;\r\n property OnKeyDown;\r\n property OnKeyPress;\r\n property OnKeyUp;\r\n property OnMeasureItem;\r\n property OnMouseDown;\r\n property OnMouseMove;\r\n property OnMouseUp;\r\n property OnStartDrag;\r\n property OnContextPopup;\r\n property OnMouseWheelDown;\r\n property OnMouseWheelUp;\r\n property OnEndDock;\r\n property OnStartDock;\r\n end;\r\n\r\nconst\r\n clbDefaultState = cbUnchecked;\r\n clbDefaultEnabled = True;\r\n\r\nfunction CheckBitmap: TBitmap;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvxCheckListBox.pas $';\r\n Revision: '$Revision: 13415 $';\r\n Date: '$Date: 2012-09-10 11:51:54 +0200 (lun. 10 sept. 2012) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\n{$R JvxCheckListBox.res}\r\n\r\nuses\r\n SysUtils, Consts, Math,\r\n {$IFDEF HAS_UNIT_SYSTEM_UITYPES}\r\n System.UITypes,\r\n {$ENDIF HAS_UNIT_SYSTEM_UITYPES}\r\n {$IFNDEF COMPILER12_UP}\r\n JvJCLUtils, // ULONG_PTR\r\n {$ENDIF ~COMPILER12_UP}\r\n JvConsts, JvJVCLUtils, JvThemes;\r\n\r\n//=== { TJvListBoxStrings } ==================================================\r\n\r\ntype\r\n TJvListBoxStrings = class(TStrings)\r\n private\r\n ListBox: TJvxCustomListBox;\r\n protected\r\n function Get(Index: Integer): string; override;\r\n function GetCount: Integer; override;\r\n function GetObject(Index: Integer): TObject; override;\r\n procedure PutObject(Index: Integer; AObject: TObject); override;\r\n procedure SetUpdateState(Updating: Boolean); override;\r\n public\r\n function Add(const S: string): Integer; override;\r\n procedure Clear; override;\r\n procedure Delete(Index: Integer); override;\r\n procedure Insert(Index: Integer; const S: string); override;\r\n end;\r\n\r\nfunction TJvListBoxStrings.GetCount: Integer;\r\nbegin\r\n Result := SendMessage(ListBox.Handle, LB_GETCOUNT, 0, 0);\r\nend;\r\n\r\nfunction TJvListBoxStrings.Get(Index: Integer): string;\r\nvar\r\n Len: Integer;\r\n Text: array [0..4095] of Char;\r\nbegin\r\n Len := SendMessage(ListBox.Handle, LB_GETTEXT, Index, LPARAM(@Text));\r\n if Len < 0 then\r\n Error(SListIndexError, Index);\r\n SetString(Result, Text, Len);\r\nend;\r\n\r\nfunction TJvListBoxStrings.GetObject(Index: Integer): TObject;\r\nbegin\r\n Result := TObject(ListBox.GetItemData(Index));\r\n if LPARAM(Result) = LPARAM(LB_ERR) then\r\n Error(SListIndexError, Index);\r\nend;\r\n\r\nprocedure TJvListBoxStrings.PutObject(Index: Integer; AObject: TObject);\r\nbegin\r\n ListBox.SetItemData(Index, LPARAM(AObject));\r\nend;\r\n\r\nfunction TJvListBoxStrings.Add(const S: string): Integer;\r\nbegin\r\n Result := SendMessage(ListBox.Handle, LB_ADDSTRING, 0, LPARAM(PChar(S)));\r\n if Result < 0 then\r\n raise EOutOfResources.CreateRes(@SInsertLineError);\r\nend;\r\n\r\nprocedure TJvListBoxStrings.Insert(Index: Integer; const S: string);\r\nbegin\r\n if SendMessage(ListBox.Handle, LB_INSERTSTRING, Index, LPARAM(PChar(S))) < 0 then\r\n raise EOutOfResources.CreateRes(@SInsertLineError);\r\nend;\r\n\r\nprocedure TJvListBoxStrings.Delete(Index: Integer);\r\nbegin\r\n ListBox.DeleteString(Index);\r\nend;\r\n\r\nprocedure TJvListBoxStrings.Clear;\r\nbegin\r\n ListBox.ResetContent;\r\nend;\r\n\r\nprocedure TJvListBoxStrings.SetUpdateState(Updating: Boolean);\r\nbegin\r\n SendMessage(ListBox.Handle, WM_SETREDRAW, Ord(not Updating), 0);\r\n if not Updating then\r\n ListBox.Refresh;\r\nend;\r\n\r\n//=== { TJvxCustomListBox } ==================================================\r\n\r\n{ TJvxCustomListBox implementation copied from STDCTRLS.PAS and modified }\r\n\r\nprocedure ListIndexError(Index: Integer);\r\n\r\n function ReturnAddr: Pointer;\r\n asm\r\n MOV EAX,[EBP+4]\r\n end;\r\n\r\nbegin\r\n raise EStringListError.CreateResFmt(@SListIndexError, [Index]) at ReturnAddr;\r\nend;\r\n\r\nconstructor TJvxCustomListBox.Create(AOwner: TComponent);\r\nconst\r\n ListBoxStyle = [csSetCaption, csDoubleClicks];\r\nbegin\r\n inherited Create(AOwner);\r\n ControlStyle := ListBoxStyle;\r\n Width := 121;\r\n Height := 97;\r\n TabStop := True;\r\n ParentColor := False;\r\n FItems := CreateItemList;\r\n TJvListBoxStrings(FItems).ListBox := Self;\r\n FCanvas := TControlCanvas.Create;\r\n FCanvas.Control := Self;\r\n FItemHeight := 16;\r\n FBorderStyle := bsSingle;\r\n FExtendedSelect := True;\r\nend;\r\n\r\ndestructor TJvxCustomListBox.Destroy;\r\nbegin\r\n // (ahuser) moved inherited to the top otherwise it will raise an AV in csDesigning\r\n inherited Destroy;\r\n FCanvas.Free;\r\n FItems.Free;\r\n FSaveItems.Free;\r\nend;\r\n\r\nfunction TJvxCustomListBox.CreateItemList: TStrings;\r\nbegin\r\n Result := TJvListBoxStrings.Create;\r\nend;\r\n\r\nfunction TJvxCustomListBox.GetCanvas: TCanvas;\r\nbegin\r\n Result := FCanvas;\r\nend;\r\n\r\nfunction TJvxCustomListBox.GetItemData(Index: Integer): Longint;\r\nbegin\r\n Result := SendMessage(Handle, LB_GETITEMDATA, Index, 0);\r\nend;\r\n\r\nprocedure TJvxCustomListBox.SetItemData(Index: Integer; AData: Longint);\r\nbegin\r\n SendMessage(Handle, LB_SETITEMDATA, Index, AData);\r\nend;\r\n\r\nprocedure TJvxCustomListBox.DeleteString(Index: Integer);\r\nbegin\r\n SendMessage(Handle, LB_DELETESTRING, Index, 0);\r\nend;\r\n\r\nprocedure TJvxCustomListBox.SetHorizontalExtent;\r\nbegin\r\n SendMessage(Handle, LB_SETHORIZONTALEXTENT, FMaxItemWidth, 0);\r\nend;\r\n\r\nfunction TJvxCustomListBox.GetItemWidth(Index: Integer): Integer;\r\nvar\r\n ATabWidth: array [0..0] of Integer;\r\n S: string;\r\nbegin\r\n Result := 0;\r\n if csDestroying in ComponentState then\r\n Exit;\r\n if (Style <> lbStandard) and Assigned(FOnGetItemWidth) and\r\n Assigned(FOnDrawItem) then\r\n FOnGetItemWidth(Self, Index, Result)\r\n else\r\n begin\r\n S := Items[Index] + 'x';\r\n if TabWidth > 0 then\r\n begin\r\n {if (FTabChar > #0) then\r\n for I := 1 to Length(S) do\r\n if S[I] = FTabChar then S[I] := #9;}\r\n ATabWidth[0] := Round((TabWidth * FCanvas.TextWidth('0')) * 0.25);\r\n Result :=\r\n LoWord(GetTabbedTextExtent(FCanvas.Handle, PChar(S), Length(S), 1, ATabWidth));\r\n end\r\n else\r\n Result := FCanvas.TextWidth(S);\r\n end;\r\nend;\r\n\r\nprocedure TJvxCustomListBox.ResetHorizontalExtent;\r\nvar\r\n I: Integer;\r\nbegin\r\n FMaxItemWidth := 0;\r\n for I := 0 to Items.Count - 1 do\r\n FMaxItemWidth := Max(FMaxItemWidth, GetItemWidth(I));\r\n SetHorizontalExtent;\r\nend;\r\n\r\nprocedure TJvxCustomListBox.ResetContent;\r\nbegin\r\n SendMessage(Handle, LB_RESETCONTENT, 0, 0);\r\nend;\r\n\r\nprocedure TJvxCustomListBox.Clear;\r\nbegin\r\n FItems.Clear;\r\nend;\r\n\r\nprocedure TJvxCustomListBox.SetColumnWidth;\r\nbegin\r\n if FColumns > 0 then\r\n SendMessage(Handle, LB_SETCOLUMNWIDTH, (Width + FColumns - 3) div FColumns, 0);\r\nend;\r\n\r\nprocedure TJvxCustomListBox.SetColumns(Value: Integer);\r\nbegin\r\n if FColumns <> Value then\r\n if (FColumns = 0) or (Value = 0) then\r\n begin\r\n FColumns := Value;\r\n RecreateWnd;\r\n end\r\n else\r\n begin\r\n FColumns := Value;\r\n if HandleAllocated then\r\n SetColumnWidth;\r\n end;\r\nend;\r\n\r\nfunction TJvxCustomListBox.GetItemIndex: Integer;\r\nbegin\r\n Result := SendMessage(Handle, LB_GETCURSEL, 0, 0);\r\nend;\r\n\r\nfunction TJvxCustomListBox.GetSelCount: Integer;\r\nbegin\r\n Result := SendMessage(Handle, LB_GETSELCOUNT, 0, 0);\r\nend;\r\n\r\nprocedure TJvxCustomListBox.SetItemIndex(Value: Integer);\r\nbegin\r\n if GetItemIndex <> Value then\r\n SendMessage(Handle, LB_SETCURSEL, Value, 0);\r\nend;\r\n\r\nprocedure TJvxCustomListBox.SetExtendedSelect(Value: Boolean);\r\nbegin\r\n if Value <> FExtendedSelect then\r\n begin\r\n FExtendedSelect := Value;\r\n RecreateWnd;\r\n end;\r\nend;\r\n\r\nprocedure TJvxCustomListBox.SetIntegralHeight(Value: Boolean);\r\nbegin\r\n if Value <> FIntegralHeight then\r\n begin\r\n FIntegralHeight := Value;\r\n RecreateWnd;\r\n end;\r\nend;\r\n\r\nfunction TJvxCustomListBox.GetAutoScroll: Boolean;\r\nbegin\r\n Result := FAutoScroll and (Columns = 0);\r\nend;\r\n\r\nprocedure TJvxCustomListBox.SetOnDrawItem(Value: TDrawItemEvent);\r\nbegin\r\n if Assigned(FOnDrawItem) <> Assigned(Value) then\r\n begin\r\n FOnDrawItem := Value;\r\n Perform(WM_HSCROLL, SB_TOP, 0);\r\n if HandleAllocated then\r\n if AutoScroll then\r\n ResetHorizontalExtent\r\n else\r\n SendMessage(Handle, LB_SETHORIZONTALEXTENT, 0, 0);\r\n end\r\n else\r\n FOnDrawItem := Value;\r\nend;\r\n\r\nprocedure TJvxCustomListBox.SetOnGetItemWidth(Value: TGetItemWidthEvent);\r\nbegin\r\n if Assigned(FOnGetItemWidth) <> Assigned(Value) then\r\n begin\r\n FOnGetItemWidth := Value;\r\n Perform(WM_HSCROLL, SB_TOP, 0);\r\n if HandleAllocated then\r\n if AutoScroll then\r\n ResetHorizontalExtent\r\n else\r\n SendMessage(Handle, LB_SETHORIZONTALEXTENT, 0, 0);\r\n end\r\n else\r\n FOnGetItemWidth := Value;\r\nend;\r\n\r\nprocedure TJvxCustomListBox.SetAutoScroll(Value: Boolean);\r\nbegin\r\n if AutoScroll <> Value then\r\n begin\r\n FAutoScroll := Value;\r\n Perform(WM_HSCROLL, SB_TOP, 0);\r\n if HandleAllocated then\r\n if AutoScroll then\r\n ResetHorizontalExtent\r\n else\r\n SendMessage(Handle, LB_SETHORIZONTALEXTENT, 0, 0);\r\n end;\r\nend;\r\n\r\nfunction TJvxCustomListBox.GetItemHeight: Integer;\r\nvar\r\n R: TRect;\r\nbegin\r\n Result := FItemHeight;\r\n if HandleAllocated and (FStyle = lbStandard) then\r\n begin\r\n Perform(LB_GETITEMRECT, 0, LPARAM(@R));\r\n Result := R.Bottom - R.Top;\r\n end;\r\nend;\r\n\r\nprocedure TJvxCustomListBox.SetItemHeight(Value: Integer);\r\nbegin\r\n if (FItemHeight <> Value) and (Value > 0) then\r\n begin\r\n FItemHeight := Value;\r\n RecreateWnd;\r\n end;\r\nend;\r\n\r\nprocedure TJvxCustomListBox.SetTabWidth(Value: Integer);\r\nbegin\r\n if Value < 0 then\r\n Value := 0;\r\n if FTabWidth <> Value then\r\n begin\r\n FTabWidth := Value;\r\n RecreateWnd;\r\n end;\r\nend;\r\n\r\nprocedure TJvxCustomListBox.SetMultiSelect(Value: Boolean);\r\nbegin\r\n if FMultiSelect <> Value then\r\n begin\r\n FMultiSelect := Value;\r\n RecreateWnd;\r\n end;\r\nend;\r\n\r\nfunction TJvxCustomListBox.GetSelected(Index: Integer): Boolean;\r\nvar\r\n R: Longint;\r\nbegin\r\n R := SendMessage(Handle, LB_GETSEL, Index, 0);\r\n if R = LB_ERR then\r\n ListIndexError(Index);\r\n Result := LongBool(R);\r\nend;\r\n\r\nprocedure TJvxCustomListBox.SetSelected(Index: Integer; Value: Boolean);\r\nbegin\r\n if MultiSelect then\r\n begin\r\n if SendMessage(Handle, LB_SETSEL, Ord(Value), Index) = LB_ERR then\r\n ListIndexError(Index);\r\n end\r\n else\r\n begin\r\n if Value then\r\n SetItemIndex(Index)\r\n else\r\n if ItemIndex = Index then\r\n SetItemIndex(-1);\r\n end;\r\nend;\r\n\r\nprocedure TJvxCustomListBox.SetSorted(Value: Boolean);\r\nbegin\r\n if FSorted <> Value then\r\n begin\r\n FSorted := Value;\r\n RecreateWnd;\r\n end;\r\nend;\r\n\r\nprocedure TJvxCustomListBox.SetStyle(Value: TListBoxStyle);\r\nbegin\r\n if FStyle <> Value then\r\n begin\r\n FStyle := Value;\r\n RecreateWnd;\r\n end;\r\nend;\r\n\r\nfunction TJvxCustomListBox.GetTopIndex: Integer;\r\nbegin\r\n Result := SendMessage(Handle, LB_GETTOPINDEX, 0, 0);\r\nend;\r\n\r\nprocedure TJvxCustomListBox.SetBorderStyle(Value: TBorderStyle);\r\nbegin\r\n if FBorderStyle <> Value then\r\n begin\r\n FBorderStyle := Value;\r\n RecreateWnd;\r\n end;\r\nend;\r\n\r\nprocedure TJvxCustomListBox.SetTopIndex(Value: Integer);\r\nbegin\r\n if GetTopIndex <> Value then\r\n SendMessage(Handle, LB_SETTOPINDEX, Value, 0);\r\nend;\r\n\r\nprocedure TJvxCustomListBox.SetGraySelection(Value: Boolean);\r\nbegin\r\n if FGraySelection <> Value then\r\n begin\r\n FGraySelection := Value;\r\n if not Focused then\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nfunction TJvxCustomListBox.GetItems: TStrings;\r\nbegin\r\n Result := FItems;\r\nend;\r\n\r\nprocedure TJvxCustomListBox.SetItems(Value: TStrings);\r\nbegin\r\n Items.Assign(Value);\r\nend;\r\n\r\nfunction TJvxCustomListBox.ItemAtPos(Pos: TPoint; Existing: Boolean): Integer;\r\nvar\r\n Count: Integer;\r\n ItemRect: TRect;\r\nbegin\r\n if PtInRect(ClientRect, Pos) then\r\n begin\r\n Result := TopIndex;\r\n Count := Items.Count;\r\n while Result < Count do\r\n begin\r\n Perform(LB_GETITEMRECT, Result, LPARAM(@ItemRect));\r\n if PtInRect(ItemRect, Pos) then\r\n Exit;\r\n Inc(Result);\r\n end;\r\n if not Existing then\r\n Exit;\r\n end;\r\n Result := -1;\r\nend;\r\n\r\nfunction TJvxCustomListBox.ItemRect(Index: Integer): TRect;\r\nvar\r\n Count: Integer;\r\nbegin\r\n Count := Items.Count;\r\n if (Index = 0) or (Index < Count) then\r\n Perform(LB_GETITEMRECT, Index, LPARAM(@Result))\r\n else\r\n if Index = Count then\r\n begin\r\n Perform(LB_GETITEMRECT, Index - 1, LPARAM(@Result));\r\n OffsetRect(Result, 0, Result.Bottom - Result.Top);\r\n end\r\n else\r\n Result := Rect(0, 0, 0, 0);\r\nend;\r\n\r\nprocedure TJvxCustomListBox.CreateParams(var Params: TCreateParams);\r\ntype\r\n PSelects = ^TSelects;\r\n TSelects = array [Boolean] of Longword;\r\nconst\r\n BorderStyles: array [TBorderStyle] of Longword = (0, WS_BORDER);\r\n Styles: array [TListBoxStyle] of Longword =\r\n (0, LBS_OWNERDRAWFIXED, LBS_OWNERDRAWVARIABLE, LBS_OWNERDRAWFIXED, LBS_OWNERDRAWFIXED);\r\n Sorteds: TSelects = (0, LBS_SORT);\r\n MultiSelects: TSelects = (0, LBS_MULTIPLESEL);\r\n ExtendSelects: TSelects = (0, LBS_EXTENDEDSEL);\r\n IntegralHeights: TSelects = (LBS_NOINTEGRALHEIGHT, 0);\r\n MultiColumns: TSelects = (0, LBS_MULTICOLUMN);\r\n TabStops: TSelects = (0, LBS_USETABSTOPS);\r\nvar\r\n Selects: PSelects;\r\nbegin\r\n inherited CreateParams(Params);\r\n CreateSubClass(Params, 'LISTBOX');\r\n with Params do\r\n begin\r\n Selects := @MultiSelects;\r\n if FExtendedSelect then\r\n Selects := @ExtendSelects;\r\n Style := Style or (WS_HSCROLL or WS_VSCROLL or LBS_HASSTRINGS or LBS_NOTIFY) or\r\n Styles[FStyle] or Sorteds[FSorted] or Selects[FMultiSelect] or\r\n IntegralHeights[FIntegralHeight] or MultiColumns[FColumns <> 0] or\r\n BorderStyles[FBorderStyle] or TabStops[FTabWidth <> 0];\r\n if Ctl3D and (FBorderStyle = bsSingle) then\r\n begin\r\n Style := Style and not WS_BORDER;\r\n ExStyle := ExStyle or WS_EX_CLIENTEDGE;\r\n end;\r\n WindowClass.Style := WindowClass.Style and not (CS_HREDRAW or CS_VREDRAW);\r\n end;\r\nend;\r\n\r\nprocedure TJvxCustomListBox.CreateWnd;\r\nvar\r\n W, H: Integer;\r\nbegin\r\n W := Width;\r\n H := Height;\r\n inherited CreateWnd;\r\n SetWindowPos(Handle, 0, Left, Top, W, H, SWP_NOZORDER or SWP_NOACTIVATE);\r\n if FTabWidth <> 0 then\r\n begin\r\n SendMessage(Handle, LB_SETTABSTOPS, 1, LPARAM(@FTabWidth));\r\n end;\r\n SetColumnWidth;\r\n if FSaveItems <> nil then\r\n begin\r\n FItems.Assign(FSaveItems);\r\n SetTopIndex(FSaveTopIndex);\r\n SetItemIndex(FSaveItemIndex);\r\n FSaveItems.Free;\r\n FSaveItems := nil;\r\n end;\r\nend;\r\n\r\nprocedure TJvxCustomListBox.DestroyWnd;\r\nbegin\r\n if FItems.Count > 0 then\r\n begin\r\n FSaveItems := TStringList.Create;\r\n FSaveItems.Assign(FItems);\r\n FSaveTopIndex := GetTopIndex;\r\n FSaveItemIndex := GetItemIndex;\r\n end;\r\n inherited DestroyWnd;\r\nend;\r\n\r\nprocedure TJvxCustomListBox.WndProc(var Msg: TMessage);\r\nbegin\r\n if AutoScroll then\r\n begin\r\n case Msg.Msg of\r\n LB_ADDSTRING, LB_INSERTSTRING:\r\n begin\r\n inherited WndProc(Msg);\r\n FMaxItemWidth := Max(FMaxItemWidth, GetItemWidth(Msg.Result));\r\n SetHorizontalExtent;\r\n Exit;\r\n end;\r\n LB_DELETESTRING:\r\n begin\r\n if GetItemWidth(Msg.WParam) >= FMaxItemWidth then\r\n begin\r\n Perform(WM_HSCROLL, SB_TOP, 0);\r\n inherited WndProc(Msg);\r\n ResetHorizontalExtent;\r\n end\r\n else\r\n inherited WndProc(Msg);\r\n Exit;\r\n end;\r\n LB_RESETCONTENT:\r\n begin\r\n FMaxItemWidth := 0;\r\n SetHorizontalExtent;\r\n Perform(WM_HSCROLL, SB_TOP, 0);\r\n inherited WndProc(Msg);\r\n Exit;\r\n end;\r\n WM_SETFONT:\r\n begin\r\n inherited WndProc(Msg);\r\n if not (csDestroying in ComponentState) then\r\n begin\r\n FCanvas.Font.Assign(Self.Font);\r\n ResetHorizontalExtent;\r\n end;\r\n Exit;\r\n end;\r\n end;\r\n end;\r\n {for auto drag mode, let listbox handle itself, instead of TControl}\r\n if not (csDesigning in ComponentState) and ((Msg.Msg = WM_LBUTTONDOWN) or\r\n (Msg.Msg = WM_LBUTTONDBLCLK)) and not Dragging then\r\n begin\r\n if DragMode = dmAutomatic then\r\n begin\r\n if IsControlMouseMsg(TWMMouse(Msg)) then\r\n Exit;\r\n ControlState := ControlState + [csLButtonDown];\r\n Dispatch(Msg); {overrides TControl's BeginDrag}\r\n Exit;\r\n end;\r\n end;\r\n inherited WndProc(Msg);\r\nend;\r\n\r\nprocedure TJvxCustomListBox.WMLButtonDown(var Msg: TWMLButtonDown);\r\nvar\r\n ItemNo: Integer;\r\n ShiftState: TShiftState;\r\nbegin\r\n ShiftState := KeysToShiftState(Msg.Keys);\r\n if (DragMode = dmAutomatic) and FMultiSelect then\r\n begin\r\n if not (ssShift in ShiftState) or (ssCtrl in ShiftState) then\r\n begin\r\n ItemNo := ItemAtPos(SmallPointToPoint(Msg.Pos), True);\r\n if (ItemNo >= 0) and Selected[ItemNo] then\r\n begin\r\n BeginDrag(False);\r\n Exit;\r\n end;\r\n end;\r\n end;\r\n inherited;\r\n if (DragMode = dmAutomatic) and not (FMultiSelect and\r\n ((ssCtrl in ShiftState) or (ssShift in ShiftState))) then\r\n BeginDrag(False);\r\nend;\r\n\r\nprocedure TJvxCustomListBox.WMNCHitTest(var Msg: TWMNCHitTest);\r\nbegin\r\n if csDesigning in ComponentState then\r\n DefaultHandler(Msg)\r\n else\r\n inherited;\r\nend;\r\n\r\nprocedure TJvxCustomListBox.CNCommand(var Msg: TWMCommand);\r\nbegin\r\n case Msg.NotifyCode of\r\n LBN_SELCHANGE:\r\n begin\r\n inherited Changed;\r\n Click;\r\n end;\r\n LBN_DBLCLK:\r\n DblClick;\r\n end;\r\nend;\r\n\r\nprocedure TJvxCustomListBox.WMPaint(var Msg: TWMPaint);\r\n\r\n procedure PaintListBox;\r\n var\r\n DrawItemMsg: TWMDrawItem;\r\n MeasureItemMsg: TWMMeasureItem;\r\n DrawItemStruct: TDrawItemStruct;\r\n MeasureItemStruct: TMeasureItemStruct;\r\n R: TRect;\r\n Y, I, H, W: Integer;\r\n begin\r\n { Initialize drawing records }\r\n DrawItemMsg.Msg := CN_DRAWITEM;\r\n DrawItemMsg.DrawItemStruct := @DrawItemStruct;\r\n DrawItemMsg.Ctl := Handle;\r\n DrawItemStruct.CtlType := ODT_LISTBOX;\r\n DrawItemStruct.itemAction := ODA_DRAWENTIRE;\r\n DrawItemStruct.itemState := 0;\r\n DrawItemStruct.HDC := Msg.DC;\r\n DrawItemStruct.CtlID := Handle;\r\n DrawItemStruct.hwndItem := Handle;\r\n { Intialize measure records }\r\n MeasureItemMsg.Msg := CN_MEASUREITEM;\r\n MeasureItemMsg.IDCtl := Handle;\r\n MeasureItemMsg.MeasureItemStruct := @MeasureItemStruct;\r\n MeasureItemStruct.CtlType := ODT_LISTBOX;\r\n MeasureItemStruct.CtlID := Handle;\r\n { Draw the listbox }\r\n Y := 0;\r\n I := TopIndex;\r\n GetClipBox(Msg.DC, R);\r\n H := Height;\r\n W := Width;\r\n while Y < H do\r\n begin\r\n MeasureItemStruct.itemID := I;\r\n if I < Items.Count then\r\n MeasureItemStruct.itemData := ULONG_PTR(Items.Objects[I]);\r\n MeasureItemStruct.itemWidth := W;\r\n MeasureItemStruct.itemHeight := FItemHeight;\r\n DrawItemStruct.itemData := MeasureItemStruct.itemData;\r\n DrawItemStruct.itemID := I;\r\n Dispatch(MeasureItemMsg);\r\n DrawItemStruct.rcItem := Rect(0, Y, MeasureItemStruct.itemWidth,\r\n Y + Integer(MeasureItemStruct.itemHeight));\r\n Dispatch(DrawItemMsg);\r\n Inc(Y, MeasureItemStruct.itemHeight);\r\n Inc(I);\r\n if I >= Items.Count then\r\n Break;\r\n end;\r\n end;\r\n\r\nbegin\r\n if Msg.DC <> 0 then\r\n PaintListBox\r\n else\r\n inherited;\r\nend;\r\n\r\nprocedure TJvxCustomListBox.BoundsChanged;\r\nbegin\r\n inherited BoundsChanged;\r\n SetColumnWidth;\r\nend;\r\n\r\nprocedure TJvxCustomListBox.DragCanceled;\r\nvar\r\n M: TWMMouse;\r\n MousePos: TPoint;\r\nbegin\r\n with M do\r\n begin\r\n Msg := WM_LBUTTONDOWN;\r\n GetCursorPos(MousePos);\r\n Pos := PointToSmallPoint(ScreenToClient(MousePos));\r\n Keys := 0;\r\n Result := 0;\r\n end;\r\n DefaultHandler(M);\r\n M.Msg := WM_LBUTTONUP;\r\n DefaultHandler(M);\r\nend;\r\n\r\nprocedure TJvxCustomListBox.DefaultDrawText(X, Y: Integer; const S: string);\r\nvar\r\n ATabWidth: array [0..0] of Longint;\r\nbegin\r\n if csDestroying in ComponentState then\r\n Exit;\r\n FCanvas.UpdateTextFlags;\r\n if FTabWidth = 0 then\r\n FCanvas.TextOut(X, Y, S)\r\n else\r\n begin\r\n ATabWidth[0] := Round((TabWidth * FCanvas.TextWidth('0')) * 0.25);\r\n TabbedTextOut(FCanvas.Handle, X, Y, PChar(S), Length(S), 1, ATabWidth, X);\r\n end;\r\nend;\r\n\r\nprocedure TJvxCustomListBox.DrawItem(Index: Integer; Rect: TRect;\r\n State: TOwnerDrawState);\r\nbegin\r\n if csDestroying in ComponentState then\r\n Exit;\r\n if Assigned(FOnDrawItem) then\r\n FOnDrawItem(Self, Index, Rect, State)\r\n else\r\n begin\r\n FCanvas.FillRect(Rect);\r\n if Index < Items.Count then\r\n begin\r\n if not UseRightToLeftAlignment then\r\n Inc(Rect.Left, 2)\r\n else\r\n Dec(Rect.Right, 2);\r\n DefaultDrawText(Rect.Left,\r\n Max(Rect.Top, (Rect.Bottom + Rect.Top - CanvasMaxTextHeight(FCanvas)) div 2),\r\n Items[Index]);\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvxCustomListBox.MeasureItem(Index: Integer; var Height: Integer);\r\nbegin\r\n if Assigned(FOnMeasureItem) then\r\n FOnMeasureItem(Self, Index, Height);\r\nend;\r\n\r\nprocedure TJvxCustomListBox.CNDrawItem(var Msg: TWMDrawItem);\r\nvar\r\n State: TOwnerDrawState;\r\nbegin\r\n if csDestroying in ComponentState then\r\n Exit;\r\n with Msg.DrawItemStruct^ do\r\n begin\r\n State := TOwnerDrawState(LoWord(itemState));\r\n FCanvas.Handle := HDC;\r\n FCanvas.Font := Font;\r\n FCanvas.Brush := Brush;\r\n if (Integer(itemID) >= 0) and (odSelected in State) then\r\n begin\r\n with FCanvas do\r\n if not (csDesigning in ComponentState) and FGraySelection and\r\n not Focused then\r\n begin\r\n Brush.Color := clBtnFace;\r\n if ColorToRGB(Font.Color) = ColorToRGB(clBtnFace) then\r\n Font.Color := clBtnText;\r\n end\r\n else\r\n begin\r\n Brush.Color := clHighlight;\r\n Font.Color := clHighlightText\r\n end;\r\n end;\r\n if Integer(itemID) >= 0 then\r\n DrawItem(itemID, rcItem, State)\r\n else\r\n FCanvas.FillRect(rcItem);\r\n if odFocused in State then\r\n DrawFocusRect(HDC, rcItem);\r\n FCanvas.Handle := 0;\r\n end;\r\nend;\r\n\r\nprocedure TJvxCustomListBox.CNMeasureItem(var Msg: TWMMeasureItem);\r\nvar\r\n LItemHeight: Integer;\r\nbegin\r\n with Msg.MeasureItemStruct^ do\r\n begin\r\n LItemHeight := FItemHeight;\r\n if FStyle = lbOwnerDrawVariable then\r\n MeasureItem(itemID, LItemHeight);\r\n itemHeight := UINT(LItemHeight);\r\n end;\r\nend;\r\n\r\nprocedure TJvxCustomListBox.FocusKilled(NextWnd: THandle);\r\nbegin\r\n inherited FocusKilled(NextWnd);\r\n if FGraySelection and MultiSelect and (SelCount > 1) then\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvxCustomListBox.FocusSet(PrevWnd: THandle);\r\nbegin\r\n inherited FocusSet(PrevWnd);\r\n if FGraySelection and MultiSelect and (SelCount > 1) then\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvxCustomListBox.CMCtl3DChanged(var Msg: TMessage);\r\nbegin\r\n if FBorderStyle = bsSingle then\r\n RecreateWnd;\r\n inherited;\r\nend;\r\n\r\n//=== { TJvCheckListBoxItem } ================================================\r\n\r\ntype\r\n TJvCheckListBoxItem = class(TObject)\r\n private\r\n FData: Longint;\r\n FState: TCheckBoxState;\r\n FEnabled: Boolean;\r\n function GetChecked: Boolean;\r\n public\r\n constructor Create;\r\n property Checked: Boolean read GetChecked;\r\n property Enabled: Boolean read FEnabled write FEnabled;\r\n property State: TCheckBoxState read FState write FState;\r\n end;\r\n\r\nconstructor TJvCheckListBoxItem.Create;\r\nbegin\r\n inherited Create;\r\n FState := clbDefaultState;\r\n FEnabled := clbDefaultEnabled;\r\nend;\r\n\r\nfunction TJvCheckListBoxItem.GetChecked: Boolean;\r\nbegin\r\n Result := FState = cbChecked;\r\nend;\r\n\r\n//=== { TJvCheckListBoxStrings } =============================================\r\n\r\ntype\r\n TJvCheckListBoxStrings = class(TJvListBoxStrings)\r\n public\r\n procedure Exchange(Index1, Index2: Integer); override;\r\n procedure Move(CurIndex, NewIndex: Integer); override;\r\n end;\r\n\r\nprocedure TJvCheckListBoxStrings.Exchange(Index1, Index2: Integer);\r\nvar\r\n TempEnabled1, TempEnabled2: Boolean;\r\n TempState1, TempState2: TCheckBoxState;\r\nbegin\r\n with TJvxCheckListBox(ListBox) do\r\n begin\r\n TempState1 := State[Index1];\r\n TempEnabled1 := EnabledItem[Index1];\r\n TempState2 := State[Index2];\r\n TempEnabled2 := EnabledItem[Index2];\r\n inherited Exchange(Index1, Index2);\r\n State[Index1] := TempState2;\r\n EnabledItem[Index1] := TempEnabled2;\r\n State[Index2] := TempState1;\r\n EnabledItem[Index2] := TempEnabled1;\r\n end;\r\nend;\r\n\r\nprocedure TJvCheckListBoxStrings.Move(CurIndex, NewIndex: Integer);\r\nvar\r\n TempEnabled: Boolean;\r\n TempState: TCheckBoxState;\r\nbegin\r\n with TJvxCheckListBox(ListBox) do\r\n begin\r\n TempState := State[CurIndex];\r\n TempEnabled := EnabledItem[CurIndex];\r\n inherited Move(CurIndex, NewIndex);\r\n State[NewIndex] := TempState;\r\n EnabledItem[NewIndex] := TempEnabled;\r\n end;\r\nend;\r\n\r\n//=== { TJvxCheckListBox } ===================================================\r\n\r\n// (rom) changed to var\r\nvar\r\n GCheckBitmap: TBitmap = nil;\r\n\r\nfunction CheckBitmap: TBitmap;\r\nbegin\r\n if GCheckBitmap = nil then\r\n begin\r\n GCheckBitmap := TBitmap.Create;\r\n GCheckBitmap.Handle := LoadBitmap(HInstance, 'JvxCheckListBoxIMAGES');\r\n end;\r\n Result := GCheckBitmap;\r\nend;\r\n\r\nconst\r\n InternalVersion = 202; { for backward compatibility only }\r\n\r\nconstructor TJvxCheckListBox.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FAutoScroll := True;\r\n with CheckBitmap do\r\n begin\r\n FCheckWidth := Width div 6;\r\n FCheckHeight := Height div 3;\r\n end;\r\n FDrawBitmap := TBitmap.Create;\r\n with FDrawBitmap do\r\n begin\r\n Width := FCheckWidth;\r\n Height := FCheckHeight;\r\n end;\r\n FIniLink := TJvIniLink.Create;\r\n FIniLink.OnSave := IniSave;\r\n FIniLink.OnLoad := IniLoad;\r\nend;\r\n\r\ndestructor TJvxCheckListBox.Destroy;\r\nbegin\r\n FSaveStates.Free;\r\n FSaveStates := nil;\r\n FDrawBitmap.Free;\r\n FDrawBitmap := nil;\r\n FIniLink.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvxCheckListBox.Loaded;\r\nbegin\r\n inherited Loaded;\r\n UpdateCheckStates;\r\nend;\r\n\r\nfunction TJvxCheckListBox.CreateItemList: TStrings;\r\nbegin\r\n Result := TJvCheckListBoxStrings.Create;\r\nend;\r\n\r\nconst\r\n sCount = 'Count';\r\n sItem = 'Item';\r\n\r\nprocedure TJvxCheckListBox.LoadFromAppStorage(const AppStorage: TJvCustomAppStorage; const Path: string);\r\nvar\r\n I: Integer;\r\n ACount: Integer;\r\nbegin\r\n ACount := Min(AppStorage.ReadInteger(AppStorage.ConcatPaths([Path, sCount]), 0), Items.Count);\r\n for I := 0 to ACount - 1 do\r\n begin\r\n State[I] := TCheckBoxState(AppStorage.ReadInteger(AppStorage.ConcatPaths([Path, sItem + IntToStr(I)]),\r\n Integer(clbDefaultState)));\r\n if (State[I] = cbChecked) and (FCheckKind = ckRadioButtons) then\r\n Exit;\r\n end;\r\nend;\r\n\r\nprocedure TJvxCheckListBox.SaveToAppStorage(const AppStorage: TJvCustomAppStorage; const Path: string);\r\nvar\r\n I: Integer;\r\nbegin\r\n AppStorage.DeleteSubTree(Path);\r\n AppStorage.WriteInteger(AppStorage.ConcatPaths([Path, sCount]), Items.Count);\r\n for I := 0 to Items.Count - 1 do\r\n AppStorage.WriteInteger(AppStorage.ConcatPaths([Path, sItem + IntToStr(I)]), Ord(State[I]));\r\nend;\r\n\r\nprocedure TJvxCheckListBox.Load;\r\nbegin\r\n IniLoad(nil);\r\nend;\r\n\r\nprocedure TJvxCheckListBox.Save;\r\nbegin\r\n IniSave(nil);\r\nend;\r\n\r\nfunction TJvxCheckListBox.GetStorage: TJvFormPlacement;\r\nbegin\r\n Result := FIniLink.Storage;\r\nend;\r\n\r\nprocedure TJvxCheckListBox.SetStorage(Value: TJvFormPlacement);\r\nbegin\r\n FIniLink.Storage := Value;\r\nend;\r\n\r\nprocedure TJvxCheckListBox.IniSave(Sender: TObject);\r\nbegin\r\n if (Name <> '') and Assigned(IniStorage) then\r\n InternalSave(GetDefaultSection(Self));\r\nend;\r\n\r\nprocedure TJvxCheckListBox.IniLoad(Sender: TObject);\r\nbegin\r\n if (Name <> '') and Assigned(IniStorage) then\r\n InternalLoad(GetDefaultSection(Self));\r\nend;\r\n\r\nprocedure TJvxCheckListBox.ReadCheckData(Reader: TReader);\r\nvar\r\n I: Integer;\r\nbegin\r\n Items.BeginUpdate;\r\n try\r\n Reader.ReadListBegin;\r\n Clear;\r\n while not Reader.EndOfList do\r\n begin\r\n I := Items.Add(Reader.ReadString);\r\n if FReserved >= InternalVersion then\r\n begin\r\n State[I] := TCheckBoxState(Reader.ReadInteger);\r\n EnabledItem[I] := Reader.ReadBoolean;\r\n end\r\n else\r\n begin { for backward compatibility only }\r\n Checked[I] := Reader.ReadBoolean;\r\n EnabledItem[I] := Reader.ReadBoolean;\r\n if FReserved > 0 then\r\n State[I] := TCheckBoxState(Reader.ReadInteger);\r\n end;\r\n end;\r\n Reader.ReadListEnd;\r\n UpdateCheckStates;\r\n finally\r\n Items.EndUpdate;\r\n end;\r\nend;\r\n\r\nprocedure TJvxCheckListBox.WriteCheckData(Writer: TWriter);\r\nvar\r\n I: Integer;\r\nbegin\r\n with Writer do\r\n begin\r\n WriteListBegin;\r\n for I := 0 to Items.Count - 1 do\r\n begin\r\n WriteString(Items[I]);\r\n WriteInteger(Ord(Self.State[I]));\r\n WriteBoolean(EnabledItem[I]);\r\n end;\r\n WriteListEnd;\r\n end;\r\nend;\r\n\r\nprocedure TJvxCheckListBox.ReadVersion(Reader: TReader);\r\nbegin\r\n FReserved := Reader.ReadInteger;\r\nend;\r\n\r\nprocedure TJvxCheckListBox.WriteVersion(Writer: TWriter);\r\nbegin\r\n Writer.WriteInteger(InternalVersion);\r\nend;\r\n\r\nprocedure TJvxCheckListBox.DefineProperties(Filer: TFiler);\r\n\r\n function DoWrite: Boolean;\r\n var\r\n I: Integer;\r\n Ancestor: TJvxCheckListBox;\r\n begin\r\n Result := False;\r\n Ancestor := TJvxCheckListBox(Filer.Ancestor);\r\n if (Ancestor <> nil) and (Ancestor.Items.Count = Items.Count) and\r\n (Ancestor.Items.Count > 0) then\r\n for I := 1 to Items.Count - 1 do\r\n begin\r\n Result := (CompareText(Items[I], Ancestor.Items[I]) <> 0) or\r\n (State[I] <> Ancestor.State[I]) or\r\n (EnabledItem[I] <> Ancestor.EnabledItem[I]);\r\n if Result then\r\n Break;\r\n end\r\n else\r\n Result := Items.Count > 0;\r\n end;\r\n\r\nbegin\r\n inherited DefineProperties(Filer);\r\n Filer.DefineProperty('InternalVersion', ReadVersion, WriteVersion, Filer.Ancestor = nil);\r\n Filer.DefineProperty('Strings', ReadCheckData, WriteCheckData, DoWrite);\r\nend;\r\n\r\nprocedure TJvxCheckListBox.CreateWnd;\r\nbegin\r\n inherited CreateWnd;\r\n if FSaveStates <> nil then\r\n begin\r\n FSaveStates.Free;\r\n FSaveStates := nil;\r\n end;\r\n ResetItemHeight;\r\nend;\r\n\r\nprocedure TJvxCheckListBox.DestroyWnd;\r\nbegin\r\n inherited DestroyWnd;\r\nend;\r\n\r\nprocedure TJvxCheckListBox.WMDestroy(var Msg: TWMDestroy);\r\nvar\r\n I: Integer;\r\nbegin\r\n if Items.Count > 0 then\r\n begin\r\n if FSaveStates <> nil then\r\n FSaveStates.Clear\r\n else\r\n FSaveStates := TList.Create;\r\n for I := 0 to Items.Count - 1 do\r\n begin\r\n FSaveStates.Add(TObject(MakeLong(Ord(EnabledItem[I]), Word(State[I]))));\r\n FindCheckObject(I).Free;\r\n end;\r\n end;\r\n inherited;\r\nend;\r\n\r\nprocedure TJvxCheckListBox.CreateParams(var Params: TCreateParams);\r\nbegin\r\n inherited CreateParams(Params);\r\n with Params do\r\n if Style and (LBS_OWNERDRAWFIXED or LBS_OWNERDRAWVARIABLE) = 0 then\r\n Style := Style or LBS_OWNERDRAWFIXED;\r\nend;\r\n\r\nprocedure TJvxCheckListBox.SetItems(Value: TStrings);\r\nvar\r\n I: Integer;\r\nbegin\r\n Items.BeginUpdate;\r\n try\r\n inherited SetItems(Value);\r\n if (Value <> nil) and (Value is TJvListBoxStrings) and\r\n (TJvListBoxStrings(Value).ListBox <> nil) and\r\n (TJvListBoxStrings(Value).ListBox is TJvxCheckListBox) then\r\n begin\r\n for I := 0 to Items.Count - 1 do\r\n if I < Value.Count then\r\n begin\r\n Self.State[I] := TJvxCheckListBox(TJvListBoxStrings(Value).ListBox).State[I];\r\n EnabledItem[I] :=\r\n TJvxCheckListBox(TJvListBoxStrings(Value).ListBox).EnabledItem[I];\r\n end;\r\n end;\r\n finally\r\n Items.EndUpdate;\r\n end;\r\nend;\r\n\r\nprocedure TJvxCheckListBox.InternalLoad(const Section: string);\r\nbegin\r\n if Assigned(IniStorage) then\r\n with IniStorage do\r\n LoadFromAppStorage(AppStorage, AppStorage.ConcatPaths([AppStoragePath, Section]));\r\nend;\r\n\r\nprocedure TJvxCheckListBox.InternalSave(const Section: string);\r\nbegin\r\n if Assigned(IniStorage) then\r\n with IniStorage do\r\n SaveToAppStorage(AppStorage, AppStorage.ConcatPaths([AppStoragePath, Section]));\r\nend;\r\n\r\nfunction TJvxCheckListBox.GetItemWidth(Index: Integer): Integer;\r\nbegin\r\n Result := inherited GetItemWidth(Index) + GetCheckWidth;\r\nend;\r\n\r\nfunction TJvxCheckListBox.GetCheckWidth: Integer;\r\nbegin\r\n Result := FCheckWidth + 2;\r\nend;\r\n\r\nfunction TJvxCheckListBox.GetAllowGrayed: Boolean;\r\nbegin\r\n Result := FAllowGrayed and (FCheckKind in [ckCheckBoxes, ckCheckMarks]);\r\nend;\r\n\r\nprocedure TJvxCheckListBox.FontChanged;\r\nbegin\r\n inherited FontChanged;\r\n ResetItemHeight;\r\nend;\r\n\r\nfunction TJvxCheckListBox.GetItemHeight: Integer;\r\nvar\r\n R: TRect;\r\nbegin\r\n Result := FItemHeight;\r\n if HandleAllocated and ((FStyle = lbStandard) or\r\n ((FStyle = lbOwnerDrawFixed) and not Assigned(FOnDrawItem))) then\r\n begin\r\n Perform(LB_GETITEMRECT, 0, LPARAM(@R));\r\n Result := R.Bottom - R.Top;\r\n end;\r\nend;\r\n\r\nprocedure TJvxCheckListBox.ResetItemHeight;\r\nvar\r\n H: Integer;\r\nbegin\r\n if csDestroying in ComponentState then\r\n Exit;\r\n if (Style = lbStandard) or ((Style = lbOwnerDrawFixed) and\r\n not Assigned(FOnDrawItem)) then\r\n begin\r\n FCanvas.Font := Font;\r\n H := Max(CanvasMaxTextHeight(FCanvas), FCheckHeight);\r\n if Style = lbOwnerDrawFixed then\r\n H := Max(H, FItemHeight);\r\n Perform(LB_SETITEMHEIGHT, 0, H);\r\n if (H * Items.Count) <= ClientHeight then\r\n SetScrollRange(Handle, SB_VERT, 0, 0, True);\r\n end;\r\nend;\r\n\r\nprocedure TJvxCheckListBox.DrawItem(Index: Integer; Rect: TRect;\r\n State: TOwnerDrawState);\r\nvar\r\n R: TRect;\r\n SaveEvent: TDrawItemEvent;\r\nbegin\r\n if csDestroying in ComponentState then\r\n Exit;\r\n if Index < Items.Count then\r\n begin\r\n R := Rect;\r\n if not UseRightToLeftAlignment then\r\n begin\r\n R.Right := Rect.Left;\r\n R.Left := R.Right - GetCheckWidth;\r\n end\r\n else\r\n begin\r\n R.Left := Rect.Right;\r\n R.Right := R.Left + GetCheckWidth;\r\n end;\r\n DrawCheck(R, GetState(Index), EnabledItem[Index]);\r\n if not EnabledItem[Index] then\r\n if odSelected in State then\r\n FCanvas.Font.Color := clInactiveCaptionText\r\n else\r\n FCanvas.Font.Color := clGrayText;\r\n end;\r\n if (Style = lbStandard) and Assigned(FOnDrawItem) then\r\n begin\r\n SaveEvent := OnDrawItem;\r\n OnDrawItem := nil;\r\n try\r\n inherited DrawItem(Index, Rect, State);\r\n finally\r\n OnDrawItem := SaveEvent;\r\n end;\r\n end\r\n else\r\n inherited DrawItem(Index, Rect, State);\r\nend;\r\n\r\nprocedure TJvxCheckListBox.CNDrawItem(var Msg: TWMDrawItem);\r\nbegin\r\n with Msg.DrawItemStruct^ do\r\n if not UseRightToLeftAlignment then\r\n rcItem.Left := rcItem.Left + GetCheckWidth\r\n else\r\n rcItem.Right := rcItem.Right - GetCheckWidth;\r\n\r\n inherited;\r\nend;\r\n\r\nprocedure TJvxCheckListBox.DrawCheck(R: TRect; AState: TCheckBoxState;\r\n Enabled: Boolean);\r\nconst\r\n CheckImages: array [TCheckBoxState, TCheckKind, Boolean] of Integer =\r\n (((3, 0), (9, 6), (15, 12)), { unchecked }\r\n ((4, 1), (10, 7), (16, 13)), { checked }\r\n ((5, 2), (11, 8), (17, 14))); { grayed }\r\nvar\r\n DrawRect: TRect;\r\n SaveColor: TColor;\r\n {$IFDEF JVCLThemesEnabled}\r\n Flags: Cardinal;\r\n {$ENDIF JVCLThemesEnabled}\r\nbegin\r\n if csDestroying in ComponentState then\r\n Exit;\r\n DrawRect.Left := R.Left + (R.Right - R.Left - FCheckWidth) div 2;\r\n DrawRect.Top := R.Top + (R.Bottom - R.Top - FCheckHeight) div 2;\r\n DrawRect.Right := DrawRect.Left + FCheckWidth;\r\n DrawRect.Bottom := DrawRect.Top + FCheckHeight;\r\n SaveColor := FCanvas.Brush.Color;\r\n {$IFDEF JVCLThemesEnabled}\r\n if ThemeServices.{$IFDEF RTL230_UP}Enabled{$ELSE}ThemesEnabled{$ENDIF RTL230_UP} and (CheckKind in [ckCheckBoxes, ckRadioButtons]) then\r\n begin\r\n Flags := 0;\r\n if not Enabled then\r\n Flags := Flags or DFCS_INACTIVE;\r\n if AState = cbChecked then\r\n Flags := Flags or DFCS_CHECKED\r\n else\r\n if AState = cbGrayed then\r\n Flags := Flags or DFCS_MONO;\r\n if CheckKind = ckCheckBoxes then\r\n DrawThemedFrameControl(Canvas.Handle, DrawRect, DFC_BUTTON,\r\n DFCS_BUTTONCHECK or Flags)\r\n else\r\n if CheckKind = ckRadioButtons then\r\n DrawThemedFrameControl(Canvas.Handle, DrawRect, DFC_BUTTON,\r\n DFCS_BUTTONRADIO or Flags);\r\n end\r\n else\r\n {$ENDIF JVCLThemesEnabled}\r\n begin\r\n AssignBitmapCell(CheckBitmap, FDrawBitmap, 6, 3,\r\n CheckImages[AState, CheckKind, Enabled]);\r\n FCanvas.Brush.Color := Self.Color;\r\n try\r\n FCanvas.BrushCopy(DrawRect, FDrawBitmap, Bounds(0, 0, FCheckWidth,\r\n FCheckHeight), CheckBitmap.TransparentColor and not PaletteMask);\r\n finally\r\n FCanvas.Brush.Color := SaveColor;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvxCheckListBox.ApplyState(AState: TCheckBoxState; EnabledOnly: Boolean);\r\nvar\r\n I: Integer;\r\nbegin\r\n if FCheckKind in [ckCheckBoxes, ckCheckMarks] then\r\n for I := 0 to Items.Count - 1 do\r\n if not EnabledOnly or EnabledItem[I] then\r\n State[I] := AState;\r\nend;\r\n\r\nfunction TJvxCheckListBox.GetCheckedIndex: Integer;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := -1;\r\n if FCheckKind = ckRadioButtons then\r\n for I := 0 to Items.Count - 1 do\r\n if State[I] = cbChecked then\r\n begin\r\n Result := I;\r\n Break;\r\n end;\r\nend;\r\n\r\nprocedure TJvxCheckListBox.SetCheckedIndex(Value: Integer);\r\nbegin\r\n if (FCheckKind = ckRadioButtons) and (Items.Count > 0) then\r\n SetState(Max(Value, 0), cbChecked);\r\nend;\r\n\r\nprocedure TJvxCheckListBox.UpdateCheckStates;\r\nbegin\r\n if (FCheckKind = ckRadioButtons) and (Items.Count > 0) then\r\n begin\r\n FInUpdateStates := True;\r\n try\r\n SetState(Max(GetCheckedIndex, 0), cbChecked);\r\n finally\r\n FInUpdateStates := False;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvxCheckListBox.SetCheckKind(Value: TCheckKind);\r\nbegin\r\n if FCheckKind <> Value then\r\n begin\r\n FCheckKind := Value;\r\n UpdateCheckStates;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvxCheckListBox.SetChecked(Index: Integer; AChecked: Boolean);\r\nconst\r\n CheckStates: array [Boolean] of TCheckBoxState = (cbUnchecked, cbChecked);\r\nbegin\r\n SetState(Index, CheckStates[AChecked]);\r\nend;\r\n\r\nprocedure TJvxCheckListBox.SetState(Index: Integer; AState: TCheckBoxState);\r\nvar\r\n I: Integer;\r\nbegin\r\n if (AState <> GetState(Index)) or FInUpdateStates then\r\n begin\r\n if (FCheckKind = ckRadioButtons) and (AState = cbUnchecked) and\r\n (GetCheckedIndex = Index) then\r\n Exit;\r\n TJvCheckListBoxItem(GetCheckObject(Index)).State := AState;\r\n if (FCheckKind = ckRadioButtons) and (AState = cbChecked) then\r\n for I := Items.Count - 1 downto 0 do\r\n begin\r\n if (I <> Index) and (GetState(I) = cbChecked) then\r\n begin\r\n TJvCheckListBoxItem(GetCheckObject(I)).State := cbUnchecked;\r\n InvalidateCheck(I);\r\n end;\r\n end;\r\n InvalidateCheck(Index);\r\n if not (csReading in ComponentState) then\r\n ChangeItemState(Index);\r\n end;\r\nend;\r\n\r\nprocedure TJvxCheckListBox.SetItemEnabled(Index: Integer; Value: Boolean);\r\nbegin\r\n if Value <> GetItemEnabled(Index) then\r\n begin\r\n TJvCheckListBoxItem(GetCheckObject(Index)).Enabled := Value;\r\n InvalidateItem(Index);\r\n end;\r\nend;\r\n\r\nprocedure TJvxCheckListBox.InvalidateCheck(Index: Integer);\r\nvar\r\n R: TRect;\r\nbegin\r\n R := ItemRect(Index);\r\n if not UseRightToLeftAlignment then\r\n R.Right := R.Left + GetCheckWidth\r\n else\r\n R.Left := R.Right - GetCheckWidth;\r\n InvalidateRect(Handle, @R, not (csOpaque in ControlStyle));\r\n UpdateWindow(Handle);\r\nend;\r\n\r\nprocedure TJvxCheckListBox.InvalidateItem(Index: Integer);\r\nvar\r\n R: TRect;\r\nbegin\r\n R := ItemRect(Index);\r\n InvalidateRect(Handle, @R, not (csOpaque in ControlStyle));\r\n UpdateWindow(Handle);\r\nend;\r\n\r\nfunction TJvxCheckListBox.GetChecked(Index: Integer): Boolean;\r\nbegin\r\n if IsCheckObject(Index) then\r\n Result := TJvCheckListBoxItem(GetCheckObject(Index)).GetChecked\r\n else\r\n Result := False;\r\nend;\r\n\r\nfunction TJvxCheckListBox.GetState(Index: Integer): TCheckBoxState;\r\nbegin\r\n if IsCheckObject(Index) then\r\n Result := TJvCheckListBoxItem(GetCheckObject(Index)).State\r\n else\r\n Result := clbDefaultState;\r\n if (FCheckKind = ckRadioButtons) and (Result <> cbChecked) then\r\n Result := cbUnchecked;\r\nend;\r\n\r\nfunction TJvxCheckListBox.GetItemEnabled(Index: Integer): Boolean;\r\nbegin\r\n if IsCheckObject(Index) then\r\n Result := TJvCheckListBoxItem(GetCheckObject(Index)).Enabled\r\n else\r\n Result := clbDefaultEnabled;\r\nend;\r\n\r\nprocedure TJvxCheckListBox.KeyPress(var Key: Char);\r\nbegin\r\n inherited KeyPress(Key);\r\n case Key of\r\n ' ':\r\n begin\r\n ToggleClickCheck(ItemIndex);\r\n Key := #0;\r\n end;\r\n '+':\r\n begin\r\n ApplyState(cbChecked, True);\r\n ClickCheck;\r\n end;\r\n '-':\r\n begin\r\n ApplyState(cbUnchecked, True);\r\n ClickCheck;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvxCheckListBox.MouseDown(Button: TMouseButton; Shift: TShiftState;\r\n X, Y: Integer);\r\nvar\r\n Index: Integer;\r\nbegin\r\n inherited MouseDown(Button, Shift, X, Y);\r\n if Button = mbLeft then\r\n begin\r\n Index := ItemAtPos(Point(X, Y), True);\r\n if Index <> -1 then\r\n begin\r\n if not UseRightToLeftAlignment then\r\n begin\r\n if X - ItemRect(Index).Left < GetCheckWidth then\r\n ToggleClickCheck(Index);\r\n end\r\n else\r\n begin\r\n Dec(X, ItemRect(Index).Right - GetCheckWidth);\r\n if (X > 0) and (X < GetCheckWidth) then\r\n ToggleClickCheck(Index);\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvxCheckListBox.ToggleClickCheck(Index: Integer);\r\nvar\r\n State: TCheckBoxState;\r\nbegin\r\n if (Index >= 0) and (Index < Items.Count) and EnabledItem[Index] then\r\n begin\r\n State := Self.State[Index];\r\n case State of\r\n cbUnchecked:\r\n if AllowGrayed then\r\n State := cbGrayed\r\n else\r\n State := cbChecked;\r\n cbChecked:\r\n State := cbUnchecked;\r\n cbGrayed:\r\n State := cbChecked;\r\n end;\r\n Self.State[Index] := State;\r\n ClickCheck;\r\n end;\r\nend;\r\n\r\nprocedure TJvxCheckListBox.ChangeItemState(Index: Integer);\r\nbegin\r\n if Assigned(FOnStateChange) then\r\n FOnStateChange(Self, Index);\r\nend;\r\n\r\nprocedure TJvxCheckListBox.ClickCheck;\r\nbegin\r\n if Assigned(FOnClickCheck) then\r\n FOnClickCheck(Self);\r\nend;\r\n\r\nfunction TJvxCheckListBox.GetItemData(Index: Integer): Longint;\r\nvar\r\n Item: TJvCheckListBoxItem;\r\nbegin\r\n Result := 0;\r\n if IsCheckObject(Index) then\r\n begin\r\n Item := TJvCheckListBoxItem(GetCheckObject(Index));\r\n if Item <> nil then\r\n Result := Item.FData;\r\n end;\r\nend;\r\n\r\nfunction TJvxCheckListBox.GetCheckObject(Index: Integer): TObject;\r\nbegin\r\n Result := FindCheckObject(Index);\r\n if Result = nil then\r\n Result := CreateCheckObject(Index);\r\nend;\r\n\r\nfunction TJvxCheckListBox.FindCheckObject(Index: Integer): TObject;\r\nvar\r\n ItemData: Longint;\r\nbegin\r\n Result := nil;\r\n ItemData := inherited GetItemData(Index);\r\n if ItemData = LB_ERR then\r\n ListIndexError(Index)\r\n else\r\n begin\r\n Result := TJvCheckListBoxItem(TObject(ItemData));\r\n if not (Result is TJvCheckListBoxItem) then\r\n Result := nil;\r\n end;\r\nend;\r\n\r\nfunction TJvxCheckListBox.CreateCheckObject(Index: Integer): TObject;\r\nbegin\r\n Result := TJvCheckListBoxItem.Create;\r\n inherited SetItemData(Index, LPARAM(Result));\r\nend;\r\n\r\nfunction TJvxCheckListBox.IsCheckObject(Index: Integer): Boolean;\r\nbegin\r\n Result := FindCheckObject(Index) <> nil;\r\nend;\r\n\r\nprocedure TJvxCheckListBox.SetItemData(Index: Integer; AData: Longint);\r\nvar\r\n Item: TJvCheckListBoxItem;\r\n L: Longint;\r\nbegin\r\n Item := TJvCheckListBoxItem(GetCheckObject(Index));\r\n Item.FData := AData;\r\n if (FSaveStates <> nil) and (FSaveStates.Count > 0) then\r\n begin\r\n L := Longint(FSaveStates[0]);\r\n Item.FState := TCheckBoxState(HiWord(L));\r\n Item.FEnabled := LoWord(L) <> 0;\r\n FSaveStates.Delete(0);\r\n end;\r\nend;\r\n\r\nprocedure TJvxCheckListBox.ResetContent;\r\nvar\r\n I: Integer;\r\nbegin\r\n for I := Items.Count - 1 downto 0 do\r\n begin\r\n if IsCheckObject(I) then\r\n GetCheckObject(I).Free;\r\n inherited SetItemData(I, 0);\r\n end;\r\n inherited ResetContent;\r\nend;\r\n\r\nprocedure TJvxCheckListBox.DeleteString(Index: Integer);\r\nbegin\r\n if IsCheckObject(Index) then\r\n GetCheckObject(Index).Free;\r\n inherited SetItemData(Index, 0);\r\n inherited DeleteString(Index);\r\nend;\r\n\r\ninitialization\r\n {$IFDEF UNITVERSIONING}\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n {$ENDIF UNITVERSIONING}\r\n\r\nfinalization\r\n FreeAndNil(GCheckBitmap);\r\n {$IFDEF UNITVERSIONING}\r\n UnregisterUnitVersion(HInstance);\r\n {$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/JvxSlider.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvxSlider.PAS, released on 2002-07-04.\r\n\r\nThe Initial Developers of the Original Code are: Fedor Koshevnikov, Igor Pavluk and Serge Korolev\r\nCopyright (c) 1997, 1998 Fedor Koshevnikov, Igor Pavluk and Serge Korolev\r\nCopyright (c) 2001,2002 SGB Software\r\nAll Rights Reserved.\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n// $Id: JvxSlider.pas 13104 2011-09-07 06:50:43Z obones $\r\n\r\nunit JvxSlider;\r\n\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF UNITVERSIONING}\r\n JclUnitVersioning,\r\n {$ENDIF UNITVERSIONING}\r\n SysUtils, Classes,\r\n Windows, Forms, Controls, ExtCtrls, Graphics, Messages, Menus,\r\n JvComponent, JvExControls;\r\n\r\ntype\r\n TNumThumbStates = 1..2;\r\n TSliderOrientation = (soHorizontal, soVertical);\r\n TSliderOption = (soShowFocus, soShowPoints, soSmooth,\r\n soRulerOpaque, soThumbOpaque);\r\n TSliderOptions = set of TSliderOption;\r\n TSliderImage = (siHThumb, siHRuler, siVThumb, siVRuler);\r\n TSliderImages = set of TSliderImage;\r\n TSliderImageArray = array [TSliderImage] of TBitmap;\r\n TJumpMode = (jmNone, jmHome, jmEnd, jmNext, jmPrior);\r\n\r\n TJvCustomSlider = class(TJvCustomControl)\r\n private\r\n FUserImages: TSliderImages;\r\n FImages: TSliderImageArray;\r\n FEdgeSize: Integer;\r\n FRuler: TBitmap;\r\n FPaintBuffered: Boolean;\r\n FRulerOrg: TPoint;\r\n FThumbRect: TRect;\r\n FThumbDown: Boolean;\r\n FNumThumbStates: TNumThumbStates;\r\n FPointsRect: TRect;\r\n FOrientation: TSliderOrientation;\r\n FOptions: TSliderOptions;\r\n FBevelStyle: TPanelBevel;\r\n FBevelWidth: Integer;\r\n FMinValue: Longint;\r\n FMaxValue: Longint;\r\n FIncrement: Longint;\r\n FValue: Longint;\r\n FHit: Integer;\r\n FFocused: Boolean;\r\n FSliding: Boolean;\r\n FTracking: Boolean;\r\n FTimerActive: Boolean;\r\n FMousePos: TPoint;\r\n FStartJump: TJumpMode;\r\n FReadOnly: Boolean;\r\n FOnChange: TNotifyEvent;\r\n FOnChanged: TNotifyEvent;\r\n FOnDrawPoints: TNotifyEvent;\r\n function GetImage(Index: Integer): TBitmap;\r\n procedure SetImage(Index: Integer; Value: TBitmap);\r\n procedure SliderImageChanged(Sender: TObject);\r\n procedure SetEdgeSize(Value: Integer);\r\n function GetNumThumbStates: TNumThumbStates;\r\n procedure SetNumThumbStates(Value: TNumThumbStates);\r\n procedure SetBevelStyle(Value: TPanelBevel);\r\n procedure SetOrientation(Value: TSliderOrientation);\r\n procedure SetOptions(Value: TSliderOptions);\r\n procedure SetMinValue(Value: Longint);\r\n procedure SetMaxValue(Value: Longint);\r\n procedure SetIncrement(Value: Longint);\r\n procedure SetReadOnly(Value: Boolean);\r\n function GetThumbOffset: Integer;\r\n procedure SetThumbOffset(Value: Integer);\r\n procedure SetValue(Value: Longint);\r\n procedure ThumbJump(Jump: TJumpMode);\r\n function GetThumbPosition(var Offset: Integer): TPoint;\r\n function JumpTo(X, Y: Integer): TJumpMode;\r\n procedure InvalidateThumb;\r\n procedure StopTracking;\r\n procedure TimerTrack;\r\n function StoreImage(Index: Integer): Boolean;\r\n procedure CreateElements;\r\n procedure BuildRuler(R: TRect);\r\n procedure AdjustElements;\r\n procedure ReadUserImages(Stream: TStream);\r\n procedure WriteUserImages(Stream: TStream);\r\n procedure InternalDrawPoints(ACanvas: TCanvas; PointsStep, PointsHeight,\r\n ExtremePointsHeight: Longint);\r\n procedure DrawThumb(Canvas: TCanvas; Origin: TPoint; Highlight: Boolean);\r\n function GetRulerLength: Integer;\r\n procedure WMPaint(var Msg: TWMPaint); message WM_PAINT;\r\n procedure WMSetCursor(var Msg: TWMSetCursor); message WM_SETCURSOR;\r\n procedure WMTimer(var Msg: TMessage); message WM_TIMER;\r\n protected\r\n procedure BoundsChanged; override;\r\n procedure FocusChanged(AControl: TWinControl); override;\r\n procedure GetDlgCode(var Code: TDlgCodes); override;\r\n procedure EnabledChanged; override;\r\n procedure AlignControls(AControl: TControl; var Rect: TRect); override;\r\n procedure DefineProperties(Filer: TFiler); override;\r\n procedure KeyDown(var Key: Word; Shift: TShiftState); override;\r\n procedure Loaded; override;\r\n procedure MouseDown(Button: TMouseButton; Shift: TShiftState;\r\n X, Y: Integer); override;\r\n procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;\r\n procedure MouseUp(Button: TMouseButton; Shift: TShiftState;\r\n X, Y: Integer); override;\r\n procedure Paint; override;\r\n function CanModify: Boolean; virtual;\r\n function GetSliderRect: TRect; virtual;\r\n function GetSliderValue: Longint; virtual;\r\n procedure Change; dynamic;\r\n procedure Changed; dynamic;\r\n procedure Sized; virtual;\r\n procedure RangeChanged; virtual;\r\n procedure SetRange(Min, Max: Longint);\r\n procedure ThumbMouseDown(Button: TMouseButton; Shift: TShiftState;\r\n X, Y: Integer); virtual;\r\n procedure ThumbMouseMove(Shift: TShiftState; X, Y: Integer); virtual;\r\n procedure ThumbMouseUp(Button: TMouseButton; Shift: TShiftState;\r\n X, Y: Integer); virtual;\r\n property ThumbOffset: Integer read GetThumbOffset write SetThumbOffset;\r\n property SliderRect: TRect read GetSliderRect;\r\n property BevelStyle: TPanelBevel read FBevelStyle write SetBevelStyle\r\n default bvNone;\r\n property ImageHThumb: TBitmap index Ord(siHThumb) read GetImage\r\n write SetImage stored StoreImage;\r\n property ImageHRuler: TBitmap index Ord(siHRuler) read GetImage\r\n write SetImage stored StoreImage;\r\n property ImageVThumb: TBitmap index Ord(siVThumb) read GetImage\r\n write SetImage stored StoreImage;\r\n property ImageVRuler: TBitmap index Ord(siVRuler) read GetImage\r\n write SetImage stored StoreImage;\r\n property NumThumbStates: TNumThumbStates read GetNumThumbStates\r\n write SetNumThumbStates default 2;\r\n property Orientation: TSliderOrientation read FOrientation\r\n write SetOrientation default soHorizontal;\r\n property EdgeSize: Integer read FEdgeSize write SetEdgeSize default 2;\r\n property Options: TSliderOptions read FOptions write SetOptions\r\n default [soShowFocus, soShowPoints, soSmooth];\r\n property ReadOnly: Boolean read FReadOnly write SetReadOnly default False;\r\n property OnChange: TNotifyEvent read FOnChange write FOnChange;\r\n property OnChanged: TNotifyEvent read FOnChanged write FOnChanged;\r\n property OnDrawPoints: TNotifyEvent read FOnDrawPoints write FOnDrawPoints;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n procedure DefaultDrawPoints(PointsStep, PointsHeight,\r\n ExtremePointsHeight: Longint); virtual;\r\n function GetValueByOffset(Offset: Integer): Longint;\r\n function GetOffsetByValue(Value: Longint): Integer;\r\n property Canvas;\r\n property RulerLength: Integer read GetRulerLength;\r\n property Increment: Longint read FIncrement write SetIncrement default 10;\r\n property MinValue: Longint read FMinValue write SetMinValue default 0;\r\n property MaxValue: Longint read FMaxValue write SetMaxValue default 100;\r\n property Value: Longint read FValue write SetValue default 0;\r\n end;\r\n\r\n {$IFDEF RTL230_UP}\r\n [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n {$ENDIF RTL230_UP}\r\n TJvxSlider = class(TJvCustomSlider)\r\n published\r\n property Align;\r\n property BevelStyle;\r\n property Color;\r\n property Cursor;\r\n property DragMode;\r\n property DragCursor;\r\n property Enabled;\r\n property ImageHThumb;\r\n property ImageHRuler;\r\n property ImageVThumb;\r\n property ImageVRuler;\r\n property Increment;\r\n property MinValue;\r\n property MaxValue;\r\n property NumThumbStates;\r\n property Orientation;\r\n { ensure Orientation is published before EdgeSize }\r\n property EdgeSize;\r\n property Options;\r\n property ParentColor;\r\n property ParentShowHint;\r\n property PopupMenu;\r\n property ShowHint;\r\n property TabOrder;\r\n property TabStop default True;\r\n property Value;\r\n property Visible;\r\n property Anchors;\r\n property Constraints;\r\n property DragKind;\r\n property OnChange;\r\n property OnChanged;\r\n property OnDrawPoints;\r\n property OnClick;\r\n property OnDblClick;\r\n property OnEnter;\r\n property OnExit;\r\n property OnMouseMove;\r\n property OnMouseDown;\r\n property OnMouseUp;\r\n property OnKeyDown;\r\n property OnKeyUp;\r\n property OnKeyPress;\r\n property OnDragOver;\r\n property OnDragDrop;\r\n property OnEndDrag;\r\n property OnStartDrag;\r\n property OnContextPopup;\r\n property OnMouseWheelDown;\r\n property OnMouseWheelUp;\r\n property OnEndDock;\r\n property OnStartDock;\r\n {$IFDEF JVCLThemesEnabled}\r\n property ParentBackground default True;\r\n {$ENDIF JVCLThemesEnabled}\r\n end;\r\n\r\n TJvSliderImages = class;\r\n\r\n TJvCustomTrackBar = class(TJvCustomSlider)\r\n private\r\n FImages: TJvSliderImages;\r\n protected\r\n property Images: TJvSliderImages read FImages write FImages;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n end;\r\n\r\n TJvSliderImages = class(TPersistent)\r\n private\r\n FSlider: TJvCustomSlider;\r\n function GetNumThumbStates: TNumThumbStates;\r\n procedure SetNumThumbStates(Value: TNumThumbStates);\r\n function GetEdgeSize: Integer;\r\n procedure SetEdgeSize(Value: Integer);\r\n function GetImage(Index: Integer): TBitmap;\r\n procedure SetImage(Index: Integer; Value: TBitmap);\r\n function StoreImage(Index: Integer): Boolean;\r\n published\r\n property HorzThumb: TBitmap index Ord(siHThumb) read GetImage\r\n write SetImage stored StoreImage;\r\n property HorzRuler: TBitmap index Ord(siHRuler) read GetImage\r\n write SetImage stored StoreImage;\r\n property VertThumb: TBitmap index Ord(siVThumb) read GetImage\r\n write SetImage stored StoreImage;\r\n property VertRuler: TBitmap index Ord(siVRuler) read GetImage\r\n write SetImage stored StoreImage;\r\n property NumThumbStates: TNumThumbStates read GetNumThumbStates\r\n write SetNumThumbStates default 2;\r\n property EdgeSize: Integer read GetEdgeSize write SetEdgeSize default 2;\r\n end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n UnitVersioning: TUnitVersionInfo = (\r\n RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/branches/JVCL3_47_PREPARATION/run/JvxSlider.pas $';\r\n Revision: '$Revision: 13104 $';\r\n Date: '$Date: 2011-09-07 08:50:43 +0200 (mer. 07 sept. 2011) $';\r\n LogPath: 'JVCL\\run'\r\n );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n Consts, Math,\r\n JvJVCLUtils, JvJCLUtils, JvConsts, JvTypes, JvThemes;\r\n\r\n{$R JvxSlider.res}\r\n\r\n//=== { TJvCustomSlider } ====================================================\r\n\r\nconst\r\n ImagesResNames: array [TSliderImage] of PChar =\r\n ('JvW95HTB', 'JvW95HRL', 'JvW95VTB', 'JvW95VRL');\r\n Indent = 6;\r\n JumpInterval = 400;\r\n\r\nconstructor TJvCustomSlider.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n ControlState := ControlState + [csCreating];\r\n ControlStyle := [csClickEvents, csCaptureMouse, csDoubleClicks, csOpaque]; // csAcceptsControls\r\n IncludeThemeStyle(Self, [csParentBackground]);\r\n Width := 150;\r\n Height := 40;\r\n FNumThumbStates := 2;\r\n FBevelWidth := 1;\r\n FOrientation := soHorizontal;\r\n FOptions := [soShowFocus, soShowPoints, soSmooth];\r\n FEdgeSize := 2;\r\n FMinValue := 0;\r\n FMaxValue := 100;\r\n FIncrement := 10;\r\n TabStop := True;\r\n CreateElements;\r\n ControlState := ControlState - [csCreating];\r\nend;\r\n\r\ndestructor TJvCustomSlider.Destroy;\r\nvar\r\n I: TSliderImage;\r\nbegin\r\n FOnChange := nil;\r\n FOnChanged := nil;\r\n FOnDrawPoints := nil;\r\n FRuler.Free;\r\n for I := Low(FImages) to High(FImages) do\r\n begin\r\n FImages[I].OnChange := nil;\r\n FImages[I].Free;\r\n end;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TJvCustomSlider.Loaded;\r\nvar\r\n I: TSliderImage;\r\nbegin\r\n inherited Loaded;\r\n for I := Low(FImages) to High(FImages) do\r\n if I in FUserImages then\r\n SetImage(Ord(I), FImages[I]);\r\nend;\r\n\r\nprocedure TJvCustomSlider.AlignControls(AControl: TControl; var Rect: TRect);\r\nvar\r\n BevelSize: Integer;\r\nbegin\r\n BevelSize := 0;\r\n if BevelStyle <> bvNone then\r\n Inc(BevelSize, FBevelWidth);\r\n InflateRect(Rect, -BevelSize, -BevelSize);\r\n inherited AlignControls(AControl, Rect);\r\nend;\r\n\r\n\r\nprocedure TJvCustomSlider.WMPaint(var Msg: TWMPaint);\r\nvar\r\n DC, MemDC: HDC;\r\n MemBitmap, OldBitmap: HBITMAP;\r\n PS: TPaintStruct;\r\nbegin\r\n if FPaintBuffered then\r\n inherited\r\n else\r\n begin\r\n Canvas.Lock;\r\n try\r\n MemDC := GetDC(HWND_DESKTOP);\r\n MemBitmap := CreateCompatibleBitmap(MemDC, ClientWidth, ClientHeight);\r\n ReleaseDC(HWND_DESKTOP, MemDC);\r\n MemDC := CreateScreenCompatibleDC;\r\n OldBitmap := SelectObject(MemDC, MemBitmap);\r\n try\r\n DC := Msg.DC;\r\n Perform(WM_ERASEBKGND, MemDC, MemDC);\r\n FPaintBuffered := True;\r\n Msg.DC := MemDC;\r\n try\r\n WMPaint(Msg);\r\n finally\r\n Msg.DC := DC;\r\n FPaintBuffered := False;\r\n end;\r\n if DC = 0 then\r\n DC := BeginPaint(Handle, PS);\r\n BitBlt(DC, 0, 0, ClientWidth, ClientHeight, MemDC, 0, 0, SRCCOPY);\r\n if Msg.DC = 0 then\r\n EndPaint(Handle, PS);\r\n finally\r\n SelectObject(MemDC, OldBitmap);\r\n DeleteDC(MemDC);\r\n DeleteObject(MemBitmap);\r\n end;\r\n finally\r\n Canvas.Unlock;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomSlider.WMSetCursor(var Msg: TWMSetCursor);\r\nvar\r\n P: TPoint;\r\nbegin\r\n GetCursorPos(P);\r\n if not (csDesigning in ComponentState) and\r\n PtInRect(FThumbRect, ScreenToClient(P)) then\r\n begin\r\n Windows.SetCursor(Screen.Cursors[crHand]);\r\n end\r\n else\r\n inherited;\r\nend;\r\n\r\nprocedure TJvCustomSlider.WMTimer(var Msg: TMessage);\r\nbegin\r\n TimerTrack;\r\nend;\r\n\r\n\r\nprocedure TJvCustomSlider.Paint;\r\nvar\r\n R: TRect;\r\n TopColor, BottomColor, TransColor: TColor;\r\n HighlightThumb: Boolean;\r\n P: TPoint;\r\n Offset: Integer;\r\nbegin\r\n if csPaintCopy in ControlState then\r\n begin\r\n Offset := GetOffsetByValue(GetSliderValue);\r\n P := GetThumbPosition(Offset);\r\n end\r\n else\r\n P := Point(FThumbRect.Left, FThumbRect.Top);\r\n R := GetClientRect;\r\n if BevelStyle <> bvNone then\r\n begin\r\n TopColor := clBtnHighlight;\r\n if BevelStyle = bvLowered then\r\n TopColor := clBtnShadow;\r\n BottomColor := clBtnShadow;\r\n if BevelStyle = bvLowered then\r\n BottomColor := clBtnHighlight;\r\n Frame3D(Canvas, R, TopColor, BottomColor, FBevelWidth);\r\n end;\r\n if csOpaque in ControlStyle then\r\n DrawThemedBackground(Self, Canvas, R, Self.Color);\r\n if FRuler.Width > 0 then\r\n begin\r\n if soRulerOpaque in Options then\r\n TransColor := clNone\r\n else\r\n TransColor := FRuler.TransparentColor;\r\n DrawBitmapTransparent(Canvas, FRulerOrg.X, FRulerOrg.Y, FRuler, TransColor);\r\n end;\r\n if (soShowFocus in Options) and FFocused and\r\n not (csDesigning in ComponentState) then\r\n begin\r\n R := SliderRect;\r\n InflateRect(R, -2, -2);\r\n Canvas.DrawFocusRect(R);\r\n end;\r\n if soShowPoints in Options then\r\n begin\r\n if Assigned(FOnDrawPoints) then\r\n FOnDrawPoints(Self)\r\n else\r\n InternalDrawPoints(Canvas, Increment, 3, 5);\r\n end;\r\n if csPaintCopy in ControlState then\r\n HighlightThumb := not Enabled\r\n else\r\n HighlightThumb := FThumbDown or not Enabled;\r\n DrawThumb(Canvas, P, HighlightThumb);\r\nend;\r\n\r\nfunction TJvCustomSlider.CanModify: Boolean;\r\nbegin\r\n Result := True;\r\nend;\r\n\r\nfunction TJvCustomSlider.GetSliderValue: Longint;\r\nbegin\r\n Result := FValue;\r\nend;\r\n\r\nfunction TJvCustomSlider.GetSliderRect: TRect;\r\nbegin\r\n Result := Bounds(0, 0, Width, Height);\r\n if BevelStyle <> bvNone then\r\n InflateRect(Result, -FBevelWidth, -FBevelWidth);\r\nend;\r\n\r\nprocedure TJvCustomSlider.DrawThumb(Canvas: TCanvas; Origin: TPoint;\r\n Highlight: Boolean);\r\nvar\r\n R: TRect;\r\n Image: TBitmap;\r\n TransColor: TColor;\r\nbegin\r\n if Orientation = soHorizontal then\r\n Image := ImageHThumb\r\n else\r\n Image := ImageVThumb;\r\n R := Rect(0, 0, Image.Width, Image.Height);\r\n if NumThumbStates = 2 then\r\n begin\r\n if Highlight then\r\n R.Left := (R.Right - R.Left) div 2\r\n else\r\n R.Right := (R.Right - R.Left) div 2;\r\n end;\r\n if soThumbOpaque in Options then\r\n TransColor := clNone\r\n else\r\n TransColor := Image.TransparentColor;\r\n DrawBitmapRectTransparent(Canvas, Origin.X, Origin.Y, R, Image, TransColor);\r\nend;\r\n\r\nprocedure TJvCustomSlider.InternalDrawPoints(ACanvas: TCanvas;\r\n PointsStep, PointsHeight, ExtremePointsHeight: Longint);\r\nconst\r\n MinInterval = 3;\r\nvar\r\n RulerLength: Integer;\r\n Interval, Scale, PointsCnt, I, Val: Longint;\r\n X, H, X1, X2, Y1, Y2: Integer;\r\n Range: Double;\r\nbegin\r\n RulerLength := GetRulerLength;\r\n ACanvas.Pen.Color := clWindowText;\r\n Scale := 0;\r\n Range := MaxValue - MinValue;\r\n repeat\r\n Inc(Scale);\r\n PointsCnt := Round(Range / (Scale * PointsStep)) + 1;\r\n if PointsCnt > 1 then\r\n Interval := RulerLength div (PointsCnt - 1)\r\n else\r\n Interval := RulerLength;\r\n until (Interval >= MinInterval + 1) or (Interval >= RulerLength);\r\n Val := MinValue;\r\n for I := 1 to PointsCnt do\r\n begin\r\n H := PointsHeight;\r\n if I = PointsCnt then\r\n Val := MaxValue;\r\n if (Val = MaxValue) or (Val = MinValue) then\r\n H := ExtremePointsHeight;\r\n X := GetOffsetByValue(Val);\r\n if Orientation = soHorizontal then\r\n begin\r\n X1 := X + (FImages[siHThumb].Width div NumThumbStates) div 2;\r\n Y1 := FPointsRect.Top;\r\n X2 := X1;\r\n Y2 := Y1 + H;\r\n end\r\n else\r\n begin\r\n X1 := FPointsRect.Left;\r\n Y1 := X + FImages[siVThumb].Height div 2;\r\n X2 := X1 + H;\r\n Y2 := Y1;\r\n end;\r\n with ACanvas do\r\n begin\r\n MoveTo(X1, Y1);\r\n LineTo(X2, Y2);\r\n end;\r\n Inc(Val, Scale * PointsStep);\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomSlider.DefaultDrawPoints(PointsStep, PointsHeight, ExtremePointsHeight: Longint);\r\nbegin\r\n InternalDrawPoints(Canvas, PointsStep, PointsHeight, ExtremePointsHeight);\r\nend;\r\n\r\nprocedure TJvCustomSlider.CreateElements;\r\nvar\r\n I: TSliderImage;\r\nbegin\r\n FRuler := TBitmap.Create;\r\n for I := Low(FImages) to High(FImages) do\r\n SetImage(Ord(I), nil);\r\n AdjustElements;\r\nend;\r\n\r\nprocedure TJvCustomSlider.BuildRuler(R: TRect);\r\nvar\r\n DstR, BmpR: TRect;\r\n I, L, B, N, C, Offs, Len, RulerWidth: Integer;\r\n TmpBmp: TBitmap;\r\n Index: TSliderImage;\r\nbegin\r\n TmpBmp := TBitmap.Create;\r\n try\r\n if Orientation = soHorizontal then\r\n Index := siHRuler\r\n else\r\n Index := siVRuler;\r\n if Orientation = soHorizontal then\r\n begin\r\n L := R.Right - R.Left - 2 * Indent;\r\n if L < 0 then\r\n L := 0;\r\n TmpBmp.Width := L;\r\n TmpBmp.Height := FImages[Index].Height;\r\n L := TmpBmp.Width - 2 * FEdgeSize;\r\n B := FImages[Index].Width - 2 * FEdgeSize;\r\n RulerWidth := FImages[Index].Width;\r\n end\r\n else\r\n begin\r\n TmpBmp.Width := FImages[Index].Width;\r\n TmpBmp.Height := R.Bottom - R.Top - 2 * Indent;\r\n L := TmpBmp.Height - 2 * FEdgeSize;\r\n B := FImages[Index].Height - 2 * FEdgeSize;\r\n RulerWidth := FImages[Index].Height;\r\n end;\r\n N := (L div B) + 1;\r\n C := L mod B;\r\n for I := 0 to N - 1 do\r\n begin\r\n if I = 0 then\r\n begin\r\n Offs := 0;\r\n Len := RulerWidth - FEdgeSize;\r\n end\r\n else\r\n begin\r\n Offs := FEdgeSize + I * B;\r\n if I = N - 1 then\r\n Len := C + FEdgeSize\r\n else\r\n Len := B;\r\n end;\r\n if Orientation = soHorizontal then\r\n DstR := Rect(Offs, 0, Offs + Len, TmpBmp.Height)\r\n else\r\n DstR := Rect(0, Offs, TmpBmp.Width, Offs + Len);\r\n if I = 0 then\r\n Offs := 0\r\n else\r\n if I = N - 1 then\r\n Offs := FEdgeSize + B - C\r\n else\r\n Offs := FEdgeSize;\r\n if Orientation = soHorizontal then\r\n BmpR := Rect(Offs, 0, Offs + DstR.Right - DstR.Left, TmpBmp.Height)\r\n else\r\n BmpR := Rect(0, Offs, TmpBmp.Width, Offs + DstR.Bottom - DstR.Top);\r\n TmpBmp.Canvas.CopyRect(DstR, FImages[Index].Canvas, BmpR);\r\n end;\r\n FRuler.Assign(TmpBmp);\r\n finally\r\n TmpBmp.Free;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomSlider.AdjustElements;\r\nvar\r\n SaveValue: Longint;\r\n R: TRect;\r\nbegin\r\n SaveValue := Value;\r\n R := SliderRect;\r\n BuildRuler(R);\r\n if Orientation = soHorizontal then\r\n begin\r\n if FImages[siHThumb].Height > FRuler.Height then\r\n begin\r\n FThumbRect := Bounds(R.Left + Indent, R.Top + Indent,\r\n FImages[siHThumb].Width div NumThumbStates, FImages[siHThumb].Height);\r\n FRulerOrg := Point(R.Left + Indent, R.Top + Indent +\r\n (FImages[siHThumb].Height - FRuler.Height) div 2);\r\n FPointsRect := Rect(FRulerOrg.X, R.Top + Indent +\r\n FImages[siHThumb].Height + 1,\r\n FRulerOrg.X + FRuler.Width, R.Bottom - R.Top - 1);\r\n end\r\n else\r\n begin\r\n FThumbRect := Bounds(R.Left + Indent, R.Top + Indent +\r\n (FRuler.Height - FImages[siHThumb].Height) div 2,\r\n FImages[siHThumb].Width div NumThumbStates, FImages[siHThumb].Height);\r\n FRulerOrg := Point(R.Left + Indent, R.Top + Indent);\r\n FPointsRect := Rect(FRulerOrg.X, R.Top + Indent + FRuler.Height + 1,\r\n FRulerOrg.X + FRuler.Width, R.Bottom - R.Top - 1);\r\n end;\r\n end\r\n else\r\n begin { soVertical }\r\n if FImages[siVThumb].Width div NumThumbStates > FRuler.Width then\r\n begin\r\n FThumbRect := Bounds(R.Left + Indent, R.Top + Indent,\r\n FImages[siVThumb].Width div NumThumbStates, FImages[siVThumb].Height);\r\n FRulerOrg := Point(R.Left + Indent + (FImages[siVThumb].Width div NumThumbStates -\r\n FRuler.Width) div 2, R.Top + Indent);\r\n FPointsRect := Rect(R.Left + Indent + FImages[siVThumb].Width div NumThumbStates + 1,\r\n FRulerOrg.Y, R.Right - R.Left - 1, FRulerOrg.Y + FRuler.Height);\r\n end\r\n else\r\n begin\r\n FThumbRect := Bounds(R.Left + Indent + (FRuler.Width -\r\n FImages[siVThumb].Width div NumThumbStates) div 2, R.Top + Indent,\r\n FImages[siVThumb].Width div NumThumbStates, FImages[siVThumb].Height);\r\n FRulerOrg := Point(R.Left + Indent, R.Top + Indent);\r\n FPointsRect := Rect(R.Left + Indent + FRuler.Width + 1, FRulerOrg.Y,\r\n R.Right - R.Left - 1, FRulerOrg.Y + FRuler.Height);\r\n end;\r\n end;\r\n Value := SaveValue;\r\n Invalidate;\r\nend;\r\n\r\nprocedure TJvCustomSlider.Sized;\r\nbegin\r\n AdjustElements;\r\nend;\r\n\r\nprocedure TJvCustomSlider.Change;\r\nbegin\r\n if Assigned(FOnChange) then\r\n FOnChange(Self);\r\nend;\r\n\r\nprocedure TJvCustomSlider.Changed;\r\nbegin\r\n if Assigned(FOnChanged) then\r\n FOnChanged(Self);\r\nend;\r\n\r\nprocedure TJvCustomSlider.RangeChanged;\r\nbegin\r\nend;\r\n\r\nprocedure TJvCustomSlider.DefineProperties(Filer: TFiler);\r\n\r\n function DoWrite: Boolean;\r\n begin\r\n if Assigned(Filer.Ancestor) then\r\n Result := FUserImages <> TJvCustomSlider(Filer.Ancestor).FUserImages\r\n else\r\n Result := FUserImages <> [];\r\n end;\r\n\r\nbegin\r\n if Filer is TReader then\r\n inherited DefineProperties(Filer);\r\n Filer.DefineBinaryProperty('UserImages', ReadUserImages, WriteUserImages, DoWrite);\r\nend;\r\n\r\nprocedure TJvCustomSlider.ReadUserImages(Stream: TStream);\r\nbegin\r\n Stream.ReadBuffer(FUserImages, SizeOf(FUserImages));\r\nend;\r\n\r\nprocedure TJvCustomSlider.WriteUserImages(Stream: TStream);\r\nbegin\r\n Stream.WriteBuffer(FUserImages, SizeOf(FUserImages));\r\nend;\r\n\r\nfunction TJvCustomSlider.StoreImage(Index: Integer): Boolean;\r\nbegin\r\n Result := TSliderImage(Index) in FUserImages;\r\nend;\r\n\r\nfunction TJvCustomSlider.GetImage(Index: Integer): TBitmap;\r\nbegin\r\n Result := FImages[TSliderImage(Index)];\r\nend;\r\n\r\nprocedure TJvCustomSlider.SliderImageChanged(Sender: TObject);\r\nbegin\r\n if not (csCreating in ControlState) then\r\n Sized;\r\nend;\r\n\r\nprocedure TJvCustomSlider.SetImage(Index: Integer; Value: TBitmap);\r\nvar\r\n Idx: TSliderImage;\r\nbegin\r\n Idx := TSliderImage(Index);\r\n if FImages[Idx] = nil then\r\n begin\r\n FImages[Idx] := TBitmap.Create;\r\n FImages[Idx].OnChange := SliderImageChanged;\r\n end;\r\n if Value = nil then\r\n begin\r\n FImages[Idx].Handle := LoadBitmap(HInstance, ImagesResNames[Idx]);\r\n Exclude(FUserImages, Idx);\r\n if not (csReading in ComponentState) then\r\n begin\r\n if Idx in [siHThumb, siVThumb] then\r\n Exclude(FOptions, soThumbOpaque)\r\n else\r\n Exclude(FOptions, soRulerOpaque);\r\n Invalidate;\r\n end;\r\n end\r\n else\r\n begin\r\n FImages[Idx].Assign(Value);\r\n Include(FUserImages, Idx);\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomSlider.SetEdgeSize(Value: Integer);\r\nvar\r\n MaxSize: Integer;\r\nbegin\r\n if Orientation = soHorizontal then\r\n MaxSize := FImages[siHRuler].Width\r\n else\r\n MaxSize := FImages[siVRuler].Height;\r\n if Value * 2 < MaxSize then\r\n if Value <> FEdgeSize then\r\n begin\r\n FEdgeSize := Value;\r\n Sized;\r\n end;\r\nend;\r\n\r\nfunction TJvCustomSlider.GetNumThumbStates: TNumThumbStates;\r\nbegin\r\n Result := FNumThumbStates;\r\nend;\r\n\r\nprocedure TJvCustomSlider.SetNumThumbStates(Value: TNumThumbStates);\r\nbegin\r\n if FNumThumbStates <> Value then\r\n begin\r\n FNumThumbStates := Value;\r\n AdjustElements;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomSlider.SetBevelStyle(Value: TPanelBevel);\r\nbegin\r\n if Value <> FBevelStyle then\r\n begin\r\n FBevelStyle := Value;\r\n Sized;\r\n Update;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomSlider.SetOrientation(Value: TSliderOrientation);\r\nbegin\r\n if Orientation <> Value then\r\n begin\r\n FOrientation := Value;\r\n Sized;\r\n if ComponentState * [csLoading, csUpdating] = [] then\r\n SetBounds(Left, Top, Height, Width);\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomSlider.SetOptions(Value: TSliderOptions);\r\nbegin\r\n if Value <> FOptions then\r\n begin\r\n FOptions := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomSlider.SetRange(Min, Max: Longint);\r\nbegin\r\n if (Min < Max) or (csReading in ComponentState) then\r\n begin\r\n FMinValue := Min;\r\n FMaxValue := Max;\r\n if not (csReading in ComponentState) then\r\n if Min + Increment > Max then\r\n FIncrement := Max - Min;\r\n if soShowPoints in Options then\r\n Invalidate;\r\n Self.Value := FValue;\r\n RangeChanged;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomSlider.SetMinValue(Value: Longint);\r\nbegin\r\n if FMinValue <> Value then\r\n SetRange(Value, MaxValue);\r\nend;\r\n\r\nprocedure TJvCustomSlider.SetMaxValue(Value: Longint);\r\nbegin\r\n if FMaxValue <> Value then\r\n SetRange(MinValue, Value);\r\nend;\r\n\r\nprocedure TJvCustomSlider.SetIncrement(Value: Longint);\r\nbegin\r\n if not (csReading in ComponentState) and\r\n ((Value > MaxValue - MinValue) or (Value < 1)) then\r\n raise EJVCLException.CreateResFmt(@SOutOfRange, [1, MaxValue - MinValue]);\r\n if (Value > 0) and (FIncrement <> Value) then\r\n begin\r\n FIncrement := Value;\r\n Self.Value := FValue;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nfunction TJvCustomSlider.GetValueByOffset(Offset: Integer): Longint;\r\nvar\r\n Range: Double;\r\n R: TRect;\r\nbegin\r\n R := SliderRect;\r\n if Orientation = soVertical then\r\n Offset := ClientHeight - Offset - FImages[siVThumb].Height;\r\n Range := MaxValue - MinValue;\r\n Result := Round((Offset - R.Left - Indent) * Range / GetRulerLength);\r\n if not (soSmooth in Options) then\r\n Result := Round(Result / Increment) * Increment;\r\n Result := Min(MinValue + Max(Result, 0), MaxValue);\r\nend;\r\n\r\nfunction TJvCustomSlider.GetOffsetByValue(Value: Longint): Integer;\r\nvar\r\n Range: Double;\r\n R: TRect;\r\n MinIndent: Integer;\r\nbegin\r\n R := SliderRect;\r\n Range := MaxValue - MinValue;\r\n if Orientation = soHorizontal then\r\n MinIndent := R.Left + Indent\r\n else\r\n MinIndent := R.Top + Indent;\r\n Result := Round((Value - MinValue) / Range * GetRulerLength) + MinIndent;\r\n if Orientation = soVertical then\r\n Result := R.Top + R.Bottom - Result - FImages[siVThumb].Height;\r\n Result := Max(Result, MinIndent);\r\nend;\r\n\r\nfunction TJvCustomSlider.GetThumbPosition(var Offset: Integer): TPoint;\r\nvar\r\n R: TRect;\r\n MinIndent: Integer;\r\nbegin\r\n R := SliderRect;\r\n if Orientation = soHorizontal then\r\n MinIndent := R.Left + Indent\r\n else\r\n MinIndent := R.Top + Indent;\r\n Offset :=\r\n Min(GetOffsetByValue(GetValueByOffset(Min(Max(Offset, MinIndent), MinIndent + GetRulerLength))),\r\n MinIndent + GetRulerLength);\r\n if Orientation = soHorizontal then\r\n begin\r\n Result.X := Offset;\r\n Result.Y := FThumbRect.Top;\r\n end\r\n else\r\n begin\r\n Result.Y := Offset;\r\n Result.X := FThumbRect.Left;\r\n end;\r\nend;\r\n\r\nfunction TJvCustomSlider.GetThumbOffset: Integer;\r\nbegin\r\n if Orientation = soHorizontal then\r\n Result := FThumbRect.Left\r\n else\r\n Result := FThumbRect.Top;\r\nend;\r\n\r\nprocedure TJvCustomSlider.InvalidateThumb;\r\nbegin\r\n if HandleAllocated then\r\n Windows.InvalidateRect(Handle, @FThumbRect, not (csOpaque in ControlStyle));\r\nend;\r\n\r\nprocedure TJvCustomSlider.SetThumbOffset(Value: Integer);\r\nvar\r\n ValueBefore: Longint;\r\n P: TPoint;\r\nbegin\r\n ValueBefore := FValue;\r\n P := GetThumbPosition(Value);\r\n InvalidateThumb;\r\n FThumbRect := Bounds(P.X, P.Y, RectWidth(FThumbRect), RectHeight(FThumbRect));\r\n InvalidateThumb;\r\n if FSliding then\r\n begin\r\n FValue := GetValueByOffset(Value);\r\n if ValueBefore <> FValue then\r\n Change;\r\n end;\r\nend;\r\n\r\nfunction TJvCustomSlider.GetRulerLength: Integer;\r\nbegin\r\n if Orientation = soHorizontal then\r\n begin\r\n Result := FRuler.Width;\r\n Dec(Result, FImages[siHThumb].Width div NumThumbStates);\r\n end\r\n else\r\n begin\r\n Result := FRuler.Height;\r\n Dec(Result, FImages[siVThumb].Height);\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomSlider.SetValue(Value: Longint);\r\nvar\r\n ValueChanged: Boolean;\r\nbegin\r\n if Value > MaxValue then\r\n Value := MaxValue;\r\n if Value < MinValue then\r\n Value := MinValue;\r\n ValueChanged := FValue <> Value;\r\n FValue := Value;\r\n ThumbOffset := GetOffsetByValue(Value);\r\n if ValueChanged then\r\n Change;\r\nend;\r\n\r\nprocedure TJvCustomSlider.SetReadOnly(Value: Boolean);\r\nbegin\r\n if FReadOnly <> Value then\r\n begin\r\n if Value then\r\n begin\r\n StopTracking;\r\n if FSliding then\r\n ThumbMouseUp(mbLeft, [], 0, 0);\r\n end;\r\n FReadOnly := Value;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomSlider.ThumbJump(Jump: TJumpMode);\r\nvar\r\n NewValue: Longint;\r\nbegin\r\n if Jump <> jmNone then\r\n begin\r\n case Jump of\r\n jmHome:\r\n NewValue := MinValue;\r\n jmPrior:\r\n NewValue := (Round(Value / Increment) * Increment) - Increment;\r\n jmNext:\r\n NewValue := (Round(Value / Increment) * Increment) + Increment;\r\n jmEnd:\r\n NewValue := MaxValue;\r\n else\r\n Exit;\r\n end;\r\n if NewValue >= MaxValue then\r\n NewValue := MaxValue\r\n else\r\n if NewValue <= MinValue then\r\n NewValue := MinValue;\r\n if NewValue <> Value then\r\n Value := NewValue;\r\n end;\r\nend;\r\n\r\nfunction TJvCustomSlider.JumpTo(X, Y: Integer): TJumpMode;\r\nbegin\r\n Result := jmNone;\r\n if Orientation = soHorizontal then\r\n begin\r\n if FThumbRect.Left > X then\r\n Result := jmPrior\r\n else\r\n if FThumbRect.Right < X then\r\n Result := jmNext;\r\n end\r\n else\r\n if Orientation = soVertical then\r\n begin\r\n if FThumbRect.Top > Y then\r\n Result := jmNext\r\n else\r\n if FThumbRect.Bottom < Y then\r\n Result := jmPrior;\r\n end;\r\nend;\r\n\r\n\r\nprocedure TJvCustomSlider.EnabledChanged;\r\nbegin\r\n inherited EnabledChanged;\r\n InvalidateThumb;\r\nend;\r\n\r\nprocedure TJvCustomSlider.FocusChanged(AControl: TWinControl);\r\nvar\r\n Active: Boolean;\r\nbegin\r\n Active := AControl = Self;\r\n if Active <> FFocused then\r\n begin\r\n FFocused := Active;\r\n if soShowFocus in Options then\r\n Invalidate;\r\n end;\r\n inherited FocusChanged(AControl);\r\nend;\r\n\r\nprocedure TJvCustomSlider.GetDlgCode(var Code: TDlgCodes);\r\nbegin\r\n Code := [dcWantArrows];\r\nend;\r\n\r\nprocedure TJvCustomSlider.BoundsChanged;\r\nbegin\r\n inherited BoundsChanged;\r\n if not (csReading in ComponentState) then\r\n Sized;\r\nend;\r\n\r\n\r\nprocedure TJvCustomSlider.StopTracking;\r\nbegin\r\n if FTracking then\r\n begin\r\n if FTimerActive then\r\n begin\r\n KillTimer(Handle, 1);\r\n FTimerActive := False;\r\n end;\r\n FTracking := False;\r\n MouseCapture := False;\r\n Changed;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomSlider.TimerTrack;\r\nvar\r\n Jump: TJumpMode;\r\nbegin\r\n Jump := JumpTo(FMousePos.X, FMousePos.Y);\r\n if Jump = FStartJump then\r\n begin\r\n ThumbJump(Jump);\r\n if not FTimerActive then\r\n begin\r\n SetTimer(Handle, 1, JumpInterval, nil);\r\n FTimerActive := True;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomSlider.MouseDown(Button: TMouseButton; Shift: TShiftState;\r\n X, Y: Integer);\r\nvar\r\n Rect: TRect;\r\n P: TPoint;\r\nbegin\r\n inherited MouseDown(Button, Shift, X, Y);\r\n if (Button = mbLeft) and not (ssDouble in Shift) then\r\n begin\r\n if CanFocus then\r\n SetFocus;\r\n P := Point(X, Y);\r\n if PtInRectInclusive(FThumbRect,P) then\r\n ThumbMouseDown(Button, Shift, X, Y)\r\n else\r\n begin\r\n with FRulerOrg, FRuler do\r\n Rect := Bounds(X, Y, Width, Height);\r\n InflateRect(Rect, Ord(Orientation = soVertical) * 3,\r\n Ord(Orientation = soHorizontal) * 3);\r\n if PtInRectInclusive(Rect, P) and CanModify and not ReadOnly then\r\n begin\r\n MouseCapture := True;\r\n FTracking := True;\r\n FMousePos := P;\r\n FStartJump := JumpTo(X, Y);\r\n TimerTrack;\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomSlider.MouseMove(Shift: TShiftState; X, Y: Integer);\r\nbegin\r\n if (csLButtonDown in ControlState) and FSliding then\r\n ThumbMouseMove(Shift, X, Y)\r\n else\r\n if FTracking then\r\n FMousePos := Point(X, Y);\r\n inherited MouseMove(Shift, X, Y);\r\nend;\r\n\r\nprocedure TJvCustomSlider.MouseUp(Button: TMouseButton; Shift: TShiftState;\r\n X, Y: Integer);\r\nbegin\r\n StopTracking;\r\n if FSliding then\r\n ThumbMouseUp(Button, Shift, X, Y);\r\n inherited MouseUp(Button, Shift, X, Y);\r\nend;\r\n\r\nprocedure TJvCustomSlider.KeyDown(var Key: Word; Shift: TShiftState);\r\nvar\r\n Jump: TJumpMode;\r\nbegin\r\n Jump := jmNone;\r\n if Shift = [] then\r\n begin\r\n if Key = VK_HOME then\r\n Jump := jmHome\r\n else\r\n if Key = VK_END then\r\n Jump := jmEnd;\r\n if Orientation = soHorizontal then\r\n begin\r\n if Key = VK_LEFT then\r\n Jump := jmPrior\r\n else\r\n if Key = VK_RIGHT then\r\n Jump := jmNext;\r\n end\r\n else\r\n begin\r\n if Key = VK_UP then\r\n Jump := jmNext\r\n else\r\n if Key = VK_DOWN then\r\n Jump := jmPrior;\r\n end;\r\n end;\r\n if (Jump <> jmNone) and CanModify and not ReadOnly then\r\n begin\r\n Key := 0;\r\n ThumbJump(Jump);\r\n Changed;\r\n end;\r\n inherited KeyDown(Key, Shift);\r\nend;\r\n\r\nprocedure TJvCustomSlider.ThumbMouseDown(Button: TMouseButton;\r\n Shift: TShiftState; X, Y: Integer);\r\nbegin\r\n if CanFocus then\r\n SetFocus;\r\n if (Button = mbLeft) and CanModify and not ReadOnly then\r\n begin\r\n FSliding := True;\r\n FThumbDown := True;\r\n if Orientation = soHorizontal then\r\n FHit := X - FThumbRect.Left\r\n else\r\n FHit := Y - FThumbRect.Top;\r\n InvalidateThumb;\r\n Update;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomSlider.ThumbMouseMove(Shift: TShiftState; X, Y: Integer);\r\nbegin\r\n if (csLButtonDown in ControlState) and CanModify and not ReadOnly then\r\n begin\r\n if Orientation = soHorizontal then\r\n ThumbOffset := X - FHit\r\n else\r\n ThumbOffset := Y - FHit;\r\n end;\r\nend;\r\n\r\nprocedure TJvCustomSlider.ThumbMouseUp(Button: TMouseButton;\r\n Shift: TShiftState; X, Y: Integer);\r\nbegin\r\n if Button = mbLeft then\r\n begin\r\n FSliding := False;\r\n FThumbDown := False;\r\n InvalidateThumb;\r\n Update;\r\n if CanModify and not ReadOnly then\r\n Changed;\r\n end;\r\nend;\r\n\r\n//=== { TJvCustomTrackBar } ==================================================\r\n\r\nconstructor TJvCustomTrackBar.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FImages := TJvSliderImages.Create;\r\n FImages.FSlider := Self;\r\nend;\r\n\r\ndestructor TJvCustomTrackBar.Destroy;\r\nbegin\r\n FImages.Free;\r\n inherited Destroy;\r\nend;\r\n\r\n//=== { TJvSliderImages } ====================================================\r\n\r\nfunction TJvSliderImages.GetImage(Index: Integer): TBitmap;\r\nbegin\r\n Result := FSlider.GetImage(Index);\r\nend;\r\n\r\nprocedure TJvSliderImages.SetImage(Index: Integer; Value: TBitmap);\r\nbegin\r\n FSlider.SetImage(Index, Value);\r\nend;\r\n\r\nfunction TJvSliderImages.StoreImage(Index: Integer): Boolean;\r\nbegin\r\n Result := FSlider.StoreImage(Index);\r\nend;\r\n\r\nfunction TJvSliderImages.GetNumThumbStates: TNumThumbStates;\r\nbegin\r\n Result := FSlider.NumThumbStates;\r\nend;\r\n\r\nprocedure TJvSliderImages.SetNumThumbStates(Value: TNumThumbStates);\r\nbegin\r\n FSlider.NumThumbStates := Value;\r\nend;\r\n\r\nfunction TJvSliderImages.GetEdgeSize: Integer;\r\nbegin\r\n Result := FSlider.EdgeSize;\r\nend;\r\n\r\nprocedure TJvSliderImages.SetEdgeSize(Value: Integer);\r\nbegin\r\n FSlider.EdgeSize := Value;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/ModuleLoader.pas", "content": "{******************************************************************}\r\n{ }\r\n{ Project JEDI }\r\n{ OS independent Dynamic Loading Helpers }\r\n{ }\r\n{ The initial developer of the this code is }\r\n{ Robert Marquardt INVALID_MODULEHANDLE_VALUE;\r\nend;\r\n\r\n// load the DLL file FileName\r\n// LoadLibraryEx is used to get better control of the loading\r\n// for the allowed values for flags see LoadLibraryEx documentation.\r\n\r\nfunction LoadModuleEx(var Module: TModuleHandle; FileName: string; Flags: Cardinal): Boolean;\r\nbegin\r\n if Module = INVALID_MODULEHANDLE_VALUE then\r\n Module := LoadLibraryEx(PChar(FileName), 0, Flags);\r\n Result := Module <> INVALID_MODULEHANDLE_VALUE;\r\nend;\r\n\r\n// unload a DLL loaded with LoadModule or LoadModuleEx\r\n// The procedure will not try to unload a handle with\r\n// value INVALID_MODULEHANDLE_VALUE and assigns this value\r\n// to Module after unload.\r\n\r\nprocedure UnloadModule(var Module: TModuleHandle);\r\nbegin\r\n if Module <> INVALID_MODULEHANDLE_VALUE then\r\n FreeLibrary(Module);\r\n Module := INVALID_MODULEHANDLE_VALUE;\r\nend;\r\n\r\n// returns the pointer to the symbol named SymbolName\r\n// if it is exported from the DLL Module\r\n// nil is returned if the symbol is not available\r\n\r\nfunction GetModuleSymbol(Module: TModuleHandle; SymbolName: string): Pointer;\r\nbegin\r\n Result := nil;\r\n if Module <> INVALID_MODULEHANDLE_VALUE then\r\n Result := GetProcAddress(Module, PChar(SymbolName));\r\nend;\r\n\r\n// returns the pointer to the symbol named SymbolName\r\n// if it is exported from the DLL Module\r\n// nil is returned if the symbol is not available.\r\n// as an extra the Boolean variable Accu is updated\r\n// by anding in the success of the function.\r\n// This is very handy for rendering a global result\r\n// when accessing a long list of symbols.\r\n\r\nfunction GetModuleSymbolEx(Module: TModuleHandle; SymbolName: string; var Accu: Boolean): Pointer;\r\nbegin\r\n Result := nil;\r\n if Module <> INVALID_MODULEHANDLE_VALUE then\r\n Result := GetProcAddress(Module, PChar(SymbolName));\r\n Accu := Accu and (Result <> nil);\r\nend;\r\n\r\n// get the value of variables exported from a DLL Module\r\n// Delphi cannot access variables in a DLL directly, so\r\n// this function allows to copy the data from the DLL.\r\n// Beware! You are accessing the DLL memory image directly.\r\n// Be sure to access a variable not a function and be sure\r\n// to read the correct amount of data.\r\n\r\nfunction ReadModuleData(Module: TModuleHandle; SymbolName: string; var Buffer; Size: Cardinal): Boolean;\r\nvar\r\n Sym: Pointer;\r\nbegin\r\n Result := True;\r\n Sym := GetModuleSymbolEx(Module, SymbolName, Result);\r\n if Result then\r\n Move(Sym^, Buffer, Size);\r\nend;\r\n\r\n// set the value of variables exported from a DLL Module\r\n// Delphi cannot access variables in a DLL directly, so\r\n// this function allows to copy the data to the DLL!\r\n// BEWARE! You are accessing the DLL memory image directly.\r\n// Be sure to access a variable not a function and be sure\r\n// to write the correct amount of data.\r\n// The changes are not persistent. They get lost when the\r\n// DLL is unloaded.\r\n\r\nfunction WriteModuleData(Module: TModuleHandle; SymbolName: string; var Buffer; Size: Cardinal): Boolean;\r\nvar\r\n Sym: Pointer;\r\nbegin\r\n Result := True;\r\n Sym := GetModuleSymbolEx(Module, SymbolName, Result);\r\n if Result then\r\n Move(Buffer, Sym^, Size);\r\nend;\r\n\r\n{$ENDIF MSWINDOWS}\r\n\r\n{$IFDEF UNIX}\r\n\r\nconst\r\n TYPE_E_ELEMENTNOTFOUND = $8002802B;\r\n\r\n// load the .so file FileName\r\n// the rules for FileName are those of dlopen()\r\n// Returns: True = success, False = failure to load\r\n// Assigns: the handle of the loaded .so to Module\r\n// Warning: if Module has any other value than INVALID_MODULEHANDLE_VALUE\r\n// on entry the function will do nothing but returning success.\r\n\r\nfunction LoadModule(var Module: TModuleHandle; FileName: string): Boolean;\r\nbegin\r\n if Module = INVALID_MODULEHANDLE_VALUE then\r\n Module := dlopen(PChar(FileName), RTLD_NOW);\r\n Result := Module <> INVALID_MODULEHANDLE_VALUE;\r\nend;\r\n\r\n// load the .so file FileName\r\n// dlopen() with flags is used to get better control of the loading\r\n// for the allowed values for flags see \"man dlopen\".\r\n\r\nfunction LoadModuleEx(var Module: TModuleHandle; FileName: string; Flags: Cardinal): Boolean;\r\nbegin\r\n if Module = INVALID_MODULEHANDLE_VALUE then\r\n Module := dlopen(PChar(FileName), Flags);\r\n Result := Module <> INVALID_MODULEHANDLE_VALUE;\r\nend;\r\n\r\n// unload a .so loaded with LoadModule or LoadModuleEx\r\n// The procedure will not try to unload a handle with\r\n// value INVALID_MODULEHANDLE_VALUE and assigns this value\r\n// to Module after unload.\r\n\r\nprocedure UnloadModule(var Module: TModuleHandle);\r\nbegin\r\n if Module <> INVALID_MODULEHANDLE_VALUE then\r\n dlclose(Module);\r\n Module := INVALID_MODULEHANDLE_VALUE;\r\nend;\r\n\r\n// returns the pointer to the symbol named SymbolName\r\n// if it is exported from the .so Module\r\n// nil is returned if the symbol is not available\r\n\r\nfunction GetModuleSymbol(Module: TModuleHandle; SymbolName: string): Pointer;\r\nbegin\r\n Result := nil;\r\n if Module <> INVALID_MODULEHANDLE_VALUE then\r\n Result := dlsym(Module, PChar(SymbolName));\r\nend;\r\n\r\n// returns the pointer to the symbol named SymbolName\r\n// if it is exported from the .so Module\r\n// nil is returned if the symbol is not available.\r\n// as an extra the Boolean variable Accu is updated\r\n// by anding in the success of the function.\r\n// This is very handy for rendering a global result\r\n// when accessing a long list of symbols.\r\n\r\nfunction GetModuleSymbolEx(Module: TModuleHandle; SymbolName: string; var Accu: Boolean): Pointer;\r\nbegin\r\n Result := nil;\r\n if Module <> INVALID_MODULEHANDLE_VALUE then\r\n Result := dlsym(Module, PChar(SymbolName));\r\n Accu := Accu and (Result <> nil);\r\nend;\r\n\r\n// get the value of variables exported from a .so Module\r\n// Delphi cannot access variables in a .so directly, so\r\n// this function allows to copy the data from the .so.\r\n// Beware! You are accessing the .so memory image directly.\r\n// Be sure to access a variable not a function and be sure\r\n// to read the correct amount of data.\r\n\r\nfunction ReadModuleData(Module: TModuleHandle; SymbolName: string; var Buffer; Size: Cardinal): Boolean;\r\nvar\r\n Sym: Pointer;\r\nbegin\r\n Result := True;\r\n Sym := GetModuleSymbolEx(Module, SymbolName, Result);\r\n if Result then\r\n Move(Sym^, Buffer, Size);\r\nend;\r\n\r\n// set the value of variables exported from a .so Module\r\n// Delphi cannot access variables in a .so directly, so\r\n// this function allows to copy the data to the .so!\r\n// BEWARE! You are accessing the .so memory image directly.\r\n// Be sure to access a variable not a function and be sure\r\n// to write the correct amount of data.\r\n// The changes are not persistent. They get lost when the\r\n// .so is unloaded.\r\n\r\nfunction WriteModuleData(Module: TModuleHandle; SymbolName: string; var Buffer; Size: Cardinal): Boolean;\r\nvar\r\n Sym: Pointer;\r\nbegin\r\n Result := True;\r\n Sym := GetModuleSymbolEx(Module, SymbolName, Result);\r\n if Result then\r\n Move(Buffer, Sym^, Size);\r\nend;\r\n\r\n{$ENDIF UNIX}\r\n\r\n//=== { TModuleLoader } ======================================================\r\n\r\nconstructor TModuleLoader.Create(const ADLLName: string; LoadMethods: TModuleLoadMethods = []);\r\nbegin\r\n inherited Create;\r\n FHandle := INVALID_MODULEHANDLE_VALUE;\r\n FDLLName := ADLLName;\r\n Load(LoadMethods);\r\nend;\r\n\r\ndestructor TModuleLoader.Destroy;\r\nbegin\r\n Unload;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TModuleLoader.Error(ErrorCode: Cardinal);\r\nbegin\r\n // overriden classes should handle this\r\nend;\r\n\r\nfunction TModuleLoader.GetExportedSymbol(const AName: string; var Buffer;\r\n Size: Integer): Boolean;\r\nvar\r\n ASymbol: Pointer;\r\nbegin\r\n Result := GetProcedure(AName, ASymbol);\r\n if Result then\r\n Move(ASymbol^, Buffer, Size);\r\nend;\r\n\r\nfunction TModuleLoader.GetLoaded: Boolean;\r\nbegin\r\n Result := Handle <> INVALID_MODULEHANDLE_VALUE;\r\nend;\r\n\r\nfunction TModuleLoader.GetProcedure(const AName: string; var AProc: Pointer): Boolean;\r\nbegin\r\n Result := Loaded;\r\n if Result and not Assigned(AProc) then\r\n begin\r\n AProc := GetModuleSymbol(Handle, AName);\r\n Result := Assigned(AProc);\r\n end;\r\n if not Result then\r\n begin\r\n AProc := nil;\r\n Error(DWORD(TYPE_E_ELEMENTNOTFOUND));\r\n end;\r\nend;\r\n\r\nclass function TModuleLoader.IsAvaliable(const ADLLName: string; const AProcName: string = ''): Boolean;\r\nvar\r\n Module: TModuleHandle;\r\n P: Pointer;\r\nbegin\r\n Result := LoadModule(Module, ADLLName);\r\n if Result then\r\n begin\r\n if AProcName <> '' then\r\n begin\r\n P := GetModuleSymbol(Module, AProcName);\r\n Result := Assigned(P);\r\n end;\r\n UnloadModule(Module);\r\n end;\r\nend;\r\n\r\nprocedure TModuleLoader.Load(LoadMethods: TModuleLoadMethods);\r\nconst\r\n cLoadMethods: array [TModuleLoadMethod] of DWORD =\r\n {$IFDEF MSWINDOWS}\r\n (DONT_RESOLVE_DLL_REFERENCES, LOAD_LIBRARY_AS_DATAFILE, LOAD_WITH_ALTERED_SEARCH_PATH);\r\n {$ENDIF MSWINDOWS}\r\n {$IFDEF UNIX}\r\n (RTLD_LAZY, RTLD_LAZY, RTLD_LAZY); // there is not really a equivalent under Linux\r\n {$ENDIF UNIX}\r\nvar\r\n Flags: DWORD;\r\n I: TModuleLoadMethod;\r\nbegin\r\n Flags := 0;\r\n for I := Low(TModuleLoadMethod) to High(TModuleLoadMethod) do\r\n if I in LoadMethods then\r\n Flags := Flags or cLoadMethods[I];\r\n if FHandle = INVALID_MODULEHANDLE_VALUE then\r\n LoadModuleEx(FHandle, DLLName, Flags);\r\n if FHandle = INVALID_MODULEHANDLE_VALUE then\r\n Error(GetLastError);\r\nend;\r\n\r\nfunction TModuleLoader.SetExportedSymbol(const AName: string; var Buffer;\r\n Size: Integer): Boolean;\r\nvar\r\n ASymbol: Pointer;\r\nbegin\r\n Result := GetProcedure(AName, ASymbol);\r\n if Result then\r\n Move(Buffer, ASymbol^, Size);\r\nend;\r\n\r\nprocedure TModuleLoader.Unload;\r\nbegin\r\n if FHandle <> INVALID_MODULEHANDLE_VALUE then\r\n UnloadModule(FHandle);\r\n FHandle := INVALID_MODULEHANDLE_VALUE;\r\nend;\r\n\r\nend.\r\n\r\n" }, { "path": "External/Jedi/Jvcl/run/ObjSel.pas", "content": "{******************************************************************************\r\n\r\n Object Picker API interface Unit for Object Pascal\r\n\r\n Portions created by Microsoft are Copyright (C) 1995-2001 Microsoft\r\n Corporation. All Rights Reserved.\r\n\r\n The original file is: objsel.h, released June 2000. The original Pascal\r\n code is: ObjSel.pas, released December 2000. The initial developer of the\r\n Pascal code is Marcel van Brakel (brakelm att chello dott nl).\r\n\r\n Portions created by Marcel van Brakel are Copyright (C) 1999-2001\r\n Marcel van Brakel. All Rights Reserved.\r\n\r\n Obtained through: Joint Endeavour of Delphi Innovators (Project JEDI)\r\n\r\n You may retrieve the latest version of this file at the Project JEDI home\r\n page, located at http://delphi-jedi.org or my personal homepage located at\r\n http://members.chello.nl/m.vanbrakel2\r\n\r\n The contents of this file are used with permission, subject to the Mozilla\r\n Public License Version 1.1 (the \"License\"); you may not use this file except\r\n in compliance with the License. You may obtain a copy of the License at\r\n http://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\n Software distributed under the License is distributed on an \"AS IS\" basis,\r\n WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for\r\n the specific language governing rights and limitations under the License.\r\n\r\n Alternatively, the contents of this file may be used under the terms of the\r\n GNU Lesser General Public License (the \"LGPL License\"), in which case the\r\n provisions of the LGPL License are applicable instead of those above.\r\n If you wish to allow use of your version of this file only under the terms\r\n of the LGPL License and not to allow others to use your version of this file\r\n under the MPL, indicate your decision by deleting the provisions above and\r\n replace them with the notice and other provisions required by the LGPL\r\n License. If you do not delete the provisions above, a recipient may use\r\n your version of this file under either the MPL or the LGPL License.\r\n\r\n For more information about the LGPL: http://www.gnu.org/copyleft/lesser.html\r\n\r\n******************************************************************************}\r\n\r\nunit ObjSel;\r\n\r\n{$I jvcl.inc}\r\n{$I windowsonly.inc}\r\n\r\n{$WEAKPACKAGEUNIT}\r\n\r\n{$HPPEMIT ''}\r\n{$HPPEMIT '#include \"ObjSel.h\"'}\r\n{$HPPEMIT ''}\r\n{$HPPEMIT 'typedef IDsObjectPicker* _di_IDsObjectPicker;'}\r\n\r\ninterface\r\n\r\nuses\r\n Windows, ActiveX;\r\n\r\nconst\r\n //'{17d6ccd8-3b7b-11d2-b9e0-00c04fd8dbf7}'\r\n CLSID_DsObjectPicker: TGUID = (\r\n D1: $17D6CCD8; D2: $3B7B; D3: $11D2; D4: ($B9, $E0, $00, $C0, $4F, $D8, $DB, $F7));\r\n {$EXTERNALSYM CLSID_DsObjectPicker}\r\n\r\n IID_IDsObjectPicker: TGUID = (\r\n D1: $0C87E64E; D2: $3B7A; D3: $11D2; D4: ($B9, $E0, $00, $C0, $4F, $D8, $DB, $F7));\r\n {$EXTERNALSYM IID_IDsObjectPicker}\r\n\r\n{\r\nCLIPBOARD FORMATS\r\n=================\r\n\r\nCFSTR_DSOP_DS_SELECTION_LIST\r\n Returns an HGLOBAL for global memory containing a DS_SELECTION_LIST\r\n variable length structure.\r\n}\r\n\r\nconst\r\n CFSTR_DSOP_DS_SELECTION_LIST = 'CFSTR_DSOP_DS_SELECTION_LIST';\r\n {$EXTERNALSYM CFSTR_DSOP_DS_SELECTION_LIST}\r\n\r\n{\r\nSCOPE TYPES\r\n===========\r\n\r\nA scope is an entry in the \"Look In\" dropdown list of the Object Picker\r\ndialog.\r\n\r\nWhen initializing the DS Object Picker, DSOP_SCOPE_TYPEs are used with\r\nDSOP_SCOPE_INIT_INFO.flType member to specify which types of scopes the\r\nDS Object Picker should put in the \"Look In\" list.\r\n\r\nDSOP_SCOPE_TYPE_TARGET_COMPUTER\r\n Computer specified by DSOP_INIT_INFO.pwzTargetComputer, NULL is\r\n local computer.\r\n\r\nDSOP_SCOPE_TYPE_UPLEVEL_JOINED_DOMAIN\r\n Uplevel domain to which target computer is joined.\r\n\r\nDSOP_SCOPE_TYPE_DOWNLEVEL_JOINED_DOMAIN\r\n Downlevel domain to which target computer is joined.\r\n\r\nDSOP_SCOPE_TYPE_ENTERPRISE_DOMAIN\r\n All domains in the enterprise to which the target computer belongs\r\n other than the JOINED_DOMAIN or USER_SPECIFIED_*_SCOPEs.\r\n\r\nDSOP_SCOPE_TYPE_GLOBAL_CATALOG\r\n The Entire Directory scope.\r\n\r\nDSOP_SCOPE_TYPE_EXTERNAL_UPLEVEL_DOMAIN\r\n All uplevel domains external to the enterprise but trusted by the\r\n domain to which the target computer is joined.\r\n\r\nDSOP_SCOPE_TYPE_EXTERNAL_DOWNLEVEL_DOMAIN\r\n All downlevel domains external to the enterprise but trusted by the\r\n domain to which the target computer is joined.\r\n\r\nDSOP_SCOPE_TYPE_WORKGROUP\r\n The workgroup of which TARGET_COMPUTER is a member. Applies only if the\r\n TARGET_COMPUTER is not joined to a domain.\r\n\r\nDSOP_SCOPE_TYPE_USER_ENTERED_UPLEVEL_SCOPE\r\nDSOP_SCOPE_TYPE_USER_ENTERED_DOWNLEVEL_SCOPE\r\n Any uplevel or downlevel scope generated by processing user input. If\r\n neither of these types is specified, user entries that do not refer to\r\n one of the scopes in the \"Look In\" control will be rejected.\r\n\r\n}\r\n\r\nconst\r\n DSOP_SCOPE_TYPE_TARGET_COMPUTER = $00000001;\r\n {$EXTERNALSYM DSOP_SCOPE_TYPE_TARGET_COMPUTER}\r\n DSOP_SCOPE_TYPE_UPLEVEL_JOINED_DOMAIN = $00000002;\r\n {$EXTERNALSYM DSOP_SCOPE_TYPE_UPLEVEL_JOINED_DOMAIN}\r\n DSOP_SCOPE_TYPE_DOWNLEVEL_JOINED_DOMAIN = $00000004;\r\n {$EXTERNALSYM DSOP_SCOPE_TYPE_DOWNLEVEL_JOINED_DOMAIN}\r\n DSOP_SCOPE_TYPE_ENTERPRISE_DOMAIN = $00000008;\r\n {$EXTERNALSYM DSOP_SCOPE_TYPE_ENTERPRISE_DOMAIN}\r\n DSOP_SCOPE_TYPE_GLOBAL_CATALOG = $00000010;\r\n {$EXTERNALSYM DSOP_SCOPE_TYPE_GLOBAL_CATALOG}\r\n DSOP_SCOPE_TYPE_EXTERNAL_UPLEVEL_DOMAIN = $00000020;\r\n {$EXTERNALSYM DSOP_SCOPE_TYPE_EXTERNAL_UPLEVEL_DOMAIN}\r\n DSOP_SCOPE_TYPE_EXTERNAL_DOWNLEVEL_DOMAIN = $00000040;\r\n {$EXTERNALSYM DSOP_SCOPE_TYPE_EXTERNAL_DOWNLEVEL_DOMAIN}\r\n DSOP_SCOPE_TYPE_WORKGROUP = $00000080;\r\n {$EXTERNALSYM DSOP_SCOPE_TYPE_WORKGROUP}\r\n DSOP_SCOPE_TYPE_USER_ENTERED_UPLEVEL_SCOPE = $00000100;\r\n {$EXTERNALSYM DSOP_SCOPE_TYPE_USER_ENTERED_UPLEVEL_SCOPE}\r\n DSOP_SCOPE_TYPE_USER_ENTERED_DOWNLEVEL_SCOPE = $00000200;\r\n {$EXTERNALSYM DSOP_SCOPE_TYPE_USER_ENTERED_DOWNLEVEL_SCOPE}\r\n\r\n{\r\nDSOP_SCOPE_INIT_INFO flags\r\n==========================\r\n\r\nThe flScope member can contain zero or more of the following flags:\r\n\r\nDSOP_SCOPE_FLAG_STARTING_SCOPE\r\n The scope should be the first one selected in the Look In control after\r\n dialog initialization. If more than one scope specifies this flag,\r\n the one which is chosen to be the starting scope is implementation\r\n dependant.\r\n\r\nDSOP_SCOPE_FLAG_WANT_PROVIDER_WINNT\r\n ADs paths for objects selected from this scope should be converted to use\r\n the WinNT provider.\r\n\r\nDSOP_SCOPE_FLAG_WANT_PROVIDER_LDAP\r\n ADs paths for objects selected from this scope should be converted to use\r\n the LDAP provider.\r\n\r\nDSOP_SCOPE_FLAG_WANT_PROVIDER_GC\r\n ADs paths for objects selected from this scope should be converted to use\r\n the GC provider.\r\n\r\nDSOP_SCOPE_FLAG_WANT_SID_PATH\r\n ADs paths for objects selected from this scope having an objectSid\r\n attribute should be converted to the form LDAP://, where x\r\n represents the hexidecimal digits of the objectSid attribute value.\r\n\r\nDSOP_SCOPE_FLAG_WANT_DOWNLEVEL_BUILTIN_PATH\r\n ADs paths for downlevel well-known SID objects (for example,\r\n DSOP_DOWNLEVEL_FILTER_INTERACTIVE) are an empty string unless this flag is\r\n specified. If it is, the paths will be of the form\r\n WinNT://NT AUTHORITY/Interactive or WinNT://Creator owner.\r\n\r\nDSOP_SCOPE_FLAG_DEFAULT_FILTER_USERS\r\n If the scope filter contains the DSOP_FILTER_USERS or\r\n DSOP_DOWNLEVEL_FILTER_USERS flag, then check the Users checkbox by\r\n default in the Look For dialog.\r\n\r\nDSOP_SCOPE_FLAG_DEFAULT_FILTER_GROUPS\r\n\r\nDSOP_SCOPE_FLAG_DEFAULT_FILTER_COMPUTERS\r\n\r\nDSOP_SCOPE_FLAG_DEFAULT_FILTER_CONTACTS\r\n}\r\n\r\nconst\r\n DSOP_SCOPE_FLAG_STARTING_SCOPE = $00000001;\r\n {$EXTERNALSYM DSOP_SCOPE_FLAG_STARTING_SCOPE}\r\n DSOP_SCOPE_FLAG_WANT_PROVIDER_WINNT = $00000002;\r\n {$EXTERNALSYM DSOP_SCOPE_FLAG_WANT_PROVIDER_WINNT}\r\n DSOP_SCOPE_FLAG_WANT_PROVIDER_LDAP = $00000004;\r\n {$EXTERNALSYM DSOP_SCOPE_FLAG_WANT_PROVIDER_LDAP}\r\n DSOP_SCOPE_FLAG_WANT_PROVIDER_GC = $00000008;\r\n {$EXTERNALSYM DSOP_SCOPE_FLAG_WANT_PROVIDER_GC}\r\n DSOP_SCOPE_FLAG_WANT_SID_PATH = $00000010;\r\n {$EXTERNALSYM DSOP_SCOPE_FLAG_WANT_SID_PATH}\r\n DSOP_SCOPE_FLAG_WANT_DOWNLEVEL_BUILTIN_PATH = $00000020;\r\n {$EXTERNALSYM DSOP_SCOPE_FLAG_WANT_DOWNLEVEL_BUILTIN_PATH}\r\n DSOP_SCOPE_FLAG_DEFAULT_FILTER_USERS = $00000040;\r\n {$EXTERNALSYM DSOP_SCOPE_FLAG_DEFAULT_FILTER_USERS}\r\n DSOP_SCOPE_FLAG_DEFAULT_FILTER_GROUPS = $00000080;\r\n {$EXTERNALSYM DSOP_SCOPE_FLAG_DEFAULT_FILTER_GROUPS}\r\n DSOP_SCOPE_FLAG_DEFAULT_FILTER_COMPUTERS = $00000100;\r\n {$EXTERNALSYM DSOP_SCOPE_FLAG_DEFAULT_FILTER_COMPUTERS}\r\n DSOP_SCOPE_FLAG_DEFAULT_FILTER_CONTACTS = $00000200;\r\n {$EXTERNALSYM DSOP_SCOPE_FLAG_DEFAULT_FILTER_CONTACTS}\r\n\r\n{\r\nThe flMixedModeOnly/flNativeModeOnly member of an uplevel scope can\r\ncontain one or more of the following flags (at least one must be specified):\r\n\r\nDSOP_FILTER_INCLUDE_ADVANCED_VIEW\r\n Include objects which have the attribute showInAdvancedViewOnly set to\r\n true.\r\n\r\nDSOP_FILTER_USERS\r\n Include user objects.\r\n\r\nDSOP_FILTER_BUILTIN_GROUPS\r\n Include group objects with a groupType value having the flag\r\n GROUP_TYPE_BUILTIN_LOCAL_GROUP.\r\n\r\nDSOP_FILTER_WELL_KNOWN_PRINCIPALS\r\n Include the contents of the WellKnown Security Principals container.\r\n\r\nDSOP_FILTER_UNIVERSAL_GROUPS_DL\r\n Include distribution list universal groups.\r\n\r\nDSOP_FILTER_UNIVERSAL_GROUPS_SE\r\n Include security enabled universal groups.\r\n\r\nDSOP_FILTER_GLOBAL_GROUPS_DL\r\n Include distribution list global groups.\r\n\r\nDSOP_FILTER_GLOBAL_GROUPS_SE\r\n Include security enabled global groups.\r\n\r\nDSOP_FILTER_DOMAIN_LOCAL_GROUPS_DL\r\n Include distribution list domain global groups.\r\n\r\nDSOP_FILTER_DOMAIN_LOCAL_GROUPS_SE\r\n Include security enabled domain local groups.\r\n\r\nDSOP_FILTER_CONTACTS\r\n Include contact objects.\r\n\r\nDSOP_FILTER_COMPUTERS\r\n Include computer objects.\r\n}\r\n\r\nconst\r\n DSOP_FILTER_INCLUDE_ADVANCED_VIEW = $00000001;\r\n {$EXTERNALSYM DSOP_FILTER_INCLUDE_ADVANCED_VIEW}\r\n DSOP_FILTER_USERS = $00000002;\r\n {$EXTERNALSYM DSOP_FILTER_USERS}\r\n DSOP_FILTER_BUILTIN_GROUPS = $00000004;\r\n {$EXTERNALSYM DSOP_FILTER_BUILTIN_GROUPS}\r\n DSOP_FILTER_WELL_KNOWN_PRINCIPALS = $00000008;\r\n {$EXTERNALSYM DSOP_FILTER_WELL_KNOWN_PRINCIPALS}\r\n DSOP_FILTER_UNIVERSAL_GROUPS_DL = $00000010;\r\n {$EXTERNALSYM DSOP_FILTER_UNIVERSAL_GROUPS_DL}\r\n DSOP_FILTER_UNIVERSAL_GROUPS_SE = $00000020;\r\n {$EXTERNALSYM DSOP_FILTER_UNIVERSAL_GROUPS_SE}\r\n DSOP_FILTER_GLOBAL_GROUPS_DL = $00000040;\r\n {$EXTERNALSYM DSOP_FILTER_GLOBAL_GROUPS_DL}\r\n DSOP_FILTER_GLOBAL_GROUPS_SE = $00000080;\r\n {$EXTERNALSYM DSOP_FILTER_GLOBAL_GROUPS_SE}\r\n DSOP_FILTER_DOMAIN_LOCAL_GROUPS_DL = $00000100;\r\n {$EXTERNALSYM DSOP_FILTER_DOMAIN_LOCAL_GROUPS_DL}\r\n DSOP_FILTER_DOMAIN_LOCAL_GROUPS_SE = $00000200;\r\n {$EXTERNALSYM DSOP_FILTER_DOMAIN_LOCAL_GROUPS_SE}\r\n DSOP_FILTER_CONTACTS = $00000400;\r\n {$EXTERNALSYM DSOP_FILTER_CONTACTS}\r\n DSOP_FILTER_COMPUTERS = $00000800;\r\n {$EXTERNALSYM DSOP_FILTER_COMPUTERS}\r\n\r\n{\r\nThe flFilter member of a downlevel scope can contain one or more of the\r\nfollowing flags:\r\n\r\nDSOP_DOWNLEVEL_FILTER_USERS\r\n Include user objects.\r\n\r\nDSOP_DOWNLEVEL_FILTER_LOCAL_GROUPS\r\n Include all local groups.\r\n\r\nDSOP_DOWNLEVEL_FILTER_GLOBAL_GROUPS\r\n Include all global groups.\r\n\r\nDSOP_DOWNLEVEL_FILTER_COMPUTERS\r\n Include computer objects\r\n\r\nDSOP_DOWNLEVEL_FILTER_WORLD\r\n Include builtin security principal World (Everyone).\r\n\r\nDSOP_DOWNLEVEL_FILTER_AUTHENTICATED_USER\r\n Include builtin security principal Authenticated User.\r\n\r\nDSOP_DOWNLEVEL_FILTER_ANONYMOUS\r\n Include builtin security principal Anonymous.\r\n\r\nDSOP_DOWNLEVEL_FILTER_BATCH\r\n Include builtin security principal Batch.\r\n\r\nDSOP_DOWNLEVEL_FILTER_CREATOR_OWNER\r\n Include builtin security principal Creator Owner.\r\n\r\nDSOP_DOWNLEVEL_FILTER_CREATOR_GROUP\r\n Include builtin security principal Creator Group.\r\n\r\nDSOP_DOWNLEVEL_FILTER_DIALUP\r\n Include builtin security principal Dialup.\r\n\r\nDSOP_DOWNLEVEL_FILTER_INTERACTIVE\r\n Include builtin security principal Interactive.\r\n\r\nDSOP_DOWNLEVEL_FILTER_NETWORK\r\n Include builtin security principal Network.\r\n\r\nDSOP_DOWNLEVEL_FILTER_SERVICE\r\n Include builtin security principal Service.\r\n\r\nDSOP_DOWNLEVEL_FILTER_SYSTEM\r\n Include builtin security principal System.\r\n\r\nDSOP_DOWNLEVEL_FILTER_EXCLUDE_BUILTIN_GROUPS\r\n Exclude local builtin groups returned by groups enumeration.\r\n\r\nDSOP_DOWNLEVEL_FILTER_TERMINAL_SERVER\r\n Include builtin security principal Terminal Server.\r\n\r\nDSOP_DOWNLEVEL_FILTER_LOCAL_SERVICE\r\n Include builtin security principal Local Service\r\n\r\nDSOP_DOWNLEVEL_FILTER_NETWORK_SERVICE\r\n Include builtin security principal Network Service\r\n\r\nDSOP_DOWNLEVEL_FILTER_ALL_WELLKNOWN_SIDS\r\n Include all builtin security principals.\r\n}\r\n\r\nconst\r\n DSOP_DOWNLEVEL_FILTER_USERS = DWORD($80000001);\r\n {$EXTERNALSYM DSOP_DOWNLEVEL_FILTER_USERS}\r\n DSOP_DOWNLEVEL_FILTER_LOCAL_GROUPS = DWORD($80000002);\r\n {$EXTERNALSYM DSOP_DOWNLEVEL_FILTER_LOCAL_GROUPS}\r\n DSOP_DOWNLEVEL_FILTER_GLOBAL_GROUPS = DWORD($80000004);\r\n {$EXTERNALSYM DSOP_DOWNLEVEL_FILTER_GLOBAL_GROUPS}\r\n DSOP_DOWNLEVEL_FILTER_COMPUTERS = DWORD($80000008);\r\n {$EXTERNALSYM DSOP_DOWNLEVEL_FILTER_COMPUTERS}\r\n DSOP_DOWNLEVEL_FILTER_WORLD = DWORD($80000010);\r\n {$EXTERNALSYM DSOP_DOWNLEVEL_FILTER_WORLD}\r\n DSOP_DOWNLEVEL_FILTER_AUTHENTICATED_USER = DWORD($80000020);\r\n {$EXTERNALSYM DSOP_DOWNLEVEL_FILTER_AUTHENTICATED_USER}\r\n DSOP_DOWNLEVEL_FILTER_ANONYMOUS = DWORD($80000040);\r\n {$EXTERNALSYM DSOP_DOWNLEVEL_FILTER_ANONYMOUS}\r\n DSOP_DOWNLEVEL_FILTER_BATCH = DWORD($80000080);\r\n {$EXTERNALSYM DSOP_DOWNLEVEL_FILTER_BATCH}\r\n DSOP_DOWNLEVEL_FILTER_CREATOR_OWNER = DWORD($80000100);\r\n {$EXTERNALSYM DSOP_DOWNLEVEL_FILTER_CREATOR_OWNER}\r\n DSOP_DOWNLEVEL_FILTER_CREATOR_GROUP = DWORD($80000200);\r\n {$EXTERNALSYM DSOP_DOWNLEVEL_FILTER_CREATOR_GROUP}\r\n DSOP_DOWNLEVEL_FILTER_DIALUP = DWORD($80000400);\r\n {$EXTERNALSYM DSOP_DOWNLEVEL_FILTER_DIALUP}\r\n DSOP_DOWNLEVEL_FILTER_INTERACTIVE = DWORD($80000800);\r\n {$EXTERNALSYM DSOP_DOWNLEVEL_FILTER_INTERACTIVE}\r\n DSOP_DOWNLEVEL_FILTER_NETWORK = DWORD($80001000);\r\n {$EXTERNALSYM DSOP_DOWNLEVEL_FILTER_NETWORK}\r\n DSOP_DOWNLEVEL_FILTER_SERVICE = DWORD($80002000);\r\n {$EXTERNALSYM DSOP_DOWNLEVEL_FILTER_SERVICE}\r\n DSOP_DOWNLEVEL_FILTER_SYSTEM = DWORD($80004000);\r\n {$EXTERNALSYM DSOP_DOWNLEVEL_FILTER_SYSTEM}\r\n DSOP_DOWNLEVEL_FILTER_EXCLUDE_BUILTIN_GROUPS = DWORD($80008000);\r\n {$EXTERNALSYM DSOP_DOWNLEVEL_FILTER_EXCLUDE_BUILTIN_GROUPS}\r\n DSOP_DOWNLEVEL_FILTER_TERMINAL_SERVER = DWORD($80010000);\r\n {$EXTERNALSYM DSOP_DOWNLEVEL_FILTER_TERMINAL_SERVER}\r\n DSOP_DOWNLEVEL_FILTER_ALL_WELLKNOWN_SIDS = DWORD($80020000);\r\n {$EXTERNALSYM DSOP_DOWNLEVEL_FILTER_ALL_WELLKNOWN_SIDS}\r\n DSOP_DOWNLEVEL_FILTER_LOCAL_SERVICE = DWORD($80040000);\r\n {$EXTERNALSYM DSOP_DOWNLEVEL_FILTER_LOCAL_SERVICE}\r\n DSOP_DOWNLEVEL_FILTER_NETWORK_SERVICE = DWORD($80080000);\r\n {$EXTERNALSYM DSOP_DOWNLEVEL_FILTER_NETWORK_SERVICE}\r\n DSOP_DOWNLEVEL_FILTER_REMOTE_LOGON = DWORD($80100000);\r\n {$EXTERNALSYM DSOP_DOWNLEVEL_FILTER_REMOTE_LOGON}\r\n\r\n{\r\nDSOP_UPLEVEL_FILTER_FLAGS\r\n=========================\r\n\r\nContains the DSOP_FILTER_* flags for use with a DSOP_SCOPE_INIT_INFO\r\nstructure when the scope is uplevel (DS-aware).\r\n\r\nflBothModes\r\n Flags to use for an uplevel scope, regardless of whether it is a\r\n mixed or native mode domain.\r\n\r\nflMixedModeOnly\r\n Flags to use when an uplevel domain is in mixed mode.\r\n\r\nflNativeModeOnly\r\n Flags to use when an uplevel domain is in native mode.\r\n\r\nDSOP_FILTER_FLAGS\r\n=================\r\n\r\nUplevel\r\n Contains flags to use for an uplevel scope.\r\n\r\nflDownlevel\r\n Flags to use for a downlevel scope.\r\n}\r\n\r\ntype\r\n _DSOP_UPLEVEL_FILTER_FLAGS = record\r\n flBothModes: ULONG;\r\n flMixedModeOnly: ULONG;\r\n flNativeModeOnly: ULONG;\r\n end;\r\n {$EXTERNALSYM _DSOP_UPLEVEL_FILTER_FLAGS}\r\n DSOP_UPLEVEL_FILTER_FLAGS = _DSOP_UPLEVEL_FILTER_FLAGS;\r\n {$EXTERNALSYM DSOP_UPLEVEL_FILTER_FLAGS}\r\n TDsOpUpLevelFilterFlags = DSOP_UPLEVEL_FILTER_FLAGS;\r\n PDsOpUpLevelFilterFlags = ^DSOP_UPLEVEL_FILTER_FLAGS;\r\n\r\n _DSOP_FILTER_FLAGS = record\r\n Uplevel: DSOP_UPLEVEL_FILTER_FLAGS;\r\n flDownlevel: ULONG;\r\n end;\r\n {$EXTERNALSYM _DSOP_FILTER_FLAGS}\r\n DSOP_FILTER_FLAGS = _DSOP_FILTER_FLAGS;\r\n {$EXTERNALSYM DSOP_FILTER_FLAGS}\r\n TDsOpFilterFlags = DSOP_FILTER_FLAGS;\r\n PDsOpFilterFlags = ^DSOP_FILTER_FLAGS;\r\n\r\n{\r\nDSOP_SCOPE_INIT_INFO\r\n====================\r\n\r\nEach DSOP_SCOPE_INIT_INFO structure in the array DSOP_INIT_INFO.aDsScopeInfos\r\ndescribes a single scope or a group of scopes with the same settings.\r\n\r\ncbSize\r\n Size, in bytes, of the entire structure.\r\n\r\nflType\r\n DSOP_SCOPE_TYPE_* flags. It is legal to combine multiple values via\r\n bitwise OR if all of the types of scopes combined in this way require\r\n the same settings.\r\n\r\nflScope\r\n DSOP_SCOPE_ * flags.\r\n\r\nFilterFlags\r\n DSOP_FILTER_* flags that indicate which types of objects should be\r\n presented to the user in this scope.\r\n\r\npwzDcName\r\n Name of the DC of a domain. This member is used only if the flType\r\n member contains the flag DSOP_SCOPE_TYPE_JOINED_DOMAIN. If that flag is\r\n not set, this member must be NULL.\r\n\r\npwzADsPath\r\n Currently not supported, must be NULL.\r\n\r\nhr\r\n Filled with S_OK if the scope represented by this structure could be\r\n created, or an error message indicating why it could not. If\r\n IDsObjectPicker::SetScopes returns a success code, this value will\r\n also be a success code.\r\n}\r\n\r\ntype\r\n PWSTR = PWideChar;\r\n {$EXTERNALSYM PWSTR}\r\n\r\n PDSOP_SCOPE_INIT_INFO = ^DSOP_SCOPE_INIT_INFO;\r\n {$EXTERNALSYM PDSOP_SCOPE_INIT_INFO}\r\n _DSOP_SCOPE_INIT_INFO = record\r\n cbSize: ULONG;\r\n flType: ULONG;\r\n flScope: ULONG;\r\n FilterFlags: DSOP_FILTER_FLAGS;\r\n pwzDcName: PWSTR; // OPTIONAL\r\n pwzADsPath: PWSTR; // OPTIONAL\r\n hr: HRESULT;\r\n end;\r\n {$EXTERNALSYM _DSOP_SCOPE_INIT_INFO}\r\n DSOP_SCOPE_INIT_INFO = _DSOP_SCOPE_INIT_INFO;\r\n {$EXTERNALSYM DSOP_SCOPE_INIT_INFO}\r\n PCDSOP_SCOPE_INIT_INFO = PDSOP_SCOPE_INIT_INFO;\r\n {$EXTERNALSYM PCDSOP_SCOPE_INIT_INFO}\r\n TDsOpScopeInitInfo = DSOP_SCOPE_INIT_INFO;\r\n PDsOpScopeInitInfo = PDSOP_SCOPE_INIT_INFO;\r\n\r\n{\r\nDSOP_INIT_INFO flags\r\n====================\r\n\r\nThe following flags may be set in DSOP_INIT_INFO.flOptions:\r\n\r\nDSOP_FLAG_MULTISELECT\r\n Allow multiple selections. If this flag is not set, the dialog will\r\n return zero or one objects.\r\n\r\nDSOP_FLAG_SKIP_TARGET_COMPUTER_DC_CHECK\r\n If this flag is NOT set, then the DSOP_SCOPE_TYPE_TARGET_COMPUTER flag\r\n will be ignored if the target computer is a DC. This flag has no effect\r\n unless DSOP_SCOPE_TYPE_TARGET_COMPUTER is specified.\r\n\r\n}\r\n\r\nconst\r\n DSOP_FLAG_MULTISELECT = $00000001;\r\n {$EXTERNALSYM DSOP_FLAG_MULTISELECT}\r\n DSOP_FLAG_SKIP_TARGET_COMPUTER_DC_CHECK = $00000002;\r\n {$EXTERNALSYM DSOP_FLAG_SKIP_TARGET_COMPUTER_DC_CHECK}\r\n\r\n{\r\nDSOP_INIT_INFO\r\n==============\r\n\r\nUsed to configure the DS Object Picker dialog.\r\n\r\ncbSize\r\n Size, in bytes, of entire structure.\r\n\r\npwzTargetComputer\r\n Sets the computer associated with DSOP_SCOPE_TARGET_COMPUTER, and\r\n which is used to determine the joined domain and enterprise.\r\n If this value is NULL, the target computer is the local machine.\r\n\r\ncDsScopeInfos\r\n Count of elements in aDsScopeInfos. Must be at least 1, since\r\n the object picker cannot operate without at least one scope.\r\n\r\naDsScopeInfos\r\n Array of scope initialization structures. Must be present and\r\n contain at least one element.\r\n\r\nflOptions\r\n Various DS Object Picker flags (DSOP_FLAG_MULTISELECT).\r\n\r\ncAttributesToFetch\r\n Count of elements in apwzAttributeNames. Can be 0.\r\n\r\napwzAttributeNames\r\n Array of names of attributes to fetch for each object. Ignored\r\n if cAttributesToFetch is 0.\r\n}\r\n\r\ntype\r\n LPLPWSTR = ^LPWSTR;\r\n\r\n PDSOP_INIT_INFO = ^DSOP_INIT_INFO;\r\n {$EXTERNALSYM PDSOP_INIT_INFO}\r\n _DSOP_INIT_INFO = record\r\n cbSize: ULONG;\r\n pwzTargetComputer: PWSTR;\r\n cDsScopeInfos: ULONG;\r\n aDsScopeInfos: PDSOP_SCOPE_INIT_INFO;\r\n flOptions: ULONG;\r\n cAttributesToFetch: ULONG;\r\n apwzAttributeNames: LPLPWSTR;\r\n end;\r\n {$EXTERNALSYM _DSOP_INIT_INFO}\r\n DSOP_INIT_INFO = _DSOP_INIT_INFO;\r\n {$EXTERNALSYM DSOP_INIT_INFO}\r\n PCDSOP_INIT_INFO = PDSOP_INIT_INFO;\r\n {$EXTERNALSYM PCDSOP_INIT_INFO}\r\n TDsOpInitInfo = DSOP_INIT_INFO;\r\n PDsOpInitInfo = PDSOP_INIT_INFO;\r\n\r\n{\r\nDS_SELECTION\r\n============\r\nDescribes an object selected by the user.\r\n\r\npwzName\r\n The object's RDN.\r\n\r\npwzADsPath\r\n The object's ADsPath.\r\n\r\npwzClass\r\n The object's class attribute value.\r\n\r\npwzUPN\r\n The object's userPrincipalName attribute value.\r\n\r\npvarFetchedAttributes\r\n An array of VARIANTs, one for each attribute fetched.\r\n\r\nflScopeType\r\n A single DSOP_SCOPE_TYPE_* flag describing the type of the scope\r\n from which this object was selected.\r\n\r\nDS_SELECTION_LIST\r\n=================\r\nAvailable as a clipboard format from the data object returned by\r\nIDsObjectPicker::InvokeDialog. Contains a list of objects that the user\r\nselected.\r\n\r\ncItems\r\n Number of elements in the aDsSelection array.\r\n\r\ncFetchedAttributes\r\n Number of elements in each DSSELECTION.avarFetchedAttributes member.\r\n\r\naDsSelection\r\n Array of cItems DSSELECTION structures.\r\n}\r\n\r\nconst\r\n ANYSIZE_ARRAY = 1;\r\n {$EXTERNALSYM ANYSIZE_ARRAY}\r\n\r\ntype\r\n PDS_SELECTION = ^DS_SELECTION;\r\n {$EXTERNALSYM PDS_SELECTION}\r\n _DS_SELECTION = record\r\n pwzName: PWSTR;\r\n pwzADsPath: PWSTR;\r\n pwzClass: PWSTR;\r\n pwzUPN: PWSTR;\r\n pvarFetchedAttributes: POleVariant;\r\n flScopeType: ULONG;\r\n end;\r\n {$EXTERNALSYM _DS_SELECTION}\r\n DS_SELECTION = _DS_SELECTION;\r\n {$EXTERNALSYM DS_SELECTION}\r\n TDsSelection = DS_SELECTION;\r\n PDsSelection = PDS_SELECTION;\r\n\r\n PDS_SELECTION_LIST = ^DS_SELECTION_LIST;\r\n {$EXTERNALSYM PDS_SELECTION_LIST}\r\n _DS_SELECTION_LIST = record\r\n cItems: ULONG;\r\n cFetchedAttributes: ULONG;\r\n aDsSelection: array [0..ANYSIZE_ARRAY - 1] of DS_SELECTION;\r\n end;\r\n {$EXTERNALSYM _DS_SELECTION_LIST}\r\n DS_SELECTION_LIST = _DS_SELECTION_LIST;\r\n {$EXTERNALSYM DS_SELECTION_LIST}\r\n TDsSelectionList = DS_SELECTION_LIST;\r\n PDsSelectionList = PDS_SELECTION_LIST;\r\n\r\n//\r\n// Object Picker Interfaces\r\n//\r\n\r\n//\r\n// The main interface to the DS Object Picker, used to initialize it,\r\n// invoke the dialog, and return the user's selections.\r\n//\r\n\r\ntype\r\n IDsObjectPicker = interface(IUnknown)\r\n ['{0c87e64e-3b7a-11d2-b9e0-00c04fd8dbf7}']\r\n // Sets scope, filter, etc. for use with next invocation of dialog\r\n function Initialize(const pInitInfo: PDSOP_INIT_INFO): HRESULT; stdcall;\r\n // Creates the modal DS Object Picker dialog.\r\n function InvokeDialog(hwndParent: HWND; out ppdoSelections: IDataObject): HRESULT; stdcall;\r\n end;\r\n {$EXTERNALSYM IDsObjectPicker}\r\n\r\nimplementation\r\n\r\nend.\r\n\r\n" }, { "path": "External/Jedi/Jvcl/run/Ras32.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvHRas32.PAS, released on 2001-02-28.\r\n\r\nThe Initial Developer of the Original Code is Sbastien Buysse [sbuysse att buypin dott com]\r\nPortions created by Sbastien Buysse are Copyright (C) 2001 Sbastien Buysse.\r\nAll Rights Reserved.\r\n\r\nContributor(s): Michael Beck [mbeck att bigfoot dott com].\r\n\r\nLast Modified: 2000-02-28\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n\r\nunit Ras32;\r\n\r\n{$I jvcl.inc}\r\n\r\n{*******************************************************}\r\n{ This unit is an interface to the RAS (RASAPI32) }\r\n{ imported functions : All w95/98 functions }\r\n{*******************************************************}\r\n\r\n// (rom) cleaned. but should be replaced by RAS conversion\r\n\r\ninterface\r\n\r\nuses\r\n Windows;\r\n\r\n{$HPPEMIT '#include \"ras.h\"'}\r\n\r\nconst\r\n UNLEN = 256;\r\n {$EXTERNALSYM UNLEN}\r\n PWLEN = 256;\r\n {$EXTERNALSYM PWLEN}\r\n DNLEN = 15;\r\n {$EXTERNALSYM DNLEN}\r\n RAS_MaxEntryName = 256;\r\n {$EXTERNALSYM RAS_MaxEntryName}\r\n RAS_MaxDeviceName = 128;\r\n {$EXTERNALSYM RAS_MaxDeviceName}\r\n RAS_MaxDeviceType = 16;\r\n {$EXTERNALSYM RAS_MaxDeviceType}\r\n RAS_MaxParamKey = 32;\r\n {$EXTERNALSYM RAS_MaxParamKey}\r\n RAS_MaxParamValue = 128;\r\n {$EXTERNALSYM RAS_MaxParamValue}\r\n RAS_MaxPhoneNumber = 128;\r\n {$EXTERNALSYM RAS_MaxPhoneNumber}\r\n RAS_MaxCallbackNumber = RAS_MaxPhoneNumber;\r\n {$EXTERNALSYM RAS_MaxCallbackNumber}\r\n\r\ntype\r\n UINT = Word;\r\n {$EXTERNALSYM UINT}\r\n PHRASConn = ^HRASConn;\r\n HRASConn = DWORD;\r\n {$EXTERNALSYM HRASConn}\r\n\r\nconst\r\n RASDialEvent = 'RASDialEvent';\r\n WM_RASDialEvent = $0CCCD;\r\n RASCS_Paused = $1000;\r\n RASCS_Done = $2000;\r\n RASBase = 600;\r\n Success = 0;\r\n PENDING = (RASBase + 0);\r\n ERROR_INVALID_PORT_HANDLE = (RASBase + 1);\r\n ERROR_PORT_ALREADY_OPEN = (RASBase + 2);\r\n ERROR_BUFFER_TOO_SMALL = (RASBase + 3);\r\n ERROR_WRONG_INFO_SPECIFIED = (RASBase + 4);\r\n ERROR_CANNOT_SET_PORT_INFO = (RASBase + 5);\r\n ERROR_PORT_NOT_ConnECTED = (RASBase + 6);\r\n ERROR_EVENT_INVALID = (RASBase + 7);\r\n ERROR_DEVICE_DOES_NOT_EXIST = (RASBase + 8);\r\n ERROR_DEVICETYPE_DOES_NOT_EXIST = (RASBase + 9);\r\n ERROR_INVALID_BUFFER = (RASBase + 10);\r\n ERROR_ROUTE_NOT_AVAILABLE = (RASBase + 11);\r\n ERROR_ROUTE_NOT_ALLOCATED = (RASBase + 12);\r\n ERROR_INVALID_COMPRESSION_SPECIFIED = (RASBase + 13);\r\n ERROR_OUT_OF_BUFFERS = (RASBase + 14);\r\n ERROR_PORT_NOT_FOUND = (RASBase + 15);\r\n ERROR_ASYNC_REQUEST_PENDING = (RASBase + 16);\r\n ERROR_ALREADY_DISConnECTING = (RASBase + 17);\r\n ERROR_PORT_NOT_OPEN = (RASBase + 18);\r\n ERROR_PORT_DISConnECTED = (RASBase + 19);\r\n ERROR_NO_ENDPOINTS = (RASBase + 20);\r\n ERROR_CANNOT_OPEN_PHONEBOOK = (RASBase + 21);\r\n ERROR_CANNOT_LOAD_PHONEBOOK = (RASBase + 22);\r\n ERROR_CANNOT_FIND_PHONEBOOK_ENTRY = (RASBase + 23);\r\n ERROR_CANNOT_WRITE_PHONEBOOK = (RASBase + 24);\r\n ERROR_CORRUPT_PHONEBOOK = (RASBase + 25);\r\n ERROR_CANNOT_LOAD_string = (RASBase + 26);\r\n ERROR_KEY_NOT_FOUND = (RASBase + 27);\r\n ERROR_DISConnECTION = (RASBase + 28);\r\n ERROR_REMOTE_DISConnECTION = (RASBase + 29);\r\n ERROR_HARDWARE_FAILURE = (RASBase + 30);\r\n ERROR_USER_DISConnECTION = (RASBase + 31);\r\n ERROR_INVALID_SIZE = (RASBase + 32);\r\n ERROR_PORT_NOT_AVAILABLE = (RASBase + 33);\r\n ERROR_CANNOT_PROJECT_CLIENT = (RASBase + 34);\r\n ERROR_UNKNOWN = (RASBase + 35);\r\n ERROR_WRONG_DEVICE_ATTACHED = (RASBase + 36);\r\n ERROR_BAD_string = (RASBase + 37);\r\n ERROR_REQUEST_TIMEOUT = (RASBase + 38);\r\n ERROR_CANNOT_GET_LANA = (RASBase + 39);\r\n ERROR_NETBIOS_ERROR = (RASBase + 40);\r\n ERROR_SERVER_OUT_OF_RESOURCES = (RASBase + 41);\r\n ERROR_NAME_EXISTS_ON_NET = (RASBase + 42);\r\n ERROR_SERVER_GENERAL_NET_FAILURE = (RASBase + 43);\r\n WARNING_MSG_ALIAS_NOT_ADDED = (RASBase + 44);\r\n ERROR_AUTH_INTERNAL = (RASBase + 45);\r\n ERROR_RESTRICTED_LOGON_HOURS = (RASBase + 46);\r\n ERROR_ACCT_DISABLED = (RASBase + 47);\r\n ERROR_PASSWD_EXPIRED = (RASBase + 48);\r\n ERROR_NO_DIALIN_PERMISSION = (RASBase + 49);\r\n ERROR_SERVER_NOT_RESPONDING = (RASBase + 50);\r\n ERROR_FROM_DEVICE = (RASBase + 51);\r\n ERROR_UNRECOGNIZED_RESPONSE = (RASBase + 52);\r\n ERROR_MACRO_NOT_FOUND = (RASBase + 53);\r\n ERROR_MACRO_NOT_DEFINED = (RASBase + 54);\r\n ERROR_MESSAGE_MACRO_NOT_FOUND = (RASBase + 55);\r\n ERROR_DEFAULTOFF_MACRO_NOT_FOUND = (RASBase + 56);\r\n ERROR_FILE_COULD_NOT_BE_OPENED = (RASBase + 57);\r\n ERROR_DEVICENAME_TOO_LONG = (RASBase + 58);\r\n ERROR_DEVICENAME_NOT_FOUND = (RASBase + 59);\r\n ERROR_NO_RESPONSES = (RASBase + 60);\r\n ERROR_NO_COMMAND_FOUND = (RASBase + 61);\r\n ERROR_WRONG_KEY_SPECIFIED = (RASBase + 62);\r\n ERROR_UNKNOWN_DEVICE_TYPE = (RASBase + 63);\r\n ERROR_ALLOCATING_MEMORY = (RASBase + 64);\r\n ERROR_PORT_NOT_CONFIGURED = (RASBase + 65);\r\n ERROR_DEVICE_NOT_READY = (RASBase + 66);\r\n ERROR_READING_INI_FILE = (RASBase + 67);\r\n ERROR_NO_ConnECTION = (RASBase + 68);\r\n ERROR_BAD_USAGE_IN_INI_FILE = (RASBase + 69);\r\n ERROR_READING_SECTIONNAME = (RASBase + 70);\r\n ERROR_READING_DEVICETYPE = (RASBase + 71);\r\n ERROR_READING_DEVICENAME = (RASBase + 72);\r\n ERROR_READING_USAGE = (RASBase + 73);\r\n ERROR_READING_MAXConnECTBPS = (RASBase + 74);\r\n ERROR_READING_MAXCARRIERBPS = (RASBase + 75);\r\n ERROR_LINE_BUSY = (RASBase + 76);\r\n ERROR_VOICE_ANSWER = (RASBase + 77);\r\n ERROR_NO_ANSWER = (RASBase + 78);\r\n ERROR_NO_CARRIER = (RASBase + 79);\r\n ERROR_NO_DIALTONE = (RASBase + 80);\r\n ERROR_IN_COMMAND = (RASBase + 81);\r\n ERROR_WRITING_SECTIONNAME = (RASBase + 82);\r\n ERROR_WRITING_DEVICETYPE = (RASBase + 83);\r\n ERROR_WRITING_DEVICENAME = (RASBase + 84);\r\n ERROR_WRITING_MAXConnECTBPS = (RASBase + 85);\r\n ERROR_WRITING_MAXCARRIERBPS = (RASBase + 86);\r\n ERROR_WRITING_USAGE = (RASBase + 87);\r\n ERROR_WRITING_DEFAULTOFF = (RASBase + 88);\r\n ERROR_READING_DEFAULTOFF = (RASBase + 89);\r\n ERROR_EMPTY_INI_FILE = (RASBase + 90);\r\n ERROR_AUTHENTICATION_FAILURE = (RASBase + 91);\r\n ERROR_PORT_OR_DEVICE = (RASBase + 92);\r\n ERROR_NOT_BINARY_MACRO = (RASBase + 93);\r\n ERROR_DCB_NOT_FOUND = (RASBase + 94);\r\n ERROR_STATE_MACHINES_NOT_STARTED = (RASBase + 95);\r\n ERROR_STATE_MACHINES_ALREADY_STARTED = (RASBase + 96);\r\n ERROR_PARTIAL_RESPONSE_LOOPING = (RASBase + 97);\r\n ERROR_UNKNOWN_RESPONSE_KEY = (RASBase + 98);\r\n ERROR_RECV_BUF_FULL = (RASBase + 99);\r\n ERROR_CMD_TOO_LONG = (RASBase + 100);\r\n ERROR_UNSUPPORTED_BPS = (RASBase + 101);\r\n ERROR_UNEXPECTED_RESPONSE = (RASBase + 102);\r\n ERROR_INTERACTIVE_MODE = (RASBase + 103);\r\n ERROR_BAD_CALLBACK_NUMBER = (RASBase + 104);\r\n ERROR_INVALID_AUTH_STATE = (RASBase + 105);\r\n ERROR_WRITING_INITBPS = (RASBase + 106);\r\n ERROR_INVALID_WIN_HANDLE = (RASBase + 107);\r\n ERROR_NO_PASSWORD = (RASBase + 108);\r\n ERROR_NO_USERNAME = (RASBase + 109);\r\n ERROR_CANNOT_START_STATE_MACHINE = (RASBase + 110);\r\n ERROR_GETTING_COMMSTATE = (RASBase + 111);\r\n ERROR_SETTING_COMMSTATE = (RASBase + 112);\r\n ERROR_COMM_function = (RASBase + 113);\r\n ERROR_CONFIGURATION_PROBLEM = (RASBase + 114);\r\n ERROR_X25_DIAGNOSTIC = (RASBase + 115);\r\n ERROR_TOO_MANY_LINE_ERRORS = (RASBase + 116);\r\n ERROR_OVERRUN = (RASBase + 117);\r\n ERROR_ACCT_EXPIRED = (RASBase + 118);\r\n ERROR_CHANGING_PASSWORD = (RASBase + 119);\r\n ERROR_NO_ACTIVE_ISDN_LINES = (RASBase + 120);\r\n ERROR_NO_ISDN_CHANNELS_AVAILABLE = (RASBase + 121);\r\n\r\nconst\r\n RASCS_OpenPort = 0;\r\n RASCS_PortOpened = 1;\r\n RASCS_ConnectDevice = 2;\r\n RASCS_DeviceConnected = 3;\r\n RASCS_AllDevicesConnected = 4;\r\n RASCS_Authenticate = 5;\r\n RASCS_AuthNotify = 6;\r\n RASCS_AuthRetry = 7;\r\n RASCS_AuthCallback = 8;\r\n RASCS_AuthChangePassword = 9;\r\n RASCS_AuthProject = 10;\r\n RASCS_AuthLinkSpeed = 11;\r\n RASCS_AuthAck = 12;\r\n RASCS_ReAuthenticate = 13;\r\n RASCS_Authenticated = 14;\r\n RASCS_PrepareForCallback = 15;\r\n RASCS_WaiTFormodemReset = 16;\r\n RASCS_WaitForCallback = 17;\r\n\r\n RASCS_Interactive = RASCS_Paused;\r\n RASCS_RetryAuthentication = RASCS_Paused + 1;\r\n RASCS_CallbackSetByCaller = RASCS_Paused + 2;\r\n RASCS_PasswordExpired = RASCS_Paused + 3;\r\n\r\n RASCS_Connected = RASCS_Done;\r\n RASCS_DisConnected = RASCS_Done + 1;\r\n\r\ntype\r\n PRASConn = ^TRASConn;\r\n TRASConn = record\r\n dwSize: DWORD;\r\n rasConn: HRASConn;\r\n szEntryName: array [0..RAS_MaxEntryName] of Char;\r\n szDeviceType: array [0..RAS_MaxDeviceType] of Char;\r\n szDeviceName: array [0..RAS_MaxDeviceName] of Char;\r\n {$IFDEF NT_EXTNS}\r\n szPhonebook: array [0..MAX_PATH - 1] of Char;\r\n dwSubEntry: Longint;\r\n {$ENDIF NT_EXTNS}\r\n end;\r\n\r\n PRASConnStatus = ^TRASConnStatus;\r\n TRASConnStatus = record\r\n dwSize: Longint;\r\n rasConnstate: Word;\r\n dwError: Longint;\r\n szDeviceType: array [0..RAS_MaxDeviceType] of Char;\r\n szDeviceName: array [0..RAS_MaxDeviceName] of Char;\r\n end;\r\n\r\n PRASDIALEXTENSIONS = ^TRASDIALEXTENSIONS;\r\n TRASDIALEXTENSIONS = record\r\n dwSize: DWORD;\r\n dwfOptions: DWORD;\r\n hwndParent: HWND;\r\n reserved: DWORD;\r\n end;\r\n\r\n PRASDialParams = ^TRASDialParams;\r\n TRASDialParams = record\r\n dwSize: DWORD;\r\n szEntryName: array [0..RAS_MaxEntryName] of Char;\r\n szPhoneNumber: array [0..RAS_MaxPhoneNumber] of Char;\r\n szCallbackNumber: array [0..RAS_MaxCallbackNumber] of Char;\r\n szUserName: array [0..UNLEN] of Char;\r\n szPassword: array [0..PWLEN] of Char;\r\n szDomain: array [0..DNLEN] of Char;\r\n end;\r\n\r\n PRASEntryName = ^TRASEntryName;\r\n TRASEntryName = record\r\n dwSize: Longint;\r\n szEntryName: array [0..RAS_MaxEntryName] of Char;\r\n end;\r\n\r\n TRasDial = function(\r\n lpRasDialExtensions: PRASDIALEXTENSIONS; // Pointer to function extensions data\r\n lpszPhonebook: PChar; // Pointer to full path and FileName of phonebook file\r\n lpRasDialParams: PRASDIALPARAMS; // Pointer to calling parameters data\r\n dwNotifierType: DWORD; // specifies type of RasDial event handler\r\n lpvNotifier: DWORD; // specifies a handler for RasDial events\r\n var rasConn: HRASConn // Pointer to variable to receive connection Handle\r\n ): DWORD; stdcall;\r\n\r\n TRasEnumConnections = function(\r\n RASConn: PrasConn; // buffer to receive Connections data\r\n var BufSize: DWORD; // Size in bytes of buffer\r\n var Connections: DWORD // number of Connections written to buffer\r\n ): Longint; stdcall;\r\n\r\n TRasEnumEntries = function(\r\n reserved: PChar; // reserved, must be NULL\r\n lpszPhonebook: PChar; // Pointer to full path and FileName of phonebook file\r\n lprasentryname: PRASENTRYNAME; // buffer to receive phonebook entries\r\n var lpcb: DWORD; // Size in bytes of buffer\r\n var lpcEntries: DWORD // number of entries written to buffer\r\n ): DWORD; stdcall;\r\n\r\n TRasGetConnectStatus = function(\r\n RASConn: hrasConn; // Handle to Remote Access Connection of interest\r\n RASConnStatus: PRASConnStatus // buffer to receive status data\r\n ): Longint; stdcall;\r\n\r\n TRasGetErrorstring = function(\r\n ErrorCode: DWORD; // error code to get string for\r\n szErrorstring: PChar; // buffer to hold error string\r\n BufSize: DWORD // SizeOf buffer\r\n ): Longint; stdcall;\r\n\r\n TRasHangUp = function(\r\n RASConn: hrasConn // Handle to the Remote Access Connection to hang up }\r\n ): Longint; stdcall;\r\n\r\n TRasGetEntryDialParams = function(\r\n lpszPhonebook: PChar; // Pointer to the full path and FileName of the phonebook file\r\n var lprasdialparams: TRASDIALPARAMS; // Pointer to a structure that receives the connection parameters\r\n var lpfPassword: BOOL // indicates whether the user's password was retrieved\r\n ): DWORD; stdcall;\r\n\r\n TRasValidateEntryName = function(\r\n lpszPhonebook: PChar; // Pointer to full path and FileName of phone-book file\r\n lpszEntry: PChar // Pointer to the entry name to validate\r\n ): DWORD; stdcall;\r\n\r\n TRasCreatePhonebookEntry = function(\r\n Handle: HWND; // Handle to the Parent window of the dialog box\r\n lpszPhonebook: PChar // Pointer to the full path and FileName of the phone-book file\r\n ): DWORD; stdcall;\r\n\r\n TRasEditPhonebookEntry = function(\r\n Handle: HWND; // Handle to the Parent window of the dialog box\r\n lpszPhonebook: PChar; // Pointer to the full path and FileName of the phone-book file\r\n lpszEntryName: PChar // Pointer to the phone-book entry name\r\n ): DWORD; stdcall;\r\n\r\nimplementation\r\n\r\nend." }, { "path": "External/Jedi/Jvcl/run/VFW.pas", "content": "unit VFW;\r\n\r\ninterface\r\n\r\n(****************************************************************************\r\n *\r\n * VfW.H - Video for windows include file for WIN32\r\n *\r\n * Copyright (c) 1991-1999, Microsoft Corp. All rights reserved.\r\n *\r\n * This include files defines interfaces to the following\r\n * video components\r\n *\r\n * COMPMAN - Installable Compression Manager.\r\n * DRAWDIB - Routines for drawing to the display.\r\n * VIDEO - Video Capture Driver Interface\r\n *\r\n * AVIFMT - AVI File Format structure definitions.\r\n * MMREG - FOURCC and other things\r\n *\r\n * AVIFile - Interface for reading AVI Files and AVI Streams\r\n * MCIWND - MCI/AVI window class\r\n * AVICAP - AVI Capture Window class\r\n *\r\n * MSACM - Audio compression manager.\r\n *\r\n * The following symbols control inclusion of various parts of this file:\r\n *\r\n * NOCOMPMAN - dont include COMPMAN\r\n * NODRAWDIB - dont include DRAWDIB\r\n * NOVIDEO - dont include video capture interface\r\n *\r\n * NOAVIFMT - dont include AVI file format structs\r\n * NOMMREG - dont include MMREG\r\n *\r\n * NOAVIFILE - dont include AVIFile interface\r\n * NOMCIWND - dont include AVIWnd class.\r\n * NOAVICAP - dont include AVICap class.\r\n *\r\n * NOMSACM - dont include ACM stuff.\r\n *\r\n ****************************************************************************)\r\n\r\n(******************************************************************************)\r\n(* *)\r\n(* VFW.PAS Conversion by Ronald Dittrich *)\r\n(* *)\r\n(* E-Mail: info att swiftsoft dott de *)\r\n(* http://www.swiftsoft.de *)\r\n(* *)\r\n(******************************************************************************)\r\n\r\n(******************************************************************************)\r\n(* *)\r\n(* Modyfied: 25.April.2000 *)\r\n(* *)\r\n(* E-Mail: *)\r\n(* Ivo Steinmann: isteinmann att bluewin dott ch *)\r\n(* *)\r\n(* Please send all messages regarding specific errors and lacks of this unit *)\r\n(* to Ivo Steinmann *)\r\n(* *)\r\n(******************************************************************************)\r\n\r\nuses\r\n Windows, MMSystem, Messages, CommDlg, ActiveX, Dialogs;\r\n\r\n(****************************************************************************\r\n *\r\n * types\r\n *\r\n ***************************************************************************)\r\n\r\ntype\r\n PVOID = Pointer;\r\n {$EXTERNALSYM PVOID}\r\n LONG = Longint;\r\n {$EXTERNALSYM LONG}\r\n PLONG = ^LONG;\r\n {$EXTERNALSYM PLONG}\r\n int = Integer;\r\n {$EXTERNALSYM int}\r\n\r\n(****************************************************************************\r\n *\r\n * VideoForWindowsVersion() - returns version of VfW\r\n *\r\n ***************************************************************************)\r\n\r\nfunction VideoForWindowsVersion: DWORD; pascal;\r\n\r\n(****************************************************************************\r\n *\r\n * call these to start stop using VfW from your app.\r\n *\r\n ***************************************************************************)\r\n {\r\nfunction InitVFW: LONG; stdcall;\r\nfunction TermVFW: LONG; stdcall; }\r\n\r\n(****************************************************************************/\r\n/* */\r\n/* Macros */\r\n/* */\r\n/* should we define this?? */\r\n/* */\r\n/****************************************************************************)\r\n\r\nfunction MKFOURCC(ch0, ch1, ch2, ch3: Char): FOURCC;\r\n\r\n(****************************************************************************\r\n *\r\n * COMPMAN - Installable Compression Manager.\r\n *\r\n ****************************************************************************)\r\n\r\nconst\r\n ICVERSION = $0104 ;\r\n\r\ntype\r\n HIC = THandle; // Handle to an Installable Compressor\r\n\r\n//\r\n// this code in biCompression means the DIB must be accesed via\r\n// 48 bit pointers! using *ONLY* the selector given.\r\n//\r\nconst\r\n BI_1632 = $32333631; // '1632'\r\n\r\nfunction mmioFOURCC(ch0, ch1, ch2, ch3: Char): FOURCC;\r\n{$EXTERNALSYM mmioFOURCC}\r\n\r\ntype\r\n TWOCC = word;\r\n\r\nfunction aviTWOCC(ch0, ch1: Char): TWOCC;\r\n\r\nconst\r\n ICTYPE_VIDEO = $63646976; {vidc}\r\n ICTYPE_AUDIO = $63647561; {audc}\r\n\r\nconst\r\n ICERR_OK = 0 ;\r\n ICERR_DONTDRAW = 1 ;\r\n ICERR_NEWPALETTE = 2 ;\r\n ICERR_GOTOKEYFRAME = 3 ;\r\n ICERR_STOPDRAWING = 4 ;\r\n\r\n ICERR_UNSUPPORTED = -1 ;\r\n ICERR_BADFORMAT = -2 ;\r\n ICERR_MEMORY = -3 ;\r\n ICERR_INTERNAL = -4 ;\r\n ICERR_BADFLAGS = -5 ;\r\n ICERR_BADPARAM = -6 ;\r\n ICERR_BADSIZE = -7 ;\r\n ICERR_BADHANDLE = -8 ;\r\n ICERR_CANTUPDATE = -9 ;\r\n ICERR_ABORT = -10 ;\r\n ICERR_ERROR = -100 ;\r\n ICERR_BADBITDEPTH = -200 ;\r\n ICERR_BADIMAGESIZE = -201 ;\r\n\r\n ICERR_CUSTOM = -400 ; // errors less than ICERR_CUSTOM...\r\n\r\n{-- Values for dwFlags of ICOpen() -------------------------------------------}\r\n\r\n ICMODE_COMPRESS = 1 ;\r\n ICMODE_DECOMPRESS = 2 ;\r\n ICMODE_FASTDECOMPRESS = 3 ;\r\n ICMODE_QUERY = 4 ;\r\n ICMODE_FASTCOMPRESS = 5 ;\r\n ICMODE_DRAW = 8 ;\r\n\r\n{-- Flags for AVI file index -------------------------------------------------}\r\n\r\n AVIIF_LIST = $00000001 ;\r\n AVIIF_TWOCC = $00000002 ;\r\n AVIIF_KEYFRAME = $00000010 ;\r\n\r\n{-- quality flags ------------------------------------------------------------}\r\n\r\n ICQUALITY_LOW = 0 ;\r\n ICQUALITY_HIGH = 10000 ;\r\n ICQUALITY_DEFAULT = -1 ;\r\n\r\n(************************************************************************\r\n************************************************************************)\r\n\r\n ICM_USER = (DRV_USER+$0000) ;\r\n\r\n ICM_RESERVED_LOW = (DRV_USER+$1000) ;\r\n ICM_RESERVED_HIGH = (DRV_USER+$2000) ;\r\n ICM_RESERVED = ICM_RESERVED_LOW ;\r\n\r\n(************************************************************************\r\n\r\n messages.\r\n\r\n************************************************************************)\r\n\r\n ICM_GETSTATE = (ICM_RESERVED+0) ; // Get compressor state\r\n ICM_SETSTATE = (ICM_RESERVED+1) ; // Set compressor state\r\n ICM_GETINFO = (ICM_RESERVED+2) ; // Query info about the compressor\r\n\r\n ICM_CONFIGURE = (ICM_RESERVED+10); // show the configure dialog\r\n ICM_ABOUT = (ICM_RESERVED+11); // show the about box\r\n\r\n ICM_GETDEFAULTQUALITY = (ICM_RESERVED+30); // get the default value for quality\r\n ICM_GETQUALITY = (ICM_RESERVED+31); // get the current value for quality\r\n ICM_SETQUALITY = (ICM_RESERVED+32); // set the default value for quality\r\n\r\n ICM_SET = (ICM_RESERVED+40); // Tell the driver something\r\n ICM_GET = (ICM_RESERVED+41); // Ask the driver something\r\n\r\n{-- Constants for ICM_SET: ---------------------------------------------------}\r\n\r\n ICM_FRAMERATE = $526D7246; {FrmR}\r\n ICM_KEYFRAMERATE = $5279654B; {KeyR}\r\n\r\n(************************************************************************\r\n\r\n ICM specific messages.\r\n\r\n************************************************************************)\r\n\r\n ICM_COMPRESS_GET_FORMAT = (ICM_USER+4) ; // get compress format or size\r\n ICM_COMPRESS_GET_SIZE = (ICM_USER+5) ; // get output size\r\n ICM_COMPRESS_QUERY = (ICM_USER+6) ; // query support for compress\r\n ICM_COMPRESS_BEGIN = (ICM_USER+7) ; // begin a series of compress calls.\r\n ICM_COMPRESS = (ICM_USER+8) ; // compress a frame\r\n ICM_COMPRESS_END = (ICM_USER+9) ; // end of a series of compress calls.\r\n\r\n ICM_DECOMPRESS_GET_FORMAT = (ICM_USER+10) ; // get decompress format or size\r\n ICM_DECOMPRESS_QUERY = (ICM_USER+11) ; // query support for dempress\r\n ICM_DECOMPRESS_BEGIN = (ICM_USER+12) ; // start a series of decompress calls\r\n ICM_DECOMPRESS = (ICM_USER+13) ; // decompress a frame\r\n ICM_DECOMPRESS_END = (ICM_USER+14) ; // end a series of decompress calls\r\n ICM_DECOMPRESS_SET_PALETTE = (ICM_USER+29) ; // fill in the DIB color table\r\n ICM_DECOMPRESS_GET_PALETTE = (ICM_USER+30) ; // fill in the DIB color table\r\n\r\n ICM_DRAW_QUERY = (ICM_USER+31) ; // query support for dempress\r\n ICM_DRAW_BEGIN = (ICM_USER+15) ; // start a series of draw calls\r\n ICM_DRAW_GET_PALETTE = (ICM_USER+16) ; // get the palette needed for drawing\r\n ICM_DRAW_START = (ICM_USER+18) ; // start decompress clock\r\n ICM_DRAW_STOP = (ICM_USER+19) ; // stop decompress clock\r\n ICM_DRAW_END = (ICM_USER+21) ; // end a series of draw calls\r\n ICM_DRAW_GETTIME = (ICM_USER+32) ; // get value of decompress clock\r\n ICM_DRAW = (ICM_USER+33) ; // generalized \"render\" message\r\n ICM_DRAW_WINDOW = (ICM_USER+34) ; // drawing window has moved or hidden\r\n ICM_DRAW_SETTIME = (ICM_USER+35) ; // set correct value for decompress clock\r\n ICM_DRAW_REALIZE = (ICM_USER+36) ; // realize palette for drawing\r\n ICM_DRAW_FLUSH = (ICM_USER+37) ; // clear out buffered frames\r\n ICM_DRAW_RENDERBUFFER = (ICM_USER+38) ; // draw undrawn things in queue\r\n\r\n ICM_DRAW_START_PLAY = (ICM_USER+39) ; // start of a play\r\n ICM_DRAW_STOP_PLAY = (ICM_USER+40) ; // end of a play\r\n\r\n ICM_DRAW_SUGGESTFORMAT = (ICM_USER+50) ; // Like ICGetDisplayFormat\r\n ICM_DRAW_CHANGEPALETTE = (ICM_USER+51) ; // for animating palette\r\n\r\n ICM_GETBUFFERSWANTED = (ICM_USER+41) ; // ask about prebuffering\r\n\r\n ICM_GETDEFAULTKEYFRAMERATE = (ICM_USER+42) ; // get the default value for key frames\r\n\r\n ICM_DECOMPRESSEX_BEGIN = (ICM_USER+60) ; // start a series of decompress calls\r\n ICM_DECOMPRESSEX_QUERY = (ICM_USER+61) ; // start a series of decompress calls\r\n ICM_DECOMPRESSEX = (ICM_USER+62) ; // decompress a frame\r\n ICM_DECOMPRESSEX_END = (ICM_USER+63) ; // end a series of decompress calls\r\n\r\n ICM_COMPRESS_FRAMES_INFO = (ICM_USER+70) ; // tell about compress to come\r\n ICM_SET_STATUS_PROC = (ICM_USER+72) ; // set status callback\r\n\r\n(************************************************************************\r\n************************************************************************)\r\n\r\ntype\r\n PICOPEN = ^TICOPEN;\r\n TICOPEN = packed record\r\n dwSize : DWORD ; // sizeof(ICOPEN)\r\n fccType : DWORD ; // 'vidc'\r\n fccHandler : DWORD ; //\r\n dwVersion : DWORD ; // version of compman opening you\r\n dwFlags : DWORD ; // LOWORD is type specific\r\n dwError : DWORD ; // error return.\r\n pV1Reserved : PVOID ; // Reserved\r\n pV2Reserved : PVOID ; // Reserved\r\n dnDevNode : DWORD ; // Devnode for PnP devices\r\n end;\r\n\r\n(************************************************************************\r\n************************************************************************)\r\n\r\n PICINFO = ^TICINFO;\r\n TICINFO = packed record\r\n dwSize : DWORD; // sizeof(ICINFO)\r\n fccType : DWORD; // compressor type 'vidc' 'audc'\r\n fccHandler : DWORD; // compressor sub-type 'rle ' 'jpeg' 'pcm '\r\n dwFlags : DWORD; // flags LOWORD is type specific\r\n dwVersion : DWORD; // version of the driver\r\n dwVersionICM : DWORD; // version of the ICM used\r\n //\r\n // under Win32, the driver always returns UNICODE strings.\r\n //\r\n szName : array[0..15] of WChar ; // short name\r\n szDescription : array[0..127] of WChar ; // DWORD name\r\n szDriver : array[0..127] of WChar ; // driver that contains compressor\r\n end;\r\n\r\n{-- Flags for the field of the structure. ------------}\r\n\r\nconst\r\n VIDCF_QUALITY = $0001 ; // supports quality\r\n VIDCF_CRUNCH = $0002 ; // supports crunching to a frame size\r\n VIDCF_TEMPORAL = $0004 ; // supports inter-frame compress\r\n VIDCF_COMPRESSFRAMES = $0008 ; // wants the compress all frames message\r\n VIDCF_DRAW = $0010 ; // supports drawing\r\n VIDCF_FASTTEMPORALC = $0020 ; // does not need prev frame on compress\r\n VIDCF_FASTTEMPORALD = $0080 ; // does not need prev frame on decompress\r\n //VIDCF_QUALITYTIME = $0040 ; // supports temporal quality\r\n\r\n //VIDCF_FASTTEMPORAL = (VIDCF_FASTTEMPORALC or VIDCF_FASTTEMPORALD)\r\n\r\n(************************************************************************\r\n************************************************************************)\r\n\r\n ICCOMPRESS_KEYFRAME = $00000001;\r\n\r\ntype\r\n PICCOMPRESS = ^TICCOMPRESS;\r\n TICCOMPRESS = packed record\r\n dwFlags : DWORD; // flags\r\n\r\n lpbiOutput : PBITMAPINFOHEADER ; // output format\r\n lpOutput : PVOID ; // output data\r\n\r\n lpbiInput : PBITMAPINFOHEADER ; // format of frame to compress\r\n lpInput : PVOID ; // frame data to compress\r\n\r\n lpckid : PDWORD ; // ckid for data in AVI file\r\n lpdwFlags : PDWORD; // flags in the AVI index.\r\n lFrameNum : LONG ; // frame number of seq.\r\n dwFrameSize : DWORD ; // reqested size in bytes. (if non zero)\r\n\r\n dwQuality : DWORD ; // quality\r\n\r\n // these are new fields\r\n\r\n lpbiPrev : PBITMAPINFOHEADER ; // format of previous frame\r\n lpPrev : PVOID ; // previous frame\r\n end;\r\n\r\n(************************************************************************\r\n************************************************************************)\r\n\r\nconst\r\n ICCOMPRESSFRAMES_PADDING = $00000001 ;\r\n\r\ntype\r\n TICCompressProc = function(lInputOutput: LPARAM; lFrame: DWORD; lpBits: PVOID; len: LONG): LONG; stdcall;\r\n\r\n PICCOMPRESSFRAMES = ^TICCOMPRESSFRAMES;\r\n TICCOMPRESSFRAMES = packed record\r\n dwFlags : DWORD ; // flags\r\n\r\n lpbiOutput : PBITMAPINFOHEADER ; // output format\r\n lOutput : LPARAM ; // output identifier\r\n\r\n lpbiInput : PBITMAPINFOHEADER ; // format of frame to compress\r\n lInput : LPARAM ; // input identifier\r\n\r\n lStartFrame : LONG ; // start frame\r\n lFrameCount : LONG ; // # of frames\r\n\r\n lQuality : LONG ; // quality\r\n lDataRate : LONG ; // data rate\r\n lKeyRate : LONG ; // key frame rate\r\n\r\n dwRate : DWORD ; // frame rate, as always\r\n dwScale : DWORD ;\r\n\r\n dwOverheadPerFrame : DWORD ;\r\n dwReserved2 : DWORD ;\r\n\r\n GetData : TICCompressProc;\r\n PutData : TICCompressProc;\r\n end;\r\n\r\n{-- Messages for Status callback ---------------------------------------------}\r\n\r\nconst\r\n ICSTATUS_START = 0 ;\r\n ICSTATUS_STATUS = 1 ; // l = % done\r\n ICSTATUS_END = 2 ;\r\n ICSTATUS_ERROR = 3 ; // l = error string (LPSTR)\r\n ICSTATUS_YIELD = 4 ;\r\n\r\ntype\r\n // return nonzero means abort operation in progress\r\n TICStatusProc = function(lParam: LPARAM; message: UINT; l: LONG): LONG; stdcall;\r\n\r\n PICSETSTATUSPROC = ^TICSETSTATUSPROC;\r\n TICSETSTATUSPROC = packed record\r\n dwFlags : DWORD ;\r\n lParam : LPARAM ;\r\n Status : TICStatusProc;\r\n end;\r\n\r\n(************************************************************************\r\n************************************************************************)\r\n\r\nconst\r\n ICDECOMPRESS_HURRYUP = $80000000 ; // don't draw just buffer (hurry up!)\r\n ICDECOMPRESS_UPDATE = $40000000 ; // don't draw just update screen\r\n ICDECOMPRESS_PREROLL = $20000000 ; // this frame is before real start\r\n ICDECOMPRESS_NULLFRAME = $10000000 ; // repeat last frame\r\n ICDECOMPRESS_NOTKEYFRAME = $08000000 ; // this frame is not a key frame\r\n\r\ntype\r\n PICDECOMPRESS = ^TICDECOMPRESS;\r\n TICDECOMPRESS = packed record\r\n dwFlags : DWORD ; // flags (from AVI index...)\r\n lpbiInput : PBITMAPINFOHEADER ; // BITMAPINFO of compressed data\r\n // biSizeImage has the chunk size\r\n lpInput : PVOID ; // compressed data\r\n lpbiOutput : PBITMAPINFOHEADER ; // DIB to decompress to\r\n lpOutput : PVOID ;\r\n ckid : DWORD ; // ckid from AVI file\r\n end;\r\n\r\n PICDECOMPRESSEX = ^TICDECOMPRESSEX;\r\n TICDECOMPRESSEX = packed record\r\n\r\n //\r\n // same as ICM_DECOMPRESS\r\n //\r\n\r\n dwFlags : DWORD;\r\n lpbiSrc : PBITMAPINFOHEADER; // BITMAPINFO of compressed data\r\n lpSrc : PVOID; // compressed data\r\n lpbiDst : PBITMAPINFOHEADER; // DIB to decompress to\r\n lpDst : PVOID; // output data\r\n\r\n //\r\n // new for ICM_DECOMPRESSEX\r\n //\r\n\r\n xDst : int; // destination rectangle\r\n yDst : int;\r\n dxDst : int;\r\n dyDst : int;\r\n\r\n xSrc : int; // source rectangle\r\n ySrc : int;\r\n dxSrc : int;\r\n dySrc : int;\r\n end;\r\n\r\n(************************************************************************\r\n************************************************************************)\r\n\r\nconst\r\n ICDRAW_QUERY = $00000001 ; // test for support\r\n ICDRAW_FULLSCREEN = $00000002 ; // draw to full screen\r\n ICDRAW_HDC = $00000004 ; // draw to a HDC/HWND\r\n ICDRAW_ANIMATE = $00000008 ; // expect palette animation\r\n ICDRAW_CONTINUE = $00000010 ; // draw is a continuation of previous draw\r\n ICDRAW_MEMORYDC = $00000020 ; // DC is offscreen, by the way\r\n ICDRAW_UPDATING = $00000040 ; // We're updating, as opposed to playing\r\n ICDRAW_RENDER = $00000080 ; // used to render data not draw it\r\n ICDRAW_BUFFER = $00000100 ; // please buffer this data offscreen, we will need to update it\r\n\r\ntype\r\n PICDRAWBEGIN = ^TICDRAWBEGIN;\r\n TICDRAWBEGIN = packed record\r\n dwFlags : DWORD ; // flags\r\n\r\n hpal : HPALETTE ; // palette to draw with\r\n hwnd : HWND ; // window to draw to\r\n hdc : HDC ; // HDC to draw to\r\n\r\n xDst : int ; // destination rectangle\r\n yDst : int ;\r\n dxDst : int ;\r\n dyDst : int ;\r\n\r\n lpbi : PBITMAPINFOHEADER ;\r\n // format of frame to draw\r\n\r\n xSrc : int ; // source rectangle\r\n ySrc : int ;\r\n dxSrc : int ;\r\n dySrc : int ;\r\n\r\n dwRate : DWORD ; // frames/second = (dwRate/dwScale)\r\n dwScale : DWORD ;\r\n end;\r\n\r\n(************************************************************************\r\n************************************************************************)\r\n\r\nconst\r\n ICDRAW_HURRYUP = $80000000 ; // don't draw just buffer (hurry up!)\r\n ICDRAW_UPDATE = $40000000 ; // don't draw just update screen\r\n ICDRAW_PREROLL = $20000000 ; // this frame is before real start\r\n ICDRAW_NULLFRAME = $10000000 ; // repeat last frame\r\n ICDRAW_NOTKEYFRAME = $08000000 ; // this frame is not a key frame\r\n\r\ntype\r\n PICDRAW = ^TICDRAW;\r\n TICDRAW = packed record\r\n dwFlags : DWORD ; // flags\r\n lpFormat : PVOID ; // format of frame to decompress\r\n lpData : PVOID ; // frame data to decompress\r\n cbData : DWORD ;\r\n lTime : LONG ; // time in drawbegin units (see dwRate and dwScale)\r\n end;\r\n\r\n PICDRAWSUGGEST = ^TICDRAWSUGGEST;\r\n TICDRAWSUGGEST = packed record\r\n lpbiIn : PBITMAPINFOHEADER ; // format to be drawn\r\n lpbiSuggest : PBITMAPINFOHEADER ; // location for suggested format (or NULL to get size)\r\n dxSrc : int ; // source extent or 0\r\n dySrc : int ;\r\n dxDst : int ; // dest extent or 0\r\n dyDst : int ;\r\n hicDecompressor : HIC ; // decompressor you can talk to\r\n end;\r\n\r\n(************************************************************************\r\n************************************************************************)\r\n\r\n PICPALETTE = ^TICPALETTE;\r\n TICPALETTE = packed record\r\n dwFlags : DWORD ; // flags (from AVI index...)\r\n iStart : int ; // first palette to change\r\n iLen : int ; // count of entries to change.\r\n lppe : PPALETTEENTRY ; // palette\r\n end;\r\n\r\n(************************************************************************\r\n\r\n ICM function declarations\r\n\r\n************************************************************************)\r\n\r\nfunction ICInfo(fccType, fccHandler: DWORD; lpicinfo: PICINFO) : BOOL ; stdcall ;\r\nfunction ICInstall(fccType, fccHandler: DWORD; lParam: LPARAM; szDesc: LPSTR; wFlags: UINT) : BOOL ; stdcall ;\r\nfunction ICRemove(fccType, fccHandler: DWORD; wFlags: UINT) : BOOL ; stdcall ;\r\nfunction ICGetInfo(hic: HIC; picinfo: PICINFO; cb: DWORD) : DWORD ; stdcall ;\r\n\r\nfunction ICOpen(fccType, fccHandler: DWORD; wMode: UINT) : HIC ; stdcall ;\r\nfunction ICOpenFunction(fccType, fccHandler: DWORD; wMode: UINT; lpfnHandler: TFarProc) : HIC ; stdcall ;\r\nfunction ICClose(hic: HIC) : DWORD; stdcall ;\r\n\r\nfunction ICSendMessage(hic: HIC; msg: UINT; dw1, dw2: DWORD) : DWORD ; stdcall ;\r\n\r\n{-- Values for wFlags of ICInstall -------------------------------------------}\r\n\r\nconst\r\n ICINSTALL_UNICODE = $8000 ;\r\n\r\n ICINSTALL_FUNCTION = $0001 ; // lParam is a DriverProc (function ptr)\r\n ICINSTALL_DRIVER = $0002 ; // lParam is a driver name (string)\r\n ICINSTALL_HDRV = $0004 ; // lParam is a HDRVR (driver handle)\r\n\r\n ICINSTALL_DRIVERW = $8002 ; // lParam is a unicode driver name\r\n\r\n{-- Query macros -------------------------------------------------------------}\r\n\r\n ICMF_CONFIGURE_QUERY = $00000001 ;\r\n ICMF_ABOUT_QUERY = $00000001 ;\r\n\r\nfunction ICQueryAbout(hic: HIC): BOOL;\r\nfunction ICAbout(hic: HIC; hwnd: HWND): DWORD;\r\nfunction ICQueryConfigure(hic: HIC): BOOL;\r\nfunction ICConfigure(hic: HIC; hwnd: HWND): DWORD;\r\n\r\n{-- Get/Set state macros -----------------------------------------------------}\r\n\r\nfunction ICGetState(hic: HIC; pv: PVOID; cb: DWORD): DWORD;\r\nfunction ICSetState(hic: HIC; pv: PVOID; cb: DWORD): DWORD;\r\nfunction ICGetStateSize(hic: HIC): DWORD;\r\n\r\n{-- Get value macros ---------------------------------------------------------}\r\n\r\nfunction ICGetDefaultQuality(hic: HIC): DWORD;\r\nfunction ICGetDefaultKeyFrameRate(hic: HIC): DWORD;\r\n\r\n{-- Draw window macro --------------------------------------------------------}\r\n\r\nfunction ICDrawWindow(hic: HIC; prc: PRECT): DWORD;\r\n\r\n(************************************************************************\r\n\r\n compression functions\r\n\r\n************************************************************************/\r\n/*\r\n * ICCompress()\r\n *\r\n * compress a single frame\r\n *\r\n *)\r\nfunction ICCompress(\r\n hic : HIC;\r\n dwFlags : DWORD; // flags\r\n lpbiOutput : PBITMAPINFOHEADER; // output format\r\n lpData : PVOID; // output data\r\n lpbiInput : PBITMAPINFOHEADER; // format of frame to compress\r\n lpBits : PVOID; // frame data to compress\r\n lpckid : PDWORD; // ckid for data in AVI file\r\n lpdwFlags : PDWORD; // flags in the AVI index.\r\n lFrameNum : DWORD; // frame number of seq.\r\n dwFrameSize : DWORD; // reqested size in bytes. (if non zero)\r\n dwQuality : DWORD; // quality within one frame\r\n lpbiPrev : PBITMAPINFOHEADER; // format of previous frame\r\n lpPrev : PVOID // previous frame\r\n ): DWORD; cdecl;\r\n\r\n(*\r\n * ICCompressBegin()\r\n *\r\n * start compression from a source format (lpbiInput) to a dest\r\n * format (lpbiOuput) is supported.\r\n *\r\n *)\r\n\r\nfunction ICCompressBegin(hic: HIC; lpbiInput: PBITMAPINFOHEADER; lpbiOutput: PBITMAPINFOHEADER): DWORD;\r\n\r\n(*\r\n * ICCompressQuery()\r\n *\r\n * determines if compression from a source format (lpbiInput) to a dest\r\n * format (lpbiOuput) is supported.\r\n *\r\n *)\r\n\r\nfunction ICCompressQuery(hic: HIC; lpbiInput, lpbiOutput: PBITMAPINFOHEADER): DWORD;\r\n\r\n(*\r\n * ICCompressGetFormat()\r\n *\r\n * get the output format, (format of compressed data)\r\n * if lpbiOutput is NULL return the size in bytes needed for format.\r\n *\r\n *)\r\n\r\nfunction ICCompressGetFormat(hic: HIC; lpbiInput, lpbiOutput: PBITMAPINFOHEADER): DWORD;\r\nfunction ICCompressGetFormatSize(hic: HIC; lpbi: PBITMAPINFOHEADER): DWORD;\r\n\r\n(*\r\n * ICCompressSize()\r\n *\r\n * return the maximal size of a compressed frame\r\n *\r\n *)\r\n\r\nfunction ICCompressGetSize(hic: HIC; lpbiInput, lpbiOutput: PBITMAPINFOHEADER): DWORD;\r\nfunction ICCompressEnd(hic: HIC): DWORD;\r\n\r\n(************************************************************************\r\n\r\n decompression functions\r\n\r\n************************************************************************)\r\n\r\n(*\r\n * ICDecompress()\r\n *\r\n * decompress a single frame\r\n *\r\n *)\r\n\r\nfunction ICDecompress(\r\n hic : HIC;\r\n dwFlags : DWORD; // flags (from AVI index...)\r\n lpbiFormat : PBITMAPINFOHEADER; // BITMAPINFO of compressed data\r\n // biSizeImage has the chunk size\r\n lpData : PVOID; // data\r\n lpbi : PBITMAPINFOHEADER; // DIB to decompress to\r\n lpBits : PVOID\r\n ): DWORD; cdecl;\r\n\r\n(*\r\n * ICDecompressBegin()\r\n *\r\n * start compression from a source format (lpbiInput) to a dest\r\n * format (lpbiOutput) is supported.\r\n *\r\n *)\r\n\r\nfunction ICDecompressBegin(hic: HIC; lpbiInput, lpbiOutput: PBITMAPINFOHEADER): DWORD;\r\n\r\n(*\r\n * ICDecompressQuery()\r\n *\r\n * determines if compression from a source format (lpbiInput) to a dest\r\n * format (lpbiOutput) is supported.\r\n *\r\n *)\r\n\r\nfunction ICDecompressQuery(hic: HIC; lpbiInput, lpbiOutput: PBITMAPINFOHEADER): DWORD;\r\n\r\n(*\r\n * ICDecompressGetFormat()\r\n *\r\n * get the output format, (format of un-compressed data)\r\n * if lpbiOutput is NULL return the size in bytes needed for format.\r\n *\r\n *)\r\n\r\nfunction ICDecompressGetFormat(hic: HIC; lpbiInput, lpbiOutput: PBITMAPINFOHEADER): DWORD;\r\nfunction ICDecompressGetFormatSize(hic: HIC; lpbi: PBITMAPINFOHEADER): DWORD;\r\n\r\n(*\r\n * ICDecompressGetPalette()\r\n *\r\n * get the output palette\r\n *\r\n *)\r\n\r\nfunction ICDecompressGetPalette(hic: HIC; lpbiInput, lpbiOutput: PBITMAPINFOHEADER): DWORD;\r\nfunction ICDecompressSetPalette(hic: HIC; lpbiPalette: PBITMAPINFOHEADER): DWORD;\r\n\r\nfunction ICDecompressEnd(hic: HIC): DWORD;\r\n\r\n(************************************************************************\r\n\r\n decompression (ex) functions\r\n\r\n************************************************************************)\r\n\r\n//\r\n// on Win16 these functions are macros that call ICMessage. ICMessage will\r\n// not work on NT. rather than add new entrypoints we have given\r\n// them as static inline functions\r\n//\r\n\r\n(*\r\n * ICDecompressEx()\r\n *\r\n * decompress a single frame\r\n *\r\n *)\r\n\r\nfunction ICDecompressEx(\r\n hic : HIC;\r\n dwFlags : DWORD;\r\n lpbiSrc : PBITMAPINFOHEADER;\r\n lpSrc : PVOID;\r\n xSrc : int;\r\n ySrc : int;\r\n dxSrc : int;\r\n dySrc : int;\r\n lpbiDst : PBITMAPINFOHEADER;\r\n lpDst : PVOID;\r\n xDst : int;\r\n yDst : int;\r\n dxDst : int;\r\n dyDst : int\r\n ): DWORD; stdcall;\r\n\r\n(*\r\n * ICDecompressExBegin()\r\n *\r\n * start compression from a source format (lpbiInput) to a dest\r\n * format (lpbiOutput) is supported.\r\n *\r\n *)\r\n\r\nfunction ICDecompressExBegin(\r\n hic : HIC;\r\n dwFlags : DWORD;\r\n lpbiSrc : PBITMAPINFOHEADER;\r\n lpSrc : PVOID;\r\n xSrc : int;\r\n ySrc : int;\r\n dxSrc : int;\r\n dySrc : int;\r\n lpbiDst : PBITMAPINFOHEADER;\r\n lpDst : PVOID;\r\n xDst : int;\r\n yDst : int;\r\n dxDst : int;\r\n dyDst : int\r\n ): DWORD; stdcall;\r\n\r\n(*\r\n * ICDecompressExQuery()\r\n *\r\n *)\r\n\r\nfunction ICDecompressExQuery(\r\n hic : HIC;\r\n dwFlags : DWORD;\r\n lpbiSrc : PBITMAPINFOHEADER;\r\n lpSrc : PVOID;\r\n xSrc : int;\r\n ySrc : int;\r\n dxSrc : int;\r\n dySrc : int;\r\n lpbiDst : PBITMAPINFOHEADER;\r\n lpDst : PVOID;\r\n xDst : int;\r\n yDst : int;\r\n dxDst : int;\r\n dyDst : int\r\n ): DWORD; stdcall;\r\n\r\nfunction ICDecompressExEnd(hic: HIC): DWORD;\r\n\r\n(************************************************************************\r\n\r\n drawing functions\r\n\r\n************************************************************************)\r\n\r\n(*\r\n * ICDrawBegin()\r\n *\r\n * start decompressing data with format (lpbiInput) directly to the screen\r\n *\r\n * return zero if the decompressor supports drawing.\r\n *\r\n *)\r\n\r\nfunction ICDrawBegin(\r\n hic : HIC;\r\n dwFlags : DWORD; // flags\r\n hpal : HPALETTE; // palette to draw with\r\n hwnd : HWND; // window to draw to\r\n hdc : HDC; // HDC to draw to\r\n xDst : int; // destination rectangle\r\n yDst : int;\r\n dxDst : int;\r\n dyDst : int;\r\n lpbi : PBITMAPINFOHEADER; // format of frame to draw\r\n xSrc : int; // source rectangle\r\n ySrc : int;\r\n dxSrc : int;\r\n dySrc : int;\r\n dwRate : DWORD; // frames/second = (dwRate/dwScale)\r\n dwScale : DWORD\r\n ): DWORD; cdecl;\r\n\r\n(*\r\n * ICDraw()\r\n *\r\n * decompress data directly to the screen\r\n *\r\n *)\r\n\r\nfunction ICDraw(\r\n hic : HIC;\r\n dwFlags : DWORD; // flags\r\n lpFormat : PVOID; // format of frame to decompress\r\n lpData : PVOID; // frame data to decompress\r\n cbData : DWORD; // size of data\r\n lTime : DWORD // time to draw this frame\r\n ): DWORD; cdecl;\r\n\r\n// ICMessage is not supported on Win32, so provide a static inline function\r\n// to do the same job\r\nfunction ICDrawSuggestFormat(\r\n hic : HIC;\r\n lpbiIn : PBITMAPINFOHEADER;\r\n lpbiOut : PBITMAPINFOHEADER;\r\n dxSrc : int;\r\n dySrc : int;\r\n dxDst : int;\r\n dyDst : int;\r\n hicDecomp : HIC\r\n ): DWORD; stdcall;\r\n\r\n(*\r\n * ICDrawQuery()\r\n *\r\n * determines if the compressor is willing to render the specified format.\r\n *\r\n *)\r\n\r\nfunction ICDrawQuery(hic: HIC; lpbiInput: PBITMAPINFOHEADER): DWORD;\r\nfunction ICDrawChangePalette(hic: HIC; lpbiInput: PBITMAPINFOHEADER): DWORD;\r\nfunction ICGetBuffersWanted(hic: HIC; lpdwBuffers: PDWORD): DWORD;\r\nfunction ICDrawEnd(hic: HIC): DWORD;\r\nfunction ICDrawStart(hic: HIC): DWORD;\r\nfunction ICDrawStartPlay(hic: HIC; lFrom, lTo: DWORD): DWORD;\r\nfunction ICDrawStop(hic: HIC): DWORD;\r\nfunction ICDrawStopPlay(hic: HIC): DWORD;\r\nfunction ICDrawGetTime(hic: HIC; lplTime: PDWORD): DWORD;\r\nfunction ICDrawSetTime(hic: HIC; lTime: DWORD): DWORD;\r\nfunction ICDrawRealize(hic: HIC; hdc: HDC; fBackground: BOOL): DWORD;\r\nfunction ICDrawFlush(hic: HIC): DWORD;\r\nfunction ICDrawRenderBuffer(hic: HIC): DWORD;\r\n\r\n(************************************************************************\r\n\r\n Status callback functions\r\n\r\n************************************************************************/\r\n\r\n/*\r\n * ICSetStatusProc()\r\n *\r\n * Set the status callback function\r\n *\r\n *)\r\n\r\n\r\n// ICMessage is not supported on NT\r\nfunction ICSetStatusProc(\r\n hic : HIC;\r\n dwFlags : DWORD;\r\n lParam : DWORD;\r\n fpfnStatus : TICStatusProc\r\n ): DWORD; stdcall;\r\n\r\n(************************************************************************\r\n\r\nhelper routines for DrawDib and MCIAVI...\r\n\r\n************************************************************************)\r\n\r\nfunction ICLocate(fccType, fccHandler: DWORD; lpbiIn, lpbiOut: PBITMAPINFOHEADER; wFlags: WORD): HIC; stdcall;\r\nfunction ICGetDisplayFormat(hic: HIC; lpbiIn, lpbiOut: PBITMAPINFOHEADER; BitDepth: int; dx, dy: int): HIC; stdcall;\r\n\r\nfunction ICDecompressOpen(fccType, fccHandler: DWORD; lpbiIn, lpbiOut: PBITMAPINFOHEADER): HIC;\r\nfunction ICDrawOpen(fccType, fccHandler: DWORD; lpbiIn: PBITMAPINFOHEADER): HIC;\r\n\r\n(************************************************************************\r\nHigher level functions\r\n************************************************************************)\r\n\r\nfunction ICImageCompress(\r\n hic : HIC; // compressor to use\r\n uiFlags : UINT; // flags (none yet)\r\n lpbiIn : PBITMAPINFO; // format to compress from\r\n lpBits : PVOID; // data to compress\r\n lpbiOut : PBITMAPINFO; // compress to this (NULL ==> default)\r\n lQuality : LONG; // quality to use\r\n plSize : PDWORD // compress to this size (0=whatever)\r\n ): THANDLE; stdcall;\r\n\r\nfunction ICImageDecompress(\r\n hic : HIC; // compressor to use\r\n uiFlags : UINT; // flags (none yet)\r\n lpbiIn : PBITMAPINFO; // format to decompress from\r\n lpBits : PVOID; // data to decompress\r\n lpbiOut : PBITMAPINFO // decompress to this (NULL ==> default)\r\n ): THANDLE; stdcall;\r\n\r\n{-- TCompVars ----------------------------------------------------------------}\r\n\r\n//\r\n// Structure used by ICSeqCompressFrame and ICCompressorChoose routines\r\n// Make sure this matches the autodoc in icm.c!\r\n//\r\n\r\ntype\r\n PCOMPVARS = ^TCOMPVARS;\r\n TCOMPVARS = packed record\r\n cbSize : DWORD; // set to sizeof(COMPVARS) before\r\n // calling ICCompressorChoose\r\n dwFlags : DWORD; // see below...\r\n hic : HIC; // HIC of chosen compressor\r\n fccType : DWORD; // basically ICTYPE_VIDEO\r\n fccHandler : DWORD; // handler of chosen compressor or\r\n // \"\" or \"DIB \"\r\n lpbiIn : PBITMAPINFO; // input format\r\n lpbiOut : PBITMAPINFO; // output format - will compress to this\r\n lpBitsOut : PVOID;\r\n lpBitsPrev : PVOID;\r\n lFrame : LONG;\r\n lKey : LONG; // key frames how often?\r\n lDataRate : LONG; // desired data rate KB/Sec\r\n lQ : LONG; // desired quality\r\n lKeyCount : LONG;\r\n lpState : PVOID; // state of compressor\r\n cbState : LONG; // size of the state\r\n end;\r\n\r\n// FLAGS for dwFlags element of COMPVARS structure:\r\n// set this flag if you initialize COMPVARS before calling ICCompressorChoose\r\n\r\nconst\r\n ICMF_COMPVARS_VALID = $00000001; // COMPVARS contains valid data\r\n\r\n//\r\n// allows user to choose compressor, quality etc...\r\n//\r\nfunction ICCompressorChoose(\r\n hwnd : HWND; // parent window for dialog\r\n uiFlags : UINT; // flags\r\n pvIn : PVOID; // input format (optional)\r\n lpData : PVOID; // input data (optional)\r\n pc : PCOMPVARS; // data about the compressor/dlg\r\n lpszTitle : LPSTR // dialog title (optional)\r\n ): BOOL; stdcall;\r\n\r\n// defines for uiFlags\r\n\r\nconst\r\n ICMF_CHOOSE_KEYFRAME = $0001; // show KeyFrame Every box\r\n ICMF_CHOOSE_DATARATE = $0002; // show DataRate box\r\n ICMF_CHOOSE_PREVIEW = $0004; // allow expanded preview dialog\r\n ICMF_CHOOSE_ALLCOMPRESSORS = $0008; // don't only show those that\r\n // can handle the input format\r\n // or input data\r\n\r\nfunction ICSeqCompressFrameStart(pc: PCOMPVARS; lpbiIn: PBITMAPINFO): BOOL; stdcall;\r\nprocedure ICSeqCompressFrameEnd(pc: PCOMPVARS); stdcall;\r\n\r\nfunction ICSeqCompressFrame(\r\n pc : PCOMPVARS; // set by ICCompressorChoose\r\n uiFlags : UINT; // flags\r\n lpBits : PVOID; // input DIB bits\r\n pfKey : PBOOL; // did it end up being a key frame?\r\n plSize : PDWORD // size to compress to/of returned image\r\n ): PVOID; stdcall;\r\n\r\nprocedure ICCompressorFree(pc: PCOMPVARS); stdcall;\r\n\r\n\r\n(**************************************************************************\r\n *\r\n * DRAWDIB - Routines for drawing to the display.\r\n *\r\n *************************************************************************)\r\n\r\ntype\r\n HDRAWDIB = THandle; // hdd\r\n\r\n(*********************************************************************\r\n\r\n DrawDib Flags\r\n\r\n**********************************************************************)\r\n\r\nconst\r\n DDF_UPDATE = $0002; // re-draw the last DIB\r\n DDF_SAME_HDC = $0004; // HDC same as last call (all setup)\r\n DDF_SAME_DRAW = $0008; // draw params are the same\r\n DDF_DONTDRAW = $0010; // dont draw frame, just decompress\r\n DDF_ANIMATE = $0020; // allow palette animation\r\n DDF_BUFFER = $0040; // always buffer image\r\n DDF_JUSTDRAWIT = $0080; // just draw it with GDI\r\n DDF_FULLSCREEN = $0100; // use DisplayDib\r\n DDF_BACKGROUNDPAL = $0200; // Realize palette in background\r\n DDF_NOTKEYFRAME = $0400; // this is a partial frame update, hint\r\n DDF_HURRYUP = $0800; // hurry up please!\r\n DDF_HALFTONE = $1000; // always halftone\r\n\r\n DDF_PREROLL = DDF_DONTDRAW; // Builing up a non-keyframe\r\n DDF_SAME_DIB = DDF_SAME_DRAW;\r\n DDF_SAME_SIZE = DDF_SAME_DRAW;\r\n\r\n(*********************************************************************\r\n\r\n DrawDib functions\r\n\r\n*********************************************************************)\r\n\r\n{-- DrawDibOpen() ------------------------------------------------------------}\r\n\r\nfunction DrawDibOpen: HDRAWDIB; stdcall;\r\n\r\n{-- DrawDibClose() -----------------------------------------------------------}\r\n\r\nfunction DrawDibClose(hdd: HDRAWDIB): BOOL; stdcall;\r\n\r\n{-- DrawDibGetBuffer() -------------------------------------------------------}\r\n\r\nfunction DrawDibGetBuffer(hdd: HDRAWDIB; lpbi: PBITMAPINFOHEADER; dwSize: DWORD; dwFlags: DWORD): PVOID; stdcall;\r\n\r\n{-- DrawDibGetPalette() - get the palette used for drawing DIBs --------------}\r\n\r\nfunction DrawDibGetPalette(hdd: HDRAWDIB): HPALETTE; stdcall;\r\n\r\n{-- DrawDibSetPalette() - set the palette used for drawing DIBs --------------}\r\n\r\nfunction DrawDibSetPalette(hdd: HDRAWDIB; hpal: HPALETTE): BOOL; stdcall;\r\n\r\n{-- DrawDibChangePalette() ---------------------------------------------------}\r\n\r\nfunction DrawDibChangePalette(hdd: HDRAWDIB; iStart, iLen: int; lppe: PPALETTEENTRY): BOOL; stdcall;\r\n\r\n{-- DrawDibRealize() - realize the palette in a HDD --------------------------}\r\n\r\nfunction DrawDibRealize(hdd: HDRAWDIB; hdc: HDC; fBackground: BOOL): UINT; stdcall;\r\n\r\n{-- DrawDibStart() - start of streaming playback -----------------------------}\r\n\r\nfunction DrawDibStart(hdd: HDRAWDIB; rate: DWORD): BOOL; stdcall;\r\n\r\n{-- DrawDibStop() - start of streaming playback ------------------------------}\r\n\r\nfunction DrawDibStop(hdd: HDRAWDIB): BOOL; stdcall;\r\n\r\n{-- DrawDibBegin() - prepare to draw -----------------------------------------}\r\n\r\nfunction DrawDibBegin(\r\n hdd : HDRAWDIB;\r\n hdc : HDC;\r\n dxDst : int;\r\n dyDst : int;\r\n lpbi : PBITMAPINFOHEADER;\r\n dxSrc : int;\r\n dySrc : int;\r\n wFlags : UINT\r\n ): BOOL; stdcall;\r\n\r\n{-- DrawDibDraw() - actually draw a DIB to the screen ------------------------}\r\n\r\nfunction DrawDibDraw(\r\n hdd : HDRAWDIB;\r\n hdc : HDC;\r\n xDst : int;\r\n yDst : int;\r\n dxDst : int;\r\n dyDst : int;\r\n lpbi : PBITMAPINFOHEADER;\r\n lpBits : PVOID;\r\n xSrc : int;\r\n ySrc : int;\r\n dxSrc : int;\r\n dySrc : int;\r\n wFlags : UINT\r\n ): BOOL; stdcall;\r\n\r\n{-- DrawDibUpdate() - redraw last image (may only be valid with DDF_BUFFER) --}\r\n\r\nfunction DrawDibUpdate(hdd: HDRAWDIB; hdc: HDC; x, y: int): BOOL;\r\n\r\n{-- DrawDibEnd() -------------------------------------------------------------}\r\n\r\nfunction DrawDibEnd(hdd: HDRAWDIB): BOOL; stdcall;\r\n\r\n{-- DrawDibTime() - for debugging purposes only ------------------------------}\r\n\r\ntype\r\n PDRAWDIBTIME = ^TDRAWDIBTIME;\r\n TDRAWDIBTIME = packed record\r\n timeCount : LONG;\r\n timeDraw : LONG;\r\n timeDecompress : LONG;\r\n timeDither : LONG;\r\n timeStretch : LONG;\r\n timeBlt : LONG;\r\n timeSetDIBits : LONG;\r\n end;\r\n\r\nfunction DrawDibTime(hdd: HDRAWDIB; lpddtime: PDRAWDIBTIME): BOOL; stdcall;\r\n\r\n{-- Display profiling --------------------------------------------------------}\r\n\r\nconst\r\n PD_CAN_DRAW_DIB = $0001; // if you can draw at all\r\n PD_CAN_STRETCHDIB = $0002; // basicly RC_STRETCHDIB\r\n PD_STRETCHDIB_1_1_OK = $0004; // is it fast?\r\n PD_STRETCHDIB_1_2_OK = $0008; // ...\r\n PD_STRETCHDIB_1_N_OK = $0010; // ...\r\n\r\nfunction DrawDibProfileDisplay(lpbi: PBITMAPINFOHEADER): DWORD; stdcall;\r\n\r\n(****************************************************************************\r\n *\r\n * AVIFMT - AVI file format definitions\r\n *\r\n ****************************************************************************)\r\n\r\n//\r\n// The following is a short description of the AVI file format. Please\r\n// see the accompanying documentation for a full explanation.\r\n//\r\n// An AVI file is the following RIFF form:\r\n//\r\n// RIFF('AVI'\r\n// LIST('hdrl'\r\n// avih()\r\n// LIST ('strl'\r\n// strh()\r\n// strf()\r\n// ... additional header data\r\n// LIST('movi'\r\n// { LIST('rec'\r\n// SubChunk...\r\n// )\r\n// | SubChunk } ....\r\n// )\r\n// [ ]\r\n// )\r\n//\r\n// The main file header specifies how many streams are present. For\r\n// each one, there must be a stream header chunk and a stream format\r\n// chunk, enlosed in a 'strl' LIST chunk. The 'strf' chunk contains\r\n// type-specific format information; for a video stream, this should\r\n// be a BITMAPINFO structure, including palette. For an audio stream,\r\n// this should be a WAVEFORMAT (or PCMWAVEFORMAT) structure.\r\n//\r\n// The actual data is contained in subchunks within the 'movi' LIST\r\n// chunk. The first two characters of each data chunk are the\r\n// stream number with which that data is associated.\r\n//\r\n// Some defined chunk types:\r\n// Video Streams:\r\n// ##db: RGB DIB bits\r\n// ##dc: RLE8 compressed DIB bits\r\n// ##pc: Palette Change\r\n//\r\n// Audio Streams:\r\n// ##wb: waveform audio bytes\r\n//\r\n// The grouping into LIST 'rec' chunks implies only that the contents of\r\n// the chunk should be read into memory at the same time. This\r\n// grouping is used for files specifically intended to be played from\r\n// CD-ROM.\r\n//\r\n// The index chunk at the end of the file should contain one entry for\r\n// each data chunk in the file.\r\n//\r\n// Limitations for the current software:\r\n// Only one video stream and one audio stream are allowed.\r\n// The streams must start at the beginning of the file.\r\n//\r\n//\r\n// To register codec types please obtain a copy of the Multimedia\r\n// Developer Registration Kit from:\r\n//\r\n// Microsoft Corporation\r\n// Multimedia Systems Group\r\n// Product Marketing\r\n// One Microsoft Way\r\n// Redmond, WA 98052-6399\r\n//\r\n\r\n{-- form types, list types and chunk types -----------------------------------}\r\n\r\nconst\r\n formtypeAVI = $20495641; // mmioFOURCC('A', 'V', 'I', ' ')\r\n listtypeAVIHEADER = $6C726468; // mmioFOURCC('h', 'd', 'r', 'l')\r\n ckidAVIMAINHDR = $68697661; // mmioFOURCC('a', 'v', 'i', 'h')\r\n listtypeSTREAMHEADER = $6C727473; // mmioFOURCC('s', 't', 'r', 'l')\r\n ckidSTREAMHEADER = $68727473; // mmioFOURCC('s', 't', 'r', 'h')\r\n ckidSTREAMFORMAT = $66727473; // mmioFOURCC('s', 't', 'r', 'f')\r\n ckidSTREAMHANDLERDATA = $64727473; // mmioFOURCC('s', 't', 'r', 'd')\r\n ckidSTREAMNAME = $6E727473; // mmioFOURCC('s', 't', 'r', 'n')\r\n\r\n listtypeAVIMOVIE = $69766F6D; // mmioFOURCC('m', 'o', 'v', 'i')\r\n listtypeAVIRECORD = $20636572; // mmioFOURCC('r', 'e', 'c', ' ')\r\n\r\n ckidAVINEWINDEX = $31786469; // mmioFOURCC('i', 'd', 'x', '1')\r\n\r\n{-- Stream types for the field of the stream header ----------------}\r\n\r\n streamtypeVIDEO = $73646976; // mmioFOURCC('v', 'i', 'd', 's')\r\n streamtypeAUDIO = $73647561; // mmioFOURCC('a', 'u', 'd', 's')\r\n streamtypeMIDI = $7364696D; // mmioFOURCC('m', 'i', 'd', 's')\r\n streamtypeTEXT = $73747874; // mmioFOURCC('t', 'x', 't', 's')\r\n\r\n{-- Basic chunk types --------------------------------------------------------}\r\n\r\n cktypeDIBbits = $6264; // aviTWOCC('d', 'b')\r\n cktypeDIBcompressed = $6364; // aviTWOCC('d', 'c')\r\n cktypePALchange = $6370; // aviTWOCC('p', 'c')\r\n cktypeWAVEbytes = $6277; // aviTWOCC('w', 'b')\r\n\r\n{-- Chunk id to use for extra chunks for padding -----------------------------}\r\n\r\n ckidAVIPADDING = $4B4E554A; // mmioFOURCC('J', 'U', 'N', 'K')\r\n\r\n(*\r\n** Useful macros\r\n**\r\n** Warning: These are nasty macro, and MS C 6.0 compiles some of them\r\n** incorrectly if optimizations are on. Ack.\r\n*)\r\n\r\n{-- Macro to get stream number out of a FOURCC ckid --------------------------}\r\n\r\nfunction FromHex(n: BYTE): BYTE;\r\nfunction StreamFromFOURCC(fcc: DWORD): BYTE;\r\n\r\n{-- Macro to get TWOCC chunk type out of a FOURCC ckid -----------------------}\r\n\r\nfunction TWOCCFromFOURCC(fcc: DWORD): WORD;\r\n\r\n{-- Macro to make a ckid for a chunk out of a TWOCC and a stream num (0-255) -}\r\n\r\nfunction ToHex(n: BYTE): BYTE;\r\nfunction MAKEAVICKID(tcc: WORD; stream: BYTE): DWORD;\r\n\r\n{-- Main AVI file header -----------------------------------------------------}\r\n\r\n{-- flags for use in in AVIFileHdr ---------------------------------}\r\n\r\nconst\r\n AVIF_HASINDEX = $00000010; // Index at end of file?\r\n AVIF_MUSTUSEINDEX = $00000020;\r\n AVIF_ISINTERLEAVED = $00000100;\r\n AVIF_TRUSTCKTYPE = $00000800; // Use CKType to find key frames?\r\n AVIF_WASCAPTUREFILE = $00010000;\r\n AVIF_COPYRIGHTED = $00020000;\r\n\r\n{-- The AVI File Header LIST chunk should be padded to this size -------------}\r\n\r\nconst\r\n AVI_HEADERSIZE = 2048; // size of AVI header list\r\n\r\ntype\r\n PMainAVIHeader = ^TMainAVIHeader;\r\n TMainAVIHeader = packed record\r\n dwMicroSecPerFrame : DWORD; // frame display rate (or 0L)\r\n dwMaxBytesPerSec : DWORD; // max. transfer rate\r\n dwPaddingGranularity : DWORD; // pad to multiples of this\r\n // size; normally 2K.\r\n dwFlags : DWORD; // the ever-present flags\r\n dwTotalFrames : DWORD; // # frames in file\r\n dwInitialFrames : DWORD;\r\n dwStreams : DWORD;\r\n dwSuggestedBufferSize : DWORD;\r\n\r\n dwWidth : DWORD;\r\n dwHeight : DWORD;\r\n\r\n dwReserved : array[0..3] of DWORD;\r\n end;\r\n\r\n{-- Stream header ------------------------------------------------------------}\r\n\r\nconst\r\n AVISF_DISABLED = $00000001;\r\n\r\n AVISF_VIDEO_PALCHANGES = $00010000;\r\n\r\ntype\r\n PAVIStreamHeader = ^TAVIStreamHeader;\r\n TAVIStreamHeader = packed record\r\n fccType : FOURCC;\r\n fccHandler : FOURCC;\r\n dwFlags : DWORD; // Contains AVITF_* flags\r\n wPriority : WORD;\r\n wLanguage : WORD;\r\n dwInitialFrames : DWORD;\r\n dwScale : DWORD;\r\n dwRate : DWORD; // dwRate / dwScale == samples/second\r\n dwStart : DWORD;\r\n dwLength : DWORD; // In units above...\r\n dwSuggestedBufferSize : DWORD;\r\n dwQuality : DWORD;\r\n dwSampleSize : DWORD;\r\n rcFrame : TRECT;\r\n end;\r\n\r\n{-- Flags for index ----------------------------------------------------------}\r\n\r\nconst\r\n AVIIF_NOTIME = $00000100; // this frame doesn't take any time\r\n AVIIF_COMPUSE = $0FFF0000; // these bits are for compressor use\r\n\r\ntype\r\n PAVIINDEXENTRY = ^TAVIINDEXENTRY;\r\n TAVIINDEXENTRY = packed record\r\n ckid : DWORD;\r\n dwFlags : DWORD;\r\n dwChunkOffset : DWORD; // Position of chunk\r\n dwChunkLength : DWORD; // Length of chunk\r\n end;\r\n\r\n{-- Palette change chunk (used in video streams) -----------------------------}\r\n\r\n PAVIPALCHANGE = ^TAVIPALCHANGE;\r\n TAVIPALCHANGE = packed record\r\n bFirstEntry : BYTE; // first entry to change\r\n bNumEntries : BYTE; // # entries to change (0 if 256)\r\n wFlags : WORD; // Mostly to preserve alignment...\r\n peNew : array [0..0] of TPaletteEntry; // New color specifications\r\n end;\r\n\r\n(****************************************************************************\r\n *\r\n * AVIFile - routines for reading/writing standard AVI files\r\n *\r\n ***************************************************************************)\r\n\r\n//\r\n// Ansi - Unicode thunking.\r\n//\r\n// Unicode or Ansi-only apps can call the avifile APIs.\r\n// any Win32 app who wants to use\r\n// any of the AVI COM interfaces must be UNICODE - the AVISTREAMINFO and\r\n// AVIFILEINFO structures used in the Info methods of these interfaces are\r\n// the unicode variants, and no thunking to or from ansi takes place\r\n// except in the AVIFILE api entrypoints.\r\n//\r\n// For Ansi/Unicode thunking: for each entrypoint or structure that\r\n// uses chars or strings, two versions are declared in the Win32 version,\r\n// ApiNameW and ApiNameA. The default name ApiName is #defined to one or\r\n// other of these depending on whether UNICODE is defined (during\r\n// compilation of the app that is including this header). The source will\r\n// contain ApiName and ApiNameA (with ApiName being the Win16 implementation,\r\n// and also #defined to ApiNameW, and ApiNameA being the thunk entrypoint).\r\n//\r\n\r\n// For GetFrame::SetFormat - use the best format for the display\r\n\r\nconst\r\n AVIGETFRAMEF_BESTDISPLAYFMT = 1;\r\n\r\n//\r\n// Structures used by AVIStreamInfo & AVIFileInfo.\r\n//\r\n// These are related to, but not identical to, the header chunks\r\n// in an AVI file.\r\n//\r\n\r\n{-- AVISTREAMINFO ------------------------------------------------------------}\r\n\r\n// for Unicode/Ansi thunking we need to declare three versions of this!\r\n\r\ntype\r\n PAVIStreamInfoW = ^TAVIStreamInfoW;\r\n TAVIStreamInfoW = packed record\r\n fccType : DWORD;\r\n fccHandler : DWORD;\r\n dwFlags : DWORD; // Contains AVITF_* flags\r\n dwCaps : DWORD;\r\n wPriority : WORD;\r\n wLanguage : WORD;\r\n dwScale : DWORD;\r\n dwRate : DWORD; // dwRate / dwScale == samples/second\r\n dwStart : DWORD;\r\n dwLength : DWORD; // In units above...\r\n dwInitialFrames : DWORD;\r\n dwSuggestedBufferSize : DWORD;\r\n dwQuality : DWORD;\r\n dwSampleSize : DWORD;\r\n rcFrame : TRECT;\r\n dwEditCount : DWORD;\r\n dwFormatChangeCount : DWORD;\r\n szName : array[0..63] of WideChar;\r\n end;\r\n\r\n PAVIStreamInfoA = ^TAVIStreamInfoA;\r\n TAVIStreamInfoA = packed record\r\n fccType : DWORD;\r\n fccHandler : DWORD;\r\n dwFlags : DWORD; // Contains AVITF_* flags\r\n dwCaps : DWORD;\r\n wPriority : WORD;\r\n wLanguage : WORD;\r\n dwScale : DWORD;\r\n dwRate : DWORD; // dwRate / dwScale == samples/second\r\n dwStart : DWORD;\r\n dwLength : DWORD; // In units above...\r\n dwInitialFrames : DWORD;\r\n dwSuggestedBufferSize : DWORD;\r\n dwQuality : DWORD;\r\n dwSampleSize : DWORD;\r\n rcFrame : TRECT;\r\n dwEditCount : DWORD;\r\n dwFormatChangeCount : DWORD;\r\n szName : array[0..63] of AnsiChar;\r\n end;\r\n\r\n PAVIStreamInfo = ^TAVIStreamInfo;\r\n {$IFDEF UNICODE}\r\n TAVIStreamInfo = TAVIStreamInfoW;\r\n {$ELSE}\r\n TAVIStreamInfo = TAVIStreamInfoA;\r\n {$ENDIF UNICODE}\r\n\r\nconst\r\n AVISTREAMINFO_DISABLED = $00000001;\r\n AVISTREAMINFO_FORMATCHANGES = $00010000;\r\n\r\n{-- AVIFILEINFO --------------------------------------------------------------}\r\n\r\ntype\r\n PAVIFileInfoW = ^TAVIFileInfoW;\r\n TAVIFileInfoW = packed record\r\n dwMaxBytesPerSec : DWORD; // max. transfer rate\r\n dwFlags : DWORD; // the ever-present flags\r\n dwCaps : DWORD;\r\n dwStreams : DWORD;\r\n dwSuggestedBufferSize : DWORD;\r\n\r\n dwWidth : DWORD;\r\n dwHeight : DWORD;\r\n\r\n dwScale : DWORD;\r\n dwRate : DWORD; // dwRate / dwScale == samples/second\r\n dwLength : DWORD;\r\n\r\n dwEditCount : DWORD;\r\n\r\n szFileType : array[0..63] of WideChar;\r\n // descriptive string for file type?\r\n end;\r\n\r\n PAVIFileInfoA = ^TAVIFileInfoA;\r\n TAVIFileInfoA = packed record\r\n dwMaxBytesPerSec : DWORD; // max. transfer rate\r\n dwFlags : DWORD; // the ever-present flags\r\n dwCaps : DWORD;\r\n dwStreams : DWORD;\r\n dwSuggestedBufferSize : DWORD;\r\n\r\n dwWidth : DWORD;\r\n dwHeight : DWORD;\r\n\r\n dwScale : DWORD;\r\n dwRate : DWORD; // dwRate / dwScale == samples/second\r\n dwLength : DWORD;\r\n\r\n dwEditCount : DWORD;\r\n\r\n szFileType : array[0..63] of AnsiChar;\r\n // descriptive string for file type?\r\n end;\r\n\r\n PAVIFileInfo = ^TAVIFileInfo;\r\n {$IFDEF UNICODE}\r\n TAVIFileInfo = TAVIFileInfoW;\r\n {$ELSE}\r\n TAVIFileInfo = TAVIFileInfoA;\r\n {$ENDIF UNICODE}\r\n\r\n{-- Flags for dwFlags --------------------------------------------------------}\r\n\r\nconst\r\n AVIFILEINFO_HASINDEX = $00000010;\r\n AVIFILEINFO_MUSTUSEINDEX = $00000020;\r\n AVIFILEINFO_ISINTERLEAVED = $00000100;\r\n AVIFILEINFO_WASCAPTUREFILE = $00010000;\r\n AVIFILEINFO_COPYRIGHTED = $00020000;\r\n\r\n{-- Flags for dwCaps ---------------------------------------------------------}\r\n\r\n AVIFILECAPS_CANREAD = $00000001;\r\n AVIFILECAPS_CANWRITE = $00000002;\r\n AVIFILECAPS_ALLKEYFRAMES = $00000010;\r\n AVIFILECAPS_NOCOMPRESSION = $00000020;\r\n\r\ntype\r\n TAVISAVECALLBACK = function(i: int): BOOL; pascal;\r\n\r\n{-- AVICOMPRESSOPTIONS -------------------------------------------------------}\r\n\r\n// Make sure it matches the AutoDoc in avisave.c !!!\r\n\r\ntype\r\n PAVICOMPRESSOPTIONS = ^TAVICOMPRESSOPTIONS;\r\n TAVICOMPRESSOPTIONS = packed record\r\n fccType : DWORD; // stream type, for consistency\r\n fccHandler : DWORD; // compressor\r\n dwKeyFrameEvery : DWORD; // keyframe rate\r\n dwQuality : DWORD; // compress quality 0-10,000\r\n dwBytesPerSecond : DWORD; // bytes per second\r\n dwFlags : DWORD; // flags... see below\r\n lpFormat : PVOID; // save format\r\n cbFormat : DWORD;\r\n lpParms : PVOID; // compressor options\r\n cbParms : DWORD;\r\n dwInterleaveEvery : DWORD; // for non-video streams only\r\n end;\r\n\r\n//\r\n// Defines for the dwFlags field of the AVICOMPRESSOPTIONS struct\r\n// Each of these flags determines if the appropriate field in the structure\r\n// (dwInterleaveEvery, dwBytesPerSecond, and dwKeyFrameEvery) is payed\r\n// attention to. See the autodoc in avisave.c for details.\r\n//\r\n\r\nconst\r\n AVICOMPRESSF_INTERLEAVE = $00000001; // interleave\r\n AVICOMPRESSF_DATARATE = $00000002; // use a data rate\r\n AVICOMPRESSF_KEYFRAMES = $00000004; // use keyframes\r\n AVICOMPRESSF_VALID = $00000008; // has valid data?\r\n\r\n(****** AVI Stream Interface *******************************************)\r\n\r\ntype\r\n IAVIStream = interface(IUnknown)\r\n function Create(lParam1, lParam2: LPARAM): HResult; stdcall;\r\n function Info(var psi: TAVIStreamInfoW; lSize: LONG): HResult; stdcall;\r\n function FindSample(lPos: LONG; lFlags: LONG): LONG; stdcall;\r\n function ReadFormat(lPos: LONG; lpFormat: PVOID; var lpcbFormat: LONG): HResult; stdcall;\r\n function SetFormat(lPos: LONG; lpFormat: PVOID; cbFormat: LONG): HResult; stdcall;\r\n function Read(lStart: LONG; lSamples: LONG; lpBuffer: PVOID; cbBuffer: LONG; var plBytes, plSamples: LONG): HResult; stdcall;\r\n function Write(lStart: LONG; lSamples: LONG; lpBuffer: PVOID; cbBuffer: LONG; dwFlags: DWORD; var plSampWritten, plBytesWritten: LONG): HResult; stdcall;\r\n function Delete(lStart: LONG; lSamples: LONG): HResult; stdcall;\r\n function ReadData(fcc: DWORD; lp: PVOID; var lpcb: LONG): HResult; stdcall;\r\n function WriteData(fcc: DWORD; lp: PVOID; cb: LONG): HResult; stdcall;\r\n function SetInfo(var lpInfo: TAVIStreamInfoW; cbInfo: LONG): HResult; stdcall;\r\n end;\r\n\r\n IAVIStreaming = interface(IUnknown)\r\n function _Begin(lStart, lEnd : LONG; lRate : LONG): HResult; stdcall;\r\n function _End: HResult; stdcall;\r\n end;\r\n\r\n IAVIEditStream = interface(IUnknown)\r\n function Cut(var plStart, plLength: LONG; var ppResult: IAVIStream): HResult; stdcall;\r\n function Copy(var plStart, plLength: LONG; var ppResult: IAVIStream): HResult; stdcall;\r\n function Paste(var plPos: LONG; var plLength: LONG; pstream: IAVIStream; lStart, lEnd: LONG): HResult; stdcall;\r\n function Clone(var ppResult: IAVIStream): HResult; stdcall;\r\n function SetInfo(var lpInfo: TAVIStreamInfoW; cbInfo: LONG): HResult; stdcall;\r\n end;\r\n\r\n{-- AVIFile ------------------------------------------------------------------}\r\n\r\n IAVIFile = interface(IUnknown)\r\n function Info(var pfi: TAVIFileInfoW; iSize: LONG): HResult; stdcall;\r\n function GetStream(var ppStream: IAVISTREAM; fccType: DWORD; lParam: LONG): HResult; stdcall;\r\n function CreateStream(var ppStream: IAVISTREAM; var psi: TAVIStreamInfoW): HResult; stdcall;\r\n function WriteData(ckid: DWORD; lpData: PVOID; cbData: LONG): HResult; stdcall;\r\n function ReadData(ckid: DWORD; lpData: PVOID; lpcbData: PLONG): HResult; stdcall;\r\n function EndRecord: HResult; stdcall;\r\n function DeleteStream(fccType: DWORD; lParam: LONG): HResult; stdcall;\r\n end;\r\n\r\n{-- GetFrame -----------------------------------------------------------------}\r\n\r\n // The functions 'BeginExtraction' and 'EndExtraction' have actually\r\n // the names 'Begin' and 'End', but we cannot use that identifiers for\r\n // obvious reasons.\r\n\r\n IGetFrame = interface(IUnknown)\r\n function GetFrame(lPos: LONG): PBitmapInfoHeader; stdcall;\r\n function BeginExtraction(lStart, lEnd, lRate: LONG): HResult; stdcall;\r\n function EndExtraction: HResult; stdcall;\r\n function SetFormat(var lpbi: TBitmapInfoHeader; lpBits: Pointer; x, y, dx, dy: Integer): HResult; stdcall;\r\n end;\r\n\r\n{-- GUIDs --------------------------------------------------------------------}\r\n\r\nconst\r\n IID_IAVIFile : TGUID = (D1: $00020020; D2: $0; D3: $0; D4:($C0,$0,$0,$0,$0,$0,$0,$46));\r\n IID_IAVIStream : TGUID = (D1: $00020021; D2: $0; D3: $0; D4:($C0,$0,$0,$0,$0,$0,$0,$46));\r\n IID_IAVIStreaming : TGUID = (D1: $00020022; D2: $0; D3: $0; D4:($C0,$0,$0,$0,$0,$0,$0,$46));\r\n IID_IGetFrame : TGUID = (D1: $00020023; D2: $0; D3: $0; D4:($C0,$0,$0,$0,$0,$0,$0,$46));\r\n IID_IAVIEditStream: TGUID = (D1: $00020024; D2: $0; D3: $0; D4:($C0,$0,$0,$0,$0,$0,$0,$46));\r\n\r\n CLSID_AVISimpleUnMarshal : TGUID = (D1: $00020009; D2: $0; D3: $0; D4:($C0,$0,$0,$0,$0,$0,$0,$46));\r\n CLSID_AVIFile : TGUID = (D1: $00020000; D2: $0; D3: $0; D4:($C0,$0,$0,$0,$0,$0,$0,$46));\r\n\r\n AVIFILEHANDLER_CANREAD = $0001;\r\n AVIFILEHANDLER_CANWRITE = $0002;\r\n AVIFILEHANDLER_CANACCEPTNONRGB = $0004;\r\n\r\n{-- Functions ----------------------------------------------------------------}\r\n\r\nprocedure AVIFileInit; stdcall; // Call this first!\r\nprocedure AVIFileExit; stdcall;\r\n\r\nfunction AVIFileAddRef(pfile: IAVIFile): ULONG; stdcall;\r\nfunction AVIFileRelease(pfile: IAVIFile): ULONG; stdcall;\r\n\r\nfunction AVIFileOpenA(var ppfile: IAVIFile; szFile: LPCSTR; uMode: UINT; lpHandler: PCLSID): HResult; stdcall;\r\nfunction AVIFileOpenW(var ppfile: IAVIFile; szFile: LPCWSTR; uMode: UINT; lpHandler: PCLSID): HResult; stdcall;\r\n\r\n{$IFDEF UNICODE}\r\nfunction AVIFileOpen(var ppfile: IAVIFile; szFile: LPCWSTR; uMode: UINT; lpHandler: PCLSID): HResult; stdcall;\r\n{$ELSE}\r\nfunction AVIFileOpen(var ppfile: IAVIFile; szFile: LPCSTR; uMode: UINT; lpHandler: PCLSID): HResult; stdcall;\r\n{$ENDIF UNICODE}\r\n\r\nfunction AVIFileInfoW(pfile: IAVIFile; var pfi: TAVIFILEINFOW; lSize: LONG): HResult; stdcall;\r\nfunction AVIFileInfoA(pfile: IAVIFile; var pfi: TAVIFILEINFOA; lSize: LONG): HResult; stdcall;\r\n\r\nfunction AVIFileInfo(pfile: IAVIFile; var pfi: TAVIFILEINFO; lSize: LONG): HResult; stdcall;\r\n\r\nfunction AVIFileGetStream(pfile: IAVIFile; var ppavi: IAVISTREAM; fccType: DWORD; lParam: LONG): HResult; stdcall;\r\n\r\nfunction AVIFileCreateStreamW(pfile: IAVIFile; var ppavi: IAVISTREAM; var psi: TAVISTREAMINFOW): HResult; stdcall;\r\nfunction AVIFileCreateStreamA(pfile: IAVIFile; var ppavi: IAVISTREAM; var psi: TAVISTREAMINFOA): HResult; stdcall;\r\n\r\nfunction AVIFileCreateStream(pfile: IAVIFile; var ppavi: IAVISTREAM; var psi: TAVISTREAMINFO): HResult; stdcall;\r\n\r\nfunction AVIFileWriteData(pfile: IAVIFile; ckid: DWORD; lpData: PVOID; cbData: LONG): HResult; stdcall;\r\nfunction AVIFileReadData(pfile: IAVIFile; ckid: DWORD; lpData: PVOID; var lpcbData: LONG): HResult; stdcall;\r\nfunction AVIFileEndRecord(pfile: IAVIFile): HResult; stdcall;\r\n\r\nfunction AVIStreamAddRef(pavi: IAVIStream): ULONG; stdcall;\r\nfunction AVIStreamRelease(pavi: IAVIStream): ULONG; stdcall;\r\n\r\nfunction AVIStreamInfoW (pavi: IAVIStream; var psi: TAVISTREAMINFOW; lSize: LONG): HResult; stdcall;\r\nfunction AVIStreamInfoA (pavi: IAVIStream; var psi: TAVISTREAMINFOA; lSize: LONG): HResult; stdcall;\r\n\r\nfunction AVIStreamInfo(pavi: IAVIStream; var psi: TAVISTREAMINFO; lSize: LONG): HResult; stdcall;\r\n\r\nfunction AVIStreamFindSample(pavi: IAVIStream; lPos: LONG; lFlags: LONG): LONG; stdcall;\r\nfunction AVIStreamReadFormat(pavi: IAVIStream; lPos: LONG; lpFormat: PVOID; lpcbFormat: PLONG): HResult; stdcall;\r\nfunction AVIStreamSetFormat(pavi: IAVIStream; lPos: LONG; lpFormat: PVOID; cbFormat: LONG): HResult; stdcall;\r\nfunction AVIStreamReadData(pavi: IAVIStream; fcc: DWORD; lp: PVOID; lpcb: PLONG): HResult; stdcall;\r\nfunction AVIStreamWriteData(pavi: IAVIStream; fcc: DWORD; lp: PVOID; cb: LONG): HResult; stdcall;\r\n\r\nfunction AVIStreamRead(\r\n pavi : IAVISTREAM;\r\n lStart : LONG;\r\n lSamples : LONG;\r\n lpBuffer : PVOID;\r\n cbBuffer : LONG;\r\n plBytes : PLONG;\r\n plSamples : PLONG\r\n ): HResult; stdcall;\r\n\r\nconst\r\n AVISTREAMREAD_CONVENIENT = -1;\r\n\r\nfunction AVIStreamWrite(\r\n pavi : IAVISTREAM;\r\n lStart : LONG;\r\n lSamples : LONG;\r\n lpBuffer : PVOID;\r\n cbBuffer : LONG;\r\n dwFlags : DWORD;\r\n plSampWritten : PLONG;\r\n plBytesWritten : PLONG\r\n ): HResult; stdcall;\r\n\r\n// Right now, these just use AVIStreamInfo() to get information, then\r\n// return some of it. Can they be more efficient?\r\n\r\nfunction AVIStreamStart(pavi: IAVIStream): LONG; stdcall;\r\nfunction AVIStreamLength(pavi: IAVIStream): LONG; stdcall;\r\nfunction AVIStreamTimeToSample(pavi: IAVIStream; lTime: LONG): LONG; stdcall;\r\nfunction AVIStreamSampleToTime(pavi: IAVIStream; lSample: LONG): LONG; stdcall;\r\n\r\nfunction AVIStreamBeginStreaming(pavi: IAVIStream; lStart, lEnd: LONG; lRate: LONG): HResult; stdcall;\r\nfunction AVIStreamEndStreaming(pavi: IAVIStream): HResult; stdcall;\r\n\r\n{-- Helper functions for using IGetFrame -------------------------------------}\r\n\r\nfunction AVIStreamGetFrameOpen(pavi: IAVIStream; lpbiWanted: PBitmapInfoHeader): IGetFrame; stdcall;\r\nfunction AVIStreamGetFrame(pg: IGetFrame; lPos: LONG): PBitmapInfoHeader; stdcall;\r\nfunction AVIStreamGetFrameClose(pg: IGetFrame): HResult; stdcall;\r\n\r\n// !!! We need some way to place an advise on a stream....\r\n// STDAPI AVIStreamHasChanged (PAVISTREAM pavi);\r\n\r\n{-- Shortcut function --------------------------------------------------------}\r\n\r\nfunction AVIStreamOpenFromFileA(var ppavi: IAVISTREAM; szFile: LPCSTR; fccType: DWORD;\r\n lParam: LONG; mode: UINT; pclsidHandler: PCLSID): HResult; stdcall;\r\nfunction AVIStreamOpenFromFileW(var ppavi: IAVISTREAM; szFile: LPCWSTR; fccType: DWORD;\r\n lParam: LONG; mode: UINT; pclsidHandler: PCLSID): HResult; stdcall;\r\n\r\n{$IFDEF UNICODE}\r\nfunction AVIStreamOpenFromFile(var ppavi: IAVISTREAM; szFile: LPCWSTR; fccType: DWORD;\r\n lParam: LONG; mode: UINT; pclsidHandler: PCLSID): HResult; stdcall;\r\n{$ELSE}\r\nfunction AVIStreamOpenFromFile(var ppavi: IAVISTREAM; szFile: LPCSTR; fccType: DWORD;\r\n lParam: LONG; mode: UINT; pclsidHandler: PCLSID): HResult; stdcall;\r\n{$ENDIF UNICODE}\r\n\r\n{-- Use to create disembodied streams ----------------------------------------}\r\n\r\nfunction AVIStreamCreate(var ppavi: IAVISTREAM; lParam1, lParam2: LONG; pclsidHandler: PCLSID): HResult; stdcall;\r\n\r\n// PHANDLER AVIAPI AVIGetHandler (PAVISTREAM pavi, PAVISTREAMHANDLER psh);\r\n// PAVISTREAM AVIAPI AVIGetStream (PHANDLER p);\r\n\r\n{-- Flags for AVIStreamFindSample --------------------------------------------}\r\n\r\nconst\r\n FIND_DIR = $0000000F; // direction\r\n FIND_NEXT = $00000001; // go forward\r\n FIND_PREV = $00000004; // go backward\r\n FIND_FROM_START = $00000008; // start at the logical beginning\r\n\r\n FIND_TYPE = $000000F0; // type mask\r\n FIND_KEY = $00000010; // find key frame.\r\n FIND_ANY = $00000020; // find any (non-empty) sample\r\n FIND_FORMAT = $00000040; // find format change\r\n\r\n FIND_RET = $0000F000; // return mask\r\n FIND_POS = $00000000; // return logical position\r\n FIND_LENGTH = $00001000; // return logical size\r\n FIND_OFFSET = $00002000; // return physical position\r\n FIND_SIZE = $00003000; // return physical size\r\n FIND_INDEX = $00004000; // return physical index position\r\n\r\n{-- Stuff to support backward compat. ----------------------------------------}\r\n\r\nfunction AVIStreamFindKeyFrame(var pavi: IAVISTREAM; lPos: LONG; lFlags: LONG): DWORD; stdcall; // AVIStreamFindSample\r\n\r\n// Non-portable: this is alias for method name\r\n// FindKeyFrame FindSample\r\n\r\nfunction AVIStreamClose(pavi: IAVISTREAM): ULONG; stdcall; // AVIStreamRelease\r\nfunction AVIFileClose(pfile: IAVIFILE): ULONG; stdcall; // AVIFileRelease\r\nprocedure AVIStreamInit; stdcall; // AVIFileInit\r\nprocedure AVIStreamExit; stdcall; // AVIFileExit\r\n\r\nconst\r\n SEARCH_NEAREST = FIND_PREV;\r\n SEARCH_BACKWARD = FIND_PREV;\r\n SEARCH_FORWARD = FIND_NEXT;\r\n SEARCH_KEY = FIND_KEY;\r\n SEARCH_ANY = FIND_ANY;\r\n\r\n{-- Helper macros ------------------------------------------------------------}\r\n\r\nfunction AVIStreamSampleToSample(pavi1, pavi2: IAVISTREAM; l: LONG): LONG;\r\nfunction AVIStreamNextSample(pavi: IAVISTREAM; l: LONG): LONG;\r\nfunction AVIStreamPrevSample(pavi: IAVISTREAM; l: LONG): LONG;\r\nfunction AVIStreamNearestSample(pavi: IAVISTREAM; l: LONG): LONG;\r\nfunction AVIStreamNextKeyFrame(pavi: IAVISTREAM; l: LONG): LONG;\r\nfunction AVIStreamPrevKeyFrame(pavi: IAVISTREAM; l: LONG): LONG;\r\nfunction AVIStreamNearestKeyFrame(pavi: IAVISTREAM; l: LONG): LONG;\r\nfunction AVIStreamIsKeyFrame(pavi: IAVISTREAM; l: LONG): BOOL;\r\nfunction AVIStreamPrevSampleTime(pavi: IAVISTREAM; t: LONG): LONG;\r\nfunction AVIStreamNextSampleTime(pavi: IAVISTREAM; t: LONG): LONG;\r\nfunction AVIStreamNearestSampleTime(pavi: IAVISTREAM; t: LONG): LONG;\r\nfunction AVIStreamNextKeyFrameTime(pavi: IAVISTREAM; t: LONG): LONG;\r\nfunction AVIStreamPrevKeyFrameTime(pavi: IAVISTREAM; t: LONG): LONG;\r\nfunction AVIStreamNearestKeyFrameTime(pavi: IAVISTREAM; t: LONG): LONG;\r\nfunction AVIStreamStartTime(pavi: IAVISTREAM): LONG;\r\nfunction AVIStreamLengthTime(pavi: IAVISTREAM): LONG;\r\nfunction AVIStreamEnd(pavi: IAVISTREAM): LONG;\r\nfunction AVIStreamEndTime(pavi: IAVISTREAM): LONG;\r\nfunction AVIStreamSampleSize(pavi: IAVISTREAM; lPos: LONG; plSize: PLONG): LONG;\r\nfunction AVIStreamFormatSize(pavi: IAVISTREAM; lPos: LONG; plSize: PLONG): HResult;\r\nfunction AVIStreamDataSize(pavi: IAVISTREAM; fcc: DWORD; plSize: PLONG): HResult;\r\n\r\n{== AVISave routines and structures ==========================================}\r\n\r\nconst\r\n comptypeDIB = $20424944; // mmioFOURCC('D', 'I', 'B', ' ')\r\n\r\nfunction AVIMakeCompressedStream(\r\n var ppsCompressed : IAVISTREAM;\r\n ppsSource : IAVISTREAM;\r\n lpOptions : PAVICOMPRESSOPTIONS;\r\n pclsidHandler : PCLSID\r\n ): HResult; stdcall;\r\n\r\n// Non-portable: uses variable number of params\r\n// EXTERN_C HRESULT CDECL AVISaveA (LPCSTR szFile,\r\n// CLSID FAR *pclsidHandler,\r\n// AVISAVECALLBACK lpfnCallback,\r\n// int nStreams,\r\n// PAVISTREAM pfile,\r\n// LPAVICOMPRESSOPTIONS lpOptions,\r\n// ...);\r\n\r\nfunction AVISaveVA(\r\n szFile : LPCSTR;\r\n pclsidHandler : PCLSID;\r\n lpfnCallback : TAVISAVECALLBACK;\r\n nStreams : int;\r\n var ppavi : IAVISTREAM;\r\n var plpOptions : PAVICOMPRESSOPTIONS\r\n ): HResult; stdcall;\r\n\r\n// Non-portable: uses variable number of params\r\n// EXTERN_C HRESULT CDECL AVISaveW (LPCWSTR szFile,\r\n// CLSID FAR *pclsidHandler,\r\n// AVISAVECALLBACK lpfnCallback,\r\n// int nStreams,\r\n// PAVISTREAM pfile,\r\n// LPAVICOMPRESSOPTIONS lpOptions,\r\n// ...);\r\n\r\nfunction AVISaveVW(\r\n szFile : LPCWSTR;\r\n pclsidHandler : PCLSID;\r\n lpfnCallback : TAVISAVECALLBACK;\r\n nStreams : int;\r\n var ppavi : IAVISTREAM;\r\n var plpOptions : PAVICOMPRESSOPTIONS\r\n ): HResult; stdcall;\r\n\r\n// #define AVISave AVISaveA\r\n\r\nfunction AVISaveV(\r\n szFile : LPCSTR;\r\n pclsidHandler : PCLSID;\r\n lpfnCallback : TAVISAVECALLBACK;\r\n nStreams : int;\r\n var ppavi : IAVISTREAM;\r\n var plpOptions : PAVICOMPRESSOPTIONS\r\n ): HResult; stdcall; // AVISaveVA\r\n\r\nfunction AVISaveOptions(\r\n hwnd : HWND;\r\n uiFlags : UINT;\r\n nStreams : int;\r\n var ppavi : IAVISTREAM;\r\n var plpOptions : PAVICOMPRESSOPTIONS\r\n ): BOOL; stdcall;\r\n\r\nfunction AVISaveOptionsFree(nStreams: int; var plpOptions: PAVICOMPRESSOPTIONS): HResult; stdcall;\r\n\r\n{-- FLAGS FOR uiFlags --------------------------------------------------------}\r\n\r\n// Same as the flags for ICCompressorChoose (see compman.h)\r\n// These determine what the compression options dialog for video streams\r\n// will look like.\r\n\r\nfunction AVIBuildFilterW(lpszFilter: LPWSTR; cbFilter: LONG; fSaving: BOOL): HResult; stdcall;\r\nfunction AVIBuildFilterA(lpszFilter: LPSTR; cbFilter: LONG; fSaving: BOOL): HResult; stdcall;\r\n\r\nfunction AVIBuildFilter(lpszFilter: LPSTR; cbFilter: LONG; fSaving: BOOL): HResult; stdcall; // AVIBuildFilterA\r\n\r\nfunction AVIMakeFileFromStreams(var ppfile: IAVIFILE; nStreams: int; var papStreams: IAVISTREAM): HResult; stdcall;\r\n\r\nfunction AVIMakeStreamFromClipboard(cfFormat: UINT; hGlobal: THANDLE; var ppstream: IAVISTREAM): HResult; stdcall;\r\n\r\n{-- Clipboard routines -------------------------------------------------------}\r\n\r\nfunction AVIPutFileOnClipboard(pf: IAVIFILE): HResult; stdcall;\r\nfunction AVIGetFromClipboard(var lppf: IAVIFILE): HResult; stdcall;\r\nfunction AVIClearClipboard: HResult; stdcall;\r\n\r\n{-- Editing routines ---------------------------------------------------------}\r\n\r\nfunction CreateEditableStream(var ppsEditable: IAVISTREAM; psSource: IAVISTREAM): HResult; stdcall;\r\n\r\nfunction EditStreamCut(pavi: IAVISTREAM; var plStart, plLength: LONG; var ppResult: IAVISTREAM): HResult; stdcall;\r\n\r\nfunction EditStreamCopy(pavi: IAVISTREAM; var plStart, plLength: LONG; var ppResult: IAVISTREAM): HResult; stdcall;\r\n\r\nfunction EditStreamPaste(pavi: IAVISTREAM; var plPos, plLength: LONG; pstream: IAVISTREAM; lStart, lEnd: LONG): HResult; stdcall;\r\n\r\nfunction EditStreamClone(pavi: IAVISTREAM; var ppResult: IAVISTREAM): HResult; stdcall;\r\n\r\nfunction EditStreamSetNameA(pavi: IAVISTREAM; lpszName: LPCSTR): HResult; stdcall;\r\nfunction EditStreamSetNameW(pavi: IAVISTREAM; lpszName: LPCWSTR): HResult; stdcall;\r\nfunction EditStreamSetInfoW(pavi: IAVISTREAM; lpInfo: PAVISTREAMINFOW; cbInfo: LONG): HResult; stdcall;\r\nfunction EditStreamSetInfoA(pavi: IAVISTREAM; lpInfo: PAVISTREAMINFOA; cbInfo: LONG): HResult; stdcall;\r\n\r\nfunction EditStreamSetInfo(pavi: IAVISTREAM; lpInfo: PAVISTREAMINFOA; cbInfo: LONG): HResult; stdcall; // EditStreamSetInfoA\r\nfunction EditStreamSetName(pavi: IAVISTREAM; lpszName: LPCSTR): HResult; stdcall; // EditStreamSetNameA\r\n\r\n{-- Error handling -----------------------------------------------------------}\r\n\r\nconst\r\n AVIERR_OK = 0;\r\n\r\n// !!! Questions to be answered:\r\n// How can you get a string form of these errors?\r\n// Which of these errors should be replaced by errors in SCODE.H?\r\n\r\nconst\r\n AVIERR_UNSUPPORTED = $80044065; // MAKE_AVIERR(101)\r\n AVIERR_BADFORMAT = $80044066; // MAKE_AVIERR(102)\r\n AVIERR_MEMORY = $80044067; // MAKE_AVIERR(103)\r\n AVIERR_INTERNAL = $80044068; // MAKE_AVIERR(104)\r\n AVIERR_BADFLAGS = $80044069; // MAKE_AVIERR(105)\r\n AVIERR_BADPARAM = $8004406A; // MAKE_AVIERR(106)\r\n AVIERR_BADSIZE = $8004406B; // MAKE_AVIERR(107)\r\n AVIERR_BADHANDLE = $8004406C; // MAKE_AVIERR(108)\r\n AVIERR_FILEREAD = $8004406D; // MAKE_AVIERR(109)\r\n AVIERR_FILEWRITE = $8004406E; // MAKE_AVIERR(110)\r\n AVIERR_FILEOPEN = $8004406F; // MAKE_AVIERR(111)\r\n AVIERR_COMPRESSOR = $80044070; // MAKE_AVIERR(112)\r\n AVIERR_NOCOMPRESSOR = $80044071; // MAKE_AVIERR(113)\r\n AVIERR_READONLY = $80044072; // MAKE_AVIERR(114)\r\n AVIERR_NODATA = $80044073; // MAKE_AVIERR(115)\r\n AVIERR_BUFFERTOOSMALL = $80044074; // MAKE_AVIERR(116)\r\n AVIERR_CANTCOMPRESS = $80044075; // MAKE_AVIERR(117)\r\n AVIERR_USERABORT = $800440C6; // MAKE_AVIERR(198)\r\n AVIERR_ERROR = $800440C7; // MAKE_AVIERR(199)\r\n\r\n{== MCIWnd - Window class for MCI objects ====================================}\r\n\r\n//\r\n// MCIWnd\r\n//\r\n// MCIWnd window class header file.\r\n//\r\n// the MCIWnd window class is a window class for controling MCI devices\r\n// MCI devices include, wave files, midi files, AVI Video, cd audio,\r\n// vcr, video disc, and others..\r\n//\r\n// to learn more about MCI and mci command sets see the\r\n// \"Microsoft Multimedia Programmers's guide\" in the Win31 SDK\r\n//\r\n// the easiest use of the MCIWnd class is like so:\r\n//\r\n// hwnd = MCIWndCreate(hwndParent, hInstance, 0, \"chimes.wav\");\r\n// ...\r\n// MCIWndPlay(hwnd);\r\n// MCIWndStop(hwnd);\r\n// MCIWndPause(hwnd);\r\n// ....\r\n// MCIWndDestroy(hwnd);\r\n//\r\n// this will create a window with a play/pause, stop and a playbar\r\n// and start the wave file playing.\r\n//\r\n// mciwnd.h defines macros for all the most common MCI commands, but\r\n// any string command can be used if needed.\r\n//\r\n// Note: unlike the mciSendString() API, no alias or file name needs\r\n// to be specifed, since the device to use is implied by the window handle.\r\n//\r\n// MCIWndSendString(hwnd, \"setaudio stream to 2\");\r\n//\r\n// (C) Copyright Microsoft Corp. 1991-1995. All rights reserved.\r\n//\r\n// WIN32:\r\n//\r\n// MCIWnd supports both ansi and unicode interfaces. For any message that\r\n// takes or returns a text string, two versions of the message are defined,\r\n// appended with A or W for Ansi or Wide Char. The message or api itself\r\n// is defined to be one or other of these depending on whether you have\r\n// UNICODE defined in your application.\r\n// Thus for the api MCIWndCreate, there are in fact two apis,\r\n// MCIWndCreateA and MCIWndCreateW. If you call MCIWndCreate, this will be\r\n// re-routed to MCIWndCreateA unless UNICODE is defined when building your\r\n// application. In any one application, you can mix calls to the\r\n// Ansi and Unicode entrypoints.\r\n//\r\n// If you use SendMessage instead of the macros below such as MCIWndOpen(),\r\n// you will see that the messages have changed for WIN32, to support Ansi\r\n// and Unicode entrypoints. In particular, MCI_OPEN has been replaced by\r\n// MCWNDM_OPENA, or MCIWNDM_OPENW (MCIWNDM_OPEN is defined to be one or\r\n// other of these).\r\n//\r\n// Also, note that the WIN32 implementation of MCIWnd uses UNICODE\r\n// so all apis and messages supporting ANSI strings do so by mapping them\r\n// UNICODE strings and then calling the corresponding UNICODE entrypoint.\r\n//\r\n\r\nfunction MCIWndSM(hWnd: HWND; Msg: UINT; wParam: WPARAM; lParam: LPARAM): DWORD;\r\n\r\nconst \r\n MCIWND_WINDOW_CLASS = 'MCIWndClass' ;\r\n\r\nfunction MCIWndCreateA(hwndParent: HWND; hInstance: HINST; dwStyle: DWORd; szFile: LPCSTR): HWND; cdecl;\r\nfunction MCIWndCreateW(hwndParent: HWND; hInstance: HINST; dwStyle: DWORd; szFile: LPCWSTR): HWND; cdecl;\r\n\r\nfunction MCIWndCreate(hwndParent: HWND; hInstance: HINST; dwStyle: DWORd; szFile: LPCSTR): HWND; cdecl; // MCIWndCreateA\r\n\r\nfunction MCIWndRegisterClass: BOOL; cdecl;\r\n\r\n{-- Flags for the MCIWndOpen command -----------------------------------------}\r\n\r\nconst\r\n MCIWNDOPENF_NEW = $0001; // open a new file\r\n\r\n{-- Window styles ------------------------------------------------------------}\r\n\r\n MCIWNDF_NOAUTOSIZEWINDOW = $0001; // when movie size changes\r\n MCIWNDF_NOPLAYBAR = $0002; // no toolbar\r\n MCIWNDF_NOAUTOSIZEMOVIE = $0004; // when window size changes\r\n MCIWNDF_NOMENU = $0008; // no popup menu from RBUTTONDOWN\r\n MCIWNDF_SHOWNAME = $0010; // show name in caption\r\n MCIWNDF_SHOWPOS = $0020; // show position in caption\r\n MCIWNDF_SHOWMODE = $0040; // show mode in caption\r\n MCIWNDF_SHOWALL = $0070; // show all\r\n\r\n MCIWNDF_NOTIFYMODE = $0100; // tell parent of mode change\r\n MCIWNDF_NOTIFYPOS = $0200; // tell parent of pos change\r\n MCIWNDF_NOTIFYSIZE = $0400; // tell parent of size change\r\n MCIWNDF_NOTIFYERROR = $1000; // tell parent of an error\r\n MCIWNDF_NOTIFYALL = $1F00; // tell all\r\n\r\n MCIWNDF_NOTIFYANSI = $0080;\r\n\r\n// The MEDIA notification includes a text string.\r\n// To receive notifications in ANSI instead of unicode set the\r\n// MCIWNDF_NOTIFYANSI style bit. The macro below includes this bit\r\n// by default unless you define UNICODE in your application.\r\n\r\n MCIWNDF_NOTIFYMEDIAA = $0880; // tell parent of media change\r\n MCIWNDF_NOTIFYMEDIAW = $0800; // tell parent of media change\r\n\r\n MCIWNDF_NOTIFYMEDIA = MCIWNDF_NOTIFYMEDIAA;\r\n\r\n MCIWNDF_RECORD = $2000; // Give a record button\r\n MCIWNDF_NOERRORDLG = $4000; // Show Error Dlgs for MCI cmds?\r\n MCIWNDF_NOOPEN = $8000; // Don't allow user to open things\r\n\r\n{-- Can macros ---------------------------------------------------------------}\r\n\r\nfunction MCIWndCanPlay(hwnd: HWND): BOOL;\r\nfunction MCIWndCanRecord(hwnd: HWND): BOOL;\r\nfunction MCIWndCanSave(hwnd: HWND): BOOL;\r\nfunction MCIWndCanWindow(hwnd: HWND): BOOL;\r\nfunction MCIWndCanEject(hwnd: HWND): BOOL;\r\nfunction MCIWndCanConfig(hwnd: HWND): BOOL;\r\nfunction MCIWndPaletteKick(hwnd: HWND): BOOL;\r\n\r\nfunction MCIWndSave(hwnd: HWND; szFile: LPCSTR): DWORD;\r\nfunction MCIWndSaveDialog(hwnd: HWND): DWORD;\r\n\r\n// If you dont give a device it will use the current device....\r\n\r\nfunction MCIWndNew(hwnd: HWND; lp: PVOID): DWORD;\r\nfunction MCIWndRecord(hwnd: HWND): DWORD;\r\nfunction MCIWndOpen(hwnd: HWND; sz: LPCSTR; f: BOOL): DWORD;\r\nfunction MCIWndOpenDialog(hwnd: HWND): DWORD;\r\nfunction MCIWndClose(hwnd: HWND): DWORD;\r\nfunction MCIWndPlay(hwnd: HWND): DWORD;\r\nfunction MCIWndStop(hwnd: HWND): DWORD;\r\nfunction MCIWndPause(hwnd: HWND): DWORD;\r\nfunction MCIWndResume(hwnd: HWND): DWORD;\r\nfunction MCIWndSeek(hwnd: HWND; lPos: DWORD): DWORD;\r\nfunction MCIWndEject(hwnd: HWND): DWORD;\r\n\r\nfunction MCIWndHome(hwnd: HWND): DWORD;\r\nfunction MCIWndEnd(hwnd: HWND): DWORD;\r\n\r\nfunction MCIWndGetSource(hwnd: HWND; prc: PRECT): DWORD;\r\nfunction MCIWndPutSource(hwnd: HWND; prc: PRECT): DWORD;\r\n\r\nfunction MCIWndGetDest(hwnd: HWND; prc: PRECT): DWORD;\r\nfunction MCIWndPutDest(hwnd: HWND; prc: PRECT): DWORD;\r\n\r\nfunction MCIWndPlayReverse(hwnd: HWND): DWORD;\r\nfunction MCIWndPlayFrom(hwnd: HWND; lPos: DWORD): DWORD;\r\nfunction MCIWndPlayTo(hwnd: HWND; lPos: DWORD): DWORD;\r\nfunction MCIWndPlayFromTo(hwnd: HWND; lStart, lEnd: DWORD): DWORD;\r\n\r\nfunction MCIWndGetDeviceID(hwnd: HWND): UINT;\r\nfunction MCIWndGetAlias(hwnd: HWND): UINT;\r\nfunction MCIWndGetMode(hwnd: HWND; lp: LPSTR; len: UINT): DWORD;\r\nfunction MCIWndGetPosition(hwnd: HWND): DWORD;\r\nfunction MCIWndGetPositionString(hwnd: HWND; lp: LPSTR; len: UINT): DWORD;\r\nfunction MCIWndGetStart(hwnd: HWND): DWORD;\r\nfunction MCIWndGetLength(hwnd: HWND): DWORD;\r\nfunction MCIWndGetEnd(hwnd: HWND): DWORD;\r\n\r\nfunction MCIWndStep(hwnd: HWND; n: DWORD): DWORD;\r\n\r\nprocedure MCIWndDestroy(hwnd: HWND);\r\nprocedure MCIWndSetZoom(hwnd: HWND; iZoom: UINT);\r\nfunction MCIWndGetZoom(hwnd: HWND): UINT;\r\nfunction MCIWndSetVolume(hwnd: HWND; iVol: UINT): DWORD;\r\nfunction MCIWndGetVolume(hwnd: HWND): DWORD;\r\nfunction MCIWndSetSpeed(hwnd: HWND; iSpeed: UINT): DWORD;\r\nfunction MCIWndGetSpeed(hwnd: HWND): DWORD;\r\nfunction MCIWndSetTimeFormat(hwnd: HWND; lp: LPCSTR): DWORD;\r\nfunction MCIWndGetTimeFormat(hwnd: HWND; lp: LPSTR; len: UINT): DWORD;\r\nprocedure MCIWndValidateMedia(hwnd: HWND);\r\n\r\nprocedure MCIWndSetRepeat(hwnd: HWND; f: BOOL);\r\nfunction MCIWndGetRepeat(hwnd: HWND): BOOL;\r\n\r\nfunction MCIWndUseFrames(hwnd: HWND): DWORD;\r\nfunction MCIWndUseTime(hwnd: HWND): DWORD;\r\n\r\nprocedure MCIWndSetActiveTimer(hwnd: HWND; active: UINT);\r\nprocedure MCIWndSetInactiveTimer(hwnd: HWND; inactive: UINT);\r\nprocedure MCIWndSetTimers(hwnd: HWND; active, inactive: UINT);\r\nfunction MCIWndGetActiveTimer(hwnd: HWND): UINT;\r\nfunction MCIWndGetInactiveTimer(hwnd: HWND): UINT;\r\n\r\nfunction MCIWndRealize(hwnd: HWND; fBkgnd: BOOL): DWORD;\r\n\r\nfunction MCIWndSendString(hwnd: HWND; sz: LPCSTR): DWORD;\r\nfunction MCIWndReturnString(hwnd: HWND; lp: LPSTR; len: UINT): DWORD;\r\nfunction MCIWndGetError(hwnd: HWND; lp: LPSTR; len: UINT): DWORD;\r\n\r\n// #define MCIWndActivate(hwnd, f) (void)MCIWndSM(hwnd, WM_ACTIVATE, (WPARAM)(BOOL)(f), 0)\r\n\r\nfunction MCIWndGetPalette(hwnd: HWND): HPALETTE;\r\nfunction MCIWndSetPalette(hwnd: HWND; hpal: HPALETTE): DWORD;\r\n\r\nfunction MCIWndGetFileName(hwnd: HWND; lp: LPSTR; len: UINT): DWORD;\r\nfunction MCIWndGetDevice(hwnd: HWND; lp: LPSTR; len: UINT): DWORD;\r\n\r\nfunction MCIWndGetStyles(hwnd: HWND): UINT;\r\nfunction MCIWndChangeStyles(hwnd: HWND; Mask: UINT; value: DWORD): DWORD;\r\n\r\ntype\r\n PUnknown = ^IUnknown;\r\n\r\nfunction MCIWndOpenInterface(hwnd: HWND; pUnk: PUnknown): DWORD;\r\n\r\nfunction MCIWndSetOwner(hwnd: HWND; hwndP: HWND): DWORD;\r\n\r\n{-- Messages an app will send to MCIWND --------------------------------------}\r\n\r\n// all the text-related messages are defined out of order above (they need\r\n// to be defined before the MCIWndOpen() macros\r\n\r\nconst\r\n MCIWNDM_GETDEVICEID = WM_USER + 100;\r\n MCIWNDM_GETSTART = WM_USER + 103;\r\n MCIWNDM_GETLENGTH = WM_USER + 104;\r\n MCIWNDM_GETEND = WM_USER + 105;\r\n MCIWNDM_EJECT = WM_USER + 107;\r\n MCIWNDM_SETZOOM = WM_USER + 108;\r\n MCIWNDM_GETZOOM = WM_USER + 109;\r\n MCIWNDM_SETVOLUME = WM_USER + 110;\r\n MCIWNDM_GETVOLUME = WM_USER + 111;\r\n MCIWNDM_SETSPEED = WM_USER + 112;\r\n MCIWNDM_GETSPEED = WM_USER + 113;\r\n MCIWNDM_SETREPEAT = WM_USER + 114;\r\n MCIWNDM_GETREPEAT = WM_USER + 115;\r\n MCIWNDM_REALIZE = WM_USER + 118;\r\n MCIWNDM_VALIDATEMEDIA = WM_USER + 121;\r\n MCIWNDM_PLAYFROM = WM_USER + 122;\r\n MCIWNDM_PLAYTO = WM_USER + 123;\r\n MCIWNDM_GETPALETTE = WM_USER + 126;\r\n MCIWNDM_SETPALETTE = WM_USER + 127;\r\n MCIWNDM_SETTIMERS = WM_USER + 129;\r\n MCIWNDM_SETACTIVETIMER = WM_USER + 130;\r\n MCIWNDM_SETINACTIVETIMER = WM_USER + 131;\r\n MCIWNDM_GETACTIVETIMER = WM_USER + 132;\r\n MCIWNDM_GETINACTIVETIMER = WM_USER + 133;\r\n MCIWNDM_CHANGESTYLES = WM_USER + 135;\r\n MCIWNDM_GETSTYLES = WM_USER + 136;\r\n MCIWNDM_GETALIAS = WM_USER + 137;\r\n MCIWNDM_PLAYREVERSE = WM_USER + 139;\r\n MCIWNDM_GET_SOURCE = WM_USER + 140;\r\n MCIWNDM_PUT_SOURCE = WM_USER + 141;\r\n MCIWNDM_GET_DEST = WM_USER + 142;\r\n MCIWNDM_PUT_DEST = WM_USER + 143;\r\n MCIWNDM_CAN_PLAY = WM_USER + 144;\r\n MCIWNDM_CAN_WINDOW = WM_USER + 145;\r\n MCIWNDM_CAN_RECORD = WM_USER + 146;\r\n MCIWNDM_CAN_SAVE = WM_USER + 147;\r\n MCIWNDM_CAN_EJECT = WM_USER + 148;\r\n MCIWNDM_CAN_CONFIG = WM_USER + 149;\r\n MCIWNDM_PALETTEKICK = WM_USER + 150;\r\n MCIWNDM_OPENINTERFACE = WM_USER + 151;\r\n MCIWNDM_SETOWNER = WM_USER + 152;\r\n\r\n{-- Define both A and W messages ---------------------------------------------}\r\n\r\n MCIWNDM_SENDSTRINGA = WM_USER + 101;\r\n MCIWNDM_GETPOSITIONA = WM_USER + 102;\r\n MCIWNDM_GETMODEA = WM_USER + 106;\r\n MCIWNDM_SETTIMEFORMATA = WM_USER + 119;\r\n MCIWNDM_GETTIMEFORMATA = WM_USER + 120;\r\n MCIWNDM_GETFILENAMEA = WM_USER + 124;\r\n MCIWNDM_GETDEVICEA = WM_USER + 125;\r\n MCIWNDM_GETERRORA = WM_USER + 128;\r\n MCIWNDM_NEWA = WM_USER + 134;\r\n MCIWNDM_RETURNSTRINGA = WM_USER + 138;\r\n MCIWNDM_OPENA = WM_USER + 153;\r\n\r\n MCIWNDM_SENDSTRINGW = WM_USER + 201;\r\n MCIWNDM_GETPOSITIONW = WM_USER + 202;\r\n MCIWNDM_GETMODEW = WM_USER + 206;\r\n MCIWNDM_SETTIMEFORMATW = WM_USER + 219;\r\n MCIWNDM_GETTIMEFORMATW = WM_USER + 220;\r\n MCIWNDM_GETFILENAMEW = WM_USER + 224;\r\n MCIWNDM_GETDEVICEW = WM_USER + 225;\r\n MCIWNDM_GETERRORW = WM_USER + 228;\r\n MCIWNDM_NEWW = WM_USER + 234;\r\n MCIWNDM_RETURNSTRINGW = WM_USER + 238;\r\n MCIWNDM_OPENW = WM_USER + 252;\r\n\r\n{-- Map defaults to A --------------------------------------------------------}\r\n\r\n MCIWNDM_SENDSTRING = MCIWNDM_SENDSTRINGA;\r\n MCIWNDM_GETPOSITION = MCIWNDM_GETPOSITIONA;\r\n MCIWNDM_GETMODE = MCIWNDM_GETMODEA;\r\n MCIWNDM_SETTIMEFORMAT = MCIWNDM_SETTIMEFORMATA;\r\n MCIWNDM_GETTIMEFORMAT = MCIWNDM_GETTIMEFORMATA;\r\n MCIWNDM_GETFILENAME = MCIWNDM_GETFILENAMEA;\r\n MCIWNDM_GETDEVICE = MCIWNDM_GETDEVICEA;\r\n MCIWNDM_GETERROR = MCIWNDM_GETERRORA;\r\n MCIWNDM_NEW = MCIWNDM_NEWA;\r\n MCIWNDM_RETURNSTRING = MCIWNDM_RETURNSTRINGA;\r\n MCIWNDM_OPEN = MCIWNDM_OPENA;\r\n\r\n// note that the source text for MCIWND will thus contain\r\n// support for eg MCIWNDM_SENDSTRING (both the 16-bit entrypoint and\r\n// in win32 mapped to MCIWNDM_SENDSTRINGW), and MCIWNDM_SENDSTRINGA (the\r\n// win32 ansi thunk).\r\n\r\n{-- Messages MCIWND will send to an app --------------------------------------}\r\n\r\nconst\r\n MCIWNDM_NOTIFYMODE = WM_USER + 200; // wp = hwnd, lp = mode\r\n MCIWNDM_NOTIFYPOS = WM_USER + 201; // wp = hwnd, lp = pos\r\n MCIWNDM_NOTIFYSIZE = WM_USER + 202; // wp = hwnd\r\n MCIWNDM_NOTIFYMEDIA = WM_USER + 203; // wp = hwnd, lp = fn\r\n MCIWNDM_NOTIFYERROR = WM_USER + 205; // wp = hwnd, lp = error\r\n\r\n{-- Special seek values for START and END ------------------------------------}\r\n\r\n MCIWND_START = dword(-1) ;\r\n MCIWND_END = dword(-2) ;\r\n\r\n{== VIDEO - Video capture driver interface ===================================}\r\n\r\ntype\r\n HVIDEO = THandle;\r\n PHVIDEO = ^HVIDEO;\r\n\r\n{-- Error return values ------------------------------------------------------}\r\n\r\nconst\r\n DV_ERR_OK = 0; // No error\r\n DV_ERR_BASE = 1; // Error Base \r\n DV_ERR_NONSPECIFIC = DV_ERR_BASE;\r\n DV_ERR_BADFORMAT = DV_ERR_BASE + 1; // unsupported video format \r\n DV_ERR_STILLPLAYING = DV_ERR_BASE + 2; // still something playing \r\n DV_ERR_UNPREPARED = DV_ERR_BASE + 3; // header not prepared \r\n DV_ERR_SYNC = DV_ERR_BASE + 4; // device is synchronous \r\n DV_ERR_TOOMANYCHANNELS = DV_ERR_BASE + 5; // number of channels exceeded \r\n DV_ERR_NOTDETECTED = DV_ERR_BASE + 6; // HW not detected \r\n DV_ERR_BADINSTALL = DV_ERR_BASE + 7; // Can not get Profile \r\n DV_ERR_CREATEPALETTE = DV_ERR_BASE + 8;\r\n DV_ERR_SIZEFIELD = DV_ERR_BASE + 9;\r\n DV_ERR_PARAM1 = DV_ERR_BASE + 10;\r\n DV_ERR_PARAM2 = DV_ERR_BASE + 11;\r\n DV_ERR_CONFIG1 = DV_ERR_BASE + 12;\r\n DV_ERR_CONFIG2 = DV_ERR_BASE + 13;\r\n DV_ERR_FLAGS = DV_ERR_BASE + 14;\r\n DV_ERR_13 = DV_ERR_BASE + 15;\r\n\r\n DV_ERR_NOTSUPPORTED = DV_ERR_BASE + 16; // function not suported \r\n DV_ERR_NOMEM = DV_ERR_BASE + 17; // out of memory \r\n DV_ERR_ALLOCATED = DV_ERR_BASE + 18; // device is allocated \r\n DV_ERR_BADDEVICEID = DV_ERR_BASE + 19;\r\n DV_ERR_INVALHANDLE = DV_ERR_BASE + 20;\r\n DV_ERR_BADERRNUM = DV_ERR_BASE + 21;\r\n DV_ERR_NO_BUFFERS = DV_ERR_BASE + 22; // out of buffers \r\n\r\n DV_ERR_MEM_CONFLICT = DV_ERR_BASE + 23; // Mem conflict detected \r\n DV_ERR_IO_CONFLICT = DV_ERR_BASE + 24; // I/O conflict detected \r\n DV_ERR_DMA_CONFLICT = DV_ERR_BASE + 25; // DMA conflict detected\r\n DV_ERR_INT_CONFLICT = DV_ERR_BASE + 26; // Interrupt conflict detected\r\n DV_ERR_PROTECT_ONLY = DV_ERR_BASE + 27; // Can not run in standard mode\r\n DV_ERR_LASTERROR = DV_ERR_BASE + 27;\r\n\r\n DV_ERR_USER_MSG = DV_ERR_BASE + 1000; // Hardware specific errors\r\n\r\n{-- Callback messages --------------------------------------------------------}\r\n\r\n// Note that the values for all installable driver callback messages are\r\n// identical, (ie. MM_DRVM_DATA has the same value for capture drivers,\r\n// installable video codecs, and the audio compression manager).\r\n\r\nconst\r\n DV_VM_OPEN = MM_DRVM_OPEN; // Obsolete messages\r\n DV_VM_CLOSE = MM_DRVM_CLOSE;\r\n DV_VM_DATA = MM_DRVM_DATA;\r\n DV_VM_ERROR = MM_DRVM_ERROR;\r\n\r\n{== Structures ===============================================================}\r\n\r\n{-- Video data block header --------------------------------------------------}\r\n\r\ntype\r\n PVIDEOHDR = ^TVIDEOHDR;\r\n TVIDEOHDR = record\r\n lpData : PBYTE; // pointer to locked data buffer\r\n dwBufferLength : DWORD; // Length of data buffer\r\n dwBytesUsed : DWORD; // Bytes actually used\r\n dwTimeCaptured : DWORD; // Milliseconds from start of stream\r\n dwUser : DWORD; // for client's use\r\n dwFlags : DWORD; // assorted flags (see defines)\r\n dwReserved : array[0..3] of DWORD; // reserved for driver\r\n end;\r\n\r\n{-- dwFlags field of VIDEOHDR ------------------------------------------------}\r\n\r\nconst\r\n VHDR_DONE = $00000001; // Done bit\r\n VHDR_PREPARED = $00000002; // Set if this header has been prepared\r\n VHDR_INQUEUE = $00000004; // Reserved for driver\r\n VHDR_KEYFRAME = $00000008; // Key Frame\r\n\r\n{-- Channel capabilities structure -------------------------------------------}\r\n\r\ntype\r\n PCHANNEL_CAPS = ^TCHANNEL_CAPS;\r\n TCHANNEL_CAPS = record\r\n dwFlags : DWORD; // Capability flags\r\n dwSrcRectXMod : DWORD; // Granularity of src rect in x\r\n dwSrcRectYMod : DWORD; // Granularity of src rect in y\r\n dwSrcRectWidthMod : DWORD; // Granularity of src rect width\r\n dwSrcRectHeightMod : DWORD; // Granularity of src rect height\r\n dwDstRectXMod : DWORD; // Granularity of dst rect in x\r\n dwDstRectYMod : DWORD; // Granularity of dst rect in y\r\n dwDstRectWidthMod : DWORD; // Granularity of dst rect width\r\n dwDstRectHeightMod : DWORD; // Granularity of dst rect height\r\n end;\r\n\r\n{-- dwFlags of CHANNEL_CAPS --------------------------------------------------}\r\n\r\nconst\r\n VCAPS_OVERLAY = $00000001; // overlay channel \r\n VCAPS_SRC_CAN_CLIP = $00000002; // src rect can clip\r\n VCAPS_DST_CAN_CLIP = $00000004; // dst rect can clip\r\n VCAPS_CAN_SCALE = $00000008; // allows src != dst\r\n\r\n{== API flags ================================================================}\r\n\r\n{-- Types of channels to open with the videoOpen function --------------------}\r\n\r\nconst\r\n VIDEO_EXTERNALIN = $0001;\r\n VIDEO_EXTERNALOUT = $0002;\r\n VIDEO_IN = $0004;\r\n VIDEO_OUT = $0008;\r\n\r\n{-- Is a driver dialog available for this channel ----------------------------}\r\n\r\n VIDEO_DLG_QUERY = $0010;\r\n\r\n{-- videoConfigure (both GET and SET) ----------------------------------------}\r\n\r\n VIDEO_CONFIGURE_QUERY = $8000;\r\n\r\n{-- videoConfigure (SET only) ------------------------------------------------}\r\n\r\n VIDEO_CONFIGURE_SET = $1000;\r\n\r\n{-- videoConfigure (GET only) ------------------------------------------------}\r\n\r\n VIDEO_CONFIGURE_GET = $2000;\r\n VIDEO_CONFIGURE_QUERYSIZE = $0001;\r\n\r\n VIDEO_CONFIGURE_CURRENT = $0010;\r\n VIDEO_CONFIGURE_NOMINAL = $0020;\r\n VIDEO_CONFIGURE_MIN = $0040;\r\n VIDEO_CONFIGURE_MAX = $0080;\r\n\r\n{== Configure messages =======================================================}\r\n\r\n DVM_USER = $4000;\r\n\r\n DVM_CONFIGURE_START = $1000;\r\n DVM_CONFIGURE_END = $1FFF;\r\n\r\n DVM_PALETTE = DVM_CONFIGURE_START + 1;\r\n DVM_FORMAT = DVM_CONFIGURE_START + 2;\r\n DVM_PALETTERGB555 = DVM_CONFIGURE_START + 3;\r\n DVM_SRC_RECT = DVM_CONFIGURE_START + 4;\r\n DVM_DST_RECT = DVM_CONFIGURE_START + 5;\r\n\r\n{== AVICAP - Window class for AVI capture ====================================}\r\n\r\nfunction AVICapSM(hwnd: HWND; m: UINT; w: WPARAM; l: LPARAM): DWORD;\r\n\r\n{-- Window messages WM_CAP... which can be sent to an AVICAP window ----------}\r\n\r\n// UNICODE\r\n//\r\n// The Win32 version of AVICAP on NT supports UNICODE applications:\r\n// for each API or message that takes a char or string parameter, there are\r\n// two versions, ApiNameA and ApiNameW. The default name ApiName is #defined\r\n// to one or other depending on whether UNICODE is defined. Apps can call\r\n// the A and W apis directly, and mix them.\r\n//\r\n// The 32-bit AVICAP on NT uses unicode exclusively internally.\r\n// ApiNameA() will be implemented as a call to ApiNameW() together with\r\n// translation of strings.\r\n\r\n// Defines start of the message range\r\nconst\r\n WM_CAP_START = WM_USER;\r\n WM_CAP_UNICODE_START = WM_USER + 100;\r\n\r\n WM_CAP_GET_CAPSTREAMPTR = WM_CAP_START + 1;\r\n\r\n WM_CAP_SET_CALLBACK_ERRORW = WM_CAP_UNICODE_START + 2;\r\n WM_CAP_SET_CALLBACK_STATUSW = WM_CAP_UNICODE_START + 3;\r\n WM_CAP_SET_CALLBACK_ERRORA = WM_CAP_START + 2;\r\n WM_CAP_SET_CALLBACK_STATUSA = WM_CAP_START + 3;\r\n {$IFDEF UNICODE}\r\n WM_CAP_SET_CALLBACK_ERROR = WM_CAP_SET_CALLBACK_ERRORW;\r\n WM_CAP_SET_CALLBACK_STATUS = WM_CAP_SET_CALLBACK_STATUSW;\r\n {$ELSE}\r\n WM_CAP_SET_CALLBACK_ERROR = WM_CAP_SET_CALLBACK_ERRORA;\r\n WM_CAP_SET_CALLBACK_STATUS = WM_CAP_SET_CALLBACK_STATUSA;\r\n {$ENDIF UNICODE}\r\n\r\n WM_CAP_SET_CALLBACK_YIELD = WM_CAP_START + 4;\r\n WM_CAP_SET_CALLBACK_FRAME = WM_CAP_START + 5;\r\n WM_CAP_SET_CALLBACK_VIDEOSTREAM = WM_CAP_START + 6;\r\n WM_CAP_SET_CALLBACK_WAVESTREAM = WM_CAP_START + 7;\r\n WM_CAP_GET_USER_DATA = WM_CAP_START + 8;\r\n WM_CAP_SET_USER_DATA = WM_CAP_START + 9;\r\n\r\n WM_CAP_DRIVER_CONNECT = WM_CAP_START + 10;\r\n WM_CAP_DRIVER_DISCONNECT = WM_CAP_START + 11;\r\n\r\n WM_CAP_DRIVER_GET_NAMEA = WM_CAP_START + 12;\r\n WM_CAP_DRIVER_GET_VERSIONA = WM_CAP_START + 13;\r\n WM_CAP_DRIVER_GET_NAMEW = WM_CAP_UNICODE_START + 12;\r\n WM_CAP_DRIVER_GET_VERSIONW = WM_CAP_UNICODE_START + 13;\r\n {$IFDEF UNICODE}\r\n WM_CAP_DRIVER_GET_NAME = WM_CAP_DRIVER_GET_NAMEW;\r\n WM_CAP_DRIVER_GET_VERSION = WM_CAP_DRIVER_GET_VERSIONW;\r\n {$ELSE}\r\n WM_CAP_DRIVER_GET_NAME = WM_CAP_DRIVER_GET_NAMEA;\r\n WM_CAP_DRIVER_GET_VERSION = WM_CAP_DRIVER_GET_VERSIONA;\r\n {$ENDIF UNICODE}\r\n\r\n WM_CAP_DRIVER_GET_CAPS = WM_CAP_START + 14;\r\n\r\n WM_CAP_FILE_SET_CAPTURE_FILEA = WM_CAP_START + 20;\r\n WM_CAP_FILE_GET_CAPTURE_FILEA = WM_CAP_START + 21;\r\n WM_CAP_FILE_SAVEASA = WM_CAP_START + 23;\r\n WM_CAP_FILE_SAVEDIBA = WM_CAP_START + 25;\r\n WM_CAP_FILE_SET_CAPTURE_FILEW = WM_CAP_UNICODE_START + 20;\r\n WM_CAP_FILE_GET_CAPTURE_FILEW = WM_CAP_UNICODE_START + 21;\r\n WM_CAP_FILE_SAVEASW = WM_CAP_UNICODE_START + 23;\r\n WM_CAP_FILE_SAVEDIBW = WM_CAP_UNICODE_START + 25;\r\n {$IFDEF UNICODE}\r\n WM_CAP_FILE_SET_CAPTURE_FILE = WM_CAP_FILE_SET_CAPTURE_FILEW;\r\n WM_CAP_FILE_GET_CAPTURE_FILE = WM_CAP_FILE_GET_CAPTURE_FILEW;\r\n WM_CAP_FILE_SAVEAS = WM_CAP_FILE_SAVEASW;\r\n WM_CAP_FILE_SAVEDIB = WM_CAP_FILE_SAVEDIBW;\r\n {$ELSE}\r\n WM_CAP_FILE_SET_CAPTURE_FILE = WM_CAP_FILE_SET_CAPTURE_FILEA;\r\n WM_CAP_FILE_GET_CAPTURE_FILE = WM_CAP_FILE_GET_CAPTURE_FILEA;\r\n WM_CAP_FILE_SAVEAS = WM_CAP_FILE_SAVEASA;\r\n WM_CAP_FILE_SAVEDIB = WM_CAP_FILE_SAVEDIBA;\r\n {$ENDIF UNICODE}\r\n\r\n // out of order to save on ifdefs\r\n\r\n WM_CAP_FILE_ALLOCATE = WM_CAP_START + 22;\r\n WM_CAP_FILE_SET_INFOCHUNK = WM_CAP_START + 24;\r\n\r\n WM_CAP_EDIT_COPY = WM_CAP_START + 30;\r\n\r\n WM_CAP_SET_AUDIOFORMAT = WM_CAP_START + 35;\r\n WM_CAP_GET_AUDIOFORMAT = WM_CAP_START + 36;\r\n\r\n WM_CAP_DLG_VIDEOFORMAT = WM_CAP_START + 41;\r\n WM_CAP_DLG_VIDEOSOURCE = WM_CAP_START + 42;\r\n WM_CAP_DLG_VIDEODISPLAY = WM_CAP_START + 43;\r\n WM_CAP_GET_VIDEOFORMAT = WM_CAP_START + 44;\r\n WM_CAP_SET_VIDEOFORMAT = WM_CAP_START + 45;\r\n WM_CAP_DLG_VIDEOCOMPRESSION = WM_CAP_START + 46;\r\n\r\n WM_CAP_SET_PREVIEW = WM_CAP_START + 50;\r\n WM_CAP_SET_OVERLAY = WM_CAP_START + 51;\r\n WM_CAP_SET_PREVIEWRATE = WM_CAP_START + 52;\r\n WM_CAP_SET_SCALE = WM_CAP_START + 53;\r\n WM_CAP_GET_STATUS = WM_CAP_START + 54;\r\n WM_CAP_SET_SCROLL = WM_CAP_START + 55;\r\n\r\n WM_CAP_GRAB_FRAME = WM_CAP_START + 60;\r\n WM_CAP_GRAB_FRAME_NOSTOP = WM_CAP_START + 61;\r\n\r\n WM_CAP_SEQUENCE = WM_CAP_START + 62;\r\n WM_CAP_SEQUENCE_NOFILE = WM_CAP_START + 63;\r\n WM_CAP_SET_SEQUENCE_SETUP = WM_CAP_START + 64;\r\n WM_CAP_GET_SEQUENCE_SETUP = WM_CAP_START + 65;\r\n\r\n WM_CAP_SET_MCI_DEVICEA = WM_CAP_START + 66;\r\n WM_CAP_GET_MCI_DEVICEA = WM_CAP_START + 67;\r\n WM_CAP_SET_MCI_DEVICEW = WM_CAP_UNICODE_START + 66;\r\n WM_CAP_GET_MCI_DEVICEW = WM_CAP_UNICODE_START + 67;\r\n {$IFDEF UNICODE}\r\n WM_CAP_SET_MCI_DEVICE = WM_CAP_SET_MCI_DEVICEW;\r\n WM_CAP_GET_MCI_DEVICE = WM_CAP_GET_MCI_DEVICEW;\r\n {$ELSE}\r\n WM_CAP_SET_MCI_DEVICE = WM_CAP_SET_MCI_DEVICEA;\r\n WM_CAP_GET_MCI_DEVICE = WM_CAP_GET_MCI_DEVICEA;\r\n {$ENDIF UNICODE}\r\n\r\n WM_CAP_STOP = WM_CAP_START + 68;\r\n WM_CAP_ABORT = WM_CAP_START + 69;\r\n\r\n WM_CAP_SINGLE_FRAME_OPEN = WM_CAP_START + 70;\r\n WM_CAP_SINGLE_FRAME_CLOSE = WM_CAP_START + 71;\r\n WM_CAP_SINGLE_FRAME = WM_CAP_START + 72;\r\n\r\n WM_CAP_PAL_OPENA = WM_CAP_START + 80;\r\n WM_CAP_PAL_SAVEA = WM_CAP_START + 81;\r\n WM_CAP_PAL_OPENW = WM_CAP_UNICODE_START + 80;\r\n WM_CAP_PAL_SAVEW = WM_CAP_UNICODE_START + 81;\r\n {$IFDEF UNICODE}\r\n WM_CAP_PAL_OPEN = WM_CAP_PAL_OPENW;\r\n WM_CAP_PAL_SAVE = WM_CAP_PAL_SAVEW;\r\n {$ELSE}\r\n WM_CAP_PAL_OPEN = WM_CAP_PAL_OPENA;\r\n WM_CAP_PAL_SAVE = WM_CAP_PAL_SAVEA;\r\n {$ENDIF UNICODE}\r\n\r\n WM_CAP_PAL_PASTE = WM_CAP_START + 82;\r\n WM_CAP_PAL_AUTOCREATE = WM_CAP_START + 83;\r\n WM_CAP_PAL_MANUALCREATE = WM_CAP_START + 84;\r\n\r\n // Following added post VFW 1.1\r\n\r\n WM_CAP_SET_CALLBACK_CAPCONTROL = WM_CAP_START + 85;\r\n\r\n // Defines end of the message range\r\n\r\n WM_CAP_UNICODE_END = WM_CAP_PAL_SAVEW;\r\n WM_CAP_END = WM_CAP_UNICODE_END;\r\n\r\n{-- Callback definitions -----------------------------------------------------}\r\n\r\ntype\r\n TCAPYIELDCALLBACK = function(hWnd: HWND): DWORD; stdcall;\r\n\r\n TCAPSTATUSCALLBACKW = function(hWnd: HWND; nID: int; lpsz: LPCWSTR): DWORD; stdcall;\r\n TCAPERRORCALLBACKW = function(hWnd: HWND; nID: int; lpsz: LPCWSTR): DWORD; stdcall;\r\n TCAPSTATUSCALLBACKA = function(hWnd: HWND; nID: int; lpsz: LPCSTR): DWORD; stdcall;\r\n TCAPERRORCALLBACKA = function(hWnd: HWND; nID: int; lpsz: LPCSTR): DWORD; stdcall;\r\n\r\n {$IFDEF UNICODE}\r\n TCAPSTATUSCALLBACK = TCAPSTATUSCALLBACKW;\r\n TCAPERRORCALLBACK = TCAPERRORCALLBACKW;\r\n {$ELSE}\r\n TCAPSTATUSCALLBACK = TCAPSTATUSCALLBACKA;\r\n TCAPERRORCALLBACK = TCAPERRORCALLBACKA;\r\n {$ENDIF UNICODE}\r\n\r\n TCAPVIDEOCALLBACK = function(hWnd: HWND; lpVHdr: PVIDEOHDR): DWORD; stdcall;\r\n TCAPWAVECALLBACK = function(hWnd: HWND; lpWHdr: PWAVEHDR): DWORD; stdcall;\r\n TCAPCONTROLCALLBACK = function(hWnd: HWND; nState: int): DWORD; stdcall;\r\n\r\n{-- Structures ---------------------------------------------------------------}\r\n\r\ntype\r\n PCAPDRIVERCAPS = ^TCAPDRIVERCAPS;\r\n TCAPDRIVERCAPS = record\r\n wDeviceIndex : UINT; // Driver index in system.ini\r\n fHasOverlay : BOOL; // Can device overlay?\r\n fHasDlgVideoSource : BOOL; // Has Video source dlg?\r\n fHasDlgVideoFormat : BOOL; // Has Format dlg?\r\n fHasDlgVideoDisplay : BOOL; // Has External out dlg?\r\n fCaptureInitialized : BOOL; // Driver ready to capture?\r\n fDriverSuppliesPalettes : BOOL; // Can driver make palettes?\r\n\r\n // following always NULL on Win32.\r\n hVideoIn : THANDLE; // Driver In channel\r\n hVideoOut : THANDLE; // Driver Out channel\r\n hVideoExtIn : THANDLE; // Driver Ext In channel\r\n hVideoExtOut : THANDLE; // Driver Ext Out channel\r\n end;\r\n\r\n PCAPSTATUS = ^TCAPSTATUS;\r\n TCAPSTATUS = record\r\n uiImageWidth : UINT ; // Width of the image\r\n uiImageHeight : UINT ; // Height of the image\r\n fLiveWindow : BOOL ; // Now Previewing video?\r\n fOverlayWindow : BOOL ; // Now Overlaying video?\r\n fScale : BOOL ; // Scale image to client?\r\n ptScroll : TPOINT ; // Scroll position\r\n fUsingDefaultPalette : BOOL ; // Using default driver palette?\r\n fAudioHardware : BOOL ; // Audio hardware present?\r\n fCapFileExists : BOOL ; // Does capture file exist?\r\n dwCurrentVideoFrame : DWORD ; // # of video frames cap'td\r\n dwCurrentVideoFramesDropped : DWORD ; // # of video frames dropped\r\n dwCurrentWaveSamples : DWORD ; // # of wave samples cap'td\r\n dwCurrentTimeElapsedMS : DWORD ; // Elapsed capture duration\r\n hPalCurrent : HPALETTE; // Current palette in use\r\n fCapturingNow : BOOL ; // Capture in progress?\r\n dwReturn : DWORD ; // Error value after any operation\r\n wNumVideoAllocated : UINT ; // Actual number of video buffers\r\n wNumAudioAllocated : UINT ; // Actual number of audio buffers\r\n end;\r\n\r\n // Default values in parenthesis\r\n\r\n PCAPTUREPARMS = ^TCAPTUREPARMS;\r\n TCAPTUREPARMS = record\r\n dwRequestMicroSecPerFrame : DWORD ; // Requested capture rate\r\n fMakeUserHitOKToCapture : BOOL ; // Show \"Hit OK to cap\" dlg?\r\n wPercentDropForError : UINT ; // Give error msg if > (10%)\r\n fYield : BOOL ; // Capture via background task?\r\n dwIndexSize : DWORD ; // Max index size in frames (32K)\r\n wChunkGranularity : UINT ; // Junk chunk granularity (2K)\r\n fUsingDOSMemory : BOOL ; // Use DOS buffers?\r\n wNumVideoRequested : UINT ; // # video buffers, If 0, autocalc\r\n fCaptureAudio : BOOL ; // Capture audio?\r\n wNumAudioRequested : UINT ; // # audio buffers, If 0, autocalc\r\n vKeyAbort : UINT ; // Virtual key causing abort\r\n fAbortLeftMouse : BOOL ; // Abort on left mouse?\r\n fAbortRightMouse : BOOL ; // Abort on right mouse?\r\n fLimitEnabled : BOOL ; // Use wTimeLimit?\r\n wTimeLimit : UINT ; // Seconds to capture\r\n fMCIControl : BOOL ; // Use MCI video source?\r\n fStepMCIDevice : BOOL ; // Step MCI device?\r\n dwMCIStartTime : DWORD ; // Time to start in MS\r\n dwMCIStopTime : DWORD ; // Time to stop in MS\r\n fStepCaptureAt2x : BOOL ; // Perform spatial averaging 2x\r\n wStepCaptureAverageFrames : UINT ; // Temporal average n Frames\r\n dwAudioBufferSize : DWORD ; // Size of audio bufs (0 = default)\r\n fDisableWriteCache : BOOL ; // Attempt to disable write cache\r\n AVStreamMaster : UINT ; // Which stream controls length?\r\n end;\r\n\r\n{-- AVStreamMaster -----------------------------------------------------------}\r\n\r\n// Since Audio and Video streams generally use non-synchronized capture\r\n// clocks, this flag determines whether the audio stream is to be considered\r\n// the master or controlling clock when writing the AVI file:\r\n//\r\n// AVSTREAMMASTER_AUDIO - Audio is master, video frame duration is forced\r\n// to match audio duration (VFW 1.0, 1.1 default)\r\n// AVSTREAMMASTER_NONE - No master, audio and video streams may be of\r\n// different lengths\r\n\r\nconst\r\n AVSTREAMMASTER_AUDIO = 0; // Audio master (VFW 1.0, 1.1)\r\n AVSTREAMMASTER_NONE = 1; // No master\r\n\r\ntype\r\n PCAPINFOCHUNK = ^TCAPINFOCHUNK;\r\n TCAPINFOCHUNK = record\r\n fccInfoID : FOURCC; // Chunk ID, \"ICOP\" for copyright\r\n lpData : PVOID; // pointer to data\r\n cbData : DWORD; // size of lpData\r\n end;\r\n\r\n{-- CapControlCallback states ------------------------------------------------}\r\n\r\nconst\r\n CONTROLCALLBACK_PREROLL = 1; // Waiting to start capture \r\n CONTROLCALLBACK_CAPTURING = 2; // Now capturing\r\n\r\n{-- Message crackers for above -----------------------------------------------}\r\n\r\n// message wrapper macros are defined for the default messages only. Apps\r\n// that wish to mix Ansi and UNICODE message sending will have to\r\n// reference the _A and _W messages directly\r\n\r\nfunction capSetCallbackOnError(hwnd: HWND; fpProc: TCAPERRORCALLBACK): BOOL;\r\nfunction capSetCallbackOnStatus(hwnd: HWND; fpProc: TCAPSTATUSCALLBACK): BOOL;\r\nfunction capSetCallbackOnYield(hwnd: HWND; fpProc: TCAPYIELDCALLBACK): BOOL;\r\nfunction capSetCallbackOnFrame(hwnd: HWND; fpProc: TCAPVIDEOCALLBACK): BOOL;\r\nfunction capSetCallbackOnVideoStream(hwnd: HWND; fpProc: TCAPVIDEOCALLBACK): BOOL;\r\nfunction capSetCallbackOnWaveStream(hwnd: HWND; fpProc: TCAPWAVECALLBACK): BOOL;\r\nfunction capSetCallbackOnCapControl(hwnd: HWND; fpProc: TCAPCONTROLCALLBACK): BOOL;\r\n\r\nfunction capSetUserData(hwnd: HWND; lUser: DWORD): BOOL;\r\nfunction capGetUserData(hwnd: HWND): DWORD;\r\n\r\nfunction capDriverConnect(hwnd: HWND; i: INT): BOOL;\r\nfunction capDriverDisconnect(hwnd: HWND): BOOL;\r\nfunction capDriverGetName(hwnd: HWND; szName: LPTSTR; wSize: WORD): BOOL;\r\nfunction capDriverGetVersion(hwnd: HWND; szVer: LPTSTR; wSize: WORD): BOOL;\r\nfunction capDriverGetCaps(hwnd: HWND; s: PCAPDRIVERCAPS; wSize: WORD): BOOL;\r\n\r\nfunction capFileSetCaptureFile(hwnd: HWND; szName: LPTSTR): BOOL;\r\nfunction capFileGetCaptureFile(hwnd: HWND; szName: LPTSTR; wSize: WORD): BOOL;\r\nfunction capFileAlloc(hwnd: HWND; dwSize: DWORD): BOOL;\r\nfunction capFileSaveAs(hwnd: HWND; szName: LPCTSTR): BOOL;\r\nfunction capFileSetInfoChunk(hwnd: HWND; lpInfoChunk: PCAPINFOCHUNK): BOOL;\r\nfunction capFileSaveDIB(hwnd: HWND; szName: LPCTSTR): BOOL;\r\n\r\nfunction capEditCopy(hwnd: HWND): BOOL;\r\n\r\nfunction capSetAudioFormat(hwnd: HWND; s: PWAVEFORMATEX; wSize: WORD): BOOL;\r\nfunction capGetAudioFormat(hwnd: HWND; s: PWAVEFORMATEX; wSize: WORD): DWORD;\r\nfunction capGetAudioFormatSize(hwnd: HWND): DWORD;\r\n\r\nfunction capDlgVideoFormat(hwnd: HWND): BOOL;\r\nfunction capDlgVideoSource(hwnd: HWND): BOOL;\r\nfunction capDlgVideoDisplay(hwnd: HWND): BOOL;\r\nfunction capDlgVideoCompression(hwnd: HWND): BOOL;\r\n\r\nfunction capGetVideoFormat(hwnd: HWND; s: PVOID; wSize: WORD): DWORD;\r\nfunction capGetVideoFormatSize(hwnd: HWND): DWORD;\r\nfunction capSetVideoFormat(hwnd: HWND; s: PVOID; wSize: WORD): BOOL;\r\n\r\nfunction capPreview(hwnd: HWND; f: BOOL): BOOL;\r\nfunction capPreviewRate(hwnd: HWND; wMS: WORD): BOOL;\r\nfunction capOverlay(hwnd: HWND; f: BOOL): BOOL;\r\nfunction capPreviewScale(hwnd: HWND; f: BOOL): BOOL;\r\nfunction capGetStatus(hwnd: HWND; s: PCAPSTATUS; wSize: WORD): BOOL;\r\nfunction capSetScrollPos(hwnd: HWND; lpP: PPOINT): BOOL;\r\n\r\nfunction capGrabFrame(hwnd: HWND): BOOL;\r\nfunction capGrabFrameNoStop(hwnd: HWND): BOOL;\r\n\r\nfunction capCaptureSequence(hwnd: HWND): BOOL;\r\nfunction capCaptureSequenceNoFile(hwnd: HWND): BOOL;\r\nfunction capCaptureStop(hwnd: HWND): BOOL;\r\nfunction capCaptureAbort(hwnd: HWND): BOOL;\r\n\r\nfunction capCaptureSingleFrameOpen(hwnd: HWND): BOOL;\r\nfunction capCaptureSingleFrameClose(hwnd: HWND): BOOL;\r\nfunction capCaptureSingleFrame(hwnd: HWND): BOOL;\r\n\r\nfunction capCaptureGetSetup(hwnd: HWND; s: PCAPTUREPARMS; wSize: WORD): BOOL;\r\nfunction capCaptureSetSetup(hwnd: HWND; s: PCAPTUREPARMS; wSize: WORD): BOOL;\r\n\r\nfunction capSetMCIDeviceName(hwnd: HWND; szName: LPCTSTR): BOOL;\r\nfunction capGetMCIDeviceName(hwnd: HWND; szName: LPTSTR; wSize: WORD): BOOL;\r\n\r\nfunction capPaletteOpen(hwnd: HWND; szName: LPCTSTR): BOOL;\r\nfunction capPaletteSave(hwnd: HWND; szName: LPCTSTR): BOOL;\r\nfunction capPalettePaste(hwnd: HWND): BOOL;\r\nfunction capPaletteAuto(hwnd: HWND; iFrames, iColors: INT): BOOL;\r\nfunction capPaletteManual(hwnd: HWND; fGrab: BOOL; iColors: INT): BOOL;\r\n\r\n{-- The only exported functions from AVICAP.DLL ------------------------------}\r\n\r\nfunction capCreateCaptureWindowA(\r\n lpszWindowName : LPCSTR;\r\n dwStyle : DWORD;\r\n x, y : int;\r\n nWidth, nHeight : int;\r\n hwndParent : HWND;\r\n nID : int\r\n ): HWND; stdcall;\r\n\r\nfunction capGetDriverDescriptionA(\r\n wDriverIndex : UINT;\r\n lpszName : LPSTR;\r\n cbName : int;\r\n lpszVer : LPSTR;\r\n cbVer : int\r\n ): BOOL; stdcall;\r\n\r\nfunction capCreateCaptureWindowW(\r\n lpszWindowName : LPCWSTR;\r\n dwStyle : DWORD;\r\n x, y : int;\r\n nWidth, nHeight : int;\r\n hwndParent : HWND;\r\n nID : int\r\n ): HWND; stdcall;\r\n\r\nfunction capGetDriverDescriptionW(\r\n wDriverIndex : UINT;\r\n lpszName : LPWSTR;\r\n cbName : int;\r\n lpszVer : LPWSTR;\r\n cbVer : int\r\n ): BOOL; stdcall;\r\n\r\nfunction capCreateCaptureWindow(\r\n lpszWindowName : LPCTSTR;\r\n dwStyle : DWORD;\r\n x, y : int;\r\n nWidth, nHeight : int;\r\n hwndParent : HWND;\r\n nID : int\r\n ): HWND; stdcall; // capCreateCaptureWindowA or capCreateCaptureWindowW if UNICODE is defined \r\n\r\nfunction capGetDriverDescription(\r\n wDriverIndex : UINT;\r\n lpszName : LPTSTR;\r\n cbName : int;\r\n lpszVer : LPTSTR;\r\n cbVer : int\r\n ): BOOL; stdcall; // capGetDriverDescriptionA ir capGetDriverDescriptionW if UNICODE is defined\r\n\r\n{-- New information chunk IDs ------------------------------------------------}\r\n\r\nconst\r\n infotypeDIGITIZATION_TIME = $54494449; // mmioFOURCC ('I','D','I','T')\r\n infotypeSMPTE_TIME = $504D5349; // mmioFOURCC ('I','S','M','P')\r\n\r\n{-- String IDs from status and error callbacks -------------------------------}\r\n\r\n IDS_CAP_BEGIN = 300; // \"Capture Start\" \r\n IDS_CAP_END = 301; // \"Capture End\" \r\n\r\n IDS_CAP_INFO = 401; // \"%s\" \r\n IDS_CAP_OUTOFMEM = 402; // \"Out of memory\" \r\n IDS_CAP_FILEEXISTS = 403; // \"File '%s' exists -- overwrite it?\" \r\n IDS_CAP_ERRORPALOPEN = 404; // \"Error opening palette '%s'\" \r\n IDS_CAP_ERRORPALSAVE = 405; // \"Error saving palette '%s'\" \r\n IDS_CAP_ERRORDIBSAVE = 406; // \"Error saving frame '%s'\" \r\n IDS_CAP_DEFAVIEXT = 407; // \"avi\" \r\n IDS_CAP_DEFPALEXT = 408; // \"pal\" \r\n IDS_CAP_CANTOPEN = 409; // \"Cannot open '%s'\"\r\n IDS_CAP_SEQ_MSGSTART = 410; // \"Select OK to start capture\\nof video sequence\\nto %s.\"\r\n IDS_CAP_SEQ_MSGSTOP = 411; // \"Hit ESCAPE or click to end capture\" \r\n\r\n IDS_CAP_VIDEDITERR = 412; // \"An error occurred while trying to run VidEdit.\" \r\n IDS_CAP_READONLYFILE = 413; // \"The file '%s' is a read-only file.\" \r\n IDS_CAP_WRITEERROR = 414; // \"Unable to write to file '%s'.\\nDisk may be full.\" \r\n IDS_CAP_NODISKSPACE = 415; // \"There is no space to create a capture file on the specified device.\" \r\n IDS_CAP_SETFILESIZE = 416; // \"Set File Size\" \r\n IDS_CAP_SAVEASPERCENT = 417; // \"SaveAs: %2ld%% Hit Escape to abort.\" \r\n\r\n IDS_CAP_DRIVER_ERROR = 418; // Driver specific error message \r\n\r\n IDS_CAP_WAVE_OPEN_ERROR = 419; // \"Error: Cannot open the wave input device.\\nCheck sample size, frequency, and channels.\" \r\n IDS_CAP_WAVE_ALLOC_ERROR = 420; // \"Error: Out of memory for wave buffers.\" \r\n IDS_CAP_WAVE_PREPARE_ERROR = 421; // \"Error: Cannot prepare wave buffers.\" \r\n IDS_CAP_WAVE_ADD_ERROR = 422; // \"Error: Cannot add wave buffers.\" \r\n IDS_CAP_WAVE_SIZE_ERROR = 423; // \"Error: Bad wave size.\" \r\n\r\n IDS_CAP_VIDEO_OPEN_ERROR = 424; // \"Error: Cannot open the video input device.\" \r\n IDS_CAP_VIDEO_ALLOC_ERROR = 425; // \"Error: Out of memory for video buffers.\"\r\n IDS_CAP_VIDEO_PREPARE_ERROR = 426; // \"Error: Cannot prepare video buffers.\" \r\n IDS_CAP_VIDEO_ADD_ERROR = 427; // \"Error: Cannot add video buffers.\" \r\n IDS_CAP_VIDEO_SIZE_ERROR = 428; // \"Error: Bad video size.\" \r\n\r\n IDS_CAP_FILE_OPEN_ERROR = 429; // \"Error: Cannot open capture file.\" \r\n IDS_CAP_FILE_WRITE_ERROR = 430; // \"Error: Cannot write to capture file. Disk may be full.\" \r\n IDS_CAP_RECORDING_ERROR = 431; // \"Error: Cannot write to capture file. Data rate too high or disk full.\" \r\n IDS_CAP_RECORDING_ERROR2 = 432; // \"Error while recording\" \r\n IDS_CAP_AVI_INIT_ERROR = 433; // \"Error: Unable to initialize for capture.\"\r\n IDS_CAP_NO_FRAME_CAP_ERROR = 434; // \"Warning: No frames captured.\\nConfirm that vertical sync interrupts\\nare configured and enabled.\" \r\n IDS_CAP_NO_PALETTE_WARN = 435; // \"Warning: Using default palette.\" \r\n IDS_CAP_MCI_CONTROL_ERROR = 436; // \"Error: Unable to access MCI device.\" \r\n IDS_CAP_MCI_CANT_STEP_ERROR = 437; // \"Error: Unable to step MCI device.\" \r\n IDS_CAP_NO_AUDIO_CAP_ERROR = 438; // \"Error: No audio data captured.\\nCheck audio card settings.\" \r\n IDS_CAP_AVI_DRAWDIB_ERROR = 439; // \"Error: Unable to draw this data format.\"\r\n IDS_CAP_COMPRESSOR_ERROR = 440; // \"Error: Unable to initialize compressor.\"\r\n IDS_CAP_AUDIO_DROP_ERROR = 441; // \"Error: Audio data was lost during capture, reduce capture rate.\"\r\n\r\n{-- Status string IDs --------------------------------------------------------}\r\n\r\n IDS_CAP_STAT_LIVE_MODE = 500; // \"Live window\" \r\n IDS_CAP_STAT_OVERLAY_MODE = 501; // \"Overlay window\" \r\n IDS_CAP_STAT_CAP_INIT = 502; // \"Setting up for capture - Please wait\" \r\n IDS_CAP_STAT_CAP_FINI = 503; // \"Finished capture, now writing frame %ld\" \r\n IDS_CAP_STAT_PALETTE_BUILD = 504; // \"Building palette map\" \r\n IDS_CAP_STAT_OPTPAL_BUILD = 505; // \"Computing optimal palette\" \r\n IDS_CAP_STAT_I_FRAMES = 506; // \"%d frames\" \r\n IDS_CAP_STAT_L_FRAMES = 507; // \"%ld frames\" \r\n IDS_CAP_STAT_CAP_L_FRAMES = 508; // \"Captured %ld frames\" \r\n IDS_CAP_STAT_CAP_AUDIO = 509; // \"Capturing audio\" \r\n IDS_CAP_STAT_VIDEOCURRENT = 510; // \"Captured %ld frames (%ld dropped) %d.%03d sec.\" \r\n IDS_CAP_STAT_VIDEOAUDIO = 511; // \"Captured %d.%03d sec. %ld frames (%ld dropped) (%d.%03d fps). %ld audio bytes (%d,%03d sps)\" \r\n IDS_CAP_STAT_VIDEOONLY = 512; // \"Captured %d.%03d sec. %ld frames (%ld dropped) (%d.%03d fps)\" \r\n IDS_CAP_STAT_FRAMESDROPPED = 513; // \"Dropped %ld of %ld frames (%d.%02d%%) during capture.\"\r\n\r\n{== FilePreview dialog =======================================================}\r\n\r\nfunction GetOpenFileNamePreviewA(lpofn: POPENFILENAMEA): BOOL; stdcall;\r\nfunction GetSaveFileNamePreviewA(lpofn: POPENFILENAMEA): BOOL; stdcall;\r\n\r\nfunction GetOpenFileNamePreviewW(lpofn: POPENFILENAMEW): BOOL; stdcall;\r\nfunction GetSaveFileNamePreviewW(lpofn: POPENFILENAMEW): BOOL; stdcall;\r\n\r\nfunction GetOpenFileNamePreview(lpofn: POPENFILENAMEA): BOOL; stdcall; // GetOpenFileNamePreviewA\r\nfunction GetSaveFileNamePreview(lpofn: POPENFILENAMEA): BOOL; stdcall; // GetSaveFileNamePreviewA\r\n\r\nimplementation\r\n\r\nfunction MKFOURCC( ch0, ch1, ch2, ch3: Char ): FOURCC;\r\nbegin\r\n Result := (DWord(Ord(ch0))) or\r\n (DWord(Ord(ch1)) shl 8) or\r\n (DWord(Ord(ch2)) shl 16) or\r\n (DWord(Ord(ch3)) shl 24);\r\nend;\r\n\r\nfunction mmioFOURCC( ch0, ch1, ch2, ch3: Char ): FOURCC;\r\nbegin\r\n Result := MKFOURCC(ch0,ch1,ch2,ch3);\r\nend;\r\n\r\nfunction aviTWOCC(ch0, ch1: Char): TWOCC;\r\nbegin\r\n Result := (Word(Ord(ch0))) or (Word(Ord(ch1)) shl 8);\r\nend;\r\n\r\n{-- Query macros -------------------------------------------------------------}\r\n\r\nfunction ICQueryAbout(hic: HIC): BOOL;\r\nbegin\r\n Result := ICSendMessage(hic, ICM_ABOUT, dword(-1), ICMF_ABOUT_QUERY) = ICERR_OK;\r\nend;\r\n\r\nfunction ICAbout(hic: HIC; hwnd: HWND): DWORD;\r\nbegin\r\n Result := ICSendMessage(hic, ICM_ABOUT, hwnd, 0);\r\nend;\r\n\r\nfunction ICQueryConfigure(hic: HIC): BOOL;\r\nbegin\r\n Result := ICSendMessage(hic, ICM_CONFIGURE, dword(-1), ICMF_CONFIGURE_QUERY) = ICERR_OK;\r\nend;\r\n\r\nfunction ICConfigure(hic: HIC; hwnd: HWND): DWORD;\r\nbegin\r\n Result := ICSendMessage(hic, ICM_CONFIGURE, hwnd, 0);\r\nend;\r\n\r\n{-- Get/Set state macros -----------------------------------------------------}\r\n\r\nfunction ICGetState(hic: HIC; pv: PVOID; cb: DWORD): DWORD;\r\nbegin\r\n Result := ICSendMessage(hic, ICM_GETSTATE, DWORD(pv), cb);\r\nend;\r\n\r\nfunction ICSetState(hic: HIC; pv: PVOID; cb: DWORD): DWORD;\r\nbegin\r\n Result := ICSendMessage(hic, ICM_SETSTATE, DWORD(pv), cb);\r\nend;\r\n\r\nfunction ICGetStateSize(hic: HIC): DWORD;\r\nbegin\r\n Result := ICGetState(hic, nil, 0);\r\nend;\r\n\r\n{-- Get value macros ---------------------------------------------------------}\r\n\r\nfunction ICGetDefaultQuality(hic: HIC): DWORD;\r\nbegin\r\n ICSendMessage(hic, ICM_GETDEFAULTQUALITY, DWORD(@Result), sizeof(Result));\r\nend;\r\n\r\nfunction ICGetDefaultKeyFrameRate(hic: HIC): DWORD;\r\nbegin\r\n ICSendMessage(hic, ICM_GETDEFAULTKEYFRAMERATE, DWORD(@Result), sizeof(Result));\r\nend;\r\n\r\n{-- Draw window macro --------------------------------------------------------}\r\n\r\nfunction ICDrawWindow(hic: HIC; prc: PRECT): DWORD;\r\nbegin\r\n Result := ICSendMessage(hic, ICM_DRAW_WINDOW, DWORD(prc), sizeof(prc^));\r\nend;\r\n\r\n{-- ICCompressBegin() - start compression from a source fmt to a dest fmt ----}\r\n\r\nfunction ICCompressBegin(hic: HIC; lpbiInput, lpbiOutput: PBITMAPINFOHEADER): DWORD;\r\nbegin\r\n Result := ICSendMessage(hic, ICM_COMPRESS_BEGIN, DWORD(lpbiInput), DWORD(lpbiOutput));\r\nend;\r\n\r\n{-- ICCompressQuery() - determines if compression from src to dst is supp ----}\r\n\r\nfunction ICCompressQuery(hic: HIC; lpbiInput, lpbiOutput: PBITMAPINFOHEADER): DWORD;\r\nbegin\r\n Result := ICSendMessage(hic, ICM_COMPRESS_QUERY, DWORD(lpbiInput), DWORD(lpbiOutput));\r\nend;\r\n\r\n{-- ICCompressGetFormat() - get the output format (fmt of compressed) --------}\r\n\r\n// if lpbiOutput is nil return the size in bytes needed for format.\r\n\r\nfunction ICCompressGetFormat(hic: HIC; lpbiInput, lpbiOutput: PBITMAPINFOHEADER): DWORD;\r\nbegin\r\n Result := ICSendMessage(hic, ICM_COMPRESS_GET_FORMAT, DWORD(lpbiInput), DWORD(lpbiOutput));\r\nend;\r\n\r\nfunction ICCompressGetFormatSize(hic: HIC; lpbi: PBITMAPINFOHEADER): DWORD;\r\nbegin\r\n Result := ICCompressGetFormat(hic, lpbi, nil);\r\nend;\r\n\r\n{-- ICCompressSize() - return the maximal size of a compressed frame ---------}\r\n\r\nfunction ICCompressGetSize(hic: HIC; lpbiInput, lpbiOutput: PBITMAPINFOHEADER): DWORD;\r\nbegin\r\n Result := ICSendMessage(hic, ICM_COMPRESS_GET_SIZE, DWORD(lpbiInput), DWORD(lpbiOutput));\r\nend;\r\n\r\nfunction ICCompressEnd(hic: HIC): DWORD;\r\nbegin\r\n Result := ICSendMessage(hic, ICM_COMPRESS_END, 0, 0);\r\nend;\r\n\r\n{-- ICDecompressBegin() - start compression from src fmt to a dest fmt -------}\r\n\r\nfunction ICDecompressBegin(hic: HIC; lpbiInput, lpbiOutput: PBITMAPINFOHEADER): DWORD;\r\nbegin\r\n Result := ICSendMessage(hic, ICM_DECOMPRESS_BEGIN, DWORD(lpbiInput), DWORD(lpbiOutput));\r\nend;\r\n\r\n{-- ICDecompressQuery() - determines if compression is supported -------------}\r\n\r\nfunction ICDecompressQuery(hic: HIC; lpbiInput, lpbiOutput: PBITMAPINFOHEADER): DWORD;\r\nbegin\r\n Result := ICSendMessage(hic, ICM_DECOMPRESS_QUERY, DWORD(lpbiInput), DWORD(lpbiOutput));\r\nend;\r\n\r\n{-- ICDecompressGetFormat - get the output fmt (fmt of uncompressed data) ----}\r\n\r\n// if lpbiOutput is NULL return the size in bytes needed for format.\r\n\r\nfunction ICDecompressGetFormat(hic: HIC; lpbiInput, lpbiOutput: PBITMAPINFOHEADER): DWORD;\r\nbegin\r\n Result := ICSendMessage(hic, ICM_DECOMPRESS_GET_FORMAT, DWORD(lpbiInput), DWORD(lpbiOutput));\r\nend;\r\n\r\nfunction ICDecompressGetFormatSize(hic: HIC; lpbi: PBITMAPINFOHEADER): DWORD;\r\nbegin\r\n Result := ICDecompressGetFormat(hic, lpbi, nil);\r\nend;\r\n\r\n{-- ICDecompressGetPalette() - get the output palette ------------------------}\r\n\r\nfunction ICDecompressGetPalette(hic: HIC; lpbiInput, lpbiOutput: PBITMAPINFOHEADER): DWORD;\r\nbegin\r\n Result := ICSendMessage(hic, ICM_DECOMPRESS_GET_PALETTE, DWORD(lpbiInput), DWORD(lpbiOutput));\r\nend;\r\n\r\nfunction ICDecompressSetPalette(hic: HIC; lpbiPalette: PBITMAPINFOHEADER): DWORD;\r\nbegin\r\n Result := ICSendMessage(hic, ICM_DECOMPRESS_SET_PALETTE, DWORD(lpbiPalette), 0);\r\nend;\r\n\r\nfunction ICDecompressEnd(hic: HIC): DWORD;\r\nbegin\r\n Result := ICSendMessage(hic, ICM_DECOMPRESS_END, 0, 0);\r\nend;\r\n\r\n{-- ICDecompressEx() - decompress a single frame -----------------------------}\r\n\r\nfunction ICDecompressEx(\r\n hic : HIC;\r\n dwFlags : DWORD;\r\n lpbiSrc : PBITMAPINFOHEADER;\r\n lpSrc : PVOID;\r\n xSrc : int;\r\n ySrc : int;\r\n dxSrc : int;\r\n dySrc : int;\r\n lpbiDst : PBITMAPINFOHEADER;\r\n lpDst : PVOID;\r\n xDst : int;\r\n yDst : int;\r\n dxDst : int;\r\n dyDst : int\r\n ): DWORD; stdcall;\r\nvar\r\n ic : TICDECOMPRESSEX;\r\nbegin\r\n ic.dwFlags := dwFlags;\r\n ic.lpbiSrc := lpbiSrc;\r\n ic.lpSrc := lpSrc;\r\n ic.xSrc := xSrc;\r\n ic.ySrc := ySrc;\r\n ic.dxSrc := dxSrc;\r\n ic.dySrc := dySrc;\r\n ic.lpbiDst := lpbiDst;\r\n ic.lpDst := lpDst;\r\n ic.xDst := xDst;\r\n ic.yDst := yDst;\r\n ic.dxDst := dxDst;\r\n ic.dyDst := dyDst;\r\n\r\n // note that ICM swaps round the length and pointer\r\n // length in lparam2, pointer in lparam1\r\n Result := ICSendMessage(hic, ICM_DECOMPRESSEX, DWORD(@ic), sizeof(ic));\r\nend;\r\n\r\n{-- ICDecompressExBegin() - start compression from a src fmt to a dest fmt ---}\r\n\r\nfunction ICDecompressExBegin(\r\n hic : HIC;\r\n dwFlags : DWORD;\r\n lpbiSrc : PBITMAPINFOHEADER;\r\n lpSrc : PVOID;\r\n xSrc : int;\r\n ySrc : int;\r\n dxSrc : int;\r\n dySrc : int;\r\n lpbiDst : PBITMAPINFOHEADER;\r\n lpDst : PVOID;\r\n xDst : int;\r\n yDst : int;\r\n dxDst : int;\r\n dyDst : int\r\n ): DWORD; stdcall;\r\nvar\r\n ic : TICDECOMPRESSEX ;\r\nbegin\r\n ic.dwFlags := dwFlags;\r\n ic.lpbiSrc := lpbiSrc;\r\n ic.lpSrc := lpSrc;\r\n ic.xSrc := xSrc;\r\n ic.ySrc := ySrc;\r\n ic.dxSrc := dxSrc;\r\n ic.dySrc := dySrc;\r\n ic.lpbiDst := lpbiDst;\r\n ic.lpDst := lpDst;\r\n ic.xDst := xDst;\r\n ic.yDst := yDst;\r\n ic.dxDst := dxDst;\r\n ic.dyDst := dyDst;\r\n\r\n // note that ICM swaps round the length and pointer\r\n // length in lparam2, pointer in lparam1\r\n Result := ICSendMessage(hic, ICM_DECOMPRESSEX_BEGIN, DWORD(@ic), sizeof(ic));\r\nend;\r\n\r\n{-- ICDecompressExQuery() ----------------------------------------------------}\r\n\r\nfunction ICDecompressExQuery(\r\n hic : HIC;\r\n dwFlags : DWORD;\r\n lpbiSrc : PBITMAPINFOHEADER;\r\n lpSrc : PVOID;\r\n xSrc : int;\r\n ySrc : int;\r\n dxSrc : int;\r\n dySrc : int;\r\n lpbiDst : PBITMAPINFOHEADER;\r\n lpDst : PVOID;\r\n xDst : int;\r\n yDst : int;\r\n dxDst : int;\r\n dyDst : int\r\n ): DWORD; stdcall;\r\nvar\r\n ic : TICDECOMPRESSEX;\r\nbegin\r\n ic.dwFlags := dwFlags;\r\n ic.lpbiSrc := lpbiSrc;\r\n ic.lpSrc := lpSrc;\r\n ic.xSrc := xSrc;\r\n ic.ySrc := ySrc;\r\n ic.dxSrc := dxSrc;\r\n ic.dySrc := dySrc;\r\n ic.lpbiDst := lpbiDst;\r\n ic.lpDst := lpDst;\r\n ic.xDst := xDst;\r\n ic.yDst := yDst;\r\n ic.dxDst := dxDst;\r\n ic.dyDst := dyDst;\r\n\r\n // note that ICM swaps round the length and pointer\r\n // length in lparam2, pointer in lparam1\r\n Result := ICSendMessage(hic, ICM_DECOMPRESSEX_QUERY, DWORD(@ic), sizeof(ic));\r\nend;\r\n\r\nfunction ICDecompressExEnd(hic: HIC): DWORD;\r\nbegin\r\n Result := ICSendMessage(hic, ICM_DECOMPRESSEX_END, 0, 0)\r\nend;\r\n\r\nfunction ICDrawSuggestFormat(\r\n hic : HIC;\r\n lpbiIn : PBITMAPINFOHEADER;\r\n lpbiOut : PBITMAPINFOHEADER;\r\n dxSrc : int;\r\n dySrc : int;\r\n dxDst : int;\r\n dyDst : int;\r\n hicDecomp : HIC\r\n ): DWORD; stdcall;\r\nvar\r\n ic : TICDRAWSUGGEST;\r\nbegin\r\n ic.lpbiIn := lpbiIn;\r\n ic.lpbiSuggest := lpbiOut;\r\n ic.dxSrc := dxSrc;\r\n ic.dySrc := dySrc;\r\n ic.dxDst := dxDst;\r\n ic.dyDst := dyDst;\r\n ic.hicDecompressor := hicDecomp;\r\n\r\n // note that ICM swaps round the length and pointer\r\n // length in lparam2, pointer in lparam1\r\n Result := ICSendMessage(hic, ICM_DRAW_SUGGESTFORMAT, DWORD(@ic), sizeof(ic));\r\nend;\r\n\r\n{-- ICDrawQuery() - determines if the compressor is willing to render fmt ----}\r\n\r\nfunction ICDrawQuery(hic: HIC; lpbiInput: PBITMAPINFOHEADER): DWORD;\r\nbegin\r\n Result := ICSendMessage(hic, ICM_DRAW_QUERY, DWORD(lpbiInput), 0);\r\nend;\r\n\r\nfunction ICDrawChangePalette(hic: HIC; lpbiInput: PBITMAPINFOHEADER): DWORD;\r\nbegin\r\n Result := ICSendMessage(hic, ICM_DRAW_CHANGEPALETTE, DWORD(lpbiInput), 0);\r\nend;\r\n\r\nfunction ICGetBuffersWanted(hic: HIC; lpdwBuffers: PDWORD): DWORD;\r\nbegin\r\n Result := ICSendMessage(hic, ICM_GETBUFFERSWANTED, DWORD(lpdwBuffers), 0);\r\nend;\r\n\r\nfunction ICDrawEnd(hic: HIC): DWORD;\r\nbegin\r\n Result := ICSendMessage(hic, ICM_DRAW_END, 0, 0);\r\nend;\r\n\r\nfunction ICDrawStart(hic: HIC): DWORD;\r\nbegin\r\n Result := ICSendMessage(hic, ICM_DRAW_START, 0, 0);\r\nend;\r\n\r\nfunction ICDrawStartPlay(hic: HIC; lFrom, lTo: DWORD): DWORD;\r\nbegin\r\n Result := ICSendMessage(hic, ICM_DRAW_START_PLAY, lFrom, lTo);\r\nend;\r\n\r\nfunction ICDrawStop(hic: HIC): DWORD;\r\nbegin\r\n Result := ICSendMessage(hic, ICM_DRAW_STOP, 0, 0);\r\nend;\r\n\r\nfunction ICDrawStopPlay(hic: HIC): DWORD;\r\nbegin\r\n Result := ICSendMessage(hic, ICM_DRAW_STOP_PLAY, 0, 0);\r\nend;\r\n\r\nfunction ICDrawGetTime(hic: HIC; lplTime: PDWORD): DWORD;\r\nbegin\r\n Result := ICSendMessage(hic, ICM_DRAW_GETTIME, DWORD(lplTime), 0);\r\nend;\r\n\r\nfunction ICDrawSetTime(hic: HIC; lTime: DWORD): DWORD;\r\nbegin\r\n Result := ICSendMessage(hic, ICM_DRAW_SETTIME, lTime, 0);\r\nend;\r\n\r\nfunction ICDrawRealize(hic: HIC; hdc: HDC; fBackground: BOOL): DWORD;\r\nbegin\r\n Result := ICSendMessage(hic, ICM_DRAW_REALIZE, DWORD(hdc), DWORD(fBackground));\r\nend;\r\n\r\nfunction ICDrawFlush(hic: HIC): DWORD;\r\nbegin\r\n Result := ICSendMessage(hic, ICM_DRAW_FLUSH, 0, 0);\r\nend;\r\n\r\nfunction ICDrawRenderBuffer(hic: HIC): DWORD;\r\nbegin\r\n Result := ICSendMessage(hic, ICM_DRAW_RENDERBUFFER, 0, 0);\r\nend;\r\n\r\n{-- ICSetStatusProc() - Set the status callback function ---------------------}\r\n\r\n// ICMessage is not supported on NT\r\n\r\nfunction ICSetStatusProc(\r\n hic : HIC;\r\n dwFlags : DWORD;\r\n lParam : DWORD;\r\n fpfnStatus : TICStatusProc\r\n ): DWORD; stdcall;\r\nvar\r\n ic : TICSETSTATUSPROC;\r\nbegin\r\n ic.dwFlags := dwFlags;\r\n ic.lParam := lParam;\r\n ic.Status := fpfnStatus;\r\n\r\n // note that ICM swaps round the length and pointer\r\n // length in lparam2, pointer in lparam1\r\n Result := ICSendMessage(hic, ICM_SET_STATUS_PROC, DWORD(@ic), sizeof(ic));\r\nend;\r\n\r\n{== Helper routines for DrawDib and MCIAVI... ================================}\r\n\r\nfunction ICDecompressOpen(fccType, fccHandler: DWORD; lpbiIn, lpbiOut: PBITMAPINFOHEADER): HIC;\r\nbegin\r\n Result := ICLocate(fccType, fccHandler, lpbiIn, lpbiOut, ICMODE_DECOMPRESS);\r\nend;\r\n\r\nfunction ICDrawOpen(fccType, fccHandler: DWORD; lpbiIn: PBITMAPINFOHEADER): HIC;\r\nbegin\r\n Result := ICLocate(fccType, fccHandler, lpbiIn, nil, ICMODE_DRAW);\r\nend;\r\n\r\n{-- DrawDibUpdate() - redraw last image (may only be valid with DDF_BUFFER) --}\r\n\r\nfunction DrawDibUpdate(hdd: HDRAWDIB; hdc: HDC; x, y: int): BOOL;\r\nbegin\r\n Result := DrawDibDraw(hdd, hdc, x, y, 0, 0, nil, nil, 0, 0, 0, 0, DDF_UPDATE);\r\nend;\r\n\r\n{== Useful macros ============================================================}\r\n\r\n{-- Macro to get stream number out of a FOURCC ckid --------------------------}\r\n\r\nfunction FromHex(n: BYTE): BYTE;\r\nbegin\r\n if n >= Ord('A') then\r\n Result := Ord(n) + 10 - Ord('A')\r\n else\r\n Result := Ord(n) - Ord('0');\r\nend;\r\n\r\nfunction StreamFromFOURCC(fcc: DWORD): BYTE;\r\nbegin\r\n Result := (FromHex(Lo(LoWord(fcc))) shl 4) + FromHex(Hi(LoWord(fcc)));\r\nend;\r\n\r\n{-- Macro to get TWOCC chunk type out of a FOURCC ckid -----------------------}\r\n\r\nfunction TWOCCFromFOURCC(fcc: DWORD): WORD;\r\nbegin\r\n Result := HiWord(fcc);\r\nend;\r\n\r\n{-- Macro to make a ckid for a chunk out of a TWOCC and a stream num (0-255) -}\r\n\r\nfunction ToHex(n: BYTE): BYTE;\r\nbegin\r\n if n > 9 then\r\n Result := n - 10 + Ord('A')\r\n else\r\n Result := n + Ord('0');\r\nend;\r\n\r\nfunction MAKEAVICKID(tcc: WORD; stream: BYTE): DWORD;\r\nbegin\r\n Result := MakeLONG((ToHex(stream and $0F) shl 8) or ToHex((stream and $F0) shr 4),tcc);\r\nend;\r\n\r\n{-- Helper macros ------------------------------------------------------------}\r\n\r\nfunction AVIStreamSampleToSample(pavi1, pavi2: IAVISTREAM; l: LONG): LONG;\r\nbegin\r\n Result := AVIStreamTimeToSample(pavi1,AVIStreamSampleToTime(pavi2, l));\r\nend;\r\n\r\nfunction AVIStreamNextSample(pavi: IAVISTREAM; l: LONG): LONG;\r\nbegin\r\n Result := AVIStreamFindSample(pavi,l+1,FIND_NEXT or FIND_ANY);\r\nend;\r\n\r\nfunction AVIStreamPrevSample(pavi: IAVISTREAM; l: LONG): LONG;\r\nbegin\r\n Result := AVIStreamFindSample(pavi,l-1,FIND_PREV or FIND_ANY);\r\nend;\r\n\r\nfunction AVIStreamNearestSample(pavi: IAVISTREAM; l: LONG): LONG;\r\nbegin\r\n Result := AVIStreamFindSample(pavi,l,FIND_PREV or FIND_ANY);\r\nend;\r\n\r\nfunction AVIStreamNextKeyFrame(pavi: IAVISTREAM; l: LONG): LONG;\r\nbegin\r\n Result := AVIStreamFindSample(pavi,l+1,FIND_NEXT or FIND_KEY);\r\nend;\r\n\r\nfunction AVIStreamPrevKeyFrame(pavi: IAVISTREAM; l: LONG): LONG;\r\nbegin\r\n Result := AVIStreamFindSample(pavi,l-1,FIND_PREV or FIND_KEY);\r\nend;\r\n\r\nfunction AVIStreamNearestKeyFrame(pavi: IAVISTREAM; l: LONG): LONG;\r\nbegin\r\n Result := AVIStreamFindSample(pavi,l,FIND_PREV or FIND_KEY)\r\nend;\r\n\r\nfunction AVIStreamIsKeyFrame(pavi: IAVISTREAM; l: LONG): BOOL;\r\nbegin\r\n Result := AVIStreamNearestKeyFrame(pavi,l) = l;\r\nend;\r\n\r\nfunction AVIStreamPrevSampleTime(pavi: IAVISTREAM; t: LONG): LONG;\r\nbegin\r\n Result := AVIStreamSampleToTime(pavi, AVIStreamPrevSample(pavi,AVIStreamTimeToSample(pavi,t)));\r\nend;\r\n\r\nfunction AVIStreamNextSampleTime(pavi: IAVISTREAM; t: LONG): LONG;\r\nbegin\r\n Result := AVIStreamSampleToTime(pavi, AVIStreamNextSample(pavi,AVIStreamTimeToSample(pavi,t)));\r\nend;\r\n\r\nfunction AVIStreamNearestSampleTime(pavi: IAVISTREAM; t: LONG): LONG;\r\nbegin\r\n Result := AVIStreamSampleToTime(pavi, AVIStreamNearestSample(pavi,AVIStreamTimeToSample(pavi,t)));\r\nend;\r\n\r\nfunction AVIStreamNextKeyFrameTime(pavi: IAVISTREAM; t: LONG): LONG;\r\nbegin\r\n Result := AVIStreamSampleToTime(pavi, AVIStreamNextKeyFrame(pavi,AVIStreamTimeToSample(pavi, t)));\r\nend;\r\n\r\nfunction AVIStreamPrevKeyFrameTime(pavi: IAVISTREAM; t: LONG): LONG;\r\nbegin\r\n Result := AVIStreamSampleToTime(pavi, AVIStreamPrevKeyFrame(pavi,AVIStreamTimeToSample(pavi, t)));\r\nend;\r\n\r\nfunction AVIStreamNearestKeyFrameTime(pavi: IAVISTREAM; t: LONG): LONG;\r\nbegin\r\n Result := AVIStreamSampleToTime(pavi, AVIStreamNearestKeyFrame(pavi,AVIStreamTimeToSample(pavi, t)));\r\nend;\r\n\r\nfunction AVIStreamStartTime(pavi: IAVISTREAM): LONG;\r\nbegin\r\n Result := AVIStreamSampleToTime(pavi, AVIStreamStart(pavi));\r\nend;\r\n\r\nfunction AVIStreamLengthTime(pavi: IAVISTREAM): LONG;\r\nbegin\r\n Result := AVIStreamSampleToTime(pavi, AVIStreamLength(pavi));\r\nend;\r\n\r\nfunction AVIStreamEnd(pavi: IAVISTREAM): LONG;\r\nbegin\r\n Result := AVIStreamStart(pavi) + AVIStreamLength(pavi);\r\nend;\r\n\r\nfunction AVIStreamEndTime(pavi: IAVISTREAM): LONG;\r\nbegin\r\n Result := AVIStreamSampleToTime(pavi, AVIStreamEnd(pavi));\r\nend;\r\n\r\nfunction AVIStreamSampleSize(pavi: IAVISTREAM; lPos: LONG; plSize: PLONG): LONG;\r\nbegin\r\n Result := AVIStreamRead(pavi,lPos,1,nil,0,plSize,nil);\r\nend;\r\n\r\nfunction AVIStreamFormatSize(pavi: IAVISTREAM; lPos: LONG; plSize: PLONG): HResult;\r\nbegin\r\n Result := AVIStreamReadFormat(pavi,lPos,nil,plSize);\r\nend;\r\n\r\nfunction AVIStreamDataSize(pavi: IAVISTREAM; fcc: DWORD; plSize: PLONG): HResult;\r\nbegin\r\n Result := AVIStreamReadData(pavi,fcc,nil,plSize)\r\nend;\r\n\r\n{== MCIWnd ===================================================================}\r\n\r\nfunction MCIWndSM(hWnd: HWND; Msg: UINT; wParam: WPARAM; lParam: LPARAM): DWORD;\r\nbegin\r\n Result := SendMessage(hWnd, Msg, wParam, lParam);\r\nend;\r\n\r\n{-- Can macros ---------------------------------------------------------------}\r\n\r\nfunction MCIWndCanPlay(hwnd: HWND): BOOL;\r\nbegin\r\n Result := MCIWndSM(hwnd,MCIWNDM_CAN_PLAY,0,0) <> 0;\r\nend;\r\n\r\nfunction MCIWndCanRecord(hwnd: HWND): BOOL;\r\nbegin\r\n Result := MCIWndSM(hwnd,MCIWNDM_CAN_RECORD,0,0) <> 0;\r\nend;\r\n\r\nfunction MCIWndCanSave(hwnd: HWND): BOOL;\r\nbegin\r\n Result := MCIWndSM(hwnd,MCIWNDM_CAN_SAVE,0,0) <> 0;\r\nend;\r\n\r\nfunction MCIWndCanWindow(hwnd: HWND): BOOL;\r\nbegin\r\n Result := MCIWndSM(hwnd,MCIWNDM_CAN_WINDOW,0,0) <> 0;\r\nend;\r\n\r\nfunction MCIWndCanEject(hwnd: HWND): BOOL;\r\nbegin\r\n Result := MCIWndSM(hwnd,MCIWNDM_CAN_EJECT,0,0) <> 0;\r\nend;\r\n\r\nfunction MCIWndCanConfig(hwnd: HWND): BOOL;\r\nbegin\r\n Result := MCIWndSM(hwnd,MCIWNDM_CAN_CONFIG,0,0) <> 0;\r\nend;\r\n\r\nfunction MCIWndPaletteKick(hwnd: HWND): BOOL;\r\nbegin\r\n Result := MCIWndSM(hwnd,MCIWNDM_PALETTEKICK,0,0) <> 0;\r\nend;\r\n\r\nfunction MCIWndSave(hwnd: HWND; szFile: LPCSTR): DWORD;\r\nbegin\r\n Result := MCIWndSM(hwnd, MCI_SAVE, 0, LPARAM(szFile));\r\nend;\r\n\r\nfunction MCIWndSaveDialog(hwnd: HWND): DWORD;\r\nbegin\r\n Result := MCIWndSave(hwnd, LPCSTR(-1));\r\nend;\r\n\r\n// If you dont give a device it will use the current device....\r\n\r\nfunction MCIWndNew(hwnd: HWND; lp: PVOID): DWORD;\r\nbegin\r\n Result := MCIWndSM(hwnd, MCIWNDM_NEW, 0, LPARAM(lp));\r\nend;\r\n\r\nfunction MCIWndRecord(hwnd: HWND): DWORD;\r\nbegin\r\n Result := MCIWndSM(hwnd, MCI_RECORD, 0, 0);\r\nend;\r\n\r\nfunction MCIWndOpen(hwnd: HWND; sz: LPCSTR; f: BOOL): DWORD;\r\nbegin\r\n Result := MCIWndSM(hwnd, MCIWNDM_OPEN, WPARAM(f), LPARAM(sz));\r\nend;\r\n\r\nfunction MCIWndOpenDialog(hwnd: HWND): DWORD;\r\nbegin\r\n Result := MCIWndOpen(hwnd, LPCSTR(-1), False);\r\nend;\r\n\r\nfunction MCIWndClose(hwnd: HWND): DWORD;\r\nbegin\r\n Result := MCIWndSM(hwnd, MCI_CLOSE, 0, 0);\r\nend;\r\n\r\nfunction MCIWndPlay(hwnd: HWND): DWORD;\r\nbegin\r\n Result := MCIWndSM(hwnd, MCI_PLAY, 0, 0);\r\nend;\r\n\r\nfunction MCIWndStop(hwnd: HWND): DWORD;\r\nbegin\r\n Result := MCIWndSM(hwnd, MCI_STOP, 0, 0);\r\nend;\r\n\r\nfunction MCIWndPause(hwnd: HWND): DWORD;\r\nbegin\r\n Result := MCIWndSM(hwnd, MCI_PAUSE, 0, 0);\r\nend;\r\n\r\nfunction MCIWndResume(hwnd: HWND): DWORD;\r\nbegin\r\n Result := MCIWndSM(hwnd, MCI_RESUME, 0, 0);\r\nend;\r\n\r\nfunction MCIWndSeek(hwnd: HWND; lPos: DWORD): DWORD;\r\nbegin\r\n Result := MCIWndSM(hwnd, MCI_SEEK, 0, lPos);\r\nend;\r\n\r\nfunction MCIWndEject(hwnd: HWND): DWORD;\r\nbegin\r\n Result := MCIWndSM(hwnd, MCIWNDM_EJECT, 0, 0);\r\nend;\r\n\r\nfunction MCIWndHome(hwnd: HWND): DWORD;\r\nbegin\r\n Result := MCIWndSeek(hwnd, MCIWND_START);\r\nend;\r\n\r\nfunction MCIWndEnd(hwnd: HWND): DWORD;\r\nbegin\r\n Result := MCIWndSeek(hwnd, MCIWND_END);\r\nend;\r\n\r\nfunction MCIWndGetSource(hwnd: HWND; prc: PRECT): DWORD;\r\nbegin\r\n Result := MCIWndSM(hwnd, MCIWNDM_GET_SOURCE, 0, LPARAM(prc));\r\nend;\r\n\r\nfunction MCIWndPutSource(hwnd: HWND; prc: PRECT): DWORD;\r\nbegin\r\n Result := MCIWndSM(hwnd, MCIWNDM_PUT_SOURCE, 0, LPARAM(prc));\r\nend;\r\n\r\nfunction MCIWndGetDest(hwnd: HWND; prc: PRECT): DWORD;\r\nbegin\r\n Result := MCIWndSM(hwnd, MCIWNDM_GET_DEST, 0, LPARAM(prc));\r\nend;\r\n\r\nfunction MCIWndPutDest(hwnd: HWND; prc: PRECT): DWORD;\r\nbegin\r\n Result := MCIWndSM(hwnd, MCIWNDM_PUT_DEST, 0, LPARAM(prc));\r\nend;\r\n\r\nfunction MCIWndPlayReverse(hwnd: HWND): DWORD;\r\nbegin\r\n Result := MCIWndSM(hwnd, MCIWNDM_PLAYREVERSE, 0, 0);\r\nend;\r\n\r\nfunction MCIWndPlayFrom(hwnd: HWND; lPos: DWORD): DWORD;\r\nbegin\r\n Result := MCIWndSM(hwnd, MCIWNDM_PLAYFROM, 0, lPos);\r\nend;\r\n\r\nfunction MCIWndPlayTo(hwnd: HWND; lPos: DWORD): DWORD;\r\nbegin\r\n Result := MCIWndSM(hwnd, MCIWNDM_PLAYTO, 0, lPos);\r\nend;\r\n\r\nfunction MCIWndPlayFromTo(hwnd: HWND; lStart, lEnd: DWORD): DWORD;\r\nbegin\r\n MCIWndSeek(hwnd, lStart);\r\n Result := MCIWndPlayTo(hwnd, lEnd);\r\nend;\r\n\r\nfunction MCIWndGetDeviceID(hwnd: HWND): UINT;\r\nbegin\r\n Result := MCIWndSM(hwnd, MCIWNDM_GETDEVICEID, 0, 0);\r\nend;\r\n\r\nfunction MCIWndGetAlias(hwnd: HWND): UINT;\r\nbegin\r\n Result := MCIWndSM(hwnd, MCIWNDM_GETALIAS, 0, 0);\r\nend;\r\n\r\nfunction MCIWndGetMode(hwnd: HWND; lp: LPCSTR; len: UINT): DWORD;\r\nbegin\r\n Result := MCIWndSM(hwnd, MCIWNDM_GETMODE, len, LPARAM(lp));\r\nend;\r\n\r\nfunction MCIWndGetPosition(hwnd: HWND): DWORD;\r\nbegin\r\n Result := MCIWndSM(hwnd, MCIWNDM_GETPOSITION, 0, 0);\r\nend;\r\n\r\nfunction MCIWndGetPositionString(hwnd: HWND; lp: LPCSTR; len: UINT): DWORD;\r\nbegin\r\n Result := MCIWndSM(hwnd, MCIWNDM_GETPOSITION, len, LPARAM(lp));\r\nend;\r\n\r\nfunction MCIWndGetStart(hwnd: HWND): DWORD;\r\nbegin\r\n Result := MCIWndSM(hwnd, MCIWNDM_GETSTART, 0, 0);\r\nend;\r\n\r\nfunction MCIWndGetLength(hwnd: HWND): DWORD;\r\nbegin\r\n Result := MCIWndSM(hwnd, MCIWNDM_GETLENGTH, 0, 0);\r\nend;\r\n\r\nfunction MCIWndGetEnd(hwnd: HWND): DWORD;\r\nbegin\r\n Result := MCIWndSM(hwnd, MCIWNDM_GETEND, 0, 0);\r\nend;\r\n\r\nfunction MCIWndStep(hwnd: HWND; n: DWORD): DWORD;\r\nbegin\r\n Result := MCIWndSM(hwnd, MCI_STEP, 0, n);\r\nend;\r\n\r\nprocedure MCIWndDestroy(hwnd: HWND);\r\nbegin\r\n MCIWndSM(hwnd, WM_CLOSE, 0, 0);\r\nend;\r\n\r\nprocedure MCIWndSetZoom(hwnd: HWND; iZoom: UINT);\r\nbegin\r\n MCIWndSM(hwnd, MCIWNDM_SETZOOM, 0, iZoom);\r\nend;\r\n\r\nfunction MCIWndGetZoom(hwnd: HWND): UINT;\r\nbegin\r\n Result := MCIWndSM(hwnd, MCIWNDM_GETZOOM, 0, 0);\r\nend;\r\n\r\nfunction MCIWndSetVolume(hwnd: HWND; iVol: UINT): DWORD;\r\nbegin\r\n Result := MCIWndSM(hwnd, MCIWNDM_SETVOLUME, 0, iVol);\r\nend;\r\n\r\nfunction MCIWndGetVolume(hwnd: HWND): DWORD;\r\nbegin\r\n Result := MCIWndSM(hwnd, MCIWNDM_GETVOLUME, 0, 0);\r\nend;\r\n\r\nfunction MCIWndSetSpeed(hwnd: HWND; iSpeed: UINT): DWORD;\r\nbegin\r\n Result := MCIWndSM(hwnd, MCIWNDM_SETSPEED, 0, iSpeed);\r\nend;\r\n\r\nfunction MCIWndGetSpeed(hwnd: HWND): DWORD;\r\nbegin\r\n Result := MCIWndSM(hwnd, MCIWNDM_GETSPEED, 0, 0);\r\nend;\r\n\r\nfunction MCIWndSetTimeFormat(hwnd: HWND; lp: LPCSTR): DWORD;\r\nbegin\r\n Result := MCIWndSM(hwnd, MCIWNDM_SETTIMEFORMAT, 0, LPARAM(lp));\r\nend;\r\n\r\nfunction MCIWndGetTimeFormat(hwnd: HWND; lp: LPCSTR; len: UINT): DWORD;\r\nbegin\r\n Result := MCIWndSM(hwnd, MCIWNDM_GETTIMEFORMAT, len, LPARAM(lp));\r\nend;\r\n\r\nprocedure MCIWndValidateMedia(hwnd: HWND);\r\nbegin\r\n MCIWndSM(hwnd, MCIWNDM_VALIDATEMEDIA, 0, 0);\r\nend;\r\n\r\nprocedure MCIWndSetRepeat(hwnd: HWND; f: BOOL);\r\nbegin\r\n MCIWndSM(hwnd, MCIWNDM_SETREPEAT, 0, LPARAM(f));\r\nend;\r\n\r\nfunction MCIWndGetRepeat(hwnd: HWND): BOOL;\r\nbegin\r\n Result := MCIWndSM(hwnd, MCIWNDM_GETREPEAT, 0, 0) <> 0;\r\nend;\r\n\r\nfunction MCIWndUseFrames(hwnd: HWND): DWORD;\r\nbegin\r\n Result := MCIWndSetTimeFormat(hwnd, 'frames');\r\nend;\r\n\r\nfunction MCIWndUseTime(hwnd: HWND): DWORD;\r\nbegin\r\n Result := MCIWndSetTimeFormat(hwnd, 'ms');\r\nend;\r\n\r\nprocedure MCIWndSetActiveTimer(hwnd: HWND; active: UINT);\r\nbegin\r\n MCIWndSM(hwnd, MCIWNDM_SETACTIVETIMER, active, 0);\r\nend;\r\n\r\nprocedure MCIWndSetInactiveTimer(hwnd: HWND; inactive: UINT);\r\nbegin\r\n MCIWndSM(hwnd, MCIWNDM_SETINACTIVETIMER, inactive, 0);\r\nend;\r\n\r\nprocedure MCIWndSetTimers(hwnd: HWND; active, inactive: UINT);\r\nbegin\r\n MCIWndSM(hwnd, MCIWNDM_SETTIMERS, active, inactive);\r\nend;\r\n\r\nfunction MCIWndGetActiveTimer(hwnd: HWND): UINT;\r\nbegin\r\n Result := MCIWndSM(hwnd, MCIWNDM_GETACTIVETIMER, 0, 0);\r\nend;\r\n\r\nfunction MCIWndGetInactiveTimer(hwnd: HWND): UINT;\r\nbegin\r\n Result := MCIWndSM(hwnd, MCIWNDM_GETINACTIVETIMER, 0, 0);\r\nend;\r\n\r\nfunction MCIWndRealize(hwnd: HWND; fBkgnd: BOOL): DWORD;\r\nbegin\r\n Result := MCIWndSM(hwnd, MCIWNDM_REALIZE, WPARAM(fBkgnd), 0);\r\nend;\r\n\r\nfunction MCIWndSendString(hwnd: HWND; sz: LPCSTR): DWORD;\r\nbegin\r\n Result := MCIWndSM(hwnd, MCIWNDM_SENDSTRING, 0, LPARAM(sz));\r\nend;\r\n\r\nfunction MCIWndReturnString(hwnd: HWND; lp: LPSTR; len: UINT): DWORD;\r\nbegin\r\n Result := MCIWndSM(hwnd, MCIWNDM_RETURNSTRING, len, LPARAM(lp));\r\nend;\r\n\r\nfunction MCIWndGetError(hwnd: HWND; lp: LPSTR; len: UINT): DWORD;\r\nbegin\r\n Result := MCIWndSM(hwnd, MCIWNDM_GETERROR, len, LPARAM(lp));\r\nend;\r\n\r\nfunction MCIWndGetPalette(hwnd: HWND): HPALETTE;\r\nbegin\r\n Result := MCIWndSM(hwnd, MCIWNDM_GETPALETTE, 0, 0);\r\nend;\r\n\r\nfunction MCIWndSetPalette(hwnd: HWND; hpal: HPALETTE): DWORD;\r\nbegin\r\n Result := MCIWndSM(hwnd, MCIWNDM_SETPALETTE, hpal, 0);\r\nend;\r\n\r\nfunction MCIWndGetFileName(hwnd: HWND; lp: LPCSTR; len: UINT): DWORD;\r\nbegin\r\n Result := MCIWndSM(hwnd, MCIWNDM_GETFILENAME, len, LPARAM(lp));\r\nend;\r\n\r\nfunction MCIWndGetDevice(hwnd: HWND; lp: LPCSTR; len: UINT): DWORD;\r\nbegin\r\n Result := MCIWndSM(hwnd, MCIWNDM_GETDEVICE, len, LPARAM(lp));\r\nend;\r\n\r\nfunction MCIWndGetStyles(hwnd: HWND): UINT;\r\nbegin\r\n Result := MCIWndSM(hwnd, MCIWNDM_GETSTYLES, 0, 0);\r\nend;\r\n\r\nfunction MCIWndChangeStyles(hwnd: HWND; Mask: UINT; value: DWORD): DWORD;\r\nbegin\r\n Result := MCIWndSM(hwnd, MCIWNDM_CHANGESTYLES, Mask, value);\r\nend;\r\n\r\nfunction MCIWndOpenInterface(hwnd: HWND; pUnk: PUNKNOWN): DWORD;\r\nbegin\r\n Result := MCIWndSM(hwnd, MCIWNDM_OPENINTERFACE, 0, LPARAM(pUnk));\r\nend;\r\n\r\nfunction MCIWndSetOwner(hwnd: HWND; hwndP: HWND): DWORD;\r\nbegin\r\n Result := MCIWndSM(hwnd, MCIWNDM_SETOWNER, hwndP, 0);\r\nend;\r\n\r\n{== AVICAP - Window class for AVI capture ====================================}\r\n\r\nfunction AVICapSM(hwnd: HWND; m: UINT; w: WPARAM; l: LPARAM): DWORD;\r\nbegin\r\n if IsWindow(hwnd) then\r\n Result := SendMessage(hwnd,m,w,l)\r\n else\r\n Result := 0;\r\nend;\r\n\r\n{-- Message crackers for above -----------------------------------------------}\r\n\r\nfunction capSetCallbackOnError(hwnd: HWND; fpProc: TCAPERRORCALLBACK): BOOL;\r\nbegin\r\n Result := AVICapSM(hwnd, WM_CAP_SET_CALLBACK_ERROR, 0, LPARAM(@fpProc)) <> 0;\r\nend;\r\n\r\nfunction capSetCallbackOnStatus(hwnd: HWND; fpProc: TCAPSTATUSCALLBACK): BOOL;\r\nbegin\r\n Result := AVICapSM(hwnd, WM_CAP_SET_CALLBACK_STATUS, 0, LPARAM(@fpProc)) <> 0;\r\nend;\r\n\r\nfunction capSetCallbackOnYield(hwnd: HWND; fpProc: TCAPYIELDCALLBACK): BOOL;\r\nbegin\r\n Result := AVICapSM(hwnd, WM_CAP_SET_CALLBACK_YIELD, 0, LPARAM(@fpProc)) <> 0;\r\nend;\r\n\r\nfunction capSetCallbackOnFrame(hwnd: HWND; fpProc: TCAPVIDEOCALLBACK): BOOL;\r\nbegin\r\n Result := AVICapSM(hwnd, WM_CAP_SET_CALLBACK_FRAME, 0, LPARAM(@fpProc)) <> 0;\r\nend;\r\n\r\nfunction capSetCallbackOnVideoStream(hwnd: HWND; fpProc: TCAPVIDEOCALLBACK): BOOL;\r\nbegin\r\n Result := AVICapSM(hwnd, WM_CAP_SET_CALLBACK_VIDEOSTREAM, 0, LPARAM(@fpProc)) <> 0;\r\nend;\r\n\r\nfunction capSetCallbackOnWaveStream(hwnd: HWND; fpProc: TCAPWAVECALLBACK): BOOL;\r\nbegin\r\n Result := AVICapSM(hwnd, WM_CAP_SET_CALLBACK_WAVESTREAM, 0, LPARAM(@fpProc)) <> 0;\r\nend;\r\n\r\nfunction capSetCallbackOnCapControl(hwnd: HWND; fpProc: TCAPCONTROLCALLBACK): BOOL;\r\nbegin\r\n Result := AVICapSM(hwnd, WM_CAP_SET_CALLBACK_CAPCONTROL, 0, LPARAM(@fpProc)) <> 0;\r\nend;\r\n\r\nfunction capSetUserData(hwnd: HWND; lUser: DWORD): BOOL;\r\nbegin\r\n Result := AVICapSM(hwnd, WM_CAP_SET_USER_DATA, 0, lUser) <> 0;\r\nend;\r\n\r\nfunction capGetUserData(hwnd: HWND): DWORD;\r\nbegin\r\n Result := AVICapSM(hwnd, WM_CAP_GET_USER_DATA, 0, 0);\r\nend;\r\n\r\nfunction capDriverConnect(hwnd: HWND; i: INT): BOOL;\r\nbegin\r\n Result := AVICapSM(hwnd, WM_CAP_DRIVER_CONNECT, i, 0) <> 0;\r\nend;\r\n\r\nfunction capDriverDisconnect(hwnd: HWND): BOOL;\r\nbegin\r\n Result := AVICapSM(hwnd, WM_CAP_DRIVER_DISCONNECT, 0, 0) <> 0;\r\nend;\r\n\r\nfunction capDriverGetName(hwnd: HWND; szName: LPTSTR; wSize: WORD): BOOL;\r\nbegin\r\n Result := AVICapSM(hwnd, WM_CAP_DRIVER_GET_NAME, wSize, LPARAM(szName)) <> 0;\r\nend;\r\n\r\nfunction capDriverGetVersion(hwnd: HWND; szVer: LPTSTR; wSize: WORD): BOOL;\r\nbegin\r\n Result := AVICapSM(hwnd, WM_CAP_DRIVER_GET_VERSION, wSize, LPARAM(szVer)) <> 0;\r\nend;\r\n\r\nfunction capDriverGetCaps(hwnd: HWND; s: PCAPDRIVERCAPS; wSize: WORD): BOOL;\r\nbegin\r\n Result := AVICapSM(hwnd, WM_CAP_DRIVER_GET_CAPS, wSize, LPARAM(s)) <> 0;\r\nend;\r\n\r\nfunction capFileSetCaptureFile(hwnd: HWND; szName: LPTSTR): BOOL;\r\nbegin\r\n Result := AVICapSM(hwnd, WM_CAP_FILE_SET_CAPTURE_FILE, 0, LPARAM(szName)) <> 0;\r\nend;\r\n\r\nfunction capFileGetCaptureFile(hwnd: HWND; szName: LPTSTR; wSize: WORD): BOOL;\r\nbegin\r\n Result := AVICapSM(hwnd, WM_CAP_FILE_GET_CAPTURE_FILE, wSize, LPARAM(szName)) <> 0;\r\nend;\r\n\r\nfunction capFileAlloc(hwnd: HWND; dwSize: DWORD): BOOL;\r\nbegin\r\n Result := AVICapSM(hwnd, WM_CAP_FILE_ALLOCATE, 0, dwSize) <> 0;\r\nend;\r\n\r\nfunction capFileSaveAs(hwnd: HWND; szName: LPCTSTR): BOOL;\r\nbegin\r\n Result := AVICapSM(hwnd, WM_CAP_FILE_SAVEAS, 0, LPARAM(szName)) <> 0;\r\nend;\r\n\r\nfunction capFileSetInfoChunk(hwnd: HWND; lpInfoChunk: PCAPINFOCHUNK): BOOL;\r\nbegin\r\n Result := AVICapSM(hwnd, WM_CAP_FILE_SET_INFOCHUNK, 0, LPARAM(lpInfoChunk)) <> 0;\r\nend;\r\n\r\nfunction capFileSaveDIB(hwnd: HWND; szName: LPCTSTR): BOOL;\r\nbegin\r\n Result := AVICapSM(hwnd, WM_CAP_FILE_SAVEDIB, 0, LPARAM(szName)) <> 0;\r\nend;\r\n\r\nfunction capEditCopy(hwnd: HWND): BOOL;\r\nbegin\r\n Result := AVICapSM(hwnd, WM_CAP_EDIT_COPY, 0, 0) <> 0;\r\nend;\r\n\r\nfunction capSetAudioFormat(hwnd: HWND; s: PWAVEFORMATEX; wSize: WORD): BOOL;\r\nbegin\r\n Result := AVICapSM(hwnd, WM_CAP_SET_AUDIOFORMAT, wSize, LPARAM(s)) <> 0;\r\nend;\r\n\r\nfunction capGetAudioFormat(hwnd: HWND; s: PWAVEFORMATEX; wSize: WORD): DWORD;\r\nbegin\r\n Result := AVICapSM(hwnd, WM_CAP_GET_AUDIOFORMAT, wSize, LPARAM(s));\r\nend;\r\n\r\nfunction capGetAudioFormatSize(hwnd: HWND): DWORD;\r\nbegin\r\n Result := AVICapSM(hwnd, WM_CAP_GET_AUDIOFORMAT, 0, 0);\r\nend;\r\n\r\nfunction capDlgVideoFormat(hwnd: HWND): BOOL;\r\nbegin\r\n Result := AVICapSM(hwnd, WM_CAP_DLG_VIDEOFORMAT, 0, 0) <> 0;\r\nend;\r\n\r\nfunction capDlgVideoSource(hwnd: HWND): BOOL;\r\nbegin\r\n Result := AVICapSM(hwnd, WM_CAP_DLG_VIDEOSOURCE, 0, 0) <> 0;\r\nend;\r\n\r\nfunction capDlgVideoDisplay(hwnd: HWND): BOOL;\r\nbegin\r\n Result := AVICapSM(hwnd, WM_CAP_DLG_VIDEODISPLAY, 0, 0) <> 0;\r\nend;\r\n\r\nfunction capDlgVideoCompression(hwnd: HWND): BOOL;\r\nbegin\r\n Result := AVICapSM(hwnd, WM_CAP_DLG_VIDEOCOMPRESSION, 0, 0) <> 0;\r\nend;\r\n\r\nfunction capGetVideoFormat(hwnd: HWND; s: PVOID; wSize: WORD): DWORD;\r\nbegin\r\n Result := AVICapSM(hwnd, WM_CAP_GET_VIDEOFORMAT, wSize, LPARAM(s));\r\nend;\r\n\r\nfunction capGetVideoFormatSize(hwnd: HWND): DWORD;\r\nbegin\r\n Result := AVICapSM(hwnd, WM_CAP_GET_VIDEOFORMAT, 0, 0);\r\nend;\r\n\r\nfunction capSetVideoFormat(hwnd: HWND; s: PVOID; wSize: WORD): BOOL;\r\nbegin\r\n Result := AVICapSM(hwnd, WM_CAP_SET_VIDEOFORMAT, wSize, LPARAM(s)) <> 0;\r\nend;\r\n\r\nfunction capPreview(hwnd: HWND; f: BOOL): BOOL;\r\nbegin\r\n Result := AVICapSM(hwnd, WM_CAP_SET_PREVIEW, WPARAM(f), 0) <> 0;\r\nend;\r\n\r\nfunction capPreviewRate(hwnd: HWND; wMS: WORD): BOOL;\r\nbegin\r\n Result := AVICapSM(hwnd, WM_CAP_SET_PREVIEWRATE, wMS, 0) <> 0;\r\nend;\r\n\r\nfunction capOverlay(hwnd: HWND; f: BOOL): BOOL;\r\nbegin\r\n Result := AVICapSM(hwnd, WM_CAP_SET_OVERLAY, WPARAM(f), 0) <> 0;\r\nend;\r\n\r\nfunction capPreviewScale(hwnd: HWND; f: BOOL): BOOL;\r\nbegin\r\n Result := AVICapSM(hwnd, WM_CAP_SET_SCALE, WPARAM(f), 0) <> 0;\r\nend;\r\n\r\nfunction capGetStatus(hwnd: HWND; s: PCAPSTATUS; wSize: WORD): BOOL;\r\nbegin\r\n Result := AVICapSM(hwnd, WM_CAP_GET_STATUS, wSize, LPARAM(s)) <> 0;\r\nend;\r\n\r\nfunction capSetScrollPos(hwnd: HWND; lpP: PPOINT): BOOL;\r\nbegin\r\n Result := AVICapSM(hwnd, WM_CAP_SET_SCROLL, 0, LPARAM(lpP)) <> 0;\r\nend;\r\n\r\nfunction capGrabFrame(hwnd: HWND): BOOL;\r\nbegin\r\n Result := AVICapSM(hwnd, WM_CAP_GRAB_FRAME, 0, 0) <> 0;\r\nend;\r\n\r\nfunction capGrabFrameNoStop(hwnd: HWND): BOOL;\r\nbegin\r\n Result := AVICapSM(hwnd, WM_CAP_GRAB_FRAME_NOSTOP, 0, 0) <> 0;\r\nend;\r\n\r\nfunction capCaptureSequence(hwnd: HWND): BOOL;\r\nbegin\r\n Result := AVICapSM(hwnd, WM_CAP_SEQUENCE, 0, 0) <> 0;\r\nend;\r\n\r\nfunction capCaptureSequenceNoFile(hwnd: HWND): BOOL;\r\nbegin\r\n Result := AVICapSM(hwnd, WM_CAP_SEQUENCE_NOFILE, 0, 0) <> 0;\r\nend;\r\n\r\nfunction capCaptureStop(hwnd: HWND): BOOL;\r\nbegin\r\n Result := AVICapSM(hwnd, WM_CAP_STOP, 0, 0) <> 0;\r\nend;\r\n\r\nfunction capCaptureAbort(hwnd: HWND): BOOL;\r\nbegin\r\n Result := AVICapSM(hwnd, WM_CAP_ABORT, 0, 0) <> 0;\r\nend;\r\n\r\nfunction capCaptureSingleFrameOpen(hwnd: HWND): BOOL;\r\nbegin\r\n Result := AVICapSM(hwnd, WM_CAP_SINGLE_FRAME_OPEN, 0, 0) <> 0;\r\nend;\r\n\r\nfunction capCaptureSingleFrameClose(hwnd: HWND): BOOL;\r\nbegin\r\n Result := AVICapSM(hwnd, WM_CAP_SINGLE_FRAME_CLOSE, 0, 0) <> 0;\r\nend;\r\n\r\nfunction capCaptureSingleFrame(hwnd: HWND): BOOL;\r\nbegin\r\n Result := AVICapSM(hwnd, WM_CAP_SINGLE_FRAME, 0, 0) <> 0;\r\nend;\r\n\r\nfunction capCaptureGetSetup(hwnd: HWND; s: PCAPTUREPARMS; wSize: WORD): BOOL;\r\nbegin\r\n Result := AVICapSM(hwnd, WM_CAP_GET_SEQUENCE_SETUP, wSize, LPARAM(s)) <> 0;\r\nend;\r\n\r\nfunction capCaptureSetSetup(hwnd: HWND; s: PCAPTUREPARMS; wSize: WORD): BOOL;\r\nbegin\r\n Result := AVICapSM(hwnd, WM_CAP_SET_SEQUENCE_SETUP, wSize, LPARAM(s)) <> 0;\r\nend;\r\n\r\nfunction capSetMCIDeviceName(hwnd: HWND; szName: LPCTSTR): BOOL;\r\nbegin\r\n Result := AVICapSM(hwnd, WM_CAP_SET_MCI_DEVICE, 0, LPARAM(szName)) <> 0;\r\nend;\r\n\r\nfunction capGetMCIDeviceName(hwnd: HWND; szName: LPTSTR; wSize: WORD): BOOL;\r\nbegin\r\n Result := AVICapSM(hwnd, WM_CAP_GET_MCI_DEVICE, wSize, LPARAM(szName)) <> 0;\r\nend;\r\n\r\nfunction capPaletteOpen(hwnd: HWND; szName: LPCTSTR): BOOL;\r\nbegin\r\n Result := AVICapSM(hwnd, WM_CAP_PAL_OPEN, 0, LPARAM(szName)) <> 0;\r\nend;\r\n\r\nfunction capPaletteSave(hwnd: HWND; szName: LPCTSTR): BOOL;\r\nbegin\r\n Result := AVICapSM(hwnd, WM_CAP_PAL_SAVE, 0, LPARAM(szName)) <> 0;\r\nend;\r\n\r\nfunction capPalettePaste(hwnd: HWND): BOOL;\r\nbegin\r\n Result := AVICapSM(hwnd, WM_CAP_PAL_PASTE, 0, 0) <> 0;\r\nend;\r\n\r\nfunction capPaletteAuto(hwnd: HWND; iFrames, iColors: INT): BOOL;\r\nbegin\r\n Result := AVICapSM(hwnd, WM_CAP_PAL_AUTOCREATE, iFrames, iColors) <> 0;\r\nend;\r\n\r\nfunction capPaletteManual(hwnd: HWND; fGrab: BOOL; iColors: INT): BOOL;\r\nbegin\r\n Result := AVICapSM(hwnd, WM_CAP_PAL_MANUALCREATE, WPARAM(fGrab), iColors) <> 0;\r\nend;\r\n\r\n{== Externals ================================================================}\r\n\r\nconst\r\n VFWDLL = 'MSVFW32.DLL';\r\n AVIFILDLL = 'AVIFIL32.DLL';\r\n AVICAPDLL = 'AVICAP32.DLL';\r\n\r\n{-- Returns version of VFW ---------------------------------------------------}\r\n\r\nfunction VideoForWindowsVersion: DWord; pascal; external VFWDLL;\r\n\r\n{-- Call these to start stop using VfW from your app -------------------------}\r\n\r\n{ TODO: Where are these functions? }\r\n {\r\n function InitVFW: LONG; stdcall;\r\n function TermVFW: LONG; stdcall; }\r\n\r\n{-- ICM function declarations ------------------------------------------------}\r\n\r\nfunction ICInfo(fccType, fccHandler: DWORD; lpicinfo: PICINFO) : BOOL ; stdcall ; external VFWDLL;\r\nfunction ICInstall(fccType, fccHandler: DWORD; lParam: LPARAM; szDesc: LPSTR; wFlags: UINT) : BOOL ; stdcall ; external VFWDLL;\r\nfunction ICRemove(fccType, fccHandler: DWORD; wFlags: UINT) : BOOL ; stdcall ; external VFWDLL;\r\nfunction ICGetInfo(hic: HIC; picinfo: PICINFO; cb: DWORD) : DWORD ; stdcall ; external VFWDLL;\r\n\r\nfunction ICOpen(fccType, fccHandler: DWORD; wMode: UINT) : HIC ; stdcall ; external VFWDLL;\r\nfunction ICOpenFunction(fccType, fccHandler: DWORD; wMode: UINT; lpfnHandler: TFarProc) : HIC ; stdcall ; external VFWDLL;\r\nfunction ICClose(hic: HIC) : DWORD ; stdcall ; external VFWDLL;\r\n\r\nfunction ICSendMessage(hic: HIC; msg: UINT; dw1, dw2: DWORD) : DWORD ; stdcall ; external VFWDLL;\r\n\r\n{== Compression functions ====================================================}\r\n\r\n{-- ICCompress() - compress a single frame -----------------------------------}\r\n\r\nfunction ICCompress(\r\n hic : HIC;\r\n dwFlags : DWORD; // flags\r\n lpbiOutput : PBITMAPINFOHEADER; // output format\r\n lpData : PVOID; // output data\r\n lpbiInput : PBITMAPINFOHEADER; // format of frame to compress\r\n lpBits : PVOID; // frame data to compress\r\n lpckid : PDWORD; // ckid for data in AVI file\r\n lpdwFlags : PDWORD; // flags in the AVI index.\r\n lFrameNum : DWORD; // frame number of seq.\r\n dwFrameSize : DWORD; // reqested size in bytes. (if non zero)\r\n dwQuality : DWORD; // quality within one frame\r\n lpbiPrev : PBITMAPINFOHEADER; // format of previous frame\r\n lpPrev : PVOID // previous frame\r\n ) : DWORD; cdecl; external VFWDLL;\r\n\r\n{== Decompression functions ==================================================}\r\n\r\n{-- ICDecompress() - decompress a single frame -------------------------------}\r\n\r\nfunction ICDecompress(\r\n hic : HIC;\r\n dwFlags : DWORD; // flags (from AVI index...)\r\n lpbiFormat : PBITMAPINFOHEADER; // BITMAPINFO of compressed data\r\n // biSizeImage has the chunk size\r\n lpData : PVOID; // data\r\n lpbi : PBITMAPINFOHEADER; // DIB to decompress to\r\n lpBits : PVOID\r\n ): DWORD; cdecl; external VFWDLL;\r\n\r\n{== Drawing functions ========================================================}\r\n\r\n{-- ICDrawBegin() - start decompressing data with fmt directly to screen -----}\r\n\r\n// return zero if the decompressor supports drawing.\r\n\r\nfunction ICDrawBegin(\r\n hic : HIC;\r\n dwFlags : DWORD; // flags\r\n hpal : HPALETTE; // palette to draw with\r\n hwnd : HWND; // window to draw to\r\n hdc : HDC; // HDC to draw to\r\n xDst : int; // destination rectangle\r\n yDst : int;\r\n dxDst : int;\r\n dyDst : int;\r\n lpbi : PBITMAPINFOHEADER; // format of frame to draw\r\n xSrc : int; // source rectangle\r\n ySrc : int;\r\n dxSrc : int;\r\n dySrc : int;\r\n dwRate : DWORD; // frames/second = (dwRate/dwScale)\r\n dwScale : DWORD\r\n ): DWORD; cdecl; external VFWDLL;\r\n\r\n{-- ICDraw() - decompress data directly to the screen ------------------------}\r\n\r\nfunction ICDraw(\r\n hic : HIC;\r\n dwFlags : DWORD; // flags\r\n lpFormat : PVOID; // format of frame to decompress\r\n lpData : PVOID; // frame data to decompress\r\n cbData : DWORD; // size of data\r\n lTime : DWORD // time to draw this frame\r\n ): DWORD; cdecl; external VFWDLL;\r\n\r\n{== Helper routines for DrawDib and MCIAVI... ================================}\r\n\r\nfunction ICLocate(fccType, fccHandler: DWORD; lpbiIn, lpbiOut: PBITMAPINFOHEADER; wFlags: WORD): HIC; stdcall; external VFWDLL;\r\nfunction ICGetDisplayFormat(hic: HIC; lpbiIn, lpbiOut: PBITMAPINFOHEADER; BitDepth: int; dx, dy: int): HIC; stdcall; external VFWDLL;\r\n\r\n{== Higher level functions ===================================================}\r\n\r\nfunction ICImageCompress(\r\n hic : HIC; // compressor to use\r\n uiFlags : UINT; // flags (none yet)\r\n lpbiIn : PBITMAPINFO; // format to compress from\r\n lpBits : PVOID; // data to compress\r\n lpbiOut : PBITMAPINFO; // compress to this (NULL ==> default)\r\n lQuality : LONG; // quality to use\r\n plSize : PDWORD // compress to this size (0=whatever)\r\n ): THANDLE; stdcall; external VFWDLL;\r\n\r\nfunction ICImageDecompress(\r\n hic : HIC; // compressor to use\r\n uiFlags : UINT; // flags (none yet)\r\n lpbiIn : PBITMAPINFO; // format to decompress from\r\n lpBits : PVOID; // data to decompress\r\n lpbiOut : PBITMAPINFO // decompress to this (NULL ==> default)\r\n ): THANDLE; stdcall; external VFWDLL;\r\n\r\n{-- ICCompressorChoose() - allows user to choose compressor, quality etc... --}\r\n\r\nfunction ICCompressorChoose(\r\n hwnd : HWND; // parent window for dialog\r\n uiFlags : UINT; // flags\r\n pvIn : PVOID; // input format (optional)\r\n lpData : PVOID; // input data (optional)\r\n pc : PCOMPVARS; // data about the compressor/dlg\r\n lpszTitle : LPSTR // dialog title (optional)\r\n ): BOOL; stdcall; external VFWDLL;\r\n\r\nfunction ICSeqCompressFrameStart(pc: PCOMPVARS; lpbiIn: PBITMAPINFO): BOOL; stdcall; external VFWDLL;\r\nprocedure ICSeqCompressFrameEnd(pc: PCOMPVARS); stdcall; external VFWDLL;\r\n\r\nfunction ICSeqCompressFrame(\r\n pc : PCOMPVARS; // set by ICCompressorChoose\r\n uiFlags : UINT; // flags\r\n lpBits : PVOID; // input DIB bits\r\n pfKey : PBOOL; // did it end up being a key frame?\r\n plSize : PDWORD // size to compress to/of returned image\r\n ): PVOID; stdcall; external VFWDLL;\r\n\r\nprocedure ICCompressorFree(pc: PCOMPVARS); stdcall; external VFWDLL;\r\n\r\n{== DrawDib functions ========================================================}\r\n\r\n{-- DrawDibOpen() ------------------------------------------------------------}\r\n\r\nfunction DrawDibOpen: HDRAWDIB; stdcall; external VFWDLL;\r\n\r\n{-- DrawDibClose() -----------------------------------------------------------}\r\n\r\nfunction DrawDibClose(hdd: HDRAWDIB): BOOL; stdcall; external VFWDLL;\r\n\r\n{-- DrawDibGetBuffer() -------------------------------------------------------}\r\n\r\nfunction DrawDibGetBuffer(hdd: HDRAWDIB; lpbi: PBITMAPINFOHEADER; dwSize: DWORD; dwFlags: DWORD): PVOID; stdcall; external VFWDLL;\r\n\r\n{-- DrawDibGetPalette() - get the palette used for drawing DIBs --------------}\r\n\r\nfunction DrawDibGetPalette(hdd: HDRAWDIB): HPALETTE; stdcall; external VFWDLL;\r\n\r\n{-- DrawDibSetPalette() - set the palette used for drawing DIBs --------------}\r\n\r\nfunction DrawDibSetPalette(hdd: HDRAWDIB; hpal: HPALETTE): BOOL; stdcall; external VFWDLL;\r\n\r\n{-- DrawDibChangePalette() ---------------------------------------------------}\r\n\r\nfunction DrawDibChangePalette(hdd: HDRAWDIB; iStart, iLen: int; lppe: PPALETTEENTRY): BOOL; stdcall; external VFWDLL;\r\n\r\n{-- DrawDibRealize() - realize the palette in a HDD --------------------------}\r\n\r\nfunction DrawDibRealize(hdd: HDRAWDIB; hdc: HDC; fBackground: BOOL): UINT; stdcall; external VFWDLL;\r\n\r\n{-- DrawDibStart() - start of streaming playback -----------------------------}\r\n\r\nfunction DrawDibStart(hdd: HDRAWDIB; rate: DWORD): BOOL; stdcall; external VFWDLL;\r\n\r\n{-- DrawDibStop() - start of streaming playback ------------------------------}\r\n\r\nfunction DrawDibStop(hdd: HDRAWDIB): BOOL; stdcall; external VFWDLL;\r\n\r\n{-- DrawDibBegin() - prepare to draw -----------------------------------------}\r\n\r\nfunction DrawDibBegin(\r\n hdd : HDRAWDIB;\r\n hdc : HDC;\r\n dxDst : int;\r\n dyDst : int;\r\n lpbi : PBITMAPINFOHEADER;\r\n dxSrc : int;\r\n dySrc : int;\r\n wFlags : UINT\r\n ): BOOL; stdcall; external VFWDLL;\r\n\r\n{-- DrawDibDraw() - actually draw a DIB to the screen ------------------------}\r\n\r\nfunction DrawDibDraw(\r\n hdd : HDRAWDIB;\r\n hdc : HDC;\r\n xDst : int;\r\n yDst : int;\r\n dxDst : int;\r\n dyDst : int;\r\n lpbi : PBITMAPINFOHEADER;\r\n lpBits : PVOID;\r\n xSrc : int;\r\n ySrc : int;\r\n dxSrc : int;\r\n dySrc : int;\r\n wFlags : UINT\r\n ): BOOL; stdcall; external VFWDLL;\r\n\r\n{-- DrawDibEnd() -------------------------------------------------------------}\r\n\r\nfunction DrawDibEnd(hdd: HDRAWDIB): BOOL; stdcall; external VFWDLL;\r\n\r\n{-- DrawDibTime() - for debugging purposes only ------------------------------}\r\n\r\nfunction DrawDibTime(hdd: HDRAWDIB; lpddtime: PDRAWDIBTIME): BOOL; stdcall; external VFWDLL;\r\n\r\n{-- Display profiling --------------------------------------------------------}\r\n\r\nfunction DrawDibProfileDisplay(lpbi: PBITMAPINFOHEADER): DWORD; stdcall; external VFWDLL;\r\n\r\n{-- Functions ----------------------------------------------------------------}\r\n\r\nprocedure AVIFileInit; stdcall; external AVIFILDLL; // Call this first!\r\nprocedure AVIFileExit; stdcall; external AVIFILDLL;\r\n\r\nfunction AVIFileAddRef(pfile: IAVIFILE): ULONG; stdcall; external AVIFILDLL;\r\nfunction AVIFileRelease(pfile: IAVIFILE): ULONG; stdcall; external AVIFILDLL;\r\n\r\nfunction AVIFileOpenA(var ppfile: IAVIFILE; szFile: LPCSTR; uMode: UINT; lpHandler: PCLSID): HResult; stdcall; external AVIFILDLL;\r\nfunction AVIFileOpenW(var ppfile: IAVIFILE; szFile: LPCWSTR; uMode: UINT; lpHandler: PCLSID): HResult; stdcall; external AVIFILDLL;\r\n\r\n{$IFDEF UNICODE}\r\nfunction AVIFileOpen(var ppfile: IAVIFILE; szFile: LPCWSTR; uMode: UINT; lpHandler: PCLSID): HResult; stdcall; external AVIFILDLL name 'AVIFileOpenW';\r\n{$ELSE}\r\nfunction AVIFileOpen(var ppfile: IAVIFILE; szFile: LPCSTR; uMode: UINT; lpHandler: PCLSID): HResult; stdcall; external AVIFILDLL name 'AVIFileOpenA';\r\n{$ENDIF UNICODE}\r\n\r\nfunction AVIFileInfoW(pfile: IAVIFILE; var pfi: TAVIFILEINFOW; lSize: LONG): HResult; stdcall; external AVIFILDLL;\r\nfunction AVIFileInfoA(pfile: IAVIFILE; var pfi: TAVIFILEINFOA; lSize: LONG): HResult; stdcall; external AVIFILDLL;\r\n\r\n{$IFDEF UNICODE}\r\nfunction AVIFileInfo(pfile: IAVIFILE; var pfi: TAVIFILEINFO; lSize: LONG): HResult; stdcall; external AVIFILDLL name 'AVIFileInfoW';\r\n{$ELSE}\r\nfunction AVIFileInfo(pfile: IAVIFILE; var pfi: TAVIFILEINFO; lSize: LONG): HResult; stdcall; external AVIFILDLL name 'AVIFileInfoA';\r\n{$ENDIF UNICODE}\r\n\r\nfunction AVIFileGetStream(pfile: IAVIFILE; var ppavi: IAVISTREAM; fccType: DWORD; lParam: LONG): HResult; stdcall; external AVIFILDLL;\r\n\r\nfunction AVIFileCreateStreamW(pfile: IAVIFILE; var ppavi: IAVISTREAM; var psi: TAVISTREAMINFOW): HResult; stdcall; external AVIFILDLL;\r\nfunction AVIFileCreateStreamA(pfile: IAVIFILE; var ppavi: IAVISTREAM; var psi: TAVISTREAMINFOA): HResult; stdcall; external AVIFILDLL;\r\n\r\n{$IFDEF UNICODE}\r\nfunction AVIFileCreateStream(pfile: IAVIFILE; var ppavi: IAVISTREAM; var psi: TAVISTREAMINFO): HResult; stdcall; external AVIFILDLL name 'AVIFileCreateStreamW';\r\n{$ELSE}\r\nfunction AVIFileCreateStream(pfile: IAVIFILE; var ppavi: IAVISTREAM; var psi: TAVISTREAMINFO): HResult; stdcall; external AVIFILDLL name 'AVIFileCreateStreamA';\r\n{$ENDIF UNICODE}\r\n\r\nfunction AVIFileWriteData(pfile: IAVIFILE; ckid: DWORD; lpData: PVOID; cbData: LONG): HResult; stdcall; external AVIFILDLL;\r\nfunction AVIFileReadData(pfile: IAVIFILE; ckid: DWORD; lpData: PVOID; var lpcbData: LONG): HResult; stdcall; external AVIFILDLL;\r\nfunction AVIFileEndRecord(pfile: IAVIFILE): HResult; stdcall; external AVIFILDLL;\r\n\r\nfunction AVIStreamAddRef(pavi: IAVISTREAM): ULONG; stdcall; external AVIFILDLL;\r\nfunction AVIStreamRelease(pavi: IAVISTREAM): ULONG; stdcall; external AVIFILDLL;\r\n\r\nfunction AVIStreamInfoW (pavi: IAVISTREAM; var psi: TAVISTREAMINFOW; lSize: LONG): HResult; stdcall; external AVIFILDLL;\r\nfunction AVIStreamInfoA (pavi: IAVISTREAM; var psi: TAVISTREAMINFOA; lSize: LONG): HResult; stdcall; external AVIFILDLL;\r\n\r\n{$IFDEF UNICODE}\r\nfunction AVIStreamInfo(pavi: IAVISTREAM; var psi: TAVISTREAMINFO; lSize: LONG): HResult; stdcall; external AVIFILDLL name 'AVIStreamInfoW';\r\n{$ELSE}\r\nfunction AVIStreamInfo(pavi: IAVISTREAM; var psi: TAVISTREAMINFO; lSize: LONG): HResult; stdcall; external AVIFILDLL name 'AVIStreamInfoA';\r\n{$ENDIF UNICODE}\r\n\r\nfunction AVIStreamFindSample(pavi: IAVISTREAM; lPos: LONG; lFlags: LONG): LONG; stdcall; external AVIFILDLL;\r\nfunction AVIStreamReadFormat(pavi: IAVISTREAM; lPos: LONG; lpFormat: PVOID; lpcbFormat: PLONG): HResult; stdcall; external AVIFILDLL;\r\nfunction AVIStreamSetFormat(pavi: IAVISTREAM; lPos: LONG; lpFormat: PVOID; cbFormat: LONG): HResult; stdcall; external AVIFILDLL;\r\nfunction AVIStreamReadData(pavi: IAVISTREAM; fcc: DWORD; lp: PVOID; lpcb: PLONG): HResult; stdcall; external AVIFILDLL;\r\nfunction AVIStreamWriteData(pavi: IAVISTREAM; fcc: DWORD; lp: PVOID; cb: LONG): HResult; stdcall; external AVIFILDLL;\r\n\r\nfunction AVIStreamRead(\r\n pavi : IAVISTREAM;\r\n lStart : LONG;\r\n lSamples : LONG;\r\n lpBuffer : PVOID;\r\n cbBuffer : LONG;\r\n plBytes : PLONG;\r\n plSamples : PLONG\r\n ): HResult; stdcall; external AVIFILDLL;\r\n\r\nfunction AVIStreamWrite(\r\n pavi : IAVISTREAM;\r\n lStart : LONG;\r\n lSamples : LONG;\r\n lpBuffer : PVOID;\r\n cbBuffer : LONG;\r\n dwFlags : DWORD;\r\n plSampWritten : PLONG;\r\n plBytesWritten : PLONG\r\n ): HResult; stdcall; external AVIFILDLL;\r\n\r\n// Right now, these just use AVIStreamInfo() to get information, then\r\n// return some of it. Can they be more efficient?\r\n\r\nfunction AVIStreamStart(pavi: IAVISTREAM): LONG; stdcall; external AVIFILDLL;\r\nfunction AVIStreamLength(pavi: IAVISTREAM): LONG; stdcall; external AVIFILDLL;\r\nfunction AVIStreamTimeToSample(pavi: IAVISTREAM; lTime: LONG): LONG; stdcall; external AVIFILDLL;\r\nfunction AVIStreamSampleToTime(pavi: IAVISTREAM; lSample: LONG): LONG; stdcall; external AVIFILDLL;\r\n\r\nfunction AVIStreamBeginStreaming(pavi: IAVISTREAM; lStart, lEnd: LONG; lRate: LONG): HResult; stdcall; external AVIFILDLL;\r\nfunction AVIStreamEndStreaming(pavi: IAVISTREAM): HResult; stdcall; external AVIFILDLL;\r\n\r\n{-- Helper functions for using IGetFrame -------------------------------------}\r\n\r\nfunction AVIStreamGetFrameOpen_(pavi: IAVISTREAM; lpbiWanted: PBitmapInfoHeader): pointer; stdcall; external AVIFILDLL name 'AVIStreamGetFrameOpen';\r\nfunction AVIStreamGetFrame(pg: IGETFRAME; lPos: LONG): PBitmapInfoHeader; stdcall; external AVIFILDLL;\r\nfunction AVIStreamGetFrameClose(pg: IGETFRAME): HResult; stdcall; external AVIFILDLL;\r\n\r\nfunction AVIStreamGetFrameOpen(pavi: IAVIStream; lpbiWanted: PBitmapInfoHeader): IGetFrame; stdcall;\r\nbegin\r\n pointer(Result) := AVIStreamGetFrameOpen_(pavi, lpbiWanted);\r\nend;\r\n\r\n// !!! We need some way to place an advise on a stream....\r\n// STDAPI AVIStreamHasChanged (PAVISTREAM pavi);\r\n\r\n{-- Shortcut function --------------------------------------------------------}\r\n\r\nfunction AVIStreamOpenFromFileA(var ppavi: IAVISTREAM; szFile: LPCSTR; fccType: DWORD;\r\n lParam: LONG; mode: UINT; pclsidHandler: PCLSID): HResult; stdcall; external AVIFILDLL;\r\nfunction AVIStreamOpenFromFileW(var ppavi: IAVISTREAM; szFile: LPCWSTR; fccType: DWORD;\r\n lParam: LONG; mode: UINT; pclsidHandler: PCLSID): HResult; stdcall; external AVIFILDLL;\r\n\r\n{$IFDEF UNICODE}\r\nfunction AVIStreamOpenFromFile(var ppavi: IAVISTREAM; szFile: LPCWSTR; fccType: DWORD;\r\n lParam: LONG; mode: UINT; pclsidHandler: PCLSID): HResult; stdcall; external AVIFILDLL name 'AVIStreamOpenFromFileW';\r\n{$ELSE}\r\nfunction AVIStreamOpenFromFile(var ppavi: IAVISTREAM; szFile: LPCSTR; fccType: DWORD;\r\n lParam: LONG; mode: UINT; pclsidHandler: PCLSID): HResult; stdcall; external AVIFILDLL name 'AVIStreamOpenFromFileA';\r\n{$ENDIF UNICODE}\r\n\r\n{-- Use to create disembodied streams ----------------------------------------}\r\n\r\nfunction AVIStreamCreate(var ppavi: IAVISTREAM; lParam1, lParam2: LONG;\r\n pclsidHandler: PCLSID): HResult; stdcall; external AVIFILDLL;\r\n\r\n// PHANDLER AVIAPI AVIGetHandler (PAVISTREAM pavi, PAVISTREAMHANDLER psh);\r\n// PAVISTREAM AVIAPI AVIGetStream (PHANDLER p);\r\n\r\n{-- Stuff to support backward compat. ----------------------------------------}\r\n\r\nfunction AVIStreamFindKeyFrame(var pavi: IAVISTREAM; lPos: LONG; lFlags: LONG): DWORD; stdcall; external AVIFILDLL name 'AVIStreamFindSample';\r\n\r\n// Non-portable: this is alias for method name\r\n// FindKeyFrame FindSample\r\n\r\nfunction AVIStreamClose(pavi: IAVISTREAM): ULONG; stdcall; external AVIFILDLL name 'AVIStreamRelease';\r\nfunction AVIFileClose(pfile: IAVIFILE): ULONG; stdcall; external AVIFILDLL name 'AVIFileRelease';\r\nprocedure AVIStreamInit; stdcall; external AVIFILDLL name 'AVIFileInit';\r\nprocedure AVIStreamExit; stdcall; external AVIFILDLL name 'AVIFileExit';\r\n\r\n{== AVISave routines and structures ==========================================}\r\n\r\nfunction AVIMakeCompressedStream(\r\n var ppsCompressed : IAVISTREAM;\r\n ppsSource : IAVISTREAM;\r\n lpOptions : PAVICOMPRESSOPTIONS;\r\n pclsidHandler : PCLSID\r\n ): HResult; stdcall; external AVIFILDLL;\r\n\r\n// Non-portable: uses variable number of params\r\n// EXTERN_C HRESULT CDECL AVISaveA (LPCSTR szFile,\r\n// CLSID FAR *pclsidHandler,\r\n// AVISAVECALLBACK lpfnCallback,\r\n// int nStreams,\r\n// PAVISTREAM pfile,\r\n// LPAVICOMPRESSOPTIONS lpOptions,\r\n// ...);\r\n\r\nfunction AVISaveVA(\r\n szFile : LPCSTR;\r\n pclsidHandler : PCLSID;\r\n lpfnCallback : TAVISAVECALLBACK;\r\n nStreams : int;\r\n var ppavi : IAVISTREAM;\r\n var plpOptions : PAVICOMPRESSOPTIONS\r\n ): HResult; stdcall; external AVIFILDLL;\r\n\r\n// Non-portable: uses variable number of params\r\n// EXTERN_C HRESULT CDECL AVISaveW (LPCWSTR szFile,\r\n// CLSID FAR *pclsidHandler,\r\n// AVISAVECALLBACK lpfnCallback,\r\n// int nStreams,\r\n// PAVISTREAM pfile,\r\n// LPAVICOMPRESSOPTIONS lpOptions,\r\n// ...);\r\n\r\nfunction AVISaveVW(\r\n szFile : LPCWSTR;\r\n pclsidHandler : PCLSID;\r\n lpfnCallback : TAVISAVECALLBACK;\r\n nStreams : int;\r\n var ppavi : IAVISTREAM;\r\n var plpOptions : PAVICOMPRESSOPTIONS\r\n ): HResult; stdcall; external AVIFILDLL;\r\n\r\n// #define AVISave AVISaveA\r\n\r\nfunction AVISaveV(\r\n szFile : LPCSTR;\r\n pclsidHandler : PCLSID;\r\n lpfnCallback : TAVISAVECALLBACK;\r\n nStreams : int;\r\n var ppavi : IAVISTREAM;\r\n var plpOptions : PAVICOMPRESSOPTIONS\r\n ): HResult; stdcall; external AVIFILDLL name 'AVISaveVA';\r\n\r\nfunction AVISaveOptions(\r\n hwnd : HWND;\r\n uiFlags : UINT;\r\n nStreams : int;\r\n var ppavi : IAVISTREAM;\r\n var plpOptions : PAVICOMPRESSOPTIONS\r\n ): BOOL; stdcall; external AVIFILDLL;\r\n\r\nfunction AVISaveOptionsFree(nStreams: int; var plpOptions: PAVICOMPRESSOPTIONS): HResult; stdcall; external AVIFILDLL;\r\n\r\n{-----------------------------------------------------------------------------}\r\n\r\nfunction AVIBuildFilterW(lpszFilter: LPWSTR; cbFilter: LONG; fSaving: BOOL): HResult; stdcall; external AVIFILDLL;\r\nfunction AVIBuildFilterA(lpszFilter: LPSTR; cbFilter: LONG; fSaving: BOOL): HResult; stdcall; external AVIFILDLL;\r\n\r\nfunction AVIBuildFilter(lpszFilter: LPSTR; cbFilter: LONG; fSaving: BOOL): HResult; stdcall; external AVIFILDLL name 'AVIBuildFilterA';\r\n\r\nfunction AVIMakeFileFromStreams(var ppfile: IAVIFILE; nStreams: int; var papStreams: IAVISTREAM): HResult; stdcall; external AVIFILDLL;\r\n\r\nfunction AVIMakeStreamFromClipboard(cfFormat: UINT; hGlobal: THANDLE; var ppstream: IAVISTREAM): HResult; stdcall; external AVIFILDLL;\r\n\r\n{-- Clipboard routines -------------------------------------------------------}\r\n\r\nfunction AVIPutFileOnClipboard(pf: IAVIFILE): HResult; stdcall; external AVIFILDLL;\r\nfunction AVIGetFromClipboard(var lppf: IAVIFILE): HResult; stdcall; external AVIFILDLL;\r\nfunction AVIClearClipboard: HResult; stdcall; external AVIFILDLL;\r\n\r\n{-- Editing routines ---------------------------------------------------------}\r\n\r\nfunction CreateEditableStream(var ppsEditable: IAVISTREAM; psSource: IAVISTREAM): HResult; stdcall; external AVIFILDLL;\r\n\r\nfunction EditStreamCut(pavi: IAVISTREAM; var plStart, plLength: LONG; var ppResult: IAVISTREAM): HResult; stdcall; external AVIFILDLL;\r\nfunction EditStreamCopy(pavi: IAVISTREAM; var plStart, plLength: LONG; var ppResult: IAVISTREAM): HResult; stdcall; external AVIFILDLL;\r\nfunction EditStreamPaste(pavi: IAVISTREAM; var plPos, plLength: LONG; pstream: IAVISTREAM; lStart, lEnd: LONG): HResult; stdcall; external AVIFILDLL;\r\nfunction EditStreamClone(pavi: IAVISTREAM; var ppResult: IAVISTREAM): HResult; stdcall; external AVIFILDLL;\r\n\r\nfunction EditStreamSetNameA(pavi: IAVISTREAM; lpszName: LPCSTR): HResult; stdcall; external AVIFILDLL;\r\nfunction EditStreamSetNameW(pavi: IAVISTREAM; lpszName: LPCWSTR): HResult; stdcall; external AVIFILDLL;\r\nfunction EditStreamSetInfoW(pavi: IAVISTREAM; lpInfo: PAVISTREAMINFOW; cbInfo: LONG): HResult; stdcall; external AVIFILDLL;\r\nfunction EditStreamSetInfoA(pavi: IAVISTREAM; lpInfo: PAVISTREAMINFOA; cbInfo: LONG): HResult; stdcall; external AVIFILDLL;\r\n\r\nfunction EditStreamSetInfo(pavi: IAVISTREAM; lpInfo: PAVISTREAMINFOA; cbInfo: LONG): HResult; stdcall; external AVIFILDLL name 'EditStreamSetInfoA';\r\nfunction EditStreamSetName(pavi: IAVISTREAM; lpszName: LPCSTR): HResult; stdcall; external AVIFILDLL name 'EditStreamSetNameA';\r\n\r\n{-- MCIWnd -------------------------------------------------------------------}\r\n\r\nfunction MCIWndCreateA(hwndParent: HWND; hInstance: HINST; dwStyle: DWORd; szFile: LPCSTR): HWND; cdecl; external VFWDLL;\r\nfunction MCIWndCreateW(hwndParent: HWND; hInstance: HINST; dwStyle: DWORd; szFile: LPCWSTR): HWND; cdecl; external VFWDLL;\r\n\r\nfunction MCIWndCreate(hwndParent: HWND; hInstance: HINST; dwStyle: DWORd; szFile: LPCSTR): HWND; cdecl; external VFWDLL name 'MCIWndCreateA';\r\n\r\nfunction MCIWndRegisterClass: BOOL; cdecl; external VFWDLL;\r\n\r\n{== AVICAP - Window class for AVI capture ====================================}\r\n\r\n{-- The only exported functions from AVICAP.DLL ------------------------------}\r\n\r\nfunction capCreateCaptureWindowA(\r\n lpszWindowName : LPCSTR;\r\n dwStyle : DWORD;\r\n x, y : int;\r\n nWidth, nHeight : int;\r\n hwndParent : HWND;\r\n nID : int\r\n ): HWND; stdcall; external AVICAPDLL;\r\n\r\nfunction capGetDriverDescriptionA(\r\n wDriverIndex : UINT;\r\n lpszName : LPSTR;\r\n cbName : int;\r\n lpszVer : LPSTR;\r\n cbVer : int\r\n ): BOOL; stdcall; external AVICAPDLL;\r\n\r\nfunction capCreateCaptureWindowW(\r\n lpszWindowName : LPCWSTR;\r\n dwStyle : DWORD;\r\n x, y : int;\r\n nWidth, nHeight : int;\r\n hwndParent : HWND;\r\n nID : int\r\n ): HWND; stdcall; external AVICAPDLL;\r\n\r\nfunction capGetDriverDescriptionW(\r\n wDriverIndex : UINT;\r\n lpszName : LPWSTR;\r\n cbName : int;\r\n lpszVer : LPWSTR;\r\n cbVer : int\r\n ): BOOL; stdcall; external AVICAPDLL;\r\n\r\nfunction capCreateCaptureWindow(\r\n lpszWindowName : LPCTSTR;\r\n dwStyle : DWORD;\r\n x, y : int;\r\n nWidth, nHeight : int;\r\n hwndParent : HWND;\r\n nID : int\r\n ): HWND; stdcall; external AVICAPDLL name {$IFDEF UNICODE}'capCreateCaptureWindowW'{$ELSE}'capCreateCaptureWindowA'{$ENDIF UNICODE};\r\n\r\nfunction capGetDriverDescription(\r\n wDriverIndex : UINT;\r\n lpszName : LPTSTR;\r\n cbName : int;\r\n lpszVer : LPTSTR;\r\n cbVer : int\r\n ): BOOL; stdcall; external AVICAPDLL name {$IFDEF UNICODE}'capGetDriverDescriptionW'{$ELSE}'capGetDriverDescriptionA'{$ENDIF UNICODE};\r\n\r\n{== FilePreview dialog =======================================================}\r\n\r\nfunction GetOpenFileNamePreviewA(lpofn: POPENFILENAMEA): BOOL; stdcall; external VFWDLL;\r\nfunction GetSaveFileNamePreviewA(lpofn: POPENFILENAMEA): BOOL; stdcall; external VFWDLL;\r\n\r\nfunction GetOpenFileNamePreviewW(lpofn: POPENFILENAMEW): BOOL; stdcall; external VFWDLL;\r\nfunction GetSaveFileNamePreviewW(lpofn: POPENFILENAMEW): BOOL; stdcall; external VFWDLL;\r\n\r\nfunction GetOpenFileNamePreview(lpofn: POPENFILENAMEA): BOOL; stdcall; external VFWDLL name 'GetOpenFileNamePreviewA';\r\nfunction GetSaveFileNamePreview(lpofn: POPENFILENAMEA): BOOL; stdcall; external VFWDLL name 'GetSaveFileNamePreviewA';\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/WinConvTypes.pas", "content": "{******************************************************************}\r\n{ }\r\n{ Borland Delphi Runtime Library }\r\n{ Config Manager API interface unit }\r\n{ }\r\n{ The original Pascal code is: WinConvTypes.pas, }\r\n{ released 5 Nov 2004. }\r\n{ The initial developer of the Pascal code is Robert Marquardt }\r\n{ (robert_marquardt att gmx dott de) }\r\n{ }\r\n{ Portions created by Robert Marquardt are }\r\n{ Copyright (C) 2004 Robert Marquardt. }\r\n{ }\r\n{ Contributor(s): }\r\n{ }\r\n{ Obtained through: }\r\n{ Joint Endeavour of Delphi Innovators (Project JEDI) }\r\n{ }\r\n{ You may retrieve the latest version of this file at the Project }\r\n{ JEDI home page, located at http://delphi-jedi.org }\r\n{ }\r\n{ The contents of this file are used with permission, subject to }\r\n{ the Mozilla Public License Version 1.1 (the \"License\"); you may }\r\n{ not use this file except in compliance with the License. You may }\r\n{ obtain a copy of the License at }\r\n{ http://www.mozilla.org/MPL/MPL-1.1.html }\r\n{ }\r\n{ Software distributed under the License is distributed on an }\r\n{ \"AS IS\" basis, WITHOUT WARRANTY OF ANY KIND, either express or }\r\n{ implied. See the License for the specific language governing }\r\n{ rights and limitations under the License. }\r\n{ }\r\n{******************************************************************}\r\n\r\nunit WinConvTypes;\r\n\r\n{$I windowsversion.inc}\r\n{$I jvcl.inc}\r\n\r\ninterface\r\n\r\n{$WEAKPACKAGEUNIT ON}\r\n\r\nuses\r\n Windows;\r\n\r\ntype\r\n PHICON = ^HICON;\r\n\r\n {$IFDEF UNICODE}\r\n PCTSTR = PWideChar;\r\n PTSTR = PWideChar;\r\n TCHAR = WideChar;\r\n {$ELSE}\r\n PCTSTR = PAnsiChar;\r\n PTSTR = PAnsiChar;\r\n TCHAR = Char;\r\n {$ENDIF UNICODE}\r\n {$EXTERNALSYM PCTSTR}\r\n {$EXTERNALSYM PTSTR}\r\n {$EXTERNALSYM TCHAR}\r\n PPWSTR = ^PWideChar;\r\n PPASTR = ^PAnsiChar;\r\n PPSTR = ^PTSTR;\r\n\r\n{$IFNDEF RTL185_UP}\r\ntype\r\n // WARNING: Those types are defined as DWORD for simplicity under old versions\r\n // of Delphi but they really should be defined as pointers to their base types\r\n ULONG_PTR = DWORD;\r\n {$EXTERNALSYM ULONG_PTR}\r\n DWORD_PTR = DWORD;\r\n {$EXTERNALSYM DWORD_PTR}\r\n UINT_PTR = DWORD;\r\n {$EXTERNALSYM UINT_PTR}\r\n{$ENDIF ~RTL185_UP}\r\n\r\n{$IFNDEF RTL220_UP}\r\ntype\r\n ULONG32 = ULONG;\r\n {$EXTERNALSYM ULONG32}\r\n ULONG64 = Int64; // (rom) no unsigned Int64 available in Delphi\r\n {$EXTERNALSYM ULONG64}\r\n{$ENDIF ~RTL220_UP}\r\n\r\nimplementation\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/Winamp.pas", "content": "{-----------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/MPL-1.1.html\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: JvHWinamp.PAS, released on 2001-02-28.\r\n\r\nThe Initial Developer of the Original Code is Sbastien Buysse [sbuysse att buypin dott com]\r\nPortions created by Sbastien Buysse are Copyright (C) 2001 Sbastien Buysse.\r\nAll Rights Reserved.\r\n\r\nContributor(s): Michael Beck [mbeck att bigfoot dott com].\r\n\r\nLast Modified: 2000-02-28\r\n\r\nYou may retrieve the latest version of this file at the Project JEDI's JVCL home page,\r\nlocated at http://jvcl.delphi-jedi.org\r\n\r\nKnown Issues:\r\n-----------------------------------------------------------------------------}\r\n\r\nunit Winamp;\r\n\r\n{$I jvcl.inc}\r\n\r\n// (rom) this is a conversion.\r\n\r\n{*******************************************************}\r\n{ This unit is an interface to the Winamp Api }\r\n{*******************************************************}\r\n\r\ninterface\r\n\r\nuses\r\n Messages;\r\n\r\n(*\r\n** Winamp frontend/plug-in control API documentation v1.1.\r\n** By Justin Frankel. Updates by Christophe Thibault.\r\n** Copyright (C) 1997-2000, Nullsoft Inc.\r\n** Last updated: JUL.12.2000.\r\n**\r\n** Introduction\r\n** -----------------------\r\n** This file describes a means to easily communicate to Winamp\r\n** via the classic Win32 Message API.\r\n**\r\n** These definitions/code assume C/C++. Porting to VB/Delphi shouldn't\r\n** be too hard.\r\n**\r\n** First, you find the HWND of the Winamp main window. From a plug-in\r\n** you can easily extract this from the plug-in structure (hMainWindow,\r\n** hwndParent, whatever). For external apps, use:\r\n**\r\n** HWND hwnd_winamp = FindWindow(\"Winamp v1.x\",NULL);\r\n**\r\n** (note: I know, we're in Winamp 2.x, but it's 1.x for compatibility)\r\n**\r\n** Once you have the hwnd_winamp, it's a good idea to check the version\r\n** number. To do this, you send a WM_WA_IPC message to hwnd_winamp.\r\n** Note that WM_WA_IPC is defined as Win32's WM_USER.\r\n**\r\n** Note that sometimes you might want to use PostMessage instead of\r\n** SendMessage.\r\n*)\r\n\r\nconst\r\n WM_WA_IPC = WM_USER;\r\n\r\n (**************************************************************************)\r\n\r\n IPC_GETVERSION = 0;\r\n\r\n (*\r\n ** int version = SendMessage(hwnd_winamp,WM_WA_IPC,0,IPC_GETVERSION);\r\n **\r\n ** Version will be 0x20yx for winamp 2.yx. versions previous to Winamp 2.0\r\n ** typically (but not always) use 0x1zyx for 1.zx versions. Weird, I know.\r\n **\r\n ** The basic format for sending messages to Winamp is:\r\n ** int result=SendMessage(hwnd_winamp,WM_WA_IPC,command_data,command);\r\n ** (for the version check, command_data is 0).\r\n *)\r\n\r\n IPC_DELETE = 101;\r\n\r\n (*\r\n ** SendMessage(hwnd_winamp,WM_WA_IPC,0,IPC_DELETE);\r\n **\r\n ** You can use IPC_DELETE to clear Winamp's internal playlist.\r\n *)\r\n\r\n IPC_STARTPLAY = 102;\r\n\r\n (*\r\n ** SendMessage(hwnd_winamp,WM_WA_IPC,0,IPC_STARTPLAY);\r\n **\r\n ** Using IPC_STARTPLAY is like hitting 'Play' in Winamp, mostly.\r\n *)\r\n\r\n IPC_ISPLAYING = 104;\r\n\r\n (*\r\n ** int res = SendMessage(hwnd_winamp,WM_WA_IPC,0,IPC_ISPLAYING);\r\n **\r\n ** IPC_ISPLAYING returns the status of playback.\r\n ** If it returns 1, it is playing. if it returns 3, it is paused,\r\n ** if it returns 0, it is not playing.\r\n *)\r\n\r\n IPC_GETOUTPUTTIME = 105;\r\n\r\n (*\r\n ** int res = SendMessage(hwnd_winamp,WM_WA_IPC,mode,IPC_GETOUTPUTTIME);\r\n **\r\n ** IPC_GETOUTPUTTIME returns the position in milliseconds of the\r\n ** current song (mode = 0), or the song length, in seconds (mode = 1).\r\n ** Returns -1 if not playing or error.\r\n *)\r\n\r\n IPC_JUMPTOTIME = 106;\r\n\r\n (* (requires Winamp 1.60+)\r\n ** SendMessage(hwnd_winamp,WM_WA_IPC,ms,IPC_JUMPTOTIME);\r\n ** IPC_JUMPTOTIME sets the position in milliseconds of the\r\n ** current song (approximately).\r\n ** Returns -1 if not playing, 1 on eof, or 0 if successful\r\n *)\r\n\r\n IPC_WRITEPLAYLIST = 120;\r\n\r\n (* (requires Winamp 1.666+)\r\n ** SendMessage(hwnd_winamp,WM_WA_IPC,0,IPC_WRITEPLAYLIST);\r\n **\r\n ** IPC_WRITEPLAYLIST writes the current playlist to \\\\Winamp.m3u,\r\n ** and returns the current playlist position.\r\n ** Kinda obsoleted by some of the 2.x new stuff, but still good for when\r\n ** using a front-end (instead of a plug-in)\r\n *)\r\n\r\n IPC_SETPLAYLISTPOS = 121;\r\n\r\n (* (requires Winamp 2.0+)\r\n ** SendMessage(hwnd_winamp,WM_WA_IPC,position,IPC_SETPLAYLISTPOS)\r\n **\r\n ** IPC_SETPLAYLISTPOS sets the playlsit position to 'position'.\r\n *)\r\n\r\n IPC_SETVOLUME = 122;\r\n\r\n (* (requires Winamp 2.0+)\r\n ** SendMessage(hwnd_winamp,WM_WA_IPC,volume,IPC_SETVOLUME);\r\n **\r\n ** IPC_SETVOLUME sets the volume of Winamp (from 0-255).\r\n *)\r\n\r\n IPC_SETPANNING = 123;\r\n\r\n (* (requires Winamp 2.0+)\r\n ** SendMessage(hwnd_winamp,WM_WA_IPC,panning,IPC_SETPANNING);\r\n **\r\n ** IPC_SETPANNING sets the panning of Winamp (from 0 (left) to 255 (right)).\r\n *)\r\n\r\n IPC_GETLISTLENGTH = 124;\r\n\r\n (* (requires Winamp 2.0+)\r\n ** int length = SendMessage(hwnd_winamp,WM_WA_IPC,0,IPC_GETLISTLENGTH);\r\n **\r\n ** IPC_GETLISTLENGTH returns the length of the current playlist, in\r\n ** tracks.\r\n *)\r\n\r\n IPC_SETSKIN = 200;\r\n\r\n (* (requires Winamp 2.04+, only usable from plug-ins (not external apps))\r\n ** SendMessage(hwnd_winamp,WM_WA_IPC,(WPARAM)\"skinname\",IPC_SETSKIN);\r\n **\r\n ** IPC_SETSKIN sets the current skin to \"skinname\". Note that skinname\r\n ** can be the name of a skin, a skin .zip file, with or without path.\r\n ** If path isn't specified, the default search path is the winamp skins\r\n ** directory.\r\n *)\r\n\r\n IPC_GETSKIN = 201;\r\n\r\n (* (requires Winamp 2.04+, only usable from plug-ins (not external apps))\r\n ** SendMessage(hwnd_winamp,WM_WA_IPC,(WPARAM)skinname_buffer,IPC_GETSKIN);\r\n **\r\n ** IPC_GETSKIN puts the directory where skin bitmaps can be found\r\n ** into skinname_buffer.\r\n ** skinname_buffer must be MAX_PATH characters in length.\r\n ** When using a .zip'd skin file, it'll return a temporary directory\r\n ** where the ZIP was decompressed.\r\n *)\r\n\r\n IPC_EXECPLUG = 202;\r\n\r\n (* (requires Winamp 2.04+, only usable from plug-ins (not external apps))\r\n ** SendMessage(hwnd_winamp,WM_WA_IPC,(WPARAM)\"vis_file.dll\",IPC_EXECPLUG);\r\n **\r\n ** IPC_EXECPLUG executes a visualization plug-in pointed to by WPARAM.\r\n ** the format of this string can be:\r\n ** \"vis_whatever.dll\"\r\n ** \"vis_whatever.dll,0\" // (first mod, file in winamp plug-in dir)\r\n ** \"C:\\\\dir\\\\vis_whatever.dll,1\"\r\n *)\r\n\r\n IPC_GETPLAYLISTFILE = 211;\r\n\r\n (* (requires Winamp 2.04+, only usable from plug-ins (not external apps))\r\n ** char *name=SendMessage(hwnd_winamp,WM_WA_IPC,index,IPC_GETPLAYLISTFILE);\r\n **\r\n ** IPC_GETPLAYLISTFILE gets the filename of the playlist entry [index].\r\n ** returns a pointer to it. returns NULL on error.\r\n *)\r\n\r\n IPC_GETPLAYLISTTITLE = 212;\r\n\r\n (* (requires Winamp 2.04+, only usable from plug-ins (not external apps))\r\n ** char *name=SendMessage(hwnd_winamp,WM_WA_IPC,index,IPC_GETPLAYLISTTITLE);\r\n **\r\n ** IPC_GETPLAYLISTTITLE gets the title of the playlist entry [index].\r\n ** returns a pointer to it. returns NULL on error.\r\n *)\r\n\r\n IPC_GETLISTPOS = 125;\r\n\r\n (* (requires Winamp 2.05+)\r\n ** int pos=SendMessage(hwnd_winamp,WM_WA_IPC,0,IPC_GETLISTPOS);\r\n **\r\n ** IPC_GETLISTPOS returns the playlist position. A lot like IPC_WRITEPLAYLIST\r\n ** only faster since it doesn't have to write out the list. Heh, silly me.\r\n *)\r\n\r\n IPC_GETINFO = 126;\r\n\r\n (* (requires Winamp 2.05+)\r\n ** int inf=SendMessage(hwnd_winamp,WM_WA_IPC,mode,IPC_GETINFO);\r\n **\r\n ** IPC_GETINFO returns info about the current playing song. The value\r\n ** it returns depends on the value of 'mode'.\r\n ** Mode Meaning\r\n ** ------------------\r\n ** 0 Samplerate (i.e. 44100)\r\n ** 1 Bitrate (i.e. 128)\r\n ** 2 Channels (i.e. 2)\r\n *)\r\n\r\n IPC_GETEQDATA = 127;\r\n\r\n (* (requires Winamp 2.05+)\r\n ** int data=SendMessage(hwnd_winamp,WM_WA_IPC,pos,IPC_GETEQDATA);\r\n **\r\n ** IPC_GETEQDATA queries the status of the EQ.\r\n ** The value returned depends on what 'pos' is set to:\r\n ** Value Meaning\r\n ** ------------------\r\n ** 0-9 The 10 bands of EQ data. 0-63 (+20db - -20db)\r\n ** 10 The preamp value. 0-63 (+20db - -20db)\r\n ** 11 Enabled. zero if disabled, nonzero if enabled.\r\n ** 12 Autoload. zero if disabled, nonzero if enabled.\r\n *)\r\n\r\n IPC_SETEQDATA = 128;\r\n (* (requires Winamp 2.05+)\r\n ** SendMessage(hwnd_winamp,WM_WA_IPC,pos,IPC_GETEQDATA);\r\n ** SendMessage(hwnd_winamp,WM_WA_IPC,value,IPC_SETEQDATA);\r\n **\r\n ** IPC_SETEQDATA sets the value of the last position retrieved\r\n ** by IPC_GETEQDATA.\r\n *)\r\n\r\n IPC_ADDBOOKMARK = 129;\r\n (* (requires Winamp 2.4+)\r\n ** SendMessage(hwnd_winamp,WM_WA_IPC,(WPARAM)file,IPC_ADDBOOKMARK);\r\n **\r\n ** IPC_ADDBOOKMARK will add the specified file to the Winamp bookmark list.\r\n *)\r\n\r\n IPC_RESTARTWINAMP = 135;\r\n (* (requires Winamp 2.2+)\r\n ** SendMessage(hwnd_winamp,WM_WA_IPC,0,IPC_RESTARTWINAMP);\r\n **\r\n ** IPC_RESTARTWINAMP will restart Winamp (isn't that obvious ? :)\r\n *)\r\n\r\n IPC_MBOPEN = 241;\r\n (* (requires Winamp 2.05+)\r\n ** SendMessage(hwnd_winamp,WM_WA_IPC,0,IPC_MBOPEN);\r\n ** SendMessage(hwnd_winamp,WM_WA_IPC,(WPARAM)url,IPC_MBOPEN);\r\n **\r\n ** IPC_MBOPEN will open a new URL in the minibrowser. if url is NULL, it will open the Minibrowser window.\r\n *)\r\n\r\n IPC_INETAVAILABLE = 242;\r\n (* (requires Winamp 2.05+)\r\n ** val=SendMessage(hwnd_winamp,WM_WA_IPC,0,IPC_INETAVAILABLE);\r\n **\r\n ** IPC_INETAVAILABLE will return 1 if the Internet connection is available for Winamp.\r\n *)\r\n\r\n IPC_UPDTITLE = 243;\r\n (* (requires Winamp 2.2+)\r\n ** SendMessage(hwnd_winamp,WM_WA_IPC,0,IPC_UPDTITLE);\r\n **\r\n ** IPC_UPDTITLE will ask Winamp to update the informations about the current title.\r\n *)\r\n\r\n IPC_CHANGECURRENTFILE = 245;\r\n (* (requires Winamp 2.05+)\r\n ** SendMessage(hwnd_winamp,WM_WA_IPC,(WPARAM)file,IPC_CHANGECURRENTFILE);\r\n **\r\n ** IPC_CHANGECURRENTFILE will set the current playlist item.\r\n *)\r\n\r\n IPC_GETMBURL = 246;\r\n (* (requires Winamp 2.2+)\r\n ** char buffer[4096]; // Urls can be VERY long\r\n ** SendMessage(hwnd_winamp,WM_WA_IPC,(WPARAM)buffer,IPC_GETMBURL);\r\n **\r\n ** IPC_GETMBURL will retrieve the current Minibrowser URL into buffer.\r\n *)\r\n\r\n IPC_REFRESHPLCACHE = 247;\r\n (* (requires Winamp 2.2+)\r\n ** SendMessage(hwnd_winamp,WM_WA_IPC,0,IPC_REFRESHPLCACHE);\r\n **\r\n ** IPC_REFRESHPLCACHE will flush the playlist cache buffer.\r\n *)\r\n\r\n IPC_MBBLOCK = 248;\r\n (* (requires Winamp 2.4+)\r\n ** SendMessage(hwnd_winamp,WM_WA_IPC,value,IPC_MBBLOCK);\r\n **\r\n ** IPC_MBBLOCK will block the Minibrowser from updates if value is set to 1\r\n *)\r\n\r\n IPC_MBOPENREAL = 249;\r\n (* (requires Winamp 2.4+)\r\n ** SendMessage(hwnd_winamp,WM_WA_IPC,(WPARAM)url,IPC_MBOPENREAL);\r\n **\r\n ** IPC_MBOPENREAL works the same as IPC_MBOPEN except that it will works even if\r\n ** IPC_MBBLOCK has been set to 1\r\n *)\r\n\r\n IPC_GET_SHUFFLE = 250;\r\n (* (requires Winamp 2.4+)\r\n ** val=SendMessage(hwnd_winamp,WM_WA_IPC,0,IPC_GET_SHUFFLE);\r\n **\r\n ** IPC_GET_SHUFFLE returns the status of the Shuffle option (1 if set)\r\n *)\r\n\r\n IPC_GET_REPEAT = 251;\r\n (* (requires Winamp 2.4+)\r\n ** val=SendMessage(hwnd_winamp,WM_WA_IPC,0,IPC_GET_REPEAT);\r\n **\r\n ** IPC_GET_REPEAT returns the status of the Repeat option (1 if set)\r\n *)\r\n\r\n IPC_SET_SHUFFLE = 252;\r\n (* (requires Winamp 2.4+)\r\n ** SendMessage(hwnd_winamp,WM_WA_IPC,value,IPC_SET_SHUFFLE);\r\n **\r\n ** IPC_SET_SHUFFLE sets the status of the Shuffle option (1 to turn it on)\r\n *)\r\n\r\n IPC_SET_REPEAT = 253;\r\n (* (requires Winamp 2.4+)\r\n ** SendMessage(hwnd_winamp,WM_WA_IPC,value,IPC_SET_REPEAT);\r\n **\r\n ** IPC_SET_REPEAT sets the status of the Repeat option (1 to turn it on)\r\n *)\r\n\r\n (**************************************************************************)\r\n\r\n (*\r\n ** Some API calls tend to require that you send data via WM_COPYDATA\r\n ** instead of WM_USER. Such as IPC_PLAYFILE:\r\n *)\r\n\r\n IPC_PLAYFILE = 100;\r\n\r\n (*\r\n ** COPYDATASTRUCT cds;\r\n ** cds.dwData = IPC_PLAYFILE;\r\n ** cds.lpData = (void * ) \"file.mp3\";\r\n ** cds.cbData = strlen((Char * )cds.lpData) + 1; // include space for null char\r\n ** SendMessage(hwnd_winamp, WM_COPYDATA, (WPARAM)NULL, (LPARAM)&cds);\r\n **\r\n ** This will play the file \"file.mp3\".\r\n **\r\n *)\r\n\r\n IPC_CHDIR = 103;\r\n\r\n (*\r\n ** COPYDATASTRUCT cds;\r\n ** cds.dwData = IPC_CHDIR;\r\n ** cds.lpData = (void * ) \"c: \\\\download\";\r\n ** cds.cbData = strlen((Char * )cds.lpData) + 1; // include space for null char\r\n ** SendMessage(hwnd_winamp, WM_COPYDATA, (WPARAM)NULL, (LPARAM)&cds);\r\n **\r\n ** This will make Winamp change to the Directory C: \\\\download\r\n **\r\n *)\r\n\r\n (**************************************************************************)\r\n\r\n (*\r\n ** Finally there are some WM_COMMAND messages that you can use to send\r\n ** Winamp misc commands.\r\n **\r\n ** To send these, use:\r\n **\r\n ** SendMessage(hwnd_winamp, WM_COMMAND,command_name,0);\r\n *)\r\n\r\n WINAMP_OPTIONS_EQ = 40036; // toggles the EQ window\r\n WINAMP_OPTIONS_PLEDIT = 40040; // toggles the playlist window\r\n WINAMP_VOLUMEUP = 40058; // turns the volume up a little\r\n WINAMP_VOLUMEDOWN = 40059; // turns the volume down a little\r\n WINAMP_FFWD5S = 40060; // fast forwards 5 seconds\r\n WINAMP_REW5S = 40061; // rewinds 5 seconds\r\n\r\n // the following are the five main control buttons, with optionally shift\r\n // or control pressed\r\n // (for the exact functions of each, just try it out)\r\n WINAMP_BUTTON1 = 40044;\r\n WINAMP_BUTTON2 = 40045;\r\n WINAMP_BUTTON3 = 40046;\r\n WINAMP_BUTTON4 = 40047;\r\n WINAMP_BUTTON5 = 40048;\r\n WINAMP_BUTTON1_SHIFT = 40144;\r\n WINAMP_BUTTON2_SHIFT = 40145;\r\n WINAMP_BUTTON3_SHIFT = 40146;\r\n WINAMP_BUTTON4_SHIFT = 40147;\r\n WINAMP_BUTTON5_SHIFT = 40148;\r\n WINAMP_BUTTON1_CTRL = 40154;\r\n WINAMP_BUTTON2_CTRL = 40155;\r\n WINAMP_BUTTON3_CTRL = 40156;\r\n WINAMP_BUTTON4_CTRL = 40157;\r\n WINAMP_BUTTON5_CTRL = 40158;\r\n\r\n WINAMP_FILE_PLAY = 40029; // pops up the load file(s) box\r\n WINAMP_OPTIONS_PREFS = 40012; // pops up the preferences\r\n WINAMP_OPTIONS_AOT = 40019; // toggles always on top\r\n WINAMP_HELP_ABOUT = 40041; // pops up the about box :)\r\n\r\n (*\r\n ** EOF.. Enjoy.\r\n *)\r\n\r\nimplementation\r\n\r\nend.\r\n" }, { "path": "External/Jedi/Jvcl/run/run.txt", "content": "" }, { "path": "External/KOLDetours.pas", "content": "unit KOLDetours;\r\n// NOTE: SEE END OF FILE FOR EXAMPLE OF DETOURING OBJECT FUNCTIONS!!!\r\n//\r\n// Unit: KOL detours\r\n// purpose: Interception of methods, procedures and functions\r\n// Author: KOL version Thaddy de Koning\r\n// Original author? published first in Delphi Magazine 101.\r\n// Copyright: This version 2004, Thaddy de Koning\r\n// Remarks: Freeware, use as you like.\r\n// I did very little to the code, tnx to the original author.\r\n// Only works for NT and higher.\r\n//\r\ninterface\r\n\r\nuses Windows, Classes;\r\n //Forms;\r\n\r\nfunction InterceptCreate(const TargetProc, InterceptProc: Pointer): Pointer;\r\n{ Redirects the procedure TargetProc to InterceptProc. Returns the address of a\r\n trampoline function, which can be used to call the original routine from\r\n your Intercept. Also, the trampoline function must be passed to the\r\n InterceptRemove function to restore the original routine again. The Intercept\r\n and trampoline routines must have the exact same signature as TargetProc for\r\n the Intercept to work. Example:\r\n\r\n var\r\n TrampolineMessageBox: function(hWnd: HWND; lpText, lpCaption: PChar;\r\n uType: UINT): Integer; stdcall;\r\n\r\n function InterceptMessageBox(hWnd: HWND; lpText, lpCaption: PChar;\r\n uType: UINT): Integer; stdcall;\r\n var\r\n S: String;\r\n begin\r\n S := UpperCase(lpText);\r\n Result := TrampolineMessageBox(hWnd,PChar(S),lpCaption,uType);\r\n end;\r\n\r\n @TrampolineMessageBox := InterceptCreate(@MessageBox,@InterceptMessageBox);\r\n MessageBox(0,'Intercept test','Test',MB_OK);\r\n // Will display the message 'Intercept test' in upper case\r\n InterceptRemove(@TrampolineMessageBox,@InterceptMessageBox);\r\n MessageBox(0,'Intercept test','Test',MB_OK);\r\n // Will display the message 'Intercept test' in original case\r\n\r\n\r\n NOTE: SEE END OF FILE FOR EXAMPLE OF DETOURING OBJECT FUNCTIONS!!!\r\n\r\n }\r\n\r\nfunction InterceptRemove(var Trampoline: Pointer; const InterceptProc: Pointer): Boolean;\r\n{ Restores the Intercept. You must pass the trampoline as returned by the\r\n InterceptCreate function and the Intercept routine. This trampoline will be freed\r\n and set to nil }\r\n\r\n\r\n{$IFDEF VER120}\r\ntype\r\n PPointer = ^Pointer;\r\n{$ENDIF}\r\n\r\nconst\r\n SizeOfJmp = 5;\r\n { Size of an assembly JMP instruction in bytes (1 byte for the OpCode and\r\n 4 bytes for the address displacement) }\r\n TrampolineSize = 32;\r\n { The amount of bytes allocated for a trampoline function. A trampoline\r\n should be large enough to accomodate at least 5 bytes from the original\r\n routine, and 5 bytes for an unconditional JMP instruction. A single\r\n assembly instruction can take up 17 bytes: up to 4 bytes for an instruction\r\n prefix + up to 3 bytes for the instruction opcode + 1 optional ModR/M byte\r\n + 1 optional SIB-byte + up to 4 address displacement bytes + up to 4\r\n immediate data bytes (see Intel's IA-32 instruction reference for details).\r\n Since at least 5 bytes from the original routine have to be copied to the\r\n trampoline, and the fifth byte could start a new 17-byte instruction, this\r\n means a maximum of 4+17=21 bytes could be needed. Including the 5 bytes for\r\n an unconditional JMP, we should allocate 26 bytes minimum. We use 32 bytes\r\n here to be on the safe side. }\r\n\r\nconst // Machine code values for certain assembly opcodes\r\n opJmpIndirect = $25FF; // jmp dword ptr[
    ] jmp dword ptr [$12345678]\r\n opJmpRelative = $E9; // jmp jmp -$00001234\r\n opJmpEax = $E0FF; // jmp eax\r\n opRetPop = $C2; // ret ret $1234\r\n opRet = $C3; // ret\r\n opPreES = $26; // ES-prefix (e.g. jmp dword ptr ES:[$12345678])\r\n opPreCS = $2E; // CS-prefix\r\n opPreSS = $36; // SS-prefix\r\n opPreDS = $3E; // DS-prefix\r\n opPreFS = $64; // FS-prefix\r\n opPreGS = $65; // GS-prefix\r\n opInt3 = $CC; // int 3 (debug breakpoint)\r\n //\r\n opMovECX = $0D8B; // mov ECX (mov ECX, EAX)\r\n\r\ntype\r\n PIntercepts=^TIntercepts;\r\n //TIntercepts = object(Tobj)\r\n TIntercepts = class(TComponent)\r\n { Helper class for creating Intercepts }\r\n private\r\n FUse16BitAddress: Boolean;\r\n FUse16BitOperand: Boolean;\r\n { Scratch area for copying assembly instructions }\r\n FScratch: array [0..63] of Byte;\r\n FProcess: THandle;\r\n { Handle to the current process }\r\n protected\r\n function GetFinalCode(const Proc: Pointer; const SkipJumps: Boolean = False): Pointer;\r\n { Examines the routine Proc. Returns the address where the actual code of\r\n Proc is located. }\r\n function InsertIntercept(const TargetProc, Trampoline, InterceptProc: Pointer): Boolean;\r\n { Is called by CreateIntercept. The first few instructions of TargetProc are\r\n copied to the Trampoline. TargetProc is adjusted by inserting an\r\n unconditional JMP instruction to the InterceptProc. The Trampoline is\r\n extended with an unconditional JMP instruction to the remainder of\r\n TargetProc }\r\n function CopyInstruction(Src, Dst: Pointer): Pointer;\r\n { Copies the assembly instruction at Src to Dst. Returns the address of the\r\n next instruction in Src. Dst can be nil. In that case the instruction is\r\n not actually copied and only the address of the next instruction is\r\n returned. This can be helpful to calculate the number of bytes an\r\n instruction takes. }\r\n procedure AdjustTarget(const Src, Dst: Pointer; const OpCodeSize,\r\n TargetOffset: Integer);\r\n { Adjusts the relative target of the instruction at Dst. Src points to the\r\n source instruction and Dst to the already copied destination instruction.\r\n OpCodeSize must be the fixed size of the OpCode and TargetOffset the\r\n offset from the OpCode where the relative target is located.\r\n Example:\r\n Src: $00005000 jmp -$1000\r\n At address $00005000 is an instruction that jumps $1000 bytes backwards,\r\n that is to address $00004000. When this instruction is copied to Dst\r\n at address $00007000:\r\n Dst: $00007000 jmp -$1000\r\n than it jumps to address $00006000, which is incorrect. The instruction is\r\n adjusted so it jumps to the right address:\r\n Dst: $00007000 jmp -$3000 }\r\n function SetPermission(const Code: Pointer; const Size: Integer;\r\n const Permission: Longword): Longword;\r\n { Change the access protection of a piece of assembly code. Code should\r\n point to the code and be Size bytes in size. Permission should be a\r\n constant representing the requested permission (see the Windows API help\r\n on VirtualProtect). Returns the old permission value }\r\n function InsertJump(Code, Target: Pointer; Size: Integer): Boolean;\r\n { Adds an unconditional jump at address Code to jump to Target. If Size is\r\n larger than the space needed for the jump (5 bytes), then the remainder\r\n of the Code is filled with \"int 3\" instructions. Returns False if the\r\n jump could not be inserted (size < 5) }\r\n\r\n property Use16BitAddress: Boolean read FUse16BitAddress write FUse16BitAddress;\r\n { Indicates if the current instruction uses a 16-bit address (if False, a\r\n 32-bit address is used) }\r\n property Use16BitOperand: Boolean read FUse16BitOperand write FUse16BitOperand;\r\n { Indicates if the current instruction uses a 16-bit operand (if False, a\r\n 32-bit operand is used}\r\n public\r\n destructor Destroy; override;\r\n\r\n function CreateIntercept(TargetProc, InterceptProc: Pointer): Pointer;\r\n { Redirects TargetProc to InterceptProc and returns a trampoline routine }\r\n function RemoveIntercept(Trampoline, InterceptProc: Pointer): Boolean;\r\n { Restores a Intercept }\r\n end;\r\n\r\nfunction NewIntercepts:TIntercepts;\r\n\r\ntype\r\n POpCodeEntry = ^TOpCodeEntry;\r\n\r\n TCopyInstructionProc = function (const Intercepts: PIntercepts;\r\n Entry: POpCodeEntry; Src, Dst: Pointer): Pointer;\r\n { Procedural type used to copy assembly instructions }\r\n\r\n TOpCodeEntry = packed record\r\n { Contains information about an assembly OpCode }\r\n Size32: Byte; // Fixed size of OpCode with 32-bit operand\r\n Size16: Byte; // Fixed size of OpCode with 16-bit operand\r\n ModOfs: Byte; // Offset to ModR/M byte\r\n RelOfs: Byte; // Offset to relative target\r\n UseAdr: Boolean; // Use address-size attribute instead of operand-size attribute\r\n Copy : TCopyInstructionProc; // Function used to copy instruction\r\n end;\r\n\r\n\r\n\r\n{ Forward declarations of TCopyInstructionProc functions used in the\r\n OneByteOpCodes and TwoByteOpCodes arrays }\r\n\r\nfunction CopyNormal(const Intercepts: PIntercepts; Entry: POpCodeEntry;\r\n Src, Dst: Pointer): Pointer; forward;\r\n{ Default function for copying instructions }\r\n\r\nfunction Copy2ByteOpCode(const Intercepts: PIntercepts; Entry: POpCodeEntry;\r\n Src, Dst: Pointer): Pointer; forward;\r\n{ Function for copying 2 byte long OpCodes. The first OpCode byte is $0F }\r\n\r\nfunction CopyWithPrefix(const Intercepts: PIntercepts; Entry: POpCodeEntry;\r\n Src, Dst: Pointer): Pointer; forward;\r\n{ Function for copying instructions that contain prefix bytes }\r\n\r\nfunction CopyWith16BitOperand(const Intercepts: PIntercepts; Entry: POpCodeEntry;\r\n Src, Dst: Pointer): Pointer; forward;\r\n{ Function for copying instructions that contain a prefix instructing to use\r\n 16-bit operands }\r\n\r\nfunction CopyWith16BitAddress(const Intercepts: PIntercepts; Entry: POpCodeEntry;\r\n Src, Dst: Pointer): Pointer; forward;\r\n{ Function for copying instructions that contain a prefix instructing to use\r\n 16-bit addresses }\r\n\r\nfunction CopyOpF6(const Intercepts: PIntercepts; Entry: POpCodeEntry;\r\n Src, Dst: Pointer): Pointer; forward;\r\n{ Function for copying instructions with OpCode $F6 (test, div, idiv, mul,\r\n imul, not and neg using a 8-bit operand) }\r\n\r\nfunction CopyOpF7(const Intercepts: PIntercepts; Entry: POpCodeEntry;\r\n Src, Dst: Pointer): Pointer; forward;\r\n{ Function for copying instructions with OpCode $F7 (test, div, idiv, mul,\r\n imul, not and neg using a 16/32-bit operand) }\r\n\r\nfunction CopyInvalid(const Intercepts: PIntercepts; Entry: POpCodeEntry;\r\n Src, Dst: Pointer): Pointer; forward;\r\n{ Called when trying to copy an invalid OpCode. Just skips the OpCode. }\r\n\r\nconst\r\n OneByteOpCodes: array [0..255] of TOpCodeEntry = (\r\n // Information about OpCodes of 1 byte\r\n (Size32: 2; Size16: 2; ModOfs: 1; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // ADD /r\r\n (Size32: 2; Size16: 2; ModOfs: 1; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // ADD /r\r\n (Size32: 2; Size16: 2; ModOfs: 1; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // ADD /r\r\n (Size32: 2; Size16: 2; ModOfs: 1; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // ADD /r\r\n (Size32: 2; Size16: 2; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // ADD ib\r\n (Size32: 5; Size16: 3; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // ADD iw\r\n (Size32: 1; Size16: 1; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // PUSH\r\n (Size32: 1; Size16: 1; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // POP\r\n (Size32: 2; Size16: 2; ModOfs: 1; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // OR /r\r\n (Size32: 2; Size16: 2; ModOfs: 1; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // OR /r\r\n (Size32: 2; Size16: 2; ModOfs: 1; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // OR /r\r\n (Size32: 2; Size16: 2; ModOfs: 1; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // OR /r\r\n (Size32: 2; Size16: 2; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // OR ib\r\n (Size32: 5; Size16: 3; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // OR iw\r\n (Size32: 1; Size16: 1; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // PUSH\r\n (Size32: 1; Size16: 1; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: Copy2ByteOpCode ), // Extension Ops\r\n (Size32: 2; Size16: 2; ModOfs: 1; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // ADC /r\r\n (Size32: 2; Size16: 2; ModOfs: 1; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // ADC /r\r\n (Size32: 2; Size16: 2; ModOfs: 1; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // ADC /r\r\n (Size32: 2; Size16: 2; ModOfs: 1; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // ADC /r\r\n (Size32: 2; Size16: 2; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // ADC ib\r\n (Size32: 5; Size16: 3; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // ADC id\r\n (Size32: 1; Size16: 1; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // PUSH\r\n (Size32: 1; Size16: 1; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // POP\r\n (Size32: 2; Size16: 2; ModOfs: 1; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // SBB /r\r\n (Size32: 2; Size16: 2; ModOfs: 1; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // SBB /r\r\n (Size32: 2; Size16: 2; ModOfs: 1; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // SBB /r\r\n (Size32: 2; Size16: 2; ModOfs: 1; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // SBB /r\r\n (Size32: 2; Size16: 2; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // SBB ib\r\n (Size32: 5; Size16: 3; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // SBB id\r\n (Size32: 1; Size16: 1; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // PUSH\r\n (Size32: 1; Size16: 1; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // POP\r\n (Size32: 2; Size16: 2; ModOfs: 1; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // AND /r\r\n (Size32: 2; Size16: 2; ModOfs: 1; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // AND /r\r\n (Size32: 2; Size16: 2; ModOfs: 1; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // AND /r\r\n (Size32: 2; Size16: 2; ModOfs: 1; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // AND /r\r\n (Size32: 2; Size16: 2; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // AND ib\r\n (Size32: 5; Size16: 3; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // AND id\r\n (Size32: 1; Size16: 1; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyWithPrefix ), // ES prefix\r\n (Size32: 1; Size16: 1; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // DAA\r\n (Size32: 2; Size16: 2; ModOfs: 1; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // SUB /r\r\n (Size32: 2; Size16: 2; ModOfs: 1; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // SUB /r\r\n (Size32: 2; Size16: 2; ModOfs: 1; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // SUB /r\r\n (Size32: 2; Size16: 2; ModOfs: 1; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // SUB /r\r\n (Size32: 2; Size16: 2; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // SUB ib\r\n (Size32: 5; Size16: 3; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // SUB id\r\n (Size32: 1; Size16: 1; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyWithPrefix ), // CS prefix\r\n (Size32: 1; Size16: 1; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // DAS\r\n (Size32: 2; Size16: 2; ModOfs: 1; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // XOR /r\r\n (Size32: 2; Size16: 2; ModOfs: 1; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // XOR /r\r\n (Size32: 2; Size16: 2; ModOfs: 1; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // XOR /r\r\n (Size32: 2; Size16: 2; ModOfs: 1; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // XOR /r\r\n (Size32: 2; Size16: 2; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // XOR ib\r\n (Size32: 5; Size16: 3; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // XOR id\r\n (Size32: 1; Size16: 1; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyWithPrefix ), // SS prefix\r\n (Size32: 1; Size16: 1; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // AAA\r\n (Size32: 2; Size16: 2; ModOfs: 1; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // CMP /r\r\n (Size32: 2; Size16: 2; ModOfs: 1; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // CMP /r\r\n (Size32: 2; Size16: 2; ModOfs: 1; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // CMP /r\r\n (Size32: 2; Size16: 2; ModOfs: 1; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // CMP /r\r\n (Size32: 2; Size16: 2; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // CMP ib\r\n (Size32: 5; Size16: 3; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // CMP id\r\n (Size32: 1; Size16: 1; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyWithPrefix ), // DS prefix\r\n (Size32: 1; Size16: 1; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // AAS\r\n (Size32: 1; Size16: 1; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // INC\r\n (Size32: 1; Size16: 1; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // INC\r\n (Size32: 1; Size16: 1; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // INC\r\n (Size32: 1; Size16: 1; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // INC\r\n (Size32: 1; Size16: 1; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // INC\r\n (Size32: 1; Size16: 1; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // INC\r\n (Size32: 1; Size16: 1; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // INC\r\n (Size32: 1; Size16: 1; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // INC\r\n (Size32: 1; Size16: 1; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // DEC\r\n (Size32: 1; Size16: 1; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // DEC\r\n (Size32: 1; Size16: 1; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // DEC\r\n (Size32: 1; Size16: 1; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // DEC\r\n (Size32: 1; Size16: 1; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // DEC\r\n (Size32: 1; Size16: 1; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // DEC\r\n (Size32: 1; Size16: 1; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // DEC\r\n (Size32: 1; Size16: 1; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // DEC\r\n (Size32: 1; Size16: 1; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // PUSH\r\n (Size32: 1; Size16: 1; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // PUSH\r\n (Size32: 1; Size16: 1; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // PUSH\r\n (Size32: 1; Size16: 1; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // PUSH\r\n (Size32: 1; Size16: 1; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // PUSH\r\n (Size32: 1; Size16: 1; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // PUSH\r\n (Size32: 1; Size16: 1; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // PUSH\r\n (Size32: 1; Size16: 1; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // PUSH\r\n (Size32: 1; Size16: 1; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // POP\r\n (Size32: 1; Size16: 1; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // POP\r\n (Size32: 1; Size16: 1; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // POP\r\n (Size32: 1; Size16: 1; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // POP\r\n (Size32: 1; Size16: 1; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // POP\r\n (Size32: 1; Size16: 1; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // POP\r\n (Size32: 1; Size16: 1; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // POP\r\n (Size32: 1; Size16: 1; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // POP\r\n (Size32: 1; Size16: 1; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // PUSHAD\r\n (Size32: 1; Size16: 1; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // POPAD\r\n (Size32: 2; Size16: 2; ModOfs: 1; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // BOUND /r\r\n (Size32: 2; Size16: 2; ModOfs: 1; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // ARPL /r\r\n (Size32: 1; Size16: 1; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyWithPrefix ), // FS prefix\r\n (Size32: 1; Size16: 1; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyWithPrefix ), // GS prefix\r\n (Size32: 1; Size16: 1; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyWith16BitOperand), // Operand Prefix\r\n (Size32: 1; Size16: 1; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyWith16BitAddress), // Address Prefix\r\n (Size32: 5; Size16: 3; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // PUSH\r\n (Size32: 6; Size16: 4; ModOfs: 1; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), //\r\n (Size32: 2; Size16: 2; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // PUSH\r\n (Size32: 3; Size16: 3; ModOfs: 1; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // IMUL /r ib\r\n (Size32: 1; Size16: 1; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // INS\r\n (Size32: 1; Size16: 1; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // INS\r\n (Size32: 1; Size16: 1; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // OUTS/OUTSB\r\n (Size32: 1; Size16: 1; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // OUTS/OUTSW\r\n (Size32: 2; Size16: 2; ModOfs: 0; RelOfs: 1; UseAdr: False; Copy: CopyNormal ), // JO\r\n (Size32: 2; Size16: 2; ModOfs: 0; RelOfs: 1; UseAdr: False; Copy: CopyNormal ), // JNO\r\n (Size32: 2; Size16: 2; ModOfs: 0; RelOfs: 1; UseAdr: False; Copy: CopyNormal ), // JB/JC/JNAE\r\n (Size32: 2; Size16: 2; ModOfs: 0; RelOfs: 1; UseAdr: False; Copy: CopyNormal ), // JAE/JNB/JNC\r\n (Size32: 2; Size16: 2; ModOfs: 0; RelOfs: 1; UseAdr: False; Copy: CopyNormal ), // JE/JZ\r\n (Size32: 2; Size16: 2; ModOfs: 0; RelOfs: 1; UseAdr: False; Copy: CopyNormal ), // JNE/JNZ\r\n (Size32: 2; Size16: 2; ModOfs: 0; RelOfs: 1; UseAdr: False; Copy: CopyNormal ), // JBE/JNA\r\n (Size32: 2; Size16: 2; ModOfs: 0; RelOfs: 1; UseAdr: False; Copy: CopyNormal ), // JA/JNBE\r\n (Size32: 2; Size16: 2; ModOfs: 0; RelOfs: 1; UseAdr: False; Copy: CopyNormal ), // JS\r\n (Size32: 2; Size16: 2; ModOfs: 0; RelOfs: 1; UseAdr: False; Copy: CopyNormal ), // JNS\r\n (Size32: 2; Size16: 2; ModOfs: 0; RelOfs: 1; UseAdr: False; Copy: CopyNormal ), // JP/JPE\r\n (Size32: 2; Size16: 2; ModOfs: 0; RelOfs: 1; UseAdr: False; Copy: CopyNormal ), // JNP/JPO\r\n (Size32: 2; Size16: 2; ModOfs: 0; RelOfs: 1; UseAdr: False; Copy: CopyNormal ), // JL/JNGE\r\n (Size32: 2; Size16: 2; ModOfs: 0; RelOfs: 1; UseAdr: False; Copy: CopyNormal ), // JGE/JNL\r\n (Size32: 2; Size16: 2; ModOfs: 0; RelOfs: 1; UseAdr: False; Copy: CopyNormal ), // JLE/JNG\r\n (Size32: 2; Size16: 2; ModOfs: 0; RelOfs: 1; UseAdr: False; Copy: CopyNormal ), // JG/JNLE\r\n (Size32: 3; Size16: 3; ModOfs: 1; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // ADC/2 ib, etc.s\r\n (Size32: 6; Size16: 4; ModOfs: 1; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), //\r\n (Size32: 2; Size16: 2; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // MOV al,x\r\n (Size32: 3; Size16: 3; ModOfs: 1; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // ADC/2 ib, etc.\r\n (Size32: 2; Size16: 2; ModOfs: 1; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // TEST /r\r\n (Size32: 2; Size16: 2; ModOfs: 1; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // TEST /r\r\n (Size32: 2; Size16: 2; ModOfs: 1; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // XCHG /r @todo\r\n (Size32: 2; Size16: 2; ModOfs: 1; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // XCHG /r @todo\r\n (Size32: 2; Size16: 2; ModOfs: 1; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // MOV /r\r\n (Size32: 2; Size16: 2; ModOfs: 1; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // MOV /r\r\n (Size32: 2; Size16: 2; ModOfs: 1; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // MOV /r\r\n (Size32: 2; Size16: 2; ModOfs: 1; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // MOV /r\r\n (Size32: 2; Size16: 2; ModOfs: 1; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // MOV /r\r\n (Size32: 2; Size16: 2; ModOfs: 1; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // LEA /r\r\n (Size32: 2; Size16: 2; ModOfs: 1; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // MOV /r\r\n (Size32: 2; Size16: 2; ModOfs: 1; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // POP /0\r\n (Size32: 1; Size16: 1; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // NOP\r\n (Size32: 1; Size16: 1; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // XCHG\r\n (Size32: 1; Size16: 1; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // XCHG\r\n (Size32: 1; Size16: 1; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // XCHG\r\n (Size32: 1; Size16: 1; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // XCHG\r\n (Size32: 1; Size16: 1; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // XCHG\r\n (Size32: 1; Size16: 1; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // XCHG\r\n (Size32: 1; Size16: 1; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // XCHG\r\n (Size32: 1; Size16: 1; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // CWDE\r\n (Size32: 1; Size16: 1; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // CDQ\r\n (Size32: 7; Size16: 5; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // CALL cp\r\n (Size32: 1; Size16: 1; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // WAIT/FWAIT\r\n (Size32: 1; Size16: 1; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // PUSHFD\r\n (Size32: 1; Size16: 1; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // POPFD\r\n (Size32: 1; Size16: 1; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // SAHF\r\n (Size32: 1; Size16: 1; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // LAHF\r\n (Size32: 5; Size16: 3; ModOfs: 0; RelOfs: 0; UseAdr: True ; Copy: CopyNormal ), // MOV\r\n (Size32: 5; Size16: 3; ModOfs: 0; RelOfs: 0; UseAdr: True ; Copy: CopyNormal ), // MOV\r\n (Size32: 5; Size16: 3; ModOfs: 0; RelOfs: 0; UseAdr: True ; Copy: CopyNormal ), // MOV\r\n (Size32: 5; Size16: 3; ModOfs: 0; RelOfs: 0; UseAdr: True ; Copy: CopyNormal ), // MOV\r\n (Size32: 1; Size16: 1; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // MOVS\r\n (Size32: 1; Size16: 1; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // MOVS/MOVSD\r\n (Size32: 1; Size16: 1; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // CMPS/CMPSB\r\n (Size32: 1; Size16: 1; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // CMPS/CMPSW\r\n (Size32: 2; Size16: 2; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // TEST\r\n (Size32: 5; Size16: 3; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // TEST\r\n (Size32: 1; Size16: 1; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // STOS/STOSB\r\n (Size32: 1; Size16: 1; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // STOS/STOSW\r\n (Size32: 1; Size16: 1; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // LODS/LODSB\r\n (Size32: 1; Size16: 1; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // LODS/LODSW\r\n (Size32: 1; Size16: 1; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // SCAS/SCASB\r\n (Size32: 1; Size16: 1; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // SCAS/SCASD\r\n (Size32: 2; Size16: 2; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // MOV B0+rb\r\n (Size32: 2; Size16: 2; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // MOV B0+rb\r\n (Size32: 2; Size16: 2; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // MOV B0+rb\r\n (Size32: 2; Size16: 2; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // MOV B0+rb\r\n (Size32: 2; Size16: 2; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // MOV B0+rb\r\n (Size32: 2; Size16: 2; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // MOV B0+rb\r\n (Size32: 2; Size16: 2; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // MOV B0+rb\r\n (Size32: 2; Size16: 2; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // MOV B0+rb\r\n (Size32: 5; Size16: 3; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // MOV B8+rb\r\n (Size32: 5; Size16: 3; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // MOV B8+rb\r\n (Size32: 5; Size16: 3; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // MOV B8+rb\r\n (Size32: 5; Size16: 3; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // MOV B8+rb\r\n (Size32: 5; Size16: 3; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // MOV B8+rb\r\n (Size32: 5; Size16: 3; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // MOV B8+rb\r\n (Size32: 5; Size16: 3; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // MOV B8+rb\r\n (Size32: 5; Size16: 3; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // MOV B8+rb\r\n (Size32: 3; Size16: 3; ModOfs: 1; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // RCL/2 ib, etc.\r\n (Size32: 3; Size16: 3; ModOfs: 1; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // RCL/2 ib, etc.\r\n (Size32: 3; Size16: 3; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // RET\r\n (Size32: 1; Size16: 1; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // RET\r\n (Size32: 2; Size16: 2; ModOfs: 1; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // LES\r\n (Size32: 2; Size16: 2; ModOfs: 1; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // LDS\r\n (Size32: 3; Size16: 3; ModOfs: 1; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // MOV\r\n (Size32: 6; Size16: 4; ModOfs: 1; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // MOV\r\n (Size32: 4; Size16: 4; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // ENTER\r\n (Size32: 1; Size16: 1; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // LEAVE\r\n (Size32: 3; Size16: 3; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // RET\r\n (Size32: 1; Size16: 1; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // RET\r\n (Size32: 1; Size16: 1; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // INT 3\r\n (Size32: 2; Size16: 2; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // INT ib\r\n (Size32: 1; Size16: 1; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // INTO\r\n (Size32: 1; Size16: 1; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // IRET\r\n (Size32: 2; Size16: 2; ModOfs: 1; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // RCL/2, etc.\r\n (Size32: 2; Size16: 2; ModOfs: 1; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // RCL/2, etc.\r\n (Size32: 2; Size16: 2; ModOfs: 1; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // RCL/2, etc.\r\n (Size32: 2; Size16: 2; ModOfs: 1; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // RCL/2, etc.\r\n (Size32: 2; Size16: 2; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // AAM\r\n (Size32: 2; Size16: 2; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // AAD\r\n (Size32: 1; Size16: 1; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyInvalid ), //\r\n (Size32: 1; Size16: 1; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // XLAT/XLATB\r\n (Size32: 2; Size16: 2; ModOfs: 1; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // FADD, etc.\r\n (Size32: 2; Size16: 2; ModOfs: 1; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // F2XM1, etc.\r\n (Size32: 2; Size16: 2; ModOfs: 1; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // FLADD, etc.\r\n (Size32: 2; Size16: 2; ModOfs: 1; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // FCLEX, etc.\r\n (Size32: 2; Size16: 2; ModOfs: 1; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // FADD/0, etc.\r\n (Size32: 2; Size16: 2; ModOfs: 1; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // FFREE, etc.\r\n (Size32: 2; Size16: 2; ModOfs: 1; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // FADDP, etc.\r\n (Size32: 2; Size16: 2; ModOfs: 1; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // FBLD/4, etc.\r\n (Size32: 2; Size16: 2; ModOfs: 0; RelOfs: 1; UseAdr: False; Copy: CopyNormal ), // LOOPNE cb\r\n (Size32: 2; Size16: 2; ModOfs: 0; RelOfs: 1; UseAdr: False; Copy: CopyNormal ), // LOOPE cb\r\n (Size32: 2; Size16: 2; ModOfs: 0; RelOfs: 1; UseAdr: False; Copy: CopyNormal ), // LOOP cb\r\n (Size32: 2; Size16: 2; ModOfs: 0; RelOfs: 1; UseAdr: False; Copy: CopyNormal ), // JCXZ/JECXZ\r\n (Size32: 2; Size16: 2; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // IN ib\r\n (Size32: 2; Size16: 2; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // IN id\r\n (Size32: 2; Size16: 2; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // OUT ib\r\n (Size32: 2; Size16: 2; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // OUT ib\r\n (Size32: 5; Size16: 3; ModOfs: 0; RelOfs: 1; UseAdr: False; Copy: CopyNormal ), // CALL cd\r\n (Size32: 5; Size16: 3; ModOfs: 0; RelOfs: 1; UseAdr: False; Copy: CopyNormal ), // JMP cd\r\n (Size32: 7; Size16: 5; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // JMP cp\r\n (Size32: 2; Size16: 2; ModOfs: 0; RelOfs: 1; UseAdr: False; Copy: CopyNormal ), // JMP cb\r\n (Size32: 1; Size16: 1; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // IN ib\r\n (Size32: 1; Size16: 1; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // IN id\r\n (Size32: 1; Size16: 1; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // OUT\r\n (Size32: 1; Size16: 1; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // OUT\r\n (Size32: 1; Size16: 1; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyWithPrefix ), // LOCK prefix\r\n (Size32: 1; Size16: 1; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyInvalid ), //\r\n (Size32: 1; Size16: 1; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyWithPrefix ), // REPNE prefix\r\n (Size32: 1; Size16: 1; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyWithPrefix ), // REPE prefix\r\n (Size32: 1; Size16: 1; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // HLT\r\n (Size32: 1; Size16: 1; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // CMC\r\n (Size32: 0; Size16: 0; ModOfs: 1; RelOfs: 0; UseAdr: False; Copy: CopyOpF6 ), // TEST/0, DIV/6\r\n (Size32: 0; Size16: 0; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyOpF7 ), // TEST/0, DIV/6\r\n (Size32: 1; Size16: 1; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // CLC\r\n (Size32: 1; Size16: 1; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // STC\r\n (Size32: 1; Size16: 1; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // CLI\r\n (Size32: 1; Size16: 1; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // STI\r\n (Size32: 1; Size16: 1; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // CLD\r\n (Size32: 1; Size16: 1; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // STD\r\n (Size32: 2; Size16: 2; ModOfs: 1; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // DEC/1,INC/0\r\n (Size32: 2; Size16: 2; ModOfs: 1; RelOfs: 0; UseAdr: False; Copy: CopyNormal ));// CALL/2\r\n\r\nconst\r\n TwoByteOpCodes: array [0..255] of TOpCodeEntry = (\r\n // Information about OpCodes of 2 bytes\r\n (Size32: 2; Size16: 2; ModOfs: 1; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // LLDT/2, etc.\r\n (Size32: 2; Size16: 2; ModOfs: 1; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // INVLPG/7, etc.\r\n (Size32: 2; Size16: 2; ModOfs: 1; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // LAR/r\r\n (Size32: 2; Size16: 2; ModOfs: 1; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // LSL/r\r\n (Size32: 1; Size16: 1; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyInvalid ), // _04\r\n (Size32: 1; Size16: 1; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyInvalid ), // _05\r\n (Size32: 2; Size16: 2; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // CLTS\r\n (Size32: 1; Size16: 1; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyInvalid ), // _07\r\n (Size32: 2; Size16: 2; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // INVD\r\n (Size32: 2; Size16: 2; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // WBINVD\r\n (Size32: 1; Size16: 1; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyInvalid ), // _0A\r\n (Size32: 2; Size16: 2; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // UD2\r\n (Size32: 1; Size16: 1; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyInvalid ), // _0C\r\n (Size32: 1; Size16: 1; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyInvalid ), // _0D\r\n (Size32: 1; Size16: 1; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyInvalid ), // _0E\r\n (Size32: 1; Size16: 1; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyInvalid ), // _0F\r\n (Size32: 1; Size16: 1; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyInvalid ), // _10\r\n (Size32: 1; Size16: 1; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyInvalid ), // _11\r\n (Size32: 1; Size16: 1; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyInvalid ), // _12\r\n (Size32: 1; Size16: 1; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyInvalid ), // _13\r\n (Size32: 1; Size16: 1; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyInvalid ), // _14\r\n (Size32: 1; Size16: 1; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyInvalid ), // _15\r\n (Size32: 1; Size16: 1; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyInvalid ), // _16\r\n (Size32: 1; Size16: 1; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyInvalid ), // _17\r\n (Size32: 1; Size16: 1; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyInvalid ), // _18\r\n (Size32: 1; Size16: 1; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyInvalid ), // _19\r\n (Size32: 1; Size16: 1; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyInvalid ), // _1A\r\n (Size32: 1; Size16: 1; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyInvalid ), // _1B\r\n (Size32: 1; Size16: 1; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyInvalid ), // _1C\r\n (Size32: 1; Size16: 1; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyInvalid ), // _1D\r\n (Size32: 1; Size16: 1; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyInvalid ), // _1E\r\n (Size32: 1; Size16: 1; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyInvalid ), // _1F\r\n (Size32: 2; Size16: 2; ModOfs: 1; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // MOV/r\r\n (Size32: 2; Size16: 2; ModOfs: 1; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // MOV/r\r\n (Size32: 2; Size16: 2; ModOfs: 1; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // MOV/r\r\n (Size32: 2; Size16: 2; ModOfs: 1; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // MOV/r\r\n (Size32: 1; Size16: 1; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyInvalid ), // _24\r\n (Size32: 1; Size16: 1; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyInvalid ), // _25\r\n (Size32: 1; Size16: 1; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyInvalid ), // _26\r\n (Size32: 1; Size16: 1; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyInvalid ), // _27\r\n (Size32: 1; Size16: 1; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyInvalid ), // _28\r\n (Size32: 1; Size16: 1; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyInvalid ), // _29\r\n (Size32: 1; Size16: 1; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyInvalid ), // _2A\r\n (Size32: 1; Size16: 1; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyInvalid ), // _2B\r\n (Size32: 1; Size16: 1; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyInvalid ), // _2C\r\n (Size32: 1; Size16: 1; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyInvalid ), // _2D\r\n (Size32: 1; Size16: 1; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyInvalid ), // _2E\r\n (Size32: 1; Size16: 1; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyInvalid ), // _2F\r\n (Size32: 2; Size16: 2; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // WRMSR\r\n (Size32: 2; Size16: 2; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // RDTSC\r\n (Size32: 2; Size16: 2; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // RDMSR\r\n (Size32: 2; Size16: 2; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // RDPMC\r\n (Size32: 2; Size16: 2; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // SYSENTER\r\n (Size32: 2; Size16: 2; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // SYSEXIT\r\n (Size32: 1; Size16: 1; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyInvalid ), // _36\r\n (Size32: 1; Size16: 1; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyInvalid ), // _37\r\n (Size32: 1; Size16: 1; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyInvalid ), // _38\r\n (Size32: 1; Size16: 1; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyInvalid ), // _39\r\n (Size32: 1; Size16: 1; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyInvalid ), // _3A\r\n (Size32: 1; Size16: 1; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyInvalid ), // _3B\r\n (Size32: 1; Size16: 1; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyInvalid ), // _3C\r\n (Size32: 1; Size16: 1; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyInvalid ), // _3D\r\n (Size32: 1; Size16: 1; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyInvalid ), // _3E\r\n (Size32: 1; Size16: 1; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyInvalid ), // _3F\r\n (Size32: 2; Size16: 2; ModOfs: 1; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // CMOVO (0F 40)\r\n (Size32: 2; Size16: 2; ModOfs: 1; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // CMOVNO (0F 41)\r\n (Size32: 2; Size16: 2; ModOfs: 1; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // CMOVB & CMOVNE (0F 42)\r\n (Size32: 2; Size16: 2; ModOfs: 1; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // CMOVAE & CMOVNB (0F 43)\r\n (Size32: 2; Size16: 2; ModOfs: 1; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // CMOVE & CMOVZ (0F 44)\r\n (Size32: 2; Size16: 2; ModOfs: 1; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // CMOVNE & CMOVNZ (0F 45)\r\n (Size32: 2; Size16: 2; ModOfs: 1; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // CMOVBE & CMOVNA (0F 46)\r\n (Size32: 2; Size16: 2; ModOfs: 1; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // CMOVA & CMOVNBE (0F 47)\r\n (Size32: 2; Size16: 2; ModOfs: 1; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // CMOVS (0F 48)\r\n (Size32: 2; Size16: 2; ModOfs: 1; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // CMOVNS (0F 49)\r\n (Size32: 2; Size16: 2; ModOfs: 1; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // CMOVP & CMOVPE (0F 4A)\r\n (Size32: 2; Size16: 2; ModOfs: 1; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // CMOVNP & CMOVPO (0F 4B)\r\n (Size32: 2; Size16: 2; ModOfs: 1; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // CMOVL & CMOVNGE (0F 4C)\r\n (Size32: 2; Size16: 2; ModOfs: 1; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // CMOVGE & CMOVNL (0F 4D)\r\n (Size32: 2; Size16: 2; ModOfs: 1; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // CMOVLE & CMOVNG (0F 4E)\r\n (Size32: 2; Size16: 2; ModOfs: 1; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // CMOVG & CMOVNLE (0F 4F)\r\n (Size32: 1; Size16: 1; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyInvalid ), // _50\r\n (Size32: 1; Size16: 1; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyInvalid ), // _51\r\n (Size32: 1; Size16: 1; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyInvalid ), // _52\r\n (Size32: 1; Size16: 1; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyInvalid ), // _53\r\n (Size32: 1; Size16: 1; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyInvalid ), // _54\r\n (Size32: 1; Size16: 1; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyInvalid ), // _55\r\n (Size32: 1; Size16: 1; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyInvalid ), // _56\r\n (Size32: 1; Size16: 1; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyInvalid ), // _57\r\n (Size32: 1; Size16: 1; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyInvalid ), // _58\r\n (Size32: 1; Size16: 1; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyInvalid ), // _59\r\n (Size32: 1; Size16: 1; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyInvalid ), // _5A\r\n (Size32: 1; Size16: 1; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyInvalid ), // _5B\r\n (Size32: 1; Size16: 1; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyInvalid ), // _5C\r\n (Size32: 1; Size16: 1; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyInvalid ), // _5D\r\n (Size32: 1; Size16: 1; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyInvalid ), // _5E\r\n (Size32: 1; Size16: 1; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyInvalid ), // _5F\r\n (Size32: 2; Size16: 2; ModOfs: 1; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // PUNPCKLBW/r\r\n (Size32: 1; Size16: 1; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyInvalid ), // _61\r\n (Size32: 2; Size16: 2; ModOfs: 1; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // PUNPCKLWD/r\r\n (Size32: 2; Size16: 2; ModOfs: 1; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // PACKSSWB/r\r\n (Size32: 2; Size16: 2; ModOfs: 1; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // PCMPGTB/r\r\n (Size32: 2; Size16: 2; ModOfs: 1; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // PCMPGTW/r\r\n (Size32: 2; Size16: 2; ModOfs: 1; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // PCMPGTD/r\r\n (Size32: 2; Size16: 2; ModOfs: 1; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // PACKUSWB/r\r\n (Size32: 2; Size16: 2; ModOfs: 1; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // PUNPCKHBW/r\r\n (Size32: 2; Size16: 2; ModOfs: 1; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // PUNPCKHWD/r\r\n (Size32: 2; Size16: 2; ModOfs: 1; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // PUNPCKHDQ/r\r\n (Size32: 2; Size16: 2; ModOfs: 1; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // PACKSSDW/r\r\n (Size32: 1; Size16: 1; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyInvalid ), // _6C\r\n (Size32: 1; Size16: 1; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyInvalid ), // _6D\r\n (Size32: 2; Size16: 2; ModOfs: 1; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // MOVD/r\r\n (Size32: 2; Size16: 2; ModOfs: 1; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // MOV/r\r\n (Size32: 1; Size16: 1; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyInvalid ), // _70\r\n (Size32: 3; Size16: 3; ModOfs: 1; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // PSLLW/6 ib,PSRAW/4 ib,PSRLW/2 ib\r\n (Size32: 3; Size16: 3; ModOfs: 1; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // PSLLD/6 ib,PSRAD/4 ib,PSRLD/2 ib\r\n (Size32: 3; Size16: 3; ModOfs: 1; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // PSLLQ/6 ib,PSRLQ/2 ib\r\n (Size32: 2; Size16: 2; ModOfs: 1; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // PCMPEQB/r\r\n (Size32: 2; Size16: 2; ModOfs: 1; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // PCMPEQW/r\r\n (Size32: 2; Size16: 2; ModOfs: 1; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // PCMPEQD/r\r\n (Size32: 2; Size16: 2; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // EMMS\r\n (Size32: 1; Size16: 1; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyInvalid ), // _78\r\n (Size32: 1; Size16: 1; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyInvalid ), // _79\r\n (Size32: 1; Size16: 1; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyInvalid ), // _7A\r\n (Size32: 1; Size16: 1; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyInvalid ), // _7B\r\n (Size32: 1; Size16: 1; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyInvalid ), // _7C\r\n (Size32: 1; Size16: 1; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyInvalid ), // _7D\r\n (Size32: 2; Size16: 2; ModOfs: 1; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // MOVD/r\r\n (Size32: 2; Size16: 2; ModOfs: 1; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // MOV/r\r\n (Size32: 5; Size16: 3; ModOfs: 0; RelOfs: 1; UseAdr: False; Copy: CopyNormal ), // JO\r\n (Size32: 5; Size16: 3; ModOfs: 0; RelOfs: 1; UseAdr: False; Copy: CopyNormal ), // JNO\r\n (Size32: 5; Size16: 3; ModOfs: 0; RelOfs: 1; UseAdr: False; Copy: CopyNormal ), // JB,JC,JNAE\r\n (Size32: 5; Size16: 3; ModOfs: 0; RelOfs: 1; UseAdr: False; Copy: CopyNormal ), // JAE,JNB,JNC\r\n (Size32: 5; Size16: 3; ModOfs: 0; RelOfs: 1; UseAdr: False; Copy: CopyNormal ), // JE,JZ,JZ\r\n (Size32: 5; Size16: 3; ModOfs: 0; RelOfs: 1; UseAdr: False; Copy: CopyNormal ), // JNE,JNZ\r\n (Size32: 5; Size16: 3; ModOfs: 0; RelOfs: 1; UseAdr: False; Copy: CopyNormal ), // JBE,JNA\r\n (Size32: 5; Size16: 3; ModOfs: 0; RelOfs: 1; UseAdr: False; Copy: CopyNormal ), // JA,JNBE\r\n (Size32: 5; Size16: 3; ModOfs: 0; RelOfs: 1; UseAdr: False; Copy: CopyNormal ), // JS\r\n (Size32: 5; Size16: 3; ModOfs: 0; RelOfs: 1; UseAdr: False; Copy: CopyNormal ), // JNS\r\n (Size32: 5; Size16: 3; ModOfs: 0; RelOfs: 1; UseAdr: False; Copy: CopyNormal ), // JP,JPE\r\n (Size32: 5; Size16: 3; ModOfs: 0; RelOfs: 1; UseAdr: False; Copy: CopyNormal ), // JNP,JPO\r\n (Size32: 5; Size16: 3; ModOfs: 0; RelOfs: 1; UseAdr: False; Copy: CopyNormal ), // JL,NGE\r\n (Size32: 5; Size16: 3; ModOfs: 0; RelOfs: 1; UseAdr: False; Copy: CopyNormal ), // JGE,JNL\r\n (Size32: 5; Size16: 3; ModOfs: 0; RelOfs: 1; UseAdr: False; Copy: CopyNormal ), // JLE,JNG\r\n (Size32: 5; Size16: 3; ModOfs: 0; RelOfs: 1; UseAdr: False; Copy: CopyNormal ), // JG,JNLE\r\n (Size32: 2; Size16: 2; ModOfs: 1; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // CMOVO (0F 40)\r\n (Size32: 2; Size16: 2; ModOfs: 1; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // CMOVNO (0F 41)\r\n (Size32: 2; Size16: 2; ModOfs: 1; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // CMOVB & CMOVC & CMOVNAE (0F 42)\r\n (Size32: 2; Size16: 2; ModOfs: 1; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // CMOVAE & CMOVNB & CMOVNC (0F 43)\r\n (Size32: 2; Size16: 2; ModOfs: 1; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // CMOVE & CMOVZ (0F 44)\r\n (Size32: 2; Size16: 2; ModOfs: 1; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // CMOVNE & CMOVNZ (0F 45)\r\n (Size32: 2; Size16: 2; ModOfs: 1; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // CMOVBE & CMOVNA (0F 46)\r\n (Size32: 2; Size16: 2; ModOfs: 1; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // CMOVA & CMOVNBE (0F 47)\r\n (Size32: 2; Size16: 2; ModOfs: 1; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // CMOVS (0F 48)\r\n (Size32: 2; Size16: 2; ModOfs: 1; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // CMOVNS (0F 49)\r\n (Size32: 2; Size16: 2; ModOfs: 1; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // CMOVP & CMOVPE (0F 4A)\r\n (Size32: 2; Size16: 2; ModOfs: 1; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // CMOVNP & CMOVPO (0F 4B)\r\n (Size32: 2; Size16: 2; ModOfs: 1; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // CMOVL & CMOVNGE (0F 4C)\r\n (Size32: 2; Size16: 2; ModOfs: 1; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // CMOVGE & CMOVNL (0F 4D)\r\n (Size32: 2; Size16: 2; ModOfs: 1; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // CMOVLE & CMOVNG (0F 4E)\r\n (Size32: 2; Size16: 2; ModOfs: 1; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // CMOVG & CMOVNLE (0F 4F)\r\n (Size32: 2; Size16: 2; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // PUSH\r\n (Size32: 2; Size16: 2; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // POP\r\n (Size32: 2; Size16: 2; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // CPUID\r\n (Size32: 2; Size16: 2; ModOfs: 1; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // BT (0F A3)\r\n (Size32: 3; Size16: 3; ModOfs: 1; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // SHLD\r\n (Size32: 2; Size16: 2; ModOfs: 1; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // SHLD\r\n (Size32: 1; Size16: 1; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyInvalid ), // _A6\r\n (Size32: 1; Size16: 1; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyInvalid ), // _A7\r\n (Size32: 2; Size16: 2; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // PUSH\r\n (Size32: 2; Size16: 2; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // POP\r\n (Size32: 2; Size16: 2; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // RSM\r\n (Size32: 2; Size16: 2; ModOfs: 1; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // BTS (0F AB)\r\n (Size32: 3; Size16: 3; ModOfs: 1; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // SHRD\r\n (Size32: 2; Size16: 2; ModOfs: 1; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // SHRD\r\n (Size32: 2; Size16: 2; ModOfs: 1; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // FXRSTOR/1,FXSAVE/0\r\n (Size32: 2; Size16: 2; ModOfs: 1; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // IMUL (0F AF)\r\n (Size32: 2; Size16: 2; ModOfs: 1; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // CMPXCHG (0F B0)\r\n (Size32: 2; Size16: 2; ModOfs: 1; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // CMPXCHG (0F B1)\r\n (Size32: 2; Size16: 2; ModOfs: 1; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // LSS/r\r\n (Size32: 2; Size16: 2; ModOfs: 1; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // BTR (0F B3)\r\n (Size32: 2; Size16: 2; ModOfs: 1; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // LFS/r\r\n (Size32: 2; Size16: 2; ModOfs: 1; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // LGS/r\r\n (Size32: 2; Size16: 2; ModOfs: 1; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // MOVZX/r\r\n (Size32: 2; Size16: 2; ModOfs: 1; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // MOVZX/r\r\n (Size32: 1; Size16: 1; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyInvalid ), // _B8\r\n (Size32: 1; Size16: 1; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyInvalid ), // _B9\r\n (Size32: 3; Size16: 3; ModOfs: 1; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // BT & BTC & BTR & BTS (0F BA)\r\n (Size32: 2; Size16: 2; ModOfs: 1; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // BTC (0F BB)\r\n (Size32: 2; Size16: 2; ModOfs: 1; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // BSF (0F BC)\r\n (Size32: 2; Size16: 2; ModOfs: 1; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // BSR (0F BD)\r\n (Size32: 2; Size16: 2; ModOfs: 1; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // MOVSX/r\r\n (Size32: 2; Size16: 2; ModOfs: 1; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // MOVSX/r\r\n (Size32: 2; Size16: 2; ModOfs: 1; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // XADD/r\r\n (Size32: 2; Size16: 2; ModOfs: 1; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // XADD/r\r\n (Size32: 1; Size16: 1; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyInvalid ), // _C2\r\n (Size32: 1; Size16: 1; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyInvalid ), // _C3\r\n (Size32: 1; Size16: 1; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyInvalid ), // _C4\r\n (Size32: 1; Size16: 1; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyInvalid ), // _C5\r\n (Size32: 1; Size16: 1; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyInvalid ), // _C6\r\n (Size32: 2; Size16: 2; ModOfs: 1; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // CMPXCHG8B (0F C7)\r\n (Size32: 2; Size16: 2; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // BSWAP 0F C8 + rd\r\n (Size32: 2; Size16: 2; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // BSWAP 0F C8 + rd\r\n (Size32: 2; Size16: 2; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // BSWAP 0F C8 + rd\r\n (Size32: 2; Size16: 2; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // BSWAP 0F C8 + rd\r\n (Size32: 2; Size16: 2; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // BSWAP 0F C8 + rd\r\n (Size32: 2; Size16: 2; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // BSWAP 0F C8 + rd\r\n (Size32: 2; Size16: 2; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // BSWAP 0F C8 + rd\r\n (Size32: 2; Size16: 2; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // BSWAP 0F C8 + rd\r\n (Size32: 1; Size16: 1; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyInvalid ), // _D0\r\n (Size32: 2; Size16: 2; ModOfs: 1; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // PSRLW/r\r\n (Size32: 2; Size16: 2; ModOfs: 1; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // PSRLD/r\r\n (Size32: 2; Size16: 2; ModOfs: 1; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // PSRLQ/r\r\n (Size32: 1; Size16: 1; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyInvalid ), // _D4\r\n (Size32: 2; Size16: 2; ModOfs: 1; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // PMULLW/r\r\n (Size32: 1; Size16: 1; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyInvalid ), // _D6\r\n (Size32: 1; Size16: 1; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyInvalid ), // _D7\r\n (Size32: 2; Size16: 2; ModOfs: 1; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // PSUBUSB/r\r\n (Size32: 2; Size16: 2; ModOfs: 1; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // PSUBUSW/r\r\n (Size32: 1; Size16: 1; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyInvalid ), // _DA\r\n (Size32: 2; Size16: 2; ModOfs: 1; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // PAND/r\r\n (Size32: 2; Size16: 2; ModOfs: 1; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // PADDUSB/r\r\n (Size32: 2; Size16: 2; ModOfs: 1; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // PADDUSW/r\r\n (Size32: 1; Size16: 1; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyInvalid ), // _DE\r\n (Size32: 2; Size16: 2; ModOfs: 1; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // PANDN/r\r\n (Size32: 1; Size16: 1; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyInvalid ), // _E0\r\n (Size32: 2; Size16: 2; ModOfs: 1; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // PSRAW/r\r\n (Size32: 2; Size16: 2; ModOfs: 1; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // PSRAD/r\r\n (Size32: 1; Size16: 1; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyInvalid ), // _E3\r\n (Size32: 1; Size16: 1; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyInvalid ), // _E4\r\n (Size32: 2; Size16: 2; ModOfs: 1; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // PMULHW/r\r\n (Size32: 1; Size16: 1; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyInvalid ), // _E6\r\n (Size32: 1; Size16: 1; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyInvalid ), // _E7\r\n (Size32: 2; Size16: 2; ModOfs: 1; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // PSUBB/r\r\n (Size32: 2; Size16: 2; ModOfs: 1; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // PSUBW/r\r\n (Size32: 1; Size16: 1; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyInvalid ), // _EA\r\n (Size32: 2; Size16: 2; ModOfs: 1; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // POR/r\r\n (Size32: 2; Size16: 2; ModOfs: 1; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // PADDSB/r\r\n (Size32: 2; Size16: 2; ModOfs: 1; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // PADDSW/r\r\n (Size32: 1; Size16: 1; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyInvalid ), // _EE\r\n (Size32: 2; Size16: 2; ModOfs: 1; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // PXOR/r\r\n (Size32: 1; Size16: 1; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyInvalid ), // _F0\r\n (Size32: 2; Size16: 2; ModOfs: 1; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // PSLLW/r\r\n (Size32: 2; Size16: 2; ModOfs: 1; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // PSLLD/r\r\n (Size32: 2; Size16: 2; ModOfs: 1; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // PSLLQ/r\r\n (Size32: 1; Size16: 1; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyInvalid ), // _F4\r\n (Size32: 2; Size16: 2; ModOfs: 1; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // PMADDWD/r\r\n (Size32: 1; Size16: 1; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyInvalid ), // _F6\r\n (Size32: 1; Size16: 1; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyInvalid ), // _F7\r\n (Size32: 2; Size16: 2; ModOfs: 1; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // PSUBB/r\r\n (Size32: 2; Size16: 2; ModOfs: 1; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // PSUBW/r\r\n (Size32: 2; Size16: 2; ModOfs: 1; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // PSUBD/r\r\n (Size32: 1; Size16: 1; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyInvalid ), // _FB\r\n (Size32: 2; Size16: 2; ModOfs: 1; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // PADDB/r\r\n (Size32: 2; Size16: 2; ModOfs: 1; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // PADDW/r\r\n (Size32: 2; Size16: 2; ModOfs: 1; RelOfs: 0; UseAdr: False; Copy: CopyNormal ), // PADDD/r\r\n (Size32: 1; Size16: 1; ModOfs: 0; RelOfs: 0; UseAdr: False; Copy: CopyInvalid ));// _FF\r\n\r\nconst\r\n ModRMSizes: array [0..255] of ShortInt = (\r\n { Contains the number of extra bytes for each possible ModR/M byte.\r\n A negative value means that the instruction also uses a SIB-byte }\r\n 0,0,0,0, -1,4,0,0, 0,0,0,0, -1,4,0,0,\r\n 0,0,0,0, -1,4,0,0, 0,0,0,0, -1,4,0,0,\r\n 0,0,0,0, -1,4,0,0, 0,0,0,0, -1,4,0,0,\r\n 0,0,0,0, -1,4,0,0, 0,0,0,0, -1,4,0,0,\r\n 1,1,1,1, 2,1,1,1, 1,1,1,1, 2,1,1,1,\r\n 1,1,1,1, 2,1,1,1, 1,1,1,1, 2,1,1,1,\r\n 1,1,1,1, 2,1,1,1, 1,1,1,1, 2,1,1,1,\r\n 1,1,1,1, 2,1,1,1, 1,1,1,1, 2,1,1,1,\r\n 4,4,4,4, 5,4,4,4, 4,4,4,4, 5,4,4,4,\r\n 4,4,4,4, 5,4,4,4, 4,4,4,4, 5,4,4,4,\r\n 4,4,4,4, 5,4,4,4, 4,4,4,4, 5,4,4,4,\r\n 4,4,4,4, 5,4,4,4, 4,4,4,4, 5,4,4,4,\r\n 0,0,0,0, 0,0,0,0, 0,0,0,0, 0,0,0,0,\r\n 0,0,0,0, 0,0,0,0, 0,0,0,0, 0,0,0,0,\r\n 0,0,0,0, 0,0,0,0, 0,0,0,0, 0,0,0,0,\r\n 0,0,0,0, 0,0,0,0, 0,0,0,0, 0,0,0,0);\r\n\r\nimplementation\r\n\r\nuses SysUtils;\r\n\r\n\r\n{ TCopyInstructionProc functions used for copying instructions: }\r\n\r\nfunction CopyNormal(const Intercepts: PIntercepts; Entry: POpCodeEntry;\r\n Src, Dst: Pointer): Pointer;\r\n{ Default function for copying instructions }\r\nvar\r\n FixedSize, Size, ModRMSize: Integer;\r\n ModRM, SIB: Byte;\r\n P: PByte;\r\nbegin\r\n { Determine the number of fixed bytes used by the instruction }\r\n if Entry.UseAdr then\r\n if Intercepts.Use16BitAddress then\r\n FixedSize := Entry.Size16\r\n else\r\n FixedSize := Entry.Size32\r\n else\r\n if Intercepts.Use16BitOperand then\r\n FixedSize := Entry.Size16\r\n else\r\n FixedSize := Entry.Size32;\r\n { Determine the size of the instruction }\r\n Size := FixedSize;\r\n if Entry.ModOfs > 0 then begin\r\n { The instruction uses a ModR/M byte }\r\n P := Src;\r\n Inc(P,Entry.ModOfs);\r\n ModRM := P^;\r\n { Determine extra bytes used by ModR/M }\r\n ModRMSize := ModRMSizes[ModRM];\r\n if ModRMSize < 0 then begin\r\n { The instruction also uses a SIB-byte }\r\n ModRMSize := -ModRMSize;\r\n Inc(P);\r\n SIB := P^;\r\n { If the Base of the SIB-byte (lower 3 bits) have value 5, the instruction\r\n may use 1 or 4 extra bytes, depending on ModR/M }\r\n if (SIB and $07) = 5 then\r\n case (ModRM and $C0) of\r\n $00, $80: Inc(Size,4);\r\n $40 : Inc(Size);\r\n end;\r\n end;\r\n Inc(Size,ModRMSize);\r\n end;\r\n { Copy the calculated number of bytes }\r\n Move(Src^,Dst^,Size);\r\n if Entry.RelOfs <> 0 then\r\n { The instruction uses a relative offset, for example \"je -500\". We cannot\r\n just copy this instruction to a new address, because the code at the\r\n new address -500 bytes is incorrect (see comment on AdjustTarget method) }\r\n Intercepts.AdjustTarget(Src,Dst,FixedSize,Entry.RelOfs);\r\n Result := Src;\r\n Inc(PByte(Result),Size);\r\nend;\r\n\r\nfunction Copy2ByteOpCode(const Intercepts: PIntercepts; Entry: POpCodeEntry;\r\n Src, Dst: Pointer): Pointer;\r\n{ Function for copying 2 byte long OpCodes. The first OpCode byte is $0F }\r\nbegin\r\n { Copy the first OpCode byte (that is, the $0F prefix) }\r\n CopyNormal(Intercepts,Entry,Src,Dst);\r\n Inc(PByte(Src)); Inc(PByte(Dst));\r\n { Copy the remainder using the TwoByteOpCodes instruction table }\r\n Entry := @TwoByteOpCodes[PByte(Src)^];\r\n Result := Entry.Copy(Intercepts,Entry,Src,Dst);\r\nend;\r\n\r\nfunction CopyWithPrefix(const Intercepts: PIntercepts; Entry: POpCodeEntry;\r\n Src, Dst: Pointer): Pointer;\r\n{ Function for copying instructions that contain prefix bytes }\r\nbegin\r\n { Copy the prefix byte the normal way }\r\n CopyNormal(Intercepts,Entry,Src,Dst);\r\n Inc(PByte(Src)); Inc(PByte(Dst));\r\n { Copy the remainder using the normal OpCode instruction table }\r\n Entry := @OneByteOpCodes[PByte(Src)^];\r\n Result := Entry.Copy(Intercepts,Entry,Src,Dst);\r\nend;\r\n\r\nfunction CopyWith16BitOperand(const Intercepts: PIntercepts; Entry: POpCodeEntry;\r\n Src, Dst: Pointer): Pointer;\r\n{ Function for copying instructions that contain a prefix instructing to use\r\n 16-bit operands }\r\nbegin\r\n Intercepts.Use16BitOperand := True;\r\n Result := CopyWithPrefix(Intercepts,Entry,Src,Dst);\r\nend;\r\n\r\nfunction CopyWith16BitAddress(const Intercepts: PIntercepts; Entry: POpCodeEntry;\r\n Src, Dst: Pointer): Pointer;\r\n{ Function for copying instructions that contain a prefix instructing to use\r\n 16-bit addresses }\r\nbegin\r\n Intercepts.Use16BitAddress := True;\r\n Result := CopyWithPrefix(Intercepts,Entry,Src,Dst);\r\nend;\r\n\r\nfunction CopyOpF6(const Intercepts: PIntercepts; Entry: POpCodeEntry;\r\n Src, Dst: Pointer): Pointer;\r\n{ Function for copying instructions with OpCode $F6 (test, div, idiv, mul,\r\n imul, not and neg using a 8-bit operand) }\r\nconst\r\n E1: TOpCodeEntry = (Size32: 3; Size16: 3; ModOfs: 1; RelOfs: 0;\r\n UseAdr: False; Copy: CopyNormal);\r\n E2: TOpCodeEntry = (Size32: 2; Size16: 2; ModOfs: 1; RelOfs: 0;\r\n UseAdr: False; Copy: CopyNormal);\r\nbegin\r\n { $F6-OpCodes are 2 or 3 bytes in size, depending on bits 3-5 of the ModR/M\r\n byte. If these bits are all 0, the instruction is 3 bytes, otherwise it\r\n is 2 bytes in size }\r\n Inc(PByte(Src));\r\n if PByte(Src)^ and $38 = 0 then\r\n Entry := @E1\r\n else\r\n Entry := @E2;\r\n Dec(PByte(Src));\r\n Result := Entry.Copy(Intercepts,Entry,Src,Dst);\r\nend;\r\n\r\nfunction CopyOpF7(const Intercepts: PIntercepts; Entry: POpCodeEntry;\r\n Src, Dst: Pointer): Pointer;\r\n{ Function for copying instructions with OpCode $F7 (test, div, idiv, mul,\r\n imul, not and neg using a16/32-bit operand) }\r\nconst\r\n E1: TOpCodeEntry = (Size32: 6; Size16: 4; ModOfs: 1; RelOfs: 0;\r\n UseAdr: False; Copy: CopyNormal);\r\n E2: TOpCodeEntry = (Size32: 2; Size16: 2; ModOfs: 1; RelOfs: 0;\r\n UseAdr: False; Copy: CopyNormal);\r\nbegin\r\n { $F6-OpCodes are 2, 4 or 6 bytes in size, depending on bits 3-5 of the ModR/M\r\n byte. If these bits are all 0, the instruction is 6 bytes in 32-bit mode or\r\n 4 bytes in 16-bit mode. Otherwise it is 2 bytes in size }\r\n Inc(PByte(Src));\r\n if PByte(Src)^ and $38 = 0 then\r\n Entry := @E1\r\n else\r\n Entry := @E2;\r\n Dec(PByte(Src));\r\n Result := Entry.Copy(Intercepts,Entry,Src,Dst);\r\nend;\r\n\r\nfunction CopyInvalid(const Intercepts: PIntercepts; Entry: POpCodeEntry;\r\n Src, Dst: Pointer): Pointer;\r\n{ Called when trying to copy an invalid OpCode. Just skips the OpCode. }\r\nbegin\r\n Assert(False,'Invalid OpCode');\r\n Result := Src;\r\n Inc(PByte(Result));\r\nend;\r\n\r\n{ TIntercepts }\r\n\r\nprocedure TIntercepts.AdjustTarget(const Src, Dst: Pointer; const OpCodeSize,\r\n TargetOffset: Integer);\r\nvar\r\n TargetSize, OrigOffset, NewOffset: Integer;\r\n TargetAddr: Pointer;\r\nbegin\r\n { Example:\r\n Src: $00005000 jmp -$1000 ---> Dst: $00007000 jmp -$1000\r\n Dst must be adjusted to:\r\n Dst: $00007000 jmp -$3000\r\n The parameters are:\r\n Src: $00005000\r\n Dst: $00007000\r\n OpCodeSize: 5 (size of a relative JMP instruction)\r\n TargetOffset: 1 (the target is located 1 byte after the OpCode)\r\n First, calculate then target size (the size in bytes of the relative\r\n target) and the corresponding address of the target ($00007001 in this\r\n example). }\r\n TargetSize := OpCodeSize - TargetOffset;\r\n TargetAddr := Dst;\r\n Inc(PByte(TargetAddr),TargetOffset);\r\n { Get the original target value (-$1000 in the example). This depends on the\r\n size of the target, either 1, 2 or 4 bytes. }\r\n case TargetSize of\r\n 1: OrigOffset := PShortInt(TargetAddr)^;\r\n 2: OrigOffset := PSmallInt(TargetAddr)^;\r\n 4: OrigOffset := PLongInt(TargetAddr)^;\r\n else\r\n begin\r\n Assert(False);\r\n OrigOffset := 0;\r\n end;\r\n end;\r\n { Calculate the new target value based on the original value and the\r\n difference between the Src and Dst location. In the example, the new value\r\n should be -$1000 - ($00007000 - $00005000) = -$3000.\r\n The new value could potentionally fall outside the range of the target.\r\n This is checked with assertions. }\r\n NewOffset := OrigOffset - (Integer(Dst) - Integer(Src));\r\n case TargetSize of\r\n 1: begin\r\n Assert((NewOffset >= Low(ShortInt)) and (NewOffset <= High(ShortInt)));\r\n PShortInt(TargetAddr)^ := NewOffset;\r\n end;\r\n 2: begin\r\n Assert((NewOffset >= Low(SmallInt)) and (NewOffset <= High(SmallInt)));\r\n PSmallInt(TargetAddr)^ := NewOffset;\r\n end;\r\n 4: PLongInt(TargetAddr)^ := NewOffset;\r\n end;\r\nend;\r\n\r\nfunction TIntercepts.CopyInstruction(Src, Dst: Pointer): Pointer;\r\nvar\r\n Entry: POpCodeEntry;\r\nbegin\r\n Assert(Assigned(Src));\r\n if not Assigned(Dst) then\r\n Dst := @FScratch;\r\n { Default to 32-bit operands and addresses }\r\n FUse16BitAddress := False;\r\n FUse16BitOperand := False;\r\n { Get information about the OpCode at Src }\r\n Entry := @OneByteOpCodes[PByte(Src)^];\r\n Result := Entry.Copy(@Self,Entry,Src,Dst);\r\nend;\r\n\r\nfunction NewIntercepts:TIntercepts;\r\n//var\r\n// t:TIntercepts;\r\nbegin\r\n //Result^ := (TIntercepts.Create);\r\n //New(Result,Create);\r\n //t := TIntercepts.Create(Application);\r\n //Result := @t;\r\n Result := TIntercepts.Create(nil {Application});\r\n Result.FProcess := GetCurrentProcess;\r\nend;\r\n\r\nfunction TIntercepts.CreateIntercept(TargetProc, InterceptProc: Pointer): Pointer;\r\nbegin\r\n Assert(Assigned(TargetProc) and Assigned(InterceptProc));\r\n GetMem(Result,TrampolineSize);\r\n TargetProc := GetFinalCode(TargetProc);\r\n InterceptProc := GetFinalCode(InterceptProc);\r\n if not InsertIntercept(TargetProc, Result, InterceptProc) then\r\n begin\r\n FreeMem(Result);\r\n Result := nil;\r\n end;\r\nend;\r\n\r\ndestructor TIntercepts.Destroy;\r\nbegin\r\n FillChar(FScratch, Length(FScratch),0);\r\n inherited;\r\nend;\r\n\r\nfunction TIntercepts.GetFinalCode(const Proc: Pointer;\r\n const SkipJumps: Boolean): Pointer;\r\nbegin\r\n Assert(Assigned(Proc));\r\n Result := Proc;\r\n if Assigned(Result) then begin\r\n if PWord(Result)^ = opJmpIndirect then begin\r\n { The assembly code of Proc has the following format:\r\n jmp dword ptr []\r\n This means that Proc uses a DLL import table. We need to get the\r\n address of the actual routine.\r\n First, retrieve the address of the import table entry by dereferencing\r\n the pointer after the JMP instruction () }\r\n Inc(PWord(Result));\r\n Result := PPointer(Result)^;\r\n { Next, derefence this pointer again to get to the actual implementation.\r\n That is, the address at the import table entry, points to the actual\r\n implementation }\r\n Result := PPointer(Result)^;\r\n end else if (PByte(Result)^ = opJmpRelative) and SkipJumps then begin\r\n { The assembly code of Proc has the following format:\r\n jmp \r\n When this method is called with SkipJumps=True, we need to get the\r\n actual address this instruction jumps to. To get this address, we\r\n need to increment the pointer bytes, plus\r\n the size of the JMP-instruction itself (which is 5 bytes).\r\n Note that you need to typecast the Result to a PByte in order to\r\n advance the pointer a certain number of bytes. }\r\n Inc(PByte(Result));\r\n Inc(PByte(Result),PInteger(Result)^ + SizeOfJmp);\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TIntercepts.InsertIntercept(const TargetProc, Trampoline,\r\n InterceptProc: Pointer): Boolean;\r\nvar\r\n P, Q: Pointer;\r\n BytesToCopy, BytesCopied: Integer;\r\n //OrigTrampolineAccess,\r\n OrigTargetProcAccess: Longword;\r\nbegin\r\n Result := False;\r\n P := TargetProc;\r\n BytesToCopy := 0;\r\n while BytesToCopy < SizeOfJmp do\r\n begin\r\n { Calculate the size of the assembly instructions to be copied to the\r\n trampoline by dummy-copying assembly instructions until at least 5 bytes\r\n (SizeOfJmp) have been processed }\r\n Q := P;\r\n P := CopyInstruction(P,nil);\r\n BytesToCopy := Integer(P) - Integer(TargetProc);\r\n { When the OpCode is a JMP or RET instruction, we do not need to copy\r\n more instructions (as they will never be executed) }\r\n if PByte(Q)^ in [opJmpRelative,opRetPop,opRet] then\r\n Break;\r\n if (PWord(Q)^ = opJmpEax) or (PWord(Q)^ = opJmpIndirect) then\r\n Break;\r\n if PByte(Q)^ in [opPreES,opPreCS,opPreSS,opPreDS,opPreFS,opPreGS] then begin\r\n Inc(PByte(Q));\r\n if PWord(Q)^ = opJmpIndirect then\r\n Break;\r\n end;\r\n end;\r\n { We need at least 5 bytes to insert a JMP instruction }\r\n if BytesToCopy < SizeOfJmp then\r\n Exit\r\n { Don't copy beyond the trampoline }\r\n else if BytesToCopy > (TrampolineSize - SizeOfJmp - 1) then\r\n Exit;\r\n { Enable write access to original routine and trampoline }\r\n OrigTargetProcAccess := 0;\r\n //OrigTrampolineAccess :=\r\n SetPermission(Trampoline, TrampolineSize, PAGE_EXECUTE_READWRITE);\r\n try\r\n OrigTargetProcAccess := SetPermission(TargetProc, BytesToCopy, PAGE_EXECUTE_READWRITE);\r\n { Copy first few original instructions to trampoline }\r\n BytesCopied := 0;\r\n P := TargetProc;\r\n Q := Trampoline;\r\n while BytesCopied < BytesToCopy do\r\n begin\r\n P := CopyInstruction(P,Q);\r\n BytesCopied := Integer(P) - Integer(TargetProc);\r\n Q := Trampoline;\r\n Inc(PByte(Q),BytesCopied);\r\n end;\r\n if BytesCopied <> BytesToCopy then\r\n Exit;\r\n { Add an unconditional jump to the trampoline (Q) to jump to the remainder\r\n of the original routine (P) }\r\n if not InsertJump(Q,P,SizeOfJmp) then\r\n Exit;\r\n { Set the last byte of the trampoline to the size of the copied code. This\r\n byte is later used by RemoveIntercept the restore the situation. }\r\n Q := Trampoline;\r\n Inc(PByte(Q),TrampolineSize - 1);\r\n PByte(Q)^ := BytesCopied;\r\n { Put an unconditional jump at the beginning of to the original routine\r\n (TargetProc) to jump to the Intercept routine (InterceptProc) }\r\n Result := InsertJump(TargetProc, InterceptProc, BytesCopied);\r\n finally\r\n { Restore permissions }\r\n //SetPermission(Trampoline,TrampolineSize,OrigTrampolineAccess); //keep full execute + read + write rights for whole page!\r\n SetPermission(TargetProc,BytesToCopy,OrigTargetProcAccess);\r\n end;\r\nend;\r\n\r\nfunction TIntercepts.InsertJump(Code, Target: Pointer;\r\n Size: Integer): Boolean;\r\nbegin\r\n Result := (Size >= SizeOfJmp);\r\n if Result then\r\n begin\r\n { Add a relative JMP instruction (jmp ) }\r\n PByte(Code)^ := opJmpRelative;\r\n Inc(PByte(Code));\r\n { Set the to Target - (Code + SizeOfJmp) }\r\n PInteger(Code)^ := Integer(Target) - (Integer(Code) - 1 + SizeOfJmp);\r\n Inc(PInteger(Code));\r\n Dec(Size,SizeOfJmp);\r\n { Fill the remainder of Code with \"int 3\" instructions. These instructions\r\n should never be executed, but in case they do anyway, \"int 3\" is used\r\n as a debug breakpoint so control is passed to the debugger }\r\n while Size > 0 do\r\n begin\r\n PByte(Code)^ := opInt3;\r\n Inc(PByte(Code));\r\n Dec(Size);\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TIntercepts.RemoveIntercept(Trampoline,\r\n InterceptProc: Pointer): Boolean;\r\nvar\r\n CodeSize, Target, BytesCopied: Integer;\r\n OrigProcAccess: Longword;\r\n P, Q, Src, Dst: PByte;\r\nbegin\r\n Trampoline := GetFinalCode(Trampoline,True);\r\n InterceptProc := GetFinalCode(InterceptProc);\r\n { Retrieve codesize from last byte of trampoline }\r\n P := Trampoline;\r\n Inc(P,TrampolineSize - 1);\r\n CodeSize := P^;\r\n Result := (CodeSize > 0) and (CodeSize < TrampolineSize - 1);\r\n if Result then begin\r\n { The last instruction of the trampoline must be a JMP to the remainder of\r\n the original routine}\r\n P := Trampoline;\r\n Inc(P,CodeSize);\r\n Result := (P^ = opJmpRelative);\r\n if Result then begin\r\n { Retrieve jump target }\r\n Inc(P);\r\n Target := PInteger(P)^;\r\n { Set P to the beginning of the original routine }\r\n P := Trampoline;\r\n Inc(P,Target + SizeOfJmp);\r\n { The original routine must start with a JMP to the Intercept }\r\n Result := (P^ = opJmpRelative);\r\n if Result then begin\r\n { Retrieve jump target }\r\n Inc(P);\r\n Target := PInteger(P)^;\r\n Dec(P);\r\n { Check that the target points to the Intercept }\r\n Q := P;\r\n Inc(Q,Target + SizeOfJmp);\r\n Result := (Q = InterceptProc);\r\n if Result then begin\r\n { Enable write access to original routine to remove Intercept }\r\n OrigProcAccess := SetPermission(P,CodeSize,PAGE_EXECUTE_READWRITE);\r\n try\r\n { Copy instructions from trampoline back to original routine }\r\n BytesCopied := 0;\r\n Src := Trampoline;\r\n Dst := P;\r\n while BytesCopied < CodeSize do begin\r\n Src := CopyInstruction(Src,Dst);\r\n BytesCopied := Integer(Src) - Integer(Trampoline);\r\n Dst := P;\r\n Inc(Dst,BytesCopied);\r\n end;\r\n Result := (BytesCopied = CodeSize);\r\n finally\r\n SetPermission(P,CodeSize,OrigProcAccess);\r\n end;\r\n end;\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TIntercepts.SetPermission(const Code: Pointer; const Size: Integer;\r\n const Permission: Longword): Longword;\r\nbegin\r\n Assert(Assigned(Code) and (Size > 0));\r\n { Flush the instruction cache so changes to the code page are effective\r\n immediately }\r\n if Permission <> 0 then\r\n if FlushInstructionCache(FProcess,Code,Size) then\r\n VirtualProtect(Code,Size,Permission,Longword(Result));\r\nend;\r\n\r\n{ Main Intercepts functions }\r\n\r\nfunction InterceptCreate(const TargetProc, InterceptProc: Pointer): Pointer;\r\nvar\r\n Intercepts: TIntercepts;\r\nbegin\r\n if Assigned(TargetProc) and Assigned(InterceptProc) then\r\n begin\r\n { Intercepts only work on NT based operating systems (Windows NT, 2000, XP) }\r\n //if Winver >= wvNT {= VER_PLATFORM_WIN32_NT} then\r\n begin\r\n Intercepts := NewIntercepts;\r\n try\r\n Result := Intercepts.CreateIntercept(TargetProc, InterceptProc);\r\n finally\r\n Intercepts.Free;\r\n end;\r\n end\r\n //else Result := nil;\r\n end else\r\n Result := nil;\r\n\r\n if Result = nil then\r\n Raise Exception.CreateFmt('Could not intercept procedure %p!',[TargetProc]);\r\nend;\r\n\r\nfunction InterceptRemove(var Trampoline: Pointer; const InterceptProc: Pointer): Boolean;\r\nvar\r\n Intercepts: TIntercepts;\r\nbegin\r\n if Assigned(Trampoline) and Assigned(InterceptProc) then begin\r\n Intercepts := NewIntercepts;\r\n try\r\n Result := Intercepts.RemoveIntercept(Trampoline,InterceptProc);\r\n FreeMem(Trampoline);\r\n Trampoline := nil;\r\n finally\r\n Intercepts.Free;\r\n end;\r\n end else\r\n Result := False;\r\nend;\r\n\r\nend.\r\n" }, { "path": "External/SynEdit/Source/Contributors.txt", "content": "Contributors to the SynEdit project:\r\n\r\n Ackbar, Andre Mens, Andy Colson, Anthony Steele, Arentjan Banck, Aaron Chan,\r\n Bruno Mikkelsen, Colin Laplace, Daniel Parnell, David H. Muir, Dean Harmon,\r\n Eden Kirin, Eric Grange, Erik B. Berry, Falko Jens Wagner, Flvio Etrusco, \r\n James D. Richardson, Jan Fiala, Jeff Rafter, Johan Visser, Jordan Russell, \r\n Jorg Jans, Jonathan Halterman, Kirys, Lasse Vagsather Karlsen, Leon Brown, \r\n Lorant Toth, Mal Hrz, Marko Njezic, Martin Pley, Massimo Maria Ghisalberti, \r\n Mattias Gaertner, Michael Beck, Michael Hieke, Mike Gibbard,\r\n Morten J. Skovrup, Murad Kakabayev, Pieter Polak, Primoz Gabrijelcic,\r\n Roman Silin, Ruggero Bandera, Satya, Stefan van As, Steve Sutherland,\r\n Sven Blankenberg, Tony De Buys, Woo Young Bum, Roman Kassebaum\r\n\r\n\r\nMost of the files in the SynEdit package are based on mwEdit version 0.92a.\r\nmwEdit was started by Martin Waldenburg in 1998, but is no longer\r\nactively maintained.\r\n\r\nContributors to the mwEdit project (up to version 0.92a, in the order\r\nof appearance):\r\n\r\n Martin Waldenburg\r\n\r\n Woo Young Bum, Angus Johnson, Michael Trier, James Jacobson,\r\n Thomas Kurz, Primoz Gabrijelcic, Michael Beck, Andy Jeffries,\r\n Edward Kreis, Brad Stowers, Willo van der Merwe, Cyrille de Brebisson,\r\n Carlos Wijders, Kees van Spelde, Bernt Levinsson, Ted Berg,\r\n Igor Shitikov, Michael Hieke, Dragan Grbic, Lucifer, Olivier Deckmyn,\r\n Luiz C. Vaz de Brito, Hideo Koiso, Theodoros Bebekis, Albert Research,\r\n Tony de Buys, Greg Chapman, Jeff Corbets, Heedong Lim,\r\n Kieran McNamara, Martijn van der Kooij, Jan Jacobs, ArentJan Banck,\r\n Alexander Reiter, xueyu, Sebastian J. Gross, Stefan van As,\r\n Vladimir Kuznetsov, David Muir, Nick Hoddinott, Hanai Tohru,\r\n Winfried Schttler, Hiep Ma, Daniel Rodrguez Herrera, Nur Ismail,\r\n Peter Adam, Wynand Breytenbach, Milan Nikolic, Robert Persson,\r\n John T. Truchon, Igor P. Zenkov, Odilon Nelson, Martijn Tonies,\r\n Eden Kirin, Max Horvth, riceball, Ewart Nijburg, Nils Springob,\r\n Jeff D. Smith, Pavel Krehula, Peter Wolters\r\n\r\n$Id: Contributors.txt,v 1.20.2.2 2004/12/10 15:31:01 maelh Exp $\r\n" }, { "path": "External/SynEdit/Source/QSynAutoCorrect.pas", "content": "unit QSynAutoCorrect;\r\n\r\n{$DEFINE SYN_CLX}\r\n{$DEFINE QSYNAUTOCORRECT}\r\n\r\n{$I SynAutoCorrect.pas}\r\n" }, { "path": "External/SynEdit/Source/QSynAutoCorrectEditor.dfm", "content": "object frmAutoCorrectEditor: TfrmAutoCorrectEditor\r\n Left = 210\r\n Top = 111\r\n Caption = 'AutoCorrection Items...'\r\n ClientHeight = 377\r\n ClientWidth = 521\r\n Color = clBtnFace\r\n Font.Charset = DEFAULT_CHARSET\r\n Font.Color = clWindowText\r\n Font.Height = -11\r\n Font.Name = 'MS Sans Serif'\r\n Font.Style = []\r\n OldCreateOrder = True\r\n Position = poScreenCenter\r\n ShowHint = True\r\n OnCreate = FormCreate\r\n OnPaint = FormPaint\r\n OnShow = FormShow\r\n PixelsPerInch = 96\r\n TextHeight = 13\r\n object lblLabel1: TLabel\r\n Left = 16\r\n Top = 56\r\n Width = 38\r\n Height = 13\r\n Caption = '&Original:'\r\n FocusControl = lbxItems\r\n end\r\n object lblLabel2: TLabel\r\n Left = 252\r\n Top = 56\r\n Width = 56\r\n Height = 13\r\n Caption = '&Corrections:'\r\n FocusControl = lbxItems\r\n end\r\n object btnAdd: TSpeedButton\r\n Left = 16\r\n Top = 16\r\n Width = 65\r\n Height = 23\r\n Hint = 'Adds a new item to the auto-correction list.'\r\n Caption = ' &Add'\r\n Glyph.Data = {\r\n 36030000424D3603000000000000360000002800000010000000100000000100\r\n 18000000000000030000C40E0000C40E00000000000000000000008080008080\r\n 0080800080800080800080800080800080800080800080800080800080800080\r\n 8000808000808000808000808000808080808080808080808080808080808080\r\n 8080808080808080808080808080808080808080808080808080008080000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 00000000000000808080008080000000FFFFFF00FFFFFFFFFF00FFFFFFFFFF00\r\n FFFFFFFFFF00FFFF000000000000FFFFFF00FFFF000000808080008080000000\r\n 00FFFFFFFFFF00FFFFFFFFFF00FFFFFFFFFF00FFFFFFFFFF000000C0C0C00000\r\n 00FFFFFF000000808080008080000000FFFFFF00FFFFFFFFFF00FFFFFFFFFF00\r\n FFFFFFFFFF00FFFF00000000FFFFC0C0C0000000000000808080008080000000\r\n 00FFFFFFFFFF00FFFFFFFFFF00FFFFFFFFFF00FFFFFFFFFF0000000000000000\r\n 00000000000000808080FFFFFF000000FFFFFF80808000FFFFFFFFFF00FFFFFF\r\n FFFF00FFFF00FFFFFFFFFF00FFFFFFFFFF00FFFF00000080808080808000FFFF\r\n 00FFFF808080FFFFFF00FFFF80808000FFFFFFFFFFFFFFFF00FFFFFFFFFF00FF\r\n FFFFFFFF000000808080008080808080FFFFFF80808000FFFF80808000FFFFFF\r\n FFFF00FFFF00FFFFFFFFFF00FFFFFFFFFF00FFFF000000808080808080808080\r\n 808080FFFFFF808080FFFFFF00FFFFFFFFFF00FFFFFFFFFF00FFFFFFFFFF00FF\r\n FFFFFFFF000000808080FFFFFF00FFFF80808000FFFFFFFFFF80808080808080\r\n 8080808080000000000000000000000000000000000000008080008080808080\r\n 00FFFF80808000FFFF80808000FFFF0080800080800080800080800080800080\r\n 8000808000808000808080808000FFFF008080808080FFFFFF00808080808000\r\n FFFF00808000808000808000808000808000808000808000808000FFFF008080\r\n 00808080808000FFFF0080800080808080800080800080800080800080800080\r\n 80008080008080008080008080008080008080808080FFFFFF00808000808000\r\n 8080008080008080008080008080008080008080008080008080}\r\n OnClick = btnAddClick\r\n end\r\n object btnDelete: TSpeedButton\r\n Left = 88\r\n Top = 16\r\n Width = 65\r\n Height = 23\r\n Hint = 'Removes the selected item from the auto-correction list.'\r\n Caption = '&Delete'\r\n Enabled = False\r\n Glyph.Data = {\r\n 36030000424D3603000000000000360000002800000010000000100000000100\r\n 18000000000000030000C40E0000C40E00000000000000000000008080008080\r\n 0080800080800080800080800080800080800080800080800080800080800080\r\n 8000808000808000808000808000808080808080808080808080808080808080\r\n 8080808080808080808080808080808080808080808080808080008080000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 00000000000000808080008080000000FFFFFF00FFFFFFFFFF00FFFFFFFFFF00\r\n FFFFFFFFFF00FFFF000000000000FFFFFF00FFFF000000808080808080000000\r\n 00FFFFFFFFFF00FFFFFFFFFF00FFFFFFFFFF00FFFFFFFFFF000000C0C0C00000\r\n 00FFFFFF000000808080000080000000FFFFFF00FFFFFFFFFF00FFFFFFFFFF00\r\n FFFFFFFFFF00FFFF00000000FFFFC0C0C0000000000000808080000080000080\r\n 00FFFFFFFFFF00FFFFFFFFFF80808000008000FFFFFFFFFF0000000000000000\r\n 0000000000000080808080808000008080808000FFFFFFFFFF80808000008080\r\n 8080FFFFFF00FFFFFFFFFF00FFFFFFFFFF00FFFF000000808080008080000080\r\n 00008080808000FFFF000080000080FFFFFF00FFFFFFFFFF00FFFFFFFFFF00FF\r\n FFFFFFFF000000808080008080808080000080000080000080000080FFFFFF00\r\n FFFFFFFFFF00FFFFFFFFFF00FFFFFFFFFF00FFFF000000808080008080808080\r\n 000080000080000080FFFFFF00FFFFFFFFFF00FFFFFFFFFF00FFFFFFFFFF00FF\r\n FFFFFFFF00000080808080808000008000008000008000008080808000000000\r\n 0000000000000000000000000000000000000000000000008080000080000080\r\n 8080800080800000800000808080800080800080800080800080800080800080\r\n 8000808000808000808000808000808000808000808000808000008000008080\r\n 8080008080008080008080008080008080008080008080008080008080008080\r\n 0080800080800080800080800000800000808080800080800080800080800080\r\n 8000808000808000808000808000808000808000808000808000808000808000\r\n 8080008080008080008080008080008080008080008080008080}\r\n OnClick = btnDeleteClick\r\n end\r\n object btnClear: TSpeedButton\r\n Left = 160\r\n Top = 16\r\n Width = 65\r\n Height = 23\r\n Hint = 'Clears the entire list.'\r\n Caption = '&Clear'\r\n Glyph.Data = {\r\n F6000000424DF600000000000000760000002800000010000000100000000100\r\n 0400000000008000000000000000000000001000000000000000000000000000\r\n 8000008000000080800080000000800080008080000080808000C0C0C0000000\r\n FF0000FF000000FFFF00FF000000FF00FF00FFFF0000FFFFFF00888888888888\r\n 8888888888888888888888808888888888088800088888888888880000888888\r\n 8088888000888888088888880008888008888888800088008888888888000008\r\n 8888888888800088888888888800000888888888800088008888888000088880\r\n 0888880000888888008888000888888888088888888888888888}\r\n OnClick = btnClearClick\r\n end\r\n object btnEdit: TSpeedButton\r\n Left = 232\r\n Top = 16\r\n Width = 65\r\n Height = 23\r\n Hint = 'Edits the selected item on the auto-correction list.'\r\n Caption = '&Edit'\r\n Enabled = False\r\n OnClick = btnEditClick\r\n end\r\n object btnDone: TSpeedButton\r\n Left = 312\r\n Top = 16\r\n Width = 65\r\n Height = 23\r\n Hint = 'Closes the edit dialog and saves the list.'\r\n Caption = '&Done'\r\n OnClick = btnDoneClick\r\n end\r\n object bvlSeparator: TBevel\r\n Left = 304\r\n Top = 16\r\n Width = 2\r\n Height = 23\r\n end\r\n object lbxItems: TListBox\r\n Left = 16\r\n Top = 72\r\n Width = 489\r\n Height = 289\r\n Style = lbOwnerDrawFixed\r\n BorderStyle = bsNone\r\n ItemHeight = 15\r\n TabOrder = 0\r\n OnClick = lbxItemsClick\r\n end\r\nend\r\n" }, { "path": "External/SynEdit/Source/QSynAutoCorrectEditor.pas", "content": "unit QSynAutoCorrectEditor;\r\n\r\n{$DEFINE SYN_CLX}\r\n{$DEFINE QSYNAUTOCORRECTEDITOR}\r\n\r\n{$I SynAutoCorrectEditor.pas}\r\n" }, { "path": "External/SynEdit/Source/QSynCompletionProposal.pas", "content": "unit QSynCompletionProposal;\r\n\r\n{$DEFINE SYN_CLX}\r\n{$DEFINE QSYNCOMPLETIONPROPOSAL}\r\n\r\n{$I SynCompletionProposal.pas}\r\n" }, { "path": "External/SynEdit/Source/QSynDBEdit.pas", "content": "unit QSynDBEdit;\r\n\r\n{$DEFINE SYN_CLX}\r\n{$DEFINE QSYNDBEDIT}\r\n\r\n{$I SynDBEdit.pas}\r\n" }, { "path": "External/SynEdit/Source/QSynEdit.pas", "content": "unit QSynEdit;\r\n\r\n{$DEFINE SYN_CLX}\r\n{$DEFINE QSYNEDIT}\r\n\r\n{$I SynEdit.pas}\r\n" }, { "path": "External/SynEdit/Source/QSynEditAutoComplete.pas", "content": "unit QSynEditAutoComplete;\r\n\r\n{$DEFINE SYN_CLX}\r\n{$DEFINE QSYNEDITAUTOCOMPLETE}\r\n\r\n{$I SynEditAutoComplete.pas}\r\n" }, { "path": "External/SynEdit/Source/QSynEditExport.pas", "content": "unit QSynEditExport;\r\n\r\n{$DEFINE SYN_CLX}\r\n{$DEFINE QSYNEDITEXPORT}\r\n\r\n{$I SynEditExport.pas}\r\n" }, { "path": "External/SynEdit/Source/QSynEditHighlighter.pas", "content": "unit QSynEditHighlighter;\r\n\r\n{$DEFINE SYN_CLX}\r\n{$DEFINE QSYNEDITHIGHLIGHTER}\r\n\r\n{$I SynEditHighlighter.pas}\r\n" }, { "path": "External/SynEdit/Source/QSynEditKbdHandler.pas", "content": "unit QSynEditKbdHandler;\r\n\r\n{$DEFINE SYN_CLX}\r\n{$DEFINE QSYNEDITKBDHANDLER}\r\n\r\n{$I SynEditKbdHandler.pas}\r\n" }, { "path": "External/SynEdit/Source/QSynEditKeyCmdEditor.dfm", "content": "object SynEditKeystrokeEditorForm: TSynEditKeystrokeEditorForm\r\n Left = 405\r\n Top = 306\r\n BorderStyle = fbsDialog\r\n Caption = 'Edit Keystroke'\r\n ClientHeight = 129\r\n ClientWidth = 269\r\n Color = clBtnFace\r\n Font.Charset = DEFAULT_CHARSET\r\n Font.Color = clWindowText\r\n Font.Height = -11\r\n Font.Name = 'MS Sans Serif'\r\n Font.Style = []\r\n KeyPreview = True\r\n OldCreateOrder = True\r\n Position = poScreenCenter\r\n OnCreate = FormCreate\r\n OnKeyDown = FormKeyDown\r\n OnShow = FormShow\r\n PixelsPerInch = 96\r\n TextHeight = 13\r\n object pnlAlign: TPanel\r\n Left = 3\r\n Top = 5\r\n Width = 262\r\n Height = 120\r\n BevelInner = bvRaised\r\n BevelOuter = bvLowered\r\n TabOrder = 0\r\n object Label1: TLabel\r\n Left = 9\r\n Top = 14\r\n Width = 50\r\n Height = 13\r\n Caption = 'Command:'\r\n end\r\n object Label2: TLabel\r\n Left = 9\r\n Top = 41\r\n Width = 50\r\n Height = 13\r\n Caption = 'Keystroke:'\r\n end\r\n object Label4: TLabel\r\n Left = 9\r\n Top = 65\r\n Width = 50\r\n Height = 13\r\n Caption = 'Keystroke:'\r\n end\r\n object bntClearKey: TButton\r\n Left = 9\r\n Top = 86\r\n Width = 75\r\n Height = 25\r\n Caption = 'Clear Key'\r\n TabOrder = 3\r\n OnClick = bntClearKeyClick\r\n end\r\n object btnOK: TButton\r\n Left = 93\r\n Top = 86\r\n Width = 75\r\n Height = 25\r\n Caption = 'OK'\r\n TabOrder = 1\r\n OnClick = btnOKClick\r\n end\r\n object cmbCommand: TComboBox\r\n Left = 65\r\n Top = 10\r\n Width = 186\r\n Height = 21\r\n ItemHeight = 13\r\n TabOrder = 0\r\n OnExit = cmbCommandExit\r\n OnKeyPress = cmbCommandKeyPress\r\n end\r\n object btnCancel: TButton\r\n Left = 177\r\n Top = 86\r\n Width = 75\r\n Height = 25\r\n Cancel = True\r\n Caption = 'Cancel'\r\n ModalResult = 2\r\n TabOrder = 2\r\n end\r\n end\r\nend\r\n" }, { "path": "External/SynEdit/Source/QSynEditKeyCmdEditor.pas", "content": "unit QSynEditKeyCmdEditor;\r\n\r\n{$DEFINE SYN_CLX}\r\n{$DEFINE QSYNEDITKEYCMDEDITOR}\r\n\r\n{$I SynEditKeyCmdEditor.pas}\r\n" }, { "path": "External/SynEdit/Source/QSynEditKeyCmds.pas", "content": "unit QSynEditKeyCmds;\r\n\r\n{$DEFINE SYN_CLX}\r\n{$DEFINE QSYNEDITKEYCMDS}\r\n\r\n{$I SynEditKeyCmds.pas}\r\n" }, { "path": "External/SynEdit/Source/QSynEditKeyCmdsEditor.dfm", "content": "object SynEditKeystrokesEditorForm: TSynEditKeystrokesEditorForm\r\n Left = 345\r\n Top = 317\r\n Width = 390\r\n Height = 353\r\n ActiveControl = KeyCmdList\r\n BorderIcons = [biSystemMenu, biMaximize]\r\n Caption = 'Keystroke Editor'\r\n Color = clButton\r\n Font.Color = clText\r\n Font.Height = 11\r\n Font.Name = 'MS Sans Serif'\r\n Font.Pitch = fpVariable\r\n Font.Style = []\r\n Font.Weight = 40\r\n ParentFont = False\r\n Position = poScreenCenter\r\n OnCreate = FormCreate\r\n OnResize = FormResize\r\n PixelsPerInch = 96\r\n TextHeight = 13\r\n TextWidth = 6\r\n object pnlBottom: TPanel\r\n Left = 8\r\n Top = 8\r\n Width = 365\r\n Height = 308\r\n Anchors = [akLeft, akTop, akRight, akBottom]\r\n BevelInner = bvRaised\r\n BevelOuter = bvLowered\r\n TabOrder = 0\r\n object lnlInfo: TLabel\r\n Left = 5\r\n Top = 271\r\n Width = 229\r\n Height = 13\r\n Anchors = [akLeft, akBottom]\r\n Caption = 'NOTE: To have multiple keystrokes do the same'\r\n end\r\n object lnlInfo2: TLabel\r\n Left = 42\r\n Top = 287\r\n Width = 217\r\n Height = 13\r\n Anchors = [akLeft, akBottom]\r\n Caption = 'command, assign the command multiple times.'\r\n end\r\n object pnlCommands: TPanel\r\n Left = 16\r\n Top = 16\r\n Width = 246\r\n Height = 244\r\n Anchors = [akLeft, akTop, akRight, akBottom]\r\n BevelInner = bvLowered\r\n BorderWidth = 4\r\n Caption = 'pnlCommands'\r\n TabOrder = 0\r\n object KeyCmdList: TListView\r\n Left = 6\r\n Top = 6\r\n Width = 234\r\n Height = 232\r\n Align = alClient\r\n BorderStyle = bsNone\r\n ColumnClick = False\r\n ColumnMove = False\r\n Columns = <\r\n item\r\n AllowClick = False\r\n Caption = 'Command'\r\n Tag = 0\r\n Width = 117\r\n end\r\n item\r\n AllowClick = False\r\n Caption = 'Keystroke'\r\n Tag = 0\r\n Width = 101\r\n end>\r\n TabOrder = 0\r\n ViewStyle = vsReport\r\n OnClick = KeyCmdListClick\r\n OnDblClick = btnEditClick\r\n end\r\n end\r\n object btnAdd: TButton\r\n Left = 276\r\n Top = 20\r\n Width = 75\r\n Height = 25\r\n Anchors = [akTop, akRight]\r\n Caption = '&Add'\r\n TabOrder = 1\r\n OnClick = btnAddClick\r\n end\r\n object btnEdit: TButton\r\n Left = 276\r\n Top = 52\r\n Width = 75\r\n Height = 25\r\n Anchors = [akTop, akRight]\r\n Caption = '&Edit'\r\n Enabled = False\r\n TabOrder = 2\r\n OnClick = btnEditClick\r\n end\r\n object btnDelete: TButton\r\n Left = 276\r\n Top = 84\r\n Width = 75\r\n Height = 25\r\n Anchors = [akTop, akRight]\r\n Caption = '&Delete'\r\n Enabled = False\r\n TabOrder = 3\r\n OnClick = btnDeleteClick\r\n end\r\n object btnClear: TButton\r\n Left = 276\r\n Top = 116\r\n Width = 75\r\n Height = 25\r\n Anchors = [akTop, akRight]\r\n Caption = 'C&lear List'\r\n TabOrder = 4\r\n OnClick = btnClearClick\r\n end\r\n object btnReset: TButton\r\n Left = 276\r\n Top = 148\r\n Width = 75\r\n Height = 25\r\n Anchors = [akTop, akRight]\r\n Caption = '&Reset List'\r\n TabOrder = 5\r\n OnClick = btnResetClick\r\n end\r\n object btnOK: TButton\r\n Left = 276\r\n Top = 241\r\n Width = 75\r\n Height = 25\r\n Anchors = [akRight, akBottom]\r\n Caption = '&OK'\r\n Default = True\r\n TabOrder = 6\r\n OnClick = btnOKClick\r\n end\r\n object btnCancel: TButton\r\n Left = 276\r\n Top = 273\r\n Width = 75\r\n Height = 25\r\n Anchors = [akRight, akBottom]\r\n Cancel = True\r\n Caption = '&Cancel'\r\n TabOrder = 7\r\n OnClick = btnCancelClick\r\n end\r\n end\r\nend\r\n" }, { "path": "External/SynEdit/Source/QSynEditKeyCmdsEditor.pas", "content": "unit QSynEditKeyCmdsEditor;\r\n\r\n{$DEFINE SYN_CLX}\r\n{$DEFINE QSYNEDITKEYCMDSEDITOR}\r\n\r\n{$I SynEditKeyCmdsEditor.pas}\r\n" }, { "path": "External/SynEdit/Source/QSynEditKeyConst.pas", "content": "unit QSynEditKeyConst;\r\n\r\n{$DEFINE SYN_CLX}\r\n{$DEFINE QSYNEDITKEYCONST}\r\n\r\n{$I SynEditKeyConst.pas}\r\n" }, { "path": "External/SynEdit/Source/QSynEditMiscClasses.pas", "content": "unit QSynEditMiscClasses;\r\n\r\n{$DEFINE SYN_CLX}\r\n{$DEFINE QSYNEDITMISCCLASSES}\r\n\r\n{$I SynEditMiscClasses.pas}\r\n" }, { "path": "External/SynEdit/Source/QSynEditMiscProcs.pas", "content": "unit QSynEditMiscProcs;\r\n\r\n{$DEFINE SYN_CLX}\r\n{$DEFINE QSYNEDITMISCPROCS}\r\n\r\n{$I SynEditMiscProcs.pas}\r\n\r\n\r\n" }, { "path": "External/SynEdit/Source/QSynEditOptionsDialog.dfm", "content": "object fmEditorOptionsDialog: TfmEditorOptionsDialog\r\n Left = 580\r\n Top = 154\r\n Width = 369\r\n Height = 394\r\n VertScrollBar.Range = 387\r\n HorzScrollBar.Range = 361\r\n ActiveControl = PageControl1\r\n BorderStyle = fbsDialog\r\n Caption = 'Editor Options'\r\n Color = clButton\r\n Font.Color = clText\r\n Font.Height = 11\r\n Font.Name = 'MS Sans Serif'\r\n Font.Pitch = fpVariable\r\n Font.Style = []\r\n Font.Weight = 40\r\n ParentFont = False\r\n Position = poScreenCenter\r\n OnCreate = FormCreate\r\n OnShow = FormShow\r\n PixelsPerInch = 96\r\n TextHeight = 13\r\n TextWidth = 6\r\n object PageControl1: TPageControl\r\n Left = 6\r\n Top = 8\r\n Width = 355\r\n Height = 345\r\n ActivePage = Display\r\n TabOrder = 0\r\n object Display: TTabSheet\r\n Caption = 'Display'\r\n ImageIndex = 1\r\n object gbRightEdge: TGroupBox\r\n Left = 8\r\n Top = 136\r\n Width = 159\r\n Height = 88\r\n Caption = 'Right Edge'\r\n TabOrder = 1\r\n object Label3: TLabel\r\n Left = 9\r\n Top = 56\r\n Width = 54\r\n Height = 13\r\n Caption = 'Edge color:'\r\n end\r\n object Label10: TLabel\r\n Left = 9\r\n Top = 26\r\n Width = 66\r\n Height = 13\r\n Caption = 'Edge Column:'\r\n end\r\n object pRightEdgeBack: TPanel\r\n Left = 80\r\n Top = 54\r\n Width = 52\r\n Height = 21\r\n BorderWidth = 1\r\n TabOrder = 1\r\n object pRightEdgeColor: TPanel\r\n Left = 2\r\n Top = 2\r\n Width = 38\r\n Height = 17\r\n Align = alClient\r\n BevelOuter = bvLowered\r\n Color = clGray\r\n TabOrder = 0\r\n OnClick = pRightEdgeColorClick\r\n end\r\n object btnRightEdge: TPanel\r\n Left = 40\r\n Top = 2\r\n Width = 10\r\n Height = 17\r\n Align = alRight\r\n BevelOuter = bvNone\r\n TabOrder = 1\r\n OnMouseDown = btnRightEdgeMouseDown\r\n object Image1: TImage\r\n Left = 3\r\n Top = 6\r\n Width = 5\r\n Height = 5\r\n Picture.Data = {\r\n 07544269746D61708E000000424D8A0000000000000076000000280000000500\r\n 000005000000010004000000000014000000C40E0000C40E0000100000000000\r\n 0000000000000000800000800000008080008000000080008000808000008080\r\n 8000C0C0C0000000FF0000FF000000FFFF00FF000000FF00FF00FFFF0000FFFF\r\n FF00DDDDD000DD0DD000D000D00000000000DDDDD000}\r\n Transparent = True\r\n OnMouseDown = btnRightEdgeMouseDown\r\n end\r\n end\r\n end\r\n object eRightEdge: TEdit\r\n Left = 80\r\n Top = 23\r\n Width = 51\r\n Height = 21\r\n TabOrder = 0\r\n Text = '0'\r\n end\r\n end\r\n object gbGutter: TGroupBox\r\n Left = 8\r\n Top = 8\r\n Width = 330\r\n Height = 121\r\n Caption = 'Gutter'\r\n TabOrder = 0\r\n object Label1: TLabel\r\n Left = 176\r\n Top = 89\r\n Width = 58\r\n Height = 13\r\n Caption = 'Gutter color:'\r\n end\r\n object ckGutterAutosize: TCheckBox\r\n Left = 9\r\n Top = 37\r\n Width = 120\r\n Height = 17\r\n Caption = 'Autosize'\r\n TabOrder = 1\r\n end\r\n object ckGutterShowLineNumbers: TCheckBox\r\n Left = 9\r\n Top = 56\r\n Width = 120\r\n Height = 17\r\n Caption = 'Show line numbers'\r\n TabOrder = 2\r\n end\r\n object ckGutterShowLeaderZeros: TCheckBox\r\n Left = 9\r\n Top = 94\r\n Width = 120\r\n Height = 17\r\n Caption = 'Show leading zeros'\r\n TabOrder = 4\r\n end\r\n object ckGutterStartAtZero: TCheckBox\r\n Left = 9\r\n Top = 75\r\n Width = 120\r\n Height = 17\r\n Caption = 'Start at zero'\r\n TabOrder = 3\r\n end\r\n object ckGutterVisible: TCheckBox\r\n Left = 9\r\n Top = 18\r\n Width = 120\r\n Height = 17\r\n Caption = 'Visible'\r\n Checked = True\r\n State = cbChecked\r\n TabOrder = 0\r\n end\r\n object cbGutterFont: TCheckBox\r\n Left = 176\r\n Top = 18\r\n Width = 120\r\n Height = 17\r\n Caption = 'Use Gutter Font'\r\n TabOrder = 5\r\n OnClick = cbGutterFontClick\r\n end\r\n object btnGutterFont: TButton\r\n Left = 282\r\n Top = 13\r\n Width = 40\r\n Height = 25\r\n Caption = 'Font'\r\n TabOrder = 6\r\n OnClick = btnGutterFontClick\r\n end\r\n object pGutterBack: TPanel\r\n Left = 252\r\n Top = 85\r\n Width = 52\r\n Height = 21\r\n BorderWidth = 1\r\n TabOrder = 8\r\n object pGutterColor: TPanel\r\n Left = 2\r\n Top = 2\r\n Width = 38\r\n Height = 17\r\n Align = alClient\r\n BevelOuter = bvLowered\r\n Color = clGray\r\n TabOrder = 0\r\n OnClick = pGutterColorClick\r\n end\r\n object btnGutterColor: TPanel\r\n Left = 40\r\n Top = 2\r\n Width = 10\r\n Height = 17\r\n Align = alRight\r\n BevelOuter = bvNone\r\n TabOrder = 1\r\n OnMouseDown = btnGutterColorMouseDown\r\n object Image2: TImage\r\n Left = 3\r\n Top = 6\r\n Width = 5\r\n Height = 5\r\n Picture.Data = {\r\n 07544269746D61708E000000424D8A0000000000000076000000280000000500\r\n 000005000000010004000000000014000000C40E0000C40E0000100000000000\r\n 0000000000000000800000800000008080008000000080008000808000008080\r\n 8000C0C0C0000000FF0000FF000000FFFF00FF000000FF00FF00FFFF0000FFFF\r\n FF00DDDDD000DD0DD000D000D00000000000DDDDD000}\r\n Transparent = True\r\n OnMouseDown = btnGutterColorMouseDown\r\n end\r\n end\r\n end\r\n object pnlGutterFontDisplay: TPanel\r\n Left = 176\r\n Top = 40\r\n Width = 145\r\n Height = 33\r\n BevelOuter = bvNone\r\n TabOrder = 7\r\n object lblGutterFont: TLabel\r\n Left = 19\r\n Top = 9\r\n Width = 72\r\n Height = 8\r\n Caption = 'Terminal 8pt'\r\n Font.Color = clText\r\n Font.Height = 11\r\n Font.Name = 'Terminal'\r\n Font.Pitch = fpVariable\r\n Font.Style = []\r\n Font.Weight = 40\r\n ParentFont = False\r\n end\r\n end\r\n end\r\n object gbBookmarks: TGroupBox\r\n Left = 8\r\n Top = 232\r\n Width = 159\r\n Height = 79\r\n Caption = 'Bookmarks'\r\n TabOrder = 3\r\n object ckBookmarkKeys: TCheckBox\r\n Left = 9\r\n Top = 24\r\n Width = 97\r\n Height = 17\r\n Caption = 'Bookmark keys'\r\n TabOrder = 0\r\n end\r\n object ckBookmarkVisible: TCheckBox\r\n Left = 9\r\n Top = 48\r\n Width = 121\r\n Height = 17\r\n Caption = 'Bookmarks visible'\r\n TabOrder = 1\r\n end\r\n end\r\n object gbEditorFont: TGroupBox\r\n Left = 180\r\n Top = 232\r\n Width = 159\r\n Height = 79\r\n Caption = 'Editor Font'\r\n TabOrder = 4\r\n object btnFont: TButton\r\n Left = 64\r\n Top = 49\r\n Width = 84\r\n Height = 25\r\n Caption = 'Font'\r\n TabOrder = 0\r\n OnClick = btnFontClick\r\n end\r\n object Panel3: TPanel\r\n Left = 8\r\n Top = 19\r\n Width = 143\r\n Height = 30\r\n BevelOuter = bvNone\r\n TabOrder = 1\r\n object labFont: TLabel\r\n Left = 2\r\n Top = 1\r\n Width = 128\r\n Height = 16\r\n Caption = 'Courier New 10pt'\r\n Font.Color = clText\r\n Font.Height = 13\r\n Font.Name = 'Courier New'\r\n Font.Pitch = fpVariable\r\n Font.Style = []\r\n Font.Weight = 40\r\n ParentFont = False\r\n end\r\n end\r\n end\r\n object gbLineSpacing: TGroupBox\r\n Left = 180\r\n Top = 136\r\n Width = 159\r\n Height = 88\r\n Caption = 'Line spacing / Tab spacing'\r\n TabOrder = 2\r\n object Label8: TLabel\r\n Left = 9\r\n Top = 27\r\n Width = 55\r\n Height = 13\r\n Caption = 'Extra Lines:'\r\n end\r\n object Label9: TLabel\r\n Left = 9\r\n Top = 56\r\n Width = 53\r\n Height = 13\r\n Caption = 'Tab Width:'\r\n end\r\n object eLineSpacing: TEdit\r\n Left = 80\r\n Top = 23\r\n Width = 52\r\n Height = 21\r\n TabOrder = 0\r\n Text = '0'\r\n end\r\n object eTabWidth: TEdit\r\n Left = 80\r\n Top = 53\r\n Width = 52\r\n Height = 21\r\n TabOrder = 1\r\n Text = '8'\r\n end\r\n end\r\n end\r\n object Options: TTabSheet\r\n Caption = 'Options'\r\n ImageIndex = 1\r\n object gbOptions: TGroupBox\r\n Left = 8\r\n Top = 0\r\n Width = 330\r\n Height = 247\r\n Caption = 'Options'\r\n TabOrder = 0\r\n object ckAutoIndent: TCheckBox\r\n Left = 9\r\n Top = 15\r\n Width = 130\r\n Height = 17\r\n Hint = \r\n 'Will indent the caret on new lines with the same amount of leadi' +\r\n 'ng white space as the preceding line'\r\n Caption = 'Auto indent'\r\n TabOrder = 0\r\n end\r\n object ckDragAndDropEditing: TCheckBox\r\n Left = 9\r\n Top = 34\r\n Width = 130\r\n Height = 17\r\n Hint = \r\n 'Allows you to select a block of text and drag it within the docu' +\r\n 'ment to another location'\r\n Caption = 'Drag and drop editing'\r\n TabOrder = 1\r\n end\r\n object ckDragAndDropFiles: TCheckBox\r\n Left = 9\r\n Top = 53\r\n Width = 130\r\n Height = 17\r\n Hint = 'Allows the editor accept OLE file drops'\r\n Caption = 'Drag and drop files'\r\n TabOrder = 2\r\n end\r\n object ckHalfPageScroll: TCheckBox\r\n Left = 176\r\n Top = 15\r\n Width = 130\r\n Height = 17\r\n Hint = \r\n 'When scrolling with page-up and page-down commands, only scroll ' +\r\n 'a half page at a time'\r\n Caption = 'Half page scroll'\r\n TabOrder = 11\r\n end\r\n object ckNoSelection: TCheckBox\r\n Left = 176\r\n Top = 224\r\n Width = 130\r\n Height = 17\r\n Hint = 'Disables selecting text'\r\n Caption = 'No selection'\r\n TabOrder = 21\r\n end\r\n object ckNoCaret: TCheckBox\r\n Left = 9\r\n Top = 224\r\n Width = 130\r\n Height = 17\r\n Hint = 'Makes it so the caret is never visible'\r\n Caption = 'No caret'\r\n TabOrder = 20\r\n end\r\n object ckScrollByOneLess: TCheckBox\r\n Left = 176\r\n Top = 34\r\n Width = 130\r\n Height = 17\r\n Hint = 'Forces scrolling to be one less'\r\n Caption = 'Scroll by one less'\r\n TabOrder = 12\r\n end\r\n object ckScrollPastEOF: TCheckBox\r\n Left = 176\r\n Top = 53\r\n Width = 130\r\n Height = 17\r\n Hint = 'Allows the cursor to go past the end of file marker'\r\n Caption = 'Scroll past end of file'\r\n TabOrder = 13\r\n end\r\n object ckScrollPastEOL: TCheckBox\r\n Left = 176\r\n Top = 72\r\n Width = 130\r\n Height = 17\r\n Hint = \r\n 'Allows the cursor to go past the last character into the white s' +\r\n 'pace at the end of a line'\r\n Caption = 'Scroll past end of line'\r\n TabOrder = 14\r\n end\r\n object ckShowScrollHint: TCheckBox\r\n Left = 176\r\n Top = 91\r\n Width = 130\r\n Height = 17\r\n Hint = \r\n 'Shows a hint of the visible line numbers when scrolling vertical' +\r\n 'ly'\r\n Caption = 'Show scroll hint'\r\n TabOrder = 15\r\n end\r\n object ckSmartTabs: TCheckBox\r\n Left = 9\r\n Top = 129\r\n Width = 130\r\n Height = 17\r\n Hint = \r\n 'When tabbing, the cursor will go to the next non-white space cha' +\r\n 'racter of the previous line'\r\n Caption = 'Smart tabs'\r\n TabOrder = 6\r\n end\r\n object ckTabsToSpaces: TCheckBox\r\n Left = 176\r\n Top = 129\r\n Width = 130\r\n Height = 17\r\n Hint = 'Converts a tab character to the number of spaces in Tab Width'\r\n Caption = 'Tabs to spaces'\r\n TabOrder = 17\r\n end\r\n object ckTrimTrailingSpaces: TCheckBox\r\n Left = 176\r\n Top = 148\r\n Width = 130\r\n Height = 17\r\n Hint = 'Spaces at the end of lines will be trimmed and not saved'\r\n Caption = 'Trim trailing spaces'\r\n TabOrder = 18\r\n end\r\n object ckWantTabs: TCheckBox\r\n Left = 9\r\n Top = 110\r\n Width = 130\r\n Height = 17\r\n Hint = \r\n 'Let the editor accept tab characters instead of going to the nex' +\r\n 't control'\r\n Caption = 'Want tabs'\r\n TabOrder = 5\r\n end\r\n object ckAltSetsColumnMode: TCheckBox\r\n Left = 9\r\n Top = 72\r\n Width = 130\r\n Height = 17\r\n Hint = \r\n 'Holding down the Alt Key will put the selection mode into column' +\r\n 'ar format'\r\n Caption = 'Alt sets column mode'\r\n TabOrder = 3\r\n end\r\n object ckKeepCaretX: TCheckBox\r\n Left = 9\r\n Top = 91\r\n Width = 130\r\n Height = 17\r\n Hint = \r\n 'When moving through lines the X position will always stay the sa' +\r\n 'me'\r\n Caption = 'Maintain caret column'\r\n TabOrder = 4\r\n end\r\n object ckScrollHintFollows: TCheckBox\r\n Left = 176\r\n Top = 110\r\n Width = 152\r\n Height = 17\r\n Hint = 'The scroll hint follows the mouse when scrolling vertically'\r\n Caption = 'Scroll hint follows mouse'\r\n TabOrder = 16\r\n end\r\n object ckGroupUndo: TCheckBox\r\n Left = 176\r\n Top = 167\r\n Width = 130\r\n Height = 17\r\n Hint = \r\n 'When undoing/redoing actions, handle all continous changes of th' +\r\n 'e same kind in one call instead undoing/redoing each command sep' +\r\n 'arately'\r\n Caption = 'Group undo'\r\n TabOrder = 19\r\n end\r\n object ckSmartTabDelete: TCheckBox\r\n Left = 9\r\n Top = 148\r\n Width = 130\r\n Height = 17\r\n Hint = 'similar to Smart Tabs, but when you delete characters'\r\n Caption = 'Smart tab delete'\r\n TabOrder = 7\r\n end\r\n object ckRightMouseMoves: TCheckBox\r\n Left = 9\r\n Top = 167\r\n Width = 146\r\n Height = 17\r\n Hint = \r\n 'When clicking with the right mouse for a popup menu, move the cu' +\r\n 'rsor to that location'\r\n Caption = 'Right mouse moves cursor'\r\n TabOrder = 8\r\n end\r\n object ckEnhanceHomeKey: TCheckBox\r\n Left = 9\r\n Top = 186\r\n Width = 146\r\n Height = 17\r\n Hint = 'enhances home key positioning, similar to visual studio'\r\n Caption = 'Enhance Home Key'\r\n TabOrder = 9\r\n end\r\n object ckHideShowScrollbars: TCheckBox\r\n Left = 9\r\n Top = 205\r\n Width = 160\r\n Height = 17\r\n Hint = \r\n 'if enabled, then the scrollbars will only show when necessary. ' +\r\n 'If you have ScrollPastEOL, then it the horizontal bar will alway' +\r\n 's be there (it uses MaxLength instead)'\r\n Caption = 'Hide scrollbars as necessary'\r\n TabOrder = 10\r\n end\r\n object ckDisableScrollArrows: TCheckBox\r\n Left = 176\r\n Top = 186\r\n Width = 130\r\n Height = 17\r\n Hint = \r\n 'Disables the scroll bar arrow buttons when you can'#39't scroll in t' +\r\n 'hat direction any more'\r\n Caption = 'Disable scroll arrows'\r\n TabOrder = 22\r\n end\r\n object ckShowSpecialChars: TCheckBox\r\n Left = 176\r\n Top = 205\r\n Width = 130\r\n Height = 17\r\n Hint = 'Shows linebreaks, spaces and tabs using special symbols'\r\n Caption = 'Show special chars'\r\n TabOrder = 23\r\n end\r\n end\r\n object gbCaret: TGroupBox\r\n Left = 8\r\n Top = 249\r\n Width = 330\r\n Height = 62\r\n Caption = 'Caret'\r\n TabOrder = 1\r\n object Label2: TLabel\r\n Left = 16\r\n Top = 17\r\n Width = 56\r\n Height = 13\r\n Caption = 'Insert caret:'\r\n end\r\n object Label4: TLabel\r\n Left = 16\r\n Top = 41\r\n Width = 75\r\n Height = 13\r\n Caption = 'Overwrite caret:'\r\n end\r\n object cInsertCaret: TComboBox\r\n Left = 120\r\n Top = 13\r\n Width = 186\r\n Height = 21\r\n Style = csDropDownList\r\n ItemHeight = 15\r\n Items.Strings = (\r\n 'Vertical Line'\r\n 'Horizontal Line'\r\n 'Half Block'\r\n 'Block')\r\n TabOrder = 0\r\n end\r\n object cOverwriteCaret: TComboBox\r\n Left = 120\r\n Top = 37\r\n Width = 186\r\n Height = 21\r\n Style = csDropDownList\r\n ItemHeight = 15\r\n Items.Strings = (\r\n 'Vertical Line'\r\n 'Horizontal Line'\r\n 'Half Block'\r\n 'Block')\r\n TabOrder = 1\r\n end\r\n end\r\n end\r\n object Keystrokes: TTabSheet\r\n Caption = 'Keystrokes'\r\n ImageIndex = 2\r\n object btnAddKey: TButton\r\n Left = 96\r\n Top = 152\r\n Width = 75\r\n Height = 25\r\n Caption = '&Add'\r\n TabOrder = 2\r\n OnClick = btnAddKeyClick\r\n end\r\n object btnRemKey: TButton\r\n Left = 176\r\n Top = 152\r\n Width = 75\r\n Height = 25\r\n Caption = '&Remove'\r\n TabOrder = 3\r\n OnClick = btnRemKeyClick\r\n end\r\n object gbKeyStrokes: TGroupBox\r\n Left = 8\r\n Top = 192\r\n Width = 330\r\n Height = 119\r\n Caption = 'Keystroke Options'\r\n TabOrder = 4\r\n object Label5: TLabel\r\n Left = 16\r\n Top = 28\r\n Width = 50\r\n Height = 13\r\n Caption = 'Command:'\r\n end\r\n object Label6: TLabel\r\n Left = 16\r\n Top = 91\r\n Width = 50\r\n Height = 13\r\n Caption = 'Keystroke:'\r\n end\r\n object Label7: TLabel\r\n Left = 16\r\n Top = 59\r\n Width = 50\r\n Height = 13\r\n Caption = 'Keystroke:'\r\n end\r\n object cKeyCommand: TComboBox\r\n Left = 120\r\n Top = 23\r\n Width = 186\r\n Height = 21\r\n ItemHeight = 15\r\n TabOrder = 0\r\n OnExit = cKeyCommandExit\r\n OnKeyPress = cKeyCommandKeyPress\r\n OnKeyUp = cKeyCommandKeyUp\r\n end\r\n end\r\n object btnUpdateKey: TButton\r\n Left = 16\r\n Top = 152\r\n Width = 75\r\n Height = 25\r\n Caption = '&Update'\r\n TabOrder = 1\r\n OnClick = btnUpdateKeyClick\r\n end\r\n object pnlCommands: TPanel\r\n Left = 8\r\n Top = 13\r\n Width = 330\r\n Height = 132\r\n Anchors = [akLeft, akTop, akRight, akBottom]\r\n BevelInner = bvRaised\r\n BevelOuter = bvLowered\r\n Caption = 'pnlCommands'\r\n TabOrder = 0\r\n object KeyList: TListView\r\n Left = 2\r\n Top = 2\r\n Width = 326\r\n Height = 128\r\n Align = alClient\r\n BorderStyle = bsNone\r\n ColumnClick = False\r\n ColumnMove = False\r\n Columns = <\r\n item\r\n AllowClick = False\r\n Caption = 'Command'\r\n Tag = 0\r\n Width = 167\r\n end\r\n item\r\n AllowClick = False\r\n Caption = 'Keystroke'\r\n Tag = 0\r\n Width = 142\r\n end>\r\n RowSelect = True\r\n ReadOnly = True\r\n TabOrder = 0\r\n ViewStyle = vsReport\r\n OnChanging = KeyListChanging\r\n OnEditing = KeyListEditing\r\n OnSelectItem = KeyListSelectItem\r\n end\r\n end\r\n end\r\n end\r\n object btnOk: TButton\r\n Left = 200\r\n Top = 362\r\n Width = 75\r\n Height = 25\r\n Caption = '&OK'\r\n ModalResult = 1\r\n TabOrder = 1\r\n OnClick = btnOkClick\r\n end\r\n object btnCancel: TButton\r\n Left = 280\r\n Top = 362\r\n Width = 75\r\n Height = 25\r\n Caption = '&Cancel'\r\n ModalResult = 2\r\n TabOrder = 2\r\n end\r\n object ColorDialog: TColorDialog\r\n Left = 8\r\n Top = 368\r\n end\r\n object ColorPopup: TPopupMenu\r\n Images = ImageList1\r\n Left = 40\r\n Top = 368\r\n object None1: TMenuItem\r\n Tag = -1\r\n Caption = 'None'\r\n OnClick = PopupMenuClick\r\n end\r\n object Scrollbar1: TMenuItem\r\n Caption = 'Scrollbar'\r\n OnClick = PopupMenuClick\r\n end\r\n object Background1: TMenuItem\r\n Tag = 1\r\n Caption = 'Background'\r\n OnClick = PopupMenuClick\r\n end\r\n object ActiveCaption1: TMenuItem\r\n Tag = 2\r\n Caption = 'Active Caption'\r\n OnClick = PopupMenuClick\r\n end\r\n object InactiveCaption1: TMenuItem\r\n Tag = 3\r\n Caption = 'Inactive Caption'\r\n OnClick = PopupMenuClick\r\n end\r\n object Menu1: TMenuItem\r\n Tag = 4\r\n Caption = 'Menu'\r\n OnClick = PopupMenuClick\r\n end\r\n object Window1: TMenuItem\r\n Tag = 5\r\n Caption = 'Window'\r\n OnClick = PopupMenuClick\r\n end\r\n object WindowFrame1: TMenuItem\r\n Tag = 6\r\n Caption = 'Window Frame'\r\n OnClick = PopupMenuClick\r\n end\r\n object MEnu2: TMenuItem\r\n Tag = 7\r\n Caption = 'Menu Text'\r\n OnClick = PopupMenuClick\r\n end\r\n object WindowText1: TMenuItem\r\n Tag = 8\r\n Caption = 'Window Text'\r\n OnClick = PopupMenuClick\r\n end\r\n object CaptionText1: TMenuItem\r\n Tag = 9\r\n Caption = 'Caption Text'\r\n OnClick = PopupMenuClick\r\n end\r\n object ActiveBorder1: TMenuItem\r\n Tag = 10\r\n Caption = 'Active Border'\r\n OnClick = PopupMenuClick\r\n end\r\n object InactiveBorder1: TMenuItem\r\n Tag = 11\r\n Caption = 'Inactive Border'\r\n OnClick = PopupMenuClick\r\n end\r\n object ApplicationWorkspace1: TMenuItem\r\n Tag = 12\r\n Caption = 'Application Workspace'\r\n OnClick = PopupMenuClick\r\n end\r\n object Highlight1: TMenuItem\r\n Tag = 13\r\n Caption = 'Highlight'\r\n OnClick = PopupMenuClick\r\n end\r\n object HighlightText1: TMenuItem\r\n Tag = 14\r\n Caption = 'Highlight Text'\r\n OnClick = PopupMenuClick\r\n end\r\n object ButtonFace1: TMenuItem\r\n Tag = 15\r\n Caption = 'Button Face'\r\n OnClick = PopupMenuClick\r\n end\r\n object ButtonShadow1: TMenuItem\r\n Tag = 16\r\n Caption = 'Button Shadow'\r\n OnClick = PopupMenuClick\r\n end\r\n object GrayText1: TMenuItem\r\n Tag = 17\r\n Caption = 'Gray Text'\r\n OnClick = PopupMenuClick\r\n end\r\n object ButtonText1: TMenuItem\r\n Tag = 18\r\n Caption = 'Button Text'\r\n OnClick = PopupMenuClick\r\n end\r\n object InactiveCaptionText1: TMenuItem\r\n Tag = 19\r\n Caption = 'Inactive Caption Text'\r\n OnClick = PopupMenuClick\r\n end\r\n object Highlight2: TMenuItem\r\n Tag = 20\r\n Caption = 'Highlight'\r\n OnClick = PopupMenuClick\r\n end\r\n object N3dDarkShadow1: TMenuItem\r\n Tag = 21\r\n Caption = '3D Dark Shadow'\r\n OnClick = PopupMenuClick\r\n end\r\n object N3DLight1: TMenuItem\r\n Tag = 22\r\n Caption = '3D Light'\r\n OnClick = PopupMenuClick\r\n end\r\n object InfoTipText1: TMenuItem\r\n Tag = 23\r\n Caption = 'Info Tip Text'\r\n OnClick = PopupMenuClick\r\n end\r\n object InfoTipBackground1: TMenuItem\r\n Tag = 24\r\n Caption = 'Info Tip Background'\r\n OnClick = PopupMenuClick\r\n end\r\n end\r\n object ImageList1: TImageList\r\n Left = 72\r\n Top = 368\r\n end\r\n object FontDialog: TFontDialog\r\n Font.Color = clText\r\n Font.Height = 11\r\n Font.Name = 'MS Sans Serif'\r\n Font.Pitch = fpVariable\r\n Font.Style = []\r\n Font.Weight = 40\r\n Left = 104\r\n Top = 368\r\n end\r\nend\r\n" }, { "path": "External/SynEdit/Source/QSynEditOptionsDialog.pas", "content": "unit QSynEditOptionsDialog;\r\n\r\n{$DEFINE SYN_CLX}\r\n{$DEFINE QSYNEDITOPTIONSDIALOG}\r\n\r\n{$I SynEditOptionsDialog.pas}\r\n" }, { "path": "External/SynEdit/Source/QSynEditPlugins.pas", "content": "unit QSynEditPlugins;\r\n\r\n{$DEFINE SYN_CLX}\r\n{$DEFINE QSYNEDITPLUGINS}\r\n\r\n{$I SynEditPlugins.pas}\r\n" }, { "path": "External/SynEdit/Source/QSynEditPrint.pas", "content": "unit QSynEditPrint;\r\n\r\n{$DEFINE SYN_CLX}\r\n{$DEFINE QSYNEDITPRINT}\r\n\r\n{$I SynEditPrint.pas}\r\n" }, { "path": "External/SynEdit/Source/QSynEditPrintHeaderFooter.pas", "content": "unit QSynEditPrintHeaderFooter;\r\n\r\n{$DEFINE SYN_CLX}\r\n{$DEFINE QSYNEDITPRINTHEADERFOOTER}\r\n\r\n{$I SynEditPrintHeaderFooter.pas}\r\n" }, { "path": "External/SynEdit/Source/QSynEditPrintMargins.pas", "content": "unit QSynEditPrintMargins;\r\n\r\n{$DEFINE SYN_CLX}\r\n{$DEFINE QSYNEDITPRINTMARGINS}\r\n\r\n{$I SynEditPrintMargins.pas}\r\n" }, { "path": "External/SynEdit/Source/QSynEditPrintMarginsDialog.dfm", "content": "object SynEditPrintMarginsDlg: TSynEditPrintMarginsDlg\r\n Left = 244\r\n Top = 189\r\n ActiveControl = CBUnits\r\n BorderStyle = fbsDialog\r\n Caption = 'Margins'\r\n ClientHeight = 344\r\n ClientWidth = 506\r\n Color = clBtnFace\r\n ParentFont = True\r\n OldCreateOrder = True\r\n Position = poScreenCenter\r\n OnCreate = FormCreate\r\n OnDestroy = FormDestroy\r\n PixelsPerInch = 96\r\n TextHeight = 13\r\n object Image1: TImage\r\n Left = 275\r\n Top = 10\r\n Width = 223\r\n Height = 292\r\n AutoSize = True\r\n Picture.Data = {\r\n 07544269746D617036800000424D36800000000000007600000028000000DF00\r\n 0000240100000100040000000000C07F0000C40E0000C40E0000100000000000\r\n 0000000000000000800000800000008080008000000080008000808000008080\r\n 8000C0C0C0000000FF0000FF000000FFFF00FF000000FF00FF00FFFF0000FFFF\r\n FF00FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFF\r\n FFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFF\r\n FFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFF\r\n FFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFF\r\n FFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FF0FFF0F00FF0FF0FF0F\r\n F0F0000F0FFFF00F000F0FF000FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFF\r\n FFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFF0FF0FF000FF0F0FF0FF0FF0F0FF0F0FFFF0F0FFFFF00F0FFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FF0FF000FF0F0FF0FF0F\r\n F0FF000F0FFFF0F0000FF00F0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFF\r\n FFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFF0FF0F0F00FF0F0FF0FF0FF0FFFF0F0FFFF0F0FF0FF00F0FFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FF00FF0F00FF00000000\r\n 0FF0000F0FFF000F00FF0FF000FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFF\r\n FFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFF0FF00FF0FFFFFFFFFFFFFFFFFFFFF0FFFF0FFFFFFFFFF0FFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFF0FFF\r\n FFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FF0FFF0FFFFFFFFFFFFF\r\n FFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFF\r\n FFF0FFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFF00000000000000000000000000000000000000000000000000000\r\n 000000000000000000000000000000000000000000000000000000000000FFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFF0FFF\r\n FFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFF\r\n FFF0FFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFF0FFF\r\n FFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFF\r\n FFF0FFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFF0FFFFFFFFFFFFFFFFFFFFF000000F\r\n FFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFF\r\n FFF0FFFFFFFFFFFFFFFFFFFFF000000FFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFF0FFFFFFFFFFFFFFFFFFFFFF00000F\r\n FFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFF\r\n FFF0FFFFFFFFFFFFFFFFFFFFFF0000FFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFF0FFFFFFFFFFFFFFFFFFFFFF0000FF\r\n FFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFF\r\n FFF0FFFFFFFFFFFFFFFFFFFFFFF000FFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFF0FFFFFFFFFFFFFFFFFFFFFFF000FF\r\n FFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFF\r\n FFF0FFFFFFFFFFFFFFFFFFFFFFF00FFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFF0FFF\r\n FFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFF\r\n FFF0FFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFF0FFFFFFFFF99FF9FF9FF99F99FF9F\r\n F9FF99F99FF90F9FF99F99F99FF9FF99F99F99FF9FF900000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 000000000000000000000000000FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFF\r\n FFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFF9FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFF\r\n FFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF000FFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFF9FFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFF000FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFF\r\n FFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF000FFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFF00000FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFF\r\n FFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFF9FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF00000FFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFF9FFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFF00000FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFF\r\n FFF0FFFFFFFFF99F99FF9FF9FF99F99FF9FF9FF99F99099FF9FF99F99F99FF9F\r\n F99F99F99FF9FF9FF99F99FF9FF9FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0000000FFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFF0FFF\r\n FFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFF9FFFFFFFFFFFFFFFFF0FF\r\n F0FF000F0000FF000FF000F0FFFF00FF000F0FF000FFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFF0000000FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFF\r\n FFF0FFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFF9FFFFFFFFFFFFFFF9F0FFF0F0FFFF0FF0F0FF0F0FFFF0FFFF0FF0\r\n FFFFF00F0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFF00000000FFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFF00FF\r\n FFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FF\r\n F0F0000FF000F0FF0F0000F0FFFF0FF0000FF00F0FFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFF\r\n FFF0FFFFFFFFFFFFFFFFFFFFFFF000FFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFF9FFFFFFFFFFFFFFFFF00000F0FF0FFFF0F0FF0F0FF0F0FFFF0FF0\r\n FF0FF00F0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFF0FFFFFFFFFFFFFFFFFFFFFFF000FF\r\n FFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFF9FFFFFFFFFFFFFFF9F0FF\r\n F0FF00FF0000FF000FF00FF000F000FF00FF0FF000FFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFF\r\n FFF0FFFFFFFFFFFFFFFFFFFFFFF0000FFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFF9F0FFF0FFFFFFFFFFFFFF0FFFFFFFFFFF0FFF\r\n FFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFF0FFF0FF00000\r\n 00FF000FF000F0FFFFFFFFFFFFF0FFFFFFF0FFFFFFFF0000000FFFFFFFF0000F\r\n FFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FF\r\n F0FFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFF0FFFFFFFF0FFF0F0FFF0FF0F0FF0F0FFFF0FFFFFFFFFFFFF0FFFF\r\n FFF0FFFFFFFFFFF0FFFFFFFFFF00000FFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFF9FFFFFFFFFFFFFFF9FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFF0FFF0F0000F0\r\n 00F0FF0F0000F0FFFFFFFFFFFFF0FFFFFFF0FFFFFFFFFFF0FFFFFFFFFF000000\r\n FFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF9FFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFF0FFFFFFFF00000F0FF0FFF0F0FF0F0FF0F0FFFFFFFFFFFFF0FFFF\r\n FFF0FFFFFFFFFFF0FFFFFFFFFF000000FFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFF0FFF0FF00F00\r\n 00FF000FF00FF000FFFFFFFFFFF0FFFFFFF0FFFFFFFF0000000FFFFFF0000000\r\n FFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFF9FFFFFFFFFFFFFFF9FFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFF0FFFFFFFF0FFF0FFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFF0FFFF\r\n FFF0FFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFF9FFFFFFFFFFFFFFF9FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFF0FFF0FFFFFFF\r\n FFFFFF0FFFFFFFFFFFFFFFFFFFF0FFFFFFF0FFFFFFFF0000000FFFFFFFFF0FFF\r\n FFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFF0000000FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFF\r\n FFF0FFFFFFFF0FF0FFFFFFFFFFFF0FFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFF9FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0000000FFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFF0FFFFFFFF0FF0FFFFFFFFFFFF0FFF\r\n FFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFF9FFFFFFFFFFFFFFF9FFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFF00000FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFF\r\n FFF0FFFFFFFF0FFFFFFFFFFFFFFF0FFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF00000FFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFF0FFF\r\n FFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFF9FFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFF00000FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFF\r\n FFF0FFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFF9FFFFFFFFFFFFFFF9FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF000FFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFF0FFFFFFFF0000000FFFFFFFFF0FFF\r\n FFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF9FFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFF000FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFF\r\n FFF0FFFFFFFFFF00000FFFFFFFFF0FFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF000FFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFF0FFFFFFFFFF0FFFFFFFFFFFFF0FFF\r\n FFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFF9FFFFFFFFFFFFFFF9FFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFF\r\n FFF0FFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFF9FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFF0FFFFFFFFFFF0000FFFFFFFFFFFFF\r\n FFFFFFFFFFFF0000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 000000000000000000000000000000000000000000000000000000000000FFFF\r\n FFF0FFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFF9FFFFFFFFFFFFFFF9FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFF000000FFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF9FFFFFFFFFFFFFFF9FFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFF0FFFFFFFFFF0FFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF9FFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFF0FFFFFFFFFFF000FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFF9FFFFFFFFFFFFFFF9FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFF0F0F0FFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFF0FFFFFFFFFF0F0F0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFF9FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFF00F0FFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF9FFFFFFFFFFFFFFF9FFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFF9FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFF00000FFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFF0FFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFF9FFFFFFFFFFFFFFF9FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFF0FFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF9FFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFF0FFFFFFFFFF00000FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFF0FFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0000FFFFFF9FFFFFFFFFFFFFFF9FFFF\r\n FFF000FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFF0FFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n F0000000FFFFFFFFFFFFFFFFFFF9FFF0000000FFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFF0000FFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFF000000000000000FFFFFFFFFFFFFFFF00000\r\n 000000F00000FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n F00000000FF9FFFFFFFFFFFFFFFFFF00000000FFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFF0FF00FFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF00000FFFFF9FFFFFFFFFFFFFFF9FFFF\r\n F00000FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFF0FFFFFFFFFF0F0F0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n F000FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF00FFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFF0F0F0FFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF9FFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFF0FFFFFFFFFF00000FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFF9FFFFFFFFFFFFFFF9FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF9FFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFF0FFFFFFFF0000000FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0000F000FF000FF0FFF0F0FFFFFF0F\r\n FF000F0FF000FF0F0FF0FF000FF000F0FF0F00FFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF9FFFFFFFFFFFFFFF9FFFF\r\n FF0FFF0FFFFF00FFF0FFF0F0FFFFFF0FF0FFFFF00F0FFF0F0FF0F0FF0F0FFFF0\r\n FF0F0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFF0FFFFFFFF0000000FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFF9FFFFFF0FFF0000FF00FFF0FFF0F0FFFFFF0F\r\n F0000FF00F0FFF0F0FF0F0FF0F0000F0FF0F0FFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFF00FFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FF0FFF0FF0FF00FFF00000F000FFFF0FF0FF0FF00F0FFF0F0FF0F0FF0F0FF0F0\r\n FF0F0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFF0FFFFFFFFFFF000FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFF9FFFFFFFFFFFFFFF9FFFFFF0FFFF00FF0000FF0FFF0F0FFFFFF0F\r\n FF00FF0FF000FF0F000FFF000FF00FF000F000FFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFF0FFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF9FFFF\r\n FF0FFFFFFFFF00FFF0FFF0F0FFFFFF0FFFFFFFFFFF0FFF0FFFFFFFFF0FFFFFFF\r\n FFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFF0FFFFFFFFFFF000FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFF0FFF0FFF0F0000F0000\r\n 0FFFFFFFFFFFFF0FFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFF00FFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF9FFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFF0FFFFFFFF0000000FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFF9FFFFFFFFFFFFFFF9FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFF0FF00FFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFF0FFFFFFFFFF0F0F0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFF0F0F0FFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFF0FFFFFFFFFF00000FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFF0FFFFFFFFFF00000FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFF0FFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFF0FFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFF000F0FFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFF0FFFFFFFFFF0FFF0F0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFF0FFF0F0FFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFF0FFFFFFFFFF000000FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFF0FFFFFFFF0F00000FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFF0FFFFFFFFFF00000FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFF0FFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFF0FFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFF00FFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0\r\n 0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFF0000FFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFF\r\n FFFFFFFFFFFFFFFF0FF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0000FFFF\r\n 000F0FF000FF000FF000FFFF000FF0FF0F0FF0F000F0FF0FF000FFFFF0F0FF0F\r\n 00F0FF0FFF0FF0FF0F0F0FF0FFF00FF0FFF000FF000FFFF0FF0FF00000F0FFF0\r\n 00F0F0FF0F000FFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFF00F0FF0F0FFFF0FF0FFFF0FF0F0FF\r\n 0F0FF0F0F0F0FF0F0FF0FFFF0F0F0F0F0FF0FF0FFF0FF0FF0F0F0FF0FF0FF0F0\r\n FF0FFFF0FF0FFFF0FF0FF00FF0F0FF0FF0F0F0FF0FFFF0FFFFFFFFFFFFFFFFFF\r\n FFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FF00F\r\n F00F0F0FF0F0000F0FF0FFFF0FF0F0FF0F0FF0F0F0F0FF0F0FF0FFFF0F0F0F0F\r\n 0FF0FF0FFF0FF0FF0F0F0FF0FF0FF0F0FF0000F0FF0FFFF0FF0FF0F000F0FF0F\r\n F0F0F0FF0FF00FFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFF0FFF0F0FF0F0FF0F0FF0FFFF0FF0F0FF\r\n 0F0FF0F0F0F0FF0F0FF0FFFF0F0F0F0F0FF0FF0FFF0FF0FF0F0F0FF0FF0FF0F0\r\n FF0FF0F0FF0FFFF0FF0FF0FFF0F0FF0FF0F0F0FF0F0FFFFFFFFFFFFFFFFFFFFF\r\n FFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFF\r\n F0000FF000FF00FFF000FFFF000FF0000F000F0000F000FFF000FFFF0F0F0F00\r\n 00F000FFFF000000FF0F000000F00FF000F00FFF000FFFF000000F0000F000F0\r\n 00F0F000FFF000FFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFF0FF0FFFFFFFFFFFFF0FFFFFFFFF0FFFFFFFFFFFF\r\n FFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFF0FF0FFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF00FFFFF\r\n FFFF0FFFF0FFFFFFFFF0FFFFFFFFFFFF0FFFFFFFF0FFFFFFFFFFFFFFFFFFFF0F\r\n FFF0FFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFF\r\n FFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFF0000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000090000000000000000\r\n 000000000000000000000000000000000000000000000000000000000000FFFF\r\n FFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF9FFFFFFFFF\r\n FF00FFFFFFFFFFF9FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFF9FFFFFFFFFFF00FFFFFFFFFFF9FFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFF\r\n FFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF9FFFFFFFFF\r\n FF00FFFFFFFFFFF9FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFF9FFFFFFFFFFF00FFFFFFFFFFF9FFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFF\r\n FFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF9FFFFFFFFF\r\n FF00FFFFFFFFFFF9FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFF9FFFFFFFFFFF00FFFFFFFFFFF9FFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFF\r\n FFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF9FFFFFFFFF\r\n FF00FFFFFFFFFFF9FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFF9FFFFFFFFFFF00FFFFFFFFFFF9FFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFF\r\n FFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF9FFFFFFFFF\r\n FF00FFFFFFFFFFF9FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFF9FFFFFFFFFFF00FFFFFFFFFFF9FFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFF\r\n FFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFF\r\n FFFFFFFF000FFF00FF0000FF00FF0FF0FF0FFFFFFFFFFFFFFFFFFF9FFFFFFFFF\r\n FF00FFFFFFFFFFF9FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFF0FF0F0FF0F0F0FF0FF0F0FF0\r\n FF0FFFFFFFFFFFFFFFFFFF9FFFFFFFFFFF00FFFFFFFFFFF9FFFFFFFFFFFFFFFF\r\n FFFF000FFF00FF00F00F00FF0FF0FF0FFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFF\r\n FFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFF\r\n FFFFFFFF0FF0F0FF0F0F0FF0FF0F0FF0FF0FFFFFFFFFFFFFFFFFFF9FFFFFFFFF\r\n FF00FFFFFFFFFFF9FFFFFFFFFFFFFFFFFFFF0FF0F0FF0F0FF0F0FF0F0FF0FF0F\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFF0000F0FF0F0F0FF0FF0F0FF0\r\n FF0FFFFFFFFFFFFFFFFFFF9FFFFFFFFFFF00FFFFFFFFFFF9FFFFFFFFFFFFFFFF\r\n FFFF0FF0F0FF0F0FF0F0FF0F0FF0FF0FFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFF\r\n FFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFF\r\n FFFFFFFF0FF0FF00F00000FF00FF000000FFFFFFFFFFFFFFFFFFFF9FFFFFFFFF\r\n FF00FFFFFFFFFFF9FFFFFFFFFFFFFFFFFFFF0000F0FF0F0FF0F0FF0F0FF0FF0F\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFF0FF0FFFFFF0F0FFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFF9FFFFFFFFFFF00FFFFFFFFFFF9FFFFFFFFFFFFFFFF\r\n FFFF0FF0FF00F000000F00FF000000FFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFF\r\n FFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFF\r\n FFFFFFFF000FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF9FFFFFFFFF\r\n FF00FFFFFFFFFFF9FFFFFFFFFFFFFFFFFFFF0FF0FFFFFF0FF0FFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFF9FFFFFFFFFFF00FFFFFFFFFFF9FFFFFFFFFFFFFFFF\r\n FFFF000FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFF\r\n FFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF9FFFFFFFFF\r\n FF00FFFFFFFFFFF9FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFF9FFFFFFFFFFF00FFFFFFFFFFF9FFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFF\r\n FFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF9FFFFFFFFF\r\n FF00FFFFFFFFFFF9FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFF9FFFFFFFFFFF00FFFFFFFFFFF9FFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFF\r\n FFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF9FFFFFFFFF\r\n FF00FFFFFFFFFFF9FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFF9FFFFFFFFFFF00FFFFFFFFFFF9FFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFF\r\n FFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF9FFFFFFFFF\r\n FF00FFFFFFFFFFF9FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFF000000000000000000000000000000\r\n 000000000FFFFFFFFFFFFF9FFFFFFFFFFF00FFFFFFFFFFF9FFFFFFFFFFFFFF00\r\n 00000000000000000000000000000000000000FFFFFFFFFFFFFFFFFFFFF0FFFF\r\n FFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFF\r\n FF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFF9FFFFFFFFF\r\n FF00FFFFFFFFFFF9FFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFF0FFFFFFFFFFFFFFFFFFFFF0FFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFF0FFFFFFFFFFFFF9FFFFFFFFFFF00FFFFFFFFFFF9FFFFFFFFFFFFFF0F\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFF0FFFF\r\n FFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFF\r\n FF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFF9FFFFFFFFF\r\n FF00FFFFFFFFFFF9FFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFF0FFFFFFFFFFFFFFFFFFFFF0FFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFF0FFFFFFFFFFFFF9FFFFFFFFFFF00FFFFFFFFFFF9FFFFFFFFFFFFFF0F\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFF0FFFF\r\n FFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFF\r\n FF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFF9FFFFFFFFF\r\n FF00FFFFFFFFFFF9FFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFF0FFFFFFFFFFFFFFFFFFFFF0FFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFF0FFFFFFFFFFFFF9FFFFFFFFFFF00FFFFFFFFFFF9FFFFFFFFFFFFFF0F\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFF0FFFF\r\n FFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFF\r\n FF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFF9FFFFFFFFF\r\n FF00FFFFFFFFFFF9FFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFF0FFFFFFFFFFFFFFFFFFFFF0FFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFF0FFFFFFFFFFFFF9FFFFFFFFFFF00FFFFFFFFFFF9FFFFFFFFFFFFFF0F\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFF0FFFF\r\n FFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFF\r\n FF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFF9FFFFFFFFF\r\n FF00FFFFFFFFFFF9FFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFF0FFFFFFFFFFFFFFFFFFFFF0FFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFF0FFFFFFFFFFFFF9FFFFFFFFFFF00FFFFFFFFFFF9FFFFFFFFFFFFFF0F\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFF0FFFF\r\n FFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFF\r\n FF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFF9FFFFFFFFF\r\n FF00FFFFFFFFFFF9FFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFF0FFFFFFFFFFFFFFFFFFFFF0FFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFF0FFFFFFFFFFFFF9FFFFFFFFFFF00FFFFFFFFFFF9FFFFFFFFFFFFFF0F\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFF0FFFF\r\n FFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFF\r\n FF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFF9FFFFFFFFF\r\n FF00FFFFFFFFFFF9FFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFF0FFFFFFFFFFFFFFFFFFFFF0FFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFF0FFFFFFFFFFFFF9FFFFFFFFFFF00FFFFFFFFFFF9FFFFFFFFFFFFFF0F\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFF0FFFF\r\n FFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFF\r\n FF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFF9FFFFFFFFF\r\n FF00FFFFFFFFFFF9FFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFF0FFFFFFFFFFFFFFFFFFFFF0FFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFF0FFFFFFFFFFFFF9FFFFFFFFFFF00FFFFFFFFFFF9FFFFFFFFFFFFFF0F\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFF0FFFF\r\n FFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFF\r\n FF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFF9FFFFFFFFF\r\n FF00FFFFFFFFFFF9FFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFF0FFFFFFFFFFFFFFFFFFFFF0FFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFF0FFFFFFFFFFFFF9FFFFFFFFFFF00FFFFFFFFFFF9FFFFFFFFFFFFFF0F\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFF0FFFF\r\n FFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFF\r\n FF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFF9FFFFFFFFF\r\n FF00FFFFFFFFFFF9FFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFF0FFFFFFFFFFFFFFFFFFFFF0FFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFF0FFFFFFFFFFFFF9FFFFFFFFFFF00FFFFFFFFFFF9FFFFFFFFFFFFFF0F\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFF0FFFF\r\n FFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFF\r\n FF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFF9FFFFFFFFF\r\n FF00FFFFFFFFFFF9FFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFF0FFFFFFFFFFFFFFFFFFFFF0FFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFF0FFFFFFFFFFFFF9FFFFFFFFFFF00FFFFFFFFFFF9FFFFFFFFFFFFFF0F\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFF0FFFF\r\n FFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFF\r\n FF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFF9FFFFFFFFF\r\n FF00FFFFFFFFFFF9FFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFF0FFFFFFFFFFFFFFFFFFFFF0FFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFF0FFFFFFFFFFFFF9FFFFFFFFFFF00FFFFFFFFFFF9FFFFFFFFFFFFFF0F\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFF0FFFF\r\n FFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFF\r\n FF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFF9FFFFFFFFF\r\n FF00FFFFFFFFFFF9FFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFF0FFFFFFFFFFFFFFFFFFFFF0FFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFF0FFFFFFFFFFFFF9FFFFFFFFFFF00FFFFFFFFFFF9FFFFFFFFFFFFFF0F\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFF0FFFF\r\n FFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFF\r\n FF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFF9FFF00000F\r\n FF00FFFFFFFFFFF9FFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFF0FFFFFFFFFFFFFFFFFFFFF0FFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFF0FFFFFFFFFFFFF9FF0FFFFF0FF00FFFF00000FF9FFFFFFFFFFFFFF0F\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFF0FFFF\r\n FFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFF\r\n FF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFF9FF0FFFFF0\r\n FF00FFF0FFFFF0F9FFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFF0FFFFFFFFFFFFFFFFFFFFF0FFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFF0FFFFFF0000000FFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFF0FFFFFFFFFFFFF9FF0FF0FF0FF00FFF0FFFFF0F9FFFFFFFFFFFFFF0F\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFF0000000FFFFFFFFF0FFFF\r\n FFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFF0FF0FFFFFFFFF\r\n FF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFF9FFF0F000F\r\n FF00FFF0FF0FF0F9FFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFF0FFFFF0FF0FFFFFFFFFFFF0FFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFF0FFFFFF0FF0FFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFF0FFFFFFFFFFFFF9FFFFFFFFFFF00FFFF0F000FF9FFFFFFFFFFFFFF0F\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFF0FF0FFFFFFFFFFFF0FFFF\r\n FFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFF0FF00FFFFFFFF\r\n FF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFF0000000FFF9FFFF0000F\r\n FF00FFFFFFFFFFF9FFF0000000FFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFF0FFFFF0FF00FFFFFFFFFFF0FFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFF0FFFFFFF00FF00FFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFF0FFFFFFFFF0FFF9FFFFFFFF0FF00FFFFF0000FF9FFFFFFFFF0FFFF0F\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFF00FF00FFFFFFFFF0FFFF\r\n FFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFF0F00000FFFFFF\r\n FF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFF0FFF9FFFFFFFF0\r\n FF00FFFFFFFFF0F9FFFFFFFFF0FFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFF0FFFFF0F00000FFFFFFFFF0FFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFF0FFFFFFFFF0FFF9FFFF00000FF00FFFFFFFFF0F9FFFFFFFFF0FFFF0F\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFF0FFFF\r\n FFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFF000F0FFFFF\r\n FF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFF000FFFF9FFFF0FFFF\r\n FF00FFFFF00000F9FFFFFF000FFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFF0FFFFFFFF000F0FFFFFFFF0FFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFF0FFFFFFFF0FFF0F0FFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFF0FFFFF0F0F0FFF9FFF000000FF00FFFFF0FFFFF9FFFFF0F0F0FFFF0F\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFF0FFF0F0FFFFFFF0FFFF\r\n FFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFF0FFF0F0FFFF\r\n FF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFF0F0F0FFF9FFFF0FFF0\r\n FF00FFFF000000F9FFFFF0F0F0FFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFF0FFFFFFF0FFF0F0FFFFFFF0FFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFF0FFFFFFFF000000FFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFF0FFFFFF00F0FFF9FFF000000FF00FFFFF0FFF0F9FFFFFF00F0FFFF0F\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFF000000FFFFFFFF0FFFF\r\n FFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFF\r\n FF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFF9FFFF0FFF0\r\n FF00FFFF000000F9FFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFF0FFFFFFFFFFFFFFFFFFFFF0FFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFF0FFFFFF0000000FFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFF0FFFFF0FFFFFFF9FFFFFFFFFFF00FFFFF0FFF0F9FFFFF0FFFFFFFF0F\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFF0000000FFFFFFFFF0FFFF\r\n FFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFF0FFFFFFFFFF\r\n FF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFF000000FFF9FFFFF000F\r\n FF00FFFFFFFFFFF9FFFF000000FFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFF0FFFFFFF0FFFFFFFFFFFFF0FFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFF0FFFFFFFF0FFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFF0FFF0F0FFFFFFF9FFFF0F0F0FF00FFFFFF000FF9FFF0000000FFFF0F\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFF0FFFFFFFFFFFFF0FFFF\r\n FFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFF0000FFFFFF\r\n FF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFF000000FFF9FFFF0F0F0\r\n FF00FFFFF0F0F0F9FFFFF0FFF0FFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFF0FFFFFFFF0000FFFFFFFFF0FFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFF0FFFFFFFF0FFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFF0FFFFF0FFF0FFF9FFFFF00F0FF00FFFFF0F0F0F9FFFFFFFFFFFFFF0F\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFF0FFFFFFFFFFFFF0FFFF\r\n FFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFF000000FFFFFF\r\n FF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFF9FFFFFFFFF\r\n FF00FFFFFF00F0F9FFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFF0FFFFFF000000FFFFFFFFF0FFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFF0FFFFFFFF0FFF0FFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFF0FFFFFFFFFFFFF9FFFF00000FF00FFFFFFFFFFF9FFFFFFFFFFFFFF0F\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFF0FFF0FFFFFFFFF0FFFF\r\n FFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFF\r\n FF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFF9FFFF0FFFF\r\n FF00FFFFF00000F9FFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFF0FFFFFFFFFFFFFFFFFFFFF0FFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFF0FFFFFFFFFFFFF9FFFF0FFFFFF00FFFFF0FFFFF9FFFFFFFFFFFFFF0F\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFF0FFFF\r\n FFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFF\r\n FF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFF9FFFFFFFFF\r\n FF00FFFFF0FFFFF9FFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFF0FFFFFFFFFFFFFFFFFFFFF0FFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFF0FFFFFFFFFFFFF9FFFFFFFFFFF00FFFFFFFFFFF9FFFFFFFFFFFFFF0F\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFF0FFFF\r\n FFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFF\r\n FF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFF9FFFFFFFFF\r\n FF00FFFFFFFFFFF9FFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFF0FFFFFFFFFFFFFFFFFFFFF0FFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFF0FFFFFFFFFFFFF9FFFFFFFFFFF00FFFFFFFFFFF9FFFFFFFFFFFFFF0F\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFF0FFFF\r\n FFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFF\r\n FF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFF9FFFFFFFFF\r\n FF00FFFFFFFFFFF9FFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFF0FFFFFFFFFFFFFFFFFFFFF0FFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFF0FFFFFFFFFFFFF9FFFFFFFFFFF00FFFFFFFFFFF9FFFFFFFFFFFFFF0F\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFF0FFFF\r\n FFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFF\r\n FF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFF9FFFFFFFFF\r\n FF00FFFFFFFFFFF9FFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFF0FFFFFFFFFFFFFFFFFFFFF0FFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFF0FFFFFFFFFFFFF9FFFFFFFFFFF00FFFFFFFFFFF9FFFFFFFFFFFFFF0F\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFF0FFFF\r\n FFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFF\r\n FF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFF9FFFFFFFFF\r\n FF00FFFFFFFFFFF9FFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFF0FFFFFFFFFFFFFFFFFFFFF0FFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFF0FFFFFFFFFFFFF9FFFFFFFFFFF00FFFFFFFFFFF9FFFFFFFFFFFFFF0F\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFF0FFFF\r\n FFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFF\r\n FF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFF9FFFFFFFFF\r\n FF00FFFFFFFFFFF9FFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFF0FFFFFFFFFFFFFFFFFFFFF0FFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFF0FFFFFFFFFFFFF9FFFFFFFFFFF00FFFFFFFFFFF9FFFFFFFFFFFFFF0F\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFF0FFFF\r\n FFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFF\r\n FF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFF9FFFFFFFFF\r\n FF00FFFFFFFFFFF9FFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFF0FFFFFFFFFFFFFFFFFFFFF0FFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFF0FFFFFFFFFFFFF9FFFFFFFFFFF00FFFFFFFFFFF9FFFFFFFFFFFFFF0F\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFF0FFFF\r\n FFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFF\r\n FF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFF9FFFFFFFFF\r\n FF00FFFFFFFFFFF9FFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFF0FFFFFFFFFFFFFFFFFFFFF0FFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFF0FFFFFFFFFFFFF9FFFFFFFFFFF00FFFFFFFFFFF9FFFFFFFFFFFFFF0F\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFF0FFFF\r\n FFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFF\r\n FF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFF9FFFFFFFFF\r\n FF00FFFFFFFFFFF9FFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFF0FFFFFFFFFFFFFFFFFFFFF0FFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFF0FFFFFFFFFFFFF9FFFFFFFFFFF00FFFFFFFFFFF9FFFFFFFFFFFFFF0F\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFF0FFFF\r\n FFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFF\r\n FF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFF9FFFFFFFFF\r\n FF00FFFFFFFFFFF9FFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFF0FFFFFFFFFFFFFFFFFFFFF0FFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFF0FFFFFFFFFFFFF9FFFFFFFFFFF00FFFFFFFFFFF9FFFFFFFFFFFFFF0F\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFF0FFFF\r\n FFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFF\r\n FF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFF9FFFFFFFFF\r\n FF00FFFFFFFFFFF9FFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFF0FFFFFFFFFFFFFFFFFFFFF0FFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFF0FFFFFFFFFFFFF9FFFFFFFFFFF00FFFFFFFFFFF9FFFFFFFFFFFFFF0F\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFF0FFFF\r\n FFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFF\r\n FF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFF9FFFFFFFFF\r\n FF00FFFFFFFFFFF9FFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFF0FFFFFFFFFFFFFFFFFFFFF0FFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFF0FFFFFFFFFFFFF9FFFFFFFFFFF00FFFFFFFFFFF9FFFFFFFFFFFFFF0F\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFF0FFFF\r\n FFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFF\r\n FF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFF9FFFFFFFFF\r\n FF00FFFFFFFFFFF9FFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFF0FFFFFFFFFFFFFFFFFFFFF0FFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFF000000000000000000000000000000\r\n 000000000FFFFFFFFFFFFF9FFFFFFFFFFF00FFFFFFFFFFF9FFFFFFFFFFFFFF00\r\n 00000000000000000000000000000000000000FFFFFFFFFFFFFFFFFFFFF0FFFF\r\n FFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF9FFFFFFFFF\r\n FF00FFFFFFFFFFF9FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFF9FFFFFFFFFFF00FFFFFFFFFFF9FFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFF\r\n FFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF9FFFFFFFFF\r\n FF00FFFFFFFFFFF9FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFF9FFFFFFFFFFF00FFFFFFFFFFF9FFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFF\r\n FFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF9FFFFFFFFF\r\n FF00FFFFFFFFFFF9FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFF9FFFFFFFFFFF00FFFFFFFFFFF9FFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFF\r\n FFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF9FFFFFFFFF\r\n FF00FFFFFFFFFFF9FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFF9FFFFFFFFFFF00FFFFFFFFFFF9FFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFF\r\n FFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFF9FFFFFFFFF\r\n FF00FFFFFFFFFFF9FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFF9FFFFFFFFFFF00FFFFFFFFFFF9FFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFF\r\n FFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFF0FFFF00FF000FFFFFFFFFFFFFFFFFFFFFFFFFFF9FFFFFFFFF\r\n FF00FFFFFFFFFFF9FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFF0FF0F0FF0FFFF\r\n FFFFFFFFFFFFFFFFFFFFFF9FFFFFFFFFFF00FFFFFFFFFFF9FFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFF0FFF00FF000FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFF\r\n FFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFF0FFF0FF0F0FF0FFFFFFFFFFFFFFFFFFFFFFFFFF9FFFFFFFFF\r\n FF00FFFFFFFFFFF9FFFFFFFFFFFFFFFFFFFFFFFFFFFF0FF0FF0F0FF0FFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFF0FF0F0FF0FFFF\r\n FFFFFFFFFFFFFFFFFFFFFF9FFFFFFFFFFF00FFFFFFFFFFF9FFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFF0FF0FF0F0FF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFF\r\n FFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFF0FFFF00FF000FFFFFFFFFFFFFFFFFFFFFFFFFFF9FFFFFFFFF\r\n FF00FFFFFFFFFFF9FFFFFFFFFFFFFFFFFFFFFFFFFFFF0FF0FF0F0FF0FFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFF9FFFFFFFFFFF00FFFFFFFFFFF9FFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFF0FFF00FF000FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFF\r\n FFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFF00000FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF9FFFFFFFFF\r\n FF00FFFFFFFFFFF9FFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFF9FFFFFFFFFFF00FFFFFFFFFFF9FFFFFFFFFFFFFFFF\r\n FFFFFFFFFF00000FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFF\r\n FFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF9FFFFFFFFF\r\n FF00FFFFFFFFFFF9FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFF9FFFFFFFFFFF00FFFFFFFFFFF9FFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFF\r\n FFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF9FFFFFFFFF\r\n FF00FFFFFFFFFFF9FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFF9FFFFFFFFFFF00FFFFFFFFFFF9FFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFF\r\n FFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF9FFFFFFFFF\r\n FF00FFFFFFFFFFF9FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFF9FFFFFFFFFFF00FFFFFFFFFFF9FFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFF\r\n FFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF9FFFFFFFFF\r\n FF00FFFFFFFFFFF9FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFF0000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000900000000000000000000000000000000000000000\r\n 000000000000000000000000000000000000000000000000000000000000FFFF\r\n FFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF00FFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFF00FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFF0FF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FF0FFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFF0000FF000FF00\r\n 0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFF0FFFF0000FF000FF000FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFF0FFFF0FF0F0FF0F0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFF0FF0F0FF0F0FFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFF000F0FF0F000\r\n 0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFF0FFFFF000F0FF0F0000FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFF0000FFFF0F0FF0F0FF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0000FFFF0F0FF0F0FF0FFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FF0F0000FF000FF00\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFF0FF0F0000FF000FF00FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFF0FF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FF0FFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0000FFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFF0000FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF00000FF\r\n 0FF000F0FF0FFFF0FF0FF000F0FF0FF0000FFF000F0FFF000FF000FFFFFFFFFF\r\n FFFFFFFFFFFF000FF0FF0FF000FFF0FF000F0FF0FFFF0FF0FF000F0FF0FF0F00\r\n 0FFF000F0FFF000F000FFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFF0FFFFF0F00FFFF0FF0FFFF0FF0F0FF0F0FF0FF0\r\n 0FF0F0FFFF0FF0FFFF0FF0FFFFFFFFFFFFFFFFFFFFF0FFF0F0FF0F0FFFFF0F00\r\n FFFF0FF0FFFF0FF0F0FF0F0FF0FF0F0FF0F0FFFF0FF0FFF0FF0FFFFFFFFFFFFF\r\n FFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFF0\r\n F00000F0FF0FFFF0FF0F0FF0F0FF0FF00FF0F0000F0FF0000F0FF0FFFFFFFFFF\r\n FFFFFFFFFFF0FFF0F0FF0F0000FF0F00000F0FF0FFFF0FF0F0FF0F0FF0FF0F0F\r\n F0F0000F0FF00000FF0FFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFF00000F0F00FF0F0FF0FFFF0FF0F0FF0F0FF0FF0\r\n 0FF0F0FF0F0FF0FF0F0FF0FFFFFFFFFFFFFFFFFFFFF0FFF0F0FF0F0FF0FF0F00\r\n FF0F0FF0FFFF0FF0F0FF0F0FF0FF0F0FF0F0FF0F0FF0FF00FF0FFFFFFFFFFFFF\r\n FFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFF0F\r\n FF000FF000FFFFF000FF0FF0F000000F000FFF00FF000F00FFF000FFFFFFFFFF\r\n FFFFFFFFFFF0FFF0F000FFF00FF0FFF000FF000FFFFF000FF0FF0F000000FF00\r\n 0FFF00FF000F00FF000FFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n 0FFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFF0FFF0FFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFF\r\n FFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF00000FF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFF0FFFFFFFFFF\r\n FFFFFFFFFFF0FFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0F\r\n FFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFF0}\r\n end\r\n object Label1: TLabel\r\n Left = 10\r\n Top = 44\r\n Width = 21\r\n Height = 13\r\n Caption = 'Left:'\r\n end\r\n object Label2: TLabel\r\n Left = 10\r\n Top = 69\r\n Width = 28\r\n Height = 13\r\n Caption = 'Right:'\r\n end\r\n object Label3: TLabel\r\n Left = 10\r\n Top = 94\r\n Width = 22\r\n Height = 13\r\n Caption = 'Top:'\r\n end\r\n object Label4: TLabel\r\n Left = 10\r\n Top = 119\r\n Width = 36\r\n Height = 13\r\n Caption = 'Bottom:'\r\n end\r\n object Label5: TLabel\r\n Left = 10\r\n Top = 14\r\n Width = 27\r\n Height = 13\r\n Caption = 'Units:'\r\n end\r\n object Label6: TLabel\r\n Left = 10\r\n Top = 174\r\n Width = 38\r\n Height = 13\r\n Caption = 'Header:'\r\n end\r\n object Label7: TLabel\r\n Left = 10\r\n Top = 199\r\n Width = 33\r\n Height = 13\r\n Caption = 'Footer:'\r\n end\r\n object Label8: TLabel\r\n Left = 10\r\n Top = 224\r\n Width = 84\r\n Height = 13\r\n Caption = 'HFInternalMargin:'\r\n end\r\n object Label9: TLabel\r\n Left = 10\r\n Top = 249\r\n Width = 86\r\n Height = 13\r\n Caption = 'LeftHFTextIndent:'\r\n end\r\n object Label10: TLabel\r\n Left = 10\r\n Top = 274\r\n Width = 93\r\n Height = 13\r\n Caption = 'RightHFTextIndent:'\r\n end\r\n object Label11: TLabel\r\n Left = 10\r\n Top = 144\r\n Width = 29\r\n Height = 13\r\n Caption = 'Gutter'\r\n end\r\n object OKBtn: TButton\r\n Left = 344\r\n Top = 310\r\n Width = 75\r\n Height = 25\r\n Caption = 'OK'\r\n Default = True\r\n ModalResult = 1\r\n TabOrder = 12\r\n end\r\n object CancelBtn: TButton\r\n Left = 424\r\n Top = 310\r\n Width = 75\r\n Height = 25\r\n Cancel = True\r\n Caption = 'Cancel'\r\n ModalResult = 2\r\n TabOrder = 13\r\n end\r\n object CBMirrorMargins: TCheckBox\r\n Left = 10\r\n Top = 300\r\n Width = 97\r\n Height = 17\r\n Caption = 'Mirror margins'\r\n TabOrder = 11\r\n end\r\n object EditLeft: TEdit\r\n Left = 110\r\n Top = 40\r\n Width = 151\r\n Height = 21\r\n TabOrder = 1\r\n end\r\n object EditRight: TEdit\r\n Left = 110\r\n Top = 65\r\n Width = 151\r\n Height = 21\r\n TabOrder = 2\r\n end\r\n object EditTop: TEdit\r\n Left = 110\r\n Top = 90\r\n Width = 151\r\n Height = 21\r\n TabOrder = 3\r\n end\r\n object EditBottom: TEdit\r\n Left = 110\r\n Top = 115\r\n Width = 151\r\n Height = 21\r\n TabOrder = 4\r\n end\r\n object EditGutter: TEdit\r\n Left = 110\r\n Top = 140\r\n Width = 151\r\n Height = 21\r\n TabOrder = 5\r\n end\r\n object EditHeader: TEdit\r\n Left = 110\r\n Top = 170\r\n Width = 151\r\n Height = 21\r\n TabOrder = 6\r\n end\r\n object EditFooter: TEdit\r\n Left = 110\r\n Top = 195\r\n Width = 151\r\n Height = 21\r\n TabOrder = 7\r\n end\r\n object EditHFInternalMargin: TEdit\r\n Left = 110\r\n Top = 220\r\n Width = 151\r\n Height = 21\r\n TabOrder = 8\r\n end\r\n object EditLeftHFTextIndent: TEdit\r\n Left = 110\r\n Top = 245\r\n Width = 151\r\n Height = 21\r\n TabOrder = 9\r\n end\r\n object EditRightHFTextIndent: TEdit\r\n Left = 110\r\n Top = 270\r\n Width = 151\r\n Height = 21\r\n TabOrder = 10\r\n end\r\n object CBUnits: TComboBox\r\n Left = 110\r\n Top = 10\r\n Width = 151\r\n Height = 21\r\n Style = csDropDownList\r\n ItemHeight = 13\r\n TabOrder = 0\r\n OnChange = CBUnitsChange\r\n Items.Strings = (\r\n 'mm'\r\n 'cm'\r\n 'Inches'\r\n 'Thousandths Of Inches')\r\n end\r\nend\r\n" }, { "path": "External/SynEdit/Source/QSynEditPrintMarginsDialog.pas", "content": "unit QSynEditPrintMarginsDialog;\r\n\r\n{$DEFINE SYN_CLX}\r\n{$DEFINE QSYNEDITPRINTMARGINSDIALOG}\r\n\r\n{$I SynEditPrintMarginsDialog.pas}\r\n" }, { "path": "External/SynEdit/Source/QSynEditPrintPreview.pas", "content": "unit QSynEditPrintPreview;\r\n\r\n{$DEFINE SYN_CLX}\r\n{$DEFINE QSYNEDITPRINTPREVIEW}\r\n\r\n{$I SynEditPrintPreview.pas}\r\n" }, { "path": "External/SynEdit/Source/QSynEditPrintTypes.pas", "content": "unit QSynEditPrintTypes;\r\n\r\n{$DEFINE SYN_CLX}\r\n{$DEFINE QSYNEDITPRINTTYPES}\r\n\r\n{$I SynEditPrintTypes.pas}\r\n" }, { "path": "External/SynEdit/Source/QSynEditPrinterInfo.pas", "content": "unit QSynEditPrinterInfo;\r\n\r\n{$DEFINE SYN_CLX}\r\n{$DEFINE QSYNEDITPRINTERINFO}\r\n\r\n{$I SynEditPrinterInfo.pas}\r\n" }, { "path": "External/SynEdit/Source/QSynEditPropertyReg.pas", "content": "unit QSynEditPropertyReg;\r\n\r\n{$DEFINE SYN_CLX}\r\n{$DEFINE QSYNEDITPROPERTYREG}\r\n\r\n{$I SynEditPropertyReg.pas}\r\n" }, { "path": "External/SynEdit/Source/QSynEditPythonBehaviour.pas", "content": "unit QSynEditPythonBehaviour;\r\n\r\n{$DEFINE SYN_CLX}\r\n{$DEFINE QSYNEDITPYTHONBEHAVIOUR}\r\n\r\n{$I SynEditPythonBehaviour.pas}\r\n" }, { "path": "External/SynEdit/Source/QSynEditReg.pas", "content": "unit QSynEditReg;\r\n\r\n{$DEFINE SYN_CLX}\r\n{$DEFINE QSYNEDITREG}\r\n\r\n{$I SynEditReg.pas}\r\n" }, { "path": "External/SynEdit/Source/QSynEditRegexSearch.pas", "content": "unit QSynEditRegexSearch;\r\n\r\n{$DEFINE SYN_CLX}\r\n{$DEFINE QSYNEDITREGEXSEARCH}\r\n\r\n{$I SynEditRegexSearch.pas}\r\n" }, { "path": "External/SynEdit/Source/QSynEditSearch.pas", "content": "unit QSynEditSearch;\r\n\r\n{$DEFINE SYN_CLX}\r\n{$DEFINE QSYNEDITSEARCH}\r\n\r\n{$I SynEditSearch.pas}\r\n" }, { "path": "External/SynEdit/Source/QSynEditStrConst.pas", "content": "unit QSynEditStrConst;\r\n\r\n{$DEFINE SYN_CLX}\r\n{$DEFINE QSYNEDITSTRCONST}\r\n\r\n{$I SynEditStrConst.pas}\r\n" }, { "path": "External/SynEdit/Source/QSynEditTextBuffer.pas", "content": "unit QSynEditTextBuffer;\r\n\r\n{$DEFINE SYN_CLX}\r\n{$DEFINE QSYNEDITTEXTBUFFER}\r\n\r\n{$I SynEditTextBuffer.pas}\r\n" }, { "path": "External/SynEdit/Source/QSynEditTypes.pas", "content": "unit QSynEditTypes;\r\n\r\n{$DEFINE SYN_CLX}\r\n{$DEFINE QSYNEDITTYPES}\r\n\r\n{$I SynEditTypes.pas}\r\n" }, { "path": "External/SynEdit/Source/QSynEditWildcardSearch.pas", "content": "unit QSynEditWildcardSearch;\r\n\r\n{$DEFINE SYN_CLX}\r\n{$DEFINE QSYNEDITWILDCARDSEARCH}\r\n\r\n{$I SynEditWildcardSearch.pas}\r\n" }, { "path": "External/SynEdit/Source/QSynEditWordWrap.pas", "content": "unit QSynEditWordWrap;\r\n\r\n{$DEFINE SYN_CLX}\r\n{$DEFINE QSYNEDITWORDWRAP}\r\n\r\n{$I SynEditWordWrap.pas}\r\n" }, { "path": "External/SynEdit/Source/QSynExportHTML.pas", "content": "unit QSynExportHTML;\r\n\r\n{$DEFINE SYN_CLX}\r\n{$DEFINE QSYNEXPORTHTML}\r\n\r\n{$I SynExportHTML.pas}\r\n" }, { "path": "External/SynEdit/Source/QSynExportRTF.pas", "content": "unit QSynExportRTF;\r\n\r\n{$DEFINE SYN_CLX}\r\n{$DEFINE QSYNEXPORTRTF}\r\n\r\n{$I SynExportRTF.pas}\r\n" }, { "path": "External/SynEdit/Source/QSynExportTeX.pas", "content": "unit QSynExportTeX;\r\n\r\n{$DEFINE SYN_CLX}\r\n{$DEFINE QSYNEXPORTTEX}\r\n\r\n{$I SynExportTeX.pas}\r\n" }, { "path": "External/SynEdit/Source/QSynHighlighterADSP21xx.pas", "content": "unit QSynHighlighterADSP21xx;\r\n\r\n{$DEFINE SYN_CLX}\r\n{$DEFINE QSYNHIGHLIGHTERADSP21XX}\r\n\r\n{$I SynHighlighterADSP21xx.pas}\r\n" }, { "path": "External/SynEdit/Source/QSynHighlighterAWK.pas", "content": "unit QSynHighlighterAWK;\r\n\r\n{$DEFINE SYN_CLX}\r\n{$DEFINE QSYNHIGHLIGHTERAWK}\r\n\r\n{$I SynHighlighterAWK.pas}\r\n" }, { "path": "External/SynEdit/Source/QSynHighlighterAsm.pas", "content": "unit QSynHighlighterAsm;\r\n\r\n{$DEFINE SYN_CLX}\r\n{$DEFINE QSYNHIGHLIGHTERASM}\r\n\r\n{$I SynHighlighterAsm.pas}\r\n" }, { "path": "External/SynEdit/Source/QSynHighlighterBaan.pas", "content": "unit QSynHighlighterBaan;\r\n\r\n{$DEFINE SYN_CLX}\r\n{$DEFINE QSYNHIGHLIGHTERBAAN}\r\n\r\n{$I SynHighlighterBaan.pas}\r\n" }, { "path": "External/SynEdit/Source/QSynHighlighterBat.pas", "content": "unit QSynHighlighterBat;\r\n\r\n{$DEFINE SYN_CLX}\r\n{$DEFINE QSYNHIGHLIGHTERBAT}\r\n\r\n{$I SynHighlighterBat.pas}\r\n" }, { "path": "External/SynEdit/Source/QSynHighlighterCAC.pas", "content": "unit QSynHighlighterCAC;\r\n\r\n{$DEFINE SYN_CLX}\r\n{$DEFINE QSYNHIGHLIGHTERCAC}\r\n\r\n{$I SynHighlighterCAC.pas}\r\n" }, { "path": "External/SynEdit/Source/QSynHighlighterCPM.pas", "content": "unit QSynHighlighterCPM;\r\n\r\n{$DEFINE SYN_CLX}\r\n{$DEFINE QSYNHIGHLIGHTERCPM}\r\n\r\n{$I SynHighlighterCPM.pas}\r\n" }, { "path": "External/SynEdit/Source/QSynHighlighterCS.pas", "content": "unit QSynHighlighterCS;\r\n\r\n{$DEFINE SYN_CLX}\r\n{$DEFINE QSYNHIGHLIGHTERCS}\r\n\r\n{$I SynHighlighterCS.pas}\r\n" }, { "path": "External/SynEdit/Source/QSynHighlighterCache.pas", "content": "unit QSynHighlighterCache;\r\n\r\n{$DEFINE SYN_CLX}\r\n{$DEFINE QSYNHIGHLIGHTERCACHE}\r\n\r\n{$I SynHighlighterCache.pas}\r\n" }, { "path": "External/SynEdit/Source/QSynHighlighterCobol.pas", "content": "unit QSynHighlighterCobol;\r\n\r\n{$DEFINE SYN_CLX}\r\n{$DEFINE QSYNHIGHLIGHTERCOBOL}\r\n\r\n{$I SynHighlighterCobol.pas}\r\n" }, { "path": "External/SynEdit/Source/QSynHighlighterCpp.pas", "content": "unit QSynHighlighterCpp;\r\n\r\n{$DEFINE SYN_CLX}\r\n{$DEFINE QSYNHIGHLIGHTERCPP}\r\n\r\n{$I SynHighlighterCpp.pas}\r\n" }, { "path": "External/SynEdit/Source/QSynHighlighterCss.pas", "content": "unit QSynHighlighterCss;\r\n\r\n{$DEFINE SYN_CLX}\r\n{$DEFINE QSYNHIGHLIGHTERCSS}\r\n\r\n{$I SynHighlighterCss.pas}\r\n" }, { "path": "External/SynEdit/Source/QSynHighlighterDOT.pas", "content": "unit QSynHighlighterDOT;\r\n\r\n{$DEFINE SYN_CLX}\r\n{$DEFINE QSYNHIGHLIGHTERDOT}\r\n\r\n{$I SynHighlighterDOT.pas}\r\n" }, { "path": "External/SynEdit/Source/QSynHighlighterDfm.pas", "content": "unit QSynHighlighterDfm;\r\n\r\n{$DEFINE SYN_CLX}\r\n{$DEFINE QSYNHIGHLIGHTERDFM}\r\n\r\n{$I SynHighlighterDfm.pas}\r\n" }, { "path": "External/SynEdit/Source/QSynHighlighterDml.pas", "content": "unit QSynHighlighterDml;\r\n\r\n{$DEFINE SYN_CLX}\r\n{$DEFINE QSYNHIGHLIGHTERDML}\r\n\r\n{$I SynHighlighterDml.pas}\r\n" }, { "path": "External/SynEdit/Source/QSynHighlighterEiffel.pas", "content": "unit QSynHighlighterEiffel;\r\n\r\n{$DEFINE SYN_CLX}\r\n{$DEFINE QSYNHIGHLIGHTEREIFFEL}\r\n\r\n{$I SynHighlighterEiffel.pas}\r\n" }, { "path": "External/SynEdit/Source/QSynHighlighterFortran.pas", "content": "unit QSynHighlighterFortran;\r\n\r\n{$DEFINE SYN_CLX}\r\n{$DEFINE QSYNHIGHLIGHTERFORTRAN}\r\n\r\n{$I SynHighlighterFortran.pas}\r\n" }, { "path": "External/SynEdit/Source/QSynHighlighterFoxpro.pas", "content": "unit QSynHighlighterFoxpro;\r\n\r\n{$DEFINE SYN_CLX}\r\n{$DEFINE QSYNHIGHLIGHTERFOXPRO}\r\n\r\n{$I SynHighlighterFoxpro.pas}\r\n" }, { "path": "External/SynEdit/Source/QSynHighlighterGWS.pas", "content": "unit QSynHighlighterGWS;\r\n\r\n{$DEFINE SYN_CLX}\r\n{$DEFINE QSYNHIGHLIGHTERGWS}\r\n\r\n{$I SynHighlighterGWS.pas}\r\n" }, { "path": "External/SynEdit/Source/QSynHighlighterGalaxy.pas", "content": "unit QSynHighlighterGalaxy;\r\n\r\n{$DEFINE SYN_CLX}\r\n{$DEFINE QSYNHIGHLIGHTERGALAXY}\r\n\r\n{$I SynHighlighterGalaxy.pas}\r\n" }, { "path": "External/SynEdit/Source/QSynHighlighterGeneral.pas", "content": "unit QSynHighlighterGeneral;\r\n\r\n{$DEFINE SYN_CLX}\r\n{$DEFINE QSYNHIGHLIGHTERGENERAL}\r\n\r\n{$I SynHighlighterGeneral.pas}\r\n" }, { "path": "External/SynEdit/Source/QSynHighlighterHC11.pas", "content": "unit QSynHighlighterHC11;\r\n\r\n{$DEFINE SYN_CLX}\r\n{$DEFINE QSYNHIGHLIGHTERHC11}\r\n\r\n{$I SynHighlighterHC11.pas}\r\n" }, { "path": "External/SynEdit/Source/QSynHighlighterHP48.pas", "content": "unit QSynHighlighterHP48;\r\n\r\n{$DEFINE SYN_CLX}\r\n{$DEFINE QSYNHIGHLIGHTERHP48}\r\n\r\n{$I SynHighlighterHP48.pas}\r\n" }, { "path": "External/SynEdit/Source/QSynHighlighterHashEntries.pas", "content": "unit QSynHighlighterHashEntries;\r\n\r\n{$DEFINE SYN_CLX}\r\n{$DEFINE QSYNHIGHLIGHTERHASHENTRIES}\r\n\r\n{$I SynHighlighterHashEntries.pas}\r\n" }, { "path": "External/SynEdit/Source/QSynHighlighterHaskell.pas", "content": "unit QSynHighlighterHaskell;\r\n\r\n{$DEFINE SYN_CLX}\r\n{$DEFINE QSYNHIGHLIGHTERHASKELL}\r\n\r\n{$I SynHighlighterHaskell.pas}\r\n" }, { "path": "External/SynEdit/Source/QSynHighlighterHtml.pas", "content": "unit QSynHighlighterHtml;\r\n\r\n{$DEFINE SYN_CLX}\r\n{$DEFINE QSYNHIGHLIGHTERHTML}\r\n\r\n{$I SynHighlighterHtml.pas}\r\n" }, { "path": "External/SynEdit/Source/QSynHighlighterIDL.pas", "content": "unit QSynHighlighterIDL;\r\n\r\n{$DEFINE SYN_CLX}\r\n{$DEFINE QSYNHIGHLIGHTERIDL}\r\n\r\n{$I SynHighlighterIDL.pas}\r\n" }, { "path": "External/SynEdit/Source/QSynHighlighterIni.pas", "content": "unit QSynHighlighterIni;\r\n\r\n{$DEFINE SYN_CLX}\r\n{$DEFINE QSYNHIGHLIGHTERINI}\r\n\r\n{$I SynHighlighterIni.pas}\r\n" }, { "path": "External/SynEdit/Source/QSynHighlighterInno.pas", "content": "unit QSynHighlighterInno;\r\n\r\n{$DEFINE SYN_CLX}\r\n{$DEFINE QSYNHIGHLIGHTERINNO}\r\n\r\n{$I SynHighlighterInno.pas}\r\n" }, { "path": "External/SynEdit/Source/QSynHighlighterJScript.pas", "content": "unit QSynHighlighterJScript;\r\n\r\n{$DEFINE SYN_CLX}\r\n{$DEFINE QSYNHIGHLIGHTERJSCRIPT}\r\n\r\n{$I SynHighlighterJScript.pas}\r\n" }, { "path": "External/SynEdit/Source/QSynHighlighterJava.pas", "content": "unit QSynHighlighterJava;\r\n\r\n{$DEFINE SYN_CLX}\r\n{$DEFINE QSYNHIGHLIGHTERJAVA}\r\n\r\n{$I SynHighlighterJava.pas}\r\n" }, { "path": "External/SynEdit/Source/QSynHighlighterKix.pas", "content": "unit QSynHighlighterKix;\r\n\r\n{$DEFINE SYN_CLX}\r\n{$DEFINE QSYNHIGHLIGHTERKIX}\r\n\r\n{$I SynHighlighterKix.pas}\r\n" }, { "path": "External/SynEdit/Source/QSynHighlighterLDraw.pas", "content": "unit QSynHighlighterLDraw;\r\n\r\n{$DEFINE SYN_CLX}\r\n{$DEFINE QSYNHIGHLIGHTERLDRAW}\r\n\r\n{$I SynHighlighterLDraw.pas}\r\n" }, { "path": "External/SynEdit/Source/QSynHighlighterM3.pas", "content": "unit QSynHighlighterM3;\r\n\r\n{$DEFINE SYN_CLX}\r\n{$DEFINE QSYNHIGHLIGHTERM3}\r\n\r\n{$I SynHighlighterM3.pas}\r\n" }, { "path": "External/SynEdit/Source/QSynHighlighterManager.pas", "content": "unit QSynHighlighterManager;\r\n\r\n{$DEFINE SYN_CLX}\r\n{$DEFINE QSYNHIGHLIGHTERMANAGER}\r\n\r\n{$I SynHighlighterManager.pas}\r\n" }, { "path": "External/SynEdit/Source/QSynHighlighterModelica.pas", "content": "unit QSynHighlighterModelica;\r\n\r\n{$DEFINE SYN_CLX}\r\n{$DEFINE QSYNHIGHLIGHTERMODELICA}\r\n\r\n{$I SynHighlighterModelica.pas}\r\n" }, { "path": "External/SynEdit/Source/QSynHighlighterMsg.pas", "content": "unit QSynHighlighterMsg;\r\n\r\n{$DEFINE SYN_CLX}\r\n{$DEFINE QSYNHIGHLIGHTERMSG}\r\n\r\n{$I SynHighlighterMsg.pas}\r\n" }, { "path": "External/SynEdit/Source/QSynHighlighterMulti.pas", "content": "unit QSynHighlighterMulti;\r\n\r\n{$DEFINE SYN_CLX}\r\n{$DEFINE QSYNHIGHLIGHTERMULTI}\r\n\r\n{$I SynHighlighterMulti.pas}\r\n" }, { "path": "External/SynEdit/Source/QSynHighlighterPHP.pas", "content": "unit QSynHighlighterPHP;\r\n\r\n{$DEFINE SYN_CLX}\r\n{$DEFINE QSYNHIGHLIGHTERPHP}\r\n\r\n{$I SynHighlighterPHP.pas}\r\n" }, { "path": "External/SynEdit/Source/QSynHighlighterPas.pas", "content": "unit QSynHighlighterPas;\r\n\r\n{$DEFINE SYN_CLX}\r\n{$DEFINE QSYNHIGHLIGHTERPAS}\r\n\r\n{$I SynHighlighterPas.pas}\r\n" }, { "path": "External/SynEdit/Source/QSynHighlighterPerl.pas", "content": "unit QSynHighlighterPerl;\r\n\r\n{$DEFINE SYN_CLX}\r\n{$DEFINE QSYNHIGHLIGHTERPERL}\r\n\r\n{$I SynHighlighterPerl.pas}\r\n" }, { "path": "External/SynEdit/Source/QSynHighlighterProgress.pas", "content": "unit QSynHighlighterProgress;\r\n\r\n{$DEFINE SYN_CLX}\r\n{$DEFINE QSYNHIGHLIGHTERPROGRESS}\r\n\r\n{$I SynHighlighterProgress.pas}\r\n" }, { "path": "External/SynEdit/Source/QSynHighlighterPython.pas", "content": "unit QSynHighlighterPython;\r\n\r\n{$DEFINE SYN_CLX}\r\n{$DEFINE QSYNHIGHLIGHTERPYTHON}\r\n\r\n{$I SynHighlighterPython.pas}\r\n" }, { "path": "External/SynEdit/Source/QSynHighlighterRC.pas", "content": "unit QSynHighlighterRC;\r\n\r\n{$DEFINE SYN_CLX}\r\n{$DEFINE QSYNHIGHLIGHTERRC}\r\n\r\n{$I SynHighlighterRC.pas}\r\n\r\n" }, { "path": "External/SynEdit/Source/QSynHighlighterRuby.pas", "content": "unit QSynHighlighterRuby;\r\n\r\n{$DEFINE SYN_CLX}\r\n{$DEFINE QSYNHIGHLIGHTERRUBY}\r\n\r\n{$I SynHighlighterRuby.pas}\r\n" }, { "path": "External/SynEdit/Source/QSynHighlighterSDD.pas", "content": "unit QSynHighlighterSDD;\r\n\r\n{$DEFINE SYN_CLX}\r\n{$DEFINE QSYNHIGHLIGHTERSDD}\r\n\r\n{$I SynHighlighterSDD.pas}\r\n" }, { "path": "External/SynEdit/Source/QSynHighlighterSQL.pas", "content": "unit QSynHighlighterSQL;\r\n\r\n{$DEFINE SYN_CLX}\r\n{$DEFINE QSYNHIGHLIGHTERSQL}\r\n\r\n{$I SynHighlighterSQL.pas}\r\n" }, { "path": "External/SynEdit/Source/QSynHighlighterST.pas", "content": "unit QSynHighlighterST;\r\n\r\n{$DEFINE SYN_CLX}\r\n{$DEFINE QSYNHIGHLIGHTERST}\r\n\r\n{$I SynHighlighterST.pas}\r\n" }, { "path": "External/SynEdit/Source/QSynHighlighterSml.pas", "content": "unit QSynHighlighterSml;\r\n\r\n{$DEFINE SYN_CLX}\r\n{$DEFINE QSYNHIGHLIGHTERSML}\r\n\r\n{$I SynHighlighterSml.pas}\r\n" }, { "path": "External/SynEdit/Source/QSynHighlighterTclTk.pas", "content": "unit QSynHighlighterTclTk;\r\n\r\n{$DEFINE SYN_CLX}\r\n{$DEFINE QSYNHIGHLIGHTERTCLTK}\r\n\r\n{$I SynHighlighterTclTk.pas}\r\n" }, { "path": "External/SynEdit/Source/QSynHighlighterTeX.pas", "content": "unit QSynHighlighterTeX;\r\n\r\n{$DEFINE SYN_CLX}\r\n{$DEFINE QSYNHIGHLIGHTERTEX}\r\n\r\n{$I SynHighlighterTeX.pas}\r\n" }, { "path": "External/SynEdit/Source/QSynHighlighterUNIXShellScript.pas", "content": "unit QSynHighlighterUNIXShellScript;\r\n\r\n{$DEFINE SYN_CLX}\r\n{$DEFINE QSynHighlighterUNIXShellScript}\r\n\r\n{$I SynHighlighterUNIXShellScript.pas}\r\n" }, { "path": "External/SynEdit/Source/QSynHighlighterURI.pas", "content": "unit QSynHighlighterURI;\r\n\r\n{$DEFINE SYN_CLX}\r\n{$DEFINE QSYNHIGHLIGHTERURI}\r\n\r\n{$I SynHighlighterURI.pas}\r\n" }, { "path": "External/SynEdit/Source/QSynHighlighterUnreal.pas", "content": "unit QSynHighlighterUnreal;\r\n\r\n{$DEFINE SYN_CLX}\r\n{$DEFINE QSYNHIGHLIGHTERUNREAL}\r\n\r\n{$I SynHighlighterUnreal.pas}\r\n" }, { "path": "External/SynEdit/Source/QSynHighlighterVB.pas", "content": "unit QSynHighlighterVB;\r\n\r\n{$DEFINE SYN_CLX}\r\n{$DEFINE QSYNHIGHLIGHTERVB}\r\n\r\n{$I SynHighlighterVB.pas}\r\n" }, { "path": "External/SynEdit/Source/QSynHighlighterVBScript.pas", "content": "unit QSynHighlighterVBScript;\r\n\r\n{$DEFINE SYN_CLX}\r\n{$DEFINE QSYNHIGHLIGHTERVBSCRIPT}\r\n\r\n{$I SynHighlighterVBScript.pas}\r\n" }, { "path": "External/SynEdit/Source/QSynHighlighterVrml97.pas", "content": "unit QSynHighlighterVrml97;\r\n\r\n{$DEFINE SYN_CLX}\r\n{$DEFINE QSYNHIGHLIGHTERVRML97}\r\n\r\n{$I SynHighlighterVrml97.pas}\r\n" }, { "path": "External/SynEdit/Source/QSynHighlighterXML.pas", "content": "unit QSynHighlighterXML;\r\n\r\n{$DEFINE SYN_CLX}\r\n{$DEFINE QSYNHIGHLIGHTERXML}\r\n\r\n{$I SynHighlighterXML.pas}\r\n" }, { "path": "External/SynEdit/Source/QSynMacroRecorder.pas", "content": "unit QSynMacroRecorder;\r\n\r\n{$DEFINE SYN_CLX}\r\n{$DEFINE QSYNMACRORECORDER}\r\n\r\n{$I SynMacroRecorder.pas}\r\n" }, { "path": "External/SynEdit/Source/QSynMemo.pas", "content": "unit QSynMemo;\r\n\r\n{$DEFINE SYN_CLX}\r\n{$DEFINE QSYNMEMO}\r\n\r\n{$I SynMemo.pas}\r\n" }, { "path": "External/SynEdit/Source/QSynRegExpr.pas", "content": "unit QSynRegExpr;\r\n\r\n{$DEFINE SYN_CLX}\r\n{$DEFINE QSYNREGEXPR}\r\n\r\n{$I SynRegExpr.pas}\r\n" }, { "path": "External/SynEdit/Source/QSynURIOpener.pas", "content": "unit QSynURIOpener;\r\n\r\n{$DEFINE SYN_CLX}\r\n{$DEFINE QSYNURIOPENER}\r\n\r\n{$I SynURIOpener.pas}\r\n\r\n" }, { "path": "External/SynEdit/Source/QSynUnicode.pas", "content": "unit QSynUnicode;\r\n\r\n{$DEFINE SYN_CLX}\r\n{$DEFINE QSYNUNICODE}\r\n\r\n{$I SynUnicode.pas}\r\n" }, { "path": "External/SynEdit/Source/SynAutoCorrect.pas", "content": "{-------------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: SynAutoCorrect.pas, released 2001-10-05.\r\nAuthor of this file is Aaron Chan.\r\nUnicode translation by Mal Hrz.\r\nAll Rights Reserved.\r\n\r\nContributors to the SynEdit and mwEdit projects are listed in the\r\nContributors.txt file.\r\n\r\nAlternatively, the contents of this file may be used under the terms of the\r\nGNU General Public License Version 2 or later (the \"GPL\"), in which case\r\nthe provisions of the GPL are applicable instead of those above.\r\nIf you wish to allow use of your version of this file only under the terms\r\nof the GPL and not to allow others to use your version of this file\r\nunder the MPL, indicate your decision by deleting the provisions above and\r\nreplace them with the notice and other provisions required by the GPL.\r\nIf you do not delete the provisions above, a recipient may use your version\r\nof this file under either the MPL or the GPL.\r\n\r\n$Id: SynAutoCorrect.pas,v 1.13.2.7 2008/09/14 16:24:57 maelh Exp $\r\n\r\nYou may retrieve the latest version of this file at the SynEdit home page,\r\nlocated at http://SynEdit.SourceForge.net\r\n\r\n-------------------------------------------------------------------------------}\r\n\r\n{*******************************************************}\r\n{ }\r\n{ Aerodynamica Components }\r\n{ SynAutoCorrect 2.x }\r\n{ }\r\n{ Copyright (c) 1996-2003, Aerodynamica Software }\r\n{ }\r\n{ Author: Aaron Chan }\r\n{ Portions by Greg Nixon and Jan Fiala }\r\n{ }\r\n{*******************************************************}\r\n\r\n{\r\n @author: Aaron Chan\r\n @url: http://aerodynamica.idz.net\r\n @comp-url: http://aerodynamica.idz.net/products.asp?id=SynAC_2\r\n @email: aerodynamica@idz.net\r\n @last-updated: 12/04/03\r\n @history:\r\n\r\n ! comment * changed + added\r\n - removed @ bug-fixed # todo\r\n\r\n 12/04/2003\r\n - removed integrated sound support.\r\n * changed keyboard and mouse handling to use SynEdit plugin system.\r\n\r\n 11/04/04 - Release 2.21:\r\n @ Fixed support for correction after delimiters.\r\n * SOUND_SUPPORT undefined by default.\r\n\r\n 24/03/03 - Release 2.2:\r\n @ Fixed \"Stack Overflow\" bug and memory leak (fixed by Danail Traichev).\r\n\r\n 30/09/02 - Release 2.1:\r\n @ Fixed bug when user KeyDown and MouseDown events weren't fired.\r\n + Added INI_FILES and REGISTRY compiler defines (to minimize code size\r\n if you don't need these features).\r\n * Further tidy-up of code.\r\n * Quite a few minor bug-fixes and tweaks.\r\n * Items editor enhanced.\r\n * Improved demo.\r\n * Registry and INI file entries are saved in a new and improved way, which\r\n overcomes some limitations set by the old method. If you still want to\r\n use the old method, define OLD_SAVE_METHOD.\r\n\r\n 31/07/02 - Revision 2.01:\r\n @ Fixed bug which occured when undefining SOUND_SUPPORT (reported by\r\n Stefan Ascher).\r\n\r\n 30/07/02 - First public release of version 2.0:\r\n @ MANY bugs fixed and small tweaks everywhere in the code (some\r\n courtesy of Jan Fiala).\r\n + Ability to play an optional WAVE file (or beep) on correction.\r\n + Options set.\r\n * New demo.\r\n}\r\n\r\n{$IFNDEF QSYNAUTOCORRECT}\r\nunit SynAutoCorrect;\r\n{$ENDIF}\r\n\r\n{$I SynEdit.inc}\r\n\r\ninterface\r\n\r\nuses\r\n{$IFDEF SYN_WIN32} //Borland translation of Qt doesn't include Char handling\r\n Windows,\r\n{$ELSE}\r\n Libc,\r\n{$ENDIF}\r\n{$IFDEF SYN_CLX}\r\n QGraphics,\r\n QControls,\r\n QForms,\r\n QDialogs,\r\n Types,\r\n QSynEditMiscProcs,\r\n QSynEditTypes,\r\n QSynEditKeyCmds,\r\n QSynEdit,\r\n QSynUnicode,\r\n{$ELSE}\r\n Registry,\r\n Messages,\r\n Graphics,\r\n Controls,\r\n Forms,\r\n Dialogs,\r\n SynEditMiscProcs,\r\n SynEditTypes,\r\n SynEditKeyCmds,\r\n SynEdit,\r\n SynEditMiscClasses, \r\n SynUnicode,\r\n{$ENDIF}\r\n Classes,\r\n SysUtils,\r\n IniFiles;\r\n\r\ntype\r\n TAsSynAutoCorrectOption = (ascoCorrectOnMouseDown, ascoIgnoreCase,\r\n ascoMaintainCase);\r\n TAsSynAutoCorrectOptions = set of TAsSynAutoCorrectOption;\r\n\r\n TAutoCorrectAction = (aaCorrect, aaAbort);\r\n TAutoCorrectEvent = procedure(Sender: TObject;\r\n const AOriginal, ACorrection: UnicodeString; Line, Column: Integer;\r\n var Action: TAutoCorrectAction) of object;\r\n\r\n TCustomSynAutoCorrect = class(TComponent)\r\n private\r\n { Private declarations }\r\n\r\n { Published properties and events }\r\n FEditor: TCustomSynEdit;\r\n FEnabled: Boolean;\r\n FItems: TUnicodeStrings;\r\n FItemSepChar: WideChar;\r\n FOptions: TAsSynAutoCorrectOptions;\r\n\r\n FOnAutoCorrect: TAutoCorrectEvent;\r\n FOnCorrected: TNotifyEvent;\r\n\r\n { Private variables and methods }\r\n FPrevLine: Integer;\r\n\r\n function CorrectItemStart(EditLine, SearchString: UnicodeString; StartPos: LongInt;\r\n MatchCase, WholeWord: Boolean): LongInt;\r\n function FindAndCorrect(var EditLine: UnicodeString; Original, Correction: UnicodeString;\r\n var CurrentX: Integer): Boolean;\r\n function PreviousToken: UnicodeString;\r\n\r\n { Accessor methods }\r\n function GetItems: TUnicodeStrings;\r\n procedure SetItems(const Value: TUnicodeStrings);\r\n protected\r\n { Protected declarations }\r\n procedure DefineProperties(Filer: TFiler); override;\r\n procedure KeyboardHandler(Sender: TObject; AfterProcessing: Boolean;\r\n var Handled: Boolean; var Command: TSynEditorCommand; var AChar: WideChar;\r\n Data: Pointer; HandlerData: Pointer); virtual;\r\n procedure MouseDownHandler(Sender: TObject; Button: TMouseButton;\r\n Shift: TShiftState; X, Y: Integer); virtual;\r\n procedure Notification(AComponent: TComponent;\r\n Operation: TOperation); override;\r\n procedure SetEditor(Value: TCustomSynEdit);\r\n public\r\n { Public declarations }\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n\r\n procedure Add(AOriginal, ACorrection: UnicodeString);\r\n function AutoCorrectAll: Boolean;\r\n procedure Delete(AIndex: Integer);\r\n procedure Edit(AIndex: Integer; ANewOriginal, ANewCorrection: UnicodeString);\r\n\r\n procedure LoadFromINI(AFileName, ASection: string);\r\n procedure SaveToINI(AFileName, ASection: string);\r\n\r\n{$IFNDEF SYN_CLX}\r\n procedure LoadFromRegistry(ARoot: DWORD; AKey: string);\r\n procedure SaveToRegistry(ARoot: DWORD; AKey: string);\r\n{$ENDIF}\r\n\r\n function LoadFromList(AFileName: string): Boolean;\r\n procedure SaveToList(AFileName: string);\r\n\r\n { Utility functions }\r\n function HalfString(Str: UnicodeString; GetFirstHalf: Boolean): UnicodeString;\r\n public\r\n { Published declarations }\r\n property Enabled: Boolean read FEnabled write FEnabled default True;\r\n property Editor: TCustomSynEdit read FEditor write SetEditor;\r\n property Items: TUnicodeStrings read GetItems write SetItems;\r\n property ItemSepChar: WideChar read FItemSepChar write FItemSepChar default #9;\r\n property Options: TAsSynAutoCorrectOptions read FOptions write FOptions\r\n default [ascoIgnoreCase, ascoMaintainCase];\r\n\r\n property OnAutoCorrect: TAutoCorrectEvent read FOnAutoCorrect\r\n write FOnAutoCorrect;\r\n property OnCorrected: TNotifyEvent read FOnCorrected write FOnCorrected;\r\n end;\r\n\r\n TSynAutoCorrect = class(TCustomSynAutoCorrect)\r\n published\r\n { Published declarations }\r\n property Enabled;\r\n property Editor;\r\n property Items;\r\n property ItemSepChar;\r\n property Options;\r\n\r\n property OnAutoCorrect;\r\n property OnCorrected;\r\n end;\r\n\r\nimplementation\r\n\r\n\r\n{ TCustomSynAutoCorrect }\r\n\r\nconstructor TCustomSynAutoCorrect.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n\r\n FEnabled := True;\r\n FItems := TUnicodeStringList.Create;\r\n FItemSepChar := #9;\r\n FOptions := [ascoIgnoreCase, ascoMaintainCase];\r\n FPrevLine := -1;\r\n// FEditor := nil; initialized by Delphi\r\nend;\r\n\r\ndestructor TCustomSynAutoCorrect.Destroy;\r\nbegin\r\n Editor := nil;\r\n inherited;\r\n FItems.Free;\r\nend;\r\n\r\n\r\n{ Utility functions }\r\n\r\nfunction TCustomSynAutoCorrect.HalfString(Str: UnicodeString;\r\n GetFirstHalf: Boolean): UnicodeString;\r\nvar\r\n i: Integer;\r\nbegin\r\n i := LastDelimiter(FItemSepChar, Str);\r\n if i = 0 then i := Pred(MaxInt);\r\n\r\n if GetFirstHalf then\r\n Result := Copy(Str, 1, Pred(i))\r\n else\r\n Result := Copy(Str, Succ(i), MaxInt);\r\nend;\r\n\r\nprocedure TCustomSynAutoCorrect.LoadFromIni(AFileName, ASection: string);\r\nvar\r\n i: Integer;\r\n Original, Correction: UnicodeString;\r\n Reg: TIniFile;\r\nbegin\r\n Reg := TIniFile.Create(AFileName);\r\n try\r\n FItems.Clear;\r\n with Reg do\r\n for i := 0 to Pred(ReadInteger(ASection, 'Count', 0)) do\r\n begin\r\n Original := ReadString(ASection, 'Original' + IntToStr(i), '');\r\n Correction := ReadString(ASection, 'Correction' + IntToStr(i), '');\r\n if not ((Original = '') and (Correction = '')) then\r\n FItems.Add(Original + FItemSepChar + Correction);\r\n end;\r\n finally\r\n Reg.Free;\r\n end;\r\nend;\r\n\r\nprocedure TCustomSynAutoCorrect.SaveToIni(AFileName, ASection: string);\r\nvar\r\n i: Integer;\r\n Reg: TIniFile;\r\nbegin\r\n Reg := TIniFile.Create(AFileName);\r\n try\r\n with Reg do\r\n begin\r\n WriteInteger(ASection, 'Count', FItems.Count);\r\n for i := 0 to Pred(FItems.Count) do\r\n begin\r\n WriteString(ASection, 'Original' + IntToStr(i),\r\n HalfString(FItems[i], True));\r\n WriteString(ASection, 'Correction' + IntToStr(i),\r\n HalfString(FItems[i], False));\r\n end;\r\n end;\r\n finally\r\n Reg.Free;\r\n end;\r\nend;\r\n\r\nfunction TCustomSynAutoCorrect.LoadFromList(AFileName: string): Boolean;\r\nbegin\r\n Result := False;\r\n if FileExists(AFileName) then\r\n begin\r\n FItems.LoadFromFile(AFileName);\r\n Result := True;\r\n end;\r\nend;\r\n\r\nprocedure TCustomSynAutoCorrect.SaveToList(AFileName: string);\r\nbegin\r\n FItems.SaveToFile(AFileName);\r\nend;\r\n\r\n{$IFNDEF SYN_CLX}\r\nprocedure TCustomSynAutoCorrect.LoadFromRegistry(ARoot: DWORD; AKey: string);\r\nvar\r\n i: Integer;\r\n Original, Correction: UnicodeString;\r\n Reg: TRegIniFile;\r\nbegin\r\n Reg := TRegIniFile.Create('');\r\n try\r\n with Reg do\r\n begin\r\n RootKey := ARoot;\r\n TBetterRegistry(Reg).OpenKeyReadOnly(AKey);\r\n FItems.Clear;\r\n for i := 0 to Pred(ReadInteger('', 'Count', 0)) do\r\n begin\r\n Original := ReadString('', 'Original' + IntToStr(i), '');\r\n Correction := ReadString('', 'Correction' + IntToStr(i), '');\r\n if not ((Original = '') and (Correction = '')) then\r\n FItems.Add(Original + FItemSepChar + Correction);\r\n end;\r\n end;\r\n finally\r\n Reg.Free;\r\n end;\r\nend;\r\n\r\nprocedure TCustomSynAutoCorrect.SaveToRegistry(ARoot: DWORD; AKey: string);\r\nvar\r\n i: Integer;\r\n Reg: TRegIniFile;\r\nbegin\r\n Reg := TRegIniFile.Create('');\r\n try\r\n with Reg do\r\n begin\r\n RootKey := ARoot;\r\n OpenKey(AKey, True);\r\n WriteInteger('', 'Count', FItems.Count);\r\n for i := 0 to Pred(FItems.Count) do\r\n begin\r\n WriteString('', 'Original' + IntToStr(i), HalfString(FItems[i], True));\r\n WriteString('', 'Correction' + IntToStr(i),\r\n HalfString(FItems[i], False));\r\n end;\r\n end;\r\n finally\r\n Reg.Free;\r\n end;\r\nend;\r\n{$ENDIF}\r\n\r\nprocedure TCustomSynAutoCorrect.Add(AOriginal, ACorrection: UnicodeString);\r\nbegin\r\n FItems.Add(AOriginal + FItemSepChar + ACorrection);\r\nend;\r\n\r\nfunction TCustomSynAutoCorrect.AutoCorrectAll: Boolean;\r\nvar\r\n i, cx: Integer;\r\n s, Original, Correction, CurrText: UnicodeString;\r\nbegin\r\n Result := False;\r\n if Assigned(Editor) then\r\n begin\r\n s := Editor.Lines.Text;\r\n cx := -1;\r\n\r\n for i := 0 to Pred(FItems.Count) do\r\n begin\r\n CurrText := FItems[i];\r\n Original := HalfString(CurrText, True);\r\n Correction := HalfString(CurrText, False);\r\n FindAndCorrect(s, Original, Correction, cx);\r\n end;\r\n Editor.Lines.Text := s;\r\n end;\r\nend;\r\n\r\nfunction TCustomSynAutoCorrect.CorrectItemStart(EditLine, SearchString: UnicodeString;\r\n StartPos: LongInt; MatchCase, WholeWord: Boolean): LongInt;\r\nvar\r\n SearchCount, I: Integer;\r\n CurBuf, Buf: PWideChar;\r\n BufLen: Integer;\r\n\r\n function FindNextWordStart(var BufPtr: PWideChar): Boolean;\r\n begin\r\n while (SearchCount > 0) and not Editor.IsWordBreakChar(BufPtr^) do\r\n begin\r\n Inc(BufPtr, 1);\r\n Dec(SearchCount);\r\n end;\r\n\r\n while (SearchCount > 0) and Editor.IsWordBreakChar(BufPtr^) do\r\n begin\r\n Inc(BufPtr, 1);\r\n Dec(SearchCount);\r\n end;\r\n\r\n Result := SearchCount >= 0;\r\n end;\r\n\r\n function ScanText(var BufPtr: PWideChar): Boolean;\r\n var\r\n FirstWord: Boolean;\r\n begin\r\n Result := False;\r\n\r\n FirstWord := True;\r\n\r\n if WholeWord then\r\n begin\r\n while (SearchCount > 0) and Editor.IsWordBreakChar(BufPtr^) do\r\n begin\r\n Inc(BufPtr, 1);\r\n Dec(SearchCount);\r\n end;\r\n end;\r\n\r\n while SearchCount >= 0 do\r\n begin\r\n if WholeWord and (FirstWord = False) then\r\n if not FindNextWordStart(BufPtr) then Break;\r\n I := 0;\r\n while (BufPtr[I] = SearchString[I + 1]) do\r\n begin\r\n Inc(I);\r\n if I >= Length(SearchString) then\r\n begin\r\n if not WholeWord or (SearchCount = 0) or\r\n Editor.IsWordBreakChar(BufPtr[I]) then\r\n begin\r\n Result := True;\r\n Exit;\r\n end;\r\n Break;\r\n end;\r\n end;\r\n FirstWord := False;\r\n Inc(BufPtr);\r\n Dec(SearchCount);\r\n end;\r\n end;\r\n\r\nbegin\r\n Result := -1;\r\n\r\n if not MatchCase then\r\n begin\r\n EditLine := SynWideUpperCase(EditLine);\r\n SearchString := SynWideUpperCase(SearchString);\r\n end;\r\n\r\n BufLen := Length(EditLine);\r\n Buf := PWideChar(EditLine);\r\n\r\n if BufLen > 0 then\r\n begin\r\n SearchCount := succ(BufLen - StartPos - Length(SearchString));\r\n\r\n if (SearchCount >= 0) and (SearchCount <= BufLen) and\r\n (StartPos + SearchCount <= BufLen) then\r\n begin\r\n CurBuf := PWideChar(@Buf[StartPos]);\r\n if not ScanText(CurBuf) then\r\n CurBuf := nil\r\n else\r\n begin\r\n if CurBuf <> nil then\r\n Result := CurBuf - Buf;\r\n end;\r\n end;\r\n end;\r\n\r\n CurBuf := nil; \r\nend;\r\n\r\nprocedure TCustomSynAutoCorrect.DefineProperties(Filer: TFiler);\r\nbegin\r\n inherited;\r\n{$IFNDEF UNICODE}\r\n UnicodeDefineProperties(Filer, Self);\r\n{$ENDIF}\r\nend;\r\n\r\nprocedure TCustomSynAutoCorrect.Delete(AIndex: Integer);\r\nbegin\r\n FItems.Delete(AIndex);\r\nend;\r\n\r\nprocedure TCustomSynAutoCorrect.Edit(AIndex: Integer;\r\n ANewOriginal, ANewCorrection: UnicodeString);\r\nbegin\r\n if AIndex > -1 then\r\n FItems[AIndex] := ANewOriginal + FItemSepChar + ANewCorrection;\r\nend;\r\n\r\nprocedure TCustomSynAutoCorrect.KeyboardHandler(Sender: TObject; AfterProcessing: Boolean;\r\n var Handled: Boolean; var Command: TSynEditorCommand; var AChar: WideChar;\r\n Data: Pointer; HandlerData: Pointer);\r\nvar\r\n b: Boolean;\r\n i, cx: Integer;\r\n s, Original, Correction, CurrText: UnicodeString;\r\nbegin\r\n if Enabled and not AfterProcessing and not Handled then\r\n begin\r\n FPrevLine := Editor.CaretY;\r\n case Command of\r\n ecLineBreak, ecTab, ecChar:\r\n begin\r\n if (Command = ecChar) and not Editor.IsWordBreakChar(AChar) then\r\n Exit;\r\n b := False;\r\n s := PreviousToken;\r\n if s <> '' then\r\n begin\r\n cx := Editor.CaretX;\r\n for i := 0 to Pred(FItems.Count) do\r\n begin\r\n CurrText := FItems[i];\r\n Original := HalfString(CurrText, True);\r\n Correction := HalfString(CurrText, False);\r\n b := b or FindAndCorrect(s, Original, Correction, cx);\r\n end;\r\n\r\n if Assigned(OnCorrected) then\r\n OnCorrected(Self);\r\n end;\r\n end;\r\n end; {endcase}\r\n end;\r\nend;\r\n\r\nprocedure TCustomSynAutoCorrect.MouseDownHandler(Sender: TObject;\r\n Button: TMouseButton; Shift: TShiftState; X, Y: Integer);\r\nvar\r\n Action: TAutoCorrectAction;\r\n b: Boolean;\r\n i, cx: Integer;\r\n s, Original, Correction, CurrText: UnicodeString;\r\nbegin\r\n if ascoCorrectOnMouseDown in FOptions then\r\n begin\r\n if Assigned(Editor) and Enabled and (FPrevLine <> -1) then\r\n begin\r\n b := False;\r\n s := Editor.Lines[Pred(FPrevLine)];\r\n cx := -1;\r\n\r\n for i := 0 to Pred(FItems.Count) do\r\n begin\r\n CurrText := FItems[i];\r\n Original := HalfString(CurrText, True);\r\n Correction := HalfString(CurrText, False);\r\n b := b or FindAndCorrect(s, Original, Correction, cx);\r\n end;\r\n\r\n if b then\r\n begin\r\n if Assigned(FOnAutoCorrect) then\r\n begin\r\n Action := aaCorrect;\r\n FOnAutoCorrect(Self, Editor.Lines[Pred(FPrevLine)], s, Editor.CaretY,\r\n 0, Action);\r\n if Action = aaAbort then Exit;\r\n end;\r\n Editor.Lines[Pred(FPrevLine)] := s;\r\n \r\n if Assigned(OnCorrected) then\r\n OnCorrected(Self);\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TCustomSynAutoCorrect.FindAndCorrect(var EditLine: UnicodeString;\r\n Original, Correction: UnicodeString; var CurrentX: Integer): Boolean;\r\nvar\r\n StartPos: LongInt;\r\n EndPos: Integer;\r\n FoundText, ReplaceDefText: UnicodeString;\r\n p: TBufferCoord;\r\n Action: TAutoCorrectAction;\r\n\r\n function FirstCapCase(s: UnicodeString): UnicodeString;\r\n begin\r\n if s <> '' then\r\n begin\r\n s := SynWideLowerCase(s);\r\n s[1] := SynWideUpperCase(s[1])[1];\r\n end;\r\n\r\n Result := s;\r\n end;\r\n\r\nbegin\r\n Result := False;\r\n ReplaceDefText := Correction;\r\n StartPos := 0;\r\n EndPos := Length(Original);\r\n\r\n if (Editor <> nil) and not (Editor.ReadOnly) then\r\n begin\r\n StartPos := CorrectItemStart(EditLine, Original, StartPos,\r\n not (ascoIgnoreCase in FOptions), True);\r\n\r\n while StartPos > -1 do\r\n begin\r\n if (ascoMaintainCase in FOptions) then\r\n begin\r\n Correction := ReplaceDefText;\r\n FoundText := Copy(EditLine,StartPos+1,EndPos);\r\n\r\n if FoundText = SynWideUpperCase(FoundText) then\r\n Correction := SynWideUpperCase(Correction)\r\n else\r\n begin\r\n if FoundText = SynWideLowerCase(FoundText) then\r\n Correction := SynWideLowerCase(Correction)\r\n else\r\n begin\r\n if FoundText = FirstCapCase(FoundText) then\r\n Correction := FirstCapCase(Correction);\r\n end;\r\n end;\r\n end;\r\n\r\n if CurrentX > - 1 then\r\n begin\r\n p := Editor.CaretXY;\r\n if Assigned(FOnAutoCorrect) then\r\n begin\r\n Action := aaCorrect;\r\n FOnAutoCorrect(Self, Original, Correction, P.Line, P.Char, Action);\r\n\r\n if Action = aaAbort then Break;\r\n end;\r\n\r\n Editor.BeginUpdate;\r\n\r\n try\r\n if p.Char = 0 then\r\n Editor.BlockBegin := BufferCoord(p.Char - 1 - EndPos, p.Line)\r\n else\r\n Editor.BlockBegin := BufferCoord(p.Char - EndPos, p.Line);\r\n\r\n Editor.BlockEnd := p;\r\n p := Editor.BlockBegin;\r\n Editor.SelText := Correction;\r\n Result := True;\r\n finally\r\n Editor.EndUpdate;\r\n end;\r\n\r\n Break;\r\n end\r\n else\r\n begin\r\n Result := True;\r\n EditLine := Copy(EditLine, 1, StartPos) + Correction +\r\n Copy(EditLine, StartPos + EndPos + 1, MaxInt);\r\n Inc(StartPos, EndPos);\r\n StartPos := CorrectItemStart(EditLine, Original, StartPos,\r\n not (ascoIgnoreCase in FOptions), True);\r\n end;\r\n end;\r\n end; \r\nend;\r\n \r\nfunction TCustomSynAutoCorrect.GetItems: TUnicodeStrings;\r\nbegin\r\n Result := FItems;\r\nend;\r\n\r\nprocedure TCustomSynAutoCorrect.Notification(AComponent: TComponent;\r\n Operation: TOperation);\r\nbegin\r\n inherited;\r\n if (Operation = opRemove) and (AComponent = FEditor) then\r\n begin\r\n Editor := nil;\r\n end;\r\nend;\r\n\r\nfunction TCustomSynAutoCorrect.PreviousToken: UnicodeString;\r\nvar\r\n i, cx: Integer;\r\nbegin\r\n Result := Editor.LineText;\r\n cx := Editor.CaretX;\r\n i := Pred(cx);\r\n\r\n if i <= Length(Result) then\r\n begin\r\n while (i > 0) and not Editor.IsWordBreakChar(Result[i]) do Dec(i);\r\n Inc(i);\r\n Result := Copy(Result, i, cx - i);\r\n end\r\n else\r\n Result := '';\r\nend;\r\n\r\nprocedure TCustomSynAutoCorrect.SetEditor(Value: TCustomSynEdit);\r\nbegin\r\n if FEditor <> Value then\r\n begin\r\n if Assigned(FEditor) then\r\n begin\r\n Editor.RemoveMouseDownHandler(MouseDownHandler);\r\n Editor.UnregisterCommandHandler(KeyboardHandler);\r\n{$IFDEF SYN_COMPILER_5_UP}\r\n Editor.RemoveFreeNotification(Self);\r\n{$ENDIF}\r\n end;\r\n\r\n FEditor := Value;\r\n\r\n if Assigned(FEditor) then\r\n begin\r\n Editor.FreeNotification(Self);\r\n Editor.RegisterCommandHandler(KeyboardHandler, nil);\r\n Editor.AddMouseDownHandler(MouseDownHandler);\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TCustomSynAutoCorrect.SetItems(const Value: TUnicodeStrings);\r\nbegin\r\n FItems.Assign(Value);\r\nend;\r\n\r\nend.\r\n" }, { "path": "External/SynEdit/Source/SynAutoCorrectEditor.dfm", "content": "object frmAutoCorrectEditor: TfrmAutoCorrectEditor\r\n Left = 210\r\n Top = 111\r\n BorderStyle = bsDialog\r\n Caption = 'AutoCorrection Items...'\r\n ClientHeight = 377\r\n ClientWidth = 521\r\n Color = clBtnFace\r\n Font.Charset = DEFAULT_CHARSET\r\n Font.Color = clWindowText\r\n Font.Height = -11\r\n Font.Name = 'MS Sans Serif'\r\n Font.Style = []\r\n OldCreateOrder = True\r\n Position = poScreenCenter\r\n ShowHint = True\r\n OnCreate = FormCreate\r\n OnPaint = FormPaint\r\n OnShow = FormShow\r\n PixelsPerInch = 96\r\n TextHeight = 13\r\n object lblLabel1: TLabel\r\n Left = 16\r\n Top = 56\r\n Width = 38\r\n Height = 13\r\n Caption = '&Original:'\r\n FocusControl = lbxItems\r\n end\r\n object lblLabel2: TLabel\r\n Left = 252\r\n Top = 56\r\n Width = 56\r\n Height = 13\r\n Caption = '&Corrections:'\r\n FocusControl = lbxItems\r\n end\r\n object btnAdd: TSpeedButton\r\n Left = 16\r\n Top = 16\r\n Width = 65\r\n Height = 23\r\n Hint = 'Adds a new item to the auto-correction list.'\r\n Caption = ' &Add'\r\n Glyph.Data = {\r\n 36030000424D3603000000000000360000002800000010000000100000000100\r\n 1800000000000003000000000000000000000000000000000000008080008080\r\n 0080800080800080800080800080800080800080800080800080800080800080\r\n 8000808000808000808000808000808080808080808080808080808080808080\r\n 8080808080808080808080808080808080808080808080808080008080000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 00000000000000808080008080000000FFFFFF00FFFFFFFFFF00FFFFFFFFFF00\r\n FFFFFFFFFF00FFFF000000000000FFFFFF00FFFF000000808080008080000000\r\n 00FFFFFFFFFF00FFFFFFFFFF00FFFFFFFFFF00FFFFFFFFFF000000C0C0C00000\r\n 00FFFFFF000000808080008080000000FFFFFF00FFFFFFFFFF00FFFFFFFFFF00\r\n FFFFFFFFFF00FFFF00000000FFFFC0C0C0000000000000808080008080000000\r\n 00FFFFFFFFFF00FFFFFFFFFF00FFFFFFFFFF00FFFFFFFFFF0000000000000000\r\n 00000000000000808080FFFFFF000000FFFFFF80808000FFFFFFFFFF00FFFFFF\r\n FFFF00FFFF00FFFFFFFFFF00FFFFFFFFFF00FFFF00000080808080808000FFFF\r\n 00FFFF808080FFFFFF00FFFF80808000FFFFFFFFFFFFFFFF00FFFFFFFFFF00FF\r\n FFFFFFFF000000808080008080808080FFFFFF80808000FFFF80808000FFFFFF\r\n FFFF00FFFF00FFFFFFFFFF00FFFFFFFFFF00FFFF000000808080808080808080\r\n 808080FFFFFF808080FFFFFF00FFFFFFFFFF00FFFFFFFFFF00FFFFFFFFFF00FF\r\n FFFFFFFF000000808080FFFFFF00FFFF80808000FFFFFFFFFF80808080808080\r\n 8080808080000000000000000000000000000000000000008080008080808080\r\n 00FFFF80808000FFFF80808000FFFF0080800080800080800080800080800080\r\n 8000808000808000808080808000FFFF008080808080FFFFFF00808080808000\r\n FFFF00808000808000808000808000808000808000808000808000FFFF008080\r\n 00808080808000FFFF0080800080808080800080800080800080800080800080\r\n 80008080008080008080008080008080008080808080FFFFFF00808000808000\r\n 8080008080008080008080008080008080008080008080008080}\r\n OnClick = btnAddClick\r\n end\r\n object btnDelete: TSpeedButton\r\n Left = 88\r\n Top = 16\r\n Width = 65\r\n Height = 23\r\n Hint = 'Removes the selected item from the auto-correction list.'\r\n Caption = '&Delete'\r\n Enabled = False\r\n Glyph.Data = {\r\n 36030000424D3603000000000000360000002800000010000000100000000100\r\n 1800000000000003000000000000000000000000000000000000008080008080\r\n 0080800080800080800080800080800080800080800080800080800080800080\r\n 8000808000808000808000808000808080808080808080808080808080808080\r\n 8080808080808080808080808080808080808080808080808080008080000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 00000000000000808080008080000000FFFFFF00FFFFFFFFFF00FFFFFFFFFF00\r\n FFFFFFFFFF00FFFF000000000000FFFFFF00FFFF000000808080808080000000\r\n 00FFFFFFFFFF00FFFFFFFFFF00FFFFFFFFFF00FFFFFFFFFF000000C0C0C00000\r\n 00FFFFFF000000808080000080000000FFFFFF00FFFFFFFFFF00FFFFFFFFFF00\r\n FFFFFFFFFF00FFFF00000000FFFFC0C0C0000000000000808080000080000080\r\n 00FFFFFFFFFF00FFFFFFFFFF80808000008000FFFFFFFFFF0000000000000000\r\n 0000000000000080808080808000008080808000FFFFFFFFFF80808000008080\r\n 8080FFFFFF00FFFFFFFFFF00FFFFFFFFFF00FFFF000000808080008080000080\r\n 00008080808000FFFF000080000080FFFFFF00FFFFFFFFFF00FFFFFFFFFF00FF\r\n FFFFFFFF000000808080008080808080000080000080000080000080FFFFFF00\r\n FFFFFFFFFF00FFFFFFFFFF00FFFFFFFFFF00FFFF000000808080008080808080\r\n 000080000080000080FFFFFF00FFFFFFFFFF00FFFFFFFFFF00FFFFFFFFFF00FF\r\n FFFFFFFF00000080808080808000008000008000008000008080808000000000\r\n 0000000000000000000000000000000000000000000000008080000080000080\r\n 8080800080800000800000808080800080800080800080800080800080800080\r\n 8000808000808000808000808000808000808000808000808000008000008080\r\n 8080008080008080008080008080008080008080008080008080008080008080\r\n 0080800080800080800080800000800000808080800080800080800080800080\r\n 8000808000808000808000808000808000808000808000808000808000808000\r\n 8080008080008080008080008080008080008080008080008080}\r\n OnClick = btnDeleteClick\r\n end\r\n object btnClear: TSpeedButton\r\n Left = 160\r\n Top = 16\r\n Width = 65\r\n Height = 23\r\n Hint = 'Clears the entire list.'\r\n Caption = '&Clear'\r\n Glyph.Data = {\r\n F6000000424DF600000000000000760000002800000010000000100000000100\r\n 0400000000008000000000000000000000001000000010000000000000000000\r\n 8000008000000080800080000000800080008080000080808000C0C0C0000000\r\n FF0000FF000000FFFF00FF000000FF00FF00FFFF0000FFFFFF00888888888888\r\n 8888888888888888888888808888888888088800088888888888880000888888\r\n 8088888000888888088888880008888008888888800088008888888888000008\r\n 8888888888800088888888888800000888888888800088008888888000088880\r\n 0888880000888888008888000888888888088888888888888888}\r\n OnClick = btnClearClick\r\n end\r\n object btnEdit: TSpeedButton\r\n Left = 232\r\n Top = 16\r\n Width = 65\r\n Height = 23\r\n Hint = 'Edits the selected item on the auto-correction list.'\r\n Caption = '&Edit'\r\n Enabled = False\r\n OnClick = btnEditClick\r\n end\r\n object btnDone: TSpeedButton\r\n Left = 312\r\n Top = 16\r\n Width = 65\r\n Height = 23\r\n Hint = 'Closes the edit dialog and saves the list.'\r\n Caption = '&Done'\r\n OnClick = btnDoneClick\r\n end\r\n object bvlSeparator: TBevel\r\n Left = 304\r\n Top = 16\r\n Width = 2\r\n Height = 23\r\n end\r\n object lbxItems: TListBox\r\n Left = 16\r\n Top = 72\r\n Width = 489\r\n Height = 289\r\n Style = lbOwnerDrawFixed\r\n BorderStyle = bsNone\r\n ItemHeight = 15\r\n TabOrder = 0\r\n OnClick = lbxItemsClick\r\n end\r\nend\r\n" }, { "path": "External/SynEdit/Source/SynAutoCorrectEditor.pas", "content": "{-------------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: SynAutoCorrectEditor.pas, released 2001-10-05.\r\nAuthor of this file is Aaron Chan.\r\nUnicode translation by Mal Hrz.\r\nAll Rights Reserved.\r\n\r\nContributors to the SynEdit and mwEdit projects are listed in the\r\nContributors.txt file.\r\n\r\nAlternatively, the contents of this file may be used under the terms of the\r\nGNU General Public License Version 2 or later (the \"GPL\"), in which case\r\nthe provisions of the GPL are applicable instead of those above.\r\nIf you wish to allow use of your version of this file only under the terms\r\nof the GPL and not to allow others to use your version of this file\r\nunder the MPL, indicate your decision by deleting the provisions above and\r\nreplace them with the notice and other provisions required by the GPL.\r\nIf you do not delete the provisions above, a recipient may use your version\r\nof this file under either the MPL or the GPL.\r\n\r\n$Id: SynAutoCorrectEditor.pas,v 1.9.2.3 2008/09/14 16:24:57 maelh Exp $\r\n\r\nYou may retrieve the latest version of this file at the SynEdit home page,\r\nlocated at http://SynEdit.SourceForge.net\r\n\r\nKnown Issues:\r\n-------------------------------------------------------------------------------}\r\n// TODO: use TntUnicode to enable unicode input\r\n\r\n\r\n{$IFNDEF QSYNAUTOCORRECTEDITOR}\r\nunit SynAutoCorrectEditor;\r\n{$ENDIF}\r\n\r\ninterface\r\n\r\n{$I SynEdit.inc}\r\n\r\nuses\r\n{$IFDEF SYN_CLX}\r\n QGraphics, QControls, QForms, QDialogs, QExtCtrls, QStdCtrls, QButtons, Types,\r\n QSynAutoCorrect,\r\n QSynUnicode,\r\n{$ELSE}\r\n Windows, Messages, Graphics, Controls, Forms, Dialogs, ExtCtrls, StdCtrls,\r\n Buttons, Registry,\r\n SynAutoCorrect,\r\n SynUnicode,\r\n{$ENDIF}\r\n SysUtils,\r\n Classes;\r\n\r\ntype\r\n TfrmAutoCorrectEditor = class(TForm)\r\n lblLabel1: TLabel;\r\n lblLabel2: TLabel;\r\n lbxItems: TListBox;\r\n btnAdd: TSpeedButton;\r\n btnDelete: TSpeedButton;\r\n btnClear: TSpeedButton;\r\n btnEdit: TSpeedButton;\r\n btnDone: TSpeedButton;\r\n bvlSeparator: TBevel;\r\n procedure FormShow(Sender: TObject);\r\n procedure btnAddClick(Sender: TObject);\r\n procedure btnDeleteClick(Sender: TObject);\r\n procedure btnEditClick(Sender: TObject);\r\n procedure btnDoneClick(Sender: TObject);\r\n procedure btnClearClick(Sender: TObject);\r\n procedure lbxItemsClick(Sender: TObject);\r\n procedure FormCreate(Sender: TObject);\r\n procedure FormPaint(Sender: TObject);\r\n private\r\n procedure lbxItemsDrawItemCLX(Sender: TObject; Index: Integer;\r\n Rect: TRect; State: TOwnerDrawState; var Handled: Boolean);\r\n{$IFNDEF SYN_CLX}\r\n procedure lbxItemsDrawItem(Control: TWinControl; Index: Integer;\r\n Rect: TRect; State: TOwnerDrawState);\r\n{$ENDIF}\r\n public\r\n SynAutoCorrect: TSynAutoCorrect;\r\n end;\r\n\r\nresourcestring\r\n SConfirmation = 'Confirmation';\r\n SError = 'Error';\r\n SOriginal = 'Original:';\r\n SCorrection = 'Correction:';\r\n SAdd = 'Add...';\r\n SEdit = 'Edit...';\r\n SPleaseSelectItem = 'Please select an item before executing this command!';\r\n SClearListConfirmation = 'Are you sure you want to clear the entire list?';\r\n\r\nimplementation\r\n\r\n{$R *.dfm}\r\n\r\nprocedure TfrmAutoCorrectEditor.FormShow(Sender: TObject);\r\nbegin\r\n lbxItems.Items.Assign(SynAutoCorrect.Items);\r\n Invalidate;\r\nend;\r\n\r\nprocedure TfrmAutoCorrectEditor.lbxItemsDrawItemCLX(Sender: TObject;\r\n Index: Integer; Rect: TRect; State: TOwnerDrawState; var Handled: Boolean);\r\nvar\r\n s: UnicodeString;\r\nbegin\r\n with lbxItems do\r\n begin\r\n s := Items[Index];\r\n Canvas.FillRect(Rect);\r\n TextOut(Canvas, Rect.Left + 2, Rect.Top, SynAutoCorrect.HalfString(s, True));\r\n TextOut(Canvas, Rect.Left + (lbxItems.ClientWidth div 2) + 2, Rect.Top,\r\n SynAutoCorrect.HalfString(s, False));\r\n FormPaint(nil);\r\n end;\r\nend;\r\n\r\n{$IFNDEF SYN_CLX}\r\nprocedure TfrmAutoCorrectEditor.lbxItemsDrawItem(Control: TWinControl;\r\n Index: Integer; Rect: TRect; State: TOwnerDrawState);\r\nvar\r\n Dummy: Boolean;\r\nbegin\r\n Dummy := True;\r\n lbxItemsDrawItemCLX(Control, Index, Rect, State, Dummy);\r\nend;\r\n{$ENDIF}\r\n\r\nprocedure TfrmAutoCorrectEditor.btnAddClick(Sender: TObject);\r\nvar\r\n Original, Correction: string;\r\nbegin\r\n if InputQuery(SAdd, SOriginal, Original) then\r\n InputQuery(SAdd, SCorrection, Correction)\r\n else\r\n Exit;\r\n\r\n with SynAutoCorrect do\r\n begin\r\n if (Original <> '') and (Correction <> '') then\r\n begin\r\n Add(Original, Correction);\r\n lbxItems.Items.Assign(SynAutoCorrect.Items);\r\n end;\r\n end;\r\n\r\n btnDelete.Enabled := lbxItems.ItemIndex > -1;\r\n btnEdit.Enabled := lbxItems.ItemIndex > -1;\r\nend;\r\n\r\nprocedure TfrmAutoCorrectEditor.btnDeleteClick(Sender: TObject);\r\nbegin\r\n if lbxItems.ItemIndex < 0 then\r\n begin\r\n {$IFDEF SYN_CLX}\r\n ShowMessage(SPleaseSelectItem); // TODO: use MessageDlg instead\r\n {$ELSE}\r\n MessageBox(0, PChar(SPleaseSelectItem), PChar(SError), MB_ICONERROR or MB_OK);\r\n {$ENDIF}\r\n\r\n Exit;\r\n end;\r\n\r\n SynAutoCorrect.Delete(lbxItems.ItemIndex);\r\n lbxItems.Items.Assign(SynAutoCorrect.Items);\r\n\r\n btnDelete.Enabled := lbxItems.ItemIndex > -1;\r\n btnEdit.Enabled := lbxItems.ItemIndex > -1;\r\nend;\r\n\r\nprocedure TfrmAutoCorrectEditor.btnEditClick(Sender: TObject);\r\nvar\r\n Original, Correction, CurrText: string; // TODO: unicode adapt\r\nbegin\r\n if lbxItems.ItemIndex < 0 then\r\n begin\r\n {$IFDEF SYN_CLX}\r\n ShowMessage(SPleaseSelectItem); // TODO: use MessageDlg instead\r\n {$ELSE}\r\n MessageBox(0, PChar(SPleaseSelectItem), PChar(SError), MB_ICONERROR or MB_OK);\r\n {$ENDIF}\r\n Exit;\r\n end;\r\n\r\n with SynAutoCorrect do\r\n begin\r\n CurrText := SynAutoCorrect.Items[lbxItems.ItemIndex];\r\n Original := SynAutoCorrect.HalfString(CurrText, True);\r\n Correction := SynAutoCorrect.HalfString(CurrText, False);\r\n\r\n if InputQuery(SEdit, SOriginal, Original) then\r\n InputQuery(SEdit, SCorrection, Correction)\r\n else\r\n Exit;\r\n\r\n Edit(lbxItems.ItemIndex, Original, Correction);\r\n lbxItems.Items.Assign(SynAutoCorrect.Items);\r\n end;\r\n\r\n btnDelete.Enabled := lbxItems.ItemIndex > -1;\r\n btnEdit.Enabled := lbxItems.ItemIndex > -1;\r\nend;\r\n\r\nprocedure TfrmAutoCorrectEditor.btnDoneClick(Sender: TObject);\r\nbegin\r\n Close;\r\nend;\r\n\r\nprocedure TfrmAutoCorrectEditor.btnClearClick(Sender: TObject);\r\nbegin\r\n{$IFNDEF SYN_CLX} // TODO: also a MsgBox for CLX\r\n if MessageBox(0, PChar(SClearListConfirmation), PChar(SConfirmation),\r\n MB_YESNO or MB_ICONQUESTION) <> IDYES then Exit;\r\n{$ENDIF}\r\n SynAutoCorrect.Items.Clear;\r\n lbxItems.Items.Clear;\r\n\r\n btnDelete.Enabled := lbxItems.ItemIndex > -1;\r\n btnEdit.Enabled := lbxItems.ItemIndex > -1;\r\nend;\r\n\r\nprocedure TfrmAutoCorrectEditor.lbxItemsClick(Sender: TObject);\r\nbegin\r\n btnDelete.Enabled := lbxItems.ItemIndex > -1;\r\n btnEdit.Enabled := lbxItems.ItemIndex > -1;\r\nend;\r\n\r\nprocedure TfrmAutoCorrectEditor.FormCreate(Sender: TObject);\r\nbegin\r\n ClientWidth := 521;\r\n ClientHeight := 377;\r\n{$IFDEF SYN_CLX}\r\n lbxItems.OnDrawItem := lbxItemsDrawItemCLX;\r\n BorderStyle := fbsSingle;\r\n{$ELSE}\r\n lbxItems.OnDrawItem := lbxItemsDrawItem;\r\n BorderStyle := bsSingle;\r\n{$ENDIF}\r\nend;\r\n\r\nprocedure TfrmAutoCorrectEditor.FormPaint(Sender: TObject);\r\nbegin\r\n { Paints the line in the middle of the listbox. }\r\n with lbxItems.Canvas do\r\n begin\r\n Pen.Color := clBlack;\r\n PenPos := Point(lbxItems.Width div 2 - 8, 0);\r\n LineTo(lbxItems.Width div 2 - 8, lbxItems.Height);\r\n end;\r\nend;\r\n\r\nend.\r\n" }, { "path": "External/SynEdit/Source/SynCompletionProposal.pas", "content": "{-------------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: SynCompletionProposal.pas, released 2000-04-11.\r\nThe Original Code is based on mwCompletionProposal.pas by Cyrille de Brebisson,\r\npart of the mwEdit component suite.\r\nPortions created by Cyrille de Brebisson are Copyright (C) 1999\r\nCyrille de Brebisson.\r\nUnicode translation by Mal Hrz.\r\nAll Rights Reserved.\r\n\r\nContributors to the SynEdit and mwEdit projects are listed in the\r\nContributors.txt file.\r\n\r\nAlternatively, the contents of this file may be used under the terms of the\r\nGNU General Public License Version 2 or later (the \"GPL\"), in which case\r\nthe provisions of the GPL are applicable instead of those above.\r\nIf you wish to allow use of your version of this file only under the terms\r\nof the GPL and not to allow others to use your version of this file\r\nunder the MPL, indicate your decision by deleting the provisions above and\r\nreplace them with the notice and other provisions required by the GPL.\r\nIf you do not delete the provisions above, a recipient may use your version\r\nof this file under either the MPL or the GPL.\r\n\r\n$Id: SynCompletionProposal.pas,v 1.80.1.1 2013/06/25 10:31:19 codehunterworks Exp $\r\n\r\nYou may retrieve the latest version of this file at the SynEdit home page,\r\nlocated at http://SynEdit.SourceForge.net\r\n\r\nLast Changes:\r\n 1.80.1.1 - Removed TProposalColumn.BiggestWord and\r\n added TProposalColumn.ColumnWidth (Static Column Width in Pixels)\r\n\r\nKnown Issues:\r\n-------------------------------------------------------------------------------}\r\n\r\n{$IFNDEF QSYNCOMPLETIONPROPOSAL}\r\nunit SynCompletionProposal;\r\n{$ENDIF}\r\n\r\n{$I SynEdit.inc}\r\n\r\ninterface\r\n\r\nuses\r\n{$IFDEF SYN_CLX}\r\n Qt,\r\n Types,\r\n QControls,\r\n QGraphics,\r\n QForms,\r\n QStdCtrls,\r\n QExtCtrls,\r\n QMenus,\r\n QImgList,\r\n QDialogs,\r\n QSynEditTypes,\r\n QSynEditKeyCmds,\r\n QSynEditHighlighter,\r\n QSynEditKbdHandler,\r\n QSynEdit,\r\n QSynUnicode, \r\n{$ELSE}\r\n Windows,\r\n Messages,\r\n Graphics,\r\n Forms,\r\n Controls,\r\n StdCtrls,\r\n ExtCtrls,\r\n Menus,\r\n Dialogs,\r\n SynEditTypes,\r\n SynEditKeyCmds,\r\n SynEditHighlighter,\r\n SynEditKbdHandler,\r\n SynEdit,\r\n SynUnicode,\r\n{$ENDIF}\r\n SysUtils,\r\n Classes;\r\n\r\ntype\r\n SynCompletionType = (ctCode, ctHint, ctParams);\r\n\r\n TSynForm = {$IFDEF SYN_COMPILER_3_UP}TCustomForm{$ELSE}TForm{$ENDIF};\r\n\r\n TSynBaseCompletionProposalPaintItem = procedure(Sender: TObject;\r\n Index: Integer; TargetCanvas: TCanvas; ItemRect: TRect;\r\n var CustomDraw: Boolean) of object;\r\n\r\n TSynBaseCompletionProposalMeasureItem = procedure(Sender: TObject;\r\n Index: Integer; TargetCanvas: TCanvas; var ItemWidth: Integer) of object;\r\n\r\n TCodeCompletionEvent = procedure(Sender: TObject; var Value: UnicodeString;\r\n Shift: TShiftState; Index: Integer; EndToken: WideChar) of object;\r\n\r\n TAfterCodeCompletionEvent = procedure(Sender: TObject; const Value: UnicodeString;\r\n Shift: TShiftState; Index: Integer; EndToken: WideChar) of object;\r\n\r\n TValidateEvent = procedure(Sender: TObject; Shift: TShiftState;\r\n EndToken: WideChar) of object; \r\n\r\n TCompletionParameter = procedure(Sender: TObject; CurrentIndex: Integer;\r\n var Level, IndexToDisplay: Integer; var Key: WideChar;\r\n var DisplayString: UnicodeString) of object;\r\n\r\n TCompletionExecute = procedure(Kind: SynCompletionType; Sender: TObject;\r\n var CurrentInput: UnicodeString; var x, y: Integer; var CanExecute: Boolean) of object;\r\n\r\n TCompletionChange = procedure(Sender: TObject; AIndex: Integer) of object;\r\n\r\n TSynCompletionOption = (scoCaseSensitive, //Use case sensitivity to do matches\r\n scoLimitToMatchedText, //Limit the matched text to only what they have typed in\r\n scoTitleIsCentered, //Center the title in the box if you choose to use titles\r\n scoUseInsertList, //Use the InsertList to insert text instead of the ItemList (which will be displayed)\r\n scoUsePrettyText, //Use the PrettyText function to output the words\r\n scoUseBuiltInTimer, //Use the built in timer and the trigger keys to execute the proposal as well as the shortcut\r\n scoEndCharCompletion, //When an end char is pressed, it triggers completion to occur (like the Delphi IDE)\r\n scoConsiderWordBreakChars,//Use word break characters as additional end characters\r\n scoCompleteWithTab, //Use the tab character for completion\r\n scoCompleteWithEnter); //Use the Enter character for completion\r\n\r\n TSynCompletionOptions = set of TSynCompletionOption;\r\n\r\n\r\nconst\r\n DefaultProposalOptions = [scoLimitToMatchedText, scoEndCharCompletion, scoCompleteWithTab, scoCompleteWithEnter];\r\n DefaultEndOfTokenChr = '()[]. ';\r\n\r\ntype\r\n TProposalColumns = class;\r\n\r\n TSynBaseCompletionProposalForm = class(TSynForm)\r\n private\r\n FCurrentString: UnicodeString;\r\n FOnKeyPress: TKeyPressWEvent;\r\n FOnPaintItem: TSynBaseCompletionProposalPaintItem;\r\n FOnMeasureItem: TSynBaseCompletionProposalMeasureItem;\r\n FOnChangePosition: TCompletionChange;\r\n FItemList: TUnicodeStrings;\r\n FInsertList: TUnicodeStrings;\r\n FAssignedList: TUnicodeStrings;\r\n FPosition: Integer;\r\n FLinesInWindow: Integer;\r\n FTitleFontHeight: Integer;\r\n FFontHeight: integer;\r\n FScrollbar: TScrollBar;\r\n FOnValidate: TValidateEvent;\r\n FOnCancel: TNotifyEvent;\r\n FClSelect: TColor;\r\n fClSelectText: TColor;\r\n FClTitleBackground: TColor;\r\n fClBackGround: TColor;\r\n Bitmap: TBitmap; // used for drawing\r\n TitleBitmap: TBitmap; // used for title-drawing\r\n FCurrentEditor: TCustomSynEdit;\r\n FTitle: UnicodeString;\r\n FTitleFont: TFont;\r\n FFont: TFont;\r\n FResizeable: Boolean;\r\n FItemHeight: Integer;\r\n FMargin: Integer;\r\n FEffectiveItemHeight: Integer;\r\n FImages: TImageList;\r\n\r\n//These are the reflections of the Options property of the CompletionProposal\r\n FCase: boolean;\r\n FMatchText: Boolean;\r\n FFormattedText: Boolean;\r\n FCenterTitle: Boolean;\r\n FUseInsertList: boolean;\r\n FCompleteWithTab: Boolean;\r\n FCompleteWithEnter: Boolean;\r\n\r\n FMouseWheelAccumulator: integer;\r\n FDisplayKind: SynCompletionType;\r\n FParameterToken: TCompletionParameter;\r\n FCurrentIndex: Integer;\r\n FCurrentLevel: Integer;\r\n FDefaultKind: SynCompletionType;\r\n FEndOfTokenChr: UnicodeString;\r\n FTriggerChars: UnicodeString;\r\n OldShowCaret: Boolean;\r\n FHeightBuffer: Integer;\r\n FColumns: TProposalColumns;\r\n procedure SetCurrentString(const Value: UnicodeString);\r\n procedure MoveLine(cnt: Integer);\r\n procedure ScrollbarOnChange(Sender: TObject);\r\n procedure ScrollbarOnScroll(Sender: TObject; ScrollCode: TScrollCode; var ScrollPos: Integer);\r\n procedure ScrollbarOnEnter(Sender: TObject);\r\n\r\n procedure SetItemList(const Value: TUnicodeStrings);\r\n procedure SetInsertList(const Value: TUnicodeStrings);\r\n procedure SetPosition(const Value: Integer);\r\n procedure SetResizeable(const Value: Boolean);\r\n procedure SetItemHeight(const Value: Integer);\r\n procedure SetImages(const Value: TImageList);\r\n procedure StringListChange(Sender: TObject);\r\n procedure DoDoubleClick(Sender : TObject);\r\n procedure DoFormShow(Sender: TObject);\r\n procedure DoFormHide(Sender: TObject);\r\n procedure AdjustScrollBarPosition;\r\n procedure AdjustMetrics;\r\n procedure SetTitle(const Value: UnicodeString);\r\n procedure SetFont(const Value: TFont);\r\n procedure SetTitleFont(const Value: TFont);\r\n procedure SetColumns(Value: TProposalColumns);\r\n procedure TitleFontChange(Sender: TObject);\r\n procedure FontChange(Sender: TObject);\r\n procedure RecalcItemHeight;\r\n function IsWordBreakChar(AChar: WideChar): Boolean;\r\n protected\r\n procedure DoKeyPressW(Key: WideChar);\r\n procedure KeyDown(var Key: Word; Shift: TShiftState); override;\r\n procedure KeyPress(var Key: Char); override;\r\n procedure KeyPressW(var Key: WideChar); virtual;\r\n procedure Paint; override;\r\n procedure Activate; override;\r\n procedure Deactivate; override;\r\n procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;\r\n procedure Resize; override;\r\n procedure Notification(AComponent: TComponent; Operation: TOperation); override;\r\n{$IFDEF SYN_CLX}\r\n function DoMouseWheel(Shift: TShiftState; WheelDelta: Integer;\r\n const MousePos: TPoint): Boolean; override;\r\n procedure KeyString(var S: UnicodeString; var Handled: Boolean); override; \r\n function WidgetFlags: Integer; override;\r\n{$ELSE}\r\n procedure WMChar(var Msg: TWMChar); message WM_CHAR;\r\n procedure WMMouseWheel(var Msg: TMessage); message WM_MOUSEWHEEL;\r\n procedure WMActivate (var Message: TWMActivate); message WM_ACTIVATE;\r\n procedure WMEraseBackgrnd(var Message: TMessage); message WM_ERASEBKGND;\r\n procedure WMGetDlgCode(var Message: TWMGetDlgCode); message WM_GETDLGCODE;\r\n procedure CreateParams(var Params: TCreateParams); override;\r\n procedure CreateWnd; override;\r\n {$IFDEF SYN_DELPHI_4_UP}\r\n function CanResize(var NewWidth, NewHeight: Integer): Boolean; override;\r\n {$ENDIF}\r\n{$ENDIF}\r\n public\r\n constructor Create(AOwner: Tcomponent); override;\r\n destructor Destroy; override;\r\n\r\n function LogicalToPhysicalIndex(Index: Integer): Integer;\r\n function PhysicalToLogicalIndex(Index: Integer): Integer;\r\n\r\n property DisplayType: SynCompletionType read FDisplayKind write FDisplayKind;\r\n property DefaultType: SynCompletionType read FDefaultKind write FDefaultKind default ctCode;\r\n property CurrentString: UnicodeString read FCurrentString write SetCurrentString;\r\n property CurrentIndex: Integer read FCurrentIndex write FCurrentIndex;\r\n property CurrentLevel: Integer read FCurrentLevel write FCurrentLevel;\r\n property OnParameterToken: TCompletionParameter read FParameterToken write FParameterToken;\r\n property OnKeyPress: TKeyPressWEvent read FOnKeyPress write FOnKeyPress;\r\n property OnPaintItem: TSynBaseCompletionProposalPaintItem read FOnPaintItem write FOnPaintItem;\r\n property OnMeasureItem: TSynBaseCompletionProposalMeasureItem read FOnMeasureItem write FOnMeasureItem;\r\n property OnValidate: TValidateEvent read FOnValidate write FOnValidate;\r\n property OnCancel: TNotifyEvent read FOnCancel write FOnCancel;\r\n property ItemList: TUnicodeStrings read FItemList write SetItemList;\r\n property InsertList: TUnicodeStrings read FInsertList write SetInsertList;\r\n property AssignedList: TUnicodeStrings read FAssignedList write FAssignedList;\r\n property Position: Integer read FPosition write SetPosition;\r\n property Title: UnicodeString read fTitle write SetTitle;\r\n property ClSelect: TColor read FClSelect write FClSelect default clHighlight;\r\n property ClSelectedText: TColor read FClSelectText write FClSelectText default clHighlightText;\r\n property ClBackground: TColor read FClBackGround write FClBackGround default clWindow;\r\n property ClTitleBackground: TColor read FClTitleBackground write FClTitleBackground default clBtnFace;\r\n property ItemHeight: Integer read FItemHeight write SetItemHeight default 0;\r\n property Margin: Integer read FMargin write FMargin default 2;\r\n\r\n property UsePrettyText: boolean read FFormattedText write FFormattedText default False;\r\n property UseInsertList: boolean read FUseInsertList write FUseInsertList default False;\r\n property CenterTitle: boolean read FCenterTitle write FCenterTitle default True;\r\n property CaseSensitive: Boolean read fCase write fCase default False;\r\n property CurrentEditor: TCustomSynEdit read fCurrentEditor write fCurrentEditor;\r\n property MatchText: Boolean read fMatchText write fMatchText;\r\n property EndOfTokenChr: UnicodeString read FEndOfTokenChr write FEndOfTokenChr;\r\n property TriggerChars: UnicodeString read FTriggerChars write FTriggerChars;\r\n property CompleteWithTab: Boolean read FCompleteWithTab write FCompleteWithTab;\r\n property CompleteWithEnter: Boolean read FCompleteWithEnter write FCompleteWithEnter;\r\n\r\n property TitleFont: TFont read fTitleFont write SetTitleFont;\r\n property Font: TFont read fFont write SetFont;\r\n property Columns: TProposalColumns read FColumns write SetColumns;\r\n property Resizeable: Boolean read FResizeable write SetResizeable default True;\r\n property Images: TImageList read FImages write SetImages;\r\n end;\r\n\r\n TSynBaseCompletionProposal = class(TComponent)\r\n private\r\n FForm: TSynBaseCompletionProposalForm;\r\n FOnExecute: TCompletionExecute;\r\n FOnClose: TNotifyEvent;\r\n FOnShow: TNotifyEvent;\r\n FWidth: Integer;\r\n FPreviousToken: UnicodeString;\r\n FDotOffset: Integer;\r\n FOptions: TSynCompletionOptions;\r\n FNbLinesInWindow: Integer;\r\n\r\n FCanExecute: Boolean;\r\n function GetClSelect: TColor;\r\n procedure SetClSelect(const Value: TColor);\r\n function GetCurrentString: UnicodeString;\r\n function GetItemList: TUnicodeStrings;\r\n function GetInsertList: TUnicodeStrings;\r\n function GetOnCancel: TNotifyEvent;\r\n function GetOnKeyPress: TKeyPressWEvent;\r\n function GetOnPaintItem: TSynBaseCompletionProposalPaintItem;\r\n function GetOnMeasureItem: TSynBaseCompletionProposalMeasureItem;\r\n function GetOnValidate: TValidateEvent;\r\n function GetPosition: Integer;\r\n procedure SetCurrentString(const Value: UnicodeString);\r\n procedure SetItemList(const Value: TUnicodeStrings);\r\n procedure SetInsertList(const Value: TUnicodeStrings);\r\n procedure SetNbLinesInWindow(const Value: Integer);\r\n procedure SetOnCancel(const Value: TNotifyEvent);\r\n procedure SetOnKeyPress(const Value: TKeyPressWEvent);\r\n procedure SetOnPaintItem(const Value: TSynBaseCompletionProposalPaintItem);\r\n procedure SetOnMeasureItem(const Value: TSynBaseCompletionProposalMeasureItem);\r\n procedure SetPosition(const Value: Integer);\r\n procedure SetOnValidate(const Value: TValidateEvent);\r\n procedure SetWidth(Value: Integer);\r\n procedure SetImages(const Value: TImageList);\r\n function GetDisplayKind: SynCompletionType;\r\n procedure SetDisplayKind(const Value: SynCompletionType);\r\n function GetParameterToken: TCompletionParameter;\r\n procedure SetParameterToken(const Value: TCompletionParameter);\r\n function GetDefaultKind: SynCompletionType;\r\n procedure SetDefaultKind(const Value: SynCompletionType);\r\n function GetClBack: TColor;\r\n procedure SetClBack(const Value: TColor);\r\n function GetClSelectedText: TColor;\r\n procedure SetClSelectedText(const Value: TColor);\r\n function GetEndOfTokenChar: UnicodeString;\r\n procedure SetEndOfTokenChar(const Value: UnicodeString);\r\n function GetClTitleBackground: TColor;\r\n procedure SetClTitleBackground(const Value: TColor);\r\n procedure SetTitle(const Value: UnicodeString);\r\n function GetTitle: UnicodeString;\r\n function GetFont: TFont;\r\n function GetTitleFont: TFont;\r\n procedure SetFont(const Value: TFont);\r\n procedure SetTitleFont(const Value: TFont);\r\n function GetOptions: TSynCompletionOptions;\r\n function GetTriggerChars: UnicodeString;\r\n procedure SetTriggerChars(const Value: UnicodeString);\r\n function GetOnChange: TCompletionChange;\r\n procedure SetOnChange(const Value: TCompletionChange);\r\n procedure SetColumns(const Value: TProposalColumns);\r\n function GetColumns: TProposalColumns;\r\n function GetResizeable: Boolean;\r\n procedure SetResizeable(const Value: Boolean);\r\n function GetItemHeight: Integer;\r\n procedure SetItemHeight(const Value: Integer);\r\n function GetMargin: Integer;\r\n procedure SetMargin(const Value: Integer);\r\n function GetImages: TImageList;\r\n function IsWordBreakChar(AChar: WideChar): Boolean;\r\n protected\r\n procedure DefineProperties(Filer: TFiler); override;\r\n procedure SetOptions(const Value: TSynCompletionOptions); virtual;\r\n procedure EditorCancelMode(Sender: TObject); virtual; \r\n procedure HookedEditorCommand(Sender: TObject; AfterProcessing: Boolean;\r\n var Handled: Boolean; var Command: TSynEditorCommand; var AChar: WideChar;\r\n Data: Pointer; HandlerData: Pointer); virtual;\r\n public\r\n constructor Create(Aowner: TComponent); override;\r\n procedure Execute(s: UnicodeString; x, y: Integer);\r\n procedure ExecuteEx(s: UnicodeString; x, y: Integer; Kind: SynCompletionType\r\n {$IFDEF SYN_COMPILER_4_UP} = ctCode {$ENDIF}); virtual;\r\n procedure Activate;\r\n procedure Deactivate;\r\n\r\n procedure ClearList;\r\n function DisplayItem(AIndex: Integer): UnicodeString;\r\n function InsertItem(AIndex: Integer): UnicodeString;\r\n procedure AddItemAt(Where: Integer; ADisplayText, AInsertText: UnicodeString);\r\n procedure AddItem(ADisplayText, AInsertText: UnicodeString);\r\n procedure ResetAssignedList;\r\n\r\n property OnKeyPress: TKeyPressWEvent read GetOnKeyPress write SetOnKeyPress;\r\n property OnValidate: TValidateEvent read GetOnValidate write SetOnValidate;\r\n property OnCancel: TNotifyEvent read GetOnCancel write SetOnCancel;\r\n property CurrentString: UnicodeString read GetCurrentString write SetCurrentString;\r\n property DotOffset: Integer read FDotOffset write FDotOffset;\r\n property DisplayType: SynCompletionType read GetDisplayKind write SetDisplayKind;\r\n property Form: TSynBaseCompletionProposalForm read FForm;\r\n property PreviousToken: UnicodeString read FPreviousToken;\r\n property Position: Integer read GetPosition write SetPosition;\r\n published\r\n property DefaultType: SynCompletionType read GetDefaultKind write SetDefaultKind default ctCode;\r\n property Options: TSynCompletionOptions read GetOptions write SetOptions default DefaultProposalOptions;\r\n\r\n property ItemList: TUnicodeStrings read GetItemList write SetItemList;\r\n property InsertList: TUnicodeStrings read GetInsertList write SetInsertList;\r\n property NbLinesInWindow: Integer read FNbLinesInWindow write SetNbLinesInWindow default 8;\r\n property ClSelect: TColor read GetClSelect write SetClSelect default clHighlight;\r\n property ClSelectedText: TColor read GetClSelectedText write SetClSelectedText default clHighlightText;\r\n property ClBackground: TColor read GetClBack write SetClBack default clWindow;\r\n property ClTitleBackground: TColor read GetClTitleBackground write SetClTitleBackground default clBtnFace;\r\n property Width: Integer read FWidth write SetWidth default 260;\r\n property EndOfTokenChr: UnicodeString read GetEndOfTokenChar write SetEndOfTokenChar;\r\n property TriggerChars: UnicodeString read GetTriggerChars write SetTriggerChars;\r\n property Title: UnicodeString read GetTitle write SetTitle;\r\n property Font: TFont read GetFont write SetFont;\r\n property TitleFont: TFont read GetTitleFont write SetTitleFont;\r\n property Columns: TProposalColumns read GetColumns write SetColumns;\r\n property Resizeable: Boolean read GetResizeable write SetResizeable default True;\r\n property ItemHeight: Integer read GetItemHeight write SetItemHeight default 0;\r\n property Images: TImageList read GetImages write SetImages default nil;\r\n property Margin: Integer read GetMargin write SetMargin default 2;\r\n\r\n property OnChange: TCompletionChange read GetOnChange write SetOnChange;\r\n property OnClose: TNotifyEvent read FOnClose write FOnClose;\r\n property OnExecute: TCompletionExecute read FOnExecute write FOnExecute;\r\n property OnMeasureItem: TSynBaseCompletionProposalMeasureItem read GetOnMeasureItem write SetOnMeasureItem;\r\n property OnPaintItem: TSynBaseCompletionProposalPaintItem read GetOnPaintItem write SetOnPaintItem;\r\n property OnParameterToken: TCompletionParameter read GetParameterToken write SetParameterToken;\r\n property OnShow: TNotifyEvent read FOnShow write FOnShow;\r\n end;\r\n\r\n TSynCompletionProposal = class(TSynBaseCompletionProposal)\r\n private\r\n fEditors: TList;\r\n FShortCut: TShortCut;\r\n FNoNextKey: Boolean;\r\n FCompletionStart: Integer;\r\n FAdjustCompletionStart: Boolean;\r\n {$IFDEF SYN_CLX} // Missing-ShowWindow-Workaround\r\n FIgnoreFocusCommands: Boolean;\r\n {$ENDIF}\r\n FOnCodeCompletion: TCodeCompletionEvent;\r\n FTimer: TTimer;\r\n FTimerInterval: Integer;\r\n FEditor: TCustomSynEdit;\r\n FOnAfterCodeCompletion: TAfterCodeCompletionEvent;\r\n FOnCancelled: TNotifyEvent;\r\n procedure SetEditor(const Value: TCustomSynEdit);\r\n procedure HandleOnCancel(Sender: TObject);\r\n procedure HandleOnValidate(Sender: TObject; Shift: TShiftState; EndToken: WideChar);\r\n procedure HandleOnKeyPress(Sender: TObject; var Key: WideChar);\r\n procedure HandleDblClick(Sender: TObject);\r\n procedure EditorKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);\r\n procedure EditorKeyPress(Sender: TObject; var Key: WideChar);\r\n procedure TimerExecute(Sender: TObject);\r\n function GetPreviousToken(AEditor: TCustomSynEdit): UnicodeString;\r\n function GetCurrentInput(AEditor: TCustomSynEdit): UnicodeString;\r\n function GetTimerInterval: Integer;\r\n procedure SetTimerInterval(const Value: Integer);\r\n function GetEditor(i: Integer): TCustomSynEdit;\r\n procedure InternalCancelCompletion; \r\n protected\r\n procedure DoExecute(AEditor: TCustomSynEdit); virtual;\r\n procedure Notification(AComponent: TComponent; Operation: TOperation); override;\r\n procedure SetShortCut(Value: TShortCut);\r\n procedure SetOptions(const Value: TSynCompletionOptions); override;\r\n procedure EditorCancelMode(Sender: TObject); override;\r\n procedure HookedEditorCommand(Sender: TObject; AfterProcessing: Boolean;\r\n var Handled: Boolean; var Command: TSynEditorCommand; var AChar: WideChar;\r\n Data: Pointer; HandlerData: Pointer); override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n procedure AddEditor(AEditor: TCustomSynEdit);\r\n function RemoveEditor(AEditor: TCustomSynEdit): boolean;\r\n function EditorsCount: integer;\r\n procedure ExecuteEx(s: UnicodeString; x, y: Integer; Kind : SynCompletionType\r\n {$IFDEF SYN_COMPILER_4_UP} = ctCode {$ENDIF}); override;\r\n procedure ActivateCompletion;\r\n procedure CancelCompletion; \r\n procedure ActivateTimer(ACurrentEditor: TCustomSynEdit);\r\n procedure DeactivateTimer;\r\n property Editors[i: Integer]: TCustomSynEdit read GetEditor;\r\n property CompletionStart: Integer read FCompletionStart write FCompletionStart; // ET 04/02/2003\r\n published\r\n property ShortCut: TShortCut read FShortCut write SetShortCut;\r\n property Editor: TCustomSynEdit read FEditor write SetEditor;\r\n property TimerInterval: Integer read GetTimerInterval write SetTimerInterval default 1000;\r\n\r\n property OnAfterCodeCompletion: TAfterCodeCompletionEvent read FOnAfterCodeCompletion write FOnAfterCodeCompletion;\r\n property OnCancelled: TNotifyEvent read FOnCancelled write FOnCancelled;\r\n property OnCodeCompletion: TCodeCompletionEvent read FOnCodeCompletion write FOnCodeCompletion;\r\n end;\r\n\r\n TSynAutoComplete = class(TComponent)\r\n private\r\n FShortCut: TShortCut;\r\n fEditor: TCustomSynEdit;\r\n fAutoCompleteList: TUnicodeStrings;\r\n fNoNextKey : Boolean;\r\n FEndOfTokenChr: UnicodeString;\r\n FOnBeforeExecute: TNotifyEvent; \r\n FOnAfterExecute: TNotifyEvent; \r\n FInternalCompletion: TSynCompletionProposal;\r\n FDoLookup: Boolean;\r\n FOptions: TSynCompletionOptions;\r\n procedure SetAutoCompleteList(List: TUnicodeStrings);\r\n procedure SetEditor(const Value: TCustomSynEdit);\r\n procedure SetDoLookup(const Value: Boolean);\r\n procedure CreateInternalCompletion;\r\n function GetOptions: TSynCompletionOptions;\r\n procedure SetOptions(const Value: TSynCompletionOptions);\r\n procedure DoInternalAutoCompletion(Sender: TObject;\r\n const Value: UnicodeString; Shift: TShiftState; Index: Integer;\r\n EndToken: WideChar);\r\n function GetExecuting: Boolean;\r\n protected\r\n procedure SetShortCut(Value: TShortCut);\r\n procedure Notification(AComponent: TComponent; Operation: TOperation);\r\n override;\r\n procedure EditorKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);\r\n virtual;\r\n procedure EditorKeyPress(Sender: TObject; var Key: WideChar); virtual;\r\n function GetPreviousToken(Editor: TCustomSynEdit): UnicodeString;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n procedure Execute(Token: UnicodeString; Editor: TCustomSynEdit);\r\n procedure ExecuteEx(Token: UnicodeString; Editor: TCustomSynEdit; LookupIfNotExact: Boolean);\r\n function GetTokenList: UnicodeString;\r\n function GetTokenValue(Token: UnicodeString): UnicodeString;\r\n procedure CancelCompletion;\r\n property Executing: Boolean read GetExecuting;\r\n published\r\n property AutoCompleteList: TUnicodeStrings read fAutoCompleteList\r\n write SetAutoCompleteList;\r\n property EndOfTokenChr: UnicodeString read FEndOfTokenChr write FEndOfTokenChr;\r\n property Editor: TCustomSynEdit read fEditor write SetEditor;\r\n property ShortCut: TShortCut read FShortCut write SetShortCut;\r\n property OnBeforeExecute: TNotifyEvent read FOnBeforeExecute write FOnBeforeExecute;\r\n property OnAfterExecute: TNotifyEvent read FOnAfterExecute write FOnAfterExecute;\r\n property DoLookupWhenNotExact: Boolean read FDoLookup write SetDoLookup default true;\r\n property Options: TSynCompletionOptions read GetOptions write SetOptions default DefaultProposalOptions;\r\n end;\r\n\r\n TProposalColumn = class(TCollectionItem)\r\n private\r\n FColumnWidth: Integer;\r\n FInternalWidth: Integer;\r\n FFontStyle: TFontStyles;\r\n protected\r\n procedure DefineProperties(Filer: TFiler); override;\r\n public\r\n constructor Create(Collection: TCollection); override;\r\n destructor Destroy; override;\r\n procedure Assign(Source: TPersistent); override;\r\n published\r\n property ColumnWidth: Integer read FColumnWidth write FColumnWidth;\r\n property DefaultFontStyle: TFontStyles read FFontStyle write FFontStyle default [];\r\n end;\r\n\r\n TProposalColumns = class(TCollection)\r\n private\r\n FOwner: TPersistent;\r\n function GetItem(Index: Integer): TProposalColumn;\r\n procedure SetItem(Index: Integer; Value: TProposalColumn);\r\n protected\r\n function GetOwner: TPersistent; {$IFDEF SYN_COMPILER_3_UP} override; {$ENDIF}\r\n public\r\n constructor Create(AOwner: TPersistent; ItemClass: TCollectionItemClass);\r\n function Add: TProposalColumn;\r\n {$IFDEF SYN_COMPILER_3_UP}\r\n function FindItemID(ID: Integer): TProposalColumn;\r\n {$ENDIF}\r\n {$IFDEF SYN_COMPILER_4_UP}\r\n function Insert(Index: Integer): TProposalColumn;\r\n {$ENDIF}\r\n property Items[Index: Integer]: TProposalColumn read GetItem write SetItem; default;\r\n end;\r\n\r\n\r\nprocedure FormattedTextOut(TargetCanvas: TCanvas; const Rect: TRect;\r\n const Text: UnicodeString; Selected: Boolean; Columns: TProposalColumns; Images: TImageList);\r\nfunction FormattedTextWidth(TargetCanvas: TCanvas; const Text: UnicodeString;\r\n Columns: TProposalColumns; Images: TImageList): Integer;\r\nfunction PrettyTextToFormattedString(const APrettyText: UnicodeString;\r\n AlternateBoldStyle: Boolean {$IFDEF SYN_COMPILER_4_UP} = False {$ENDIF}): UnicodeString;\r\n\r\nimplementation\r\n\r\nuses\r\n{$IFDEF SYN_COMPILER_4_UP}\r\n Math,\r\n{$ENDIF}\r\n{$IFDEF SYN_CLX}\r\n QSynEditTextBuffer,\r\n QSynEditMiscProcs,\r\n QSynEditKeyConst;\r\n{$ELSE}\r\n SynEditTextBuffer,\r\n SynEditMiscProcs,\r\n SynEditKeyConst, System.UITypes, System.Types;\r\n{$ENDIF}\r\n\r\nconst\r\n TextHeightString = 'CompletionProposal';\r\n\r\n//------------------------- Formatted painting stuff ---------------------------\r\n\r\ntype\r\n TFormatCommand = (fcNoCommand, fcColor, fcStyle, fcColumn, fcHSpace, fcImage);\r\n TFormatCommands = set of TFormatCommand;\r\n\r\n PFormatChunk = ^TFormatChunk;\r\n TFormatChunk = record\r\n Str: UnicodeString;\r\n Command: TFormatCommand;\r\n Data: Pointer;\r\n end;\r\n\r\n PFormatStyleData = ^TFormatStyleData;\r\n TFormatStyleData = record\r\n Style: WideChar;\r\n Action: Integer; // -1 = Reset, +1 = Set, 0 = Toggle\r\n end;\r\n\r\n TFormatChunkList = class\r\n private\r\n FChunks: TList;\r\n function GetCount: Integer;\r\n function GetChunk(Index: Integer): PFormatChunk;\r\n public\r\n constructor Create;\r\n destructor Destroy; override;\r\n procedure Clear;\r\n procedure Add(AChunk: PFormatChunk);\r\n property Count: Integer read GetCount;\r\n property Chunks[Index: Integer]: PFormatChunk read GetChunk; default;\r\n end;\r\n\r\n\r\nconst\r\n AllCommands = [fcColor..High(TFormatCommand)];\r\n\r\n\r\nfunction TFormatChunkList.GetCount: Integer;\r\nbegin\r\n Result := FChunks.Count;\r\nend;\r\n\r\nfunction TFormatChunkList.GetChunk(Index: Integer): PFormatChunk;\r\nbegin\r\n Result := FChunks[Index];\r\nend;\r\n\r\nprocedure TFormatChunkList.Clear;\r\nvar\r\n C: PFormatChunk;\r\n StyleFormatData: PFormatStyleData;\r\nbegin\r\n while FChunks.Count > 0 do\r\n begin\r\n C := FChunks.Last;\r\n FChunks.Delete(FChunks.Count-1);\r\n\r\n case C^.Command of\r\n fcStyle:\r\n begin\r\n StyleFormatData := C^.Data;\r\n Dispose(StyleFormatData);\r\n end;\r\n end;\r\n\r\n Dispose(C);\r\n end;\r\nend;\r\n\r\nconstructor TFormatChunkList.Create;\r\nbegin\r\n inherited Create;\r\n FChunks := TList.Create;\r\nend;\r\n\r\ndestructor TFormatChunkList.Destroy;\r\nbegin\r\n Clear;\r\n FChunks.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TFormatChunkList.Add(AChunk: PFormatChunk);\r\nbegin\r\n FChunks.Add(AChunk);\r\nend;\r\n\r\n\r\nfunction ParseFormatChunks(const FormattedString: UnicodeString; ChunkList: TFormatChunkList;\r\n const StripCommands: TFormatCommands): Boolean;\r\nvar\r\n CurChar: WideChar;\r\n CurPos: Integer;\r\n CurrentChunk: UnicodeString;\r\n PossibleErrorPos: Integer;\r\n ErrorFound: Boolean;\r\n\r\n procedure NextChar;\r\n begin\r\n inc(CurPos);\r\n {$IFOPT R+}\r\n // Work-around Delphi's annoying behaviour of failing the RangeCheck when\r\n // reading the final #0 char\r\n if CurPos = Length(FormattedString) +1 then\r\n CurChar := #0\r\n else\r\n {$ENDIF}\r\n CurChar := FormattedString[CurPos];\r\n end;\r\n\r\n procedure AddStringChunk;\r\n var\r\n C: PFormatChunk;\r\n begin\r\n C := New(PFormatChunk);\r\n C^.Str := CurrentChunk;\r\n C^.Command := fcNoCommand;\r\n C^.Data := nil;\r\n ChunkList.Add(C);\r\n\r\n CurrentChunk := '';\r\n end;\r\n\r\n procedure AddCommandChunk(ACommand: TFormatCommand; Data: Pointer);\r\n var\r\n C: PFormatChunk;\r\n begin\r\n C := New(PFormatChunk);\r\n C^.Str := '';\r\n C^.Command := ACommand;\r\n C^.Data := Data;\r\n ChunkList.Add(C);\r\n end;\r\n\r\n procedure ParseEscapeSequence;\r\n var\r\n Command: UnicodeString;\r\n Parameter: UnicodeString;\r\n CommandType: TFormatCommand;\r\n Data: Pointer;\r\n begin\r\n Assert(CurChar = '\\');\r\n NextChar;\r\n if CurChar = '\\' then\r\n begin\r\n CurrentChunk := CurrentChunk + '\\';\r\n NextChar;\r\n exit;\r\n end;\r\n\r\n if CurrentChunk <> '' then\r\n AddStringChunk;\r\n\r\n Command := '';\r\n while (CurChar <> '{') and (CurPos <= Length(FormattedString)) do\r\n begin\r\n Command := Command +CurChar;\r\n NextChar;\r\n end;\r\n\r\n if CurChar = '{' then\r\n begin\r\n PossibleErrorPos := CurPos;\r\n NextChar;\r\n Parameter := '';\r\n while (CurChar <> '}') and (CurPos <= Length(FormattedString)) do\r\n begin\r\n Parameter := Parameter + CurChar;\r\n NextChar;\r\n end;\r\n\r\n if CurChar = '}' then\r\n begin\r\n Command := SynWideUpperCase(Command);\r\n\r\n Data := nil;\r\n CommandType := fcNoCommand;\r\n\r\n if Command = 'COLOR' then\r\n begin\r\n try\r\n Data := Pointer(StringToColor(Parameter));\r\n CommandType := fcColor;\r\n except\r\n CommandType := fcNoCommand;\r\n ErrorFound := True;\r\n end;\r\n end else\r\n if Command = 'COLUMN' then\r\n begin\r\n if Parameter <> '' then\r\n begin\r\n CommandType := fcNoCommand;\r\n ErrorFound := True;\r\n end else\r\n CommandType := fcColumn;\r\n end else\r\n if Command = 'HSPACE' then\r\n begin\r\n try\r\n Data := Pointer(StrToInt(Parameter));\r\n CommandType := fcHSpace;\r\n except\r\n CommandType := fcNoCommand;\r\n ErrorFound := True;\r\n end;\r\n end else\r\n if Command = 'IMAGE' then\r\n begin\r\n try\r\n Data := Pointer(StrToInt(Parameter));\r\n CommandType := fcImage;\r\n except\r\n CommandType := fcNoCommand;\r\n ErrorFound := True;\r\n end;\r\n end else\r\n if Command = 'STYLE' then\r\n begin\r\n if (Length(Parameter) = 2)\r\n and CharInSet(Parameter[1], ['+', '-', '~'])\r\n and CharInSet(SynWideUpperCase(Parameter[2])[1],\r\n ['B', 'I', 'U', 'S']) then\r\n begin\r\n CommandType := fcStyle;\r\n if not (fcStyle in StripCommands) then\r\n begin\r\n Data := New(PFormatStyleData);\r\n PFormatStyleData(Data)^.Style := SynWideUpperCase(Parameter[2])[1];\r\n case Parameter[1] of\r\n '+': PFormatStyleData(Data)^.Action := 1;\r\n '-': PFormatStyleData(Data)^.Action := -1;\r\n '~': PFormatStyleData(Data)^.Action := 0;\r\n end;\r\n end;\r\n end else\r\n begin\r\n CommandType := fcNoCommand;\r\n ErrorFound := True;\r\n end;\r\n end else\r\n ErrorFound := True;\r\n\r\n if (CommandType <> fcNoCommand) and (not (CommandType in StripCommands)) then\r\n AddCommandChunk(CommandType, Data);\r\n\r\n NextChar;\r\n end;\r\n end;\r\n Result := not ErrorFound;\r\n end;\r\n\r\n procedure ParseString;\r\n begin\r\n Assert(CurChar <> '\\');\r\n while (CurChar <> '\\') and (CurPos <= Length(FormattedString)) do\r\n begin\r\n CurrentChunk := CurrentChunk +CurChar;\r\n NextChar;\r\n end;\r\n end;\r\n\r\nbegin\r\n Assert(Assigned(ChunkList));\r\n\r\n if FormattedString = '' then\r\n exit;\r\n\r\n ErrorFound := False;\r\n CurrentChunk := '';\r\n CurPos := 1;\r\n CurChar := FormattedString[1];\r\n\r\n while CurPos <= Length(FormattedString) do\r\n begin\r\n if CurChar = '\\' then\r\n ParseEscapeSequence\r\n else\r\n ParseString;\r\n end;\r\n\r\n if CurrentChunk <> '' then\r\n AddStringChunk;\r\nend;\r\n\r\n\r\nfunction StripFormatCommands(const FormattedString: UnicodeString): UnicodeString;\r\nvar\r\n Chunks: TFormatChunkList;\r\n i: Integer;\r\nbegin\r\n Chunks := TFormatChunkList.Create;\r\n try\r\n ParseFormatChunks(FormattedString, Chunks, AllCommands);\r\n\r\n Result := '';\r\n for i := 0 to Chunks.Count -1 do\r\n Result := Result + Chunks[i]^.Str;\r\n\r\n finally\r\n Chunks.Free;\r\n end;\r\nend;\r\n\r\n\r\nfunction PaintChunks(TargetCanvas: TCanvas; const Rect: TRect;\r\n ChunkList: TFormatChunkList; Columns: TProposalColumns; Images: TImageList;\r\n Invisible: Boolean): Integer;\r\nvar\r\n i: Integer;\r\n X: Integer;\r\n C: PFormatChunk;\r\n CurrentColumn: TProposalColumn;\r\n CurrentColumnIndex: Integer;\r\n LastColumnStart: Integer;\r\n Style: TFontStyles;\r\n OldFont: TFont;\r\nbegin\r\n OldFont := TFont.Create;\r\n try\r\n OldFont.Assign(TargetCanvas.Font);\r\n\r\n if Assigned(Columns) and (Columns.Count > 0) then\r\n begin\r\n CurrentColumnIndex := 0;\r\n CurrentColumn := TProposalColumn(Columns.Items[0]);\r\n TargetCanvas.Font.Style := CurrentColumn.FFontStyle;\r\n end else\r\n begin\r\n CurrentColumnIndex := -1;\r\n CurrentColumn := nil;\r\n end;\r\n\r\n LastColumnStart := Rect.Left;\r\n X := Rect.Left;\r\n\r\n TargetCanvas.Brush.Style := bsClear;\r\n\r\n for i := 0 to ChunkList.Count -1 do\r\n begin\r\n C := ChunkList[i];\r\n\r\n case C^.Command of\r\n fcNoCommand:\r\n begin\r\n if not Invisible then\r\n TextOut(TargetCanvas, X, Rect.Top, C^.Str);\r\n\r\n inc(X, TextWidth(TargetCanvas, C^.Str));\r\n if X > Rect.Right then\r\n break;\r\n end;\r\n fcColor:\r\n if not Invisible then\r\n TargetCanvas.Font.Color := TColor(C^.Data);\r\n fcStyle:\r\n begin\r\n case PFormatStyleData(C^.Data)^.Style of\r\n 'I': Style := [fsItalic];\r\n 'B': Style := [fsBold];\r\n 'U': Style := [fsUnderline];\r\n 'S': Style := [fsStrikeout];\r\n else Assert(False);\r\n end;\r\n\r\n\r\n case PFormatStyleData(C^.Data)^.Action of\r\n -1: TargetCanvas.Font.Style := TargetCanvas.Font.Style - Style;\r\n 0: if TargetCanvas.Font.Style * Style = [] then\r\n TargetCanvas.Font.Style := TargetCanvas.Font.Style + Style\r\n else\r\n TargetCanvas.Font.Style := TargetCanvas.Font.Style - Style;\r\n 1: TargetCanvas.Font.Style := TargetCanvas.Font.Style + Style;\r\n else Assert(False);\r\n end;\r\n end;\r\n fcColumn:\r\n if Assigned(Columns) and (Columns.Count > 0) then\r\n begin\r\n if CurrentColumnIndex <= Columns.Count -1 then\r\n begin\r\n inc(LastColumnStart, CurrentColumn.FColumnWidth);\r\n X := LastColumnStart;\r\n\r\n inc(CurrentColumnIndex);\r\n if CurrentColumnIndex <= Columns.Count -1 then\r\n begin\r\n CurrentColumn := TProposalColumn(Columns.Items[CurrentColumnIndex]);\r\n TargetCanvas.Font.Style := CurrentColumn.FFontStyle;\r\n end else\r\n CurrentColumn := nil;\r\n end;\r\n end;\r\n fcHSpace:\r\n begin\r\n inc(X, Integer(C^.Data));\r\n if X > Rect.Right then\r\n break;\r\n end;\r\n fcImage:\r\n begin\r\n Assert(Assigned(Images));\r\n\r\n Images.Draw(TargetCanvas, X, Rect.Top, Integer(C^.Data));\r\n\r\n inc(X, Images.Width);\r\n if X > Rect.Right then\r\n break;\r\n end;\r\n end;\r\n end;\r\n\r\n Result := X;\r\n TargetCanvas.Font.Assign(OldFont);\r\n finally\r\n OldFont.Free;\r\n TargetCanvas.Brush.Style := bsSolid;\r\n end;\r\nend;\r\n\r\nprocedure FormattedTextOut(TargetCanvas: TCanvas; const Rect: TRect;\r\n const Text: UnicodeString; Selected: Boolean; Columns: TProposalColumns; Images: TImageList);\r\nvar\r\n Chunks: TFormatChunkList;\r\n StripCommands: TFormatCommands;\r\nbegin\r\n Chunks := TFormatChunkList.Create;\r\n try\r\n if Selected then\r\n StripCommands := [fcColor]\r\n else\r\n StripCommands := [];\r\n\r\n ParseFormatChunks(Text, Chunks, StripCommands);\r\n PaintChunks(TargetCanvas, Rect, Chunks, Columns, Images, False);\r\n finally\r\n Chunks.Free;\r\n end;\r\nend;\r\n\r\nfunction FormattedTextWidth(TargetCanvas: TCanvas; const Text: UnicodeString;\r\n Columns: TProposalColumns; Images: TImageList): Integer;\r\nvar\r\n Chunks: TFormatChunkList;\r\n TmpRect: TRect;\r\nbegin\r\n Chunks := TFormatChunkList.Create;\r\n try\r\n TmpRect := Rect(0, 0, MaxInt, MaxInt);\r\n\r\n ParseFormatChunks(Text, Chunks, [fcColor]);\r\n Result := PaintChunks(TargetCanvas, TmpRect, Chunks, Columns, Images, True);\r\n finally\r\n Chunks.Free;\r\n end;\r\nend;\r\n\r\nfunction PrettyTextToFormattedString(const APrettyText: UnicodeString;\r\n AlternateBoldStyle: Boolean {$IFDEF SYN_COMPILER_4_UP} = False {$ENDIF}): UnicodeString;\r\nvar\r\n i: Integer;\r\n Color: TColor;\r\nBegin\r\n Result := '';\r\n i := 1;\r\n while i <= Length(APrettyText) do\r\n case APrettyText[i] of\r\n #1, #2:\r\n begin\r\n Color := (Ord(APrettyText[i + 3]) shl 8\r\n +Ord(APrettyText[i + 2])) shl 8\r\n +Ord(APrettyText[i + 1]);\r\n\r\n Result := Result+'\\color{'+ColorToString(Color)+'}';\r\n\r\n inc(i, 4);\r\n end;\r\n #3:\r\n begin\r\n if CharInSet(SynWideUpperCase(APrettyText[i + 1])[1], ['B', 'I', 'U']) then\r\n begin\r\n Result := Result + '\\style{';\r\n\r\n case APrettyText[i + 1] of\r\n 'B': Result := Result + '+B';\r\n 'b': Result := Result + '-B';\r\n 'I': Result := Result + '+I';\r\n 'i': Result := Result + '-I';\r\n 'U': Result := Result + '+U';\r\n 'u': Result := Result + '-U';\r\n end;\r\n\r\n Result := Result + '}';\r\n end;\r\n inc(i, 2);\r\n end;\r\n #9:\r\n begin\r\n Result := Result + '\\column{}';\r\n if AlternateBoldStyle then\r\n Result := Result + '\\style{~B}';\r\n inc(i);\r\n end;\r\n else\r\n Result := Result + APrettyText[i];\r\n inc(i);\r\n end;\r\nend;\r\n\r\n\r\n// TProposalColumn\r\n\r\nconstructor TProposalColumn.Create(Collection: TCollection);\r\nbegin\r\n inherited;\r\n FColumnWidth := 100;\r\n FInternalWidth := -1;\r\n FFontStyle := [];\r\nend;\r\n\r\ndestructor TProposalColumn.Destroy;\r\nbegin\r\n inherited;\r\nend;\r\n\r\nprocedure TProposalColumn.Assign(Source: TPersistent);\r\nbegin\r\n if Source is TProposalColumn then\r\n begin\r\n FColumnWidth := TProposalColumn(Source).FColumnWidth;\r\n FInternalWidth := TProposalColumn(Source).FInternalWidth;\r\n FFontStyle := TProposalColumn(Source).FFontStyle;\r\n end\r\n else\r\n inherited Assign(Source);\r\nend;\r\n\r\nprocedure TProposalColumn.DefineProperties(Filer: TFiler);\r\nbegin\r\n inherited;\r\n{$IFNDEF UNICODE}\r\n UnicodeDefineProperties(Filer, Self);\r\n{$ENDIF}\r\nend;\r\n\r\nconstructor TProposalColumns.Create(AOwner: TPersistent; ItemClass: TCollectionItemClass);\r\nbegin\r\n inherited Create(ItemClass);\r\n FOwner := AOwner;\r\nend;\r\n\r\nfunction TProposalColumns.GetOwner: TPersistent;\r\nbegin\r\n Result := FOwner;\r\nend;\r\n\r\nfunction TProposalColumns.GetItem(Index: Integer): TProposalColumn;\r\nbegin\r\n Result := inherited GetItem(Index) as TProposalColumn;\r\nend;\r\n\r\nprocedure TProposalColumns.SetItem(Index: Integer; Value: TProposalColumn);\r\nbegin\r\n inherited SetItem(Index, Value);\r\nend;\r\n\r\nfunction TProposalColumns.Add: TProposalColumn;\r\nbegin\r\n Result := inherited Add as TProposalColumn;\r\nend;\r\n\r\n\r\n{$IFDEF SYN_COMPILER_3_UP}\r\nfunction TProposalColumns.FindItemID(ID: Integer): TProposalColumn;\r\nbegin\r\n Result := inherited FindItemID(ID) as TProposalColumn;\r\nend;\r\n{$ENDIF}\r\n\r\n{$IFDEF SYN_COMPILER_4_UP}\r\nfunction TProposalColumns.Insert(Index: Integer): TProposalColumn;\r\nbegin\r\n Result := inherited Insert(Index) as TProposalColumn;\r\nend;\r\n{$ENDIF}\r\n\r\n\r\n\r\n//============================================================================\r\n\r\n\r\n//Moved from completion component\r\nfunction FormatParamList(const S: UnicodeString; CurrentIndex: Integer): UnicodeString;\r\nvar\r\n i: Integer;\r\n List: TUnicodeStrings;\r\nbegin\r\n Result := '';\r\n List := TUnicodeStringList.Create;\r\n try\r\n List.CommaText := S;\r\n for i := 0 to List.Count - 1 do\r\n begin\r\n if i = CurrentIndex then\r\n Result := Result + '\\style{~B}' + List[i] + '\\style{~B}'\r\n else\r\n Result := Result + List[i];\r\n\r\n if i < List.Count - 1 then\r\n// Result := Result + ', ';\r\n Result := Result + ' ';\r\n end;\r\n finally\r\n List.Free;\r\n end;\r\nend;\r\n// End GBN 10/11/2001\r\n\r\n{ TSynBaseCompletionProposalForm }\r\n\r\nconstructor TSynBaseCompletionProposalForm.Create(AOwner: TComponent);\r\nbegin\r\n FResizeable := True;\r\n{$IFDEF SYN_CPPB_1}\r\n CreateNew(AOwner, 0);\r\n{$ELSE}\r\n CreateNew(AOwner);\r\n{$ENDIF}\r\n Bitmap := TBitmap.Create;\r\n TitleBitmap := TBitmap.Create;\r\n FItemList := TUnicodeStringList.Create;\r\n FInsertList := TUnicodeStringList.Create;\r\n FAssignedList := TUnicodeStringList.Create;\r\n FMatchText := False;\r\n{$IFDEF SYN_CLX}\r\n BorderStyle := fbsNone;\r\n{$ELSE}\r\n BorderStyle := bsNone;\r\n{$ENDIF}\r\n FScrollbar := TScrollBar.Create(Self);\r\n FScrollbar.Kind := sbVertical;\r\n{$IFNDEF SYN_CLX}\r\n FScrollbar.ParentCtl3D := False;\r\n{$ENDIF}\r\n FScrollbar.OnChange := ScrollbarOnChange;\r\n FScrollbar.OnScroll := ScrollbarOnScroll;\r\n FScrollbar.OnEnter := ScrollbarOnEnter;\r\n FScrollbar.Parent := Self;\r\n Visible := False;\r\n\r\n FTitleFont := TFont.Create;\r\n FTitleFont.Name := 'MS Sans Serif';\r\n FTitleFont.Size := 8;\r\n FTitleFont.Style := [fsBold];\r\n FTitleFont.Color := clBtnText;\r\n\r\n FFont := TFont.Create;\r\n FFont.Name := 'MS Sans Serif';\r\n FFont.Size := 8;\r\n\r\n ClSelect := clHighlight;\r\n ClSelectedText := clHighlightText;\r\n ClBackground := clWindow;\r\n ClTitleBackground := clBtnFace;\r\n\r\n\r\n (FItemList as TUnicodeStringList).OnChange := StringListChange; // Really necessary? It seems to work\r\n FTitle := ''; // fine without it\r\n FUseInsertList := False;\r\n FFormattedText := False;\r\n FCenterTitle := True;\r\n FCase := False;\r\n\r\n FColumns := TProposalColumns.Create(AOwner, TProposalColumn);\r\n\r\n FItemHeight := 0;\r\n FMargin := 2;\r\n FEffectiveItemHeight := 0;\r\n RecalcItemHeight;\r\n\r\n Canvas.Font.Assign(FTitleFont);\r\n FTitleFontHeight := TextHeight(Canvas, TextHeightString);\r\n FHeightBuffer := 0;\r\n\r\n FTitleFont.OnChange := TitleFontChange;\r\n FFont.OnChange := FontChange;\r\n\r\n OnDblClick := DoDoubleClick;\r\n OnShow := DoFormShow;\r\n OnHide := DoFormHide;\r\nend;\r\n\r\n{$IFDEF SYN_CLX}\r\n\r\nfunction TSynBaseCompletionProposalForm.DoMouseWheel(Shift: TShiftState;\r\n WheelDelta: Integer; const MousePos: TPoint): Boolean;\r\nconst\r\n WHEEL_DIVISOR = 120; { according to Qt API... }\r\nvar\r\n iWheelClicks: integer;\r\n iLinesToScroll: integer;\r\nbegin\r\n if ssCtrl in Application.KeyState then\r\n iLinesToScroll := FLinesInWindow \r\n else\r\n iLinesToScroll := 3;\r\n Inc(fMouseWheelAccumulator, WheelDelta);\r\n iWheelClicks := fMouseWheelAccumulator div WHEEL_DIVISOR;\r\n fMouseWheelAccumulator := fMouseWheelAccumulator mod WHEEL_DIVISOR;\r\n Position := Position - iWheelClicks * iLinesToScroll;\r\n Update;\r\n Result := True;\r\nend;\r\n\r\nprocedure TSynBaseCompletionProposalForm.KeyString(var S: UnicodeString;\r\n var Handled: Boolean);\r\nvar\r\n i: Integer;\r\nbegin\r\n inherited;\r\n Handled := True;\r\n for i := 1 to Length(S) do\r\n DoKeyPressW(S[i]);\r\nend;\r\n\r\nfunction TSynBaseCompletionProposalForm.WidgetFlags: Integer;\r\nbegin\r\n Result := Integer(WidgetFlags_WType_Popup);\r\nend;\r\n\r\n{$ELSE SYN_CLX}\r\n\r\nprocedure TSynBaseCompletionProposalForm.CreateParams(var Params: TCreateParams);\r\nconst\r\n CS_DROPSHADOW = $20000;\r\n{$IFNDEF SYN_COMPILER_3_UP}\r\nvar\r\n VersionInfo: TOSVersionInfo;\r\n{$ENDIF}\r\nbegin\r\n inherited;\r\n with Params do\r\n begin\r\n Style := WS_POPUP;\r\n ExStyle := WS_EX_TOOLWINDOW;\r\n\r\n {$IFDEF SYN_COMPILER_3_UP}\r\n if ((Win32Platform and VER_PLATFORM_WIN32_NT) <> 0)\r\n and (Win32MajorVersion > 4)\r\n and (Win32MinorVersion > 0) {Windows XP} then\r\n {$ELSE}\r\n VersionInfo.dwOSVersionInfoSize := sizeof(TOSVersionInfo);\r\n if GetVersionEx(VersionInfo)\r\n and ((VersionInfo.dwPlatformId and VER_PLATFORM_WIN32_NT) <> 0)\r\n and (VersionInfo.dwMajorVersion > 4)\r\n and (VersionInfo.dwMinorVersion > 0) {Windows XP} then\r\n {$ENDIF}\r\n Params.WindowClass.style := Params.WindowClass.style or CS_DROPSHADOW;\r\n\r\n if DisplayType = ctCode then\r\n if FResizeable then\r\n Style := Style or WS_THICKFRAME\r\n else\r\n Style := Style or WS_DLGFRAME;\r\n end;\r\nend;\r\n\r\nprocedure TSynBaseCompletionProposalForm.CreateWnd;\r\nbegin\r\n inherited;\r\n\r\n if not (csDesigning in ComponentState) then\r\n begin\r\n // \"redefine\" window-procedure to get Unicode messages\r\n if Win32Platform = VER_PLATFORM_WIN32_NT then\r\n SetWindowLongW(Handle, GWL_WNDPROC, Integer(GetWindowLongA(Handle, GWL_WNDPROC)));\r\n end;\r\nend;\r\n{$ENDIF}\r\n\r\nprocedure TSynBaseCompletionProposalForm.Activate;\r\nbegin\r\n Visible := True;\r\n if DisplayType = ctCode then\r\n (CurrentEditor as TCustomSynEdit).AddFocusControl(Self);\r\nend;\r\n\r\nprocedure TSynBaseCompletionProposalForm.Deactivate;\r\nbegin\r\n if (DisplayType = ctCode) then\r\n (CurrentEditor as TCustomSynEdit).RemoveFocusControl(Self);\r\n Visible := False;\r\nend;\r\n\r\ndestructor TSynBaseCompletionProposalForm.Destroy;\r\nbegin\r\n inherited Destroy;\r\n FColumns.Free;\r\n Bitmap.Free;\r\n TitleBitmap.Free;\r\n FItemList.Free;\r\n FInsertList.Free;\r\n FAssignedList.Free;\r\n FTitleFont.Free;\r\n FFont.Free;\r\nend;\r\n\r\nprocedure TSynBaseCompletionProposalForm.KeyDown(var Key: Word; Shift: TShiftState);\r\nvar\r\n C: WideChar;\r\nbegin \r\n if DisplayType = ctCode then\r\n begin\r\n case Key of\r\n SYNEDIT_RETURN:\r\n if (FCompleteWithEnter) and Assigned(OnValidate) then\r\n OnValidate(Self, Shift, #0); \r\n SYNEDIT_TAB:\r\n if (FCompleteWithTab) and Assigned(OnValidate) then\r\n OnValidate(Self, Shift, #0); \r\n SYNEDIT_ESCAPE:\r\n begin\r\n if Assigned(OnCancel) then\r\n OnCancel(Self);\r\n end;\r\n SYNEDIT_LEFT:\r\n begin\r\n if Length(FCurrentString) > 0 then\r\n begin\r\n CurrentString := Copy(CurrentString, 1, Length(CurrentString) - 1);\r\n if Assigned(CurrentEditor) then\r\n (CurrentEditor as TCustomSynEdit).CommandProcessor(ecLeft, #0, nil);\r\n end\r\n else\r\n begin\r\n //Since we have control, we need to re-send the key to\r\n //the editor so that the cursor behaves properly\r\n if Assigned(CurrentEditor) then\r\n (CurrentEditor as TCustomSynEdit).CommandProcessor(ecLeft, #0, nil);\r\n\r\n if Assigned(OnCancel) then\r\n OnCancel(Self);\r\n end;\r\n end;\r\n SYNEDIT_RIGHT:\r\n begin\r\n if Assigned(CurrentEditor) then\r\n with CurrentEditor as TCustomSynEdit do\r\n begin\r\n if CaretX <= Length(LineText) then\r\n C := LineText[CaretX]\r\n else\r\n C := #32;\r\n\r\n if Self.IsWordBreakChar(C) then\r\n if Assigned(OnCancel) then\r\n OnCancel(Self)\r\n else\r\n else\r\n CurrentString := CurrentString + C;\r\n\r\n CommandProcessor(ecRight, #0, nil);\r\n end;\r\n end;\r\n SYNEDIT_PRIOR:\r\n MoveLine(-FLinesInWindow);\r\n SYNEDIT_NEXT:\r\n MoveLine(FLinesInWindow);\r\n SYNEDIT_END:\r\n Position := FAssignedList.Count - 1;\r\n SYNEDIT_HOME:\r\n Position := 0;\r\n SYNEDIT_UP:\r\n if ssCtrl in Shift then\r\n Position := 0\r\n else\r\n MoveLine(-1);\r\n SYNEDIT_DOWN:\r\n if ssCtrl in Shift then\r\n Position := FAssignedList.Count - 1\r\n else\r\n MoveLine(1);\r\n SYNEDIT_BACK:\r\n if (Shift = []) then\r\n begin\r\n if Length(FCurrentString) > 0 then\r\n begin\r\n CurrentString := Copy(CurrentString, 1, Length(CurrentString) - 1);\r\n\r\n if Assigned(CurrentEditor) then\r\n (CurrentEditor as TCustomSynEdit).CommandProcessor(ecDeleteLastChar, #0, nil);\r\n end\r\n else\r\n begin\r\n //Since we have control, we need to re-send the key to\r\n //the editor so that the cursor behaves properly\r\n if Assigned(CurrentEditor) then\r\n (CurrentEditor as TCustomSynEdit).CommandProcessor(ecDeleteLastChar, #0, nil);\r\n\r\n if Assigned(OnCancel) then\r\n OnCancel(Self);\r\n end;\r\n end;\r\n SYNEDIT_DELETE: if Assigned(CurrentEditor) then\r\n (CurrentEditor as TCustomSynEdit).CommandProcessor(ecDeleteChar, #0, nil);\r\n end;\r\n end;\r\n Invalidate;\r\nend;\r\n\r\nprocedure TSynBaseCompletionProposalForm.KeyPress(var Key: Char);\r\nbegin\r\n{$IFDEF SYN_CLX}\r\n DoKeyPressW(WideChar(Key));\r\n{$ENDIF}\r\nend;\r\n\r\n{.$MESSAGE 'Check what must be adapted in DoKeyPressW and related methods'}\r\nprocedure TSynBaseCompletionProposalForm.DoKeyPressW(Key: WideChar);\r\nbegin\r\n if Key <> #0 then\r\n KeyPressW(Key);\r\nend;\r\n\r\nprocedure TSynBaseCompletionProposalForm.KeyPressW(var Key: WideChar);\r\nbegin\r\n if DisplayType = ctCode then\r\n begin\r\n case Key of\r\n #13, #27:; // These keys are already handled by KeyDown\r\n #32..High(WideChar):\r\n begin\r\n if IsWordBreakChar(Key) and Assigned(OnValidate) then\r\n begin\r\n if Key = #32 then\r\n OnValidate(Self, [], #0)\r\n else\r\n OnValidate(Self, [], Key);\r\n end;\r\n\r\n CurrentString := CurrentString + Key;\r\n\r\n if Assigned(OnKeyPress) then\r\n OnKeyPress(Self, Key);\r\n end;\r\n #8:\r\n if Assigned(OnKeyPress) then\r\n OnKeyPress(Self, Key);\r\n else\r\n with CurrentEditor as TCustomSynEdit do\r\n CommandProcessor(ecChar, Key, nil);\r\n\r\n if Assigned(OnCancel) then\r\n OnCancel(Self);\r\n end;\r\n end;\r\n Invalidate; \r\nend;\r\n\r\nprocedure TSynBaseCompletionProposalForm.MouseDown(Button: TMouseButton;\r\n Shift: TShiftState; X, Y: Integer);\r\nbegin\r\n y := (y - fHeightBuffer) div FEffectiveItemHeight;\r\n Position := FScrollbar.Position + y;\r\n// (CurrentEditor as TCustomSynEdit).UpdateCaret;\r\nend;\r\n\r\n{$IFNDEF SYN_CLX}\r\n{$IFDEF SYN_DELPHI_4_UP}\r\nfunction TSynBaseCompletionProposalForm.CanResize(var NewWidth, NewHeight: Integer): Boolean;\r\nvar\r\n NewLinesInWindow: Integer;\r\n BorderWidth: Integer;\r\nbegin\r\n Result := True;\r\n case FDisplayKind of\r\n ctCode:\r\n begin\r\n BorderWidth := 2 * GetSystemMetrics(SM_CYSIZEFRAME);\r\n\r\n if FEffectiveItemHeight <> 0 then\r\n begin\r\n NewLinesInWindow := (NewHeight-FHeightBuffer) div FEffectiveItemHeight;\r\n if NewLinesInWindow < 1 then\r\n NewLinesInWindow := 1;\r\n end else\r\n NewLinesInWindow := 0;\r\n\r\n FLinesInWindow := NewLinesInWindow;\r\n\r\n NewHeight := FEffectiveItemHeight * FLinesInWindow + FHeightBuffer + BorderWidth;\r\n\r\n if (NewWidth-BorderWidth) < FScrollbar.Width then\r\n NewWidth := FScrollbar.Width + BorderWidth;\r\n end;\r\n ctHint:;\r\n ctParams:;\r\n end;\r\nend;\r\n{$ENDIF}\r\n{$ENDIF}\r\n\r\nprocedure TSynBaseCompletionProposalForm.Resize;\r\nbegin\r\n inherited;\r\n\r\n if FEffectiveItemHeight <> 0 then\r\n FLinesInWindow := (Height - FHeightBuffer) div FEffectiveItemHeight;\r\n\r\n if not(csCreating in ControlState) then\r\n AdjustMetrics;\r\n\r\n AdjustScrollBarPosition;\r\n Invalidate;\r\nend;\r\n\r\n\r\nprocedure TSynBaseCompletionProposalForm.Paint;\r\n\r\n procedure ResetCanvas;\r\n begin\r\n with Bitmap.Canvas do\r\n begin\r\n Pen.Color := FClBackGround;\r\n Brush.Color := FClBackGround;\r\n Font.Assign(FFont);\r\n end;\r\n end;\r\n\r\nconst\r\n TitleMargin = 2;\r\nvar\r\n TmpRect: TRect;\r\n TmpX: Integer;\r\n AlreadyDrawn: boolean;\r\n TmpString: UnicodeString;\r\n i: Integer;\r\nbegin\r\n if FDisplayKind = ctCode then\r\n begin\r\n with Bitmap do\r\n begin\r\n ResetCanvas;\r\n Canvas.Pen.Color := clBtnFace;\r\n Canvas.Rectangle(0, 0, ClientWidth - FScrollbar.Width, ClientHeight);\r\n for i := 0 to Min(FLinesInWindow - 1, FAssignedList.Count - 1) do\r\n begin\r\n if i + FScrollbar.Position = Position then\r\n begin\r\n Canvas.Brush.Color := FClSelect;\r\n Canvas.Pen.Color := FClSelect;\r\n Canvas.Rectangle(0, FEffectiveItemHeight * i, ClientWidth - FScrollbar.Width,\r\n FEffectiveItemHeight * (i + 1));\r\n Canvas.Pen.Color := fClSelectText;\r\n Canvas.Font.Assign(FFont);\r\n Canvas.Font.Color := FClSelectText;\r\n end;\r\n\r\n AlreadyDrawn := False;\r\n\r\n if Assigned(OnPaintItem) then\r\n OnPaintItem(Self, LogicalToPhysicalIndex(FScrollBar.Position + i),\r\n Canvas, Rect(0, FEffectiveItemHeight * i, ClientWidth - FScrollbar.Width,\r\n FEffectiveItemHeight * (i + 1)), AlreadyDrawn);\r\n\r\n if AlreadyDrawn then\r\n ResetCanvas\r\n else\r\n begin\r\n if FFormattedText then\r\n begin\r\n FormattedTextOut(Canvas, Rect(FMargin,\r\n FEffectiveItemHeight * i + ((FEffectiveItemHeight - FFontHeight) div 2),\r\n Bitmap.Width, FEffectiveItemHeight * (i + 1)),\r\n FAssignedList[FScrollbar.Position + i],\r\n (i + FScrollbar.Position = Position), FColumns, FImages);\r\n end\r\n else\r\n begin\r\n TextOut(Canvas, FMargin, FEffectiveItemHeight * i,\r\n FAssignedList[FScrollbar.Position + i]);\r\n end;\r\n\r\n if i + FScrollbar.Position = Position then\r\n ResetCanvas;\r\n end;\r\n end;\r\n end;\r\n Canvas.Draw(0, FHeightBuffer, Bitmap);\r\n\r\n if FTitle <> '' then\r\n begin\r\n with TitleBitmap do\r\n begin\r\n Canvas.Brush.Color := FClTitleBackground;\r\n TmpRect := Rect(0, 0, ClientWidth + 1, FHeightBuffer); //GBN\r\n Canvas.FillRect(TmpRect);\r\n Canvas.Pen.Color := clBtnShadow;\r\n dec(TmpRect.Bottom, 1);\r\n Canvas.PenPos := TmpRect.BottomRight;\r\n Canvas.LineTo(TmpRect.Left - 1,TmpRect.Bottom);\r\n Canvas.Pen.Color := clBtnFace;\r\n\r\n Canvas.Font.Assign(FTitleFont);\r\n\r\n if CenterTitle then\r\n begin\r\n TmpX := (Width - TextWidth(Canvas, Title)) div 2;\r\n if TmpX < TitleMargin then\r\n TmpX := TitleMargin; //We still want to be able to read it, even if it does go over the edge\r\n end else\r\n begin\r\n TmpX := TitleMargin;\r\n end;\r\n TextRect(Canvas, TmpRect, TmpX, TitleMargin - 1, FTitle); // -1 because TmpRect.Top is already 1\r\n end;\r\n Canvas.Draw(0, 0, TitleBitmap);\r\n end;\r\n end else\r\n if (FDisplayKind = ctHint) or (FDisplayKind = ctParams) then\r\n begin\r\n with Bitmap do\r\n begin\r\n ResetCanvas;\r\n tmpRect := Rect(0, 0, ClientWidth, ClientHeight);\r\n Canvas.FillRect(tmpRect);\r\n Frame3D(Canvas, tmpRect, cl3DLight, cl3DDkShadow, 1);\r\n\r\n for i := 0 to FAssignedList.Count - 1 do\r\n begin\r\n AlreadyDrawn := False;\r\n if Assigned(OnPaintItem) then\r\n OnPaintItem(Self, i, Canvas, Rect(0, FEffectiveItemHeight * i + FMargin,\r\n ClientWidth, FEffectiveItemHeight * (i + 1) + FMargin), AlreadyDrawn);\r\n\r\n if AlreadyDrawn then\r\n ResetCanvas\r\n else\r\n begin\r\n if FDisplayKind = ctParams then\r\n TmpString := FormatParamList(FAssignedList[i], CurrentIndex)\r\n else\r\n TmpString := FAssignedList[i];\r\n\r\n FormattedTextOut(Canvas, Rect(FMargin + 1,\r\n FEffectiveItemHeight * i + ((FEffectiveItemHeight-FFontHeight) div 2) + FMargin,\r\n Bitmap.Width - 1, FEffectiveItemHeight * (i + 1) + FMargin), TmpString,\r\n False, nil, FImages);\r\n end;\r\n end;\r\n end;\r\n Canvas.Draw(0, 0, Bitmap);\r\n end;\r\nend;\r\n\r\nprocedure TSynBaseCompletionProposalForm.ScrollbarOnChange(Sender: TObject);\r\nbegin\r\n if Position < FScrollbar.Position then\r\n Position := FScrollbar.Position\r\n else\r\n if Position > FScrollbar.Position + FLinesInWindow - 1 then\r\n Position := FScrollbar.Position + FLinesInWindow - 1\r\n else\r\n Repaint;\r\nend;\r\n\r\nprocedure TSynBaseCompletionProposalForm.ScrollbarOnScroll(Sender: TObject;\r\n ScrollCode: TScrollCode; var ScrollPos: Integer);\r\nbegin \r\n with CurrentEditor as TCustomSynEdit do\r\n begin\r\n SetFocus;\r\n //This tricks the caret into showing itself again.\r\n AlwaysShowCaret := False;\r\n AlwaysShowCaret := True;\r\n// UpdateCaret;\r\n end;\r\nend;\r\n\r\nprocedure TSynBaseCompletionProposalForm.ScrollbarOnEnter(Sender: TObject);\r\nbegin\r\n ActiveControl := nil;\r\nend;\r\n\r\nprocedure TSynBaseCompletionProposalForm.MoveLine(cnt: Integer);\r\nbegin\r\n if (cnt > 0) then begin\r\n if (Position < (FAssignedList.Count - cnt)) then\r\n Position := Position + cnt\r\n else\r\n Position := FAssignedList.Count - 1;\r\n end else begin\r\n if (Position + cnt) > 0 then\r\n Position := Position + cnt\r\n else\r\n Position := 0;\r\n end;\r\nend;\r\n\r\nfunction TSynBaseCompletionProposalForm.LogicalToPhysicalIndex(Index: Integer): Integer;\r\nbegin\r\n if FMatchText and (Index >= 0) and (Index < FAssignedList.Count) then\r\n Result := Integer(FAssignedList.Objects[Index])\r\n else\r\n Result := Index;\r\nend;\r\n\r\nfunction TSynBaseCompletionProposalForm.PhysicalToLogicalIndex(Index: Integer): Integer;\r\nvar i : Integer;\r\nbegin\r\n if FMatchText then\r\n begin\r\n Result := -1;\r\n for i := 0 to FAssignedList.Count - 1 do\r\n if Integer(FAssignedList.Objects[i]) = Index then\r\n begin\r\n Result := i;\r\n break;\r\n end;\r\n end else\r\n Result := Index;\r\nend;\r\n\r\nprocedure TSynBaseCompletionProposalForm.SetCurrentString(const Value: UnicodeString);\r\n\r\n function MatchItem(AIndex: Integer; UseItemList: Boolean): Boolean;\r\n var\r\n CompareString: UnicodeString;\r\n begin\r\n{ if UseInsertList then\r\n CompareString := FInsertList[AIndex]\r\n else\r\n begin\r\n CompareString := FItemList[AIndex];\r\n\r\n if UsePrettyText then\r\n CompareString := StripFormatCommands(CompareString);\r\n end;}\r\n\r\n if UseInsertList then\r\n CompareString := FInsertList[aIndex]\r\n else\r\n begin\r\n if (FMatchText) and (not UseItemList) then\r\n CompareString := FAssignedList[aIndex]\r\n else\r\n CompareString := FItemList[aIndex]; //GBN 29/08/2002 Fix for when match text is not active\r\n\r\n if UsePrettyText then\r\n CompareString := StripFormatCommands(CompareString);\r\n end;\r\n\r\n\r\n CompareString := Copy(CompareString, 1, Length(Value));\r\n\r\n if FCase then\r\n Result := WideCompareStr(CompareString, Value) = 0\r\n else\r\n Result := WideCompareText(CompareString, Value) = 0;\r\n end;\r\n\r\n procedure RecalcList;\r\n var\r\n i: Integer;\r\n begin\r\n FAssignedList.Clear;\r\n for i := 0 to FItemList.Count -1 do\r\n begin\r\n if MatchItem(i, True) then\r\n FAssignedList.AddObject(FItemList[i], TObject(i));\r\n end;\r\n end;\r\n\r\nvar\r\n i: Integer;\r\nbegin\r\n FCurrentString := Value;\r\n if DisplayType <> ctCode then\r\n exit;\r\n if FMatchText then\r\n begin\r\n RecalcList;\r\n AdjustScrollBarPosition;\r\n Position := 0;\r\n \r\n if Visible and Assigned(FOnChangePosition) and (DisplayType = ctCode) then\r\n FOnChangePosition(Owner as TSynBaseCompletionProposal,\r\n LogicalToPhysicalIndex(FPosition));\r\n \r\n Repaint;\r\n end\r\n else\r\n begin\r\n i := 0;\r\n while (i < ItemList.Count) and (not MatchItem(i, True)) do\r\n inc(i);\r\n\r\n if i < ItemList.Count then\r\n Position := i\r\n else\r\n Position := 0;\r\n end;\r\nend;\r\n\r\nprocedure TSynBaseCompletionProposalForm.SetItemList(const Value: TUnicodeStrings);\r\nbegin\r\n FItemList.Assign(Value);\r\n FAssignedList.Assign(Value);\r\n CurrentString := CurrentString;\r\nend;\r\n\r\nprocedure TSynBaseCompletionProposalForm.SetInsertList(const Value: TUnicodeStrings);\r\nbegin\r\n FInsertList.Assign(Value);\r\nend;\r\n\r\nprocedure TSynBaseCompletionProposalForm.DoDoubleClick(Sender: TObject);\r\nbegin\r\n//we need to do the same as the enter key;\r\n if DisplayType = ctCode then\r\n if Assigned(OnValidate) then OnValidate(Self, [], #0); //GBN 15/11/2001\r\nend;\r\n\r\nprocedure TSynBaseCompletionProposalForm.SetPosition(const Value: Integer);\r\nbegin\r\n if ((Value <= 0) and (FPosition = 0)) or (FPosition = Value) then\r\n exit;\r\n\r\n if Value <= FAssignedList.Count - 1 then\r\n begin\r\n FPosition := Value;\r\n if Position < FScrollbar.Position then\r\n FScrollbar.Position := Position else\r\n if FScrollbar.Position < (Position - FLinesInWindow + 1) then\r\n FScrollbar.Position := Position - FLinesInWindow + 1;\r\n\r\n if Visible and Assigned(FOnChangePosition) and (DisplayType = ctCode) then\r\n FOnChangePosition(Owner as TSynBaseCompletionProposal,\r\n LogicalToPhysicalIndex(FPosition));\r\n\r\n Repaint;\r\n end;\r\nend;\r\n\r\nprocedure TSynBaseCompletionProposalForm.SetResizeable(const Value: Boolean);\r\nbegin\r\n FResizeable := Value;\r\n {$IFDEF SYN_CLX}\r\n {$ELSE}\r\n RecreateWnd;\r\n {$ENDIF}\r\nend;\r\n\r\nprocedure TSynBaseCompletionProposalForm.SetItemHeight(const Value: Integer);\r\nbegin\r\n if Value <> FItemHeight then\r\n begin\r\n FItemHeight := Value;\r\n RecalcItemHeight;\r\n end;\r\nend;\r\n\r\nprocedure TSynBaseCompletionProposalForm.SetImages(const Value: TImageList);\r\nbegin\r\n if FImages <> Value then\r\n begin\r\n {$IFDEF SYN_COMPILER_5_UP}\r\n if Assigned(FImages) then\r\n FImages.RemoveFreeNotification(Self);\r\n {$ENDIF SYN_COMPILER_5_UP}\r\n\r\n FImages := Value;\r\n if Assigned(FImages) then\r\n FImages.FreeNotification(Self);\r\n end;\r\nend;\r\n\r\n\r\nprocedure TSynBaseCompletionProposalForm.RecalcItemHeight;\r\nbegin\r\n Canvas.Font.Assign(FFont);\r\n FFontHeight := TextHeight(Canvas, TextHeightString);\r\n if FItemHeight > 0 then\r\n FEffectiveItemHeight := FItemHeight\r\n else\r\n begin\r\n FEffectiveItemHeight := FFontHeight;\r\n end;\r\nend;\r\n\r\nprocedure TSynBaseCompletionProposalForm.StringListChange(Sender: TObject);\r\nbegin\r\n FScrollbar.Position := Position;\r\nend;\r\n\r\nfunction TSynBaseCompletionProposalForm.IsWordBreakChar(AChar: WideChar): Boolean;\r\nbegin\r\n Result := (Owner as TSynBaseCompletionProposal).IsWordBreakChar(AChar);\r\nend;\r\n\r\n{$IFNDEF SYN_CLX}\r\nprocedure TSynBaseCompletionProposalForm.WMMouseWheel(var Msg: TMessage);\r\nvar\r\n nDelta: integer;\r\n nWheelClicks: integer;\r\n{$IFNDEF SYN_COMPILER_4_UP}\r\nconst\r\n LinesToScroll = 3;\r\n WHEEL_DELTA = 120;\r\n WHEEL_PAGESCROLL = MAXDWORD;\r\n {$IFNDEF SYN_COMPILER_3_UP}\r\n SPI_GETWHEELSCROLLLINES = 104;\r\n {$ENDIF}\r\n{$ENDIF}\r\nbegin\r\n if csDesigning in ComponentState then exit;\r\n\r\n{$IFDEF SYN_COMPILER_4_UP}\r\n if GetKeyState(VK_CONTROL) >= 0 then nDelta := Mouse.WheelScrollLines\r\n{$ELSE}\r\n if GetKeyState(VK_CONTROL) >= 0 then\r\n {$IFDEF SYN_CLX}\r\n nDelta := LinesToScroll\r\n {$ELSE}\r\n SystemParametersInfo(SPI_GETWHEELSCROLLLINES, 0, @nDelta, 0)\r\n {$ENDIF}\r\n{$ENDIF}\r\n else nDelta := FLinesInWindow;\r\n\r\n Inc(fMouseWheelAccumulator, SmallInt(Msg.wParamHi));\r\n nWheelClicks := fMouseWheelAccumulator div WHEEL_DELTA;\r\n fMouseWheelAccumulator := fMouseWheelAccumulator mod WHEEL_DELTA;\r\n if (nDelta = integer(WHEEL_PAGESCROLL)) or (nDelta > FLinesInWindow) then\r\n nDelta := FLinesInWindow;\r\n\r\n Position := Position - (nDelta * nWheelClicks);\r\n// (CurrentEditor as TCustomSynEdit).UpdateCaret;\r\nend;\r\n{$ENDIF}\r\n\r\nfunction GetMDIParent (const Form: TSynForm): TSynForm;\r\n{ Returns the parent of the specified MDI child form. But, if Form isn't a\r\n MDI child, it simply returns Form. }\r\nvar\r\n I, J: Integer;\r\nbegin\r\n Result := Form;\r\n if Form = nil then\r\n exit;\r\n if (Form is TSynForm) and\r\n ((Form as TForm).FormStyle = fsMDIChild) then\r\n for I := 0 to Screen.FormCount-1 do\r\n with Screen.Forms[I] do\r\n begin\r\n if FormStyle <> fsMDIForm then Continue;\r\n for J := 0 to MDIChildCount-1 do\r\n if MDIChildren[J] = Form then\r\n begin\r\n Result := Screen.Forms[I];\r\n exit;\r\n end;\r\n end;\r\nend;\r\n\r\n{$IFNDEF SYN_CLX}\r\nprocedure TSynBaseCompletionProposalForm.WMActivate(var Message: TWMActivate);\r\nvar\r\n ParentForm: TSynForm;\r\nbegin\r\n if csDesigning in ComponentState then begin\r\n inherited;\r\n Exit;\r\n end;\r\n {Owner of the component that created me}\r\n if Owner.Owner is TSynForm then\r\n ParentForm := GetMDIParent(Owner.Owner as TSynForm)\r\n else\r\n ParentForm := nil;\r\n\r\n if Assigned(ParentForm) and ParentForm.HandleAllocated then\r\n SendMessage(ParentForm.Handle, WM_NCACTIVATE, Ord(Message.Active <> WA_INACTIVE), 0);\r\nend;\r\n\r\nprocedure TSynBaseCompletionProposalForm.WMChar(var Msg: TWMChar);\r\nbegin\r\n if Win32PlatformIsUnicode then\r\n DoKeyPressW(WideChar(Msg.CharCode))\r\n else\r\n DoKeyPressW(KeyUnicode(AnsiChar(Msg.CharCode)));\r\nend;\r\n{$ENDIF}\r\n\r\nprocedure TSynBaseCompletionProposalForm.DoFormHide(Sender: TObject);\r\nbegin\r\n if CurrentEditor <> nil then\r\n begin\r\n (CurrentEditor as TCustomSynEdit).AlwaysShowCaret := OldShowCaret;\r\n// (CurrentEditor as TCustomSynEdit).UpdateCaret;\r\n if DisplayType = ctCode then\r\n begin\r\n (Owner as TSynBaseCompletionProposal).FWidth := Width;\r\n (Owner as TSynBaseCompletionProposal).FNbLinesInWindow := FLinesInWindow;\r\n end;\r\n end;\r\n //GBN 28/08/2002\r\n if Assigned((Owner as TSynBaseCompletionProposal).OnClose) then\r\n TSynBaseCompletionProposal(Owner).OnClose(Self);\r\nend;\r\n\r\nprocedure TSynBaseCompletionProposalForm.DoFormShow(Sender: TObject);\r\nbegin\r\n if Assigned(CurrentEditor) then\r\n begin\r\n with CurrentEditor as TCustomSynEdit do\r\n begin\r\n OldShowCaret := AlwaysShowCaret;\r\n AlwaysShowCaret := Focused;\r\n// UpdateCaret;\r\n end;\r\n end;\r\n //GBN 28/08/2002\r\n if Assigned((Owner as TSynBaseCompletionProposal).OnShow) then\r\n (Owner as TSynBaseCompletionProposal).OnShow(Self);\r\nend;\r\n\r\n{$IFDEF SYN_CLX}\r\n{$ELSE}\r\nprocedure TSynBaseCompletionProposalForm.WMEraseBackgrnd(\r\n var Message: TMessage);\r\nbegin\r\n Message.Result:=1;\r\nend;\r\n\r\n//GBN 24/02/2002\r\nprocedure TSynBaseCompletionProposalForm.WMGetDlgCode(var Message: TWMGetDlgCode);\r\nbegin\r\n inherited;\r\n Message.Result := Message.Result or DLGC_WANTTAB;\r\nend;\r\n{$ENDIF}\r\n\r\nprocedure TSynBaseCompletionProposalForm.AdjustMetrics;\r\nbegin\r\n if DisplayType = ctCode then\r\n begin\r\n if FTitle <> '' then\r\n FHeightBuffer := FTitleFontHeight + 4 {Margin}\r\n else\r\n FHeightBuffer := 0;\r\n\r\n if (ClientWidth >= FScrollbar.Width) and (ClientHeight >= FHeightBuffer) then\r\n begin\r\n Bitmap.Width := ClientWidth - FScrollbar.Width;\r\n Bitmap.Height := ClientHeight - FHeightBuffer;\r\n end;\r\n\r\n if (ClientWidth > 0) and (FHeightBuffer > 0) then\r\n begin\r\n TitleBitmap.Width := ClientWidth;\r\n TitleBitmap.Height := FHeightBuffer;\r\n end;\r\n end else\r\n begin\r\n if (ClientWidth > 0) and (ClientHeight > 0) then\r\n begin\r\n Bitmap.Width := ClientWidth;\r\n Bitmap.Height := ClientHeight;\r\n end;\r\n end;\r\nend;\r\n\r\n\r\nprocedure TSynBaseCompletionProposalForm.AdjustScrollBarPosition;\r\nbegin\r\n if FDisplayKind = ctCode then\r\n begin\r\n if Assigned(FScrollbar) then\r\n begin\r\n FScrollbar.Top := FHeightBuffer;\r\n FScrollbar.Height := ClientHeight - FHeightBuffer;\r\n FScrollbar.Left := ClientWidth - FScrollbar.Width;\r\n\r\n if FAssignedList.Count - FLinesInWindow < 0 then\r\n begin\r\n {$IFNDEF SYN_CLX}\r\n {$IFDEF SYN_DELPHI_4_UP}\r\n FScrollbar.PageSize := 0;\r\n {$ENDIF}\r\n {$ENDIF}\r\n FScrollbar.Max := 0;\r\n FScrollbar.Enabled := False;\r\n end else\r\n begin\r\n {$IFNDEF SYN_CLX}\r\n {$IFDEF SYN_DELPHI_4_UP}\r\n FScrollbar.PageSize := 0;\r\n {$ENDIF}\r\n {$ENDIF}\r\n FScrollbar.Max := FAssignedList.Count - FLinesInWindow;\r\n if FScrollbar.Max <> 0 then\r\n begin\r\n FScrollbar.LargeChange := FLinesInWindow;\r\n {$IFNDEF SYN_CLX}\r\n {$IFDEF SYN_DELPHI_4_UP}\r\n FScrollbar.PageSize := 1;\r\n {$ENDIF}\r\n {$ENDIF}\r\n FScrollbar.Enabled := True;\r\n end else\r\n FScrollbar.Enabled := False;\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TSynBaseCompletionProposalForm.SetTitle(const Value: UnicodeString);\r\nbegin\r\n FTitle := Value;\r\n AdjustMetrics;\r\nend;\r\n\r\nprocedure TSynBaseCompletionProposalForm.SetFont(const Value: TFont);\r\nbegin\r\n FFont.Assign(Value);\r\n RecalcItemHeight;\r\n AdjustMetrics;\r\nend;\r\n\r\nprocedure TSynBaseCompletionProposalForm.SetTitleFont(const Value: TFont);\r\nbegin\r\n FTitleFont.Assign(Value);\r\n FTitleFontHeight := TextHeight(Canvas, TextHeightString);\r\n AdjustMetrics;\r\nend;\r\n\r\nprocedure TSynBaseCompletionProposalForm.SetColumns(Value: TProposalColumns);\r\nbegin\r\n FColumns.Assign(Value);\r\nend;\r\n\r\n\r\nprocedure TSynBaseCompletionProposalForm.TitleFontChange(Sender: TObject);\r\nbegin\r\n Canvas.Font.Assign(FTitleFont);\r\n FTitleFontHeight := TextHeight(Canvas, TextHeightString);\r\n AdjustMetrics;\r\nend;\r\n\r\nprocedure TSynBaseCompletionProposalForm.FontChange(Sender: TObject);\r\nbegin\r\n RecalcItemHeight;\r\n AdjustMetrics;\r\nend;\r\n\r\nprocedure TSynBaseCompletionProposalForm.Notification(AComponent: TComponent;\r\n Operation: TOperation);\r\nbegin\r\n if (Operation = opRemove) then\r\n begin\r\n if AComponent = FImages then\r\n Images := nil;\r\n end;\r\n\r\n inherited Notification(AComponent, Operation);\r\nend;\r\n\r\n\r\n{ TSynBaseCompletionProposal }\r\n\r\nconstructor TSynBaseCompletionProposal.Create(Aowner: TComponent);\r\nbegin\r\n FWidth := 260;\r\n FNbLinesInWindow := 8;\r\n inherited Create(AOwner);\r\n FForm := TSynBaseCompletionProposalForm.Create(Self);\r\n EndOfTokenChr := DefaultEndOfTokenChr;\r\n FDotOffset := 0;\r\n DefaultType := ctCode;\r\nend;\r\n\r\nprocedure TSynBaseCompletionProposal.Execute(s: UnicodeString; x, y: integer);\r\nbegin\r\n ExecuteEx(s, x, y, DefaultType);\r\nend;\r\n\r\nprocedure TSynBaseCompletionProposal.ExecuteEx(s: UnicodeString; x, y: integer; Kind : SynCompletionType);\r\n\r\n function GetWorkAreaWidth: Integer;\r\n begin\r\n {$IFDEF SYN_CLX}\r\n Result := Screen.Width\r\n {$ELSE}\r\n {$IFDEF SYN_COMPILER_5_UP}\r\n Result := Screen.DesktopWidth;\r\n {$ELSE}\r\n Result := Screen.Width;\r\n {$ENDIF}\r\n {$ENDIF}\r\n end;\r\n\r\n function GetWorkAreaHeight: Integer;\r\n begin\r\n {$IFDEF SYN_CLX}\r\n Result := Screen.Height\r\n {$ELSE}\r\n {$IFDEF SYN_COMPILER_5_UP}\r\n Result := Screen.DesktopHeight;\r\n {$ELSE}\r\n Result := Screen.Height;\r\n {$ENDIF}\r\n {$ENDIF}\r\n end;\r\n\r\n function GetParamWidth(const S: UnicodeString): Integer;\r\n var\r\n i: Integer;\r\n List: TUnicodeStringList;\r\n NewWidth: Integer;\r\n begin\r\n List := TUnicodeStringList.Create;\r\n try\r\n List.CommaText := S;\r\n\r\n Result := 0;\r\n for i := -1 to List.Count -1 do\r\n begin\r\n NewWidth := FormattedTextWidth(Form.Canvas,\r\n FormatParamList(S, i), Columns, FForm.Images);\r\n\r\n if NewWidth > Result then\r\n Result := NewWidth;\r\n end;\r\n finally\r\n List.Free;\r\n end;\r\n end;\r\n\r\n procedure RecalcFormPlacement;\r\n var\r\n i: Integer;\r\n tmpWidth: Integer;\r\n tmpHeight: Integer;\r\n tmpX: Integer;\r\n tmpY: Integer;\r\n tmpStr: UnicodeString;\r\n BorderWidth: Integer;\r\n NewWidth: Integer;\r\n begin\r\n\r\n tmpX := x;\r\n tmpY := y;\r\n tmpWidth := 0;\r\n tmpHeight := 0;\r\n case Kind of\r\n ctCode:\r\n begin\r\n BorderWidth :=\r\n {$IFDEF SYN_CLX}\r\n 6; // TODO: I don't know how to retrieve the border width in CLX\r\n {$ELSE}\r\n 2 * GetSystemMetrics(SM_CYSIZEFRAME);\r\n {$ENDIF}\r\n\r\n tmpWidth := FWidth;\r\n tmpHeight := Form.FHeightBuffer + Form.FEffectiveItemHeight * FNbLinesInWindow + BorderWidth;\r\n end;\r\n ctHint:\r\n begin\r\n BorderWidth := 2;\r\n tmpHeight := Form.FEffectiveItemHeight * ItemList.Count + BorderWidth\r\n + 2 * Form.Margin;\r\n\r\n Form.Canvas.Font.Assign(Font);\r\n for i := 0 to ItemList.Count -1 do\r\n begin\r\n tmpStr := ItemList[i];\r\n NewWidth := FormattedTextWidth(Form.Canvas, tmpStr, nil, FForm.Images);\r\n if NewWidth > tmpWidth then\r\n tmpWidth := NewWidth;\r\n end;\r\n\r\n inc(tmpWidth, 2 * FForm.Margin +BorderWidth);\r\n end;\r\n ctParams:\r\n begin\r\n BorderWidth := 2;\r\n tmpHeight := Form.FEffectiveItemHeight * ItemList.Count + BorderWidth\r\n + 2 * Form.Margin;\r\n\r\n Form.Canvas.Font.Assign(Font);\r\n for i := 0 to ItemList.Count -1 do\r\n begin\r\n NewWidth := GetParamWidth(StripFormatCommands(ItemList[i]));\r\n\r\n if Assigned(Form.OnMeasureItem) then\r\n Form.OnMeasureItem(Self, i, Form.Canvas, NewWidth);\r\n\r\n if NewWidth > tmpWidth then\r\n tmpWidth := NewWidth;\r\n end;\r\n\r\n inc(tmpWidth, 2 * FForm.Margin +BorderWidth);\r\n end;\r\n end;\r\n\r\n\r\n if tmpX + tmpWidth > GetWorkAreaWidth then\r\n begin\r\n tmpX := GetWorkAreaWidth - tmpWidth - 5; //small space buffer\r\n if tmpX < 0 then\r\n tmpX := 0;\r\n end;\r\n\r\n if tmpY + tmpHeight > GetWorkAreaHeight then\r\n begin\r\n tmpY := tmpY - tmpHeight - (Form.CurrentEditor as TCustomSynEdit).LineHeight -2;\r\n if tmpY < 0 then\r\n tmpY := 0;\r\n end;\r\n\r\n Form.Width := tmpWidth;\r\n Form.Height := tmpHeight;\r\n Form.Top := tmpY;\r\n Form.Left := tmpX;\r\n end;\r\n\r\nvar\r\n TmpOffset: Integer;\r\nbegin\r\n DisplayType := Kind;\r\n\r\n FCanExecute := True;\r\n if Assigned(OnExecute) then\r\n OnExecute(Kind, Self, s, x, y, FCanExecute);\r\n\r\n if (not FCanExecute) or (ItemList.Count = 0) then\r\n begin\r\n if Form.Visible and (Kind = ctParams) then\r\n Form.Visible := False;\r\n exit;\r\n end;\r\n\r\n Form.FormStyle := fsStayOnTop;\r\n\r\n if Assigned(Form.CurrentEditor) then\r\n begin\r\n TmpOffset := TextWidth((Form.CurrentEditor as TCustomSynEdit).Canvas, Copy(s, 1, DotOffset));\r\n if DotOffset > 1 then\r\n TmpOffset := TmpOffset + (3 * (DotOffset -1))\r\n end else\r\n TmpOffset := 0;\r\n x := x - tmpOffset;\r\n\r\n ResetAssignedList;\r\n\r\n case Kind of\r\n ctCode:\r\n if Form.AssignedList.Count > 0 then\r\n begin\r\n //This may seem redundant, but it fixes scrolling bugs for the first time\r\n //That is the only time these occur\r\n Position := 0;\r\n Form.AdjustScrollBarPosition;\r\n Form.FScrollbar.Position := Form.Position;\r\n Form.FScrollbar.Visible := True;\r\n\r\n RecalcFormPlacement;\r\n Form.Show;\r\n\r\n CurrentString := s; // bug id 1496148\r\n end;\r\n ctParams, ctHint:\r\n begin\r\n Form.FScrollbar.Visible := False;\r\n\r\n RecalcFormPlacement;\r\n\r\n {$IFNDEF SYN_CLX}\r\n// ShowWindow(Form.Handle, SW_SHOWNOACTIVATE);\r\n ShowWindow(Form.Handle, SW_SHOWNA);\r\n Form.Visible := True;\r\n {$ELSE}\r\n Form.Show;\r\n (Form.CurrentEditor as TCustomSynEdit).SetFocus;\r\n {$ENDIF}\r\n Form.Repaint;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TSynBaseCompletionProposal.GetCurrentString: UnicodeString;\r\nbegin\r\n Result := Form.CurrentString;\r\nend;\r\n\r\nfunction TSynBaseCompletionProposal.GetItemList: TUnicodeStrings;\r\nbegin\r\n Result := Form.ItemList;\r\nend;\r\n\r\nfunction TSynBaseCompletionProposal.GetInsertList: TUnicodeStrings;\r\nbegin\r\n Result := Form.InsertList;\r\nend;\r\n\r\nfunction TSynBaseCompletionProposal.GetOnCancel: TNotifyEvent;\r\nbegin\r\n Result := Form.OnCancel;\r\nend;\r\n\r\nfunction TSynBaseCompletionProposal.GetOnKeyPress: TKeyPressWEvent;\r\nbegin\r\n Result := Form.OnKeyPress;\r\nend;\r\n\r\nfunction TSynBaseCompletionProposal.GetOnPaintItem: TSynBaseCompletionProposalPaintItem;\r\nbegin\r\n Result := Form.OnPaintItem;\r\nend;\r\n\r\nfunction TSynBaseCompletionProposal.GetOnMeasureItem: TSynBaseCompletionProposalMeasureItem;\r\nbegin\r\n Result := Form.OnMeasureItem;\r\nend;\r\n\r\nfunction TSynBaseCompletionProposal.GetOnValidate: TValidateEvent;\r\nbegin\r\n Result := Form.OnValidate;\r\nend;\r\n\r\nfunction TSynBaseCompletionProposal.GetPosition: Integer;\r\nbegin\r\n Result := Form.Position;\r\nend;\r\n\r\nprocedure TSynBaseCompletionProposal.SetCurrentString(const Value: UnicodeString);\r\nbegin\r\n Form.CurrentString := Value;\r\nend;\r\n\r\nprocedure TSynBaseCompletionProposal.SetItemList(const Value: TUnicodeStrings);\r\nbegin\r\n Form.ItemList := Value;\r\nend;\r\n\r\nprocedure TSynBaseCompletionProposal.SetInsertList(const Value: TUnicodeStrings);\r\nbegin\r\n Form.InsertList := Value;\r\nend;\r\n\r\nprocedure TSynBaseCompletionProposal.SetNbLinesInWindow(const Value: Integer);\r\nbegin\r\n FNbLinesInWindow := Value;\r\nend;\r\n\r\nprocedure TSynBaseCompletionProposal.SetOnCancel(const Value: TNotifyEvent);\r\nbegin\r\n Form.OnCancel := Value;\r\nend;\r\n\r\nprocedure TSynBaseCompletionProposal.SetOnKeyPress(const Value: TKeyPressWEvent);\r\nbegin\r\n Form.OnKeyPress := Value;\r\nend;\r\n\r\nprocedure TSynBaseCompletionProposal.SetOnPaintItem(const Value:\r\n TSynBaseCompletionProposalPaintItem);\r\nbegin\r\n Form.OnPaintItem := Value;\r\nend;\r\n\r\nprocedure TSynBaseCompletionProposal.SetOnMeasureItem(const Value:\r\n TSynBaseCompletionProposalMeasureItem);\r\nbegin\r\n Form.OnMeasureItem := Value;\r\nend;\r\n\r\n\r\nprocedure TSynBaseCompletionProposal.SetPosition(const Value: Integer);\r\nbegin\r\n form.Position := Value;\r\nend;\r\n\r\nprocedure TSynBaseCompletionProposal.SetOnValidate(const Value: TValidateEvent);\r\nbegin\r\n form.OnValidate := Value;\r\nend;\r\n\r\nfunction TSynBaseCompletionProposal.GetClSelect: TColor;\r\nbegin\r\n Result := Form.ClSelect;\r\nend;\r\n\r\nprocedure TSynBaseCompletionProposal.SetClSelect(const Value: TColor);\r\nbegin\r\n Form.ClSelect := Value;\r\nend;\r\n\r\nprocedure TSynBaseCompletionProposal.SetWidth(Value: Integer);\r\nbegin\r\n FWidth := Value;\r\nend;\r\n\r\nprocedure TSynBaseCompletionProposal.Activate;\r\nbegin\r\n if Assigned(Form) then\r\n Form.Activate;\r\nend;\r\n\r\nprocedure TSynBaseCompletionProposal.Deactivate;\r\nbegin\r\n if Assigned(Form) then\r\n Form.Deactivate;\r\nend;\r\n\r\nprocedure TSynBaseCompletionProposal.DefineProperties(Filer: TFiler);\r\nbegin\r\n inherited;\r\n{$IFNDEF UNICODE}\r\n UnicodeDefineProperties(Filer, Self);\r\n{$ENDIF}\r\nend;\r\n\r\nfunction TSynBaseCompletionProposal.GetClBack: TColor;\r\nbegin\r\n Result := Form.ClBackground;\r\nend;\r\n\r\nprocedure TSynBaseCompletionProposal.SetClBack(const Value: TColor);\r\nbegin\r\n Form.ClBackground := Value\r\nend;\r\n\r\nfunction TSynBaseCompletionProposal.GetClSelectedText: TColor;\r\nbegin\r\n Result := Form.ClSelectedText;\r\nend;\r\n\r\nprocedure TSynBaseCompletionProposal.SetClSelectedText(const Value: TColor);\r\nbegin\r\n Form.ClSelectedText := Value;\r\nend;\r\n\r\nprocedure TSynBaseCompletionProposal.AddItem(ADisplayText, AInsertText: UnicodeString);\r\nbegin\r\n GetInsertList.Add(AInsertText);\r\n GetItemList.Add(ADisplayText);\r\nend;\r\n\r\nprocedure TSynBaseCompletionProposal.AddItemAt(Where: Integer; ADisplayText, AInsertText: UnicodeString);\r\nbegin\r\n try\r\n GetInsertList.Insert(Where, AInsertText);\r\n GetItemList.Insert(Where, ADisplayText); \r\n except\r\n raise Exception.Create('Cannot insert item at position ' + IntToStr(Where) + '.');\r\n end;\r\nend;\r\n\r\nprocedure TSynBaseCompletionProposal.ClearList;\r\nbegin\r\n GetInsertList.Clear;\r\n GetItemList.Clear;\r\nend;\r\n\r\nfunction TSynBaseCompletionProposal.DisplayItem(AIndex : Integer): UnicodeString;\r\nbegin\r\n Result := GetItemList[AIndex];\r\nend;\r\n\r\nfunction TSynBaseCompletionProposal.InsertItem(AIndex : Integer): UnicodeString;\r\nbegin\r\n Result := GetInsertList[AIndex];\r\nend;\r\n\r\nfunction TSynBaseCompletionProposal.IsWordBreakChar(AChar: WideChar): Boolean;\r\nbegin\r\n Result := False;\r\n if (scoConsiderWordBreakChars in Options) and Assigned(Form) and\r\n Assigned(Form.CurrentEditor)\r\n then\r\n Result := Form.CurrentEditor.IsWordBreakChar(AChar);\r\n Result := Result or (Pos(AChar, EndOfTokenChr) > 0);\r\nend;\r\n\r\nfunction TSynBaseCompletionProposal.GetDisplayKind: SynCompletionType;\r\nbegin\r\n Result := Form.DisplayType;\r\nend;\r\n\r\nprocedure TSynBaseCompletionProposal.SetDisplayKind(const Value: SynCompletionType);\r\nbegin\r\n Form.DisplayType := Value;\r\nend;\r\n\r\nfunction TSynBaseCompletionProposal.GetParameterToken: TCompletionParameter;\r\nbegin\r\n Result := Form.OnParameterToken;\r\nend;\r\n\r\nprocedure TSynBaseCompletionProposal.SetParameterToken(\r\n const Value: TCompletionParameter);\r\nbegin\r\n Form.OnParameterToken := Value;\r\nend;\r\n\r\nprocedure TSynBaseCompletionProposal.SetColumns(const Value: TProposalColumns);\r\nbegin\r\n FForm.Columns := Value;\r\nend;\r\n\r\nfunction TSynBaseCompletionProposal.GetColumns: TProposalColumns;\r\nbegin\r\n Result := FForm.Columns;\r\nend;\r\n\r\nfunction TSynBaseCompletionProposal.GetResizeable: Boolean;\r\nbegin\r\n Result := FForm.Resizeable;\r\nend;\r\n\r\nprocedure TSynBaseCompletionProposal.SetResizeable(const Value: Boolean);\r\nbegin\r\n if FForm.Resizeable <> Value then\r\n FForm.Resizeable := Value;\r\nend;\r\n\r\nfunction TSynBaseCompletionProposal.GetItemHeight: Integer;\r\nbegin\r\n Result := FForm.ItemHeight;\r\nend;\r\n\r\nprocedure TSynBaseCompletionProposal.SetItemHeight(const Value: Integer);\r\nbegin\r\n if FForm.ItemHeight <> Value then\r\n FForm.ItemHeight := Value;\r\nend;\r\n\r\nprocedure TSynBaseCompletionProposal.SetImages(const Value: TImageList);\r\nbegin\r\n FForm.Images := Value;\r\nend;\r\n\r\nfunction TSynBaseCompletionProposal.GetImages: TImageList;\r\nbegin\r\n Result := FForm.Images;\r\nend;\r\n\r\nfunction TSynBaseCompletionProposal.GetMargin: Integer;\r\nbegin\r\n Result := FForm.Margin;\r\nend;\r\n\r\nprocedure TSynBaseCompletionProposal.SetMargin(const Value: Integer);\r\nbegin\r\n if Value <> FForm.Margin then\r\n FForm.Margin := Value;\r\nend;\r\n\r\nfunction TSynBaseCompletionProposal.GetDefaultKind: SynCompletionType;\r\nbegin\r\n Result := Form.DefaultType;\r\nend;\r\n\r\nprocedure TSynBaseCompletionProposal.SetDefaultKind(const Value: SynCompletionType);\r\nbegin\r\n Form.DefaultType := Value;\r\n Form.DisplayType := Value;\r\n {$IFDEF SYN_CLX}\r\n {$ELSE}\r\n Form.RecreateWnd;\r\n {$ENDIF}\r\nend;\r\n\r\nprocedure TSynBaseCompletionProposal.SetEndOfTokenChar(\r\n const Value: UnicodeString);\r\nbegin\r\n if Form.FEndOfTokenChr <> Value then\r\n begin\r\n Form.FEndOfTokenChr := Value;\r\n end;\r\nend;\r\n\r\nfunction TSynBaseCompletionProposal.GetClTitleBackground: TColor;\r\nbegin\r\n Result := Form.ClTitleBackground;\r\nend;\r\n\r\nprocedure TSynBaseCompletionProposal.SetClTitleBackground(\r\n const Value: TColor);\r\nbegin\r\n Form.ClTitleBackground := Value;\r\nend;\r\n\r\nfunction TSynBaseCompletionProposal.GetTitle: UnicodeString;\r\nbegin\r\n Result := Form.Title;\r\nend;\r\n\r\nprocedure TSynBaseCompletionProposal.SetTitle(const Value: UnicodeString);\r\nbegin\r\n Form.Title := Value;\r\nend;\r\n\r\nfunction TSynBaseCompletionProposal.GetFont: TFont;\r\nbegin\r\n Result := Form.Font;\r\nend;\r\n\r\nfunction TSynBaseCompletionProposal.GetTitleFont: TFont;\r\nbegin\r\n Result := Form.TitleFont;\r\nend;\r\n\r\nprocedure TSynBaseCompletionProposal.SetFont(const Value: TFont);\r\nbegin\r\n Form.Font := Value;\r\nend;\r\n\r\nprocedure TSynBaseCompletionProposal.SetTitleFont(const Value: TFont);\r\nbegin\r\n Form.TitleFont := Value;\r\nend;\r\n\r\nfunction TSynBaseCompletionProposal.GetEndOfTokenChar: UnicodeString;\r\nbegin\r\n Result := Form.EndOfTokenChr;\r\nend;\r\n\r\nfunction TSynBaseCompletionProposal.GetOptions: TSynCompletionOptions;\r\nbegin\r\n Result := fOptions;\r\nend;\r\n\r\nprocedure TSynBaseCompletionProposal.SetOptions(\r\n const Value: TSynCompletionOptions);\r\nbegin\r\n if fOptions <> Value then\r\n begin\r\n fOptions := Value;\r\n Form.CenterTitle := scoTitleIsCentered in Value;\r\n Form.CaseSensitive := scoCaseSensitive in Value;\r\n Form.UsePrettyText := scoUsePrettyText in Value;\r\n Form.UseInsertList := scoUseInsertList in Value;\r\n Form.MatchText := scoLimitToMatchedText in Value;\r\n Form.CompleteWithTab := scoCompleteWithTab in Value;\r\n Form.CompleteWithEnter := scoCompleteWithEnter in Value;\r\n end;\r\nend;\r\n\r\nfunction TSynBaseCompletionProposal.GetTriggerChars: UnicodeString;\r\nbegin\r\n Result := Form.TriggerChars;\r\nend;\r\n\r\nprocedure TSynBaseCompletionProposal.SetTriggerChars(const Value: UnicodeString);\r\nbegin\r\n Form.TriggerChars := Value;\r\nend;\r\n\r\nprocedure TSynBaseCompletionProposal.EditorCancelMode(Sender: TObject);\r\nbegin\r\n //Do nothing here, used in TSynCompletionProposal\r\nend;\r\n\r\nprocedure TSynBaseCompletionProposal.HookedEditorCommand(Sender: TObject;\r\n AfterProcessing: Boolean; var Handled: Boolean; var Command: TSynEditorCommand;\r\n var AChar: WideChar; Data, HandlerData: Pointer);\r\nbegin\r\n // Do nothing here, used in TSynCompletionProposal\r\nend;\r\n\r\nfunction TSynBaseCompletionProposal.GetOnChange: TCompletionChange;\r\nbegin\r\n Result := Form.FOnChangePosition;\r\nend;\r\n\r\nprocedure TSynBaseCompletionProposal.SetOnChange(\r\n const Value: TCompletionChange);\r\nbegin\r\n Form.FOnChangePosition := Value;\r\nend;\r\n\r\nprocedure TSynBaseCompletionProposal.ResetAssignedList;\r\nbegin\r\n Form.AssignedList.Assign(ItemList);\r\nend;\r\n\r\n{ ---------------- TSynCompletionProposal -------------- }\r\n\r\nprocedure TSynCompletionProposal.HandleOnCancel(Sender: TObject);\r\nvar\r\n F: TSynBaseCompletionProposalForm;\r\nbegin\r\n F := Sender as TSynBaseCompletionProposalForm;\r\n FNoNextKey := False;\r\n if F.CurrentEditor <> nil then\r\n begin\r\n if Assigned(FTimer) then\r\n FTimer.Enabled := False;\r\n\r\n F.Hide;\r\n\r\n if ((F.CurrentEditor as TCustomSynEdit).Owner is TWinControl) and\r\n (((F.CurrentEditor as TCustomSynEdit).Owner as TWinControl).Visible) then\r\n begin\r\n ((F.CurrentEditor as TCustomSynEdit).Owner as TWinControl).SetFocus;\r\n end;\r\n\r\n (F.CurrentEditor as TCustomSynEdit).SetFocus;\r\n\r\n{$IFDEF SYN_CLX}\r\n GetParentForm( F.CurrentEditor ).Show;\r\n{$ENDIF}\r\n\r\n if Assigned(OnCancelled) then\r\n OnCancelled(Self);\r\n end;\r\nend;\r\n\r\nprocedure TSynCompletionProposal.HandleOnValidate(Sender: TObject;\r\n Shift: TShiftState; EndToken: WideChar);\r\nvar\r\n F: TSynBaseCompletionProposalForm;\r\n Value: UnicodeString;\r\n Index: Integer;\r\nbegin\r\n F := Sender as TSynBaseCompletionProposalForm;\r\n if Assigned(F.CurrentEditor) then\r\n with F.CurrentEditor as TCustomSynEdit do\r\n begin\r\n //Treat entire completion as a single undo operation\r\n BeginUpdate;\r\n BeginUndoBlock;\r\n try\r\n if FAdjustCompletionStart then\r\n FCompletionStart := BufferCoord(FCompletionStart, CaretY).Char;\r\n BlockBegin := BufferCoord(FCompletionStart, CaretY);\r\n if EndToken = #0 then\r\n BlockEnd := BufferCoord(WordEnd.Char, CaretY)\r\n else\r\n BlockEnd := BufferCoord(CaretX, CaretY);\r\n\r\n if scoUseInsertList in FOptions then\r\n begin\r\n if scoLimitToMatchedText in FOptions then\r\n begin\r\n if (Form.FAssignedList.Count > Position) then\r\n //GBN 15/01/2002 - Added check to make sure item is only used when no EndChar\r\n if (InsertList.Count > Integer(Form.FAssignedList.Objects[position])) and\r\n ((scoEndCharCompletion in fOptions) or (EndToken = #0)) then\r\n Value := InsertList[Integer(Form.FAssignedList.Objects[position])]\r\n else\r\n Value := SelText\r\n else\r\n Value := SelText;\r\n end else\r\n begin\r\n //GBN 15/01/2002 - Added check to make sure item is only used when no EndChar\r\n if (InsertList.Count > Position) and\r\n ((scoEndCharCompletion in FOptions) or (EndToken = #0)) then\r\n Value := InsertList[position]\r\n else\r\n Value := SelText;\r\n end;\r\n end else\r\n begin\r\n //GBN 15/01/2002 - Added check to make sure item is only used when no EndChar\r\n if (Form.FAssignedList.Count > Position) and\r\n ((scoEndCharCompletion in FOptions) or (EndToken = #0)) then\r\n Value := Form.FAssignedList[Position]\r\n else\r\n Value := SelText;\r\n end;\r\n Index := Position; //GBN 15/11/2001, need to assign position to temp var since it changes later\r\n\r\n //GBN 15/01/2002 - Cleaned this code up a bit\r\n if Assigned(FOnCodeCompletion) then\r\n FOnCodeCompletion(Self, Value, Shift,\r\n F.LogicalToPhysicalIndex(Index), EndToken); //GBN 15/11/2001\r\n\r\n if SelText <> Value then\r\n SelText := Value;\r\n\r\n with (F.CurrentEditor as TCustomSynEdit) do\r\n begin\r\n //GBN 25/02/2002\r\n //This replaces the previous way of cancelling the completion by\r\n //sending a WM_MOUSEDOWN message. The problem with the mouse down is\r\n //that the editor would bounce back to the left margin, very irritating\r\n InternalCancelCompletion;\r\n SetFocus;\r\n{$IFDEF SYN_CLX}\r\n GetParentForm( F.CurrentEditor ).Show;\r\n{$ENDIF}\r\n EnsureCursorPosVisible; //GBN 25/02/2002\r\n CaretXY := BlockEnd;\r\n BlockBegin := CaretXY;\r\n end;\r\n //GBN 15/11/2001\r\n if Assigned(FOnAfterCodeCompletion) then\r\n FOnAfterCodeCompletion(Self, Value, Shift,\r\n F.LogicalToPhysicalIndex(Index), EndToken);\r\n\r\n finally\r\n EndUndoBlock;\r\n EndUpdate;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TSynCompletionProposal.HandleOnKeyPress(Sender: TObject; var Key: WideChar);\r\nvar\r\n F: TSynBaseCompletionProposalForm;\r\nbegin\r\n F := Sender as TSynBaseCompletionProposalForm;\r\n if F.CurrentEditor <> nil then\r\n begin\r\n with F.CurrentEditor as TCustomSynEdit do\r\n CommandProcessor(ecChar, Key, nil);\r\n //Daisy chain completions\r\n Application.ProcessMessages;\r\n if (System.Pos(Key, TriggerChars) > 0) and not F.Visible then\r\n begin\r\n if (Sender is TCustomSynEdit) then\r\n DoExecute(Sender as TCustomSynEdit)\r\n else\r\n if Assigned(Form.CurrentEditor) then\r\n DoExecute(Form.CurrentEditor as TCustomSynEdit);\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TSynCompletionProposal.SetEditor(const Value: TCustomSynEdit);\r\nbegin\r\n if Editor <> Value then\r\n begin\r\n if Assigned(Editor) then\r\n RemoveEditor(Editor);\r\n FEditor := Value;\r\n if Assigned(Value) then\r\n AddEditor(Value);\r\n end;\r\nend;\r\n\r\nprocedure TSynCompletionProposal.Notification(AComponent: TComponent;\r\n Operation: TOperation);\r\nbegin\r\n if (Operation = opRemove) then\r\n begin\r\n if Editor = AComponent then\r\n Editor := nil\r\n else if AComponent is TCustomSynEdit then\r\n RemoveEditor(TCustomSynEdit(AComponent));\r\n end;\r\n\r\n inherited Notification(AComponent, Operation);\r\nend;\r\n\r\nconstructor TSynCompletionProposal.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n Form.OnKeyPress := HandleOnKeyPress;\r\n Form.OnValidate := HandleOnValidate;\r\n Form.OnCancel := HandleOnCancel;\r\n Form.OnDblClick := HandleDblClick;\r\n EndOfTokenChr := DefaultEndOfTokenChr;\r\n TriggerChars := '.';\r\n fTimerInterval:= 1000;\r\n fNoNextKey := False;\r\n\r\n{$IFDEF SYN_CLX}\r\n fShortCut := QMenus.ShortCut(Ord(' '), [ssCtrl]);\r\n // Belongs to Missing-ShowWindow-Workaround\r\n FIgnoreFocusCommands := False;\r\n{$ELSE}\r\n fShortCut := Menus.ShortCut(Ord(' '), [ssCtrl]);\r\n{$ENDIF}\r\n Options := DefaultProposalOptions;\r\n fEditors := TList.Create;\r\nend;\r\n\r\nprocedure TSynCompletionProposal.SetShortCut(Value: TShortCut);\r\nbegin\r\n FShortCut := Value;\r\nend;\r\n\r\nprocedure TSynCompletionProposal.EditorKeyDown(Sender: TObject;\r\n var Key: Word; Shift: TShiftState);\r\nvar\r\n ShortCutKey: Word;\r\n ShortCutShift: TShiftState;\r\nbegin\r\n ShortCutToKey (fShortCut,ShortCutKey,ShortCutShift);\r\n with Sender as TCustomSynEdit do\r\n begin\r\n if ((DefaultType <> ctCode) or not(ReadOnly)) and (Shift = ShortCutShift) and (Key = ShortCutKey) then\r\n begin\r\n Form.CurrentEditor := Sender as TCustomSynEdit;\r\n Key := 0;\r\n DoExecute(Sender as TCustomSynEdit);\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TSynCompletionProposal.GetCurrentInput(AEditor: TCustomSynEdit): UnicodeString;\r\nvar\r\n s: UnicodeString;\r\n i: integer;\r\nbegin\r\n Result := '';\r\n if AEditor <> nil then\r\n begin\r\n s := AEditor.LineText;\r\n i := AEditor.CaretX - 1;\r\n if i <= Length(s) then\r\n begin \r\n FAdjustCompletionStart := False;\r\n while (i > 0) and (s[i] > #32) and not Self.IsWordBreakChar(s[i]) do\r\n dec(i);\r\n\r\n FCompletionStart := i + 1;\r\n Result := Copy(s, i + 1, AEditor.CaretX - i - 1);\r\n end\r\n else\r\n FAdjustCompletionStart := True;\r\n\r\n FCompletionStart := i + 1;\r\n end; \r\nend;\r\n\r\nfunction TSynCompletionProposal.GetPreviousToken(AEditor: TCustomSynEdit): UnicodeString;\r\nvar\r\n Line: UnicodeString;\r\n X: Integer;\r\nbegin\r\n Result := '';\r\n if not Assigned(AEditor) then\r\n exit;\r\n\r\n Line := AEditor.Lines[AEditor.CaretXY.Line - 1];\r\n X := AEditor.CaretXY.Char - 1;\r\n if (X = 0) or (X > Length(Line)) or (Length(Line) = 0) then\r\n exit;\r\n\r\n if Self.IsWordBreakChar(Line[X]) then\r\n dec(X);\r\n\r\n while (X > 0) and not(Self.IsWordBreakChar(Line[X])) do\r\n begin\r\n Result := Line[X] + Result;\r\n dec(x);\r\n end;\r\nend;\r\n\r\nprocedure TSynCompletionProposal.EditorKeyPress(Sender: TObject; var Key: WideChar);\r\nbegin\r\n if fNoNextKey then\r\n begin\r\n FNoNextKey := False;\r\n Key := #0;\r\n end\r\n else\r\n if Assigned(FTimer) then\r\n begin\r\n if Pos(Key, TriggerChars) <> 0 then\r\n ActivateTimer(Sender as TCustomSynEdit)\r\n else\r\n DeactivateTimer;\r\n end;\r\nend;\r\n\r\nprocedure TSynCompletionProposal.ActivateTimer(ACurrentEditor: TCustomSynEdit);\r\nbegin\r\n if Assigned(FTimer) then\r\n begin\r\n Form.CurrentEditor := ACurrentEditor;\r\n FTimer.Enabled := True;\r\n end;\r\nend;\r\n\r\nprocedure TSynCompletionProposal.DeactivateTimer;\r\nbegin\r\n if Assigned(FTimer) then\r\n begin\r\n FTimer.Enabled := False;\r\n end;\r\nend;\r\n\r\n\r\nprocedure TSynCompletionProposal.HandleDblClick(Sender: TObject);\r\nbegin\r\n HandleOnValidate(Sender, [], #0);\r\nend;\r\n\r\ndestructor TSynCompletionProposal.Destroy;\r\nbegin\r\n if Form.Visible then\r\n CancelCompletion;\r\n Editor := nil;\r\n while fEditors.Count <> 0 do\r\n RemoveEditor(TCustomSynEdit(FEditors.Last));\r\n\r\n inherited;\r\n\r\n fEditors.Free;\r\nend;\r\n\r\nprocedure TSynCompletionProposal.TimerExecute(Sender: TObject);\r\nbegin\r\n if not Assigned(FTimer) then exit;\r\n FTimer.Enabled := False; //GBN 13/11/2001 \r\n if Application.Active then\r\n begin\r\n DoExecute(Form.CurrentEditor as TCustomSynEdit);\r\n FNoNextKey := False;\r\n end else if Form.Visible then Form.Hide;\r\nend;\r\n\r\nfunction TSynCompletionProposal.GetTimerInterval: Integer;\r\nbegin\r\n Result := FTimerInterval;\r\nend;\r\n\r\nprocedure TSynCompletionProposal.SetTimerInterval(const Value: Integer);\r\nbegin\r\n FTimerInterval := Value;\r\n if Assigned(FTimer) then\r\n FTimer.Interval := Value;\r\nend;\r\n\r\nprocedure TSynCompletionProposal.SetOptions(const Value: TSynCompletionOptions);\r\nbegin\r\n inherited;\r\n\r\n if scoUseBuiltInTimer in Value then\r\n begin\r\n if not(Assigned(FTimer)) then\r\n begin\r\n FTimer := TTimer.Create(Self);\r\n FTimer.Enabled := False;\r\n FTimer.Interval := FTimerInterval;\r\n FTimer.OnTimer := TimerExecute;\r\n end;\r\n end else begin\r\n if Assigned(FTimer) then\r\n begin\r\n FreeAndNil(FTimer);\r\n end;\r\n end;\r\n\r\nend;\r\n\r\nprocedure TSynCompletionProposal.ExecuteEx(s: UnicodeString; x, y: integer;\r\n Kind: SynCompletionType);\r\nbegin\r\n {$IFDEF SYN_CLX} // Missing-ShowWindow-Workaround\r\n FIgnoreFocusCommands := True;\r\n try\r\n {$ENDIF}\r\n inherited;\r\n if Assigned(FTimer) then\r\n FTimer.Enabled := False;\r\n {$IFDEF SYN_CLX} // Missing-ShowWindow-Workaround\r\n finally\r\n FIgnoreFocusCommands := False;\r\n end;\r\n {$ENDIF}\r\nend;\r\n\r\nprocedure TSynCompletionProposal.AddEditor(AEditor: TCustomSynEdit);\r\nvar\r\n i : integer;\r\nbegin\r\n i := fEditors.IndexOf(AEditor);\r\n if i = -1 then begin\r\n AEditor.FreeNotification(Self);\r\n fEditors.Add(AEditor);\r\n AEditor.AddKeyDownHandler(EditorKeyDown);\r\n AEditor.AddKeyPressHandler(EditorKeyPress);\r\n AEditor.RegisterCommandHandler(HookedEditorCommand, Self);\r\n end;\r\nend;\r\n\r\nfunction TSynCompletionProposal.EditorsCount: integer;\r\nbegin\r\n result := fEditors.count;\r\nend;\r\n\r\nfunction TSynCompletionProposal.GetEditor(i: integer): TCustomSynEdit;\r\nbegin\r\n if (i < 0) or (i >= EditorsCount) then\r\n Result := nil\r\n else\r\n Result := fEditors[i];\r\nend;\r\n\r\nfunction TSynCompletionProposal.RemoveEditor(AEditor: TCustomSynEdit): boolean;\r\nvar\r\n i: integer;\r\nbegin\r\n i := fEditors.Remove(AEditor);\r\n result := i <> -1;\r\n if result then begin\r\n if Form.CurrentEditor = AEditor then\r\n begin\r\n if Form.Visible then\r\n CancelCompletion;\r\n Form.CurrentEditor := nil;\r\n end;\r\n AEditor.RemoveKeyDownHandler(EditorKeyDown);\r\n AEditor.RemoveKeyPressHandler(EditorKeyPress);\r\n AEditor.UnregisterCommandHandler(HookedEditorCommand);\r\n {$IFDEF SYN_COMPILER_5_UP}\r\n RemoveFreeNotification( AEditor );\r\n {$ENDIF}\r\n if fEditor = AEditor then\r\n fEditor := nil;\r\n end;\r\nend;\r\n\r\nprocedure TSynCompletionProposal.DoExecute(AEditor: TCustomSynEdit);\r\nvar\r\n p: TPoint;\r\n i: integer;\r\nbegin\r\n i := FEditors.IndexOf(AEditor);\r\n if i <> -1 then\r\n with AEditor do\r\n begin\r\n if (DefaultType <> ctCode) or not ReadOnly then\r\n begin\r\n if DefaultType = ctHint then\r\n GetCursorPos(P)\r\n else\r\n begin\r\n p := ClientToScreen(RowColumnToPixels(DisplayXY));\r\n Inc(p.y, LineHeight);\r\n end;\r\n\r\n Form.CurrentEditor := AEditor;\r\n\r\n FPreviousToken := GetPreviousToken(Form.CurrentEditor as TCustomSynEdit);\r\n ExecuteEx(GetCurrentInput(AEditor), p.x, p.y, DefaultType);\r\n FNoNextKey := (DefaultType = ctCode) and FCanExecute and Form.Visible;\r\n end;\r\n end; \r\nend;\r\n\r\nprocedure TSynCompletionProposal.InternalCancelCompletion;\r\nbegin\r\n if Assigned(FTimer) then FTimer.Enabled := False;\r\n FNoNextKey := False;\r\n if (Form.Visible) then\r\n begin\r\n Deactivate;\r\n Form.Hide;\r\n end;\r\nend;\r\n\r\nprocedure TSynCompletionProposal.CancelCompletion;\r\nbegin\r\n InternalCancelCompletion;\r\n if Assigned(OnCancelled) then OnCancelled(Self); \r\nend;\r\n\r\nprocedure TSynCompletionProposal.EditorCancelMode(Sender: TObject);\r\nbegin\r\n if (DisplayType = ctParams) then CancelCompletion;\r\nend;\r\n\r\nprocedure TSynCompletionProposal.HookedEditorCommand(Sender: TObject;\r\n AfterProcessing: Boolean; var Handled: Boolean; var Command: TSynEditorCommand;\r\n var AChar: WideChar; Data, HandlerData: Pointer);\r\nbegin\r\n inherited;\r\n\r\n if AfterProcessing and Form.Visible then\r\n begin\r\n case DisplayType of\r\n ctCode:\r\n begin\r\n\r\n end;\r\n ctHint:\r\n begin\r\n {$IFDEF SYN_CLX}\r\n if ((Command <> ecLostFocus) and (Command <> ecGotFocus))\r\n or (not FIgnoreFocusCommands) then\r\n {$ENDIF}\r\n CancelCompletion\r\n end;\r\n ctParams:\r\n begin\r\n case Command of\r\n ecGotFocus, ecLostFocus:\r\n {$IFDEF SYN_CLX}\r\n if ((Command <> ecLostFocus) and (Command <> ecGotFocus))\r\n or (not FIgnoreFocusCommands) then\r\n {$ENDIF}\r\n CancelCompletion;\r\n ecLineBreak:\r\n DoExecute(Sender as TCustomSynEdit);\r\n ecChar:\r\n begin\r\n case AChar of\r\n #27:\r\n CancelCompletion;\r\n #32..'z':\r\n with Form do\r\n begin\r\n{ if Pos(AChar, FTriggerChars) > 0 then\r\n begin\r\n if Assigned(FParameterToken) then\r\n begin\r\n TmpIndex := CurrentIndex;\r\n TmpLevel := CurrentLevel;\r\n TmpStr := CurrentString;\r\n OnParameterToken(Self, CurrentIndex, TmpLevel, TmpIndex, AChar, TmpStr);\r\n CurrentIndex := TmpIndex;\r\n CurrentLevel := TmpLevel;\r\n CurrentString := TmpStr;\r\n end;\r\n end;}\r\n DoExecute(Sender as TCustomSynEdit);\r\n end;\r\n else DoExecute(Sender as TCustomSynEdit);\r\n end;\r\n end;\r\n else DoExecute(Sender as TCustomSynEdit);\r\n end;\r\n end;\r\n end;\r\n end else\r\n if (not Form.Visible) and Assigned(FTimer) then\r\n begin\r\n if (Command = ecChar) then\r\n if (Pos(AChar, TriggerChars) = 0) then\r\n FTimer.Enabled := False\r\n else\r\n else\r\n FTimer.Enabled := False;\r\n end;\r\n\r\nend;\r\n\r\nprocedure TSynCompletionProposal.ActivateCompletion;\r\nbegin\r\n DoExecute(Editor);\r\nend;\r\n\r\n\r\n\r\n{ TSynAutoComplete }\r\n\r\nconstructor TSynAutoComplete.Create(AOwner: TComponent);\r\nbegin\r\n inherited;\r\n FDoLookup := True;\r\n CreateInternalCompletion;\r\n FEndOfTokenChr := DefaultEndOfTokenChr;\r\n fAutoCompleteList := TUnicodeStringList.Create;\r\n fNoNextKey := false;\r\n{$IFDEF SYN_CLX}\r\n fShortCut := QMenus.ShortCut(Ord(' '), [ssShift]);\r\n{$ELSE}\r\n fShortCut := Menus.ShortCut(Ord(' '), [ssShift]);\r\n{$ENDIF}\r\nend;\r\n\r\nprocedure TSynAutoComplete.SetShortCut(Value: TShortCut);\r\nbegin\r\n FShortCut := Value;\r\nend;\r\n\r\ndestructor TSynAutoComplete.Destroy;\r\nbegin\r\n Editor := nil;\r\n if Assigned(FInternalCompletion) then\r\n begin\r\n FInternalCompletion.Free;\r\n FInternalCompletion := nil;\r\n end;\r\n inherited;\r\n fAutoCompleteList.free;\r\nend;\r\n\r\nprocedure TSynAutoComplete.EditorKeyDown(Sender: TObject; var Key: Word;\r\n Shift: TShiftState);\r\nvar\r\n ShortCutKey: Word;\r\n ShortCutShift: TShiftState;\r\nbegin\r\n ShortCutToKey (fShortCut,ShortCutKey,ShortCutShift);\r\n if not (Sender as TCustomSynEdit).ReadOnly and\r\n (Shift = ShortCutShift) and (Key = ShortCutKey) then\r\n begin\r\n Execute(GetPreviousToken(Sender as TCustomSynEdit), Sender as TCustomSynEdit);\r\n fNoNextKey := True;\r\n Key := 0;\r\n end;\r\nend;\r\n\r\nprocedure TSynAutoComplete.EditorKeyPress(Sender: TObject; var Key: WideChar);\r\nbegin\r\n if fNoNextKey then\r\n begin\r\n fNoNextKey := False;\r\n Key := #0;\r\n end;\r\nend;\r\n\r\nprocedure TSynAutoComplete.Execute(Token: UnicodeString; Editor: TCustomSynEdit);\r\nbegin\r\n ExecuteEx(Token, Editor, FDoLookup);\r\nend;\r\n\r\nprocedure TSynAutoComplete.ExecuteEx(Token: UnicodeString; Editor: TCustomSynEdit;\r\n LookupIfNotExact: Boolean);\r\nvar\r\n Temp: UnicodeString;\r\n i, j: integer;\r\n StartOfBlock: TBufferCoord;\r\n ChangedIndent: Boolean;\r\n ChangedTrailing: Boolean;\r\n TmpOptions: TSynEditorOptions;\r\n OrigOptions: TSynEditorOptions;\r\n BeginningSpaceCount : Integer;\r\n Spacing: UnicodeString;\r\nbegin\r\n if Assigned(OnBeforeExecute) then OnBeforeExecute(Self);\r\n try\r\n i := AutoCompleteList.IndexOf(Token);\r\n if (i <> -1) then\r\n begin\r\n TmpOptions := Editor.Options;\r\n OrigOptions := Editor.Options;\r\n ChangedIndent := eoAutoIndent in TmpOptions;\r\n ChangedTrailing := eoTrimTrailingSpaces in TmpOptions;\r\n\r\n if ChangedIndent then Exclude(TmpOptions, eoAutoIndent);\r\n if ChangedTrailing then Exclude(TmpOptions, eoTrimTrailingSpaces);\r\n\r\n if ChangedIndent or ChangedTrailing then\r\n Editor.Options := TmpOptions;\r\n\r\n Editor.UndoList.AddChange(crAutoCompleteBegin, StartOfBlock, StartOfBlock, '',\r\n smNormal);\r\n\r\n fNoNextKey := True;\r\n for j := 1 to Length(Token) do\r\n Editor.CommandProcessor(ecDeleteLastChar, ' ', nil);\r\n BeginningSpaceCount := Editor.DisplayX - 1; \r\n if not(eoTabsToSpaces in Editor.Options) and\r\n (BeginningSpaceCount >= Editor.TabWidth)\r\n then\r\n Spacing := UnicodeStringOfChar(#9, BeginningSpaceCount div Editor.TabWidth)\r\n + UnicodeStringOfChar(' ', BeginningSpaceCount mod Editor.TabWidth)\r\n else\r\n Spacing := UnicodeStringOfChar(' ', BeginningSpaceCount);\r\n\r\n inc(i);\r\n if (i < AutoCompleteList.Count) and\r\n (Length(AutoCompleteList[i]) > 0) and\r\n (AutoCompleteList[i][1] = '|') then\r\n begin\r\n inc(i);\r\n end;\r\n StartOfBlock.Char := -1;\r\n StartOfBlock.Line := -1;\r\n while (i < AutoCompleteList.Count) and\r\n (length(AutoCompleteList[i]) > 0) and\r\n (AutoCompleteList[i][1] = '=') do\r\n begin\r\n { for j := 0 to PrevSpace - 1 do\r\n Editor.CommandProcessor(ecDeleteLastChar, ' ', nil);}\r\n Temp := AutoCompleteList[i];\r\n for j := 2 to Length(Temp) do begin\r\n if (Temp[j] = #9) then\r\n Editor.CommandProcessor(ecTab, Temp[j], nil)\r\n else\r\n Editor.CommandProcessor(ecChar, Temp[j], nil);\r\n if (Temp[j] = '|') then\r\n StartOfBlock := Editor.CaretXY\r\n end;\r\n inc(i);\r\n if (i < AutoCompleteList.Count) and\r\n (length(AutoCompleteList[i]) > 0) and\r\n (AutoCompleteList[i][1] = '=') then\r\n begin\r\n Editor.CommandProcessor (ecLineBreak,' ',nil);\r\n for j := 1 to length(Spacing) do\r\n if (Spacing[j] = #9) then\r\n Editor.CommandProcessor(ecTab, #9, nil)\r\n else\r\n Editor.CommandProcessor (ecChar, ' ', nil);\r\n end;\r\n end;\r\n if (StartOfBlock.Char <> -1) and (StartOfBlock.Line <> -1) then begin\r\n Editor.CaretXY := StartOfBlock;\r\n Editor.CommandProcessor(ecDeleteLastChar, ' ', nil);\r\n end;\r\n\r\n if ChangedIndent or ChangedTrailing then Editor.Options := OrigOptions;\r\n\r\n Editor.UndoList.AddChange(crAutoCompleteEnd, StartOfBlock, StartOfBlock,\r\n '', smNormal);\r\n fNoNextKey := False; \r\n end\r\n else if LookupIfNotExact and Assigned(FInternalCompletion) then\r\n begin\r\n FInternalCompletion.AddEditor(Editor);\r\n FInternalCompletion.ClearList;\r\n for i := 0 to AutoCompleteList.Count - 1 do\r\n if (Length(AutoCompleteList[i]) > 0) and (AutoCompleteList[i][1] <> '=') and (AutoCompleteList[i][1] <> '|') then\r\n begin\r\n if (i + 1 < AutoCompleteList.Count) and (length(AutoCompleteList[i + 1]) > 0) and\r\n (AutoCompleteList[i + 1][1] = '|') then\r\n begin\r\n Temp := AutoCompleteList[i + 1];\r\n Delete(Temp, 1, 1);\r\n end\r\n else\r\n Temp := AutoCompleteList[i];\r\n Temp := '\\style{+B}' + AutoCompleteList[i] + '\\style{-B}\\column{}' + Temp;\r\n FInternalCompletion.ItemList.Add(Temp);\r\n FInternalCompletion.InsertList.Add(AutoCompleteList[i]);\r\n end;\r\n FInternalCompletion.DoExecute(Editor);\r\n end;\r\n finally\r\n if Assigned(OnAfterExecute) then OnAfterExecute(Self);\r\n end; \r\nend;\r\n\r\nprocedure TSynAutoComplete.DoInternalAutoCompletion(Sender: TObject;\r\n const Value: UnicodeString; Shift: TShiftState; Index: Integer; EndToken: WideChar);\r\nbegin\r\n ExecuteEx(GetPreviousToken(Editor), Editor, False);\r\n FInternalCompletion.Editor := nil;\r\nend;\r\n\r\nfunction TSynAutoComplete.GetPreviousToken(Editor: TCustomSynEdit): UnicodeString;\r\nvar\r\n s: UnicodeString;\r\n i: Integer;\r\nbegin\r\n Result := '';\r\n if Editor <> nil then\r\n begin\r\n s := Editor.LineText;\r\n i := Editor.CaretX - 1;\r\n if i <= Length (s) then\r\n begin\r\n while (i > 0) and (s[i] > ' ') and (Pos(s[i], FEndOfTokenChr) = 0) do\r\n Dec(i);\r\n Result := copy(s, i + 1, Editor.CaretX - i - 1);\r\n end;\r\n end\r\nend;\r\n\r\nprocedure TSynAutoComplete.Notification(AComponent: TComponent; Operation: TOperation);\r\nbegin\r\n if (Operation = opRemove) and (Editor = AComponent) then\r\n Editor := nil;\r\n inherited Notification(AComponent, Operation);\r\nend;\r\n\r\nprocedure TSynAutoComplete.SetAutoCompleteList(List: TUnicodeStrings);\r\nbegin\r\n fAutoCompleteList.Assign(List);\r\nend;\r\n\r\nprocedure TSynAutoComplete.SetEditor(const Value: TCustomSynEdit);\r\nbegin\r\n if Editor <> Value then\r\n begin\r\n if Editor <> nil then\r\n begin\r\n Editor.RemoveKeyDownHandler( EditorKeyDown );\r\n Editor.RemoveKeyPressHandler( EditorKeyPress );\r\n {$IFDEF SYN_COMPILER_5_UP}\r\n RemoveFreeNotification( Editor );\r\n {$ENDIF}\r\n end;\r\n fEditor := Value;\r\n if Editor <> nil then\r\n begin\r\n Editor.AddKeyDownHandler( EditorKeyDown );\r\n Editor.AddKeyPressHandler( EditorKeyPress );\r\n FreeNotification( Editor );\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TSynAutoComplete.GetTokenList: UnicodeString;\r\nvar\r\n List: TUnicodeStringList;\r\n i: integer;\r\nbegin\r\n Result := '';\r\n if AutoCompleteList.Count < 1 then Exit;\r\n List := TUnicodeStringList.Create;\r\n i := 0;\r\n while (i < AutoCompleteList.Count) do begin\r\n if (length(AutoCompleteList[i]) > 0) and (AutoCompleteList[i][1] <> '=') then\r\n List.Add(WideTrim(AutoCompleteList[i]));\r\n inc(i);\r\n end;\r\n Result := List.Text;\r\n List.Free;\r\nend;\r\n\r\nfunction TSynAutoComplete.GetTokenValue(Token: UnicodeString): UnicodeString;\r\nvar\r\n i: integer;\r\n List: TUnicodeStringList;\r\nbegin\r\n Result := '';\r\n i := AutoCompleteList.IndexOf(Token);\r\n if i <> -1 then\r\n begin\r\n List := TUnicodeStringList.Create;\r\n Inc(i);\r\n while (i < AutoCompleteList.Count) and\r\n (length(AutoCompleteList[i]) > 0) and\r\n (AutoCompleteList[i][1] = '=') do begin\r\n if Length(AutoCompleteList[i]) = 1 then\r\n List.Add('')\r\n else\r\n List.Add(Copy(AutoCompleteList[i], 2, Length(AutoCompleteList[i])));\r\n inc(i);\r\n end;\r\n Result := List.Text;\r\n List.Free;\r\n end;\r\nend;\r\n\r\nprocedure TSynAutoComplete.SetDoLookup(const Value: Boolean);\r\nbegin\r\n FDoLookup := Value;\r\n if FDoLookup and not(Assigned(FInternalCompletion)) then\r\n CreateInternalCompletion\r\n else begin\r\n FInternalCompletion.Free;\r\n FInternalCompletion := nil;\r\n end;\r\nend;\r\n\r\nprocedure TSynAutoComplete.CreateInternalCompletion;\r\nbegin\r\n FInternalCompletion := TSynCompletionProposal.Create(Self);\r\n FInternalCompletion.Options := DefaultProposalOptions + [scoUsePrettyText] - [scoUseBuiltInTimer];\r\n FInternalCompletion.EndOfTokenChr := FEndOfTokenChr;\r\n FInternalCompletion.ShortCut := 0;\r\n FInternalCompletion.OnAfterCodeCompletion := DoInternalAutoCompletion;\r\n// with FInternalCompletion.Columns.Add do\r\n// //this is the trigger column\r\n// BiggestWord := 'XXXXXXXX';\r\nend;\r\n\r\nfunction TSynAutoComplete.GetOptions: TSynCompletionOptions;\r\nbegin\r\n Result := FOptions;\r\nend;\r\n\r\nprocedure TSynAutoComplete.SetOptions(const Value: TSynCompletionOptions);\r\nbegin\r\n FOptions := Value;\r\n if Assigned(FInternalCompletion) then\r\n FInternalCompletion.Options := FOptions + [scoUsePrettyText] - [scoUseBuiltInTimer];\r\nend;\r\n\r\nprocedure TSynAutoComplete.CancelCompletion;\r\nbegin\r\n if Assigned(FInternalCompletion) then\r\n FInternalCompletion.CancelCompletion;\r\nend;\r\n\r\nfunction TSynAutoComplete.GetExecuting: Boolean;\r\nbegin\r\n if Assigned(FInternalCompletion) then\r\n Result := FInternalCompletion.Form.Visible\r\n else Result := False;\r\nend;\r\n\r\nend.\r\n" }, { "path": "External/SynEdit/Source/SynDBEdit.pas", "content": "{-------------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: SynDBEdit.pas, released 2000-05-05.\r\nThe Original Code is based on DBmwEdit.pas by Vladimir Kuznetsov, part of\r\nthe mwEdit component suite.\r\nPortions created by Vladimir Kuznetsov are Copyright (C) 1999 Vladimir Kuznetsov.\r\nUnicode translation by Mal Hrz.\r\nAll Rights Reserved.\r\n\r\nContributors to the SynEdit and mwEdit projects are listed in the\r\nContributors.txt file.\r\n\r\nAlternatively, the contents of this file may be used under the terms of the\r\nGNU General Public License Version 2 or later (the \"GPL\"), in which case\r\nthe provisions of the GPL are applicable instead of those above.\r\nIf you wish to allow use of your version of this file only under the terms\r\nof the GPL and not to allow others to use your version of this file\r\nunder the MPL, indicate your decision by deleting the provisions above and\r\nreplace them with the notice and other provisions required by the GPL.\r\nIf you do not delete the provisions above, a recipient may use your version\r\nof this file under either the MPL or the GPL.\r\n\r\n$Id: SynDBEdit.pas,v 1.11.2.2 2009/06/14 13:33:38 maelh Exp $\r\n\r\nYou may retrieve the latest version of this file at the SynEdit home page,\r\nlocated at http://SynEdit.SourceForge.net\r\n\r\nKnown Issues:\r\n-------------------------------------------------------------------------------}\r\n\r\n{$IFNDEF QSYNDBEDIT}\r\nunit SynDBEdit;\r\n{$ENDIF}\r\n\r\n{$I SynEdit.inc}\r\n\r\ninterface\r\n\r\nuses\r\n{$IFNDEF SYN_COMPILER_3_UP}\r\n DbTables,\r\n{$ENDIF}\r\n{$IFDEF SYN_CLX}\r\n Qt,\r\n QControls,\r\n QDBCtrls,\r\n QSynEdit,\r\n QSynEditKeyCmds,\r\n{$ELSE}\r\n Windows,\r\n Messages,\r\n Controls,\r\n DbCtrls,\r\n SynEdit,\r\n SynEditKeyCmds,\r\n{$ENDIF}\r\n SysUtils,\r\n Classes,\r\n DB;\r\n\r\ntype\r\n TCustomDBSynEdit = class(TCustomSynEdit)\r\n private\r\n FDataLink: TFieldDataLink;\r\n fEditing: boolean;\r\n FBeginEdit: boolean;\r\n FLoadData: TNotifyEvent;\r\n procedure DataChange(Sender: TObject);\r\n procedure EditingChange(Sender: TObject);\r\n function GetDataField: string;\r\n function GetDataSource: TDataSource;\r\n function GetField: TField;\r\n procedure SetDataField(const Value: string);\r\n procedure SetDataSource(Value: TDataSource);\r\n procedure SetEditing(Value: Boolean);\r\n procedure UpdateData(Sender: TObject);\r\n private\r\n {$IFNDEF SYN_CLX}\r\n procedure CMEnter(var Msg: TCMEnter); message CM_ENTER;\r\n procedure CMExit(var Msg: TCMExit); message CM_EXIT;\r\n procedure CMGetDataLink(var Msg: TMessage); message CM_GETDATALINK;\r\n {$ENDIF}\r\n protected\r\n function GetReadOnly: boolean; override;\r\n procedure Loaded; override;\r\n procedure DoChange; override;\r\n procedure SetReadOnly(Value: boolean); override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n procedure DragDrop(Source: TObject; X, Y: Integer); override;\r\n procedure ExecuteCommand(Command: TSynEditorCommand; AChar: WideChar;\r\n Data: pointer); override;\r\n procedure LoadMemo;\r\n procedure Notification(AComponent: TComponent; Operation: TOperation);\r\n override;\r\n {$IFDEF SYN_CLX}\r\n function EventFilter(Sender: QObjectH; Event: QEventH): Boolean; override;\r\n {$ENDIF}\r\n protected\r\n property DataField: string read GetDataField write SetDataField;\r\n property DataSource: TDataSource read GetDataSource write SetDataSource;\r\n property Field: TField read GetField;\r\n property OnLoadData: TNotifyEvent read fLoadData write fLoadData;\r\n end;\r\n\r\n TDBSynEdit = class(TCustomDBSynEdit)\r\n published\r\n // TCustomDBSynEdit properties\r\n property DataField;\r\n property DataSource;\r\n property Field;\r\n // TCustomDBSynEdit events\r\n property OnLoadData;\r\n // inherited properties\r\n property Align;\r\n {$IFDEF SYN_COMPILER_4_UP}\r\n property Anchors;\r\n property Constraints;\r\n {$ENDIF}\r\n property Color;\r\n {$IFNDEF SYN_CLX}\r\n property Ctl3D;\r\n {$ENDIF}\r\n property Enabled;\r\n property Font;\r\n property Height;\r\n property Name;\r\n property ParentColor;\r\n {$IFNDEF SYN_CLX}\r\n property ParentCtl3D;\r\n {$ENDIF}\r\n property ParentFont;\r\n property ParentShowHint;\r\n property PopupMenu;\r\n property ShowHint;\r\n property TabOrder;\r\n property TabStop default True;\r\n property Tag;\r\n property Visible;\r\n property Width;\r\n // inherited events\r\n property OnClick;\r\n property OnDblClick;\r\n property OnDragDrop;\r\n property OnDragOver;\r\n {$IFDEF SYN_COMPILER_4_UP}\r\n {$IFNDEF SYN_CLX}\r\n property OnEndDock;\r\n {$ENDIF}\r\n {$ENDIF}\r\n property OnEndDrag;\r\n property OnEnter;\r\n property OnExit;\r\n property OnKeyDown;\r\n property OnKeyPress;\r\n property OnKeyUp;\r\n property OnMouseDown;\r\n property OnMouseMove;\r\n property OnMouseUp;\r\n {$IFDEF SYN_COMPILER_4_UP}\r\n {$IFNDEF SYN_CLX}\r\n property OnStartDock;\r\n {$ENDIF}\r\n {$ENDIF}\r\n property OnStartDrag;\r\n // TCustomSynEdit properties\r\n property BookMarkOptions;\r\n property BorderStyle;\r\n property ExtraLineSpacing;\r\n property Gutter;\r\n property HideSelection;\r\n property Highlighter;\r\n{$IFNDEF SYN_CLX}\r\n property ImeMode;\r\n property ImeName;\r\n{$ENDIF}\r\n property InsertCaret;\r\n property InsertMode;\r\n property Keystrokes;\r\n property MaxScrollWidth;\r\n property MaxUndo;\r\n property Options;\r\n property OverwriteCaret;\r\n property ReadOnly;\r\n property RightEdge;\r\n property RightEdgeColor;\r\n property ScrollBars;\r\n property SearchEngine;\r\n property SelectedColor;\r\n property SelectionMode;\r\n property TabWidth;\r\n property WantTabs;\r\n // TCustomSynEdit events\r\n property OnChange;\r\n property OnCommandProcessed;\r\n property OnDropFiles;\r\n property OnGutterClick;\r\n property OnGutterGetText;\r\n property OnGutterPaint;\r\n property OnPaint;\r\n property OnPlaceBookmark;\r\n property OnProcessCommand;\r\n property OnProcessUserCommand;\r\n property OnReplaceText;\r\n property OnSpecialLineColors;\r\n property OnStatusChange;\r\n property OnPaintTransient;\r\n end;\r\n\r\nimplementation\r\n\r\nconstructor TCustomDBSynEdit.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FDataLink := TFieldDataLink.Create;\r\n FDataLink.Control := Self;\r\n FDataLink.OnDataChange := DataChange;\r\n FDataLink.OnEditingChange := EditingChange;\r\n FDataLink.OnUpdateData := UpdateData;\r\nend;\r\n\r\ndestructor TCustomDBSynEdit.Destroy;\r\nbegin\r\n FDataLink.Free;\r\n FDataLink := nil;\r\n inherited Destroy;\r\nend;\r\n\r\n{$IFNDEF SYN_CLX}\r\nprocedure TCustomDBSynEdit.CMEnter(var Msg: TCMEnter);\r\nbegin\r\n SetEditing(True);\r\n inherited;\r\nend;\r\n\r\nprocedure TCustomDBSynEdit.CMExit(var Msg: TCMExit);\r\nbegin\r\n try\r\n FDataLink.UpdateRecord;\r\n except\r\n SetFocus;\r\n raise;\r\n end;\r\n SetEditing(False);\r\n inherited;\r\nend;\r\n\r\nprocedure TCustomDBSynEdit.CMGetDataLink(var Msg: TMessage);\r\nbegin\r\n Msg.Result := Integer(FDataLink);\r\nend;\r\n{$ENDIF}\r\n\r\nprocedure TCustomDBSynEdit.DataChange(Sender: TObject);\r\nbegin\r\n if FDataLink.Field <> nil then\r\n begin\r\n if FBeginEdit then\r\n begin\r\n FBeginEdit := False;\r\n Exit;\r\n end;\r\n{$IFDEF SYN_COMPILER_3_UP}\r\n if FDataLink.Field.IsBlob then\r\n LoadMemo\r\n else\r\n{$ENDIF}\r\n Text := FDataLink.Field.Text;\r\n if Assigned(FLoadData) then\r\n FLoadData(Self);\r\n end\r\n else\r\n begin\r\n if csDesigning in ComponentState then\r\n Text := Name\r\n else\r\n Text := '';\r\n end;\r\nend;\r\n\r\nprocedure TCustomDBSynEdit.DragDrop(Source: TObject; X, Y: Integer);\r\nbegin\r\n FDataLink.Edit;\r\n inherited;\r\nend;\r\n\r\nprocedure TCustomDBSynEdit.EditingChange(Sender: TObject);\r\nbegin\r\n if FDataLink.Editing then\r\n begin\r\n if Assigned(FDataLink.DataSource)\r\n and (FDataLink.DataSource.State <> dsInsert)\r\n then\r\n FBeginEdit := True;\r\n end;\r\nend;\r\n\r\nprocedure TCustomDBSynEdit.ExecuteCommand(Command: TSynEditorCommand;\r\n AChar: WideChar; Data: pointer);\r\nbegin\r\n // cancel on [ESC]\r\n if (Command = ecChar) and (AChar = #27) then\r\n FDataLink.Reset\r\n // set editing state if editor command\r\n else if (Command >= ecEditCommandFirst) and (Command <= ecEditCommandLast) then\r\n if not FDataLink.Edit then Exit;\r\n \r\n inherited;\r\nend;\r\n\r\nfunction TCustomDBSynEdit.GetDataField: string;\r\nbegin\r\n Result := FDataLink.FieldName;\r\nend;\r\n\r\nfunction TCustomDBSynEdit.GetDataSource: TDataSource;\r\nbegin\r\n Result := FDataLink.DataSource;\r\nend;\r\n\r\nfunction TCustomDBSynEdit.GetField: TField;\r\nbegin\r\n Result := FDataLink.Field;\r\nend;\r\n\r\nfunction TCustomDBSynEdit.GetReadOnly: Boolean;\r\nbegin\r\n Result := FDataLink.ReadOnly;\r\nend;\r\n\r\nprocedure TCustomDBSynEdit.Loaded;\r\nbegin\r\n inherited Loaded;\r\n if csDesigning in ComponentState then\r\n DataChange(Self);\r\nend;\r\n\r\nprocedure TCustomDBSynEdit.LoadMemo;\r\n{$IFDEF SYN_COMPILER_3_UP}\r\nvar\r\n BlobStream: TStream;\r\n{$ELSE}\r\nvar\r\n BlobStream: TBlobStream;\r\n BlobField: TBlobField;\r\n{$ENDIF}\r\nbegin\r\n try\r\n{$IFDEF SYN_COMPILER_3_UP}\r\n BlobStream := FDataLink.DataSet.CreateBlobStream(FDataLink.Field, bmRead);\r\n{$ELSE}\r\n BlobField := FDataLink.Field as TBlobField;\r\n BlobStream := TBlobStream.Create(BlobField, bmRead);\r\n{$ENDIF}\r\n Lines.BeginUpdate;\r\n Lines.LoadFromStream(BlobStream{$IFDEF UNICODE}, TEncoding.Default{$ENDIF});\r\n Lines.EndUpdate;\r\n BlobStream.Free;\r\n Modified := False;\r\n ClearUndo;\r\n except\r\n // Memo too large \r\n on E: EInvalidOperation do\r\n Lines.Text := Format('(%s)', [E.Message]);\r\n end;\r\n EditingChange(Self);\r\nend;\r\n\r\nprocedure TCustomDBSynEdit.DoChange;\r\nbegin\r\n FDataLink.Modified;\r\n inherited;\r\nend;\r\n\r\nprocedure TCustomDBSynEdit.Notification(AComponent: TComponent;\r\n Operation: TOperation);\r\nbegin\r\n inherited Notification(AComponent, Operation);\r\n if (Operation = opRemove) and (FDataLink <> nil) and (AComponent = DataSource)\r\n then\r\n DataSource := nil;\r\nend;\r\n\r\nprocedure TCustomDBSynEdit.SetDataField(const Value: string);\r\nbegin\r\n FDataLink.FieldName := Value;\r\nend;\r\n\r\nprocedure TCustomDBSynEdit.SetDataSource(Value: TDataSource);\r\nbegin\r\n if not (FDataLink.DataSourceFixed and (csLoading in ComponentState)) then\r\n FDataLink.DataSource := Value;\r\n if Value <> nil then\r\n Value.FreeNotification(Self);\r\nend;\r\n\r\nprocedure TCustomDBSynEdit.SetEditing(Value: Boolean);\r\nbegin\r\n if fEditing <> Value then\r\n begin\r\n fEditing := Value;\r\n{$IFDEF SYN_COMPILER_3_UP}\r\n if not Assigned(FDataLink.Field) or not FDataLink.Field.IsBlob then\r\n{$ENDIF}\r\n FDataLink.Reset;\r\n end;\r\nend;\r\n\r\nprocedure TCustomDBSynEdit.SetReadOnly(Value: Boolean);\r\nbegin\r\n FDataLink.ReadOnly := Value;\r\nend;\r\n\r\nprocedure TCustomDBSynEdit.UpdateData(Sender: TObject);\r\n{$IFDEF SYN_COMPILER_3_UP}\r\nvar\r\n BlobStream: TStream;\r\n{$ENDIF}\r\nbegin\r\n{$IFDEF SYN_COMPILER_3_UP}\r\n if FDataLink.Field.IsBlob then\r\n begin\r\n BlobStream := FDataLink.DataSet.CreateBlobStream(FDataLink.Field, bmWrite);\r\n Lines.SaveToStream(BlobStream);\r\n BlobStream.Free;\r\n end else\r\n{$ENDIF}\r\n FDataLink.Field.AsString := Text;\r\nend;\r\n\r\n{$IFDEF SYN_CLX}\r\nfunction TCustomDBSynEdit.EventFilter(Sender: QObjectH;\r\n Event: QEventH): Boolean;\r\nbegin\r\n Result := inherited EventFilter(Sender, Event);\r\n case QEvent_type(Event) of\r\n QEventType_FocusIn:\r\n SetEditing(True);\r\n QEventType_FocusOut:\r\n SetEditing(False);\r\n end;\r\nend;\r\n{$ENDIF}\r\n\r\nend.\r\n\r\n" }, { "path": "External/SynEdit/Source/SynEdit.inc", "content": "(******************************************************************************)\r\n(* SynEdit Include File. This file was adapted from Brad Stowers' DFS.INC *)\r\n(* file and used with permission. This will help reduce headaches when new *)\r\n(* versions of Delphi and C++Builder are released, among other things. *)\r\n(******************************************************************************)\r\n(* Brad Stowers: bstowers@pobox.com *)\r\n(* Delphi Free Stuff: http://delphifreestuff.com/ *)\r\n(* February 24, 1999 *)\r\n(******************************************************************************)\r\n(* *)\r\n(* Complete Boolean Evaluation compiler directive is turned off by including *)\r\n(* this file. *)\r\n(* The $ObjExportAll directive is turned on if compiling with C++Builder 3 or *)\r\n(* higher. This is required for Delphi components built in Builder with *)\r\n(* run-time packages. *)\r\n(* *)\r\n(* Here is a brief explanation of what each of the defines mean: *)\r\n(* SYN_WIN32 : Compilation target is 32-bit Windows *)\r\n(* SYN_COMPILER_2 : Delphi 2 or C++Builder 1 is the compiler. *)\r\n(* SYN_COMPILER_2_UP : Delphi 2 or higher, or C++Builder 1 or higher is *)\r\n(* the compiler. *)\r\n(* SYN_COMPILER_3 : Delphi 3 or C++Builder 3 is the compiler. *)\r\n(* SYN_COMPILER_3_UP : Delphi 3 or higher, or C++Builder 3 or higher is *)\r\n(* the compiler. *)\r\n(* SYN_COMPILER_4 : Delphi 4 or C++Builder 4 is the compiler. *)\r\n(* SYN_COMPILER_4_UP : Delphi 4 or higher, or C++Builder 4 or higher is *)\r\n(* the compiler. *)\r\n(* SYN_COMPILER_5 : Delphi 5 or C++Builder 5 is the compiler. *)\r\n(* SYN_COMPILER_5_UP : Delphi 5 or higher, or C++Builder 5 or higher is *)\r\n(* the compiler. *)\r\n(* SYN_COMPILER_6 : Delphi 6, C++Builder 6, Kylix 1 or Kylix 2 is *)\r\n(* the compiler. *)\r\n(* SYN_COMPILER_6_UP : Delphi 6, C++Builder 6, Kylix 1, Kylix 2 or higher *)\r\n(* is the compiler. *)\r\n(* SYN_COMPILER_7 : Delphi 7 or Kylix 3 is the compiler. *)\r\n(* SYN_COMPILER_7_UP : Delphi 7, Kylix 3 or higher is the compiler. *)\r\n(* SYN_COMPILER_9 : Delphi 2005 is the compiler. *)\r\n(* SYN_COMPILER_9_UP : Delphi 2005 or higher is the compiler. *)\r\n(* SYN_COMPILER_10 : Delphi 2006 is the compiler. *)\r\n(* SYN_COMPILER_10_UP : Delphi 2006 or higher is the compiler. *)\r\n(* SYN_COMPILER_11 : Delphi 2007 is the compiler. *)\r\n(* SYN_COMPILER_11_UP : Delphi 2007 or higher is the compiler. *)\r\n(* SYN_COMPILER_12 : Delphi 2009 is the compiler. *)\r\n(* SYN_COMPILER_12_UP : Delphi 2009 or higher is the compiler. *)\r\n(* SYN_COMPILER_14 : Delphi 2010 is the compiler. *)\r\n(* SYN_COMPILER_14_UP : Delphi 2010 or higher is the compiler. *)\r\n(* SYN_COMPILER_15 : Delphi XE is the compiler. *)\r\n(* SYN_COMPILER_15_UP : Delphi XE or higher is the compiler. *)\r\n(* SYN_COMPILER_16 : Delphi XE2 is the compiler. *)\r\n(* SYN_COMPILER_16_UP : Delphi XE2 or higher is the compiler. *)\r\n(* SYN_COMPILER_17 : Delphi XE3 is the compiler. *)\r\n(* SYN_COMPILER_17_UP : Delphi XE3 or higher is the compiler. *)\r\n(* SYN_COMPILER_18 : Delphi XE4 is the compiler. *)\r\n(* SYN_COMPILER_18_UP : Delphi XE4 or higher is the compiler. *)\r\n(* SYN_COMPILER_19 : Delphi XE5 is the compiler. *)\r\n(* SYN_COMPILER_19_UP : Delphi XE5 or higher is the compiler. *)\r\n(* SYN_CPPB : Any version of C++Builder is being used. *)\r\n(* SYN_CPPB_1 : C++B v1.0x is being used. *)\r\n(* SYN_CPPB_3 : C++B v3.0x is being used. *)\r\n(* SYN_CPPB_3_UP : C++B v3.0x or higher is being used. *)\r\n(* SYN_CPPB_4 : C++B v4.0x is being used. *)\r\n(* SYN_CPPB_4_UP : C++B v4.0x or higher is being used. *)\r\n(* SYN_CPPB_5 : C++B v5.0x is being used. *)\r\n(* SYN_CPPB_5_UP : C++B v5.0x or higher is being used. *)\r\n(* SYN_CPPB_6 : C++B v6.0x is being used. *)\r\n(* SYN_CPPB_6_UP : C++B v6.0x or higher is being used. *)\r\n(* SYN_DELPHI : Any version of Delphi is being used. *)\r\n(* SYN_DELPHI_PE : The personal edition of Delphi is being used. *)\r\n(* SYN_DELPHI_2 : Delphi 2 is being used. *)\r\n(* SYN_DELPHI_2_UP : Delphi 2 or higher is being used. *)\r\n(* SYN_DELPHI_3 : Delphi 3 is being used. *)\r\n(* SYN_DELPHI_3_UP : Delphi 3 or higher is being used. *)\r\n(* SYN_DELPHI_4 : Delphi 4 is being used. *)\r\n(* SYN_DELPHI_4_UP : Delphi 4 or higher is being used. *)\r\n(* SYN_DELPHI_5 : Delphi 5 is being used. *)\r\n(* SYN_DELPHI_5_UP : Delphi 5 or higher is being used. *)\r\n(* SYN_DELPHI_6 : Delphi 6 is being used. *)\r\n(* SYN_DELPHI_6_UP : Delphi 6 or higher is being used. *)\r\n(* SYN_DELPHI_7 : Delphi 7 is being used. *)\r\n(* SYN_DELPHI_7_UP : Delphi 7 or higher is being used. *)\r\n(* SYN_DELPHI_8 : Delphi 8 is being used. *)\r\n(* SYN_DELPHI_8_UP : Delphi 8 or higher is being used. *)\r\n(* SYN_DELPHI_2005 : Delphi 2005 is being used. *)\r\n(* SYN_DELPHI_2005_UP : Delphi 2005 or higher is being used. *)\r\n(* SYN_DELPHI_2006 : Delphi 2006 is being used. *)\r\n(* SYN_DELPHI_2006_UP : Delphi 2006 or higher is being used. *)\r\n(* SYN_DELPHI_2007 : Delphi 2007 is being used. *)\r\n(* SYN_DELPHI_2007_UP : Delphi 2007 or higher is being used. *)\r\n(* SYN_DELPHI_2009 : Delphi 2009 is being used. *)\r\n(* SYN_DELPHI_2009_UP : Delphi 2009 or higher is being used. *)\r\n(* SYN_DELPHI_2010 : Delphi 2010 is being used. *)\r\n(* SYN_DELPHI_2010_UP : Delphi 2010 or higher is being used. *)\r\n(* SYN_DELPHI_XE : Delphi XE is being used. *)\r\n(* SYN_DELPHI_XE_UP : Delphi XE or higher is being used. *)\r\n(* SYN_DELPHI_XE2 : Delphi XE2 is being used. *)\r\n(* SYN_DELPHI_XE2_UP : Delphi XE2 or higher is being used. *)\r\n(* SYN_DELPHI_XE3 : Delphi XE3 is being used. *)\r\n(* SYN_DELPHI_XE3_UP : Delphi XE3 or higher is being used. *)\r\n(* SYN_DELPHI_XE4 : Delphi XE4 is being used. *)\r\n(* SYN_DELPHI_XE4_UP : Delphi XE4 or higher is being used. *)\r\n(* SYN_DELPHI_XE5 : Delphi XE5 is being used. *)\r\n(* SYN_DELPHI_XE5_UP : Delphi XE5 or higher is being used. *)\r\n(* SYN_KYLIX : Kylix 1.0 is being using. *)\r\n(* SYN_CLX : A CLX application is being created. *)\r\n(******************************************************************************)\r\n\r\n{$DEFINE SYNEDIT_INCLUDE}\r\n\r\n{------------------------------------------------------------------------------}\r\n{ Common compiler defines }\r\n{ (remove the dot in front of a define to enable it) }\r\n{------------------------------------------------------------------------------}\r\n\r\n{$B-,H+} // defaults are short evaluation of boolean values and long strings\r\n\r\n{.$DEFINE SYN_DEVELOPMENT_CHECKS} // additional tests for debugging\r\n{$IFDEF SYN_DEVELOPMENT_CHECKS}\r\n {$R+,Q+,S+,T+}\r\n{$ENDIF}\r\n\r\n{------------------------------------------------------------------------------}\r\n{ Pull in all defines from SynEditJedi.inc (must be done after the common }\r\n{ compiler defines to work correctly). Use SynEdit-prefix to avoid problems }\r\n{ with other versions of jedi.inc in the search-path. }\r\n{------------------------------------------------------------------------------}\r\n\r\n{$I SynEditJedi.inc}\r\n\r\n{------------------------------------------------------------------------------}\r\n{ SYN_WIN32, SYN_LINUX and SYN_KYLIX defines }\r\n{------------------------------------------------------------------------------}\r\n\r\n{$IFDEF WIN32}\r\n {$DEFINE SYN_WIN32}\r\n{$ENDIF}\r\n\r\n{$IFDEF LINUX}\r\n {$DEFINE SYN_LINUX}\r\n {$DEFINE SYN_KYLIX}\r\n {$DEFINE SYN_COMPILER_6}\r\n {$DEFINE SYN_DELPHI}\r\n {$DEFINE SYN_DELPHI_6}\r\n{$ENDIF}\r\n\r\n{------------------------------------------------------------------------------}\r\n{ VERXXX to SYN_COMPILERX, SYN_DELPHIX and SYN_CPPBX mappings }\r\n{------------------------------------------------------------------------------}\r\n\r\n{$if CompilerVersion > 26}\r\n {$define VER260}\r\n{$endif}\r\n\r\n{$IFDEF VER260}\r\n {$DEFINE SYN_COMPILER_19}\r\n {$DEFINE SYN_DELPHI}\r\n {$DEFINE SYN_DELPHI_XE5}\r\n{$ENDIF}\r\n\r\n{$IFDEF VER250}\r\n {$DEFINE SYN_COMPILER_18}\r\n {$DEFINE SYN_DELPHI}\r\n {$DEFINE SYN_DELPHI_XE4}\r\n{$ENDIF}\r\n\r\n{$IFDEF VER240}\r\n {$DEFINE SYN_COMPILER_17}\r\n {$DEFINE SYN_DELPHI}\r\n {$DEFINE SYN_DELPHI_XE3}\r\n{$ENDIF}\r\n\r\n{$IFDEF VER230}\r\n {$DEFINE SYN_COMPILER_16}\r\n {$DEFINE SYN_DELPHI}\r\n {$DEFINE SYN_DELPHI_XE2}\r\n{$ENDIF}\r\n\r\n{$IFDEF VER220}\r\n {$DEFINE SYN_COMPILER_15}\r\n {$DEFINE SYN_DELPHI}\r\n {$DEFINE SYN_DELPHI_XE}\r\n{$ENDIF}\r\n\r\n{$IFDEF VER210}\r\n {$DEFINE SYN_COMPILER_14}\r\n {$DEFINE SYN_DELPHI}\r\n {$DEFINE SYN_DELPHI_2010}\r\n{$ENDIF}\r\n\r\n{$IFDEF VER200}\r\n {$DEFINE SYN_COMPILER_12}\r\n {$DEFINE SYN_DELPHI}\r\n {$DEFINE SYN_DELPHI_2009}\r\n{$ENDIF}\r\n\r\n{$IFDEF VER190}\r\n {$DEFINE SYN_COMPILER_11}\r\n {$DEFINE SYN_DELPHI}\r\n {$DEFINE SYN_DELPHI_2007}\r\n{$ENDIF}\r\n\r\n{$IFDEF VER180}\r\n {$DEFINE SYN_COMPILER_10}\r\n {$DEFINE SYN_DELPHI}\r\n {$DEFINE SYN_DELPHI_2006}\r\n{$ENDIF}\r\n\r\n{$IFDEF VER170}\r\n {$DEFINE SYN_COMPILER_9}\r\n {$DEFINE SYN_DELPHI}\r\n {$DEFINE SYN_DELPHI_2005}\r\n{$ENDIF}\r\n\r\n{$IFDEF VER160}\r\n {$DEFINE SYN_COMPILER_8}\r\n {$DEFINE SYN_DELPHI}\r\n {$DEFINE SYN_DELPHI_8}\r\n{$ENDIF}\r\n\r\n{$IFDEF VER150}\r\n {$DEFINE SYN_COMPILER_7}\r\n {$IFNDEF BCB}\r\n {$DEFINE SYN_DELPHI}\r\n {$DEFINE SYN_DELPHI_7}\r\n {$ELSE}\r\n {.$DEFINE SYN_CPPB}\r\n {.$DEFINE SYN_CPPB_7}\r\n {$ENDIF}\r\n{$ENDIF}\r\n\r\n{$IFDEF VER140}\r\n {$DEFINE SYN_COMPILER_6}\r\n {$IFNDEF BCB}\r\n {$DEFINE SYN_DELPHI}\r\n {$DEFINE SYN_DELPHI_6}\r\n {$ELSE}\r\n {$DEFINE SYN_CPPB}\r\n {$DEFINE SYN_CPPB_6}\r\n {$ENDIF}\r\n{$ENDIF}\r\n\r\n{$IFDEF VER130}\r\n {$DEFINE SYN_COMPILER_5}\r\n {$IFNDEF BCB}\r\n {$DEFINE SYN_DELPHI}\r\n {$DEFINE SYN_DELPHI_5}\r\n {$ELSE}\r\n {$DEFINE SYN_CPPB}\r\n {$DEFINE SYN_CPPB_5}\r\n {$ENDIF}\r\n{$ENDIF}\r\n\r\n{$IFDEF VER125}\r\n {$DEFINE SYN_COMPILER_4}\r\n {$DEFINE SYN_CPPB}\r\n {$DEFINE SYN_CPPB_4}\r\n{$ENDIF}\r\n\r\n{$IFDEF VER120}\r\n {$DEFINE SYN_COMPILER_4}\r\n {$DEFINE SYN_DELPHI}\r\n {$DEFINE SYN_DELPHI_4}\r\n{$ENDIF}\r\n\r\n{$IFDEF VER110}\r\n {$DEFINE SYN_COMPILER_3}\r\n {$DEFINE SYN_CPPB}\r\n {$DEFINE SYN_CPPB_3}\r\n{$ENDIF}\r\n\r\n{$IFDEF VER100}\r\n {$DEFINE SYN_COMPILER_3}\r\n {$DEFINE SYN_DELPHI}\r\n {$DEFINE SYN_DELPHI_3}\r\n{$ENDIF}\r\n\r\n{$IFDEF VER93}\r\n {$DEFINE SYN_COMPILER_2} { C++B v1 compiler is really v2 }\r\n {$DEFINE SYN_CPPB}\r\n {$DEFINE SYN_CPPB_1}\r\n{$ENDIF}\r\n\r\n{$IFDEF VER90}\r\n {$DEFINE SYN_COMPILER_2}\r\n {$DEFINE SYN_DELPHI}\r\n {$DEFINE SYN_DELPHI_2}\r\n{$ENDIF}\r\n\r\n{$IFDEF SYN_COMPILER_2}\r\n {$DEFINE SYN_COMPILER_1_UP}\r\n {$DEFINE SYN_COMPILER_2_UP}\r\n{$ENDIF}\r\n\r\n{$IFDEF SYN_COMPILER_3}\r\n {$DEFINE SYN_COMPILER_1_UP}\r\n {$DEFINE SYN_COMPILER_2_UP}\r\n {$DEFINE SYN_COMPILER_3_UP}\r\n{$ENDIF}\r\n\r\n{$IFDEF SYN_COMPILER_4}\r\n {$DEFINE SYN_COMPILER_1_UP}\r\n {$DEFINE SYN_COMPILER_2_UP}\r\n {$DEFINE SYN_COMPILER_3_UP}\r\n {$DEFINE SYN_COMPILER_4_UP}\r\n{$ENDIF}\r\n\r\n{$IFDEF SYN_COMPILER_5}\r\n {$DEFINE SYN_COMPILER_1_UP}\r\n {$DEFINE SYN_COMPILER_2_UP}\r\n {$DEFINE SYN_COMPILER_3_UP}\r\n {$DEFINE SYN_COMPILER_4_UP}\r\n {$DEFINE SYN_COMPILER_5_UP}\r\n{$ENDIF}\r\n\r\n{$IFDEF SYN_COMPILER_6}\r\n {$DEFINE SYN_COMPILER_1_UP}\r\n {$DEFINE SYN_COMPILER_2_UP}\r\n {$DEFINE SYN_COMPILER_3_UP}\r\n {$DEFINE SYN_COMPILER_4_UP}\r\n {$DEFINE SYN_COMPILER_5_UP}\r\n {$DEFINE SYN_COMPILER_6_UP}\r\n{$ENDIF}\r\n\r\n{$IFDEF SYN_COMPILER_7}\r\n {$DEFINE SYN_COMPILER_1_UP}\r\n {$DEFINE SYN_COMPILER_2_UP}\r\n {$DEFINE SYN_COMPILER_3_UP}\r\n {$DEFINE SYN_COMPILER_4_UP}\r\n {$DEFINE SYN_COMPILER_5_UP}\r\n {$DEFINE SYN_COMPILER_6_UP}\r\n {$DEFINE SYN_COMPILER_7_UP}\r\n{$ENDIF}\r\n\r\n{$IFDEF SYN_COMPILER_8}\r\n {$DEFINE SYN_COMPILER_1_UP}\r\n {$DEFINE SYN_COMPILER_2_UP}\r\n {$DEFINE SYN_COMPILER_3_UP}\r\n {$DEFINE SYN_COMPILER_4_UP}\r\n {$DEFINE SYN_COMPILER_5_UP}\r\n {$DEFINE SYN_COMPILER_6_UP}\r\n {$DEFINE SYN_COMPILER_7_UP}\r\n {$DEFINE SYN_COMPILER_8_UP}\r\n{$ENDIF}\r\n\r\n{$IFDEF SYN_COMPILER_9}\r\n {$DEFINE SYN_COMPILER_1_UP}\r\n {$DEFINE SYN_COMPILER_2_UP}\r\n {$DEFINE SYN_COMPILER_3_UP}\r\n {$DEFINE SYN_COMPILER_4_UP}\r\n {$DEFINE SYN_COMPILER_5_UP}\r\n {$DEFINE SYN_COMPILER_6_UP}\r\n {$DEFINE SYN_COMPILER_7_UP}\r\n {$DEFINE SYN_COMPILER_8_UP}\r\n {$DEFINE SYN_COMPILER_9_UP}\r\n{$ENDIF}\r\n\r\n{$IFDEF SYN_COMPILER_10}\r\n {$DEFINE SYN_COMPILER_1_UP}\r\n {$DEFINE SYN_COMPILER_2_UP}\r\n {$DEFINE SYN_COMPILER_3_UP}\r\n {$DEFINE SYN_COMPILER_4_UP}\r\n {$DEFINE SYN_COMPILER_5_UP}\r\n {$DEFINE SYN_COMPILER_6_UP}\r\n {$DEFINE SYN_COMPILER_7_UP}\r\n {$DEFINE SYN_COMPILER_8_UP}\r\n {$DEFINE SYN_COMPILER_9_UP}\r\n {$DEFINE SYN_COMPILER_10_UP}\r\n{$ENDIF}\r\n\r\n{$IFDEF SYN_COMPILER_11}\r\n {$DEFINE SYN_COMPILER_1_UP}\r\n {$DEFINE SYN_COMPILER_2_UP}\r\n {$DEFINE SYN_COMPILER_3_UP}\r\n {$DEFINE SYN_COMPILER_4_UP}\r\n {$DEFINE SYN_COMPILER_5_UP}\r\n {$DEFINE SYN_COMPILER_6_UP}\r\n {$DEFINE SYN_COMPILER_7_UP}\r\n {$DEFINE SYN_COMPILER_8_UP}\r\n {$DEFINE SYN_COMPILER_9_UP}\r\n {$DEFINE SYN_COMPILER_10_UP}\r\n {$DEFINE SYN_COMPILER_11_UP}\r\n{$ENDIF}\r\n\r\n{$IFDEF SYN_COMPILER_12}\r\n {$DEFINE SYN_COMPILER_1_UP}\r\n {$DEFINE SYN_COMPILER_2_UP}\r\n {$DEFINE SYN_COMPILER_3_UP}\r\n {$DEFINE SYN_COMPILER_4_UP}\r\n {$DEFINE SYN_COMPILER_5_UP}\r\n {$DEFINE SYN_COMPILER_6_UP}\r\n {$DEFINE SYN_COMPILER_7_UP}\r\n {$DEFINE SYN_COMPILER_8_UP}\r\n {$DEFINE SYN_COMPILER_9_UP}\r\n {$DEFINE SYN_COMPILER_10_UP}\r\n {$DEFINE SYN_COMPILER_11_UP}\r\n {$DEFINE SYN_COMPILER_12_UP}\r\n{$ENDIF}\r\n\r\n{$IFDEF SYN_COMPILER_14}\r\n {$DEFINE SYN_COMPILER_1_UP}\r\n {$DEFINE SYN_COMPILER_2_UP}\r\n {$DEFINE SYN_COMPILER_3_UP}\r\n {$DEFINE SYN_COMPILER_4_UP}\r\n {$DEFINE SYN_COMPILER_5_UP}\r\n {$DEFINE SYN_COMPILER_6_UP}\r\n {$DEFINE SYN_COMPILER_7_UP}\r\n {$DEFINE SYN_COMPILER_8_UP}\r\n {$DEFINE SYN_COMPILER_9_UP}\r\n {$DEFINE SYN_COMPILER_10_UP}\r\n {$DEFINE SYN_COMPILER_11_UP}\r\n {$DEFINE SYN_COMPILER_12_UP}\r\n {$DEFINE SYN_COMPILER_14_UP}\r\n{$ENDIF}\r\n\r\n{$IFDEF SYN_COMPILER_15}\r\n {$DEFINE SYN_COMPILER_1_UP}\r\n {$DEFINE SYN_COMPILER_2_UP}\r\n {$DEFINE SYN_COMPILER_3_UP}\r\n {$DEFINE SYN_COMPILER_4_UP}\r\n {$DEFINE SYN_COMPILER_5_UP}\r\n {$DEFINE SYN_COMPILER_6_UP}\r\n {$DEFINE SYN_COMPILER_7_UP}\r\n {$DEFINE SYN_COMPILER_8_UP}\r\n {$DEFINE SYN_COMPILER_9_UP}\r\n {$DEFINE SYN_COMPILER_10_UP}\r\n {$DEFINE SYN_COMPILER_11_UP}\r\n {$DEFINE SYN_COMPILER_12_UP}\r\n {$DEFINE SYN_COMPILER_14_UP}\r\n {$DEFINE SYN_COMPILER_15_UP}\r\n{$ENDIF}\r\n\r\n{$IFDEF SYN_COMPILER_16}\r\n {$DEFINE SYN_COMPILER_1_UP}\r\n {$DEFINE SYN_COMPILER_2_UP}\r\n {$DEFINE SYN_COMPILER_3_UP}\r\n {$DEFINE SYN_COMPILER_4_UP}\r\n {$DEFINE SYN_COMPILER_5_UP}\r\n {$DEFINE SYN_COMPILER_6_UP}\r\n {$DEFINE SYN_COMPILER_7_UP}\r\n {$DEFINE SYN_COMPILER_8_UP}\r\n {$DEFINE SYN_COMPILER_9_UP}\r\n {$DEFINE SYN_COMPILER_10_UP}\r\n {$DEFINE SYN_COMPILER_11_UP}\r\n {$DEFINE SYN_COMPILER_12_UP}\r\n {$DEFINE SYN_COMPILER_14_UP}\r\n {$DEFINE SYN_COMPILER_15_UP}\r\n {$DEFINE SYN_COMPILER_16_UP}\r\n{$ENDIF}\r\n\r\n{$IFDEF SYN_COMPILER_17}\r\n {$DEFINE SYN_COMPILER_1_UP}\r\n {$DEFINE SYN_COMPILER_2_UP}\r\n {$DEFINE SYN_COMPILER_3_UP}\r\n {$DEFINE SYN_COMPILER_4_UP}\r\n {$DEFINE SYN_COMPILER_5_UP}\r\n {$DEFINE SYN_COMPILER_6_UP}\r\n {$DEFINE SYN_COMPILER_7_UP}\r\n {$DEFINE SYN_COMPILER_8_UP}\r\n {$DEFINE SYN_COMPILER_9_UP}\r\n {$DEFINE SYN_COMPILER_10_UP}\r\n {$DEFINE SYN_COMPILER_11_UP}\r\n {$DEFINE SYN_COMPILER_12_UP}\r\n {$DEFINE SYN_COMPILER_14_UP}\r\n {$DEFINE SYN_COMPILER_15_UP}\r\n {$DEFINE SYN_COMPILER_16_UP}\r\n {$DEFINE SYN_COMPILER_17_UP}\r\n{$ENDIF}\r\n\r\n{$IFDEF SYN_COMPILER_18}\r\n {$DEFINE SYN_COMPILER_1_UP}\r\n {$DEFINE SYN_COMPILER_2_UP}\r\n {$DEFINE SYN_COMPILER_3_UP}\r\n {$DEFINE SYN_COMPILER_4_UP}\r\n {$DEFINE SYN_COMPILER_5_UP}\r\n {$DEFINE SYN_COMPILER_6_UP}\r\n {$DEFINE SYN_COMPILER_7_UP}\r\n {$DEFINE SYN_COMPILER_8_UP}\r\n {$DEFINE SYN_COMPILER_9_UP}\r\n {$DEFINE SYN_COMPILER_10_UP}\r\n {$DEFINE SYN_COMPILER_11_UP}\r\n {$DEFINE SYN_COMPILER_12_UP}\r\n {$DEFINE SYN_COMPILER_14_UP}\r\n {$DEFINE SYN_COMPILER_15_UP}\r\n {$DEFINE SYN_COMPILER_16_UP}\r\n {$DEFINE SYN_COMPILER_17_UP}\r\n {$DEFINE SYN_COMPILER_18_UP}\r\n{$ENDIF}\r\n\r\n{$IFDEF SYN_COMPILER_19}\r\n {$DEFINE SYN_COMPILER_1_UP}\r\n {$DEFINE SYN_COMPILER_2_UP}\r\n {$DEFINE SYN_COMPILER_3_UP}\r\n {$DEFINE SYN_COMPILER_4_UP}\r\n {$DEFINE SYN_COMPILER_5_UP}\r\n {$DEFINE SYN_COMPILER_6_UP}\r\n {$DEFINE SYN_COMPILER_7_UP}\r\n {$DEFINE SYN_COMPILER_8_UP}\r\n {$DEFINE SYN_COMPILER_9_UP}\r\n {$DEFINE SYN_COMPILER_10_UP}\r\n {$DEFINE SYN_COMPILER_11_UP}\r\n {$DEFINE SYN_COMPILER_12_UP}\r\n {$DEFINE SYN_COMPILER_14_UP}\r\n {$DEFINE SYN_COMPILER_15_UP}\r\n {$DEFINE SYN_COMPILER_16_UP}\r\n {$DEFINE SYN_COMPILER_17_UP}\r\n {$DEFINE SYN_COMPILER_18_UP}\r\n {$DEFINE SYN_COMPILER_19_UP}\r\n{$ENDIF}\r\n\r\n{$IFDEF SYN_DELPHI_2}\r\n {$DEFINE SYN_DELPHI_2_UP}\r\n{$ENDIF}\r\n\r\n{$IFDEF SYN_DELPHI_3}\r\n {$DEFINE SYN_DELPHI_2_UP}\r\n {$DEFINE SYN_DELPHI_3_UP}\r\n{$ENDIF}\r\n\r\n{$IFDEF SYN_DELPHI_4}\r\n {$DEFINE SYN_DELPHI_2_UP}\r\n {$DEFINE SYN_DELPHI_3_UP}\r\n {$DEFINE SYN_DELPHI_4_UP}\r\n{$ENDIF}\r\n\r\n{$IFDEF SYN_DELPHI_5}\r\n {$DEFINE SYN_DELPHI_2_UP}\r\n {$DEFINE SYN_DELPHI_3_UP}\r\n {$DEFINE SYN_DELPHI_4_UP}\r\n {$DEFINE SYN_DELPHI_5_UP}\r\n{$ENDIF}\r\n\r\n{$IFDEF SYN_DELPHI_6}\r\n {$DEFINE SYN_DELPHI_2_UP}\r\n {$DEFINE SYN_DELPHI_3_UP}\r\n {$DEFINE SYN_DELPHI_4_UP}\r\n {$DEFINE SYN_DELPHI_5_UP}\r\n {$DEFINE SYN_DELPHI_6_UP}\r\n{$ENDIF}\r\n\r\n{$IFDEF SYN_DELPHI_7}\r\n {$DEFINE SYN_DELPHI_2_UP}\r\n {$DEFINE SYN_DELPHI_3_UP}\r\n {$DEFINE SYN_DELPHI_4_UP}\r\n {$DEFINE SYN_DELPHI_5_UP}\r\n {$DEFINE SYN_DELPHI_6_UP}\r\n {$DEFINE SYN_DELPHI_7_UP}\r\n{$ENDIF}\r\n\r\n{$IFDEF SYN_DELPHI_8}\r\n {$DEFINE SYN_DELPHI_2_UP}\r\n {$DEFINE SYN_DELPHI_3_UP}\r\n {$DEFINE SYN_DELPHI_4_UP}\r\n {$DEFINE SYN_DELPHI_5_UP}\r\n {$DEFINE SYN_DELPHI_6_UP}\r\n {$DEFINE SYN_DELPHI_7_UP}\r\n {$DEFINE SYN_DELPHI_8_UP}\r\n{$ENDIF}\r\n\r\n{$IFDEF SYN_DELPHI_2005}\r\n {$DEFINE SYN_DELPHI_2_UP}\r\n {$DEFINE SYN_DELPHI_3_UP}\r\n {$DEFINE SYN_DELPHI_4_UP}\r\n {$DEFINE SYN_DELPHI_5_UP}\r\n {$DEFINE SYN_DELPHI_6_UP}\r\n {$DEFINE SYN_DELPHI_7_UP}\r\n {$DEFINE SYN_DELPHI_8_UP}\r\n {$DEFINE SYN_DELPHI_2005_UP}\r\n{$ENDIF}\r\n\r\n{$IFDEF SYN_DELPHI_2006}\r\n {$DEFINE SYN_DELPHI_2_UP}\r\n {$DEFINE SYN_DELPHI_3_UP}\r\n {$DEFINE SYN_DELPHI_4_UP}\r\n {$DEFINE SYN_DELPHI_5_UP}\r\n {$DEFINE SYN_DELPHI_6_UP}\r\n {$DEFINE SYN_DELPHI_7_UP}\r\n {$DEFINE SYN_DELPHI_8_UP}\r\n {$DEFINE SYN_DELPHI_2005_UP}\r\n {$DEFINE SYN_DELPHI_2006_UP}\r\n{$ENDIF}\r\n\r\n{$IFDEF SYN_DELPHI_2007}\r\n {$DEFINE SYN_DELPHI_2_UP}\r\n {$DEFINE SYN_DELPHI_3_UP}\r\n {$DEFINE SYN_DELPHI_4_UP}\r\n {$DEFINE SYN_DELPHI_5_UP}\r\n {$DEFINE SYN_DELPHI_6_UP}\r\n {$DEFINE SYN_DELPHI_7_UP}\r\n {$DEFINE SYN_DELPHI_8_UP}\r\n {$DEFINE SYN_DELPHI_2005_UP}\r\n {$DEFINE SYN_DELPHI_2006_UP}\r\n {$DEFINE SYN_DELPHI_2007_UP}\r\n{$ENDIF}\r\n\r\n{$IFDEF SYN_DELPHI_2009}\r\n {$DEFINE SYN_DELPHI_2_UP}\r\n {$DEFINE SYN_DELPHI_3_UP}\r\n {$DEFINE SYN_DELPHI_4_UP}\r\n {$DEFINE SYN_DELPHI_5_UP}\r\n {$DEFINE SYN_DELPHI_6_UP}\r\n {$DEFINE SYN_DELPHI_7_UP}\r\n {$DEFINE SYN_DELPHI_8_UP}\r\n {$DEFINE SYN_DELPHI_2005_UP}\r\n {$DEFINE SYN_DELPHI_2006_UP}\r\n {$DEFINE SYN_DELPHI_2007_UP}\r\n {$DEFINE SYN_DELPHI_2009_UP}\r\n{$ENDIF}\r\n\r\n{$IFDEF SYN_DELPHI_2010}\r\n {$DEFINE SYN_DELPHI_2_UP}\r\n {$DEFINE SYN_DELPHI_3_UP}\r\n {$DEFINE SYN_DELPHI_4_UP}\r\n {$DEFINE SYN_DELPHI_5_UP}\r\n {$DEFINE SYN_DELPHI_6_UP}\r\n {$DEFINE SYN_DELPHI_7_UP}\r\n {$DEFINE SYN_DELPHI_8_UP}\r\n {$DEFINE SYN_DELPHI_2005_UP}\r\n {$DEFINE SYN_DELPHI_2006_UP}\r\n {$DEFINE SYN_DELPHI_2007_UP}\r\n {$DEFINE SYN_DELPHI_2009_UP}\r\n {$DEFINE SYN_DELPHI_2010_UP}\r\n{$ENDIF}\r\n\r\n{$IFDEF SYN_DELPHI_XE}\r\n {$DEFINE SYN_DELPHI_2_UP}\r\n {$DEFINE SYN_DELPHI_3_UP}\r\n {$DEFINE SYN_DELPHI_4_UP}\r\n {$DEFINE SYN_DELPHI_5_UP}\r\n {$DEFINE SYN_DELPHI_6_UP}\r\n {$DEFINE SYN_DELPHI_7_UP}\r\n {$DEFINE SYN_DELPHI_8_UP}\r\n {$DEFINE SYN_DELPHI_2005_UP}\r\n {$DEFINE SYN_DELPHI_2006_UP}\r\n {$DEFINE SYN_DELPHI_2007_UP}\r\n {$DEFINE SYN_DELPHI_2009_UP}\r\n {$DEFINE SYN_DELPHI_2010_UP}\r\n {$DEFINE SYN_DELPHI_XE_UP}\r\n{$ENDIF}\r\n\r\n{$IFDEF SYN_DELPHI_XE2}\r\n {$DEFINE SYN_DELPHI_2_UP}\r\n {$DEFINE SYN_DELPHI_3_UP}\r\n {$DEFINE SYN_DELPHI_4_UP}\r\n {$DEFINE SYN_DELPHI_5_UP}\r\n {$DEFINE SYN_DELPHI_6_UP}\r\n {$DEFINE SYN_DELPHI_7_UP}\r\n {$DEFINE SYN_DELPHI_8_UP}\r\n {$DEFINE SYN_DELPHI_2005_UP}\r\n {$DEFINE SYN_DELPHI_2006_UP}\r\n {$DEFINE SYN_DELPHI_2007_UP}\r\n {$DEFINE SYN_DELPHI_2009_UP}\r\n {$DEFINE SYN_DELPHI_2010_UP}\r\n {$DEFINE SYN_DELPHI_XE_UP}\r\n {$DEFINE SYN_DELPHI_XE2_UP}\r\n{$ENDIF}\r\n\r\n{$IFDEF SYN_DELPHI_XE3}\r\n {$DEFINE SYN_DELPHI_2_UP}\r\n {$DEFINE SYN_DELPHI_3_UP}\r\n {$DEFINE SYN_DELPHI_4_UP}\r\n {$DEFINE SYN_DELPHI_5_UP}\r\n {$DEFINE SYN_DELPHI_6_UP}\r\n {$DEFINE SYN_DELPHI_7_UP}\r\n {$DEFINE SYN_DELPHI_8_UP}\r\n {$DEFINE SYN_DELPHI_2005_UP}\r\n {$DEFINE SYN_DELPHI_2006_UP}\r\n {$DEFINE SYN_DELPHI_2007_UP}\r\n {$DEFINE SYN_DELPHI_2009_UP}\r\n {$DEFINE SYN_DELPHI_2010_UP}\r\n {$DEFINE SYN_DELPHI_XE_UP}\r\n {$DEFINE SYN_DELPHI_XE2_UP}\r\n {$DEFINE SYN_DELPHI_XE3_UP}\r\n{$ENDIF}\r\n\r\n{$IFDEF SYN_DELPHI_XE4}\r\n {$DEFINE SYN_DELPHI_2_UP}\r\n {$DEFINE SYN_DELPHI_3_UP}\r\n {$DEFINE SYN_DELPHI_4_UP}\r\n {$DEFINE SYN_DELPHI_5_UP}\r\n {$DEFINE SYN_DELPHI_6_UP}\r\n {$DEFINE SYN_DELPHI_7_UP}\r\n {$DEFINE SYN_DELPHI_8_UP}\r\n {$DEFINE SYN_DELPHI_2005_UP}\r\n {$DEFINE SYN_DELPHI_2006_UP}\r\n {$DEFINE SYN_DELPHI_2007_UP}\r\n {$DEFINE SYN_DELPHI_2009_UP}\r\n {$DEFINE SYN_DELPHI_2010_UP}\r\n {$DEFINE SYN_DELPHI_XE_UP}\r\n {$DEFINE SYN_DELPHI_XE2_UP}\r\n {$DEFINE SYN_DELPHI_XE3_UP}\r\n {$DEFINE SYN_DELPHI_XE4_UP}\r\n{$ENDIF}\r\n\r\n{$IFDEF SYN_DELPHI_XE5}\r\n {$DEFINE SYN_DELPHI_2_UP}\r\n {$DEFINE SYN_DELPHI_3_UP}\r\n {$DEFINE SYN_DELPHI_4_UP}\r\n {$DEFINE SYN_DELPHI_5_UP}\r\n {$DEFINE SYN_DELPHI_6_UP}\r\n {$DEFINE SYN_DELPHI_7_UP}\r\n {$DEFINE SYN_DELPHI_8_UP}\r\n {$DEFINE SYN_DELPHI_2005_UP}\r\n {$DEFINE SYN_DELPHI_2006_UP}\r\n {$DEFINE SYN_DELPHI_2007_UP}\r\n {$DEFINE SYN_DELPHI_2009_UP}\r\n {$DEFINE SYN_DELPHI_2010_UP}\r\n {$DEFINE SYN_DELPHI_XE_UP}\r\n {$DEFINE SYN_DELPHI_XE2_UP}\r\n {$DEFINE SYN_DELPHI_XE3_UP}\r\n {$DEFINE SYN_DELPHI_XE4_UP}\r\n {$DEFINE SYN_DELPHI_XE5_UP}\r\n{$ENDIF}\r\n\r\n{$IFDEF SYN_CPPB_6}\r\n {$DEFINE SYN_CPPB_3_UP}\r\n {$DEFINE SYN_CPPB_4_UP}\r\n {$DEFINE SYN_CPPB_5_UP}\r\n {$DEFINE SYN_CPPB_6_UP}\r\n{$ENDIF}\r\n\r\n{$IFDEF SYN_CPPB_3}\r\n {$DEFINE SYN_CPPB_3_UP}\r\n{$ENDIF}\r\n\r\n{$IFDEF SYN_COMPILER_3_UP}\r\n {$DEFINE SYN_NO_COM_CLEANUP}\r\n{$ENDIF}\r\n\r\n{$IFDEF SYN_CPPB_3_UP}\r\n // C++Builder requires this if you use Delphi components in run-time packages.\r\n {$ObjExportAll On}\r\n{$ENDIF}\r\n\r\n{$IFDEF SYN_KYLIX}\r\n // A Kylix application is always a CLX application\r\n {$DEFINE SYN_CLX}\r\n\r\n {$IF not Declared(CompilerVersion)}\r\n {$DEFINE SYN_KYLIX_1}\r\n {$ELSEIF Declared(CompilerVersion) and (CompilerVersion > +14)}\r\n {$DEFINE SYN_KYLIX_2}\r\n {$ELSEIF Declared(CompilerVersion) and (CompilerVersion < +15)}\r\n {$DEFINE SYN_KYLIX_3}\r\n {$ELSEIF True}\r\n Add new Kylix version\r\n {$IFEND}\r\n{$ELSE}\r\n {$DEFINE SYN_WIN32}\r\n{$ENDIF}\r\n\r\n{------------------------------------------------------------------------------}\r\n{ Please change this to suit your needs (to activate an option remove the dot }\r\n{ in front of a DEFINE) }\r\n{------------------------------------------------------------------------------}\r\n\r\n// \"Heredoc\" syntax highlighting\r\n// If you enable the following statement and use highlighter(s) that have\r\n// support for \"Heredoc\" strings as scheme(s) in SynMultiSyn, you must\r\n// implement your own SynMultiSyn OnCustomRange event handler in order to\r\n// properly store Range State information\r\n{.$DEFINE SYN_HEREDOC}\r\n\r\n// Define OWN_UnicodeString_MEMMGR to speed up WideStrings-handling\r\n{$IFDEF SYN_WIN32}\r\n {$IFNDEF UNICODE}\r\n {$DEFINE OWN_UnicodeString_MEMMGR}\r\n {$ENDIF}\r\n{$ENDIF}\r\n\r\n// Turn this off if you don't need complex script support, since it is slower\r\n{.$DEFINE SYN_UNISCRIBE}\r\n\r\n// $Id: SynEdit.inc,v 1.16.2.19 2009/06/14 13:41:44 maelh Exp $\r\n" }, { "path": "External/SynEdit/Source/SynEdit.pas", "content": "{-------------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: SynEdit.pas, released 2000-04-07.\r\nThe Original Code is based on mwCustomEdit.pas by Martin Waldenburg, part of\r\nthe mwEdit component suite.\r\nPortions created by Martin Waldenburg are Copyright (C) 1998 Martin Waldenburg.\r\nUnicode translation by Mal Hrz.\r\nAll Rights Reserved.\r\n\r\nContributors to the SynEdit and mwEdit projects are listed in the\r\nContributors.txt file.\r\n\r\nAlternatively, the contents of this file may be used under the terms of the\r\nGNU General Public License Version 2 or later (the \"GPL\"), in which case\r\nthe provisions of the GPL are applicable instead of those above.\r\nIf you wish to allow use of your version of this file only under the terms\r\nof the GPL and not to allow others to use your version of this file\r\nunder the MPL, indicate your decision by deleting the provisions above and\r\nreplace them with the notice and other provisions required by the GPL.\r\nIf you do not delete the provisions above, a recipient may use your version\r\nof this file under either the MPL or the GPL.\r\n\r\n$Id: SynEdit.pas,v 1.32.1 2012/19/09 10:50:00 CodehunterWorks Exp $\r\n\r\nYou may retrieve the latest version of this file at the SynEdit home page,\r\nlocated at http://SynEdit.SourceForge.net\r\n\r\nKnown Issues:\r\n- Undo is buggy when dealing with Hard Tabs (when inserting text after EOL and\r\n when trimming).\r\n\r\n-------------------------------------------------------------------------------}\r\n//todo: remove SynEdit Clipboard Format?\r\n//todo: in WordWrap mode, parse lines only once in PaintLines()\r\n//todo: Remove checks for WordWrap. Must abstract the behaviour with the plugins instead.\r\n//todo: Move WordWrap glyph to the WordWrap plugin.\r\n//todo: remove fShowSpecChar variable\r\n//todo: remove the several Undo block types?\r\n\r\n{$IFNDEF QSYNEDIT}\r\nunit SynEdit;\r\n{$ENDIF}\r\n\r\n{$I SynEdit.inc}\r\n\r\ninterface\r\n\r\nuses\r\n{$IFDEF SYN_CLX}\r\n {$IFDEF SYN_LINUX}\r\n Xlib,\r\n {$ENDIF}\r\n Qt,\r\n Types,\r\n QControls,\r\n QGraphics,\r\n QForms,\r\n QStdCtrls,\r\n QExtCtrls,\r\n QSynUnicode,\r\n{$ELSE}\r\n Controls,\r\n Contnrs,\r\n Graphics,\r\n Forms,\r\n StdCtrls,\r\n ExtCtrls,\r\n Windows,\r\n Messages,\r\n {$IFDEF SYN_COMPILER_4_UP}\r\n StdActns,\r\n Dialogs,\r\n {$ENDIF}\r\n {$IFDEF SYN_COMPILER_7}\r\n Themes,\r\n {$ENDIF}\r\n {$IFDEF SYN_COMPILER_17_UP}\r\n UITypes,\r\n {$ENDIF}\r\n SynUnicode,\r\n{$ENDIF}\r\n{$IFDEF SYN_CLX}\r\n kTextDrawer,\r\n QSynEditTypes,\r\n QSynEditKeyConst,\r\n QSynEditMiscProcs,\r\n QSynEditMiscClasses,\r\n QSynEditTextBuffer,\r\n QSynEditKeyCmds,\r\n QSynEditHighlighter,\r\n QSynEditKbdHandler,\r\n{$ELSE}\r\n Imm,\r\n SynTextDrawer,\r\n SynEditTypes,\r\n SynEditKeyConst,\r\n SynEditMiscProcs,\r\n SynEditMiscClasses,\r\n SynEditTextBuffer,\r\n SynEditKeyCmds,\r\n SynEditHighlighter,\r\n SynEditKbdHandler,\r\n{$ENDIF}\r\n{$IFDEF UNICODE}\r\n WideStrUtils,\r\n{$ENDIF}\r\n Math,\r\n SysUtils,\r\n Classes;\r\n\r\nconst\r\n{$IFNDEF SYN_COMPILER_3_UP}\r\n // not defined in all Delphi versions\r\n WM_MOUSEWHEEL = $020A;\r\n{$ENDIF}\r\n\r\n // maximum scroll range\r\n MAX_SCROLL = 32767;\r\n\r\n // Max number of book/gutter marks returned from GetEditMarksForLine - that\r\n // really should be enough.\r\n MAX_MARKS = 16;\r\n\r\n SYNEDIT_CLIPBOARD_FORMAT = 'SynEdit Control Block Type';\r\n\r\nvar\r\n SynEditClipboardFormat: UINT;\r\n\r\ntype\r\n\tTBufferCoord = SynEditTypes.TBufferCoord;\r\n\tTDisplayCoord = SynEditTypes.TDisplayCoord;\r\n\r\n{$IFDEF SYN_CLX}\r\n TSynBorderStyle = bsNone..bsSingle;\r\n{$ELSE}\r\n TSynBorderStyle = TBorderStyle;\r\n{$ENDIF}\r\n\r\n TSynReplaceAction = (raCancel, raSkip, raReplace, raReplaceAll);\r\n\r\n ESynEditError = class(ESynError);\r\n\r\n TDropFilesEvent = procedure(Sender: TObject; X, Y: Integer; AFiles: TUnicodeStrings)\r\n of object;\r\n\r\n THookedCommandEvent = procedure(Sender: TObject; AfterProcessing: Boolean;\r\n var Handled: Boolean; var Command: TSynEditorCommand; var AChar: WideChar;\r\n Data: pointer; HandlerData: pointer) of object;\r\n\r\n TPaintEvent = procedure(Sender: TObject; ACanvas: TCanvas) of object;\r\n\r\n TProcessCommandEvent = procedure(Sender: TObject;\r\n var Command: TSynEditorCommand; var AChar: WideChar; Data: pointer) of object;\r\n\r\n TReplaceTextEvent = procedure(Sender: TObject; const ASearch, AReplace:\r\n UnicodeString; Line, Column: Integer; var Action: TSynReplaceAction) of object;\r\n\r\n TSpecialLineColorsEvent = procedure(Sender: TObject; Line: Integer;\r\n var Special: Boolean; var FG, BG: TColor) of object;\r\n\r\n TTransientType = (ttBefore, ttAfter);\r\n TPaintTransient = procedure(Sender: TObject; Canvas: TCanvas;\r\n TransientType: TTransientType) of object;\r\n\r\n TScrollEvent = procedure(Sender: TObject; ScrollBar: TScrollBarKind) of object;\r\n\r\n TGutterGetTextEvent = procedure(Sender: TObject; aLine: Integer;\r\n var aText: UnicodeString) of object;\r\n\r\n TGutterPaintEvent = procedure(Sender: TObject; aLine: Integer;\r\n X, Y: Integer) of object;\r\n\r\n TSynEditCaretType = (ctVerticalLine, ctHorizontalLine, ctHalfBlock, ctBlock);\r\n\r\n TSynStateFlag = (sfCaretChanged, sfScrollbarChanged, sfLinesChanging,\r\n sfIgnoreNextChar, sfCaretVisible, sfDblClicked, sfPossibleGutterClick,\r\n sfWaitForDragging, sfInsideRedo, sfGutterDragging);\r\n\r\n TSynStateFlags = set of TSynStateFlag;\r\n\r\n TScrollHintFormat = (shfTopLineOnly, shfTopToBottom);\r\n\r\n TSynEditorOption = (\r\n eoAltSetsColumnMode, //Holding down the Alt Key will put the selection mode into columnar format\r\n eoAutoIndent, //Will indent the caret on new lines with the same amount of leading white space as the preceding line\r\n eoAutoSizeMaxScrollWidth, //Automatically resizes the MaxScrollWidth property when inserting text\r\n eoDisableScrollArrows, //Disables the scroll bar arrow buttons when you can't scroll in that direction any more\r\n eoDragDropEditing, //Allows you to select a block of text and drag it within the document to another location\r\n eoDropFiles, //Allows the editor accept OLE file drops\r\n eoEnhanceHomeKey, //enhances home key positioning, similar to visual studio\r\n eoEnhanceEndKey, //enhances End key positioning, similar to JDeveloper\r\n eoGroupUndo, //When undoing/redoing actions, handle all continous changes of the same kind in one call instead undoing/redoing each command separately\r\n eoHalfPageScroll, //When scrolling with page-up and page-down commands, only scroll a half page at a time\r\n eoHideShowScrollbars, //if enabled, then the scrollbars will only show when necessary. If you have ScrollPastEOL, then it the horizontal bar will always be there (it uses MaxLength instead)\r\n eoKeepCaretX, //When moving through lines w/o Cursor Past EOL, keeps the X position of the cursor\r\n eoNoCaret, //Makes it so the caret is never visible\r\n eoNoSelection, //Disables selecting text\r\n eoRightMouseMovesCursor, //When clicking with the right mouse for a popup menu, move the cursor to that location\r\n eoScrollByOneLess, //Forces scrolling to be one less\r\n eoScrollHintFollows, //The scroll hint follows the mouse when scrolling vertically\r\n eoScrollPastEof, //Allows the cursor to go past the end of file marker\r\n eoScrollPastEol, //Allows the cursor to go past the last character into the white space at the end of a line\r\n eoShowScrollHint, //Shows a hint of the visible line numbers when scrolling vertically\r\n eoShowSpecialChars, //Shows the special Characters\r\n eoSmartTabDelete, //similar to Smart Tabs, but when you delete characters\r\n eoSmartTabs, //When tabbing, the cursor will go to the next non-white space character of the previous line\r\n eoSpecialLineDefaultFg, //disables the foreground text color override when using the OnSpecialLineColor event\r\n eoTabIndent, //When active and act as block indent, unindent when text is selected\r\n eoTabsToSpaces, //Converts a tab character to a specified number of space characters\r\n eoTrimTrailingSpaces //Spaces at the end of lines will be trimmed and not saved\r\n );\r\n\r\n TSynEditorOptions = set of TSynEditorOption;\r\n\r\n TSynFontSmoothMethod = (fsmNone, fsmAntiAlias, fsmClearType);\r\n\r\nconst\r\n SYNEDIT_DEFAULT_OPTIONS = [eoAutoIndent, eoDragDropEditing, eoEnhanceEndKey,\r\n eoScrollPastEol, eoShowScrollHint, eoSmartTabs, eoTabsToSpaces,\r\n eoSmartTabDelete, eoGroupUndo];\r\n\r\n{$IFNDEF SYN_CLX}\r\ntype\r\n TCreateParamsW = record\r\n Caption: PWideChar;\r\n Style: DWORD;\r\n ExStyle: DWORD;\r\n X, Y: Integer;\r\n Width, Height: Integer;\r\n WndParent: HWnd;\r\n Param: Pointer;\r\n WindowClass: TWndClassW;\r\n WinClassName: array[0..63] of WideChar;\r\n InternalCaption: UnicodeString;\r\n end;\r\n{$ENDIF}\r\n\r\ntype\r\n// use scAll to update a statusbar when another TCustomSynEdit got the focus\r\n TSynStatusChange = (scAll, scCaretX, scCaretY, scLeftChar, scTopLine,\r\n scInsertMode, scModified, scSelection, scReadOnly);\r\n TSynStatusChanges = set of TSynStatusChange;\r\n\r\n TContextHelpEvent = procedure(Sender: TObject; word: UnicodeString)\r\n of object;\r\n\r\n TStatusChangeEvent = procedure(Sender: TObject; Changes: TSynStatusChanges)\r\n of object;\r\n\r\n TMouseCursorEvent = procedure(Sender: TObject; const aLineCharPos: TBufferCoord;\r\n var aCursor: TCursor) of object;\r\n\r\n TCustomSynEdit = class;\r\n\r\n TSynEditMark = class\r\n protected\r\n fLine, fChar, fImage: Integer;\r\n fEdit: TCustomSynEdit;\r\n fVisible: Boolean;\r\n fInternalImage: Boolean;\r\n fBookmarkNum: Integer;\r\n function GetEdit: TCustomSynEdit; virtual;\r\n procedure SetChar(const Value: Integer); virtual;\r\n procedure SetImage(const Value: Integer); virtual;\r\n procedure SetLine(const Value: Integer); virtual;\r\n procedure SetVisible(const Value: Boolean);\r\n procedure SetInternalImage(const Value: Boolean);\r\n function GetIsBookmark: Boolean;\r\n public\r\n constructor Create(AOwner: TCustomSynEdit);\r\n property Line: Integer read fLine write SetLine;\r\n property Char: Integer read fChar write SetChar;\r\n property Edit: TCustomSynEdit read fEdit;\r\n property ImageIndex: Integer read fImage write SetImage;\r\n property BookmarkNumber: Integer read fBookmarkNum write fBookmarkNum;\r\n property Visible: Boolean read fVisible write SetVisible;\r\n property InternalImage: Boolean read fInternalImage write SetInternalImage;\r\n property IsBookmark: Boolean read GetIsBookmark;\r\n end;\r\n\r\n TPlaceMarkEvent = procedure(Sender: TObject; var Mark: TSynEditMark)\r\n of object;\r\n\r\n TSynEditMarks = array[1..MAX_MARKS] of TSynEditMark;\r\n\r\n { A list of mark objects. Each object cause a litle picture to be drawn in the gutter. }\r\n TSynEditMarkList = class(TObjectList) // It makes more sence to derive from TObjectList,\r\n protected // as it automatically frees its members\r\n fEdit: TCustomSynEdit;\r\n fOnChange: TNotifyEvent;\r\n procedure Notify(Ptr: Pointer; Action: TListNotification); override;\r\n function GetItem(Index: Integer): TSynEditMark;\r\n procedure SetItem(Index: Integer; Item: TSynEditMark);\r\n property OwnsObjects; // This is to hide the inherited property,\r\n public // because TSynEditMarkList always owns the marks\r\n constructor Create(AOwner: TCustomSynEdit);\r\n function First: TSynEditMark;\r\n function Last: TSynEditMark;\r\n function Extract(Item: TSynEditMark): TSynEditMark;\r\n procedure ClearLine(line: Integer);\r\n procedure GetMarksForLine(line: Integer; var Marks: TSynEditMarks);\r\n procedure Place(mark: TSynEditMark);\r\n public\r\n property Items[Index: Integer]: TSynEditMark read GetItem write SetItem; default;\r\n property Edit: TCustomSynEdit read fEdit;\r\n property OnChange: TNotifyEvent read FOnChange write FOnChange;\r\n end;\r\n\r\n TGutterClickEvent = procedure(Sender: TObject; Button: TMouseButton;\r\n X, Y, Line: Integer; Mark: TSynEditMark) of object;\r\n\r\n // aIndex parameters of Line notifications are 0-based.\r\n // aRow parameter of GetRowLength() is 1-based.\r\n ISynEditBufferPlugin = interface\r\n // conversion methods\r\n function BufferToDisplayPos(const aPos: TBufferCoord): TDisplayCoord;\r\n function DisplayToBufferPos(const aPos: TDisplayCoord): TBufferCoord;\r\n function RowCount: Integer;\r\n function GetRowLength(aRow: Integer): Integer;\r\n // plugin notifications\r\n function LinesInserted(aIndex: Integer; aCount: Integer): Integer;\r\n function LinesDeleted(aIndex: Integer; aCount: Integer): Integer;\r\n function LinesPutted(aIndex: Integer; aCount: Integer): Integer;\r\n // font or size change\r\n procedure DisplayChanged;\r\n // pretty clear, heh?\r\n procedure Reset;\r\n end;\r\n\r\n TSynEditPlugin = class(TObject)\r\n private\r\n fOwner: TCustomSynEdit;\r\n protected\r\n procedure AfterPaint(ACanvas: TCanvas; const AClip: TRect;\r\n FirstLine, LastLine: Integer); virtual;\r\n procedure PaintTransient(ACanvas: TCanvas; ATransientType: TTransientType); virtual;\r\n procedure LinesInserted(FirstLine, Count: Integer); virtual;\r\n procedure LinesDeleted(FirstLine, Count: Integer); virtual;\r\n protected\r\n property Editor: TCustomSynEdit read fOwner;\r\n public\r\n constructor Create(AOwner: TCustomSynEdit);\r\n destructor Destroy; override;\r\n end;\r\n\r\n{$IFDEF SYN_COMPILER_6_UP}\r\n TCustomSynEditSearchNotFoundEvent = procedure(Sender: TObject;\r\n FindText: UnicodeString) of object;\r\n{$ENDIF}\r\n\r\n TCustomSynEdit = class(TCustomControl)\r\n private\r\n{$IFNDEF SYN_CLX}\r\n procedure WMCancelMode(var Message: TMessage); message WM_CANCELMODE;\r\n procedure WMCaptureChanged(var Msg: TMessage); message WM_CAPTURECHANGED;\r\n procedure WMChar(var Msg: TWMChar); message WM_CHAR;\r\n procedure WMClear(var Msg: TMessage); message WM_CLEAR;\r\n procedure WMCopy(var Message: TMessage); message WM_COPY;\r\n procedure WMCut(var Message: TMessage); message WM_CUT;\r\n procedure WMDropFiles(var Msg: TMessage); message WM_DROPFILES;\r\n procedure WMDestroy(var Message: TWMDestroy); message WM_DESTROY;\r\n procedure WMEraseBkgnd(var Msg: TMessage); message WM_ERASEBKGND;\r\n procedure WMGetDlgCode(var Msg: TWMGetDlgCode); message WM_GETDLGCODE;\r\n procedure WMGetText(var Msg: TWMGetText); message WM_GETTEXT;\r\n procedure WMGetTextLength(var Msg: TWMGetTextLength); message WM_GETTEXTLENGTH;\r\n procedure WMHScroll(var Msg: TWMScroll); message WM_HSCROLL;\r\n procedure WMPaste(var Message: TMessage); message WM_PASTE;\r\n procedure WMSetText(var Msg: TWMSetText); message WM_SETTEXT;\r\n procedure WMImeChar(var Msg: TMessage); message WM_IME_CHAR;\r\n procedure WMImeComposition(var Msg: TMessage); message WM_IME_COMPOSITION;\r\n procedure WMImeNotify(var Msg: TMessage); message WM_IME_NOTIFY;\r\n procedure WMKillFocus(var Msg: TWMKillFocus); message WM_KILLFOCUS;\r\n procedure WMSetCursor(var Msg: TWMSetCursor); message WM_SETCURSOR;\r\n procedure WMSetFocus(var Msg: TWMSetFocus); message WM_SETFOCUS;\r\n procedure WMSize(var Msg: TWMSize); message WM_SIZE;\r\n procedure WMUndo(var Msg: TMessage); message WM_UNDO;\r\n procedure WMVScroll(var Msg: TWMScroll); message WM_VSCROLL;\r\n{$ENDIF}\r\n{$IFNDEF SYN_COMPILER_6_UP}\r\n procedure WMMouseWheel(var Msg: TMessage); message WM_MOUSEWHEEL;\r\n{$ENDIF}\r\n private\r\n fAlwaysShowCaret: Boolean;\r\n fBlockBegin: TBufferCoord;\r\n fBlockEnd: TBufferCoord;\r\n fCaretX: Integer;\r\n fLastCaretX: integer;\r\n fCaretY: Integer;\r\n fCharsInWindow: Integer;\r\n fCharWidth: Integer;\r\n fFontDummy: TFont;\r\n fFontSmoothing: TSynFontSmoothMethod;\r\n fInserting: Boolean;\r\n fLines: TUnicodeStrings;\r\n fOrigLines: TUnicodeStrings;\r\n fOrigUndoList: TSynEditUndoList;\r\n fOrigRedoList: TSynEditUndoList;\r\n fLinesInWindow: Integer;\r\n fLeftChar: Integer;\r\n fMaxScrollWidth: Integer;\r\n fPaintLock: Integer;\r\n fReadOnly: Boolean;\r\n fRightEdge: Integer;\r\n fRightEdgeColor: TColor;\r\n fScrollHintColor: TColor;\r\n fScrollHintFormat: TScrollHintFormat;\r\n FScrollBars: TScrollStyle;\r\n fTextHeight: Integer;\r\n fTextOffset: Integer;\r\n fTopLine: Integer;\r\n fHighlighter: TSynCustomHighlighter;\r\n fSelectedColor: TSynSelectedColor;\r\n fActiveLineColor: TColor;\r\n fUndoList: TSynEditUndoList;\r\n fRedoList: TSynEditUndoList;\r\n fBookMarks: array[0..9] of TSynEditMark; // these are just references, fMarkList is the owner\r\n fMouseDownX: Integer;\r\n fMouseDownY: Integer;\r\n fBookMarkOpt: TSynBookMarkOpt;\r\n fBorderStyle: TSynBorderStyle;\r\n fHideSelection: Boolean;\r\n fMouseWheelAccumulator: Integer;\r\n fOverwriteCaret: TSynEditCaretType;\r\n fInsertCaret: TSynEditCaretType;\r\n fCaretOffset: TPoint;\r\n fKeyStrokes: TSynEditKeyStrokes;\r\n fModified: Boolean;\r\n fMarkList: TSynEditMarkList;\r\n fExtraLineSpacing: Integer;\r\n fSelectionMode: TSynSelectionMode;\r\n fActiveSelectionMode: TSynSelectionMode; //mode of the active selection\r\n fWantReturns: Boolean;\r\n fWantTabs: Boolean;\r\n fWordWrapPlugin: ISynEditBufferPlugin;\r\n fWordWrapGlyph: TSynGlyph;\r\n fCaretAtEOL: Boolean; // used by wordwrap\r\n\r\n fGutter: TSynGutter;\r\n fTabWidth: Integer;\r\n fTextDrawer: TheTextDrawer;\r\n fInvalidateRect: TRect;\r\n fStateFlags: TSynStateFlags;\r\n fOptions: TSynEditorOptions;\r\n fStatusChanges: TSynStatusChanges;\r\n fLastKey: word;\r\n fLastShiftState: TShiftState;\r\n fSearchEngine: TSynEditSearchCustom;\r\n fHookedCommandHandlers: TObjectList;\r\n fKbdHandler: TSynEditKbdHandler;\r\n fFocusList: TList;\r\n fPlugins: TObjectList;\r\n fScrollTimer: TTimer;\r\n fScrollDeltaX, fScrollDeltaY: Integer;\r\n // event handlers\r\n fOnChange: TNotifyEvent;\r\n fOnClearMark: TPlaceMarkEvent;\r\n fOnCommandProcessed: TProcessCommandEvent;\r\n fOnDropFiles: TDropFilesEvent;\r\n fOnGutterClick: TGutterClickEvent;\r\n FOnKeyPressW: TKeyPressWEvent;\r\n fOnMouseCursor: TMouseCursorEvent;\r\n fOnPaint: TPaintEvent;\r\n fOnPlaceMark: TPlaceMarkEvent;\r\n fOnProcessCommand: TProcessCommandEvent;\r\n fOnProcessUserCommand: TProcessCommandEvent;\r\n fOnReplaceText: TReplaceTextEvent;\r\n fOnSpecialLineColors: TSpecialLineColorsEvent;\r\n fOnContextHelp: TContextHelpEvent;\r\n fOnPaintTransient: TPaintTransient;\r\n fOnScroll: TScrollEvent;\r\n fOnGutterGetText: TGutterGetTextEvent;\r\n fOnGutterPaint: TGutterPaintEvent;\r\n\r\n fOnStatusChange: TStatusChangeEvent;\r\n fShowSpecChar: Boolean;\r\n FPaintTransientLock: Integer;\r\n FIsScrolling: Boolean;\r\n\r\n fChainListCleared: TNotifyEvent;\r\n fChainListDeleted: TStringListChangeEvent;\r\n fChainListInserted: TStringListChangeEvent;\r\n fChainListPutted: TStringListChangeEvent;\r\n fChainLinesChanging: TNotifyEvent;\r\n fChainLinesChanged: TNotifyEvent;\r\n fChainedEditor: TCustomSynEdit;\r\n fChainUndoAdded: TNotifyEvent;\r\n fChainRedoAdded: TNotifyEvent;\r\n\r\n FAdditionalWordBreakChars: TSysCharSet;\r\n FAdditionalIdentChars: TSysCharSet;\r\n\r\n{$IFDEF SYN_COMPILER_6_UP}\r\n fSearchNotFound: TCustomSynEditSearchNotFoundEvent;\r\n OnFindBeforeSearch: TNotifyEvent;\r\n OnReplaceBeforeSearch: TNotifyEvent;\r\n OnCloseBeforeSearch: TNotifyEvent;\r\n SelStartBeforeSearch: integer;\r\n SelLengthBeforeSearch: integer;\r\n{$ENDIF}\r\n\r\n{$IFNDEF SYN_CLX}\r\n FWindowProducedMessage: Boolean;\r\n{$ENDIF}\r\n\r\n{$IFDEF SYN_LINUX}\r\n FDeadKeysFixed: Boolean;\r\n{$ENDIF}\r\n\r\n{$IFDEF SYN_CLX}\r\n FHScrollBar : TSynEditScrollBar;\r\n FVScrollBar : TSynEditScrollBar;\r\n procedure ScrollEvent(Sender: TObject; ScrollCode: TScrollCode; var ScrollPos: Integer);\r\n{$ENDIF}\r\n\r\n procedure BookMarkOptionsChanged(Sender: TObject);\r\n procedure ComputeCaret(X, Y: Integer);\r\n procedure ComputeScroll(X, Y: Integer);\r\n procedure DoHomeKey(Selection:boolean);\r\n procedure DoEndKey(Selection: Boolean);\r\n procedure DoLinesDeleted(FirstLine, Count: integer);\r\n procedure DoLinesInserted(FirstLine, Count: integer);\r\n procedure DoShiftTabKey;\r\n procedure DoTabKey;\r\n procedure DoCaseChange(const Cmd : TSynEditorCommand);\r\n function FindHookedCmdEvent(AHandlerProc: THookedCommandEvent): integer;\r\n procedure SynFontChanged(Sender: TObject);\r\n function GetBlockBegin: TBufferCoord;\r\n function GetBlockEnd: TBufferCoord;\r\n function GetCanPaste: Boolean;\r\n function GetCanRedo: Boolean;\r\n function GetCanUndo: Boolean;\r\n function GetCaretXY: TBufferCoord;\r\n function GetDisplayX: Integer;\r\n function GetDisplayY: Integer;\r\n function GetDisplayXY: TDisplayCoord;\r\n function GetDisplayLineCount: Integer;\r\n function GetFont: TFont;\r\n function GetHookedCommandHandlersCount: Integer;\r\n function GetLineText: UnicodeString;\r\n function GetMaxUndo: Integer;\r\n function GetOptions: TSynEditorOptions;\r\n function GetSelAvail: Boolean;\r\n function GetSelTabBlock: Boolean;\r\n function GetSelTabLine: Boolean;\r\n function GetSelText: UnicodeString;\r\n function SynGetText: UnicodeString;\r\n function GetWordAtCursor: UnicodeString;\r\n function GetWordAtMouse: UnicodeString;\r\n function GetWordWrap: Boolean;\r\n procedure GutterChanged(Sender: TObject);\r\n function LeftSpaces(const Line: UnicodeString): Integer;\r\n function LeftSpacesEx(const Line: UnicodeString; WantTabs: Boolean): Integer;\r\n function GetLeftSpacing(CharCount: Integer; WantTabs: Boolean): UnicodeString;\r\n procedure LinesChanging(Sender: TObject);\r\n procedure MoveCaretAndSelection(const ptBefore, ptAfter: TBufferCoord;\r\n SelectionCommand: Boolean);\r\n procedure MoveCaretHorz(DX: Integer; SelectionCommand: Boolean);\r\n procedure MoveCaretVert(DY: Integer; SelectionCommand: Boolean);\r\n procedure PluginsAfterPaint(ACanvas: TCanvas; const AClip: TRect;\r\n FirstLine, LastLine: Integer);\r\n procedure ReadAddedKeystrokes(Reader: TReader);\r\n procedure ReadRemovedKeystrokes(Reader: TReader);\r\n function ScanFrom(Index: Integer): Integer;\r\n procedure ScrollTimerHandler(Sender: TObject);\r\n procedure SelectedColorsChanged(Sender: TObject);\r\n procedure SetBlockBegin(Value: TBufferCoord);\r\n procedure SetBlockEnd(Value: TBufferCoord);\r\n procedure SetBorderStyle(Value: TSynBorderStyle);\r\n procedure SetCaretX(Value: Integer);\r\n procedure SetCaretY(Value: Integer);\r\n procedure InternalSetCaretX(Value: Integer);\r\n procedure InternalSetCaretY(Value: Integer);\r\n procedure SetInternalDisplayXY(const aPos: TDisplayCoord);\r\n procedure SetActiveLineColor(Value: TColor);\r\n procedure SetExtraLineSpacing(const Value: Integer);\r\n procedure SetFont(const Value: TFont);\r\n procedure SetGutter(const Value: TSynGutter);\r\n procedure SetGutterWidth(Value: Integer);\r\n procedure SetHideSelection(const Value: Boolean);\r\n procedure SetHighlighter(const Value: TSynCustomHighlighter);\r\n procedure SetInsertCaret(const Value: TSynEditCaretType);\r\n procedure SetInsertMode(const Value: Boolean);\r\n procedure SetKeystrokes(const Value: TSynEditKeyStrokes);\r\n procedure SetLeftChar(Value: Integer);\r\n procedure SetLines(Value: TUnicodeStrings);\r\n procedure SetLineText(Value: UnicodeString);\r\n procedure SetMaxScrollWidth(Value: Integer);\r\n procedure SetMaxUndo(const Value: Integer);\r\n procedure SetModified(Value: Boolean);\r\n procedure SetOptions(Value: TSynEditorOptions);\r\n procedure SetOverwriteCaret(const Value: TSynEditCaretType);\r\n procedure SetRightEdge(Value: Integer);\r\n procedure SetRightEdgeColor(Value: TColor);\r\n procedure SetScrollBars(const Value: TScrollStyle);\r\n procedure SetSearchEngine(Value: TSynEditSearchCustom);\r\n procedure SetSelectionMode(const Value: TSynSelectionMode);\r\n procedure SetActiveSelectionMode(const Value: TSynSelectionMode);\r\n procedure SetSelTextExternal(const Value: UnicodeString);\r\n procedure SetTabWidth(Value: Integer);\r\n procedure SynSetText(const Value: UnicodeString);\r\n procedure SetTopLine(Value: Integer);\r\n procedure SetWordWrap(const Value: Boolean);\r\n procedure SetWordWrapGlyph(const Value: TSynGlyph);\r\n procedure WordWrapGlyphChange(Sender: TObject);\r\n procedure SizeOrFontChanged(bFont: boolean);\r\n procedure ProperSetLine(ALine: Integer; const ALineText: UnicodeString);\r\n procedure UpdateModifiedStatus;\r\n procedure UndoRedoAdded(Sender: TObject);\r\n procedure UpdateLastCaretX;\r\n procedure UpdateScrollBars;\r\n procedure WriteAddedKeystrokes(Writer: TWriter);\r\n procedure WriteRemovedKeystrokes(Writer: TWriter);\r\n procedure SetAdditionalIdentChars(const Value: TSysCharSet);\r\n procedure SetAdditionalWordBreakChars(const Value: TSysCharSet);\r\n\r\n{$IFDEF SYN_COMPILER_6_UP}\r\n procedure DoSearchFindFirstExecute(Action: TSearchFindFirst);\r\n procedure DoSearchFindExecute(Action: TSearchFind);\r\n procedure DoSearchReplaceExecute(Action: TSearchReplace);\r\n procedure DoSearchFindNextExecute(Action: TSearchFindNext);\r\n procedure FindDialogFindFirst(Sender: TObject);\r\n procedure FindDialogFind(Sender: TObject);\r\n function SearchByFindDialog(FindDialog: TFindDialog) : bool;\r\n procedure FindDialogClose(Sender: TObject);\r\n{$ENDIF}\r\n protected\r\n FIgnoreNextChar: Boolean;\r\n FCharCodeString: string;\r\n{$IFDEF SYN_COMPILER_6_UP}\r\n function DoMouseWheel(Shift: TShiftState; WheelDelta: Integer;\r\n MousePos: TPoint): Boolean; override;\r\n{$ENDIF}\r\n{$IFDEF SYN_CLX}\r\n procedure Resize; override;\r\n function GetClientOrigin: TPoint; override;\r\n function GetClientRect: TRect; override;\r\n function WidgetFlags: Integer; override;\r\n procedure KeyString(var S: UnicodeString; var Handled: Boolean); override;\r\n function NeedKey(Key: Integer; Shift: TShiftState;\r\n const KeyText: UnicodeString): Boolean; override;\r\n{$ELSE}\r\n procedure CreateParams(var Params: TCreateParams); override;\r\n procedure CreateWnd; override;\r\n procedure DestroyWnd; override;\r\n procedure InvalidateRect(const aRect: TRect; aErase: Boolean); virtual;\r\n{$ENDIF}\r\n procedure DblClick; override;\r\n procedure DecPaintLock;\r\n procedure DefineProperties(Filer: TFiler); override;\r\n procedure DoChange; virtual;\r\n{$IFDEF SYN_CLX}\r\n procedure DoKeyPressW(var Key: WideChar);\r\n{$ELSE}\r\n procedure DoKeyPressW(var Message: TWMKey);\r\n{$ENDIF}\r\n procedure DragCanceled; override;\r\n procedure DragOver(Source: TObject; X, Y: Integer;\r\n State: TDragState; var Accept: Boolean); override;\r\n function GetReadOnly: boolean; virtual;\r\n procedure HighlighterAttrChanged(Sender: TObject);\r\n procedure IncPaintLock;\r\n procedure InitializeCaret;\r\n procedure KeyUp(var Key: Word; Shift: TShiftState); override;\r\n procedure KeyDown(var Key: Word; Shift: TShiftState); override;\r\n procedure KeyPress(var Key: Char); override;\r\n procedure KeyPressW(var Key: WideChar); virtual;\r\n procedure LinesChanged(Sender: TObject); virtual;\r\n procedure ListCleared(Sender: TObject);\r\n procedure ListDeleted(Sender: TObject; aIndex: Integer; aCount: Integer);\r\n procedure ListInserted(Sender: TObject; Index: Integer; aCount: Integer);\r\n procedure ListPutted(Sender: TObject; Index: Integer; aCount: Integer);\r\n //helper procs to chain list commands\r\n procedure ChainListCleared(Sender: TObject);\r\n procedure ChainListDeleted(Sender: TObject; aIndex: Integer; aCount: Integer);\r\n procedure ChainListInserted(Sender: TObject; aIndex: Integer; aCount: Integer);\r\n procedure ChainListPutted(Sender: TObject; aIndex: Integer; aCount: Integer);\r\n procedure ChainLinesChanging(Sender: TObject);\r\n procedure ChainLinesChanged(Sender: TObject);\r\n procedure ChainUndoRedoAdded(Sender: TObject);\r\n procedure ScanRanges;\r\n procedure Loaded; override;\r\n procedure MarkListChange(Sender: TObject);\r\n procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y:\r\n Integer); override;\r\n procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;\r\n procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);\r\n override;\r\n procedure NotifyHookedCommandHandlers(AfterProcessing: Boolean;\r\n var Command: TSynEditorCommand; var AChar: WideChar; Data: pointer); virtual;\r\n procedure Paint; override;\r\n procedure PaintGutter(const AClip: TRect; const aFirstRow,\r\n aLastRow: Integer); virtual;\r\n procedure PaintTextLines(AClip: TRect; const aFirstRow, aLastRow,\r\n FirstCol, LastCol: Integer); virtual;\r\n procedure RecalcCharExtent;\r\n procedure RedoItem;\r\n procedure InternalSetCaretXY(const Value: TBufferCoord); virtual;\r\n procedure SetCaretXY(const Value: TBufferCoord); virtual;\r\n procedure SetCaretXYEx(CallEnsureCursorPos: Boolean; Value: TBufferCoord); virtual;\r\n procedure SetFontSmoothing(AValue: TSynFontSmoothMethod);\r\n procedure SetName(const Value: TComponentName); override;\r\n procedure SetReadOnly(Value: boolean); virtual;\r\n procedure SetWantReturns(Value: Boolean);\r\n procedure SetSelTextPrimitive(const Value: UnicodeString);\r\n procedure SetSelTextPrimitiveEx(PasteMode: TSynSelectionMode; Value: PWideChar;\r\n AddToUndoList: Boolean);\r\n procedure SetWantTabs(Value: Boolean);\r\n procedure StatusChanged(AChanges: TSynStatusChanges);\r\n // If the translations requires Data, memory will be allocated for it via a\r\n // GetMem call. The client must call FreeMem on Data if it is not NIL.\r\n function TranslateKeyCode(Code: word; Shift: TShiftState;\r\n var Data: pointer): TSynEditorCommand;\r\n procedure UndoItem;\r\n procedure UpdateMouseCursor; virtual;\r\n protected\r\n fGutterWidth: Integer;\r\n fInternalImage: TSynInternalImage;\r\n procedure HideCaret;\r\n procedure ShowCaret;\r\n procedure DoOnClearBookmark(var Mark: TSynEditMark); virtual;\r\n procedure DoOnCommandProcessed(Command: TSynEditorCommand; AChar: WideChar;\r\n Data: pointer); virtual;\r\n // no method DoOnDropFiles, intercept the WM_DROPFILES instead\r\n procedure DoOnGutterClick(Button: TMouseButton; X, Y: Integer); virtual;\r\n procedure DoOnPaint; virtual;\r\n procedure DoOnPaintTransientEx(TransientType: TTransientType; Lock: Boolean); virtual;\r\n procedure DoOnPaintTransient(TransientType: TTransientType); virtual;\r\n\r\n procedure DoOnPlaceMark(var Mark: TSynEditMark); virtual;\r\n procedure DoOnProcessCommand(var Command: TSynEditorCommand;\r\n var AChar: WideChar; Data: pointer); virtual;\r\n function DoOnReplaceText(const ASearch, AReplace: UnicodeString;\r\n Line, Column: Integer): TSynReplaceAction; virtual;\r\n function DoOnSpecialLineColors(Line: Integer;\r\n var Foreground, Background: TColor): Boolean; virtual;\r\n procedure DoOnStatusChange(Changes: TSynStatusChanges); virtual;\r\n function GetSelEnd: integer;\r\n function GetSelStart: integer;\r\n function GetSelLength: integer;\r\n procedure SetSelEnd(const Value: integer);\r\n procedure SetSelStart(const Value: integer);\r\n procedure SetSelLength(const Value: integer);\r\n procedure SetAlwaysShowCaret(const Value: Boolean);\r\n function ShrinkAtWideGlyphs(const S: UnicodeString; First: Integer;\r\n var CharCount: Integer): UnicodeString;\r\n procedure LinesHookChanged;\r\n property InternalCaretX: Integer write InternalSetCaretX;\r\n property InternalCaretY: Integer write InternalSetCaretY;\r\n property InternalCaretXY: TBufferCoord write InternalSetCaretXY;\r\n property FontSmoothing: TSynFontSmoothMethod read fFontSmoothing write SetFontSmoothing;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n property Canvas;\r\n property SelStart: Integer read GetSelStart write SetSelStart;\r\n property SelEnd: Integer read GetSelEnd write SetSelEnd;\r\n property AlwaysShowCaret: Boolean read FAlwaysShowCaret\r\n write SetAlwaysShowCaret;\r\n procedure UpdateCaret;\r\n{$IFDEF SYN_COMPILER_4_UP}\r\n procedure AddKey(Command: TSynEditorCommand; Key1: word; SS1: TShiftState;\r\n Key2: word = 0; SS2: TShiftState = []);\r\n{$ELSE}\r\n procedure AddKey(Command: TSynEditorCommand; Key1: word; SS1: TShiftState;\r\n Key2: word; SS2: TShiftState);\r\n{$ENDIF}\r\n procedure BeginUndoBlock;\r\n procedure BeginUpdate;\r\n function CaretInView: Boolean;\r\n function CharIndexToRowCol(Index: Integer): TBufferCoord;\r\n procedure Clear;\r\n procedure ClearAll;\r\n procedure ClearBookMark(BookMark: Integer);\r\n procedure ClearSelection;\r\n procedure CommandProcessor(Command: TSynEditorCommand; AChar: WideChar;\r\n Data: pointer); virtual;\r\n procedure ClearUndo;\r\n procedure CopyToClipboard;\r\n procedure CutToClipboard;\r\n procedure DoCopyToClipboard(const SText: UnicodeString);\r\n procedure DragDrop(Source: TObject; X, Y: Integer); override;\r\n procedure EndUndoBlock;\r\n procedure EndUpdate;\r\n procedure EnsureCursorPosVisible;\r\n procedure EnsureCursorPosVisibleEx(ForceToMiddle: Boolean;\r\n EvenIfVisible: Boolean = False);\r\n procedure FindMatchingBracket; virtual;\r\n function GetMatchingBracket: TBufferCoord; virtual;\r\n function GetMatchingBracketEx(const APoint: TBufferCoord): TBufferCoord; virtual;\r\n{$IFDEF SYN_COMPILER_4_UP}\r\n function ExecuteAction(Action: TBasicAction): Boolean; override;\r\n{$ENDIF}\r\n procedure ExecuteCommand(Command: TSynEditorCommand; AChar: WideChar;\r\n Data: pointer); virtual;\r\n function ExpandAtWideGlyphs(const S: UnicodeString): UnicodeString;\r\n function GetBookMark(BookMark: Integer; var X, Y: Integer): Boolean;\r\n function GetHighlighterAttriAtRowCol(const XY: TBufferCoord; var Token: UnicodeString;\r\n var Attri: TSynHighlighterAttributes): Boolean;\r\n function GetHighlighterAttriAtRowColEx(const XY: TBufferCoord; var Token: UnicodeString;\r\n var TokenType, Start: Integer;\r\n var Attri: TSynHighlighterAttributes): boolean;\r\n function GetPositionOfMouse(out aPos: TBufferCoord): Boolean;\r\n function GetWordAtRowCol(XY: TBufferCoord): UnicodeString;\r\n procedure GotoBookMark(BookMark: Integer); virtual;\r\n procedure GotoLineAndCenter(ALine: Integer); virtual;\r\n function IsIdentChar(AChar: WideChar): Boolean; virtual;\r\n function IsWhiteChar(AChar: WideChar): Boolean; virtual;\r\n function IsWordBreakChar(AChar: WideChar): Boolean; virtual;\r\n\r\n // Codehunter patch: Make InsertBlock, DoBlockIndent, DoBlockUnindent public\r\n procedure InsertBlock(const BB, BE: TBufferCoord; ChangeStr: PWideChar; AddToUndoList: Boolean);\r\n // Codehunter patch: Added UnifiedSelection\r\n function UnifiedSelection: TBufferBlock;\r\n procedure DoBlockIndent;\r\n procedure DoBlockUnindent;\r\n\r\n procedure InvalidateGutter;\r\n procedure InvalidateGutterLine(aLine: integer);\r\n procedure InvalidateGutterLines(FirstLine, LastLine: integer);\r\n procedure InvalidateLine(Line: integer);\r\n procedure InvalidateLines(FirstLine, LastLine: integer);\r\n procedure InvalidateSelection;\r\n function IsBookmark(BookMark: Integer): Boolean;\r\n function IsPointInSelection(const Value: TBufferCoord): Boolean;\r\n procedure LockUndo;\r\n function BufferToDisplayPos(const p: TBufferCoord): TDisplayCoord;\r\n function DisplayToBufferPos(const p: TDisplayCoord): TBufferCoord;\r\n function LineToRow(aLine: Integer): Integer;\r\n function RowToLine(aRow: Integer): Integer;\r\n procedure Notification(AComponent: TComponent;\r\n Operation: TOperation); override;\r\n procedure PasteFromClipboard;\r\n\r\n function NextWordPos: TBufferCoord; virtual;\r\n function NextWordPosEx(const XY: TBufferCoord): TBufferCoord; virtual;\r\n function WordStart: TBufferCoord; virtual;\r\n function WordStartEx(const XY: TBufferCoord): TBufferCoord; virtual;\r\n function WordEnd: TBufferCoord; virtual;\r\n function WordEndEx(const XY: TBufferCoord): TBufferCoord; virtual;\r\n function PrevWordPos: TBufferCoord; virtual;\r\n function PrevWordPosEx(const XY: TBufferCoord): TBufferCoord; virtual;\r\n\r\n function PixelsToRowColumn(aX, aY: Integer): TDisplayCoord;\r\n function PixelsToNearestRowColumn(aX, aY: Integer): TDisplayCoord;\r\n procedure Redo;\r\n procedure RegisterCommandHandler(const AHandlerProc: THookedCommandEvent;\r\n AHandlerData: pointer);\r\n function RowColumnToPixels(const RowCol: TDisplayCoord): TPoint;\r\n function RowColToCharIndex(RowCol: TBufferCoord): Integer;\r\n function SearchReplace(const ASearch, AReplace: UnicodeString;\r\n AOptions: TSynSearchOptions): Integer;\r\n procedure SelectAll;\r\n procedure SetBookMark(BookMark: Integer; X: Integer; Y: Integer);\r\n procedure SetCaretAndSelection(const ptCaret, ptBefore, ptAfter: TBufferCoord);\r\n procedure SetDefaultKeystrokes; virtual;\r\n procedure SetSelWord;\r\n procedure SetWordBlock(Value: TBufferCoord);\r\n procedure Undo;\r\n procedure UnlockUndo;\r\n procedure UnregisterCommandHandler(AHandlerProc: THookedCommandEvent);\r\n{$IFDEF SYN_COMPILER_4_UP}\r\n function UpdateAction(Action: TBasicAction): Boolean; override;\r\n{$ENDIF}\r\n procedure SetFocus; override;\r\n\r\n procedure AddKeyUpHandler(aHandler: TKeyEvent);\r\n procedure RemoveKeyUpHandler(aHandler: TKeyEvent);\r\n procedure AddKeyDownHandler(aHandler: TKeyEvent);\r\n procedure RemoveKeyDownHandler(aHandler: TKeyEvent);\r\n procedure AddKeyPressHandler(aHandler: TKeyPressWEvent);\r\n procedure RemoveKeyPressHandler(aHandler: TKeyPressWEvent);\r\n procedure AddFocusControl(aControl: TWinControl);\r\n procedure RemoveFocusControl(aControl: TWinControl);\r\n procedure AddMouseDownHandler(aHandler: TMouseEvent);\r\n procedure RemoveMouseDownHandler(aHandler: TMouseEvent);\r\n procedure AddMouseUpHandler(aHandler: TMouseEvent);\r\n procedure RemoveMouseUpHandler(aHandler: TMouseEvent);\r\n procedure AddMouseCursorHandler(aHandler: TMouseCursorEvent);\r\n procedure RemoveMouseCursorHandler(aHandler: TMouseCursorEvent);\r\n\r\n{$IFDEF SYN_CLX}\r\n function EventFilter(Sender: QObjectH; Event: QEventH): Boolean; override;\r\n{$ELSE}\r\n procedure WndProc(var Msg: TMessage); override;\r\n{$ENDIF}\r\n procedure SetLinesPointer(ASynEdit: TCustomSynEdit);\r\n procedure RemoveLinesPointer;\r\n procedure HookTextBuffer(aBuffer: TSynEditStringList;\r\n aUndo, aRedo: TSynEditUndoList);\r\n procedure UnHookTextBuffer;\r\n public\r\n property AdditionalIdentChars: TSysCharSet read FAdditionalIdentChars write SetAdditionalIdentChars;\r\n property AdditionalWordBreakChars: TSysCharSet read FAdditionalWordBreakChars write SetAdditionalWordBreakChars;\r\n property BlockBegin: TBufferCoord read GetBlockBegin write SetBlockBegin;\r\n property BlockEnd: TBufferCoord read GetBlockEnd write SetBlockEnd;\r\n property CanPaste: Boolean read GetCanPaste;\r\n property CanRedo: Boolean read GetCanRedo;\r\n property CanUndo: Boolean read GetCanUndo;\r\n property CaretX: Integer read fCaretX write SetCaretX;\r\n property CaretY: Integer read fCaretY write SetCaretY;\r\n property CaretXY: TBufferCoord read GetCaretXY write SetCaretXY;\r\n property ActiveLineColor: TColor read fActiveLineColor\r\n write SetActiveLineColor default clNone;\r\n property DisplayX: Integer read GetDisplayX;\r\n property DisplayY: Integer read GetDisplayY;\r\n property DisplayXY: TDisplayCoord read GetDisplayXY;\r\n property DisplayLineCount: Integer read GetDisplayLineCount;\r\n property CharsInWindow: Integer read fCharsInWindow;\r\n property CharWidth: Integer read fCharWidth;\r\n property Color;\r\n property Font: TFont read GetFont write SetFont;\r\n property Highlighter: TSynCustomHighlighter\r\n read fHighlighter write SetHighlighter;\r\n property LeftChar: Integer read fLeftChar write SetLeftChar;\r\n property LineHeight: Integer read fTextHeight;\r\n property LinesInWindow: Integer read fLinesInWindow;\r\n property LineText: UnicodeString read GetLineText write SetLineText;\r\n property Lines: TUnicodeStrings read fLines write SetLines;\r\n property Marks: TSynEditMarkList read fMarkList;\r\n property MaxScrollWidth: Integer read fMaxScrollWidth write SetMaxScrollWidth\r\n default 1024;\r\n property Modified: Boolean read fModified write SetModified;\r\n property PaintLock: Integer read fPaintLock;\r\n property ReadOnly: Boolean read GetReadOnly write SetReadOnly default False;\r\n property SearchEngine: TSynEditSearchCustom read fSearchEngine write SetSearchEngine;\r\n property SelAvail: Boolean read GetSelAvail;\r\n property SelLength: Integer read GetSelLength write SetSelLength;\r\n property SelTabBlock: Boolean read GetSelTabBlock;\r\n property SelTabLine: Boolean read GetSelTabLine;\r\n property SelText: UnicodeString read GetSelText write SetSelTextExternal;\r\n property StateFlags: TSynStateFlags read fStateFlags;\r\n property Text: UnicodeString read SynGetText write SynSetText;\r\n property TopLine: Integer read fTopLine write SetTopLine;\r\n property WordAtCursor: UnicodeString read GetWordAtCursor;\r\n property WordAtMouse: UnicodeString read GetWordAtMouse;\r\n property UndoList: TSynEditUndoList read fUndoList;\r\n property RedoList: TSynEditUndoList read fRedoList;\r\n public\r\n property OnProcessCommand: TProcessCommandEvent\r\n read FOnProcessCommand write FOnProcessCommand;\r\n\r\n property BookMarkOptions: TSynBookMarkOpt\r\n read fBookMarkOpt write fBookMarkOpt;\r\n property BorderStyle: TSynBorderStyle read FBorderStyle write SetBorderStyle\r\n default bsSingle;\r\n property ExtraLineSpacing: Integer\r\n read fExtraLineSpacing write SetExtraLineSpacing default 0;\r\n property Gutter: TSynGutter read fGutter write SetGutter;\r\n property HideSelection: Boolean read fHideSelection write SetHideSelection\r\n default False;\r\n property InsertCaret: TSynEditCaretType read FInsertCaret\r\n write SetInsertCaret default ctVerticalLine;\r\n property InsertMode: boolean read fInserting write SetInsertMode\r\n default true;\r\n property IsScrolling : Boolean read FIsScrolling;\r\n property Keystrokes: TSynEditKeyStrokes\r\n read FKeystrokes write SetKeystrokes stored False;\r\n property MaxUndo: Integer read GetMaxUndo write SetMaxUndo default 1024;\r\n property Options: TSynEditorOptions read GetOptions write SetOptions\r\n default SYNEDIT_DEFAULT_OPTIONS;\r\n property OverwriteCaret: TSynEditCaretType read FOverwriteCaret\r\n write SetOverwriteCaret default ctBlock;\r\n property RightEdge: Integer read fRightEdge write SetRightEdge default 80;\r\n property RightEdgeColor: TColor\r\n read fRightEdgeColor write SetRightEdgeColor default clSilver;\r\n property ScrollHintColor: TColor read fScrollHintColor\r\n write fScrollHintColor default clInfoBk;\r\n property ScrollHintFormat: TScrollHintFormat read fScrollHintFormat\r\n write fScrollHintFormat default shfTopLineOnly;\r\n property ScrollBars: TScrollStyle\r\n read FScrollBars write SetScrollBars default ssBoth;\r\n property SelectedColor: TSynSelectedColor\r\n read FSelectedColor write FSelectedColor;\r\n property SelectionMode: TSynSelectionMode\r\n read FSelectionMode write SetSelectionMode default smNormal;\r\n property ActiveSelectionMode: TSynSelectionMode read fActiveSelectionMode\r\n write SetActiveSelectionMode stored False;\r\n property TabWidth: integer read fTabWidth write SetTabWidth default 8;\r\n property WantReturns: boolean read fWantReturns write SetWantReturns default True;\r\n property WantTabs: boolean read fWantTabs write SetWantTabs default False;\r\n property WordWrap: boolean read GetWordWrap write SetWordWrap default False;\r\n property WordWrapGlyph: TSynGlyph read fWordWrapGlyph write SetWordWrapGlyph;\r\n property OnChange: TNotifyEvent read FOnChange write FOnChange;\r\n property OnClearBookmark: TPlaceMarkEvent read fOnClearMark\r\n write fOnClearMark;\r\n property OnCommandProcessed: TProcessCommandEvent\r\n read fOnCommandProcessed write fOnCommandProcessed;\r\n property OnContextHelp: TContextHelpEvent\r\n read fOnContextHelp write fOnContextHelp;\r\n property OnDropFiles: TDropFilesEvent read fOnDropFiles write fOnDropFiles;\r\n property OnGutterClick: TGutterClickEvent\r\n read fOnGutterClick write fOnGutterClick;\r\n property OnGutterGetText: TGutterGetTextEvent read fOnGutterGetText\r\n write fOnGutterGetText;\r\n property OnGutterPaint: TGutterPaintEvent read fOnGutterPaint\r\n write fOnGutterPaint;\r\n property OnMouseCursor: TMouseCursorEvent read fOnMouseCursor\r\n write fOnMouseCursor;\r\n property OnKeyPress: TKeyPressWEvent read FOnKeyPressW write FOnKeyPressW;\r\n property OnPaint: TPaintEvent read fOnPaint write fOnPaint;\r\n property OnPlaceBookmark: TPlaceMarkEvent\r\n read FOnPlaceMark write FOnPlaceMark;\r\n property OnProcessUserCommand: TProcessCommandEvent\r\n read FOnProcessUserCommand write FOnProcessUserCommand;\r\n property OnReplaceText: TReplaceTextEvent read fOnReplaceText\r\n write fOnReplaceText;\r\n property OnSpecialLineColors: TSpecialLineColorsEvent\r\n read fOnSpecialLineColors write fOnSpecialLineColors;\r\n property OnStatusChange: TStatusChangeEvent\r\n read fOnStatusChange write fOnStatusChange;\r\n property OnPaintTransient: TPaintTransient\r\n read fOnPaintTransient write fOnPaintTransient;\r\n property OnScroll: TScrollEvent\r\n read fOnScroll write fOnScroll;\r\n published\r\n property Cursor default crIBeam;\r\n{$IFDEF SYN_COMPILER_6_UP}\r\n property OnSearchNotFound: TCustomSynEditSearchNotFoundEvent\r\n read fSearchNotFound write fSearchNotFound;\r\n{$ENDIF}\r\n end;\r\n\r\n TSynEdit = class(TCustomSynEdit)\r\n published\r\n // inherited properties\r\n property Align;\r\n{$IFDEF SYN_COMPILER_4_UP}\r\n property Anchors;\r\n property Constraints;\r\n{$ENDIF}\r\n property Color;\r\n property ActiveLineColor;\r\n{$IFDEF SYN_CLX}\r\n{$ELSE}\r\n property Ctl3D;\r\n property ParentCtl3D;\r\n{$ENDIF}\r\n property Enabled;\r\n property Font;\r\n property Height;\r\n property Name;\r\n property ParentColor default False;\r\n property ParentFont default False;\r\n property ParentShowHint;\r\n property PopupMenu;\r\n property ShowHint;\r\n property TabOrder;\r\n property TabStop default True;\r\n property Visible;\r\n property Width;\r\n // inherited events\r\n property OnClick;\r\n property OnDblClick;\r\n property OnDragDrop;\r\n property OnDragOver;\r\n{$IFDEF SYN_CLX}\r\n{$ELSE}\r\n{$IFDEF SYN_COMPILER_4_UP}\r\n property OnEndDock;\r\n property OnStartDock;\r\n{$ENDIF}\r\n{$ENDIF}\r\n property OnEndDrag;\r\n property OnEnter;\r\n property OnExit;\r\n property OnKeyDown;\r\n property OnKeyPress;\r\n property OnKeyUp;\r\n property OnMouseDown;\r\n property OnMouseMove;\r\n property OnMouseUp;\r\n property OnMouseWheel;\r\n property OnMouseWheelDown;\r\n property OnMouseWheelUp;\r\n property OnStartDrag;\r\n // TCustomSynEdit properties\r\n property BookMarkOptions;\r\n property BorderStyle;\r\n property ExtraLineSpacing;\r\n property Gutter;\r\n property HideSelection;\r\n property Highlighter;\r\n{$IFNDEF SYN_CLX}\r\n property ImeMode;\r\n property ImeName;\r\n{$ENDIF}\r\n property InsertCaret;\r\n property InsertMode;\r\n property Keystrokes;\r\n property Lines;\r\n property MaxScrollWidth;\r\n property MaxUndo;\r\n property Options;\r\n property OverwriteCaret;\r\n property ReadOnly;\r\n property RightEdge;\r\n property RightEdgeColor;\r\n property ScrollHintColor;\r\n property ScrollHintFormat;\r\n property ScrollBars;\r\n property SearchEngine;\r\n property SelectedColor;\r\n property SelectionMode;\r\n property TabWidth;\r\n property WantReturns;\r\n property WantTabs;\r\n property WordWrap;\r\n property WordWrapGlyph;\r\n // TCustomSynEdit events\r\n property OnChange;\r\n property OnClearBookmark;\r\n property OnCommandProcessed;\r\n property OnContextHelp;\r\n property OnDropFiles;\r\n property OnGutterClick;\r\n property OnGutterGetText;\r\n property OnGutterPaint;\r\n property OnMouseCursor;\r\n property OnPaint;\r\n property OnPlaceBookmark;\r\n property OnProcessCommand;\r\n property OnProcessUserCommand;\r\n property OnReplaceText;\r\n property OnScroll;\r\n property OnSpecialLineColors;\r\n property OnStatusChange;\r\n property OnPaintTransient;\r\n\r\n property FontSmoothing;\r\n end;\r\n\r\nimplementation\r\n\r\n{$R SynEdit.res}\r\n\r\nuses\r\n{$IFDEF SYN_COMPILER_6_UP}\r\n Consts,\r\n{$ENDIF}\r\n{$IFDEF SYN_COMPILER_18_UP}\r\n AnsiStrings,\r\n{$ENDIF}\r\n{$IFDEF SYN_CLX}\r\n QStdActns,\r\n QClipbrd,\r\n QSynEditWordWrap,\r\n QSynEditStrConst;\r\n{$ELSE}\r\n Clipbrd,\r\n ShellAPI,\r\n SynEditWordWrap,\r\n SynEditStrConst, System.Types;\r\n{$ENDIF}\r\n\r\n{$IFDEF SYN_CLX}\r\nconst\r\n FrameWidth = 2; { the border width when BoderStyle = bsSingle (until we support TWidgetStyle...) }\r\n{$ENDIF}\r\n\r\nfunction CeilOfIntDiv(Dividend: Cardinal; Divisor: Word): Word;\r\nVar\r\n Remainder: Word;\r\nbegin\r\n DivMod(Dividend, Divisor, Result, Remainder);\r\n if Remainder > 0 then\r\n Inc(Result);\r\nend;\r\n\r\nfunction TrimTrailingSpaces(const S: UnicodeString): UnicodeString;\r\nvar\r\n I: Integer;\r\nbegin\r\n I := Length(S);\r\n while (I > 0) and ((S[I] = #32) or (S[I] = #9)) do\r\n Dec(I);\r\n Result := Copy(S, 1, I);\r\nend;\r\n\r\n{ THookedCommandHandlerEntry }\r\n\r\ntype\r\n THookedCommandHandlerEntry = class(TObject)\r\n private\r\n fEvent: THookedCommandEvent;\r\n fData: pointer;\r\n constructor Create(AEvent: THookedCommandEvent; AData: pointer);\r\n function Equals(AEvent: THookedCommandEvent): Boolean; {$IFDEF UNICODE} reintroduce; {$ENDIF}\r\n end;\r\n\r\nconstructor THookedCommandHandlerEntry.Create(AEvent: THookedCommandEvent;\r\n AData: pointer);\r\nbegin\r\n inherited Create;\r\n fEvent := AEvent;\r\n fData := AData;\r\nend;\r\n\r\nfunction THookedCommandHandlerEntry.Equals(AEvent: THookedCommandEvent): Boolean;\r\nbegin\r\n with TMethod(fEvent) do\r\n Result := (Code = TMethod(AEvent).Code) and (Data = TMethod(AEvent).Data);\r\nend;\r\n\r\n{ TCustomSynEdit }\r\n\r\nfunction TCustomSynEdit.PixelsToNearestRowColumn(aX, aY: Integer): TDisplayCoord;\r\n// Result is in display coordinates\r\nvar\r\n f: Single;\r\nbegin\r\n{$IFDEF SYN_CLX}\r\n with ClientRect.TopLeft do\r\n begin\r\n Dec(aX, X);\r\n Dec(aY, Y);\r\n end;\r\n{$ENDIF}\r\n f := (aX - fGutterWidth - 2) / fCharWidth;\r\n // don't return a partially visible last line\r\n if aY >= fLinesInWindow * fTextHeight then\r\n begin\r\n aY := fLinesInWindow * fTextHeight - 1;\r\n if aY < 0 then\r\n aY := 0;\r\n end;\r\n Result.Column := Max(1, LeftChar + Round(f));\r\n Result.Row := Max(1, TopLine + (aY div fTextHeight));\r\nend;\r\n\r\nfunction TCustomSynEdit.PixelsToRowColumn(aX, aY: Integer): TDisplayCoord;\r\nbegin\r\n{$IFDEF SYN_CLX}\r\n with ClientRect.TopLeft do\r\n begin\r\n Dec(aX, X);\r\n Dec(aY, Y);\r\n end;\r\n{$ENDIF}\r\n Result.Column := Max(1, LeftChar + ((aX - fGutterWidth - 2) div fCharWidth));\r\n Result.Row := Max(1, TopLine + (aY div fTextHeight));\r\nend;\r\n\r\nfunction TCustomSynEdit.RowColumnToPixels(const RowCol: TDisplayCoord): TPoint;\r\nbegin\r\n Result.X := (RowCol.Column-1) * fCharWidth + fTextOffset;\r\n Result.Y := (RowCol.Row - fTopLine) * fTextHeight;\r\n{$IFDEF SYN_CLX}\r\n with ClientRect.TopLeft do\r\n begin\r\n Inc(Result.X, X);\r\n Inc(Result.Y, Y);\r\n end;\r\n{$ENDIF}\r\nend;\r\n\r\nprocedure TCustomSynEdit.ComputeCaret(X, Y: Integer);\r\n//X,Y are pixel coordinates\r\nvar\r\n vCaretNearestPos : TDisplayCoord;\r\nbegin\r\n vCaretNearestPos := PixelsToNearestRowColumn(X, Y);\r\n vCaretNearestPos.Row := MinMax(vCaretNearestPos.Row, 1, DisplayLineCount);\r\n SetInternalDisplayXY(vCaretNearestPos);\r\nend;\r\n\r\nprocedure TCustomSynEdit.ComputeScroll(X, Y: Integer);\r\n//X,Y are pixel coordinates\r\nvar\r\n iScrollBounds: TRect; { relative to the client area }\r\nbegin\r\n { don't scroll if dragging text from other control }\r\n if (not MouseCapture) and (not Dragging) then\r\n begin\r\n fScrollTimer.Enabled := False;\r\n Exit;\r\n end;\r\n\r\n iScrollBounds := Bounds(fGutterWidth, 0, fCharsInWindow * fCharWidth,\r\n fLinesInWindow * fTextHeight);\r\n if BorderStyle = bsNone then\r\n InflateRect(iScrollBounds, -2, -2);\r\n\r\n if X < iScrollBounds.Left then\r\n fScrollDeltaX := (X - iScrollBounds.Left) div fCharWidth - 1\r\n else if X >= iScrollBounds.Right then\r\n fScrollDeltaX := (X - iScrollBounds.Right) div fCharWidth + 1\r\n else\r\n fScrollDeltaX := 0;\r\n\r\n if Y < iScrollBounds.Top then\r\n fScrollDeltaY := (Y - iScrollBounds.Top) div fTextHeight - 1\r\n else if Y >= iScrollBounds.Bottom then\r\n fScrollDeltaY := (Y - iScrollBounds.Bottom) div fTextHeight + 1\r\n else\r\n fScrollDeltaY := 0;\r\n\r\n fScrollTimer.Enabled := (fScrollDeltaX <> 0) or (fScrollDeltaY <> 0);\r\nend;\r\n\r\nprocedure TCustomSynEdit.DoCopyToClipboard(const SText: UnicodeString);\r\n{$IFNDEF SYN_CLX}\r\nvar\r\n Mem: HGLOBAL;\r\n P: PByte;\r\n SLen: Integer;\r\n{$ENDIF}\r\nbegin\r\n if SText = '' then Exit;\r\n SetClipboardText(SText);\r\n{$IFDEF SYN_CLX}\r\nend;\r\n{$ELSE}\r\n SLen := Length(SText);\r\n // Open and Close are the only TClipboard methods we use because TClipboard\r\n // is very hard (impossible) to work with if you want to put more than one\r\n // format on it at a time.\r\n Clipboard.Open;\r\n try\r\n // Copy it in our custom format so we know what kind of block it is.\r\n // That effects how it is pasted in.\r\n // This format is kept as ANSI to be compatible with programs using the\r\n // ANSI version of Synedit.\r\n Mem := GlobalAlloc(GMEM_MOVEABLE or GMEM_DDESHARE,\r\n sizeof(TSynSelectionMode) + SLen + 1);\r\n if Mem <> 0 then\r\n begin\r\n P := GlobalLock(Mem);\r\n try\r\n if P <> nil then\r\n begin\r\n // Our format: TSynSelectionMode value followed by Ansi-text.\r\n PSynSelectionMode(P)^ := fActiveSelectionMode;\r\n inc(P, SizeOf(TSynSelectionMode));\r\n Move(PAnsiChar(AnsiString(SText))^, P^, SLen + 1);\r\n SetClipboardData(SynEditClipboardFormat, Mem);\r\n end;\r\n finally\r\n GlobalUnlock(Mem);\r\n end;\r\n end;\r\n // Don't free Mem! It belongs to the clipboard now, and it will free it\r\n // when it is done with it.\r\n finally\r\n Clipboard.Close;\r\n end;\r\nend;\r\n{$ENDIF}\r\n\r\nprocedure TCustomSynEdit.CopyToClipboard;\r\nvar\r\n SText: UnicodeString;\r\n ChangeTrim: Boolean;\r\nbegin\r\n if SelAvail then\r\n begin\r\n ChangeTrim := (fActiveSelectionMode = smColumn) and (eoTrimTrailingSpaces in Options);\r\n try\r\n if ChangeTrim then\r\n Exclude(fOptions, eoTrimTrailingSpaces);\r\n SText := SelText;\r\n finally\r\n if ChangeTrim then\r\n Include(fOptions, eoTrimTrailingSpaces);\r\n end;\r\n DoCopyToClipboard(SText);\r\n end;\r\nend;\r\n\r\nprocedure TCustomSynEdit.CutToClipboard;\r\nbegin\r\n if not ReadOnly and SelAvail then\r\n begin\r\n BeginUndoBlock;\r\n try\r\n DoCopyToClipboard(SelText);\r\n SelText := '';\r\n finally\r\n EndUndoBlock;\r\n end;\r\n end;\r\nend;\r\n\r\nconstructor TCustomSynEdit.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n fLines := TSynEditStringList.Create(ExpandAtWideGlyphs);\r\n fOrigLines := fLines;\r\n with TSynEditStringList(fLines) do\r\n begin\r\n OnChange := LinesChanged;\r\n OnChanging := LinesChanging;\r\n OnCleared := ListCleared;\r\n OnDeleted := ListDeleted;\r\n OnInserted := ListInserted;\r\n OnPutted := ListPutted;\r\n end;\r\n fFontDummy := TFont.Create;\r\n fUndoList := TSynEditUndoList.Create;\r\n fUndoList.OnAddedUndo := UndoRedoAdded;\r\n fOrigUndoList := fUndoList;\r\n fRedoList := TSynEditUndoList.Create;\r\n fRedoList.OnAddedUndo := UndoRedoAdded;\r\n fOrigRedoList := fRedoList;\r\n\r\n{$IFDEF SYN_COMPILER_4_UP}\r\n{$IFDEF SYN_CLX}\r\n{$ELSE}\r\n DoubleBuffered := False;\r\n{$ENDIF}\r\n{$ENDIF}\r\n fActiveLineColor := clNone;\r\n fSelectedColor := TSynSelectedColor.Create;\r\n fSelectedColor.OnChange := SelectedColorsChanged;\r\n fBookMarkOpt := TSynBookMarkOpt.Create(Self);\r\n fBookMarkOpt.OnChange := BookMarkOptionsChanged;\r\n// fRightEdge has to be set before FontChanged is called for the first time\r\n fRightEdge := 80;\r\n fGutter := TSynGutter.Create;\r\n fGutter.OnChange := GutterChanged;\r\n fGutterWidth := fGutter.Width;\r\n fWordWrapGlyph := TSynGlyph.Create(HINSTANCE, 'SynEditWrapped', clLime);\r\n fWordWrapGlyph.OnChange := WordWrapGlyphChange;\r\n fTextOffset := fGutterWidth + 2;\r\n ControlStyle := ControlStyle + [csOpaque, csSetCaption];\r\n{$IFDEF SYN_COMPILER_7_UP}\r\n {$IFNDEF SYN_CLX}\r\n ControlStyle := ControlStyle + [csNeedsBorderPaint];\r\n {$ENDIF}\r\n{$ENDIF}\r\n Height := 150;\r\n Width := 200;\r\n Cursor := crIBeam;\r\n Color := clWindow;\r\n{$IFDEF SYN_WIN32}\r\n fFontDummy.Name := 'Courier New';\r\n fFontDummy.Size := 10;\r\n{$ENDIF}\r\n{$IFDEF SYN_KYLIX}\r\n fFontDummy.Name := 'adobe-courier';\r\n if fFontDummy.Name = 'adobe-courier' then\r\n fFontDummy.Size := 12\r\n else begin\r\n fFontDummy.Name := 'terminal';\r\n fFontDummy.Size := 14;\r\n end;\r\n{$ENDIF}\r\n{$IFDEF SYN_COMPILER_3_UP}\r\n fFontDummy.CharSet := DEFAULT_CHARSET;\r\n{$ENDIF}\r\n fTextDrawer := TheTextDrawer.Create([fsBold], fFontDummy);\r\n Font.Assign(fFontDummy);\r\n Font.OnChange := SynFontChanged;\r\n ParentFont := False;\r\n ParentColor := False;\r\n TabStop := True;\r\n fInserting := True;\r\n fMaxScrollWidth := 1024;\r\n fScrollBars := ssBoth;\r\n fBorderStyle := bsSingle;\r\n fInsertCaret := ctVerticalLine;\r\n fOverwriteCaret := ctBlock;\r\n FSelectionMode := smNormal;\r\n fActiveSelectionMode := smNormal;\r\n fFocusList := TList.Create;\r\n fKbdHandler := TSynEditKbdHandler.Create;\r\n fKeystrokes := TSynEditKeyStrokes.Create(Self);\r\n fMarkList := TSynEditMarkList.Create(self);\r\n fMarkList.OnChange := MarkListChange;\r\n SetDefaultKeystrokes;\r\n fRightEdgeColor := clSilver;\r\n fWantReturns := True;\r\n fWantTabs := False;\r\n fTabWidth := 8;\r\n fLeftChar := 1;\r\n fTopLine := 1;\r\n fCaretX := 1;\r\n fLastCaretX := 1;\r\n fCaretY := 1;\r\n fBlockBegin.Char := 1;\r\n fBlockBegin.Line := 1;\r\n fBlockEnd := fBlockBegin;\r\n fOptions := SYNEDIT_DEFAULT_OPTIONS;\r\n fScrollTimer := TTimer.Create(Self);\r\n fScrollTimer.Enabled := False;\r\n fScrollTimer.Interval := 100;\r\n fScrollTimer.OnTimer := ScrollTimerHandler;\r\n\r\n{$IFDEF SYN_CLX}\r\n InputKeys := [ikArrows, ikChars, ikReturns, ikEdit, ikNav, ikEsc];\r\n\r\n FHScrollBar := TSynEditScrollbar.Create(self);\r\n FHScrollBar.Kind := sbHorizontal;\r\n FHScrollBar.Height := CYHSCROLL;\r\n FHScrollBar.OnScroll := ScrollEvent;\r\n FVScrollBar := TSynEditScrollbar.Create(self);\r\n FVScrollBar.Kind := sbVertical;\r\n FVScrollBar.Width := CXVSCROLL;\r\n FVScrollBar.OnScroll := ScrollEvent;\r\n\r\n // Set parent after BOTH scrollbars are created.\r\n FHScrollBar.Parent := Self;\r\n FHScrollBar.Color := clScrollBar;\r\n FVScrollBar.Parent := Self;\r\n FVScrollBar.Color := clScrollBar;\r\n{$ENDIF}\r\n fScrollHintColor := clInfoBk;\r\n fScrollHintFormat := shfTopLineOnly;\r\n\r\n SynFontChanged(nil);\r\nend;\r\n\r\n{$IFNDEF SYN_CLX}\r\nprocedure TCustomSynEdit.CreateParams(var Params: TCreateParams);\r\nconst\r\n BorderStyles: array[TBorderStyle] of DWORD = (0, WS_BORDER);\r\n ClassStylesOff = CS_VREDRAW or CS_HREDRAW;\r\nbegin\r\n // Clear WindowText to avoid it being used as Caption, or else window creation will\r\n // fail if it's bigger than 64KB. It's useless to set the Caption anyway.\r\n StrDispose(WindowText);\r\n WindowText := nil;\r\n inherited CreateParams(Params);\r\n with Params do\r\n begin\r\n WindowClass.Style := WindowClass.Style and not ClassStylesOff;\r\n Style := Style or BorderStyles[fBorderStyle] or WS_CLIPCHILDREN;\r\n\r\n if NewStyleControls and Ctl3D and (fBorderStyle = bsSingle) then\r\n begin\r\n Style := Style and not WS_BORDER;\r\n ExStyle := ExStyle or WS_EX_CLIENTEDGE;\r\n end;\r\n\r\n{$IFNDEF UNICODE}\r\n if not (csDesigning in ComponentState) then\r\n begin\r\n // Necessary for unicode support, especially IME won't work else\r\n if Win32PlatformIsUnicode then\r\n WindowClass.lpfnWndProc := @DefWindowProcW;\r\n end;\r\n{$ENDIF}\r\n end;\r\nend;\r\n{$ENDIF}\r\n\r\nprocedure TCustomSynEdit.DecPaintLock;\r\nvar\r\n vAuxPos: TDisplayCoord;\r\nbegin\r\n Assert(fPaintLock > 0);\r\n Dec(fPaintLock);\r\n if (fPaintLock = 0) and HandleAllocated then\r\n begin\r\n if sfScrollbarChanged in fStateFlags then\r\n UpdateScrollbars;\r\n // Locks the caret inside the visible area\r\n if WordWrap and ([scCaretX,scCaretY] * fStatusChanges <> []) then\r\n begin\r\n vAuxPos := DisplayXY;\r\n // This may happen in the last row of a line or in rows which length is\r\n // greater than CharsInWindow (Tabs and Spaces are allowed beyond\r\n // CharsInWindow while wrapping the lines)\r\n if (vAuxPos.Column > CharsInWindow +1) and (CharsInWindow > 0) then\r\n begin\r\n if fCaretAtEOL then\r\n fCaretAtEOL := False\r\n else\r\n begin\r\n if scCaretY in fStatusChanges then\r\n begin\r\n vAuxPos.Column := CharsInWindow + 1;\r\n fCaretX := DisplayToBufferPos(vAuxPos).Char;\r\n Include(fStatusChanges,scCaretX);\r\n UpdateLastCaretX;\r\n end;\r\n end;\r\n Include(fStateFlags, sfCaretChanged);\r\n end;\r\n end;\r\n if sfCaretChanged in fStateFlags then\r\n UpdateCaret;\r\n if fStatusChanges <> [] then\r\n DoOnStatusChange(fStatusChanges);\r\n end;\r\nend;\r\n\r\ndestructor TCustomSynEdit.Destroy;\r\nbegin\r\n Highlighter := nil;\r\n if (fChainedEditor <> nil) or (fLines <> fOrigLines) then\r\n RemoveLinesPointer;\r\n\r\n inherited Destroy;\r\n\r\n // free listeners while other fields are still valid\r\n\r\n // do not use FreeAndNil, it first nils and then freey causing problems with\r\n // code accessing fHookedCommandHandlers while destruction\r\n fHookedCommandHandlers.Free;\r\n fHookedCommandHandlers := nil;\r\n // do not use FreeAndNil, it first nils and then frees causing problems with\r\n // code accessing fPlugins while destruction\r\n fPlugins.Free;\r\n fPlugins := nil;\r\n\r\n fMarkList.Free;\r\n fBookMarkOpt.Free;\r\n fKeyStrokes.Free;\r\n fKbdHandler.Free;\r\n fFocusList.Free;\r\n fSelectedColor.Free;\r\n fOrigUndoList.Free;\r\n fOrigRedoList.Free;\r\n fGutter.Free;\r\n fWordWrapGlyph.Free;\r\n fTextDrawer.Free;\r\n fInternalImage.Free;\r\n fFontDummy.Free;\r\n fOrigLines.Free;\r\nend;\r\n\r\nfunction TCustomSynEdit.GetBlockBegin: TBufferCoord;\r\nbegin\r\n if (fBlockEnd.Line < fBlockBegin.Line)\r\n or ((fBlockEnd.Line = fBlockBegin.Line) and (fBlockEnd.Char < fBlockBegin.Char))\r\n then\r\n Result := fBlockEnd\r\n else\r\n Result := fBlockBegin;\r\nend;\r\n\r\nfunction TCustomSynEdit.GetBlockEnd: TBufferCoord;\r\nbegin\r\n if (fBlockEnd.Line < fBlockBegin.Line)\r\n or ((fBlockEnd.Line = fBlockBegin.Line) and (fBlockEnd.Char < fBlockBegin.Char))\r\n then\r\n Result := fBlockBegin\r\n else\r\n Result := fBlockEnd;\r\nend;\r\n\r\nprocedure TCustomSynEdit.SynFontChanged(Sender: TObject);\r\nbegin\r\n RecalcCharExtent;\r\n SizeOrFontChanged(True);\r\nend;\r\n\r\nfunction TCustomSynEdit.GetFont: TFont;\r\nbegin\r\n Result := inherited Font;\r\nend;\r\n\r\nfunction TCustomSynEdit.GetLineText: UnicodeString;\r\nbegin\r\n if (CaretY >= 1) and (CaretY <= Lines.Count) then\r\n Result := Lines[CaretY - 1]\r\n else\r\n Result := '';\r\nend;\r\n\r\nfunction TCustomSynEdit.GetSelAvail: Boolean;\r\nbegin\r\n Result := (fBlockBegin.Char <> fBlockEnd.Char) or\r\n ((fBlockBegin.Line <> fBlockEnd.Line) and (fActiveSelectionMode <> smColumn));\r\nend;\r\n\r\nfunction TCustomSynEdit.GetSelTabBlock: Boolean;\r\nbegin\r\n Result := (fBlockBegin.Line <> fBlockEnd.Line) and (fActiveSelectionMode <> smColumn);\r\nend;\r\n\r\nfunction TCustomSynEdit.GetSelTabLine: Boolean;\r\nbegin\r\n Result := (BlockBegin.Char <= 1) and (BlockEnd.Char > length(Lines[CaretY - 1])) and SelAvail;\r\nend;\r\n\r\nfunction TCustomSynEdit.GetSelText: UnicodeString;\r\n\r\n function CopyPadded(const S: UnicodeString; Index, Count: Integer): UnicodeString;\r\n var\r\n SrcLen: Integer;\r\n DstLen: Integer;\r\n i: Integer;\r\n P: PWideChar;\r\n begin\r\n SrcLen := Length(S);\r\n DstLen := Index + Count;\r\n if SrcLen >= DstLen then\r\n Result := Copy(S, Index, Count)\r\n else begin\r\n SetLength(Result, DstLen);\r\n P := PWideChar(Result);\r\n WStrCopy(P, PWideChar(Copy(S, Index, Count)));\r\n Inc(P, Length(S));\r\n for i := 0 to DstLen - Srclen - 1 do\r\n P[i] := #32;\r\n end;\r\n end;\r\n\r\n procedure CopyAndForward(const S: UnicodeString; Index, Count: Integer; var P:\r\n PWideChar);\r\n var\r\n pSrc: PWideChar;\r\n SrcLen: Integer;\r\n DstLen: Integer;\r\n begin\r\n SrcLen := Length(S);\r\n if (Index <= SrcLen) and (Count > 0) then\r\n begin\r\n Dec(Index);\r\n pSrc := PWideChar(S) + Index;\r\n DstLen := Min(SrcLen - Index, Count);\r\n Move(pSrc^, P^, DstLen * sizeof(WideChar));\r\n Inc(P, DstLen);\r\n P^ := #0;\r\n end;\r\n end;\r\n\r\n function CopyPaddedAndForward(const S: UnicodeString; Index, Count: Integer;\r\n var P: PWideChar): Integer;\r\n var\r\n OldP: PWideChar;\r\n Len, i: Integer;\r\n begin\r\n Result := 0;\r\n OldP := P;\r\n CopyAndForward(S, Index, Count, P);\r\n Len := Count - (P - OldP);\r\n if not (eoTrimTrailingSpaces in Options) then\r\n begin\r\n for i := 0 to Len - 1 do\r\n P[i] := #32;\r\n Inc(P, Len);\r\n end\r\n else\r\n Result:= Len;\r\n end;\r\n\r\nvar\r\n First, Last, TotalLen: Integer;\r\n ColFrom, ColTo: Integer;\r\n I: Integer;\r\n l, r: Integer;\r\n s: UnicodeString;\r\n P: PWideChar;\r\n cRow: Integer;\r\n vAuxLineChar: TBufferCoord;\r\n vAuxRowCol: TDisplayCoord;\r\n vTrimCount: Integer;\r\nbegin\r\n if not SelAvail then\r\n Result := ''\r\n else begin\r\n ColFrom := BlockBegin.Char;\r\n First := BlockBegin.Line - 1;\r\n //\r\n ColTo := BlockEnd.Char;\r\n Last := BlockEnd.Line - 1;\r\n //\r\n TotalLen := 0;\r\n case fActiveSelectionMode of\r\n smNormal:\r\n if (First = Last) then\r\n Result := Copy(Lines[First], ColFrom, ColTo - ColFrom)\r\n else begin\r\n // step1: calculate total length of result string\r\n TotalLen := Max(0, Length(Lines[First]) - ColFrom + 1);\r\n for i := First + 1 to Last - 1 do\r\n Inc(TotalLen, Length(Lines[i]));\r\n Inc(TotalLen, ColTo - 1);\r\n Inc(TotalLen, Length(SLineBreak) * (Last - First));\r\n // step2: build up result string\r\n SetLength(Result, TotalLen);\r\n P := PWideChar(Result);\r\n CopyAndForward(Lines[First], ColFrom, MaxInt, P);\r\n\r\n CopyAndForward(SLineBreak, 1, MaxInt, P);\r\n\r\n for i := First + 1 to Last - 1 do\r\n begin\r\n CopyAndForward(Lines[i], 1, MaxInt, P);\r\n CopyAndForward(SLineBreak, 1, MaxInt, P);\r\n end;\r\n CopyAndForward(Lines[Last], 1, ColTo - 1, P);\r\n end;\r\n smColumn:\r\n begin\r\n with BufferToDisplayPos(BlockBegin) do\r\n begin\r\n First := Row;\r\n ColFrom := Column;\r\n end;\r\n with BufferToDisplayPos(BlockEnd) do\r\n begin\r\n Last := Row;\r\n ColTo := Column;\r\n end;\r\n if ColFrom > ColTo then\r\n SwapInt(ColFrom, ColTo);\r\n // step1: pre-allocate string large enough for worst case\r\n TotalLen := ((ColTo - ColFrom) + Length(sLineBreak)) *\r\n (Last - First +1);\r\n SetLength(Result, TotalLen);\r\n P := PWideChar(Result);\r\n\r\n // step2: copy chunks to the pre-allocated string\r\n TotalLen := 0;\r\n for cRow := First to Last do\r\n begin\r\n vAuxRowCol.Row := cRow;\r\n vAuxRowCol.Column := ColFrom;\r\n vAuxLineChar := DisplayToBufferPos(vAuxRowCol);\r\n l := vAuxLineChar.Char;\r\n s := Lines[vAuxLineChar.Line - 1];\r\n vAuxRowCol.Column := ColTo;\r\n r := DisplayToBufferPos(vAuxRowCol).Char;\r\n\r\n vTrimCount := CopyPaddedAndForward(s, l, r - l, P);\r\n TotalLen := TotalLen + (r - l) - vTrimCount + Length(sLineBreak);\r\n CopyAndForward(sLineBreak, 1, MaxInt, P);\r\n end;\r\n SetLength(Result, TotalLen - Length(sLineBreak));\r\n end;\r\n smLine:\r\n begin\r\n // If block selection includes LastLine,\r\n // line break code(s) of the last line will not be added.\r\n // step1: calculate total length of result string\r\n for i := First to Last do\r\n Inc(TotalLen, Length(Lines[i]) + Length(SLineBreak));\r\n if Last = Lines.Count then\r\n Dec(TotalLen, Length(SLineBreak));\r\n // step2: build up result string\r\n SetLength(Result, TotalLen);\r\n P := PWideChar(Result);\r\n for i := First to Last - 1 do\r\n begin\r\n CopyAndForward(Lines[i], 1, MaxInt, P);\r\n CopyAndForward(SLineBreak, 1, MaxInt, P);\r\n end;\r\n CopyAndForward(Lines[Last], 1, MaxInt, P);\r\n if (Last + 1) < Lines.Count then\r\n CopyAndForward(SLineBreak, 1, MaxInt, P);\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TCustomSynEdit.SynGetText: UnicodeString;\r\nbegin\r\n Result := Lines.Text;\r\nend;\r\n\r\nfunction TCustomSynEdit.GetWordAtCursor: UnicodeString;\r\nbegin\r\n Result:=GetWordAtRowCol(CaretXY);\r\nend;\r\n\r\nprocedure TCustomSynEdit.HideCaret;\r\nbegin\r\n if sfCaretVisible in fStateFlags then\r\n{$IFDEF SYN_CLX}\r\n kTextDrawer.HideCaret(Self);\r\n{$ELSE}\r\n if Windows.HideCaret(Handle) then\r\n{$ENDIF}\r\n Exclude(fStateFlags, sfCaretVisible);\r\nend;\r\n\r\nprocedure TCustomSynEdit.IncPaintLock;\r\nbegin\r\n inc(fPaintLock);\r\nend;\r\n\r\nprocedure TCustomSynEdit.InvalidateGutter;\r\nbegin\r\n InvalidateGutterLines(-1, -1);\r\nend;\r\n\r\nprocedure TCustomSynEdit.InvalidateGutterLine(aLine: Integer);\r\nbegin\r\n if (aLine < 1) or (aLine > Lines.Count) then\r\n Exit;\r\n\r\n InvalidateGutterLines(aLine, aLine);\r\nend;\r\n\r\nprocedure TCustomSynEdit.InvalidateGutterLines(FirstLine, LastLine: integer);\r\n// note: FirstLine and LastLine don't need to be in correct order\r\nvar\r\n rcInval: TRect;\r\nbegin\r\n if Visible and HandleAllocated then\r\n if (FirstLine = -1) and (LastLine = -1) then\r\n begin\r\n rcInval := Rect(0, 0, fGutterWidth, ClientHeight);\r\n{$IFDEF SYN_CLX}\r\n with GetClientRect do\r\n OffsetRect(rcInval, Left, Top);\r\n{$ENDIF}\r\n if sfLinesChanging in fStateFlags then\r\n UnionRect(fInvalidateRect, fInvalidateRect, rcInval)\r\n else\r\n InvalidateRect(rcInval, False);\r\n end\r\n else begin\r\n { find the visible lines first }\r\n if (LastLine < FirstLine) then\r\n SwapInt(LastLine, FirstLine);\r\n if WordWrap then\r\n begin\r\n FirstLine := LineToRow(FirstLine);\r\n if LastLine <= Lines.Count then\r\n LastLine := LineToRow(LastLine)\r\n else\r\n LastLine := MaxInt;\r\n end;\r\n FirstLine := Max(FirstLine, TopLine);\r\n LastLine := Min(LastLine, TopLine + LinesInWindow);\r\n { any line visible? }\r\n if (LastLine >= FirstLine) then\r\n begin\r\n rcInval := Rect(0, fTextHeight * (FirstLine - TopLine),\r\n fGutterWidth, fTextHeight * (LastLine - TopLine + 1));\r\n{$IFDEF SYN_CLX}\r\n with GetClientRect do\r\n OffsetRect(rcInval, Left, Top);\r\n{$ENDIF}\r\n if sfLinesChanging in fStateFlags then\r\n UnionRect(fInvalidateRect, fInvalidateRect, rcInval)\r\n else\r\n InvalidateRect(rcInval, False);\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TCustomSynEdit.InvalidateLines(FirstLine, LastLine: integer);\r\n// note: FirstLine and LastLine don't need to be in correct order\r\nvar\r\n rcInval: TRect;\r\nbegin\r\n if Visible and HandleAllocated then\r\n if (FirstLine = -1) and (LastLine = -1) then\r\n begin\r\n rcInval := ClientRect;\r\n Inc(rcInval.Left, fGutterWidth);\r\n if sfLinesChanging in fStateFlags then\r\n UnionRect(fInvalidateRect, fInvalidateRect, rcInval)\r\n else\r\n InvalidateRect(rcInval, False);\r\n end\r\n else begin\r\n FirstLine := Max(FirstLine,1);\r\n LastLine := Max(LastLine,1);\r\n { find the visible lines first }\r\n if (LastLine < FirstLine) then\r\n SwapInt(LastLine, FirstLine);\r\n\r\n if LastLine >= Lines.Count then\r\n LastLine := MaxInt; // paint empty space beyond last line\r\n\r\n if WordWrap then\r\n begin\r\n FirstLine := LineToRow(FirstLine);\r\n // Could avoid this conversion if (First = Last) and\r\n // (Length < CharsInWindow) but the dependency isn't worth IMO.\r\n if LastLine < Lines.Count then\r\n LastLine := LineToRow(LastLine + 1) - 1;\r\n end;\r\n\r\n // TopLine is in display coordinates, so FirstLine and LastLine must be\r\n // converted previously.\r\n FirstLine := Max(FirstLine, TopLine);\r\n LastLine := Min(LastLine, TopLine + LinesInWindow);\r\n\r\n { any line visible? }\r\n if (LastLine >= FirstLine) then\r\n begin\r\n rcInval := Rect(fGutterWidth, fTextHeight * (FirstLine - TopLine),\r\n ClientWidth, fTextHeight * (LastLine - TopLine + 1));\r\n{$IFDEF SYN_CLX}\r\n with GetClientRect do\r\n OffsetRect(rcInval, Left, Top);\r\n{$ENDIF}\r\n if sfLinesChanging in fStateFlags then\r\n UnionRect(fInvalidateRect, fInvalidateRect, rcInval)\r\n else\r\n InvalidateRect(rcInval, False);\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TCustomSynEdit.InvalidateSelection;\r\nbegin\r\n InvalidateLines(BlockBegin.Line, BlockEnd.Line);\r\nend;\r\n\r\n{$IFDEF SYN_COMPILER_5}\r\nfunction TryStrToInt(const S: string; out Value: Integer): Boolean;\r\nvar\r\n E: Integer;\r\nbegin\r\n Val(S, Value, E);\r\n Result := E = 0;\r\nend;\r\n{$ENDIF}\r\n\r\nprocedure TCustomSynEdit.KeyUp(var Key: Word; Shift: TShiftState);\r\n{$IFDEF SYN_LINUX}\r\nvar\r\n Code: Byte;\r\n{$ENDIF}\r\n{$IFNDEF SYN_CLX}\r\nvar\r\n CharCode: Integer;\r\n KeyMsg: TWMKey;\r\n{$ENDIF}\r\nbegin\r\n {$IFDEF SYN_LINUX}\r\n // uniform Keycode: key has the same value wether Shift is pressed or not\r\n if Key <= 255 then\r\n begin\r\n Code := XKeysymToKeycode(Xlib.PDisplay(QtDisplay), Key);\r\n Key := XKeycodeToKeysym(Xlib.PDisplay(QtDisplay), Code, 0);\r\n if AnsiChar(Key) in ['a'..'z'] then Key := Ord(UpCase(AnsiChar(Key)));\r\n end;\r\n {$ENDIF}\r\n\r\n {$IFNDEF SYN_CLX}\r\n if (ssAlt in Shift) and (Key >= VK_NUMPAD0) and (Key <= VK_NUMPAD9) then\r\n FCharCodeString := FCharCodeString + IntToStr(Key - VK_NUMPAD0);\r\n\r\n if Key = VK_MENU then\r\n begin\r\n if (FCharCodeString <> '') and TryStrToInt(FCharCodeString, CharCode) and\r\n (CharCode >= 256) and (CharCode <= 65535) then\r\n begin\r\n KeyMsg.Msg := WM_CHAR;\r\n KeyMsg.CharCode := CharCode;\r\n KeyMsg.Unused := 0;\r\n KeyMsg.KeyData := 0;\r\n DoKeyPressW(KeyMsg);\r\n FIgnoreNextChar := True;\r\n end;\r\n FCharCodeString := '';\r\n end;\r\n {$ENDIF}\r\n\r\n inherited;\r\n fKbdHandler.ExecuteKeyUp(Self, Key, Shift);\r\nend;\r\n\r\nprocedure TCustomSynEdit.KeyDown(var Key: Word; Shift: TShiftState);\r\nvar\r\n Data: pointer;\r\n C: WideChar;\r\n Cmd: TSynEditorCommand;\r\n {$IFDEF SYN_LINUX}\r\n Code: Byte;\r\n {$ENDIF}\r\nbegin\r\n {$IFDEF SYN_LINUX}\r\n // uniform Keycode: key has the same value wether Shift is pressed or not\r\n if Key <= 255 then\r\n begin\r\n Code := XKeysymToKeycode(Xlib.PDisplay(QtDisplay), Key);\r\n Key := XKeycodeToKeysym(Xlib.PDisplay(QtDisplay), Code, 0);\r\n if AnsiChar(Key) in ['a'..'z'] then Key := Ord(UpCase(AnsiChar(Key)));\r\n end;\r\n {$ENDIF}\r\n inherited;\r\n fKbdHandler.ExecuteKeyDown(Self, Key, Shift);\r\n\r\n Data := nil;\r\n C := #0;\r\n try\r\n Cmd := TranslateKeyCode(Key, Shift, Data);\r\n if Cmd <> ecNone then begin\r\n Key := 0; // eat it.\r\n Include(fStateFlags, sfIgnoreNextChar);\r\n CommandProcessor(Cmd, C, Data);\r\n end\r\n else\r\n Exclude(fStateFlags, sfIgnoreNextChar);\r\n finally\r\n if Data <> nil then\r\n FreeMem(Data);\r\n end;\r\nend;\r\n\r\nprocedure TCustomSynEdit.Loaded;\r\nbegin\r\n inherited Loaded;\r\n GutterChanged(Self);\r\n UpdateScrollBars;\r\nend;\r\n\r\nprocedure TCustomSynEdit.KeyPress(var Key: Char);\r\n{$IFDEF SYN_CLX}\r\nvar\r\n KeyW: WideChar;\r\n{$ENDIF}\r\nbegin\r\n{$IFDEF SYN_CLX}\r\n KeyW := WideChar(Key);\r\n DoKeyPressW(KeyW);\r\n if KeyW > High(AnsiChar) then\r\n Key := #0\r\n else\r\n Key := AnsiChar(KeyW);\r\n{$ELSE}\r\n // for Windows, don't do anything here\r\n{$ENDIF}\r\nend;\r\n\r\n{$IFDEF SYN_CLX}\r\nprocedure TCustomSynEdit.DoKeyPressW(var Key: WideChar);\r\nbegin\r\n if (csNoStdEvents in ControlStyle) then Exit;\r\n\r\n if (Key <> #0) and Assigned(FOnKeyPressW) then\r\n FOnKeyPressW(Self, Key);\r\n\r\n if WideChar(Key) <> #0 then\r\n KeyPressW(Key);\r\nend;\r\n{$ELSE}\r\ntype\r\n TAccessWinControl = class(TWinControl);\r\n\r\n{.$MESSAGE 'Check what must be adapted in DoKeyPressW and related methods'}\r\nprocedure TCustomSynEdit.DoKeyPressW(var Message: TWMKey);\r\nvar\r\n Form: TCustomForm;\r\n Key: WideChar;\r\nbegin\r\n if FIgnoreNextChar then\r\n begin\r\n FIgnoreNextChar := False;\r\n Exit;\r\n end;\r\n\r\n Key := WideChar(Message.CharCode);\r\n\r\n Form := GetParentForm(Self);\r\n if (Form <> nil) and (Form <> TWinControl(Self)) and Form.KeyPreview and\r\n (Key <= High(AnsiChar)) and TAccessWinControl(Form).DoKeyPress(Message)\r\n then\r\n Exit;\r\n Key := WideChar(Message.CharCode);\r\n\r\n if (csNoStdEvents in ControlStyle) then Exit;\r\n\r\n if Assigned(FOnKeyPressW) then\r\n FOnKeyPressW(Self, Key);\r\n\r\n if WideChar(Key) <> #0 then\r\n KeyPressW(Key);\r\nend;\r\n{$ENDIF}\r\n\r\nprocedure TCustomSynEdit.KeyPressW(var Key: WideChar);\r\nbegin\r\n // don't fire the event if key is to be ignored\r\n if not (sfIgnoreNextChar in fStateFlags) then\r\n begin\r\n fKbdHandler.ExecuteKeyPress(Self, Key);\r\n CommandProcessor(ecChar, Key, nil);\r\n end\r\n else\r\n // don't ignore further keys\r\n Exclude(fStateFlags, sfIgnoreNextChar);\r\nend;\r\n\r\nfunction TCustomSynEdit.LeftSpaces(const Line: UnicodeString): Integer;\r\nbegin\r\n Result := LeftSpacesEx(Line, False);\r\nend;\r\n\r\nfunction TCustomSynEdit.LeftSpacesEx(const Line: UnicodeString; WantTabs: Boolean): Integer;\r\nvar\r\n p: PWideChar;\r\nbegin\r\n p := PWideChar(Line);\r\n if Assigned(p) and (eoAutoIndent in fOptions) then\r\n begin\r\n Result := 0;\r\n while (p^ >= #1) and (p^ <= #32) do\r\n begin\r\n if (p^ = #9) and WantTabs then\r\n Inc(Result, TabWidth)\r\n else\r\n Inc(Result);\r\n Inc(p);\r\n end;\r\n end\r\n else\r\n Result := 0;\r\nend;\r\n\r\nfunction TCustomSynEdit.GetLeftSpacing(CharCount: Integer; WantTabs: Boolean): UnicodeString;\r\nbegin\r\n if WantTabs and not(eoTabsToSpaces in Options) and (CharCount >= TabWidth) then\r\n Result := UnicodeStringOfChar(#9, CharCount div TabWidth) +\r\n UnicodeStringOfChar(#32, CharCount mod TabWidth)\r\n else\r\n Result := UnicodeStringOfChar(#32, CharCount);\r\nend;\r\n\r\nprocedure TCustomSynEdit.LinesChanging(Sender: TObject);\r\nbegin\r\n Include(fStateFlags, sfLinesChanging);\r\nend;\r\n\r\nprocedure TCustomSynEdit.LinesChanged(Sender: TObject);\r\nvar\r\n vOldMode: TSynSelectionMode;\r\nbegin\r\n Exclude(fStateFlags, sfLinesChanging);\r\n if HandleAllocated then\r\n begin\r\n UpdateScrollBars;\r\n vOldMode := fActiveSelectionMode;\r\n SetBlockBegin(CaretXY);\r\n fActiveSelectionMode := vOldMode;\r\n InvalidateRect(fInvalidateRect, False);\r\n FillChar(fInvalidateRect, SizeOf(TRect), 0);\r\n if fGutter.ShowLineNumbers and fGutter.AutoSize then\r\n fGutter.AutoSizeDigitCount(Lines.Count);\r\n if not (eoScrollPastEof in Options) then\r\n TopLine := TopLine;\r\n end;\r\nend;\r\n\r\nprocedure TCustomSynEdit.MouseDown(Button: TMouseButton; Shift: TShiftState;\r\n X, Y: Integer);\r\nvar\r\n bWasSel: Boolean;\r\n bStartDrag: Boolean;\r\n TmpBegin, TmpEnd: TBufferCoord;\r\nbegin\r\n {$IFDEF SYN_CLX}\r\n if not PtInRect(GetClientRect, Point(X,Y)) then\r\n Exit;\r\n {$ENDIF}\r\n\r\n TmpBegin := FBlockBegin;\r\n TmpEnd := FBlockEnd;\r\n\r\n bWasSel := False;\r\n bStartDrag := False;\r\n if Button = mbLeft then\r\n begin\r\n if SelAvail then\r\n begin\r\n //remember selection state, as it will be cleared later\r\n bWasSel := True;\r\n fMouseDownX := X;\r\n fMouseDownY := Y;\r\n end;\r\n end;\r\n\r\n inherited MouseDown(Button, Shift, X, Y);\r\n\r\n if (Button = mbLeft) and (ssDouble in Shift) then Exit;\r\n\r\n fKbdHandler.ExecuteMouseDown(Self, Button, Shift, X, Y);\r\n\r\n if (Button in [mbLeft, mbRight]) then\r\n begin\r\n if Button = mbRight then\r\n begin\r\n if (eoRightMouseMovesCursor in Options) and\r\n (SelAvail and not IsPointInSelection(DisplayToBufferPos(PixelsToRowColumn(X, Y)))\r\n or not SelAvail) then\r\n begin\r\n InvalidateSelection;\r\n FBlockEnd := FBlockBegin;\r\n ComputeCaret(X, Y);\r\n end\r\n else\r\n Exit;\r\n end\r\n else\r\n ComputeCaret(X, Y);\r\n end;\r\n\r\n if Button = mbLeft then\r\n begin\r\n //I couldn't track down why, but sometimes (and definately not all the time)\r\n //the block positioning is lost. This makes sure that the block is\r\n //maintained in case they started a drag operation on the block\r\n FBlockBegin := TmpBegin;\r\n FBlockEnd := TmpEnd;\r\n\r\n MouseCapture := True;\r\n //if mousedown occurred in selected block begin drag operation\r\n Exclude(fStateFlags, sfWaitForDragging);\r\n if bWasSel and (eoDragDropEditing in fOptions) and (X >= fGutterWidth + 2)\r\n and (SelectionMode = smNormal) and IsPointInSelection(DisplayToBufferPos(PixelsToRowColumn(X, Y))) then\r\n begin\r\n bStartDrag := True\r\n end;\r\n end;\r\n\r\n if (Button = mbLeft) and bStartDrag then\r\n Include(fStateFlags, sfWaitForDragging)\r\n else\r\n begin\r\n if not (sfDblClicked in fStateFlags) then\r\n begin\r\n if ssShift in Shift then\r\n //BlockBegin and BlockEnd are restored to their original position in the\r\n //code from above and SetBlockEnd will take care of proper invalidation\r\n SetBlockEnd(CaretXY)\r\n else\r\n begin\r\n if (eoAltSetsColumnMode in Options) and (fActiveSelectionMode <> smLine) then\r\n begin\r\n if ssAlt in Shift then\r\n SelectionMode := smColumn\r\n else\r\n SelectionMode := smNormal;\r\n end;\r\n //Selection mode must be set before calling SetBlockBegin\r\n SetBlockBegin(CaretXY);\r\n end;\r\n end;\r\n end;\r\n\r\n if (X < fGutterWidth) then\r\n Include(fStateFlags, sfPossibleGutterClick);\r\n if (sfPossibleGutterClick in fStateFlags) and (Button = mbRight) then\r\n begin\r\n DoOnGutterClick(Button, X, Y)\r\n end;\r\n\r\n SetFocus;\r\n{$IFNDEF SYN_CLX}\r\n Windows.SetFocus(Handle);\r\n{$ENDIF}\r\nend;\r\n\r\nprocedure TCustomSynEdit.MouseMove(Shift: TShiftState; X, Y: Integer);\r\nvar\r\n P: TDisplayCoord;\r\nbegin\r\n{$IFDEF SYN_CLX}\r\n if not InDragDropOperation then\r\n UpdateMouseCursor;\r\n{$ENDIF}\r\n inherited MouseMove(Shift, x, y);\r\n if MouseCapture and (sfWaitForDragging in fStateFlags) then\r\n begin\r\n if (Abs(fMouseDownX - X) >= GetSystemMetrics(SM_CXDRAG))\r\n or (Abs(fMouseDownY - Y) >= GetSystemMetrics(SM_CYDRAG)) then\r\n begin\r\n Exclude(fStateFlags, sfWaitForDragging);\r\n BeginDrag(False);\r\n{$IFDEF SYN_CLX}\r\n MouseCapture := False;\r\n{$ENDIF}\r\n end;\r\n end\r\n else if (ssLeft in Shift) and MouseCapture then\r\n begin\r\n // should we begin scrolling?\r\n ComputeScroll(X, Y);\r\n { compute new caret }\r\n P := PixelsToNearestRowColumn(X, Y);\r\n P.Row := MinMax(P.Row, 1, DisplayLineCount);\r\n if fScrollDeltaX <> 0 then\r\n P.Column := DisplayX;\r\n if fScrollDeltaY <> 0 then\r\n P.Row := DisplayY;\r\n InternalCaretXY := DisplayToBufferPos(P);\r\n BlockEnd := CaretXY;\r\n if (sfPossibleGutterClick in fStateFlags) and (FBlockBegin.Line <> CaretXY.Line) then\r\n Include(fStateFlags, sfGutterDragging);\r\n end;\r\nend;\r\n\r\nprocedure TCustomSynEdit.ScrollTimerHandler(Sender: TObject);\r\nvar\r\n iMousePos: TPoint;\r\n C: TDisplayCoord;\r\n X, Y: Integer;\r\n vCaret: TBufferCoord;\r\nbegin\r\n GetCursorPos( iMousePos );\r\n iMousePos := ScreenToClient( iMousePos );\r\n C := PixelsToRowColumn( iMousePos.X, iMousePos.Y );\r\n C.Row := MinMax(C.Row, 1, DisplayLineCount);\r\n if fScrollDeltaX <> 0 then\r\n begin\r\n LeftChar := LeftChar + fScrollDeltaX;\r\n X := LeftChar;\r\n if fScrollDeltaX > 0 then // scrolling right?\r\n Inc(X, CharsInWindow);\r\n C.Column := X;\r\n end;\r\n if fScrollDeltaY <> 0 then\r\n begin\r\n{$IFDEF SYN_CLX}\r\n if ssShift in Application.KeyState then\r\n{$ELSE}\r\n if GetKeyState(SYNEDIT_SHIFT) < 0 then\r\n{$ENDIF}\r\n TopLine := TopLine + fScrollDeltaY * LinesInWindow\r\n else\r\n TopLine := TopLine + fScrollDeltaY;\r\n Y := TopLine;\r\n if fScrollDeltaY > 0 then // scrolling down?\r\n Inc(Y, LinesInWindow - 1);\r\n C.Row := MinMax(Y, 1, DisplayLineCount);\r\n end;\r\n vCaret := DisplayToBufferPos(C);\r\n if (CaretX <> vCaret.Char) or (CaretY <> vCaret.Line) then\r\n begin\r\n // changes to line / column in one go\r\n IncPaintLock;\r\n try\r\n InternalCaretXY := vCaret;\r\n // if MouseCapture is True we're changing selection. otherwise we're dragging\r\n if MouseCapture then\r\n SetBlockEnd(CaretXY);\r\n finally\r\n DecPaintLock;\r\n end;\r\n end;\r\n ComputeScroll(iMousePos.x, iMousePos.y);\r\nend;\r\n\r\nprocedure TCustomSynEdit.MouseUp(Button: TMouseButton; Shift: TShiftState;\r\n X, Y: Integer);\r\nbegin\r\n inherited MouseUp(Button, Shift, X, Y);\r\n fKbdHandler.ExecuteMouseUp(Self, Button, Shift, X, Y);\r\n\r\n fScrollTimer.Enabled := False;\r\n if (Button = mbRight) and (Shift = [ssRight]) and Assigned(PopupMenu) then\r\n exit;\r\n MouseCapture := False;\r\n if (sfPossibleGutterClick in fStateFlags) and (X < fGutterWidth) and (Button <> mbRight) then\r\n begin\r\n DoOnGutterClick(Button, X, Y)\r\n end\r\n else if fStateFlags * [sfDblClicked, sfWaitForDragging] = [sfWaitForDragging] then\r\n begin\r\n ComputeCaret(X, Y);\r\n if not(ssShift in Shift) then\r\n SetBlockBegin(CaretXY);\r\n SetBlockEnd(CaretXY);\r\n Exclude(fStateFlags, sfWaitForDragging);\r\n end;\r\n Exclude(fStateFlags, sfDblClicked);\r\n Exclude(fStateFlags, sfPossibleGutterClick);\r\n Exclude(fStateFlags, sfGutterDragging);\r\nend;\r\n\r\nprocedure TCustomSynEdit.DoOnGutterClick(Button: TMouseButton; X, Y: Integer);\r\nvar\r\n i : Integer;\r\n offs : Integer;\r\n line : Integer;\r\n allmrk: TSynEditMarks;\r\n mark : TSynEditMark;\r\nbegin\r\n if Assigned(fOnGutterClick) then\r\n begin\r\n line := DisplayToBufferPos(PixelsToRowColumn(X,Y)).Line;\r\n if line <= Lines.Count then\r\n begin\r\n Marks.GetMarksForLine(line, allmrk);\r\n offs := 0;\r\n mark := nil;\r\n for i := 1 to MAX_MARKS do\r\n begin\r\n if assigned(allmrk[i]) then\r\n begin\r\n Inc(offs, BookMarkOptions.XOffset);\r\n if X < offs then\r\n begin\r\n mark := allmrk[i];\r\n break;\r\n end;\r\n end;\r\n end; //for\r\n fOnGutterClick(Self, Button, X, Y, line, mark);\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TCustomSynEdit.Paint;\r\nvar\r\n rcClip, rcDraw: TRect;\r\n nL1, nL2, nC1, nC2: Integer;\r\n{$IFDEF SYN_CLX}\r\n iRestoreViewPort: Boolean;\r\n iClientRect: TRect;\r\n iClientRegion: QRegionH;\r\n iClip: QRegionH;\r\n{$ENDIF}\r\nbegin\r\n{$IFDEF SYN_CLX}\r\n { draws the lower-right corner of the scrollbars }\r\n if FHScrollBar.Visible and FVScrollBar.Visible then\r\n begin\r\n Canvas.Brush.Color := FHScrollBar.Color;\r\n Canvas.FillRect(Bounds(FVScrollBar.Left, FHScrollBar.Top,\r\n FVScrollBar.Width, FHScrollBar.Height));\r\n end;\r\n { validates the NC area }\r\n iClientRect := GetClientRect;\r\n iClientRegion := QRegion_create(@iClientRect, QRegionRegionType_Rectangle);\r\n iClip := QPainter_clipRegion(Canvas.Handle);\r\n QRegion_intersect(iClip, iClip, iClientRegion);\r\n QRegion_destroy(iClientRegion);\r\n if BorderStyle <> bsNone then\r\n begin\r\n { draws the border }\r\n iClientRect := Rect( 0, 0, Width, Height );\r\n QClxDrawUtil_DrawWinPanel(Canvas.Handle, @iClientRect,\r\n Palette.ColorGroup(cgActive), True, QBrushH(0));\r\n { sets transformation to ignore NC area }\r\n OffsetRect(iClientRect, FrameWidth, FrameWidth);\r\n QPainter_setViewport(Canvas.Handle, @iClientRect);\r\n iRestoreViewPort := True;\r\n end\r\n else\r\n iRestoreViewPort := False;\r\n { Compute the invalidated rect. }\r\n rcClip := Canvas.ClipRect;\r\n OffsetRect(rcClip, - iClientRect.Left, - iClientRect.Top);\r\n{$ELSE}\r\n // Get the invalidated rect. Compute the invalid area in lines / columns.\r\n rcClip := Canvas.ClipRect;\r\n{$ENDIF}\r\n // columns\r\n nC1 := LeftChar;\r\n if (rcClip.Left > fGutterWidth + 2) then\r\n Inc(nC1, (rcClip.Left - fGutterWidth - 2) div CharWidth);\r\n nC2 := LeftChar +\r\n (rcClip.Right - fGutterWidth - 2 + CharWidth - 1) div CharWidth;\r\n // lines\r\n nL1 := Max(TopLine + rcClip.Top div fTextHeight, TopLine);\r\n nL2 := MinMax(TopLine + (rcClip.Bottom + fTextHeight - 1) div fTextHeight,\r\n 1, DisplayLineCount);\r\n // Now paint everything while the caret is hidden.\r\n HideCaret;\r\n try\r\n // First paint the gutter area if it was (partly) invalidated.\r\n if (rcClip.Left < fGutterWidth) then\r\n begin\r\n rcDraw := rcClip;\r\n rcDraw.Right := fGutterWidth;\r\n PaintGutter(rcDraw, nL1, nL2);\r\n end;\r\n // Then paint the text area if it was (partly) invalidated.\r\n if (rcClip.Right > fGutterWidth) then\r\n begin\r\n rcDraw := rcClip;\r\n rcDraw.Left := Max(rcDraw.Left, fGutterWidth);\r\n PaintTextLines(rcDraw, nL1, nL2, nC1, nC2);\r\n end;\r\n PluginsAfterPaint(Canvas, rcClip, nL1, nL2);\r\n{$IFDEF SYN_CLX}\r\n if iRestoreViewPort then\r\n QPainter_setViewport(Canvas.Handle, 0, 0, Width, Height);\r\n{$ENDIF}\r\n // If there is a custom paint handler call it.\r\n DoOnPaint;\r\n DoOnPaintTransient(ttAfter);\r\n finally\r\n UpdateCaret;\r\n end;\r\nend;\r\n\r\nprocedure TCustomSynEdit.PaintGutter(const AClip: TRect;\r\n const aFirstRow, aLastRow: Integer);\r\n\r\n procedure DrawMark(aMark: TSynEditMark; var aGutterOff: Integer;\r\n aMarkRow: Integer);\r\n begin\r\n if (not aMark.InternalImage) and Assigned(fBookMarkOpt.BookmarkImages) then\r\n begin\r\n if aMark.ImageIndex <= fBookMarkOpt.BookmarkImages.Count then\r\n begin\r\n if aMark.IsBookmark = BookMarkOptions.DrawBookmarksFirst then\r\n aGutterOff := 0\r\n else if aGutterOff = 0 then\r\n aGutterOff := fBookMarkOpt.XOffset;\r\n with fBookMarkOpt do\r\n BookmarkImages.Draw(Canvas, LeftMargin + aGutterOff,\r\n (aMarkRow - TopLine) * fTextHeight, aMark.ImageIndex);\r\n Inc(aGutterOff, fBookMarkOpt.XOffset);\r\n end;\r\n end\r\n else begin\r\n if aMark.ImageIndex in [0..9] then\r\n begin\r\n if not Assigned(fInternalImage) then\r\n begin\r\n fInternalImage := TSynInternalImage.Create(HINSTANCE,\r\n 'SynEditInternalImages', 10);\r\n end;\r\n if aGutterOff = 0 then\r\n begin\r\n fInternalImage.Draw(Canvas, aMark.ImageIndex,\r\n fBookMarkOpt.LeftMargin + aGutterOff,\r\n (aMarkRow - TopLine) * fTextHeight, fTextHeight);\r\n end;\r\n Inc(aGutterOff, fBookMarkOpt.XOffset);\r\n end;\r\n end;\r\n end;\r\n\r\nvar\r\n cLine: Integer;\r\n cMark: Integer;\r\n rcLine: TRect;\r\n aGutterOffs: PIntArray;\r\n bHasOtherMarks: Boolean;\r\n s: UnicodeString;\r\n vFirstLine: Integer;\r\n vLastLine: Integer;\r\n vMarkRow: Integer;\r\n vGutterRow: Integer;\r\n vLineTop: Integer;\r\n{$IFNDEF SYN_CLX}\r\n dc: HDC;\r\n TextSize: TSize;\r\n{$ENDIF}\r\nbegin\r\n vFirstLine := RowToLine(aFirstRow);\r\n vLastLine := RowToLine(aLastRow);\r\n //todo: Does the following comment still apply?\r\n // Changed to use fTextDrawer.BeginDrawing and fTextDrawer.EndDrawing only\r\n // when absolutely necessary. Note: Never change brush / pen / font of the\r\n // canvas inside of this block (only through methods of fTextDrawer)!\r\n // If we have to draw the line numbers then we don't want to erase\r\n // the background first. Do it line by line with TextRect instead\r\n // and fill only the area after the last visible line.\r\n{$IFDEF SYN_CLX}\r\n{$ELSE}\r\n dc := Canvas.Handle;\r\n{$ENDIF}\r\n\r\n if fGutter.Gradient then\r\n SynDrawGradient(Canvas, fGutter.GradientStartColor, fGutter.GradientEndColor,\r\n fGutter.GradientSteps, Rect(0, 0, fGutterWidth, ClientHeight), True);\r\n\r\n Canvas.Brush.Color := fGutter.Color;\r\n\r\n if fGutter.ShowLineNumbers then\r\n begin\r\n if fGutter.UseFontStyle then\r\n fTextDrawer.SetBaseFont(fGutter.Font)\r\n else\r\n fTextDrawer.Style := [];\r\n{$IFDEF SYN_CLX}\r\n fTextDrawer.BeginDrawing(canvas);\r\n{$ELSE}\r\n fTextDrawer.BeginDrawing(dc);\r\n{$ENDIF}\r\n try\r\n if fGutter.UseFontStyle then\r\n fTextDrawer.SetForeColor(fGutter.Font.Color)\r\n else\r\n fTextDrawer.SetForeColor(Self.Font.Color);\r\n fTextDrawer.SetBackColor(fGutter.Color);\r\n\r\n // prepare the rect initially\r\n rcLine := AClip;\r\n rcLine.Right := Max(rcLine.Right, fGutterWidth - 2);\r\n rcLine.Bottom := rcLine.Top;\r\n\r\n for cLine := vFirstLine to vLastLine do\r\n begin\r\n vLineTop := (LineToRow(cLine) - TopLine) * fTextHeight;\r\n if WordWrap and not fGutter.Gradient then\r\n begin\r\n // erase space between wrapped lines (from previous line to current one)\r\n rcLine.Top := rcLine.Bottom;\r\n rcLine.Bottom := vLineTop;\r\n with rcLine do\r\n fTextDrawer.ExtTextOut(Left, Top, [tooOpaque], rcLine, '', 0);\r\n end;\r\n // next line rect\r\n rcLine.Top := vLineTop;\r\n rcLine.Bottom := rcLine.Top + fTextHeight;\r\n\r\n s := fGutter.FormatLineNumber(cLine);\r\n if Assigned(OnGutterGetText) then\r\n OnGutterGetText(Self, cLine, s);\r\n{$IFDEF SYN_CLX}\r\n if fGutter.Gradient then\r\n Canvas.Brush.Style := bsClear\r\n else\r\n Canvas.Brush.Style := bsSolid;\r\n Canvas.FillRect(rcLine);\r\n Canvas.TextRect(rcLine, fGutter.LeftOffset, rcLine.Top, s);\r\n // restore brush\r\n if fGutter.Gradient then\r\n Canvas.Brush.Style := bsSolid;\r\n{$ELSE}\r\n TextSize := GetTextSize(DC, PWideChar(s), Length(s));\r\n if fGutter.Gradient then\r\n begin\r\n SetBkMode(DC, TRANSPARENT);\r\n Windows.ExtTextOutW(DC, (fGutterWidth - fGutter.RightOffset - 2) - TextSize.cx,\r\n rcLine.Top + ((fTextHeight - Integer(TextSize.cy)) div 2), 0,\r\n @rcLine, PWideChar(s), Length(s), nil);\r\n SetBkMode(DC, OPAQUE);\r\n end\r\n else\r\n Windows.ExtTextOutW(DC, (fGutterWidth - fGutter.RightOffset - 2) - TextSize.cx,\r\n rcLine.Top + ((fTextHeight - Integer(TextSize.cy)) div 2), ETO_OPAQUE,\r\n @rcLine, PWideChar(s), Length(s), nil);\r\n{$ENDIF}\r\n end;\r\n // now erase the remaining area if any\r\n if (AClip.Bottom > rcLine.Bottom) and not fGutter.Gradient then\r\n begin\r\n rcLine.Top := rcLine.Bottom;\r\n rcLine.Bottom := AClip.Bottom;\r\n with rcLine do\r\n fTextDrawer.ExtTextOut(Left, Top, [tooOpaque], rcLine, '', 0);\r\n end;\r\n finally\r\n fTextDrawer.EndDrawing;\r\n if fGutter.UseFontStyle then\r\n fTextDrawer.SetBaseFont(Self.Font);\r\n end;\r\n end\r\n else if not fGutter.Gradient then\r\n Canvas.FillRect(AClip);\r\n\r\n{$IFDEF SYN_WIN32}\r\n // draw word wrap glyphs transparently over gradient\r\n if fGutter.Gradient then\r\n Canvas.Brush.Style := bsClear;\r\n{$ENDIF}\r\n // paint wrapped line glyphs\r\n if WordWrap and fWordWrapGlyph.Visible then\r\n for cLine := aFirstRow to aLastRow do\r\n if LineToRow(RowToLine(cLine)) <> cLine then\r\n fWordWrapGlyph.Draw(Canvas,\r\n (fGutterWidth - fGutter.RightOffset - 2) - fWordWrapGlyph.Width,\r\n (cLine - TopLine) * fTextHeight, fTextHeight);\r\n{$IFDEF SYN_WIN32}\r\n // restore brush\r\n if fGutter.Gradient then\r\n Canvas.Brush.Style := bsSolid;\r\n{$ENDIF}\r\n\r\n // the gutter separator if visible\r\n if (fGutter.BorderStyle <> gbsNone) and (AClip.Right >= fGutterWidth - 2) then\r\n with Canvas do\r\n begin\r\n Pen.Color := fGutter.BorderColor;\r\n Pen.Width := 1;\r\n with AClip do\r\n begin\r\n if fGutter.BorderStyle = gbsMiddle then\r\n begin\r\n MoveTo(fGutterWidth - 2, Top);\r\n LineTo(fGutterWidth - 2, Bottom);\r\n Pen.Color := fGutter.Color;\r\n end;\r\n MoveTo(fGutterWidth - 1, Top);\r\n LineTo(fGutterWidth - 1, Bottom);\r\n end;\r\n end;\r\n\r\n // now the gutter marks\r\n if BookMarkOptions.GlyphsVisible and (Marks.Count > 0)\r\n and (vLastLine >= vFirstLine) then\r\n begin\r\n aGutterOffs := AllocMem((aLastRow - aFirstRow + 1) * SizeOf(Integer));\r\n try\r\n // Instead of making a two pass loop we look while drawing the bookmarks\r\n // whether there is any other mark to be drawn\r\n bHasOtherMarks := False;\r\n for cMark := 0 to Marks.Count - 1 do with Marks[cMark] do\r\n if Visible and (Line >= vFirstLine) and (Line <= vLastLine) then\r\n begin\r\n if IsBookmark <> BookMarkOptions.DrawBookmarksFirst then\r\n bHasOtherMarks := True\r\n else begin\r\n vMarkRow := LineToRow(Line);\r\n if vMarkRow >= aFirstRow then\r\n DrawMark(Marks[cMark], aGutterOffs[vMarkRow - aFirstRow], vMarkRow);\r\n end\r\n end;\r\n if bHasOtherMarks then\r\n for cMark := 0 to Marks.Count - 1 do with Marks[cMark] do\r\n begin\r\n if Visible and (IsBookmark <> BookMarkOptions.DrawBookmarksFirst)\r\n and (Line >= vFirstLine) and (Line <= vLastLine) then\r\n begin\r\n vMarkRow := LineToRow(Line);\r\n if vMarkRow >= aFirstRow then\r\n DrawMark(Marks[cMark], aGutterOffs[vMarkRow - aFirstRow], vMarkRow);\r\n end;\r\n end;\r\n if Assigned(OnGutterPaint) then\r\n for cLine := vFirstLine to vLastLine do\r\n begin\r\n vGutterRow := LineToRow(cLine);\r\n OnGutterPaint(Self, cLine, aGutterOffs[vGutterRow - aFirstRow],\r\n (vGutterRow - TopLine) * LineHeight);\r\n end;\r\n finally\r\n FreeMem(aGutterOffs);\r\n end;\r\n end\r\n else if Assigned(OnGutterPaint) then\r\n begin\r\n for cLine := vFirstLine to vLastLine do\r\n begin\r\n vGutterRow := LineToRow(cLine);\r\n OnGutterPaint(Self, cLine, 0, (vGutterRow - TopLine) * LineHeight);\r\n end;\r\n end;\r\nend;\r\n\r\n// Inserts filling chars into a string containing chars that display as glyphs\r\n// wider than an average glyph. (This is often the case with Asian glyphs, which\r\n// are usually wider than latin glpyhs)\r\n// This is only to simplify paint-operations and has nothing to do with\r\n// multi-byte chars.\r\nfunction TCustomSynEdit.ExpandAtWideGlyphs(const S: UnicodeString): UnicodeString;\r\nvar\r\n i, j, CountOfAvgGlyphs: Integer;\r\nbegin\r\n Result := S;\r\n j := 0;\r\n SetLength(Result, Length(S) * 2); // speed improvement\r\n for i := 1 to Length(S) do\r\n begin\r\n inc(j);\r\n CountOfAvgGlyphs := CeilOfIntDiv(fTextDrawer.TextWidth(S[i]), fCharWidth);\r\n\r\n if j + CountOfAvgGlyphs > Length(Result) then\r\n SetLength(Result, Length(Result) + 128);\r\n\r\n // insert CountOfAvgGlyphs filling chars\r\n while CountOfAvgGlyphs > 1 do\r\n begin\r\n Result[j] := FillerChar;\r\n inc(j);\r\n dec(CountOfAvgGlyphs);\r\n end;\r\n\r\n Result[j] := S[i];\r\n end;\r\n\r\n SetLength(Result, j);\r\nend;\r\n\r\n// does the opposite of ExpandAtWideGlyphs\r\nfunction TCustomSynEdit.ShrinkAtWideGlyphs(const S: UnicodeString; First: Integer;\r\n var CharCount: Integer): UnicodeString;\r\nvar\r\n i, j: Integer;\r\nbegin\r\n SetLength(Result, Length(S));\r\n\r\n i := First;\r\n j := 0;\r\n while i < First + CharCount do\r\n begin\r\n inc(j);\r\n while S[i] = FillerChar do\r\n inc(i);\r\n Result[j] := S[i];\r\n inc(i);\r\n end;\r\n\r\n SetLength(Result, j);\r\n CharCount := j;\r\nend;\r\n\r\nprocedure TCustomSynEdit.PaintTextLines(AClip: TRect; const aFirstRow, aLastRow,\r\n FirstCol, LastCol: Integer);\r\nvar\r\n bDoRightEdge: Boolean; // right edge\r\n nRightEdge: Integer;\r\n // selection info\r\n bAnySelection: Boolean; // any selection visible?\r\n vSelStart: TDisplayCoord; // start of selected area\r\n vSelEnd: TDisplayCoord; // end of selected area\r\n // info about normal and selected text and background colors\r\n bSpecialLine, bLineSelected, bCurrentLine: Boolean;\r\n colFG, colBG: TColor;\r\n colSelFG, colSelBG: TColor;\r\n // info about selection of the current line\r\n nLineSelStart, nLineSelEnd: Integer;\r\n bComplexLine: Boolean;\r\n // painting the background and the text\r\n rcLine, rcToken: TRect;\r\n TokenAccu: record\r\n // Note: s is not managed as a string, it will only grow!!!\r\n // Never use AppendStr or \"+\", use Len and MaxLen instead and\r\n // copy the string chars directly. This is for efficiency.\r\n Len, MaxLen, CharsBefore: Integer;\r\n s: UnicodeString;\r\n TabString: UnicodeString;\r\n FG, BG: TColor;\r\n Style: TFontStyles;\r\n end;\r\n{$IFNDEF SYN_CLX}\r\n dc: HDC;\r\n{$ENDIF}\r\n SynTabGlyphString: UnicodeString;\r\n\r\n vFirstLine: Integer;\r\n vLastLine: Integer;\r\n\r\n{ local procedures }\r\n\r\n function colEditorBG: TColor;\r\n var\r\n iAttri: TSynHighlighterAttributes;\r\n begin\r\n if (ActiveLineColor <> clNone) and (bCurrentLine) then\r\n Result := ActiveLineColor\r\n else begin\r\n Result := Color;\r\n if Highlighter <> nil then\r\n begin\r\n iAttri := Highlighter.WhitespaceAttribute;\r\n if (iAttri <> nil) and (iAttri.Background <> clNone) then\r\n Result := iAttri.Background;\r\n end;\r\n end;\r\n end;\r\n\r\n procedure ComputeSelectionInfo;\r\n var\r\n vStart: TBufferCoord;\r\n vEnd: TBufferCoord;\r\n begin\r\n bAnySelection := False;\r\n // Only if selection is visible anyway.\r\n if not HideSelection or Self.Focused then\r\n begin\r\n bAnySelection := True;\r\n // Get the *real* start of the selected area.\r\n if fBlockBegin.Line < fBlockEnd.Line then\r\n begin\r\n vStart := fBlockBegin;\r\n vEnd := fBlockEnd;\r\n end\r\n else if fBlockBegin.Line > fBlockEnd.Line then\r\n begin\r\n vEnd := fBlockBegin;\r\n vStart := fBlockEnd;\r\n end\r\n else if fBlockBegin.Char <> fBlockEnd.Char then\r\n begin\r\n // No selection at all, or it is only on this line.\r\n vStart.Line := fBlockBegin.Line;\r\n vEnd.Line := vStart.Line;\r\n if fBlockBegin.Char < fBlockEnd.Char then\r\n begin\r\n vStart.Char := fBlockBegin.Char;\r\n vEnd.Char := fBlockEnd.Char;\r\n end\r\n else\r\n begin\r\n vStart.Char := fBlockEnd.Char;\r\n vEnd.Char := fBlockBegin.Char;\r\n end;\r\n end\r\n else\r\n bAnySelection := False;\r\n // If there is any visible selection so far, then test if there is an\r\n // intersection with the area to be painted.\r\n if bAnySelection then\r\n begin\r\n // Don't care if the selection is not visible.\r\n bAnySelection := (vEnd.Line >= vFirstLine) and (vStart.Line <= vLastLine);\r\n if bAnySelection then\r\n begin\r\n // Transform the selection from text space into screen space\r\n vSelStart := BufferToDisplayPos(vStart);\r\n vSelEnd := BufferToDisplayPos(vEnd);\r\n // In the column selection mode sort the begin and end of the selection,\r\n // this makes the painting code simpler.\r\n if (fActiveSelectionMode = smColumn) and (vSelStart.Column > vSelEnd.Column) then\r\n SwapInt(vSelStart.Column, vSelEnd.Column);\r\n end;\r\n end;\r\n end;\r\n end;\r\n\r\n procedure SetDrawingColors(Selected: Boolean);\r\n begin\r\n with fTextDrawer do\r\n if Selected then\r\n begin\r\n SetBackColor(colSelBG);\r\n SetForeColor(colSelFG);\r\n Canvas.Brush.Color := colSelBG;\r\n end\r\n else begin\r\n SetBackColor(colBG);\r\n SetForeColor(colFG);\r\n Canvas.Brush.Color := colBG;\r\n end;\r\n end;\r\n\r\n function ColumnToXValue(Col: Integer): Integer;\r\n begin\r\n Result := fTextOffset + Pred(Col) * fCharWidth;\r\n end;\r\n\r\n //todo: Review SpecialChars and HardTabs painting. Token parameter of PaintToken procedure could very probably be passed by reference.\r\n\r\n // Note: The PaintToken procedure will take care of invalid parameters\r\n // like empty token rect or invalid indices into TokenLen.\r\n // CharsBefore tells if Token starts at column one or not\r\n procedure PaintToken(Token: UnicodeString;\r\n TokenLen, CharsBefore, First, Last: Integer);\r\n var\r\n Text: UnicodeString;\r\n Counter, nX, nCharsToPaint: Integer;\r\n sTabbedToken: UnicodeString;\r\n DoTabPainting: Boolean;\r\n i, TabStart, TabLen, CountOfAvgGlyphs, VisibleGlyphPart, FillerCount,\r\n NonFillerPos: Integer;\r\n rcTab: TRect;\r\n const\r\n ETOOptions = [tooOpaque, tooClipped];\r\n begin\r\n sTabbedToken := Token;\r\n DoTabPainting := False;\r\n\r\n Counter := Last - CharsBefore;\r\n while Counter > First - CharsBefore - 1 do\r\n begin\r\n if Length(Token) >= Counter then\r\n begin\r\n if fShowSpecChar and (Token[Counter] = #32) then\r\n Token[Counter] := SynSpaceGlyph\r\n else if Token[Counter] = #9 then\r\n begin\r\n Token[Counter] := #32; //Tabs painted differently if necessary\r\n DoTabPainting := fShowSpecChar;\r\n end;\r\n end;\r\n Dec(Counter);\r\n end;\r\n\r\n if (Last >= First) and (rcToken.Right > rcToken.Left) then\r\n begin\r\n nX := ColumnToXValue(First);\r\n\r\n Dec(First, CharsBefore);\r\n Dec(Last, CharsBefore);\r\n\r\n if (First > TokenLen) then\r\n begin\r\n nCharsToPaint := 0;\r\n Text := '';\r\n end\r\n else\r\n begin\r\n FillerCount := 0;\r\n NonFillerPos := First;\r\n while Token[NonFillerPos] = FillerChar do\r\n begin\r\n inc(FillerCount);\r\n inc(NonFillerPos);\r\n end;\r\n\r\n CountOfAvgGlyphs := CeilOfIntDiv(fTextDrawer.TextWidth(Token[NonFillerPos]) , fCharWidth);\r\n\r\n // first visible part of the glyph (1-based)\r\n // (the glyph is visually sectioned in parts of size fCharWidth)\r\n VisibleGlyphPart := CountOfAvgGlyphs - FillerCount;\r\n\r\n // clip off invisible parts\r\n nX := nX - fCharWidth * (VisibleGlyphPart - 1);\r\n\r\n nCharsToPaint := Min(Last - First + 1, TokenLen - First + 1);\r\n\r\n // clip off partially visible glyphs at line end\r\n if WordWrap then\r\n while nX + fCharWidth * nCharsToPaint > ClientWidth do\r\n begin\r\n dec(nCharsToPaint);\r\n while (nCharsToPaint > 0) and (Token[First + nCharsToPaint - 1] = FillerChar) do\r\n dec(nCharsToPaint);\r\n end;\r\n\r\n // same as copy(Token, First, nCharsToPaint) and remove filler chars\r\n Text := ShrinkAtWideGlyphs(Token, First, nCharsToPaint);\r\n end;\r\n\r\n fTextDrawer.ExtTextOut(nX, rcToken.Top, ETOOptions, rcToken,\r\n PWideChar(Text), nCharsToPaint);\r\n\r\n if DoTabPainting then\r\n begin\r\n // fix everything before the FirstChar\r\n for i := 1 to First - 1 do // wipe the text out so we don't\r\n if sTabbedToken[i] = #9 then // count it out of the range\r\n sTabbedToken[i] := #32; // we're looking for\r\n\r\n TabStart := pos(#9, sTabbedToken);\r\n rcTab.Top := rcToken.Top;\r\n rcTab.Bottom := rcToken.Bottom;\r\n while (TabStart > 0) and (TabStart >= First) and (TabStart <= Last) do\r\n begin\r\n TabLen := 1;\r\n while (TabStart + CharsBefore + TabLen - 1) mod FTabWidth <> 0 do inc(TabLen);\r\n Text := SynTabGlyphString;\r\n\r\n nX := ColumnToXValue(CharsBefore + TabStart + (TabLen div 2) - 1);\r\n if TabLen mod 2 = 0 then\r\n nX := nX + (fCharWidth div 2)\r\n else nX := nX + fCharWidth;\r\n\r\n rcTab.Left := nX;\r\n rcTab.Right := nX + fTextDrawer.GetCharWidth;\r\n\r\n fTextDrawer.ExtTextOut(nX, rcTab.Top, ETOOptions, rcTab,\r\n PWideChar(Text), 1);\r\n\r\n for i := 0 to TabLen - 1 do //wipe the text out so we don't\r\n sTabbedToken[TabStart + i] := #32; //count it again\r\n\r\n TabStart := pos(#9, sTabbedToken);\r\n end;\r\n end;\r\n rcToken.Left := rcToken.Right;\r\n end;\r\n end;\r\n\r\n{$IFNDEF SYN_CLX}\r\n procedure AdjustEndRect;\r\n // trick to avoid clipping the last pixels of text in italic,\r\n // see also AdjustLastCharWidth() in TheTextDrawer.ExtTextOut()\r\n var\r\n LastChar: Cardinal;\r\n NormalCharWidth, RealCharWidth: Integer;\r\n CharInfo: TABC;\r\n tm: TTextMetricA;\r\n begin\r\n LastChar := Ord(TokenAccu.s[TokenAccu.Len]);\r\n NormalCharWidth := fTextDrawer.TextWidth(WideChar(LastChar));\r\n RealCharWidth := NormalCharWidth;\r\n if Win32PlatformIsUnicode then\r\n begin\r\n if GetCharABCWidthsW(Canvas.Handle, LastChar, LastChar, CharInfo) then\r\n begin\r\n RealCharWidth := CharInfo.abcA + Integer(CharInfo.abcB);\r\n if CharInfo.abcC >= 0 then\r\n Inc(RealCharWidth, CharInfo.abcC);\r\n end\r\n else if LastChar < Ord(High(AnsiChar)) then\r\n begin\r\n GetTextMetricsA(Canvas.Handle, tm);\r\n RealCharWidth := tm.tmAveCharWidth + tm.tmOverhang;\r\n end;\r\n end\r\n else if WideChar(LastChar) <= High(AnsiChar) then\r\n begin\r\n if GetCharABCWidths(Canvas.Handle, LastChar, LastChar, CharInfo) then\r\n begin\r\n RealCharWidth := CharInfo.abcA + Integer(CharInfo.abcB);\r\n if CharInfo.abcC >= 0 then\r\n Inc(RealCharWidth, CharInfo.abcC);\r\n end\r\n else if LastChar < Ord(High(AnsiChar)) then\r\n begin\r\n GetTextMetricsA(Canvas.Handle, tm);\r\n RealCharWidth := tm.tmAveCharWidth + tm.tmOverhang;\r\n end;\r\n end;\r\n\r\n if RealCharWidth > NormalCharWidth then\r\n Inc(rcToken.Left, RealCharWidth - NormalCharWidth);\r\n end;\r\n{$ENDIF}\r\n\r\n procedure PaintHighlightToken(bFillToEOL: Boolean);\r\n var\r\n bComplexToken: Boolean;\r\n nC1, nC2, nC1Sel, nC2Sel: Integer;\r\n bU1, bSel, bU2: Boolean;\r\n nX1, nX2: Integer;\r\n begin\r\n // Compute some helper variables.\r\n nC1 := Max(FirstCol, TokenAccu.CharsBefore + 1);\r\n nC2 := Min(LastCol, TokenAccu.CharsBefore + TokenAccu.Len + 1);\r\n if bComplexLine then\r\n begin\r\n bU1 := (nC1 < nLineSelStart);\r\n bSel := (nC1 < nLineSelEnd) and (nC2 >= nLineSelStart);\r\n bU2 := (nC2 >= nLineSelEnd);\r\n bComplexToken := bSel and (bU1 or bU2);\r\n end\r\n else\r\n begin\r\n bU1 := False; // to shut up Compiler warning Delphi 2\r\n bSel := bLineSelected;\r\n bU2 := False; // to shut up Compiler warning Delphi 2\r\n bComplexToken := False;\r\n end;\r\n // Any token chars accumulated?\r\n if (TokenAccu.Len > 0) then\r\n begin\r\n // Initialize the colors and the font style.\r\n if not bSpecialLine then\r\n begin\r\n colBG := TokenAccu.BG;\r\n colFG := TokenAccu.FG;\r\n end;\r\n\r\n if bSpecialLine and (eoSpecialLineDefaultFg in fOptions) then\r\n colFG := TokenAccu.FG;\r\n\r\n fTextDrawer.SetStyle(TokenAccu.Style);\r\n // Paint the chars\r\n if bComplexToken then\r\n begin\r\n // first unselected part of the token\r\n if bU1 then\r\n begin\r\n SetDrawingColors(False);\r\n rcToken.Right := ColumnToXValue(nLineSelStart);\r\n with TokenAccu do\r\n PaintToken(s, Len, CharsBefore, nC1, nLineSelStart);\r\n end;\r\n // selected part of the token\r\n SetDrawingColors(True);\r\n nC1Sel := Max(nLineSelStart, nC1);\r\n nC2Sel := Min(nLineSelEnd, nC2);\r\n rcToken.Right := ColumnToXValue(nC2Sel);\r\n with TokenAccu do\r\n PaintToken(s, Len, CharsBefore, nC1Sel, nC2Sel);\r\n // second unselected part of the token\r\n if bU2 then\r\n begin\r\n SetDrawingColors(False);\r\n rcToken.Right := ColumnToXValue(nC2);\r\n with TokenAccu do\r\n PaintToken(s, Len, CharsBefore, nLineSelEnd, nC2);\r\n end;\r\n end\r\n else\r\n begin\r\n SetDrawingColors(bSel);\r\n rcToken.Right := ColumnToXValue(nC2);\r\n with TokenAccu do\r\n PaintToken(s, Len, CharsBefore, nC1, nC2);\r\n end;\r\n end;\r\n\r\n // Fill the background to the end of this line if necessary.\r\n if bFillToEOL and (rcToken.Left < rcLine.Right) then\r\n begin\r\n if not bSpecialLine then colBG := colEditorBG;\r\n if bComplexLine then\r\n begin\r\n nX1 := ColumnToXValue(nLineSelStart);\r\n nX2 := ColumnToXValue(nLineSelEnd);\r\n if (rcToken.Left < nX1) then\r\n begin\r\n SetDrawingColors(False);\r\n rcToken.Right := nX1;\r\n{$IFNDEF SYN_CLX}\r\n if (TokenAccu.Len > 0) and (TokenAccu.Style <> []) then\r\n AdjustEndRect;\r\n{$ENDIF}\r\n Canvas.FillRect(rcToken);\r\n rcToken.Left := nX1;\r\n end;\r\n if (rcToken.Left < nX2) then\r\n begin\r\n SetDrawingColors(True);\r\n rcToken.Right := nX2;\r\n{$IFNDEF SYN_CLX}\r\n if (TokenAccu.Len > 0) and (TokenAccu.Style <> []) then\r\n AdjustEndRect;\r\n{$ENDIF}\r\n Canvas.FillRect(rcToken);\r\n rcToken.Left := nX2;\r\n end;\r\n if (rcToken.Left < rcLine.Right) then\r\n begin\r\n SetDrawingColors(False);\r\n rcToken.Right := rcLine.Right;\r\n{$IFNDEF SYN_CLX}\r\n if (TokenAccu.Len > 0) and (TokenAccu.Style <> []) then\r\n AdjustEndRect;\r\n{$ENDIF}\r\n Canvas.FillRect(rcToken);\r\n end;\r\n end\r\n else\r\n begin\r\n SetDrawingColors(bLineSelected);\r\n rcToken.Right := rcLine.Right;\r\n{$IFNDEF SYN_CLX}\r\n if (TokenAccu.Len > 0) and (TokenAccu.Style <> []) then\r\n AdjustEndRect;\r\n{$ENDIF}\r\n Canvas.FillRect(rcToken);\r\n end;\r\n end;\r\n end;\r\n\r\n // Store the token chars with the attributes in the TokenAccu\r\n // record. This will paint any chars already stored if there is\r\n // a (visible) change in the attributes.\r\n procedure AddHighlightToken(const Token: UnicodeString;\r\n CharsBefore, TokenLen: Integer;\r\n Foreground, Background: TColor;\r\n Style: TFontStyles);\r\n var\r\n bCanAppend: Boolean;\r\n bSpacesTest, bIsSpaces: Boolean;\r\n i: Integer;\r\n\r\n function TokenIsSpaces: Boolean;\r\n var\r\n pTok: PWideChar;\r\n begin\r\n if not bSpacesTest then\r\n begin\r\n bSpacesTest := True;\r\n pTok := PWideChar(Token);\r\n while pTok^ <> #0 do\r\n begin\r\n if pTok^ <> #32 then\r\n break;\r\n Inc(pTok);\r\n end;\r\n bIsSpaces := pTok^ = #0;\r\n end;\r\n Result := bIsSpaces;\r\n end;\r\n\r\n begin\r\n if (Background = clNone) or\r\n ((ActiveLineColor <> clNone) and (bCurrentLine)) then\r\n begin\r\n Background := colEditorBG;\r\n end;\r\n if Foreground = clNone then Foreground := Font.Color;\r\n // Do we have to paint the old chars first, or can we just append?\r\n bCanAppend := False;\r\n bSpacesTest := False;\r\n if (TokenAccu.Len > 0) then\r\n begin\r\n // font style must be the same or token is only spaces\r\n if (TokenAccu.Style = Style)\r\n or (not (fsUnderline in Style) and not (fsUnderline in TokenAccu.Style)\r\n and TokenIsSpaces) then\r\n begin\r\n // either special colors or same colors\r\n if (bSpecialLine and not (eoSpecialLineDefaultFg in fOptions)) or bLineSelected or\r\n // background color must be the same and\r\n ((TokenAccu.BG = Background) and\r\n // foreground color must be the same or token is only spaces\r\n ((TokenAccu.FG = Foreground) or TokenIsSpaces)) then\r\n begin\r\n bCanAppend := True;\r\n end;\r\n end;\r\n // If we can't append it, then we have to paint the old token chars first.\r\n if not bCanAppend then\r\n PaintHighlightToken(False);\r\n end;\r\n // Don't use AppendStr because it's more expensive.\r\n if bCanAppend then\r\n begin\r\n if (TokenAccu.Len + TokenLen > TokenAccu.MaxLen) then\r\n begin\r\n TokenAccu.MaxLen := TokenAccu.Len + TokenLen + 32;\r\n SetLength(TokenAccu.s, TokenAccu.MaxLen);\r\n end;\r\n for i := 1 to TokenLen do\r\n TokenAccu.s[TokenAccu.Len + i] := Token[i];\r\n Inc(TokenAccu.Len, TokenLen);\r\n end\r\n else\r\n begin\r\n TokenAccu.Len := TokenLen;\r\n if (TokenAccu.Len > TokenAccu.MaxLen) then\r\n begin\r\n TokenAccu.MaxLen := TokenAccu.Len + 32;\r\n SetLength(TokenAccu.s, TokenAccu.MaxLen);\r\n end;\r\n for i := 1 to TokenLen do\r\n TokenAccu.s[i] := Token[i];\r\n TokenAccu.CharsBefore := CharsBefore;\r\n TokenAccu.FG := Foreground;\r\n TokenAccu.BG := Background;\r\n TokenAccu.Style := Style;\r\n end;\r\n end;\r\n\r\n procedure PaintLines;\r\n var\r\n nLine: Integer; // line index for the loop\r\n cRow: Integer;\r\n sLine: UnicodeString; // the current line (tab expanded)\r\n sLineExpandedAtWideGlyphs: UnicodeString;\r\n sToken: UnicodeString; // highlighter token info\r\n nTokenPos, nTokenLen: Integer;\r\n attr: TSynHighlighterAttributes;\r\n vAuxPos: TDisplayCoord;\r\n vFirstChar: Integer;\r\n vLastChar: Integer;\r\n vStartRow: Integer;\r\n vEndRow: Integer;\r\n begin\r\n // Initialize rcLine for drawing. Note that Top and Bottom are updated\r\n // inside the loop. Get only the starting point for this.\r\n rcLine := AClip;\r\n rcLine.Left := fGutterWidth + 2;\r\n rcLine.Bottom := (aFirstRow - TopLine) * fTextHeight;\r\n // Make sure the token accumulator string doesn't get reassigned to often.\r\n if Assigned(fHighlighter) then\r\n begin\r\n TokenAccu.MaxLen := Max(128, fCharsInWindow);\r\n SetLength(TokenAccu.s, TokenAccu.MaxLen);\r\n end;\r\n // Now loop through all the lines. The indices are valid for Lines.\r\n for nLine := vFirstLine to vLastLine do\r\n begin\r\n sLine := TSynEditStringList(Lines).ExpandedStrings[nLine - 1];\r\n sLineExpandedAtWideGlyphs := ExpandAtWideGlyphs(sLine);\r\n // determine whether will be painted with ActiveLineColor\r\n bCurrentLine := CaretY = nLine;\r\n // Initialize the text and background colors, maybe the line should\r\n // use special values for them.\r\n colFG := Font.Color;\r\n colBG := colEditorBG;\r\n bSpecialLine := DoOnSpecialLineColors(nLine, colFG, colBG);\r\n if bSpecialLine then\r\n begin\r\n // The selection colors are just swapped, like seen in Delphi.\r\n colSelFG := colBG;\r\n colSelBG := colFG;\r\n end\r\n else\r\n begin\r\n colSelFG := fSelectedColor.Foreground;\r\n colSelBG := fSelectedColor.Background;\r\n end;\r\n\r\n vStartRow := Max(LineToRow(nLine), aFirstRow);\r\n vEndRow := Min(LineToRow(nLine + 1) - 1, aLastRow);\r\n for cRow := vStartRow to vEndRow do\r\n begin\r\n if WordWrap then\r\n begin\r\n vAuxPos.Row := cRow;\r\n if Assigned(fHighlighter) then\r\n vAuxPos.Column := FirstCol\r\n else\r\n // When no highlighter is assigned, we must always start from the\r\n // first char in a row and PaintToken will do the actual clipping\r\n vAuxPos.Column := 1;\r\n vFirstChar := fWordWrapPlugin.DisplayToBufferPos(vAuxPos).Char;\r\n vAuxPos.Column := LastCol;\r\n vLastChar := fWordWrapPlugin.DisplayToBufferPos(vAuxPos).Char;\r\n end\r\n else\r\n begin\r\n vFirstChar := FirstCol;\r\n vLastChar := LastCol;\r\n end;\r\n // Get the information about the line selection. Three different parts\r\n // are possible (unselected before, selected, unselected after), only\r\n // unselected or only selected means bComplexLine will be False. Start\r\n // with no selection, compute based on the visible columns.\r\n bComplexLine := False;\r\n nLineSelStart := 0;\r\n nLineSelEnd := 0;\r\n // Does the selection intersect the visible area?\r\n if bAnySelection and (cRow >= vSelStart.Row) and (cRow <= vSelEnd.Row) then\r\n begin\r\n // Default to a fully selected line. This is correct for the smLine\r\n // selection mode and a good start for the smNormal mode.\r\n nLineSelStart := FirstCol;\r\n nLineSelEnd := LastCol + 1;\r\n if (fActiveSelectionMode = smColumn) or\r\n ((fActiveSelectionMode = smNormal) and (cRow = vSelStart.Row)) then\r\n begin\r\n if (vSelStart.Column > LastCol) then\r\n begin\r\n nLineSelStart := 0;\r\n nLineSelEnd := 0;\r\n end\r\n else if (vSelStart.Column > FirstCol) then\r\n begin\r\n nLineSelStart := vSelStart.Column;\r\n bComplexLine := True;\r\n end;\r\n end;\r\n if (fActiveSelectionMode = smColumn) or\r\n ((fActiveSelectionMode = smNormal) and (cRow = vSelEnd.Row)) then\r\n begin\r\n if (vSelEnd.Column < FirstCol) then\r\n begin\r\n nLineSelStart := 0;\r\n nLineSelEnd := 0;\r\n end\r\n else if (vSelEnd.Column < LastCol) then\r\n begin\r\n nLineSelEnd := vSelEnd.Column;\r\n bComplexLine := True;\r\n end;\r\n end;\r\n end; //endif bAnySelection\r\n\r\n // Update the rcLine rect to this line.\r\n rcLine.Top := rcLine.Bottom;\r\n Inc(rcLine.Bottom, fTextHeight);\r\n\r\n bLineSelected := not bComplexLine and (nLineSelStart > 0);\r\n rcToken := rcLine;\r\n\r\n if not Assigned(fHighlighter) or not fHighlighter.Enabled then\r\n begin\r\n // Remove text already displayed (in previous rows)\r\n if (vFirstChar <> FirstCol) or (vLastChar <> LastCol) then\r\n sToken := Copy(sLineExpandedAtWideGlyphs, vFirstChar, vLastChar - vFirstChar)\r\n else\r\n sToken := Copy(sLineExpandedAtWideGlyphs, 1, vLastChar);\r\n if fShowSpecChar and (Length(sLineExpandedAtWideGlyphs) < vLastChar) then\r\n sToken := sToken + SynLineBreakGlyph;\r\n nTokenLen := Length(sToken);\r\n if bComplexLine then\r\n begin\r\n SetDrawingColors(False);\r\n rcToken.Left := Max(rcLine.Left, ColumnToXValue(FirstCol));\r\n rcToken.Right := Min(rcLine.Right, ColumnToXValue(nLineSelStart));\r\n PaintToken(sToken, nTokenLen, 0, FirstCol, nLineSelStart);\r\n rcToken.Left := Max(rcLine.Left, ColumnToXValue(nLineSelEnd));\r\n rcToken.Right := Min(rcLine.Right, ColumnToXValue(LastCol));\r\n PaintToken(sToken, nTokenLen, 0, nLineSelEnd, LastCol);\r\n SetDrawingColors(True);\r\n rcToken.Left := Max(rcLine.Left, ColumnToXValue(nLineSelStart));\r\n rcToken.Right := Min(rcLine.Right, ColumnToXValue(nLineSelEnd));\r\n PaintToken(sToken, nTokenLen, 0, nLineSelStart, nLineSelEnd - 1);\r\n end\r\n else\r\n begin\r\n SetDrawingColors(bLineSelected);\r\n PaintToken(sToken, nTokenLen, 0, FirstCol, LastCol);\r\n end;\r\n end\r\n else\r\n begin\r\n // Initialize highlighter with line text and range info. It is\r\n // necessary because we probably did not scan to the end of the last\r\n // line - the internal highlighter range might be wrong.\r\n if nLine = 1 then\r\n fHighlighter.ResetRange\r\n else\r\n fHighlighter.SetRange(TSynEditStringList(Lines).Ranges[nLine - 2]);\r\n fHighlighter.SetLineExpandedAtWideGlyphs(sLine, sLineExpandedAtWideGlyphs,\r\n nLine - 1);\r\n // Try to concatenate as many tokens as possible to minimize the count\r\n // of ExtTextOutW calls necessary. This depends on the selection state\r\n // or the line having special colors. For spaces the foreground color\r\n // is ignored as well.\r\n TokenAccu.Len := 0;\r\n nTokenPos := 0;\r\n nTokenLen := 0;\r\n attr := nil;\r\n // Test first whether anything of this token is visible.\r\n while not fHighlighter.GetEol do\r\n begin\r\n nTokenPos := fHighlighter.GetExpandedTokenPos;\r\n sToken := fHighlighter.GetExpandedToken;\r\n nTokenLen := Length(sToken);\r\n if nTokenPos + nTokenLen >= vFirstChar then\r\n begin\r\n if nTokenPos + nTokenLen > vLastChar then\r\n begin\r\n if nTokenPos > vLastChar then\r\n break;\r\n if WordWrap then\r\n nTokenLen := vLastChar - nTokenPos - 1\r\n else\r\n nTokenLen := vLastChar - nTokenPos;\r\n end;\r\n // Remove offset generated by tokens already displayed (in previous rows)\r\n Dec(nTokenPos, vFirstChar - FirstCol);\r\n // It's at least partially visible. Get the token attributes now.\r\n attr := fHighlighter.GetTokenAttribute;\r\n if Assigned(attr) then\r\n AddHighlightToken(sToken, nTokenPos, nTokenLen, attr.Foreground,\r\n attr.Background, attr.Style)\r\n else\r\n AddHighlightToken(sToken, nTokenPos, nTokenLen, colFG, colBG,\r\n Font.Style);\r\n end;\r\n // Let the highlighter scan the next token.\r\n fHighlighter.Next;\r\n end;\r\n // Draw anything that's left in the TokenAccu record. Fill to the end\r\n // of the invalid area with the correct colors.\r\n if fShowSpecChar and fHighlighter.GetEol then\r\n begin\r\n if (attr = nil) or (attr <> fHighlighter.CommentAttribute) then\r\n attr := fHighlighter.WhitespaceAttribute;\r\n AddHighlightToken(SynLineBreakGlyph, nTokenPos + nTokenLen, 1,\r\n attr.Foreground, attr.Background, []);\r\n end;\r\n PaintHighlightToken(True);\r\n end;\r\n // Now paint the right edge if necessary. We do it line by line to reduce\r\n // the flicker. Should not cost very much anyway, compared to the many\r\n // calls to ExtTextOutW.\r\n if bDoRightEdge then\r\n begin\r\n Canvas.MoveTo(nRightEdge, rcLine.Top);\r\n Canvas.LineTo(nRightEdge, rcLine.Bottom + 1);\r\n end;\r\n end; //endfor cRow\r\n bCurrentLine := False;\r\n end; //endfor cLine\r\n end;\r\n\r\n{ end local procedures }\r\n\r\nbegin\r\n vFirstLine := RowToLine(aFirstRow);\r\n vLastLine := RowToLine(aLastRow);\r\n\r\n bCurrentLine := False;\r\n // If the right edge is visible and in the invalid area, prepare to paint it.\r\n // Do this first to realize the pen when getting the dc variable.\r\n SynTabGlyphString := SynTabGlyph;\r\n bDoRightEdge := False;\r\n if (fRightEdge > 0) then\r\n begin // column value\r\n nRightEdge := fTextOffset + fRightEdge * fCharWidth; // pixel value\r\n if (nRightEdge >= AClip.Left) and (nRightEdge <= AClip.Right) then\r\n begin\r\n bDoRightEdge := True;\r\n Canvas.Pen.Color := fRightEdgeColor;\r\n Canvas.Pen.Width := 1;\r\n end;\r\n end;\r\n{$IFDEF SYN_CLX}\r\n{$ELSE}\r\n // Do everything else with API calls. This (maybe) realizes the new pen color.\r\n dc := Canvas.Handle;\r\n{$ENDIF}\r\n // If anything of the two pixel space before the text area is visible, then\r\n // fill it with the component background color.\r\n if (AClip.Left < fGutterWidth + 2) then\r\n begin\r\n rcToken := AClip;\r\n rcToken.Left := Max(AClip.Left, fGutterWidth);\r\n rcToken.Right := fGutterWidth + 2;\r\n // Paint whole left edge of the text with same color.\r\n // (value of WhiteAttribute can vary in e.g. MultiSyn)\r\n if Highlighter <> nil then\r\n Highlighter.ResetRange;\r\n Canvas.Brush.Color := colEditorBG;\r\n Canvas.FillRect(rcToken);\r\n // Adjust the invalid area to not include this area.\r\n AClip.Left := rcToken.Right;\r\n end;\r\n // Paint the visible text lines. To make this easier, compute first the\r\n // necessary information about the selected area: is there any visible\r\n // selected area, and what are its lines / columns?\r\n if (vLastLine >= vFirstLine) then\r\n begin\r\n ComputeSelectionInfo;\r\n fTextDrawer.Style := Font.Style;\r\n{$IFDEF SYN_CLX}\r\n fTextDrawer.BeginDrawing(Canvas);\r\n{$ELSE}\r\n fTextDrawer.BeginDrawing(dc);\r\n{$ENDIF}\r\n try\r\n PaintLines;\r\n finally\r\n fTextDrawer.EndDrawing;\r\n end;\r\n end;\r\n // If there is anything visible below the last line, then fill this as well.\r\n rcToken := AClip;\r\n rcToken.Top := (aLastRow - TopLine + 1) * fTextHeight;\r\n if (rcToken.Top < rcToken.Bottom) then\r\n begin\r\n if Highlighter <> nil then\r\n Highlighter.ResetRange;\r\n Canvas.Brush.Color := colEditorBG;\r\n Canvas.FillRect(rcToken);\r\n // Draw the right edge if necessary.\r\n if bDoRightEdge then\r\n begin\r\n Canvas.MoveTo(nRightEdge, rcToken.Top);\r\n Canvas.LineTo(nRightEdge, rcToken.Bottom + 1);\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TCustomSynEdit.PasteFromClipboard;\r\nvar\r\n AddPasteEndMarker: boolean;\r\n vStartOfBlock: TBufferCoord;\r\n vEndOfBlock: TBufferCoord;\r\n StoredPaintLock: Integer;\r\n PasteMode: TSynSelectionMode;\r\n{$IFNDEF SYN_CLX}\r\n Mem: HGLOBAL;\r\n P: PByte;\r\n{$ENDIF}\r\nbegin\r\n if not CanPaste then\r\n exit;\r\n DoOnPaintTransient(ttBefore);\r\n BeginUndoBlock;\r\n AddPasteEndMarker := False;\r\n PasteMode := SelectionMode;\r\n try\r\n{$IFNDEF SYN_CLX}\r\n // Check for our special format and read PasteMode.\r\n // The text is ignored as it is ANSI-only to stay compatible with programs\r\n // using the ANSI version of SynEdit.\r\n //\r\n // Instead we take the text stored in CF_UNICODETEXT or CF_TEXT.\r\n if Clipboard.HasFormat(SynEditClipboardFormat) then\r\n begin\r\n Clipboard.Open;\r\n try\r\n Mem := Clipboard.GetAsHandle(SynEditClipboardFormat);\r\n P := GlobalLock(Mem);\r\n try\r\n if P <> nil then\r\n PasteMode := PSynSelectionMode(P)^;\r\n finally\r\n GlobalUnlock(Mem);\r\n end\r\n finally\r\n Clipboard.Close;\r\n end;\r\n end;\r\n{$ENDIF}\r\n fUndoList.AddChange(crPasteBegin, BlockBegin, BlockEnd, '', smNormal);\r\n AddPasteEndMarker := True;\r\n if SelAvail then\r\n begin\r\n fUndoList.AddChange(crDelete, fBlockBegin, fBlockEnd, SelText,\r\n fActiveSelectionMode);\r\n end\r\n else\r\n ActiveSelectionMode := SelectionMode;\r\n\r\n if SelAvail then\r\n begin\r\n vStartOfBlock := BlockBegin;\r\n vEndOfBlock := BlockEnd;\r\n fBlockBegin := vStartOfBlock;\r\n fBlockEnd := vEndOfBlock;\r\n\r\n // Pasting always occurs at column 0 when current selection is\r\n // smLine type\r\n if fActiveSelectionMode = smLine then\r\n vStartOfBlock.Char := 1;\r\n end\r\n else\r\n vStartOfBlock := CaretXY;\r\n\r\n SetSelTextPrimitiveEx(PasteMode, PWideChar(GetClipboardText), True);\r\n vEndOfBlock := BlockEnd;\r\n if PasteMode = smNormal then\r\n fUndoList.AddChange(crPaste, vStartOfBlock, vEndOfBlock, SelText,\r\n PasteMode)\r\n else if PasteMode = smColumn then\r\n // Do nothing. Moved to InsertColumn\r\n else if PasteMode = smLine then\r\n if CaretX = 1 then\r\n fUndoList.AddChange(crPaste, BufferCoord(1, vStartOfBlock.Line),\r\n BufferCoord(CharsInWindow, vEndOfBlock.Line - 1), SelText, smLine)\r\n else\r\n fUndoList.AddChange(crPaste, BufferCoord(1, vStartOfBlock.Line),\r\n vEndOfBlock, SelText, smNormal);\r\n finally\r\n if AddPasteEndMarker then\r\n fUndoList.AddChange(crPasteEnd, BlockBegin, BlockEnd, '', smNormal);\r\n EndUndoBlock;\r\n end;\r\n\r\n // ClientRect can be changed by UpdateScrollBars if eoHideShowScrollBars\r\n // is enabled\r\n if eoHideShowScrollBars in Options then\r\n begin\r\n StoredPaintLock := fPaintLock;\r\n try\r\n fPaintLock := 0;\r\n UpdateScrollBars;\r\n finally\r\n fPaintLock := StoredPaintLock;\r\n end;\r\n end;\r\n\r\n EnsureCursorPosVisible;\r\n // Selection should have changed...\r\n StatusChanged([scSelection]);\r\n DoOnPaintTransient(ttAfter);\r\nend;\r\n\r\nprocedure TCustomSynEdit.SelectAll;\r\nvar\r\n LastPt: TBufferCoord;\r\nbegin\r\n LastPt.Char := 1;\r\n LastPt.Line := Lines.Count;\r\n if LastPt.Line > 0 then\r\n Inc(LastPt.Char, Length(Lines[LastPt.Line - 1]))\r\n else\r\n LastPt.Line := 1;\r\n SetCaretAndSelection(LastPt, BufferCoord(1, 1), LastPt);\r\n // Selection should have changed...\r\n StatusChanged([scSelection]);\r\nend;\r\n\r\nprocedure TCustomSynEdit.SetBlockBegin(Value: TBufferCoord);\r\nvar\r\n nInval1, nInval2: Integer;\r\n SelChanged: Boolean;\r\nbegin\r\n ActiveSelectionMode := SelectionMode;\r\n if (eoScrollPastEol in Options) and not WordWrap then\r\n Value.Char := MinMax(Value.Char, 1, fMaxScrollWidth + 1)\r\n else\r\n Value.Char := Max(Value.Char, 1);\r\n Value.Line := MinMax(Value.Line, 1, Lines.Count);\r\n if (fActiveSelectionMode = smNormal) then\r\n if (Value.Line >= 1) and (Value.Line <= Lines.Count) then\r\n Value.Char := Min(Value.Char, Length(Lines[Value.Line - 1]) + 1)\r\n else\r\n Value.Char := 1;\r\n if SelAvail then\r\n begin\r\n if fBlockBegin.Line < fBlockEnd.Line then\r\n begin\r\n nInval1 := Min(Value.Line, fBlockBegin.Line);\r\n nInval2 := Max(Value.Line, fBlockEnd.Line);\r\n end\r\n else\r\n begin\r\n nInval1 := Min(Value.Line, fBlockEnd.Line);\r\n nInval2 := Max(Value.Line, fBlockBegin.Line);\r\n end;\r\n fBlockBegin := Value;\r\n fBlockEnd := Value;\r\n InvalidateLines(nInval1, nInval2);\r\n SelChanged := True;\r\n end\r\n else\r\n begin\r\n SelChanged :=\r\n (fBlockBegin.Char <> Value.Char) or (fBlockBegin.Line <> Value.Line) or\r\n (fBlockEnd.Char <> Value.Char) or (fBlockEnd.Line <> Value.Line);\r\n fBlockBegin := Value;\r\n fBlockEnd := Value;\r\n end;\r\n if SelChanged then\r\n StatusChanged([scSelection]);\r\nend;\r\n\r\nprocedure TCustomSynEdit.SetBlockEnd(Value: TBufferCoord);\r\nvar\r\n nLine: Integer;\r\nbegin\r\n ActiveSelectionMode := SelectionMode;\r\n if not (eoNoSelection in Options) then\r\n begin\r\n if (eoScrollPastEol in Options) and not WordWrap then\r\n Value.Char := MinMax(Value.Char, 1, fMaxScrollWidth + 1)\r\n else\r\n Value.Char := Max(Value.Char, 1);\r\n Value.Line := MinMax(Value.Line, 1, Lines.Count);\r\n if (fActiveSelectionMode = smNormal) then\r\n if (Value.Line >= 1) and (Value.Line <= Lines.Count) then\r\n Value.Char := Min(Value.Char, Length(Lines[Value.Line - 1]) + 1)\r\n else\r\n Value.Char := 1;\r\n if (Value.Char <> fBlockEnd.Char) or (Value.Line <> fBlockEnd.Line) then\r\n begin\r\n if (Value.Char <> fBlockEnd.Char) or (Value.Line <> fBlockEnd.Line) then\r\n begin\r\n if (fActiveSelectionMode = smColumn) and (Value.Char <> fBlockEnd.Char) then\r\n begin\r\n InvalidateLines(\r\n Min(fBlockBegin.Line, Min(fBlockEnd.Line, Value.Line)),\r\n Max(fBlockBegin.Line, Max(fBlockEnd.Line, Value.Line)));\r\n fBlockEnd := Value;\r\n end\r\n else begin\r\n nLine := fBlockEnd.Line;\r\n fBlockEnd := Value;\r\n if (fActiveSelectionMode <> smColumn) or (fBlockBegin.Char <> fBlockEnd.Char) then\r\n InvalidateLines(nLine, fBlockEnd.Line);\r\n end;\r\n StatusChanged([scSelection]);\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TCustomSynEdit.SetCaretX(Value: Integer);\r\nvar\r\n vNewCaret: TBufferCoord;\r\nbegin\r\n vNewCaret.Char := Value;\r\n vNewCaret.Line := CaretY;\r\n SetCaretXY(vNewCaret);\r\nend;\r\n\r\nprocedure TCustomSynEdit.SetCaretY(Value: Integer);\r\nvar\r\n vNewCaret: TBufferCoord;\r\nbegin\r\n vNewCaret.Line := Value;\r\n vNewCaret.Char := CaretX;\r\n SetCaretXY(vNewCaret);\r\nend;\r\n\r\nprocedure TCustomSynEdit.InternalSetCaretX(Value: Integer);\r\nvar\r\n vNewCaret: TBufferCoord;\r\nbegin\r\n vNewCaret.Char := Value;\r\n vNewCaret.Line := CaretY;\r\n InternalSetCaretXY(vNewCaret);\r\nend;\r\n\r\nprocedure TCustomSynEdit.InternalSetCaretY(Value: Integer);\r\nvar\r\n vNewCaret: TBufferCoord;\r\nbegin\r\n vNewCaret.Line := Value;\r\n vNewCaret.Char := CaretX;\r\n InternalSetCaretXY(vNewCaret);\r\nend;\r\n\r\nfunction TCustomSynEdit.GetCaretXY: TBufferCoord;\r\nbegin\r\n Result.Char := CaretX;\r\n Result.Line := CaretY;\r\nend;\r\n\r\nfunction TCustomSynEdit.GetDisplayX: Integer;\r\nbegin\r\n Result := DisplayXY.Column;\r\nend;\r\n\r\nfunction TCustomSynEdit.GetDisplayY: Integer;\r\nbegin\r\n if not WordWrap then\r\n Result := CaretY\r\n else\r\n Result := DisplayXY.Row;\r\nend;\r\n\r\nFunction TCustomSynEdit.GetDisplayXY: TDisplayCoord;\r\nbegin\r\n Result := BufferToDisplayPos(CaretXY);\r\n if WordWrap and fCaretAtEOL then\r\n begin\r\n if Result.Column = 1 then\r\n begin\r\n Dec(Result.Row);\r\n Result.Column := fWordWrapPlugin.GetRowLength(Result.Row) +1;\r\n end\r\n else begin\r\n // Work-around situations where fCaretAtEOL should have been updated because of\r\n //text change (it's only valid when Column = 1). Updating it in ProperSetLine()\r\n //would probably be the right thing, but...\r\n fCaretAtEOL := False;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TCustomSynEdit.SetCaretXY(const Value: TBufferCoord);\r\n//there are two setCaretXY methods. One Internal, one External. The published\r\n//property CaretXY (re)sets the block as well\r\nbegin\r\n IncPaintLock;\r\n try\r\n Include(fStatusChanges, scSelection);\r\n SetCaretXYEx(True, Value);\r\n if SelAvail then\r\n InvalidateSelection;\r\n fBlockBegin.Char := fCaretX;\r\n fBlockBegin.Line := fCaretY;\r\n fBlockEnd := fBlockBegin;\r\n finally\r\n DecPaintLock;\r\n end;\r\nend;\r\n\r\nprocedure TCustomSynEdit.InternalSetCaretXY(const Value: TBufferCoord);\r\nbegin\r\n SetCaretXYEx(True, Value);\r\nend;\r\n\r\nprocedure TCustomSynEdit.UpdateLastCaretX;\r\nbegin\r\n fLastCaretX := DisplayX;\r\nend;\r\n\r\nprocedure TCustomSynEdit.SetCaretXYEx(CallEnsureCursorPos: Boolean; Value: TBufferCoord);\r\nvar\r\n nMaxX: Integer;\r\n vTriggerPaint: boolean;\r\nbegin\r\n fCaretAtEOL := False;\r\n vTriggerPaint := HandleAllocated;\r\n if vTriggerPaint then\r\n DoOnPaintTransient(ttBefore);\r\n if WordWrap then\r\n nMaxX := MaxInt\r\n else\r\n nMaxX := MaxScrollWidth + 1;\r\n if Value.Line > Lines.Count then\r\n Value.Line := Lines.Count;\r\n if Value.Line < 1 then\r\n begin\r\n // this is just to make sure if Lines stringlist should be empty\r\n Value.Line := 1;\r\n if not (eoScrollPastEol in fOptions) then\r\n nMaxX := 1;\r\n end\r\n else\r\n begin\r\n if not (eoScrollPastEol in fOptions) then\r\n nMaxX := Length(Lines[Value.Line - 1]) + 1;\r\n end;\r\n if (Value.Char > nMaxX) and (not(eoScrollPastEol in Options) or\r\n not(eoAutoSizeMaxScrollWidth in Options)) then\r\n begin\r\n Value.Char := nMaxX;\r\n end;\r\n if Value.Char < 1 then\r\n Value.Char := 1;\r\n if (Value.Char <> fCaretX) or (Value.Line <> fCaretY) then\r\n begin\r\n IncPaintLock;\r\n try\r\n // simply include the flags, fPaintLock is > 0\r\n if fCaretX <> Value.Char then\r\n begin\r\n fCaretX := Value.Char;\r\n Include(fStatusChanges, scCaretX);\r\n end;\r\n if fCaretY <> Value.Line then\r\n begin\r\n if ActiveLineColor <> clNone then\r\n begin\r\n InvalidateLine(Value.Line);\r\n InvalidateLine(fCaretY);\r\n end;\r\n fCaretY := Value.Line;\r\n Include(fStatusChanges, scCaretY);\r\n end;\r\n // Call UpdateLastCaretX before DecPaintLock because the event handler it\r\n // calls could raise an exception, and we don't want fLastCaretX to be\r\n // left in an undefined state if that happens.\r\n UpdateLastCaretX;\r\n if CallEnsureCursorPos then\r\n EnsureCursorPosVisible;\r\n Include(fStateFlags, sfCaretChanged);\r\n Include(fStateFlags, sfScrollbarChanged);\r\n finally\r\n DecPaintLock;\r\n end;\r\n end\r\n else begin\r\n // Also call UpdateLastCaretX if the caret didn't move. Apps don't know\r\n // anything about fLastCaretX and they shouldn't need to. So, to avoid any\r\n // unwanted surprises, always update fLastCaretX whenever CaretXY is\r\n // assigned to.\r\n // Note to SynEdit developers: If this is undesirable in some obscure\r\n // case, just save the value of fLastCaretX before assigning to CaretXY and\r\n // restore it afterward as appropriate.\r\n UpdateLastCaretX;\r\n end;\r\n if vTriggerPaint then\r\n DoOnPaintTransient(ttAfter);\r\nend;\r\n\r\nfunction TCustomSynEdit.CaretInView: Boolean;\r\nvar\r\n vCaretRowCol: TDisplayCoord;\r\nbegin\r\n vCaretRowCol := DisplayXY;\r\n Result := (vCaretRowCol.Column >= LeftChar)\r\n and (vCaretRowCol.Column <= LeftChar + CharsInWindow)\r\n and (vCaretRowCol.Row >= TopLine)\r\n and (vCaretRowCol.Row <= TopLine + LinesInWindow);\r\nend;\r\n\r\nprocedure TCustomSynEdit.SetActiveLineColor(Value: TColor);\r\nbegin\r\n if (fActiveLineColor<>Value) then\r\n begin\r\n fActiveLineColor:=Value;\r\n InvalidateLine(CaretY);\r\n end;\r\nend;\r\n\r\nprocedure TCustomSynEdit.SetFont(const Value: TFont);\r\n{$IFDEF SYN_CLX}\r\n{$ELSE}\r\nvar\r\n DC: HDC;\r\n Save: THandle;\r\n Metrics: TTextMetric;\r\n AveCW, MaxCW: Integer;\r\n{$ENDIF}\r\nbegin\r\n{$IFDEF SYN_CLX}\r\n inherited Font := Value;\r\n{$ELSE}\r\n DC := GetDC(0);\r\n Save := SelectObject(DC, Value.Handle);\r\n GetTextMetrics(DC, Metrics);\r\n SelectObject(DC, Save);\r\n ReleaseDC(0, DC);\r\n with Metrics do\r\n begin\r\n AveCW := tmAveCharWidth;\r\n MaxCW := tmMaxCharWidth;\r\n end;\r\n case AveCW = MaxCW of\r\n True: inherited Font := Value;\r\n False:\r\n begin\r\n with fFontDummy do\r\n begin\r\n Color := Value.Color;\r\n Pitch := fpFixed;\r\n Size := Value.Size;\r\n Style := Value.Style;\r\n Name := Value.Name;\r\n end;\r\n inherited Font := fFontDummy;\r\n end;\r\n end;\r\n{$ENDIF}\r\n TSynEditStringList(fLines).FontChanged;\r\n if fGutter.ShowLineNumbers then\r\n GutterChanged(Self);\r\nend;\r\n\r\nprocedure TCustomSynEdit.SetGutterWidth(Value: Integer);\r\nbegin\r\n Value := Max(Value, 0);\r\n if fGutterWidth <> Value then\r\n begin\r\n fGutterWidth := Value;\r\n fTextOffset := fGutterWidth + 2 - (LeftChar - 1) * fCharWidth;\r\n if HandleAllocated then\r\n begin\r\n fCharsInWindow := Max(ClientWidth - fGutterWidth - 2, 0) div fCharWidth;\r\n if WordWrap then\r\n fWordWrapPlugin.DisplayChanged;\r\n UpdateScrollBars;\r\n Invalidate;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TCustomSynEdit.SetLeftChar(Value: Integer);\r\nvar\r\n MaxVal: Integer;\r\n iDelta: Integer;\r\n iTextArea: TRect;\r\nbegin\r\n if WordWrap then\r\n Value := 1;\r\n\r\n if eoScrollPastEol in Options then\r\n begin\r\n if eoAutoSizeMaxScrollWidth in Options then\r\n MaxVal := MaxInt - CharsInWindow\r\n else\r\n MaxVal := MaxScrollWidth - CharsInWindow + 1\r\n end\r\n else\r\n begin\r\n MaxVal := TSynEditStringList(Lines).LengthOfLongestLine;\r\n if MaxVal > CharsInWindow then\r\n MaxVal := MaxVal - CharsInWindow + 1\r\n else\r\n MaxVal := 1;\r\n end;\r\n Value := MinMax(Value, 1, MaxVal);\r\n if Value <> fLeftChar then\r\n begin\r\n iDelta := fLeftChar - Value;\r\n fLeftChar := Value;\r\n fTextOffset := fGutterWidth + 2 - (LeftChar - 1) * fCharWidth;\r\n if Abs(iDelta) < CharsInWindow then\r\n begin\r\n iTextArea := ClientRect;\r\n Inc(iTextArea.Left, fGutterWidth + 2);\r\n{$IFDEF SYN_CLX}\r\n ScrollWindow(Self, iDelta * CharWidth, 0, @iTextArea);\r\n{$ELSE}\r\n ScrollWindow(Handle, iDelta * CharWidth, 0, @iTextArea, @iTextArea);\r\n{$ENDIF}\r\n end\r\n else\r\n InvalidateLines(-1, -1);\r\n if (Options >= [eoAutoSizeMaxScrollWidth, eoScrollPastEol]) and\r\n (MaxScrollWidth < LeftChar + CharsInWindow) then\r\n begin\r\n MaxScrollWidth := LeftChar + CharsInWindow\r\n end\r\n else\r\n UpdateScrollBars;\r\n StatusChanged([scLeftChar]);\r\n end;\r\nend;\r\n\r\nprocedure TCustomSynEdit.SetLines(Value: TUnicodeStrings);\r\nbegin\r\n Lines.Assign(Value);\r\nend;\r\n\r\nprocedure TCustomSynEdit.SetLineText(Value: UnicodeString);\r\nbegin\r\n if (CaretY >= 1) and (CaretY <= Max(1, Lines.Count)) then\r\n Lines[CaretY - 1] := Value;\r\nend;\r\n\r\nprocedure TCustomSynEdit.SetFontSmoothing(AValue: TSynFontSmoothMethod);\r\nconst\r\n NONANTIALIASED_QUALITY = 3;\r\n ANTIALIASED_QUALITY = 4;\r\n CLEARTYPE_QUALITY = 5;\r\nvar\r\n bMethod: Byte;\r\n lf: TLogFont;\r\nbegin\r\n if fFontSmoothing <> AValue then begin\r\n fFontSmoothing:= AValue;\r\n case fFontSmoothing of\r\n fsmAntiAlias:\r\n bMethod:= ANTIALIASED_QUALITY;\r\n fsmClearType:\r\n bMethod:= CLEARTYPE_QUALITY;\r\n else // fsmNone also\r\n bMethod:= NONANTIALIASED_QUALITY;\r\n end;\r\n GetObject(Font.Handle, SizeOf(TLogFont), @lf);\r\n lf.lfQuality:= bMethod;\r\n Font.Handle:= CreateFontIndirect(lf);\r\n end;\r\nend;\r\n\r\nprocedure TCustomSynEdit.SetName(const Value: TComponentName);\r\nvar\r\n TextToName: Boolean;\r\nbegin\r\n TextToName := (ComponentState * [csDesigning, csLoading] = [csDesigning])\r\n and (TrimRight(Text) = Name);\r\n inherited SetName(Value);\r\n if TextToName then\r\n Text := Value;\r\nend;\r\n\r\nprocedure TCustomSynEdit.SetScrollBars(const Value: TScrollStyle);\r\nbegin\r\n if (FScrollBars <> Value) then\r\n begin\r\n FScrollBars := Value;\r\n UpdateScrollBars;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TCustomSynEdit.SetSelTextPrimitive(const Value: UnicodeString);\r\nbegin\r\n SetSelTextPrimitiveEx(fActiveSelectionMode, PWideChar(Value), True);\r\nend;\r\n\r\n// This is really a last minute change and I hope I did it right.\r\n// Reason for this modification: next two lines will loose the CaretX position\r\n// if eoScrollPastEol is not set in Options. That is not really a good idea\r\n// as we would typically want the cursor to stay where it is.\r\n// To fix this (in the absence of a better idea), I changed the code in\r\n// DeleteSelection not to trim the string if eoScrollPastEol is not set.\r\nprocedure TCustomSynEdit.SetSelTextPrimitiveEx(PasteMode: TSynSelectionMode;\r\n Value: PWideChar; AddToUndoList: Boolean);\r\nvar\r\n BB, BE: TBufferCoord;\r\n TempString: UnicodeString;\r\n\r\n procedure DeleteSelection;\r\n var\r\n x, MarkOffset, MarkOffset2: Integer;\r\n UpdateMarks: Boolean;\r\n begin\r\n UpdateMarks := False;\r\n MarkOffset := 0;\r\n MarkOffset2 := 0;\r\n case fActiveSelectionMode of\r\n smNormal:\r\n begin\r\n if Lines.Count > 0 then\r\n begin\r\n // Create a string that contains everything on the first line up\r\n // to the selection mark, and everything on the last line after\r\n // the selection mark.\r\n if BB.Char > 1 then\r\n MarkOffset2 := 1;\r\n TempString := Copy(Lines[BB.Line - 1], 1, BB.Char - 1) +\r\n Copy(Lines[BE.Line - 1], BE.Char, MaxInt);\r\n // Delete all lines in the selection range.\r\n TSynEditStringList(Lines).DeleteLines(BB.Line, BE.Line - BB.Line);\r\n // Put the stuff that was outside of selection back in.\r\n if Options >= [eoScrollPastEol, eoTrimTrailingSpaces] then\r\n TempString := TrimTrailingSpaces(TempString);\r\n Lines[BB.Line - 1] := TempString;\r\n end;\r\n UpdateMarks := True;\r\n InternalCaretXY := BB;\r\n end;\r\n smColumn:\r\n begin\r\n // swap X if needed\r\n if BB.Char > BE.Char then\r\n SwapInt(Integer(BB.Char), Integer(BE.Char));\r\n\r\n for x := BB.Line - 1 to BE.Line - 1 do\r\n begin\r\n TempString := Lines[x];\r\n Delete(TempString, BB.Char, BE.Char - BB.Char);\r\n ProperSetLine(x, TempString);\r\n end;\r\n // Lines never get deleted completely, so keep caret at end.\r\n InternalCaretXY := BufferCoord(BB.Char, fBlockEnd.Line);\r\n // Column deletion never removes a line entirely, so no mark\r\n // updating is needed here.\r\n end;\r\n smLine:\r\n begin\r\n if BE.Line = Lines.Count then\r\n begin\r\n Lines[BE.Line - 1] := '';\r\n for x := BE.Line - 2 downto BB.Line - 1 do\r\n Lines.Delete(x);\r\n end\r\n else begin\r\n for x := BE.Line - 1 downto BB.Line - 1 do\r\n Lines.Delete(x);\r\n end;\r\n // smLine deletion always resets to first column.\r\n InternalCaretXY := BufferCoord(1, BB.Line);\r\n UpdateMarks := TRUE;\r\n MarkOffset := 1;\r\n end;\r\n end;\r\n // Update marks\r\n if UpdateMarks then\r\n DoLinesDeleted(BB.Line + MarkOffset2, BE.Line - BB.Line + MarkOffset);\r\n end;\r\n\r\n procedure InsertText;\r\n\r\n function CountLines(p: PWideChar): Integer;\r\n begin\r\n Result := 0;\r\n while p^ <> #0 do\r\n begin\r\n if p^ = #13 then\r\n Inc(p);\r\n if p^ = #10 then\r\n Inc(p);\r\n Inc(Result);\r\n p := GetEOL(p);\r\n end;\r\n end;\r\n\r\n function InsertNormal: Integer;\r\n var\r\n sLeftSide: UnicodeString;\r\n sRightSide: UnicodeString;\r\n Str: UnicodeString;\r\n Start: PWideChar;\r\n P: PWideChar;\r\n begin\r\n Result := 0;\r\n sLeftSide := Copy(LineText, 1, CaretX - 1);\r\n if CaretX - 1 > Length(sLeftSide) then\r\n begin\r\n sLeftSide := sLeftSide + UnicodeStringOfChar(#32,\r\n CaretX - 1 - Length(sLeftSide));\r\n end;\r\n sRightSide := Copy(LineText, CaretX, Length(LineText) - (CaretX - 1));\r\n // step1: insert the first line of Value into current line\r\n Start := PWideChar(Value);\r\n P := GetEOL(Start);\r\n if P^ <> #0 then\r\n begin\r\n Str := sLeftSide + Copy(Value, 1, P - Start);\r\n ProperSetLine(CaretY - 1, Str);\r\n TSynEditStringList(Lines).InsertLines(CaretY, CountLines(P));\r\n end\r\n else begin\r\n Str := sLeftSide + Value + sRightSide;\r\n ProperSetLine(CaretY -1, Str);\r\n end;\r\n // step2: insert left lines of Value\r\n while P^ <> #0 do\r\n begin\r\n if P^ = #13 then\r\n Inc(P);\r\n if P^ = #10 then\r\n Inc(P);\r\n Inc(fCaretY);\r\n Include(fStatusChanges, scCaretY);\r\n Start := P;\r\n P := GetEOL(Start);\r\n if P = Start then\r\n begin\r\n if p^ <> #0 then\r\n Str := ''\r\n else\r\n Str := sRightSide;\r\n end\r\n else begin\r\n SetString(Str, Start, P - Start);\r\n if p^ = #0 then\r\n Str := Str + sRightSide\r\n end;\r\n ProperSetLine(CaretY -1, Str);\r\n Inc(Result);\r\n end;\r\n if eoTrimTrailingSpaces in Options then\r\n if sRightSide = '' then\r\n fCaretX := GetExpandedLength(Str, TabWidth) + 1\r\n else\r\n fCaretX := 1 + Length(Lines[CaretY - 1]) - Length(TrimTrailingSpaces(sRightSide))\r\n else fCaretX := 1 + Length(Lines[CaretY - 1]) - Length(sRightSide);\r\n StatusChanged([scCaretX]);\r\n end;\r\n\r\n function InsertColumn: Integer;\r\n var\r\n Str: UnicodeString;\r\n Start: PWideChar;\r\n P: PWideChar;\r\n Len: Integer;\r\n InsertPos: Integer;\r\n LineBreakPos: TBufferCoord;\r\n begin\r\n Result := 0;\r\n // Insert string at current position\r\n InsertPos := CaretX;\r\n Start := PWideChar(Value);\r\n repeat\r\n P := GetEOL(Start);\r\n if P <> Start then\r\n begin\r\n SetLength(Str, P - Start);\r\n Move(Start^, Str[1], (P - Start) * sizeof(WideChar));\r\n if CaretY > Lines.Count then\r\n begin\r\n Inc(Result);\r\n TempString := UnicodeStringOfChar(#32, InsertPos - 1) + Str;\r\n Lines.Add('');\r\n if AddToUndoList then\r\n begin\r\n LineBreakPos.Line := CaretY -1;\r\n LineBreakPos.Char := Length(Lines[CaretY - 2]) + 1;\r\n fUndoList.AddChange(crLineBreak, LineBreakPos, LineBreakPos, '', smNormal);\r\n end;\r\n end\r\n else begin\r\n TempString := Lines[CaretY - 1];\r\n Len := Length(TempString);\r\n if Len < InsertPos then\r\n begin\r\n TempString :=\r\n TempString + UnicodeStringOfChar(#32, InsertPos - Len - 1) + Str\r\n end\r\n else\r\n Insert(Str, TempString, InsertPos);\r\n end;\r\n ProperSetLine(CaretY - 1, TempString);\r\n // Add undo change here from PasteFromClipboard\r\n if AddToUndoList then\r\n begin\r\n fUndoList.AddChange(crPaste, BufferCoord(InsertPos, CaretY),\r\n BufferCoord(InsertPos + (P - Start), CaretY), '', fActiveSelectionMode);\r\n end;\r\n end;\r\n if P^ = #13 then\r\n begin\r\n Inc(P);\r\n if P^ = #10 then\r\n Inc(P);\r\n Inc(fCaretY);\r\n Include(fStatusChanges, scCaretY);\r\n end;\r\n Start := P;\r\n until P^ = #0;\r\n Inc(fCaretX, Length(Str));\r\n Include(fStatusChanges, scCaretX);\r\n end;\r\n\r\n function InsertLine: Integer;\r\n var\r\n Start: PWideChar;\r\n P: PWideChar;\r\n Str: UnicodeString;\r\n n: Integer;\r\n begin\r\n Result := 0;\r\n fCaretX := 1;\r\n // Insert string before current line\r\n Start := PWideChar(Value);\r\n repeat\r\n P := GetEOL(Start);\r\n if P <> Start then\r\n begin\r\n SetLength(Str, P - Start);\r\n Move(Start^, Str[1], (P - Start) * sizeof(WideChar));\r\n end\r\n else\r\n Str := '';\r\n if (P^ = #0) then\r\n begin\r\n n := Lines.Count;\r\n if (n >= CaretY) then\r\n Lines[CaretY - 1] := Str + Lines[CaretY - 1]\r\n else\r\n Lines.Add(Str);\r\n if eoTrimTrailingSpaces in Options then\r\n Lines[CaretY - 1] := TrimTrailingSpaces(Lines[CaretY - 1]);\r\n fCaretX := 1 + Length(Str);\r\n end\r\n else begin\r\n //--------- KV from SynEditStudio\r\n if (CaretY = Lines.Count) or InsertMode then\r\n begin\r\n Lines.Insert(CaretY -1, '');\r\n Inc(Result);\r\n end;\r\n //---------\r\n ProperSetLine(CaretY - 1, Str);\r\n Inc(fCaretY);\r\n Include(fStatusChanges, scCaretY);\r\n Inc(Result);\r\n if P^ = #13 then\r\n Inc(P);\r\n if P^ = #10 then\r\n Inc(P);\r\n Start := P;\r\n end;\r\n until P^ = #0;\r\n StatusChanged([scCaretX]);\r\n end;\r\n\r\n var\r\n StartLine: Integer;\r\n StartCol: Integer;\r\n InsertedLines: Integer;\r\n begin\r\n if Value = '' then\r\n Exit;\r\n\r\n StartLine := CaretY;\r\n StartCol := CaretX;\r\n case PasteMode of\r\n smNormal:\r\n InsertedLines := InsertNormal;\r\n smColumn:\r\n InsertedLines := InsertColumn;\r\n smLine:\r\n InsertedLines := InsertLine;\r\n else\r\n InsertedLines := 0;\r\n end;\r\n // We delete selected based on the current selection mode, but paste\r\n // what's on the clipboard according to what it was when copied.\r\n // Update marks\r\n if InsertedLines > 0 then\r\n begin\r\n if (PasteMode = smNormal) and (StartCol > 1) then\r\n Inc(StartLine);\r\n DoLinesInserted(StartLine, InsertedLines);\r\n end;\r\n // Force caret reset\r\n InternalCaretXY := CaretXY;\r\n end;\r\n\r\nbegin\r\n IncPaintLock;\r\n Lines.BeginUpdate;\r\n try\r\n BB := BlockBegin;\r\n BE := BlockEnd;\r\n if SelAvail then\r\n begin\r\n DeleteSelection;\r\n InternalCaretXY := BB;\r\n end;\r\n if (Value <> nil) and (Value[0] <> #0) then\r\n InsertText;\r\n if CaretY < 1 then\r\n InternalCaretY := 1;\r\n finally\r\n Lines.EndUpdate;\r\n DecPaintLock;\r\n end;\r\nend;\r\n\r\nprocedure TCustomSynEdit.SynSetText(const Value: UnicodeString);\r\nbegin\r\n Lines.Text := Value;\r\nend;\r\n\r\nprocedure TCustomSynEdit.SetTopLine(Value: Integer);\r\nvar\r\n Delta: Integer;\r\n{$IFDEF SYN_CLX}\r\n iClip: TRect;\r\n{$ENDIF}\r\nbegin\r\n if (eoScrollPastEof in Options) then\r\n Value := Min(Value, DisplayLineCount)\r\n else\r\n Value := Min(Value, DisplayLineCount - fLinesInWindow + 1);\r\n Value := Max(Value, 1);\r\n if Value <> TopLine then\r\n begin\r\n Delta := TopLine - Value;\r\n fTopLine := Value;\r\n if Abs(Delta) < fLinesInWindow then\r\n{$IFDEF SYN_CLX}\r\n begin\r\n iClip := GetClientRect;\r\n ScrollWindow(Self, 0, fTextHeight * Delta, @iClip);\r\n end\r\n{$ELSE}\r\n ScrollWindow(Handle, 0, fTextHeight * Delta, nil, nil)\r\n{$ENDIF}\r\n else\r\n Invalidate;\r\n\r\n UpdateWindow(Handle);\r\n UpdateScrollBars;\r\n StatusChanged([scTopLine]);\r\n end;\r\nend;\r\n\r\nprocedure TCustomSynEdit.ShowCaret;\r\nbegin\r\n if not (eoNoCaret in Options) and not (sfCaretVisible in fStateFlags) then\r\n begin\r\n{$IFDEF SYN_CLX}\r\n kTextDrawer.ShowCaret(Self);\r\n{$ELSE}\r\n if Windows.ShowCaret(Handle) then\r\n{$ENDIF}\r\n Include(fStateFlags, sfCaretVisible);\r\n end;\r\nend;\r\n\r\nprocedure TCustomSynEdit.UpdateCaret;\r\nvar\r\n CX, CY: Integer;\r\n iClientRect: TRect;\r\n vCaretDisplay: TDisplayCoord;\r\n vCaretPix: TPoint;\r\n{$IFNDEF SYN_CLX}\r\n cf: TCompositionForm;\r\n{$ENDIF}\r\nbegin\r\n if (PaintLock <> 0) or not (Focused or FAlwaysShowCaret) then\r\n Include(fStateFlags, sfCaretChanged)\r\n else\r\n begin\r\n Exclude(fStateFlags, sfCaretChanged);\r\n vCaretDisplay := DisplayXY;\r\n if WordWrap and (vCaretDisplay.Column > CharsInWindow + 1) then\r\n vCaretDisplay.Column := CharsInWindow + 1;\r\n vCaretPix := RowColumnToPixels(vCaretDisplay);\r\n CX := vCaretPix.X + FCaretOffset.X;\r\n CY := vCaretPix.Y + FCaretOffset.Y;\r\n iClientRect := GetClientRect;\r\n Inc(iClientRect.Left, fGutterWidth);\r\n if (CX >= iClientRect.Left) and (CX < iClientRect.Right)\r\n and (CY >= iClientRect.Top) and (CY < iClientRect.Bottom) then\r\n begin\r\n SetCaretPos(CX, CY);\r\n ShowCaret;\r\n end\r\n else\r\n begin\r\n SetCaretPos(CX, CY);\r\n HideCaret;\r\n end;\r\n{$IFNDEF SYN_CLX}\r\n cf.dwStyle := CFS_POINT;\r\n cf.ptCurrentPos := Point(CX, CY);\r\n ImmSetCompositionWindow(ImmGetContext(Handle), @cf);\r\n{$ENDIF}\r\n end;\r\nend;\r\n\r\nprocedure TCustomSynEdit.UpdateScrollBars;\r\nvar\r\n nMaxScroll: Integer;\r\n{$IFNDEF SYN_CLX}\r\n ScrollInfo: TScrollInfo;\r\n iRightChar: Integer;\r\n{$ELSE}\r\n iClientRect: TRect;\r\n\r\n procedure CalcScrollbarsVisible;\r\n begin\r\n if not HandleAllocated or (PaintLock <> 0) then\r\n Include(fStateFlags, sfScrollbarChanged)\r\n else begin\r\n Exclude(fStateFlags, sfScrollbarChanged);\r\n if fScrollBars <> ssNone then\r\n begin\r\n if (fScrollBars in [ssBoth, ssHorizontal]) and (not WordWrap) then\r\n begin\r\n if eoScrollPastEol in Options then\r\n nMaxScroll := MaxScrollWidth\r\n else\r\n nMaxScroll := Max(TSynEditStringList(Lines).LengthOfLongestLine, 1);\r\n\r\n FHScrollBar.Min := 1;\r\n FHScrollBar.Max := nMaxScroll; // Qt handles values above MAX_SCROLL\r\n FHScrollBar.Position := LeftChar;\r\n FHScrollBar.LargeChange := CharsInWindow - Ord(eoScrollByOneLess in fOptions);\r\n\r\n if eoHideShowScrollbars in Options then\r\n FHScrollBar.Visible := nMaxScroll > CharsInWindow\r\n else FHScrollBar.Visible := True;\r\n\r\n end\r\n else\r\n FHScrollBar.Visible := False;\r\n\r\n if fScrollBars in [ssBoth, ssVertical] then\r\n begin\r\n nMaxScroll := DisplayLineCount;\r\n if eoScrollPastEof in Options then\r\n Inc(nMaxScroll, LinesInWindow - 1);\r\n\r\n FVScrollBar.Min := 1;\r\n FVScrollBar.Max := Max(1, nMaxScroll);\r\n FVScrollBar.LargeChange := LinesInWindow shr Ord(eoHalfPageScroll in fOptions);\r\n FVScrollBar.Position := TopLine;\r\n\r\n if eoHideShowScrollbars in Options then\r\n FVScrollBar.Visible := nMaxScroll > LinesInWindow\r\n else\r\n FVScrollBar.Visible := True;\r\n end\r\n else\r\n FVScrollBar.Visible:=FALSE;\r\n end\r\n else\r\n begin\r\n FHScrollBar.Visible := False;\r\n FVScrollBar.Visible := False;\r\n end;\r\n end;\r\n end;\r\n\r\n{$ENDIF}\r\nbegin\r\n{$IFNDEF SYN_CLX}\r\n if not HandleAllocated or (PaintLock <> 0) then\r\n Include(fStateFlags, sfScrollbarChanged)\r\n else begin\r\n Exclude(fStateFlags, sfScrollbarChanged);\r\n if fScrollBars <> ssNone then\r\n begin\r\n ScrollInfo.cbSize := SizeOf(ScrollInfo);\r\n ScrollInfo.fMask := SIF_ALL;\r\n if not(eoHideShowScrollbars in Options) then\r\n begin\r\n ScrollInfo.fMask := ScrollInfo.fMask or SIF_DISABLENOSCROLL;\r\n end;\r\n\r\n if Visible then SendMessage(Handle, WM_SETREDRAW, 0, 0);\r\n\r\n if (fScrollBars in [{$IFDEF SYN_COMPILER_17_UP}TScrollStyle.{$ENDIF}ssBoth, {$IFDEF SYN_COMPILER_17_UP}TScrollStyle.{$ENDIF}ssHorizontal]) and not WordWrap then\r\n begin\r\n if eoScrollPastEol in Options then\r\n nMaxScroll := MaxScrollWidth\r\n else\r\n nMaxScroll := Max(TSynEditStringList(Lines).LengthOfLongestLine, 1);\r\n if nMaxScroll <= MAX_SCROLL then\r\n begin\r\n ScrollInfo.nMin := 1;\r\n ScrollInfo.nMax := nMaxScroll;\r\n ScrollInfo.nPage := CharsInWindow;\r\n ScrollInfo.nPos := LeftChar;\r\n end\r\n else begin\r\n ScrollInfo.nMin := 0;\r\n ScrollInfo.nMax := MAX_SCROLL;\r\n ScrollInfo.nPage := MulDiv(MAX_SCROLL, CharsInWindow, nMaxScroll);\r\n ScrollInfo.nPos := MulDiv(MAX_SCROLL, LeftChar, nMaxScroll);\r\n end;\r\n\r\n ShowScrollBar(Handle, SB_HORZ, not(eoHideShowScrollbars in Options) or\r\n (ScrollInfo.nMin = 0) or (ScrollInfo.nMax > CharsInWindow));\r\n SetScrollInfo(Handle, SB_HORZ, ScrollInfo, True);\r\n\r\n //Now for the arrows\r\n if (eoDisableScrollArrows in Options) or (nMaxScroll <= CharsInWindow) then\r\n begin\r\n iRightChar := LeftChar + CharsInWindow -1;\r\n if (LeftChar <= 1) and (iRightChar >= nMaxScroll) then\r\n begin\r\n EnableScrollBar(Handle, SB_HORZ, ESB_DISABLE_BOTH);\r\n end\r\n else begin\r\n EnableScrollBar(Handle, SB_HORZ, ESB_ENABLE_BOTH);\r\n if (LeftChar <= 1) then\r\n EnableScrollBar(Handle, SB_HORZ, ESB_DISABLE_LEFT)\r\n else if iRightChar >= nMaxScroll then\r\n EnableScrollBar(Handle, SB_HORZ, ESB_DISABLE_RIGHT)\r\n end;\r\n end\r\n else\r\n EnableScrollBar(Handle, SB_HORZ, ESB_ENABLE_BOTH);\r\n end\r\n else\r\n ShowScrollBar(Handle, SB_HORZ, False);\r\n\r\n if fScrollBars in [ssBoth, ssVertical] then\r\n begin\r\n nMaxScroll := DisplayLineCount;\r\n if (eoScrollPastEof in Options) then\r\n Inc(nMaxScroll, LinesInWindow - 1);\r\n if nMaxScroll <= MAX_SCROLL then\r\n begin\r\n ScrollInfo.nMin := 1;\r\n ScrollInfo.nMax := Max(1, nMaxScroll);\r\n ScrollInfo.nPage := LinesInWindow;\r\n ScrollInfo.nPos := TopLine;\r\n end\r\n else begin\r\n ScrollInfo.nMin := 0;\r\n ScrollInfo.nMax := MAX_SCROLL;\r\n ScrollInfo.nPage := MulDiv(MAX_SCROLL, LinesInWindow, nMaxScroll);\r\n ScrollInfo.nPos := MulDiv(MAX_SCROLL, TopLine, nMaxScroll);\r\n end;\r\n\r\n ShowScrollBar(Handle, SB_VERT, not(eoHideShowScrollbars in Options) or\r\n (ScrollInfo.nMin = 0) or (ScrollInfo.nMax > LinesInWindow));\r\n SetScrollInfo(Handle, SB_VERT, ScrollInfo, True);\r\n\r\n if (eoDisableScrollArrows in Options) or (nMaxScroll <= LinesInWindow) then\r\n begin\r\n if (TopLine <= 1) and (nMaxScroll <= LinesInWindow) then\r\n begin\r\n EnableScrollBar(Handle, SB_VERT, ESB_DISABLE_BOTH);\r\n end\r\n else begin\r\n EnableScrollBar(Handle, SB_VERT, ESB_ENABLE_BOTH);\r\n if (TopLine <= 1) then\r\n EnableScrollBar(Handle, SB_VERT, ESB_DISABLE_UP)\r\n else if ((DisplayLineCount - TopLine - LinesInWindow + 1) = 0) then\r\n EnableScrollBar(Handle, SB_VERT, ESB_DISABLE_DOWN);\r\n end;\r\n end\r\n else\r\n EnableScrollBar(Handle, SB_VERT, ESB_ENABLE_BOTH);\r\n\r\n if Visible then SendMessage(Handle, WM_SETREDRAW, -1, 0);\r\n if fPaintLock=0 then\r\n Invalidate;\r\n\r\n end\r\n else\r\n ShowScrollBar(Handle, SB_VERT, False);\r\n\r\n end {endif fScrollBars <> ssNone}\r\n else\r\n ShowScrollBar(Handle, SB_BOTH, False);\r\n end;\r\n{$ELSE}\r\n if FHScrollBar<>nil then\r\n begin\r\n CalcScrollBarsVisible;\r\n\r\n iClientRect := GetClientRect;\r\n\r\n FHScrollBar.Left := iClientRect.Left;\r\n FHScrollBar.Top := iClientRect.Bottom;\r\n FHScrollBar.Width := iClientRect.Right - iClientRect.Left;\r\n\r\n FVScrollBar.Top := iClientRect.Top;\r\n FVScrollBar.Left := iClientRect.Right;\r\n FVScrollBar.Height := iClientRect.Bottom - iClientRect.Top;\r\n end;\r\n{$ENDIF}\r\nend;\r\n\r\n{$IFDEF SYN_CLX}\r\nprocedure TCustomSynEdit.ScrollEvent(Sender: TObject; ScrollCode: TScrollCode; var ScrollPos: Integer);\r\nvar\r\n ScrollKind: TScrollBarKind;\r\nbegin\r\n if Sender = FHScrollBar then\r\n begin\r\n ScrollKind := sbHorizontal;\r\n LeftChar := ScrollPos;\r\n end\r\n else if Sender = FVScrollBar then\r\n begin\r\n ScrollKind := sbVertical;\r\n TopLine := ScrollPos;\r\n end\r\n else\r\n Exit;\r\n if Visible and CanFocus and not (csDesigning in ComponentState) then\r\n SetFocus\r\n else\r\n UpdateCaret;\r\n if Assigned(OnScroll) then OnScroll(Self,ScrollKind);\r\nend;\r\n\r\nfunction TCustomSynEdit.GetClientRect: TRect;\r\nbegin\r\n Result := Inherited GetClientRect;\r\n if FHScrollBar.Visible then\r\n Result.Bottom := Result.Bottom - CYHSCROLL;\r\n if FVScrollBar.Visible then\r\n Result.Right := Result.Right - CXVSCROLL;\r\n if BorderStyle <> bsNone then\r\n InflateRect(Result, -FrameWidth, -FrameWidth);\r\nend;\r\n\r\nfunction TCustomSynEdit.GetClientOrigin: TPoint;\r\nbegin\r\n Result := inherited GetClientOrigin;\r\n if BorderStyle <> bsNone then\r\n begin\r\n Inc(Result.X, FrameWidth);\r\n Inc(Result.Y, FrameWidth);\r\n end;\r\nend;\r\n\r\nprocedure TCustomSynEdit.Resize;\r\nbegin\r\n inherited Resize;\r\n SizeOrFontChanged(False);\r\nend;\r\n\r\nfunction TCustomSynEdit.WidgetFlags: Integer;\r\nbegin\r\n Result := Integer(WidgetFlags_WRepaintNoErase);\r\nend;\r\n{$ENDIF}\r\n\r\n{$IFDEF SYN_COMPILER_6_UP}\r\nfunction TCustomSynEdit.DoMouseWheel(Shift: TShiftState;\r\n WheelDelta: Integer; MousePos: TPoint): Boolean;\r\nconst\r\n WHEEL_DIVISOR = 120; // Mouse Wheel standard\r\nvar\r\n iWheelClicks: Integer;\r\n iLinesToScroll: Integer;\r\nbegin\r\n Result := inherited DoMouseWheel(Shift, WheelDelta, MousePos);\r\n if Result then\r\n Exit;\r\n{$IFDEF SYN_CLX}\r\n if ssCtrl in Application.KeyState then\r\n{$ELSE}\r\n if GetKeyState(SYNEDIT_CONTROL) < 0 then\r\n{$ENDIF}\r\n iLinesToScroll := LinesInWindow shr Ord(eoHalfPageScroll in fOptions)\r\n else\r\n iLinesToScroll := 3;\r\n Inc(fMouseWheelAccumulator, WheelDelta);\r\n iWheelClicks := fMouseWheelAccumulator div WHEEL_DIVISOR;\r\n fMouseWheelAccumulator := fMouseWheelAccumulator mod WHEEL_DIVISOR;\r\n TopLine := TopLine - iWheelClicks * iLinesToScroll;\r\n Update;\r\n if Assigned(OnScroll) then OnScroll(Self,sbVertical);\r\n Result := True;\r\nend;\r\n{$ENDIF}\r\n\r\n{$IFDEF SYN_CLX}\r\nprocedure TCustomSynEdit.KeyString(var S: UnicodeString; var Handled: Boolean);\r\nvar\r\n i: Integer;\r\nbegin\r\n inherited;\r\n Handled := True;\r\n for i := 1 to Length(S) do\r\n DoKeyPressW(S[i]);\r\nend;\r\n\r\nfunction TCustomSynEdit.NeedKey(Key: Integer; Shift: TShiftState;\r\n const KeyText: UnicodeString): Boolean;\r\nbegin\r\n if ((Key = Key_Return) or (Key = Key_Enter)) then\r\n Result := WantReturns\r\n else\r\n Result := inherited NeedKey(Key, Shift, KeyText);\r\nend;\r\n{$ENDIF SYN_CLX}\r\n\r\n{$IFNDEF SYN_CLX}\r\nprocedure TCustomSynEdit.WMCaptureChanged(var Msg: TMessage);\r\nbegin\r\n fScrollTimer.Enabled := False;\r\n inherited;\r\nend;\r\n\r\nprocedure TCustomSynEdit.WMChar(var Msg: TWMChar);\r\nbegin\r\n{$IFNDEF UNICODE}\r\n if not Win32PlatformIsUnicode then\r\n Msg.CharCode := Word(KeyUnicode(AnsiChar(Msg.CharCode)));\r\n{$ENDIF}\r\n\r\n DoKeyPressW(Msg);\r\nend;\r\n\r\nprocedure TCustomSynEdit.WMClear(var Msg: TMessage);\r\nbegin\r\n if not ReadOnly then\r\n SelText := '';\r\nend;\r\n\r\nprocedure TCustomSynEdit.WMCopy(var Message: TMessage);\r\nbegin\r\n CopyToClipboard;\r\n Message.Result := ord(True);\r\nend;\r\n\r\nprocedure TCustomSynEdit.WMCut(var Message: TMessage);\r\nbegin\r\n if not ReadOnly then\r\n CutToClipboard;\r\n Message.Result := ord(True);\r\nend;\r\n\r\nprocedure TCustomSynEdit.WMDropFiles(var Msg: TMessage);\r\nvar\r\n i, iNumberDropped: Integer;\r\n FileNameA: array[0..MAX_PATH - 1] of AnsiChar;\r\n FileNameW: array[0..MAX_PATH - 1] of WideChar;\r\n Point: TPoint;\r\n FilesList: TUnicodeStringList;\r\nbegin\r\n try\r\n if Assigned(fOnDropFiles) then\r\n begin\r\n FilesList := TUnicodeStringList.Create;\r\n try\r\n iNumberDropped := DragQueryFile(THandle(Msg.wParam), Cardinal(-1),\r\n nil, 0);\r\n DragQueryPoint(THandle(Msg.wParam), Point);\r\n\r\n if Win32PlatformIsUnicode then\r\n for i := 0 to iNumberDropped - 1 do\r\n begin\r\n DragQueryFileW(THandle(Msg.wParam), i, FileNameW,\r\n sizeof(FileNameW) div 2);\r\n FilesList.Add(FileNameW)\r\n end\r\n else\r\n for i := 0 to iNumberDropped - 1 do\r\n begin\r\n DragQueryFileA(THandle(Msg.wParam), i, FileNameA,\r\n sizeof(FileNameA));\r\n FilesList.Add(UnicodeString(FileNameA))\r\n end;\r\n fOnDropFiles(Self, Point.X, Point.Y, FilesList);\r\n finally\r\n FilesList.Free;\r\n end;\r\n end;\r\n finally\r\n Msg.Result := 0;\r\n DragFinish(THandle(Msg.wParam));\r\n end;\r\nend;\r\n\r\nprocedure TCustomSynEdit.WMDestroy(var Message: TWMDestroy);\r\nbegin\r\n {$IFDEF UNICODE}\r\n // assign WindowText here, otherwise the VCL will call GetText twice\r\n if WindowText = nil then\r\n WindowText := Lines.GetText;\r\n {$ENDIF}\r\n inherited;\r\nend;\r\n\r\nprocedure TCustomSynEdit.WMEraseBkgnd(var Msg: TMessage);\r\nbegin\r\n Msg.Result := 1;\r\nend;\r\n\r\nprocedure TCustomSynEdit.WMGetDlgCode(var Msg: TWMGetDlgCode);\r\nbegin\r\n inherited;\r\n Msg.Result := Msg.Result or DLGC_WANTARROWS or DLGC_WANTCHARS;\r\n if fWantTabs then\r\n Msg.Result := Msg.Result or DLGC_WANTTAB;\r\n if fWantReturns then\r\n Msg.Result := Msg.Result or DLGC_WANTALLKEYS;\r\nend;\r\n\r\nprocedure TCustomSynEdit.WMGetText(var Msg: TWMGetText);\r\nbegin\r\n if HandleAllocated and IsWindowUnicode(Handle) then\r\n begin\r\n WStrLCopy(PWideChar(Msg.Text), PWideChar(Text), Msg.TextMax - 1);\r\n Msg.Result := WStrLen(PWideChar(Msg.Text));\r\n end\r\n else\r\n begin\r\n {$IFDEF SYN_COMPILER_18_UP}AnsiStrings.{$ENDIF}StrLCopy(PAnsiChar(Msg.Text), PAnsiChar(AnsiString(Text)), Msg.TextMax - 1);\r\n Msg.Result := {$IFDEF SYN_COMPILER_18_UP}AnsiStrings.{$ENDIF}StrLen(PAnsiChar(Msg.Text));\r\n end;\r\nend;\r\n\r\nprocedure TCustomSynEdit.WMGetTextLength(var Msg: TWMGetTextLength);\r\nbegin\r\n{$IFDEF SYN_COMPILER_4_UP}\r\n // Avoid (useless) temporary copy of WindowText while window is recreated\r\n // because of docking.\r\n if csDocking in ControlState then\r\n Msg.Result := 0\r\n else\r\n{$ENDIF}\r\n Msg.Result := Length(Text);\r\nend;\r\n\r\nprocedure TCustomSynEdit.WMHScroll(var Msg: TWMScroll);\r\nvar\r\n iMaxWidth: integer;\r\nbegin\r\n Msg.Result := 0;\r\n case Msg.ScrollCode of\r\n // Scrolls to start / end of the line\r\n SB_LEFT: LeftChar := 1;\r\n SB_RIGHT:\r\n if eoScrollPastEol in Options then\r\n LeftChar := MaxScrollWidth - CharsInWindow +1\r\n else\r\n // Simply set LeftChar property to the LengthOfLongestLine,\r\n // it would do the range checking and constrain the value if necessary\r\n LeftChar := TSynEditStringList(Lines).LengthOfLongestLine;\r\n // Scrolls one char left / right\r\n SB_LINERIGHT: LeftChar := LeftChar + 1;\r\n SB_LINELEFT: LeftChar := LeftChar - 1;\r\n // Scrolls one page of chars left / right\r\n SB_PAGERIGHT: LeftChar := LeftChar\r\n + (fCharsInWindow - Ord(eoScrollByOneLess in fOptions));\r\n SB_PAGELEFT: LeftChar := LeftChar\r\n - (fCharsInWindow - Ord(eoScrollByOneLess in fOptions));\r\n // Scrolls to the current scroll bar position\r\n SB_THUMBPOSITION,\r\n SB_THUMBTRACK:\r\n begin\r\n FIsScrolling := True;\r\n if eoScrollPastEol in Options then\r\n iMaxWidth := MaxScrollWidth\r\n else\r\n iMaxWidth := Max(TSynEditStringList(Lines).LengthOfLongestLine, 1);\r\n if iMaxWidth > MAX_SCROLL then\r\n LeftChar := MulDiv(iMaxWidth, Msg.Pos, MAX_SCROLL)\r\n else\r\n LeftChar := Msg.Pos;\r\n end;\r\n SB_ENDSCROLL: FIsScrolling := False;\r\n end;\r\n if Assigned(OnScroll) then OnScroll(Self,sbHorizontal);\r\nend;\r\n\r\nfunction IsWindows98orLater: Boolean;\r\nbegin\r\n Result := (Win32MajorVersion > 4) or\r\n (Win32MajorVersion = 4) and (Win32MinorVersion > 0);\r\nend;\r\n\r\nprocedure TCustomSynEdit.WMImeChar(var Msg: TMessage);\r\nbegin\r\n // do nothing here, the IME string is retrieved in WMImeComposition\r\n\r\n // Handling the WM_IME_CHAR message stops Windows from sending WM_CHAR\r\n // messages while using the IME\r\nend;\r\n\r\nprocedure TCustomSynEdit.WMImeComposition(var Msg: TMessage);\r\nvar\r\n imc: HIMC;\r\n PW: PWideChar;\r\n PA: PAnsiChar;\r\n PWLength: Integer;\r\n ImeCount: Integer;\r\nbegin\r\n if (Msg.LParam and GCS_RESULTSTR) <> 0 then\r\n begin\r\n imc := ImmGetContext(Handle);\r\n try\r\n if IsWindows98orLater then\r\n begin\r\n ImeCount := ImmGetCompositionStringW(imc, GCS_RESULTSTR, nil, 0);\r\n // ImeCount is always the size in bytes, also for Unicode\r\n GetMem(PW, ImeCount + sizeof(WideChar));\r\n try\r\n ImmGetCompositionStringW(imc, GCS_RESULTSTR, PW, ImeCount);\r\n PW[ImeCount div sizeof(WideChar)] := #0;\r\n CommandProcessor(ecImeStr, #0, PW);\r\n finally\r\n FreeMem(PW);\r\n end;\r\n end\r\n else\r\n begin\r\n ImeCount := ImmGetCompositionStringA(imc, GCS_RESULTSTR, nil, 0);\r\n // ImeCount is always the size in bytes, also for Unicode\r\n GetMem(PA, ImeCount + sizeof(AnsiChar));\r\n try\r\n ImmGetCompositionStringA(imc, GCS_RESULTSTR, PA, ImeCount);\r\n PA[ImeCount] := #0;\r\n\r\n PWLength := MultiByteToWideChar(DefaultSystemCodePage, 0, PA, ImeCount,\r\n nil, 0);\r\n GetMem(PW, (PWLength + 1) * sizeof(WideChar));\r\n try\r\n MultiByteToWideChar(DefaultSystemCodePage, 0, PA, ImeCount,\r\n PW, PWLength);\r\n CommandProcessor(ecImeStr, #0, PW);\r\n finally\r\n FreeMem(PW);\r\n end;\r\n finally\r\n FreeMem(PA);\r\n end;\r\n end;\r\n finally\r\n ImmReleaseContext(Handle, imc);\r\n end;\r\n end;\r\n inherited;\r\nend;\r\n\r\nprocedure TCustomSynEdit.WMImeNotify(var Msg: TMessage);\r\nvar\r\n imc: HIMC;\r\n LogFontW: TLogFontW;\r\n LogFontA: TLogFontA;\r\nbegin\r\n with Msg do\r\n begin\r\n case WParam of\r\n IMN_SETOPENSTATUS:\r\n begin\r\n imc := ImmGetContext(Handle);\r\n if imc <> 0 then\r\n begin\r\n if IsWindows98orLater then\r\n begin\r\n GetObjectW(Font.Handle, SizeOf(TLogFontW), @LogFontW);\r\n ImmSetCompositionFontW(imc, @LogFontW);\r\n end\r\n else\r\n begin\r\n GetObjectA(Font.Handle, SizeOf(TLogFontA), @LogFontA);\r\n ImmSetCompositionFontA(imc, @LogFontA);\r\n end;\r\n ImmReleaseContext(Handle, imc);\r\n end;\r\n end;\r\n end;\r\n end;\r\n inherited;\r\nend;\r\n\r\nprocedure TCustomSynEdit.WMKillFocus(var Msg: TWMKillFocus);\r\nbegin\r\n inherited;\r\n CommandProcessor(ecLostFocus, #0, nil);\r\n //Added check for focused to prevent caret disappearing problem\r\n if Focused or FAlwaysShowCaret then\r\n exit;\r\n HideCaret;\r\n Windows.DestroyCaret;\r\n if FHideSelection and SelAvail then\r\n InvalidateSelection;\r\nend;\r\n\r\nprocedure TCustomSynEdit.WMPaste(var Message: TMessage);\r\nbegin\r\n if not ReadOnly then\r\n PasteFromClipboard;\r\n Message.Result := ord(True);\r\nend;\r\n\r\nprocedure TCustomSynEdit.WMCancelMode(var Message:TMessage);\r\nbegin\r\n\r\nend;\r\n\r\nprocedure TCustomSynEdit.WMSetFocus(var Msg: TWMSetFocus);\r\nbegin\r\n CommandProcessor(ecGotFocus, #0, nil);\r\n\r\n InitializeCaret;\r\n if FHideSelection and SelAvail then\r\n InvalidateSelection;\r\nend;\r\n\r\nprocedure TCustomSynEdit.WMSetText(var Msg: TWMSetText);\r\nbegin\r\n Msg.Result := 1;\r\n try\r\n if HandleAllocated and IsWindowUnicode(Handle) then\r\n Text := PWideChar(Msg.Text)\r\n else\r\n Text := UnicodeString(PAnsiChar(Msg.Text));\r\n except\r\n Msg.Result := 0;\r\n raise\r\n end\r\nend;\r\n\r\nprocedure TCustomSynEdit.WMSize(var Msg: TWMSize);\r\nbegin\r\n inherited;\r\n SizeOrFontChanged(False);\r\nend;\r\n\r\nprocedure TCustomSynEdit.WMUndo(var Msg: TMessage);\r\nbegin\r\n Undo;\r\nend;\r\n\r\nvar\r\n ScrollHintWnd: THintWindow;\r\n\r\nfunction GetScrollHint: THintWindow;\r\nbegin\r\n if ScrollHintWnd = nil then\r\n ScrollHintWnd := HintWindowClass.Create(Application);\r\n Result := ScrollHintWnd;\r\nend;\r\n\r\nprocedure TCustomSynEdit.WMVScroll(var Msg: TWMScroll);\r\nvar\r\n s: string;\r\n rc: TRect;\r\n pt: TPoint;\r\n ScrollHint: THintWindow;\r\n ButtonH: Integer;\r\n ScrollInfo: TScrollInfo;\r\nbegin\r\n Msg.Result := 0;\r\n case Msg.ScrollCode of\r\n // Scrolls to start / end of the text\r\n SB_TOP: TopLine := 1;\r\n SB_BOTTOM: TopLine := DisplayLineCount;\r\n // Scrolls one line up / down\r\n SB_LINEDOWN: TopLine := TopLine + 1;\r\n SB_LINEUP: TopLine := TopLine - 1;\r\n // Scrolls one page of lines up / down\r\n SB_PAGEDOWN: TopLine := TopLine\r\n + (fLinesInWindow - Ord(eoScrollByOneLess in fOptions));\r\n SB_PAGEUP: TopLine := TopLine\r\n - (fLinesInWindow - Ord(eoScrollByOneLess in fOptions));\r\n // Scrolls to the current scroll bar position\r\n SB_THUMBPOSITION,\r\n SB_THUMBTRACK:\r\n begin\r\n FIsScrolling := True;\r\n if DisplayLineCount > MAX_SCROLL then\r\n TopLine := MulDiv(LinesInWindow + DisplayLineCount - 1, Msg.Pos,\r\n MAX_SCROLL)\r\n else\r\n TopLine := Msg.Pos;\r\n\r\n if eoShowScrollHint in fOptions then\r\n begin\r\n ScrollHint := GetScrollHint;\r\n ScrollHint.Color := fScrollHintColor;\r\n case FScrollHintFormat of\r\n shfTopLineOnly:\r\n s := Format(SYNS_ScrollInfoFmtTop, [RowToLine(TopLine)]);\r\n else\r\n s := Format(SYNS_ScrollInfoFmt, [RowToLine(TopLine),\r\n RowToLine(TopLine + Min(LinesInWindow, DisplayLineCount-TopLine))]);\r\n end;\r\n\r\n{$IFDEF SYN_COMPILER_3_UP}\r\n rc := ScrollHint.CalcHintRect(200, s, nil);\r\n{$ELSE}\r\n rc := Rect(0, 0, TextWidth(ScrollHint.Canvas, s) + 6,\r\n TextHeight(ScrollHint.Canvas, s) + 4);\r\n{$ENDIF}\r\n if eoScrollHintFollows in fOptions then\r\n begin\r\n ButtonH := GetSystemMetrics(SM_CYVSCROLL);\r\n\r\n FillChar(ScrollInfo, SizeOf(ScrollInfo), 0);\r\n ScrollInfo.cbSize := SizeOf(ScrollInfo);\r\n ScrollInfo.fMask := SIF_ALL;\r\n GetScrollInfo(Handle, SB_VERT, ScrollInfo);\r\n\r\n pt := ClientToScreen(Point(ClientWidth - rc.Right - 4,\r\n ((rc.Bottom - rc.Top) shr 1) + //half the size of the hint window\r\n Round((ScrollInfo.nTrackPos / ScrollInfo.nMax) * //The percentage of the page that has been scrolled\r\n (ClientHeight - (ButtonH * 2))) //The height minus the arrow buttons\r\n + ButtonH)); //The height of the top button\r\n end\r\n else\r\n pt := ClientToScreen(Point(ClientWidth - rc.Right - 4, 10));\r\n\r\n OffsetRect(rc, pt.x, pt.y);\r\n ScrollHint.ActivateHint(rc, s);\r\n{$IFDEF SYN_COMPILER_3}\r\n SendMessage(ScrollHint.Handle, WM_NCPAINT, 1, 0);\r\n{$ENDIF}\r\n{$IFNDEF SYN_COMPILER_3_UP}\r\n ScrollHint.Invalidate;\r\n{$ENDIF}\r\n ScrollHint.Update;\r\n end;\r\n end;\r\n // Ends scrolling\r\n SB_ENDSCROLL:\r\n begin\r\n FIsScrolling := False;\r\n if eoShowScrollHint in fOptions then\r\n ShowWindow(GetScrollHint.Handle, SW_HIDE);\r\n end;\r\n end;\r\n Update;\r\n if Assigned(OnScroll) then OnScroll(Self,sbVertical);\r\nend;\r\n{$ENDIF}\r\n\r\nfunction TCustomSynEdit.ScanFrom(Index: Integer): Integer;\r\nvar\r\n iRange: TSynEditRange;\r\nbegin\r\n Result := Index;\r\n if Result >= Lines.Count then Exit;\r\n\r\n if Result = 0 then\r\n fHighlighter.ResetRange\r\n else\r\n fHighlighter.SetRange(TSynEditStringList(Lines).Ranges[Result - 1]);\r\n\r\n repeat\r\n fHighlighter.SetLine(Lines[Result], Result);\r\n fHighlighter.NextToEol;\r\n iRange := fHighlighter.GetRange;\r\n if TSynEditStringList(Lines).Ranges[Result] = iRange then\r\n Exit; // avoid the final Decrement\r\n TSynEditStringList(Lines).Ranges[Result] := iRange;\r\n Inc(Result);\r\n until (Result = Lines.Count);\r\n Dec(Result);\r\nend;\r\n\r\nprocedure TCustomSynEdit.ListCleared(Sender: TObject);\r\nbegin\r\n if WordWrap then\r\n fWordWrapPlugin.Reset;\r\n\r\n ClearUndo;\r\n // invalidate the *whole* client area\r\n FillChar(fInvalidateRect, SizeOf(TRect), 0);\r\n Invalidate;\r\n // set caret and selected block to start of text\r\n CaretXY := BufferCoord(1, 1);\r\n // scroll to start of text\r\n TopLine := 1;\r\n LeftChar := 1;\r\n Include(fStatusChanges, scAll);\r\nend;\r\n\r\nprocedure TCustomSynEdit.ListDeleted(Sender: TObject; aIndex: Integer;\r\n aCount: Integer);\r\nbegin\r\n if Assigned(fHighlighter) and (Lines.Count > 0) then\r\n ScanFrom(aIndex);\r\n\r\n if WordWrap then\r\n fWordWrapPlugin.LinesDeleted(aIndex, aCount);\r\n\r\n InvalidateLines(aIndex + 1, MaxInt);\r\n InvalidateGutterLines(aIndex + 1, MaxInt);\r\nend;\r\n\r\nprocedure TCustomSynEdit.ListInserted(Sender: TObject; Index: Integer;\r\n aCount: Integer);\r\nvar\r\n L: Integer;\r\n vLastScan: Integer;\r\nbegin\r\n if Assigned(fHighlighter) and (Lines.Count > 0) then\r\n begin\r\n vLastScan := Index;\r\n repeat\r\n vLastScan := ScanFrom(vLastScan);\r\n Inc(vLastScan);\r\n until vLastScan >= Index + aCount;\r\n end;\r\n\r\n if WordWrap then\r\n fWordWrapPlugin.LinesInserted(Index, aCount);\r\n\r\n InvalidateLines(Index + 1, MaxInt);\r\n InvalidateGutterLines(Index + 1, MaxInt);\r\n\r\n if (eoAutoSizeMaxScrollWidth in fOptions) then\r\n begin\r\n L := TSynEditStringList(Lines).ExpandedStringLengths[Index];\r\n if L > MaxScrollWidth then\r\n MaxScrollWidth := L;\r\n end;\r\nend;\r\n\r\nprocedure TCustomSynEdit.ListPutted(Sender: TObject; Index: Integer;\r\n aCount: Integer);\r\nvar\r\n L: Integer;\r\n vEndLine: Integer;\r\nbegin\r\n vEndLine := Index +1;\r\n if WordWrap then\r\n begin\r\n if fWordWrapPlugin.LinesPutted(Index, aCount) <> 0 then\r\n vEndLine := MaxInt;\r\n InvalidateGutterLines(Index + 1, vEndLine);\r\n end;\r\n if Assigned(fHighlighter) then\r\n begin\r\n vEndLine := Max(vEndLine, ScanFrom(Index) + 1);\r\n // If this editor is chained then the real owner of text buffer will probably\r\n // have already parsed the changes, so ScanFrom will return immediately.\r\n if fLines <> fOrigLines then\r\n vEndLine := MaxInt;\r\n end;\r\n InvalidateLines(Index + 1, vEndLine);\r\n\r\n if (eoAutoSizeMaxScrollWidth in fOptions) then\r\n begin\r\n L := TSynEditStringList(Lines).ExpandedStringLengths[Index];\r\n if L > MaxScrollWidth then\r\n MaxScrollWidth := L;\r\n end;\r\nend;\r\n\r\nprocedure TCustomSynEdit.ScanRanges;\r\nvar\r\n i: Integer;\r\nbegin\r\n if Assigned(fHighlighter) and (Lines.Count > 0) then begin\r\n fHighlighter.ResetRange;\r\n i := 0;\r\n repeat\r\n fHighlighter.SetLine(Lines[i], i);\r\n fHighlighter.NextToEol;\r\n TSynEditStringList(Lines).Ranges[i] := fHighlighter.GetRange;\r\n Inc(i);\r\n until i >= Lines.Count;\r\n end;\r\nend;\r\n\r\nprocedure TCustomSynEdit.SetWordBlock(Value: TBufferCoord);\r\nvar\r\n vBlockBegin: TBufferCoord;\r\n vBlockEnd: TBufferCoord;\r\n TempString: UnicodeString;\r\n\r\n procedure CharScan;\r\n var\r\n cRun: Integer;\r\n begin\r\n { search BlockEnd }\r\n vBlockEnd.Char := Length(TempString);\r\n for cRun := Value.Char to Length(TempString) do\r\n if not IsIdentChar(TempString[cRun]) then\r\n begin\r\n vBlockEnd.Char := cRun;\r\n Break;\r\n end;\r\n { search BlockBegin }\r\n vBlockBegin.Char := 1;\r\n for cRun := Value.Char - 1 downto 1 do\r\n if not IsIdentChar(TempString[cRun]) then\r\n begin\r\n vBlockBegin.Char := cRun + 1;\r\n Break;\r\n end;\r\n end;\r\n\r\nbegin\r\n if (eoScrollPastEol in Options) and not WordWrap then\r\n Value.Char := MinMax(Value.Char, 1, fMaxScrollWidth + 1)\r\n else\r\n Value.Char := Max(Value.Char, 1);\r\n Value.Line := MinMax(Value.Line, 1, Lines.Count);\r\n TempString := Lines[Value.Line - 1] + #0; //needed for CaretX = LineLength + 1\r\n if Value.Char > Length(TempString) then\r\n begin\r\n InternalCaretXY := BufferCoord(Length(TempString), Value.Line);\r\n exit;\r\n end;\r\n\r\n CharScan;\r\n\r\n vBlockBegin.Line := Value.Line;\r\n vBlockEnd.Line := Value.Line;\r\n SetCaretAndSelection(vBlockEnd, vBlockBegin, vBlockEnd);\r\n InvalidateLine(Value.Line);\r\n StatusChanged([scSelection]);\r\nend;\r\n\r\nprocedure TCustomSynEdit.DblClick;\r\nvar\r\n ptMouse: TPoint;\r\nbegin\r\n GetCursorPos(ptMouse);\r\n ptMouse := ScreenToClient(ptMouse);\r\n if ptMouse.X >= fGutterWidth + 2 then\r\n begin\r\n if not (eoNoSelection in fOptions) then\r\n SetWordBlock(CaretXY);\r\n inherited;\r\n Include(fStateFlags, sfDblClicked);\r\n MouseCapture := False;\r\n end\r\n else\r\n inherited;\r\nend;\r\n\r\nfunction TCustomSynEdit.GetCanUndo: Boolean;\r\nbegin\r\n result := not ReadOnly and fUndoList.CanUndo;\r\nend;\r\n\r\nfunction TCustomSynEdit.GetCanRedo: Boolean;\r\nbegin\r\n result := not ReadOnly and fRedoList.CanUndo;\r\nend;\r\n\r\nfunction TCustomSynEdit.GetCanPaste;\r\nbegin\r\n Result := not ReadOnly and ClipboardProvidesText;\r\nend;\r\n\r\nprocedure TCustomSynEdit.InsertBlock(const BB, BE: TBufferCoord; ChangeStr: PWideChar;\r\n AddToUndoList: Boolean);\r\n// used by BlockIndent and Redo\r\nbegin\r\n SetCaretAndSelection(BB, BB, BE);\r\n ActiveSelectionMode := smColumn;\r\n SetSelTextPrimitiveEx(smColumn, ChangeStr, AddToUndoList);\r\n StatusChanged([scSelection]);\r\nend;\r\n\r\nprocedure TCustomSynEdit.Redo;\r\n\r\n procedure RemoveGroupBreak;\r\n var\r\n Item: TSynEditUndoItem;\r\n OldBlockNumber: Integer;\r\n begin\r\n if fRedoList.LastChangeReason = crGroupBreak then\r\n begin\r\n OldBlockNumber := UndoList.BlockChangeNumber;\r\n Item := fRedoList.PopItem;\r\n try\r\n UndoList.BlockChangeNumber := Item.ChangeNumber;\r\n fUndoList.AddGroupBreak;\r\n finally\r\n UndoList.BlockChangeNumber := OldBlockNumber;\r\n Item.Free;\r\n end;\r\n UpdateModifiedStatus;\r\n end;\r\n end;\r\n\r\nvar\r\n Item: TSynEditUndoItem;\r\n OldChangeNumber: integer;\r\n SaveChangeNumber: integer;\r\n FLastChange : TSynChangeReason;\r\n FAutoComplete: Boolean;\r\n FPasteAction: Boolean;\r\n FSpecial1: Boolean;\r\n FSpecial2: Boolean;\r\n FKeepGoing: Boolean;\r\nbegin\r\n if ReadOnly then\r\n exit;\r\n\r\n FLastChange := FRedoList.LastChangeReason;\r\n FAutoComplete := FLastChange = crAutoCompleteBegin;\r\n FPasteAction := FLastChange = crPasteBegin;\r\n FSpecial1 := FLastChange = crSpecial1Begin;\r\n FSpecial2 := FLastChange = crSpecial2Begin;\r\n\r\n Item := fRedoList.PeekItem;\r\n if Item <> nil then\r\n begin\r\n OldChangeNumber := Item.ChangeNumber;\r\n SaveChangeNumber := fUndoList.BlockChangeNumber;\r\n fUndoList.BlockChangeNumber := Item.ChangeNumber;\r\n try\r\n repeat\r\n RedoItem;\r\n Item := fRedoList.PeekItem;\r\n if Item = nil then\r\n FKeepGoing := False\r\n else begin\r\n if FAutoComplete then\r\n FKeepGoing:= (FRedoList.LastChangeReason <> crAutoCompleteEnd)\r\n else if FPasteAction then\r\n FKeepGoing:= (FRedoList.LastChangeReason <> crPasteEnd)\r\n else if FSpecial1 then\r\n FKeepGoing := (FRedoList.LastChangeReason <> crSpecial1End)\r\n else if FSpecial2 then\r\n FKeepGoing := (FRedoList.LastChangeReason <> crSpecial2End)\r\n else if Item.ChangeNumber = OldChangeNumber then\r\n FKeepGoing := True\r\n else begin\r\n FKeepGoing := ((eoGroupUndo in FOptions) and\r\n (FLastChange = Item.ChangeReason) and\r\n not(FLastChange in [crIndent, crUnindent]));\r\n end;\r\n FLastChange := Item.ChangeReason;\r\n end;\r\n until not(FKeepGoing);\r\n\r\n //we need to eat the last command since it does nothing and also update modified status...\r\n if (FAutoComplete and (FRedoList.LastChangeReason = crAutoCompleteEnd)) or\r\n (FPasteAction and (FRedoList.LastChangeReason = crPasteEnd)) or\r\n (FSpecial1 and (FRedoList.LastChangeReason = crSpecial1End)) or\r\n (FSpecial2 and (FRedoList.LastChangeReason = crSpecial2End)) then\r\n begin\r\n RedoItem;\r\n UpdateModifiedStatus;\r\n end;\r\n\r\n finally\r\n fUndoList.BlockChangeNumber := SaveChangeNumber;\r\n end;\r\n RemoveGroupBreak;\r\n end;\r\nend;\r\n\r\nprocedure TCustomSynEdit.RedoItem;\r\nvar\r\n Item: TSynEditUndoItem;\r\n Run, StrToDelete: PWideChar;\r\n Len: Integer;\r\n TempString: UnicodeString;\r\n CaretPt: TBufferCoord;\r\n ChangeScrollPastEol: boolean;\r\n BeginX: integer;\r\nbegin\r\n ChangeScrollPastEol := not (eoScrollPastEol in Options);\r\n Item := fRedoList.PopItem;\r\n if Assigned(Item) then\r\n try\r\n ActiveSelectionMode := Item.ChangeSelMode;\r\n IncPaintLock;\r\n Include(fOptions, eoScrollPastEol);\r\n fUndoList.InsideRedo := True;\r\n case Item.ChangeReason of\r\n crCaret:\r\n begin\r\n fUndoList.AddChange(Item.ChangeReason, CaretXY, CaretXY, '', fActiveSelectionMode);\r\n InternalCaretXY := Item.ChangeStartPos;\r\n end;\r\n crSelection:\r\n begin\r\n fUndoList.AddChange(Item.ChangeReason, BlockBegin, BlockEnd, '', fActiveSelectionMode);\r\n SetCaretAndSelection(CaretXY, Item.ChangeStartPos, Item.ChangeEndPos);\r\n end;\r\n crInsert, crPaste, crDragDropInsert:\r\n begin\r\n SetCaretAndSelection(Item.ChangeStartPos, Item.ChangeStartPos,\r\n Item.ChangeStartPos);\r\n SetSelTextPrimitiveEx(Item.ChangeSelMode, PWideChar(Item.ChangeStr),\r\n False);\r\n InternalCaretXY := Item.ChangeEndPos;\r\n fUndoList.AddChange(Item.ChangeReason, Item.ChangeStartPos,\r\n Item.ChangeEndPos, SelText, Item.ChangeSelMode);\r\n if Item.ChangeReason = crDragDropInsert then begin\r\n SetCaretAndSelection(Item.ChangeStartPos, Item.ChangeStartPos,\r\n Item.ChangeEndPos);\r\n end;\r\n end;\r\n crDeleteAfterCursor, crSilentDeleteAfterCursor:\r\n begin\r\n SetCaretAndSelection(Item.ChangeStartPos, Item.ChangeStartPos,\r\n Item.ChangeEndPos);\r\n TempString := SelText;\r\n SetSelTextPrimitiveEx(Item.ChangeSelMode, PWideChar(Item.ChangeStr),\r\n False);\r\n fUndoList.AddChange(Item.ChangeReason, Item.ChangeStartPos,\r\n Item.ChangeEndPos, TempString, Item.ChangeSelMode);\r\n InternalCaretXY := Item.ChangeEndPos;\r\n end;\r\n crDelete, crSilentDelete:\r\n begin\r\n SetCaretAndSelection(Item.ChangeStartPos, Item.ChangeStartPos,\r\n Item.ChangeEndPos);\r\n TempString := SelText;\r\n SetSelTextPrimitiveEx(Item.ChangeSelMode, PWideChar(Item.ChangeStr),\r\n False);\r\n fUndoList.AddChange(Item.ChangeReason, Item.ChangeStartPos,\r\n Item.ChangeEndPos, TempString, Item.ChangeSelMode);\r\n InternalCaretXY := Item.ChangeStartPos;\r\n end;\r\n crLineBreak:\r\n begin\r\n CaretPt := Item.ChangeStartPos;\r\n SetCaretAndSelection(CaretPt, CaretPt, CaretPt);\r\n CommandProcessor(ecLineBreak, #13, nil);\r\n end;\r\n crIndent:\r\n begin\r\n SetCaretAndSelection(Item.ChangeEndPos, Item.ChangeStartPos,\r\n Item.ChangeEndPos);\r\n fUndoList.AddChange(Item.ChangeReason, Item.ChangeStartPos,\r\n Item.ChangeEndPos, Item.ChangeStr, Item.ChangeSelMode);\r\n end;\r\n crUnindent :\r\n begin // re-delete the (raggered) column\r\n // Delete string\r\n StrToDelete := PWideChar(Item.ChangeStr);\r\n InternalCaretY := Item.ChangeStartPos.Line;\r\n if Item.ChangeSelMode = smColumn then\r\n BeginX := Min(Item.ChangeStartPos.Char, Item.ChangeEndPos.Char)\r\n else\r\n BeginX := 1;\r\n repeat\r\n Run := GetEOL(StrToDelete);\r\n if Run <> StrToDelete then\r\n begin\r\n Len := Run - StrToDelete;\r\n if Len > 0 then\r\n begin\r\n TempString := Lines[CaretY - 1];\r\n Delete(TempString, BeginX, Len);\r\n Lines[CaretY - 1] := TempString;\r\n end;\r\n end\r\n else\r\n Len := 0;\r\n if Run^ = #13 then\r\n begin\r\n Inc(Run);\r\n if Run^ = #10 then\r\n Inc(Run);\r\n Inc(fCaretY);\r\n end;\r\n StrToDelete := Run;\r\n until Run^ = #0;\r\n if Item.ChangeSelMode = smColumn then\r\n SetCaretAndSelection(Item.ChangeStartPos, Item.ChangeStartPos,\r\n Item.ChangeEndPos)\r\n else begin\r\n // restore selection\r\n CaretPt.Char := Item.ChangeStartPos.Char - fTabWidth;\r\n CaretPt.Line := Item.ChangeStartPos.Line;\r\n SetCaretAndSelection( CaretPt, CaretPt,\r\n BufferCoord(Item.ChangeEndPos.Char - Len, Item.ChangeEndPos.Line) );\r\n end;\r\n // add to undo list\r\n fUndoList.AddChange(Item.ChangeReason, Item.ChangeStartPos,\r\n Item.ChangeEndPos, Item.ChangeStr, Item.ChangeSelMode);\r\n end;\r\n crWhiteSpaceAdd:\r\n begin\r\n fUndoList.AddChange(Item.ChangeReason, Item.ChangeStartPos,\r\n Item.ChangeEndPos, '', Item.ChangeSelMode);\r\n SetCaretAndSelection(Item.ChangeEndPos, Item.ChangeEndPos,\r\n Item.ChangeEndPos);\r\n SetSelTextPrimitiveEx(Item.ChangeSelMode, PWideChar(Item.ChangeStr), True);\r\n InternalCaretXY := Item.ChangeStartPos;\r\n end;\r\n end;\r\n finally\r\n fUndoList.InsideRedo := False;\r\n if ChangeScrollPastEol then\r\n Exclude(fOptions, eoScrollPastEol);\r\n Item.Free;\r\n DecPaintLock;\r\n end;\r\nend;\r\n\r\nprocedure TCustomSynEdit.Undo;\r\n\r\n procedure RemoveGroupBreak;\r\n var\r\n Item: TSynEditUndoItem;\r\n OldBlockNumber: Integer;\r\n begin\r\n if fUndoList.LastChangeReason = crGroupBreak then\r\n begin\r\n OldBlockNumber := RedoList.BlockChangeNumber;\r\n try\r\n Item := fUndoList.PopItem;\r\n RedoList.BlockChangeNumber := Item.ChangeNumber;\r\n Item.Free;\r\n fRedoList.AddGroupBreak;\r\n finally\r\n RedoList.BlockChangeNumber := OldBlockNumber;\r\n end;\r\n end;\r\n end;\r\n\r\nvar\r\n Item: TSynEditUndoItem;\r\n OldChangeNumber: integer;\r\n SaveChangeNumber: integer;\r\n FLastChange : TSynChangeReason;\r\n FAutoComplete: Boolean;\r\n FPasteAction: Boolean;\r\n FSpecial1: Boolean;\r\n FSpecial2: Boolean;\r\n FKeepGoing: Boolean;\r\nbegin\r\n if ReadOnly then\r\n exit;\r\n\r\n RemoveGroupBreak;\r\n\r\n FLastChange := FUndoList.LastChangeReason;\r\n FAutoComplete := FLastChange = crAutoCompleteEnd;\r\n FPasteAction := FLastChange = crPasteEnd;\r\n FSpecial1 := FLastChange = crSpecial1End;\r\n FSpecial2 := FLastChange = crSpecial2End;\r\n\r\n Item := fUndoList.PeekItem;\r\n if Item <> nil then\r\n begin\r\n OldChangeNumber := Item.ChangeNumber;\r\n SaveChangeNumber := fRedoList.BlockChangeNumber;\r\n fRedoList.BlockChangeNumber := Item.ChangeNumber;\r\n\r\n try\r\n repeat\r\n UndoItem;\r\n Item := fUndoList.PeekItem;\r\n if Item = nil then\r\n FKeepGoing := False\r\n else begin\r\n if FAutoComplete then\r\n FKeepGoing := (FUndoList.LastChangeReason <> crAutoCompleteBegin)\r\n else if FPasteAction then\r\n FKeepGoing := (FUndoList.LastChangeReason <> crPasteBegin)\r\n else if FSpecial1 then\r\n FKeepGoing := (FUndoList.LastChangeReason <> crSpecial1Begin)\r\n else if FSpecial2 then\r\n FKeepGoing := (FUndoList.LastChangeReason <> crSpecial2Begin)\r\n else if Item.ChangeNumber = OldChangeNumber then\r\n FKeepGoing := True\r\n else begin\r\n FKeepGoing := ((eoGroupUndo in FOptions) and\r\n (FLastChange = Item.ChangeReason) and\r\n not(FLastChange in [crIndent, crUnindent]));\r\n end;\r\n FLastChange := Item.ChangeReason;\r\n end;\r\n until not(FKeepGoing);\r\n\r\n //we need to eat the last command since it does nothing and also update modified status...\r\n if (FAutoComplete and (FUndoList.LastChangeReason = crAutoCompleteBegin)) or\r\n (FPasteAction and (FUndoList.LastChangeReason = crPasteBegin)) or\r\n (FSpecial1 and (FUndoList.LastChangeReason = crSpecial1Begin)) or\r\n (FSpecial2 and (FUndoList.LastChangeReason = crSpecial2Begin)) then\r\n begin\r\n UndoItem;\r\n UpdateModifiedStatus;\r\n end;\r\n\r\n finally\r\n fRedoList.BlockChangeNumber := SaveChangeNumber;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TCustomSynEdit.UndoItem;\r\nvar\r\n Item: TSynEditUndoItem;\r\n TmpPos: TBufferCoord;\r\n TmpStr: UnicodeString;\r\n ChangeScrollPastEol: Boolean;\r\n BeginX: Integer;\r\nbegin\r\n ChangeScrollPastEol := not (eoScrollPastEol in Options);\r\n Item := fUndoList.PopItem;\r\n if Assigned(Item) then\r\n try\r\n ActiveSelectionMode := Item.ChangeSelMode;\r\n IncPaintLock;\r\n Include(fOptions, eoScrollPastEol);\r\n case Item.ChangeReason of\r\n crCaret:\r\n begin\r\n fRedoList.AddChange(Item.ChangeReason, CaretXY, CaretXY, '', fActiveSelectionMode);\r\n InternalCaretXY := Item.ChangeStartPos;\r\n end;\r\n crSelection:\r\n begin\r\n fRedoList.AddChange(Item.ChangeReason, BlockBegin, BlockEnd, '', fActiveSelectionMode);\r\n SetCaretAndSelection(CaretXY, Item.ChangeStartPos, Item.ChangeEndPos);\r\n end;\r\n crInsert, crPaste, crDragDropInsert:\r\n begin\r\n SetCaretAndSelection(Item.ChangeStartPos, Item.ChangeStartPos,\r\n Item.ChangeEndPos);\r\n TmpStr := SelText;\r\n SetSelTextPrimitiveEx(Item.ChangeSelMode, PWideChar(Item.ChangeStr),\r\n False);\r\n fRedoList.AddChange(Item.ChangeReason, Item.ChangeStartPos,\r\n Item.ChangeEndPos, TmpStr, Item.ChangeSelMode);\r\n InternalCaretXY := Item.ChangeStartPos;\r\n end;\r\n crDeleteAfterCursor, crDelete,\r\n crSilentDelete, crSilentDeleteAfterCursor,\r\n crDeleteAll:\r\n begin\r\n // If there's no selection, we have to set\r\n // the Caret's position manualy.\r\n if Item.ChangeSelMode = smColumn then\r\n TmpPos := BufferCoord(\r\n Min(Item.ChangeStartPos.Char, Item.ChangeEndPos.Char),\r\n Min(Item.ChangeStartPos.Line, Item.ChangeEndPos.Line))\r\n else\r\n TmpPos := TBufferCoord(MinPoint(\r\n TPoint(Item.ChangeStartPos), TPoint(Item.ChangeEndPos)));\r\n if (Item.ChangeReason in [crDeleteAfterCursor,\r\n crSilentDeleteAfterCursor]) and (TmpPos.Line > Lines.Count) then\r\n begin\r\n InternalCaretXY := BufferCoord(1, Lines.Count);\r\n fLines.Add('');\r\n end;\r\n CaretXY := TmpPos;\r\n SetSelTextPrimitiveEx(Item.ChangeSelMode, PWideChar(Item.ChangeStr),\r\n False );\r\n if Item.ChangeReason in [crDeleteAfterCursor,\r\n crSilentDeleteAfterCursor]\r\n then\r\n TmpPos := Item.ChangeStartPos\r\n else\r\n TmpPos := Item.ChangeEndPos;\r\n if Item.ChangeReason in [crSilentDelete, crSilentDeleteAfterCursor]\r\n then\r\n InternalCaretXY := TmpPos\r\n else begin\r\n SetCaretAndSelection(TmpPos, Item.ChangeStartPos,\r\n Item.ChangeEndPos);\r\n end;\r\n fRedoList.AddChange(Item.ChangeReason, Item.ChangeStartPos,\r\n Item.ChangeEndPos, '', Item.ChangeSelMode);\r\n if Item.ChangeReason = crDeleteAll then begin\r\n InternalCaretXY := BufferCoord(1, 1);\r\n fBlockEnd := BufferCoord(1, 1);\r\n end;\r\n EnsureCursorPosVisible;\r\n end;\r\n crLineBreak:\r\n begin\r\n // If there's no selection, we have to set\r\n // the Caret's position manualy.\r\n InternalCaretXY := Item.ChangeStartPos;\r\n if CaretY > 0 then\r\n begin\r\n TmpStr := Lines.Strings[CaretY - 1];\r\n if (Length(TmpStr) < CaretX - 1)\r\n and (LeftSpaces(Item.ChangeStr) = 0)\r\n then\r\n TmpStr := TmpStr + UnicodeStringOfChar(#32, CaretX - 1 - Length(TmpStr));\r\n ProperSetLine(CaretY - 1, TmpStr + Item.ChangeStr);\r\n Lines.Delete(Item.ChangeEndPos.Line);\r\n end\r\n else\r\n ProperSetLine(CaretY - 1, Item.ChangeStr);\r\n DoLinesDeleted(CaretY + 1, 1);\r\n fRedoList.AddChange(Item.ChangeReason, Item.ChangeStartPos,\r\n Item.ChangeEndPos, '', Item.ChangeSelMode);\r\n end;\r\n crIndent:\r\n begin\r\n SetCaretAndSelection(Item.ChangeEndPos, Item.ChangeStartPos,\r\n Item.ChangeEndPos);\r\n fRedoList.AddChange(Item.ChangeReason, Item.ChangeStartPos,\r\n Item.ChangeEndPos, Item.ChangeStr, Item.ChangeSelMode);\r\n end;\r\n crUnindent: // reinsert the (raggered) column that was deleted\r\n begin\r\n // reinsert the string\r\n if Item.ChangeSelMode <> smColumn then\r\n InsertBlock(BufferCoord(1, Item.ChangeStartPos.Line),\r\n BufferCoord(1, Item.ChangeEndPos.Line),\r\n PWideChar(Item.ChangeStr), False)\r\n else\r\n begin\r\n BeginX := Min( Item.ChangeStartPos.Char, Item.ChangeEndPos.Char );\r\n InsertBlock(BufferCoord(BeginX, Item.ChangeStartPos.Line),\r\n BufferCoord(BeginX, Item.ChangeEndPos.Line),\r\n PWideChar(Item.ChangeStr), False);\r\n end;\r\n SetCaretAndSelection(Item.ChangeStartPos, Item.ChangeStartPos,\r\n Item.ChangeEndPos);\r\n fRedoList.AddChange(Item.ChangeReason, Item.ChangeStartPos,\r\n Item.ChangeEndPos, Item.ChangeStr, Item.ChangeSelMode);\r\n end;\r\n crWhiteSpaceAdd:\r\n begin\r\n SetCaretAndSelection(Item.ChangeStartPos, Item.ChangeStartPos,\r\n Item.ChangeEndPos);\r\n TmpStr := SelText;\r\n SetSelTextPrimitiveEx(Item.ChangeSelMode, PWideChar(Item.ChangeStr), True);\r\n fRedoList.AddChange(Item.ChangeReason, Item.ChangeStartPos,\r\n Item.ChangeEndPos, TmpStr, Item.ChangeSelMode);\r\n InternalCaretXY := Item.ChangeStartPos;\r\n end;\r\n end;\r\n finally\r\n if ChangeScrollPastEol then\r\n Exclude(fOptions, eoScrollPastEol);\r\n Item.Free;\r\n DecPaintLock;\r\n end;\r\nend;\r\n\r\nprocedure TCustomSynEdit.ClearBookMark(BookMark: Integer);\r\nbegin\r\n if (BookMark in [0..9]) and assigned(fBookMarks[BookMark]) then\r\n begin\r\n DoOnClearBookmark(fBookMarks[BookMark]);\r\n FMarkList.Remove(fBookMarks[Bookmark]);\r\n fBookMarks[BookMark] := nil;\r\n end\r\nend;\r\n\r\nprocedure TCustomSynEdit.GotoBookMark(BookMark: Integer);\r\nvar\r\n iNewPos: TBufferCoord;\r\nbegin\r\n if (BookMark in [0..9]) and\r\n assigned(fBookMarks[BookMark]) and\r\n (fBookMarks[BookMark].Line <= fLines.Count)\r\n then\r\n begin\r\n iNewPos.Char := fBookMarks[BookMark].Char;\r\n iNewPos.Line := fBookMarks[BookMark].Line;\r\n //call it this way instead to make sure that the caret ends up in the middle\r\n //if it is off screen (like Delphi does with bookmarks)\r\n SetCaretXYEx(False, iNewPos);\r\n EnsureCursorPosVisibleEx(True);\r\n if SelAvail then\r\n InvalidateSelection;\r\n fBlockBegin.Char := fCaretX;\r\n fBlockBegin.Line := fCaretY;\r\n fBlockEnd := fBlockBegin;\r\n end;\r\nend;\r\n\r\nprocedure TCustomSynEdit.GotoLineAndCenter(ALine: Integer);\r\nbegin\r\n SetCaretXYEx( False, BufferCoord(1, ALine) );\r\n if SelAvail then\r\n InvalidateSelection;\r\n fBlockBegin.Char := fCaretX;\r\n fBlockBegin.Line := fCaretY;\r\n fBlockEnd := fBlockBegin;\r\n EnsureCursorPosVisibleEx(True);\r\nend;\r\n\r\nprocedure TCustomSynEdit.SetBookMark(BookMark: Integer; X: Integer; Y: Integer);\r\nvar\r\n mark: TSynEditMark;\r\nbegin\r\n if (BookMark in [0..9]) and (Y >= 1) and (Y <= Max(1, fLines.Count)) then\r\n begin\r\n mark := TSynEditMark.Create(self);\r\n with mark do\r\n begin\r\n Line := Y;\r\n Char := X;\r\n ImageIndex := Bookmark;\r\n BookmarkNumber := Bookmark;\r\n Visible := True;\r\n InternalImage := (fBookMarkOpt.BookmarkImages = nil);\r\n end;\r\n DoOnPlaceMark(Mark);\r\n if (mark <> nil) then\r\n begin\r\n if assigned(fBookMarks[BookMark]) then\r\n ClearBookmark(BookMark);\r\n fBookMarks[BookMark] := mark;\r\n FMarkList.Add(fBookMarks[BookMark]);\r\n end;\r\n end;\r\nend;\r\n\r\n{$IFNDEF SYN_CLX}\r\nfunction IsTextMessage(Msg: UINT): Boolean;\r\nbegin\r\n Result := (Msg = WM_SETTEXT) or (Msg = WM_GETTEXT) or (Msg = WM_GETTEXTLENGTH);\r\nend;\r\n\r\nprocedure TCustomSynEdit.WndProc(var Msg: TMessage);\r\nconst\r\n ALT_KEY_DOWN = $20000000;\r\nbegin\r\n // Prevent Alt-Backspace from beeping\r\n if (Msg.Msg = WM_SYSCHAR) and (Msg.wParam = VK_BACK) and\r\n (Msg.lParam and ALT_KEY_DOWN <> 0)\r\n then\r\n Msg.Msg := 0;\r\n\r\n // handle direct WndProc calls that could happen through VCL-methods like Perform\r\n if HandleAllocated and IsWindowUnicode(Handle) then\r\n if not FWindowProducedMessage then\r\n begin\r\n FWindowProducedMessage := True;\r\n if IsTextMessage(Msg.Msg) then\r\n begin\r\n with Msg do\r\n Result := SendMessageA(Handle, Msg, wParam, lParam);\r\n Exit;\r\n end;\r\n end\r\n else\r\n FWindowProducedMessage := False;\r\n\r\n inherited;\r\nend;\r\n{$ENDIF}\r\n\r\nprocedure TCustomSynEdit.ChainListCleared(Sender: TObject);\r\nbegin\r\n if Assigned(fChainListCleared) then\r\n fChainListCleared(Sender);\r\n TSynEditStringList(fOrigLines).OnCleared(Sender);\r\nend;\r\n\r\nprocedure TCustomSynEdit.ChainListDeleted(Sender: TObject; aIndex: Integer;\r\n aCount: Integer);\r\nbegin\r\n if Assigned(fChainListDeleted) then\r\n fChainListDeleted(Sender, aIndex, aCount);\r\n TSynEditStringList(fOrigLines).OnDeleted(Sender, aIndex, aCount);\r\nend;\r\n\r\nprocedure TCustomSynEdit.ChainListInserted(Sender: TObject; aIndex: Integer;\r\n aCount: Integer);\r\nbegin\r\n if Assigned(fChainListInserted) then\r\n fChainListInserted(Sender, aIndex, aCount);\r\n TSynEditStringList(fOrigLines).OnInserted(Sender, aIndex, aCount);\r\nend;\r\n\r\nprocedure TCustomSynEdit.ChainListPutted(Sender: TObject; aIndex: Integer;\r\n aCount: Integer);\r\nbegin\r\n if Assigned(fChainListPutted) then\r\n fChainListPutted(Sender, aIndex, aCount);\r\n TSynEditStringList(fOrigLines).OnPutted(Sender, aIndex, aCount);\r\nend;\r\n\r\nprocedure TCustomSynEdit.ChainLinesChanging(Sender: TObject);\r\nbegin\r\n if Assigned(fChainLinesChanging) then\r\n fChainLinesChanging(Sender);\r\n TSynEditStringList(fOrigLines).OnChanging(Sender);\r\nend;\r\n\r\nprocedure TCustomSynEdit.ChainLinesChanged(Sender: TObject);\r\nbegin\r\n if Assigned(fChainLinesChanged) then\r\n fChainLinesChanged(Sender);\r\n TSynEditStringList(fOrigLines).OnChange(Sender);\r\nend;\r\n\r\nprocedure TCustomSynEdit.ChainUndoRedoAdded(Sender: TObject);\r\nvar\r\n iList: TSynEditUndoList;\r\n iHandler: TNotifyEvent;\r\nbegin\r\n if Sender = fUndoList then\r\n begin\r\n iList := fOrigUndoList;\r\n iHandler := fChainUndoAdded;\r\n end\r\n else { if Sender = fRedoList then }\r\n begin\r\n iList := fOrigRedoList;\r\n iHandler := fChainRedoAdded;\r\n end;\r\n if Assigned(iHandler) then\r\n iHandler(Sender);\r\n iList.OnAddedUndo(Sender);\r\nend;\r\n\r\nprocedure TCustomSynEdit.UnHookTextBuffer;\r\nvar\r\n vOldWrap: Boolean;\r\nbegin\r\n Assert(fChainedEditor = nil);\r\n if fLines = fOrigLines then\r\n Exit;\r\n\r\n vOldWrap := WordWrap;\r\n WordWrap := False;\r\n\r\n //first put back the real methods\r\n with TSynEditStringList(fLines) do\r\n begin\r\n OnCleared := fChainListCleared;\r\n OnDeleted := fChainListDeleted;\r\n OnInserted := fChainListInserted;\r\n OnPutted := fChainListPutted;\r\n OnChanging := fChainLinesChanging;\r\n OnChange := fChainLinesChanged;\r\n end;\r\n fUndoList.OnAddedUndo := fChainUndoAdded;\r\n fRedoList.OnAddedUndo := fChainRedoAdded;\r\n\r\n fChainListCleared := nil;\r\n fChainListDeleted := nil;\r\n fChainListInserted := nil;\r\n fChainListPutted := nil;\r\n fChainLinesChanging := nil;\r\n fChainLinesChanged := nil;\r\n fChainUndoAdded := nil;\r\n\r\n //make the switch\r\n fLines := fOrigLines;\r\n fUndoList := fOrigUndoList;\r\n fRedoList := fOrigRedoList;\r\n LinesHookChanged;\r\n\r\n WordWrap := vOldWrap;\r\nend;\r\n\r\nprocedure TCustomSynEdit.HookTextBuffer(aBuffer: TSynEditStringList;\r\n aUndo, aRedo: TSynEditUndoList);\r\nvar\r\n vOldWrap: Boolean;\r\nbegin\r\n Assert(fChainedEditor = nil);\r\n Assert(fLines = fOrigLines);\r\n\r\n vOldWrap := WordWrap;\r\n WordWrap := False;\r\n\r\n if fChainedEditor <> nil then\r\n RemoveLinesPointer\r\n else if fLines <> fOrigLines then\r\n UnHookTextBuffer;\r\n\r\n //store the current values and put in the chained methods\r\n fChainListCleared := aBuffer.OnCleared;\r\n aBuffer.OnCleared := ChainListCleared;\r\n fChainListDeleted := aBuffer.OnDeleted;\r\n aBuffer.OnDeleted := ChainListDeleted;\r\n fChainListInserted := aBuffer.OnInserted;\r\n aBuffer.OnInserted := ChainListInserted;\r\n fChainListPutted := aBuffer.OnPutted;\r\n aBuffer.OnPutted := ChainListPutted;\r\n fChainLinesChanging := aBuffer.OnChanging;\r\n aBuffer.OnChanging := ChainLinesChanging;\r\n fChainLinesChanged := aBuffer.OnChange;\r\n aBuffer.OnChange := ChainLinesChanged;\r\n\r\n fChainUndoAdded := aUndo.OnAddedUndo;\r\n aUndo.OnAddedUndo := ChainUndoRedoAdded;\r\n fChainRedoAdded := aRedo.OnAddedUndo;\r\n aRedo.OnAddedUndo := ChainUndoRedoAdded;\r\n\r\n //make the switch\r\n fLines := aBuffer;\r\n fUndoList := aUndo;\r\n fRedoList := aRedo;\r\n LinesHookChanged;\r\n\r\n WordWrap := vOldWrap;\r\nend;\r\n\r\nprocedure TCustomSynEdit.LinesHookChanged;\r\nvar\r\n iLongestLineLength: Integer;\r\nbegin\r\n Invalidate;\r\n if eoAutoSizeMaxScrollWidth in fOptions then\r\n begin\r\n iLongestLineLength := TSynEditStringList(Lines).LengthOfLongestLine;\r\n if iLongestLineLength > MaxScrollWidth then\r\n MaxScrollWidth := iLongestLineLength;\r\n end;\r\n UpdateScrollBars;\r\nend;\r\n\r\nprocedure TCustomSynEdit.SetLinesPointer(ASynEdit: TCustomSynEdit);\r\nbegin\r\n HookTextBuffer(TSynEditStringList(ASynEdit.Lines),\r\n ASynEdit.UndoList, ASynEdit.RedoList);\r\n\r\n fChainedEditor := ASynEdit;\r\n ASynEdit.FreeNotification(Self);\r\nend;\r\n\r\nprocedure TCustomSynEdit.RemoveLinesPointer;\r\nbegin\r\n {$IFDEF SYN_COMPILER_5_UP}\r\n if Assigned(fChainedEditor) then\r\n RemoveFreeNotification(fChainedEditor);\r\n {$ENDIF}\r\n fChainedEditor := nil;\r\n\r\n UnHookTextBuffer;\r\nend;\r\n\r\n{$IFDEF SYN_CLX}\r\nfunction TCustomSynEdit.EventFilter(Sender: QObjectH; Event: QEventH): Boolean;\r\nbegin\r\n Result := inherited EventFilter(Sender, Event);\r\n case QEvent_type(Event) of\r\n QEventType_FocusIn:\r\n begin\r\n {$IFDEF SYN_LINUX}\r\n if not FDeadKeysFixed then\r\n begin\r\n FDeadKeysFixed := True;\r\n with TEdit.Create(Self) do\r\n begin\r\n Parent := Self;\r\n BorderStyle := bsNone;\r\n Color := Self.Color;\r\n ReadOnly := True;\r\n Top := ClientRect.Top;\r\n Left := ClientRect.Left + fGutterWidth + 2;\r\n Show;\r\n SetFocus;\r\n Free;\r\n end;\r\n SetFocus;\r\n end\r\n else\r\n {$ENDIF}\r\n begin\r\n InitializeCaret;\r\n if FHideSelection and SelAvail then\r\n InvalidateSelection;\r\n end;\r\n end;\r\n QEventType_FocusOut:\r\n begin\r\n HideCaret;\r\n kTextDrawer.DestroyCaret;\r\n if FHideSelection and SelAvail then\r\n InvalidateSelection;\r\n EndDrag(False);\r\n end;\r\n end;\r\nend;\r\n{$ENDIF}\r\n\r\nprocedure TCustomSynEdit.DragCanceled;\r\nbegin\r\n fScrollTimer.Enabled := False;\r\n inherited;\r\nend;\r\n\r\nprocedure TCustomSynEdit.DragOver(Source: TObject; X, Y: Integer;\r\n State: TDragState; var Accept: Boolean);\r\nvar\r\n vNewPos: TDisplayCoord;\r\nbegin\r\n inherited;\r\n if (Source is TCustomSynEdit) and not ReadOnly then\r\n begin\r\n Accept := True;\r\n //Ctrl is pressed => change cursor to indicate copy instead of move\r\n{$IFDEF SYN_CLX}\r\n{$ELSE}\r\n if GetKeyState(VK_CONTROL) < 0 then\r\n DragCursor := crMultiDrag\r\n else\r\n DragCursor := crDrag;\r\n{$ENDIF}\r\n if Dragging then //if the drag source is the SynEdit itself\r\n begin\r\n if State = dsDragLeave then //restore prev caret position\r\n ComputeCaret(FMouseDownX, FMouseDownY)\r\n else\r\n begin\r\n vNewPos := PixelsToNearestRowColumn(X, Y);\r\n vNewPos.Column := MinMax(vNewPos.Column, LeftChar, LeftChar + CharsInWindow - 1);\r\n vNewPos.Row := MinMax(vNewPos.Row, TopLine, TopLine + LinesInWindow - 1);\r\n InternalCaretXY := DisplayToBufferPos(vNewPos);\r\n ComputeScroll(X, Y);\r\n end;\r\n end\r\n else //if is dragging from another SynEdit\r\n ComputeCaret(X, Y); //position caret under the mouse cursor\r\n end;\r\nend;\r\n\r\nprocedure TCustomSynEdit.DragDrop(Source: TObject; X, Y: Integer);\r\nvar\r\n vNewCaret: TBufferCoord;\r\n DoDrop, DropAfter, DropMove: Boolean;\r\n vBB, vBE: TBufferCoord;\r\n DragDropText: UnicodeString;\r\n ChangeScrollPastEOL: Boolean;\r\nbegin\r\n if not ReadOnly and (Source is TCustomSynEdit)\r\n and TCustomSynEdit(Source).SelAvail then\r\n begin\r\n IncPaintLock;\r\n try\r\n inherited;\r\n ComputeCaret(X, Y);\r\n vNewCaret := CaretXY;\r\n // if from other control then move when SHIFT, else copy\r\n // if from Self then copy when CTRL, else move\r\n if Source <> Self then\r\n begin\r\n{$IFDEF SYN_CLX}\r\n DropMove := ssShift in Application.KeyState;\r\n{$ELSE}\r\n DropMove := GetKeyState(VK_SHIFT) < 0;\r\n{$ENDIF}\r\n DoDrop := True;\r\n DropAfter := False;\r\n end\r\n else\r\n begin\r\n{$IFDEF SYN_CLX}\r\n DropMove := not(ssCtrl in Application.KeyState);\r\n{$ELSE}\r\n DropMove := GetKeyState(VK_CONTROL) >= 0;\r\n{$ENDIF}\r\n vBB := BlockBegin;\r\n vBE := BlockEnd;\r\n DropAfter := (vNewCaret.Line > vBE.Line)\r\n or ((vNewCaret.Line = vBE.Line) and ((vNewCaret.Char > vBE.Char) or\r\n ((not DropMove) and (vNewCaret.Char = vBE.Char))));\r\n DoDrop := DropAfter or (vNewCaret.Line < vBB.Line)\r\n or ((vNewCaret.Line = vBB.Line) and ((vNewCaret.Char < vBB.Char) or\r\n ((not DropMove) and (vNewCaret.Char = vBB.Char))));\r\n end;\r\n if DoDrop then begin\r\n BeginUndoBlock;\r\n try\r\n DragDropText := TCustomSynEdit(Source).SelText;\r\n // delete the selected text if necessary\r\n if DropMove then\r\n begin\r\n if Source <> Self then\r\n TCustomSynEdit(Source).SelText := ''\r\n else\r\n begin\r\n SelText := '';\r\n // adjust horizontal drop position\r\n if DropAfter and (vNewCaret.Line = vBE.Line) then\r\n Dec(vNewCaret.Char, vBE.Char - vBB.Char);\r\n // adjust vertical drop position\r\n if DropAfter and (vBE.Line > vBB.Line) then\r\n Dec(vNewCaret.Line, vBE.Line - vBB.Line);\r\n end;\r\n end;\r\n //todo: this is probably already done inside SelText\r\n // insert the selected text\r\n ChangeScrollPastEOL := not (eoScrollPastEol in fOptions);\r\n try\r\n if ChangeScrollPastEOL then\r\n Include(fOptions, eoScrollPastEol);\r\n InternalCaretXY := vNewCaret;\r\n BlockBegin := vNewCaret;\r\n { Add the text. Undo is locked so the action is recorded as crDragDropInsert\r\n instead of crInsert (code right bellow). }\r\n Assert(not SelAvail);\r\n LockUndo;\r\n try\r\n SelText := DragDropText;\r\n finally\r\n UnlockUndo;\r\n end;\r\n finally\r\n if ChangeScrollPastEOL then\r\n Exclude(fOptions, eoScrollPastEol);\r\n end;\r\n // save undo information\r\n if Source = Self then\r\n begin\r\n fUndoList.AddChange(crDragDropInsert, vNewCaret, BlockEnd, SelText,\r\n fActiveSelectionMode);\r\n end\r\n else begin\r\n fUndoList.AddChange(crInsert, vNewCaret, BlockEnd,\r\n SelText, fActiveSelectionMode);\r\n end;\r\n BlockEnd := CaretXY;\r\n CommandProcessor(ecSelGotoXY, #0, @vNewCaret);\r\n finally\r\n EndUndoBlock;\r\n end;\r\n end;\r\n finally\r\n DecPaintLock;\r\n end;\r\n end\r\n else\r\n inherited;\r\nend;\r\n\r\nprocedure TCustomSynEdit.SetRightEdge(Value: Integer);\r\nbegin\r\n if fRightEdge <> Value then\r\n begin\r\n fRightEdge := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TCustomSynEdit.SetRightEdgeColor(Value: TColor);\r\nvar\r\n nX: Integer;\r\n rcInval: TRect;\r\nbegin\r\n if fRightEdgeColor <> Value then\r\n begin\r\n fRightEdgeColor := Value;\r\n if HandleAllocated then\r\n begin\r\n nX := fTextOffset + fRightEdge * fCharWidth;\r\n rcInval := Rect(nX - 1, 0, nX + 1, Height);\r\n InvalidateRect(rcInval, False);\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TCustomSynEdit.GetMaxUndo: Integer;\r\nbegin\r\n result := fUndoList.MaxUndoActions;\r\nend;\r\n\r\nprocedure TCustomSynEdit.SetMaxUndo(const Value: Integer);\r\nbegin\r\n if Value > -1 then\r\n begin\r\n fUndoList.MaxUndoActions := Value;\r\n fRedoList.MaxUndoActions := Value;\r\n end;\r\nend;\r\n\r\nprocedure TCustomSynEdit.Notification(AComponent: TComponent;\r\n Operation: TOperation);\r\nbegin\r\n inherited Notification(AComponent, Operation);\r\n if Operation = opRemove then\r\n begin\r\n if AComponent = fSearchEngine then\r\n begin\r\n SearchEngine := nil;\r\n end;\r\n\r\n if AComponent = fHighlighter then\r\n begin\r\n Highlighter := nil;\r\n end;\r\n\r\n if AComponent = fChainedEditor then\r\n begin\r\n RemoveLinesPointer;\r\n end;\r\n\r\n if (fBookmarkOpt <> nil) then\r\n if (AComponent = fBookmarkOpt.BookmarkImages) then\r\n begin\r\n fBookmarkOpt.BookmarkImages := nil;\r\n InvalidateGutterLines(-1, -1);\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TCustomSynEdit.SetHighlighter(const Value: TSynCustomHighlighter);\r\nbegin\r\n if Value <> fHighlighter then\r\n begin\r\n if Assigned(fHighlighter) then\r\n begin\r\n fHighlighter.UnhookAttrChangeEvent(HighlighterAttrChanged);\r\n{$IFDEF SYN_COMPILER_5_UP}\r\n fHighlighter.RemoveFreeNotification(Self);\r\n{$ENDIF}\r\n end;\r\n if Assigned(Value) then\r\n begin\r\n Value.HookAttrChangeEvent(HighlighterAttrChanged);\r\n Value.FreeNotification(Self);\r\n end;\r\n fHighlighter := Value;\r\n if not(csDestroying in ComponentState) then\r\n HighlighterAttrChanged(fHighlighter);\r\n end;\r\nend;\r\n\r\nprocedure TCustomSynEdit.SetBorderStyle(Value: TSynBorderStyle);\r\nbegin\r\n if fBorderStyle <> Value then\r\n begin\r\n fBorderStyle := Value;\r\n{$IFDEF SYN_CLX}\r\n Resize;\r\n Invalidate;\r\n{$ELSE}\r\n RecreateWnd;\r\n{$ENDIF}\r\n end;\r\nend;\r\n\r\nprocedure TCustomSynEdit.SetHideSelection(const Value: Boolean);\r\nbegin\r\n if fHideSelection <> Value then\r\n begin\r\n FHideSelection := Value;\r\n InvalidateSelection;\r\n end;\r\nend;\r\n\r\nprocedure TCustomSynEdit.SetInsertMode(const Value: Boolean);\r\nbegin\r\n if fInserting <> Value then\r\n begin\r\n fInserting := Value;\r\n if not (csDesigning in ComponentState) then\r\n // Reset the caret.\r\n InitializeCaret;\r\n StatusChanged([scInsertMode]);\r\n end;\r\nend;\r\n\r\nprocedure TCustomSynEdit.InitializeCaret;\r\nvar\r\n ct: TSynEditCaretType;\r\n cw, ch: Integer;\r\nbegin\r\n // CreateCaret automatically destroys the previous one, so we don't have to\r\n // worry about cleaning up the old one here with DestroyCaret.\r\n // Ideally, we will have properties that control what these two carets look like.\r\n if InsertMode then\r\n ct := FInsertCaret\r\n else\r\n ct := FOverwriteCaret;\r\n case ct of\r\n ctHorizontalLine:\r\n begin\r\n cw := fCharWidth;\r\n ch := 2;\r\n FCaretOffset := Point(0, fTextHeight - 2);\r\n end;\r\n ctHalfBlock:\r\n begin\r\n cw := fCharWidth;\r\n ch := (fTextHeight - 2) div 2;\r\n FCaretOffset := Point(0, ch);\r\n end;\r\n ctBlock:\r\n begin\r\n cw := fCharWidth;\r\n ch := fTextHeight - 2;\r\n FCaretOffset := Point(0, 0);\r\n end;\r\n else\r\n begin // ctVerticalLine\r\n cw := 2;\r\n ch := fTextHeight - 2;\r\n FCaretOffset := Point(-1, 0);\r\n end;\r\n end;\r\n Exclude(fStateFlags, sfCaretVisible);\r\n\r\n if Focused or FAlwaysShowCaret then\r\n begin\r\n {$IFDEF SYN_CLX}\r\n CreateCaret(self, 0, cw, ch);\r\n {$ELSE}\r\n CreateCaret(Handle, 0, cw, ch);\r\n {$ENDIF}\r\n UpdateCaret;\r\n end;\r\nend;\r\n\r\nprocedure TCustomSynEdit.SetInsertCaret(const Value: TSynEditCaretType);\r\nbegin\r\n if FInsertCaret <> Value then\r\n begin\r\n FInsertCaret := Value;\r\n InitializeCaret;\r\n end;\r\nend;\r\n\r\nprocedure TCustomSynEdit.SetOverwriteCaret(const Value: TSynEditCaretType);\r\nbegin\r\n if FOverwriteCaret <> Value then\r\n begin\r\n FOverwriteCaret := Value;\r\n InitializeCaret;\r\n end;\r\nend;\r\n\r\nprocedure TCustomSynEdit.SetMaxScrollWidth(Value: Integer);\r\nbegin\r\n Value := MinMax(Value, 1, MaxInt - 1);\r\n if MaxScrollWidth <> Value then\r\n begin\r\n fMaxScrollWidth := Value;\r\n if eoScrollPastEol in Options then\r\n UpdateScrollBars;\r\n end;\r\nend;\r\n\r\nprocedure TCustomSynEdit.EnsureCursorPosVisible;\r\nbegin\r\n EnsureCursorPosVisibleEx(False);\r\nend;\r\n\r\nprocedure TCustomSynEdit.EnsureCursorPosVisibleEx(ForceToMiddle: Boolean;\r\n EvenIfVisible: Boolean = False);\r\nvar\r\n TmpMiddle: Integer;\r\n VisibleX: Integer;\r\n vCaretRow: Integer;\r\nbegin\r\n HandleNeeded;\r\n IncPaintLock;\r\n try\r\n // Make sure X is visible\r\n VisibleX := DisplayX;\r\n if VisibleX < LeftChar then\r\n LeftChar := VisibleX\r\n else if VisibleX >= CharsInWindow + LeftChar then\r\n LeftChar := VisibleX - CharsInWindow + 1\r\n else\r\n LeftChar := LeftChar;\r\n\r\n // Make sure Y is visible\r\n vCaretRow := DisplayY;\r\n if ForceToMiddle then\r\n begin\r\n if vCaretRow < (TopLine - 1) then\r\n begin\r\n TmpMiddle := LinesInWindow div 2;\r\n if vCaretRow - TmpMiddle < 0 then\r\n TopLine := 1\r\n else\r\n TopLine := vCaretRow - TmpMiddle + 1;\r\n end\r\n else if vCaretRow > (TopLine + (LinesInWindow - 2)) then\r\n begin\r\n TmpMiddle := LinesInWindow div 2;\r\n TopLine := vCaretRow - (LinesInWindow - 1) + TmpMiddle;\r\n end\r\n { Forces to middle even if visible in viewport }\r\n else if EvenIfVisible then\r\n begin\r\n TmpMiddle := fLinesInWindow div 2;\r\n TopLine := vCaretRow - TmpMiddle + 1;\r\n end;\r\n end\r\n else begin\r\n if vCaretRow < TopLine then\r\n TopLine := vCaretRow\r\n else if vCaretRow > TopLine + Max(1, LinesInWindow) - 1 then\r\n TopLine := vCaretRow - (LinesInWindow - 1)\r\n else\r\n TopLine := TopLine;\r\n end;\r\n finally\r\n DecPaintLock;\r\n end;\r\nend;\r\n\r\nprocedure TCustomSynEdit.SetKeystrokes(const Value: TSynEditKeyStrokes);\r\nbegin\r\n if Value = nil then\r\n FKeystrokes.Clear\r\n else\r\n FKeystrokes.Assign(Value);\r\nend;\r\n\r\nprocedure TCustomSynEdit.SetDefaultKeystrokes;\r\nbegin\r\n FKeystrokes.ResetDefaults;\r\nend;\r\n\r\n// If the translations requires Data, memory will be allocated for it via a\r\n// GetMem call. The client must call FreeMem on Data if it is not NIL.\r\n\r\nfunction TCustomSynEdit.TranslateKeyCode(Code: word; Shift: TShiftState;\r\n var Data: pointer): TSynEditorCommand;\r\nvar\r\n i: Integer;\r\n{$IFNDEF SYN_COMPILER_3_UP}\r\nconst\r\n VK_ACCEPT = $30;\r\n{$ENDIF}\r\nbegin\r\n i := KeyStrokes.FindKeycode2(fLastKey, fLastShiftState, Code, Shift);\r\n if i >= 0 then\r\n Result := KeyStrokes[i].Command\r\n else begin\r\n i := Keystrokes.FindKeycode(Code, Shift);\r\n if i >= 0 then\r\n Result := Keystrokes[i].Command\r\n else\r\n Result := ecNone;\r\n end;\r\n{$IFDEF SYN_CLX}\r\n if Result = ecNone then\r\n{$ELSE}\r\n if (Result = ecNone) and (Code >= VK_ACCEPT) and (Code <= VK_SCROLL) then\r\n{$ENDIF}\r\n begin\r\n fLastKey := Code;\r\n fLastShiftState := Shift;\r\n end\r\n else\r\n begin\r\n fLastKey := 0;\r\n fLastShiftState := [];\r\n end;\r\nend;\r\n\r\nprocedure TCustomSynEdit.CommandProcessor(Command: TSynEditorCommand;\r\n AChar: WideChar; Data: pointer);\r\nbegin\r\n // first the program event handler gets a chance to process the command\r\n DoOnProcessCommand(Command, AChar, Data);\r\n if Command <> ecNone then\r\n begin\r\n // notify hooked command handlers before the command is executed inside of\r\n // the class\r\n NotifyHookedCommandHandlers(False, Command, AChar, Data);\r\n // internal command handler\r\n if (Command <> ecNone) and (Command < ecUserFirst) then\r\n ExecuteCommand(Command, AChar, Data);\r\n // notify hooked command handlers after the command was executed inside of\r\n // the class\r\n if Command <> ecNone then\r\n NotifyHookedCommandHandlers(True, Command, AChar, Data);\r\n end;\r\n DoOnCommandProcessed(Command, AChar, Data);\r\nend;\r\n\r\nprocedure TCustomSynEdit.ExecuteCommand(Command: TSynEditorCommand; AChar: WideChar;\r\n Data: pointer);\r\n\r\n procedure SetSelectedTextEmpty;\r\n var\r\n vSelText: UnicodeString;\r\n vUndoBegin, vUndoEnd: TBufferCoord;\r\n begin\r\n vUndoBegin := fBlockBegin;\r\n vUndoEnd := fBlockEnd;\r\n vSelText := SelText;\r\n SetSelTextPrimitive('');\r\n if (vUndoBegin.Line < vUndoEnd.Line) or (\r\n (vUndoBegin.Line = vUndoEnd.Line) and (vUndoBegin.Char < vUndoEnd.Char)) then\r\n begin\r\n fUndoList.AddChange(crDelete, vUndoBegin, vUndoEnd, vSelText,\r\n fActiveSelectionMode);\r\n end\r\n else\r\n begin\r\n fUndoList.AddChange(crDeleteAfterCursor, vUndoBegin, vUndoEnd, vSelText,\r\n fActiveSelectionMode);\r\n end;\r\n end;\r\n\r\n procedure ForceCaretX(aCaretX: integer);\r\n var\r\n vRestoreScroll: boolean;\r\n begin\r\n vRestoreScroll := not (eoScrollPastEol in fOptions);\r\n Include(fOptions, eoScrollPastEol);\r\n try\r\n InternalCaretX := aCaretX;\r\n finally\r\n if vRestoreScroll then\r\n Exclude(fOptions, eoScrollPastEol);\r\n end;\r\n end;\r\n\r\nvar\r\n CX: Integer;\r\n Len: Integer;\r\n Temp: UnicodeString;\r\n Temp2: UnicodeString;\r\n Helper: UnicodeString;\r\n TabBuffer: UnicodeString;\r\n SpaceBuffer: UnicodeString;\r\n SpaceCount1: Integer;\r\n SpaceCount2: Integer;\r\n BackCounter: Integer;\r\n StartOfBlock: TBufferCoord;\r\n EndOfBlock: TBufferCoord;\r\n bChangeScroll: Boolean;\r\n moveBkm: Boolean;\r\n WP: TBufferCoord;\r\n Caret: TBufferCoord;\r\n CaretNew: TBufferCoord;\r\n counter: Integer;\r\n InsDelta: Integer;\r\n iUndoBegin, iUndoEnd: TBufferCoord;\r\n vCaretRow: Integer;\r\n vTabTrim: integer;\r\n s: UnicodeString;\r\n i: Integer;\r\nbegin\r\n IncPaintLock;\r\n try\r\n case Command of\r\n// horizontal caret movement or selection\r\n ecLeft, ecSelLeft:\r\n MoveCaretHorz(-1, Command = ecSelLeft);\r\n ecRight, ecSelRight:\r\n MoveCaretHorz(1, Command = ecSelRight);\r\n ecPageLeft, ecSelPageLeft:\r\n MoveCaretHorz(-CharsInWindow, Command = ecSelPageLeft);\r\n ecPageRight, ecSelPageRight:\r\n MoveCaretHorz(CharsInWindow, Command = ecSelPageRight);\r\n ecLineStart, ecSelLineStart:\r\n begin\r\n DoHomeKey(Command = ecSelLineStart);\r\n end;\r\n ecLineEnd, ecSelLineEnd:\r\n DoEndKey(Command = ecSelLineEnd);\r\n// vertical caret movement or selection\r\n ecUp, ecSelUp:\r\n begin\r\n MoveCaretVert(-1, Command = ecSelUp);\r\n Update;\r\n end;\r\n ecDown, ecSelDown:\r\n begin\r\n MoveCaretVert(1, Command = ecSelDown);\r\n Update;\r\n end;\r\n ecPageUp, ecSelPageUp, ecPageDown, ecSelPageDown:\r\n begin\r\n counter := fLinesInWindow shr Ord(eoHalfPageScroll in fOptions);\r\n if eoScrollByOneLess in fOptions then\r\n Dec(counter);\r\n if (Command in [ecPageUp, ecSelPageUp]) then\r\n counter := -counter;\r\n TopLine := TopLine + counter;\r\n MoveCaretVert(counter, Command in [ecSelPageUp, ecSelPageDown]);\r\n Update;\r\n end;\r\n ecPageTop, ecSelPageTop:\r\n begin\r\n CaretNew := DisplayToBufferPos(\r\n DisplayCoord(DisplayX, TopLine) );\r\n MoveCaretAndSelection(CaretXY, CaretNew, Command = ecSelPageTop);\r\n Update;\r\n end;\r\n ecPageBottom, ecSelPageBottom:\r\n begin\r\n CaretNew := DisplayToBufferPos(\r\n DisplayCoord(DisplayX, TopLine + LinesInWindow -1) );\r\n MoveCaretAndSelection(CaretXY, CaretNew, Command = ecSelPageBottom);\r\n Update;\r\n end;\r\n ecEditorTop, ecSelEditorTop:\r\n begin\r\n CaretNew.Char := 1;\r\n CaretNew.Line := 1;\r\n MoveCaretAndSelection(CaretXY, CaretNew, Command = ecSelEditorTop);\r\n Update;\r\n end;\r\n ecEditorBottom, ecSelEditorBottom:\r\n begin\r\n CaretNew.Char := 1;\r\n CaretNew.Line := Lines.Count;\r\n if (CaretNew.Line > 0) then\r\n CaretNew.Char := Length(Lines[CaretNew.Line - 1]) + 1;\r\n MoveCaretAndSelection(CaretXY, CaretNew, Command = ecSelEditorBottom);\r\n Update;\r\n end;\r\n// goto special line / column position\r\n ecGotoXY, ecSelGotoXY:\r\n if Assigned(Data) then\r\n begin\r\n MoveCaretAndSelection(CaretXY, TBufferCoord(Data^), Command = ecSelGotoXY);\r\n Update;\r\n end;\r\n// word selection\r\n ecWordLeft, ecSelWordLeft:\r\n begin\r\n CaretNew := PrevWordPos;\r\n MoveCaretAndSelection(CaretXY, CaretNew, Command = ecSelWordLeft);\r\n end;\r\n ecWordRight, ecSelWordRight:\r\n begin\r\n CaretNew := NextWordPos;\r\n MoveCaretAndSelection(CaretXY, CaretNew, Command = ecSelWordRight);\r\n end;\r\n ecSelWord:\r\n \tbegin\r\n \t SetSelWord;\r\n \tend;\r\n ecSelectAll:\r\n begin\r\n SelectAll;\r\n end;\r\n ecDeleteLastChar:\r\n if not ReadOnly then begin\r\n DoOnPaintTransientEx(ttBefore,true);\r\n try\r\n if SelAvail then\r\n SetSelectedTextEmpty\r\n else begin\r\n Temp := LineText;\r\n TabBuffer := TSynEditStringList(Lines).ExpandedStrings[CaretY - 1];\r\n Len := Length(Temp);\r\n Caret := CaretXY;\r\n vTabTrim := 0;\r\n if CaretX > Len + 1 then\r\n begin\r\n Helper := '';\r\n if eoSmartTabDelete in fOptions then\r\n begin\r\n //It's at the end of the line, move it to the length\r\n if Len > 0 then\r\n InternalCaretX := Len + 1\r\n else begin\r\n //move it as if there were normal spaces there\r\n SpaceCount1 := CaretX - 1;\r\n SpaceCount2 := 0;\r\n // unindent\r\n if SpaceCount1 > 0 then\r\n begin\r\n BackCounter := CaretY - 2;\r\n //It's better not to have if statement inside loop\r\n if (eoTrimTrailingSpaces in Options) and (Len = 0) then\r\n while BackCounter >= 0 do\r\n begin\r\n SpaceCount2 := LeftSpacesEx(Lines[BackCounter], True);\r\n if SpaceCount2 < SpaceCount1 then\r\n break;\r\n Dec(BackCounter);\r\n end\r\n else\r\n while BackCounter >= 0 do\r\n begin\r\n SpaceCount2 := LeftSpaces(Lines[BackCounter]);\r\n if SpaceCount2 < SpaceCount1 then\r\n break;\r\n Dec(BackCounter);\r\n end;\r\n if (BackCounter = -1) and (SpaceCount2 > SpaceCount1) then\r\n SpaceCount2 := 0;\r\n end;\r\n if SpaceCount2 = SpaceCount1 then\r\n SpaceCount2 := 0;\r\n fCaretX := fCaretX - (SpaceCount1 - SpaceCount2);\r\n UpdateLastCaretX;\r\n fStateFlags := fStateFlags + [sfCaretChanged];\r\n StatusChanged([scCaretX]);\r\n end;\r\n end\r\n else begin\r\n // only move caret one column\r\n InternalCaretX := CaretX - 1;\r\n end;\r\n end else if CaretX = 1 then begin\r\n // join this line with the last line if possible\r\n if CaretY > 1 then\r\n begin\r\n InternalCaretY := CaretY - 1;\r\n InternalCaretX := Length(Lines[CaretY - 1]) + 1;\r\n Lines.Delete(CaretY);\r\n DoLinesDeleted(CaretY+1, 1);\r\n if eoTrimTrailingSpaces in Options then\r\n Temp := TrimTrailingSpaces(Temp);\r\n\r\n LineText := LineText + Temp;\r\n Helper := #13#10;\r\n end;\r\n end\r\n else begin\r\n // delete text before the caret\r\n SpaceCount1 := LeftSpaces(Temp);\r\n SpaceCount2 := 0;\r\n if (Temp[CaretX - 1] <= #32) and (SpaceCount1 = CaretX - 1) then\r\n begin\r\n if eoSmartTabDelete in fOptions then\r\n begin\r\n // unindent\r\n if SpaceCount1 > 0 then\r\n begin\r\n BackCounter := CaretY - 2;\r\n while BackCounter >= 0 do\r\n begin\r\n SpaceCount2 := LeftSpaces(Lines[BackCounter]);\r\n if SpaceCount2 < SpaceCount1 then\r\n break;\r\n Dec(BackCounter);\r\n end;\r\n if (BackCounter = -1) and (SpaceCount2 > SpaceCount1) then\r\n SpaceCount2 := 0;\r\n end;\r\n if SpaceCount2 = SpaceCount1 then\r\n SpaceCount2 := 0;\r\n Helper := Copy(Temp, 1, SpaceCount1 - SpaceCount2);\r\n Delete(Temp, 1, SpaceCount1 - SpaceCount2);\r\n end\r\n else begin\r\n SpaceCount2 := SpaceCount1;\r\n //how much till the next tab column\r\n BackCounter := (DisplayX - 1) mod FTabWidth;\r\n if BackCounter = 0 then BackCounter := FTabWidth;\r\n\r\n SpaceCount1 := 0;\r\n CX := DisplayX - BackCounter;\r\n while (SpaceCount1 < FTabWidth) and\r\n (SpaceCount1 < BackCounter) and\r\n (TabBuffer[CX] <> #9) do\r\n begin\r\n Inc(SpaceCount1);\r\n Inc(CX);\r\n end;\r\n {$IFOPT R+}\r\n // Avoids an exception when compiled with $R+.\r\n // 'CX' can be 'Length(TabBuffer)+1', which isn't an AV and evaluates\r\n //to #0. But when compiled with $R+, Delphi raises an Exception.\r\n if CX <= Length(TabBuffer) then\r\n {$ENDIF}\r\n if TabBuffer[CX] = #9 then\r\n SpaceCount1 := SpaceCount1 + 1;\r\n\r\n if SpaceCount2 = SpaceCount1 then\r\n begin\r\n Helper := Copy(Temp, 1, SpaceCount1);\r\n Delete(Temp, 1, SpaceCount1);\r\n end\r\n else begin\r\n Helper := Copy(Temp, SpaceCount2 - SpaceCount1 + 1, SpaceCount1);\r\n Delete(Temp, SpaceCount2 - SpaceCount1 + 1, SpaceCount1);\r\n end;\r\n SpaceCount2 := 0;\r\n end;\r\n fCaretX := fCaretX - (SpaceCount1 - SpaceCount2);\r\n UpdateLastCaretX;\r\n // Stores the previous \"expanded\" CaretX if the line contains tabs.\r\n if (eoTrimTrailingSpaces in Options) and (Len <> Length(TabBuffer)) then\r\n vTabTrim := CharIndex2CaretPos(CaretX, TabWidth, Temp);\r\n ProperSetLine(CaretY - 1, Temp);\r\n fStateFlags := fStateFlags + [sfCaretChanged];\r\n StatusChanged([scCaretX]);\r\n // Calculates a delta to CaretX to compensate for trimmed tabs.\r\n if vTabTrim <> 0 then\r\n if Length(Temp) <> Length(LineText) then\r\n Dec(vTabTrim, CharIndex2CaretPos(CaretX, TabWidth, LineText))\r\n else\r\n vTabTrim := 0;\r\n end\r\n else begin\r\n // delete char\r\n counter := 1;\r\n InternalCaretX := CaretX - counter;\r\n // Stores the previous \"expanded\" CaretX if the line contains tabs.\r\n if (eoTrimTrailingSpaces in Options) and (Len <> Length(TabBuffer)) then\r\n vTabTrim := CharIndex2CaretPos(CaretX, TabWidth, Temp);\r\n Helper := Copy(Temp, CaretX, counter);\r\n Delete(Temp, CaretX, counter);\r\n ProperSetLine(CaretY - 1, Temp);\r\n // Calculates a delta to CaretX to compensate for trimmed tabs.\r\n if vTabTrim <> 0 then\r\n if Length(Temp) <> Length(LineText) then\r\n Dec(vTabTrim, CharIndex2CaretPos(CaretX, TabWidth, LineText))\r\n else\r\n vTabTrim := 0;\r\n end;\r\n end;\r\n if (Caret.Char <> CaretX) or (Caret.Line <> CaretY) then\r\n begin\r\n fUndoList.AddChange(crSilentDelete, CaretXY, Caret, Helper,\r\n smNormal);\r\n if vTabTrim <> 0 then\r\n ForceCaretX(CaretX + vTabTrim);\r\n end;\r\n end;\r\n EnsureCursorPosVisible;\r\n finally\r\n DoOnPaintTransientEx(ttAfter,true);\r\n end;\r\n end;\r\n ecDeleteChar:\r\n if not ReadOnly then begin\r\n DoOnPaintTransient(ttBefore);\r\n\r\n if SelAvail then\r\n SetSelectedTextEmpty\r\n else begin\r\n // Call UpdateLastCaretX. Even though the caret doesn't move, the\r\n // current caret position should \"stick\" whenever text is modified.\r\n UpdateLastCaretX;\r\n Temp := LineText;\r\n Len := Length(Temp);\r\n if CaretX <= Len then\r\n begin\r\n // delete char\r\n counter := 1;\r\n Helper := Copy(Temp, CaretX, counter);\r\n Caret.Char := CaretX + counter;\r\n Caret.Line := CaretY;\r\n Delete(Temp, CaretX, counter);\r\n ProperSetLine(CaretY - 1, Temp);\r\n end\r\n else begin\r\n // join line with the line after\r\n if CaretY < Lines.Count then\r\n begin\r\n Helper := UnicodeStringOfChar(#32, CaretX - 1 - Len);\r\n ProperSetLine(CaretY - 1, Temp + Helper + Lines[CaretY]);\r\n Caret.Char := 1;\r\n Caret.Line := CaretY + 1;\r\n Helper := #13#10;\r\n Lines.Delete(CaretY);\r\n DoLinesDeleted(CaretY +1, 1);\r\n end;\r\n end;\r\n if (Caret.Char <> CaretX) or (Caret.Line <> CaretY) then\r\n begin\r\n fUndoList.AddChange(crSilentDeleteAfterCursor, CaretXY, Caret,\r\n Helper, smNormal);\r\n end;\r\n end;\r\n DoOnPaintTransient(ttAfter);\r\n end;\r\n ecDeleteWord, ecDeleteEOL:\r\n if not ReadOnly then begin\r\n DoOnPaintTransient(ttBefore);\r\n Len := Length(LineText);\r\n if Command = ecDeleteWord then\r\n begin\r\n WP := WordEnd;\r\n Temp := LineText;\r\n if (WP.Char < CaretX) or ((WP.Char = CaretX) and (WP.Line < fLines.Count)) then\r\n begin\r\n if WP.Char > Len then\r\n begin\r\n Inc(WP.Line);\r\n WP.Char := 1;\r\n Temp := Lines[WP.Line - 1];\r\n end\r\n else if Temp[WP.Char] <> #32 then\r\n Inc(WP.Char);\r\n end;\r\n {$IFOPT R+}\r\n Temp := Temp + #0;\r\n {$ENDIF}\r\n if Temp <> '' then\r\n while Temp[WP.Char] = #32 do\r\n Inc(WP.Char);\r\n end\r\n else begin\r\n WP.Char := Len + 1;\r\n WP.Line := CaretY;\r\n end;\r\n if (WP.Char <> CaretX) or (WP.Line <> CaretY) then\r\n begin\r\n SetBlockBegin(CaretXY);\r\n SetBlockEnd(WP);\r\n ActiveSelectionMode := smNormal;\r\n Helper := SelText;\r\n SetSelTextPrimitive(UnicodeStringOfChar(' ', CaretX - BlockBegin.Char));\r\n fUndoList.AddChange(crSilentDeleteAfterCursor, CaretXY, WP,\r\n Helper, smNormal);\r\n InternalCaretXY := CaretXY;\r\n end;\r\n end;\r\n ecDeleteLastWord, ecDeleteBOL:\r\n if not ReadOnly then begin\r\n DoOnPaintTransient(ttBefore);\r\n if Command = ecDeleteLastWord then\r\n WP := PrevWordPos\r\n else begin\r\n WP.Char := 1;\r\n WP.Line := CaretY;\r\n end;\r\n if (WP.Char <> CaretX) or (WP.Line <> CaretY) then\r\n begin\r\n SetBlockBegin(CaretXY);\r\n SetBlockEnd(WP);\r\n ActiveSelectionMode := smNormal;\r\n Helper := SelText;\r\n SetSelTextPrimitive('');\r\n fUndoList.AddChange(crSilentDelete, WP, CaretXY, Helper,\r\n smNormal);\r\n InternalCaretXY := WP;\r\n end;\r\n DoOnPaintTransient(ttAfter);\r\n end;\r\n ecDeleteLine:\r\n if not ReadOnly and (Lines.Count > 0) and not ((CaretY = Lines.Count) and (Length(Lines[CaretY - 1]) = 0))\r\n then begin\r\n DoOnPaintTransient(ttBefore);\r\n if SelAvail then\r\n SetBlockBegin(CaretXY);\r\n Helper := LineText;\r\n if CaretY = Lines.Count then\r\n begin\r\n Lines[CaretY - 1] := '';\r\n fUndoList.AddChange(crSilentDeleteAfterCursor, BufferCoord(1, CaretY),\r\n BufferCoord(Length(Helper) + 1, CaretY), Helper, smNormal);\r\n end\r\n else begin\r\n Lines.Delete(CaretY - 1);\r\n Helper := Helper + #13#10;\r\n fUndoList.AddChange(crSilentDeleteAfterCursor, BufferCoord(1, CaretY),\r\n BufferCoord(1, CaretY + 1), Helper, smNormal);\r\n DoLinesDeleted(CaretY, 1);\r\n end;\r\n InternalCaretXY := BufferCoord(1, CaretY); // like seen in the Delphi editor\r\n end;\r\n ecClearAll:\r\n begin\r\n if not ReadOnly then ClearAll;\r\n end;\r\n ecInsertLine,\r\n ecLineBreak:\r\n if not ReadOnly then begin\r\n UndoList.BeginBlock;\r\n try\r\n if SelAvail then\r\n begin\r\n Helper := SelText;\r\n iUndoBegin := fBlockBegin;\r\n iUndoEnd := fBlockEnd;\r\n SetSelTextPrimitive('');\r\n fUndoList.AddChange(crDelete, iUndoBegin, iUndoEnd, Helper,\r\n fActiveSelectionMode);\r\n end;\r\n Temp := LineText;\r\n Temp2 := Temp;\r\n// This is sloppy, but the Right Thing would be to track the column of markers\r\n// too, so they could be moved depending on whether they are after the caret...\r\n InsDelta := Ord(CaretX = 1);\r\n Len := Length(Temp);\r\n if Len > 0 then\r\n begin\r\n if Len >= CaretX then\r\n begin\r\n if CaretX > 1 then\r\n begin\r\n Temp := Copy(LineText, 1, CaretX - 1);\r\n SpaceCount1 := LeftSpacesEx(Temp,true);\r\n Delete(Temp2, 1, CaretX - 1);\r\n Lines.Insert(CaretY, GetLeftSpacing(SpaceCount1, True) + Temp2);\r\n ProperSetLine(CaretY - 1, Temp);\r\n fUndoList.AddChange(crLineBreak, CaretXY, CaretXY, Temp2,\r\n smNormal);\r\n if Command = ecLineBreak then\r\n InternalCaretXY := BufferCoord(\r\n Length(GetLeftSpacing(SpaceCount1,true)) + 1,\r\n CaretY + 1);\r\n end\r\n else begin\r\n Lines.Insert(CaretY - 1, '');\r\n fUndoList.AddChange(crLineBreak, CaretXY, CaretXY, Temp2,\r\n smNormal);\r\n if Command = ecLineBreak then\r\n InternalCaretY := CaretY + 1;\r\n end;\r\n end\r\n else begin\r\n SpaceCount2 := 0;\r\n BackCounter := CaretY;\r\n if eoAutoIndent in Options then\r\n begin\r\n repeat\r\n Dec(BackCounter);\r\n Temp := Lines[BackCounter];\r\n SpaceCount2 := LeftSpaces(Temp);\r\n until (BackCounter = 0) or (Temp <> '');\r\n end;\r\n Lines.Insert(CaretY, '');\r\n Caret := CaretXY;\r\n\r\n fUndoList.AddChange(crLineBreak, Caret, Caret, '', smNormal); //KV\r\n if Command = ecLineBreak then\r\n begin\r\n InternalCaretXY := BufferCoord(1, CaretY +1);\r\n if SpaceCount2 > 0 then\r\n begin\r\n SpaceBuffer := Copy(Lines[BackCounter], 1, SpaceCount2);\r\n for i := 1 to Length(SpaceBuffer) do\r\n if SpaceBuffer[i] = #9 then\r\n CommandProcessor(ecTab, #0, nil)\r\n else\r\n CommandProcessor(ecChar, SpaceBuffer[i], nil);\r\n end;\r\n end;\r\n end;\r\n end\r\n else begin\r\n if fLines.Count = 0 then\r\n fLines.Add('');\r\n SpaceCount2 := 0;\r\n if eoAutoIndent in Options then\r\n begin\r\n BackCounter := CaretY - 1;\r\n while BackCounter >= 0 do\r\n begin\r\n SpaceCount2 := LeftSpacesEx(Lines[BackCounter],True);\r\n if Length(Lines[BackCounter]) > 0 then break;\r\n dec(BackCounter);\r\n end;\r\n end;\r\n Lines.Insert(CaretY - 1, '');\r\n fUndoList.AddChange(crLineBreak, CaretXY, CaretXY, '', smNormal);\r\n if Command = ecLineBreak then\r\n InternalCaretX := SpaceCount2 + 1;\r\n if Command = ecLineBreak then\r\n InternalCaretY := CaretY + 1;\r\n end;\r\n DoLinesInserted(CaretY - InsDelta, 1);\r\n BlockBegin := CaretXY;\r\n BlockEnd := CaretXY;\r\n EnsureCursorPosVisible;\r\n UpdateLastCaretX;\r\n finally\r\n UndoList.EndBlock;\r\n end;\r\n end;\r\n ecTab:\r\n if not ReadOnly then DoTabKey;\r\n ecShiftTab:\r\n if not ReadOnly then DoShiftTabKey;\r\n ecMatchBracket:\r\n FindMatchingBracket;\r\n ecChar:\r\n // #127 is Ctrl + Backspace, #32 is space\r\n if not ReadOnly and (AChar >= #32) and (AChar <> #127) then\r\n begin\r\n if SelAvail then\r\n begin\r\n BeginUndoBlock;\r\n try\r\n Helper := SelText;\r\n iUndoBegin := fBlockBegin;\r\n iUndoEnd := fBlockEnd;\r\n StartOfBlock := BlockBegin;\r\n if fActiveSelectionMode = smLine then\r\n StartOfBlock.Char := 1;\r\n fUndoList.AddChange(crDelete, iUndoBegin, iUndoEnd, Helper,\r\n fActiveSelectionMode);\r\n SetSelTextPrimitive(AChar);\r\n if fActiveSelectionMode <> smColumn then\r\n begin\r\n fUndoList.AddChange(crInsert, StartOfBlock, BlockEnd, '',\r\n smNormal);\r\n end;\r\n finally\r\n EndUndoBlock;\r\n end;\r\n end\r\n else\r\n begin\r\n SpaceCount2 := 0;\r\n Temp := LineText;\r\n Len := Length(Temp);\r\n if Len < CaretX then\r\n begin\r\n if (Len > 0) then\r\n SpaceBuffer := UnicodeStringOfChar(#32, CaretX - Len - Ord(fInserting))\r\n else\r\n SpaceBuffer := GetLeftSpacing(CaretX - Len - Ord(fInserting), True);\r\n SpaceCount2 := Length(SpaceBuffer);\r\n\r\n Temp := Temp + SpaceBuffer;\r\n end;\r\n // Added the check for whether or not we're in insert mode.\r\n // If we are, we append one less space than we would in overwrite mode.\r\n // This is because in overwrite mode we have to put in a final space\r\n // character which will be overwritten with the typed character. If we put the\r\n // extra space in in insert mode, it would be left at the end of the line and\r\n // cause problems unless eoTrimTrailingSpaces is set.\r\n bChangeScroll := not (eoScrollPastEol in fOptions);\r\n try\r\n if bChangeScroll then Include(fOptions, eoScrollPastEol);\r\n StartOfBlock := CaretXY;\r\n\r\n if fInserting then\r\n begin\r\n if not WordWrap and not (eoAutoSizeMaxScrollWidth in Options)\r\n and (CaretX > MaxScrollWidth) then\r\n begin\r\n Exit;\r\n end;\r\n Insert(AChar, Temp, CaretX);\r\n if (eoTrimTrailingSpaces in Options) and ((AChar = #9) or (AChar = #32)) and (Length(TrimTrailingSpaces(LineText)) = 0) then\r\n InternalCaretX := GetExpandedLength(Temp, TabWidth) + 1\r\n else\r\n begin\r\n if Len = 0 then\r\n InternalCaretX := Length(Temp) + 1\r\n else\r\n InternalCaretX := CaretX + 1;\r\n end;\r\n ProperSetLine(CaretY - 1, Temp);\r\n if SpaceCount2 > 0 then\r\n begin\r\n BeginUndoBlock;\r\n try\r\n //if we inserted spaces with this char, we need to account for those\r\n //in the X Position\r\n StartOfBlock.Char := StartOfBlock.Char - SpaceCount2;\r\n EndOfBlock := CaretXY;\r\n EndOfBlock.Char := EndOfBlock.Char - 1;\r\n //The added whitespace\r\n fUndoList.AddChange(crWhiteSpaceAdd, EndOfBlock, StartOfBlock, '',\r\n smNormal);\r\n StartOfBlock.Char := StartOfBlock.Char + SpaceCount2;\r\n\r\n fUndoList.AddChange(crInsert, StartOfBlock, CaretXY, '',\r\n smNormal);\r\n finally\r\n EndUndoBlock;\r\n end;\r\n end\r\n else begin\r\n fUndoList.AddChange(crInsert, StartOfBlock, CaretXY, '',\r\n smNormal);\r\n end;\r\n end\r\n else begin\r\n// Processing of case character covers on LeadByte.\r\n counter := 1;\r\n Helper := Copy(Temp, CaretX, counter);\r\n Temp[CaretX] := AChar;\r\n CaretNew.Char := CaretX + counter;\r\n CaretNew.Line := CaretY;\r\n ProperSetLine(CaretY - 1, Temp);\r\n fUndoList.AddChange(crInsert, StartOfBlock, CaretNew, Helper,\r\n smNormal);\r\n InternalCaretX := CaretX + 1;\r\n end;\r\n if CaretX >= LeftChar + fCharsInWindow then\r\n LeftChar := LeftChar + Min(25, fCharsInWindow - 1);\r\n finally\r\n if bChangeScroll then Exclude(fOptions, eoScrollPastEol);\r\n end;\r\n end;\r\n DoOnPaintTransient(ttAfter);\r\n end;\r\n ecUpperCase,\r\n ecLowerCase,\r\n ecToggleCase,\r\n ecTitleCase,\r\n ecUpperCaseBlock,\r\n ecLowerCaseBlock,\r\n ecToggleCaseBlock:\r\n if not ReadOnly then DoCaseChange(Command);\r\n ecUndo:\r\n begin\r\n if not ReadOnly then Undo;\r\n end;\r\n ecRedo:\r\n begin\r\n if not ReadOnly then Redo;\r\n end;\r\n ecGotoMarker0..ecGotoMarker9:\r\n begin\r\n if BookMarkOptions.EnableKeys then\r\n GotoBookMark(Command - ecGotoMarker0);\r\n end;\r\n ecSetMarker0..ecSetMarker9:\r\n begin\r\n if BookMarkOptions.EnableKeys then\r\n begin\r\n CX := Command - ecSetMarker0;\r\n if Assigned(Data) then\r\n Caret := TBufferCoord(Data^)\r\n else\r\n Caret := CaretXY;\r\n if assigned(fBookMarks[CX]) then\r\n begin\r\n moveBkm := (fBookMarks[CX].Line <> Caret.Line);\r\n ClearBookMark(CX);\r\n if moveBkm then\r\n SetBookMark(CX, Caret.Char, Caret.Line);\r\n end\r\n else\r\n SetBookMark(CX, Caret.Char, Caret.Line);\r\n end; // if BookMarkOptions.EnableKeys\r\n end;\r\n ecCut:\r\n begin\r\n if (not ReadOnly) and SelAvail then\r\n CutToClipboard;\r\n end;\r\n ecCopy:\r\n begin\r\n CopyToClipboard;\r\n end;\r\n ecPaste:\r\n begin\r\n if not ReadOnly then PasteFromClipboard;\r\n end;\r\n ecScrollUp, ecScrollDown:\r\n begin\r\n vCaretRow := DisplayY;\r\n if (vCaretRow < TopLine) or (vCaretRow >= TopLine + LinesInWindow) then\r\n // If the caret is not in view then, like the Delphi editor, move\r\n // it in view and do nothing else\r\n EnsureCursorPosVisible\r\n else begin\r\n if Command = ecScrollUp then\r\n begin\r\n TopLine := TopLine - 1;\r\n if vCaretRow > TopLine + LinesInWindow - 1 then\r\n MoveCaretVert((TopLine + LinesInWindow - 1) - vCaretRow, False);\r\n end\r\n else begin\r\n TopLine := TopLine + 1;\r\n if vCaretRow < TopLine then\r\n MoveCaretVert(TopLine - vCaretRow, False);\r\n end;\r\n EnsureCursorPosVisible;\r\n Update;\r\n end;\r\n end;\r\n ecScrollLeft:\r\n begin\r\n LeftChar := LeftChar - 1;\r\n // todo: The following code was commented out because it is not MBCS or hard-tab safe.\r\n //if CaretX > LeftChar + CharsInWindow then\r\n // InternalCaretX := LeftChar + CharsInWindow;\r\n Update;\r\n end;\r\n ecScrollRight:\r\n begin\r\n LeftChar := LeftChar + 1;\r\n // todo: The following code was commented out because it is not MBCS or hard-tab safe.\r\n //if CaretX < LeftChar then\r\n // InternalCaretX := LeftChar;\r\n Update;\r\n end;\r\n ecInsertMode:\r\n begin\r\n InsertMode := True;\r\n end;\r\n ecOverwriteMode:\r\n begin\r\n InsertMode := False;\r\n end;\r\n ecToggleMode:\r\n begin\r\n InsertMode := not InsertMode;\r\n end;\r\n ecBlockIndent:\r\n if not ReadOnly then DoBlockIndent;\r\n ecBlockUnindent:\r\n if not ReadOnly then DoBlockUnindent;\r\n ecNormalSelect:\r\n SelectionMode := smNormal;\r\n ecColumnSelect:\r\n SelectionMode := smColumn;\r\n ecLineSelect:\r\n SelectionMode := smLine;\r\n ecContextHelp:\r\n begin\r\n if Assigned (fOnContextHelp) then\r\n fOnContextHelp (self,WordAtCursor);\r\n end;\r\n ecImeStr:\r\n if not ReadOnly then\r\n begin\r\n SetString(S, PWideChar(Data), WStrLen(Data));\r\n if SelAvail then\r\n begin\r\n BeginUndoBlock;\r\n try\r\n fUndoList.AddChange(crDelete, fBlockBegin, fBlockEnd, Helper,\r\n smNormal);\r\n StartOfBlock := fBlockBegin;\r\n SetSelTextPrimitive(s);\r\n fUndoList.AddChange(crInsert, fBlockBegin, fBlockEnd, Helper,\r\n smNormal);\r\n finally\r\n EndUndoBlock;\r\n end;\r\n InvalidateGutterLines(-1, -1);\r\n end\r\n else\r\n begin\r\n Temp := LineText;\r\n Len := Length(Temp);\r\n if Len < CaretX then\r\n Temp := Temp + UnicodeStringOfChar(#32, CaretX - Len - 1);\r\n bChangeScroll := not (eoScrollPastEol in fOptions);\r\n try\r\n if bChangeScroll then Include(fOptions, eoScrollPastEol);\r\n StartOfBlock := CaretXY;\r\n Len := Length(s);\r\n if not fInserting then\r\n begin\r\n Helper := Copy(Temp, CaretX, Len);\r\n Delete(Temp, CaretX, Len);\r\n end;\r\n Insert(s, Temp, CaretX);\r\n InternalCaretX := (CaretX + Len);\r\n ProperSetLine(CaretY - 1, Temp);\r\n if fInserting then\r\n Helper := '';\r\n fUndoList.AddChange(crInsert, StartOfBlock, CaretXY, Helper,\r\n smNormal);\r\n if CaretX >= LeftChar + fCharsInWindow then\r\n LeftChar := LeftChar + min(25, fCharsInWindow - 1);\r\n finally\r\n if bChangeScroll then Exclude(fOptions, eoScrollPastEol);\r\n end;\r\n end;\r\n end;\r\n end;\r\n finally\r\n DecPaintLock;\r\n end;\r\nend;\r\n\r\nprocedure TCustomSynEdit.DoOnCommandProcessed(Command: TSynEditorCommand;\r\n AChar: WideChar; Data: pointer);\r\nbegin\r\n if Assigned(fOnCommandProcessed) then\r\n fOnCommandProcessed(Self, Command, AChar, Data);\r\nend;\r\n\r\nprocedure TCustomSynEdit.DoOnProcessCommand(var Command: TSynEditorCommand;\r\n var AChar: WideChar; Data: pointer);\r\nbegin\r\n if Command < ecUserFirst then\r\n begin\r\n if Assigned(FOnProcessCommand) then\r\n FOnProcessCommand(Self, Command, AChar, Data);\r\n end\r\n else begin\r\n if Assigned(FOnProcessUserCommand) then\r\n FOnProcessUserCommand(Self, Command, AChar, Data);\r\n end;\r\nend;\r\n\r\nprocedure TCustomSynEdit.ClearAll;\r\nbegin\r\n Lines.Clear;\r\n fMarkList.Clear; // fMarkList.Clear also frees all bookmarks,\r\n FillChar(fBookMarks, sizeof(fBookMarks), 0); // so fBookMarks should be cleared too\r\n fUndoList.Clear;\r\n fRedoList.Clear;\r\n Modified := False;\r\nend;\r\n\r\nprocedure TCustomSynEdit.ClearSelection;\r\nbegin\r\n if SelAvail then\r\n SelText := '';\r\nend;\r\n\r\nfunction TCustomSynEdit.NextWordPosEx(const XY: TBufferCoord): TBufferCoord;\r\nvar\r\n CX, CY, LineLen: Integer;\r\n Line: UnicodeString;\r\nbegin\r\n CX := XY.Char;\r\n CY := XY.Line;\r\n\r\n // valid line?\r\n if (CY >= 1) and (CY <= Lines.Count) then\r\n begin\r\n Line := Lines[CY - 1];\r\n\r\n LineLen := Length(Line);\r\n if CX >= LineLen then\r\n begin\r\n // find first IdentChar or multibyte char in the next line\r\n if CY < Lines.Count then\r\n begin\r\n Line := Lines[CY];\r\n Inc(CY);\r\n CX := StrScanForCharInCategory(Line, 1, IsIdentChar);\r\n if CX = 0 then\r\n Inc(CX);\r\n end;\r\n end\r\n else\r\n begin\r\n // find next word-break-char if current char is an IdentChar\r\n if IsIdentChar(Line[CX]) then\r\n CX := StrScanForCharInCategory(Line, CX, IsWordBreakChar);\r\n // if word-break-char found, find the next IdentChar\r\n if CX > 0 then\r\n CX := StrScanForCharInCategory(Line, CX, IsIdentChar);\r\n // if one of those failed just position at the end of the line\r\n if CX = 0 then\r\n CX := LineLen + 1;\r\n end;\r\n end;\r\n Result.Char := CX;\r\n Result.Line := CY;\r\nend;\r\n\r\nfunction TCustomSynEdit.WordStartEx(const XY: TBufferCoord): TBufferCoord;\r\nvar\r\n CX, CY: Integer;\r\n Line: UnicodeString;\r\nbegin\r\n CX := XY.Char;\r\n CY := XY.Line;\r\n // valid line?\r\n if (CY >= 1) and (CY <= Lines.Count) then\r\n begin\r\n Line := Lines[CY - 1];\r\n CX := Min(CX, Length(Line) + 1);\r\n\r\n if CX > 1 then\r\n begin // only find previous char, if not already on start of line\r\n // if previous char isn't a word-break-char search for the last IdentChar\r\n if not IsWordBreakChar(Line[CX - 1]) then\r\n CX := StrRScanForCharInCategory(Line, CX - 1, IsWordBreakChar) + 1;\r\n end;\r\n end;\r\n Result.Char := CX;\r\n Result.Line := CY;\r\nend;\r\n\r\nfunction TCustomSynEdit.WordEndEx(const XY: TBufferCoord): TBufferCoord;\r\nvar\r\n CX, CY: Integer;\r\n Line: UnicodeString;\r\nbegin\r\n CX := XY.Char;\r\n CY := XY.Line;\r\n // valid line?\r\n if (CY >= 1) and (CY <= Lines.Count) then\r\n begin\r\n Line := Lines[CY - 1];\r\n\r\n CX := StrScanForCharInCategory(Line, CX, IsWordBreakChar);\r\n // if no word-break-char is found just position at the end of the line\r\n if CX = 0 then\r\n CX := Length(Line) + 1;\r\n end;\r\n Result.Char := CX;\r\n Result.Line := CY;\r\nend;\r\n\r\nfunction TCustomSynEdit.PrevWordPosEx(const XY: TBufferCoord): TBufferCoord;\r\nvar\r\n CX, CY: Integer;\r\n Line: UnicodeString;\r\nbegin\r\n CX := XY.Char;\r\n CY := XY.Line;\r\n // valid line?\r\n if (CY >= 1) and (CY <= Lines.Count) then\r\n begin\r\n Line := Lines[CY - 1];\r\n CX := Min(CX, Length(Line) + 1);\r\n\r\n if CX <= 1 then\r\n begin\r\n // find last IdentChar in the previous line\r\n if CY > 1 then\r\n begin\r\n Dec(CY);\r\n Line := Lines[CY - 1];\r\n CX := Length(Line) + 1;\r\n end;\r\n end\r\n else\r\n begin\r\n // if previous char is a word-break-char search for the last IdentChar\r\n if IsWordBreakChar(Line[CX - 1]) then\r\n CX := StrRScanForCharInCategory(Line, CX - 1, IsIdentChar);\r\n if CX > 0 then\r\n // search for the first IdentChar of this \"word\"\r\n CX := StrRScanForCharInCategory(Line, CX - 1, IsWordBreakChar) + 1;\r\n if CX = 0 then\r\n begin\r\n // else just position at the end of the previous line\r\n if CY > 1 then\r\n begin\r\n Dec(CY);\r\n Line := Lines[CY - 1];\r\n CX := Length(Line) + 1;\r\n end\r\n else\r\n CX := 1;\r\n end;\r\n end;\r\n end;\r\n Result.Char := CX;\r\n Result.Line := CY;\r\nend;\r\n\r\nprocedure TCustomSynEdit.SetSelectionMode(const Value: TSynSelectionMode);\r\nbegin\r\n if FSelectionMode <> Value then\r\n begin\r\n fSelectionMode := Value;\r\n ActiveSelectionMode := Value;\r\n end;\r\nend;\r\n\r\nprocedure TCustomSynEdit.SetActiveSelectionMode(const Value: TSynSelectionMode);\r\nbegin\r\n if fActiveSelectionMode <> Value then\r\n begin\r\n if SelAvail then\r\n InvalidateSelection;\r\n fActiveSelectionMode := Value;\r\n if SelAvail then\r\n InvalidateSelection;\r\n StatusChanged([scSelection]);\r\n end;\r\nend;\r\n\r\nprocedure TCustomSynEdit.SetAdditionalIdentChars(const Value: TSysCharSet);\r\nbegin\r\n FAdditionalIdentChars := Value;\r\nend;\r\n\r\nprocedure TCustomSynEdit.SetAdditionalWordBreakChars(const Value: TSysCharSet);\r\nbegin\r\n FAdditionalWordBreakChars := Value;\r\nend;\r\n\r\nprocedure TCustomSynEdit.BeginUndoBlock;\r\nbegin\r\n fUndoList.BeginBlock;\r\nend;\r\n\r\nprocedure TCustomSynEdit.BeginUpdate;\r\nbegin\r\n IncPaintLock;\r\nend;\r\n\r\nprocedure TCustomSynEdit.EndUndoBlock;\r\nbegin\r\n fUndoList.EndBlock;\r\nend;\r\n\r\nprocedure TCustomSynEdit.EndUpdate;\r\nbegin\r\n DecPaintLock;\r\nend;\r\n\r\nprocedure TCustomSynEdit.AddKey(Command: TSynEditorCommand;\r\n Key1: word; SS1: TShiftState; Key2: word; SS2: TShiftState);\r\nvar\r\n Key: TSynEditKeyStroke;\r\nbegin\r\n Key := Keystrokes.Add;\r\n Key.Command := Command;\r\n Key.Key := Key1;\r\n Key.Shift := SS1;\r\n Key.Key2 := Key2;\r\n Key.Shift2 := SS2;\r\nend;\r\n\r\n{ Called by FMarkList if change }\r\nprocedure TCustomSynEdit.MarkListChange(Sender: TObject);\r\nbegin\r\n InvalidateGutter;\r\nend;\r\n\r\nfunction TCustomSynEdit.GetSelStart: integer;\r\nbegin\r\n if GetSelAvail then\r\n Result := RowColToCharIndex(BlockBegin)\r\n else\r\n Result := RowColToCharIndex(CaretXY);\r\nend;\r\n\r\nprocedure TCustomSynEdit.SetAlwaysShowCaret(const Value: Boolean);\r\nbegin\r\n if FAlwaysShowCaret <> Value then\r\n begin\r\n FAlwaysShowCaret := Value;\r\n if not(csDestroying in ComponentState) and not(focused) then\r\n begin\r\n if Value then\r\n begin\r\n InitializeCaret;\r\n end\r\n else\r\n begin\r\n HideCaret;\r\n {$IFDEF SYN_CLX}\r\n kTextDrawer.DestroyCaret;\r\n {$ELSE}\r\n Windows.DestroyCaret;\r\n {$ENDIF}\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TCustomSynEdit.SetSelStart(const Value: Integer);\r\nbegin\r\n { if we don't call HandleNeeded, CharsInWindow may be 0 and LeftChar will\r\n be set to CaretX }\r\n HandleNeeded;\r\n InternalCaretXY := CharIndexToRowCol(Value);\r\n BlockBegin := CaretXY;\r\nend;\r\n\r\nfunction TCustomSynEdit.GetSelEnd: Integer;\r\nbegin\r\n if GetSelAvail then\r\n Result := RowColToCharIndex(Blockend)\r\n else\r\n Result := RowColToCharIndex(CaretXY);\r\nend;\r\n\r\nprocedure TCustomSynEdit.SetSelEnd(const Value: Integer);\r\nbegin\r\n HandleNeeded;\r\n BlockEnd := CharIndexToRowCol( Value );\r\nend;\r\n\r\nprocedure TCustomSynEdit.SetSelWord;\r\nbegin\r\n SetWordBlock(CaretXY);\r\nend;\r\n\r\nprocedure TCustomSynEdit.SetExtraLineSpacing(const Value: Integer);\r\nbegin\r\n fExtraLineSpacing := Value;\r\n SynFontChanged(self);\r\nend;\r\n\r\nfunction TCustomSynEdit.GetBookMark(BookMark: Integer; var X, Y: Integer):\r\n Boolean;\r\nvar\r\n i: Integer;\r\nbegin\r\n Result := False;\r\n if assigned(Marks) then\r\n for i := 0 to Marks.Count - 1 do\r\n if Marks[i].IsBookmark and (Marks[i].BookmarkNumber = BookMark) then\r\n begin\r\n X := Marks[i].Char;\r\n Y := Marks[i].Line;\r\n Result := True;\r\n Exit;\r\n end;\r\nend;\r\n\r\nfunction TCustomSynEdit.IsBookmark(BookMark: Integer): Boolean;\r\nvar\r\n x, y: Integer;\r\nbegin\r\n Result := GetBookMark(BookMark, x, y);\r\nend;\r\n\r\nprocedure TCustomSynEdit.ClearUndo;\r\nbegin\r\n fUndoList.Clear;\r\n fRedoList.Clear;\r\nend;\r\n\r\nprocedure TCustomSynEdit.SetSelTextExternal(const Value: UnicodeString);\r\nvar\r\n StartOfBlock, EndOfBlock: TBufferCoord;\r\nbegin\r\n BeginUndoBlock;\r\n try\r\n if SelAvail then\r\n begin\r\n fUndoList.AddChange(crDelete, fBlockBegin, fBlockEnd,\r\n SelText, fActiveSelectionMode);\r\n end\r\n else\r\n ActiveSelectionMode := SelectionMode;\r\n StartOfBlock := BlockBegin;\r\n EndOfBlock := BlockEnd;\r\n fBlockBegin := StartOfBlock;\r\n fBlockEnd := EndOfBlock;\r\n SetSelTextPrimitive(Value);\r\n if (Value <> '') and (fActiveSelectionMode <> smColumn) then\r\n fUndoList.AddChange(crInsert, StartOfBlock, BlockEnd, '', fActiveSelectionMode);\r\n finally\r\n EndUndoBlock;\r\n end;\r\nend;\r\n\r\nprocedure TCustomSynEdit.SetGutter(const Value: TSynGutter);\r\nbegin\r\n fGutter.Assign(Value);\r\nend;\r\n\r\nprocedure TCustomSynEdit.GutterChanged(Sender: TObject);\r\nvar\r\n nW: Integer;\r\nbegin\r\n if not (csLoading in ComponentState) then\r\n begin\r\n if fGutter.ShowLineNumbers and fGutter.AutoSize then\r\n fGutter.AutoSizeDigitCount(Lines.Count);\r\n if fGutter.UseFontStyle then\r\n begin\r\n fTextDrawer.SetBaseFont(fGutter.Font);\r\n nW := fGutter.RealGutterWidth(fTextDrawer.CharWidth);\r\n fTextDrawer.SetBaseFont(Font);\r\n end\r\n else\r\n nW := fGutter.RealGutterWidth(fCharWidth);\r\n if nW = fGutterWidth then\r\n InvalidateGutter\r\n else\r\n SetGutterWidth(nW);\r\n end;\r\nend;\r\n\r\nprocedure TCustomSynEdit.LockUndo;\r\nbegin\r\n fUndoList.Lock;\r\n fRedoList.Lock;\r\nend;\r\n\r\nprocedure TCustomSynEdit.UnlockUndo;\r\nbegin\r\n fUndoList.Unlock;\r\n fRedoList.Unlock;\r\nend;\r\n\r\nfunction TCustomSynEdit.UnifiedSelection: TBufferBlock;\r\nbegin\r\n if BlockBegin.Line > BlockEnd.Line then begin\r\n result.BeginLine:= BlockEnd.Line;\r\n result.EndLine:= BlockBegin.Line;\r\n end else begin\r\n result.BeginLine:= BlockBegin.Line;\r\n result.EndLine:= BlockEnd.Line;\r\n end;\r\n if BlockBegin.Char > BlockEnd.Char then begin\r\n result.BeginChar:= BlockEnd.Char;\r\n result.EndChar:= BlockBegin.Char;\r\n end else begin\r\n result.BeginChar:= BlockBegin.Char;\r\n result.EndChar:= BlockEnd.Char;\r\n end;\r\nend;\r\n\r\n\r\n{$IFNDEF SYN_COMPILER_6_UP}\r\nprocedure TCustomSynEdit.WMMouseWheel(var Msg: TMessage);\r\nvar\r\n nDelta: Integer;\r\n nWheelClicks: Integer;\r\n{$IFNDEF SYN_COMPILER_4_UP}\r\nconst\r\n LinesToScroll = 3;\r\n WHEEL_DELTA = 120;\r\n WHEEL_PAGESCROLL = MAXDWORD;\r\n SPI_GETWHEELSCROLLLINES = 104;\r\n{$ENDIF}\r\nbegin\r\n if csDesigning in ComponentState then\r\n exit;\r\n\r\n\tMsg.Result := 1;\r\n\r\n{$IFDEF SYN_COMPILER_4_UP}\r\n // In some occasions Windows will not properly initialize mouse wheel, but\r\n // will still keep sending WM_MOUSEWHEEL message. Calling inherited procedure\r\n // will re-initialize related properties (i.e. Mouse.WheelScrollLines)\r\n inherited;\r\n{$ENDIF}\r\n\r\n if GetKeyState(VK_CONTROL) >= 0 then\r\n begin\r\n{$IFDEF SYN_COMPILER_4_UP}\r\n nDelta := Mouse.WheelScrollLines\r\n{$ELSE}\r\n if not SystemParametersInfo(SPI_GETWHEELSCROLLLINES, 0, @nDelta, 0) then\r\n nDelta := LinesToScroll;\r\n{$ENDIF}\r\n end\r\n else\r\n nDelta := LinesInWindow shr Ord(eoHalfPageScroll in fOptions);\r\n\r\n Inc(fMouseWheelAccumulator, SmallInt(Msg.wParamHi));\r\n nWheelClicks := fMouseWheelAccumulator div WHEEL_DELTA;\r\n fMouseWheelAccumulator := fMouseWheelAccumulator mod WHEEL_DELTA;\r\n if (nDelta = Integer(WHEEL_PAGESCROLL)) or (nDelta > LinesInWindow) then\r\n nDelta := LinesInWindow;\r\n TopLine := TopLine - (nDelta * nWheelClicks);\r\n Update;\r\n if Assigned(OnScroll) then OnScroll(Self,sbVertical);\r\nend;\r\n{$ENDIF}\r\n\r\n{$IFNDEF SYN_CLX}\r\nprocedure TCustomSynEdit.WMSetCursor(var Msg: TWMSetCursor);\r\nbegin\r\n if (Msg.HitTest = HTCLIENT) and (Msg.CursorWnd = Handle) and\r\n not(csDesigning in ComponentState) then\r\n begin\r\n UpdateMouseCursor;\r\n end\r\n else\r\n inherited;\r\nend;\r\n{$ENDIF}\r\n\r\nprocedure TCustomSynEdit.SetTabWidth(Value: Integer);\r\nbegin\r\n Value := MinMax(Value, 1, 256);\r\n if (Value <> fTabWidth) then begin\r\n fTabWidth := Value;\r\n TSynEditStringList(Lines).TabWidth := Value;\r\n Invalidate; // to redraw text containing tab chars\r\n if WordWrap then\r\n begin\r\n fWordWrapPlugin.Reset;\r\n InvalidateGutter;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TCustomSynEdit.SelectedColorsChanged(Sender: TObject);\r\nbegin\r\n InvalidateSelection;\r\nend;\r\n\r\n// find / replace\r\n\r\nfunction TCustomSynEdit.SearchReplace(const ASearch, AReplace: UnicodeString;\r\n AOptions: TSynSearchOptions): Integer;\r\nvar\r\n ptStart, ptEnd: TBufferCoord; // start and end of the search range\r\n ptCurrent: TBufferCoord; // current search position\r\n nSearchLen, nReplaceLen, n, nFound: integer;\r\n nInLine: integer;\r\n bBackward, bFromCursor: boolean;\r\n bPrompt: boolean;\r\n bReplace, bReplaceAll: boolean;\r\n bEndUndoBlock: boolean;\r\n nAction: TSynReplaceAction;\r\n iResultOffset: Integer;\r\n\r\n function InValidSearchRange(First, Last: Integer): Boolean;\r\n begin\r\n Result := True;\r\n if (fActiveSelectionMode = smNormal) or not (ssoSelectedOnly in AOptions) then\r\n begin\r\n if ((ptCurrent.Line = ptStart.Line) and (First < ptStart.Char)) or\r\n ((ptCurrent.Line = ptEnd.Line) and (Last > ptEnd.Char))\r\n then\r\n Result := False;\r\n end\r\n else\r\n if (fActiveSelectionMode = smColumn) then\r\n // solves bug in search/replace when smColumn mode active and no selection\r\n Result := (First >= ptStart.Char) and (Last <= ptEnd.Char) or (ptEnd.Char - ptStart.Char < 1);\r\n end;\r\n\r\nbegin\r\n if not Assigned(fSearchEngine) then\r\n raise ESynEditError.Create('No search engine has been assigned');\r\n\r\n Result := 0;\r\n // can't search for or replace an empty string\r\n if Length(ASearch) = 0 then exit;\r\n // get the text range to search in, ignore the \"Search in selection only\"\r\n // option if nothing is selected\r\n bBackward := (ssoBackwards in AOptions);\r\n bPrompt := (ssoPrompt in AOptions);\r\n bReplace := (ssoReplace in AOptions);\r\n bReplaceAll := (ssoReplaceAll in AOptions);\r\n bFromCursor := not (ssoEntireScope in AOptions);\r\n if not SelAvail then Exclude(AOptions, ssoSelectedOnly);\r\n if (ssoSelectedOnly in AOptions) then begin\r\n ptStart := BlockBegin;\r\n ptEnd := BlockEnd;\r\n // search the whole line in the line selection mode\r\n if (fActiveSelectionMode = smLine) then\r\n begin\r\n ptStart.Char := 1;\r\n ptEnd.Char := Length(Lines[ptEnd.Line - 1]) + 1;\r\n end\r\n else if (fActiveSelectionMode = smColumn) then\r\n // make sure the start column is smaller than the end column\r\n if (ptStart.Char > ptEnd.Char) then\r\n SwapInt(Integer(ptStart.Char), Integer(ptEnd.Char));\r\n // ignore the cursor position when searching in the selection\r\n if bBackward then\r\n ptCurrent := ptEnd\r\n else\r\n ptCurrent := ptStart;\r\n end\r\n else\r\n begin\r\n ptStart.Char := 1;\r\n ptStart.Line := 1;\r\n ptEnd.Line := Lines.Count;\r\n ptEnd.Char := Length(Lines[ptEnd.Line - 1]) + 1;\r\n if bFromCursor then\r\n if bBackward then ptEnd := CaretXY else ptStart := CaretXY;\r\n if bBackward then ptCurrent := ptEnd else ptCurrent := ptStart;\r\n end;\r\n // initialize the search engine\r\n fSearchEngine.Options := AOptions;\r\n fSearchEngine.Pattern := ASearch;\r\n // search while the current search position is inside of the search range\r\n nReplaceLen := 0;\r\n DoOnPaintTransient(ttBefore);\r\n if bReplaceAll and not bPrompt then\r\n begin\r\n IncPaintLock;\r\n BeginUndoBlock;\r\n bEndUndoBlock := True;\r\n end\r\n else\r\n bEndUndoBlock := False;\r\n try\r\n while (ptCurrent.Line >= ptStart.Line) and (ptCurrent.Line <= ptEnd.Line) do\r\n begin\r\n nInLine := fSearchEngine.FindAll(Lines[ptCurrent.Line - 1]);\r\n iResultOffset := 0;\r\n if bBackward then\r\n n := Pred(fSearchEngine.ResultCount)\r\n else\r\n n := 0;\r\n // Operate on all results in this line.\r\n while nInLine > 0 do\r\n begin\r\n // An occurrence may have been replaced with a text of different length\r\n nFound := fSearchEngine.Results[n] + iResultOffset;\r\n nSearchLen := fSearchEngine.Lengths[n];\r\n if bBackward then Dec(n) else Inc(n);\r\n Dec(nInLine);\r\n // Is the search result entirely in the search range?\r\n if not InValidSearchRange(nFound, nFound + nSearchLen) then continue;\r\n Inc(Result);\r\n // Select the text, so the user can see it in the OnReplaceText event\r\n // handler or as the search result.\r\n\r\n ptCurrent.Char := nFound;\r\n BlockBegin := ptCurrent;\r\n // Be sure to use the Ex version of CursorPos so that it appears in the middle if necessary\r\n SetCaretXYEx(False, BufferCoord(1, ptCurrent.Line));\r\n EnsureCursorPosVisibleEx(True);\r\n Inc(ptCurrent.Char, nSearchLen);\r\n BlockEnd := ptCurrent;\r\n InternalCaretXY := ptCurrent;\r\n if bBackward then InternalCaretXY := BlockBegin else InternalCaretXY := ptCurrent;\r\n // If it's a search only we can leave the procedure now.\r\n if not (bReplace or bReplaceAll) then exit;\r\n // Prompt and replace or replace all. If user chooses to replace\r\n // all after prompting, turn off prompting.\r\n if bPrompt and Assigned(fOnReplaceText) then\r\n begin\r\n nAction := DoOnReplaceText(ASearch, AReplace, ptCurrent.Line, nFound);\r\n if nAction = raCancel then\r\n exit;\r\n end\r\n else\r\n nAction := raReplace;\r\n if nAction = raSkip then\r\n Dec(Result)\r\n else begin\r\n // user has been prompted and has requested to silently replace all\r\n // so turn off prompting\r\n if nAction = raReplaceAll then begin\r\n if not bReplaceAll or bPrompt then\r\n begin\r\n bReplaceAll := True;\r\n IncPaintLock;\r\n end;\r\n bPrompt := False;\r\n if bEndUndoBlock = false then\r\n BeginUndoBlock;\r\n bEndUndoBlock:= true;\r\n end;\r\n // Allow advanced substition in the search engine\r\n SelText := fSearchEngine.Replace(SelText, AReplace);\r\n nReplaceLen := CaretX - nFound;\r\n end;\r\n // fix the caret position and the remaining results\r\n if not bBackward then begin\r\n InternalCaretX := nFound + nReplaceLen;\r\n if (nSearchLen <> nReplaceLen) and (nAction <> raSkip) then\r\n begin\r\n Inc(iResultOffset, nReplaceLen - nSearchLen);\r\n if (fActiveSelectionMode <> smColumn) and (CaretY = ptEnd.Line) then\r\n begin\r\n Inc(ptEnd.Char, nReplaceLen - nSearchLen);\r\n BlockEnd := ptEnd;\r\n end;\r\n end;\r\n end;\r\n if not bReplaceAll then\r\n exit;\r\n end;\r\n // search next / previous line\r\n if bBackward then\r\n Dec(ptCurrent.Line)\r\n else\r\n Inc(ptCurrent.Line);\r\n end;\r\n finally\r\n if bReplaceAll and not bPrompt then DecPaintLock;\r\n if bEndUndoBlock then EndUndoBlock;\r\n DoOnPaintTransient( ttAfter );\r\n end;\r\nend;\r\n\r\nfunction TCustomSynEdit.IsPointInSelection(const Value: TBufferCoord): boolean;\r\nvar\r\n ptBegin, ptEnd: TBufferCoord;\r\nbegin\r\n ptBegin := BlockBegin;\r\n ptEnd := BlockEnd;\r\n if (Value.Line >= ptBegin.Line) and (Value.Line <= ptEnd.Line) and\r\n ((ptBegin.Line <> ptEnd.Line) or (ptBegin.Char <> ptEnd.Char)) then\r\n begin\r\n if fActiveSelectionMode = smLine then\r\n Result := True\r\n else if (fActiveSelectionMode = smColumn) then\r\n begin\r\n if (ptBegin.Char > ptEnd.Char) then\r\n Result := (Value.Char >= ptEnd.Char) and (Value.Char < ptBegin.Char)\r\n else if (ptBegin.Char < ptEnd.Char) then\r\n Result := (Value.Char >= ptBegin.Char) and (Value.Char < ptEnd.Char)\r\n else\r\n Result := False;\r\n end\r\n else\r\n Result := ((Value.Line > ptBegin.Line) or (Value.Char >= ptBegin.Char)) and\r\n ((Value.Line < ptEnd.Line) or (Value.Char < ptEnd.Char));\r\n end\r\n else\r\n Result := False;\r\nend;\r\n\r\nprocedure TCustomSynEdit.SetFocus;\r\nbegin\r\n if (fFocusList.Count > 0) then\r\n begin\r\n if TWinControl (fFocusList.Last).CanFocus then\r\n TWinControl (fFocusList.Last).SetFocus;\r\n exit;\r\n end;\r\n inherited;\r\nend;\r\n\r\nprocedure TCustomSynEdit.UpdateMouseCursor;\r\n\r\n{$IFDEF SYN_CLX}\r\n procedure SetCursor(aCursor: QCursorH);\r\n begin\r\n QWidget_setCursor(Handle, aCursor);\r\n end;\r\n{$ENDIF}\r\n\r\nvar\r\n ptCursor: TPoint;\r\n ptLineCol: TBufferCoord;\r\n iNewCursor: TCursor;\r\nbegin\r\n GetCursorPos(ptCursor);\r\n ptCursor := ScreenToClient(ptCursor);\r\n{$IFDEF SYN_CLX}\r\n //handle the scrollbars junction in the bottom-right corner\r\n if not PtInRect(ClientRect, ptCursor) then\r\n begin\r\n QWidget_setCursor(Handle, Screen.Cursors[crDefault]);\r\n Exit;\r\n end;\r\n{$ENDIF}\r\n if (ptCursor.X < fGutterWidth) then\r\n SetCursor(Screen.Cursors[fGutter.Cursor])\r\n else begin\r\n ptLineCol := DisplayToBufferPos(PixelsToRowColumn(ptCursor.X, ptCursor.Y));\r\n if (eoDragDropEditing in fOptions) and (not MouseCapture) and IsPointInSelection(ptLineCol) then\r\n iNewCursor := crArrow\r\n else\r\n iNewCursor := Cursor;\r\n if Assigned(OnMouseCursor) then\r\n OnMouseCursor(Self, ptLineCol, iNewCursor);\r\n fKbdHandler.ExecuteMouseCursor(Self, ptLineCol, iNewCursor);\r\n SetCursor(Screen.Cursors[iNewCursor]);\r\n end;\r\nend;\r\n\r\nprocedure TCustomSynEdit.BookMarkOptionsChanged(Sender: TObject);\r\nbegin\r\n InvalidateGutter;\r\nend;\r\n\r\nfunction TCustomSynEdit.GetOptions: TSynEditorOptions;\r\nbegin\r\n Result := fOptions;\r\nend;\r\n\r\nprocedure TCustomSynEdit.SetOptions(Value: TSynEditorOptions);\r\nconst\r\n ScrollOptions = [eoDisableScrollArrows,eoHideShowScrollbars,\r\n eoScrollPastEof,eoScrollPastEol];\r\nvar\r\n{$IFNDEF SYN_CLX}\r\n bSetDrag: Boolean;\r\n{$ENDIF}\r\n TmpBool: Boolean;\r\n bUpdateScroll: Boolean;\r\n vTempBlockBegin, vTempBlockEnd : TBufferCoord;\r\nbegin\r\n if (Value <> fOptions) then\r\n begin\r\n{$IFNDEF SYN_CLX}\r\n bSetDrag := (eoDropFiles in fOptions) <> (eoDropFiles in Value);\r\n{$ENDIF}\r\n\r\n if not (eoScrollPastEol in Options) then\r\n LeftChar := LeftChar;\r\n if not (eoScrollPastEof in Options) then\r\n TopLine := TopLine;\r\n\r\n bUpdateScroll := (Options * ScrollOptions) <> (Value * ScrollOptions);\r\n\r\n fOptions := Value;\r\n\r\n // constrain caret position to MaxScrollWidth if eoScrollPastEol is enabled\r\n InternalCaretXY := CaretXY;\r\n if (eoScrollPastEol in Options) then\r\n begin\r\n vTempBlockBegin := BlockBegin;\r\n vTempBlockEnd := BlockEnd;\r\n SetBlockBegin(vTempBlockBegin);\r\n SetBlockEnd(vTempBlockEnd);\r\n end;\r\n\r\n{$IFDEF SYN_CLX}\r\n{$ELSE}\r\n // (un)register HWND as drop target\r\n if bSetDrag and not (csDesigning in ComponentState) and HandleAllocated then\r\n DragAcceptFiles(Handle, (eoDropFiles in fOptions));\r\n{$ENDIF}\r\n TmpBool := eoShowSpecialChars in Value;\r\n if TmpBool <> fShowSpecChar then\r\n begin\r\n fShowSpecChar := TmpBool;\r\n Invalidate;\r\n end;\r\n if bUpdateScroll then\r\n UpdateScrollBars;\r\n end;\r\nend;\r\n\r\nprocedure TCustomSynEdit.SizeOrFontChanged(bFont: boolean);\r\nbegin\r\n if HandleAllocated and (fCharWidth <> 0) then\r\n begin\r\n fCharsInWindow := Max(ClientWidth - fGutterWidth - 2, 0) div fCharWidth;\r\n fLinesInWindow := ClientHeight div fTextHeight;\r\n if WordWrap then\r\n begin\r\n fWordWrapPlugin.DisplayChanged;\r\n Invalidate;\r\n end;\r\n if bFont then\r\n begin\r\n if Gutter.ShowLineNumbers then\r\n GutterChanged(Self)\r\n else\r\n UpdateScrollbars;\r\n InitializeCaret;\r\n Exclude(fStateFlags, sfCaretChanged);\r\n Invalidate;\r\n end\r\n else\r\n UpdateScrollbars;\r\n Exclude(fStateFlags, sfScrollbarChanged);\r\n if not (eoScrollPastEol in Options) then\r\n LeftChar := LeftChar;\r\n if not (eoScrollPastEof in Options) then\r\n TopLine := TopLine;\r\n end;\r\nend;\r\n\r\nprocedure TCustomSynEdit.MoveCaretHorz(DX: Integer; SelectionCommand: Boolean);\r\nvar\r\n ptO, ptDst: TBufferCoord;\r\n s: UnicodeString;\r\n nLineLen: Integer;\r\n bChangeY: Boolean;\r\n vCaretRowCol: TDisplayCoord;\r\nbegin\r\n if WordWrap then\r\n begin\r\n if DX > 0 then\r\n begin\r\n if fCaretAtEOL then\r\n begin\r\n fCaretAtEOL := False;\r\n UpdateLastCaretX;\r\n IncPaintLock;\r\n Include(fStateFlags, sfCaretChanged);\r\n DecPaintLock;\r\n Exit;\r\n end;\r\n end\r\n else\r\n begin // DX < 0. Handle ecLeft/ecPageLeft at BOL.\r\n if (not fCaretAtEOL) and (CaretX > 1) and (DisplayX = 1) then\r\n begin\r\n fCaretAtEOL := True;\r\n UpdateLastCaretX;\r\n if DisplayX > CharsInWindow +1 then\r\n SetInternalDisplayXY( DisplayCoord(CharsInWindow +1, DisplayY) )\r\n else begin\r\n IncPaintLock;\r\n Include(fStateFlags, sfCaretChanged);\r\n DecPaintLock;\r\n end;\r\n Exit;\r\n end;\r\n end;\r\n end;\r\n ptO := CaretXY;\r\n ptDst := ptO;\r\n s := LineText;\r\n nLineLen := Length(s);\r\n // only moving or selecting one char can change the line\r\n bChangeY := not (eoScrollPastEol in fOptions);\r\n if bChangeY and (DX = -1) and (ptO.Char = 1) and (ptO.Line > 1) then\r\n begin\r\n // end of previous line\r\n Dec(ptDst.Line);\r\n ptDst.Char := Length(Lines[ptDst.Line - 1]) + 1;\r\n end\r\n else if bChangeY and (DX = 1) and (ptO.Char > nLineLen) and (ptO.Line < Lines.Count) then\r\n begin\r\n // start of next line\r\n Inc(ptDst.Line);\r\n ptDst.Char := 1;\r\n end\r\n else begin\r\n ptDst.Char := Max(1, ptDst.Char + DX);\r\n // don't go past last char when ScrollPastEol option not set\r\n if (DX > 0) and bChangeY then\r\n ptDst.Char := Min(ptDst.Char, nLineLen + 1);\r\n end;\r\n // set caret and block begin / end\r\n MoveCaretAndSelection(fBlockBegin, ptDst, SelectionCommand);\r\n // if caret is beyond CharsInWindow move to next row (this means there are\r\n // spaces/tabs at the end of the row)\r\n if WordWrap and (DX > 0) and (CaretX < Length(LineText)) then\r\n begin\r\n vCaretRowCol := DisplayXY;\r\n if (vCaretRowCol.Column = 1) and (LineToRow(CaretY) <> vCaretRowCol.Row) then\r\n begin\r\n fCaretAtEOL := True;\r\n UpdateLastCaretX;\r\n end\r\n else if vCaretRowCol.Column > CharsInWindow +1 then\r\n begin\r\n Inc(vCaretRowCol.Row);\r\n vCaretRowCol.Column := 1;\r\n InternalCaretXY := DisplayToBufferPos(vCaretRowCol);\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TCustomSynEdit.MoveCaretVert(DY: Integer; SelectionCommand: Boolean);\r\nvar\r\n ptO, ptDst, vEOLTestPos: TDisplayCoord;\r\n vDstLineChar: TBufferCoord;\r\n SaveLastCaretX: Integer;\r\nbegin\r\n ptO := DisplayXY;\r\n ptDst := ptO;\r\n\r\n Inc(ptDst.Row, DY);\r\n if DY >= 0 then\r\n begin\r\n if RowToLine(ptDst.Row) > Lines.Count then\r\n ptDst.Row := Max(1, DisplayLineCount);\r\n end\r\n else begin\r\n if ptDst.Row < 1 then\r\n ptDst.Row := 1;\r\n end;\r\n\r\n if (ptO.Row <> ptDst.Row) then\r\n begin\r\n if eoKeepCaretX in Options then\r\n ptDst.Column := fLastCaretX;\r\n end;\r\n vDstLineChar := DisplayToBufferPos(ptDst);\r\n SaveLastCaretX := fLastCaretX;\r\n\r\n // set caret and block begin / end\r\n IncPaintLock;\r\n MoveCaretAndSelection(fBlockBegin, vDstLineChar, SelectionCommand);\r\n if WordWrap then\r\n begin\r\n vEOLTestPos := BufferToDisplayPos(vDstLineChar);\r\n fCaretAtEOL := (vEOLTestPos.Column = 1) and (vEOLTestPos.Row <> ptDst.Row);\r\n end;\r\n DecPaintLock;\r\n\r\n // Restore fLastCaretX after moving caret, since UpdateLastCaretX, called by\r\n // SetCaretXYEx, changes them. This is the one case where we don't want that.\r\n fLastCaretX := SaveLastCaretX;\r\nend;\r\n\r\nprocedure TCustomSynEdit.MoveCaretAndSelection(const ptBefore, ptAfter: TBufferCoord;\r\n SelectionCommand: Boolean);\r\nbegin\r\n if (eoGroupUndo in FOptions) and UndoList.CanUndo then\r\n fUndoList.AddGroupBreak;\r\n\r\n IncPaintLock;\r\n if SelectionCommand then\r\n begin\r\n if not SelAvail then\r\n SetBlockBegin(ptBefore);\r\n SetBlockEnd(ptAfter);\r\n end\r\n else\r\n SetBlockBegin(ptAfter);\r\n InternalCaretXY := ptAfter;\r\n DecPaintLock;\r\nend;\r\n\r\nprocedure TCustomSynEdit.SetCaretAndSelection(const ptCaret, ptBefore,\r\n ptAfter: TBufferCoord);\r\nvar\r\n vOldMode: TSynSelectionMode;\r\nbegin\r\n vOldMode := fActiveSelectionMode;\r\n IncPaintLock;\r\n try\r\n InternalCaretXY := ptCaret;\r\n SetBlockBegin(ptBefore);\r\n SetBlockEnd(ptAfter);\r\n finally\r\n ActiveSelectionMode := vOldMode;\r\n DecPaintLock;\r\n end;\r\nend;\r\n\r\nprocedure TCustomSynEdit.RecalcCharExtent;\r\nconst\r\n iFontStyles: array[0..3] of TFontStyles = ([], [fsItalic], [fsBold],\r\n [fsItalic, fsBold]);\r\nvar\r\n iHasStyle: array[0..3] of Boolean;\r\n cAttr: Integer;\r\n cStyle: Integer;\r\n iCurr: TFontStyles;\r\nbegin\r\n FillChar(iHasStyle, SizeOf(iHasStyle), 0);\r\n if Assigned(fHighlighter) and (fHighlighter.AttrCount > 0) then begin\r\n for cAttr := 0 to fHighlighter.AttrCount - 1 do\r\n begin\r\n iCurr := fHighlighter.Attribute[cAttr].Style * [fsItalic, fsBold];\r\n for cStyle := 0 to 3 do\r\n if iCurr = iFontStyles[cStyle] then\r\n begin\r\n iHasStyle[cStyle] := True;\r\n break;\r\n end;\r\n end;\r\n end\r\n else begin\r\n iCurr := Font.Style * [fsItalic, fsBold];\r\n for cStyle := 0 to 3 do\r\n if iCurr = iFontStyles[cStyle] then\r\n begin\r\n iHasStyle[cStyle] := True;\r\n break;\r\n end;\r\n end;\r\n\r\n fTextHeight := 0;\r\n fCharWidth := 0;\r\n fTextDrawer.BaseFont := Self.Font;\r\n for cStyle := 0 to 3 do\r\n if iHasStyle[cStyle] then\r\n begin\r\n fTextDrawer.BaseStyle := iFontStyles[cStyle];\r\n fTextHeight := Max(fTextHeight, fTextDrawer.CharHeight);\r\n fCharWidth := Max(fCharWidth, fTextDrawer.CharWidth);\r\n end;\r\n Inc(fTextHeight, fExtraLineSpacing);\r\nend;\r\n\r\nprocedure TCustomSynEdit.HighlighterAttrChanged(Sender: TObject);\r\nbegin\r\n RecalcCharExtent;\r\n if Sender is TSynCustomHighlighter then\r\n begin\r\n Lines.BeginUpdate;\r\n try\r\n ScanRanges;\r\n finally\r\n Lines.EndUpdate;\r\n end;\r\n end\r\n else\r\n Invalidate;\r\n SizeOrFontChanged(True);\r\nend;\r\n\r\nprocedure TCustomSynEdit.StatusChanged(AChanges: TSynStatusChanges);\r\nbegin\r\n fStatusChanges := fStatusChanges + AChanges;\r\n if PaintLock = 0 then\r\n DoOnStatusChange(fStatusChanges);\r\nend;\r\n\r\nprocedure TCustomSynEdit.DoCaseChange(const Cmd: TSynEditorCommand);\r\n\r\n function ToggleCase(const aStr: UnicodeString): UnicodeString;\r\n var\r\n i: Integer;\r\n sLower: UnicodeString;\r\n begin\r\n Result := SynWideUpperCase(aStr);\r\n sLower := SynWideLowerCase(aStr);\r\n for i := 1 to Length(aStr) do\r\n begin\r\n if Result[i] = aStr[i] then\r\n Result[i] := sLower[i];\r\n end;\r\n end;\r\n\r\nvar\r\n w: UnicodeString;\r\n oldCaret, oldBlockBegin, oldBlockEnd: TBufferCoord;\r\n bHadSel : Boolean;\r\nbegin\r\n Assert((Cmd >= ecUpperCase) and (Cmd <= ecToggleCaseBlock));\r\n if SelAvail then\r\n begin\r\n bHadSel := True;\r\n oldBlockBegin := BlockBegin;\r\n oldBlockEnd := BlockEnd;\r\n end\r\n else begin\r\n bHadSel := False;\r\n end;\r\n oldCaret := CaretXY;\r\n try\r\n if Cmd < ecUpperCaseBlock then\r\n begin\r\n { word commands }\r\n SetSelWord;\r\n if SelText = '' then\r\n begin\r\n { searches a previous word }\r\n InternalCaretXY := PrevWordPos;\r\n SetSelWord;\r\n if SelText = '' then\r\n begin\r\n { try once more since PrevWordPos may have failed last time.\r\n (PrevWordPos \"points\" to the end of the previous line instead of the\r\n beggining of the previous word if invoked (e.g.) when CaretX = 1) }\r\n InternalCaretXY := PrevWordPos;\r\n SetSelWord;\r\n end;\r\n end;\r\n end\r\n else begin\r\n { block commands }\r\n if not SelAvail then\r\n begin\r\n if CaretX <= Length(LineText) then\r\n MoveCaretHorz(1, True)\r\n else if CaretY < Lines.Count then\r\n InternalCaretXY := BufferCoord(1, CaretY +1);\r\n end;\r\n end;\r\n\r\n w := SelText;\r\n if w <> '' then\r\n begin\r\n case Cmd of\r\n ecUpperCase, ecUpperCaseBlock:\r\n w := SynWideUpperCase(w);\r\n ecLowerCase, ecLowerCaseBlock:\r\n w := SynWideLowerCase(w);\r\n ecToggleCase, ecToggleCaseBlock:\r\n w := ToggleCase(w);\r\n ecTitleCase:\r\n w := SynWideUpperCase(w[1]) + SynWideLowerCase(Copy(w, 2, Length(w)));\r\n end;\r\n BeginUndoBlock;\r\n try\r\n if bHadSel then\r\n fUndoList.AddChange(crSelection, oldBlockBegin, oldBlockEnd, '', fActiveSelectionMode)\r\n else\r\n fUndoList.AddChange(crSelection, oldCaret, oldCaret, '', fActiveSelectionMode);\r\n fUndoList.AddChange(crCaret, oldCaret, oldCaret, '', fActiveSelectionMode);\r\n SelText := w;\r\n finally\r\n EndUndoBlock;\r\n end;\r\n end;\r\n finally\r\n { \"word\" commands do not restore Selection }\r\n if bHadSel and (Cmd >= ecUpperCaseBlock) then\r\n begin\r\n BlockBegin := oldBlockBegin;\r\n BlockEnd := oldBlockEnd;\r\n end;\r\n { \"block\" commands with empty Selection move the Caret }\r\n if bHadSel or (Cmd < ecUpperCaseBlock) then\r\n CaretXY := oldCaret;\r\n end;\r\nend;\r\n\r\nprocedure TCustomSynEdit.DoTabKey;\r\nvar\r\n StartOfBlock: TBufferCoord;\r\n i, MinLen, iLine: integer;\r\n PrevLine, Spaces: UnicodeString;\r\n p: PWideChar;\r\n NewCaretX: integer;\r\n ChangeScroll: Boolean;\r\n nPhysX, nDistanceToTab, nSpacesToNextTabStop : Integer;\r\n OldSelTabLine, vIgnoreSmartTabs: Boolean;\r\nbegin\r\n // Provide Visual Studio like block indenting\r\n OldSelTabLine := SelTabLine;\r\n if (eoTabIndent in Options) and ((SelTabBlock) or (OldSelTabLine)) then\r\n begin\r\n DoBlockIndent;\r\n if OldSelTabLine then\r\n begin\r\n if fBlockBegin.Char < fBlockEnd.Char then\r\n FBlockBegin.Char := 1\r\n else\r\n fBlockEnd.Char := 1;\r\n end;\r\n exit;\r\n end;\r\n i := 0;\r\n iLine := 0;\r\n MinLen := 0;\r\n vIgnoreSmartTabs := False;\r\n if eoSmartTabs in fOptions then\r\n begin\r\n iLine := CaretY - 1;\r\n if (iLine > 0) and (iLine < Lines.Count) then\r\n begin\r\n Dec(iLine);\r\n repeat\r\n //todo: rethink it\r\n MinLen := DisplayToBufferPos(DisplayCoord(\r\n BufferToDisplayPos(CaretXY).Column, LineToRow(iLine + 1))).Char;\r\n PrevLine := Lines[iLine];\r\n if (Length(PrevLine) >= MinLen) then begin\r\n p := @PrevLine[MinLen];\r\n // scan over non-whitespaces\r\n repeat\r\n if (p^ = #9) or (p^ = #32) then break;\r\n Inc(i);\r\n Inc(p);\r\n until p^ = #0;\r\n // scan over whitespaces\r\n if p^ <> #0 then\r\n repeat\r\n if (p^ <> #9) and (p^ <> #32) then break;\r\n Inc(i);\r\n Inc(p);\r\n until p^ = #0;\r\n break;\r\n end;\r\n Dec(iLine);\r\n until iLine < 0;\r\n end\r\n else\r\n vIgnoreSmartTabs := True;\r\n end;\r\n fUndoList.BeginBlock;\r\n try\r\n if SelAvail then\r\n begin\r\n fUndoList.AddChange(crDelete, fBlockBegin, fBlockEnd, SelText,\r\n fActiveSelectionMode);\r\n SetSelTextPrimitive('');\r\n end;\r\n StartOfBlock := CaretXY;\r\n\r\n if i = 0 then\r\n begin\r\n if (eoTabsToSpaces in fOptions) then\r\n begin\r\n i := TabWidth - (StartOfBlock.Char - 1) mod TabWidth;\r\n if i = 0 then\r\n i := TabWidth;\r\n end\r\n else\r\n i := TabWidth;\r\n end;\r\n\r\n if eoTabsToSpaces in fOptions then\r\n begin\r\n Spaces := UnicodeStringOfChar(#32, i);\r\n NewCaretX := StartOfBlock.Char + i;\r\n end\r\n else if (eoTrimTrailingSpaces in Options) and (StartOfBlock.Char > Length(LineText)) then\r\n begin\r\n // work-around for trimming Tabs\r\n nPhysX := BufferToDisplayPos(CaretXY).Column;\r\n if (eoSmartTabs in fOptions) and not vIgnoreSmartTabs and (iLine > -1) then\r\n begin\r\n i := BufferToDisplayPos( BufferCoord(MinLen+i, iLine+1) ).Column;\r\n nDistanceToTab := i - nPhysX;\r\n end\r\n else\r\n nDistanceToTab := TabWidth - ((nPhysX - 1) mod TabWidth);\r\n NewCaretX := StartOfBlock.Char + nDistanceToTab;\r\n end\r\n else begin\r\n if (eoSmartTabs in fOptions) and not vIgnoreSmartTabs and (iLine > -1) then\r\n begin\r\n Spaces := Copy(fLines[CaretXY.Line - 1], 1, CaretXY.Char - 1);\r\n while Pos(#9, Spaces) > 0 do\r\n Delete(Spaces, Pos(#9, Spaces), 1);\r\n Spaces := WideTrim(Spaces);\r\n\r\n //smart tabs are only in the front of the line *NOT IN THE MIDDLE*\r\n if Spaces = '' then\r\n begin\r\n i := BufferToDisplayPos( BufferCoord(MinLen+i, iLine+1) ).Column;\r\n\r\n nPhysX := DisplayX;\r\n nDistanceToTab := i - nPhysX;\r\n nSpacesToNextTabStop := TabWidth - ((nPhysX - 1) mod TabWidth);\r\n if nSpacesToNextTabStop <= nDistanceToTab then begin\r\n Spaces := #9;\r\n Dec(nDistanceToTab, nSpacesToNextTabStop);\r\n end;\r\n while nDistanceToTab >= TabWidth do begin\r\n Spaces := Spaces + #9;\r\n Dec(nDistanceToTab, TabWidth);\r\n end;\r\n if nDistanceToTab > 0 then\r\n Spaces := Spaces + UnicodeStringOfChar(#32, nDistanceToTab);\r\n end else\r\n Spaces := #9;\r\n end\r\n else begin\r\n Spaces := #9;\r\n end;\r\n if (eoTrimTrailingSpaces in Options) and (Length(TrimTrailingSpaces(LineText)) = 0) then\r\n NewCaretX := StartOfBlock.Char + GetExpandedLength(Spaces, TabWidth)\r\n else\r\n NewCaretX := StartOfBlock.Char + Length(Spaces);\r\n end;\r\n\r\n SetSelTextPrimitive(Spaces);\r\n // Undo is already handled in SetSelText when SelectionMode is Column\r\n if fActiveSelectionMode <> smColumn then\r\n begin\r\n fUndoList.AddChange(crInsert, StartOfBlock, CaretXY, SelText,\r\n fActiveSelectionMode);\r\n end;\r\n finally\r\n fUndoList.EndBlock;\r\n end;\r\n\r\n ChangeScroll := not(eoScrollPastEol in fOptions);\r\n try\r\n Include(fOptions, eoScrollPastEol);\r\n InternalCaretX := NewCaretX;\r\n finally\r\n if ChangeScroll then\r\n Exclude(fOptions, eoScrollPastEol);\r\n end;\r\n\r\n EnsureCursorPosVisible;\r\nend;\r\n\r\nprocedure TCustomSynEdit.DoShiftTabKey;\r\n// shift-tab key handling\r\nvar\r\n NewX: Integer;\r\n Line: UnicodeString;\r\n LineLen: Integer;\r\n DestX: Integer;\r\n\r\n MaxLen, iLine: Integer;\r\n PrevLine, OldSelText: UnicodeString;\r\n p: PWideChar;\r\n OldCaretXY: TBufferCoord;\r\n ChangeScroll: Boolean;\r\nbegin\r\n // Provide Visual Studio like block indenting\r\n if (eoTabIndent in Options) and ((SelTabBlock) or (SelTabLine)) then\r\n begin\r\n DoBlockUnIndent;\r\n exit;\r\n end;\r\n\r\n NewX := CaretX;\r\n\r\n if (NewX <> 1) and (eoSmartTabs in fOptions) then\r\n begin\r\n iLine := CaretY - 1;\r\n if (iLine > 0) and (iLine < Lines.Count) then\r\n begin\r\n Dec(iLine);\r\n MaxLen := CaretX - 1;\r\n repeat\r\n PrevLine := Lines[iLine];\r\n if (Length(PrevLine) >= MaxLen) then\r\n begin\r\n p := @PrevLine[MaxLen];\r\n // scan over whitespaces\r\n repeat\r\n if p^ <> #32 then break;\r\n Dec(NewX);\r\n Dec(p);\r\n until NewX = 1;\r\n // scan over non-whitespaces\r\n if NewX <> 1 then\r\n repeat\r\n if p^ = #32 then break;\r\n Dec(NewX);\r\n Dec(p);\r\n until NewX = 1;\r\n break;\r\n end;\r\n Dec(iLine);\r\n until iLine < 0;\r\n end;\r\n end;\r\n\r\n if NewX = CaretX then\r\n begin\r\n Line := LineText;\r\n LineLen := Length(Line);\r\n\r\n // find real un-tab position\r\n\r\n DestX := ((CaretX - 2) div TabWidth) * TabWidth + 1;\r\n if NewX > LineLen then\r\n NewX := DestX\r\n else if (NewX > DestX) and (Line[NewX - 1] = #9) then\r\n dec(NewX)\r\n else begin\r\n while (NewX > DestX) and ((NewX - 1 > LineLen) or (Line[NewX - 1] = #32)) do\r\n dec(NewX);\r\n end;\r\n end;\r\n\r\n // perform un-tab\r\n if (NewX <> CaretX) then\r\n begin\r\n SetBlockBegin(BufferCoord(NewX, CaretY));\r\n SetBlockEnd(CaretXY);\r\n OldCaretXY := CaretXY;\r\n\r\n OldSelText := SelText;\r\n SetSelTextPrimitive('');\r\n\r\n fUndoList.AddChange(crSilentDelete, BufferCoord(NewX, CaretY),\r\n OldCaretXY, OldSelText, smNormal);\r\n\r\n // KV\r\n ChangeScroll := not(eoScrollPastEol in fOptions);\r\n try\r\n Include(fOptions, eoScrollPastEol);\r\n InternalCaretX := NewX;\r\n finally\r\n if ChangeScroll then\r\n Exclude(fOptions, eoScrollPastEol);\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TCustomSynEdit.DoHomeKey(Selection: Boolean);\r\n\r\n function LastCharInRow: Integer;\r\n var\r\n vPos: TDisplayCoord;\r\n begin\r\n if fLines.Count = 0 then\r\n Result := 1\r\n else\r\n begin\r\n vPos := DisplayXY;\r\n vPos.Column := Min(CharsInWindow, fWordWrapPlugin.GetRowLength(vPos.Row) + 1);\r\n Result := DisplayToBufferPos(vPos).Char;\r\n end;\r\n end;\r\n\r\nvar\r\n newX: Integer;\r\n first_nonblank: Integer;\r\n s: UnicodeString;\r\n vNewPos: TDisplayCoord;\r\n vMaxX: Integer;\r\nbegin\r\n // home key enhancement\r\n if (eoEnhanceHomeKey in fOptions) and (LineToRow(CaretY) = DisplayY) then\r\n begin\r\n s := fLines[CaretXY.Line - 1];\r\n\r\n first_nonblank := 1;\r\n if WordWrap then\r\n vMaxX := LastCharInRow() -1\r\n else\r\n vMaxX := Length(s);\r\n while (first_nonblank <= vMaxX) and\r\n CharInSet(s[first_nonblank], [#32, #9])\r\n do\r\n inc(first_nonblank);\r\n dec(first_nonblank);\r\n\r\n newX := CaretXY.Char - 1;\r\n\r\n if (newX > first_nonblank) or (newX = 0) then\r\n newX := first_nonblank + 1\r\n else\r\n newX := 1;\r\n end\r\n else\r\n newX := 1;\r\n\r\n if WordWrap then\r\n begin\r\n vNewPos.Row := DisplayY;\r\n vNewPos.Column := BufferToDisplayPos(BufferCoord(newX, CaretY)).Column;\r\n MoveCaretAndSelection(CaretXY, DisplayToBufferPos(vNewPos), Selection);\r\n end\r\n else\r\n MoveCaretAndSelection(CaretXY, BufferCoord(newX, CaretY), Selection);\r\nend;\r\n\r\nprocedure TCustomSynEdit.DoEndKey(Selection: Boolean);\r\n\r\n function CaretInLastRow: Boolean;\r\n var\r\n vLastRow: Integer;\r\n begin\r\n if not WordWrap then\r\n Result := True\r\n else\r\n begin\r\n vLastRow := LineToRow(CaretY + 1) - 1;\r\n // This check allows good behaviour with empty rows (this can be useful in a diff app ;-)\r\n while (vLastRow > 1)\r\n and (fWordWrapPlugin.GetRowLength(vLastRow) = 0)\r\n and (RowToLine(vLastRow) = CaretY) do\r\n begin\r\n Dec(vLastRow);\r\n end;\r\n Result := DisplayY = vLastRow;\r\n end;\r\n end;\r\n\r\n function FirstCharInRow: Integer;\r\n var\r\n vPos: TDisplayCoord;\r\n begin\r\n vPos.Row := DisplayY;\r\n vPos.Column := 1;\r\n Result := DisplayToBufferPos(vPos).Char;\r\n end;\r\n\r\nvar\r\n vText: UnicodeString;\r\n vLastNonBlank: Integer;\r\n vNewX: Integer;\r\n vNewCaret: TDisplayCoord;\r\n vMinX: Integer;\r\n vEnhance: Boolean;\r\nbegin\r\n if (eoEnhanceEndKey in fOptions) and CaretInLastRow then\r\n begin\r\n vEnhance := True;\r\n vText := LineText;\r\n vLastNonBlank := Length(vText);\r\n if WordWrap then\r\n vMinX := FirstCharInRow() - 1\r\n else\r\n vMinX := 0;\r\n while (vLastNonBlank > vMinX) and CharInSet(vText[vLastNonBlank], [#32, #9]) do\r\n Dec(vLastNonBlank);\r\n\r\n vNewX := CaretX - 1;\r\n if vNewX = vLastNonBlank then\r\n vNewX := Length(LineText) + 1\r\n else\r\n vNewX := vLastNonBlank + 1;\r\n end\r\n else\r\n begin\r\n vNewX := Length(LineText) + 1;\r\n vEnhance := False;\r\n end;\r\n\r\n if WordWrap then\r\n begin\r\n vNewCaret.Row := DisplayY;\r\n if vEnhance then\r\n vNewCaret.Column := BufferToDisplayPos(BufferCoord(vNewX, CaretY)).Column\r\n else\r\n vNewCaret.Column := fWordWrapPlugin.GetRowLength(vNewCaret.Row) + 1;\r\n vNewCaret.Column := Min(CharsInWindow + 1, vNewCaret.Column);\r\n MoveCaretAndSelection(CaretXY, DisplayToBufferPos(vNewCaret), Selection);\r\n // Updates fCaretAtEOL flag.\r\n SetInternalDisplayXY(vNewCaret);\r\n end\r\n else\r\n MoveCaretAndSelection(CaretXY,\r\n BufferCoord(vNewX, CaretY), Selection);\r\nend;\r\n\r\n{$IFNDEF SYN_CLX}\r\nprocedure TCustomSynEdit.CreateWnd;\r\nbegin\r\n inherited;\r\n\r\n{$IFNDEF UNICODE}\r\n if not (csDesigning in ComponentState) then\r\n begin\r\n // \"redefine\" window-procedure to get Unicode messages\r\n if Win32PlatformIsUnicode then\r\n SetWindowLongW(Handle, GWL_WNDPROC, Integer(GetWindowLongA(Handle, GWL_WNDPROC)));\r\n end;\r\n{$ENDIF}\r\n\r\n if (eoDropFiles in fOptions) and not (csDesigning in ComponentState) then\r\n DragAcceptFiles(Handle, True);\r\n\r\n UpdateScrollBars;\r\nend;\r\n\r\nprocedure TCustomSynEdit.DestroyWnd;\r\nbegin\r\n if (eoDropFiles in fOptions) and not (csDesigning in ComponentState) then\r\n DragAcceptFiles(Handle, False);\r\n\r\n{$IFNDEF UNICODE}\r\n if not (csDesigning in ComponentState) then\r\n begin\r\n // restore window-procedure to what VCL expects\r\n if Win32PlatformIsUnicode then\r\n SetWindowLongA(Handle, GWL_WNDPROC, Integer(GetWindowLongW(Handle, GWL_WNDPROC)));\r\n end;\r\n{$ENDIF}\r\n\r\n{$IFDEF UNICODE}\r\n // assign WindowText here, otherwise the VCL will call GetText twice\r\n if WindowText = nil then\r\n WindowText := Lines.GetText;\r\n{$ENDIF}\r\n inherited;\r\nend;\r\n\r\nprocedure TCustomSynEdit.InvalidateRect(const aRect: TRect; aErase: Boolean);\r\nbegin\r\n Windows.InvalidateRect(Handle, @aRect, aErase);\r\nend;\r\n{$ENDIF}\r\n\r\nprocedure TCustomSynEdit.DoBlockIndent;\r\nvar\r\n OrgCaretPos: TBufferCoord;\r\n BB, BE: TBufferCoord;\r\n Run, StrToInsert: PWideChar;\r\n e, x, i, InsertStrLen: Integer;\r\n Spaces: UnicodeString;\r\n OrgSelectionMode: TSynSelectionMode;\r\n InsertionPos: TBufferCoord;\r\nbegin\r\n OrgSelectionMode := fActiveSelectionMode;\r\n OrgCaretPos := CaretXY;\r\n\r\n StrToInsert := nil;\r\n if SelAvail then\r\n try\r\n // keep current selection detail\r\n BB := BlockBegin;\r\n BE := BlockEnd;\r\n\r\n // build text to insert\r\n if (BE.Char = 1) then\r\n begin\r\n e := BE.Line - 1;\r\n x := 1;\r\n end\r\n else begin\r\n e := BE.Line;\r\n if eoTabsToSpaces in Options then\r\n x := CaretX + FTabWidth\r\n else x := CaretX + 1;\r\n end;\r\n if (eoTabsToSpaces in Options) then\r\n begin\r\n InsertStrLen := (FTabWidth + 2) * (e - BB.Line) + FTabWidth + 1;\r\n // chars per line * lines-1 + last line + null char\r\n StrToInsert := WStrAlloc(InsertStrLen);\r\n Run := StrToInsert;\r\n Spaces := UnicodeStringOfChar(#32, FTabWidth);\r\n end\r\n else begin\r\n InsertStrLen:= 3 * (e - BB.Line) + 2;\r\n // #9#13#10 * lines-1 + (last line's #9 + null char)\r\n StrToInsert := WStrAlloc(InsertStrLen);\r\n Run := StrToInsert;\r\n Spaces := #9;\r\n end;\r\n for i := BB.Line to e-1 do\r\n begin\r\n WStrCopy(Run, PWideChar(Spaces + #13#10));\r\n Inc(Run, Length(spaces) + 2);\r\n end;\r\n WStrCopy(Run, PWideChar(Spaces));\r\n\r\n fUndoList.BeginBlock;\r\n try\r\n InsertionPos.Line := BB.Line;\r\n if fActiveSelectionMode = smColumn then\r\n InsertionPos.Char := Min(BB.Char, BE.Char)\r\n else\r\n InsertionPos.Char := 1;\r\n InsertBlock(InsertionPos, InsertionPos, StrToInsert, True);\r\n fUndoList.AddChange(crIndent, BB, BE, '', smColumn);\r\n //We need to save the position of the end block for redo\r\n fUndoList.AddChange(crIndent,\r\n BufferCoord(BB.Char + length(Spaces), BB.Line),\r\n BufferCoord(BE.Char + length(Spaces), BE.Line),\r\n '', smColumn);\r\n finally\r\n fUndoList.EndBlock;\r\n end;\r\n\r\n //adjust the x position of orgcaretpos appropriately\r\n OrgCaretPos.Char := X;\r\n finally\r\n if BE.Char > 1 then\r\n Inc(BE.Char, Length(Spaces));\r\n WStrDispose(StrToInsert);\r\n SetCaretAndSelection(OrgCaretPos,\r\n BufferCoord(BB.Char + Length(Spaces), BB.Line), BE);\r\n ActiveSelectionMode := OrgSelectionMode;\r\n end;\r\nend;\r\n\r\nprocedure TCustomSynEdit.DoBlockUnindent;\r\nvar\r\n OrgCaretPos,\r\n BB, BE: TBufferCoord;\r\n Line, Run,\r\n FullStrToDelete,\r\n StrToDelete: PWideChar;\r\n Len, x, StrToDeleteLen, i, TmpDelLen, FirstIndent, LastIndent, e: Integer;\r\n TempString: UnicodeString;\r\n OrgSelectionMode: TSynSelectionMode;\r\n SomethingToDelete: Boolean;\r\n\r\n function GetDelLen: Integer;\r\n var\r\n Run: PWideChar;\r\n begin\r\n Result := 0;\r\n Run := Line;\r\n //Take care of tab character\r\n if Run[0] = #9 then\r\n begin\r\n Result := 1;\r\n SomethingToDelete := True;\r\n exit;\r\n end;\r\n //Deal with compound tabwidths Sometimes they have TabChars after a few\r\n //spaces, yet we need to delete the whole tab width even though the char\r\n //count might not be FTabWidth because of the TabChar\r\n while (Run[0] = #32) and (Result < FTabWidth) do\r\n begin\r\n Inc(Result);\r\n Inc(Run);\r\n SomethingToDelete := True;\r\n end;\r\n if (Run[0] = #9) and (Result < FTabWidth) then\r\n Inc(Result);\r\n end;\r\n\r\nbegin\r\n OrgSelectionMode := fActiveSelectionMode;\r\n Len := 0;\r\n LastIndent := 0;\r\n if SelAvail then\r\n begin\r\n // store current selection detail\r\n BB := BlockBegin;\r\n BE := BlockEnd;\r\n OrgCaretPos := CaretXY;\r\n x := fCaretX;\r\n\r\n // convert selection to complete lines\r\n if BE.Char = 1 then\r\n e := BE.Line - 1\r\n else\r\n e := BE.Line;\r\n\r\n // build string to delete\r\n StrToDeleteLen := (FTabWidth + 2) * (e - BB.Line) + FTabWidth + 1;\r\n // chars per line * lines-1 + last line + null char\r\n StrToDelete := WStrAlloc(StrToDeleteLen);\r\n StrToDelete[0] := #0;\r\n SomethingToDelete := False;\r\n for i := BB.Line to e-1 do\r\n begin\r\n Line := PWideChar(Lines[i - 1]);\r\n //'Line' is 0-based, 'BB.x' is 1-based, so the '-1'\r\n //And must not increment 'Line' pointer by more than its 'Length'\r\n if fActiveSelectionMode = smColumn then\r\n Inc(Line, MinIntValue([BB.Char - 1, BE.Char - 1, Length(Lines[i - 1])]));\r\n //Instead of doing a UnicodeStringOfChar, we need to get *exactly* what was\r\n //being deleted incase there is a TabChar\r\n TmpDelLen := GetDelLen;\r\n WStrCat(StrToDelete, PWideChar(Copy(Line, 1, TmpDelLen)));\r\n WStrCat(StrToDelete, PWideChar(UnicodeString(#13#10)));\r\n if (fCaretY = i) and (x <> 1) then\r\n x := x - TmpDelLen;\r\n end;\r\n Line := PWideChar(Lines[e - 1]);\r\n if fActiveSelectionMode = smColumn then\r\n Inc(Line, MinIntValue([BB.Char - 1, BE.Char - 1, Length(Lines[e - 1])]));\r\n TmpDelLen := GetDelLen;\r\n WStrCat(StrToDelete, PWideChar(Copy(Line, 1, TmpDelLen)));\r\n if (fCaretY = e) and (x <> 1) then\r\n x := x - TmpDelLen;\r\n\r\n FirstIndent := -1;\r\n FullStrToDelete := nil;\r\n // Delete string\r\n if SomethingToDelete then\r\n begin\r\n FullStrToDelete := StrToDelete;\r\n InternalCaretY := BB.Line;\r\n if fActiveSelectionMode <> smColumn then\r\n i := 1\r\n else\r\n i := Min(BB.Char, BE.Char);\r\n repeat\r\n Run := GetEOL(StrToDelete);\r\n if Run <> StrToDelete then\r\n begin\r\n Len := Run - StrToDelete;\r\n if FirstIndent = -1 then\r\n FirstIndent := Len;\r\n if Len > 0 then\r\n begin\r\n TempString := Lines[CaretY - 1];\r\n Delete(TempString, i, Len);\r\n Lines[CaretY - 1] := TempString;\r\n end;\r\n end;\r\n if Run^ = #13 then\r\n begin\r\n Inc(Run);\r\n if Run^ = #10 then\r\n Inc(Run);\r\n Inc(fCaretY);\r\n end;\r\n StrToDelete := Run;\r\n until Run^ = #0;\r\n LastIndent := Len;\r\n fUndoList.AddChange(crUnindent, BB, BE, FullStrToDelete, fActiveSelectionMode);\r\n end;\r\n // restore selection\r\n if FirstIndent = -1 then\r\n FirstIndent := 0;\r\n //adjust the x position of orgcaretpos appropriately\r\n if fActiveSelectionMode = smColumn then\r\n SetCaretAndSelection(OrgCaretPos, BB, BE)\r\n else\r\n begin\r\n OrgCaretPos.Char := X;\r\n Dec(BB.Char, FirstIndent);\r\n Dec(BE.Char, LastIndent);\r\n SetCaretAndSelection(OrgCaretPos, BB, BE);\r\n end;\r\n ActiveSelectionMode := OrgSelectionMode;\r\n if FullStrToDelete <> nil then\r\n WStrDispose(FullStrToDelete)\r\n else\r\n WStrDispose(StrToDelete);\r\n end;\r\nend;\r\n\r\n{$IFDEF SYN_COMPILER_4_UP}\r\nfunction TCustomSynEdit.ExecuteAction(Action: TBasicAction): Boolean;\r\nbegin\r\n if Action is TEditAction then\r\n begin\r\n Result := Focused;\r\n if Result then\r\n begin\r\n if Action is TEditCut then\r\n CommandProcessor(ecCut, ' ', nil)\r\n else if Action is TEditCopy then\r\n CommandProcessor(ecCopy, ' ', nil)\r\n else if Action is TEditPaste then\r\n CommandProcessor(ecPaste, ' ', nil)\r\n{$IFDEF SYN_COMPILER_5_UP}\r\n else if Action is TEditDelete then\r\n begin\r\n if SelAvail then\r\n ClearSelection\r\n else\r\n CommandProcessor(ecDeleteChar, ' ', nil)\r\n end\r\n{$IFDEF SYN_CLX}\r\n{$ELSE}\r\n else if Action is TEditUndo then\r\n CommandProcessor(ecUndo, ' ', nil)\r\n{$ENDIF}\r\n else if Action is TEditSelectAll then\r\n CommandProcessor(ecSelectAll, ' ', nil);\r\n{$ENDIF}\r\n end\r\n end\r\n{$IFDEF SYN_COMPILER_6_UP}\r\n else if Action is TSearchAction then\r\n begin\r\n Result := Focused;\r\n if Action is TSearchFindFirst then\r\n DoSearchFindFirstExecute(TSearchFindFirst(Action))\r\n else if Action is TSearchFind then\r\n DoSearchFindExecute(TSearchFind(Action))\r\n else if Action is TSearchReplace then\r\n DoSearchReplaceExecute(TSearchReplace(Action));\r\n end\r\n else if Action is TSearchFindNext then\r\n begin\r\n Result := Focused;\r\n DoSearchFindNextExecute(TSearchFindNext(Action))\r\n end\r\n{$ENDIF}\r\n else\r\n Result := inherited ExecuteAction(Action);\r\nend;\r\n\r\nfunction TCustomSynEdit.UpdateAction(Action: TBasicAction): Boolean;\r\nbegin\r\n if Action is TEditAction then\r\n begin\r\n Result := Focused;\r\n if Result then\r\n begin\r\n if Action is TEditCut then\r\n TEditAction(Action).Enabled := SelAvail and not ReadOnly\r\n else if Action is TEditCopy then\r\n TEditAction(Action).Enabled := SelAvail\r\n else if Action is TEditPaste then\r\n TEditAction(Action).Enabled := CanPaste\r\n{$IFDEF SYN_COMPILER_5_UP}\r\n else if Action is TEditDelete then\r\n TEditAction(Action).Enabled := not ReadOnly\r\n{$IFDEF SYN_CLX}\r\n{$ELSE}\r\n else if Action is TEditUndo then\r\n TEditAction(Action).Enabled := CanUndo\r\n{$ENDIF}\r\n else if Action is TEditSelectAll then\r\n TEditAction(Action).Enabled := True;\r\n{$ENDIF}\r\n end;\r\n{$IFDEF SYN_COMPILER_6_UP}\r\n end else if Action is TSearchAction then\r\n begin\r\n Result := Focused;\r\n if Result then\r\n begin\r\n if Action is TSearchFindFirst then\r\n TSearchAction(Action).Enabled := (Text<>'') and assigned(fSearchEngine)\r\n else if Action is TSearchFind then\r\n TSearchAction(Action).Enabled := (Text<>'') and assigned(fSearchEngine)\r\n else if Action is TSearchReplace then\r\n TSearchAction(Action).Enabled := (Text<>'') and assigned(fSearchEngine);\r\n end;\r\n end else if Action is TSearchFindNext then\r\n begin\r\n Result := Focused;\r\n if Result then\r\n TSearchAction(Action).Enabled := (Text<>'')\r\n and (TSearchFindNext(Action).SearchFind <> nil)\r\n and (TSearchFindNext(Action).SearchFind.Dialog.FindText <> '');\r\n{$ENDIF}\r\n end\r\n else\r\n Result := inherited UpdateAction(Action);\r\nend;\r\n{$ENDIF}\r\n\r\nprocedure TCustomSynEdit.SetModified(Value: Boolean);\r\nbegin\r\n if Value <> fModified then begin\r\n fModified := Value;\r\n if (eoGroupUndo in Options) and (not Value) and UndoList.CanUndo then\r\n UndoList.AddGroupBreak;\r\n UndoList.InitialState := not Value;\r\n StatusChanged([scModified]);\r\n end;\r\nend;\r\n\r\nfunction TCustomSynEdit.DoOnSpecialLineColors(Line: Integer; var Foreground,\r\n Background: TColor): Boolean;\r\nbegin\r\n Result := False;\r\n if Assigned(fOnSpecialLineColors) then\r\n fOnSpecialLineColors(Self, Line, Result, Foreground, Background);\r\nend;\r\n\r\nprocedure TCustomSynEdit.InvalidateLine(Line: Integer);\r\nvar\r\n rcInval: TRect;\r\nbegin\r\n if (not HandleAllocated) or (Line < 1) or (Line > Lines.Count) or (not Visible) then\r\n Exit;\r\n\r\n if WordWrap then\r\n begin\r\n InvalidateLines(Line, Line);\r\n Exit;\r\n end;\r\n\r\n if (Line >= TopLine) and (Line <= TopLine + LinesInWindow) then\r\n begin\r\n // invalidate text area of this line\r\n rcInval := Rect(fGutterWidth, fTextHeight * (Line - TopLine), ClientWidth, 0);\r\n rcInval.Bottom := rcInval.Top + fTextHeight;\r\n{$IFDEF SYN_CLX}\r\n with GetClientRect do\r\n OffsetRect(rcInval, Left, Top);\r\n{$ENDIF}\r\n if sfLinesChanging in fStateFlags then\r\n UnionRect(fInvalidateRect, fInvalidateRect, rcInval)\r\n else\r\n InvalidateRect(rcInval, False);\r\n end;\r\nend;\r\n\r\nfunction TCustomSynEdit.GetReadOnly: Boolean;\r\nbegin\r\n Result := fReadOnly;\r\nend;\r\n\r\nprocedure TCustomSynEdit.SetReadOnly(Value: Boolean);\r\nbegin\r\n if fReadOnly <> Value then\r\n begin\r\n fReadOnly := Value;\r\n StatusChanged([scReadOnly]);\r\n end;\r\nend;\r\n\r\nprocedure TCustomSynEdit.FindMatchingBracket;\r\nbegin\r\n InternalCaretXY := GetMatchingBracket;\r\nend;\r\n\r\nfunction TCustomSynEdit.GetMatchingBracket: TBufferCoord;\r\nbegin\r\n Result := GetMatchingBracketEx(CaretXY);\r\nend;\r\n\r\nfunction TCustomSynEdit.GetMatchingBracketEx(const APoint: TBufferCoord): TBufferCoord;\r\nconst\r\n Brackets: array[0..7] of WideChar = ('(', ')', '[', ']', '{', '}', '<', '>');\r\nvar\r\n Line: UnicodeString;\r\n i, PosX, PosY, Len: Integer;\r\n Test, BracketInc, BracketDec: WideChar;\r\n NumBrackets: Integer;\r\n vDummy: UnicodeString;\r\n attr: TSynHighlighterAttributes;\r\n p: TBufferCoord;\r\n isCommentOrString: Boolean;\r\nbegin\r\n Result.Char := 0;\r\n Result.Line := 0;\r\n // get char at caret\r\n PosX := APoint.Char;\r\n PosY := APoint.Line;\r\n Line := Lines[APoint.Line - 1];\r\n if Length(Line) >= PosX then\r\n begin\r\n Test := Line[PosX];\r\n // is it one of the recognized brackets?\r\n for i := Low(Brackets) to High(Brackets) do\r\n if Test = Brackets[i] then\r\n begin\r\n // this is the bracket, get the matching one and the direction\r\n BracketInc := Brackets[i];\r\n BracketDec := Brackets[i xor 1]; // 0 -> 1, 1 -> 0, ...\r\n // search for the matching bracket (that is until NumBrackets = 0)\r\n NumBrackets := 1;\r\n if Odd(i) then\r\n begin\r\n repeat\r\n // search until start of line\r\n while PosX > 1 do\r\n begin\r\n Dec(PosX);\r\n Test := Line[PosX];\r\n p.Char := PosX;\r\n p.Line := PosY;\r\n if (Test = BracketInc) or (Test = BracketDec) then\r\n begin\r\n if GetHighlighterAttriAtRowCol(p, vDummy, attr) then\r\n isCommentOrString := (attr = Highlighter.StringAttribute) or\r\n (attr = Highlighter.CommentAttribute)\r\n else\r\n isCommentOrString := False;\r\n if (Test = BracketInc) and (not isCommentOrString) then\r\n Inc(NumBrackets)\r\n else if (Test = BracketDec) and (not isCommentOrString) then\r\n begin\r\n Dec(NumBrackets);\r\n if NumBrackets = 0 then\r\n begin\r\n // matching bracket found, set caret and bail out\r\n Result := P;\r\n exit;\r\n end;\r\n end;\r\n end;\r\n end;\r\n // get previous line if possible\r\n if PosY = 1 then break;\r\n Dec(PosY);\r\n Line := Lines[PosY - 1];\r\n PosX := Length(Line) + 1;\r\n until False;\r\n end\r\n else begin\r\n repeat\r\n // search until end of line\r\n Len := Length(Line);\r\n while PosX < Len do\r\n begin\r\n Inc(PosX);\r\n Test := Line[PosX];\r\n p.Char := PosX;\r\n p.Line := PosY;\r\n if (Test = BracketInc) or (Test = BracketDec) then\r\n begin\r\n if GetHighlighterAttriAtRowCol(p, vDummy, attr) then\r\n isCommentOrString := (attr = Highlighter.StringAttribute) or\r\n (attr = Highlighter.CommentAttribute)\r\n else\r\n isCommentOrString := False;\r\n if (Test = BracketInc) and (not isCommentOrString) then\r\n Inc(NumBrackets)\r\n else if (Test = BracketDec)and (not isCommentOrString) then\r\n begin\r\n Dec(NumBrackets);\r\n if NumBrackets = 0 then\r\n begin\r\n // matching bracket found, set caret and bail out\r\n Result := P;\r\n exit;\r\n end;\r\n end;\r\n end;\r\n end;\r\n // get next line if possible\r\n if PosY = Lines.Count then\r\n Break;\r\n Inc(PosY);\r\n Line := Lines[PosY - 1];\r\n PosX := 0;\r\n until False;\r\n end;\r\n // don't test the other brackets, we're done\r\n break;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TCustomSynEdit.GetHighlighterAttriAtRowCol(const XY: TBufferCoord;\r\n var Token: UnicodeString; var Attri: TSynHighlighterAttributes): Boolean;\r\nvar\r\n TmpType, TmpStart: Integer;\r\nbegin\r\n Result := GetHighlighterAttriAtRowColEx(XY, Token, TmpType, TmpStart, Attri);\r\nend;\r\n\r\nfunction TCustomSynEdit.GetHighlighterAttriAtRowColEx(const XY: TBufferCoord;\r\n var Token: UnicodeString; var TokenType, Start: Integer;\r\n var Attri: TSynHighlighterAttributes): boolean;\r\nvar\r\n PosX, PosY: Integer;\r\n Line: UnicodeString;\r\nbegin\r\n PosY := XY.Line - 1;\r\n if Assigned(Highlighter) and (PosY >= 0) and (PosY < Lines.Count) then\r\n begin\r\n Line := Lines[PosY];\r\n if PosY = 0 then\r\n Highlighter.ResetRange\r\n else\r\n Highlighter.SetRange(TSynEditStringList(Lines).Ranges[PosY - 1]);\r\n Highlighter.SetLine(Line, PosY);\r\n PosX := XY.Char;\r\n if (PosX > 0) and (PosX <= Length(Line)) then\r\n while not Highlighter.GetEol do\r\n begin\r\n Start := Highlighter.GetTokenPos + 1;\r\n Token := Highlighter.GetToken;\r\n if (PosX >= Start) and (PosX < Start + Length(Token)) then\r\n begin\r\n Attri := Highlighter.GetTokenAttribute;\r\n TokenType := Highlighter.GetTokenKind;\r\n Result := True;\r\n exit;\r\n end;\r\n Highlighter.Next;\r\n end;\r\n end;\r\n Token := '';\r\n Attri := nil;\r\n Result := False;\r\nend;\r\n\r\nfunction TCustomSynEdit.FindHookedCmdEvent(AHandlerProc: THookedCommandEvent): Integer;\r\nvar\r\n Entry: THookedCommandHandlerEntry;\r\nbegin\r\n Result := GetHookedCommandHandlersCount - 1;\r\n while Result >= 0 do\r\n begin\r\n Entry := THookedCommandHandlerEntry(fHookedCommandHandlers[Result]);\r\n if Entry.Equals(AHandlerProc) then\r\n break;\r\n Dec(Result);\r\n end;\r\nend;\r\n\r\nfunction TCustomSynEdit.GetHookedCommandHandlersCount: Integer;\r\nbegin\r\n if Assigned(fHookedCommandHandlers) then\r\n Result := fHookedCommandHandlers.Count\r\n else\r\n Result := 0;\r\nend;\r\n\r\nprocedure TCustomSynEdit.RegisterCommandHandler(\r\n const AHandlerProc: THookedCommandEvent; AHandlerData: pointer);\r\nbegin\r\n if not Assigned(AHandlerProc) then\r\n begin\r\n{$IFDEF SYN_DEVELOPMENT_CHECKS}\r\n raise Exception.Create('Event handler is NIL in RegisterCommandHandler');\r\n{$ENDIF}\r\n exit;\r\n end;\r\n if not Assigned(fHookedCommandHandlers) then\r\n fHookedCommandHandlers := TObjectList.Create;\r\n if FindHookedCmdEvent(AHandlerProc) = -1 then\r\n fHookedCommandHandlers.Add(THookedCommandHandlerEntry.Create(\r\n AHandlerProc, AHandlerData))\r\n else\r\n{$IFDEF SYN_DEVELOPMENT_CHECKS}\r\n raise Exception.CreateFmt('Event handler (%p, %p) already registered',\r\n [TMethod(AHandlerProc).Data, TMethod(AHandlerProc).Code]);\r\n{$ENDIF}\r\nend;\r\n\r\nprocedure TCustomSynEdit.UnregisterCommandHandler(AHandlerProc:\r\n THookedCommandEvent);\r\nvar\r\n i: Integer;\r\nbegin\r\n if not Assigned(AHandlerProc) then\r\n begin\r\n{$IFDEF SYN_DEVELOPMENT_CHECKS}\r\n raise Exception.Create('Event handler is NIL in UnregisterCommandHandler');\r\n{$ENDIF}\r\n exit;\r\n end;\r\n i := FindHookedCmdEvent(AHandlerProc);\r\n if i > -1 then\r\n fHookedCommandHandlers.Delete(i)\r\n else\r\n{$IFDEF SYN_DEVELOPMENT_CHECKS}\r\n raise Exception.CreateFmt('Event handler (%p, %p) is not registered',\r\n [TMethod(AHandlerProc).Data, TMethod(AHandlerProc).Code]);\r\n{$ENDIF}\r\nend;\r\n\r\nprocedure TCustomSynEdit.NotifyHookedCommandHandlers(AfterProcessing: Boolean;\r\n var Command: TSynEditorCommand; var AChar: WideChar; Data: pointer);\r\nvar\r\n Handled: Boolean;\r\n i: Integer;\r\n Entry: THookedCommandHandlerEntry;\r\nbegin\r\n Handled := False;\r\n for i := 0 to GetHookedCommandHandlersCount - 1 do\r\n begin\r\n Entry := THookedCommandHandlerEntry(fHookedCommandHandlers[i]);\r\n // NOTE: Command should NOT be set to ecNone, because this might interfere\r\n // with other handlers. Set Handled to False instead (and check its value\r\n // to not process the command twice).\r\n Entry.fEvent(Self, AfterProcessing, Handled, Command, AChar, Data,\r\n Entry.fData);\r\n end;\r\n if Handled then\r\n Command := ecNone;\r\nend;\r\n\r\nprocedure TCustomSynEdit.DoOnClearBookmark(var Mark: TSynEditMark);\r\nbegin\r\n if Assigned(fOnClearMark) then\r\n fOnClearMark(Self, Mark);\r\nend;\r\n\r\nprocedure TCustomSynEdit.DoOnPaintTransientEx(TransientType: TTransientType; Lock: Boolean);\r\nvar\r\n DoTransient: Boolean;\r\n i: Integer;\r\nbegin\r\n DoTransient:=(FPaintTransientLock=0);\r\n if Lock then\r\n begin\r\n if (TransientType=ttBefore) then inc(FPaintTransientLock)\r\n else\r\n begin\r\n dec(FPaintTransientLock);\r\n DoTransient:=(FPaintTransientLock=0);\r\n end;\r\n end;\r\n\r\n if DoTransient then\r\n begin\r\n // plugins\r\n if fPlugins <> nil then\r\n for i := 0 to fPlugins.Count - 1 do\r\n TSynEditPlugin(fPlugins[i]).PaintTransient(Canvas, TransientType);\r\n // event\r\n if Assigned(fOnPaintTransient) then\r\n begin\r\n Canvas.Font.Assign(Font);\r\n Canvas.Brush.Color := Color;\r\n HideCaret;\r\n try\r\n fOnPaintTransient(Self, Canvas, TransientType);\r\n finally\r\n ShowCaret;\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TCustomSynEdit.DoOnPaintTransient(TransientType: TTransientType);\r\nbegin\r\n DoOnPaintTransientEx(TransientType, False);\r\nend;\r\n\r\nprocedure TCustomSynEdit.DoOnPaint;\r\nbegin\r\n if Assigned(fOnPaint) then\r\n begin\r\n Canvas.Font.Assign(Font);\r\n Canvas.Brush.Color := Color;\r\n fOnPaint(Self, Canvas);\r\n end;\r\nend;\r\n\r\nprocedure TCustomSynEdit.DoOnPlaceMark(var Mark: TSynEditMark);\r\nbegin\r\n if Assigned(fOnPlaceMark) then\r\n fOnPlaceMark(Self, Mark);\r\nend;\r\n\r\nfunction TCustomSynEdit.DoOnReplaceText(const ASearch, AReplace: UnicodeString;\r\n Line, Column: Integer): TSynReplaceAction;\r\nbegin\r\n Result := raCancel;\r\n if Assigned(fOnReplaceText) then\r\n fOnReplaceText(Self, ASearch, AReplace, Line, Column, Result);\r\nend;\r\n\r\nprocedure TCustomSynEdit.DoOnStatusChange(Changes: TSynStatusChanges);\r\nbegin\r\n if Assigned(fOnStatusChange) then\r\n begin\r\n fOnStatusChange(Self, fStatusChanges);\r\n fStatusChanges := [];\r\n end;\r\nend;\r\n\r\nprocedure TCustomSynEdit.UpdateModifiedStatus;\r\nbegin\r\n Modified := not UndoList.InitialState;\r\nend;\r\n\r\nprocedure TCustomSynEdit.UndoRedoAdded(Sender: TObject);\r\nbegin\r\n UpdateModifiedStatus;\r\n\r\n // we have to clear the redo information, since adding undo info removes\r\n // the necessary context to undo earlier edit actions\r\n if (Sender = fUndoList) and not fUndoList.InsideRedo and\r\n (fUndoList.PeekItem<>nil) and (fUndoList.PeekItem.ChangeReason<>crGroupBreak) then\r\n fRedoList.Clear;\r\n if TSynEditUndoList(Sender).BlockCount = 0 then\r\n DoChange;\r\nend;\r\n\r\nfunction TCustomSynEdit.GetWordAtRowCol(XY: TBufferCoord): UnicodeString;\r\nvar\r\n Line: UnicodeString;\r\n Len, Stop: Integer;\r\nbegin\r\n Result := '';\r\n if (XY.Line >= 1) and (XY.Line <= Lines.Count) then\r\n begin\r\n Line := Lines[XY.Line - 1];\r\n Len := Length(Line);\r\n if Len = 0 then Exit;\r\n if (XY.Char >= 1) and (XY.Char <= Len + 1) and IsIdentChar(Line[XY.Char]) then\r\n begin\r\n Stop := XY.Char;\r\n while (Stop <= Len) and IsIdentChar(Line[Stop]) do\r\n Inc(Stop);\r\n while (XY.Char > 1) and IsIdentChar(Line[XY.Char - 1]) do\r\n Dec(XY.Char);\r\n if Stop > XY.Char then\r\n Result := Copy(Line, XY.Char, Stop - XY.Char);\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TCustomSynEdit.BufferToDisplayPos(const p: TBufferCoord): TDisplayCoord;\r\n// BufferToDisplayPos takes a position in the text and transforms it into\r\n// the row and column it appears to be on the screen\r\nvar\r\n s: UnicodeString;\r\n i, L: Integer;\r\n x, CountOfAvgGlyphs: Integer;\r\nbegin\r\n Canvas.Font := Font;\r\n\r\n Result := TDisplayCoord(p);\r\n if p.Line - 1 < Lines.Count then\r\n begin\r\n s := Lines[p.Line - 1];\r\n l := Length(s);\r\n x := 0;\r\n for i := 1 to p.Char - 1 do begin\r\n if (i <= l) and (s[i] = #9) then\r\n inc(x, TabWidth - (x mod TabWidth))\r\n else if i <= l then\r\n begin\r\n CountOfAvgGlyphs := CeilOfIntDiv(fTextDrawer.TextWidth(s[i]) , fCharWidth);\r\n inc(x, CountOfAvgGlyphs);\r\n end\r\n else\r\n inc(x);\r\n end;\r\n Result.Column := x + 1;\r\n end;\r\n if WordWrap then\r\n Result := fWordWrapPlugin.BufferToDisplayPos(TBufferCoord(Result));\r\nend;\r\n\r\nfunction TCustomSynEdit.DisplayToBufferPos(const p: TDisplayCoord): TBufferCoord;\r\n// DisplayToBufferPos takes a position on screen and transfrom it\r\n// into position of text\r\nvar\r\n s: UnicodeString;\r\n i, L: Integer;\r\n x, CountOfAvgGlyphs: Integer;\r\nbegin\r\n Canvas.Font := Font;\r\n\r\n if WordWrap then\r\n Result := fWordWrapPlugin.DisplayToBufferPos(p)\r\n else\r\n Result := TBufferCoord(p);\r\n if Result.Line <= lines.Count then\r\n begin\r\n s := Lines[Result.Line -1];\r\n l := Length(s);\r\n x := 0;\r\n i := 0;\r\n\r\n while x < Result.Char do\r\n begin\r\n inc(i);\r\n if (i <= l) and (s[i] = #9) then\r\n inc(x, TabWidth - (x mod TabWidth))\r\n else if i <= l then\r\n begin\r\n CountOfAvgGlyphs := CeilOfIntDiv(fTextDrawer.TextWidth(s[i]) , fCharWidth);\r\n inc(x, CountOfAvgGlyphs);\r\n end\r\n else\r\n inc(x);\r\n end;\r\n Result.Char := i;\r\n end;\r\nend;\r\n\r\nprocedure TCustomSynEdit.DoLinesDeleted(FirstLine, Count: Integer);\r\nvar\r\n i: Integer;\r\nbegin\r\n // gutter marks\r\n for i := 0 to Marks.Count - 1 do\r\n if Marks[i].Line >= FirstLine + Count then\r\n Marks[i].Line := Marks[i].Line - Count\r\n else if Marks[i].Line > FirstLine then\r\n Marks[i].Line := FirstLine;\r\n\r\n // plugins\r\n if fPlugins <> nil then\r\n for i := 0 to fPlugins.Count - 1 do\r\n TSynEditPlugin(fPlugins[i]).LinesDeleted(FirstLine, Count);\r\nend;\r\n\r\nprocedure TCustomSynEdit.DoLinesInserted(FirstLine, Count: Integer);\r\nvar\r\n i: Integer;\r\nbegin\r\n // gutter marks\r\n for i := 0 to Marks.Count - 1 do\r\n if Marks[i].Line >= FirstLine then\r\n Marks[i].Line := Marks[i].Line + Count;\r\n\r\n // plugins\r\n if fPlugins <> nil then\r\n for i := 0 to fPlugins.Count - 1 do\r\n TSynEditPlugin(fPlugins[i]).LinesInserted(FirstLine, Count);\r\nend;\r\n\r\nprocedure TCustomSynEdit.PluginsAfterPaint(ACanvas: TCanvas; const AClip: TRect;\r\n FirstLine, LastLine: Integer);\r\nvar\r\n i: Integer;\r\nbegin\r\n if fPlugins <> nil then\r\n for i := 0 to fPlugins.Count - 1 do\r\n TSynEditPlugin(fPlugins[i]).AfterPaint(ACanvas, AClip, FirstLine, LastLine);\r\nend;\r\n\r\nprocedure TCustomSynEdit.ProperSetLine(ALine: Integer; const ALineText: UnicodeString);\r\nbegin\r\n if eoTrimTrailingSpaces in Options then\r\n Lines[ALine] := TrimTrailingSpaces(ALineText)\r\n else\r\n Lines[ALine] := ALineText;\r\nend;\r\n\r\nprocedure TCustomSynEdit.AddKeyUpHandler(aHandler: TKeyEvent);\r\nbegin\r\n fKbdHandler.AddKeyUpHandler(aHandler);\r\nend;\r\n\r\nprocedure TCustomSynEdit.RemoveKeyUpHandler(aHandler: TKeyEvent);\r\nbegin\r\n fKbdHandler.RemoveKeyUpHandler(aHandler);\r\nend;\r\n\r\nprocedure TCustomSynEdit.AddKeyDownHandler(aHandler: TKeyEvent);\r\nbegin\r\n fKbdHandler.AddKeyDownHandler(aHandler);\r\nend;\r\n\r\nprocedure TCustomSynEdit.RemoveKeyDownHandler(aHandler: TKeyEvent);\r\nbegin\r\n fKbdHandler.RemoveKeyDownHandler(aHandler);\r\nend;\r\n\r\nprocedure TCustomSynEdit.AddKeyPressHandler(aHandler: TKeyPressWEvent);\r\nbegin\r\n fKbdHandler.AddKeyPressHandler(aHandler);\r\nend;\r\n\r\nprocedure TCustomSynEdit.RemoveKeyPressHandler(aHandler: TKeyPressWEvent);\r\nbegin\r\n fKbdHandler.RemoveKeyPressHandler(aHandler);\r\nend;\r\n\r\nprocedure TCustomSynEdit.AddFocusControl(aControl: TWinControl);\r\nbegin\r\n fFocusList.Add(aControl);\r\nend;\r\n\r\nprocedure TCustomSynEdit.RemoveFocusControl(aControl: TWinControl);\r\nbegin\r\n fFocusList.Remove(aControl);\r\nend;\r\n\r\nfunction TCustomSynEdit.IsIdentChar(AChar: WideChar): Boolean;\r\nbegin\r\n if Assigned(Highlighter) then\r\n Result := Highlighter.IsIdentChar(AChar)\r\n else\r\n Result := AChar >= #33;\r\n\r\n if Assigned(Highlighter) then\r\n Result := Result or CharInSet(AChar, Highlighter.AdditionalIdentChars)\r\n else\r\n Result := Result or CharInSet(AChar, Self.AdditionalIdentChars);\r\n\r\n Result := Result and not IsWordBreakChar(AChar);\r\nend;\r\n\r\nfunction TCustomSynEdit.IsWhiteChar(AChar: WideChar): Boolean;\r\nbegin\r\n if Assigned(Highlighter) then\r\n Result := Highlighter.IsWhiteChar(AChar)\r\n else\r\n case AChar of\r\n #0..#32:\r\n Result := True;\r\n else\r\n Result := not (IsIdentChar(AChar) or IsWordBreakChar(AChar))\r\n end\r\nend;\r\n\r\nfunction TCustomSynEdit.IsWordBreakChar(AChar: WideChar): Boolean;\r\nbegin\r\n if Assigned(Highlighter) then\r\n Result := Highlighter.IsWordBreakChar(AChar)\r\n else\r\n case AChar of\r\n #0..#32, '.', ',', ';', ':', '\"', '''', '', '`', '', '^', '!', '?', '&',\r\n '$', '@', '', '%', '#', '~', '[', ']', '(', ')', '{', '}', '<', '>',\r\n '-', '=', '+', '*', '/', '\\', '|':\r\n Result := True;\r\n else\r\n Result := False;\r\n end;\r\n\r\n if Assigned(Highlighter) then\r\n begin\r\n Result := Result or CharInSet(AChar, Highlighter.AdditionalWordBreakChars);\r\n Result := Result and not CharInSet(AChar, Highlighter.AdditionalIdentChars);\r\n end\r\n else\r\n begin\r\n Result := Result or CharInSet(AChar, Self.AdditionalWordBreakChars);\r\n Result := Result and not CharInSet(AChar, Self.AdditionalIdentChars);\r\n end;\r\nend;\r\n\r\nprocedure TCustomSynEdit.SetSearchEngine(Value: TSynEditSearchCustom);\r\nbegin\r\n if (fSearchEngine <> Value) then\r\n begin\r\n fSearchEngine := Value;\r\n if Assigned(fSearchEngine) then\r\n fSearchEngine.FreeNotification(Self);\r\n end;\r\nend;\r\n\r\nfunction TCustomSynEdit.NextWordPos: TBufferCoord;\r\nbegin\r\n Result := NextWordPosEx(CaretXY);\r\nend;\r\n\r\nfunction TCustomSynEdit.WordStart: TBufferCoord;\r\nbegin\r\n Result := WordStartEx(CaretXY);\r\nend;\r\n\r\nfunction TCustomSynEdit.WordEnd: TBufferCoord;\r\nbegin\r\n Result := WordEndEx(CaretXY);\r\nend;\r\n\r\nfunction TCustomSynEdit.PrevWordPos: TBufferCoord;\r\nbegin\r\n Result := PrevWordPosEx(CaretXY);\r\nend;\r\n\r\nfunction TCustomSynEdit.GetPositionOfMouse(out aPos: TBufferCoord): Boolean;\r\n// Get XY caret position of mouse. Returns False if point is outside the\r\n// region of the SynEdit control.\r\nvar\r\n Point: TPoint;\r\nbegin\r\n GetCursorPos(Point); // mouse position (on screen)\r\n Point := Self.ScreenToClient(Point); // convert to SynEdit coordinates\r\n { Make sure it fits within the SynEdit bounds }\r\n if (Point.X < 0) or (Point.Y < 0) or (Point.X > Self.Width) or (Point.Y> Self.Height) then\r\n begin\r\n Result := False;\r\n Exit;\r\n end;\r\n\r\n { inside the editor, get the word under the mouse pointer }\r\n aPos := DisplayToBufferPos(PixelsToRowColumn(Point.X, Point.Y));\r\n Result := True;\r\nend;\r\n\r\nfunction TCustomSynEdit.GetWordAtMouse: UnicodeString;\r\nvar\r\n Point: TBufferCoord;\r\nbegin\r\n { Return the word under the mouse }\r\n if GetPositionOfMouse(Point) then // if point is valid\r\n Result := Self.GetWordAtRowCol(Point); // return the point at the mouse position\r\nend;\r\n\r\nfunction TCustomSynEdit.CharIndexToRowCol(Index: Integer): TBufferCoord;\r\n{ Index is 0-based; Result.x and Result.y are 1-based }\r\nvar\r\n x, y, Chars: Integer;\r\nbegin\r\n x := 0;\r\n y := 0;\r\n Chars := 0;\r\n while y < Lines.Count do\r\n begin\r\n x := Length(Lines[y]);\r\n if Chars + x + 2 > Index then\r\n begin\r\n x := Index - Chars;\r\n break;\r\n end;\r\n Inc(Chars, x + 2);\r\n x := 0;\r\n Inc(y);\r\n end;\r\n Result.Char := x + 1;\r\n Result.Line := y + 1;\r\nend;\r\n\r\nfunction TCustomSynEdit.RowColToCharIndex(RowCol: TBufferCoord): Integer;\r\n{ Row and Col are 1-based; Result is 0-based }\r\nvar\r\n synEditStringList : TSynEditStringList;\r\nbegin\r\n RowCol.Line := Min(Lines.Count, RowCol.Line) - 1;\r\n synEditStringList := (FLines as TSynEditStringList);\r\n // CharIndexToRowCol assumes a line break size of two\r\n Result := synEditStringList.LineCharIndex(RowCol.Line)\r\n + RowCol.Line * 2 + (RowCol.Char -1);\r\nend;\r\n\r\nprocedure TCustomSynEdit.Clear;\r\n{ just to attain interface compatibility with TMemo }\r\nbegin\r\n ClearAll;\r\nend;\r\n\r\nfunction TCustomSynEdit.GetSelLength: Integer;\r\nbegin\r\n if SelAvail then\r\n Result := RowColToCharIndex(BlockEnd) - RowColToCharIndex(BlockBegin)\r\n else\r\n Result := 0;\r\nend;\r\n\r\nprocedure TCustomSynEdit.SetSelLength(const Value: Integer);\r\nvar\r\n iNewCharIndex: Integer;\r\n iNewBegin: TBufferCoord;\r\n iNewEnd: TBufferCoord;\r\nbegin\r\n iNewCharIndex := RowColToCharIndex(BlockBegin) + Value;\r\n if (Value >= 0) or (iNewCharIndex < 0) then\r\n begin\r\n if iNewCharIndex < 0 then\r\n begin\r\n iNewEnd.Char := Length(Lines[Lines.Count - 1]) + 1;\r\n iNewEnd.Line := Lines.Count;\r\n end\r\n else\r\n iNewEnd := CharIndexToRowCol(iNewCharIndex);\r\n SetCaretAndSelection(iNewEnd, BlockBegin, iNewEnd);\r\n end\r\n else begin\r\n iNewBegin := CharIndexToRowCol(iNewCharIndex);\r\n SetCaretAndSelection(iNewBegin, iNewBegin, BlockBegin);\r\n end;\r\nend;\r\n\r\nprocedure TCustomSynEdit.DefineProperties(Filer: TFiler);\r\n\r\n{$IFDEF SYN_COMPILER_6_UP}\r\n function CollectionsEqual(C1, C2: TCollection): Boolean;\r\n begin\r\n Result := Classes.CollectionsEqual(C1, C2, nil, nil);\r\n end;\r\n{$ENDIF}\r\n\r\n function HasKeyData: Boolean;\r\n var\r\n iDefKeys: TSynEditKeyStrokes;\r\n begin\r\n if Filer.Ancestor <> nil then\r\n begin\r\n Result := not CollectionsEqual(Keystrokes,\r\n TCustomSynEdit(Filer.Ancestor).Keystrokes);\r\n end\r\n else begin\r\n iDefKeys := TSynEditKeyStrokes.Create(nil);\r\n try\r\n iDefKeys.ResetDefaults;\r\n Result := not CollectionsEqual(Keystrokes, iDefKeys);\r\n finally\r\n iDefKeys.Free;\r\n end;\r\n end;\r\n end;\r\n\r\nvar\r\n iSaveKeyData: Boolean;\r\nbegin\r\n inherited;\r\n{$IFNDEF UNICODE}\r\n UnicodeDefineProperties(Filer, Self);\r\n{$ENDIF}\r\n iSaveKeyData := HasKeyData;\r\n Filer.DefineProperty('RemovedKeystrokes', ReadRemovedKeystrokes,\r\n WriteRemovedKeystrokes, iSaveKeyData);\r\n Filer.DefineProperty('AddedKeystrokes', ReadAddedKeystrokes, WriteAddedKeystrokes,\r\n iSaveKeyData);\r\nend;\r\n\r\nprocedure TCustomSynEdit.DoChange;\r\nbegin\r\n if Assigned(fOnChange) then\r\n fOnChange(Self);\r\nend;\r\n\r\nprocedure TCustomSynEdit.ReadAddedKeystrokes(Reader: TReader);\r\nvar\r\n iAddKeys: TSynEditKeyStrokes;\r\n cKey: Integer;\r\nbegin\r\n if Reader.NextValue = vaCollection then\r\n Reader.ReadValue\r\n else\r\n Exit;\r\n iAddKeys := TSynEditKeyStrokes.Create(Self);\r\n try\r\n Reader.ReadCollection(iAddKeys);\r\n for cKey := 0 to iAddKeys.Count -1 do\r\n Keystrokes.Add.Assign(iAddKeys[cKey]);\r\n finally\r\n iAddKeys.Free;\r\n end;\r\nend;\r\n\r\nprocedure TCustomSynEdit.ReadRemovedKeystrokes(Reader: TReader);\r\nvar\r\n iDelKeys: TSynEditKeyStrokes;\r\n cKey: Integer;\r\n iKey: TSynEditKeyStroke;\r\n iToDelete: Integer;\r\nbegin\r\n if Reader.NextValue = vaCollection then\r\n Reader.ReadValue\r\n else\r\n Exit;\r\n iDelKeys := TSynEditKeyStrokes.Create(nil);\r\n try\r\n Reader.ReadCollection(iDelKeys);\r\n for cKey := 0 to iDelKeys.Count -1 do\r\n begin\r\n iKey := iDelKeys[cKey];\r\n iToDelete := Keystrokes.FindShortcut2(iKey.ShortCut, iKey.ShortCut2);\r\n if (iToDelete >= 0) and (Keystrokes[iToDelete].Command = iKey.Command) then\r\n Keystrokes[iToDelete].Free;\r\n end;\r\n finally\r\n iDelKeys.Free;\r\n end;\r\nend;\r\n\r\nprocedure TCustomSynEdit.WriteAddedKeystrokes(Writer: TWriter);\r\nvar\r\n iDefaultKeys: TSynEditKeyStrokes;\r\n iAddedKeys: TSynEditKeyStrokes;\r\n cKey: Integer;\r\n iKey: TSynEditKeyStroke;\r\n iDelIndex: Integer;\r\nbegin\r\n iDefaultKeys := TSynEditKeyStrokes.Create(nil);\r\n try\r\n if Writer.Ancestor <> nil then\r\n iDefaultKeys.Assign(TSynEdit(Writer.Ancestor).Keystrokes)\r\n else\r\n iDefaultKeys.ResetDefaults;\r\n iAddedKeys := TSynEditKeyStrokes.Create(nil);\r\n try\r\n for cKey := 0 to Keystrokes.Count -1 do\r\n begin\r\n iKey := Keystrokes[cKey];\r\n iDelIndex := iDefaultKeys.FindShortcut2(iKey.ShortCut, iKey.ShortCut2);\r\n //if it's not a default keystroke, add it\r\n if (iDelIndex < 0) or (iDefaultKeys[iDelIndex].Command <> iKey.Command) then\r\n iAddedKeys.Add.Assign(iKey);\r\n end;\r\n Writer.WriteCollection(iAddedKeys);\r\n finally\r\n iAddedKeys.Free;\r\n end;\r\n finally\r\n iDefaultKeys.Free;\r\n end;\r\nend;\r\n\r\nprocedure TCustomSynEdit.WriteRemovedKeystrokes(Writer: TWriter);\r\nvar\r\n iRemovedKeys: TSynEditKeyStrokes;\r\n cKey: Integer;\r\n iKey: TSynEditKeyStroke;\r\n iFoundAt: Integer;\r\nbegin\r\n iRemovedKeys := TSynEditKeyStrokes.Create(nil);\r\n try\r\n if Writer.Ancestor <> nil then\r\n iRemovedKeys.Assign(TSynEdit(Writer.Ancestor).Keystrokes)\r\n else\r\n iRemovedKeys.ResetDefaults;\r\n cKey := 0;\r\n while cKey < iRemovedKeys.Count do\r\n begin\r\n iKey := iRemovedKeys[cKey];\r\n iFoundAt := Keystrokes.FindShortcut2(iKey.ShortCut, iKey.ShortCut2);\r\n if (iFoundAt >= 0) and (Keystrokes[iFoundAt].Command = iKey.Command) then\r\n iKey.Free //if exists in Keystrokes, then shouldn't be in \"removed\" list\r\n else\r\n Inc(cKey);\r\n end;\r\n Writer.WriteCollection(iRemovedKeys);\r\n finally\r\n iRemovedKeys.Free;\r\n end;\r\nend;\r\n\r\nprocedure TCustomSynEdit.AddMouseDownHandler(aHandler: TMouseEvent);\r\nbegin\r\n fKbdHandler.AddMouseDownHandler(aHandler);\r\nend;\r\n\r\nprocedure TCustomSynEdit.RemoveMouseDownHandler(aHandler: TMouseEvent);\r\nbegin\r\n fKbdHandler.RemoveMouseDownHandler(aHandler);\r\nend;\r\n\r\nprocedure TCustomSynEdit.AddMouseUpHandler(aHandler: TMouseEvent);\r\nbegin\r\n fKbdHandler.AddMouseUpHandler(aHandler);\r\nend;\r\n\r\nprocedure TCustomSynEdit.RemoveMouseUpHandler(aHandler: TMouseEvent);\r\nbegin\r\n fKbdHandler.RemoveMouseUpHandler(aHandler);\r\nend;\r\n\r\nprocedure TCustomSynEdit.AddMouseCursorHandler(aHandler: TMouseCursorEvent);\r\nbegin\r\n fKbdHandler.AddMouseCursorHandler(aHandler);\r\nend;\r\n\r\nprocedure TCustomSynEdit.RemoveMouseCursorHandler(aHandler: TMouseCursorEvent);\r\nbegin\r\n fKbdHandler.RemoveMouseCursorHandler(aHandler);\r\nend;\r\n\r\n{$IFDEF SYN_COMPILER_6_UP}\r\nprocedure TCustomSynEdit.DoSearchFindFirstExecute(Action: TSearchFindFirst);\r\nbegin\r\n OnFindBeforeSearch := Action.Dialog.OnFind;\r\n OnCloseBeforeSearch := Action.Dialog.OnClose;\r\n SelStartBeforeSearch := SelStart; SelLengthBeforeSearch := SelLength;\r\n\r\n Action.Dialog.OnFind := FindDialogFindFirst;\r\n Action.Dialog.OnClose := FindDialogClose;\r\n Action.Dialog.Execute();\r\nend;\r\n\r\nprocedure TCustomSynEdit.DoSearchFindExecute(Action: TSearchFind);\r\nbegin\r\n OnFindBeforeSearch := Action.Dialog.OnFind;\r\n OnCloseBeforeSearch := Action.Dialog.OnClose;\r\n\r\n Action.Dialog.OnFind := FindDialogFind;\r\n Action.Dialog.OnClose := FindDialogClose;\r\n Action.Dialog.Execute();\r\nend;\r\n\r\nprocedure TCustomSynEdit.DoSearchReplaceExecute(Action: TSearchReplace);\r\nbegin\r\n OnFindBeforeSearch := Action.Dialog.OnFind;\r\n OnReplaceBeforeSearch := Action.Dialog.OnReplace;\r\n OnCloseBeforeSearch := Action.Dialog.OnClose;\r\n\r\n Action.Dialog.OnFind := FindDialogFind;\r\n Action.Dialog.OnReplace := FindDialogFind;\r\n Action.Dialog.OnClose := FindDialogClose;\r\n Action.Dialog.Execute();\r\nend;\r\n\r\nprocedure TCustomSynEdit.DoSearchFindNextExecute(Action: TSearchFindNext);\r\nbegin\r\n SearchByFindDialog(Action.SearchFind.Dialog);\r\nend;\r\n\r\nprocedure TCustomSynEdit.FindDialogFindFirst(Sender: TObject);\r\nbegin\r\n TFindDialog(Sender).CloseDialog;\r\n\r\n if (SelStart = SelStartBeforeSearch) and (SelLength = SelLengthBeforeSearch) then\r\n begin\r\n SelStart := 0;\r\n SelLength := 0;\r\n end;\r\n\r\n if Sender is TFindDialog then\r\n if not SearchByFindDialog(TFindDialog(Sender)) and (SelStart = 0) and (SelLength = 0) then\r\n begin\r\n SelStart := SelStartBeforeSearch;\r\n SelLength := SelLengthBeforeSearch;\r\n end;\r\nend;\r\n\r\nprocedure TCustomSynEdit.FindDialogFind(Sender: TObject);\r\nbegin\r\n if Sender is TFindDialog then\r\n SearchByFindDialog(TFindDialog(Sender));\r\nend;\r\n\r\nfunction TCustomSynEdit.SearchByFindDialog(FindDialog: TFindDialog) : bool;\r\nvar\r\n Options :TSynSearchOptions;\r\n ReplaceText, MessageText :String;\r\n OldSelStart, OldSelLength: integer;\r\nbegin\r\n if (frReplaceAll in FindDialog.Options) then Options := [ssoReplaceAll]\r\n else if (frReplace in FindDialog.Options) then Options := [ssoReplace]\r\n else Options := [ssoSelectedOnly];\r\n\r\n if (frMatchCase in FindDialog.Options) then Options := Options + [ssoMatchCase];\r\n if (frWholeWord in FindDialog.Options) then Options := Options + [ssoWholeWord];\r\n if (not (frDown in FindDialog.Options)) then Options := Options + [ssoBackwards];\r\n\r\n if (ssoSelectedOnly in Options)\r\n then ReplaceText := ''\r\n else ReplaceText := TReplaceDialog(FindDialog).ReplaceText;\r\n\r\n OldSelStart := SelStart; OldSelLength := SelLength;\r\n if (UpperCase(SelText) = UpperCase(FindDialog.FindText)) and not (frReplace in FindDialog.Options) then\r\n SelStart := SelStart + SelLength\r\n else\r\n SelLength := 0;\r\n\r\n Result := SearchReplace(FindDialog.FindText, ReplaceText, Options) > 0;\r\n if not Result then\r\n begin\r\n SelStart := OldSelStart; SelLength := OldSelLength;\r\n if Assigned(OnSearchNotFound) then\r\n OnSearchNotFound(self, FindDialog.FindText)\r\n else\r\n begin\r\n MessageText := Format(STextNotFound, [FindDialog.FindText]);\r\n ShowMessage(MessageText);\r\n end;\r\n end\r\n else if (frReplace in FindDialog.Options) then\r\n begin\r\n SelStart := SelStart - Length(FindDialog.FindText) - 1;\r\n SelLength := Length(FindDialog.FindText) + 1;\r\n end;\r\nend;\r\n\r\nprocedure TCustomSynEdit.FindDialogClose(Sender: TObject);\r\nbegin\r\n TFindDialog(Sender).OnFind := OnFindBeforeSearch;\r\n if Sender is TReplaceDialog then\r\n TReplaceDialog(Sender).OnReplace := OnReplaceBeforeSearch;\r\n TFindDialog(Sender).OnClose := OnCloseBeforeSearch;\r\nend;\r\n{$ENDIF}\r\n\r\nfunction TCustomSynEdit.GetWordWrap: Boolean;\r\nbegin\r\n Result := fWordWrapPlugin <> nil;\r\nend;\r\n\r\nprocedure TCustomSynEdit.SetWordWrap(const Value: Boolean);\r\nvar\r\n vTempBlockBegin, vTempBlockEnd : TBufferCoord;\r\n vOldTopLine: Integer;\r\n vShowCaret: Boolean;\r\nbegin\r\n if WordWrap <> Value then\r\n begin\r\n Invalidate; // better Invalidate before changing LeftChar and TopLine\r\n vShowCaret := CaretInView;\r\n vOldTopLine := RowToLine(TopLine);\r\n if Value then\r\n begin\r\n fWordWrapPlugin := TSynWordWrapPlugin.Create(Self);\r\n LeftChar := 1;\r\n end\r\n else\r\n fWordWrapPlugin := nil;\r\n TopLine := LineToRow(vOldTopLine);\r\n UpdateScrollBars;\r\n\r\n // constrain caret position to MaxScrollWidth if eoScrollPastEol is enabled\r\n if (eoScrollPastEol in Options) then\r\n begin\r\n InternalCaretXY := CaretXY;\r\n vTempBlockBegin := BlockBegin;\r\n vTempBlockEnd := BlockEnd;\r\n SetBlockBegin(vTempBlockBegin);\r\n SetBlockEnd(vTempBlockEnd);\r\n end;\r\n if vShowCaret then\r\n EnsureCursorPosVisible;\r\n end;\r\nend;\r\n\r\nfunction TCustomSynEdit.GetDisplayLineCount: Integer;\r\nbegin\r\n if fWordWrapPlugin = nil then\r\n Result := Lines.Count\r\n else if Lines.Count = 0 then\r\n Result := 0\r\n else begin\r\n Result := fWordWrapPlugin.RowCount;\r\n end;\r\nend;\r\n\r\nfunction TCustomSynEdit.LineToRow(aLine: Integer): Integer;\r\nvar\r\n vBufferPos: TBufferCoord;\r\nbegin\r\n if not WordWrap then\r\n Result := aLine\r\n else begin\r\n vBufferPos.Char := 1;\r\n vBufferPos.Line := aLine;\r\n Result := BufferToDisplayPos(vBufferPos).Row;\r\n end;\r\nend;\r\n\r\nfunction TCustomSynEdit.RowToLine(aRow: Integer): Integer;\r\nvar\r\n vDisplayPos: TDisplayCoord;\r\nbegin\r\n if not WordWrap then\r\n Result := aRow\r\n else begin\r\n vDisplayPos.Column := 1;\r\n vDisplayPos.Row := aRow;\r\n Result := DisplayToBufferPos(vDisplayPos).Line;\r\n end;\r\nend;\r\n\r\nprocedure TCustomSynEdit.SetInternalDisplayXY(const aPos: TDisplayCoord);\r\nbegin\r\n IncPaintLock;\r\n InternalCaretXY := DisplayToBufferPos(aPos);\r\n fCaretAtEOL := WordWrap and (aPos.Row <= fWordWrapPlugin.RowCount) and\r\n (aPos.Column > fWordWrapPlugin.GetRowLength(aPos.Row)) and\r\n (DisplayY <> aPos.Row);\r\n DecPaintLock;\r\n UpdateLastCaretX;\r\nend;\r\n\r\nprocedure TCustomSynEdit.SetWantReturns(Value: Boolean);\r\nbegin\r\n fWantReturns := Value;\r\n {$IFDEF SYN_CLX}\r\n if fWantReturns then\r\n InputKeys := InputKeys + [ikReturns]\r\n else\r\n InputKeys := InputKeys - [ikReturns];\r\n {$ENDIF}\r\nend;\r\n\r\nprocedure TCustomSynEdit.SetWantTabs(Value: Boolean);\r\nbegin\r\n fWantTabs := Value;\r\n {$IFDEF SYN_CLX}\r\n if fWantTabs then\r\n InputKeys := InputKeys + [ikTabs]\r\n else\r\n InputKeys := InputKeys - [ikTabs];\r\n {$ENDIF}\r\nend;\r\n\r\nprocedure TCustomSynEdit.SetWordWrapGlyph(const Value: TSynGlyph);\r\nbegin\r\n fWordWrapGlyph.Assign(Value);\r\nend;\r\n\r\nprocedure TCustomSynEdit.WordWrapGlyphChange(Sender: TObject);\r\nbegin\r\n if not (csLoading in ComponentState) then\r\n InvalidateGutter;\r\nend;\r\n\r\n\r\n{ TSynEditMark }\r\n\r\nfunction TSynEditMark.GetEdit: TCustomSynEdit;\r\nbegin\r\n if FEdit <> nil then try\r\n if FEdit.Marks.IndexOf(self) = -1 then\r\n FEdit := nil;\r\n except\r\n FEdit := nil;\r\n end;\r\n Result := FEdit;\r\nend;\r\n\r\nfunction TSynEditMark.GetIsBookmark: Boolean;\r\nbegin\r\n Result := (fBookmarkNum >= 0);\r\nend;\r\n\r\nprocedure TSynEditMark.SetChar(const Value: Integer);\r\nbegin\r\n FChar := Value;\r\nend;\r\n\r\nprocedure TSynEditMark.SetImage(const Value: Integer);\r\nbegin\r\n FImage := Value;\r\n if fVisible and Assigned(fEdit) then\r\n fEdit.InvalidateGutterLines(fLine, fLine);\r\nend;\r\n\r\nprocedure TSynEditMark.SetInternalImage(const Value: Boolean);\r\nbegin\r\n fInternalImage := Value;\r\n if fVisible and Assigned(fEdit) then\r\n fEdit.InvalidateGutterLines(fLine, fLine);\r\nend;\r\n\r\nprocedure TSynEditMark.SetLine(const Value: Integer);\r\nbegin\r\n if fVisible and Assigned(fEdit) then\r\n begin\r\n if fLine > 0 then\r\n fEdit.InvalidateGutterLines(fLine, fLine);\r\n fLine := Value;\r\n fEdit.InvalidateGutterLines(fLine, fLine);\r\n end\r\n else\r\n fLine := Value;\r\nend;\r\n\r\nprocedure TSynEditMark.SetVisible(const Value: Boolean);\r\nbegin\r\n if fVisible <> Value then\r\n begin\r\n fVisible := Value;\r\n if Assigned(fEdit) then\r\n fEdit.InvalidateGutterLines(fLine, fLine);\r\n end;\r\nend;\r\n\r\nconstructor TSynEditMark.Create(AOwner: TCustomSynEdit);\r\nbegin\r\n inherited Create;\r\n fBookmarkNum := -1;\r\n fEdit := AOwner;\r\nend;\r\n\r\n{ TSynEditMarkList }\r\n\r\nprocedure TSynEditMarkList.Notify(Ptr: Pointer; Action: TListNotification);\r\nbegin\r\n inherited;\r\n if Assigned(FOnChange) then\r\n FOnChange(Self);\r\nend;\r\n\r\nfunction TSynEditMarkList.GetItem(Index: Integer): TSynEditMark;\r\nbegin\r\n Result := TSynEditMark(inherited GetItem(Index));\r\nend;\r\n\r\nprocedure TSynEditMarkList.SetItem(Index: Integer; Item: TSynEditMark);\r\nbegin\r\n inherited SetItem(Index, Item);\r\nend;\r\n\r\nconstructor TSynEditMarkList.Create(AOwner: TCustomSynEdit);\r\nbegin\r\n inherited Create;\r\n fEdit := AOwner;\r\nend;\r\n\r\nfunction TSynEditMarkList.First: TSynEditMark;\r\nbegin\r\n Result := TSynEditMark(inherited First);\r\nend;\r\n\r\nfunction TSynEditMarkList.Last: TSynEditMark;\r\nbegin\r\n result := TSynEditMark(inherited Last);\r\nend;\r\n\r\nfunction TSynEditMarkList.Extract(Item: TSynEditMark): TSynEditMark;\r\nbegin\r\n Result := TSynEditMark(inherited Extract(Item));\r\nend;\r\n\r\nprocedure TSynEditMarkList.ClearLine(Line: Integer);\r\nvar\r\n i: Integer;\r\nbegin\r\n for i := Count - 1 downto 0 do\r\n if not Items[i].IsBookmark and (Items[i].Line = Line) then\r\n Delete(i);\r\nend;\r\n\r\nprocedure TSynEditMarkList.GetMarksForLine(line: Integer; var marks: TSynEditMarks);\r\n//Returns up to maxMarks book/gutter marks for a chosen line.\r\nvar\r\n cnt: Integer;\r\n i: Integer;\r\nbegin\r\n FillChar(marks, SizeOf(marks), 0);\r\n cnt := 0;\r\n for i := 0 to Count - 1 do\r\n begin\r\n if Items[i].Line = line then\r\n begin\r\n Inc(cnt);\r\n marks[cnt] := Items[i];\r\n if cnt = MAX_MARKS then break;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TSynEditMarkList.Place(mark: TSynEditMark);\r\nbegin\r\n if assigned(fEdit) then\r\n if Assigned(fEdit.OnPlaceBookmark) then\r\n fEdit.OnPlaceBookmark(fEdit, mark);\r\n if assigned(mark) then\r\n Add(mark);\r\nend;\r\n\r\n{ TSynEditPlugin }\r\n\r\nconstructor TSynEditPlugin.Create(AOwner: TCustomSynEdit);\r\nbegin\r\n inherited Create;\r\n if AOwner <> nil then\r\n begin\r\n fOwner := AOwner;\r\n if fOwner.fPlugins = nil then\r\n fOwner.fPlugins := TObjectList.Create;\r\n fOwner.fPlugins.Add(Self);\r\n end;\r\nend;\r\n\r\ndestructor TSynEditPlugin.Destroy;\r\nbegin\r\n if fOwner <> nil then\r\n fOwner.fPlugins.Extract(Self); // we are being destroyed, fOwner should not free us\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TSynEditPlugin.AfterPaint(ACanvas: TCanvas; const AClip: TRect;\r\n FirstLine, LastLine: Integer);\r\nbegin\r\n // nothing\r\nend;\r\n\r\nprocedure TSynEditPlugin.PaintTransient(ACanvas: TCanvas; ATransientType: TTransientType);\r\nbegin\r\n // nothing\r\nend;\r\n\r\nprocedure TSynEditPlugin.LinesInserted(FirstLine, Count: Integer);\r\nbegin\r\n // nothing\r\nend;\r\n\r\nprocedure TSynEditPlugin.LinesDeleted(FirstLine, Count: Integer);\r\nbegin\r\n // nothing\r\nend;\r\n\r\n{$IFNDEF UNICODE}\r\n{$IFNDEF SYN_CLX}\r\nvar\r\n GetMsgHook: HHOOK;\r\n\r\nfunction GetMsgProc(Code: Integer; wParam: WPARAM; lParam: LPARAM): LRESULT; stdcall;\r\nvar\r\n{$IFNDEF SYN_COMPILER_9_UP}\r\n WndProc: Pointer;\r\n{$ENDIF}\r\n WinCtrl: TWinControl;\r\nbegin\r\n WinCtrl := TCustomSynEdit(FindControl(PMsg(lParam)^.hWnd));\r\n if WinCtrl is TCustomSynEdit then\r\n begin\r\n TCustomSynEdit(WinCtrl).FWindowProducedMessage := True;\r\n\r\n{$IFNDEF SYN_COMPILER_9_UP}\r\n if Code = HC_ACTION then\r\n begin\r\n with PMsg(lParam)^ do\r\n case message of\r\n WM_CHAR:\r\n begin\r\n if wParam > Ord(High(AnsiChar)) then\r\n if IsWindowUnicode(hWnd) then\r\n begin\r\n WndProc := Pointer(GetWindowLong(hWnd, GWL_WNDPROC));\r\n CallWindowProcW(WndProc, hWnd, WM_CHAR, wParam, lParam);\r\n Message := WM_NULL;\r\n end;\r\n end;\r\n end;\r\n end;\r\n{$ENDIF}\r\n\r\n end;\r\n\r\n Result := CallNextHookEx(GetMsgHook, Code, wParam, lParam);\r\nend;\r\n{$ENDIF}\r\n{$ENDIF}\r\n\r\ninitialization\r\n{$IFNDEF SYN_CLX}\r\n{$IFNDEF UNICODE}\r\n if Win32PlatformIsUnicode and not (csDesigning in Application.ComponentState) then\r\n begin\r\n // Hooking GetMessage/PeekMessage-calls is necessary as the use of\r\n // PeekMessageA in TApplication.ProcessMessage mutilates Unicode-messages.\r\n GetMsgHook := SetWindowsHookExW(WH_GETMESSAGE, GetMsgProc, 0,\r\n GetCurrentThreadId);\r\n end\r\n else\r\n GetMsgHook := 0;\r\n{$ENDIF}\r\n SynEditClipboardFormat := RegisterClipboardFormat(SYNEDIT_CLIPBOARD_FORMAT);\r\n{$ENDIF}\r\n\r\nfinalization\r\n{$IFNDEF SYN_CLX}\r\n{$IFNDEF UNICODE}\r\n if Win32PlatformIsUnicode and (GetMsgHook <> 0) then\r\n UnhookWindowsHookEx(GetMsgHook);\r\n{$ENDIF}\r\n{$ENDIF}\r\n\r\nend." }, { "path": "External/SynEdit/Source/SynEditAutoComplete.pas", "content": "{-------------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: SynEditAutoComplete.pas, released 2000-06-25.\r\n\r\nThe Initial Author of the Original Code is Michael Hieke.\r\nPortions written by Michael Hieke are Copyright 2000 Michael Hieke.\r\nPortions written by Cyrille de Brebisson (from mwCompletionProposal.pas) are\r\nCopyright 1999 Cyrille de Brebisson.\r\nUnicode translation by Mal Hrz.\r\nAll Rights Reserved.\r\n\r\nContributors to the SynEdit and mwEdit projects are listed in the\r\nContributors.txt file.\r\n\r\nAlternatively, the contents of this file may be used under the terms of the\r\nGNU General Public License Version 2 or later (the \"GPL\"), in which case\r\nthe provisions of the GPL are applicable instead of those above.\r\nIf you wish to allow use of your version of this file only under the terms\r\nof the GPL and not to allow others to use your version of this file\r\nunder the MPL, indicate your decision by deleting the provisions above and\r\nreplace them with the notice and other provisions required by the GPL.\r\nIf you do not delete the provisions above, a recipient may use your version\r\nof this file under either the MPL or the GPL.\r\n\r\n$Id: SynEditAutoComplete.pas,v 1.10.2.4 2008/09/14 16:24:58 maelh Exp $\r\n\r\nYou may retrieve the latest version of this file at the SynEdit home page,\r\nlocated at http://SynEdit.SourceForge.net\r\n\r\nKnown Issues:\r\n-------------------------------------------------------------------------------}\r\n\r\n{$IFNDEF QSYNEDITAUTOCOMPLETE}\r\nunit SynEditAutoComplete;\r\n{$ENDIF}\r\n\r\n{$I SynEdit.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF SYN_CLX}\r\n Qt,\r\n QMenus,\r\n Types,\r\n QSynEdit,\r\n QSynEditKeyCmds,\r\n QSynUnicode, \r\n {$ELSE}\r\n Windows,\r\n Menus,\r\n SynEdit,\r\n SynEditKeyCmds,\r\n SynUnicode, \r\n {$ENDIF}\r\n Classes;\r\n\r\ntype\r\n TCustomSynAutoComplete = class(TComponent)\r\n protected\r\n fAutoCompleteList: TUnicodeStrings;\r\n fCompletions: TUnicodeStrings;\r\n fCompletionComments: TUnicodeStrings;\r\n fCompletionValues: TUnicodeStrings;\r\n fEditor: TCustomSynEdit;\r\n fEditors: TList;\r\n fEOTokenChars: UnicodeString;\r\n fCaseSensitive: boolean;\r\n fParsed: boolean;\r\n procedure CompletionListChanged(Sender: TObject);\r\n procedure DefineProperties(Filer: TFiler); override; \r\n function GetCompletions: TUnicodeStrings;\r\n function GetCompletionComments: TUnicodeStrings;\r\n function GetCompletionValues: TUnicodeStrings;\r\n function GetEditorCount: integer;\r\n function GetNthEditor(Index: integer): TCustomSynEdit;\r\n procedure SetAutoCompleteList(Value: TUnicodeStrings); virtual;\r\n procedure SetEditor(Value: TCustomSynEdit);\r\n procedure SynEditCommandHandler(Sender: TObject; AfterProcessing: boolean;\r\n var Handled: boolean; var Command: TSynEditorCommand; var AChar: WideChar;\r\n Data: pointer; HandlerData: pointer);\r\n procedure Notification(AComponent: TComponent; Operation: TOperation);\r\n override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n\r\n function AddEditor(AEditor: TCustomSynEdit): boolean;\r\n function RemoveEditor(AEditor: TCustomSynEdit): boolean;\r\n\r\n procedure AddCompletion(const AToken, AValue, AComment: UnicodeString);\r\n procedure Execute(AEditor: TCustomSynEdit); virtual;\r\n procedure ExecuteCompletion(const AToken: UnicodeString; AEditor: TCustomSynEdit);\r\n virtual;\r\n procedure ParseCompletionList; virtual;\r\n public\r\n property AutoCompleteList: TUnicodeStrings read fAutoCompleteList\r\n write SetAutoCompleteList;\r\n property CaseSensitive: boolean read fCaseSensitive write fCaseSensitive;\r\n property Completions: TUnicodeStrings read GetCompletions;\r\n property CompletionComments: TUnicodeStrings read GetCompletionComments;\r\n property CompletionValues: TUnicodeStrings read GetCompletionValues;\r\n property Editor: TCustomSynEdit read fEditor write SetEditor;\r\n property EditorCount: integer read GetEditorCount;\r\n property Editors[Index: integer]: TCustomSynEdit read GetNthEditor;\r\n property EndOfTokenChr: UnicodeString read fEOTokenChars write fEOTokenChars;\r\n end;\r\n\r\n TSynAutoComplete = class(TCustomSynAutoComplete)\r\n published\r\n property AutoCompleteList;\r\n property CaseSensitive;\r\n property Editor;\r\n property EndOfTokenChr;\r\n end;\r\n\r\nimplementation\r\n\r\nuses\r\n{$IFDEF SYN_CLX}\r\n QSynEditTypes,\r\n{$ELSE}\r\n SynEditTypes,\r\n{$ENDIF}\r\n SysUtils;\r\n\r\n{ TCustomSynAutoComplete }\r\n\r\nprocedure TCustomSynAutoComplete.AddCompletion(const AToken, AValue, AComment: UnicodeString);\r\nbegin\r\n if AToken <> '' then\r\n begin\r\n if (fAutoCompleteList.Count = 0) and (fCompletions.Count = 0) then\r\n fParsed := True;\r\n fCompletions.Add(AToken);\r\n fCompletionComments.Add(AComment);\r\n fCompletionValues.Add(AValue);\r\n end;\r\nend;\r\n\r\nfunction TCustomSynAutoComplete.AddEditor(AEditor: TCustomSynEdit): boolean;\r\nvar\r\n i: integer;\r\nbegin\r\n if AEditor <> nil then\r\n begin\r\n i := fEditors.IndexOf(AEditor);\r\n if i = -1 then\r\n begin\r\n AEditor.FreeNotification(Self);\r\n fEditors.Add(AEditor);\r\n AEditor.RegisterCommandHandler(SynEditCommandHandler, nil);\r\n end;\r\n Result := True;\r\n end\r\n else\r\n Result := False;\r\nend;\r\n\r\nprocedure TCustomSynAutoComplete.CompletionListChanged(Sender: TObject);\r\nbegin\r\n fParsed := False;\r\nend;\r\n\r\nconstructor TCustomSynAutoComplete.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n fAutoCompleteList := TUnicodeStringList.Create;\r\n TUnicodeStringList(fAutoCompleteList).OnChange := CompletionListChanged;\r\n fCompletions := TUnicodeStringList.Create;\r\n fCompletionComments := TUnicodeStringList.Create;\r\n fCompletionValues := TUnicodeStringList.Create;\r\n fEditors := TList.Create;\r\n fEOTokenChars := '()[]{}.';\r\nend;\r\n\r\ndestructor TCustomSynAutoComplete.Destroy;\r\nbegin\r\n Editor := nil;\r\n while EditorCount > 0 do\r\n RemoveEditor(TCustomSynEdit(fEditors.Last));\r\n\r\n inherited Destroy;\r\n fEditors.Free;\r\n fCompletions.Free;\r\n fCompletionComments.Free;\r\n fCompletionValues.Free;\r\n fAutoCompleteList.Free;\r\nend;\r\n\r\nprocedure TCustomSynAutoComplete.DefineProperties(Filer: TFiler);\r\nbegin\r\n inherited;\r\n{$IFNDEF UNICODE}\r\n UnicodeDefineProperties(Filer, Self);\r\n{$ENDIF}\r\nend;\r\n\r\nprocedure TCustomSynAutoComplete.Execute(AEditor: TCustomSynEdit);\r\nvar\r\n s: UnicodeString;\r\n i, j: integer;\r\nbegin\r\n if AEditor <> nil then\r\n begin\r\n // get token\r\n s := AEditor.LineText;\r\n j := AEditor.CaretX;\r\n i := j - 1;\r\n if i <= Length(s) then\r\n begin\r\n while (i > 0) and (s[i] > ' ') and (Pos(s[i], fEOTokenChars) = 0) do\r\n Dec(i);\r\n Inc(i);\r\n s := Copy(s, i, j - i);\r\n ExecuteCompletion(s, AEditor);\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TCustomSynAutoComplete.ExecuteCompletion(const AToken: UnicodeString;\r\n AEditor: TCustomSynEdit);\r\nvar\r\n i, j, Len, IndentLen: integer;\r\n s: UnicodeString;\r\n IdxMaybe, NumMaybe: integer;\r\n p: TBufferCoord;\r\n NewCaretPos: boolean;\r\n Temp: TUnicodeStringList;\r\nbegin\r\n if not fParsed then\r\n ParseCompletionList;\r\n Len := Length(AToken);\r\n if (Len > 0) and (AEditor <> nil) and not AEditor.ReadOnly\r\n and (fCompletions.Count > 0) then\r\n begin\r\n // find completion for this token - not all chars necessary if unambiguous\r\n i := fCompletions.Count - 1;\r\n IdxMaybe := -1;\r\n NumMaybe := 0;\r\n if fCaseSensitive then\r\n begin\r\n while i > -1 do\r\n begin\r\n s := fCompletions[i];\r\n if WideCompareStr(s, AToken) = 0 then\r\n break\r\n else if WideCompareStr(Copy(s, 1, Len), AToken) = 0 then\r\n begin\r\n Inc(NumMaybe);\r\n IdxMaybe := i;\r\n end;\r\n Dec(i);\r\n end;\r\n end\r\n else\r\n begin\r\n while i > -1 do\r\n begin\r\n s := fCompletions[i];\r\n if WideCompareText(s, AToken) = 0 then\r\n break\r\n else if WideCompareText(Copy(s, 1, Len), AToken) = 0 then\r\n begin\r\n Inc(NumMaybe);\r\n IdxMaybe := i;\r\n end;\r\n Dec(i);\r\n end;\r\n end;\r\n if (i = -1) and (NumMaybe = 1) then\r\n i := IdxMaybe;\r\n if i > -1 then\r\n begin\r\n // select token in editor\r\n p := AEditor.CaretXY;\r\n AEditor.BeginUpdate;\r\n try\r\n AEditor.BlockBegin := BufferCoord(p.Char - Len, p.Line);\r\n AEditor.BlockEnd := p;\r\n // indent the completion string if necessary, determine the caret pos\r\n IndentLen := p.Char - Len - 1;\r\n p := AEditor.BlockBegin;\r\n NewCaretPos := False;\r\n Temp := TUnicodeStringList.Create;\r\n try\r\n Temp.Text := fCompletionValues[i];\r\n // indent lines\r\n if (IndentLen > 0) and (Temp.Count > 1) then\r\n begin\r\n s := UnicodeStringOfChar(' ', IndentLen);\r\n for i := 1 to Temp.Count - 1 do\r\n Temp[i] := s + Temp[i];\r\n end;\r\n // find first '|' and use it as caret position\r\n for i := 0 to Temp.Count - 1 do\r\n begin\r\n s := Temp[i];\r\n j := Pos('|', s);\r\n if j > 0 then\r\n begin\r\n Delete(s, j, 1);\r\n Temp[i] := s;\r\n// if j > 1 then\r\n// Dec(j);\r\n NewCaretPos := True;\r\n Inc(p.Line, i);\r\n if i = 0 then\r\n// Inc(p.x, j)\r\n Inc(p.Char, j - 1)\r\n else\r\n p.Char := j;\r\n break;\r\n end;\r\n end;\r\n s := Temp.Text;\r\n // strip the trailing #13#10 that was appended by the stringlist\r\n i := Length(s);\r\n if (i >= 2) and (s[i - 1] = #13) and (s[i] = #10) then\r\n SetLength(s, i - 2);\r\n finally\r\n Temp.Free;\r\n end;\r\n // replace the selected text and position the caret\r\n AEditor.SelText := s;\r\n if NewCaretPos then\r\n AEditor.CaretXY := p;\r\n finally\r\n AEditor.EndUpdate; \r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TCustomSynAutoComplete.GetCompletions: TUnicodeStrings;\r\nbegin\r\n if not fParsed then\r\n ParseCompletionList;\r\n Result := fCompletions;\r\nend;\r\n\r\nfunction TCustomSynAutoComplete.GetCompletionComments: TUnicodeStrings;\r\nbegin\r\n if not fParsed then\r\n ParseCompletionList;\r\n Result := fCompletionComments;\r\nend;\r\n\r\nfunction TCustomSynAutoComplete.GetCompletionValues: TUnicodeStrings;\r\nbegin\r\n if not fParsed then\r\n ParseCompletionList;\r\n Result := fCompletionValues;\r\nend;\r\n\r\nfunction TCustomSynAutoComplete.GetEditorCount: integer;\r\nbegin\r\n Result := fEditors.Count;\r\nend;\r\n\r\nfunction TCustomSynAutoComplete.GetNthEditor(Index: integer): TCustomSynEdit;\r\nbegin\r\n if (Index >= 0) and (Index < fEditors.Count) then\r\n Result := fEditors[Index]\r\n else\r\n Result := nil;\r\nend;\r\n\r\nprocedure TCustomSynAutoComplete.Notification(AComponent: TComponent;\r\n Operation: TOperation);\r\nbegin\r\n inherited Notification(AComponent, Operation);\r\n if Operation = opRemove then\r\n begin\r\n if AComponent = Editor then\r\n Editor := nil\r\n else if AComponent is TCustomSynEdit then\r\n RemoveEditor(TCustomSynEdit(AComponent));\r\n end;\r\nend;\r\n\r\nprocedure TCustomSynAutoComplete.ParseCompletionList;\r\nvar\r\n BorlandDCI: boolean;\r\n i, j, Len: integer;\r\n s, sCompl, sComment, sComplValue: UnicodeString;\r\n\r\n procedure SaveEntry;\r\n begin\r\n fCompletions.Add(sCompl);\r\n sCompl := '';\r\n fCompletionComments.Add(sComment);\r\n sComment := '';\r\n fCompletionValues.Add(sComplValue);\r\n sComplValue := '';\r\n end;\r\n\r\nbegin\r\n fCompletions.Clear;\r\n fCompletionComments.Clear;\r\n fCompletionValues.Clear;\r\n\r\n if fAutoCompleteList.Count > 0 then\r\n begin\r\n s := fAutoCompleteList[0];\r\n BorlandDCI := (s <> '') and (s[1] = '[');\r\n\r\n sCompl := '';\r\n sComment := '';\r\n sComplValue := '';\r\n for i := 0 to fAutoCompleteList.Count - 1 do\r\n begin\r\n s := fAutoCompleteList[i];\r\n Len := Length(s);\r\n if BorlandDCI then\r\n begin\r\n // the style of the Delphi32.dci file\r\n if (Len > 0) and (s[1] = '[') then\r\n begin\r\n // save last entry\r\n if sCompl <> '' then\r\n SaveEntry;\r\n // new completion entry\r\n j := 2;\r\n while (j <= Len) and (s[j] > ' ') do\r\n Inc(j);\r\n sCompl := Copy(s, 2, j - 2);\r\n // start of comment in DCI file\r\n while (j <= Len) and (s[j] <= ' ') do\r\n Inc(j);\r\n if (j <= Len) and (s[j] = '|') then\r\n Inc(j);\r\n while (j <= Len) and (s[j] <= ' ') do\r\n Inc(j);\r\n sComment := Copy(s, j, Len);\r\n if sComment[Length(sComment)] = ']' then\r\n SetLength(sComment, Length(sComment) - 1);\r\n end\r\n else\r\n begin\r\n if sComplValue <> '' then\r\n sComplValue := sComplValue + #13#10;\r\n sComplValue := sComplValue + s;\r\n end;\r\n end\r\n else\r\n begin\r\n // the original style\r\n if (Len > 0) and (s[1] <> '=') then\r\n begin\r\n // save last entry\r\n if sCompl <> '' then\r\n SaveEntry;\r\n // new completion entry\r\n sCompl := s;\r\n end\r\n else if (Len > 0) and (s[1] = '=') then\r\n begin\r\n if sComplValue <> '' then\r\n sComplValue := sComplValue + #13#10;\r\n sComplValue := sComplValue + Copy(s, 2, Len);\r\n end;\r\n end;\r\n end;\r\n if sCompl <> '' then //mg 2000-11-07\r\n SaveEntry;\r\n end;\r\n fParsed := True;\r\nend;\r\n\r\nfunction TCustomSynAutoComplete.RemoveEditor(AEditor: TCustomSynEdit): boolean;\r\nvar\r\n i: integer;\r\nbegin\r\n if AEditor <> nil then\r\n begin\r\n i := fEditors.IndexOf(AEditor);\r\n if (i > -1) then\r\n begin\r\n if fEditor = AEditor then\r\n fEditor := nil;\r\n fEditors.Delete(i);\r\n AEditor.UnregisterCommandHandler(SynEditCommandHandler);\r\n {$IFDEF SYN_COMPILER_5_UP}\r\n RemoveFreeNotification(AEditor);\r\n {$ENDIF}\r\n end;\r\n end;\r\n Result := False;\r\nend;\r\n\r\nprocedure TCustomSynAutoComplete.SetAutoCompleteList(Value: TUnicodeStrings);\r\nbegin\r\n fAutoCompleteList.Assign(Value);\r\n fParsed := False;\r\nend;\r\n\r\nprocedure TCustomSynAutoComplete.SetEditor(Value: TCustomSynEdit);\r\nbegin\r\n if Value <> fEditor then\r\n begin\r\n if fEditor <> nil then\r\n RemoveEditor(fEditor);\r\n fEditor := Value;\r\n if (Value <> nil) then\r\n AddEditor(Value);\r\n end;\r\nend;\r\n\r\nprocedure TCustomSynAutoComplete.SynEditCommandHandler(Sender: TObject;\r\n AfterProcessing: boolean; var Handled: boolean;\r\n var Command: TSynEditorCommand; var AChar: WideChar; Data: pointer;\r\n HandlerData: pointer);\r\nbegin\r\n if not AfterProcessing and not Handled and (Command = ecAutoCompletion) then\r\n begin\r\n Handled := True;\r\n Execute(Sender as TCustomSynEdit);\r\n end;\r\nend;\r\n\r\nend.\r\n\r\n" }, { "path": "External/SynEdit/Source/SynEditExport.pas", "content": "{-------------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: SynEditExport.pas, released 2000-04-16.\r\n\r\nThe Original Code is partly based on the mwExport.pas file from the\r\nmwEdit component suite by Martin Waldenburg and other developers, the Initial\r\nAuthor of this file is Michael Hieke.\r\nPortions created by Michael Hieke are Copyright 2000 Michael Hieke.\r\nPortions created by James D. Jacobson are Copyright 1999 Martin Waldenburg.\r\nUnicode translation by Mal Hrz.\r\nAll Rights Reserved.\r\n\r\nContributors to the SynEdit project are listed in the Contributors.txt file.\r\n\r\nAlternatively, the contents of this file may be used under the terms of the\r\nGNU General Public License Version 2 or later (the \"GPL\"), in which case\r\nthe provisions of the GPL are applicable instead of those above.\r\nIf you wish to allow use of your version of this file only under the terms\r\nof the GPL and not to allow others to use your version of this file\r\nunder the MPL, indicate your decision by deleting the provisions above and\r\nreplace them with the notice and other provisions required by the GPL.\r\nIf you do not delete the provisions above, a recipient may use your version\r\nof this file under either the MPL or the GPL.\r\n\r\n$Id: SynEditExport.pas,v 1.17.2.8 2008/09/17 13:59:12 maelh Exp $\r\n\r\nYou may retrieve the latest version of this file at the SynEdit home page,\r\nlocated at http://SynEdit.SourceForge.net\r\n\r\nKnown Issues:\r\n-------------------------------------------------------------------------------}\r\n\r\n{ Base class for exporting a programming language source file or part of it to\r\n a formatted output like HTML or RTF and copying this to the Windows clipboard\r\n or saving it to a file. }\r\n{$IFNDEF QSYNEDITEXPORT}\r\nunit SynEditExport;\r\n{$ENDIF}\r\n\r\n{$I SynEdit.inc}\r\n\r\ninterface\r\n\r\nuses\r\n{$IFDEF SYN_KYLIX}\r\n Libc,\r\n{$ENDIF}\r\n{$IFDEF SYN_CLX}\r\n Qt,\r\n QGraphics,\r\n QClipbrd,\r\n QSynEditHighlighter,\r\n QSynEditTypes,\r\n QSynUnicode,\r\n Types,\r\n{$ELSE}\r\n Windows,\r\n Graphics,\r\n Clipbrd,\r\n SynEditHighlighter,\r\n SynEditTypes,\r\n SynUnicode, \r\n{$ENDIF}\r\n Classes,\r\n SysUtils;\r\n\r\ntype\r\n ESynEncoding = class(ESynError);\r\n\r\n { Base exporter class, implements the buffering and the common functionality\r\n to track the changes of token attributes, to export to the clipboard or to\r\n save the output to a file. Descendant classes have to implement only the\r\n actual formatting of tokens. }\r\n TSynCustomExporter = class(TComponent)\r\n private\r\n fBuffer: TMemoryStream;\r\n FCharSize: Integer;\r\n fFirstAttribute: Boolean;\r\n FStreaming: Boolean;\r\n procedure AssignFont(Value: TFont);\r\n procedure SetEncoding(const Value: TSynEncoding);\r\n procedure SetExportAsText(Value: Boolean);\r\n procedure SetFont(Value: TFont);\r\n procedure SetHighlighter(Value: TSynCustomHighlighter);\r\n procedure SetTitle(const Value: UnicodeString);\r\n procedure SetUseBackground(const Value: Boolean);\r\n function StringSize(const AText: UnicodeString): Integer;\r\n procedure WriteString(const AText: UnicodeString);\r\n protected\r\n fBackgroundColor: TColor;\r\n fClipboardFormat: UINT;\r\n fDefaultFilter: string;\r\n FEncoding: TSynEncoding;\r\n fExportAsText: Boolean;\r\n fFont: TFont;\r\n fHighlighter: TSynCustomHighlighter;\r\n fLastBG: TColor;\r\n fLastFG: TColor;\r\n fLastStyle: TFontStyles;\r\n fTitle: UnicodeString;\r\n fUseBackground: Boolean;\r\n { Adds a string to the output buffer. }\r\n procedure AddData(const AText: UnicodeString);\r\n { Adds a string and a trailing newline to the output buffer. }\r\n procedure AddDataNewLine(const AText: UnicodeString);\r\n { Adds a newline to the output buffer. }\r\n procedure AddNewLine;\r\n { Copies the data under this format to the clipboard. The clipboard has to\r\n be opened explicitly when more than one format is to be set. }\r\n procedure CopyToClipboardFormat(AFormat: UINT);\r\n procedure DefineProperties(Filer: TFiler); override;\r\n { Has to be overridden in descendant classes to add the closing format\r\n strings to the output buffer. The parameters can be used to track what\r\n changes are made for the next token. }\r\n procedure FormatAttributeDone(BackgroundChanged, ForegroundChanged: Boolean;\r\n FontStylesChanged: TFontStyles); virtual; abstract;\r\n { Has to be overridden in descendant classes to add the opening format\r\n strings to the output buffer. The parameters can be used to track what\r\n changes have been made in respect to the previous token. }\r\n procedure FormatAttributeInit(BackgroundChanged, ForegroundChanged: Boolean;\r\n FontStylesChanged: TFontStyles); virtual; abstract;\r\n { Has to be overridden in descendant classes to add the closing format\r\n strings to the output buffer after the last token has been written. }\r\n procedure FormatAfterLastAttribute; virtual; abstract;\r\n { Has to be overridden in descendant classes to add the opening format\r\n strings to the output buffer when the first token is about to be written. }\r\n procedure FormatBeforeFirstAttribute(BackgroundChanged,\r\n ForegroundChanged: Boolean; FontStylesChanged: TFontStyles);\r\n virtual; abstract;\r\n { Has to be overridden in descendant classes to add the formatted text of\r\n the actual token text to the output buffer. }\r\n procedure FormatToken(Token: UnicodeString); virtual;\r\n { Has to be overridden in descendant classes to add a newline in the output\r\n format to the output buffer. }\r\n procedure FormatNewLine; virtual; abstract;\r\n { Returns the size of the formatted text in the output buffer, to be used\r\n in the format header or footer. }\r\n function GetBufferSize: integer;\r\n { The clipboard format the exporter creates as native format. }\r\n function GetClipboardFormat: UINT; virtual;\r\n { Has to be overridden in descendant classes to return the correct output\r\n format footer. }\r\n function GetFooter: UnicodeString; virtual; abstract;\r\n { Has to be overridden in descendant classes to return the name of the\r\n output format. }\r\n function GetFormatName: string; virtual;\r\n { Has to be overridden in descendant classes to return the correct output\r\n format header. }\r\n function GetHeader: UnicodeString; virtual; abstract;\r\n { Inserts a data block at the given position into the output buffer. Is\r\n used to insert the format header after the exporting, since some header\r\n data may be known only after the conversion is done. }\r\n procedure InsertData(APos: Integer; const AText: UnicodeString);\r\n function ReplaceReservedChar(AChar: WideChar): UnicodeString; virtual; abstract;\r\n { Returns a string that has all the invalid chars of the output format\r\n replaced with the entries in the replacement array. }\r\n function ReplaceReservedChars(AToken: UnicodeString): UnicodeString;\r\n { Sets the token attribute of the next token to determine the changes\r\n of colors and font styles so the properties of the next token can be\r\n added to the output buffer. }\r\n procedure SetTokenAttribute(Attri: TSynHighlighterAttributes); virtual;\r\n function UseBom: Boolean; virtual; abstract;\r\n public\r\n { Creates an instance of the exporter. }\r\n constructor Create(AOwner: TComponent); override;\r\n { Destroys an instance of the exporter. }\r\n destructor Destroy; override;\r\n { Clears the output buffer and any internal data that relates to the last\r\n exported text. }\r\n procedure Clear; virtual;\r\n { Copies the output buffer contents to the clipboard, as the native format\r\n or as text depending on the ExportAsText property. }\r\n procedure CopyToClipboard;\r\n { Exports everything in the strings parameter to the output buffer. }\r\n procedure ExportAll(ALines: TUnicodeStrings);\r\n { Exports the given range of the strings parameter to the output buffer. }\r\n procedure ExportRange(ALines: TUnicodeStrings; Start, Stop: TBufferCoord);\r\n { Saves the contents of the output buffer to a file. }\r\n procedure SaveToFile(const FileName: UnicodeString);\r\n { Saves the contents of the output buffer to a stream. }\r\n procedure SaveToStream(Stream: TStream);\r\n function SupportedEncodings: TSynEncodings; virtual; abstract;\r\n public\r\n { Default background color for text that has no token attribute assigned or\r\n for token attributes that have the background set to default. }\r\n property Color: TColor read fBackgroundColor write fBackgroundColor;\r\n { Filter string for the output format for SaveAs file dialogs. }\r\n property DefaultFilter: string read fDefaultFilter write fDefaultFilter;\r\n property Encoding: TSynEncoding read FEncoding write SetEncoding default seUTF8;\r\n property ExportAsText: Boolean read fExportAsText write SetExportAsText;\r\n { The font to be used for the output format. The font color is used for text\r\n that has no token attribute assigned or for token attributes that have\r\n the background set to default. }\r\n property Font: TFont read fFont write SetFont;\r\n { The output format of the exporter. }\r\n property FormatName: string read GetFormatName;\r\n { The highlighter to use for exporting. }\r\n property Highlighter: TSynCustomHighlighter\r\n read fHighlighter write SetHighlighter;\r\n { The title to embedd into the output header. }\r\n property Title: UnicodeString read fTitle write SetTitle;\r\n { Use the token attribute background for the exporting. }\r\n property UseBackground: Boolean read fUseBackground write SetUseBackground;\r\n end;\r\n\r\nconst\r\n EncodingStrs: array[TSynEncoding] of string =\r\n ('UTF-8', 'UTF-16 Little Endian', 'UTF-16 Big Endian', 'ANSI');\r\n\r\nresourcestring\r\n SEncodingError = '%s encoding is not supported by %s-exporter';\r\n\r\nimplementation\r\n\r\nuses\r\n{$IFDEF SYN_COMPILER_4_UP}\r\n Math,\r\n{$ENDIF}\r\n{$IFDEF SYN_CLX}\r\n QSynEditMiscProcs,\r\n QSynEditStrConst;\r\n{$ELSE}\r\n SynEditMiscProcs,\r\n SynEditStrConst;\r\n{$ENDIF}\r\n\r\n{ TSynCustomExporter }\r\n\r\nconstructor TSynCustomExporter.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n fBuffer := TMemoryStream.Create;\r\n{$IFNDEF SYN_CLX}\r\n fClipboardFormat := CF_TEXT;\r\n{$ENDIF}\r\n FCharSize := 1;\r\n FEncoding := seUTF8;\r\n fFont := TFont.Create;\r\n fBackgroundColor := clWindow;\r\n AssignFont(nil);\r\n Clear;\r\n fTitle := SYNS_Untitled;\r\nend;\r\n\r\ndestructor TSynCustomExporter.Destroy;\r\nbegin\r\n fFont.Free;\r\n fBuffer.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TSynCustomExporter.AddData(const AText: UnicodeString);\r\nbegin\r\n if AText <> '' then\r\n begin\r\n WriteString(AText);\r\n fBuffer.SetSize(fBuffer.Position);\r\n end;\r\nend;\r\n\r\nprocedure TSynCustomExporter.AddDataNewLine(const AText: UnicodeString);\r\nbegin\r\n AddData(AText);\r\n AddNewLine;\r\nend;\r\n\r\nprocedure TSynCustomExporter.AddNewLine;\r\nbegin\r\n WriteString(WideCRLF);\r\n fBuffer.SetSize(fBuffer.Position);\r\nend;\r\n\r\nprocedure TSynCustomExporter.AssignFont(Value: TFont);\r\nbegin\r\n if Value <> nil then\r\n fFont.Assign(Value)\r\n else\r\n begin\r\n fFont.Name := 'Courier New';\r\n fFont.Size := 10;\r\n fFont.Color := clWindowText;\r\n fFont.Style := [];\r\n end;\r\nend;\r\n\r\nprocedure TSynCustomExporter.Clear;\r\nbegin\r\n fBuffer.Position := 0;\r\n // Size is ReadOnly in Delphi 2\r\n fBuffer.SetSize(0);\r\n fLastStyle := [];\r\n fLastBG := clWindow;\r\n fLastFG := clWindowText;\r\nend;\r\n\r\nprocedure SetClipboardText(Text: UnicodeString);\r\n{$IFDEF SYN_CLX}\r\nbegin\r\n Clipboard.AsText := Text;\r\nend;\r\n{$ELSE}\r\nvar\r\n Mem: HGLOBAL;\r\n P: PByte;\r\n SLen: Integer;\r\nbegin\r\n SLen := Length(Text);\r\n Clipboard.Open;\r\n try\r\n Clipboard.Clear;\r\n\r\n // set ANSI text only on Win9X, WinNT automatically creates ANSI from Unicode\r\n if Win32Platform <> VER_PLATFORM_WIN32_NT then\r\n begin\r\n Mem := GlobalAlloc(GMEM_MOVEABLE or GMEM_DDESHARE, SLen + 1);\r\n if Mem <> 0 then\r\n begin\r\n P := GlobalLock(Mem);\r\n try\r\n if P <> nil then\r\n begin\r\n Move(PAnsiChar(AnsiString(Text))^, P^, SLen + 1);\r\n Clipboard.SetAsHandle(CF_TEXT, Mem);\r\n end;\r\n finally\r\n GlobalUnlock(Mem);\r\n end;\r\n end;\r\n end;\r\n\r\n // set unicode text, this also works on Win9X, even if the clipboard-viewer\r\n // can't show it, Word 2000+ can paste it including the unicode only characters\r\n Mem := GlobalAlloc(GMEM_MOVEABLE or GMEM_DDESHARE,\r\n (SLen + 1) * sizeof(WideChar));\r\n if Mem <> 0 then\r\n begin\r\n P := GlobalLock(Mem);\r\n try\r\n if P <> nil then\r\n begin\r\n Move(PWideChar(Text)^, P^, (SLen + 1) * sizeof(WideChar));\r\n Clipboard.SetAsHandle(CF_UNICODETEXT, Mem);\r\n end;\r\n finally\r\n GlobalUnlock(Mem);\r\n end;\r\n end;\r\n // Don't free Mem! It belongs to the clipboard now, and it will free it\r\n // when it is done with it.\r\n finally\r\n Clipboard.Close;\r\n end;\r\nend;\r\n{$ENDIF}\r\n\r\nprocedure TSynCustomExporter.CopyToClipboard;\r\nconst\r\n Nulls: array[0..1] of Byte = (0, 0);\r\nvar\r\n S: UnicodeString;\r\nbegin\r\n if fExportAsText then\r\n begin\r\n fBuffer.Position := fBuffer.Size;\r\n fBuffer.Write(Nulls, FCharSize);\r\n case Encoding of\r\n seUTF16LE:\r\n S := PWideChar(fBuffer.Memory);\r\n seUTF16BE:\r\n begin\r\n S := PWideChar(fBuffer.Memory);\r\n StrSwapByteOrder(PWideChar(S));\r\n end;\r\n seUTF8:\r\n{$IFDEF UNICODE}\r\n S := UTF8ToUnicodeString(PAnsiChar(fBuffer.Memory));\r\n{$ELSE}\r\n S := UTF8Decode(PAnsiChar(fBuffer.Memory));\r\n{$ENDIF}\r\n seAnsi:\r\n S := UnicodeString(PAnsiChar(fBuffer.Memory));\r\n end;\r\n SetClipboardText(S);\r\n end\r\n else\r\n CopyToClipboardFormat(GetClipboardFormat);\r\nend;\r\n\r\nprocedure TSynCustomExporter.CopyToClipboardFormat(AFormat: UINT);\r\n{$IFNDEF SYN_CLX}\r\nvar\r\n hData: THandle;\r\n hDataSize: UINT;\r\n PtrData: PByte;\r\n{$ENDIF}\r\nbegin\r\n{$IFNDEF SYN_CLX}\r\n hDataSize := GetBufferSize + 1;\r\n hData := GlobalAlloc(GMEM_MOVEABLE or GMEM_ZEROINIT or GMEM_SHARE, hDataSize);\r\n if hData <> 0 then\r\n try\r\n PtrData := GlobalLock(hData);\r\n if Assigned(PtrData) then\r\n begin\r\n try\r\n fBuffer.Position := 0;\r\n fBuffer.Read(PtrData^, hDataSize - 1); // trailing #0\r\n finally\r\n GlobalUnlock(hData);\r\n end;\r\n Clipboard.SetAsHandle(AFormat, hData);\r\n end\r\n else\r\n Abort;\r\n except\r\n GlobalFree(hData);\r\n OutOfMemoryError;\r\n end;\r\n{$ENDIF}\r\nend;\r\n\r\nprocedure TSynCustomExporter.DefineProperties(Filer: TFiler);\r\nbegin\r\n inherited;\r\n{$IFNDEF UNICODE}\r\n UnicodeDefineProperties(Filer, Self);\r\n{$ENDIF}\r\nend;\r\n\r\nprocedure TSynCustomExporter.ExportAll(ALines: TUnicodeStrings);\r\nbegin\r\n ExportRange(ALines, BufferCoord(1, 1), BufferCoord(MaxInt, MaxInt));\r\nend;\r\n\r\nprocedure TSynCustomExporter.ExportRange(ALines: TUnicodeStrings; Start, Stop: TBufferCoord);\r\nvar\r\n i: Integer;\r\n Line, Token: UnicodeString;\r\n Attri: TSynHighlighterAttributes;\r\nbegin\r\n FStreaming := True;\r\n try\r\n // abort if not all necessary conditions are met\r\n if not Assigned(ALines) or not Assigned(Highlighter) or (ALines.Count = 0)\r\n or (Start.Line > ALines.Count) or (Start.Line > Stop.Line)\r\n then\r\n {$IFDEF SYN_CLX}\r\n exit;\r\n {$ELSE}\r\n Abort;\r\n {$ENDIF}\r\n Stop.Line := Max(1, Min(Stop.Line, ALines.Count));\r\n Stop.Char := Max(1, Min(Stop.Char, Length(ALines[Stop.Line - 1]) + 1));\r\n Start.Char := Max(1, Min(Start.Char, Length(ALines[Start.Line - 1]) + 1));\r\n if (Start.Line = Stop.Line) and (Start.Char >= Stop.Char) then\r\n {$IFDEF SYN_CLX}\r\n exit;\r\n {$ELSE}\r\n Abort;\r\n {$ENDIF}\r\n // initialization\r\n fBuffer.Position := 0;\r\n // Size is ReadOnly in Delphi 2\r\n fBuffer.SetSize(Max($1000, (Stop.Line - Start.Line) * 128) * FCharSize);\r\n Highlighter.ResetRange;\r\n // export all the lines into fBuffer\r\n fFirstAttribute := True;\r\n for i := Start.Line to Stop.Line do\r\n begin\r\n Line := ALines[i - 1];\r\n // order is important, since Start.Y might be equal to Stop.Y\r\n if i = Stop.Line then\r\n Delete(Line, Stop.Char, MaxInt);\r\n if (i = Start.Line) and (Start.Char > 1) then\r\n Delete(Line, 1, Start.Char - 1);\r\n // export the line\r\n Highlighter.SetLine(Line, i);\r\n while not Highlighter.GetEOL do\r\n begin\r\n Attri := Highlighter.GetTokenAttribute;\r\n if Assigned(Attri) then // The .pas highlighter, for example, can return a nil Attri above for a trailing EOF/null that was loaded from a stream\r\n begin\r\n Token := ReplaceReservedChars(Highlighter.GetToken);\r\n SetTokenAttribute(Attri);\r\n FormatToken(Token);\r\n end;\r\n Highlighter.Next;\r\n end;\r\n FormatNewLine;\r\n end;\r\n if not fFirstAttribute then\r\n FormatAfterLastAttribute;\r\n\r\n // insert header\r\n InsertData(0, GetHeader);\r\n // add footer\r\n AddData(GetFooter);\r\n finally\r\n FStreaming := False\r\n end\r\nend;\r\n\r\nprocedure TSynCustomExporter.FormatToken(Token: UnicodeString);\r\nbegin\r\n AddData(Token);\r\nend;\r\n\r\nfunction TSynCustomExporter.GetBufferSize: integer;\r\nbegin\r\n Result := fBuffer.Size;\r\nend;\r\n\r\nfunction TSynCustomExporter.GetClipboardFormat: UINT;\r\nbegin\r\n Result := fClipboardFormat;\r\nend;\r\n\r\nfunction TSynCustomExporter.GetFormatName: string;\r\nbegin\r\n Result := '';\r\nend;\r\n\r\nprocedure TSynCustomExporter.InsertData(APos: Integer; const AText: UnicodeString);\r\nvar\r\n Size, ToMove, SizeNeeded: Integer;\r\n Dest: PByte;\r\nbegin\r\n Size := StringSize(AText);\r\n if Size > 0 then\r\n begin\r\n ToMove := fBuffer.Position;\r\n SizeNeeded := ToMove + Size;\r\n if fBuffer.Size < SizeNeeded then\r\n // Size is ReadOnly in Delphi 2\r\n fBuffer.SetSize((SizeNeeded + $1800) and not $FFF); // increment in pages\r\n Dest := fBuffer.Memory;\r\n Inc(Dest, Size);\r\n Move(fBuffer.Memory^, Dest^, ToMove);\r\n fBuffer.Position := 0;\r\n WriteString(AText);\r\n fBuffer.Position := ToMove + Size;\r\n fBuffer.SetSize(fBuffer.Position);\r\n end;\r\nend;\r\n\r\nfunction TSynCustomExporter.ReplaceReservedChars(AToken: UnicodeString): UnicodeString;\r\nvar\r\n I, ISrc, IDest, SrcLen, DestLen: Integer;\r\n Replace: UnicodeString;\r\n c: WideChar; //mh 2000-10-10\r\nbegin\r\n if AToken <> '' then\r\n begin\r\n SrcLen := Length(AToken);\r\n ISrc := 1;\r\n DestLen := SrcLen;\r\n IDest := 1;\r\n SetLength(Result, DestLen);\r\n while ISrc <= SrcLen do\r\n begin\r\n c := AToken[ISrc];\r\n Replace := ReplaceReservedChar(c);\r\n if Replace <> '' then\r\n Inc(ISrc)\r\n else\r\n begin\r\n if IDest > DestLen then\r\n begin\r\n Inc(DestLen, 32);\r\n SetLength(Result, DestLen);\r\n end;\r\n Result[IDest] := c;\r\n Inc(ISrc);\r\n Inc(IDest);\r\n continue;\r\n end;\r\n if IDest + Length(Replace) - 1 > DestLen then\r\n begin\r\n Inc(DestLen, Max(32, IDest + Length(Replace) - DestLen));\r\n SetLength(Result, DestLen);\r\n end;\r\n for I := 1 to Length(Replace) do\r\n begin\r\n Result[IDest] := Replace[I];\r\n Inc(IDest);\r\n end;\r\n end;\r\n SetLength(Result, IDest - 1);\r\n end\r\n else\r\n Result := '';\r\nend;\r\n\r\nprocedure TSynCustomExporter.SaveToFile(const FileName: UnicodeString);\r\nvar\r\n Stream: TStream;\r\nbegin\r\n Stream := TWideFileStream.Create(FileName, fmCreate);\r\n try\r\n SaveToStream(Stream);\r\n finally\r\n Stream.Free;\r\n end;\r\nend;\r\n\r\nprocedure TSynCustomExporter.SaveToStream(Stream: TStream);\r\nbegin\r\n if UseBOM then\r\n case Encoding of\r\n seUTF8:\r\n Stream.WriteBuffer(UTF8BOM, 3);\r\n seUTF16LE:\r\n Stream.WriteBuffer(UTF16BOMLE, 2);\r\n seUTF16BE:\r\n Stream.WriteBuffer(UTF16BOMBE, 2);\r\n end;\r\n fBuffer.Position := 0;\r\n fBuffer.SaveToStream(Stream);\r\nend;\r\n\r\nprocedure TSynCustomExporter.SetEncoding(const Value: TSynEncoding);\r\nbegin\r\n // don't change encoding while streaming as this could corrupt output data\r\n if FStreaming then exit;\r\n\r\n if not (Value in SupportedEncodings) then\r\n raise ESynEncoding.CreateFmt(SEncodingError, [EncodingStrs[Value],\r\n GetFormatName]);\r\n\r\n FEncoding := Value;\r\n if Value in [seUTF8, seAnsi] then\r\n FCharSize := 1\r\n else if Value in [seUTF16LE, seUTF16BE] then\r\n FCharSize := 2;\r\nend;\r\n\r\nprocedure TSynCustomExporter.SetExportAsText(Value: Boolean);\r\nbegin\r\n if fExportAsText <> Value then\r\n begin\r\n fExportAsText := Value;\r\n Clear;\r\n end;\r\nend;\r\n\r\nprocedure TSynCustomExporter.SetFont(Value: TFont);\r\nbegin\r\n AssignFont(Value);\r\nend;\r\n\r\nprocedure TSynCustomExporter.SetHighlighter(Value: TSynCustomHighlighter);\r\nbegin\r\n if fHighlighter <> Value then\r\n begin\r\n if fHighlighter <> nil then\r\n fHighlighter.FreeNotification(Self);\r\n fHighlighter := Value;\r\n Clear;\r\n if Assigned(fHighlighter) and Assigned(fHighlighter.WhitespaceAttribute) and fUseBackground then\r\n fBackgroundColor := fHighlighter.WhitespaceAttribute.Background;\r\n end;\r\nend;\r\n\r\nprocedure TSynCustomExporter.SetTitle(const Value: UnicodeString);\r\nbegin\r\n if fTitle <> Value then\r\n begin\r\n if Value <> '' then\r\n fTitle := Value\r\n else\r\n fTitle := SYNS_Untitled;\r\n end;\r\nend;\r\n\r\nprocedure TSynCustomExporter.SetTokenAttribute(Attri: TSynHighlighterAttributes);\r\nvar\r\n ChangedBG: Boolean;\r\n ChangedFG: Boolean;\r\n ChangedStyles: TFontStyles;\r\n\r\n function ValidatedColor(AColor, ADefColor: TColor): TColor;\r\n begin\r\n if AColor = clNone then\r\n Result := ColorToRGB(ADefColor)\r\n else\r\n Result := ColorToRGB(AColor);\r\n end;\r\n\r\nbegin\r\n if fFirstAttribute then\r\n begin\r\n fFirstAttribute := False;\r\n fLastBG := ValidatedColor(Attri.Background, fBackgroundColor);\r\n fLastFG := ValidatedColor(Attri.Foreground, fFont.Color);\r\n fLastStyle := Attri.Style;\r\n FormatBeforeFirstAttribute(UseBackground and (fLastBG <> fBackgroundColor),\r\n fLastFG <> fFont.Color, Attri.Style);\r\n end\r\n else\r\n begin\r\n ChangedBG := UseBackground and\r\n (fLastBG <> ValidatedColor(Attri.Background, fBackgroundColor));\r\n ChangedFG := (fLastFG <> ValidatedColor(Attri.Foreground, fFont.Color));\r\n // which font style bits are to be reset?\r\n ChangedStyles := fLastStyle - Attri.Style;\r\n if ChangedBG or ChangedFG or (fLastStyle <> Attri.Style) then\r\n begin\r\n FormatAttributeDone(ChangedBG, ChangedFG, ChangedStyles);\r\n // which font style bits are to be set?\r\n ChangedStyles := Attri.Style - fLastStyle;\r\n fLastBG := ValidatedColor(Attri.Background, fBackgroundColor);\r\n fLastFG := ValidatedColor(Attri.Foreground, fFont.Color);\r\n fLastStyle := Attri.Style;\r\n FormatAttributeInit(ChangedBG, ChangedFG, ChangedStyles);\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TSynCustomExporter.SetUseBackground(const Value: Boolean);\r\nbegin\r\n fUseBackground := Value;\r\n if Assigned(fHighlighter) and Assigned(fHighlighter.WhitespaceAttribute) and fUseBackground then\r\n fBackgroundColor := fHighlighter.WhitespaceAttribute.Background;\r\nend;\r\n\r\nfunction TSynCustomExporter.StringSize(const AText: UnicodeString): Integer;\r\nbegin\r\n Result := 0;\r\n case Encoding of\r\n seUTF8:\r\n Result := Length(UTF8Encode(AText));\r\n seUTF16LE, seUTF16BE:\r\n Result := Length(AText);\r\n seAnsi:\r\n Result := Length(AnsiString(PWideChar(AText)));\r\n end;\r\n Result := Result * FCharSize;\r\nend;\r\n\r\nprocedure TSynCustomExporter.WriteString(const AText: UnicodeString);\r\nvar\r\n UTF8Str: UTF8String;\r\n AnsiStr: AnsiString;\r\nbegin\r\n case Encoding of\r\n seUTF8:\r\n begin\r\n UTF8Str := UTF8Encode(AText);\r\n fBuffer.WriteBuffer(UTF8Str[1], Length(UTF8Str));\r\n end;\r\n seUTF16LE:\r\n fBuffer.WriteBuffer(AText[1], Length(AText) * sizeof(WideChar));\r\n seUTF16BE:\r\n begin\r\n StrSwapByteOrder(PWideChar(AText));\r\n fBuffer.WriteBuffer(AText[1], Length(AText) * sizeof(WideChar));\r\n end;\r\n seAnsi:\r\n begin\r\n AnsiStr := AnsiString(PWideChar(AText));\r\n fBuffer.WriteBuffer(AnsiStr[1], Length(AnsiStr));\r\n end;\r\n end;\r\nend;\r\n\r\n\r\nend.\r\n\r\n" }, { "path": "External/SynEdit/Source/SynEditHighlighter.pas", "content": "{-------------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: SynEditHighlighter.pas, released 2000-04-07.\r\n\r\nThe Original Code is based on mwHighlighter.pas by Martin Waldenburg, part of\r\nthe mwEdit component suite.\r\nPortions created by Martin Waldenburg are Copyright (C) 1998 Martin Waldenburg.\r\nUnicode translation by Mal Hrz.\r\nOptions property added by CodehunterWorks\r\nAll Rights Reserved.\r\n\r\nContributors to the SynEdit and mwEdit projects are listed in the\r\nContributors.txt file.\r\n\r\n$Id: SynEditHighlighter.pas,v 1.9.1 2012/09/12 08:17:19 CodehunterWorks Exp $\r\n\r\nYou may retrieve the latest version of this file at the SynEdit home page,\r\nlocated at http://SynEdit.SourceForge.net\r\n\r\nKnown Issues:\r\n-------------------------------------------------------------------------------}\r\n\r\n{$IFNDEF QSYNEDITHIGHLIGHTER}\r\nunit SynEditHighlighter;\r\n{$ENDIF}\r\n\r\n{$I SynEdit.inc}\r\n\r\ninterface\r\n\r\nuses\r\n{$IFDEF SYN_CLX}\r\n kTextDrawer,\r\n Types,\r\n QGraphics,\r\n QSynEditTypes,\r\n QSynEditMiscClasses,\r\n QSynUnicode,\r\n{$ELSE}\r\n Graphics,\r\n Windows,\r\n Registry,\r\n IniFiles,\r\n SynEditTypes,\r\n SynEditMiscClasses,\r\n SynUnicode,\r\n{$ENDIF}\r\n SysUtils,\r\n Classes,\r\n SynEditHighlighterOptions;\r\n\r\n{$IFNDEF SYN_CLX}\r\ntype\r\n TBetterRegistry = SynEditMiscClasses.TBetterRegistry;\r\n{$ENDIF}\r\n\r\ntype\r\n TSynHighlighterAttributes = class(TPersistent)\r\n private\r\n fBackground: TColor;\r\n fBackgroundDefault: TColor;\r\n fForeground: TColor;\r\n fForegroundDefault: TColor;\r\n fFriendlyName: UnicodeString;\r\n fName: string;\r\n fStyle: TFontStyles;\r\n fStyleDefault: TFontStyles;\r\n fOnChange: TNotifyEvent;\r\n procedure Changed; virtual;\r\n function GetBackgroundColorStored: Boolean;\r\n function GetForegroundColorStored: Boolean;\r\n function GetFontStyleStored: Boolean;\r\n procedure SetBackground(Value: TColor);\r\n procedure SetForeground(Value: TColor);\r\n procedure SetStyle(Value: TFontStyles);\r\n function GetStyleFromInt: Integer;\r\n procedure SetStyleFromInt(const Value: Integer);\r\n public\r\n procedure Assign(Source: TPersistent); override;\r\n procedure AssignColorAndStyle(Source: TSynHighlighterAttributes);\r\n constructor Create(AName: string; AFriendlyName: UnicodeString);\r\n procedure InternalSaveDefaultValues;\r\n{$IFNDEF SYN_CLX}\r\n function LoadFromBorlandRegistry(RootKey: HKEY; AttrKey, AttrName: string;\r\n OldStyle: Boolean): Boolean; virtual;\r\n function LoadFromRegistry(Reg: TBetterRegistry): Boolean;\r\n function SaveToRegistry(Reg: TBetterRegistry): Boolean;\r\n function LoadFromFile(Ini: TIniFile): Boolean;\r\n function SaveToFile(Ini: TIniFile): Boolean;\r\n{$ENDIF}\r\n public\r\n property FriendlyName: UnicodeString read fFriendlyName;\r\n property IntegerStyle: Integer read GetStyleFromInt write SetStyleFromInt;\r\n property Name: string read fName;\r\n property OnChange: TNotifyEvent read fOnChange write fOnChange;\r\n published\r\n property Background: TColor read fBackground write SetBackground\r\n stored GetBackgroundColorStored;\r\n property Foreground: TColor read fForeground write SetForeground\r\n stored GetForegroundColorStored;\r\n property Style: TFontStyles read fStyle write SetStyle\r\n stored GetFontStyleStored;\r\n end;\r\n\r\n TSynHighlighterCapability = (\r\n hcUserSettings, // supports Enum/UseUserSettings\r\n hcRegistry // supports LoadFrom/SaveToRegistry\r\n );\r\n\r\n TSynHighlighterCapabilities = set of TSynHighlighterCapability;\r\n\r\nconst\r\n SYN_ATTR_COMMENT = 0;\r\n SYN_ATTR_IDENTIFIER = 1;\r\n SYN_ATTR_KEYWORD = 2;\r\n SYN_ATTR_STRING = 3;\r\n SYN_ATTR_WHITESPACE = 4;\r\n SYN_ATTR_SYMBOL = 5;\r\n\r\ntype\r\n TSynCustomHighlighter = class(TComponent)\r\n private\r\n fAttributes: TStringList;\r\n fAttrChangeHooks: TSynNotifyEventChain;\r\n fUpdateCount: Integer;\r\n fEnabled: Boolean;\r\n FAdditionalWordBreakChars: TSysCharSet;\r\n FAdditionalIdentChars: TSysCharSet;\r\n FExportName: string;\r\n FOptions: TSynEditHighlighterOptions;\r\n function GetExportName: string;\r\n procedure SetEnabled(const Value: Boolean);\r\n procedure SetAdditionalIdentChars(const Value: TSysCharSet);\r\n procedure SetAdditionalWordBreakChars(const Value: TSysCharSet);\r\n protected\r\n fCasedLine: PWideChar;\r\n fCasedLineStr: UnicodeString;\r\n fCaseSensitive: Boolean;\r\n fDefaultFilter: string;\r\n fExpandedLine: PWideChar;\r\n fExpandedLineLen: Integer;\r\n fExpandedLineStr: UnicodeString;\r\n fExpandedTokenPos: Integer;\r\n fLine: PWideChar;\r\n fLineLen: Integer;\r\n fLineStr: UnicodeString;\r\n fLineNumber: Integer;\r\n fStringLen: Integer;\r\n fToIdent: PWideChar;\r\n fTokenPos: Integer;\r\n fUpdateChange: Boolean;\r\n Run: Integer;\r\n ExpandedRun: Integer;\r\n fOldRun: Integer;\r\n procedure Loaded; override;\r\n procedure AddAttribute(Attri: TSynHighlighterAttributes);\r\n procedure DefHighlightChange(Sender: TObject);\r\n procedure DefineProperties(Filer: TFiler); override;\r\n procedure FreeHighlighterAttributes;\r\n function GetAttribCount: Integer; virtual;\r\n function GetAttribute(Index: Integer): TSynHighlighterAttributes; virtual;\r\n function GetDefaultAttribute(Index: Integer): TSynHighlighterAttributes;\r\n virtual; abstract;\r\n function GetDefaultFilter: string; virtual;\r\n function GetSampleSource: UnicodeString; virtual;\r\n procedure DoSetLine(const Value: UnicodeString; LineNumber: Integer); virtual;\r\n function IsCurrentToken(const Token: UnicodeString): Boolean; virtual;\r\n function IsFilterStored: Boolean; virtual;\r\n function IsLineEnd(Run: Integer): Boolean; virtual;\r\n procedure SetAttributesOnChange(AEvent: TNotifyEvent);\r\n procedure SetDefaultFilter(Value: string); virtual;\r\n procedure SetSampleSource(Value: UnicodeString); virtual;\r\n protected\r\n function GetCapabilitiesProp: TSynHighlighterCapabilities;\r\n function GetFriendlyLanguageNameProp: UnicodeString;\r\n function GetLanguageNameProp: string;\r\n public\r\n class function GetCapabilities: TSynHighlighterCapabilities; virtual;\r\n class function GetFriendlyLanguageName: UnicodeString; virtual;\r\n class function GetLanguageName: string; virtual;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n procedure Assign(Source: TPersistent); override;\r\n procedure BeginUpdate;\r\n procedure EndUpdate;\r\n function GetEol: Boolean; virtual; abstract;\r\n function GetExpandedToken: UnicodeString; virtual;\r\n function GetExpandedTokenPos: Integer; virtual;\r\n function GetKeyWords(TokenKind: Integer): UnicodeString; virtual;\r\n function GetRange: Pointer; virtual;\r\n function GetToken: UnicodeString; virtual;\r\n function GetTokenAttribute: TSynHighlighterAttributes; virtual; abstract;\r\n function GetTokenKind: Integer; virtual; abstract;\r\n function GetTokenPos: Integer; virtual;\r\n function IsKeyword(const AKeyword: UnicodeString): Boolean; virtual;\r\n procedure Next; virtual;\r\n procedure NextToEol;\r\n function PosToExpandedPos(Pos: Integer): Integer;\r\n procedure SetLineExpandedAtWideGlyphs(const Line, ExpandedLine: UnicodeString;\r\n LineNumber: Integer); virtual;\r\n procedure SetLine(const Value: UnicodeString; LineNumber: Integer); virtual;\r\n procedure SetRange(Value: Pointer); virtual;\r\n procedure ResetRange; virtual;\r\n function UseUserSettings(settingIndex: Integer): Boolean; virtual;\r\n procedure EnumUserSettings(Settings: TStrings); virtual;\r\n{$IFNDEF SYN_CLX}\r\n function LoadFromRegistry(RootKey: HKEY; Key: string): Boolean; virtual;\r\n function SaveToRegistry(RootKey: HKEY; Key: string): Boolean; virtual;\r\n function LoadFromFile(AFileName: string): Boolean;\r\n function SaveToFile(AFileName: string): Boolean;\r\n{$ENDIF}\r\n procedure HookAttrChangeEvent(ANotifyEvent: TNotifyEvent);\r\n procedure UnhookAttrChangeEvent(ANotifyEvent: TNotifyEvent);\r\n function IsIdentChar(AChar: WideChar): Boolean; virtual;\r\n function IsWhiteChar(AChar: WideChar): Boolean; virtual;\r\n function IsWordBreakChar(AChar: WideChar): Boolean; virtual;\r\n property FriendlyLanguageName: UnicodeString read GetFriendlyLanguageNameProp;\r\n property LanguageName: string read GetLanguageNameProp;\r\n public\r\n property AdditionalIdentChars: TSysCharSet read FAdditionalIdentChars write SetAdditionalIdentChars;\r\n property AdditionalWordBreakChars: TSysCharSet read FAdditionalWordBreakChars write SetAdditionalWordBreakChars;\r\n property AttrCount: Integer read GetAttribCount;\r\n property Attribute[Index: Integer]: TSynHighlighterAttributes\r\n read GetAttribute;\r\n property Capabilities: TSynHighlighterCapabilities read GetCapabilitiesProp;\r\n property SampleSource: UnicodeString read GetSampleSource write SetSampleSource;\r\n property CommentAttribute: TSynHighlighterAttributes\r\n index SYN_ATTR_COMMENT read GetDefaultAttribute;\r\n property IdentifierAttribute: TSynHighlighterAttributes\r\n index SYN_ATTR_IDENTIFIER read GetDefaultAttribute;\r\n property KeywordAttribute: TSynHighlighterAttributes\r\n index SYN_ATTR_KEYWORD read GetDefaultAttribute;\r\n property StringAttribute: TSynHighlighterAttributes\r\n index SYN_ATTR_STRING read GetDefaultAttribute;\r\n property SymbolAttribute: TSynHighlighterAttributes\r\n index SYN_ATTR_SYMBOL read GetDefaultAttribute;\r\n property WhitespaceAttribute: TSynHighlighterAttributes\r\n index SYN_ATTR_WHITESPACE read GetDefaultAttribute;\r\n property ExportName: string read GetExportName;\r\n published\r\n property DefaultFilter: string read GetDefaultFilter write SetDefaultFilter\r\n stored IsFilterStored;\r\n property Enabled: Boolean read fEnabled write SetEnabled default True;\r\n property Options: TSynEditHighlighterOptions read FOptions write FOptions; // <-- Codehunter patch\r\n end;\r\n\r\n TSynCustomHighlighterClass = class of TSynCustomHighlighter;\r\n\r\n{$IFNDEF SYN_CPPB_1}\r\n TSynHighlighterList = class(TList)\r\n private\r\n hlList: TList;\r\n function GetItem(Index: Integer): TSynCustomHighlighterClass;\r\n public\r\n constructor Create;\r\n destructor Destroy; override;\r\n function Count: Integer;\r\n function FindByFriendlyName(FriendlyName: string): Integer;\r\n function FindByName(Name: string): Integer;\r\n function FindByClass(Comp: TComponent): Integer;\r\n property Items[Index: Integer]: TSynCustomHighlighterClass\r\n read GetItem; default;\r\n end;\r\n\r\n procedure RegisterPlaceableHighlighter(highlighter:\r\n TSynCustomHighlighterClass);\r\n function GetPlaceableHighlighters: TSynHighlighterList;\r\n{$ENDIF}\r\n\r\nimplementation\r\n\r\nuses\r\n SynEditMiscProcs,\r\n{$IFDEF UNICODE}\r\n WideStrUtils,\r\n{$ENDIF}\r\n{$IFDEF SYN_CLX}\r\n QSynEditStrConst;\r\n{$ELSE}\r\n SynEditStrConst;\r\n{$ENDIF}\r\n\r\n{$IFNDEF SYN_CPPB_1}\r\n{ THighlighterList }\r\n\r\nfunction TSynHighlighterList.Count: Integer;\r\nbegin\r\n Result := hlList.Count;\r\nend;\r\n\r\nconstructor TSynHighlighterList.Create;\r\nbegin\r\n inherited Create;\r\n hlList := TList.Create;\r\nend;\r\n\r\ndestructor TSynHighlighterList.Destroy;\r\nbegin\r\n hlList.Free;\r\n inherited;\r\nend;\r\n\r\nfunction TSynHighlighterList.FindByClass(Comp: TComponent): Integer;\r\nvar\r\n i: Integer;\r\nbegin\r\n Result := -1;\r\n for i := 0 to Count - 1 do\r\n begin\r\n if Comp is Items[i] then\r\n begin\r\n Result := i;\r\n Exit;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TSynHighlighterList.FindByFriendlyName(FriendlyName: string): Integer;\r\nvar\r\n i: Integer;\r\nbegin\r\n Result := -1;\r\n for i := 0 to Count - 1 do\r\n begin\r\n if Items[i].GetFriendlyLanguageName = FriendlyName then\r\n begin\r\n Result := i;\r\n Exit;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TSynHighlighterList.FindByName(Name: string): Integer;\r\nvar\r\n i: Integer;\r\nbegin\r\n Result := -1;\r\n for i := 0 to Count - 1 do\r\n begin\r\n if Items[i].GetLanguageName = Name then\r\n begin\r\n Result := i;\r\n Exit;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TSynHighlighterList.GetItem(Index: Integer): TSynCustomHighlighterClass;\r\nbegin\r\n Result := TSynCustomHighlighterClass(hlList[Index]);\r\nend;\r\n\r\nvar\r\n G_PlaceableHighlighters: TSynHighlighterList;\r\n\r\n function GetPlaceableHighlighters: TSynHighlighterList;\r\n begin\r\n Result := G_PlaceableHighlighters;\r\n end;\r\n\r\n procedure RegisterPlaceableHighlighter(highlighter: TSynCustomHighlighterClass);\r\n begin\r\n if G_PlaceableHighlighters.hlList.IndexOf(highlighter) < 0 then\r\n G_PlaceableHighlighters.hlList.Add(highlighter);\r\n end;\r\n{$ENDIF}\r\n\r\n{ TSynHighlighterAttributes }\r\n\r\nprocedure TSynHighlighterAttributes.Assign(Source: TPersistent);\r\nbegin\r\n if Source is TSynHighlighterAttributes then\r\n begin\r\n fName := TSynHighlighterAttributes(Source).fName;\r\n AssignColorAndStyle(TSynHighlighterAttributes(Source));\r\n end\r\n else\r\n inherited Assign(Source);\r\nend;\r\n\r\nprocedure TSynHighlighterAttributes.AssignColorAndStyle(Source: TSynHighlighterAttributes);\r\nvar\r\n bChanged: Boolean;\r\nbegin\r\n bChanged := False;\r\n if fBackground <> Source.fBackground then\r\n begin\r\n fBackground := Source.fBackground;\r\n bChanged := True;\r\n end;\r\n if fForeground <> Source.fForeground then\r\n begin\r\n fForeground := Source.fForeground;\r\n bChanged := True;\r\n end;\r\n if fStyle <> Source.fStyle then\r\n begin\r\n fStyle := Source.fStyle;\r\n bChanged := True;\r\n end;\r\n if bChanged then\r\n Changed;\r\nend;\r\n\r\n\r\nprocedure TSynHighlighterAttributes.Changed;\r\nbegin\r\n if Assigned(fOnChange) then\r\n fOnChange(Self);\r\nend;\r\n\r\nconstructor TSynHighlighterAttributes.Create(AName: string; AFriendlyName: UnicodeString);\r\nbegin\r\n inherited Create;\r\n Background := clNone;\r\n Foreground := clNone;\r\n fName := AName;\r\n fFriendlyName := AFriendlyName;\r\nend;\r\n\r\nfunction TSynHighlighterAttributes.GetBackgroundColorStored: Boolean;\r\nbegin\r\n Result := fBackground <> fBackgroundDefault;\r\nend;\r\n\r\nfunction TSynHighlighterAttributes.GetForegroundColorStored: Boolean;\r\nbegin\r\n Result := fForeground <> fForegroundDefault;\r\nend;\r\n\r\nfunction TSynHighlighterAttributes.GetFontStyleStored: Boolean;\r\nbegin\r\n Result := fStyle <> fStyleDefault;\r\nend;\r\n\r\nprocedure TSynHighlighterAttributes.InternalSaveDefaultValues;\r\nbegin\r\n fForegroundDefault := fForeground;\r\n fBackgroundDefault := fBackground;\r\n fStyleDefault := fStyle;\r\nend;\r\n\r\n{$IFNDEF SYN_CLX}\r\nfunction TSynHighlighterAttributes.LoadFromBorlandRegistry(RootKey: HKEY;\r\n AttrKey, AttrName: string; OldStyle: Boolean): Boolean;\r\n // How the highlighting information is stored:\r\n // Delphi 1.0:\r\n // I don't know and I don't care.\r\n // Delphi 2.0 & 3.0:\r\n // In the registry branch HKCU\\Software\\Borland\\Delphi\\x.0\\Highlight\r\n // where x=2 or x=3.\r\n // Each entry is one string value, encoded as\r\n // ,,,,,,\r\n // Example:\r\n // 0,16777215,BI,0,1,0,15\r\n // foreground color (RGB): 0\r\n // background color (RGB): 16777215 ($FFFFFF)\r\n // font style: BI (bold italic), possible flags: B(old), I(talic), U(nderline)\r\n // default foreground: no, specified color will be used (black (0) is used when this flag is 1)\r\n // default background: yes, white ($FFFFFF, 15) will be used for background\r\n // foreground index: 0 (foreground index (Pal16), corresponds to foreground RGB color)\r\n // background index: 15 (background index (Pal16), corresponds to background RGB color)\r\n // Delphi 4.0 & 5.0:\r\n // In the registry branch HKCU\\Software\\Borland\\Delphi\\4.0\\Editor\\Highlight.\r\n // Each entry is subkey containing several values:\r\n // Foreground Color: foreground index (Pal16), 0..15 (dword)\r\n // Background Color: background index (Pal16), 0..15 (dword)\r\n // Bold: fsBold yes/no, 0/True (string)\r\n // Italic: fsItalic yes/no, 0/True (string)\r\n // Underline: fsUnderline yes/no, 0/True (string)\r\n // Default Foreground: use default foreground (clBlack) yes/no, False/-1 (string)\r\n // Default Background: use default backround (clWhite) yes/no, False/-1 (string)\r\nconst\r\n Pal16: array [0..15] of TColor = (\r\n clBlack, clMaroon, clGreen, clOlive, clNavy, clPurple, clTeal, clLtGray,\r\n clDkGray, clRed, clLime, clYellow, clBlue, clFuchsia, clAqua, clWhite\r\n );\r\n\r\n function LoadOldStyle(RootKey: HKEY; AttrKey, AttrName: string): Boolean;\r\n var\r\n descript: string;\r\n fgColRGB: string;\r\n bgColRGB: string;\r\n fontStyle: string;\r\n fgDefault: string;\r\n bgDefault: string;\r\n fgIndex16: string;\r\n bgIndex16: string;\r\n reg: TBetterRegistry;\r\n\r\n function Get(var Name: string): string;\r\n var\r\n p: Integer;\r\n begin\r\n p := Pos(',', Name);\r\n if p = 0 then p := Length(Name) + 1;\r\n Result := Copy(name, 1, p - 1);\r\n name := Copy(name, p + 1, Length(name) - p);\r\n end;\r\n\r\n begin { LoadOldStyle }\r\n Result := False;\r\n try\r\n reg := TBetterRegistry.Create;\r\n reg.RootKey := RootKey;\r\n try\r\n with reg do\r\n begin\r\n if OpenKeyReadOnly(AttrKey) then\r\n begin\r\n try\r\n if ValueExists(AttrName) then\r\n begin\r\n descript := ReadString(AttrName);\r\n fgColRGB := Get(descript);\r\n bgColRGB := Get(descript);\r\n fontStyle := Get(descript);\r\n fgDefault := Get(descript);\r\n bgDefault := Get(descript);\r\n fgIndex16 := Get(descript);\r\n bgIndex16 := Get(descript);\r\n if bgDefault = '1' then\r\n Background := clWindow\r\n else\r\n Background := Pal16[StrToInt(bgIndex16)];\r\n if fgDefault = '1' then\r\n Foreground := clWindowText\r\n else\r\n Foreground := Pal16[StrToInt(fgIndex16)];\r\n Style := [];\r\n if Pos('B', fontStyle) > 0 then Style := Style + [fsBold];\r\n if Pos('I', fontStyle) > 0 then Style := Style + [fsItalic];\r\n if Pos('U', fontStyle) > 0 then Style := Style + [fsUnderline];\r\n Result := True;\r\n end;\r\n finally\r\n CloseKey;\r\n end;\r\n end; // if\r\n end; // with\r\n finally\r\n reg.Free;\r\n end;\r\n except\r\n end;\r\n end; { LoadOldStyle }\r\n\r\n function LoadNewStyle(RootKey: HKEY; AttrKey, AttrName: string): Boolean;\r\n var\r\n fgColor: Integer;\r\n bgColor: Integer;\r\n fontBold: string;\r\n fontItalic: string;\r\n fontUnderline: string;\r\n fgDefault: string;\r\n bgDefault: string;\r\n reg: TBetterRegistry;\r\n\r\n function IsTrue(Value: string): Boolean;\r\n begin\r\n Result := not ((UpperCase(Value) = 'FALSE') or (Value = '0'));\r\n end; { IsTrue }\r\n\r\n begin\r\n Result := False;\r\n try\r\n reg := TBetterRegistry.Create;\r\n reg.RootKey := RootKey;\r\n try\r\n with reg do\r\n begin\r\n if OpenKeyReadOnly(AttrKey + '\\' + AttrName) then\r\n begin\r\n try\r\n if ValueExists('Foreground Color')\r\n then fgColor := Pal16[ReadInteger('Foreground Color')]\r\n else if ValueExists('Foreground Color New') then\r\n fgColor := StringToColor(ReadString('Foreground Color New'))\r\n else\r\n Exit;\r\n if ValueExists('Background Color')\r\n then bgColor := Pal16[ReadInteger('Background Color')]\r\n else if ValueExists('Background Color New') then\r\n bgColor := StringToColor(ReadString('Background Color New'))\r\n else\r\n Exit;\r\n if ValueExists('Bold')\r\n then fontBold := ReadString('Bold')\r\n else Exit;\r\n if ValueExists('Italic')\r\n then fontItalic := ReadString('Italic')\r\n else Exit;\r\n if ValueExists('Underline')\r\n then fontUnderline := ReadString('Underline')\r\n else Exit;\r\n if ValueExists('Default Foreground')\r\n then fgDefault := ReadString('Default Foreground')\r\n else Exit;\r\n if ValueExists('Default Background')\r\n then bgDefault := ReadString('Default Background')\r\n else Exit;\r\n if IsTrue(bgDefault)\r\n then Background := clWindow\r\n else Background := bgColor;\r\n if IsTrue(fgDefault)\r\n then Foreground := clWindowText\r\n else Foreground := fgColor;\r\n Style := [];\r\n if IsTrue(fontBold) then Style := Style + [fsBold];\r\n if IsTrue(fontItalic) then Style := Style + [fsItalic];\r\n if IsTrue(fontUnderline) then Style := Style + [fsUnderline];\r\n Result := True;\r\n finally\r\n CloseKey;\r\n end;\r\n end; // if\r\n end; // with\r\n finally\r\n reg.Free;\r\n end;\r\n except\r\n end;\r\n end; { LoadNewStyle }\r\n\r\nbegin\r\n if OldStyle then\r\n Result := LoadOldStyle(RootKey, AttrKey, AttrName)\r\n else\r\n Result := LoadNewStyle(RootKey, AttrKey, AttrName);\r\nend; { TSynHighlighterAttributes.LoadFromBorlandRegistry }\r\n{$ENDIF}\r\n\r\nprocedure TSynHighlighterAttributes.SetBackground(Value: TColor);\r\nbegin\r\n if fBackGround <> Value then\r\n begin\r\n fBackGround := Value;\r\n Changed;\r\n end;\r\nend;\r\n\r\nprocedure TSynHighlighterAttributes.SetForeground(Value: TColor);\r\nbegin\r\n if fForeGround <> Value then\r\n begin\r\n fForeGround := Value;\r\n Changed;\r\n end;\r\nend;\r\n\r\nprocedure TSynHighlighterAttributes.SetStyle(Value: TFontStyles);\r\nbegin\r\n if fStyle <> Value then\r\n begin\r\n fStyle := Value;\r\n Changed;\r\n end;\r\nend;\r\n\r\n{$IFNDEF SYN_CLX}\r\nfunction TSynHighlighterAttributes.LoadFromRegistry(Reg: TBetterRegistry): Boolean;\r\nvar\r\n Key: string;\r\nbegin\r\n Key := Reg.CurrentPath;\r\n if Reg.OpenKeyReadOnly(Name) then\r\n begin\r\n if Reg.ValueExists('Background') then\r\n Background := Reg.ReadInteger('Background');\r\n if Reg.ValueExists('Foreground') then\r\n Foreground := Reg.ReadInteger('Foreground');\r\n if Reg.ValueExists('Style') then\r\n IntegerStyle := Reg.ReadInteger('Style');\r\n reg.OpenKeyReadOnly('\\' + Key);\r\n Result := True;\r\n end\r\n else\r\n Result := False;\r\nend;\r\n\r\nfunction TSynHighlighterAttributes.SaveToRegistry(Reg: TBetterRegistry): Boolean;\r\nvar\r\n Key: string;\r\nbegin\r\n Key := Reg.CurrentPath;\r\n if Reg.OpenKey(Name, True) then\r\n begin\r\n Reg.WriteInteger('Background', Background);\r\n Reg.WriteInteger('Foreground', Foreground);\r\n Reg.WriteInteger('Style', IntegerStyle);\r\n reg.OpenKey('\\' + Key, False);\r\n Result := True;\r\n end\r\n else\r\n Result := False;\r\nend;\r\n\r\nfunction TSynHighlighterAttributes.LoadFromFile(Ini : TIniFile): boolean;\r\nvar\r\n S: TStringList;\r\nbegin\r\n S := TStringList.Create;\r\n try\r\n Ini.ReadSection(Name, S);\r\n if S.Count > 0 then\r\n begin\r\n if S.IndexOf('Background') <> -1 then\r\n Background := Ini.ReadInteger(Name, 'Background', Background);\r\n if S.IndexOf('Foreground') <> -1 then\r\n Foreground := Ini.ReadInteger(Name, 'Foreground', Foreground);\r\n if S.IndexOf('Style') <> -1 then\r\n IntegerStyle := Ini.ReadInteger(Name, 'Style', IntegerStyle);\r\n Result := true;\r\n end\r\n else\r\n Result := False;\r\n finally\r\n S.Free;\r\n end;\r\nend;\r\n\r\nfunction TSynHighlighterAttributes.SaveToFile(Ini : TIniFile): boolean;\r\nbegin\r\n Ini.WriteInteger(Name, 'Background', Background);\r\n Ini.WriteInteger(Name, 'Foreground', Foreground);\r\n Ini.WriteInteger(Name, 'Style', IntegerStyle);\r\n Result := True;\r\nend;\r\n\r\n{$ENDIF}\r\n\r\nfunction TSynHighlighterAttributes.GetStyleFromInt: Integer;\r\nbegin\r\n if fsBold in Style then Result := 1 else Result := 0;\r\n if fsItalic in Style then Result := Result + 2;\r\n if fsUnderline in Style then Result:= Result + 4;\r\n if fsStrikeout in Style then Result:= Result + 8;\r\nend;\r\n\r\nprocedure TSynHighlighterAttributes.SetStyleFromInt(const Value: Integer);\r\nbegin\r\n if Value and $1 = 0 then Style:= [] else Style := [fsBold];\r\n if Value and $2 <> 0 then Style:= Style + [fsItalic];\r\n if Value and $4 <> 0 then Style:= Style + [fsUnderline];\r\n if Value and $8 <> 0 then Style:= Style + [fsStrikeout];\r\nend;\r\n\r\n{ TSynCustomHighlighter }\r\n\r\nconstructor TSynCustomHighlighter.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n fAttributes := TStringList.Create;\r\n fAttributes.Duplicates := dupError;\r\n fAttributes.Sorted := True;\r\n fAttrChangeHooks := TSynNotifyEventChain.CreateEx(Self);\r\n fDefaultFilter := '';\r\n fEnabled := True;\r\n FOptions:= TSynEditHighlighterOptions.Create; // <-- Codehunter patch\r\nend;\r\n\r\ndestructor TSynCustomHighlighter.Destroy;\r\nbegin\r\n inherited Destroy;\r\n FreeHighlighterAttributes;\r\n fAttributes.Free;\r\n fAttrChangeHooks.Free;\r\n FOptions.Free; // <-- Codehunter patch\r\nend;\r\n\r\nprocedure TSynCustomHighlighter.BeginUpdate;\r\nbegin\r\n Inc(fUpdateCount);\r\nend;\r\n\r\nprocedure TSynCustomHighlighter.EndUpdate;\r\nbegin\r\n if fUpdateCount > 0 then\r\n begin\r\n Dec(fUpdateCount);\r\n if (fUpdateCount = 0) and fUpdateChange then\r\n begin\r\n fUpdateChange := False;\r\n DefHighlightChange(nil);\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TSynCustomHighlighter.FreeHighlighterAttributes;\r\nvar\r\n i: Integer;\r\nbegin\r\n if fAttributes <> nil then\r\n begin\r\n for i := fAttributes.Count - 1 downto 0 do\r\n TSynHighlighterAttributes(fAttributes.Objects[i]).Free;\r\n fAttributes.Clear;\r\n end;\r\nend;\r\n\r\nprocedure TSynCustomHighlighter.Assign(Source: TPersistent);\r\nvar\r\n Src: TSynCustomHighlighter;\r\n i, j: Integer;\r\n AttriName: string;\r\n SrcAttri: TSynHighlighterAttributes;\r\nbegin\r\n if (Source <> nil) and (Source is TSynCustomHighlighter) then\r\n begin\r\n Src := TSynCustomHighlighter(Source);\r\n for i := 0 to AttrCount - 1 do\r\n begin\r\n // assign first attribute with the same name\r\n AttriName := Attribute[i].Name;\r\n for j := 0 to Src.AttrCount - 1 do\r\n begin\r\n SrcAttri := Src.Attribute[j];\r\n if AttriName = SrcAttri.Name then\r\n begin\r\n Attribute[i].Assign(SrcAttri);\r\n break;\r\n end;\r\n end;\r\n end;\r\n // assign the sample source text only if same or descendant class\r\n if Src is ClassType then\r\n SampleSource := Src.SampleSource;\r\n //fWordBreakChars := Src.WordBreakChars; //TODO: does this make sense anyway?\r\n DefaultFilter := Src.DefaultFilter;\r\n Enabled := Src.Enabled;\r\n end\r\n else\r\n inherited Assign(Source);\r\nend;\r\n\r\nprocedure TSynCustomHighlighter.EnumUserSettings(Settings: TStrings);\r\nbegin\r\n Settings.Clear;\r\nend;\r\n\r\nfunction TSynCustomHighlighter.UseUserSettings(settingIndex: Integer): Boolean;\r\nbegin\r\n Result := False;\r\nend;\r\n\r\n{$IFNDEF SYN_CLX}\r\nfunction TSynCustomHighlighter.LoadFromRegistry(RootKey: HKEY;\r\n Key: string): Boolean;\r\nvar\r\n r: TBetterRegistry;\r\n i: Integer;\r\nbegin\r\n r := TBetterRegistry.Create;\r\n try\r\n r.RootKey := RootKey;\r\n if r.OpenKeyReadOnly(Key) then\r\n begin\r\n Result := True;\r\n for i := 0 to AttrCount - 1 do\r\n Result := Attribute[i].LoadFromRegistry(r) and Result;\r\n end\r\n else\r\n Result := False;\r\n finally\r\n r.Free;\r\n end;\r\nend;\r\n\r\nfunction TSynCustomHighlighter.SaveToRegistry(RootKey: HKEY;\r\n Key: string): Boolean;\r\nvar\r\n r: TBetterRegistry;\r\n i: Integer;\r\nbegin\r\n r := TBetterRegistry.Create;\r\n try\r\n r.RootKey := RootKey;\r\n if r.OpenKey(Key,True) then\r\n begin\r\n Result := True;\r\n for i := 0 to AttrCount - 1 do\r\n Result := Attribute[i].SaveToRegistry(r) and Result;\r\n end\r\n else\r\n Result := False;\r\n finally\r\n r.Free;\r\n end;\r\nend;\r\n\r\nfunction TSynCustomHighlighter.LoadFromFile(AFileName : String): boolean;\r\nvar\r\n AIni: TIniFile;\r\n i: Integer;\r\nbegin\r\n AIni := TIniFile.Create(AFileName);\r\n try\r\n with AIni do\r\n begin\r\n Result := True;\r\n for i := 0 to AttrCount - 1 do\r\n Result := Attribute[i].LoadFromFile(AIni) and Result;\r\n end;\r\n finally\r\n AIni.Free;\r\n end;\r\nend;\r\n\r\nfunction TSynCustomHighlighter.SaveToFile(AFileName : String): boolean;\r\nvar\r\n AIni: TIniFile;\r\n i: integer;\r\nbegin\r\n AIni := TIniFile.Create(AFileName);\r\n try\r\n with AIni do\r\n begin\r\n Result := True;\r\n for i := 0 to AttrCount - 1 do\r\n Result := Attribute[i].SaveToFile(AIni) and Result;\r\n end;\r\n finally\r\n AIni.Free;\r\n end;\r\nend;\r\n\r\n{$ENDIF}\r\n\r\nprocedure TSynCustomHighlighter.AddAttribute(Attri: TSynHighlighterAttributes);\r\nbegin\r\n fAttributes.AddObject(Attri.Name, Attri);\r\nend;\r\n\r\nprocedure TSynCustomHighlighter.DefHighlightChange(Sender: TObject);\r\nbegin\r\n if fUpdateCount > 0 then\r\n fUpdateChange := True\r\n else if not(csLoading in ComponentState) then\r\n begin\r\n fAttrChangeHooks.Sender := Sender;\r\n fAttrChangeHooks.Fire;\r\n end;\r\nend;\r\n\r\nprocedure TSynCustomHighlighter.DefineProperties(Filer: TFiler);\r\nbegin\r\n inherited;\r\n{$IFNDEF UNICODE}\r\n UnicodeDefineProperties(Filer, Self);\r\n{$ENDIF}\r\nend;\r\n\r\nfunction TSynCustomHighlighter.GetAttribCount: Integer;\r\nbegin\r\n Result := fAttributes.Count;\r\nend;\r\n\r\nfunction TSynCustomHighlighter.GetAttribute(Index: Integer):\r\n TSynHighlighterAttributes;\r\nbegin\r\n Result := nil;\r\n if (Index >= 0) and (Index < fAttributes.Count) then\r\n Result := TSynHighlighterAttributes(fAttributes.Objects[Index]);\r\nend;\r\n\r\nclass function TSynCustomHighlighter.GetCapabilities: TSynHighlighterCapabilities;\r\nbegin\r\n Result := [hcRegistry]; //registry save/load supported by default\r\nend;\r\n\r\nfunction TSynCustomHighlighter.GetCapabilitiesProp: TSynHighlighterCapabilities;\r\nbegin\r\n Result := GetCapabilities;\r\nend;\r\n\r\nfunction TSynCustomHighlighter.GetDefaultFilter: string;\r\nbegin\r\n Result := fDefaultFilter;\r\nend;\r\n\r\nfunction TSynCustomHighlighter.GetExpandedTokenPos: Integer;\r\nbegin\r\n if fExpandedLine = nil then\r\n Result := fTokenPos\r\n else\r\n Result := fExpandedTokenPos;\r\nend;\r\n\r\nfunction TSynCustomHighlighter.GetExportName: string;\r\nbegin\r\n if FExportName = '' then\r\n FExportName := SynEditMiscProcs.DeleteTypePrefixAndSynSuffix(ClassName);\r\n Result := FExportName;\r\nend;\r\n\r\nfunction TSynCustomHighlighter.GetExpandedToken: UnicodeString;\r\nvar\r\n Len: Integer;\r\nbegin\r\n if fExpandedLine = nil then\r\n begin\r\n Result := GetToken;\r\n Exit;\r\n end;\r\n\r\n Len := ExpandedRun - fExpandedTokenPos;\r\n SetLength(Result, Len);\r\n if Len > 0 then\r\n WStrLCopy(@Result[1], fExpandedLine + fExpandedTokenPos, Len);\r\nend;\r\n\r\nclass function TSynCustomHighlighter.GetFriendlyLanguageName: UnicodeString;\r\nbegin\r\n{$IFDEF SYN_DEVELOPMENT_CHECKS}\r\n raise Exception.CreateFmt('%s.GetFriendlyLanguageName not implemented', [ClassName]);\r\n{$ENDIF}\r\n Result := SYNS_FriendlyLangUnknown;\r\nend;\r\n\r\nclass function TSynCustomHighlighter.GetLanguageName: string;\r\nbegin\r\n{$IFDEF SYN_DEVELOPMENT_CHECKS}\r\n raise Exception.CreateFmt('%s.GetLanguageName not implemented', [ClassName]);\r\n{$ENDIF}\r\n Result := SYNS_LangUnknown;\r\nend;\r\n\r\nfunction TSynCustomHighlighter.GetFriendlyLanguageNameProp: UnicodeString;\r\nbegin\r\n Result := GetFriendlyLanguageName;\r\nend;\r\n\r\nfunction TSynCustomHighlighter.GetLanguageNameProp: string;\r\nbegin\r\n Result := GetLanguageName;\r\nend;\r\n\r\nfunction TSynCustomHighlighter.GetRange: Pointer;\r\nbegin\r\n Result := nil;\r\nend;\r\n\r\nfunction TSynCustomHighlighter.GetToken: UnicodeString;\r\nvar\r\n Len: Integer;\r\nbegin\r\n Len := Run - fTokenPos;\r\n SetLength(Result, Len);\r\n if Len > 0 then\r\n WStrLCopy(@Result[1], fCasedLine + fTokenPos, Len);\r\nend;\r\n\r\nfunction TSynCustomHighlighter.GetTokenPos: Integer;\r\nbegin\r\n Result := fTokenPos;\r\nend;\r\n\r\nfunction TSynCustomHighlighter.GetKeyWords(TokenKind: Integer): UnicodeString;\r\nbegin\r\n Result := '';\r\nend;\r\n\r\nfunction TSynCustomHighlighter.GetSampleSource: UnicodeString;\r\nbegin\r\n Result := '';\r\nend;\r\n\r\nprocedure TSynCustomHighlighter.HookAttrChangeEvent(ANotifyEvent: TNotifyEvent);\r\nbegin\r\n fAttrChangeHooks.Add(ANotifyEvent);\r\nend;\r\n\r\nfunction TSynCustomHighlighter.IsCurrentToken(const Token: UnicodeString): Boolean;\r\nvar\r\n I: Integer;\r\n Temp: PWideChar;\r\nbegin\r\n Temp := fToIdent;\r\n if Length(Token) = fStringLen then\r\n begin\r\n Result := True;\r\n for i := 1 to fStringLen do\r\n begin\r\n if Temp^ <> Token[i] then\r\n begin\r\n Result := False;\r\n break;\r\n end;\r\n inc(Temp);\r\n end;\r\n end\r\n else\r\n Result := False;\r\nend;\r\n\r\nfunction TSynCustomHighlighter.IsFilterStored: Boolean;\r\nbegin\r\n Result := True;\r\nend;\r\n\r\nfunction TSynCustomHighlighter.IsIdentChar(AChar: WideChar): Boolean;\r\nbegin\r\n case AChar of\r\n '_', '0'..'9', 'A'..'Z', 'a'..'z':\r\n Result := True;\r\n else\r\n Result := False;\r\n end;\r\nend;\r\n\r\nfunction TSynCustomHighlighter.IsKeyword(const AKeyword: UnicodeString): Boolean;\r\nbegin\r\n Result := False;\r\nend;\r\n\r\nfunction TSynCustomHighlighter.IsLineEnd(Run: Integer): Boolean;\r\nbegin\r\n Result := (Run >= fLineLen) or (fLine[Run] = #10) or (fLine[Run] = #13);\r\nend;\r\n\r\nfunction TSynCustomHighlighter.IsWhiteChar(AChar: WideChar): Boolean;\r\nbegin\r\n case AChar of\r\n #0..#32:\r\n Result := True;\r\n else\r\n Result := not (IsIdentChar(AChar) or IsWordBreakChar(AChar))\r\n end\r\nend;\r\n\r\nfunction TSynCustomHighlighter.IsWordBreakChar(AChar: WideChar): Boolean;\r\nbegin\r\n case AChar of\r\n #0..#32, '.', ',', ';', ':', '\"', '''', '', '`', '', '^', '!', '?', '&',\r\n '$', '@', '', '%', '#', '~', '[', ']', '(', ')', '{', '}', '<', '>',\r\n '-', '=', '+', '*', '/', '\\', '|':\r\n Result := True;\r\n else\r\n Result := False;\r\n end;\r\nend;\r\n\r\nprocedure TSynCustomHighlighter.Next;\r\nvar\r\n Delta: Integer;\r\nbegin\r\n if fOldRun = Run then Exit;\r\n\r\n fExpandedTokenPos := ExpandedRun;\r\n if fExpandedLine = nil then Exit;\r\n\r\n Delta := Run - fOldRun;\r\n while Delta > 0 do\r\n begin\r\n while fExpandedLine[ExpandedRun] = FillerChar do\r\n inc(ExpandedRun);\r\n inc(ExpandedRun);\r\n dec(Delta);\r\n end;\r\n fOldRun := Run;\r\nend;\r\n\r\nprocedure TSynCustomHighlighter.NextToEol;\r\nbegin\r\n while not GetEol do Next;\r\nend;\r\n\r\nprocedure TSynCustomHighlighter.ResetRange;\r\nbegin\r\nend;\r\n\r\nprocedure TSynCustomHighlighter.SetAdditionalIdentChars(\r\n const Value: TSysCharSet);\r\nbegin\r\n FAdditionalIdentChars := Value;\r\nend;\r\n\r\nprocedure TSynCustomHighlighter.SetAdditionalWordBreakChars(\r\n const Value: TSysCharSet);\r\nbegin\r\n FAdditionalWordBreakChars := Value;\r\nend;\r\n\r\nprocedure TSynCustomHighlighter.SetAttributesOnChange(AEvent: TNotifyEvent);\r\nvar\r\n i: Integer;\r\n Attri: TSynHighlighterAttributes;\r\nbegin\r\n for i := fAttributes.Count - 1 downto 0 do\r\n begin\r\n Attri := TSynHighlighterAttributes(fAttributes.Objects[i]);\r\n if Attri <> nil then\r\n begin\r\n Attri.OnChange := AEvent;\r\n Attri.InternalSaveDefaultValues;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TSynCustomHighlighter.SetLineExpandedAtWideGlyphs(const Line,\r\n ExpandedLine: UnicodeString; LineNumber: Integer);\r\nbegin\r\n fExpandedLineStr := ExpandedLine;\r\n fExpandedLine := PWideChar(fExpandedLineStr);\r\n fExpandedLineLen := Length(fExpandedLineStr);\r\n DoSetLine(Line, LineNumber);\r\n Next;\r\nend;\r\n\r\nprocedure TSynCustomHighlighter.SetLine(const Value: UnicodeString; LineNumber: Integer);\r\nbegin\r\n fExpandedLineStr := '';\r\n fExpandedLine := nil;\r\n fExpandedLineLen := 0;\r\n DoSetLine(Value, LineNumber);\r\n Next;\r\nend;\r\n\r\nprocedure TSynCustomHighlighter.DoSetLine(const Value: UnicodeString; LineNumber: Integer);\r\n\r\n procedure DoWideLowerCase(const value : UnicodeString; var dest : UnicodeString);\r\n begin\r\n // segregated here so case-insensitive highlighters don't have to pay the overhead\r\n // of the exception frame for the release of the temporary string\r\n dest := SynWideLowerCase(value);\r\n end;\r\n\r\nbegin\r\n // UnicodeStrings are not reference counted, hence we need to copy\r\n if fCaseSensitive then\r\n begin\r\n fLineStr := Value;\r\n fCasedLineStr := '';\r\n fCasedLine := PWideChar(fLineStr);\r\n end\r\n else\r\n begin\r\n DoWideLowerCase(Value, fLineStr);\r\n fCasedLineStr := Value;\r\n fCasedLine := PWideChar(fCasedLineStr);\r\n end;\r\n fLine := PWideChar(fLineStr);\r\n fLineLen := Length(fLineStr);\r\n\r\n Run := 0;\r\n ExpandedRun := 0;\r\n fOldRun := Run;\r\n fLineNumber := LineNumber;\r\nend;\r\n\r\nprocedure TSynCustomHighlighter.SetRange(Value: Pointer);\r\nbegin\r\nend;\r\n\r\nprocedure TSynCustomHighlighter.SetDefaultFilter(Value: string);\r\nbegin\r\n fDefaultFilter := Value;\r\nend;\r\n\r\nprocedure TSynCustomHighlighter.SetSampleSource(Value: UnicodeString);\r\nbegin\r\n // TODO: sure this should be empty?\r\nend;\r\n\r\nprocedure TSynCustomHighlighter.UnhookAttrChangeEvent(ANotifyEvent: TNotifyEvent);\r\nbegin\r\n fAttrChangeHooks.Remove(ANotifyEvent);\r\nend;\r\n\r\nprocedure TSynCustomHighlighter.SetEnabled(const Value: Boolean);\r\nbegin\r\n if fEnabled <> Value then\r\n begin\r\n fEnabled := Value;\r\n DefHighlightChange(nil);\r\n end;\r\nend;\r\n\r\nprocedure TSynCustomHighlighter.Loaded;\r\nbegin\r\n inherited;\r\n DefHighlightChange(nil);\r\nend;\r\n\r\n// Pos and Result are 1-based (i.e. positions in a UnicodeString not a PWideChar)\r\nfunction TSynCustomHighlighter.PosToExpandedPos(Pos: Integer): Integer;\r\nvar\r\n i: Integer;\r\nbegin\r\n if fExpandedLine = nil then\r\n begin\r\n Result := Pos;\r\n Exit;\r\n end;\r\n\r\n Result := 0;\r\n i := 0;\r\n while i < Pos do\r\n begin\r\n while fExpandedLine[Result] = FillerChar do\r\n inc(Result);\r\n inc(Result);\r\n inc(i);\r\n end;\r\nend;\r\n\r\n{$IFNDEF SYN_CPPB_1}\r\ninitialization\r\n G_PlaceableHighlighters := TSynHighlighterList.Create;\r\nfinalization\r\n G_PlaceableHighlighters.Free;\r\n G_PlaceableHighlighters := nil;\r\n{$ENDIF}\r\nend." }, { "path": "External/SynEdit/Source/SynEditHighlighterOptions.pas", "content": "{-------------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nDatetime format is dd.MM.yyyy hh:mm:ss.\r\n\r\nThe Original Code is: SynEditHighlighterOptions.pas, released 12.09.2012.\r\n\r\nAll Rights Reserved.\r\n\r\nContributors to the SynEdit and mwEdit projects are listed in the\r\nContributors.txt file.\r\n\r\n$Id: SynEditHighlighterOptions.pas,v 1.0.2 25.10.2012 11:16:19 CodehunterWorks Exp $\r\n\r\nYou may retrieve the latest version of this file at the SynEdit home page,\r\nlocated at http://SynEdit.SourceForge.net\r\n\r\nLast Changes:\r\n 21.09.2012 08:37:10 - Moved from String to WideString\r\n 25.10.2012 11:16:19 - Added DefaultExtension property\r\n\r\nKnown Issues:\r\n-------------------------------------------------------------------------------}\r\n\r\nunit SynEditHighlighterOptions;\r\n\r\ninterface\r\n\r\nuses\r\n Classes;\r\n\r\ntype\r\n TSynEditHighlighterOptions = class(TPersistent)\r\n private\r\n FAutoDetectEnabled: Boolean;\r\n FAutoDetectLineLimit: Cardinal;\r\n FAutoDetectMatchExpression: WideString;\r\n FDefaultExtension: WideString;\r\n FLineCommentarEnd: WideString;\r\n FLineCommentarStart: WideString;\r\n FTitle: WideString;\r\n FVisible: Boolean;\r\n public\r\n procedure Assign(Source: TPersistent); override;\r\n procedure AssignTo(Dest: TPersistent); override;\r\n published\r\n property AutoDetectEnabled: Boolean read FAutoDetectEnabled write FAutoDetectEnabled;\r\n property AutoDetectLineLimit: Cardinal read FAutoDetectLineLimit write FAutoDetectLineLimit;\r\n property AutoDetectMatchExpression: WideString read FAutoDetectMatchExpression write FAutoDetectMatchExpression;\r\n property DefaultExtension: WideString read FDefaultExtension write FDefaultExtension;\r\n property LineCommentarEnd: WideString read FLineCommentarEnd write FLineCommentarEnd;\r\n property LineCommentarStart: WideString read FLineCommentarStart write FLineCommentarStart;\r\n property Title: WideString read FTitle write FTitle;\r\n property Visible: Boolean read FVisible write FVisible;\r\n end;\r\n\r\nimplementation\r\n\r\nprocedure TSynEditHighlighterOptions.Assign(Source: TPersistent);\r\nbegin\r\n if Source.InheritsFrom(TSynEditHighlighterOptions) then begin\r\n with TSynEditHighlighterOptions(Source) do begin\r\n FAutoDetectEnabled:= AutoDetectEnabled;\r\n FAutoDetectMatchExpression:= AutoDetectMatchExpression;\r\n FAutoDetectLineLimit:= AutoDetectLineLimit;\r\n FDefaultExtension:= DefaultExtension;\r\n FLineCommentarStart:= LineCommentarStart;\r\n FLineCommentarEnd:= LineCommentarEnd;\r\n FTitle:= Title;\r\n FVisible:= Visible;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TSynEditHighlighterOptions.AssignTo(Dest: TPersistent);\r\nbegin\r\n if Dest.InheritsFrom(TSynEditHighlighterOptions) then begin\r\n with TSynEditHighlighterOptions(Dest) do begin\r\n AutoDetectEnabled:= FAutoDetectEnabled;\r\n AutoDetectMatchExpression:= FAutoDetectMatchExpression;\r\n AutoDetectLineLimit:= FAutoDetectLineLimit;\r\n DefaultExtension:= FDefaultExtension;\r\n LineCommentarStart:= FLineCommentarStart;\r\n LineCommentarEnd:= FLineCommentarEnd;\r\n Title:= FTitle;\r\n Visible:= FVisible;\r\n end;\r\n end;\r\nend;\r\n\r\nend.\r\n" }, { "path": "External/SynEdit/Source/SynEditJedi.inc", "content": "{$IFNDEF JEDI_INC}\r\n{$DEFINE JEDI_INC}\r\n\r\n{**************************************************************************************************}\r\n{ }\r\n{ The contents of this file are subject to the Mozilla Public License Version 1.1 (the \"License\");}\r\n{ you may not use this file except in compliance with the License. You may obtain a copy of the }\r\n{ License at http://www.mozilla.org/MPL/ }\r\n{ }\r\n{ Software distributed under the License is distributed on an \"AS IS\" basis, WITHOUT WARRANTY OF }\r\n{ ANY KIND, either express or implied. See the License for the specific language governing rights }\r\n{ and limitations under the License. }\r\n{ }\r\n{ The Original Code is: jedi.inc. }\r\n{ The Initial Developer of the Original Code is Project JEDI http://www.delphi-jedi.org }\r\n{ }\r\n{ Alternatively, the contents of this file may be used under the terms of the GNU Lesser General }\r\n{ Public License (the \"LGPL License\"), in which case the provisions of the LGPL License are }\r\n{ applicable instead of those above. If you wish to allow use of your version of this file only }\r\n{ under the terms of the LGPL License and not to allow others to use your version of this file }\r\n{ under the MPL, indicate your decision by deleting the provisions above and replace them with }\r\n{ the notice and other provisions required by the LGPL License. If you do not delete the }\r\n{ provisions above, a recipient may use your version of this file under either the MPL or the }\r\n{ LGPL License. }\r\n{ }\r\n{ For more information about the LGPL: http://www.gnu.org/copyleft/lesser.html }\r\n{ }\r\n{**************************************************************************************************}\r\n{ }\r\n{ This file defines various generic compiler directives used in different libraries, e.g. in the }\r\n{ JEDI Code Library (JCL) and JEDI Visual Component Library Library (JVCL). The directives in }\r\n{ this file are of generic nature and consist mostly of mappings from the VERXXX directives }\r\n{ defined by Delphi, C++ Builder and FPC to friendly names such as DELPHI5 and }\r\n{ SUPPORTS_WIDESTRING. These friendly names are subsequently used in the libraries to test for }\r\n{ compiler versions and/or whether the compiler supports certain features (such as widestrings or }\r\n{ 64 bit integers. The libraries provide an additional, library specific, include file. For the }\r\n{ JCL e.g. this is jcl.inc. These files should be included in source files instead of this file }\r\n{ (which is pulled in automatically). }\r\n{ }\r\n{**************************************************************************************************}\r\n{ }\r\n{ Last modified: $Date: 2009/01/06 16:26:01 $ }\r\n{ Revision: $Rev:: 2446 $ }\r\n{ Author: $Author: maelh $ }\r\n{ }\r\n{**************************************************************************************************}\r\n\r\n(*\r\n\r\n- Development environment directives\r\n\r\n This file defines two directives to indicate which development environment the\r\n library is being compiled with. Currently this can either be Delphi, Kylix,\r\n C++ Builder or FPC.\r\n\r\n Directive Description\r\n ------------------------------------------------------------------------------\r\n DELPHI Defined if compiled with Delphi\r\n KYLIX Defined if compiled with Kylix\r\n DELPHICOMPILER Defined if compiled with Delphi or Kylix/Delphi\r\n BCB Defined if compiled with C++ Builder\r\n CPPBUILDER Defined if compiled with C++ Builder (alias for BCB)\r\n BCBCOMPILER Defined if compiled with C++ Builder or Kylix/C++\r\n DELPHILANGUAGE Defined if compiled with Delphi, Kylix or C++ Builder\r\n BORLAND Defined if compiled with Delphi, Kylix or C++ Builder\r\n FPC Defined if compiled with FPC\r\n\r\n- Platform Directives\r\n\r\n Platform directives are not all explicitly defined in this file, some are\r\n defined by the compiler itself. They are listed here only for completeness.\r\n\r\n Directive Description\r\n ------------------------------------------------------------------------------\r\n WIN32 Defined when target platform is 32 bit Windows\r\n WIN64 Defined when target platform is 64 bit Windows\r\n MSWINDOWS Defined when target platform is 32 bit Windows\r\n LINUX Defined when target platform is Linux\r\n UNIX Defined when target platform is Unix-like (including Linux)\r\n CLR Defined when target platform is .NET\r\n\r\n- Architecture directives. These are auto-defined by FPC\r\n CPU32 and CPU64 are mostly for generic pointer size dependant differences rather\r\n than for a specific architecture.\r\n\r\n CPU386 Defined when target platform is native x86 (win32)\r\n CPUx86_64 Defined when target platform is native x86_64 (win64)\r\n CPU32 Defined when target is 32-bit\r\n CPU64\t Defined when target is 64-bit\r\n\r\n- Visual library Directives\r\n\r\n The following directives indicate for a visual library. In a Delphi/BCB\r\n (Win32) application you need to define the VisualCLX symbol in the project\r\n options, if you want to use the VisualCLX library. Alternatively you can use\r\n the IDE expert, which is distributed with the JCL to do this automatically.\r\n\r\n Directive Description\r\n ------------------------------------------------------------------------------\r\n VCL Defined for Delphi/BCB (Win32) exactly if VisualCLX is not defined\r\n VisualCLX Defined for Kylix; needs to be defined for Delphi/BCB to\r\n use JCL with VisualCLX applications.\r\n\r\n\r\n- Other cross-platform related defines\r\n\r\n These symbols are intended to help in writing portable code.\r\n\r\n Directive Description\r\n ------------------------------------------------------------------------------\r\n PUREPASCAL Code is machine-independent (as opposed to assembler code)\r\n Win32API Code is specific for the Win32 API;\r\n use instead of \"{$IFNDEF CLR} {$IFDEF MSWINDOWS}\" constructs\r\n\r\n\r\n- Delphi Versions\r\n\r\n The following directives are direct mappings from the VERXXX directives to a\r\n friendly name of the associated compiler. These directives are only defined if\r\n the compiler is Delphi (ie DELPHI is defined).\r\n\r\n Directive Description\r\n ------------------------------------------------------------------------------\r\n DELPHI1 Defined when compiling with Delphi 1\r\n DELPHI2 Defined when compiling with Delphi 2\r\n DELPHI3 Defined when compiling with Delphi 3\r\n DELPHI4 Defined when compiling with Delphi 4\r\n DELPHI5 Defined when compiling with Delphi 5\r\n DELPHI6 Defined when compiling with Delphi 6\r\n DELPHI7 Defined when compiling with Delphi 7\r\n DELPHI8 Defined when compiling with Delphi 8\r\n DELPHI2005 Defined when compiling with Delphi 2005\r\n DELPHI9 Alias for DELPHI2005\r\n DELPHI10 Defined when compiling with Delphi Personality of BDS 4.0\r\n DELPHI2006 Alias for DELPHI10\r\n DELPHI11 Defined when compiling with Delphi 2007 for Win32 \r\n DELPHI2007 Alias for DELPHI11\r\n DELPHI12 Defined when compiling with Delphi for Win32 2009 \r\n DELPHI2009 Alias for DELPHI12\r\n DELPHI1_UP Defined when compiling with Delphi 1 or higher\r\n DELPHI2_UP Defined when compiling with Delphi 2 or higher\r\n DELPHI3_UP Defined when compiling with Delphi 3 or higher\r\n DELPHI4_UP Defined when compiling with Delphi 4 or higher\r\n DELPHI5_UP Defined when compiling with Delphi 5 or higher\r\n DELPHI6_UP Defined when compiling with Delphi 6 or higher\r\n DELPHI7_UP Defined when compiling with Delphi 7 or higher\r\n DELPHI8_UP Defined when compiling with Delphi 8 or higher\r\n DELPHI2005_UP Defined when compiling with Delphi 2005 or higher\r\n DELPHI9_UP Alias for DELPHI2005_UP\r\n DELPHI10_UP Defined when compiling with Delphi Personality of BDS 4.0 or higher\r\n DELPHI2006_UP Alias for DELPHI10_UP\r\n DELPHI11_UP Defined when compiling with Delphi 2007 for Win32 or higher\r\n DELPHI2007_UP Alias for DELPHI11_UP\r\n DELPHI12_UP Defined when compiling with Delphi for Win32 2009 or higher\r\n DELPHI2009_UP Alias for DELPHI12_UP\r\n\r\n\r\n- Kylix Versions\r\n\r\n The following directives are direct mappings from the VERXXX directives to a\r\n friendly name of the associated compiler. These directives are only defined if\r\n the compiler is Kylix (ie KYLIX is defined).\r\n\r\n Directive Description\r\n ------------------------------------------------------------------------------\r\n KYLIX1 Defined when compiling with Kylix 1\r\n KYLIX2 Defined when compiling with Kylix 2\r\n KYLIX3 Defined when compiling with Kylix 3\r\n KYLIX1_UP Defined when compiling with Kylix 1 or higher\r\n KYLIX2_UP Defined when compiling with Kylix 2 or higher\r\n KYLIX3_UP Defined when compiling with Kylix 3 or higher\r\n\r\n\r\n- Delphi Compiler Versions (Delphi / Kylix, not in BCB mode)\r\n\r\n Directive Description\r\n ------------------------------------------------------------------------------\r\n DELPHICOMPILER1 Defined when compiling with Delphi 1\r\n DELPHICOMPILER2 Defined when compiling with Delphi 2\r\n DELPHICOMPILER3 Defined when compiling with Delphi 3\r\n DELPHICOMPILER4 Defined when compiling with Delphi 4\r\n DELPHICOMPILER5 Defined when compiling with Delphi 5\r\n DELPHICOMPILER6 Defined when compiling with Delphi 6 or Kylix 1, 2 or 3\r\n DELPHICOMPILER7 Defined when compiling with Delphi 7\r\n DELPHICOMPILER8 Defined when compiling with Delphi 8\r\n DELPHICOMPILER9 Defined when compiling with Delphi 2005\r\n DELPHICOMPILER10 Defined when compiling with Delphi Personality of BDS 4.0\r\n DELPHICOMPILER11 Defined when compiling with Delphi 2007 for Win32\r\n DELPHICOMPILER12 Defined when compiling with Delphi Personality of BDS 6.0\r\n DELPHICOMPILER1_UP Defined when compiling with Delphi 1 or higher\r\n DELPHICOMPILER2_UP Defined when compiling with Delphi 2 or higher\r\n DELPHICOMPILER3_UP Defined when compiling with Delphi 3 or higher\r\n DELPHICOMPILER4_UP Defined when compiling with Delphi 4 or higher\r\n DELPHICOMPILER5_UP Defined when compiling with Delphi 5 or higher\r\n DELPHICOMPILER6_UP Defined when compiling with Delphi 6 or Kylix 1, 2 or 3 or higher\r\n DELPHICOMPILER7_UP Defined when compiling with Delphi 7 or higher\r\n DELPHICOMPILER8_UP Defined when compiling with Delphi 8 or higher\r\n DELPHICOMPILER9_UP Defined when compiling with Delphi 2005\r\n DELPHICOMPILER10_UP Defined when compiling with Delphi Personality of BDS 4.0 or higher\r\n DELPHICOMPILER11_UP Defined when compiling with Delphi 2007 for Win32 or higher\r\n DELPHICOMPILER12_UP Defined when compiling with Delphi Personality of BDS 6.0 or higher\r\n\r\n\r\n- C++ Builder Versions\r\n\r\n The following directives are direct mappings from the VERXXX directives to a\r\n friendly name of the associated compiler. These directives are only defined if\r\n the compiler is C++ Builder (ie BCB is defined).\r\n\r\n Directive Description\r\n ------------------------------------------------------------------------------\r\n BCB1 Defined when compiling with C++ Builder 1\r\n BCB3 Defined when compiling with C++ Builder 3\r\n BCB4 Defined when compiling with C++ Builder 4\r\n BCB5 Defined when compiling with C++ Builder 5\r\n BCB6 Defined when compiling with C++ Builder 6\r\n BCB10 Defined when compiling with C++ Builder Personality of BDS 4.0 (also known as C++Builder 2006)\r\n BCB11 Defined when compiling with C++ Builder Personality of RAD Studio 2007 (also known as C++Builder 2007)\r\n BCB12 Defined when compiling with C++ Builder Personality of RAD Studio 2009 (also known as C++Builder 2009)\r\n BCB1_UP Defined when compiling with C++ Builder 1 or higher\r\n BCB3_UP Defined when compiling with C++ Builder 3 or higher\r\n BCB4_UP Defined when compiling with C++ Builder 4 or higher\r\n BCB5_UP Defined when compiling with C++ Builder 5 or higher\r\n BCB6_UP Defined when compiling with C++ Builder 6 or higher\r\n BCB10_UP Defined when compiling with C++ Builder Personality of BDS 4.0 or higher\r\n BCB11_UP Defined when compiling with C++ Builder Personality of RAD Studio 2007 or higher\r\n BCB12_UP Defined when compiling with C++ Builder Personality of RAD Studio 2009 or higher\r\n\r\n\r\n- CodeGear RAD Studio / Borland Developer Studio Versions\r\n\r\n The following directives are direct mappings from the VERXXX directives to a\r\n friendly name of the associated IDE. These directives are only defined if\r\n the IDE is Borland Developer Studio Version 2 or above.\r\n\r\n Note: Borland Developer Studio 2006 is marketed as Delphi 2006 or C++Builder 2006,\r\n but those provide only different labels for identical content.\r\n\r\n Directive Description\r\n ------------------------------------------------------------------------------\r\n BDS Defined when compiling with a Borland Developer Studio version's dcc32.exe\r\n BDS2 Defined when compiling with BDS 2.0 (Delphi 8)\r\n BDS3 Defined when compiling with BDS 3.0 (Delphi 2005)\r\n BDS4 Defined when compiling with BDS 4.0 (Borland Developer Studio 2006)\r\n BDS5 Defined when compiling with BDS 5.0 (CodeGear RAD Studio 2007)\r\n BDS6 Defined when compiling with BDS 6.0 (CodeGear RAD Studio 2009)\r\n BDS2_UP Defined when compiling with BDS 2.0 or higher\r\n BDS3_UP Defined when compiling with BDS 3.0 or higher\r\n BDS4_UP Defined when compiling with BDS 4.0 or higher\r\n BDS5_UP Defined when compiling with BDS 5.0 or higher\r\n BDS6_UP Defined when compiling with BDS 6.0 or higher\r\n\r\n- Compiler Versions\r\n\r\n The following directives are direct mappings from the VERXXX directives to a\r\n friendly name of the associated compiler. Unlike the DELPHI_X and BCB_X\r\n directives, these directives are indepedent of the development environment.\r\n That is, they are defined regardless of whether compilation takes place using\r\n Delphi or C++ Builder.\r\n\r\n Directive Description\r\n ------------------------------------------------------------------------------\r\n COMPILER1 Defined when compiling with Delphi 1\r\n COMPILER2 Defined when compiling with Delphi 2 or C++ Builder 1\r\n COMPILER3 Defined when compiling with Delphi 3\r\n COMPILER35 Defined when compiling with C++ Builder 3\r\n COMPILER4 Defined when compiling with Delphi 4 or C++ Builder 4\r\n COMPILER5 Defined when compiling with Delphi 5 or C++ Builder 5\r\n COMPILER6 Defined when compiling with Delphi 6 or C++ Builder 6\r\n COMPILER7 Defined when compiling with Delphi 7\r\n COMPILER8 Defined when compiling with Delphi 8\r\n COMPILER9 Defined when compiling with Delphi 9\r\n COMPILER10 Defined when compiling with Delphi or C++ Builder Personalities of BDS 4.0\r\n COMPILER11 Defined when compiling with Delphi 2007 for Win32\r\n COMPILER12 Defined when compiling with Delphi or C++ Builder Personalities of BDS 6.0\r\n COMPILER1_UP Defined when compiling with Delphi 1 or higher\r\n COMPILER2_UP Defined when compiling with Delphi 2 or C++ Builder 1 or higher\r\n COMPILER3_UP Defined when compiling with Delphi 3 or higher\r\n COMPILER35_UP Defined when compiling with C++ Builder 3 or higher\r\n COMPILER4_UP Defined when compiling with Delphi 4 or C++ Builder 4 or higher\r\n COMPILER5_UP Defined when compiling with Delphi 5 or C++ Builder 5 or higher\r\n COMPILER6_UP Defined when compiling with Delphi 6 or C++ Builder 6 or higher\r\n COMPILER7_UP Defined when compiling with Delphi 7\r\n COMPILER8_UP Defined when compiling with Delphi 8\r\n COMPILER9_UP Defined when compiling with Delphi Personalities of BDS 3.0\r\n COMPILER10_UP Defined when compiling with Delphi or C++ Builder Personalities of BDS 4.0 or higher\r\n COMPILER11_UP Defined when compiling with Delphi 2007 for Win32 or higher\r\n COMPILER12_UP Defined when compiling with Delphi or C++ Builder Personalities of BDS 6.0 or higher\r\n\r\n\r\n- RTL Versions\r\n\r\n Use e.g. following to determine the exact RTL version since version 14.0:\r\n {$IFDEF CONDITIONALEXPRESSIONS}\r\n {$IF Declared(RTLVersion) and (RTLVersion >= 14.2)}\r\n // code for Delphi 6.02 or higher, Kylix 2 or higher, C++ Builder 6 or higher\r\n ...\r\n {$IFEND}\r\n {$ENDIF}\r\n\r\n Directive Description\r\n ------------------------------------------------------------------------------\r\n RTL80_UP Defined when compiling with Delphi 1 or higher\r\n RTL90_UP Defined when compiling with Delphi 2 or higher\r\n RTL93_UP Defined when compiling with C++ Builder 1 or higher\r\n RTL100_UP Defined when compiling with Delphi 3 or higher\r\n RTL110_UP Defined when compiling with C++ Builder 3 or higher\r\n RTL120_UP Defined when compiling with Delphi 4 or higher\r\n RTL125_UP Defined when compiling with C++ Builder 4 or higher\r\n RTL130_UP Defined when compiling with Delphi 5 or C++ Builder 5 or higher\r\n RTL140_UP Defined when compiling with Delphi 6, Kylix 1, 2 or 3 or C++ Builder 6 or higher\r\n RTL150_UP Defined when compiling with Delphi 7 or higher\r\n RTL160_UP Defined when compiling with Delphi 8 or higher\r\n RTL170_UP Defined when compiling with Delphi Personalities of BDS 3.0 or higher\r\n RTL180_UP Defined when compiling with Delphi or C++ Builder Personalities of BDS 4.0 or higher\r\n RTL185_UP Defined when compiling with Delphi 2007 for Win32 or higher\r\n RTL190_UP Defined when compiling with Delphi.NET of BDS 5.0 or later\r\n RTL200_UP Defined when compiling with Delphi or C++ Builder Personalities of BDS 6.0 or later\r\n\r\n\r\n- CLR Versions\r\n\r\n Directive Description\r\n ------------------------------------------------------------------------------\r\n CLR Defined when compiling for .NET\r\n CLR10 Defined when compiling for .NET 1.0 (may be overriden by FORCE_CLR10)\r\n CLR10_UP Defined when compiling for .NET 1.0 or higher\r\n CLR11 Defined when compiling for .NET 1.1 (may be overriden by FORCE_CLR11)\r\n CLR11_UP Defined when compiling for .NET 1.1 or higher\r\n CLR20 Defined when compiling for .NET 2.0 (may be overriden by FORCE_CLR20)\r\n CLR20_UP Defined when compiling for .NET 2.0 or higher\r\n\r\n\r\n- Feature Directives\r\n\r\n The features directives are used to test if the compiler supports specific\r\n features, such as method overloading, and adjust the sources accordingly. Use\r\n of these directives is preferred over the use of the DELPHI and COMPILER\r\n directives.\r\n\r\n Directive Description\r\n ------------------------------------------------------------------------------\r\n SUPPORTS_CONSTPARAMS Compiler supports const parameters (D1+)\r\n SUPPORTS_SINGLE Compiler supports the Single type (D1+)\r\n SUPPORTS_DOUBLE Compiler supports the Double type (D1+)\r\n SUPPORTS_EXTENDED Compiler supports the Extended type (D1+)\r\n SUPPORTS_CURRENCY Compiler supports the Currency type (D2+)\r\n SUPPORTS_THREADVAR Compiler supports threadvar declarations (D2+)\r\n SUPPORTS_OUTPARAMS Compiler supports out parameters (D3+)\r\n SUPPORTS_VARIANT Compiler supports variant (D2+)\r\n SUPPORTS_WIDECHAR Compiler supports the WideChar type (D2+)\r\n SUPPORTS_WIDESTRING Compiler supports the WideString type (D3+/BCB3+)\r\n SUPPORTS_INTERFACE Compiler supports interfaces (D3+/BCB3+)\r\n SUPPORTS_DISPINTERFACE Compiler supports dispatch interfaces (D3+/BCB3+)\r\n SUPPORTS_DISPID Compiler supports dispatch ids (D3+/BCB3+/FPC)\r\n SUPPORTS_EXTSYM Compiler supports the $EXTERNALSYM directive (D4+/BCB3+)\r\n SUPPORTS_NODEFINE Compiler supports the $NODEFINE directive (D4+/BCB3+)\r\n SUPPORTS_LONGWORD Compiler supports the LongWord type (unsigned 32 bit) (D4+/BCB4+)\r\n SUPPORTS_INT64 Compiler supports the Int64 type (D4+/BCB4+)\r\n SUPPORTS_DYNAMICARRAYS Compiler supports dynamic arrays (D4+/BCB4+)\r\n SUPPORTS_DEFAULTPARAMS Compiler supports default parameters (D4+/BCB4+)\r\n SUPPORTS_OVERLOAD Compiler supports overloading (D4+/BCB4+)\r\n SUPPORTS_IMPLEMENTS Compiler supports implements (D4+/BCB4+)\r\n SUPPORTS_DEPRECATED Compiler supports the deprecated directive (D6+/BCB6+)\r\n SUPPORTS_PLATFORM Compiler supports the platform directive (D6+/BCB6+)\r\n SUPPORTS_LIBRARY Compiler supports the library directive (D6+/BCB6+/FPC)\r\n SUPPORTS_LOCAL Compiler supports the local directive (D6+/BCB6+)\r\n SUPPORTS_INLINE Compiler supports the inline directive (D9+/FPC)\r\n SUPPORTS_FOR_IN Compiler supports for in loops (D9+)\r\n SUPPORTS_NESTED_CONSTANTS Compiler supports nested constants (D9+)\r\n SUPPORTS_NESTED_TYPES Compiler supports nested types (D9+)\r\n SUPPORTS_ENHANCED_RECORDS Compiler supports class [operator|function|procedure] for record types (D9.NET, D10+)\r\n SUPPORTS_CLASS_FIELDS Compiler supports class fields (D9.NET, D10+)\r\n SUPPORTS_CLASS_HELPERS Compiler supports class helpers (D9.NET, D10+)\r\n SUPPORTS_CLASS_OPERATORS Compiler supports class operators (D9.NET, D10+)\r\n SUPPORTS_STRICT Compiler supports strict keyword (D9.NET, D10+)\r\n SUPPORTS_STATIC Compiler supports static keyword (D9.NET, D10+)\r\n SUPPORTS_FINAL Compiler supports final keyword (D9.NET, D10+)\r\n SUPPORTS_GENERICS Compiler supports generic implementations (D11.net, D12+)\r\n ACCEPT_DEPRECATED Compiler supports or ignores the deprecated directive (D6+/BCB6+/FPC)\r\n ACCEPT_PLATFORM Compiler supports or ignores the platform directive (D6+/BCB6+/FPC)\r\n ACCEPT_LIBRARY Compiler supports or ignores the library directive (D6+/BCB6+)\r\n SUPPORTS_CUSTOMVARIANTS Compiler supports custom variants (D6+/BCB6+)\r\n SUPPORTS_VARARGS Compiler supports varargs (D6+/BCB6+)\r\n SUPPORTS_ENUMVALUE Compiler supports assigning ordinalities to values of enums (D6+/BCB6+)\r\n SUPPORTS_DEPRECATED_WARNINGS Compiler supports deprecated warnings (D6+/BCB6+)\r\n SUPPORTS_LIBRARY_WARNINGS Compiler supports library warnings (D6+/BCB6+)\r\n SUPPORTS_PLATFORM_WARNINGS Compiler supports platform warnings (D6+/BCB6+)\r\n SUPPORTS_UNSAFE_WARNINGS Compiler supports unsafe warnings (D7)\r\n SUPPORTS_WEAKPACKAGEUNIT Compiler supports the WEAKPACKAGEUNIT directive\r\n SUPPORTS_COMPILETIME_MESSAGES Compiler supports the MESSAGE directive\r\n SUPPORTS_PACKAGES Compiler supports Packages \r\n HAS_UNIT_LIBC Unit Libc exists (Kylix, FPC on Linux/x86)\r\n HAS_UNIT_RTLCONSTS Unit RTLConsts exists (D6+/BCB6+/FPC)\r\n HAS_UNIT_TYPES Unit Types exists (D6+/BCB6+/FPC)\r\n HAS_UNIT_VARIANTS Unit Variants exists (D6+/BCB6+/FPC)\r\n HAS_UNIT_STRUTILS Unit StrUtils exists (D6+/BCB6+/FPC)\r\n HAS_UNIT_DATEUTILS Unit DateUtils exists (D6+/BCB6+/FPC)\r\n HAS_UNIT_CONTNRS Unit contnrs exists (D6+/BCB6+/FPC)\r\n HAS_UNIT_ANSISTRINGS Unit AnsiStrings exists (D12+)\r\n XPLATFORM_RTL The RTL supports crossplatform function names (e.g. RaiseLastOSError) (D6+/BCB6+/FPC)\r\n SUPPORTS_UNICODE string type is aliased to an unicode string (WideString or UnicodeString) (DX.net, D12+)\r\n SUPPORTS_UNICODE_STRING Compiler supports UnicodeString (D12+)\r\n\r\n\r\n- Compiler Settings\r\n\r\n The compiler settings directives indicate whether a specific compiler setting\r\n is in effect. This facilitates changing compiler settings locally in a more\r\n compact and readible manner.\r\n\r\n Directive Description\r\n ------------------------------------------------------------------------------\r\n ALIGN_ON Compiling in the A+ state (no alignment)\r\n BOOLEVAL_ON Compiling in the B+ state (complete boolean evaluation)\r\n ASSERTIONS_ON Compiling in the C+ state (assertions on)\r\n DEBUGINFO_ON Compiling in the D+ state (debug info generation on)\r\n IMPORTEDDATA_ON Compiling in the G+ state (creation of imported data references)\r\n LONGSTRINGS_ON Compiling in the H+ state (string defined as AnsiString)\r\n IOCHECKS_ON Compiling in the I+ state (I/O checking enabled)\r\n WRITEABLECONST_ON Compiling in the J+ state (typed constants can be modified)\r\n LOCALSYMBOLS Compiling in the L+ state (local symbol generation)\r\n TYPEINFO_ON Compiling in the M+ state (RTTI generation on)\r\n OPTIMIZATION_ON Compiling in the O+ state (code optimization on)\r\n OPENSTRINGS_ON Compiling in the P+ state (variable string parameters are openstrings)\r\n OVERFLOWCHECKS_ON Compiling in the Q+ state (overflow checing on)\r\n RANGECHECKS_ON Compiling in the R+ state (range checking on)\r\n TYPEDADDRESS_ON Compiling in the T+ state (pointers obtained using the @ operator are typed)\r\n SAFEDIVIDE_ON Compiling in the U+ state (save FDIV instruction through RTL emulation)\r\n VARSTRINGCHECKS_ON Compiling in the V+ state (type checking of shortstrings)\r\n STACKFRAMES_ON Compiling in the W+ state (generation of stack frames)\r\n EXTENDEDSYNTAX_ON Compiling in the X+ state (Delphi extended syntax enabled)\r\n*)\r\n\r\n{$DEFINE BORLAND}\r\n\r\n{ Set FreePascal to Delphi mode }\r\n{$IFDEF FPC}\r\n {$MODE DELPHI}\r\n {$ASMMODE Intel}\r\n {$UNDEF BORLAND}\r\n // FPC defines CPU* and Unix automatically\r\n{$ENDIF}\r\n\r\n{$IFDEF BORLAND}\r\n {$IFDEF LINUX}\r\n {$DEFINE KYLIX}\r\n {$ENDIF LINUX}\r\n {$IFNDEF CLR}\r\n {$DEFINE CPU386} // For Borland compilers select the x86 compat assembler by default\r\n {$DEFINE CPU32} // Assume Borland compilers are 32-bit (rather than 64-bit)\r\n {$ENDIF ~CLR}\r\n{$ENDIF BORLAND}\r\n\r\n{------------------------------------------------------------------------------}\r\n{ VERXXX to COMPILERX, DELPHIX and BCBX mappings }\r\n{------------------------------------------------------------------------------}\r\n\r\n{$IFDEF BORLAND}\r\n {$IFDEF KYLIX}\r\n {$I kylix.inc} // FPC incompatible stuff\r\n {$ELSE ~KYLIX}\r\n\r\n {$DEFINE UNKNOWN_COMPILER_VERSION}\r\n\r\n {$IFDEF VER80}\r\n {$DEFINE COMPILER1}\r\n {$DEFINE DELPHI1}\r\n {$DEFINE DELPHICOMPILER1}\r\n {$DEFINE RTL80_UP}\r\n {$UNDEF UNKNOWN_COMPILER_VERSION}\r\n {$ENDIF}\r\n\r\n {$IFDEF VER90}\r\n {$DEFINE COMPILER2}\r\n {$DEFINE DELPHI2}\r\n {$DEFINE DELPHICOMPILER2}\r\n {$DEFINE RTL90_UP}\r\n {$UNDEF UNKNOWN_COMPILER_VERSION}\r\n {$ENDIF}\r\n\r\n {$IFDEF VER93}\r\n {$DEFINE COMPILER2}\r\n {$DEFINE BCB1}\r\n {$DEFINE BCB}\r\n {$DEFINE RTL93_UP}\r\n {$UNDEF UNKNOWN_COMPILER_VERSION}\r\n {$ENDIF}\r\n\r\n {$IFDEF VER100}\r\n {$DEFINE COMPILER3}\r\n {$DEFINE DELPHI3}\r\n {$DEFINE DELPHICOMPILER3}\r\n {$DEFINE RTL100_UP}\r\n {$UNDEF UNKNOWN_COMPILER_VERSION}\r\n {$ENDIF}\r\n\r\n {$IFDEF VER110}\r\n {$DEFINE COMPILER35}\r\n {$DEFINE BCB3}\r\n {$DEFINE RTL110_UP}\r\n {$UNDEF UNKNOWN_COMPILER_VERSION}\r\n {$ENDIF}\r\n\r\n {$IFDEF VER120}\r\n {$DEFINE COMPILER4}\r\n {$DEFINE DELPHI4}\r\n {$DEFINE DELPHICOMPILER4}\r\n {$DEFINE RTL120_UP}\r\n {$UNDEF UNKNOWN_COMPILER_VERSION}\r\n {$ENDIF}\r\n\r\n {$IFDEF VER125}\r\n {$DEFINE COMPILER4}\r\n {$DEFINE BCB4}\r\n {$DEFINE BCB}\r\n {$DEFINE RTL125_UP}\r\n {$UNDEF UNKNOWN_COMPILER_VERSION}\r\n {$ENDIF}\r\n\r\n {$IFDEF VER130}\r\n {$DEFINE COMPILER5}\r\n {$IFDEF BCB}\r\n {$DEFINE BCB5}\r\n {$ELSE}\r\n {$DEFINE DELPHI5}\r\n {$DEFINE DELPHICOMPILER5}\r\n {$ENDIF}\r\n {$DEFINE RTL130_UP}\r\n {$UNDEF UNKNOWN_COMPILER_VERSION}\r\n {$ENDIF}\r\n\r\n {$IFDEF VER140}\r\n {$DEFINE COMPILER6}\r\n {$IFDEF BCB}\r\n {$DEFINE BCB6}\r\n {$ELSE}\r\n {$DEFINE DELPHI6}\r\n {$DEFINE DELPHICOMPILER6}\r\n {$ENDIF}\r\n {$DEFINE RTL140_UP}\r\n {$UNDEF UNKNOWN_COMPILER_VERSION}\r\n {$ENDIF}\r\n\r\n {$IFDEF VER150}\r\n {$DEFINE COMPILER7}\r\n {$DEFINE DELPHI7}\r\n {$DEFINE DELPHICOMPILER7}\r\n {$DEFINE RTL150_UP}\r\n {$UNDEF UNKNOWN_COMPILER_VERSION}\r\n {$ENDIF}\r\n\r\n {$IFDEF VER160}\r\n {$DEFINE BDS2}\r\n {$DEFINE BDS}\r\n {$IFDEF CLR}\r\n {$DEFINE CLR10}\r\n {$ENDIF CLR}\r\n {$DEFINE COMPILER8}\r\n {$DEFINE DELPHI8}\r\n {$DEFINE DELPHICOMPILER8}\r\n {$DEFINE RTL160_UP}\r\n {$UNDEF UNKNOWN_COMPILER_VERSION}\r\n {$ENDIF}\r\n\r\n {$IFDEF VER170}\r\n {$DEFINE BDS3}\r\n {$DEFINE BDS}\r\n {$IFDEF CLR}\r\n {$DEFINE CLR11}\r\n {$ENDIF CLR}\r\n {$DEFINE COMPILER9}\r\n {$DEFINE DELPHI9}\r\n {$DEFINE DELPHI2005} // synonym to DELPHI9\r\n {$DEFINE DELPHICOMPILER9}\r\n {$DEFINE RTL170_UP}\r\n {$UNDEF UNKNOWN_COMPILER_VERSION}\r\n {$ENDIF}\r\n\r\n {$IFDEF VER180}\r\n {$DEFINE BDS}\r\n {$IFDEF CLR}\r\n {$DEFINE CLR11}\r\n {$ENDIF CLR}\r\n {$IFDEF VER185}\r\n {$DEFINE BDS5}\r\n {$DEFINE COMPILER11}\r\n {$IFDEF BCB}\r\n {$DEFINE BCB11}\r\n {$ELSE}\r\n {$DEFINE DELPHI11}\r\n {$DEFINE DELPHI2007} // synonym to DELPHI11\r\n {$DEFINE DELPHICOMPILER11}\r\n {$ENDIF}\r\n {$DEFINE RTL185_UP}\r\n {$ELSE ~~VER185}\r\n {$DEFINE BDS4}\r\n {$DEFINE COMPILER10}\r\n {$IFDEF BCB}\r\n {$DEFINE BCB10}\r\n {$ELSE}\r\n {$DEFINE DELPHI10}\r\n {$DEFINE DELPHI2006} // synonym to DELPHI10\r\n {$DEFINE DELPHICOMPILER10}\r\n {$ENDIF}\r\n {$DEFINE RTL180_UP}\r\n {$ENDIF ~VER185}\r\n {$UNDEF UNKNOWN_COMPILER_VERSION}\r\n {$ENDIF}\r\n\r\n {$IFDEF VER190} // Delphi 2007 for .NET\r\n {$DEFINE BDS}\r\n {$DEFINE BDS5}\r\n {$IFDEF CLR}\r\n {$DEFINE CLR20}\r\n {$ENDIF CLR}\r\n {$DEFINE COMPILER11}\r\n {$DEFINE DELPHI11}\r\n {$DEFINE DELPHI2007} // synonym to DELPHI11\r\n {$DEFINE DELPHICOMPILER11}\r\n {$DEFINE RTL190_UP}\r\n {$UNDEF UNKNOWN_COMPILER_VERSION}\r\n {$ENDIF VER190}\r\n\r\n {$IFDEF VER200} // RAD Studio 2009\r\n {$DEFINE BDS}\r\n {$DEFINE BDS6}\r\n {$IFDEF CLR}\r\n {$DEFINE CLR20}\r\n {$ENDIF CLR}\r\n {$DEFINE COMPILER12}\r\n {$IFDEF BCB}\r\n {$DEFINE BCB12}\r\n {$ELSE}\r\n {$DEFINE DELPHI12}\r\n {$DEFINE DELPHI2009} // synonym to DELPHI12\r\n {$DEFINE DELPHICOMPILER12}\r\n {$ENDIF BCB}\r\n {$IFDEF CLR}\r\n {$DEFINE RTL190_UP}\r\n {$ELSE}\r\n {$DEFINE RTL200_UP}\r\n {$ENDIF}\r\n {$UNDEF UNKNOWN_COMPILER_VERSION}\r\n {$ENDIF VER200}\r\n\r\n {$IFDEF UNKNOWN_COMPILER_VERSION} // adjust for newer version (always use latest version)\r\n {$DEFINE BDS}\r\n {$DEFINE BDS6}\r\n {$DEFINE COMPILER12}\r\n {$IFDEF BCB}\r\n {$DEFINE BCB12}\r\n {$ELSE}\r\n {$DEFINE DELPHI12}\r\n {$DEFINE DELPHI2009} // synonym to DELPHI12\r\n {$DEFINE DELPHICOMPILER12}\r\n {$ENDIF BCB}\r\n {$IFDEF CLR}\r\n {$DEFINE RTL190_UP}\r\n {$ELSE}\r\n {$DEFINE RTL200_UP}\r\n {$ENDIF}\r\n {$UNDEF UNKNOWN_COMPILER_VERSION}\r\n {$ENDIF}\r\n\r\n {$ENDIF ~KYLIX}\r\n\r\n {$IFDEF BCB}\r\n {$DEFINE CPPBUILDER}\r\n {$DEFINE BCBCOMPILER}\r\n {$ELSE ~BCB}\r\n {$DEFINE DELPHI}\r\n {$DEFINE DELPHICOMPILER}\r\n {$ENDIF ~BCB}\r\n\r\n{$ENDIF BORLAND}\r\n\r\n{------------------------------------------------------------------------------}\r\n{ DELPHIX_UP from DELPHIX mappings }\r\n{------------------------------------------------------------------------------}\r\n\r\n{$IFDEF DELPHI12} {$DEFINE DELPHI12_UP} {$ENDIF}\r\n{$IFDEF DELPHI11} {$DEFINE DELPHI11_UP} {$ENDIF}\r\n{$IFDEF DELPHI10} {$DEFINE DELPHI10_UP} {$ENDIF}\r\n{$IFDEF DELPHI9} {$DEFINE DELPHI9_UP} {$ENDIF}\r\n{$IFDEF DELPHI8} {$DEFINE DELPHI8_UP} {$ENDIF}\r\n{$IFDEF DELPHI7} {$DEFINE DELPHI7_UP} {$ENDIF}\r\n{$IFDEF DELPHI6} {$DEFINE DELPHI6_UP} {$ENDIF}\r\n{$IFDEF DELPHI5} {$DEFINE DELPHI5_UP} {$ENDIF}\r\n{$IFDEF DELPHI4} {$DEFINE DELPHI4_UP} {$ENDIF}\r\n{$IFDEF DELPHI3} {$DEFINE DELPHI3_UP} {$ENDIF}\r\n{$IFDEF DELPHI2} {$DEFINE DELPHI2_UP} {$ENDIF}\r\n{$IFDEF DELPHI1} {$DEFINE DELPHI1_UP} {$ENDIF}\r\n\r\n{------------------------------------------------------------------------------}\r\n{ DELPHIX_UP from DELPHIX_UP mappings }\r\n{------------------------------------------------------------------------------}\r\n\r\n{$IFDEF DELPHI12_UP}\r\n {$DEFINE DELPHI2009_UP} // synonym to DELPHI12_UP\r\n {$DEFINE DELPHI11_UP}\r\n{$ENDIF}\r\n\r\n{$IFDEF DELPHI11_UP}\r\n {$DEFINE DELPHI2007_UP} // synonym to DELPHI11_UP\r\n {$DEFINE DELPHI10_UP}\r\n{$ENDIF}\r\n\r\n{$IFDEF DELPHI10_UP}\r\n {$DEFINE DELPHI2006_UP} // synonym to DELPHI10_UP\r\n {$DEFINE DELPHI9_UP}\r\n{$ENDIF}\r\n\r\n{$IFDEF DELPHI9_UP}\r\n {$DEFINE DELPHI2005_UP} // synonym to DELPHI9_UP\r\n {$DEFINE DELPHI8_UP}\r\n{$ENDIF}\r\n\r\n{$IFDEF DELPHI8_UP} {$DEFINE DELPHI7_UP} {$ENDIF}\r\n{$IFDEF DELPHI7_UP} {$DEFINE DELPHI6_UP} {$ENDIF}\r\n{$IFDEF DELPHI6_UP} {$DEFINE DELPHI5_UP} {$ENDIF}\r\n{$IFDEF DELPHI5_UP} {$DEFINE DELPHI4_UP} {$ENDIF}\r\n{$IFDEF DELPHI4_UP} {$DEFINE DELPHI3_UP} {$ENDIF}\r\n{$IFDEF DELPHI3_UP} {$DEFINE DELPHI2_UP} {$ENDIF}\r\n{$IFDEF DELPHI2_UP} {$DEFINE DELPHI1_UP} {$ENDIF}\r\n\r\n{------------------------------------------------------------------------------}\r\n{ BCBX_UP from BCBX mappings }\r\n{------------------------------------------------------------------------------}\r\n\r\n{$IFDEF BCB12} {$DEFINE BCB12_UP} {$ENDIF}\r\n{$IFDEF BCB11} {$DEFINE BCB11_UP} {$ENDIF}\r\n{$IFDEF BCB10} {$DEFINE BCB10_UP} {$ENDIF}\r\n{$IFDEF BCB6} {$DEFINE BCB6_UP} {$ENDIF}\r\n{$IFDEF BCB5} {$DEFINE BCB5_UP} {$ENDIF}\r\n{$IFDEF BCB4} {$DEFINE BCB4_UP} {$ENDIF}\r\n{$IFDEF BCB3} {$DEFINE BCB3_UP} {$ENDIF}\r\n{$IFDEF BCB1} {$DEFINE BCB1_UP} {$ENDIF}\r\n\r\n{------------------------------------------------------------------------------}\r\n{ BCBX_UP from BCBX_UP mappings }\r\n{------------------------------------------------------------------------------}\r\n\r\n{$IFDEF BCB12_UP} {$DEFINE BCB11_UP} {$ENDIF}\r\n{$IFDEF BCB11_UP} {$DEFINE BCB10_UP} {$ENDIF}\r\n{$IFDEF BCB10_UP} {$DEFINE BCB6_UP} {$ENDIF}\r\n{$IFDEF BCB6_UP} {$DEFINE BCB5_UP} {$ENDIF}\r\n{$IFDEF BCB5_UP} {$DEFINE BCB4_UP} {$ENDIF}\r\n{$IFDEF BCB4_UP} {$DEFINE BCB3_UP} {$ENDIF}\r\n{$IFDEF BCB3_UP} {$DEFINE BCB1_UP} {$ENDIF}\r\n\r\n{------------------------------------------------------------------------------}\r\n{ BDSX_UP from BDSX mappings }\r\n{------------------------------------------------------------------------------}\r\n\r\n{$IFDEF BDS6} {$DEFINE BDS6_UP} {$ENDIF}\r\n{$IFDEF BDS5} {$DEFINE BDS5_UP} {$ENDIF}\r\n{$IFDEF BDS4} {$DEFINE BDS4_UP} {$ENDIF}\r\n{$IFDEF BDS3} {$DEFINE BDS3_UP} {$ENDIF}\r\n{$IFDEF BDS2} {$DEFINE BDS2_UP} {$ENDIF}\r\n\r\n{------------------------------------------------------------------------------}\r\n{ BDSX_UP from BDSX_UP mappings }\r\n{------------------------------------------------------------------------------}\r\n\r\n{$IFDEF BDS6_UP} {$DEFINE BDS5_UP} {$ENDIF}\r\n{$IFDEF BDS5_UP} {$DEFINE BDS4_UP} {$ENDIF}\r\n{$IFDEF BDS4_UP} {$DEFINE BDS3_UP} {$ENDIF}\r\n{$IFDEF BDS3_UP} {$DEFINE BDS2_UP} {$ENDIF}\r\n\r\n{------------------------------------------------------------------------------}\r\n{ DELPHICOMPILERX_UP from DELPHICOMPILERX mappings }\r\n{------------------------------------------------------------------------------}\r\n\r\n{$IFDEF DELPHICOMPILER12} {$DEFINE DELPHICOMPILER12_UP} {$ENDIF}\r\n{$IFDEF DELPHICOMPILER11} {$DEFINE DELPHICOMPILER11_UP} {$ENDIF}\r\n{$IFDEF DELPHICOMPILER10} {$DEFINE DELPHICOMPILER10_UP} {$ENDIF}\r\n{$IFDEF DELPHICOMPILER9} {$DEFINE DELPHICOMPILER9_UP} {$ENDIF}\r\n{$IFDEF DELPHICOMPILER8} {$DEFINE DELPHICOMPILER8_UP} {$ENDIF}\r\n{$IFDEF DELPHICOMPILER7} {$DEFINE DELPHICOMPILER7_UP} {$ENDIF}\r\n{$IFDEF DELPHICOMPILER6} {$DEFINE DELPHICOMPILER6_UP} {$ENDIF}\r\n{$IFDEF DELPHICOMPILER5} {$DEFINE DELPHICOMPILER5_UP} {$ENDIF}\r\n{$IFDEF DELPHICOMPILER4} {$DEFINE DELPHICOMPILER4_UP} {$ENDIF}\r\n{$IFDEF DELPHICOMPILER3} {$DEFINE DELPHICOMPILER3_UP} {$ENDIF}\r\n{$IFDEF DELPHICOMPILER2} {$DEFINE DELPHICOMPILER2_UP} {$ENDIF}\r\n{$IFDEF DELPHICOMPILER1} {$DEFINE DELPHICOMPILER1_UP} {$ENDIF}\r\n\r\n{------------------------------------------------------------------------------}\r\n{ DELPHICOMPILERX_UP from DELPHICOMPILERX_UP mappings }\r\n{------------------------------------------------------------------------------}\r\n\r\n{$IFDEF DELPHICOMPILER12_UP} {$DEFINE DELPHICOMPILER11_UP} {$ENDIF}\r\n{$IFDEF DELPHICOMPILER11_UP} {$DEFINE DELPHICOMPILER10_UP} {$ENDIF}\r\n{$IFDEF DELPHICOMPILER10_UP} {$DEFINE DELPHICOMPILER9_UP} {$ENDIF}\r\n{$IFDEF DELPHICOMPILER9_UP} {$DEFINE DELPHICOMPILER8_UP} {$ENDIF}\r\n{$IFDEF DELPHICOMPILER8_UP} {$DEFINE DELPHICOMPILER7_UP} {$ENDIF}\r\n{$IFDEF DELPHICOMPILER8_UP} {$DEFINE DELPHICOMPILER7_UP} {$ENDIF}\r\n{$IFDEF DELPHICOMPILER7_UP} {$DEFINE DELPHICOMPILER6_UP} {$ENDIF}\r\n{$IFDEF DELPHICOMPILER6_UP} {$DEFINE DELPHICOMPILER5_UP} {$ENDIF}\r\n{$IFDEF DELPHICOMPILER5_UP} {$DEFINE DELPHICOMPILER4_UP} {$ENDIF}\r\n{$IFDEF DELPHICOMPILER4_UP} {$DEFINE DELPHICOMPILER3_UP} {$ENDIF}\r\n{$IFDEF DELPHICOMPILER3_UP} {$DEFINE DELPHICOMPILER2_UP} {$ENDIF}\r\n{$IFDEF DELPHICOMPILER2_UP} {$DEFINE DELPHICOMPILER1_UP} {$ENDIF}\r\n\r\n{------------------------------------------------------------------------------}\r\n{ COMPILERX_UP from COMPILERX mappings }\r\n{------------------------------------------------------------------------------}\r\n\r\n{$IFDEF COMPILER12} {$DEFINE COMPILER12_UP} {$ENDIF}\r\n{$IFDEF COMPILER11} {$DEFINE COMPILER11_UP} {$ENDIF}\r\n{$IFDEF COMPILER10} {$DEFINE COMPILER10_UP} {$ENDIF}\r\n{$IFDEF COMPILER9} {$DEFINE COMPILER9_UP} {$ENDIF}\r\n{$IFDEF COMPILER8} {$DEFINE COMPILER8_UP} {$ENDIF}\r\n{$IFDEF COMPILER7} {$DEFINE COMPILER7_UP} {$ENDIF}\r\n{$IFDEF COMPILER6} {$DEFINE COMPILER6_UP} {$ENDIF}\r\n{$IFDEF COMPILER5} {$DEFINE COMPILER5_UP} {$ENDIF}\r\n{$IFDEF COMPILER4} {$DEFINE COMPILER4_UP} {$ENDIF}\r\n{$IFDEF COMPILER35} {$DEFINE COMPILER35_UP} {$ENDIF}\r\n{$IFDEF COMPILER3} {$DEFINE COMPILER3_UP} {$ENDIF}\r\n{$IFDEF COMPILER2} {$DEFINE COMPILER2_UP} {$ENDIF}\r\n{$IFDEF COMPILER1} {$DEFINE COMPILER1_UP} {$ENDIF}\r\n\r\n{------------------------------------------------------------------------------}\r\n{ COMPILERX_UP from COMPILERX_UP mappings }\r\n{------------------------------------------------------------------------------}\r\n\r\n{$IFDEF COMPILER12_UP} {$DEFINE COMPILER11_UP} {$ENDIF}\r\n{$IFDEF COMPILER11_UP} {$DEFINE COMPILER10_UP} {$ENDIF}\r\n{$IFDEF COMPILER10_UP} {$DEFINE COMPILER9_UP} {$ENDIF}\r\n{$IFDEF COMPILER9_UP} {$DEFINE COMPILER8_UP} {$ENDIF}\r\n{$IFDEF COMPILER8_UP} {$DEFINE COMPILER7_UP} {$ENDIF}\r\n{$IFDEF COMPILER7_UP} {$DEFINE COMPILER6_UP} {$ENDIF}\r\n{$IFDEF COMPILER6_UP} {$DEFINE COMPILER5_UP} {$ENDIF}\r\n{$IFDEF COMPILER5_UP} {$DEFINE COMPILER4_UP} {$ENDIF}\r\n{$IFDEF COMPILER4_UP} {$DEFINE COMPILER35_UP} {$ENDIF}\r\n{$IFDEF COMPILER35_UP} {$DEFINE COMPILER3_UP} {$ENDIF}\r\n{$IFDEF COMPILER3_UP} {$DEFINE COMPILER2_UP} {$ENDIF}\r\n{$IFDEF COMPILER2_UP} {$DEFINE COMPILER1_UP} {$ENDIF}\r\n\r\n{------------------------------------------------------------------------------}\r\n{ RTLX_UP from RTLX_UP mappings }\r\n{------------------------------------------------------------------------------}\r\n\r\n{$IFDEF RTL200_UP} {$DEFINE RTL190_UP} {$ENDIF}\r\n{$IFDEF RTL190_UP} {$DEFINE RTL185_UP} {$ENDIF}\r\n{$IFDEF RTL185_UP} {$DEFINE RTL180_UP} {$ENDIF}\r\n{$IFDEF RTL180_UP} {$DEFINE RTL170_UP} {$ENDIF}\r\n{$IFDEF RTL170_UP} {$DEFINE RTL160_UP} {$ENDIF}\r\n{$IFDEF RTL160_UP} {$DEFINE RTL150_UP} {$ENDIF}\r\n{$IFDEF RTL150_UP} {$DEFINE RTL145_UP} {$ENDIF}\r\n{$IFDEF RTL145_UP} {$DEFINE RTL142_UP} {$ENDIF}\r\n{$IFDEF RTL142_UP} {$DEFINE RTL140_UP} {$ENDIF}\r\n{$IFDEF RTL140_UP} {$DEFINE RTL130_UP} {$ENDIF}\r\n{$IFDEF RTL130_UP} {$DEFINE RTL125_UP} {$ENDIF}\r\n{$IFDEF RTL125_UP} {$DEFINE RTL120_UP} {$ENDIF}\r\n{$IFDEF RTL120_UP} {$DEFINE RTL110_UP} {$ENDIF}\r\n{$IFDEF RTL110_UP} {$DEFINE RTL100_UP} {$ENDIF}\r\n{$IFDEF RTL100_UP} {$DEFINE RTL93_UP} {$ENDIF}\r\n{$IFDEF RTL93_UP} {$DEFINE RTL90_UP} {$ENDIF}\r\n{$IFDEF RTL90_UP} {$DEFINE RTL80_UP} {$ENDIF}\r\n\r\n{------------------------------------------------------------------------------}\r\n{ Check for CLR overrides of default detection }\r\n{------------------------------------------------------------------------------}\r\n\r\n{$IFDEF CLR}\r\n {$IFDEF FORCE_CLR10}\r\n {$DEFINE CLR10}\r\n {$UNDEF CLR11}\r\n {$UNDEF CLR20}\r\n {$ENDIF FORCE_CLR10}\r\n\r\n {$IFDEF FORCE_CLR11}\r\n {$UNDEF CLR10}\r\n {$DEFINE CLR11}\r\n {$UNDEF CLR20}\r\n {$ENDIF FORCE_CLR11}\r\n\r\n {$IFDEF FORCE_CLR20}\r\n {$UNDEF CLR10}\r\n {$UNDEF CLR11}\r\n {$DEFINE CLR20}\r\n {$ENDIF FORCE_CLR20}\r\n{$ENDIF CLR}\r\n\r\n{------------------------------------------------------------------------------}\r\n{ CLRX from CLRX_UP mappings }\r\n{------------------------------------------------------------------------------}\r\n\r\n{$IFDEF CLR10} {$DEFINE CLR10_UP} {$ENDIF}\r\n{$IFDEF CLR11} {$DEFINE CLR11_UP} {$ENDIF}\r\n{$IFDEF CLR20} {$DEFINE CLR20_UP} {$ENDIF}\r\n\r\n{------------------------------------------------------------------------------}\r\n{ CLRX_UP from CLRX_UP mappings }\r\n{------------------------------------------------------------------------------}\r\n\r\n{$IFDEF CLR20_UP} {$DEFINE CLR11_UP} {$ENDIF}\r\n{$IFDEF CLR11_UP} {$DEFINE CLR10_UP} {$ENDIF}\r\n\r\n{------------------------------------------------------------------------------}\r\n\r\n{$IFDEF DELPHICOMPILER}\r\n {$DEFINE DELPHILANGUAGE}\r\n{$ENDIF}\r\n\r\n{$IFDEF BCBCOMPILER}\r\n {$DEFINE DELPHILANGUAGE}\r\n{$ENDIF}\r\n\r\n{------------------------------------------------------------------------------}\r\n{ KYLIXX_UP from KYLIXX mappings }\r\n{------------------------------------------------------------------------------}\r\n\r\n{$IFDEF KYLIX3} {$DEFINE KYLIX3_UP} {$ENDIF}\r\n{$IFDEF KYLIX2} {$DEFINE KYLIX2_UP} {$ENDIF}\r\n{$IFDEF KYLIX1} {$DEFINE KYLIX1_UP} {$ENDIF}\r\n\r\n{------------------------------------------------------------------------------}\r\n{ KYLIXX_UP from KYLIXX_UP mappings }\r\n{------------------------------------------------------------------------------}\r\n\r\n{$IFDEF KYLIX3_UP} {$DEFINE KYLIX2_UP} {$ENDIF}\r\n{$IFDEF KYLIX2_UP} {$DEFINE KYLIX1_UP} {$ENDIF}\r\n\r\n{------------------------------------------------------------------------------}\r\n{ Map COMPILERX_UP to friendly feature names }\r\n{------------------------------------------------------------------------------}\r\n\r\n{$IFDEF FPC}\r\n {$IFDEF VER1_0}\r\n Please use FPC 2.0 or higher to compile this.\r\n {$ELSE}\r\n {$DEFINE SUPPORTS_OUTPARAMS}\r\n {$DEFINE SUPPORTS_WIDECHAR}\r\n {$DEFINE SUPPORTS_WIDESTRING}\r\n {$IFDEF HASINTF}\r\n {$DEFINE SUPPORTS_INTERFACE}\r\n {$ENDIF}\r\n {$IFDEF HASVARIANT}\r\n {$DEFINE SUPPORTS_VARIANT}\r\n {$ENDIF}\r\n {$IFDEF FPC_HAS_TYPE_SINGLE}\r\n {$DEFINE SUPPORTS_SINGLE}\r\n {$ENDIF}\r\n {$IFDEF FPC_HAS_TYPE_DOUBLE}\r\n {$DEFINE SUPPORTS_DOUBLE}\r\n {$ENDIF}\r\n {$IFDEF FPC_HAS_TYPE_EXTENDED}\r\n {$DEFINE SUPPORTS_EXTENDED}\r\n {$ENDIF}\r\n {$IFDEF HASCURRENCY}\r\n {$DEFINE SUPPORTS_CURRENCY}\r\n {$ENDIF}\r\n {$DEFINE SUPPORTS_THREADVAR}\r\n {$DEFINE SUPPORTS_CONSTPARAMS}\r\n {$DEFINE SUPPORTS_LONGWORD}\r\n {$DEFINE SUPPORTS_INT64}\r\n {$DEFINE SUPPORTS_DYNAMICARRAYS}\r\n {$DEFINE SUPPORTS_DEFAULTPARAMS}\r\n {$DEFINE SUPPORTS_OVERLOAD}\r\n {$DEFINE ACCEPT_DEPRECATED} // 2.2 also gives warnings\r\n {$DEFINE ACCEPT_PLATFORM} // 2.2 also gives warnings\r\n {$DEFINE ACCEPT_LIBRARY}\r\n {$DEFINE SUPPORTS_EXTSYM}\r\n {$DEFINE SUPPORTS_NODEFINE}\r\n\r\n {$DEFINE SUPPORTS_CUSTOMVARIANTS}\r\n {$DEFINE SUPPORTS_VARARGS}\r\n {$DEFINE SUPPORTS_ENUMVALUE}\r\n {$IFDEF LINUX}\r\n {$DEFINE HAS_UNIT_LIBC}\r\n {$ENDIF LINUX}\r\n {$DEFINE HAS_UNIT_CONTNRS}\r\n {$DEFINE HAS_UNIT_TYPES}\r\n {$DEFINE HAS_UNIT_VARIANTS}\r\n {$DEFINE HAS_UNIT_STRUTILS}\r\n {$DEFINE HAS_UNIT_DATEUTILS}\r\n {$DEFINE HAS_UNIT_RTLCONSTS}\r\n\r\n {$DEFINE XPLATFORM_RTL}\r\n\r\n {$IFDEF VER2_2}\r\n {$DEFINE SUPPORTS_DISPINTERFACE}\r\n {$DEFINE SUPPORTS_IMPLEMENTS}\r\n {$DEFINE SUPPORTS_DISPID}\r\n {$ELSE}\r\n {$UNDEF SUPPORTS_DISPINTERFACE}\r\n {$UNDEF SUPPORTS_IMPLEMENTS}\r\n {$endif}\r\n {$UNDEF SUPPORTS_UNSAFE_WARNINGS}\r\n {$ENDIF}\r\n{$ENDIF FPC}\r\n\r\n{$IFDEF CLR}\r\n {$DEFINE SUPPORTS_UNICODE}\r\n{$ENDIF CLR}\r\n\r\n{$IFDEF COMPILER1_UP}\r\n {$DEFINE SUPPORTS_CONSTPARAMS}\r\n {$DEFINE SUPPORTS_SINGLE}\r\n {$DEFINE SUPPORTS_DOUBLE}\r\n {$DEFINE SUPPORTS_EXTENDED}\r\n {$DEFINE SUPPORTS_PACKAGES} \r\n{$ENDIF COMPILER1_UP}\r\n\r\n{$IFDEF COMPILER2_UP}\r\n {$DEFINE SUPPORTS_CURRENCY}\r\n {$DEFINE SUPPORTS_THREADVAR}\r\n {$DEFINE SUPPORTS_VARIANT}\r\n {$DEFINE SUPPORTS_WIDECHAR}\r\n{$ENDIF COMPILER2_UP}\r\n\r\n{$IFDEF COMPILER3_UP}\r\n {$DEFINE SUPPORTS_OUTPARAMS}\r\n {$DEFINE SUPPORTS_WIDESTRING}\r\n {$DEFINE SUPPORTS_INTERFACE}\r\n {$DEFINE SUPPORTS_DISPINTERFACE}\r\n {$DEFINE SUPPORTS_DISPID}\r\n {$DEFINE SUPPORTS_WEAKPACKAGEUNIT}\r\n{$ENDIF COMPILER3_UP}\r\n\r\n{$IFDEF COMPILER35_UP}\r\n {$DEFINE SUPPORTS_EXTSYM}\r\n {$DEFINE SUPPORTS_NODEFINE}\r\n{$ENDIF COMPILER35_UP}\r\n\r\n{$IFDEF COMPILER4_UP}\r\n {$DEFINE SUPPORTS_LONGWORD}\r\n {$DEFINE SUPPORTS_INT64}\r\n {$DEFINE SUPPORTS_DYNAMICARRAYS}\r\n {$DEFINE SUPPORTS_DEFAULTPARAMS}\r\n {$DEFINE SUPPORTS_OVERLOAD}\r\n {$DEFINE SUPPORTS_IMPLEMENTS}\r\n{$ENDIF COMPILER4_UP}\r\n\r\n{$IFDEF COMPILER6_UP}\r\n {$DEFINE SUPPORTS_DEPRECATED}\r\n {$DEFINE SUPPORTS_LIBRARY}\r\n {$DEFINE SUPPORTS_PLATFORM}\r\n {$DEFINE SUPPORTS_LOCAL}\r\n {$DEFINE ACCEPT_DEPRECATED}\r\n {$DEFINE ACCEPT_PLATFORM}\r\n {$DEFINE ACCEPT_LIBRARY}\r\n {$DEFINE SUPPORTS_DEPRECATED_WARNINGS}\r\n {$DEFINE SUPPORTS_LIBRARY_WARNINGS}\r\n {$DEFINE SUPPORTS_PLATFORM_WARNINGS}\r\n {$DEFINE SUPPORTS_CUSTOMVARIANTS}\r\n {$DEFINE SUPPORTS_VARARGS}\r\n {$DEFINE SUPPORTS_ENUMVALUE}\r\n {$DEFINE SUPPORTS_COMPILETIME_MESSAGES}\r\n{$ENDIF COMPILER6_UP}\r\n\r\n{$IFDEF COMPILER7_UP}\r\n {$DEFINE SUPPORTS_UNSAFE_WARNINGS}\r\n{$ENDIF COMPILER7_UP}\r\n\r\n{$IFDEF COMPILER9_UP}\r\n {$DEFINE SUPPORTS_FOR_IN}\r\n {$DEFINE SUPPORTS_INLINE}\r\n {$DEFINE SUPPORTS_NESTED_CONSTANTS}\r\n {$DEFINE SUPPORTS_NESTED_TYPES}\r\n {$IFDEF CLR}\r\n {$DEFINE SUPPORTS_ENHANCED_RECORDS}\r\n {$DEFINE SUPPORTS_CLASS_FIELDS}\r\n {$DEFINE SUPPORTS_CLASS_HELPERS}\r\n {$DEFINE SUPPORTS_CLASS_OPERATORS}\r\n {$DEFINE SUPPORTS_STRICT}\r\n {$DEFINE SUPPORTS_STATIC}\r\n {$DEFINE SUPPORTS_FINAL}\r\n {$ENDIF CLR}\r\n{$ENDIF COMPILER9_UP}\r\n\r\n{$IFDEF COMPILER10_UP}\r\n {$DEFINE SUPPORTS_ENHANCED_RECORDS}\r\n {$DEFINE SUPPORTS_CLASS_FIELDS}\r\n {$DEFINE SUPPORTS_CLASS_HELPERS}\r\n {$DEFINE SUPPORTS_CLASS_OPERATORS}\r\n {$DEFINE SUPPORTS_STRICT}\r\n {$DEFINE SUPPORTS_STATIC}\r\n {$DEFINE SUPPORTS_FINAL}\r\n{$ENDIF COMPILER10_UP}\r\n\r\n{$IFDEF COMPILER11_UP}\r\n {$IFDEF CLR}\r\n {$DEFINE SUPPORTS_GENERICS}\r\n {$ENDIF CLR}\r\n{$ENDIF COMPILER11_UP}\r\n\r\n{$IFDEF COMPILER12_UP}\r\n {$DEFINE SUPPORTS_GENERICS}\r\n {$DEFINE HAS_UNIT_ANSISTRINGS}\r\n {$IFNDEF CLR}\r\n {$DEFINE SUPPORTS_UNICODE}\r\n {$DEFINE SUPPORTS_UNICODE_STRING}\r\n {$ENDIF CLR}\r\n{$ENDIF COMPILER12_UP}\r\n\r\n{$IFDEF RTL140_UP}\r\n {$IFDEF LINUX}\r\n {$DEFINE HAS_UNIT_LIBC}\r\n {$ENDIF LINUX}\r\n {$DEFINE HAS_UNIT_RTLCONSTS}\r\n {$DEFINE HAS_UNIT_TYPES}\r\n {$DEFINE HAS_UNIT_VARIANTS}\r\n {$DEFINE HAS_UNIT_STRUTILS}\r\n {$DEFINE HAS_UNIT_DATEUTILS}\r\n {$DEFINE XPLATFORM_RTL}\r\n{$ENDIF RTL140_UP}\r\n\r\n{$IFDEF RTL130_UP}\r\n {$DEFINE HAS_UNIT_CONTNRS}\r\n{$ENDIF RTL130_UP}\r\n\r\n{------------------------------------------------------------------------------}\r\n{ Cross-platform related defines }\r\n{------------------------------------------------------------------------------}\r\n\r\n{$IFNDEF CPU386}\r\n {$DEFINE PUREPASCAL}\r\n{$ENDIF}\r\n\r\n{$IFDEF WIN32}\r\n {$DEFINE MSWINDOWS} // predefined for D6+/BCB6+\r\n {$DEFINE Win32API}\r\n{$ENDIF}\r\n\r\n{$IFDEF DELPHILANGUAGE}\r\n {$IFDEF LINUX}\r\n {$DEFINE UNIX}\r\n {$ENDIF}\r\n\r\n {$IFNDEF CONSOLE}\r\n {$IFDEF LINUX}\r\n {$DEFINE VisualCLX}\r\n {$ENDIF}\r\n {$IFNDEF VisualCLX}\r\n {$DEFINE VCL}\r\n {$ENDIF}\r\n {$ENDIF ~CONSOLE}\r\n{$ENDIF DELPHILANGUAGE}\r\n\r\n{------------------------------------------------------------------------------}\r\n{ Compiler settings }\r\n{------------------------------------------------------------------------------}\r\n\r\n{$IFOPT A+} {$DEFINE ALIGN_ON} {$ENDIF}\r\n{$IFOPT B+} {$DEFINE BOOLEVAL_ON} {$ENDIF}\r\n{$IFDEF COMPILER2_UP}\r\n {$IFOPT C+} {$DEFINE ASSERTIONS_ON} {$ENDIF}\r\n{$ENDIF}\r\n{$IFOPT D+} {$DEFINE DEBUGINFO_ON} {$ENDIF}\r\n{$IFOPT G+} {$DEFINE IMPORTEDDATA_ON} {$ENDIF}\r\n{$IFDEF COMPILER2_UP}\r\n {$IFOPT H+} {$DEFINE LONGSTRINGS_ON} {$ENDIF}\r\n{$ENDIF}\r\n\r\n// Hints\r\n{$IFOPT I+} {$DEFINE IOCHECKS_ON} {$ENDIF}\r\n{$IFDEF COMPILER2_UP}\r\n {$IFOPT J+} {$DEFINE WRITEABLECONST_ON} {$ENDIF}\r\n{$ENDIF}\r\n{$IFOPT L+} {$DEFINE LOCALSYMBOLS} {$ENDIF}\r\n{$IFOPT M+} {$DEFINE TYPEINFO_ON} {$ENDIF}\r\n{$IFOPT O+} {$DEFINE OPTIMIZATION_ON} {$ENDIF}\r\n{$IFOPT P+} {$DEFINE OPENSTRINGS_ON} {$ENDIF}\r\n{$IFOPT Q+} {$DEFINE OVERFLOWCHECKS_ON} {$ENDIF}\r\n{$IFOPT R+} {$DEFINE RANGECHECKS_ON} {$ENDIF}\r\n\r\n// Real compatibility\r\n{$IFOPT T+} {$DEFINE TYPEDADDRESS_ON} {$ENDIF}\r\n{$IFOPT U+} {$DEFINE SAFEDIVIDE_ON} {$ENDIF}\r\n{$IFOPT V+} {$DEFINE VARSTRINGCHECKS_ON} {$ENDIF}\r\n{$IFOPT W+} {$DEFINE STACKFRAMES_ON} {$ENDIF}\r\n\r\n// Warnings\r\n{$IFOPT X+} {$DEFINE EXTENDEDSYNTAX_ON} {$ENDIF}\r\n\r\n// for Delphi/BCB trial versions remove the point from the line below\r\n{.$UNDEF SUPPORTS_WEAKPACKAGEUNIT}\r\n\r\n{$ENDIF ~JEDI_INC}\r\n" }, { "path": "External/SynEdit/Source/SynEditKbdHandler.pas", "content": "{-------------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: SynEditKeyCmds.pas, released 2000-04-07.\r\nThe Original Code is based on the mwKeyCmds.pas file from the\r\nmwEdit component suite by Martin Waldenburg and other developers, the Initial\r\nAuthor of this file is Brad Stowers.\r\nUnicode translation by Mal Hrz.\r\nAll Rights Reserved.\r\n\r\nContributors to the SynEdit and mwEdit projects are listed in the\r\nContributors.txt file.\r\n\r\nAlternatively, the contents of this file may be used under the terms of the\r\nGNU General Public License Version 2 or later (the \"GPL\"), in which case\r\nthe provisions of the GPL are applicable instead of those above.\r\nIf you wish to allow use of your version of this file only under the terms\r\nof the GPL and not to allow others to use your version of this file\r\nunder the MPL, indicate your decision by deleting the provisions above and\r\nreplace them with the notice and other provisions required by the GPL.\r\nIf you do not delete the provisions above, a recipient may use your version\r\nof this file under either the MPL or the GPL.\r\n\r\n$Id: SynEditKbdHandler.pas,v 1.10.2.1 2004/08/31 12:55:17 maelh Exp $\r\n\r\nYou may retrieve the latest version of this file at the SynEdit home page,\r\nlocated at http://SynEdit.SourceForge.net\r\n\r\nKnown Issues:\r\n-------------------------------------------------------------------------------}\r\n\r\n{$IFNDEF QSYNEDITKBDHANDLER}\r\nunit SynEditKbdHandler;\r\n{$ENDIF}\r\n\r\n{$I SynEdit.inc}\r\n\r\ninterface\r\n\r\nuses\r\n{$IFDEF SYN_CLX}\r\n Types,\r\n QGraphics,\r\n QControls,\r\n QForms,\r\n QSynEditTypes,\r\n{$ELSE}\r\n Windows,\r\n Messages,\r\n Graphics,\r\n Controls,\r\n Forms,\r\n SynEditTypes,\r\n{$ENDIF}\r\n SysUtils,\r\n Classes;\r\n\r\ntype\r\n { This class provides a TWinControl-Object which supports only the\r\n needed Methods }\r\n TKeyboardControl = class(TWinControl)\r\n public\r\n property OnKeyDown;\r\n property OnKeyPress;\r\n property OnMouseDown;\r\n end;\r\n\r\n TMouseCursorEvent = procedure(Sender: TObject; const aLineCharPos: TBufferCoord;\r\n var aCursor: TCursor) of object;\r\n\r\n TMethodList = class\r\n private\r\n fData: TList;\r\n function GetItem(Index: integer): TMethod;\r\n function GetCount: Integer;\r\n public\r\n constructor Create;\r\n destructor Destroy; override;\r\n procedure Add(aHandler: TMethod);\r\n procedure Remove(aHandler: TMethod);\r\n property Items[Index: Integer]: TMethod read GetItem; default;\r\n property Count: Integer read GetCount;\r\n end;\r\n\r\n TSynEditKbdHandler = class (TObject)\r\n private\r\n fKeyPressChain: TMethodList;\r\n fKeyDownChain: TMethodList;\r\n fKeyUpChain: TMethodList;\r\n fMouseDownChain: TMethodList;\r\n fMouseUpChain: TMethodList;\r\n fMouseCursorChain: TMethodList;\r\n { avoid infinite recursiveness }\r\n fInKeyPress: Boolean;\r\n fInKeyDown: Boolean;\r\n fInKeyUp: Boolean;\r\n fInMouseDown: Boolean;\r\n fInMouseUp: Boolean;\r\n fInMouseCursor: Boolean;\r\n public\r\n constructor Create;\r\n destructor Destroy; override;\r\n\r\n procedure ExecuteKeyPress(Sender: TObject; var Key: WideChar);\r\n procedure ExecuteKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);\r\n procedure ExecuteKeyUp(Sender: TObject; var Key: Word; Shift: TShiftState);\r\n procedure ExecuteMouseDown(Sender: TObject; Button: TMouseButton;\r\n Shift: TShiftState; X, Y: Integer);\r\n procedure ExecuteMouseUp(Sender: TObject; Button: TMouseButton;\r\n Shift: TShiftState; X, Y: Integer);\r\n procedure ExecuteMouseCursor(Sender: TObject; const aLineCharPos: TBufferCoord;\r\n var aCursor: TCursor);\r\n\r\n procedure AddKeyDownHandler(aHandler: TKeyEvent);\r\n procedure RemoveKeyDownHandler(aHandler: TKeyEvent);\r\n procedure AddKeyUpHandler(aHandler: TKeyEvent);\r\n procedure RemoveKeyUpHandler(aHandler: TKeyEvent);\r\n procedure AddKeyPressHandler(aHandler: TKeyPressWEvent);\r\n procedure RemoveKeyPressHandler(aHandler: TKeyPressWEvent);\r\n procedure AddMouseDownHandler(aHandler: TMouseEvent);\r\n procedure RemoveMouseDownHandler(aHandler: TMouseEvent);\r\n procedure AddMouseUpHandler(aHandler: TMouseEvent);\r\n procedure RemoveMouseUpHandler(aHandler: TMouseEvent);\r\n procedure AddMouseCursorHandler(aHandler: TMouseCursorEvent);\r\n procedure RemoveMouseCursorHandler(aHandler: TMouseCursorEvent);\r\n end;\r\n\r\n\r\nimplementation\r\n\r\n{ TSynEditKbdHandler }\r\n\r\nprocedure TSynEditKbdHandler.AddKeyDownHandler(aHandler: TKeyEvent);\r\nbegin\r\n fKeyDownChain.Add(TMethod(aHandler));\r\nend;\r\n\r\nprocedure TSynEditKbdHandler.AddKeyUpHandler(aHandler: TKeyEvent);\r\nbegin\r\n fKeyUpChain.Add(TMethod(aHandler));\r\nend;\r\n\r\nprocedure TSynEditKbdHandler.AddKeyPressHandler(aHandler: TKeyPressWEvent);\r\nbegin\r\n fKeyPressChain.Add(TMethod(aHandler));\r\nend;\r\n\r\nprocedure TSynEditKbdHandler.AddMouseDownHandler(aHandler: TMouseEvent);\r\nbegin\r\n fMouseDownChain.Add(TMethod(aHandler));\r\nend;\r\n\r\nprocedure TSynEditKbdHandler.AddMouseUpHandler(aHandler: TMouseEvent);\r\nbegin\r\n fMouseUpChain.Add(TMethod(aHandler));\r\nend;\r\n\r\nprocedure TSynEditKbdHandler.AddMouseCursorHandler(aHandler: TMouseCursorEvent);\r\nbegin\r\n fMouseCursorChain.Add(TMethod(aHandler));\r\nend;\r\n\r\nconstructor TSynEditKbdHandler.Create;\r\nbegin\r\n { Elements to handle KeyDown-Events }\r\n fKeyDownChain := TMethodList.Create;\r\n\r\n { Elements to handle KeyUp-Events }\r\n fKeyUpChain := TMethodList.Create;\r\n\r\n { Elements to handle KeyPress-Events }\r\n fKeyPressChain := TMethodList.Create;\r\n\r\n { Elements to handle MouseDown Events }\r\n fMouseDownChain := TMethodList.Create;\r\n\r\n { Elements to handle MouseUp Events }\r\n fMouseUpChain := TMethodList.Create;\r\n\r\n { Elements to handle MouseCursor Events }\r\n fMouseCursorChain := TMethodList.Create;\r\nend;\r\n\r\ndestructor TSynEditKbdHandler.Destroy;\r\nbegin\r\n fKeyPressChain.Free;\r\n fKeyDownChain.Free;\r\n fKeyUpChain.Free;\r\n fMouseDownChain.Free;\r\n fMouseUpChain.Free;\r\n fMouseCursorChain.Free;\r\n\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TSynEditKbdHandler.ExecuteKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);\r\nvar\r\n idx: Integer;\r\nbegin\r\n if fInKeyDown then\r\n exit;\r\n fInKeyDown := True;\r\n try\r\n with fKeyDownChain do\r\n begin\r\n for idx := Count - 1 downto 0 do\r\n begin\r\n TKeyEvent(Items[idx])(Sender, Key, Shift);\r\n if (Key = 0) then\r\n begin\r\n fInKeyDown := False;\r\n exit;\r\n end;\r\n end;\r\n end;\r\n finally\r\n fInKeyDown := False;\r\n end;\r\nend;\r\n\r\nprocedure TSynEditKbdHandler.ExecuteKeyUp(Sender: TObject; var Key: Word; Shift: TShiftState);\r\nvar\r\n idx: Integer;\r\nbegin\r\n if fInKeyUp then\r\n exit;\r\n fInKeyUp := True;\r\n try\r\n with fKeyUpChain do\r\n begin\r\n for idx := Count - 1 downto 0 do\r\n begin\r\n TKeyEvent(Items[idx])(Sender,Key,Shift);\r\n if (Key = 0) then\r\n begin\r\n fInKeyUp := False;\r\n exit;\r\n end;\r\n end;\r\n end;\r\n finally\r\n fInKeyUp := False;\r\n end;\r\nend;\r\n\r\nprocedure TSynEditKbdHandler.ExecuteKeyPress(Sender: TObject; var Key: WideChar);\r\nvar\r\n idx: Integer;\r\nbegin\r\n if fInKeyPress then\r\n exit;\r\n fInKeyPress := True;\r\n try\r\n with fKeyPressChain do\r\n begin\r\n for idx := Count - 1 downto 0 do\r\n begin\r\n TKeyPressWEvent(Items[idx])(Sender, Key);\r\n if (Key = #0) then\r\n begin\r\n fInKeyPress := False;\r\n exit;\r\n end;\r\n end;\r\n end;\r\n finally\r\n fInKeyPress := False;\r\n end;\r\nend;\r\n\r\nprocedure TSynEditKbdHandler.ExecuteMouseDown(Sender: TObject; Button: TMouseButton;\r\n Shift: TShiftState; X, Y: Integer);\r\nvar\r\n cHandler: Integer;\r\nbegin\r\n if fInMouseDown then\r\n Exit;\r\n fInMouseDown := True;\r\n try\r\n for cHandler := fMouseDownChain.Count - 1 downto 0 do\r\n TMouseEvent(fMouseDownChain[cHandler])(Sender, Button, Shift, X, Y);\r\n finally\r\n fInMouseDown := False;\r\n end;\r\nend;\r\n\r\nprocedure TSynEditKbdHandler.ExecuteMouseUp(Sender: TObject; Button: TMouseButton;\r\n Shift: TShiftState; X, Y: Integer);\r\nvar\r\n cHandler: Integer;\r\nbegin\r\n if fInMouseUp then\r\n Exit;\r\n fInMouseUp := True;\r\n try\r\n for cHandler := fMouseUpChain.Count - 1 downto 0 do\r\n TMouseEvent(fMouseUpChain[cHandler])(Sender, Button, Shift, X, Y);\r\n finally\r\n fInMouseUp := False;\r\n end;\r\nend;\r\n\r\nprocedure TSynEditKbdHandler.ExecuteMouseCursor(Sender: TObject;\r\n const aLineCharPos: TBufferCoord; var aCursor: TCursor);\r\nvar\r\n cHandler: Integer;\r\nbegin\r\n if fInMouseCursor then\r\n Exit;\r\n fInMouseCursor := True;\r\n try\r\n for cHandler := fMouseCursorChain.Count - 1 downto 0 do\r\n TMouseCursorEvent(fMouseCursorChain[cHandler])(Sender, aLineCharPos, aCursor);\r\n finally\r\n fInMouseCursor := False;\r\n end;\r\nend;\r\n\r\nprocedure TSynEditKbdHandler.RemoveKeyDownHandler(aHandler: TKeyEvent);\r\nbegin\r\n fKeyDownChain.Remove(TMethod(aHandler));\r\nend;\r\n\r\nprocedure TSynEditKbdHandler.RemoveKeyUpHandler(aHandler: TKeyEvent);\r\nbegin\r\n fKeyUpChain.Remove(TMethod(aHandler));\r\nend;\r\n\r\nprocedure TSynEditKbdHandler.RemoveKeyPressHandler(aHandler: TKeyPressWEvent);\r\nbegin\r\n fKeyPressChain.Remove(TMethod(aHandler));\r\nend;\r\n\r\nprocedure TSynEditKbdHandler.RemoveMouseDownHandler(aHandler: TMouseEvent);\r\nbegin\r\n fMouseDownChain.Remove(TMethod(aHandler));\r\nend;\r\n\r\nprocedure TSynEditKbdHandler.RemoveMouseUpHandler(aHandler: TMouseEvent);\r\nbegin\r\n fMouseUpChain.Remove(TMethod(aHandler));\r\nend;\r\n\r\nprocedure TSynEditKbdHandler.RemoveMouseCursorHandler(aHandler: TMouseCursorEvent);\r\nbegin\r\n fMouseCursorChain.Remove(TMethod(aHandler));\r\nend;\r\n\r\n{ TMethodList }\r\n\r\nprocedure TMethodList.Add(aHandler: TMethod);\r\nbegin\r\n fData.Add(aHandler.Data);\r\n fData.Add(aHandler.Code);\r\nend;\r\n\r\nconstructor TMethodList.Create;\r\nbegin\r\n fData := TList.Create;\r\nend;\r\n\r\ndestructor TMethodList.Destroy;\r\nbegin\r\n fData.Free;\r\nend;\r\n\r\nfunction TMethodList.GetCount: Integer;\r\nbegin\r\n Result := fData.Count div 2;\r\nend;\r\n\r\nfunction TMethodList.GetItem(Index: Integer): TMethod;\r\nbegin\r\n Index := Index * 2;\r\n Result.Data := fData[Index];\r\n Result.Code := fData[Index + 1];\r\nend;\r\n\r\nprocedure TMethodList.Remove(aHandler: TMethod);\r\nvar\r\n cPos: Integer;\r\nbegin\r\n cPos := fData.Count - 2;\r\n while cPos >= 0 do\r\n begin\r\n if (fData.List[cPos] = aHandler.Data) and (fData.List[cPos + 1] = aHandler.Code) then\r\n begin\r\n fData.Delete(cPos);\r\n fData.Delete(cPos);\r\n Exit;\r\n end;\r\n Dec(cPos, 2);\r\n end;\r\nend;\r\n\r\nend.\r\n" }, { "path": "External/SynEdit/Source/SynEditKeyCmdEditor.dfm", "content": "object SynEditKeystrokeEditorForm: TSynEditKeystrokeEditorForm\r\n Left = 424\r\n Top = 306\r\n BorderStyle = bsDialog\r\n Caption = 'Edit Keystroke'\r\n ClientHeight = 129\r\n ClientWidth = 269\r\n Font.Charset = DEFAULT_CHARSET\r\n Font.Color = clWindowText\r\n Font.Height = -11\r\n Font.Name = 'MS Sans Serif'\r\n Font.Style = []\r\n Position = poScreenCenter\r\n OnCreate = FormCreate\r\n OnKeyDown = FormKeyDown\r\n OnShow = FormShow\r\n PixelsPerInch = 96\r\n TextHeight = 13\r\n object pnlAlign: TPanel\r\n Left = 3\r\n Top = 5\r\n Width = 262\r\n Height = 120\r\n BevelInner = bvRaised\r\n BevelOuter = bvLowered\r\n TabOrder = 0\r\n object Label1: TLabel\r\n Left = 9\r\n Top = 14\r\n Width = 50\r\n Height = 13\r\n Caption = 'Command:'\r\n end\r\n object Label2: TLabel\r\n Left = 9\r\n Top = 41\r\n Width = 50\r\n Height = 13\r\n Caption = 'Keystroke:'\r\n end\r\n object Label4: TLabel\r\n Left = 9\r\n Top = 65\r\n Width = 50\r\n Height = 13\r\n Caption = 'Keystroke:'\r\n end\r\n object bntClearKey: TButton\r\n Left = 9\r\n Top = 86\r\n Width = 75\r\n Height = 25\r\n Caption = 'Clear Key'\r\n TabOrder = 3\r\n OnClick = bntClearKeyClick\r\n end\r\n object btnOK: TButton\r\n Left = 93\r\n Top = 86\r\n Width = 75\r\n Height = 25\r\n Caption = 'OK'\r\n TabOrder = 1\r\n OnClick = btnOKClick\r\n end\r\n object cmbCommand: TComboBox\r\n Left = 65\r\n Top = 10\r\n Width = 186\r\n Height = 21\r\n ItemHeight = 13\r\n TabOrder = 0\r\n OnExit = cmbCommandExit\r\n OnKeyPress = cmbCommandKeyPress\r\n end\r\n object btnCancel: TButton\r\n Left = 177\r\n Top = 86\r\n Width = 75\r\n Height = 25\r\n Cancel = True\r\n Caption = 'Cancel'\r\n ModalResult = 2\r\n TabOrder = 2\r\n end\r\n end\r\nend\r\n" }, { "path": "External/SynEdit/Source/SynEditKeyCmdEditor.pas", "content": "{-------------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: SynEditKeyCmdEditor.pas, released 2000-04-07.\r\nThe Original Code is based on the mwKeyCmdEditor.pas file from the\r\nmwEdit component suite by Martin Waldenburg and other developers.\r\nPortions created by Martin Waldenburg are Copyright (C) 1998 Martin Waldenburg.\r\nAll Rights Reserved.\r\n\r\nContributors to the SynEdit and mwEdit projects are listed in the\r\nContributors.txt file.\r\n\r\nAlternatively, the contents of this file may be used under the terms of the\r\nGNU General Public License Version 2 or later (the \"GPL\"), in which case\r\nthe provisions of the GPL are applicable instead of those above.\r\nIf you wish to allow use of your version of this file only under the terms\r\nof the GPL and not to allow others to use your version of this file\r\nunder the MPL, indicate your decision by deleting the provisions above and\r\nreplace them with the notice and other provisions required by the GPL.\r\nIf you do not delete the provisions above, a recipient may use your version\r\nof this file under either the MPL or the GPL.\r\n\r\n$Id: SynEditKeyCmdEditor.pas,v 1.10.2.1 2004/08/31 12:55:17 maelh Exp $\r\n\r\nYou may retrieve the latest version of this file at the SynEdit home page,\r\nlocated at http://SynEdit.SourceForge.net\r\n\r\nKnown Issues:\r\n-------------------------------------------------------------------------------}\r\n\r\n{$IFNDEF QSYNEDITKEYCMDEDITOR}\r\nunit SynEditKeyCmdEditor;\r\n{$ENDIF}\r\n\r\n{$I SynEdit.inc}\r\n\r\ninterface\r\n\r\nuses\r\n{$IFDEF SYN_CLX}\r\n Qt,\r\n QGraphics,\r\n QMenus,\r\n QControls,\r\n QForms,\r\n QDialogs,\r\n QStdCtrls,\r\n QExtCtrls,\r\n QComCtrls,\r\n QSynEditKeyCmds,\r\n QSynEditMiscClasses,\r\n{$ELSE}\r\n Windows,\r\n Messages,\r\n Graphics,\r\n Menus,\r\n Controls,\r\n Forms,\r\n Dialogs,\r\n StdCtrls,\r\n ComCtrls,\r\n ExtCtrls,\r\n SynEditKeyCmds,\r\n SynEditMiscClasses,\r\n{$ENDIF}\r\n SysUtils,\r\n Classes;\r\n\r\n\r\ntype\r\n TSynEditKeystrokeEditorForm = class(TForm)\r\n pnlAlign: TPanel;\r\n Label1: TLabel;\r\n Label2: TLabel;\r\n Label4: TLabel;\r\n bntClearKey: TButton;\r\n btnOK: TButton;\r\n cmbCommand: TComboBox;\r\n btnCancel: TButton;\r\n\r\n procedure FormShow(Sender: TObject);\r\n procedure bntClearKeyClick(Sender: TObject);\r\n procedure cmbCommandKeyPress(Sender: TObject; var Key: Char);\r\n procedure cmbCommandExit(Sender: TObject);\r\n procedure btnOKClick(Sender: TObject);\r\n procedure FormCreate(Sender: TObject);\r\n procedure FormKeyDown(Sender: TObject; var Key: Word;\r\n Shift: TShiftState);\r\n private\r\n FExtended: Boolean;\r\n procedure SetCommand(const Value: TSynEditorCommand);\r\n procedure SetKeystroke(const Value: TShortcut);\r\n procedure AddEditorCommand(const S: string);\r\n function GetCommand: TSynEditorCommand;\r\n function GetKeystroke: TShortcut;\r\n function GetKeystroke2: TShortcut;\r\n procedure SetKeystroke2(const Value: TShortcut);\r\n public\r\n hkKeystroke2: TSynHotKey;\r\n hkKeystroke: TSynHotKey;\r\n property Command: TSynEditorCommand read GetCommand write SetCommand;\r\n property Keystroke: TShortcut read GetKeystroke write SetKeystroke;\r\n property Keystroke2: TShortcut read GetKeystroke2 write SetKeystroke2;\r\n property ExtendedString: Boolean read FExtended write FExtended default True;\r\n end;\r\n\r\nvar\r\n SynEditKeystrokeEditorForm: TSynEditKeystrokeEditorForm;\r\n\r\nimplementation\r\n\r\n{$R *.dfm}\r\n\r\n{ TSynEditKeystrokeEditorForm }\r\n\r\nprocedure TSynEditKeystrokeEditorForm.SetCommand(const Value: TSynEditorCommand);\r\nbegin\r\n if FExtended then\r\n cmbCommand.Text := ConvertCodeStringToExtended(EditorCommandToCodeString(Value))\r\n else cmbCommand.Text := EditorCommandToCodeString(Value);\r\nend;\r\n\r\nprocedure TSynEditKeystrokeEditorForm.SetKeystroke(const Value: TShortcut);\r\nbegin\r\n hkKeystroke.Hotkey := Value;\r\nend;\r\n\r\nprocedure TSynEditKeystrokeEditorForm.FormShow(Sender: TObject);\r\nVar i : Integer;\r\nbegin\r\n if FExtended then\r\n GetEditorCommandExtended(AddEditorCommand)\r\n else GetEditorCommandValues(AddEditorCommand);\r\n\r\n //Now add the values for quick access\r\n for i := 0 to cmbCommand.Items.Count - 1 do\r\n cmbCommand.Items.Objects[i] := TObject(IndexToEditorCommand(i));\r\n if FExtended then\r\n cmbCommand.Sorted := True;\r\nend;\r\n\r\nprocedure TSynEditKeystrokeEditorForm.AddEditorCommand(const S: string);\r\nbegin\r\n cmbCommand.Items.Add(S);\r\nend;\r\n\r\nfunction TSynEditKeystrokeEditorForm.GetCommand: TSynEditorCommand;\r\nvar\r\n NewCmd: longint;\r\nbegin\r\n cmbCommand.ItemIndex := cmbCommand.Items.IndexOf(cmbCommand.Text);\r\n if cmbCommand.ItemIndex <> -1 then\r\n begin\r\n NewCmd := TSynEditorCommand(Integer(cmbCommand.Items.Objects[cmbCommand.ItemIndex]));\r\n end else if not IdentToEditorCommand(cmbCommand.Text, NewCmd) then\r\n begin\r\n try\r\n NewCmd := StrToInt(cmbCommand.Text);\r\n except\r\n NewCmd := ecNone;\r\n end;\r\n end;\r\n Result := NewCmd;\r\nend;\r\n\r\nfunction TSynEditKeystrokeEditorForm.GetKeystroke: TShortcut;\r\nbegin\r\n Result := hkKeystroke.HotKey;\r\nend;\r\n\r\nprocedure TSynEditKeystrokeEditorForm.bntClearKeyClick(Sender: TObject);\r\nbegin\r\n hkKeystroke.HotKey := 0;\r\n hkKeystroke2.HotKey := 0;\r\nend;\r\n\r\nfunction TSynEditKeystrokeEditorForm.GetKeystroke2: TShortcut;\r\nbegin\r\n Result := hkKeystroke2.HotKey;\r\nend;\r\n\r\nprocedure TSynEditKeystrokeEditorForm.SetKeystroke2(const Value: TShortcut);\r\nbegin\r\n hkKeystroke2.Hotkey := Value;\r\nend;\r\n\r\nprocedure TSynEditKeystrokeEditorForm.cmbCommandKeyPress(Sender: TObject;\r\n var Key: Char);\r\nvar WorkStr : String;\r\n i : Integer;\r\nbegin\r\n//This would be better if componentized, but oh well...\r\n WorkStr := AnsiUppercase(Copy(cmbCommand.Text, 1, cmbCommand.SelStart) + Key);\r\n i := 0;\r\n While i < cmbCommand.Items.Count do\r\n begin\r\n if pos(WorkStr, AnsiUppercase(cmbCommand.Items[i])) = 1 then\r\n begin\r\n cmbCommand.Text := cmbCommand.Items[i];\r\n cmbCommand.SelStart := length(WorkStr);\r\n cmbCommand.SelLength := Length(cmbCommand.Text) - cmbCommand.SelStart;\r\n Key := #0;\r\n break;\r\n end else inc(i);\r\n end;\r\nend;\r\n\r\nprocedure TSynEditKeystrokeEditorForm.cmbCommandExit(Sender: TObject);\r\nVAR TmpIndex : Integer;\r\nbegin\r\n TmpIndex := cmbCommand.Items.IndexOf(cmbCommand.Text);\r\n if TmpIndex = -1 then\r\n begin\r\n cmbCommand.ItemIndex := cmbCommand.Items.IndexOf(ConvertCodeStringToExtended('ecNone'));\r\n end else cmbCommand.ItemIndex := TmpIndex; //need to force it incase they just typed something in\r\nend;\r\n\r\nprocedure TSynEditKeystrokeEditorForm.btnOKClick(Sender: TObject);\r\nbegin\r\n if Command = ecNone then\r\n begin\r\n MessageDlg('You must first select a command.', mtError, [mbOK], 0);\r\n cmbCommand.SetFocus;\r\n cmbCommand.SelectAll;\r\n end else if Keystroke = 0 then\r\n begin\r\n MessageDlg('The command \"'+cmbCommand.Text+'\" needs to have at least one keystroke assigned to it.', mtError, [mbOK], 0);\r\n hkKeystroke.SetFocus;\r\n end else ModalResult := mrOK;\r\nend;\r\n\r\nprocedure TSynEditKeystrokeEditorForm.FormCreate(Sender: TObject);\r\nbegin \r\n hkKeystroke := TSynHotKey.Create(self);\r\n with hkKeystroke do\r\n begin\r\n Parent := pnlAlign;\r\n Left := 65;\r\n Top := 38;\r\n Width := 186;\r\n Height := 19;\r\n HotKey := 0;\r\n InvalidKeys := [];\r\n Modifiers := [];\r\n TabOrder := 1;\r\n end;\r\n\r\n hkKeystroke2 := TSynHotKey.Create(self);\r\n with hkKeystroke2 do\r\n begin\r\n Parent := pnlAlign;\r\n Left := 65;\r\n Top := 62;\r\n Width := 186;\r\n Height := 19;\r\n HotKey := 0;\r\n InvalidKeys := [];\r\n Modifiers := [];\r\n TabOrder := 2;\r\n end;\r\nend;\r\n\r\nprocedure TSynEditKeystrokeEditorForm.FormKeyDown(Sender: TObject;\r\n var Key: Word; Shift: TShiftState);\r\nbegin\r\n // if this event is not present CLX will complain\r\nend;\r\n\r\nend.\r\n\r\n\r\n\r\n" }, { "path": "External/SynEdit/Source/SynEditKeyCmds.pas", "content": "{-------------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: SynEditKeyCmds.pas, released 2000-04-07.\r\nThe Original Code is based on the mwKeyCmds.pas file from the\r\nmwEdit component suite by Martin Waldenburg and other developers, the Initial\r\nAuthor of this file is Brad Stowers.\r\nAll Rights Reserved.\r\n\r\nContributors to the SynEdit and mwEdit projects are listed in the\r\nContributors.txt file.\r\n\r\nAlternatively, the contents of this file may be used under the terms of the\r\nGNU General Public License Version 2 or later (the \"GPL\"), in which case\r\nthe provisions of the GPL are applicable instead of those above.\r\nIf you wish to allow use of your version of this file only under the terms\r\nof the GPL and not to allow others to use your version of this file\r\nunder the MPL, indicate your decision by deleting the provisions above and\r\nreplace them with the notice and other provisions required by the GPL.\r\nIf you do not delete the provisions above, a recipient may use your version\r\nof this file under either the MPL or the GPL.\r\n\r\n$Id: SynEditKeyCmds.pas,v 1.23.2.4 2008/09/14 16:24:58 maelh Exp $\r\n\r\nYou may retrieve the latest version of this file at the SynEdit home page,\r\nlocated at http://SynEdit.SourceForge.net\r\n\r\nKnown Issues:\r\n-------------------------------------------------------------------------------}\r\n// TODO: introduce friendly Names for the Commands (EditorCommandStrs is not good enough for end-users)\r\n\r\n{$IFNDEF QSYNEDITKEYCMDS}\r\nunit SynEditKeyCmds;\r\n{$ENDIF}\r\n\r\n{$I SynEdit.inc}\r\n\r\ninterface\r\n\r\nuses\r\n{$IFDEF SYN_CLX}\r\n QMenus,\r\n QSynUnicode,\r\n{$ELSE}\r\n Menus,\r\n SynUnicode,\r\n{$ENDIF}\r\n Classes,\r\n SysUtils;\r\n\r\nconst\r\n //****************************************************************************\r\n // NOTE! If you add an editor command, you must also update the\r\n // EditorCommandStrs constant array in implementation section below, or the\r\n // command will not show up in the IDE.\r\n //****************************************************************************\r\n\r\n // \"Editor Commands\". Key strokes are translated from a table into these\r\n // I used constants instead of a set so that additional commands could be\r\n // added in descendants (you can't extend a set)\r\n\r\n // There are two ranges of editor commands: the ecViewXXX commands are always\r\n // valid, while the ecEditXXX commands are ignored when the editor is in\r\n // read-only mode\r\n\r\n ecNone = 0; // Nothing. Useful for user event to handle command\r\n ecViewCommandFirst = 0;\r\n ecViewCommandLast = 500;\r\n ecEditCommandFirst = 501;\r\n ecEditCommandLast = 1000;\r\n\r\n ecLeft = 1; // Move cursor left one char\r\n ecRight = 2; // Move cursor right one char\r\n ecUp = 3; // Move cursor up one line\r\n ecDown = 4; // Move cursor down one line\r\n ecWordLeft = 5; // Move cursor left one word\r\n ecWordRight = 6; // Move cursor right one word\r\n ecLineStart = 7; // Move cursor to beginning of line\r\n ecLineEnd = 8; // Move cursor to end of line\r\n ecPageUp = 9; // Move cursor up one page\r\n ecPageDown = 10; // Move cursor down one page\r\n ecPageLeft = 11; // Move cursor right one page\r\n ecPageRight = 12; // Move cursor left one page\r\n ecPageTop = 13; // Move cursor to top of page\r\n ecPageBottom = 14; // Move cursor to bottom of page\r\n ecEditorTop = 15; // Move cursor to absolute beginning\r\n ecEditorBottom = 16; // Move cursor to absolute end\r\n ecGotoXY = 17; // Move cursor to specific coordinates, Data = PPoint\r\n\r\n//******************************************************************************\r\n// Maybe the command processor should just take a boolean that signifies if\r\n// selection is affected or not?\r\n//******************************************************************************\r\n\r\n ecSelection = 100; // Add this to ecXXX command to get equivalent\r\n // command, but with selection enabled. This is not\r\n // a command itself.\r\n // Same as commands above, except they affect selection, too\r\n ecSelLeft = ecLeft + ecSelection;\r\n ecSelRight = ecRight + ecSelection;\r\n ecSelUp = ecUp + ecSelection;\r\n ecSelDown = ecDown + ecSelection;\r\n ecSelWordLeft = ecWordLeft + ecSelection;\r\n ecSelWordRight = ecWordRight + ecSelection;\r\n ecSelLineStart = ecLineStart + ecSelection;\r\n ecSelLineEnd = ecLineEnd + ecSelection;\r\n ecSelPageUp = ecPageUp + ecSelection;\r\n ecSelPageDown = ecPageDown + ecSelection;\r\n ecSelPageLeft = ecPageLeft + ecSelection;\r\n ecSelPageRight = ecPageRight + ecSelection;\r\n ecSelPageTop = ecPageTop + ecSelection;\r\n ecSelPageBottom = ecPageBottom + ecSelection;\r\n ecSelEditorTop = ecEditorTop + ecSelection;\r\n ecSelEditorBottom = ecEditorBottom + ecSelection;\r\n ecSelGotoXY = ecGotoXY + ecSelection; // Data = PPoint\r\n\r\n ecSelWord = 198;\r\n ecSelectAll = 199; // Select entire contents of editor, cursor to end\r\n\r\n ecCopy = 201; // Copy selection to clipboard\r\n\r\n ecScrollUp = 211; // Scroll up one line leaving cursor position unchanged.\r\n ecScrollDown = 212; // Scroll down one line leaving cursor position unchanged.\r\n ecScrollLeft = 213; // Scroll left one char leaving cursor position unchanged.\r\n ecScrollRight = 214; // Scroll right one char leaving cursor position unchanged.\r\n\r\n ecInsertMode = 221; // Set insert mode\r\n ecOverwriteMode = 222; // Set overwrite mode\r\n ecToggleMode = 223; // Toggle ins/ovr mode\r\n\r\n ecNormalSelect = 231; // Normal selection mode\r\n ecColumnSelect = 232; // Column selection mode\r\n ecLineSelect = 233; // Line selection mode\r\n\r\n ecMatchBracket = 250; // Go to matching bracket\r\n ecCommentBlock = 251; // Comment Block\r\n\r\n ecGotoMarker0 = 301; // Goto marker\r\n ecGotoMarker1 = 302; // Goto marker\r\n ecGotoMarker2 = 303; // Goto marker\r\n ecGotoMarker3 = 304; // Goto marker\r\n ecGotoMarker4 = 305; // Goto marker\r\n ecGotoMarker5 = 306; // Goto marker\r\n ecGotoMarker6 = 307; // Goto marker\r\n ecGotoMarker7 = 308; // Goto marker\r\n ecGotoMarker8 = 309; // Goto marker\r\n ecGotoMarker9 = 310; // Goto marker\r\n ecSetMarker0 = 351; // Set marker, Data = PPoint - X, Y Pos\r\n ecSetMarker1 = 352; // Set marker, Data = PPoint - X, Y Pos\r\n ecSetMarker2 = 353; // Set marker, Data = PPoint - X, Y Pos\r\n ecSetMarker3 = 354; // Set marker, Data = PPoint - X, Y Pos\r\n ecSetMarker4 = 355; // Set marker, Data = PPoint - X, Y Pos\r\n ecSetMarker5 = 356; // Set marker, Data = PPoint - X, Y Pos\r\n ecSetMarker6 = 357; // Set marker, Data = PPoint - X, Y Pos\r\n ecSetMarker7 = 358; // Set marker, Data = PPoint - X, Y Pos\r\n ecSetMarker8 = 359; // Set marker, Data = PPoint - X, Y Pos\r\n ecSetMarker9 = 360; // Set marker, Data = PPoint - X, Y Pos\r\n\r\n ecGotFocus = 480;\r\n ecLostFocus = 481;\r\n\r\n ecContextHelp = 490; // Help on Word, Data = Word\r\n\r\n ecDeleteLastChar = 501; // Delete last char (i.e. backspace key)\r\n ecDeleteChar = 502; // Delete char at cursor (i.e. delete key)\r\n ecDeleteWord = 503; // Delete from cursor to end of word\r\n ecDeleteLastWord = 504; // Delete from cursor to start of word\r\n ecDeleteBOL = 505; // Delete from cursor to beginning of line\r\n ecDeleteEOL = 506; // Delete from cursor to end of line\r\n ecDeleteLine = 507; // Delete current line\r\n ecClearAll = 508; // Delete everything\r\n ecLineBreak = 509; // Break line at current position, move caret to new line\r\n ecInsertLine = 510; // Break line at current position, leave caret\r\n ecChar = 511; // Insert a character at current position\r\n\r\n ecImeStr = 550; // Insert character(s) from IME\r\n\r\n ecUndo = 601; // Perform undo if available\r\n ecRedo = 602; // Perform redo if available\r\n ecCut = 603; // Cut selection to clipboard\r\n ecPaste = 604; // Paste clipboard to current position\r\n\r\n ecBlockIndent = 610; // Indent selection\r\n ecBlockUnindent = 611; // Unindent selection\r\n ecTab = 612; // Tab key\r\n ecShiftTab = 613; // Shift+Tab key\r\n\r\n ecAutoCompletion = 650;\r\n\r\n ecUpperCase = 620; // apply to the current or previous word\r\n ecLowerCase = 621;\r\n ecToggleCase = 622;\r\n ecTitleCase = 623;\r\n ecUpperCaseBlock = 625; // apply to current selection, or current char if no selection\r\n ecLowerCaseBlock = 626;\r\n ecToggleCaseBlock = 627;\r\n\r\n ecString = 630; //Insert a whole string\r\n\r\n ecUserFirst = 1001; // Start of user-defined commands\r\n\r\ntype\r\n ESynKeyError = class(Exception);\r\n\r\n TSynEditorCommand = type word;\r\n\r\n TSynEditKeyStroke = class(TCollectionItem)\r\n private\r\n FKey: word; // Virtual keycode, i.e. VK_xxx\r\n FShift: TShiftState;\r\n FKey2: word;\r\n FShift2: TShiftState;\r\n FCommand: TSynEditorCommand;\r\n function GetShortCut: TShortCut;\r\n function GetShortCut2: TShortCut;\r\n procedure SetCommand(const Value: TSynEditorCommand);\r\n procedure SetKey(const Value: word);\r\n procedure SetKey2(const Value: word);\r\n procedure SetShift(const Value: TShiftState);\r\n procedure SetShift2(const Value: TShiftState);\r\n procedure SetShortCut(const Value: TShortCut);\r\n procedure SetShortCut2(const Value: TShortCut);\r\n protected\r\n{$IFDEF SYN_COMPILER_3_UP}\r\n function GetDisplayName: string; override;\r\n{$ENDIF}\r\n public\r\n procedure Assign(Source: TPersistent); override;\r\n procedure LoadFromStream(AStream: TStream);\r\n procedure SaveToStream(AStream: TStream);\r\n // No duplicate checking is done if assignment made via these properties!\r\n property Key: word read FKey write SetKey;\r\n property Key2: word read FKey2 write SetKey2;\r\n property Shift: TShiftState read FShift write SetShift;\r\n property Shift2: TShiftState read FShift2 write SetShift2;\r\n published\r\n property Command: TSynEditorCommand read FCommand write SetCommand;\r\n property ShortCut: TShortCut read GetShortCut write SetShortCut\r\n default 0;\r\n property ShortCut2: TShortCut read GetShortCut2 write SetShortCut2\r\n default 0;\r\n end;\r\n\r\n TSynEditKeyStrokes = class(TCollection)\r\n private\r\n FOwner: TPersistent;\r\n function GetItem(Index: Integer): TSynEditKeyStroke;\r\n procedure SetItem(Index: Integer; Value: TSynEditKeyStroke);\r\n protected\r\n{$IFDEF SYN_COMPILER_3_UP}\r\n function GetOwner: TPersistent; override;\r\n{$ENDIF}\r\n public\r\n constructor Create(AOwner: TPersistent);\r\n function Add: TSynEditKeyStroke;\r\n procedure AddKey(const ACmd: TSynEditorCommand; const AKey: word;\r\n const AShift: TShiftState);\r\n procedure Assign(Source: TPersistent); override;\r\n function FindCommand(Cmd: TSynEditorCommand): integer;\r\n function FindKeycode(Code: word; SS: TShiftState): integer;\r\n function FindKeycode2(Code1: word; SS1: TShiftState;\r\n Code2: word; SS2: TShiftState): integer;\r\n function FindShortcut(SC: TShortcut): integer;\r\n function FindShortcut2(SC, SC2: TShortcut): integer;\r\n procedure LoadFromStream(AStream: TStream);\r\n procedure ResetDefaults;\r\n procedure SaveToStream(AStream: TStream);\r\n public\r\n property Items[Index: Integer]: TSynEditKeyStroke read GetItem\r\n write SetItem; default;\r\n end;\r\n\r\n// These are mainly for the TSynEditorCommand property editor, but could be\r\n// useful elsewhere.\r\nfunction EditorCommandToDescrString(Cmd: TSynEditorCommand): string;\r\nfunction EditorCommandToCodeString(Cmd: TSynEditorCommand): string;\r\nprocedure GetEditorCommandValues(Proc: TGetStrProc);\r\nprocedure GetEditorCommandExtended(Proc: TGetStrProc);\r\nfunction IdentToEditorCommand(const Ident: string; var Cmd: longint): Boolean;\r\nfunction EditorCommandToIdent(Cmd: longint; var Ident: string): Boolean;\r\nfunction ConvertCodeStringToExtended(AString: string): string;\r\nfunction ConvertExtendedToCodeString(AString: string): string;\r\nfunction ConvertExtendedToCommand(AString: string): TSynEditorCommand;\r\nfunction ConvertCodeStringToCommand(AString: string): TSynEditorCommand;\r\nfunction IndexToEditorCommand(const AIndex: Integer): Integer;\r\n\r\nimplementation\r\n\r\nuses\r\n{$IFDEF SYN_CLX}\r\n kTextDrawer,\r\n Types,\r\n Qt,\r\n QSynEditKeyConst,\r\n QSynEditStrConst;\r\n{$ELSE}\r\n Windows,\r\n SynEditKeyConst,\r\n SynEditStrConst;\r\n{$ENDIF}\r\n\r\n{ Command mapping routines }\r\n\r\n{$IFDEF SYN_COMPILER_2}\r\n// This is defined in D3/C3 and up.\r\ntype\r\n TIdentMapEntry = record\r\n Value: TSynEditorCommand;\r\n Name: string;\r\n end;\r\n{$ENDIF}\r\n\r\nconst\r\n EditorCommandStrs: array[0..100] of TIdentMapEntry = (\r\n (Value: ecNone; Name: 'ecNone'),\r\n (Value: ecLeft; Name: 'ecLeft'),\r\n (Value: ecRight; Name: 'ecRight'),\r\n (Value: ecUp; Name: 'ecUp'),\r\n (Value: ecDown; Name: 'ecDown'),\r\n (Value: ecWordLeft; Name: 'ecWordLeft'),\r\n (Value: ecWordRight; Name: 'ecWordRight'),\r\n (Value: ecLineStart; Name: 'ecLineStart'),\r\n (Value: ecLineEnd; Name: 'ecLineEnd'),\r\n (Value: ecPageUp; Name: 'ecPageUp'),\r\n (Value: ecPageDown; Name: 'ecPageDown'),\r\n (Value: ecPageLeft; Name: 'ecPageLeft'),\r\n (Value: ecPageRight; Name: 'ecPageRight'),\r\n (Value: ecPageTop; Name: 'ecPageTop'),\r\n (Value: ecPageBottom; Name: 'ecPageBottom'),\r\n (Value: ecEditorTop; Name: 'ecEditorTop'),\r\n (Value: ecEditorBottom; Name: 'ecEditorBottom'),\r\n (Value: ecGotoXY; Name: 'ecGotoXY'),\r\n (Value: ecSelLeft; Name: 'ecSelLeft'),\r\n (Value: ecSelRight; Name: 'ecSelRight'),\r\n (Value: ecSelUp; Name: 'ecSelUp'),\r\n (Value: ecSelDown; Name: 'ecSelDown'),\r\n (Value: ecSelWordLeft; Name: 'ecSelWordLeft'),\r\n (Value: ecSelWordRight; Name: 'ecSelWordRight'),\r\n (Value: ecSelLineStart; Name: 'ecSelLineStart'),\r\n (Value: ecSelLineEnd; Name: 'ecSelLineEnd'),\r\n (Value: ecSelPageUp; Name: 'ecSelPageUp'),\r\n (Value: ecSelPageDown; Name: 'ecSelPageDown'),\r\n (Value: ecSelPageLeft; Name: 'ecSelPageLeft'),\r\n (Value: ecSelPageRight; Name: 'ecSelPageRight'),\r\n (Value: ecSelPageTop; Name: 'ecSelPageTop'),\r\n (Value: ecSelPageBottom; Name: 'ecSelPageBottom'),\r\n (Value: ecSelEditorTop; Name: 'ecSelEditorTop'),\r\n (Value: ecSelEditorBottom; Name: 'ecSelEditorBottom'),\r\n (Value: ecSelGotoXY; Name: 'ecSelGotoXY'),\r\n (Value: ecSelWord; Name: 'ecSelWord'),\r\n (Value: ecSelectAll; Name: 'ecSelectAll'),\r\n (Value: ecDeleteLastChar; Name: 'ecDeleteLastChar'),\r\n (Value: ecDeleteChar; Name: 'ecDeleteChar'),\r\n (Value: ecDeleteWord; Name: 'ecDeleteWord'),\r\n (Value: ecDeleteLastWord; Name: 'ecDeleteLastWord'),\r\n (Value: ecDeleteBOL; Name: 'ecDeleteBOL'),\r\n (Value: ecDeleteEOL; Name: 'ecDeleteEOL'),\r\n (Value: ecDeleteLine; Name: 'ecDeleteLine'),\r\n (Value: ecClearAll; Name: 'ecClearAll'),\r\n (Value: ecLineBreak; Name: 'ecLineBreak'),\r\n (Value: ecInsertLine; Name: 'ecInsertLine'),\r\n (Value: ecChar; Name: 'ecChar'),\r\n (Value: ecImeStr; Name: 'ecImeStr'),\r\n (Value: ecUndo; Name: 'ecUndo'),\r\n (Value: ecRedo; Name: 'ecRedo'),\r\n (Value: ecCut; Name: 'ecCut'),\r\n (Value: ecCopy; Name: 'ecCopy'),\r\n (Value: ecPaste; Name: 'ecPaste'),\r\n (Value: ecScrollUp; Name: 'ecScrollUp'),\r\n (Value: ecScrollDown; Name: 'ecScrollDown'),\r\n (Value: ecScrollLeft; Name: 'ecScrollLeft'),\r\n (Value: ecScrollRight; Name: 'ecScrollRight'),\r\n (Value: ecInsertMode; Name: 'ecInsertMode'),\r\n (Value: ecOverwriteMode; Name: 'ecOverwriteMode'),\r\n (Value: ecToggleMode; Name: 'ecToggleMode'),\r\n (Value: ecBlockIndent; Name: 'ecBlockIndent'),\r\n (Value: ecBlockUnindent; Name: 'ecBlockUnindent'),\r\n (Value: ecTab; Name: 'ecTab'),\r\n (Value: ecShiftTab; Name: 'ecShiftTab'),\r\n (Value: ecMatchBracket; Name: 'ecMatchBracket'),\r\n (Value: ecCommentBlock; Name: 'ecCommentBlock'),\r\n (Value: ecNormalSelect; Name: 'ecNormalSelect'),\r\n (Value: ecColumnSelect; Name: 'ecColumnSelect'),\r\n (Value: ecLineSelect; Name: 'ecLineSelect'),\r\n (Value: ecAutoCompletion; Name: 'ecAutoCompletion'),\r\n (Value: ecUserFirst; Name: 'ecUserFirst'),\r\n (Value: ecContextHelp; Name: 'ecContextHelp'),\r\n (Value: ecGotoMarker0; Name: 'ecGotoMarker0'),\r\n (Value: ecGotoMarker1; Name: 'ecGotoMarker1'),\r\n (Value: ecGotoMarker2; Name: 'ecGotoMarker2'),\r\n (Value: ecGotoMarker3; Name: 'ecGotoMarker3'),\r\n (Value: ecGotoMarker4; Name: 'ecGotoMarker4'),\r\n (Value: ecGotoMarker5; Name: 'ecGotoMarker5'),\r\n (Value: ecGotoMarker6; Name: 'ecGotoMarker6'),\r\n (Value: ecGotoMarker7; Name: 'ecGotoMarker7'),\r\n (Value: ecGotoMarker8; Name: 'ecGotoMarker8'),\r\n (Value: ecGotoMarker9; Name: 'ecGotoMarker9'),\r\n (Value: ecSetMarker0; Name: 'ecSetMarker0'),\r\n (Value: ecSetMarker1; Name: 'ecSetMarker1'),\r\n (Value: ecSetMarker2; Name: 'ecSetMarker2'),\r\n (Value: ecSetMarker3; Name: 'ecSetMarker3'),\r\n (Value: ecSetMarker4; Name: 'ecSetMarker4'),\r\n (Value: ecSetMarker5; Name: 'ecSetMarker5'),\r\n (Value: ecSetMarker6; Name: 'ecSetMarker6'),\r\n (Value: ecSetMarker7; Name: 'ecSetMarker7'),\r\n (Value: ecSetMarker8; Name: 'ecSetMarker8'),\r\n (Value: ecSetMarker9; Name: 'ecSetMarker9'),\r\n (Value: ecUpperCase; Name: 'ecUpperCase'),\r\n (Value: ecLowerCase; Name: 'ecLowerCase'),\r\n (Value: ecToggleCase; Name: 'ecToggleCase'),\r\n (Value: ecTitleCase; Name: 'ecTitleCase'),\r\n (Value: ecUpperCaseBlock; Name: 'ecUpperCaseBlock'),\r\n (Value: ecLowerCaseBlock; Name: 'ecLowerCaseBlock'),\r\n (Value: ecToggleCaseBlock; Name: 'ecToggleCaseBlock'),\r\n (Value: ecString; Name:'ecString'));\r\n\r\nprocedure GetEditorCommandValues(Proc: TGetStrProc);\r\nvar\r\n i: integer;\r\nbegin\r\n for i := Low(EditorCommandStrs) to High(EditorCommandStrs) do\r\n Proc(EditorCommandStrs[I].Name);\r\nend;\r\n\r\nprocedure GetEditorCommandExtended(Proc: TGetStrProc);\r\nvar\r\n i: integer;\r\nbegin\r\n for i := Low(EditorCommandStrs) to High(EditorCommandStrs) do\r\n Proc(ConvertCodeStringToExtended(EditorCommandStrs[I].Name));\r\nend;\r\n\r\nfunction IdentToEditorCommand(const Ident: string; var Cmd: longint): boolean;\r\n{$IFDEF SYN_COMPILER_2}\r\nvar\r\n I: Integer;\r\n{$ENDIF}\r\nbegin\r\n{$IFDEF SYN_COMPILER_2}\r\n Result := FALSE;\r\n for I := Low(EditorCommandStrs) to High(EditorCommandStrs) do\r\n if CompareText(EditorCommandStrs[I].Name, Ident) = 0 then\r\n begin\r\n Result := TRUE;\r\n Cmd := EditorCommandStrs[I].Value;\r\n break;\r\n end;\r\n{$ELSE}\r\n Result := IdentToInt(Ident, Cmd, EditorCommandStrs);\r\n{$ENDIF}\r\nend;\r\n\r\nfunction EditorCommandToIdent(Cmd: longint; var Ident: string): boolean;\r\n{$IFDEF SYN_COMPILER_2}\r\nvar\r\n I: Integer;\r\n{$ENDIF}\r\nbegin\r\n{$IFDEF SYN_COMPILER_2}\r\n Result := FALSE;\r\n for I := Low(EditorCommandStrs) to High(EditorCommandStrs) do\r\n if EditorCommandStrs[I].Value = Cmd then\r\n begin\r\n Result := TRUE;\r\n Ident := EditorCommandStrs[I].Name;\r\n break;\r\n end;\r\n{$ELSE}\r\n Result := IntToIdent(Cmd, Ident, EditorCommandStrs);\r\n{$ENDIF}\r\nend;\r\n\r\nfunction EditorCommandToDescrString(Cmd: TSynEditorCommand): string;\r\nbegin\r\n // Doesn't do anything yet.\r\n Result := '';\r\nend;\r\n\r\nfunction EditorCommandToCodeString(Cmd: TSynEditorCommand): string;\r\nbegin\r\n if not EditorCommandToIdent(Cmd, Result) then\r\n Result := IntToStr(Cmd);\r\nend;\r\n\r\n{ TSynEditKeyStroke }\r\n\r\nprocedure TSynEditKeyStroke.Assign(Source: TPersistent);\r\nbegin\r\n if Source is TSynEditKeyStroke then\r\n begin\r\n Command := TSynEditKeyStroke(Source).Command;\r\n Key := TSynEditKeyStroke(Source).Key;\r\n Key2 := TSynEditKeyStroke(Source).Key2;\r\n Shift := TSynEditKeyStroke(Source).Shift;\r\n Shift2 := TSynEditKeyStroke(Source).Shift2;\r\n end else\r\n inherited Assign(Source);\r\nend;\r\n\r\n{$IFDEF SYN_COMPILER_3_UP}\r\nfunction TSynEditKeyStroke.GetDisplayName: string;\r\nbegin\r\n Result := EditorCommandToCodeString(Command) + ' - ' + ShortCutToText(ShortCut);\r\n if ShortCut <> 0 then\r\n Result := Result + ' ' + ShortCutToText(ShortCut2);\r\n if Result = '' then\r\n Result := inherited GetDisplayName;\r\nend;\r\n{$ENDIF}\r\n\r\nfunction TSynEditKeyStroke.GetShortCut: TShortCut;\r\nbegin\r\n{$IFDEF SYN_CLX}\r\n Result := QMenus.ShortCut(Key, Shift);\r\n{$ELSE}\r\n Result := Menus.ShortCut(Key, Shift);\r\n{$ENDIF}\r\nend;\r\n\r\nprocedure TSynEditKeyStroke.SetCommand(const Value: TSynEditorCommand);\r\nbegin\r\n if Value <> FCommand then\r\n FCommand := Value;\r\nend;\r\n\r\nprocedure TSynEditKeyStroke.SetKey(const Value: word);\r\nbegin\r\n if Value <> FKey then\r\n FKey := Value;\r\nend;\r\n\r\nprocedure TSynEditKeyStroke.SetShift(const Value: TShiftState);\r\nbegin\r\n if Value <> FShift then\r\n FShift := Value;\r\nend;\r\n\r\nprocedure TSynEditKeyStroke.SetShortCut(const Value: TShortCut);\r\nvar\r\n NewKey: Word;\r\n NewShift: TShiftState;\r\n Dup: integer;\r\nbegin\r\n // Duplicate values of no shortcut are OK.\r\n if Value <> 0 then\r\n begin\r\n // Check for duplicate shortcut in the collection and disallow if there is.\r\n Dup := TSynEditKeyStrokes(Collection).FindShortcut2(Value, ShortCut2);\r\n if (Dup <> -1) and (Dup <> Self.Index) then\r\n begin\r\n raise ESynKeyError.Create(SYNS_EDuplicateShortCut);\r\n end;\r\n end;\r\n\r\n{$IFDEF SYN_CLX}\r\n QMenus.ShortCutToKey(Value, NewKey, NewShift);\r\n{$ELSE}\r\n Menus.ShortCutToKey(Value, NewKey, NewShift);\r\n{$ENDIF}\r\n\r\n if (NewKey <> Key) or (NewShift <> Shift) then\r\n begin\r\n Key := NewKey;\r\n Shift := NewShift;\r\n end;\r\nend;\r\n\r\nprocedure TSynEditKeyStroke.SetKey2(const Value: word);\r\nbegin\r\n if Value <> FKey2 then\r\n FKey2 := Value;\r\nend;\r\n\r\nprocedure TSynEditKeyStroke.SetShift2(const Value: TShiftState);\r\nbegin\r\n if Value <> FShift2 then\r\n FShift2 := Value;\r\nend;\r\n\r\nprocedure TSynEditKeyStroke.SetShortCut2(const Value: TShortCut);\r\nvar\r\n NewKey: Word;\r\n NewShift: TShiftState;\r\n Dup: integer;\r\nbegin\r\n // Duplicate values of no shortcut are OK.\r\n if Value <> 0 then\r\n begin\r\n // Check for duplicate shortcut in the collection and disallow if there is.\r\n Dup := TSynEditKeyStrokes(Collection).FindShortcut2(ShortCut, Value);\r\n if (Dup <> -1) and (Dup <> Self.Index) then\r\n raise ESynKeyError.Create(SYNS_EDuplicateShortCut);\r\n end;\r\n\r\n{$IFDEF SYN_CLX}\r\n QMenus.ShortCutToKey(Value, NewKey, NewShift);\r\n{$ELSE}\r\n Menus.ShortCutToKey(Value, NewKey, NewShift);\r\n{$ENDIF}\r\n if (NewKey <> Key2) or (NewShift <> Shift2) then\r\n begin\r\n Key2 := NewKey;\r\n Shift2 := NewShift;\r\n end;\r\nend;\r\n\r\nfunction TSynEditKeyStroke.GetShortCut2: TShortCut;\r\nbegin\r\n{$IFDEF SYN_CLX}\r\n Result := QMenus.ShortCut(Key2, Shift2);\r\n{$ELSE}\r\n Result := Menus.ShortCut(Key2, Shift2);\r\n{$ENDIF}\r\nend;\r\n\r\nprocedure TSynEditKeyStroke.LoadFromStream(AStream: TStream);\r\nbegin\r\n with AStream do begin\r\n Read(fKey, SizeOf(fKey));\r\n Read(fShift, SizeOf(fShift));\r\n Read(fKey2, SizeOf(fKey2));\r\n Read(fShift2, SizeOf(fShift2));\r\n Read(fCommand, SizeOf(fCommand));\r\n end;\r\nend;\r\n\r\nprocedure TSynEditKeyStroke.SaveToStream(AStream: TStream);\r\nbegin\r\n with AStream do begin\r\n Write(fKey, SizeOf(fKey));\r\n Write(fShift, SizeOf(fShift));\r\n Write(fKey2, SizeOf(fKey2));\r\n Write(fShift2, SizeOf(fShift2));\r\n Write(fCommand, SizeOf(fCommand));\r\n end;\r\nend;\r\n\r\n\r\n{ TSynEditKeyStrokes }\r\n\r\nfunction TSynEditKeyStrokes.Add: TSynEditKeyStroke;\r\nbegin\r\n Result := TSynEditKeyStroke(inherited Add);\r\nend;\r\n\r\nprocedure TSynEditKeyStrokes.AddKey(const ACmd: TSynEditorCommand; const AKey: word;\r\n const AShift: TShiftState);\r\nvar\r\n NewKeystroke: TSynEditKeyStroke;\r\nbegin\r\n NewKeystroke := Add;\r\n try\r\n NewKeystroke.Key := AKey;\r\n NewKeystroke.Shift := AShift;\r\n NewKeystroke.Command := ACmd;\r\n except\r\n NewKeystroke.Free;\r\n raise;\r\n end;\r\nend;\r\n\r\nprocedure TSynEditKeyStrokes.Assign(Source: TPersistent);\r\nvar\r\n x: integer;\r\nbegin\r\n if Source is TSynEditKeyStrokes then\r\n begin\r\n Clear;\r\n for x := 0 to TSynEditKeyStrokes(Source).Count-1 do\r\n begin\r\n with Add do\r\n Assign(TSynEditKeyStrokes(Source)[x]);\r\n end;\r\n end\r\n else\r\n inherited Assign(Source);\r\nend;\r\n\r\nconstructor TSynEditKeyStrokes.Create(AOwner: TPersistent);\r\nbegin\r\n inherited Create(TSynEditKeyStroke);\r\n FOwner := AOwner;\r\nend;\r\n\r\nfunction TSynEditKeyStrokes.FindCommand(Cmd: TSynEditorCommand): integer;\r\nvar\r\n x: integer;\r\nbegin\r\n Result := -1;\r\n for x := 0 to Count-1 do\r\n if Items[x].Command = Cmd then\r\n begin\r\n Result := x;\r\n break;\r\n end;\r\nend;\r\n\r\nfunction TSynEditKeyStrokes.FindKeycode(Code: word; SS: TShiftState): integer;\r\nvar\r\n x: integer;\r\nbegin\r\n Result := -1;\r\n for x := 0 to Count-1 do\r\n if (Items[x].Key = Code) and (Items[x].Shift = SS) and (Items[x].Key2 = 0)\r\n then begin\r\n Result := x;\r\n break;\r\n end;\r\nend;\r\n\r\nfunction TSynEditKeyStrokes.FindKeycode2(Code1: word; SS1: TShiftState;\r\n Code2: word; SS2: TShiftState): integer;\r\nvar\r\n x: integer;\r\nbegin\r\n Result := -1;\r\n for x := 0 to Count-1 do\r\n if (Items[x].Key = Code1) and (Items[x].Shift = SS1) and\r\n (Items[x].Key2 = Code2) and (Items[x].Shift2 = SS2) then\r\n begin\r\n Result := x;\r\n break;\r\n end;\r\nend;\r\n\r\nfunction TSynEditKeyStrokes.FindShortcut(SC: TShortcut): integer;\r\nvar\r\n x: integer;\r\nbegin\r\n Result := -1;\r\n for x := 0 to Count-1 do\r\n if Items[x].Shortcut = SC then\r\n begin\r\n Result := x;\r\n break;\r\n end;\r\nend;\r\n\r\nfunction TSynEditKeyStrokes.FindShortcut2(SC, SC2: TShortcut): integer;\r\nvar\r\n x: integer;\r\nbegin\r\n Result := -1;\r\n for x := 0 to Count-1 do\r\n if (Items[x].Shortcut = SC) and (Items[x].Shortcut2 = SC2) then\r\n begin\r\n Result := x;\r\n break;\r\n end;\r\nend;\r\n\r\nfunction TSynEditKeyStrokes.GetItem(Index: Integer): TSynEditKeyStroke;\r\nbegin\r\n Result := TSynEditKeyStroke(inherited GetItem(Index));\r\nend;\r\n\r\n{$IFDEF SYN_COMPILER_3_UP}\r\nfunction TSynEditKeyStrokes.GetOwner: TPersistent;\r\nbegin\r\n Result := FOwner;\r\nend;\r\n{$ENDIF}\r\n\r\nprocedure TSynEditKeyStrokes.LoadFromStream(AStream: TStream);\r\nvar\r\n Num: integer;\r\nbegin\r\n Clear;\r\n AStream.Read(Num, SizeOf(Num));\r\n while Num > 0 do begin\r\n with Add do\r\n LoadFromStream(AStream);\r\n Dec(Num);\r\n end;\r\nend;\r\n\r\nprocedure TSynEditKeyStrokes.ResetDefaults;\r\nbegin\r\n Clear;\r\n\r\n AddKey(ecUp, SYNEDIT_UP, []);\r\n AddKey(ecSelUp, SYNEDIT_UP, [ssShift]);\r\n AddKey(ecScrollUp, SYNEDIT_UP, [ssCtrl]);\r\n AddKey(ecDown, SYNEDIT_DOWN, []);\r\n AddKey(ecSelDown, SYNEDIT_DOWN, [ssShift]);\r\n AddKey(ecScrollDown, SYNEDIT_DOWN, [ssCtrl]);\r\n AddKey(ecLeft, SYNEDIT_LEFT, []);\r\n AddKey(ecSelLeft, SYNEDIT_LEFT, [ssShift]);\r\n AddKey(ecWordLeft, SYNEDIT_LEFT, [ssCtrl]);\r\n AddKey(ecSelWordLeft, SYNEDIT_LEFT, [ssShift,ssCtrl]);\r\n AddKey(ecRight, SYNEDIT_RIGHT, []);\r\n AddKey(ecSelRight, SYNEDIT_RIGHT, [ssShift]);\r\n AddKey(ecWordRight, SYNEDIT_RIGHT, [ssCtrl]);\r\n AddKey(ecSelWordRight, SYNEDIT_RIGHT, [ssShift,ssCtrl]);\r\n AddKey(ecPageDown, SYNEDIT_NEXT, []);\r\n AddKey(ecSelPageDown, SYNEDIT_NEXT, [ssShift]);\r\n AddKey(ecPageBottom, SYNEDIT_NEXT, [ssCtrl]);\r\n AddKey(ecSelPageBottom, SYNEDIT_NEXT, [ssShift,ssCtrl]);\r\n AddKey(ecPageUp, SYNEDIT_PRIOR, []);\r\n AddKey(ecSelPageUp, SYNEDIT_PRIOR, [ssShift]);\r\n AddKey(ecPageTop, SYNEDIT_PRIOR, [ssCtrl]);\r\n AddKey(ecSelPageTop, SYNEDIT_PRIOR, [ssShift,ssCtrl]);\r\n AddKey(ecLineStart, SYNEDIT_HOME, []);\r\n AddKey(ecSelLineStart, SYNEDIT_HOME, [ssShift]);\r\n AddKey(ecEditorTop, SYNEDIT_HOME, [ssCtrl]);\r\n AddKey(ecSelEditorTop, SYNEDIT_HOME, [ssShift,ssCtrl]);\r\n AddKey(ecLineEnd, SYNEDIT_END, []);\r\n AddKey(ecSelLineEnd, SYNEDIT_END, [ssShift]);\r\n AddKey(ecEditorBottom, SYNEDIT_END, [ssCtrl]);\r\n AddKey(ecSelEditorBottom, SYNEDIT_END, [ssShift,ssCtrl]);\r\n AddKey(ecToggleMode, SYNEDIT_INSERT, []);\r\n AddKey(ecCopy, SYNEDIT_INSERT, [ssCtrl]);\r\n AddKey(ecCut, SYNEDIT_DELETE, [ssShift]);\r\n AddKey(ecPaste, SYNEDIT_INSERT, [ssShift]);\r\n AddKey(ecDeleteChar, SYNEDIT_DELETE, []);\r\n AddKey(ecDeleteLastChar, SYNEDIT_BACK, []);\r\n AddKey(ecDeleteLastChar, SYNEDIT_BACK, [ssShift]);\r\n AddKey(ecDeleteLastWord, SYNEDIT_BACK, [ssCtrl]);\r\n AddKey(ecUndo, SYNEDIT_BACK, [ssAlt]);\r\n AddKey(ecRedo, SYNEDIT_BACK, [ssAlt,ssShift]);\r\n AddKey(ecLineBreak, SYNEDIT_RETURN, []);\r\n AddKey(ecLineBreak, SYNEDIT_RETURN, [ssShift]);\r\n AddKey(ecTab, SYNEDIT_TAB, []);\r\n AddKey(ecShiftTab, SYNEDIT_TAB, [ssShift]);\r\n AddKey(ecContextHelp, SYNEDIT_F1, []);\r\n\r\n AddKey(ecSelectAll, ord('A'), [ssCtrl]);\r\n AddKey(ecCopy, ord('C'), [ssCtrl]);\r\n AddKey(ecPaste, ord('V'), [ssCtrl]);\r\n AddKey(ecCut, ord('X'), [ssCtrl]);\r\n AddKey(ecBlockIndent, ord('I'), [ssCtrl,ssShift]);\r\n AddKey(ecBlockUnindent, ord('U'), [ssCtrl,ssShift]);\r\n AddKey(ecLineBreak, ord('M'), [ssCtrl]);\r\n AddKey(ecInsertLine, ord('N'), [ssCtrl]);\r\n AddKey(ecDeleteWord, ord('T'), [ssCtrl]);\r\n AddKey(ecDeleteLine, ord('Y'), [ssCtrl]);\r\n AddKey(ecDeleteEOL, ord('Y'), [ssCtrl,ssShift]);\r\n AddKey(ecUndo, ord('Z'), [ssCtrl]);\r\n AddKey(ecRedo, ord('Z'), [ssCtrl,ssShift]);\r\n AddKey(ecGotoMarker0, ord('0'), [ssCtrl]);\r\n AddKey(ecGotoMarker1, ord('1'), [ssCtrl]);\r\n AddKey(ecGotoMarker2, ord('2'), [ssCtrl]);\r\n AddKey(ecGotoMarker3, ord('3'), [ssCtrl]);\r\n AddKey(ecGotoMarker4, ord('4'), [ssCtrl]);\r\n AddKey(ecGotoMarker5, ord('5'), [ssCtrl]);\r\n AddKey(ecGotoMarker6, ord('6'), [ssCtrl]);\r\n AddKey(ecGotoMarker7, ord('7'), [ssCtrl]);\r\n AddKey(ecGotoMarker8, ord('8'), [ssCtrl]);\r\n AddKey(ecGotoMarker9, ord('9'), [ssCtrl]);\r\n AddKey(ecSetMarker0, ord('0'), [ssCtrl,ssShift]);\r\n AddKey(ecSetMarker1, ord('1'), [ssCtrl,ssShift]);\r\n AddKey(ecSetMarker2, ord('2'), [ssCtrl,ssShift]);\r\n AddKey(ecSetMarker3, ord('3'), [ssCtrl,ssShift]);\r\n AddKey(ecSetMarker4, ord('4'), [ssCtrl,ssShift]);\r\n AddKey(ecSetMarker5, ord('5'), [ssCtrl,ssShift]);\r\n AddKey(ecSetMarker6, ord('6'), [ssCtrl,ssShift]);\r\n AddKey(ecSetMarker7, ord('7'), [ssCtrl,ssShift]);\r\n AddKey(ecSetMarker8, ord('8'), [ssCtrl,ssShift]);\r\n AddKey(ecSetMarker9, ord('9'), [ssCtrl,ssShift]);\r\n AddKey(ecNormalSelect, ord('N'), [ssCtrl,ssShift]);\r\n AddKey(ecColumnSelect, ord('C'), [ssCtrl,ssShift]);\r\n AddKey(ecLineSelect, ord('L'), [ssCtrl,ssShift]);\r\n AddKey(ecMatchBracket, ord('B'), [ssCtrl,ssShift]);\r\nend;\r\n\r\nprocedure TSynEditKeyStrokes.SetItem(Index: Integer; Value: TSynEditKeyStroke);\r\nbegin\r\n inherited SetItem(Index, Value);\r\nend;\r\n\r\nprocedure TSynEditKeyStrokes.SaveToStream(AStream: TStream);\r\nvar\r\n i, Num: integer;\r\nbegin\r\n Num := Count;\r\n AStream.Write(Num, SizeOf(Num));\r\n for i := 0 to Num - 1 do\r\n Items[i].SaveToStream(AStream);\r\nend;\r\n\r\nfunction ConvertCodeStringToExtended(AString: string): string;\r\nvar\r\n i: integer;\r\n WorkStr: string;\r\nbegin\r\n if pos('ec', AString) = 1 then\r\n begin\r\n Delete(AString, 1, 2);\r\n WorkStr := '';\r\n\r\n for i := length(AString) downto 1 do\r\n if CharInSet(AString[i], ['A'..'Z', '0'..'9']) and (i > 1) and\r\n not CharInSet(AString[i - 1], ['A'..'Z', '0'..'9']) then\r\n begin\r\n WorkStr := ' ' + AString[i] + WorkStr\r\n end\r\n else\r\n WorkStr := AString[i] + WorkStr;\r\n\r\n trim(WorkStr);\r\n\r\n i := pos('Sel ', WorkStr);\r\n while i <> 0 do\r\n begin\r\n Delete(WorkStr, i, Length('Sel '));\r\n Insert('Select ', WorkStr, i);\r\n i := pos('Sel ', WorkStr);\r\n end;\r\n\r\n i := pos('Marker ', WorkStr);\r\n while i <> 0 do\r\n begin\r\n Delete(WorkStr, i, Length('Marker '));\r\n Insert('Bookmark ', WorkStr,i);\r\n i := pos('Marker ', WorkStr);\r\n end;\r\n\r\n Result := Trim(WorkStr);\r\n end\r\n else\r\n Result := AString;\r\nend;\r\n\r\nfunction ConvertExtendedToCodeString(AString: string): string;\r\nvar\r\n i: Integer;\r\n WorkStr: string;\r\nbegin\r\n if pos('ec', AString) = 1 then\r\n begin\r\n result := AString;\r\n exit;\r\n end;\r\n\r\n WorkStr := AString;\r\n\r\n i := pos('Select All', WorkStr);\r\n if i = 0 then\r\n begin\r\n i := pos('Select ', WorkStr);\r\n while i <> 0 do\r\n begin\r\n Delete(WorkStr,i,Length('Select '));\r\n Insert('Sel ',WorkStr,i);\r\n i := pos('Select ', WorkStr);\r\n end;\r\n end;\r\n\r\n i := pos('Bookmark ', WorkStr);\r\n while i <> 0 do\r\n begin\r\n Delete(WorkStr,i,Length('Bookmark '));\r\n Insert('Marker ',WorkStr,i);\r\n i := pos('Bookmark ', WorkStr);\r\n end;\r\n\r\n i := pos(' ', WorkStr);\r\n while i <> 0 do\r\n begin\r\n delete(WorkStr,i,1);\r\n i := pos(' ', WorkStr);\r\n end;\r\n\r\n Result := 'ec' + WorkStr;\r\nend;\r\n\r\nfunction IndexToEditorCommand(const AIndex: Integer): Integer;\r\nbegin\r\n Result := EditorCommandStrs[AIndex].Value;\r\nend;\r\n\r\nfunction ConvertExtendedToCommand(AString: string): TSynEditorCommand;\r\nbegin\r\n Result := ConvertCodeStringToCommand(ConvertExtendedToCodeString(AString));\r\nend;\r\n\r\nfunction ConvertCodeStringToCommand(AString: string): TSynEditorCommand;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := ecNone;\r\n\r\n AString := Uppercase(AString);\r\n for i := Low(EditorCommandStrs) to High(EditorCommandStrs) do\r\n if Uppercase(EditorCommandStrs[i].Name) = AString then\r\n begin\r\n Result := EditorCommandStrs[i].Value;\r\n break;\r\n end;\r\nend;\r\n\r\n\r\ninitialization\r\n RegisterIntegerConsts(TypeInfo(TSynEditorCommand), IdentToEditorCommand,\r\n EditorCommandToIdent);\r\nend.\r\n" }, { "path": "External/SynEdit/Source/SynEditKeyCmdsEditor.dfm", "content": "object SynEditKeystrokesEditorForm: TSynEditKeystrokesEditorForm\r\n Left = 300\r\n Top = 241\r\n BorderIcons = [biSystemMenu, biMaximize]\r\n AutoScroll = False\r\n Caption = 'Keystroke Editor'\r\n ClientHeight = 319\r\n ClientWidth = 382\r\n Font.Charset = DEFAULT_CHARSET\r\n Font.Color = clWindowText\r\n Font.Height = -11\r\n Font.Name = 'MS Sans Serif'\r\n Font.Style = []\r\n Position = poScreenCenter\r\n OnCreate = FormCreate\r\n OnResize = FormResize\r\n PixelsPerInch = 96\r\n TextHeight = 13\r\n object pnlBottom: TPanel\r\n Left = 8\r\n Top = 8\r\n Width = 365\r\n Height = 308\r\n BevelInner = bvRaised\r\n BevelOuter = bvLowered\r\n TabOrder = 0\r\n object lnlInfo: TLabel\r\n Left = 5\r\n Top = 271\r\n Width = 229\r\n Height = 13\r\n Caption = 'NOTE: To have multiple keystrokes do the same'\r\n end\r\n object lnlInfo2: TLabel\r\n Left = 42\r\n Top = 287\r\n Width = 217\r\n Height = 13\r\n Caption = 'command, assign the command multiple times.'\r\n end\r\n object pnlCommands: TPanel\r\n Left = 16\r\n Top = 16\r\n Width = 246\r\n Height = 244\r\n BevelInner = bvLowered\r\n BorderWidth = 4\r\n Caption = 'pnlCommands'\r\n TabOrder = 0\r\n object KeyCmdList: TListView\r\n Left = 6\r\n Top = 6\r\n Width = 234\r\n Height = 232\r\n Align = alClient\r\n BorderStyle = bsNone\r\n ColumnClick = False\r\n OnClick = KeyCmdListClick\r\n OnDblClick = btnEditClick\r\n Columns = <\r\n item\r\n Caption = 'Command'\r\n Width = 117\r\n end\r\n item\r\n Caption = 'Keystroke'\r\n Width = 101\r\n end>\r\n HideSelection = False\r\n TabOrder = 0\r\n ViewStyle = vsReport\r\n end\r\n end\r\n object btnAdd: TButton\r\n Left = 276\r\n Top = 20\r\n Width = 75\r\n Height = 25\r\n Caption = '&Add'\r\n TabOrder = 1\r\n OnClick = btnAddClick\r\n end\r\n object btnEdit: TButton\r\n Left = 276\r\n Top = 52\r\n Width = 75\r\n Height = 25\r\n Caption = '&Edit'\r\n Enabled = False\r\n TabOrder = 2\r\n OnClick = btnEditClick\r\n end\r\n object btnDelete: TButton\r\n Left = 276\r\n Top = 84\r\n Width = 75\r\n Height = 25\r\n Caption = '&Delete'\r\n Enabled = False\r\n TabOrder = 3\r\n OnClick = btnDeleteClick\r\n end\r\n object btnClear: TButton\r\n Left = 276\r\n Top = 116\r\n Width = 75\r\n Height = 25\r\n Caption = 'C&lear List'\r\n TabOrder = 4\r\n OnClick = btnClearClick\r\n end\r\n object btnReset: TButton\r\n Left = 276\r\n Top = 148\r\n Width = 75\r\n Height = 25\r\n Caption = '&Reset List'\r\n TabOrder = 5\r\n OnClick = btnResetClick\r\n end\r\n object btnOK: TButton\r\n Left = 276\r\n Top = 241\r\n Width = 75\r\n Height = 25\r\n Caption = '&OK'\r\n Default = True\r\n TabOrder = 6\r\n OnClick = btnOKClick\r\n end\r\n object btnCancel: TButton\r\n Left = 276\r\n Top = 273\r\n Width = 75\r\n Height = 25\r\n Cancel = True\r\n Caption = '&Cancel'\r\n TabOrder = 7\r\n OnClick = btnCancelClick\r\n end\r\n end\r\nend\r\n" }, { "path": "External/SynEdit/Source/SynEditKeyCmdsEditor.pas", "content": "{-------------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: SynEditKeyCmdsEditor.pas, released 2000-04-07.\r\nThe Original Code is based on the mwKeyCmdsEditor.pas file from the\r\nmwEdit component suite by Martin Waldenburg and other developers, the Initial\r\nAuthor of this file is Brad Stowers.\r\nAll Rights Reserved.\r\n\r\nContributors to the SynEdit and mwEdit projects are listed in the\r\nContributors.txt file.\r\n\r\nAlternatively, the contents of this file may be used under the terms of the\r\nGNU General Public License Version 2 or later (the \"GPL\"), in which case\r\nthe provisions of the GPL are applicable instead of those above.\r\nIf you wish to allow use of your version of this file only under the terms\r\nof the GPL and not to allow others to use your version of this file\r\nunder the MPL, indicate your decision by deleting the provisions above and\r\nreplace them with the notice and other provisions required by the GPL.\r\nIf you do not delete the provisions above, a recipient may use your version\r\nof this file under either the MPL or the GPL.\r\n\r\n$Id: SynEditKeyCmdsEditor.pas,v 1.10.2.2 2004/12/10 15:31:05 maelh Exp $\r\n\r\nYou may retrieve the latest version of this file at the SynEdit home page,\r\nlocated at http://SynEdit.SourceForge.net\r\n\r\nKnown Issues:\r\n-------------------------------------------------------------------------------}\r\n\r\n{$IFNDEF QSYNEDITKEYCMDSEDITOR}\r\nunit SynEditKeyCmdsEditor;\r\n{$ENDIF}\r\n\r\n{$I SynEdit.inc}\r\n\r\ninterface\r\n\r\nuses\r\n{$IFDEF SYN_CLX}\r\n Qt,\r\n QGraphics,\r\n QControls,\r\n QForms,\r\n QDialogs,\r\n QComCtrls,\r\n QMenus,\r\n QStdCtrls,\r\n QExtCtrls,\r\n QButtons,\r\n QSynEditKeyCmds,\r\n{$ELSE}\r\n Windows,\r\n Messages,\r\n Graphics,\r\n Controls,\r\n Forms,\r\n Dialogs,\r\n ComCtrls,\r\n Menus,\r\n StdCtrls,\r\n Buttons,\r\n ExtCtrls,\r\n SynEditKeyCmds,\r\n{$ENDIF}\r\n SysUtils,\r\n Classes;\r\n\r\ntype\r\n TSynEditKeystrokesEditorForm = class(TForm)\r\n pnlBottom: TPanel;\r\n lnlInfo: TLabel;\r\n lnlInfo2: TLabel;\r\n btnAdd: TButton;\r\n btnEdit: TButton;\r\n btnDelete: TButton;\r\n btnClear: TButton;\r\n btnReset: TButton;\r\n btnOK: TButton;\r\n btnCancel: TButton;\r\n pnlCommands: TPanel;\r\n KeyCmdList: TListView;\r\n procedure FormResize(Sender: TObject);\r\n procedure btnAddClick(Sender: TObject);\r\n procedure btnEditClick(Sender: TObject);\r\n procedure btnDeleteClick(Sender: TObject);\r\n procedure btnResetClick(Sender: TObject);\r\n procedure FormCreate(Sender: TObject);\r\n procedure btnClearClick(Sender: TObject);\r\n procedure btnOKClick(Sender: TObject);\r\n procedure btnCancelClick(Sender: TObject);\r\n procedure KeyCmdListClick(Sender: TObject);\r\n private\r\n FKeystrokes: TSynEditKeystrokes;\r\n FExtended: Boolean;\r\n procedure SetKeystrokes(const Value: TSynEditKeyStrokes);\r\n procedure UpdateKeystrokesList;\r\n {$IFNDEF SYN_CLX}\r\n procedure WMGetMinMaxInfo(var Msg: TWMGetMinMaxInfo);\r\n message WM_GETMINMAXINFO;\r\n {$ENDIF}\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n\r\n property Keystrokes: TSynEditKeyStrokes read FKeystrokes write SetKeystrokes;\r\n property ExtendedString: Boolean read FExtended write FExtended;\r\n end;\r\n\r\nimplementation\r\n\r\n{$R *.dfm}\r\n\r\nuses\r\n{$IFDEF SYN_CLX}\r\n QSynEditKeyCmdEditor,\r\n QSynEditStrConst;\r\n{$ELSE}\r\n SynEditKeyCmdEditor,\r\n SynEditStrConst;\r\n{$ENDIF}\r\n\r\n{ TSynEditKeystrokesEditorForm }\r\n\r\nconstructor TSynEditKeystrokesEditorForm.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n FKeystrokes := nil;\r\nend;\r\n\r\ndestructor TSynEditKeystrokesEditorForm.Destroy;\r\nbegin\r\n if Assigned(FKeyStrokes) then FKeystrokes.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TSynEditKeystrokesEditorForm.SetKeystrokes(const Value:\r\n TSynEditKeyStrokes);\r\nbegin\r\n if FKeystrokes = nil then\r\n FKeystrokes := TSynEditKeyStrokes.Create(Self);\r\n FKeystrokes.Assign(Value);\r\n UpdateKeystrokesList;\r\nend;\r\n\r\nprocedure TSynEditKeystrokesEditorForm.UpdateKeystrokesList;\r\nvar\r\n x: integer;\r\nbegin\r\n KeyCmdList.Items.BeginUpdate;\r\n try\r\n KeyCmdList.Items.Clear;\r\n for x := 0 to FKeystrokes.Count-1 do\r\n begin\r\n with KeyCmdList.Items.Add do\r\n begin\r\n if FExtended then\r\n Caption := ConvertCodeStringToExtended(EditorCommandToCodeString(FKeystrokes[x].Command))\r\n else Caption := EditorCommandToCodeString(FKeystrokes[x].Command);\r\n if FKeystrokes[x].ShortCut = 0 then\r\n SubItems.Add(SYNS_ShortCutNone)\r\n else\r\n if FKeystrokes[x].ShortCut2 = 0 then\r\n {$IFDEF SYN_CLX}\r\n SubItems.Add(QMenus.ShortCutToText(FKeystrokes[x].ShortCut))\r\n {$ELSE}\r\n SubItems.Add(Menus.ShortCutToText(FKeystrokes[x].ShortCut))\r\n {$ENDIF}\r\n else\r\n {$IFDEF SYN_CLX}\r\n SubItems.Add(QMenus.ShortCutToText(FKeystrokes[x].ShortCut)+ ' '+\r\n QMenus.ShortCutToText(FKeystrokes[x].ShortCut2));\r\n {$ELSE}\r\n SubItems.Add(Menus.ShortCutToText(FKeystrokes[x].ShortCut)+ ' '+\r\n Menus.ShortCutToText(FKeystrokes[x].ShortCut2));\r\n {$ENDIF}\r\n end;\r\n end;\r\n finally\r\n KeyCmdList.Items.EndUpdate;\r\n end;\r\nend;\r\n\r\nprocedure TSynEditKeystrokesEditorForm.FormResize(Sender: TObject);\r\nbegin\r\n pnlBottom.Width := pnlBottom.Left + ClientWidth - 25;\r\n pnlBottom.Height := ClientHeight - 11;\r\n pnlCommands.Width := ClientWidth - 136;\r\n pnlCommands.Height := ClientHeight - 75;\r\n\r\n btnAdd.Left := pnlCommands.Left + pnlCommands.Width + 14;\r\n btnEdit.Left := pnlCommands.Left + pnlCommands.Width + 14;\r\n btnDelete.Left := pnlCommands.Left + pnlCommands.Width + 14;\r\n btnClear.Left := pnlCommands.Left + pnlCommands.Width + 14;\r\n btnReset.Left := pnlCommands.Left + pnlCommands.Width + 14;\r\n\r\n btnOK.Left := pnlCommands.Left + pnlCommands.Width + 14;\r\n btnOK.Top := pnlCommands.Top + pnlCommands.Height - 19;\r\n btnCancel.Left := pnlCommands.Left + pnlCommands.Width + 14;\r\n btnCancel.Top := pnlCommands.Top + pnlCommands.Height + 13;\r\n\r\n lnlInfo.Top := pnlCommands.Top + pnlCommands.Height + 11;\r\n lnlInfo2.Top := pnlCommands.Top + pnlCommands.Height + 27;\r\nend;\r\n\r\n{$IFNDEF SYN_CLX}\r\nprocedure TSynEditKeystrokesEditorForm.WMGetMinMaxInfo(var Msg: TWMGetMinMaxInfo);\r\nbegin\r\n inherited;\r\n Msg.MinMaxInfo.ptMinTrackSize := Point(300, 225);\r\nend;\r\n{$ENDIF}\r\n\r\nprocedure TSynEditKeystrokesEditorForm.btnAddClick(Sender: TObject); //DDH 10/16/01 Begin (reworked proc)\r\nvar\r\n NewStroke: TSynEditKeyStroke;\r\n AForm : TSynEditKeystrokeEditorForm;\r\n\r\n function AddKeyStroke: Boolean;\r\n var\r\n KeyLoc: Integer;\r\n TmpCommand: string;\r\n begin\r\n Result := False;\r\n KeyLoc := 0;\r\n if AForm.ShowModal = mrOK then\r\n begin\r\n Result := True;\r\n NewStroke := FKeystrokes.Add;\r\n NewStroke.Command := AForm.Command;\r\n try\r\n KeyLoc := TSynEditKeyStrokes(NewStroke.Collection).FindShortcut2(AForm.Keystroke, AForm.Keystroke2);\r\n NewStroke.ShortCut := AForm.Keystroke;\r\n NewStroke.ShortCut2 := AForm.Keystroke2;\r\n except\r\n on ESynKeyError do\r\n begin\r\n // Shortcut already exists in the collection!\r\n if FExtended then\r\n TmpCommand := ConvertCodeStringToExtended(EditorCommandToCodeString(TSynEditKeyStrokes(NewStroke.Collection).Items[KeyLoc].Command))\r\n else TmpCommand := EditorCommandToCodeString(TSynEditKeyStrokes(NewStroke.Collection).Items[KeyLoc].Command);\r\n\r\n {$IFDEF SYN_CLX}\r\n Result := MessageDlg(Format(SYNS_DuplicateShortcutMsg,\r\n [QMenus.ShortCutToText(AForm.Keystroke), TmpCommand]),\r\n mtError, [mbOK, mbCancel], 0) = mrOK;\r\n {$ELSE}\r\n Result := MessageDlg(Format(SYNS_DuplicateShortcutMsg,\r\n [Menus.ShortCutToText(AForm.Keystroke), TmpCommand]),\r\n mtError, [mbOK, mbCancel], 0) = mrOK;\r\n {$ENDIF}\r\n NewStroke.Free;\r\n\r\n if Result then\r\n Result := AddKeyStroke;\r\n end;\r\n // Some other kind of exception, we don't deal with it...\r\n end;\r\n end;\r\n end;\r\n\r\nbegin\r\n AForm := TSynEditKeystrokeEditorForm.Create(Self);\r\n with AForm do\r\n try\r\n Caption := 'Add Keystroke';\r\n ExtendedString := self.ExtendedString;\r\n Command := ecNone;\r\n Keystroke := 0;\r\n Keystroke2 := 0;\r\n\r\n if AddKeyStroke then\r\n begin\r\n\r\n with KeyCmdList.Items.Add do\r\n begin\r\n if FExtended then\r\n Caption := ConvertCodeStringToExtended(EditorCommandToCodeString(NewStroke.Command))\r\n else Caption := EditorCommandToCodeString(NewStroke.Command);\r\n if NewStroke.ShortCut = 0 then\r\n SubItems.Add(SYNS_ShortcutNone)\r\n else\r\n if NewStroke.ShortCut2 = 0 then\r\n {$IFDEF SYN_CLX}\r\n SubItems.Add(QMenus.ShortCutToText(NewStroke.ShortCut))\r\n {$ELSE}\r\n SubItems.Add(Menus.ShortCutToText(NewStroke.ShortCut))\r\n {$ENDIF}\r\n else\r\n {$IFDEF SYN_CLX}\r\n SubItems.Add(QMenus.ShortCutToText(NewStroke.ShortCut)+ ' '+\r\n QMenus.ShortCutToText(NewStroke.ShortCut2));\r\n {$ELSE}\r\n SubItems.Add(Menus.ShortCutToText(NewStroke.ShortCut)+ ' '+\r\n Menus.ShortCutToText(NewStroke.ShortCut2));\r\n {$ENDIF}\r\n end;\r\n end;\r\n finally\r\n AForm.Free;\r\n end;\r\nend;\r\n\r\nprocedure TSynEditKeystrokesEditorForm.btnEditClick(Sender: TObject);\r\nvar\r\n SelItem: TListItem;\r\n OldShortcut: TShortcut;\r\n OldShortcut2: TShortcut;\r\n AForm: TSynEditKeystrokeEditorForm;\r\n\r\n function EditKeyStroke: Boolean;\r\n var\r\n KeyLoc: Integer;\r\n TmpCommand: string;\r\n begin\r\n Result := False;\r\n KeyLoc := 0;\r\n if AForm.ShowModal = mrOK then\r\n begin\r\n Result := True;\r\n OldShortCut := FKeystrokes[SelItem.Index].ShortCut;\r\n OldShortCut2 := FKeystrokes[SelItem.Index].ShortCut2;\r\n\r\n try\r\n KeyLoc := TSynEditKeyStrokes(FKeystrokes[SelItem.Index].Collection).FindShortcut2(AForm.Keystroke, AForm.Keystroke2);\r\n FKeystrokes[SelItem.Index].Command := AForm.Command;\r\n FKeystrokes[SelItem.Index].ShortCut := AForm.Keystroke;\r\n FKeystrokes[SelItem.Index].ShortCut2 := AForm.Keystroke2;\r\n except\r\n on ESynKeyError do\r\n begin\r\n // Shortcut already exists in the collection!\r\n if FExtended then\r\n TmpCommand := ConvertCodeStringToExtended(EditorCommandToCodeString(TSynEditKeyStrokes(FKeystrokes[SelItem.Index].Collection).Items[KeyLoc].Command))\r\n else TmpCommand := EditorCommandToCodeString(TSynEditKeyStrokes(FKeystrokes[SelItem.Index].Collection).Items[KeyLoc].Command);\r\n\r\n {$IFDEF SYN_CLX}\r\n Result := MessageDlg(Format(SYNS_DuplicateShortcutMsg,\r\n [QMenus.ShortCutToText(AForm.Keystroke), TmpCommand]),\r\n mtError, [mbOK, mbCancel], 0) = mrOK;\r\n {$ELSE}\r\n Result := MessageDlg(Format(SYNS_DuplicateShortcutMsg,\r\n [Menus.ShortCutToText(AForm.Keystroke), TmpCommand]),\r\n mtError, [mbOK, mbCancel], 0) = mrOK;\r\n {$ENDIF}\r\n\r\n FKeystrokes[SelItem.Index].ShortCut := OldShortCut;\r\n FKeystrokes[SelItem.Index].ShortCut2 := OldShortCut2;\r\n\r\n if Result then\r\n Result := EditKeyStroke;\r\n end;\r\n // Some other kind of exception, we don't deal with it...\r\n end;\r\n end;\r\n(*\r\n if ShowModal = mrOK then\r\n begin\r\n\r\n try\r\n except\r\n on ESynKeyError do\r\n begin\r\n // Shortcut already exists in the collection!\r\n {$IFDEF SYN_KYLIX}\r\n MessageDlg(Format(SYNS_DuplicateShortcutMsg2,\r\n [QMenus.ShortCutToText(Keystroke)]), mtError, [mbOK], 0);\r\n {$ELSE}\r\n MessageDlg(Format(SYNS_DuplicateShortcutMsg2,\r\n [Menus.ShortCutToText(Keystroke)]), mtError, [mbOK], 0);\r\n {$ENDIF}\r\n end;\r\n // Some other kind of exception, we don't deal with it...\r\n end;\r\n*)\r\n end;\r\nbegin\r\n SelItem := KeyCmdList.Selected;\r\n if SelItem = NIL then\r\n begin\r\n {$IFDEF SYN_CLX}\r\n QControls.Beep;\r\n {$ELSE}\r\n MessageBeep(1);\r\n {$ENDIF}\r\n exit;\r\n end;\r\n AForm := TSynEditKeystrokeEditorForm.Create(Self);\r\n with AForm do\r\n try\r\n ExtendedString := self.ExtendedString;\r\n Command := FKeystrokes[SelItem.Index].Command;\r\n Keystroke := FKeystrokes[SelItem.Index].Shortcut;\r\n Keystroke2 := FKeystrokes[SelItem.Index].Shortcut2;\r\n if EditKeyStroke then\r\n begin\r\n KeyCmdList.Items.BeginUpdate;\r\n try\r\n with SelItem do\r\n begin\r\n\r\n if FExtended then\r\n Caption := ConvertCodeStringToExtended(EditorCommandToCodeString(FKeystrokes[Index].Command))\r\n else Caption := EditorCommandToCodeString(FKeystrokes[Index].Command);\r\n\r\n if FKeystrokes[Index].ShortCut = 0 then\r\n SubItems[0] := SYNS_ShortcutNone\r\n else\r\n if FKeystrokes[Index].ShortCut2 = 0 then\r\n {$IFDEF SYN_CLX}\r\n SubItems[0] := QMenus.ShortCutToText(FKeystrokes[Index].ShortCut)\r\n {$ELSE}\r\n SubItems[0] := Menus.ShortCutToText(FKeystrokes[Index].ShortCut)\r\n {$ENDIF}\r\n else\r\n {$IFDEF SYN_CLX}\r\n SubItems[0] := QMenus.ShortCutToText(FKeystrokes[Index].ShortCut)\r\n + ' ' + QMenus.ShortCutToText(FKeystrokes[Index].ShortCut2);\r\n {$ELSE}\r\n SubItems[0] := Menus.ShortCutToText(FKeystrokes[Index].ShortCut)\r\n + ' ' + Menus.ShortCutToText(FKeystrokes[Index].ShortCut2);\r\n {$ENDIF}\r\n end;\r\n finally\r\n KeyCmdList.Items.EndUpdate;\r\n end;\r\n end;\r\n finally\r\n AForm.Free;\r\n end;\r\nend; //DDH 10/16/01 End (reworked procs)\r\n\r\nprocedure TSynEditKeystrokesEditorForm.btnDeleteClick(Sender: TObject);\r\nvar\r\n SelItem: TListItem;\r\nbegin\r\n SelItem := KeyCmdList.Selected;\r\n if SelItem = nil then\r\n begin\r\n {$IFDEF SYN_CLX}\r\n QControls.Beep;\r\n {$ELSE}\r\n MessageBeep(1);\r\n {$ENDIF}\r\n exit;\r\n end;\r\n FKeystrokes[SelItem.Index].Free;\r\n KeyCmdList.Items.Delete(SelItem.Index);\r\nend;\r\n\r\nprocedure TSynEditKeystrokesEditorForm.btnClearClick(Sender: TObject);\r\nbegin\r\n FKeystrokes.Clear;\r\n KeyCmdList.Items.Clear;\r\nend;\r\n\r\nprocedure TSynEditKeystrokesEditorForm.btnResetClick(Sender: TObject);\r\nbegin\r\n FKeystrokes.ResetDefaults;\r\n UpdateKeystrokesList;\r\nend;\r\n\r\nprocedure TSynEditKeystrokesEditorForm.FormCreate(Sender: TObject);\r\nbegin\r\n {$IFDEF SYN_COMPILER_3_UP}\r\n KeyCmdList.RowSelect := True;\r\n {$ENDIF}\r\nend;\r\n\r\nprocedure TSynEditKeystrokesEditorForm.btnOKClick(Sender: TObject);\r\nbegin\r\n ModalResult := mrOK;\r\nend;\r\n\r\nprocedure TSynEditKeystrokesEditorForm.btnCancelClick(Sender: TObject);\r\nbegin\r\n ModalResult := mrCancel;\r\nend;\r\n\r\nprocedure TSynEditKeystrokesEditorForm.KeyCmdListClick(Sender: TObject);\r\nbegin\r\n btnEdit.Enabled := Assigned(KeyCmdList.Selected);\r\n btnDelete.Enabled := btnEdit.Enabled;\r\nend;\r\n\r\nend.\r\n\r\n" }, { "path": "External/SynEdit/Source/SynEditKeyConst.pas", "content": "{-------------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: SynEditKeyCmds.pas, released 2000-04-07.\r\nThe Original Code is based on the mwKeyCmds.pas file from the\r\nmwEdit component suite by Martin Waldenburg and other developers, the Initial\r\nAuthor of this file is Brad Stowers.\r\nAll Rights Reserved.\r\n\r\nContributors to the SynEdit and mwEdit projects are listed in the\r\nContributors.txt file.\r\n\r\nAlternatively, the contents of this file may be used under the terms of the\r\nGNU General Public License Version 2 or later (the \"GPL\"), in which case\r\nthe provisions of the GPL are applicable instead of those above.\r\nIf you wish to allow use of your version of this file only under the terms\r\nof the GPL and not to allow others to use your version of this file\r\nunder the MPL, indicate your decision by deleting the provisions above and\r\nreplace them with the notice and other provisions required by the GPL.\r\nIf you do not delete the provisions above, a recipient may use your version\r\nof this file under either the MPL or the GPL.\r\n\r\n$Id: SynEditKeyConst.pas,v 1.4.2.1 2004/08/31 12:55:17 maelh Exp $\r\n\r\nYou may retrieve the latest version of this file at the SynEdit home page,\r\nlocated at http://SynEdit.SourceForge.net\r\n\r\nKnown Issues:\r\n-------------------------------------------------------------------------------}\r\n\r\n{$IFNDEF QSYNEDITKEYCONST}\r\nunit SynEditKeyConst;\r\n{$ENDIF}\r\n\r\n{ This unit provides a translation of DELPHI and CLX key constants to\r\n more readable SynEdit constants }\r\n\r\n{$I SynEdit.inc}\r\n\r\ninterface\r\n\r\nuses\r\n{$IFDEF SYN_CLX}\r\n Qt;\r\n{$ELSE}\r\n Windows;\r\n{$ENDIF}\r\n\r\nconst\r\n\r\n{$IFDEF SYN_CLX}\r\n\r\n SYNEDIT_RETURN = KEY_RETURN;\r\n SYNEDIT_ESCAPE = KEY_ESCAPE;\r\n SYNEDIT_SPACE = KEY_SPACE;\r\n SYNEDIT_PRIOR = KEY_PRIOR;\r\n SYNEDIT_NEXT = KEY_NEXT;\r\n SYNEDIT_END = KEY_END;\r\n SYNEDIT_HOME = KEY_HOME;\r\n SYNEDIT_UP = KEY_UP;\r\n SYNEDIT_DOWN = KEY_DOWN;\r\n SYNEDIT_BACK = KEY_BACKSPACE;\r\n SYNEDIT_LEFT = KEY_LEFT;\r\n SYNEDIT_RIGHT = KEY_RIGHT;\r\n SYNEDIT_MENU = KEY_MENU;\r\n SYNEDIT_CONTROL = KEY_CONTROL;\r\n SYNEDIT_SHIFT = KEY_SHIFT;\r\n SYNEDIT_F1 = KEY_F1;\r\n SYNEDIT_F2 = KEY_F2;\r\n SYNEDIT_F3 = KEY_F3;\r\n SYNEDIT_F4 = KEY_F4;\r\n SYNEDIT_F5 = KEY_F5;\r\n SYNEDIT_F6 = KEY_F6;\r\n SYNEDIT_F7 = KEY_F7;\r\n SYNEDIT_F8 = KEY_F8;\r\n SYNEDIT_F9 = KEY_F9;\r\n SYNEDIT_F10 = KEY_F10;\r\n SYNEDIT_F11 = KEY_F11;\r\n SYNEDIT_F12 = KEY_F12;\r\n SYNEDIT_F13 = KEY_F13;\r\n SYNEDIT_F14 = KEY_F14;\r\n SYNEDIT_F15 = KEY_F15;\r\n SYNEDIT_F16 = KEY_F16;\r\n SYNEDIT_F17 = KEY_F17;\r\n SYNEDIT_F18 = KEY_F18;\r\n SYNEDIT_F19 = KEY_F19;\r\n SYNEDIT_F20 = KEY_F20;\r\n SYNEDIT_F21 = KEY_F21;\r\n SYNEDIT_F22 = KEY_F22;\r\n SYNEDIT_F23 = KEY_F23;\r\n SYNEDIT_F24 = KEY_F24;\r\n SYNEDIT_PRINT = KEY_PRINT;\r\n SYNEDIT_INSERT = KEY_INSERT;\r\n SYNEDIT_DELETE = KEY_DELETE;\r\n SYNEDIT_NUMPAD0 = KEY_0;\r\n SYNEDIT_NUMPAD1 = KEY_1;\r\n SYNEDIT_NUMPAD2 = KEY_2;\r\n SYNEDIT_NUMPAD3 = KEY_3;\r\n SYNEDIT_NUMPAD4 = KEY_4;\r\n SYNEDIT_NUMPAD5 = KEY_5;\r\n SYNEDIT_NUMPAD6 = KEY_6;\r\n SYNEDIT_NUMPAD7 = KEY_7;\r\n SYNEDIT_NUMPAD8 = KEY_8;\r\n SYNEDIT_NUMPAD9 = KEY_9;\r\n SYNEDIT_MULTIPLY = KEY_MULTIPLY;\r\n SYNEDIT_ADD = KEY_PLUS;\r\n SYNEDIT_SEPARATOR = KEY_ENTER;\r\n SYNEDIT_SUBTRACT = KEY_MINUS;\r\n SYNEDIT_DECIMAL = KEY_PERIOD;\r\n SYNEDIT_DIVIDE = KEY_SLASH;\r\n SYNEDIT_NUMLOCK = KEY_NUMLOCK;\r\n SYNEDIT_SCROLL = KEY_SCROLLLOCK;\r\n SYNEDIT_TAB = KEY_TAB;\r\n SYNEDIT_CLEAR = KEY_SYSREQ;\r\n SYNEDIT_PAUSE = KEY_PAUSE;\r\n SYNEDIT_CAPITAL = KEY_CAPSLOCK;\r\n \r\n{$ELSE}\r\n\r\n SYNEDIT_RETURN = VK_RETURN;\r\n SYNEDIT_ESCAPE = VK_ESCAPE;\r\n SYNEDIT_SPACE = VK_SPACE;\r\n SYNEDIT_PRIOR = VK_PRIOR;\r\n SYNEDIT_NEXT = VK_NEXT;\r\n SYNEDIT_END = VK_END;\r\n SYNEDIT_HOME = VK_HOME;\r\n SYNEDIT_UP = VK_UP;\r\n SYNEDIT_DOWN = VK_DOWN;\r\n SYNEDIT_BACK = VK_BACK;\r\n SYNEDIT_LEFT = VK_LEFT;\r\n SYNEDIT_RIGHT = VK_RIGHT;\r\n SYNEDIT_MENU = VK_MENU;\r\n SYNEDIT_CONTROL = VK_CONTROL;\r\n SYNEDIT_SHIFT = VK_SHIFT;\r\n SYNEDIT_F1 = VK_F1;\r\n SYNEDIT_F2 = VK_F2;\r\n SYNEDIT_F3 = VK_F3;\r\n SYNEDIT_F4 = VK_F4;\r\n SYNEDIT_F5 = VK_F5;\r\n SYNEDIT_F6 = VK_F6;\r\n SYNEDIT_F7 = VK_F7;\r\n SYNEDIT_F8 = VK_F8;\r\n SYNEDIT_F9 = VK_F9;\r\n SYNEDIT_F10 = VK_F10;\r\n SYNEDIT_F11 = VK_F11;\r\n SYNEDIT_F12 = VK_F12;\r\n SYNEDIT_F13 = VK_F13;\r\n SYNEDIT_F14 = VK_F14;\r\n SYNEDIT_F15 = VK_F15;\r\n SYNEDIT_F16 = VK_F16;\r\n SYNEDIT_F17 = VK_F17;\r\n SYNEDIT_F18 = VK_F18;\r\n SYNEDIT_F19 = VK_F19;\r\n SYNEDIT_F20 = VK_F20;\r\n SYNEDIT_F21 = VK_F21;\r\n SYNEDIT_F22 = VK_F22;\r\n SYNEDIT_F23 = VK_F23;\r\n SYNEDIT_F24 = VK_F24;\r\n SYNEDIT_PRINT = VK_PRINT;\r\n SYNEDIT_INSERT = VK_INSERT;\r\n SYNEDIT_DELETE = VK_DELETE;\r\n SYNEDIT_NUMPAD0 = VK_NUMPAD0;\r\n SYNEDIT_NUMPAD1 = VK_NUMPAD1;\r\n SYNEDIT_NUMPAD2 = VK_NUMPAD2;\r\n SYNEDIT_NUMPAD3 = VK_NUMPAD3;\r\n SYNEDIT_NUMPAD4 = VK_NUMPAD4;\r\n SYNEDIT_NUMPAD5 = VK_NUMPAD5;\r\n SYNEDIT_NUMPAD6 = VK_NUMPAD6;\r\n SYNEDIT_NUMPAD7 = VK_NUMPAD7;\r\n SYNEDIT_NUMPAD8 = VK_NUMPAD8;\r\n SYNEDIT_NUMPAD9 = VK_NUMPAD9;\r\n SYNEDIT_MULTIPLY = VK_MULTIPLY;\r\n SYNEDIT_ADD = VK_ADD;\r\n SYNEDIT_SEPARATOR = VK_SEPARATOR;\r\n SYNEDIT_SUBTRACT = VK_SUBTRACT;\r\n SYNEDIT_DECIMAL = VK_DECIMAL;\r\n SYNEDIT_DIVIDE = VK_DIVIDE;\r\n SYNEDIT_NUMLOCK = VK_NUMLOCK;\r\n SYNEDIT_SCROLL = VK_SCROLL;\r\n SYNEDIT_TAB = VK_TAB;\r\n SYNEDIT_CLEAR = VK_CLEAR;\r\n SYNEDIT_PAUSE = VK_PAUSE;\r\n SYNEDIT_CAPITAL = VK_CAPITAL;\r\n \r\n{$ENDIF}\r\n\r\nimplementation\r\n\r\nend.\r\n" }, { "path": "External/SynEdit/Source/SynEditMiscClasses.pas", "content": "{-------------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: SynEditMiscClasses.pas, released 2000-04-07.\r\nThe Original Code is based on the mwSupportClasses.pas file from the\r\nmwEdit component suite by Martin Waldenburg and other developers, the Initial\r\nAuthor of this file is Michael Hieke.\r\nUnicode translation by Mal Hrz.\r\nAll Rights Reserved.\r\n\r\nContributors to the SynEdit and mwEdit projects are listed in the\r\nContributors.txt file.\r\n\r\nAlternatively, the contents of this file may be used under the terms of the\r\nGNU General Public License Version 2 or later (the \"GPL\"), in which case\r\nthe provisions of the GPL are applicable instead of those above.\r\nIf you wish to allow use of your version of this file only under the terms\r\nof the GPL and not to allow others to use your version of this file\r\nunder the MPL, indicate your decision by deleting the provisions above and\r\nreplace them with the notice and other provisions required by the GPL.\r\nIf you do not delete the provisions above, a recipient may use your version\r\nof this file under either the MPL or the GPL.\r\n\r\n$Id: SynEditMiscClasses.pas,v 1.35.2.9 2008/09/17 13:59:12 maelh Exp $\r\n\r\nYou may retrieve the latest version of this file at the SynEdit home page,\r\nlocated at http://SynEdit.SourceForge.net\r\n\r\nKnown Issues:\r\n-------------------------------------------------------------------------------}\r\n\r\n{$IFNDEF QSYNEDITMISCCLASSES}\r\nunit SynEditMiscClasses;\r\n{$ENDIF}\r\n\r\n{$I SynEdit.inc}\r\n\r\ninterface\r\n\r\nuses\r\n{$IFDEF SYN_CLX}\r\n {$IFDEF SYN_LINUX}\r\n Xlib,\r\n {$ENDIF}\r\n Types,\r\n Qt,\r\n QConsts,\r\n QGraphics,\r\n QControls,\r\n QImgList,\r\n QStdCtrls,\r\n QMenus,\r\n kTextDrawer,\r\n QSynEditTypes,\r\n QSynEditKeyConst,\r\n QSynUnicode,\r\n{$ELSE}\r\n Consts,\r\n Windows,\r\n Messages,\r\n Graphics,\r\n Controls,\r\n Forms,\r\n StdCtrls,\r\n Menus,\r\n Registry,\r\n SynEditTypes,\r\n SynEditKeyConst,\r\n SynUnicode,\r\n{$ENDIF}\r\n{$IFDEF SYN_COMPILER_4_UP}\r\n Math,\r\n{$ENDIF}\r\n Classes,\r\n SysUtils;\r\n\r\ntype\r\n TSynSelectedColor = class(TPersistent)\r\n private\r\n fBG: TColor;\r\n fFG: TColor;\r\n fOnChange: TNotifyEvent;\r\n procedure SetBG(Value: TColor);\r\n procedure SetFG(Value: TColor);\r\n public\r\n constructor Create;\r\n procedure Assign(Source: TPersistent); override;\r\n published\r\n property Background: TColor read fBG write SetBG default clHighLight;\r\n property Foreground: TColor read fFG write SetFG default clHighLightText;\r\n property OnChange: TNotifyEvent read fOnChange write fOnChange;\r\n end;\r\n\r\n TSynGutterBorderStyle = (gbsNone, gbsMiddle, gbsRight);\r\n\r\n TSynGutter = class(TPersistent)\r\n private\r\n fFont: TFont;\r\n fColor: TColor;\r\n fBorderColor: TColor;\r\n fWidth: integer;\r\n fShowLineNumbers: boolean;\r\n fDigitCount: integer;\r\n fLeadingZeros: boolean;\r\n fZeroStart: boolean;\r\n fLeftOffset: integer;\r\n fRightOffset: integer;\r\n fOnChange: TNotifyEvent;\r\n fCursor: TCursor;\r\n fVisible: boolean;\r\n fUseFontStyle: boolean;\r\n fAutoSize: boolean;\r\n fAutoSizeDigitCount: integer;\r\n fBorderStyle: TSynGutterBorderStyle;\r\n fLineNumberStart: Integer;\r\n fGradient: Boolean;\r\n fGradientStartColor: TColor;\r\n fGradientEndColor: TColor;\r\n fGradientSteps: Integer;\r\n procedure SetAutoSize(const Value: boolean);\r\n procedure SetBorderColor(const Value: TColor);\r\n procedure SetColor(const Value: TColor);\r\n procedure SetDigitCount(Value: integer);\r\n procedure SetLeadingZeros(const Value: boolean);\r\n procedure SetLeftOffset(Value: integer);\r\n procedure SetRightOffset(Value: integer);\r\n procedure SetShowLineNumbers(const Value: boolean);\r\n procedure SetUseFontStyle(Value: boolean);\r\n procedure SetVisible(Value: boolean);\r\n procedure SetWidth(Value: integer);\r\n procedure SetZeroStart(const Value: boolean);\r\n procedure SetFont(Value: TFont);\r\n procedure OnFontChange(Sender: TObject);\r\n procedure SetBorderStyle(const Value: TSynGutterBorderStyle);\r\n procedure SetLineNumberStart(const Value: Integer);\r\n procedure SetGradient(const Value: Boolean);\r\n procedure SetGradientStartColor(const Value: TColor);\r\n procedure SetGradientEndColor(const Value: TColor);\r\n procedure SetGradientSteps(const Value: Integer);\r\n function GetWidth: integer;\r\n public\r\n constructor Create;\r\n destructor Destroy; override;\r\n procedure Assign(Source: TPersistent); override;\r\n procedure AutoSizeDigitCount(LinesCount: integer);\r\n function FormatLineNumber(Line: integer): string;\r\n function RealGutterWidth(CharWidth: integer): integer;\r\n published\r\n property AutoSize: boolean read fAutoSize write SetAutoSize default FALSE;\r\n property BorderStyle: TSynGutterBorderStyle read fBorderStyle\r\n write SetBorderStyle default gbsMiddle;\r\n property Color: TColor read fColor write SetColor default clBtnFace;\r\n property BorderColor: TColor read fBorderColor write SetBorderColor default clWindow;\r\n property Cursor: TCursor read fCursor write fCursor default crDefault;\r\n property DigitCount: integer read fDigitCount write SetDigitCount\r\n default 4;\r\n property Font: TFont read fFont write SetFont;\r\n property LeadingZeros: boolean read fLeadingZeros write SetLeadingZeros\r\n default FALSE;\r\n property LeftOffset: integer read fLeftOffset write SetLeftOffset\r\n default 16;\r\n property RightOffset: integer read fRightOffset write SetRightOffset\r\n default 2;\r\n property ShowLineNumbers: boolean read fShowLineNumbers\r\n write SetShowLineNumbers default FALSE;\r\n property UseFontStyle: boolean read fUseFontStyle write SetUseFontStyle\r\n default True;\r\n property Visible: boolean read fVisible write SetVisible default TRUE;\r\n property Width: integer read GetWidth write SetWidth default 30;\r\n property ZeroStart: boolean read fZeroStart write SetZeroStart\r\n default False;\r\n property LineNumberStart: Integer read fLineNumberStart write SetLineNumberStart default 1;\r\n property Gradient: Boolean read fGradient write SetGradient default False;\r\n property GradientStartColor: TColor read fGradientStartColor write SetGradientStartColor default clWindow;\r\n property GradientEndColor: TColor read fGradientEndColor write SetGradientEndColor default clBtnFace;\r\n property GradientSteps: Integer read fGradientSteps write SetGradientSteps default 48;\r\n property OnChange: TNotifyEvent read fOnChange write fOnChange;\r\n end;\r\n\r\n TSynBookMarkOpt = class(TPersistent)\r\n private\r\n fBookmarkImages: TImageList;\r\n fDrawBookmarksFirst: boolean;\r\n fEnableKeys: Boolean;\r\n fGlyphsVisible: Boolean;\r\n fLeftMargin: Integer;\r\n fOwner: TComponent;\r\n fXoffset: integer;\r\n fOnChange: TNotifyEvent;\r\n procedure SetBookmarkImages(const Value: TImageList);\r\n procedure SetDrawBookmarksFirst(Value: boolean);\r\n procedure SetGlyphsVisible(Value: Boolean);\r\n procedure SetLeftMargin(Value: Integer);\r\n procedure SetXOffset(Value: integer);\r\n public\r\n constructor Create(AOwner: TComponent);\r\n procedure Assign(Source: TPersistent); override;\r\n published\r\n property BookmarkImages: TImageList\r\n read fBookmarkImages write SetBookmarkImages;\r\n property DrawBookmarksFirst: boolean read fDrawBookmarksFirst\r\n write SetDrawBookmarksFirst default True;\r\n property EnableKeys: Boolean\r\n read fEnableKeys write fEnableKeys default True;\r\n property GlyphsVisible: Boolean\r\n read fGlyphsVisible write SetGlyphsVisible default True;\r\n property LeftMargin: Integer read fLeftMargin write SetLeftMargin default 2;\r\n property Xoffset: integer read fXoffset write SetXOffset default 12;\r\n property OnChange: TNotifyEvent read fOnChange write fOnChange;\r\n end;\r\n\r\n TSynGlyph = class(TPersistent)\r\n private\r\n fVisible: boolean;\r\n fInternalGlyph, fGlyph: TBitmap;\r\n fInternalMaskColor, fMaskColor: TColor;\r\n fOnChange: TNotifyEvent;\r\n procedure SetGlyph(Value: TBitmap);\r\n procedure GlyphChange(Sender: TObject);\r\n procedure SetMaskColor(Value: TColor);\r\n procedure SetVisible(Value: boolean);\r\n function GetWidth : integer;\r\n function GetHeight : integer;\r\n public\r\n constructor Create(aModule: THandle; const aName: string; aMaskColor: TColor);\r\n destructor Destroy; override;\r\n procedure Assign(aSource: TPersistent); override;\r\n procedure Draw(aCanvas: TCanvas; aX, aY, aLineHeight: integer);\r\n property Width : integer read GetWidth;\r\n property Height : integer read GetHeight;\r\n published\r\n property Glyph: TBitmap read fGlyph write SetGlyph;\r\n property MaskColor: TColor read fMaskColor write SetMaskColor default clNone;\r\n property Visible: boolean read fVisible write SetVisible default True;\r\n property OnChange: TNotifyEvent read fOnChange write fOnChange;\r\n end;\r\n\r\n { TSynMethodChain }\r\n\r\n ESynMethodChain = class(Exception);\r\n TSynExceptionEvent = procedure (Sender: TObject; E: Exception;\r\n var DoContinue: Boolean) of object;\r\n\r\n TSynMethodChain = class(TObject)\r\n private\r\n FNotifyProcs: TList;\r\n FExceptionHandler: TSynExceptionEvent;\r\n protected\r\n procedure DoFire(const AEvent: TMethod); virtual; abstract;\r\n function DoHandleException(E: Exception): Boolean; virtual;\r\n property ExceptionHandler: TSynExceptionEvent read FExceptionHandler\r\n write FExceptionHandler;\r\n public\r\n constructor Create; virtual;\r\n destructor Destroy; override;\r\n procedure Add(AEvent: TMethod);\r\n procedure Remove(AEvent: TMethod);\r\n procedure Fire;\r\n end;\r\n\r\n { TSynNotifyEventChain }\r\n\r\n TSynNotifyEventChain = class(TSynMethodChain)\r\n private\r\n FSender: TObject;\r\n protected\r\n procedure DoFire(const AEvent: TMethod); override;\r\n public\r\n constructor CreateEx(ASender: TObject);\r\n procedure Add(AEvent: TNotifyEvent);\r\n procedure Remove(AEvent: TNotifyEvent);\r\n property ExceptionHandler;\r\n property Sender: TObject read FSender write FSender;\r\n end;\r\n\r\n { TSynInternalImage }\r\n \r\n TSynInternalImage = class(TObject)\r\n private\r\n fImages : TBitmap;\r\n fWidth : Integer;\r\n fHeight : Integer;\r\n fCount : Integer;\r\n\r\n function CreateBitmapFromInternalList(aModule: THandle; const Name: string): TBitmap;\r\n procedure FreeBitmapFromInternalList;\r\n public\r\n constructor Create(aModule: THandle; const Name: string; Count: integer);\r\n destructor Destroy; override;\r\n procedure Draw(ACanvas: TCanvas; Number, X, Y, LineHeight: integer);\r\n procedure DrawTransparent(ACanvas: TCanvas; Number, X, Y,\r\n LineHeight: integer; TransparentColor: TColor);\r\n end;\r\n\r\n{ TSynHotKey }\r\n\r\nconst\r\n {$IFDEF SYN_CLX}\r\n BorderWidth = 2;\r\n {$ELSE}\r\n BorderWidth = 0;\r\n {$ENDIF}\r\n\r\ntype\r\n {$IFDEF SYN_CLX}\r\n TSynBorderStyle = bsNone..bsSingle;\r\n {$ELSE}\r\n TSynBorderStyle = TBorderStyle;\r\n {$ENDIF}\r\n\r\n THKModifier = (hkShift, hkCtrl, hkAlt);\r\n THKModifiers = set of THKModifier;\r\n THKInvalidKey = (hcNone, hcShift, hcCtrl, hcAlt, hcShiftCtrl,\r\n hcShiftAlt, hcCtrlAlt, hcShiftCtrlAlt);\r\n THKInvalidKeys = set of THKInvalidKey;\r\n\r\n TSynHotKey = class(TCustomControl)\r\n private\r\n FBorderStyle: TSynBorderStyle;\r\n FHotKey: TShortCut;\r\n FInvalidKeys: THKInvalidKeys;\r\n FModifiers: THKModifiers;\r\n FPressedOnlyModifiers: Boolean;\r\n procedure SetBorderStyle(const Value: TSynBorderStyle);\r\n procedure SetHotKey(const Value: TShortCut);\r\n procedure SetInvalidKeys(const Value: THKInvalidKeys);\r\n procedure SetModifiers(const Value: THKModifiers);\r\n {$IFNDEF SYN_CLX}\r\n procedure WMGetDlgCode(var Message: TMessage); message WM_GETDLGCODE;\r\n procedure WMKillFocus(var Msg: TWMKillFocus); message WM_KILLFOCUS;\r\n procedure WMSetFocus(var Msg: TWMSetFocus); message WM_SETFOCUS;\r\n {$ENDIF}\r\n protected\r\n {$IFNDEF SYN_CLX}\r\n procedure CreateParams(var Params: TCreateParams); override;\r\n {$ENDIF}\r\n {$IFDEF SYN_CLX}\r\n function EventFilter(Sender: QObjectH; Event: QEventH): Boolean; override;\r\n {$ENDIF}\r\n procedure DoExit; override;\r\n procedure KeyDown(var Key: Word; Shift: TShiftState); override;\r\n procedure KeyUp(var Key: Word; Shift: TShiftState); override;\r\n procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;\r\n procedure Paint; override;\r\n {$IFDEF SYN_CLX}\r\n function WidgetFlags: Integer; override;\r\n {$ENDIF}\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n published\r\n property BorderStyle: TSynBorderStyle read FBorderStyle write SetBorderStyle\r\n default bsSingle;\r\n property HotKey: TShortCut read FHotKey write SetHotKey default $0041; { Alt+A }\r\n property InvalidKeys: THKInvalidKeys read FInvalidKeys write SetInvalidKeys default [hcNone, hcShift];\r\n property Modifiers: THKModifiers read FModifiers write SetModifiers default [hkAlt];\r\n end;\r\n\r\n TSynEditSearchCustom = class(TComponent)\r\n protected\r\n function GetPattern: UnicodeString; virtual; abstract;\r\n procedure SetPattern(const Value: UnicodeString); virtual; abstract;\r\n function GetLength(Index: Integer): Integer; virtual; abstract;\r\n function GetResult(Index: Integer): Integer; virtual; abstract;\r\n function GetResultCount: Integer; virtual; abstract;\r\n procedure SetOptions(const Value: TSynSearchOptions); virtual; abstract;\r\n public\r\n function FindAll(const NewText: UnicodeString): Integer; virtual; abstract;\r\n function Replace(const aOccurrence, aReplacement: UnicodeString): UnicodeString; virtual; abstract;\r\n property Pattern: UnicodeString read GetPattern write SetPattern;\r\n property ResultCount: Integer read GetResultCount;\r\n property Results[Index: Integer]: Integer read GetResult;\r\n property Lengths[Index: Integer]: Integer read GetLength;\r\n property Options: TSynSearchOptions write SetOptions;\r\n end;\r\n\r\n{$IFNDEF SYN_CLX}\r\n {$IFNDEF SYN_COMPILER_4_UP}\r\n TBetterRegistry = class(TRegistry)\r\n function OpenKeyReadOnly(const Key: string): Boolean;\r\n end;\r\n {$ELSE}\r\n TBetterRegistry = TRegistry;\r\n {$ENDIF}\r\n{$ENDIF}\r\n\r\nimplementation\r\n\r\nuses\r\n{$IFDEF SYN_CLX}\r\n QSynEditMiscProcs;\r\n{$ELSE}\r\n SynEditMiscProcs;\r\n{$ENDIF}\r\n\r\n{ TSynSelectedColor }\r\n\r\nconstructor TSynSelectedColor.Create;\r\nbegin\r\n inherited Create;\r\n fBG := clHighLight;\r\n fFG := clHighLightText;\r\nend;\r\n\r\nprocedure TSynSelectedColor.Assign(Source: TPersistent);\r\nvar\r\n Src: TSynSelectedColor;\r\nbegin\r\n if (Source <> nil) and (Source is TSynSelectedColor) then begin\r\n Src := TSynSelectedColor(Source);\r\n fBG := Src.fBG;\r\n fFG := Src.fFG;\r\n if Assigned(fOnChange) then fOnChange(Self);\r\n end else\r\n inherited Assign(Source);\r\nend;\r\n\r\nprocedure TSynSelectedColor.SetBG(Value: TColor);\r\nbegin\r\n if (fBG <> Value) then begin\r\n fBG := Value;\r\n if Assigned(fOnChange) then fOnChange(Self);\r\n end;\r\nend;\r\n\r\nprocedure TSynSelectedColor.SetFG(Value: TColor);\r\nbegin\r\n if (fFG <> Value) then begin\r\n fFG := Value;\r\n if Assigned(fOnChange) then fOnChange(Self);\r\n end;\r\nend;\r\n\r\n{ TSynGutter }\r\n\r\nconstructor TSynGutter.Create;\r\nbegin\r\n inherited Create;\r\n fFont := TFont.Create;\r\n fFont.Name := 'Courier New';\r\n fFont.Size := 8;\r\n fFont.Style := [];\r\n fUseFontStyle := True;\r\n fFont.OnChange := OnFontChange;\r\n\r\n fColor := clBtnFace;\r\n fVisible := TRUE;\r\n fWidth := 30;\r\n fLeftOffset := 16;\r\n fDigitCount := 4;\r\n fAutoSizeDigitCount := fDigitCount;\r\n fRightOffset := 2;\r\n fBorderColor := clWindow;\r\n fBorderStyle := gbsMiddle;\r\n fLineNumberStart := 1;\r\n fZeroStart := False;\r\n fGradient := False;\r\n fGradientStartColor := clWindow;\r\n fGradientEndColor := clBtnFace;\r\n fGradientSteps := 48;\r\nend;\r\n\r\ndestructor TSynGutter.Destroy;\r\nbegin\r\n fFont.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TSynGutter.Assign(Source: TPersistent);\r\nvar\r\n Src: TSynGutter;\r\nbegin\r\n if Assigned(Source) and (Source is TSynGutter) then \r\n begin\r\n Src := TSynGutter(Source);\r\n fFont.Assign(src.Font);\r\n fUseFontStyle := src.fUseFontStyle;\r\n fColor := Src.fColor;\r\n fVisible := Src.fVisible;\r\n fWidth := Src.fWidth;\r\n fShowLineNumbers := Src.fShowLineNumbers;\r\n fLeadingZeros := Src.fLeadingZeros;\r\n fZeroStart := Src.fZeroStart;\r\n fLeftOffset := Src.fLeftOffset;\r\n fDigitCount := Src.fDigitCount;\r\n fRightOffset := Src.fRightOffset;\r\n fAutoSize := Src.fAutoSize;\r\n fAutoSizeDigitCount := Src.fAutoSizeDigitCount;\r\n fLineNumberStart := Src.fLineNumberStart;\r\n fBorderColor := Src.fBorderColor;\r\n fBorderStyle := Src.fBorderStyle;\r\n fGradient := Src.fGradient;\r\n fGradientStartColor := Src.fGradientStartColor;\r\n fGradientEndColor := Src.fGradientEndColor;\r\n fGradientSteps := Src.fGradientSteps;\r\n if Assigned(fOnChange) then fOnChange(Self);\r\n end \r\n else\r\n inherited;\r\nend;\r\n\r\nprocedure TSynGutter.AutoSizeDigitCount(LinesCount: integer);\r\nvar\r\n nDigits: integer;\r\nbegin\r\n if fVisible and fAutoSize and fShowLineNumbers then \r\n begin\r\n if fZeroStart then\r\n Dec(LinesCount)\r\n else if fLineNumberStart > 1 then\r\n Inc(LinesCount, fLineNumberStart - 1);\r\n\r\n nDigits := Max(Length(IntToStr(LinesCount)), fDigitCount);\r\n if fAutoSizeDigitCount <> nDigits then begin\r\n fAutoSizeDigitCount := nDigits;\r\n if Assigned(fOnChange) then fOnChange(Self);\r\n end;\r\n end else\r\n fAutoSizeDigitCount := fDigitCount;\r\nend;\r\n\r\nfunction TSynGutter.FormatLineNumber(Line: integer): string;\r\nvar\r\n i: integer;\r\nbegin\r\n if fZeroStart then\r\n Dec(Line)\r\n else if fLineNumberStart > 1 then\r\n Inc(Line, fLineNumberStart - 1);\r\n Result := Format('%*d', [fAutoSizeDigitCount, Line]);\r\n if fLeadingZeros then\r\n for i := 1 to fAutoSizeDigitCount - 1 do begin\r\n if (Result[i] <> ' ') then break;\r\n Result[i] := '0';\r\n end;\r\nend;\r\n\r\nfunction TSynGutter.RealGutterWidth(CharWidth: integer): integer;\r\nbegin\r\n if not fVisible then\r\n Result := 0\r\n else if fShowLineNumbers then\r\n Result := fLeftOffset + fRightOffset + fAutoSizeDigitCount * CharWidth + 2\r\n else\r\n Result := fWidth;\r\nend;\r\n\r\nprocedure TSynGutter.SetAutoSize(const Value: boolean);\r\nbegin\r\n if fAutoSize <> Value then begin\r\n fAutoSize := Value;\r\n if Assigned(fOnChange) then fOnChange(Self);\r\n end;\r\nend;\r\n\r\nprocedure TSynGutter.SetColor(const Value: TColor);\r\nbegin\r\n if fColor <> Value then begin\r\n fColor := Value;\r\n if Assigned(fOnChange) then fOnChange(Self);\r\n end;\r\nend;\r\n\r\nprocedure TSynGutter.SetFont(Value: TFont);\r\nbegin\r\n fFont.Assign(Value);\r\nend;\r\n\r\nprocedure TSynGutter.OnFontChange(Sender: TObject);\r\nbegin\r\n if Assigned(fOnChange) then fOnChange(Self);\r\nend;\r\n\r\nprocedure TSynGutter.SetDigitCount(Value: integer);\r\nbegin\r\n Value := MinMax(Value, 2, 12);\r\n if fDigitCount <> Value then begin\r\n fDigitCount := Value;\r\n fAutoSizeDigitCount := fDigitCount;\r\n if Assigned(fOnChange) then fOnChange(Self);\r\n end;\r\nend;\r\n\r\nprocedure TSynGutter.SetLeadingZeros(const Value: boolean);\r\nbegin\r\n if fLeadingZeros <> Value then begin\r\n fLeadingZeros := Value;\r\n if Assigned(fOnChange) then fOnChange(Self);\r\n end;\r\nend;\r\n\r\nprocedure TSynGutter.SetLeftOffset(Value: integer);\r\nbegin\r\n Value := Max(0, Value);\r\n if fLeftOffset <> Value then begin\r\n fLeftOffset := Value;\r\n if Assigned(fOnChange) then fOnChange(Self);\r\n end;\r\nend;\r\n\r\nprocedure TSynGutter.SetRightOffset(Value: integer);\r\nbegin\r\n Value := Max(0, Value);\r\n if fRightOffset <> Value then begin\r\n fRightOffset := Value;\r\n if Assigned(fOnChange) then fOnChange(Self);\r\n end;\r\nend;\r\n\r\nprocedure TSynGutter.SetShowLineNumbers(const Value: boolean);\r\nbegin\r\n if fShowLineNumbers <> Value then begin\r\n fShowLineNumbers := Value;\r\n if Assigned(fOnChange) then fOnChange(Self);\r\n end;\r\nend;\r\n\r\nprocedure TSynGutter.SetUseFontStyle(Value: boolean);\r\nbegin\r\n if fUseFontStyle <> Value then begin\r\n fUseFontStyle := Value;\r\n if Assigned(fOnChange) then fOnChange(Self);\r\n end;\r\nend;\r\n\r\nprocedure TSynGutter.SetVisible(Value: boolean);\r\nbegin\r\n if fVisible <> Value then begin\r\n fVisible := Value;\r\n if Assigned(fOnChange) then fOnChange(Self);\r\n end;\r\nend;\r\n\r\nprocedure TSynGutter.SetWidth(Value: integer);\r\nbegin\r\n Value := Max(0, Value);\r\n if fWidth <> Value then begin\r\n fWidth := Value;\r\n if Assigned(fOnChange) then fOnChange(Self);\r\n end;\r\nend;\r\n\r\nprocedure TSynGutter.SetZeroStart(const Value: boolean);\r\nbegin\r\n if fZeroStart <> Value then begin\r\n fZeroStart := Value;\r\n if Assigned(fOnChange) then fOnChange(Self);\r\n end;\r\nend;\r\n\r\nprocedure TSynGutter.SetBorderStyle(const Value: TSynGutterBorderStyle);\r\nbegin\r\n fBorderStyle := Value;\r\n if Assigned(fOnChange) then fOnChange(Self);\r\nend;\r\n\r\nprocedure TSynGutter.SetLineNumberStart(const Value: Integer);\r\nbegin\r\n if Value <> fLineNumberStart then\r\n begin\r\n fLineNumberStart := Value;\r\n if fLineNumberStart < 0 then\r\n fLineNumberStart := 0;\r\n if fLineNumberStart = 0 then\r\n fZeroStart := True\r\n else\r\n fZeroStart := False;\r\n if Assigned(fOnChange) then fOnChange(Self);\r\n end;\r\nend;\r\n\r\nprocedure TSynGutter.SetBorderColor(const Value: TColor);\r\nbegin\r\n if fBorderColor <> Value then \r\n begin\r\n fBorderColor := Value;\r\n if Assigned(fOnChange) then fOnChange(Self);\r\n end;\r\nend;\r\n\r\nprocedure TSynGutter.SetGradient(const Value: Boolean);\r\nbegin\r\n if Value <> fGradient then\r\n begin\r\n fGradient := Value;\r\n if Assigned(fOnChange) then fOnChange(Self);\r\n end;\r\nend;\r\n\r\nprocedure TSynGutter.SetGradientEndColor(const Value: TColor);\r\nbegin\r\n if Value <> fGradientEndColor then\r\n begin\r\n fGradientEndColor := Value;\r\n if Assigned(fOnChange) then fOnChange(Self);\r\n end;\r\nend;\r\n\r\nprocedure TSynGutter.SetGradientStartColor(const Value: TColor);\r\nbegin\r\n if Value <> fGradientStartColor then\r\n begin\r\n fGradientStartColor := Value;\r\n if Assigned(fOnChange) then fOnChange(Self);\r\n end;\r\nend;\r\n\r\nprocedure TSynGutter.SetGradientSteps(const Value: Integer);\r\nbegin\r\n if Value <> fGradientSteps then\r\n begin\r\n fGradientSteps := Value;\r\n if fGradientSteps < 2 then\r\n fGradientSteps := 2;\r\n if Assigned(fOnChange) then fOnChange(Self);\r\n end;\r\nend;\r\n\r\nfunction TSynGutter.GetWidth: integer;\r\nbegin\r\n if not Visible then\r\n Result := 0\r\n else\r\n Result := fWidth;\r\nend;\r\n\r\n{ TSynBookMarkOpt }\r\n\r\nconstructor TSynBookMarkOpt.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create;\r\n fDrawBookmarksFirst := TRUE;\r\n fEnableKeys := True;\r\n fGlyphsVisible := True;\r\n fLeftMargin := 2;\r\n fOwner := AOwner;\r\n fXOffset := 12;\r\nend;\r\n\r\nprocedure TSynBookMarkOpt.Assign(Source: TPersistent);\r\nvar\r\n Src: TSynBookMarkOpt;\r\nbegin\r\n if (Source <> nil) and (Source is TSynBookMarkOpt) then begin\r\n Src := TSynBookMarkOpt(Source);\r\n fBookmarkImages := Src.fBookmarkImages;\r\n fDrawBookmarksFirst := Src.fDrawBookmarksFirst;\r\n fEnableKeys := Src.fEnableKeys;\r\n fGlyphsVisible := Src.fGlyphsVisible;\r\n fLeftMargin := Src.fLeftMargin;\r\n fXoffset := Src.fXoffset;\r\n if Assigned(fOnChange) then fOnChange(Self);\r\n end else\r\n inherited Assign(Source);\r\nend;\r\n\r\nprocedure TSynBookMarkOpt.SetBookmarkImages(const Value: TImageList);\r\nbegin\r\n if fBookmarkImages <> Value then begin\r\n fBookmarkImages := Value;\r\n if Assigned(fBookmarkImages) then fBookmarkImages.FreeNotification(fOwner);\r\n if Assigned(fOnChange) then fOnChange(Self);\r\n end;\r\nend;\r\n\r\nprocedure TSynBookMarkOpt.SetDrawBookmarksFirst(Value: boolean);\r\nbegin\r\n if Value <> fDrawBookmarksFirst then begin\r\n fDrawBookmarksFirst := Value;\r\n if Assigned(fOnChange) then fOnChange(Self);\r\n end;\r\nend;\r\n\r\nprocedure TSynBookMarkOpt.SetGlyphsVisible(Value: Boolean);\r\nbegin\r\n if fGlyphsVisible <> Value then begin\r\n fGlyphsVisible := Value;\r\n if Assigned(fOnChange) then fOnChange(Self);\r\n end;\r\nend;\r\n\r\nprocedure TSynBookMarkOpt.SetLeftMargin(Value: Integer);\r\nbegin\r\n if fLeftMargin <> Value then begin\r\n fLeftMargin := Value;\r\n if Assigned(fOnChange) then fOnChange(Self);\r\n end;\r\nend;\r\n\r\nprocedure TSynBookMarkOpt.SetXOffset(Value: integer);\r\nbegin\r\n if fXOffset <> Value then begin\r\n fXOffset := Value;\r\n if Assigned(fOnChange) then fOnChange(Self);\r\n end;\r\nend;\r\n\r\n{ TSynGlyph }\r\n\r\nconstructor TSynGlyph.Create(aModule: THandle; const aName: string; aMaskColor: TColor);\r\nbegin\r\n inherited Create;\r\n\r\n if aName <> '' then\r\n begin\r\n fInternalGlyph := TBitmap.Create;\r\n fInternalGlyph.LoadFromResourceName(aModule, aName);\r\n fInternalMaskColor := aMaskColor;\r\n end\r\n else\r\n fInternalMaskColor := clNone;\r\n\r\n fVisible := True;\r\n fGlyph := TBitmap.Create;\r\n fGlyph.OnChange := GlyphChange;\r\n fMaskColor := clNone;\r\nend;\r\n\r\ndestructor TSynGlyph.Destroy;\r\nbegin\r\n if Assigned(fInternalGlyph) then\r\n FreeAndNil(fInternalGlyph);\r\n\r\n fGlyph.Free;\r\n\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TSynGlyph.Assign(aSource: TPersistent);\r\nvar\r\n vSrc : TSynGlyph;\r\nbegin\r\n if Assigned(aSource) and (aSource is TSynGlyph) then\r\n begin\r\n vSrc := TSynGlyph(aSource);\r\n fInternalGlyph := vSrc.fInternalGlyph;\r\n fInternalMaskColor := vSrc.fInternalMaskColor;\r\n fVisible := vSrc.fVisible;\r\n fGlyph := vSrc.fGlyph;\r\n fMaskColor := vSrc.fMaskColor;\r\n if Assigned(fOnChange) then fOnChange(Self);\r\n end\r\n else\r\n inherited;\r\nend;\r\n\r\nprocedure TSynGlyph.Draw(aCanvas: TCanvas; aX, aY, aLineHeight: integer);\r\nvar\r\n rcSrc, rcDest : TRect;\r\n vGlyph : TBitmap;\r\n vMaskColor : TColor;\r\nbegin\r\n if not fGlyph.Empty then\r\n begin\r\n vGlyph := fGlyph;\r\n vMaskColor := fMaskColor;\r\n end\r\n else if Assigned(fInternalGlyph) then\r\n begin\r\n vGlyph := fInternalGlyph;\r\n vMaskColor := fInternalMaskColor;\r\n end\r\n else\r\n Exit;\r\n\r\n if aLineHeight >= vGlyph.Height then\r\n begin\r\n rcSrc := Rect(0, 0, vGlyph.Width, vGlyph.Height);\r\n Inc(aY, (aLineHeight - vGlyph.Height) div 2);\r\n rcDest := Rect(aX, aY, aX + vGlyph.Width, aY + vGlyph.Height);\r\n end\r\n else\r\n begin\r\n rcDest := Rect(aX, aY, aX + vGlyph.Width, aY + aLineHeight);\r\n aY := (vGlyph.Height - aLineHeight) div 2;\r\n rcSrc := Rect(0, aY, vGlyph.Width, aY + aLineHeight);\r\n end;\r\n\r\n{$IFDEF SYN_CLX}\r\n if vMaskColor = clNone then\r\n vGlyph.Transparent := False\r\n else begin\r\n vGlyph.TransparentColor := vMaskColor;\r\n vGlyph.Transparent := True;\r\n end;\r\n aCanvas.CopyRect(rcDest, vGlyph.Canvas, rcSrc);\r\n{$ELSE}\r\n aCanvas.BrushCopy(rcDest, vGlyph, rcSrc, vMaskColor);\r\n{$ENDIF}\r\nend;\r\n\r\nprocedure TSynGlyph.SetGlyph(Value: TBitmap);\r\nbegin\r\n fGlyph.Assign(Value);\r\nend;\r\n\r\nprocedure TSynGlyph.GlyphChange(Sender: TObject);\r\nbegin\r\n if Assigned(fOnChange) then fOnChange(Self);\r\nend;\r\n\r\nprocedure TSynGlyph.SetMaskColor(Value: TColor);\r\nbegin\r\n if fMaskColor <> Value then\r\n begin\r\n fMaskColor := Value;\r\n if Assigned(fOnChange) then fOnChange(Self);\r\n end;\r\nend;\r\n\r\nprocedure TSynGlyph.SetVisible(Value: boolean);\r\nbegin\r\n if fVisible <> Value then\r\n begin\r\n fVisible := Value;\r\n if Assigned(fOnChange) then fOnChange(Self);\r\n end;\r\nend;\r\n\r\nfunction TSynGlyph.GetWidth : integer;\r\nbegin\r\n if not fGlyph.Empty then\r\n Result := fGlyph.Width\r\n else\r\n if Assigned(fInternalGlyph) then\r\n Result := fInternalGlyph.Width\r\n else\r\n Result := 0;\r\nend;\r\n\r\nfunction TSynGlyph.GetHeight : integer;\r\nbegin\r\n if not fGlyph.Empty then\r\n Result := fGlyph.Height\r\n else\r\n if Assigned(fInternalGlyph) then\r\n Result := fInternalGlyph.Height\r\n else\r\n Result := 0;\r\nend;\r\n\r\n{ TSynMethodChain }\r\n\r\nprocedure TSynMethodChain.Add(AEvent: TMethod);\r\nbegin\r\n if not Assigned(@AEvent) then\r\n raise ESynMethodChain.CreateFmt(\r\n '%s.Entry : the parameter `AEvent'' must be specified.', [ClassName]);\r\n\r\n with FNotifyProcs, AEvent do\r\n begin\r\n Add(Code);\r\n Add(Data);\r\n end\r\nend;\r\n\r\nconstructor TSynMethodChain.Create;\r\nbegin\r\n inherited;\r\n FNotifyProcs := TList.Create;\r\nend;\r\n\r\ndestructor TSynMethodChain.Destroy;\r\nbegin\r\n FNotifyProcs.Free;\r\n inherited;\r\nend;\r\n\r\nfunction TSynMethodChain.DoHandleException(E: Exception): Boolean;\r\nbegin\r\n if not Assigned(FExceptionHandler) then\r\n raise E\r\n else\r\n try\r\n Result := True;\r\n FExceptionHandler(Self, E, Result);\r\n except\r\n raise ESynMethodChain.CreateFmt(\r\n '%s.DoHandleException : MUST NOT occur any kind of exception in '+\r\n 'ExceptionHandler', [ClassName]);\r\n end;\r\nend;\r\n\r\nprocedure TSynMethodChain.Fire;\r\nvar\r\n AMethod: TMethod;\r\n i: Integer;\r\nbegin\r\n i := 0;\r\n with FNotifyProcs, AMethod do\r\n while i < Count do\r\n try\r\n repeat\r\n Code := Items[i];\r\n Inc(i);\r\n Data := Items[i];\r\n Inc(i);\r\n\r\n DoFire(AMethod)\r\n until i >= Count;\r\n except\r\n on E: Exception do\r\n if not DoHandleException(E) then\r\n i := MaxInt;\r\n end;\r\nend;\r\n\r\nprocedure TSynMethodChain.Remove(AEvent: TMethod);\r\nvar\r\n i: Integer;\r\nbegin\r\n if not Assigned(@AEvent) then\r\n raise ESynMethodChain.CreateFmt(\r\n '%s.Remove: the parameter `AEvent'' must be specified.', [ClassName]);\r\n\r\n with FNotifyProcs, AEvent do\r\n begin\r\n i := Count - 1;\r\n while i > 0 do\r\n if Items[i] <> Data then\r\n Dec(i, 2)\r\n else\r\n begin\r\n Dec(i);\r\n if Items[i] = Code then\r\n begin\r\n Delete(i);\r\n Delete(i);\r\n end;\r\n Dec(i);\r\n end;\r\n end;\r\nend;\r\n\r\n{ TSynNotifyEventChain }\r\n\r\nprocedure TSynNotifyEventChain.Add(AEvent: TNotifyEvent);\r\nbegin\r\n inherited Add(TMethod(AEvent));\r\nend;\r\n\r\nconstructor TSynNotifyEventChain.CreateEx(ASender: TObject);\r\nbegin\r\n inherited Create;\r\n FSender := ASender;\r\nend;\r\n\r\nprocedure TSynNotifyEventChain.DoFire(const AEvent: TMethod);\r\nbegin\r\n TNotifyEvent(AEvent)(FSender);\r\nend;\r\n\r\nprocedure TSynNotifyEventChain.Remove(AEvent: TNotifyEvent);\r\nbegin\r\n inherited Remove(TMethod(AEvent));\r\nend;\r\n\r\n\r\n{ TSynInternalImage }\r\n\r\ntype\r\n TInternalResource = class (TObject)\r\n public\r\n UsageCount : Integer;\r\n Name : string;\r\n Bitmap : TBitmap;\r\n end;\r\n\r\nvar\r\n InternalResources: TList;\r\n\r\nconstructor TSynInternalImage.Create(aModule: THandle; const Name: string; Count: integer);\r\nbegin\r\n inherited Create;\r\n fImages := CreateBitmapFromInternalList( aModule, Name );\r\n fWidth := (fImages.Width + Count shr 1) div Count;\r\n fHeight := fImages.Height;\r\n fCount := Count;\r\n end;\r\n\r\ndestructor TSynInternalImage.Destroy;\r\nbegin\r\n FreeBitmapFromInternalList;\r\n inherited Destroy;\r\nend;\r\n\r\nfunction TSynInternalImage.CreateBitmapFromInternalList(aModule: THandle;\r\n const Name: string): TBitmap;\r\nvar\r\n idx: Integer;\r\n newIntRes: TInternalResource;\r\nbegin\r\n { There is no list until now }\r\n if (InternalResources = nil) then\r\n InternalResources := TList.Create;\r\n\r\n { Search the list for the needed resource }\r\n for idx := 0 to InternalResources.Count - 1 do\r\n if (TInternalResource(InternalResources[idx]).Name = UpperCase(Name)) then\r\n with TInternalResource(InternalResources[idx]) do begin\r\n UsageCount := UsageCount + 1;\r\n Result := Bitmap;\r\n exit;\r\n end;\r\n\r\n { There is no loaded resource in the list so let's create a new one }\r\n Result := TBitmap.Create;\r\n Result.LoadFromResourceName(aModule, Name);\r\n\r\n { Add the new resource to our list }\r\n newIntRes:= TInternalResource.Create;\r\n newIntRes.UsageCount := 1;\r\n newIntRes.Name := UpperCase(Name);\r\n newIntRes.Bitmap := Result;\r\n InternalResources.Add(newIntRes);\r\nend;\r\n\r\nprocedure TSynInternalImage.FreeBitmapFromInternalList;\r\nvar\r\n idx: Integer;\r\n intRes: TInternalResource;\r\n function FindImageInList: Integer;\r\n begin\r\n for Result := 0 to InternalResources.Count - 1 do\r\n if (TInternalResource (InternalResources[Result]).Bitmap = fImages) then\r\n exit;\r\n Result := -1;\r\n end;\r\nbegin\r\n { Search the index of our resource in the list }\r\n idx := FindImageInList;\r\n\r\n { Ey, what's this ???? }\r\n if (idx = -1) then\r\n exit;\r\n\r\n { Decrement the usagecount in the object. If there are no more users\r\n remove the object from the list and free it }\r\n intRes := TInternalResource (InternalResources[idx]);\r\n with intRes do begin\r\n UsageCount := UsageCount - 1;\r\n if (UsageCount = 0) then begin\r\n Bitmap.Free;\r\n InternalResources.Delete (idx);\r\n intRes.Free;\r\n end;\r\n end;\r\n\r\n { If there are no more entries in the list free it }\r\n if (InternalResources.Count = 0) then begin\r\n InternalResources.Free;\r\n InternalResources := nil;\r\n end;\r\nend;\r\n\r\nprocedure TSynInternalImage.Draw(ACanvas: TCanvas;\r\n Number, X, Y, LineHeight: integer);\r\nvar\r\n rcSrc, rcDest: TRect;\r\nbegin\r\n if (Number >= 0) and (Number < fCount) then\r\n begin\r\n if LineHeight >= fHeight then begin\r\n rcSrc := Rect(Number * fWidth, 0, (Number + 1) * fWidth, fHeight);\r\n Inc(Y, (LineHeight - fHeight) div 2);\r\n rcDest := Rect(X, Y, X + fWidth, Y + fHeight);\r\n end else begin\r\n rcDest := Rect(X, Y, X + fWidth, Y + LineHeight);\r\n Y := (fHeight - LineHeight) div 2;\r\n rcSrc := Rect(Number * fWidth, Y, (Number + 1) * fWidth,\r\n Y + LineHeight);\r\n end;\r\n ACanvas.CopyRect(rcDest, fImages.Canvas, rcSrc);\r\n end;\r\nend;\r\n\r\nprocedure TSynInternalImage.DrawTransparent(ACanvas: TCanvas; Number, X, Y,\r\n LineHeight: integer; TransparentColor: TColor);\r\nvar\r\n rcSrc, rcDest: TRect;\r\nbegin\r\n if (Number >= 0) and (Number < fCount) then\r\n begin\r\n if LineHeight >= fHeight then begin\r\n rcSrc := Rect(Number * fWidth, 0, (Number + 1) * fWidth, fHeight);\r\n Inc(Y, (LineHeight - fHeight) div 2);\r\n rcDest := Rect(X, Y, X + fWidth, Y + fHeight);\r\n end else begin\r\n rcDest := Rect(X, Y, X + fWidth, Y + LineHeight);\r\n Y := (fHeight - LineHeight) div 2;\r\n rcSrc := Rect(Number * fWidth, Y, (Number + 1) * fWidth,\r\n Y + LineHeight);\r\n end;\r\n{$IFDEF SYN_CLX}\r\n ACanvas.CopyMode := cmMergeCopy;\r\n ACanvas.CopyRect(rcDest, fImages.Canvas, rcSrc);\r\n{$ELSE}\r\n ACanvas.BrushCopy(rcDest, fImages, rcSrc, TransparentColor);\r\n{$ENDIF}\r\n end;\r\nend;\r\n\r\n{ TSynHotKey }\r\n\r\nfunction KeySameAsShiftState(Key: Word; Shift: TShiftState): Boolean;\r\nbegin\r\n Result := (Key = SYNEDIT_SHIFT) and (ssShift in Shift) or\r\n (Key = SYNEDIT_CONTROL) and (ssCtrl in Shift) or\r\n (Key = SYNEDIT_MENU) and (ssAlt in Shift);\r\nend;\r\n\r\nfunction ModifiersToShiftState(Modifiers: THKModifiers): TShiftState;\r\nbegin\r\n Result := [];\r\n if hkShift in Modifiers then Include(Result, ssShift);\r\n if hkCtrl in Modifiers then Include(Result, ssCtrl);\r\n if hkAlt in Modifiers then Include(Result, ssAlt);\r\nend;\r\n\r\nfunction ShiftStateToTHKInvalidKey(Shift: TShiftState): THKInvalidKey;\r\nbegin\r\n Shift := Shift * [ssShift, ssAlt, ssCtrl];\r\n if Shift = [ssShift] then\r\n Result := hcShift\r\n else if Shift = [ssCtrl] then\r\n Result := hcCtrl\r\n else if Shift = [ssAlt] then\r\n Result := hcAlt\r\n else if Shift = [ssShift, ssCtrl] then\r\n Result := hcShiftCtrl\r\n else if Shift = [ssShift, ssAlt] then\r\n Result := hcShiftAlt\r\n else if Shift = [ssCtrl, ssAlt] then\r\n Result := hcCtrlAlt\r\n else if Shift = [ssShift, ssCtrl, ssAlt] then\r\n Result := hcShiftCtrlAlt\r\n else\r\n Result := hcNone;\r\nend;\r\n\r\nfunction ShortCutToTextEx(Key: Word; Shift: TShiftState): UnicodeString;\r\nbegin\r\n if ssCtrl in Shift then Result := SmkcCtrl;\r\n if ssShift in Shift then Result := Result + SmkcShift;\r\n if ssAlt in Shift then Result := Result + SmkcAlt;\r\n\r\n {$IFDEF SYN_CLX}\r\n if Lo(Key) > Ord('Z') then\r\n Result := Result + Chr(Key)\r\n else\r\n {$ENDIF}\r\n Result := Result + ShortCutToText(TShortCut(Key));\r\n if Result = '' then\r\n Result := srNone;\r\nend;\r\n\r\nconstructor TSynHotKey.Create(AOwner: TComponent);\r\nbegin\r\n inherited;\r\n {$IFDEF SYN_CLX}\r\n InputKeys := [ikAll];\r\n {$ENDIF}\r\n\r\n BorderStyle := bsSingle;\r\n {$IFNDEF SYN_CLX}\r\n {$IFDEF SYN_COMPILER_7_UP}\r\n ControlStyle := ControlStyle + [csNeedsBorderPaint];\r\n {$ENDIF}\r\n {$ENDIF}\r\n\r\n FInvalidKeys := [hcNone, hcShift];\r\n FModifiers := [hkAlt];\r\n SetHotKey($0041); { Alt+A }\r\n\r\n ParentColor := False;\r\n Color := clWindow;\r\n TabStop := True;\r\nend;\r\n\r\n{$IFNDEF SYN_CLX}\r\nprocedure TSynHotKey.CreateParams(var Params: TCreateParams);\r\nconst\r\n BorderStyles: array[TSynBorderStyle] of DWORD = (0, WS_BORDER);\r\n ClassStylesOff = CS_VREDRAW or CS_HREDRAW;\r\nbegin\r\n inherited CreateParams(Params);\r\n with Params do\r\n begin\r\n WindowClass.Style := WindowClass.Style and not ClassStylesOff;\r\n Style := Style or BorderStyles[fBorderStyle] or WS_CLIPCHILDREN;\r\n\r\n if NewStyleControls and Ctl3D and (fBorderStyle = bsSingle) then\r\n begin\r\n Style := Style and not WS_BORDER;\r\n ExStyle := ExStyle or WS_EX_CLIENTEDGE;\r\n end;\r\n end;\r\nend;\r\n{$ENDIF}\r\n\r\nprocedure TSynHotKey.DoExit;\r\nbegin\r\n inherited;\r\n if FPressedOnlyModifiers then\r\n begin\r\n Text := srNone;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\n{$IFDEF SYN_CLX}\r\nfunction TSynHotKey.EventFilter(Sender: QObjectH; Event: QEventH): Boolean;\r\nbegin\r\n Result := inherited EventFilter(Sender, Event);\r\n case QEvent_type(Event) of\r\n QEventType_FocusIn:\r\n begin\r\n Canvas.Font := Font;\r\n CreateCaret(Self, 0, 1, TextHeight(Canvas, 'x') + 2);\r\n SetCaretPos(BorderWidth + 1 + TextWidth(Canvas, Text), BorderWidth + 1);\r\n ShowCaret(Self);\r\n end;\r\n QEventType_FocusOut:\r\n begin\r\n DestroyCaret;\r\n end;\r\n end;\r\nend;\r\n{$ENDIF}\r\n\r\nprocedure TSynHotKey.KeyDown(var Key: Word; Shift: TShiftState);\r\nvar\r\n MaybeInvalidKey: THKInvalidKey;\r\n SavedKey: Word;\r\n {$IFDEF SYN_LINUX}\r\n Code: Byte;\r\n {$ENDIF}\r\nbegin\r\n {$IFDEF SYN_LINUX}\r\n // uniform Keycode: key has the same value wether Shift is pressed or not\r\n if Key <= 255 then\r\n begin\r\n Code := XKeysymToKeycode(Xlib.PDisplay(QtDisplay), Key);\r\n Key := XKeycodeToKeysym(Xlib.PDisplay(QtDisplay), Code, 0);\r\n if AnsiChar(Key) in ['a'..'z'] then Key := Ord(UpCase(AnsiChar(Key)));\r\n end;\r\n {$ENDIF}\r\n \r\n SavedKey := Key;\r\n FPressedOnlyModifiers := KeySameAsShiftState(Key, Shift);\r\n\r\n MaybeInvalidKey := ShiftStateToTHKInvalidKey(Shift);\r\n if MaybeInvalidKey in FInvalidKeys then\r\n Shift := ModifiersToShiftState(FModifiers);\r\n\r\n if not FPressedOnlyModifiers then\r\n begin\r\n {$IFDEF SYN_CLX}\r\n if Lo(Key) > Ord('Z') then\r\n Key := Lo(Key);\r\n {$ENDIF}\r\n FHotKey := ShortCut(Key, Shift)\r\n end\r\n else\r\n begin\r\n FHotKey := 0;\r\n Key := 0;\r\n end;\r\n\r\n if Text <> ShortCutToTextEx(Key, Shift) then\r\n begin\r\n Text := ShortCutToTextEx(Key, Shift);\r\n Invalidate;\r\n SetCaretPos(BorderWidth + 1 + TextWidth(Canvas, Text), BorderWidth + 1);\r\n end;\r\n\r\n Key := SavedKey;\r\nend;\r\n\r\nprocedure TSynHotKey.KeyUp(var Key: Word; Shift: TShiftState);\r\n{$IFDEF SYN_LINUX}\r\nvar\r\n Code: Byte;\r\n{$ENDIF}\r\nbegin\r\n {$IFDEF SYN_LINUX}\r\n // uniform Keycode: key has the same value wether Shift is pressed or not\r\n if Key <= 255 then\r\n begin\r\n Code := XKeysymToKeycode(Xlib.PDisplay(QtDisplay), Key);\r\n Key := XKeycodeToKeysym(Xlib.PDisplay(QtDisplay), Code, 0);\r\n if AnsiChar(Key) in ['a'..'z'] then Key := Ord(UpCase(AnsiChar(Key)));\r\n end;\r\n {$ENDIF}\r\n \r\n if FPressedOnlyModifiers then\r\n begin\r\n Text := srNone;\r\n Invalidate;\r\n SetCaretPos(BorderWidth + 1 + TextWidth(Canvas, Text), BorderWidth + 1);\r\n end;\r\nend;\r\n\r\nprocedure TSynHotKey.MouseDown(Button: TMouseButton; Shift: TShiftState; X,\r\n Y: Integer);\r\nbegin\r\n inherited;\r\n SetFocus;\r\nend;\r\n\r\nprocedure TSynHotKey.Paint;\r\nvar\r\n r: TRect;\r\nbegin\r\n r := ClientRect;\r\n \r\n {$IFDEF SYN_CLX}\r\n QClxDrawUtil_DrawWinPanel(Canvas.Handle, @r, Palette.ColorGroup(cgActive), True,\r\n QBrushH(0));\r\n {$ENDIF}\r\n\r\n Canvas.Brush.Style := bsSolid;\r\n Canvas.Brush.Color := Color;\r\n InflateRect(r, -BorderWidth, -BorderWidth);\r\n Canvas.FillRect(r);\r\n TextRect(Canvas, r, BorderWidth + 1, BorderWidth + 1, Text);\r\nend;\r\n\r\nprocedure TSynHotKey.SetBorderStyle(const Value: TSynBorderStyle);\r\nbegin\r\n if FBorderStyle <> Value then\r\n begin\r\n FBorderStyle := Value;\r\n{$IFDEF SYN_CLX}\r\n Resize;\r\n Invalidate;\r\n{$ELSE}\r\n RecreateWnd;\r\n{$ENDIF}\r\n end;\r\nend;\r\n\r\nprocedure TSynHotKey.SetHotKey(const Value: TShortCut);\r\nvar\r\n Key: Word;\r\n Shift: TShiftState;\r\n MaybeInvalidKey: THKInvalidKey;\r\nbegin\r\n ShortCutToKey(Value, Key, Shift);\r\n\r\n MaybeInvalidKey := ShiftStateToTHKInvalidKey(Shift);\r\n if MaybeInvalidKey in FInvalidKeys then\r\n Shift := ModifiersToShiftState(FModifiers);\r\n\r\n FHotKey := ShortCut(Key, Shift);\r\n Text := ShortCutToTextEx(Key, Shift);\r\n Invalidate;\r\n if not Visible then\r\n SetCaretPos(BorderWidth + 1 + TextWidth(Canvas, Text), BorderWidth + 1);\r\nend;\r\n\r\nprocedure TSynHotKey.SetInvalidKeys(const Value: THKInvalidKeys);\r\nbegin\r\n FInvalidKeys := Value;\r\n SetHotKey(FHotKey);\r\nend;\r\n\r\nprocedure TSynHotKey.SetModifiers(const Value: THKModifiers);\r\nbegin\r\n FModifiers := Value;\r\n SetHotKey(FHotKey);\r\nend;\r\n\r\n{$IFDEF SYN_CLX}\r\nfunction TSynHotKey.WidgetFlags: Integer;\r\nbegin\r\n Result := inherited WidgetFlags or Integer(WidgetFlags_WRepaintNoErase);\r\nend;\r\n{$ENDIF}\r\n\r\n{$IFNDEF SYN_CLX}\r\nprocedure TSynHotKey.WMGetDlgCode(var Message: TMessage);\r\nbegin\r\n Message.Result := DLGC_WANTTAB or DLGC_WANTARROWS;\r\nend;\r\n\r\nprocedure TSynHotKey.WMKillFocus(var Msg: TWMKillFocus);\r\nbegin\r\n DestroyCaret;\r\nend;\r\n\r\nprocedure TSynHotKey.WMSetFocus(var Msg: TWMSetFocus);\r\nbegin\r\n Canvas.Font := Font;\r\n CreateCaret(Handle, 0, 1, -Canvas.Font.Height + 2);\r\n SetCaretPos(BorderWidth + 1 + TextWidth(Canvas, Text), BorderWidth + 1);\r\n ShowCaret(Handle);\r\nend;\r\n{$ENDIF}\r\n\r\n\r\n{$IFNDEF SYN_CLX}\r\n {$IFNDEF SYN_COMPILER_4_UP}\r\n\r\n{ TBetterRegistry }\r\n\r\nfunction TBetterRegistry.OpenKeyReadOnly(const Key: string): Boolean;\r\n\r\n function IsRelative(const Value: string): Boolean;\r\n begin\r\n Result := not ((Value <> '') and (Value[1] = '\\'));\r\n end;\r\n\r\nvar\r\n TempKey: HKey;\r\n S: string;\r\n Relative: Boolean;\r\nbegin\r\n S := Key;\r\n Relative := IsRelative(S);\r\n\r\n if not Relative then Delete(S, 1, 1);\r\n TempKey := 0;\r\n Result := RegOpenKeyEx(GetBaseKey(Relative), PChar(S), 0,\r\n KEY_READ, TempKey) = ERROR_SUCCESS;\r\n if Result then\r\n begin\r\n if (CurrentKey <> 0) and Relative then S := CurrentPath + '\\' + S;\r\n ChangeKey(TempKey, S);\r\n end;\r\nend; { TBetterRegistry.OpenKeyReadOnly }\r\n\r\n {$ENDIF SYN_COMPILER_4_UP}\r\n{$ENDIF SYN_CLX}\r\n\r\nbegin\r\n InternalResources := nil;\r\nend.\r\n" }, { "path": "External/SynEdit/Source/SynEditMiscProcs.pas", "content": "{-------------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: SynEditMiscProcs.pas, released 2000-04-07.\r\nThe Original Code is based on the mwSupportProcs.pas file from the\r\nmwEdit component suite by Martin Waldenburg and other developers, the Initial\r\nAuthor of this file is Michael Hieke.\r\nUnicode translation by Mal Hrz.\r\nAll Rights Reserved.\r\n\r\nContributors to the SynEdit and mwEdit projects are listed in the\r\nContributors.txt file.\r\n\r\nAlternatively, the contents of this file may be used under the terms of the\r\nGNU General Public License Version 2 or later (the \"GPL\"), in which case\r\nthe provisions of the GPL are applicable instead of those above.\r\nIf you wish to allow use of your version of this file only under the terms\r\nof the GPL and not to allow others to use your version of this file\r\nunder the MPL, indicate your decision by deleting the provisions above and\r\nreplace them with the notice and other provisions required by the GPL.\r\nIf you do not delete the provisions above, a recipient may use your version\r\nof this file under either the MPL or the GPL.\r\n\r\n$Id: SynEditMiscProcs.pas,v 1.35.2.8 2009/09/28 17:54:20 maelh Exp $\r\n\r\nYou may retrieve the latest version of this file at the SynEdit home page,\r\nlocated at http://SynEdit.SourceForge.net\r\n\r\nKnown Issues:\r\n-------------------------------------------------------------------------------}\r\n\r\n{$IFNDEF QSYNEDITMISCPROCS}\r\nunit SynEditMiscProcs;\r\n{$ENDIF}\r\n\r\n{$I SynEdit.inc}\r\n\r\ninterface\r\n\r\nuses\r\n{$IFDEF SYN_CLX}\r\n Types,\r\n kTextDrawer,\r\n QGraphics,\r\n QSynEditTypes,\r\n QSynEditHighlighter,\r\n QSynUnicode,\r\n{$ELSE}\r\n Windows,\r\n Graphics,\r\n SynEditTypes,\r\n SynEditHighlighter,\r\n SynUnicode,\r\n{$ENDIF}\r\n{$IFDEF SYN_COMPILER_4_UP}\r\n Math,\r\n{$ENDIF}\r\n Classes;\r\n\r\nconst\r\n MaxIntArraySize = MaxInt div 16;\r\n\r\ntype\r\n PIntArray = ^TIntArray;\r\n TIntArray = array[0..MaxIntArraySize - 1] of Integer;\r\n\r\n{$IFNDEF SYN_COMPILER_4_UP}\r\nfunction Max(x, y: Integer): Integer;\r\nfunction Min(x, y: Integer): Integer;\r\n{$ENDIF}\r\n\r\nfunction MinMax(x, mi, ma: Integer): Integer;\r\nprocedure SwapInt(var l, r: Integer);\r\nfunction MaxPoint(const P1, P2: TPoint): TPoint;\r\nfunction MinPoint(const P1, P2: TPoint): TPoint;\r\n\r\nfunction GetIntArray(Count: Cardinal; InitialValue: integer): PIntArray;\r\n\r\n{$IFNDEF SYN_CLX}\r\nprocedure InternalFillRect(dc: HDC; const rcPaint: TRect);\r\n{$ENDIF}\r\n\r\n// Converting tabs to spaces: To use the function several times it's better\r\n// to use a function pointer that is set to the fastest conversion function.\r\ntype\r\n TConvertTabsProc = function(const Line: UnicodeString;\r\n TabWidth: Integer): UnicodeString;\r\n\r\nfunction GetBestConvertTabsProc(TabWidth: Integer): TConvertTabsProc;\r\n// This is the slowest conversion function which can handle TabWidth <> 2^n.\r\nfunction ConvertTabs(const Line: UnicodeString; TabWidth: Integer): UnicodeString;\r\n\r\ntype\r\n TConvertTabsProcEx = function(const Line: UnicodeString; TabWidth: Integer;\r\n var HasTabs: Boolean): UnicodeString;\r\n\r\nfunction GetBestConvertTabsProcEx(TabWidth: Integer): TConvertTabsProcEx;\r\n// This is the slowest conversion function which can handle TabWidth <> 2^n.\r\nfunction ConvertTabsEx(const Line: UnicodeString; TabWidth: Integer;\r\n var HasTabs: Boolean): UnicodeString;\r\n\r\nfunction GetExpandedLength(const aStr: UnicodeString; aTabWidth: Integer): Integer;\r\n\r\nfunction CharIndex2CaretPos(Index, TabWidth: Integer;\r\n const Line: UnicodeString): Integer;\r\nfunction CaretPos2CharIndex(Position, TabWidth: Integer; const Line: UnicodeString;\r\n var InsideTabChar: Boolean): Integer;\r\n\r\n// search for the first char of set AChars in Line, starting at index Start\r\nfunction StrScanForCharInCategory(const Line: UnicodeString; Start: Integer;\r\n IsOfCategory: TCategoryMethod): Integer;\r\n// the same, but searching backwards\r\nfunction StrRScanForCharInCategory(const Line: UnicodeString; Start: Integer;\r\n IsOfCategory: TCategoryMethod): Integer;\r\n\r\nfunction GetEOL(Line: PWideChar): PWideChar;\r\n\r\n// Remove all '/' characters from string by changing them into '\\.'.\r\n// Change all '\\' characters into '\\\\' to allow for unique decoding.\r\nfunction EncodeString(s: UnicodeString): UnicodeString;\r\n\r\n// Decodes string, encoded with EncodeString.\r\nfunction DecodeString(s: UnicodeString): UnicodeString;\r\n\r\n{$IFNDEF SYN_COMPILER_5_UP}\r\nprocedure FreeAndNil(var Obj);\r\n{$ENDIF}\r\n\r\n{$IFNDEF SYN_COMPILER_3_UP}\r\nprocedure Assert(Expr: Boolean); { stub for Delphi 2 }\r\n{$ENDIF}\r\n\r\n{$IFNDEF SYN_COMPILER_3_UP}\r\nfunction LastDelimiter(const Delimiters, S: UnicodeString): Integer;\r\n{$ENDIF}\r\n\r\n{$IFNDEF SYN_COMPILER_4_UP}\r\ntype\r\n TReplaceFlags = set of (rfReplaceAll, rfIgnoreCase);\r\n\r\nfunction StringReplace(const S, OldPattern, NewPattern: UnicodeString;\r\n Flags: TReplaceFlags): UnicodeString;\r\n{$ENDIF}\r\n\r\n{$IFDEF SYN_CLX}\r\nfunction GetRValue(RGBValue: TColor): byte;\r\nfunction GetGValue(RGBValue: TColor): byte;\r\nfunction GetBValue(RGBValue: TColor): byte;\r\nfunction RGB(r, g, b: Byte): Cardinal;\r\n{$ENDIF}\r\n\r\ntype\r\n THighlighterAttriProc = function (Highlighter: TSynCustomHighlighter;\r\n Attri: TSynHighlighterAttributes; UniqueAttriName: string;\r\n Params: array of Pointer): Boolean of object;\r\n\r\n// Enums all child highlighters and their attributes of a TSynMultiSyn through a\r\n// callback function.\r\n// This function also handles nested TSynMultiSyns including their MarkerAttri.\r\nfunction EnumHighlighterAttris(Highlighter: TSynCustomHighlighter;\r\n SkipDuplicates: Boolean; HighlighterAttriProc: THighlighterAttriProc;\r\n Params: array of Pointer): Boolean;\r\n\r\n{$IFDEF SYN_HEREDOC}\r\n// Calculates Frame Check Sequence (FCS) 16-bit Checksum (as defined in RFC 1171)\r\nfunction CalcFCS(const ABuf; ABufSize: Cardinal): Word;\r\n{$ENDIF}\r\n\r\nprocedure SynDrawGradient(const ACanvas: TCanvas; const AStartColor, AEndColor: TColor;\r\n ASteps: Integer; const ARect: TRect; const AHorizontal: Boolean);\r\n\r\nfunction DeleteTypePrefixAndSynSuffix(S: string): string;\r\n\r\nimplementation\r\n\r\nuses\r\n SysUtils,\r\n {$IFDEF SYN_CLX}\r\n QSynHighlighterMulti;\r\n {$ELSE}\r\n SynHighlighterMulti;\r\n {$ENDIF}\r\n\r\n{$IFNDEF SYN_COMPILER_4_UP}\r\nfunction Max(x, y: Integer): Integer;\r\nbegin\r\n if x > y then Result := x else Result := y;\r\nend;\r\n\r\nfunction Min(x, y: Integer): Integer;\r\nbegin\r\n if x < y then Result := x else Result := y;\r\nend;\r\n{$ENDIF}\r\n\r\nfunction MinMax(x, mi, ma: Integer): Integer;\r\nbegin\r\n x := Min(x, ma);\r\n Result := Max(x, mi);\r\nend;\r\n\r\nprocedure SwapInt(var l, r: Integer);\r\nvar\r\n tmp: Integer;\r\nbegin\r\n tmp := r;\r\n r := l;\r\n l := tmp;\r\nend;\r\n\r\nfunction MaxPoint(const P1, P2: TPoint): TPoint;\r\nbegin\r\n if (P2.y > P1.y) or ((P2.y = P1.y) and (P2.x > P1.x)) then\r\n Result := P2\r\n else\r\n Result := P1;\r\nend;\r\n\r\nfunction MinPoint(const P1, P2: TPoint): TPoint;\r\nbegin\r\n if (P2.y < P1.y) or ((P2.y = P1.y) and (P2.x < P1.x)) then\r\n Result := P2\r\n else\r\n Result := P1;\r\nend;\r\n\r\nfunction GetIntArray(Count: Cardinal; InitialValue: Integer): PIntArray;\r\nvar\r\n p: PInteger;\r\nbegin\r\n Result := AllocMem(Count * SizeOf(Integer));\r\n if Assigned(Result) and (InitialValue <> 0) then\r\n begin\r\n p := PInteger(Result);\r\n while (Count > 0) do\r\n begin\r\n p^ := InitialValue;\r\n Inc(p);\r\n Dec(Count);\r\n end;\r\n end;\r\nend;\r\n\r\n{$IFNDEF SYN_CLX}\r\nprocedure InternalFillRect(dc: HDC; const rcPaint: TRect);\r\nbegin\r\n ExtTextOut(dc, 0, 0, ETO_OPAQUE, @rcPaint, nil, 0, nil);\r\nend;\r\n{$ENDIF}\r\n\r\n// Please don't change this function; no stack frame and efficient register use.\r\nfunction GetHasTabs(pLine: PWideChar; var CharsBefore: Integer): Boolean;\r\nbegin\r\n CharsBefore := 0;\r\n if Assigned(pLine) then\r\n begin\r\n while pLine^ <> #0 do \r\n begin\r\n if pLine^ = #9 then break;\r\n Inc(CharsBefore);\r\n Inc(pLine);\r\n end;\r\n Result := pLine^ = #9;\r\n end\r\n else\r\n Result := False;\r\nend;\r\n\r\n\r\nfunction ConvertTabs1Ex(const Line: UnicodeString; TabWidth: Integer;\r\n var HasTabs: Boolean): UnicodeString;\r\nvar\r\n pDest: PWideChar;\r\n nBeforeTab: Integer;\r\nbegin\r\n Result := Line; // increment reference count only\r\n if GetHasTabs(pointer(Line), nBeforeTab) then\r\n begin\r\n HasTabs := True;\r\n pDest := @Result[nBeforeTab + 1]; // this will make a copy of Line\r\n // We have at least one tab in the string, and the tab width is 1.\r\n // pDest points to the first tab char. We overwrite all tabs with spaces.\r\n repeat\r\n if (pDest^ = #9) then pDest^ := ' ';\r\n Inc(pDest);\r\n until (pDest^ = #0);\r\n end\r\n else\r\n HasTabs := False;\r\nend;\r\n\r\nfunction ConvertTabs1(const Line: UnicodeString; TabWidth: Integer): UnicodeString;\r\nvar\r\n HasTabs: Boolean;\r\nbegin\r\n Result := ConvertTabs1Ex(Line, TabWidth, HasTabs);\r\nend;\r\n\r\nfunction ConvertTabs2nEx(const Line: UnicodeString; TabWidth: Integer;\r\n var HasTabs: Boolean): UnicodeString;\r\nvar\r\n i, DestLen, TabCount, TabMask: Integer;\r\n pSrc, pDest: PWideChar;\r\nbegin\r\n Result := Line; // increment reference count only\r\n if GetHasTabs(pointer(Line), DestLen) then\r\n begin\r\n HasTabs := True;\r\n pSrc := @Line[1 + DestLen];\r\n // We have at least one tab in the string, and the tab width equals 2^n.\r\n // pSrc points to the first tab char in Line. We get the number of tabs\r\n // and the length of the expanded string now.\r\n TabCount := 0;\r\n TabMask := (TabWidth - 1) xor $7FFFFFFF;\r\n repeat\r\n if pSrc^ = #9 then\r\n begin\r\n DestLen := (DestLen + TabWidth) and TabMask;\r\n Inc(TabCount);\r\n end\r\n else\r\n Inc(DestLen);\r\n Inc(pSrc);\r\n until (pSrc^ = #0);\r\n // Set the length of the expanded string.\r\n SetLength(Result, DestLen);\r\n DestLen := 0;\r\n pSrc := PWideChar(Line);\r\n pDest := PWideChar(Result);\r\n // We use another TabMask here to get the difference to 2^n.\r\n TabMask := TabWidth - 1;\r\n repeat\r\n if pSrc^ = #9 then\r\n begin\r\n i := TabWidth - (DestLen and TabMask);\r\n Inc(DestLen, i);\r\n //This is used for both drawing and other stuff and is meant to be #9 and not #32\r\n repeat\r\n pDest^ := #9;\r\n Inc(pDest);\r\n Dec(i);\r\n until (i = 0);\r\n Dec(TabCount);\r\n if TabCount = 0 then\r\n begin\r\n repeat\r\n Inc(pSrc);\r\n pDest^ := pSrc^;\r\n Inc(pDest);\r\n until (pSrc^ = #0);\r\n exit;\r\n end;\r\n end\r\n else\r\n begin\r\n pDest^ := pSrc^;\r\n Inc(pDest);\r\n Inc(DestLen);\r\n end;\r\n Inc(pSrc);\r\n until (pSrc^ = #0);\r\n end\r\n else\r\n HasTabs := False;\r\nend;\r\n\r\nfunction ConvertTabs2n(const Line: UnicodeString; TabWidth: Integer): UnicodeString;\r\nvar\r\n HasTabs: Boolean;\r\nbegin\r\n Result := ConvertTabs2nEx(Line, TabWidth, HasTabs);\r\nend;\r\n\r\nfunction ConvertTabsEx(const Line: UnicodeString; TabWidth: Integer;\r\n var HasTabs: Boolean): UnicodeString;\r\nvar\r\n i, DestLen, TabCount: Integer;\r\n pSrc, pDest: PWideChar;\r\nbegin\r\n Result := Line; // increment reference count only\r\n if GetHasTabs(pointer(Line), DestLen) then\r\n begin\r\n HasTabs := True;\r\n pSrc := @Line[1 + DestLen];\r\n // We have at least one tab in the string, and the tab width is greater\r\n // than 1. pSrc points to the first tab char in Line. We get the number\r\n // of tabs and the length of the expanded string now.\r\n TabCount := 0;\r\n repeat\r\n if pSrc^ = #9 then\r\n begin\r\n DestLen := DestLen + TabWidth - DestLen mod TabWidth;\r\n Inc(TabCount);\r\n end\r\n else\r\n Inc(DestLen);\r\n Inc(pSrc);\r\n until (pSrc^ = #0);\r\n // Set the length of the expanded string.\r\n SetLength(Result, DestLen);\r\n DestLen := 0;\r\n pSrc := PWideChar(Line);\r\n pDest := PWideChar(Result);\r\n repeat\r\n if pSrc^ = #9 then\r\n begin\r\n i := TabWidth - (DestLen mod TabWidth);\r\n Inc(DestLen, i);\r\n repeat\r\n pDest^ := #9;\r\n Inc(pDest);\r\n Dec(i);\r\n until (i = 0);\r\n Dec(TabCount);\r\n if TabCount = 0 then\r\n begin\r\n repeat\r\n Inc(pSrc);\r\n pDest^ := pSrc^;\r\n Inc(pDest);\r\n until (pSrc^ = #0);\r\n exit;\r\n end;\r\n end\r\n else\r\n begin\r\n pDest^ := pSrc^;\r\n Inc(pDest);\r\n Inc(DestLen);\r\n end;\r\n Inc(pSrc);\r\n until (pSrc^ = #0);\r\n end\r\n else\r\n HasTabs := False;\r\nend;\r\n\r\nfunction ConvertTabs(const Line: UnicodeString; TabWidth: Integer): UnicodeString;\r\nvar\r\n HasTabs: Boolean;\r\nbegin\r\n Result := ConvertTabsEx(Line, TabWidth, HasTabs);\r\nend;\r\n\r\nfunction IsPowerOfTwo(TabWidth: Integer): Boolean;\r\nvar\r\n nW: Integer;\r\nbegin\r\n nW := 2;\r\n repeat\r\n if (nW >= TabWidth) then break;\r\n Inc(nW, nW);\r\n until (nW >= $10000); // we don't want 64 kByte spaces...\r\n Result := (nW = TabWidth);\r\nend;\r\n\r\nfunction GetBestConvertTabsProc(TabWidth: Integer): TConvertTabsProc;\r\nbegin\r\n if (TabWidth < 2) then Result := TConvertTabsProc(@ConvertTabs1)\r\n else if IsPowerOfTwo(TabWidth) then\r\n Result := TConvertTabsProc(@ConvertTabs2n)\r\n else\r\n Result := TConvertTabsProc(@ConvertTabs);\r\nend;\r\n\r\nfunction GetBestConvertTabsProcEx(TabWidth: Integer): TConvertTabsProcEx;\r\nbegin\r\n if (TabWidth < 2) then Result := ConvertTabs1Ex\r\n else if IsPowerOfTwo(TabWidth) then\r\n Result := ConvertTabs2nEx\r\n else\r\n Result := ConvertTabsEx;\r\nend;\r\n\r\nfunction GetExpandedLength(const aStr: UnicodeString; aTabWidth: Integer): Integer;\r\nvar\r\n iRun: PWideChar;\r\nbegin\r\n Result := 0;\r\n iRun := PWideChar(aStr);\r\n while iRun^ <> #0 do\r\n begin\r\n if iRun^ = #9 then\r\n Inc(Result, aTabWidth - (Result mod aTabWidth))\r\n else\r\n Inc(Result);\r\n Inc(iRun);\r\n end;\r\nend;\r\n\r\nfunction CharIndex2CaretPos(Index, TabWidth: Integer;\r\n const Line: UnicodeString): Integer;\r\nvar\r\n iChar: Integer;\r\n pNext: PWideChar;\r\nbegin\r\n// possible sanity check here: Index := Max(Index, Length(Line));\r\n if Index > 1 then\r\n begin\r\n if (TabWidth <= 1) or not GetHasTabs(pointer(Line), iChar) then\r\n Result := Index\r\n else\r\n begin\r\n if iChar + 1 >= Index then\r\n Result := Index\r\n else\r\n begin\r\n // iChar is number of chars before first #9\r\n Result := iChar;\r\n // Index is *not* zero-based\r\n Inc(iChar);\r\n Dec(Index, iChar);\r\n pNext := @Line[iChar];\r\n while Index > 0 do\r\n begin\r\n case pNext^ of\r\n #0:\r\n begin\r\n Inc(Result, Index);\r\n break;\r\n end;\r\n #9:\r\n begin\r\n // Result is still zero-based\r\n Inc(Result, TabWidth);\r\n Dec(Result, Result mod TabWidth);\r\n end;\r\n else\r\n Inc(Result);\r\n end;\r\n Dec(Index);\r\n Inc(pNext);\r\n end;\r\n // done with zero-based computation\r\n Inc(Result);\r\n end;\r\n end;\r\n end\r\n else\r\n Result := 1;\r\nend;\r\n\r\nfunction CaretPos2CharIndex(Position, TabWidth: Integer; const Line: UnicodeString;\r\n var InsideTabChar: Boolean): Integer;\r\nvar\r\n iPos: Integer;\r\n pNext: PWideChar;\r\nbegin\r\n InsideTabChar := False;\r\n if Position > 1 then\r\n begin\r\n if (TabWidth <= 1) or not GetHasTabs(pointer(Line), iPos) then\r\n Result := Position\r\n else\r\n begin\r\n if iPos + 1 >= Position then\r\n Result := Position\r\n else\r\n begin\r\n // iPos is number of chars before first #9\r\n Result := iPos + 1;\r\n pNext := @Line[Result];\r\n // for easier computation go zero-based (mod-operation)\r\n Dec(Position);\r\n while iPos < Position do\r\n begin\r\n case pNext^ of\r\n #0: break;\r\n #9: begin\r\n Inc(iPos, TabWidth);\r\n Dec(iPos, iPos mod TabWidth);\r\n if iPos > Position then\r\n begin\r\n InsideTabChar := True;\r\n break;\r\n end;\r\n end;\r\n else\r\n Inc(iPos);\r\n end;\r\n Inc(Result);\r\n Inc(pNext);\r\n end;\r\n end;\r\n end;\r\n end\r\n else\r\n Result := Position;\r\nend;\r\n\r\nfunction StrScanForCharInCategory(const Line: UnicodeString; Start: Integer;\r\n IsOfCategory: TCategoryMethod): Integer;\r\nvar\r\n p: PWideChar;\r\nbegin\r\n if (Start > 0) and (Start <= Length(Line)) then\r\n begin\r\n p := PWideChar(@Line[Start]);\r\n repeat\r\n if IsOfCategory(p^) then\r\n begin\r\n Result := Start;\r\n exit;\r\n end;\r\n Inc(p);\r\n Inc(Start);\r\n until p^ = #0;\r\n end;\r\n Result := 0;\r\nend;\r\n\r\nfunction StrRScanForCharInCategory(const Line: UnicodeString; Start: Integer;\r\n IsOfCategory: TCategoryMethod): Integer;\r\nvar\r\n I: Integer;\r\nbegin\r\n Result := 0;\r\n if (Start > 0) and (Start <= Length(Line)) then\r\n begin\r\n for I := Start downto 1 do\r\n if IsOfCategory(Line[I]) then\r\n begin\r\n Result := I;\r\n Exit;\r\n end;\r\n end;\r\nend;\r\n\r\nfunction GetEOL(Line: PWideChar): PWideChar;\r\nbegin\r\n Result := Line;\r\n if Assigned(Result) then\r\n while (Result^ <> #0) and (Result^ <> #10) and (Result^ <> #13) do\r\n Inc(Result);\r\nend;\r\n\r\n{$IFOPT R+}{$DEFINE RestoreRangeChecking}{$ELSE}{$UNDEF RestoreRangeChecking}{$ENDIF}\r\n{$R-}\r\nfunction EncodeString(s: UnicodeString): UnicodeString;\r\nvar\r\n i, j: Integer;\r\nbegin\r\n SetLength(Result, 2 * Length(s)); // worst case\r\n j := 0;\r\n for i := 1 to Length(s) do\r\n begin\r\n Inc(j);\r\n if s[i] = '\\' then\r\n begin\r\n Result[j] := '\\';\r\n Result[j + 1] := '\\';\r\n Inc(j);\r\n end\r\n else if s[i] = '/' then\r\n begin\r\n Result[j] := '\\';\r\n Result[j + 1] := '.';\r\n Inc(j);\r\n end\r\n else\r\n Result[j] := s[i];\r\n end; //for\r\n SetLength(Result, j);\r\nend; { EncodeString }\r\n\r\nfunction DecodeString(s: UnicodeString): UnicodeString;\r\nvar\r\n i, j: Integer;\r\nbegin\r\n SetLength(Result, Length(s)); // worst case\r\n j := 0;\r\n i := 1;\r\n while i <= Length(s) do\r\n begin\r\n Inc(j);\r\n if s[i] = '\\' then\r\n begin\r\n Inc(i);\r\n if s[i] = '\\' then\r\n Result[j] := '\\'\r\n else\r\n Result[j] := '/';\r\n end\r\n else\r\n Result[j] := s[i];\r\n Inc(i);\r\n end; //for\r\n SetLength(Result,j);\r\nend; { DecodeString }\r\n{$IFDEF RestoreRangeChecking}{$R+}{$ENDIF}\r\n\r\n{$IFNDEF SYN_COMPILER_5_UP}\r\nprocedure FreeAndNil(var Obj);\r\nvar\r\n P: TObject;\r\nbegin\r\n P := TObject(Obj);\r\n TObject(Obj) := nil;\r\n P.Free;\r\nend;\r\n{$ENDIF}\r\n\r\n{$IFNDEF SYN_COMPILER_3_UP}\r\nprocedure Assert(Expr: Boolean); { stub for Delphi 2 }\r\nbegin\r\nend;\r\n{$ENDIF}\r\n\r\n{$IFNDEF SYN_COMPILER_3_UP}\r\nfunction LastDelimiter(const Delimiters, S: UnicodeString): Integer;\r\nvar\r\n P: PWideChar;\r\nbegin\r\n Result := Length(S);\r\n P := PWideChar(Delimiters);\r\n while Result > 0 do\r\n begin\r\n if (S[Result] <> #0) and (StrScan(P, S[Result]) <> nil) then\r\n exit;\r\n Dec(Result);\r\n end;\r\nend;\r\n{$ENDIF}\r\n\r\n{$IFNDEF SYN_COMPILER_4_UP}\r\nfunction StringReplace(const S, OldPattern, NewPattern: UnicodeString;\r\n Flags: TReplaceFlags): UnicodeString;\r\nvar\r\n SearchStr, Patt, NewStr: UnicodeString;\r\n Offset: Integer;\r\nbegin\r\n if rfIgnoreCase in Flags then\r\n begin\r\n SearchStr := SynWideUpperCase(S);\r\n Patt := SynWideUpperCase(OldPattern);\r\n end\r\n else\r\n begin\r\n SearchStr := S;\r\n Patt := OldPattern;\r\n end;\r\n NewStr := S;\r\n Result := '';\r\n while SearchStr <> '' do\r\n begin\r\n Offset := Pos(Patt, SearchStr);\r\n if Offset = 0 then\r\n begin\r\n Result := Result + NewStr;\r\n Break;\r\n end;\r\n Result := Result + Copy(NewStr, 1, Offset - 1) + NewPattern;\r\n NewStr := Copy(NewStr, Offset + Length(OldPattern), MaxInt);\r\n if not (rfReplaceAll in Flags) then\r\n begin\r\n Result := Result + NewStr;\r\n Break;\r\n end;\r\n SearchStr := Copy(SearchStr, Offset + Length(Patt), MaxInt);\r\n end;\r\nend;\r\n{$ENDIF}\r\n\r\n{$IFDEF SYN_CLX}\r\ntype\r\n TColorRec = packed record\r\n Blue: Byte;\r\n Green: Byte;\r\n Red: Byte;\r\n Unused: Byte;\r\n end;\r\n\r\nfunction GetRValue(RGBValue: TColor): byte;\r\nbegin\r\n Result := TColorRec(RGBValue).Red;\r\nend;\r\n\r\nfunction GetGValue(RGBValue: TColor): byte;\r\nbegin\r\n Result := TColorRec(RGBValue).Green;\r\nend;\r\n\r\nfunction GetBValue(RGBValue: TColor): byte;\r\nbegin\r\n Result := TColorRec(RGBValue).Blue;\r\nend;\r\n\r\nfunction RGB(r, g, b: Byte): Cardinal;\r\nbegin\r\n Result := (r or (g shl 8) or (b shl 16));\r\nend;\r\n{$ENDIF}\r\n\r\nfunction DeleteTypePrefixAndSynSuffix(S: string): string;\r\nbegin\r\n Result := S;\r\n if CharInSet(Result[1], ['T', 't']) then //ClassName is never empty so no AV possible\r\n if Pos('tsyn', LowerCase(Result)) = 1 then\r\n Delete(Result, 1, 4)\r\n else\r\n Delete(Result, 1, 1);\r\n\r\n if Copy(LowerCase(Result), Length(Result) - 2, 3) = 'syn' then\r\n SetLength(Result, Length(Result) - 3);\r\nend;\r\n\r\nfunction GetHighlighterIndex(Highlighter: TSynCustomHighlighter;\r\n HighlighterList: TList): Integer;\r\nvar\r\n i: Integer;\r\nbegin\r\n Result := 1;\r\n for i := 0 to HighlighterList.Count - 1 do\r\n if HighlighterList[i] = Highlighter then\r\n Exit\r\n else if Assigned(HighlighterList[i]) and (TObject(HighlighterList[i]).ClassType = Highlighter.ClassType) then\r\n inc(Result);\r\nend;\r\n\r\nfunction InternalEnumHighlighterAttris(Highlighter: TSynCustomHighlighter;\r\n SkipDuplicates: Boolean; HighlighterAttriProc: THighlighterAttriProc;\r\n Params: array of Pointer; HighlighterList: TList): Boolean;\r\nvar\r\n i: Integer;\r\n UniqueAttriName: string;\r\nbegin\r\n Result := True;\r\n\r\n if (HighlighterList.IndexOf(Highlighter) >= 0) then\r\n begin\r\n if SkipDuplicates then Exit;\r\n end\r\n else\r\n HighlighterList.Add(Highlighter);\r\n\r\n if Highlighter is TSynMultiSyn then\r\n with TSynMultiSyn(Highlighter) do\r\n begin\r\n Result := InternalEnumHighlighterAttris(DefaultHighlighter, SkipDuplicates,\r\n HighlighterAttriProc, Params, HighlighterList);\r\n if not Result then Exit;\r\n\r\n for i := 0 to Schemes.Count - 1 do\r\n begin\r\n UniqueAttriName := Highlighter.ExportName +\r\n IntToStr(GetHighlighterIndex(Highlighter, HighlighterList)) + '.' +\r\n Schemes[i].MarkerAttri.Name + IntToStr(i + 1);\r\n\r\n Result := HighlighterAttriProc(Highlighter, Schemes[i].MarkerAttri,\r\n UniqueAttriName, Params);\r\n if not Result then Exit;\r\n\r\n Result := InternalEnumHighlighterAttris(Schemes[i].Highlighter,\r\n SkipDuplicates, HighlighterAttriProc, Params, HighlighterList);\r\n if not Result then Exit\r\n end\r\n end\r\n else if Assigned(Highlighter) then\r\n for i := 0 to Highlighter.AttrCount - 1 do\r\n begin\r\n UniqueAttriName := Highlighter.ExportName +\r\n IntToStr(GetHighlighterIndex(Highlighter, HighlighterList)) + '.' +\r\n Highlighter.Attribute[i].Name;\r\n\r\n Result := HighlighterAttriProc(Highlighter, Highlighter.Attribute[i],\r\n UniqueAttriName, Params);\r\n if not Result then Exit\r\n end\r\nend;\r\n\r\nfunction EnumHighlighterAttris(Highlighter: TSynCustomHighlighter;\r\n SkipDuplicates: Boolean; HighlighterAttriProc: THighlighterAttriProc;\r\n Params: array of Pointer): Boolean;\r\nvar\r\n HighlighterList: TList;\r\nbegin\r\n if not Assigned(Highlighter) or not Assigned(HighlighterAttriProc) then\r\n begin\r\n Result := False;\r\n Exit;\r\n end;\r\n\r\n HighlighterList := TList.Create;\r\n try\r\n Result := InternalEnumHighlighterAttris(Highlighter, SkipDuplicates,\r\n HighlighterAttriProc, Params, HighlighterList)\r\n finally\r\n HighlighterList.Free\r\n end\r\nend;\r\n\r\n{$IFDEF SYN_HEREDOC}\r\n// Fast Frame Check Sequence (FCS) Implementation\r\n// Translated from sample code given with RFC 1171 by Marko Njezic\r\n\r\nconst\r\n fcstab : array[Byte] of Word = (\r\n $0000, $1189, $2312, $329b, $4624, $57ad, $6536, $74bf,\r\n $8c48, $9dc1, $af5a, $bed3, $ca6c, $dbe5, $e97e, $f8f7,\r\n $1081, $0108, $3393, $221a, $56a5, $472c, $75b7, $643e,\r\n $9cc9, $8d40, $bfdb, $ae52, $daed, $cb64, $f9ff, $e876,\r\n $2102, $308b, $0210, $1399, $6726, $76af, $4434, $55bd,\r\n $ad4a, $bcc3, $8e58, $9fd1, $eb6e, $fae7, $c87c, $d9f5,\r\n $3183, $200a, $1291, $0318, $77a7, $662e, $54b5, $453c,\r\n $bdcb, $ac42, $9ed9, $8f50, $fbef, $ea66, $d8fd, $c974,\r\n $4204, $538d, $6116, $709f, $0420, $15a9, $2732, $36bb,\r\n $ce4c, $dfc5, $ed5e, $fcd7, $8868, $99e1, $ab7a, $baf3,\r\n $5285, $430c, $7197, $601e, $14a1, $0528, $37b3, $263a,\r\n $decd, $cf44, $fddf, $ec56, $98e9, $8960, $bbfb, $aa72,\r\n $6306, $728f, $4014, $519d, $2522, $34ab, $0630, $17b9,\r\n $ef4e, $fec7, $cc5c, $ddd5, $a96a, $b8e3, $8a78, $9bf1,\r\n $7387, $620e, $5095, $411c, $35a3, $242a, $16b1, $0738,\r\n $ffcf, $ee46, $dcdd, $cd54, $b9eb, $a862, $9af9, $8b70,\r\n $8408, $9581, $a71a, $b693, $c22c, $d3a5, $e13e, $f0b7,\r\n $0840, $19c9, $2b52, $3adb, $4e64, $5fed, $6d76, $7cff,\r\n $9489, $8500, $b79b, $a612, $d2ad, $c324, $f1bf, $e036,\r\n $18c1, $0948, $3bd3, $2a5a, $5ee5, $4f6c, $7df7, $6c7e,\r\n $a50a, $b483, $8618, $9791, $e32e, $f2a7, $c03c, $d1b5,\r\n $2942, $38cb, $0a50, $1bd9, $6f66, $7eef, $4c74, $5dfd,\r\n $b58b, $a402, $9699, $8710, $f3af, $e226, $d0bd, $c134,\r\n $39c3, $284a, $1ad1, $0b58, $7fe7, $6e6e, $5cf5, $4d7c,\r\n $c60c, $d785, $e51e, $f497, $8028, $91a1, $a33a, $b2b3,\r\n $4a44, $5bcd, $6956, $78df, $0c60, $1de9, $2f72, $3efb,\r\n $d68d, $c704, $f59f, $e416, $90a9, $8120, $b3bb, $a232,\r\n $5ac5, $4b4c, $79d7, $685e, $1ce1, $0d68, $3ff3, $2e7a,\r\n $e70e, $f687, $c41c, $d595, $a12a, $b0a3, $8238, $93b1,\r\n $6b46, $7acf, $4854, $59dd, $2d62, $3ceb, $0e70, $1ff9,\r\n $f78f, $e606, $d49d, $c514, $b1ab, $a022, $92b9, $8330,\r\n $7bc7, $6a4e, $58d5, $495c, $3de3, $2c6a, $1ef1, $0f78\r\n );\r\n\r\nfunction CalcFCS(const ABuf; ABufSize: Cardinal): Word;\r\nvar\r\n CurFCS: Word;\r\n P: ^Byte;\r\nbegin\r\n CurFCS := $ffff;\r\n P := @ABuf;\r\n while ABufSize <> 0 do\r\n begin\r\n CurFCS := (CurFCS shr 8) xor fcstab[(CurFCS xor P^) and $ff];\r\n Dec(ABufSize);\r\n Inc(P);\r\n end;\r\n Result := CurFCS;\r\nend;\r\n{$ENDIF}\r\n\r\nprocedure SynDrawGradient(const ACanvas: TCanvas; const AStartColor, AEndColor: TColor;\r\n ASteps: Integer; const ARect: TRect; const AHorizontal: Boolean);\r\nvar\r\n StartColorR, StartColorG, StartColorB: Byte;\r\n DiffColorR, DiffColorG, DiffColorB: Integer;\r\n i, Size: Integer;\r\n PaintRect: TRect;\r\nbegin\r\n StartColorR := GetRValue(ColorToRGB(AStartColor));\r\n StartColorG := GetGValue(ColorToRGB(AStartColor));\r\n StartColorB := GetBValue(ColorToRGB(AStartColor));\r\n\r\n DiffColorR := GetRValue(ColorToRGB(AEndColor)) - StartColorR;\r\n DiffColorG := GetGValue(ColorToRGB(AEndColor)) - StartColorG;\r\n DiffColorB := GetBValue(ColorToRGB(AEndColor)) - StartColorB;\r\n\r\n ASteps := MinMax(ASteps, 2, 256);\r\n\r\n if AHorizontal then\r\n begin\r\n Size := ARect.Right - ARect.Left;\r\n PaintRect.Top := ARect.Top;\r\n PaintRect.Bottom := ARect.Bottom;\r\n\r\n for i := 0 to ASteps - 1 do\r\n begin\r\n PaintRect.Left := ARect.Left + MulDiv(i, Size, ASteps);\r\n PaintRect.Right := ARect.Left + MulDiv(i + 1, Size, ASteps);\r\n\r\n ACanvas.Brush.Color := RGB(StartColorR + MulDiv(i, DiffColorR, ASteps - 1),\r\n StartColorG + MulDiv(i, DiffColorG, ASteps - 1),\r\n StartColorB + MulDiv(i, DiffColorB, ASteps - 1));\r\n\r\n ACanvas.FillRect(PaintRect);\r\n end;\r\n end\r\n else\r\n begin\r\n Size := ARect.Bottom - ARect.Top;\r\n PaintRect.Left := ARect.Left;\r\n PaintRect.Right := ARect.Right;\r\n\r\n for i := 0 to ASteps - 1 do\r\n begin\r\n PaintRect.Top := ARect.Top + MulDiv(i, Size, ASteps);\r\n PaintRect.Bottom := ARect.Top + MulDiv(i + 1, Size, ASteps);\r\n\r\n ACanvas.Brush.Color := RGB(StartColorR + MulDiv(i, DiffColorR, ASteps - 1),\r\n StartColorG + MulDiv(i, DiffColorG, ASteps - 1),\r\n StartColorB + MulDiv(i, DiffColorB, ASteps - 1));\r\n\r\n ACanvas.FillRect(PaintRect);\r\n end;\r\n end;\r\nend;\r\n\r\nend.\r\n" }, { "path": "External/SynEdit/Source/SynEditOptionsDialog.dfm", "content": "object fmEditorOptionsDialog: TfmEditorOptionsDialog\r\n Left = 580\r\n Top = 154\r\n BorderStyle = bsDialog\r\n Caption = 'Editor Options'\r\n ClientHeight = 394\r\n ClientWidth = 369\r\n Font.Charset = DEFAULT_CHARSET\r\n Font.Color = clWindowText\r\n Font.Height = -11\r\n Font.Name = 'MS Sans Serif'\r\n Font.Style = []\r\n Position = poScreenCenter\r\n OnCreate = FormCreate\r\n OnShow = FormShow\r\n PixelsPerInch = 96\r\n TextHeight = 13\r\n object PageControl1: TPageControl\r\n Left = 6\r\n Top = 8\r\n Width = 355\r\n Height = 345\r\n ActivePage = Display\r\n TabOrder = 0\r\n object Display: TTabSheet\r\n Caption = 'Display'\r\n object gbRightEdge: TGroupBox\r\n Left = 8\r\n Top = 136\r\n Width = 159\r\n Height = 88\r\n Caption = 'Right Edge'\r\n TabOrder = 1\r\n object Label3: TLabel\r\n Left = 9\r\n Top = 56\r\n Width = 54\r\n Height = 13\r\n Caption = 'Edge color:'\r\n end\r\n object Label10: TLabel\r\n Left = 9\r\n Top = 26\r\n Width = 66\r\n Height = 13\r\n Caption = 'Edge Column:'\r\n end\r\n object pRightEdgeBack: TPanel\r\n Left = 80\r\n Top = 54\r\n Width = 52\r\n Height = 21\r\n BorderWidth = 1\r\n TabOrder = 1\r\n object pRightEdgeColor: TPanel\r\n Left = 2\r\n Top = 2\r\n Width = 38\r\n Height = 17\r\n Align = alClient\r\n BevelOuter = bvLowered\r\n Color = clGray\r\n TabOrder = 0\r\n OnClick = pRightEdgeColorClick\r\n end\r\n object btnRightEdge: TPanel\r\n Left = 40\r\n Top = 2\r\n Width = 10\r\n Height = 17\r\n Align = alRight\r\n BevelOuter = bvNone\r\n TabOrder = 1\r\n OnMouseDown = btnRightEdgeMouseDown\r\n object Image1: TImage\r\n Left = 3\r\n Top = 6\r\n Width = 5\r\n Height = 5\r\n Picture.Data = {\r\n 07544269746D61708A000000424D8A0000000000000076000000280000000500\r\n 0000050000000100040000000000140000000000000000000000100000001000\r\n 0000000000000000800000800000008080008000000080008000808000008080\r\n 8000C0C0C0000000FF0000FF000000FFFF00FF000000FF00FF00FFFF0000FFFF\r\n FF00DDDDD000DD0DD000D000D00000000000DDDDD000}\r\n Transparent = True\r\n OnMouseDown = btnRightEdgeMouseDown\r\n end\r\n end\r\n end\r\n object eRightEdge: TEdit\r\n Left = 80\r\n Top = 23\r\n Width = 51\r\n Height = 21\r\n TabOrder = 0\r\n Text = '0'\r\n end\r\n end\r\n object gbGutter: TGroupBox\r\n Left = 8\r\n Top = 8\r\n Width = 330\r\n Height = 121\r\n Caption = 'Gutter'\r\n TabOrder = 0\r\n object Label1: TLabel\r\n Left = 176\r\n Top = 89\r\n Width = 58\r\n Height = 13\r\n Caption = 'Gutter color:'\r\n end\r\n object ckGutterAutosize: TCheckBox\r\n Left = 9\r\n Top = 37\r\n Width = 120\r\n Height = 17\r\n Caption = 'Autosize'\r\n TabOrder = 1\r\n end\r\n object ckGutterShowLineNumbers: TCheckBox\r\n Left = 9\r\n Top = 56\r\n Width = 120\r\n Height = 17\r\n Caption = 'Show line numbers'\r\n TabOrder = 2\r\n end\r\n object ckGutterShowLeaderZeros: TCheckBox\r\n Left = 9\r\n Top = 94\r\n Width = 120\r\n Height = 17\r\n Caption = 'Show leading zeros'\r\n TabOrder = 4\r\n end\r\n object ckGutterStartAtZero: TCheckBox\r\n Left = 9\r\n Top = 75\r\n Width = 120\r\n Height = 17\r\n Caption = 'Start at zero'\r\n TabOrder = 3\r\n end\r\n object ckGutterVisible: TCheckBox\r\n Left = 9\r\n Top = 18\r\n Width = 120\r\n Height = 17\r\n Caption = 'Visible'\r\n State = cbChecked\r\n TabOrder = 0\r\n end\r\n object cbGutterFont: TCheckBox\r\n Left = 176\r\n Top = 18\r\n Width = 120\r\n Height = 17\r\n Caption = 'Use Gutter Font'\r\n TabOrder = 5\r\n OnClick = cbGutterFontClick\r\n end\r\n object btnGutterFont: TButton\r\n Left = 282\r\n Top = 13\r\n Width = 40\r\n Height = 25\r\n Caption = 'Font'\r\n TabOrder = 6\r\n OnClick = btnGutterFontClick\r\n end\r\n object pGutterBack: TPanel\r\n Left = 252\r\n Top = 85\r\n Width = 52\r\n Height = 21\r\n BorderWidth = 1\r\n TabOrder = 8\r\n object pGutterColor: TPanel\r\n Left = 2\r\n Top = 2\r\n Width = 38\r\n Height = 17\r\n Align = alClient\r\n BevelOuter = bvLowered\r\n Color = clGray\r\n TabOrder = 0\r\n OnClick = pGutterColorClick\r\n end\r\n object btnGutterColor: TPanel\r\n Left = 40\r\n Top = 2\r\n Width = 10\r\n Height = 17\r\n Align = alRight\r\n BevelOuter = bvNone\r\n TabOrder = 1\r\n OnMouseDown = btnGutterColorMouseDown\r\n object Image2: TImage\r\n Left = 3\r\n Top = 6\r\n Width = 5\r\n Height = 5\r\n Picture.Data = {\r\n 07544269746D61708A000000424D8A0000000000000076000000280000000500\r\n 0000050000000100040000000000140000000000000000000000100000001000\r\n 0000000000000000800000800000008080008000000080008000808000008080\r\n 8000C0C0C0000000FF0000FF000000FFFF00FF000000FF00FF00FFFF0000FFFF\r\n FF00DDDDD000DD0DD000D000D00000000000DDDDD000}\r\n Transparent = True\r\n OnMouseDown = btnGutterColorMouseDown\r\n end\r\n end\r\n end\r\n object pnlGutterFontDisplay: TPanel\r\n Left = 176\r\n Top = 40\r\n Width = 145\r\n Height = 33\r\n BevelOuter = bvNone\r\n TabOrder = 7\r\n object lblGutterFont: TLabel\r\n Left = 19\r\n Top = 9\r\n Width = 105\r\n Height = 14\r\n Caption = 'Courier New 8pt'\r\n Font.Charset = DEFAULT_CHARSET\r\n Font.Color = clWindowText\r\n Font.Height = -11\r\n Font.Name = 'Courier New'\r\n Font.Style = []\r\n ParentFont = False\r\n end\r\n end\r\n end\r\n object gbBookmarks: TGroupBox\r\n Left = 8\r\n Top = 232\r\n Width = 159\r\n Height = 79\r\n Caption = 'Bookmarks'\r\n TabOrder = 3\r\n object ckBookmarkKeys: TCheckBox\r\n Left = 9\r\n Top = 24\r\n Width = 97\r\n Height = 17\r\n Caption = 'Bookmark keys'\r\n TabOrder = 0\r\n end\r\n object ckBookmarkVisible: TCheckBox\r\n Left = 9\r\n Top = 48\r\n Width = 121\r\n Height = 17\r\n Caption = 'Bookmarks visible'\r\n TabOrder = 1\r\n end\r\n end\r\n object gbEditorFont: TGroupBox\r\n Left = 180\r\n Top = 232\r\n Width = 159\r\n Height = 79\r\n Caption = 'Editor Font'\r\n TabOrder = 4\r\n object btnFont: TButton\r\n Left = 64\r\n Top = 49\r\n Width = 84\r\n Height = 25\r\n Caption = 'Font'\r\n TabOrder = 0\r\n OnClick = btnFontClick\r\n end\r\n object Panel3: TPanel\r\n Left = 8\r\n Top = 19\r\n Width = 143\r\n Height = 30\r\n BevelOuter = bvNone\r\n TabOrder = 1\r\n object labFont: TLabel\r\n Left = 2\r\n Top = 1\r\n Width = 128\r\n Height = 16\r\n Caption = 'Courier New 10pt'\r\n Font.Charset = DEFAULT_CHARSET\r\n Font.Color = clWindowText\r\n Font.Height = -13\r\n Font.Name = 'Courier New'\r\n Font.Style = []\r\n ParentFont = False\r\n end\r\n end\r\n end\r\n object gbLineSpacing: TGroupBox\r\n Left = 180\r\n Top = 136\r\n Width = 159\r\n Height = 88\r\n Caption = 'Line spacing / Tab spacing'\r\n TabOrder = 2\r\n object Label8: TLabel\r\n Left = 9\r\n Top = 27\r\n Width = 55\r\n Height = 13\r\n Caption = 'Extra Lines:'\r\n end\r\n object Label9: TLabel\r\n Left = 9\r\n Top = 56\r\n Width = 53\r\n Height = 13\r\n Caption = 'Tab Width:'\r\n end\r\n object eLineSpacing: TEdit\r\n Left = 80\r\n Top = 23\r\n Width = 52\r\n Height = 21\r\n TabOrder = 0\r\n Text = '0'\r\n end\r\n object eTabWidth: TEdit\r\n Left = 80\r\n Top = 53\r\n Width = 52\r\n Height = 21\r\n TabOrder = 1\r\n Text = '8'\r\n end\r\n end\r\n end\r\n object Options: TTabSheet\r\n Caption = 'Options'\r\n object gbOptions: TGroupBox\r\n Left = 8\r\n Top = 0\r\n Width = 330\r\n Height = 247\r\n Caption = 'Options'\r\n TabOrder = 0\r\n object ckAutoIndent: TCheckBox\r\n Left = 9\r\n Top = 15\r\n Width = 130\r\n Height = 17\r\n Hint = \r\n 'Will indent the caret on new lines with the same amount of leadi' +\r\n 'ng white space as the preceding line'\r\n Caption = 'Auto indent'\r\n TabOrder = 0\r\n end\r\n object ckDragAndDropEditing: TCheckBox\r\n Left = 9\r\n Top = 53\r\n Width = 130\r\n Height = 17\r\n Hint = \r\n 'Allows you to select a block of text and drag it within the docu' +\r\n 'ment to another location'\r\n Caption = 'Drag and drop editing'\r\n TabOrder = 2\r\n end\r\n object ckAutoSizeMaxWidth: TCheckBox\r\n Left = 9\r\n Top = 34\r\n Width = 130\r\n Height = 17\r\n Hint = 'Allows the editor accept OLE file drops'\r\n Caption = 'Auto size scroll width'\r\n TabOrder = 1\r\n end\r\n object ckHalfPageScroll: TCheckBox\r\n Left = 176\r\n Top = 15\r\n Width = 130\r\n Height = 17\r\n Hint = \r\n 'When scrolling with page-up and page-down commands, only scroll ' +\r\n 'a half page at a time'\r\n Caption = 'Half page scroll'\r\n TabOrder = 12\r\n end\r\n object ckEnhanceEndKey: TCheckBox\r\n Left = 9\r\n Top = 186\r\n Width = 130\r\n Height = 17\r\n Hint = 'Makes it so the caret is never visible'\r\n Caption = 'Enhance End Key'\r\n TabOrder = 9\r\n end\r\n object ckScrollByOneLess: TCheckBox\r\n Left = 176\r\n Top = 34\r\n Width = 130\r\n Height = 17\r\n Hint = 'Forces scrolling to be one less'\r\n Caption = 'Scroll by one less'\r\n TabOrder = 13\r\n end\r\n object ckScrollPastEOF: TCheckBox\r\n Left = 176\r\n Top = 53\r\n Width = 130\r\n Height = 17\r\n Hint = 'Allows the cursor to go past the end of file marker'\r\n Caption = 'Scroll past end of file'\r\n TabOrder = 14\r\n end\r\n object ckScrollPastEOL: TCheckBox\r\n Left = 176\r\n Top = 72\r\n Width = 130\r\n Height = 17\r\n Hint = \r\n 'Allows the cursor to go past the last character into the white s' +\r\n 'pace at the end of a line'\r\n Caption = 'Scroll past end of line'\r\n TabOrder = 15\r\n end\r\n object ckShowScrollHint: TCheckBox\r\n Left = 176\r\n Top = 91\r\n Width = 130\r\n Height = 17\r\n Hint = \r\n 'Shows a hint of the visible line numbers when scrolling vertical' +\r\n 'ly'\r\n Caption = 'Show scroll hint'\r\n TabOrder = 16\r\n end\r\n object ckSmartTabs: TCheckBox\r\n Left = 9\r\n Top = 129\r\n Width = 130\r\n Height = 17\r\n Hint = \r\n 'When tabbing, the cursor will go to the next non-white space cha' +\r\n 'racter of the previous line'\r\n Caption = 'Smart tabs'\r\n TabOrder = 6\r\n end\r\n object ckTabsToSpaces: TCheckBox\r\n Left = 176\r\n Top = 129\r\n Width = 130\r\n Height = 17\r\n Hint = 'Converts a tab character to the number of spaces in Tab Width'\r\n Caption = 'Tabs to spaces'\r\n TabOrder = 18\r\n end\r\n object ckTrimTrailingSpaces: TCheckBox\r\n Left = 176\r\n Top = 148\r\n Width = 130\r\n Height = 17\r\n Hint = 'Spaces at the end of lines will be trimmed and not saved'\r\n Caption = 'Trim trailing spaces'\r\n TabOrder = 19\r\n end\r\n object ckWantTabs: TCheckBox\r\n Left = 9\r\n Top = 110\r\n Width = 130\r\n Height = 17\r\n Hint = \r\n 'Let the editor accept tab characters instead of going to the nex' +\r\n 't control'\r\n Caption = 'Want tabs'\r\n TabOrder = 5\r\n end\r\n object ckAltSetsColumnMode: TCheckBox\r\n Left = 9\r\n Top = 72\r\n Width = 130\r\n Height = 17\r\n Hint = \r\n 'Holding down the Alt Key will put the selection mode into column' +\r\n 'ar format'\r\n Caption = 'Alt sets column mode'\r\n TabOrder = 3\r\n end\r\n object ckKeepCaretX: TCheckBox\r\n Left = 9\r\n Top = 91\r\n Width = 130\r\n Height = 17\r\n Hint = \r\n 'When moving through lines the X position will always stay the sa' +\r\n 'me'\r\n Caption = 'Maintain caret column'\r\n TabOrder = 4\r\n end\r\n object ckScrollHintFollows: TCheckBox\r\n Left = 176\r\n Top = 110\r\n Width = 152\r\n Height = 17\r\n Hint = 'The scroll hint follows the mouse when scrolling vertically'\r\n Caption = 'Scroll hint follows mouse'\r\n TabOrder = 17\r\n end\r\n object ckGroupUndo: TCheckBox\r\n Left = 177\r\n Top = 167\r\n Width = 130\r\n Height = 17\r\n Hint = \r\n 'When undoing/redoing actions, handle all continous changes of th' +\r\n 'e same kind in one call instead undoing/redoing each command sep' +\r\n 'arately'\r\n Caption = 'Group undo'\r\n TabOrder = 20\r\n end\r\n object ckSmartTabDelete: TCheckBox\r\n Left = 9\r\n Top = 148\r\n Width = 130\r\n Height = 17\r\n Hint = 'similar to Smart Tabs, but when you delete characters'\r\n Caption = 'Smart tab delete'\r\n TabOrder = 7\r\n end\r\n object ckRightMouseMoves: TCheckBox\r\n Left = 177\r\n Top = 186\r\n Width = 146\r\n Height = 17\r\n Hint = \r\n 'When clicking with the right mouse for a popup menu, move the cu' +\r\n 'rsor to that location'\r\n Caption = 'Right mouse moves cursor'\r\n TabOrder = 21\r\n end\r\n object ckEnhanceHomeKey: TCheckBox\r\n Left = 9\r\n Top = 167\r\n Width = 146\r\n Height = 17\r\n Hint = 'enhances home key positioning, similar to visual studio'\r\n Caption = 'Enhance Home Key'\r\n TabOrder = 8\r\n end\r\n object ckHideShowScrollbars: TCheckBox\r\n Left = 9\r\n Top = 205\r\n Width = 156\r\n Height = 17\r\n Hint = \r\n 'if enabled, then the scrollbars will only show when necessary. ' +\r\n 'If you have ScrollPastEOL, then it the horizontal bar will alway' +\r\n 's be there (it uses MaxLength instead)'\r\n Caption = 'Hide scrollbars as necessary'\r\n TabOrder = 10\r\n end\r\n object ckDisableScrollArrows: TCheckBox\r\n Left = 9\r\n Top = 224\r\n Width = 130\r\n Height = 17\r\n Hint = \r\n 'Disables the scroll bar arrow buttons when you can'#39't scroll in t' +\r\n 'hat direction any more'\r\n Caption = 'Disable scroll arrows'\r\n TabOrder = 11\r\n end\r\n object ckShowSpecialChars: TCheckBox\r\n Left = 177\r\n Top = 205\r\n Width = 130\r\n Height = 17\r\n Hint = 'Shows linebreaks, spaces and tabs using special symbols'\r\n Caption = 'Show special chars'\r\n TabOrder = 22\r\n end\r\n end\r\n object gbCaret: TGroupBox\r\n Left = 8\r\n Top = 249\r\n Width = 330\r\n Height = 62\r\n Caption = 'Caret'\r\n TabOrder = 1\r\n object Label2: TLabel\r\n Left = 16\r\n Top = 17\r\n Width = 56\r\n Height = 13\r\n Caption = 'Insert caret:'\r\n end\r\n object Label4: TLabel\r\n Left = 16\r\n Top = 41\r\n Width = 75\r\n Height = 13\r\n Caption = 'Overwrite caret:'\r\n end\r\n object cInsertCaret: TComboBox\r\n Left = 120\r\n Top = 13\r\n Width = 186\r\n Height = 21\r\n Style = csDropDownList\r\n ItemHeight = 13\r\n Items.Strings = (\r\n 'Vertical Line'\r\n 'Horizontal Line'\r\n 'Half Block'\r\n 'Block')\r\n TabOrder = 0\r\n end\r\n object cOverwriteCaret: TComboBox\r\n Left = 120\r\n Top = 37\r\n Width = 186\r\n Height = 21\r\n Style = csDropDownList\r\n ItemHeight = 13\r\n Items.Strings = (\r\n 'Vertical Line'\r\n 'Horizontal Line'\r\n 'Half Block'\r\n 'Block')\r\n TabOrder = 1\r\n end\r\n end\r\n end\r\n object Keystrokes: TTabSheet\r\n Caption = 'Keystrokes'\r\n object btnAddKey: TButton\r\n Left = 96\r\n Top = 152\r\n Width = 75\r\n Height = 25\r\n Caption = '&Add'\r\n TabOrder = 2\r\n OnClick = btnAddKeyClick\r\n end\r\n object btnRemKey: TButton\r\n Left = 176\r\n Top = 152\r\n Width = 75\r\n Height = 25\r\n Caption = '&Remove'\r\n TabOrder = 3\r\n OnClick = btnRemKeyClick\r\n end\r\n object gbKeyStrokes: TGroupBox\r\n Left = 8\r\n Top = 192\r\n Width = 330\r\n Height = 119\r\n Caption = 'Keystroke Options'\r\n TabOrder = 4\r\n object Label5: TLabel\r\n Left = 16\r\n Top = 28\r\n Width = 50\r\n Height = 13\r\n Caption = 'Command:'\r\n end\r\n object Label6: TLabel\r\n Left = 16\r\n Top = 91\r\n Width = 50\r\n Height = 13\r\n Caption = 'Keystroke:'\r\n end\r\n object Label7: TLabel\r\n Left = 16\r\n Top = 59\r\n Width = 50\r\n Height = 13\r\n Caption = 'Keystroke:'\r\n end\r\n object cKeyCommand: TComboBox\r\n Left = 120\r\n Top = 23\r\n Width = 186\r\n Height = 21\r\n ItemHeight = 0\r\n TabOrder = 0\r\n OnExit = cKeyCommandExit\r\n OnKeyPress = cKeyCommandKeyPress\r\n OnKeyUp = cKeyCommandKeyUp\r\n end\r\n end\r\n object btnUpdateKey: TButton\r\n Left = 16\r\n Top = 152\r\n Width = 75\r\n Height = 25\r\n Caption = '&Update'\r\n TabOrder = 1\r\n OnClick = btnUpdateKeyClick\r\n end\r\n object pnlCommands: TPanel\r\n Left = 8\r\n Top = 13\r\n Width = 330\r\n Height = 132\r\n BevelInner = bvRaised\r\n BevelOuter = bvLowered\r\n Caption = 'pnlCommands'\r\n TabOrder = 0\r\n object KeyList: TListView\r\n Left = 2\r\n Top = 2\r\n Width = 326\r\n Height = 128\r\n Align = alClient\r\n BorderStyle = bsNone\r\n ColumnClick = False\r\n Columns = <\r\n item\r\n Caption = 'Command'\r\n Width = 167\r\n end\r\n item\r\n Caption = 'Keystroke'\r\n Width = 142\r\n end>\r\n ReadOnly = True\r\n HideSelection = False\r\n RowSelect = True\r\n OnChanging = KeyListChanging\r\n TabOrder = 0\r\n ViewStyle = vsReport\r\n end\r\n end\r\n end\r\n end\r\n object btnOk: TButton\r\n Left = 200\r\n Top = 362\r\n Width = 75\r\n Height = 25\r\n Caption = '&OK'\r\n ModalResult = 1\r\n TabOrder = 1\r\n OnClick = btnOkClick\r\n end\r\n object btnCancel: TButton\r\n Left = 280\r\n Top = 362\r\n Width = 75\r\n Height = 25\r\n Caption = '&Cancel'\r\n ModalResult = 2\r\n TabOrder = 2\r\n end\r\n object ColorDialog: TColorDialog\r\n Ctl3D = True\r\n Left = 8\r\n Top = 368\r\n end\r\n object ColorPopup: TPopupMenu\r\n Left = 40\r\n Top = 368\r\n object None1: TMenuItem\r\n Tag = -1\r\n Caption = 'None'\r\n OnClick = PopupMenuClick\r\n end\r\n object Scrollbar1: TMenuItem\r\n Caption = 'Scrollbar'\r\n OnClick = PopupMenuClick\r\n end\r\n object Background1: TMenuItem\r\n Tag = 1\r\n Caption = 'Background'\r\n OnClick = PopupMenuClick\r\n end\r\n object ActiveCaption1: TMenuItem\r\n Tag = 2\r\n Caption = 'Active Caption'\r\n OnClick = PopupMenuClick\r\n end\r\n object InactiveCaption1: TMenuItem\r\n Tag = 3\r\n Caption = 'Inactive Caption'\r\n OnClick = PopupMenuClick\r\n end\r\n object Menu1: TMenuItem\r\n Tag = 4\r\n Caption = 'Menu'\r\n OnClick = PopupMenuClick\r\n end\r\n object Window1: TMenuItem\r\n Tag = 5\r\n Caption = 'Window'\r\n OnClick = PopupMenuClick\r\n end\r\n object WindowFrame1: TMenuItem\r\n Tag = 6\r\n Caption = 'Window Frame'\r\n OnClick = PopupMenuClick\r\n end\r\n object MEnu2: TMenuItem\r\n Tag = 7\r\n Caption = 'Menu Text'\r\n OnClick = PopupMenuClick\r\n end\r\n object WindowText1: TMenuItem\r\n Tag = 8\r\n Caption = 'Window Text'\r\n OnClick = PopupMenuClick\r\n end\r\n object CaptionText1: TMenuItem\r\n Tag = 9\r\n Caption = 'Caption Text'\r\n OnClick = PopupMenuClick\r\n end\r\n object ActiveBorder1: TMenuItem\r\n Tag = 10\r\n Caption = 'Active Border'\r\n OnClick = PopupMenuClick\r\n end\r\n object InactiveBorder1: TMenuItem\r\n Tag = 11\r\n Caption = 'Inactive Border'\r\n OnClick = PopupMenuClick\r\n end\r\n object ApplicationWorkspace1: TMenuItem\r\n Tag = 12\r\n Caption = 'Application Workspace'\r\n OnClick = PopupMenuClick\r\n end\r\n object Highlight1: TMenuItem\r\n Tag = 13\r\n Caption = 'Highlight'\r\n OnClick = PopupMenuClick\r\n end\r\n object HighlightText1: TMenuItem\r\n Tag = 14\r\n Caption = 'Highlight Text'\r\n OnClick = PopupMenuClick\r\n end\r\n object ButtonFace1: TMenuItem\r\n Tag = 15\r\n Caption = 'Button Face'\r\n OnClick = PopupMenuClick\r\n end\r\n object ButtonShadow1: TMenuItem\r\n Tag = 16\r\n Caption = 'Button Shadow'\r\n OnClick = PopupMenuClick\r\n end\r\n object GrayText1: TMenuItem\r\n Tag = 17\r\n Caption = 'Gray Text'\r\n OnClick = PopupMenuClick\r\n end\r\n object ButtonText1: TMenuItem\r\n Tag = 18\r\n Caption = 'Button Text'\r\n OnClick = PopupMenuClick\r\n end\r\n object InactiveCaptionText1: TMenuItem\r\n Tag = 19\r\n Caption = 'Inactive Caption Text'\r\n OnClick = PopupMenuClick\r\n end\r\n object Highlight2: TMenuItem\r\n Tag = 20\r\n Caption = 'Highlight'\r\n OnClick = PopupMenuClick\r\n end\r\n object N3dDarkShadow1: TMenuItem\r\n Tag = 21\r\n Caption = '3D Dark Shadow'\r\n OnClick = PopupMenuClick\r\n end\r\n object N3DLight1: TMenuItem\r\n Tag = 22\r\n Caption = '3D Light'\r\n OnClick = PopupMenuClick\r\n end\r\n object InfoTipText1: TMenuItem\r\n Tag = 23\r\n Caption = 'Info Tip Text'\r\n OnClick = PopupMenuClick\r\n end\r\n object InfoTipBackground1: TMenuItem\r\n Tag = 24\r\n Caption = 'Info Tip Background'\r\n OnClick = PopupMenuClick\r\n end\r\n end\r\n object ImageList1: TImageList\r\n Left = 72\r\n Top = 368\r\n end\r\n object FontDialog: TFontDialog\r\n Font.Charset = DEFAULT_CHARSET\r\n Font.Color = clWindowText\r\n Font.Height = -11\r\n Font.Name = 'MS Sans Serif'\r\n Font.Style = []\r\n MinFontSize = 0\r\n MaxFontSize = 0\r\n Options = [fdEffects, fdFixedPitchOnly]\r\n Left = 104\r\n Top = 368\r\n end\r\nend\r\n" }, { "path": "External/SynEdit/Source/SynEditOptionsDialog.pas", "content": "{-------------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: SynEdit.pas, released 2000-04-07.\r\nThe Original Code is based on mwCustomEdit.pas by Martin Waldenburg, part of\r\nthe mwEdit component suite.\r\nPortions created by Martin Waldenburg are Copyright (C) 1998 Martin Waldenburg.\r\nAll Rights Reserved.\r\n\r\nContributors to the SynEdit and mwEdit projects are listed in the\r\nContributors.txt file.\r\n\r\nAlternatively, the contents of this file may be used under the terms of the\r\nGNU General Public License Version 2 or later (the \"GPL\"), in which case\r\nthe provisions of the GPL are applicable instead of those above.\r\nIf you wish to allow use of your version of this file only under the terms\r\nof the GPL and not to allow others to use your version of this file\r\nunder the MPL, indicate your decision by deleting the provisions above and\r\nreplace them with the notice and other provisions required by the GPL.\r\nIf you do not delete the provisions above, a recipient may use your version\r\nof this file under either the MPL or the GPL.\r\n\r\n$Id: SynEditOptionsDialog.pas,v 1.21.2.5 2005/07/20 13:37:18 maelh Exp $\r\n\r\nYou may retrieve the latest version of this file at the SynEdit home page,\r\nlocated at http://SynEdit.SourceForge.net\r\n\r\nKnown Issues:\r\n\r\n-------------------------------------------------------------------------------}\r\n\r\n{$IFNDEF QSYNEDITOPTIONSDIALOG}\r\nunit SynEditOptionsDialog;\r\n{$ENDIF}\r\n\r\n{$I SynEdit.inc}\r\n\r\ninterface\r\n\r\nuses\r\n{$IFDEF SYN_CLX}\r\n Qt,\r\n Types,\r\n QGraphics,\r\n QControls,\r\n QForms,\r\n QDialogs,\r\n QStdCtrls,\r\n QComCtrls,\r\n QExtCtrls,\r\n QButtons,\r\n QImgList,\r\n QMenus,\r\n QSynEdit,\r\n QSynEditHighlighter,\r\n QSynEditMiscClasses,\r\n QSynEditKeyCmds,\r\n{$ELSE}\r\n Windows,\r\n Messages,\r\n Graphics,\r\n Controls,\r\n Forms,\r\n Dialogs,\r\n StdCtrls,\r\n ComCtrls,\r\n CommCtrl,\r\n Registry,\r\n ExtCtrls,\r\n Buttons,\r\n {$IFDEF SYN_DELPHI_4_UP}\r\n ImgList,\r\n {$ENDIF}\r\n Menus,\r\n SynEdit,\r\n SynEditHighlighter,\r\n SynEditMiscClasses,\r\n SynEditKeyCmds,\r\n{$ENDIF}\r\n Classes,\r\n SysUtils;\r\n\r\ntype\r\n{$IFNDEF SYN_DELPHI_4_UP}\r\n TLVSelectItemEvent = procedure(Sender: TObject; Item: TListItem;\r\n Selected: Boolean) of object;\r\n{$ENDIF}\r\n\r\n TColorPopup = (cpGutter, cpRightEdge);\r\n \r\n TSynEditorOptionsUserCommand = procedure(AUserCommand: Integer;\r\n var ADescription: string) of object;\r\n\r\n //NOTE: in order for the user commands to be recorded correctly, you must\r\n // put the command itself in the object property.\r\n // you can do this like so:\r\n //\r\n // StringList.AddObject('ecSomeCommand', TObject(ecSomeCommand))\r\n //\r\n // where ecSomeCommand is the command that you want to add\r\n\r\n TSynEditorOptionsAllUserCommands = procedure(ACommands: TStrings) of object;\r\n\r\n TSynEditorOptionsContainer = class;\r\n\r\n TfmEditorOptionsDialog = class(TForm)\r\n PageControl1: TPageControl;\r\n btnOk: TButton;\r\n btnCancel: TButton;\r\n Display: TTabSheet;\r\n ColorDialog: TColorDialog;\r\n ColorPopup: TPopupMenu;\r\n None1: TMenuItem;\r\n Scrollbar1: TMenuItem;\r\n ActiveCaption1: TMenuItem;\r\n Background1: TMenuItem;\r\n InactiveCaption1: TMenuItem;\r\n Menu1: TMenuItem;\r\n Window1: TMenuItem;\r\n WindowFrame1: TMenuItem;\r\n MEnu2: TMenuItem;\r\n WindowText1: TMenuItem;\r\n CaptionText1: TMenuItem;\r\n ActiveBorder1: TMenuItem;\r\n InactiveBorder1: TMenuItem;\r\n ApplicationWorkspace1: TMenuItem;\r\n Highlight1: TMenuItem;\r\n HighlightText1: TMenuItem;\r\n ButtonFace1: TMenuItem;\r\n ButtonShadow1: TMenuItem;\r\n GrayText1: TMenuItem;\r\n ButtonText1: TMenuItem;\r\n InactiveCaptionText1: TMenuItem;\r\n Highlight2: TMenuItem;\r\n N3dDarkShadow1: TMenuItem;\r\n N3DLight1: TMenuItem;\r\n InfoTipText1: TMenuItem;\r\n InfoTipBackground1: TMenuItem;\r\n ImageList1: TImageList;\r\n Options: TTabSheet;\r\n Keystrokes: TTabSheet;\r\n gbBookmarks: TGroupBox;\r\n ckBookmarkKeys: TCheckBox;\r\n ckBookmarkVisible: TCheckBox;\r\n gbLineSpacing: TGroupBox;\r\n eLineSpacing: TEdit;\r\n gbGutter: TGroupBox;\r\n Label1: TLabel;\r\n ckGutterAutosize: TCheckBox;\r\n ckGutterShowLineNumbers: TCheckBox;\r\n ckGutterShowLeaderZeros: TCheckBox;\r\n ckGutterStartAtZero: TCheckBox;\r\n ckGutterVisible: TCheckBox;\r\n gbRightEdge: TGroupBox;\r\n Label3: TLabel;\r\n pRightEdgeBack: TPanel;\r\n eRightEdge: TEdit;\r\n gbEditorFont: TGroupBox;\r\n btnFont: TButton;\r\n gbOptions: TGroupBox;\r\n ckAutoIndent: TCheckBox;\r\n ckDragAndDropEditing: TCheckBox;\r\n ckAutoSizeMaxWidth: TCheckBox;\r\n ckHalfPageScroll: TCheckBox;\r\n ckEnhanceEndKey: TCheckBox;\r\n ckScrollByOneLess: TCheckBox;\r\n ckScrollPastEOF: TCheckBox;\r\n ckScrollPastEOL: TCheckBox;\r\n ckShowScrollHint: TCheckBox;\r\n ckSmartTabs: TCheckBox;\r\n ckTabsToSpaces: TCheckBox;\r\n ckTrimTrailingSpaces: TCheckBox;\r\n ckWantTabs: TCheckBox;\r\n gbCaret: TGroupBox;\r\n cInsertCaret: TComboBox;\r\n Label2: TLabel;\r\n Label4: TLabel;\r\n cOverwriteCaret: TComboBox;\r\n Panel3: TPanel;\r\n labFont: TLabel;\r\n FontDialog: TFontDialog;\r\n btnAddKey: TButton;\r\n btnRemKey: TButton;\r\n gbKeyStrokes: TGroupBox;\r\n Label5: TLabel;\r\n Label6: TLabel;\r\n Label7: TLabel;\r\n cKeyCommand: TComboBox;\r\n btnUpdateKey: TButton;\r\n ckAltSetsColumnMode: TCheckBox;\r\n ckKeepCaretX: TCheckBox;\r\n eTabWidth: TEdit;\r\n pRightEdgeColor: TPanel;\r\n Label8: TLabel;\r\n Label9: TLabel;\r\n Label10: TLabel;\r\n cbGutterFont: TCheckBox;\r\n btnGutterFont: TButton;\r\n btnRightEdge: TPanel;\r\n Image1: TImage;\r\n pGutterBack: TPanel;\r\n pGutterColor: TPanel;\r\n btnGutterColor: TPanel;\r\n Image2: TImage;\r\n ckScrollHintFollows: TCheckBox;\r\n ckGroupUndo: TCheckBox;\r\n ckSmartTabDelete: TCheckBox;\r\n ckRightMouseMoves: TCheckBox;\r\n pnlGutterFontDisplay: TPanel;\r\n lblGutterFont: TLabel;\r\n ckEnhanceHomeKey: TCheckBox;\r\n pnlCommands: TPanel;\r\n KeyList: TListView;\r\n ckHideShowScrollbars: TCheckBox;\r\n ckDisableScrollArrows: TCheckBox;\r\n ckShowSpecialChars: TCheckBox;\r\n procedure PopupMenuClick(Sender: TObject);\r\n procedure FormCreate(Sender: TObject);\r\n procedure pGutterColorClick(Sender: TObject);\r\n procedure pRightEdgeColorClick(Sender: TObject);\r\n procedure btnFontClick(Sender: TObject);\r\n procedure KeyListSelectItem(Sender: TObject; Item: TListItem;\r\n Selected: Boolean);\r\n procedure btnUpdateKeyClick(Sender: TObject);\r\n procedure btnAddKeyClick(Sender: TObject);\r\n procedure btnRemKeyClick(Sender: TObject);\r\n procedure FormShow(Sender: TObject);\r\n procedure KeyListEditing(Sender: TObject; Item: TListItem;\r\n var AllowEdit: Boolean);\r\n procedure btnOkClick(Sender: TObject);\r\n procedure btnGutterFontClick(Sender: TObject);\r\n procedure cbGutterFontClick(Sender: TObject);\r\n procedure btnRightEdgeMouseDown(Sender: TObject; Button: TMouseButton;\r\n Shift: TShiftState; X, Y: Integer);\r\n procedure btnGutterColorMouseDown(Sender: TObject;\r\n Button: TMouseButton; Shift: TShiftState; X, Y: Integer);\r\n procedure cKeyCommandExit(Sender: TObject);\r\n procedure cKeyCommandKeyPress(Sender: TObject; var Key: Char);\r\n procedure cKeyCommandKeyUp(Sender: TObject; var Key: Word;\r\n Shift: TShiftState);\r\n procedure KeyListChanging(Sender: TObject; Item: TListItem;\r\n Change: TItemChange; var AllowChange: Boolean);\r\n private\r\n FSynEdit: TSynEditorOptionsContainer;\r\n FPoppedFrom : TColorPopup;\r\n FUserCommand: TSynEditorOptionsUserCommand;\r\n FAllUserCommands: TSynEditorOptionsAllUserCommands;\r\n\r\n OldSelected: TListItem;\r\n InChanging: Boolean;\r\n FExtended: Boolean;\r\n\r\n {$IFNDEF SYN_COMPILER_4_UP}\r\n FOldWndProc: TWndMethod;\r\n procedure OverridingWndProc(var Message: TMessage);\r\n {$ENDIF}\r\n\r\n function GetColor(Item : TMenuItem) : TColor;\r\n procedure GetData;\r\n procedure PutData;\r\n procedure EditStrCallback(const S: string);\r\n procedure FillInKeystrokeInfo(AKey: TSynEditKeystroke; AItem: TListItem);\r\n public\r\n eKeyShort2: TSynHotKey;\r\n eKeyShort1: TSynHotKey;\r\n {$IFNDEF SYN_DELPHI_4_UP}\r\n FOnSelectItem: TLVSelectItemEvent;\r\n {$ENDIF}\r\n\r\n function Execute(EditOptions : TSynEditorOptionsContainer) : Boolean;\r\n property GetUserCommandNames: TSynEditorOptionsUserCommand read FUserCommand\r\n write FUserCommand;\r\n property GetAllUserCommands: TSynEditorOptionsAllUserCommands\r\n read FAllUserCommands\r\n write FAllUserCommands;\r\n property UseExtendedStrings: Boolean read FExtended write FExtended;\r\n end;\r\n\r\n TSynEditOptionsDialog = class(TComponent)\r\n private\r\n FForm: TfmEditorOptionsDialog;\r\n function GetUserCommandNames: TSynEditorOptionsUserCommand;\r\n procedure SetUserCommandNames(\r\n const Value: TSynEditorOptionsUserCommand);\r\n function GetUserCommands: TSynEditorOptionsAllUserCommands;\r\n procedure SetUserCommands(\r\n const Value: TSynEditorOptionsAllUserCommands);\r\n function GetExtended: Boolean;\r\n procedure SetExtended(const Value: Boolean);\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n function Execute(EditOptions : TSynEditorOptionsContainer) : Boolean;\r\n property Form: TfmEditorOptionsDialog read FForm;\r\n published\r\n property GetUserCommand: TSynEditorOptionsUserCommand\r\n read GetUserCommandNames\r\n write SetUserCommandNames;\r\n property GetAllUserCommands: TSynEditorOptionsAllUserCommands\r\n read GetUserCommands\r\n write SetUserCommands;\r\n property UseExtendedStrings: Boolean read GetExtended write SetExtended;\r\n end;\r\n\r\n //This class is assignable to a SynEdit without modifying key properties that affect function\r\n TSynEditorOptionsContainer = class(TComponent)\r\n private\r\n FHideSelection: Boolean;\r\n FWantTabs: Boolean;\r\n FMaxUndo: Integer;\r\n FExtraLineSpacing: Integer;\r\n FTabWidth: Integer;\r\n FMaxScrollWidth: Integer;\r\n FRightEdge: Integer;\r\n FSelectedColor: TSynSelectedColor;\r\n FRightEdgeColor: TColor;\r\n FFont: TFont;\r\n FBookmarks: TSynBookMarkOpt;\r\n FOverwriteCaret: TSynEditCaretType;\r\n FInsertCaret: TSynEditCaretType;\r\n FKeystrokes: TSynEditKeyStrokes;\r\n FOptions: TSynEditorOptions;\r\n FSynGutter: TSynGutter;\r\n FColor: TColor;\r\n procedure SetBookMarks(const Value: TSynBookMarkOpt);\r\n procedure SetFont(const Value: TFont);\r\n procedure SetKeystrokes(const Value: TSynEditKeyStrokes);\r\n procedure SetOptions(const Value: TSynEditorOptions);\r\n procedure SetSynGutter(const Value: TSynGutter);\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n procedure Assign(Source : TPersistent); override;\r\n procedure AssignTo(Dest : TPersistent); override;\r\n published\r\n property Options : TSynEditorOptions read FOptions write SetOptions;\r\n property BookMarkOptions : TSynBookMarkOpt read FBookmarks write SetBookMarks;\r\n property Color : TColor read FColor write FColor;\r\n property Font : TFont read FFont write SetFont;\r\n property ExtraLineSpacing : Integer read FExtraLineSpacing write FExtraLineSpacing;\r\n property Gutter : TSynGutter read FSynGutter write SetSynGutter;\r\n property RightEdge : Integer read FRightEdge write FRightEdge;\r\n property RightEdgeColor : TColor read FRightEdgeColor write FRightEdgeColor;\r\n property WantTabs : Boolean read FWantTabs write FWantTabs;\r\n property InsertCaret : TSynEditCaretType read FInsertCaret write FInsertCaret;\r\n property OverwriteCaret : TSynEditCaretType read FOverwriteCaret write FOverwriteCaret;\r\n property HideSelection : Boolean read FHideSelection write FHideSelection;\r\n property MaxScrollWidth : Integer read FMaxScrollWidth write FMaxScrollWidth;\r\n property MaxUndo : Integer read FMaxUndo write FMaxUndo;\r\n property SelectedColor : TSynSelectedColor read FSelectedColor write FSelectedColor;\r\n property TabWidth : Integer read FTabWidth write FTabWidth;\r\n property Keystrokes : TSynEditKeyStrokes read FKeystrokes write SetKeystrokes;\r\n end;\r\n\r\nimplementation\r\n\r\n{$R *.dfm}\r\n\r\nuses\r\n{$IFDEF SYN_CLX}\r\n QSynEditKeyConst;\r\n{$ELSE}\r\n SynEditKeyConst;\r\n{$ENDIF}\r\n\r\n{ TSynEditOptionsDialog }\r\n\r\nconstructor TSynEditOptionsDialog.create(AOwner: TComponent);\r\nbegin\r\n inherited;\r\n FForm:= TfmEditorOptionsDialog.Create(Self);\r\nend;\r\n\r\ndestructor TSynEditOptionsDialog.destroy;\r\nbegin\r\n FForm.Free;\r\n inherited;\r\nend;\r\n\r\nfunction TSynEditOptionsDialog.Execute(EditOptions : TSynEditorOptionsContainer) : Boolean;\r\nbegin\r\n Result:= FForm.Execute(EditOptions);\r\nend;\r\n\r\nfunction TSynEditOptionsDialog.GetUserCommands: TSynEditorOptionsAllUserCommands;\r\nbegin\r\n Result := FForm.GetAllUserCommands;\r\nend;\r\n\r\nfunction TSynEditOptionsDialog.GetUserCommandNames: TSynEditorOptionsUserCommand;\r\nbegin\r\n Result := FForm.GetUserCommandNames\r\nend;\r\n\r\nprocedure TSynEditOptionsDialog.SetUserCommands(\r\n const Value: TSynEditorOptionsAllUserCommands);\r\nbegin\r\n FForm.GetAllUserCommands := Value;\r\nend;\r\n\r\nprocedure TSynEditOptionsDialog.SetUserCommandNames(\r\n const Value: TSynEditorOptionsUserCommand);\r\nbegin\r\n FForm.GetUserCommandNames := Value;\r\nend;\r\n\r\nfunction TSynEditOptionsDialog.GetExtended: Boolean;\r\nbegin\r\n Result := FForm.UseExtendedStrings;\r\nend;\r\n\r\nprocedure TSynEditOptionsDialog.SetExtended(const Value: Boolean);\r\nbegin\r\n FForm.UseExtendedStrings := Value;\r\nend;\r\n\r\n{ TSynEditorOptionsContainer }\r\n\r\nprocedure TSynEditorOptionsContainer.Assign(Source: TPersistent);\r\nbegin\r\n if Assigned(Source) and (Source is TCustomSynEdit) then\r\n begin\r\n Self.Font.Assign(TCustomSynEdit(Source).Font);\r\n Self.BookmarkOptions.Assign(TCustomSynEdit(Source).BookmarkOptions);\r\n Self.Gutter.Assign(TCustomSynEdit(Source).Gutter);\r\n Self.Keystrokes.Assign(TCustomSynEdit(Source).Keystrokes);\r\n Self.SelectedColor.Assign(TCustomSynEdit(Source).SelectedColor);\r\n\r\n Self.Color := TCustomSynEdit(Source).Color;\r\n Self.Options := TCustomSynEdit(Source).Options;\r\n Self.ExtraLineSpacing := TCustomSynEdit(Source).ExtraLineSpacing;\r\n Self.HideSelection := TCustomSynEdit(Source).HideSelection;\r\n Self.InsertCaret := TCustomSynEdit(Source).InsertCaret;\r\n Self.OverwriteCaret := TCustomSynEdit(Source).OverwriteCaret;\r\n Self.MaxScrollWidth := TCustomSynEdit(Source).MaxScrollWidth;\r\n Self.MaxUndo := TCustomSynEdit(Source).MaxUndo;\r\n Self.RightEdge := TCustomSynEdit(Source).RightEdge;\r\n Self.RightEdgeColor := TCustomSynEdit(Source).RightEdgeColor;\r\n Self.TabWidth := TCustomSynEdit(Source).TabWidth;\r\n Self.WantTabs := TCustomSynEdit(Source).WantTabs;\r\n end else\r\n inherited;\r\nend;\r\n\r\nprocedure TSynEditorOptionsContainer.AssignTo(Dest: TPersistent);\r\nbegin\r\n if Assigned(Dest) and (Dest is TCustomSynEdit) then\r\n begin\r\n TCustomSynEdit(Dest).Font.Assign(Self.Font);\r\n TCustomSynEdit(Dest).BookmarkOptions.Assign(Self.BookmarkOptions);\r\n TCustomSynEdit(Dest).Gutter.Assign(Self.Gutter);\r\n TCustomSynEdit(Dest).Keystrokes.Assign(Self.Keystrokes);\r\n TCustomSynEdit(Dest).SelectedColor.Assign(Self.SelectedColor);\r\n\r\n TCustomSynEdit(Dest).Color := Self.Color;\r\n TCustomSynEdit(Dest).Options := Self.Options;\r\n TCustomSynEdit(Dest).ExtraLineSpacing := Self.ExtraLineSpacing;\r\n TCustomSynEdit(Dest).HideSelection := Self.HideSelection;\r\n TCustomSynEdit(Dest).InsertCaret := Self.InsertCaret;\r\n TCustomSynEdit(Dest).OverwriteCaret := Self.OverwriteCaret;\r\n TCustomSynEdit(Dest).MaxScrollWidth := Self.MaxScrollWidth;\r\n TCustomSynEdit(Dest).MaxUndo := Self.MaxUndo;\r\n TCustomSynEdit(Dest).RightEdge := Self.RightEdge;\r\n TCustomSynEdit(Dest).RightEdgeColor := Self.RightEdgeColor;\r\n TCustomSynEdit(Dest).TabWidth := Self.TabWidth;\r\n TCustomSynEdit(Dest).WantTabs := Self.WantTabs;\r\n end else\r\n inherited;\r\nend;\r\n\r\nconstructor TSynEditorOptionsContainer.create(AOwner: TComponent);\r\nbegin\r\n inherited;\r\n FBookmarks:= TSynBookMarkOpt.Create(Self);\r\n FKeystrokes:= TSynEditKeyStrokes.Create(Self);\r\n FSynGutter:= TSynGutter.Create;\r\n FSelectedColor:= TSynSelectedColor.Create;\r\n FSelectedColor.Foreground:= clHighlightText;\r\n FSelectedColor.Background:= clHighlight;\r\n FFont:= TFont.Create;\r\n FFont.Name:= 'Courier New';\r\n FFont.Size:= 8;\r\n Color:= clWindow;\r\n Keystrokes.ResetDefaults;\r\n Options := [eoAutoIndent,eoDragDropEditing,eoDropFiles,eoScrollPastEol,\r\n eoShowScrollHint,eoSmartTabs,eoAltSetsColumnMode, eoTabsToSpaces,eoTrimTrailingSpaces, eoKeepCaretX];\r\n ExtraLineSpacing := 0;\r\n HideSelection := False;\r\n InsertCaret := ctVerticalLine;\r\n OverwriteCaret := ctBlock;\r\n MaxScrollWidth := 1024;\r\n MaxUndo := 1024;\r\n RightEdge := 80;\r\n RightEdgeColor := clSilver;\r\n TabWidth := 8;\r\n WantTabs := True;\r\nend;\r\n\r\ndestructor TSynEditorOptionsContainer.destroy;\r\nbegin\r\n FBookMarks.Free;\r\n FKeyStrokes.Free;\r\n FSynGutter.Free;\r\n FSelectedColor.Free;\r\n FFont.Free;\r\n inherited;\r\nend;\r\n\r\nprocedure TSynEditorOptionsContainer.SetBookMarks(\r\n const Value: TSynBookMarkOpt);\r\nbegin\r\n FBookmarks.Assign(Value);\r\nend;\r\n\r\nprocedure TSynEditorOptionsContainer.SetFont(const Value: TFont);\r\nbegin\r\n FFont.Assign(Value);\r\nend;\r\n\r\nprocedure TSynEditorOptionsContainer.SetKeystrokes(\r\n const Value: TSynEditKeyStrokes);\r\nbegin\r\n FKeystrokes.Assign(Value);\r\nend;\r\n\r\nprocedure TSynEditorOptionsContainer.SetOptions(\r\n const Value: TSynEditorOptions);\r\nbegin\r\n FOptions:= Value;\r\nend;\r\n\r\nprocedure TSynEditorOptionsContainer.SetSynGutter(const Value: TSynGutter);\r\nbegin\r\n FSynGutter.Assign(Value);\r\nend;\r\n\r\n{ TfmEditorOptionsDialog }\r\n\r\nfunction TfmEditorOptionsDialog.Execute(EditOptions : TSynEditorOptionsContainer) : Boolean;\r\nbegin\r\n if (EditOptions = nil) then\r\n begin\r\n Result:= False;\r\n Exit;\r\n end;\r\n //Assign the Containers\r\n FSynEdit:= EditOptions;\r\n //Get Data\r\n GetData;\r\n //Show the form\r\n Result:= Showmodal = mrOk;\r\n //PutData\r\n if Result then PutData;\r\nend;\r\n\r\n\r\nprocedure TfmEditorOptionsDialog.GetData;\r\nvar I : Integer;\r\n Item : TListItem;\r\nbegin\r\n //Gutter\r\n ckGutterVisible.Checked:= FSynEdit.Gutter.Visible;\r\n ckGutterAutosize.Checked:= FSynEdit.Gutter.AutoSize;\r\n ckGutterShowLineNumbers.Checked:= FSynEdit.Gutter.ShowLineNumbers;\r\n ckGutterShowLeaderZeros.Checked:= FSynEdit.Gutter.LeadingZeros;\r\n ckGutterStartAtZero.Checked:= FSynEdit.Gutter.ZeroStart;\r\n cbGutterFont.Checked := FSynEdit.Gutter.UseFontStyle;\r\n pGutterColor.Color:= FSynEdit.Gutter.Color;\r\n lblGutterFont.Font.Assign(FSynEdit.Gutter.Font);\r\n lblGutterFont.Caption:= lblGutterFont.Font.Name + ' ' + IntToStr(lblGutterFont.Font.Size) + 'pt'; \r\n //Right Edge\r\n eRightEdge.Text:= IntToStr(FSynEdit.RightEdge);\r\n pRightEdgeColor.Color:= FSynEdit.RightEdgeColor;\r\n //Line Spacing\r\n eLineSpacing.Text:= IntToStr(FSynEdit.ExtraLineSpacing);\r\n eTabWidth.Text:= IntToStr(FSynEdit.TabWidth);\r\n //Bookmarks\r\n ckBookmarkKeys.Checked:= FSynEdit.BookMarkOptions.EnableKeys;\r\n ckBookmarkVisible.Checked:= FSynEdit.BookMarkOptions.GlyphsVisible;\r\n //Font\r\n labFont.Font.Assign(FSynEdit.Font);\r\n labFont.Caption:= labFont.Font.Name + ' ' + IntToStr(labFont.Font.Size) + 'pt';\r\n //Options\r\n ckAutoIndent.Checked:= eoAutoIndent in FSynEdit.Options;\r\n ckAutoSizeMaxWidth.Checked:= eoAutoSizeMaxScrollWidth in FSynEdit.Options;\r\n ckDragAndDropEditing.Checked:= eoDragDropEditing in FSynEdit.Options;\r\n ckWantTabs.Checked:= FSynEdit.WantTabs;\r\n ckSmartTabs.Checked:= eoSmartTabs in FSynEdit.Options;\r\n ckAltSetsColumnMode.Checked:= eoAltSetsColumnMode in FSynEdit.Options;\r\n ckHalfPageScroll.Checked:= eoHalfPageScroll in FSynEdit.Options;\r\n ckScrollByOneLess.Checked:= eoScrollByOneLess in FSynEdit.Options;\r\n ckScrollPastEOF.Checked:= eoScrollPastEof in FSynEdit.Options;\r\n ckScrollPastEOL.Checked:= eoScrollPastEol in FSynEdit.Options;\r\n ckShowScrollHint.Checked:= eoShowScrollHint in FSynEdit.Options;\r\n ckTabsToSpaces.Checked:= eoTabsToSpaces in FSynEdit.Options;\r\n ckTrimTrailingSpaces.Checked:= eoTrimTrailingSpaces in FSynEdit.Options;\r\n ckKeepCaretX.Checked:= eoKeepCaretX in FSynEdit.Options;\r\n ckSmartTabDelete.Checked := eoSmartTabDelete in FSynEdit.Options;\r\n ckRightMouseMoves.Checked := eoRightMouseMovesCursor in FSynEdit.Options;\r\n ckEnhanceHomeKey.Checked := eoEnhanceHomeKey in FSynEdit.Options;\r\n ckEnhanceEndKey.Checked := eoEnhanceEndKey in FSynEdit.Options;\r\n ckGroupUndo.Checked := eoGroupUndo in FSynEdit.Options;\r\n ckDisableScrollArrows.Checked := eoDisableScrollArrows in FSynEdit.Options;\r\n ckHideShowScrollbars.Checked := eoHideShowScrollbars in FSynEdit.Options;\r\n ckShowSpecialChars.Checked := eoShowSpecialChars in FSynEdit.Options;\r\n\r\n //Caret\r\n cInsertCaret.ItemIndex:= ord(FSynEdit.InsertCaret);\r\n cOverwriteCaret.ItemIndex:= ord(FSynEdit.OverwriteCaret);\r\n\r\n\r\n KeyList.Items.BeginUpdate;\r\n try\r\n KeyList.Items.Clear;\r\n for I:= 0 to FSynEdit.Keystrokes.Count-1 do\r\n begin\r\n Item:= KeyList.Items.Add;\r\n FillInKeystrokeInfo(FSynEdit.Keystrokes.Items[I], Item);\r\n Item.Data:= FSynEdit.Keystrokes.Items[I];\r\n end;\r\n if (KeyList.Items.Count > 0) then KeyList.Items[0].Selected:= True;\r\n finally\r\n KeyList.Items.EndUpdate;\r\n end;\r\nend;\r\n\r\nprocedure TfmEditorOptionsDialog.PutData;\r\nvar\r\n vOptions: TSynEditorOptions;\r\n\r\n procedure SetFlag(aOption: TSynEditorOption; aValue: Boolean);\r\n begin\r\n if aValue then\r\n Include(vOptions, aOption)\r\n else\r\n Exclude(vOptions, aOption);\r\n end;\r\n\r\nbegin\r\n //Gutter\r\n FSynEdit.Gutter.Visible:= ckGutterVisible.Checked;\r\n FSynEdit.Gutter.AutoSize := ckGutterAutosize.Checked;\r\n FSynEdit.Gutter.ShowLineNumbers:= ckGutterShowLineNumbers.Checked;\r\n FSynEdit.Gutter.LeadingZeros:= ckGutterShowLeaderZeros.Checked;\r\n FSynEdit.Gutter.ZeroStart:= ckGutterStartAtZero.Checked;\r\n FSynEdit.Gutter.Color:= pGutterColor.Color;\r\n FSynEdit.Gutter.UseFontStyle := cbGutterFont.Checked;\r\n FSynEdit.Gutter.Font.Assign(lblGutterFont.Font);\r\n //Right Edge\r\n FSynEdit.RightEdge:= StrToIntDef(eRightEdge.Text, 80);\r\n FSynEdit.RightEdgeColor:= pRightEdgeColor.Color;\r\n //Line Spacing\r\n FSynEdit.ExtraLineSpacing:= StrToIntDef(eLineSpacing.Text, 0);\r\n FSynEdit.TabWidth:= StrToIntDef(eTabWidth.Text, 8);\r\n //Bookmarks\r\n FSynEdit.BookMarkOptions.EnableKeys:= ckBookmarkKeys.Checked;\r\n FSynEdit.BookMarkOptions.GlyphsVisible:= ckBookmarkVisible.Checked;\r\n //Font\r\n FSynEdit.Font.Assign(labFont.Font);\r\n //Options\r\n FSynEdit.WantTabs:= ckWantTabs.Checked;\r\n vOptions := FSynEdit.Options; //Keep old values for unsupported options\r\n SetFlag(eoAutoIndent, ckAutoIndent.Checked);\r\n SetFlag(eoAutoSizeMaxScrollWidth, ckAutoSizeMaxWidth.Checked);\r\n SetFlag(eoDragDropEditing, ckDragAndDropEditing.Checked);\r\n SetFlag(eoSmartTabs, ckSmartTabs.Checked);\r\n SetFlag(eoAltSetsColumnMode, ckAltSetsColumnMode.Checked);\r\n SetFlag(eoHalfPageScroll, ckHalfPageScroll.Checked);\r\n SetFlag(eoScrollByOneLess, ckScrollByOneLess.Checked);\r\n SetFlag(eoScrollPastEof, ckScrollPastEOF.Checked);\r\n SetFlag(eoScrollPastEol, ckScrollPastEOL.Checked);\r\n SetFlag(eoShowScrollHint, ckShowScrollHint.Checked);\r\n SetFlag(eoTabsToSpaces, ckTabsToSpaces.Checked);\r\n SetFlag(eoTrimTrailingSpaces, ckTrimTrailingSpaces.Checked);\r\n SetFlag(eoKeepCaretX, ckKeepCaretX.Checked);\r\n SetFlag(eoSmartTabDelete, ckSmartTabDelete.Checked);\r\n SetFlag(eoRightMouseMovesCursor, ckRightMouseMoves.Checked);\r\n SetFlag(eoEnhanceHomeKey, ckEnhanceHomeKey.Checked);\r\n SetFlag(eoEnhanceEndKey, ckEnhanceEndKey.Checked);\r\n SetFlag(eoGroupUndo, ckGroupUndo.Checked);\r\n SetFlag(eoDisableScrollArrows, ckDisableScrollArrows.Checked);\r\n SetFlag(eoHideShowScrollbars, ckHideShowScrollbars.Checked);\r\n SetFlag(eoShowSpecialChars, ckShowSpecialChars.Checked);\r\n FSynEdit.Options := vOptions;\r\n //Caret\r\n FSynEdit.InsertCaret:= TSynEditCaretType(cInsertCaret.ItemIndex);\r\n FSynEdit.OverwriteCaret:= TSynEditCaretType(cOverwriteCaret.ItemIndex);\r\nend;\r\n\r\nfunction TfmEditorOptionsDialog.GetColor(Item: TMenuItem): TColor;\r\nbegin\r\n if (Item.Tag = -1) or (Item.Tag > 24) then\r\n Result:= clNone\r\n else\r\n Result:= TColor(Byte(Item.Tag) or $80000000);\r\nend;\r\n\r\nprocedure TfmEditorOptionsDialog.PopupMenuClick(Sender: TObject);\r\nvar C : TColor;\r\nbegin\r\n C:= GetColor(TMenuItem(Sender));\r\n //Set the color based on where it was \"popped from\"\r\n if (FPoppedFrom = cpGutter) then\r\n pGutterColor.Color:= C\r\n else if (FPoppedFrom = cpRightEdge) then\r\n pRightEdgeColor.Color:= C;\r\nend;\r\n\r\nprocedure TfmEditorOptionsDialog.FormCreate(Sender: TObject);\r\nvar I : Integer;\r\n C : TColor;\r\n B : TBitmap;\r\nbegin\r\n {$IFDEF SYN_COMPILER_4_UP}\r\n KeyList.OnSelectItem := KeyListSelectItem;\r\n {$ELSE}\r\n FOldWndProc := KeyList.WindowProc;\r\n KeyList.WindowProc := OverridingWndProc;\r\n FOnSelectItem := KeyListSelectItem;\r\n {$ENDIF}\r\n\r\n InChanging := False;\r\n B:= TBitmap.Create;\r\n try\r\n B.Width:= 16;\r\n B.Height:= 16;\r\n //Loop through and create colored images\r\n for I:= 0 to ColorPopup.Items.Count-1 do\r\n begin\r\n if ColorPopup.Items[I].Tag = -1 then Continue;\r\n C:= GetColor(ColorPopup.Items[I]);\r\n B.Canvas.Brush.Color:= C;\r\n B.Canvas.Brush.Style:= bsSolid;\r\n B.Canvas.Pen.Style:= psSolid;\r\n B.Canvas.Pen.Color:= clBlack;\r\n B.Canvas.Rectangle(0,0,16,16);\r\n ImageList1.Add(B, nil);\r\n{$IFDEF SYN_COMPILER_4_UP}\r\n ColorPopup.Items[I].ImageIndex:= ColorPopup.Items[I].Tag;\r\n{$ENDIF}\r\n end;\r\n finally\r\n B.Free;\r\n end;\r\n\r\n eKeyShort1:= TSynHotKey.Create(Self);\r\n with eKeyShort1 do\r\n begin\r\n Parent := gbKeystrokes;\r\n Left := 120;\r\n Top := 55;\r\n Width := 185;\r\n Height := 21;\r\n HotKey := 0;\r\n InvalidKeys := [];\r\n Modifiers := [];\r\n TabOrder := 1;\r\n end;\r\n\r\n eKeyShort2:= TSynHotKey.Create(Self);\r\n with eKeyShort2 do\r\n begin\r\n Parent := gbKeystrokes;\r\n Left := 120;\r\n Top := 87;\r\n Width := 185;\r\n Height := 21;\r\n HotKey := 0;\r\n InvalidKeys := [];\r\n Modifiers := [];\r\n TabOrder := 2;\r\n end;\r\nend;\r\n\r\nprocedure TfmEditorOptionsDialog.pGutterColorClick(Sender: TObject);\r\nbegin\r\n ColorDialog.Color:= pGutterColor.Color;\r\n if (ColorDialog.Execute) then\r\n begin\r\n pGutterColor.Color:= ColorDialog.Color;\r\n end;\r\nend;\r\n\r\nprocedure TfmEditorOptionsDialog.pRightEdgeColorClick(Sender: TObject);\r\nbegin\r\n ColorDialog.Color:= pRightEdgeColor.Color;\r\n if (ColorDialog.Execute) then\r\n begin\r\n pRightEdgeColor.Color:= ColorDialog.Color;\r\n end;\r\nend;\r\n\r\nprocedure TfmEditorOptionsDialog.btnFontClick(Sender: TObject);\r\nbegin\r\n FontDialog.Font.Assign(labFont.Font);\r\n if FontDialog.Execute then\r\n begin\r\n labFont.Font.Assign(FontDialog.Font);\r\n labFont.Caption:= labFont.Font.Name;\r\n labFont.Caption:= labFont.Font.Name + ' ' + IntToStr(labFont.Font.Size) + 'pt'; \r\n end;\r\nend;\r\n\r\nprocedure TfmEditorOptionsDialog.KeyListSelectItem(Sender: TObject;\r\n Item: TListItem; Selected: Boolean);\r\nbegin\r\n if KeyList.Selected = nil then Exit;\r\n cKeyCommand.Text := KeyList.Selected.Caption;\r\n cKeyCommand.ItemIndex := cKeyCommand.Items.IndexOf(KeyList.Selected.Caption);\r\n eKeyShort1.HotKey := TSynEditKeyStroke(KeyList.Selected.Data).ShortCut;\r\n eKeyShort2.HotKey := TSynEditKeyStroke(KeyList.Selected.Data).ShortCut2;\r\n OldSelected := Item;\r\nend;\r\n\r\nprocedure TfmEditorOptionsDialog.btnUpdateKeyClick(Sender: TObject);\r\nvar Cmd : Integer;\r\n{ KeyLoc : Integer;\r\n TmpCommand : string;\r\n OldShortcut : TShortcut;\r\n OldShortcut2 : TShortcut;\r\n}\r\nbegin\r\n if (KeyList.Selected = nil) and (Sender <> btnAddKey) then\r\n begin\r\n btnAddKey.Click;\r\n Exit;\r\n end;\r\n\r\n if KeyList.Selected = nil then Exit;\r\n if cKeyCommand.ItemIndex < 0 then Exit;\r\n\r\n Cmd := Integer(cKeyCommand.Items.Objects[cKeyCommand.ItemIndex]);\r\n\r\n TSynEditKeyStroke(OldSelected.Data).Command:= Cmd;\r\n\r\n if eKeyShort1.HotKey <> 0 then\r\n TSynEditKeyStroke(OldSelected.Data).ShortCut := eKeyShort1.HotKey;\r\n\r\n if eKeyShort2.HotKey <> 0 then\r\n TSynEditKeyStroke(OldSelected.Data).ShortCut2:= eKeyShort2.HotKey;\r\n\r\n FillInKeystrokeInfo(TSynEditKeyStroke(OldSelected.Data), KeyList.Selected);\r\nend;\r\n\r\nprocedure TfmEditorOptionsDialog.btnAddKeyClick(Sender: TObject);\r\nvar Item : TListItem;\r\nbegin\r\n Item:= KeyList.Items.Add;\r\n Item.Data:= FSynEdit.Keystrokes.Add;\r\n Item.Selected:= True;\r\n btnUpdateKeyClick(btnAddKey);\r\nend;\r\n\r\nprocedure TfmEditorOptionsDialog.btnRemKeyClick(Sender: TObject);\r\nbegin\r\n if KeyList.Selected = nil then Exit;\r\n TSynEditKeyStroke(KeyList.Selected.Data).Free;\r\n KeyList.Selected.Delete;\r\nend;\r\n\r\nprocedure TfmEditorOptionsDialog.EditStrCallback(const S: string);\r\nbegin\r\n //Add the Item\r\n if FExtended then\r\n cKeyCommand.Items.AddObject(S, TObject(ConvertExtendedToCommand(S)))\r\n else cKeyCommand.Items.AddObject(S, TObject(ConvertCodeStringToCommand(S)));\r\nend;\r\n\r\nprocedure TfmEditorOptionsDialog.FormShow(Sender: TObject);\r\nvar Commands: TStringList;\r\n i : Integer;\r\nbegin\r\n//We need to do this now because it will not have been assigned when\r\n//create occurs\r\n cKeyCommand.Items.Clear;\r\n //Start the callback to add the strings\r\n if FExtended then\r\n GetEditorCommandExtended(EditStrCallback)\r\n else\r\n GetEditorCommandValues(EditStrCallBack);\r\n //Now add in the user defined ones if they have any\r\n if Assigned(FAllUserCommands) then\r\n begin\r\n Commands := TStringList.Create;\r\n try\r\n FAllUserCommands(Commands);\r\n for i := 0 to Commands.Count - 1 do\r\n if Commands.Objects[i] <> nil then\r\n cKeyCommand.Items.AddObject(Commands[i], Commands.Objects[i]);\r\n finally\r\n Commands.Free;\r\n end;\r\n end;\r\n\r\n PageControl1.ActivePage := PageControl1.Pages[0];\r\nend;\r\n\r\nprocedure TfmEditorOptionsDialog.KeyListEditing(Sender: TObject;\r\n Item: TListItem; var AllowEdit: Boolean);\r\nbegin\r\n AllowEdit:= False;\r\nend;\r\n\r\n\r\nprocedure TfmEditorOptionsDialog.btnOkClick(Sender: TObject);\r\nbegin\r\n btnUpdateKey.Click;\r\n ModalResult:= mrOk;\r\nend;\r\n\r\nprocedure TfmEditorOptionsDialog.btnGutterFontClick(Sender: TObject);\r\nbegin\r\n FontDialog.Font.Assign(lblGutterFont.Font);\r\n if FontDialog.Execute then\r\n begin\r\n lblGutterFont.Font.Assign(FontDialog.Font);\r\n lblGutterFont.Caption:= lblGutterFont.Font.Name + ' ' + IntToStr(lblGutterFont.Font.Size) + 'pt';\r\n end;\r\nend;\r\n\r\nprocedure TfmEditorOptionsDialog.cbGutterFontClick(Sender: TObject);\r\nbegin\r\n lblGutterFont.Enabled := cbGutterFont.Checked;\r\n btnGutterFont.Enabled := cbGutterFont.Checked;\r\nend;\r\n\r\nprocedure TfmEditorOptionsDialog.btnRightEdgeMouseDown(Sender: TObject;\r\n Button: TMouseButton; Shift: TShiftState; X, Y: Integer);\r\nvar P : TPoint;\r\nbegin\r\n FPoppedFrom:= cpRightEdge;\r\n P:= pRightEdgeColor.ClientToScreen(Point(-1, pRightEdgeColor.Height-1));\r\n btnRightEdge.BevelOuter := bvLowered;\r\n ColorPopup.Popup(P.X, P.Y);\r\n btnRightEdge.BevelOuter := bvNone;\r\nend;\r\n\r\nprocedure TfmEditorOptionsDialog.btnGutterColorMouseDown(Sender: TObject;\r\n Button: TMouseButton; Shift: TShiftState; X, Y: Integer);\r\nvar P : TPoint;\r\nbegin\r\n FPoppedFrom:= cpGutter;\r\n P:= pGutterColor.ClientToScreen(Point(-1, pGutterColor.Height-1));\r\n btnGutterColor.BevelOuter := bvLowered;\r\n ColorPopup.Popup(P.X, P.Y);\r\n btnGutterColor.BevelOuter := bvNone;\r\nend;\r\n\r\nprocedure TfmEditorOptionsDialog.FillInKeystrokeInfo(\r\n AKey: TSynEditKeystroke; AItem: TListItem);\r\nvar TmpString: String;\r\nbegin\r\n with AKey do\r\n begin\r\n if Command >= ecUserFirst then\r\n begin\r\n TmpString := 'User Command';\r\n if Assigned(GetUserCommandNames) then\r\n GetUserCommandNames(Command, TmpString);\r\n end else begin\r\n if FExtended then\r\n TmpString := ConvertCodeStringToExtended(EditorCommandToCodeString(Command))\r\n else TmpString := EditorCommandToCodeString(Command);\r\n end;\r\n\r\n AItem.Caption:= TmpString;\r\n AItem.SubItems.Clear;\r\n\r\n TmpString := '';\r\n if Shortcut <> 0 then\r\n TmpString := ShortCutToText(ShortCut);\r\n\r\n if (TmpString <> '') and (Shortcut2 <> 0) then\r\n TmpString := TmpString + ' ' + ShortCutToText(ShortCut2);\r\n\r\n AItem.SubItems.Add(TmpString);\r\n\r\n end;\r\n\r\nend;\r\n\r\nprocedure TfmEditorOptionsDialog.cKeyCommandExit(Sender: TObject);\r\nVAR TmpIndex : Integer;\r\nbegin\r\n TmpIndex := cKeyCommand.Items.IndexOf(cKeyCommand.Text);\r\n if TmpIndex = -1 then\r\n begin\r\n if FExtended then\r\n cKeyCommand.ItemIndex := cKeyCommand.Items.IndexOf(ConvertCodeStringToExtended('ecNone'))\r\n else cKeyCommand.ItemIndex := cKeyCommand.Items.IndexOf('ecNone');\r\n end else cKeyCommand.ItemIndex := TmpIndex; //need to force it incase they just typed something in\r\n\r\nend;\r\n\r\nprocedure TfmEditorOptionsDialog.cKeyCommandKeyPress(Sender: TObject;\r\n var Key: Char);\r\nvar WorkStr : string;\r\n i : Integer;\r\nbegin\r\n//This would be better if componentized, but oh well...\r\n WorkStr := Uppercase(Copy(cKeyCommand.Text, 1, cKeyCommand.SelStart) + Key);\r\n i := 0;\r\n While i < cKeyCommand.Items.Count do\r\n begin\r\n if pos(WorkStr, Uppercase(cKeyCommand.Items[i])) = 1 then\r\n begin\r\n cKeyCommand.Text := cKeyCommand.Items[i];\r\n cKeyCommand.SelStart := length(WorkStr);\r\n cKeyCommand.SelLength := Length(cKeyCommand.Text) - cKeyCommand.SelStart;\r\n Key := #0;\r\n break;\r\n end else inc(i);\r\n end;\r\n\r\nend;\r\n\r\nprocedure TfmEditorOptionsDialog.cKeyCommandKeyUp(Sender: TObject;\r\n var Key: Word; Shift: TShiftState);\r\nbegin\r\n if Key = SYNEDIT_RETURN then btnUpdateKey.Click;\r\nend;\r\n\r\nprocedure TfmEditorOptionsDialog.KeyListChanging(Sender: TObject;\r\n Item: TListItem; Change: TItemChange; var AllowChange: Boolean);\r\nbegin\r\n//make sure that it's saved.\r\n if InChanging then exit;\r\n InChanging := True;\r\n if Visible then\r\n begin\r\n if (Item = OldSelected) and\r\n ((Item.Caption <> cKeyCommand.Text) or\r\n (TSynEditKeystroke(Item.Data).ShortCut <> eKeyShort1.HotKey) or\r\n (TSynEditKeystroke(Item.Data).ShortCut2 <> eKeyShort2.HotKey)) then\r\n begin\r\n btnUpdateKeyClick(btnUpdateKey);\r\n end;\r\n end;\r\n InChanging := False;\r\nend;\r\n\r\n{$IFNDEF SYN_COMPILER_4_UP}\r\nprocedure TfmEditorOptionsDialog.OverridingWndProc(var Message: TMessage);\r\nvar\r\n Item: TListItem;\r\nbegin\r\n FOldWndProc(Message);\r\n\r\n if Message.Msg = CN_NOTIFY then\r\n with TWMNotify(Message) do\r\n if NMHdr.code = LVN_ITEMCHANGED then\r\n with PNMListView(NMHdr)^ do\r\n begin\r\n Item := KeyList.Items[iItem];\r\n if Assigned(FOnSelectItem) and (uChanged = LVIF_STATE) then\r\n begin\r\n if (uOldState and LVIS_SELECTED <> 0) and\r\n (uNewState and LVIS_SELECTED = 0) then\r\n FOnSelectItem(Self, Item, False)\r\n else if (uOldState and LVIS_SELECTED = 0) and\r\n (uNewState and LVIS_SELECTED <> 0) then\r\n FOnSelectItem(Self, Item, True);\r\n end;\r\n end;\r\nend;\r\n{$ENDIF}\r\n\r\nend.\r\n" }, { "path": "External/SynEdit/Source/SynEditPlugins.pas", "content": "{-------------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: SynEditPlugins.pas, released 2001-10-17.\r\n\r\nAuthor of this file is Flvio Etrusco.\r\nPortions created by Flvio Etrusco are Copyright 2001 Flvio Etrusco.\r\nUnicode translation by Mal Hrz.\r\nAll Rights Reserved.\r\n\r\nContributors to the SynEdit project are listed in the Contributors.txt file.\r\n\r\nAlternatively, the contents of this file may be used under the terms of the\r\nGNU General Public License Version 2 or later (the \"GPL\"), in which case\r\nthe provisions of the GPL are applicable instead of those above.\r\nIf you wish to allow use of your version of this file only under the terms\r\nof the GPL and not to allow others to use your version of this file\r\nunder the MPL, indicate your decision by deleting the provisions above and\r\nreplace them with the notice and other provisions required by the GPL.\r\nIf you do not delete the provisions above, a recipient may use your version\r\nof this file under either the MPL or the GPL.\r\n\r\n$Id: SynEditPlugins.pas,v 1.8.2.2 2008/09/14 16:24:58 maelh Exp $\r\n\r\nYou may retrieve the latest version of this file at the SynEdit home page,\r\nlocated at http://SynEdit.SourceForge.net\r\n\r\nKnown Issues:\r\n-------------------------------------------------------------------------------}\r\n\r\n{$IFNDEF QSYNEDITPLUGINS}\r\nunit SynEditPlugins;\r\n{$ENDIF}\r\n\r\n{$I SynEdit.inc}\r\n\r\ninterface\r\n\r\nuses\r\n{$IFDEF SYN_CLX}\r\n Qt,\r\n Types,\r\n QMenus,\r\n QSynEdit,\r\n QSynEditKeyCmds,\r\n QSynUnicode,\r\n{$ELSE}\r\n Windows,\r\n Menus,\r\n SynEdit,\r\n SynEditKeyCmds,\r\n SynUnicode,\r\n{$ENDIF}\r\n Classes;\r\n\r\ntype\r\n TAbstractSynPlugin = class(TComponent)\r\n private\r\n procedure SetEditor(const Value: TCustomSynEdit);\r\n function GetEditors(aIndex: integer): TCustomSynEdit;\r\n function GetEditor: TCustomSynEdit;\r\n function GetEditorCount: integer;\r\n protected\r\n fEditors: TList;\r\n procedure Notification(aComponent: TComponent;\r\n aOperation: TOperation); override;\r\n procedure DoAddEditor(aEditor: TCustomSynEdit); virtual;\r\n procedure DoRemoveEditor(aEditor: TCustomSynEdit); virtual;\r\n function AddEditor(aEditor: TCustomSynEdit): integer;\r\n function RemoveEditor(aEditor: TCustomSynEdit): integer;\r\n public\r\n destructor Destroy; override;\r\n property Editors[aIndex: integer]: TCustomSynEdit read GetEditors;\r\n property EditorCount: integer read GetEditorCount;\r\n published\r\n property Editor: TCustomSynEdit read GetEditor write SetEditor;\r\n end;\r\n\r\n TAbstractSynHookerPlugin = class(TAbstractSynPlugin)\r\n protected\r\n procedure HookEditor(aEditor: TCustomSynEdit; aCommandID: TSynEditorCommand;\r\n aOldShortCut, aNewShortCut: TShortCut);\r\n procedure UnHookEditor(aEditor: TCustomSynEdit;\r\n aCommandID: TSynEditorCommand; aShortCut: TShortCut);\r\n procedure OnCommand(Sender: TObject; AfterProcessing: boolean;\r\n var Handled: boolean; var Command: TSynEditorCommand; var AChar: WideChar;\r\n Data: pointer; HandlerData: pointer); virtual; abstract;\r\n end;\r\n\r\n TPluginState = (psNone, psExecuting, psAccepting, psCancelling);\r\n\r\n TAbstractSynSingleHookPlugin = class(TAbstractSynHookerPlugin)\r\n private\r\n fCommandID: TSynEditorCommand;\r\n function IsShortCutStored: Boolean;\r\n procedure SetShortCut(const Value: TShortCut);\r\n protected\r\n fState: TPluginState;\r\n fCurrentEditor: TCustomSynEdit;\r\n fShortCut: TShortCut;\r\n class function DefaultShortCut: TShortCut; virtual;\r\n procedure DoAddEditor(aEditor: TCustomSynEdit); override;\r\n procedure DoRemoveEditor(aEditor: TCustomSynEdit); override;\r\n {}\r\n procedure DoExecute; virtual; abstract;\r\n procedure DoAccept; virtual; abstract;\r\n procedure DoCancel; virtual; abstract;\r\n public\r\n constructor Create(aOwner: TComponent); override;\r\n destructor Destroy; override;\r\n property CommandID: TSynEditorCommand read fCommandID;\r\n property CurrentEditor: TCustomSynEdit read fCurrentEditor;\r\n function Executing: boolean;\r\n procedure Execute(aEditor: TCustomSynEdit);\r\n procedure Accept;\r\n procedure Cancel;\r\n published\r\n property ShortCut: TShortCut read fShortCut write SetShortCut\r\n stored IsShortCutStored;\r\n end;\r\n\r\n { use TAbstractSynCompletion for non-visual completion }\r\n\r\n TAbstractSynCompletion = class(TAbstractSynSingleHookPlugin)\r\n protected\r\n fCurrentString: UnicodeString;\r\n protected\r\n procedure SetCurrentString(const Value: UnicodeString); virtual;\r\n procedure OnCommand(Sender: TObject; AfterProcessing: boolean;\r\n var Handled: boolean; var Command: TSynEditorCommand; var AChar: WideChar;\r\n Data: pointer; HandlerData: pointer); override;\r\n procedure DoExecute; override;\r\n procedure DoAccept; override;\r\n procedure DoCancel; override;\r\n function GetCurrentEditorString: UnicodeString; virtual;\r\n public\r\n procedure AddEditor(aEditor: TCustomSynEdit);\r\n property CurrentString: UnicodeString read fCurrentString write SetCurrentString;\r\n end;\r\n\r\nfunction NewPluginCommand: TSynEditorCommand;\r\nprocedure ReleasePluginCommand(aCmd: TSynEditorCommand);\r\n\r\nimplementation\r\n\r\nuses\r\n{$IFDEF SYN_CLX}\r\n QForms,\r\n QSynEditTypes,\r\n QSynEditMiscProcs,\r\n QSynEditStrConst,\r\n{$ELSE}\r\n Forms,\r\n SynEditTypes,\r\n SynEditMiscProcs,\r\n SynEditStrConst,\r\n{$ENDIF}\r\n SysUtils;\r\n\r\nconst\r\n ecPluginBase = 64000;\r\n\r\nvar\r\n gCurrentCommand: integer = ecPluginBase;\r\n\r\nfunction NewPluginCommand: TSynEditorCommand;\r\nbegin\r\n Result := gCurrentCommand;\r\n Inc(gCurrentCommand);\r\nend;\r\n\r\nprocedure ReleasePluginCommand(aCmd: TSynEditorCommand);\r\nbegin\r\n if aCmd = Pred(gCurrentCommand) then\r\n gCurrentCommand := aCmd;\r\nend;\r\n\r\n{ TAbstractSynPlugin }\r\n\r\nfunction TAbstractSynPlugin.AddEditor(aEditor: TCustomSynEdit): integer;\r\nbegin\r\n if fEditors = nil then\r\n begin\r\n fEditors := TList.Create;\r\n end\r\n else\r\n if fEditors.IndexOf(aEditor) >= 0 then\r\n begin\r\n Result := -1;\r\n Exit;\r\n end;\r\n aEditor.FreeNotification(Self);\r\n Result := fEditors.Add(aEditor);\r\n DoAddEditor(aEditor);\r\nend;\r\n\r\ndestructor TAbstractSynPlugin.Destroy;\r\nbegin\r\n { RemoveEditor will free fEditors when it reaches count = 0}\r\n while Assigned(fEditors) do\r\n RemoveEditor(Editors[0]);\r\n inherited;\r\nend;\r\n\r\nprocedure TAbstractSynPlugin.Notification(aComponent: TComponent;\r\n aOperation: TOperation);\r\nbegin\r\n inherited;\r\n if aOperation = opRemove then\r\n begin\r\n if (aComponent = Editor) or (aComponent is TCustomSynEdit) then\r\n RemoveEditor(TCustomSynEdit(aComponent));\r\n end;\r\nend;\r\n\r\nprocedure TAbstractSynPlugin.DoAddEditor(aEditor: TCustomSynEdit);\r\nbegin\r\n\r\nend;\r\n\r\nprocedure TAbstractSynPlugin.DoRemoveEditor(aEditor: TCustomSynEdit);\r\nbegin\r\n\r\nend;\r\n\r\nfunction TAbstractSynPlugin.RemoveEditor(aEditor: TCustomSynEdit): integer;\r\nbegin\r\n if fEditors = nil then\r\n begin\r\n Result := -1;\r\n Exit;\r\n end;\r\n Result := fEditors.Remove(aEditor);\r\n //aEditor.RemoveFreeNotification(Self);\r\n if fEditors.Count = 0 then\r\n begin\r\n fEditors.Free;\r\n fEditors := nil;\r\n end;\r\n if Result >= 0 then\r\n DoRemoveEditor(aEditor);\r\nend;\r\n\r\nprocedure TAbstractSynPlugin.SetEditor(const Value: TCustomSynEdit);\r\nvar\r\n iEditor: TCustomSynEdit;\r\nbegin\r\n iEditor := Editor;\r\n if iEditor <> Value then\r\n try\r\n if (iEditor <> nil) and (fEditors.Count = 1) then\r\n RemoveEditor(iEditor);\r\n if Value <> nil then\r\n AddEditor(Value);\r\n except\r\n if [csDesigning] * ComponentState = [csDesigning] then\r\n Application.HandleException(Self)\r\n else\r\n raise;\r\n end;\r\nend;\r\n\r\nfunction TAbstractSynPlugin.GetEditors(aIndex: integer): TCustomSynEdit;\r\nbegin\r\n Result := TCustomSynEdit(fEditors[aIndex]);\r\nend;\r\n\r\nfunction TAbstractSynPlugin.GetEditor: TCustomSynEdit;\r\nbegin\r\n if fEditors <> nil then\r\n Result := fEditors[0]\r\n else\r\n Result := nil;\r\nend;\r\n\r\nfunction TAbstractSynPlugin.GetEditorCount: integer;\r\nbegin\r\n if fEditors <> nil then\r\n Result := fEditors.Count\r\n else\r\n Result := 0;\r\nend;\r\n\r\n{ TAbstractSynHookerPlugin }\r\n\r\nprocedure TAbstractSynHookerPlugin.HookEditor(aEditor: TCustomSynEdit;\r\n aCommandID: TSynEditorCommand; aOldShortCut, aNewShortCut: TShortCut);\r\nvar\r\n iIndex: integer;\r\n iKeystroke: TSynEditKeyStroke;\r\nbegin\r\n Assert(aNewShortCut <> 0);\r\n { shortcurts aren't created while in design-time }\r\n if [csDesigning] * ComponentState = [csDesigning] then\r\n begin\r\n if TSynEdit(aEditor).Keystrokes.FindShortcut(aNewShortCut) >= 0 then\r\n raise ESynKeyError.Create(SYNS_EDuplicateShortCut)\r\n else\r\n Exit;\r\n end;\r\n { tries to update old Keystroke }\r\n if aOldShortCut <> 0 then\r\n begin\r\n iIndex := TSynEdit(aEditor).Keystrokes.FindShortcut(aOldShortCut);\r\n if (iIndex >= 0) then\r\n begin\r\n iKeystroke := TSynEdit(aEditor).Keystrokes[iIndex];\r\n if iKeystroke.Command = aCommandID then\r\n begin\r\n iKeystroke.ShortCut := aNewShortCut;\r\n Exit;\r\n end;\r\n end;\r\n end;\r\n { new Keystroke }\r\n iKeystroke := TSynEdit(aEditor).Keystrokes.Add;\r\n try\r\n iKeystroke.ShortCut := aNewShortCut;\r\n except\r\n iKeystroke.Free;\r\n raise;\r\n end;\r\n iKeystroke.Command := aCommandID;\r\n aEditor.RegisterCommandHandler(OnCommand, Self);\r\nend;\r\n\r\nprocedure TAbstractSynHookerPlugin.UnHookEditor(aEditor: TCustomSynEdit;\r\n aCommandID: TSynEditorCommand; aShortCut: TShortCut);\r\nvar\r\n iIndex: integer;\r\nbegin\r\n aEditor.UnregisterCommandHandler(OnCommand);\r\n iIndex := TSynEdit(aEditor).Keystrokes.FindShortcut(aShortCut);\r\n if (iIndex >= 0) and\r\n (TSynEdit(aEditor).Keystrokes[iIndex].Command = aCommandID) then\r\n TSynEdit(aEditor).Keystrokes[iIndex].Free;\r\nend;\r\n\r\n{ TAbstractSynHookerPlugin }\r\n\r\nprocedure TAbstractSynSingleHookPlugin.Accept;\r\nbegin\r\n fState := psAccepting;\r\n try\r\n DoAccept;\r\n finally\r\n fCurrentEditor := nil;\r\n fState := psNone;\r\n end;\r\nend;\r\n\r\nprocedure TAbstractSynSingleHookPlugin.Cancel;\r\nbegin\r\n fState := psCancelling;\r\n try\r\n DoCancel;\r\n finally\r\n fCurrentEditor := nil;\r\n fState := psNone;\r\n end;\r\nend;\r\n\r\nconstructor TAbstractSynSingleHookPlugin.Create(aOwner: TComponent);\r\nbegin\r\n inherited;\r\n fCommandID := NewPluginCommand;\r\n fShortCut := DefaultShortCut;\r\nend;\r\n\r\nclass function TAbstractSynSingleHookPlugin.DefaultShortCut: TShortCut;\r\nbegin\r\n Result := 0;\r\nend;\r\n\r\ndestructor TAbstractSynSingleHookPlugin.Destroy;\r\nbegin\r\n if Executing then\r\n Cancel;\r\n ReleasePluginCommand(CommandID);\r\n inherited;\r\nend;\r\n\r\nprocedure TAbstractSynSingleHookPlugin.DoAddEditor(\r\n aEditor: TCustomSynEdit);\r\nbegin\r\n if ShortCut <> 0 then\r\n HookEditor(aEditor, CommandID, 0, ShortCut);\r\nend;\r\n\r\nprocedure TAbstractSynSingleHookPlugin.Execute(aEditor: TCustomSynEdit);\r\nbegin\r\n if Executing then\r\n Cancel;\r\n Assert(fCurrentEditor = nil);\r\n fCurrentEditor := aEditor;\r\n Assert(fState = psNone);\r\n fState := psExecuting;\r\n try\r\n DoExecute;\r\n except\r\n Cancel;\r\n raise;\r\n end;\r\nend;\r\n\r\nfunction TAbstractSynSingleHookPlugin.Executing: boolean;\r\nbegin\r\n Result := fState = psExecuting;\r\nend;\r\n\r\nfunction TAbstractSynSingleHookPlugin.IsShortCutStored: Boolean;\r\nbegin\r\n Result := fShortCut <> DefaultShortCut;\r\nend;\r\n\r\nprocedure TAbstractSynSingleHookPlugin.DoRemoveEditor(aEditor: TCustomSynEdit);\r\nbegin\r\n if ShortCut <> 0 then\r\n UnHookEditor(aEditor, CommandID, ShortCut);\r\n if Executing and (CurrentEditor = aEditor) then\r\n Cancel;\r\nend;\r\n\r\nprocedure TAbstractSynSingleHookPlugin.SetShortCut(const Value: TShortCut);\r\nvar\r\n cEditor: integer;\r\nbegin\r\n if fShortCut <> Value then\r\n begin\r\n if Assigned(fEditors) then\r\n if Value <> 0 then\r\n begin\r\n for cEditor := 0 to fEditors.Count -1 do\r\n HookEditor(Editors[cEditor], CommandID, fShortCut, Value);\r\n end\r\n else\r\n begin\r\n for cEditor := 0 to fEditors.Count -1 do\r\n UnHookEditor(Editors[cEditor], CommandID, fShortCut);\r\n end;\r\n fShortCut := Value;\r\n end;\r\nend;\r\n\r\n{ TAbstractSynCompletion }\r\n\r\nfunction TAbstractSynCompletion.GetCurrentEditorString: UnicodeString;\r\nvar\r\n S: UnicodeString;\r\n Col: integer;\r\nbegin\r\n S := CurrentEditor.LineText;\r\n if (CurrentEditor.CaretX > 1) and\r\n (CurrentEditor.CaretX - 1 <= Length(S)) then\r\n begin\r\n for Col := CurrentEditor.CaretX - 1 downto 1 do\r\n if not CurrentEditor.IsIdentChar(S[Col])then\r\n break;\r\n Result := Copy(S, Col + 1, CurrentEditor.CaretX - Col - 1);\r\n end;\r\nend;\r\n\r\nprocedure TAbstractSynCompletion.DoAccept;\r\nbegin\r\n fCurrentString := '';\r\nend;\r\n\r\nprocedure TAbstractSynCompletion.DoCancel;\r\nbegin\r\n fCurrentString := '';\r\nend;\r\n\r\nprocedure TAbstractSynCompletion.DoExecute;\r\nbegin\r\n CurrentString := GetCurrentEditorString;\r\nend;\r\n\r\nprocedure TAbstractSynCompletion.OnCommand(Sender: TObject;\r\n AfterProcessing: boolean; var Handled: boolean;\r\n var Command: TSynEditorCommand; var AChar: WideChar; Data,\r\n HandlerData: Pointer);\r\nvar\r\n S: UnicodeString;\r\nbegin \r\n if not Executing then\r\n begin\r\n if (Command = CommandID) then\r\n begin\r\n Execute(Sender as TCustomSynEdit);\r\n Handled := True;\r\n end;\r\n end\r\n else { Executing }\r\n if Sender = CurrentEditor then\r\n begin\r\n if not AfterProcessing then\r\n begin\r\n case Command of\r\n ecChar:\r\n if aChar = #27 then\r\n begin\r\n Cancel;\r\n Handled := True;\r\n end\r\n else\r\n begin\r\n if not(CurrentEditor.IsIdentChar(aChar)) then \r\n Accept;\r\n {don't handle the char}\r\n end;\r\n ecLineBreak:\r\n begin\r\n Accept;\r\n Handled := True;\r\n end;\r\n ecLeft, ecSelLeft:\r\n if CurrentString = '' then\r\n Handled := True;\r\n ecDeleteLastChar:\r\n if CurrentString = '' then\r\n Handled := True;\r\n ecTab:\r\n Accept;\r\n ecDeleteChar,\r\n ecRight, ecSelRight,\r\n ecLostFocus, ecGotFocus:\r\n ; {processed on AfterProcessing}\r\n else\r\n Cancel;\r\n end;\r\n end\r\n else { AfterProcessing }\r\n case Command of\r\n ecLostFocus, ecGotFocus,\r\n ecDeleteChar:\r\n ;\r\n ecDeleteLastChar,\r\n ecLeft, ecSelLeft,\r\n ecChar:\r\n CurrentString := GetCurrentEditorString;\r\n ecRight, ecSelRight: begin\r\n S := GetCurrentEditorString;\r\n if S = '' then\r\n Cancel\r\n else\r\n CurrentString := S;\r\n end;\r\n else\r\n if CurrentString <> GetCurrentEditorString then\r\n Cancel;\r\n end;\r\n end; {endif Sender = CurrentEditor}\r\nend;\r\n\r\nprocedure TAbstractSynCompletion.SetCurrentString(const Value: UnicodeString);\r\nbegin\r\n fCurrentString := Value;\r\nend;\r\n\r\nprocedure TAbstractSynCompletion.AddEditor(aEditor: TCustomSynEdit);\r\nbegin\r\n inherited AddEditor(aEditor);\r\nend;\r\n\r\nend.\r\n" }, { "path": "External/SynEdit/Source/SynEditPrint.pas", "content": "{-------------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: SynEditPrint.pas, released 2000-06-01.\r\n\r\nThe Initial Author of the Original Code is Morten J. Skovrup.\r\nPortions written by Morten J. Skovrup are copyright 2000 Morten J. Skovrup.\r\nUnicode translation by Mal Hrz.\r\nAll Rights Reserved.\r\n\r\nContributors to the SynEdit project are listed in the Contributors.txt file.\r\n\r\nAlternatively, the contents of this file may be used under the terms of the\r\nGNU General Public License Version 2 or later (the \"GPL\"), in which case\r\nthe provisions of the GPL are applicable instead of those above.\r\nIf you wish to allow use of your version of this file only under the terms\r\nof the GPL and not to allow others to use your version of this file\r\nunder the MPL, indicate your decision by deleting the provisions above and\r\nreplace them with the notice and other provisions required by the GPL.\r\nIf you do not delete the provisions above, a recipient may use your version\r\nof this file under either the MPL or the GPL.\r\n\r\n$Id: SynEditPrint.pas,v 1.34.2.12 2008/09/23 14:02:08 maelh Exp $\r\n\r\nYou may retrieve the latest version of this file at the SynEdit home page,\r\nlocated at http://SynEdit.SourceForge.net\r\n\r\nKnown Issues:\r\n Wrapping across page boundaries is not supported\r\n-------------------------------------------------------------------------------}\r\n\r\n{-------------------------------------------------------------------------------\r\nCONTENTS:\r\n Print controller component.\r\n Allows setting margins, headers and footers.\r\n\r\n Design time properties:\r\n Header : Class property to set properties for headers -\r\n see CSynEditHeaderFooter.pas\r\n Footer : Class property to set properties for footers -\r\n see CSynEditHeaderFooter.pas\r\n Margins : Class property to set properties for margins -\r\n see CSynEditPrintMargins.pas\r\n Lines : The lines that should be printed (see also SynEdit the\r\n property below)\r\n Font : The font the lines should be printed in (see also SynEdit\r\n the property below)\r\n Title : A title - can be referenced in headers/footers by using the\r\n $TITLE$ macro\r\n Wrap : Wrap text to margins\r\n Highlight : Highlight text\r\n Colors : Print in colors\r\n LineNumbers : Print line numbers\r\n LineOffset : Value added to linenumbers when printing\r\n PageOffset : Value added to pagenumbers when printing\r\n OnPrintLine : Fired when a line is printed\r\n OnPrintStatus : Fired at Beginning, End and when a new page is started\r\n Highlighter : The highlighter used for highlighting the text (see also the\r\n SynEdit property below)\r\n LineNumbersInMargin : If true line numbers are printed in the left margin,\r\n else left margin is increased by width of line\r\n number text.\r\n SelectedOnly : Print only the selected Area\r\n Run-time properties:\r\n DocTitle : Used to display the document name in the print queue monitor\r\n PrinterInfo : Read only. Returns info on printer (used internally)\r\n PageCount : Returns the total number of pages;\r\n SynEdit : By setting SynEdit to a specific TSynEdit component, the\r\n properties Lines, Font and Highlighter are automatically\r\n set to the corresponding values of the TSynEdit component\r\n Run-time methods:\r\n UpdatePages : Used internally by the TSynEditPrintPreview component\r\n PrintToCanvas : Used internally by the TSynEditPrintPreview component\r\n Print : Prints the contents of the Lines property\r\n PrintRange(StartPage,EndPage) : Prints the specified page-range (both inclusive)\r\n-------------------------------------------------------------------------------}\r\n\r\n{$IFNDEF QSYNEDITPRINT}\r\nunit SynEditPrint;\r\n{$ENDIF}\r\n\r\n{$M+}\r\n{$I SynEdit.inc}\r\n\r\ninterface\r\n\r\nuses\r\n{$IFDEF SYN_CLX}\r\n Qt,\r\n QGraphics,\r\n QPrinters,\r\n Types,\r\n QSynEdit,\r\n QSynEditTypes,\r\n QSynEditPrintTypes,\r\n QSynEditPrintHeaderFooter,\r\n QSynEditPrinterInfo,\r\n QSynEditPrintMargins,\r\n QSynEditMiscProcs,\r\n QSynEditHighlighter,\r\n QSynUnicode,\r\n{$ELSE}\r\n Windows,\r\n Graphics,\r\n Printers,\r\n SynEdit,\r\n SynEditTypes,\r\n SynEditPrintTypes,\r\n SynEditPrintHeaderFooter,\r\n SynEditPrinterInfo,\r\n SynEditPrintMargins,\r\n SynEditMiscProcs,\r\n SynEditHighlighter,\r\n SynUnicode,\r\n{$ENDIF}\r\n SysUtils,\r\n Classes;\r\n\r\ntype\r\n TPageLine = class\r\n public\r\n FirstLine: Integer;\r\n end;\r\n //The actual print controller object\r\n TSynEditPrint = class(TComponent)\r\n private\r\n FCopies: Integer; \r\n FFooter: TFooter;\r\n FHeader: THeader;\r\n FLines: TUnicodeStrings;\r\n FMargins: TSynEditPrintMargins;\r\n FPageCount: Integer;\r\n FFont: TFont;\r\n FTitle: UnicodeString;\r\n FDocTitle: UnicodeString; \r\n FPrinterInfo: TSynEditPrinterInfo;\r\n FPages: TList;\r\n FCanvas: TCanvas;\r\n FCharWidth: Integer;\r\n FMaxLeftChar: Integer;\r\n FWrap: Boolean;\r\n FOnPrintLine: TPrintLineEvent;\r\n FOnPrintStatus: TPrintStatusEvent;\r\n FYPos: Integer;\r\n FLineHeight: Integer;\r\n FHighlight: Boolean;\r\n FColors: Boolean;\r\n FHighlighter: TSynCustomHighlighter;\r\n FOldFont: TFont;\r\n FSynOK: Boolean;\r\n FLineNumbers: Boolean;\r\n FLineNumber: Integer;\r\n FLineOffset: Integer;\r\n FAbort: Boolean;\r\n FPrinting: Boolean;\r\n FDefaultBG: TColor;\r\n FPageOffset: Integer;\r\n FRangesOK: Boolean;\r\n FMaxWidth: integer;\r\n FMaxCol: Integer;\r\n FPagesCounted: Boolean;\r\n FLineNumbersInMargin: Boolean;\r\n FTabWidth: integer;\r\n fFontColor: TColor; \r\n fSelectedOnly: Boolean; \r\n fSelAvail: Boolean;\r\n fSelMode: TSynSelectionMode;\r\n fBlockBegin: TBufferCoord;\r\n fBlockEnd: TBufferCoord;\r\n FETODist: PIntArray;\r\n procedure CalcPages;\r\n procedure SetLines(const Value: TUnicodeStrings);\r\n procedure SetFont(const Value: TFont);\r\n procedure SetCharWidth(const Value: Integer);\r\n procedure SetMaxLeftChar(const Value: Integer);\r\n procedure PrintPage(Num: Integer);\r\n procedure WriteLine(const Text: UnicodeString);\r\n procedure WriteLineNumber;\r\n procedure HandleWrap(const Text: UnicodeString; MaxWidth: Integer);\r\n procedure TextOut(const Text: UnicodeString; AList: TList);\r\n procedure SetHighlighter(const Value: TSynCustomHighlighter);\r\n procedure RestoreCurrentFont;\r\n procedure SaveCurrentFont;\r\n procedure SetPixelsPrInch;\r\n procedure InitPrint;\r\n procedure InitRanges;\r\n function GetPageCount: Integer;\r\n procedure SetSynEdit(const Value: TCustomSynEdit);\r\n procedure SetFooter(const Value: TFooter);\r\n procedure SetHeader(const Value: THeader);\r\n procedure SetMargins(const Value: TSynEditPrintMargins);\r\n function ClipLineToRect(S: UnicodeString; R: TRect): UnicodeString;\r\n function ExpandAtWideGlyphs(const S: UnicodeString): UnicodeString;\r\n protected\r\n procedure DefineProperties(Filer: TFiler); override;\r\n property MaxLeftChar: Integer read FMaxLeftChar write SetMaxLeftChar;\r\n property CharWidth: Integer read FCharWidth write SetCharWidth;\r\n procedure PrintStatus(Status: TSynPrintStatus; PageNumber: integer;\r\n var Abort: boolean); virtual;\r\n procedure PrintLine(LineNumber, PageNumber: Integer); virtual;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n procedure UpdatePages(ACanvas: TCanvas);\r\n procedure PrintToCanvas(ACanvas: TCanvas; PageNumber: Integer);\r\n procedure Print;\r\n procedure PrintRange(StartPage, EndPage: Integer);\r\n property PrinterInfo: TSynEditPrinterInfo read FPrinterInfo;\r\n property PageCount: Integer read GetPageCount;\r\n property SynEdit: TCustomSynEdit write SetSynEdit;\r\n\r\n procedure LoadFromStream(AStream: TStream);\r\n procedure SaveToStream(AStream: TStream);\r\n published\r\n property Copies: integer read FCopies write FCopies;\r\n property Header: THeader read FHeader write SetHeader;\r\n property Footer: TFooter read FFooter write SetFooter;\r\n property Margins: TSynEditPrintMargins read FMargins write SetMargins;\r\n property Lines: TUnicodeStrings read FLines write SetLines;\r\n property Font: TFont read FFont write SetFont;\r\n property Title: UnicodeString read FTitle write FTitle;\r\n property DocTitle: UnicodeString read FDocTitle write FDocTitle; \r\n property Wrap: Boolean read FWrap write FWrap default True;\r\n property Highlight: Boolean read FHighlight write FHighlight default True;\r\n property SelectedOnly: Boolean read FSelectedOnly write FSelectedOnly \r\n default False;\r\n property Colors: Boolean read FColors write FColors default False;\r\n property LineNumbers: Boolean read FLineNumbers write FLineNumbers\r\n default False;\r\n property LineOffset: Integer read FLineOffset write FLineOffset default 0;\r\n property PageOffset: Integer read FPageOffset write FPageOffset default 0;\r\n property OnPrintLine: TPrintLineEvent read FOnPrintLine write FOnPrintLine;\r\n property OnPrintStatus: TPrintStatusEvent read FOnPrintStatus\r\n write FOnPrintStatus;\r\n property Highlighter: TSynCustomHighlighter read FHighlighter\r\n write SetHighlighter;\r\n property LineNumbersInMargin: Boolean read FLineNumbersInMargin\r\n write FLineNumbersInMargin default False;\r\n property TabWidth: integer read fTabWidth write fTabWidth; \r\n property Color: TColor read fDefaultBG write fDefaultBG; \r\n end;\r\n\r\nimplementation\r\n\r\nuses\r\n Math, System.UITypes;\r\n\r\n{ TSynEditPrint }\r\n\r\nconstructor TSynEditPrint.Create(AOwner: TComponent);\r\nbegin\r\n inherited;\r\n FCopies := 1;\r\n FFooter := TFooter.Create;\r\n FHeader := THeader.Create;\r\n FLines := TUnicodeStringList.Create;\r\n FMargins := TSynEditPrintMargins.Create;\r\n FPrinterInfo := TSynEditPrinterInfo.Create;\r\n FFont := TFont.Create;\r\n FOldFont := TFont.Create;\r\n MaxLeftChar := 1024;\r\n FWrap := True;\r\n FHighlight := True;\r\n FColors := False;\r\n FLineNumbers := False;\r\n FLineOffset := 0;\r\n FPageOffset := 0;\r\n FLineNumbersInMargin := False;\r\n FPages := TList.Create;\r\n FTabWidth := 8; \r\n FDefaultBG := clWhite; \r\nend;\r\n\r\ndestructor TSynEditPrint.Destroy;\r\nvar\r\n i: Integer;\r\nbegin\r\n FFooter.Free;\r\n FHeader.Free;\r\n FLines.Free;\r\n FMargins.Free;\r\n FPrinterInfo.Free;\r\n FFont.Free;\r\n FOldFont.Free;\r\n for i := 0 to FPages.Count - 1 do\r\n TPageLine(FPages[i]).Free;\r\n FPages.Free;\r\n FreeMem(FETODist);\r\n inherited;\r\nend;\r\n\r\nprocedure TSynEditPrint.DefineProperties(Filer: TFiler);\r\nbegin\r\n inherited;\r\n{$IFNDEF UNICODE}\r\n UnicodeDefineProperties(Filer, Self);\r\n{$ENDIF}\r\nend;\r\n\r\nprocedure TSynEditPrint.SetLines(const Value: TUnicodeStrings);\r\nvar\r\n i, j: Integer;\r\n ConvertTabsProc: TConvertTabsProc;\r\n TmpString: UnicodeString;\r\nbegin\r\n ConvertTabsProc := GetBestConvertTabsProc(FTabWidth);\r\n with FLines do\r\n begin\r\n BeginUpdate;\r\n try\r\n Clear;\r\n for i := 0 to Value.Count - 1 do\r\n begin\r\n TmpString := ConvertTabsProc(Value[i], FTabWidth);\r\n j := Pos(#9, TmpString);\r\n While j > 0 do\r\n begin\r\n TmpString[j] := ' ';\r\n j := Pos(#9, TmpString);\r\n end;\r\n Add(TmpString);\r\n end;\r\n finally\r\n EndUpdate;\r\n end;\r\n end;\r\n FRangesOK := False;\r\n FPagesCounted := False;\r\nend;\r\n\r\nprocedure TSynEditPrint.SetFont(const Value: TFont);\r\nbegin\r\n FFont.Assign(Value);\r\n FPagesCounted := False;\r\nend;\r\n\r\nprocedure TSynEditPrint.SetCharWidth(const Value: Integer);\r\nbegin\r\n FCharWidth := Value;\r\nend;\r\n\r\nprocedure TSynEditPrint.SetMaxLeftChar(const Value: Integer);\r\nbegin\r\n FMaxLeftChar := Value;\r\nend;\r\n\r\nprocedure TSynEditPrint.SetHighlighter(const Value: TSynCustomHighlighter);\r\nbegin\r\n FHighlighter := Value;\r\n FRangesOK := False;\r\n FPagesCounted := False;\r\nend;\r\n\r\n// Inserts filling chars into a string containing chars that display as glyphs\r\n// wider than an average glyph. (This is often the case with Asian glyphs, which\r\n// are usually wider than latin glpyhs)\r\n// This is only to simplify paint-operations and has nothing to do with\r\n// multi-byte chars.\r\nfunction TSynEditPrint.ExpandAtWideGlyphs(const S: UnicodeString): UnicodeString;\r\nvar\r\n i, j, CountOfAvgGlyphs: Integer;\r\nbegin\r\n FCanvas.Font := Font;\r\n\r\n j := 0;\r\n SetLength(Result, Length(S) * 2); // speed improvement\r\n for i := 1 to Length(S) do\r\n begin\r\n inc(j);\r\n CountOfAvgGlyphs := Ceil(TextWidth(FCanvas, S[i]) / fCharWidth);\r\n\r\n if j + CountOfAvgGlyphs > Length(Result) then\r\n SetLength(Result, Length(Result) + 128);\r\n\r\n // insert CountOfAvgGlyphs filling chars\r\n while CountOfAvgGlyphs > 1 do\r\n begin\r\n Result[j] := FillerChar;\r\n inc(j);\r\n dec(CountOfAvgGlyphs);\r\n end;\r\n\r\n Result[j] := S[i];\r\n end;\r\n\r\n SetLength(Result, j);\r\nend;\r\n\r\nprocedure TSynEditPrint.InitPrint;\r\n{ Initialize Font.PixelsPerInch, Character widths, Margins, Total Page count,\r\n headers and footers}\r\nvar\r\n TmpSize: Integer;\r\n{$IFNDEF SYN_CLX}\r\n TmpTextMetrics: TTextMetric;\r\n{$ENDIF}\r\nbegin\r\n// FDefaultBG := FCanvas.Brush.Color; \r\n fFontColor := FFont.Color;\r\n FCanvas.Font.Assign(FFont);\r\n if not FPrinting then\r\n begin\r\n SetPixelsPrInch;\r\n TmpSize := FCanvas.Font.Size;\r\n FCanvas.Font.PixelsPerInch := FFont.PixelsPerInch;\r\n FCanvas.Font.Size := TmpSize;\r\n end;\r\n // Calculate TextMetrics with the (probably) most wider text styles so text is\r\n // never clipped (although potentially wasting space)\r\n FCanvas.Font.Style := [fsBold, fsItalic, fsUnderline, fsStrikeOut];\r\n{$IFDEF SYN_CLX}\r\n CharWidth := TextWidth(FCanvas, 'W');\r\n FLineHeight := TextHeight(FCanvas, 'Wp');\r\n{$ELSE}\r\n GetTextMetrics(FCanvas.Handle, TmpTextMetrics);\r\n CharWidth := TmpTextMetrics.tmAveCharWidth;\r\n FLineHeight := TmpTextMetrics.tmHeight + TmpTextMetrics.tmExternalLeading;\r\n{$ENDIF}\r\n FCanvas.Font.Style := FFont.Style;\r\n FMargins.InitPage(FCanvas, 1, FPrinterInfo, FLineNumbers, FLineNumbersInMargin,\r\n FLines.Count - 1 + FLineOffset);\r\n CalcPages;\r\n FHeader.InitPrint(FCanvas, FPageCount, FTitle, FMargins);\r\n FFooter.InitPrint(FCanvas, FPageCount, FTitle, FMargins);\r\n FSynOK := Highlight and Assigned(FHighLighter) and (FLines.Count > 0);\r\nend;\r\n\r\nprocedure TSynEditPrint.SetPixelsPrInch;\r\nvar\r\n TmpSize: Integer;\r\nbegin\r\n FHeader.SetPixPrInch(FPrinterInfo.YPixPrInch);\r\n FFooter.SetPixPrInch(FPrinterInfo.YPixPrInch);\r\n //This should be necessary - else size would be changed...\r\n TmpSize := FFont.Size;\r\n FFont.PixelsPerInch := FPrinterInfo.YPixPrInch;\r\n FFont.Size := TmpSize;\r\nend;\r\n\r\nprocedure TSynEditPrint.InitRanges;\r\n//Initialize ranges in Highlighter\r\nvar\r\n i: Integer;\r\nbegin\r\n if not FRangesOK and Assigned(FHighlighter) and (Lines.Count > 0) then\r\n begin\r\n FHighlighter.ResetRange;\r\n FLines.Objects[0] := fHighlighter.GetRange;\r\n i := 1;\r\n while i < Lines.Count do\r\n begin\r\n FHighlighter.SetLine(FLines[i - 1], i - 1);\r\n FHighlighter.NextToEol;\r\n FLines.Objects[i] := FHighlighter.GetRange;\r\n Inc(i);\r\n end;\r\n FRangesOK := True;\r\n end;\r\nend;\r\n\r\n// Calculates the total number of pages\r\nprocedure TSynEditPrint.CalcPages;\r\nvar\r\n AStr, Text: UnicodeString;\r\n StrWidth: Integer;\r\n i, j: Integer;\r\n AList: TList;\r\n YPos: Integer;\r\n PageLine: TPageLine;\r\n\r\n //Counts the number of lines a line is wrapped to\r\n procedure CountWrapped;\r\n var\r\n j: Integer;\r\n begin\r\n for j := 0 to AList.Count - 1 do\r\n YPos := YPos + FLineHeight;\r\n end;\r\n\r\nvar\r\n iStartLine, iEndLine: integer;\r\n iSelStart, iSelLen: integer;\r\nbegin\r\n InitRanges;\r\n for i := 0 to FPages.Count - 1 do\r\n TPageLine(FPages[i]).Free;\r\n FPages.Clear;\r\n FMaxWidth := FMargins.PRight - FMargins.PLeft;\r\n AStr := '';\r\n FMaxCol := 0;\r\n while TextWidth(FCanvas, AStr) < FMaxWidth do\r\n begin\r\n AStr := AStr + 'W';\r\n FMaxCol := FMaxCol + 1;\r\n end;\r\n FMaxCol := FMaxCol - 1;\r\n {FTestString is used to Calculate MaxWidth when prewiewing and printing -\r\n else the length is not calculated correctly when prewiewing and the\r\n zoom is different from 0.25,0.5,1,2,4 (as for example 1.20) - WHY???}\r\n// fTestString := UnicodeStringOfChar('W', FMaxCol);\r\n AStr := UnicodeStringOfChar('W', FMaxCol);\r\n FMaxWidth := TextWidth(FCanvas, AStr);\r\n FPageCount := 1;\r\n PageLine := TPageLine.Create;\r\n PageLine.FirstLine := 0;\r\n FPages.Add(PageLine);\r\n YPos := FMargins.PTop;\r\n if SelectedOnly then\r\n begin\r\n iStartLine := fBlockBegin.Line -1;\r\n iEndLine := fBlockEnd.Line -1;\r\n end\r\n else begin\r\n iStartLine := 0;\r\n iEndLine := Lines.Count -1;\r\n end;\r\n for i := iStartLine to iEndLine do\r\n begin\r\n if not fSelectedOnly or (fSelMode = smLine) then\r\n Text := Lines[i]\r\n else\r\n begin\r\n if (fSelMode = smColumn) or (i = fBlockBegin.Line -1) then\r\n iSelStart := fBlockBegin.Char\r\n else\r\n iSelStart := 1;\r\n if (fSelMode = smColumn) or (i = fBlockEnd.Line -1) then\r\n iSelLen := fBlockEnd.Char - iSelStart\r\n else\r\n iSelLen := MaxInt;\r\n Text := Copy( Lines[i], iSelStart, iSelLen );\r\n end;\r\n {if new page then increase FPageCount and save the top-line number in\r\n FPages}\r\n if YPos + FLineHeight > FMargins.PBottom then\r\n begin\r\n YPos := FMargins.PTop;\r\n FPageCount := FPageCount + 1;\r\n PageLine := TPageLine.Create;\r\n PageLine.FirstLine := i;\r\n FPages.Add(PageLine);\r\n end;\r\n StrWidth := TextWidth(FCanvas, Text);\r\n {Check for wrap}\r\n if Wrap and (StrWidth > FMaxWidth) then begin \r\n AList := TList.Create;\r\n if WrapTextEx(Text, [' ', '-', #9, ','], FMaxCol, AList) then\r\n CountWrapped\r\n else\r\n begin\r\n {If WrapTextToList didn't succed with the first set of breakchars\r\n then try this one:}\r\n if WrapTextEx(Text, [';', ')', '.'], FMaxCol, AList) then\r\n CountWrapped\r\n else\r\n begin\r\n {If WrapTextToList didn't succed at all, then do it the\r\n primitive way}\r\n while Length(Text) > 0 do\r\n begin\r\n AStr := Copy(Text, 1, FMaxCol);\r\n Delete(Text, 1, FMaxCol);\r\n if Length(Text) > 0 then\r\n YPos := YPos + FLineHeight;\r\n end;\r\n end;\r\n end;\r\n for j := 0 to AList.Count - 1 do\r\n TWrapPos(AList[j]).Free;\r\n AList.Free;\r\n end;\r\n YPos := YPos + FLineHeight;\r\n end;\r\n FPagesCounted := True;\r\nend;\r\n\r\n{ Writes the line number. FMargins. PLeft is the position of the left margin\r\n (which is automatically incremented by the length of the linenumber text, if\r\n the linenumbers should not be placed in the margin) }\r\nprocedure TSynEditPrint.WriteLineNumber;\r\nvar\r\n AStr: UnicodeString;\r\nbegin\r\n SaveCurrentFont;\r\n AStr := IntToStr(FLineNumber + FLineOffset) + ': ';\r\n FCanvas.Brush.Color := FDefaultBG; \r\n FCanvas.Font.Style := [];\r\n FCanvas.Font.Color := clBlack;\r\n {$IFDEF SYN_CLX}\r\n QSynUnicode.\r\n {$ELSE}\r\n SynUnicode.\r\n {$ENDIF}\r\n TextOut(FCanvas, FMargins.PLeft - TextWidth(FCanvas, AStr), FYPos, AStr);\r\n RestoreCurrentFont;\r\nend;\r\n\r\nprocedure TSynEditPrint.HandleWrap(const Text: UnicodeString; MaxWidth: Integer);\r\nvar\r\n AStr: UnicodeString;\r\n AList: TList;\r\n j: Integer;\r\n\r\n procedure WrapPrimitive;\r\n var\r\n i: Integer;\r\n WrapPos: TWrapPos;\r\n begin\r\n i := 1;\r\n while i <= Length(Text) do\r\n begin\r\n AStr := '';\r\n while (Length(AStr) < FMaxCol) and (i <= Length(Text)) do\r\n begin\r\n AStr := AStr + Text[i];\r\n i := i + 1;\r\n end;\r\n WrapPos := TWrapPos.Create;\r\n WrapPos.Index := i - 1;\r\n AList.Add(WrapPos);\r\n if (Length(AStr) - i) <= FMaxCol then\r\n Break;\r\n end;\r\n end;\r\n \r\nbegin\r\n AStr := '';\r\n //First try to break the string at the following chars:\r\n AList := TList.Create;\r\n if WrapTextEx(Text, [' ', '-', #9, ','], FMaxCol, AList) then\r\n TextOut(Text, AList)\r\n else\r\n begin\r\n //Then try to break the string at the following chars:\r\n if WrapTextEx(Text, [';', ')', '.'], FMaxCol, AList) then\r\n TextOut(Text, AList)\r\n else\r\n begin\r\n WrapPrimitive;\r\n TextOut(Text, AList)\r\n end;\r\n end;\r\n for j := 0 to AList.Count - 1 do\r\n TWrapPos(Alist[j]).Free;\r\n AList.Free;\r\nend;\r\n\r\nprocedure TSynEditPrint.SaveCurrentFont;\r\nbegin\r\n FOldFont.Assign(FCanvas.Font);\r\nend;\r\n\r\nprocedure TSynEditPrint.RestoreCurrentFont;\r\nbegin\r\n FCanvas.Font.Assign(FOldFont);\r\nend;\r\n\r\nfunction TSynEditPrint.ClipLineToRect(S: UnicodeString; R: TRect): UnicodeString;\r\nbegin\r\n while TextWidth(FCanvas, S) > FMaxWidth do\r\n SetLength(S, Length(S) - 1);\r\n\r\n Result := S;\r\nend;\r\n\r\n//Does the actual printing\r\nprocedure TSynEditPrint.TextOut(const Text: UnicodeString; AList: TList);\r\nvar\r\n Token: UnicodeString;\r\n TokenPos: Integer;\r\n Attr: TSynHighlighterAttributes;\r\n AColor: TColor;\r\n TokenStart: Integer;\r\n LCount: Integer;\r\n Handled: Boolean;\r\n aStr: UnicodeString;\r\n i, WrapPos, OldWrapPos: Integer;\r\n Lines: TUnicodeStringList;\r\n ClipRect: TRect;\r\n sLine, sLineExpandedAtWideGlyphs: UnicodeString;\r\n ExpandedPos: Integer;\r\n\r\n {$IFNDEF SYN_CLX}\r\n procedure InitETODist(CharWidth: Integer; const Text: UnicodeString);\r\n var\r\n Size: TSize;\r\n i: Integer;\r\n begin\r\n ReallocMem(FETODist, Length(Text) * SizeOf(Integer));\r\n for i := 0 to Length(Text) - 1 do\r\n begin\r\n Size := GetTextSize(FCanvas.Handle, @Text[i + 1], 1);\r\n FETODist[i] := Ceil(Size.cx / CharWidth) * CharWidth;\r\n end;\r\n end;\r\n {$ENDIF}\r\n \r\n procedure ClippedTextOut(X, Y: Integer; Text: UnicodeString);\r\n begin\r\n Text := ClipLineToRect(Text, ClipRect);\r\n {$IFDEF SYN_CLX}\r\n QSynUnicode.TextOut(FCanvas, X, Y, Text);\r\n {$ELSE}\r\n InitETODist(FCharWidth, Text);\r\n Windows.ExtTextOutW(FCanvas.Handle, X, Y, 0, nil, PWideChar(Text),\r\n Length(Text), PInteger(FETODist));\r\n {$ENDIF}\r\n end;\r\n\r\n procedure SplitToken;\r\n var\r\n AStr: UnicodeString;\r\n Last: Integer;\r\n FirstPos: Integer;\r\n TokenEnd: Integer;\r\n begin\r\n Last := TokenPos;\r\n FirstPos := TokenPos;\r\n TokenEnd := TokenPos + Length(Token);\r\n while (LCount < AList.Count) and (TokenEnd > TWrapPos(AList[LCount]).Index) do\r\n begin\r\n AStr := Copy(Text, Last + 1, TWrapPos(AList[LCount]).Index - Last);\r\n Last := TWrapPos(AList[LCount]).Index;\r\n ExpandedPos := FHighlighter.PosToExpandedPos(FirstPos);\r\n ClippedTextOut(FMargins.PLeft + ExpandedPos * FCharWidth, FYPos, AStr);\r\n FirstPos := 0;\r\n LCount := LCount + 1;\r\n FYPos := FYPos + FLineHeight;\r\n end;\r\n AStr := Copy(Text, Last + 1, TokenEnd - Last);\r\n ExpandedPos := FHighlighter.PosToExpandedPos(FirstPos);\r\n ClippedTextOut(FMargins.PLeft + ExpandedPos * FCharWidth, FYPos, AStr);\r\n //Ready for next token:\r\n TokenStart := TokenPos + Length(Token) - Length(AStr);\r\n end;\r\nbegin\r\n with FMargins do\r\n ClipRect := Rect(PLeft, PTop, PRight, PBottom);\r\n\r\n if FSynOK then\r\n begin\r\n SaveCurrentFont;\r\n FHighlighter.SetRange(FLines.Objects[FLineNumber - 1]);\r\n sLine := Text;\r\n sLineExpandedAtWideGlyphs := ExpandAtWideGlyphs(sLine);\r\n FHighlighter.SetLineExpandedAtWideGlyphs(sLine, sLineExpandedAtWideGlyphs, FLineNumber);\r\n\r\n Token := '';\r\n TokenStart := 0;\r\n LCount := 0;\r\n while not FHighLighter.GetEol do\r\n begin\r\n Token := FHighLighter.GetToken;\r\n TokenPos := FHighLighter.GetTokenPos;\r\n Attr := FHighLighter.GetTokenAttribute;\r\n if Assigned(Attr) then\r\n begin\r\n FCanvas.Font.Style := Attr.Style;\r\n if FColors then\r\n begin\r\n AColor := Attr.Foreground;\r\n if AColor = clNone then\r\n AColor := FFont.Color;\r\n FCanvas.Font.Color := AColor;\r\n AColor := Attr.Background;\r\n if AColor = clNone then\r\n AColor := FDefaultBG;\r\n FCanvas.Brush.Color := AColor;\r\n end\r\n else\r\n begin\r\n FCanvas.Font.Color := fFontColor; \r\n FCanvas.Brush.Color := FDefaultBG;\r\n end;\r\n end\r\n else\r\n begin\r\n FCanvas.Font.Color := fFontColor; \r\n FCanvas.Brush.Color := FDefaultBG;\r\n end;\r\n Handled := False;\r\n if Assigned(AList) then\r\n begin\r\n if (LCount < AList.Count) then\r\n begin\r\n //Split between tokens:\r\n if (TokenPos >= TWrapPos(AList[LCount]).Index) then\r\n begin\r\n LCount := LCount + 1;\r\n TokenStart := TokenPos;\r\n FYPos := FYPos + FLineHeight;\r\n end\r\n else\r\n begin\r\n //Split in the middle of a token:\r\n if (TokenPos + Length(Token) > TWrapPos(AList[LCount]).Index) then begin\r\n Handled := True;\r\n SplitToken;\r\n end;\r\n end;\r\n end;\r\n end;\r\n {$IFNDEF SYN_CLX}\r\n if not Handled then\r\n begin\r\n ExpandedPos := FHighLighter.PosToExpandedPos(TokenPos - TokenStart);\r\n ClippedTextOut(FMargins.PLeft + ExpandedPos * FCharWidth, FYPos, Token);\r\n end;\r\n {$ENDIF}\r\n FHighLighter.Next;\r\n end;\r\n RestoreCurrentFont;\r\n end\r\n else\r\n begin\r\n Lines := TUnicodeStringList.Create;\r\n try\r\n OldWrapPos := 0;\r\n if Assigned(AList) then\r\n for i := 0 to AList.Count - 1 do\r\n begin\r\n WrapPos := TWrapPos(AList[i]).Index;\r\n if i = 0 then\r\n AStr := Copy(Text, 1, WrapPos)\r\n else\r\n AStr := Copy(Text, OldWrapPos + 1, WrapPos - OldWrapPos);\r\n Lines.Add(AStr);\r\n OldWrapPos := WrapPos;\r\n end;\r\n if Length(Text) > 0 then\r\n Lines.Add(Copy(Text, OldWrapPos + 1, MaxInt));\r\n\r\n for i := 0 to Lines.Count - 1 do\r\n begin\r\n ClippedTextOut(FMargins.PLeft, FYPos, Lines[i]);\r\n if i < Lines.Count - 1 then\r\n FYPos := FYPos + FLineHeight;\r\n end;\r\n finally\r\n Lines.Free;\r\n end\r\n end\r\nend;\r\n\r\nprocedure TSynEditPrint.WriteLine(const Text: UnicodeString);\r\nvar\r\n StrWidth: Integer;\r\nbegin\r\n if FLineNumbers then WriteLineNumber;\r\n StrWidth := TextWidth(FCanvas, Text);\r\n {Note that MaxWidth is calculated, using FTestString found in CalcPages -\r\n else the length is not calculated correctly when prewiewing and the\r\n zoom is different from 0.25,0.5,1,2,4 (as for example 1.20) - WHY???\r\n }\r\n if Wrap and (StrWidth > FMaxWidth) then\r\n HandleWrap(Text, FMaxWidth)\r\n else\r\n TextOut(Text, nil);\r\n FYPos := FYPos + FLineHeight;\r\nend;\r\n\r\nprocedure TSynEditPrint.PrintPage(Num: Integer);\r\n//Prints a page\r\nvar\r\n i, iEnd: Integer;\r\n iSelStart, iSelLen: integer;\r\nbegin\r\n PrintStatus(psNewPage, Num, FAbort);\r\n if not FAbort then\r\n begin\r\n FCanvas.Brush.Color := Color;\r\n with FMargins do\r\n FCanvas.FillRect(Rect(PLeft, PTop, PRight, PBottom));\r\n FMargins.InitPage(FCanvas, Num, FPrinterInfo, FLineNumbers,\r\n FLineNumbersInMargin, FLines.Count - 1 + FLineOffset);\r\n FHeader.Print(FCanvas, Num + FPageOffset);\r\n if FPages.Count > 0 then\r\n begin\r\n FYPos := FMargins.PTop;\r\n if Num = FPageCount then\r\n iEnd := FLines.Count - 1\r\n else\r\n iEnd := TPageLine(FPages[Num]).FirstLine - 1;\r\n for i := TPageLine(FPages[Num - 1]).FirstLine to iEnd do\r\n begin\r\n FLineNumber := i + 1;\r\n if (not fSelectedOnly or ((i >= fBlockBegin.Line - 1) and (i <= fBlockEnd.Line - 1))) then begin\r\n if (not fSelectedOnly or (fSelMode = smLine)) then\r\n WriteLine(Lines[i])\r\n else\r\n begin\r\n if (fSelMode = smColumn) or (i = fBlockBegin.Line -1) then\r\n iSelStart := fBlockBegin.Char\r\n else\r\n iSelStart := 1;\r\n if (fSelMode = smColumn) or (i = fBlockEnd.Line -1) then\r\n iSelLen := fBlockEnd.Char - iSelStart\r\n else\r\n iSelLen := MaxInt;\r\n WriteLine( Copy( Lines[i], iSelStart, iSelLen ) );\r\n end;\r\n PrintLine(i + 1, Num);\r\n end;\r\n end;\r\n end;\r\n FFooter.Print(FCanvas, Num + FPageOffset);\r\n end;\r\nend;\r\n\r\nprocedure TSynEditPrint.UpdatePages(ACanvas: TCanvas);\r\n//Update pages (called explicitly by preview component)\r\nbegin\r\n FCanvas := ACanvas;\r\n FPrinterInfo.UpdatePrinter;\r\n InitPrint;\r\nend;\r\n\r\nprocedure TSynEditPrint.PrintToCanvas(ACanvas: TCanvas; PageNumber: Integer);\r\n//Print to specified canvas. Used by preview component\r\nbegin\r\n FAbort := False;\r\n FPrinting := False;\r\n FCanvas := ACanvas;\r\n PrintPage(PageNumber);\r\nend;\r\n\r\nprocedure TSynEditPrint.Print;\r\nbegin\r\n PrintRange(1, -1);\r\nend;\r\n\r\nprocedure TSynEditPrint.PrintRange(StartPage, EndPage: Integer);\r\n//Prints the pages in the specified range\r\nvar\r\n i, ii: Integer;\r\nbegin\r\n if fSelectedOnly and not fSelAvail then\r\n exit;\r\n\r\n FPrinting := True;\r\n FAbort := False;\r\n // The next part sets the document title that is used by the printer queue.\r\n if FDocTitle <> '' then\r\n Printer.Title := FDocTitle\r\n else\r\n Printer.Title := FTitle;\r\n Printer.BeginDoc;\r\n PrintStatus(psBegin, StartPage, FAbort);\r\n UpdatePages(Printer.Canvas);\r\n\r\n for ii:=1 to Copies do\r\n begin\r\n i := StartPage;\r\n if EndPage < 0 then\r\n EndPage := FPageCount;\r\n while (i <= EndPage) and (not FAbort) do begin\r\n PrintPage(i);\r\n if ((i < EndPage) or (ii 0 then\r\n begin\r\n TmpCanvas.Handle := DC;\r\n UpdatePages(TmpCanvas);\r\n TmpCanvas.Handle := 0;\r\n Result := FPageCount;\r\n FPagesCounted := True;\r\n end;\r\n finally\r\n ReleaseDC(0, DC);\r\n end;\r\n {$ENDIF}\r\n finally\r\n TmpCanvas.Free;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TSynEditPrint.SetSynEdit(const Value: TCustomSynEdit);\r\nbegin\r\n// Lines := Value.Lines;\r\n HighLighter := Value.Highlighter;\r\n Font := Value.Font;\r\n FTabWidth := Value.TabWidth;\r\n Lines := Value.Lines;\r\n fSelAvail := Value.SelAvail;\r\n fBlockBegin := Value.BlockBegin;\r\n fBlockEnd := Value.BlockEnd;\r\n fSelMode := Value.SelectionMode;\r\nend;\r\n\r\nprocedure TSynEditPrint.LoadFromStream(AStream: TStream);\r\nvar\r\n Len, BufferSize: Integer;\r\n Buffer: PWideChar;\r\nbegin\r\n FHeader.LoadFromStream(AStream);\r\n FFooter.LoadFromStream(AStream);\r\n FMargins.LoadFromStream(AStream);\r\n with AStream do\r\n begin\r\n Read(Len, sizeof(Len));\r\n BufferSize := Len * sizeof(WideChar);\r\n GetMem(Buffer, BufferSize + sizeof(WideChar));\r\n try\r\n Read(Buffer^, BufferSize);\r\n Buffer[BufferSize div sizeof(WideChar)] := #0;\r\n FTitle := Buffer;\r\n finally\r\n FreeMem(Buffer);\r\n end;\r\n Read(Len, sizeof(Len));\r\n BufferSize := Len * sizeof(WideChar);\r\n GetMem(Buffer, BufferSize + sizeof(WideChar));\r\n try\r\n Read(Buffer^, BufferSize);\r\n Buffer[BufferSize div sizeof(WideChar)] := #0;\r\n FDocTitle := Buffer;\r\n finally\r\n FreeMem(Buffer);\r\n end;\r\n Read(FWrap, SizeOf(FWrap));\r\n Read(FHighlight, SizeOf(FHighlight));\r\n Read(FColors, SizeOf(FColors));\r\n Read(FLineNumbers, SizeOf(FLineNumbers));\r\n Read(FLineOffset, SizeOf(FLineOffset));\r\n Read(FPageOffset, SizeOf(FPageOffset));\r\n end;\r\nend;\r\n\r\nprocedure TSynEditPrint.SaveToStream(AStream: TStream);\r\nvar\r\n aLen: Integer;\r\nbegin\r\n FHeader.SaveToStream(AStream);\r\n FFooter.SaveToStream(AStream);\r\n FMargins.SaveToStream(AStream);\r\n with AStream do\r\n begin\r\n aLen := Length(FTitle);\r\n Write(aLen, SizeOf(aLen));\r\n Write(PWideChar(FTitle)^, aLen * sizeof(WideChar));\r\n aLen := Length(FDocTitle);\r\n Write(aLen, SizeOf(aLen));\r\n Write(PWideChar(FDocTitle)^, aLen * sizeof(WideChar));\r\n Write(FWrap, SizeOf(FWrap));\r\n Write(FHighlight, SizeOf(FHighlight));\r\n Write(FColors, SizeOf(FColors));\r\n Write(FLineNumbers, SizeOf(FLineNumbers));\r\n Write(FLineOffset, SizeOf(FLineOffset));\r\n Write(FPageOffset, SizeOf(FPageOffset));\r\n end;\r\nend;\r\n\r\nprocedure TSynEditPrint.SetFooter(const Value: TFooter);\r\nbegin\r\n FFooter.Assign(Value);\r\nend;\r\n\r\nprocedure TSynEditPrint.SetHeader(const Value: THeader);\r\nbegin\r\n FHeader.Assign(Value);\r\nend;\r\n\r\nprocedure TSynEditPrint.SetMargins(const Value: TSynEditPrintMargins);\r\nbegin\r\n FMargins.Assign(Value);\r\nend;\r\n\r\nend.\r\n\r\n" }, { "path": "External/SynEdit/Source/SynEditPrintHeaderFooter.pas", "content": "{-------------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: SynEditPrintHeaderFooter.pas, released 2000-06-01.\r\n\r\nThe Initial Author of the Original Code is Morten J. Skovrup.\r\nPortions written by Morten J. Skovrup are copyright 2000 Morten J. Skovrup.\r\nPortions written by Michael Hieke are copyright 2000 Michael Hieke.\r\nUnicode translation by Mal Hrz.\r\nAll Rights Reserved.\r\n\r\nContributors to the SynEdit project are listed in the Contributors.txt file.\r\n\r\nAlternatively, the contents of this file may be used under the terms of the\r\nGNU General Public License Version 2 or later (the \"GPL\"), in which case\r\nthe provisions of the GPL are applicable instead of those above.\r\nIf you wish to allow use of your version of this file only under the terms\r\nof the GPL and not to allow others to use your version of this file\r\nunder the MPL, indicate your decision by deleting the provisions above and\r\nreplace them with the notice and other provisions required by the GPL.\r\nIf you do not delete the provisions above, a recipient may use your version\r\nof this file under either the MPL or the GPL.\r\n\r\n$Id: SynEditPrintHeaderFooter.pas,v 1.10.2.7 2008/09/23 14:02:08 maelh Exp $\r\n\r\nYou may retrieve the latest version of this file at the SynEdit home page,\r\nlocated at http://SynEdit.SourceForge.net\r\n\r\nKnown Issues:\r\n-------------------------------------------------------------------------------}\r\n\r\n\r\n{-------------------------------------------------------------------------------\r\nCONTENTS:\r\n Classes handling info about headers and footers.\r\n\r\n THeaderFooterItem:\r\n Class handling an item in a header or footer. An item has a text,Font,\r\n LineNumber and Alignment (i.e. two items can be on the same line but have\r\n different fonts). Used internally.\r\n\r\n THeaderFooter:\r\n Collection of THeaderFooterItem's\r\n Design-time properties:\r\n FrameTypes : Frame around header or footer - can be any combination of:\r\n ftLine : Line under header or line above footer\r\n ftBox : Box around header or footer\r\n ftShaded : Filled box (without frame) around header or footer.\r\n ShadedColor : Fill color if ftShaded is in FrameTypes\r\n LineColor : Color of line or box if ftLine or ftBox is in FrameTypes\r\n DefaultFont : Default font for THeaderFooterItem's. This can be used to\r\n set the header/footer font once for all items.\r\n RomanNumbers : Print page numbers as Roman numbers.\r\n MirrorPosition : Mirror position of left/right aligned THeaderFooterItem's\r\n Can be used when printing 2-sided.\r\n Run-time methods:\r\n function Add(Text: UnicodeString; Font: TFont;\r\n Alignment: TAlignment;\r\n LineNumber: Integer) : Integer;\r\n Add a THeaderFooterItem. If Font is nil or not specified then DefaultFont\r\n is used. Returned value is the index of the added item.\r\n The Text parameter can contain the following macros:\r\n $PAGECOUNT$ : Print total number of pages\r\n $PAGENUM$ : Print current page number\r\n $TITLE$ : Print the title\r\n $DATE$ : Print the date\r\n $TIME$ : Print the time\r\n $DATETIME$ : Print the date and then the time\r\n $TIMEDATE$ : Print the time and then the date\r\n procedure Delete(Index : Integer);\r\n Delete THeaderFooterItem with index Index.\r\n procedure Clear;\r\n Clear all THeaderFooterItems.\r\n function Count : Integer;\r\n Returns number of THeaderFooterItems.\r\n function Get(Index : Integer) : THeaderFooterItem;\r\n Returns THeaderFooterItem with Index.\r\n procedure SetPixPrInch(Value : Integer);\r\n Corrects the PixPerInch property of fonts. Used internally by\r\n TSynEditPrint.\r\n procedure InitPrint(ACanvas : TCanvas;NumPages : Integer; Title : UnicodeString;\r\n Margins : TSynEditPrintMargins);\r\n Prepares the header or footer for printing. Used internally by\r\n TSynEditPrint.\r\n procedure Print(ACanvas : TCanvas; PageNum : Integer = 0);\r\n Prints the header or footer. Used internally by TSynEditPrint.\r\n\r\n-------------------------------------------------------------------------------}\r\n\r\n{$IFNDEF QSYNEDITPRINTHEADERFOOTER}\r\nunit SynEditPrintHeaderFooter;\r\n{$ENDIF}\r\n{$M+}\r\n\r\n{$I SynEdit.inc}\r\n\r\ninterface\r\n\r\nuses\r\n{$IFDEF SYN_CLX}\r\n Qt,\r\n QSynEditPrintTypes,\r\n QSynEditPrintMargins,\r\n QSynUnicode,\r\n QGraphics,\r\n{$ELSE}\r\n Windows,\r\n SynEditPrintTypes,\r\n SynEditPrintMargins,\r\n SynUnicode,\r\n Graphics,\r\n{$ENDIF}\r\n Classes,\r\n SysUtils;\r\n\r\ntype\r\n //An item in a header or footer. An item has a text,Font,LineNumber and\r\n //Alignment (i.e. two items can be on the same line but have different\r\n //fonts).\r\n THeaderFooterItem = class\r\n private\r\n FText: UnicodeString;\r\n FFont: TFont;\r\n FLineNumber: Integer;\r\n FAlignment: TAlignment;\r\n {Used to store the original Index when the item was added - the index\r\n might change when the list is sorted}\r\n FIndex: Integer;\r\n function GetAsString: UnicodeString;\r\n procedure SetAsString(const Value: UnicodeString);\r\n procedure SetFont(const Value: TFont);\r\n public\r\n constructor Create;\r\n destructor Destroy; override;\r\n function GetText(NumPages, PageNum: Integer; Roman: Boolean;\r\n Title, ATime, ADate: UnicodeString): UnicodeString;\r\n procedure LoadFromStream(AStream: TStream);\r\n procedure SaveToStream(AStream: TStream);\r\n public\r\n property Alignment: TAlignment read FAlignment write FAlignment;\r\n property AsString: UnicodeString read GetAsString write SetAsString;\r\n property Font: TFont read FFont write SetFont;\r\n property LineNumber: Integer read FLineNumber write FLineNumber;\r\n property Text: UnicodeString read FText write FText;\r\n end;\r\n\r\n THeaderFooterType = (hftHeader, hftFooter);\r\n\r\n //Used internally to calculate line height and font-base-line for header and\r\n //footer\r\n TLineInfo = class\r\n public\r\n LineHeight: Integer;\r\n MaxBaseDist: Integer;\r\n end;\r\n\r\n //The header/footer class\r\n THeaderFooter = class(TPersistent)\r\n private\r\n FType: THeaderFooterType; // Indicates if header or footer\r\n FFrameTypes: TFrameTypes;\r\n FShadedColor: TColor;\r\n FLineColor: TColor;\r\n FItems: TList;\r\n FDefaultFont: TFont;\r\n FDate, FTime: UnicodeString;\r\n FNumPages: Integer;\r\n FTitle: UnicodeString;\r\n FMargins: TSynEditPrintMargins;\r\n FFrameHeight: Integer;\r\n FOldPen: TPen;\r\n FOldBrush: TBrush;\r\n FOldFont: TFont;\r\n FRomanNumbers: Boolean;\r\n FLineInfo: TList;\r\n FLineCount: Integer;\r\n FMirrorPosition: Boolean;\r\n procedure SetDefaultFont(const Value: TFont);\r\n procedure DrawFrame(ACanvas: TCanvas);\r\n procedure CalcHeight(ACanvas: TCanvas);\r\n procedure SaveFontPenBrush(ACanvas: TCanvas);\r\n procedure RestoreFontPenBrush(ACanvas: TCanvas);\r\n function GetAsString: UnicodeString;\r\n procedure SetAsString(const Value: UnicodeString);\r\n public\r\n constructor Create;\r\n destructor Destroy; override;\r\n function Add(Text: UnicodeString; Font: TFont; Alignment: TAlignment;\r\n LineNumber: Integer): Integer;\r\n procedure Delete(Index: Integer);\r\n procedure Clear;\r\n function Count: Integer;\r\n function Get(Index: Integer): THeaderFooterItem;\r\n procedure SetPixPrInch(Value: Integer);\r\n procedure InitPrint(ACanvas: TCanvas; NumPages: Integer; Title: UnicodeString;\r\n Margins: TSynEditPrintMargins);\r\n procedure Print(ACanvas: TCanvas; PageNum: Integer);\r\n procedure Assign(Source: TPersistent); override;\r\n procedure FixLines;\r\n property AsString: UnicodeString read GetAsString write SetAsString;\r\n procedure LoadFromStream(AStream: TStream);\r\n procedure SaveToStream(AStream: TStream);\r\n published\r\n property FrameTypes: TFrameTypes read FFrameTypes write FFrameTypes\r\n default [ftLine];\r\n property ShadedColor: TColor read FShadedColor write FShadedColor\r\n default clSilver;\r\n property LineColor: TColor read FLineColor write FLineColor default clBlack;\r\n property DefaultFont: TFont read FDefaultFont write SetDefaultFont;\r\n property RomanNumbers: Boolean read FRomanNumbers write FRomanNumbers\r\n default False;\r\n property MirrorPosition: Boolean read FMirrorPosition write FMirrorPosition\r\n default False;\r\n end;\r\n\r\n //The header and footer - does nothing but set the value of FType in\r\n //THeaderFooter\r\n THeader = class(THeaderFooter)\r\n public\r\n constructor Create;\r\n end;\r\n\r\n TFooter = class(THeaderFooter)\r\n public\r\n constructor Create;\r\n end;\r\n\r\n {$IFNDEF SYN_COMPILER_3_UP}\r\n TFontCharSet = 0..255;\r\n {$ENDIF}\r\n\r\nimplementation\r\n\r\nuses\r\n{$IFDEF SYN_COMPILER_4_UP}\r\n Math,\r\n{$ENDIF}\r\n{$IFDEF SYN_CLX}\r\n QSynEditMiscProcs;\r\n{$ELSE}\r\n SynEditMiscProcs, System.UITypes;\r\n{$ENDIF}\r\n\r\n// Helper routine for AsString processing.\r\nfunction GetFirstEl(var Value: UnicodeString; Delim: WideChar): UnicodeString;\r\nvar\r\n p: Integer;\r\nbegin\r\n p := Pos(Delim, Value);\r\n if p = 0 then\r\n p := Length(Value) + 1;\r\n Result := Copy(Value, 1, p - 1);\r\n Delete(Value, 1, p);\r\nend;\r\n\r\n\r\n{ THeaderFooterItem }\r\n\r\nconstructor THeaderFooterItem.Create;\r\nbegin\r\n inherited;\r\n FFont := TFont.Create;\r\nend;\r\n\r\ndestructor THeaderFooterItem.Destroy;\r\nbegin\r\n inherited;\r\n FFont.Free;\r\nend;\r\n\r\n// Returns string representation of THeaderFooterItem to alleviate storing\r\n// items into external storage (registry, ini file).\r\nfunction THeaderFooterItem.GetAsString: UnicodeString;\r\nbegin\r\n Result :=\r\n EncodeString(FText) + '/' +\r\n{$IFDEF SYN_COMPILER_3_UP}\r\n{$IFDEF SYN_CLX}\r\n IntToStr(Ord(FFont.Charset)) + '/' +\r\n{$ELSE}\r\n IntToStr(FFont.Charset) + '/' +\r\n{$ENDIF}\r\n{$ELSE}\r\n IntToStr(DEFAULT_CHARSET)+'/' + \r\n{$ENDIF}\r\n IntToStr(FFont.Color) + '/' +\r\n IntToStr(FFont.Height) + '/' +\r\n EncodeString(FFont.Name) + '/' +\r\n IntToStr(Ord(FFont.Pitch)) + '/' +\r\n IntToStr(FFont.PixelsPerInch) + '/' +\r\n IntToStr(FFont.Size) + '/' +\r\n IntToStr(byte(FFont.Style)) + '/' +\r\n IntToStr(FLineNumber) + '/' +\r\n IntToStr(Ord(FAlignment));\r\nend;\r\n\r\n\r\n{ This is basically copied from original SynEditPrint.pas. Returns the\r\n header/footer text with macros expanded }\r\nfunction THeaderFooterItem.GetText(NumPages, PageNum: Integer;\r\n Roman: Boolean; Title, ATime, ADate: UnicodeString): UnicodeString;\r\nvar\r\n Len, Start, Run: Integer;\r\n AStr: UnicodeString;\r\n\r\n procedure DoAppend(AText: UnicodeString);\r\n begin\r\n Result := Result + AText;\r\n end;\r\n procedure TryAppend(var First: Integer; After: Integer);\r\n begin\r\n if After > First then\r\n begin\r\n DoAppend(Copy(AStr, First, After - First));\r\n First := After;\r\n end;\r\n end;\r\n function TryExecuteMacro: Boolean;\r\n var\r\n Macro: UnicodeString;\r\n begin\r\n Result := True;\r\n Macro := SynWideUpperCase(Copy(FText, Start, Run - Start + 1));\r\n if Macro = '$PAGENUM$' then\r\n begin\r\n if Roman then\r\n DoAppend(IntToRoman(PageNum))\r\n else\r\n DoAppend(IntToStr(PageNum));\r\n Exit;\r\n end;\r\n if Macro = '$PAGECOUNT$' then\r\n begin\r\n if Roman then\r\n DoAppend(IntToRoman(NumPages))\r\n else\r\n DoAppend(IntToStr(NumPages));\r\n Exit;\r\n end;\r\n if Macro = '$TITLE$' then\r\n begin\r\n DoAppend(Title);\r\n Exit;\r\n end;\r\n if Macro = '$DATE$' then\r\n begin\r\n DoAppend(ADate);\r\n Exit;\r\n end;\r\n if Macro = '$TIME$' then\r\n begin\r\n DoAppend(ATime);\r\n Exit;\r\n end;\r\n if Macro = '$DATETIME$' then\r\n begin\r\n DoAppend(ADate + ' ' + ATime);\r\n Exit;\r\n end;\r\n if Macro = '$TIMEDATE$' then\r\n begin\r\n DoAppend(ATime + ' ' + ADate);\r\n Exit;\r\n end;\r\n Result := False;\r\n end;\r\n\r\nbegin\r\n Result := '';\r\n AStr := FText;\r\n if WideTrim(AStr) = '' then\r\n Exit;\r\n // parse the line\r\n Len := Length(AStr);\r\n if Len > 0 then\r\n begin\r\n // start with left-aligned text\r\n Start := 1;\r\n Run := 1;\r\n while Run <= Len do\r\n begin\r\n // test for embedded macro\r\n if AStr[Run] = '$' then\r\n begin\r\n TryAppend(Start, Run);\r\n Inc(Run);\r\n // search for next '$' which could mark the end of a macro\r\n while Run <= Len do begin\r\n if AStr[Run] = '$' then\r\n begin\r\n // if this is a macro execute it and skip the chars from output\r\n if TryExecuteMacro then\r\n begin\r\n Inc(Run); // also the '$'\r\n Start := Run;\r\n break;\r\n end\r\n else\r\n begin\r\n // this '$' might again be the start of a macro\r\n TryAppend(Start, Run);\r\n Inc(Run); //ek 2001-08-02\r\n end;\r\n end\r\n else\r\n Inc(Run);\r\n end;\r\n end\r\n else\r\n Inc(Run);\r\n end;\r\n TryAppend(Start, Run);\r\n end;\r\nend;\r\n\r\nprocedure THeaderFooterItem.LoadFromStream(AStream: TStream);\r\nvar\r\n aCharset: TFontCharset;\r\n aColor: TColor;\r\n aHeight: Integer;\r\n aName: TFontName;\r\n aPitch: TFontPitch;\r\n aSize: Integer;\r\n aStyle: TFontStyles;\r\n Len, BufferSize: Integer;\r\n Buffer: Pointer;\r\nbegin\r\n with AStream do\r\n begin\r\n Read(Len, sizeof(Len));\r\n BufferSize := Len * sizeof(WideChar);\r\n GetMem(Buffer, BufferSize + sizeof(WideChar));\r\n try\r\n Read(Buffer^, BufferSize);\r\n PWideChar(Buffer)[BufferSize div sizeof(WideChar)] := #0;\r\n FText := PWideChar(Buffer);\r\n finally\r\n FreeMem(Buffer);\r\n end;\r\n Read(FLineNumber, sizeof(FLineNumber));\r\n // font\r\n Read(aCharset, sizeof(aCharset));\r\n Read(aColor, sizeof(aColor));\r\n Read(aHeight, sizeof(aHeight));\r\n Read(BufferSize, sizeof(BufferSize));\r\n GetMem(Buffer, BufferSize + 1);\r\n try\r\n Read(Buffer^, BufferSize);\r\n PAnsiChar(Buffer)[BufferSize div sizeof(AnsiChar)] := #0;\r\n aName := string(PAnsiChar(Buffer));\r\n finally\r\n FreeMem(Buffer);\r\n end;\r\n Read(aPitch, sizeof(aPitch));\r\n Read(aSize, sizeof(aSize));\r\n Read(aStyle, sizeof(aStyle));\r\n {$IFDEF SYN_COMPILER_3_UP}\r\n FFont.Charset := aCharset;\r\n {$ENDIF}\r\n FFont.Color := aColor;\r\n FFont.Height := aHeight;\r\n FFont.Name := aName;\r\n FFont.Pitch := aPitch;\r\n FFont.Size := aSize;\r\n FFont.Style := aStyle;\r\n Read(FAlignment, sizeof(FAlignment));\r\n end;\r\nend;\r\n\r\nprocedure THeaderFooterItem.SaveToStream(AStream: TStream);\r\nvar\r\n aCharset: TFontCharset;\r\n aColor: TColor;\r\n aHeight: Integer;\r\n aName: TFontName;\r\n aPitch: TFontPitch;\r\n aSize: Integer;\r\n aStyle: TFontStyles;\r\n aLen: Integer;\r\nbegin\r\n with AStream do\r\n begin\r\n aLen := Length(FText);\r\n Write(aLen, sizeof(aLen));\r\n Write(PWideChar(FText)^, aLen * sizeof(WideChar));\r\n Write(FLineNumber, sizeof(FLineNumber));\r\n // font\r\n {$IFDEF SYN_COMPILER_3_UP}\r\n aCharset := FFont.Charset;\r\n {$ELSE}\r\n aCharset := DEFAULT_CHARSET;\r\n {$ENDIF}\r\n aColor := FFont.Color;\r\n aHeight := FFont.Height;\r\n aName := FFont.Name;\r\n aPitch := FFont.Pitch;\r\n aSize := FFont.Size;\r\n aStyle := FFont.Style;\r\n Write(aCharset, SizeOf(aCharset));\r\n Write(aColor, SizeOf(aColor));\r\n Write(aHeight, SizeOf(aHeight));\r\n aLen := Length(aName);\r\n Write(aLen, SizeOf(aLen));\r\n {$IFDEF SYN_COMPILER_2} // In D2 TFontName is a ShortString\r\n Write(PAnsiChar(@aName[1])^, aLen); // D2 cannot convert ShortStrings to PAnsiChar\r\n {$ELSE}\r\n Write(PAnsiChar(AnsiString(aName))^, aLen);\r\n {$ENDIF}\r\n Write(aPitch, SizeOf(aPitch));\r\n Write(aSize, SizeOf(aSize));\r\n Write(aStyle, SizeOf(aStyle));\r\n Write(FAlignment, SizeOf(FAlignment));\r\n end;\r\nend;\r\n\r\nprocedure THeaderFooterItem.SetAsString(const Value: UnicodeString);\r\nvar\r\n s: UnicodeString;\r\n sty: TFontStyles;\r\nbegin\r\n s := Value;\r\n FText := DecodeString(GetFirstEl(s, '/'));\r\n{$IFDEF SYN_COMPILER_3_UP}\r\n{$IFDEF SYN_CLX}\r\n GetFirstEl(s, '/');\r\n{$ELSE}\r\n FFont.Charset := StrToIntDef(GetFirstEl(s, '/'), 0);\r\n{$ENDIF}\r\n{$ELSE}\r\n GetFirstEl(s, '/');\r\n{$ENDIF}\r\n FFont.Color := StrToIntDef(GetFirstEl(s, '/'), 0);\r\n FFont.Height := StrToIntDef(GetFirstEl(s, '/'), 0);\r\n FFont.Name := DecodeString(GetFirstEl(s, '/'));\r\n FFont.Pitch := TFontPitch(StrToIntDef(GetFirstEl(s, '/'), 0));\r\n FFont.PixelsPerInch := StrToIntDef(GetFirstEl(s, '/'), 0);\r\n FFont.Size := StrToIntDef(GetFirstEl(s, '/'), 0);\r\n byte(sty) := StrToIntDef(GetFirstEl(s, '/'), 0);\r\n FFont.Style := sty;\r\n FLineNumber := StrToIntDef(GetFirstEl(s, '/'), 0);\r\n FAlignment := TAlignment(StrToIntDef(GetFirstEl(s, '/'), 0));\r\nend;\r\n\r\nprocedure THeaderFooterItem.SetFont(const Value: TFont);\r\nbegin\r\n FFont.Assign(Value);\r\nend;\r\n\r\n{ THeaderFooter }\r\n\r\nconstructor THeaderFooter.Create;\r\nbegin\r\n inherited;\r\n FFrameTypes := [ftLine];\r\n FShadedColor := clSilver;\r\n FLineColor := clBlack;\r\n FItems := TList.Create;\r\n FDefaultFont := TFont.Create;\r\n FOldPen := TPen.Create;\r\n FOldBrush := TBrush.Create;\r\n FOldFont := TFont.Create;\r\n FRomanNumbers := False;\r\n FMirrorPosition := False;\r\n FLineInfo := TList.Create;\r\n with FDefaultFont do\r\n begin\r\n Name := 'Arial';\r\n Size := 10;\r\n Color := clBlack;\r\n end;\r\nend;\r\n\r\ndestructor THeaderFooter.Destroy;\r\nvar\r\n i: Integer;\r\nbegin\r\n Clear;\r\n FItems.Free;\r\n FDefaultFont.Free;\r\n FOldPen.Free;\r\n FOldBrush.Free;\r\n FOldFont.Free;\r\n for i := 0 to FLineInfo.Count - 1 do\r\n TLineInfo(FLineInfo[i]).Free;\r\n FLineInfo.Free;\r\n inherited;\r\nend;\r\n\r\nfunction THeaderFooter.Add(Text: UnicodeString; Font: TFont;\r\n Alignment: TAlignment; LineNumber: Integer): Integer;\r\nvar\r\n AItem: THeaderFooterItem;\r\nbegin\r\n AItem := THeaderFooterItem.Create;\r\n if Font = nil then\r\n AItem.Font := FDefaultFont\r\n else\r\n AItem.Font := Font;\r\n AItem.Alignment := Alignment;\r\n AItem.LineNumber := LineNumber;\r\n AItem.FIndex := FItems.Add(AItem);\r\n AItem.Text := Text;\r\n Result := AItem.FIndex;\r\nend;\r\n\r\nprocedure THeaderFooter.Delete(Index: Integer);\r\nvar\r\n i: Integer;\r\nbegin\r\n for i := 0 to FItems.Count - 1 do\r\n begin\r\n if THeaderFooterItem(FItems[i]).FIndex = Index then\r\n begin\r\n FItems.Delete(i);\r\n Break;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure THeaderFooter.Clear;\r\nvar\r\n i: Integer;\r\nbegin\r\n for i := 0 to FItems.Count - 1 do\r\n THeaderFooterItem(FItems[i]).Free;\r\n FItems.Clear;\r\nend;\r\n\r\nprocedure THeaderFooter.SetDefaultFont(const Value: TFont);\r\nbegin\r\n FDefaultFont.Assign(Value);\r\nend;\r\n\r\n{ Counts number of lines in header/footer and changes the line-number so they\r\n start with 1 (the user might add header/footer items starting at line 2) }\r\nprocedure THeaderFooter.FixLines;\r\nvar\r\n i, CurLine: Integer;\r\n LineInfo: TLineInfo;\r\nbegin\r\n for i := 0 to FLineInfo.Count - 1 do\r\n TLineInfo(FLineInfo[i]).Free;\r\n FLineInfo.Clear;\r\n CurLine := 0;\r\n FLineCount := 0;\r\n for i := 0 to FItems.Count - 1 do\r\n begin\r\n if THeaderFooterItem(FItems[i]).LineNumber <> CurLine then\r\n begin\r\n CurLine := THeaderFooterItem(FItems[i]).LineNumber;\r\n FLineCount := FLineCount + 1;\r\n LineInfo := TLineInfo.Create;\r\n FLineInfo.Add(LineInfo);\r\n end;\r\n THeaderFooterItem(FItems[i]).LineNumber := FLineCount;\r\n end;\r\nend;\r\n\r\n{ Calculates the hight of the header/footer, finds the line height for each line\r\n and calculates the font baseline where text is to be written }\r\nprocedure THeaderFooter.CalcHeight(ACanvas: TCanvas);\r\nvar\r\n i, CurLine: Integer;\r\n AItem: THeaderFooterItem;\r\n FOrgHeight: Integer;\r\n{$IFNDEF SYN_CLX}\r\n TextMetric: TTextMetric;\r\n{$ENDIF}\r\nbegin\r\n FFrameHeight := -1;\r\n if FItems.Count <= 0 then Exit;\r\n\r\n CurLine := 1;\r\n FFrameHeight := 0;\r\n FOrgHeight := FFrameHeight;\r\n for i := 0 to FItems.Count - 1 do\r\n begin\r\n AItem := THeaderFooterItem(FItems[i]);\r\n if AItem.LineNumber <> CurLine then\r\n begin\r\n CurLine := AItem.LineNumber;\r\n FOrgHeight := FFrameHeight;\r\n end;\r\n ACanvas.Font.Assign(AItem.Font);\r\n {$IFNDEF SYN_CLX}\r\n GetTextMetrics(ACanvas.Handle, TextMetric);\r\n with TLineInfo(FLineInfo[CurLine - 1]), TextMetric do\r\n begin\r\n LineHeight := Max(LineHeight, TextHeight(ACanvas, 'W'));\r\n MaxBaseDist := Max(MaxBaseDist, tmHeight - tmDescent);\r\n end;\r\n {$ENDIF}\r\n FFrameHeight := Max(FFrameHeight, FOrgHeight + TextHeight(ACanvas, 'W'));\r\n end;\r\n FFrameHeight := FFrameHeight + 2 * FMargins.PHFInternalMargin;\r\nend;\r\n\r\nfunction CompareItems(Item1, Item2: Pointer): Integer;\r\n//Used to sort header/footer items\r\nbegin\r\n Result := THeaderFooterItem(Item1).LineNumber - THeaderFooterItem(Item2).LineNumber;\r\n if Result = 0 then\r\n Result := Integer(Item1) - Integer(Item2);\r\nend;\r\n\r\nprocedure THeaderFooter.SetPixPrInch(Value: Integer);\r\nvar\r\n i, TmpSize: Integer;\r\n AFont: TFont;\r\nbegin\r\n for i := 0 to FItems.Count - 1 do\r\n begin\r\n AFont := THeaderFooterItem(FItems[i]).Font;\r\n TmpSize := AFont.Size;\r\n AFont.PixelsPerInch := Value;\r\n AFont.Size := TmpSize;\r\n end;\r\nend;\r\n\r\nprocedure THeaderFooter.InitPrint(ACanvas: TCanvas; NumPages: Integer; Title: UnicodeString;\r\n Margins: TSynEditPrintMargins);\r\nbegin\r\n SaveFontPenBrush(ACanvas);\r\n FDate := DateToStr(Now);\r\n FTime := TimeToStr(Now);\r\n FNumPages := NumPages;\r\n FMargins := Margins;\r\n FTitle := Title;\r\n FItems.Sort(CompareItems);\r\n FixLines;\r\n CalcHeight(ACanvas);\r\n RestoreFontPenBrush(ACanvas);\r\nend;\r\n\r\nprocedure THeaderFooter.SaveFontPenBrush(ACanvas: TCanvas);\r\nbegin\r\n FOldFont.Assign(ACanvas.Font);\r\n FOldPen.Assign(ACanvas.Pen);\r\n FOldBrush.Assign(ACanvas.Brush);\r\nend;\r\n\r\nprocedure THeaderFooter.RestoreFontPenBrush(ACanvas: TCanvas);\r\nbegin\r\n ACanvas.Font.Assign(FOldFont);\r\n ACanvas.Pen.Assign(FOldPen);\r\n ACanvas.Brush.Assign(FOldBrush);\r\nend;\r\n\r\nprocedure THeaderFooter.DrawFrame(ACanvas: TCanvas);\r\n//Draws frame around header/footer\r\nbegin\r\n if (FrameTypes = []) then Exit;\r\n with ACanvas, FMargins do begin\r\n Pen.Color := LineColor;\r\n Brush.Color := ShadedColor;\r\n if ftShaded in FrameTypes then\r\n Brush.Style := bsSolid\r\n else\r\n Brush.Style := bsClear;\r\n if ftBox in FrameTypes then\r\n Pen.Style := psSolid\r\n else\r\n Pen.Style := psClear;\r\n if FrameTypes * [ftBox, ftShaded] <> [] then begin\r\n if FType = hftHeader then\r\n Rectangle(PLeft, PHeader - FFrameHeight, PRight, PHeader)\r\n else\r\n Rectangle(PLeft, PFooter, PRight, PFooter + FFrameHeight);\r\n end;\r\n if ftLine in FrameTypes then begin\r\n Pen.Style := psSolid;\r\n if FType = hftHeader then begin\r\n MoveTo(PLeft, PHeader);\r\n LineTo(PRight, PHeader);\r\n end\r\n else begin\r\n MoveTo(PLeft, PFooter);\r\n LineTo(PRight, PFooter);\r\n end\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure THeaderFooter.Print(ACanvas: TCanvas; PageNum: Integer);\r\nvar\r\n i, X, Y, CurLine: Integer;\r\n AStr: UnicodeString;\r\n AItem: THeaderFooterItem;\r\n{$IFNDEF SYN_CLX}\r\n OldAlign: UINT;\r\n{$ENDIF}\r\n TheAlignment: TAlignment;\r\nbegin\r\n if (FFrameHeight <= 0) then Exit; // No header/footer\r\n SaveFontPenBrush(ACanvas);\r\n DrawFrame(ACanvas);\r\n ACanvas.Brush.Style := bsClear;\r\n if FType = hftHeader then\r\n Y := FMargins.PHeader - FFrameHeight\r\n else\r\n Y := FMargins.PFooter;\r\n Y := Y + FMargins.PHFInternalMargin; // Add the specified internal margin\r\n\r\n CurLine := 1;\r\n for i := 0 to FItems.Count - 1 do\r\n begin\r\n AItem := THeaderFooterItem(FItems[i]);\r\n ACanvas.Font := AItem.Font;\r\n if AItem.LineNumber <> CurLine then\r\n begin\r\n Y := Y + TLineInfo(FLineInfo[CurLine - 1]).LineHeight;\r\n CurLine := AItem.LineNumber;\r\n end;\r\n AStr := AItem.GetText(FNumPages, PageNum, FRomanNumbers, FTitle, FTime, FDate);\r\n //Find the alignment of the header/footer item - check for MirrorPosition\r\n TheAlignment := AItem.Alignment;\r\n if MirrorPosition and ((PageNum mod 2) = 0) then\r\n begin\r\n case AItem.Alignment of\r\n taRightJustify: TheAlignment := taLeftJustify;\r\n taLeftJustify: TheAlignment := taRightJustify;\r\n end;\r\n end;\r\n //Find X-position of text\r\n with FMargins do begin\r\n X := PLeftHFTextIndent;\r\n case TheAlignment of\r\n taRightJustify: X := PRightHFTextIndent - TextWidth(ACanvas, AStr);\r\n taCenter: X := (PLeftHFTextIndent + PRightHFTextIndent - TextWidth(ACanvas, AStr)) div 2;\r\n end;\r\n end;\r\n {Aligning at base line - Fonts can have different size in headers and footers}\r\n {$IFNDEF SYN_CLX}\r\n OldAlign := SetTextAlign(ACanvas.Handle, TA_BASELINE);\r\n ExtTextOutW(ACanvas.Handle, X, Y + TLineInfo(FLineInfo[CurLine - 1]).MaxBaseDist,\r\n 0, nil, PWideChar(AStr), Length(AStr), nil);\r\n SetTextAlign(ACanvas.Handle, OldAlign);\r\n {$ELSE}\r\n TextOut(ACanvas, X, Y + TLineInfo(FLineInfo[CurLine - 1]).MaxBaseDist, AStr);\r\n {$ENDIF}\r\n end;\r\n RestoreFontPenBrush(ACanvas);\r\nend;\r\n\r\nprocedure THeaderFooter.Assign(Source: TPersistent);\r\nvar\r\n Src: THeaderFooter;\r\n i: Integer;\r\nbegin\r\n if (Source <> nil) and (Source is THeaderFooter) then begin\r\n Src := THeaderFooter(Source);\r\n Clear;\r\n FType := Src.FType;\r\n FFrameTypes := Src.FFrameTypes;\r\n FShadedColor := Src.FShadedColor;\r\n FLineColor := Src.FLineColor;\r\n for i := 0 to Src.FItems.Count - 1 do begin\r\n with THeaderFooterItem(Src.FItems[i]) do\r\n Add(Text, Font, Alignment, LineNumber);\r\n end;\r\n FDefaultFont.Assign(Src.FDefaultFont);\r\n FRomanNumbers := Src.FRomanNumbers;\r\n FMirrorPosition := Src.FMirrorPosition;\r\n end else\r\n inherited Assign(Source);\r\nend;\r\n\r\nfunction THeaderFooter.Count: Integer;\r\nbegin\r\n Result := FItems.Count;\r\nend;\r\n\r\nfunction THeaderFooter.Get(Index: Integer): THeaderFooterItem;\r\nbegin\r\n Result := THeaderFooterItem(FItems[Index]);\r\nend;\r\n\r\nfunction THeaderFooter.GetAsString: UnicodeString;\r\nvar\r\n i: integer;\r\nbegin\r\n FixLines;\r\n Result := '';\r\n for i := 0 to FItems.Count - 1 do begin\r\n if Result <> '' then Result := Result + '/';\r\n Result := Result + EncodeString(THeaderFooterItem(FItems[i]).AsString);\r\n end; //for\r\nend;\r\n\r\nprocedure THeaderFooter.SetAsString(const Value: UnicodeString);\r\nvar\r\n item: THeaderFooterItem;\r\n s: UnicodeString;\r\nbegin\r\n Clear;\r\n item := THeaderFooterItem.Create;\r\n try\r\n s := Value;\r\n while s <> '' do\r\n begin\r\n item.AsString := DecodeString(GetFirstEl(s, '/'));\r\n Add(item.Text, item.Font, item.Alignment, item.LineNumber);\r\n end; \r\n finally\r\n item.Free;\r\n end;\r\nend;\r\n\r\nprocedure THeaderFooter.LoadFromStream(AStream: TStream);\r\nvar\r\n Num, i: Integer;\r\n aCharset: TFontCharset;\r\n aColor: TColor;\r\n aHeight: Integer;\r\n aName: TFontName;\r\n aPitch: TFontPitch;\r\n aSize: Integer;\r\n aStyle: TFontStyles;\r\n bufSize: Integer;\r\n buffer: PAnsiChar;\r\nbegin\r\n with AStream do begin\r\n // read header/footer properties first\r\n Read(FFrameTypes, SizeOf(FFrameTypes));\r\n Read(FShadedColor, SizeOf(FShadedColor));\r\n Read(FLineColor, SizeOf(FLineColor));\r\n Read(FRomanNumbers, SizeOf(FRomanNumbers));\r\n Read(FMirrorPosition, SizeOf(FMirrorPosition));\r\n // font\r\n Read(aCharset, SizeOf(aCharset));\r\n Read(aColor, SizeOf(aColor));\r\n Read(aHeight, SizeOf(aHeight));\r\n Read(bufSize, SizeOf(bufSize));\r\n GetMem(buffer, bufSize+1);\r\n try\r\n Read(buffer^, bufSize);\r\n buffer[bufSize] := #0;\r\n aName := string(buffer);\r\n finally\r\n FreeMem(buffer);\r\n end;\r\n Read(aPitch, SizeOf(aPitch));\r\n Read(aSize, SizeOf(aSize));\r\n Read(aStyle, SizeOf(aStyle));\r\n {$IFDEF SYN_COMPILER_3_UP}\r\n FDefaultFont.Charset := aCharset;\r\n {$ENDIF}\r\n FDefaultFont.Color := aColor;\r\n FDefaultFont.Height := aHeight;\r\n FDefaultFont.Name := aName;\r\n FDefaultFont.Pitch := aPitch;\r\n FDefaultFont.Size := aSize;\r\n FDefaultFont.Style := aStyle;\r\n // now read in the items\r\n Read(Num, SizeOf(Num));\r\n while Num > 0 do\r\n begin\r\n // load headerfooter items from stream\r\n i := Add('', nil, taLeftJustify, 1);\r\n Get(i).LoadFromStream(AStream);\r\n Dec(Num);\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure THeaderFooter.SaveToStream(AStream: TStream);\r\nvar\r\n i, Num: integer;\r\n aCharset: TFontCharset;\r\n aColor: TColor;\r\n aHeight: Integer;\r\n aName: TFontName;\r\n aPitch: TFontPitch;\r\n aSize: Integer;\r\n aStyle: TFontStyles;\r\n aLen : integer;\r\nbegin\r\n with AStream do begin\r\n // write the header/footer properties first\r\n Write(FFrameTypes, SizeOf(FFrameTypes));\r\n Write(FShadedColor, SizeOf(FShadedColor));\r\n Write(FLineColor, SizeOf(FLineColor));\r\n Write(FRomanNumbers, SizeOf(FRomanNumbers));\r\n Write(FMirrorPosition, SizeOf(FMirrorPosition));\r\n // font\r\n {$IFDEF SYN_COMPILER_3_UP}\r\n aCharset := FDefaultFont.Charset;\r\n {$ELSE}\r\n aCharSet := DEFAULT_CHARSET;\r\n {$ENDIF}\r\n aColor := FDefaultFont.Color;\r\n aHeight := FDefaultFont.Height;\r\n aName := FDefaultFont.Name;\r\n aPitch := FDefaultFont.Pitch;\r\n aSize := FDefaultFont.Size;\r\n aStyle := FDefaultFont.Style;\r\n Write(aCharset, SizeOf(aCharset));\r\n Write(aColor, SizeOf(aColor));\r\n Write(aHeight, SizeOf(aHeight));\r\n aLen := Length(aName);\r\n Write(aLen, SizeOf(aLen));\r\n {$IFDEF SYN_COMPILER_2} // In D2 TFontName is a ShortString\r\n Write(PAnsiChar(@aName[1])^, Length(aName)); // D2 cannot convert ShortStrings to PAnsiChar\r\n {$ELSE}\r\n Write(PAnsiChar(AnsiString(aName))^, Length(aName));\r\n {$ENDIF}\r\n Write(aPitch, SizeOf(aPitch));\r\n Write(aSize, SizeOf(aSize));\r\n Write(aStyle, SizeOf(aStyle));\r\n\r\n // now write the items\r\n Num := Count;\r\n Write(Num, SizeOf(Num));\r\n for i := 0 to Num - 1 do\r\n Get(i).SaveToStream(AStream);\r\n end;\r\nend;\r\n\r\n{ THeader }\r\n\r\nconstructor THeader.Create;\r\nbegin\r\n inherited;\r\n FType := hftHeader;\r\nend;\r\n\r\n{ TFooter }\r\n\r\nconstructor TFooter.Create;\r\nbegin\r\n inherited;\r\n FType := hftFooter;\r\nend;\r\n\r\nend.\r\n\r\n" }, { "path": "External/SynEdit/Source/SynEditPrintMargins.pas", "content": "{-------------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: SynEditPrintMargins.pas, released 2000-06-01.\r\n\r\nThe Initial Author of the Original Code is Morten J. Skovrup.\r\nPortions written by Morten J. Skovrup are copyright 2000 Morten J. Skovrup.\r\nAll Rights Reserved.\r\n\r\nContributors to the SynEdit project are listed in the Contributors.txt file.\r\n\r\nAlternatively, the contents of this file may be used under the terms of the\r\nGNU General Public License Version 2 or later (the \"GPL\"), in which case\r\nthe provisions of the GPL are applicable instead of those above.\r\nIf you wish to allow use of your version of this file only under the terms\r\nof the GPL and not to allow others to use your version of this file\r\nunder the MPL, indicate your decision by deleting the provisions above and\r\nreplace them with the notice and other provisions required by the GPL.\r\nIf you do not delete the provisions above, a recipient may use your version\r\nof this file under either the MPL or the GPL.\r\n\r\n$Id: SynEditPrintMargins.pas,v 1.5.2.2 2006/05/21 11:59:34 maelh Exp $\r\n\r\nYou may retrieve the latest version of this file at the SynEdit home page,\r\nlocated at http://SynEdit.SourceForge.net\r\n\r\nKnown Issues:\r\n-------------------------------------------------------------------------------}\r\n\r\n\r\n{-------------------------------------------------------------------------------\r\nCONTENTS:\r\n Class handling all sizes involded when printing.\r\n\r\n Design-time properties\r\n UnitSystem : The units used to specify sizes in. Internally is allways used mm.\r\n Left : Distance from left edge of paper to text.\r\n Right : Distance from right edge of paper to text.\r\n Top : Distance from top edge of paper to top of text.\r\n Bottom : Distance from bottom edge of paper to bottom of text.\r\n Gutter : Binding gutter - added to right margin (or left if 2-sided)\r\n Header : Distance from top edge of paper to line below header.\r\n Footer : Distance from bottom edge of paper to line above footer.\r\n LeftHFTextIndent : Distance from left margin to first left-aligned character\r\n in header or footer\r\n RightHFTextIndent : Distance from right margin to last right-aligned character\r\n in header or footer\r\n HFInternalMargin : Internal margin between top-line and text in header and\r\n footer AND between bottom-line and text in header and\r\n footer.\r\n MirrorMargins : Set if margins should be mirrored (i.e. when printing\r\n 2-sided).\r\n\r\n Run-time properties\r\n PLeft : Left position of text in device units (pixels) - this is the left\r\n margin minus the left unprintable distance (+ gutter).\r\n PRight : Right position of text in device units (pixels) - calculated form\r\n left.\r\n PTop : Top position of text in device units (pixels) - this is the top\r\n margin minus the top unprintable distance.\r\n PBottom : Bottom position of text in device units (pixels) - calculated form\r\n top.\r\n PGutter : Binding gutter in device units (pixels)\r\n PHeader : Header in device units (pixels)\r\n PFooter : Footer in device units (pixels) - calculated from top\r\n PLeftHFTextIndent : Left position of text in header and footer in device\r\n units (pixels). Calculated as Left margin + LeftHFTextIndent\r\n PRightHFTextIndent : Right position of text in header and footer in device\r\n units (pixels). Calculated from left\r\n PHFInternalMargin : Internal margin in device units (pixels).\r\n\r\n Run-time methods\r\n InitPage : Called by TSynEditPrint class to initialize margins.\r\n Assign : Assign values from another TSynEditPrintMargins object.\r\n\r\n-------------------------------------------------------------------------------}\r\n\r\n{$IFNDEF QSYNEDITPRINTMARGINS}\r\nunit SynEditPrintMargins;\r\n{$ENDIF}\r\n{$M+}\r\n\r\n{$I SynEdit.inc }\r\n\r\ninterface\r\n\r\nuses\r\n{$IFDEF SYN_CLX}\r\n QGraphics,\r\n QSynEditPrintTypes,\r\n QSynEditPrinterInfo,\r\n QSynUnicode, \r\n{$ELSE}\r\n Graphics,\r\n SynEditPrintTypes,\r\n SynEditPrinterInfo,\r\n SynUnicode,\r\n{$ENDIF}\r\n Classes,\r\n SysUtils;\r\n\r\ntype\r\n //Margins class - sorting out dimensions of printable area\r\n TSynEditPrintMargins = class(TPersistent)\r\n private\r\n FLeft, // Distance from left edge of paper to text\r\n FRight, // Distance from right edge of paper to text\r\n FTop, // Distance from top edge of paper to top of text\r\n FBottom: Double; // Distance from bottom edge of paper to bottom of text\r\n FHeader, // Distance from top edge of paper to line below header\r\n FFooter: Double; // Distance from bottom edge of paper to line above footer\r\n FLeftHFTextIndent: Double; // Distance from left margin to first left-aligned character\r\n // in header or footer\r\n FRightHFTextIndent: Double; // Distance from right margin to last right-aligned character\r\n // in header or footer\r\n FHFInternalMargin: Double; // Internal margin between top-line and text in header and\r\n // footer AND between bottom-line and text in header and\r\n // footer\r\n FGutter: Double; // Binding gutter - added to right margin (or left if 2-sided)\r\n FMirrorMargins: Boolean; // Set if margins should be mirrored (i.e. when printing\r\n // 2-sided)\r\n FUnitSystem: TUnitSystem; // The units used to specify sizes in.\r\n // Internally is allways used mm\r\n function ConvertTo(Value: Double): Double;\r\n function ConvertFrom(Value: Double): Double;\r\n function GetBottom: Double;\r\n function GetFooter: Double;\r\n function GetGutter: Double;\r\n function GetHeader: Double;\r\n function GetLeft: Double;\r\n function GetRight: Double;\r\n function GetTop: Double;\r\n function GetLeftHFTextIndent: Double;\r\n function GetRightHFTextIndent: Double;\r\n function GetHFInternalMargin: Double;\r\n procedure SetBottom(const Value: Double);\r\n procedure SetFooter(const Value: Double);\r\n procedure SetGutter(const Value: Double);\r\n procedure SetHeader(const Value: Double);\r\n procedure SetLeft(const Value: Double);\r\n procedure SetRight(const Value: Double);\r\n procedure SetTop(const Value: Double);\r\n procedure SetLeftHFTextIndent(const Value: Double);\r\n procedure SetRightHFTextIndent(const Value: Double);\r\n procedure SetHFInternalMargin(const Value: Double);\r\n public\r\n { When initpage has been called, the following values will reflect the\r\n margins in paper units. Note that all values are calculated from\r\n left or top of paper (i.e. PRight is distance from left margin) }\r\n\r\n PLeft, // Left position of text in device units (pixels) - this is the left\r\n // margin minus the left unprintable distance (+ gutter)\r\n PRight, // Right position of text in device units (pixels) - calculated form\r\n // left\r\n PTop, // Top position of text in device units (pixels) - this is the top\r\n // margin minus the top unprintable distance\r\n PBottom: Integer; // Bottom position of text in device units (pixels) -\r\n // calculated form top\r\n PHeader, // Header in device units (pixels)\r\n PFooter: Integer; // Footer in device units (pixels) - calculated from top\r\n PLeftHFTextIndent: Integer; // Left position of text in header and footer in device\r\n // units (pixels). Calculated as Left margin + LeftHFTextIndent\r\n PRightHFTextIndent: Integer; // Right position of text in header and footer in device\r\n // units (pixels). Calculated from left\r\n PHFInternalMargin: Integer; // Internal margin in device units (pixels)\r\n PGutter: Integer; // Binding gutter in device units (pixels)\r\n constructor Create;\r\n procedure InitPage(ACanvas: TCanvas; PageNum: Integer;\r\n PrinterInfo: TSynEditPrinterInfo; LineNumbers,\r\n LineNumbersInMargin: Boolean; MaxLineNum: Integer);\r\n procedure Assign(Source: TPersistent); override;\r\n procedure LoadFromStream(AStream: TStream);\r\n procedure SaveToStream(AStream: TStream);\r\n published\r\n property UnitSystem: TUnitSystem read FUnitSystem write FUnitSystem\r\n default usMM;\r\n property Left: Double read GetLeft write SetLeft;\r\n property Right: Double read GetRight write SetRight;\r\n property Top: Double read GetTop write SetTop;\r\n property Bottom: Double read GetBottom write SetBottom;\r\n property Header: Double read GetHeader write SetHeader;\r\n property Footer: Double read GetFooter write SetFooter;\r\n property LeftHFTextIndent: Double read GetLeftHFTextIndent\r\n write SetLeftHFTextIndent;\r\n property RightHFTextIndent: Double read GetRightHFTextIndent\r\n write SetRightHFTextIndent;\r\n property HFInternalMargin: Double read GetHFInternalMargin\r\n write SetHFInternalMargin;\r\n property Gutter: Double read GetGutter write SetGutter;\r\n property MirrorMargins: Boolean read FMirrorMargins write FMirrorMargins;\r\n end;\r\n\r\nimplementation\r\n\r\n{ TSynEditPrintMargins }\r\nconst\r\n mmPrInch = 25.4;\r\n mmPrCm = 10;\r\n\r\nconstructor TSynEditPrintMargins.Create;\r\nbegin\r\n inherited;\r\n FUnitSystem := usMM;\r\n FLeft := DefLeft;\r\n FRight := DefRight;\r\n FTop := DefTop;\r\n FBottom := DefBottom;\r\n FHeader := DefHeader;\r\n FFooter := DefFooter;\r\n FLeftHFTextIndent := DefLeftHFTextIndent;\r\n FRightHFTextIndent := DefRightHFTextIndent;\r\n FHFInternalMargin := DefHFInternalMargin;\r\n FGutter := DefGutter;\r\n FMirrorMargins := False;\r\nend;\r\n\r\nfunction TSynEditPrintMargins.ConvertTo(Value: Double): Double;\r\n{Convert Value to mm}\r\nbegin\r\n case FUnitSystem of\r\n usCM: Result := Value * mmPrCm;\r\n usInch: Result := Value * mmPrInch;\r\n muThousandthsOfInches: Result := mmPrInch * Value / 1000;\r\n else\r\n Result := Value;\r\n end;\r\nend;\r\n\r\nfunction TSynEditPrintMargins.ConvertFrom(Value: Double): Double;\r\n{Convert from mm to selected UnitSystem}\r\nbegin\r\n case FUnitSystem of\r\n usCM: Result := Value / mmPrCm;\r\n usInch: Result := Value / mmPrInch;\r\n muThousandthsOfInches: Result := 1000 * Value / mmPrInch;\r\n else\r\n Result := Value;\r\n end;\r\nend;\r\n\r\nfunction TSynEditPrintMargins.GetBottom: Double;\r\nbegin\r\n Result := ConvertFrom(FBottom);\r\nend;\r\n\r\nfunction TSynEditPrintMargins.GetFooter: Double;\r\nbegin\r\n Result := ConvertFrom(FFooter);\r\nend;\r\n\r\nfunction TSynEditPrintMargins.GetGutter: Double;\r\nbegin\r\n Result := ConvertFrom(FGutter);\r\nend;\r\n\r\nfunction TSynEditPrintMargins.GetHeader: Double;\r\nbegin\r\n Result := ConvertFrom(FHeader);\r\nend;\r\n\r\nfunction TSynEditPrintMargins.GetLeft: Double;\r\nbegin\r\n Result := ConvertFrom(FLeft);\r\nend;\r\n\r\nfunction TSynEditPrintMargins.GetRight: Double;\r\nbegin\r\n Result := ConvertFrom(FRight);\r\nend;\r\n\r\nfunction TSynEditPrintMargins.GetTop: Double;\r\nbegin\r\n Result := ConvertFrom(FTop);\r\nend;\r\n\r\nfunction TSynEditPrintMargins.GetLeftHFTextIndent: Double;\r\nbegin\r\n Result := ConvertFrom(FLeftHFTextIndent);\r\nend;\r\n\r\nfunction TSynEditPrintMargins.GetRightHFTextIndent: Double;\r\nbegin\r\n Result := ConvertFrom(FRightHFTextIndent);\r\nend;\r\n\r\nfunction TSynEditPrintMargins.GetHFInternalMargin: Double;\r\nbegin\r\n Result := ConvertFrom(FHFInternalMargin);\r\nend;\r\n\r\nprocedure TSynEditPrintMargins.SetBottom(const Value: Double);\r\nbegin\r\n FBottom := ConvertTo(Value);\r\nend;\r\n\r\nprocedure TSynEditPrintMargins.SetFooter(const Value: Double);\r\nbegin\r\n FFooter := ConvertTo(Value);\r\nend;\r\n\r\nprocedure TSynEditPrintMargins.SetGutter(const Value: Double);\r\nbegin\r\n FGutter := ConvertTo(Value);\r\nend;\r\n\r\nprocedure TSynEditPrintMargins.SetHeader(const Value: Double);\r\nbegin\r\n FHeader := ConvertTo(Value);\r\nend;\r\n\r\nprocedure TSynEditPrintMargins.SetLeft(const Value: Double);\r\nbegin\r\n FLeft := ConvertTo(Value);\r\nend;\r\n\r\nprocedure TSynEditPrintMargins.SetRight(const Value: Double);\r\nbegin\r\n FRight := ConvertTo(Value);\r\nend;\r\n\r\nprocedure TSynEditPrintMargins.SetTop(const Value: Double);\r\nbegin\r\n FTop := ConvertTo(Value);\r\nend;\r\n\r\nprocedure TSynEditPrintMargins.SetLeftHFTextIndent(const Value: Double);\r\nbegin\r\n FLeftHFTextIndent := ConvertTo(Value);\r\nend;\r\n\r\nprocedure TSynEditPrintMargins.SetRightHFTextIndent(const Value: Double);\r\nbegin\r\n FRightHFTextIndent := ConvertTo(Value);\r\nend;\r\n\r\nprocedure TSynEditPrintMargins.SetHFInternalMargin(const Value: Double);\r\nbegin\r\n FHFInternalMargin := ConvertTo(Value);\r\nend;\r\n\r\n// -----------------------------------------------------------------------------\r\n// Called by TSynEditPrint class to initialize margins\r\nprocedure TSynEditPrintMargins.InitPage(ACanvas: TCanvas; PageNum: Integer;\r\n PrinterInfo: TSynEditPrinterInfo; LineNumbers, LineNumbersInMargin: Boolean;\r\n MaxLineNum: Integer);\r\n//Calculate the P... values\r\nbegin\r\n if FMirrorMargins and ((PageNum mod 2) = 0) then\r\n begin\r\n PLeft := PrinterInfo.PixFromLeft(FRight);\r\n PRight := PrinterInfo.PrintableWidth - PrinterInfo.PixFromRight(FLeft + FGutter);\r\n end\r\n else begin\r\n PLeft := PrinterInfo.PixFromLeft(FLeft + FGutter);\r\n PRight := PrinterInfo.PrintableWidth - PrinterInfo.PixFromRight(FRight);\r\n end;\r\n if LineNumbers and (not LineNumbersInMargin) then\r\n PLeft := PLeft + TextWidth(ACanvas, IntToStr(MaxLineNum) + ': ');\r\n PTop := PrinterInfo.PixFromTop(FTop);\r\n PBottom := PrinterInfo.PrintableHeight - PrinterInfo.PixFromBottom(FBottom);\r\n PHeader := PrinterInfo.PixFromTop(FHeader);\r\n PFooter := PrinterInfo.PrintableHeight - PrinterInfo.PixFromBottom(FFooter);\r\n PHFInternalMargin := Round(PrinterInfo.YPixPrmm * FHFInternalMargin);\r\n PGutter := Round(PrinterInfo.XPixPrmm * FGutter);\r\n PRightHFTextIndent := PRight - Round(PrinterInfo.XPixPrmm * FRightHFTextIndent);\r\n PLeftHFTextIndent := PLeft + Round(PrinterInfo.XPixPrmm * FLeftHFTextIndent);\r\nend;\r\n\r\n// -----------------------------------------------------------------------------\r\n// Assign values from another TSynEditPrintMargins object\r\nprocedure TSynEditPrintMargins.Assign(Source: TPersistent);\r\nvar\r\n Src: TSynEditPrintMargins;\r\nbegin\r\n if (Source <> nil) and (Source is TSynEditPrintMargins) then begin\r\n Src := TSynEditPrintMargins(Source);\r\n FLeft := Src.FLeft;\r\n FRight := Src.FRight;\r\n FTop := Src.FTop;\r\n FBottom := Src.FBottom;\r\n FHeader := Src.FHeader;\r\n FFooter := Src.FFooter;\r\n FLeftHFTextIndent := Src.FLeftHFTextIndent;\r\n FRightHFTextIndent := Src.FRightHFTextIndent;\r\n FHFInternalMargin := Src.FHFInternalMargin;\r\n FGutter := Src.FGutter;\r\n FMirrorMargins := Src.FMirrorMargins;\r\n FUnitSystem := Src.FUnitSystem;\r\n end else\r\n inherited;\r\nend;\r\n\r\nprocedure TSynEditPrintMargins.LoadFromStream(AStream: TStream);\r\nbegin\r\n // we read all our values in MM\r\n with AStream do begin\r\n Read(FUnitSystem, SizeOf(FUnitSystem));\r\n Read(FLeft, SizeOf(FLeft));\r\n Read(FRight, SizeOf(FRight));\r\n Read(FTop, SizeOf(FTop));\r\n Read(FBottom, SizeOf(FBottom));\r\n Read(FHeader, SizeOf(FHeader));\r\n Read(FFooter, SizeOf(FFooter));\r\n Read(FLeftHFTextIndent, SizeOf(FLeftHFTextIndent));\r\n Read(FRightHFTextIndent, SizeOf(FRightHFTextIndent));\r\n Read(FHFInternalMargin, SizeOf(FHFInternalMargin));\r\n Read(FGutter, SizeOf(FGutter));\r\n Read(FMirrorMargins, SizeOf(FMirrorMargins));\r\n end;\r\nend;\r\n\r\nprocedure TSynEditPrintMargins.SaveToStream(AStream: TStream);\r\nbegin\r\n // we always write our values in MM\r\n with AStream do begin\r\n Write(FUnitSystem, SizeOf(FUnitSystem));\r\n Write(FLeft, SizeOf(FLeft));\r\n Write(FRight, SizeOf(FRight));\r\n Write(FTop, SizeOf(FTop));\r\n Write(FBottom, SizeOf(FBottom));\r\n Write(FHeader, SizeOf(FHeader));\r\n Write(FFooter, SizeOf(FFooter));\r\n Write(FLeftHFTextIndent, SizeOf(FLeftHFTextIndent));\r\n Write(FRightHFTextIndent, SizeOf(FRightHFTextIndent));\r\n Write(FHFInternalMargin, SizeOf(FHFInternalMargin));\r\n Write(FGutter, SizeOf(FGutter));\r\n Write(FMirrorMargins, SizeOf(FMirrorMargins));\r\n end;\r\nend;\r\n\r\nend.\r\n\r\n" }, { "path": "External/SynEdit/Source/SynEditPrintMarginsDialog.dfm", "content": "object SynEditPrintMarginsDlg: TSynEditPrintMarginsDlg\r\n Left = 244\r\n Top = 189\r\n ActiveControl = CBUnits\r\n BorderStyle = bsDialog\r\n Caption = 'Margins'\r\n ClientHeight = 344\r\n ClientWidth = 506\r\n ParentFont = True\r\n Position = poScreenCenter\r\n OnCreate = FormCreate\r\n OnDestroy = FormDestroy\r\n PixelsPerInch = 96\r\n TextHeight = 13\r\n object Image1: TImage\r\n Left = 275\r\n Top = 10\r\n Width = 223\r\n Height = 292\r\n AutoSize = True\r\n Picture.Data = {\r\n 07544269746D617036800000424D36800000000000007600000028000000DF00\r\n 0000240100000100040000000000C07F00000000000000000000100000001000\r\n 0000000000000000800000800000008080008000000080008000808000008080\r\n 8000C0C0C0000000FF0000FF000000FFFF00FF000000FF00FF00FFFF0000FFFF\r\n FF00FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFF\r\n FFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFF\r\n FFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFF\r\n FFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFF\r\n FFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FF0FFF0F00FF0FF0FF0F\r\n F0F0000F0FFFF00F000F0FF000FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFF\r\n FFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFF0FF0FF000FF0F0FF0FF0FF0F0FF0F0FFFF0F0FFFFF00F0FFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FF0FF000FF0F0FF0FF0F\r\n F0FF000F0FFFF0F0000FF00F0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFF\r\n FFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFF0FF0F0F00FF0F0FF0FF0FF0FFFF0F0FFFF0F0FF0FF00F0FFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FF00FF0F00FF00000000\r\n 0FF0000F0FFF000F00FF0FF000FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFF\r\n FFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFF0FF00FF0FFFFFFFFFFFFFFFFFFFFF0FFFF0FFFFFFFFFF0FFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFF0FFF\r\n FFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FF0FFF0FFFFFFFFFFFFF\r\n FFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFF\r\n FFF0FFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFF00000000000000000000000000000000000000000000000000000\r\n 000000000000000000000000000000000000000000000000000000000000FFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFF0FFF\r\n FFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFF\r\n FFF0FFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFF0FFF\r\n FFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFF\r\n FFF0FFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFF0FFFFFFFFFFFFFFFFFFFFF000000F\r\n FFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFF\r\n FFF0FFFFFFFFFFFFFFFFFFFFF000000FFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFF0FFFFFFFFFFFFFFFFFFFFFF00000F\r\n FFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFF\r\n FFF0FFFFFFFFFFFFFFFFFFFFFF0000FFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFF0FFFFFFFFFFFFFFFFFFFFFF0000FF\r\n FFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFF\r\n FFF0FFFFFFFFFFFFFFFFFFFFFFF000FFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFF0FFFFFFFFFFFFFFFFFFFFFFF000FF\r\n FFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFF\r\n FFF0FFFFFFFFFFFFFFFFFFFFFFF00FFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFF0FFF\r\n FFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFF\r\n FFF0FFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFF0FFFFFFFFF99FF9FF9FF99F99FF9F\r\n F9FF99F99FF90F9FF99F99F99FF9FF99F99F99FF9FF900000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 000000000000000000000000000FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFF\r\n FFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFF9FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFF\r\n FFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF000FFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFF9FFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFF000FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFF\r\n FFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF000FFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFF00000FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFF\r\n FFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFF9FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF00000FFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFF9FFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFF00000FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFF\r\n FFF0FFFFFFFFF99F99FF9FF9FF99F99FF9FF9FF99F99099FF9FF99F99F99FF9F\r\n F99F99F99FF9FF9FF99F99FF9FF9FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0000000FFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFF0FFF\r\n FFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFF9FFFFFFFFFFFFFFFFF0FF\r\n F0FF000F0000FF000FF000F0FFFF00FF000F0FF000FFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFF0000000FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFF\r\n FFF0FFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFF9FFFFFFFFFFFFFFF9F0FFF0F0FFFF0FF0F0FF0F0FFFF0FFFF0FF0\r\n FFFFF00F0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFF00000000FFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFF00FF\r\n FFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FF\r\n F0F0000FF000F0FF0F0000F0FFFF0FF0000FF00F0FFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFF\r\n FFF0FFFFFFFFFFFFFFFFFFFFFFF000FFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFF9FFFFFFFFFFFFFFFFF00000F0FF0FFFF0F0FF0F0FF0F0FFFF0FF0\r\n FF0FF00F0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFF0FFFFFFFFFFFFFFFFFFFFFFF000FF\r\n FFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFF9FFFFFFFFFFFFFFF9F0FF\r\n F0FF00FF0000FF000FF00FF000F000FF00FF0FF000FFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFF\r\n FFF0FFFFFFFFFFFFFFFFFFFFFFF0000FFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFF9F0FFF0FFFFFFFFFFFFFF0FFFFFFFFFFF0FFF\r\n FFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFF0FFF0FF00000\r\n 00FF000FF000F0FFFFFFFFFFFFF0FFFFFFF0FFFFFFFF0000000FFFFFFFF0000F\r\n FFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FF\r\n F0FFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFF0FFFFFFFF0FFF0F0FFF0FF0F0FF0F0FFFF0FFFFFFFFFFFFF0FFFF\r\n FFF0FFFFFFFFFFF0FFFFFFFFFF00000FFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFF9FFFFFFFFFFFFFFF9FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFF0FFF0F0000F0\r\n 00F0FF0F0000F0FFFFFFFFFFFFF0FFFFFFF0FFFFFFFFFFF0FFFFFFFFFF000000\r\n FFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF9FFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFF0FFFFFFFF00000F0FF0FFF0F0FF0F0FF0F0FFFFFFFFFFFFF0FFFF\r\n FFF0FFFFFFFFFFF0FFFFFFFFFF000000FFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFF0FFF0FF00F00\r\n 00FF000FF00FF000FFFFFFFFFFF0FFFFFFF0FFFFFFFF0000000FFFFFF0000000\r\n FFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFF9FFFFFFFFFFFFFFF9FFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFF0FFFFFFFF0FFF0FFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFF0FFFF\r\n FFF0FFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFF9FFFFFFFFFFFFFFF9FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFF0FFF0FFFFFFF\r\n FFFFFF0FFFFFFFFFFFFFFFFFFFF0FFFFFFF0FFFFFFFF0000000FFFFFFFFF0FFF\r\n FFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFF0000000FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFF\r\n FFF0FFFFFFFF0FF0FFFFFFFFFFFF0FFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFF9FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0000000FFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFF0FFFFFFFF0FF0FFFFFFFFFFFF0FFF\r\n FFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFF9FFFFFFFFFFFFFFF9FFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFF00000FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFF\r\n FFF0FFFFFFFF0FFFFFFFFFFFFFFF0FFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF00000FFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFF0FFF\r\n FFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFF9FFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFF00000FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFF\r\n FFF0FFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFF9FFFFFFFFFFFFFFF9FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF000FFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFF0FFFFFFFF0000000FFFFFFFFF0FFF\r\n FFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF9FFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFF000FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFF\r\n FFF0FFFFFFFFFF00000FFFFFFFFF0FFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF000FFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFF0FFFFFFFFFF0FFFFFFFFFFFFF0FFF\r\n FFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFF9FFFFFFFFFFFFFFF9FFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFF\r\n FFF0FFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFF9FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFF0FFFFFFFFFFF0000FFFFFFFFFFFFF\r\n FFFFFFFFFFFF0000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000000000000000000000\r\n 000000000000000000000000000000000000000000000000000000000000FFFF\r\n FFF0FFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFF9FFFFFFFFFFFFFFF9FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFF000000FFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF9FFFFFFFFFFFFFFF9FFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFF0FFFFFFFFFF0FFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF9FFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFF0FFFFFFFFFFF000FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFF9FFFFFFFFFFFFFFF9FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFF0F0F0FFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFF0FFFFFFFFFF0F0F0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFF9FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFF00F0FFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF9FFFFFFFFFFFFFFF9FFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFF9FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFF00000FFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFF0FFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFF9FFFFFFFFFFFFFFF9FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFF0FFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF9FFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFF0FFFFFFFFFF00000FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFF0FFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0000FFFFFF9FFFFFFFFFFFFFFF9FFFF\r\n FFF000FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFF0FFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n F0000000FFFFFFFFFFFFFFFFFFF9FFF0000000FFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFF0000FFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFF000000000000000FFFFFFFFFFFFFFFF00000\r\n 000000F00000FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n F00000000FF9FFFFFFFFFFFFFFFFFF00000000FFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFF0FF00FFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF00000FFFFF9FFFFFFFFFFFFFFF9FFFF\r\n F00000FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFF0FFFFFFFFFF0F0F0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n F000FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF00FFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFF0F0F0FFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF9FFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFF0FFFFFFFFFF00000FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFF9FFFFFFFFFFFFFFF9FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF9FFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFF0FFFFFFFF0000000FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0000F000FF000FF0FFF0F0FFFFFF0F\r\n FF000F0FF000FF0F0FF0FF000FF000F0FF0F00FFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF9FFFFFFFFFFFFFFF9FFFF\r\n FF0FFF0FFFFF00FFF0FFF0F0FFFFFF0FF0FFFFF00F0FFF0F0FF0F0FF0F0FFFF0\r\n FF0F0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFF0FFFFFFFF0000000FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFF9FFFFFF0FFF0000FF00FFF0FFF0F0FFFFFF0F\r\n F0000FF00F0FFF0F0FF0F0FF0F0000F0FF0F0FFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFF00FFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FF0FFF0FF0FF00FFF00000F000FFFF0FF0FF0FF00F0FFF0F0FF0F0FF0F0FF0F0\r\n FF0F0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFF0FFFFFFFFFFF000FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFF9FFFFFFFFFFFFFFF9FFFFFF0FFFF00FF0000FF0FFF0F0FFFFFF0F\r\n FF00FF0FF000FF0F000FFF000FF00FF000F000FFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFF0FFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF9FFFF\r\n FF0FFFFFFFFF00FFF0FFF0F0FFFFFF0FFFFFFFFFFF0FFF0FFFFFFFFF0FFFFFFF\r\n FFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFF0FFFFFFFFFFF000FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFF0FFF0FFF0F0000F0000\r\n 0FFFFFFFFFFFFF0FFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFF00FFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF9FFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFF0FFFFFFFF0000000FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFF9FFFFFFFFFFFFFFF9FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFF0FF00FFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFF0FFFFFFFFFF0F0F0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFF0F0F0FFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFF0FFFFFFFFFF00000FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFF0FFFFFFFFFF00000FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFF0FFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFF0FFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFF000F0FFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFF0FFFFFFFFFF0FFF0F0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFF0FFF0F0FFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFF0FFFFFFFFFF000000FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFF0FFFFFFFF0F00000FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFF0FFFFFFFFFF00000FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFF0FFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFF0FFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFF00FFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0\r\n 0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFF0000FFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFF\r\n FFFFFFFFFFFFFFFF0FF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0000FFFF\r\n 000F0FF000FF000FF000FFFF000FF0FF0F0FF0F000F0FF0FF000FFFFF0F0FF0F\r\n 00F0FF0FFF0FF0FF0F0F0FF0FFF00FF0FFF000FF000FFFF0FF0FF00000F0FFF0\r\n 00F0F0FF0F000FFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFF00F0FF0F0FFFF0FF0FFFF0FF0F0FF\r\n 0F0FF0F0F0F0FF0F0FF0FFFF0F0F0F0F0FF0FF0FFF0FF0FF0F0F0FF0FF0FF0F0\r\n FF0FFFF0FF0FFFF0FF0FF00FF0F0FF0FF0F0F0FF0FFFF0FFFFFFFFFFFFFFFFFF\r\n FFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FF00F\r\n F00F0F0FF0F0000F0FF0FFFF0FF0F0FF0F0FF0F0F0F0FF0F0FF0FFFF0F0F0F0F\r\n 0FF0FF0FFF0FF0FF0F0F0FF0FF0FF0F0FF0000F0FF0FFFF0FF0FF0F000F0FF0F\r\n F0F0F0FF0FF00FFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFF0FFF0F0FF0F0FF0F0FF0FFFF0FF0F0FF\r\n 0F0FF0F0F0F0FF0F0FF0FFFF0F0F0F0F0FF0FF0FFF0FF0FF0F0F0FF0FF0FF0F0\r\n FF0FF0F0FF0FFFF0FF0FF0FFF0F0FF0FF0F0F0FF0F0FFFFFFFFFFFFFFFFFFFFF\r\n FFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFF\r\n F0000FF000FF00FFF000FFFF000FF0000F000F0000F000FFF000FFFF0F0F0F00\r\n 00F000FFFF000000FF0F000000F00FF000F00FFF000FFFF000000F0000F000F0\r\n 00F0F000FFF000FFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFF0FF0FFFFFFFFFFFFF0FFFFFFFFF0FFFFFFFFFFFF\r\n FFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFF0FF0FFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF00FFFFF\r\n FFFF0FFFF0FFFFFFFFF0FFFFFFFFFFFF0FFFFFFFF0FFFFFFFFFFFFFFFFFFFF0F\r\n FFF0FFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFF\r\n FFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFF0000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000000000000000000000000000090000000000000000\r\n 000000000000000000000000000000000000000000000000000000000000FFFF\r\n FFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF9FFFFFFFFF\r\n FF00FFFFFFFFFFF9FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFF9FFFFFFFFFFF00FFFFFFFFFFF9FFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFF\r\n FFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF9FFFFFFFFF\r\n FF00FFFFFFFFFFF9FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFF9FFFFFFFFFFF00FFFFFFFFFFF9FFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFF\r\n FFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF9FFFFFFFFF\r\n FF00FFFFFFFFFFF9FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFF9FFFFFFFFFFF00FFFFFFFFFFF9FFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFF\r\n FFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF9FFFFFFFFF\r\n FF00FFFFFFFFFFF9FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFF9FFFFFFFFFFF00FFFFFFFFFFF9FFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFF\r\n FFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF9FFFFFFFFF\r\n FF00FFFFFFFFFFF9FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFF9FFFFFFFFFFF00FFFFFFFFFFF9FFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFF\r\n FFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFF\r\n FFFFFFFF000FFF00FF0000FF00FF0FF0FF0FFFFFFFFFFFFFFFFFFF9FFFFFFFFF\r\n FF00FFFFFFFFFFF9FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFF0FF0F0FF0F0F0FF0FF0F0FF0\r\n FF0FFFFFFFFFFFFFFFFFFF9FFFFFFFFFFF00FFFFFFFFFFF9FFFFFFFFFFFFFFFF\r\n FFFF000FFF00FF00F00F00FF0FF0FF0FFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFF\r\n FFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFF\r\n FFFFFFFF0FF0F0FF0F0F0FF0FF0F0FF0FF0FFFFFFFFFFFFFFFFFFF9FFFFFFFFF\r\n FF00FFFFFFFFFFF9FFFFFFFFFFFFFFFFFFFF0FF0F0FF0F0FF0F0FF0F0FF0FF0F\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFF0000F0FF0F0F0FF0FF0F0FF0\r\n FF0FFFFFFFFFFFFFFFFFFF9FFFFFFFFFFF00FFFFFFFFFFF9FFFFFFFFFFFFFFFF\r\n FFFF0FF0F0FF0F0FF0F0FF0F0FF0FF0FFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFF\r\n FFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFF\r\n FFFFFFFF0FF0FF00F00000FF00FF000000FFFFFFFFFFFFFFFFFFFF9FFFFFFFFF\r\n FF00FFFFFFFFFFF9FFFFFFFFFFFFFFFFFFFF0000F0FF0F0FF0F0FF0F0FF0FF0F\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFF0FF0FFFFFF0F0FFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFF9FFFFFFFFFFF00FFFFFFFFFFF9FFFFFFFFFFFFFFFF\r\n FFFF0FF0FF00F000000F00FF000000FFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFF\r\n FFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFF\r\n FFFFFFFF000FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF9FFFFFFFFF\r\n FF00FFFFFFFFFFF9FFFFFFFFFFFFFFFFFFFF0FF0FFFFFF0FF0FFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFF9FFFFFFFFFFF00FFFFFFFFFFF9FFFFFFFFFFFFFFFF\r\n FFFF000FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFF\r\n FFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF9FFFFFFFFF\r\n FF00FFFFFFFFFFF9FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFF9FFFFFFFFFFF00FFFFFFFFFFF9FFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFF\r\n FFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF9FFFFFFFFF\r\n FF00FFFFFFFFFFF9FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFF9FFFFFFFFFFF00FFFFFFFFFFF9FFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFF\r\n FFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF9FFFFFFFFF\r\n FF00FFFFFFFFFFF9FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFF9FFFFFFFFFFF00FFFFFFFFFFF9FFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFF\r\n FFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF9FFFFFFFFF\r\n FF00FFFFFFFFFFF9FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFF000000000000000000000000000000\r\n 000000000FFFFFFFFFFFFF9FFFFFFFFFFF00FFFFFFFFFFF9FFFFFFFFFFFFFF00\r\n 00000000000000000000000000000000000000FFFFFFFFFFFFFFFFFFFFF0FFFF\r\n FFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFF\r\n FF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFF9FFFFFFFFF\r\n FF00FFFFFFFFFFF9FFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFF0FFFFFFFFFFFFFFFFFFFFF0FFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFF0FFFFFFFFFFFFF9FFFFFFFFFFF00FFFFFFFFFFF9FFFFFFFFFFFFFF0F\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFF0FFFF\r\n FFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFF\r\n FF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFF9FFFFFFFFF\r\n FF00FFFFFFFFFFF9FFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFF0FFFFFFFFFFFFFFFFFFFFF0FFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFF0FFFFFFFFFFFFF9FFFFFFFFFFF00FFFFFFFFFFF9FFFFFFFFFFFFFF0F\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFF0FFFF\r\n FFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFF\r\n FF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFF9FFFFFFFFF\r\n FF00FFFFFFFFFFF9FFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFF0FFFFFFFFFFFFFFFFFFFFF0FFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFF0FFFFFFFFFFFFF9FFFFFFFFFFF00FFFFFFFFFFF9FFFFFFFFFFFFFF0F\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFF0FFFF\r\n FFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFF\r\n FF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFF9FFFFFFFFF\r\n FF00FFFFFFFFFFF9FFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFF0FFFFFFFFFFFFFFFFFFFFF0FFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFF0FFFFFFFFFFFFF9FFFFFFFFFFF00FFFFFFFFFFF9FFFFFFFFFFFFFF0F\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFF0FFFF\r\n FFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFF\r\n FF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFF9FFFFFFFFF\r\n FF00FFFFFFFFFFF9FFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFF0FFFFFFFFFFFFFFFFFFFFF0FFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFF0FFFFFFFFFFFFF9FFFFFFFFFFF00FFFFFFFFFFF9FFFFFFFFFFFFFF0F\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFF0FFFF\r\n FFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFF\r\n FF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFF9FFFFFFFFF\r\n FF00FFFFFFFFFFF9FFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFF0FFFFFFFFFFFFFFFFFFFFF0FFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFF0FFFFFFFFFFFFF9FFFFFFFFFFF00FFFFFFFFFFF9FFFFFFFFFFFFFF0F\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFF0FFFF\r\n FFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFF\r\n FF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFF9FFFFFFFFF\r\n FF00FFFFFFFFFFF9FFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFF0FFFFFFFFFFFFFFFFFFFFF0FFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFF0FFFFFFFFFFFFF9FFFFFFFFFFF00FFFFFFFFFFF9FFFFFFFFFFFFFF0F\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFF0FFFF\r\n FFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFF\r\n FF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFF9FFFFFFFFF\r\n FF00FFFFFFFFFFF9FFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFF0FFFFFFFFFFFFFFFFFFFFF0FFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFF0FFFFFFFFFFFFF9FFFFFFFFFFF00FFFFFFFFFFF9FFFFFFFFFFFFFF0F\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFF0FFFF\r\n FFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFF\r\n FF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFF9FFFFFFFFF\r\n FF00FFFFFFFFFFF9FFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFF0FFFFFFFFFFFFFFFFFFFFF0FFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFF0FFFFFFFFFFFFF9FFFFFFFFFFF00FFFFFFFFFFF9FFFFFFFFFFFFFF0F\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFF0FFFF\r\n FFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFF\r\n FF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFF9FFFFFFFFF\r\n FF00FFFFFFFFFFF9FFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFF0FFFFFFFFFFFFFFFFFFFFF0FFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFF0FFFFFFFFFFFFF9FFFFFFFFFFF00FFFFFFFFFFF9FFFFFFFFFFFFFF0F\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFF0FFFF\r\n FFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFF\r\n FF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFF9FFFFFFFFF\r\n FF00FFFFFFFFFFF9FFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFF0FFFFFFFFFFFFFFFFFFFFF0FFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFF0FFFFFFFFFFFFF9FFFFFFFFFFF00FFFFFFFFFFF9FFFFFFFFFFFFFF0F\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFF0FFFF\r\n FFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFF\r\n FF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFF9FFFFFFFFF\r\n FF00FFFFFFFFFFF9FFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFF0FFFFFFFFFFFFFFFFFFFFF0FFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFF0FFFFFFFFFFFFF9FFFFFFFFFFF00FFFFFFFFFFF9FFFFFFFFFFFFFF0F\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFF0FFFF\r\n FFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFF\r\n FF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFF9FFFFFFFFF\r\n FF00FFFFFFFFFFF9FFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFF0FFFFFFFFFFFFFFFFFFFFF0FFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFF0FFFFFFFFFFFFF9FFFFFFFFFFF00FFFFFFFFFFF9FFFFFFFFFFFFFF0F\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFF0FFFF\r\n FFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFF\r\n FF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFF9FFF00000F\r\n FF00FFFFFFFFFFF9FFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFF0FFFFFFFFFFFFFFFFFFFFF0FFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFF0FFFFFFFFFFFFF9FF0FFFFF0FF00FFFF00000FF9FFFFFFFFFFFFFF0F\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFF0FFFF\r\n FFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFF\r\n FF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFF9FF0FFFFF0\r\n FF00FFF0FFFFF0F9FFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFF0FFFFFFFFFFFFFFFFFFFFF0FFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFF0FFFFFF0000000FFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFF0FFFFFFFFFFFFF9FF0FF0FF0FF00FFF0FFFFF0F9FFFFFFFFFFFFFF0F\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFF0000000FFFFFFFFF0FFFF\r\n FFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFF0FF0FFFFFFFFF\r\n FF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFF9FFF0F000F\r\n FF00FFF0FF0FF0F9FFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFF0FFFFF0FF0FFFFFFFFFFFF0FFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFF0FFFFFF0FF0FFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFF0FFFFFFFFFFFFF9FFFFFFFFFFF00FFFF0F000FF9FFFFFFFFFFFFFF0F\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFF0FF0FFFFFFFFFFFF0FFFF\r\n FFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFF0FF00FFFFFFFF\r\n FF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFF0000000FFF9FFFF0000F\r\n FF00FFFFFFFFFFF9FFF0000000FFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFF0FFFFF0FF00FFFFFFFFFFF0FFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFF0FFFFFFF00FF00FFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFF0FFFFFFFFF0FFF9FFFFFFFF0FF00FFFFF0000FF9FFFFFFFFF0FFFF0F\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFF00FF00FFFFFFFFF0FFFF\r\n FFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFF0F00000FFFFFF\r\n FF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFF0FFF9FFFFFFFF0\r\n FF00FFFFFFFFF0F9FFFFFFFFF0FFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFF0FFFFF0F00000FFFFFFFFF0FFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFF0FFFFFFFFF0FFF9FFFF00000FF00FFFFFFFFF0F9FFFFFFFFF0FFFF0F\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFF0FFFF\r\n FFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFF000F0FFFFF\r\n FF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFF000FFFF9FFFF0FFFF\r\n FF00FFFFF00000F9FFFFFF000FFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFF0FFFFFFFF000F0FFFFFFFF0FFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFF0FFFFFFFF0FFF0F0FFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFF0FFFFF0F0F0FFF9FFF000000FF00FFFFF0FFFFF9FFFFF0F0F0FFFF0F\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFF0FFF0F0FFFFFFF0FFFF\r\n FFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFF0FFF0F0FFFF\r\n FF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFF0F0F0FFF9FFFF0FFF0\r\n FF00FFFF000000F9FFFFF0F0F0FFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFF0FFFFFFF0FFF0F0FFFFFFF0FFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFF0FFFFFFFF000000FFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFF0FFFFFF00F0FFF9FFF000000FF00FFFFF0FFF0F9FFFFFF00F0FFFF0F\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFF000000FFFFFFFF0FFFF\r\n FFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFF\r\n FF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFF9FFFF0FFF0\r\n FF00FFFF000000F9FFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFF0FFFFFFFFFFFFFFFFFFFFF0FFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFF0FFFFFF0000000FFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFF0FFFFF0FFFFFFF9FFFFFFFFFFF00FFFFF0FFF0F9FFFFF0FFFFFFFF0F\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFF0000000FFFFFFFFF0FFFF\r\n FFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFF0FFFFFFFFFF\r\n FF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFF000000FFF9FFFFF000F\r\n FF00FFFFFFFFFFF9FFFF000000FFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFF0FFFFFFF0FFFFFFFFFFFFF0FFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFF0FFFFFFFF0FFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFF0FFF0F0FFFFFFF9FFFF0F0F0FF00FFFFFF000FF9FFF0000000FFFF0F\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFF0FFFFFFFFFFFFF0FFFF\r\n FFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFF0000FFFFFF\r\n FF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFF000000FFF9FFFF0F0F0\r\n FF00FFFFF0F0F0F9FFFFF0FFF0FFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFF0FFFFFFFF0000FFFFFFFFF0FFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFF0FFFFFFFF0FFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFF0FFFFF0FFF0FFF9FFFFF00F0FF00FFFFF0F0F0F9FFFFFFFFFFFFFF0F\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFF0FFFFFFFFFFFFF0FFFF\r\n FFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFF000000FFFFFF\r\n FF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFF9FFFFFFFFF\r\n FF00FFFFFF00F0F9FFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFF0FFFFFF000000FFFFFFFFF0FFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFF0FFFFFFFF0FFF0FFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFF0FFFFFFFFFFFFF9FFFF00000FF00FFFFFFFFFFF9FFFFFFFFFFFFFF0F\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFF0FFF0FFFFFFFFF0FFFF\r\n FFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFF\r\n FF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFF9FFFF0FFFF\r\n FF00FFFFF00000F9FFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFF0FFFFFFFFFFFFFFFFFFFFF0FFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFF0FFFFFFFFFFFFF9FFFF0FFFFFF00FFFFF0FFFFF9FFFFFFFFFFFFFF0F\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFF0FFFF\r\n FFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFF\r\n FF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFF9FFFFFFFFF\r\n FF00FFFFF0FFFFF9FFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFF0FFFFFFFFFFFFFFFFFFFFF0FFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFF0FFFFFFFFFFFFF9FFFFFFFFFFF00FFFFFFFFFFF9FFFFFFFFFFFFFF0F\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFF0FFFF\r\n FFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFF\r\n FF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFF9FFFFFFFFF\r\n FF00FFFFFFFFFFF9FFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFF0FFFFFFFFFFFFFFFFFFFFF0FFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFF0FFFFFFFFFFFFF9FFFFFFFFFFF00FFFFFFFFFFF9FFFFFFFFFFFFFF0F\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFF0FFFF\r\n FFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFF\r\n FF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFF9FFFFFFFFF\r\n FF00FFFFFFFFFFF9FFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFF0FFFFFFFFFFFFFFFFFFFFF0FFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFF0FFFFFFFFFFFFF9FFFFFFFFFFF00FFFFFFFFFFF9FFFFFFFFFFFFFF0F\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFF0FFFF\r\n FFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFF\r\n FF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFF9FFFFFFFFF\r\n FF00FFFFFFFFFFF9FFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFF0FFFFFFFFFFFFFFFFFFFFF0FFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFF0FFFFFFFFFFFFF9FFFFFFFFFFF00FFFFFFFFFFF9FFFFFFFFFFFFFF0F\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFF0FFFF\r\n FFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFF\r\n FF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFF9FFFFFFFFF\r\n FF00FFFFFFFFFFF9FFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFF0FFFFFFFFFFFFFFFFFFFFF0FFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFF0FFFFFFFFFFFFF9FFFFFFFFFFF00FFFFFFFFFFF9FFFFFFFFFFFFFF0F\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFF0FFFF\r\n FFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFF\r\n FF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFF9FFFFFFFFF\r\n FF00FFFFFFFFFFF9FFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFF0FFFFFFFFFFFFFFFFFFFFF0FFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFF0FFFFFFFFFFFFF9FFFFFFFFFFF00FFFFFFFFFFF9FFFFFFFFFFFFFF0F\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFF0FFFF\r\n FFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFF\r\n FF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFF9FFFFFFFFF\r\n FF00FFFFFFFFFFF9FFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFF0FFFFFFFFFFFFFFFFFFFFF0FFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFF0FFFFFFFFFFFFF9FFFFFFFFFFF00FFFFFFFFFFF9FFFFFFFFFFFFFF0F\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFF0FFFF\r\n FFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFF\r\n FF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFF9FFFFFFFFF\r\n FF00FFFFFFFFFFF9FFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFF0FFFFFFFFFFFFFFFFFFFFF0FFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFF0FFFFFFFFFFFFF9FFFFFFFFFFF00FFFFFFFFFFF9FFFFFFFFFFFFFF0F\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFF0FFFF\r\n FFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFF\r\n FF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFF9FFFFFFFFF\r\n FF00FFFFFFFFFFF9FFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFF0FFFFFFFFFFFFFFFFFFFFF0FFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFF0FFFFFFFFFFFFF9FFFFFFFFFFF00FFFFFFFFFFF9FFFFFFFFFFFFFF0F\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFF0FFFF\r\n FFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFF\r\n FF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFF9FFFFFFFFF\r\n FF00FFFFFFFFFFF9FFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFF0FFFFFFFFFFFFFFFFFFFFF0FFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFF0FFFFFFFFFFFFF9FFFFFFFFFFF00FFFFFFFFFFF9FFFFFFFFFFFFFF0F\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFF0FFFF\r\n FFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFF\r\n FF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFF9FFFFFFFFF\r\n FF00FFFFFFFFFFF9FFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFF0FFFFFFFFFFFFFFFFFFFFF0FFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFF0FFFFFFFFFFFFF9FFFFFFFFFFF00FFFFFFFFFFF9FFFFFFFFFFFFFF0F\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFF0FFFF\r\n FFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFF\r\n FF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFF9FFFFFFFFF\r\n FF00FFFFFFFFFFF9FFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFF0FFFFFFFFFFFFFFFFFFFFF0FFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFF0FFFFFFFFFFFFF9FFFFFFFFFFF00FFFFFFFFFFF9FFFFFFFFFFFFFF0F\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFF0FFFF\r\n FFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFF\r\n FF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFF9FFFFFFFFF\r\n FF00FFFFFFFFFFF9FFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFF0FFFFFFFFFFFFFFFFFFFFF0FFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFF000000000000000000000000000000\r\n 000000000FFFFFFFFFFFFF9FFFFFFFFFFF00FFFFFFFFFFF9FFFFFFFFFFFFFF00\r\n 00000000000000000000000000000000000000FFFFFFFFFFFFFFFFFFFFF0FFFF\r\n FFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF9FFFFFFFFF\r\n FF00FFFFFFFFFFF9FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFF9FFFFFFFFFFF00FFFFFFFFFFF9FFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFF\r\n FFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF9FFFFFFFFF\r\n FF00FFFFFFFFFFF9FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFF9FFFFFFFFFFF00FFFFFFFFFFF9FFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFF\r\n FFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF9FFFFFFFFF\r\n FF00FFFFFFFFFFF9FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFF9FFFFFFFFFFF00FFFFFFFFFFF9FFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFF\r\n FFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF9FFFFFFFFF\r\n FF00FFFFFFFFFFF9FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFF9FFFFFFFFFFF00FFFFFFFFFFF9FFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFF\r\n FFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFF9FFFFFFFFF\r\n FF00FFFFFFFFFFF9FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFF9FFFFFFFFFFF00FFFFFFFFFFF9FFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFF\r\n FFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFF0FFFF00FF000FFFFFFFFFFFFFFFFFFFFFFFFFFF9FFFFFFFFF\r\n FF00FFFFFFFFFFF9FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFF0FF0F0FF0FFFF\r\n FFFFFFFFFFFFFFFFFFFFFF9FFFFFFFFFFF00FFFFFFFFFFF9FFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFF0FFF00FF000FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFF\r\n FFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFF0FFF0FF0F0FF0FFFFFFFFFFFFFFFFFFFFFFFFFF9FFFFFFFFF\r\n FF00FFFFFFFFFFF9FFFFFFFFFFFFFFFFFFFFFFFFFFFF0FF0FF0F0FF0FFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFF0FF0F0FF0FFFF\r\n FFFFFFFFFFFFFFFFFFFFFF9FFFFFFFFFFF00FFFFFFFFFFF9FFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFF0FF0FF0F0FF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFF\r\n FFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFF0FFFF00FF000FFFFFFFFFFFFFFFFFFFFFFFFFFF9FFFFFFFFF\r\n FF00FFFFFFFFFFF9FFFFFFFFFFFFFFFFFFFFFFFFFFFF0FF0FF0F0FF0FFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFF9FFFFFFFFFFF00FFFFFFFFFFF9FFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFF0FFF00FF000FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFF\r\n FFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFF00000FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF9FFFFFFFFF\r\n FF00FFFFFFFFFFF9FFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFF9FFFFFFFFFFF00FFFFFFFFFFF9FFFFFFFFFFFFFFFF\r\n FFFFFFFFFF00000FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFF\r\n FFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF9FFFFFFFFF\r\n FF00FFFFFFFFFFF9FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFF9FFFFFFFFFFF00FFFFFFFFFFF9FFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFF\r\n FFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF9FFFFFFFFF\r\n FF00FFFFFFFFFFF9FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFF9FFFFFFFFFFF00FFFFFFFFFFF9FFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFF\r\n FFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF9FFFFFFFFF\r\n FF00FFFFFFFFFFF9FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFF9FFFFFFFFFFF00FFFFFFFFFFF9FFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFF\r\n FFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF9FFFFFFFFF\r\n FF00FFFFFFFFFFF9FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFF0000000000000000000000000000000000000000000000000000\r\n 0000000000000000000000900000000000000000000000000000000000000000\r\n 000000000000000000000000000000000000000000000000000000000000FFFF\r\n FFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF00FFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFF00FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFF0FF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FF0FFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFF0000FF000FF00\r\n 0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFF0FFFF0000FF000FF000FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFF0FFFF0FF0F0FF0F0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFF0FF0F0FF0F0FFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFF000F0FF0F000\r\n 0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFF0FFFFF000F0FF0F0000FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFF0000FFFF0F0FF0F0FF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0000FFFF0F0FF0F0FF0FFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FF0F0000FF000FF00\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFF0FF0F0000FF000FF00FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFF0FF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FF0FFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0000FFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFF0000FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF00000FF\r\n 0FF000F0FF0FFFF0FF0FF000F0FF0FF0000FFF000F0FFF000FF000FFFFFFFFFF\r\n FFFFFFFFFFFF000FF0FF0FF000FFF0FF000F0FF0FFFF0FF0FF000F0FF0FF0F00\r\n 0FFF000F0FFF000F000FFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFF0FFFFF0F00FFFF0FF0FFFF0FF0F0FF0F0FF0FF0\r\n 0FF0F0FFFF0FF0FFFF0FF0FFFFFFFFFFFFFFFFFFFFF0FFF0F0FF0F0FFFFF0F00\r\n FFFF0FF0FFFF0FF0F0FF0F0FF0FF0F0FF0F0FFFF0FF0FFF0FF0FFFFFFFFFFFFF\r\n FFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFF0\r\n F00000F0FF0FFFF0FF0F0FF0F0FF0FF00FF0F0000F0FF0000F0FF0FFFFFFFFFF\r\n FFFFFFFFFFF0FFF0F0FF0F0000FF0F00000F0FF0FFFF0FF0F0FF0F0FF0FF0F0F\r\n F0F0000F0FF00000FF0FFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFF00000F0F00FF0F0FF0FFFF0FF0F0FF0F0FF0FF0\r\n 0FF0F0FF0F0FF0FF0F0FF0FFFFFFFFFFFFFFFFFFFFF0FFF0F0FF0F0FF0FF0F00\r\n FF0F0FF0FFFF0FF0F0FF0F0FF0FF0F0FF0F0FF0F0FF0FF00FF0FFFFFFFFFFFFF\r\n FFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFF0F\r\n FF000FF000FFFFF000FF0FF0F000000F000FFF00FF000F00FFF000FFFFFFFFFF\r\n FFFFFFFFFFF0FFF0F000FFF00FF0FFF000FF000FFFFF000FF0FF0F000000FF00\r\n 0FFF00FF000F00FF000FFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n 0FFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFF0FFF0FFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFF\r\n FFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF00000FF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFF0FFFFFFFFFF\r\n FFFFFFFFFFF0FFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0F\r\n FFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0FFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n FFF0}\r\n end\r\n object Label1: TLabel\r\n Left = 10\r\n Top = 44\r\n Width = 21\r\n Height = 13\r\n Caption = 'Left:'\r\n end\r\n object Label2: TLabel\r\n Left = 10\r\n Top = 69\r\n Width = 28\r\n Height = 13\r\n Caption = 'Right:'\r\n end\r\n object Label3: TLabel\r\n Left = 10\r\n Top = 94\r\n Width = 22\r\n Height = 13\r\n Caption = 'Top:'\r\n end\r\n object Label4: TLabel\r\n Left = 10\r\n Top = 119\r\n Width = 36\r\n Height = 13\r\n Caption = 'Bottom:'\r\n end\r\n object Label5: TLabel\r\n Left = 10\r\n Top = 14\r\n Width = 27\r\n Height = 13\r\n Caption = 'Units:'\r\n end\r\n object Label6: TLabel\r\n Left = 10\r\n Top = 174\r\n Width = 38\r\n Height = 13\r\n Caption = 'Header:'\r\n end\r\n object Label7: TLabel\r\n Left = 10\r\n Top = 199\r\n Width = 33\r\n Height = 13\r\n Caption = 'Footer:'\r\n end\r\n object Label8: TLabel\r\n Left = 10\r\n Top = 224\r\n Width = 84\r\n Height = 13\r\n Caption = 'HFInternalMargin:'\r\n end\r\n object Label9: TLabel\r\n Left = 10\r\n Top = 249\r\n Width = 86\r\n Height = 13\r\n Caption = 'LeftHFTextIndent:'\r\n end\r\n object Label10: TLabel\r\n Left = 10\r\n Top = 274\r\n Width = 93\r\n Height = 13\r\n Caption = 'RightHFTextIndent:'\r\n end\r\n object Label11: TLabel\r\n Left = 10\r\n Top = 144\r\n Width = 29\r\n Height = 13\r\n Caption = 'Gutter'\r\n end\r\n object OKBtn: TButton\r\n Left = 344\r\n Top = 310\r\n Width = 75\r\n Height = 25\r\n Caption = 'OK'\r\n Default = True\r\n ModalResult = 1\r\n TabOrder = 12\r\n end\r\n object CancelBtn: TButton\r\n Left = 424\r\n Top = 310\r\n Width = 75\r\n Height = 25\r\n Cancel = True\r\n Caption = 'Cancel'\r\n ModalResult = 2\r\n TabOrder = 13\r\n end\r\n object CBMirrorMargins: TCheckBox\r\n Left = 10\r\n Top = 300\r\n Width = 97\r\n Height = 17\r\n Caption = 'Mirror margins'\r\n TabOrder = 11\r\n end\r\n object EditLeft: TEdit\r\n Left = 110\r\n Top = 40\r\n Width = 151\r\n Height = 21\r\n TabOrder = 1\r\n end\r\n object EditRight: TEdit\r\n Left = 110\r\n Top = 65\r\n Width = 151\r\n Height = 21\r\n TabOrder = 2\r\n end\r\n object EditTop: TEdit\r\n Left = 110\r\n Top = 90\r\n Width = 151\r\n Height = 21\r\n TabOrder = 3\r\n end\r\n object EditBottom: TEdit\r\n Left = 110\r\n Top = 115\r\n Width = 151\r\n Height = 21\r\n TabOrder = 4\r\n end\r\n object EditGutter: TEdit\r\n Left = 110\r\n Top = 140\r\n Width = 151\r\n Height = 21\r\n TabOrder = 5\r\n end\r\n object EditHeader: TEdit\r\n Left = 110\r\n Top = 170\r\n Width = 151\r\n Height = 21\r\n TabOrder = 6\r\n end\r\n object EditFooter: TEdit\r\n Left = 110\r\n Top = 195\r\n Width = 151\r\n Height = 21\r\n TabOrder = 7\r\n end\r\n object EditHFInternalMargin: TEdit\r\n Left = 110\r\n Top = 220\r\n Width = 151\r\n Height = 21\r\n TabOrder = 8\r\n end\r\n object EditLeftHFTextIndent: TEdit\r\n Left = 110\r\n Top = 245\r\n Width = 151\r\n Height = 21\r\n TabOrder = 9\r\n end\r\n object EditRightHFTextIndent: TEdit\r\n Left = 110\r\n Top = 270\r\n Width = 151\r\n Height = 21\r\n TabOrder = 10\r\n end\r\n object CBUnits: TComboBox\r\n Left = 110\r\n Top = 10\r\n Width = 151\r\n Height = 21\r\n Style = csDropDownList\r\n ItemHeight = 13\r\n Items.Strings = (\r\n 'mm'\r\n 'cm'\r\n 'Inches'\r\n 'Thousandths Of Inches')\r\n TabOrder = 0\r\n OnChange = CBUnitsChange\r\n end\r\nend\r\n" }, { "path": "External/SynEdit/Source/SynEditPrintMarginsDialog.pas", "content": "{-------------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: SynEditPrintMarginsDialog.pas, released 2000-06-01.\r\n\r\nThe Initial Author of the Original Code is Morten J. Skovrup.\r\nPortions written by Morten J. Skovrup are copyright 2000 Morten J. Skovrup.\r\nAll Rights Reserved.\r\n\r\nContributors to the SynEdit project are listed in the Contributors.txt file.\r\n\r\nAlternatively, the contents of this file may be used under the terms of the\r\nGNU General Public License Version 2 or later (the \"GPL\"), in which case\r\nthe provisions of the GPL are applicable instead of those above.\r\nIf you wish to allow use of your version of this file only under the terms\r\nof the GPL and not to allow others to use your version of this file\r\nunder the MPL, indicate your decision by deleting the provisions above and\r\nreplace them with the notice and other provisions required by the GPL.\r\nIf you do not delete the provisions above, a recipient may use your version\r\nof this file under either the MPL or the GPL.\r\n\r\n$Id: SynEditPrintMarginsDialog.pas,v 1.5.2.1 2004/08/31 12:55:18 maelh Exp $\r\n\r\nYou may retrieve the latest version of this file at the SynEdit home page,\r\nlocated at http://SynEdit.SourceForge.net\r\n\r\nKnown Issues:\r\n-------------------------------------------------------------------------------}\r\n\r\n\r\n{-------------------------------------------------------------------------------\r\nCONTENTS:\r\n Property editor for TSynEditPrintMargins - nothing fancy, it only displays\r\n a picture that can help with understanding the different values.\r\n-------------------------------------------------------------------------------}\r\n\r\n{$IFNDEF QSYNEDITPRINTMARGINSDIALOG}\r\nunit SynEditPrintMarginsDialog;\r\n{$ENDIF}\r\n\r\n{$I SynEdit.inc}\r\n\r\ninterface\r\n\r\nuses\r\n{$IFDEF SYN_CLX}\r\n Qt,\r\n QGraphics,\r\n QForms,\r\n QControls,\r\n QStdCtrls,\r\n QButtons,\r\n QExtCtrls,\r\n QDialogs,\r\n QSynEditPrint,\r\n QSynEditPrintTypes,\r\n QSynEditPrintMargins,\r\n{$ELSE}\r\n Windows,\r\n Graphics,\r\n Forms,\r\n Controls,\r\n StdCtrls,\r\n Buttons,\r\n ExtCtrls,\r\n Dialogs,\r\n SynEditPrint,\r\n SynEditPrintTypes,\r\n SynEditPrintMargins,\r\n{$ENDIF}\r\n SysUtils,\r\n Classes;\r\n\r\ntype\r\n TSynEditPrintMarginsDlg = class(TForm)\r\n OKBtn: TButton;\r\n CancelBtn: TButton;\r\n Image1: TImage;\r\n Label1: TLabel;\r\n Label2: TLabel;\r\n Label3: TLabel;\r\n Label4: TLabel;\r\n Label5: TLabel;\r\n Label6: TLabel;\r\n Label7: TLabel;\r\n Label8: TLabel;\r\n Label9: TLabel;\r\n CBMirrorMargins: TCheckBox;\r\n Label10: TLabel;\r\n Label11: TLabel;\r\n EditLeft: TEdit;\r\n EditRight: TEdit;\r\n EditTop: TEdit;\r\n EditBottom: TEdit;\r\n EditGutter: TEdit;\r\n EditHeader: TEdit;\r\n EditFooter: TEdit;\r\n EditHFInternalMargin: TEdit;\r\n EditLeftHFTextIndent: TEdit;\r\n EditRightHFTextIndent: TEdit;\r\n CBUnits: TComboBox;\r\n procedure FormCreate(Sender: TObject);\r\n procedure FormDestroy(Sender: TObject);\r\n procedure CBUnitsChange(Sender: TObject);\r\n private\r\n { Private declarations }\r\n FMargins: TSynEditPrintMargins;\r\n FInternalCall: Boolean;\r\n public\r\n { Public declarations }\r\n procedure SetMargins(SynEditMargins: TSynEditPrintMargins);\r\n procedure GetMargins(SynEditMargins: TSynEditPrintMargins);\r\n end;\r\n\r\nimplementation\r\n\r\n{$R *.dfm}\r\n\r\n{ TSynEditPrintMarginsDlg }\r\n\r\nprocedure TSynEditPrintMarginsDlg.FormCreate(Sender: TObject);\r\nbegin\r\n FMargins := TSynEditPrintMargins.Create;\r\n FInternalCall := False;\r\nend;\r\n\r\nprocedure TSynEditPrintMarginsDlg.FormDestroy(Sender: TObject);\r\nbegin\r\n FMargins.Free;\r\nend;\r\n\r\nprocedure TSynEditPrintMarginsDlg.GetMargins(\r\n SynEditMargins: TSynEditPrintMargins);\r\nvar\r\n CurEdit: TEdit;\r\n function StringToFloat(Edit: TEdit): Double;\r\n begin\r\n CurEdit := Edit;\r\n Result := StrToFloat(Edit.Text);\r\n end;\r\nbegin\r\n with SynEditMargins do begin\r\n if not FInternalCall then\r\n UnitSystem := TUnitSystem(CBUnits.ItemIndex);\r\n try\r\n Left := StringToFloat(EditLeft);\r\n Right := StringToFloat(EditRight);\r\n Top := StringToFloat(EditTop);\r\n Bottom := StringToFloat(EditBottom);\r\n Gutter := StringToFloat(EditGutter);\r\n Header := StringToFloat(EditHeader);\r\n Footer := StringToFloat(EditFooter);\r\n LeftHFTextIndent := StringToFloat(EditLeftHFTextIndent);\r\n RightHFTextIndent := StringToFloat(EditRightHFTextIndent);\r\n HFInternalMargin := StringToFloat(EditHFInternalMargin);\r\n except\r\n MessageDlg('Invalid number!', mtError, [mbOk], 0);\r\n CurEdit.SetFocus;\r\n end;\r\n MirrorMargins := CBMirrorMargins.Checked;\r\n end;\r\nend;\r\n\r\nprocedure TSynEditPrintMarginsDlg.SetMargins(\r\n SynEditMargins: TSynEditPrintMargins);\r\nbegin\r\n with SynEditMargins do begin\r\n CBUnits.ItemIndex := Ord(UnitSystem);\r\n EditLeft.Text := FloatToStr(Left);\r\n EditRight.Text := FloatToStr(Right);\r\n EditTop.Text := FloatToStr(Top);\r\n EditBottom.Text := FloatToStr(Bottom);\r\n EditGutter.Text := FloatToStr(Gutter);\r\n EditHeader.Text := FloatToStr(Header);\r\n EditFooter.Text := FloatToStr(Footer);\r\n EditLeftHFTextIndent.Text := FloatToStr(LeftHFTextIndent);\r\n EditRightHFTextIndent.Text := FloatToStr(RightHFTextIndent);\r\n EditHFInternalMargin.Text := FloatToStr(HFInternalMargin);\r\n CBMirrorMargins.Checked := MirrorMargins;\r\n end;\r\nend;\r\n\r\nprocedure TSynEditPrintMarginsDlg.CBUnitsChange(Sender: TObject);\r\nbegin\r\n FInternalCall := True;\r\n GetMargins(FMargins);\r\n FInternalCall := False;\r\n FMargins.UnitSystem := TUnitSystem(CBUnits.ItemIndex);\r\n SetMargins(FMargins);\r\nend;\r\n\r\nend.\r\n\r\n" }, { "path": "External/SynEdit/Source/SynEditPrintPreview.pas", "content": "{-------------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: SynEditPrintPreview.pas, released 2000-06-01.\r\n\r\nThe Initial Author of the Original Code is Morten J. Skovrup.\r\nPortions written by Morten J. Skovrup are copyright 2000 Morten J. Skovrup.\r\nPortions written by Michael Hieke are copyright 2000 Michael Hieke.\r\nUnicode translation by Mal Hrz.\r\nAll Rights Reserved.\r\n\r\nContributors to the SynEdit project are listed in the Contributors.txt file.\r\n\r\nAlternatively, the contents of this file may be used under the terms of the\r\nGNU General Public License Version 2 or later (the \"GPL\"), in which case\r\nthe provisions of the GPL are applicable instead of those above.\r\nIf you wish to allow use of your version of this file only under the terms\r\nof the GPL and not to allow others to use your version of this file\r\nunder the MPL, indicate your decision by deleting the provisions above and\r\nreplace them with the notice and other provisions required by the GPL.\r\nIf you do not delete the provisions above, a recipient may use your version\r\nof this file under either the MPL or the GPL.\r\n\r\n$Id: SynEditPrintPreview.pas,v 1.18.2.2 2008/09/14 16:24:59 maelh Exp $\r\n\r\nYou may retrieve the latest version of this file at the SynEdit home page,\r\nlocated at http://SynEdit.SourceForge.net\r\n\r\nKnown Issues:\r\n-------------------------------------------------------------------------------}\r\n\r\n\r\n{-------------------------------------------------------------------------------\r\nCONTENTS:\r\n Print preview component. Allmost identical to code developed by Michael Hieke.\r\n It is important to call UpdatePreview whenever things change (i.e. just\r\n before the preview is shown, and when the printer is changed)\r\n-------------------------------------------------------------------------------}\r\n\r\n{$IFNDEF QSYNEDITPRINTPREVIEW}\r\nunit SynEditPrintPreview;\r\n{$ENDIF}\r\n\r\n{$I SynEdit.inc}\r\n\r\n{$M+}\r\ninterface\r\n\r\nuses\r\n{$IFDEF SYN_CLX}\r\n Qt,\r\n QControls,\r\n QGraphics,\r\n QForms,\r\n Types,\r\n QSynEditPrint,\r\n{$ELSE}\r\n {$IFDEF SYN_COMPILER_7}\r\n Themes,\r\n {$ENDIF}\r\n Windows,\r\n Controls,\r\n Messages,\r\n Graphics,\r\n Forms,\r\n SynEditPrint,\r\n{$ENDIF}\r\n Classes,\r\n SysUtils;\r\n\r\ntype\r\n//Event raised when page is changed in preview\r\n TPreviewPageEvent = procedure(Sender: TObject; PageNumber: Integer) of object;\r\n TSynPreviewScale = (pscWholePage, pscPageWidth, pscUserScaled);\r\n\r\n {$IFNDEF SYN_COMPILER_4_UP}\r\n TWMMouseWheel = record\r\n Msg: Cardinal;\r\n Keys: SmallInt;\r\n WheelDelta: SmallInt;\r\n case Integer of\r\n 0: (\r\n XPos: Smallint;\r\n YPos: Smallint);\r\n 1: (\r\n Pos: TSmallPoint;\r\n Result: Longint);\r\n end;\r\n {$ENDIF}\r\n\r\n TSynEditPrintPreview = class(TCustomControl)\r\n protected\r\n FBorderStyle: TBorderStyle;\r\n FSynEditPrint: TSynEditPrint;\r\n FScaleMode: TSynPreviewScale;\r\n FScalePercent: Integer;\r\n // these are in pixels ( = screen device units)\r\n FVirtualSize: TPoint;\r\n FVirtualOffset: TPoint;\r\n FPageSize: TPoint;\r\n FScrollPosition: TPoint;\r\n FPageBG: TColor;\r\n FPageNumber: Integer;\r\n FShowScrollHint: Boolean;\r\n FOnPreviewPage: TPreviewPageEvent;\r\n FOnScaleChange: TNotifyEvent; // JD 2002-01-9\r\n {$IFNDEF SYN_CLX}\r\n FWheelAccumulator: Integer;\r\n {$ENDIF}\r\n procedure SetBorderStyle(Value: TBorderStyle);\r\n procedure SetPageBG(Value: TColor);\r\n procedure SetSynEditPrint(Value: TSynEditPrint);\r\n procedure SetScaleMode(Value: TSynPreviewScale);\r\n procedure SetScalePercent(Value: Integer);\r\n private\r\n {$IFNDEF SYN_CLX}\r\n procedure WMEraseBkgnd(var Msg: TWMEraseBkgnd); message WM_ERASEBKGND;\r\n procedure WMHScroll(var Msg: TWMHScroll); message WM_HSCROLL;\r\n procedure WMSize(var Msg: TWMSize); message WM_SIZE;\r\n procedure WMVScroll(var Msg: TWMVScroll); message WM_VSCROLL;\r\n procedure WMMouseWheel(var Message: TWMMouseWheel); message\r\n {$IFDEF SYN_COMPILER_3_UP} WM_MOUSEWHEEL {$ELSE} $020A {$ENDIF};\r\n {$ENDIF}\r\n procedure PaintPaper;\r\n function GetPageCount: Integer;\r\n protected\r\n {$IFNDEF SYN_CLX}\r\n procedure CreateParams(var Params: TCreateParams); override;\r\n {$ENDIF}\r\n function GetPageHeightFromWidth(AWidth: Integer): Integer;\r\n function GetPageHeight100Percent: Integer;\r\n function GetPageWidthFromHeight(AHeight: Integer): Integer;\r\n function GetPageWidth100Percent: Integer;\r\n procedure Notification(AComponent: TComponent; Operation: TOperation); override;\r\n procedure ScrollHorzFor(Value: Integer);\r\n procedure ScrollHorzTo(Value: Integer); virtual;\r\n procedure ScrollVertFor(Value: Integer);\r\n procedure ScrollVertTo(Value: Integer); virtual;\r\n procedure UpdateScrollbars; virtual;\r\n procedure SizeChanged; virtual;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n procedure Paint; override;\r\n procedure UpdatePreview;\r\n procedure NextPage;\r\n procedure PreviousPage;\r\n procedure FirstPage;\r\n procedure LastPage;\r\n procedure Print;\r\n property PageNumber: Integer read FPageNumber;\r\n property PageCount: Integer read GetPageCount;\r\n published\r\n property Align default alClient;\r\n property BorderStyle: TBorderStyle read FBorderStyle write SetBorderStyle\r\n default bsSingle;\r\n property Color default clAppWorkspace;\r\n property Cursor;\r\n property PageBGColor: TColor read FPageBG write SetPageBG default clWhite;\r\n property PopupMenu; // JD 2002-01-9\r\n property SynEditPrint: TSynEditPrint read FSynEditPrint\r\n write SetSynEditPrint;\r\n property ScaleMode: TSynPreviewScale read FScaleMode write SetScaleMode\r\n default pscUserScaled;\r\n property ScalePercent: Integer read FScalePercent write SetScalePercent\r\n default 100;\r\n property Visible default True;\r\n property ShowScrollHint: Boolean read FShowScrollHint write FShowScrollHint\r\n default True;\r\n property OnClick;\r\n property OnMouseDown;\r\n property OnMouseUp;\r\n property OnPreviewPage: TPreviewPageEvent read FOnPreviewPage\r\n write FOnPreviewPage;\r\n property OnScaleChange: TNotifyEvent read FOnScaleChange // JD 2002-01-9\r\n write FOnScaleChange; // JD 2002-01-9\r\n end;\r\n\r\nimplementation\r\n\r\nuses\r\n{$IFDEF SYN_CLX}\r\n QSynEditStrConst;\r\n{$ELSE}\r\n SynEditStrConst;\r\n{$ENDIF}\r\n\r\nconst\r\n MARGIN_X = 12; // margin width left and right of page\r\n MARGIN_Y = 12; // margin height above and below page\r\n SHADOW_SIZE = 2; // page shadow width\r\n\r\n{ TSynEditPrintPreview }\r\n\r\nconstructor TSynEditPrintPreview.Create(AOwner: TComponent);\r\nbegin\r\n inherited;\r\n{$IFDEF SYN_COMPILER_7_UP}\r\n {$IFNDEF SYN_CLX}\r\n ControlStyle := ControlStyle + [csNeedsBorderPaint];\r\n {$ENDIF}\r\n{$ENDIF}\r\n FBorderStyle := bsSingle;\r\n FScaleMode := pscUserScaled;\r\n FScalePercent := 100;\r\n FPageBG := clWhite;\r\n Width := 200;\r\n Height := 120;\r\n ParentColor := False;\r\n Color := clAppWorkspace;\r\n Visible := True;\r\n FPageNumber := 1;\r\n FShowScrollHint := True;\r\n Align := alClient;\r\n{$IFNDEF SYN_CLX}\r\n FWheelAccumulator := 0;\r\n{$ENDIF}\r\nend;\r\n\r\n{$IFNDEF SYN_CLX}\r\nprocedure TSynEditPrintPreview.CreateParams(var Params: TCreateParams);\r\nconst\r\n BorderStyles: array[TBorderStyle] of DWord = (0, WS_BORDER);\r\nbegin\r\n inherited;\r\n with Params do begin\r\n Style := Style or WS_HSCROLL or WS_VSCROLL or BorderStyles[FBorderStyle]\r\n or WS_CLIPCHILDREN;\r\n if NewStyleControls and Ctl3D and (FBorderStyle = bsSingle) then begin\r\n Style := Style and not WS_BORDER;\r\n ExStyle := ExStyle or WS_EX_CLIENTEDGE;\r\n end;\r\n end;\r\nend;\r\n{$ENDIF}\r\n\r\nfunction TSynEditPrintPreview.GetPageHeightFromWidth(AWidth: Integer): Integer;\r\nbegin\r\n if Assigned(FSynEditPrint) then begin\r\n with FSynEditPrint.PrinterInfo do\r\n Result := MulDiv(AWidth, PhysicalHeight, PhysicalWidth);\r\n end\r\n else\r\n Result := MulDiv(AWidth, 141, 100); // fake A4 size\r\nend;\r\n\r\nfunction TSynEditPrintPreview.GetPageWidthFromHeight(AHeight: Integer): Integer;\r\nbegin\r\n if Assigned(FSynEditPrint) then begin\r\n with FSynEditPrint.PrinterInfo do\r\n Result := MulDiv(AHeight, PhysicalWidth, PhysicalHeight);\r\n end\r\n else\r\n Result := MulDiv(AHeight, 100, 141); // fake A4 size\r\nend;\r\n\r\nfunction TSynEditPrintPreview.GetPageHeight100Percent: Integer;\r\nvar\r\n {$IFNDEF SYN_CLX}\r\n DC: HDC;\r\n {$ENDIF}\r\n ScreenDPI: Integer;\r\nbegin\r\n Result := 0;\r\n{$IFDEF SYN_CLX}\r\n ScreenDPI := Screen.Height;\r\n{$ELSE}\r\n DC := GetDC(0);\r\n ScreenDPI := GetDeviceCaps(DC, LogPixelsY);\r\n ReleaseDC(0, DC);\r\n{$ENDIF}\r\n if Assigned(FSynEditPrint) then\r\n with FSynEditPrint.PrinterInfo do\r\n Result := MulDiv(PhysicalHeight, ScreenDPI, YPixPrInch);\r\nend;\r\n\r\nfunction TSynEditPrintPreview.GetPageWidth100Percent: Integer;\r\nvar\r\n {$IFNDEF SYN_CLX}\r\n DC: HDC;\r\n {$ENDIF}\r\n ScreenDPI: Integer;\r\nbegin\r\n Result := 0;\r\n{$IFDEF SYN_CLX}\r\n ScreenDPI := Screen.Height;\r\n{$ELSE}\r\n DC := GetDC(0);\r\n ScreenDPI := GetDeviceCaps(DC, LogPixelsX);\r\n ReleaseDC(0, DC);\r\n{$ENDIF}\r\n if Assigned(FSynEditPrint) then\r\n with FSynEditPrint.PrinterInfo do\r\n Result := MulDiv(PhysicalWidth, ScreenDPI, XPixPrInch);\r\nend;\r\n\r\nprocedure TSynEditPrintPreview.Notification(AComponent: TComponent;\r\n Operation: TOperation);\r\nbegin\r\n inherited;\r\n if (Operation = opRemove) and (AComponent = FSynEditPrint) then\r\n SynEditPrint := nil;\r\nend;\r\n\r\nprocedure TSynEditPrintPreview.PaintPaper;\r\nvar\r\n rcClip, rcPaper: TRect;\r\n {$IFNDEF SYN_CLX}\r\n rgnPaper: HRGN;\r\n {$ENDIF}\r\n i: Integer;\r\nbegin\r\n with Canvas do begin\r\n // we work in MM_TEXT mapping mode here...\r\n rcClip := ClipRect;\r\n if IsRectEmpty(rcClip) then Exit;\r\n Brush.Color := Self.Color;\r\n Brush.Style := bsSolid;\r\n Pen.Color := clBlack;\r\n Pen.Width := 1;\r\n Pen.Style := psSolid;\r\n if (csDesigning in ComponentState) or (not Assigned(FSynEditPrint)) then begin\r\n FillRect(rcClip);\r\n Brush.Color := FPageBG;\r\n Rectangle(MARGIN_X, MARGIN_Y, MARGIN_X + 30, MARGIN_Y + 43);\r\n Exit;\r\n end;\r\n // fill background around paper\r\n with rcPaper do begin\r\n Left := FVirtualOffset.X + FScrollPosition.X;\r\n if ScaleMode = pscWholePage then\r\n Top := FVirtualOffset.Y\r\n else\r\n Top := FVirtualOffset.Y + FScrollPosition.Y;\r\n Right := Left + FPageSize.X;\r\n Bottom := Top + FPageSize.Y;\r\n {$IFNDEF SYN_CLX}\r\n rgnPaper := CreateRectRgn(Left, Top, Right + 1, Bottom + 1);\r\n {$ENDIF}\r\n end;\r\n {$IFNDEF SYN_CLX}\r\n if (NULLREGION <> ExtSelectClipRgn(Handle, rgnPaper, RGN_DIFF)) then\r\n FillRect(rcClip);\r\n {$ENDIF}\r\n // paper shadow\r\n Brush.Color := clDkGray;\r\n with rcPaper do begin\r\n for i := 1 to SHADOW_SIZE do\r\n PolyLine([Point(Left + i, Bottom + i), Point(Right + i, Bottom + i),\r\n Point(Right + i, Top + i)]);\r\n end;\r\n // paint paper background\r\n {$IFNDEF SYN_CLX}\r\n SelectClipRgn(Handle, rgnPaper);\r\n {$ENDIF}\r\n Brush.Color := FPageBG;\r\n with rcPaper do\r\n Rectangle(Left, Top, Right + 1, Bottom + 1);\r\n {$IFNDEF SYN_CLX}\r\n DeleteObject(rgnPaper);\r\n {$ENDIF}\r\n end;\r\nend;\r\n\r\nprocedure TSynEditPrintPreview.Paint;\r\nvar\r\n ptOrgScreen: TPoint;\r\nbegin\r\n with Canvas do begin\r\n PaintPaper;\r\n if (csDesigning in ComponentState) or (not Assigned(FSynEditPrint)) then\r\n Exit;\r\n // paint the contents, clipped to the area inside of the print margins\r\n // correct scaling for output:\r\n\r\n {$IFNDEF SYN_CLX}\r\n SetMapMode(Handle, MM_ANISOTROPIC);\r\n {$ENDIF}\r\n // compute the logical point (0, 0) in screen pixels\r\n with FSynEditPrint.PrinterInfo do\r\n begin\r\n {$IFNDEF SYN_CLX}\r\n SetWindowExtEx(Handle, PhysicalWidth, PhysicalHeight, nil);\r\n SetViewPortExtEx(Handle, FPageSize.X, FPageSize.Y, nil);\r\n {$ENDIF}\r\n ptOrgScreen.X := MulDiv(LeftGutter, FPageSize.X, PhysicalWidth);\r\n ptOrgScreen.Y := MulDiv(TopGutter, FPageSize.Y, PhysicalHeight);\r\n Inc(ptOrgScreen.X, FVirtualOffset.X + FScrollPosition.X);\r\n if ScaleMode = pscWholePage then\r\n Inc(ptOrgScreen.Y, FVirtualOffset.Y)\r\n else\r\n Inc(ptOrgScreen.Y, FVirtualOffset.Y + FScrollPosition.Y);\r\n {$IFNDEF SYN_CLX}\r\n SetViewPortOrgEx(Handle, ptOrgScreen.X, ptOrgScreen.Y, nil);\r\n // clip the output to the print margins\r\n IntersectClipRect(Handle, 0, 0, PrintableWidth, PrintableHeight);\r\n {$ENDIF}\r\n end;\r\n FSynEditPrint.PrintToCanvas(Canvas, FPageNumber);\r\n end;\r\nend;\r\n\r\nprocedure TSynEditPrintPreview.ScrollHorzFor(Value: Integer);\r\nbegin\r\n ScrollHorzTo(FScrollPosition.X + Value);\r\nend;\r\n\r\nprocedure TSynEditPrintPreview.ScrollHorzTo(Value: Integer);\r\nvar\r\n nW, n: Integer;\r\nbegin\r\n nW := ClientWidth;\r\n n := nW - FVirtualSize.X;\r\n if (Value < n) then Value := n;\r\n if (Value > 0) then Value := 0;\r\n if (Value <> FScrollPosition.X) then\r\n begin\r\n n := Value - FScrollPosition.X;\r\n FScrollPosition.X := Value;\r\n UpdateScrollbars;\r\n if (Abs(n) > nW div 2) then\r\n Invalidate\r\n else\r\n begin\r\n {$IFNDEF SYN_CLX}\r\n ScrollWindow(Handle, n, 0, nil, nil);\r\n {$ENDIF}\r\n Update;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TSynEditPrintPreview.ScrollVertFor(Value: Integer);\r\nbegin\r\n ScrollVertTo(FScrollPosition.Y + Value);\r\nend;\r\n\r\nprocedure TSynEditPrintPreview.ScrollVertTo(Value: Integer);\r\nvar\r\n nH, n: Integer;\r\nbegin\r\n nH := ClientHeight;\r\n n := nH - FVirtualSize.Y;\r\n if (Value < n) then Value := n;\r\n if (Value > 0) then Value := 0;\r\n if (Value <> FScrollPosition.Y) then\r\n begin\r\n n := Value - FScrollPosition.Y;\r\n FScrollPosition.Y := Value;\r\n UpdateScrollbars;\r\n if (Abs(n) > nH div 2) then\r\n Invalidate\r\n else\r\n begin\r\n {$IFNDEF SYN_CLX}\r\n ScrollWindow(Handle, 0, n, nil, nil);\r\n {$ENDIF}\r\n Update;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TSynEditPrintPreview.SizeChanged;\r\nvar\r\n nWDef: Integer;\r\nbegin\r\n if not (HandleAllocated and Assigned(FSynEditPrint)) then Exit;\r\n // compute paper size\r\n case fScaleMode of\r\n pscWholePage: begin\r\n FPageSize.X := ClientWidth - 2 * MARGIN_X - SHADOW_SIZE;\r\n FPageSize.Y := ClientHeight - 2 * MARGIN_Y - SHADOW_SIZE;\r\n nWDef := GetPageWidthFromHeight(FPageSize.Y);\r\n if (nWDef < FPageSize.X) then\r\n FPageSize.X := nWDef\r\n else\r\n FPageSize.Y := GetPageHeightFromWidth(FPageSize.X);\r\n end;\r\n pscPageWidth: begin\r\n FPageSize.X := ClientWidth - 2 * MARGIN_X - SHADOW_SIZE;\r\n FPageSize.Y := GetPageHeightFromWidth(FPageSize.X);\r\n end;\r\n pscUserScaled: begin\r\n FPageSize.X := MulDiv(GetPageWidth100Percent, fScalePercent, 100);\r\n FPageSize.Y := MulDiv(GetPageHeight100Percent, fScalePercent, 100);\r\n end;\r\n end;\r\n FVirtualSize.X := FPageSize.X + 2 * MARGIN_X + SHADOW_SIZE;\r\n FVirtualSize.Y := FPageSize.Y + 2 * MARGIN_Y + SHADOW_SIZE;\r\n FVirtualOffset.X := MARGIN_X;\r\n if (FVirtualSize.X < ClientWidth) then\r\n Inc(FVirtualOffset.X, (ClientWidth - FVirtualSize.X) div 2);\r\n FVirtualOffset.Y := MARGIN_Y;\r\n if (FVirtualSize.Y < ClientHeight) then\r\n Inc(FVirtualOffset.Y, (ClientHeight - FVirtualSize.Y) div 2);\r\n UpdateScrollbars;\r\n// TODO\r\n FScrollPosition.X := 0;\r\n FScrollPosition.Y := 0;\r\nend;\r\n\r\n\r\nprocedure TSynEditPrintPreview.UpdateScrollbars;\r\n{$IFNDEF SYN_CLX}\r\nvar\r\n si: TScrollInfo;\r\n{$ENDIF}\r\nbegin\r\n{$IFNDEF SYN_CLX}\r\n FillChar(si, SizeOf(TScrollInfo), 0);\r\n si.cbSize := SizeOf(TScrollInfo);\r\n si.fMask := SIF_ALL;\r\n case FScaleMode of\r\n pscWholePage: begin\r\n // hide horizontal scrollbar\r\n ShowScrollbar(Handle, SB_HORZ, False);\r\n // show vertical scrollbar, enable if more than one page\r\n si.fMask := si.fMask or SIF_DISABLENOSCROLL;\r\n si.nMin := 1;\r\n if Assigned(FSynEditPrint) then begin\r\n si.nMax := FSynEditPrint.PageCount;\r\n si.nPos := FPageNumber;\r\n end\r\n else begin\r\n si.nMax := 1;\r\n si.nPos := 1;\r\n end;\r\n si.nPage := 1;\r\n SetScrollInfo(Handle, SB_VERT, si, True);\r\n end;\r\n pscPageWidth: begin\r\n // hide horizontal scrollbar\r\n ShowScrollbar(Handle, SB_HORZ, False);\r\n // show vertical scrollbar\r\n si.fMask := si.fMask or SIF_DISABLENOSCROLL;\r\n si.nMax := FVirtualSize.Y;\r\n si.nPos := -FScrollPosition.Y;\r\n si.nPage := ClientHeight;\r\n SetScrollInfo(Handle, SB_VERT, si, True);\r\n end;\r\n pscUserScaled: begin\r\n ShowScrollbar(Handle, SB_HORZ, True);\r\n ShowScrollbar(Handle, SB_VERT, True);\r\n si.fMask := si.fMask or SIF_DISABLENOSCROLL;\r\n // show horizontal scrollbar\r\n si.nMax := FVirtualSize.X;\r\n si.nPos := -FScrollPosition.X;\r\n si.nPage := ClientWidth;\r\n SetScrollInfo(Handle, SB_HORZ, si, True);\r\n // show vertical scrollbar\r\n si.nMax := FVirtualSize.Y;\r\n si.nPos := -FScrollPosition.Y;\r\n si.nPage := ClientHeight;\r\n SetScrollInfo(Handle, SB_VERT, si, True);\r\n end;\r\n end;\r\n{$ENDIF}\r\nend;\r\n\r\nprocedure TSynEditPrintPreview.SetBorderStyle(Value: TBorderStyle);\r\nbegin\r\n if (Value <> FBorderStyle) then\r\n begin\r\n FBorderStyle := Value;\r\n {$IFNDEF SYN_CLX}\r\n RecreateWnd;\r\n {$ENDIF}\r\n end;\r\nend;\r\n\r\nprocedure TSynEditPrintPreview.SetPageBG(Value: TColor);\r\nbegin\r\n if (FPageBG <> Value) then\r\n begin\r\n FPageBG := Value;\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TSynEditPrintPreview.SetSynEditPrint(Value: TSynEditPrint);\r\nbegin\r\n if (FSynEditPrint <> Value) then\r\n begin\r\n FSynEditPrint := Value;\r\n if Assigned(FSynEditPrint) then\r\n FSynEditPrint.FreeNotification(Self);\r\n end;\r\nend;\r\n\r\nprocedure TSynEditPrintPreview.SetScaleMode(Value: TSynPreviewScale);\r\nbegin\r\n if (FScaleMode <> Value) then begin\r\n FScaleMode := Value;\r\n FScrollPosition := Point(0, 0);\r\n SizeChanged;\r\n if Assigned(FOnScaleChange) then // JD 2002-01-9\r\n FOnScaleChange(Self); // JD 2002-01-9\r\n Invalidate;\r\n end;\r\nend;\r\n\r\nprocedure TSynEditPrintPreview.SetScalePercent(Value: Integer);\r\nbegin\r\n if (FScalePercent <> Value) then begin\r\n FScaleMode := pscUserScaled;\r\n FScrollPosition := Point(0, 0);\r\n FScalePercent := Value;\r\n SizeChanged;\r\n Invalidate;\r\n end else\r\n ScaleMode := pscUserScaled;\r\n if Assigned(FOnScaleChange) then // JD 2002-01-9\r\n FOnScaleChange(Self); // JD 2002-01-9\r\nend;\r\n\r\n{$IFNDEF SYN_CLX}\r\nprocedure TSynEditPrintPreview.WMEraseBkgnd(var Msg: TWMEraseBkgnd);\r\nbegin\r\n Msg.Result := 1;\r\nend;\r\n\r\nprocedure TSynEditPrintPreview.WMHScroll(var Msg: TWMHScroll);\r\nvar\r\n nW: Integer;\r\nbegin\r\n if (FScaleMode <> pscWholePage) then begin\r\n nW := ClientWidth;\r\n case Msg.ScrollCode of\r\n SB_TOP: ScrollHorzTo(0);\r\n SB_BOTTOM: ScrollHorzTo(-FVirtualSize.X);\r\n SB_LINEDOWN: ScrollHorzFor(-(nW div 10));\r\n SB_LINEUP: ScrollHorzFor(nW div 10);\r\n SB_PAGEDOWN: ScrollHorzFor(-(nW div 2));\r\n SB_PAGEUP: ScrollHorzFor(nW div 2);\r\n SB_THUMBPOSITION, SB_THUMBTRACK: ScrollHorzTo(-Msg.Pos);\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TSynEditPrintPreview.WMSize(var Msg: TWMSize);\r\nbegin\r\n inherited;\r\n if not (csDesigning in ComponentState) then SizeChanged;\r\nend;\r\n\r\nvar\r\n ScrollHintWnd: THintWindow;\r\n\r\nfunction GetScrollHint: THintWindow;\r\nbegin\r\n if ScrollHintWnd = nil then begin\r\n ScrollHintWnd := HintWindowClass.Create(Application);\r\n ScrollHintWnd.Visible := FALSE;\r\n end;\r\n Result := ScrollHintWnd;\r\nend;\r\n\r\nprocedure TSynEditPrintPreview.WMVScroll(var Msg: TWMVScroll);\r\nvar\r\n nH: Integer;\r\n s: string;\r\n rc: TRect;\r\n pt: TPoint;\r\n ScrollHint: THintWindow;\r\nbegin\r\n if (FScaleMode = pscWholePage) then begin\r\n if Assigned(FSynEditPrint) then\r\n case Msg.ScrollCode of\r\n SB_TOP: FPageNumber := 1;\r\n SB_BOTTOM: FPageNumber := FSynEditPrint.PageCount;\r\n SB_LINEDOWN, SB_PAGEDOWN: begin\r\n FPageNumber := FPageNumber + 1;\r\n if FPageNumber > FSynEditPrint.PageCount then\r\n FPageNumber := FSynEditPrint.PageCount;\r\n end;\r\n SB_LINEUP, SB_PAGEUP: begin\r\n FPageNumber := FPageNumber - 1;\r\n if FPageNumber < 1 then\r\n FPageNumber := 1;\r\n end;\r\n SB_THUMBPOSITION, SB_THUMBTRACK: begin\r\n FPageNumber := Msg.Pos;\r\n //Showing hint window - principle copied from SynEdit.pas\r\n if FShowScrollHint then begin\r\n ScrollHint := GetScrollHint;\r\n if not ScrollHint.Visible then begin\r\n ScrollHint.Color := Application.HintColor;\r\n ScrollHint.Visible := TRUE;\r\n end;\r\n s := Format(SYNS_PreviewScrollInfoFmt, [FPageNumber]);\r\n{$IFDEF SYN_COMPILER_3_UP}\r\n rc := ScrollHint.CalcHintRect(200, s, nil);\r\n{$ELSE}\r\n rc := Rect(0, 0, TextWidth(ScrollHint.Canvas, s) + 6,\r\n TextHeight(ScrollHint.Canvas, s) + 4);\r\n{$ENDIF}\r\n pt := ClientToScreen(Point(ClientWidth - rc.Right - 4, 10));\r\n OffsetRect(rc, pt.x, pt.y);\r\n ScrollHint.ActivateHint(rc, s);\r\n{$IFDEF SYN_COMPILER_3}\r\n SendMessage(ScrollHint.Handle, WM_NCPAINT, 1, 0);\r\n{$ENDIF}\r\n{$IFNDEF SYN_COMPILER_3_UP}\r\n ScrollHint.Invalidate;\r\n{$ENDIF}\r\n ScrollHint.Update;\r\n end;\r\n end;\r\n SB_ENDSCROLL: begin\r\n if FShowScrollHint then\r\n begin\r\n ScrollHint := GetScrollHint;\r\n ScrollHint.Visible := False;\r\n ShowWindow(ScrollHint.Handle, SW_HIDE);\r\n end;\r\n end;\r\n end;\r\n {Updating scroll position and redrawing}\r\n FScrollPosition.Y := -(FPageNumber - 1);\r\n UpdateScrollbars;\r\n if Assigned(FOnPreviewPage) then\r\n FOnPreviewPage(Self, FPageNumber);\r\n Invalidate;\r\n end\r\n else begin\r\n nH := ClientHeight;\r\n case Msg.ScrollCode of\r\n SB_TOP: ScrollVertTo(0);\r\n SB_BOTTOM: ScrollVertTo(-FVirtualSize.Y);\r\n SB_LINEDOWN: ScrollVertFor(-(nH div 10));\r\n SB_LINEUP: ScrollVertFor(nH div 10);\r\n SB_PAGEDOWN: ScrollVertFor(-(nH div 2));\r\n SB_PAGEUP: ScrollVertFor(nH div 2);\r\n SB_THUMBPOSITION, SB_THUMBTRACK: ScrollVertTo(-Msg.Pos);\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TSynEditPrintPreview.WMMouseWheel(var Message: TWMMouseWheel);\r\n{$IFNDEF SYN_COMPILER_3_UP}\r\nconst\r\n WHEEL_DELTA = 120;\r\n{$ENDIF}\r\nvar\r\n bCtrl: Boolean;\r\n\r\n procedure MouseWheelUp;\r\n begin\r\n if bCtrl and (fPageNumber > 1) then\r\n PreviousPage\r\n else\r\n ScrollVertFor(WHEEL_DELTA);\r\n end;\r\n\r\n procedure MouseWheelDown;\r\n begin\r\n if bCtrl and (fPageNumber < PageCount) then\r\n NextPage\r\n else\r\n ScrollVertFor(-WHEEL_DELTA);\r\n end;\r\n\r\nvar\r\n MousePos: TPoint;\r\n IsNeg: Boolean;\r\nbegin\r\n { Find modifiers }\r\n bCtrl := GetKeyState(VK_CONTROL) < 0;\r\n\r\n { Find mouse pos and increment accumulator }\r\n MousePos:= SmallPointToPoint(Message.Pos);\r\n Inc(FWheelAccumulator, Message.WheelDelta);\r\n\r\n { Do actions while accumulated is bigger than delta }\r\n while Abs(FWheelAccumulator) >= WHEEL_DELTA do\r\n begin\r\n IsNeg := FWheelAccumulator < 0;\r\n FWheelAccumulator := Abs(FWheelAccumulator) - WHEEL_DELTA;\r\n if IsNeg then\r\n begin\r\n if FWheelAccumulator <> 0 then FWheelAccumulator := -FWheelAccumulator;\r\n MouseWheelDown;\r\n end\r\n else\r\n MouseWheelUp;\r\n end;\r\nend;\r\n\r\n{$ENDIF}\r\n\r\nprocedure TSynEditPrintPreview.UpdatePreview;\r\nvar\r\n OldScale: Integer;\r\n OldMode: TSynPreviewScale;\r\nbegin\r\n OldScale := ScalePercent;\r\n OldMode := ScaleMode;\r\n ScalePercent := 100;\r\n if Assigned(FSynEditPrint) then\r\n FSynEditPrint.UpdatePages(Canvas);\r\n SizeChanged;\r\n Invalidate;\r\n ScaleMode := OldMode;\r\n if ScaleMode = pscUserScaled then\r\n ScalePercent := OldScale;\r\n if Assigned(FOnPreviewPage) then\r\n FOnPreviewPage(Self, FPageNumber);\r\nend;\r\n\r\nprocedure TSynEditPrintPreview.FirstPage;\r\nbegin\r\n FPageNumber := 1;\r\n if Assigned(FOnPreviewPage) then\r\n FOnPreviewPage(Self, FPageNumber);\r\n Invalidate;\r\nend;\r\n\r\nprocedure TSynEditPrintPreview.LastPage;\r\nbegin\r\n if Assigned(FSynEditPrint) then\r\n FPageNumber := FSynEditPrint.PageCount;\r\n if Assigned(FOnPreviewPage) then\r\n FOnPreviewPage(Self, FPageNumber);\r\n Invalidate;\r\nend;\r\n\r\nprocedure TSynEditPrintPreview.NextPage;\r\nbegin\r\n FPageNumber := FPageNumber + 1;\r\n if Assigned(FSynEditPrint) and (FPageNumber > FSynEditPrint.PageCount) then\r\n FPageNumber := FSynEditPrint.PageCount;\r\n if Assigned(FOnPreviewPage) then\r\n FOnPreviewPage(Self, FPageNumber);\r\n Invalidate;\r\nend;\r\n\r\nprocedure TSynEditPrintPreview.PreviousPage;\r\nbegin\r\n FPageNumber := FPageNumber - 1;\r\n if Assigned(FSynEditPrint) and (FPageNumber < 1) then\r\n FPageNumber := 1;\r\n if Assigned(FOnPreviewPage) then\r\n FOnPreviewPage(Self, FPageNumber);\r\n Invalidate;\r\nend;\r\n\r\nprocedure TSynEditPrintPreview.Print;\r\nbegin\r\n if Assigned(FSynEditPrint) then begin\r\n FSynEditPrint.Print;\r\n UpdatePreview;\r\n end;\r\nend;\r\n\r\nfunction TSynEditPrintPreview.GetPageCount: Integer;\r\nbegin\r\n Result := SynEditPrint.PageCount;\r\nend;\r\n\r\nend.\r\n" }, { "path": "External/SynEdit/Source/SynEditPrintTypes.pas", "content": "{-------------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: SynEditPrintTypes.pas, released 2000-06-01.\r\n\r\nThe Initial Author of the Original Code is Morten J. Skovrup.\r\nPortions written by Morten J. Skovrup are copyright 2000 Morten J. Skovrup.\r\nUnicode translation by Mal Hrz.\r\nAll Rights Reserved.\r\n\r\nContributors to the SynEdit project are listed in the Contributors.txt file.\r\n\r\nAlternatively, the contents of this file may be used under the terms of the\r\nGNU General Public License Version 2 or later (the \"GPL\"), in which case\r\nthe provisions of the GPL are applicable instead of those above.\r\nIf you wish to allow use of your version of this file only under the terms\r\nof the GPL and not to allow others to use your version of this file\r\nunder the MPL, indicate your decision by deleting the provisions above and\r\nreplace them with the notice and other provisions required by the GPL.\r\nIf you do not delete the provisions above, a recipient may use your version\r\nof this file under either the MPL or the GPL.\r\n\r\n$Id: SynEditPrintTypes.pas,v 1.4.2.3 2008/09/14 16:24:59 maelh Exp $\r\n\r\nYou may retrieve the latest version of this file at the SynEdit home page,\r\nlocated at http://SynEdit.SourceForge.net\r\n\r\nKnown Issues:\r\n Wrapping across page boundaries is not supported\r\n-------------------------------------------------------------------------------}\r\n\r\n\r\n{-------------------------------------------------------------------------------\r\nCONTENTS:\r\n Misc types and procedures used in printing and previewing\r\n-------------------------------------------------------------------------------}\r\n\r\n\r\n{$IFNDEF QSYNEDITPRINTTYPES}\r\nunit SynEditPrintTypes;\r\n{$ENDIF}\r\n\r\ninterface\r\n\r\nuses\r\n{$IFDEF SYN_CLX}\r\n QSynUnicode,\r\n{$ELSE}\r\n SynUnicode,\r\n{$ENDIF}\r\n Classes, SysUtils;\r\n\r\nconst\r\n DefLeft = 25; //Default left margin [mm]\r\n DefRight = 15; //Default right margin [mm]\r\n DefTop = 25; //Default top margin [mm]\r\n DefBottom = 25; //Default bottom margin [mm]\r\n DefHeader = 15; //Default margin from top of paper to bottom of header [mm]\r\n DefFooter = 15; //Default margin from top of footer to bottom of paper [mm]\r\n DefLeftHFTextIndent = 2; //Default Header/footer indent from left margin [mm]\r\n DefRightHFTextIndent = 2; //Default Header/footer indent from right margin [mm]\r\n DefHFInternalMargin = 0.5; //Default Internal margin between Header/footer text and lines [mm]\r\n DefGutter = 0; //Default Binding gutter - added to left or right margin [mm]\r\ntype\r\n//Frame around header/footer\r\n TFrameType = (ftLine, ftBox, ftShaded);\r\n TFrameTypes = set of TFrameType;\r\n//Margin units (internally is allways used [mm])\r\n TUnitSystem = (usMM, usCM, usInch, muThousandthsOfInches);\r\n//Print status events\r\n TSynPrintStatus = (psBegin, psNewPage, psEnd);\r\n TPrintStatusEvent = procedure(Sender: TObject; Status: TSynPrintStatus;\r\n PageNumber: Integer; var Abort: Boolean) of object;\r\n//Event raised when a line is printed (can be used to generate Table of Contents)\r\n TPrintLineEvent = procedure(Sender: TObject; LineNumber, PageNumber: Integer) of object;\r\ntype\r\n TWrapPos = class\r\n public\r\n Index: Integer;\r\n end;\r\n\r\nfunction IntToRoman(Value: Integer): string;\r\n\r\n// TODO: BreakChars is ANSI only but SynEditPrint only uses Ansi chars and should be rewritten to use WordWrap of SynEdit anyway\r\nfunction WrapTextEx(const Line: UnicodeString; BreakChars: TSysCharSet;\r\n MaxCol: Integer; AList: TList): Boolean;\r\n\r\nimplementation\r\n\r\n//Returns wrapping positions in AList.\r\nfunction WrapTextEx(const Line: UnicodeString; BreakChars: TSysCharSet;\r\n MaxCol: Integer; AList: TList): Boolean;\r\nvar\r\n WrapPos: TWrapPos;\r\n Pos, PreviousPos: Integer;\r\n Found: Boolean;\r\nbegin\r\n if Length(Line) <= MaxCol then\r\n begin\r\n Result := True;\r\n Exit;\r\n end;\r\n\r\n Result := False;\r\n Pos := 1;\r\n PreviousPos := 0;\r\n WrapPos := TWrapPos.Create;\r\n while Pos <= Length(Line) do\r\n begin\r\n Found := (Pos - PreviousPos > MaxCol) and (WrapPos.Index <> 0);\r\n if not Found and (Line[Pos] <= High(Char)) and CharInSet(Char(Line[Pos]), BreakChars) then // We found a possible break\r\n WrapPos.Index := Pos;\r\n\r\n if Found then\r\n begin\r\n Result := True;\r\n AList.Add(WrapPos);\r\n PreviousPos := WrapPos.Index;\r\n\r\n // If more wraps needed and not end of line then a new wrap is created\r\n if ((Length(Line) - PreviousPos) > MaxCol) and (Pos < Length(Line)) then\r\n WrapPos := TWrapPos.Create\r\n else\r\n Break;\r\n end;\r\n Pos := Pos + 1;\r\n end;\r\n\r\n if (AList.Count = 0) or (AList.Last <> WrapPos) then\r\n WrapPos.Free;\r\nend;\r\n\r\n//Integer to Roman - copied from SWAG\r\nfunction IntToRoman(Value: Integer): string;\r\nbegin\r\n Result := '';\r\n while Value >= 1000 do begin\r\n Result := Result + 'M';\r\n Value := Value - 1000;\r\n end;\r\n\r\n if Value >= 900 then\r\n begin\r\n Result := Result + 'CM';\r\n Value := Value - 900;\r\n end;\r\n\r\n while Value >= 500 do\r\n begin\r\n Result := Result + 'D';\r\n Value := Value - 500;\r\n end;\r\n\r\n if Value >= 400 then\r\n begin\r\n Result := Result + 'CD';\r\n Value := Value - 400;\r\n end;\r\n\r\n while Value >= 100 do\r\n begin\r\n Result := Result + 'C';\r\n Value := Value - 100;\r\n end;\r\n\r\n if Value >= 90 then\r\n begin\r\n Result := Result + 'XC';\r\n Value := Value - 90;\r\n end;\r\n\r\n while Value >= 50 do\r\n begin\r\n Result := Result + 'L';\r\n Value := Value - 50;\r\n end;\r\n\r\n if Value >= 40 then\r\n begin\r\n Result := Result + 'XL';\r\n Value := Value - 40;\r\n end;\r\n\r\n while Value >= 10 do\r\n begin\r\n Result := Result + 'X';\r\n Value := Value - 10;\r\n end;\r\n\r\n if Value >= 9 then\r\n begin\r\n Result := Result + 'IX';\r\n Value := Value - 9;\r\n end;\r\n\r\n while Value >= 5 do\r\n begin\r\n Result := Result + 'V';\r\n Value := Value - 5;\r\n end;\r\n\r\n if Value >= 4 then\r\n begin\r\n Result := Result + 'IV';\r\n Value := Value - 4;\r\n end;\r\n\r\n while Value > 0 do\r\n begin\r\n Result := Result + 'I';\r\n Dec(Value);\r\n end;\r\nend;\r\n\r\nend.\r\n\r\n" }, { "path": "External/SynEdit/Source/SynEditPrinterInfo.pas", "content": "{-------------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: SynEditPrinterInfo.pas, released 2000-06-01.\r\n\r\nThe Initial Author of the Original Code is Morten J. Skovrup.\r\nPortions written by Morten J. Skovrup are copyright 2000 Morten J. Skovrup.\r\nAll Rights Reserved.\r\n\r\nContributors to the SynEdit project are listed in the Contributors.txt file.\r\n\r\nAlternatively, the contents of this file may be used under the terms of the\r\nGNU General Public License Version 2 or later (the \"GPL\"), in which case\r\nthe provisions of the GPL are applicable instead of those above.\r\nIf you wish to allow use of your version of this file only under the terms\r\nof the GPL and not to allow others to use your version of this file\r\nunder the MPL, indicate your decision by deleting the provisions above and\r\nreplace them with the notice and other provisions required by the GPL.\r\nIf you do not delete the provisions above, a recipient may use your version\r\nof this file under either the MPL or the GPL.\r\n\r\n$Id: SynEditPrinterInfo.pas,v 1.4.2.2 2005/10/18 01:43:23 etrusco Exp $\r\n\r\nYou may retrieve the latest version of this file at the SynEdit home page,\r\nlocated at http://SynEdit.SourceForge.net\r\n\r\nKnown Issues:\r\n-------------------------------------------------------------------------------}\r\n\r\n\r\n{-------------------------------------------------------------------------------\r\nCONTENTS:\r\n Class retrieving info about selected printer and paper size.\r\n-------------------------------------------------------------------------------}\r\n\r\n{$IFNDEF QSYNEDITPRINTERINFO}\r\nunit SynEditPrinterInfo;\r\n{$ENDIF}\r\n\r\n{$I SynEdit.inc}\r\n\r\ninterface\r\n\r\nuses\r\n{$IFDEF SYN_CLX}\r\n Qt,\r\n QPrinters;\r\n{$ELSE}\r\n Windows,\r\n Printers;\r\n{$ENDIF}\r\n\r\ntype\r\n //Printer info class - getting dimensions of paper\r\n TSynEditPrinterInfo = class\r\n private\r\n FPhysicalWidth: Integer;\r\n FPhysicalHeight: Integer;\r\n FPrintableWidth: Integer;\r\n FPrintableHeight: Integer;\r\n FLeftGutter: Integer;\r\n FRightGutter: Integer;\r\n FTopGutter: Integer;\r\n FBottomGutter: Integer;\r\n FXPixPrInch: Integer;\r\n FYPixPrInch: Integer;\r\n FXPixPrmm: Single;\r\n FYPixPrmm: Single;\r\n FIsUpdated: Boolean;\r\n procedure FillDefault;\r\n function GetBottomGutter: Integer;\r\n function GetLeftGutter: Integer;\r\n function GetPhysicalHeight: Integer;\r\n function GetPhysicalWidth: Integer;\r\n function GetPrintableHeight: Integer;\r\n function GetPrintableWidth: Integer;\r\n function GetRightGutter: Integer;\r\n function GetTopGutter: Integer;\r\n function GetXPixPrInch: Integer;\r\n function GetYPixPrInch: Integer;\r\n function GetXPixPrmm: Single;\r\n function GetYPixPrmm: Single;\r\n public\r\n procedure UpdatePrinter;\r\n function PixFromLeft(mmValue: Double): Integer;\r\n function PixFromRight(mmValue: Double): Integer;\r\n function PixFromTop(mmValue: Double): Integer;\r\n function PixFromBottom(mmValue: Double): Integer;\r\n property PhysicalWidth: Integer read GetPhysicalWidth;\r\n property PhysicalHeight: Integer read GetPhysicalHeight;\r\n property PrintableWidth: Integer read GetPrintableWidth;\r\n property PrintableHeight: Integer read GetPrintableHeight;\r\n property LeftGutter: Integer read GetLeftGutter;\r\n property RightGutter: Integer read GetRightGutter;\r\n property TopGutter: Integer read GetTopGutter;\r\n property BottomGutter: Integer read GetBottomGutter;\r\n property XPixPrInch: Integer read GetXPixPrInch;\r\n property YPixPrInch: Integer read GetYPixPrInch;\r\n property XPixPrmm: Single read GetXPixPrmm;\r\n property YPixPrmm: Single read GetYPixPrmm;\r\n end;\r\n\r\nimplementation\r\n\r\n{ TSynEditPrinterInfo }\r\n\r\nfunction TSynEditPrinterInfo.PixFromBottom(mmValue: Double): Integer;\r\nbegin\r\n if not FIsUpdated then\r\n UpdatePrinter;\r\n Result := Round(mmValue * FYPixPrmm - FBottomGutter);\r\nend;\r\n\r\nfunction TSynEditPrinterInfo.PixFromLeft(mmValue: Double): Integer;\r\nbegin\r\n if not FIsUpdated then\r\n UpdatePrinter;\r\n Result := Round(mmValue * FXPixPrmm - FLeftGutter);\r\nend;\r\n\r\nfunction TSynEditPrinterInfo.PixFromRight(mmValue: Double): Integer;\r\nbegin\r\n if not FIsUpdated then\r\n UpdatePrinter;\r\n Result := Round(mmValue * FXPixPrmm - FRightGutter);\r\nend;\r\n\r\nfunction TSynEditPrinterInfo.PixFromTop(mmValue: Double): Integer;\r\nbegin\r\n if not FIsUpdated then\r\n UpdatePrinter;\r\n Result := Round(mmValue * FYPixPrmm - FTopGutter);\r\nend;\r\n\r\nprocedure TSynEditPrinterInfo.FillDefault;\r\n{In case of no printers installed this information is used\r\n (I think it's taken from a HP LaserJet III with A4 paper)}\r\nbegin\r\n FPhysicalWidth := 2481;\r\n FPhysicalHeight := 3507;\r\n FPrintableWidth := 2358;\r\n FPrintableHeight := 3407;\r\n FLeftGutter := 65;\r\n FRightGutter := 58;\r\n FTopGutter := 50;\r\n FBottomGutter := 50;\r\n FXPixPrInch := 300;\r\n FYPixPrInch := 300;\r\n FXPixPrmm := FXPixPrInch / 25.4;\r\n FYPixPrmm := FYPixPrInch / 25.4;\r\nend;\r\n\r\nfunction TSynEditPrinterInfo.GetBottomGutter: Integer;\r\nbegin\r\n if not FIsUpdated then\r\n UpdatePrinter;\r\n Result := FBottomGutter;\r\nend;\r\n\r\nfunction TSynEditPrinterInfo.GetLeftGutter: Integer;\r\nbegin\r\n if not FIsUpdated then\r\n UpdatePrinter;\r\n Result := FLeftGutter;\r\nend;\r\n\r\nfunction TSynEditPrinterInfo.GetPhysicalHeight: Integer;\r\nbegin\r\n if not FIsUpdated then\r\n UpdatePrinter;\r\n Result := FPhysicalHeight;\r\nend;\r\n\r\nfunction TSynEditPrinterInfo.GetPhysicalWidth: Integer;\r\nbegin\r\n if not FIsUpdated then\r\n UpdatePrinter;\r\n Result := FPhysicalWidth;\r\nend;\r\n\r\nfunction TSynEditPrinterInfo.GetPrintableHeight: Integer;\r\nbegin\r\n if not FIsUpdated then\r\n UpdatePrinter;\r\n Result := FPrintableHeight;\r\nend;\r\n\r\nfunction TSynEditPrinterInfo.GetPrintableWidth: Integer;\r\nbegin\r\n if not FIsUpdated then\r\n UpdatePrinter;\r\n Result := FPrintableWidth;\r\nend;\r\n\r\nfunction TSynEditPrinterInfo.GetRightGutter: Integer;\r\nbegin\r\n if not FIsUpdated then\r\n UpdatePrinter;\r\n Result := FRightGutter;\r\nend;\r\n\r\nfunction TSynEditPrinterInfo.GetTopGutter: Integer;\r\nbegin\r\n if not FIsUpdated then\r\n UpdatePrinter;\r\n Result := FTopGutter;\r\nend;\r\n\r\nfunction TSynEditPrinterInfo.GetXPixPrInch: Integer;\r\nbegin\r\n if not FIsUpdated then\r\n UpdatePrinter;\r\n Result := FXPixPrInch;\r\nend;\r\n\r\nfunction TSynEditPrinterInfo.GetXPixPrmm: Single;\r\nbegin\r\n if not FIsUpdated then\r\n UpdatePrinter;\r\n Result := FXPixPrmm;\r\nend;\r\n\r\nfunction TSynEditPrinterInfo.GetYPixPrInch: Integer;\r\nbegin\r\n if not FIsUpdated then\r\n UpdatePrinter;\r\n Result := FYPixPrInch;\r\nend;\r\n\r\nfunction TSynEditPrinterInfo.GetYPixPrmm: Single;\r\nbegin\r\n if not FIsUpdated then\r\n UpdatePrinter;\r\n Result := FYPixPrmm;\r\nend;\r\n\r\nprocedure TSynEditPrinterInfo.UpdatePrinter;\r\nbegin\r\n FIsUpdated := True;\r\n Printer.Refresh;\r\n if Printer.Printers.Count <= 0 then\r\n begin\r\n FillDefault;\r\n Exit;\r\n end;\r\n{$IFNDEF SYN_CLX}\r\n FPhysicalWidth := GetDeviceCaps(Printer.Handle, Windows.PhysicalWidth);\r\n FPhysicalHeight := GetDeviceCaps(Printer.Handle, Windows.PhysicalHeight);\r\n{$ENDIF}\r\n FPrintableWidth := Printer.PageWidth; {or GetDeviceCaps(Printer.Handle, HorzRes);}\r\n FPrintableHeight := Printer.PageHeight; {or GetDeviceCaps(Printer.Handle, VertRes);}\r\n{$IFNDEF SYN_CLX}\r\n FLeftGutter := GetDeviceCaps(Printer.Handle, PhysicalOffsetX);\r\n FTopGutter := GetDeviceCaps(Printer.Handle, PhysicalOffsetY);\r\n{$ENDIF}\r\n FRightGutter := FPhysicalWidth - FPrintableWidth - FLeftGutter;\r\n FBottomGutter := FPhysicalHeight - FPrintableHeight - FTopGutter;\r\n{$IFNDEF SYN_CLX}\r\n FXPixPrInch := GetDeviceCaps(Printer.Handle, LogPixelsX);\r\n FYPixPrInch := GetDeviceCaps(Printer.Handle, LogPixelsY);\r\n{$ENDIF}\r\n FXPixPrmm := FXPixPrInch / 25.4;\r\n FYPixPrmm := FYPixPrInch / 25.4;\r\nend;\r\n\r\nend.\r\n\r\n" }, { "path": "External/SynEdit/Source/SynEditPropertyReg.pas", "content": "{-------------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: SynEditPropertyReg.pas, released 2000-04-07.\r\nThe Original Code is based on mwEditPropertyReg.pas, part of the\r\nmwEdit component suite.\r\nUnicode translation by Mal Hrz.\r\nAll Rights Reserved.\r\n\r\nContributors to the SynEdit and mwEdit projects are listed in the\r\nContributors.txt file.\r\n\r\nAlternatively, the contents of this file may be used under the terms of the\r\nGNU General Public License Version 2 or later (the \"GPL\"), in which case\r\nthe provisions of the GPL are applicable instead of those above.\r\nIf you wish to allow use of your version of this file only under the terms\r\nof the GPL and not to allow others to use your version of this file\r\nunder the MPL, indicate your decision by deleting the provisions above and\r\nreplace them with the notice and other provisions required by the GPL.\r\nIf you do not delete the provisions above, a recipient may use your version\r\nof this file under either the MPL or the GPL.\r\n\r\n$Id: SynEditPropertyReg.pas,v 1.17.2.6 2008/09/14 16:24:59 maelh Exp $\r\n\r\nYou may retrieve the latest version of this file at the SynEdit home page,\r\nlocated at http://SynEdit.SourceForge.net\r\n\r\nKnown Issues:\r\n-------------------------------------------------------------------------------}\r\n\r\n{$IFNDEF QSYNEDITPROPERTYREG}\r\nunit SynEditPropertyReg;\r\n{$ENDIF}\r\n\r\n{$I SynEdit.inc}\r\n\r\ninterface\r\n\r\nuses\r\n{$IFDEF SYN_COMPILER_6_UP}\r\n DesignIntf,\r\n DesignEditors,\r\n {$IFDEF SYN_KYLIX}\r\n ClxEditors,\r\n ClxStrEdit,\r\n {$ELSE}\r\n VCLEditors,\r\n StrEdit,\r\n {$ENDIF}\r\n{$ELSE}\r\n DsgnIntf,\r\n StrEdit,\r\n{$ENDIF}\r\n{$IFDEF SYN_CLX}\r\n QSynUnicode,\r\n{$ELSE}\r\n SynUnicode,\r\n{$ENDIF}\r\n{$IFDEF USE_TNT_DESIGNTIME_SUPPORT}\r\n TntClasses,\r\n TntStrEdit_Design,\r\n{$ENDIF}\r\n Classes;\r\n\r\ntype\r\n{$IFDEF USE_TNT_DESIGNTIME_SUPPORT}\r\n // Wrapper around TUnicodeStringListProperty to enable the TNT property editor to\r\n // handle TUnicodeStrings\r\n TSynUnicodeStringListProperty = class(TWideStringListProperty)\r\n private\r\n FUnicodeStrings: TUnicodeStrings;\r\n FTntStrings: TTntStrings;\r\n protected\r\n function GetStrings: TTntStrings; override;\r\n procedure SetStrings(const Value: TTntStrings); override;\r\n public\r\n{$IFDEF SYN_COMPILER_6_UP}\r\n constructor Create(const ADesigner: IDesigner; APropCount: Integer); override;\r\n{$ELSE}\r\n constructor Create(const ADesigner: IFormDesigner; APropCount: Integer); override;\r\n{$ENDIF}\r\n destructor Destroy; override;\r\n end;\r\n{$ENDIF}\r\n\r\n TSynEditFontProperty = class(TFontProperty)\r\n public\r\n procedure Edit; override;\r\n end;\r\n\r\n TSynEditCommandProperty = class(TIntegerProperty)\r\n public\r\n procedure Edit; override;\r\n function GetAttributes: TPropertyAttributes; override;\r\n function GetValue: string; override;\r\n procedure GetValues(Proc: TGetStrProc); override;\r\n procedure SetValue(const Value: string); override;\r\n end;\r\n\r\n TSynEditKeystrokesProperty = class(TClassProperty)\r\n public\r\n procedure Edit; override;\r\n function GetAttributes: TPropertyAttributes; override;\r\n end;\r\n\r\n TSynEditPrintMarginsProperty = class(TClassProperty)\r\n public\r\n procedure Edit; override;\r\n function GetAttributes: TPropertyAttributes; override;\r\n end;\r\n\r\n TAutoCorrectionProperty = class(TPropertyEditor)\r\n public\r\n procedure Edit; override;\r\n function GetAttributes: TPropertyAttributes; override;\r\n function GetValue:string; override;\r\n end;\r\n\r\n TSynAutoCorrectComponentEditor = class(TDefaultEditor)\r\n procedure Edit; override;\r\n procedure ExecuteVerb(Index: Integer); override;\r\n function GetVerb(Index: Integer): string; override;\r\n function GetVerbCount: Integer; override;\r\n end;\r\n\r\nprocedure Register;\r\n\r\nimplementation\r\n\r\nuses\r\n{$IFDEF SYN_CLX}\r\n QDialogs,\r\n QForms,\r\n QGraphics,\r\n QControls,\r\n QSynEditKeyCmds,\r\n QSynEditKeyCmdsEditor,\r\n QSynEdit,\r\n QSynEditPrint,\r\n QSynEditPrintMargins,\r\n QSynEditPrintMarginsDialog,\r\n QSynCompletionProposal,\r\n QSynMacroRecorder,\r\n QSynAutoCorrect,\r\n QSynAutoCorrectEditor,\r\n{$ELSE}\r\n Dialogs,\r\n Forms,\r\n Graphics,\r\n Controls,\r\n SynEditKeyCmds,\r\n SynEditKeyCmdsEditor,\r\n SynEdit,\r\n SynEditPrint,\r\n SynEditPrintMargins,\r\n SynEditPrintMarginsDialog,\r\n SynCompletionProposal,\r\n SynMacroRecorder,\r\n SynAutoCorrect,\r\n SynAutoCorrectEditor,\r\n{$ENDIF}\r\n SysUtils;\r\n\r\n{$IFDEF USE_TNT_DESIGNTIME_SUPPORT}\r\n\r\n{ TSynUnicodeStringListProperty }\r\n\r\n{$IFDEF SYN_COMPILER_6_UP}\r\nconstructor TSynUnicodeStringListProperty.Create(const ADesigner: IDesigner; APropCount: Integer);\r\n{$ELSE}\r\nconstructor TSynUnicodeStringListProperty.Create(const ADesigner: IFormDesigner; APropCount: Integer);\r\n{$ENDIF}\r\nbegin\r\n inherited;\r\n FUnicodeStrings := TUnicodeStringList.Create;\r\n FTntStrings := TTntStringList.Create;\r\nend;\r\n\r\ndestructor TSynUnicodeStringListProperty.Destroy;\r\nbegin\r\n FTntStrings.Free;\r\n FUnicodeStrings.Free;\r\n inherited;\r\nend;\r\n\r\nfunction TSynUnicodeStringListProperty.GetStrings: TTntStrings;\r\nvar\r\n UnicodeStrings: TUnicodeStrings;\r\n i: Integer;\r\nbegin\r\n UnicodeStrings := TUnicodeStrings(GetOrdValue);\r\n \r\n FTntStrings.Clear;\r\n FTntStrings.BeginUpdate;\r\n try\r\n for i := 0 to UnicodeStrings.Count - 1 do\r\n FTntStrings.AddObject(UnicodeStrings[i], UnicodeStrings.Objects[i]);\r\n finally\r\n FTntStrings.EndUpdate;\r\n end;\r\n Result := FTntStrings;\r\nend;\r\n\r\nprocedure TSynUnicodeStringListProperty.SetStrings(const Value: TTntStrings);\r\nvar\r\n i: Integer;\r\nbegin\r\n FUnicodeStrings.Clear;\r\n FUnicodeStrings.BeginUpdate;\r\n try\r\n for i := 0 to Value.Count - 1 do\r\n FUnicodeStrings.AddObject(Value[I], Value.Objects[I]);\r\n finally\r\n FUnicodeStrings.EndUpdate;\r\n end;\r\n SetOrdValue(Longint(FUnicodeStrings));\r\nend;\r\n{$ENDIF}\r\n\r\n\r\n{ TSynEditFontProperty }\r\n\r\nprocedure TSynEditFontProperty.Edit;\r\nconst\r\n { context ids for the Font editor }\r\n hcDFontEditor = 25000;\r\nvar\r\n FontDialog: TFontDialog;\r\nbegin\r\n FontDialog := TFontDialog.Create(Application);\r\n try\r\n FontDialog.Font := TFont(GetOrdValue);\r\n FontDialog.HelpContext := hcDFontEditor;\r\n {$IFDEF SYN_CLX}\r\n {$ELSE}\r\n FontDialog.Options := FontDialog.Options + [fdShowHelp, fdForceFontExist,\r\n fdFixedPitchOnly];\r\n {$ENDIF}\r\n if FontDialog.Execute then\r\n SetOrdValue(Longint(FontDialog.Font));\r\n finally\r\n FontDialog.Free;\r\n end;\r\nend;\r\n\r\n{ TSynEditCommandProperty }\r\n\r\nprocedure TSynEditCommandProperty.Edit;\r\nbegin\r\n ShowMessage('I''m thinking that this will show a dialog that has a list'#13#10+\r\n 'of all editor commands and a description of them to choose from.');\r\nend;\r\n\r\nfunction TSynEditCommandProperty.GetAttributes: TPropertyAttributes;\r\nbegin\r\n Result := [paMultiSelect, paDialog, paValueList, paRevertable];\r\nend;\r\n\r\nfunction TSynEditCommandProperty.GetValue: string;\r\nbegin\r\n Result := EditorCommandToCodeString(TSynEditorCommand(GetOrdValue));\r\nend;\r\n\r\nprocedure TSynEditCommandProperty.GetValues(Proc: TGetStrProc);\r\nbegin\r\n GetEditorCommandValues(Proc);\r\nend;\r\n\r\nprocedure TSynEditCommandProperty.SetValue(const Value: string);\r\nvar\r\n NewValue: longint;\r\nbegin\r\n if IdentToEditorCommand(Value, NewValue) then\r\n SetOrdValue(NewValue)\r\n else\r\n inherited SetValue(Value);\r\nend;\r\n\r\n{ TSynEditKeystrokesProperty }\r\n\r\nprocedure TSynEditKeystrokesProperty.Edit;\r\nvar\r\n Dlg: TSynEditKeystrokesEditorForm;\r\nbegin\r\n Application.CreateForm(TSynEditKeystrokesEditorForm, Dlg);\r\n try\r\n Dlg.Caption := Self.GetName;\r\n Dlg.Keystrokes := TSynEditKeystrokes(GetOrdValue);\r\n if Dlg.ShowModal = mrOk then\r\n begin\r\n { SetOrdValue will operate on all selected propertiy values }\r\n SetOrdValue(Longint(Dlg.Keystrokes));\r\n Modified;\r\n end;\r\n finally\r\n Dlg.Free;\r\n end;\r\nend;\r\n\r\nfunction TSynEditKeystrokesProperty.GetAttributes: TPropertyAttributes;\r\nbegin\r\n Result := [paDialog, paReadOnly];\r\nend;\r\n\r\n{ TSynEditPrintMarginsProperty }\r\n\r\nprocedure TSynEditPrintMarginsProperty.Edit;\r\nvar\r\n SynEditPrintMarginsDlg: TSynEditPrintMarginsDlg;\r\nbegin\r\n SynEditPrintMarginsDlg := TSynEditPrintMarginsDlg.Create(nil);\r\n try\r\n SynEditPrintMarginsDlg.SetMargins(TSynEditPrintMargins(GetOrdValue));\r\n if SynEditPrintMarginsDlg.ShowModal = mrOk then\r\n SynEditPrintMarginsDlg.GetMargins(TSynEditPrintMargins(GetOrdValue));\r\n finally\r\n SynEditPrintMarginsDlg.Free;\r\n end;\r\nend;\r\n\r\nfunction TSynEditPrintMarginsProperty.GetAttributes: TPropertyAttributes;\r\nbegin\r\n Result := [paDialog, paSubProperties, paReadOnly, paSortList];\r\nend; \r\n\r\nprocedure TSynAutoCorrectComponentEditor.Edit;\r\nvar\r\n frmAutoCorrectEditor: TfrmAutoCorrectEditor;\r\nbegin\r\n frmAutoCorrectEditor := TfrmAutoCorrectEditor.Create(Application);\r\n try\r\n frmAutoCorrectEditor.SynAutoCorrect := TSynAutoCorrect(Component);\r\n frmAutoCorrectEditor.ShowModal;\r\n finally\r\n frmAutoCorrectEditor.Free;\r\n end;\r\n Designer.Modified;\r\nend;\r\n\r\nprocedure TSynAutoCorrectComponentEditor.ExecuteVerb(Index: Integer);\r\nbegin\r\n case Index of\r\n 0: Edit;\r\n end;\r\nend;\r\n\r\nfunction TSynAutoCorrectComponentEditor.GetVerb(Index: Integer): string;\r\nbegin\r\n case Index of\r\n 0: Result := '&Edit...';\r\n end;\r\nend;\r\n\r\nfunction TSynAutoCorrectComponentEditor.GetVerbCount: Integer;\r\nbegin\r\n Result := 1;\r\nend;\r\n\r\nprocedure TAutoCorrectionProperty.Edit;\r\nvar\r\n frmAutoCorrectEditor: TfrmAutoCorrectEditor;\r\nbegin\r\n frmAutoCorrectEditor := TfrmAutoCorrectEditor.Create(Application);\r\n try\r\n frmAutoCorrectEditor.SynAutoCorrect := TSynAutoCorrect(GetComponent(0));\r\n frmAutoCorrectEditor.ShowModal;\r\n finally\r\n frmAutoCorrectEditor.Free;\r\n end;\r\n Designer.Modified;\r\nend;\r\n\r\nfunction TAutoCorrectionProperty.GetAttributes: TPropertyAttributes;\r\nbegin\r\n GetAttributes := [paDialog, paReadOnly];\r\nend;\r\n\r\nfunction TAutoCorrectionProperty.GetValue: string;\r\nbegin\r\n GetValue := '(AutoCorrections)';\r\nend; \r\n\r\n\r\n{ Register }\r\n\r\nprocedure Register;\r\nbegin\r\n// TODO: Delphi 2005 has native Unicode property editors, we should use them (but I don't have D2005 to test)\r\n{$IFDEF USE_TNT_DESIGNTIME_SUPPORT}\r\n // Troy Wolbrink added my (Mal Hrz) WideChar property editor to\r\n // TntUnicodeStringProperty_Design.pas.\r\n // As it is registered there, no need to do it a second time here.\r\n // However as he uses TTntStrings and we use TUnicodeStrings, we need\r\n // a wrapper to do the \"translation\".\r\n RegisterPropertyEditor(TypeInfo(TUnicodeStrings), nil,\r\n '', TSynUnicodeStringListProperty);\r\n{$ELSE}\r\n RegisterPropertyEditor(TypeInfo(WideChar), nil,\r\n '', TCharProperty);\r\n RegisterPropertyEditor(TypeInfo(TUnicodeStrings), nil,\r\n '', TStringListProperty);\r\n{$ENDIF}\r\n\r\n RegisterPropertyEditor(TypeInfo(TFont), TCustomSynEdit,\r\n 'Font', TSynEditFontProperty);\r\n RegisterPropertyEditor(TypeInfo(TSynEditorCommand), nil,\r\n '', TSynEditCommandProperty);\r\n RegisterPropertyEditor(TypeInfo(TSynEditKeystrokes), nil,\r\n '', TSynEditKeystrokesProperty);\r\n RegisterPropertyEditor(TypeInfo(TSynEditPrintMargins), TPersistent,\r\n '', TSynEditPrintMarginsProperty);\r\n RegisterPropertyEditor(TypeInfo(TStrings), TSynAutoCorrect,\r\n 'Items', TAutoCorrectionProperty);\r\n RegisterComponentEditor(TSynAutoCorrect, TSynAutoCorrectComponentEditor);\r\n {$IFDEF SYN_DELPHI_6_UP} // TODO: shouldn't that be COMPILER_6_UP instead?\r\n RegisterPropertyEditor(TypeInfo(TShortCut), TSynCompletionProposal, '',\r\n TShortCutProperty);\r\n RegisterPropertyEditor(TypeInfo(TShortCut), TSynAutoComplete, '',\r\n TShortCutProperty);\r\n RegisterPropertyEditor(TypeInfo(TShortCut), TSynMacroRecorder, '',\r\n TShortCutProperty);\r\n {$ENDIF}\r\nend;\r\n\r\nend.\r\n\r\n" }, { "path": "External/SynEdit/Source/SynEditPythonBehaviour.pas", "content": "{-------------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: SynEditPythonBehaviour.pas, released 2000-06-23.\r\nThe Original Code is based on odPythonBehaviour.pas by Olivier Deckmyn, part\r\nof the mwEdit component suite.\r\nUnicode translation by Mal Hrz.\r\n\r\nContributors to the SynEdit and mwEdit projects are listed in the\r\nContributors.txt file.\r\n\r\nAlternatively, the contents of this file may be used under the terms of the\r\nGNU General Public License Version 2 or later (the \"GPL\"), in which case\r\nthe provisions of the GPL are applicable instead of those above.\r\nIf you wish to allow use of your version of this file only under the terms\r\nof the GPL and not to allow others to use your version of this file\r\nunder the MPL, indicate your decision by deleting the provisions above and\r\nreplace them with the notice and other provisions required by the GPL.\r\nIf you do not delete the provisions above, a recipient may use your version\r\nof this file under either the MPL or the GPL.\r\n\r\n$Id: SynEditPythonBehaviour.pas,v 1.5.2.3 2008/09/14 16:24:59 maelh Exp $\r\n\r\nYou may retrieve the latest version of this file at the SynEdit home page,\r\nlocated at http://SynEdit.SourceForge.net\r\n\r\nKnown Issues:\r\n-------------------------------------------------------------------------------}\r\n{\r\n@abstract(Provides a component which implements editing rules to apply to a Python source file)\r\n@author(Olivier Deckmyn, converted to SynEdit by David Muir )\r\n@created(1999-10-17)\r\n@lastmod(May 19, 2000)\r\nThe SynEditPythonBehaviour unit provides a simple component implements editing rules to apply\r\nto a python source file. Python has a unusual way to mark blocks (like begin/end in pascal) : it\r\nuses indentation. So the rule is after a \":\" and a line break, we have to indent once.\r\n}\r\n{$IFNDEF QSYNEDITPYTHONBEHAVIOUR}\r\nunit SynEditPythonBehaviour;\r\n{$ENDIF}\r\n\r\n{$I SynEdit.inc}\r\n\r\ninterface\r\n\r\nuses\r\n {$IFDEF SYN_CLX}\r\n Qt, QGraphics, QControls, QForms, QDialogs,\r\n QSynEdit,\r\n QSynEditKeyCmds,\r\n QSynUnicode, \r\n {$ELSE}\r\n Windows, Messages, Graphics, Controls, Forms, Dialogs,\r\n SynEdit,\r\n SynEditKeyCmds,\r\n SynUnicode, \r\n {$ENDIF}\r\n SysUtils,\r\n Classes;\r\n\r\ntype\r\n TSynEditPythonBehaviour = class(TComponent)\r\n private\r\n FEditor: TSynEdit;\r\n fIndent: integer;\r\n protected\r\n procedure SetEditor(Value: TSynEdit); virtual;\r\n procedure doProcessUserCommand(Sender: TObject; AfterProcessing: boolean;\r\n var Handled: boolean; var Command: TSynEditorCommand;\r\n var AChar: WideChar; Data: Pointer; HandlerData: Pointer); virtual;\r\n public\r\n constructor Create(aOwner: TComponent); override;\r\n published\r\n property Editor: TSynEdit read FEditor write SetEditor;\r\n property Indent: integer read fIndent write fIndent default 4;\r\n end;\r\n\r\nimplementation\r\n\r\nuses\r\n{$IFDEF SYN_CLX}\r\n QSynEditStrConst;\r\n{$ELSE}\r\n SynEditStrConst;\r\n{$ENDIF}\r\n\r\nprocedure TSynEditPythonBehaviour.SetEditor(Value: TSynEdit);\r\nbegin\r\n if FEditor <> Value then\r\n begin\r\n if (Editor <> nil) and not (csDesigning in ComponentState) then\r\n Editor.UnregisterCommandHandler(doProcessUserCommand);\r\n // Set the new editor\r\n FEditor := Value;\r\n if (Editor <> nil) and not (csDesigning in ComponentState) then\r\n Editor.RegisterCommandHandler(doProcessUserCommand, nil);\r\n end;\r\nend; \r\n\r\nprocedure TSynEditPythonBehaviour.doProcessUserCommand(Sender: TObject;\r\n AfterProcessing: boolean; var Handled: boolean;\r\n var Command: TSynEditorCommand; var AChar: WideChar; Data: Pointer;\r\n HandlerData: pointer);\r\nvar\r\n iEditor: TCustomSynEdit;\r\n iPrevLine: UnicodeString;\r\n cSpace: integer;\r\nbegin\r\n if (Command = ecLineBreak) and AfterProcessing then\r\n begin\r\n iEditor := Sender as TCustomSynEdit;\r\n { CaretY should never be lesser than 2 right after ecLineBreak, so there's\r\n no need for a check }\r\n iPrevLine := WideTrimRight(iEditor.Lines[iEditor.CaretY - 2]);\r\n if (iPrevLine <> '') and (iPrevLine[Length(iPrevLine)] = ':') then\r\n begin\r\n iEditor.UndoList.BeginBlock;\r\n try\r\n for cSpace := 1 to Indent do\r\n iEditor.ExecuteCommand(ecChar, #32, nil);\r\n finally\r\n iEditor.UndoList.EndBlock;\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\nconstructor TSynEditPythonBehaviour.Create(aOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n fIndent := 4;\r\nend;\r\n\r\nend.\r\n\r\n" }, { "path": "External/SynEdit/Source/SynEditReg.pas", "content": "{-------------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: SynEditReg.pas, released 2000-04-07.\r\nAll Rights Reserved.\r\n\r\nContributors to the SynEdit and mwEdit projects are listed in the\r\nContributors.txt file.\r\n\r\nAlternatively, the contents of this file may be used under the terms of the\r\nGNU General Public License Version 2 or later (the \"GPL\"), in which case\r\nthe provisions of the GPL are applicable instead of those above.\r\nIf you wish to allow use of your version of this file only under the terms\r\nof the GPL and not to allow others to use your version of this file\r\nunder the MPL, indicate your decision by deleting the provisions above and\r\nreplace them with the notice and other provisions required by the GPL.\r\nIf you do not delete the provisions above, a recipient may use your version\r\nof this file under either the MPL or the GPL.\r\n\r\n$Id: SynEditReg.pas,v 1.33.2.2 2004/10/18 15:25:00 maelh Exp $\r\n\r\nYou may retrieve the latest version of this file at the SynEdit home page,\r\nlocated at http://SynEdit.SourceForge.net\r\n\r\nKnown Issues:\r\n-------------------------------------------------------------------------------}\r\n\r\n{$IFNDEF QSYNEDITREG}\r\nunit SynEditReg;\r\n{$ENDIF}\r\n\r\n{$I SynEdit.inc}\r\n\r\ninterface\r\n\r\nuses\r\n{$IFDEF SYN_CLX}\r\n // SynEdit components\r\n QSynEdit,\r\n QSynMemo,\r\n {$IFNDEF SYN_DELPHI_PE}\r\n QSynDBEdit,\r\n {$ENDIF}\r\n QSynEditStrConst,\r\n QSynEditHighlighter,\r\n QSynEditMiscClasses,\r\n QSynEditPlugins,\r\n QSynEditExport,\r\n QSynExportHTML,\r\n QSynExportRTF,\r\n QSynExportTeX,\r\n QSynHighlighterMulti,\r\n QSynCompletionProposal,\r\n QSynEditPythonBehaviour,\r\n QSynEditPrint,\r\n QSynEditPrintPreview,\r\n QSynMacroRecorder,\r\n QSynAutoCorrect,\r\n QSynEditSearch,\r\n QSynEditRegexSearch,\r\n QSynHighlighterManager,\r\n QSynEditOptionsDialog,\r\n QSynHighlighterADSP21xx,\r\n QSynHighlighterAsm,\r\n QSynHighlighterAWK,\r\n QSynHighlighterBaan,\r\n QSynHighlighterBat,\r\n QSynHighlighterCAC,\r\n QSynHighlighterCache,\r\n QSynHighlighterCobol,\r\n QSynHighlighterCpp,\r\n QSynHighlighterCS,\r\n QSynHighlighterCss,\r\n QSynHighlighterDfm,\r\n QSynHighlighterDml,\r\n QSynHighlighterDOT,\r\n QSynHighlighterEiffel,\r\n QSynHighlighterFortran,\r\n QSynHighlighterFoxpro,\r\n QSynHighlighterGalaxy,\r\n QSynHighlighterGeneral,\r\n QSynHighlighterHaskell,\r\n QSynHighlighterHC11,\r\n QSynHighlighterHP48,\r\n QSynHighlighterHtml,\r\n QSynHighlighterIni,\r\n QSynHighlighterInno,\r\n QSynHighlighterJava,\r\n QSynHighlighterJScript,\r\n QSynHighlighterKix,\r\n QSynHighlighterModelica,\r\n QSynHighlighterM3,\r\n QSynHighlighterPas,\r\n QSynHighlighterPerl,\r\n QSynHighlighterPHP,\r\n QSynHighlighterProgress,\r\n QSynHighlighterPython,\r\n QSynHighlighterRC,\r\n QSynHighlighterRuby,\r\n QSynHighlighterSml,\r\n QSynHighlighterSQL,\r\n QSynHighlighterTclTk,\r\n QSynHighlighterTeX,\r\n QSynHighlighterUNIXShellScript,\r\n QSynHighlighterURI,\r\n QSynHighlighterVB,\r\n QSynHighlighterVBScript,\r\n QSynHighlighterVrml97,\r\n QSynHighlighterGWS,\r\n QSynHighlighterCPM,\r\n QSynHighlighterSDD,\r\n QSynHighlighterXML,\r\n QSynHighlighterMsg,\r\n QSynHighlighterIDL,\r\n QSynHighlighterUnreal,\r\n QSynHighlighterST,\r\n QSynHighlighterLDraw,\r\n QSynURIOpener,\r\n{$ELSE}\r\n // SynEdit components\r\n SynEdit,\r\n SynMemo,\r\n {$IFNDEF SYN_DELPHI_PE}\r\n SynDBEdit,\r\n {$ENDIF}\r\n SynEditStrConst,\r\n SynEditHighlighter,\r\n SynEditMiscClasses,\r\n SynEditPlugins,\r\n SynEditExport,\r\n SynExportHTML,\r\n SynExportRTF,\r\n SynExportTeX, \r\n SynHighlighterMulti,\r\n SynCompletionProposal,\r\n SynEditPythonBehaviour,\r\n SynEditPrint,\r\n SynEditPrintPreview,\r\n SynMacroRecorder,\r\n SynAutoCorrect,\r\n SynEditSearch,\r\n SynEditRegexSearch,\r\n {$IFDEF SYN_COMPILER_4_UP}\r\n SynHighlighterManager,\r\n {$ENDIF}\r\n SynEditOptionsDialog,\r\n SynHighlighterADSP21xx,\r\n SynHighlighterAsm,\r\n SynHighlighterAWK,\r\n SynHighlighterBaan, \r\n SynHighlighterBat,\r\n SynHighlighterCAC,\r\n SynHighlighterCache,\r\n SynHighlighterCobol, \r\n SynHighlighterCpp,\r\n SynHighlighterCS,\r\n SynHighlighterCss,\r\n SynHighlighterDfm,\r\n SynHighlighterDml,\r\n SynHighlighterDOT,\r\n {$ifdef SYN_DELPHI_2009_UP}\r\n SynHighlighterDWS,\r\n {$endif}\r\n SynHighlighterEiffel,\r\n SynHighlighterFortran,\r\n SynHighlighterFoxpro,\r\n SynHighlighterGalaxy,\r\n SynHighlighterGeneral, \r\n SynHighlighterHaskell,\r\n SynHighlighterHC11,\r\n SynHighlighterHP48, \r\n SynHighlighterHtml,\r\n SynHighlighterIni,\r\n SynHighlighterInno,\r\n SynHighlighterJava,\r\n SynHighlighterJScript,\r\n SynHighlighterKix,\r\n SynHighlighterModelica,\r\n SynHighlighterM3, \r\n SynHighlighterPas,\r\n SynHighlighterPerl, \r\n SynHighlighterPHP,\r\n SynHighlighterProgress, \r\n SynHighlighterPython,\r\n SynHighlighterRC,\r\n SynHighlighterRuby, \r\n SynHighlighterSml,\r\n SynHighlighterSQL, \r\n SynHighlighterTclTk,\r\n SynHighlighterTeX,\r\n SynHighlighterUNIXShellScript,\r\n SynHighlighterURI,\r\n SynHighlighterVB,\r\n SynHighlighterVBScript,\r\n SynHighlighterVrml97, \r\n SynHighlighterGWS,\r\n SynHighlighterCPM, \r\n SynHighlighterSDD,\r\n SynHighlighterXML,\r\n SynHighlighterMsg, \r\n SynHighlighterIDL,\r\n SynHighlighterUnreal,\r\n SynHighlighterST,\r\n SynHighlighterLDraw, \r\n SynURIOpener,\r\n{$ENDIF}\r\n Classes;\r\n\r\nprocedure Register;\r\n\r\nimplementation\r\n\r\nprocedure Register;\r\nbegin\r\n// SynEdit main components\r\n RegisterComponents(SYNS_ComponentsPage, [TSynEdit, TSynMemo]);\r\n\r\n{$IFNDEF SYN_DELPHI_PE}\r\n RegisterComponents(SYNS_ComponentsPage, [TDBSynEdit]);\r\n{$ENDIF}\r\n\r\n{$IFDEF SYN_COMPILER_6_UP}\r\n GroupDescendentsWith(TSynCustomHighlighter, TSynEdit);\r\n GroupDescendentsWith(TSynEditSearchCustom, TSynEdit);\r\n GroupDescendentsWith(TSynCustomExporter, TSynEdit);\r\n GroupDescendentsWith(TSynMultiSyn, TSynEdit);\r\n GroupDescendentsWith(TSynBaseCompletionProposal, TSynEdit);\r\n GroupDescendentsWith(TSynAutoComplete, TSynEdit);\r\n GroupDescendentsWith(TAbstractSynPlugin, TSynEdit);\r\n GroupDescendentsWith(TCustomSynAutoCorrect, TSynEdit);\r\n GroupDescendentsWith(TSynEditPrint, TSynEdit);\r\n GroupDescendentsWith(TSynEditPrintPreview, TSynEdit);\r\n GroupDescendentsWith(TSynEditPythonBehaviour, TSynEdit);\r\n GroupDescendentsWith(TSynHighlighterManager, TSynEdit);\r\n GroupDescendentsWith(TSynEditOptionsDialog, TSynEdit);\r\n GroupDescendentsWith(TSynURIOpener, TSynEdit);\r\n{$ENDIF}\r\n\r\n// SynEdit extra components\r\n RegisterComponents(SYNS_ComponentsPage, [TSynExporterHTML, TSynExporterRTF,\r\n TSynExporterTeX, TSynEditPythonBehaviour, TSynMultiSyn,\r\n TSynCompletionProposal, TSynAutoComplete, TSynMacroRecorder,\r\n TSynEditPrint, TSynEditPrintPreview, TSynAutoCorrect,\r\n TSynEditSearch, TSynEditRegexSearch, TSynEditOptionsDialog, TSynURIOpener]);\r\n{$IFDEF SYN_COMPILER_4_UP}\r\n RegisterComponents(SYNS_ComponentsPage, [TSynHighlighterManager]);\r\n{$ENDIF}\r\n\r\n// SynEdit highlighters\r\n RegisterComponents(SYNS_HighlightersPage, [\r\n //classic\r\n TSynCppSyn, TSynEiffelSyn, TSynFortranSyn, TSynGeneralSyn, TSynJavaSyn,\r\n TSynM3Syn, TSynPasSyn, TSynVBSyn, TSynCobolSyn, TSynCSSyn,\r\n // internet\r\n TSynCssSyn, TSynHTMLSyn, TSynJScriptSyn, TSynPHPSyn, TSynVBScriptSyn,\r\n TSynXMLSyn, TSynVrml97Syn,\r\n //interpreted\r\n TSynAWKSyn, TSynBATSyn,\r\n {$ifdef SYN_DELPHI_2009_UP}\r\n TSynDWSSyn,\r\n {$endif}\r\n TSynKixSyn, TSynPerlSyn, TSynPythonSyn,\r\n TSynTclTkSyn, TSynGWScriptSyn, TSynRubySyn, TSynUNIXShellScriptSyn,\r\n //database\r\n TSynCACSyn, TSynCacheSyn, TSynFoxproSyn, TSynSQLSyn, TSynSDDSyn,\r\n //assembler\r\n TSynADSP21xxSyn, TSynAsmSyn, TSynHC11Syn, TSynHP48Syn, TSynSTSyn,\r\n //data modeling\r\n TSynDmlSyn, TSynModelicaSyn, TSynSMLSyn,\r\n //data\r\n TSynDfmSyn, TSynIniSyn, TSynInnoSyn,\r\n // other\r\n TSynBaanSyn, TSynGalaxySyn, TSynProgressSyn, TSynMsgSyn, \r\n TSynIdlSyn, TSynUnrealSyn, TSynCPMSyn, TSynTeXSyn,\r\n TSynHaskellSyn, TSynLDRSyn, TSynURISyn, TSynDOTSyn, TSynRCSyn\r\n ]);\r\nend;\r\n\r\nend.\r\n" }, { "path": "External/SynEdit/Source/SynEditRegexSearch.pas", "content": "{-------------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: SynEditRegexSearch.pas, released 2002-07-26.\r\n\r\nOriginal Code by Eduardo Mauro, Gerald Nunn and Flvio Etrusco.\r\nUnicode translation by Mal Hrz.\r\nAll Rights Reserved.\r\n\r\nContributors to the SynEdit project are listed in the Contributors.txt file.\r\n\r\nAlternatively, the contents of this file may be used under the terms of the\r\nGNU General Public License Version 2 or later (the \"GPL\"), in which case\r\nthe provisions of the GPL are applicable instead of those above.\r\nIf you wish to allow use of your version of this file only under the terms\r\nof the GPL and not to allow others to use your version of this file\r\nunder the MPL, indicate your decision by deleting the provisions above and\r\nreplace them with the notice and other provisions required by the GPL.\r\nIf you do not delete the provisions above, a recipient may use your version\r\nof this file under either the MPL or the GPL.\r\n\r\n$Id: SynEditRegexSearch.pas,v 1.5.2.2 2008/09/14 16:24:59 maelh Exp $\r\n\r\nYou may retrieve the latest version of this file at the SynEdit home page,\r\nlocated at http://SynEdit.SourceForge.net\r\n\r\nKnown Issues:\r\n-------------------------------------------------------------------------------}\r\n\r\n{$IFNDEF QSYNEDITREGEXSEARCH}\r\nunit SynEditRegexSearch;\r\n{$ENDIF}\r\n\r\n{$I SynEdit.inc}\r\n\r\ninterface\r\n\r\nuses\r\n{$IFDEF SYN_CLX}\r\n QSynEditTypes,\r\n QSynRegExpr,\r\n QSynEditMiscClasses,\r\n QSynUnicode,\r\n{$ELSE}\r\n SynEditTypes,\r\n SynRegExpr,\r\n SynEditMiscClasses,\r\n SynUnicode,\r\n{$ENDIF}\r\n Classes;\r\n\r\ntype\r\n TSynEditRegexSearch = class(TSynEditSearchCustom)\r\n private\r\n fRegex: TRegExpr;\r\n fPositions: TList;\r\n fLengths: TList;\r\n protected\r\n function GetPattern: UnicodeString; override;\r\n procedure SetPattern(const Value: UnicodeString); override;\r\n procedure SetOptions(const Value: TSynSearchOptions); override;\r\n function GetLength(Index: Integer): Integer; override;\r\n function GetResult(Index: Integer): Integer; override;\r\n function GetResultCount: Integer; override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n function FindAll(const NewText: UnicodeString): Integer; override;\r\n function Replace(const aOccurrence, aReplacement: UnicodeString): UnicodeString; override;\r\n end;\r\n\r\nimplementation\r\n\r\nuses\r\n{$IFDEF SYN_CLX}\r\n QConsts;\r\n{$ELSE}\r\n Consts;\r\n{$ENDIF}\r\n\r\n{ TSynEditRegexSearch }\r\n\r\nconstructor TSynEditRegexSearch.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n fRegex := TRegExpr.Create;\r\n fPositions := TList.Create;\r\n fLengths := TList.Create;\r\nend;\r\n\r\ndestructor TSynEditRegexSearch.Destroy;\r\nbegin\r\n inherited;\r\n fRegex.Free;\r\n fPositions.Free;\r\n fLengths.Free;\r\nend;\r\n\r\nfunction TSynEditRegexSearch.FindAll(const NewText: UnicodeString): Integer;\r\n\r\n procedure AddResult(const aPos, aLength: Integer);\r\n begin\r\n fPositions.Add(Pointer(aPos));\r\n fLengths.Add(Pointer(aLength));\r\n end;\r\n\r\nbegin\r\n fPositions.Clear;\r\n fLengths.Clear;\r\n if fRegex.Exec(NewText) then\r\n begin\r\n AddResult(fRegex.MatchPos[0], fRegex.MatchLen[0]);\r\n Result := 1;\r\n while fRegex.ExecNext do\r\n begin\r\n AddResult(fRegex.MatchPos[0], fRegex.MatchLen[0]);\r\n Inc(Result);\r\n end;\r\n end\r\n else\r\n Result := 0;\r\nend;\r\n\r\nfunction TSynEditRegexSearch.Replace(const aOccurrence, aReplacement: UnicodeString): UnicodeString;\r\nbegin\r\n Result := fRegex.Replace(aOccurrence, aReplacement, True);\r\nend; \r\n\r\nfunction TSynEditRegexSearch.GetLength(Index: Integer): Integer;\r\nbegin\r\n Result := Integer(fLengths[Index]);\r\nend;\r\n\r\nfunction TSynEditRegexSearch.GetPattern: UnicodeString;\r\nbegin\r\n Result := fRegex.Expression;\r\nend;\r\n\r\nfunction TSynEditRegexSearch.GetResult(Index: Integer): Integer;\r\nbegin\r\n Result := Integer(fPositions[Index]);\r\nend;\r\n\r\nfunction TSynEditRegexSearch.GetResultCount: Integer;\r\nbegin\r\n Result := fPositions.Count;\r\nend;\r\n\r\nprocedure TSynEditRegexSearch.SetOptions(const Value: TSynSearchOptions);\r\nbegin\r\n fRegex.ModifierI := not(ssoMatchCase in Value);\r\nend;\r\n\r\nprocedure TSynEditRegexSearch.SetPattern(const Value: UnicodeString);\r\nbegin\r\n fRegex.Expression := Value;\r\nend;\r\n\r\nend.\r\n\r\n" }, { "path": "External/SynEdit/Source/SynEditSearch.pas", "content": "{-------------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: SynEditSearch.pas, released 2000-04-07.\r\n\r\nThe Original Code is based on the mwEditSearch.pas file from the mwEdit\r\ncomponent suite by Martin Waldenburg and other developers.\r\nPortions created by Martin Waldenburg are Copyright 1999 Martin Waldenburg.\r\nUnicode translation by Mal Hrz.\r\nAll Rights Reserved.\r\n\r\nContributors to the SynEdit project are listed in the Contributors.txt file.\r\n\r\nAlternatively, the contents of this file may be used under the terms of the\r\nGNU General Public License Version 2 or later (the \"GPL\"), in which case\r\nthe provisions of the GPL are applicable instead of those above.\r\nIf you wish to allow use of your version of this file only under the terms\r\nof the GPL and not to allow others to use your version of this file\r\nunder the MPL, indicate your decision by deleting the provisions above and\r\nreplace them with the notice and other provisions required by the GPL.\r\nIf you do not delete the provisions above, a recipient may use your version\r\nof this file under either the MPL or the GPL.\r\n\r\n$Id: SynEditSearch.pas,v 1.12.2.6 2009/09/29 00:16:46 maelh Exp $\r\n\r\nYou may retrieve the latest version of this file at the SynEdit home page,\r\nlocated at http://SynEdit.SourceForge.net\r\n\r\nKnown Issues:\r\n-------------------------------------------------------------------------------}\r\n\r\n{$IFNDEF QSYNEDITSEARCH}\r\nunit SynEditSearch;\r\n{$ENDIF}\r\n\r\n{$I SynEdit.inc}\r\n\r\ninterface\r\n\r\nuses\r\n{$IFDEF SYN_CLX}\r\n QSynEditTypes,\r\n QSynEditMiscClasses,\r\n QSynUnicode, \r\n{$ELSE}\r\n SynEditTypes,\r\n SynEditMiscClasses,\r\n SynUnicode,\r\n{$ENDIF}\r\n Classes;\r\n\r\ntype\r\n TSynEditSearch = class(TSynEditSearchCustom)\r\n private\r\n Run: PWideChar;\r\n Origin: PWideChar;\r\n TheEnd: PWideChar;\r\n Pat, CasedPat: UnicodeString;\r\n fCount: Integer;\r\n fTextLen: Integer;\r\n Look_At: Integer;\r\n PatLen, PatLenSucc: Integer;\r\n Shift: array[WideChar] of Integer;\r\n fCaseSensitive: Boolean;\r\n fWhole: Boolean;\r\n fResults: TList;\r\n fShiftInitialized: Boolean;\r\n FTextToSearch: UnicodeString;\r\n function GetFinished: Boolean;\r\n procedure InitShiftTable;\r\n procedure SetCaseSensitive(const Value: Boolean);\r\n protected\r\n function TestWholeWord: Boolean;\r\n procedure SetPattern(const Value: UnicodeString); override;\r\n function GetPattern: UnicodeString; override;\r\n function GetLength(Index: Integer): Integer; override;\r\n function GetResult(Index: Integer): Integer; override;\r\n function GetResultCount: Integer; override;\r\n procedure SetOptions(const Value: TSynSearchOptions); override;\r\n public\r\n constructor Create(aOwner: TComponent); override;\r\n destructor Destroy; override;\r\n function FindAll(const NewText: UnicodeString): Integer; override;\r\n function Replace(const aOccurrence, aReplacement: UnicodeString): UnicodeString; override;\r\n function FindFirst(const NewText: UnicodeString): Integer;\r\n procedure FixResults(First, Delta: Integer);\r\n function Next: Integer;\r\n property Count: Integer read fCount write fCount;\r\n property Finished: Boolean read GetFinished;\r\n property Pattern read CasedPat;\r\n property CaseSensitive: Boolean read fCaseSensitive write SetCaseSensitive;\r\n property Whole: Boolean read fWhole write fWhole;\r\n end;\r\n\r\nimplementation\r\n\r\nuses\r\n{$IFDEF SYN_CLX}\r\n Types,\r\n{$ELSE}\r\n Windows,\r\n{$ENDIF}\r\n SysUtils;\r\n\r\nconstructor TSynEditSearch.Create(aOwner: TComponent);\r\nbegin\r\n inherited;\r\n fResults := TList.Create;\r\nend;\r\n\r\nfunction TSynEditSearch.GetFinished: Boolean;\r\nbegin\r\n Result := (Run >= TheEnd) or (PatLen >= fTextLen);\r\nend;\r\n\r\nfunction TSynEditSearch.GetResult(Index: Integer): Integer;\r\nbegin\r\n Result := 0;\r\n if (Index >= 0) and (Index < fResults.Count) then\r\n Result := Integer(fResults[Index]);\r\nend;\r\n\r\nfunction TSynEditSearch.GetResultCount: Integer;\r\nbegin\r\n Result := fResults.Count;\r\nend;\r\n\r\nprocedure TSynEditSearch.FixResults(First, Delta: Integer);\r\nvar\r\n i: Integer;\r\nbegin\r\n if (Delta <> 0) and (fResults.Count > 0) then begin\r\n i := Pred(fResults.Count);\r\n while i >= 0 do begin\r\n if Integer(fResults[i]) <= First then break;\r\n fResults[i] := pointer(Integer(fResults[i]) - Delta);\r\n Dec(i);\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TSynEditSearch.InitShiftTable;\r\nvar\r\n C: WideChar;\r\n I: Integer;\r\nbegin\r\n PatLen := Length(Pat);\r\n if Patlen = 0 then raise Exception.Create('Pattern is empty');\r\n PatLenSucc := PatLen + 1;\r\n Look_At := 1;\r\n for C := Low(WideChar) to High(WideChar) do Shift[C] := PatLenSucc;\r\n for I := 1 to PatLen do Shift[Pat[I]] := PatLenSucc - I;\r\n while Look_at < PatLen do\r\n begin\r\n if Pat[PatLen] = Pat[PatLen - Look_at] then break;\r\n inc(Look_at);\r\n end;\r\n fShiftInitialized := True;\r\nend; \r\n\r\n// TODO: would be more intelligent to use IsWordBreakChar for SynEdit\r\nfunction IsWordBreakChar(C: WideChar): Boolean;\r\nbegin\r\n case C of\r\n #0..#32, '.', ',', ';', ':', '\"', '''', '', '`', '', '^', '!', '?', '&',\r\n '$', '@', '', '%', '#', '~', '[', ']', '(', ')', '{', '}', '<', '>',\r\n '-', '=', '+', '*', '/', '\\', '|':\r\n Result := True;\r\n else\r\n Result := False;\r\n end;\r\nend;\r\n\r\nfunction TSynEditSearch.TestWholeWord: Boolean;\r\nvar\r\n Test: PWideChar;\r\nbegin\r\n Test := Run - PatLen;\r\n\r\n Result := ((Test < Origin) or IsWordBreakChar(Test[0])) and\r\n ((Run >= TheEnd) or IsWordBreakChar(Run[1]));\r\nend;\r\n\r\nfunction TSynEditSearch.Next: Integer;\r\nvar\r\n I: Integer;\r\n J: PWideChar;\r\nbegin\r\n Result := 0;\r\n inc(Run, PatLen);\r\n while Run < TheEnd do\r\n begin\r\n if Pat[Patlen] <> Run^ then\r\n inc(Run, Shift[(Run + 1)^])\r\n else\r\n begin\r\n J := Run - PatLen + 1;\r\n I := 1;\r\n while Pat[I] = J^ do\r\n begin\r\n if I = PatLen then\r\n begin\r\n case fWhole of\r\n True: if not TestWholeWord then break;\r\n end;\r\n inc(fCount);\r\n Result := Run - Origin - Patlen + 2;\r\n exit;\r\n end;\r\n inc(I);\r\n inc(J);\r\n end;\r\n Inc(Run, Look_At);\r\n if Run >= TheEnd then\r\n break;\r\n Inc(Run, Shift[Run^] - 1);\r\n end;\r\n end;\r\nend;\r\n\r\ndestructor TSynEditSearch.Destroy;\r\nbegin\r\n fResults.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TSynEditSearch.SetPattern(const Value: UnicodeString);\r\nbegin\r\n if Pat <> Value then\r\n begin\r\n CasedPat := Value;\r\n if CaseSensitive then\r\n Pat := CasedPat\r\n else\r\n Pat := SynWideLowerCase(CasedPat);\r\n fShiftInitialized := False;\r\n end;\r\n fCount := 0;\r\nend;\r\n\r\nprocedure TSynEditSearch.SetCaseSensitive(const Value: Boolean);\r\nbegin\r\n if fCaseSensitive <> Value then\r\n begin\r\n fCaseSensitive := Value;\r\n if fCaseSensitive then\r\n Pat := CasedPat\r\n else\r\n Pat := SynWideLowerCase(CasedPat);\r\n fShiftInitialized := False;\r\n end;\r\nend;\r\n\r\nfunction TSynEditSearch.FindAll(const NewText: UnicodeString): Integer;\r\nvar\r\n Found: Integer;\r\nbegin\r\n // never shrink Capacity\r\n fResults.Count := 0;\r\n Found := FindFirst(NewText);\r\n while Found > 0 do\r\n begin\r\n fResults.Add(Pointer(Found));\r\n Found := Next;\r\n end;\r\n Result := fResults.Count;\r\nend;\r\n\r\nfunction TSynEditSearch.Replace(const aOccurrence, aReplacement: UnicodeString): UnicodeString;\r\nbegin\r\n Result := aReplacement;\r\nend; \r\n\r\nfunction TSynEditSearch.FindFirst(const NewText: UnicodeString): Integer;\r\nbegin\r\n if not fShiftInitialized then\r\n InitShiftTable;\r\n Result := 0;\r\n fTextLen := Length(NewText);\r\n if fTextLen >= PatLen then\r\n begin\r\n if CaseSensitive then\r\n FTextToSearch := NewText\r\n else\r\n FTextToSearch := SynWideLowerCase(NewText);\r\n Origin := PWideChar(FTextToSearch);\r\n TheEnd := Origin + fTextLen;\r\n Run := (Origin - 1);\r\n Result := Next;\r\n end;\r\nend;\r\n\r\nfunction TSynEditSearch.GetLength(Index: Integer): Integer;\r\nbegin\r\n Result := PatLen; \r\nend;\r\n\r\nfunction TSynEditSearch.GetPattern: UnicodeString;\r\nbegin\r\n Result := CasedPat; \r\nend;\r\n\r\nprocedure TSynEditSearch.SetOptions(const Value: TSynSearchOptions);\r\nbegin\r\n CaseSensitive := ssoMatchCase in Value;\r\n Whole := ssoWholeWord in Value;\r\nend;\r\n\r\nend.\r\n\r\n" }, { "path": "External/SynEdit/Source/SynEditStrConst.pas", "content": "{-------------------------------------------------------------------------------\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: SynEditStrConst.pas, released 2000-04-07.\r\nThe Original Code is based on mwLocalStr.pas by Michael Hieke, part of the\r\nmwEdit component suite.\r\nAll Rights Reserved.\r\n\r\nContributors to the SynEdit and mwEdit projects are listed in the\r\nContributors.txt file.\r\n\r\nAlternatively, the contents of this file may be used under the terms of the\r\nGNU General Public License Version 2 or later (the \"GPL\"), in which case\r\nthe provisions of the GPL are applicable instead of those above.\r\nIf you wish to allow use of your version of this file only under the terms\r\nof the GPL and not to allow others to use your version of this file\r\nunder the MPL, indicate your decision by deleting the provisions above and\r\nreplace them with the notice and other provisions required by the GPL.\r\nIf you do not delete the provisions above, a recipient may use your version\r\nof this file under either the MPL or the GPL.\r\n\r\n$Id: SynEditStrConst.pas,v 1.41.2.5 2009/01/06 16:26:01 maelh Exp $\r\n\r\nYou may retrieve the latest version of this file at the SynEdit home page,\r\nlocated at http://SynEdit.SourceForge.net\r\n\r\nKnown Issues:\r\n-------------------------------------------------------------------------------}\r\n\r\n{$IFNDEF QSynEditStrConst}\r\nunit SynEditStrConst;\r\n{$ENDIF}\r\n\r\n{$I SynEdit.inc}\r\n\r\ninterface\r\n\r\n// NOTE: this is design-time stuff, so no need to have it in stringtables\r\nconst\r\n SYNS_ComponentsPage = 'SynEdit';\r\n SYNS_HighlightersPage = 'SynEdit Highlighters';\r\n\r\n// NOTE: the following constants are used to store information to the registry,\r\n// INI files or XML files. For maximum compatibility only the chars\r\n// 'A'..'Z', 'a'..'z', '0'..'9', '_' and '-' are allowed!\r\n//\r\n// If you want translated/\"pretty\"/more detailed descriptions use the\r\n// resourcestrings, i.e. the \"friendly\" versions below.\r\n\r\n// constant names for highlighter attributes\r\n//\r\n//\r\nconst\r\n SYNS_AttrAreaAIdentifier = 'Area_A_Identifier';\r\n SYNS_AttrArrowHead = 'ArrowHead';\r\n SYNS_AttrAsm = 'Asm';\r\n SYNS_AttrAsmComment = 'AsmComment';\r\n SYNS_AttrAsmKey = 'AsmKey';\r\n SYNS_AttrAssembler = 'Assembler';\r\n SYNS_AttrAttribute = 'Attribute';\r\n SYNS_AttrAttributeName = 'AttributeName';\r\n SYNS_AttrAttributeValue = 'AttributeValue';\r\n SYNS_AttrBasicTypes = 'BasicTypes';\r\n SYNS_AttrBlock = 'Block';\r\n SYNS_AttrBoolean = 'Booleanvalue';\r\n SYNS_AttrBrackets = 'Brackets';\r\n SYNS_AttrCDATASection = 'CDATA-Section';\r\n SYNS_AttrCharacter = 'Character';\r\n SYNS_AttrClass = 'Class';\r\n SYNS_AttrColor = 'ColorValue';\r\n SYNS_AttrComment = 'Comment';\r\n SYNS_AttrCondition = 'Condition';\r\n SYNS_AttrConditionalComment = 'ConditionalComment';\r\n SYNS_AttrDataType = 'DataType';\r\n SYNS_AttrDebugLines = 'DebuggingLines';\r\n SYNS_AttrDefaultPackage = 'DefaultPackages';\r\n SYNS_AttrDelimitedIdentifier = 'DelimitedIdentifier';\r\n SYNS_AttrDir = 'Direction';\r\n SYNS_AttrDirections = 'Directions';\r\n SYNS_AttrDirective = 'Directive';\r\n SYNS_AttrDOCTYPESection = 'DOCTYPE-Section';\r\n SYNS_AttrDocumentation = 'Documentation';\r\n SYNS_AttrElementName = 'ElementName';\r\n SYNS_AttrEmbedSQL = 'EmbeddedSQL';\r\n SYNS_AttrEmbedText = 'EmbeddedText';\r\n SYNS_AttrEntityReference = 'EntityReference';\r\n SYNS_AttrEscapeAmpersand = 'EscapeAmpersand';\r\n SYNS_AttrEvent = 'Event';\r\n SYNS_AttrException = 'Exception';\r\n SYNS_AttrFirstTri = 'FirstTri';\r\n SYNS_AttrFloat = 'Float';\r\n SYNS_AttrForm = 'Form';\r\n SYNS_AttrFourthTri = 'FourthTri';\r\n SYNS_AttrFunction = 'Function';\r\n SYNS_AttrHexadecimal = 'Hexadecimal';\r\n SYNS_AttrIcon = 'IconReference';\r\n SYNS_AttrIdentifier = 'Identifier';\r\n SYNS_AttrIllegalChar = 'IllegalChar';\r\n SYNS_AttrInclude = 'Include';\r\n SYNS_AttrIndicator = 'IndicatorArea';\r\n SYNS_AttrIndirect = 'Indirect';\r\n SYNS_AttrInvalidSymbol = 'InvalidSymbol';\r\n SYNS_AttrInternalFunction = 'InternalFunction';\r\n SYNS_AttrKey = 'Key';\r\n SYNS_AttrLabel = 'Label';\r\n SYNS_AttrLace = 'Lace';\r\n SYNS_AttrLine = 'Line';\r\n SYNS_AttrMacro = 'Macro';\r\n SYNS_AttrMarker = 'Marker';\r\n SYNS_AttrMathMode = 'MathMode';\r\n SYNS_AttrMessage = 'Message';\r\n SYNS_AttrMiscellaneous = 'Miscellaneous';\r\n SYNS_AttrNamespaceAttrName = 'NamespaceAttributeName';\r\n SYNS_AttrNamespaceAttrValue = 'NamespaceAttributeValue';\r\n SYNS_AttrNonReservedKeyword = 'NonreservedKeyword';\r\n SYNS_AttrNull = 'Null';\r\n SYNS_AttrNumber = 'Number';\r\n SYNS_AttrOctal = 'Octal';\r\n SYNS_AttrOperator = 'Operator';\r\n SYNS_AttrOperatorAndSymbols = 'OperatorAndSymbols';\r\n SYNS_AttrOpLine = 'OpLine';\r\n SYNS_AttrOptions = 'Options';\r\n SYNS_AttrPath = 'PathName'; \r\n SYNS_AttrPLSQL = 'PLSQL-ReservedWord';\r\n SYNS_AttrPragma = 'Pragma';\r\n SYNS_AttrPredefined = 'Predefined';\r\n SYNS_AttrPreprocessor = 'Preprocessor';\r\n SYNS_AttrProcessingInstr = 'ProcessingInstruction';\r\n SYNS_AttrProperty = 'Property';\r\n SYNS_AttrQuad = 'Quad';\r\n SYNS_AttrQualifier = 'Qualifier';\r\n SYNS_AttrRegister = 'Register';\r\n SYNS_AttrReservedWord = 'ReservedWord';\r\n SYNS_AttrResultValue = 'ResultValue';\r\n SYNS_AttrRoundBracket = 'RoundBracket';\r\n SYNS_AttrRpl = 'Rpl';\r\n SYNS_AttrRplKey = 'Rpl-Key';\r\n SYNS_AttrRplComment = 'Rpl-Comment';\r\n SYNS_AttrSASM = 'SASM';\r\n SYNS_AttrSASMComment = 'SASM-Comment';\r\n SYNS_AttrSASMKey = 'SASM-Key';\r\n SYNS_AttrSecondReservedWord = 'SecondReservedWord';\r\n SYNS_AttrSecondTri = 'SecondTri';\r\n SYNS_AttrSection = 'Section';\r\n SYNS_AttrSequence = 'SequenceNumberArea';\r\n SYNS_AttrShape = 'Shape';\r\n SYNS_AttrSingleString = 'SingleQuotedString';\r\n SYNS_AttrSpace = 'Space';\r\n SYNS_AttrSpecialVariable = 'SpecialVariable';\r\n SYNS_AttrSQLKey = 'SQL-Keyword';\r\n SYNS_AttrSQLPlus = 'SQLPlus-Command';\r\n SYNS_AttrSquareBracket = 'SquareBracket';\r\n SYNS_AttrString = 'String';\r\n SYNS_AttrSymbol = 'Symbol';\r\n SYNS_AttrSyntaxError = 'SyntaxError';\r\n SYNS_AttrSystem = 'SystemFunctionsAndVariables';\r\n SYNS_AttrSystemValue = 'SystemValue';\r\n SYNS_AttrTagArea = 'TagArea';\r\n SYNS_AttrTableName = 'TableName';\r\n SYNS_AttrTerminator = 'Terminator';\r\n SYNS_AttrTeXCommand = 'TeX-Command';\r\n SYNS_AttrText = 'Text';\r\n SYNS_AttrTextMathMode = 'TextInMathMode';\r\n SYNS_AttrThirdTri = 'ThirdTri';\r\n SYNS_AttrTixKeyWords = 'Tix-Keywords';\r\n SYNS_AttrTriangle = 'Triangle';\r\n SYNS_AttrUndefinedProperty = 'UndefinedProperty';\r\n SYNS_AttrUnknownWord = 'UnknownWord';\r\n SYNS_AttrURI = 'URI';\r\n SYNS_AttrUser = 'UserFunctionsAndVariables';\r\n SYNS_AttrUserFunction = 'UserFunctions';\r\n SYNS_AttrValue = 'Value';\r\n SYNS_AttrVariable = 'Variable';\r\n SYNS_AttrVisitedURI = 'VisitedURI';\r\n SYNS_AttrVrmlAppearance = 'Vrml_Appearance';\r\n SYNS_AttrVrmlAttribute = 'Vrml_Attribute';\r\n SYNS_AttrVrmlDefinition = 'Vrml_Definition';\r\n SYNS_AttrVrmlEvent = 'Vrml_Event';\r\n SYNS_AttrVrmlGrouping = 'Vrml_Grouping';\r\n SYNS_AttrVrmlInterpolator = 'Vrml_Interpolator';\r\n SYNS_AttrVrmlLight = 'Vrml_Light';\r\n SYNS_AttrVrmlNode = 'Vrml_Node';\r\n SYNS_AttrVrmlParameter = 'Vrml_Parameter';\r\n SYNS_AttrVrmlProto = 'Vrml_Proto';\r\n SYNS_AttrVrmlSensor = 'Vrml_Sensor';\r\n SYNS_AttrVrmlShape = 'Vrml_Shape';\r\n SYNS_AttrVrmlShape_Hint = 'Vrml_Shape_Hint';\r\n SYNS_AttrVrmlTime_dependent = 'Vrml_Time_dependent';\r\n SYNS_AttrVrmlViewpoint = 'Vrml_Viewpoint';\r\n SYNS_AttrVrmlWorldInfo = 'Vrml_WorldInfo';\r\n SYNS_AttrWhitespace = 'Whitespace';\r\n SYNS_AttrWidgetWords = 'Widget-Keywords';\r\n SYNS_AttrX3DDocType = 'X3DDocType';\r\n SYNS_AttrX3DHeader = 'X3DHeader';\r\n\r\n // constant language names\r\n SYNS_LangHP48 = 'HP48';\r\n SYNS_LangCAClipper = 'CA-Clipper';\r\n SYNS_LangCPM = 'COAS_Product_Manager_Report';\r\n SYNS_LangCPP = 'CandCPlusPlus';\r\n SYNS_LangCS = 'CSharp';\r\n SYNS_LangJava = 'Java';\r\n SYNS_LangPerl = 'Perl';\r\n SYNS_LangBatch = 'MS-DOS_Batch';\r\n SYNS_LangDfm = 'BorlandForms';\r\n SYNS_LangAWK = 'AWK';\r\n SYNS_LangCORBAIDL = 'CORBA_IDL';\r\n SYNS_LangHTML = 'HTML';\r\n SYNS_LangVBSScript = 'MS-VBScript';\r\n SYNS_LangGalaxy = 'Galaxy';\r\n SYNS_LangGeneral = 'General';\r\n SYNS_LangPascal = 'ObjectPascal';\r\n SYNS_LangX86Asm = 'x86Assembly';\r\n SYNS_LangPython = 'Python';\r\n SYNS_LangTclTk = 'TclTk';\r\n SYNS_LangSQL = 'SQL';\r\n SYNS_LangGembase = 'Gembase';\r\n SYNS_LangINI = 'INI';\r\n SYNS_LangSML = 'StandardML';\r\n SYNS_LangVisualBASIC = 'VisualBasic';\r\n SYNS_LangADSP21xx = 'ADSP21xx';\r\n SYNS_LangPHP = 'PHP';\r\n SYNS_LangSybaseSQL = 'SybaseSQL';\r\n SYNS_LangGeneralMulti = 'General_Multi-Highlighter';\r\n SYNS_LangCache = 'CacheObjectScript';\r\n SYNS_LangCSS = 'CascadingStyleSheet';\r\n SYNS_LangJScript = 'JavaScript';\r\n SYNS_LangKIX = 'KiXtart';\r\n SYNS_LangBaan = 'Baan_4GL';\r\n SYNS_LangFoxpro = 'Foxpro';\r\n SYNS_LangFortran = 'Fortran';\r\n SYNS_Lang68HC11 = '68HC11_Assembler';\r\n SYNS_LangProgress = 'Progress';\r\n SYNS_LangInno = 'InnoSetupScript';\r\n SYNS_LangModelica = 'Modelica';\r\n SYNS_LangModula3 = 'Modula3';\r\n SYNS_LangSDD = 'SemantaDataDictionary';\r\n SYNS_LangXML = 'XML';\r\n SYNS_LangGWS = 'GW-TEL';\r\n SYNS_LangSynGenMsgfiles = 'SynGen_Msg';\r\n SYNS_LangUnreal = 'Unreal';\r\n SYNS_LangST = 'StructuredText';\r\n SYNS_LangCOBOL = 'COBOL';\r\n SYNS_LangTeX = 'TeX';\r\n SYNS_LangRC = 'Resource';\r\n SYNS_LangRuby = 'Ruby';\r\n SYNS_LangNameUNIXShellScript = 'UNIXShellScript';\r\n SYNS_LangHaskell = 'Haskell';\r\n SYNS_LangDOT = 'DOT_Graph_Drawing_Description_language';\r\n SYNS_LangEiffel = 'Eiffel';\r\n SYNS_LangLDraw = 'LEGO_LDraw';\r\n SYNS_LangUnknown = '';\r\n SYNS_LangURI = 'URI';\r\n SYNS_LangVrml97 = 'Vrml97';\r\n\r\nresourcestring\r\n SYNS_NoSearchEngineError = 'No search engine has been assigned';\r\n\r\n SYNS_Untitled = 'Untitled';\r\n\r\n // Friendly names for highlighter attributes\r\n SYNS_FriendlyAttrAreaAIdentifier = 'Area A Identifier';\r\n SYNS_FriendlyAttrArrowHead = 'ArrowHead';\r\n SYNS_FriendlyAttrAsm = 'Asm';\r\n SYNS_FriendlyAttrAsmComment = 'Asm Comment';\r\n SYNS_FriendlyAttrAsmKey = 'Asm Key';\r\n SYNS_FriendlyAttrAssembler = 'Assembler';\r\n SYNS_FriendlyAttrAttribute = 'Attribute';\r\n SYNS_FriendlyAttrAttributeName = 'Attribute Name';\r\n SYNS_FriendlyAttrAttributeValue = 'Attribute Value';\r\n SYNS_FriendlyAttrBasicTypes = 'Basic Types';\r\n SYNS_FriendlyAttrBlock = 'Block';\r\n SYNS_FriendlyAttrBoolean = 'Boolean value';\r\n SYNS_FriendlyAttrBrackets = 'Brackets';\r\n SYNS_FriendlyAttrCDATASection = 'CDATA Section';\r\n SYNS_FriendlyAttrCharacter = 'Character';\r\n SYNS_FriendlyAttrClass = 'Class';\r\n SYNS_FriendlyAttrColor = 'Color Value';\r\n SYNS_FriendlyAttrComment = 'Comment';\r\n SYNS_FriendlyAttrCondition = 'Condition';\r\n SYNS_FriendlyAttrConditionalComment = 'Conditional Comment';\r\n SYNS_FriendlyAttrDataType = 'Data Type';\r\n SYNS_FriendlyAttrDebugLines = 'Debugging Lines';\r\n SYNS_FriendlyAttrDefaultPackage = 'Default Packages';\r\n SYNS_FriendlyAttrDelimitedIdentifier = 'Delimited Identifier';\r\n SYNS_FriendlyAttrDir = 'Direction';\r\n SYNS_FriendlyAttrDirections = 'Directions';\r\n SYNS_FriendlyAttrDirective = 'Directive';\r\n SYNS_FriendlyAttrDOCTYPESection = 'DOCTYPE Section';\r\n SYNS_FriendlyAttrDocumentation = 'Documentation';\r\n SYNS_FriendlyAttrElementName = 'Element Name';\r\n SYNS_FriendlyAttrEmbedSQL = 'Embedded SQL';\r\n SYNS_FriendlyAttrEmbedText = 'Embedded Text';\r\n SYNS_FriendlyAttrEntityReference = 'Entity Reference';\r\n SYNS_FriendlyAttrEscapeAmpersand = 'Escape Ampersand';\r\n SYNS_FriendlyAttrEvent = 'Event';\r\n SYNS_FriendlyAttrException = 'Exception';\r\n SYNS_FriendlyAttrFirstTri = 'FirstTri';\r\n SYNS_FriendlyAttrFloat = 'Float';\r\n SYNS_FriendlyAttrForm = 'Form';\r\n SYNS_FriendlyAttrFourthTri = 'FourthTri';\r\n SYNS_FriendlyAttrFunction = 'Function';\r\n SYNS_FriendlyAttrHexadecimal = 'Hexadecimal';\r\n SYNS_FriendlyAttrIcon = 'Icon Reference';\r\n SYNS_FriendlyAttrIdentifier = 'Identifier';\r\n SYNS_FriendlyAttrIllegalChar = 'Illegal Char';\r\n SYNS_FriendlyAttrInclude = 'Include';\r\n SYNS_FriendlyAttrIndicator = 'Indicator Area';\r\n SYNS_FriendlyAttrIndirect = 'Indirect';\r\n SYNS_FriendlyAttrInvalidSymbol = 'Invalid Symbol';\r\n SYNS_FriendlyAttrInternalFunction = 'Internal Function';\r\n SYNS_FriendlyAttrKey = 'Key';\r\n SYNS_FriendlyAttrLabel = 'Label';\r\n SYNS_FriendlyAttrLace = 'Lace';\r\n SYNS_FriendlyAttrLine = 'Line';\r\n SYNS_FriendlyAttrMacro = 'Macro';\r\n SYNS_FriendlyAttrMarker = 'Marker';\r\n SYNS_FriendlyAttrMathMode = 'Math Mode';\r\n SYNS_FriendlyAttrMessage = 'Message';\r\n SYNS_FriendlyAttrMiscellaneous = 'Miscellaneous';\r\n SYNS_FriendlyAttrNamespaceAttrName = 'Namespace Attribute Name';\r\n SYNS_FriendlyAttrNamespaceAttrValue = 'Namespace Attribute Value';\r\n SYNS_FriendlyAttrNonReservedKeyword = 'Non-reserved Keyword';\r\n SYNS_FriendlyAttrNull = 'Null';\r\n SYNS_FriendlyAttrNumber = 'Number';\r\n SYNS_FriendlyAttrOctal = 'Octal';\r\n SYNS_FriendlyAttrOperator = 'Operator';\r\n SYNS_FriendlyAttrOperatorAndSymbols = 'Operator And Symbols';\r\n SYNS_FriendlyAttrOpLine = 'OpLine';\r\n SYNS_FriendlyAttrOptions = 'Options';\r\n SYNS_FriendlyAttrPath = 'Pathname'; \r\n SYNS_FriendlyAttrPLSQL = 'PL/SQL Reserved Word';\r\n SYNS_FriendlyAttrPragma = 'Pragma';\r\n SYNS_FriendlyAttrPredefined = 'Predefined';\r\n SYNS_FriendlyAttrPreprocessor = 'Preprocessor';\r\n SYNS_FriendlyAttrProcessingInstr = 'Processing Instruction';\r\n SYNS_FriendlyAttrProperty = 'Property';\r\n SYNS_FriendlyAttrQuad = 'Quad';\r\n SYNS_FriendlyAttrQualifier = 'Qualifier';\r\n SYNS_FriendlyAttrRegister = 'Register';\r\n SYNS_FriendlyAttrReservedWord = 'Reserved Word';\r\n SYNS_FriendlyAttrResultValue = 'Result Value';\r\n SYNS_FriendlyAttrRoundBracket = 'Round Bracket';\r\n SYNS_FriendlyAttrRpl = 'Rpl';\r\n SYNS_FriendlyAttrRplKey = 'Rpl Key';\r\n SYNS_FriendlyAttrRplComment = 'Rpl Comment';\r\n SYNS_FriendlyAttrSASM = 'SASM';\r\n SYNS_FriendlyAttrSASMComment = 'SASM Comment';\r\n SYNS_FriendlyAttrSASMKey = 'SASM Key';\r\n SYNS_FriendlyAttrSecondReservedWord = 'Second Reserved Word';\r\n SYNS_FriendlyAttrSecondTri = 'SecondTri';\r\n SYNS_FriendlyAttrSection = 'Section';\r\n SYNS_FriendlyAttrSequence = 'Sequence Number Area';\r\n SYNS_FriendlyAttrShape = 'Shape';\r\n SYNS_FriendlyAttrSingleString = 'Single Quoted String';\r\n SYNS_FriendlyAttrSpace = 'Space';\r\n SYNS_FriendlyAttrSpecialVariable = 'Special Variable';\r\n SYNS_FriendlyAttrSQLKey = 'SQL Keyword';\r\n SYNS_FriendlyAttrSQLPlus = 'SQL*Plus Command';\r\n SYNS_FriendlyAttrSquareBracket = 'Square Bracket';\r\n SYNS_FriendlyAttrString = 'String';\r\n SYNS_FriendlyAttrSymbol = 'Symbol';\r\n SYNS_FriendlyAttrSyntaxError = 'Syntax Error';\r\n SYNS_FriendlyAttrSystem = 'System Functions and Variables';\r\n SYNS_FriendlyAttrSystemValue = 'System Value';\r\n SYNS_FriendlyAttrTagArea = 'Tag Area';\r\n SYNS_FriendlyAttrTableName = 'Table Name';\r\n SYNS_FriendlyAttrTerminator = 'Terminator';\r\n SYNS_FriendlyAttrTeXCommand = 'TeX Command';\r\n SYNS_FriendlyAttrText = 'Text';\r\n SYNS_FriendlyAttrTextMathMode = 'Text in Math Mode';\r\n SYNS_FriendlyAttrThirdTri = 'ThirdTri';\r\n SYNS_FriendlyAttrTixKeyWords = 'Tix Keywords'; \r\n SYNS_FriendlyAttrTriangle = 'Triangle';\r\n SYNS_FriendlyAttrUndefinedProperty = 'Undefined Property';\r\n SYNS_FriendlyAttrUnknownWord = 'Unknown Word';\r\n SYNS_FriendlyAttrURI = 'URI';\r\n SYNS_FriendlyAttrUser = 'User Functions and Variables';\r\n SYNS_FriendlyAttrUserFunction = 'User Functions';\r\n SYNS_FriendlyAttrValue = 'Value';\r\n SYNS_FriendlyAttrVariable = 'Variable';\r\n SYNS_FriendlyAttrVisitedURI = 'Visited URI';\r\n SYNS_FriendlyAttrVrmlAppearance = 'Vrml_Appearance';\r\n SYNS_FriendlyAttrVrmlAttribute = 'Vrml_Attribute';\r\n SYNS_FriendlyAttrVrmlDefinition = 'Vrml_Definition';\r\n SYNS_FriendlyAttrVrmlEvent = 'Vrml_Event';\r\n SYNS_FriendlyAttrVrmlGrouping = 'Vrml_Grouping';\r\n SYNS_FriendlyAttrVrmlInterpolator = 'Vrml_Interpolator';\r\n SYNS_FriendlyAttrVrmlLight = 'Vrml_Light';\r\n SYNS_FriendlyAttrVrmlNode = 'Vrml_Node';\r\n SYNS_FriendlyAttrVrmlParameter = 'Vrml_Parameter';\r\n SYNS_FriendlyAttrVrmlProto = 'Vrml_Proto';\r\n SYNS_FriendlyAttrVrmlSensor = 'Vrml_Sensor';\r\n SYNS_FriendlyAttrVrmlShape = 'Vrml_Shape';\r\n SYNS_FriendlyAttrVrmlShape_Hint = 'Vrml_Shape_Hint';\r\n SYNS_FriendlyAttrVrmlTime_dependent = 'Vrml_Time_dependent';\r\n SYNS_FriendlyAttrVrmlViewpoint = 'Vrml_Viewpoint';\r\n SYNS_FriendlyAttrVrmlWorldInfo = 'Vrml_WorldInfo';\r\n SYNS_FriendlyAttrWhitespace = 'Whitespace';\r\n SYNS_FriendlyAttrWidgetWords = 'Widget Keywords'; \r\n SYNS_FriendlyAttrX3DDocType = 'X3DDocType';\r\n SYNS_FriendlyAttrX3DHeader = 'X3DHeader';\r\n\r\n // names of exporter output formats\r\n SYNS_ExporterFormatHTML = 'HTML';\r\n SYNS_ExporterFormatRTF = 'RTF';\r\n SYNS_ExporterFormatTeX = 'TeX';\r\n\r\n // TCustomSynEdit scroll hint window caption\r\n SYNS_ScrollInfoFmt = '%d - %d';\r\n SYNS_ScrollInfoFmtTop = 'Top Line: %d';\r\n // TSynEditPrintPreview page number\r\n SYNS_PreviewScrollInfoFmt = 'Page: %d';\r\n\r\n // strings for property editors etc\r\n SYNS_EDuplicateShortcut = 'Shortcut already exists';\r\n SYNS_ShortcutNone = '';\r\n SYNS_DuplicateShortcutMsg = 'The keystroke \"%s\" is already assigned ' +\r\n 'to another editor command. (%s)';\r\n SYNS_DuplicateShortcutMsg2 = 'The keystroke \"%s\" is already assigned ' +\r\n 'to another editor command.'#13#10'The ' +\r\n 'shortcut for this item has not been changed.';\r\n\r\n // Filters used for open/save dialog\r\n SYNS_FilterPascal = 'Pascal Files (*.pas;*.pp;*.dpr;*.dpk;*.inc)|*.pas;*.pp;*.dpr;*.dpk;*.inc';\r\n SYNS_FilterHP48 = 'HP48 Files (*.s;*.sou;*.a;*.hp)|*.s;*.sou;*.a;*.hp';\r\n SYNS_FilterCAClipper = 'CA-Clipper Files (*.prg;*.ch;*.inc)|*.prg;*.ch;*.inc';\r\n SYNS_FilterCORBAIDL = 'CORBA IDL Files (*.idl)|*.idl';\r\n SYNS_FilterCPM = 'CPM Reports (*.rdf;*.rif;*.rmf;*.rxf)|*.rdf;*.rif;*.rmf;*.rxf';\r\n SYNS_FilterCPP = 'C/C++ Files (*.c;*.cpp;*.cc;*.h;*.hpp;*.hh;*.cxx;*.hxx;*.cu)|*.c;*.cpp;*.cc;*.h;*.hpp;*.hh;*.cxx;*.hxx;*.cu';\r\n SYNS_FilterCS = 'C# Files (*.cs)|*.cs';\r\n SYNS_FilterDWS = 'DWScript Files (*.dws;*.pas;*.inc)|*.dws;*.pas;*.inc';\r\n SYNS_FilterJava = 'Java Files (*.java)|*.java';\r\n SYNS_FilterPerl = 'Perl Files (*.pl;*.pm;*.cgi)|*.pl;*.pm;*.cgi';\r\n SYNS_FilterAWK = 'AWK Scripts (*.awk)|*.awk';\r\n SYNS_FilterHTML = 'HTML Documents (*.htm;*.html)|*.htm;*.html';\r\n SYNS_FilterVBScript = 'VBScript Files (*.vbs)|*.vbs';\r\n SYNS_FilterGalaxy = 'Galaxy Files (*.gtv;*.galrep;*.txt)|*.gtv;*.galrep;*.txt';\r\n SYNS_FilterPython = 'Python Files (*.py)|*.py';\r\n SYNS_FilterSQL = 'SQL Files (*.sql)|*.sql';\r\n SYNS_FilterTclTk = 'Tcl/Tk Files (*.tcl)|*.tcl';\r\n SYNS_FilterRTF = 'Rich Text Format Documents (*.rtf)|*.rtf';\r\n SYNS_FilterBatch = 'MS-DOS Batch Files (*.bat;*.cmd)|*.bat;*.cmd';\r\n SYNS_FilterDFM = 'Borland Form Files (*.dfm;*.xfm)|*.dfm;*.xfm';\r\n SYNS_FilterX86Assembly = 'x86 Assembly Files (*.asm)|*.asm';\r\n SYNS_FilterGembase = 'GEMBASE Files (*.dml;*.gem)|*.dml;*.gem';\r\n SYNS_FilterINI = 'INI Files (*.ini)|*.ini';\r\n SYNS_FilterSML = 'Standard ML Files (*.sml)|*.sml';\r\n SYNS_FilterVisualBASIC = 'Visual Basic Files (*.bas)|*.bas';\r\n SYNS_FilterADSP21xx = 'DSP Files (*.dsp;*.inc)|*.dsp;*.inc';\r\n SYNS_FilterPHP = 'PHP Files (*.php;*.php3;*.phtml;*.inc)|*.php;*.php3;*.phtml;*.inc';\r\n SYNS_FilterCache = 'Cache Files (*.mac;*.inc;*.int)|*.mac;*.inc;*.int';\r\n SYNS_FilterCSS = 'Cascading Stylesheets (*.css)|*.css';\r\n SYNS_FilterJScript = 'Javascript Files (*.js)|*.js';\r\n SYNS_FilterKIX = 'KiXtart Scripts (*.kix)|*.kix';\r\n SYNS_FilterBaan = 'Baan 4GL Files (*.cln)|*.cln';\r\n SYNS_FilterFoxpro = 'Foxpro Files (*.prg)|*.prg';\r\n SYNS_FilterFortran = 'Fortran Files (*.for)|*.for';\r\n SYNS_FilterAsm68HC11 = '68HC11 Assembler Files (*.hc11;*.asm;*.asc)|*.hc11;*.asm;*.asc';\r\n SYNS_FilterProgress = 'Progress Files (*.w;*.p;*.i)|*.w;*.p;*.i';\r\n SYNS_FilterInno = 'Inno Setup Scripts (*.iss)|*.iss';\r\n SYNS_FilterModelica = 'Modelica Files (*.mo)|*.mo';\r\n SYNS_FilterModula3 = 'Modula-3 Files (*.m3)|*.m3';\r\n SYNS_FilterSDD = 'Semanta DD Files (*.sdd)|*.sdd';\r\n SYNS_FilterXML = 'XML Files (*.xml;*.xsd;*.xsl;*.xslt;*.dtd)|*.xml;*.xsd;*.xsl;*.xslt;*.dtd';\r\n SYNS_FilterGWS = 'GW-TEL Scripts (*.gws)|*.gws';\r\n SYNS_FilterSynGenMsgfiles = 'Msg Files (*.msg)|*.msg';\r\n SYNS_FilterST = 'Structured Text Files (*.st)|*.st';\r\n SYNS_FilterCOBOL = 'COBOL Files (*.cbl;*.cob)|*.cbl;*.cob';\r\n SYNS_FilterTeX = 'TeX Files (*.tex)|*.tex';\r\n SYNS_FilterRC = 'Resource Files (*.rc)|*.rc';\r\n SYNS_FilterRuby = 'Ruby Files (*.rb;*.rbw)|*.rb;*.rbw';\r\n SYNS_FilterUNIXShellScript = 'UNIX Shell Scripts (*.sh)|*.sh';\r\n SYNS_FilterHaskell = 'Haskell Files (*.hs;*.lhs)|*.hs;*.lhs';\r\n SYNS_FilterDOT = 'DOT Graph Drawing Description (*.dot)|*.dot';\r\n SYNS_FilterEiffel = 'Eiffel (*.e;*.ace)|*.e;*.ace';\r\n SYNS_FilterLDraw = 'LEGO LDraw Files (*.ldr)|*.ldr';\r\n SYNS_FilterURI = 'All Files (*.*)|*.*';\r\n SYNS_FilterVrml97 = 'Vrml97/X3D World (*.wrl;*.wrml;*.vrl;*.vrml;*.x3d)|*.wrl;*.wrml;*.vrl;*.vrml;*.x3d';\r\n\r\n // friendly language names\r\n SYNS_FriendlyLangHP48 = 'HP48';\r\n SYNS_FriendlyLangCAClipper = 'CA-Clipper';\r\n SYNS_FriendlyLangCPM = 'COAS Product Manager Report';\r\n SYNS_FriendlyLangCPP = 'C/C++';\r\n SYNS_FriendlyLangCS = 'C#';\r\n SYNS_FriendlyLangJava = 'Java';\r\n SYNS_FriendlyLangPerl = 'Perl';\r\n SYNS_FriendlyLangBatch = 'MS-DOS Batch';\r\n SYNS_FriendlyLangDfm = 'Borland Forms';\r\n SYNS_FriendlyLangAWK = 'AWK';\r\n SYNS_FriendlyLangCORBAIDL = 'CORBA IDL';\r\n SYNS_FriendlyLangHTML = 'HTML';\r\n SYNS_FriendlyLangVBSScript = 'MS VBScript';\r\n SYNS_FriendlyLangGalaxy = 'Galaxy';\r\n SYNS_FriendlyLangGeneral = 'General';\r\n SYNS_FriendlyLangPascal = 'Object Pascal';\r\n SYNS_FriendlyLangX86Asm = 'x86 Assembly';\r\n SYNS_FriendlyLangPython = 'Python';\r\n SYNS_FriendlyLangTclTk = 'Tcl/Tk';\r\n SYNS_FriendlyLangSQL = 'SQL';\r\n SYNS_FriendlyLangGembase = 'Gembase';\r\n SYNS_FriendlyLangINI = 'INI';\r\n SYNS_FriendlyLangSML = 'Standard ML';\r\n SYNS_FriendlyLangVisualBASIC = 'Visual Basic';\r\n SYNS_FriendlyLangADSP21xx = 'ADSP21xx';\r\n SYNS_FriendlyLangPHP = 'PHP';\r\n SYNS_FriendlyLangSybaseSQL = 'Sybase SQL';\r\n SYNS_FriendlyLangGeneralMulti = 'General Multi-Highlighter';\r\n SYNS_FriendlyLangCache = 'Cache Object Script';\r\n SYNS_FriendlyLangCSS = 'Cascading Style Sheet';\r\n SYNS_FriendlyLangJScript = 'JavaScript';\r\n SYNS_FriendlyLangKIX = 'KiXtart';\r\n SYNS_FriendlyLangBaan = 'Baan 4GL';\r\n SYNS_FriendlyLangFoxpro = 'Foxpro';\r\n SYNS_FriendlyLangFortran = 'Fortran';\r\n SYNS_FriendlyLang68HC11 = '68HC11 Assembler';\r\n SYNS_FriendlyLangProgress = 'Progress';\r\n SYNS_FriendlyLangInno = 'Inno Setup Script';\r\n SYNS_FriendlyLangModelica = 'Modelica';\r\n SYNS_FriendlyLangModula3 = 'Modula 3';\r\n SYNS_FriendlyLangSDD = 'Semanta Data Dictionary';\r\n SYNS_FriendlyLangXML = 'XML';\r\n SYNS_FriendlyLangGWS = 'GW-TEL';\r\n SYNS_FriendlyLangSynGenMsgfiles = 'SynGen Msg';\r\n SYNS_FriendlyLangUnreal = 'Unreal';\r\n SYNS_FriendlyLangST = 'Structured Text';\r\n SYNS_FriendlyLangCOBOL = 'COBOL';\r\n SYNS_FriendlyLangTeX = 'TeX';\r\n SYNS_FriendlyLangRC = 'Resource';\r\n SYNS_FriendlyLangRuby = 'Ruby';\r\n SYNS_FriendlyLangNameUNIXShellScript = 'UNIX Shell Script';\r\n SYNS_FriendlyLangHaskell = 'Haskell';\r\n SYNS_FriendlyLangDOT = 'DOT Graph Drawing Description language';\r\n SYNS_FriendlyLangEiffel = 'Eiffel';\r\n SYNS_FriendlyLangLDraw = 'LEGO LDraw';\r\n SYNS_FriendlyLangUnknown = ''; \r\n SYNS_FriendlyLangURI = 'URI';\r\n SYNS_FriendlyLangVrml97 = 'Vrml97';\r\n\r\nimplementation\r\n\r\nend.\r\n" }, { "path": "External/SynEdit/Source/SynEditTextBuffer.pas", "content": "{-------------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: SynEditTextBuffer.pas, released 2000-04-07.\r\nThe Original Code is based on parts of mwCustomEdit.pas by Martin Waldenburg,\r\npart of the mwEdit component suite.\r\nPortions created by Martin Waldenburg are Copyright (C) 1998 Martin Waldenburg.\r\nUnicode translation by Mal Hrz.\r\nAll Rights Reserved.\r\n\r\nContributors to the SynEdit and mwEdit projects are listed in the\r\nContributors.txt file.\r\n\r\nAlternatively, the contents of this file may be used under the terms of the\r\nGNU General Public License Version 2 or later (the \"GPL\"), in which case\r\nthe provisions of the GPL are applicable instead of those above.\r\nIf you wish to allow use of your version of this file only under the terms\r\nof the GPL and not to allow others to use your version of this file\r\nunder the MPL, indicate your decision by deleting the provisions above and\r\nreplace them with the notice and other provisions required by the GPL.\r\nIf you do not delete the provisions above, a recipient may use your version\r\nof this file under either the MPL or the GPL.\r\n\r\n$Id: SynEditTextBuffer.pas,v 1.14 2011/12/28 09:24:20 Egg Exp $\r\n\r\nYou may retrieve the latest version of this file at the SynEdit home page,\r\nlocated at http://SynEdit.SourceForge.net\r\n\r\nKnown Issues:\r\n-------------------------------------------------------------------------------}\r\n//todo: Avoid calculating expanded string unncessarily (just calculate expandedLength instead).\r\n\r\n{$IFNDEF QSYNEDITTEXTBUFFER}\r\nunit SynEditTextBuffer;\r\n{$ENDIF}\r\n\r\n{$I SynEdit.inc}\r\n\r\ninterface\r\n\r\nuses\r\n{$IFDEF SYN_CLX}\r\n kTextDrawer,\r\n Types,\r\n QSynEditTypes,\r\n QSynEditMiscProcs,\r\n QSynUnicode,\r\n{$ELSE}\r\n Windows,\r\n SynEditTypes,\r\n SynEditMiscProcs,\r\n SynUnicode,\r\n{$ENDIF}\r\n Classes,\r\n SysUtils,\r\n Graphics;\r\n\r\ntype\r\n TSynEditRange = pointer;\r\n\r\n TSynEditStringFlag = (sfHasTabs, sfHasNoTabs, sfExpandedLengthUnknown);\r\n TSynEditStringFlags = set of TSynEditStringFlag;\r\n\r\n PSynEditStringRec = ^TSynEditStringRec;\r\n TSynEditStringRec = record\r\n {$IFDEF OWN_UnicodeString_MEMMGR}\r\n FString: PWideChar; // \"array of WideChar\";\r\n {$ELSE}\r\n FString: UnicodeString;\r\n {$ENDIF OWN_UnicodeString_MEMMGR}\r\n fObject: TObject;\r\n fRange: TSynEditRange;\r\n fExpandedLength: Integer;\r\n fCharIndex : Integer;\r\n fFlags: TSynEditStringFlags;\r\n end;\r\n\r\n TSynEditTwoWideChars = record\r\n One, Two : WideChar;\r\n end;\r\n PSynEditTwoWideChars = ^TSynEditTwoWideChars;\r\n\r\nconst\r\n SynEditStringRecSize = SizeOf(TSynEditStringRec);\r\n MaxSynEditStrings = MaxInt div SynEditStringRecSize;\r\n\r\n NullRange = TSynEditRange(-1);\r\n\r\ntype\r\n PSynEditStringRecList = ^TSynEditStringRecList;\r\n TSynEditStringRecList = array[0..MaxSynEditStrings - 1] of TSynEditStringRec;\r\n\r\n TStringListChangeEvent = procedure(Sender: TObject; Index: Integer;\r\n Count: integer) of object;\r\n\r\n TExpandAtWideGlyphsFunc = function (const S: UnicodeString): UnicodeString of object;\r\n\r\n TSynEditFileFormat = (sffDos, sffUnix, sffMac, sffUnicode); // DOS: CRLF, UNIX: LF, Mac: CR, Unicode: LINE SEPARATOR\r\n\r\n TSynEditStringList = class(TUnicodeStrings)\r\n private\r\n fList: PSynEditStringRecList;\r\n fCount: integer;\r\n fCapacity: integer;\r\n fFileFormat: TSynEditFileFormat;\r\n fAppendNewLineAtEOF: Boolean;\r\n fConvertTabsProc: TConvertTabsProcEx;\r\n fIndexOfLongestLine: integer;\r\n fTabWidth: integer;\r\n FExpandAtWideGlyphsFunc: TExpandAtWideGlyphsFunc;\r\n FCharIndexesAreValid : Boolean;\r\n fOnChange: TNotifyEvent;\r\n fOnChanging: TNotifyEvent;\r\n fOnCleared: TNotifyEvent;\r\n fOnDeleted: TStringListChangeEvent;\r\n fOnInserted: TStringListChangeEvent;\r\n fOnPutted: TStringListChangeEvent;\r\n function ExpandString(Index: integer): UnicodeString;\r\n function GetExpandedString(Index: integer): UnicodeString;\r\n function GetExpandedStringLength(Index: integer): integer;\r\n function GetLengthOfLongestLine: Integer;\r\n function GetRange(Index: integer): TSynEditRange;\r\n procedure Grow;\r\n procedure InsertItem(Index: integer; const S: UnicodeString);\r\n procedure PutRange(Index: integer; ARange: TSynEditRange);\r\n procedure SetFileFormat(const Value: TSynEditFileFormat);\r\n {$IFDEF OWN_UnicodeString_MEMMGR}\r\n procedure SetListString(Index: Integer; const S: UnicodeString);\r\n {$ENDIF OWN_UnicodeString_MEMMGR}\r\n protected\r\n FStreaming: Boolean;\r\n function Get(Index: Integer): UnicodeString; override;\r\n function GetCapacity: integer;\r\n {$IFDEF SYN_COMPILER_3_UP} override; {$ENDIF}\r\n function GetCount: integer; override;\r\n function GetObject(Index: integer): TObject; override;\r\n function GetTextStr: UnicodeString; override;\r\n procedure Put(Index: integer; const S: UnicodeString); override;\r\n procedure PutObject(Index: integer; AObject: TObject); override;\r\n procedure SetCapacity(NewCapacity: integer);\r\n {$IFDEF SYN_COMPILER_3_UP} override; {$ENDIF}\r\n procedure SetTabWidth(Value: integer);\r\n procedure SetUpdateState(Updating: Boolean); override;\r\n procedure UpdateCharIndexes;\r\n public\r\n constructor Create(AExpandAtWideGlyphsFunc: TExpandAtWideGlyphsFunc);\r\n destructor Destroy; override;\r\n function Add(const S: UnicodeString): integer; override;\r\n procedure AddStrings(Strings: TUnicodeStrings); override;\r\n procedure Clear; override;\r\n procedure Delete(Index: integer); override;\r\n procedure DeleteLines(Index, NumLines: integer);\r\n procedure Exchange(Index1, Index2: integer); override;\r\n procedure Insert(Index: integer; const S: UnicodeString); override;\r\n procedure InsertLines(Index, NumLines: integer);\r\n procedure InsertStrings(Index: integer; NewStrings: TUnicodeStrings);\r\n procedure InsertText(Index: integer; NewText: UnicodeString);\r\n{$IFDEF UNICODE}\r\n procedure SaveToStream(Stream: TStream; Encoding: TEncoding); override;\r\n function GetSeparatedText(Separators: UnicodeString): UnicodeString;\r\n{$ELSE}\r\n procedure SaveToStream(Stream: TStream; WithBOM: Boolean = True); override;\r\n{$ENDIF}\r\n procedure SetTextStr(const Value: UnicodeString); override;\r\n procedure LoadFromStream(Stream: TStream); override;\r\n procedure FontChanged;\r\n function LineCharLength(Index : Integer) : Integer;\r\n function LineCharIndex(Index : Integer) : Integer;\r\n\r\n property AppendNewLineAtEOF: Boolean read fAppendNewLineAtEOF write fAppendNewLineAtEOF;\r\n\r\n property FileFormat: TSynEditFileFormat read fFileFormat write SetFileFormat;\r\n property ExpandedStrings[Index: integer]: UnicodeString read GetExpandedString;\r\n property ExpandedStringLengths[Index: integer]: integer read GetExpandedStringLength;\r\n property LengthOfLongestLine: Integer read GetLengthOfLongestLine;\r\n property Ranges[Index: integer]: TSynEditRange read GetRange write PutRange;\r\n property TabWidth: integer read fTabWidth write SetTabWidth;\r\n property OnChange: TNotifyEvent read fOnChange write fOnChange;\r\n property OnChanging: TNotifyEvent read fOnChanging write fOnChanging;\r\n property OnCleared: TNotifyEvent read fOnCleared write fOnCleared;\r\n property OnDeleted: TStringListChangeEvent read fOnDeleted write fOnDeleted;\r\n property OnInserted: TStringListChangeEvent read fOnInserted\r\n write fOnInserted;\r\n property OnPutted: TStringListChangeEvent read fOnPutted write fOnPutted;\r\n end;\r\n\r\n ESynEditStringList = class(Exception);\r\n\r\n TSynChangeReason = (crInsert, crPaste, crDragDropInsert,\r\n // Note: several undo entries can be chained together via the ChangeNumber\r\n // see also TCustomSynEdit.[Begin|End]UndoBlock methods\r\n crDeleteAfterCursor, crDelete,\r\n crLineBreak, crIndent, crUnindent,\r\n crSilentDelete, crSilentDeleteAfterCursor,\r\n crAutoCompleteBegin, crAutoCompleteEnd,\r\n crPasteBegin, crPasteEnd, // for pasting, since it might do a lot of operations\r\n crSpecial1Begin, crSpecial1End,\r\n crSpecial2Begin, crSpecial2End,\r\n crCaret, // just restore the Caret, allowing better Undo behavior\r\n crSelection, // restore Selection\r\n crNothing,\r\n crGroupBreak,\r\n crDeleteAll,\r\n crWhiteSpaceAdd // for undo/redo of adding a character past EOL and repositioning the caret\r\n );\r\n\r\n TSynEditUndoItem = class(TPersistent)\r\n protected\r\n fChangeReason: TSynChangeReason;\r\n fChangeSelMode: TSynSelectionMode;\r\n fChangeStartPos: TBufferCoord;\r\n fChangeEndPos: TBufferCoord;\r\n fChangeStr: UnicodeString;\r\n fChangeNumber: integer; \r\n public\r\n procedure Assign(Source: TPersistent); override;\r\n property ChangeReason: TSynChangeReason read fChangeReason;\r\n property ChangeSelMode: TSynSelectionMode read fChangeSelMode;\r\n property ChangeStartPos: TBufferCoord read fChangeStartPos;\r\n property ChangeEndPos: TBufferCoord read fChangeEndPos;\r\n property ChangeStr: UnicodeString read fChangeStr;\r\n property ChangeNumber: integer read fChangeNumber;\r\n end;\r\n\r\n TSynEditUndoList = class(TPersistent)\r\n protected\r\n fBlockChangeNumber: integer;\r\n fBlockCount: integer;\r\n fFullUndoImposible: boolean;\r\n fItems: TList;\r\n fLockCount: integer;\r\n fMaxUndoActions: integer;\r\n fNextChangeNumber: integer;\r\n fInitialChangeNumber: integer;\r\n fInsideRedo: boolean;\r\n fOnAddedUndo: TNotifyEvent;\r\n procedure EnsureMaxEntries;\r\n function GetCanUndo: boolean;\r\n function GetItemCount: integer;\r\n procedure SetMaxUndoActions(Value: integer);\r\n procedure SetInitialState(const Value: boolean);\r\n function GetInitialState: boolean;\r\n function GetItems(Index: Integer): TSynEditUndoItem;\r\n procedure SetItems(Index: Integer; const Value: TSynEditUndoItem);\r\n public\r\n constructor Create;\r\n destructor Destroy; override;\r\n procedure AddChange(AReason: TSynChangeReason; const AStart, AEnd: TBufferCoord;\r\n const ChangeText: UnicodeString; SelMode: TSynSelectionMode);\r\n procedure BeginBlock; \r\n procedure Clear;\r\n procedure EndBlock;\r\n procedure Lock;\r\n function PeekItem: TSynEditUndoItem;\r\n function PopItem: TSynEditUndoItem;\r\n procedure PushItem(Item: TSynEditUndoItem);\r\n procedure Unlock;\r\n function LastChangeReason: TSynChangeReason;\r\n public\r\n procedure Assign(Source: TPersistent); override;\r\n procedure AddGroupBreak;\r\n procedure DeleteItem(AIndex: Integer);\r\n property BlockChangeNumber: integer read fBlockChangeNumber\r\n write fBlockChangeNumber;\r\n property CanUndo: boolean read GetCanUndo;\r\n property FullUndoImpossible: boolean read fFullUndoImposible;\r\n property InitialState: boolean read GetInitialState write SetInitialState;\r\n property Items[Index: Integer]: TSynEditUndoItem read GetItems write SetItems;\r\n property ItemCount: integer read GetItemCount;\r\n property BlockCount: integer read fBlockCount;\r\n property MaxUndoActions: integer read fMaxUndoActions\r\n write SetMaxUndoActions;\r\n property InsideRedo: boolean read fInsideRedo write fInsideRedo;\r\n property OnAddedUndo: TNotifyEvent read fOnAddedUndo write fOnAddedUndo;\r\n end;\r\n\r\nimplementation\r\n\r\n{$IFDEF SYN_COMPILER_3_UP}\r\nresourcestring\r\n{$ELSE}\r\nconst\r\n{$ENDIF}\r\n SListIndexOutOfBounds = 'Invalid stringlist index %d';\r\n SInvalidCapacity = 'Stringlist capacity cannot be smaller than count';\r\n\r\n{ TSynEditStringList }\r\n\r\nprocedure ListIndexOutOfBounds(Index: integer);\r\nbegin\r\n raise ESynEditStringList.CreateFmt(SListIndexOutOfBounds, [Index]);\r\nend;\r\n\r\nconstructor TSynEditStringList.Create(AExpandAtWideGlyphsFunc: TExpandAtWideGlyphsFunc);\r\nbegin\r\n inherited Create;\r\n FExpandAtWideGlyphsFunc := AExpandAtWideGlyphsFunc;\r\n SetFileFormat(sffDos);\r\n fIndexOfLongestLine := -1;\r\n TabWidth := 8;\r\nend;\r\n\r\ndestructor TSynEditStringList.Destroy;\r\nbegin\r\n fOnChange := nil;\r\n fOnChanging := nil;\r\n inherited Destroy;\r\n {$IFDEF OWN_UnicodeString_MEMMGR}\r\n fOnCleared := nil;\r\n Clear;\r\n {$ELSE}\r\n if fCount <> 0 then\r\n Finalize(fList^[0], fCount);\r\n fCount := 0;\r\n SetCapacity(0);\r\n {$ENDIF OWN_UnicodeString_MEMMGR}\r\nend;\r\n\r\nfunction TSynEditStringList.Add(const S: UnicodeString): integer;\r\nbegin\r\n BeginUpdate;\r\n Result := fCount;\r\n InsertItem(Result, S);\r\n if Assigned(OnInserted) then\r\n OnInserted(Self, Result, 1);\r\n EndUpdate;\r\nend;\r\n\r\nprocedure TSynEditStringList.AddStrings(Strings: TUnicodeStrings);\r\nvar\r\n i, FirstAdded: integer;\r\nbegin\r\n if Strings.Count > 0 then begin\r\n fIndexOfLongestLine := -1;\r\n BeginUpdate;\r\n try\r\n i := fCount + Strings.Count;\r\n if i > fCapacity then\r\n SetCapacity((i + 15) and (not 15));\r\n FirstAdded := fCount;\r\n for i := 0 to Strings.Count - 1 do begin\r\n with fList^[fCount] do begin\r\n Pointer(fString) := nil;\r\n {$IFDEF OWN_UnicodeString_MEMMGR}\r\n SetListString(fCount, Strings[i]);\r\n {$ELSE}\r\n fString := Strings[i];\r\n {$ENDIF OWN_UnicodeString_MEMMGR}\r\n fObject := Strings.Objects[i];\r\n fRange := NullRange;\r\n fExpandedLength := -1;\r\n fFlags := [sfExpandedLengthUnknown];\r\n end;\r\n Inc(fCount);\r\n end;\r\n if Assigned(OnInserted) then\r\n OnInserted(Self, FirstAdded, Strings.Count);\r\n finally\r\n EndUpdate;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TSynEditStringList.Clear;\r\n{$IFDEF OWN_UnicodeString_MEMMGR}\r\nvar\r\n I: Integer;\r\n{$ENDIF OWN_UnicodeString_MEMMGR}\r\nbegin\r\n if fCount <> 0 then begin\r\n BeginUpdate;\r\n {$IFDEF OWN_UnicodeString_MEMMGR}\r\n for I := 0 to FCount - 1 do\r\n with FList[I] do\r\n if TDynWideCharArray(FString) <> nil then\r\n TDynWideCharArray(FString) := nil;\r\n {$ELSE}\r\n Finalize(fList^[0], fCount);\r\n {$ENDIF OWN_UnicodeString_MEMMGR}\r\n fCount := 0;\r\n SetCapacity(0);\r\n if Assigned(fOnCleared) then\r\n fOnCleared(Self);\r\n EndUpdate;\r\n end;\r\n fIndexOfLongestLine := -1;\r\nend;\r\n\r\nprocedure TSynEditStringList.Delete(Index: integer);\r\nbegin\r\n if (Index < 0) or (Index > fCount) then\r\n ListIndexOutOfBounds(Index);\r\n BeginUpdate;\r\n {$IFDEF OWN_UnicodeString_MEMMGR}\r\n SetListString(Index, '');\r\n {$ELSE}\r\n Finalize(fList^[Index]);\r\n {$ENDIF OWN_UnicodeString_MEMMGR}\r\n Dec(fCount);\r\n if Index < fCount then begin\r\n System.Move(fList^[Index + 1], fList^[Index],\r\n (fCount - Index) * SynEditStringRecSize);\r\n {$IFDEF OWN_UnicodeString_MEMMGR}\r\n Pointer(FList[fCount].fString) := nil; // avoid freeing the string, the address is now used in another element\r\n {$ENDIF OWN_UnicodeString_MEMMGR}\r\n end;\r\n fIndexOfLongestLine := -1;\r\n if Assigned(fOnDeleted) then\r\n fOnDeleted( Self, Index, 1 );\r\n EndUpdate;\r\nend;\r\n\r\nprocedure TSynEditStringList.DeleteLines(Index, NumLines: Integer);\r\nvar\r\n LinesAfter: integer;\r\n{$IFDEF OWN_UnicodeString_MEMMGR}\r\n I: Integer;\r\n{$ENDIF OWN_UnicodeString_MEMMGR}\r\nbegin\r\n if NumLines > 0 then begin\r\n if (Index < 0) or (Index > fCount) then\r\n ListIndexOutOfBounds(Index);\r\n LinesAfter := fCount - (Index + NumLines - 1);\r\n if LinesAfter < 0 then\r\n NumLines := fCount - Index - 1;\r\n {$IFDEF OWN_UnicodeString_MEMMGR}\r\n for I := Index to Index + NumLines - 1 do\r\n with FList[I] do\r\n if TDynWideCharArray(FString) <> nil then\r\n TDynWideCharArray(FString) := nil;\r\n {$ELSE}\r\n Finalize(fList^[Index], NumLines);\r\n {$ENDIF OWN_UnicodeString_MEMMGR}\r\n\r\n if LinesAfter > 0 then begin\r\n BeginUpdate;\r\n try\r\n System.Move(fList^[Index + NumLines], fList^[Index],\r\n LinesAfter * SynEditStringRecSize);\r\n finally\r\n EndUpdate;\r\n end;\r\n end;\r\n Dec(fCount, NumLines);\r\n if Assigned(fOnDeleted) then\r\n fOnDeleted( Self, Index, NumLines );\r\n end;\r\nend;\r\n\r\nprocedure TSynEditStringList.Exchange(Index1, Index2: integer);\r\nvar\r\n Temp: TSynEditStringRec;\r\nbegin\r\n if (Index1 < 0) or (Index1 >= fCount) then\r\n ListIndexOutOfBounds(Index1);\r\n if (Index2 < 0) or (Index2 >= fCount) then\r\n ListIndexOutOfBounds(Index2);\r\n BeginUpdate;\r\n Temp := fList^[Index1];\r\n fList^[Index1] := fList^[Index2];\r\n fList^[Index2] := Temp;\r\n if fIndexOfLongestLine = Index1 then\r\n fIndexOfLongestLine := Index2\r\n else if fIndexOfLongestLine = Index2 then\r\n fIndexOfLongestLine := Index1;\r\n EndUpdate;\r\nend;\r\n\r\nfunction TSynEditStringList.ExpandString(Index: integer): UnicodeString;\r\nvar\r\n HasTabs: Boolean;\r\nbegin\r\n with fList^[Index] do\r\n {$IFDEF OWN_UnicodeString_MEMMGR}\r\n if Length(TDynWideCharArray(FString)) = 0 then\r\n {$ELSE}\r\n if Length(FString) = 0 then\r\n {$ENDIF}\r\n begin\r\n Result := '';\r\n Exclude(fFlags, sfExpandedLengthUnknown);\r\n Exclude(fFlags, sfHasTabs);\r\n Include(fFlags, sfHasNoTabs);\r\n fExpandedLength := 0;\r\n end\r\n else\r\n begin\r\n Result := fConvertTabsProc(fstring, fTabWidth, HasTabs);\r\n fExpandedLength := Length(FExpandAtWideGlyphsFunc(Result));\r\n Exclude(fFlags, sfExpandedLengthUnknown);\r\n Exclude(fFlags, sfHasTabs);\r\n Exclude(fFlags, sfHasNoTabs);\r\n if HasTabs then\r\n Include(fFlags, sfHasTabs)\r\n else\r\n Include(fFlags, sfHasNoTabs);\r\n end;\r\nend;\r\n\r\nfunction TSynEditStringList.Get(Index: integer): UnicodeString;\r\n{$IFDEF OWN_UnicodeString_MEMMGR}\r\nvar\r\n Len: Integer;\r\n{$ENDIF OWN_UnicodeString_MEMMGR}\r\nbegin\r\n if Cardinal(Index) 0 then\r\n begin\r\n SetLength(Result, Len - 1); // exclude #0\r\n if Result <> '' then\r\n System.Move(FString^, Result[1], Len * SizeOf(WideChar));\r\n end\r\n else\r\n Result := '';\r\n end\r\n {$ELSE}\r\n Result := fList^[Index].fString\r\n {$ENDIF OWN_UnicodeString_MEMMGR}\r\n else\r\n Result := '';\r\nend;\r\n\r\nprocedure TSynEditStringList.UpdateCharIndexes;\r\nvar\r\n i, n : Integer;\r\n p : PSynEditStringRec;\r\nbegin\r\n FCharIndexesAreValid:=True;\r\n if fCount=0 then Exit;\r\n p:=@fList^[0];\r\n n:=0;\r\n for i:=1 to fCount do begin\r\n p.fCharIndex:=n;\r\n Inc(n, Length(p.FString));\r\n Inc(p);\r\n end;\r\nend;\r\n\r\nfunction TSynEditStringList.LineCharLength(Index : Integer) : Integer;\r\nbegin\r\n if Cardinal(Index)= 0) and (Index < fCount) then\r\n begin\r\n if sfHasNoTabs in fList^[Index].fFlags then\r\n Result := Get(Index)\r\n else\r\n Result := ExpandString(Index);\r\n end else\r\n Result := '';\r\nend;\r\n\r\nfunction TSynEditStringList.GetExpandedStringLength(Index: integer): integer;\r\nbegin\r\n if (Index >= 0) and (Index < fCount) then\r\n begin\r\n if sfExpandedLengthUnknown in fList^[Index].fFlags then\r\n Result := Length( ExpandedStrings[index] )\r\n else\r\n Result := fList^[Index].fExpandedLength;\r\n end\r\n else\r\n Result := 0;\r\nend;\r\n\r\nfunction TSynEditStringList.GetLengthOfLongestLine: Integer;\r\nvar\r\n i, MaxLen: Integer;\r\n PRec: PSynEditStringRec;\r\nbegin\r\n if fIndexOfLongestLine < 0 then\r\n begin\r\n MaxLen := 0;\r\n if fCount > 0 then\r\n begin\r\n PRec := @fList^[0];\r\n for i := 0 to fCount - 1 do\r\n begin\r\n if sfExpandedLengthUnknown in PRec^.fFlags then\r\n ExpandString(i);\r\n if PRec^.fExpandedLength > MaxLen then\r\n begin\r\n MaxLen := PRec^.fExpandedLength;\r\n fIndexOfLongestLine := i;\r\n end;\r\n Inc(PRec);\r\n end;\r\n end;\r\n end;\r\n if (fIndexOfLongestLine >= 0) and (fIndexOfLongestLine < fCount) then\r\n Result := fList^[fIndexOfLongestLine].fExpandedLength\r\n else\r\n Result := 0;\r\nend;\r\n\r\nfunction TSynEditStringList.GetObject(Index: integer): TObject;\r\nbegin\r\n if (Index >= 0) and (Index < fCount) then\r\n Result := fList^[Index].fObject\r\n else\r\n Result := nil;\r\nend;\r\n\r\nfunction TSynEditStringList.GetRange(Index: integer): TSynEditRange;\r\nbegin\r\n if (Index >= 0) and (Index < fCount) then\r\n Result := fList^[Index].fRange\r\n else\r\n Result := nil;\r\nend;\r\n\r\n{$IFDEF UNICODE}\r\nfunction TSynEditStringList.GetSeparatedText(Separators: UnicodeString): UnicodeString;\r\n{Optimized by Eric Grange}\r\nvar\r\n I, L, Size, LineBreakSize: Integer;\r\n P, PLineBreak: PChar;\r\n PRec: PSynEditStringRec;\r\nbegin\r\n if fCount = 0 then begin\r\n Result := '';\r\n exit;\r\n end;\r\n LineBreakSize := Length(Separators);\r\n PLineBreak := Pointer(Separators);\r\n\r\n // compute buffer size\r\n Size := (fCount-1) * LineBreakSize\r\n + LineCharIndex( fCount-1 )\r\n + Length( fList^[fCount-1].FString );\r\n SetLength(Result, Size);\r\n\r\n P := Pointer(Result);\r\n PRec := @fList^[0];\r\n\r\n // handle 1st line separately (to avoid trailing line break)\r\n L := Length(PRec.FString);\r\n if L <> 0 then\r\n begin\r\n System.Move(Pointer(PRec.FString)^, P^, L * SizeOf(Char));\r\n Inc(P, L);\r\n end;\r\n Inc(PRec);\r\n\r\n for I := 1 to fCount-1 do\r\n begin\r\n case LineBreakSize of\r\n 0 : ;\r\n 1 : begin\r\n P^ := PLineBreak^;\r\n Inc(P);\r\n end;\r\n 2 : begin\r\n PSynEditTwoWideChars(P)^ := PSynEditTwoWideChars(PLineBreak)^;\r\n Inc(P, 2);\r\n end;\r\n else\r\n System.Move(PLineBreak^, P^, LineBreakSize * SizeOf(Char));\r\n Inc(P, LineBreakSize);\r\n end;\r\n if Pointer( PRec.FString ) <> nil then\r\n begin\r\n L := Length(PRec.FString);\r\n System.Move(Pointer(PRec.FString)^, P^, L * SizeOf(Char));\r\n Inc(P, L);\r\n end;\r\n Inc(PRec);\r\n end;\r\nend;\r\n{$ENDIF}\r\n\r\nfunction TSynEditStringList.GetTextStr: UnicodeString;\r\nvar\r\n LB: UnicodeString;\r\nbegin\r\n if not FStreaming then\r\n begin\r\n Result := GetSeparatedText(sLineBreak);\r\n end\r\n else\r\n begin\r\n case FileFormat of\r\n sffDos:\r\n LB := WideCRLF;\r\n sffUnix:\r\n LB := WideLF;\r\n sffMac:\r\n LB := WideCR;\r\n sffUnicode:\r\n LB := WideLineSeparator;\r\n end;\r\n Result := GetSeparatedText(LB);\r\n if AppendNewLineAtEOF then\r\n Result := Result + LB;\r\n end;\r\nend;\r\n\r\nprocedure TSynEditStringList.Grow;\r\nvar\r\n Delta: Integer;\r\nbegin\r\n if fCapacity > 64 then\r\n Delta := fCapacity div 4\r\n else\r\n Delta := 16;\r\n SetCapacity(fCapacity + Delta);\r\nend;\r\n\r\nprocedure TSynEditStringList.Insert(Index: integer; const S: UnicodeString);\r\nbegin\r\n if (Index < 0) or (Index > fCount) then\r\n ListIndexOutOfBounds(Index);\r\n BeginUpdate;\r\n InsertItem(Index, S);\r\n if Assigned(fOnInserted) then\r\n fOnInserted( Self, Index, 1 );\r\n EndUpdate;\r\nend;\r\n\r\nprocedure TSynEditStringList.InsertItem(Index: Integer; const S: UnicodeString);\r\nbegin\r\n BeginUpdate;\r\n if fCount = fCapacity then\r\n Grow;\r\n if Index < fCount then\r\n begin\r\n System.Move(fList^[Index], fList^[Index + 1],\r\n (fCount - Index) * SynEditStringRecSize);\r\n end;\r\n fIndexOfLongestLine := -1; \r\n with fList^[Index] do\r\n begin\r\n Pointer(fString) := nil;\r\n {$IFDEF OWN_UnicodeString_MEMMGR}\r\n SetListString(Index, S);\r\n {$ELSE}\r\n fString := S;\r\n {$ENDIF OWN_UnicodeString_MEMMGR}\r\n fObject := nil;\r\n fRange := NullRange;\r\n fExpandedLength := -1;\r\n fFlags := [sfExpandedLengthUnknown];\r\n end;\r\n Inc(fCount);\r\n EndUpdate;\r\nend;\r\n\r\nprocedure TSynEditStringList.InsertLines(Index, NumLines: Integer);\r\nvar\r\n c_Line: Integer;\r\nbegin\r\n if (Index < 0) or (Index > fCount) then\r\n ListIndexOutOfBounds(Index);\r\n if NumLines > 0 then\r\n begin\r\n BeginUpdate;\r\n try\r\n SetCapacity(fCount + NumLines);\r\n if Index < fCount then\r\n begin\r\n System.Move(fList^[Index], fList^[Index + NumLines],\r\n (fCount - Index) * SynEditStringRecSize);\r\n end;\r\n for c_Line := Index to Index + NumLines -1 do\r\n with fList^[c_Line] do\r\n begin\r\n Pointer(fString) := nil;\r\n fObject := nil;\r\n fRange := NullRange;\r\n fExpandedLength := -1;\r\n fFlags := [sfExpandedLengthUnknown];\r\n end;\r\n Inc(fCount, NumLines);\r\n if Assigned(OnInserted) then\r\n OnInserted(Self, Index, NumLines);\r\n finally\r\n EndUpdate;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TSynEditStringList.InsertStrings(Index: integer;\r\n NewStrings: TUnicodeStrings);\r\nvar\r\n i, Cnt: integer;\r\nbegin\r\n Cnt := NewStrings.Count;\r\n if Cnt = 0 then exit;\r\n\r\n BeginUpdate;\r\n try\r\n InsertLines(Index, Cnt);\r\n for i := 0 to Cnt - 1 do\r\n Strings[Index + i] := NewStrings[i];\r\n finally\r\n EndUpdate;\r\n end;\r\nend;\r\n\r\nprocedure TSynEditStringList.InsertText(Index: integer;\r\n NewText: UnicodeString);\r\nvar\r\n TmpStringList: TUnicodeStringList;\r\nbegin\r\n if NewText = '' then exit;\r\n\r\n TmpStringList := TUnicodeStringList.Create;\r\n try\r\n TmpStringList.Text := NewText;\r\n InsertStrings(Index, TmpStringList);\r\n finally\r\n TmpStringList.Free;\r\n end;\r\nend;\r\n\r\nprocedure TSynEditStringList.LoadFromStream(Stream: TStream);\r\nbegin\r\n FStreaming := True;\r\n inherited;\r\n FStreaming := False;\r\nend;\r\n\r\n{$IFDEF UNICODE}\r\nprocedure TSynEditStringList.SaveToStream(Stream: TStream; Encoding: TEncoding);\r\nbegin\r\n FStreaming := True;\r\n inherited;\r\n FStreaming := False;\r\nend;\r\n{$ELSE}\r\nprocedure TSynEditStringList.SaveToStream(Stream: TStream; WithBOM: Boolean);\r\nbegin\r\n FStreaming := True;\r\n inherited;\r\n FStreaming := False;\r\nend;\r\n{$ENDIF}\r\n\r\nprocedure TSynEditStringList.Put(Index: integer; const S: UnicodeString);\r\nbegin\r\n if (Index = 0) and (fCount = 0) or (fCount = Index) then\r\n Add(S)\r\n else begin\r\n if Cardinal(Index)>=Cardinal(fCount) then\r\n ListIndexOutOfBounds(Index);\r\n BeginUpdate;\r\n fIndexOfLongestLine := -1;\r\n with fList^[Index] do begin\r\n Include(fFlags, sfExpandedLengthUnknown);\r\n Exclude(fFlags, sfHasTabs);\r\n Exclude(fFlags, sfHasNoTabs);\r\n {$IFDEF OWN_UnicodeString_MEMMGR}\r\n SetListString(Index, S);\r\n {$ELSE}\r\n fString := S;\r\n {$ENDIF OWN_UnicodeString_MEMMGR}\r\n end;\r\n if Assigned(fOnPutted) then\r\n fOnPutted( Self, Index, 1 );\r\n EndUpdate;\r\n end;\r\nend;\r\n\r\nprocedure TSynEditStringList.PutObject(Index: integer; AObject: TObject);\r\nbegin\r\n if Cardinal(Index)>=Cardinal(fCount) then\r\n ListIndexOutOfBounds(Index);\r\n BeginUpdate;\r\n fList^[Index].fObject := AObject;\r\n EndUpdate;\r\nend;\r\n\r\nprocedure TSynEditStringList.PutRange(Index: integer; ARange: TSynEditRange);\r\nbegin\r\n if Cardinal(Index)>=Cardinal(fCount) then\r\n ListIndexOutOfBounds(Index);\r\n BeginUpdate;\r\n fList^[Index].fRange := ARange;\r\n EndUpdate;\r\nend;\r\n\r\nprocedure TSynEditStringList.SetCapacity(NewCapacity: integer);\r\n{$IFDEF OWN_UnicodeString_MEMMGR}\r\nvar\r\n I : integer;\r\n{$ENDIF OWN_UnicodeString_MEMMGR}\r\nbegin\r\n if NewCapacity < Count then\r\n EListError.Create( SInvalidCapacity );\r\n ReallocMem(fList, NewCapacity * SynEditStringRecSize);\r\n {$IFDEF OWN_UnicodeString_MEMMGR}\r\n for I := fCount to NewCapacity - 1 do\r\n Pointer(fList[I].fString) := nil; // so that it does not get freed\r\n {$ENDIF OWN_UnicodeString_MEMMGR}\r\n fCapacity := NewCapacity;\r\nend;\r\n\r\nprocedure TSynEditStringList.SetFileFormat(const Value: TSynEditFileFormat);\r\nbegin\r\n fFileFormat := Value;\r\n{$IFDEF UNICODE}\r\n case FileFormat of\r\n sffDos:\r\n LineBreak := WideCRLF;\r\n sffUnix:\r\n LineBreak := WideLF;\r\n sffMac:\r\n LineBreak := WideCR;\r\n sffUnicode:\r\n LineBreak := WideLineSeparator;\r\n end;\r\n{$ENDIF}\r\nend;\r\n\r\n{$IFDEF OWN_UnicodeString_MEMMGR}\r\nprocedure TSynEditStringList.SetListString(Index: Integer; const S: UnicodeString);\r\nvar\r\n Len: Integer;\r\n A: TDynWideCharArray;\r\nbegin\r\n with FList[Index] do\r\n begin\r\n Pointer(A) := TDynWideCharArray(FString);\r\n if A <> nil then\r\n A := nil; // free memory\r\n\r\n Len := Length(S);\r\n if Len > 0 then\r\n begin\r\n SetLength(A, Len + 1); // include #0\r\n System.Move(S[1], A[0], Len * SizeOf(WideChar));\r\n A[Len] := #0;\r\n end;\r\n\r\n FString := PWideChar(A);\r\n Pointer(A) := nil; // do not release the array on procedure exit\r\n end;\r\nend;\r\n{$ENDIF OWN_UnicodeString_MEMMGR}\r\n\r\nprocedure TSynEditStringList.SetTabWidth(Value: integer);\r\nvar\r\n i: integer;\r\nbegin\r\n if Value <> fTabWidth then begin\r\n fTabWidth := Value;\r\n fConvertTabsProc := GetBestConvertTabsProcEx(fTabWidth);\r\n fIndexOfLongestLine := -1;\r\n for i := 0 to fCount - 1 do\r\n with fList^[i] do begin\r\n fExpandedLength := -1;\r\n Exclude(fFlags, sfHasNoTabs);\r\n Include(fFlags, sfExpandedLengthUnknown);\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TSynEditStringList.SetTextStr(const Value: UnicodeString);\r\nvar\r\n S: UnicodeString;\r\n Size: Integer;\r\n P, Start, Pmax: PWideChar;\r\n fCR, fLF, fLINESEPARATOR: Boolean;\r\nbegin\r\n fLINESEPARATOR := False;\r\n fCR := False;\r\n fLF := False;\r\n BeginUpdate;\r\n try\r\n Clear;\r\n P := Pointer(Value);\r\n if P <> nil then\r\n begin\r\n Size := Length(Value);\r\n Pmax := @Value[Size];\r\n while (P <= Pmax) do\r\n begin\r\n Start := P;\r\n while (P^ <> WideCR) and (P^ <> WideLF) and (P^ <> WideLineSeparator) and (P <= Pmax) do\r\n begin\r\n Inc(P);\r\n end;\r\n if P<>Start then\r\n begin\r\n SetString(S, Start, P - Start);\r\n InsertItem(fCount, S);\r\n end else InsertItem(fCount, '');\r\n if P^ = WideLineSeparator then\r\n begin\r\n fLINESEPARATOR := True;\r\n Inc(P);\r\n end;\r\n if P^ = WideCR then\r\n begin\r\n fCR := True;\r\n Inc(P);\r\n end;\r\n if P^ = WideLF then\r\n begin\r\n fLF := True;\r\n Inc(P);\r\n end;\r\n end;\r\n // keep the old format of the file\r\n if not AppendNewLineAtEOF and\r\n (CharInSet(Value[Size], [#10, #13]) or (Value[Size] = WideLineSeparator))\r\n then\r\n InsertItem(fCount, '');\r\n end;\r\n if Assigned(OnInserted) and (fCount > 0) then\r\n OnInserted(Self, 0, fCount);\r\n finally\r\n EndUpdate;\r\n end;\r\n if fLINESEPARATOR then\r\n FileFormat := sffUnicode\r\n else if fCR and not fLF then\r\n FileFormat := sffMac\r\n else if fLF and not fCR then\r\n FileFormat := sffUnix\r\n else\r\n FileFormat := sffDos;\r\nend;\r\n\r\nprocedure TSynEditStringList.SetUpdateState(Updating: Boolean);\r\nbegin\r\n FCharIndexesAreValid:=False;\r\n if Updating then begin\r\n if Assigned(fOnChanging) then\r\n fOnChanging(Self);\r\n end else begin\r\n if Assigned(fOnChange) then\r\n fOnChange(Self);\r\n end;\r\nend;\r\n\r\nprocedure TSynEditStringList.FontChanged;\r\nvar\r\n i: Integer;\r\nbegin\r\n fIndexOfLongestLine := -1;\r\n for i := 0 to fCount - 1 do\r\n with fList^[i] do\r\n begin\r\n fExpandedLength := -1;\r\n Exclude(fFlags, sfHasNoTabs);\r\n Include(fFlags, sfExpandedLengthUnknown);\r\n end;\r\nend;\r\n\r\n{ TSynEditUndoItem }\r\n\r\nprocedure TSynEditUndoItem.Assign(Source: TPersistent);\r\nbegin\r\n if (Source is TSynEditUndoItem) then\r\n begin\r\n fChangeReason:=TSynEditUndoItem(Source).fChangeReason;\r\n fChangeSelMode:=TSynEditUndoItem(Source).fChangeSelMode;\r\n fChangeStartPos:=TSynEditUndoItem(Source).fChangeStartPos;\r\n fChangeEndPos:=TSynEditUndoItem(Source).fChangeEndPos;\r\n fChangeStr:=TSynEditUndoItem(Source).fChangeStr;\r\n fChangeNumber:=TSynEditUndoItem(Source).fChangeNumber;\r\n end\r\n else\r\n inherited Assign(Source);\r\nend;\r\n\r\n\r\n{ TSynEditUndoList }\r\n\r\nconstructor TSynEditUndoList.Create;\r\nbegin\r\n inherited Create;\r\n fItems := TList.Create;\r\n fMaxUndoActions := 1024;\r\n fNextChangeNumber := 1;\r\n fInsideRedo := False;\r\nend;\r\n\r\ndestructor TSynEditUndoList.Destroy;\r\nbegin\r\n Clear;\r\n fItems.Free;\r\n inherited Destroy;\r\nend;\r\n\r\nprocedure TSynEditUndoList.Assign(Source: TPersistent);\r\nvar\r\n i: Integer;\r\n UndoItem: TSynEditUndoItem;\r\nbegin\r\n if (Source is TSynEditUndoList) then\r\n begin\r\n Clear;\r\n for i:=0 to TSynEditUndoList(Source).fItems.Count-1 do\r\n begin\r\n UndoItem:=TSynEditUndoItem.Create;\r\n UndoItem.Assign(TSynEditUndoList(Source).fItems[i]);\r\n fItems.Add(UndoItem);\r\n end;\r\n fBlockChangeNumber:=TSynEditUndoList(Source).fBlockChangeNumber;\r\n fBlockCount:=TSynEditUndoList(Source).fBlockCount;\r\n fFullUndoImposible:=TSynEditUndoList(Source).fFullUndoImposible;\r\n fLockCount:=TSynEditUndoList(Source).fLockCount;\r\n fMaxUndoActions:=TSynEditUndoList(Source).fMaxUndoActions;\r\n fNextChangeNumber:=TSynEditUndoList(Source).fNextChangeNumber;\r\n fInsideRedo:=TSynEditUndoList(Source).fInsideRedo;\r\n end\r\n else\r\n inherited Assign(Source);\r\nend;\r\n\r\nprocedure TSynEditUndoList.AddChange(AReason: TSynChangeReason; const AStart,\r\n AEnd: TBufferCoord; const ChangeText: UnicodeString; SelMode: TSynSelectionMode);\r\nvar\r\n NewItem: TSynEditUndoItem;\r\nbegin\r\n if fLockCount = 0 then begin\r\n NewItem := TSynEditUndoItem.Create;\r\n try\r\n with NewItem do begin\r\n fChangeReason := AReason;\r\n fChangeSelMode := SelMode;\r\n fChangeStartPos := AStart;\r\n fChangeEndPos := AEnd;\r\n fChangeStr := ChangeText;\r\n if fBlockChangeNumber <> 0 then\r\n fChangeNumber := fBlockChangeNumber\r\n else begin\r\n fChangeNumber := fNextChangeNumber;\r\n if fBlockCount = 0 then begin\r\n Inc(fNextChangeNumber);\r\n if fNextChangeNumber = 0 then\r\n Inc(fNextChangeNumber);\r\n end;\r\n end;\r\n end;\r\n PushItem(NewItem);\r\n except\r\n NewItem.Free;\r\n raise;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TSynEditUndoList.BeginBlock;\r\nbegin\r\n Inc(fBlockCount);\r\n fBlockChangeNumber := fNextChangeNumber;\r\nend;\r\n\r\nprocedure TSynEditUndoList.Clear;\r\nvar\r\n i: integer;\r\nbegin\r\n for i := 0 to fItems.Count - 1 do\r\n TSynEditUndoItem(fItems[i]).Free;\r\n fItems.Clear;\r\n fFullUndoImposible := False;\r\nend;\r\n\r\nprocedure TSynEditUndoList.EndBlock;\r\nvar\r\n iBlockID: integer;\r\nbegin\r\n if fBlockCount > 0 then begin\r\n Dec(fBlockCount);\r\n if fBlockCount = 0 then begin\r\n iBlockID := fBlockChangeNumber;\r\n fBlockChangeNumber := 0;\r\n Inc(fNextChangeNumber);\r\n if fNextChangeNumber = 0 then\r\n Inc(fNextChangeNumber);\r\n if (fItems.Count > 0) and (PeekItem.ChangeNumber = iBlockID) and\r\n Assigned(OnAddedUndo) then\r\n begin\r\n OnAddedUndo( Self );\r\n end;\r\n end;\r\n end;\r\nend;\r\n\r\nprocedure TSynEditUndoList.EnsureMaxEntries;\r\nvar\r\n Item: TSynEditUndoItem;\r\nbegin\r\n if fItems.Count > fMaxUndoActions then \r\n begin\r\n fFullUndoImposible := True; \r\n while fItems.Count > fMaxUndoActions do begin\r\n Item := fItems[0];\r\n Item.Free;\r\n fItems.Delete(0);\r\n end;\r\n end;\r\nend;\r\n\r\nfunction TSynEditUndoList.GetCanUndo: boolean;\r\nbegin\r\n Result := fItems.Count > 0;\r\nend;\r\n\r\nfunction TSynEditUndoList.GetItemCount: integer;\r\nbegin\r\n Result := fItems.Count;\r\nend;\r\n\r\nprocedure TSynEditUndoList.Lock;\r\nbegin\r\n Inc(fLockCount);\r\nend;\r\n\r\nfunction TSynEditUndoList.PeekItem: TSynEditUndoItem;\r\nvar\r\n iLast: integer;\r\nbegin\r\n Result := nil;\r\n iLast := fItems.Count - 1;\r\n if iLast >= 0 then\r\n Result := fItems[iLast];\r\nend;\r\n\r\nfunction TSynEditUndoList.PopItem: TSynEditUndoItem;\r\nvar\r\n iLast: integer;\r\nbegin\r\n Result := nil;\r\n iLast := fItems.Count - 1;\r\n if iLast >= 0 then begin\r\n Result := fItems[iLast];\r\n fItems.Delete(iLast);\r\n end;\r\nend;\r\n\r\nprocedure TSynEditUndoList.PushItem(Item: TSynEditUndoItem);\r\nbegin\r\n if Assigned(Item) then begin\r\n fItems.Add(Item);\r\n EnsureMaxEntries;\r\n if (Item.ChangeReason <> crGroupBreak) and Assigned(OnAddedUndo) then\r\n OnAddedUndo(Self);\r\n end;\r\nend;\r\n\r\nprocedure TSynEditUndoList.SetMaxUndoActions(Value: integer);\r\nbegin\r\n if Value < 0 then\r\n Value := 0;\r\n if Value <> fMaxUndoActions then begin\r\n fMaxUndoActions := Value;\r\n EnsureMaxEntries;\r\n end;\r\nend;\r\n\r\nprocedure TSynEditUndoList.Unlock;\r\nbegin\r\n if fLockCount > 0 then\r\n Dec(fLockCount);\r\nend;\r\n\r\nfunction TSynEditUndoList.LastChangeReason: TSynChangeReason;\r\nbegin\r\n if fItems.Count = 0 then\r\n result := crNothing\r\n else\r\n result := TSynEditUndoItem(fItems[fItems.Count - 1]).fChangeReason;\r\nend;\r\n\r\nprocedure TSynEditUndoList.AddGroupBreak;\r\nvar\r\n vDummy: TBufferCoord;\r\nbegin\r\n //Add the GroupBreak even if ItemCount = 0. Since items are stored in\r\n //reverse order in TCustomSynEdit.fRedoList, a GroupBreak could be lost.\r\n if LastChangeReason <> crGroupBreak then\r\n begin\r\n AddChange(crGroupBreak, vDummy, vDummy, '', smNormal);\r\n end;\r\nend;\r\n\r\nprocedure TSynEditUndoList.SetInitialState(const Value: boolean);\r\nbegin\r\n if Value then\r\n begin\r\n if ItemCount = 0 then\r\n fInitialChangeNumber := 0\r\n else\r\n fInitialChangeNumber := PeekItem.ChangeNumber;\r\n end\r\n else\r\n if ItemCount = 0 then\r\n begin\r\n if fInitialChangeNumber = 0 then\r\n fInitialChangeNumber := -1;\r\n end\r\n else if PeekItem.ChangeNumber = fInitialChangeNumber then\r\n fInitialChangeNumber := -1;\r\nend;\r\n\r\nfunction TSynEditUndoList.GetInitialState: boolean;\r\nbegin\r\n if ItemCount = 0 then\r\n Result := fInitialChangeNumber = 0\r\n else\r\n Result := PeekItem.ChangeNumber = fInitialChangeNumber;\r\nend;\r\n\r\nfunction TSynEditUndoList.GetItems(Index: Integer): TSynEditUndoItem;\r\nbegin\r\n Result := TSynEditUndoItem(fItems[Index]);\r\nend;\r\n\r\nprocedure TSynEditUndoList.SetItems(Index: Integer;\r\n const Value: TSynEditUndoItem);\r\nbegin\r\n fItems[Index] := Value;\r\nend;\r\n\r\nprocedure TSynEditUndoList.DeleteItem(AIndex: Integer);\r\nbegin\r\n TSynEditUndoItem(fItems[AIndex]).Free;\r\n fItems.Delete(AIndex);\r\nend;\r\n\r\nend.\r\n" }, { "path": "External/SynEdit/Source/SynEditTypes.pas", "content": "{-------------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: SynEditTypes.pas, released 2000-04-07.\r\nThe Original Code is based on parts of mwCustomEdit.pas by Martin Waldenburg,\r\npart of the mwEdit component suite.\r\nPortions created by Martin Waldenburg are Copyright (C) 1998 Martin Waldenburg.\r\nUnicode translation by Mal Hrz.\r\nAll Rights Reserved.\r\n\r\nContributors to the SynEdit and mwEdit projects are listed in the\r\nContributors.txt file.\r\n\r\nAlternatively, the contents of this file may be used under the terms of the\r\nGNU General Public License Version 2 or later (the \"GPL\"), in which case\r\nthe provisions of the GPL are applicable instead of those above.\r\nIf you wish to allow use of your version of this file only under the terms\r\nof the GPL and not to allow others to use your version of this file\r\nunder the MPL, indicate your decision by deleting the provisions above and\r\nreplace them with the notice and other provisions required by the GPL.\r\nIf you do not delete the provisions above, a recipient may use your version\r\nof this file under either the MPL or the GPL.\r\n\r\n$Id: SynEditTypes.pas,v 1.13.2.2 2012/09/17 14:17:25 CodehunterWorks Exp $\r\n\r\nYou may retrieve the latest version of this file at the SynEdit home page,\r\nlocated at http://SynEdit.SourceForge.net\r\n\r\nKnown Issues:\r\n-------------------------------------------------------------------------------}\r\n\r\n{$IFNDEF QSYNEDITTYPES}\r\nunit SynEditTypes;\r\n{$ENDIF}\r\n\r\n{$I SynEdit.inc}\r\n\r\ninterface\r\n\r\nuses\r\n SysUtils;\r\n\r\nconst\r\n// These might need to be localized depending on the characterset because they might be\r\n// interpreted as valid ident characters.\r\n SynTabGlyph = WideChar($2192); //'->'\r\n SynSoftBreakGlyph = WideChar($00AC); //''\r\n SynLineBreakGlyph = WideChar($00B6); //''\r\n SynSpaceGlyph = WideChar($2219); //''\r\n\r\ntype\r\n ESynError = class(Exception);\r\n\r\n TSynSearchOption = (ssoMatchCase, ssoWholeWord, ssoBackwards,\r\n ssoEntireScope, ssoSelectedOnly, ssoReplace, ssoReplaceAll, ssoPrompt);\r\n TSynSearchOptions = set of TSynSearchOption;\r\n\r\n TCategoryMethod = function(AChar: WideChar): Boolean of object;\r\n\r\n TKeyPressWEvent = procedure(Sender: TObject; var Key: WideChar) of object;\r\n\r\n PSynSelectionMode = ^TSynSelectionMode;\r\n TSynSelectionMode = (smNormal, smLine, smColumn);\r\n\r\n PBorlandSelectionMode = ^TBorlandSelectionMode;\r\n TBorlandSelectionMode = (\r\n bsmInclusive, // selects inclusive blocks. Borland IDE shortcut: Ctrl+O+I\r\n bsmLine, // selects line blocks. Borland IDE shortcut: Ctrl+O+L\r\n bsmColumn, // selects column blocks. Borland IDE shortcut: Ctrl+O+C\r\n bsmNormal // selects normal Block. Borland IDE shortcut: Ctrl+O+K\r\n );\r\n\r\n //todo: better field names. CharIndex and LineIndex?\r\n TBufferCoord = record\r\n Char: integer;\r\n Line: integer;\r\n end;\r\n\r\n // Codehunter patch: added TBufferBlock\r\n TBufferBlock = record\r\n BeginLine,\r\n BeginChar,\r\n EndLine,\r\n EndChar: Integer;\r\n end;\r\n\r\n TDisplayCoord = record\r\n Column: integer;\r\n Row: integer;\r\n end;\r\n\r\nfunction DisplayCoord(AColumn, ARow: Integer): TDisplayCoord;\r\nfunction BufferCoord(AChar, ALine: Integer): TBufferCoord;\r\n\r\nimplementation\r\n\r\nfunction DisplayCoord(AColumn, ARow: Integer): TDisplayCoord;\r\nbegin\r\n Result.Column := AColumn;\r\n Result.Row := ARow;\r\nend;\r\n\r\nfunction BufferCoord(AChar, ALine: Integer): TBufferCoord;\r\nbegin\r\n Result.Char := AChar;\r\n Result.Line := ALine;\r\nend;\r\n\r\nend.\r\n" }, { "path": "External/SynEdit/Source/SynEditWildcardSearch.pas", "content": "{-------------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: SynEditWildcardSearch.pas, released 2003-06-21.\r\n\r\nThe original author of this file is Michael Elsdoerfer.\r\nUnicode translation by Mal Hrz.\r\nAll Rights Reserved.\r\n\r\nContributors to the SynEdit project are listed in the Contributors.txt file.\r\n\r\nAlternatively, the contents of this file may be used under the terms of the\r\nGNU General Public License Version 2 or later (the \"GPL\"), in which case\r\nthe provisions of the GPL are applicable instead of those above.\r\nIf you wish to allow use of your version of this file only under the terms\r\nof the GPL and not to allow others to use your version of this file\r\nunder the MPL, indicate your decision by deleting the provisions above and\r\nreplace them with the notice and other provisions required by the GPL.\r\nIf you do not delete the provisions above, a recipient may use your version\r\nof this file under either the MPL or the GPL.\r\n\r\n$Id: SynEditWildcardSearch.pas,v 1.2.2.2 2008/09/14 16:24:59 maelh Exp $\r\n\r\nYou may retrieve the latest version of this file at the SynEdit home page,\r\nlocated at http://SynEdit.SourceForge.net\r\n\r\nKnown Issues:\r\n-------------------------------------------------------------------------------}\r\n\r\n{$IFNDEF QSYNEDITWILDCARDSEARCH}\r\nunit SynEditWildcardSearch;\r\n{$ENDIF}\r\n\r\n{$I SynEdit.inc}\r\n\r\ninterface\r\n\r\nuses\r\n{$IFDEF SYN_CLX}\r\n QSynEdit,\r\n QSynEditTypes,\r\n QSynRegExpr,\r\n QSynEditMiscClasses,\r\n QSynEditRegexSearch\r\n{$ELSE}\r\n SynEdit,\r\n SynEditTypes,\r\n SynRegExpr,\r\n SynEditRegexSearch,\r\n{$ENDIF}\r\n Classes;\r\n\r\ntype\r\n TSynEditWildcardSearch = class(TSynEditRegexSearch)\r\n private\r\n fPattern: UnicodeString;\r\n protected\r\n function GetPattern: UnicodeString; override;\r\n procedure SetPattern(const Value: UnicodeString); override;\r\n procedure SetOptions(const Value: TSynSearchOptions); override;\r\n function GetLength(Index: Integer): Integer; override;\r\n function GetResult(Index: Integer): Integer; override;\r\n function GetResultCount: Integer; override;\r\n // Converts the Wildcard to a regular expression\r\n function WildCardToRegExpr(AWildCard: UnicodeString): UnicodeString;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n destructor Destroy; override;\r\n function FindAll(const NewText: UnicodeString): Integer; override;\r\n function Replace(const aOccurrence, aReplacement: UnicodeString): UnicodeString; override; //slm 11/29/02\r\n end;\r\n\r\nimplementation\r\n\r\nuses\r\n{$IFDEF SYN_CLX}\r\n QConsts;\r\n{$ELSE}\r\n Consts;\r\n{$ENDIF}\r\n\r\n{ TSynEditWildcardSearch }\r\n\r\nconstructor TSynEditWildcardSearch.Create(AOwner: TComponent);\r\nbegin\r\n inherited Create(AOwner);\r\n fPattern := '';\r\nend;\r\n\r\ndestructor TSynEditWildcardSearch.Destroy;\r\nbegin\r\n inherited;\r\nend;\r\n\r\nfunction TSynEditWildcardSearch.FindAll(const NewText: UnicodeString): integer;\r\nbegin\r\n Result := inherited FindAll(NewText);\r\nend;\r\n\r\nfunction TSynEditWildcardSearch.Replace(const aOccurrence, aReplacement: UnicodeString): UnicodeString;\r\nbegin\r\n Result := inherited Replace(aOccurrence, aReplacement);\r\nend; \r\n\r\nfunction TSynEditWildcardSearch.GetLength(Index: Integer): Integer;\r\nbegin\r\n Result := inherited GetLength(Index);\r\nend;\r\n\r\nfunction TSynEditWildcardSearch.GetPattern: UnicodeString;\r\nbegin\r\n Result := fPattern;\r\nend;\r\n\r\nfunction TSynEditWildcardSearch.GetResult(Index: integer): integer;\r\nbegin\r\n Result := inherited GetResult(Index);\r\nend;\r\n\r\nfunction TSynEditWildcardSearch.GetResultCount: integer;\r\nbegin\r\n Result := inherited GetResultCount;\r\nend;\r\n\r\nprocedure TSynEditWildcardSearch.SetOptions(const Value: TSynSearchOptions);\r\nbegin\r\n inherited;\r\nend;\r\n\r\nprocedure TSynEditWildcardSearch.SetPattern(const Value: UnicodeString);\r\nbegin\r\n fPattern := Value;\r\n // Convert into a real regular expression and assign it\r\n inherited SetPattern(WildCardToRegExpr(Value));\r\nend;\r\n\r\nfunction TSynEditWildcardSearch.WildCardToRegExpr(\r\n AWildCard: UnicodeString): UnicodeString;\r\nvar\r\n i: Integer;\r\nbegin\r\n Result := '';\r\n\r\n for i := 1 to Length(AWildCard) do\r\n case AWildCard[i] of\r\n '*': Result := Result + '.*';\r\n '?': Result := Result + '.?';\r\n else Result := Result + AWildCard[i];\r\n end;\r\nend;\r\n\r\nend.\r\n\r\n" }, { "path": "External/SynEdit/Source/SynEditWordWrap.pas", "content": "{-------------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is SynEditWordWrap.pas by Flvio Etrusco, released 2003-12-11.\r\nUnicode translation by Mal Hrz.\r\nAll Rights Reserved.\r\n\r\nContributors to the SynEdit and mwEdit projects are listed in the\r\nContributors.txt file.\r\n\r\nAlternatively, the contents of this file may be used under the terms of the\r\nGNU General Public License Version 2 or later (the \"GPL\"), in which case\r\nthe provisions of the GPL are applicable instead of those above.\r\nIf you wish to allow use of your version of this file only under the terms\r\nof the GPL and not to allow others to use your version of this file\r\nunder the MPL, indicate your decision by deleting the provisions above and\r\nreplace them with the notice and other provisions required by the GPL.\r\nIf you do not delete the provisions above, a recipient may use your version\r\nof this file under either the MPL or the GPL.\r\n\r\n$Id: SynEditWordWrap.pas,v 1.8.2.6 2008/09/14 16:24:59 maelh Exp $\r\n\r\nYou may retrieve the latest version of this file at the SynEdit home page,\r\nlocated at http://SynEdit.SourceForge.net\r\n\r\nKnown Issues:\r\n-------------------------------------------------------------------------------}\r\n//todo: Use a single implementation of ReWrapLines that takes starting line and number of lines to rewrap\r\n//todo: Tweak code to try finding better wrapping points. Some support by the highlighters will be needed, probably.\r\n//todo: Document the code\r\n//todo: The length of the last Row of a Line could be calculated from the Line length instead of being stored. This would be only useful when most of the lines aren't wrapped.\r\n\r\n{$IFNDEF QSYNEDITWORDWRAP}\r\nunit SynEditWordWrap;\r\n{$ENDIF}\r\n\r\n{$I SynEdit.inc}\r\n\r\ninterface\r\n\r\nuses\r\n{$IFDEF SYN_CLX}\r\n QSynEditTypes,\r\n QSynEditTextBuffer,\r\n QSynEdit,\r\n{$ELSE}\r\n SynEditTypes,\r\n SynEditTextBuffer,\r\n SynEdit,\r\n{$ENDIF}\r\n SysUtils,\r\n Classes;\r\n\r\nvar\r\n // Accumulate/hide whitespace at EOL (at end of wrapped rows, actually)\r\n OldWhitespaceBehaviour: Boolean = False;\r\n\r\nconst\r\n MaxIndex = MaxInt div 16;\r\n\r\ntype\r\n TLineIndex = 0..MaxIndex;\r\n TRowIndex = 0..MaxIndex;\r\n TRowLength = word;\r\n\r\n TRowIndexArray = array [TLineIndex] of TRowIndex;\r\n PRowIndexArray = ^TRowIndexArray;\r\n\r\n TRowLengthArray = array [TRowIndex] of TRowLength;\r\n PRowLengthArray = ^TRowLengthArray;\r\n\r\n {$IFNDEF SYN_COMPILER_4_UP}\r\n TSysCharSet = set of Char;\r\n {$ENDIF}\r\n\r\n // For clarity, I'll refer to buffer coordinates as 'Line' and\r\n // 'Char' and to display (wrapped) coordinates as 'Row' and 'Column'.\r\n\r\n // fLineOffsets[n] is the index of the first row of the [n+1]th line.\r\n // e.g. Starting row of first line (0) is 0. Starting row of second line (1)\r\n // is fLineOffsets[0]. Clear?\r\n\r\n TSynWordWrapPlugin = class(TInterfacedObject, ISynEditBufferPlugin)\r\n private\r\n fLineOffsets: PRowIndexArray;\r\n fRowLengths: PRowLengthArray;\r\n fLineCapacity: integer;\r\n fRowCapacity: integer;\r\n fLineCount: integer;\r\n\r\n fEditor: TCustomSynEdit;\r\n fMinRowLength: TRowLength;\r\n fMaxRowLength: TRowLength;\r\n procedure GrowLines(aMinSize: integer);\r\n procedure MoveLines(aStart: TLineIndex; aMoveBy: integer);\r\n procedure GrowRows(aMinSize: integer);\r\n procedure MoveRows(aStart: TRowIndex; aMoveBy: integer);\r\n procedure SetEmpty;\r\n protected\r\n procedure WrapLines;\r\n function ReWrapLine(aIndex: TLineIndex): integer;\r\n procedure TrimArrays;\r\n property LineOffsets: PRowIndexArray read fLineOffsets;\r\n property RowLengths: PRowLengthArray read fRowLengths;\r\n property Editor: TCustomSynEdit read fEditor;\r\n public\r\n constructor Create(aOwner: TCustomSynEdit);\r\n destructor Destroy; override;\r\n property LineCount: integer read fLineCount;\r\n { ISynEditBufferPlugin }\r\n function BufferToDisplayPos(const aPos: TBufferCoord): TDisplayCoord;\r\n function DisplayToBufferPos(const aPos: TDisplayCoord): TBufferCoord;\r\n function RowCount: integer;\r\n function GetRowLength(aRow: integer): integer;\r\n function LinesInserted(aIndex: integer; aCount: integer): integer;\r\n function LinesDeleted(aIndex: integer; aCount: integer): integer;\r\n function LinesPutted(aIndex: integer; aCount: integer): integer;\r\n procedure Reset;\r\n procedure DisplayChanged; \r\n end;\r\n\r\nimplementation\r\n\r\nuses\r\n{$IFDEF SYN_CLX}\r\n QSynUnicode,\r\n{$ELSE}\r\n SynUnicode,\r\n{$ENDIF}\r\n{$IFDEF SYN_COMPILER_6_UP}\r\n RTLConsts,\r\n{$ELSE}\r\n {$IFDEF SYN_CLX}\r\n QConsts,\r\n {$ELSE}\r\n Consts,\r\n {$ENDIF}\r\n{$ENDIF}\r\n{$IFNDEF SYN_COMPILER_4_UP}\r\n SynEditMiscProcs,\r\n{$ENDIF}\r\n Math;\r\n\r\n{ TSynWordWrapPlugin }\r\n\r\nfunction TSynWordWrapPlugin.BufferToDisplayPos(\r\n const aPos: TBufferCoord): TDisplayCoord;\r\nvar\r\n vStartRow: integer; // first row of the line\r\n cRow: integer;\r\n vRowLen: integer;\r\nbegin\r\n Assert(aPos.Char > 0);\r\n Assert(aPos.Line > 0);\r\n if LineCount < aPos.Line then\r\n begin\r\n // beyond EOF\r\n Result.Column := aPos.Char;\r\n Result.Row := RowCount + (aPos.Line - LineCount);\r\n Exit;\r\n end;\r\n if aPos.Line = 1 then\r\n vStartRow := 0\r\n else\r\n vStartRow := fLineOffsets[aPos.Line - 2];\r\n vRowLen := 0;\r\n for cRow := vStartRow to fLineOffsets[aPos.Line - 1] - 1 do\r\n begin\r\n Inc(vRowLen, fRowLengths[cRow]);\r\n if aPos.Char <= vRowLen then\r\n begin\r\n Result.Column := aPos.Char - vRowLen + fRowLengths[cRow];\r\n Result.Row := cRow + 1;\r\n Exit;\r\n end;\r\n end;\r\n // beyond EOL\r\n Result.Column := aPos.Char - vRowLen + fRowLengths[fLineOffsets[aPos.Line - 1] - 1];\r\n Result.Row := fLineOffsets[aPos.Line - 1];\r\nend;\r\n\r\nconstructor TSynWordWrapPlugin.Create(aOwner: TCustomSynEdit);\r\nbegin\r\n inherited Create; // just to work as reminder in case I revert it to a TComponent... \r\n if aOwner = nil then\r\n raise Exception.Create( 'Owner of TSynWordWrapPlugin must be a TCustomSynEdit' );\r\n fEditor := aOwner;\r\n Reset;\r\nend;\r\n\r\ndestructor TSynWordWrapPlugin.Destroy;\r\nbegin\r\n inherited;\r\n FreeMem(fLineOffsets);\r\n FreeMem(fRowLengths);\r\nend;\r\n\r\nprocedure TSynWordWrapPlugin.DisplayChanged;\r\nbegin\r\n if Editor.CharsInWindow <> fMaxRowLength then\r\n Reset;\r\nend;\r\n\r\nfunction TSynWordWrapPlugin.DisplayToBufferPos(\r\n const aPos: TDisplayCoord): TBufferCoord;\r\nvar\r\n cLine: integer;\r\n cRow: integer;\r\nbegin\r\n Assert(aPos.Column > 0);\r\n Assert(aPos.Row > 0);\r\n if aPos.Row > RowCount then\r\n begin\r\n // beyond EOF\r\n Result.Char := aPos.Column;\r\n Result.Line := aPos.Row - RowCount + LineCount;\r\n Exit;\r\n end;\r\n //todo: use a binary search or something smarter\r\n for cLine := LineCount - 2 downto 0 do\r\n if aPos.Row > fLineOffsets[cLine] then\r\n begin\r\n Result.Line := cLine + 2;\r\n if aPos.Row = fLineOffsets[cLine + 1] then //last row of line\r\n Result.Char := Min(aPos.Column, fMaxRowLength + 1)\r\n else\r\n Result.Char := Min(aPos.Column, fRowLengths[aPos.Row - 1] + 1);\r\n for cRow := fLineOffsets[cLine] to aPos.Row - 2 do\r\n Inc(Result.Char, fRowLengths[cRow]);\r\n Exit;\r\n end;\r\n // first line\r\n Result.Line := 1;\r\n if aPos.Row = fLineOffsets[0] then //last row of line\r\n Result.Char := Min(aPos.Column, fMaxRowLength + 1)\r\n else\r\n Result.Char := Min(aPos.Column, fRowLengths[aPos.Row - 1] + 1);\r\n for cRow := 0 to aPos.Row - 2 do\r\n Inc(Result.Char, fRowLengths[cRow]);\r\nend;\r\n\r\nfunction TSynWordWrapPlugin.GetRowLength(aRow: integer): integer;\r\n// aRow is 1-based...\r\nbegin\r\n if (aRow <= 0) or (aRow > RowCount) then\r\n TList.Error(SListIndexError, aRow);\r\n Result := fRowLengths[aRow - 1];\r\nend;\r\n\r\nprocedure TSynWordWrapPlugin.GrowLines(aMinSize: integer);\r\nconst\r\n vStepSize = 256;\r\nbegin\r\n Assert(aMinSize > 0);\r\n if aMinSize > fLineCapacity then\r\n begin\r\n aMinSize := aMinSize + vStepSize - (aMinSize mod vStepSize);\r\n ReallocMem(fLineOffsets, aMinSize * SizeOf(TRowIndex));\r\n fLineCapacity := aMinSize;\r\n end;\r\nend;\r\n\r\nprocedure TSynWordWrapPlugin.GrowRows(aMinSize: integer);\r\nconst\r\n vStepSize = 512;\r\nbegin\r\n Assert(aMinSize > 0);\r\n if aMinSize > fRowCapacity then\r\n begin\r\n aMinSize := aMinSize + vStepSize - (aMinSize mod vStepSize);\r\n ReallocMem(fRowLengths, aMinSize * SizeOf(TRowLength));\r\n fRowCapacity := aMinSize;\r\n end;\r\nend;\r\n\r\nfunction TSynWordWrapPlugin.LinesDeleted(aIndex: integer; aCount: integer): integer;\r\nvar\r\n vStartRow: integer;\r\n vEndRow: integer;\r\n cLine: integer;\r\nbegin\r\n if fMaxRowLength = 0 then\r\n begin\r\n Result := 0;\r\n Exit;\r\n end;\r\n Assert(aIndex >= 0);\r\n Assert(aCount >= 1);\r\n Assert(aIndex + aCount <= LineCount);\r\n\r\n if aIndex = 0 then\r\n vStartRow := 0\r\n else\r\n vStartRow := fLineOffsets[aIndex - 1];\r\n vEndRow := fLineOffsets[aIndex + aCount - 1];\r\n Result := vEndRow - vStartRow;\r\n // resize fRowLengths\r\n if vEndRow < RowCount then\r\n MoveRows(vEndRow, -Result);\r\n // resize fLineOffsets\r\n MoveLines(aIndex + aCount, -aCount);\r\n Dec(fLineCount, aCount);\r\n // update offsets\r\n for cLine := aIndex to LineCount - 1 do\r\n Dec(fLineOffsets[cLine], Result);\r\nend;\r\n\r\nfunction TSynWordWrapPlugin.LinesInserted(aIndex: integer; aCount: integer): integer;\r\nvar\r\n vPrevOffset: TRowIndex;\r\n cLine: integer;\r\nbegin\r\n if fMaxRowLength = 0 then\r\n begin\r\n Result := 0;\r\n Exit;\r\n end;\r\n Assert(aIndex >= 0);\r\n Assert(aCount >= 1);\r\n Assert(aIndex <= LineCount);\r\n // resize fLineOffsets\r\n GrowLines(LineCount + aCount);\r\n if aIndex < LineCount then // no need for MoveLines if inserting at LineCount (TSynEditStringList.Add)\r\n begin\r\n Inc(fLineCount, aCount); // fLineCount must be updated before calling MoveLines()\r\n MoveLines(aIndex, aCount);\r\n end\r\n else\r\n Inc(fLineCount, aCount); \r\n // set offset to same as previous line (i.e. the line has 0 rows)\r\n if aIndex = 0 then\r\n vPrevOffset := 0\r\n else\r\n vPrevOffset := fLineOffsets[aIndex - 1];\r\n for cLine := aIndex to aIndex + aCount - 1 do\r\n fLineOffsets[cLine] := vPrevOffset;\r\n // Rewrap\r\n Result := 0;\r\n for cLine := aIndex to aIndex + aCount - 1 do\r\n Inc(Result, ReWrapLine(cLine));\r\nend;\r\n\r\nfunction TSynWordWrapPlugin.LinesPutted(aIndex: integer; aCount: integer): integer;\r\nvar\r\n cLine: integer;\r\nbegin\r\n if fMaxRowLength = 0 then\r\n begin\r\n Result := 0;\r\n Exit;\r\n end;\r\n Assert(aIndex >= 0);\r\n Assert(aCount >= 1);\r\n Assert(aIndex + aCount <= LineCount);\r\n // Rewrap\r\n Result := 0;\r\n for cLine := aIndex to aIndex + aCount - 1 do\r\n Inc(Result, ReWrapLine(cLine));\r\nend;\r\n\r\nprocedure TSynWordWrapPlugin.MoveLines(aStart: TLineIndex; aMoveBy: integer);\r\nvar\r\n vMoveCount: integer;\r\nbegin\r\n Assert(aMoveBy <> 0);\r\n Assert(aStart + aMoveBy >= 0);\r\n Assert(aStart + aMoveBy < LineCount);\r\n vMoveCount := LineCount - aStart;\r\n if aMoveBy > 0 then\r\n Dec(vMoveCount, aMoveBy);\r\n Move(fLineOffsets[aStart], fLineOffsets[aStart + aMoveBy],\r\n vMoveCount * SizeOf(TRowIndex));\r\nend;\r\n\r\nprocedure TSynWordWrapPlugin.MoveRows(aStart: TRowIndex; aMoveBy: integer);\r\nvar\r\n vMoveCount: integer;\r\nbegin\r\n Assert(aMoveBy <> 0);\r\n Assert(aStart + aMoveBy >= 0);\r\n Assert(aStart + aMoveBy < RowCount);\r\n vMoveCount := RowCount - aStart;\r\n if aMoveBy > 0 then\r\n Dec(vMoveCount, aMoveBy);\r\n Move(fRowLengths[aStart], fRowLengths[aStart + aMoveBy],\r\n vMoveCount * SizeOf(TRowLength));\r\nend;\r\n\r\nprocedure TSynWordWrapPlugin.Reset;\r\nbegin\r\n Assert(Editor.CharsInWindow >= 0);\r\n\r\n fMaxRowLength := Editor.CharsInWindow;\r\n fMinRowLength := Editor.CharsInWindow - (Editor.CharsInWindow div 3);\r\n\r\n if fMinRowLength <= 0 then\r\n fMinRowLength := 1;\r\n\r\n WrapLines;\r\nend;\r\n\r\nfunction TSynWordWrapPlugin.ReWrapLine(aIndex: TLineIndex): integer;\r\n// Returns RowCount delta (how many wrapped lines were added or removed by this change).\r\nvar\r\n vMaxNewRows: Cardinal;\r\n vLine: UnicodeString;\r\n vLineRowCount: Integer; //numbers of rows parsed in this line\r\n vTempRowLengths: PRowLengthArray;\r\n vRowBegin: PWideChar;\r\n vLineEnd: PWideChar;\r\n vRowEnd: PWideChar;\r\n vRunner: PWideChar;\r\n vRowMinEnd: PWideChar;\r\n vLastVisibleChar: PWideChar;\r\n\r\n vStartRow: Integer; // first row of the line\r\n vOldNextRow: Integer; // first row of the next line, before the change\r\n cLine: Integer;\r\n\r\n p : PRowIndexArray;\r\nbegin\r\n // ****** First parse the new string using an auxiliar array *****\r\n vLine := TSynEditStringList(Editor.Lines).ExpandedStrings[aIndex];\r\n vLine := Editor.ExpandAtWideGlyphs(vLine);\r\n // Pre-allocate a buffer for rowlengths\r\n vMaxNewRows := ((Length(vLine) - 1) div fMinRowLength) + 1;\r\n vTempRowLengths := AllocMem(vMaxNewRows * SizeOf(TRowLength));\r\n try\r\n vLineRowCount := 0;\r\n vRowBegin := PWideChar(vLine);\r\n vRowEnd := vRowBegin + fMaxRowLength;\r\n vLineEnd := vRowBegin + Length(vLine);\r\n while vRowEnd < vLineEnd do\r\n begin\r\n if OldWhitespaceBehaviour and CharInSet(vRowEnd^, [#32, #9]) then\r\n begin\r\n repeat\r\n Inc(vRowEnd);\r\n until not CharInSet(vRowEnd^, [#32, #9]);\r\n end\r\n else\r\n begin\r\n vRowMinEnd := vRowBegin + fMinRowLength;\r\n vRunner := vRowEnd;\r\n while vRunner > vRowMinEnd do\r\n begin\r\n if Editor.IsWordBreakChar(vRunner^) then\r\n begin\r\n vRowEnd := vRunner;\r\n break;\r\n end;\r\n Dec(vRunner);\r\n end;\r\n end;\r\n // Check TRowLength overflow\r\n if OldWhitespaceBehaviour and (vRowEnd - vRowBegin > High(TRowLength)) then\r\n begin\r\n vRowEnd := vRowBegin + High(TRowLength);\r\n vRowMinEnd := vRowEnd - (High(TRowLength) mod Editor.TabWidth);\r\n while (vRowEnd^ = #9) and (vRowEnd > vRowMinEnd) do\r\n Dec(vRowEnd);\r\n end;\r\n\r\n // do not cut wide glyphs in half\r\n if vRowEnd > vRowBegin then\r\n begin\r\n vLastVisibleChar := vRowEnd - 1;\r\n while (vLastVisibleChar^ = FillerChar) and (vLastVisibleChar > vRowBegin) do\r\n dec(vLastVisibleChar);\r\n vRowEnd := vLastVisibleChar + 1;\r\n end;\r\n\r\n // Finally store the rowlength\r\n vTempRowLengths[vLineRowCount] := vRowEnd - vRowBegin;\r\n\r\n Inc(vLineRowCount);\r\n vRowBegin := vRowEnd;\r\n Inc(vRowEnd, fMaxRowLength);\r\n end; //endwhile vRowEnd < vLineEnd\r\n if (vLineEnd > vRowBegin) or (Length(vLine) = 0) then\r\n begin\r\n vTempRowLengths[vLineRowCount] := vLineEnd - vRowBegin;\r\n Inc(vLineRowCount);\r\n end;\r\n\r\n // ****** Then updates the main arrays ******\r\n if aIndex = 0 then\r\n vStartRow := 0\r\n else\r\n vStartRow := fLineOffsets[aIndex - 1];\r\n vOldNextRow := fLineOffsets[aIndex];\r\n Result := vLineRowCount - (vOldNextRow - vStartRow);\r\n if Result <> 0 then\r\n begin\r\n // MoveRows depends on RowCount, so we need some special processing...\r\n if Result > 0 then\r\n begin\r\n // ...if growing, update offsets (and thus RowCount) before rowlengths\r\n GrowRows(RowCount + Result);\r\n if Result = 1 then begin\r\n // EG: this makes Schlemiel run twice as fast, but doesn't solve\r\n // the algorithmic issue if someone can spend some time looking\r\n // at the big picture... there are huge speedups to be made by\r\n // eliminating this loop\r\n p:=fLineOffsets;\r\n for cLine := aIndex to LineCount - 1 do\r\n Inc(p[cLine])\r\n end else begin\r\n p:=fLineOffsets;\r\n for cLine := aIndex to LineCount - 1 do\r\n Inc(p[cLine], Result);\r\n end;\r\n if vOldNextRow < RowCount - Result then\r\n MoveRows(vOldNextRow, Result);\r\n end\r\n else\r\n begin\r\n // ...if shrinking, update offsets after rowlengths\r\n if vOldNextRow < RowCount then\r\n MoveRows(vOldNextRow, Result);\r\n for cLine := aIndex to LineCount - 1 do\r\n Inc(fLineOffsets[cLine], Result);\r\n end;\r\n end;\r\n Move(vTempRowLengths[0], fRowLengths[vStartRow], vLineRowCount * SizeOf(TRowLength));\r\n finally\r\n FreeMem(vTempRowLengths);\r\n end;\r\nend;\r\n\r\nprocedure TSynWordWrapPlugin.WrapLines;\r\nvar\r\n cRow: Integer;\r\n cLine: Integer;\r\n vLine: UnicodeString;\r\n vMaxNewRows: Integer;\r\n vRowBegin: PWideChar;\r\n vLineEnd: PWideChar;\r\n vRowEnd: PWideChar;\r\n vRunner: PWideChar;\r\n vRowMinEnd: PWideChar;\r\n vLastVisibleChar: PWideChar;\r\nbegin\r\n if (Editor.Lines.Count = 0) or (fMaxRowLength <= 0) then\r\n begin\r\n SetEmpty;\r\n Exit;\r\n end;\r\n\r\n GrowLines(Editor.Lines.Count);\r\n GrowRows(Editor.Lines.Count);\r\n\r\n cRow := 0;\r\n for cLine := 0 to Editor.Lines.Count - 1 do\r\n begin\r\n vLine := TSynEditStringList(Editor.Lines).ExpandedStrings[cLine];\r\n vLine := Editor.ExpandAtWideGlyphs(vLine);\r\n\r\n vMaxNewRows := ((Length(vLine) - 1) div fMinRowLength) + 1;\r\n GrowRows(cRow + vMaxNewRows);\r\n\r\n vRowBegin := PWideChar(vLine);\r\n vRowEnd := vRowBegin + fMaxRowLength;\r\n vLineEnd := vRowBegin + Length(vLine);\r\n while vRowEnd < vLineEnd do\r\n begin\r\n if OldWhitespaceBehaviour and CharInSet(vRowEnd^, [#32, #9]) then\r\n begin\r\n repeat\r\n Inc(vRowEnd);\r\n until not CharInSet(vRowEnd^, [#32, #9]);\r\n end\r\n else\r\n begin\r\n vRowMinEnd := vRowBegin + fMinRowLength;\r\n vRunner := vRowEnd;\r\n while vRunner > vRowMinEnd do\r\n begin\r\n if Editor.IsWordBreakChar(vRunner^) then\r\n begin\r\n vRowEnd := vRunner;\r\n break;\r\n end;\r\n Dec(vRunner);\r\n end;\r\n end;\r\n\r\n if OldWhitespaceBehaviour and (vRowEnd - vRowBegin > High(TRowLength)) then\r\n begin\r\n vRowEnd := vRowBegin + High(TRowLength);\r\n vRowMinEnd := vRowEnd - (High(TRowLength) mod Editor.TabWidth);\r\n while (vRowEnd^ = #9) and (vRowEnd > vRowMinEnd) do\r\n Dec(vRowEnd);\r\n end;\r\n\r\n // do not cut wide glyphs in half\r\n if vRowEnd > vRowBegin then\r\n begin\r\n vLastVisibleChar := vRowEnd - 1;\r\n while (vLastVisibleChar^ = FillerChar) and (vLastVisibleChar > vRowBegin) do\r\n dec(vLastVisibleChar);\r\n vRowEnd := vLastVisibleChar + 1;\r\n end;\r\n\r\n fRowLengths[cRow] := vRowEnd - vRowBegin;\r\n\r\n Inc(cRow);\r\n vRowBegin := vRowEnd;\r\n Inc(vRowEnd, fMaxRowLength);\r\n end;\r\n if (vLineEnd > vRowBegin) or (Length(vLine) = 0) then\r\n begin\r\n fRowLengths[cRow] := vLineEnd - vRowBegin;\r\n Inc(cRow);\r\n end;\r\n fLineOffsets[cLine] := cRow;\r\n end;\r\n fLineCount := Editor.Lines.Count;\r\nend;\r\n\r\nfunction TSynWordWrapPlugin.RowCount: integer;\r\nbegin\r\n if LineCount > 0 then\r\n Result := fLineOffsets[LineCount - 1]\r\n else\r\n Result := 0;\r\nend;\r\n\r\nprocedure TSynWordWrapPlugin.SetEmpty;\r\nbegin\r\n fLineCount := 0;\r\n // free unsused memory\r\n TrimArrays;\r\nend;\r\n\r\nprocedure TSynWordWrapPlugin.TrimArrays;\r\nbegin\r\n ReallocMem(fLineOffsets, LineCount * SizeOf(TRowIndex));\r\n fLineCapacity := LineCount;\r\n ReallocMem(fRowLengths, RowCount * SizeOf(TRowLength));\r\n fRowCapacity := RowCount;\r\nend;\r\n\r\nend.\r\n" }, { "path": "External/SynEdit/Source/SynExportHTML.pas", "content": "{-------------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: SynExportHTML.pas, released 2000-04-16.\r\n\r\nThe Original Code is partly based on the mwHTMLExport.pas file from the\r\nmwEdit component suite by Martin Waldenburg and other developers, the Initial\r\nAuthor of this file is Michael Hieke.\r\nPortions created by Michael Hieke are Copyright 2000 Michael Hieke.\r\nPortions created by James D. Jacobson are Copyright 1999 Martin Waldenburg.\r\nChanges to emit XHTML 1.0 Strict complying code by Mal Hrz.\r\nUnicode translation by Mal Hrz.\r\nAll Rights Reserved.\r\n\r\nContributors to the SynEdit project are listed in the Contributors.txt file.\r\n\r\nAlternatively, the contents of this file may be used under the terms of the\r\nGNU General Public License Version 2 or later (the \"GPL\"), in which case\r\nthe provisions of the GPL are applicable instead of those above.\r\nIf you wish to allow use of your version of this file only under the terms\r\nof the GPL and not to allow others to use your version of this file\r\nunder the MPL, indicate your decision by deleting the provisions above and\r\nreplace them with the notice and other provisions required by the GPL.\r\nIf you do not delete the provisions above, a recipient may use your version\r\nof this file under either the MPL or the GPL.\r\n\r\n$Id: SynExportHTML.pas,v 1.19.2.7 2008/09/14 16:24:59 maelh Exp $\r\n\r\nYou may retrieve the latest version of this file at the SynEdit home page,\r\nlocated at http://SynEdit.SourceForge.net\r\n\r\nKnown Issues:\r\n-------------------------------------------------------------------------------}\r\n\r\n{$IFNDEF QSYNEXPORTHTML}\r\nunit SynExportHTML;\r\n{$ENDIF}\r\n\r\n{$I SynEdit.inc}\r\n\r\ninterface\r\n\r\nuses\r\n{$IFDEF SYN_CLX}\r\n Qt,\r\n QGraphics,\r\n QSynEditExport,\r\n QSynEditHighlighter,\r\n QSynUnicode, \r\n{$ELSE}\r\n Windows,\r\n Graphics,\r\n SynEditExport,\r\n SynEditHighlighter,\r\n SynUnicode, \r\n{$ENDIF}\r\n Classes;\r\n\r\ntype\r\n TSynExporterHTML = class(TSynCustomExporter)\r\n private\r\n function AttriToCSS(Attri: TSynHighlighterAttributes;\r\n UniqueAttriName: string): string;\r\n function AttriToCSSCallback(Highlighter: TSynCustomHighlighter;\r\n Attri: TSynHighlighterAttributes; UniqueAttriName: string;\r\n Params: array of Pointer): Boolean;\r\n function ColorToHTML(AColor: TColor): string;\r\n function GetStyleName(Highlighter: TSynCustomHighlighter;\r\n Attri: TSynHighlighterAttributes): string;\r\n function MakeValidName(Name: string): string;\r\n function StyleNameCallback(Highlighter: TSynCustomHighlighter;\r\n Attri: TSynHighlighterAttributes; UniqueAttriName: string;\r\n Params: array of Pointer): Boolean;\r\n protected\r\n fCreateHTMLFragment: boolean;\r\n procedure FormatAfterLastAttribute; override;\r\n procedure FormatAttributeDone(BackgroundChanged, ForegroundChanged: boolean;\r\n FontStylesChanged: TFontStyles); override;\r\n procedure FormatAttributeInit(BackgroundChanged, ForegroundChanged: boolean;\r\n FontStylesChanged: TFontStyles); override;\r\n procedure FormatBeforeFirstAttribute(BackgroundChanged,\r\n ForegroundChanged: boolean; FontStylesChanged: TFontStyles); override;\r\n procedure FormatNewLine; override;\r\n function GetFooter: UnicodeString; override;\r\n function GetFormatName: string; override;\r\n function GetHeader: UnicodeString; override;\r\n function ReplaceReservedChar(AChar: WideChar): UnicodeString; override;\r\n function UseBom: Boolean; override;\r\n public\r\n constructor Create(AOwner: TComponent); override;\r\n function SupportedEncodings: TSynEncodings; override;\r\n published\r\n property Color;\r\n property CreateHTMLFragment: boolean read fCreateHTMLFragment\r\n write fCreateHTMLFragment default False;\r\n property DefaultFilter;\r\n property Encoding;\r\n property Font;\r\n property Highlighter;\r\n property Title;\r\n property UseBackground;\r\n end;\r\n\r\nimplementation\r\n\r\nuses\r\n{$IFDEF SYN_CLX}\r\n QSynEditMiscProcs,\r\n QSynEditStrConst,\r\n QSynHighlighterMulti,\r\n{$ELSE}\r\n SynEditMiscProcs,\r\n SynEditStrConst, \r\n SynHighlighterMulti,\r\n{$ENDIF}\r\n SysUtils;\r\n\r\n\r\n{ TSynExporterHTML }\r\n\r\nconstructor TSynExporterHTML.Create(AOwner: TComponent);\r\nconst\r\n CF_HTML = 'HTML Format';\r\nbegin\r\n inherited Create(AOwner);\r\n {$IFNDEF SYN_CLX}\r\n fClipboardFormat := RegisterClipboardFormat(CF_HTML);\r\n {$ENDIF} // TODO: register for Kylix, too, see what Netscape Composer uses/accepts\r\n fDefaultFilter := SYNS_FilterHTML;\r\n FEncoding := seUTF8;\r\nend;\r\n\r\nfunction TSynExporterHTML.AttriToCSS(Attri: TSynHighlighterAttributes;\r\n UniqueAttriName: string): string;\r\nvar\r\n StyleName: string;\r\nbegin\r\n StyleName := MakeValidName(UniqueAttriName);\r\n\r\n Result := '.' + StyleName + ' { ';\r\n if UseBackground and (Attri.Background <> clNone) then\r\n Result := Result + 'background-color: ' + ColorToHTML(Attri.Background) + '; ';\r\n if Attri.Foreground <> clNone then\r\n Result := Result + 'color: ' + ColorToHTML(Attri.Foreground) + '; ';\r\n\r\n if fsBold in Attri.Style then\r\n Result := Result + 'font-weight: bold; ';\r\n if fsItalic in Attri.Style then\r\n Result := Result + 'font-style: italic; ';\r\n if fsUnderline in Attri.Style then\r\n Result := Result + 'text-decoration: underline; ';\r\n if fsStrikeOut in Attri.Style then\r\n Result := Result + 'text-decoration: line-through; ';\r\n\r\n Result := Result + '}';\r\nend;\r\n\r\nfunction TSynExporterHTML.AttriToCSSCallback(Highlighter: TSynCustomHighlighter;\r\n Attri: TSynHighlighterAttributes; UniqueAttriName: string;\r\n Params: array of Pointer): Boolean;\r\nvar\r\n Styles: ^string;\r\nbegin\r\n Styles := Params[0];\r\n Styles^ := Styles^ + AttriToCSS(Attri, UniqueAttriName) + #13#10; \r\n Result := True; // we want all attributes => tell EnumHighlighterAttris to continue\r\nend;\r\n\r\nfunction TSynExporterHTML.ColorToHTML(AColor: TColor): string;\r\nvar\r\n RGBColor: longint;\r\n RGBValue: byte;\r\nconst\r\n Digits: array[0..15] of Char = '0123456789ABCDEF';\r\nbegin\r\n RGBColor := ColorToRGB(AColor);\r\n Result := '#000000';\r\n RGBValue := GetRValue(RGBColor);\r\n if RGBValue > 0 then\r\n begin\r\n Result[2] := Digits[RGBValue shr 4];\r\n Result[3] := Digits[RGBValue and 15];\r\n end;\r\n RGBValue := GetGValue(RGBColor);\r\n if RGBValue > 0 then\r\n begin\r\n Result[4] := Digits[RGBValue shr 4];\r\n Result[5] := Digits[RGBValue and 15];\r\n end;\r\n RGBValue := GetBValue(RGBColor);\r\n if RGBValue > 0 then\r\n begin\r\n Result[6] := Digits[RGBValue shr 4];\r\n Result[7] := Digits[RGBValue and 15];\r\n end;\r\nend;\r\n\r\nprocedure TSynExporterHTML.FormatAfterLastAttribute;\r\nbegin\r\n AddData('');\r\nend;\r\n\r\nprocedure TSynExporterHTML.FormatAttributeDone(BackgroundChanged,\r\n ForegroundChanged: boolean; FontStylesChanged: TFontStyles);\r\nbegin\r\n AddData('');\r\nend;\r\n\r\nprocedure TSynExporterHTML.FormatAttributeInit(BackgroundChanged,\r\n ForegroundChanged: boolean; FontStylesChanged: TFontStyles);\r\nvar\r\n StyleName: string;\r\nbegin\r\n StyleName := GetStyleName(Highlighter, Highlighter.GetTokenAttribute);\r\n AddData(Format('', [StyleName]));\r\nend;\r\n\r\nprocedure TSynExporterHTML.FormatBeforeFirstAttribute(BackgroundChanged,\r\n ForegroundChanged: boolean; FontStylesChanged: TFontStyles);\r\nvar\r\n StyleName: string;\r\nbegin\r\n StyleName := GetStyleName(Highlighter, Highlighter.GetTokenAttribute);\r\n AddData(Format('', [StyleName]));\r\nend;\r\n\r\nprocedure TSynExporterHTML.FormatNewLine;\r\nbegin\r\n AddNewLine;\r\nend;\r\n\r\nfunction TSynExporterHTML.GetFooter: UnicodeString;\r\nbegin\r\n Result := '';\r\n if fExportAsText then\r\n Result := ''#13#10''#13#10\r\n else\r\n Result := '';\r\n if not(fCreateHTMLFragment and fExportAsText) then\r\n Result := Result + ''#13#10'';\r\nend;\r\n\r\nfunction TSynExporterHTML.GetFormatName: string;\r\nbegin\r\n Result := SYNS_ExporterFormatHTML;\r\nend;\r\n\r\nfunction TSynExporterHTML.GetHeader: UnicodeString;\r\nconst\r\n DescriptionSize = 105;\r\n FooterSize1 = 47;\r\n FooterSize2 = 31;\r\n NativeHeader = 'Version:0.9'#13#10 +\r\n 'StartHTML:%.10d'#13#10 +\r\n 'EndHTML:%.10d'#13#10 +\r\n 'StartFragment:%.10d'#13#10 +\r\n 'EndFragment:%.10d'#13#10;\r\n HTMLAsTextHeader = ''#13#10 +\r\n ''#13#10 +\r\n ''#13#10 +\r\n ''#13#10;\r\n HTMLAsTextHeader2 =''#13#10 +\r\n ''#13#10 +\r\n ''#13#10 +\r\n ''#13#10 +\r\n ''#13#10;\r\n EncodingStrs: array[TSynEncoding] of string =\r\n ('UTF-8', 'UTF-16', 'UTF-16', 'ANSI is Unsupported');\r\nvar\r\n EncodingStr, Styles, Header, Header2: string;\r\nbegin\r\n EncodingStr := EncodingStrs[Encoding];\r\n EnumHighlighterAttris(Highlighter, True, AttriToCSSCallback, [@Styles]);\r\n\r\n Header := Format(HTMLAsTextHeader, [EncodingStr]);\r\n Header := Header + '' + Title + ''#13#10 +\r\n Format(HTMLAsTextHeader2, [EncodingStr, ColorToHtml(fFont.Color),\r\n ColorToHTML(fBackgroundColor), Styles]);\r\n\r\n Result := '';\r\n if fExportAsText then\r\n begin\r\n if not fCreateHTMLFragment then\r\n Result := Header;\r\n\r\n Result := Result + Format('
    '#13#10'',\r\n      [fFont.Size, fFont.Name]);\r\n  end\r\n  else\r\n  begin\r\n    // Described in http://msdn.microsoft.com/library/sdkdoc/htmlclip/htmlclipboard.htm\r\n    Header2 := '
    ';\r\n    Result := Format(NativeHeader, [DescriptionSize,\r\n      DescriptionSize + Length(Header) + Length(Header2) + GetBufferSize + FooterSize1,\r\n      DescriptionSize + Length(Header),\r\n      DescriptionSize + Length(Header) + Length(Header2) + GetBufferSize + FooterSize2]);\r\n    Result := Result + Header + Header2;\r\n  end;\r\nend;\r\n\r\nfunction TSynExporterHTML.GetStyleName(Highlighter: TSynCustomHighlighter;\r\n  Attri: TSynHighlighterAttributes): string;\r\nbegin\r\n  EnumHighlighterAttris(Highlighter, False, StyleNameCallback, [Attri, @Result]);\r\nend;\r\n\r\nfunction TSynExporterHTML.MakeValidName(Name: string): string;\r\nvar\r\n  i: Integer;\r\nbegin\r\n  Result := LowerCase(Name);\r\n  for i := Length(Result) downto 1 do\r\n    if CharInSet(Result[i], ['.', '_']) then\r\n      Result[i] := '-'\r\n    else if not CharInSet(Result[i], ['a'..'z', '0'..'9', '-']) then\r\n      Delete(Result, i, 1);\r\nend;\r\n\r\nfunction TSynExporterHTML.ReplaceReservedChar(AChar: WideChar): UnicodeString;\r\nbegin\r\n  case AChar of\r\n    '&': Result := '&';\r\n    '<': Result := '<';\r\n    '>': Result := '>';\r\n    '\"': Result := '"';\r\n    else Result := '';\r\n  end\r\nend;\r\n\r\nfunction TSynExporterHTML.StyleNameCallback(Highlighter: TSynCustomHighlighter;\r\n    Attri: TSynHighlighterAttributes; UniqueAttriName: string;\r\n    Params: array of Pointer): Boolean;\r\nvar\r\n  AttriToFind: TSynHighlighterAttributes;\r\n  StyleName: ^string;\r\nbegin\r\n  AttriToFind := Params[0];\r\n  StyleName := Params[1];\r\n\r\n  if Attri = AttriToFind then\r\n  begin\r\n    StyleName^ := MakeValidName(UniqueAttriName);\r\n    Result := False; // found => inform EnumHighlighterAttris to stop searching\r\n  end\r\n  else\r\n    Result := True;\r\nend;\r\n\r\nfunction TSynExporterHTML.UseBom: Boolean;\r\nbegin\r\n  // do not include seUTF8 as some browsers have problems with UTF-8-BOM\r\n  Result := Encoding in [seUTF16LE, seUTF16BE];\r\nend;\r\n\r\nfunction TSynExporterHTML.SupportedEncodings: TSynEncodings;\r\nbegin\r\n  Result := [seUTF8, seUTF16LE, seUTF16BE];\r\nend;\r\n\r\nend.\r\n"
  },
  {
    "path": "External/SynEdit/Source/SynExportRTF.pas",
    "content": "{-------------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: SynExportRTF.pas, released 2000-04-16.\r\n\r\nThe Original Code is partly based on the mwRTFExport.pas file from the\r\nmwEdit component suite by Martin Waldenburg and other developers, the Initial\r\nAuthor of this file is Michael Hieke.\r\nPortions created by Michael Hieke are Copyright 2000 Michael Hieke.\r\nPortions created by James D. Jacobson are Copyright 1999 Martin Waldenburg.\r\nUnicode translation by Mal Hrz.\r\nAll Rights Reserved.\r\n\r\nContributors to the SynEdit project are listed in the Contributors.txt file.\r\n\r\nAlternatively, the contents of this file may be used under the terms of the\r\nGNU General Public License Version 2 or later (the \"GPL\"), in which case\r\nthe provisions of the GPL are applicable instead of those above.\r\nIf you wish to allow use of your version of this file only under the terms\r\nof the GPL and not to allow others to use your version of this file\r\nunder the MPL, indicate your decision by deleting the provisions above and\r\nreplace them with the notice and other provisions required by the GPL.\r\nIf you do not delete the provisions above, a recipient may use your version\r\nof this file under either the MPL or the GPL.\r\n\r\n$Id: SynExportRTF.pas,v 1.10.2.3 2008/09/14 16:24:59 maelh Exp $\r\n\r\nYou may retrieve the latest version of this file at the SynEdit home page,\r\nlocated at http://SynEdit.SourceForge.net\r\n\r\nKnown Issues:\r\n-------------------------------------------------------------------------------}\r\n\r\n{$IFNDEF QSYNEXPORTRTF}\r\nunit SynExportRTF;\r\n{$ENDIF}\r\n\r\n{$I SynEdit.inc}\r\n\r\ninterface\r\n\r\nuses\r\n  {$IFDEF SYN_CLX}\r\n  Qt,\r\n  QGraphics,\r\n  QSynEditExport,\r\n  QSynUnicode,  \r\n  {$ELSE}\r\n  Windows,\r\n  Graphics,\r\n  RichEdit,\r\n  SynEditExport,\r\n  SynUnicode,    \r\n  {$ENDIF}\r\n  Classes;\r\n\r\ntype\r\n  TSynExporterRTF = class(TSynCustomExporter)\r\n  private\r\n    fAttributesChanged: Boolean;\r\n    fListColors: TList;\r\n    function ColorToRTF(AColor: TColor): UnicodeString;\r\n    function GetColorIndex(AColor: TColor): Integer;\r\n  protected\r\n    procedure FormatAfterLastAttribute; override;\r\n    procedure FormatAttributeDone(BackgroundChanged, ForegroundChanged: Boolean;\r\n      FontStylesChanged: TFontStyles); override;\r\n    procedure FormatAttributeInit(BackgroundChanged, ForegroundChanged: Boolean;\r\n      FontStylesChanged: TFontStyles); override;\r\n    procedure FormatBeforeFirstAttribute(BackgroundChanged,\r\n      ForegroundChanged: Boolean; FontStylesChanged: TFontStyles); override;\r\n    procedure FormatNewLine; override;\r\n    function GetFooter: UnicodeString; override;\r\n    function GetFormatName: string; override;\r\n    function GetHeader: UnicodeString; override;\r\n    function ReplaceReservedChar(AChar: WideChar): UnicodeString; override;\r\n    function UseBom: Boolean; override;\r\n  public\r\n    constructor Create(AOwner: TComponent); override;\r\n    destructor Destroy; override;\r\n    procedure Clear; override;\r\n    function SupportedEncodings: TSynEncodings; override;\r\n  published\r\n    property Color;\r\n    property DefaultFilter;\r\n    property Encoding;\r\n    property Font;\r\n    property Highlighter;\r\n    property Title;\r\n    property UseBackground;\r\n  end;\r\n\r\nimplementation\r\n\r\nuses\r\n{$IFDEF SYN_CLX}\r\n  QSynEditStrConst,\r\n  QSynEditMiscProcs,\r\n{$ELSE}\r\n  SynEditStrConst,\r\n{$ENDIF}\r\n  SysUtils;\r\n\r\n{ TSynExporterRTF }\r\n\r\nconstructor TSynExporterRTF.Create(AOwner: TComponent);\r\nbegin\r\n  inherited Create(AOwner);\r\n  fListColors := TList.Create;\r\n  fDefaultFilter := SYNS_FilterRTF;\r\n{$IFNDEF SYN_CLX}\r\n  fClipboardFormat := RegisterClipboardFormat(CF_RTF);\r\n{$ENDIF} // TODO: register for Kylix, too, see what Netscape Composer uses/accepts\r\n  FEncoding := seUTF8;\r\nend;\r\n\r\ndestructor TSynExporterRTF.Destroy;\r\nbegin\r\n  fListColors.Free;\r\n  fListColors := nil;\r\n  inherited Destroy;\r\nend;\r\n\r\nprocedure TSynExporterRTF.Clear;\r\nbegin\r\n  inherited Clear;\r\n  if Assigned(fListColors) then\r\n    fListColors.Clear;\r\nend;\r\n\r\nfunction TSynExporterRTF.ColorToRTF(AColor: TColor): UnicodeString;\r\nvar\r\n  Col: Integer;\r\nbegin\r\n  Col := ColorToRGB(AColor);\r\n  Result := Format('\\red%d\\green%d\\blue%d;', [GetRValue(Col), GetGValue(Col),\r\n    GetBValue(Col)]);\r\nend;\r\n\r\nprocedure TSynExporterRTF.FormatAfterLastAttribute;\r\nbegin\r\n  // no need to reset the font style here...\r\nend;\r\n\r\nprocedure TSynExporterRTF.FormatAttributeDone(BackgroundChanged,\r\n  ForegroundChanged: Boolean; FontStylesChanged: TFontStyles);\r\nconst\r\n  FontTags: array[TFontStyle] of UnicodeString = ('\\b0', '\\i0', '\\ul0', '\\strike0');\r\nvar\r\n  AStyle: TFontStyle;\r\nbegin\r\n  // nothing to do about the color, but reset the font style\r\n  for AStyle := Low(TFontStyle) to High(TFontStyle) do\r\n  begin\r\n    if AStyle in FontStylesChanged then\r\n    begin\r\n      fAttributesChanged := True;\r\n      AddData(FontTags[AStyle]);\r\n    end;\r\n  end;\r\nend;\r\n\r\nprocedure TSynExporterRTF.FormatAttributeInit(BackgroundChanged,\r\n  ForegroundChanged: Boolean; FontStylesChanged: TFontStyles);\r\nconst\r\n  FontTags: array[TFontStyle] of UnicodeString = ('\\b', '\\i', '\\ul', '\\strike');\r\nvar\r\n  AStyle: TFontStyle;\r\nbegin\r\n  // background color\r\n  if BackgroundChanged then\r\n  begin\r\n    AddData(Format('\\cb%d', [GetColorIndex(fLastBG)]));\r\n    fAttributesChanged := True;\r\n  end;\r\n  // text color\r\n  if ForegroundChanged then\r\n  begin\r\n    AddData(Format('\\cf%d', [GetColorIndex(fLastFG)]));\r\n    fAttributesChanged := True;\r\n  end;\r\n  // font styles\r\n  for AStyle := Low(TFontStyle) to High(TFontStyle) do\r\n    if AStyle in FontStylesChanged then\r\n    begin\r\n      AddData(FontTags[AStyle]);\r\n      fAttributesChanged := True;\r\n    end;\r\n  if fAttributesChanged then\r\n  begin\r\n    AddData(' ');\r\n    fAttributesChanged := False;\r\n  end;\r\nend;\r\n\r\nprocedure TSynExporterRTF.FormatBeforeFirstAttribute(BackgroundChanged,\r\n  ForegroundChanged: Boolean; FontStylesChanged: TFontStyles);\r\nbegin\r\n  FormatAttributeInit(BackgroundChanged, ForegroundChanged, FontStylesChanged);\r\nend;\r\n\r\nprocedure TSynExporterRTF.FormatNewLine;\r\nbegin\r\n  AddData(#13#10'\\par ');\r\nend;\r\n\r\nfunction TSynExporterRTF.GetColorIndex(AColor: TColor): Integer;\r\nbegin\r\n  Result := fListColors.IndexOf(pointer(AColor));\r\n  if Result = -1 then\r\n    Result := fListColors.Add(pointer(AColor));\r\nend;\r\n\r\nfunction TSynExporterRTF.GetFooter: UnicodeString;\r\nbegin\r\n  Result := '}';\r\nend;\r\n\r\nfunction TSynExporterRTF.GetFormatName: string;\r\nbegin\r\n  Result := SYNS_ExporterFormatRTF;\r\nend;\r\n\r\nfunction TSynExporterRTF.GetHeader: UnicodeString;\r\nvar\r\n  i: Integer;\r\n\r\n  function GetFontTable: UnicodeString;\r\n  begin\r\n    Result := '{\\fonttbl{\\f0\\fmodern ' + Font.Name;\r\n    Result := Result + ';}}'#13#10;\r\n  end;\r\n\r\nbegin\r\n  Result := '{\\rtf1\\ansi\\ansicpg1252\\uc1\\deff0\\deftab720' + GetFontTable;\r\n  // all the colors\r\n  Result := Result + '{\\colortbl';\r\n  for i := 0 to fListColors.Count - 1 do\r\n    Result := Result + ColorToRTF(TColor(fListColors[i]));\r\n  Result := Result + '}'#13#10;\r\n  // title and creator comment\r\n  Result := Result + '{\\info{\\comment Generated by the SynEdit RTF ' +\r\n    'exporter}'#13#10;\r\n  Result := Result + '{\\title ' + fTitle + '}}'#13#10;\r\n  if fUseBackground then\r\n    Result := Result + { TODO: use background color } #13#10;\r\n  Result := Result + Format('\\deflang1033\\pard\\plain\\f0\\fs%d ',\r\n    [2 * Font.Size]);\r\nend;\r\n\r\nfunction TSynExporterRTF.ReplaceReservedChar(AChar: WideChar): UnicodeString;\r\nbegin\r\n  Result := '';\r\n  case AChar of\r\n    '\\': Result := '\\\\';\r\n    '{': Result := '\\{';\r\n    '}': Result := '\\}';\r\n  end;\r\n  if AChar > #127 then\r\n  begin\r\n    if AChar <= #255 then\r\n      Result := '\\''' + LowerCase(IntToHex(Ord(AChar), 2))\r\n    else\r\n      // SmallInt type-cast is necessary because RTF\r\n      // uses signed 16-Bit Integer for Unicode characters\r\n      Result := '\\u' + IntToStr(SmallInt(AChar)) + '?';\r\n  end;\r\nend;\r\n\r\nfunction TSynExporterRTF.SupportedEncodings: TSynEncodings;\r\nbegin\r\n  Result := [seUTF8];\r\nend;\r\n\r\nfunction TSynExporterRTF.UseBom: Boolean;\r\nbegin\r\n  Result := False;\r\nend;\r\n\r\nend.\r\n\r\n"
  },
  {
    "path": "External/SynEdit/Source/SynExportTeX.pas",
    "content": "{-------------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: SynExportTeX.pas, released 2002-09-12.\r\n\r\nThe Original Code is partly based on the mwHTMLExport.pas file from the\r\nmwEdit component suite by Martin Waldenburg and other developers, the Initial\r\nAuthor of this file is Ascher Stefan.\r\nPortions created by Ascher Stefan are Copyright 2002 Ascher Stefan.\r\nUnicode translation by Mal Hrz.\r\nAll Rights Reserved.\r\n\r\nContributors to the SynEdit project are listed in the Contributors.txt file.\r\n\r\nAlternatively, the contents of this file may be used under the terms of the\r\nGNU General Public License Version 2 or later (the \"GPL\"), in which case\r\nthe provisions of the GPL are applicable instead of those above.\r\nIf you wish to allow use of your version of this file only under the terms\r\nof the GPL and not to allow others to use your version of this file\r\nunder the MPL, indicate your decision by deleting the provisions above and\r\nreplace them with the notice and other provisions required by the GPL.\r\nIf you do not delete the provisions above, a recipient may use your version\r\nof this file under either the MPL or the GPL.\r\n\r\n$Id: SynExportTeX.pas,v 1.8.2.5 2008/09/14 16:24:59 maelh Exp $\r\n\r\nYou may retrieve the latest version of this file at the SynEdit home page,\r\nlocated at http://SynEdit.SourceForge.net\r\n\r\nKnown Issues:\r\n- LaTeX 2e doesn't support Unicode, so this exporter doesn't either.\r\n  (There are solutions like the package utc.sty but still they don't allow mixing\r\n  of different languages like Arabic and Chinese.\r\n  We'll have to wait for LaTeX 3.)\r\n-------------------------------------------------------------------------------}\r\n\r\n{$IFNDEF QSYNEXPORTTEX}\r\nunit SynExportTeX;\r\n{$ENDIF}\r\n\r\n{$I SynEdit.inc}\r\n\r\ninterface\r\n\r\nuses\r\n{$IFDEF SYN_CLX}\r\n  Qt,\r\n  QGraphics,\r\n  QSynEditExport,\r\n  QSynEditHighlighter,\r\n  QSynUnicode,  \r\n{$ELSE}\r\n  Windows,\r\n  Graphics,\r\n  SynEditExport,\r\n  SynEditHighlighter,\r\n  SynUnicode,\r\n{$ENDIF}\r\n  Classes;\r\n\r\ntype\r\n  TSynExporterTeX = class(TSynCustomExporter)\r\n  private\r\n    fMargin: integer;\r\n    fLastAttri: TSynHighlighterAttributes;\r\n    function AttriToCommand(Attri: TSynHighlighterAttributes;\r\n      UniqueAttriName: string): string;\r\n    function AttriToCommandCallback(Highlighter: TSynCustomHighlighter;\r\n      Attri: TSynHighlighterAttributes; UniqueAttriName: string;\r\n      Params: array of Pointer): Boolean;\r\n    function CommandNameCallback(Highlighter: TSynCustomHighlighter;\r\n      Attri: TSynHighlighterAttributes; UniqueAttriName: string;\r\n      Params: array of Pointer): Boolean;\r\n    function GetCommandName(Highlighter: TSynCustomHighlighter;\r\n      Attri: TSynHighlighterAttributes): string;\r\n    function GetNewCommands: string;\r\n    function MakeValidName(Name: string): string;\r\n  protected\r\n    fCreateTeXFragment: boolean;\r\n    fTabWidth: integer;\r\n    fPageStyleEmpty: boolean;\r\n    \r\n    // overriding these abstract methods (though they are never called for this\r\n    // specific highlighter) to prevent abstract instance warnings\r\n    procedure FormatAfterLastAttribute; override;\r\n    procedure FormatAttributeDone(BackgroundChanged: Boolean;\r\n      ForegroundChanged: Boolean; FontStylesChanged: TFontStyles); override;\r\n    procedure FormatAttributeInit(BackgroundChanged: Boolean;\r\n      ForegroundChanged: Boolean; FontStylesChanged: TFontStyles); override;\r\n    procedure FormatBeforeFirstAttribute(BackgroundChanged: Boolean;\r\n      ForegroundChanged: Boolean; FontStylesChanged: TFontStyles); override;\r\n\r\n    procedure FormatNewLine; override;\r\n    procedure FormatToken(Token: UnicodeString); override;\r\n    function GetFooter: UnicodeString; override;\r\n    function GetFormatName: string; override;\r\n    function GetHeader: UnicodeString; override;\r\n    function ReplaceReservedChar(AChar: WideChar): UnicodeString; override;\r\n    procedure SetTokenAttribute(Attri: TSynHighlighterAttributes); override;\r\n    function UseBom: Boolean; override;\r\n  public\r\n    constructor Create(AOwner: TComponent); override;\r\n    function SupportedEncodings: TSynEncodings; override;\r\n  published\r\n    property Margin: integer read fMargin write fMargin default 2;\r\n    property TabWidth: integer read fTabWidth write fTabWidth default 2;\r\n    property Color;\r\n    property CreateTeXFragment: boolean read fCreateTeXFragment\r\n      write fCreateTeXFragment default false;\r\n    property PageStyleEmpty: boolean read fPageStyleEmpty write fPageStyleEmpty\r\n      default false;\r\n    property DefaultFilter;\r\n    property Encoding;\r\n    property Font;\r\n    property Highlighter;\r\n    property Title;\r\n    property UseBackground;\r\n  end;\r\n\r\nimplementation\r\n\r\nuses\r\n{$IFDEF SYN_CLX}\r\n  QSynEditMiscProcs,\r\n  QSynEditStrConst,\r\n{$ELSE}\r\n  SynEditMiscProcs,\r\n  SynEditStrConst,\r\n{$ENDIF}\r\n  SysUtils;\r\n\r\n\r\n// DotDecSepFormat always formats with a dot as decimal separator.\r\n// This is necessary because LaTeX expects a dot, but VCL's Format is\r\n// language-dependent, i.e. with another locale set, the separator can be\r\n// different (for example a comma).\r\nfunction DotDecSepFormat(const Format: string; const Args: array of const): string;\r\nvar\r\n{$IFDEF UNICODE}\r\n  OldDecimalSeparator: WideChar;\r\n{$ELSE}\r\n  OldDecimalSeparator: AnsiChar;\r\n{$ENDIF}\r\nbegin\r\n  OldDecimalSeparator := {$IFDEF SYN_COMPILER_15_UP}FormatSettings.{$ENDIF}DecimalSeparator;\r\n  {$IFDEF SYN_COMPILER_15_UP}FormatSettings.{$ENDIF}DecimalSeparator := '.';\r\n  Result := SysUtils.Format(Format, Args);\r\n  {$IFDEF SYN_COMPILER_15_UP}FormatSettings.{$ENDIF}DecimalSeparator := OldDecimalSeparator;\r\nend;\r\n\r\nfunction ColorToTeX(AColor: TColor): string;\r\nconst\r\n  f = '%1.2g';\r\n  f2 = '%s,%s,%s';\r\nvar\r\n  RGBColor: LongWord;\r\n  RValue, GValue, BValue: string;\r\nbegin\r\n  RGBColor := ColorToRGB(AColor);\r\n  RValue := DotDecSepFormat(f, [GetRValue(RGBColor) / 255]);\r\n  GValue := DotDecSepFormat(f, [GetGValue(RGBColor) / 255]);\r\n  BValue := DotDecSepFormat(f, [GetBValue(RGBColor) / 255]);\r\n  Result := Format(f2, [RValue, GValue, BValue]);\r\nend;\r\n\r\n{ TSynExporterTeX }\r\n\r\nconstructor TSynExporterTeX.Create(AOwner: TComponent);\r\nbegin\r\n  inherited Create(AOwner);\r\n  fMargin := 2;\r\n  fTabWidth := 2;\r\n  fPageStyleEmpty := false;\r\n  fDefaultFilter := SYNS_FilterTeX;\r\n  FEncoding := seAnsi;\r\nend;\r\n\r\nfunction TSynExporterTeX.AttriToCommandCallback(\r\n  Highlighter: TSynCustomHighlighter; Attri: TSynHighlighterAttributes;\r\n  UniqueAttriName: string; Params: array of Pointer): Boolean;\r\nvar\r\n  Commands: ^string;\r\nbegin\r\n  Commands := Params[0];\r\n  Commands^ := Commands^ + AttriToCommand(Attri, UniqueAttriName) + SLineBreak;\r\n  Result := True; // we want all attributes => tell EnumHighlighterAttris to continue\r\nend;\r\n\r\nfunction TSynExporterTeX.AttriToCommand(Attri: TSynHighlighterAttributes;\r\n  UniqueAttriName: string): string;\r\nconst\r\n  NewCommand    = '\\newcommand{\\%s}[1]{%s#1%s}';\r\n  SBold         = '\\textbf{';\r\n  SItalic       = '\\textit{';\r\n  SUnderline    = '\\uln{';\r\n  SColor        = '\\textcolor[rgb]{%s}{';\r\n  SBackColor    = '\\colorbox[rgb]{%s}{';\r\nvar\r\n  Formatting: string;\r\n  BracketCount: Integer;\r\nbegin\r\n  BracketCount := 0;\r\n  with Attri do\r\n  begin\r\n    if fsBold in Style then\r\n    begin\r\n      Formatting := Formatting + SBold;\r\n      Inc(BracketCount);\r\n    end;\r\n    if fsItalic in Style then\r\n    begin\r\n      Formatting := Formatting + SItalic;\r\n      Inc(BracketCount);\r\n    end;\r\n    if fsUnderline in Style then\r\n    begin\r\n      Formatting := Formatting + SUnderline;\r\n      Inc(BracketCount);\r\n    end;\r\n    if (Foreground <> clBlack) and (Foreground <> clNone)  then\r\n    begin\r\n      Formatting := Formatting + Format(SColor, [ColorToTeX(Foreground)]);\r\n      Inc(BracketCount);\r\n    end;\r\n    if fUseBackground and (Background <> clNone) then\r\n    begin\r\n      Formatting := Formatting + Format(SBackColor, [ColorToTeX(Background)]);\r\n      Inc(BracketCount);\r\n    end;\r\n    Result := Format(NewCommand, [MakeValidName(UniqueAttriName), Formatting,\r\n      StringOfChar('}', BracketCount)])\r\n  end;\r\nend;\r\n\r\nfunction TSynExporterTeX.CommandNameCallback(\r\n  Highlighter: TSynCustomHighlighter; Attri: TSynHighlighterAttributes;\r\n  UniqueAttriName: string; Params: array of Pointer): Boolean;\r\nvar\r\n  AttriToFind: TSynHighlighterAttributes;\r\n  CommandName: ^string;\r\nbegin\r\n  AttriToFind := Params[0];\r\n  CommandName := Params[1];\r\n\r\n  if Attri = AttriToFind then\r\n  begin\r\n    CommandName^ := MakeValidName(UniqueAttriName);\r\n    Result := False; // found => inform EnumHighlighterAttris to stop searching\r\n  end\r\n  else\r\n    Result := True;\r\nend;\r\n\r\nprocedure TSynExporterTeX.FormatToken(Token: UnicodeString);\r\nvar\r\n  CommandName: string;\r\nbegin\r\n  CommandName := GetCommandName(Highlighter, fLastAttri);\r\n  AddData('\\' + CommandName + '{' + Token + '}');\r\nend;\r\n\r\nprocedure TSynExporterTeX.FormatNewLine;\r\nbegin\r\n  AddData('\\\\' + SLineBreak);\r\nend;\r\n\r\n// do nothing with these\r\nprocedure TSynExporterTeX.FormatAfterLastAttribute;\r\nbegin\r\nend;\r\n\r\nprocedure TSynExporterTeX.FormatAttributeDone;\r\nbegin\r\nend;\r\n\r\nprocedure TSynExporterTeX.FormatAttributeInit;\r\nbegin\r\nend;\r\n\r\nprocedure TSynExporterTeX.FormatBeforeFirstAttribute;\r\nbegin\r\nend;\r\n\r\nfunction TSynExporterTeX.GetCommandName(Highlighter: TSynCustomHighlighter;\r\n  Attri: TSynHighlighterAttributes): string;\r\nbegin\r\n  EnumHighlighterAttris(Highlighter, False, CommandNameCallback, [Attri, @Result]);\r\nend;\r\n\r\nfunction TSynExporterTeX.GetFooter: UnicodeString;\r\nbegin\r\n  if not fCreateTeXFragment then\r\n    Result := SLineBreak + '\\end{ttfamily}' + SLineBreak + '\\end{document}'\r\n  else\r\n    Result := SLineBreak + '\\end{ttfamily}';\r\nend;\r\n\r\nfunction TSynExporterTeX.GetFormatName: string;\r\nbegin\r\n  Result := SYNS_ExporterFormatTeX;\r\nend;\r\n\r\nfunction TSynExporterTeX.GetHeader: UnicodeString;\r\nconst\r\n  TeXHeader   = '\\documentclass[a4paper, %dpt]{article}' + SLineBreak +\r\n                '\\usepackage[a4paper, margin=%dcm]{geometry}' + SLineBreak +\r\n                '\\usepackage[T1]{fontenc}' + SLineBreak +\r\n                '\\usepackage{color}' + SLineBreak +\r\n                '\\usepackage{alltt}' + SLineBreak +\r\n                '\\usepackage{times}' + SLineBreak +\r\n                '\\usepackage{ulem}' + SLineBreak +\r\n{$IFDEF WIN32}\r\n                // It is recommennded to use AnsiNew on Windows\r\n                '\\usepackage[ansinew]{inputenc}' + SLineBreak +\r\n{$ELSE}\r\n                // and Latin1 on UNIX Systems, see also DE FAQ 8.5.3\r\n                '\\usepackage[latin1]{inputenc}' + SLineBreak +\r\n{$ENDIF}\r\n                '%s' + SLineBreak; // New Commands\r\n  TeXHeader2  = '%% Generated by SynEdit TeX exporter' + SLineBreak + SLineBreak +\r\n                '\\begin{document}';\r\n  EmptyPage   = '\\pagestyle{empty}';\r\n  TeXDocument = '\\begin{ttfamily}' + SLineBreak +\r\n                '\\noindent' + SLineBreak;\r\nvar\r\n  PageStyle: string;\r\nbegin\r\n  if not fCreateTeXFragment then\r\n  begin\r\n    if fPageStyleEmpty then\r\n      PageStyle := SLineBreak + EmptyPage\r\n    else\r\n      PageStyle := '';\r\n    Result := Format(TeXHeader + SLineBreak + SLineBreak,\r\n      [Font.Size, fMargin, GetNewCommands]);\r\n    Result := Result + '\\title{' + Title + '}' + SLineBreak + TeXHeader2 +\r\n      SLineBreak + PageStyle;\r\n  end;\r\n  Result := Result + TeXDocument;\r\nend;\r\n\r\nfunction TSynExporterTeX.GetNewCommands: string;\r\nconst\r\n  FixedCommands = '%% Special Characters' + SLineBreak +\r\n                  '\\newcommand\\SPC{\\hspace*{0.6em}}' + SLineBreak +\r\n                  '\\newcommand\\TAB{\\hspace*{%sem}}' + SLineBreak +\r\n                  '\\newcommand\\BS{\\mbox{\\char 92}}' + SLineBreak +   // Backslash\r\n                  '\\newcommand\\TLD{\\mbox{\\char 126}}' + SLineBreak + // ~\r\n                  '\\newcommand\\CIR{\\mbox{\\char 94}}' + SLineBreak  + // ^\r\n                  '\\newcommand\\HYP{\\mbox{\\char 45}}' + SLineBreak  + // a simple -\r\n                  '\\newcommand\\QOT{\\mbox{\\char 34}}' + SLineBreak  + // \"\r\n                  '\\newcommand{\\uln}[1]{\\bgroup \\markoverwith{\\hbox{\\_}}\\ULon{{#1}}}' + SLineBreak +\r\n                  '%% Highlighter Attributes' + SLineBreak;\r\n  f = '%1.1g';\r\nvar\r\n  tw: string;\r\n  Commands: string;\r\nbegin\r\n  tw := DotDecSepFormat(f, [fTabWidth * 0.6]);\r\n  Result := Format(FixedCommands, [tw]);\r\n\r\n  EnumHighlighterAttris(Highlighter, True, AttriToCommandCallback, [@Commands]);\r\n  Result := Result + Commands;\r\nend;\r\n\r\nfunction TSynExporterTeX.MakeValidName(Name: string): string;\r\nvar\r\n  i: Integer;\r\nbegin\r\n  Result := Name;\r\n  \r\n  for i := Length(Result) downto 1 do\r\n  if CharInSet(Result[i], ['1'..'9']) then\r\n    Result[i] := Char(Ord('A') + Ord(Result[i]) - Ord('1'))\r\n  else if Result[i] = '0' then\r\n    Result[i] := 'Z'\r\n  else if not CharInSet(Result[i], ['a'..'z', 'A'..'Z']) then\r\n    Delete(Result, i, 1);\r\nend;\r\n\r\nfunction TSynExporterTeX.ReplaceReservedChar(AChar: WideChar): UnicodeString;\r\nbegin\r\n  case AChar of\r\n    '{': Result := '\\{';\r\n    '}': Result := '\\}';\r\n    '\\': Result := '\\BS ';\r\n    '~': Result := '\\TLD ';\r\n    '^': Result := '\\CIR ';\r\n    ' ': Result := '\\SPC ';\r\n    #9: Result := '\\TAB ';\r\n    '-': Result := '\\HYP ';\r\n    '\"': Result := '\\QOT ';\r\n    '@': Result := '$@$';\r\n    '$': Result := '\\$';\r\n    '&': Result := '\\&';\r\n    '<': Result := '$<$';\r\n    '>': Result := '$>$';\r\n    '_': Result := '\\_';\r\n    '#': Result := '\\#';\r\n    '%': Result := '\\%';\r\n    else Result := '';\r\n  end;\r\nend;\r\n\r\nprocedure TSynExporterTeX.SetTokenAttribute(Attri: TSynHighlighterAttributes);\r\nbegin\r\n  fLastAttri := Attri;\r\nend;\r\n\r\nfunction TSynExporterTeX.SupportedEncodings: TSynEncodings;\r\nbegin\r\n  Result := [seAnsi];\r\nend;\r\n\r\nfunction TSynExporterTeX.UseBom: Boolean;\r\nbegin\r\n  Result := False;\r\nend;\r\n\r\nend.\r\n\r\n"
  },
  {
    "path": "External/SynEdit/Source/SynHighlighterADSP21xx.pas",
    "content": "{-------------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: SynHighlighterADSP21xx.pas, released 2000-04-17.\r\nThe Original Code is based on the wbADSP21xxSyn.pas file from the\r\nmwEdit component suite by Martin Waldenburg and other developers, the Initial\r\nAuthor of this file is Wynand Breytenbach.\r\nUnicode translation by Mal Hrz.\r\nAll Rights Reserved.\r\n\r\nContributors to the SynEdit and mwEdit projects are listed in the\r\nContributors.txt file.\r\n\r\nAlternatively, the contents of this file may be used under the terms of the\r\nGNU General Public License Version 2 or later (the \"GPL\"), in which case\r\nthe provisions of the GPL are applicable instead of those above.\r\nIf you wish to allow use of your version of this file only under the terms\r\nof the GPL and not to allow others to use your version of this file\r\nunder the MPL, indicate your decision by deleting the provisions above and\r\nreplace them with the notice and other provisions required by the GPL.\r\nIf you do not delete the provisions above, a recipient may use your version\r\nof this file under either the MPL or the GPL.\r\n\r\n$Id: SynHighlighterADSP21xx.pas,v 1.16.2.7 2008/09/14 16:24:59 maelh Exp $\r\n\r\nYou may retrieve the latest version of this file at the SynEdit home page,\r\nlocated at http://SynEdit.SourceForge.net\r\n\r\nKnown Issues:\r\n-------------------------------------------------------------------------------}\r\n{\r\n@abstract(Provides a ADSP21xx highlighter for SynEdit)\r\n@author(Wynand Breytenbach, converted to SynEdit by David Muir )\r\n@created(1999)\r\n@lastmod(2000-06-23)\r\nThe SynHighlighterADSP21xx unit provides a ADSP21xx DSP assembler highlighter for SynEdit.\r\n}\r\n\r\n{$IFNDEF QSYNHIGHLIGHTERADSP21XX}\r\nunit SynHighlighterADSP21xx;\r\n{$ENDIF}\r\n\r\n{$I SynEdit.inc}\r\n\r\ninterface\r\n\r\nuses\r\n{$IFDEF SYN_CLX}\r\n  QGraphics,\r\n  QSynEditTypes,\r\n  QSynEditHighlighter,\r\n  QSynUnicode,\r\n{$ELSE}\r\n  Graphics,\r\n  SynEditTypes,\r\n  SynEditHighlighter,\r\n  SynUnicode,\r\n{$ENDIF}\r\n  SysUtils,\r\n  Classes;\r\n\r\ntype\r\n  TtkTokenKind = (tkComment, tkCondition, tkIdentifier, tkKey, tkNull, tkNumber,\r\n    tkRegister, tkSpace, tkString, tkSymbol, tkUnknown);\r\n\r\n  TRangeState = (rsUnKnown, rsPascalComment, rsCComment, rsHexNumber,\r\n    rsBinaryNumber, rsInclude);\r\n\r\n  PIdentFuncTableFunc = ^TIdentFuncTableFunc;\r\n  TIdentFuncTableFunc = function (Index: Integer): TtkTokenKind of object;\r\n\r\n  TSynADSP21xxSyn = class(TSynCustomHighlighter)\r\n  private\r\n    fRange: TRangeState;\r\n    fIdentFuncTable: array[0..820] of TIdentFuncTableFunc;\r\n    FTokenID: TtkTokenKind;\r\n    fNumberAttri: TSynHighlighterAttributes;\r\n    fStringAttri: TSynHighlighterAttributes;\r\n    fKeyAttri: TSynHighlighterAttributes;\r\n    fSymbolAttri: TSynHighlighterAttributes;\r\n    fCommentAttri: TSynHighlighterAttributes;\r\n    fIdentifierAttri: TSynHighlighterAttributes;\r\n    fSpaceAttri: TSynHighlighterAttributes;\r\n    fRegisterAttri: TSynHighlighterAttributes;\r\n    fConditionAttri: TSynHighlighterAttributes;\r\n    fNullAttri: TSynHighlighterAttributes;\r\n    fUnknownAttri: TSynHighlighterAttributes;\r\n    function AltFunc(Index: Integer): TtkTokenKind;\r\n    function FuncAbs(Index: Integer): TtkTokenKind;\r\n    function FuncAbstract(Index: Integer): TtkTokenKind;\r\n    function FuncAc(Index: Integer): TtkTokenKind;\r\n    function FuncAf(Index: Integer): TtkTokenKind;\r\n    function FuncAlt95reg(Index: Integer): TtkTokenKind;\r\n    function FuncAnd(Index: Integer): TtkTokenKind;\r\n    function FuncAr(Index: Integer): TtkTokenKind;\r\n    function FuncAr95sat(Index: Integer): TtkTokenKind;\r\n    function FuncAshift(Index: Integer): TtkTokenKind;\r\n    function FuncAstat(Index: Integer): TtkTokenKind;\r\n    function FuncAux(Index: Integer): TtkTokenKind;\r\n    function FuncAv(Index: Integer): TtkTokenKind;\r\n    function FuncAv95latch(Index: Integer): TtkTokenKind;\r\n    function FuncAx0(Index: Integer): TtkTokenKind;\r\n    function FuncAx1(Index: Integer): TtkTokenKind;\r\n    function FuncAy0(Index: Integer): TtkTokenKind;\r\n    function FuncAy1(Index: Integer): TtkTokenKind;\r\n    function FuncB(Index: Integer): TtkTokenKind;\r\n    function FuncBit95rev(Index: Integer): TtkTokenKind;\r\n    function FuncBm(Index: Integer): TtkTokenKind;\r\n    function FuncBoot(Index: Integer): TtkTokenKind;\r\n    function FuncBy(Index: Integer): TtkTokenKind;\r\n    function FuncCache(Index: Integer): TtkTokenKind;\r\n    function FuncCall(Index: Integer): TtkTokenKind;\r\n    function FuncCe(Index: Integer): TtkTokenKind;\r\n    function FuncCirc(Index: Integer): TtkTokenKind;\r\n    function FuncClear(Index: Integer): TtkTokenKind;\r\n    function FuncClr(Index: Integer): TtkTokenKind;\r\n    function FuncClrbit(Index: Integer): TtkTokenKind;\r\n    function FuncCntl(Index: Integer): TtkTokenKind;\r\n    function FuncCntr(Index: Integer): TtkTokenKind;\r\n    function FuncConst(Index: Integer): TtkTokenKind;\r\n    function FuncDefine(Index: Integer): TtkTokenKind;\r\n    function FuncDis(Index: Integer): TtkTokenKind;\r\n    function FuncDivq(Index: Integer): TtkTokenKind;\r\n    function FuncDivs(Index: Integer): TtkTokenKind;\r\n    function FuncDm(Index: Integer): TtkTokenKind;\r\n    function FuncDmovlay(Index: Integer): TtkTokenKind;\r\n    function FuncDo(Index: Integer): TtkTokenKind;\r\n    function FuncElse(Index: Integer): TtkTokenKind;\r\n    function FuncEmode(Index: Integer): TtkTokenKind;\r\n    function FuncEna(Index: Integer): TtkTokenKind;\r\n    function FuncEndif(Index: Integer): TtkTokenKind;\r\n    function FuncEndmacro(Index: Integer): TtkTokenKind;\r\n    function FuncEndmod(Index: Integer): TtkTokenKind;\r\n    function FuncEntry(Index: Integer): TtkTokenKind;\r\n    function FuncEq(Index: Integer): TtkTokenKind;\r\n    function FuncExp(Index: Integer): TtkTokenKind;\r\n    function FuncExpadj(Index: Integer): TtkTokenKind;\r\n    function FuncExternal(Index: Integer): TtkTokenKind;\r\n    function FuncFl0(Index: Integer): TtkTokenKind;\r\n    function FuncFl1(Index: Integer): TtkTokenKind;\r\n    function FuncFl2(Index: Integer): TtkTokenKind;\r\n    function FuncFlag95in(Index: Integer): TtkTokenKind;\r\n    function FuncFlag95out(Index: Integer): TtkTokenKind;\r\n    function FuncFor(Index: Integer): TtkTokenKind;\r\n    function FuncForever(Index: Integer): TtkTokenKind;\r\n    function FuncGe(Index: Integer): TtkTokenKind;\r\n    function FuncGlobal(Index: Integer): TtkTokenKind;\r\n    function FuncGo95mode(Index: Integer): TtkTokenKind;\r\n    function FuncGt(Index: Integer): TtkTokenKind;\r\n    function FuncH(Index: Integer): TtkTokenKind;\r\n    function FuncHi(Index: Integer): TtkTokenKind;\r\n    function FuncI0(Index: Integer): TtkTokenKind;\r\n    function FuncI1(Index: Integer): TtkTokenKind;\r\n    function FuncI2(Index: Integer): TtkTokenKind;\r\n    function FuncI3(Index: Integer): TtkTokenKind;\r\n    function FuncI4(Index: Integer): TtkTokenKind;\r\n    function FuncI5(Index: Integer): TtkTokenKind;\r\n    function FuncI6(Index: Integer): TtkTokenKind;\r\n    function FuncI7(Index: Integer): TtkTokenKind;\r\n    function FuncIcntl(Index: Integer): TtkTokenKind;\r\n    function FuncIdle(Index: Integer): TtkTokenKind;\r\n    function FuncIf(Index: Integer): TtkTokenKind;\r\n    function FuncIfc(Index: Integer): TtkTokenKind;\r\n    function FuncIfdef(Index: Integer): TtkTokenKind;\r\n    function FuncIfndef(Index: Integer): TtkTokenKind;\r\n    function FuncImask(Index: Integer): TtkTokenKind;\r\n    function FuncIn(Index: Integer): TtkTokenKind;\r\n    function FuncInclude(Index: Integer): TtkTokenKind;\r\n    function FuncInit(Index: Integer): TtkTokenKind;\r\n    function FuncIo(Index: Integer): TtkTokenKind;\r\n    function FuncJump(Index: Integer): TtkTokenKind;\r\n    function FuncL0(Index: Integer): TtkTokenKind;\r\n    function FuncL1(Index: Integer): TtkTokenKind;\r\n    function FuncL2(Index: Integer): TtkTokenKind;\r\n    function FuncL3(Index: Integer): TtkTokenKind;\r\n    function FuncL4(Index: Integer): TtkTokenKind;\r\n    function FuncL5(Index: Integer): TtkTokenKind;\r\n    function FuncL6(Index: Integer): TtkTokenKind;\r\n    function FuncL7(Index: Integer): TtkTokenKind;\r\n    function FuncLe(Index: Integer): TtkTokenKind;\r\n    function FuncLo(Index: Integer): TtkTokenKind;\r\n    function FuncLocal(Index: Integer): TtkTokenKind;\r\n    function FuncLoop(Index: Integer): TtkTokenKind;\r\n    function FuncLshift(Index: Integer): TtkTokenKind;\r\n    function FuncLt(Index: Integer): TtkTokenKind;\r\n    function FuncM95mode(Index: Integer): TtkTokenKind;\r\n    function FuncM0(Index: Integer): TtkTokenKind;\r\n    function FuncM1(Index: Integer): TtkTokenKind;\r\n    function FuncM2(Index: Integer): TtkTokenKind;\r\n    function FuncM3(Index: Integer): TtkTokenKind;\r\n    function FuncM4(Index: Integer): TtkTokenKind;\r\n    function FuncM5(Index: Integer): TtkTokenKind;\r\n    function FuncM6(Index: Integer): TtkTokenKind;\r\n    function FuncM7(Index: Integer): TtkTokenKind;\r\n    function FuncMacro(Index: Integer): TtkTokenKind;\r\n    function FuncMf(Index: Integer): TtkTokenKind;\r\n    function FuncModify(Index: Integer): TtkTokenKind;\r\n    function FuncModule(Index: Integer): TtkTokenKind;\r\n    function FuncMr(Index: Integer): TtkTokenKind;\r\n    function FuncMr0(Index: Integer): TtkTokenKind;\r\n    function FuncMr1(Index: Integer): TtkTokenKind;\r\n    function FuncMr2(Index: Integer): TtkTokenKind;\r\n    function FuncMstat(Index: Integer): TtkTokenKind;\r\n    function FuncMv(Index: Integer): TtkTokenKind;\r\n    function FuncMx0(Index: Integer): TtkTokenKind;\r\n    function FuncMx1(Index: Integer): TtkTokenKind;\r\n    function FuncMy0(Index: Integer): TtkTokenKind;\r\n    function FuncMy1(Index: Integer): TtkTokenKind;\r\n    function FuncName(Index: Integer): TtkTokenKind;\r\n    function FuncNe(Index: Integer): TtkTokenKind;\r\n    function FuncNeg(Index: Integer): TtkTokenKind;\r\n    function FuncNewpage(Index: Integer): TtkTokenKind;\r\n    function FuncNop(Index: Integer): TtkTokenKind;\r\n    function FuncNorm(Index: Integer): TtkTokenKind;\r\n    function FuncNot(Index: Integer): TtkTokenKind;\r\n    function FuncOf(Index: Integer): TtkTokenKind;\r\n    function FuncOr(Index: Integer): TtkTokenKind;\r\n    function FuncPass(Index: Integer): TtkTokenKind;\r\n    function FuncPc(Index: Integer): TtkTokenKind;\r\n    function FuncPm(Index: Integer): TtkTokenKind;\r\n    function FuncPop(Index: Integer): TtkTokenKind;\r\n    function FuncPort(Index: Integer): TtkTokenKind;\r\n    function FuncPush(Index: Integer): TtkTokenKind;\r\n    function FuncRam(Index: Integer): TtkTokenKind;\r\n    function FuncRegbank(Index: Integer): TtkTokenKind;\r\n    function FuncReset(Index: Integer): TtkTokenKind;\r\n    function FuncRnd(Index: Integer): TtkTokenKind;\r\n    function FuncRom(Index: Integer): TtkTokenKind;\r\n    function FuncRti(Index: Integer): TtkTokenKind;\r\n    function FuncRts(Index: Integer): TtkTokenKind;\r\n    function FuncRx0(Index: Integer): TtkTokenKind;\r\n    function FuncRx1(Index: Integer): TtkTokenKind;\r\n    function FuncSat(Index: Integer): TtkTokenKind;\r\n    function FuncSb(Index: Integer): TtkTokenKind;\r\n    function FuncSec95reg(Index: Integer): TtkTokenKind;\r\n    function FuncSeg(Index: Integer): TtkTokenKind;\r\n    function FuncSegment(Index: Integer): TtkTokenKind;\r\n    function FuncSet(Index: Integer): TtkTokenKind;\r\n    function FuncSetbit(Index: Integer): TtkTokenKind;\r\n    function FuncShift(Index: Integer): TtkTokenKind;\r\n    function FuncShl(Index: Integer): TtkTokenKind;\r\n    function FuncShr(Index: Integer): TtkTokenKind;\r\n    function FuncSi(Index: Integer): TtkTokenKind;\r\n    function FuncSr(Index: Integer): TtkTokenKind;\r\n    function FuncSr0(Index: Integer): TtkTokenKind;\r\n    function FuncSr1(Index: Integer): TtkTokenKind;\r\n    function FuncSs(Index: Integer): TtkTokenKind;\r\n    function FuncSstat(Index: Integer): TtkTokenKind;\r\n    function FuncStatic(Index: Integer): TtkTokenKind;\r\n    function FuncSts(Index: Integer): TtkTokenKind;\r\n    function FuncSu(Index: Integer): TtkTokenKind;\r\n    function FuncTest(Index: Integer): TtkTokenKind;\r\n    function FuncTestbit(Index: Integer): TtkTokenKind;\r\n    function FuncTglbit(Index: Integer): TtkTokenKind;\r\n    function FuncTimer(Index: Integer): TtkTokenKind;\r\n    function FuncToggle(Index: Integer): TtkTokenKind;\r\n    function FuncTopofpcstack(Index: Integer): TtkTokenKind;\r\n    function FuncTrap(Index: Integer): TtkTokenKind;\r\n    function FuncTrue(Index: Integer): TtkTokenKind;\r\n    function FuncTx0(Index: Integer): TtkTokenKind;\r\n    function FuncTx1(Index: Integer): TtkTokenKind;\r\n    function FuncUndef(Index: Integer): TtkTokenKind;\r\n    function FuncUntil(Index: Integer): TtkTokenKind;\r\n    function FuncUs(Index: Integer): TtkTokenKind;\r\n    function FuncUu(Index: Integer): TtkTokenKind;\r\n    function FuncVar(Index: Integer): TtkTokenKind;\r\n    function FuncXor(Index: Integer): TtkTokenKind;\r\n    function HashKey(Str: PWideChar): Cardinal;\r\n    function IdentKind(MayBe: PWideChar): TtkTokenKind;\r\n    procedure InitIdent;\r\n    procedure PascalCommentProc;\r\n    procedure BraceCloseProc;\r\n    procedure BraceOpenProc;\r\n    procedure CCommentProc;\r\n    procedure CRProc;\r\n    procedure ExclamationProc;\r\n    procedure IdentProc;\r\n    procedure IntegerProc;\r\n    procedure IncludeCloseProc;\r\n    procedure LFProc;\r\n    procedure NullProc;\r\n    procedure NumberProc;\r\n    procedure BinaryNumber;\r\n    procedure HexNumber;\r\n    procedure SlashProc;\r\n    procedure SpaceProc;\r\n    procedure StringProc;\r\n    procedure UnknownProc;\r\n  protected\r\n    function IsFilterStored: Boolean; override;\r\n  public\r\n    class function GetCapabilities: TSynHighlighterCapabilities; override;\r\n    class function GetLanguageName: string; override;\r\n    class function GetFriendlyLanguageName: UnicodeString; override;\r\n  public\r\n    constructor Create(AOwner: TComponent); override;\r\n    function GetDefaultAttribute(Index: integer): TSynHighlighterAttributes;\r\n      override;\r\n    function GetEol: Boolean; override;\r\n    function GetRange: Pointer; override;\r\n    function GetTokenID: TtkTokenKind;\r\n    function GetTokenAttribute: TSynHighlighterAttributes; override;\r\n    function GetTokenKind: integer; override;\r\n    procedure Next; override;\r\n    procedure SetRange(Value: Pointer); override;\r\n    procedure ResetRange; override;\r\n    function UseUserSettings(settingIndex: integer): boolean; override;\r\n    procedure EnumUserSettings(settings: TStrings); override;\r\n  published\r\n    property CommentAttri: TSynHighlighterAttributes read fCommentAttri\r\n      write fCommentAttri;\r\n    property ConditionAttri: TSynHighlighterAttributes read fConditionAttri\r\n      write fConditionAttri;\r\n    property IdentifierAttri: TSynHighlighterAttributes read fIdentifierAttri\r\n      write fIdentifierAttri;\r\n    property KeyAttri: TSynHighlighterAttributes read fKeyAttri write fKeyAttri;\r\n    property NumberAttri: TSynHighlighterAttributes read fNumberAttri\r\n      write fNumberAttri;\r\n    property RegisterAttri: TSynHighlighterAttributes read fRegisterAttri\r\n      write fRegisterAttri;\r\n    property StringAttri: TSynHighlighterAttributes read fStringAttri\r\n      write fStringAttri;\r\n    property SpaceAttri: TSynHighlighterAttributes read fSpaceAttri\r\n      write fSpaceAttri;\r\n    property SymbolAttri: TSynHighlighterAttributes read fSymbolAttri\r\n      write fSymbolAttri;\r\n  end;\r\n\r\nimplementation\r\n\r\nuses\r\n{$IFDEF SYN_CLX}\r\n  QSynEditStrConst;\r\n{$ELSE}\r\n  Windows,\r\n  SynEditStrConst;\r\n{$ENDIF}\r\n\r\nconst\r\n  KeyWords: array[0..178] of UnicodeString = (\r\n    'abs', 'abstract', 'ac', 'af', 'alt_reg', 'and', 'ar', 'ar_sat', 'ashift', \r\n    'astat', 'aux', 'av', 'av_latch', 'ax0', 'ax1', 'ay0', 'ay1', 'b', \r\n    'bit_rev', 'bm', 'boot', 'by', 'cache', 'call', 'ce', 'circ', 'clear', \r\n    'clr', 'clrbit', 'cntl', 'cntr', 'const', 'define', 'dis', 'divq', 'divs', \r\n    'dm', 'dmovlay', 'do', 'else', 'emode', 'ena', 'endif', 'endmacro', \r\n    'endmod', 'entry', 'eq', 'exp', 'expadj', 'external', 'fl0', 'fl1', 'fl2', \r\n    'flag_in', 'flag_out', 'for', 'forever', 'ge', 'global', 'go_mode', 'gt', \r\n    'h', 'hi', 'i0', 'i1', 'i2', 'i3', 'i4', 'i5', 'i6', 'i7', 'icntl', 'idle', \r\n    'if', 'ifc', 'ifdef', 'ifndef', 'imask', 'in', 'include', 'init', 'io', \r\n    'jump', 'l0', 'l1', 'l2', 'l3', 'l4', 'l5', 'l6', 'l7', 'le', 'lo', 'local', \r\n    'loop', 'lshift', 'lt', 'm_mode', 'm0', 'm1', 'm2', 'm3', 'm4', 'm5', 'm6', \r\n    'm7', 'macro', 'mf', 'modify', 'module', 'mr', 'mr0', 'mr1', 'mr2', 'mstat', \r\n    'mv', 'mx0', 'mx1', 'my0', 'my1', 'name', 'ne', 'neg', 'newpage', 'nop', \r\n    'norm', 'not', 'of', 'or', 'pass', 'pc', 'pm', 'pop', 'port', 'push', 'ram', \r\n    'regbank', 'reset', 'rnd', 'rom', 'rti', 'rts', 'rx0', 'rx1', 'sat', 'sb', \r\n    'sec_reg', 'seg', 'segment', 'set', 'setbit', 'shift', 'shl', 'shr', 'si', \r\n    'sr', 'sr0', 'sr1', 'ss', 'sstat', 'static', 'sts', 'su', 'test', 'testbit', \r\n    'tglbit', 'timer', 'toggle', 'topofpcstack', 'trap', 'true', 'tx0', 'tx1', \r\n    'undef', 'until', 'us', 'uu', 'var', 'xor' \r\n  );\r\n\r\n  KeyIndices: array[0..820] of Integer = (\r\n    -1, -1, -1, -1, -1, -1, -1, -1, 110, -1, -1, -1, -1, -1, -1, -1, -1, -1, 67, \r\n    15, -1, 48, 100, 132, -1, -1, -1, -1, -1, 133, -1, -1, -1, -1, -1, -1, -1, \r\n    152, 93, 155, -1, -1, -1, 70, 62, -1, -1, 103, 0, -1, -1, 10, -1, -1, -1, \r\n    -1, -1, -1, 171, -1, -1, -1, -1, 120, 162, -1, -1, -1, -1, -1, 82, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 153, -1, -1, -1, 50, \r\n    -1, -1, -1, -1, -1, -1, 72, 12, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, 20, -1, -1, -1, 25, -1, -1, -1, 8, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, 156, 83, -1, -1, -1, -1, -1, 77, 106, -1, 45, 27, \r\n    -1, -1, -1, -1, -1, 7, -1, -1, 43, -1, 74, 14, 174, 73, 86, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, 56, -1, -1, -1, -1, 111, -1, -1, 140, -1, \r\n    -1, -1, 89, -1, -1, -1, -1, 127, -1, -1, -1, 28, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, 116, -1, 49, -1, -1, 164, 23, -1, -1, 9, -1, -1, \r\n    -1, -1, 149, -1, -1, -1, 40, -1, -1, 46, -1, 94, -1, 81, -1, 134, -1, -1, \r\n    -1, -1, -1, -1, -1, 55, -1, 47, -1, -1, -1, -1, 11, -1, 135, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, 109, -1, -1, -1, -1, -1, -1, 65, 142, -1, \r\n    -1, 98, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 128, -1, -1, -1, -1, \r\n    -1, 18, -1, 68, 16, -1, -1, 101, 91, -1, -1, -1, 130, -1, 167, -1, -1, -1, \r\n    115, -1, -1, -1, -1, 19, 158, -1, 163, -1, -1, -1, -1, -1, 104, -1, -1, -1, \r\n    -1, -1, -1, -1, 39, -1, 79, 172, -1, -1, -1, -1, 41, -1, 38, 176, 80, -1, \r\n    -1, -1, 118, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 71, \r\n    75, -1, -1, 51, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 138, -1, -1, -1, -1, \r\n    -1, -1, 42, -1, -1, -1, -1, -1, -1, 58, -1, -1, 136, -1, -1, -1, -1, -1, -1, \r\n    177, -1, -1, -1, -1, -1, -1, -1, 57, -1, 157, 84, 21, -1, -1, -1, -1, -1, 1, \r\n    -1, -1, -1, 96, 161, -1, -1, 123, -1, -1, -1, -1, -1, -1, -1, -1, -1, 87, \r\n    -1, -1, -1, 54, 137, -1, -1, 124, 145, -1, -1, -1, -1, -1, -1, -1, -1, 112, \r\n    -1, -1, 173, -1, -1, -1, 90, -1, 125, -1, 166, -1, -1, -1, -1, 144, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 117, -1, -1, 170, -1, -1, \r\n    35, -1, -1, -1, -1, -1, -1, -1, 148, -1, 44, -1, -1, -1, -1, 159, -1, -1, \r\n    -1, -1, -1, 150, -1, -1, -1, -1, 31, -1, -1, -1, -1, -1, -1, 63, -1, -1, -1, \r\n    178, -1, -1, -1, 141, 60, -1, 17, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, 66, 143, -1, -1, 99, -1, -1, 97, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, 37, -1, -1, 26, -1, -1, 69, -1, -1, -1, 102, -1, -1, 121, -1, \r\n    -1, -1, 61, 129, 95, -1, -1, -1, 122, -1, 139, -1, -1, 36, 175, -1, -1, -1, \r\n    -1, -1, 105, -1, -1, -1, -1, -1, 108, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, 32, -1, -1, -1, -1, -1, 119, -1, -1, -1, -1, -1, -1, 2, -1, -1, 165, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, 52, -1, -1, -1, -1, -1, -1, 92, -1, 147, \r\n    -1, 131, 3, -1, 24, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 168, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, 4, -1, -1, -1, -1, 13, -1, -1, 85, 59, \r\n    -1, -1, 146, -1, -1, -1, -1, -1, -1, -1, -1, -1, 33, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, 88, -1, -1, 107, -1, -1, -1, -1, -1, -1, 160, -1, -1, -1, \r\n    -1, -1, -1, -1, 113, 151, -1, -1, -1, -1, 53, -1, -1, -1, -1, -1, 34, 29, \r\n    169, 126, 114, -1, -1, 22, -1, -1, -1, 6, -1, -1, -1, -1, -1, -1, -1, 78, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, 154, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, 76, -1, -1, -1, -1, -1, 5, 30, -1, -1, -1, -1, -1, -1, \r\n    64, -1, -1, -1, -1, -1, -1 \r\n  );\r\n\r\n{$Q-}\r\nfunction TSynADSP21xxSyn.HashKey(Str: PWideChar): Cardinal;\r\nbegin\r\n  Result := 0;\r\n  while IsIdentChar(Str^) do\r\n  begin\r\n    Result := Result * 641 + Ord(Str^) * 282;\r\n    inc(Str);\r\n  end;\r\n  Result := Result mod 821;\r\n  fStringLen := Str - fToIdent;\r\nend;\r\n{$Q+}\r\n\r\nfunction TSynADSP21xxSyn.IdentKind(MayBe: PWideChar): TtkTokenKind;\r\nvar\r\n  Key: Cardinal;\r\nbegin\r\n  fToIdent := MayBe;\r\n  Key := HashKey(MayBe);\r\n  if Key <= High(fIdentFuncTable) then\r\n    Result := fIdentFuncTable[Key](KeyIndices[Key])\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nprocedure TSynADSP21xxSyn.InitIdent;\r\nvar\r\n  i: Integer;\r\nbegin\r\n  for i := Low(fIdentFuncTable) to High(fIdentFuncTable) do\r\n    if KeyIndices[i] = -1 then\r\n      fIdentFuncTable[i] := AltFunc;\r\n\r\n  fIdentFuncTable[48] := FuncAbs;\r\n  fIdentFuncTable[426] := FuncAbstract;\r\n  fIdentFuncTable[642] := FuncAc;\r\n  fIdentFuncTable[667] := FuncAf;\r\n  fIdentFuncTable[693] := FuncAlt95reg;\r\n  fIdentFuncTable[806] := FuncAnd;\r\n  fIdentFuncTable[767] := FuncAr;\r\n  fIdentFuncTable[153] := FuncAr95sat;\r\n  fIdentFuncTable[126] := FuncAshift;\r\n  fIdentFuncTable[220] := FuncAstat;\r\n  fIdentFuncTable[51] := FuncAux;\r\n  fIdentFuncTable[253] := FuncAv;\r\n  fIdentFuncTable[99] := FuncAv95latch;\r\n  fIdentFuncTable[698] := FuncAx0;\r\n  fIdentFuncTable[159] := FuncAx1;\r\n  fIdentFuncTable[19] := FuncAy0;\r\n  fIdentFuncTable[301] := FuncAy1;\r\n  fIdentFuncTable[543] := FuncB;\r\n  fIdentFuncTable[298] := FuncBit95rev;\r\n  fIdentFuncTable[320] := FuncBm;\r\n  fIdentFuncTable[118] := FuncBoot;\r\n  fIdentFuncTable[420] := FuncBy;\r\n  fIdentFuncTable[763] := FuncCache;\r\n  fIdentFuncTable[217] := FuncCall;\r\n  fIdentFuncTable[669] := FuncCe;\r\n  fIdentFuncTable[122] := FuncCirc;\r\n  fIdentFuncTable[579] := FuncClear;\r\n  fIdentFuncTable[147] := FuncClr;\r\n  fIdentFuncTable[196] := FuncClrbit;\r\n  fIdentFuncTable[757] := FuncCntl;\r\n  fIdentFuncTable[807] := FuncCntr;\r\n  fIdentFuncTable[525] := FuncConst;\r\n  fIdentFuncTable[629] := FuncDefine;\r\n  fIdentFuncTable[715] := FuncDis;\r\n  fIdentFuncTable[756] := FuncDivq;\r\n  fIdentFuncTable[499] := FuncDivs;\r\n  fIdentFuncTable[604] := FuncDm;\r\n  fIdentFuncTable[576] := FuncDmovlay;\r\n  fIdentFuncTable[347] := FuncDo;\r\n  fIdentFuncTable[337] := FuncElse;\r\n  fIdentFuncTable[229] := FuncEmode;\r\n  fIdentFuncTable[345] := FuncEna;\r\n  fIdentFuncTable[391] := FuncEndif;\r\n  fIdentFuncTable[156] := FuncEndmacro;\r\n  fIdentFuncTable[509] := FuncEndmod;\r\n  fIdentFuncTable[146] := FuncEntry;\r\n  fIdentFuncTable[232] := FuncEq;\r\n  fIdentFuncTable[248] := FuncExp;\r\n  fIdentFuncTable[21] := FuncExpadj;\r\n  fIdentFuncTable[213] := FuncExternal;\r\n  fIdentFuncTable[91] := FuncFl0;\r\n  fIdentFuncTable[373] := FuncFl1;\r\n  fIdentFuncTable[655] := FuncFl2;\r\n  fIdentFuncTable[750] := FuncFlag95in;\r\n  fIdentFuncTable[448] := FuncFlag95out;\r\n  fIdentFuncTable[246] := FuncFor;\r\n  fIdentFuncTable[175] := FuncForever;\r\n  fIdentFuncTable[416] := FuncGe;\r\n  fIdentFuncTable[398] := FuncGlobal;\r\n  fIdentFuncTable[702] := FuncGo95mode;\r\n  fIdentFuncTable[541] := FuncGt;\r\n  fIdentFuncTable[593] := FuncH;\r\n  fIdentFuncTable[44] := FuncHi;\r\n  fIdentFuncTable[532] := FuncI0;\r\n  fIdentFuncTable[814] := FuncI1;\r\n  fIdentFuncTable[275] := FuncI2;\r\n  fIdentFuncTable[557] := FuncI3;\r\n  fIdentFuncTable[18] := FuncI4;\r\n  fIdentFuncTable[300] := FuncI5;\r\n  fIdentFuncTable[582] := FuncI6;\r\n  fIdentFuncTable[43] := FuncI7;\r\n  fIdentFuncTable[369] := FuncIcntl;\r\n  fIdentFuncTable[98] := FuncIdle;\r\n  fIdentFuncTable[161] := FuncIf;\r\n  fIdentFuncTable[158] := FuncIfc;\r\n  fIdentFuncTable[370] := FuncIfdef;\r\n  fIdentFuncTable[800] := FuncIfndef;\r\n  fIdentFuncTable[143] := FuncImask;\r\n  fIdentFuncTable[775] := FuncIn;\r\n  fIdentFuncTable[339] := FuncInclude;\r\n  fIdentFuncTable[349] := FuncInit;\r\n  fIdentFuncTable[236] := FuncIo;\r\n  fIdentFuncTable[70] := FuncJump;\r\n  fIdentFuncTable[137] := FuncL0;\r\n  fIdentFuncTable[419] := FuncL1;\r\n  fIdentFuncTable[701] := FuncL2;\r\n  fIdentFuncTable[162] := FuncL3;\r\n  fIdentFuncTable[444] := FuncL4;\r\n  fIdentFuncTable[726] := FuncL5;\r\n  fIdentFuncTable[187] := FuncL6;\r\n  fIdentFuncTable[469] := FuncL7;\r\n  fIdentFuncTable[305] := FuncLe;\r\n  fIdentFuncTable[662] := FuncLo;\r\n  fIdentFuncTable[38] := FuncLocal;\r\n  fIdentFuncTable[234] := FuncLoop;\r\n  fIdentFuncTable[595] := FuncLshift;\r\n  fIdentFuncTable[430] := FuncLt;\r\n  fIdentFuncTable[564] := FuncM95mode;\r\n  fIdentFuncTable[279] := FuncM0;\r\n  fIdentFuncTable[561] := FuncM1;\r\n  fIdentFuncTable[22] := FuncM2;\r\n  fIdentFuncTable[304] := FuncM3;\r\n  fIdentFuncTable[586] := FuncM4;\r\n  fIdentFuncTable[47] := FuncM5;\r\n  fIdentFuncTable[329] := FuncM6;\r\n  fIdentFuncTable[611] := FuncM7;\r\n  fIdentFuncTable[144] := FuncMacro;\r\n  fIdentFuncTable[729] := FuncMf;\r\n  fIdentFuncTable[617] := FuncModify;\r\n  fIdentFuncTable[268] := FuncModule;\r\n  fIdentFuncTable[8] := FuncMr;\r\n  fIdentFuncTable[180] := FuncMr0;\r\n  fIdentFuncTable[462] := FuncMr1;\r\n  fIdentFuncTable[744] := FuncMr2;\r\n  fIdentFuncTable[760] := FuncMstat;\r\n  fIdentFuncTable[315] := FuncMv;\r\n  fIdentFuncTable[211] := FuncMx0;\r\n  fIdentFuncTable[493] := FuncMx1;\r\n  fIdentFuncTable[353] := FuncMy0;\r\n  fIdentFuncTable[635] := FuncMy1;\r\n  fIdentFuncTable[63] := FuncName;\r\n  fIdentFuncTable[589] := FuncNe;\r\n  fIdentFuncTable[599] := FuncNeg;\r\n  fIdentFuncTable[434] := FuncNewpage;\r\n  fIdentFuncTable[452] := FuncNop;\r\n  fIdentFuncTable[471] := FuncNorm;\r\n  fIdentFuncTable[759] := FuncNot;\r\n  fIdentFuncTable[192] := FuncOf;\r\n  fIdentFuncTable[292] := FuncOr;\r\n  fIdentFuncTable[594] := FuncPass;\r\n  fIdentFuncTable[309] := FuncPc;\r\n  fIdentFuncTable[666] := FuncPm;\r\n  fIdentFuncTable[23] := FuncPop;\r\n  fIdentFuncTable[29] := FuncPort;\r\n  fIdentFuncTable[238] := FuncPush;\r\n  fIdentFuncTable[255] := FuncRam;\r\n  fIdentFuncTable[401] := FuncRegbank;\r\n  fIdentFuncTable[449] := FuncReset;\r\n  fIdentFuncTable[384] := FuncRnd;\r\n  fIdentFuncTable[601] := FuncRom;\r\n  fIdentFuncTable[183] := FuncRti;\r\n  fIdentFuncTable[540] := FuncRts;\r\n  fIdentFuncTable[276] := FuncRx0;\r\n  fIdentFuncTable[558] := FuncRx1;\r\n  fIdentFuncTable[478] := FuncSat;\r\n  fIdentFuncTable[453] := FuncSb;\r\n  fIdentFuncTable[705] := FuncSec95reg;\r\n  fIdentFuncTable[664] := FuncSeg;\r\n  fIdentFuncTable[507] := FuncSegment;\r\n  fIdentFuncTable[225] := FuncSet;\r\n  fIdentFuncTable[520] := FuncSetbit;\r\n  fIdentFuncTable[745] := FuncShift;\r\n  fIdentFuncTable[37] := FuncShl;\r\n  fIdentFuncTable[87] := FuncShr;\r\n  fIdentFuncTable[785] := FuncSi;\r\n  fIdentFuncTable[39] := FuncSr;\r\n  fIdentFuncTable[136] := FuncSr0;\r\n  fIdentFuncTable[418] := FuncSr1;\r\n  fIdentFuncTable[321] := FuncSs;\r\n  fIdentFuncTable[514] := FuncSstat;\r\n  fIdentFuncTable[736] := FuncStatic;\r\n  fIdentFuncTable[431] := FuncSts;\r\n  fIdentFuncTable[64] := FuncSu;\r\n  fIdentFuncTable[323] := FuncTest;\r\n  fIdentFuncTable[216] := FuncTestbit;\r\n  fIdentFuncTable[645] := FuncTglbit;\r\n  fIdentFuncTable[473] := FuncTimer;\r\n  fIdentFuncTable[311] := FuncToggle;\r\n  fIdentFuncTable[683] := FuncTopofpcstack;\r\n  fIdentFuncTable[758] := FuncTrap;\r\n  fIdentFuncTable[496] := FuncTrue;\r\n  fIdentFuncTable[58] := FuncTx0;\r\n  fIdentFuncTable[340] := FuncTx1;\r\n  fIdentFuncTable[465] := FuncUndef;\r\n  fIdentFuncTable[160] := FuncUntil;\r\n  fIdentFuncTable[605] := FuncUs;\r\n  fIdentFuncTable[348] := FuncUu;\r\n  fIdentFuncTable[408] := FuncVar;\r\n  fIdentFuncTable[536] := FuncXor;\r\nend;\r\n\r\nfunction TSynADSP21xxSyn.AltFunc(Index: Integer): TtkTokenKind;\r\nbegin\r\n  Result := tkIdentifier\r\nend;\r\n\r\nfunction TSynADSP21xxSyn.FuncAbs(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkRegister\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynADSP21xxSyn.FuncAbstract(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynADSP21xxSyn.FuncAc(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkRegister\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynADSP21xxSyn.FuncAf(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkRegister\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynADSP21xxSyn.FuncAlt95reg(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynADSP21xxSyn.FuncAnd(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynADSP21xxSyn.FuncAr(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkRegister\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynADSP21xxSyn.FuncAr95sat(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynADSP21xxSyn.FuncAshift(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynADSP21xxSyn.FuncAstat(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynADSP21xxSyn.FuncAux(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynADSP21xxSyn.FuncAv(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkRegister\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynADSP21xxSyn.FuncAv95latch(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynADSP21xxSyn.FuncAx0(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkRegister\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynADSP21xxSyn.FuncAx1(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkRegister\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynADSP21xxSyn.FuncAy0(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkRegister\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynADSP21xxSyn.FuncAy1(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkRegister\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynADSP21xxSyn.FuncB(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n  begin\r\n    if FLine[Run + 1] = '#' then\r\n    begin\r\n      Result := tkNumber;\r\n      fRange := rsBinaryNumber;\r\n    end\r\n    else\r\n    begin\r\n      Result := tkIdentifier;\r\n    end\r\n  end\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynADSP21xxSyn.FuncBit95rev(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynADSP21xxSyn.FuncBm(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkRegister\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynADSP21xxSyn.FuncBoot(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynADSP21xxSyn.FuncBy(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynADSP21xxSyn.FuncCache(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynADSP21xxSyn.FuncCall(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynADSP21xxSyn.FuncCe(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkCondition\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynADSP21xxSyn.FuncCirc(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkRegister\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynADSP21xxSyn.FuncClear(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynADSP21xxSyn.FuncClr(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynADSP21xxSyn.FuncClrbit(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynADSP21xxSyn.FuncCntl(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynADSP21xxSyn.FuncCntr(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkRegister\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynADSP21xxSyn.FuncConst(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynADSP21xxSyn.FuncDefine(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynADSP21xxSyn.FuncDis(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynADSP21xxSyn.FuncDivq(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkRegister\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynADSP21xxSyn.FuncDivs(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkRegister\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynADSP21xxSyn.FuncDm(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkRegister\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynADSP21xxSyn.FuncDmovlay(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkRegister\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynADSP21xxSyn.FuncDo(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynADSP21xxSyn.FuncElse(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynADSP21xxSyn.FuncEmode(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkRegister\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynADSP21xxSyn.FuncEna(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynADSP21xxSyn.FuncEndif(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynADSP21xxSyn.FuncEndmacro(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynADSP21xxSyn.FuncEndmod(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynADSP21xxSyn.FuncEntry(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynADSP21xxSyn.FuncEq(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkCondition\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynADSP21xxSyn.FuncExp(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkRegister\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynADSP21xxSyn.FuncExpadj(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynADSP21xxSyn.FuncExternal(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynADSP21xxSyn.FuncFl0(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkRegister\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynADSP21xxSyn.FuncFl1(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkRegister\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynADSP21xxSyn.FuncFl2(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkRegister\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynADSP21xxSyn.FuncFlag95in(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkRegister\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynADSP21xxSyn.FuncFlag95out(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkRegister\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynADSP21xxSyn.FuncFor(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynADSP21xxSyn.FuncForever(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkCondition\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynADSP21xxSyn.FuncGe(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkCondition\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynADSP21xxSyn.FuncGlobal(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynADSP21xxSyn.FuncGo95mode(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynADSP21xxSyn.FuncGt(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkCondition\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynADSP21xxSyn.FuncH(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n  begin\r\n    if FLine[Run + 1] = '#' then\r\n    begin\r\n      Result := tkNumber;\r\n      fRange := rsHexNumber;\r\n    end\r\n    else\r\n    begin\r\n      Result := tkIdentifier;\r\n    end\r\n  end\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynADSP21xxSyn.FuncHi(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkRegister\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynADSP21xxSyn.FuncI0(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkRegister\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynADSP21xxSyn.FuncI1(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkRegister\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynADSP21xxSyn.FuncI2(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkRegister\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynADSP21xxSyn.FuncI3(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkRegister\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynADSP21xxSyn.FuncI4(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkRegister\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynADSP21xxSyn.FuncI5(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkRegister\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynADSP21xxSyn.FuncI6(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkRegister\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynADSP21xxSyn.FuncI7(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkRegister\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynADSP21xxSyn.FuncIcntl(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkRegister\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynADSP21xxSyn.FuncIdle(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynADSP21xxSyn.FuncIf(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynADSP21xxSyn.FuncIfc(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkRegister\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynADSP21xxSyn.FuncIfdef(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynADSP21xxSyn.FuncIfndef(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynADSP21xxSyn.FuncImask(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkRegister\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynADSP21xxSyn.FuncIn(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynADSP21xxSyn.FuncInclude(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynADSP21xxSyn.FuncInit(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynADSP21xxSyn.FuncIo(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkRegister\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynADSP21xxSyn.FuncJump(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynADSP21xxSyn.FuncL0(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkRegister\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynADSP21xxSyn.FuncL1(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkRegister\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynADSP21xxSyn.FuncL2(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkRegister\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynADSP21xxSyn.FuncL3(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkRegister\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynADSP21xxSyn.FuncL4(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkRegister\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynADSP21xxSyn.FuncL5(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkRegister\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynADSP21xxSyn.FuncL6(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkRegister\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynADSP21xxSyn.FuncL7(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkRegister\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynADSP21xxSyn.FuncLe(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkCondition\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynADSP21xxSyn.FuncLo(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkRegister\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynADSP21xxSyn.FuncLocal(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynADSP21xxSyn.FuncLoop(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynADSP21xxSyn.FuncLshift(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynADSP21xxSyn.FuncLt(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkCondition\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynADSP21xxSyn.FuncM95mode(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynADSP21xxSyn.FuncM0(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkRegister\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynADSP21xxSyn.FuncM1(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkRegister\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynADSP21xxSyn.FuncM2(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkRegister\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynADSP21xxSyn.FuncM3(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkRegister\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynADSP21xxSyn.FuncM4(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkRegister\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynADSP21xxSyn.FuncM5(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkRegister\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynADSP21xxSyn.FuncM6(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkRegister\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynADSP21xxSyn.FuncM7(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkRegister\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynADSP21xxSyn.FuncMacro(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynADSP21xxSyn.FuncMf(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkCondition\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynADSP21xxSyn.FuncModify(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynADSP21xxSyn.FuncModule(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynADSP21xxSyn.FuncMr(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkRegister\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynADSP21xxSyn.FuncMr0(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkRegister\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynADSP21xxSyn.FuncMr1(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkRegister\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynADSP21xxSyn.FuncMr2(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkRegister\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynADSP21xxSyn.FuncMstat(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkRegister\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynADSP21xxSyn.FuncMv(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkCondition\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynADSP21xxSyn.FuncMx0(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkRegister\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynADSP21xxSyn.FuncMx1(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkRegister\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynADSP21xxSyn.FuncMy0(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkRegister\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynADSP21xxSyn.FuncMy1(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkRegister\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynADSP21xxSyn.FuncName(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynADSP21xxSyn.FuncNe(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkCondition\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynADSP21xxSyn.FuncNeg(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynADSP21xxSyn.FuncNewpage(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynADSP21xxSyn.FuncNop(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynADSP21xxSyn.FuncNorm(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynADSP21xxSyn.FuncNot(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkCondition\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynADSP21xxSyn.FuncOf(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynADSP21xxSyn.FuncOr(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynADSP21xxSyn.FuncPass(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynADSP21xxSyn.FuncPc(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkRegister\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynADSP21xxSyn.FuncPm(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkRegister\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynADSP21xxSyn.FuncPop(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynADSP21xxSyn.FuncPort(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynADSP21xxSyn.FuncPush(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynADSP21xxSyn.FuncRam(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkRegister\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynADSP21xxSyn.FuncRegbank(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynADSP21xxSyn.FuncReset(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynADSP21xxSyn.FuncRnd(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynADSP21xxSyn.FuncRom(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynADSP21xxSyn.FuncRti(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynADSP21xxSyn.FuncRts(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynADSP21xxSyn.FuncRx0(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkRegister\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynADSP21xxSyn.FuncRx1(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkRegister\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynADSP21xxSyn.FuncSat(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynADSP21xxSyn.FuncSb(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkRegister\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynADSP21xxSyn.FuncSec95reg(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkRegister\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynADSP21xxSyn.FuncSeg(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkRegister\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynADSP21xxSyn.FuncSegment(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkRegister\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynADSP21xxSyn.FuncSet(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynADSP21xxSyn.FuncSetbit(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynADSP21xxSyn.FuncShift(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynADSP21xxSyn.FuncShl(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynADSP21xxSyn.FuncShr(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynADSP21xxSyn.FuncSi(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkRegister\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynADSP21xxSyn.FuncSr(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkRegister\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynADSP21xxSyn.FuncSr0(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkRegister\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynADSP21xxSyn.FuncSr1(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkRegister\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynADSP21xxSyn.FuncSs(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkCondition\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynADSP21xxSyn.FuncSstat(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynADSP21xxSyn.FuncStatic(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynADSP21xxSyn.FuncSts(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynADSP21xxSyn.FuncSu(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkRegister\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynADSP21xxSyn.FuncTest(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynADSP21xxSyn.FuncTestbit(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynADSP21xxSyn.FuncTglbit(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynADSP21xxSyn.FuncTimer(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkRegister\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynADSP21xxSyn.FuncToggle(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynADSP21xxSyn.FuncTopofpcstack(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkRegister\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynADSP21xxSyn.FuncTrap(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynADSP21xxSyn.FuncTrue(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynADSP21xxSyn.FuncTx0(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkRegister\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynADSP21xxSyn.FuncTx1(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkRegister\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynADSP21xxSyn.FuncUndef(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynADSP21xxSyn.FuncUntil(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynADSP21xxSyn.FuncUs(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkCondition\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynADSP21xxSyn.FuncUu(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkCondition\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynADSP21xxSyn.FuncVar(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynADSP21xxSyn.FuncXor(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nconstructor TSynADSP21xxSyn.Create(AOwner: TComponent);\r\nbegin\r\n  inherited Create(AOwner);\r\n\r\n  fCaseSensitive := False;\r\n\r\n  fCommentAttri := TSynHighlighterAttributes.Create(SYNS_AttrComment, SYNS_FriendlyAttrComment);\r\n  fCommentAttri.ForeGround := clTeal;\r\n  fCommentAttri.Style:= [fsItalic];\r\n  AddAttribute(fCommentAttri);\r\n\r\n  fIdentifierAttri := TSynHighlighterAttributes.Create(SYNS_AttrIdentifier, SYNS_FriendlyAttrIdentifier);\r\n  AddAttribute(fIdentifierAttri);\r\n\r\n  fKeyAttri := TSynHighlighterAttributes.Create(SYNS_AttrReservedWord, SYNS_FriendlyAttrReservedWord);\r\n  fKeyAttri.Style:= [fsBold];\r\n  AddAttribute(fKeyAttri);\r\n\r\n  fNumberAttri := TSynHighlighterAttributes.Create(SYNS_AttrNumber, SYNS_FriendlyAttrNumber);\r\n  fNumberAttri.ForeGround := clOlive;\r\n  AddAttribute(fNumberAttri);\r\n\r\n  fRegisterAttri := TSynHighlighterAttributes.Create(SYNS_AttrRegister, SYNS_FriendlyAttrRegister);\r\n  fRegisterAttri.ForeGround := clBlue;\r\n  AddAttribute(fRegisterAttri);\r\n\r\n  fConditionAttri := TSynHighlighterAttributes.Create(SYNS_AttrCondition, SYNS_FriendlyAttrCondition);\r\n  fConditionAttri.ForeGround := clFuchsia;\r\n  AddAttribute(fConditionAttri);\r\n\r\n  fSpaceAttri := TSynHighlighterAttributes.Create(SYNS_AttrSpace, SYNS_FriendlyAttrSpace);\r\n  AddAttribute(fSpaceAttri);\r\n\r\n  fSymbolAttri := TSynHighlighterAttributes.Create(SYNS_AttrSymbol, SYNS_FriendlyAttrSymbol);\r\n  AddAttribute(fSymbolAttri);\r\n\r\n  fStringAttri := TSynHighlighterAttributes.Create(SYNS_AttrString, SYNS_FriendlyAttrString);\r\n  AddAttribute(fStringAttri);\r\n\r\n  fNullAttri := TSynHighlighterAttributes.Create(SYNS_AttrNull, SYNS_FriendlyAttrNull);\r\n  AddAttribute(fNullAttri);\r\n\r\n  fUnknownAttri := TSynHighlighterAttributes.Create(SYNS_AttrUnknownWord, SYNS_FriendlyAttrUnknownWord);\r\n  AddAttribute(fUnknownAttri);\r\n\r\n  SetAttributesOnChange(DefHighlightChange);\r\n\r\n  InitIdent;\r\n  fRange := rsUnknown;\r\n  fDefaultFilter := SYNS_FilterADSP21xx;\r\nend;\r\n\r\nprocedure TSynADSP21xxSyn.BraceCloseProc;\r\nbegin\r\n  inc(Run);\r\n  fTokenId := tkSymbol;\r\nend;\r\n\r\nprocedure TSynADSP21xxSyn.StringProc;\r\nbegin\r\n  fTokenID := tkString;\r\n  if (FLine[Run + 1] = #39) and (FLine[Run + 2] = #39) then inc(Run, 2);\r\n  repeat\r\n    case FLine[Run] of\r\n      #0, #10, #13: break;\r\n    end;\r\n    inc(Run);\r\n  until FLine[Run] = #39;\r\n  if FLine[Run] <> #0 then inc(Run);\r\nend;\r\n\r\nprocedure TSynADSP21xxSyn.PascalCommentProc;\r\nbegin\r\n  fTokenID := tkComment;\r\n  case FLine[Run] of\r\n    #0:\r\n      begin\r\n        NullProc;\r\n        exit;\r\n      end;\r\n    #10:\r\n      begin\r\n        LFProc;\r\n        exit;\r\n      end;\r\n    #13:\r\n      begin\r\n        CRProc;\r\n        exit;\r\n      end;\r\n  end;\r\n\r\n  while FLine[Run] <> #0 do\r\n    case FLine[Run] of\r\n      '}':\r\n        begin\r\n          fRange := rsUnKnown;\r\n          inc(Run);\r\n          break;\r\n        end;\r\n      #10: break;\r\n      #13: break;\r\n      else inc(Run);\r\n    end;\r\nend;\r\n\r\nprocedure TSynADSP21xxSyn.CCommentProc;\r\nbegin\r\n  fTokenID := tkComment;\r\n  case FLine[Run] of\r\n    #0: begin\r\n          NullProc;\r\n          exit;\r\n        end;\r\n    #10:begin\r\n         LFProc;\r\n         exit;\r\n        end;\r\n    #13:begin\r\n          CRProc;\r\n          exit;\r\n        end;\r\n  end;\r\n\r\n  while FLine[Run] <> #0 do\r\n    case FLine[Run] of\r\n      '*':\r\n        begin\r\n          if FLine[Run+1] = '/' then\r\n          begin\r\n            fRange := rsUnknown;\r\n            inc(Run, 2);\r\n            break;\r\n          end\r\n          else\r\n            Inc(Run);\r\n        end;\r\n      #10: break;\r\n      #13: break;\r\n      else inc(Run);\r\n    end;\r\nend;\r\n\r\nprocedure TSynADSP21xxSyn.BraceOpenProc;\r\nbegin\r\n  fTokenID := tkComment;\r\n  fRange := rsPascalComment;\r\n  inc(Run);\r\n  while FLine[Run] <> #0 do\r\n    case FLine[Run] of\r\n      '}':\r\n        begin\r\n          fRange := rsUnKnown;\r\n          inc(Run);\r\n          break;\r\n        end;\r\n      #10: break;\r\n      #13: break;\r\n    else inc(Run);\r\n    end;\r\nend;\r\n\r\n\r\nprocedure TSynADSP21xxSyn.IncludeCloseProc;\r\nbegin\r\n  inc(Run);\r\n  fTokenId := tkSymbol;\r\nend;\r\n\r\nprocedure TSynADSP21xxSyn.CRProc;\r\nbegin\r\n  fTokenID := tkSpace;\r\n  Case FLine[Run + 1] of\r\n    #10: inc(Run, 2);\r\n  else inc(Run);\r\n  end;\r\nend;\r\n\r\nprocedure TSynADSP21xxSyn.ExclamationProc;\r\nbegin\r\n  fTokenID := tkComment;\r\n  repeat\r\n    inc(Run);\r\n  until IsLineEnd(Run);\r\nend;\r\n\r\nprocedure TSynADSP21xxSyn.IdentProc;\r\nbegin\r\n  fTokenID := IdentKind((fLine + Run));\r\n  inc(Run, fStringLen);\r\n  while IsIdentChar(fLine[Run]) do\r\n    inc(Run);\r\nend;\r\n\r\nprocedure TSynADSP21xxSyn.IntegerProc;\r\n\r\n  function IsIntegerChar: Boolean;\r\n  begin\r\n    case fLine[Run] of\r\n      '0'..'9', 'A'..'F', 'a'..'f':\r\n        Result := True;\r\n      else\r\n        Result := False;\r\n    end;\r\n  end;\r\n\r\nbegin\r\n  inc(Run);\r\n  fTokenID := tkNumber;\r\n  while IsIntegerChar do inc(Run);\r\nend;\r\n\r\nprocedure TSynADSP21xxSyn.LFProc;\r\nbegin\r\n  fTokenID := tkSpace;\r\n  inc(Run);\r\nend;\r\n\r\nprocedure TSynADSP21xxSyn.NullProc;\r\nbegin\r\n  fTokenID := tkNull;\r\n  inc(Run);\r\nend;\r\n\r\nprocedure TSynADSP21xxSyn.NumberProc;\r\n\r\n  function IsNumberChar: Boolean;\r\n  begin\r\n    case fLine[Run] of\r\n      '0'..'9', 'A'..'F', 'a'..'f', 'x', 'X', '.':\r\n        Result := True;\r\n      else\r\n        Result := False;\r\n    end;\r\n  end;\r\n\r\nbegin\r\n  inc(Run);\r\n  fTokenID := tkNumber;\r\n  while IsNumberChar do\r\n  begin\r\n    case FLine[Run] of\r\n      '.':\r\n        if FLine[Run + 1] = '.' then break;\r\n    end;\r\n    inc(Run);\r\n  end;\r\nend;\r\n\r\nprocedure TSynADSP21xxSyn.HexNumber;\r\n\r\n  function IsHexChar: Boolean;\r\n  begin\r\n    case fLine[Run] of\r\n      '0'..'9', 'A'..'F', 'a'..'f':\r\n        Result := True;\r\n      else\r\n        Result := False;\r\n    end;\r\n  end;\r\n\r\nbegin\r\n  inc(Run);\r\n  fTokenID := tkNumber;\r\n  fRange := rsUnKnown;\r\n  while IsHexChar do\r\n  begin\r\n    inc(Run);\r\n  end;\r\nend;\r\n\r\nprocedure TSynADSP21xxSyn.BinaryNumber;\r\nbegin\r\n  inc(Run);\r\n  fRange := rsUnKnown;\r\n  while CharInSet(FLine[Run], ['0'..'1']) do\r\n  begin\r\n    inc(Run);\r\n  end;\r\n  if CharInSet(FLine[Run], ['2'..'9', 'A'..'F', 'a'..'f']) then\r\n  begin\r\n    fTokenID := tkIdentifier\r\n  end\r\n  else\r\n    fTokenID := tkNumber;\r\nend;\r\n\r\nprocedure TSynADSP21xxSyn.SlashProc;\r\nbegin\r\n  if FLine[Run + 1] = '*' then\r\n  begin\r\n    fTokenID := tkComment;\r\n    fRange := rsCComment;\r\n    inc(Run, 2);\r\n    while FLine[Run] <> #0 do\r\n      case FLine[Run] of\r\n        '*':  begin\r\n                if FLine[Run+1] = '/' then\r\n                begin\r\n                  inc(Run, 2);\r\n                  fRange := rsUnknown;\r\n                  break;\r\n                end\r\n                else inc(Run);\r\n              end;\r\n        #10: break;\r\n        #13: break;\r\n        else inc(Run);\r\n      end;\r\n    end\r\n  else\r\n  begin\r\n    inc(Run);\r\n    fTokenID := tkSymbol;\r\n  end;\r\nend;\r\n\r\nprocedure TSynADSP21xxSyn.SpaceProc;\r\nbegin\r\n  inc(Run);\r\n  fTokenID := tkSpace;\r\n  while (FLine[Run] <= #32) and not IsLineEnd(Run) do inc(Run);\r\nend;\r\n\r\nprocedure TSynADSP21xxSyn.UnknownProc;\r\nbegin\r\n  inc(Run);\r\n  fTokenID := tkUnknown;\r\nend;\r\n\r\nprocedure TSynADSP21xxSyn.Next;\r\nbegin\r\n  fTokenPos := Run;\r\n  case fRange of\r\n    rsPascalComment: PascalCommentProc;\r\n    rsCComment: CCommentProc;\r\n    rsHexNumber: HexNumber;\r\n    rsBinaryNumber: BinaryNumber;\r\n  else\r\n    fRange := rsUnknown;\r\n    case fLine[Run] of\r\n      #0: NullProc;\r\n      #10: LFProc;\r\n      #13: CRProc;\r\n      #1..#9, #11, #12, #14..#32: SpaceProc;\r\n      '$': IntegerProc;\r\n      #39: StringProc;\r\n      '0'..'9': NumberProc;\r\n      'A'..'Z', 'a'..'z', '_': IdentProc;\r\n      '{': BraceOpenProc;\r\n      '}': BraceCloseProc;\r\n      '/': SlashProc;\r\n      '>': IncludeCloseProc;\r\n      '!': ExclamationProc;\r\n      else UnknownProc;\r\n    end;\r\n  end;\r\n  inherited;\r\nend;\r\n\r\nfunction TSynADSP21xxSyn.GetDefaultAttribute(Index: integer): TSynHighlighterAttributes;\r\nbegin\r\n  case Index of\r\n    SYN_ATTR_COMMENT: Result := fCommentAttri;\r\n    SYN_ATTR_IDENTIFIER: Result := fIdentifierAttri;\r\n    SYN_ATTR_KEYWORD: Result := fKeyAttri;\r\n    SYN_ATTR_STRING: Result := fStringAttri;\r\n    SYN_ATTR_WHITESPACE: Result := fSpaceAttri;\r\n    SYN_ATTR_SYMBOL: Result := fSymbolAttri;\r\n  else\r\n    Result := nil;\r\n  end;\r\nend;\r\n\r\nfunction TSynADSP21xxSyn.GetEol: Boolean;\r\nbegin\r\n  Result := Run = fLineLen + 1;\r\nend;\r\n\r\nfunction TSynADSP21xxSyn.GetTokenID: TtkTokenKind;\r\nbegin\r\n  Result := fTokenId;\r\nend;\r\n\r\nfunction TSynADSP21xxSyn.GetTokenKind: integer;\r\nbegin\r\n  Result := Ord(GetTokenID);\r\nend;\r\n\r\nfunction TSynADSP21xxSyn.GetTokenAttribute: TSynHighlighterAttributes;\r\nbegin\r\n  case GetTokenID of\r\n    tkComment: Result := fCommentAttri;\r\n    tkIdentifier: Result := fIdentifierAttri;\r\n    tkKey: Result := fKeyAttri;\r\n    tkNumber: Result := fNumberAttri;\r\n    tkSpace: Result := fSpaceAttri;\r\n    tkString: Result := fStringAttri;\r\n    tkSymbol: Result := fSymbolAttri;\r\n    tkRegister: Result := fRegisterAttri;\r\n    tkCondition: Result := fConditionAttri;\r\n    tkUnknown: Result := fSymbolAttri;\r\n  else\r\n    Result := nil;\r\n  end;\r\nend;\r\n\r\nfunction TSynADSP21xxSyn.GetRange: Pointer;\r\nbegin\r\n  Result := Pointer(fRange);\r\nend;\r\n\r\nprocedure TSynADSP21xxSyn.SetRange(Value: Pointer);\r\nbegin\r\n  fRange := TRangeState(Value);\r\nend;\r\n\r\nprocedure TSynADSP21xxSyn.ResetRange;\r\nbegin\r\n  fRange:= rsUnknown;\r\nend;\r\n\r\nprocedure TSynADSP21xxSyn.EnumUserSettings(settings: TStrings);\r\nbegin\r\n  { returns the user settings that exist in the registry }\r\n  {$IFNDEF SYN_CLX}\r\n  with TBetterRegistry.Create do\r\n  begin\r\n    try\r\n      RootKey := HKEY_CURRENT_USER;\r\n      // we need some method to make the following statement more universal!\r\n      if OpenKeyReadOnly('\\SOFTWARE\\Wynand\\DSPIDE\\1.0') then\r\n      begin\r\n        try\r\n          GetKeyNames(settings);\r\n        finally\r\n          CloseKey;\r\n        end;\r\n      end;\r\n    finally\r\n      Free;\r\n    end;\r\n  end;\r\n  {$ENDIF}\r\nend;\r\n\r\nfunction TSynADSP21xxSyn.UseUserSettings(settingIndex: integer): boolean;\r\n// Possible parameter values:\r\n//   index into TStrings returned by EnumUserSettings\r\n// Possible return values:\r\n//   true : settings were read and used\r\n//   false: problem reading settings or invalid version specified - old settings\r\n//          were preserved\r\n\r\n    {$IFNDEF SYN_CLX}\r\n    function ReadDspIDESetting(settingTag: string; attri: TSynHighlighterAttributes; key: string): boolean;\r\n    begin\r\n      try\r\n        Result := attri.LoadFromBorlandRegistry(HKEY_CURRENT_USER,\r\n               '\\Software\\Wynand\\DspIDE\\1.0\\Editor\\Highlight',key,false);\r\n      except Result := false; end;\r\n    end;\r\n    {$ENDIF}\r\nvar\r\n  tmpNumberAttri    : TSynHighlighterAttributes;\r\n  tmpKeyAttri       : TSynHighlighterAttributes;\r\n  tmpSymbolAttri    : TSynHighlighterAttributes;\r\n  tmpCommentAttri   : TSynHighlighterAttributes;\r\n  tmpConditionAttri : TSynHighlighterAttributes;\r\n  tmpIdentifierAttri: TSynHighlighterAttributes;\r\n  tmpSpaceAttri     : TSynHighlighterAttributes;\r\n  tmpRegisterAttri  : TSynHighlighterAttributes;\r\n  StrLst            : TStringList;\r\n\r\nbegin  // UseUserSettings\r\n  StrLst := TStringList.Create;\r\n  try\r\n    EnumUserSettings(StrLst);\r\n    if settingIndex >= StrLst.Count then\r\n      Result := false\r\n    else\r\n    begin\r\n      tmpNumberAttri    := TSynHighlighterAttributes.Create('', '');\r\n      tmpKeyAttri       := TSynHighlighterAttributes.Create('', '');\r\n      tmpSymbolAttri    := TSynHighlighterAttributes.Create('', '');\r\n      tmpCommentAttri   := TSynHighlighterAttributes.Create('', '');\r\n      tmpConditionAttri := TSynHighlighterAttributes.Create('', '');\r\n      tmpIdentifierAttri:= TSynHighlighterAttributes.Create('', '');\r\n      tmpSpaceAttri     := TSynHighlighterAttributes.Create('', '');\r\n      tmpRegisterAttri  := TSynHighlighterAttributes.Create('', '');\r\n\r\n      tmpNumberAttri    .Assign(fNumberAttri);\r\n      tmpKeyAttri       .Assign(fKeyAttri);\r\n      tmpSymbolAttri    .Assign(fSymbolAttri);\r\n      tmpCommentAttri   .Assign(fCommentAttri);\r\n      tmpConditionAttri .Assign(fConditionAttri);\r\n      tmpIdentifierAttri.Assign(fIdentifierAttri);\r\n      tmpSpaceAttri     .Assign(fSpaceAttri);\r\n      tmpRegisterAttri  .Assign(fRegisterAttri);\r\n      {$IFNDEF SYN_CLX}\r\n      Result := ReadDspIDESetting(StrLst[settingIndex],fCommentAttri,'Comment')       and\r\n                ReadDspIDESetting(StrLst[settingIndex],fIdentifierAttri,'Identifier') and\r\n                ReadDspIDESetting(StrLst[settingIndex],fKeyAttri,'Reserved word')     and\r\n                ReadDspIDESetting(StrLst[settingIndex],fNumberAttri,'BinaryNumber')   and\r\n                ReadDspIDESetting(StrLst[settingIndex],fSpaceAttri,'Whitespace')      and\r\n                ReadDspIDESetting(StrLst[settingIndex],fSymbolAttri,'Symbol')         and\r\n                ReadDspIDESetting(StrLst[settingIndex],fConditionAttri,'Condition')   and\r\n                ReadDspIDESetting(StrLst[settingIndex],fRegisterAttri,'Symbol');\r\n      {$ELSE}\r\n      Result := False;\r\n      {$ENDIF}\r\n      if not Result then\r\n      begin\r\n        fNumberAttri     .Assign(tmpNumberAttri);\r\n        fKeyAttri        .Assign(tmpKeyAttri);\r\n        fSymbolAttri     .Assign(tmpSymbolAttri);\r\n        fCommentAttri    .Assign(tmpCommentAttri);\r\n        fConditionAttri  .Assign(tmpConditionAttri);\r\n        fIdentifierAttri .Assign(tmpIdentifierAttri);\r\n        fSpaceAttri      .Assign(tmpSpaceAttri);\r\n        fConditionAttri  .Assign(tmpConditionAttri);\r\n        fRegisterAttri   .Assign(tmpRegisterAttri);\r\n      end;\r\n      tmpNumberAttri    .Free;\r\n      tmpKeyAttri       .Free;\r\n      tmpSymbolAttri    .Free;\r\n      tmpCommentAttri   .Free;\r\n      tmpConditionAttri .Free;\r\n      tmpIdentifierAttri.Free;\r\n      tmpSpaceAttri     .Free;\r\n      tmpRegisterAttri  .Free;\r\n    end;\r\n  finally StrLst.Free; end;\r\nend;\r\n\r\nfunction TSynADSP21xxSyn.IsFilterStored: Boolean;\r\nbegin\r\n  Result := fDefaultFilter <> SYNS_FilterADSP21xx;\r\nend;\r\n\r\nclass function TSynADSP21xxSyn.GetLanguageName: string;\r\nbegin\r\n  Result := SYNS_LangADSP21xx;\r\nend;\r\n\r\nclass function TSynADSP21xxSyn.GetCapabilities: TSynHighlighterCapabilities;\r\nbegin\r\n  Result := inherited GetCapabilities + [hcUserSettings];\r\nend;\r\n\r\nclass function TSynADSP21xxSyn.GetFriendlyLanguageName: UnicodeString;\r\nbegin\r\n  Result := SYNS_FriendlyLangADSP21xx;\r\nend;\r\n\r\ninitialization\r\n{$IFNDEF SYN_CPPB_1}\r\n  RegisterPlaceableHighlighter(TSynADSP21xxSyn);\r\n{$ENDIF}\r\nend.\r\n"
  },
  {
    "path": "External/SynEdit/Source/SynHighlighterAWK.pas",
    "content": "{-------------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: SynHighlighterAWK.pas, released 2000-06-18.\r\nThe Original Code is based on the hkAWKSyn.pas file from the\r\nmwEdit component suite by Martin Waldenburg and other developers, the Initial\r\nAuthor of this file is Hideo Koiso.\r\nUnicode translation by Mal Hrz.\r\nAll Rights Reserved.\r\n\r\nContributors to the SynEdit and mwEdit projects are listed in the\r\nContributors.txt file.\r\n\r\nAlternatively, the contents of this file may be used under the terms of the\r\nGNU General Public License Version 2 or later (the \"GPL\"), in which case\r\nthe provisions of the GPL are applicable instead of those above.\r\nIf you wish to allow use of your version of this file only under the terms\r\nof the GPL and not to allow others to use your version of this file\r\nunder the MPL, indicate your decision by deleting the provisions above and\r\nreplace them with the notice and other provisions required by the GPL.\r\nIf you do not delete the provisions above, a recipient may use your version\r\nof this file under either the MPL or the GPL.\r\n\r\n$Id: SynHighlighterAWK.pas,v 1.10.2.6 2008/09/14 16:24:59 maelh Exp $\r\n\r\nYou may retrieve the latest version of this file at the SynEdit home page,\r\nlocated at http://SynEdit.SourceForge.net\r\n\r\nKnown Issues:\r\n-------------------------------------------------------------------------------}\r\n{\r\n@abstract(Provides a AWK Script highlighter for SynEdit)\r\n@author(Hideo Koiso , converted to SynEdit by David Muir )\r\n@created(7 November 1999, converted to SynEdit April 18, 2000)\r\n@lastmod(June 19, 2000)\r\nThe SynHighlighterAWK unit provides SynEdit with a AWK Script (.awk) highlighter.\r\n}\r\n\r\n{$IFNDEF QSYNHIGHLIGHTERAWK}\r\nunit SynHighlighterAWK;\r\n{$ENDIF}\r\n\r\ninterface\r\n\r\n{$I SynEdit.inc}\r\n\r\nuses\r\n{$IFDEF SYN_CLX}\r\n  QGraphics,\r\n  QSynEditTypes,\r\n  QSynEditHighlighter,\r\n  QSynUnicode,\r\n{$ELSE}\r\n  Graphics,\r\n  SynEditTypes,\r\n  SynEditHighlighter,\r\n  SynUnicode,\r\n{$ENDIF}\r\n  SysUtils,\r\n  Classes;\r\n\r\ntype\r\n  TtkTokenKind = (tkComment, tkIdentifier, tkInterFunc, tkKey, tkNull,\r\n    tkNumber, tkSpace, tkString, tkSymbol, tkSysVar, tkUnknown);\r\n\r\n  TSynAWKSyn = class(TSynCustomHighLighter)\r\n  private\r\n    AWKSyntaxList: TUnicodeStringList;\r\n    FTokenID: TtkTokenKind;\r\n    fCommentAttri: TSynHighlighterAttributes;\r\n    fIdentifierAttri: TSynHighlighterAttributes;\r\n    fInterFuncAttri: TSynHighlighterAttributes;\r\n    fKeyAttri: TSynHighlighterAttributes;\r\n    fNumberAttri: TSynHighlighterAttributes;\r\n    fSpaceAttri: TSynHighlighterAttributes;\r\n    fStringAttri: TSynHighlighterAttributes;\r\n    fSymbolAttri: TSynHighlighterAttributes;\r\n    fSysVarAttri: TSynHighlighterAttributes;\r\n    procedure AndProc;\r\n    procedure CommentProc;\r\n    procedure CRProc;\r\n    procedure ExclamProc;\r\n    procedure FieldRefProc;\r\n    procedure IdentProc;\r\n    procedure LFProc;\r\n    procedure MakeSyntaxList;\r\n    procedure MinusProc;\r\n    procedure NullProc;\r\n    procedure OpInputProc;\r\n    procedure OrProc;\r\n    procedure PlusProc;\r\n    procedure QuestionProc;\r\n    procedure SpaceProc;\r\n    procedure StringProc;\r\n    procedure SymbolProc;\r\n    procedure NumberProc;\r\n    procedure BraceProc;\r\n  protected\r\n    function IsFilterStored: Boolean; override;\r\n  public\r\n    class function GetLanguageName: string; override;\r\n    class function GetFriendlyLanguageName: UnicodeString; override;\r\n  public\r\n    constructor Create(AOwner: TComponent); override;\r\n    destructor Destroy; override;\r\n    function GetDefaultAttribute(Index: integer): TSynHighlighterAttributes;\r\n      override;\r\n    function GetEol: Boolean; override;\r\n    function GetTokenID: TtkTokenKind;\r\n    function GetTokenAttribute: TSynHighlighterAttributes; override;\r\n    function GetTokenKind: integer; override;\r\n    procedure Next; override;\r\n  published\r\n    property CommentAttri: TSynHighlighterAttributes read fCommentAttri\r\n      write fCommentAttri;\r\n    property IdentifierAttri: TSynHighlighterAttributes read fIdentifierAttri\r\n      write fIdentifierAttri;\r\n    property InterFuncAttri: TSynHighlighterAttributes read fInterFuncAttri\r\n      write fInterFuncAttri;\r\n    property KeyAttri: TSynHighlighterAttributes read fKeyAttri write fKeyAttri;\r\n    property NumberAttri: TSynHighlighterAttributes read fNumberAttri\r\n      write fNumberAttri;\r\n    property SpaceAttri: TSynHighlighterAttributes read fSpaceAttri\r\n      write fSpaceAttri;\r\n    property SymbolAttri: TSynHighlighterAttributes read fSymbolAttri\r\n      write fSymbolAttri;\r\n    property SysVarAttri: TSynHighlighterAttributes read fSysVarAttri\r\n      write fSysVarAttri;\r\n    property StringAttri: TSynHighlighterAttributes read fStringAttri\r\n      write fStringAttri;\r\n  end;\r\n\r\nimplementation\r\n\r\nuses\r\n{$IFDEF UNICODE}\r\n  WideStrUtils,\r\n{$ENDIF}\r\n{$IFDEF SYN_CLX}\r\n  QSynEditStrConst;\r\n{$ELSE}\r\n  SynEditStrConst;\r\n{$ENDIF}\r\n\r\nprocedure TSynAWKSyn.MakeSyntaxList;\r\nbegin\r\n  with AWKSyntaxList do\r\n  begin\r\n    Sorted := True;\r\n\r\n    { *** Preferably sort and put previously. *** }\r\n    AddObject('ARGC', TObject(tkSysVar));\r\n    AddObject('ARGIND', TObject(tkSysVar)); { GNU Extention }\r\n    AddObject('ARGV', TObject(tkSysVar));\r\n    AddObject('atan2', TObject(tkInterFunc));\r\n    AddObject('BEGIN', TObject(tkKey));\r\n    AddObject('break', TObject(tkKey));\r\n    AddObject('close', TObject(tkInterFunc));\r\n    AddObject('continue', TObject(tkKey));\r\n    AddObject('CONVFMT', TObject(tkSysVar)); { POSIX Extention }\r\n    AddObject('cos', TObject(tkInterFunc));\r\n    AddObject('delete', TObject(tkInterFunc));\r\n    AddObject('do', TObject(tkKey));\r\n    AddObject('else', TObject(tkKey));\r\n    AddObject('END', TObject(tkKey));\r\n    AddObject('ENVIRON', TObject(tkSysVar));\r\n    AddObject('ERRNO', TObject(tkSysVar)); { GNU Extention }\r\n    AddObject('exit', TObject(tkKey));\r\n    AddObject('exp', TObject(tkInterFunc));\r\n    AddObject('FIELDWIDTH', TObject(tkSysVar)); { GNU Extention }\r\n    AddObject('FILENAME', TObject(tkSysVar));\r\n    AddObject('FNR', TObject(tkSysVar));\r\n    AddObject('for', TObject(tkKey));\r\n    AddObject('FS', TObject(tkSysVar));\r\n    AddObject('function', TObject(tkKey));\r\n    AddObject('getline', TObject(tkKey));\r\n    AddObject('gsub', TObject(tkInterFunc));\r\n    AddObject('if', TObject(tkKey));\r\n    AddObject('IGNORECASE', TObject(tkSysVar));\r\n    AddObject('index', TObject(tkInterFunc));\r\n    AddObject('int', TObject(tkInterFunc));\r\n    AddObject('jindex', TObject(tkInterFunc)); { jgawk }\r\n    AddObject('jlength', TObject(tkInterFunc)); { jgawk }\r\n    AddObject('jsubstr', TObject(tkInterFunc)); { jgawk }\r\n    AddObject('length', TObject(tkInterFunc));\r\n    AddObject('log', TObject(tkInterFunc));\r\n    AddObject('match', TObject(tkInterFunc));\r\n    AddObject('next', TObject(tkUnknown)); { & next file (GNU Extention) }\r\n    AddObject('NF', TObject(tkSysVar));\r\n    AddObject('NR', TObject(tkSysVar));\r\n    AddObject('OFMT', TObject(tkSysVar));\r\n    AddObject('OFS', TObject(tkSysVar));\r\n    AddObject('ORS', TObject(tkSysVar));\r\n    AddObject('print', TObject(tkKey));\r\n    AddObject('printf', TObject(tkInterFunc));\r\n    AddObject('rand', TObject(tkInterFunc));\r\n    AddObject('return', TObject(tkKey));\r\n    AddObject('RLENGTH', TObject(tkSysVar));\r\n    AddObject('RS', TObject(tkSysVar));\r\n    AddObject('RSTART', TObject(tkSysVar));\r\n    AddObject('sin', TObject(tkInterFunc));\r\n    AddObject('split', TObject(tkInterFunc));\r\n    AddObject('sprintf', TObject(tkInterFunc));\r\n    AddObject('sqrt', TObject(tkInterFunc));\r\n    AddObject('srand', TObject(tkInterFunc));\r\n    AddObject('strftime', TObject(tkInterFunc)); { GNU Extention }\r\n    AddObject('sub', TObject(tkInterFunc));\r\n    AddObject('SUBSEP', TObject(tkSysVar));\r\n    AddObject('substr', TObject(tkInterFunc));\r\n    AddObject('system', TObject(tkInterFunc));\r\n    AddObject('systime', TObject(tkInterFunc)); { GNU Extention }\r\n    AddObject('tolower', TObject(tkInterFunc));\r\n    AddObject('toupper', TObject(tkInterFunc));\r\n    AddObject('while', TObject(tkKey));\r\n  end;\r\nend;\r\n\r\nprocedure TSynAWKSyn.BraceProc;\r\nbegin\r\n  fTokenID := tkIdentifier;\r\n  Inc(Run);\r\nend;\r\n\r\nprocedure TSynAWKSyn.NumberProc;\r\nbegin\r\n  fTokenID := tkNumber;\r\n  Inc(Run);\r\n  while CharInSet(fLine[Run], ['0'..'9']) do\r\n    Inc(Run);\r\nend;\r\n\r\nprocedure TSynAWKSyn.IdentProc;\r\nvar\r\n  i: Integer;\r\n  idx: Integer;\r\n  s: UnicodeString;\r\nbegin\r\n  i := Run;\r\n  while CharInSet(fLine[i], ['a'..'z', 'A'..'Z']) do\r\n    Inc(i);\r\n  SetLength(s, i - Run);\r\n  WStrLCopy(PWideChar(s), fLine + Run, i - Run);\r\n  Run := i;\r\n  if AWKSyntaxList.Find(s, idx) and (AWKSyntaxList.Strings[idx] = s) then\r\n  begin\r\n    fTokenID := TtkTokenKind(AWKSyntaxList.Objects[idx]);\r\n    if (fTokenID = tkUnKnown) then\r\n    begin\r\n      fTokenID := tkKey;\r\n      if (fLine[i] = ' ') then\r\n      begin\r\n        while (fLine[i] = ' ') do\r\n          Inc(i);\r\n        if (fLine[i + 0] = 'f') and\r\n          (fLine[i + 1] = 'i') and\r\n          (fLine[i + 2] = 'l') and\r\n          (fLine[i + 3] = 'e') and\r\n          CharInSet(fLine[i + 4], [#0..#32, ';']) then\r\n        begin\r\n          Run := (i + 4);\r\n        end;\r\n      end;\r\n    end;\r\n  end\r\n  else\r\n    fTokenID := tkIdentifier;\r\nend;\r\n\r\nprocedure TSynAWKSyn.Next;\r\nbegin\r\n  fTokenPos := Run;\r\n  case fLine[Run] of\r\n    #0: NullProc;\r\n    #10: LFProc;\r\n    #13: CRProc;\r\n    #1..#9, #11, #12, #14..#32: SpaceProc;\r\n    '\"', #$27: StringProc; { \"...\" }\r\n    '(', ')', '[', ']': BraceProc; { (, ), [ and ] }\r\n    '#': CommentProc; { # ... }\r\n    '$': FieldRefProc; { $0 .. $9 }\r\n    '+': PlusProc; { +, ++ and += }\r\n    '-': MinusProc; { -, -- and -= }\r\n    '!': ExclamProc; { ! and !~ }\r\n    '?': QuestionProc; { ?: }\r\n    '|': OrProc; { || }\r\n    '&': AndProc; { && }\r\n    '*', '/', '%', '^', '<', '=', '>': OpInputProc; { *=, /=, %= ... etc. }\r\n    'a'..'z', 'A'..'Z': IdentProc;\r\n    '0'..'9': NumberProc;\r\n    else SymbolProc;\r\n  end;\r\n  inherited;\r\nend;\r\n\r\nprocedure TSynAWKSyn.StringProc;\r\nbegin\r\n  repeat\r\n    Inc(Run);\r\n    if (fLine[Run] = '\"') and (fLine[Run - 1] <> '\\') then\r\n    begin\r\n      fTokenID := tkString;\r\n      Inc(Run);\r\n      Exit;\r\n    end;\r\n  until CharInSet(fLine[Run], [#0..#31]);\r\n  fTokenID := tkIdentifier;\r\nend;\r\n\r\nprocedure TSynAWKSyn.CommentProc;\r\nbegin\r\n  fTokenID := tkComment;\r\n  while not IsLineEnd(Run) do\r\n    Inc(Run);\r\nend;\r\n\r\nprocedure TSynAWKSyn.FieldRefProc;\r\n\r\n  function IsAlphaNumChar(Run: Integer): Boolean;\r\n  begin\r\n    case fLine[Run] of\r\n      '0'..'9', 'a'..'z', 'A'..'Z':\r\n        Result := True;\r\n      else\r\n        Result := False;\r\n    end;\r\n  end;\r\n\r\nbegin\r\n  Inc(Run);\r\n  if CharInSet(fLine[Run], ['0'..'9']) and not IsAlphaNumChar(Run + 1) then\r\n  begin\r\n    fTokenID := tkSymbol;\r\n    Inc(Run);\r\n  end\r\n  else\r\n    fTokenID := tkIdentifier;\r\nend;\r\n\r\nprocedure TSynAWKSyn.SymbolProc;\r\nbegin\r\n  fTokenID := tkSymbol;\r\n  Inc(Run);\r\nend;\r\n\r\nprocedure TSynAWKSyn.PlusProc;\r\nbegin\r\n  fTokenID := tkSymbol;\r\n  Inc(Run);\r\n  if CharInSet(fLine[Run], ['+', '=']) then\r\n    Inc(Run);\r\nend;\r\n\r\nprocedure TSynAWKSyn.MinusProc;\r\nbegin\r\n  fTokenID := tkSymbol;\r\n  Inc(Run);\r\n  if CharInSet(fLine[Run], ['-', '=']) then\r\n    Inc(Run);\r\nend;\r\n\r\nprocedure TSynAWKSyn.OpInputProc;\r\nbegin\r\n  fTokenID := tkSymbol;\r\n  Inc(Run);\r\n  if (fLine[Run] = '=') then\r\n    Inc(Run);\r\nend;\r\n\r\nprocedure TSynAWKSyn.ExclamProc;\r\nbegin\r\n  fTokenID := tkSymbol;\r\n  Inc(Run);\r\n  if CharInSet(fLine[Run], ['=', '~']) then\r\n    Inc(Run);\r\nend;\r\n\r\nprocedure TSynAWKSyn.QuestionProc;\r\nbegin\r\n  Inc(Run);\r\n  if (fLine[Run] = ':') then\r\n  begin\r\n    fTokenID := tkSymbol;\r\n    Inc(Run);\r\n  end\r\n  else\r\n    fTokenID := tkIdentifier;\r\nend;\r\n\r\nprocedure TSynAWKSyn.OrProc;\r\nbegin\r\n  Inc(Run);\r\n  if (fLine[Run] = '|') then\r\n  begin\r\n    fTokenID := tkSymbol;\r\n    Inc(Run);\r\n  end\r\n  else\r\n    fTokenID := tkIdentifier;\r\nend;\r\n\r\nprocedure TSynAWKSyn.AndProc;\r\nbegin\r\n  Inc(Run);\r\n  if (fLine[Run] = '&') then\r\n  begin\r\n    fTokenID := tkSymbol;\r\n    Inc(Run);\r\n  end\r\n  else\r\n    fTokenID := tkIdentifier;\r\nend;\r\n\r\nconstructor TSynAWKSyn.Create(AOwner: TComponent);\r\nbegin\r\n  inherited Create(AOwner);\r\n\r\n  fCaseSensitive := True;\r\n\r\n  fCommentAttri := TSynHighlighterAttributes.Create(SYNS_AttrComment, SYNS_FriendlyAttrComment);\r\n  fCommentAttri.Foreground := clBlue;\r\n  AddAttribute(fCommentAttri);\r\n\r\n  fIdentifierAttri := TSynHighlighterAttributes.Create(SYNS_AttrIdentifier, SYNS_FriendlyAttrIdentifier);\r\n  AddAttribute(fIdentifierAttri);\r\n\r\n  fInterFuncAttri := TSynHighlighterAttributes.Create(SYNS_AttrInternalFunction, SYNS_FriendlyAttrInternalFunction);\r\n  fInterFuncAttri.Foreground := $00408080;\r\n  fInterFuncAttri.Style := [fsBold];\r\n  AddAttribute(fInterFuncAttri);\r\n\r\n  fKeyAttri := TSynHighlighterAttributes.Create(SYNS_AttrReservedWord, SYNS_FriendlyAttrReservedWord);\r\n  fKeyAttri.Foreground := $00FF0080;\r\n  fKeyAttri.Style := [fsBold];\r\n  AddAttribute(fKeyAttri);\r\n\r\n  fNumberAttri := TSynHighlighterAttributes.Create(SYNS_AttrNumber, SYNS_FriendlyAttrNumber);\r\n  AddAttribute(fNumberAttri);\r\n\r\n  fSpaceAttri := TSynHighlighterAttributes.Create(SYNS_AttrSpace, SYNS_FriendlyAttrSpace);\r\n  AddAttribute(fSpaceAttri);\r\n\r\n  fStringAttri := TSynHighlighterAttributes.Create(SYNS_AttrString, SYNS_FriendlyAttrString);\r\n  fStringAttri.Foreground := clTeal;\r\n  AddAttribute(fStringAttri);\r\n\r\n  fSymbolAttri := TSynHighlighterAttributes.Create(SYNS_AttrSymbol, SYNS_FriendlyAttrSymbol);\r\n  fSymbolAttri.Style := [fsBold];\r\n  AddAttribute(fSymbolAttri);\r\n\r\n  fSysVarAttri := TSynHighlighterAttributes.Create(SYNS_AttrSystemValue, SYNS_FriendlyAttrSystemValue);\r\n  fSysVarAttri.Foreground := $000080FF;\r\n  fSysVarAttri.Style := [fsBold];\r\n  AddAttribute(fSysVarAttri);\r\n\r\n  SetAttributesOnChange(DefHighlightChange);\r\n\r\n  AWKSyntaxList := TUnicodeStringList.Create;\r\n  MakeSyntaxList;\r\n\r\n  fDefaultFilter := SYNS_FilterAWK;\r\nend;\r\n\r\ndestructor TSynAWKSyn.Destroy;\r\nbegin\r\n  AWKSyntaxList.Free;\r\n\r\n  inherited Destroy;\r\nend;\r\n\r\nprocedure TSynAWKSyn.CRProc;\r\nbegin\r\n  fTokenID := tkSpace;\r\n  Inc(Run);\r\n  if fLine[Run] = #10 then Inc(Run);\r\nend;\r\n\r\nprocedure TSynAWKSyn.LFProc;\r\nbegin\r\n  fTokenID := tkSpace;\r\n  Inc(Run);\r\nend;\r\n\r\nprocedure TSynAWKSyn.NullProc;\r\nbegin\r\n  fTokenID := tkNull;\r\n  inc(Run);\r\nend;\r\n\r\nprocedure TSynAWKSyn.SpaceProc;\r\nbegin\r\n  inc(Run);\r\n  fTokenID := tkSpace;\r\n  while (FLine[Run] <= #32) and not IsLineEnd(Run) do inc(Run);\r\nend;\r\n\r\nfunction TSynAWKSyn.GetDefaultAttribute(Index: integer): TSynHighlighterAttributes;\r\nbegin\r\n  case Index of\r\n    SYN_ATTR_COMMENT: Result := fCommentAttri;\r\n    SYN_ATTR_KEYWORD: Result := fKeyAttri;\r\n    SYN_ATTR_WHITESPACE: Result := fSpaceAttri;\r\n    SYN_ATTR_SYMBOL: Result := fSymbolAttri;\r\n  else\r\n    Result := nil;\r\n  end;\r\nend;\r\n\r\nfunction TSynAWKSyn.GetEol: Boolean;\r\nbegin\r\n  Result := Run = fLineLen + 1;\r\nend;\r\n\r\nfunction TSynAWKSyn.GetTokenID: TtkTokenKind;\r\nbegin\r\n  Result := fTokenId;\r\nend;\r\n\r\nfunction TSynAWKSyn.GetTokenAttribute: TSynHighlighterAttributes;\r\nbegin\r\n  case fTokenID of\r\n    tkComment: Result := fCommentAttri;\r\n    tkIdentifier: Result := fIdentifierAttri;\r\n    tkInterFunc: Result := fInterFuncAttri;\r\n    tkKey: Result := fKeyAttri;\r\n    tkNumber: Result := fNumberAttri;\r\n    tkSpace: Result := fSpaceAttri;\r\n    tkString: Result := fStringAttri;\r\n    tkSymbol: Result := fSymbolAttri;\r\n    tkSysVar: Result := fSysVarAttri;\r\n  else\r\n    Result := nil;\r\n  end;\r\nend;\r\n\r\nfunction TSynAWKSyn.GetTokenKind: integer;\r\nbegin\r\n  Result := Ord(fTokenId);\r\nend;\r\n\r\nfunction TSynAWKSyn.IsFilterStored: Boolean;\r\nbegin\r\n  Result := fDefaultFilter <> SYNS_FilterAWK;\r\nend;\r\n\r\nclass function TSynAWKSyn.GetLanguageName: string;\r\nbegin\r\n  Result := SYNS_LangAWK;\r\nend;\r\n\r\nclass function TSynAWKSyn.GetFriendlyLanguageName: UnicodeString;\r\nbegin\r\n  Result := SYNS_FriendlyLangAWK;\r\nend;\r\n\r\n{$IFNDEF SYN_CPPB_1}\r\ninitialization\r\n  RegisterPlaceableHighlighter(TSynAWKSyn);\r\n{$ENDIF}\r\nend.\r\n"
  },
  {
    "path": "External/SynEdit/Source/SynHighlighterAsm.pas",
    "content": "{-------------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: SynHighlighterASM.pas, released 2000-04-18.\r\nThe Original Code is based on the nhAsmSyn.pas file from the\r\nmwEdit component suite by Martin Waldenburg and other developers, the Initial\r\nAuthor of this file is Nick Hoddinott.\r\nUnicode translation by Mal Hrz.\r\nAll Rights Reserved.\r\n\r\nContributors to the SynEdit and mwEdit projects are listed in the\r\nContributors.txt file.\r\n\r\nAlternatively, the contents of this file may be used under the terms of the\r\nGNU General Public License Version 2 or later (the \"GPL\"), in which case\r\nthe provisions of the GPL are applicable instead of those above.\r\nIf you wish to allow use of your version of this file only under the terms\r\nof the GPL and not to allow others to use your version of this file\r\nunder the MPL, indicate your decision by deleting the provisions above and\r\nreplace them with the notice and other provisions required by the GPL.\r\nIf you do not delete the provisions above, a recipient may use your version\r\nof this file under either the MPL or the GPL.\r\n\r\n$Id: SynHighlighterAsm.pas,v 1.14.2.6 2008/09/14 16:24:59 maelh Exp $\r\n\r\nYou may retrieve the latest version of this file at the SynEdit home page,\r\nlocated at http://SynEdit.SourceForge.net\r\n\r\nKnown Issues:\r\n-------------------------------------------------------------------------------}\r\n{\r\n@abstract(Provides a x86 Assembler highlighter for SynEdit)\r\n@author(Nick Hoddinott , converted to SynEdit by David Muir )\r\n@created(7 November 1999, converted to SynEdit April 18, 2000)\r\n@lastmod(April 18, 2000)\r\nThe SynHighlighterASM unit provides SynEdit with a x86 Assembler (.asm) highlighter.\r\nThe highlighter supports all x86 op codes, Intel MMX and AMD 3D NOW! op codes.\r\nThanks to Martin Waldenburg, Hideo Koiso.\r\n}\r\n\r\n{$IFNDEF QSYNHIGHLIGHTERASM}\r\nunit SynHighlighterAsm;\r\n{$ENDIF}\r\n\r\n{$I SynEdit.inc}\r\n\r\ninterface\r\n\r\nuses\r\n{$IFDEF SYN_CLX}\r\n  QGraphics,\r\n  QSynEditTypes,\r\n  QSynEditHighlighter,\r\n  QSynHighlighterHashEntries,\r\n  QSynUnicode,\r\n{$ELSE}\r\n  Graphics,\r\n  SynEditTypes,\r\n  SynEditHighlighter,\r\n  SynHighlighterHashEntries,\r\n  SynUnicode,\r\n{$ENDIF}\r\n  SysUtils,\r\n  Classes;\r\n\r\ntype\r\n  TtkTokenKind = (tkComment, tkIdentifier, tkKey, tkNull, tkNumber, tkSpace,\r\n    tkString, tkSymbol, tkUnknown);\r\n\r\ntype\r\n  TSynAsmSyn = class(TSynCustomHighlighter)\r\n  private\r\n    fTokenID: TtkTokenKind;\r\n    fCommentAttri: TSynHighlighterAttributes;\r\n    fIdentifierAttri: TSynHighlighterAttributes;\r\n    fKeyAttri: TSynHighlighterAttributes;\r\n    fNumberAttri: TSynHighlighterAttributes;\r\n    fSpaceAttri: TSynHighlighterAttributes;\r\n    fStringAttri: TSynHighlighterAttributes;\r\n    fSymbolAttri: TSynHighlighterAttributes;\r\n    fKeywords: TSynHashEntryList;\r\n    function HashKey(Str: PWideChar): Cardinal;\r\n    procedure CommentProc;\r\n    procedure CRProc;\r\n    procedure GreaterProc;\r\n    procedure IdentProc;\r\n    procedure LFProc;\r\n    procedure LowerProc;\r\n    procedure NullProc;\r\n    procedure NumberProc;\r\n    procedure SlashProc;\r\n    procedure SpaceProc;\r\n    procedure StringProc;\r\n    procedure SingleQuoteStringProc;\r\n    procedure SymbolProc;\r\n    procedure UnknownProc;\r\n    procedure DoAddKeyword(AKeyword: UnicodeString; AKind: integer);\r\n    function IdentKind(MayBe: PWideChar): TtkTokenKind;\r\n  protected\r\n    function GetSampleSource: UnicodeString; override;\r\n    function IsFilterStored: Boolean; override;\r\n  public\r\n    class function GetLanguageName: string; override;\r\n    class function GetFriendlyLanguageName: UnicodeString; override;    \r\n  public\r\n    constructor Create(AOwner: TComponent); override;\r\n    destructor Destroy; override;\r\n    function GetDefaultAttribute(Index: integer): TSynHighlighterAttributes;\r\n      override;\r\n    function GetEol: Boolean; override;\r\n    function GetTokenID: TtkTokenKind;\r\n    function GetTokenAttribute: TSynHighlighterAttributes; override;\r\n    function GetTokenKind: integer; override;\r\n    procedure Next; override;\r\n  published\r\n    property CommentAttri: TSynHighlighterAttributes read fCommentAttri\r\n      write fCommentAttri;\r\n    property IdentifierAttri: TSynHighlighterAttributes read fIdentifierAttri\r\n      write fIdentifierAttri;\r\n    property KeyAttri: TSynHighlighterAttributes read fKeyAttri write fKeyAttri;\r\n    property NumberAttri: TSynHighlighterAttributes read fNumberAttri\r\n      write fNumberAttri;\r\n    property SpaceAttri: TSynHighlighterAttributes read fSpaceAttri\r\n      write fSpaceAttri;\r\n    property StringAttri: TSynHighlighterAttributes read fStringAttri\r\n      write fStringAttri;\r\n    property SymbolAttri: TSynHighlighterAttributes read fSymbolAttri\r\n      write fSymbolAttri;\r\n  end;\r\n\r\nimplementation\r\n\r\nuses\r\n{$IFDEF SYN_CLX}\r\n  QSynEditStrConst;\r\n{$ELSE}\r\n  SynEditStrConst;\r\n{$ENDIF}\r\n\r\nconst\r\n  Mnemonics: UnicodeString =\r\n    'aaa,aad,aam,adc,add,and,arpl,bound,bsf,bsr,bswap,bt,btc,' +\r\n    'btr,bts,call,cbw,cdq,clc,cld,cli,clts,cmc,cmp,cmps,cmpsb,cmpsd,cmpsw,' +\r\n    'cmpxchg,cwd,cwde,daa,das,dec,div,emms,enter,f2xm1,fabs,fadd,faddp,fbld,' +\r\n    'fbstp,fchs,fclex,fcmovb,fcmovbe,fcmove,fcmovnb,fcmovnbe,fcmovne,fcmovnu,' +\r\n    'fcmovu,fcom,fcomi,fcomip,fcomp,fcompp,fcos,fdecstp,fdiv,fdivp,fdivr,' +\r\n    'fdivrp,femms,ffree,fiadd,ficom,ficomp,fidiv,fidivr,fild,fimul,fincstp,' +\r\n    'finit,fist,fistp,fisub,fisubr,fld,fld1,fldcw,fldenv,fldl2e,fldl2t,fldlg2,' +\r\n    'fldln2,fldpi,fldz,fmul,fmulp,fnclex,fninit,fnop,fnsave,fnstcw,fnstenv,' +\r\n    'fnstsw,fpatan,fprem1,fptan,frndint,frstor,fsave,fscale,fsin,fsincos,' +\r\n    'fsqrt,fst,fstcw,fstenv,fstp,fstsw,fsub,fsubp,fsubr,fsubrp,ftst,' +\r\n    'fucom,fucomi,fucomip,fucomp,fucompp,fwait,fxch,fxtract,fyl2xp1,hlt,idiv,' +\r\n    'imul,in,inc,ins,insb,insd,insw,int,into,invd,invlpg,iret,iretd,iretw,' +\r\n    'ja,jae,jb,jbe,jc,jcxz,je,jecxz,jg,jge,jl,jle,jmp,jna,jnae,jnb,jnbe,jnc,' +\r\n    'jne,jng,jnge,jnl,jnle,jno,jnp,jns,jnz,jo,jp,jpe,jpo,js,jz,lahf,lar,lds,' +\r\n    'lea,leave,les,lfs,lgdt,lgs,lidt,lldt,lmsw,lock,lods,lodsb,lodsd,lodsw,' +\r\n    'loop,loope,loopne,loopnz,loopz,lsl,lss,ltr,mov,movd,movq, movs,movsb,' +\r\n    'movsd,movsw,movsx,movzx,mul,neg,nop,not,or,out,outs,outsb,outsd,outsw,' +\r\n    'packssdw,packsswb,packuswb,paddb,paddd,paddsb,paddsw,paddusb,paddusw,' +\r\n    'paddw,pand,pandn,pavgusb,pcmpeqb,pcmpeqd,pcmpeqw,pcmpgtb,pcmpgtd,pcmpgtw,' +\r\n    'pf2id,pfacc,pfadd,pfcmpeq,pfcmpge,pfcmpgt,pfmax,pfmin,pfmul,pfrcp,' +\r\n    'pfrcpit1,pfrcpit2,pfrsqit1,pfrsqrt,pfsub,pfsubr,pi2fd,pmaddwd,pmulhrw,' +\r\n    'pmulhw,pmullw,pop,popa,popad,popaw,popf,popfd,popfw,por,prefetch,prefetchw,' +\r\n    'pslld,psllq,psllw,psrad,psraw,psrld,psrlq,psrlw,psubb,psubd,psubsb,' +\r\n    'psubsw,psubusb,psubusw,psubw,punpckhbw,punpckhdq,punpckhwd,punpcklbw,' +\r\n    'punpckldq,punpcklwd,push,pusha,pushad,pushaw,pushf,pushfd,pushfw,pxor,' +\r\n    'rcl,rcr,rep,repe,repne,repnz,repz,ret,rol,ror,sahf,sal,sar,sbb,scas,' +\r\n    'scasb,scasd,scasw,seta,setae,setb,setbe,setc,sete,setg,setge,setl,setle,' +\r\n    'setna,setnae,setnb,setnbe,setnc,setne,setng,setnge,setnl,setnle,setno,' +\r\n    'setnp,setns,setnz,seto,setp,setpo,sets,setz,sgdt,shl,shld,shr,shrd,sidt,' +\r\n    'sldt,smsw,stc,std,sti,stos,stosb,stosd,stosw,str,sub,test,verr,verw,' +\r\n    'wait,wbinvd,xadd,xchg,xlat,xlatb,xor';\r\n\r\nprocedure TSynAsmSyn.DoAddKeyword(AKeyword: UnicodeString; AKind: integer);\r\nvar\r\n  HashValue: Cardinal;\r\nbegin\r\n  HashValue := HashKey(PWideChar(AKeyword));\r\n  fKeywords[HashValue] := TSynHashEntry.Create(AKeyword, AKind);\r\nend;\r\n\r\n{$Q-}\r\nfunction TSynAsmSyn.HashKey(Str: PWideChar): Cardinal;\r\nbegin\r\n  Result := 0;\r\n  while IsIdentChar(Str^) do\r\n  begin\r\n    Result := Result * 197 + Ord(Str^) * 14;\r\n    inc(Str);\r\n  end;\r\n  Result := Result mod 4561;\r\n  fStringLen := Str - fToIdent;\r\nend;\r\n{$Q+}\r\n\r\nfunction TSynAsmSyn.IdentKind(MayBe: PWideChar): TtkTokenKind;\r\nvar\r\n  Entry: TSynHashEntry;\r\nbegin\r\n  fToIdent := MayBe;\r\n  Entry := fKeywords[HashKey(MayBe)];\r\n  while Assigned(Entry) do\r\n  begin\r\n    if Entry.KeywordLen > fStringLen then\r\n      break\r\n    else if Entry.KeywordLen = fStringLen then\r\n      if IsCurrentToken(Entry.Keyword) then\r\n      begin\r\n        Result := TtkTokenKind(Entry.Kind);\r\n        exit;\r\n      end;\r\n    Entry := Entry.Next;\r\n  end;\r\n  Result := tkIdentifier;\r\nend;\r\n\r\nconstructor TSynAsmSyn.Create(AOwner: TComponent);\r\nbegin\r\n  inherited Create(AOwner);\r\n\r\n  fCaseSensitive := False;\r\n\r\n  fKeywords := TSynHashEntryList.Create;\r\n\r\n  fCommentAttri       := TSynHighlighterAttributes.Create(SYNS_AttrComment, SYNS_FriendlyAttrComment);\r\n  fCommentAttri.Style := [fsItalic];\r\n  AddAttribute(fCommentAttri);\r\n  fIdentifierAttri    := TSynHighlighterAttributes.Create(SYNS_AttrIdentifier, SYNS_FriendlyAttrIdentifier);\r\n  AddAttribute(fIdentifierAttri);\r\n  fKeyAttri           := TSynHighlighterAttributes.Create(SYNS_AttrReservedWord, SYNS_FriendlyAttrReservedWord);\r\n  fKeyAttri.Style     := [fsBold];\r\n  AddAttribute(fKeyAttri);\r\n  fNumberAttri        := TSynHighlighterAttributes.Create(SYNS_AttrNumber, SYNS_FriendlyAttrNumber);\r\n  AddAttribute(fNumberAttri);\r\n  fSpaceAttri         := TSynHighlighterAttributes.Create(SYNS_AttrSpace, SYNS_FriendlyAttrSpace);\r\n  AddAttribute(fSpaceAttri);\r\n  fStringAttri        := TSynHighlighterAttributes.Create(SYNS_AttrString, SYNS_FriendlyAttrString);\r\n  AddAttribute(fStringAttri);\r\n  fSymbolAttri        := TSynHighlighterAttributes.Create(SYNS_AttrSymbol, SYNS_FriendlyAttrSymbol);\r\n  AddAttribute(fSymbolAttri);\r\n\r\n  EnumerateKeywords(Ord(tkKey), Mnemonics, IsIdentChar, DoAddKeyword);\r\n  SetAttributesOnChange(DefHighlightChange);\r\n  fDefaultFilter      := SYNS_FilterX86Assembly;\r\nend;\r\n\r\ndestructor TSynAsmSyn.Destroy;\r\nbegin\r\n  fKeywords.Free;\r\n  inherited Destroy;\r\nend;\r\n\r\nprocedure TSynAsmSyn.CommentProc;\r\nbegin\r\n  fTokenID := tkComment;\r\n  repeat\r\n    Inc(Run);\r\n  until IsLineEnd(Run);\r\nend;\r\n\r\nprocedure TSynAsmSyn.CRProc;\r\nbegin\r\n  fTokenID := tkSpace;\r\n  Inc(Run);\r\n  if fLine[Run] = #10 then Inc(Run);\r\nend;\r\n\r\nprocedure TSynAsmSyn.GreaterProc;\r\nbegin\r\n  Inc(Run);\r\n  fTokenID := tkSymbol;\r\n  if fLine[Run] = '=' then Inc(Run);\r\nend;\r\n\r\nprocedure TSynAsmSyn.IdentProc;\r\nbegin\r\n  fTokenID := IdentKind((fLine + Run));\r\n  inc(Run, fStringLen);\r\n  while IsIdentChar(fLine[Run]) do inc(Run);\r\nend;\r\n\r\nprocedure TSynAsmSyn.LFProc;\r\nbegin\r\n  fTokenID := tkSpace;\r\n  inc(Run);\r\nend;\r\n\r\nprocedure TSynAsmSyn.LowerProc;\r\nbegin\r\n  Inc(Run);\r\n  fTokenID := tkSymbol;\r\n  if CharInSet(fLine[Run], ['=', '>']) then Inc(Run);\r\nend;\r\n\r\nprocedure TSynAsmSyn.NullProc;\r\nbegin\r\n  fTokenID := tkNull;\r\n  inc(Run);\r\nend;\r\n\r\nprocedure TSynAsmSyn.NumberProc;\r\n\r\n  function IsNumberChar: Boolean;\r\n  begin\r\n    case fLine[Run] of\r\n      '0'..'9', '.', 'a'..'f', 'h', 'A'..'F', 'H':\r\n        Result := True;\r\n      else\r\n        Result := False;\r\n    end;\r\n  end;\r\n\r\nbegin\r\n  inc(Run);\r\n  fTokenID := tkNumber;\r\n  while IsNumberChar do\r\n    Inc(Run);\r\nend;\r\n\r\nprocedure TSynAsmSyn.SlashProc;\r\nbegin\r\n  Inc(Run);\r\n  if fLine[Run] = '/' then begin\r\n    fTokenID := tkComment;\r\n    repeat\r\n      Inc(Run);\r\n    until IsLineEnd(Run);\r\n  end else\r\n    fTokenID := tkSymbol;\r\nend;\r\n\r\nprocedure TSynAsmSyn.SpaceProc;\r\nbegin\r\n  fTokenID := tkSpace;\r\n  repeat\r\n    Inc(Run);\r\n  until (fLine[Run] > #32) or IsLineEnd(Run);\r\nend;\r\n\r\nprocedure TSynAsmSyn.StringProc;\r\nbegin\r\n  fTokenID := tkString;\r\n  if (FLine[Run + 1] = #34) and (FLine[Run + 2] = #34) then\r\n    inc(Run, 2);\r\n  repeat\r\n    case FLine[Run] of\r\n      #0, #10, #13: break;\r\n    end;\r\n    inc(Run);\r\n  until FLine[Run] = #34;\r\n  if FLine[Run] <> #0 then inc(Run);\r\nend;\r\n\r\nprocedure TSynAsmSyn.SingleQuoteStringProc;\r\nbegin\r\n  fTokenID := tkString;\r\n  if (FLine[Run + 1] = #39) and (FLine[Run + 2] = #39) then\r\n    inc(Run, 2);\r\n  repeat\r\n    case FLine[Run] of\r\n      #0, #10, #13: break;\r\n    end;\r\n    inc(Run);\r\n  until FLine[Run] = #39;\r\n  if FLine[Run] <> #0 then inc(Run);\r\nend;\r\n\r\nprocedure TSynAsmSyn.SymbolProc;\r\nbegin\r\n  inc(Run);\r\n  fTokenID := tkSymbol;\r\nend;\r\n\r\nprocedure TSynAsmSyn.UnknownProc;\r\nbegin\r\n  inc(Run);\r\n  fTokenID := tkIdentifier;\r\nend;\r\n\r\nprocedure TSynAsmSyn.Next;\r\nbegin\r\n  fTokenPos := Run;\r\n  case fLine[Run] of\r\n     #0: NullProc;\r\n    #10: LFProc;\r\n    #13: CRProc;\r\n    #34: StringProc;\r\n    #39: SingleQuoteStringProc;\r\n    '>': GreaterProc;\r\n    '<': LowerProc;\r\n    '/': SlashProc;\r\n\r\n    'A'..'Z', 'a'..'z', '_':\r\n      IdentProc;\r\n    '0'..'9':\r\n      NumberProc;\r\n    #1..#9, #11, #12, #14..#32:\r\n      SpaceProc;\r\n    '#', ';':\r\n      CommentProc;\r\n    '.', ':', '&', '{', '}', '=', '^', '-', '+', '(', ')', '*':\r\n      SymbolProc;\r\n    else\r\n      UnknownProc;\r\n  end;\r\n  inherited;\r\nend;\r\n\r\nfunction TSynAsmSyn.GetDefaultAttribute(Index: integer): TSynHighlighterAttributes;\r\nbegin\r\n  case Index of\r\n    SYN_ATTR_COMMENT: Result := fCommentAttri;\r\n    SYN_ATTR_IDENTIFIER: Result := fIdentifierAttri;\r\n    SYN_ATTR_KEYWORD: Result := fKeyAttri;\r\n    SYN_ATTR_STRING: Result := fStringAttri;\r\n    SYN_ATTR_WHITESPACE: Result := fSpaceAttri;\r\n    SYN_ATTR_SYMBOL: Result := fSymbolAttri;\r\n  else\r\n    Result := nil;\r\n  end;\r\nend;\r\n\r\nfunction TSynAsmSyn.GetEol: Boolean;\r\nbegin\r\n  Result := Run = fLineLen + 1;\r\nend;\r\n\r\nfunction TSynAsmSyn.GetTokenAttribute: TSynHighlighterAttributes;\r\nbegin\r\n  case fTokenID of\r\n    tkComment: Result := fCommentAttri;\r\n    tkIdentifier: Result := fIdentifierAttri;\r\n    tkKey: Result := fKeyAttri;\r\n    tkNumber: Result := fNumberAttri;\r\n    tkSpace: Result := fSpaceAttri;\r\n    tkString: Result := fStringAttri;\r\n    tkSymbol: Result := fSymbolAttri;\r\n    tkUnknown: Result := fIdentifierAttri;\r\n    else Result := nil;\r\n  end;\r\nend;\r\n\r\nfunction TSynAsmSyn.GetTokenKind: integer;\r\nbegin\r\n  Result := Ord(fTokenId);\r\nend;\r\n\r\nfunction TSynAsmSyn.GetTokenID: TtkTokenKind;\r\nbegin\r\n  Result := fTokenId;\r\nend;\r\n\r\nclass function TSynAsmSyn.GetLanguageName: string;\r\nbegin\r\n  Result := SYNS_LangX86Asm;\r\nend;\r\n\r\nfunction TSynAsmSyn.IsFilterStored: Boolean;\r\nbegin\r\n  Result := fDefaultFilter <> SYNS_FilterX86Assembly;\r\nend;\r\n\r\nfunction TSynAsmSyn.GetSampleSource: UnicodeString;\r\nbegin\r\n  Result := '; x86 assembly sample source'#13#10 +\r\n            '  CODE\tSEGMENT\tBYTE PUBLIC'#13#10 +\r\n            '    ASSUME\tCS:CODE'#13#10 +\r\n            #13#10 +\r\n            '    PUSH SS'#13#10 +\r\n            '    POP DS'#13#10 +\r\n            '    MOV AX, AABBh'#13#10 +\r\n            '    MOV\tBYTE PTR ES:[DI], 255'#13#10 +\r\n            '    JMP SHORT AsmEnd'#13#10 +\r\n            #13#10 +\r\n            '  welcomeMsg DB ''Hello World'', 0'#13#10 +\r\n            #13#10 +\r\n            '  AsmEnd:'#13#10 +\r\n            '    MOV AX, 0'#13#10 +\r\n            #13#10 +\r\n            '  CODE\tENDS'#13#10 +\r\n            'END';\r\nend;\r\n\r\nclass function TSynAsmSyn.GetFriendlyLanguageName: UnicodeString;\r\nbegin\r\n  Result := SYNS_FriendlyLangX86Asm;\r\nend;\r\n\r\ninitialization\r\n{$IFNDEF SYN_CPPB_1}\r\n  RegisterPlaceableHighlighter(TSynAsmSyn);\r\n{$ENDIF}\r\nend.\r\n\r\n"
  },
  {
    "path": "External/SynEdit/Source/SynHighlighterBaan.pas",
    "content": "{-------------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: SynHighlighterBaan.pas, released 2000-04-21.\r\nThe Original Code is based on the mwBaanSyn.pas file from the\r\nmwEdit component suite by Martin Waldenburg and other developers, the Initial\r\nAuthor of this file is \"riceball\".\r\nUnicode translation by Mal Hrz.\r\nAll Rights Reserved.\r\n\r\nContributors to the SynEdit and mwEdit projects are listed in the\r\nContributors.txt file.\r\n\r\nAlternatively, the contents of this file may be used under the terms of the\r\nGNU General Public License Version 2 or later (the \"GPL\"), in which case\r\nthe provisions of the GPL are applicable instead of those above.\r\nIf you wish to allow use of your version of this file only under the terms\r\nof the GPL and not to allow others to use your version of this file\r\nunder the MPL, indicate your decision by deleting the provisions above and\r\nreplace them with the notice and other provisions required by the GPL.\r\nIf you do not delete the provisions above, a recipient may use your version\r\nof this file under either the MPL or the GPL.\r\n\r\n$Id: SynHighlighterBaan.pas,v 1.13.2.6 2008/09/14 16:24:59 maelh Exp $\r\n\r\nYou may retrieve the latest version of this file at the SynEdit home page,\r\nlocated at http://SynEdit.SourceForge.net\r\n\r\nKnown Issues:\r\n-------------------------------------------------------------------------------}\r\n{\r\n@abstract(Provides a Baan syntax highlighter for SynEdit)\r\n@author(riceball , converted to SynEdit by Bruno Mikkelsen )\r\n@created(2000, converted to SynEdit 2000-04-21)\r\n@lastmod(2000-04-21)\r\nThe SynHighlighterBaan unit provides SynEdit with a Baan syntax highlighter.\r\nThanks to Martin Waldenburg.\r\n}\r\n\r\n{$IFNDEF QSYNHIGHLIGHTERBAAN}\r\nunit SynHighlighterBaan;\r\n{$ENDIF}\r\n\r\n{$I SynEdit.inc}\r\n\r\ninterface\r\n\r\nuses\r\n{$IFDEF SYN_CLX}\r\n  Qt, QControls, QGraphics,\r\n  QSynEditTypes,\r\n  QSynEditHighlighter,\r\n  QSynUnicode,\r\n{$ELSE}\r\n  Windows, Messages, Controls, Graphics, Registry,\r\n  SynEditTypes,\r\n  SynEditHighlighter,\r\n  SynUnicode,\r\n{$ENDIF}\r\n  SysUtils, Classes;\r\n\r\ntype\r\n  TtkTokenKind = (tkComment, tkDirective, tkIdentifier, tkKey, tkNull, tkNumber,\r\n    tkSpace, tkString, tkSymbol, tkUnknown, tkVariable);\r\n\r\n  PIdentFuncTableFunc = ^TIdentFuncTableFunc;\r\n  TIdentFuncTableFunc = function (Index: Integer): TtkTokenKind of object;\r\n\r\ntype\r\n  TSynBaanSyn = class(TSynCustomHighlighter)\r\n  private\r\n    FTokenID: TtkTokenKind;\r\n    fIdentFuncTable: array[0..460] of TIdentFuncTableFunc;\r\n    fCommentAttri: TSynHighlighterAttributes;\r\n    fDirectiveAttri: TSynHighlighterAttributes;\r\n    fIdentifierAttri: TSynHighlighterAttributes;\r\n    fKeyAttri: TSynHighlighterAttributes;\r\n    fNumberAttri: TSynHighlighterAttributes;\r\n    fSpaceAttri: TSynHighlighterAttributes;\r\n    fStringAttri: TSynHighlighterAttributes;\r\n    fSymbolAttri: TSynHighlighterAttributes;\r\n    fVariableAttri: TSynHighlighterAttributes;\r\n    function AltFunc(Index: Integer): TtkTokenKind;\r\n    function KeyWordFunc(Index: Integer): TtkTokenKind;\r\n    function FuncBrp46open(Index: Integer): TtkTokenKind;\r\n    function FuncDate46num(Index: Integer): TtkTokenKind;\r\n    function HashKey(Str: PWideChar): Cardinal;\r\n    function IdentKind(MayBe: PWideChar): TtkTokenKind;\r\n    procedure InitIdent;\r\n    procedure AndSymbolProc;\r\n    procedure AsciiCharProc;\r\n    procedure AtSymbolProc;\r\n    procedure BraceCloseProc;\r\n    procedure BraceOpenProc;\r\n    procedure CRProc;\r\n    procedure ColonProc;\r\n    procedure CommaProc;\r\n    procedure DirectiveProc;\r\n    procedure EqualProc;\r\n    procedure ErectProc;\r\n    procedure GreaterProc;\r\n    procedure IdentProc;\r\n    procedure LFProc;\r\n    procedure LowerProc;\r\n    procedure MinusProc;\r\n    procedure ModSymbolProc;\r\n    procedure NotSymbolProc;\r\n    procedure NullProc;\r\n    procedure NumberProc;\r\n    procedure PlusProc;\r\n    procedure RoundCloseProc;\r\n    procedure RoundOpenProc;\r\n    procedure SemiColonProc;\r\n    procedure SlashProc;\r\n    procedure SpaceProc;\r\n    procedure SquareCloseProc;\r\n    procedure SquareOpenProc;\r\n    procedure StarProc;\r\n    procedure StringProc;\r\n    procedure TildeProc;\r\n    procedure XOrSymbolProc;\r\n    procedure UnknownProc;\r\n  protected\r\n    function IsFilterStored: Boolean; override;\r\n  public\r\n    class function GetLanguageName: string; override;\r\n    class function GetFriendlyLanguageName: UnicodeString; override;\r\n  public\r\n    constructor Create(AOwner: TComponent); override;\r\n    function GetDefaultAttribute(Index: integer): TSynHighlighterAttributes;\r\n      override;\r\n    function GetEol: Boolean; override;\r\n    function GetTokenID: TtkTokenKind;\r\n    function GetTokenAttribute: TSynHighlighterAttributes; override;\r\n    function GetTokenKind: integer; override;\r\n    function IsIdentChar(AChar: WideChar): Boolean; override;\r\n    procedure Next; override;\r\n  published\r\n    property CommentAttri: TSynHighlighterAttributes read fCommentAttri\r\n      write fCommentAttri;\r\n    property DirectiveAttri: TSynHighlighterAttributes read fDirectiveAttri\r\n      write fDirectiveAttri;\r\n    property IdentifierAttri: TSynHighlighterAttributes read fIdentifierAttri\r\n      write fIdentifierAttri;\r\n    property KeyAttri: TSynHighlighterAttributes read fKeyAttri write fKeyAttri;\r\n    property NumberAttri: TSynHighlighterAttributes read fNumberAttri\r\n      write fNumberAttri;\r\n    property SpaceAttri: TSynHighlighterAttributes read fSpaceAttri\r\n      write fSpaceAttri;\r\n    property StringAttri: TSynHighlighterAttributes read fStringAttri\r\n      write fStringAttri;\r\n    property SymbolAttri: TSynHighlighterAttributes read fSymbolAttri\r\n      write fSymbolAttri;\r\n    property VariableAttri: TSynHighlighterAttributes read fVariableAttri\r\n      write fVariableAttri;\r\n  end;\r\n\r\nimplementation\r\n\r\nuses\r\n{$IFDEF SYN_CLX}\r\n  QSynEditStrConst;\r\n{$ELSE}\r\n  SynEditStrConst;\r\n{$ENDIF}\r\n\r\nconst\r\n  KeyWords: array[0..112] of UnicodeString = (\r\n    '__based', '__cdecl', '__declspe', '__except', '__export', '__far', \r\n    '__fastcal', '__fortran', '__import', '__int16', '__int32', '__int64', \r\n    '__int8', '__interrup', '__loadds', '__near', '__pascal', '__rtti', \r\n    '__segment', '__segname', '__self', '__stdcall', '__thread', '__try', \r\n    '_cdecl', '_export', '_fastcall', '_import', '_pascal', '_stdcall', 'auto', \r\n    'bool', 'break', 'brp.open', 'case', 'catch', 'cdecl', 'char', 'class', \r\n    'const', 'continue', 'date.num', 'default', 'defined', 'delete', 'do', \r\n    'domain', 'double', 'else', 'endif', 'endselect', 'enum', 'explicit', \r\n    'export', 'extern', 'false', 'fastcall', 'finally', 'float', 'for', \r\n    'friend', 'from', 'function', 'goto', 'if', 'import', 'inline', 'int', \r\n    'interrupt', 'long', 'mutable', 'namespace', 'new', 'null', 'operator', \r\n    'pascal', 'private', 'protected', 'public', 'register', 'reinterpr', \r\n    'return', 'select', 'selectdo', 'short', 'signed', 'sizeof', 'sql.close', \r\n    'static', 'static_ca', 'stdcall', 'string', 'strip$', 'struct', 'switch', \r\n    'table', 'template', 'this', 'throw', 'true', 'try', 'typedef', 'typeid', \r\n    'typename', 'union', 'unsigned', 'using', 'virtual', 'void', 'volatile', \r\n    'wchar_t', 'where', 'while' \r\n  );\r\n\r\n  KeyIndices: array[0..460] of Integer = (\r\n    -1, -1, -1, -1, -1, -1, 83, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, 3, 33, 26, -1, 78, -1, -1, -1, -1, -1, 5, -1, 14, -1, 27, -1, 92, -1, \r\n    -1, -1, -1, 42, -1, 77, -1, -1, -1, -1, -1, -1, -1, -1, -1, 61, -1, -1, -1, \r\n    93, 2, -1, -1, -1, 50, -1, -1, -1, -1, -1, 40, -1, -1, -1, -1, 63, -1, 94, \r\n    -1, -1, 69, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 25, -1, -1, 44, -1, -1, \r\n    -1, 110, -1, -1, 51, -1, -1, -1, -1, 56, -1, 32, -1, -1, 109, -1, -1, -1, \r\n    -1, 16, -1, -1, -1, -1, 23, 88, -1, -1, 10, -1, -1, -1, -1, 67, -1, -1, -1, \r\n    72, 81, -1, -1, -1, 82, 24, -1, -1, -1, -1, -1, -1, -1, -1, 79, -1, -1, 64, \r\n    21, 80, -1, -1, 59, 0, -1, -1, -1, 12, -1, -1, 107, -1, 36, -1, -1, -1, -1, \r\n    31, -1, -1, -1, 62, -1, -1, 112, -1, -1, -1, -1, -1, -1, 7, -1, 106, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, 52, 104, -1, 18, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, 65, -1, -1, -1, 13, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, 29, 28, 43, -1, 20, -1, -1, -1, 38, -1, -1, -1, -1, \r\n    -1, 103, -1, 70, 87, -1, -1, -1, 85, -1, 74, -1, -1, -1, -1, -1, 35, 39, -1, \r\n    -1, 97, 53, -1, -1, -1, -1, -1, -1, -1, 84, -1, 95, -1, -1, -1, -1, -1, -1, \r\n    -1, 100, 98, -1, -1, -1, -1, -1, -1, -1, -1, 111, 73, -1, 47, -1, -1, -1, \r\n    -1, -1, -1, -1, 105, -1, -1, -1, -1, -1, 66, 86, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, 34, -1, -1, 9, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 37, 55, -1, \r\n    -1, -1, 89, -1, 11, -1, -1, -1, 19, -1, -1, -1, -1, 90, -1, 102, 54, -1, -1, \r\n    45, -1, -1, 6, 30, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 46, 8, 22, -1, \r\n    -1, -1, -1, 99, -1, -1, -1, -1, -1, -1, -1, -1, -1, 101, -1, -1, -1, -1, -1, \r\n    -1, -1, 71, -1, -1, -1, -1, -1, 96, 48, -1, -1, -1, -1, -1, 75, -1, 60, -1, \r\n    -1, 58, -1, -1, -1, 1, -1, -1, -1, -1, -1, -1, -1, 17, 4, -1, -1, -1, -1, \r\n    49, -1, -1, -1, -1, 57, -1, -1, -1, -1, 15, 91, -1, -1, 41, -1, -1, -1, 76, \r\n    68, -1, -1, -1, 108, -1, -1 \r\n  );\r\n\r\n{$Q-}\r\nfunction TSynBaanSyn.HashKey(Str: PWideChar): Cardinal;\r\nbegin\r\n  Result := 0;\r\n  while IsIdentChar(Str^) do\r\n  begin\r\n    Result := Result * 838 + Ord(Str^) * 296;\r\n    inc(Str);\r\n  end;\r\n  Result := Result mod 461;\r\n  fStringLen := Str - fToIdent;\r\nend;\r\n{$Q+}\r\n\r\nfunction TSynBaanSyn.IdentKind(MayBe: PWideChar): TtkTokenKind;\r\nvar\r\n  Key: Cardinal;\r\nbegin\r\n  fToIdent := MayBe;\r\n  Key := HashKey(MayBe);\r\n  if Key <= High(fIdentFuncTable) then\r\n    Result := fIdentFuncTable[Key](KeyIndices[Key])\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nprocedure TSynBaanSyn.InitIdent;\r\nvar\r\n  i: Integer;\r\nbegin\r\n  for i := Low(fIdentFuncTable) to High(fIdentFuncTable) do\r\n    if KeyIndices[i] = -1 then\r\n      fIdentFuncTable[i] := AltFunc;\r\n\r\n  fIdentFuncTable[21] := FuncBrp46open;\r\n  fIdentFuncTable[449] := FuncDate46num;\r\n\r\n  for i := Low(fIdentFuncTable) to High(fIdentFuncTable) do\r\n    if @fIdentFuncTable[i] = nil then\r\n      fIdentFuncTable[i] := KeyWordFunc;\r\nend;\r\n\r\nfunction TSynBaanSyn.AltFunc(Index: Integer): TtkTokenKind;\r\nbegin\r\n  Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynBaanSyn.KeyWordFunc(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier\r\nend;\r\n\r\nfunction TSynBaanSyn.FuncBrp46open(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkVariable\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynBaanSyn.FuncDate46num(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkVariable\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nconstructor TSynBaanSyn.Create(AOwner: TComponent);\r\nbegin\r\n  inherited Create(AOwner);\r\n\r\n  fCaseSensitive := False;\r\n\r\n  fCommentAttri := TSynHighlighterAttributes.Create(SYNS_AttrComment, SYNS_FriendlyAttrComment);\r\n  fCommentAttri.Style := [fsItalic];\r\n  AddAttribute(fCommentAttri);\r\n  fDirectiveAttri := TSynHighlighterAttributes.Create(SYNS_AttrDirective, SYNS_FriendlyAttrDirective);\r\n  AddAttribute(fDirectiveAttri);\r\n  fIdentifierAttri := TSynHighlighterAttributes.Create(SYNS_AttrIdentifier, SYNS_FriendlyAttrIdentifier);\r\n  AddAttribute(fIdentifierAttri);\r\n  fKeyAttri := TSynHighlighterAttributes.Create(SYNS_AttrReservedWord, SYNS_FriendlyAttrReservedWord);\r\n  fKeyAttri.Style := [fsBold];\r\n  AddAttribute(fKeyAttri);\r\n  fNumberAttri := TSynHighlighterAttributes.Create(SYNS_AttrNumber, SYNS_FriendlyAttrNumber);\r\n  AddAttribute(fNumberAttri);\r\n  fSpaceAttri := TSynHighlighterAttributes.Create(SYNS_AttrSpace, SYNS_FriendlyAttrSpace);\r\n  AddAttribute(fSpaceAttri);\r\n  fStringAttri := TSynHighlighterAttributes.Create(SYNS_AttrString, SYNS_FriendlyAttrString);\r\n  AddAttribute(fStringAttri);\r\n  fSymbolAttri := TSynHighlighterAttributes.Create(SYNS_AttrSymbol, SYNS_FriendlyAttrSymbol);\r\n  AddAttribute(fSymbolAttri);\r\n  fVariableAttri := TSynHighlighterAttributes.Create(SYNS_AttrVariable, SYNS_FriendlyAttrVariable);\r\n  AddAttribute(fVariableAttri);\r\n  SetAttributesOnChange(DefHighlightChange);\r\n  InitIdent;\r\n  fDefaultFilter := SYNS_FilterBaan;\r\nend;\r\n\r\nprocedure TSynBaanSyn.AndSymbolProc;\r\nbegin\r\n  case FLine[Run + 1] of\r\n    '=':                               {and assign}\r\n      begin\r\n        inc(Run, 2);\r\n        fTokenID := tkSymbol;\r\n      end;\r\n    '&':                               {logical and}\r\n      begin\r\n        inc(Run, 2);\r\n        fTokenID := tkSymbol;\r\n      end;\r\n  else                                 {and}\r\n    begin\r\n      inc(Run);\r\n      fTokenID := tkSymbol;\r\n    end;\r\n  end;\r\nend;\r\n\r\nprocedure TSynBaanSyn.AsciiCharProc;\r\nbegin\r\n  fTokenID := tkString;\r\n  repeat\r\n    case FLine[Run] of\r\n      #0, #10, #13: break;\r\n    end;\r\n    inc(Run);\r\n  until FLine[Run] = #39;\r\n  if FLine[Run] <> #0 then inc(Run);\r\nend;\r\n\r\nprocedure TSynBaanSyn.AtSymbolProc;\r\nbegin\r\n  fTokenID := tkSymbol;\r\n  inc(Run);\r\nend;\r\n\r\nprocedure TSynBaanSyn.BraceCloseProc;\r\nbegin\r\n  inc(Run);\r\n  fTokenId := tkSymbol;\r\nend;\r\n\r\nprocedure TSynBaanSyn.BraceOpenProc;\r\nbegin\r\n  inc(Run);\r\n  fTokenId := tkSymbol;\r\nend;\r\n\r\nprocedure TSynBaanSyn.CRProc;\r\nbegin\r\n  fTokenID := tkSpace;\r\n  Case FLine[Run + 1] of\r\n    #10: inc(Run, 2);\r\n  else inc(Run);\r\n  end;\r\nend;\r\n\r\nprocedure TSynBaanSyn.ColonProc;\r\nbegin\r\n  Case FLine[Run + 1] of\r\n    ':':                               {scope resolution operator}\r\n      begin\r\n        inc(Run, 2);\r\n        fTokenID := tkSymbol;\r\n      end;\r\n  else                                 {colon}\r\n    begin\r\n      inc(Run);\r\n      fTokenID := tkSymbol;\r\n    end;\r\n  end;\r\nend;\r\n\r\nprocedure TSynBaanSyn.CommaProc;\r\nbegin\r\n  inc(Run);\r\n  fTokenID := tkSymbol;\r\nend;\r\n\r\nprocedure TSynBaanSyn.DirectiveProc;\r\nbegin\r\n  fTokenID := tkDirective;\r\n  repeat\r\n    case FLine[Run] of\r\n      #0, #10, #13: break;\r\n    end;\r\n    inc(Run);\r\n  until FLine[Run] = #0;\r\nend;\r\n\r\nprocedure TSynBaanSyn.EqualProc;\r\nbegin\r\n  case FLine[Run + 1] of\r\n    '=':                               {logical equal}\r\n      begin\r\n        inc(Run, 2);\r\n        fTokenID := tkSymbol;\r\n      end;\r\n  else                                 {assign}\r\n    begin\r\n      inc(Run);\r\n      fTokenID := tkSymbol;\r\n    end;\r\n  end;\r\nend;\r\n\r\nprocedure TSynBaanSyn.ErectProc;\r\nbegin\r\n  inc(Run, 1);                        {Bann Comments}\r\n  fTokenID := tkComment;\r\n  while FLine[Run] <> #0 do\r\n  begin\r\n    case FLine[Run] of\r\n      #10, #13: break;\r\n    end; //case\r\n    inc(Run);\r\n  end; //while\r\nend;\r\n\r\nprocedure TSynBaanSyn.GreaterProc;\r\nbegin\r\n  Case FLine[Run + 1] of\r\n    '=':                               {greater than or equal to}\r\n      begin\r\n        inc(Run, 2);\r\n        fTokenID := tkSymbol;\r\n      end;\r\n    '>':\r\n      begin\r\n        if FLine[Run + 2] = '=' then   {shift right assign}\r\n          inc(Run, 3)\r\n        else                           {shift right}\r\n          inc(Run, 2);\r\n        fTokenID := tkSymbol;\r\n      end;\r\n  else                                 {greater than}\r\n    begin\r\n      inc(Run);\r\n      fTokenID := tkSymbol;\r\n    end;\r\n  end;\r\nend;\r\n\r\nprocedure TSynBaanSyn.IdentProc;\r\nbegin\r\n  fTokenID := IdentKind(fLine + Run);\r\n  inc(Run, fStringLen);\r\n  while IsIdentChar(fLine[Run]) do inc(Run);\r\nend;\r\n\r\nprocedure TSynBaanSyn.LFProc;\r\nbegin\r\n  fTokenID := tkSpace;\r\n  inc(Run);\r\nend;\r\n\r\nprocedure TSynBaanSyn.LowerProc;\r\nbegin\r\n  case FLine[Run + 1] of\r\n    '=':                               {less than or equal to}\r\n      begin\r\n        inc(Run, 2);\r\n        fTokenID := tkSymbol;\r\n      end;\r\n    '<':\r\n      begin\r\n        if FLine[Run + 2] = '=' then   {shift left assign}\r\n          inc(Run, 3)\r\n        else                           {shift left}\r\n          inc(Run, 2);\r\n        fTokenID := tkSymbol;\r\n      end;\r\n  else                                 {less than}\r\n    begin\r\n      inc(Run);\r\n      fTokenID := tkSymbol;\r\n    end;\r\n  end;\r\nend;\r\n\r\nprocedure TSynBaanSyn.MinusProc;\r\nbegin\r\n  case FLine[Run + 1] of\r\n    '=':                               {subtract assign}\r\n      begin\r\n        inc(Run, 2);\r\n        fTokenID := tkSymbol;\r\n      end;\r\n    '-':                               {decrement}\r\n      begin\r\n        inc(Run, 2);\r\n        fTokenID := tkSymbol;\r\n      end;\r\n    '>':                               {arrow}\r\n      begin\r\n        inc(Run, 2);\r\n        fTokenID := tkSymbol;\r\n      end;\r\n  else                                 {subtract}\r\n    begin\r\n      inc(Run);\r\n      fTokenID := tkSymbol;\r\n    end;\r\n  end;\r\nend;\r\n\r\nprocedure TSynBaanSyn.ModSymbolProc;\r\nbegin\r\n  case FLine[Run + 1] of\r\n    '=':                               {mod assign}\r\n      begin\r\n        inc(Run, 2);\r\n        fTokenID := tkSymbol;\r\n      end;\r\n  else                                 {mod}\r\n    begin\r\n      inc(Run);\r\n      fTokenID := tkSymbol;\r\n    end;\r\n  end;\r\nend;\r\n\r\nprocedure TSynBaanSyn.NotSymbolProc;\r\nbegin\r\n  case FLine[Run + 1] of\r\n    '=':                               {not equal}\r\n      begin\r\n        inc(Run, 2);\r\n        fTokenID := tkSymbol;\r\n      end;\r\n  else                                 {not}\r\n    begin\r\n      inc(Run);\r\n      fTokenID := tkSymbol;\r\n    end;\r\n  end;\r\nend;\r\n\r\nprocedure TSynBaanSyn.NullProc;\r\nbegin\r\n  fTokenID := tkNull;\r\n  inc(Run);\r\nend;\r\n\r\nprocedure TSynBaanSyn.NumberProc;\r\n\r\n  function IsNumberChar: Boolean;\r\n  begin\r\n    case fLine[Run] of\r\n      '0'..'9', '.', 'u', 'U', 'l', 'L', 'x', 'X', 'e', 'E', 'f', 'F':\r\n        Result := True;\r\n      else\r\n        Result := False;\r\n    end;\r\n  end;\r\n\r\nbegin\r\n  inc(Run);\r\n  fTokenID := tkNumber;\r\n  while IsNumberChar do\r\n  begin\r\n    case FLine[Run] of\r\n      '.':\r\n        if FLine[Run + 1] = '.' then break;\r\n    end;\r\n    inc(Run);\r\n  end;\r\nend;\r\n\r\nprocedure TSynBaanSyn.PlusProc;\r\nbegin\r\n  case FLine[Run + 1] of\r\n    '=':                               {add assign}\r\n      begin\r\n        inc(Run, 2);\r\n        fTokenID := tkSymbol;\r\n      end;\r\n    '+':                               {increment}\r\n      begin\r\n        inc(Run, 2);\r\n        fTokenID := tkSymbol;\r\n      end;\r\n  else                                 {subtract}\r\n    begin\r\n      inc(Run);\r\n      fTokenID := tkSymbol;\r\n    end;\r\n  end;\r\nend;\r\n\r\nprocedure TSynBaanSyn.RoundCloseProc;\r\nbegin\r\n  inc(Run);\r\n  fTokenID := tkSymbol;\r\nend;\r\n\r\nprocedure TSynBaanSyn.RoundOpenProc;\r\nbegin\r\n  inc(Run);\r\n  FTokenID := tkSymbol;\r\nend;\r\n\r\nprocedure TSynBaanSyn.SemiColonProc;\r\nbegin\r\n  inc(Run);\r\n  fTokenID := tkSymbol;\r\nend;\r\n\r\nprocedure TSynBaanSyn.SlashProc;\r\nbegin\r\n  case FLine[Run + 1] of\r\n    '=':                               {division assign}\r\n      begin\r\n        inc(Run, 2);\r\n        fTokenID := tkSymbol;\r\n      end;\r\n  else                                 {division}\r\n    begin\r\n      inc(Run);\r\n      fTokenID := tkSymbol;\r\n    end;\r\n  end;\r\nend;\r\n\r\nprocedure TSynBaanSyn.SpaceProc;\r\nbegin\r\n  inc(Run);\r\n  fTokenID := tkSpace;\r\n  while (FLine[Run] <= #32) and not IsLineEnd(Run) do inc(Run);\r\nend;\r\n\r\nprocedure TSynBaanSyn.SquareCloseProc;\r\nbegin\r\n  inc(Run);\r\n  fTokenID := tkSymbol;\r\nend;\r\n\r\nprocedure TSynBaanSyn.SquareOpenProc;\r\nbegin\r\n  inc(Run);\r\n  fTokenID := tkSymbol;\r\nend;\r\n\r\nprocedure TSynBaanSyn.StarProc;\r\nbegin\r\n  case FLine[Run + 1] of\r\n    '=':                               {multiply assign}\r\n      begin\r\n        inc(Run, 2);\r\n        fTokenID := tkSymbol;\r\n      end;\r\n  else                                 {star}\r\n    begin\r\n      inc(Run);\r\n      fTokenID := tkSymbol;\r\n    end;\r\n  end;\r\nend;\r\n\r\nprocedure TSynBaanSyn.StringProc;\r\nbegin\r\n  fTokenID := tkString;\r\n  if (FLine[Run + 1] = #34) and (FLine[Run + 2] = #34) then inc(Run, 2);\r\n  repeat\r\n    case FLine[Run] of\r\n      #0, #10, #13: break;\r\n      #92:\r\n        if FLine[Run + 1] = #10 then inc(Run);\r\n    end;\r\n    inc(Run);\r\n  until FLine[Run] = #34;\r\n  if FLine[Run] <> #0 then inc(Run);\r\nend;\r\n\r\nprocedure TSynBaanSyn.TildeProc;\r\nbegin\r\n  inc(Run);\r\n  fTokenId := tkSymbol;\r\nend;\r\n\r\nprocedure TSynBaanSyn.XOrSymbolProc;\r\nbegin\r\n  Case FLine[Run + 1] of\r\n    '=':                               {xor assign}\r\n      begin\r\n        inc(Run, 2);\r\n        fTokenID := tkSymbol;\r\n      end;\r\n  else                                 {xor}\r\n    begin\r\n      inc(Run);\r\n      fTokenID := tkSymbol;\r\n    end;\r\n  end;\r\nend;\r\n\r\nprocedure TSynBaanSyn.UnknownProc;\r\nbegin\r\n  inc(Run);\r\n  fTokenID := tkUnknown;\r\nend;\r\n\r\nprocedure TSynBaanSyn.Next;\r\nbegin\r\n  fTokenPos := Run;\r\n  case fLine[Run] of\r\n    '&': AndSymbolProc;\r\n    #39: AsciiCharProc;\r\n    '@': AtSymbolProc;\r\n    '}': BraceCloseProc;\r\n    '{': BraceOpenProc;\r\n    #13: CRProc;\r\n    ':': ColonProc;\r\n    ',': CommaProc;\r\n    '#': DirectiveProc;\r\n    '=': EqualProc;\r\n    '|': ErectProc;\r\n    '>': GreaterProc;\r\n    'A'..'Z', 'a'..'z', '_', '.', '$': IdentProc;\r\n    #10: LFProc;\r\n    '<': LowerProc;\r\n    '-': MinusProc;\r\n    '%': ModSymbolProc;\r\n    '!': NotSymbolProc;\r\n    #0: NullProc;\r\n    '0'..'9': NumberProc;\r\n    '+': PlusProc;\r\n    ')': RoundCloseProc;\r\n    '(': RoundOpenProc;\r\n    ';': SemiColonProc;\r\n    '/': SlashProc;\r\n    #1..#9, #11, #12, #14..#32: SpaceProc;\r\n    ']': SquareCloseProc;\r\n    '[': SquareOpenProc;\r\n    '*': StarProc;\r\n    #34: StringProc;\r\n    '~': TildeProc;\r\n    '^': XOrSymbolProc;\r\n    else UnknownProc;\r\n  end;\r\n  inherited;\r\nend;\r\n\r\nfunction TSynBaanSyn.GetDefaultAttribute(Index: Integer): TSynHighlighterAttributes;\r\nbegin\r\n  case Index of\r\n    SYN_ATTR_COMMENT: Result := fCommentAttri;\r\n    SYN_ATTR_IDENTIFIER: Result := fIdentifierAttri;\r\n    SYN_ATTR_KEYWORD: Result := fKeyAttri;\r\n    SYN_ATTR_STRING: Result := fStringAttri;\r\n    SYN_ATTR_WHITESPACE: Result := fSpaceAttri;\r\n    SYN_ATTR_SYMBOL: Result := fSymbolAttri;\r\n  else\r\n    Result := nil;\r\n  end;\r\nend;\r\n\r\nfunction TSynBaanSyn.GetEol: Boolean;\r\nbegin\r\n  Result := Run = fLineLen + 1;\r\nend;\r\n\r\nfunction TSynBaanSyn.GetTokenID: TtkTokenKind;\r\nbegin\r\n  Result := fTokenId;\r\nend;\r\n\r\nfunction TSynBaanSyn.GetTokenAttribute: TSynHighlighterAttributes;\r\nbegin\r\n  case GetTokenID of\r\n    tkComment: Result := fCommentAttri;\r\n    tkDirective: Result := fDirectiveAttri;\r\n    tkIdentifier: Result := fIdentifierAttri;\r\n    tkKey: Result := fKeyAttri;\r\n    tkNumber: Result := fNumberAttri;\r\n    tkSpace: Result := fSpaceAttri;\r\n    tkString: Result := fStringAttri;\r\n    tkSymbol: Result := fSymbolAttri;\r\n    tkVariable: Result := fVariableAttri;\r\n    tkUnknown: Result := fIdentifierAttri;\r\n    else Result := nil;\r\n  end;\r\nend;\r\n\r\nfunction TSynBaanSyn.GetTokenKind: integer;\r\nbegin\r\n  Result := Ord(fTokenId);\r\nend;\r\n\r\nfunction TSynBaanSyn.IsFilterStored: Boolean;\r\nbegin\r\n  Result := fDefaultFilter <> SYNS_FilterBaan;\r\nend;\r\n\r\nfunction TSynBaanSyn.IsIdentChar(AChar: WideChar): Boolean;\r\nbegin\r\n  case AChar of\r\n    '.', '$', '_', '0'..'9', 'a'..'z', 'A'..'Z':\r\n      Result := True;\r\n    else\r\n      Result := False;\r\n  end;\r\nend;\r\n\r\nclass function TSynBaanSyn.GetLanguageName: string;\r\nbegin\r\n  Result := SYNS_LangBaan;\r\nend;\r\n\r\nclass function TSynBaanSyn.GetFriendlyLanguageName: UnicodeString;\r\nbegin\r\n  Result := SYNS_FriendlyLangBaan;\r\nend;\r\n\r\ninitialization\r\n{$IFNDEF SYN_CPPB_1}\r\n  RegisterPlaceableHighlighter(TSynBaanSyn);\r\n{$ENDIF}\r\nend.\r\n"
  },
  {
    "path": "External/SynEdit/Source/SynHighlighterBat.pas",
    "content": "{-------------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: SynHighlighterBat.pas, released 2000-04-18.\r\nThe Original Code is based on the dmBatSyn.pas file from the\r\nmwEdit component suite by Martin Waldenburg and other developers, the Initial\r\nAuthor of this file is David H. Muir.\r\nUnicode translation by Mal Hrz.\r\nAll Rights Reserved.\r\n\r\nContributors to the SynEdit and mwEdit projects are listed in the\r\nContributors.txt file.\r\n\r\nAlternatively, the contents of this file may be used under the terms of the\r\nGNU General Public License Version 2 or later (the \"GPL\"), in which case\r\nthe provisions of the GPL are applicable instead of those above.\r\nIf you wish to allow use of your version of this file only under the terms\r\nof the GPL and not to allow others to use your version of this file\r\nunder the MPL, indicate your decision by deleting the provisions above and\r\nreplace them with the notice and other provisions required by the GPL.\r\nIf you do not delete the provisions above, a recipient may use your version\r\nof this file under either the MPL or the GPL.\r\n\r\n$Id: SynHighlighterBat.pas,v 1.14.2.6 2008/09/14 16:24:59 maelh Exp $\r\n\r\nYou may retrieve the latest version of this file at the SynEdit home page,\r\nlocated at http://SynEdit.SourceForge.net\r\n\r\nKnown Issues:\r\n-------------------------------------------------------------------------------}\r\n{\r\n@abstract(Provides a MS-DOS Batch file highlighter for SynEdit)\r\n@author(David Muir )\r\n@created(Late 1999)\r\n@lastmod(May 19, 2000)\r\nThe SynHighlighterBat unit provides SynEdit with a MS-DOS Batch file (.bat) highlighter.\r\nThe highlighter supports the formatting of keywords and parameters (batch file arguments).\r\n}\r\n\r\n{$IFNDEF QSYNHIGHLIGHTERBAT}\r\nunit SynHighlighterBat;\r\n{$ENDIF}\r\n\r\n{$I SynEdit.inc}\r\n\r\ninterface\r\n\r\nuses\r\n{$IFDEF SYN_CLX}\r\n  QGraphics,\r\n  QSynEditTypes,\r\n  QSynEditHighlighter,\r\n  QSynUnicode,\r\n{$ELSE}\r\n  Graphics,\r\n  SynEditTypes,\r\n  SynEditHighlighter,\r\n  SynUnicode,\r\n{$ENDIF}\r\n  SysUtils,\r\n  Classes;\r\n\r\ntype\r\n  TtkTokenKind = (tkComment, tkIdentifier, tkKey, tkNull, tkNumber, tkSpace,\r\n    tkUnknown, tkVariable);\r\n\r\n  PIdentFuncTableFunc = ^TIdentFuncTableFunc;\r\n  TIdentFuncTableFunc = function (Index: Integer): TtkTokenKind of object;\r\n\r\ntype\r\n  TSynBatSyn = class(TSynCustomHighlighter)\r\n  private\r\n    fIdentFuncTable: array[0..24] of TIdentFuncTableFunc;\r\n    FTokenID: TtkTokenKind;\r\n    fCommentAttri: TSynHighlighterAttributes;\r\n    fIdentifierAttri: TSynHighlighterAttributes;\r\n    fKeyAttri: TSynHighlighterAttributes;\r\n    fNumberAttri: TSynHighlighterAttributes;\r\n    fSpaceAttri: TSynHighlighterAttributes;\r\n    fVariableAttri: TSynHighlighterAttributes;\r\n    function AltFunc(Index: Integer): TtkTokenKind;\r\n    function FuncCall(Index: Integer): TtkTokenKind;\r\n    function FuncCd(Index: Integer): TtkTokenKind;\r\n    function FuncCls(Index: Integer): TtkTokenKind;\r\n    function FuncCopy(Index: Integer): TtkTokenKind;\r\n    function FuncDel(Index: Integer): TtkTokenKind;\r\n    function FuncDo(Index: Integer): TtkTokenKind;\r\n    function FuncEcho(Index: Integer): TtkTokenKind;\r\n    function FuncErrorlevel(Index: Integer): TtkTokenKind;\r\n    function FuncExist(Index: Integer): TtkTokenKind;\r\n    function FuncFor(Index: Integer): TtkTokenKind;\r\n    function FuncGoto(Index: Integer): TtkTokenKind;\r\n    function FuncIf(Index: Integer): TtkTokenKind;\r\n    function FuncIn(Index: Integer): TtkTokenKind;\r\n    function FuncNot(Index: Integer): TtkTokenKind;\r\n    function FuncOff(Index: Integer): TtkTokenKind;\r\n    function FuncOn(Index: Integer): TtkTokenKind;\r\n    function FuncPause(Index: Integer): TtkTokenKind;\r\n    function FuncSet(Index: Integer): TtkTokenKind;\r\n    function FuncShift(Index: Integer): TtkTokenKind;\r\n    function FuncStart(Index: Integer): TtkTokenKind;\r\n    function FuncTitle(Index: Integer): TtkTokenKind;\r\n    function HashKey(Str: PWideChar): Cardinal;\r\n    function IdentKind(MayBe: PWideChar): TtkTokenKind;\r\n    procedure InitIdent;\r\n    procedure VariableProc;\r\n    procedure CRProc;\r\n    procedure CommentProc;\r\n    procedure IdentProc;\r\n    procedure LFProc;\r\n    procedure NullProc;\r\n    procedure NumberProc;\r\n    procedure REMCommentProc;\r\n    procedure SpaceProc;\r\n    procedure UnknownProc;\r\n  protected\r\n    function GetSampleSource: UnicodeString; override;\r\n    function IsFilterStored: Boolean; override;\r\n  public\r\n    class function GetLanguageName: string; override;\r\n    class function GetFriendlyLanguageName: UnicodeString; override;\r\n  public\r\n    constructor Create(AOwner: TComponent); override;        \r\n    function GetDefaultAttribute(Index: integer): TSynHighlighterAttributes;\r\n      override;\r\n    function GetEol: Boolean; override;\r\n    function GetTokenID: TtkTokenKind;\r\n    function GetTokenAttribute: TSynHighlighterAttributes; override;\r\n    function GetTokenKind: integer; override;\r\n    procedure Next; override;\r\n  published\r\n    property CommentAttri: TSynHighlighterAttributes read fCommentAttri\r\n      write fCommentAttri;\r\n    property IdentifierAttri: TSynHighlighterAttributes read fIdentifierAttri\r\n      write fIdentifierAttri;\r\n    property KeyAttri: TSynHighlighterAttributes read fKeyAttri write fKeyAttri;\r\n    property NumberAttri: TSynHighlighterAttributes read fNumberAttri\r\n      write fNumberAttri;\r\n    property SpaceAttri: TSynHighlighterAttributes read fSpaceAttri\r\n      write fSpaceAttri;\r\n    property VariableAttri: TSynHighlighterAttributes read fVariableAttri\r\n      write fVariableAttri;\r\n  end;\r\n\r\nimplementation\r\n\r\nuses\r\n{$IFDEF SYN_CLX}\r\n  QSynEditStrConst;\r\n{$ELSE}\r\n  SynEditStrConst;\r\n{$ENDIF}\r\n\r\nconst\r\n  KeyWords: array[0..20] of UnicodeString = (\r\n    'call', 'cd', 'cls', 'copy', 'del', 'do', 'echo', 'errorlevel', 'exist', \r\n    'for', 'goto', 'if', 'in', 'not', 'off', 'on', 'pause', 'set', 'shift', \r\n    'start', 'title' \r\n  );\r\n\r\n  KeyIndices: array[0..24] of Integer = (\r\n    14, 4, -1, 6, 17, 12, 8, 18, 19, 15, -1, -1, 10, 3, 13, 0, 1, 11, 20, 7, 2, \r\n    5, -1, 16, 9 \r\n  );\r\n\r\n{$Q-}\r\nfunction TSynBatSyn.HashKey(Str: PWideChar): Cardinal;\r\nbegin\r\n  Result := 0;\r\n  while IsIdentChar(Str^) do\r\n  begin\r\n    Result := Result * 869 + Ord(Str^) * 61;\r\n    inc(Str);\r\n  end;\r\n  Result := Result mod 25;\r\n  fStringLen := Str - fToIdent;\r\nend;\r\n{$Q+}\r\n\r\nfunction TSynBatSyn.IdentKind(MayBe: PWideChar): TtkTokenKind;\r\nvar\r\n  Key: Cardinal;\r\nbegin\r\n  fToIdent := MayBe;\r\n  Key := HashKey(MayBe);\r\n  if Key <= High(fIdentFuncTable) then\r\n    Result := fIdentFuncTable[Key](KeyIndices[Key])\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nprocedure TSynBatSyn.InitIdent;\r\nvar\r\n  i: Integer;\r\nbegin\r\n  for i := Low(fIdentFuncTable) to High(fIdentFuncTable) do\r\n    if KeyIndices[i] = -1 then\r\n      fIdentFuncTable[i] := AltFunc;\r\n      \r\n  fIdentFuncTable[15] := FuncCall;\r\n  fIdentFuncTable[16] := FuncCd;\r\n  fIdentFuncTable[20] := FuncCls;\r\n  fIdentFuncTable[13] := FuncCopy;\r\n  fIdentFuncTable[1] := FuncDel;\r\n  fIdentFuncTable[21] := FuncDo;\r\n  fIdentFuncTable[3] := FuncEcho;\r\n  fIdentFuncTable[19] := FuncErrorlevel;\r\n  fIdentFuncTable[6] := FuncExist;\r\n  fIdentFuncTable[24] := FuncFor;\r\n  fIdentFuncTable[12] := FuncGoto;\r\n  fIdentFuncTable[17] := FuncIf;\r\n  fIdentFuncTable[5] := FuncIn;\r\n  fIdentFuncTable[14] := FuncNot;\r\n  fIdentFuncTable[0] := FuncOff;\r\n  fIdentFuncTable[9] := FuncOn;\r\n  fIdentFuncTable[23] := FuncPause;\r\n  fIdentFuncTable[4] := FuncSet;\r\n  fIdentFuncTable[7] := FuncShift;\r\n  fIdentFuncTable[8] := FuncStart;\r\n  fIdentFuncTable[18] := FuncTitle;\r\nend;\r\n\r\nfunction TSynBatSyn.AltFunc(Index: Integer): TtkTokenKind;\r\nbegin\r\n  Result := tkIdentifier\r\nend;\r\n\r\nfunction TSynBatSyn.FuncCall(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynBatSyn.FuncCd(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynBatSyn.FuncCls(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynBatSyn.FuncCopy(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynBatSyn.FuncDel(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynBatSyn.FuncDo(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynBatSyn.FuncEcho(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynBatSyn.FuncErrorlevel(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynBatSyn.FuncExist(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynBatSyn.FuncFor(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynBatSyn.FuncGoto(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynBatSyn.FuncIf(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynBatSyn.FuncIn(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynBatSyn.FuncNot(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynBatSyn.FuncOff(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynBatSyn.FuncOn(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynBatSyn.FuncPause(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynBatSyn.FuncSet(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynBatSyn.FuncShift(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynBatSyn.FuncStart(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynBatSyn.FuncTitle(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nconstructor TSynBatSyn.Create(AOwner: TComponent);\r\nbegin\r\n  inherited Create(AOwner);\r\n\r\n  fCaseSensitive := False;\r\n\r\n  fCommentAttri := TSynHighlighterAttributes.Create(SYNS_AttrComment, SYNS_FriendlyAttrComment);\r\n  fCommentAttri.Style := [fsItalic];\r\n  fCommentAttri.Foreground := clNavy;\r\n  AddAttribute(fCommentAttri);\r\n  fIdentifierAttri := TSynHighlighterAttributes.Create(SYNS_AttrIdentifier, SYNS_FriendlyAttrIdentifier);\r\n  AddAttribute(fIdentifierAttri);\r\n  fKeyAttri := TSynHighlighterAttributes.Create(SYNS_AttrKey, SYNS_FriendlyAttrKey);\r\n  fKeyAttri.Style := [fsBold];\r\n  AddAttribute(fKeyAttri);\r\n  fNumberAttri := TSynHighlighterAttributes.Create(SYNS_AttrNumber, SYNS_FriendlyAttrNumber);\r\n  fNumberAttri.Foreground := clBlue;\r\n  AddAttribute(fNumberAttri);\r\n  fSpaceAttri := TSynHighlighterAttributes.Create(SYNS_AttrSpace, SYNS_FriendlyAttrSpace);\r\n  AddAttribute(fSpaceAttri);\r\n  fVariableAttri := TSynHighlighterAttributes.Create(SYNS_AttrVariable, SYNS_FriendlyAttrVariable);\r\n  fVariableAttri.Foreground := clGreen;\r\n  AddAttribute(fVariableAttri);\r\n  SetAttributesOnChange(DefHighlightChange);\r\n  InitIdent;\r\n  fDefaultFilter := SYNS_FilterBatch;\r\nend;\r\n\r\nprocedure TSynBatSyn.VariableProc;\r\n\r\n  function IsVarChar: Boolean;\r\n  begin\r\n    case fLine[Run] of\r\n      '_', '0'..'9', 'A'..'Z', 'a'..'z':\r\n        Result := True;\r\n      else\r\n        Result := False;\r\n    end;\r\n  end;\r\n\r\nbegin\r\n  fTokenID := tkVariable;\r\n  repeat\r\n    Inc(Run);\r\n  until not IsVarChar;\r\n  if fLine[Run] = '%' then\r\n    Inc(Run);\r\nend;\r\n\r\nprocedure TSynBatSyn.CRProc;\r\nbegin\r\n  fTokenID := tkSpace;\r\n  Inc(Run);\r\n  if (fLine[Run] = #10) then Inc(Run);\r\nend;\r\n\r\nprocedure TSynBatSyn.CommentProc;\r\nbegin\r\n  fTokenID := tkIdentifier;\r\n  Inc(Run);\r\n  if fLine[Run] = ':' then begin\r\n    fTokenID := tkComment;\r\n    repeat\r\n      Inc(Run);\r\n    until IsLineEnd(Run);\r\n  end;\r\nend;\r\n\r\nprocedure TSynBatSyn.IdentProc;\r\nbegin\r\n  fTokenID := IdentKind((fLine + Run));\r\n  Inc(Run, fStringLen);\r\n  while IsIdentChar(fLine[Run]) do inc(Run);\r\nend;\r\n\r\nprocedure TSynBatSyn.LFProc;\r\nbegin\r\n  fTokenID := tkSpace;\r\n  inc(Run);\r\nend;\r\n\r\nprocedure TSynBatSyn.NullProc;\r\nbegin\r\n  fTokenID := tkNull;\r\n  inc(Run);\r\nend;\r\n\r\nprocedure TSynBatSyn.NumberProc;\r\nbegin\r\n  fTokenID := tkNumber;\r\n  repeat\r\n    Inc(Run);\r\n  until not CharInSet(fLine[Run], ['0'..'9', '.']);\r\nend;\r\n\r\nprocedure TSynBatSyn.REMCommentProc;\r\nbegin\r\n  if CharInSet(FLine[Run + 1], ['E', 'e']) and\r\n    CharInSet(FLine[Run + 2], ['M', 'm']) and\r\n    (FLine[Run + 3] < #33) then\r\n  begin\r\n    fTokenID := tkComment;\r\n    Inc(Run, 3);\r\n    while (FLine[Run] <> #0) do begin\r\n      case FLine[Run] of\r\n        #10, #13: break;\r\n      end; { case }\r\n      Inc(Run);\r\n    end; { while }\r\n  end\r\n  else\r\n  begin\r\n    fTokenID := tkIdentifier;\r\n    IdentProc;\r\n  end;\r\nend;\r\n\r\nprocedure TSynBatSyn.SpaceProc;\r\nbegin\r\n  fTokenID := tkSpace;\r\n  repeat\r\n    Inc(Run);\r\n  until (fLine[Run] > #32) or IsLineEnd(Run);\r\nend;\r\n\r\nprocedure TSynBatSyn.UnknownProc;\r\nbegin\r\n  inc(Run);\r\n  fTokenID := tkUnknown;\r\nend;\r\n\r\nprocedure TSynBatSyn.Next;\r\nbegin\r\n  fTokenPos := Run;\r\n\r\n  case fLine[Run] of\r\n    '%': VariableProc;\r\n    #13: CRProc;\r\n    ':': CommentProc;\r\n    'A'..'Q', 'S'..'Z', 'a'..'q', 's'..'z', '_': IdentProc;\r\n    #10: LFProc;\r\n    #0: NullProc;\r\n    '0'..'9': NumberProc;\r\n    'R', 'r': REMCommentProc;\r\n    #1..#9, #11, #12, #14..#32: SpaceProc;\r\n    else\r\n      UnknownProc;\r\n  end;\r\n  inherited;\r\nend;\r\n\r\nfunction TSynBatSyn.GetDefaultAttribute(Index: integer): TSynHighlighterAttributes;\r\nbegin\r\n  case Index of\r\n    SYN_ATTR_COMMENT: Result := fCommentAttri;\r\n    SYN_ATTR_IDENTIFIER: Result := fIdentifierAttri;\r\n    SYN_ATTR_KEYWORD: Result := fKeyAttri;\r\n    SYN_ATTR_WHITESPACE: Result := fSpaceAttri;\r\n  else\r\n    Result := nil;\r\n  end;\r\nend;\r\n\r\nfunction TSynBatSyn.GetEol: Boolean;\r\nbegin\r\n  Result := Run = fLineLen + 1;\r\nend;\r\n\r\nfunction TSynBatSyn.GetTokenAttribute: TSynHighlighterAttributes;\r\nbegin\r\n  case fTokenID of\r\n    tkComment: Result := fCommentAttri;\r\n    tkIdentifier: Result := fIdentifierAttri;\r\n    tkKey: Result := fKeyAttri;\r\n    tkNumber: Result := fNumberAttri;\r\n    tkSpace: Result := fSpaceAttri;\r\n    tkUnknown: Result := fIdentifierAttri;\r\n    tkVariable: Result := fVariableAttri;\r\n    else Result := nil;\r\n  end;\r\nend;\r\n\r\nfunction TSynBatSyn.GetTokenID: TtkTokenKind;\r\nbegin\r\n  Result := fTokenId;\r\nend;\r\n\r\nfunction TSynBatSyn.GetTokenKind: integer;\r\nbegin\r\n  Result := Ord(fTokenId);\r\nend;\r\n\r\nfunction TSynBatSyn.IsFilterStored: Boolean;\r\nbegin\r\n  Result := fDefaultFilter <> SYNS_FilterBatch;\r\nend;\r\n\r\nclass function TSynBatSyn.GetLanguageName: string;\r\nbegin\r\n  Result := SYNS_LangBatch;\r\nend;\r\n\r\nfunction TSynBatSyn.GetSampleSource: UnicodeString;\r\nbegin\r\n  Result := 'rem MS-DOS batch file'#13#10 +\r\n            'rem'#13#10 +\r\n            '@echo off'#13#10 +\r\n            'cls'#13#10 +\r\n            'echo The command line is: %1 %2 %3 %4 %5'#13#10 +\r\n            'rem'#13#10 +\r\n            'rem now wait for the user ...'#13#10 +\r\n            'pause'#13#10 +\r\n            'copy c:\\*.pas d:\\'#13#10 +\r\n            'if errorlevel 1 echo Error in copy action!';\r\nend;\r\n\r\nclass function TSynBatSyn.GetFriendlyLanguageName: UnicodeString;\r\nbegin\r\n  Result := SYNS_FriendlyLangBatch;\r\nend;\r\n\r\ninitialization\r\n{$IFNDEF SYN_CPPB_1}\r\n  RegisterPlaceableHighlighter(TSynBatSyn);\r\n{$ENDIF}\r\nend.\r\n"
  },
  {
    "path": "External/SynEdit/Source/SynHighlighterCAC.pas",
    "content": "{-------------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: SynHighlighterCAC.pas, released 2000-04-21.\r\nThe Original Code is based on the cwCACSyn.pas file from the\r\nmwEdit component suite by Martin Waldenburg and other developers, the Initial\r\nAuthor of this file is Carlos Wijders.\r\nUnicode translation by Mal Hrz.\r\nAll Rights Reserved.\r\n\r\nContributors to the SynEdit and mwEdit projects are listed in the\r\nContributors.txt file.\r\n\r\nAlternatively, the contents of this file may be used under the terms of the\r\nGNU General Public License Version 2 or later (the \"GPL\"), in which case\r\nthe provisions of the GPL are applicable instead of those above.\r\nIf you wish to allow use of your version of this file only under the terms\r\nof the GPL and not to allow others to use your version of this file\r\nunder the MPL, indicate your decision by deleting the provisions above and\r\nreplace them with the notice and other provisions required by the GPL.\r\nIf you do not delete the provisions above, a recipient may use your version\r\nof this file under either the MPL or the GPL.\r\n\r\n$Id: SynHighlighterCAC.pas,v 1.10.2.8 2008/09/14 16:24:59 maelh Exp $\r\n\r\nYou may retrieve the latest version of this file at the SynEdit home page,\r\nlocated at http://SynEdit.SourceForge.net\r\n\r\nKnown Issues:\r\n-------------------------------------------------------------------------------}\r\n{\r\n@abstract(Provides a CA-Clipper syntax highlighter for SynEdit)\r\n@author(Carlos Wijders , converted to SynEdit by Bruno Mikkelsen )\r\n@created(1998-12-27, converted to SynEdit 2000-04-21)\r\n@lastmod(2000-06-23)\r\nThe SynHighlighterCAC unit provides SynEdit with a CA-Clipper syntax highlighter.\r\nThanks to Primoz Gabrijelcic, Andy Jeffries.\r\n}\r\n\r\n{$IFNDEF QSYNHIGHLIGHTERCAC}\r\nunit SynHighlighterCAC;\r\n{$ENDIF}\r\n\r\n{$I SynEdit.inc}\r\n\r\ninterface\r\n\r\nuses\r\n{$IFDEF SYN_CLX}\r\n  QGraphics,\r\n  QSynEditTypes,\r\n  QSynEditHighlighter,\r\n  QSynUnicode,\r\n{$ELSE}\r\n  Graphics,\r\n  SynEditTypes,\r\n  SynEditHighlighter,\r\n  SynUnicode,\r\n{$ENDIF}\r\n  SysUtils,\r\n  Classes;\r\n\r\ntype\r\n  TtkTokenKind = (tkComment, tkDirective, tkIdentifier, tkKey, tkNull, tkNumber,\r\n    tkSpace, tkString, tkOperator, tkUnknown);\r\n\r\n  TRangeState = (rsANil, rsCStyle, rsUnknown);\r\n\r\n  PIdentFuncTableFunc = ^TIdentFuncTableFunc;\r\n  TIdentFuncTableFunc = function (Index: Integer): TtkTokenKind of object;\r\n\r\n  TSynCACSyn = class(TSynCustomHighlighter)\r\n  private\r\n    fRange: TRangeState;\r\n    FTokenID: TtkTokenKind;\r\n    fStringAttri: TSynHighlighterAttributes;\r\n    fOperatorAttri: TSynHighlighterAttributes;\r\n    fKeyAttri: TSynHighlighterAttributes;\r\n    fNumberAttri: TSynHighlighterAttributes;\r\n    fCommentAttri: TSynHighlighterAttributes;\r\n    fSpaceAttri: TSynHighlighterAttributes;\r\n    fIdentifierAttri: TSynHighlighterAttributes;\r\n    fDirecAttri: TSynHighlighterAttributes;\r\n    fIdentFuncTable: array[0..708] of TIdentFuncTableFunc;\r\n    function AltFunc(Index: Integer): TtkTokenKind;\r\n    function KeyWordFunc(Index: Integer): TtkTokenKind;\r\n    function HashKey(Str: PWideChar): Cardinal;\r\n    function IdentKind(MayBe: PWideChar): TtkTokenKind;\r\n    procedure InitIdent;\r\n    procedure StarProc;\r\n    procedure CRProc;\r\n    procedure IdentProc;\r\n    procedure LFProc;\r\n    procedure NullProc;\r\n    procedure NumberProc;\r\n    procedure SlashProc;\r\n    procedure SpaceProc;\r\n    procedure SymbolProc;\r\n    procedure StringProc;\r\n    procedure DirectiveProc;\r\n    procedure UnknownProc;\r\n    procedure CStyleProc;\r\n  protected\r\n    function IsFilterStored: Boolean; override;\r\n  public\r\n    class function GetLanguageName: string; override;\r\n    class function GetFriendlyLanguageName: UnicodeString; override;\r\n  public\r\n    constructor Create(AOwner: TComponent); override;\r\n    function GetDefaultAttribute(Index: integer): TSynHighlighterAttributes;\r\n      override;\r\n    function GetEol: Boolean; override;\r\n    function GetRange: Pointer; override;\r\n    function GetTokenID: TtkTokenKind;\r\n    function GetTokenAttribute: TSynHighlighterAttributes; override;\r\n    function GetTokenKind: integer; override;\r\n    procedure Next; override;\r\n    procedure SetRange(Value: Pointer); override;\r\n    procedure ResetRange; override;\r\n  published\r\n    property CommentAttri: TSynHighlighterAttributes read fCommentAttri\r\n      write fCommentAttri;\r\n    property IdentifierAttri: TSynHighlighterAttributes read fIdentifierAttri\r\n      write fIdentifierAttri;\r\n    property KeyAttri: TSynHighlighterAttributes read fKeyAttri write fKeyAttri;\r\n    property NumberAttri: TSynHighlighterAttributes read fNumberAttri\r\n      write fNumberAttri;\r\n    property SpaceAttri: TSynHighlighterAttributes read fSpaceAttri\r\n      write fSpaceAttri;\r\n    property StringAttri: TSynHighlighterAttributes read fStringAttri\r\n      write fStringAttri;\r\n    property OperatorAttri: TSynHighlighterAttributes read fOperatorAttri\r\n      write fOperatorAttri;\r\n    property DirecAttri: TSynHighlighterAttributes read fDirecAttri\r\n      write fDirecAttri;\r\n  end;\r\n\r\nimplementation\r\n\r\nuses\r\n{$IFDEF SYN_CLX}\r\n  QSynEditStrConst;\r\n{$ELSE}\r\n  SynEditStrConst;\r\n{$ENDIF}\r\n\r\nconst\r\n  KeyWords: array[0..142] of UnicodeString = (\r\n    'aadd', 'abs', 'and', 'announce', 'asc', 'at', 'average', 'begin', 'bof', \r\n    'break', 'call', 'cancel', 'cdow', 'chr', 'clear', 'close', 'cmonth', 'col', \r\n    'commit', 'continue', 'copy', 'count', 'create', 'ctod', 'date', 'day', \r\n    'declare', 'delete', 'deleted', 'devpos', 'dir', 'display', 'dow', 'dtoc', \r\n    'dtos', 'eject', 'else', 'elseif', 'empty', 'endcase', 'enddo', 'endif', \r\n    'eof', 'erase', 'exit', 'exp', 'external', 'fcount', 'field', 'fieldname', \r\n    'file', 'find', 'flock', 'for', 'found', 'function', 'get', 'go', 'if', \r\n    'iif', 'index', 'init', 'inkey', 'input', 'int', 'join', 'keyboard', \r\n    'lastrec', 'len', 'list', 'local', 'locate', 'lock', 'log', 'lower', \r\n    'ltrim', 'max', 'memvar', 'min', 'month', 'not', 'note', 'or', 'pack', \r\n    'parameters', 'pcol', 'pcount', 'private', 'procedure', 'prompt', 'prow', \r\n    'public', 'quit', 'read', 'recall', 'reccount', 'recno', 'reindex', \r\n    'release', 'rename', 'replace', 'replicate', 'request', 'restore', 'return', \r\n    'rlock', 'round', 'row', 'rtrim', 'run', 'save', 'say', 'seconds', 'seek', \r\n    'select', 'sequence', 'setpos', 'skip', 'sort', 'space', 'sqrt', 'static', \r\n    'store', 'str', 'substr', 'sum', 'text', 'time', 'total', 'transform', \r\n    'trim', 'type', 'unlock', 'update', 'upper', 'use', 'val', 'valtype', \r\n    'wait', 'while', 'word', 'year', 'zap' \r\n  );\r\n\r\n  KeyIndices: array[0..708] of Integer = (\r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, 138, 87, 41, 140, 88, -1, -1, -1, 11, \r\n    -1, -1, -1, 53, -1, -1, -1, -1, 54, -1, 111, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, 110, -1, -1, -1, 106, -1, -1, -1, -1, -1, -1, 24, -1, 86, -1, \r\n    -1, -1, 81, -1, -1, -1, -1, -1, 119, -1, -1, 14, -1, -1, -1, 92, -1, -1, -1, \r\n    -1, -1, 77, 89, 10, 23, -1, -1, 91, 65, -1, 122, -1, -1, -1, 36, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, 124, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, 46, -1, 27, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, 120, -1, 100, 2, -1, -1, -1, -1, 75, 7, -1, -1, \r\n    -1, -1, -1, -1, -1, 108, 99, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, 137, -1, -1, -1, -1, -1, -1, -1, -1, 50, 30, -1, \r\n    -1, -1, -1, 83, 116, -1, -1, 134, -1, -1, 69, -1, -1, -1, 109, -1, 76, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 142, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, 85, -1, -1, -1, 127, -1, -1, 102, 48, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, 90, -1, -1, -1, -1, -1, -1, -1, -1, 74, -1, -1, -1, -1, 133, \r\n    -1, 57, 113, -1, -1, -1, -1, -1, -1, 43, -1, 33, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, 126, -1, 132, -1, -1, -1, -1, -1, -1, -1, 80, -1, -1, -1, \r\n    58, -1, -1, -1, -1, -1, -1, 6, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 78, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, 125, -1, -1, -1, -1, -1, 98, -1, 49, \r\n    123, -1, -1, -1, -1, -1, -1, -1, -1, 38, -1, -1, -1, -1, -1, 15, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, 103, -1, -1, -1, -1, -1, 5, 82, -1, -1, -1, -1, -1, 35, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 29, -1, -1, -1, -1, -1, -1, 72, \r\n    -1, -1, -1, -1, -1, -1, -1, 19, 63, -1, 52, -1, -1, -1, -1, -1, 34, -1, -1, \r\n    -1, -1, -1, -1, -1, 13, -1, -1, -1, 105, -1, -1, -1, -1, -1, -1, 39, -1, -1, \r\n    -1, 118, -1, -1, -1, -1, -1, 121, 3, 115, -1, -1, 64, -1, -1, 60, -1, 114, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 47, -1, -1, -1, -1, -1, 20, -1, -1, \r\n    62, -1, -1, -1, -1, -1, -1, -1, -1, -1, 135, -1, -1, -1, -1, 22, -1, -1, -1, \r\n    -1, -1, 55, -1, 68, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 17, 94, 112, -1, \r\n    -1, -1, -1, 59, -1, -1, 21, -1, -1, 66, -1, -1, -1, -1, -1, 107, 28, -1, -1, \r\n    -1, -1, -1, -1, -1, 96, -1, -1, -1, 56, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 93, -1, -1, \r\n    -1, -1, 9, -1, -1, -1, -1, 104, -1, -1, -1, 42, -1, -1, -1, -1, 79, 18, 70, \r\n    -1, 26, 25, 32, -1, -1, 0, 37, -1, 40, -1, -1, -1, -1, 73, -1, 97, -1, -1, \r\n    -1, 67, 128, -1, -1, -1, -1, -1, -1, 136, 16, 12, -1, -1, -1, -1, -1, -1, \r\n    131, 117, -1, -1, -1, -1, -1, -1, 45, -1, -1, -1, -1, -1, -1, 51, -1, 1, -1, \r\n    -1, -1, -1, -1, 141, -1, 129, -1, 44, -1, -1, 71, -1, 61, -1, -1, -1, -1, \r\n    -1, -1, -1, 101, -1, -1, -1, -1, 4, -1, -1, -1, -1, -1, -1, -1, -1, -1, 130, \r\n    139, -1, -1, -1, -1, -1, 95, -1, -1, -1, 31, -1, -1, 84, 8 \r\n  );\r\n\r\n{$Q-}\r\nfunction TSynCACSyn.HashKey(Str: PWideChar): Cardinal;\r\nbegin\r\n  Result := 0;\r\n  while IsIdentChar(Str^) do\r\n  begin\r\n    Result := Result * 123 + Ord(Str^) * 763;\r\n    inc(Str);\r\n  end;\r\n  Result := Result mod 709;\r\n  fStringLen := Str - fToIdent;\r\nend;\r\n{$Q+}\r\n\r\nfunction TSynCACSyn.IdentKind(MayBe: PWideChar): TtkTokenKind;\r\nvar\r\n  Key: Cardinal;\r\nbegin\r\n  fToIdent := MayBe;\r\n  Key := HashKey(MayBe);\r\n  if Key <= High(fIdentFuncTable) then\r\n    Result := fIdentFuncTable[Key](KeyIndices[Key])\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nprocedure TSynCACSyn.InitIdent;\r\nvar\r\n  i: Integer;\r\nbegin\r\n  for i := Low(fIdentFuncTable) to High(fIdentFuncTable) do\r\n    if KeyIndices[i] = -1 then\r\n      fIdentFuncTable[i] := AltFunc;\r\n\r\n  for i := Low(fIdentFuncTable) to High(fIdentFuncTable) do\r\n    if @fIdentFuncTable[i] = nil then\r\n      fIdentFuncTable[i] := KeyWordFunc;  \r\nend;\r\n\r\nfunction TSynCACSyn.AltFunc(Index: Integer): TtkTokenKind;\r\nbegin\r\n  Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynCACSyn.KeyWordFunc(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nconstructor TSynCACSyn.Create(AOwner: TComponent);\r\nbegin\r\n  inherited Create(AOwner);\r\n\r\n  fCaseSensitive := False;\r\n\r\n  fCommentAttri := TSynHighlighterAttributes.Create(SYNS_AttrComment, SYNS_FriendlyAttrComment);\r\n  fCommentAttri.Style := [fsItalic];\r\n  AddAttribute(fCommentAttri);\r\n  fIdentifierAttri := TSynHighlighterAttributes.Create(SYNS_AttrIdentifier, SYNS_FriendlyAttrIdentifier);\r\n  AddAttribute(fIdentifierAttri);\r\n  fKeyAttri := TSynHighlighterAttributes.Create(SYNS_AttrReservedWord, SYNS_FriendlyAttrReservedWord);\r\n  fKeyAttri.Style := [fsBold];\r\n  AddAttribute(fKeyAttri);\r\n  fNumberAttri := TSynHighlighterAttributes.Create(SYNS_AttrNumber, SYNS_FriendlyAttrNumber);\r\n  AddAttribute(fNumberAttri);\r\n  fSpaceAttri := TSynHighlighterAttributes.Create(SYNS_AttrSpace, SYNS_FriendlyAttrSpace);\r\n  AddAttribute(fSpaceAttri);\r\n  fStringAttri := TSynHighlighterAttributes.Create(SYNS_AttrString, SYNS_FriendlyAttrString);\r\n  AddAttribute(fStringAttri);\r\n  fOperatorAttri := TSynHighlighterAttributes.Create(SYNS_AttrOperator, SYNS_FriendlyAttrOperator);\r\n  AddAttribute(fOperatorAttri);\r\n  fDirecAttri := TSynHighlighterAttributes.Create(SYNS_AttrPreprocessor, SYNS_FriendlyAttrPreprocessor);\r\n  AddAttribute(fDirecAttri);\r\n  InitIdent;\r\n  SetAttributesOnChange(DefHighlightChange);\r\n  fRange := rsUnknown;\r\n  fDefaultFilter := SYNS_FilterCAClipper;\r\nend;\r\n\r\nprocedure TSynCACSyn.CStyleProc;\r\nbegin\r\n  fTokenID := tkComment;\r\n  case FLine[Run] of\r\n    #0:\r\n      begin\r\n        NullProc;\r\n        exit;\r\n      end;\r\n    #10:\r\n      begin\r\n        LFProc;\r\n        exit;\r\n      end;\r\n\r\n    #13:\r\n      begin\r\n        CRProc;\r\n        exit;\r\n      end;\r\n  end;\r\n\r\n  while fLine[Run] <> #0 do\r\n    case fLine[Run] of\r\n      '*':\r\n        if fLine[Run + 1] = '/' then\r\n        begin\r\n          fRange := rsUnknown;\r\n          inc(Run, 2);\r\n          break;\r\n        end else inc(Run);\r\n      #10: break;\r\n      #13: break;\r\n    else inc(Run);\r\n    end;\r\nend;\r\n\r\nprocedure TSynCACSyn.CRProc;\r\nbegin\r\n  fTokenID := tkSpace;\r\n  case FLine[Run + 1] of\r\n    #10: inc(Run, 2);\r\n  else inc(Run);\r\n  end;\r\nend;\r\n\r\nprocedure TSynCACSyn.IdentProc;\r\nbegin\r\n  fTokenID := IdentKind((fLine + Run));\r\n  inc(Run, fStringLen);\r\n  while IsIdentChar(fLine[Run]) do inc(Run);\r\nend;\r\n\r\nprocedure TSynCACSyn.LFProc;\r\nbegin\r\n  fTokenID := tkSpace;\r\n  inc(Run);\r\nend;\r\n\r\nprocedure TSynCACSyn.NullProc;\r\nbegin\r\n  fTokenID := tkNull;\r\n  inc(Run);\r\nend;\r\n\r\nprocedure TSynCACSyn.NumberProc;\r\n\r\n  function IsNumberChar: Boolean;\r\n  begin\r\n    case fLine[Run] of\r\n      '0'..'9', '.', 'e', 'E':\r\n        Result := True;\r\n      else\r\n        Result := False;\r\n    end;\r\n  end;\r\n\r\nbegin\r\n  inc(Run);\r\n  fTokenID := tkNumber;\r\n  while IsNumberChar do\r\n  begin\r\n    case FLine[Run] of\r\n      '.':\r\n        if FLine[Run + 1] = '.' then break;\r\n    end;\r\n    inc(Run);\r\n  end;\r\nend;\r\n\r\nprocedure TSynCACSyn.SlashProc;\r\nbegin\r\n  case FLine[Run + 1] of\r\n    '/':\r\n      begin\r\n        inc(Run, 2);\r\n        fTokenID := tkComment;\r\n        while FLine[Run] <> #0 do\r\n        begin\r\n          case FLine[Run] of\r\n            #10, #13: break;\r\n          end;\r\n          inc(Run);\r\n        end;\r\n      end;\r\n    '*':\r\n      begin\r\n        fTokenID := tkComment;\r\n        fRange := rsCStyle;\r\n        inc(Run, 2);\r\n        while fLine[Run] <> #0 do\r\n          case fLine[Run] of\r\n            '*':\r\n              if fLine[Run + 1] = '/' then\r\n              begin\r\n                fRange := rsUnknown;\r\n                inc(Run, 2);\r\n                break;\r\n              end else inc(Run);\r\n            #10: break;\r\n            #13: break;\r\n          else inc(Run);\r\n          end;\r\n      end;\r\n  else\r\n    begin\r\n      inc(Run);\r\n      fTokenID := tkOperator;\r\n    end;\r\n  end;\r\nend;\r\n\r\nprocedure TSynCACSyn.SpaceProc;\r\nbegin\r\n  inc(Run);\r\n  fTokenID := tkSpace;\r\n  while (FLine[Run] <= #32) and not IsLineEnd(Run) do inc(Run);\r\nend;\r\n\r\nprocedure TSynCACSyn.SymbolProc;\r\nbegin\r\n  inc(Run);\r\n  fTokenID := tkOperator;\r\nend;\r\n\r\nprocedure TSynCACSyn.StringProc;\r\nvar\r\n  ActiveStr: WideChar;\r\nbegin\r\n  fTokenID := tkString;\r\n  ActiveStr := FLine[Run];\r\n  if ((FLine[Run + 1] = #39) and (FLine[Run + 2] = #39)) or\r\n    ((FLine[Run + 1] = #34) and (FLine[Run + 2] = #34)) then inc(Run, 2);\r\n  repeat\r\n    case FLine[Run] of\r\n      #0, #10, #13: break;\r\n    end;\r\n    inc(Run);\r\n  until (FLine[Run] = ActiveStr);\r\n  if FLine[Run] <> #0 then inc(Run);\r\nend;\r\n\r\nprocedure TSynCACSyn.DirectiveProc;\r\nbegin\r\n  fTokenID := tkDirective;\r\n  repeat\r\n    case FLine[Run] of\r\n      #0, #10, #13: break;\r\n      '/': if FLine[Run + 1] = '/' then break;\r\n      #34, #39: break;\r\n    end;\r\n    inc(Run);\r\n  until FLine[Run] = #0;\r\nend;\r\n\r\nprocedure TSynCACSyn.UnknownProc;\r\nbegin\r\n  inc(Run);\r\n  fTokenID := tkUnknown;\r\nend;\r\n\r\nprocedure TSynCACSyn.Next;\r\nbegin\r\n  fTokenPos := Run;\r\n  case fRange of\r\n    rsCStyle: CStyleProc;\r\n    else\r\n      case fLine[Run] of\r\n        '@': SymbolProc;\r\n        '&': SymbolProc;\r\n        '{': SymbolProc;\r\n        '}': SymbolProc;\r\n        #13: CRProc;\r\n        ':': SymbolProc;\r\n        ',': SymbolProc;\r\n        '#': DirectiveProc;\r\n        '=': SymbolProc;\r\n        '>': SymbolProc;\r\n        'A'..'Z', 'a'..'z': IdentProc;\r\n        '$': SymbolProc;\r\n        #10: LFProc;\r\n        '<': SymbolProc;\r\n        '-': SymbolProc;\r\n        '!': SymbolProc;\r\n        #0: NullProc;\r\n        '0'..'9': NumberProc;\r\n        '+': SymbolProc;\r\n        '.': SymbolProc;\r\n        '?': SymbolProc;\r\n        ')': SymbolProc;\r\n        '(': SymbolProc;\r\n        ';': SymbolProc;\r\n        '/': SlashProc;\r\n        #1..#9, #11, #12, #14..#32: SpaceProc;\r\n        ']': SymbolProc;\r\n        '[': SymbolProc;\r\n        '*': StarProc;\r\n        #39, #34: StringProc;\r\n        else UnknownProc;\r\n      end;\r\n  end;\r\n  inherited;\r\nend;\r\n\r\nfunction TSynCACSyn.GetDefaultAttribute(Index: integer): TSynHighlighterAttributes;\r\nbegin\r\n  case Index of\r\n    SYN_ATTR_COMMENT: Result := fCommentAttri;\r\n    SYN_ATTR_IDENTIFIER: Result := fIdentifierAttri;\r\n    SYN_ATTR_KEYWORD: Result := fKeyAttri;\r\n    SYN_ATTR_STRING: Result := fStringAttri;\r\n    SYN_ATTR_WHITESPACE: Result := fSpaceAttri;\r\n  else\r\n    Result := nil;\r\n  end;\r\nend;\r\n\r\nfunction TSynCACSyn.GetEol: Boolean;\r\nbegin\r\n  Result := Run = fLineLen + 1;\r\nend;\r\n\r\nfunction TSynCACSyn.GetRange: Pointer;\r\nbegin\r\n  Result := Pointer(fRange);\r\nend;\r\n\r\nfunction TSynCACSyn.GetTokenID: TtkTokenKind;\r\nbegin\r\n  Result := fTokenId;\r\nend;\r\n\r\nfunction TSynCACSyn.GetTokenAttribute: TSynHighlighterAttributes;\r\nbegin\r\n  case fTokenID of\r\n    tkComment: Result := fCommentAttri;\r\n    tkIdentifier: Result := fIdentifierAttri;\r\n    tkKey: Result := fKeyAttri;\r\n    tkNumber: Result := fNumberAttri;\r\n    tkSpace: Result := fSpaceAttri;\r\n    tkString: Result := fStringAttri;\r\n    tkDirective: Result := fDirecAttri;\r\n    tkOperator: Result := fOperatorAttri;\r\n    tkUnknown: Result := fOperatorAttri;\r\n    else Result := nil;\r\n  end;\r\nend;\r\n\r\nfunction TSynCACSyn.GetTokenKind: integer;\r\nbegin\r\n  Result := Ord(fTokenId);\r\nend;\r\n\r\nprocedure TSynCACSyn.ResetRange;\r\nbegin\r\n  fRange := rsUnknown;\r\nend;\r\n\r\nprocedure TSynCACSyn.SetRange(Value: Pointer);\r\nbegin\r\n  fRange := TRangeState(Value);\r\nend;\r\n\r\nfunction TSynCACSyn.IsFilterStored: Boolean;\r\nbegin\r\n  Result := fDefaultFilter <> SYNS_FilterCAClipper;\r\nend;\r\n\r\nclass function TSynCACSyn.GetLanguageName: string;\r\nbegin\r\n  Result := SYNS_LangCAClipper;\r\nend;\r\n\r\nprocedure TSynCACSyn.StarProc;\r\nbegin\r\n// if Run is 0 there could be an access violation\r\n  if (Run = 0) or IsLineEnd(Run - 1) then\r\n  begin\r\n    fTokenID := tkComment;\r\n    repeat\r\n      Inc(Run);\r\n    until IsLineEnd(Run);\r\n  end\r\n  else\r\n  begin\r\n    inc(Run);\r\n    fTokenID := tkOperator;\r\n  end;\r\nend;\r\n\r\nclass function TSynCACSyn.GetFriendlyLanguageName: UnicodeString;\r\nbegin\r\n  Result := SYNS_FriendlyLangCAClipper;\r\nend;\r\n\r\ninitialization\r\n{$IFNDEF SYN_CPPB_1}\r\n  RegisterPlaceableHighlighter(TSynCACSyn);\r\n{$ENDIF}\r\nend.\r\n"
  },
  {
    "path": "External/SynEdit/Source/SynHighlighterCPM.pas",
    "content": "{-------------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: SynHighlighterCPM.pas, released 2001-08-14.\r\nThe Initial Author of this file is Pieter Polak.\r\nUnicode translation by Mal Hrz.\r\nAll Rights Reserved.\r\n\r\nContributors to the SynEdit and mwEdit projects are listed in the\r\nContributors.txt file.\r\n\r\nAlternatively, the contents of this file may be used under the terms of the\r\nGNU General Public License Version 2 or later (the \"GPL\"), in which case\r\nthe provisions of the GPL are applicable instead of those above.\r\nIf you wish to allow use of your version of this file only under the terms\r\nof the GPL and not to allow others to use your version of this file\r\nunder the MPL, indicate your decision by deleting the provisions above and\r\nreplace them with the notice and other provisions required by the GPL.\r\nIf you do not delete the provisions above, a recipient may use your version\r\nof this file under either the MPL or the GPL.\r\n\r\n$Id: SynHighlighterCPM.pas,v 1.16.2.6 2008/09/14 16:24:59 maelh Exp $\r\n\r\nYou may retrieve the latest version of this file at the SynEdit home page,\r\nlocated at http://SynEdit.SourceForge.net\r\n\r\n-------------------------------------------------------------------------------}\r\n\r\n{$IFNDEF QSYNHIGHLIGHTERCPM}\r\nunit SynHighlighterCPM;\r\n{$ENDIF}\r\n\r\n{$I SynEdit.inc}\r\n\r\ninterface\r\n\r\nuses\r\n{$IFDEF SYN_CLX}\r\n  QGraphics,\r\n  QSynEditTypes,\r\n  QSynEditHighlighter,\r\n  QSynUnicode,\r\n{$ELSE}\r\n  Graphics,\r\n  SynEditTypes,\r\n  SynEditHighlighter,\r\n  SynUnicode,\r\n{$ENDIF}\r\n  SysUtils,\r\n  Classes;\r\n\r\nType\r\n  TtkTokenKind = (\r\n    tkComment,\r\n    tkIdentifier,\r\n    tkKey,\r\n    tkNull,\r\n    tkSpace,\r\n    tkSQLKey,\r\n    tkString,\r\n    tkSymbol,\r\n    tkSpecialVar,\r\n    tkSystem,\r\n    tkVariable,\r\n    tkNumber,\r\n    tkUnknown);\r\n\r\n  PIdentFuncTableFunc = ^TIdentFuncTableFunc;\r\n  TIdentFuncTableFunc = function (Index: Integer): TtkTokenKind of object;\r\n\r\n  TRangeState = (rsBraceComment, rsUnKnown);\r\n\r\ntype\r\n  TSynCPMSyn = class(TSynCustomHighlighter)\r\n  private\r\n    fRange: TRangeState;\r\n    fCommentLevel: Integer;\r\n    fTokenID: TtkTokenKind;\r\n    fIdentFuncTable: array[0..796] of TIdentFuncTableFunc;\r\n    fCommentAttri: TSynHighlighterAttributes;\r\n    fIdentifierAttri: TSynHighlighterAttributes;\r\n    fKeyAttri: TSynHighlighterAttributes;\r\n    fNumberAttri: TSynHighlighterAttributes;\r\n    fSpaceAttri: TSynHighlighterAttributes;\r\n    fSQLKeyAttri: TSynHighlighterAttributes;\r\n    fStringAttri: TSynHighlighterAttributes;\r\n    fSymbolAttri: TSynHighlighterAttributes;\r\n    fSpecialVarAttri: TSynHighlighterAttributes;\r\n    fSystemAttri: TSynHighlighterAttributes;\r\n    fVariableAttri: TSynHighlighterAttributes;\r\n    function AltFunc(Index: Integer): TtkTokenKind;\r\n    function FuncAllentities(Index: Integer): TtkTokenKind;\r\n    function FuncAllproducts(Index: Integer): TtkTokenKind;\r\n    function FuncAllproperties(Index: Integer): TtkTokenKind;\r\n    function FuncAllqualityproperties(Index: Integer): TtkTokenKind;\r\n    function FuncAllsuppliers(Index: Integer): TtkTokenKind;\r\n    function FuncAssign(Index: Integer): TtkTokenKind;\r\n    function FuncBegin(Index: Integer): TtkTokenKind;\r\n    function FuncBlock(Index: Integer): TtkTokenKind;\r\n    function FuncCase(Index: Integer): TtkTokenKind;\r\n    function FuncCategory(Index: Integer): TtkTokenKind;\r\n    function FuncCenterstr(Index: Integer): TtkTokenKind;\r\n    function FuncCharreplacestr(Index: Integer): TtkTokenKind;\r\n    function FuncCharrlenstr(Index: Integer): TtkTokenKind;\r\n    function FuncCharrllenstr(Index: Integer): TtkTokenKind;\r\n    function FuncChr(Index: Integer): TtkTokenKind;\r\n    function FuncClient(Index: Integer): TtkTokenKind;\r\n    function FuncConstants(Index: Integer): TtkTokenKind;\r\n    function FuncContinue(Index: Integer): TtkTokenKind;\r\n    function FuncCopyfile(Index: Integer): TtkTokenKind;\r\n    function FuncCountry(Index: Integer): TtkTokenKind;\r\n    function FuncDecr(Index: Integer): TtkTokenKind;\r\n    function FuncDefinition(Index: Integer): TtkTokenKind;\r\n    function FuncDistinct_execute(Index: Integer): TtkTokenKind;\r\n    function FuncDivide(Index: Integer): TtkTokenKind;\r\n    function FuncElse(Index: Integer): TtkTokenKind;\r\n    function FuncEmptysheet(Index: Integer): TtkTokenKind;\r\n    function FuncEnd(Index: Integer): TtkTokenKind;\r\n    function FuncEntitycode(Index: Integer): TtkTokenKind;\r\n    function FuncEqualstring(Index: Integer): TtkTokenKind;\r\n    function FuncEqualvalue(Index: Integer): TtkTokenKind;\r\n    function FuncExecute(Index: Integer): TtkTokenKind;\r\n    function FuncFileappend(Index: Integer): TtkTokenKind;\r\n    function FuncFileassign(Index: Integer): TtkTokenKind;\r\n    function FuncFileclose(Index: Integer): TtkTokenKind;\r\n    function FuncFilecopy(Index: Integer): TtkTokenKind;\r\n    function FuncFiledate(Index: Integer): TtkTokenKind;\r\n    function FuncFiledelete(Index: Integer): TtkTokenKind;\r\n    function FuncFileend(Index: Integer): TtkTokenKind;\r\n    function FuncFileexists(Index: Integer): TtkTokenKind;\r\n    function FuncFilereadln(Index: Integer): TtkTokenKind;\r\n    function FuncFilereset(Index: Integer): TtkTokenKind;\r\n    function FuncFilerewrite(Index: Integer): TtkTokenKind;\r\n    function FuncFilesize(Index: Integer): TtkTokenKind;\r\n    function FuncFilesort(Index: Integer): TtkTokenKind;\r\n    function FuncFiletime(Index: Integer): TtkTokenKind;\r\n    function FuncFilewriteln(Index: Integer): TtkTokenKind;\r\n    function FuncFilterstr(Index: Integer): TtkTokenKind;\r\n    function FuncFirstinstance(Index: Integer): TtkTokenKind;\r\n    function FuncFlow(Index: Integer): TtkTokenKind;\r\n    function FuncFold(Index: Integer): TtkTokenKind;\r\n    function FuncForeign(Index: Integer): TtkTokenKind;\r\n    function FuncGlobalconstants(Index: Integer): TtkTokenKind;\r\n    function FuncGlobals(Index: Integer): TtkTokenKind;\r\n    function FuncGlobalvariables(Index: Integer): TtkTokenKind;\r\n    function FuncGroupdown(Index: Integer): TtkTokenKind;\r\n    function FuncGroupfooter(Index: Integer): TtkTokenKind;\r\n    function FuncGroupheader(Index: Integer): TtkTokenKind;\r\n    function FuncGroupkey(Index: Integer): TtkTokenKind;\r\n    function FuncGroupup(Index: Integer): TtkTokenKind;\r\n    function FuncIf(Index: Integer): TtkTokenKind;\r\n    function FuncInclude(Index: Integer): TtkTokenKind;\r\n    function FuncIncr(Index: Integer): TtkTokenKind;\r\n    function FuncLanguage(Index: Integer): TtkTokenKind;\r\n    function FuncLastinstance(Index: Integer): TtkTokenKind;\r\n    function FuncLeftstr(Index: Integer): TtkTokenKind;\r\n    function FuncLength(Index: Integer): TtkTokenKind;\r\n    function FuncLlenstr(Index: Integer): TtkTokenKind;\r\n    function FuncLocal(Index: Integer): TtkTokenKind;\r\n    function FuncLocasestr(Index: Integer): TtkTokenKind;\r\n    function FuncLoop(Index: Integer): TtkTokenKind;\r\n    function FuncLowerlevelstoo(Index: Integer): TtkTokenKind;\r\n    function FuncLtrunc(Index: Integer): TtkTokenKind;\r\n    function FuncMatching(Index: Integer): TtkTokenKind;\r\n    function FuncMember(Index: Integer): TtkTokenKind;\r\n    function FuncMerge(Index: Integer): TtkTokenKind;\r\n    function FuncMessagedlg(Index: Integer): TtkTokenKind;\r\n    function FuncMetaflow(Index: Integer): TtkTokenKind;\r\n    function FuncMidstr(Index: Integer): TtkTokenKind;\r\n    function FuncMultiply(Index: Integer): TtkTokenKind;\r\n    function FuncNextinstance(Index: Integer): TtkTokenKind;\r\n    function FuncNextrepeatinstance(Index: Integer): TtkTokenKind;\r\n    function FuncOf(Index: Integer): TtkTokenKind;\r\n    function FuncOptions(Index: Integer): TtkTokenKind;\r\n    function FuncOrganisation(Index: Integer): TtkTokenKind;\r\n    function FuncOutput(Index: Integer): TtkTokenKind;\r\n    function FuncParam(Index: Integer): TtkTokenKind;\r\n    function FuncParent(Index: Integer): TtkTokenKind;\r\n    function FuncParseinc(Index: Integer): TtkTokenKind;\r\n    function FuncPdriver(Index: Integer): TtkTokenKind;\r\n    function FuncPrevinstance(Index: Integer): TtkTokenKind;\r\n    function FuncPrevrepeatinstance(Index: Integer): TtkTokenKind;\r\n    function FuncPrinter(Index: Integer): TtkTokenKind;\r\n    function FuncPrintfile(Index: Integer): TtkTokenKind;\r\n    function FuncPropertygroup(Index: Integer): TtkTokenKind;\r\n    function FuncRastr(Index: Integer): TtkTokenKind;\r\n    function FuncRaval(Index: Integer): TtkTokenKind;\r\n    function FuncReadinstance(Index: Integer): TtkTokenKind;\r\n    function FuncReadrepeatinstance(Index: Integer): TtkTokenKind;\r\n    function FuncRepeat(Index: Integer): TtkTokenKind;\r\n    function FuncRepeatcount(Index: Integer): TtkTokenKind;\r\n    function FuncReportlevel(Index: Integer): TtkTokenKind;\r\n    function FuncRightstr(Index: Integer): TtkTokenKind;\r\n    function FuncRlenstr(Index: Integer): TtkTokenKind;\r\n    function FuncRoot(Index: Integer): TtkTokenKind;\r\n    function FuncRound(Index: Integer): TtkTokenKind;\r\n    function FuncShowmessage(Index: Integer): TtkTokenKind;\r\n    function FuncSkipemtpty(Index: Integer): TtkTokenKind;\r\n    function FuncSortdown(Index: Integer): TtkTokenKind;\r\n    function FuncSortkey(Index: Integer): TtkTokenKind;\r\n    function FuncSortup(Index: Integer): TtkTokenKind;\r\n    function FuncSql_add(Index: Integer): TtkTokenKind;\r\n    function FuncSql_asfloat(Index: Integer): TtkTokenKind;\r\n    function FuncSql_asstring(Index: Integer): TtkTokenKind;\r\n    function FuncSql_create(Index: Integer): TtkTokenKind;\r\n    function FuncSql_dump(Index: Integer): TtkTokenKind;\r\n    function FuncSql_eof(Index: Integer): TtkTokenKind;\r\n    function FuncSql_execute(Index: Integer): TtkTokenKind;\r\n    function FuncSql_free(Index: Integer): TtkTokenKind;\r\n    function FuncSql_mladd(Index: Integer): TtkTokenKind;\r\n    function FuncSql_mlmultiadd(Index: Integer): TtkTokenKind;\r\n    function FuncSql_next(Index: Integer): TtkTokenKind;\r\n    function FuncSql_setvar(Index: Integer): TtkTokenKind;\r\n    function FuncSqr(Index: Integer): TtkTokenKind;\r\n    function FuncStripstr(Index: Integer): TtkTokenKind;\r\n    function FuncStroptions(Index: Integer): TtkTokenKind;\r\n    function FuncStrpos(Index: Integer): TtkTokenKind;\r\n    function FuncSubtract(Index: Integer): TtkTokenKind;\r\n    function FuncSum(Index: Integer): TtkTokenKind;\r\n    function FuncSupplier(Index: Integer): TtkTokenKind;\r\n    function FuncSuppliesofmembers(Index: Integer): TtkTokenKind;\r\n    function FuncThen(Index: Integer): TtkTokenKind;\r\n    function FuncTrunc(Index: Integer): TtkTokenKind;\r\n    function FuncUpcasestr(Index: Integer): TtkTokenKind;\r\n    function FuncUsedby(Index: Integer): TtkTokenKind;\r\n    function FuncV_date(Index: Integer): TtkTokenKind;\r\n    function FuncV_false(Index: Integer): TtkTokenKind;\r\n    function FuncV_nonereal(Index: Integer): TtkTokenKind;\r\n    function FuncV_par_language(Index: Integer): TtkTokenKind;\r\n    function FuncV_par_language_count(Index: Integer): TtkTokenKind;\r\n    function FuncV_par_language_fields(Index: Integer): TtkTokenKind;\r\n    function FuncV_time(Index: Integer): TtkTokenKind;\r\n    function FuncV_true(Index: Integer): TtkTokenKind;\r\n    function FuncVariables(Index: Integer): TtkTokenKind;\r\n    function FuncVaroptions(Index: Integer): TtkTokenKind;\r\n    function FuncWhile(Index: Integer): TtkTokenKind;\r\n    function FuncZerorlenstr(Index: Integer): TtkTokenKind;\r\n    function HashKey(Str: PWideChar): Cardinal;\r\n    function IdentKind(MayBe: PWideChar): TtkTokenKind;\r\n    procedure InitIdent;\r\n    procedure CRProc;\r\n    procedure LFProc;\r\n    procedure SemiColonProc;\r\n    procedure SymbolProc;\r\n    procedure NumberProc;\r\n    procedure BraceOpenProc;\r\n    procedure IdentProc;\r\n    procedure VariableProc;\r\n    procedure NullProc;\r\n    procedure SpaceProc;\r\n    procedure StringProc;\r\n    procedure UnknownProc;\r\n    procedure BraceCommentProc;\r\n  protected\r\n    function GetSampleSource: UnicodeString; override;\r\n    function IsFilterStored: Boolean; override;\r\n  public\r\n    class function GetLanguageName: string; override;\r\n    class function GetFriendlyLanguageName: UnicodeString; override;\r\n  public\r\n    constructor Create(AOwner: TComponent); override;\r\n    function GetDefaultAttribute(Index: integer): TSynHighlighterAttributes;\r\n      override;\r\n    function GetEol: Boolean; override;\r\n    function GetTokenID: TtkTokenKind;\r\n    function GetTokenAttribute: TSynHighlighterAttributes; override;\r\n    function GetTokenKind: integer; override;\r\n    procedure Next; override;\r\n    function GetRange: Pointer; override;\r\n    procedure ResetRange; override;\r\n    procedure SetRange(Value: Pointer); override;\r\n  published\r\n    property CommentAttri: TSynHighlighterAttributes read fCommentAttri write fCommentAttri;\r\n    property IdentifierAttri: TSynHighlighterAttributes read fIdentifierAttri write fIdentifierAttri;\r\n    property KeyAttri: TSynHighlighterAttributes read fKeyAttri write fKeyAttri;\r\n    property NumberAttri: TSynHighlighterAttributes read fNumberAttri write fNumberAttri;\r\n    property SpaceAttri: TSynHighlighterAttributes read fSpaceAttri write fSpaceAttri;\r\n    property SQLKeyAttri: TSynHighlighterAttributes read fSQLKeyAttri write fSQLKeyAttri;\r\n    property StringAttri: TSynHighlighterAttributes read fStringAttri write fStringAttri;\r\n    property SymbolAttri: TSynHighlighterAttributes read fSymbolAttri write fSymbolAttri;\r\n    property SpecialVarAttri: TSynHighlighterAttributes read fSpecialVarAttri write fSpecialVarAttri;\r\n    property SystemAttri: TSynHighlighterAttributes read fSystemAttri write fSystemAttri;\r\n    property VariableAttri: TSynHighlighterAttributes read fVariableAttri write fVariableAttri;\r\n  end;\r\n\r\nimplementation\r\n\r\nuses\r\n{$IFDEF SYN_CLX}\r\n  QSynEditStrConst;\r\n{$ELSE}\r\n  SynEditStrConst;\r\n{$ENDIF}\r\n\r\nconst\r\n  KeyWords: array[0..145] of UnicodeString = (\r\n    'allentities', 'allproducts', 'allproperties', 'allqualityproperties', \r\n    'allsuppliers', 'assign', 'begin', 'block', 'case', 'category', 'centerstr', \r\n    'charreplacestr', 'charrlenstr', 'charrllenstr', 'chr', 'client', \r\n    'constants', 'continue', 'copyfile', 'country', 'decr', 'definition', \r\n    'distinct_execute', 'divide', 'else', 'emptysheet', 'end', 'entitycode', \r\n    'equalstring', 'equalvalue', 'execute', 'fileappend', 'fileassign', \r\n    'fileclose', 'filecopy', 'filedate', 'filedelete', 'fileend', 'fileexists', \r\n    'filereadln', 'filereset', 'filerewrite', 'filesize', 'filesort', \r\n    'filetime', 'filewriteln', 'filterstr', 'firstinstance', 'flow', 'fold', \r\n    'foreign', 'globalconstants', 'globals', 'globalvariables', 'groupdown', \r\n    'groupfooter', 'groupheader', 'groupkey', 'groupup', 'if', 'include', \r\n    'incr', 'language', 'lastinstance', 'leftstr', 'length', 'llenstr', 'local', \r\n    'locasestr', 'loop', 'lowerlevelstoo', 'ltrunc', 'matching', 'member', \r\n    'merge', 'messagedlg', 'metaflow', 'midstr', 'multiply', 'nextinstance', \r\n    'nextrepeatinstance', 'of', 'options', 'organisation', 'output', 'param', \r\n    'parent', 'parseinc', 'pdriver', 'previnstance', 'prevrepeatinstance', \r\n    'printer', 'printfile', 'propertygroup', 'rastr', 'raval', 'readinstance', \r\n    'readrepeatinstance', 'repeat', 'repeatcount', 'reportlevel', 'rightstr', \r\n    'rlenstr', 'root', 'round', 'showmessage', 'skipemtpty', 'sortdown', \r\n    'sortkey', 'sortup', 'sql_add', 'sql_asfloat', 'sql_asstring', 'sql_create', \r\n    'sql_dump', 'sql_eof', 'sql_execute', 'sql_free', 'sql_mladd', \r\n    'sql_mlmultiadd', 'sql_next', 'sql_setvar', 'sqr', 'stripstr', 'stroptions', \r\n    'strpos', 'subtract', 'sum', 'supplier', 'suppliesofmembers', 'then', \r\n    'trunc', 'upcasestr', 'usedby', 'v_date', 'v_false', 'v_nonereal', \r\n    'v_par_language', 'v_par_language_count', 'v_par_language_fields', 'v_time', \r\n    'v_true', 'variables', 'varoptions', 'while', 'zerorlenstr' \r\n  );\r\n\r\n  KeyIndices: array[0..796] of Integer = (\r\n    -1, -1, -1, -1, -1, -1, -1, -1, 45, -1, 26, -1, -1, -1, -1, -1, 74, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, 25, 85, -1, -1, -1, 58, -1, 51, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, 4, 43, 30, -1, 54, 127, -1, -1, -1, 136, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, 56, 38, -1, 32, -1, -1, -1, -1, -1, -1, \r\n    -1, 133, 65, -1, 96, -1, -1, -1, 144, -1, -1, -1, -1, -1, -1, -1, -1, 89, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 10, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, 23, -1, -1, -1, 35, -1, -1, 5, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, 75, 41, -1, -1, 36, -1, -1, -1, -1, -1, -1, 143, -1, \r\n    -1, 105, -1, -1, -1, -1, -1, 86, 142, 99, -1, 131, -1, -1, -1, -1, -1, -1, \r\n    8, -1, -1, -1, -1, 83, -1, -1, 67, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, 53, 27, -1, -1, -1, -1, -1, -1, 102, -1, -1, \r\n    -1, -1, -1, -1, -1, 2, -1, -1, 28, -1, 24, 141, -1, -1, 101, -1, -1, 134, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, 111, -1, 100, -1, 15, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, 44, 135, -1, 117, -1, 77, -1, 37, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, 69, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 42, 7, -1, \r\n    109, -1, -1, -1, -1, -1, -1, -1, 107, -1, -1, -1, 113, -1, -1, 0, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, 13, -1, 73, 34, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, 132, -1, -1, -1, 123, -1, -1, -1, -1, -1, \r\n    63, -1, 48, -1, -1, -1, -1, -1, -1, -1, -1, -1, 140, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, 66, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 84, -1, \r\n    -1, -1, -1, 95, -1, -1, -1, -1, -1, -1, -1, 71, 138, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, 93, 110, -1, -1, 80, -1, -1, 137, -1, -1, -1, 91, -1, 60, -1, \r\n    -1, 62, -1, -1, -1, -1, -1, -1, -1, -1, -1, 82, -1, -1, -1, -1, -1, 29, -1, \r\n    -1, 122, -1, -1, -1, -1, 39, -1, 61, -1, -1, -1, -1, -1, 6, -1, -1, -1, -1, \r\n    -1, -1, 22, 130, -1, -1, -1, -1, -1, 81, -1, 57, -1, -1, 20, 121, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 94, -1, 31, -1, -1, -1, -1, \r\n    -1, 47, -1, -1, 108, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 33, -1, \r\n    -1, -1, 64, -1, -1, 1, -1, 118, -1, -1, -1, -1, -1, -1, 87, 49, -1, -1, -1, \r\n    -1, -1, 79, -1, -1, -1, -1, -1, -1, 119, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    46, -1, -1, -1, -1, 125, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    106, -1, 97, -1, 68, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, 40, -1, -1, 72, 70, 88, -1, 12, -1, -1, -1, -1, -1, -1, -1, 124, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 114, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 92, \r\n    -1, -1, 59, -1, -1, -1, -1, -1, 11, -1, -1, 104, -1, -1, -1, -1, -1, -1, -1, \r\n    18, 78, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, 17, -1, 129, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, 112, -1, -1, 98, -1, 116, 120, -1, 21, -1, 9, -1, \r\n    -1, -1, 19, -1, -1, -1, 50, -1, -1, -1, 126, -1, -1, 55, -1, 145, -1, -1, \r\n    -1, -1, 52, 139, -1, 14, -1, -1, 115, -1, -1, -1, 90, -1, -1, -1, 128, -1, \r\n    -1, -1, 103, -1, -1, -1, -1, -1, 3, -1, -1, 76, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, 16, -1, -1, -1 \r\n  );\r\n\r\n{$Q-}\r\nfunction TSynCPMSyn.HashKey(Str: PWideChar): Cardinal;\r\nbegin\r\n  Result := 0;\r\n  while IsIdentChar(Str^) do\r\n  begin\r\n    Result := Result * 841 + Ord(Str^) * 268;\r\n    inc(Str);\r\n  end;\r\n  Result := Result mod 797;\r\n  fStringLen := Str - fToIdent;\r\nend;\r\n{$Q+}\r\n\r\nfunction TSynCPMSyn.IdentKind(MayBe: PWideChar): TtkTokenKind;\r\nvar\r\n  Key: Cardinal;\r\nbegin\r\n  fToIdent := MayBe;\r\n  Key := HashKey(MayBe);\r\n  if Key <= High(fIdentFuncTable) then\r\n    Result := fIdentFuncTable[Key](KeyIndices[Key])\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nprocedure TSynCPMSyn.InitIdent;\r\nvar\r\n  i: Integer;\r\nbegin\r\n  for i := Low(fIdentFuncTable) to High(fIdentFuncTable) do\r\n    if KeyIndices[i] = -1 then\r\n      fIdentFuncTable[i] := AltFunc;\r\n\r\n  fIdentFuncTable[314] := FuncAllentities;\r\n  fIdentFuncTable[528] := FuncAllproducts;\r\n  fIdentFuncTable[212] := FuncAllproperties;\r\n  fIdentFuncTable[774] := FuncAllqualityproperties;\r\n  fIdentFuncTable[46] := FuncAllsuppliers;\r\n  fIdentFuncTable[127] := FuncAssign;\r\n  fIdentFuncTable[462] := FuncBegin;\r\n  fIdentFuncTable[297] := FuncBlock;\r\n  fIdentFuncTable[169] := FuncCase;\r\n  fIdentFuncTable[728] := FuncCategory;\r\n  fIdentFuncTable[106] := FuncCenterstr;\r\n  fIdentFuncTable[663] := FuncCharreplacestr;\r\n  fIdentFuncTable[607] := FuncCharrlenstr;\r\n  fIdentFuncTable[326] := FuncCharrllenstr;\r\n  fIdentFuncTable[753] := FuncChr;\r\n  fIdentFuncTable[251] := FuncClient;\r\n  fIdentFuncTable[793] := FuncConstants;\r\n  fIdentFuncTable[694] := FuncContinue;\r\n  fIdentFuncTable[674] := FuncCopyfile;\r\n  fIdentFuncTable[732] := FuncCountry;\r\n  fIdentFuncTable[481] := FuncDecr;\r\n  fIdentFuncTable[726] := FuncDefinition;\r\n  fIdentFuncTable[469] := FuncDistinct_execute;\r\n  fIdentFuncTable[120] := FuncDivide;\r\n  fIdentFuncTable[217] := FuncElse;\r\n  fIdentFuncTable[26] := FuncEmptysheet;\r\n  fIdentFuncTable[10] := FuncEnd;\r\n  fIdentFuncTable[197] := FuncEntitycode;\r\n  fIdentFuncTable[215] := FuncEqualstring;\r\n  fIdentFuncTable[446] := FuncEqualvalue;\r\n  fIdentFuncTable[48] := FuncExecute;\r\n  fIdentFuncTable[499] := FuncFileappend;\r\n  fIdentFuncTable[69] := FuncFileassign;\r\n  fIdentFuncTable[521] := FuncFileclose;\r\n  fIdentFuncTable[329] := FuncFilecopy;\r\n  fIdentFuncTable[124] := FuncFiledate;\r\n  fIdentFuncTable[142] := FuncFiledelete;\r\n  fIdentFuncTable[273] := FuncFileend;\r\n  fIdentFuncTable[67] := FuncFileexists;\r\n  fIdentFuncTable[454] := FuncFilereadln;\r\n  fIdentFuncTable[600] := FuncFilereset;\r\n  fIdentFuncTable[139] := FuncFilerewrite;\r\n  fIdentFuncTable[296] := FuncFilesize;\r\n  fIdentFuncTable[47] := FuncFilesort;\r\n  fIdentFuncTable[266] := FuncFiletime;\r\n  fIdentFuncTable[8] := FuncFilewriteln;\r\n  fIdentFuncTable[561] := FuncFilterstr;\r\n  fIdentFuncTable[505] := FuncFirstinstance;\r\n  fIdentFuncTable[356] := FuncFlow;\r\n  fIdentFuncTable[538] := FuncFold;\r\n  fIdentFuncTable[736] := FuncForeign;\r\n  fIdentFuncTable[33] := FuncGlobalconstants;\r\n  fIdentFuncTable[750] := FuncGlobals;\r\n  fIdentFuncTable[196] := FuncGlobalvariables;\r\n  fIdentFuncTable[50] := FuncGroupdown;\r\n  fIdentFuncTable[743] := FuncGroupfooter;\r\n  fIdentFuncTable[66] := FuncGroupheader;\r\n  fIdentFuncTable[478] := FuncGroupkey;\r\n  fIdentFuncTable[31] := FuncGroupup;\r\n  fIdentFuncTable[657] := FuncIf;\r\n  fIdentFuncTable[427] := FuncInclude;\r\n  fIdentFuncTable[456] := FuncIncr;\r\n  fIdentFuncTable[430] := FuncLanguage;\r\n  fIdentFuncTable[354] := FuncLastinstance;\r\n  fIdentFuncTable[525] := FuncLeftstr;\r\n  fIdentFuncTable[78] := FuncLength;\r\n  fIdentFuncTable[379] := FuncLlenstr;\r\n  fIdentFuncTable[177] := FuncLocal;\r\n  fIdentFuncTable[583] := FuncLocasestr;\r\n  fIdentFuncTable[285] := FuncLoop;\r\n  fIdentFuncTable[604] := FuncLowerlevelstoo;\r\n  fIdentFuncTable[403] := FuncLtrunc;\r\n  fIdentFuncTable[603] := FuncMatching;\r\n  fIdentFuncTable[328] := FuncMember;\r\n  fIdentFuncTable[16] := FuncMerge;\r\n  fIdentFuncTable[138] := FuncMessagedlg;\r\n  fIdentFuncTable[777] := FuncMetaflow;\r\n  fIdentFuncTable[271] := FuncMidstr;\r\n  fIdentFuncTable[675] := FuncMultiply;\r\n  fIdentFuncTable[544] := FuncNextinstance;\r\n  fIdentFuncTable[418] := FuncNextrepeatinstance;\r\n  fIdentFuncTable[476] := FuncOf;\r\n  fIdentFuncTable[440] := FuncOptions;\r\n  fIdentFuncTable[174] := FuncOrganisation;\r\n  fIdentFuncTable[390] := FuncOutput;\r\n  fIdentFuncTable[27] := FuncParam;\r\n  fIdentFuncTable[158] := FuncParent;\r\n  fIdentFuncTable[537] := FuncParseinc;\r\n  fIdentFuncTable[605] := FuncPdriver;\r\n  fIdentFuncTable[93] := FuncPrevinstance;\r\n  fIdentFuncTable[760] := FuncPrevrepeatinstance;\r\n  fIdentFuncTable[425] := FuncPrinter;\r\n  fIdentFuncTable[654] := FuncPrintfile;\r\n  fIdentFuncTable[414] := FuncPropertygroup;\r\n  fIdentFuncTable[497] := FuncRastr;\r\n  fIdentFuncTable[395] := FuncRaval;\r\n  fIdentFuncTable[80] := FuncReadinstance;\r\n  fIdentFuncTable[581] := FuncReadrepeatinstance;\r\n  fIdentFuncTable[721] := FuncRepeat;\r\n  fIdentFuncTable[160] := FuncRepeatcount;\r\n  fIdentFuncTable[249] := FuncReportlevel;\r\n  fIdentFuncTable[221] := FuncRightstr;\r\n  fIdentFuncTable[204] := FuncRlenstr;\r\n  fIdentFuncTable[768] := FuncRoot;\r\n  fIdentFuncTable[666] := FuncRound;\r\n  fIdentFuncTable[152] := FuncShowmessage;\r\n  fIdentFuncTable[579] := FuncSkipemtpty;\r\n  fIdentFuncTable[307] := FuncSortdown;\r\n  fIdentFuncTable[508] := FuncSortkey;\r\n  fIdentFuncTable[299] := FuncSortup;\r\n  fIdentFuncTable[415] := FuncSql_add;\r\n  fIdentFuncTable[247] := FuncSql_asfloat;\r\n  fIdentFuncTable[718] := FuncSql_asstring;\r\n  fIdentFuncTable[311] := FuncSql_create;\r\n  fIdentFuncTable[635] := FuncSql_dump;\r\n  fIdentFuncTable[756] := FuncSql_eof;\r\n  fIdentFuncTable[723] := FuncSql_execute;\r\n  fIdentFuncTable[269] := FuncSql_free;\r\n  fIdentFuncTable[530] := FuncSql_mladd;\r\n  fIdentFuncTable[551] := FuncSql_mlmultiadd;\r\n  fIdentFuncTable[724] := FuncSql_next;\r\n  fIdentFuncTable[482] := FuncSql_setvar;\r\n  fIdentFuncTable[449] := FuncSqr;\r\n  fIdentFuncTable[348] := FuncStripstr;\r\n  fIdentFuncTable[615] := FuncStroptions;\r\n  fIdentFuncTable[566] := FuncStrpos;\r\n  fIdentFuncTable[740] := FuncSubtract;\r\n  fIdentFuncTable[51] := FuncSum;\r\n  fIdentFuncTable[764] := FuncSupplier;\r\n  fIdentFuncTable[696] := FuncSuppliesofmembers;\r\n  fIdentFuncTable[470] := FuncThen;\r\n  fIdentFuncTable[162] := FuncTrunc;\r\n  fIdentFuncTable[344] := FuncUpcasestr;\r\n  fIdentFuncTable[77] := FuncUsedby;\r\n  fIdentFuncTable[224] := FuncV_date;\r\n  fIdentFuncTable[267] := FuncV_false;\r\n  fIdentFuncTable[55] := FuncV_nonereal;\r\n  fIdentFuncTable[421] := FuncV_par_language;\r\n  fIdentFuncTable[404] := FuncV_par_language_count;\r\n  fIdentFuncTable[751] := FuncV_par_language_fields;\r\n  fIdentFuncTable[366] := FuncV_time;\r\n  fIdentFuncTable[218] := FuncV_true;\r\n  fIdentFuncTable[159] := FuncVariables;\r\n  fIdentFuncTable[149] := FuncVaroptions;\r\n  fIdentFuncTable[84] := FuncWhile;\r\n  fIdentFuncTable[745] := FuncZerorlenstr;\r\nend;\r\n\r\nfunction TSynCPMSyn.AltFunc(Index: Integer): TtkTokenKind;\r\nbegin\r\n  Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynCPMSyn.FuncAllentities(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynCPMSyn.FuncAllproducts(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynCPMSyn.FuncAllproperties(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynCPMSyn.FuncAllqualityproperties(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynCPMSyn.FuncAllsuppliers(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynCPMSyn.FuncAssign(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkSystem\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynCPMSyn.FuncBegin(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynCPMSyn.FuncBlock(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynCPMSyn.FuncCase(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynCPMSyn.FuncCategory(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynCPMSyn.FuncCenterstr(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkSystem\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynCPMSyn.FuncCharreplacestr(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkSystem\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynCPMSyn.FuncCharrlenstr(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkSystem\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynCPMSyn.FuncCharrllenstr(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkSystem\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynCPMSyn.FuncChr(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkSystem\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynCPMSyn.FuncClient(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynCPMSyn.FuncConstants(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynCPMSyn.FuncContinue(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynCPMSyn.FuncCopyfile(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkSystem\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynCPMSyn.FuncCountry(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynCPMSyn.FuncDecr(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkSystem\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynCPMSyn.FuncDefinition(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynCPMSyn.FuncDistinct_execute(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynCPMSyn.FuncDivide(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkSystem\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynCPMSyn.FuncElse(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynCPMSyn.FuncEmptysheet(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynCPMSyn.FuncEnd(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynCPMSyn.FuncEntitycode(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynCPMSyn.FuncEqualstring(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkSystem\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynCPMSyn.FuncEqualvalue(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkSystem\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynCPMSyn.FuncExecute(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynCPMSyn.FuncFileappend(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkSystem\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynCPMSyn.FuncFileassign(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkSystem\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynCPMSyn.FuncFileclose(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkSystem\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynCPMSyn.FuncFilecopy(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkSystem\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynCPMSyn.FuncFiledate(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkSystem\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynCPMSyn.FuncFiledelete(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkSystem\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynCPMSyn.FuncFileend(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkSystem\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynCPMSyn.FuncFileexists(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkSystem\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynCPMSyn.FuncFilereadln(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkSystem\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynCPMSyn.FuncFilereset(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkSystem\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynCPMSyn.FuncFilerewrite(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkSystem\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynCPMSyn.FuncFilesize(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkSystem\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynCPMSyn.FuncFilesort(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkSystem\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynCPMSyn.FuncFiletime(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkSystem\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynCPMSyn.FuncFilewriteln(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkSystem\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynCPMSyn.FuncFilterstr(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkSystem\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynCPMSyn.FuncFirstinstance(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkSystem\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynCPMSyn.FuncFlow(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynCPMSyn.FuncFold(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynCPMSyn.FuncForeign(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkSystem\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynCPMSyn.FuncGlobalconstants(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynCPMSyn.FuncGlobals(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynCPMSyn.FuncGlobalvariables(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynCPMSyn.FuncGroupdown(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynCPMSyn.FuncGroupfooter(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynCPMSyn.FuncGroupheader(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynCPMSyn.FuncGroupkey(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynCPMSyn.FuncGroupup(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynCPMSyn.FuncIf(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynCPMSyn.FuncInclude(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynCPMSyn.FuncIncr(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkSystem\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynCPMSyn.FuncLanguage(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynCPMSyn.FuncLastinstance(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkSystem\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynCPMSyn.FuncLeftstr(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkSystem\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynCPMSyn.FuncLength(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkSystem\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynCPMSyn.FuncLlenstr(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkSystem\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynCPMSyn.FuncLocal(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkSystem\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynCPMSyn.FuncLocasestr(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkSystem\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynCPMSyn.FuncLoop(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynCPMSyn.FuncLowerlevelstoo(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynCPMSyn.FuncLtrunc(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkSystem\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynCPMSyn.FuncMatching(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynCPMSyn.FuncMember(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynCPMSyn.FuncMerge(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynCPMSyn.FuncMessagedlg(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkSystem\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynCPMSyn.FuncMetaflow(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynCPMSyn.FuncMidstr(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkSystem\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynCPMSyn.FuncMultiply(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkSystem\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynCPMSyn.FuncNextinstance(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkSystem\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynCPMSyn.FuncNextrepeatinstance(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkSystem\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynCPMSyn.FuncOf(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynCPMSyn.FuncOptions(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynCPMSyn.FuncOrganisation(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynCPMSyn.FuncOutput(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynCPMSyn.FuncParam(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynCPMSyn.FuncParent(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynCPMSyn.FuncParseinc(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynCPMSyn.FuncPdriver(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynCPMSyn.FuncPrevinstance(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkSystem\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynCPMSyn.FuncPrevrepeatinstance(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkSystem\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynCPMSyn.FuncPrinter(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynCPMSyn.FuncPrintfile(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynCPMSyn.FuncPropertygroup(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynCPMSyn.FuncRastr(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkSystem\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynCPMSyn.FuncRaval(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkSystem\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynCPMSyn.FuncReadinstance(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkSystem\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynCPMSyn.FuncReadrepeatinstance(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkSystem\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynCPMSyn.FuncRepeat(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynCPMSyn.FuncRepeatcount(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkSystem\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynCPMSyn.FuncReportlevel(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynCPMSyn.FuncRightstr(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkSystem\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynCPMSyn.FuncRlenstr(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkSystem\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynCPMSyn.FuncRoot(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkSystem\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynCPMSyn.FuncRound(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkSystem\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynCPMSyn.FuncShowmessage(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkSystem\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynCPMSyn.FuncSkipemtpty(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynCPMSyn.FuncSortdown(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynCPMSyn.FuncSortkey(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynCPMSyn.FuncSortup(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynCPMSyn.FuncSql_add(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkSQLKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynCPMSyn.FuncSql_asfloat(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkSQLKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynCPMSyn.FuncSql_asstring(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkSQLKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynCPMSyn.FuncSql_create(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkSQLKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynCPMSyn.FuncSql_dump(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkSQLKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynCPMSyn.FuncSql_eof(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkSQLKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynCPMSyn.FuncSql_execute(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkSQLKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynCPMSyn.FuncSql_free(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkSQLKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynCPMSyn.FuncSql_mladd(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkSQLKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynCPMSyn.FuncSql_mlmultiadd(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkSQLKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynCPMSyn.FuncSql_next(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkSQLKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynCPMSyn.FuncSql_setvar(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkSQLKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynCPMSyn.FuncSqr(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkSystem\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynCPMSyn.FuncStripstr(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkSystem\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynCPMSyn.FuncStroptions(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynCPMSyn.FuncStrpos(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkSystem\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynCPMSyn.FuncSubtract(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkSystem\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynCPMSyn.FuncSum(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkSystem\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynCPMSyn.FuncSupplier(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynCPMSyn.FuncSuppliesofmembers(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynCPMSyn.FuncThen(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynCPMSyn.FuncTrunc(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkSystem\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynCPMSyn.FuncUpcasestr(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkSystem\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynCPMSyn.FuncUsedby(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynCPMSyn.FuncV_date(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkSpecialVar\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynCPMSyn.FuncV_false(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkSpecialVar\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynCPMSyn.FuncV_nonereal(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkSpecialVar\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynCPMSyn.FuncV_par_language(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkSpecialVar\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynCPMSyn.FuncV_par_language_count(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkSpecialVar\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynCPMSyn.FuncV_par_language_fields(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkSpecialVar\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynCPMSyn.FuncV_time(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkSpecialVar\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynCPMSyn.FuncV_true(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkSpecialVar\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynCPMSyn.FuncVariables(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynCPMSyn.FuncVaroptions(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynCPMSyn.FuncWhile(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynCPMSyn.FuncZerorlenstr(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkSystem\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nconstructor TSynCPMSyn.Create(AOwner: TComponent);\r\nbegin\r\n  inherited Create(AOwner);\r\n\r\n  fCaseSensitive := False;\r\n\r\n  fCommentAttri := TSynHighLighterAttributes.Create(SYNS_AttrComment, SYNS_FriendlyAttrComment);\r\n  fCommentAttri.Foreground := clNavy;\r\n  fCommentAttri.Style := [fsItalic];\r\n  AddAttribute(fCommentAttri);\r\n\r\n  fIdentifierAttri := TSynHighLighterAttributes.Create(SYNS_AttrIdentifier, SYNS_FriendlyAttrIdentifier);\r\n  AddAttribute(fIdentifierAttri);\r\n\r\n  fKeyAttri := TSynHighLighterAttributes.Create(SYNS_AttrReservedWord, SYNS_FriendlyAttrReservedWord);\r\n  fKeyAttri.Foreground := clGreen;\r\n  fKeyAttri.Style := [fsBold];\r\n  AddAttribute(fKeyAttri);\r\n\r\n  fNumberAttri := TSynHighlighterAttributes.Create(SYNS_AttrNumber, SYNS_FriendlyAttrNumber);\r\n  AddAttribute(fNumberAttri);\r\n  \r\n  fSpaceAttri := TSynHighLighterAttributes.Create(SYNS_AttrSpace, SYNS_FriendlyAttrSpace);\r\n  AddAttribute(fSpaceAttri);\r\n\r\n  fSQLKeyAttri := TSynHighLighterAttributes.Create(SYNS_AttrSQLKey, SYNS_FriendlyAttrSQLKey);\r\n  fSQLKeyAttri.ForeGround := clTeal;\r\n  fSQLKeyAttri.Style := [fsBold];\r\n  AddAttribute(fSQLKeyAttri);\r\n\r\n  fStringAttri := TSynHighLighterAttributes.Create(SYNS_AttrString, SYNS_FriendlyAttrString);\r\n  AddAttribute(fStringAttri);\r\n\r\n  fSymbolAttri := TSynHighLighterAttributes.Create(SYNS_AttrSymbol, SYNS_FriendlyAttrSymbol);\r\n  AddAttribute(fSymbolAttri);\r\n\r\n  fSpecialVarAttri := TSynHighlighterAttributes.Create(SYNS_AttrSpecialVariable, SYNS_FriendlyAttrSpecialVariable);\r\n  fSpecialVarAttri.Style := [fsBold];\r\n  AddAttribute(fSpecialVarAttri);\r\n\r\n  fSystemAttri := TSynHighlighterAttributes.Create(SYNS_AttrSystem, SYNS_FriendlyAttrSystem);\r\n  fSystemAttri.Foreground := $000080FF;\r\n  fSystemAttri.Style := [fsBold];\r\n  AddAttribute(fSystemAttri);\r\n\r\n  fVariableAttri := TSynHighlighterAttributes.Create(SYNS_AttrVariable, SYNS_FriendlyAttrVariable);\r\n  fVariableAttri.Foreground := clMaroon;\r\n  AddAttribute(fVariableAttri);\r\n\r\n  SetAttributesOnChange(DefHighlightChange);\r\n  InitIdent;\r\n  fRange := rsUnknown;\r\n  fCommentLevel := 0;\r\n  fDefaultFilter := SYNS_FilterCPM;\r\nend; { Create }\r\n\r\nprocedure TSynCPMSyn.BraceOpenProc;\r\nbegin\r\n  fRange := rsBraceComment;\r\n  BraceCommentProc;\r\n  fTokenID := tkComment;\r\nend; { BraceOpenProc }\r\n\r\nprocedure TSynCPMSyn.IdentProc;\r\nbegin\r\n  fTokenID := IdentKind(fLine + Run);\r\n  inc(Run, fStringLen);\r\n  while IsIdentChar(fLine[Run]) do\r\n    Inc(Run);\r\nend; { IdentProc }\r\n\r\nprocedure TSynCPMSyn.VariableProc;\r\nbegin\r\n  fTokenID := IdentKind((fLine + Run));\r\n  if (fTokenID = tkIdentifier) then\r\n  begin\r\n    if (fLine[Run + 1] = '_') then\r\n      fTokenID := tkVariable\r\n  end;\r\n  inc(Run, fStringLen);\r\n  while IsIdentChar(fLine[Run]) do\r\n    Inc(Run);\r\nend; { VariableProc }\r\n\r\nprocedure TSynCPMSyn.NullProc;\r\nbegin\r\n  fTokenID := tkNull;\r\n  inc(Run);\r\nend; { NullProc }\r\n\r\nprocedure TSynCPMSyn.SpaceProc;\r\nbegin\r\n  inc(Run);\r\n  fTokenID := tkSpace;\r\n  while (FLine[Run] <= #32) and not IsLineEnd(Run) do inc(Run);\r\nend; { SpaceProc }\r\n\r\nprocedure TSynCPMSyn.StringProc;\r\nbegin\r\n  fTokenID := tkString;\r\n  repeat\r\n    Inc(Run);\r\n  until IsLineEnd(Run) or (fLine[Run] = '\"');\r\n  if (fLine[Run] = '\"') then\r\n  begin\r\n    Inc(Run);\r\n    if (fLine[Run] = '\"') then\r\n      Inc(Run);\r\n  end;\r\nend; { StringProc }\r\n\r\nprocedure TSynCPMSyn.UnknownProc;\r\nbegin\r\n  inc(Run);\r\n  fTokenID := tkUnknown;\r\nend; { UnknownProc }\r\n\r\nprocedure TSynCPMSyn.Next;\r\nbegin\r\n  fTokenPos := Run;\r\n  case fRange of\r\n    rsBraceComment: BraceCommentProc;\r\n  else\r\n    case fLine[Run] of\r\n      #0: NullProc;\r\n      #10: LFProc;\r\n      #13: CRProc;\r\n      #1..#9, #11, #12, #14..#32: SpaceProc;\r\n      '\"': StringProc;\r\n      '0'..'9': NumberProc;\r\n      'A'..'Z', 'a'..'z', '_':\r\n        case fLine[Run] of\r\n          'V', 'v', 'S', 's': VariableProc;\r\n          else\r\n            IdentProc;\r\n        end;\r\n      '{': BraceOpenProc;\r\n      '}', '!', '%', '&', '('..'/', ':'..'@', '['..'^', '`', '~':\r\n      begin\r\n        case fLine[Run] of\r\n          ';': SemiColonProc;\r\n          else\r\n            SymbolProc;\r\n        end;\r\n      end;\r\n    else\r\n      UnknownProc;\r\n    end;\r\n  end;\r\n  inherited;\r\nend; { Next }\r\n\r\nfunction TSynCPMSyn.GetDefaultAttribute(Index: integer): TSynHighLighterAttributes;\r\nbegin\r\n  case Index of\r\n    SYN_ATTR_COMMENT: Result := fCommentAttri;\r\n    SYN_ATTR_IDENTIFIER: Result := fIdentifierAttri;\r\n    SYN_ATTR_KEYWORD: Result := fKeyAttri;\r\n    SYN_ATTR_STRING: Result := fStringAttri;\r\n    SYN_ATTR_WHITESPACE: Result := fSpaceAttri;\r\n    SYN_ATTR_SYMBOL: Result := fSymbolAttri;\r\n    else\r\n      Result := nil;\r\n  end;\r\nend; { GetDefaultAttribute }\r\n\r\nfunction TSynCPMSyn.GetEol: Boolean;\r\nbegin\r\n  Result := Run = fLineLen + 1;\r\nend; { GetEol }\r\n\r\nfunction TSynCPMSyn.GetTokenID: TtkTokenKind;\r\nbegin\r\n  Result := fTokenId;\r\nend; { GetTokenID }\r\n\r\nfunction TSynCPMSyn.GetTokenAttribute: TSynHighLighterAttributes;\r\nbegin\r\n  case GetTokenID of\r\n    tkComment: Result := fCommentAttri;\r\n    tkIdentifier: Result := fIdentifierAttri;\r\n    tkKey: Result := fKeyAttri;\r\n    tkNumber: Result := fNumberAttri;\r\n    tkSpace: Result := fSpaceAttri;\r\n    tkSQLKey: Result := fSQLKeyAttri;\r\n    tkString: Result := fStringAttri;\r\n    tkSymbol: Result := fSymbolAttri;\r\n    tkSpecialVar: Result := fSpecialVarAttri;\r\n    tkSystem: Result := fSystemAttri;\r\n    tkVariable: Result := fVariableAttri; \r\n    tkUnknown: Result := fIdentifierAttri;\r\n  else\r\n    Result := nil;\r\n  end;\r\nend; { GetTokenAttribute }\r\n\r\nfunction TSynCPMSyn.GetTokenKind: integer;\r\nbegin\r\n  Result := Ord(fTokenId);\r\nend; { GetTokenKind }\r\n\r\nclass function TSynCPMSyn.GetLanguageName: string;\r\nbegin\r\n  Result := SYNS_LangCPM;\r\nend;\r\n\r\nprocedure TSynCPMSyn.BraceCommentProc;\r\nbegin\r\n  case fLine[Run] of\r\n     #0: NullProc;\r\n    #10: LFProc;\r\n    #13: CRProc;\r\n  else\r\n    begin\r\n      fTokenID := tkComment;\r\n      repeat\r\n        if fLine[Run] = '{' then\r\n          Inc(fCommentLevel)\r\n        else if fLine[Run] = '}' then\r\n        begin\r\n          Dec(fCommentLevel);\r\n          if (fCommentLevel < 1) then\r\n          begin\r\n            Inc(Run);\r\n            fRange := rsUnKnown;\r\n            fCommentLevel := 0;\r\n            Break;\r\n          end;\r\n        end;\r\n        Inc(Run);\r\n      until IsLineEnd(Run);\r\n    end;\r\n  end;\r\nend; { BraceCommentProc }\r\n\r\nprocedure TSynCPMSyn.CRProc;\r\nbegin\r\n  fTokenID := tkSpace;\r\n  inc(Run);\r\n  if fLine[Run] = #10 then\r\n    inc(Run);\r\nend; { CRProc }\r\n\r\nprocedure TSynCPMSyn.LFProc;\r\nbegin\r\n  fTokenID := tkSpace;\r\n  inc(Run);\r\nend; { LFProc }\r\n\r\nfunction TSynCPMSyn.GetSampleSource: UnicodeString;\r\nbegin\r\n  Result := '{ COAS Product Manager report (RDF) }'#13#10 +\r\n            'PARAM'#13#10 +\r\n            '  LANGUAGE;'#13#10 +\r\n            '  CONTINUE;'#13#10 +\r\n            'END; { Param }'#13#10 +\r\n            #13#10 +\r\n            'GLOBALS'#13#10 +\r\n            '  LANGUAGE = LOCAL;'#13#10 +\r\n            'END; { Globals }'#13#10 +\r\n            #13#10 +\r\n            'DEFINITION BLOCK \"MAIN\"'#13#10 +\r\n            'VARIABLES'#13#10 +\r\n            '  S_Query = \"\";'#13#10 +\r\n            '  V_OraErr = -1;'#13#10 +\r\n            '  V_Count;'#13#10 +\r\n            'BEGIN'#13#10 +\r\n            '  ASSIGN(S_Query, \"SELECT * FROM DUAL\");'#13#10 +\r\n            '  SQL_CREATE(V_OraErr, S_Query);'#13#10 +\r\n            '  ASSIGN(V_Count, V_NoneReal);'#13#10 +\r\n            'END;';\r\nend; { GetSampleSource }\r\n\r\nfunction TSynCPMSyn.IsFilterStored: Boolean;\r\nbegin\r\n  Result := fDefaultFilter <> SYNS_FilterCPM;\r\nend; { IsFilterStored }\r\n\r\nprocedure TSynCPMSyn.SemiColonProc;\r\nbegin\r\n  Inc(Run);\r\n  fTokenID := tkSymbol;\r\nend; { SemiColonProc }\r\n\r\nprocedure TSynCPMSyn.NumberProc;\r\n\r\n  function IsNumberChar: Boolean;\r\n  begin\r\n    case fLine[Run] of\r\n      '0'..'9', '.', 'e', 'E':\r\n        Result := True;\r\n      else\r\n        Result := False;\r\n    end;\r\n  end;\r\n\r\nbegin\r\n  inc(Run);\r\n  fTokenID := tkNumber;\r\n  while IsNumberChar do\r\n  begin\r\n    case FLine[Run] of\r\n      '.': if FLine[Run + 1] = '.' then\r\n             Break;\r\n    end;\r\n    inc(Run);\r\n  end;\r\nend; { NumberProc }\r\n\r\nprocedure TSynCPMSyn.SymbolProc;\r\nbegin\r\n  inc(Run);\r\n  fTokenID := tkSymbol;\r\nend; { SymbolProc }\r\n\r\nprocedure TSynCPMSyn.ResetRange;\r\nbegin\r\n  inherited;\r\n  fRange := rsUnknown;\r\n  fCommentLevel := 0;\r\nend; { ResetRange }\r\n\r\nprocedure TSynCPMSyn.SetRange(Value: Pointer);\r\nvar\r\n  AValue: LongInt;\r\nbegin\r\n  inherited;\r\n  AValue := Longint(Value);\r\n  fCommentLevel := AValue div $10000;\r\n  fRange := TRangeState(AValue mod $10000);\r\nend; { SetRange }\r\n\r\nfunction TSynCPMSyn.GetRange: Pointer;\r\nbegin\r\n  Result := Pointer((fCommentLevel * $10000) + Integer(fRange));\r\nend; { GetRange }\r\n\r\nclass function TSynCPMSyn.GetFriendlyLanguageName: UnicodeString;\r\nbegin\r\n  Result := SYNS_FriendlyLangCPM;\r\nend;\r\n\r\ninitialization\r\n{$IFNDEF SYN_CPPB_1}\r\n  RegisterPlaceableHighlighter(TSynCPMSyn);\r\n{$ENDIF}\r\nend.\r\n"
  },
  {
    "path": "External/SynEdit/Source/SynHighlighterCS.pas",
    "content": "{-------------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: SynHighlighterCS.pas, released 2001-10-28.\r\nThe Original Code is based on SynHighlighterCpp.pas, released 2000-04-10,\r\nwhich in turn is based on the dcjCppSyn.pas file from the mwEdit component\r\nsuite by Martin Waldenburg and other developers, the Initial Author of this file\r\nis Michael Trier.\r\nUnicode translation by Mal Hrz.\r\nAll Rights Reserved.\r\n\r\nContributors to the SynEdit and mwEdit projects are listed in the\r\nContributors.txt file.\r\n\r\nAlternatively, the contents of this file may be used under the terms of the\r\nGNU General Public License Version 2 or later (the \"GPL\"), in which case\r\nthe provisions of the GPL are applicable instead of those above.\r\nIf you wish to allow use of your version of this file only under the terms\r\nof the GPL and not to allow others to use your version of this file\r\nunder the MPL, indicate your decision by deleting the provisions above and\r\nreplace them with the notice and other provisions required by the GPL.\r\nIf you do not delete the provisions above, a recipient may use your version\r\nof this file under either the MPL or the GPL.\r\n\r\n$Id: SynHighlighterCS.pas,v 1.8.2.7 2008/09/14 16:24:59 maelh Exp $\r\n\r\nYou may retrieve the latest version of SynEdit from the SynEdit home page,\r\nlocated at http://SynEdit.SourceForge.net\r\n\r\nYou may retrieve the latest version of this file from\r\nhttp://www.ashleybrown.co.uk/synedit/\r\n\r\nKnown Issues:\r\n  - strings on multiple lines are not supported \r\n-------------------------------------------------------------------------------}\r\n{\r\n@abstract(Provides a C# syntax highlighter for SynEdit)\r\n@author(Ashley Brown)\r\n@created(2001)\r\n@lastmod(2001-10-20)\r\nThe SynHighlighterCS unit provides SynEdit with a C# syntax highlighter.\r\nBased on SynHighlighterCpp.pas\r\n}\r\n\r\n{$IFNDEF QSYNHIGHLIGHTERCS}\r\nunit SynHighlighterCS;\r\n{$ENDIF}\r\n\r\n{$I SynEdit.inc}\r\n\r\ninterface\r\n\r\nuses\r\n{$IFDEF SYN_CLX}\r\n  QGraphics,\r\n  QSynEditTypes,\r\n  QSynEditHighlighter,\r\n  QSynUnicode,\r\n{$ELSE}\r\n  Graphics,\r\n  SynEditTypes,\r\n  SynEditHighlighter,\r\n  SynEditMiscClasses,\r\n  SynUnicode,\r\n{$ENDIF}\r\n  SysUtils,\r\n  Classes;\r\n\r\ntype\r\n  TtkTokenKind = (tkAsm, tkComment, tkDirective, tkIdentifier, tkKey, tkNull,\r\n    tkNumber, tkSpace, tkString, tkSymbol, tkUnknown);\r\n\r\n  TxtkTokenKind = (\r\n    xtkAdd, xtkAddAssign, xtkAnd, xtkAndAssign, xtkArrow, xtkAssign,\r\n    xtkBitComplement, xtkBraceClose, xtkBraceOpen, xtkColon, xtkComma,\r\n    xtkDecrement, xtkDivide, xtkDivideAssign, xtkEllipse, xtkGreaterThan,\r\n    xtkGreaterThanEqual, xtkIncOr, xtkIncOrAssign, xtkIncrement, xtkLessThan,\r\n    xtkLessThanEqual, xtkLogAnd, xtkLogComplement, xtkLogEqual, xtkLogOr,\r\n    xtkMod, xtkModAssign, xtkMultiplyAssign, xtkNotEqual, xtkPoint, xtkQuestion,\r\n    xtkRoundClose, xtkRoundOpen, xtkScopeResolution, xtkSemiColon, xtkShiftLeft,\r\n    xtkShiftLeftAssign, xtkShiftRight, xtkShiftRightAssign, xtkSquareClose,\r\n    xtkSquareOpen, xtkStar, xtkSubtract, xtkSubtractAssign, xtkXor,\r\n    xtkXorAssign);\r\n\r\n  TRangeState = (rsUnknown, rsAnsiC, rsAnsiCAsm, rsAnsiCAsmBlock, rsAsm,\r\n    rsAsmBlock, rsDirective, rsDirectiveComment, rsString34, rsString39,\r\n    rsMultiLineString);\r\n\r\n  PIdentFuncTableFunc = ^TIdentFuncTableFunc;\r\n  TIdentFuncTableFunc = function (Index: Integer): TtkTokenKind of object;\r\n\r\n  TSynCSSyn = class(TSynCustomHighlighter)\r\n  private\r\n    fAsmStart: Boolean;\r\n    fRange: TRangeState;\r\n    FTokenID: TtkTokenKind;\r\n    FExtTokenID: TxtkTokenKind;\r\n    fIdentFuncTable: array[0..210] of TIdentFuncTableFunc;\r\n    fAsmAttri: TSynHighlighterAttributes;\r\n    fCommentAttri: TSynHighlighterAttributes;\r\n    fDirecAttri: TSynHighlighterAttributes;\r\n    fIdentifierAttri: TSynHighlighterAttributes;\r\n    fInvalidAttri: TSynHighlighterAttributes;\r\n    fKeyAttri: TSynHighlighterAttributes;\r\n    fNumberAttri: TSynHighlighterAttributes;\r\n    fSpaceAttri: TSynHighlighterAttributes;\r\n    fStringAttri: TSynHighlighterAttributes;\r\n    fSymbolAttri: TSynHighlighterAttributes;\r\n    function AltFunc(Index: Integer): TtkTokenKind;\r\n    function FuncAbstract(Index: Integer): TtkTokenKind;\r\n    function FuncAs(Index: Integer): TtkTokenKind;\r\n    function FuncBase(Index: Integer): TtkTokenKind;\r\n    function FuncBool(Index: Integer): TtkTokenKind;\r\n    function FuncBreak(Index: Integer): TtkTokenKind;\r\n    function FuncByte(Index: Integer): TtkTokenKind;\r\n    function FuncCase(Index: Integer): TtkTokenKind;\r\n    function FuncCatch(Index: Integer): TtkTokenKind;\r\n    function FuncChar(Index: Integer): TtkTokenKind;\r\n    function FuncChecked(Index: Integer): TtkTokenKind;\r\n    function FuncClass(Index: Integer): TtkTokenKind;\r\n    function FuncConst(Index: Integer): TtkTokenKind;\r\n    function FuncContinue(Index: Integer): TtkTokenKind;\r\n    function FuncDecimal(Index: Integer): TtkTokenKind;\r\n    function FuncDefault(Index: Integer): TtkTokenKind;\r\n    function FuncDelegate(Index: Integer): TtkTokenKind;\r\n    function FuncDo(Index: Integer): TtkTokenKind;\r\n    function FuncDouble(Index: Integer): TtkTokenKind;\r\n    function FuncElse(Index: Integer): TtkTokenKind;\r\n    function FuncEnum(Index: Integer): TtkTokenKind;\r\n    function FuncEvent(Index: Integer): TtkTokenKind;\r\n    function FuncExplicit(Index: Integer): TtkTokenKind;\r\n    function FuncExtern(Index: Integer): TtkTokenKind;\r\n    function FuncFalse(Index: Integer): TtkTokenKind;\r\n    function FuncFinally(Index: Integer): TtkTokenKind;\r\n    function FuncFixed(Index: Integer): TtkTokenKind;\r\n    function FuncFloat(Index: Integer): TtkTokenKind;\r\n    function FuncFor(Index: Integer): TtkTokenKind;\r\n    function FuncForeach(Index: Integer): TtkTokenKind;\r\n    function FuncGoto(Index: Integer): TtkTokenKind;\r\n    function FuncIf(Index: Integer): TtkTokenKind;\r\n    function FuncImplicit(Index: Integer): TtkTokenKind;\r\n    function FuncIn(Index: Integer): TtkTokenKind;\r\n    function FuncInt(Index: Integer): TtkTokenKind;\r\n    function FuncInterface(Index: Integer): TtkTokenKind;\r\n    function FuncInternal(Index: Integer): TtkTokenKind;\r\n    function FuncIs(Index: Integer): TtkTokenKind;\r\n    function FuncLock(Index: Integer): TtkTokenKind;\r\n    function FuncLong(Index: Integer): TtkTokenKind;\r\n    function FuncNamespace(Index: Integer): TtkTokenKind;\r\n    function FuncNew(Index: Integer): TtkTokenKind;\r\n    function FuncNull(Index: Integer): TtkTokenKind;\r\n    function FuncObject(Index: Integer): TtkTokenKind;\r\n    function FuncOperator(Index: Integer): TtkTokenKind;\r\n    function FuncOut(Index: Integer): TtkTokenKind;\r\n    function FuncOverride(Index: Integer): TtkTokenKind;\r\n    function FuncParams(Index: Integer): TtkTokenKind;\r\n    function FuncPrivate(Index: Integer): TtkTokenKind;\r\n    function FuncProtected(Index: Integer): TtkTokenKind;\r\n    function FuncPublic(Index: Integer): TtkTokenKind;\r\n    function FuncReadonly(Index: Integer): TtkTokenKind;\r\n    function FuncRef(Index: Integer): TtkTokenKind;\r\n    function FuncReturn(Index: Integer): TtkTokenKind;\r\n    function FuncSbyte(Index: Integer): TtkTokenKind;\r\n    function FuncSealed(Index: Integer): TtkTokenKind;\r\n    function FuncSizeof(Index: Integer): TtkTokenKind;\r\n    function FuncStackalloc(Index: Integer): TtkTokenKind;\r\n    function FuncStatic(Index: Integer): TtkTokenKind;\r\n    function FuncString(Index: Integer): TtkTokenKind;\r\n    function FuncStruct(Index: Integer): TtkTokenKind;\r\n    function FuncSwitch(Index: Integer): TtkTokenKind;\r\n    function FuncThis(Index: Integer): TtkTokenKind;\r\n    function FuncThrow(Index: Integer): TtkTokenKind;\r\n    function FuncTrue(Index: Integer): TtkTokenKind;\r\n    function FuncTry(Index: Integer): TtkTokenKind;\r\n    function FuncTypeof(Index: Integer): TtkTokenKind;\r\n    function FuncUint(Index: Integer): TtkTokenKind;\r\n    function FuncUlong(Index: Integer): TtkTokenKind;\r\n    function FuncUnchecked(Index: Integer): TtkTokenKind;\r\n    function FuncUnsafe(Index: Integer): TtkTokenKind;\r\n    function FuncUshort(Index: Integer): TtkTokenKind;\r\n    function FuncUsing(Index: Integer): TtkTokenKind;\r\n    function FuncVirtual(Index: Integer): TtkTokenKind;\r\n    function FuncVoid(Index: Integer): TtkTokenKind;\r\n    function FuncWhile(Index: Integer): TtkTokenKind;\r\n    function HashKey(Str: PWideChar): Cardinal;\r\n    function IdentKind(MayBe: PWideChar): TtkTokenKind;\r\n    procedure InitIdent;\r\n    procedure AnsiCProc;\r\n    procedure AndSymbolProc;\r\n    procedure AsciiCharProc;\r\n    procedure AtSymbolProc;\r\n    procedure BraceCloseProc;\r\n    procedure BraceOpenProc;\r\n    procedure CRProc;\r\n    procedure ColonProc;\r\n    procedure CommaProc;\r\n    procedure DirectiveProc;\r\n    procedure EqualProc;\r\n    procedure GreaterProc;\r\n    procedure IdentProc;\r\n    procedure LFProc;\r\n    procedure LowerProc;\r\n    procedure MinusProc;\r\n    procedure ModSymbolProc;\r\n    procedure NotSymbolProc;\r\n    procedure NullProc;\r\n    procedure NumberProc;\r\n    procedure OrSymbolProc;\r\n    procedure PlusProc;\r\n    procedure PointProc;\r\n    procedure QuestionProc;\r\n    procedure RoundCloseProc;\r\n    procedure RoundOpenProc;\r\n    procedure SemiColonProc;\r\n    procedure SlashProc;\r\n    procedure SpaceProc;\r\n    procedure SquareCloseProc;\r\n    procedure SquareOpenProc;\r\n    procedure StarProc;\r\n    procedure StringProc;\r\n    procedure TildeProc;\r\n    procedure XOrSymbolProc;\r\n    procedure UnknownProc;\r\n    procedure StringEndProc;\r\n  protected\r\n    function GetExtTokenID: TxtkTokenKind;\r\n    function IsFilterStored: Boolean; override;\r\n    function GetSampleSource: UnicodeString; override;\r\n    procedure NextProcedure;\r\n  public\r\n    class function GetCapabilities: TSynHighlighterCapabilities; override;\r\n    class function GetLanguageName: string; override;\r\n    class function GetFriendlyLanguageName: UnicodeString; override;\r\n  public\r\n    constructor Create(AOwner: TComponent); override;\r\n    function GetDefaultAttribute(Index: integer): TSynHighlighterAttributes;\r\n      override;\r\n    function GetEol: Boolean; override;\r\n    function GetRange: Pointer; override;\r\n    function GetTokenID: TtkTokenKind;\r\n    function GetTokenAttribute: TSynHighlighterAttributes; override;\r\n    function GetTokenKind: integer; override;\r\n    procedure Next; override;\r\n    procedure SetRange(Value: Pointer); override;\r\n    procedure ResetRange; override;\r\n    function UseUserSettings(settingIndex: integer): boolean; override;\r\n    procedure EnumUserSettings(settings: TStrings); override;\r\n    property ExtTokenID: TxtkTokenKind read GetExtTokenID;\r\n  published\r\n    property AsmAttri: TSynHighlighterAttributes read fAsmAttri write fAsmAttri;\r\n    property CommentAttri: TSynHighlighterAttributes read fCommentAttri\r\n      write fCommentAttri;\r\n    property DirecAttri: TSynHighlighterAttributes read fDirecAttri\r\n      write fDirecAttri;\r\n    property IdentifierAttri: TSynHighlighterAttributes read fIdentifierAttri\r\n      write fIdentifierAttri;\r\n    property InvalidAttri: TSynHighlighterAttributes read fInvalidAttri\r\n      write fInvalidAttri;\r\n    property KeyAttri: TSynHighlighterAttributes read fKeyAttri write fKeyAttri;\r\n    property NumberAttri: TSynHighlighterAttributes read fNumberAttri\r\n      write fNumberAttri;\r\n    property SpaceAttri: TSynHighlighterAttributes read fSpaceAttri\r\n      write fSpaceAttri;\r\n    property StringAttri: TSynHighlighterAttributes read fStringAttri\r\n      write fStringAttri;\r\n    property SymbolAttri: TSynHighlighterAttributes read fSymbolAttri\r\n      write fSymbolAttri;\r\n  end;\r\n\r\nimplementation\r\n\r\nuses\r\n{$IFDEF SYN_CLX}\r\n  QSynEditStrConst;\r\n{$ELSE}\r\n  Windows,\r\n  SynEditStrConst;\r\n{$ENDIF}\r\n\r\nconst\r\n  KeyWords: array[0..74] of UnicodeString = (\r\n    'abstract', 'as', 'base', 'bool', 'break', 'byte', 'case', 'catch', 'char', \r\n    'checked', 'class', 'const', 'continue', 'decimal', 'default', 'delegate', \r\n    'do', 'double', 'else', 'enum', 'event', 'explicit', 'extern', 'false', \r\n    'finally', 'fixed', 'float', 'for', 'foreach', 'goto', 'if', 'implicit', \r\n    'in', 'int', 'interface', 'internal', 'is', 'lock', 'long', 'namespace', \r\n    'new', 'null', 'object', 'operator', 'out', 'override', 'params', 'private', \r\n    'protected', 'public', 'readonly', 'ref', 'return', 'sbyte', 'sealed', \r\n    'sizeof', 'stackalloc', 'static', 'string', 'struct', 'switch', 'this', \r\n    'throw', 'true', 'try', 'typeof', 'uint', 'ulong', 'unchecked', 'unsafe', \r\n    'ushort', 'using', 'virtual', 'void', 'while' \r\n  );\r\n\r\n  KeyIndices: array[0..210] of Integer = (\r\n    71, -1, -1, -1, -1, -1, -1, -1, -1, 69, -1, -1, -1, -1, 1, 46, -1, -1, 62, \r\n    -1, 53, -1, -1, -1, -1, 3, -1, -1, 18, -1, 8, -1, -1, -1, -1, -1, 19, -1, \r\n    -1, -1, -1, -1, 45, -1, -1, 28, 44, -1, 47, 21, -1, -1, -1, -1, -1, 73, -1, \r\n    -1, 9, -1, -1, -1, 26, 49, 63, 65, -1, -1, 16, 67, -1, 59, -1, -1, -1, 66, \r\n    -1, 50, -1, -1, -1, 29, -1, 32, 37, -1, -1, 48, -1, -1, 55, -1, 14, 40, -1, \r\n    -1, 13, -1, 12, -1, -1, 15, 30, -1, -1, -1, 41, -1, -1, -1, -1, 4, 56, -1, \r\n    58, -1, 38, -1, -1, -1, -1, 74, -1, -1, -1, 17, 33, -1, -1, 20, -1, -1, 27, \r\n    31, -1, 6, -1, -1, -1, -1, 7, -1, -1, 10, -1, -1, 2, -1, -1, -1, 64, -1, -1, \r\n    43, -1, -1, -1, 0, -1, 34, -1, 25, -1, -1, 5, 61, 60, -1, 42, -1, -1, -1, \r\n    51, -1, -1, -1, -1, 22, -1, -1, 72, -1, -1, 57, -1, 70, -1, 11, -1, -1, -1, \r\n    24, -1, 35, -1, -1, 23, -1, 39, -1, -1, 68, 52, 36, -1, -1, -1, -1, 54, -1, \r\n    -1 \r\n  );\r\n\r\n{$Q-}\r\nfunction TSynCSSyn.HashKey(Str: PWideChar): Cardinal;\r\nbegin\r\n  Result := 0;\r\n  while IsIdentChar(Str^) do\r\n  begin\r\n    Result := Result * 723 + Ord(Str^) * 24;\r\n    inc(Str);\r\n  end;\r\n  Result := Result mod 211;\r\n  fStringLen := Str - fToIdent;\r\nend;\r\n{$Q+}\r\n\r\nfunction TSynCSSyn.IdentKind(MayBe: PWideChar): TtkTokenKind;\r\nvar\r\n  Key: Cardinal;\r\nbegin\r\n  fToIdent := MayBe;\r\n  Key := HashKey(MayBe);\r\n  if Key <= High(fIdentFuncTable) then\r\n    Result := fIdentFuncTable[Key](KeyIndices[Key])\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nprocedure TSynCSSyn.InitIdent;\r\nvar\r\n  i: Integer;\r\nbegin\r\n  for i := Low(fIdentFuncTable) to High(fIdentFuncTable) do\r\n    if KeyIndices[i] = -1 then\r\n      fIdentFuncTable[i] := AltFunc;\r\n\r\n  fIdentFuncTable[157] := FuncAbstract;\r\n  fIdentFuncTable[14] := FuncAs;\r\n  fIdentFuncTable[146] := FuncBase;\r\n  fIdentFuncTable[25] := FuncBool;\r\n  fIdentFuncTable[111] := FuncBreak;\r\n  fIdentFuncTable[164] := FuncByte;\r\n  fIdentFuncTable[135] := FuncCase;\r\n  fIdentFuncTable[140] := FuncCatch;\r\n  fIdentFuncTable[30] := FuncChar;\r\n  fIdentFuncTable[58] := FuncChecked;\r\n  fIdentFuncTable[143] := FuncClass;\r\n  fIdentFuncTable[187] := FuncConst;\r\n  fIdentFuncTable[98] := FuncContinue;\r\n  fIdentFuncTable[96] := FuncDecimal;\r\n  fIdentFuncTable[92] := FuncDefault;\r\n  fIdentFuncTable[101] := FuncDelegate;\r\n  fIdentFuncTable[68] := FuncDo;\r\n  fIdentFuncTable[125] := FuncDouble;\r\n  fIdentFuncTable[28] := FuncElse;\r\n  fIdentFuncTable[36] := FuncEnum;\r\n  fIdentFuncTable[129] := FuncEvent;\r\n  fIdentFuncTable[49] := FuncExplicit;\r\n  fIdentFuncTable[177] := FuncExtern;\r\n  fIdentFuncTable[196] := FuncFalse;\r\n  fIdentFuncTable[191] := FuncFinally;\r\n  fIdentFuncTable[161] := FuncFixed;\r\n  fIdentFuncTable[62] := FuncFloat;\r\n  fIdentFuncTable[132] := FuncFor;\r\n  fIdentFuncTable[45] := FuncForeach;\r\n  fIdentFuncTable[81] := FuncGoto;\r\n  fIdentFuncTable[102] := FuncIf;\r\n  fIdentFuncTable[133] := FuncImplicit;\r\n  fIdentFuncTable[83] := FuncIn;\r\n  fIdentFuncTable[126] := FuncInt;\r\n  fIdentFuncTable[159] := FuncInterface;\r\n  fIdentFuncTable[193] := FuncInternal;\r\n  fIdentFuncTable[203] := FuncIs;\r\n  fIdentFuncTable[84] := FuncLock;\r\n  fIdentFuncTable[116] := FuncLong;\r\n  fIdentFuncTable[198] := FuncNamespace;\r\n  fIdentFuncTable[93] := FuncNew;\r\n  fIdentFuncTable[106] := FuncNull;\r\n  fIdentFuncTable[168] := FuncObject;\r\n  fIdentFuncTable[153] := FuncOperator;\r\n  fIdentFuncTable[46] := FuncOut;\r\n  fIdentFuncTable[42] := FuncOverride;\r\n  fIdentFuncTable[15] := FuncParams;\r\n  fIdentFuncTable[48] := FuncPrivate;\r\n  fIdentFuncTable[87] := FuncProtected;\r\n  fIdentFuncTable[63] := FuncPublic;\r\n  fIdentFuncTable[77] := FuncReadonly;\r\n  fIdentFuncTable[172] := FuncRef;\r\n  fIdentFuncTable[202] := FuncReturn;\r\n  fIdentFuncTable[20] := FuncSbyte;\r\n  fIdentFuncTable[208] := FuncSealed;\r\n  fIdentFuncTable[90] := FuncSizeof;\r\n  fIdentFuncTable[112] := FuncStackalloc;\r\n  fIdentFuncTable[183] := FuncStatic;\r\n  fIdentFuncTable[114] := FuncString;\r\n  fIdentFuncTable[71] := FuncStruct;\r\n  fIdentFuncTable[166] := FuncSwitch;\r\n  fIdentFuncTable[165] := FuncThis;\r\n  fIdentFuncTable[18] := FuncThrow;\r\n  fIdentFuncTable[64] := FuncTrue;\r\n  fIdentFuncTable[150] := FuncTry;\r\n  fIdentFuncTable[65] := FuncTypeof;\r\n  fIdentFuncTable[75] := FuncUint;\r\n  fIdentFuncTable[69] := FuncUlong;\r\n  fIdentFuncTable[201] := FuncUnchecked;\r\n  fIdentFuncTable[9] := FuncUnsafe;\r\n  fIdentFuncTable[185] := FuncUshort;\r\n  fIdentFuncTable[0] := FuncUsing;\r\n  fIdentFuncTable[180] := FuncVirtual;\r\n  fIdentFuncTable[55] := FuncVoid;\r\n  fIdentFuncTable[121] := FuncWhile;\r\nend;\r\n\r\n\r\n\r\nfunction TSynCSSyn.AltFunc(Index: Integer): TtkTokenKind;\r\nbegin\r\n  Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynCSSyn.FuncAbstract(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynCSSyn.FuncAs(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynCSSyn.FuncBase(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynCSSyn.FuncBool(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynCSSyn.FuncBreak(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynCSSyn.FuncByte(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynCSSyn.FuncCase(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynCSSyn.FuncCatch(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynCSSyn.FuncChar(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynCSSyn.FuncChecked(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynCSSyn.FuncClass(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynCSSyn.FuncConst(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynCSSyn.FuncContinue(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynCSSyn.FuncDecimal(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynCSSyn.FuncDefault(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynCSSyn.FuncDelegate(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynCSSyn.FuncDo(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynCSSyn.FuncDouble(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynCSSyn.FuncElse(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynCSSyn.FuncEnum(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynCSSyn.FuncEvent(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynCSSyn.FuncExplicit(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynCSSyn.FuncExtern(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynCSSyn.FuncFalse(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynCSSyn.FuncFinally(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynCSSyn.FuncFixed(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynCSSyn.FuncFloat(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynCSSyn.FuncFor(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynCSSyn.FuncForeach(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynCSSyn.FuncGoto(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynCSSyn.FuncIf(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynCSSyn.FuncImplicit(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynCSSyn.FuncIn(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynCSSyn.FuncInt(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynCSSyn.FuncInterface(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynCSSyn.FuncInternal(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynCSSyn.FuncIs(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynCSSyn.FuncLock(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynCSSyn.FuncLong(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynCSSyn.FuncNamespace(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynCSSyn.FuncNew(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynCSSyn.FuncNull(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynCSSyn.FuncObject(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynCSSyn.FuncOperator(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynCSSyn.FuncOut(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynCSSyn.FuncOverride(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynCSSyn.FuncParams(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynCSSyn.FuncPrivate(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynCSSyn.FuncProtected(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynCSSyn.FuncPublic(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynCSSyn.FuncReadonly(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynCSSyn.FuncRef(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynCSSyn.FuncReturn(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynCSSyn.FuncSbyte(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynCSSyn.FuncSealed(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynCSSyn.FuncSizeof(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynCSSyn.FuncStackalloc(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynCSSyn.FuncStatic(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynCSSyn.FuncString(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynCSSyn.FuncStruct(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynCSSyn.FuncSwitch(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynCSSyn.FuncThis(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynCSSyn.FuncThrow(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynCSSyn.FuncTrue(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynCSSyn.FuncTry(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynCSSyn.FuncTypeof(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynCSSyn.FuncUint(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynCSSyn.FuncUlong(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynCSSyn.FuncUnchecked(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynCSSyn.FuncUnsafe(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynCSSyn.FuncUshort(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynCSSyn.FuncUsing(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynCSSyn.FuncVirtual(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynCSSyn.FuncVoid(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynCSSyn.FuncWhile(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nconstructor TSynCSSyn.Create(AOwner: TComponent);\r\nbegin\r\n  inherited Create(AOwner);\r\n\r\n  fCaseSensitive := True;\r\n\r\n  fAsmAttri := TSynHighlighterAttributes.Create(SYNS_AttrAssembler, SYNS_FriendlyAttrAssembler);\r\n  AddAttribute(fAsmAttri);\r\n  fCommentAttri := TSynHighlighterAttributes.Create(SYNS_AttrComment, SYNS_FriendlyAttrComment);\r\n  fCommentAttri.Style:= [fsItalic];\r\n  AddAttribute(fCommentAttri);\r\n  fIdentifierAttri := TSynHighlighterAttributes.Create(SYNS_AttrIdentifier, SYNS_FriendlyAttrIdentifier);\r\n  AddAttribute(fIdentifierAttri);\r\n  fInvalidAttri := TSynHighlighterAttributes.Create(SYNS_AttrIllegalChar, SYNS_FriendlyAttrIllegalChar);\r\n  AddAttribute(fInvalidAttri);\r\n  fKeyAttri := TSynHighlighterAttributes.Create(SYNS_AttrReservedWord, SYNS_FriendlyAttrReservedWord);\r\n  fKeyAttri.Style:= [fsBold];\r\n  AddAttribute(fKeyAttri);\r\n  fNumberAttri := TSynHighlighterAttributes.Create(SYNS_AttrNumber, SYNS_FriendlyAttrNumber);\r\n  AddAttribute(fNumberAttri);\r\n  fSpaceAttri := TSynHighlighterAttributes.Create(SYNS_AttrSpace, SYNS_FriendlyAttrSpace);\r\n  AddAttribute(fSpaceAttri);\r\n  fStringAttri := TSynHighlighterAttributes.Create(SYNS_AttrString, SYNS_FriendlyAttrString);\r\n  AddAttribute(fStringAttri);\r\n  fSymbolAttri := TSynHighlighterAttributes.Create(SYNS_AttrSymbol, SYNS_FriendlyAttrSymbol);\r\n  AddAttribute(fSymbolAttri);\r\n  fDirecAttri := TSynHighlighterAttributes.Create(SYNS_AttrPreprocessor, SYNS_FriendlyAttrPreprocessor);\r\n  AddAttribute(fDirecAttri);\r\n  SetAttributesOnChange(DefHighlightChange);\r\n  InitIdent;\r\n  fRange := rsUnknown;\r\n  fAsmStart := False;\r\n  fDefaultFilter := SYNS_FilterCS;\r\nend; { Create }\r\n\r\nprocedure TSynCSSyn.AnsiCProc;\r\nbegin\r\n  fTokenID := tkComment;\r\n  case FLine[Run] of\r\n    #0:\r\n      begin\r\n        NullProc;\r\n        exit;\r\n      end;\r\n    #10:\r\n      begin\r\n        LFProc;\r\n        exit;\r\n      end;\r\n    #13:\r\n      begin\r\n        CRProc;\r\n        exit;\r\n      end;\r\n  end;\r\n\r\n  while FLine[Run] <> #0 do\r\n    case FLine[Run] of\r\n      '*':\r\n        if fLine[Run + 1] = '/' then\r\n        begin\r\n          inc(Run, 2);\r\n          if fRange = rsAnsiCAsm then\r\n            fRange := rsAsm\r\n          else if fRange = rsAnsiCAsmBlock then\r\n            fRange := rsAsmBlock\r\n          else if fRange = rsDirectiveComment then\r\n            fRange := rsDirective\r\n          else\r\n            fRange := rsUnKnown;\r\n          break;\r\n        end else\r\n          inc(Run);\r\n      #10: break;\r\n      #13: break;\r\n    else inc(Run);\r\n    end;\r\nend;\r\n\r\nprocedure TSynCSSyn.AndSymbolProc;\r\nbegin\r\n  fTokenID := tkSymbol;\r\n  case FLine[Run + 1] of\r\n    '=':                               {and assign}\r\n      begin\r\n        inc(Run, 2);\r\n        FExtTokenID := xtkAndAssign;\r\n      end;\r\n    '&':                               {logical and}\r\n      begin\r\n        inc(Run, 2);\r\n        FExtTokenID := xtkLogAnd;\r\n      end;\r\n  else                                 {and}\r\n    begin\r\n      inc(Run);\r\n      FExtTokenID := xtkAnd;\r\n    end;\r\n  end;\r\nend;\r\n\r\nprocedure TSynCSSyn.AsciiCharProc;\r\nbegin\r\n  fTokenID := tkString;\r\n  repeat\r\n    if fLine[Run] = '\\' then begin\r\n      if CharInSet(fLine[Run + 1], [#39, '\\']) then\r\n        inc(Run);\r\n    end;\r\n    inc(Run);\r\n  until IsLineEnd(Run) or (fLine[Run] = #39);\r\n  if fLine[Run] = #39 then\r\n    inc(Run);\r\nend;\r\n\r\nprocedure TSynCSSyn.AtSymbolProc;\r\nbegin\r\n  fTokenID := tkUnknown;\r\n  inc(Run);\r\nend;\r\n\r\nprocedure TSynCSSyn.BraceCloseProc;\r\nbegin\r\n  inc(Run);\r\n  fTokenId := tkSymbol;\r\n  FExtTokenID := xtkBraceClose;\r\n  if fRange = rsAsmBlock then fRange := rsUnknown;\r\nend;\r\n\r\nprocedure TSynCSSyn.BraceOpenProc;\r\nbegin\r\n  inc(Run);\r\n  fTokenId := tkSymbol;\r\n  FExtTokenID := xtkBraceOpen;\r\n  if fRange = rsAsm then\r\n  begin\r\n    fRange := rsAsmBlock;\r\n    fAsmStart := True;\r\n  end;\r\nend;\r\n\r\nprocedure TSynCSSyn.CRProc;\r\nbegin\r\n  fTokenID := tkSpace;\r\n  Inc(Run);\r\n  if fLine[Run + 1] = #10 then Inc(Run);\r\nend;\r\n\r\nprocedure TSynCSSyn.ColonProc;\r\nbegin\r\n  fTokenID := tkSymbol;\r\n  Case FLine[Run + 1] of\r\n    ':':                               {scope resolution operator}\r\n      begin\r\n        inc(Run, 2);\r\n        FExtTokenID := xtkScopeResolution;\r\n      end;\r\n  else                                 {colon}\r\n    begin\r\n      inc(Run);\r\n      FExtTokenID := xtkColon;\r\n    end;\r\n  end;\r\nend;\r\n\r\nprocedure TSynCSSyn.CommaProc;\r\nbegin\r\n  inc(Run);\r\n  fTokenID := tkSymbol;\r\n  FExtTokenID := xtkComma;\r\nend;\r\n\r\nprocedure TSynCSSyn.DirectiveProc;\r\nbegin\r\n  if IsLineEnd(Run) then\r\n  begin\r\n    if (Run <= 0) or (fLine[Run - 1] <> '\\') then\r\n      fRange := rsUnknown;\r\n    NextProcedure;\r\n  end\r\n  else\r\n  begin\r\n    fTokenID := tkDirective;\r\n    while True do\r\n      case fLine[Run] of\r\n        '/': // comment?\r\n          begin\r\n            if fLine[Run + 1] = '/' then\r\n            begin // is end of directive as well\r\n              fRange := rsUnknown;\r\n              break;\r\n            end else if fLine[Run + 1] = '*' then\r\n            begin // might be embedded only\r\n              fRange := rsDirectiveComment;\r\n              break;\r\n            end else\r\n              Inc(Run);\r\n          end;\r\n        '\\': // directive continued on next line?\r\n          begin\r\n            Inc(Run);\r\n            if IsLineEnd(Run) then\r\n            begin\r\n              fRange := rsDirective;\r\n              break;\r\n            end;\r\n          end;\r\n        #0, #10, #13:\r\n          begin\r\n            fRange := rsUnknown;\r\n            break;\r\n          end;\r\n        else\r\n          Inc(Run);\r\n      end;\r\n  end;\r\nend;\r\n\r\nprocedure TSynCSSyn.EqualProc;\r\nbegin\r\n  fTokenID := tkSymbol;\r\n  case FLine[Run + 1] of\r\n    '=':                               {logical equal}\r\n      begin\r\n        inc(Run, 2);\r\n        FExtTokenID := xtkLogEqual;\r\n      end;\r\n  else                                 {assign}\r\n    begin\r\n      inc(Run);\r\n      FExtTokenID := xtkAssign;\r\n    end;\r\n  end;\r\nend;\r\n\r\nprocedure TSynCSSyn.GreaterProc;\r\nbegin\r\n  fTokenID := tkSymbol;\r\n  Case FLine[Run + 1] of\r\n    '=':                               {greater than or equal to}\r\n      begin\r\n        inc(Run, 2);\r\n        FExtTokenID := xtkGreaterThanEqual;\r\n      end;\r\n    '>':\r\n      begin\r\n        if FLine[Run + 2] = '=' then   {shift right assign}\r\n        begin\r\n          inc(Run, 3);\r\n          FExtTokenID := xtkShiftRightAssign;\r\n        end\r\n        else                           {shift right}\r\n        begin\r\n          inc(Run, 2);\r\n          FExtTokenID := xtkShiftRight;\r\n        end;\r\n      end;\r\n  else                                 {greater than}\r\n    begin\r\n      inc(Run);\r\n      FExtTokenID := xtkGreaterThan;\r\n    end;\r\n  end;\r\nend;\r\n\r\nprocedure TSynCSSyn.QuestionProc;\r\nbegin\r\n  fTokenID := tkSymbol;                {conditional}\r\n  FExtTokenID := xtkQuestion;\r\n  inc(Run);\r\nend;\r\n\r\nprocedure TSynCSSyn.IdentProc;\r\nbegin\r\n  fTokenID := IdentKind((fLine + Run));\r\n  inc(Run, fStringLen);\r\n  while IsIdentChar(fLine[Run]) do inc(Run);\r\nend;\r\n\r\nprocedure TSynCSSyn.LFProc;\r\nbegin\r\n  fTokenID := tkSpace;\r\n  inc(Run);\r\nend;\r\n\r\nprocedure TSynCSSyn.LowerProc;\r\nbegin\r\n  fTokenID := tkSymbol;\r\n  case FLine[Run + 1] of\r\n    '=':                               {less than or equal to}\r\n      begin\r\n        inc(Run, 2);\r\n        FExtTokenID := xtkLessThanEqual;\r\n      end;\r\n    '<':\r\n      begin\r\n        if FLine[Run + 2] = '=' then   {shift left assign}\r\n        begin\r\n          inc(Run, 3);\r\n          FExtTokenID := xtkShiftLeftAssign;\r\n        end\r\n        else                           {shift left}\r\n        begin\r\n          inc(Run, 2);\r\n          FExtTokenID := xtkShiftLeft;\r\n        end;\r\n      end;\r\n  else                                 {less than}\r\n    begin\r\n      inc(Run);\r\n      FExtTokenID := xtkLessThan;\r\n    end;\r\n  end;\r\nend;\r\n\r\nprocedure TSynCSSyn.MinusProc;\r\nbegin\r\n  fTokenID := tkSymbol;\r\n  case FLine[Run + 1] of\r\n    '=':                               {subtract assign}\r\n      begin\r\n        inc(Run, 2);\r\n        FExtTokenID := xtkSubtractAssign;\r\n      end;\r\n    '-':                               {decrement}\r\n      begin\r\n        inc(Run, 2);\r\n        FExtTokenID := xtkDecrement;\r\n      end;\r\n    '>':                               {arrow}\r\n      begin\r\n        inc(Run, 2);\r\n        FExtTokenID := xtkArrow;\r\n      end;\r\n  else                                 {subtract}\r\n    begin\r\n      inc(Run);\r\n      FExtTokenID := xtkSubtract;\r\n    end;\r\n  end;\r\nend;\r\n\r\nprocedure TSynCSSyn.ModSymbolProc;\r\nbegin\r\n  fTokenID := tkSymbol;\r\n  case FLine[Run + 1] of\r\n    '=':                               {mod assign}\r\n      begin\r\n        inc(Run, 2);\r\n        FExtTokenID := xtkModAssign;\r\n      end;\r\n  else                                 {mod}\r\n    begin\r\n      inc(Run);\r\n      FExtTokenID := xtkMod;\r\n    end;\r\n  end;\r\nend;\r\n\r\nprocedure TSynCSSyn.NotSymbolProc;\r\nbegin\r\n  fTokenID := tkSymbol;\r\n  case FLine[Run + 1] of\r\n    '=':                               {not equal}\r\n      begin\r\n        inc(Run, 2);\r\n        FExtTokenID := xtkNotEqual;\r\n      end;\r\n  else                                 {not}\r\n    begin\r\n      inc(Run);\r\n      FExtTokenID := xtkLogComplement;\r\n    end;\r\n  end;\r\nend;\r\n\r\nprocedure TSynCSSyn.NullProc;\r\nbegin\r\n  fTokenID := tkNull;\r\n  inc(Run);\r\nend;\r\n\r\nprocedure TSynCSSyn.NumberProc;\r\n\r\n  function IsNumberChar: Boolean;\r\n  begin\r\n    case fLine[Run] of\r\n      '0'..'9', 'A'..'F', 'a'..'f', '.', 'u', 'U', 'l', 'L', 'x', 'X':\r\n        Result := True;\r\n      else\r\n        Result := False;\r\n    end;\r\n  end;\r\n\r\nbegin\r\n  inc(Run);\r\n  fTokenID := tkNumber;\r\n  while IsNumberChar do\r\n  begin\r\n    case FLine[Run] of\r\n      '.':\r\n        if FLine[Run + 1] = '.' then break;\r\n    end;\r\n    inc(Run);\r\n  end;\r\nend;\r\n\r\nprocedure TSynCSSyn.OrSymbolProc;\r\nbegin\r\n  fTokenID := tkSymbol;\r\n  case FLine[Run + 1] of\r\n    '=':                               {or assign}\r\n      begin\r\n        inc(Run, 2);\r\n        FExtTokenID := xtkIncOrAssign;\r\n      end;\r\n    '|':                               {logical or}\r\n      begin\r\n        inc(Run, 2);\r\n        FExtTokenID := xtkLogOr;\r\n      end;\r\n  else                                 {or}\r\n    begin\r\n      inc(Run);\r\n      FExtTokenID := xtkIncOr;\r\n    end;\r\n  end;\r\nend;\r\n\r\nprocedure TSynCSSyn.PlusProc;\r\nbegin\r\n  fTokenID := tkSymbol;\r\n  case FLine[Run + 1] of\r\n    '=':                               {add assign}\r\n      begin\r\n        inc(Run, 2);\r\n        FExtTokenID := xtkAddAssign;\r\n      end;\r\n    '+':                               {increment}\r\n      begin\r\n        inc(Run, 2);\r\n        FExtTokenID := xtkIncrement;\r\n      end;\r\n  else                                 {add}\r\n    begin\r\n      inc(Run);\r\n      FExtTokenID := xtkAdd;\r\n    end;\r\n  end;\r\nend;\r\n\r\nprocedure TSynCSSyn.PointProc;\r\nbegin\r\n  fTokenID := tkSymbol;\r\n  if (FLine[Run + 1] = '.') and (FLine[Run + 2] = '.') then\r\n    begin                              {ellipse}\r\n      inc(Run, 3);\r\n      FExtTokenID := xtkEllipse;\r\n    end\r\n  else                                 {point}\r\n    begin\r\n      inc(Run);\r\n      FExtTokenID := xtkPoint;\r\n    end;\r\nend;\r\n\r\nprocedure TSynCSSyn.RoundCloseProc;\r\nbegin\r\n  inc(Run);\r\n  fTokenID := tkSymbol;\r\n  FExtTokenID := xtkRoundClose;\r\nend;\r\n\r\nprocedure TSynCSSyn.RoundOpenProc;\r\nbegin\r\n  inc(Run);\r\n  FTokenID := tkSymbol;\r\n  FExtTokenID := xtkRoundOpen;\r\nend;\r\n\r\nprocedure TSynCSSyn.SemiColonProc;\r\nbegin\r\n  inc(Run);\r\n  fTokenID := tkSymbol;\r\n  FExtTokenID := xtkSemiColon;\r\n  if fRange = rsAsm then fRange := rsUnknown;\r\nend;\r\n\r\nprocedure TSynCSSyn.SlashProc;\r\nbegin\r\n  case FLine[Run + 1] of\r\n    '/':                               {c++ style comments}\r\n      begin\r\n        fTokenID := tkComment;\r\n        inc(Run, 2);\r\n        while not IsLineEnd(Run) do Inc(Run);\r\n      end;\r\n    '*':                               {c style comments}\r\n      begin\r\n        fTokenID := tkComment;\r\n        if fRange = rsAsm then\r\n          fRange := rsAnsiCAsm\r\n        else if fRange = rsAsmBlock then\r\n          fRange := rsAnsiCAsmBlock\r\n        else if fRange <> rsDirectiveComment then                          \r\n          fRange := rsAnsiC;\r\n        inc(Run, 2);\r\n        while fLine[Run] <> #0 do\r\n          case fLine[Run] of\r\n            '*':\r\n              if fLine[Run + 1] = '/' then\r\n              begin\r\n                inc(Run, 2);\r\n                if fRange = rsDirectiveComment then\r\n                  fRange := rsDirective\r\n                else if fRange = rsAnsiCAsm then\r\n                  fRange := rsAsm\r\n                else\r\n                  begin\r\n                  if fRange = rsAnsiCAsmBlock then\r\n                    fRange := rsAsmBlock\r\n                  else\r\n                    fRange := rsUnKnown;\r\n                  end;\r\n                break;\r\n              end else inc(Run);\r\n            #10, #13:\r\n              begin\r\n                if fRange = rsDirectiveComment then\r\n                  fRange := rsAnsiC;\r\n                break;\r\n              end;\r\n          else inc(Run);\r\n          end;\r\n      end;\r\n    '=':                               {divide assign}\r\n      begin\r\n        inc(Run, 2);\r\n        fTokenID := tkSymbol;\r\n        FExtTokenID := xtkDivideAssign;\r\n      end;\r\n  else                                 {divide}\r\n    begin\r\n      inc(Run);\r\n      fTokenID := tkSymbol;\r\n      FExtTokenID := xtkDivide;\r\n    end;\r\n  end;\r\nend;\r\n\r\nprocedure TSynCSSyn.SpaceProc;\r\nbegin\r\n  inc(Run);\r\n  fTokenID := tkSpace;\r\n  while (FLine[Run] <= #32) and not IsLineEnd(Run) do inc(Run);\r\nend;\r\n\r\nprocedure TSynCSSyn.SquareCloseProc;\r\nbegin\r\n  inc(Run);\r\n  fTokenID := tkSymbol;\r\n  FExtTokenID := xtkSquareClose;\r\nend;\r\n\r\nprocedure TSynCSSyn.SquareOpenProc;\r\nbegin\r\n  inc(Run);\r\n  fTokenID := tkSymbol;\r\n  FExtTokenID := xtkSquareOpen;\r\nend;\r\n\r\nprocedure TSynCSSyn.StarProc;\r\nbegin\r\n  fTokenID := tkSymbol;\r\n  case FLine[Run + 1] of\r\n    '=':                               {multiply assign}\r\n      begin\r\n        inc(Run, 2);\r\n        FExtTokenID := xtkMultiplyAssign;\r\n      end;\r\n  else                                 {star}\r\n    begin\r\n      inc(Run);\r\n      FExtTokenID := xtkStar;\r\n    end;\r\n  end;\r\nend;\r\n\r\nprocedure TSynCSSyn.StringProc;\r\nbegin\r\n  fTokenID := tkString;\r\n  repeat\r\n    if fLine[Run] = '\\' then begin\r\n      case fLine[Run + 1] of\r\n        #34, '\\':\r\n          Inc(Run);\r\n        #00:\r\n          begin\r\n            Inc(Run);\r\n            fRange := rsMultilineString;\r\n            Exit;\r\n          end;\r\n      end;\r\n    end;\r\n    inc(Run);\r\n  until IsLineEnd(Run) or (fLine[Run] = #34);\r\n  if FLine[Run] = #34 then\r\n    inc(Run);\r\nend;\r\n\r\nprocedure TSynCSSyn.StringEndProc;\r\nbegin\r\n  fTokenID := tkString;\r\n\r\n  case FLine[Run] of\r\n    #0:\r\n      begin\r\n        NullProc;\r\n        Exit;\r\n      end;\r\n    #10:\r\n      begin\r\n        LFProc;\r\n        Exit;\r\n      end;\r\n    #13:\r\n      begin\r\n        CRProc;\r\n        Exit;\r\n      end;\r\n  end;\r\n\r\n  fRange := rsUnknown;\r\n\r\n  repeat\r\n    case FLine[Run] of\r\n      #0, #10, #13: Break;\r\n      '\\':\r\n        begin\r\n          case fLine[Run + 1] of\r\n            #34, '\\':\r\n              Inc(Run);\r\n            #00:\r\n              begin\r\n                Inc(Run);\r\n                fRange := rsMultilineString;\r\n                Exit;\r\n              end;\r\n          end;\r\n        end;\r\n      #34: Break;\r\n    end;\r\n    inc(Run);\r\n  until IsLineEnd(Run) or (fLine[Run] = #34);\r\n  if FLine[Run] = #34 then\r\n    inc(Run);\r\nend;\r\n\r\nprocedure TSynCSSyn.TildeProc;\r\nbegin\r\n  inc(Run);                            {bitwise complement}\r\n  fTokenId := tkSymbol;\r\n  FExtTokenID := xtkBitComplement;\r\nend;\r\n\r\nprocedure TSynCSSyn.XOrSymbolProc;\r\nbegin\r\n  fTokenID := tkSymbol;\r\n  Case FLine[Run + 1] of\r\n  \t'=':                               {xor assign}\r\n      begin\r\n        inc(Run, 2);\r\n        FExtTokenID := xtkXorAssign;\r\n      end;\r\n  else                                 {xor}\r\n    begin\r\n      inc(Run);\r\n      FExtTokenID := xtkXor;\r\n    end;\r\n  end;\r\nend;\r\n\r\nprocedure TSynCSSyn.UnknownProc;\r\nbegin\r\n  inc(Run);\r\n  fTokenID := tkUnknown;\r\nend;\r\n\r\nprocedure TSynCSSyn.Next;\r\nbegin\r\n  fAsmStart := False;\r\n  fTokenPos := Run;\r\n  case fRange of\r\n    rsAnsiC, rsAnsiCAsm,\r\n    rsAnsiCAsmBlock, rsDirectiveComment: AnsiCProc;\r\n    rsDirective: DirectiveProc;\r\n    rsMultilineString: StringEndProc;\r\n  else\r\n    begin\r\n      fRange := rsUnknown;\r\n      NextProcedure;\r\n    end;\r\n  end;\r\n  inherited;\r\nend;\r\n\r\nprocedure TSynCSSyn.NextProcedure;\r\nbegin\r\n  case fLine[Run] of\r\n    '&': AndSymbolProc;\r\n    #39: AsciiCharProc;\r\n    '@': AtSymbolProc;\r\n    '}': BraceCloseProc;\r\n    '{': BraceOpenProc;\r\n    #13: CRProc;\r\n    ':': ColonProc;\r\n    ',': CommaProc;\r\n    '#': DirectiveProc;\r\n    '=': EqualProc;\r\n    '>': GreaterProc;\r\n    '?': QuestionProc;\r\n    'A'..'Z', 'a'..'z', '_': IdentProc;\r\n    #10: LFProc;\r\n    '<': LowerProc;\r\n    '-': MinusProc;\r\n    '%': ModSymbolProc;\r\n    '!': NotSymbolProc;\r\n    #0: NullProc;\r\n    '0'..'9': NumberProc;\r\n    '|': OrSymbolProc;\r\n    '+': PlusProc;\r\n    '.': PointProc;\r\n    ')': RoundCloseProc;\r\n    '(': RoundOpenProc;\r\n    ';': SemiColonProc;\r\n    '/': SlashProc;\r\n    #1..#9, #11, #12, #14..#32: SpaceProc;\r\n    ']': SquareCloseProc;\r\n    '[': SquareOpenProc;\r\n    '*': StarProc;\r\n    #34: StringProc;\r\n    '~': TildeProc;\r\n    '^': XOrSymbolProc;\r\n    else UnknownProc;\r\n  end;\r\nend;\r\n\r\nfunction TSynCSSyn.GetDefaultAttribute(Index: integer): TSynHighlighterAttributes;\r\nbegin\r\n  case Index of\r\n    SYN_ATTR_COMMENT: Result := fCommentAttri;\r\n    SYN_ATTR_IDENTIFIER: Result := fIdentifierAttri;\r\n    SYN_ATTR_KEYWORD: Result := fKeyAttri;\r\n    SYN_ATTR_STRING: Result := fStringAttri;\r\n    SYN_ATTR_WHITESPACE: Result := fSpaceAttri;\r\n    else Result := nil;\r\n  end;\r\nend;\r\n\r\nfunction TSynCSSyn.GetEol: Boolean;\r\nbegin\r\n  Result := Run = fLineLen + 1;\r\nend;\r\n\r\nfunction TSynCSSyn.GetRange: Pointer;\r\nbegin\r\n  Result := Pointer(fRange);\r\nend;\r\n\r\nfunction TSynCSSyn.GetTokenID: TtkTokenKind;\r\nbegin\r\n  Result := fTokenId;\r\n  if ((fRange = rsAsm) or (fRange = rsAsmBlock)) and not fAsmStart\r\n    and not (fTokenId in [tkComment, tkSpace, tkNull])\r\n  then\r\n    Result := tkAsm;\r\nend;\r\n\r\nfunction TSynCSSyn.GetExtTokenID: TxtkTokenKind;\r\nbegin\r\n  Result := FExtTokenID;\r\nend;\r\n\r\nfunction TSynCSSyn.GetTokenAttribute: TSynHighlighterAttributes;\r\nbegin\r\n  case fTokenID of\r\n    tkAsm: Result := fAsmAttri;\r\n    tkComment: Result := fCommentAttri;\r\n    tkDirective: Result := fDirecAttri;\r\n    tkIdentifier: Result := fIdentifierAttri;\r\n    tkKey: Result := fKeyAttri;\r\n    tkNumber: Result := fNumberAttri;\r\n    tkSpace: Result := fSpaceAttri;\r\n    tkString: Result := fStringAttri;\r\n    tkSymbol: Result := fSymbolAttri;\r\n    tkUnknown: Result := fInvalidAttri;\r\n    else Result := nil;\r\n  end;\r\nend;\r\n\r\nfunction TSynCSSyn.GetTokenKind: integer;\r\nbegin\r\n  Result := Ord(GetTokenID);\r\nend;\r\n\r\nprocedure TSynCSSyn.ResetRange;\r\nbegin\r\n  fRange:= rsUnknown;\r\nend;\r\n\r\nprocedure TSynCSSyn.SetRange(Value: Pointer);\r\nbegin\r\n  fRange := TRangeState(Value);\r\nend;\r\n\r\nprocedure TSynCSSyn.EnumUserSettings(settings: TStrings);\r\nbegin\r\n  { returns the user settings that exist in the registry }\r\n  {$IFNDEF SYN_CLX}\r\n  with TBetterRegistry.Create do\r\n  begin\r\n    try\r\n      RootKey := HKEY_LOCAL_MACHINE;\r\n      if OpenKeyReadOnly('\\SOFTWARE\\Borland\\C++Builder') then\r\n      begin\r\n        try\r\n          GetKeyNames(settings);\r\n        finally\r\n          CloseKey;\r\n        end;\r\n      end;\r\n    finally\r\n      Free;\r\n    end;\r\n  end;\r\n  {$ENDIF}\r\nend;\r\n\r\nfunction TSynCSSyn.UseUserSettings(settingIndex: integer): boolean;\r\n// Possible parameter values:\r\n//   index into TStrings returned by EnumUserSettings\r\n// Possible return values:\r\n//   true : settings were read and used\r\n//   false: problem reading settings or invalid version specified - old settings\r\n//          were preserved\r\n\r\n  {$IFNDEF SYN_CLX}\r\n  function ReadCPPBSettings(settingIndex: integer): boolean;\r\n\r\n    function ReadCPPBSetting(settingTag: string; attri: TSynHighlighterAttributes; key: string): boolean;\r\n\r\n      function ReadCPPB1(settingTag: string; attri: TSynHighlighterAttributes; name: string): boolean;\r\n      var\r\n        i: integer;\r\n      begin\r\n        for i := 1 to Length(name) do\r\n          if name[i] = ' ' then name[i] := '_';\r\n        Result := attri.LoadFromBorlandRegistry(HKEY_CURRENT_USER,\r\n             '\\SOFTWARE\\Borland\\C++Builder\\'+settingTag+'\\Highlight',name,true);\r\n      end; { ReadCPPB1 }\r\n\r\n      function ReadCPPB3OrMore(settingTag: string; attri: TSynHighlighterAttributes; key: string): boolean;\r\n      begin\r\n        Result := attri.LoadFromBorlandRegistry(HKEY_CURRENT_USER,\r\n                 '\\Software\\Borland\\C++Builder\\'+settingTag+'\\Editor\\Highlight',\r\n                 key,false);\r\n      end; { ReadCPPB3OrMore }\r\n\r\n    begin { ReadCPPBSetting }\r\n      try\r\n        if (settingTag[1] = '1')\r\n          then Result := ReadCPPB1(settingTag,attri,key)\r\n          else Result := ReadCPPB3OrMore(settingTag,attri,key);\r\n      except Result := false; end;\r\n    end; { ReadCPPBSetting }\r\n\r\n  var\r\n    tmpStringAttri    : TSynHighlighterAttributes;\r\n    tmpNumberAttri    : TSynHighlighterAttributes;\r\n    tmpKeyAttri       : TSynHighlighterAttributes;\r\n    tmpSymbolAttri    : TSynHighlighterAttributes;\r\n    tmpAsmAttri       : TSynHighlighterAttributes;\r\n    tmpCommentAttri   : TSynHighlighterAttributes;\r\n    tmpIdentifierAttri: TSynHighlighterAttributes;\r\n    tmpInvalidAttri   : TSynHighlighterAttributes;\r\n    tmpSpaceAttri     : TSynHighlighterAttributes;\r\n    tmpDirecAttri     : TSynHighlighterAttributes;\r\n    s                 : TStringList;\r\n\r\n  begin { ReadCPPBSettings }\r\n    s := TStringList.Create;\r\n    try\r\n      EnumUserSettings(s);\r\n      if settingIndex >= s.Count then Result := false\r\n      else begin\r\n        tmpStringAttri    := TSynHighlighterAttributes.Create('', '');\r\n        tmpNumberAttri    := TSynHighlighterAttributes.Create('', '');\r\n        tmpKeyAttri       := TSynHighlighterAttributes.Create('', '');\r\n        tmpSymbolAttri    := TSynHighlighterAttributes.Create('', '');\r\n        tmpAsmAttri       := TSynHighlighterAttributes.Create('', '');\r\n        tmpCommentAttri   := TSynHighlighterAttributes.Create('', '');\r\n        tmpIdentifierAttri:= TSynHighlighterAttributes.Create('', '');\r\n        tmpInvalidAttri   := TSynHighlighterAttributes.Create('', '');\r\n        tmpSpaceAttri     := TSynHighlighterAttributes.Create('', '');\r\n        tmpDirecAttri     := TSynHighlighterAttributes.Create('', '');\r\n        tmpStringAttri    .Assign(fStringAttri);\r\n        tmpNumberAttri    .Assign(fNumberAttri);\r\n        tmpKeyAttri       .Assign(fKeyAttri);\r\n        tmpSymbolAttri    .Assign(fSymbolAttri);\r\n        tmpAsmAttri       .Assign(fAsmAttri);\r\n        tmpCommentAttri   .Assign(fCommentAttri);\r\n        tmpIdentifierAttri.Assign(fIdentifierAttri);\r\n        tmpInvalidAttri   .Assign(fInvalidAttri);\r\n        tmpSpaceAttri     .Assign(fSpaceAttri);\r\n        tmpDirecAttri     .Assign(fDirecAttri);\r\n        if s[settingIndex][1] = '1'\r\n          then Result := ReadCPPBSetting(s[settingIndex],fAsmAttri,'Plain text')\r\n          else Result := ReadCPPBSetting(s[settingIndex],fAsmAttri,'Assembler');\r\n        Result := Result                                                         and\r\n                  ReadCPPBSetting(s[settingIndex],fCommentAttri,'Comment')       and\r\n                  ReadCPPBSetting(s[settingIndex],fIdentifierAttri,'Identifier') and\r\n                  ReadCPPBSetting(s[settingIndex],fInvalidAttri,'Illegal Char')  and \r\n                  ReadCPPBSetting(s[settingIndex],fKeyAttri,'Reserved word')     and\r\n                  ReadCPPBSetting(s[settingIndex],fNumberAttri,'Integer')        and\r\n                  ReadCPPBSetting(s[settingIndex],fSpaceAttri,'Whitespace')      and\r\n                  ReadCPPBSetting(s[settingIndex],fStringAttri,'String')         and\r\n                  ReadCPPBSetting(s[settingIndex],fSymbolAttri,'Symbol')         and\r\n                  ReadCPPBSetting(s[settingIndex],fDirecAttri,'Preprocessor');\r\n        if not Result then begin\r\n          fStringAttri    .Assign(tmpStringAttri);\r\n          fNumberAttri    .Assign(tmpNumberAttri);\r\n          fKeyAttri       .Assign(tmpKeyAttri);\r\n          fSymbolAttri    .Assign(tmpSymbolAttri);\r\n          fAsmAttri       .Assign(tmpAsmAttri);\r\n          fCommentAttri   .Assign(tmpCommentAttri);\r\n          fIdentifierAttri.Assign(tmpIdentifierAttri);\r\n          fInvalidAttri.Assign(tmpInvalidAttri);\r\n          fSpaceAttri     .Assign(tmpSpaceAttri);\r\n          fDirecAttri     .Assign(tmpDirecAttri);\r\n        end;\r\n        tmpStringAttri    .Free;\r\n        tmpNumberAttri    .Free;\r\n        tmpKeyAttri       .Free;\r\n        tmpSymbolAttri    .Free;\r\n        tmpAsmAttri       .Free;\r\n        tmpCommentAttri   .Free;\r\n        tmpIdentifierAttri.Free;\r\n        tmpInvalidAttri   .Free;\r\n        tmpSpaceAttri     .Free;\r\n        tmpDirecAttri     .Free;\r\n      end;\r\n    finally s.Free; end;\r\n  end; { ReadCPPBSettings }\r\n  {$ENDIF}\r\n\r\nbegin\r\n  {$IFNDEF SYN_CLX}\r\n  Result := ReadCPPBSettings(settingIndex);\r\n  {$ELSE}\r\n  Result := False;\r\n  {$ENDIF}\r\nend; { TSynCSSyn.UseUserSettings }\r\n\r\nfunction TSynCSSyn.GetSampleSource: UnicodeString;\r\nbegin\r\n  Result := '/* Syntax Highlighting */'#13#10 +\r\n\t\t\t\t'int num = 12345;'#13#10 +\r\n\t\t\t\t'string str = \"Hello World\";'#13#10;\r\n\r\nend; { GetSampleSource }\r\n\r\nclass function TSynCSSyn.GetLanguageName: string;\r\nbegin\r\n  Result := SYNS_LangCS;\r\nend;\r\n\r\nfunction TSynCSSyn.IsFilterStored: boolean;\r\nbegin\r\n  Result := fDefaultFilter <> SYNS_FilterCS;\r\nend;\r\n\r\nclass function TSynCSSyn.GetCapabilities: TSynHighlighterCapabilities;\r\nbegin\r\n  Result := inherited GetCapabilities + [hcUserSettings];\r\nend;\r\n\r\nclass function TSynCSSyn.GetFriendlyLanguageName: UnicodeString;\r\nbegin\r\n  Result := SYNS_FriendlyLangCS;\r\nend;\r\n\r\ninitialization\r\n{$IFNDEF SYN_CPPB_1}\r\n  RegisterPlaceableHighlighter(TSynCSSyn);\r\n{$ENDIF}\r\nend.\r\n"
  },
  {
    "path": "External/SynEdit/Source/SynHighlighterCache.pas",
    "content": "{-------------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: SynHighlighterCache.pas, released 2000-04-21.\r\nThe Original Code is based on the mwCacheSyn.pas file from the\r\nmwEdit component suite by Martin Waldenburg and other developers, the Initial\r\nAuthor of this file is Pavel Krehula.\r\nUnicode translation by Mal Hrz.\r\nAll Rights Reserved.\r\n\r\nContributors to the SynEdit and mwEdit projects are listed in the\r\nContributors.txt file.\r\n\r\nAlternatively, the contents of this file may be used under the terms of the\r\nGNU General Public License Version 2 or later (the \"GPL\"), in which case\r\nthe provisions of the GPL are applicable instead of those above.\r\nIf you wish to allow use of your version of this file only under the terms\r\nof the GPL and not to allow others to use your version of this file\r\nunder the MPL, indicate your decision by deleting the provisions above and\r\nreplace them with the notice and other provisions required by the GPL.\r\nIf you do not delete the provisions above, a recipient may use your version\r\nof this file under either the MPL or the GPL.\r\n\r\n$Id: SynHighlighterCache.pas,v 1.13.2.6 2008/09/14 16:24:59 maelh Exp $\r\n\r\nYou may retrieve the latest version of this file at the SynEdit home page,\r\nlocated at http://SynEdit.SourceForge.net\r\n\r\nKnown Issues:\r\n-------------------------------------------------------------------------------}\r\n{\r\n@abstract(Provides a Cache object script files highlighter for SynEdit)\r\n@author(Pavel Krehula , converted to SynEdit by Bruno Mikkelsen )\r\n@created(1999-12-17, converted to SynEdit 2000-04-21)\r\n@lastmod(2000-06-23)\r\nThe SynHighlighterCache unit provides SynEdit with a Cache object script files highlighter.\r\nThanks to Martin Waldenburg.\r\n}\r\n\r\n{$IFNDEF QSYNHIGHLIGHTERCACHE}\r\nunit SynHighlighterCache;\r\n{$ENDIF}\r\n\r\n{$I SynEdit.inc}\r\n\r\ninterface\r\n\r\nuses\r\n{$IFDEF SYN_CLX}\r\n  QGraphics,\r\n  QSynEditTypes,\r\n  QSynEditHighlighter,\r\n  QSynUnicode,\r\n{$ELSE}\r\n  Graphics,\r\n  SynEditTypes,\r\n  SynEditHighlighter,\r\n  SynUnicode,\r\n{$ENDIF}\r\n  SysUtils,\r\n  Classes;\r\n\r\ntype\r\n  TtkTokenKind = (tkClass, tkComment, tkFunction, tkIdentifier, tkKey, tkNull,\r\n    tkNumber, tkDirective, tkSpace, tkString, tkSymbol, tkIndirect, tkLabel,\r\n    tkMacro, tkUserFunction, tkEmbedSQL, tkEmbedText, tkUnknown);\r\n\r\n  TRangeState = (rsUnKnown, rsSQL, rsHTML, rsCommand);\r\n\r\n  PIdentFuncTableFunc = ^TIdentFuncTableFunc;\r\n  TIdentFuncTableFunc = function (Index: Integer): TtkTokenKind of object;\r\n\r\ntype\r\n  TSynCacheSyn = class(TSynCustomHighlighter)\r\n  private\r\n    fBrace: LongInt;\r\n    fFirstBrace: Boolean;\r\n    fRange: TRangeState;\r\n    FTokenID: TtkTokenKind;\r\n    fIdentFuncTable: array[0..1996] of TIdentFuncTableFunc;\r\n    fClassAttri: TSynHighlighterAttributes;\r\n    fCommentAttri: TSynHighlighterAttributes;\r\n    fFunctionAttri: TSynHighlighterAttributes;\r\n    fIdentifierAttri: TSynHighlighterAttributes;\r\n    fKeyAttri: TSynHighlighterAttributes;\r\n    fNumberAttri: TSynHighlighterAttributes;\r\n    fDirectiveAttri: TSynHighlighterAttributes;\r\n    fSpaceAttri: TSynHighlighterAttributes;\r\n    fStringAttri: TSynHighlighterAttributes;\r\n    fSymbolAttri: TSynHighlighterAttributes;\r\n    fIndirectAttri: TSynHighlighterAttributes;\r\n    fLabelAttri: TSynHighlighterAttributes;\r\n    fMacroAttri: TSynHighlighterAttributes;\r\n    fUserFunctionAttri: TSynHighlighterAttributes;\r\n    fEmbedSQLAttri: TSynHighlighterAttributes;\r\n    fEmbedTextAttri: TSynHighlighterAttributes;\r\n    FCanKey: boolean;    // if true, the next token can be a keyword\r\n    function AltFunc(Index: Integer): TtkTokenKind;\r\n    function KeyWordFunc(Index: Integer): TtkTokenKind;\r\n    function Func38html(Index: Integer): TtkTokenKind;\r\n    function Func38sql(Index: Integer): TtkTokenKind;\r\n    function HashKey(Str: PWideChar): Cardinal;\r\n    function IdentKind(MayBe: PWideChar): TtkTokenKind;\r\n    procedure InitIdent;\r\n    procedure CRProc;\r\n    procedure CommentProc;\r\n    procedure IdentProc;\r\n    procedure LFProc;\r\n    procedure NullProc;\r\n    procedure NumberProc;\r\n    procedure SpaceProc;\r\n    procedure StringProc;\r\n    procedure UnknownProc;\r\n    procedure IndirectProc;\r\n    procedure SymbolProc;\r\n    procedure FuncProc;\r\n    procedure DirectiveProc;\r\n    procedure EmbeddedProc;\r\n  protected\r\n    function IsFilterStored: Boolean; override;\r\n  public\r\n    class function GetLanguageName: string; override;\r\n    class function GetFriendlyLanguageName: UnicodeString; override;\r\n  public\r\n    constructor Create(AOwner: TComponent); override;\r\n    function GetDefaultAttribute(Index: integer): TSynHighlighterAttributes;\r\n      override;\r\n    function GetEol: Boolean; override;\r\n    function GetRange: Pointer; override;\r\n    function GetTokenID: TtkTokenKind;\r\n    function GetTokenAttribute: TSynHighlighterAttributes; override;\r\n    function GetTokenKind: integer; override;\r\n    function IsIdentChar(AChar: WideChar): Boolean; override;\r\n    procedure Next; override;\r\n    procedure SetRange(Value: Pointer); override;\r\n    procedure ResetRange; override;\r\n  published\r\n    property ClassAttri: TSynHighlighterAttributes read fClassAttri\r\n      write fClassAttri;\r\n    property CommentAttri: TSynHighlighterAttributes read fCommentAttri\r\n      write fCommentAttri;\r\n    property FunctionAttri: TSynHighlighterAttributes read fFunctionAttri\r\n      write fFunctionAttri;\r\n    property IdentifierAttri: TSynHighlighterAttributes read fIdentifierAttri\r\n      write fIdentifierAttri;\r\n    property KeyAttri: TSynHighlighterAttributes read fKeyAttri write fKeyAttri;\r\n    property NumberAttri: TSynHighlighterAttributes read fNumberAttri\r\n      write fNumberAttri;\r\n    property PreprocesorAttri: TSynHighlighterAttributes read fDirectiveAttri\r\n      write fDirectiveAttri;\r\n    property SpaceAttri: TSynHighlighterAttributes read fSpaceAttri\r\n      write fSpaceAttri;\r\n    property StringAttri: TSynHighlighterAttributes read fStringAttri\r\n      write fStringAttri;\r\n    property SymbolAttri: TSynHighlighterAttributes read fSymbolAttri\r\n      write fSymbolAttri;\r\n    property IndirectAttri: TSynHighlighterAttributes read fIndirectAttri\r\n      write fIndirectAttri;\r\n    property LabelAttri: TSynHighlighterAttributes read fLabelAttri\r\n      write fLabelAttri;\r\n    property MacroAttri: TSynHighlighterAttributes read fMacroAttri\r\n      write fMacroAttri;\r\n    property UserFunctionAttri: TSynHighlighterAttributes\r\n      read fUserFunctionAttri write fUserFunctionAttri;\r\n    property EmbededSQLandHTMLAttri: TSynHighlighterAttributes\r\n      read fEmbedSQLAttri write fEmbedSQLAttri;\r\n    property EmbededTextAttri: TSynHighlighterAttributes read fEmbedTextAttri\r\n      write fEmbedTextAttri;\r\n  end;\r\n\r\nimplementation\r\n\r\nuses\r\n{$IFDEF SYN_CLX}\r\n  QSynEditStrConst;\r\n{$ELSE}\r\n  SynEditStrConst;\r\n{$ENDIF}\r\n\r\nconst\r\n  KeyWords: array[0..274] of UnicodeString = (\r\n    '$a', '$ascii', '$c', '$char', '$d', '$data', '$device', '$e', '$ec', \r\n    '$ecode', '$es', '$estack', '$et', '$etrap', '$extract', '$f', '$find', \r\n    '$fn', '$fnumber', '$g', '$get', '$h', '$horolog', '$i', '$in', \r\n    '$increment', '$inumber', '$io', '$j', '$job', '$justify', '$k', '$key', \r\n    '$l', '$lb', '$ld', '$length', '$lf', '$lg', '$li', '$list', '$listbuild', \r\n    '$listdata', '$listfind', '$listget', '$listlength', '$ll', '$n', '$na', \r\n    '$name', '$next', '$o', '$order', '$p', '$piece', '$principal', '$q', '$ql', \r\n    '$qlength', '$qs', '$qsubscript', '$query', '$quit', '$r', '$random', '$re', \r\n    '$reverse', '$s', '$select', '$st', '$stack', '$storage', '$t', '$test', \r\n    '$text', '$tl', '$tlevel', '$tr', '$translate', '$vi', '$view', '$x', '$y', \r\n    '$za', '$zabs', '$zarccos', '$zarcsin', '$zarctan', '$zb', '$zbitand', \r\n    '$zbitcount', '$zbitfind', '$zbitget', '$zbitlen', '$zbitnot', '$zbitor', \r\n    '$zbitset', '$zbitstr', '$zbitxor', '$zboolean', '$zc', '$zchild', \r\n    '$zconvert', '$zcos', '$zcot', '$zcrc', '$zcsc', '$zcvt', '$zcyc', '$zdate', \r\n    '$zdateh', '$zdatetime', '$zdatetimeh', '$ze', '$zeof', '$zerr', '$zerror', \r\n    '$zexp', '$zf', '$zh', '$zhex', '$zhorolog', '$zi', '$zincr', '$zincrement', \r\n    '$zio', '$zis', '$ziswide', '$zjob', '$zla', '$zlascii', '$zlc', '$zlchar', \r\n    '$zln', '$zlog', '$zmode', '$zn', '$zname', '$znext', '$znspace', '$zo', \r\n    '$zorder', '$zp', '$zparent', '$zpi', '$zpos', '$zposition', '$zpower', \r\n    '$zprevious', '$zr', '$zreference', '$zs', '$zse', '$zsearch', '$zsec', \r\n    '$zseek', '$zsin', '$zsort', '$zsqr', '$zstorage', '$zstrip', '$zt', \r\n    '$ztan', '$zth', '$ztime', '$ztimeh', '$ztimestamp', '$ztrap', '$zts', \r\n    '$zu', '$zutil', '$zv', '$zversion', '$zw', '$zwa', '$zwascii', '$zwbp', \r\n    '$zwbpack', '$zwbunp', '$zwbunpack', '$zwc', '$zwchar', '$zwidth', '$zwp', \r\n    '$zwpack', '$zwunp', '$zwunpack', '$zz', '$zzdec', '$zzenkaku', '$zzhex', \r\n    '&html', '&sql', '^$g', '^$global', '^$j', '^$job', '^$l', '^$lock', '^$r', \r\n    '^$routine', 'b', 'break', 'c', 'close', 'd', 'do', 'e', 'else', 'f', 'for', \r\n    'g', 'goto', 'h', 'halt', 'hang', 'i', 'if', 'j', 'job', 'k', 'kill', 'l', \r\n    'lock', 'm', 'merge', 'n', 'new', 'o', 'open', 'p', 'print', 'q', 'quit', \r\n    'r', 'read', 's', 'set', 'tc', 'tcommint', 'tro', 'trollback', 'ts', \r\n    'tstart', 'u', 'use', 'vi', 'view', 'w', 'write', 'x', 'xecute', 'zb', \r\n    'zbreak', 'zi', 'zinsert', 'zk', 'zkill', 'zl', 'zload', 'zn', 'znspace', \r\n    'zp', 'zprint', 'zq', 'zquit', 'zr', 'zremove', 'zs', 'zsave', 'zsync', \r\n    'ztrap', 'zw', 'zwrite', 'zzdump' \r\n  );\r\n\r\n  KeyIndices: array[0..1996] of Integer = (\r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 139, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, 186, -1, -1, -1, -1, -1, -1, -1, 153, -1, 232, -1, \r\n    212, 74, -1, -1, -1, -1, -1, 178, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, 265, -1, -1, -1, 19, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 77, -1, -1, -1, -1, -1, -1, 272, \r\n    259, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 234, -1, -1, -1, \r\n    187, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 198, 246, -1, -1, -1, \r\n    24, -1, -1, -1, -1, -1, -1, -1, -1, -1, 21, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, 76, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 236, -1, 206, 210, -1, -1, 181, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 221, -1, -1, 27, -1, -1, -1, \r\n    9, -1, -1, -1, -1, -1, 23, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    25, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 116, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, 58, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, 28, -1, -1, 137, -1, -1, -1, -1, -1, -1, 183, -1, -1, -1, 18, 49, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, 32, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, 244, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 83, -1, -1, \r\n    -1, -1, 102, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 242, 108, 31, -1, \r\n    -1, 93, -1, -1, -1, -1, -1, -1, 274, -1, -1, -1, -1, -1, -1, 128, -1, -1, \r\n    -1, -1, -1, 8, -1, -1, -1, -1, 191, -1, -1, 5, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, 17, -1, -1, -1, 88, -1, -1, -1, -1, 66, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 249, -1, 33, -1, -1, 185, 59, \r\n    -1, -1, -1, -1, -1, -1, 124, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, 193, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 248, -1, -1, \r\n    -1, 117, -1, -1, 84, -1, -1, -1, -1, -1, 100, -1, 133, -1, -1, 245, -1, -1, \r\n    -1, 257, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, 255, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, 3, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 250, -1, -1, -1, 152, -1, -1, \r\n    -1, -1, 239, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, 47, -1, -1, 22, 114, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, 247, -1, 86, 68, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, 252, -1, 80, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 6, -1, -1, -1, \r\n    -1, 113, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, 51, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, 195, -1, -1, -1, -1, -1, -1, 44, -1, -1, -1, \r\n    -1, 65, -1, 175, -1, -1, 99, -1, -1, -1, -1, -1, -1, -1, -1, 118, -1, -1, \r\n    -1, -1, -1, 95, 121, -1, 92, 188, -1, -1, -1, -1, -1, -1, -1, -1, 53, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, 156, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, 164, 240, -1, -1, -1, -1, -1, 202, -1, 130, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, 179, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    157, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 168, -1, -1, 56, -1, -1, -1, \r\n    -1, 1, -1, -1, -1, -1, 223, -1, -1, -1, -1, -1, -1, -1, -1, -1, 225, -1, -1, \r\n    -1, -1, -1, 197, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    125, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 119, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, 64, -1, -1, -1, -1, -1, -1, 63, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 55, -1, -1, \r\n    -1, -1, -1, 145, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    106, -1, -1, -1, -1, -1, -1, -1, 122, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, 67, -1, -1, -1, -1, 85, -1, -1, -1, 261, \r\n    -1, 182, -1, -1, -1, -1, -1, -1, -1, 41, -1, -1, -1, 158, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 26, 154, -1, -1, -1, -1, \r\n    -1, 201, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 91, 69, -1, -1, \r\n    -1, -1, -1, -1, -1, 72, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 34, -1, \r\n    -1, -1, -1, 123, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 251, -1, \r\n    -1, -1, 176, -1, -1, -1, -1, -1, 270, -1, -1, -1, -1, -1, -1, -1, 203, -1, \r\n    -1, -1, -1, -1, -1, 165, -1, -1, -1, 184, -1, -1, -1, -1, -1, -1, -1, 190, \r\n    103, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 120, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, 20, -1, -1, -1, -1, -1, -1, -1, -1, 144, -1, -1, \r\n    254, -1, -1, -1, -1, -1, -1, -1, 126, -1, -1, -1, -1, -1, -1, 205, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 192, -1, -1, -1, 104, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, 196, -1, -1, -1, -1, 35, -1, -1, -1, -1, \r\n    115, -1, -1, -1, -1, -1, -1, 134, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, 253, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 207, -1, -1, 166, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 231, -1, \r\n    -1, -1, -1, -1, 143, -1, 238, -1, -1, -1, -1, -1, 43, -1, -1, -1, -1, -1, \r\n    174, -1, -1, -1, -1, -1, 109, 199, -1, -1, -1, -1, -1, -1, 256, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 209, -1, -1, -1, 136, -1, -1, \r\n    -1, -1, -1, -1, 11, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 81, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, 37, -1, -1, -1, -1, -1, -1, -1, -1, 267, \r\n    -1, 96, -1, -1, -1, -1, -1, -1, -1, 148, -1, 258, -1, -1, -1, -1, -1, 150, \r\n    -1, -1, -1, -1, 90, -1, -1, -1, 211, -1, -1, -1, 140, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, 208, -1, -1, -1, -1, -1, -1, -1, -1, 13, 82, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, 38, 45, -1, -1, -1, -1, -1, 180, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, 213, -1, -1, -1, 142, -1, -1, -1, 189, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, 48, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, 273, 147, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 89, -1, \r\n    172, -1, 177, -1, -1, 260, 112, -1, -1, -1, -1, -1, 40, -1, -1, -1, -1, -1, \r\n    36, -1, 216, 61, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, 241, -1, -1, -1, -1, -1, -1, -1, -1, 243, -1, -1, -1, -1, -1, -1, 110, \r\n    39, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 10, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, 215, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 194, -1, -1, 218, \r\n    54, -1, -1, 149, -1, -1, -1, -1, -1, -1, -1, 167, -1, -1, 129, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 132, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, 12, -1, 135, -1, -1, 30, -1, -1, -1, 70, \r\n    262, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 220, -1, -1, \r\n    -1, 151, -1, 170, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 101, -1, 14, \r\n    -1, -1, 42, -1, -1, -1, -1, -1, 263, -1, -1, 0, -1, -1, 94, -1, -1, -1, -1, \r\n    -1, -1, 105, -1, -1, -1, -1, -1, -1, 75, -1, -1, -1, -1, -1, -1, 264, -1, \r\n    -1, -1, -1, 98, -1, -1, -1, -1, -1, -1, -1, -1, -1, 222, -1, -1, -1, 161, \r\n    -1, -1, 200, -1, -1, -1, -1, -1, -1, 71, 131, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 237, -1, 46, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, 204, -1, -1, -1, -1, -1, -1, -1, 266, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 224, -1, -1, 217, 169, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 229, 235, -1, \r\n    233, -1, -1, -1, -1, -1, -1, 2, -1, -1, -1, -1, -1, -1, 141, -1, -1, -1, -1, \r\n    -1, 62, -1, -1, 155, 97, -1, -1, -1, -1, -1, -1, 268, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, 159, 226, -1, 73, -1, 171, -1, -1, 271, -1, \r\n    107, -1, 127, -1, -1, -1, -1, -1, -1, -1, -1, 227, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, 4, -1, 87, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 29, -1, -1, -1, \r\n    146, -1, 138, -1, -1, -1, 228, -1, -1, -1, 173, -1, -1, -1, 50, -1, -1, 78, \r\n    -1, -1, -1, 60, -1, 219, -1, -1, 269, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    52, -1, 7, -1, -1, -1, 57, 79, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, 111, -1, -1, -1, -1, -1, -1, -1, 160, -1, \r\n    -1, -1, 214, -1, 230, -1, -1, -1, -1, 16, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 162, -1, -1, 163, -1, -1, \r\n    15, -1, -1, -1 \r\n  );\r\n\r\n{$Q-}\r\nfunction TSynCacheSyn.HashKey(Str: PWideChar): Cardinal;\r\nbegin\r\n  Result := 0;\r\n  while IsIdentChar(Str^) do\r\n  begin\r\n    Result := Result * 355 + Ord(Str^) * 71;\r\n    inc(Str);\r\n  end;\r\n  Result := Result mod 1997;\r\n  fStringLen := Str - fToIdent;\r\nend;\r\n{$Q+}\r\n\r\nfunction TSynCacheSyn.IdentKind(MayBe: PWideChar): TtkTokenKind;\r\nvar\r\n  Key: Cardinal;\r\nbegin\r\n  fToIdent := MayBe;\r\n  Key := HashKey(MayBe);\r\n  if Key <= High(fIdentFuncTable) then\r\n    Result := fIdentFuncTable[Key](KeyIndices[Key])\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nprocedure TSynCacheSyn.InitIdent;\r\nvar\r\n  i: Integer;\r\nbegin\r\n  for i := Low(fIdentFuncTable) to High(fIdentFuncTable) do\r\n    if KeyIndices[i] = -1 then\r\n      fIdentFuncTable[i] := AltFunc;\r\n\r\n  fIdentFuncTable[379] := Func38html;\r\n  fIdentFuncTable[1125] := Func38sql;\r\n\r\n  for i := Low(fIdentFuncTable) to High(fIdentFuncTable) do\r\n    if @fIdentFuncTable[i] = nil then\r\n      fIdentFuncTable[i] := KeyWordFunc;\r\nend;\r\n\r\nfunction TSynCacheSyn.AltFunc(Index: Integer): TtkTokenKind;\r\nbegin\r\n  Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynCacheSyn.KeyWordFunc(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier\r\nend;\r\n\r\nfunction TSynCacheSyn.Func38html(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n  begin\r\n    Result := tkEmbedSQL;\r\n    fRange := rsHTML;\r\n  end\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynCacheSyn.Func38sql(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n  begin\r\n    Result := tkEmbedSQL;\r\n    fRange := rsSQL;\r\n  end\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nconstructor TSynCacheSyn.Create(AOwner: TComponent);\r\nbegin\r\n  inherited Create(AOwner);\r\n\r\n  fCaseSensitive := False;\r\n\r\n  fClassAttri := TSynHighlighterAttributes.Create(SYNS_AttrClass, SYNS_FriendlyAttrClass);\r\n  AddAttribute(fClassAttri);\r\n  fCommentAttri := TSynHighlighterAttributes.Create(SYNS_AttrComment, SYNS_FriendlyAttrComment);\r\n  fCommentAttri.Style := [fsItalic];\r\n  AddAttribute(fCommentAttri);\r\n  fFunctionAttri := TSynHighlighterAttributes.Create(SYNS_AttrFunction, SYNS_FriendlyAttrFunction);\r\n  AddAttribute(fFunctionAttri);\r\n  fIdentifierAttri := TSynHighlighterAttributes.Create(SYNS_AttrIdentifier, SYNS_FriendlyAttrIdentifier);\r\n  AddAttribute(fIdentifierAttri);\r\n  fKeyAttri := TSynHighlighterAttributes.Create(SYNS_AttrReservedWord, SYNS_FriendlyAttrReservedWord);\r\n  fKeyAttri.Style := [fsBold];\r\n  AddAttribute(fKeyAttri);\r\n  fNumberAttri := TSynHighlighterAttributes.Create(SYNS_AttrNumber, SYNS_FriendlyAttrNumber);\r\n  AddAttribute(fNumberAttri);\r\n  fDirectiveAttri := TSynHighlighterAttributes.Create(SYNS_AttrDir, SYNS_FriendlyAttrDir);\r\n  AddAttribute(fDirectiveAttri);\r\n  fSpaceAttri := TSynHighlighterAttributes.Create(SYNS_AttrSpace, SYNS_FriendlyAttrSpace);\r\n  AddAttribute(fSpaceAttri);\r\n  fStringAttri := TSynHighlighterAttributes.Create(SYNS_AttrString, SYNS_FriendlyAttrString);\r\n  AddAttribute(fStringAttri);\r\n  fSymbolAttri := TSynHighlighterAttributes.Create(SYNS_AttrSymbol, SYNS_FriendlyAttrSymbol);\r\n  AddAttribute(fSymbolAttri);\r\n  fIndirectAttri := TSynHighlighterAttributes.Create(SYNS_AttrIndirect, SYNS_FriendlyAttrIndirect);\r\n  AddAttribute(fIndirectAttri);\r\n  fLabelAttri := TSynHighlighterAttributes.Create(SYNS_AttrLabel, SYNS_FriendlyAttrLabel);\r\n  AddAttribute(fLabelAttri);\r\n  fMacroAttri := TSynHighlighterAttributes.Create(SYNS_AttrMacro, SYNS_FriendlyAttrMacro);\r\n  AddAttribute(fMacroAttri);\r\n  fUserFunctionAttri := TSynHighlighterAttributes.Create(SYNS_AttrUserFunction, SYNS_FriendlyAttrUserFunction);\r\n  AddAttribute(fUserFunctionAttri);\r\n  fEmbedSQLAttri := TSynHighlighterAttributes.Create(SYNS_AttrEmbedSQL, SYNS_FriendlyAttrEmbedSQL);\r\n  AddAttribute(fEmbedSQLAttri);\r\n  fEmbedTextAttri := TSynHighlighterAttributes.Create(SYNS_AttrEmbedText, SYNS_FriendlyAttrEmbedText);\r\n  AddAttribute(fEmbedTextAttri);\r\n\r\n  SetAttributesOnChange(DefHighlightChange);\r\n  InitIdent;\r\n  fDefaultFilter := SYNS_FilterCache;\r\n  fRange := rsUnknown;\r\nend;\r\n\r\nprocedure TSynCacheSyn.CRProc;\r\nbegin\r\n  fTokenID := tkSpace;\r\n  inc(Run);\r\n  if fLine[Run] = #10 then inc(Run);\r\n  FRange := rsUnknown;\r\nend;\r\n\r\nprocedure TSynCacheSyn.CommentProc;\r\nbegin\r\n  fTokenID := tkComment;\r\n  if FLine[Run+1]=';' then fTokenID := tkEmbedText;\r\n\r\n  while FLine[Run] <> #0 do  begin\r\n    case FLine[Run] of\r\n      #10, #13: break;\r\n    end;\r\n    inc(Run);\r\n  end;\r\nend;\r\n\r\n//------------------------------------------------------------------------------\r\n//    higlight keywords and identifiers\r\n//------------------------------------------------------------------------------\r\nprocedure TSynCacheSyn.IdentProc;\r\nvar\r\n  fir: WideChar;\r\nbegin\r\n  if FTokenPos=0 then fTokenID := tkLabel\r\n  else begin\r\n    fir := FLine[Run];\r\n    if fir = '^' then FCanKey := true;\r\n\r\n    FRange := rsUnknown;\r\n    if FCanKey then\r\n      fTokenID := IdentKind(fLine + Run)\r\n    else\r\n    begin\r\n      fTokenID := tkIdentifier;\r\n      while IsIdentChar(fLine[Run]) do inc(Run);\r\n      exit;\r\n    end;\r\n    FRange := rsCommand;\r\n    inc(Run, fStringLen);\r\n    if not (IsLineEnd(Run) or CharInSet(fLine[Run], [#32, ':'])) and (fir <> '^') then\r\n    begin\r\n      fTokenID := tkIdentifier;\r\n    end\r\n  end;\r\n  while IsIdentChar(fLine[Run]) do inc(Run);\r\nend;\r\n\r\nprocedure TSynCacheSyn.LFProc;\r\nbegin\r\n  fTokenID := tkSpace;\r\n  FCanKey := true;\r\n  inc(Run);\r\nend;\r\n\r\nprocedure TSynCacheSyn.NullProc;\r\nbegin\r\n  fTokenID := tkNull;\r\n  inc(Run);\r\nend;\r\n\r\nprocedure TSynCacheSyn.NumberProc;\r\n\r\n  function IsNumberChar: Boolean;\r\n  begin\r\n    case fLine[Run] of\r\n      '0'..'9', '.', 'e', 'E':\r\n        Result := True;\r\n      else\r\n        Result := False;\r\n    end;\r\n  end;\r\n\r\nbegin\r\n  if (fTokenPos = 0) and CharInSet(FLine[Run], ['0'..'9']) then\r\n  begin\r\n    fTokenID := tkLabel;\r\n    while IsIdentChar(fLine[Run]) do inc(Run);\r\n    FCanKey := false;\r\n    exit;\r\n  end;\r\n\r\n  inc(Run);\r\n  fTokenID := tkNumber;\r\n  while IsNumberChar do\r\n  begin\r\n    case FLine[Run] of\r\n      '.':  if FLine[Run + 1] = '.' then break;\r\n    end;\r\n    inc(Run);\r\n  end;\r\n  FRange := rsUnknown;\r\nend;\r\n\r\nprocedure TSynCacheSyn.SpaceProc;\r\nvar\r\n  x: integer;\r\nbegin\r\n  x := Run;\r\n  inc(Run);\r\n  fTokenID := tkSpace;\r\n  while (FLine[Run] <= #32) and not IsLineEnd(Run) do inc(Run);\r\n  FCanKey := true;\r\n  if FRange = rsCommand then\r\n    FCanKey := (Run - x > 1);\r\nend;\r\n\r\nprocedure TSynCacheSyn.StringProc;\r\nbegin\r\n  fTokenID := tkString;\r\n  if (FLine[Run + 1] = #34) and (FLine[Run + 2] = #34) then inc(Run, 2);\r\n  repeat\r\n    case FLine[Run] of\r\n      #0, #10, #13: break;\r\n    end;\r\n    inc(Run);\r\n  until FLine[Run] = #34;\r\n  if FLine[Run] <> #0 then inc(Run);\r\n  FRange := rsUnknown;\r\nend;\r\n\r\nprocedure TSynCacheSyn.UnknownProc;\r\nbegin\r\n  inc(Run);\r\n  fTokenID := tkUnknown;\r\nend;\r\n\r\nprocedure TSynCacheSyn.Next;\r\nbegin\r\n  fTokenPos := Run;\r\n  if FLine[Run] = #0 then NullProc\r\n  else\r\n    case fRange of\r\n      rsSQL,\r\n      rsHTML: EmbeddedProc;\r\n      else\r\n        case fLine[Run] of\r\n          #13: CRProc;\r\n          ';': CommentProc;\r\n          'A'..'Z', 'a'..'z', '%', '^': IdentProc;\r\n          '$': FuncProc;\r\n          '@': IndirectProc;\r\n          #10: LFProc;\r\n          #0: NullProc;\r\n          '0'..'9': NumberProc;\r\n          #1..#9, #11, #12, #14..#32: SpaceProc;\r\n          #34: StringProc;\r\n          '(',')','+','-','[',']','.','<','>','''','=',',',':','/','\\',\r\n          '?','!','_','*': SymbolProc;\r\n          '#': DirectiveProc;\r\n          '&': EmbeddedProc;\r\n          else UnknownProc;\r\n        end;\r\n    end;\r\n  inherited;\r\nend;\r\n\r\nfunction TSynCacheSyn.GetDefaultAttribute(Index: integer): TSynHighlighterAttributes;\r\nbegin\r\n  case Index of\r\n    SYN_ATTR_COMMENT: Result := fCommentAttri;\r\n    SYN_ATTR_KEYWORD: Result := fKeyAttri;\r\n    SYN_ATTR_WHITESPACE: Result := fSpaceAttri;\r\n    SYN_ATTR_SYMBOL: Result := fSymbolAttri;\r\n  else\r\n    Result := nil;\r\n  end;\r\nend;\r\n\r\nfunction TSynCacheSyn.GetEol: Boolean;\r\nbegin\r\n  Result := Run = fLineLen + 1;\r\nend;\r\n\r\nfunction TSynCacheSyn.GetRange: Pointer;\r\nbegin\r\n  Result := Pointer(fRange);\r\nend;\r\n\r\nfunction TSynCacheSyn.GetTokenID: TtkTokenKind;\r\nbegin\r\n  Result := fTokenId;\r\nend;\r\n\r\nfunction TSynCacheSyn.GetTokenAttribute: TSynHighlighterAttributes;\r\nbegin\r\n  case GetTokenID of\r\n    tkClass: Result := fClassAttri;\r\n    tkComment: Result := fCommentAttri;\r\n    tkFunction: Result := fFunctionAttri;\r\n    tkIdentifier: Result := fIdentifierAttri;\r\n    tkKey: Result := fKeyAttri;\r\n    tkNumber: Result := fNumberAttri;\r\n    tkDirective: Result := fDirectiveAttri;\r\n    tkSpace: Result := fSpaceAttri;\r\n    tkString: Result := fStringAttri;\r\n    tkSymbol: Result := fSymbolAttri;\r\n    tkIndirect: Result := fIndirectAttri;\r\n    tkUnknown: Result := fIdentifierAttri;\r\n    tkLabel: Result := fLabelAttri;\r\n    tkMacro: Result := fMacroAttri;\r\n    tkUserFunction: Result := fUserFunctionAttri;\r\n    tkEmbedSQL: Result := fEmbedSQLAttri;\r\n    tkEmbedText: Result := fEmbedTextAttri;\r\n  else Result := nil;\r\n  end;\r\nend;\r\n\r\nfunction TSynCacheSyn.GetTokenKind: integer;\r\nbegin\r\n  Result := Ord(fTokenId);\r\nend;\r\n\r\nprocedure TSynCacheSyn.ResetRange;\r\nbegin\r\n  fRange := rsUnknown;\r\nend;\r\n\r\nprocedure TSynCacheSyn.SetRange(Value: Pointer);\r\nbegin\r\n  fRange := TRangeState(Value);\r\nend;\r\n\r\nfunction TSynCacheSyn.IsFilterStored: Boolean;\r\nbegin\r\n  Result := fDefaultFilter <> SYNS_FilterCache;\r\nend;\r\n\r\nfunction TSynCacheSyn.IsIdentChar(AChar: WideChar): Boolean;\r\nbegin\r\n  case AChar of\r\n    '0'..'9', 'a'..'z', 'A'..'Z', '%', '^', '$', '&':\r\n      Result := True;\r\n    else\r\n      Result := False;\r\n  end;\r\nend;\r\n\r\nclass function TSynCacheSyn.GetLanguageName: string;\r\nbegin\r\n  Result := SYNS_LangCache;\r\nend;\r\n\r\n//------------------------------------------------------------------------------\r\n//   highlight indirection syntax:   @ident\r\n//------------------------------------------------------------------------------\r\nprocedure TSynCacheSyn.IndirectProc;\r\nbegin\r\n  fTokenID := tkIndirect;\r\n  inc(Run);\r\n  while IsIdentChar(FLine[Run]) do inc(Run);\r\n  FRange := rsUnknown;\r\nend;\r\n\r\n//------------------------------------------------------------------------------\r\n//  highlight symbols\r\n//------------------------------------------------------------------------------\r\nprocedure TSynCacheSyn.SymbolProc;\r\nbegin\r\n  fTokenID := tkSymbol;\r\n  inc(Run);\r\n  FRange := rsUnknown;\r\nend;\r\n\r\n//------------------------------------------------------------------------------\r\n//  highlight user defined functions and macros\r\n//              function:   $$ident\r\n//              macro   :   $$$ident\r\n//------------------------------------------------------------------------------\r\nprocedure TSynCacheSyn.FuncProc;\r\nbegin\r\n  case FLine[Run] of\r\n    '$': case FLine[Run + 1] of\r\n           '$': case Fline[Run + 2] of\r\n                  '$': fTokenID := tkMacro;\r\n                  else fTokenID := tkUserFunction;\r\n                end;\r\n           else begin\r\n                  fTokenID := IdentKind((fLine + Run));\r\n                  inc(Run, fStringLen);\r\n                  if fTokenID = tkKey then fTokenID := tkFunction;\r\n                end;\r\n         end;\r\n    else fTokenID := tkIdentifier;\r\n  end;\r\n  while IsIdentChar(fLine[Run]) do inc(Run);\r\n  FRange := rsUnknown;\r\nend;\r\n\r\n//------------------------------------------------------------------------------\r\n//    highlight preprocesor directives and class syntax\r\n//              preprocesor:  #identifier\r\n//              class      :  ##class\r\n//------------------------------------------------------------------------------\r\nprocedure TSynCacheSyn.DirectiveProc;\r\nvar\r\n  i: integer;\r\nbegin\r\n  if FLine[Run + 1] = '#' then\r\n    fTokenID := tkClass\r\n  else\r\n  begin\r\n    for i := fTokenPos downto 0 do\r\n      if not CharInSet(FLine[i], [#32, '#']) then\r\n      begin\r\n        fTokenID := tkSymbol;\r\n        inc(Run);\r\n        exit;\r\n      end;\r\n\r\n    fTokenID := tkDirective\r\n  end;\r\n\r\n  inc(Run);\r\n  while IsIdentChar(fLine[Run]) or (FLine[Run] = '#') do inc(Run);\r\n  FRange := rsUnknown;\r\nend;\r\n\r\n//------------------------------------------------------------------------------\r\n//  highlight embeded SQL and HTML\r\n//                SQL  :    &sql( .... )\r\n//                HTML :    &html<   ..... >\r\n//------------------------------------------------------------------------------\r\nprocedure TSynCacheSyn.EmbeddedProc;\r\nbegin\r\n  case fRange of\r\n    rsUnknown, rsCommand: begin\r\n                 fTokenID := IdentKind( (fLine + Run) );\r\n                 if fTokenID <> tkEmbedSQL then begin\r\n                   fTokenID := tkSymbol;\r\n                   inc( Run );\r\n                 end else begin\r\n                   fBrace := 1;\r\n                   fFirstBrace := true;\r\n                   inc( Run, fStringLen );\r\n                 end;\r\n               end;\r\n    rsSQL: begin\r\n             fTokenID := tkEmbedSQL;\r\n             while (FLine[Run] <> #0) and (fBrace<>0) do begin\r\n               case FLine[Run] of\r\n                 '(': if not fFirstBrace then inc(fBrace)\r\n                      else fFirstBrace := false;\r\n                 ')': dec(fBrace);\r\n               end;\r\n               inc(Run);\r\n             end;\r\n             if fBrace=0 then fRange := rsUnknown;\r\n           end;\r\n    rsHTML: begin\r\n              fTokenID := tkEmbedSQL;\r\n              while (FLine[Run] <> #0) and (fBrace<>0) do begin\r\n                case FLine[Run] of\r\n                  '<': if not fFirstBrace then inc(fBrace)\r\n                       else fFirstBrace := false;\r\n                  '>': dec(fBrace);\r\n                end;\r\n                inc(Run);\r\n              end;\r\n              if fBrace=0 then fRange := rsUnknown;\r\n            end;\r\n  end;\r\nend;\r\n\r\nclass function TSynCacheSyn.GetFriendlyLanguageName: UnicodeString;\r\nbegin\r\n  Result := SYNS_FriendlyLangCache;\r\nend;\r\n\r\ninitialization\r\n{$IFNDEF SYN_CPPB_1}\r\n  RegisterPlaceableHighlighter(TSynCacheSyn);\r\n{$ENDIF}\r\nend.\r\n"
  },
  {
    "path": "External/SynEdit/Source/SynHighlighterCobol.pas",
    "content": "{-------------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nCode template generated with SynGen.\r\nThe original code is: SynHighlighterCobol.pas, released 2002-08-26.\r\nDescription: COBOL Syntax Parser/Highlighter\r\nThe author of this file is Andrey Ustinov.\r\nCopyright (c) 2002 Software Mining, http://www.softwaremining.com/.\r\nUnicode translation by Mal Hrz.\r\nAll rights reserved.\r\n\r\nContributors to the SynEdit and mwEdit projects are listed in the\r\nContributors.txt file.\r\n\r\nAlternatively, the contents of this file may be used under the terms of the\r\nGNU General Public License Version 2 or later (the \"GPL\"), in which case\r\nthe provisions of the GPL are applicable instead of those above.\r\nIf you wish to allow use of your version of this file only under the terms\r\nof the GPL and not to allow others to use your version of this file\r\nunder the MPL, indicate your decision by deleting the provisions above and\r\nreplace them with the notice and other provisions required by the GPL.\r\nIf you do not delete the provisions above, a recipient may use your version\r\nof this file under either the MPL or the GPL.\r\n\r\n$Id: SynHighlighterCobol.pas,v 1.5.2.7 2008/09/14 16:24:59 maelh Exp $\r\n\r\nYou may retrieve the latest version of this file at the SynEdit home page,\r\nlocated at http://SynEdit.SourceForge.net\r\n\r\n-------------------------------------------------------------------------------}\r\n\r\n{$IFNDEF QSYNHIGHLIGHTERCOBOL}\r\nunit SynHighlighterCobol;\r\n{$ENDIF}\r\n\r\n{$I SynEdit.inc}\r\n\r\ninterface\r\n\r\nuses\r\n{$IFDEF SYN_CLX}\r\n  QGraphics,\r\n  QSynEditTypes,\r\n  QSynEditHighlighter,\r\n  QSynHighlighterHashEntries,\r\n  QSynUnicode,\r\n{$ELSE}\r\n  Graphics,\r\n  SynEditTypes,\r\n  SynEditHighlighter,\r\n  SynHighlighterHashEntries,  \r\n  SynUnicode,\r\n{$ENDIF}\r\n  SysUtils,\r\n  Classes;\r\n\r\ntype\r\n  TtkTokenKind = (\r\n    tkComment,\r\n    tkIdentifier,\r\n    tkAIdentifier,\r\n    tkPreprocessor,\r\n    tkKey,\r\n    tkBoolean,\r\n    tkNull,\r\n    tkNumber,\r\n    tkSpace,\r\n    tkString,\r\n    tkSequence,\r\n    tkIndicator,\r\n    tkTagArea,\r\n    tkDebugLines,\r\n    tkUnknown);\r\n\r\n  TRangeState = (rsUnknown,\r\n                 rsQuoteString, rsApostString,\r\n                 rsPseudoText,\r\n                 rsQuoteStringMayBe, rsApostStringMayBe);\r\n\r\ntype\r\n  TSynCobolSyn = class(TSynCustomHighlighter)\r\n  private\r\n    fRange: TRangeState;\r\n    fTokenID: TtkTokenKind;\r\n    fIndicator: WideChar;\r\n\r\n    fCodeStartPos: LongInt;\r\n    fCodeMediumPos: LongInt;\r\n    fCodeEndPos: LongInt;\r\n\r\n    fCommentAttri: TSynHighlighterAttributes;\r\n    fIdentifierAttri: TSynHighlighterAttributes;\r\n    fAIdentifierAttri: TSynHighlighterAttributes;\r\n    fPreprocessorAttri: TSynHighlighterAttributes;\r\n    fKeyAttri: TSynHighlighterAttributes;\r\n    fNumberAttri: TSynHighlighterAttributes;\r\n    fBooleanAttri: TSynHighlighterAttributes;\r\n    fSpaceAttri: TSynHighlighterAttributes;\r\n    fStringAttri: TSynHighlighterAttributes;\r\n    fSequenceAttri: TSynHighlighterAttributes;\r\n    fIndicatorAttri: TSynHighlighterAttributes;\r\n    fTagAreaAttri: TSynHighlighterAttributes;\r\n    fDebugLinesAttri: TSynHighlighterAttributes;\r\n    fKeywords: TSynHashEntryList;\r\n    procedure DoAddKeyword(AKeyword: UnicodeString; AKind: integer);\r\n    function HashKey(Str: PWideChar): Integer;\r\n    function IdentKind(MayBe: PWideChar): TtkTokenKind;\r\n    procedure IdentProc;\r\n    procedure UnknownProc;\r\n    procedure NullProc;\r\n    procedure SpaceProc;\r\n    procedure CRProc;\r\n    procedure LFProc;\r\n    procedure NumberProc;\r\n    procedure PointProc;\r\n    procedure StringOpenProc;\r\n    procedure StringProc;\r\n    procedure StringEndProc;\r\n    procedure FirstCharsProc;\r\n    procedure LastCharsProc;\r\n    procedure CommentProc;\r\n    procedure DebugProc;\r\n  protected\r\n    function GetSampleSource: UnicodeString; override;\r\n    function IsFilterStored: Boolean; override;\r\n    procedure NextProcedure;\r\n\r\n    procedure SetCodeStartPos(Value: LongInt);\r\n    procedure SetCodeMediumPos(Value: LongInt);\r\n    procedure SetCodeEndPos(Value: LongInt);\r\n  public\r\n    constructor Create(AOwner: TComponent); override;\r\n    destructor Destroy; override;\r\n    class function GetLanguageName: string; override;\r\n    class function GetFriendlyLanguageName: UnicodeString; override;\r\n    function GetRange: Pointer; override;\r\n    procedure ResetRange; override;\r\n    procedure SetRange(Value: Pointer); override;\r\n    function GetDefaultAttribute(Index: integer): TSynHighlighterAttributes; override;\r\n    function GetEol: Boolean; override;\r\n    function GetTokenID: TtkTokenKind;\r\n    function GetTokenAttribute: TSynHighlighterAttributes; override;\r\n    function GetTokenKind: integer; override;\r\n    function IsIdentChar(AChar: WideChar): Boolean; override;\r\n    procedure Next; override;\r\n  published\r\n    property CommentAttri: TSynHighlighterAttributes read fCommentAttri write fCommentAttri;\r\n    property IdentifierAttri: TSynHighlighterAttributes read fIdentifierAttri write fIdentifierAttri;\r\n    property AreaAIdentifierAttri: TSynHighlighterAttributes read fAIdentifierAttri write fAIdentifierAttri;\r\n    property PreprocessorAttri: TSynHighlighterAttributes read fPreprocessorAttri write fPreprocessorAttri;\r\n    property KeyAttri: TSynHighlighterAttributes read fKeyAttri write fKeyAttri;\r\n    property NumberAttri: TSynHighlighterAttributes read fNumberAttri write fNumberAttri;\r\n    property BooleanAttri: TSynHighlighterAttributes read fBooleanAttri write fBooleanAttri;\r\n    property SpaceAttri: TSynHighlighterAttributes read fSpaceAttri write fSpaceAttri;\r\n    property StringAttri: TSynHighlighterAttributes read fStringAttri write fStringAttri;\r\n    property SequenceAttri: TSynHighlighterAttributes read fSequenceAttri write fSequenceAttri;\r\n    property IndicatorAttri: TSynHighlighterAttributes read fIndicatorAttri write fIndicatorAttri;\r\n    property TagAreaAttri: TSynHighlighterAttributes read fTagAreaAttri write fTagAreaAttri;\r\n    property DebugLinesAttri: TSynHighlighterAttributes read fDebugLinesAttri write fDebugLinesAttri;\r\n\r\n    property AreaAStartPos: LongInt read fCodeStartPos write SetCodeStartPos;\r\n    property AreaBStartPos: LongInt read fCodeMediumPos write SetCodeMediumPos;\r\n    property CodeEndPos: LongInt read fCodeEndPos write SetCodeEndPos;\r\n  end;\r\n\r\nimplementation\r\n\r\nuses\r\n{$IFDEF SYN_CLX}\r\n  QSynEditStrConst;\r\n{$ELSE}\r\n  SynEditStrConst;\r\n{$ENDIF}\r\n\r\nconst\r\n  BooleanWords: UnicodeString =\r\n    'false, true';\r\n\r\n  KeyWords: UnicodeString =\r\n    'accept, access, acquire, add, address, advancing, after, all, allowing, ' +\r\n    'alphabet, alphabetic, alphabetic-lower, alphabetic-upper, alphanumeric, ' +\r\n    'alphanumeric-edited, also, alter, alternate, and, any, apply, are, ' +\r\n    'area, areas, area-value, arithmetic, ascending, assign, at, author, ' +\r\n    'auto, automatic, auto-skip, background-color, background-colour, ' +\r\n    'backward, b-and, beep, before, beginning, bell, b-exor, binary, bit, ' +\r\n    'bits, blank, b-less, blink, block, b-not, boolean, b-or, bottom, by, ' +\r\n    'call, cancel, cd, cf, ch, chain, chaining, changed, character, ' +\r\n    'characters, class, clock-units, close, cobol, code, code-set, col, ' +\r\n    'collating, color, column, comma, command-line, commit, commitment, ' +\r\n    'common, communication, comp, comp-0, comp-1, comp-2, comp-3, comp-4, ' +\r\n    'comp-5, comp-6, comp-7, comp-8, comp-9, computational, computational-0, ' +\r\n    'computational-1, computational-2, computational-3, computational-4, ' +\r\n    'computational-5, computational-6, computational-7, computational-8, ' +\r\n    'computational-9, computational-x, compute, comp-x, com-reg, ' +\r\n    'configuration, connect, console, contained, contains, content, ' +\r\n    'continue, control-area, controls, converting, corr, corresponding, ' +\r\n    'count, crt, crt-under, currency, current, cursor, cycle, data, date, ' +\r\n    'date-compiled, date-written, day, day-of-week, db, ' +\r\n    'db-access-control-key, dbcs, db-data-name, db-exception, ' +\r\n    'db-format-name, db-record-name, db-set-name, db-status, de, ' +\r\n    'debug-contents, debugging, debug-item, debug-line, debug-name, ' +\r\n    'debug-sub-1, debug-sub-2, debug-sub-3, decimal-point, declaratives, ' +\r\n    'default, delimited, delimiter, depending, descending, destination, ' +\r\n    'detail, disable, disconnect, disk, display, display-1, display-2, ' +\r\n    'display-3, display-4, display-5, display-6, display-7, display-8, ' +\r\n    'display-9, divide, division, down, drop, duplicate, duplicates, ' +\r\n    'dynamic, egcs, egi, else, emi, empty, empty-check, enable, end, ' +\r\n    'end-accept, end-add, end-call, end-compute, end-delete, end-disable, ' +\r\n    'end-divide, end-enable, end-evaluate, end-if, ending, end-multiply, ' +\r\n    'end-of-page, end-perform, end-read, end-receive, end-return, ' +\r\n    'end-rewrite, end-search, end-send, end-start, end-string, end-subtract, ' +\r\n    'end-transceive, end-unstring, end-write, enter, entry, environment, ' +\r\n    'eop, equal, equals, erase, error, escape, esi, evaluate, every, exact, ' +\r\n    'exceeds, exception, excess-3, exclusive, exec, execute, exhibit, exit, ' +\r\n    'extend, external, externally-described-key, fd, fetch, file, ' +\r\n    'file-control, file-id, filler, final, find, finish, first, fixed, ' +\r\n    'footing, for, foreground-color, foreground-colour, form, format, free, ' +\r\n    'from, full, function, generate, get, giving, global, go, goback, ' +\r\n    'greater, group, heading, highlight, id, identification, if, in, index, ' +\r\n    'index-1, index-2, index-3, index-4, index-5, index-6, index-7, index-8, ' +\r\n    'index-9, indexed, indic, indicate, indicator, indicators, initial, ' +\r\n    'initialize, initiate, input, input-output, inspect, installation, into, ' +\r\n    'invalid, i-o, i-o-control, is, japanese, just, justified, kanji, keep, ' +\r\n    'kept, key, keyboard, last, ld, leading, left, left-justify, length, ' +\r\n    'length-check, less, like, limit, limits, linage, linage-counter, line, ' +\r\n    'line-counter, lines, linkage, locally, lock, manual, member, memory, ' +\r\n    'merge, message, mode, modified, modify, modules, more-labels, move, ' +\r\n    'multiple, multiply, name, native, negative, next, no, no-echo, none, ' +\r\n    'normal, not, number, numeric, numeric-edited, object-computer, occurs, ' +\r\n    'of, off, omitted, on, only, open, optional, or, order, organization, ' +\r\n    'other, output, overflow, owner, packed-decimal, padding, page, ' +\r\n    'page-counter, palette, paragraph, password, perform, pf, ph, pic, ' +\r\n    'picture, plus, pointer, position, positive, present, previous, printer, ' +\r\n    'printer-1, printing, print-switch, prior, procedure, procedures, ' +\r\n    'proceed, process, processing, program, program-id, prompt, protected, ' +\r\n    'purge, queue, random, range, rd, read, realm, receive, reconnect, ' +\r\n    'record, recording, record-name, records, redefines, reel, reference, ' +\r\n    'references, relation, relative, release, remainder, removal, renames, ' +\r\n    'repeated, replacing, report, reporting, reports, required, rerun, ' +\r\n    'reserve, retaining, retrieval, return, return-code, reversed, ' +\r\n    'reverse-video, rewind, rewrite, rf, rh, right, right-justify, rollback, ' +\r\n    'rolling, rounded, run, same, screen, sd, search, section, secure, ' +\r\n    'security, segment, segment-limit, select, send, sentence, separate, ' +\r\n    'sequence, sequential, session-id, set, shared, shift-in, shift-out, ' +\r\n    'sign, size, sort, sort-control, sort-core-size, sort-file-size, ' +\r\n    'sort-merge, sort-message, sort-mode-size, sort-return, source, ' +\r\n    'source-computer, space-fill, special-names, standard, standard-1, ' +\r\n    'standard-2, standard-3, standard-4, start, starting, status, stop, ' +\r\n    'store, string, subfile, subprogram, sub-queue-1, sub-queue-2, ' +\r\n    'sub-queue-3, sub-schema, subtract, sum, suppress, switch, switch-1, ' +\r\n    'switch-2, switch-3, switch-4, switch-5, switch-6, switch-7, switch-8, ' +\r\n    'symbolic, sync, synchronized, table, tally, tallying, tape, tenant, ' +\r\n    'terminal, terminate, test, text, than, then, through, thru, time, ' +\r\n    'timeout, times, to, top, trailing, trailing-sign, transaction, ' +\r\n    'transceive, type, underline, unequal, unit, unlock, unstring, until, ' +\r\n    'up, update, upon, usage, usage-mode, user, using, valid, validate, ' +\r\n    'value, values, variable, varying, wait, when, when-compiled, with, ' +\r\n    'within, words, working-storage, write, write-only, zero-fill';\r\n\r\n  PreprocessorWords: UnicodeString =\r\n    'basis, cbl, control, copy, delete, eject, insert, ready, reload, ' +\r\n    'replace, reset, service, skip1, skip2, skip3, title, trace, use';\r\n\r\n  StringWords: UnicodeString =\r\n    'high-value, high-values, low-value, low-values, null, nulls, quote, ' +\r\n    'quotes, space, spaces, zero, zeroes, zeros';\r\n\r\n  // Ambigious means that a simple string comparision is not enough\r\n  AmbigiousWords: UnicodeString =\r\n    'label';\r\n\r\nconst\r\n  StringChars: array[TRangeState] of WideChar = (#0, '\"', '''', '=',  '\"', '''');\r\n\r\nprocedure TSynCobolSyn.DoAddKeyword(AKeyword: UnicodeString; AKind: integer);\r\nvar\r\n  HashValue: integer;\r\nbegin\r\n  HashValue := HashKey(PWideChar(AKeyword));\r\n  fKeywords[HashValue] := TSynHashEntry.Create(AKeyword, AKind);\r\nend;\r\n\r\nfunction TSynCobolSyn.HashKey(Str: PWideChar): Integer;\r\nvar\r\n  fRun: LongInt;\r\n\r\n  function GetOrd: Integer;\r\n  begin\r\n    case Str^ of\r\n      'a'..'z': Result := 1 + Ord(Str^) - Ord('a');\r\n      'A'..'Z': Result := 1 + Ord(Str^) - Ord('A');\r\n      '0'..'9': Result := 28 + Ord(Str^) - Ord('0');\r\n      '-': Result := 27;\r\n      else Result := 0;\r\n    end\r\n  end;\r\n\r\nbegin\r\n  fRun := Run;\r\n  Result := 0;\r\n\r\n  while IsIdentChar(Str^) and (fRun <= fCodeEndPos) do\r\n  begin\r\n{$IFOPT Q-}\r\n    Result := 7 * Result + GetOrd;\r\n{$ELSE}\r\n    Result := (7 * Result + GetOrd) and $FFFFFF;\r\n{$ENDIF}\r\n    Inc(Str);\r\n    inc(fRun);\r\n  end;\r\n  \r\n  Result := Result and $FF; // 255\r\n  fStringLen := Str - fToIdent;\r\nend;\r\n\r\nfunction TSynCobolSyn.IdentKind(MayBe: PWideChar): TtkTokenKind;\r\nvar\r\n  Entry: TSynHashEntry;\r\n  I: Integer;\r\nbegin\r\n  fToIdent := MayBe;\r\n  Entry := fKeywords[HashKey(MayBe)];\r\n  while Assigned(Entry) do\r\n  begin\r\n    if Entry.KeywordLen > fStringLen then\r\n      break\r\n    else if Entry.KeywordLen = fStringLen then\r\n      if IsCurrentToken(Entry.Keyword) then\r\n      begin\r\n        Result := TtkTokenKind(Entry.Kind);\r\n\r\n        if Result = tkUnknown then // handling of \"ambigious\" words \r\n        begin\r\n          if IsCurrentToken('label') then\r\n          begin\r\n            I := Run + Length('label');\r\n            while fLine[I] = ' ' do\r\n              Inc(I);\r\n            if (WStrLComp(PWideChar(@fLine[I]), 'record', Length('record')) = 0)\r\n              and (I + Length('record') - 1 <= fCodeEndPos) then\r\n                Result := tkKey\r\n              else\r\n                Result := tkPreprocessor;\r\n          end\r\n          else\r\n            Result := tkIdentifier;\r\n        end;\r\n        \r\n        exit;\r\n      end;\r\n    Entry := Entry.Next;\r\n  end;\r\n  Result := tkIdentifier;\r\nend;\r\n\r\nprocedure TSynCobolSyn.SpaceProc;\r\nbegin\r\n  fTokenID := tkSpace;\r\n  repeat\r\n    inc(Run);\r\n  until not CharInSet(fLine[Run], [#1..#32]);\r\nend;\r\n\r\nprocedure TSynCobolSyn.FirstCharsProc;\r\nvar\r\n  I: Integer;\r\nbegin\r\n  if IsLineEnd(Run) then\r\n    NextProcedure\r\n  else if Run < fCodeStartPos - 1 then\r\n  begin\r\n    fTokenID := tkSequence;\r\n    repeat\r\n      inc(Run);\r\n    until (Run = fCodeStartPos - 1) or IsLineEnd(Run);\r\n  end\r\n  else\r\n  begin\r\n    fTokenID := tkIndicator;\r\n    case fLine[Run] of\r\n      '*', '/', 'D', 'd': fIndicator := fLine[Run];\r\n      '-': if fRange in [rsQuoteStringMayBe, rsApostStringMayBe] then\r\n           begin\r\n             I := Run + 1;\r\n             while fLine[I] = ' ' do\r\n               Inc(I);\r\n             if (WStrLComp(PWideChar(@fLine[I]), PWideChar(UnicodeStringOfChar(StringChars[fRange], 2)), 2) <> 0)\r\n               or (I + 1 > fCodeEndPos) then\r\n                 fRange := rsUnknown;\r\n           end;\r\n    end;\r\n    inc(Run);\r\n  end;\r\nend;\r\n\r\nprocedure TSynCobolSyn.LastCharsProc;\r\nbegin\r\n  if IsLineEnd(Run) then\r\n    NextProcedure\r\n  else\r\n  begin\r\n    fTokenID := tkTagArea;\r\n    repeat\r\n      inc(Run);\r\n    until IsLineEnd(Run);\r\n  end;\r\nend;\r\n\r\nprocedure TSynCobolSyn.CommentProc;\r\nbegin\r\n  fIndicator := #0;\r\n\r\n  if IsLineEnd(Run) then\r\n    NextProcedure\r\n  else\r\n  begin\r\n    fTokenID := tkComment;\r\n    repeat\r\n      Inc(Run);\r\n    until IsLineEnd(Run) or (Run > fCodeEndPos);\r\n  end;\r\nend;\r\n\r\nprocedure TSynCobolSyn.DebugProc;\r\nbegin\r\n  fIndicator := #0;\r\n\r\n  if IsLineEnd(Run) then\r\n    NextProcedure\r\n  else\r\n  begin\r\n    fTokenID := tkDebugLines;\r\n    repeat\r\n      Inc(Run);\r\n    until IsLineEnd(Run) or (Run > fCodeEndPos);\r\n  end;\r\nend;\r\n\r\nprocedure TSynCobolSyn.PointProc;\r\nbegin\r\n  if (Run < fCodeEndPos) and CharInSet(FLine[Run + 1], ['0'..'9', 'e', 'E']) then\r\n    NumberProc\r\n  else\r\n    UnknownProc;\r\nend;\r\n\r\nprocedure TSynCobolSyn.NumberProc;\r\n\r\n  function IsNumberChar: Boolean;\r\n  begin\r\n    case fLine[Run] of\r\n      '0'..'9', '.', 'e', 'E', '-', '+':\r\n        Result := True;\r\n      else\r\n        Result := False;\r\n    end;\r\n  end;\r\n\r\nvar\r\n  fFloat: Boolean;\r\nbegin\r\n  fTokenID := tkNumber;\r\n  Inc(Run);\r\n  fFloat := False;\r\n\r\n  while IsNumberChar and (Run <= fCodeEndPos) do\r\n  begin\r\n    case FLine[Run] of\r\n      '.':\r\n        if not CharInSet(FLine[Run + 1], ['0'..'9', 'e', 'E']) then\r\n          Break\r\n        else\r\n          fFloat := True;\r\n      'e', 'E':\r\n          if not CharInSet(FLine[Run - 1], ['0'..'9', '.']) then\r\n            Break\r\n          else fFloat := True;\r\n      '-', '+':\r\n        begin\r\n          if not fFloat or not CharInSet(FLine[Run - 1], ['e', 'E']) then\r\n            Break;\r\n        end;\r\n    end;\r\n    Inc(Run);\r\n  end;\r\nend;\r\n\r\nprocedure TSynCobolSyn.NullProc;\r\nbegin\r\n  fTokenID := tkNull;\r\n  inc(Run);\r\nend;\r\n\r\nprocedure TSynCobolSyn.CRProc;\r\nbegin\r\n  fTokenID := tkSpace;\r\n  inc(Run);\r\n  if fLine[Run] = #10 then\r\n    inc(Run);\r\nend;\r\n\r\nprocedure TSynCobolSyn.LFProc;\r\nbegin\r\n  fTokenID := tkSpace;\r\n  inc(Run);\r\nend;\r\n\r\nprocedure TSynCobolSyn.StringOpenProc;\r\nbegin\r\n  case fLine[Run] of\r\n    '\"': fRange := rsQuoteString;\r\n    '''': fRange := rsApostString;\r\n    else\r\n      if fLine[Run + 1] = '=' then\r\n      begin\r\n        fRange := rsPseudoText;\r\n        Inc(Run);\r\n      end\r\n      else\r\n      begin\r\n        UnknownProc;\r\n        Exit;\r\n      end;\r\n  end;\r\n\r\n  Inc(Run);\r\n  StringProc;\r\n  fTokenID := tkString;\r\nend;\r\n\r\nprocedure TSynCobolSyn.StringProc;\r\nbegin\r\n  fTokenID := tkString;\r\n\r\n  if Run <= fCodeEndPos then\r\n  repeat\r\n    if (fLine[Run] = StringChars[fRange])\r\n      and ((fLine[Run] <> '=') or ((Run > 0) and (fLine[Run - 1] = '='))) then\r\n    begin\r\n      if (Run = fCodeEndPos) and (fRange in [rsQuoteString, rsApostString]) then\r\n        Inc(fRange, 3)\r\n      else\r\n        fRange := rsUnknown;\r\n      Inc(Run);\r\n      Break;\r\n    end;\r\n    if not IsLineEnd(Run) then\r\n      Inc(Run);\r\n  until IsLineEnd(Run) or (Run > fCodeEndPos);\r\nend;\r\n\r\nprocedure TSynCobolSyn.StringEndProc;\r\nbegin\r\n  if IsLineEnd(Run) then\r\n    NextProcedure\r\n  else\r\n  begin\r\n    fTokenID := tkString;\r\n\r\n    if (fRange <> rsPseudoText) and (Run <= fCodeEndPos) then\r\n    repeat\r\n      if (fLine[Run] = StringChars[fRange]) then\r\n      begin\r\n        if fRange in [rsQuoteString, rsApostString] then\r\n          Inc(Run)\r\n        else\r\n        begin\r\n          Inc(Run, 2);\r\n          Dec(fRange, 3);\r\n        end;\r\n        Break;\r\n      end;\r\n      Inc(Run);\r\n    until IsLineEnd(Run) or (Run > fCodeEndPos);\r\n\r\n    StringProc;\r\n  end;\r\nend;\r\n\r\nconstructor TSynCobolSyn.Create(AOwner: TComponent);\r\nbegin\r\n  inherited Create(AOwner);\r\n\r\n  fCaseSensitive := False;\r\n\r\n  fKeywords := TSynHashEntryList.Create;\r\n\r\n  fCommentAttri := TSynHighLighterAttributes.Create(SYNS_AttrComment, SYNS_FriendlyAttrComment);\r\n  fCommentAttri.Style := [fsItalic];\r\n  fCommentAttri.Foreground := clGray;\r\n  AddAttribute(fCommentAttri);\r\n\r\n  fIdentifierAttri := TSynHighLighterAttributes.Create(SYNS_AttrIdentifier, SYNS_FriendlyAttrIdentifier);\r\n  AddAttribute(fIdentifierAttri);\r\n\r\n  fAIdentifierAttri := TSynHighLighterAttributes.Create(SYNS_AttrAreaAIdentifier, SYNS_FriendlyAttrAreaAIdentifier);\r\n  fAIdentifierAttri.Foreground := clTeal;\r\n  fAIdentifierAttri.Style := [fsBold];\r\n  AddAttribute(fAIdentifierAttri);\r\n\r\n  fPreprocessorAttri := TSynHighLighterAttributes.Create(SYNS_AttrPreprocessor, SYNS_FriendlyAttrPreprocessor);\r\n  fPreprocessorAttri.Foreground := clMaroon;\r\n  AddAttribute(fPreprocessorAttri);\r\n\r\n  fKeyAttri := TSynHighLighterAttributes.Create(SYNS_AttrReservedWord, SYNS_FriendlyAttrReservedWord);\r\n  fKeyAttri.Style := [fsBold];\r\n  AddAttribute(fKeyAttri);\r\n\r\n  fNumberAttri := TSynHighLighterAttributes.Create(SYNS_AttrNumber, SYNS_FriendlyAttrNumber);\r\n  fNumberAttri.Foreground := clGreen;\r\n  AddAttribute(fNumberAttri);\r\n\r\n  fBooleanAttri := TSynHighLighterAttributes.Create(SYNS_AttrBoolean, SYNS_FriendlyAttrBoolean);\r\n  fBooleanAttri.Foreground := clGreen;\r\n  AddAttribute(fBooleanAttri);\r\n\r\n  fSpaceAttri := TSynHighLighterAttributes.Create(SYNS_AttrSpace, SYNS_FriendlyAttrSpace);\r\n  AddAttribute(fSpaceAttri);\r\n\r\n  fStringAttri := TSynHighLighterAttributes.Create(SYNS_AttrString, SYNS_FriendlyAttrString);\r\n  fStringAttri.Foreground := clBlue;\r\n  AddAttribute(fStringAttri);\r\n\r\n  fSequenceAttri := TSynHighLighterAttributes.Create(SYNS_AttrSequence, SYNS_FriendlyAttrSequence);\r\n  fSequenceAttri.Foreground := clDkGray;\r\n  AddAttribute(fSequenceAttri);\r\n\r\n  fIndicatorAttri := TSynHighLighterAttributes.Create(SYNS_AttrIndicator, SYNS_FriendlyAttrIndicator);\r\n  fIndicatorAttri.Foreground := clRed;\r\n  AddAttribute(fIndicatorAttri);\r\n\r\n  fTagAreaAttri := TSynHighLighterAttributes.Create(SYNS_AttrTagArea, SYNS_FriendlyAttrTagArea);\r\n  fTagAreaAttri.Foreground := clMaroon;\r\n  AddAttribute(fTagAreaAttri);\r\n\r\n  fDebugLinesAttri := TSynHighLighterAttributes.Create(SYNS_AttrDebugLines, SYNS_FriendlyAttrDebugLines);\r\n  fDebugLinesAttri.Foreground := clDkGray;\r\n  AddAttribute(fDebugLinesAttri);\r\n  SetAttributesOnChange(DefHighlightChange);\r\n\r\n  fDefaultFilter := SYNS_FilterCOBOL;\r\n  fRange := rsUnknown;\r\n  fIndicator := #0;\r\n\r\n  fCodeStartPos := 7;\r\n  fCodeMediumPos := 11;\r\n  fCodeEndPos := 71;\r\n\r\n  EnumerateKeywords(Ord(tkBoolean), BooleanWords, IsIdentChar, DoAddKeyword);\r\n  EnumerateKeywords(Ord(tkKey), KeyWords, IsIdentChar, DoAddKeyword);\r\n  EnumerateKeywords(Ord(tkPreprocessor), PreprocessorWords, IsIdentChar, DoAddKeyword);\r\n  EnumerateKeywords(Ord(tkString), StringWords, IsIdentChar, DoAddKeyword);\r\n  EnumerateKeywords(Ord(tkUnknown), AmbigiousWords, IsIdentChar, DoAddKeyword);\r\nend;\r\n\r\ndestructor TSynCobolSyn.Destroy;\r\nbegin\r\n  fKeywords.Free;\r\n  inherited Destroy;\r\nend;\r\n\r\nprocedure TSynCobolSyn.IdentProc;\r\nbegin\r\n  if CharInSet(fLine[Run], ['x', 'g', 'X', 'G'])\r\n    and (Run < fCodeEndPos) and CharInSet(fLine[Run + 1], ['\"', '''']) then\r\n  begin\r\n    Inc(Run);\r\n    StringOpenProc;\r\n  end\r\n  else\r\n  begin\r\n    fTokenID := IdentKind((fLine + Run));\r\n    if (fTokenID = tkIdentifier) and (Run < fCodeMediumPos) then\r\n      fTokenID := tkAIdentifier;\r\n    inc(Run, fStringLen);\r\n\r\n    while IsIdentChar(fLine[Run]) and (Run <= fCodeEndPos) do\r\n      Inc(Run);\r\n  end;\r\nend;\r\n\r\nprocedure TSynCobolSyn.UnknownProc;\r\nbegin\r\n  inc(Run);\r\n  fTokenID := tkUnknown;\r\nend;\r\n\r\nprocedure TSynCobolSyn.Next;\r\nbegin\r\n  fTokenPos := Run;\r\n\r\n  if fTokenPos < fCodeStartPos then\r\n    FirstCharsProc\r\n  else\r\n    case fIndicator of\r\n      '*', '/': CommentProc;\r\n      'D', 'd': DebugProc;\r\n      else\r\n        if fTokenPos > fCodeEndPos then\r\n          LastCharsProc\r\n        else\r\n          case fRange of\r\n            rsQuoteString..rsApostStringMayBe: StringEndProc;\r\n          else\r\n            begin\r\n              fRange := rsUnknown;\r\n              NextProcedure;\r\n            end;\r\n          end;\r\n    end;\r\n  inherited;\r\nend;\r\n\r\nprocedure TSynCobolSyn.NextProcedure;\r\nbegin\r\n  case fLine[Run] of\r\n    #0: NullProc;\r\n    #10: LFProc;\r\n    #13: CRProc;\r\n    '\"': StringOpenProc;\r\n    '''': StringOpenProc;\r\n    '=': StringOpenProc;\r\n    #1..#9, #11, #12, #14..#32: SpaceProc;\r\n    '.': PointProc;\r\n    '0'..'9': NumberProc;\r\n    'A'..'Z', 'a'..'z': IdentProc;\r\n    else UnknownProc;\r\n  end;\r\nend;\r\n\r\nfunction TSynCobolSyn.GetDefaultAttribute(Index: integer): TSynHighLighterAttributes;\r\nbegin\r\n  case Index of\r\n    SYN_ATTR_COMMENT: Result := fCommentAttri;\r\n    SYN_ATTR_IDENTIFIER:  Result := fIdentifierAttri;\r\n    SYN_ATTR_KEYWORD: Result := fKeyAttri;\r\n    SYN_ATTR_STRING: Result := fStringAttri;\r\n    SYN_ATTR_WHITESPACE: Result := fSpaceAttri;\r\n  else\r\n    Result := nil;\r\n  end;\r\nend;\r\n\r\nfunction TSynCobolSyn.GetEol: Boolean;\r\nbegin\r\n  Result := Run = fLineLen + 1;\r\nend;\r\n\r\nfunction TSynCobolSyn.GetTokenID: TtkTokenKind;\r\nbegin\r\n  Result := fTokenId;\r\nend;\r\n\r\nfunction TSynCobolSyn.GetTokenAttribute: TSynHighLighterAttributes;\r\nbegin\r\n  case GetTokenID of\r\n    tkComment: Result := fCommentAttri;\r\n    tkIdentifier: Result := fIdentifierAttri;\r\n    tkAIdentifier: Result := fAIdentifierAttri;\r\n    tkPreprocessor: Result := fPreprocessorAttri;\r\n    tkKey: Result := fKeyAttri;\r\n    tkBoolean: Result := fBooleanAttri;\r\n    tkNumber: Result := fNumberAttri;\r\n    tkSpace: Result := fSpaceAttri;\r\n    tkString: Result := fStringAttri;\r\n    tkSequence: Result := fSequenceAttri;\r\n    tkIndicator: Result := fIndicatorAttri;\r\n    tkTagArea: Result := fTagAreaAttri;\r\n    tkDebugLines: Result := fDebugLinesAttri;\r\n    tkUnknown: Result := fIdentifierAttri;\r\n  else\r\n    Result := nil;\r\n  end;\r\nend;\r\n\r\nfunction TSynCobolSyn.GetTokenKind: integer;\r\nbegin\r\n  Result := Ord(fTokenId);\r\nend;\r\n\r\nfunction TSynCobolSyn.GetSampleSource: UnicodeString;\r\nbegin\r\n  Result := '000100* This is a sample file to be used to show all TSynCobolSyn''s'#13#10 +\r\n            '000200* features.'#13#10 +\r\n            '000300* This isn''t a valid COBOL program.'#13#10 +\r\n            '000400'#13#10 +\r\n            '000500* 1. Supported COBOL features.'#13#10 +\r\n            '000600'#13#10 +\r\n            '000700* 1.1  Sequence area.'#13#10 +\r\n            '000800*    First six columns in COBOL are reserved for enumeration'#13#10 +\r\n            '000900*    of source lines.'#13#10 +\r\n            '001000* 1.2  Indicator area.'#13#10 +\r\n            '001100*    7th column in COBOL is reserved for special markers like ''*'''#13#10 +\r\n            '001200*    or ''D''.'#13#10 +\r\n            '001300* 1.3  Comment lines.'#13#10 +\r\n            '001400*    Any line started from ''*'' in 7th column is a comment.'#13#10 +\r\n            '001500*    No separate word highlighting will be done by the editor.'#13#10 +\r\n            '001600* 1.4  Debug lines.'#13#10 +\r\n            '001700D    Any line started from ''D'' will be treated as containing debug'#13#10 +\r\n            '001800D    commands. No separate word highlighting will be done'#13#10 +\r\n            '001900D    by the editor.'#13#10 +\r\n            '002000* 1.5  Tag area.'#13#10 +\r\n            '002100*    Only columns from 8th till 72th can be used for COBOL        TAG_AREA'#13#10 +\r\n            '002200*    program. Columns beyond the 72th one may be used by some     TAG_AREA'#13#10 +\r\n            '002300*    COBOL compilers to tag the code in some internal way.        TAG_AREA'#13#10 +\r\n            '002400* 1.6  Area A identifiers.'#13#10 +\r\n            '002500*    In area A (from 8th column till'#13#10 +\r\n            '002600*    11th one) you should type only sections''/paragraphs'' names.'#13#10 +\r\n            '002700*    For example \"SOME\" is a section name:'#13#10 +\r\n            '002800 SOME SECTION.'#13#10 +\r\n            '002900* 1.7  Preprocessor directives.'#13#10 +\r\n            '003000*    For example \"COPY\" is a preprocessor directive:'#13#10 +\r\n            '003100     COPY \"PRD-DATA.SEL\".'#13#10 +\r\n            '003200* 1.8  Key words.'#13#10 +\r\n            '003300*    For example \"ACCEPT\" and \"AT\" are COBOL key words:'#13#10 +\r\n            '003400     ACCEPT WS-ENTRY AT 2030.'#13#10 +\r\n            '003500* 1.9  Boolean constants.'#13#10 +\r\n            '003600*    These are \"TRUE\" and \"FALSE\" constants. For example:'#13#10 +\r\n            '003700     EVALUATE TRUE.'#13#10 +\r\n            '003800* 1.10 Numbers.'#13#10 +\r\n            '003900*    Here are the examples of numbers:'#13#10 +\r\n            '004000 01  WSV-TEST-REC.'#13#10 +\r\n            '004100     03  WSV-INT-T\t       PIC 9(5) VALUE 12345.'#13#10 +\r\n            '004200     03  WSV-PRICES              PIC 9(4)V99 COMP-3 VALUE 0000.33. \t\t'#13#10 +\r\n            '004300     03  WSV-Z-PRICES            PIC Z(5)9.99- VALUE -2.12. \t\t'#13#10 +\r\n            '004400     03  WSV-STORE-DATE          PIC 9(4)V99E99 VALUE 0001.33E02.'#13#10 +\r\n            '004500* 1.11 Strings.'#13#10 +\r\n            '004600*    The following types of strings are supported:'#13#10 +\r\n            '004700*    1.11.1 Quoted strings.'#13#10 +\r\n            '004800         MOVE \"The name of field is \"\"PRODUCT\"\"\" TO WS-ERR-MESS.'#13#10 +\r\n            '004900         MOVE ''The name of field is ''''PRODUCT'''''' TO WS-ERR-MESS.'#13#10 +\r\n            '005000*    1.11.2 Pseudo-text.'#13#10 +\r\n            '005100         COPY'#13#10 +\r\n            '005200             REPLACING ==+00001== BY  +2'#13#10 +\r\n            '005300                       == 1 ==    BY  -3.'#13#10 +\r\n            '005400*    1.11.3 Figurative constants.'#13#10 +\r\n            '005500*        For example \"SPACES\" is figurative constant:'#13#10 +\r\n            '005600             DISPLAY SPACES UPON CRT.'#13#10 +\r\n            '005700* 1.12 Continued lines.'#13#10 +\r\n            '005800*    Only continued strings are supported. For example:'#13#10 +\r\n            '005900         MOVE \"The name of figurative constant field is'#13#10 +\r\n            '006000-\"SPACES\" TO WS-ERR-MESS.'#13#10 +\r\n            '006100*    Or (a single quotation mark in 72th column):'#13#10 +\r\n            '005900         MOVE \"The name of figurative constant field is  \"\"SPACES\"'#13#10 +\r\n            '006000-\"\"\" TO WS-ERR-MESS.'#13#10 +\r\n            '006100'#13#10 +\r\n            '006200* 2. Unsupported COBOL features.'#13#10 +\r\n            '006300'#13#10 +\r\n            '006400* 2.1 Continued lines.'#13#10 +\r\n            '006500*    Continuation of key words is not supported. For example,'#13#10 +\r\n            '006600*    the following COBOL code is valid but TSynCobolSyn won''t'#13#10 +\r\n            '006700*    highlight \"VALUE\" keyword properly:'#13#10 +\r\n            '006800     03  WSV-STORE-DATE                         PIC 9(4)V99E99 VAL'#13#10 +\r\n            '006900-UE 0001.33E02.'#13#10 +\r\n            '007000* 2.2 Identifiers started from digits.'#13#10 +\r\n            '007100*    They are valid in COBOL but won''t be highlighted properly'#13#10 +\r\n            '007200*    by TSynCobolSyn. For example, \"000-main\" is a paragraph'#13#10 +\r\n            '007300*    name and should be highlighted as Area A identifier:'#13#10 +\r\n            '007400 000-main.'#13#10 +\r\n            '007500* 2.3 Comment entries in optional paragraphs'#13#10 +\r\n            '007600*    The so called comment-entries in the optional paragraphs'#13#10 +\r\n            '007700*    of the Identification Division are not supported and won''t'#13#10 +\r\n            '007800*    be highlighted properly.';\r\nend;\r\n\r\nfunction TSynCobolSyn.IsFilterStored: Boolean;\r\nbegin\r\n  Result := fDefaultFilter <> SYNS_FilterCOBOL;\r\nend;\r\n\r\nfunction TSynCobolSyn.IsIdentChar(AChar: WideChar): Boolean;\r\nbegin\r\n  case AChar of\r\n    '-', '0'..'9', 'a'..'z', 'A'..'Z':\r\n      Result := True;\r\n    else\r\n      Result := False;              \r\n  end;\r\nend;\r\n\r\nprocedure TSynCobolSyn.SetCodeStartPos(Value: LongInt);\r\nbegin\r\n  if Value < fCodeMediumPos then\r\n    fCodeStartPos := Value\r\n  else\r\n    fCodeStartPos := fCodeMediumPos;\r\nend;\r\n\r\nprocedure TSynCobolSyn.SetCodeMediumPos(Value: LongInt);\r\nbegin\r\n  if (fCodeStartPos <= Value) and (Value <= fCodeEndPos) then\r\n    fCodeMediumPos := Value\r\n  else\r\n    if Value > fCodeEndPos\r\n    then fCodeMediumPos := fCodeEndPos\r\n    else fCodeMediumPos := fCodeStartPos;\r\nend;\r\n\r\nprocedure TSynCobolSyn.SetCodeEndPos(Value: LongInt);\r\nbegin\r\n  if Value > fCodeMediumPos then\r\n    fCodeEndPos := Value\r\n  else\r\n    fCodeEndPos := fCodeMediumPos;\r\nend;\r\n\r\nclass function TSynCobolSyn.GetLanguageName: string;\r\nbegin\r\n  Result := SYNS_LangCOBOL;\r\nend;\r\n\r\nprocedure TSynCobolSyn.ResetRange;\r\nbegin\r\n  fRange := rsUnknown;\r\nend;\r\n\r\nprocedure TSynCobolSyn.SetRange(Value: Pointer);\r\nbegin\r\n  fRange := TRangeState(Value);\r\nend;\r\n\r\nfunction TSynCobolSyn.GetRange: Pointer;\r\nbegin\r\n  Result := Pointer(fRange);\r\nend;\r\n\r\nclass function TSynCobolSyn.GetFriendlyLanguageName: UnicodeString;\r\nbegin\r\n  Result := SYNS_FriendlyLangCOBOL;\r\nend;\r\n\r\ninitialization\r\n{$IFNDEF SYN_CPPB_1}\r\n  RegisterPlaceableHighlighter(TSynCobolSyn);\r\n{$ENDIF}\r\nend.\r\n"
  },
  {
    "path": "External/SynEdit/Source/SynHighlighterCpp.pas",
    "content": "{-------------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: SynHighlighterCpp.pas, released 2000-04-10.\r\nThe Original Code is based on the dcjCppSyn.pas file from the\r\nmwEdit component suite by Martin Waldenburg and other developers, the Initial\r\nAuthor of this file is Michael Trier.\r\nUnicode translation by Mal Hrz.\r\nAll Rights Reserved.\r\n\r\nContributors to the SynEdit and mwEdit projects are listed in the\r\nContributors.txt file.\r\n\r\nAlternatively, the contents of this file may be used under the terms of the\r\nGNU General Public License Version 2 or later (the \"GPL\"), in which case\r\nthe provisions of the GPL are applicable instead of those above.\r\nIf you wish to allow use of your version of this file only under the terms\r\nof the GPL and not to allow others to use your version of this file\r\nunder the MPL, indicate your decision by deleting the provisions above and\r\nreplace them with the notice and other provisions required by the GPL.\r\nIf you do not delete the provisions above, a recipient may use your version\r\nof this file under either the MPL or the GPL.\r\n\r\n$Id: SynHighlighterCpp.pas,v 1.22.2.9 2008/09/14 16:25:00 maelh Exp $\r\n\r\nYou may retrieve the latest version of this file at the SynEdit home page,\r\nlocated at http://SynEdit.SourceForge.net\r\n\r\nKnown Issues:\r\n-------------------------------------------------------------------------------}\r\n{\r\n@abstract(Provides a C++ syntax highlighter for SynEdit)\r\n@author(Michael Trier)\r\n@created(1998)\r\n@lastmod(2001-11-21)\r\nThe SynHighlighterCpp unit provides SynEdit with a C++ syntax highlighter.\r\nThanks to Martin Waldenburg.\r\n}\r\n\r\n{$IFNDEF QSYNHIGHLIGHTERCPP}\r\nunit SynHighlighterCpp;\r\n{$ENDIF}\r\n\r\n{$I SynEdit.inc}\r\n\r\ninterface\r\n\r\nuses\r\n{$IFDEF SYN_CLX}\r\n  QGraphics,\r\n  QSynEditTypes,\r\n  QSynEditHighlighter,\r\n  QSynUnicode,\r\n{$ELSE}\r\n  Graphics,\r\n  SynEditTypes,\r\n  SynEditHighlighter,\r\n  SynUnicode,\r\n{$ENDIF}\r\n  SysUtils,\r\n  Classes;\r\n\r\ntype\r\n  TtkTokenKind = (tkAsm, tkComment, tkDirective, tkIdentifier, tkKey, tkNull,\r\n    tkNumber, tkSpace, tkString, tkSymbol, tkUnknown,\r\n    tkChar, tkFloat, tkHex, tkOctal);\r\n\r\n  TxtkTokenKind = (\r\n    xtkAdd, xtkAddAssign, xtkAnd, xtkAndAssign, xtkArrow, xtkAssign,\r\n    xtkBitComplement, xtkBraceClose, xtkBraceOpen, xtkColon, xtkComma,\r\n    xtkDecrement, xtkDivide, xtkDivideAssign, xtkEllipse, xtkGreaterThan,\r\n    xtkGreaterThanEqual, xtkIncOr, xtkIncOrAssign, xtkIncrement, xtkLessThan,\r\n    xtkLessThanEqual, xtkLogAnd, xtkLogComplement, xtkLogEqual, xtkLogOr,\r\n    xtkMod, xtkModAssign, xtkMultiplyAssign, xtkNotEqual, xtkPoint, xtkQuestion,\r\n    xtkRoundClose, xtkRoundOpen, xtkScopeResolution, xtkSemiColon, xtkShiftLeft,\r\n    xtkShiftLeftAssign, xtkShiftRight, xtkShiftRightAssign, xtkSquareClose,\r\n    xtkSquareOpen, xtkStar, xtkSubtract, xtkSubtractAssign, xtkXor,\r\n    xtkXorAssign);\r\n\r\n  TRangeState = (rsUnknown, rsAnsiC, rsAnsiCAsm, rsAnsiCAsmBlock, rsAsm,\r\n    rsAsmBlock, rsDirective, rsDirectiveComment, rsString34, rsString39,\r\n    rsMultiLineString, rsMultiLineDirective);\r\n\r\n  PIdentFuncTableFunc = ^TIdentFuncTableFunc;\r\n  TIdentFuncTableFunc = function (Index: Integer): TtkTokenKind of object;\r\n\r\n  TSynCppSyn = class(TSynCustomHighlighter)\r\n  private\r\n    fAsmStart: Boolean;\r\n    fRange: TRangeState;\r\n    FTokenID: TtkTokenKind;\r\n    FExtTokenID: TxtkTokenKind;\r\n    fIdentFuncTable: array[0..342] of TIdentFuncTableFunc;\r\n    fAsmAttri: TSynHighlighterAttributes;\r\n    fCommentAttri: TSynHighlighterAttributes;\r\n    fDirecAttri: TSynHighlighterAttributes;\r\n    fIdentifierAttri: TSynHighlighterAttributes;\r\n    fInvalidAttri: TSynHighlighterAttributes;\r\n    fKeyAttri: TSynHighlighterAttributes;\r\n    fNumberAttri: TSynHighlighterAttributes;\r\n    fFloatAttri: TSynHighlighterAttributes;\r\n    fHexAttri: TSynHighlighterAttributes;\r\n    fOctalAttri: TSynHighlighterAttributes;\r\n    fSpaceAttri: TSynHighlighterAttributes;\r\n    fStringAttri: TSynHighlighterAttributes;\r\n    fCharAttri: TSynHighlighterAttributes;\r\n    fSymbolAttri: TSynHighlighterAttributes;\r\n    function AltFunc(Index: Integer): TtkTokenKind;\r\n    function KeyWordFunc(Index: Integer): TtkTokenKind;\r\n    function FuncAsm(Index: Integer): TtkTokenKind;\r\n    function HashKey(Str: PWideChar): Cardinal;\r\n    function IdentKind(MayBe: PWideChar): TtkTokenKind;\r\n    procedure InitIdent;\r\n    procedure AnsiCProc;\r\n    procedure AndSymbolProc;\r\n    procedure AsciiCharProc;\r\n    procedure AtSymbolProc;\r\n    procedure BraceCloseProc;\r\n    procedure BraceOpenProc;\r\n    procedure CRProc;\r\n    procedure ColonProc;\r\n    procedure CommaProc;\r\n    procedure DirectiveProc;\r\n    procedure DirectiveEndProc;\r\n    procedure EqualProc;\r\n    procedure GreaterProc;\r\n    procedure IdentProc;\r\n    procedure LFProc;\r\n    procedure LowerProc;\r\n    procedure MinusProc;\r\n    procedure ModSymbolProc;\r\n    procedure NotSymbolProc;\r\n    procedure NullProc;\r\n    procedure NumberProc;\r\n    procedure OrSymbolProc;\r\n    procedure PlusProc;\r\n    procedure PointProc;\r\n    procedure QuestionProc;\r\n    procedure RoundCloseProc;\r\n    procedure RoundOpenProc;\r\n    procedure SemiColonProc;\r\n    procedure SlashProc;\r\n    procedure SpaceProc;\r\n    procedure SquareCloseProc;\r\n    procedure SquareOpenProc;\r\n    procedure StarProc;\r\n    procedure StringProc;\r\n    procedure TildeProc;\r\n    procedure XOrSymbolProc;\r\n    procedure UnknownProc;\r\n    procedure StringEndProc;\r\n  protected\r\n    function GetExtTokenID: TxtkTokenKind;\r\n    function GetSampleSource: UnicodeString; override;\r\n    function IsFilterStored: Boolean; override;\r\n  public\r\n    class function GetCapabilities: TSynHighlighterCapabilities; override;\r\n    class function GetLanguageName: string; override;\r\n    class function GetFriendlyLanguageName: UnicodeString; override;\r\n  public\r\n    constructor Create(AOwner: TComponent); override;\r\n    function GetDefaultAttribute(Index: integer): TSynHighlighterAttributes;\r\n      override;\r\n    function GetEol: Boolean; override;\r\n    function GetRange: Pointer; override;\r\n    function GetTokenID: TtkTokenKind;\r\n    function GetTokenAttribute: TSynHighlighterAttributes; override;\r\n    function GetTokenKind: integer; override;\r\n    procedure Next; override;\r\n    procedure SetRange(Value: Pointer); override;\r\n    procedure ResetRange; override;\r\n    function UseUserSettings(settingIndex: integer): boolean; override;\r\n    procedure EnumUserSettings(settings: TStrings); override;\r\n    property ExtTokenID: TxtkTokenKind read GetExtTokenID;\r\n  published\r\n    property AsmAttri: TSynHighlighterAttributes read fAsmAttri write fAsmAttri;\r\n    property CommentAttri: TSynHighlighterAttributes read fCommentAttri\r\n      write fCommentAttri;\r\n    property DirecAttri: TSynHighlighterAttributes read fDirecAttri\r\n      write fDirecAttri;\r\n    property IdentifierAttri: TSynHighlighterAttributes read fIdentifierAttri\r\n      write fIdentifierAttri;\r\n    property InvalidAttri: TSynHighlighterAttributes read fInvalidAttri\r\n      write fInvalidAttri;\r\n    property KeyAttri: TSynHighlighterAttributes read fKeyAttri write fKeyAttri;\r\n    property NumberAttri: TSynHighlighterAttributes read fNumberAttri\r\n      write fNumberAttri;\r\n    property FloatAttri: TSynHighlighterAttributes read fFloatAttri\r\n      write fFloatAttri;\r\n    property HexAttri: TSynHighlighterAttributes read fHexAttri\r\n      write fHexAttri;\r\n    property OctalAttri: TSynHighlighterAttributes read fOctalAttri\r\n      write fOctalAttri;\r\n    property SpaceAttri: TSynHighlighterAttributes read fSpaceAttri\r\n      write fSpaceAttri;\r\n    property StringAttri: TSynHighlighterAttributes read fStringAttri\r\n      write fStringAttri;\r\n    property CharAttri: TSynHighlighterAttributes read fCharAttri\r\n      write fCharAttri;\r\n    property SymbolAttri: TSynHighlighterAttributes read fSymbolAttri\r\n      write fSymbolAttri;\r\n  end;\r\n\r\nimplementation\r\n\r\nuses\r\n{$IFDEF SYN_CLX}\r\n  QSynEditStrConst;\r\n{$ELSE}\r\n  Windows,\r\n  SynEditStrConst;\r\n{$ENDIF}\r\n\r\nconst\r\n  KeyWords: array[0..94] of UnicodeString = (\r\n    '__asm', '__automated', '__cdecl', '__classid', '__closure', '__declspec', \r\n    '__dispid', '__except', '__export', '__fastcall', '__finally', '__import', \r\n    '__int16', '__int32', '__int64', '__int8', '__pascal', '__property', \r\n    '__published', '__rtti', '__stdcall', '__thread', '__try', '_asm', '_cdecl', \r\n    '_export', '_fastcall', '_import', '_pascal', '_stdcall', 'asm', 'auto', \r\n    'bool', 'break', 'case', 'catch', 'cdecl', 'char', 'class', 'const', \r\n    'const_cast', 'continue', 'default', 'delete', 'do', 'double', \r\n    'dynamic_cast', 'else', 'enum', 'explicit', 'extern', 'false', 'float', \r\n    'for', 'friend', 'goto', 'if', 'inline', 'int', 'interface', 'long', \r\n    'mutable', 'namespace', 'new', 'operator', 'pascal', 'private', 'protected', \r\n    'public', 'register', 'reinterpret_cast', 'return', 'short', 'signed', \r\n    'sizeof', 'static', 'static_cast', 'struct', 'switch', 'template', 'this', \r\n    'throw', 'true', 'try', 'typedef', 'typeid', 'typename', 'union', \r\n    'unsigned', 'using', 'virtual', 'void', 'volatile', 'wchar_t', 'while' \r\n  );\r\n\r\n  KeyIndices: array[0..342] of Integer = (\r\n    -1, 34, -1, -1, 57, 72, -1, 39, -1, 9, -1, 86, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, 88, -1, 12, 66, -1, -1, -1, -1, -1, 42, -1, -1, -1, -1, -1, 56, 51, \r\n    40, 87, 77, -1, -1, -1, -1, 64, -1, -1, -1, -1, -1, -1, -1, -1, -1, 28, 41, \r\n    -1, 63, 6, -1, -1, -1, -1, -1, -1, -1, -1, 55, 65, 0, -1, -1, -1, -1, -1, \r\n    -1, 26, 83, -1, 38, 92, -1, -1, 93, 33, -1, -1, -1, -1, -1, -1, -1, 35, -1, \r\n    -1, -1, -1, -1, -1, -1, 79, 27, -1, -1, -1, 43, -1, -1, 20, -1, -1, 31, -1, \r\n    -1, -1, -1, -1, 89, -1, -1, -1, -1, 59, -1, 58, -1, -1, 46, -1, -1, 3, -1, \r\n    -1, 17, -1, 54, -1, 45, -1, -1, -1, -1, -1, -1, 53, -1, -1, -1, 1, -1, -1, \r\n    -1, -1, 44, 90, 32, -1, -1, -1, -1, -1, -1, 91, 13, -1, -1, -1, 60, -1, -1, \r\n    -1, -1, -1, 49, -1, -1, -1, -1, -1, -1, 75, -1, -1, 76, -1, -1, -1, -1, 30, \r\n    68, 23, 82, -1, 15, -1, -1, 2, -1, 70, -1, -1, -1, 73, 18, -1, -1, -1, -1, \r\n    -1, 47, 24, 52, 14, 84, -1, -1, -1, -1, -1, 25, -1, -1, -1, 80, 69, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 21, -1, 19, -1, -1, -1, \r\n    -1, -1, -1, 74, -1, -1, -1, 29, -1, -1, -1, 67, -1, 7, -1, -1, -1, 50, 61, \r\n    -1, -1, -1, 4, -1, 94, 85, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    81, -1, -1, -1, -1, -1, 10, 16, -1, -1, 36, 37, -1, -1, -1, 8, -1, 22, -1, \r\n    -1, -1, -1, 78, 62, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, 71, -1, -1, -1, 5, -1, -1, -1, -1, -1, -1, -1, 11, -1, 48, \r\n    -1 \r\n  );\r\n\r\n{$Q-}\r\nfunction TSynCppSyn.HashKey(Str: PWideChar): Cardinal;\r\nbegin\r\n  Result := 0;\r\n  while IsIdentChar(Str^) do\r\n  begin\r\n    Result := Result * 179 + Ord(Str^) * 44;\r\n    inc(Str);\r\n  end;\r\n  Result := Result mod 343;\r\n  fStringLen := Str - fToIdent;\r\nend;\r\n{$Q+}\r\n\r\nfunction TSynCppSyn.IdentKind(MayBe: PWideChar): TtkTokenKind;\r\nvar\r\n  Key: Cardinal;\r\nbegin\r\n  fToIdent := MayBe;\r\n  Key := HashKey(MayBe);\r\n  if Key <= High(fIdentFuncTable) then\r\n    Result := fIdentFuncTable[Key](KeyIndices[Key])\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nprocedure TSynCppSyn.InitIdent;\r\nvar\r\n  i: Integer;\r\nbegin\r\n  for i := Low(fIdentFuncTable) to High(fIdentFuncTable) do\r\n    if KeyIndices[i] = -1 then\r\n      fIdentFuncTable[i] := AltFunc;\r\n\r\n  fIdentFuncTable[70] := FuncAsm;\r\n  fIdentFuncTable[191] := FuncAsm;\r\n  fIdentFuncTable[189] := FuncAsm;\r\n\r\n  for i := Low(fIdentFuncTable) to High(fIdentFuncTable) do\r\n    if @fIdentFuncTable[i] = nil then\r\n      fIdentFuncTable[i] := KeyWordFunc;\r\nend;\r\n\r\nfunction TSynCppSyn.AltFunc(Index: Integer): TtkTokenKind;\r\nbegin\r\n  Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynCppSyn.KeyWordFunc(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier\r\nend;\r\n\r\nfunction TSynCppSyn.FuncAsm(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n  begin\r\n    Result := tkKey;\r\n    fRange := rsAsm;\r\n    fAsmStart := True;\r\n  end\r\n  else\r\n    Result := tkIdentifier\r\nend;\r\n\r\nconstructor TSynCppSyn.Create(AOwner: TComponent);\r\nbegin\r\n  inherited Create(AOwner);\r\n\r\n  fCaseSensitive := True;\r\n\r\n  fAsmAttri := TSynHighlighterAttributes.Create(SYNS_AttrAssembler, SYNS_FriendlyAttrAssembler);\r\n  AddAttribute(fAsmAttri);\r\n  fCommentAttri := TSynHighlighterAttributes.Create(SYNS_AttrComment, SYNS_FriendlyAttrComment);\r\n  fCommentAttri.Style:= [fsItalic];\r\n  AddAttribute(fCommentAttri);\r\n  fIdentifierAttri := TSynHighlighterAttributes.Create(SYNS_AttrIdentifier, SYNS_FriendlyAttrIdentifier);\r\n  AddAttribute(fIdentifierAttri);\r\n  fInvalidAttri := TSynHighlighterAttributes.Create(SYNS_AttrIllegalChar, SYNS_FriendlyAttrIllegalChar);\r\n  AddAttribute(fInvalidAttri);\r\n  fKeyAttri := TSynHighlighterAttributes.Create(SYNS_AttrReservedWord, SYNS_FriendlyAttrReservedWord);\r\n  fKeyAttri.Style:= [fsBold];\r\n  AddAttribute(fKeyAttri);\r\n  fNumberAttri := TSynHighlighterAttributes.Create(SYNS_AttrNumber, SYNS_FriendlyAttrNumber);\r\n  AddAttribute(fNumberAttri);\r\n  fCharAttri := TSynHighlighterAttributes.Create(SYNS_AttrCharacter, SYNS_FriendlyAttrCharacter);\r\n  AddAttribute(fCharAttri);\r\n  fFloatAttri := TSynHighlighterAttributes.Create(SYNS_AttrFloat, SYNS_FriendlyAttrFloat);\r\n  AddAttribute(fFloatAttri);\r\n  fHexAttri := TSynHighlighterAttributes.Create(SYNS_AttrHexadecimal, SYNS_FriendlyAttrHexadecimal);\r\n  AddAttribute(fHexAttri);\r\n  fOctalAttri := TSynHighlighterAttributes.Create(SYNS_AttrOctal, SYNS_FriendlyAttrOctal);\r\n  AddAttribute(fOctalAttri);\r\n  fSpaceAttri := TSynHighlighterAttributes.Create(SYNS_AttrSpace, SYNS_FriendlyAttrSpace);\r\n  AddAttribute(fSpaceAttri);\r\n  fStringAttri := TSynHighlighterAttributes.Create(SYNS_AttrString, SYNS_FriendlyAttrString);\r\n  AddAttribute(fStringAttri);\r\n  fSymbolAttri := TSynHighlighterAttributes.Create(SYNS_AttrSymbol, SYNS_FriendlyAttrSymbol);\r\n  AddAttribute(fSymbolAttri);\r\n  fDirecAttri := TSynHighlighterAttributes.Create(SYNS_AttrPreprocessor, SYNS_FriendlyAttrPreprocessor);\r\n  AddAttribute(fDirecAttri);\r\n  SetAttributesOnChange(DefHighlightChange);\r\n  InitIdent;\r\n  fRange := rsUnknown;\r\n  fAsmStart := False;\r\n  fDefaultFilter := SYNS_FilterCPP;\r\nend;\r\n\r\nprocedure TSynCppSyn.AnsiCProc;\r\nbegin\r\n  fTokenID := tkComment;\r\n  case FLine[Run] of\r\n    #0:\r\n      begin\r\n        NullProc;\r\n        exit;\r\n      end;\r\n    #10:\r\n      begin\r\n        LFProc;\r\n        exit;\r\n      end;\r\n    #13:\r\n      begin\r\n        CRProc;\r\n        exit;\r\n      end;\r\n  end;\r\n\r\n  while FLine[Run] <> #0 do\r\n    case FLine[Run] of\r\n      '*':\r\n        if fLine[Run + 1] = '/' then\r\n        begin\r\n          inc(Run, 2);\r\n          if fRange = rsAnsiCAsm then\r\n            fRange := rsAsm\r\n          else if fRange = rsAnsiCAsmBlock then\r\n            fRange := rsAsmBlock\r\n          else if (fRange = rsDirectiveComment) and\r\n            not IsLineEnd(Run) then\r\n              fRange := rsMultiLineDirective\r\n          else\r\n            fRange := rsUnKnown;\r\n          break;\r\n        end else\r\n          inc(Run);\r\n      #10: break;\r\n      #13: break;\r\n    else inc(Run);\r\n    end;\r\nend;\r\n\r\nprocedure TSynCppSyn.AndSymbolProc;\r\nbegin\r\n  fTokenID := tkSymbol;\r\n  case FLine[Run + 1] of\r\n    '=':                               {and assign}\r\n      begin\r\n        inc(Run, 2);\r\n        FExtTokenID := xtkAndAssign;\r\n      end;\r\n    '&':                               {logical and}\r\n      begin\r\n        inc(Run, 2);\r\n        FExtTokenID := xtkLogAnd;\r\n      end;\r\n  else                                 {and}\r\n    begin\r\n      inc(Run);\r\n      FExtTokenID := xtkAnd;\r\n    end;\r\n  end;\r\nend;\r\n\r\nprocedure TSynCppSyn.AsciiCharProc;\r\nbegin\r\n  fTokenID := tkChar;\r\n  repeat\r\n    if fLine[Run] = '\\' then begin\r\n      if CharInSet(fLine[Run + 1], [#39, '\\']) then\r\n        inc(Run);\r\n    end;\r\n    inc(Run);\r\n  until IsLineEnd(Run) or (fLine[Run] = #39);\r\n  if fLine[Run] = #39 then\r\n    inc(Run);\r\nend;\r\n\r\nprocedure TSynCppSyn.AtSymbolProc;\r\nbegin\r\n  fTokenID := tkUnknown;\r\n  inc(Run);\r\nend;\r\n\r\nprocedure TSynCppSyn.BraceCloseProc;\r\nbegin\r\n  inc(Run);\r\n  fTokenId := tkSymbol;\r\n  FExtTokenID := xtkBraceClose;\r\n  if fRange = rsAsmBlock then fRange := rsUnknown;\r\nend;\r\n\r\nprocedure TSynCppSyn.BraceOpenProc;\r\nbegin\r\n  inc(Run);\r\n  fTokenId := tkSymbol;\r\n  FExtTokenID := xtkBraceOpen;\r\n  if fRange = rsAsm then\r\n  begin\r\n    fRange := rsAsmBlock;\r\n    fAsmStart := True;\r\n  end;\r\nend;\r\n\r\nprocedure TSynCppSyn.CRProc;\r\nbegin\r\n  fTokenID := tkSpace;\r\n  Inc(Run);\r\n  if fLine[Run + 1] = #10 then Inc(Run);\r\nend;\r\n\r\nprocedure TSynCppSyn.ColonProc;\r\nbegin\r\n  fTokenID := tkSymbol;\r\n  case FLine[Run + 1] of\r\n    ':':                               {scope resolution operator}\r\n      begin\r\n        inc(Run, 2);\r\n        FExtTokenID := xtkScopeResolution;\r\n      end;\r\n  else                                 {colon}\r\n    begin\r\n      inc(Run);\r\n      FExtTokenID := xtkColon;\r\n    end;\r\n  end;\r\nend;\r\n\r\nprocedure TSynCppSyn.CommaProc;\r\nbegin\r\n  inc(Run);\r\n  fTokenID := tkSymbol;\r\n  FExtTokenID := xtkComma;\r\nend;\r\n\r\nprocedure TSynCppSyn.DirectiveProc;\r\nbegin\r\n  if WideTrim(fLine)[1] <> '#' then // '#' is not first char on the line, treat it as an invalid char\r\n  begin\r\n    fTokenID := tkUnknown;\r\n    Inc(Run);\r\n    Exit;\r\n  end;\r\n  fTokenID := tkDirective;\r\n  repeat\r\n    if fLine[Run] = '/' then // comment?\r\n    begin\r\n      if fLine[Run + 1] = '/' then // is end of directive as well\r\n      begin\r\n        fRange := rsUnknown;\r\n        Exit;\r\n      end\r\n      else\r\n        if fLine[Run + 1] = '*' then // might be embedded only\r\n        begin\r\n          fRange := rsDirectiveComment;\r\n          Exit;\r\n        end;\r\n    end;\r\n    if (fLine[Run] = '\\') and (fLine[Run +1 ] = #0) then // a multiline directive\r\n    begin\r\n      Inc(Run);\r\n      fRange := rsMultiLineDirective;\r\n      Exit;\r\n    end;\r\n    Inc(Run);\r\n  until IsLineEnd(Run)\r\nend;\r\n\r\nprocedure TSynCppSyn.DirectiveEndProc;\r\nbegin\r\n  fTokenID := tkDirective;\r\n  case FLine[Run] of\r\n    #0:\r\n      begin\r\n        NullProc;\r\n        Exit;\r\n      end;\r\n    #10:\r\n      begin\r\n        LFProc;\r\n        Exit;\r\n      end;\r\n    #13:\r\n      begin\r\n        CRProc;\r\n        Exit;\r\n      end;\r\n  end;\r\n  fRange := rsUnknown;\r\n  repeat\r\n    case FLine[Run] of\r\n      #0, #10, #13: Break;\r\n      '/': // comment?\r\n        begin\r\n          case fLine[Run + 1] of\r\n            '/': // is end of directive as well\r\n              begin\r\n                fRange := rsUnknown;\r\n                Exit;\r\n              end;\r\n            '*': // might be embedded only\r\n              begin\r\n                fRange := rsDirectiveComment;\r\n                Exit;\r\n              end;\r\n          end;\r\n        end;\r\n      '\\': // yet another line?\r\n        begin\r\n          if fLine[Run + 1] = #0 then\r\n          begin\r\n            Inc(Run);\r\n            fRange := rsMultiLineDirective;\r\n            Exit;\r\n          end;\r\n        end;\r\n    end;\r\n    Inc(Run);\r\n  until IsLineEnd(Run);\r\nend;\r\n\r\nprocedure TSynCppSyn.EqualProc;\r\nbegin\r\n  fTokenID := tkSymbol;\r\n  case FLine[Run + 1] of\r\n    '=':                               {logical equal}\r\n      begin\r\n        inc(Run, 2);\r\n        FExtTokenID := xtkLogEqual;\r\n      end;\r\n  else                                 {assign}\r\n    begin\r\n      inc(Run);\r\n      FExtTokenID := xtkAssign;\r\n    end;\r\n  end;\r\nend;\r\n\r\nprocedure TSynCppSyn.GreaterProc;\r\nbegin\r\n  fTokenID := tkSymbol;\r\n  case FLine[Run + 1] of\r\n    '=':                               {greater than or equal to}\r\n      begin\r\n        inc(Run, 2);\r\n        FExtTokenID := xtkGreaterThanEqual;\r\n      end;\r\n    '>':\r\n      begin\r\n        if FLine[Run + 2] = '=' then   {shift right assign}\r\n        begin\r\n          inc(Run, 3);\r\n          FExtTokenID := xtkShiftRightAssign;\r\n        end\r\n        else                           {shift right}\r\n        begin\r\n          inc(Run, 2);\r\n          FExtTokenID := xtkShiftRight;\r\n        end;\r\n      end;\r\n  else                                 {greater than}\r\n    begin\r\n      inc(Run);\r\n      FExtTokenID := xtkGreaterThan;\r\n    end;\r\n  end;\r\nend;\r\n\r\nprocedure TSynCppSyn.QuestionProc;\r\nbegin\r\n  fTokenID := tkSymbol;                {conditional}\r\n  FExtTokenID := xtkQuestion;\r\n  inc(Run);\r\nend;\r\n\r\nprocedure TSynCppSyn.IdentProc;\r\nbegin\r\n  fTokenID := IdentKind((fLine + Run));\r\n  inc(Run, fStringLen);\r\n  while IsIdentChar(fLine[Run]) do inc(Run);\r\nend;\r\n\r\nprocedure TSynCppSyn.LFProc;\r\nbegin\r\n  fTokenID := tkSpace;\r\n  inc(Run);\r\nend;\r\n\r\nprocedure TSynCppSyn.LowerProc;\r\nbegin\r\n  fTokenID := tkSymbol;\r\n  case FLine[Run + 1] of\r\n    '=':                               {less than or equal to}\r\n      begin\r\n        inc(Run, 2);\r\n        FExtTokenID := xtkLessThanEqual;\r\n      end;\r\n    '<':\r\n      begin\r\n        if FLine[Run + 2] = '=' then   {shift left assign}\r\n        begin\r\n          inc(Run, 3);\r\n          FExtTokenID := xtkShiftLeftAssign;\r\n        end\r\n        else                           {shift left}\r\n        begin\r\n          inc(Run, 2);\r\n          FExtTokenID := xtkShiftLeft;\r\n        end;\r\n      end;\r\n  else                                 {less than}\r\n    begin\r\n      inc(Run);\r\n      FExtTokenID := xtkLessThan;\r\n    end;\r\n  end;\r\nend;\r\n\r\nprocedure TSynCppSyn.MinusProc;\r\nbegin\r\n  fTokenID := tkSymbol;\r\n  case FLine[Run + 1] of\r\n    '=':                               {subtract assign}\r\n      begin\r\n        inc(Run, 2);\r\n        FExtTokenID := xtkSubtractAssign;\r\n      end;\r\n    '-':                               {decrement}\r\n      begin\r\n        inc(Run, 2);\r\n        FExtTokenID := xtkDecrement;\r\n      end;\r\n    '>':                               {arrow}\r\n      begin\r\n        inc(Run, 2);\r\n        FExtTokenID := xtkArrow;\r\n      end;\r\n  else                                 {subtract}\r\n    begin\r\n      inc(Run);\r\n      FExtTokenID := xtkSubtract;\r\n    end;\r\n  end;\r\nend;\r\n\r\nprocedure TSynCppSyn.ModSymbolProc;\r\nbegin\r\n  fTokenID := tkSymbol;\r\n  case FLine[Run + 1] of\r\n    '=':                               {mod assign}\r\n      begin\r\n        inc(Run, 2);\r\n        FExtTokenID := xtkModAssign;\r\n      end;\r\n  else                                 {mod}\r\n    begin\r\n      inc(Run);\r\n      FExtTokenID := xtkMod;\r\n    end;\r\n  end;\r\nend;\r\n\r\nprocedure TSynCppSyn.NotSymbolProc;\r\nbegin\r\n  fTokenID := tkSymbol;\r\n  case FLine[Run + 1] of\r\n    '=':                               {not equal}\r\n      begin\r\n        inc(Run, 2);\r\n        FExtTokenID := xtkNotEqual;\r\n      end;\r\n  else                                 {not}\r\n    begin\r\n      inc(Run);\r\n      FExtTokenID := xtkLogComplement;\r\n    end;\r\n  end;\r\nend;\r\n\r\nprocedure TSynCppSyn.NullProc;\r\nbegin\r\n  fTokenID := tkNull;\r\n  inc(Run);\r\nend;\r\n\r\nprocedure TSynCppSyn.NumberProc;\r\n\r\n  function IsNumberChar(Run: Integer): Boolean;\r\n  begin\r\n    case fLine[Run] of\r\n      '0'..'9', 'A'..'F', 'a'..'f', '.', 'u', 'U', 'l', 'L', 'x', 'X', '-', '+':\r\n        Result := True;\r\n      else\r\n        Result := False;\r\n    end;\r\n  end;\r\n\r\n  function IsDigitPlusMinusChar(Run: Integer): Boolean;\r\n  begin\r\n    case fLine[Run] of\r\n      '0'..'9', '+', '-':\r\n        Result := True;\r\n      else\r\n        Result := False;\r\n    end;\r\n  end;\r\n\r\n  function IsHexDigit(Run: Integer): Boolean;\r\n  begin\r\n    case fLine[Run] of\r\n      '0'..'9', 'a'..'f', 'A'..'F':\r\n        Result := True;\r\n      else\r\n        Result := False;\r\n    end;\r\n  end;\r\n\r\n  function IsAlphaUncerscore(Run: Integer): Boolean;\r\n  begin\r\n    case fLine[Run] of\r\n      'A'..'Z', 'a'..'z', '_':\r\n        Result := True;\r\n      else\r\n        Result := False;\r\n    end;\r\n  end;\r\n\r\nvar\r\n  idx1: Integer; // token[1]\r\n  i: Integer;\r\nbegin\r\n  idx1 := Run;\r\n  Inc(Run);\r\n  fTokenID := tkNumber;\r\n  while IsNumberChar(Run) do\r\n  begin\r\n    case FLine[Run] of\r\n      '.':\r\n        if FLine[Succ(Run)] = '.' then\r\n          Break\r\n        else\r\n          if (fTokenID <> tkHex) then\r\n            fTokenID := tkFloat\r\n          else // invalid\r\n          begin\r\n            fTokenID := tkUnknown;\r\n            Exit;\r\n          end;\r\n      '-', '+':\r\n        begin\r\n          if fTokenID <> tkFloat then // number <> float. an arithmetic operator\r\n            Exit;\r\n          if not CharInSet(FLine[Pred(Run)], ['e', 'E']) then\r\n            Exit; // number = float, but no exponent. an arithmetic operator\r\n          if not IsDigitPlusMinusChar(Succ(Run)) then // invalid\r\n          begin\r\n            Inc(Run);\r\n            fTokenID := tkUnknown;\r\n            Exit;\r\n          end\r\n        end;\r\n      '0'..'7':\r\n        if (Run = Succ(idx1)) and (FLine[idx1] = '0') then // octal number\r\n          fTokenID := tkOctal;\r\n      '8', '9':\r\n        if (FLine[idx1] = '0') and\r\n           ((fTokenID <> tkHex) and (fTokenID <> tkFloat)) then // invalid octal char\r\n             fTokenID := tkUnknown;\r\n      'a'..'d', 'A'..'D':\r\n        if fTokenID <> tkHex then // invalid char\r\n          Break;\r\n      'e', 'E':\r\n        if (fTokenID <> tkHex) then\r\n          if CharInSet(FLine[Pred(Run)], ['0'..'9']) then // exponent\r\n          begin\r\n            for i := idx1 to Pred(Run) do\r\n              if CharInSet(FLine[i], ['e', 'E']) then // too many exponents\r\n              begin\r\n                fTokenID := tkUnknown;\r\n                Exit;\r\n              end;\r\n            if not IsDigitPlusMinusChar(Succ(Run)) then\r\n              Break\r\n            else\r\n              fTokenID := tkFloat\r\n          end\r\n          else // invalid char\r\n            Break;\r\n      'f', 'F':\r\n        if fTokenID <> tkHex then\r\n        begin\r\n          for i := idx1 to Pred(Run) do\r\n            if CharInSet(FLine[i], ['f', 'F']) then // declaration syntax error\r\n            begin\r\n              fTokenID := tkUnknown;\r\n              Exit;\r\n            end;\r\n          if fTokenID = tkFloat then\r\n          begin\r\n            if CharInSet(fLine[Pred(Run)], ['l', 'L']) then // can't mix\r\n              Break;\r\n          end\r\n          else\r\n            fTokenID := tkFloat;\r\n        end;\r\n      'l', 'L':\r\n        begin\r\n          for i := idx1 to Run - 2 do\r\n            if CharInSet(FLine[i], ['l', 'L']) then // declaration syntax error\r\n            begin\r\n              fTokenID := tkUnknown;\r\n              Exit;\r\n            end;\r\n          if fTokenID = tkFloat then\r\n            if CharInSet(fLine[Pred(Run)], ['f', 'F']) then // can't mix\r\n              Break;\r\n        end;\r\n      'u', 'U':\r\n        if fTokenID = tkFloat then // not allowed\r\n          Break\r\n        else\r\n          for i := idx1 to Pred(Run) do\r\n            if CharInSet(FLine[i], ['u', 'U']) then // declaration syntax error\r\n            begin\r\n              fTokenID := tkUnknown;\r\n              Exit;\r\n            end;\r\n      'x', 'X':\r\n        if (Run = Succ(idx1)) and   // 0x... 'x' must be second char\r\n           (FLine[idx1] = '0') and  // 0x...\r\n           IsHexDigit(Succ(Run)) then // 0x... must be continued with a number\r\n             fTokenID := tkHex\r\n           else // invalid char\r\n           begin\r\n             if not IsIdentChar(fLine[Succ(Run)]) and\r\n                CharInSet(FLine[Succ(idx1)], ['x', 'X']) then\r\n             begin\r\n               Inc(Run); // highlight 'x' too\r\n               fTokenID := tkUnknown;\r\n             end;\r\n             Break;\r\n           end;\r\n    end; // case\r\n    Inc(Run);\r\n  end; // while\r\n  if IsAlphaUncerscore(Run) then\r\n    fTokenID := tkUnknown;   \r\nend;\r\n\r\nprocedure TSynCppSyn.OrSymbolProc;\r\nbegin\r\n  fTokenID := tkSymbol;\r\n  case FLine[Run + 1] of\r\n    '=':                               {or assign}\r\n      begin\r\n        inc(Run, 2);\r\n        FExtTokenID := xtkIncOrAssign;\r\n      end;\r\n    '|':                               {logical or}\r\n      begin\r\n        inc(Run, 2);\r\n        FExtTokenID := xtkLogOr;\r\n      end;\r\n  else                                 {or}\r\n    begin\r\n      inc(Run);\r\n      FExtTokenID := xtkIncOr;\r\n    end;\r\n  end;\r\nend;\r\n\r\nprocedure TSynCppSyn.PlusProc;\r\nbegin\r\n  fTokenID := tkSymbol;\r\n  case FLine[Run + 1] of\r\n    '=':                               {add assign}\r\n      begin\r\n        inc(Run, 2);\r\n        FExtTokenID := xtkAddAssign;\r\n      end;\r\n    '+':                               {increment}\r\n      begin\r\n        inc(Run, 2);\r\n        FExtTokenID := xtkIncrement;\r\n      end;\r\n  else                                 {add}\r\n    begin\r\n      inc(Run);\r\n      FExtTokenID := xtkAdd;\r\n    end;\r\n  end;\r\nend;\r\n\r\nprocedure TSynCppSyn.PointProc;\r\nbegin\r\n  fTokenID := tkSymbol;\r\n  if (FLine[Run + 1] = '.') and (FLine[Run + 2] = '.') then\r\n    begin                              {ellipse}\r\n      inc(Run, 3);\r\n      FExtTokenID := xtkEllipse;\r\n    end\r\n  else\r\n    if CharInSet(FLine[Run + 1], ['0'..'9']) then // float\r\n    begin\r\n      Dec(Run); // numberproc must see the point\r\n      NumberProc;\r\n    end\r\n  else                                 {point}\r\n    begin\r\n      inc(Run);\r\n      FExtTokenID := xtkPoint;\r\n    end;\r\nend;\r\n\r\nprocedure TSynCppSyn.RoundCloseProc;\r\nbegin\r\n  inc(Run);\r\n  fTokenID := tkSymbol;\r\n  FExtTokenID := xtkRoundClose;\r\nend;\r\n\r\nprocedure TSynCppSyn.RoundOpenProc;\r\nbegin\r\n  inc(Run);\r\n  FTokenID := tkSymbol;\r\n  FExtTokenID := xtkRoundOpen;\r\nend;\r\n\r\nprocedure TSynCppSyn.SemiColonProc;\r\nbegin\r\n  inc(Run);\r\n  fTokenID := tkSymbol;\r\n  FExtTokenID := xtkSemiColon;\r\n  if fRange = rsAsm then fRange := rsUnknown;\r\nend;\r\n\r\nprocedure TSynCppSyn.SlashProc;\r\nbegin\r\n  case FLine[Run + 1] of\r\n    '/':                               {c++ style comments}\r\n      begin\r\n        fTokenID := tkComment;\r\n        inc(Run, 2);\r\n        while not IsLineEnd(Run) do Inc(Run);\r\n      end;\r\n    '*':                               {c style comments}\r\n      begin\r\n        fTokenID := tkComment;\r\n        if fRange = rsAsm then\r\n          fRange := rsAnsiCAsm\r\n        else if fRange = rsAsmBlock then\r\n          fRange := rsAnsiCAsmBlock\r\n        else if fRange <> rsDirectiveComment then\r\n          fRange := rsAnsiC;\r\n        inc(Run, 2);\r\n        while fLine[Run] <> #0 do\r\n          case fLine[Run] of\r\n            '*':\r\n              if fLine[Run + 1] = '/' then\r\n              begin\r\n                inc(Run, 2);\r\n                if fRange = rsDirectiveComment then\r\n                  fRange := rsMultiLineDirective\r\n                else if fRange = rsAnsiCAsm then\r\n                  fRange := rsAsm\r\n                else\r\n                  begin\r\n                  if fRange = rsAnsiCAsmBlock then\r\n                    fRange := rsAsmBlock\r\n                  else\r\n                    fRange := rsUnKnown;\r\n                  end;\r\n                break;\r\n              end else inc(Run);\r\n            #10, #13:\r\n              begin\r\n                if fRange = rsDirectiveComment then\r\n                  fRange := rsAnsiC;\r\n                break;\r\n              end;\r\n          else inc(Run);\r\n          end;\r\n      end;\r\n    '=':                               {divide assign}\r\n      begin\r\n        inc(Run, 2);\r\n        fTokenID := tkSymbol;\r\n        FExtTokenID := xtkDivideAssign;\r\n      end;\r\n  else                                 {divide}\r\n    begin\r\n      inc(Run);\r\n      fTokenID := tkSymbol;\r\n      FExtTokenID := xtkDivide;\r\n    end;\r\n  end;\r\nend;\r\n\r\nprocedure TSynCppSyn.SpaceProc;\r\nbegin\r\n  inc(Run);\r\n  fTokenID := tkSpace;\r\n  while (FLine[Run] <= #32) and not IsLineEnd(Run) do inc(Run);\r\nend;\r\n\r\nprocedure TSynCppSyn.SquareCloseProc;\r\nbegin\r\n  inc(Run);\r\n  fTokenID := tkSymbol;\r\n  FExtTokenID := xtkSquareClose;\r\nend;\r\n\r\nprocedure TSynCppSyn.SquareOpenProc;\r\nbegin\r\n  inc(Run);\r\n  fTokenID := tkSymbol;\r\n  FExtTokenID := xtkSquareOpen;\r\nend;\r\n\r\nprocedure TSynCppSyn.StarProc;\r\nbegin\r\n  fTokenID := tkSymbol;\r\n  case FLine[Run + 1] of\r\n    '=':                               {multiply assign}\r\n      begin\r\n        inc(Run, 2);\r\n        FExtTokenID := xtkMultiplyAssign;\r\n      end;\r\n  else                                 {star}\r\n    begin\r\n      inc(Run);\r\n      FExtTokenID := xtkStar;\r\n    end;\r\n  end;\r\nend;\r\n\r\nprocedure TSynCppSyn.StringProc;\r\nbegin\r\n  fTokenID := tkString;\r\n  repeat\r\n    if fLine[Run] = '\\' then begin\r\n      case fLine[Run + 1] of\r\n        #34, '\\':\r\n          Inc(Run);\r\n        #00:\r\n          begin\r\n            Inc(Run);\r\n            fRange := rsMultilineString;\r\n            Exit;\r\n          end;\r\n      end;\r\n    end;\r\n    inc(Run);\r\n  until IsLineEnd(Run) or (fLine[Run] = #34);\r\n  if FLine[Run] = #34 then\r\n    inc(Run);\r\nend;\r\n\r\nprocedure TSynCppSyn.StringEndProc;\r\nbegin\r\n  fTokenID := tkString;\r\n\r\n  case FLine[Run] of\r\n    #0:\r\n      begin\r\n        NullProc;\r\n        Exit;\r\n      end;\r\n    #10:\r\n      begin\r\n        LFProc;\r\n        Exit;\r\n      end;\r\n    #13:\r\n      begin\r\n        CRProc;\r\n        Exit;\r\n      end;\r\n  end;\r\n\r\n  fRange := rsUnknown;\r\n\r\n  repeat\r\n    case FLine[Run] of\r\n      #0, #10, #13: Break;\r\n      '\\':\r\n        begin\r\n          case fLine[Run + 1] of\r\n            #34, '\\':\r\n              Inc(Run);\r\n            #00:\r\n              begin\r\n                Inc(Run);\r\n                fRange := rsMultilineString;\r\n                Exit;\r\n              end;\r\n          end;\r\n        end;\r\n      #34: Break;\r\n    end;\r\n    inc(Run);\r\n  until IsLineEnd(Run) or (fLine[Run] = #34);\r\n  if FLine[Run] = #34 then\r\n    inc(Run);\r\nend;\r\n\r\nprocedure TSynCppSyn.TildeProc;\r\nbegin\r\n  inc(Run);                            {bitwise complement}\r\n  fTokenId := tkSymbol;\r\n  FExtTokenID := xtkBitComplement;\r\nend;\r\n\r\nprocedure TSynCppSyn.XOrSymbolProc;\r\nbegin\r\n  fTokenID := tkSymbol;\r\n  case FLine[Run + 1] of\r\n  \t'=':                               {xor assign}\r\n      begin\r\n        inc(Run, 2);\r\n        FExtTokenID := xtkXorAssign;\r\n      end;\r\n  else                                 {xor}\r\n    begin\r\n      inc(Run);\r\n      FExtTokenID := xtkXor;\r\n    end;\r\n  end;\r\nend;\r\n\r\nprocedure TSynCppSyn.UnknownProc;\r\nbegin\r\n  Inc(Run);\r\n  fTokenID := tkUnknown;\r\nend;\r\n\r\nprocedure TSynCppSyn.Next;\r\nbegin\r\n  fAsmStart := False;\r\n  fTokenPos := Run;\r\n  case fRange of\r\n    rsAnsiC, rsAnsiCAsm,\r\n    rsAnsiCAsmBlock, rsDirectiveComment: AnsiCProc;\r\n    rsMultiLineDirective: DirectiveEndProc;\r\n    rsMultilineString: StringEndProc;\r\n  else\r\n    begin\r\n      case fLine[Run] of\r\n        '&': AndSymbolProc;\r\n        #39: AsciiCharProc;\r\n        '@': AtSymbolProc;\r\n        '}': BraceCloseProc;\r\n        '{': BraceOpenProc;\r\n        #13: CRProc;\r\n        ':': ColonProc;\r\n        ',': CommaProc;\r\n        '#': DirectiveProc;\r\n        '=': EqualProc;\r\n        '>': GreaterProc;\r\n        '?': QuestionProc;\r\n        'A'..'Z', 'a'..'z', '_': IdentProc;\r\n        #10: LFProc;\r\n        '<': LowerProc;\r\n        '-': MinusProc;\r\n        '%': ModSymbolProc;\r\n        '!': NotSymbolProc;\r\n        #0: NullProc;\r\n        '0'..'9': NumberProc;\r\n        '|': OrSymbolProc;\r\n        '+': PlusProc;\r\n        '.': PointProc;\r\n        ')': RoundCloseProc;\r\n        '(': RoundOpenProc;\r\n        ';': SemiColonProc;\r\n        '/': SlashProc;\r\n        #1..#9, #11, #12, #14..#32: SpaceProc;\r\n        ']': SquareCloseProc;\r\n        '[': SquareOpenProc;\r\n        '*': StarProc;\r\n        #34: StringProc;\r\n        '~': TildeProc;\r\n        '^': XOrSymbolProc;\r\n        else UnknownProc;\r\n      end;\r\n    end;\r\n  end;\r\n  inherited;\r\nend;\r\n\r\nfunction TSynCppSyn.GetDefaultAttribute(Index: integer): TSynHighlighterAttributes;\r\nbegin\r\n  case Index of\r\n    SYN_ATTR_COMMENT: Result := fCommentAttri;\r\n    SYN_ATTR_IDENTIFIER: Result := fIdentifierAttri;\r\n    SYN_ATTR_KEYWORD: Result := fKeyAttri;\r\n    SYN_ATTR_STRING: Result := fStringAttri;\r\n    SYN_ATTR_WHITESPACE: Result := fSpaceAttri;\r\n    SYN_ATTR_SYMBOL: Result := fSymbolAttri;\r\n  else\r\n    Result := nil;\r\n  end;\r\nend;\r\n\r\nfunction TSynCppSyn.GetEol: Boolean;\r\nbegin\r\n  Result := Run = fLineLen + 1;\r\nend;\r\n\r\nfunction TSynCppSyn.GetRange: Pointer;\r\nbegin\r\n  Result := Pointer(fRange);\r\nend;\r\n\r\nfunction TSynCppSyn.GetTokenID: TtkTokenKind;\r\nbegin\r\n  Result := fTokenId;\r\n  if ((fRange = rsAsm) or (fRange = rsAsmBlock)) and not fAsmStart\r\n    and not (fTokenId in [tkComment, tkSpace, tkNull])\r\n  then\r\n    Result := tkAsm;\r\nend;\r\n\r\nfunction TSynCppSyn.GetExtTokenID: TxtkTokenKind;\r\nbegin\r\n  Result := FExtTokenID;\r\nend;\r\n\r\nfunction TSynCppSyn.GetTokenAttribute: TSynHighlighterAttributes;\r\nbegin\r\n  fTokenID := GetTokenID;\r\n  case fTokenID of\r\n    tkAsm: Result := fAsmAttri;\r\n    tkComment: Result := fCommentAttri;\r\n    tkDirective: Result := fDirecAttri;\r\n    tkIdentifier: Result := fIdentifierAttri;\r\n    tkKey: Result := fKeyAttri;\r\n    tkNumber: Result := fNumberAttri;\r\n    tkFloat: Result := fFloatAttri;\r\n    tkHex: Result := fHexAttri;\r\n    tkOctal: Result := fOctalAttri;\r\n    tkSpace: Result := fSpaceAttri;\r\n    tkString: Result := fStringAttri;\r\n    tkChar: Result := fCharAttri;\r\n    tkSymbol: Result := fSymbolAttri;\r\n    tkUnknown: Result := fInvalidAttri;\r\n    else Result := nil;\r\n  end;\r\nend;\r\n\r\nfunction TSynCppSyn.GetTokenKind: integer;\r\nbegin\r\n  Result := Ord(GetTokenID);\r\nend;\r\n\r\nprocedure TSynCppSyn.ResetRange;\r\nbegin\r\n  fRange:= rsUnknown;\r\nend;\r\n\r\nprocedure TSynCppSyn.SetRange(Value: Pointer);\r\nbegin\r\n  fRange := TRangeState(Value);\r\nend;\r\n\r\nprocedure TSynCppSyn.EnumUserSettings(settings: TStrings);\r\nbegin\r\n  { returns the user settings that exist in the registry }\r\n{$IFNDEF SYN_CLX}\r\n  with TBetterRegistry.Create do\r\n  begin\r\n    try\r\n      RootKey := HKEY_LOCAL_MACHINE;\r\n      if OpenKeyReadOnly('\\SOFTWARE\\Borland\\C++Builder') then\r\n      begin\r\n        try\r\n          GetKeyNames(settings);\r\n        finally\r\n          CloseKey;\r\n        end;\r\n      end;\r\n    finally\r\n      Free;\r\n    end;\r\n  end;\r\n{$ENDIF}\r\nend;\r\n\r\nfunction TSynCppSyn.UseUserSettings(settingIndex: integer): boolean;\r\n// Possible parameter values:\r\n//   index into TStrings returned by EnumUserSettings\r\n// Possible return values:\r\n//   true : settings were read and used\r\n//   false: problem reading settings or invalid version specified - old settings\r\n//          were preserved\r\n\r\n  {$IFNDEF SYN_CLX}\r\n  function ReadCPPBSettings(settingIndex: integer): boolean;\r\n\r\n    function ReadCPPBSetting(settingTag: string; attri: TSynHighlighterAttributes; key: string): boolean;\r\n\r\n      function ReadCPPB1(settingTag: string; attri: TSynHighlighterAttributes; name: string): boolean;\r\n      var\r\n        i: integer;\r\n      begin\r\n        for i := 1 to Length(name) do\r\n          if name[i] = ' ' then name[i] := '_';\r\n        Result := attri.LoadFromBorlandRegistry(HKEY_CURRENT_USER,\r\n             '\\SOFTWARE\\Borland\\C++Builder\\'+settingTag+'\\Highlight',name,true);\r\n      end; { ReadCPPB1 }\r\n\r\n      function ReadCPPB3OrMore(settingTag: string; attri: TSynHighlighterAttributes; key: string): boolean;\r\n      begin\r\n        Result := attri.LoadFromBorlandRegistry(HKEY_CURRENT_USER,\r\n                 '\\Software\\Borland\\C++Builder\\'+settingTag+'\\Editor\\Highlight',\r\n                 key,false);\r\n      end; { ReadCPPB3OrMore }\r\n\r\n    begin { ReadCPPBSetting }\r\n      try\r\n        if (settingTag[1] = '1')\r\n          then Result := ReadCPPB1(settingTag,attri,key)\r\n          else Result := ReadCPPB3OrMore(settingTag,attri,key);\r\n      except Result := false; end;\r\n    end; { ReadCPPBSetting }\r\n\r\n  var\r\n    tmpStringAttri    : TSynHighlighterAttributes;\r\n    tmpCharAttri      : TSynHighlighterAttributes;\r\n    tmpNumberAttri    : TSynHighlighterAttributes;\r\n    tmpFloatAttri     : TSynHighlighterAttributes;\r\n    tmpHexAttri       : TSynHighlighterAttributes;\r\n    tmpOctalAttri     : TSynHighlighterAttributes;\r\n    tmpKeyAttri       : TSynHighlighterAttributes;\r\n    tmpSymbolAttri    : TSynHighlighterAttributes;\r\n    tmpAsmAttri       : TSynHighlighterAttributes;\r\n    tmpCommentAttri   : TSynHighlighterAttributes;\r\n    tmpIdentifierAttri: TSynHighlighterAttributes;\r\n    tmpInvalidAttri   : TSynHighlighterAttributes;\r\n    tmpSpaceAttri     : TSynHighlighterAttributes;\r\n    tmpDirecAttri     : TSynHighlighterAttributes;\r\n    s                 : TStringList;\r\n\r\n  begin { ReadCPPBSettings }\r\n    s := TStringList.Create;\r\n    try\r\n      EnumUserSettings(s);\r\n      if settingIndex >= s.Count then Result := false\r\n      else begin\r\n        tmpStringAttri    := TSynHighlighterAttributes.Create('', '');\r\n        tmpCharAttri      := TSynHighlighterAttributes.Create('', '');\r\n        tmpNumberAttri    := TSynHighlighterAttributes.Create('', '');\r\n        tmpFloatAttri     := TSynHighlighterAttributes.Create('', '');\r\n        tmpHexAttri       := TSynHighlighterAttributes.Create('', '');\r\n        tmpOctalAttri     := TSynHighlighterAttributes.Create('', '');\r\n        tmpKeyAttri       := TSynHighlighterAttributes.Create('', '');\r\n        tmpSymbolAttri    := TSynHighlighterAttributes.Create('', '');\r\n        tmpAsmAttri       := TSynHighlighterAttributes.Create('', '');\r\n        tmpCommentAttri   := TSynHighlighterAttributes.Create('', '');\r\n        tmpIdentifierAttri:= TSynHighlighterAttributes.Create('', '');\r\n        tmpInvalidAttri   := TSynHighlighterAttributes.Create('', '');\r\n        tmpSpaceAttri     := TSynHighlighterAttributes.Create('', '');\r\n        tmpDirecAttri     := TSynHighlighterAttributes.Create('', '');\r\n        tmpStringAttri    .Assign(fStringAttri);\r\n        tmpCharAttri      .Assign(fCharAttri);\r\n        tmpNumberAttri    .Assign(fNumberAttri);\r\n        tmpFloatAttri     .Assign(fFloatAttri);\r\n        tmpHexAttri       .Assign(fHexAttri);\r\n        tmpOctalAttri     .Assign(fOctalAttri);\r\n        tmpKeyAttri       .Assign(fKeyAttri);\r\n        tmpSymbolAttri    .Assign(fSymbolAttri);\r\n        tmpAsmAttri       .Assign(fAsmAttri);\r\n        tmpCommentAttri   .Assign(fCommentAttri);\r\n        tmpIdentifierAttri.Assign(fIdentifierAttri);\r\n        tmpInvalidAttri   .Assign(fInvalidAttri);\r\n        tmpSpaceAttri     .Assign(fSpaceAttri);\r\n        tmpDirecAttri     .Assign(fDirecAttri);\r\n        if s[settingIndex][1] = '1'\r\n          then Result := ReadCPPBSetting(s[settingIndex],fAsmAttri,'Plain text')\r\n          else Result := ReadCPPBSetting(s[settingIndex],fAsmAttri,'Assembler');\r\n        Result := Result                                                         and\r\n                  ReadCPPBSetting(s[settingIndex],fCommentAttri,'Comment')       and\r\n                  ReadCPPBSetting(s[settingIndex],fIdentifierAttri,'Identifier') and\r\n                  ReadCPPBSetting(s[settingIndex],fInvalidAttri,'Illegal Char')  and\r\n                  ReadCPPBSetting(s[settingIndex],fKeyAttri,'Reserved word')     and\r\n                  ReadCPPBSetting(s[settingIndex],fNumberAttri,'Integer')        and\r\n                  ReadCPPBSetting(s[settingIndex],fFloatAttri,'Float')           and\r\n                  ReadCPPBSetting(s[settingIndex],fHexAttri,'Hex')               and\r\n                  ReadCPPBSetting(s[settingIndex],fOctalAttri,'Octal')           and\r\n                  ReadCPPBSetting(s[settingIndex],fSpaceAttri,'Whitespace')      and\r\n                  ReadCPPBSetting(s[settingIndex],fStringAttri,'String')         and\r\n                  ReadCPPBSetting(s[settingIndex],fCharAttri,'Character')             and\r\n                  ReadCPPBSetting(s[settingIndex],fSymbolAttri,'Symbol')         and\r\n                  ReadCPPBSetting(s[settingIndex],fDirecAttri,'Preprocessor');\r\n        if not Result then begin\r\n          fStringAttri    .Assign(tmpStringAttri);\r\n          fCharAttri      .Assign(tmpCharAttri);\r\n          fNumberAttri    .Assign(tmpNumberAttri);\r\n          fFloatAttri     .Assign(tmpFloatAttri);\r\n          fHexAttri       .Assign(tmpHexAttri);\r\n          fOctalAttri     .Assign(tmpOctalAttri);\r\n          fKeyAttri       .Assign(tmpKeyAttri);\r\n          fSymbolAttri    .Assign(tmpSymbolAttri);\r\n          fAsmAttri       .Assign(tmpAsmAttri);\r\n          fCommentAttri   .Assign(tmpCommentAttri);\r\n          fIdentifierAttri.Assign(tmpIdentifierAttri);\r\n          fInvalidAttri   .Assign(tmpInvalidAttri);\r\n          fSpaceAttri     .Assign(tmpSpaceAttri);\r\n          fDirecAttri     .Assign(tmpDirecAttri);\r\n        end;\r\n        tmpStringAttri    .Free;\r\n        tmpCharAttri      .Free;\r\n        tmpNumberAttri    .Free;\r\n        tmpFloatAttri     .Free;\r\n        tmpHexAttri       .Free;\r\n        tmpOctalAttri     .Free;\r\n        tmpKeyAttri       .Free;\r\n        tmpSymbolAttri    .Free;\r\n        tmpAsmAttri       .Free;\r\n        tmpCommentAttri   .Free;\r\n        tmpIdentifierAttri.Free;\r\n        tmpInvalidAttri   .Free;\r\n        tmpSpaceAttri     .Free;\r\n        tmpDirecAttri     .Free;\r\n      end;\r\n    finally s.Free; end;\r\n  end; { ReadCPPBSettings }\r\n  {$ENDIF}\r\n\r\nbegin\r\n  {$IFNDEF SYN_CLX}\r\n  Result := ReadCPPBSettings(settingIndex);\r\n  {$ELSE}\r\n  Result := False;\r\n  {$ENDIF}\r\nend; { TSynCppSyn.UseUserSettings }\r\n\r\nfunction TSynCppSyn.IsFilterStored: Boolean;\r\nbegin\r\n  Result := fDefaultFilter <> SYNS_FilterCPP;\r\nend;\r\n\r\nclass function TSynCppSyn.GetLanguageName: string;\r\nbegin\r\n  Result := SYNS_LangCPP;\r\nend;\r\n\r\nclass function TSynCppSyn.GetCapabilities: TSynHighlighterCapabilities;\r\nbegin\r\n  Result := inherited GetCapabilities + [hcUserSettings];\r\nend;\r\n\r\nfunction TSynCppSyn.GetSampleSource: UnicodeString;\r\nbegin\r\n  Result := '// Syntax Highlighting'#13#10+\r\n            'void __fastcall TForm1::Button1Click(TObject *Sender)'#13#10+\r\n            '{'#13#10+\r\n            '  int number = 123456;'#13#10+\r\n            '  char c = ''a'';'#13#10+\r\n            '  Caption = \"The number is \" + IntToStr(i);'#13#10+\r\n            '  for (int i = 0; i <= number; i++)'#13#10+\r\n            '  {'#13#10+\r\n            '    x -= 0xff;'#13#10+\r\n            '    x -= 023;'#13#10+\r\n            '    x += 1.0;'#13#10+\r\n            '    x += @; /* illegal character */'#13#10+\r\n            '  }'#13#10+\r\n            '  #ifdef USE_ASM'#13#10+\r\n            '    asm'#13#10+\r\n            '    {'#13#10+\r\n            '      ASM MOV AX, 0x1234'#13#10+\r\n            '      ASM MOV i, AX'#13#10+\r\n            '    }'#13#10+\r\n            '  #endif'#13#10+\r\n            '}';\r\n\r\nend;\r\n\r\nclass function TSynCppSyn.GetFriendlyLanguageName: UnicodeString;\r\nbegin\r\n  Result := SYNS_FriendlyLangCPP;\r\nend;\r\n\r\ninitialization\r\n{$IFNDEF SYN_CPPB_1}\r\n  RegisterPlaceableHighlighter(TSynCppSyn);\r\n{$ENDIF}\r\nend.\r\n"
  },
  {
    "path": "External/SynEdit/Source/SynHighlighterCss.pas",
    "content": "{-------------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: SynHighlighterEnhCSS.pas, released 2001-10-28\r\nInitial modifications to this CSS Highlighter were made by Ashley Brown,\r\nashley@ashleybrown.co.uk.\r\n\r\nThe Original Code is based on the SynHighlighterHTML.pas, released 2000-04-10 - \r\nthis in turn was based on the hkHTMLSyn.pas file from the mwEdit component suite\r\nby Martin Waldenburg and other developers, the Initial Author of this file is\r\nHideo Koiso.\r\nUnicode translation by Mal Hrz.\r\nAll Rights Reserved.\r\n\r\nContributors to the SynEdit and mwEdit projects are listed in the\r\nContributors.txt file.\r\n\r\nAlternatively, the contents of this file may be used under the terms of the\r\nGNU General Public License Version 2 or later (the \"GPL\"), in which case\r\nthe provisions of the GPL are applicable instead of those above.\r\nIf you wish to allow use of your version of this file only under the terms\r\nof the GPL and not to allow others to use your version of this file\r\nunder the MPL, indicate your decision by deleting the provisions above and\r\nreplace them with the notice and other provisions required by the GPL.\r\nIf you do not delete the provisions above, a recipient may use your version\r\nof this file under either the MPL or the GPL.\r\n\r\nYou may retrieve the latest version of SynEdit from the SynEdit home page,\r\nlocated at http://SynEdit.SourceForge.net\r\n\r\nYou may retrieve the latest version of this file from\r\nhttp://www.ashleybrown.co.uk/synedit/\r\n\r\nKnown Issues:\r\n-------------------------------------------------------------------------------}\r\n{\r\n@abstract(Provides an improved CSS highlighter for SynEdit)\r\n@author(Ashley Brown, based on HTML highlighter by Hideo Koiso and converted to SynEdit by Michael Hieke)\r\n@created(2001-10-28)\r\n@lastmod(2003-05-11)\r\nThe SynHighlighterEnhCSS unit provides SynEdit with an improved CSS highlighter.\r\n\r\nhttp://www.ashleybrown.co.uk/\r\nashley@ashleybrown.co.uk\r\n}\r\n\r\n{$IFNDEF QSYNHIGHLIGHTERCSS}\r\nunit SynHighlighterCSS;\r\n{$ENDIF}\r\n\r\n{$I SynEdit.inc}\r\n\r\ninterface\r\n\r\nuses\r\n{$IFDEF SYN_CLX}\r\n  QGraphics,\r\n  QSynEditTypes,\r\n  QSynEditHighlighter,\r\n  QSynHighlighterHashEntries,\r\n  QSynUnicode,\r\n{$ELSE}\r\n  Graphics,\r\n  SynEditTypes,\r\n  SynEditHighlighter,\r\n  SynHighlighterHashEntries,\r\n  SynUnicode,\r\n{$ENDIF}\r\n  SysUtils,\r\n  Classes;\r\n\r\ntype\r\n  TtkTokenKind = (tkComment, tkProperty, tkKey, tkNull, tkSpace, tkString,\r\n    tkSymbol, tkText, tkUndefProperty, tkValue, tkColor, tkNumber, tkImportant);\r\n\r\n  TRangeState = (rsComment, rsKey, rsParam, rsText, rsUnKnown, rsValue);\r\n\r\n  TSynCssSyn = class(TSynCustomHighlighter)\r\n  private\r\n    fRange: TRangeState;\r\n    fCommentRange: TRangeState;\r\n    fTokenID: TtkTokenKind;\r\n    fCommentAttri: TSynHighlighterAttributes;\r\n    fPropertyAttri: TSynHighlighterAttributes;\r\n    fKeyAttri: TSynHighlighterAttributes;\r\n    fSpaceAttri: TSynHighlighterAttributes;\r\n    fStringAttri: TSynHighlighterAttributes;\r\n    fColorAttri: TSynHighlighterAttributes;\r\n    fNumberAttri: TSynHighlighterAttributes;\r\n    fSymbolAttri: TSynHighlighterAttributes;\r\n    fTextAttri: TSynHighlighterAttributes;\r\n    fValueAttri: TSynHighlighterAttributes;\r\n    fUndefPropertyAttri: TSynHighlighterAttributes;\r\n    fImportantPropertyAttri: TSynHighlighterAttributes;\r\n    fKeywords: TSynHashEntryList;\r\n    procedure DoAddKeyword(AKeyword: UnicodeString; AKind: integer);\r\n    function HashKey(Str: PWideChar): Integer;\r\n    function IdentKind(MayBe: PWideChar): TtkTokenKind;\r\n    procedure TextProc;\r\n    procedure CommentProc;\r\n    procedure BraceCloseProc;\r\n    procedure BraceOpenProc;\r\n    procedure CRProc;\r\n    procedure SemiProc;\r\n    procedure StartValProc;\r\n    procedure NumberProc;\r\n    procedure IdentProc;\r\n    procedure LFProc;\r\n    procedure NullProc;\r\n    procedure SpaceProc;\r\n    procedure StringProc;\r\n    procedure HashProc;\r\n    procedure SlashProc;\r\n    procedure ExclamProc;\r\n  protected\r\n    function GetSampleSource: UnicodeString; override;\r\n    function IsFilterStored: Boolean; override;\r\n    procedure NextProcedure;\r\n  public\r\n    class function GetLanguageName: string; override;\r\n    class function GetFriendlyLanguageName: UnicodeString; override;\r\n  public\r\n    constructor Create(AOwner: TComponent); override;\r\n    destructor Destroy; override;\r\n    function GetDefaultAttribute(Index: integer): TSynHighlighterAttributes; override;\r\n    function GetEol: Boolean; override;\r\n    function GetRange: Pointer; override;\r\n    function GetTokenID: TtkTokenKind;\r\n    function GetTokenAttribute: TSynHighlighterAttributes; override;\r\n    function GetTokenKind: Integer; override;\r\n    function IsIdentChar(AChar: WideChar): Boolean; override;\r\n    procedure Next; override;\r\n    procedure SetRange(Value: Pointer); override;\r\n    procedure ResetRange; override;\r\n  published\r\n    property CommentAttri: TSynHighlighterAttributes read fCommentAttri\r\n      write fCommentAttri;\r\n    property PropertyAttri: TSynHighlighterAttributes read fPropertyAttri\r\n      write fPropertyAttri;\r\n    property ColorAttri: TSynHighlighterAttributes read fColorAttri\r\n      write fColorAttri;\r\n    property NumberAttri: TSynHighlighterAttributes read fNumberAttri\r\n      write fNumberAttri;\r\n    property KeyAttri: TSynHighlighterAttributes read fKeyAttri write fKeyAttri;\r\n    property SpaceAttri: TSynHighlighterAttributes read fSpaceAttri\r\n      write fSpaceAttri;\r\n    property StringAttri: TSynHighlighterAttributes read fStringAttri\r\n      write fStringAttri;\r\n    property SymbolAttri: TSynHighlighterAttributes read fSymbolAttri\r\n      write fSymbolAttri;\r\n    property TextAttri: TSynHighlighterAttributes read fTextAttri\r\n      write fTextAttri;\r\n    property ValueAttri: TSynHighlighterAttributes read fValueAttri\r\n      write fValueAttri;\r\n    property UndefPropertyAttri: TSynHighlighterAttributes read fUndefPropertyAttri\r\n      write fUndefPropertyAttri;\r\n    property ImportantPropertyAttri: TSynHighlighterAttributes read fImportantPropertyAttri\r\n      write fImportantPropertyAttri;\r\n  end;\r\n\r\nimplementation\r\n\r\nuses\r\n{$IFDEF SYN_CLX}\r\n  QSynEditStrConst;\r\n{$ELSE}\r\n  SynEditStrConst;\r\n{$ENDIF}\r\n\r\nconst\r\n   Properties_CSS1 : UnicodeString =\r\n                      'background'\r\n                     +',background-attachment'\r\n                     +',background-color'\r\n                     +',background-image'\r\n                     +',background-position'\r\n                     +',background-repeat'\r\n                     +',border'\r\n                     +',border-bottom'\r\n                     +',border-bottom-color'\r\n                     +',border-bottom-style'\r\n                     +',border-bottom-width'\r\n                     +',border-color'\r\n                     +',border-left'\r\n                     +',border-left-color'\r\n                     +',border-left-style'\r\n                     +',border-left-width'\r\n                     +',border-right'\r\n                     +',border-right-color'\r\n                     +',border-right-style'\r\n                     +',border-right-width'\r\n                     +',border-style'\r\n                     +',border-top'\r\n                     +',border-top-color'\r\n                     +',border-top-style'\r\n                     +',border-top-width'\r\n                     +',border-width'\r\n                     +',clear'\r\n                     +',color'\r\n                     +',display'\r\n                     +',float'\r\n                     +',font'\r\n                     +',font-family'\r\n                     +',font-size'\r\n                     +',font-style'\r\n                     +',font-variant'\r\n                     +',font-weight'\r\n                     +',height'\r\n                     +',letter-spacing'\r\n                     +',line-height'\r\n                     +',list-style'\r\n                     +',list-style-image'\r\n                     +',list-style-position'\r\n                     +',list-style-type'\r\n                     +',margin'\r\n                     +',margin-bottom'\r\n                     +',margin-left'\r\n                     +',margin-right'\r\n                     +',margin-top'\r\n                     +',padding'\r\n                     +',padding-bottom'\r\n                     +',padding-left'\r\n                     +',padding-right'\r\n                     +',padding-top'\r\n                     +',text-align'\r\n                     +',text-decoration'\r\n                     +',text-indent'\r\n                     +',text-transform'\r\n                     +',vertical-align'\r\n                     +',white-space'\r\n                     +',width'\r\n                     +',word-spacing';\r\n   Properties_CSS2 : UnicodeString =\r\n                      'border-collapse'\r\n                     +',border-spacing'\r\n                     +',bottom'\r\n                     +',caption-side'\r\n                     +',clip'\r\n                     +',content'\r\n                     +',counter-increment'\r\n                     +',counter-reset'\r\n                     +',cursor'\r\n                     +',direction'\r\n                     +',empty-cells'\r\n                     +',left'\r\n                     +',max-height'\r\n                     +',max-width'\r\n                     +',min-height'\r\n                     +',min-width'\r\n                     +',orphans'\r\n                     +',outline'\r\n                     +',outline-color'\r\n                     +',outline-style'\r\n                     +',outline-width'\r\n                     +',overflow'\r\n                     +',page-break-after'\r\n                     +',page-break-before'\r\n                     +',page-break-inside'\r\n                     +',position'\r\n                     +',quotes'\r\n                     +',right'\r\n                     +',table-layout'\r\n                     +',top'\r\n                     +',unicode-bidi'\r\n                     +',visibility'\r\n                     +',widows'\r\n                     +',z-index';\r\n   Properties_CSS2_Aural : UnicodeString =\r\n                      'azimuth'\r\n                     +',cue'\r\n                     +',cue-after'\r\n                     +',cue-before'\r\n                     +',elevation'\r\n                     +',pause'\r\n                     +',pause-after'\r\n                     +',pause-before'\r\n                     +',pitch'\r\n                     +',pitch-range'\r\n                     +',play-during'\r\n                     +',richness'\r\n                     +',speak'\r\n                     +',speak-header'\r\n                     +',speak-numeral'\r\n                     +',speak-punctuation'\r\n                     +',speech-rate'\r\n                     +',stress'\r\n                     +',voice-family'\r\n                     +',volume';\r\n   Properties_CSS3 : UnicodeString =\r\n                      '@font-face'\r\n                     +',@keyframes'\r\n                     +',alignment-adjust'\r\n                     +',alignment-baseline'\r\n                     +',animation'\r\n                     +',animation-delay'\r\n                     +',animation-direction'\r\n                     +',animation-duration'\r\n                     +',animation-iteration-count'\r\n                     +',animation-name'\r\n                     +',animation-play-state'\r\n                     +',animation-timing-function'\r\n                     +',appearance'\r\n                     +',backface-visibility'\r\n                     +',background-clip'\r\n                     +',background-origin'\r\n                     +',background-size'\r\n                     +',baseline-shift'\r\n                     +',bookmark-label'\r\n                     +',bookmark-level'\r\n                     +',bookmark-target'\r\n                     +',border-bottom-left-radius'\r\n                     +',border-bottom-right-radius'\r\n                     +',border-image'\r\n                     +',border-image-outset'\r\n                     +',border-image-repeat'\r\n                     +',border-image-slice'\r\n                     +',border-image-source'\r\n                     +',border-image-width'\r\n                     +',border-radius'\r\n                     +',border-top-left-radius'\r\n                     +',border-top-right-radius'\r\n                     +',box-align'\r\n                     +',box-decoration-break'\r\n                     +',box-direction'\r\n                     +',box-flex'\r\n                     +',box-flex-group'\r\n                     +',box-lines'\r\n                     +',box-ordinal-group'\r\n                     +',box-orient'\r\n                     +',box-pack'\r\n                     +',box-shadow'\r\n                     +',box-sizing'\r\n                     +',color-profile'\r\n                     +',column-count'\r\n                     +',column-fill'\r\n                     +',column-gap'\r\n                     +',column-rule'\r\n                     +',column-rule-color'\r\n                     +',column-rule-style'\r\n                     +',column-rule-width'\r\n                     +',columns'\r\n                     +',column-span'\r\n                     +',column-width'\r\n                     +',crop'\r\n                     +',dominant-baseline'\r\n                     +',drop-initial-after-adjust'\r\n                     +',drop-initial-after-align'\r\n                     +',drop-initial-before-adjust'\r\n                     +',drop-initial-before-align'\r\n                     +',drop-initial-size'\r\n                     +',drop-initial-value'\r\n                     +',fit'\r\n                     +',fit-position'\r\n                     +',float-offset'\r\n                     +',font-size-adjust'\r\n                     +',font-stretch'\r\n                     +',grid-columns'\r\n                     +',grid-rows'\r\n                     +',hanging-punctuation'\r\n                     +',hyphenate-after'\r\n                     +',hyphenate-before'\r\n                     +',hyphenate-character'\r\n                     +',hyphenate-lines'\r\n                     +',hyphenate-resource'\r\n                     +',hyphens'\r\n                     +',icon'\r\n                     +',image-orientation'\r\n                     +',image-resolution'\r\n                     +',inline-box-align'\r\n                     +',line-stacking'\r\n                     +',line-stacking-ruby'\r\n                     +',line-stacking-shift'\r\n                     +',line-stacking-strategy'\r\n                     +',mark'\r\n                     +',mark-after'\r\n                     +',mark-before'\r\n                     +',marks'\r\n                     +',marquee-direction'\r\n                     +',marquee-play-count'\r\n                     +',marquee-speed'\r\n                     +',marquee-style'\r\n                     +',move-to'\r\n                     +',nav-down'\r\n                     +',nav-index'\r\n                     +',nav-left'\r\n                     +',nav-right'\r\n                     +',nav-up'\r\n                     +',opacity'\r\n                     +',outline-offset'\r\n                     +',overflow-style'\r\n                     +',overflow-x'\r\n                     +',overflow-y'\r\n                     +',page'\r\n                     +',page-policy'\r\n                     +',perspective'\r\n                     +',perspective-origin'\r\n                     +',phonemes'\r\n                     +',punctuation-trim'\r\n                     +',rendering-intent'\r\n                     +',resize'\r\n                     +',rest'\r\n                     +',rest-after'\r\n                     +',rest-before'\r\n                     +',rotation'\r\n                     +',rotation-point'\r\n                     +',ruby-align'\r\n                     +',ruby-overhang'\r\n                     +',ruby-position'\r\n                     +',ruby-span'\r\n                     +',size'\r\n                     +',string-set'\r\n                     +',target'\r\n                     +',target-name'\r\n                     +',target-new'\r\n                     +',target-position'\r\n                     +',text-align-last'\r\n                     +',text-height'\r\n                     +',text-justify'\r\n                     +',text-outline'\r\n                     +',text-overflow'\r\n                     +',text-shadow'\r\n                     +',text-wrap'\r\n                     +',transform'\r\n                     +',transform-origin'\r\n                     +',transform-style'\r\n                     +',transition'\r\n                     +',transition-delay'\r\n                     +',transition-duration'\r\n                     +',transition-property'\r\n                     +',transition-timing-function'\r\n                     +',voice-balance'\r\n                     +',voice-duration'\r\n                     +',voice-pitch'\r\n                     +',voice-pitch-range'\r\n                     +',voice-rate'\r\n                     +',voice-stress'\r\n                     +',voice-volume'\r\n                     +',word-break'\r\n                     +',word-wrap';\r\n\r\n\r\n{ TSynCssSyn }\r\n\r\n{$Q-}\r\nfunction TSynCssSyn.HashKey(Str: PWideChar): Integer;\r\nbegin\r\n  Result := 0;\r\n  while CharInSet(Str^, ['a'..'z', 'A'..'Z', '_', '-']) do\r\n  begin\r\n    if Str^ <> '-' then\r\n    case Str^ of\r\n      '_': Inc(Result, 27);\r\n      '-': Inc(Result, 28);\r\n      else Inc(Result, Ord(SynWideUpperCase(Str^)[1]) - 64);\r\n    end;\r\n    Inc(Str);\r\n  end;\r\n  while CharInSet(Str^, ['0'..'9']) do\r\n  begin\r\n    Inc(Result, Ord(Str^) - Ord('0'));\r\n    Inc(Str);\r\n  end;\r\n  fStringLen := Str - fToIdent;\r\nend;\r\n{$Q+}\r\n\r\nfunction TSynCssSyn.IdentKind(MayBe: PWideChar): TtkTokenKind;\r\nvar\r\n  Entry: TSynHashEntry;\r\nbegin\r\n  fToIdent := MayBe;\r\n  Entry := fKeywords[HashKey(MayBe)];\r\n  while Assigned(Entry) do\r\n  begin\r\n    if Entry.KeywordLen > fStringLen then\r\n      break\r\n    else if Entry.KeywordLen = fStringLen then\r\n      if IsCurrentToken(Entry.Keyword) then\r\n      begin\r\n        Result := TtkTokenKind(Entry.Kind);\r\n        exit;\r\n      end;\r\n    Entry := Entry.Next;\r\n  end;\r\n  Result := tkUndefProperty;\r\nend;\r\n\r\nprocedure TSynCssSyn.DoAddKeyword(AKeyword: UnicodeString; AKind: Integer);\r\nvar\r\n  HashValue: Integer;\r\nbegin\r\n  HashValue := HashKey(PWideChar(AKeyword));\r\n  fKeywords[HashValue] := TSynHashEntry.Create(AKeyword, AKind);\r\nend;\r\n\r\nconstructor TSynCssSyn.Create(AOwner: TComponent);\r\nbegin\r\n  inherited Create(AOwner);\r\n\r\n  fCaseSensitive := False;\r\n\r\n  fKeywords := TSynHashEntryList.Create;\r\n  fCommentAttri := TSynHighlighterAttributes.Create(SYNS_AttrComment, SYNS_FriendlyAttrComment);\r\n  AddAttribute(fCommentAttri);\r\n\r\n  fPropertyAttri := TSynHighlighterAttributes.Create(SYNS_AttrProperty, SYNS_FriendlyAttrProperty);\r\n  fPropertyAttri.Style := [fsBold];\r\n  AddAttribute(fPropertyAttri);\r\n\r\n  fKeyAttri := TSynHighlighterAttributes.Create(SYNS_AttrReservedWord, SYNS_FriendlyAttrReservedWord);\r\n  fKeyAttri.Style := [fsBold];\r\n  fKeyAttri.Foreground := $00ff0080;\r\n  AddAttribute(fKeyAttri);\r\n\r\n  fUndefPropertyAttri := TSynHighlighterAttributes.Create(\r\n    SYNS_AttrUndefinedProperty, SYNS_FriendlyAttrUndefinedProperty);\r\n  fUndefPropertyAttri.Style := [fsBold];\r\n  fUndefPropertyAttri.Foreground := $00ff0080;\r\n  AddAttribute(fUndefPropertyAttri);\r\n\r\n  fImportantPropertyAttri := TSynHighlighterAttributes.Create(\r\n    'Important', 'Important Marker');\r\n  fImportantPropertyAttri.Style := [fsBold];\r\n  fImportantPropertyAttri.Foreground := clRed;\r\n  AddAttribute(fImportantPropertyAttri);\r\n\r\n  fSpaceAttri := TSynHighlighterAttributes.Create(SYNS_AttrSpace, SYNS_FriendlyAttrSpace);\r\n  AddAttribute(fSpaceAttri);\r\n\r\n  fColorAttri := TSynHighlighterAttributes.Create(SYNS_AttrColor, SYNS_FriendlyAttrColor);\r\n  AddAttribute(fColorAttri);\r\n\r\n  fNumberAttri := TSynHighlighterAttributes.Create(SYNS_AttrNumber, SYNS_FriendlyAttrNumber);\r\n  AddAttribute(fNumberAttri);\r\n\r\n  fStringAttri := TSynHighlighterAttributes.Create(SYNS_AttrString, SYNS_FriendlyAttrString);\r\n  AddAttribute(fStringAttri);\r\n\r\n  fSymbolAttri := TSynHighlighterAttributes.Create(SYNS_AttrSymbol, SYNS_FriendlyAttrSymbol);\r\n  AddAttribute(fSymbolAttri);\r\n\r\n  fTextAttri := TSynHighlighterAttributes.Create(SYNS_AttrText, SYNS_FriendlyAttrText);\r\n  AddAttribute(fTextAttri);\r\n\r\n  fValueAttri := TSynHighlighterAttributes.Create(SYNS_AttrValue, SYNS_FriendlyAttrValue);\r\n  fValueAttri.Foreground := $00ff8000;\r\n  AddAttribute(fValueAttri);\r\n\r\n  SetAttributesOnChange(DefHighlightChange);\r\n\r\n  // TODO: differentiating tkProperty for CSS1, CSS2 & CSS3 highlighting\r\n  EnumerateKeywords(Ord(tkProperty), Properties_CSS1, IsIdentChar, DoAddKeyword);\r\n  EnumerateKeywords(Ord(tkProperty), Properties_CSS2, IsIdentChar, DoAddKeyword);\r\n  EnumerateKeywords(Ord(tkProperty), Properties_CSS2_Aural, IsIdentChar, DoAddKeyword);\r\n  EnumerateKeywords(Ord(tkProperty), Properties_CSS3, IsIdentChar, DoAddKeyword);\r\n\r\n  fRange := rsText;\r\n  fDefaultFilter := SYNS_FilterCSS;\r\nend;\r\n\r\ndestructor TSynCssSyn.Destroy;\r\nbegin\r\n  fKeywords.Free;\r\n  inherited Destroy;\r\nend;\r\n\r\nprocedure TSynCssSyn.BraceCloseProc;\r\nbegin\r\n  fRange := rsText;\r\n  fTokenId := tkSymbol;\r\n  Inc(Run);\r\nend;\r\n\r\nprocedure TSynCssSyn.CommentProc;\r\nbegin\r\n  if fLine[Run] = #0 then\r\n    NullProc\r\n  else\r\n  begin\r\n    fTokenID := tkComment;\r\n    repeat\r\n      if (fLine[Run] = '*') and (fLine[Run + 1] = '/') then\r\n      begin\r\n        fRange := fCommentRange;\r\n        inc(Run, 2);\r\n        break;\r\n      end;\r\n      inc(Run);\r\n    until IsLineEnd(Run)\r\n  end;\r\nend;\r\n\r\nprocedure TSynCssSyn.BraceOpenProc;\r\nbegin\r\n  Inc(Run);\r\n  fRange := rsParam;\r\n  fTokenID := tkSymbol;\r\nend;\r\n\r\nprocedure TSynCssSyn.CRProc;\r\nbegin\r\n  fTokenID := tkSpace;\r\n  Inc(Run);\r\n  if fLine[Run] = #10 then Inc(Run);\r\nend;\r\n\r\nprocedure TSynCssSyn.SemiProc;\r\nbegin\r\n  fRange := rsUnknown;\r\n  fTokenID := tkSymbol;\r\n  Inc(Run);\r\nend;\r\n\r\nprocedure TSynCssSyn.StartValProc;\r\nbegin\r\n  fRange := rsValue;\r\n  fTokenID := tkSymbol;\r\n  Inc(Run);\r\nend;\r\n\r\nprocedure TSynCssSyn.NumberProc;\r\nbegin\r\n  if (FLine[Run] = '-') and not CharInSet(FLine[Run + 1], ['0'..'9']) then\r\n    IdentProc\r\n  else\r\n  begin\r\n    inc(Run);\r\n    fTokenID := tkNumber;\r\n    while CharInSet(FLine[Run], ['0'..'9', '.']) do\r\n    begin\r\n      case FLine[Run] of\r\n        '.':\r\n          if FLine[Run + 1] = '.' then break;\r\n      end;\r\n      inc(Run);\r\n    end;\r\n  end;\r\nend;\r\n\r\nprocedure TSynCssSyn.IdentProc;\r\nbegin\r\n  case fRange of\r\n    rsKey:\r\n      begin\r\n        fRange := rsParam;\r\n        fTokenID := tkKey;\r\n        Inc(Run, fStringLen);\r\n      end;\r\n    rsValue:\r\n      begin\r\n        fTokenID := tkValue;\r\n\r\n        while not IsLineEnd(Run) and\r\n          not CharInSet(fLine[Run], ['}', ';', ',', ' ']) do\r\n        begin\r\n          Inc(Run);\r\n        end;\r\n\r\n        if IsLineEnd(Run) or CharInSet(fLine[Run], ['}', ';']) then\r\n          fRange := rsParam;\r\n      end;\r\n    else\r\n      fTokenID := IdentKind((fLine + Run));\r\n      repeat\r\n        Inc(Run);\r\n      until (fLine[Run] <= #32) or CharInSet(fLine[Run], [':', '\"', '}', ';']);\r\n  end;\r\nend;\r\n\r\nprocedure TSynCssSyn.LFProc;\r\nbegin\r\n  fTokenID := tkSpace;\r\n  Inc(Run);\r\nend;\r\n\r\nprocedure TSynCssSyn.NullProc;\r\nbegin\r\n  fTokenID := tkNull;\r\n  inc(Run);\r\nend;\r\n\r\nprocedure TSynCssSyn.TextProc;\r\n\r\n  function IsStopChar: Boolean;\r\n  begin\r\n    case fLine[Run] of\r\n      #0..#31, '{', '/':\r\n        Result := True;\r\n      else\r\n        Result := False;\r\n    end;\r\n  end;\r\n\r\nbegin\r\n  if IsStopChar then\r\n  begin\r\n    NextProcedure;\r\n    exit;\r\n  end;\r\n\r\n  fTokenID := tkKey;\r\n  while not IsStopChar do Inc(Run);\r\nend;\r\n\r\nprocedure TSynCssSyn.SpaceProc;\r\nbegin\r\n  inc(Run);\r\n  fTokenID := tkSpace;\r\n  while (FLine[Run] <= #32) and not IsLineEnd(Run) do inc(Run);\r\nend;\r\n\r\nprocedure TSynCssSyn.StringProc;\r\nbegin\r\n  fTokenID := tkString;\r\n  Inc(Run);  // first '\"'\r\n  while not (IsLineEnd(Run) or (fLine[Run] = '\"')) do Inc(Run);\r\n  if fLine[Run] = '\"' then Inc(Run);  // last '\"'\r\nend;\r\n\r\nprocedure TSynCssSyn.HashProc;\r\n\r\n  function IsHexChar: Boolean;\r\n  begin\r\n    case fLine[Run] of\r\n      '0'..'9', 'A'..'F', 'a'..'f':\r\n        Result := True;\r\n      else\r\n        Result := False;\r\n    end;\r\n  end;\r\n\r\nbegin\r\n  fTokenID := tkColor;\r\n  Inc(Run);  // '#'\r\n  while IsHexChar do Inc(Run);\r\nend;\r\n\r\nprocedure TSynCssSyn.ExclamProc;\r\nbegin\r\n  if (fLine[Run + 1] = 'i') and\r\n    (fLine[Run + 2] = 'm') and\r\n    (fLine[Run + 3] = 'p') and\r\n    (fLine[Run + 4] = 'o') and\r\n    (fLine[Run + 5] = 'r') and\r\n    (fLine[Run + 6] = 't') and\r\n    (fLine[Run + 7] = 'a') and\r\n    (fLine[Run + 8] = 'n') and\r\n    (fLine[Run + 9] = 't') then\r\n  begin\r\n    fTokenID := tkImportant;\r\n    Inc(Run, 10);\r\n  end\r\n  else\r\n    IdentProc;\r\nend;\r\n\r\nprocedure TSynCssSyn.SlashProc;\r\nbegin\r\n  inc(Run);\r\n  if fLine[Run] = '*' then\r\n  begin\r\n    fTokenID := tkComment;\r\n    fCommentRange := fRange;\r\n    fRange := rsComment;\r\n    inc(Run);\r\n    if not IsLineEnd(Run) then\r\n      CommentProc;\r\n  end\r\n  else\r\n    fTokenID := tkSymbol;\r\nend;\r\n\r\nprocedure TSynCssSyn.Next;\r\nbegin\r\n  fTokenPos := Run;\r\n  case fRange of\r\n    rsText:\r\n      TextProc;\r\n    rsComment:\r\n      CommentProc;\r\n    else\r\n      NextProcedure;\r\n  end;\r\n  inherited;\r\nend;\r\n\r\nprocedure TSynCssSyn.NextProcedure;\r\nbegin\r\n  case fLine[Run] of\r\n    #0: NullProc;\r\n    #10: LFProc;\r\n    #13: CRProc;\r\n    #1..#9, #11, #12, #14..#32: SpaceProc;\r\n    '\"': StringProc;\r\n    '#': HashProc;\r\n    '{': BraceOpenProc;\r\n    '}': BraceCloseProc;\r\n    ':', ',': StartValProc;\r\n    ';': SemiProc;\r\n    '0'..'9', '-', '.': NumberProc;\r\n    '/': SlashProc;\r\n    '!': ExclamProc;\r\n    else IdentProc;\r\n  end;\r\nend;\r\n\r\nfunction TSynCssSyn.GetDefaultAttribute(Index: integer): TSynHighlighterAttributes;\r\nbegin\r\n  case Index of\r\n    SYN_ATTR_COMMENT: Result := fCommentAttri;\r\n    SYN_ATTR_KEYWORD: Result := fKeyAttri;\r\n    SYN_ATTR_WHITESPACE: Result := fSpaceAttri;\r\n    SYN_ATTR_STRING: Result := fStringAttri;\r\n    else Result := nil;\r\n  end;\r\nend;\r\n\r\nfunction TSynCssSyn.GetEol: Boolean;\r\nbegin\r\n  Result := Run = fLineLen + 1;\r\nend;\r\n\r\nfunction TSynCssSyn.GetTokenID: TtkTokenKind;\r\nbegin\r\n  Result := fTokenId;\r\nend;\r\n\r\nfunction TSynCssSyn.GetTokenAttribute: TSynHighlighterAttributes;\r\nbegin\r\n  case fTokenID of\r\n    tkComment: Result := fCommentAttri;\r\n    tkProperty: Result := fPropertyAttri;\r\n    tkKey: Result := fKeyAttri;\r\n    tkSpace: Result := fSpaceAttri;\r\n    tkString: Result := fStringAttri;\r\n    tkSymbol: Result := fSymbolAttri;\r\n    tkText: Result := fTextAttri;\r\n    tkUndefProperty: Result := fUndefPropertyAttri;\r\n    tkImportant: Result := fImportantPropertyAttri;\r\n    tkValue: Result := fValueAttri;\r\n    tkColor: Result := fColorAttri;\r\n    tkNumber: Result := fNumberAttri;\r\n    else Result := nil;\r\n  end;\r\nend;\r\n\r\nfunction TSynCssSyn.GetTokenKind: integer;\r\nbegin\r\n  Result := Ord(fTokenId);\r\nend;\r\n\r\nfunction TSynCssSyn.GetRange: Pointer;\r\nbegin\r\n  Result := Pointer(fRange);\r\nend;\r\n\r\nprocedure TSynCssSyn.SetRange(Value: Pointer);\r\nbegin\r\n  fRange := TRangeState(Value);\r\nend;\r\n\r\nprocedure TSynCssSyn.ResetRange;\r\nbegin\r\n  fRange:= rsText;\r\nend;\r\n\r\nfunction TSynCssSyn.GetSampleSource: UnicodeString;\r\nbegin\r\n  Result := '/* Syntax Highlighting */'#13#10 +\r\n        'body { font-family: Tahoma, Verdana, Arial, Helvetica, sans-serif; font-size: 8pt }'#13#10 +\r\n        'H1 { font-size: 18pt; color: #000099; made-up-property: 1 }';\r\nend; { GetSampleSource }\r\n\r\nclass function TSynCssSyn.GetLanguageName: string;\r\nbegin\r\n  Result := SYNS_LangCSS;\r\nend;\r\n\r\nfunction TSynCssSyn.IsFilterStored: boolean;\r\nbegin\r\n  Result := fDefaultFilter <> SYNS_FilterCSS;\r\nend;\r\n\r\nfunction TSynCssSyn.IsIdentChar(AChar: WideChar): Boolean;\r\nbegin\r\n  case AChar of\r\n    '_', '-', '0'..'9', 'A'..'Z', 'a'..'z':\r\n      Result := True;\r\n    else\r\n      Result := False;\r\n  end;\r\nend;\r\n\r\nclass function TSynCssSyn.GetFriendlyLanguageName: UnicodeString;\r\nbegin\r\n  Result := SYNS_FriendlyLangCSS;\r\nend;\r\n\r\ninitialization\r\n{$IFNDEF SYN_CPPB_1}\r\n  RegisterPlaceableHighlighter(TSynCssSyn);\r\n{$ENDIF}\r\nend.\r\n"
  },
  {
    "path": "External/SynEdit/Source/SynHighlighterDOT.pas",
    "content": "{-------------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nCode template generated with SynGen.\r\nThe original code is: SynHighlighterDOT.pas, released 2002-11-30.\r\nDescription: DOT Syntax Parser/Highlighter\r\nThe initial author of this file is nissl (nissl@tiscali.it, nissl@mammuth.it)\r\nUnicode translation by Mal Hrz.\r\nCopyright (c) 2002, all rights reserved.\r\n\r\nContributors to the SynEdit and mwEdit projects are listed in the\r\nContributors.txt file.\r\n\r\nAlternatively, the contents of this file may be used under the terms of the\r\nGNU General Public License Version 2 or later (the \"GPL\"), in which case\r\nthe provisions of the GPL are applicable instead of those above.\r\nIf you wish to allow use of your version of this file only under the terms\r\nof the GPL and not to allow others to use your version of this file\r\nunder the MPL, indicate your decision by deleting the provisions above and\r\nreplace them with the notice and other provisions required by the GPL.\r\nIf you do not delete the provisions above, a recipient may use your version\r\nof this file under either the MPL or the GPL.\r\n\r\n$Id: SynHighlighterDOT.pas,v 1.3.2.7 2008/09/14 16:25:00 maelh Exp $\r\n\r\nYou may retrieve the latest version of this file at the SynEdit home page,\r\nlocated at http://SynEdit.SourceForge.net\r\n\r\n-------------------------------------------------------------------------------}\r\n{\r\n@abstract(Provides a ATT DOT highlighter for SynEdit)\r\n@author(Massimo Maria Ghisalberti (nissl@mammuth.it))\r\n@created(november 2002)\r\n@lastmod(2002-11-30)\r\nThe SynHighlighterDOT unit provides SynEdit with a DOT Graph Drawing (.dot) highlighter.\r\nThe highlighter formats DOT source code ref.: http://www.research.att.com/sw/tools/graphviz/.\r\n}\r\n\r\n{$IFNDEF QSYNHIGHLIGHTERDOT}\r\nunit SynHighlighterDOT;\r\n{$ENDIF}\r\n\r\n{$I SynEdit.inc}\r\n\r\ninterface\r\n\r\nuses\r\n{$IFDEF SYN_CLX}\r\n  QControls,\r\n  QGraphics,\r\n  QSynEditTypes,\r\n  QSynEditHighlighter,\r\n  QSynUnicode,\r\n{$ELSE}\r\n  Windows,\r\n  Controls,\r\n  Graphics,\r\n  SynEditTypes,\r\n  SynEditHighlighter,\r\n  SynUnicode,\r\n{$ENDIF}\r\n  SysUtils,\r\n  Classes;\r\n\r\ntype\r\n  TtkTokenKind = (\r\n    tkArrowHead,\r\n    tkAttribute,\r\n    tkComment,\r\n    tkDirections,\r\n    tkIdentifier,\r\n    tkKey,\r\n    tkNull,\r\n    tkShape,\r\n    tkSpace,\r\n    tkString,\r\n    tkUnknown,\r\n    tkValue,\r\n    tkSymbol);\r\n\r\n  TRangeState = (rsUnKnown, rsCStyleComment, rsString);\r\n\r\n  PIdentFuncTableFunc = ^TIdentFuncTableFunc;\r\n  TIdentFuncTableFunc = function (Index: Integer): TtkTokenKind of object;\r\n\r\ntype\r\n  TSynDOTSyn = class(TSynCustomHighlighter)\r\n  private\r\n    fRange: TRangeState;\r\n    fTokenID: TtkTokenKind;\r\n    fIdentFuncTable: array[0..786] of TIdentFuncTableFunc;\r\n    fArrowHeadAttri: TSynHighlighterAttributes;\r\n    fAttributeAttri: TSynHighlighterAttributes;\r\n    fCommentAttri: TSynHighlighterAttributes;\r\n    fDirectionsAttri: TSynHighlighterAttributes;\r\n    fIdentifierAttri: TSynHighlighterAttributes;\r\n    fKeyAttri: TSynHighlighterAttributes;\r\n    fShapeAttri: TSynHighlighterAttributes;\r\n    fSpaceAttri: TSynHighlighterAttributes;\r\n    fStringAttri: TSynHighlighterAttributes;\r\n    fValueAttri: TSynHighlighterAttributes;\r\n    fSymbolAttri: TSynHighlighterAttributes;\r\n    function AltFunc(Index: Integer): TtkTokenKind;\r\n    function FuncAll(Index: Integer): TtkTokenKind;\r\n    function FuncAppendix(Index: Integer): TtkTokenKind;\r\n    function FuncArrowhead(Index: Integer): TtkTokenKind;\r\n    function FuncArrowsize(Index: Integer): TtkTokenKind;\r\n    function FuncArrowtail(Index: Integer): TtkTokenKind;\r\n    function FuncAuto(Index: Integer): TtkTokenKind;\r\n    function FuncBack(Index: Integer): TtkTokenKind;\r\n    function FuncBgcolor(Index: Integer): TtkTokenKind;\r\n    function FuncBold(Index: Integer): TtkTokenKind;\r\n    function FuncBoth(Index: Integer): TtkTokenKind;\r\n    function FuncBottomlabel(Index: Integer): TtkTokenKind;\r\n    function FuncBox(Index: Integer): TtkTokenKind;\r\n    function FuncCenter(Index: Integer): TtkTokenKind;\r\n    function FuncCircle(Index: Integer): TtkTokenKind;\r\n    function FuncClusterrank(Index: Integer): TtkTokenKind;\r\n    function FuncColor(Index: Integer): TtkTokenKind;\r\n    function FuncComment(Index: Integer): TtkTokenKind;\r\n    function FuncCompound(Index: Integer): TtkTokenKind;\r\n    function FuncConcentrate(Index: Integer): TtkTokenKind;\r\n    function FuncConstraint(Index: Integer): TtkTokenKind;\r\n    function FuncDecorate(Index: Integer): TtkTokenKind;\r\n    function FuncDiamond(Index: Integer): TtkTokenKind;\r\n    function FuncDigraph(Index: Integer): TtkTokenKind;\r\n    function FuncDir(Index: Integer): TtkTokenKind;\r\n    function FuncDistortion(Index: Integer): TtkTokenKind;\r\n    function FuncDot(Index: Integer): TtkTokenKind;\r\n    function FuncDotted(Index: Integer): TtkTokenKind;\r\n    function FuncDoublecircle(Index: Integer): TtkTokenKind;\r\n    function FuncDoubleoctagon(Index: Integer): TtkTokenKind;\r\n    function FuncE(Index: Integer): TtkTokenKind;\r\n    function FuncEdge(Index: Integer): TtkTokenKind;\r\n    function FuncEgg(Index: Integer): TtkTokenKind;\r\n    function FuncEllipse(Index: Integer): TtkTokenKind;\r\n    function FuncFalse(Index: Integer): TtkTokenKind;\r\n    function FuncFill(Index: Integer): TtkTokenKind;\r\n    function FuncFillcolor(Index: Integer): TtkTokenKind;\r\n    function FuncFilled(Index: Integer): TtkTokenKind;\r\n    function FuncFixedsize(Index: Integer): TtkTokenKind;\r\n    function FuncFontcolor(Index: Integer): TtkTokenKind;\r\n    function FuncFontname(Index: Integer): TtkTokenKind;\r\n    function FuncFontpath(Index: Integer): TtkTokenKind;\r\n    function FuncFontsize(Index: Integer): TtkTokenKind;\r\n    function FuncForward(Index: Integer): TtkTokenKind;\r\n    function FuncGlobal(Index: Integer): TtkTokenKind;\r\n    function FuncGraph(Index: Integer): TtkTokenKind;\r\n    function FuncGroup(Index: Integer): TtkTokenKind;\r\n    function FuncHeadlabel(Index: Integer): TtkTokenKind;\r\n    function FuncHeadport(Index: Integer): TtkTokenKind;\r\n    function FuncHeadurl(Index: Integer): TtkTokenKind;\r\n    function FuncHeight(Index: Integer): TtkTokenKind;\r\n    function FuncHexagon(Index: Integer): TtkTokenKind;\r\n    function FuncHouse(Index: Integer): TtkTokenKind;\r\n    function FuncId(Index: Integer): TtkTokenKind;\r\n    function FuncInv(Index: Integer): TtkTokenKind;\r\n    function FuncInvdot(Index: Integer): TtkTokenKind;\r\n    function FuncInvhouse(Index: Integer): TtkTokenKind;\r\n    function FuncInvodot(Index: Integer): TtkTokenKind;\r\n    function FuncInvtrapezium(Index: Integer): TtkTokenKind;\r\n    function FuncInvtriangle(Index: Integer): TtkTokenKind;\r\n    function FuncLabel(Index: Integer): TtkTokenKind;\r\n    function FuncLabelangle(Index: Integer): TtkTokenKind;\r\n    function FuncLabeldistance(Index: Integer): TtkTokenKind;\r\n    function FuncLabelfloat(Index: Integer): TtkTokenKind;\r\n    function FuncLabelfontcolor(Index: Integer): TtkTokenKind;\r\n    function FuncLabelfontname(Index: Integer): TtkTokenKind;\r\n    function FuncLabelfontsize(Index: Integer): TtkTokenKind;\r\n    function FuncLabeljust(Index: Integer): TtkTokenKind;\r\n    function FuncLabelloc(Index: Integer): TtkTokenKind;\r\n    function FuncLayer(Index: Integer): TtkTokenKind;\r\n    function FuncLayers(Index: Integer): TtkTokenKind;\r\n    function FuncLhead(Index: Integer): TtkTokenKind;\r\n    function FuncLtail(Index: Integer): TtkTokenKind;\r\n    function FuncMargin(Index: Integer): TtkTokenKind;\r\n    function FuncMax(Index: Integer): TtkTokenKind;\r\n    function FuncMcircle(Index: Integer): TtkTokenKind;\r\n    function FuncMclimit(Index: Integer): TtkTokenKind;\r\n    function FuncMdiamond(Index: Integer): TtkTokenKind;\r\n    function FuncMerged(Index: Integer): TtkTokenKind;\r\n    function FuncMin(Index: Integer): TtkTokenKind;\r\n    function FuncMinimum(Index: Integer): TtkTokenKind;\r\n    function FuncMinlen(Index: Integer): TtkTokenKind;\r\n    function FuncMrecord(Index: Integer): TtkTokenKind;\r\n    function FuncMsquare(Index: Integer): TtkTokenKind;\r\n    function FuncMultiples(Index: Integer): TtkTokenKind;\r\n    function FuncN(Index: Integer): TtkTokenKind;\r\n    function FuncNe(Index: Integer): TtkTokenKind;\r\n    function FuncNode(Index: Integer): TtkTokenKind;\r\n    function FuncNodesep(Index: Integer): TtkTokenKind;\r\n    function FuncNone(Index: Integer): TtkTokenKind;\r\n    function FuncNormal(Index: Integer): TtkTokenKind;\r\n    function FuncNslimit(Index: Integer): TtkTokenKind;\r\n    function FuncNw(Index: Integer): TtkTokenKind;\r\n    function FuncOctagon(Index: Integer): TtkTokenKind;\r\n    function FuncOdot(Index: Integer): TtkTokenKind;\r\n    function FuncOnto(Index: Integer): TtkTokenKind;\r\n    function FuncOrdering(Index: Integer): TtkTokenKind;\r\n    function FuncOrientation(Index: Integer): TtkTokenKind;\r\n    function FuncPage(Index: Integer): TtkTokenKind;\r\n    function FuncPagedir(Index: Integer): TtkTokenKind;\r\n    function FuncParallelogram(Index: Integer): TtkTokenKind;\r\n    function FuncPeripheries(Index: Integer): TtkTokenKind;\r\n    function FuncPlaintext(Index: Integer): TtkTokenKind;\r\n    function FuncPoint(Index: Integer): TtkTokenKind;\r\n    function FuncPolygon(Index: Integer): TtkTokenKind;\r\n    function FuncQuantum(Index: Integer): TtkTokenKind;\r\n    function FuncRank(Index: Integer): TtkTokenKind;\r\n    function FuncRankdir(Index: Integer): TtkTokenKind;\r\n    function FuncRanksep(Index: Integer): TtkTokenKind;\r\n    function FuncRatio(Index: Integer): TtkTokenKind;\r\n    function FuncRecord(Index: Integer): TtkTokenKind;\r\n    function FuncRegular(Index: Integer): TtkTokenKind;\r\n    function FuncRemincross(Index: Integer): TtkTokenKind;\r\n    function FuncRotate(Index: Integer): TtkTokenKind;\r\n    function FuncS(Index: Integer): TtkTokenKind;\r\n    function FuncSame(Index: Integer): TtkTokenKind;\r\n    function FuncSamehead(Index: Integer): TtkTokenKind;\r\n    function FuncSametail(Index: Integer): TtkTokenKind;\r\n    function FuncSamplepoints(Index: Integer): TtkTokenKind;\r\n    function FuncSe(Index: Integer): TtkTokenKind;\r\n    function FuncSearchsize(Index: Integer): TtkTokenKind;\r\n    function FuncSection(Index: Integer): TtkTokenKind;\r\n    function FuncShape(Index: Integer): TtkTokenKind;\r\n    function FuncShapefile(Index: Integer): TtkTokenKind;\r\n    function FuncSides(Index: Integer): TtkTokenKind;\r\n    function FuncSink(Index: Integer): TtkTokenKind;\r\n    function FuncSize(Index: Integer): TtkTokenKind;\r\n    function FuncSkew(Index: Integer): TtkTokenKind;\r\n    function FuncSource(Index: Integer): TtkTokenKind;\r\n    function FuncStrict(Index: Integer): TtkTokenKind;\r\n    function FuncStyle(Index: Integer): TtkTokenKind;\r\n    function FuncSubgraph(Index: Integer): TtkTokenKind;\r\n    function FuncSw(Index: Integer): TtkTokenKind;\r\n    function FuncTaillabel(Index: Integer): TtkTokenKind;\r\n    function FuncTailport(Index: Integer): TtkTokenKind;\r\n    function FuncTailurl(Index: Integer): TtkTokenKind;\r\n    function FuncToplabel(Index: Integer): TtkTokenKind;\r\n    function FuncTrapezium(Index: Integer): TtkTokenKind;\r\n    function FuncTriangle(Index: Integer): TtkTokenKind;\r\n    function FuncTripleoctagon(Index: Integer): TtkTokenKind;\r\n    function FuncTrue(Index: Integer): TtkTokenKind;\r\n    function FuncUrl(Index: Integer): TtkTokenKind;\r\n    function FuncW(Index: Integer): TtkTokenKind;\r\n    function FuncWeight(Index: Integer): TtkTokenKind;\r\n    function FuncWhen(Index: Integer): TtkTokenKind;\r\n    function FuncWidth(Index: Integer): TtkTokenKind;\r\n    function FuncZ(Index: Integer): TtkTokenKind;\r\n    function HashKey(Str: PWideChar): Cardinal;\r\n    function IdentKind(MayBe: PWideChar): TtkTokenKind;\r\n    procedure InitIdent;\r\n    procedure IdentProc;\r\n    procedure UnknownProc;\r\n    procedure NullProc;\r\n    procedure SpaceProc;\r\n    procedure CRProc;\r\n    procedure LFProc;\r\n    procedure CStyleCommentOpenProc;\r\n    procedure CStyleCommentProc;\r\n    procedure StringOpenProc;\r\n    procedure StringProc;\r\n    procedure SymbolProc;\r\n    procedure DirectionsProc;\r\n  protected\r\n    function GetSampleSource: UnicodeString; override;\r\n    function IsFilterStored: Boolean; override;\r\n  public\r\n    constructor Create(AOwner: TComponent); override;\r\n    class function GetLanguageName: string; override;\r\n    class function GetFriendlyLanguageName: UnicodeString; override;\r\n    function GetRange: Pointer; override;\r\n    procedure ResetRange; override;\r\n    procedure SetRange(Value: Pointer); override;\r\n    function GetDefaultAttribute(Index: integer): TSynHighlighterAttributes; override;\r\n    function GetEol: Boolean; override;\r\n    function GetKeyWords(TokenKind: Integer): UnicodeString; override;\r\n    function GetTokenID: TtkTokenKind;\r\n    function GetTokenAttribute: TSynHighlighterAttributes; override;\r\n    function GetTokenKind: integer; override;\r\n     function IsIdentChar(AChar: WideChar): Boolean; override;\r\n    procedure Next; override;\r\n  published\r\n    property ArrowHeadAttri: TSynHighlighterAttributes read fArrowHeadAttri write fArrowHeadAttri;\r\n    property AttributeAttri: TSynHighlighterAttributes read fAttributeAttri write fAttributeAttri;\r\n    property CommentAttri: TSynHighlighterAttributes read fCommentAttri write fCommentAttri;\r\n    property DirectionsAttri: TSynHighlighterAttributes read fDirectionsAttri write fDirectionsAttri;\r\n    property IdentifierAttri: TSynHighlighterAttributes read fIdentifierAttri write fIdentifierAttri;\r\n    property KeyAttri: TSynHighlighterAttributes read fKeyAttri write fKeyAttri;\r\n    property ShapeAttri: TSynHighlighterAttributes read fShapeAttri write fShapeAttri;\r\n    property SpaceAttri: TSynHighlighterAttributes read fSpaceAttri write fSpaceAttri;\r\n    property StringAttri: TSynHighlighterAttributes read fStringAttri write fStringAttri;\r\n    property ValueAttri: TSynHighlighterAttributes read fValueAttri write fValueAttri;\r\n    property SymbolAttri: TSynHighlighterAttributes read fSymbolAttri write fSymbolAttri;\r\n  end;\r\n\r\nimplementation\r\n\r\nuses\r\n{$IFDEF SYN_CLX}\r\n  QSynEditStrConst;\r\n{$ELSE}\r\n  SynEditStrConst;\r\n{$ENDIF}\r\n\r\nconst\r\n  KeyWords: array[0..145] of UnicodeString = (\r\n    'all', 'appendix', 'arrowhead', 'arrowsize', 'arrowtail', 'auto', 'back', \r\n    'bgcolor', 'bold', 'both', 'bottomlabel', 'box', 'center', 'circle', \r\n    'clusterrank', 'color', 'comment', 'compound', 'concentrate', 'constraint', \r\n    'decorate', 'diamond', 'digraph', 'dir', 'distortion', 'dot', 'dotted', \r\n    'doublecircle', 'doubleoctagon', 'e', 'edge', 'egg', 'ellipse', 'false', \r\n    'fill', 'fillcolor', 'filled', 'fixedsize', 'fontcolor', 'fontname', \r\n    'fontpath', 'fontsize', 'forward', 'global', 'graph', 'group', 'headlabel', \r\n    'headport', 'headurl', 'height', 'hexagon', 'house', 'id', 'inv', 'invdot', \r\n    'invhouse', 'invodot', 'invtrapezium', 'invtriangle', 'label', 'labelangle', \r\n    'labeldistance', 'labelfloat', 'labelfontcolor', 'labelfontname', \r\n    'labelfontsize', 'labeljust', 'labelloc', 'layer', 'layers', 'lhead', \r\n    'ltail', 'margin', 'max', 'mcircle', 'mclimit', 'mdiamond', 'merged', 'min', \r\n    'minimum', 'minlen', 'mrecord', 'msquare', 'multiples', 'n', 'ne', 'node', \r\n    'nodesep', 'none', 'normal', 'nslimit', 'nw', 'octagon', 'odot', 'onto', \r\n    'ordering', 'orientation', 'page', 'pagedir', 'parallelogram', \r\n    'peripheries', 'plaintext', 'point', 'polygon', 'quantum', 'rank', \r\n    'rankdir', 'ranksep', 'ratio', 'record', 'regular', 'remincross', 'rotate', \r\n    's', 'same', 'samehead', 'sametail', 'samplepoints', 'se', 'searchsize', \r\n    'section', 'shape', 'shapefile', 'sides', 'sink', 'size', 'skew', 'source', \r\n    'strict', 'style', 'subgraph', 'sw', 'taillabel', 'tailport', 'tailurl', \r\n    'toplabel', 'trapezium', 'triangle', 'tripleoctagon', 'true', 'url', 'w', \r\n    'weight', 'when', 'width', 'z' \r\n  );\r\n\r\n  KeyIndices: array[0..786] of Integer = (\r\n    -1, -1, -1, -1, 11, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, 141, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 88, 50, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, 40, -1, -1, -1, -1, 4, -1, -1, -1, -1, 90, -1, 3, -1, 110, 86, \r\n    -1, -1, 49, 23, -1, 92, -1, -1, -1, 15, -1, 122, -1, -1, 28, -1, 78, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, 85, -1, 27, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, 140, -1, 103, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 142, -1, 7, -1, 0, \r\n    -1, -1, 97, -1, -1, -1, -1, -1, 43, -1, -1, -1, 131, -1, -1, -1, 5, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 101, -1, 10, -1, \r\n    47, 68, -1, 132, -1, -1, 52, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 2, -1, \r\n    -1, -1, 64, -1, -1, 124, -1, -1, -1, -1, -1, -1, 87, -1, -1, -1, 12, -1, 84, \r\n    -1, -1, -1, 46, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, 42, -1, 38, -1, -1, -1, 143, -1, -1, -1, 145, \r\n    106, -1, 127, -1, -1, -1, 99, 75, -1, -1, 102, -1, 58, -1, -1, 56, -1, -1, \r\n    -1, -1, 9, -1, -1, -1, -1, -1, 22, -1, 73, -1, -1, -1, 17, -1, 54, 112, -1, \r\n    -1, -1, -1, -1, -1, -1, 113, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 96, -1, \r\n    21, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 69, 116, -1, -1, 32, -1, \r\n    -1, -1, -1, -1, -1, -1, 16, -1, -1, -1, -1, -1, 126, -1, -1, -1, -1, -1, -1, \r\n    -1, 71, -1, -1, -1, -1, -1, -1, -1, -1, -1, 137, -1, -1, 117, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, 111, 93, -1, -1, -1, -1, 108, -1, -1, 119, -1, -1, -1, \r\n    -1, 29, -1, -1, -1, -1, -1, -1, -1, -1, 89, -1, -1, -1, -1, 76, -1, -1, -1, \r\n    -1, -1, -1, -1, 77, -1, -1, 104, -1, -1, -1, -1, -1, -1, 33, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, 26, -1, -1, -1, 79, -1, 19, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, 39, -1, -1, -1, 115, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, 109, 35, -1, -1, 70, -1, -1, 57, -1, 72, -1, \r\n    -1, 83, -1, -1, -1, -1, 130, -1, -1, -1, 18, -1, 118, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, 81, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 61, \r\n    37, 1, -1, -1, -1, -1, 138, -1, -1, -1, -1, -1, 129, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, 14, -1, -1, 8, -1, -1, -1, 125, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, 91, -1, -1, -1, -1, -1, 60, -1, -1, -1, -1, -1, -1, -1, \r\n    95, -1, -1, -1, -1, 136, -1, -1, 20, -1, 62, -1, -1, -1, -1, 134, -1, -1, \r\n    -1, 63, -1, -1, -1, 121, 80, -1, -1, -1, -1, -1, -1, 135, -1, -1, 120, -1, \r\n    -1, -1, 53, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 31, -1, -1, -1, -1, -1, \r\n    -1, 24, -1, -1, 139, 67, -1, -1, 59, -1, -1, 36, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, 128, 34, -1, -1, -1, -1, -1, -1, -1, -1, 65, -1, 114, -1, -1, -1, -1, \r\n    -1, -1, -1, 55, -1, -1, 94, -1, -1, 13, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, 41, -1, -1, -1, -1, -1, -1, -1, 44, -1, \r\n    -1, -1, -1, -1, 74, -1, 51, 144, -1, -1, 82, 98, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, 100, 66, -1, 25, -1, -1, -1, 45, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 48, -1, -1, \r\n    6, 105, -1, -1, 133, 123, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, 107, -1, -1, -1, -1, -1, -1, -1, -1, -1, 30, -1, -1, -1 \r\n  );\r\n\r\n{$Q-}\r\nfunction TSynDOTSyn.HashKey(Str: PWideChar): Cardinal;\r\nbegin\r\n  Result := 0;\r\n  while IsIdentChar(Str^) do\r\n  begin\r\n    Result := Result * 63 + Ord(Str^) * 331;\r\n    inc(Str);\r\n  end;\r\n  Result := Result mod 787;\r\n  fStringLen := Str - fToIdent;\r\nend;\r\n{$Q+}\r\n\r\nfunction TSynDOTSyn.IdentKind(MayBe: PWideChar): TtkTokenKind;\r\nvar\r\n  Key: Cardinal;\r\nbegin\r\n  fToIdent := MayBe;\r\n  Key := HashKey(MayBe);\r\n  if Key <= High(fIdentFuncTable) then\r\n    Result := fIdentFuncTable[Key](KeyIndices[Key])\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nprocedure TSynDOTSyn.InitIdent;\r\nvar\r\n  i: Integer;\r\nbegin\r\n  for i := Low(fIdentFuncTable) to High(fIdentFuncTable) do\r\n    if KeyIndices[i] = -1 then\r\n      fIdentFuncTable[i] := AltFunc;\r\n\r\n  fIdentFuncTable[132] := FuncAll;\r\n  fIdentFuncTable[509] := FuncAppendix;\r\n  fIdentFuncTable[188] := FuncArrowhead;\r\n  fIdentFuncTable[72] := FuncArrowsize;\r\n  fIdentFuncTable[65] := FuncArrowtail;\r\n  fIdentFuncTable[149] := FuncAuto;\r\n  fIdentFuncTable[752] := FuncBack;\r\n  fIdentFuncTable[130] := FuncBgcolor;\r\n  fIdentFuncTable[536] := FuncBold;\r\n  fIdentFuncTable[266] := FuncBoth;\r\n  fIdentFuncTable[169] := FuncBottomlabel;\r\n  fIdentFuncTable[4] := FuncBox;\r\n  fIdentFuncTable[206] := FuncCenter;\r\n  fIdentFuncTable[666] := FuncCircle;\r\n  fIdentFuncTable[533] := FuncClusterrank;\r\n  fIdentFuncTable[85] := FuncColor;\r\n  fIdentFuncTable[327] := FuncComment;\r\n  fIdentFuncTable[278] := FuncCompound;\r\n  fIdentFuncTable[481] := FuncConcentrate;\r\n  fIdentFuncTable[425] := FuncConstraint;\r\n  fIdentFuncTable[573] := FuncDecorate;\r\n  fIdentFuncTable[302] := FuncDiamond;\r\n  fIdentFuncTable[272] := FuncDigraph;\r\n  fIdentFuncTable[79] := FuncDir;\r\n  fIdentFuncTable[621] := FuncDistortion;\r\n  fIdentFuncTable[726] := FuncDot;\r\n  fIdentFuncTable[419] := FuncDotted;\r\n  fIdentFuncTable[104] := FuncDoublecircle;\r\n  fIdentFuncTable[90] := FuncDoubleoctagon;\r\n  fIdentFuncTable[377] := FuncE;\r\n  fIdentFuncTable[783] := FuncEdge;\r\n  fIdentFuncTable[614] := FuncEgg;\r\n  fIdentFuncTable[319] := FuncEllipse;\r\n  fIdentFuncTable[409] := FuncFalse;\r\n  fIdentFuncTable[641] := FuncFill;\r\n  fIdentFuncTable[461] := FuncFillcolor;\r\n  fIdentFuncTable[631] := FuncFilled;\r\n  fIdentFuncTable[508] := FuncFixedsize;\r\n  fIdentFuncTable[237] := FuncFontcolor;\r\n  fIdentFuncTable[435] := FuncFontname;\r\n  fIdentFuncTable[60] := FuncFontpath;\r\n  fIdentFuncTable[685] := FuncFontsize;\r\n  fIdentFuncTable[235] := FuncForward;\r\n  fIdentFuncTable[141] := FuncGlobal;\r\n  fIdentFuncTable[693] := FuncGraph;\r\n  fIdentFuncTable[730] := FuncGroup;\r\n  fIdentFuncTable[212] := FuncHeadlabel;\r\n  fIdentFuncTable[171] := FuncHeadport;\r\n  fIdentFuncTable[749] := FuncHeadurl;\r\n  fIdentFuncTable[78] := FuncHeight;\r\n  fIdentFuncTable[51] := FuncHexagon;\r\n  fIdentFuncTable[701] := FuncHouse;\r\n  fIdentFuncTable[177] := FuncId;\r\n  fIdentFuncTable[603] := FuncInv;\r\n  fIdentFuncTable[280] := FuncInvdot;\r\n  fIdentFuncTable[660] := FuncInvhouse;\r\n  fIdentFuncTable[261] := FuncInvodot;\r\n  fIdentFuncTable[467] := FuncInvtrapezium;\r\n  fIdentFuncTable[258] := FuncInvtriangle;\r\n  fIdentFuncTable[628] := FuncLabel;\r\n  fIdentFuncTable[557] := FuncLabelangle;\r\n  fIdentFuncTable[507] := FuncLabeldistance;\r\n  fIdentFuncTable[575] := FuncLabelfloat;\r\n  fIdentFuncTable[584] := FuncLabelfontcolor;\r\n  fIdentFuncTable[192] := FuncLabelfontname;\r\n  fIdentFuncTable[650] := FuncLabelfontsize;\r\n  fIdentFuncTable[724] := FuncLabeljust;\r\n  fIdentFuncTable[625] := FuncLabelloc;\r\n  fIdentFuncTable[172] := FuncLayer;\r\n  fIdentFuncTable[315] := FuncLayers;\r\n  fIdentFuncTable[464] := FuncLhead;\r\n  fIdentFuncTable[341] := FuncLtail;\r\n  fIdentFuncTable[469] := FuncMargin;\r\n  fIdentFuncTable[274] := FuncMax;\r\n  fIdentFuncTable[699] := FuncMcircle;\r\n  fIdentFuncTable[253] := FuncMclimit;\r\n  fIdentFuncTable[391] := FuncMdiamond;\r\n  fIdentFuncTable[399] := FuncMerged;\r\n  fIdentFuncTable[92] := FuncMin;\r\n  fIdentFuncTable[423] := FuncMinimum;\r\n  fIdentFuncTable[589] := FuncMinlen;\r\n  fIdentFuncTable[493] := FuncMrecord;\r\n  fIdentFuncTable[705] := FuncMsquare;\r\n  fIdentFuncTable[472] := FuncMultiples;\r\n  fIdentFuncTable[208] := FuncN;\r\n  fIdentFuncTable[102] := FuncNe;\r\n  fIdentFuncTable[75] := FuncNode;\r\n  fIdentFuncTable[202] := FuncNodesep;\r\n  fIdentFuncTable[50] := FuncNone;\r\n  fIdentFuncTable[386] := FuncNormal;\r\n  fIdentFuncTable[70] := FuncNslimit;\r\n  fIdentFuncTable[551] := FuncNw;\r\n  fIdentFuncTable[81] := FuncOctagon;\r\n  fIdentFuncTable[364] := FuncOdot;\r\n  fIdentFuncTable[663] := FuncOnto;\r\n  fIdentFuncTable[565] := FuncOrdering;\r\n  fIdentFuncTable[300] := FuncOrientation;\r\n  fIdentFuncTable[135] := FuncPage;\r\n  fIdentFuncTable[706] := FuncPagedir;\r\n  fIdentFuncTable[252] := FuncParallelogram;\r\n  fIdentFuncTable[723] := FuncPeripheries;\r\n  fIdentFuncTable[167] := FuncPlaintext;\r\n  fIdentFuncTable[256] := FuncPoint;\r\n  fIdentFuncTable[117] := FuncPolygon;\r\n  fIdentFuncTable[402] := FuncQuantum;\r\n  fIdentFuncTable[753] := FuncRank;\r\n  fIdentFuncTable[246] := FuncRankdir;\r\n  fIdentFuncTable[773] := FuncRanksep;\r\n  fIdentFuncTable[369] := FuncRatio;\r\n  fIdentFuncTable[460] := FuncRecord;\r\n  fIdentFuncTable[74] := FuncRegular;\r\n  fIdentFuncTable[363] := FuncRemincross;\r\n  fIdentFuncTable[281] := FuncRotate;\r\n  fIdentFuncTable[289] := FuncS;\r\n  fIdentFuncTable[652] := FuncSame;\r\n  fIdentFuncTable[439] := FuncSamehead;\r\n  fIdentFuncTable[316] := FuncSametail;\r\n  fIdentFuncTable[354] := FuncSamplepoints;\r\n  fIdentFuncTable[483] := FuncSe;\r\n  fIdentFuncTable[372] := FuncSearchsize;\r\n  fIdentFuncTable[599] := FuncSection;\r\n  fIdentFuncTable[588] := FuncShape;\r\n  fIdentFuncTable[87] := FuncShapefile;\r\n  fIdentFuncTable[757] := FuncSides;\r\n  fIdentFuncTable[195] := FuncSink;\r\n  fIdentFuncTable[540] := FuncSize;\r\n  fIdentFuncTable[333] := FuncSkew;\r\n  fIdentFuncTable[248] := FuncSource;\r\n  fIdentFuncTable[640] := FuncStrict;\r\n  fIdentFuncTable[520] := FuncStyle;\r\n  fIdentFuncTable[477] := FuncSubgraph;\r\n  fIdentFuncTable[145] := FuncSw;\r\n  fIdentFuncTable[174] := FuncTaillabel;\r\n  fIdentFuncTable[756] := FuncTailport;\r\n  fIdentFuncTable[580] := FuncTailurl;\r\n  fIdentFuncTable[596] := FuncToplabel;\r\n  fIdentFuncTable[570] := FuncTrapezium;\r\n  fIdentFuncTable[351] := FuncTriangle;\r\n  fIdentFuncTable[514] := FuncTripleoctagon;\r\n  fIdentFuncTable[624] := FuncTrue;\r\n  fIdentFuncTable[115] := FuncUrl;\r\n  fIdentFuncTable[39] := FuncW;\r\n  fIdentFuncTable[128] := FuncWeight;\r\n  fIdentFuncTable[241] := FuncWhen;\r\n  fIdentFuncTable[702] := FuncWidth;\r\n  fIdentFuncTable[245] := FuncZ;\r\nend;\r\n\r\nfunction TSynDOTSyn.AltFunc(Index: Integer): TtkTokenKind;\r\nbegin\r\n  Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDOTSyn.FuncAll(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkValue\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDOTSyn.FuncAppendix(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkAttribute\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDOTSyn.FuncArrowhead(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkAttribute\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDOTSyn.FuncArrowsize(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkAttribute\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDOTSyn.FuncArrowtail(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkAttribute\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDOTSyn.FuncAuto(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkValue\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDOTSyn.FuncBack(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkValue\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDOTSyn.FuncBgcolor(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkAttribute\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDOTSyn.FuncBold(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkValue\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDOTSyn.FuncBoth(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkValue\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDOTSyn.FuncBottomlabel(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkAttribute\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDOTSyn.FuncBox(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkShape\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDOTSyn.FuncCenter(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkAttribute\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDOTSyn.FuncCircle(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkShape\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDOTSyn.FuncClusterrank(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkAttribute\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDOTSyn.FuncColor(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkAttribute\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDOTSyn.FuncComment(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkAttribute\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDOTSyn.FuncCompound(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkAttribute\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDOTSyn.FuncConcentrate(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkAttribute\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDOTSyn.FuncConstraint(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkAttribute\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDOTSyn.FuncDecorate(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkAttribute\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDOTSyn.FuncDiamond(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkShape\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDOTSyn.FuncDigraph(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDOTSyn.FuncDir(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkAttribute\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDOTSyn.FuncDistortion(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkAttribute\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDOTSyn.FuncDot(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkArrowHead\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDOTSyn.FuncDotted(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkValue\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDOTSyn.FuncDoublecircle(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkShape\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDOTSyn.FuncDoubleoctagon(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkShape\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDOTSyn.FuncE(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkValue\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDOTSyn.FuncEdge(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDOTSyn.FuncEgg(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkShape\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDOTSyn.FuncEllipse(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkShape\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDOTSyn.FuncFalse(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkValue\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDOTSyn.FuncFill(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkValue\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDOTSyn.FuncFillcolor(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkAttribute\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDOTSyn.FuncFilled(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkValue  // TODO: ANSI source isn't clear if tkValue or tkAttribute\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDOTSyn.FuncFixedsize(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkAttribute\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDOTSyn.FuncFontcolor(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkAttribute\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDOTSyn.FuncFontname(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkAttribute\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDOTSyn.FuncFontpath(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkAttribute\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDOTSyn.FuncFontsize(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkAttribute\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDOTSyn.FuncForward(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkValue\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDOTSyn.FuncGlobal(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkValue\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDOTSyn.FuncGraph(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDOTSyn.FuncGroup(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkAttribute\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDOTSyn.FuncHeadlabel(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkAttribute\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDOTSyn.FuncHeadport(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkAttribute\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDOTSyn.FuncHeadurl(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkAttribute\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDOTSyn.FuncHeight(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkAttribute\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDOTSyn.FuncHexagon(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkShape\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDOTSyn.FuncHouse(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkShape\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDOTSyn.FuncId(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDOTSyn.FuncInv(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkArrowHead\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDOTSyn.FuncInvdot(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkArrowHead\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDOTSyn.FuncInvhouse(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkShape\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDOTSyn.FuncInvodot(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkArrowHead\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDOTSyn.FuncInvtrapezium(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkShape\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDOTSyn.FuncInvtriangle(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkShape\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDOTSyn.FuncLabel(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkAttribute\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDOTSyn.FuncLabelangle(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkAttribute\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDOTSyn.FuncLabeldistance(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkAttribute\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDOTSyn.FuncLabelfloat(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkAttribute\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDOTSyn.FuncLabelfontcolor(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkAttribute\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDOTSyn.FuncLabelfontname(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkAttribute\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDOTSyn.FuncLabelfontsize(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkAttribute\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDOTSyn.FuncLabeljust(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkAttribute\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDOTSyn.FuncLabelloc(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkAttribute\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDOTSyn.FuncLayer(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkAttribute  // TODO: ANSI source isn't clear if tkAttribute or tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDOTSyn.FuncLayers(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkAttribute  // TODO: ANSI source isn't clear if tkAttribute or tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDOTSyn.FuncLhead(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkAttribute\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDOTSyn.FuncLtail(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkAttribute\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDOTSyn.FuncMargin(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkAttribute\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDOTSyn.FuncMax(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkValue\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDOTSyn.FuncMcircle(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkShape\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDOTSyn.FuncMclimit(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkAttribute\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDOTSyn.FuncMdiamond(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkShape\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDOTSyn.FuncMerged(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkAttribute\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDOTSyn.FuncMin(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkValue\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDOTSyn.FuncMinimum(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkAttribute\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDOTSyn.FuncMinlen(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkAttribute\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDOTSyn.FuncMrecord(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkShape\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDOTSyn.FuncMsquare(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkShape\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDOTSyn.FuncMultiples(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkAttribute\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDOTSyn.FuncN(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkValue\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDOTSyn.FuncNe(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkValue\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDOTSyn.FuncNode(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDOTSyn.FuncNodesep(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkAttribute\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDOTSyn.FuncNone(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkValue\r\n  else if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkArrowHead\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDOTSyn.FuncNormal(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkArrowHead\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDOTSyn.FuncNslimit(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkAttribute\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDOTSyn.FuncNw(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkValue\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDOTSyn.FuncOctagon(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkShape\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDOTSyn.FuncOdot(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkArrowHead\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDOTSyn.FuncOnto(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkAttribute\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDOTSyn.FuncOrdering(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkAttribute\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDOTSyn.FuncOrientation(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkAttribute\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDOTSyn.FuncPage(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkAttribute\r\n  else if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkValue\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDOTSyn.FuncPagedir(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkAttribute\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDOTSyn.FuncParallelogram(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkShape\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDOTSyn.FuncPeripheries(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkAttribute\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDOTSyn.FuncPlaintext(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkShape\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDOTSyn.FuncPoint(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkShape\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDOTSyn.FuncPolygon(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkShape\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDOTSyn.FuncQuantum(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkAttribute\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDOTSyn.FuncRank(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkAttribute\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDOTSyn.FuncRankdir(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkAttribute\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDOTSyn.FuncRanksep(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkAttribute\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDOTSyn.FuncRatio(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkAttribute\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDOTSyn.FuncRecord(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkShape\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDOTSyn.FuncRegular(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkAttribute\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDOTSyn.FuncRemincross(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkAttribute\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDOTSyn.FuncRotate(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkAttribute\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDOTSyn.FuncS(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkValue\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDOTSyn.FuncSame(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkValue\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDOTSyn.FuncSamehead(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkAttribute\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDOTSyn.FuncSametail(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkAttribute\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDOTSyn.FuncSamplepoints(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkAttribute\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDOTSyn.FuncSe(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkValue\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDOTSyn.FuncSearchsize(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkAttribute\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDOTSyn.FuncSection(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkAttribute\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDOTSyn.FuncShape(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkAttribute\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDOTSyn.FuncShapefile(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkAttribute\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDOTSyn.FuncSides(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkAttribute\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDOTSyn.FuncSink(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkValue\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDOTSyn.FuncSize(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkAttribute\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDOTSyn.FuncSkew(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkAttribute\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDOTSyn.FuncSource(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkValue\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDOTSyn.FuncStrict(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDOTSyn.FuncStyle(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkAttribute\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDOTSyn.FuncSubgraph(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDOTSyn.FuncSw(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkValue\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDOTSyn.FuncTaillabel(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkAttribute\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDOTSyn.FuncTailport(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkAttribute\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDOTSyn.FuncTailurl(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkAttribute\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDOTSyn.FuncToplabel(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkAttribute\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDOTSyn.FuncTrapezium(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkShape\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDOTSyn.FuncTriangle(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkShape\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDOTSyn.FuncTripleoctagon(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkShape\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDOTSyn.FuncTrue(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkValue\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDOTSyn.FuncUrl(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkAttribute\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDOTSyn.FuncW(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkValue\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDOTSyn.FuncWeight(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkAttribute\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDOTSyn.FuncWhen(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkAttribute\r\n  else if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkAttribute\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDOTSyn.FuncWidth(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkAttribute\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDOTSyn.FuncZ(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkAttribute\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nprocedure TSynDOTSyn.SpaceProc;\r\nbegin\r\n  inc(Run);\r\n  fTokenID := tkSpace;\r\n  while (FLine[Run] <= #32) and not IsLineEnd(Run) do inc(Run);\r\nend;\r\n\r\nprocedure TSynDOTSyn.NullProc;\r\nbegin\r\n  fTokenID := tkNull;\r\n  inc(Run);\r\nend;\r\n\r\nprocedure TSynDOTSyn.CRProc;\r\nbegin\r\n  fTokenID := tkSpace;\r\n  inc(Run);\r\n  if fLine[Run] = #10 then\r\n    inc(Run);\r\nend;\r\n\r\nprocedure TSynDOTSyn.LFProc;\r\nbegin\r\n  fTokenID := tkSpace;\r\n  inc(Run);\r\nend;\r\n\r\nprocedure TSynDOTSyn.DirectionsProc;\r\nbegin\r\n  Inc(Run);\r\n  if (fLine[Run] = '>') or (fLine[Run] = '-') then\r\n  begin\r\n    fTokenID := tkDirections;\r\n    inc(Run);\r\n  end\r\n  else\r\n    fTokenID := tkSymbol;\r\nend;\r\n\r\nprocedure TSynDOTSyn.CStyleCommentOpenProc;\r\nbegin\r\n  Inc(Run);\r\n  if fLine[Run] = '/' then\r\n  begin\r\n    fTokenID := tkComment;\r\n    inc(Run, 2);\r\n    while not IsLineEnd(Run) do Inc(Run);\r\n    Exit;\r\n  end;\r\n  if fLine[Run] = '*' then\r\n  begin\r\n    fRange := rsCStyleComment;\r\n    CStyleCommentProc;\r\n    fTokenID := tkComment;\r\n  end\r\n  else\r\n    fTokenID := tkIdentifier;\r\nend;\r\n\r\nprocedure TSynDOTSyn.CStyleCommentProc;\r\nbegin\r\n  case fLine[Run] of\r\n     #0: NullProc;\r\n    #10: LFProc;\r\n    #13: CRProc;\r\n    else\r\n    begin\r\n      fTokenID := tkComment;\r\n      repeat\r\n        if (fLine[Run] = '*') and (fLine[Run + 1] = '/') then\r\n        begin\r\n          Inc(Run, 2);\r\n          fRange := rsUnKnown;\r\n          Break;\r\n        end;\r\n        if not IsLineEnd(Run) then\r\n          Inc(Run);\r\n      until IsLineEnd(Run);\r\n    end;\r\n  end;\r\nend;\r\n\r\nprocedure TSynDOTSyn.StringOpenProc;\r\nbegin\r\n  Inc(Run);\r\n  fRange := rsString;\r\n  StringProc;\r\n  fTokenID := tkString;\r\nend;\r\n\r\nprocedure TSynDOTSyn.StringProc;\r\nbegin\r\n  fTokenID := tkString;\r\n  repeat\r\n    if fLine[Run] = '''' then\r\n    begin\r\n      Inc(Run, 1);\r\n      fRange := rsUnKnown;\r\n      Break;\r\n    end;\r\n    if not IsLineEnd(Run) then\r\n      Inc(Run);\r\n  until IsLineEnd(Run);\r\nend;\r\n\r\nconstructor TSynDOTSyn.Create(AOwner: TComponent);\r\nbegin\r\n  inherited Create(AOwner);\r\n\r\n  fCaseSensitive := False;\r\n\r\n  fArrowHeadAttri := TSynHighLighterAttributes.Create(SYNS_AttrArrowHead, SYNS_FriendlyAttrArrowHead);\r\n  fArrowHeadAttri.Foreground := clRed;\r\n  AddAttribute(fArrowHeadAttri);\r\n\r\n  fAttributeAttri := TSynHighLighterAttributes.Create(SYNS_AttrAttribute, SYNS_FriendlyAttrAttribute);\r\n  AddAttribute(fAttributeAttri);\r\n\r\n  fCommentAttri := TSynHighLighterAttributes.Create(SYNS_AttrComment, SYNS_FriendlyAttrComment);\r\n  fCommentAttri.Style := [fsItalic];\r\n  fCommentAttri.Foreground := clNavy;\r\n  AddAttribute(fCommentAttri);\r\n\r\n  fDirectionsAttri := TSynHighLighterAttributes.Create(SYNS_AttrDirections, SYNS_FriendlyAttrDirections);\r\n  fDirectionsAttri.Style := [fsBold];\r\n  fDirectionsAttri.Foreground := clYellow;\r\n  AddAttribute(fDirectionsAttri);\r\n\r\n  fIdentifierAttri := TSynHighLighterAttributes.Create(SYNS_AttrIdentifier, SYNS_FriendlyAttrIdentifier);\r\n  AddAttribute(fIdentifierAttri);\r\n\r\n  fKeyAttri := TSynHighLighterAttributes.Create(SYNS_AttrReservedWord, SYNS_FriendlyAttrReservedWord);\r\n  fKeyAttri.Style := [fsBold];\r\n  AddAttribute(fKeyAttri);\r\n\r\n  fShapeAttri := TSynHighLighterAttributes.Create(SYNS_AttrShape, SYNS_FriendlyAttrShape);\r\n  fShapeAttri.Style := [fsBold];\r\n  fShapeAttri.Foreground := clRed;\r\n  AddAttribute(fShapeAttri);\r\n\r\n  fSpaceAttri := TSynHighLighterAttributes.Create(SYNS_AttrSpace, SYNS_FriendlyAttrSpace);\r\n  AddAttribute(fSpaceAttri);\r\n\r\n  fStringAttri := TSynHighLighterAttributes.Create(SYNS_AttrString, SYNS_FriendlyAttrString);\r\n  AddAttribute(fStringAttri);\r\n\r\n  fValueAttri := TSynHighLighterAttributes.Create(SYNS_AttrValue, SYNS_FriendlyAttrValue);\r\n  fValueAttri.Style := [fsItalic];\r\n  fValueAttri.Foreground := clRed;\r\n  AddAttribute(fValueAttri);\r\n\r\n  fSymbolAttri := TSynHighlighterAttributes.Create(SYNS_AttrSymbol, SYNS_FriendlyAttrSymbol);\r\n  fSymbolAttri.Style := [fsBold];\r\n  fSymbolAttri.Foreground := clGreen;\r\n  AddAttribute(fSymbolAttri);\r\n\r\n  SetAttributesOnChange(DefHighlightChange);\r\n  InitIdent;\r\n  fDefaultFilter := SYNS_FilterDOT;\r\n  fRange := rsUnknown;\r\nend;\r\n\r\nprocedure TSynDOTSyn.IdentProc;\r\nbegin\r\n  fTokenID := IdentKind((fLine + Run));\r\n  inc(Run, fStringLen);\r\n  while IsIdentChar(fLine[Run]) do\r\n    Inc(Run);\r\nend;\r\n\r\nprocedure TSynDOTSyn.UnknownProc;\r\nbegin\r\n  inc(Run);\r\n  fTokenID := tkUnknown;\r\nend;\r\n\r\nprocedure TSynDOTSyn.SymbolProc;\r\nbegin\r\n  inc(Run);\r\n  fTokenId := tkSymbol;\r\nend;\r\n\r\nprocedure TSynDOTSyn.Next;\r\nbegin\r\n  fTokenPos := Run;\r\n  case fRange of\r\n    rsCStyleComment: CStyleCommentProc;\r\n  else\r\n    begin\r\n      fRange := rsUnknown;\r\n      case fLine[Run] of\r\n        #0: NullProc;\r\n        #10: LFProc;\r\n        #13: CRProc;\r\n        '/': CStyleCommentOpenProc;\r\n        '-': DirectionsProc;\r\n        '''': StringOpenProc;\r\n        #1..#9, #11, #12, #14..#32: SpaceProc;\r\n        'A'..'Z', 'a'..'z', '_': IdentProc;\r\n        '~', '{', '}', ',', '(', ')', '[', ']', '<', '>', ':', '?', ';', '!', '=': SymbolProc;\r\n        else UnknownProc;\r\n      end;\r\n    end;\r\n  end;\r\n  inherited;\r\nend;\r\n\r\nfunction TSynDOTSyn.GetDefaultAttribute(Index: integer): TSynHighLighterAttributes;\r\nbegin\r\n  case Index of\r\n    SYN_ATTR_COMMENT: Result := fCommentAttri;\r\n    SYN_ATTR_IDENTIFIER: Result := fIdentifierAttri;\r\n    SYN_ATTR_KEYWORD: Result := fKeyAttri;\r\n    SYN_ATTR_STRING: Result := fStringAttri;\r\n    SYN_ATTR_WHITESPACE: Result := fSpaceAttri;\r\n    SYN_ATTR_SYMBOL: Result := fSymbolAttri;\r\n  else\r\n    Result := nil;\r\n  end;\r\nend;\r\n\r\nfunction TSynDOTSyn.GetEol: Boolean;\r\nbegin\r\n  Result := Run = fLineLen + 1;\r\nend;\r\n\r\nfunction TSynDOTSyn.GetKeyWords(TokenKind: Integer): UnicodeString;\r\nbegin\r\n  Result :=\r\n    '--,->,all,appendix,arrowhead,arrowsize,arrowtail,auto,back,bgcolor,bo' +\r\n    'ld,both,bottomlabel,box,center,circle,clusterrank,color,comment,compou' +\r\n    'nd,concentrate,constraint,decorate,diamond,digraph,dir,distortion,dot,' +\r\n    'dotted,doublecircle,doubleoctagon,e,edge,egg,ellipse,false,fill,fillco' +\r\n    'lor,filled,fixedsize,fontcolor,fontname,fontpath,fontsize,forward,glob' +\r\n    'al,graph,group,headlabel,headport,headURL,height,hexagon,house,id,inv,' +\r\n    'invdot,invhouse,invodot,invtrapezium,invtriangle,label,labelangle,labe' +\r\n    'ldistance,labelfloat,labelfontcolor,labelfontname,labelfontsize,labelj' +\r\n    'ust,labelloc,layer,layers,lhead,ltail,margin,max,mcircle,mclimit,mdiam' +\r\n    'ond,merged,min,minimum,minlen,mrecord,msquare,multiples,n,ne,node,node' +\r\n    'sep,none,normal,nslimit,nw,octagon,odot,onto,ordering,orientation,page' +\r\n    ',pagedir,parallelogram,peripheries,plaintext,point,polygon,quantum,ran' +\r\n    'k,rankdir,ranksep,ratio,record,regular,remincross,rotate,s,same,samehe' +\r\n    'ad,sametail,samplepoints,se,searchsize,section,shape,shapefile,sides,s' +\r\n    'ink,size,skew,source,strict,style,subgraph,sw,taillabel,tailport,tailU' +\r\n    'RL,toplabel,trapezium,triangle,tripleoctagon,true,url,w,weight,when,wi' +\r\n    'dth,z';\r\nend;\r\n\r\nfunction TSynDOTSyn.GetTokenID: TtkTokenKind;\r\nbegin\r\n  Result := fTokenId;\r\nend;\r\n\r\nfunction TSynDOTSyn.GetTokenAttribute: TSynHighLighterAttributes;\r\nbegin\r\n  case GetTokenID of\r\n    tkArrowHead: Result := fArrowHeadAttri;\r\n    tkAttribute: Result := fAttributeAttri;\r\n    tkComment: Result := fCommentAttri;\r\n    tkDirections: Result := fDirectionsAttri;\r\n    tkIdentifier: Result := fIdentifierAttri;\r\n    tkKey: Result := fKeyAttri;\r\n    tkShape: Result := fShapeAttri;\r\n    tkSpace: Result := fSpaceAttri;\r\n    tkString: Result := fStringAttri;\r\n    tkValue: Result := fValueAttri;\r\n    tkUnknown: Result := fIdentifierAttri;\r\n    tkSymbol: Result := fSymbolAttri;\r\n  else\r\n    Result := nil;\r\n  end;\r\nend;\r\n\r\nfunction TSynDOTSyn.GetTokenKind: integer;\r\nbegin\r\n  Result := Ord(fTokenId);\r\nend;\r\n\r\nfunction TSynDOTSyn.GetSampleSource: UnicodeString;\r\nbegin\r\n  Result :=\r\n    '// ATT DOT Graphic description language'#13#10 +\r\n    'digraph asde91 {'#13#10 +\r\n    '  ranksep=.75; size = \"7.5,7.5\";'#13#10 +\r\n    '  {'#13#10 +\r\n    '      node [shape=plaintext, fontsize=16];'#13#10 +\r\n    '      /* the time-line graph */'#13#10 +\r\n    '      past -> 1978 -> 1980 -> 1982 -> 1983 -> 1985 -> 1986 ->'#13#10 +\r\n    '      1987 -> 1988 -> 1989 -> 1990 -> \"future\";'#13#10 +\r\n    '      /* ancestor programs */'#13#10 +\r\n    '      \"Bourne sh\"; \"make\"; \"SCCS\"; \"yacc\"; \"cron\"; \"Reiser cpp\";'#13#10 +\r\n    '      \"Cshell\"; \"emacs\"; \"build\"; \"vi\"; \"\"; \"RCS\"; \"C*\";'#13#10 +\r\n    '  }'#13#10 +\r\n    '      { rank = same;'#13#10 +\r\n    '      \"Software IS\"; \"Configuration Mgt\"; \"Architecture & Libraries\";'#13#10 +\r\n    '      \"Process\";'#13#10 +\r\n    '  };'#13#10 +\r\n    '    node [shape=box];'#13#10 +\r\n    '    { rank = same; \"past\"; \"SCCS\"; \"make\"; \"Bourne sh\"; \"yacc\"; \"cron\"; }'#13#10 +\r\n    '    { rank = same; 1978; \"Reiser cpp\"; \"Cshell\"; }'#13#10 +\r\n    '    { rank = same; 1980; \"build\"; \"emacs\"; \"vi\"; }'#13#10 +\r\n    '    { rank = same; 1982; \"RCS\"; \"\"; \"IMX\"; \"SYNED\"; }'#13#10 +\r\n    '    { rank = same; 1983; \"ksh\"; \"IFS\"; \"TTU\"; }'#13#10 +\r\n    '    { rank = same; 1985; \"nmake\"; \"Peggy\"; }'#13#10 +\r\n    '    { rank = same; 1986; \"C*\"; \"ncpp\"; \"ksh-i\"; \"\"; \"PG2\"; }'#13#10 +\r\n    '    { rank = same; 1987; \"Ansi cpp\"; \"nmake 2.0\"; \"3D File System\"; \"fdelta\";'#13#10 +\r\n    '        \"DAG\"; \"CSAS\";}'#13#10 +\r\n    '    { rank = same; 1988; \"CIA\"; \"SBCS\"; \"ksh-88\"; \"PEGASUS/PML\"; \"PAX\";'#13#10 +\r\n    '        \"backtalk\"; }'#13#10 +\r\n    '    { rank = same; 1989; \"CIA++\"; \"APP\"; \"SHIP\"; \"DataShare\"; \"ryacc\";'#13#10 +\r\n    '        \"Mosaic\"; }'#13#10 +\r\n    '    { rank = same; 1990; \"libft\"; \"CoShell\"; \"DIA\"; \"IFS-i\"; \"kyacc\"; \"sfio\";'#13#10 +\r\n    '        \"yeast\"; \"ML-X\"; \"DOT\"; }'#13#10 +\r\n    '    { rank = same; \"future\"; \"Adv. Software Technology\"; }'#13#10 +\r\n    '    \"PEGASUS/PML\" -> \"ML-X\";'#13#10 +\r\n    '    \"SCCS\" -> \"nmake\";'#13#10 +\r\n    '    \"SCCS\" -> \"3D File System\";'#13#10 +\r\n    '    \"SCCS\" -> \"RCS\";'#13#10 +\r\n    '    \"make\" -> \"nmake\";'#13#10 +\r\n    '    \"make\" -> \"build\";'#13#10 +\r\n    '}';\r\nend;\r\n\r\nfunction TSynDOTSyn.IsFilterStored: Boolean;\r\nbegin\r\n  Result := fDefaultFilter <> SYNS_FilterDOT;\r\nend;\r\n\r\nfunction TSynDOTSyn.IsIdentChar(AChar: WideChar): Boolean;\r\nbegin\r\n  case AChar of\r\n    '_', 'A'..'Z', 'a'..'z':\r\n      Result := True;\r\n    else\r\n      Result := False;\r\n  end;\r\nend;\r\n\r\nclass function TSynDOTSyn.GetLanguageName: string;\r\nbegin\r\n  Result := SYNS_LangDOT;\r\nend;\r\n\r\nprocedure TSynDOTSyn.ResetRange;\r\nbegin\r\n  fRange := rsUnknown;\r\nend;\r\n\r\nprocedure TSynDOTSyn.SetRange(Value: Pointer);\r\nbegin\r\n  fRange := TRangeState(Value);\r\nend;\r\n\r\nfunction TSynDOTSyn.GetRange: Pointer;\r\nbegin\r\n  Result := Pointer(fRange);\r\nend;\r\n\r\nclass function TSynDOTSyn.GetFriendlyLanguageName: UnicodeString;\r\nbegin\r\n  Result := SYNS_FriendlyLangDOT;\r\nend;\r\n\r\ninitialization\r\n{$IFNDEF SYN_CPPB_1}\r\n  RegisterPlaceableHighlighter(TSynDOTSyn);\r\n{$ENDIF}\r\nend.\r\n"
  },
  {
    "path": "External/SynEdit/Source/SynHighlighterDWS.pas",
    "content": "{------------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: SynHighlighterPas.pas, released 2000-04-17.\r\nThe Original Code is based on the mwPasSyn.pas file from the\r\nmwEdit component suite by Martin Waldenburg and other developers, the Initial\r\nAuthor of this file is Martin Waldenburg.\r\nPortions created by Martin Waldenburg are Copyright (C) 1998 Martin Waldenburg.\r\nAll Rights Reserved.\r\n\r\nContributors to the SynEdit and mwEdit projects are listed in the\r\nContributors.txt file.\r\n\r\nAlternatively, the contents of this file may be used under the terms of the\r\nGNU General Public License Version 2 or later (the \"GPL\"), in which case\r\nthe provisions of the GPL are applicable instead of those above.\r\nIf you wish to allow use of your version of this file only under the terms\r\nof the GPL and not to allow others to use your version of this file\r\nunder the MPL, indicate your decision by deleting the provisions above and\r\nreplace them with the notice and other provisions required by the GPL.\r\nIf you do not delete the provisions above, a recipient may use your version\r\nof this file under either the MPL or the GPL.\r\n\r\n$Id: SynHighlighterDWS.pas,v 1.11 2011/12/28 09:24:20 Egg Exp $\r\n\r\nYou may retrieve the latest version of this file at the SynEdit home page,\r\nlocated at http://SynEdit.SourceForge.net\r\n\r\nKnown Issues:\r\n-------------------------------------------------------------------------------}\r\n{\r\n@abstract(Provides a DWScript syntax highlighter for SynEdit)\r\n}\r\n\r\nunit SynHighlighterDWS;\r\n\r\n{$I SynEdit.inc}\r\n\r\ninterface\r\n\r\nuses\r\n  Windows,\r\n  Graphics,\r\n  SynEditTypes,\r\n  SynEditHighlighter,\r\n  SysUtils,\r\n  Classes,\r\n  Character;\r\n\r\ntype\r\n  TtkTokenKind = (tkAsm, tkComment, tkIdentifier, tkKey, tkNull, tkNumber,\r\n    tkSpace, tkString, tkSymbol, tkUnknown, tkFloat, tkHex, tkDirec, tkChar);\r\n\r\n  TRangeState = (rsANil, rsAnsi, rsAnsiAsm, rsAsm, rsBor, rsBorAsm, rsProperty,\r\n    rsExports, rsDirective, rsDirectiveAsm, rsHereDocSingle, rsHereDocDouble, rsUnKnown);\r\n\r\n  PIdentFuncTableFunc = ^TIdentFuncTableFunc;\r\n  TIdentFuncTableFunc = function : TtkTokenKind of object;\r\n\r\ntype\r\n   TAnsiStringList = class(TStringList)\r\n     function CompareStrings(const S1, S2: string): Integer; override;\r\n   end;\r\n\r\ntype\r\n  TSynDWSSyn = class(TSynCustomHighlighter)\r\n  private\r\n    fAsmStart: Boolean;\r\n    fRange: TRangeState;\r\n    fCommentClose : Char;\r\n    fIdentFuncTable: array[0..388] of TIdentFuncTableFunc;\r\n    fKeyWords : TAnsiStringList;\r\n    fKeyWords_PropertyScoped : TAnsiStringList;\r\n    fTokenID: TtkTokenKind;\r\n    fStringAttri: TSynHighlighterAttributes;\r\n    fCharAttri: TSynHighlighterAttributes;\r\n    fNumberAttri: TSynHighlighterAttributes;\r\n    fFloatAttri: TSynHighlighterAttributes;\r\n    fHexAttri: TSynHighlighterAttributes;\r\n    fKeyAttri: TSynHighlighterAttributes;\r\n    fSymbolAttri: TSynHighlighterAttributes;\r\n    fAsmAttri: TSynHighlighterAttributes;\r\n    fCommentAttri: TSynHighlighterAttributes;\r\n    fDirecAttri: TSynHighlighterAttributes;\r\n    fIdentifierAttri: TSynHighlighterAttributes;\r\n    fSpaceAttri: TSynHighlighterAttributes;\r\n    function AltFunc: TtkTokenKind;\r\n    function KeyWordFunc: TtkTokenKind;\r\n    function FuncAsm: TtkTokenKind;\r\n    function FuncEnd: TtkTokenKind;\r\n    function FuncPropertyScoped: TtkTokenKind;\r\n    function FuncProperty: TtkTokenKind;\r\n    function HashKey(Str: PWideChar): Cardinal;\r\n    function IdentKind(MayBe: PWideChar): TtkTokenKind;\r\n    procedure InitIdent;\r\n    procedure AddressOpProc;\r\n    procedure AsciiCharProc;\r\n    procedure AnsiProc;\r\n    procedure BorProc;\r\n    procedure BraceOpenProc;\r\n    procedure ColonOrGreaterProc;\r\n    procedure CRProc;\r\n    procedure IdentProc;\r\n    procedure IntegerProc;\r\n    procedure LFProc;\r\n    procedure LowerProc;\r\n    procedure NullProc;\r\n    procedure NumberProc;\r\n    procedure PointProc;\r\n    procedure RoundOpenProc;\r\n    procedure SemicolonProc;\r\n    procedure SlashProc;\r\n    procedure SpaceProc;\r\n    procedure StringAposProc;\r\n    procedure StringAposMultiProc;\r\n    procedure StringQuoteProc;\r\n    procedure SymbolProc;\r\n    procedure UnknownProc;\r\n  protected\r\n    function GetSampleSource: UnicodeString; override;\r\n    function IsFilterStored: Boolean; override;\r\n    function IsCurrentToken(const Token: UnicodeString): Boolean; override;\r\n\r\n  public\r\n    class function GetCapabilities: TSynHighlighterCapabilities; override;\r\n    class function GetLanguageName: string; override;\r\n    class function GetFriendlyLanguageName: UnicodeString; override;\r\n\r\n  public\r\n    constructor Create(AOwner: TComponent); override;\r\n    destructor Destroy; override;\r\n\r\n    function GetDefaultAttribute(Index: Integer): TSynHighlighterAttributes; override;\r\n    function GetEol: Boolean; override;\r\n    function GetRange: Pointer; override;\r\n    function GetTokenAttribute: TSynHighlighterAttributes; override;\r\n    function GetTokenID: TtkTokenKind;\r\n    function GetTokenKind: Integer; override;\r\n    procedure Next; override;\r\n    procedure ResetRange; override;\r\n    procedure SetRange(Value: Pointer); override;\r\n    function IsIdentChar(AChar: WideChar): Boolean; override;\r\n\r\n    procedure LoadDelphiStyle; virtual;\r\n    // ^^^\r\n    // This routine can be called to install a Delphi style of colors\r\n    // and highlighting. It modifies the basic TSynDWSSyn to reproduce\r\n    // the most recent Delphi editor highlighting.\r\n\r\n  published\r\n    property AsmAttri: TSynHighlighterAttributes read fAsmAttri write fAsmAttri;\r\n    property CommentAttri: TSynHighlighterAttributes read fCommentAttri\r\n      write fCommentAttri;\r\n    property DirectiveAttri: TSynHighlighterAttributes read fDirecAttri\r\n      write fDirecAttri;\r\n    property IdentifierAttri: TSynHighlighterAttributes read fIdentifierAttri\r\n      write fIdentifierAttri;\r\n    property KeyAttri: TSynHighlighterAttributes read fKeyAttri write fKeyAttri;\r\n    property NumberAttri: TSynHighlighterAttributes read fNumberAttri\r\n      write fNumberAttri;\r\n    property FloatAttri: TSynHighlighterAttributes read fFloatAttri\r\n      write fFloatAttri;\r\n    property HexAttri: TSynHighlighterAttributes read fHexAttri\r\n      write fHexAttri;\r\n    property SpaceAttri: TSynHighlighterAttributes read fSpaceAttri\r\n      write fSpaceAttri;\r\n    property StringAttri: TSynHighlighterAttributes read fStringAttri\r\n      write fStringAttri;\r\n    property CharAttri: TSynHighlighterAttributes read fCharAttri\r\n      write fCharAttri;\r\n    property SymbolAttri: TSynHighlighterAttributes read fSymbolAttri\r\n      write fSymbolAttri;\r\n  end;\r\n\r\nimplementation\r\n\r\nuses\r\n  SynEditStrConst;\r\n\r\nconst\r\n   // if the language is case-insensitive keywords *must* be in lowercase\r\n   cKeyWords: array[1..95] of UnicodeString = (\r\n      'abstract', 'and', 'array', 'as', 'asm',\r\n      'begin', 'break', 'case', 'cdecl', 'class', 'const', 'constructor',\r\n      'contains', 'continue', 'deprecated', 'destructor',\r\n      'div', 'do', 'downto', 'else', 'end', 'ensure', 'except', 'exit',\r\n      'export', 'exports', 'external', 'final', 'finalization',\r\n      'finally', 'for', 'forward', 'function', 'helper', 'if',\r\n      'implementation', 'implements', 'implies', 'in', 'inherited',\r\n      'initialization', 'inline', 'interface', 'is', 'lambda', 'lazy', 'library',\r\n      'message', 'method', 'mod', 'new', 'nil', 'not', 'object', 'of',\r\n      'old', 'on', 'operator', 'or', 'overload', 'override',\r\n      'pascal', 'partial', 'private', 'procedure', 'program', 'property',\r\n      'protected', 'public', 'published', 'raise', 'record',\r\n      'register', 'reintroduce', 'repeat', 'require', 'resourcestring',\r\n      'sar', 'sealed', 'set', 'shl', 'shr', 'static', 'step',\r\n      'then', 'to', 'try', 'type', 'unit', 'until',\r\n      'uses', 'var', 'virtual', 'while', 'xor'\r\n  );\r\n  cKeyWords_PropertyScoped: array [0..4] of UnicodeString = (\r\n      'default', 'index', 'read', 'stored', 'write'\r\n  );\r\n\r\nfunction TAnsiStringList.CompareStrings(const S1, S2: string): Integer;\r\nbegin\r\n   Result:=CompareText(S1, S2);\r\nend;\r\n\r\nfunction TSynDWSSyn.HashKey(Str: PWideChar): Cardinal;\r\nvar\r\n   c : Word;\r\nbegin\r\n   Result:=0;\r\n   while IsIdentChar(Str^) do begin\r\n      c:=Ord(Str^);\r\n      if c in [Ord('A')..Ord('Z')] then\r\n         c := c + (Ord('a')-Ord('A'));\r\n      Result := Result * 692 + c * 171;\r\n      inc(Str);\r\n   end;\r\n   fStringLen := Str - fToIdent;\r\n   Result := Result mod Cardinal(Length(fIdentFuncTable));\r\nend;\r\n\r\nfunction TSynDWSSyn.IdentKind(MayBe: PWideChar): TtkTokenKind;\r\nvar\r\n  Key: Cardinal;\r\nbegin\r\n  fToIdent := MayBe;\r\n  Key := HashKey(MayBe);\r\n  if Key <= High(fIdentFuncTable) then\r\n    Result := fIdentFuncTable[Key]\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nprocedure TSynDWSSyn.InitIdent;\r\n\r\n   procedure SetIdentFunc(h : Integer; const func : TIdentFuncTableFunc);\r\n   begin\r\n      fIdentFuncTable[h]:=func;\r\n   end;\r\n\r\nvar\r\n  i : Integer;\r\nbegin\r\n   for i:=Low(cKeyWords) to High(cKeyWords) do begin\r\n      SetIdentFunc(HashKey(@cKeyWords[i][1]), KeyWordFunc);\r\n      fKeyWords.Add(cKeyWords[i]);\r\n   end;\r\n\r\n   for i:=0 to High(cKeyWords_PropertyScoped) do begin\r\n      SetIdentFunc(HashKey(@cKeyWords_PropertyScoped[i][1]), FuncPropertyScoped);\r\n      fKeyWords_PropertyScoped.Add(cKeyWords_PropertyScoped[i]);\r\n   end;\r\n\r\n   for i := Low(fIdentFuncTable) to High(fIdentFuncTable) do\r\n      if @fIdentFuncTable[i] = nil then\r\n         fIdentFuncTable[i] := AltFunc;\r\n\r\n   SetIdentFunc(HashKey('asm'), FuncAsm);\r\n   SetIdentFunc(HashKey('end'), FuncEnd);\r\n   SetIdentFunc(HashKey('property'), FuncProperty);\r\n\r\n   fKeyWords.Sorted:=True;\r\nend;\r\n\r\nfunction TSynDWSSyn.AltFunc: TtkTokenKind;\r\nbegin\r\n  Result := tkIdentifier\r\nend;\r\n\r\nfunction TSynDWSSyn.KeyWordFunc: TtkTokenKind;\r\nvar\r\n   buf : String;\r\nbegin\r\n   SetString(buf, fToIdent, fStringLen);\r\n   if (fKeyWords.IndexOf(buf)>=0) and (FLine[Run - 1] <> '&') then\r\n      Result := tkKey\r\n   else Result := tkIdentifier\r\nend;\r\n\r\nfunction TSynDWSSyn.FuncAsm: TtkTokenKind;\r\nbegin\r\n   if IsCurrentToken('asm') then begin\r\n      Result := tkKey;\r\n      fRange := rsAsm;\r\n      fAsmStart := True;\r\n   end else Result:=KeyWordFunc;\r\nend;\r\n\r\nfunction TSynDWSSyn.FuncEnd: TtkTokenKind;\r\nbegin\r\n   if IsCurrentToken('end') then begin\r\n      Result := tkKey;\r\n      fRange := rsUnknown;\r\n   end else Result:=KeyWordFunc;\r\nend;\r\n\r\n// FuncPropertyScoped\r\n//\r\nfunction TSynDWSSyn.FuncPropertyScoped: TtkTokenKind;\r\nvar\r\n   buf : String;\r\nbegin\r\n   SetString(buf, fToIdent, fStringLen);\r\n   if (fRange = rsProperty) and (fKeyWords_PropertyScoped.IndexOf(buf)>=0) then\r\n      Result:=tkKey\r\n   else Result:=KeyWordFunc;\r\nend;\r\n\r\nfunction TSynDWSSyn.FuncProperty: TtkTokenKind;\r\nbegin\r\n   if IsCurrentToken('property') then begin\r\n      Result := tkKey;\r\n      fRange := rsProperty;\r\n   end else Result:=KeyWordFunc;\r\nend;\r\n\r\nconstructor TSynDWSSyn.Create(AOwner: TComponent);\r\nbegin\r\n  inherited Create(AOwner);\r\n  fCaseSensitive := True; // bypass automatic lowercase, we handle it here\r\n\r\n  fAsmAttri := TSynHighlighterAttributes.Create(SYNS_AttrAssembler, SYNS_FriendlyAttrAssembler);\r\n  fAsmAttri.Foreground:=RGB(128, 0, 0);\r\n  AddAttribute(fAsmAttri);\r\n\r\n  fCommentAttri := TSynHighlighterAttributes.Create(SYNS_AttrComment, SYNS_FriendlyAttrComment);\r\n  fCommentAttri.Foreground:=clGreen;\r\n  fCommentAttri.Style:= [fsItalic];\r\n  AddAttribute(fCommentAttri);\r\n\r\n  fDirecAttri := TSynHighlighterAttributes.Create(SYNS_AttrPreprocessor, SYNS_FriendlyAttrPreprocessor);\r\n  fDirecAttri.Foreground := TColor($808000);\r\n  fDirecAttri.Style:= [fsItalic];\r\n  AddAttribute(fDirecAttri);\r\n\r\n  fIdentifierAttri := TSynHighlighterAttributes.Create(SYNS_AttrIdentifier, SYNS_FriendlyAttrIdentifier);\r\n  AddAttribute(fIdentifierAttri);\r\n\r\n  fKeyAttri := TSynHighlighterAttributes.Create(SYNS_AttrReservedWord, SYNS_FriendlyAttrReservedWord);\r\n  fKeyAttri.Style := [fsBold];\r\n  AddAttribute(fKeyAttri);\r\n\r\n  fNumberAttri := TSynHighlighterAttributes.Create(SYNS_AttrNumber, SYNS_FriendlyAttrNumber);\r\n  fNumberAttri.Foreground := clBlue;\r\n  AddAttribute(fNumberAttri);\r\n\r\n  fFloatAttri := TSynHighlighterAttributes.Create(SYNS_AttrFloat, SYNS_FriendlyAttrFloat);\r\n  fFloatAttri.Foreground := clBlue;\r\n  AddAttribute(fFloatAttri);\r\n\r\n  fHexAttri := TSynHighlighterAttributes.Create(SYNS_AttrHexadecimal, SYNS_FriendlyAttrHexadecimal);\r\n  fHexAttri.Foreground := clBlue;\r\n  AddAttribute(fHexAttri);\r\n\r\n  fSpaceAttri := TSynHighlighterAttributes.Create(SYNS_AttrSpace, SYNS_FriendlyAttrSpace);\r\n  AddAttribute(fSpaceAttri);\r\n\r\n  fStringAttri := TSynHighlighterAttributes.Create(SYNS_AttrString, SYNS_FriendlyAttrString);\r\n  fStringAttri.Foreground := clBlue;\r\n  AddAttribute(fStringAttri);\r\n\r\n  fCharAttri := TSynHighlighterAttributes.Create(SYNS_AttrCharacter, SYNS_FriendlyAttrCharacter);\r\n  fCharAttri.Foreground := clBlue;\r\n  AddAttribute(fCharAttri);\r\n\r\n  fSymbolAttri := TSynHighlighterAttributes.Create(SYNS_AttrSymbol, SYNS_FriendlyAttrSymbol);\r\n  fSymbolAttri.Foreground := clNavy;\r\n  AddAttribute(fSymbolAttri);\r\n  SetAttributesOnChange(DefHighlightChange);\r\n\r\n  fKeyWords:=TAnsiStringList.Create;\r\n  fKeyWords_PropertyScoped:=TAnsiStringList.Create;\r\n\r\n  InitIdent;\r\n  fRange := rsUnknown;\r\n  fAsmStart := False;\r\n  fDefaultFilter := SYNS_FilterDWS;\r\nend;\r\n\r\n// Destroy\r\n//\r\ndestructor TSynDWSSyn.Destroy;\r\nbegin\r\n   inherited;\r\n   fKeyWords.Free;\r\n   fKeyWords_PropertyScoped.Free;\r\nend;\r\n\r\nprocedure TSynDWSSyn.AddressOpProc;\r\nbegin\r\n  fTokenID := tkSymbol;\r\n  inc(Run);\r\n  if fLine[Run] = '@' then inc(Run);\r\nend;\r\n\r\nprocedure TSynDWSSyn.AsciiCharProc;\r\n\r\n  function IsAsciiChar: Boolean;\r\n  begin\r\n    case fLine[Run] of\r\n      '0'..'9', '$', 'A'..'F', 'a'..'f':\r\n        Result := True;\r\n      else\r\n        Result := False;\r\n    end;\r\n  end;\r\n\r\nbegin\r\n  fTokenID := tkChar;\r\n  Inc(Run);\r\n  if fLine[run]='''' then\r\n      StringAposMultiProc\r\n  else begin\r\n     while IsAsciiChar do\r\n       Inc(Run);\r\n  end;\r\nend;\r\n\r\nprocedure TSynDWSSyn.BorProc;\r\nbegin\r\n  case fLine[Run] of\r\n     #0: NullProc;\r\n    #10: LFProc;\r\n    #13: CRProc;\r\n  else\r\n    begin\r\n      if fRange in [rsDirective, rsDirectiveAsm] then\r\n        fTokenID := tkDirec\r\n      else\r\n        fTokenID := tkComment;\r\n      repeat\r\n        if fLine[Run] = '}' then\r\n        begin\r\n          Inc(Run);\r\n          if fRange in [rsBorAsm, rsDirectiveAsm] then\r\n            fRange := rsAsm\r\n          else\r\n            fRange := rsUnKnown;\r\n          break;\r\n        end;\r\n        Inc(Run);\r\n      until IsLineEnd(Run);\r\n    end;\r\n  end;\r\nend;\r\n\r\nprocedure TSynDWSSyn.BraceOpenProc;\r\nbegin\r\n  if (fLine[Run + 1] = '$') then\r\n  begin\r\n    if fRange = rsAsm then\r\n      fRange := rsDirectiveAsm\r\n    else\r\n      fRange := rsDirective;\r\n  end\r\n  else\r\n  begin\r\n    if fRange = rsAsm then\r\n      fRange := rsBorAsm\r\n    else\r\n      fRange := rsBor;\r\n  end;\r\n  BorProc;\r\nend;\r\n\r\nprocedure TSynDWSSyn.ColonOrGreaterProc;\r\nbegin\r\n  fTokenID := tkSymbol;\r\n  inc(Run);\r\n  if fLine[Run] = '=' then inc(Run);\r\nend;\r\n\r\nprocedure TSynDWSSyn.CRProc;\r\nbegin\r\n  fTokenID := tkSpace;\r\n  inc(Run);\r\n  if fLine[Run] = #10 then\r\n    Inc(Run);\r\nend;\r\n\r\nprocedure TSynDWSSyn.IdentProc;\r\nbegin\r\n  fTokenID := IdentKind(fLine + Run);\r\n  inc(Run, fStringLen);\r\n  while IsIdentChar(fLine[Run]) do\r\n    Inc(Run);\r\nend;\r\n\r\nprocedure TSynDWSSyn.IntegerProc;\r\n\r\n  function IsIntegerChar: Boolean;\r\n  begin\r\n    case fLine[Run] of\r\n      '0'..'9', 'A'..'F', 'a'..'f':\r\n        Result := True;\r\n      else\r\n        Result := False;\r\n    end;\r\n  end;\r\n\r\nbegin\r\n  inc(Run);\r\n  fTokenID := tkHex;\r\n  while IsIntegerChar do\r\n    Inc(Run);\r\nend;\r\n\r\nprocedure TSynDWSSyn.LFProc;\r\nbegin\r\n  fTokenID := tkSpace;\r\n  inc(Run);\r\nend;\r\n\r\nprocedure TSynDWSSyn.LoadDelphiStyle;\r\n\r\n\r\n   procedure AddKeyword( const AName : string );\r\n   var\r\n     I : integer;\r\n   begin\r\n     I := HashKey( @AName[1] );\r\n     fIdentFuncTable[I]:= KeyWordFunc;\r\n     fKeyWords.Add(AName);\r\n   end;\r\n\r\n   procedure RemoveKeyword( const AName : string );\r\n   var\r\n     I : integer;\r\n   begin\r\n     I := fKeyWords.IndexOf(AName);\r\n     if I <> -1 then\r\n       fKeywords.Delete( I );\r\n   end;\r\n\r\nconst\r\n  clID = clNavy;\r\n  clString = clBlue;\r\n  clComment = clGreen;\r\n  cKeywordsToAdd: array[0..0] of UnicodeString = (\r\n      'string');\r\n  cKeywordsToRemove: array[0..1] of UnicodeString = (\r\n      'break', 'exit');\r\nvar\r\n  i : integer;\r\nbegin\r\n  // This routine can be called to install a Delphi style of colors\r\n  // and highlighting. It modifies the basic TSynDWSSyn to reproduce\r\n  // the most recent Delphi editor highlighting.\r\n\r\n  // Delphi colors...\r\n  KeyAttri.Foreground := clID;\r\n  StringAttri.Foreground := clString;\r\n  CommentAttri.Foreground := clComment;\r\n\r\n  // These are keywords highlighted in Delphi but not in TSynDWSSyn ..\r\n  for i:=Low(cKeywordsToAdd) to High(cKeywordsToAdd) do\r\n    AddKeyword( cKeywordsToAdd[i] );\r\n\r\n  // These are keywords highlighted in TSynDWSSyn but not in Delphi...\r\n  for i:=Low(cKeywordsToRemove) to High(cKeywordsToRemove) do\r\n    RemoveKeyword( cKeywordsToRemove[i] );\r\nend;\r\n\r\nprocedure TSynDWSSyn.LowerProc;\r\nbegin\r\n  fTokenID := tkSymbol;\r\n  inc(Run);\r\n  if (fLine[Run] = '=') or (fLine[Run] = '>') then\r\n    Inc(Run);\r\nend;\r\n\r\nprocedure TSynDWSSyn.NullProc;\r\nbegin\r\n  fTokenID := tkNull;\r\n  inc(Run);\r\nend;\r\n\r\nprocedure TSynDWSSyn.NumberProc;\r\n\r\n  function IsNumberChar: Boolean;\r\n  begin\r\n    case fLine[Run] of\r\n      '0'..'9', '.', 'e', 'E', '-', '+':\r\n        Result := True;\r\n      else\r\n        Result := False;\r\n    end;\r\n  end;\r\n\r\nbegin\r\n  Inc(Run);\r\n  fTokenID := tkNumber;\r\n  while IsNumberChar do\r\n  begin\r\n    case fLine[Run] of\r\n      '.':\r\n        if fLine[Run + 1] = '.' then\r\n          Break\r\n        else\r\n          fTokenID := tkFloat;\r\n      'e', 'E': fTokenID := tkFloat;\r\n      '-', '+':\r\n        begin\r\n          if fTokenID <> tkFloat then // arithmetic\r\n            Break;\r\n          if (FLine[Run - 1] <> 'e') and (FLine[Run - 1] <> 'E') then\r\n            Break; //float, but it ends here\r\n        end;\r\n    end;\r\n    Inc(Run);\r\n  end;\r\nend;\r\n\r\nprocedure TSynDWSSyn.PointProc;\r\nbegin\r\n  fTokenID := tkSymbol;\r\n  inc(Run);\r\n  if (fLine[Run] = '.') or (fLine[Run - 1] = ')') then\r\n    Inc(Run);\r\nend;\r\n\r\nprocedure TSynDWSSyn.AnsiProc;\r\nbegin\r\n  case fLine[Run] of\r\n     #0: NullProc;\r\n    #10: LFProc;\r\n    #13: CRProc;\r\n  else\r\n    fTokenID := tkComment;\r\n    repeat\r\n      if (fLine[Run] = '*') and (fLine[Run + 1] = fCommentClose) then begin\r\n        Inc(Run, 2);\r\n        if fRange = rsAnsiAsm then\r\n          fRange := rsAsm\r\n        else\r\n          fRange := rsUnKnown;\r\n        break;\r\n      end;\r\n      Inc(Run);\r\n    until IsLineEnd(Run);\r\n  end;\r\nend;\r\n\r\nprocedure TSynDWSSyn.RoundOpenProc;\r\nbegin\r\n  Inc(Run);\r\n  case fLine[Run] of\r\n    '*':\r\n      begin\r\n        Inc(Run);\r\n        if fRange = rsAsm then\r\n          fRange := rsAnsiAsm\r\n        else\r\n          fRange := rsAnsi;\r\n        fTokenID := tkComment;\r\n        fCommentClose := ')';\r\n        if not IsLineEnd(Run) then\r\n          AnsiProc;\r\n      end;\r\n    '.':\r\n      begin\r\n        inc(Run);\r\n        fTokenID := tkSymbol;\r\n      end;\r\n  else\r\n    fTokenID := tkSymbol;\r\n  end;\r\nend;\r\n\r\nprocedure TSynDWSSyn.SemicolonProc;\r\nbegin\r\n  Inc(Run);\r\n  fTokenID := tkSymbol;\r\n  if fRange in [rsProperty, rsExports] then\r\n    fRange := rsUnknown;\r\nend;\r\n\r\nprocedure TSynDWSSyn.SlashProc;\r\nbegin\r\n  Inc(Run);\r\n  case fLine[Run] of\r\n    '/': begin\r\n      fTokenID := tkComment;\r\n      repeat\r\n        Inc(Run);\r\n      until IsLineEnd(Run);\r\n    end;\r\n    '*':\r\n      begin\r\n        Inc(Run);\r\n        if fRange = rsAsm then\r\n          fRange := rsAnsiAsm\r\n        else\r\n          fRange := rsAnsi;\r\n        fTokenID := tkComment;\r\n        fCommentClose := '/';\r\n        if not IsLineEnd(Run) then\r\n          AnsiProc;\r\n      end;\r\n  else\r\n    fTokenID := tkSymbol;\r\n  end;\r\nend;\r\n\r\nprocedure TSynDWSSyn.SpaceProc;\r\nbegin\r\n  inc(Run);\r\n  fTokenID := tkSpace;\r\n  while (FLine[Run] <= #32) and not IsLineEnd(Run) do inc(Run);\r\nend;\r\n\r\nprocedure TSynDWSSyn.StringAposProc;\r\nbegin\r\n  fTokenID := tkString;\r\n  Inc(Run);\r\n  while not IsLineEnd(Run) do\r\n  begin\r\n    if fLine[Run] = #39 then begin\r\n      Inc(Run);\r\n      if fLine[Run] <> #39 then\r\n        break;\r\n    end;\r\n    Inc(Run);\r\n  end;\r\nend;\r\n\r\nprocedure TSynDWSSyn.StringAposMultiProc;\r\nbegin\r\n  fTokenID := tkString;\r\n  Inc(Run);\r\n  fRange := rsHereDocSingle;\r\n  while not IsLineEnd(Run) do\r\n  begin\r\n    if fLine[Run] = '''' then begin\r\n      Inc(Run);\r\n      if fLine[Run] <> '''' then\r\n        fRange := rsUnknown;\r\n        break;\r\n    end;\r\n    Inc(Run);\r\n  end;\r\nend;\r\n\r\nprocedure TSynDWSSyn.StringQuoteProc;\r\nbegin\r\n  fTokenID := tkString;\r\n  Inc(Run);\r\n  fRange := rsHereDocDouble;\r\n  while not IsLineEnd(Run) do\r\n  begin\r\n    if fLine[Run] = '\"' then begin\r\n      Inc(Run);\r\n      if fLine[Run] <> '\"' then\r\n        fRange := rsUnknown;\r\n        break;\r\n    end;\r\n    Inc(Run);\r\n  end;\r\nend;\r\n\r\nprocedure TSynDWSSyn.SymbolProc;\r\nbegin\r\n  inc(Run);\r\n  fTokenID := tkSymbol;\r\nend;\r\n\r\nprocedure TSynDWSSyn.UnknownProc;\r\nbegin\r\n  inc(Run);\r\n  fTokenID := tkUnknown;\r\nend;\r\n\r\nprocedure TSynDWSSyn.Next;\r\nbegin\r\n   fAsmStart := False;\r\n   fTokenPos := Run;\r\n   case fRange of\r\n      rsAnsi, rsAnsiAsm:\r\n         AnsiProc;\r\n      rsBor, rsBorAsm, rsDirective, rsDirectiveAsm:\r\n         BorProc;\r\n      rsHereDocSingle:\r\n         StringAposMultiProc;\r\n      rsHereDocDouble:\r\n         StringQuoteProc;\r\n   else\r\n      case fLine[Run] of\r\n         #0: NullProc;\r\n         #10: LFProc;\r\n         #13: CRProc;\r\n         #1..#9, #11, #12, #14..#32: SpaceProc;\r\n         '#': AsciiCharProc;\r\n         '$': IntegerProc;\r\n         #39: StringAposProc;\r\n         '\"': StringQuoteProc;\r\n         '0'..'9': NumberProc;\r\n         'A'..'Z', 'a'..'z', '_': IdentProc;\r\n         '{': BraceOpenProc;\r\n         '}', '!', '%', '&', '('..'/', ':'..'@', '['..'^', '`', '~': begin\r\n            case fLine[Run] of\r\n               '(': RoundOpenProc;\r\n               '.': PointProc;\r\n               ';': SemicolonProc;\r\n               '/': SlashProc;\r\n               ':', '>': ColonOrGreaterProc;\r\n               '<': LowerProc;\r\n               '@': AddressOpProc;\r\n            else\r\n               SymbolProc;\r\n            end;\r\n         end;\r\n         #$0080..#$FFFF :\r\n            if {$IFDEF SYN_COMPILER_18_UP}Char(fLine[Run]).IsLetterOrDigit{$ELSE}TCharacter.IsLetterOrDigit(fLine[Run]){$ENDIF} then\r\n               IdentProc\r\n            else UnknownProc;\r\n      else\r\n         UnknownProc;\r\n      end;\r\n   end;\r\n   inherited;\r\nend;\r\n\r\nfunction TSynDWSSyn.GetDefaultAttribute(Index: Integer):\r\n  TSynHighlighterAttributes;\r\nbegin\r\n  case Index of\r\n    SYN_ATTR_COMMENT: Result := fCommentAttri;\r\n    SYN_ATTR_IDENTIFIER: Result := fIdentifierAttri;\r\n    SYN_ATTR_KEYWORD: Result := fKeyAttri;\r\n    SYN_ATTR_STRING: Result := fStringAttri;\r\n    SYN_ATTR_WHITESPACE: Result := fSpaceAttri;\r\n    SYN_ATTR_SYMBOL: Result := fSymbolAttri;\r\n  else\r\n    Result := nil;\r\n  end;\r\nend;\r\n\r\nfunction TSynDWSSyn.GetEol: Boolean;\r\nbegin\r\n  Result := Run = fLineLen + 1;\r\nend;\r\n\r\nfunction TSynDWSSyn.GetTokenID: TtkTokenKind;\r\nbegin\r\n  if not fAsmStart and (fRange = rsAsm)\r\n    and not (fTokenId in [tkNull, tkComment, tkDirec, tkSpace])\r\n  then\r\n    Result := tkAsm\r\n  else\r\n    Result := fTokenId;\r\nend;\r\n\r\nfunction TSynDWSSyn.GetTokenAttribute: TSynHighlighterAttributes;\r\nbegin\r\n  case GetTokenID of\r\n    tkAsm: Result := fAsmAttri;\r\n    tkComment: Result := fCommentAttri;\r\n    tkDirec: Result := fDirecAttri;\r\n    tkIdentifier: Result := fIdentifierAttri;\r\n    tkKey: Result := fKeyAttri;\r\n    tkNumber: Result := fNumberAttri;\r\n    tkFloat: Result := fFloatAttri;\r\n    tkHex: Result := fHexAttri;\r\n    tkSpace: Result := fSpaceAttri;\r\n    tkString: Result := fStringAttri;\r\n    tkChar: Result := fCharAttri;\r\n    tkSymbol: Result := fSymbolAttri;\r\n    tkUnknown: Result := fSymbolAttri;\r\n  else\r\n    Result := nil;\r\n  end;\r\nend;\r\n\r\nfunction TSynDWSSyn.GetTokenKind: Integer;\r\nbegin\r\n  Result := Ord(GetTokenID);\r\nend;\r\n\r\nfunction TSynDWSSyn.GetRange: Pointer;\r\nbegin\r\n  Result := Pointer(fRange);\r\nend;\r\n\r\nprocedure TSynDWSSyn.SetRange(Value: Pointer);\r\nbegin\r\n  fRange := TRangeState(Value);\r\nend;\r\n\r\nprocedure TSynDWSSyn.ResetRange;\r\nbegin\r\n  fRange:= rsUnknown;\r\nend;\r\n\r\nfunction TSynDWSSyn.GetSampleSource: UnicodeString;\r\nbegin\r\n  Result := '{ Syntax highlighting }'#13#10 +\r\n             'procedure TForm1.Button1Click(Sender: TObject);'#13#10 +\r\n             'var'#13#10 +\r\n             '  Number, I, X: Integer;'#13#10 +\r\n             'begin'#13#10 +\r\n             '  Number := 123456;'#13#10 +\r\n             '  Caption := ''The Number is'' + #32 + IntToStr(Number);'#13#10 +\r\n             '  for I := 0 to Number do'#13#10 +\r\n             '  begin'#13#10 +\r\n             '    Inc(X);'#13#10 +\r\n             '    Dec(X);'#13#10 +\r\n             '    X := X + 1.0;'#13#10 +\r\n             '    X := X - $5E;'#13#10 +\r\n             '  end;'#13#10 +\r\n             '  {$R+}'#13#10 +\r\n             '  asm'#13#10 +\r\n             '    mov AX, 1234H'#13#10 +\r\n             '    mov Number, AX'#13#10 +\r\n             '  end;'#13#10 +\r\n             '  {$R-}'#13#10 +\r\n             'end;';\r\nend;\r\n\r\n\r\nclass function TSynDWSSyn.GetLanguageName: string;\r\nbegin\r\n  Result := SYNS_LangPascal;\r\nend;\r\n\r\nclass function TSynDWSSyn.GetCapabilities: TSynHighlighterCapabilities;\r\nbegin\r\n  Result := inherited GetCapabilities + [hcUserSettings];\r\nend;\r\n\r\nfunction TSynDWSSyn.IsFilterStored: Boolean;\r\nbegin\r\n  Result := fDefaultFilter <> SYNS_FilterPascal;\r\nend;\r\n\r\n// IsCurrentToken\r\n//\r\nfunction TSynDWSSyn.IsCurrentToken(const Token: UnicodeString): Boolean;\r\nvar\r\n   i : Integer;\r\n   temp : PWideChar;\r\nbegin\r\n   temp := fToIdent;\r\n   if Length(Token) = fStringLen then begin\r\n      Result := True;\r\n      for i := 1 to fStringLen do begin\r\n         if     (temp^ <> Token[i])\r\n            and (   (temp^>'z')\r\n                 or (UpCase(temp^)<>UpCase(Token[i])))  then begin\r\n            Result := False;\r\n            break;\r\n         end;\r\n         inc(temp);\r\n      end;\r\n   end else Result := False;\r\nend;\r\n\r\n// IsIdentChar\r\n//\r\nfunction TSynDWSSyn.IsIdentChar(AChar: WideChar): Boolean;\r\nbegin\r\n   if Ord(AChar)<=$7F then\r\n      Result := AnsiChar(AChar) in ['_', '0'..'9', 'A'..'Z', 'a'..'z']\r\n   else\r\n      Result := {$IFDEF SYN_COMPILER_18_UP}AChar.IsLetterOrDigit{$ELSE}TCharacter.IsLetterOrDigit(AChar){$ENDIF};\r\nend;\r\n\r\nclass function TSynDWSSyn.GetFriendlyLanguageName: UnicodeString;\r\nbegin\r\n  Result := SYNS_FriendlyLangPascal;\r\nend;\r\n\r\ninitialization\r\n\r\n{$IFNDEF SYN_CPPB_1}\r\n  RegisterPlaceableHighlighter(TSynDWSSyn);\r\n{$ENDIF}\r\n\r\nend.\r\n\r\n"
  },
  {
    "path": "External/SynEdit/Source/SynHighlighterDfm.pas",
    "content": "{-------------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: SynHighlighterDfm.pas, released 2000-04-14.\r\nThe Original Code is based on the dmDfmSyn.pas file from the\r\nmwEdit component suite by Martin Waldenburg and other developers, the Initial\r\nAuthor of this file is David H. Muir.\r\nUnicode translation by Mal Hrz.\r\nAll Rights Reserved.\r\n\r\nContributors to the SynEdit and mwEdit projects are listed in the\r\nContributors.txt file.\r\n\r\nAlternatively, the contents of this file may be used under the terms of the\r\nGNU General Public License Version 2 or later (the \"GPL\"), in which case\r\nthe provisions of the GPL are applicable instead of those above.\r\nIf you wish to allow use of your version of this file only under the terms\r\nof the GPL and not to allow others to use your version of this file\r\nunder the MPL, indicate your decision by deleting the provisions above and\r\nreplace them with the notice and other provisions required by the GPL.\r\nIf you do not delete the provisions above, a recipient may use your version\r\nof this file under either the MPL or the GPL.\r\n\r\n$Id: SynHighlighterDfm.pas,v 1.16.2.7 2008/09/14 16:25:00 maelh Exp $\r\n\r\nYou may retrieve the latest version of this file at the SynEdit home page,\r\nlocated at http://SynEdit.SourceForge.net\r\n\r\nKnown Issues:\r\n-------------------------------------------------------------------------------}\r\n{\r\n@abstract(Provides a Delphi Form Source highlighter for SynEdit)\r\n@author(David Muir )\r\n@created(April 13, 2000)\r\n@lastmod(2000-06-23)\r\nThe SynHighlighterDfm unit provides SynEdit with a Delphi Form Source (.dfm) highlighter.\r\nThe highlighter formats form source code similar to when forms are viewed as text in the Delphi editor.\r\n}\r\n\r\n{$IFNDEF QSYNHIGHLIGHTERDFM}\r\nunit SynHighlighterDfm;\r\n{$ENDIF}\r\n\r\n{$I SynEdit.inc}\r\n\r\ninterface\r\n\r\nuses\r\n{$IFDEF SYN_CLX}\r\n  QGraphics,\r\n  QSynEditTypes,\r\n  QSynEditHighlighter,\r\n  QSynUnicode,  \r\n{$ELSE}\r\n  Graphics,\r\n  SynEditTypes,\r\n  SynEditHighlighter,\r\n  SynUnicode,\r\n{$ENDIF}\r\n  SysUtils,\r\n  Classes;\r\n\r\ntype\r\n  TtkTokenKind = (tkComment, tkIdentifier, tkKey, tkNull, tkNumber, tkSpace,\r\n    tkString, tkSymbol, tkUnknown);\r\n\r\n  TRangeState = (rsANil, rsComment, rsUnKnown);\r\n\r\ntype\r\n  TSynDfmSyn = class(TSynCustomHighlighter)\r\n  private\r\n    fRange: TRangeState;\r\n    FTokenID: TtkTokenKind;\r\n    fCommentAttri: TSynHighlighterAttributes;\r\n    fIdentifierAttri: TSynHighlighterAttributes;\r\n    fKeyAttri: TSynHighlighterAttributes;\r\n    fNumberAttri: TSynHighlighterAttributes;\r\n    fSpaceAttri: TSynHighlighterAttributes;\r\n    fStringAttri: TSynHighlighterAttributes;\r\n    fSymbolAttri: TSynHighlighterAttributes;\r\n    procedure AltProc;\r\n    procedure AsciiCharProc;\r\n    procedure BraceCloseProc;\r\n    procedure BraceOpenProc;\r\n    procedure CommentProc;\r\n    procedure CRProc;\r\n    procedure EndProc;\r\n    procedure IntegerProc;\r\n    procedure LFProc;\r\n    procedure NullProc;\r\n    procedure NumberProc;\r\n    procedure ObjectProc;\r\n    procedure InheritedProc;\r\n    procedure SpaceProc;\r\n    procedure StringProc;\r\n    procedure SymbolProc;\r\n    procedure UnknownProc;\r\n  protected\r\n    function GetSampleSource: UnicodeString; override;\r\n    function IsFilterStored: Boolean; override;\r\n  public\r\n    class function GetLanguageName: string; override;\r\n    class function GetFriendlyLanguageName: UnicodeString; override;\r\n  public\r\n    constructor Create(AOwner: TComponent); override;\r\n    function GetDefaultAttribute(Index: integer): TSynHighlighterAttributes;\r\n      override;\r\n    function GetEol: Boolean; override;\r\n    function GetRange: Pointer; override;\r\n    function GetTokenID: TtkTokenKind;\r\n    function GetTokenAttribute: TSynHighlighterAttributes; override;\r\n    function GetTokenKind: integer; override;\r\n    procedure Next; override;\r\n    procedure SetRange(Value: Pointer); override;\r\n    procedure ResetRange; override;\r\n  published\r\n    property CommentAttri: TSynHighlighterAttributes read fCommentAttri\r\n      write fCommentAttri;\r\n    property IdentifierAttri: TSynHighlighterAttributes read fIdentifierAttri\r\n      write fIdentifierAttri;\r\n    property KeyAttri: TSynHighlighterAttributes read fKeyAttri write fKeyAttri;\r\n    property NumberAttri: TSynHighlighterAttributes read fNumberAttri\r\n      write fNumberAttri;\r\n    property SpaceAttri: TSynHighlighterAttributes read fSpaceAttri\r\n      write fSpaceAttri;\r\n    property StringAttri: TSynHighlighterAttributes read fStringAttri\r\n      write fStringAttri;\r\n    property SymbolAttri: TSynHighlighterAttributes read fSymbolAttri\r\n      write fSymbolAttri;\r\n  end;\r\n\r\nfunction LoadDFMFile2Strings(const AFile: UnicodeString; AStrings: TUnicodeStrings;\r\n  var WasText: Boolean): Integer; {$IFNDEF UNICODE} overload; {$ENDIF}\r\n{$IFNDEF UNICODE}\r\nfunction LoadDFMFile2Strings(const AFile: string; AStrings: TStrings;\r\n  var WasText: Boolean): Integer; overload;\r\n{$ENDIF}\r\nfunction SaveStrings2DFMFile(AStrings: TUnicodeStrings;\r\n  const AFile: UnicodeString): Integer; {$IFNDEF UNICODE} overload; {$ENDIF}\r\n{$IFNDEF UNICODE}\r\nfunction SaveStrings2DFMFile(AStrings: TStrings;\r\n  const AFile: string): Integer; overload;\r\n{$ENDIF}\r\n\r\nimplementation\r\n\r\nuses\r\n{$IFDEF SYN_CLX}\r\n  QSynEditStrConst;\r\n{$ELSE}\r\n  SynEditStrConst;\r\n{$ENDIF}\r\n\r\n{ A couple of useful Delphi Form functions }\r\n\r\nfunction LoadDFMFile2Strings(const AFile: UnicodeString; AStrings: TUnicodeStrings;\r\n  var WasText: Boolean): Integer;\r\nvar\r\n  Src, Dest: TStream;\r\n  origFormat: TStreamOriginalFormat;\r\nbegin\r\n  Result := 0;\r\n  WasText := FALSE;\r\n  AStrings.Clear;\r\n  try\r\n    Src := TWideFileStream.Create(AFile, fmOpenRead or fmShareDenyWrite);\r\n    try\r\n      Dest := TMemoryStream.Create;\r\n      try\r\n        origFormat := sofUnknown;\r\n        ObjectResourceToText(Src, Dest, origFormat);\r\n        WasText := origFormat = sofText;\r\n        Dest.Seek(0, soFromBeginning);\r\n        AStrings.LoadFromStream(Dest);\r\n      finally\r\n        Dest.Free;\r\n      end;\r\n    finally\r\n      Src.Free;\r\n    end;\r\n  except\r\n    on E: EInOutError do Result := -E.ErrorCode;\r\n    else Result := -1;\r\n  end;\r\nend;\r\n\r\n{$IFNDEF UNICODE}\r\nfunction LoadDFMFile2Strings(const AFile: string; AStrings: TStrings;\r\n  var WasText: Boolean): Integer;\r\nvar\r\n  Src, Dest: TStream;\r\n{$IFDEF SYN_COMPILER_5_UP}\r\n  origFormat: TStreamOriginalFormat;\r\n{$ENDIF}\r\nbegin\r\n  Result := 0;\r\n  WasText := FALSE;\r\n  AStrings.Clear;\r\n  try\r\n    Src := TFileStream.Create(AFile, fmOpenRead or fmShareDenyWrite);\r\n    try\r\n      Dest := TMemoryStream.Create;\r\n      try\r\n{$IFDEF SYN_COMPILER_5_UP}\r\n        origFormat := sofUnknown;\r\n        ObjectResourceToText(Src, Dest, origFormat);\r\n        WasText := origFormat = sofText;\r\n{$ELSE}\r\n        ObjectResourceToText(Src, Dest);\r\n{$ENDIF}\r\n        Dest.Seek(0, soFromBeginning);\r\n        AStrings.LoadFromStream(Dest);\r\n      finally\r\n        Dest.Free;\r\n      end;\r\n    finally\r\n      Src.Free;\r\n    end;\r\n  except\r\n    on E: EInOutError do Result := -E.ErrorCode;\r\n    else Result := -1;\r\n  end;\r\nend;\r\n{$ENDIF}\r\n\r\nfunction SaveStrings2DFMFile(AStrings: TUnicodeStrings; const AFile: UnicodeString): Integer;\r\nvar\r\n  Src, Dest: TStream;\r\n{$IFNDEF UNICODE}\r\n  OldSaveUnicode: Boolean;\r\n{$ENDIF}\r\nbegin\r\n  Result := 0;\r\n  try\r\n    Src := TMemoryStream.Create;\r\n    try\r\n{$IFNDEF UNICODE}\r\n      OldSaveUnicode := AStrings.SaveUnicode;\r\n      AStrings.SaveUnicode := False;\r\n{$ENDIF}\r\n      AStrings.SaveToStream(Src);\r\n{$IFNDEF UNICODE}\r\n      AStrings.SaveUnicode := OldSaveUnicode;\r\n{$ENDIF}\r\n      Src.Seek(0, soFromBeginning);\r\n      Dest := TWideFileStream.Create(AFile, fmCreate);\r\n      try\r\n        ObjectTextToResource(Src, Dest);\r\n      finally\r\n        Dest.Free;\r\n      end;\r\n    finally\r\n      Src.Free;\r\n    end;\r\n  except\r\n    on E: EInOutError do Result := -E.ErrorCode;\r\n    else Result := -1;\r\n  end;\r\nend;\r\n\r\n{$IFNDEF UNICODE}\r\nfunction SaveStrings2DFMFile(AStrings: TStrings; const AFile: string): Integer;\r\nvar\r\n  Src, Dest: TStream;\r\nbegin\r\n  Result := 0;\r\n  try\r\n    Src := TMemoryStream.Create;\r\n    try\r\n      AStrings.SaveToStream(Src);\r\n      Src.Seek(0, soFromBeginning);\r\n      Dest := TFileStream.Create(AFile, fmCreate);\r\n      try\r\n        ObjectTextToResource(Src, Dest);\r\n      finally\r\n        Dest.Free;\r\n      end;\r\n    finally\r\n      Src.Free;\r\n    end;\r\n  except\r\n    on E: EInOutError do Result := -E.ErrorCode;\r\n    else Result := -1;\r\n  end;\r\nend;\r\n{$ENDIF}\r\n\r\n{ TSynDfmSyn }\r\n\r\nconstructor TSynDfmSyn.Create(AOwner: TComponent);\r\nbegin\r\n  inherited Create(AOwner);\r\n\r\n  fCaseSensitive := False;\r\n\r\n  fCommentAttri := TSynHighlighterAttributes.Create(SYNS_AttrComment, SYNS_FriendlyAttrComment);\r\n  fCommentAttri.Style := [fsItalic];\r\n  AddAttribute(fCommentAttri);\r\n  fIdentifierAttri := TSynHighlighterAttributes.Create(SYNS_AttrIdentifier, SYNS_FriendlyAttrIdentifier);\r\n  AddAttribute(fIdentifierAttri);\r\n  fKeyAttri := TSynHighlighterAttributes.Create(SYNS_AttrKey, SYNS_FriendlyAttrKey);\r\n  fKeyAttri.Style := [fsBold];\r\n  AddAttribute(fKeyAttri);\r\n  fNumberAttri := TSynHighlighterAttributes.Create(SYNS_AttrNumber, SYNS_FriendlyAttrNumber);\r\n  AddAttribute(fNumberAttri);\r\n  fSpaceAttri := TSynHighlighterAttributes.Create(SYNS_AttrSpace, SYNS_FriendlyAttrSpace);\r\n  AddAttribute(fSpaceAttri);\r\n  fStringAttri := TSynHighlighterAttributes.Create(SYNS_AttrString, SYNS_FriendlyAttrString);\r\n  AddAttribute(fStringAttri);\r\n  fSymbolAttri := TSynHighlighterAttributes.Create(SYNS_AttrSymbol, SYNS_FriendlyAttrSymbol);\r\n  AddAttribute(fSymbolAttri);\r\n  SetAttributesOnChange(DefHighlightChange);\r\n  fDefaultFilter := SYNS_FilterDFM;\r\n  fRange := rsUnknown;\r\nend;\r\n\r\nprocedure TSynDfmSyn.AltProc;\r\nbegin\r\n  fTokenID := tkIdentifier;\r\n  repeat\r\n    Inc(Run);\r\n  until not IsIdentChar(fLine[Run]);\r\nend;\r\n\r\nprocedure TSynDfmSyn.AsciiCharProc;\r\nbegin\r\n  fTokenID := tkString;\r\n  repeat\r\n    Inc(Run);\r\n  until not CharInSet(fLine[Run], ['0'..'9']);\r\nend;\r\n\r\nprocedure TSynDfmSyn.BraceCloseProc;\r\nbegin\r\n  inc(Run);\r\n  fRange := rsUnknown;\r\n  fTokenId := tkIdentifier;\r\nend;\r\n\r\nprocedure TSynDfmSyn.BraceOpenProc;\r\nbegin\r\n  fRange := rsComment;\r\n  CommentProc;\r\nend;\r\n\r\nprocedure TSynDfmSyn.CommentProc;\r\nbegin\r\n  fTokenID := tkComment;\r\n  repeat\r\n    inc(Run);\r\n    if fLine[Run] = '}' then begin\r\n      Inc(Run);\r\n      fRange := rsUnknown;\r\n      break;\r\n    end;\r\n  until IsLineEnd(Run);\r\nend;\r\n\r\nprocedure TSynDfmSyn.CRProc;\r\nbegin\r\n  fTokenID := tkSpace;\r\n  Inc(Run);\r\n  if (fLine[Run] = #10) then Inc(Run);\r\nend;\r\n\r\nprocedure TSynDfmSyn.EndProc;\r\nbegin\r\n  if CharInSet(fLine[Run + 1], ['n', 'N']) and\r\n     CharInSet(fLine[Run + 2], ['d', 'D']) and\r\n     not IsIdentChar(fLine[Run + 3])\r\n  then\r\n  begin\r\n    fTokenID := tkKey;\r\n    Inc(Run, 3);\r\n  end\r\n  else\r\n    AltProc;\r\nend;\r\n\r\nprocedure TSynDfmSyn.IntegerProc;\r\n\r\n  function IsIntegerChar: Boolean;\r\n  begin\r\n    case fLine[Run] of\r\n      '0'..'9', 'A'..'F', 'a'..'f':\r\n        Result := True;\r\n      else\r\n        Result := False;\r\n    end;\r\n  end;\r\n\r\nbegin\r\n  fTokenID := tkNumber;\r\n  repeat\r\n    inc(Run);\r\n  until not IsIntegerChar;\r\nend;\r\n\r\nprocedure TSynDfmSyn.LFProc;\r\nbegin\r\n  fTokenID := tkSpace;\r\n  inc(Run);\r\nend;\r\n\r\nprocedure TSynDfmSyn.NullProc;\r\nbegin\r\n  fTokenID := tkNull;\r\n  inc(Run);\r\nend;\r\n\r\nprocedure TSynDfmSyn.NumberProc;\r\n\r\n  function IsNumberChar: Boolean;\r\n  begin\r\n    case fLine[Run] of\r\n      '0'..'9', 'e', 'E':\r\n        Result := True;\r\n      else\r\n        Result := False;\r\n    end;\r\n  end;\r\n\r\nbegin\r\n  fTokenID := tkNumber;\r\n  repeat\r\n    Inc(Run);\r\n    if fLine[Run] = '.' then\r\n    begin\r\n      if fLine[Run + 1] <> '.' then Inc(Run);\r\n      break;\r\n    end;\r\n  until not IsNumberChar;\r\nend;\r\n\r\nprocedure TSynDfmSyn.ObjectProc;\r\nbegin\r\n  if CharInSet(fLine[Run + 1], ['b', 'B']) and\r\n     CharInSet(fLine[Run + 2], ['j', 'J']) and\r\n     CharInSet(fLine[Run + 3], ['e', 'E']) and\r\n     CharInSet(fLine[Run + 4], ['c', 'C']) and\r\n     CharInSet(fLine[Run + 5], ['t', 'T']) and\r\n     not IsIdentChar(fLine[Run + 6])\r\n  then\r\n  begin\r\n    fTokenID := tkKey;\r\n    Inc(Run, 6);\r\n  end\r\n  else\r\n    AltProc;\r\nend;\r\n\r\nprocedure TSynDfmSyn.InheritedProc;\r\nbegin\r\n  if CharInSet(fLine[Run + 1], ['n', 'N']) and\r\n     CharInSet(fLine[Run + 2], ['h', 'H']) and\r\n     CharInSet(fLine[Run + 3], ['e', 'E']) and\r\n     CharInSet(fLine[Run + 4], ['r', 'R']) and\r\n     CharInSet(fLine[Run + 5], ['i', 'I']) and\r\n     CharInSet(fLine[Run + 6], ['t', 'T']) and\r\n     CharInSet(fLine[Run + 7], ['e', 'E']) and\r\n     CharInSet(fLine[Run + 8], ['d', 'D']) and\r\n     not IsIdentChar(fLine[Run + 9])\r\n  then\r\n  begin\r\n    fTokenID := tkKey;\r\n    Inc(Run, 9);\r\n  end\r\n  else if CharInSet(fLine[Run + 1], ['n', 'N']) and\r\n          CharInSet(fLine[Run + 2], ['l', 'L']) and\r\n          CharInSet(fLine[Run + 3], ['i', 'I']) and\r\n          CharInSet(fLine[Run + 4], ['n', 'N']) and\r\n          CharInSet(fLine[Run + 5], ['e', 'E']) and\r\n          not IsIdentChar(fLine[Run + 6])\r\n  then\r\n  begin\r\n    fTokenID := tkKey;\r\n    Inc(Run, 6);\r\n  end\r\n  else\r\n    AltProc;\r\nend;\r\n\r\nprocedure TSynDfmSyn.SpaceProc;\r\nbegin\r\n  fTokenID := tkSpace;\r\n  repeat\r\n    Inc(Run);\r\n  until (fLine[Run] > #32) or IsLineEnd(Run);\r\nend;\r\n\r\nprocedure TSynDfmSyn.StringProc;\r\nbegin\r\n  fTokenID := tkString;\r\n  repeat\r\n    Inc(Run);\r\n    if fLine[Run] = '''' then begin\r\n      Inc(Run);\r\n      if fLine[Run] <> '''' then break\r\n    end;\r\n  until IsLineEnd(Run);\r\nend;\r\n\r\nprocedure TSynDfmSyn.SymbolProc;\r\nbegin\r\n  inc(Run);\r\n  fTokenID := tkSymbol;\r\nend;\r\n\r\nprocedure TSynDfmSyn.UnknownProc;\r\nbegin\r\n  inc(Run);\r\n  fTokenID := tkUnknown;\r\nend;\r\n\r\nprocedure TSynDfmSyn.Next;\r\nbegin\r\n  fTokenPos := Run;\r\n  if fRange = rsComment then\r\n  begin\r\n    if fLine[Run] = #0 then\r\n      NullProc\r\n    else\r\n      CommentProc;\r\n  end\r\n  else\r\n    case fLine[Run] of\r\n      '#': AsciiCharProc;\r\n      '}': BraceCloseProc;\r\n      '{': BraceOpenProc;\r\n      #13: CRProc;\r\n      'A'..'Z', 'a'..'z', '_':\r\n        if CharInSet(fLine[Run], ['e', 'E']) then\r\n          EndProc\r\n        else if CharInSet(fLine[Run], ['o', 'O']) then\r\n          ObjectProc\r\n        else if CharInSet(fLine[Run], ['i', 'I']) then\r\n          InheritedProc\r\n        else\r\n          AltProc;\r\n      '$': IntegerProc;\r\n      #10: LFProc;\r\n      #0: NullProc;\r\n      '0'..'9': NumberProc;\r\n      '(', ')', '/', '=', '<', '>', '.', ',', '[', ']': SymbolProc;\r\n      #1..#9, #11, #12, #14..#32: SpaceProc;\r\n      #39: StringProc;\r\n      else UnknownProc;\r\n    end;\r\n  inherited;\r\nend;\r\n\r\nfunction TSynDfmSyn.GetDefaultAttribute(Index: integer): TSynHighlighterAttributes;\r\nbegin\r\n  case Index of\r\n    SYN_ATTR_COMMENT: Result := fCommentAttri;\r\n    SYN_ATTR_IDENTIFIER: Result := fIdentifierAttri;\r\n    SYN_ATTR_KEYWORD: Result := fKeyAttri;\r\n    SYN_ATTR_STRING: Result := fStringAttri;\r\n    SYN_ATTR_WHITESPACE: Result := fSpaceAttri;\r\n    SYN_ATTR_SYMBOL: Result := fSymbolAttri;\r\n  else\r\n    Result := nil;\r\n  end;\r\nend;\r\n\r\nfunction TSynDfmSyn.GetEol: Boolean;\r\nbegin\r\n  Result := Run = fLineLen + 1;\r\nend;\r\n\r\nfunction TSynDfmSyn.GetRange: Pointer;\r\nbegin\r\n  Result := Pointer(fRange);\r\nend;\r\n\r\nfunction TSynDfmSyn.GetTokenID: TtkTokenKind;\r\nbegin\r\n  Result := fTokenId;\r\nend;\r\n\r\nfunction TSynDfmSyn.GetTokenAttribute: TSynHighlighterAttributes;\r\nbegin\r\n  case fTokenID of\r\n    tkComment: Result := fCommentAttri;\r\n    tkIdentifier: Result := fIdentifierAttri;\r\n    tkKey: Result := fKeyAttri;\r\n    tkNumber: Result := fNumberAttri;\r\n    tkSpace: Result := fSpaceAttri;\r\n    tkString: Result := fStringAttri;\r\n    tkSymbol: Result := fSymbolAttri;\r\n    tkUnknown: Result := fIdentifierAttri;\r\n    else Result := nil;\r\n  end;\r\nend;\r\n\r\nfunction TSynDfmSyn.GetTokenKind: integer;\r\nbegin\r\n  Result := Ord(fTokenID);\r\nend;\r\n\r\nprocedure TSynDfmSyn.ResetRange;\r\nbegin\r\n  fRange := rsUnknown;\r\nend;\r\n\r\nprocedure TSynDfmSyn.SetRange(Value: Pointer);\r\nbegin\r\n  fRange := TRangeState(Value);\r\nend;\r\n\r\nfunction TSynDfmSyn.IsFilterStored: Boolean;\r\nbegin\r\n  Result := fDefaultFilter <> SYNS_FilterDFM;\r\nend;\r\n\r\nclass function TSynDfmSyn.GetLanguageName: string;\r\nbegin\r\n  Result := SYNS_LangDfm;\r\nend;\r\n\r\nfunction TSynDfmSyn.GetSampleSource: UnicodeString;\r\nbegin\r\n  Result := '{ Delphi/C++ Builder Form Definitions }'#13#10 +\r\n            'object TestForm: TTestForm'#13#10 +\r\n            '  Left = 273'#13#10 +\r\n            '  Top = 103'#13#10 +\r\n            '  Caption = ''SynEdit sample source'''#13#10 +\r\n            'end';\r\nend; { GetSampleSource }\r\n\r\nclass function TSynDfmSyn.GetFriendlyLanguageName: UnicodeString;\r\nbegin\r\n  Result := SYNS_FriendlyLangDfm;\r\nend;\r\n\r\n{$IFNDEF SYN_CPPB_1}\r\ninitialization\r\n  RegisterPlaceableHighlighter(TSynDfmSyn);\r\n{$ENDIF}\r\nend.\r\n"
  },
  {
    "path": "External/SynEdit/Source/SynHighlighterDml.pas",
    "content": "{-------------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: SynHighlighterDml.pas, released 2000-04-17.\r\nThe Original Code is based on the mwDmlSyn.pas file from the\r\nmwEdit component suite by Martin Waldenburg and other developers, the Initial\r\nAuthor of this file is Peter Adam.\r\nUnicode translation by Mal Hrz.\r\nAll Rights Reserved.\r\n\r\nContributors to the SynEdit and mwEdit projects are listed in the\r\nContributors.txt file.\r\n\r\nAlternatively, the contents of this file may be used under the terms of the\r\nGNU General Public License Version 2 or later (the \"GPL\"), in which case\r\nthe provisions of the GPL are applicable instead of those above.\r\nIf you wish to allow use of your version of this file only under the terms\r\nof the GPL and not to allow others to use your version of this file\r\nunder the MPL, indicate your decision by deleting the provisions above and\r\nreplace them with the notice and other provisions required by the GPL.\r\nIf you do not delete the provisions above, a recipient may use your version\r\nof this file under either the MPL or the GPL.\r\n\r\n$Id: SynHighlighterDml.pas,v 1.11.2.7 2008/09/14 16:25:00 maelh Exp $\r\n\r\nYou may retrieve the latest version of this file at the SynEdit home page,\r\nlocated at http://SynEdit.SourceForge.net\r\n\r\nKnown Issues:\r\n  - There are no metadata qualifiers.\r\n-------------------------------------------------------------------------------}\r\n{\r\n@abstract(Provides a Dml highlighter for SynEdit)\r\n@author(Peter Adam)\r\n@created(1999)\r\n@lastmod(2000-06-23)\r\nThe SynHighlighterDml unit provides SynEdit with a Dml highlighter.\r\n}\r\n\r\n{$IFNDEF QSYNHIGHLIGHTERDML}\r\nunit SynHighlighterDml;\r\n{$ENDIF}\r\n\r\n{$I SynEdit.inc}\r\n\r\ninterface\r\n\r\nuses\r\n{$IFDEF SYN_CLX}\r\n  QGraphics,\r\n  QSynEditTypes,\r\n  QSynEditHighlighter,\r\n  QSynUnicode,\r\n{$ELSE}\r\n  Graphics,\r\n  SynEditTypes,\r\n  SynEditHighlighter,\r\n  SynUnicode,\r\n{$ENDIF}\r\n  SysUtils,\r\n  Classes;\r\n\r\ntype\r\n  TtkTokenKind = (tkBlock, tkComment, tkForm, tkFunction, tkIdentifier, tkKey,\r\n    tkNull, tkNumber, tkQualifier, tkSpace, tkSpecial, tkString, tkSymbol,\r\n    tkUnknown, tkVariable);\r\n\r\n  TRangeState = (rsANil, rsAdd, rsFind, rsUnKnown);\r\n\r\n  PIdentFuncTableFunc = ^TIdentFuncTableFunc;\r\n  TIdentFuncTableFunc = function (Index: Integer): TtkTokenKind of object;\r\n\r\n  TSynDmlSyn = class(TSynCustomHighlighter)\r\n  private\r\n    fRange: TRangeState;\r\n    fIdentFuncTable: array[0..2438] of TIdentFuncTableFunc;\r\n    FTokenID: TtkTokenKind;\r\n    fFormAttri: TSynHighlighterAttributes;\r\n    fBlockAttri: TSynHighlighterAttributes;\r\n    fKeyAttri: TSynHighlighterAttributes;\r\n    fQualiAttri: TSynHighlighterAttributes;\r\n    fCommentAttri: TSynHighlighterAttributes;\r\n    fFunctionAttri: TSynHighlighterAttributes;\r\n    fVariableAttri: TSynHighlighterAttributes;\r\n    fSpecialAttri: TSynHighlighterAttributes;\r\n    fStringAttri: TSynHighlighterAttributes;\r\n    fNumberAttri: TSynHighlighterAttributes;\r\n    fSymbolAttri: TSynHighlighterAttributes;\r\n    fIdentifierAttri: TSynHighlighterAttributes;\r\n    fSpaceAttri: TSynHighlighterAttributes;\r\n    function AltFunc(Index: Integer): TtkTokenKind;\r\n    function FuncAbs(Index: Integer): TtkTokenKind;\r\n    function FuncAbsolute_position(Index: Integer): TtkTokenKind;\r\n    function FuncAccount(Index: Integer): TtkTokenKind;\r\n    function FuncAcos(Index: Integer): TtkTokenKind;\r\n    function FuncActual_break(Index: Integer): TtkTokenKind;\r\n    function FuncAdd(Index: Integer): TtkTokenKind;\r\n    function FuncAdd_form(Index: Integer): TtkTokenKind;\r\n    function FuncAlternate_form(Index: Integer): TtkTokenKind;\r\n    function FuncAscii(Index: Integer): TtkTokenKind;\r\n    function FuncAsin(Index: Integer): TtkTokenKind;\r\n    function FuncAtan(Index: Integer): TtkTokenKind;\r\n    function FuncAtan2(Index: Integer): TtkTokenKind;\r\n    function FuncAttributes(Index: Integer): TtkTokenKind;\r\n    function FuncBack(Index: Integer): TtkTokenKind;\r\n    function FuncBase(Index: Integer): TtkTokenKind;\r\n    function FuncBatch(Index: Integer): TtkTokenKind;\r\n    function FuncBegin_block(Index: Integer): TtkTokenKind;\r\n    function FuncBegin_case(Index: Integer): TtkTokenKind;\r\n    function FuncBegin_disable_trigger(Index: Integer): TtkTokenKind;\r\n    function FuncBegin_row(Index: Integer): TtkTokenKind;\r\n    function FuncBegin_signal_to_status(Index: Integer): TtkTokenKind;\r\n    function FuncBell(Index: Integer): TtkTokenKind;\r\n    function FuncBinary_to_poly(Index: Integer): TtkTokenKind;\r\n    function FuncBottom_line(Index: Integer): TtkTokenKind;\r\n    function FuncBreak(Index: Integer): TtkTokenKind;\r\n    function FuncBreak0(Index: Integer): TtkTokenKind;\r\n    function FuncCall(Index: Integer): TtkTokenKind;\r\n    function FuncCase(Index: Integer): TtkTokenKind;\r\n    function FuncCeil(Index: Integer): TtkTokenKind;\r\n    function FuncCheck(Index: Integer): TtkTokenKind;\r\n    function FuncCheck_domain(Index: Integer): TtkTokenKind;\r\n    function FuncChr(Index: Integer): TtkTokenKind;\r\n    function FuncClear_buffer(Index: Integer): TtkTokenKind;\r\n    function FuncCli(Index: Integer): TtkTokenKind;\r\n    function FuncClose(Index: Integer): TtkTokenKind;\r\n    function FuncClose_text(Index: Integer): TtkTokenKind;\r\n    function FuncCol(Index: Integer): TtkTokenKind;\r\n    function FuncColumn_heading_row(Index: Integer): TtkTokenKind;\r\n    function FuncColumn_headings(Index: Integer): TtkTokenKind;\r\n    function FuncColumn_spacing(Index: Integer): TtkTokenKind;\r\n    function FuncCommit(Index: Integer): TtkTokenKind;\r\n    function FuncCommit_rate(Index: Integer): TtkTokenKind;\r\n    function FuncCompile(Index: Integer): TtkTokenKind;\r\n    function FuncCompress(Index: Integer): TtkTokenKind;\r\n    function FuncCompress_all(Index: Integer): TtkTokenKind;\r\n    function FuncConfirm(Index: Integer): TtkTokenKind;\r\n    function FuncConnect(Index: Integer): TtkTokenKind;\r\n    function FuncContinue(Index: Integer): TtkTokenKind;\r\n    function FuncCos(Index: Integer): TtkTokenKind;\r\n    function FuncCosh(Index: Integer): TtkTokenKind;\r\n    function FuncCross_reference(Index: Integer): TtkTokenKind;\r\n    function FuncDate(Index: Integer): TtkTokenKind;\r\n    function FuncDate_seconds(Index: Integer): TtkTokenKind;\r\n    function FuncDay_of_week(Index: Integer): TtkTokenKind;\r\n    function FuncDays(Index: Integer): TtkTokenKind;\r\n    function FuncDcl(Index: Integer): TtkTokenKind;\r\n    function FuncDefault_tag(Index: Integer): TtkTokenKind;\r\n    function FuncDelete(Index: Integer): TtkTokenKind;\r\n    function FuncDelete_form(Index: Integer): TtkTokenKind;\r\n    function FuncDescription(Index: Integer): TtkTokenKind;\r\n    function FuncDir(Index: Integer): TtkTokenKind;\r\n    function FuncDisconnect(Index: Integer): TtkTokenKind;\r\n    function FuncDisplay(Index: Integer): TtkTokenKind;\r\n    function FuncDisplay_length(Index: Integer): TtkTokenKind;\r\n    function FuncDocumentation(Index: Integer): TtkTokenKind;\r\n    function FuncDomain(Index: Integer): TtkTokenKind;\r\n    function FuncEdit(Index: Integer): TtkTokenKind;\r\n    function FuncElse(Index: Integer): TtkTokenKind;\r\n    function FuncElse_if(Index: Integer): TtkTokenKind;\r\n    function FuncEnd_block(Index: Integer): TtkTokenKind;\r\n    function FuncEnd_case(Index: Integer): TtkTokenKind;\r\n    function FuncEnd_disable_trigger(Index: Integer): TtkTokenKind;\r\n    function FuncEnd_execute(Index: Integer): TtkTokenKind;\r\n    function FuncEnd_form(Index: Integer): TtkTokenKind;\r\n    function FuncEnd_if(Index: Integer): TtkTokenKind;\r\n    function FuncEnd_row(Index: Integer): TtkTokenKind;\r\n    function FuncEnd_signal_to_status(Index: Integer): TtkTokenKind;\r\n    function FuncEnd_while(Index: Integer): TtkTokenKind;\r\n    function FuncErase(Index: Integer): TtkTokenKind;\r\n    function FuncError(Index: Integer): TtkTokenKind;\r\n    function FuncExecute(Index: Integer): TtkTokenKind;\r\n    function FuncExit(Index: Integer): TtkTokenKind;\r\n    function FuncExit_forward(Index: Integer): TtkTokenKind;\r\n    function FuncExpand(Index: Integer): TtkTokenKind;\r\n    function FuncExternal(Index: Integer): TtkTokenKind;\r\n    function FuncFacility(Index: Integer): TtkTokenKind;\r\n    function FuncFailure(Index: Integer): TtkTokenKind;\r\n    function FuncFetch(Index: Integer): TtkTokenKind;\r\n    function FuncFiles(Index: Integer): TtkTokenKind;\r\n    function FuncFind(Index: Integer): TtkTokenKind;\r\n    function FuncFind_form(Index: Integer): TtkTokenKind;\r\n    function FuncFinish(Index: Integer): TtkTokenKind;\r\n    function FuncFirst(Index: Integer): TtkTokenKind;\r\n    function FuncFloor(Index: Integer): TtkTokenKind;\r\n    function FuncFooting(Index: Integer): TtkTokenKind;\r\n    function FuncFooting_form(Index: Integer): TtkTokenKind;\r\n    function FuncForm(Index: Integer): TtkTokenKind;\r\n    function FuncGenerate(Index: Integer): TtkTokenKind;\r\n    function FuncGoto(Index: Integer): TtkTokenKind;\r\n    function FuncGrouped_by(Index: Integer): TtkTokenKind;\r\n    function FuncHeading(Index: Integer): TtkTokenKind;\r\n    function FuncHeading_form(Index: Integer): TtkTokenKind;\r\n    function FuncHeight(Index: Integer): TtkTokenKind;\r\n    function FuncIdentifier(Index: Integer): TtkTokenKind;\r\n    function FuncIf(Index: Integer): TtkTokenKind;\r\n    function FuncIn(Index: Integer): TtkTokenKind;\r\n    function FuncInput_block(Index: Integer): TtkTokenKind;\r\n    function FuncInput_mask(Index: Integer): TtkTokenKind;\r\n    function FuncInput_row_height(Index: Integer): TtkTokenKind;\r\n    function FuncInt(Index: Integer): TtkTokenKind;\r\n    function FuncInvoke(Index: Integer): TtkTokenKind;\r\n    function FuncItem(Index: Integer): TtkTokenKind;\r\n    function FuncItem_block(Index: Integer): TtkTokenKind;\r\n    function FuncItem_if(Index: Integer): TtkTokenKind;\r\n    function FuncJoined_to(Index: Integer): TtkTokenKind;\r\n    function FuncLeft(Index: Integer): TtkTokenKind;\r\n    function FuncLen(Index: Integer): TtkTokenKind;\r\n    function FuncLfooting(Index: Integer): TtkTokenKind;\r\n    function FuncLheading(Index: Integer): TtkTokenKind;\r\n    function FuncLine(Index: Integer): TtkTokenKind;\r\n    function FuncLines_after(Index: Integer): TtkTokenKind;\r\n    function FuncLines_before(Index: Integer): TtkTokenKind;\r\n    function FuncList(Index: Integer): TtkTokenKind;\r\n    function FuncLoad(Index: Integer): TtkTokenKind;\r\n    function FuncLock(Index: Integer): TtkTokenKind;\r\n    function FuncLog(Index: Integer): TtkTokenKind;\r\n    function FuncLog10(Index: Integer): TtkTokenKind;\r\n    function FuncLov(Index: Integer): TtkTokenKind;\r\n    function FuncLov_auto_select(Index: Integer): TtkTokenKind;\r\n    function FuncLov_col(Index: Integer): TtkTokenKind;\r\n    function FuncLov_data(Index: Integer): TtkTokenKind;\r\n    function FuncLov_first(Index: Integer): TtkTokenKind;\r\n    function FuncLov_height(Index: Integer): TtkTokenKind;\r\n    function FuncLov_noheading(Index: Integer): TtkTokenKind;\r\n    function FuncLov_nosearch(Index: Integer): TtkTokenKind;\r\n    function FuncLov_reduced_to(Index: Integer): TtkTokenKind;\r\n    function FuncLov_row(Index: Integer): TtkTokenKind;\r\n    function FuncLov_secondary(Index: Integer): TtkTokenKind;\r\n    function FuncLov_selection(Index: Integer): TtkTokenKind;\r\n    function FuncLov_sorted_by(Index: Integer): TtkTokenKind;\r\n    function FuncLov_width(Index: Integer): TtkTokenKind;\r\n    function FuncLov_with(Index: Integer): TtkTokenKind;\r\n    function FuncLowercase(Index: Integer): TtkTokenKind;\r\n    function FuncLtrim(Index: Integer): TtkTokenKind;\r\n    function FuncMail(Index: Integer): TtkTokenKind;\r\n    function FuncMenu(Index: Integer): TtkTokenKind;\r\n    function FuncMenu_block(Index: Integer): TtkTokenKind;\r\n    function FuncMenu_form(Index: Integer): TtkTokenKind;\r\n    function FuncMessage(Index: Integer): TtkTokenKind;\r\n    function FuncMid(Index: Integer): TtkTokenKind;\r\n    function FuncMod(Index: Integer): TtkTokenKind;\r\n    function FuncModify_form(Index: Integer): TtkTokenKind;\r\n    function FuncNew(Index: Integer): TtkTokenKind;\r\n    function FuncNo_domain(Index: Integer): TtkTokenKind;\r\n    function FuncNobell(Index: Integer): TtkTokenKind;\r\n    function FuncNoclear_buffer(Index: Integer): TtkTokenKind;\r\n    function FuncNodeadlock_exit(Index: Integer): TtkTokenKind;\r\n    function FuncNoerase(Index: Integer): TtkTokenKind;\r\n    function FuncNoerror(Index: Integer): TtkTokenKind;\r\n    function FuncNoexit_forward(Index: Integer): TtkTokenKind;\r\n    function FuncNoheading(Index: Integer): TtkTokenKind;\r\n    function FuncNolov_data(Index: Integer): TtkTokenKind;\r\n    function FuncNorepeat(Index: Integer): TtkTokenKind;\r\n    function FuncNostatus(Index: Integer): TtkTokenKind;\r\n    function FuncNototals(Index: Integer): TtkTokenKind;\r\n    function FuncNounderlines(Index: Integer): TtkTokenKind;\r\n    function FuncNowait(Index: Integer): TtkTokenKind;\r\n    function FuncOpen(Index: Integer): TtkTokenKind;\r\n    function FuncOpen_text(Index: Integer): TtkTokenKind;\r\n    function FuncOpt(Index: Integer): TtkTokenKind;\r\n    function FuncOptions(Index: Integer): TtkTokenKind;\r\n    function FuncOutput(Index: Integer): TtkTokenKind;\r\n    function FuncOutput_block(Index: Integer): TtkTokenKind;\r\n    function FuncOutput_mask(Index: Integer): TtkTokenKind;\r\n    function FuncPause(Index: Integer): TtkTokenKind;\r\n    function FuncPause_block(Index: Integer): TtkTokenKind;\r\n    function FuncPerform(Index: Integer): TtkTokenKind;\r\n    function FuncPoly_to_binary(Index: Integer): TtkTokenKind;\r\n    function FuncPos(Index: Integer): TtkTokenKind;\r\n    function FuncPrint(Index: Integer): TtkTokenKind;\r\n    function FuncProcedure_form(Index: Integer): TtkTokenKind;\r\n    function FuncPrompt(Index: Integer): TtkTokenKind;\r\n    function FuncProtect(Index: Integer): TtkTokenKind;\r\n    function FuncQuery(Index: Integer): TtkTokenKind;\r\n    function FuncQuery_form(Index: Integer): TtkTokenKind;\r\n    function FuncRandom(Index: Integer): TtkTokenKind;\r\n    function FuncRead_line(Index: Integer): TtkTokenKind;\r\n    function FuncRead_only(Index: Integer): TtkTokenKind;\r\n    function FuncReceive(Index: Integer): TtkTokenKind;\r\n    function FuncReceive_arguments(Index: Integer): TtkTokenKind;\r\n    function FuncReceive_data(Index: Integer): TtkTokenKind;\r\n    function FuncReceive_table(Index: Integer): TtkTokenKind;\r\n    function FuncReduced_to(Index: Integer): TtkTokenKind;\r\n    function FuncRelease(Index: Integer): TtkTokenKind;\r\n    function FuncRemain(Index: Integer): TtkTokenKind;\r\n    function FuncRepeat(Index: Integer): TtkTokenKind;\r\n    function FuncReport(Index: Integer): TtkTokenKind;\r\n    function FuncReport_form(Index: Integer): TtkTokenKind;\r\n    function FuncReposition(Index: Integer): TtkTokenKind;\r\n    function FuncRewind_text(Index: Integer): TtkTokenKind;\r\n    function FuncRfooting(Index: Integer): TtkTokenKind;\r\n    function FuncRheading(Index: Integer): TtkTokenKind;\r\n    function FuncRight(Index: Integer): TtkTokenKind;\r\n    function FuncRollback(Index: Integer): TtkTokenKind;\r\n    function FuncRound(Index: Integer): TtkTokenKind;\r\n    function FuncRow(Index: Integer): TtkTokenKind;\r\n    function FuncRow_height(Index: Integer): TtkTokenKind;\r\n    function FuncSearch(Index: Integer): TtkTokenKind;\r\n    function FuncSecondary(Index: Integer): TtkTokenKind;\r\n    function FuncSeconds(Index: Integer): TtkTokenKind;\r\n    function FuncSelection(Index: Integer): TtkTokenKind;\r\n    function FuncSend(Index: Integer): TtkTokenKind;\r\n    function FuncSend_data(Index: Integer): TtkTokenKind;\r\n    function FuncSend_message(Index: Integer): TtkTokenKind;\r\n    function FuncSend_table(Index: Integer): TtkTokenKind;\r\n    function FuncSequence(Index: Integer): TtkTokenKind;\r\n    function FuncSeverity(Index: Integer): TtkTokenKind;\r\n    function FuncSin(Index: Integer): TtkTokenKind;\r\n    function FuncSinh(Index: Integer): TtkTokenKind;\r\n    function FuncSorted_by(Index: Integer): TtkTokenKind;\r\n    function FuncSource(Index: Integer): TtkTokenKind;\r\n    function FuncSource_if(Index: Integer): TtkTokenKind;\r\n    function FuncSqrt(Index: Integer): TtkTokenKind;\r\n    function FuncStart_stream(Index: Integer): TtkTokenKind;\r\n    function FuncStart_transaction(Index: Integer): TtkTokenKind;\r\n    function FuncStatistic(Index: Integer): TtkTokenKind;\r\n    function FuncStatus(Index: Integer): TtkTokenKind;\r\n    function FuncStream_name(Index: Integer): TtkTokenKind;\r\n    function FuncString(Index: Integer): TtkTokenKind;\r\n    function FuncSuccess(Index: Integer): TtkTokenKind;\r\n    function FuncSwitch(Index: Integer): TtkTokenKind;\r\n    function FuncSwitch_base(Index: Integer): TtkTokenKind;\r\n    function FuncSystem(Index: Integer): TtkTokenKind;\r\n    function FuncTable(Index: Integer): TtkTokenKind;\r\n    function FuncTable_form(Index: Integer): TtkTokenKind;\r\n    function FuncTable_search(Index: Integer): TtkTokenKind;\r\n    function FuncTag(Index: Integer): TtkTokenKind;\r\n    function FuncTag_length(Index: Integer): TtkTokenKind;\r\n    function FuncTan(Index: Integer): TtkTokenKind;\r\n    function FuncTanh(Index: Integer): TtkTokenKind;\r\n    function FuncTarget(Index: Integer): TtkTokenKind;\r\n    function FuncText(Index: Integer): TtkTokenKind;\r\n    function FuncText_only(Index: Integer): TtkTokenKind;\r\n    function FuncTitle(Index: Integer): TtkTokenKind;\r\n    function FuncTo(Index: Integer): TtkTokenKind;\r\n    function FuncTop_line(Index: Integer): TtkTokenKind;\r\n    function FuncTotal(Index: Integer): TtkTokenKind;\r\n    function FuncTransfer(Index: Integer): TtkTokenKind;\r\n    function FuncTrigger(Index: Integer): TtkTokenKind;\r\n    function FuncTrim(Index: Integer): TtkTokenKind;\r\n    function FuncTsuppress(Index: Integer): TtkTokenKind;\r\n    function FuncUnload(Index: Integer): TtkTokenKind;\r\n    function FuncUppercase(Index: Integer): TtkTokenKind;\r\n    function FuncUse_if(Index: Integer): TtkTokenKind;\r\n    function FuncUser_key(Index: Integer): TtkTokenKind;\r\n    function FuncUsing(Index: Integer): TtkTokenKind;\r\n    function FuncUtilities(Index: Integer): TtkTokenKind;\r\n    function FuncWait(Index: Integer): TtkTokenKind;\r\n    function FuncWhile(Index: Integer): TtkTokenKind;\r\n    function FuncWidth(Index: Integer): TtkTokenKind;\r\n    function FuncWith(Index: Integer): TtkTokenKind;\r\n    function FuncWrite(Index: Integer): TtkTokenKind;\r\n    function FuncWrite_line(Index: Integer): TtkTokenKind;\r\n    function FuncYesno_block(Index: Integer): TtkTokenKind;\r\n    function HashKey(Str: PWideChar): Cardinal;\r\n    function IdentKind(MayBe: PWideChar): TtkTokenKind;\r\n    procedure InitIdent;\r\n    procedure SymbolProc;\r\n    procedure AddressOpProc;\r\n    procedure AsciiCharProc;\r\n    procedure CRProc;\r\n    procedure GreaterProc;\r\n    procedure IdentProc;\r\n    procedure LFProc;\r\n    procedure LowerProc;\r\n    procedure NullProc;\r\n    procedure NumberProc;\r\n    procedure PointProc;\r\n    procedure SpaceProc;\r\n    procedure StringProc;\r\n    procedure UnknownProc;\r\n    procedure RemProc;\r\n    function IsQuali: Boolean;\r\n    function IsSpecial: Boolean;\r\n  protected\r\n    function IsFilterStored: Boolean; override;\r\n  public\r\n    class function GetLanguageName: string; override;\r\n    class function GetFriendlyLanguageName: UnicodeString; override;\r\n  public\r\n    constructor Create(AOwner: TComponent); override;\r\n    function GetDefaultAttribute(Index: integer): TSynHighlighterAttributes;\r\n      override;\r\n    function GetEol: Boolean; override;\r\n    function GetRange: Pointer; override;\r\n    function GetTokenID: TtkTokenKind;\r\n    function GetTokenAttribute: TSynHighlighterAttributes; override;\r\n    function GetTokenKind: integer; override;\r\n    procedure Next; override;\r\n    procedure SetRange(Value: Pointer); override;\r\n    procedure ResetRange; override;\r\n  published\r\n    property BlockAttri: TSynHighlighterAttributes read fBlockAttri\r\n      write fBlockAttri;\r\n    property CommentAttri: TSynHighlighterAttributes read fCommentAttri\r\n      write fCommentAttri;\r\n    property FormAttri: TSynHighlighterAttributes read fFormAttri\r\n      write fFormAttri;\r\n    property FunctionAttri: TSynHighlighterAttributes read fFunctionAttri\r\n      write fFunctionAttri;\r\n    property IdentifierAttri: TSynHighlighterAttributes read fIdentifierAttri\r\n      write fIdentifierAttri;\r\n    property KeyAttri: TSynHighlighterAttributes read fKeyAttri write fKeyAttri;\r\n    property NumberAttri: TSynHighlighterAttributes read fNumberAttri\r\n      write fNumberAttri;\r\n    property QualiAttri: TSynHighlighterAttributes read fQualiAttri\r\n      write fQualiAttri;\r\n    property SpaceAttri: TSynHighlighterAttributes read fSpaceAttri\r\n      write fSpaceAttri;\r\n    property SpecialAttri: TSynHighlighterAttributes read fSpecialAttri\r\n      write fSpecialAttri;\r\n    property StringAttri: TSynHighlighterAttributes read fStringAttri\r\n      write fStringAttri;\r\n    property SymbolAttri: TSynHighlighterAttributes read fSymbolAttri\r\n      write fSymbolAttri;\r\n    property VariableAttri: TSynHighlighterAttributes read fVariableAttri\r\n      write fVariableAttri;\r\n  end;\r\n\r\nimplementation\r\n\r\nuses\r\n{$IFDEF SYN_CLX}\r\n  QSynEditStrConst;\r\n{$ELSE}\r\n  SynEditStrConst;\r\n{$ENDIF}\r\n\r\nconst\r\n  KeyWords: array[0..263] of UnicodeString = (\r\n    'abs', 'absolute_position', 'account', 'acos', 'actual_break', 'add', \r\n    'add_form', 'alternate_form', 'ascii', 'asin', 'atan', 'atan2', \r\n    'attributes', 'back', 'base', 'batch', 'begin_block', 'begin_case', \r\n    'begin_disable_trigger', 'begin_row', 'begin_signal_to_status', 'bell', \r\n    'binary_to_poly', 'bottom_line', 'break', 'break0', 'call', 'case', 'ceil', \r\n    'check', 'check_domain', 'chr', 'clear_buffer', 'cli', 'close', \r\n    'close_text', 'col', 'column_heading_row', 'column_headings', \r\n    'column_spacing', 'commit', 'commit_rate', 'compile', 'compress', \r\n    'compress_all', 'confirm', 'connect', 'continue', 'cos', 'cosh', \r\n    'cross_reference', 'date', 'date_seconds', 'day_of_week', 'days', 'dcl', \r\n    'default_tag', 'delete', 'delete_form', 'description', 'dir', 'disconnect', \r\n    'display', 'display_length', 'documentation', 'domain', 'edit', 'else', \r\n    'else_if', 'end_block', 'end_case', 'end_disable_trigger', 'end_execute', \r\n    'end_form', 'end_if', 'end_row', 'end_signal_to_status', 'end_while', \r\n    'erase', 'error', 'execute', 'exit', 'exit_forward', 'expand', 'external', \r\n    'facility', 'failure', 'fetch', 'files', 'find', 'find_form', 'finish', \r\n    'first', 'floor', 'footing', 'footing_form', 'form', 'generate', 'goto', \r\n    'grouped_by', 'heading', 'heading_form', 'height', 'identifier', 'if', 'in', \r\n    'input_block', 'input_mask', 'input_row_height', 'int', 'invoke', 'item', \r\n    'item_block', 'item_if', 'joined_to', 'left', 'len', 'lfooting', 'lheading', \r\n    'line', 'lines_after', 'lines_before', 'list', 'load', 'lock', 'log', \r\n    'log10', 'lov', 'lov_auto_select', 'lov_col', 'lov_data', 'lov_first', \r\n    'lov_height', 'lov_noheading', 'lov_nosearch', 'lov_reduced_to', 'lov_row', \r\n    'lov_secondary', 'lov_selection', 'lov_sorted_by', 'lov_width', 'lov_with', \r\n    'lowercase', 'ltrim', 'mail', 'menu', 'menu_block', 'menu_form', 'message', \r\n    'mid', 'mod', 'modify_form', 'new', 'no_domain', 'nobell', 'noclear_buffer', \r\n    'nodeadlock_exit', 'noerase', 'noerror', 'noexit_forward', 'noheading', \r\n    'nolov_data', 'norepeat', 'nostatus', 'nototals', 'nounderlines', 'nowait', \r\n    'open', 'open_text', 'opt', 'options', 'output', 'output_block', \r\n    'output_mask', 'pause', 'pause_block', 'perform', 'poly_to_binary', 'pos', \r\n    'print', 'procedure_form', 'prompt', 'protect', 'query', 'query_form', \r\n    'random', 'read_line', 'read_only', 'receive', 'receive_arguments', \r\n    'receive_data', 'receive_table', 'reduced_to', 'release', 'remain', \r\n    'repeat', 'report', 'report_form', 'reposition', 'rewind_text', 'rfooting', \r\n    'rheading', 'right', 'rollback', 'round', 'row', 'row_height', 'search', \r\n    'secondary', 'seconds', 'selection', 'send', 'send_data', 'send_message', \r\n    'send_table', 'sequence', 'severity', 'sin', 'sinh', 'sorted_by', 'source', \r\n    'source_if', 'sqrt', 'start_stream', 'start_transaction', 'statistic', \r\n    'status', 'stream_name', 'string', 'success', 'switch', 'switch_base', \r\n    'system', 'table', 'table_form', 'table_search', 'tag', 'tag_length', 'tan', \r\n    'tanh', 'target', 'text', 'text_only', 'title', 'to', 'top_line', 'total', \r\n    'transfer', 'trigger', 'trim', 'tsuppress', 'unload', 'uppercase', 'use_if', \r\n    'user_key', 'using', 'utilities', 'wait', 'while', 'width', 'with', 'write', \r\n    'write_line', 'yesno_block' \r\n  );\r\n\r\n  KeyIndices: array[0..2438] of Integer = (\r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 2, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, 261, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, 230, -1, 1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, 217, -1, -1, -1, -1, -1, 183, -1, 246, -1, 134, -1, -1, -1, -1, \r\n    -1, 65, -1, -1, 223, -1, -1, -1, -1, -1, 213, -1, -1, -1, 46, -1, -1, 262, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 124, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, 111, 157, -1, -1, -1, -1, -1, -1, 118, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, 208, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 22, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, 86, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, 123, 102, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, 84, -1, 154, -1, 96, -1, -1, -1, 176, -1, -1, -1, 120, 178, -1, -1, -1, \r\n    -1, 74, -1, -1, -1, -1, 241, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 81, -1, 147, -1, -1, -1, 122, \r\n    -1, 58, -1, 87, 191, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 170, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, 5, -1, -1, 194, -1, -1, -1, 243, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, 52, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 248, -1, -1, \r\n    -1, 28, 77, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 255, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 53, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, 239, -1, -1, -1, -1, 20, -1, -1, -1, -1, 79, \r\n    116, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 192, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, 109, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, 0, -1, -1, -1, 119, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, 196, -1, -1, 85, -1, -1, -1, 104, -1, 103, -1, -1, 14, -1, -1, \r\n    131, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 105, -1, \r\n    -1, 6, -1, 182, -1, -1, 171, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 80, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 97, -1, -1, -1, -1, 41, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 142, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 204, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 185, -1, -1, -1, -1, \r\n    -1, -1, -1, 115, -1, -1, 108, -1, 150, -1, -1, 42, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, 224, -1, -1, -1, 59, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 143, 166, -1, -1, \r\n    -1, -1, -1, -1, 225, -1, -1, -1, -1, 29, -1, -1, -1, -1, -1, -1, 92, -1, -1, \r\n    226, -1, 161, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, 40, -1, -1, -1, -1, -1, -1, -1, 237, -1, -1, -1, -1, \r\n    -1, 100, -1, -1, -1, -1, -1, -1, -1, -1, 214, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, 151, -1, -1, -1, -1, -1, 8, -1, -1, -1, -1, -1, -1, -1, 146, 210, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 23, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 245, -1, -1, -1, -1, -1, 68, -1, \r\n    231, -1, -1, -1, 126, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 57, \r\n    -1, -1, -1, 112, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 7, \r\n    -1, -1, 75, -1, 252, 212, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    149, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, 187, -1, -1, -1, -1, -1, -1, -1, 78, -1, -1, \r\n    -1, -1, 47, -1, -1, -1, -1, -1, -1, -1, -1, 164, 35, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    234, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 107, -1, -1, -1, -1, \r\n    -1, -1, 50, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, 240, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 39, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 72, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 21, -1, -1, 229, 11, \r\n    -1, -1, 43, -1, -1, -1, -1, -1, 236, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, 159, -1, -1, 238, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, 181, -1, 139, -1, -1, -1, -1, -1, -1, 37, -1, -1, -1, 15, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, 83, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 69, \r\n    258, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 101, -1, -1, 153, \r\n    -1, -1, 36, -1, -1, 175, -1, -1, -1, -1, -1, -1, -1, -1, 89, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, 48, -1, 13, -1, -1, -1, -1, -1, -1, -1, -1, -1, 232, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, 199, -1, -1, -1, -1, -1, 9, -1, -1, 140, 193, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, 82, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, 177, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 33, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 163, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, 188, -1, -1, -1, -1, -1, 44, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, 228, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    19, -1, 66, -1, -1, -1, 24, -1, -1, -1, -1, 186, -1, -1, -1, -1, 99, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 67, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 253, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, 54, -1, -1, -1, -1, 259, -1, 32, -1, -1, -1, -1, -1, \r\n    121, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 221, 209, 260, -1, \r\n    -1, -1, -1, -1, -1, -1, 76, 257, -1, -1, -1, -1, 211, -1, 90, -1, -1, -1, \r\n    -1, -1, -1, 133, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 31, -1, 70, \r\n    -1, -1, -1, -1, -1, 63, -1, -1, -1, 25, 207, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, 174, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, 167, -1, -1, -1, -1, -1, -1, -1, -1, 179, -1, \r\n    189, -1, -1, -1, 113, -1, -1, -1, 110, -1, 205, -1, 56, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, 51, -1, -1, -1, -1, -1, -1, 45, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, 132, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 117, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, 4, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 180, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 71, -1, 254, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, 49, -1, -1, -1, -1, -1, -1, -1, -1, 155, -1, -1, \r\n    235, -1, 34, -1, 218, -1, -1, -1, -1, -1, -1, 152, -1, -1, -1, -1, 220, -1, \r\n    -1, -1, 141, -1, -1, -1, -1, 195, -1, -1, -1, 137, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 129, -1, -1, -1, -1, 160, -1, \r\n    -1, -1, -1, 227, -1, -1, -1, -1, -1, -1, -1, 148, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 203, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, 156, -1, -1, -1, -1, -1, -1, -1, -1, -1, 91, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, 62, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, 219, -1, -1, -1, -1, -1, 61, -1, -1, 30, -1, -1, 130, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, 12, -1, 202, -1, -1, -1, -1, -1, 200, -1, -1, 169, -1, \r\n    -1, -1, -1, -1, -1, 16, -1, -1, -1, 172, -1, -1, -1, -1, -1, -1, 162, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, 114, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, 247, -1, -1, -1, -1, -1, -1, 242, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, 198, -1, -1, -1, 251, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, 216, -1, -1, -1, -1, 128, 27, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 18, -1, -1, -1, \r\n    -1, 158, -1, -1, -1, -1, -1, -1, -1, 93, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 88, -1, 173, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, 73, -1, -1, -1, -1, 17, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, 135, -1, -1, 190, -1, -1, -1, 222, 60, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, 106, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 38, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 98, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, 136, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, 168, -1, -1, -1, -1, -1, -1, 144, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, 94, -1, 95, -1, -1, -1, -1, -1, 215, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 145, -1, \r\n    -1, -1, 10, 250, -1, -1, -1, 256, -1, -1, -1, -1, -1, -1, -1, -1, -1, 197, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 201, -1, -1, -1, \r\n    233, -1, -1, -1, -1, -1, 249, -1, -1, 184, -1, -1, -1, -1, -1, 263, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, 125, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, 26, 138, -1, -1, -1, -1, -1, -1, -1, -1, 64, \r\n    -1, -1, -1, 55, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 3, 127, 206, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 165, -1, \r\n    -1, 244, -1, -1, -1, -1, -1, -1, -1, -1 \r\n  );\r\n\r\n{$Q-}\r\nfunction TSynDmlSyn.HashKey(Str: PWideChar): Cardinal;\r\nbegin\r\n  Result := 0;\r\n  while IsIdentChar(Str^) do\r\n  begin\r\n    Result := Result * 798 + Ord(Str^) * 3;\r\n    inc(Str);\r\n  end;\r\n  Result := Result mod 2439;\r\n  fStringLen := Str - fToIdent;\r\nend;\r\n{$Q+}\r\n\r\nfunction TSynDmlSyn.IdentKind(MayBe: PWideChar): TtkTokenKind;\r\nvar\r\n  Key: Cardinal;\r\nbegin\r\n  fToIdent := MayBe;\r\n  Key := HashKey(MayBe);\r\n  if Key <= High(fIdentFuncTable) then\r\n    Result := fIdentFuncTable[Key](KeyIndices[Key])\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nprocedure TSynDmlSyn.InitIdent;\r\nvar\r\n  i: Integer;\r\nbegin\r\n  for i := Low(fIdentFuncTable) to High(fIdentFuncTable) do\r\n    if KeyIndices[i] = -1 then\r\n      fIdentFuncTable[i] := AltFunc;\r\n\r\n  fIdentFuncTable[435] := FuncAbs;\r\n  fIdentFuncTable[41] := FuncAbsolute_position;\r\n  fIdentFuncTable[13] := FuncAccount;\r\n  fIdentFuncTable[2405] := FuncAcos;\r\n  fIdentFuncTable[1707] := FuncActual_break;\r\n  fIdentFuncTable[300] := FuncAdd;\r\n  fIdentFuncTable[486] := FuncAdd_form;\r\n  fIdentFuncTable[839] := FuncAlternate_form;\r\n  fIdentFuncTable[735] := FuncAscii;\r\n  fIdentFuncTable[1265] := FuncAsin;\r\n  fIdentFuncTable[2300] := FuncAtan;\r\n  fIdentFuncTable[1065] := FuncAtan2;\r\n  fIdentFuncTable[1930] := FuncAttributes;\r\n  fIdentFuncTable[1202] := FuncBack;\r\n  fIdentFuncTable[464] := FuncBase;\r\n  fIdentFuncTable[1118] := FuncBatch;\r\n  fIdentFuncTable[1948] := FuncBegin_block;\r\n  fIdentFuncTable[2124] := FuncBegin_case;\r\n  fIdentFuncTable[2068] := FuncBegin_disable_trigger;\r\n  fIdentFuncTable[1385] := FuncBegin_row;\r\n  fIdentFuncTable[387] := FuncBegin_signal_to_status;\r\n  fIdentFuncTable[1061] := FuncBell;\r\n  fIdentFuncTable[166] := FuncBinary_to_poly;\r\n  fIdentFuncTable[776] := FuncBottom_line;\r\n  fIdentFuncTable[1391] := FuncBreak;\r\n  fIdentFuncTable[1524] := FuncBreak0;\r\n  fIdentFuncTable[2380] := FuncCall;\r\n  fIdentFuncTable[2044] := FuncCase;\r\n  fIdentFuncTable[337] := FuncCeil;\r\n  fIdentFuncTable[644] := FuncCheck;\r\n  fIdentFuncTable[1918] := FuncCheck_domain;\r\n  fIdentFuncTable[1512] := FuncChr;\r\n  fIdentFuncTable[1454] := FuncClear_buffer;\r\n  fIdentFuncTable[1305] := FuncCli;\r\n  fIdentFuncTable[1761] := FuncClose;\r\n  fIdentFuncTable[908] := FuncClose_text;\r\n  fIdentFuncTable[1179] := FuncCol;\r\n  fIdentFuncTable[1114] := FuncColumn_heading_row;\r\n  fIdentFuncTable[2183] := FuncColumn_headings;\r\n  fIdentFuncTable[1007] := FuncColumn_spacing;\r\n  fIdentFuncTable[697] := FuncCommit;\r\n  fIdentFuncTable[521] := FuncCommit_rate;\r\n  fIdentFuncTable[591] := FuncCompile;\r\n  fIdentFuncTable[1068] := FuncCompress;\r\n  fIdentFuncTable[1359] := FuncCompress_all;\r\n  fIdentFuncTable[1637] := FuncConfirm;\r\n  fIdentFuncTable[89] := FuncConnect;\r\n  fIdentFuncTable[898] := FuncContinue;\r\n  fIdentFuncTable[1200] := FuncCos;\r\n  fIdentFuncTable[1747] := FuncCosh;\r\n  fIdentFuncTable[954] := FuncCross_reference;\r\n  fIdentFuncTable[1630] := FuncDate;\r\n  fIdentFuncTable[320] := FuncDate_seconds;\r\n  fIdentFuncTable[368] := FuncDay_of_week;\r\n  fIdentFuncTable[1447] := FuncDays;\r\n  fIdentFuncTable[2394] := FuncDcl;\r\n  fIdentFuncTable[1583] := FuncDefault_tag;\r\n  fIdentFuncTable[820] := FuncDelete;\r\n  fIdentFuncTable[261] := FuncDelete_form;\r\n  fIdentFuncTable[608] := FuncDescription;\r\n  fIdentFuncTable[2142] := FuncDir;\r\n  fIdentFuncTable[1915] := FuncDisconnect;\r\n  fIdentFuncTable[1889] := FuncDisplay;\r\n  fIdentFuncTable[1520] := FuncDisplay_length;\r\n  fIdentFuncTable[2390] := FuncDocumentation;\r\n  fIdentFuncTable[76] := FuncDomain;\r\n  fIdentFuncTable[1387] := FuncEdit;\r\n  fIdentFuncTable[1414] := FuncElse;\r\n  fIdentFuncTable[801] := FuncElse_if;\r\n  fIdentFuncTable[1158] := FuncEnd_block;\r\n  fIdentFuncTable[1514] := FuncEnd_case;\r\n  fIdentFuncTable[1734] := FuncEnd_disable_trigger;\r\n  fIdentFuncTable[1043] := FuncEnd_execute;\r\n  fIdentFuncTable[2119] := FuncEnd_form;\r\n  fIdentFuncTable[224] := FuncEnd_if;\r\n  fIdentFuncTable[842] := FuncEnd_row;\r\n  fIdentFuncTable[1484] := FuncEnd_signal_to_status;\r\n  fIdentFuncTable[338] := FuncEnd_while;\r\n  fIdentFuncTable[893] := FuncErase;\r\n  fIdentFuncTable[392] := FuncError;\r\n  fIdentFuncTable[503] := FuncExecute;\r\n  fIdentFuncTable[253] := FuncExit;\r\n  fIdentFuncTable[1280] := FuncExit_forward;\r\n  fIdentFuncTable[1146] := FuncExpand;\r\n  fIdentFuncTable[206] := FuncExternal;\r\n  fIdentFuncTable[455] := FuncFacility;\r\n  fIdentFuncTable[176] := FuncFailure;\r\n  fIdentFuncTable[263] := FuncFetch;\r\n  fIdentFuncTable[2106] := FuncFiles;\r\n  fIdentFuncTable[1191] := FuncFind;\r\n  fIdentFuncTable[1492] := FuncFind_form;\r\n  fIdentFuncTable[1868] := FuncFinish;\r\n  fIdentFuncTable[651] := FuncFirst;\r\n  fIdentFuncTable[2081] := FuncFloor;\r\n  fIdentFuncTable[2267] := FuncFooting;\r\n  fIdentFuncTable[2269] := FuncFooting_form;\r\n  fIdentFuncTable[210] := FuncForm;\r\n  fIdentFuncTable[516] := FuncGenerate;\r\n  fIdentFuncTable[2196] := FuncGoto;\r\n  fIdentFuncTable[1401] := FuncGrouped_by;\r\n  fIdentFuncTable[711] := FuncHeading;\r\n  fIdentFuncTable[1173] := FuncHeading_form;\r\n  fIdentFuncTable[194] := FuncHeight;\r\n  fIdentFuncTable[461] := FuncIdentifier;\r\n  fIdentFuncTable[459] := FuncIf;\r\n  fIdentFuncTable[483] := FuncIn;\r\n  fIdentFuncTable[2151] := FuncInput_block;\r\n  fIdentFuncTable[947] := FuncInput_mask;\r\n  fIdentFuncTable[586] := FuncInput_row_height;\r\n  fIdentFuncTable[420] := FuncInt;\r\n  fIdentFuncTable[1579] := FuncInvoke;\r\n  fIdentFuncTable[134] := FuncItem;\r\n  fIdentFuncTable[824] := FuncItem_block;\r\n  fIdentFuncTable[1575] := FuncItem_if;\r\n  fIdentFuncTable[1988] := FuncJoined_to;\r\n  fIdentFuncTable[583] := FuncLeft;\r\n  fIdentFuncTable[393] := FuncLen;\r\n  fIdentFuncTable[1698] := FuncLfooting;\r\n  fIdentFuncTable[142] := FuncLheading;\r\n  fIdentFuncTable[439] := FuncLine;\r\n  fIdentFuncTable[218] := FuncLines_after;\r\n  fIdentFuncTable[1460] := FuncLines_before;\r\n  fIdentFuncTable[259] := FuncList;\r\n  fIdentFuncTable[193] := FuncLoad;\r\n  fIdentFuncTable[124] := FuncLock;\r\n  fIdentFuncTable[2361] := FuncLog;\r\n  fIdentFuncTable[807] := FuncLog10;\r\n  fIdentFuncTable[2406] := FuncLov;\r\n  fIdentFuncTable[2043] := FuncLov_auto_select;\r\n  fIdentFuncTable[1806] := FuncLov_col;\r\n  fIdentFuncTable[1921] := FuncLov_data;\r\n  fIdentFuncTable[467] := FuncLov_first;\r\n  fIdentFuncTable[1673] := FuncLov_height;\r\n  fIdentFuncTable[1499] := FuncLov_noheading;\r\n  fIdentFuncTable[70] := FuncLov_nosearch;\r\n  fIdentFuncTable[2134] := FuncLov_reduced_to;\r\n  fIdentFuncTable[2208] := FuncLov_row;\r\n  fIdentFuncTable[1788] := FuncLov_secondary;\r\n  fIdentFuncTable[2381] := FuncLov_selection;\r\n  fIdentFuncTable[1107] := FuncLov_sorted_by;\r\n  fIdentFuncTable[1268] := FuncLov_width;\r\n  fIdentFuncTable[1779] := FuncLov_with;\r\n  fIdentFuncTable[538] := FuncLowercase;\r\n  fIdentFuncTable[631] := FuncLtrim;\r\n  fIdentFuncTable[2233] := FuncMail;\r\n  fIdentFuncTable[2296] := FuncMenu;\r\n  fIdentFuncTable[743] := FuncMenu_block;\r\n  fIdentFuncTable[255] := FuncMenu_form;\r\n  fIdentFuncTable[1824] := FuncMessage;\r\n  fIdentFuncTable[858] := FuncMid;\r\n  fIdentFuncTable[588] := FuncMod;\r\n  fIdentFuncTable[729] := FuncModify_form;\r\n  fIdentFuncTable[1770] := FuncNew;\r\n  fIdentFuncTable[1176] := FuncNo_domain;\r\n  fIdentFuncTable[208] := FuncNobell;\r\n  fIdentFuncTable[1756] := FuncNoclear_buffer;\r\n  fIdentFuncTable[1858] := FuncNodeadlock_exit;\r\n  fIdentFuncTable[135] := FuncNoerase;\r\n  fIdentFuncTable[2073] := FuncNoerror;\r\n  fIdentFuncTable[1092] := FuncNoexit_forward;\r\n  fIdentFuncTable[1811] := FuncNoheading;\r\n  fIdentFuncTable[656] := FuncNolov_data;\r\n  fIdentFuncTable[1959] := FuncNorepeat;\r\n  fIdentFuncTable[1319] := FuncNostatus;\r\n  fIdentFuncTable[907] := FuncNototals;\r\n  fIdentFuncTable[2427] := FuncNounderlines;\r\n  fIdentFuncTable[632] := FuncNowait;\r\n  fIdentFuncTable[1560] := FuncOpen;\r\n  fIdentFuncTable[2226] := FuncOpen_text;\r\n  fIdentFuncTable[1941] := FuncOpt;\r\n  fIdentFuncTable[290] := FuncOptions;\r\n  fIdentFuncTable[491] := FuncOutput;\r\n  fIdentFuncTable[1952] := FuncOutput_block;\r\n  fIdentFuncTable[2108] := FuncOutput_mask;\r\n  fIdentFuncTable[1539] := FuncPause;\r\n  fIdentFuncTable[1182] := FuncPause_block;\r\n  fIdentFuncTable[214] := FuncPerform;\r\n  fIdentFuncTable[1294] := FuncPoly_to_binary;\r\n  fIdentFuncTable[219] := FuncPos;\r\n  fIdentFuncTable[1569] := FuncPrint;\r\n  fIdentFuncTable[1719] := FuncProcedure_form;\r\n  fIdentFuncTable[1105] := FuncPrompt;\r\n  fIdentFuncTable[488] := FuncProtect;\r\n  fIdentFuncTable[66] := FuncQuery;\r\n  fIdentFuncTable[2344] := FuncQuery_form;\r\n  fIdentFuncTable[575] := FuncRandom;\r\n  fIdentFuncTable[1396] := FuncRead_line;\r\n  fIdentFuncTable[885] := FuncRead_only;\r\n  fIdentFuncTable[1353] := FuncReceive;\r\n  fIdentFuncTable[1571] := FuncReceive_arguments;\r\n  fIdentFuncTable[2137] := FuncReceive_data;\r\n  fIdentFuncTable[264] := FuncReceive_table;\r\n  fIdentFuncTable[410] := FuncReduced_to;\r\n  fIdentFuncTable[1269] := FuncRelease;\r\n  fIdentFuncTable[303] := FuncRemain;\r\n  fIdentFuncTable[1784] := FuncRepeat;\r\n  fIdentFuncTable[452] := FuncReport;\r\n  fIdentFuncTable[2315] := FuncReport_form;\r\n  fIdentFuncTable[2025] := FuncReposition;\r\n  fIdentFuncTable[1259] := FuncRewind_text;\r\n  fIdentFuncTable[1938] := FuncRfooting;\r\n  fIdentFuncTable[2331] := FuncRheading;\r\n  fIdentFuncTable[1932] := FuncRight;\r\n  fIdentFuncTable[1849] := FuncRollback;\r\n  fIdentFuncTable[553] := FuncRound;\r\n  fIdentFuncTable[1581] := FuncRow;\r\n  fIdentFuncTable[2407] := FuncRow_height;\r\n  fIdentFuncTable[1525] := FuncSearch;\r\n  fIdentFuncTable[151] := FuncSecondary;\r\n  fIdentFuncTable[1475] := FuncSeconds;\r\n  fIdentFuncTable[744] := FuncSelection;\r\n  fIdentFuncTable[1490] := FuncSend;\r\n  fIdentFuncTable[845] := FuncSend_data;\r\n  fIdentFuncTable[85] := FuncSend_message;\r\n  fIdentFuncTable[720] := FuncSend_table;\r\n  fIdentFuncTable[2275] := FuncSequence;\r\n  fIdentFuncTable[2038] := FuncSeverity;\r\n  fIdentFuncTable[60] := FuncSin;\r\n  fIdentFuncTable[1763] := FuncSinh;\r\n  fIdentFuncTable[1909] := FuncSorted_by;\r\n  fIdentFuncTable[1775] := FuncSource;\r\n  fIdentFuncTable[1474] := FuncSource_if;\r\n  fIdentFuncTable[2141] := FuncSqrt;\r\n  fIdentFuncTable[79] := FuncStart_stream;\r\n  fIdentFuncTable[604] := FuncStart_transaction;\r\n  fIdentFuncTable[639] := FuncStatistic;\r\n  fIdentFuncTable[654] := FuncStatus;\r\n  fIdentFuncTable[1816] := FuncStream_name;\r\n  fIdentFuncTable[1368] := FuncString;\r\n  fIdentFuncTable[1064] := FuncSuccess;\r\n  fIdentFuncTable[39] := FuncSwitch;\r\n  fIdentFuncTable[803] := FuncSwitch_base;\r\n  fIdentFuncTable[1212] := FuncSystem;\r\n  fIdentFuncTable[2335] := FuncTable;\r\n  fIdentFuncTable[934] := FuncTable_form;\r\n  fIdentFuncTable[1759] := FuncTable_search;\r\n  fIdentFuncTable[1074] := FuncTag;\r\n  fIdentFuncTable[705] := FuncTag_length;\r\n  fIdentFuncTable[1095] := FuncTan;\r\n  fIdentFuncTable[382] := FuncTanh;\r\n  fIdentFuncTable[975] := FuncTarget;\r\n  fIdentFuncTable[229] := FuncText;\r\n  fIdentFuncTable[2007] := FuncText_only;\r\n  fIdentFuncTable[307] := FuncTitle;\r\n  fIdentFuncTable[2430] := FuncTo;\r\n  fIdentFuncTable[795] := FuncTop_line;\r\n  fIdentFuncTable[68] := FuncTotal;\r\n  fIdentFuncTable[2000] := FuncTransfer;\r\n  fIdentFuncTable[333] := FuncTrigger;\r\n  fIdentFuncTable[2341] := FuncTrim;\r\n  fIdentFuncTable[2301] := FuncTsuppress;\r\n  fIdentFuncTable[2029] := FuncUnload;\r\n  fIdentFuncTable[844] := FuncUppercase;\r\n  fIdentFuncTable[1437] := FuncUse_if;\r\n  fIdentFuncTable[1736] := FuncUser_key;\r\n  fIdentFuncTable[353] := FuncUsing;\r\n  fIdentFuncTable[2305] := FuncUtilities;\r\n  fIdentFuncTable[1485] := FuncWait;\r\n  fIdentFuncTable[1159] := FuncWhile;\r\n  fIdentFuncTable[1452] := FuncWidth;\r\n  fIdentFuncTable[1476] := FuncWith;\r\n  fIdentFuncTable[27] := FuncWrite;\r\n  fIdentFuncTable[92] := FuncWrite_line;\r\n  fIdentFuncTable[2350] := FuncYesno_block;\r\nend;\r\n\r\nfunction TSynDmlSyn.IsQuali: boolean;\r\nbegin\r\n  Result:= False;\r\n  if Run > 0 then\r\n    if fLine[Run - 1] = '/' then Result:= True;\r\nend;\r\n\r\nfunction TSynDmlSyn.IsSpecial: Boolean;\r\nbegin\r\n  Result:= False;\r\n  if Run > 0 then\r\n    if fLine[Run - 1] = '%' then Result:= True;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncAbs(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkFunction\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncAbsolute_position(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) and IsQuali then\r\n    Result := tkQualifier\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncAccount(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) and IsSpecial then\r\n    Result := tkSpecial\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncAcos(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkFunction\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncActual_break(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) and IsSpecial then\r\n    Result := tkSpecial\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncAdd(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n  begin\r\n    if IsSpecial then\r\n      Result := tkSpecial\r\n    else\r\n    begin\r\n      Result := tkKey;\r\n      fRange := rsAdd;\r\n    end;\r\n  end\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncAdd_form(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) and IsQuali then\r\n    Result := tkQualifier\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncAlternate_form(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) and IsQuali then\r\n    Result := tkQualifier\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncAscii(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkFunction\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncAsin(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkFunction\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncAtan(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkFunction\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncAtan2(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkFunction\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncAttributes(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) and IsQuali then\r\n    Result := tkQualifier\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncBack(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) and IsQuali then\r\n    Result := tkQualifier\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncBase(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) and IsQuali then\r\n    Result := tkQualifier\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncBatch(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) and IsQuali then\r\n    Result := tkQualifier\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncBegin_block(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkBlock\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncBegin_case(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncBegin_disable_trigger(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncBegin_row(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) and IsQuali then\r\n    Result := tkQualifier\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncBegin_signal_to_status(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncBell(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) and IsQuali then\r\n    Result := tkQualifier\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncBinary_to_poly(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkFunction\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncBottom_line(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) and IsSpecial then\r\n    Result := tkSpecial\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncBreak(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) and IsQuali then\r\n    Result := tkQualifier\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncBreak0(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) and IsQuali then\r\n    Result := tkQualifier\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncCall(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncCase(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncCeil(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkFunction\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncCheck(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) and IsQuali then\r\n    Result := tkQualifier\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncCheck_domain(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncChr(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkFunction\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncClear_buffer(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncCli(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncClose(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncClose_text(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncCol(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n  begin\r\n    if IsQuali then\r\n      Result := tkQualifier\r\n    else if IsSpecial then\r\n      Result := tkSpecial\r\n    else\r\n      Result := tkIdentifier;\r\n  end\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncColumn_heading_row(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) and IsQuali then\r\n    Result := tkQualifier\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncColumn_headings(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) and IsQuali then\r\n    Result := tkQualifier\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncColumn_spacing(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) and IsQuali then\r\n    Result := tkQualifier\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncCommit(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncCommit_rate(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) and IsQuali then\r\n    Result := tkQualifier\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncCompile(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncCompress(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkFunction\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncCompress_all(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkFunction\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncConfirm(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncConnect(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncContinue(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) and IsQuali then\r\n    Result := tkQualifier\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncCos(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkFunction\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncCosh(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkFunction\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncCross_reference(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncDate(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkFunction\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncDate_seconds(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkFunction\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncDay_of_week(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkFunction\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncDays(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkFunction\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncDcl(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncDefault_tag(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) and IsQuali then\r\n    Result := tkQualifier\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncDelete(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncDelete_form(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) and IsQuali then\r\n    Result := tkQualifier\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncDescription(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) and IsQuali then\r\n    Result := tkQualifier\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncDir(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncDisconnect(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncDisplay(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncDisplay_length(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) and IsQuali then\r\n    Result := tkQualifier\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncDocumentation(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncDomain(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) and IsQuali then\r\n    Result := tkQualifier\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncEdit(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncElse(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncElse_if(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncEnd_block(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkBlock\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncEnd_case(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncEnd_disable_trigger(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncEnd_execute(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncEnd_form(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkForm\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncEnd_if(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncEnd_row(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) and IsQuali then\r\n    Result := tkQualifier\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncEnd_signal_to_status(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncEnd_while(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncErase(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncError(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n  begin\r\n    if IsQuali then\r\n      Result := tkQualifier\r\n    else\r\n      Result := tkKey;\r\n  end\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncExecute(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncExit(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) and IsQuali then\r\n    Result := tkQualifier\r\n  else if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncExit_forward(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) and IsQuali then\r\n    Result := tkQualifier\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncExpand(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkFunction\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncExternal(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncFacility(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) and IsQuali then\r\n    Result := tkQualifier\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncFailure(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n  begin\r\n    if IsQuali then\r\n      Result := tkQualifier\r\n    else if IsSpecial then\r\n      Result := tkSpecial\r\n    else\r\n      Result := tkIdentifier;\r\n  end\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncFetch(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncFiles(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncFind(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n  begin\r\n    Result := tkKey;\r\n    fRange := rsFind;\r\n  end\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncFind_form(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) and IsQuali then\r\n    Result := tkQualifier\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncFinish(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncFirst(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) and IsQuali then\r\n    Result := tkQualifier\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncFloor(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncFooting(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) and IsQuali then\r\n    Result := tkQualifier\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncFooting_form(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) and IsQuali then\r\n    Result := tkQualifier\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncForm(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n  begin\r\n    if IsSpecial then\r\n      Result := tkSpecial\r\n    else\r\n      Result := tkForm;\r\n  end\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncGenerate(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncGoto(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncGrouped_by(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) and IsQuali then\r\n    Result := tkQualifier\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncHeading(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) and IsQuali then\r\n    Result := tkQualifier\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncHeading_form(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkQualifier\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncHeight(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) and IsQuali then\r\n    Result := tkQualifier\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncIdentifier(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) and IsQuali then\r\n    Result := tkQualifier\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncIf(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncIn(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) and (fRange = rsFind) then\r\n  begin\r\n    Result := tkKey;\r\n    fRange := rsUnKnown;\r\n  end\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncInput_block(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkBlock\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncInput_mask(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) and IsQuali then\r\n    Result := tkQualifier\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncInput_row_height(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) and IsQuali then\r\n    Result := tkQualifier\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncInt(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkFunction\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncInvoke(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncItem(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) and IsQuali then\r\n    Result := tkQualifier\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncItem_block(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkBlock\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncItem_if(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) and IsQuali then\r\n    Result := tkQualifier\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncJoined_to(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) and IsQuali then\r\n    Result := tkQualifier\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncLeft(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkFunction\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncLen(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n  begin\r\n    if IsQuali then\r\n      Result := tkQualifier\r\n    else\r\n      Result := tkFunction;\r\n  end\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncLfooting(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) and IsQuali then\r\n    Result := tkQualifier\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncLheading(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) and IsQuali then\r\n    Result := tkQualifier\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncLine(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncLines_after(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) and IsQuali then\r\n    Result := tkQualifier\r\n  else if IsCurrentToken(KeyWords[Index]) and IsSpecial then\r\n    Result := tkSpecial\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncLines_before(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) and IsQuali then\r\n    Result := tkQualifier\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncList(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncLoad(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncLock(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) and IsQuali then\r\n    Result := tkQualifier\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncLog(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n  begin\r\n    if IsQuali then\r\n      Result := tkQualifier\r\n    else\r\n      Result := tkFunction;\r\n  end\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncLog10(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkFunction\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncLov(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) and IsQuali then\r\n    Result := tkQualifier\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncLov_auto_select(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) and IsQuali then\r\n    Result := tkQualifier\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncLov_col(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) and IsQuali then\r\n    Result := tkQualifier\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncLov_data(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) and IsQuali then\r\n    Result := tkQualifier\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncLov_first(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) and IsQuali then\r\n    Result := tkQualifier\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncLov_height(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) and IsQuali then\r\n    Result := tkQualifier\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncLov_noheading(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) and IsQuali then\r\n    Result := tkQualifier\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncLov_nosearch(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) and IsQuali then\r\n    Result := tkQualifier\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncLov_reduced_to(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) and IsQuali then\r\n    Result := tkQualifier\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncLov_row(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) and IsQuali then\r\n    Result := tkQualifier\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncLov_secondary(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) and IsQuali then\r\n    Result := tkQualifier\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncLov_selection(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) and IsQuali then\r\n    Result := tkQualifier\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncLov_sorted_by(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) and IsQuali then\r\n    Result := tkQualifier\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncLov_width(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) and IsQuali then\r\n    Result := tkQualifier\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncLov_with(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) and IsQuali then\r\n    Result := tkQualifier\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncLowercase(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkFunction\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncLtrim(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkFunction\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncMail(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncMenu(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncMenu_block(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkBlock\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncMenu_form(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkForm\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncMessage(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncMid(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkFunction\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncMod(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkFunction\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncModify_form(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) and IsQuali then\r\n    Result := tkQualifier\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncNew(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) and IsQuali then\r\n    Result := tkQualifier\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncNo_domain(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) and IsQuali then\r\n    Result := tkQualifier\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncNobell(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) and IsQuali then\r\n    Result := tkFunction\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncNoclear_buffer(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) and IsQuali then\r\n    Result := tkQualifier\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncNodeadlock_exit(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) and IsQuali then\r\n    Result := tkQualifier\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncNoerase(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) and IsQuali then\r\n    Result := tkQualifier\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncNoerror(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) and IsQuali then\r\n    Result := tkQualifier\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncNoexit_forward(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) and IsQuali then\r\n    Result := tkQualifier\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncNoheading(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) and IsQuali then\r\n    Result := tkQualifier\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncNolov_data(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) and IsQuali then\r\n    Result := tkQualifier\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncNorepeat(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) and IsQuali then\r\n    Result := tkQualifier\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncNostatus(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) and IsQuali then\r\n    Result := tkQualifier\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncNototals(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) and IsSpecial then\r\n    Result := tkSpecial\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncNounderlines(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n  begin\r\n    if IsQuali then\r\n      Result := tkQualifier\r\n    else if IsSpecial then\r\n      Result := tkSpecial\r\n    else\r\n      Result := tkIdentifier;\r\n  end\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncNowait(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) and IsQuali then\r\n    Result := tkQualifier\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncOpen(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncOpen_text(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncOpt(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) and IsQuali then\r\n    Result := tkQualifier\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncOptions(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) and IsQuali then\r\n    Result := tkQualifier\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncOutput(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) and IsQuali then\r\n    Result := tkQualifier\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncOutput_block(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkBlock\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncOutput_mask(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) and IsQuali then\r\n    Result := tkQualifier\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncPause(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) and IsQuali then\r\n    Result := tkQualifier\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncPause_block(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkBlock\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncPerform(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncPoly_to_binary(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkFunction\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncPos(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) and IsQuali then\r\n    Result := tkQualifier\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncPrint(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncProcedure_form(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkForm\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncPrompt(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) and IsQuali then\r\n    Result := tkQualifier\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncProtect(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) and IsQuali then\r\n    Result := tkQualifier\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncQuery(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncQuery_form(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkForm\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncRandom(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncRead_line(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncRead_only(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) and IsQuali then\r\n    Result := tkQualifier\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncReceive(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncReceive_arguments(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncReceive_data(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncReceive_table(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncReduced_to(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) and IsQuali then\r\n    Result := tkQualifier\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncRelease(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncRemain(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) and IsQuali then\r\n    Result := tkQualifier\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncRepeat(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n  begin\r\n    if IsQuali then\r\n      Result := tkQualifier\r\n    else\r\n      Result := tkKey;\r\n  end\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncReport(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncReport_form(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkForm\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncReposition(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncRewind_text(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncRfooting(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkQualifier\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncRheading(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) and IsQuali then\r\n    Result := tkQualifier\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncRight(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkFunction\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncRollback(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncRound(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkFunction\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncRow(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) and IsQuali then\r\n    Result := tkQualifier\r\n  else if IsCurrentToken(KeyWords[Index]) and IsSpecial then\r\n    Result := tkSpecial\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncRow_height(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) and IsQuali then\r\n    Result := tkQualifier\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncSearch(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncSecondary(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) and IsQuali then\r\n    Result := tkQualifier\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncSeconds(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkFunction\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncSelection(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) and IsQuali then\r\n    Result := tkQualifier\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncSend(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncSend_data(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncSend_message(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncSend_table(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncSequence(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) and IsQuali then\r\n    Result := tkQualifier\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncSeverity(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) and IsQuali then\r\n    Result := tkQualifier\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncSin(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkFunction\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncSinh(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkFunction\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncSorted_by(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) and IsQuali then\r\n    Result := tkQualifier\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncSource(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) and IsQuali then\r\n    Result := tkQualifier\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncSource_if(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) and IsQuali then\r\n    Result := tkQualifier\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncSqrt(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkFunction\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncStart_stream(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncStart_transaction(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncStatistic(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) and IsQuali then\r\n    Result := tkQualifier\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncStatus(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n  begin\r\n    if IsQuali then\r\n      Result := tkQualifier\r\n    else if IsSpecial then\r\n      Result := tkSpecial\r\n    else\r\n      Result := tkIdentifier;\r\n  end\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncStream_name(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) and IsQuali then\r\n    Result := tkQualifier\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncString(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkFunction\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncSuccess(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n  begin\r\n    if IsQuali then\r\n      Result := tkQualifier\r\n    else if IsSpecial then\r\n      Result := tkSpecial\r\n    else\r\n      Result := tkIdentifier;\r\n  end\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncSwitch(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) and IsQuali then\r\n    Result := tkQualifier\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncSwitch_base(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) and IsQuali then\r\n    Result := tkQualifier\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncSystem(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) and IsQuali then\r\n    Result := tkQualifier\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncTable(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) and IsQuali then\r\n    Result := tkQualifier\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncTable_form(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkForm\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncTable_search(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncTag(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) and IsQuali then\r\n    Result := tkQualifier\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncTag_length(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) and IsQuali then\r\n    Result := tkQualifier\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncTan(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkFunction\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncTanh(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkFunction\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncTarget(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) and IsQuali then\r\n    Result := tkQualifier\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncText(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n  begin\r\n    if IsSpecial then\r\n      Result := tkSpecial\r\n    else\r\n      Result := tkKey;\r\n  end\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncText_only(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) and IsQuali then\r\n    Result := tkQualifier\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncTitle(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n  begin\r\n    if IsQuali then\r\n      Result := tkQualifier\r\n    else\r\n      Result := tkKey;\r\n  end\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncTo(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) and (fRange = rsAdd) then\r\n  begin\r\n    Result := tkKey;\r\n    fRange := rsUnKnown;\r\n  end\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncTop_line(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) and IsSpecial then\r\n    Result := tkSpecial\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncTotal(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) and IsQuali then\r\n    Result := tkQualifier\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncTransfer(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncTrigger(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncTrim(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkFunction\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncTsuppress(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) and IsSpecial then\r\n    Result := tkSpecial\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncUnload(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncUppercase(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkFunction\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncUse_if(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) and IsQuali then\r\n    Result := tkQualifier\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncUser_key(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) and IsQuali then\r\n    Result := tkQualifier\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncUsing(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) and IsQuali then\r\n    Result := tkQualifier\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncUtilities(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncWait(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) and IsQuali then\r\n    Result := tkQualifier\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncWhile(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncWidth(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) and IsQuali then\r\n    Result := tkQualifier\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncWith(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) and IsQuali then\r\n    Result := tkQualifier\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncWrite(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncWrite_line(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.FuncYesno_block(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkBlock\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynDmlSyn.AltFunc(Index: Integer): TtkTokenKind;\r\nbegin\r\n  Result := tkIdentifier;\r\nend;\r\n\r\nconstructor TSynDmlSyn.Create(AOwner: TComponent);\r\nbegin\r\n  inherited Create(AOwner);\r\n\r\n  fCaseSensitive := False;\r\n\r\n  fFormAttri:= TSynHighlighterAttributes.Create(SYNS_AttrForm, SYNS_FriendlyAttrForm);\r\n  fFormAttri.Style:= [fsBold];\r\n  fFormAttri.Foreground:= clBlue;\r\n  AddAttribute(fFormAttri);\r\n  fBlockAttri:= TSynHighlighterAttributes.Create(SYNS_AttrBlock, SYNS_FriendlyAttrBlock);\r\n  fBlockAttri.Style:= [fsBold];\r\n  fBlockAttri.Foreground:= clGreen;\r\n  AddAttribute(fBlockAttri);\r\n  fKeyAttri := TSynHighlighterAttributes.Create(SYNS_AttrKey, SYNS_FriendlyAttrKey);\r\n  fKeyAttri.Style:= [fsBold];\r\n  AddAttribute(fKeyAttri);\r\n  fCommentAttri := TSynHighlighterAttributes.Create(SYNS_AttrComment, SYNS_FriendlyAttrComment);\r\n  fCommentAttri.Style:= [fsBold];\r\n  fCommentAttri.Foreground:= clRed;\r\n  AddAttribute(fCommentAttri);\r\n  fQualiAttri:= TSynHighlighterAttributes.Create(SYNS_AttrQualifier, SYNS_FriendlyAttrQualifier);\r\n  fQualiAttri.Style:= [fsItalic];\r\n  fQualiAttri.Foreground:= clGreen;\r\n  AddAttribute(fQualiAttri);\r\n  fFunctionAttri:= TSynHighlighterAttributes.Create(SYNS_AttrFunction, SYNS_FriendlyAttrFunction);\r\n  fFunctionAttri.Style:= [fsItalic];\r\n  fFunctionAttri.Foreground:= clBlack;\r\n  AddAttribute(fFunctionAttri);\r\n  fVariableAttri:= TSynHighlighterAttributes.Create(SYNS_AttrVariable, SYNS_FriendlyAttrVariable);\r\n  fVariableAttri.Style:= [fsBold, fsItalic];\r\n  fVariableAttri.Foreground:= clBlack;\r\n  AddAttribute(fVariableAttri);\r\n  fSpecialAttri:= TSynHighlighterAttributes.Create(SYNS_AttrSpecialVariable, SYNS_FriendlyAttrSpecialVariable);\r\n  fSpecialAttri.Style:= [fsItalic];\r\n  fSpecialAttri.Foreground:= clBlack;\r\n  AddAttribute(fSpecialAttri);\r\n  fIdentifierAttri := TSynHighlighterAttributes.Create(SYNS_AttrIdentifier, SYNS_FriendlyAttrIdentifier);\r\n  AddAttribute(fIdentifierAttri);\r\n  fNumberAttri := TSynHighlighterAttributes.Create(SYNS_AttrNumber, SYNS_FriendlyAttrNumber);\r\n  AddAttribute(fNumberAttri);\r\n  fSpaceAttri := TSynHighlighterAttributes.Create(SYNS_AttrSpace, SYNS_FriendlyAttrSpace);\r\n  AddAttribute(fSpaceAttri);\r\n  fStringAttri := TSynHighlighterAttributes.Create(SYNS_AttrString, SYNS_FriendlyAttrString);\r\n  AddAttribute(fStringAttri);\r\n  fSymbolAttri := TSynHighlighterAttributes.Create(SYNS_AttrSymbol, SYNS_FriendlyAttrSymbol);\r\n  AddAttribute(fSymbolAttri);\r\n  SetAttributesOnChange(DefHighlightChange);\r\n\r\n  InitIdent;\r\n  fRange := rsUnknown;\r\n\r\n  fDefaultFilter := SYNS_FilterGembase;\r\nend;\r\n\r\nprocedure TSynDmlSyn.AddressOpProc;\r\nbegin\r\n  fTokenID := tkSymbol;\r\n  Inc(Run);\r\n  if fLine[Run] = '@' then Inc(Run);\r\nend;\r\n\r\nprocedure TSynDmlSyn.AsciiCharProc;\r\n\r\n  function IsAsciiChar: Boolean;\r\n  begin\r\n     case FLine[Run] of\r\n       '_', '0'..'9', 'A'..'Z', 'a'..'z':\r\n         Result := True;\r\n       else\r\n         Result := False;\r\n     end;\r\n  end;\r\n\r\nbegin\r\n  // variables...\r\n  fTokenID := tkVariable;\r\n  repeat\r\n    inc(Run);\r\n  until not IsAsciiChar;\r\nend;\r\n\r\nprocedure TSynDmlSyn.SymbolProc;\r\nbegin\r\n  inc(Run);\r\n  fTokenId := tkSymbol;\r\nend;\r\n\r\nprocedure TSynDmlSyn.CRProc;\r\nbegin\r\n  fTokenID := tkSpace;\r\n  inc(Run);\r\n  if FLine[Run] = #10 then inc(Run);\r\nend;\r\n\r\nprocedure TSynDmlSyn.GreaterProc;\r\nbegin\r\n  fTokenID := tkSymbol;\r\n  Inc(Run);\r\n  if FLine[Run] = '=' then Inc(Run);\r\nend;\r\n\r\nprocedure TSynDmlSyn.IdentProc;\r\nbegin\r\n  fTokenID := IdentKind((fLine + Run));\r\n  inc(Run, fStringLen);\r\n  while IsIdentChar(fLine[Run]) do inc(Run);\r\nend;\r\n\r\nprocedure TSynDmlSyn.LFProc;\r\nbegin\r\n  fTokenID := tkSpace;\r\n  inc(Run);\r\nend;\r\n\r\nprocedure TSynDmlSyn.LowerProc;\r\nbegin\r\n  fTokenID := tkSymbol;\r\n  inc(Run);\r\n  if (fLine[Run]= '=') or (fLine[Run]= '>') then Inc(Run);\r\nend;\r\n\r\nprocedure TSynDmlSyn.NullProc;\r\nbegin\r\n  fTokenID := tkNull;\r\n  inc(Run);\r\nend;\r\n\r\nprocedure TSynDmlSyn.NumberProc;\r\nbegin\r\n  inc(Run);\r\n  fTokenID := tkNumber;\r\n  while CharInSet(FLine[Run], ['0'..'9', '.']) do\r\n  begin\r\n    case FLine[Run] of\r\n      '.':\r\n        if FLine[Run + 1] = '.' then break;\r\n    end;\r\n    inc(Run);\r\n  end;\r\nend;\r\n\r\nprocedure TSynDmlSyn.PointProc;\r\nbegin\r\n  fTokenID := tkSymbol;\r\n  inc(Run);\r\n  if (fLine[Run]='.') or (fLine[Run]=')') then inc(Run);\r\nend;\r\n\r\nprocedure TSynDmlSyn.RemProc;\r\nvar\r\n  p: PWideChar;\r\nbegin\r\n  p := PWideChar(@fLine[Run - 1]);\r\n  while p >= fLine do\r\n  begin\r\n    if not CharInSet(p^, [#9, #32]) then\r\n    begin\r\n      inc(Run);\r\n      fTokenID := tkSymbol;\r\n      exit;\r\n    end;\r\n    Dec(p);\r\n  end;\r\n  // it is a comment...\r\n  fTokenID := tkComment;\r\n  repeat\r\n    Inc(Run);\r\n  until IsLineEnd(Run);\r\nend;\r\n\r\nprocedure TSynDmlSyn.SpaceProc;\r\nbegin\r\n  fTokenID := tkSpace;\r\n  while (fLine[Run] <= #32) and not IsLineEnd(Run) do inc(Run);\r\nend;\r\n\r\nprocedure TSynDmlSyn.StringProc;\r\nbegin\r\n  fTokenID := tkString;\r\n  if (FLine[Run + 1] = '\"') and (FLine[Run + 2] = '\"') then inc(Run, 2);\r\n  repeat\r\n    inc(Run);\r\n  until (FLine[Run] = '\"') or IsLineEnd(Run);\r\n\r\n  if FLine[Run] <> #0 then inc(Run);\r\nend;\r\n\r\nprocedure TSynDmlSyn.UnknownProc;\r\nbegin\r\n  inc(Run);\r\n  fTokenID := tkUnknown;\r\nend;\r\n\r\nprocedure TSynDmlSyn.Next;\r\nbegin\r\n  fTokenPos := Run;\r\n   case fLine[Run] of\r\n    #0: NullProc;\r\n    #10: LFProc;\r\n    #13: CRProc;\r\n    #1..#9, #11, #12, #14..#32:\r\n      SpaceProc;\r\n    '#': AsciiCharProc;\r\n    '\"': StringProc;\r\n    '0'..'9': NumberProc;\r\n    'A'..'Z', 'a'..'z', '_':\r\n      IdentProc;\r\n    '{': SymbolProc;\r\n    '}': SymbolProc;\r\n    '!': RemProc;\r\n    '.': PointProc;\r\n    '<': LowerProc;\r\n    '>': GreaterProc;\r\n    '@': AddressOpProc;\r\n    #39, '&', '('..'-', '/', ':', ';', '=', '?', '['..'^', '`', '~':\r\n      SymbolProc;\r\n  else\r\n    UnknownProc;\r\n  end;\r\n  inherited;\r\nend;\r\n\r\nfunction TSynDmlSyn.GetDefaultAttribute(Index: integer): TSynHighlighterAttributes;\r\nbegin\r\n  case Index of\r\n    SYN_ATTR_COMMENT: Result := fCommentAttri;\r\n    SYN_ATTR_IDENTIFIER: Result := fIdentifierAttri;\r\n    SYN_ATTR_KEYWORD: Result := fKeyAttri;\r\n    SYN_ATTR_STRING: Result := fStringAttri;\r\n    SYN_ATTR_WHITESPACE: Result := fSpaceAttri;\r\n    SYN_ATTR_SYMBOL: Result := fSymbolAttri;\r\n  else\r\n    Result := nil;\r\n  end;\r\nend;\r\n\r\nfunction TSynDmlSyn.GetEol: Boolean;\r\nbegin\r\n  Result := Run = fLineLen + 1;\r\nend;\r\n\r\nfunction TSynDmlSyn.GetTokenID: TtkTokenKind;\r\nbegin\r\n  Result:= fTokenId;\r\nend;\r\n\r\nfunction TSynDmlSyn.GetTokenAttribute: TSynHighlighterAttributes;\r\nbegin\r\n  case GetTokenID of\r\n    tkForm: Result := fFormAttri;\r\n    tkBlock: Result := fBlockAttri;\r\n    tkKey: Result := fKeyAttri;\r\n    tkComment: Result := fCommentAttri;\r\n    tkQualifier: Result := fQualiAttri;\r\n    tkFunction: Result := fFunctionAttri;\r\n    tkIdentifier: Result := fIdentifierAttri;\r\n    tkNumber: Result := fNumberAttri;\r\n    tkSpecial: Result := fSpecialAttri;\r\n    tkSpace: Result := fSpaceAttri;\r\n    tkString: Result := fStringAttri;\r\n    tkVariable: Result := fVariableAttri;\r\n    tkSymbol: Result := fSymbolAttri;\r\n    tkUnknown: Result := fSymbolAttri;\r\n    else Result := nil;\r\n  end;\r\nend;\r\n\r\nfunction TSynDmlSyn.GetTokenKind: integer;\r\nbegin\r\n  Result := Ord(GetTokenID);\r\nend;\r\n\r\nfunction TSynDmlSyn.GetRange: Pointer;\r\nbegin\r\n  Result := Pointer(fRange);\r\nend;\r\n\r\nprocedure TSynDmlSyn.SetRange(Value: Pointer);\r\nbegin\r\n  fRange := TRangeState(Value);\r\nend;\r\n\r\nprocedure TSynDmlSyn.ResetRange;\r\nbegin\r\n  fRange:= rsUnknown;\r\nend;\r\n\r\nfunction TSynDmlSyn.IsFilterStored: Boolean;\r\nbegin\r\n  Result := fDefaultFilter <> SYNS_FilterGembase;\r\nend;\r\n\r\nclass function TSynDmlSyn.GetLanguageName: string;\r\nbegin\r\n  Result := SYNS_LangGembase;\r\nend;\r\n\r\nclass function TSynDmlSyn.GetFriendlyLanguageName: UnicodeString;\r\nbegin\r\n  Result := SYNS_FriendlyLangGembase;\r\nend;\r\n\r\ninitialization\r\n{$IFNDEF SYN_CPPB_1}\r\n  RegisterPlaceableHighlighter(TSynDmlSyn);\r\n{$ENDIF}\r\nend.\r\n"
  },
  {
    "path": "External/SynEdit/Source/SynHighlighterEiffel.pas",
    "content": "{-------------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nCode template generated with SynGen.\r\nThe original code is: SynHighlighterEiffel.pas, released 2004-03-08.\r\nDescription: Eiffel Syntax Parser/Highlighter\r\nThe initial author of this file is Massimo Maria Ghisalberti (nissl).\r\nUnicode translation by Mal Hrz.\r\nCopyright (c) 2004, all rights reserved.\r\n\r\nContributors to the SynEdit and mwEdit projects are listed in the\r\nContributors.txt file.\r\n\r\nAlternatively, the contents of this file may be used under the terms of the\r\nGNU General Public License Version 2 or later (the \"GPL\"), in which case\r\nthe provisions of the GPL are applicable instead of those above.\r\nIf you wish to allow use of your version of this file only under the terms\r\nof the GPL and not to allow others to use your version of this file\r\nunder the MPL, indicate your decision by deleting the provisions above and\r\nreplace them with the notice and other provisions required by the GPL.\r\nIf you do not delete the provisions above, a recipient may use your version\r\nof this file under either the MPL or the GPL.\r\n\r\n$Id: SynHighlighterEiffel.pas,v 1.3.2.8 2008/09/14 16:25:00 maelh Exp $\r\n\r\nYou may retrieve the latest version of this file at the SynEdit home page,\r\nlocated at http://SynEdit.SourceForge.net\r\n\r\n-------------------------------------------------------------------------------}\r\n{\r\n@abstract(Provides an Eiffel highlighter for SynEdit)\r\n@author(Massimo Maria Ghisalberti (nissl@mammuth.it, nissl@linee.it - www.linee.it)\r\n@created(03-08-2004)\r\n@lastmod(03-08-2004)\r\nThe SynHighlighterEiffel unit provides SynEdit with an Eiffel highlighter.\r\n}\r\n\r\n{$IFNDEF QSYNHIGHLIGHTEREIFFEL}\r\nunit SynHighlighterEiffel;\r\n{$ENDIF}\r\n\r\n{$I SynEdit.inc}\r\n\r\ninterface\r\n\r\nuses\r\n{$IFDEF SYN_CLX}\r\n  QGraphics,\r\n  QSynEditTypes,\r\n  QSynEditHighlighter,\r\n  QSynUnicode,\r\n{$ELSE}\r\n  Graphics,\r\n  SynEditTypes,\r\n  SynEditHighlighter,\r\n  SynUnicode,\r\n{$ENDIF}\r\n  SysUtils,\r\n  Classes;\r\n\r\ntype\r\n  TtkTokenKind = (\r\n    tkBasicTypes,\r\n    tkComment,\r\n    tkIdentifier,\r\n    tkKey,\r\n    tkLace,\r\n    tkNull,\r\n    tkOperatorAndSymbols,\r\n    tkPredefined,\r\n    tkResultValue,\r\n    tkSpace,\r\n    tkString,\r\n    tkUnknown);\r\n\r\n  TRangeState = (rsUnKnown, rsEiffelComment, rsString, rsOperatorAndSymbolProc);\r\n\r\n  PIdentFuncTableFunc = ^TIdentFuncTableFunc;\r\n  TIdentFuncTableFunc = function (Index: Integer): TtkTokenKind of object;\r\n\r\ntype\r\n  TSynEiffelSyn = class(TSynCustomHighlighter)\r\n  private\r\n    fRange: TRangeState;\r\n    fTokenID: TtkTokenKind;\r\n    fIdentFuncTable: array[0..502] of TIdentFuncTableFunc;\r\n    fBasicTypesAttri: TSynHighlighterAttributes;\r\n    fCommentAttri: TSynHighlighterAttributes;\r\n    fIdentifierAttri: TSynHighlighterAttributes;\r\n    fKeyAttri: TSynHighlighterAttributes;\r\n    fLaceAttri: TSynHighlighterAttributes;\r\n    fOperatorAndSymbolsAttri: TSynHighlighterAttributes;\r\n    fPredefinedAttri: TSynHighlighterAttributes;\r\n    fResultValueAttri: TSynHighlighterAttributes;\r\n    fSpaceAttri: TSynHighlighterAttributes;\r\n    fStringAttri: TSynHighlighterAttributes;\r\n    function AltFunc(Index: Integer): TtkTokenKind;\r\n    function OperatorFunc(Index: Integer): TtkTokenKind;\r\n    function Func37u(Index: Integer): TtkTokenKind;\r\n    function FuncAdapt(Index: Integer): TtkTokenKind;\r\n    function FuncAlias(Index: Integer): TtkTokenKind;\r\n    function FuncAll(Index: Integer): TtkTokenKind;\r\n    function FuncAnd(Index: Integer): TtkTokenKind;\r\n    function FuncArray(Index: Integer): TtkTokenKind;\r\n    function FuncAs(Index: Integer): TtkTokenKind;\r\n    function FuncAssertion(Index: Integer): TtkTokenKind;\r\n    function FuncBit(Index: Integer): TtkTokenKind;\r\n    function FuncBoolean(Index: Integer): TtkTokenKind;\r\n    function FuncCharacter(Index: Integer): TtkTokenKind;\r\n    function FuncCheck(Index: Integer): TtkTokenKind;\r\n    function FuncClass(Index: Integer): TtkTokenKind;\r\n    function FuncCluster(Index: Integer): TtkTokenKind;\r\n    function FuncColon(Index: Integer): TtkTokenKind;\r\n    function FuncComma(Index: Integer): TtkTokenKind;\r\n    function FuncCreation(Index: Integer): TtkTokenKind;\r\n    function FuncCurrent(Index: Integer): TtkTokenKind;\r\n    function FuncDebug(Index: Integer): TtkTokenKind;\r\n    function FuncDefault(Index: Integer): TtkTokenKind;\r\n    function FuncDeferred(Index: Integer): TtkTokenKind;\r\n    function FuncDo(Index: Integer): TtkTokenKind;\r\n    function FuncDouble(Index: Integer): TtkTokenKind;\r\n    function FuncElse(Index: Integer): TtkTokenKind;\r\n    function FuncElseif(Index: Integer): TtkTokenKind;\r\n    function FuncEnd(Index: Integer): TtkTokenKind;\r\n    function FuncEnsure(Index: Integer): TtkTokenKind;\r\n    function FuncExclude(Index: Integer): TtkTokenKind;\r\n    function FuncExecutable(Index: Integer): TtkTokenKind;\r\n    function FuncExpanded(Index: Integer): TtkTokenKind;\r\n    function FuncExport(Index: Integer): TtkTokenKind;\r\n    function FuncExternal(Index: Integer): TtkTokenKind;\r\n    function FuncFalse(Index: Integer): TtkTokenKind;\r\n    function FuncFeature(Index: Integer): TtkTokenKind;\r\n    function FuncFrom(Index: Integer): TtkTokenKind;\r\n    function FuncFrozen(Index: Integer): TtkTokenKind;\r\n    function FuncGenerate(Index: Integer): TtkTokenKind;\r\n    function FuncIdentifier(Index: Integer): TtkTokenKind;\r\n    function FuncIf(Index: Integer): TtkTokenKind;\r\n    function FuncIgnore(Index: Integer): TtkTokenKind;\r\n    function FuncImplies(Index: Integer): TtkTokenKind;\r\n    function FuncInclude(Index: Integer): TtkTokenKind;\r\n    function FuncInclude95path(Index: Integer): TtkTokenKind;\r\n    function FuncIndexing(Index: Integer): TtkTokenKind;\r\n    function FuncInfix(Index: Integer): TtkTokenKind;\r\n    function FuncInherit(Index: Integer): TtkTokenKind;\r\n    function FuncInspect(Index: Integer): TtkTokenKind;\r\n    function FuncInteger(Index: Integer): TtkTokenKind;\r\n    function FuncInvariant(Index: Integer): TtkTokenKind;\r\n    function FuncIs(Index: Integer): TtkTokenKind;\r\n    function FuncLike(Index: Integer): TtkTokenKind;\r\n    function FuncLocal(Index: Integer): TtkTokenKind;\r\n    function FuncLoop(Index: Integer): TtkTokenKind;\r\n    function FuncMake(Index: Integer): TtkTokenKind;\r\n    function FuncNo(Index: Integer): TtkTokenKind;\r\n    function FuncNot(Index: Integer): TtkTokenKind;\r\n    function FuncObject(Index: Integer): TtkTokenKind;\r\n    function FuncObsolete(Index: Integer): TtkTokenKind;\r\n    function FuncOld(Index: Integer): TtkTokenKind;\r\n    function FuncOnce(Index: Integer): TtkTokenKind;\r\n    function FuncOptimize(Index: Integer): TtkTokenKind;\r\n    function FuncOption(Index: Integer): TtkTokenKind;\r\n    function FuncOr(Index: Integer): TtkTokenKind;\r\n    function FuncPointer(Index: Integer): TtkTokenKind;\r\n    function FuncPrecompiled(Index: Integer): TtkTokenKind;\r\n    function FuncPrecursor(Index: Integer): TtkTokenKind;\r\n    function FuncPrefix(Index: Integer): TtkTokenKind;\r\n    function FuncReal(Index: Integer): TtkTokenKind;\r\n    function FuncRedefine(Index: Integer): TtkTokenKind;\r\n    function FuncRename(Index: Integer): TtkTokenKind;\r\n    function FuncRequire(Index: Integer): TtkTokenKind;\r\n    function FuncRescue(Index: Integer): TtkTokenKind;\r\n    function FuncResult(Index: Integer): TtkTokenKind;\r\n    function FuncRetry(Index: Integer): TtkTokenKind;\r\n    function FuncRoot(Index: Integer): TtkTokenKind;\r\n    function FuncSelect(Index: Integer): TtkTokenKind;\r\n    function FuncSeparate(Index: Integer): TtkTokenKind;\r\n    function FuncString(Index: Integer): TtkTokenKind;\r\n    function FuncStrip(Index: Integer): TtkTokenKind;\r\n    function FuncSystem(Index: Integer): TtkTokenKind;\r\n    function FuncThen(Index: Integer): TtkTokenKind;\r\n    function FuncTrace(Index: Integer): TtkTokenKind;\r\n    function FuncTrue(Index: Integer): TtkTokenKind;\r\n    function FuncUndefine(Index: Integer): TtkTokenKind;\r\n    function FuncUnique(Index: Integer): TtkTokenKind;\r\n    function FuncUntil(Index: Integer): TtkTokenKind;\r\n    function FuncUse(Index: Integer): TtkTokenKind;\r\n    function FuncVariant(Index: Integer): TtkTokenKind;\r\n    function FuncVisible(Index: Integer): TtkTokenKind;\r\n    function FuncVoid(Index: Integer): TtkTokenKind;\r\n    function FuncWhen(Index: Integer): TtkTokenKind;\r\n    function FuncXor(Index: Integer): TtkTokenKind;\r\n    function FuncYes(Index: Integer): TtkTokenKind;\r\n    function HashKey(Str: PWideChar): Cardinal;\r\n    function IdentKind(MayBe: PWideChar): TtkTokenKind;\r\n    procedure IdentProc;\r\n    procedure InitIdent;\r\n    procedure OperatorAndSymbolProc;\r\n    procedure UnknownProc;\r\n    procedure NullProc;\r\n    procedure SpaceProc;\r\n    procedure CRProc;\r\n    procedure LFProc;\r\n    procedure EiffelCommentOpenProc;\r\n    procedure EiffelCommentProc;\r\n    procedure StringOpenProc;\r\n    procedure StringProc;\r\n  protected\r\n    function GetSampleSource: UnicodeString; override;\r\n    function IsFilterStored: Boolean; override;\r\n  public\r\n    constructor Create(AOwner: TComponent); override;\r\n    class function GetLanguageName: string; override;\r\n    class function GetFriendlyLanguageName: UnicodeString; override;\r\n    function GetRange: Pointer; override;\r\n    procedure ResetRange; override;\r\n    procedure SetRange(Value: Pointer); override;\r\n    function GetDefaultAttribute(Index: integer): TSynHighlighterAttributes; override;\r\n    function GetEol: Boolean; override;\r\n    function GetKeyWords(TokenKind: Integer): UnicodeString; override;\r\n    function GetTokenID: TtkTokenKind;\r\n    function GetTokenAttribute: TSynHighlighterAttributes; override;\r\n    function GetTokenKind: integer; override;\r\n    procedure Next; override;\r\n    function IsOperatorChar(AChar: WideChar): Boolean;\r\n  published\r\n    property BasicTypesAttri: TSynHighlighterAttributes read fBasicTypesAttri write fBasicTypesAttri;\r\n    property CommentAttri: TSynHighlighterAttributes read fCommentAttri write fCommentAttri;\r\n    property IdentifierAttri: TSynHighlighterAttributes read fIdentifierAttri write fIdentifierAttri;\r\n    property KeyAttri: TSynHighlighterAttributes read fKeyAttri write fKeyAttri;\r\n    property LaceAttri: TSynHighlighterAttributes read fLaceAttri write fLaceAttri;\r\n    property OperatorAndSymbolsAttri: TSynHighlighterAttributes read fOperatorAndSymbolsAttri write fOperatorAndSymbolsAttri;\r\n    property PredefinedAttri: TSynHighlighterAttributes read fPredefinedAttri write fPredefinedAttri;\r\n    property ResultValueAttri: TSynHighlighterAttributes read fResultValueAttri write fResultValueAttri;\r\n    property SpaceAttri: TSynHighlighterAttributes read fSpaceAttri write fSpaceAttri;\r\n    property StringAttri: TSynHighlighterAttributes read fStringAttri write fStringAttri;\r\n  end;\r\n\r\nimplementation\r\n\r\nuses\r\n{$IFDEF SYN_CLX}\r\n  QSynEditStrConst;\r\n{$ELSE}\r\n  SynEditStrConst;\r\n{$ENDIF}\r\n\r\nconst\r\n  KeyWords: array[0..118] of UnicodeString = (\r\n    '-', '!', '#', '$', '%u', '&', '(', ')', '*', '.', '/', '//', '/=', ':', \r\n    ':=', ';', '@', '[', '\\\\', ']', '^', '|', '+', '<', '<>', '=', '>', 'adapt', \r\n    'alias', 'all', 'and', 'array', 'as', 'assertion', 'bit', 'boolean', \r\n    'character', 'check', 'class', 'cluster', 'colon', 'comma', 'creation', \r\n    'current', 'debug', 'default', 'deferred', 'do', 'double', 'else', 'elseif', \r\n    'end', 'ensure', 'exclude', 'executable', 'expanded', 'export', 'external', \r\n    'false', 'feature', 'from', 'frozen', 'generate', 'identifier', 'if', \r\n    'ignore', 'implies', 'include', 'include_path', 'indexing', 'infix', \r\n    'inherit', 'inspect', 'integer', 'invariant', 'is', 'like', 'local', 'loop', \r\n    'make', 'no', 'not', 'object', 'obsolete', 'old', 'once', 'optimize', \r\n    'option', 'or', 'pointer', 'precompiled', 'precursor', 'prefix', 'real', \r\n    'redefine', 'rename', 'require', 'rescue', 'result', 'retry', 'root', \r\n    'select', 'separate', 'string', 'strip', 'system', 'then', 'trace', 'true', \r\n    'undefine', 'unique', 'until', 'use', 'variant', 'visible', 'void', 'when', \r\n    'xor', 'yes' \r\n  );\r\n\r\n  KeyIndices: array[0..502] of Integer = (\r\n    -1, 49, -1, -1, -1, 97, 69, 85, -1, -1, -1, 106, -1, -1, 37, -1, -1, 63, -1, \r\n    92, -1, -1, -1, -1, 108, 82, 16, -1, -1, -1, -1, -1, 86, -1, 0, -1, -1, 66, \r\n    -1, -1, -1, -1, 91, 98, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 30, 13, -1, \r\n    -1, -1, -1, -1, -1, -1, 61, -1, -1, -1, -1, -1, -1, -1, 76, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, 58, -1, -1, -1, -1, 110, -1, 1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 31, -1, -1, -1, -1, -1, -1, -1, 9, \r\n    -1, -1, -1, -1, -1, -1, 68, 88, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, 15, 105, -1, -1, -1, 51, -1, -1, 6, -1, 96, -1, -1, 17, -1, -1, 55, -1, \r\n    -1, -1, -1, -1, 117, -1, -1, -1, 77, -1, -1, -1, -1, -1, -1, 56, -1, -1, -1, \r\n    -1, 62, -1, 59, -1, -1, -1, -1, -1, -1, 79, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, 83, 10, 95, -1, 113, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, 65, 18, 23, -1, -1, -1, 35, -1, -1, -1, 7, -1, -1, 32, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 21, 90, -1, 103, -1, -1, 80, -1, \r\n    -1, -1, -1, 2, -1, 34, -1, -1, -1, -1, -1, -1, 41, -1, 27, 112, -1, -1, -1, \r\n    33, -1, 44, -1, 50, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 104, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, 25, -1, -1, -1, 93, -1, -1, -1, 8, 46, 102, -1, \r\n    -1, 19, 87, -1, -1, -1, -1, 43, -1, -1, -1, -1, -1, -1, -1, 84, 53, -1, -1, \r\n    -1, 71, -1, -1, 11, -1, 3, 107, 67, -1, 64, 47, -1, -1, -1, -1, -1, 24, -1, \r\n    -1, -1, 114, -1, -1, -1, 116, -1, -1, -1, -1, 81, 75, -1, -1, -1, -1, -1, \r\n    -1, -1, 100, -1, -1, -1, -1, -1, 54, -1, -1, 26, 115, -1, -1, -1, -1, -1, \r\n    78, 22, 36, -1, 74, -1, 20, -1, -1, 42, -1, 99, -1, -1, -1, -1, -1, -1, -1, \r\n    73, -1, 52, -1, -1, 29, -1, -1, -1, -1, -1, -1, -1, -1, 60, -1, 4, 94, -1, \r\n    -1, 40, -1, -1, 39, -1, -1, -1, -1, 45, -1, 12, -1, -1, -1, 72, 38, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 109, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, 28, 48, -1, -1, -1, -1, -1, 101, -1, 118, \r\n    -1, -1, 57, -1, -1, -1, -1, -1, 14, -1, -1, -1, -1, -1, -1, 5, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, 70, -1, 89, -1, -1, 111, -1 \r\n  );\r\n\r\n{$Q-}\r\nfunction TSynEiffelSyn.HashKey(Str: PWideChar): Cardinal;\r\nbegin\r\n  Result := 0;\r\n  while IsIdentChar(Str^) or IsOperatorChar(Str^) do\r\n  begin\r\n    Result := Result * 543 + Ord(Str^) * 79;\r\n    inc(Str);\r\n  end;\r\n  Result := Result mod 503;\r\n  fStringLen := Str - fToIdent;\r\nend;\r\n{$Q+}\r\n\r\nfunction TSynEiffelSyn.IdentKind(MayBe: PWideChar): TtkTokenKind;\r\nvar\r\n  Key: Cardinal;\r\nbegin\r\n  fToIdent := MayBe;\r\n  Key := HashKey(MayBe);\r\n  if Key <= High(fIdentFuncTable) then\r\n    Result := fIdentFuncTable[Key](KeyIndices[Key])\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nprocedure TSynEiffelSyn.InitIdent;\r\nvar\r\n  i: Integer;\r\nbegin\r\n  for i := Low(fIdentFuncTable) to High(fIdentFuncTable) do\r\n    if KeyIndices[i] = -1 then\r\n      fIdentFuncTable[i] := AltFunc;\r\n\r\n  fIdentFuncTable[34] := OperatorFunc;\r\n  fIdentFuncTable[92] := OperatorFunc;\r\n  fIdentFuncTable[250] := OperatorFunc;\r\n  fIdentFuncTable[329] := OperatorFunc;\r\n  fIdentFuncTable[413] := Func37u;\r\n  fIdentFuncTable[487] := OperatorFunc;\r\n  fIdentFuncTable[142] := OperatorFunc;\r\n  fIdentFuncTable[221] := OperatorFunc;\r\n  fIdentFuncTable[300] := OperatorFunc;\r\n  fIdentFuncTable[113] := OperatorFunc;\r\n  fIdentFuncTable[192] := OperatorFunc;\r\n  fIdentFuncTable[327] := OperatorFunc;\r\n  fIdentFuncTable[427] := OperatorFunc;\r\n  fIdentFuncTable[55] := OperatorFunc;\r\n  fIdentFuncTable[480] := OperatorFunc;\r\n  fIdentFuncTable[134] := OperatorFunc;\r\n  fIdentFuncTable[26] := OperatorFunc;\r\n  fIdentFuncTable[147] := OperatorFunc;\r\n  fIdentFuncTable[212] := OperatorFunc;\r\n  fIdentFuncTable[305] := OperatorFunc;\r\n  fIdentFuncTable[384] := OperatorFunc;\r\n  fIdentFuncTable[239] := OperatorFunc;\r\n  fIdentFuncTable[379] := OperatorFunc;\r\n  fIdentFuncTable[213] := OperatorFunc;\r\n  fIdentFuncTable[340] := OperatorFunc;\r\n  fIdentFuncTable[292] := OperatorFunc;\r\n  fIdentFuncTable[371] := OperatorFunc;\r\n  fIdentFuncTable[261] := FuncAdapt;\r\n  fIdentFuncTable[462] := FuncAlias;\r\n  fIdentFuncTable[402] := FuncAll;\r\n  fIdentFuncTable[54] := FuncAnd;\r\n  fIdentFuncTable[105] := FuncArray;\r\n  fIdentFuncTable[224] := FuncAs;\r\n  fIdentFuncTable[266] := FuncAssertion;\r\n  fIdentFuncTable[252] := FuncBit;\r\n  fIdentFuncTable[217] := FuncBoolean;\r\n  fIdentFuncTable[380] := FuncCharacter;\r\n  fIdentFuncTable[14] := FuncCheck;\r\n  fIdentFuncTable[432] := FuncClass;\r\n  fIdentFuncTable[420] := FuncCluster;\r\n  fIdentFuncTable[417] := FuncColon;\r\n  fIdentFuncTable[259] := FuncComma;\r\n  fIdentFuncTable[387] := FuncCreation;\r\n  fIdentFuncTable[311] := FuncCurrent;\r\n  fIdentFuncTable[268] := FuncDebug;\r\n  fIdentFuncTable[425] := FuncDefault;\r\n  fIdentFuncTable[301] := FuncDeferred;\r\n  fIdentFuncTable[334] := FuncDo;\r\n  fIdentFuncTable[463] := FuncDouble;\r\n  fIdentFuncTable[1] := FuncElse;\r\n  fIdentFuncTable[270] := FuncElseif;\r\n  fIdentFuncTable[139] := FuncEnd;\r\n  fIdentFuncTable[399] := FuncEnsure;\r\n  fIdentFuncTable[320] := FuncExclude;\r\n  fIdentFuncTable[368] := FuncExecutable;\r\n  fIdentFuncTable[150] := FuncExpanded;\r\n  fIdentFuncTable[167] := FuncExport;\r\n  fIdentFuncTable[474] := FuncExternal;\r\n  fIdentFuncTable[85] := FuncFalse;\r\n  fIdentFuncTable[174] := FuncFeature;\r\n  fIdentFuncTable[411] := FuncFrom;\r\n  fIdentFuncTable[63] := FuncFrozen;\r\n  fIdentFuncTable[172] := FuncGenerate;\r\n  fIdentFuncTable[17] := FuncIdentifier;\r\n  fIdentFuncTable[333] := FuncIf;\r\n  fIdentFuncTable[211] := FuncIgnore;\r\n  fIdentFuncTable[37] := FuncImplies;\r\n  fIdentFuncTable[331] := FuncInclude;\r\n  fIdentFuncTable[120] := FuncInclude95path;\r\n  fIdentFuncTable[6] := FuncIndexing;\r\n  fIdentFuncTable[496] := FuncInfix;\r\n  fIdentFuncTable[324] := FuncInherit;\r\n  fIdentFuncTable[431] := FuncInspect;\r\n  fIdentFuncTable[397] := FuncInteger;\r\n  fIdentFuncTable[382] := FuncInvariant;\r\n  fIdentFuncTable[354] := FuncIs;\r\n  fIdentFuncTable[71] := FuncLike;\r\n  fIdentFuncTable[160] := FuncLocal;\r\n  fIdentFuncTable[378] := FuncLoop;\r\n  fIdentFuncTable[181] := FuncMake;\r\n  fIdentFuncTable[245] := FuncNo;\r\n  fIdentFuncTable[353] := FuncNot;\r\n  fIdentFuncTable[25] := FuncObject;\r\n  fIdentFuncTable[191] := FuncObsolete;\r\n  fIdentFuncTable[319] := FuncOld;\r\n  fIdentFuncTable[7] := FuncOnce;\r\n  fIdentFuncTable[32] := FuncOptimize;\r\n  fIdentFuncTable[306] := FuncOption;\r\n  fIdentFuncTable[121] := FuncOr;\r\n  fIdentFuncTable[498] := FuncPointer;\r\n  fIdentFuncTable[240] := FuncPrecompiled;\r\n  fIdentFuncTable[42] := FuncPrecursor;\r\n  fIdentFuncTable[19] := FuncPrefix;\r\n  fIdentFuncTable[296] := FuncReal;\r\n  fIdentFuncTable[414] := FuncRedefine;\r\n  fIdentFuncTable[193] := FuncRename;\r\n  fIdentFuncTable[144] := FuncRequire;\r\n  fIdentFuncTable[5] := FuncRescue;\r\n  fIdentFuncTable[43] := FuncResult;\r\n  fIdentFuncTable[389] := FuncRetry;\r\n  fIdentFuncTable[362] := FuncRoot;\r\n  fIdentFuncTable[469] := FuncSelect;\r\n  fIdentFuncTable[302] := FuncSeparate;\r\n  fIdentFuncTable[242] := FuncString;\r\n  fIdentFuncTable[282] := FuncStrip;\r\n  fIdentFuncTable[135] := FuncSystem;\r\n  fIdentFuncTable[11] := FuncThen;\r\n  fIdentFuncTable[330] := FuncTrace;\r\n  fIdentFuncTable[24] := FuncTrue;\r\n  fIdentFuncTable[452] := FuncUndefine;\r\n  fIdentFuncTable[90] := FuncUnique;\r\n  fIdentFuncTable[501] := FuncUntil;\r\n  fIdentFuncTable[262] := FuncUse;\r\n  fIdentFuncTable[195] := FuncVariant;\r\n  fIdentFuncTable[344] := FuncVisible;\r\n  fIdentFuncTable[372] := FuncVoid;\r\n  fIdentFuncTable[348] := FuncWhen;\r\n  fIdentFuncTable[156] := FuncXor;\r\n  fIdentFuncTable[471] := FuncYes;\r\nend;\r\n\r\nfunction TSynEiffelSyn.AltFunc(Index: Integer): TtkTokenKind;\r\nbegin\r\n  Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynEiffelSyn.OperatorFunc(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkOperatorAndSymbols\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynEiffelSyn.Func37u(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkPredefined\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynEiffelSyn.FuncAdapt(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkLace\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynEiffelSyn.FuncAlias(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynEiffelSyn.FuncAll(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynEiffelSyn.FuncAnd(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynEiffelSyn.FuncArray(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkBasicTypes\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynEiffelSyn.FuncAs(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynEiffelSyn.FuncAssertion(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkLace\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynEiffelSyn.FuncBit(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkPredefined\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynEiffelSyn.FuncBoolean(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkBasicTypes\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynEiffelSyn.FuncCharacter(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkBasicTypes\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynEiffelSyn.FuncCheck(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynEiffelSyn.FuncClass(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynEiffelSyn.FuncCluster(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkLace\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynEiffelSyn.FuncColon(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkLace\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynEiffelSyn.FuncComma(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkLace\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynEiffelSyn.FuncCreation(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynEiffelSyn.FuncCurrent(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkPredefined\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynEiffelSyn.FuncDebug(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynEiffelSyn.FuncDefault(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkLace\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynEiffelSyn.FuncDeferred(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynEiffelSyn.FuncDo(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynEiffelSyn.FuncDouble(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkBasicTypes\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynEiffelSyn.FuncElse(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynEiffelSyn.FuncElseif(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynEiffelSyn.FuncEnd(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynEiffelSyn.FuncEnsure(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynEiffelSyn.FuncExclude(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkLace\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynEiffelSyn.FuncExecutable(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkLace\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynEiffelSyn.FuncExpanded(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynEiffelSyn.FuncExport(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynEiffelSyn.FuncExternal(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynEiffelSyn.FuncFalse(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkPredefined\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynEiffelSyn.FuncFeature(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynEiffelSyn.FuncFrom(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynEiffelSyn.FuncFrozen(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynEiffelSyn.FuncGenerate(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkLace\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynEiffelSyn.FuncIdentifier(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkLace\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynEiffelSyn.FuncIf(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynEiffelSyn.FuncIgnore(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkLace\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynEiffelSyn.FuncImplies(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynEiffelSyn.FuncInclude(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkLace\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynEiffelSyn.FuncInclude95path(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkLace\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynEiffelSyn.FuncIndexing(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynEiffelSyn.FuncInfix(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynEiffelSyn.FuncInherit(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynEiffelSyn.FuncInspect(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynEiffelSyn.FuncInteger(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkBasicTypes\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynEiffelSyn.FuncInvariant(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynEiffelSyn.FuncIs(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynEiffelSyn.FuncLike(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynEiffelSyn.FuncLocal(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynEiffelSyn.FuncLoop(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynEiffelSyn.FuncMake(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkLace\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynEiffelSyn.FuncNo(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkLace\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynEiffelSyn.FuncNot(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynEiffelSyn.FuncObject(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkLace\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynEiffelSyn.FuncObsolete(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynEiffelSyn.FuncOld(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynEiffelSyn.FuncOnce(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynEiffelSyn.FuncOptimize(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkLace\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynEiffelSyn.FuncOption(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkLace\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynEiffelSyn.FuncOr(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynEiffelSyn.FuncPointer(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkBasicTypes\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynEiffelSyn.FuncPrecompiled(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkLace\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynEiffelSyn.FuncPrecursor(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkPredefined\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynEiffelSyn.FuncPrefix(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynEiffelSyn.FuncReal(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkBasicTypes\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynEiffelSyn.FuncRedefine(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynEiffelSyn.FuncRename(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynEiffelSyn.FuncRequire(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynEiffelSyn.FuncRescue(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynEiffelSyn.FuncResult(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkResultValue\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynEiffelSyn.FuncRetry(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynEiffelSyn.FuncRoot(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkLace\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynEiffelSyn.FuncSelect(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynEiffelSyn.FuncSeparate(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynEiffelSyn.FuncString(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkBasicTypes\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynEiffelSyn.FuncStrip(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkPredefined\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynEiffelSyn.FuncSystem(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkLace\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynEiffelSyn.FuncThen(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynEiffelSyn.FuncTrace(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkLace\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynEiffelSyn.FuncTrue(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkPredefined\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynEiffelSyn.FuncUndefine(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynEiffelSyn.FuncUnique(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkPredefined\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynEiffelSyn.FuncUntil(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynEiffelSyn.FuncUse(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkLace\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynEiffelSyn.FuncVariant(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynEiffelSyn.FuncVisible(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkLace\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynEiffelSyn.FuncVoid(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkPredefined\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynEiffelSyn.FuncWhen(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynEiffelSyn.FuncXor(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynEiffelSyn.FuncYes(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkLace\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nprocedure TSynEiffelSyn.SpaceProc;\r\nbegin\r\n  inc(Run);\r\n  fTokenID := tkSpace;\r\n  while (FLine[Run] <= #32) and not IsLineEnd(Run) do inc(Run);\r\nend;\r\n\r\nprocedure TSynEiffelSyn.NullProc;\r\nbegin\r\n  fTokenID := tkNull;\r\n  inc(Run);\r\nend;\r\n\r\nprocedure TSynEiffelSyn.CRProc;\r\nbegin\r\n  fTokenID := tkSpace;\r\n  inc(Run);\r\n  if fLine[Run] = #10 then\r\n    inc(Run);\r\nend;\r\n\r\nprocedure TSynEiffelSyn.LFProc;\r\nbegin\r\n  fTokenID := tkSpace;\r\n  inc(Run);\r\nend;\r\n\r\nprocedure TSynEiffelSyn.OperatorAndSymbolProc;\r\nbegin\r\n  fTokenID := tkIdentifier;\r\n  if fLine[Run] = #33 then\r\n    begin\r\n      fRange := rsOperatorAndSymbolProc;\r\n      fTokenID := tkOperatorAndSymbols;\r\n      Inc(Run);\r\n      Exit;\r\n    end;\r\n  if CharInSet(fLine[Run], [#35..#44]) then\r\n    begin\r\n      fRange := rsOperatorAndSymbolProc;\r\n      fTokenID := tkOperatorAndSymbols;\r\n      Inc(Run);\r\n      Exit;\r\n    end;\r\n  if CharInSet(fLine[Run], [#46..#47]) then\r\n    begin\r\n      fRange := rsOperatorAndSymbolProc;\r\n      fTokenID := tkOperatorAndSymbols;\r\n      Inc(Run);\r\n      Exit;\r\n    end;\r\n  if CharInSet(fLine[Run], [#58..#64]) then\r\n    begin\r\n      fRange := rsOperatorAndSymbolProc;\r\n      fTokenID := tkOperatorAndSymbols;\r\n      Inc(Run);\r\n      Exit;\r\n    end;\r\n  if CharInSet(fLine[Run], [#91..#96]) then\r\n    begin\r\n      fRange := rsOperatorAndSymbolProc;\r\n      fTokenID := tkOperatorAndSymbols;\r\n      Inc(Run);\r\n      Exit;\r\n    end;\r\n  if CharInSet(fLine[Run], [#123..#127]) then\r\n    begin\r\n      fRange := rsOperatorAndSymbolProc;\r\n      fTokenID := tkOperatorAndSymbols;\r\n      Inc(Run);\r\n      Exit;\r\n    end;\r\nend;\r\n\r\nprocedure TSynEiffelSyn.EiffelCommentOpenProc;\r\nbegin\r\n  Inc(Run);\r\n  if (fLine[Run - 1] = '-') and (fLine[Run] = '-') then\r\n    begin\r\n      fRange := rsEiffelComment;\r\n      EiffelCommentProc;\r\n      fTokenID := tkComment;\r\n    end\r\n  else\r\n    fTokenID := tkOperatorAndSymbols;\r\nend;\r\n\r\nprocedure TSynEiffelSyn.EiffelCommentProc;\r\nbegin\r\n  fTokenID := tkComment;\r\n  repeat\r\n    if not IsLineEnd(Run) then\r\n      Inc(Run);\r\n  until IsLineEnd(Run);\r\nend;\r\n\r\nprocedure TSynEiffelSyn.StringOpenProc;\r\nbegin\r\n  Inc(Run);\r\n  fRange := rsString;\r\n  StringProc;\r\n  fTokenID := tkString;\r\nend;\r\n\r\nprocedure TSynEiffelSyn.StringProc;\r\nbegin\r\n  fTokenID := tkString;\r\n  repeat\r\n    if (fLine[Run] = '\"') then\r\n      begin\r\n        Inc(Run, 1);\r\n        fRange := rsUnKnown;\r\n        Break;\r\n      end;\r\n    if not IsLineEnd(Run) then\r\n      Inc(Run);\r\n  until IsLineEnd(Run);\r\nend;\r\n\r\nconstructor TSynEiffelSyn.Create(AOwner: TComponent);\r\nbegin\r\n  inherited Create(AOwner);\r\n\r\n  fCaseSensitive := False;\r\n\r\n  fBasicTypesAttri := TSynHighLighterAttributes.Create(SYNS_AttrBasicTypes, SYNS_FriendlyAttrBasicTypes);\r\n  fBasicTypesAttri.Style := [fsBold];\r\n  fBasicTypesAttri.Foreground := clBlue;\r\n  AddAttribute(fBasicTypesAttri);\r\n\r\n  fCommentAttri := TSynHighLighterAttributes.Create(SYNS_AttrComment, SYNS_FriendlyAttrComment);\r\n  fCommentAttri.Style := [fsItalic];\r\n  fCommentAttri.Foreground := clTeal;\r\n  AddAttribute(fCommentAttri);\r\n\r\n  fIdentifierAttri := TSynHighLighterAttributes.Create(SYNS_AttrIdentifier, SYNS_FriendlyAttrIdentifier);\r\n  fIdentifierAttri.Foreground := clMaroon;\r\n  AddAttribute(fIdentifierAttri);\r\n\r\n  fKeyAttri := TSynHighLighterAttributes.Create(SYNS_AttrReservedWord, SYNS_FriendlyAttrReservedWord);\r\n  fKeyAttri.Style := [fsBold];\r\n  fKeyAttri.Foreground := clNavy;\r\n  AddAttribute(fKeyAttri);\r\n\r\n  fLaceAttri := TSynHighLighterAttributes.Create(SYNS_AttrLace, SYNS_FriendlyAttrLace);\r\n  fLaceAttri.Style := [fsBold];\r\n  fLaceAttri.Foreground := clNavy;\r\n  AddAttribute(fLaceAttri);\r\n\r\n  fOperatorAndSymbolsAttri := TSynHighLighterAttributes.Create(SYNS_AttrOperatorAndSymbols, SYNS_FriendlyAttrOperatorAndSymbols);\r\n  fOperatorAndSymbolsAttri.Style := [fsBold];\r\n  fOperatorAndSymbolsAttri.Foreground := clOlive;\r\n  AddAttribute(fOperatorAndSymbolsAttri);\r\n\r\n  fPredefinedAttri := TSynHighLighterAttributes.Create(SYNS_AttrPredefined, SYNS_FriendlyAttrPredefined);\r\n  fPredefinedAttri.Style := [fsBold];\r\n  fPredefinedAttri.Foreground := clRed;\r\n  AddAttribute(fPredefinedAttri);\r\n\r\n  fResultValueAttri := TSynHighLighterAttributes.Create(SYNS_AttrResultValue, SYNS_FriendlyAttrResultValue);\r\n  fResultValueAttri.Style := [fsBold];\r\n  fResultValueAttri.Foreground := clPurple;\r\n  AddAttribute(fResultValueAttri);\r\n\r\n  fSpaceAttri := TSynHighLighterAttributes.Create(SYNS_AttrSpace, SYNS_FriendlyAttrSpace);\r\n  AddAttribute(fSpaceAttri);\r\n\r\n  fStringAttri := TSynHighLighterAttributes.Create(SYNS_AttrString, SYNS_FriendlyAttrString);\r\n  fStringAttri.Style := [fsItalic];\r\n  fStringAttri.Foreground := clGray;\r\n  AddAttribute(fStringAttri);\r\n\r\n  SetAttributesOnChange(DefHighlightChange);\r\n  InitIdent;\r\n  fDefaultFilter := SYNS_FilterEiffel;\r\n  fRange := rsUnknown;\r\nend;\r\n\r\nprocedure TSynEiffelSyn.IdentProc;\r\nbegin\r\n  fTokenID := IdentKind(fLine + Run);\r\n  inc(Run, fStringLen);\r\n  while IsIdentChar(fLine[Run]) do\r\n    Inc(Run);\r\nend;\r\n\r\nprocedure TSynEiffelSyn.UnknownProc;\r\nbegin\r\n  inc(Run);\r\n  fTokenID := tkUnknown;\r\nend;\r\n\r\nprocedure TSynEiffelSyn.Next;\r\nbegin\r\n  fTokenPos := Run;\r\n  fRange := rsUnknown;\r\n  case fLine[Run] of\r\n    #33, #35..#44, #46..#47, #58..#64, #91..#96, #123..#127: OperatorAndSymbolProc;\r\n    #0: NullProc;\r\n    #10: LFProc;\r\n    #13: CRProc;\r\n    '-': EiffelCommentOpenProc;\r\n    '\"': StringOpenProc;\r\n    #1..#9, #11, #12, #14..#32: SpaceProc;\r\n    'A'..'Z', 'a'..'z': IdentProc;\r\n    else UnknownProc;\r\n  end;\r\n  inherited;\r\nend;\r\n\r\nfunction TSynEiffelSyn.GetDefaultAttribute(Index: integer): TSynHighLighterAttributes;\r\nbegin\r\n  case Index of\r\n    SYN_ATTR_COMMENT: Result := fCommentAttri;\r\n    SYN_ATTR_IDENTIFIER: Result := fIdentifierAttri;\r\n    SYN_ATTR_KEYWORD: Result := fKeyAttri;\r\n    SYN_ATTR_STRING: Result := fStringAttri;\r\n    SYN_ATTR_WHITESPACE: Result := fSpaceAttri;\r\n    else Result := nil;\r\n  end;\r\nend;\r\n\r\nfunction TSynEiffelSyn.GetEol: Boolean;\r\nbegin\r\n  Result := Run = fLineLen + 1;\r\nend;\r\n\r\nfunction TSynEiffelSyn.GetKeyWords(TokenKind: Integer): UnicodeString;\r\nbegin\r\n  Result :=\r\n    '-,!,#,$,%U,&,(,),*,.,/,//,/=,:,:=,;,@,[,\\\\,],^,|,+,<,<>,=,>,adapt,ali' +\r\n    'as,all,and,Array,as,assertion,BIT,boolean,character,check,class,cluste' +\r\n    'r,colon,comma,creation,current,debug,default,deferred,do,double,else,e' +\r\n    'lseif,end,ensure,exclude,executable,expanded,export,external,false,fea' +\r\n    'ture,from,frozen,generate,identifier,if,ignore,implies,include,include' +\r\n    '_path,indexing,infix,inherit,inspect,integer,invariant,is,like,local,l' +\r\n    'oop,make,no,not,object,obsolete,old,once,optimize,option,or,pointer,pr' +\r\n    'ecompiled,precursor,prefix,real,redefine,rename,require,rescue,result,' +\r\n    'retry,root,select,separate,string,strip,system,then,trace,true,undefin' +\r\n    'e,unique,until,use,variant,visible,void,when,xor,yes';\r\nend;\r\n\r\nfunction TSynEiffelSyn.GetTokenID: TtkTokenKind;\r\nbegin\r\n  Result := fTokenId;\r\nend;\r\n\r\nfunction TSynEiffelSyn.GetTokenAttribute: TSynHighLighterAttributes;\r\nbegin\r\n  case GetTokenID of\r\n    tkBasicTypes: Result := fBasicTypesAttri;\r\n    tkComment: Result := fCommentAttri;\r\n    tkIdentifier: Result := fIdentifierAttri;\r\n    tkKey: Result := fKeyAttri;\r\n    tkLace: Result := fLaceAttri;\r\n    tkOperatorAndSymbols: Result := fOperatorAndSymbolsAttri;\r\n    tkPredefined: Result := fPredefinedAttri;\r\n    tkResultValue: Result := fResultValueAttri;\r\n    tkSpace: Result := fSpaceAttri;\r\n    tkString: Result := fStringAttri;\r\n    tkUnknown: Result := fIdentifierAttri;\r\n    else Result := nil;\r\n  end;\r\nend;\r\n\r\nfunction TSynEiffelSyn.GetTokenKind: integer;\r\nbegin\r\n  Result := Ord(fTokenId);\r\nend;\r\n\r\nfunction TSynEiffelSyn.GetSampleSource: UnicodeString;\r\nbegin\r\n  Result := '-- Eiffel sample source from SmartEiffel'#13#10 +\r\n    'class FIBONACCI'#13#10 +\r\n    '-- Eiffel comment'#13#10 +\r\n    'creation make'#13#10 +\r\n    #13#10 +\r\n    'feature'#13#10 +\r\n    #13#10 +\r\n    '   make is'#13#10 +\r\n    '      do'#13#10 +\r\n    '         if argument_count /= 1 or else'#13#10 +\r\n    '            not argument(1).is_integer'#13#10 +\r\n    '          then'#13#10 +\r\n    '            io.put_string(\"Usage: \");'#13#10 +\r\n    '            io.put_string(argument(0));'#13#10 +\r\n    '            io.put_string(\" %N\");'#13#10 +\r\n    '            die_with_code(exit_failure_code);'#13#10 +\r\n    '         end;'#13#10 +\r\n    '         io.put_integer(fibonacci(argument(1).to_integer));'#13#10 +\r\n    '         io.put_new_line;'#13#10 +\r\n    '      end;'#13#10 +\r\n    '   -- Eiffel comment'#13#10 +\r\n    '   fibonacci(i: INTEGER): INTEGER is'#13#10 +\r\n    '      require -- Eiffel comment'#13#10 +\r\n    '         i >= 0'#13#10 +\r\n    '      do'#13#10 +\r\n    '         if i = 0 then'#13#10 +\r\n    '            Result := 1;'#13#10 +\r\n    '         elseif i = 1 then'#13#10 +\r\n    '            Result := 1;'#13#10 +\r\n    '         else'#13#10 +\r\n    '            Result := fibonacci(i - 1) + fibonacci(i - 2) ;'#13#10 +\r\n    '         end;'#13#10 +\r\n    '      end;'#13#10 +\r\n    #13#10 +\r\n    'end';\r\nend;\r\n\r\nfunction TSynEiffelSyn.IsFilterStored: Boolean;\r\nbegin\r\n  Result := fDefaultFilter <> SYNS_FilterEiffel;\r\nend;\r\n\r\nclass function TSynEiffelSyn.GetLanguageName: string;\r\nbegin\r\n  Result := SYNS_LangEiffel;\r\nend;\r\n\r\nprocedure TSynEiffelSyn.ResetRange;\r\nbegin\r\n  fRange := rsUnknown;\r\nend;\r\n\r\nprocedure TSynEiffelSyn.SetRange(Value: Pointer);\r\nbegin\r\n  fRange := TRangeState(Value);\r\nend;\r\n\r\nfunction TSynEiffelSyn.GetRange: Pointer;\r\nbegin\r\n  Result := Pointer(fRange);\r\nend;\r\n\r\nfunction TSynEiffelSyn.IsOperatorChar(AChar: WideChar): Boolean;\r\nbegin\r\n  case AChar of\r\n    '-', '!', '#', '$', '%', '&', '(', ')', '*', '.', '/',\r\n    ':', ';', '@', '[', '\\', ']', '^', '|', '+', '<', '=', '>':\r\n      Result := True\r\n    else\r\n      Result := False;\r\n  end;\r\nend;\r\n\r\nclass function TSynEiffelSyn.GetFriendlyLanguageName: UnicodeString;\r\nbegin\r\n  Result := SYNS_FriendlyLangEiffel;\r\nend;\r\n\r\ninitialization\r\n{$IFNDEF SYN_CPPB_1}\r\n  RegisterPlaceableHighlighter(TSynEiffelSyn);\r\n{$ENDIF}\r\nend.\r\n"
  },
  {
    "path": "External/SynEdit/Source/SynHighlighterFortran.pas",
    "content": "{-------------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: SynHighlighterFortran.pas, released 2000-04-21.\r\nThe Original Code is based on the mwFortranSyn.pas file from the\r\nmwEdit component suite by Martin Waldenburg and other developers, the Initial\r\nAuthor of this file is \"riceball\".\r\nUnicode translation by Mal Hrz.\r\nAll Rights Reserved.\r\n\r\nContributors to the SynEdit and mwEdit projects are listed in the\r\nContributors.txt file.\r\n\r\nAlternatively, the contents of this file may be used under the terms of the\r\nGNU General Public License Version 2 or later (the \"GPL\"), in which case\r\nthe provisions of the GPL are applicable instead of those above.\r\nIf you wish to allow use of your version of this file only under the terms\r\nof the GPL and not to allow others to use your version of this file\r\nunder the MPL, indicate your decision by deleting the provisions above and\r\nreplace them with the notice and other provisions required by the GPL.\r\nIf you do not delete the provisions above, a recipient may use your version\r\nof this file under either the MPL or the GPL.\r\n\r\n$Id: SynHighlighterFortran.pas,v 1.15.2.9 2008/09/14 16:25:00 maelh Exp $\r\n\r\nYou may retrieve the latest version of this file at the SynEdit home page,\r\nlocated at http://SynEdit.SourceForge.net\r\n\r\nKnown Issues:\r\n-------------------------------------------------------------------------------}\r\n{\r\n@abstract(Provides a Fortran syntax highlighter for SynEdit)\r\n@author(riceball , converted to SynEdit by Bruno Mikkelsen )\r\n@created(2000, converted to SynEdit 2000-04-21)\r\n@lastmod(2000-06-23)\r\nThe SynHighlighterFortran unit provides SynEdit with a Fortran syntax highlighter.\r\nThanks to Martin Waldenburg.\r\n}\r\n\r\n{$IFNDEF QSYNHIGHLIGHTERFORTRAN}\r\nunit SynHighlighterFortran;\r\n{$ENDIF}\r\n\r\n{$I SynEdit.inc}\r\n\r\ninterface\r\n\r\nuses\r\n{$IFDEF SYN_CLX}\r\n  QGraphics,\r\n  QSynEditTypes,\r\n  QSynEditHighlighter,\r\n  QSynUnicode,\r\n{$ELSE}\r\n  Graphics,\r\n  SynEditTypes,\r\n  SynEditHighlighter,\r\n  SynUnicode,\r\n{$ENDIF}\r\n  SysUtils,\r\n  Classes;\r\n\r\ntype\r\n  TtkTokenKind = (tkComment, tkIdentifier, tkKey, tkNull, tkNumber, tkSpace,\r\n    tkString, tkSymbol, tkUnknown);\r\n\r\n  PIdentFuncTableFunc = ^TIdentFuncTableFunc;\r\n  TIdentFuncTableFunc = function (Index: Integer): TtkTokenKind of object;\r\n\r\ntype\r\n  TSynFortranSyn = class(TSynCustomHighlighter)\r\n  private\r\n    FTokenID: TtkTokenKind;\r\n    fIdentFuncTable: array[0..192] of TIdentFuncTableFunc;\r\n    fCommentAttri: TSynHighlighterAttributes;\r\n    fIdentifierAttri: TSynHighlighterAttributes;\r\n    fKeyAttri: TSynHighlighterAttributes;\r\n    fNumberAttri: TSynHighlighterAttributes;\r\n    fSpaceAttri: TSynHighlighterAttributes;\r\n    fStringAttri: TSynHighlighterAttributes;\r\n    fSymbolAttri: TSynHighlighterAttributes;\r\n    function AltFunc(Index: Integer): TtkTokenKind;\r\n    function KeyWordFunc(Index: Integer): TtkTokenKind;\r\n    function HashKey(Str: PWideChar): Cardinal;\r\n    function IdentKind(MayBe: PWideChar): TtkTokenKind;\r\n    procedure InitIdent;\r\n    procedure AsciiCharProc;\r\n    procedure CRProc;\r\n    procedure CommaProc;\r\n    procedure EqualProc;\r\n    procedure ExclamationProc;\r\n    procedure GreaterProc;\r\n    procedure IdentProc;\r\n    procedure LFProc;\r\n    procedure LowerProc;\r\n    procedure MinusProc;\r\n    procedure ModSymbolProc;\r\n    procedure NullProc;\r\n    procedure NumberProc;\r\n    procedure PlusProc;\r\n    procedure PointProc;\r\n    procedure RoundCloseProc;\r\n    procedure RoundOpenProc;\r\n    procedure SemiColonProc;\r\n    procedure SlashProc;\r\n    procedure SpaceProc;\r\n    procedure StarProc;\r\n    procedure StringProc;\r\n    procedure UnknownProc;\r\n    procedure CommentProc;\r\n  protected\r\n    function IsFilterStored: Boolean; override;\r\n  public\r\n    class function GetLanguageName: string; override;\r\n    class function GetFriendlyLanguageName: UnicodeString; override;\r\n  public\r\n    constructor Create(AOwner: TComponent); override;\r\n    function GetDefaultAttribute(Index: integer): TSynHighlighterAttributes;\r\n      override;\r\n    function GetEol: Boolean; override;\r\n    function GetTokenID: TtkTokenKind;\r\n    function GetTokenAttribute: TSynHighlighterAttributes; override;\r\n    function GetTokenKind: integer; override;\r\n    procedure Next; override;\r\n  published\r\n    property CommentAttri: TSynHighlighterAttributes read fCommentAttri\r\n      write fCommentAttri;\r\n    property IdentifierAttri: TSynHighlighterAttributes read fIdentifierAttri\r\n      write fIdentifierAttri;\r\n    property KeyAttri: TSynHighlighterAttributes read fKeyAttri write fKeyAttri;\r\n    property NumberAttri: TSynHighlighterAttributes read fNumberAttri\r\n      write fNumberAttri;\r\n    property SpaceAttri: TSynHighlighterAttributes read fSpaceAttri\r\n      write fSpaceAttri;\r\n    property StringAttri: TSynHighlighterAttributes read fStringAttri\r\n      write fStringAttri;\r\n    property SymbolAttri: TSynHighlighterAttributes read fSymbolAttri\r\n      write fSymbolAttri;\r\n  end;\r\n\r\nimplementation\r\n\r\nuses\r\n{$IFDEF SYN_CLX}\r\n  QSynEditStrConst;\r\n{$ELSE}\r\n  SynEditStrConst;\r\n{$ENDIF}\r\n\r\nconst\r\n  KeyWords: array[0..69] of UnicodeString = (\r\n    'allocatable', 'allocate', 'allocated', 'associated', 'call', 'case', \r\n    'character', 'close', 'common', 'complex', 'contains', 'continue', 'cycle', \r\n    'data', 'deallocate', 'default', 'define', 'dimension', 'do', 'else', \r\n    'elseif', 'elsewhere', 'end', 'enddo', 'endif', 'entry', 'equivalence', \r\n    'exit', 'external', 'forall', 'format', 'function', 'if', 'implicit', \r\n    'include', 'integer', 'interface', 'logical', 'map', 'module', 'namelist', \r\n    'nullify', 'open', 'optional', 'parameter', 'pause', 'pointer', 'print', \r\n    'private', 'program', 'public', 'pure', 'read', 'real', 'record', 'return', \r\n    'save', 'select', 'stop', 'subroutine', 'target', 'then', 'type', 'union', \r\n    'use', 'value', 'volatile', 'where', 'while', 'write' \r\n  );\r\n\r\n  KeyIndices: array[0..192] of Integer = (\r\n    8, -1, -1, -1, -1, 11, -1, -1, -1, 31, 2, -1, -1, 59, -1, -1, -1, -1, -1, \r\n    13, 55, -1, -1, -1, 65, -1, 38, 54, 40, 10, 37, -1, -1, 25, -1, -1, 5, -1, \r\n    -1, -1, -1, -1, -1, 4, -1, -1, 21, -1, -1, 49, -1, -1, -1, -1, 9, -1, -1, \r\n    27, -1, 22, -1, 6, -1, -1, -1, -1, -1, -1, -1, -1, 64, -1, -1, 53, 68, -1, \r\n    34, -1, -1, 69, 30, -1, -1, -1, 32, -1, -1, -1, 19, 16, -1, -1, -1, -1, -1, \r\n    -1, -1, 62, -1, -1, -1, -1, -1, -1, 36, 60, 14, -1, -1, 66, 29, -1, -1, -1, \r\n    -1, 24, -1, 67, -1, 15, -1, -1, -1, -1, -1, -1, 44, 35, -1, -1, 46, -1, 17, \r\n    -1, -1, 28, -1, 56, 61, -1, -1, 63, 45, 18, -1, 0, 20, -1, -1, -1, -1, -1, \r\n    -1, 42, -1, 50, 3, 58, 52, -1, -1, -1, 51, -1, 48, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, 12, 23, -1, 26, 1, -1, 41, 43, -1, -1, -1, 33, 7, -1, -1, -1, 47, \r\n    39, 57, -1 \r\n  );\r\n\r\n{$Q-}\r\nfunction TSynFortranSyn.HashKey(Str: PWideChar): Cardinal;\r\nbegin\r\n  Result := 0;\r\n  while IsIdentChar(Str^) do\r\n  begin\r\n    Result := Result * 294 + Ord(Str^) * 110;\r\n    inc(Str);\r\n  end;\r\n  Result := Result mod 193;\r\n  fStringLen := Str - fToIdent;\r\nend;\r\n{$Q+}\r\n\r\nfunction TSynFortranSyn.IdentKind(MayBe: PWideChar): TtkTokenKind;\r\nvar\r\n  Key: Cardinal;\r\nbegin\r\n  fToIdent := MayBe;\r\n  Key := HashKey(MayBe);\r\n  if Key <= High(fIdentFuncTable) then\r\n    Result := fIdentFuncTable[Key](KeyIndices[Key])\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nprocedure TSynFortranSyn.InitIdent;\r\nvar\r\n  i: Integer;\r\nbegin\r\n  for i := Low(fIdentFuncTable) to High(fIdentFuncTable) do\r\n    if KeyIndices[i] = -1 then\r\n      fIdentFuncTable[i] := AltFunc;\r\n\r\n  for i := Low(fIdentFuncTable) to High(fIdentFuncTable) do\r\n    if @fIdentFuncTable[i] = nil then\r\n      fIdentFuncTable[i] := KeyWordFunc;\r\nend;\r\n\r\nfunction TSynFortranSyn.AltFunc(Index: Integer): TtkTokenKind;\r\nbegin\r\n  Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynFortranSyn.KeyWordFunc(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier\r\nend;\r\n\r\nconstructor TSynFortranSyn.Create(AOwner: TComponent);\r\nbegin\r\n  inherited Create(AOwner);\r\n\r\n  fCaseSensitive := False;\r\n\r\n  fCommentAttri := TSynHighlighterAttributes.Create(SYNS_AttrComment, SYNS_FriendlyAttrComment);\r\n  fCommentAttri.Style := [fsItalic];\r\n  AddAttribute(fCommentAttri);\r\n  fIdentifierAttri := TSynHighlighterAttributes.Create(SYNS_AttrIdentifier, SYNS_FriendlyAttrIdentifier);\r\n  AddAttribute(fIdentifierAttri);\r\n  fKeyAttri := TSynHighlighterAttributes.Create(SYNS_AttrReservedWord, SYNS_FriendlyAttrReservedWord);\r\n  fKeyAttri.Style := [fsBold];\r\n  AddAttribute(fKeyAttri);\r\n  fNumberAttri := TSynHighlighterAttributes.Create(SYNS_AttrNumber, SYNS_FriendlyAttrNumber);\r\n  AddAttribute(fNumberAttri);\r\n  fSpaceAttri := TSynHighlighterAttributes.Create(SYNS_AttrSpace, SYNS_FriendlyAttrSpace);\r\n  AddAttribute(fSpaceAttri);\r\n  fStringAttri := TSynHighlighterAttributes.Create(SYNS_AttrString, SYNS_FriendlyAttrString);\r\n  AddAttribute(fStringAttri);\r\n  fSymbolAttri := TSynHighlighterAttributes.Create(SYNS_AttrSymbol, SYNS_FriendlyAttrSymbol);\r\n  AddAttribute(fSymbolAttri);\r\n  SetAttributesOnChange(DefHighlightChange);\r\n  InitIdent;\r\n  fDefaultFilter := SYNS_FilterFortran;\r\nend;\r\n\r\nprocedure TSynFortranSyn.AsciiCharProc;\r\nbegin\r\n  fTokenID := tkString;\r\n  repeat\r\n    case FLine[Run] of\r\n      #0, #10, #13: break;\r\n    end;\r\n    inc(Run);\r\n  until FLine[Run] = #39;\r\n  if FLine[Run] <> #0 then inc(Run);\r\nend;\r\n\r\nprocedure TSynFortranSyn.CRProc;\r\nbegin\r\n  fTokenID := tkSpace;\r\n  Inc(Run);\r\n  if fLine[Run] = #10 then Inc(Run);\r\nend;\r\n\r\nprocedure TSynFortranSyn.CommaProc;\r\nbegin\r\n  inc(Run);\r\n  fTokenID := tkSymbol;\r\nend;\r\n\r\nprocedure TSynFortranSyn.EqualProc;\r\nbegin\r\n  case FLine[Run + 1] of\r\n    '=':                               {logical equal}\r\n      begin\r\n        inc(Run, 2);\r\n        fTokenID := tkSymbol;\r\n      end;\r\n  else                                 {assign}\r\n    begin\r\n      inc(Run);\r\n      fTokenID := tkSymbol;\r\n    end;\r\n  end;\r\nend;\r\n\r\nprocedure TSynFortranSyn.ExclamationProc;\r\nbegin\r\n  inc(Run, 1);                        {Fortran Comments}\r\n  fTokenID := tkComment;\r\n  while FLine[Run] <> #0 do\r\n  begin\r\n    case FLine[Run] of\r\n      #10, #13: break;\r\n    end;\r\n    inc(Run);\r\n  end;\r\nend;\r\n\r\nprocedure TSynFortranSyn.GreaterProc;\r\nbegin\r\n  Case FLine[Run + 1] of\r\n    '=':                               {greater than or equal to}\r\n      begin\r\n        inc(Run, 2);\r\n        fTokenID := tkSymbol;\r\n      end;\r\n    '>':\r\n      begin\r\n        if FLine[Run + 2] = '=' then   {shift right assign}\r\n          inc(Run, 3)\r\n        else                           {shift right}\r\n          inc(Run, 2);\r\n        fTokenID := tkSymbol;\r\n      end;\r\n  else                                 {greater than}\r\n    begin\r\n      inc(Run);\r\n      fTokenID := tkSymbol;\r\n    end;\r\n  end;\r\nend;\r\n\r\nprocedure TSynFortranSyn.IdentProc;\r\nbegin\r\n  if CharInSet(FLine[Run], ['C', 'c']) and (Run = 0) then\r\n  begin   //Fortran comments\r\n    inc(Run, 1);\r\n    CommentProc;\r\n  end\r\n  else begin\r\n    fTokenID := IdentKind(fLine + Run);\r\n    inc(Run, fStringLen);\r\n    while IsIdentChar(fLine[Run]) do inc(Run);\r\n  end;\r\nend;\r\n\r\nprocedure TSynFortranSyn.LFProc;\r\nbegin\r\n  inc(Run);\r\n  fTokenID := tkSpace;\r\nend;\r\n\r\nprocedure TSynFortranSyn.LowerProc;\r\nbegin\r\n  case FLine[Run + 1] of\r\n    '=':                               {less than or equal to}\r\n      begin\r\n        inc(Run, 2);\r\n        fTokenID := tkSymbol;\r\n      end;\r\n    '<':\r\n      begin\r\n        if FLine[Run + 2] = '=' then   {shift left assign}\r\n          inc(Run, 3)\r\n        else                           {shift left}\r\n          inc(Run, 2);\r\n        fTokenID := tkSymbol;\r\n      end;\r\n  else                                 {less than}\r\n    begin\r\n      inc(Run);\r\n      fTokenID := tkSymbol;\r\n    end;\r\n  end;\r\nend;\r\n\r\nprocedure TSynFortranSyn.MinusProc;\r\nbegin\r\n  {subtract}\r\n  inc(Run);\r\n  fTokenID := tkSymbol;\r\nend;\r\n\r\nprocedure TSynFortranSyn.ModSymbolProc;\r\nbegin\r\n  {mod}\r\n  inc(Run);\r\n  fTokenID := tkSymbol;\r\nend;\r\n\r\nprocedure TSynFortranSyn.NullProc;\r\nbegin\r\n  fTokenID := tkNull;\r\n  inc(Run);\r\nend;\r\n\r\nprocedure TSynFortranSyn.NumberProc;\r\n\r\n  function IsNumberChar: Boolean;\r\n  begin\r\n    case fLine[Run] of\r\n      '0'..'9', '.', 'x', 'X', 'e', 'E', 'f', 'F':\r\n        Result := True;\r\n      else\r\n        Result := False;\r\n    end;\r\n  end;\r\n\r\nbegin\r\n  inc(Run);\r\n  fTokenID := tkNumber;\r\n  while IsNumberChar do\r\n  begin\r\n    case FLine[Run] of\r\n      '.':\r\n        if FLine[Run + 1] = '.' then break;\r\n    end;\r\n    inc(Run);\r\n  end;\r\nend;\r\n\r\nprocedure TSynFortranSyn.PlusProc;\r\nbegin\r\n  {subtract}\r\n  inc(Run);\r\n  fTokenID := tkSymbol;\r\nend;\r\n\r\nprocedure TSynFortranSyn.PointProc;\r\nbegin\r\n  if (((SynWideUpperCase(FLine[Run + 1]) = 'G') and CharInSet(SynWideUpperCase(FLine[Run + 2])[1], ['E', 'T'])) {.ge. .gt.}\r\n       or ((SynWideUpperCase(FLine[Run + 1]) = 'L') and CharInSet(SynWideUpperCase(FLine[Run + 2])[1], ['E', 'T'])) {.le. .lt.}\r\n       or ((SynWideUpperCase(FLine[Run + 1]) = 'N') and (SynWideUpperCase(FLine[Run + 2]) = 'E')) {.ne.}\r\n       or ((SynWideUpperCase(FLine[Run + 1]) = 'E') and (SynWideUpperCase(FLine[Run + 2]) = 'Q')) {.eq.}\r\n       or ((SynWideUpperCase(FLine[Run + 1]) = 'O') and (SynWideUpperCase(FLine[Run + 2]) = 'R'))){.or.}\r\n     and (FLine[Run + 3] = '.') then\r\n    begin\r\n      inc(Run, 4);\r\n      fTokenID := tkSymbol;\r\n    end\r\n  else if (((SynWideUpperCase(FLine[Run + 1]) = 'A')\r\n              and (SynWideUpperCase(FLine[Run + 2]) = 'N')\r\n              and (SynWideUpperCase(FLine[Run + 3]) = 'D'))    {.and.}\r\n           or ((SynWideUpperCase(FLine[Run + 1]) = 'N')\r\n              and (SynWideUpperCase(FLine[Run + 2]) = 'O')\r\n              and (SynWideUpperCase(FLine[Run + 3]) = 'T')))    {.not.}\r\n          and (FLine[Run + 4] = '.') then\r\n    begin\r\n      inc(Run, 5);\r\n      fTokenID := tkSymbol;\r\n    end\r\n  else if (SynWideUpperCase(FLine[Run + 1]) = 'T')\r\n          and (SynWideUpperCase(FLine[Run + 2]) = 'R')\r\n          and (SynWideUpperCase(FLine[Run + 3]) = 'U')\r\n          and (SynWideUpperCase(FLine[Run + 4]) = 'E')\r\n          and (FLine[Run + 5] = '.') then  {.true.}\r\n    begin\r\n      inc(Run, 6);\r\n      fTokenID := tkSymbol;\r\n    end\r\n  else if (SynWideUpperCase(FLine[Run + 1]) = 'F')\r\n          and (SynWideUpperCase(FLine[Run + 2]) = 'A')\r\n          and (SynWideUpperCase(FLine[Run + 3]) = 'L')\r\n          and (SynWideUpperCase(FLine[Run + 4]) = 'S')\r\n          and (SynWideUpperCase(FLine[Run + 5]) = 'E')\r\n          and (FLine[Run + 6] = '.') then  {.false.}\r\n    begin\r\n      inc(Run, 7);\r\n      fTokenID := tkSymbol;\r\n    end\r\n  else                                 {point}\r\n    begin\r\n      inc(Run);\r\n      fTokenID := tkSymbol;\r\n    end;\r\nend;\r\n\r\nprocedure TSynFortranSyn.RoundCloseProc;\r\nbegin\r\n  inc(Run);\r\n  fTokenID := tkSymbol;\r\nend;\r\n\r\nprocedure TSynFortranSyn.RoundOpenProc;\r\nbegin\r\n  inc(Run);\r\n  FTokenID := tkSymbol;\r\nend;\r\n\r\nprocedure TSynFortranSyn.SemiColonProc;\r\nbegin\r\n  inc(Run);\r\n  fTokenID := tkSymbol;\r\nend;\r\n\r\nprocedure TSynFortranSyn.SlashProc;\r\nbegin\r\n  {division}\r\n  inc(Run);\r\n  fTokenID := tkSymbol;\r\nend;\r\n\r\nprocedure TSynFortranSyn.SpaceProc;\r\nbegin\r\n  inc(Run);\r\n  fTokenID := tkSpace;\r\n  while (FLine[Run] <= #32) and not IsLineEnd(Run) do inc(Run);\r\nend;\r\n\r\nprocedure TSynFortranSyn.StarProc;\r\nbegin\r\n  if (Run = 0) then begin   //Fortran comments\r\n    inc(Run);\r\n    CommentProc;\r\n  end\r\n  else begin\r\n    {star}\r\n    inc(Run);\r\n    fTokenID := tkSymbol;\r\n  end;\r\nend;\r\n\r\nprocedure TSynFortranSyn.CommentProc;\r\nbegin\r\n  fTokenID := tkComment;\r\n  while FLine[Run] <> #0 do\r\n  begin\r\n    case FLine[Run] of\r\n      #10, #13: break;\r\n    end; //case\r\n    inc(Run);\r\n  end; //while\r\nend;\r\n\r\nprocedure TSynFortranSyn.StringProc;\r\nbegin\r\n  fTokenID := tkString;\r\n  if (FLine[Run + 1] = #34) and (FLine[Run + 2] = #34) then inc(Run, 2);\r\n  repeat\r\n    case FLine[Run] of\r\n      #0, #10, #13: break;\r\n      #92:\r\n        if FLine[Run + 1] = #10 then inc(Run);\r\n    end;\r\n    inc(Run);\r\n  until FLine[Run] = #34;\r\n  if FLine[Run] <> #0 then inc(Run);\r\nend;\r\n\r\nprocedure TSynFortranSyn.UnknownProc;\r\nbegin\r\n  inc(Run);\r\n  fTokenID := tkUnknown;\r\nend;\r\n\r\nprocedure TSynFortranSyn.Next;\r\nbegin\r\n  fTokenPos := Run;\r\n  case fLine[Run] of\r\n    #39: AsciiCharProc;\r\n    #13: CRProc;\r\n    ',': CommaProc;\r\n    '=': EqualProc;\r\n    '!': ExclamationProc;\r\n    '>': GreaterProc;\r\n    'A'..'Z', 'a'..'z', '_': IdentProc;\r\n    #10: LFProc;\r\n    '<': LowerProc;\r\n    '-': MinusProc;\r\n    '%': ModSymbolProc;\r\n    #0: NullProc;\r\n    '0'..'9': NumberProc;\r\n    '+': PlusProc;\r\n    '.': PointProc;\r\n    ')': RoundCloseProc;\r\n    '(': RoundOpenProc;\r\n    ';': SemiColonProc;\r\n    '/': SlashProc;\r\n    #1..#9, #11, #12, #14..#32: SpaceProc;\r\n    '*': StarProc;\r\n    #34: StringProc;\r\n    else UnknownProc;\r\n  end;\r\n  inherited;\r\nend;\r\n\r\nfunction TSynFortranSyn.GetDefaultAttribute(Index: integer): TSynHighlighterAttributes;\r\nbegin\r\n  case Index of\r\n    SYN_ATTR_COMMENT: Result := fCommentAttri;\r\n    SYN_ATTR_IDENTIFIER: Result := fIdentifierAttri;\r\n    SYN_ATTR_KEYWORD: Result := fKeyAttri;\r\n    SYN_ATTR_STRING: Result := fStringAttri;\r\n    SYN_ATTR_WHITESPACE: Result := fSpaceAttri;\r\n    SYN_ATTR_SYMBOL: Result := fSymbolAttri;\r\n  else\r\n    Result := nil;\r\n  end;\r\nend;\r\n\r\nfunction TSynFortranSyn.GetEol: Boolean;\r\nbegin\r\n  Result := Run = fLineLen + 1;\r\nend;\r\n\r\nfunction TSynFortranSyn.GetTokenID: TtkTokenKind;\r\nbegin\r\n  Result := fTokenId;\r\nend;\r\n\r\nfunction TSynFortranSyn.GetTokenAttribute: TSynHighlighterAttributes;\r\nbegin\r\n  case GetTokenID of\r\n    tkComment: Result := fCommentAttri;\r\n    tkIdentifier: Result := fIdentifierAttri;\r\n    tkKey: Result := fKeyAttri;\r\n    tkNumber: Result := fNumberAttri;\r\n    tkSpace: Result := fSpaceAttri;\r\n    tkString: Result := fStringAttri;\r\n    tkSymbol: Result := fSymbolAttri;\r\n    tkUnknown: Result := fIdentifierAttri;\r\n    else Result := nil;\r\n  end;\r\nend;\r\n\r\nfunction TSynFortranSyn.GetTokenKind: integer;\r\nbegin\r\n  Result := Ord(fTokenId);\r\nend;\r\n\r\nfunction TSynFortranSyn.IsFilterStored: Boolean;\r\nbegin\r\n  Result := fDefaultFilter <> SYNS_FilterFortran;\r\nend;\r\n\r\nclass function TSynFortranSyn.GetLanguageName: string;\r\nbegin\r\n  Result := SYNS_LangFortran;\r\nend;\r\n\r\nclass function TSynFortranSyn.GetFriendlyLanguageName: UnicodeString;\r\nbegin\r\n  Result := SYNS_FriendlyLangFortran;\r\nend;\r\n\r\ninitialization\r\n{$IFNDEF SYN_CPPB_1}\r\n  RegisterPlaceableHighlighter(TSynFortranSyn);\r\n{$ENDIF}\r\nend.\r\n"
  },
  {
    "path": "External/SynEdit/Source/SynHighlighterFoxpro.pas",
    "content": "{-------------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: SynHighlighterFoxpro.pas, released 2000-04-21.\r\nThe Original Code is based on the mwFoxproSyn.pas file from the\r\nmwEdit component suite by Martin Waldenburg and other developers, the Initial\r\nAuthor of this file is \"riceball\".\r\nUnicode translation by Mal Hrz.\r\nAll Rights Reserved.\r\n\r\nContributors to the SynEdit and mwEdit projects are listed in the\r\nContributors.txt file.\r\n\r\nAlternatively, the contents of this file may be used under the terms of the\r\nGNU General Public License Version 2 or later (the \"GPL\"), in which case\r\nthe provisions of the GPL are applicable instead of those above.\r\nIf you wish to allow use of your version of this file only under the terms\r\nof the GPL and not to allow others to use your version of this file\r\nunder the MPL, indicate your decision by deleting the provisions above and\r\nreplace them with the notice and other provisions required by the GPL.\r\nIf you do not delete the provisions above, a recipient may use your version\r\nof this file under either the MPL or the GPL.\r\n\r\n$Id: SynHighlighterFoxpro.pas,v 1.12.2.10 2008/09/14 16:25:00 maelh Exp $\r\n\r\nYou may retrieve the latest version of this file at the SynEdit home page,\r\nlocated at http://SynEdit.SourceForge.net\r\n\r\nKnown Issues:\r\n-------------------------------------------------------------------------------}\r\n{\r\n@abstract(Provides a Foxpro Syntax highlighter for SynEdit)\r\n@author(riceball , converted to SynEdit by Bruno Mikkelsen )\r\n@created(2000, converted to SynEdit 2000-04-21)\r\n@lastmod(2000-06-23)\r\nThe SynHighlighterFoxpro unit provides SynEdit with a Foxpro syntax highlighter.\r\nThanks to Martin Waldenburg.\r\n}\r\n\r\n{$IFNDEF QSYNHIGHLIGHTERFOXPRO}\r\nunit SynHighlighterFoxpro;\r\n{$ENDIF}\r\n\r\n{$I SynEdit.inc}\r\n\r\ninterface\r\n\r\nuses\r\n{$IFDEF SYN_CLX}\r\n  QGraphics,\r\n  QSynEditTypes,\r\n  QSynEditHighlighter,\r\n  QSynUnicode,\r\n{$ELSE}\r\n  Graphics,\r\n  SynEditTypes,\r\n  SynEditHighlighter,\r\n  SynUnicode,\r\n{$ENDIF}\r\n  SysUtils,\r\n  Classes;\r\n\r\ntype\r\n  TtkTokenKind = (tkComment, tkIdentifier, tkKey, tkNull, tkNumber, tkSpace,\r\n    tkString, tkSymbol, tkUnknown);\r\n\r\n  PIdentFuncTableFunc = ^TIdentFuncTableFunc;\r\n  TIdentFuncTableFunc = function (Index: Integer): TtkTokenKind of object;\r\n\r\ntype\r\n  TSynFoxproSyn = class(TSynCustomHighlighter)\r\n  private\r\n    FTokenID: TtkTokenKind;\r\n    fIdentFuncTable: array[0..17908] of TIdentFuncTableFunc;\r\n    fCommentAttri: TSynHighlighterAttributes;\r\n    fIdentifierAttri: TSynHighlighterAttributes;\r\n    fKeyAttri: TSynHighlighterAttributes;\r\n    fNumberAttri: TSynHighlighterAttributes;\r\n    fSpaceAttri: TSynHighlighterAttributes;\r\n    fStringAttri: TSynHighlighterAttributes;\r\n    fSymbolAttri: TSynHighlighterAttributes;\r\n    function AltFunc(Index: Integer): TtkTokenKind;\r\n    function KeyWordFunc(Index: Integer): TtkTokenKind;\r\n    function HashKey(Str: PWideChar): Cardinal;\r\n    function IdentKind(MayBe: PWideChar): TtkTokenKind;\r\n    procedure InitIdent;\r\n    procedure AndSymbolProc;\r\n    procedure AsciiCharProc;\r\n    procedure AtSymbolProc;\r\n    procedure BraceOpenProc;\r\n    procedure CRProc;\r\n    procedure ColonProc;\r\n    procedure CommaProc;\r\n    procedure EqualProc;\r\n    procedure GreaterProc;\r\n    procedure IdentProc;\r\n    procedure LFProc;\r\n    procedure LowerProc;\r\n    procedure MinusProc;\r\n    procedure ModSymbolProc;\r\n    procedure NotSymbolProc;\r\n    procedure NullProc;\r\n    procedure NumberProc;\r\n    procedure OrSymbolProc;\r\n    procedure PlusProc;\r\n    procedure PointProc;\r\n    procedure QuestionProc;\r\n    procedure RoundCloseProc;\r\n    procedure RoundOpenProc;\r\n    procedure SemiColonProc;\r\n    procedure SlashProc;\r\n    procedure SpaceProc;\r\n    procedure SquareCloseProc;\r\n    procedure SquareOpenProc;\r\n    procedure StarProc;\r\n    procedure StringProc;\r\n    procedure TildeProc;\r\n    procedure XOrSymbolProc;\r\n    procedure UnknownProc;\r\n  protected\r\n    function IsFilterStored: Boolean; override;\r\n  public\r\n    class function GetLanguageName: string; override;\r\n    class function GetFriendlyLanguageName: UnicodeString; override;\r\n  public\r\n    constructor Create(AOwner: TComponent); override;\r\n    function GetDefaultAttribute(Index: integer): TSynHighlighterAttributes;\r\n      override;\r\n    function GetEol: Boolean; override;\r\n    function GetTokenID: TtkTokenKind;\r\n    function GetTokenAttribute: TSynHighlighterAttributes; override;\r\n    function GetTokenKind: integer; override;\r\n    procedure Next; override;\r\n  published\r\n    property CommentAttri: TSynHighlighterAttributes read fCommentAttri\r\n      write fCommentAttri;\r\n    property IdentifierAttri: TSynHighlighterAttributes read fIdentifierAttri\r\n      write fIdentifierAttri;\r\n    property KeyAttri: TSynHighlighterAttributes read fKeyAttri write fKeyAttri;\r\n    property NumberAttri: TSynHighlighterAttributes read fNumberAttri\r\n      write fNumberAttri;\r\n    property SpaceAttri: TSynHighlighterAttributes read fSpaceAttri\r\n      write fSpaceAttri;\r\n    property StringAttri: TSynHighlighterAttributes read fStringAttri\r\n      write fStringAttri;\r\n    property SymbolAttri: TSynHighlighterAttributes read fSymbolAttri\r\n      write fSymbolAttri;\r\n  end;\r\n\r\nimplementation\r\n\r\nuses\r\n{$IFDEF SYN_CLX}\r\n  QSynEditStrConst;\r\n{$ELSE}\r\n  SynEditStrConst;\r\n{$ENDIF}\r\n\r\nconst\r\n  KeyWords: array[0..809] of UnicodeString = (\r\n    '_curobj', '_msysmenu', '_pageno', '_screen', '_vfp', 'abs', 'accept', \r\n    'aclass', 'acopy', 'acos', 'acti', 'activate', 'adatabases', 'adbobjects', \r\n    'add', 'additive', 'adel', 'adir', 'aelement', 'aerror', 'afields', 'afont', \r\n    'after', 'again', 'ains', 'ainstance', 'alen', 'alias', 'alines', 'all', \r\n    'alltrim', 'alt', 'alter', 'alternate', 'amembers', 'and', 'ansi', \r\n    'ansitooem', 'any', 'aplabout', 'appe', 'append', 'application', \r\n    'aprinters', 'array', 'as', 'asc', 'ascan', 'ascending', 'ascii', 'aselobj', \r\n    'asin', 'asort', 'assert', 'asubscript', 'at', 'at_c', 'atan', 'atc', \r\n    'atcc', 'atcline', 'atline', 'atn2', 'aused', 'autosave', 'average', 'avg', \r\n    'backcolor', 'bar', 'barcount', 'barprompt', 'baseclass', 'before', 'begin', \r\n    'bell', 'between', 'bintoc', 'bitand', 'bitclear', 'bitlshift', 'bitnot', \r\n    'bitor', 'bitrshift', 'bitset', 'bittest', 'bitxor', 'blan', 'blank', \r\n    'blink', 'blocksize', 'bof', 'border', 'bott', 'bottom', 'box', 'brow', \r\n    'browse', 'brstatus', 'build', 'by', 'calculate', 'call', 'cancel', \r\n    'candidate', 'capslock', 'caption', 'carry', 'case', 'cd', 'cdow', \r\n    'ceiling', 'century', 'change', 'char', 'chdir', 'check', 'chr', 'chrsaw', \r\n    'chrtran', 'chrtranc', 'class', 'classlib', 'clear', 'clock', 'clos', \r\n    'close', 'cls', 'cmonth', 'cnt', 'cntbar', 'cntpad', 'codepage', 'col', \r\n    'collate', 'color', 'colorscheme', 'comm', 'command', 'commands', 'comment', \r\n    'compact', 'compatible', 'compile', 'compobj', 'confirm', 'connection', \r\n    'connstring', 'console', 'continue', 'copy', 'cos', 'count', 'cpconvert', \r\n    'cpcurrent', 'cpdbf', 'cpdialog', 'cpnotrans', 'create', 'createobject', \r\n    'createoffline', 'ctobin', 'ctod', 'ctot', 'curdir', 'currency', 'cursor', \r\n    'curval', 'custom', 'database', 'databases', 'datasession', 'dateformat', \r\n    'datemark', 'datetime', 'day', 'dbalias', 'dbc', 'dbused', 'debug', \r\n    'debugout', 'decimals', 'declare', 'default', 'define', 'dele', 'delete', \r\n    'deleted', 'delimite', 'delimited', 'delimiters', 'descending', 'desktop', \r\n    'development', 'device', 'difference', 'dim', 'dimension', 'dir', \r\n    'directory', 'diskspace', 'display', 'displayvalue', 'distinct', 'dlls', \r\n    'dmy', 'do', 'dodefault', 'dohistory', 'double', 'dow', 'drop', 'dtoc', \r\n    'dtor', 'dtos', 'dtot', 'each', 'echo', 'edit', 'eject', 'else', 'empty', \r\n    'end', 'endcase', 'enddefine', 'enddo', 'endfor', 'endfunc', 'endif', \r\n    'endprintjob', 'endproc', 'endscan', 'endtext', 'endwith', 'environment', \r\n    'eof', 'erase', 'error', 'escape', 'evaluate', 'event', 'eventhandler', \r\n    'events', 'exact', 'except', 'exclusive', 'exists', 'exit', 'exp', 'export', \r\n    'expression', 'extended', 'external', 'fchsize', 'fclose', 'fcount', \r\n    'fcreate', 'fdow', 'feof', 'ferror', 'fetch', 'fflush', 'fgets', 'field', \r\n    'fields', 'file', 'files', 'fill', 'filter', 'find', 'fixed', 'float', \r\n    'flock', 'floor', 'flush', 'font', 'footer', 'fopen', 'for', 'force', \r\n    'foreign', 'form', 'format', 'found', 'fox2x', 'fputs', 'free', 'freeze', \r\n    'from', 'fseek', 'fsize', 'fullpath', 'func', 'functi', 'function', 'fv', \r\n    'fw2', 'fweek', 'fwrite', 'gath', 'gather', 'general', 'get', 'getbar', \r\n    'getcolor', 'getcp', 'getdir', 'getenv', 'getexpr', 'getfile', \r\n    'getfldstate', 'getfont', 'getnextmodified', 'getobject', 'getpad', \r\n    'getpict', 'getprinter', 'gets', 'global', 'go', 'gomonth', 'gotfocus', \r\n    'goto', 'group', 'grow', 'having', 'headings', 'help', 'helpcontextid', \r\n    'helpfilter', 'hidden', 'highlight', 'hour', 'hours', 'icon', 'id', \r\n    'idxcollate', 'if', 'ifdef', 'ifndef', 'iif', 'import', 'in', 'include', \r\n    'indbc', 'index', 'indexes', 'inkey', 'inlist', 'input', 'insert', \r\n    'insmode', 'int', 'integer', 'intensity', 'interval', 'into', 'is', \r\n    'isalpha', 'iscolor', 'isdigit', 'isexclusive', 'isflocked', 'islower', \r\n    'isnull', 'isreadonly', 'isrlocked', 'isupper', 'join', 'key', 'keyboard', \r\n    'keycomp', 'keymatch', 'label', 'last', 'lastkey', 'ledit', 'left', 'leftc', \r\n    'len', 'lenc', 'level', 'library', 'like', 'line', 'lineno', 'linked', \r\n    'list', 'loadpicture', 'local', 'locate', 'locfile', 'lock', 'lockscreen', \r\n    'log', 'log10', 'logerrors', 'logout', 'long', 'lookup', 'loop', 'lower', \r\n    'lparameter', 'lparameters', 'lpartition', 'ltrim', 'lupdate', 'macdesktop', \r\n    'machelp', 'mackey', 'macros', 'margin', 'mark', 'master', 'max', 'mcol', \r\n    'md', 'mdown', 'mdx', 'mdy', 'memlines', 'memo', 'memory', 'memos', \r\n    'memowidth', 'memvar', 'menu', 'menus', 'message', 'messagebox', 'messages', \r\n    'middle', 'min', 'minimize', 'minute', 'mkdir', 'mline', 'mod', 'modal', \r\n    'modi', 'modify', 'module', 'month', 'mouse', 'movable', 'move', 'moved', \r\n    'mrkbar', 'mrkpad', 'mrow', 'mton', 'multilocks', 'multiselect', 'mvcount', \r\n    'name', 'ndx', 'near', 'negotiate', 'network', 'newobject', 'next', \r\n    'noalias', 'noappend', 'noclear', 'noclose', 'noconsole', 'nocptrans', \r\n    'nodata', 'nodebug', 'nodefault', 'nodelete', 'noedit', 'noeject', \r\n    'noenvironment', 'nofloat', 'noinit', 'nolink', 'nolock', 'nomargin', \r\n    'nomdi', 'nomenu', 'nominimize', 'nomodify', 'nomouse', 'none', \r\n    'nooptimize', 'nooverwrite', 'noprompt', 'noread', 'norefresh', 'norequery', \r\n    'normal', 'normalize', 'nosave', 'noshadow', 'noshow', 'nospace', 'not', \r\n    'note', 'notify', 'noupdate', 'novalidate', 'noverify', 'nowait', \r\n    'nowindow', 'nowrap', 'nozoom', 'npv', 'ntom', 'null', 'nulldisplay', \r\n    'numlock', 'nvl', 'objnum', 'objtoclient', 'objvar', 'occurs', 'odometer', \r\n    'oemtoansi', 'of', 'off', 'oldval', 'oleclass', 'olecontrol', 'olepublic', \r\n    'on', 'only', 'open', 'optimize', 'or', 'order', 'os', 'otherwise', 'outer', \r\n    'overwrite', 'pack', 'pad', 'padc', 'padr', 'palette', 'para', 'parameter', \r\n    'parameters', 'path', 'payment', 'pcol', 'pdox', 'pdsetup', 'pen', 'pi', \r\n    'pictres', 'picture', 'pixels', 'plain', 'play', 'point', 'pop', 'popup', \r\n    'preference', 'preview', 'primary', 'print', 'printer', 'printjob', \r\n    'printstatus', 'private', 'proc', 'proced', 'procedure', 'procedures', \r\n    'program', 'project', 'prompt', 'proper', 'protected', 'prow', 'prtinfo', \r\n    'public', 'push', 'putfile', 'pv', 'query', 'quit', 'rand', 'range', 'rat', \r\n    'ratc', 'ratline', 'rd', 'rdlevel', 'read', 'readborder', 'recall', \r\n    'reccount', 'recno', 'record', 'recover', 'recsize', 'references', \r\n    'refresh', 'region', 'regional', 'reindex', 'rela', 'relati', 'relation', \r\n    'release', 'remote', 'rename', 'repl', 'repla', 'replace', 'replicate', \r\n    'report', 'reprocess', 'requery', 'reset', 'resizable', 'resize', \r\n    'resource', 'resources', 'rest', 'restore', 'resume', 'retry', 'retu', \r\n    'return', 'rgb', 'rgbscheme', 'right', 'rightc', 'rightclick', \r\n    'righttoleft', 'rlock', 'rmdir', 'rollback', 'round', 'row', 'rtod', \r\n    'rtrim', 'run', 'runscript', 'runtime', 'safety', 'same', 'save', 'say', \r\n    'scan', 'scat', 'scatt', 'scatter', 'scheme', 'schemes', 'scols', \r\n    'scoreboard', 'screen', 'sdf', 'second', 'seek', 'sele', 'select', \r\n    'selected', 'selection', 'separator', 'set', 'shadows', 'shape', 'show', \r\n    'shutdown', 'sign', 'sin', 'single', 'sizable', 'size', 'skip', 'skpbar', \r\n    'skppad', 'some', 'sort', 'sorted', 'soundex', 'space', 'sql', 'sqlcommit', \r\n    'sqlrollback', 'sqlstringconnect', 'sqrt', 'srows', 'status', \r\n    'statusbartext', 'std', 'step', 'sticky', 'store', 'str', 'strconv', \r\n    'string', 'strtran', 'structure', 'stuff', 'stuffc', 'style', 'substr', \r\n    'substrc', 'sum', 'summary', 'suspend', 'sylk', 'sys', 'sysformats', \r\n    'sysmenu', 'sysmenus', 'sysmetric', 'system', 'tab', 'tabindex', 'table', \r\n    'tablerevert', 'tables', 'tableupdate', 'tabstop', 'tag', 'talk', 'target', \r\n    'text', 'textmerge', 'textwidth', 'this', 'thisform', 'thisformset', 'time', \r\n    'timeout', 'timer', 'titles', 'to', 'top', 'topic', 'total', 'transaction', \r\n    'transform', 'trap', 'trbetween', 'trigger', 'trim', 'ttoc', 'ttod', \r\n    'txnlevel', 'txtwidth', 'type', 'typeahead', 'udfparms', 'undefine', \r\n    'union', 'unique', 'unlock', 'unpack', 'update', 'updated', 'upper', 'use', \r\n    'used', 'val', 'valid', 'validate', 'value', 'values', 'var', 'varread', \r\n    'vartype', 'version', 'view', 'views', 'volume', 'wait', 'wchild', 'wcols', \r\n    'week', 'wexist', 'wfont', 'when', 'while', 'window', 'windowlist', \r\n    'windows', 'with', 'wk1', 'wk3', 'wks', 'wlast', 'wlcol', 'wlrow', 'wontop', \r\n    'workarea', 'woutput', 'wparent', 'wr1', 'wread', 'writeexpression', \r\n    'writemethod', 'wrk', 'wrows', 'wtitle', 'wvisible', 'xcmdfile', 'xl5', \r\n    'xls', 'year', 'zap', 'zoom', 'zorder', 'zorderset' \r\n  );\r\n\r\n  KeyIndices: array[0..17908] of Integer = (\r\n    -1, -1, -1, -1, -1, -1, 191, -1, -1, -1, -1, -1, 485, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 416, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, 315, -1, -1, -1, -1, -1, -1, 523, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 776, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, 664, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    698, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 216, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, 499, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 16, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, 427, -1, -1, -1, -1, -1, -1, -1, -1, 205, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 124, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, 724, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, 700, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, 246, 125, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, 703, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 800, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 621, -1, \r\n    509, -1, -1, -1, -1, -1, -1, -1, -1, -1, 172, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 200, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, 579, -1, -1, -1, -1, -1, -1, -1, 592, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, 528, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, 596, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, 50, -1, -1, 150, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 759, -1, -1, 665, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, 181, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, 324, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 537, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, 745, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 728, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, 250, -1, -1, -1, -1, -1, -1, -1, 467, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 530, -1, -1, 414, -1, 282, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, 685, -1, -1, -1, -1, -1, -1, -1, -1, -1, 326, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, 756, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 561, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, 232, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    500, -1, -1, -1, -1, -1, -1, -1, -1, 332, -1, -1, -1, -1, -1, 372, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 273, -1, -1, -1, \r\n    -1, -1, -1, 582, -1, -1, -1, -1, -1, -1, -1, -1, -1, 540, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 734, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, 446, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    61, -1, -1, -1, -1, -1, -1, 680, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, 173, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 343, -1, 218, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, 366, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, 717, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, 751, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, 56, 618, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 713, -1, -1, -1, -1, -1, -1, \r\n    329, -1, -1, -1, 491, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, 238, -1, -1, -1, -1, -1, -1, -1, 513, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 12, 121, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 688, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 514, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 193, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, 19, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, 264, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, 395, -1, -1, -1, 806, -1, 475, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, 648, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 54, -1, -1, 483, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, 322, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, 10, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, 245, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, 320, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 134, -1, -1, -1, -1, \r\n    -1, 186, -1, -1, -1, -1, -1, -1, 422, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 615, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 515, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, 746, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, 750, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, 139, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 521, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, 420, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, 284, 167, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    170, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, 591, -1, -1, -1, -1, -1, -1, 53, -1, -1, -1, -1, -1, -1, \r\n    325, 641, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 452, 363, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, 137, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    716, -1, -1, -1, -1, -1, 438, -1, -1, -1, -1, -1, 619, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, 119, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 151, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, 673, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, 290, -1, -1, -1, -1, -1, -1, -1, -1, -1, 1, -1, 402, -1, -1, -1, 508, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 276, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 267, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, 798, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    696, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 211, -1, -1, -1, \r\n    -1, -1, -1, -1, 57, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 105, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 128, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 601, \r\n    352, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 730, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 637, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, 461, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 241, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, 236, -1, -1, -1, -1, -1, -1, -1, -1, -1, 638, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 770, -1, -1, 357, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, 613, -1, -1, 778, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    684, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    140, -1, -1, -1, 142, -1, 425, -1, -1, -1, 598, -1, -1, 465, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 367, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 780, \r\n    -1, -1, -1, -1, 674, 131, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, 265, -1, -1, -1, 490, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 184, -1, -1, 112, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 549, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, 558, -1, 658, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 616, -1, -1, -1, \r\n    148, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 194, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 484, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 606, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    532, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 492, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, 669, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, 522, -1, -1, -1, -1, -1, -1, -1, -1, -1, 474, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 145, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, 720, -1, -1, -1, 298, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 364, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 144, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 449, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 225, -1, \r\n    -1, -1, -1, -1, -1, -1, 333, -1, 634, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, 4, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, 695, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, 574, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, 277, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, 252, -1, -1, -1, -1, 581, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    489, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, 87, -1, -1, -1, -1, -1, -1, -1, -1, -1, 578, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, 256, -1, -1, -1, -1, -1, -1, -1, -1, 645, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 111, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, 257, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, 725, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 541, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 546, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 468, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, 754, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 70, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, 693, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, 0, 753, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, 767, -1, -1, -1, -1, -1, 434, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, 773, -1, -1, -1, -1, -1, -1, 795, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, 110, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 293, -1, \r\n    588, -1, -1, 41, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, 662, -1, -1, -1, 310, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 552, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 677, \r\n    386, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 607, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, 162, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, 202, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 255, 266, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, 271, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, 371, 25, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, 149, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 460, -1, -1, -1, -1, 599, -1, \r\n    -1, -1, -1, -1, -1, -1, 159, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, 380, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, 136, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 272, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, 26, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 66, \r\n    -1, -1, -1, -1, 542, -1, -1, -1, -1, -1, -1, 334, -1, -1, -1, -1, -1, 171, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 344, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, 699, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 604, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    104, -1, 370, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, 739, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    130, -1, -1, -1, -1, -1, 470, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, 466, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, 43, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 342, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, 694, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 453, -1, -1, -1, -1, \r\n    726, -1, -1, -1, -1, -1, 428, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, 175, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 249, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 198, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, 404, -1, -1, -1, -1, -1, -1, -1, 539, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 179, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 433, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, 176, 226, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 804, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 731, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, 473, -1, -1, -1, -1, -1, -1, -1, 47, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, 764, 630, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, 97, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, 444, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, 126, -1, 203, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, 127, -1, -1, -1, -1, -1, 556, -1, -1, -1, -1, \r\n    -1, 228, -1, -1, -1, -1, -1, 24, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, 338, -1, -1, -1, -1, 336, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 486, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 90, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 763, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    456, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 206, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 612, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    545, -1, -1, 23, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, 262, -1, -1, -1, -1, -1, -1, -1, -1, 369, \r\n    -1, -1, -1, -1, 302, 316, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 261, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 649, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, 337, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    48, -1, 118, -1, -1, -1, -1, -1, 224, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, 190, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 29, \r\n    809, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 503, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, 84, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 235, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 603, -1, 678, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    76, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 493, \r\n    -1, -1, -1, 741, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, 494, -1, -1, -1, -1, 547, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, 58, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 305, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, 631, -1, -1, 623, 676, 383, 335, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, 681, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 429, -1, -1, 7, -1, -1, -1, -1, \r\n    781, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, 722, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 75, -1, -1, -1, \r\n    451, -1, -1, -1, -1, -1, 207, -1, -1, -1, -1, -1, -1, -1, -1, -1, 346, -1, \r\n    -1, -1, 192, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, 223, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, 306, -1, -1, -1, 280, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 760, -1, -1, -1, -1, \r\n    -1, 45, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, 747, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    308, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    748, -1, 617, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, 462, -1, 178, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, 292, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    243, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 103, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 791, -1, -1, -1, -1, -1, -1, -1, \r\n    323, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 571, -1, -1, 587, -1, -1, \r\n    -1, -1, 690, -1, -1, -1, -1, -1, -1, -1, -1, 701, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 304, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, 705, 406, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 55, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 593, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, 350, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 398, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, 692, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 49, -1, -1, -1, 240, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 636, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 102, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 683, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 217, -1, 691, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, 793, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, 711, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 99, -1, -1, 743, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 101, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 505, -1, -1, -1, -1, 718, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, 672, -1, -1, -1, -1, -1, -1, 355, -1, -1, -1, -1, -1, 91, -1, 742, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 120, -1, -1, -1, -1, -1, \r\n    -1, -1, 286, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    614, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, 379, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    421, -1, -1, -1, 242, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    113, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, 784, -1, -1, 761, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, 501, -1, -1, -1, -1, -1, -1, -1, 710, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, 555, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, 704, -1, -1, -1, -1, 504, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, 744, -1, -1, -1, 360, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, 464, -1, -1, -1, -1, 38, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, 585, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 46, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, 670, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, 254, 187, 459, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, 92, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    507, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 5, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, 365, -1, -1, -1, -1, -1, -1, 643, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 432, -1, -1, -1, -1, -1, -1, 733, \r\n    -1, -1, -1, -1, -1, -1, 792, -1, -1, 668, -1, 156, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 769, -1, -1, -1, \r\n    -1, 283, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, 437, -1, -1, -1, -1, 749, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 659, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 597, 655, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, 610, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, 575, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 62, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 624, -1, -1, -1, 417, -1, -1, \r\n    -1, -1, -1, 212, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 6, -1, 785, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    799, -1, -1, -1, 95, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 303, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 115, -1, -1, -1, \r\n    -1, -1, 341, 679, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 384, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 650, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 714, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 72, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    418, 666, -1, -1, -1, -1, 213, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    215, 535, -1, 312, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 83, -1, -1, \r\n    -1, 497, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 209, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, 757, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, 331, -1, -1, 234, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, 155, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, 251, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, 740, -1, -1, -1, -1, -1, 712, -1, -1, -1, -1, -1, -1, -1, \r\n    765, -1, -1, -1, -1, -1, -1, -1, 98, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, 697, -1, -1, 42, -1, -1, -1, -1, -1, -1, \r\n    -1, 594, -1, -1, -1, -1, -1, -1, -1, -1, 538, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, 321, -1, 478, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 31, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 405, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 354, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 516, -1, -1, -1, 472, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, 165, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 214, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 82, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 656, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 263, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, 80, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    774, -1, -1, -1, -1, -1, 299, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, 388, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 381, -1, -1, -1, -1, -1, \r\n    -1, -1, 351, -1, -1, -1, 476, -1, -1, -1, -1, -1, -1, -1, -1, 375, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, 736, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, 790, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 620, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 752, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 390, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, 732, 419, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, 221, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 510, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 359, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 654, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, 177, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 153, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 168, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 738, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, 275, 768, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    560, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, 30, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, 21, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    15, -1, -1, 307, -1, -1, 107, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, 219, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, 448, -1, -1, -1, -1, 628, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, 644, -1, -1, 396, -1, -1, -1, -1, 349, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, 376, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, 244, -1, -1, -1, 719, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, 109, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, 27, -1, -1, -1, -1, -1, -1, -1, 482, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, 328, -1, -1, 368, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 301, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 311, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, 572, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 356, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, 253, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 138, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 455, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, 180, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, 347, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, 89, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 300, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 394, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, 447, -1, -1, -1, -1, -1, -1, -1, 789, -1, 393, -1, 639, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, 646, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 682, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 210, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, 605, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 525, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, 544, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, 651, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, 93, -1, -1, -1, -1, -1, -1, -1, -1, 285, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 297, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 227, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 583, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, 667, -1, -1, 270, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 410, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, 382, -1, -1, -1, -1, -1, -1, 463, -1, \r\n    -1, -1, -1, -1, -1, -1, 317, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, 608, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, 96, -1, 723, -1, -1, -1, -1, 762, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, 260, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 106, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, 116, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, 502, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, 577, -1, -1, -1, -1, -1, -1, -1, 39, -1, \r\n    -1, 2, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, 222, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    519, 11, -1, -1, -1, -1, -1, -1, -1, 562, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 686, -1, \r\n    -1, -1, 520, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 536, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, 239, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, 78, 123, 445, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 59, -1, \r\n    -1, 114, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 632, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, 660, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, 584, -1, -1, -1, -1, 506, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, 557, -1, -1, 498, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, 626, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, 22, -1, 259, -1, -1, 88, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, 314, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 129, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 152, 146, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 169, -1, -1, 339, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, 590, -1, -1, -1, -1, -1, -1, -1, -1, -1, 495, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 663, -1, -1, -1, -1, -1, -1, -1, 34, \r\n    -1, -1, -1, 289, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 548, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 230, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 362, -1, -1, -1, \r\n    -1, -1, -1, -1, 779, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 318, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, 627, -1, 141, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, 517, -1, 327, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, 424, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, 721, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 653, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, 182, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, 183, 479, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    652, -1, -1, -1, 805, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, 387, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, 565, -1, -1, -1, -1, -1, -1, -1, -1, 675, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, 348, -1, -1, -1, -1, 622, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, 518, -1, 94, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, 496, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 231, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, 435, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 319, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 122, -1, 345, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, 185, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 74, -1, \r\n    766, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, 373, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, 708, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, 635, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, 378, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 204, -1, -1, 133, -1, 258, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, 17, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, 625, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 117, \r\n    28, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, 487, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, 77, -1, -1, -1, -1, -1, 559, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 707, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, 794, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    609, -1, -1, -1, -1, -1, -1, 439, 431, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, 647, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, 340, -1, 413, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 309, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, 208, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 568, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, 602, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, 527, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 160, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 233, 566, -1, \r\n    -1, -1, -1, -1, -1, 85, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, 279, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    385, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 330, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 450, \r\n    -1, -1, -1, -1, -1, -1, -1, 788, 787, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, 727, -1, -1, -1, -1, 550, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, 9, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, 281, 531, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 163, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 567, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 229, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, 71, -1, -1, -1, -1, 661, 64, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, 755, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    3, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, 758, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 772, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    440, -1, -1, -1, -1, -1, 189, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 397, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, 512, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 237, -1, -1, 389, -1, -1, \r\n    -1, -1, -1, 458, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, 801, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 580, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, 477, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, 108, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, 361, -1, -1, -1, 44, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    201, -1, -1, -1, 67, 715, 803, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, 100, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    220, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, 441, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, 807, -1, -1, -1, 526, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 702, -1, -1, -1, -1, 132, \r\n    -1, -1, -1, -1, -1, -1, 480, -1, -1, -1, -1, -1, -1, -1, -1, -1, 195, -1, \r\n    -1, -1, -1, -1, -1, 81, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 154, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, 430, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 199, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, 737, -1, -1, -1, -1, -1, -1, -1, -1, -1, 161, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, 268, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 33, \r\n    -1, -1, -1, -1, 576, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, 633, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 65, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, 775, 529, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 296, -1, \r\n    287, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 569, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 40, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 36, -1, \r\n    -1, -1, 573, 511, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, 797, -1, 415, -1, -1, -1, -1, -1, -1, -1, 782, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, 409, -1, -1, -1, -1, -1, 403, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    454, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 247, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, 600, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, 400, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, 689, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 543, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 706, 32, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 423, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 374, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 533, 408, -1, -1, -1, -1, 808, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 313, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, 377, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 640, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, 52, -1, -1, -1, -1, -1, -1, -1, 564, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, 174, -1, -1, -1, -1, -1, 553, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 563, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    269, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 589, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, 358, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, 143, -1, -1, -1, -1, -1, -1, -1, -1, 278, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 248, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 687, \r\n    426, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, 488, -1, -1, -1, 8, 412, -1, 14, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, 671, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 60, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 524, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, 18, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 411, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, 401, -1, -1, -1, -1, 37, -1, -1, -1, -1, -1, \r\n    -1, 551, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, 629, -1, -1, -1, -1, -1, 274, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 164, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    135, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    196, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 469, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, 20, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, 295, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 86, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 68, -1, 802, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 69, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, 399, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, 166, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 291, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, 188, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    158, -1, -1, -1, -1, -1, -1, -1, -1, -1, 595, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, 642, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 586, -1, -1, -1, -1, 73, \r\n    -1, -1, 353, -1, -1, -1, -1, 570, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 443, -1, -1, -1, -1, \r\n    481, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, 771, -1, -1, -1, -1, -1, -1, -1, 147, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, 35, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, 436, -1, -1, -1, -1, -1, -1, 442, -1, -1, -1, -1, -1, -1, \r\n    79, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, 611, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 534, -1, -1, -1, -1, -1, -1, 51, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 63, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 735, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 783, -1, \r\n    -1, -1, 13, -1, -1, -1, -1, -1, -1, 729, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 391, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, 294, -1, -1, -1, 197, -1, -1, -1, -1, -1, -1, -1, 777, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 457, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, 796, -1, -1, -1, 709, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, 407, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 157, \r\n    -1, -1, 657, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 288, -1, 471, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, 392, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    554, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, 786, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1 \r\n  );\r\n\r\n{$Q-}\r\nfunction TSynFoxproSyn.HashKey(Str: PWideChar): Cardinal;\r\nbegin\r\n  Result := 0;\r\n  while IsIdentChar(Str^) do\r\n  begin\r\n    Result := Result * 934 + Ord(Str^) * 420;\r\n    inc(Str);\r\n  end;\r\n  Result := Result mod 17909;\r\n  fStringLen := Str - fToIdent;\r\nend;\r\n{$Q+}\r\n\r\nfunction TSynFoxproSyn.IdentKind(MayBe: PWideChar): TtkTokenKind;\r\nvar\r\n  Key: Cardinal;\r\nbegin\r\n  fToIdent := MayBe;\r\n  Key := HashKey(MayBe);\r\n  if Key <= High(fIdentFuncTable) then\r\n    Result := fIdentFuncTable[Key](KeyIndices[Key])\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nprocedure TSynFoxproSyn.InitIdent;\r\nvar\r\n  i: Integer;\r\nbegin\r\n  for i := Low(fIdentFuncTable) to High(fIdentFuncTable) do\r\n    if KeyIndices[i] = -1 then\r\n      fIdentFuncTable[i] := AltFunc;\r\n\r\n  for i := Low(fIdentFuncTable) to High(fIdentFuncTable) do\r\n    if @fIdentFuncTable[i] = nil then\r\n      fIdentFuncTable[i] := KeyWordFunc;\r\nend;\r\n\r\nfunction TSynFoxproSyn.AltFunc(Index: Integer): TtkTokenKind;\r\nbegin\r\n  Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynFoxproSyn.KeyWordFunc(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier\r\nend;\r\n\r\nconstructor TSynFoxproSyn.Create(AOwner: TComponent);\r\nbegin\r\n  inherited Create(AOwner);\r\n\r\n  fCaseSensitive := False;\r\n\r\n  fCommentAttri := TSynHighlighterAttributes.Create(SYNS_AttrComment, SYNS_FriendlyAttrComment);\r\n  AddAttribute(fCommentAttri);\r\n  fIdentifierAttri := TSynHighlighterAttributes.Create(SYNS_AttrIdentifier, SYNS_FriendlyAttrIdentifier);\r\n  AddAttribute(fIdentifierAttri);\r\n  fKeyAttri := TSynHighlighterAttributes.Create(SYNS_AttrReservedWord, SYNS_FriendlyAttrReservedWord);\r\n  AddAttribute(fKeyAttri);\r\n  fNumberAttri := TSynHighlighterAttributes.Create(SYNS_AttrNumber, SYNS_FriendlyAttrNumber);\r\n  AddAttribute(fNumberAttri);\r\n  fSpaceAttri := TSynHighlighterAttributes.Create(SYNS_AttrSpace, SYNS_FriendlyAttrSpace);\r\n  AddAttribute(fSpaceAttri);\r\n  fStringAttri := TSynHighlighterAttributes.Create(SYNS_AttrString, SYNS_FriendlyAttrString);\r\n  AddAttribute(fStringAttri);\r\n  fSymbolAttri := TSynHighlighterAttributes.Create(SYNS_AttrSymbol, SYNS_FriendlyAttrSymbol);\r\n  AddAttribute(fSymbolAttri);\r\n  SetAttributesOnChange(DefHighlightChange);\r\n  InitIdent;\r\n  fDefaultFilter := SYNS_FilterFoxpro;\r\nend;\r\n\r\nprocedure TSynFoxproSyn.AndSymbolProc;\r\nbegin\r\n  case FLine[Run + 1] of\r\n    '&':                               {Comments}\r\n      begin\r\n        inc(Run, 2);\r\n        fTokenID := tkComment;\r\n        while FLine[Run] <> #0 do\r\n        begin\r\n          case FLine[Run] of\r\n            #10, #13: break;\r\n          end; //case\r\n          inc(Run);\r\n        end;\r\n      end;\r\n  else                                 {and}\r\n    begin\r\n      inc(Run);\r\n      fTokenID := tkSymbol;\r\n    end;\r\n  end;\r\nend;\r\n\r\nprocedure TSynFoxproSyn.AsciiCharProc;\r\nbegin\r\n  fTokenID := tkString;\r\n  repeat\r\n    case FLine[Run] of\r\n      #0, #10, #13: break;\r\n    end;\r\n    inc(Run);\r\n  until FLine[Run] = #39;\r\n  if FLine[Run] <> #0 then inc(Run);\r\nend;\r\n\r\nprocedure TSynFoxproSyn.AtSymbolProc;\r\nbegin\r\n  fTokenID := tkKey;\r\n  inc(Run);\r\nend;\r\n\r\nprocedure TSynFoxproSyn.BraceOpenProc;\r\nbegin\r\n  fTokenID := tkString;\r\n  repeat\r\n    case FLine[Run] of\r\n      #0, #10, #13: break;\r\n      #92:\r\n        if FLine[Run + 1] = #10 then inc(Run);\r\n    end;\r\n    inc(Run);\r\n  until FLine[Run] = '}';\r\n  if FLine[Run] <> #0 then inc(Run);\r\nend;\r\n\r\nprocedure TSynFoxproSyn.CRProc;\r\nbegin\r\n  fTokenID := tkSpace;\r\n  case FLine[Run + 1] of\r\n    #10: inc(Run, 2);\r\n    else inc(Run);\r\n  end;\r\nend;\r\n\r\nprocedure TSynFoxproSyn.ColonProc;\r\nbegin\r\n  {colon}\r\n  inc(Run);\r\n  fTokenID := tkSymbol;\r\nend;\r\n\r\nprocedure TSynFoxproSyn.CommaProc;\r\nbegin\r\n  inc(Run);\r\n  fTokenID := tkSymbol;\r\nend;\r\n\r\nprocedure TSynFoxproSyn.EqualProc;\r\nbegin\r\n  case FLine[Run + 1] of\r\n    '=':                               {logical equal}\r\n      begin\r\n        inc(Run, 2);\r\n        fTokenID := tkSymbol;\r\n      end;\r\n  else                                 {assign}\r\n    begin\r\n      inc(Run);\r\n      fTokenID := tkSymbol;\r\n    end;\r\n  end;\r\nend;\r\n\r\nprocedure TSynFoxproSyn.GreaterProc;\r\nbegin\r\n  Case FLine[Run + 1] of\r\n    '=':                               {greater than or equal to}\r\n      begin\r\n        inc(Run, 2);\r\n        fTokenID := tkSymbol;\r\n      end;\r\n    '>':\r\n      begin\r\n        if FLine[Run + 2] = '=' then   {shift right assign}\r\n          inc(Run, 3)\r\n        else                           {shift right}\r\n          inc(Run, 2);\r\n        fTokenID := tkSymbol;\r\n      end;\r\n  else                                 {greater than}\r\n    begin\r\n      inc(Run);\r\n      fTokenID := tkSymbol;\r\n    end;\r\n  end;\r\nend;\r\n\r\nprocedure TSynFoxproSyn.IdentProc;\r\nbegin\r\n  fTokenID := IdentKind((fLine + Run));\r\n  inc(Run, fStringLen);\r\n  while IsIdentChar(fLine[Run]) do inc(Run);\r\nend;\r\n\r\nprocedure TSynFoxproSyn.LFProc;\r\nbegin\r\n  fTokenID := tkSpace;\r\n  inc(Run);\r\nend;\r\n\r\nprocedure TSynFoxproSyn.LowerProc;\r\nbegin\r\n  case FLine[Run + 1] of\r\n    '=':                               {less than or equal to}\r\n      begin\r\n        inc(Run, 2);\r\n        fTokenID := tkSymbol;\r\n      end;\r\n    '<':\r\n      begin\r\n        if FLine[Run + 2] = '=' then   {shift left assign}\r\n          inc(Run, 3)\r\n        else                           {shift left}\r\n          inc(Run, 2);\r\n        fTokenID := tkSymbol;\r\n      end;\r\n  else                                 {less than}\r\n    begin\r\n      inc(Run);\r\n      fTokenID := tkSymbol;\r\n    end;\r\n  end;\r\nend;\r\n\r\nprocedure TSynFoxproSyn.MinusProc;\r\nbegin\r\n  {subtract}\r\n  inc(Run);\r\n  fTokenID := tkSymbol;\r\nend;\r\n\r\nprocedure TSynFoxproSyn.ModSymbolProc;\r\nbegin\r\n  {mod}\r\n  inc(Run);\r\n  fTokenID := tkSymbol;\r\nend;\r\n\r\nprocedure TSynFoxproSyn.NotSymbolProc;\r\nbegin\r\n  {not}\r\n  inc(Run);\r\n  fTokenID := tkSymbol;\r\nend;\r\n\r\nprocedure TSynFoxproSyn.NullProc;\r\nbegin\r\n  fTokenID := tkNull;\r\n  inc(Run);\r\nend;\r\n\r\nprocedure TSynFoxproSyn.NumberProc;\r\n\r\n  function IsNumberChar: Boolean;\r\n  begin\r\n    case fLine[Run] of\r\n      '0'..'9', '.', 'x', 'X', 'e', 'E', 'f', 'F':\r\n        Result := True;\r\n      else\r\n        Result := False;\r\n    end;\r\n  end;\r\n\r\nbegin\r\n  inc(Run);\r\n  fTokenID := tkNumber;\r\n  while IsNumberChar do\r\n  begin\r\n    case FLine[Run] of\r\n      '.':\r\n        if FLine[Run + 1] = '.' then break;\r\n    end;\r\n    inc(Run);\r\n  end;\r\nend;\r\n\r\nprocedure TSynFoxproSyn.OrSymbolProc;\r\nbegin\r\n  {or}\r\n  inc(Run);\r\n  fTokenID := tkSymbol;\r\nend;\r\n\r\nprocedure TSynFoxproSyn.PlusProc;\r\nbegin\r\n  {subtract}\r\n  inc(Run);\r\n  fTokenID := tkSymbol;\r\nend;\r\n\r\nprocedure TSynFoxproSyn.PointProc;\r\nbegin\r\n  if ((SynWideUpperCase(FLine[Run + 1]) = 'T') or      {.t.}\r\n    (SynWideUpperCase(FLine[Run + 1]) = 'F')) and     {.f.}\r\n    (FLine[Run + 2] = '.') then\r\n  begin\r\n    inc(Run, 3);\r\n    fTokenID := tkSymbol;\r\n  end\r\n  else if (((SynWideUpperCase(FLine[Run + 1]) = 'A') and\r\n    (SynWideUpperCase(FLine[Run + 2]) = 'N') and\r\n    (SynWideUpperCase(FLine[Run + 3]) = 'D')) or   {.and.}\r\n    ((SynWideUpperCase(FLine[Run + 1]) = 'N') and\r\n    (SynWideUpperCase(FLine[Run + 2]) = 'O') and\r\n    (SynWideUpperCase(FLine[Run + 3]) = 'T'))) and   {.not.}\r\n    (FLine[Run + 4] = '.') then\r\n  begin\r\n    inc(Run, 5);\r\n    fTokenID := tkSymbol;\r\n  end\r\n  else if (SynWideUpperCase(FLine[Run + 1]) = 'O') and\r\n    (SynWideUpperCase(FLine[Run + 2]) = 'R') and\r\n    (FLine[Run + 3] = '.') then  {.or.}\r\n  begin\r\n    inc(Run, 4);\r\n    fTokenID := tkSymbol;\r\n  end\r\n  else                                 {point}\r\n  begin\r\n    inc(Run);\r\n    fTokenID := tkSymbol;\r\n  end;\r\nend;\r\n\r\nprocedure TSynFoxproSyn.QuestionProc;\r\nbegin\r\n  inc(Run);\r\n  fTokenID := tkSymbol;\r\nend;\r\n\r\nprocedure TSynFoxproSyn.RoundCloseProc;\r\nbegin\r\n  inc(Run);\r\n  fTokenID := tkSymbol;\r\nend;\r\n\r\nprocedure TSynFoxproSyn.RoundOpenProc;\r\nbegin\r\n  inc(Run);\r\n  fTokenID := tkSymbol;\r\nend;\r\n\r\nprocedure TSynFoxproSyn.SemiColonProc;\r\nbegin\r\n  inc(Run);\r\n  fTokenID := tkSymbol;\r\nend;\r\n\r\nprocedure TSynFoxproSyn.SlashProc;\r\nbegin\r\n  {division}\r\n  inc(Run);\r\n  fTokenID := tkSymbol;\r\nend;\r\n\r\nprocedure TSynFoxproSyn.SpaceProc;\r\nbegin\r\n  inc(Run);\r\n  fTokenID := tkSpace;\r\n  while (FLine[Run] <= #32) and not IsLineEnd(Run) do inc(Run);\r\nend;\r\n\r\nprocedure TSynFoxproSyn.SquareCloseProc;\r\nbegin\r\n  inc(Run);\r\n  fTokenID := tkSymbol;\r\nend;\r\n\r\nprocedure TSynFoxproSyn.SquareOpenProc;\r\nbegin\r\n  inc(Run);\r\n  fTokenID := tkSymbol;\r\nend;\r\n\r\nprocedure TSynFoxproSyn.StarProc;\r\nbegin\r\n  if (Run = 0) or (WideTrim(Copy(fLine, 1, Run)) = '') then\r\n  begin                        {Foxpro Comments}\r\n    inc(Run);\r\n    fTokenID := tkComment;\r\n    while FLine[Run] <> #0 do\r\n    begin\r\n      case FLine[Run] of\r\n        #10, #13: break;\r\n      end;\r\n      inc(Run);\r\n    end;\r\n  end\r\n  else\r\n  begin\r\n    {star}\r\n    inc(Run);\r\n    fTokenID := tkSymbol;\r\n  end;\r\nend;\r\n\r\nprocedure TSynFoxproSyn.StringProc;\r\nbegin\r\n  fTokenID := tkString;\r\n  if (FLine[Run + 1] = #34) and (FLine[Run + 2] = #34) then inc(Run, 2);\r\n  repeat\r\n    case FLine[Run] of\r\n      #0, #10, #13: break;\r\n      #92:\r\n        if FLine[Run + 1] = #10 then inc(Run);\r\n    end;\r\n    inc(Run);\r\n  until FLine[Run] = #34;\r\n  if FLine[Run] <> #0 then inc(Run);\r\nend;\r\n\r\nprocedure TSynFoxproSyn.TildeProc;\r\nbegin\r\n  inc(Run);\r\n  fTokenId := tkSymbol;\r\nend;\r\n\r\nprocedure TSynFoxproSyn.XOrSymbolProc;\r\nbegin\r\n  {xor}\r\n  inc(Run);\r\n  fTokenID := tkSymbol;\r\nend;\r\n\r\nprocedure TSynFoxproSyn.UnknownProc;\r\nbegin\r\n  inc(Run);\r\n  fTokenID := tkUnknown;\r\nend;\r\n\r\nprocedure TSynFoxproSyn.Next;\r\nbegin\r\n  fTokenPos := Run;\r\n  case fLine[Run] of\r\n    '&': AndSymbolProc;\r\n    #39: AsciiCharProc;\r\n    '@': AtSymbolProc;\r\n    '{': BraceOpenProc;\r\n    #13: CRProc;\r\n    ':': ColonProc;\r\n    ',': CommaProc;\r\n    '=': EqualProc;\r\n    '>': GreaterProc;\r\n    'A'..'Z', 'a'..'z', '_': IdentProc;\r\n    #10: LFProc;\r\n    '<': LowerProc;\r\n    '-': MinusProc;\r\n    '%': ModSymbolProc;\r\n    '!': NotSymbolProc;\r\n    #0: NullProc;\r\n    '0'..'9': NumberProc;\r\n    '|': OrSymbolProc;\r\n    '+': PlusProc;\r\n    '.': PointProc;\r\n    '?': QuestionProc;\r\n    ')': RoundCloseProc;\r\n    '(': RoundOpenProc;\r\n    ';': SemiColonProc;\r\n    '/': SlashProc;\r\n    #1..#9, #11, #12, #14..#32: SpaceProc;\r\n    ']': SquareCloseProc;\r\n    '[': SquareOpenProc;\r\n    '*': StarProc;\r\n    #34: StringProc;\r\n    '~': TildeProc;\r\n    '^': XOrSymbolProc;\r\n    else UnknownProc;\r\n  end;\r\n  inherited;\r\nend;\r\n\r\nfunction TSynFoxproSyn.GetDefaultAttribute(Index: integer): TSynHighlighterAttributes;\r\nbegin\r\n  case Index of\r\n    SYN_ATTR_COMMENT: Result := fCommentAttri;\r\n    SYN_ATTR_IDENTIFIER: Result := fIdentifierAttri;\r\n    SYN_ATTR_KEYWORD: Result := fKeyAttri;\r\n    SYN_ATTR_STRING: Result := fStringAttri;\r\n    SYN_ATTR_WHITESPACE: Result := fSpaceAttri;\r\n    SYN_ATTR_SYMBOL: Result := fSymbolAttri;\r\n  else\r\n    Result := nil;\r\n  end;\r\nend;\r\n\r\nfunction TSynFoxproSyn.GetEol: Boolean;\r\nbegin\r\n  Result := Run = fLineLen + 1;\r\nend;\r\n\r\nfunction TSynFoxproSyn.GetTokenID: TtkTokenKind;\r\nbegin\r\n  Result := fTokenId;\r\nend;\r\n\r\nfunction TSynFoxproSyn.GetTokenAttribute: TSynHighlighterAttributes;\r\nbegin\r\n  case GetTokenID of\r\n    tkComment: Result := fCommentAttri;\r\n    tkIdentifier: Result := fIdentifierAttri;\r\n    tkKey: Result := fKeyAttri;\r\n    tkNumber: Result := fNumberAttri;\r\n    tkSpace: Result := fSpaceAttri;\r\n    tkString: Result := fStringAttri;\r\n    tkSymbol: Result := fSymbolAttri;\r\n    tkUnknown: Result := fIdentifierAttri;\r\n    else Result := nil;\r\n  end;\r\nend;\r\n\r\nfunction TSynFoxproSyn.GetTokenKind: integer;\r\nbegin\r\n  Result := Ord(fTokenId);\r\nend;\r\n\r\nfunction TSynFoxproSyn.IsFilterStored: Boolean;\r\nbegin\r\n  Result := fDefaultFilter <> SYNS_FilterFoxpro;\r\nend;\r\n\r\nclass function TSynFoxproSyn.GetLanguageName: string;                    \r\nbegin\r\n  Result := SYNS_LangFoxpro;\r\nend;\r\n\r\nclass function TSynFoxproSyn.GetFriendlyLanguageName: UnicodeString;\r\nbegin\r\n  Result := SYNS_FriendlyLangFoxpro;\r\nend;\r\n\r\ninitialization\r\n{$IFNDEF SYN_CPPB_1}\r\n  RegisterPlaceableHighlighter(TSynFoxproSyn);\r\n{$ENDIF}\r\nend.\r\n"
  },
  {
    "path": "External/SynEdit/Source/SynHighlighterGWS.pas",
    "content": "{-------------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: SynHighlighterCpp.pas, released 2000-04-10.\r\nThe Original Code is based on the dcjCppSyn.pas file from the\r\nmwEdit component suite by Martin Waldenburg and other developers, the Initial\r\nAuthor of this file is Michael Trier.\r\nUnicode translation by Mal Hrz.\r\nAll Rights Reserved.\r\n\r\nContributors to the SynEdit and mwEdit projects are listed in the\r\nContributors.txt file.\r\n\r\nAlternatively, the contents of this file may be used under the terms of the\r\nGNU General Public License Version 2 or later (the \"GPL\"), in which case\r\nthe provisions of the GPL are applicable instead of those above.\r\nIf you wish to allow use of your version of this file only under the terms\r\nof the GPL and not to allow others to use your version of this file\r\nunder the MPL, indicate your decision by deleting the provisions above and\r\nreplace them with the notice and other provisions required by the GPL.\r\nIf you do not delete the provisions above, a recipient may use your version\r\nof this file under either the MPL or the GPL.\r\n\r\n$Id: SynHighlighterGWS.pas,v 1.13.2.7 2008/09/14 16:25:00 maelh Exp $\r\n\r\nYou may retrieve the latest version of this file at the SynEdit home page,\r\nlocated at http://SynEdit.SourceForge.net\r\n\r\n-------------------------------------------------------------------------------}\r\n\r\n{$IFNDEF QSYNHIGHLIGHTERGWS}\r\nunit SynHighlighterGWS;\r\n{$ENDIF}\r\n\r\n{ This unit provides a syntax highlighter for GW-TEL Scripts }\r\n\r\n{$I SynEdit.inc}\r\n\r\ninterface\r\n\r\nuses\r\n{$IFDEF SYN_CLX}\r\n  QGraphics,\r\n  QSynEditTypes,\r\n  QSynEditHighlighter,\r\n  QSynUnicode,\r\n{$ELSE}\r\n  Graphics,\r\n  SynEditTypes,\r\n  SynEditHighlighter,\r\n  SynUnicode,\r\n{$ENDIF}\r\n  SysUtils,\r\n  Classes;\r\n\r\nType\r\n  TtkTokenKind = (\r\n    tkComment,\r\n    tkIdentifier,\r\n    tkKey,\r\n    tkNull,\r\n    tkNumber,\r\n    tkSpace,\r\n    tkString,\r\n    tkSymbol,\r\n    tkUnknown);\r\n\r\n  TxtkTokenKind = (\r\n    xtkAdd, xtkAddAssign, xtkAnd, xtkAndAssign, xtkArrow, xtkAssign,\r\n    xtkBitComplement, xtkBraceClose, xtkBraceOpen, xtkColon, xtkComma,\r\n    xtkDecrement, xtkDivide, xtkDivideAssign, xtkEllipse, xtkGreaterThan,\r\n    xtkGreaterThanEqual, xtkIncOr, xtkIncOrAssign, xtkIncrement, xtkLessThan,\r\n    xtkLessThanEqual, xtkLogAnd, xtkLogComplement, xtkLogEqual, xtkLogOr,\r\n    xtkMod, xtkModAssign, xtkMultiplyAssign, xtkNotEqual, xtkPoint, xtkQuestion,\r\n    xtkRoundClose, xtkRoundOpen, xtkScopeResolution, xtkSemiColon, xtkShiftLeft,\r\n    xtkShiftLeftAssign, xtkShiftRight, xtkShiftRightAssign, xtkSquareClose,\r\n    xtkSquareOpen, xtkStar, xtkSubtract, xtkSubtractAssign, xtkXor,\r\n    xtkXorAssign);\r\n\r\n  TRangeState = (rsAnsiC, rsUnKnown);\r\n\r\n  PIdentFuncTableFunc = ^TIdentFuncTableFunc;\r\n  TIdentFuncTableFunc = function (Index: Integer): TtkTokenKind of object;\r\n\r\n  TSynGWScriptSyn = class(TSynCustomHighlighter)\r\n  private\r\n    fRange: TRangeState;\r\n    FTokenID: TtkTokenKind;\r\n    FExtTokenID: TxtkTokenKind;\r\n    fIdentFuncTable: array[0..12] of TIdentFuncTableFunc;\r\n    fCommentAttri: TSynHighlighterAttributes;\r\n    fIdentifierAttri: TSynHighlighterAttributes;\r\n    fInvalidAttri: TSynHighlighterAttributes;\r\n    fKeyAttri: TSynHighlighterAttributes;\r\n    fNumberAttri: TSynHighlighterAttributes;\r\n    fSpaceAttri: TSynHighlighterAttributes;\r\n    fStringAttri: TSynHighlighterAttributes;\r\n    fSymbolAttri: TSynHighlighterAttributes;\r\n    function AltFunc(Index: Integer): TtkTokenKind;\r\n    function FuncBool(Index: Integer): TtkTokenKind;\r\n    function FuncBreak(Index: Integer): TtkTokenKind;\r\n    function FuncChar(Index: Integer): TtkTokenKind;\r\n    function FuncDo(Index: Integer): TtkTokenKind;\r\n    function FuncElse(Index: Integer): TtkTokenKind;\r\n    function FuncFalse(Index: Integer): TtkTokenKind;\r\n    function FuncFor(Index: Integer): TtkTokenKind;\r\n    function FuncIf(Index: Integer): TtkTokenKind;\r\n    function FuncInt(Index: Integer): TtkTokenKind;\r\n    function FuncReturn(Index: Integer): TtkTokenKind;\r\n    function FuncString(Index: Integer): TtkTokenKind;\r\n    function FuncTrue(Index: Integer): TtkTokenKind;\r\n    function FuncWhile(Index: Integer): TtkTokenKind;\r\n    function HashKey(Str: PWideChar): Cardinal;\r\n    function IdentKind(MayBe: PWideChar): TtkTokenKind;\r\n    procedure AnsiCProc;\r\n    procedure AndSymbolProc;\r\n    procedure AsciiCharProc;\r\n    procedure AtSymbolProc;\r\n    procedure BraceCloseProc;\r\n    procedure BraceOpenProc;\r\n    procedure CRProc;\r\n    procedure ColonProc;\r\n    procedure CommaProc;\r\n    procedure EqualProc;\r\n    procedure GreaterProc;\r\n    procedure IdentProc;\r\n    procedure LFProc;\r\n    procedure LowerProc;\r\n    procedure MinusProc;\r\n    procedure ModSymbolProc;\r\n    procedure NotSymbolProc;\r\n    procedure NullProc;\r\n    procedure NumberProc;\r\n    procedure OrSymbolProc;\r\n    procedure PlusProc;\r\n    procedure PointProc;\r\n    procedure QuestionProc;\r\n    procedure RoundCloseProc;\r\n    procedure RoundOpenProc;\r\n    procedure SemiColonProc;\r\n    procedure SlashProc;\r\n    procedure SpaceProc;\r\n    procedure SquareCloseProc;\r\n    procedure SquareOpenProc;\r\n    procedure StarProc;\r\n    procedure StringProc;\r\n    procedure TildeProc;\r\n    procedure XOrSymbolProc;\r\n    procedure UnknownProc;\r\n    procedure InitIdent;\r\n  protected\r\n    function GetExtTokenID: TxtkTokenKind;\r\n    function IsFilterStored: Boolean; override;\r\n  public\r\n    constructor Create(AOwner: TComponent); override;\r\n    class function GetLanguageName: string; override;\r\n    class function GetFriendlyLanguageName: UnicodeString; override;\r\n    function GetDefaultAttribute (Index: integer): TSynHighlighterAttributes; override;\r\n    function GetEol: Boolean; override;\r\n    function GetRange: Pointer; override;\r\n    function GetTokenID: TtkTokenKind;\r\n    function GetTokenAttribute: TSynHighlighterAttributes; override;\r\n    function GetTokenKind: integer; override;\r\n    procedure Next; override;\r\n    procedure SetRange(Value: Pointer); override;\r\n    procedure ResetRange; override;\r\n\r\n    property ExtTokenID: TxtkTokenKind read GetExtTokenID;\r\n  published\r\n    property CommentAttri: TSynHighlighterAttributes read fCommentAttri write fCommentAttri;\r\n    property IdentifierAttri: TSynHighlighterAttributes read fIdentifierAttri write fIdentifierAttri;\r\n    property InvalidAttri: TSynHighlighterAttributes read fInvalidAttri write fInvalidAttri;\r\n    property KeyAttri: TSynHighlighterAttributes read fKeyAttri write fKeyAttri;\r\n    property NumberAttri: TSynHighlighterAttributes read fNumberAttri write fNumberAttri;\r\n    property SpaceAttri: TSynHighlighterAttributes read fSpaceAttri write fSpaceAttri;\r\n    property StringAttri: TSynHighlighterAttributes read fStringAttri write fStringAttri;\r\n    property SymbolAttri: TSynHighlighterAttributes read fSymbolAttri write fSymbolAttri;\r\n  end;\r\n\r\nimplementation\r\n\r\nuses\r\n{$IFDEF SYN_CLX}\r\n  QSynEditStrConst;\r\n{$ELSE}\r\n  SynEditStrConst;\r\n{$ENDIF}\r\n\r\nconst\r\n  KeyWords: array[0..12] of UnicodeString = (\r\n    'bool', 'break', 'char', 'do', 'else', 'false', 'for', 'if', 'int', \r\n    'return', 'string', 'true', 'while' \r\n  );\r\n\r\n  KeyIndices: array[0..12] of Integer = (\r\n    8, 5, 11, 12, 1, 10, 0, 2, 9, 4, 6, 3, 7 \r\n  );\r\n\r\n{$Q-}\r\nfunction TSynGWScriptSyn.HashKey(Str: PWideChar): Cardinal;\r\nbegin\r\n  Result := 0;\r\n  while IsIdentChar(Str^) do\r\n  begin\r\n    Result := Result * 797 + Ord(Str^) * 6;\r\n    inc(Str);\r\n  end;\r\n  Result := Result mod 13;\r\n  fStringLen := Str - fToIdent;\r\nend;\r\n{$Q+}\r\n\r\nprocedure TSynGWScriptSyn.InitIdent;\r\nvar\r\n  i: Integer;\r\nbegin\r\n  for i := Low(fIdentFuncTable) to High(fIdentFuncTable) do\r\n    if KeyIndices[i] = -1 then\r\n      fIdentFuncTable[i] := AltFunc;\r\n\r\n  fIdentFuncTable[6] := FuncBool;\r\n  fIdentFuncTable[4] := FuncBreak;\r\n  fIdentFuncTable[7] := FuncChar;\r\n  fIdentFuncTable[11] := FuncDo;\r\n  fIdentFuncTable[9] := FuncElse;\r\n  fIdentFuncTable[1] := FuncFalse;\r\n  fIdentFuncTable[10] := FuncFor;\r\n  fIdentFuncTable[12] := FuncIf;\r\n  fIdentFuncTable[0] := FuncInt;\r\n  fIdentFuncTable[8] := FuncReturn;\r\n  fIdentFuncTable[5] := FuncString;\r\n  fIdentFuncTable[2] := FuncTrue;\r\n  fIdentFuncTable[3] := FuncWhile;\r\nend;\r\n\r\nfunction TSynGWScriptSyn.AltFunc(Index: Integer): TtkTokenKind;\r\nbegin\r\n  Result := tkIdentifier;\r\nend;\r\n\r\n\r\nfunction TSynGWScriptSyn.FuncBool(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynGWScriptSyn.FuncBreak(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynGWScriptSyn.FuncChar(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynGWScriptSyn.FuncDo(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynGWScriptSyn.FuncElse(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynGWScriptSyn.FuncFalse(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynGWScriptSyn.FuncFor(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynGWScriptSyn.FuncIf(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynGWScriptSyn.FuncInt(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynGWScriptSyn.FuncReturn(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynGWScriptSyn.FuncString(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynGWScriptSyn.FuncTrue(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynGWScriptSyn.FuncWhile(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\n\r\nfunction TSynGWScriptSyn.IdentKind(MayBe: PWideChar): TtkTokenKind;\r\nvar\r\n  Key: Cardinal;\r\nbegin\r\n  fToIdent := MayBe;\r\n  Key := HashKey(MayBe);\r\n  if Key <= High(fIdentFuncTable) then\r\n    Result := fIdentFuncTable[Key](KeyIndices[Key])\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nconstructor TSynGWScriptSyn.Create(AOwner: TComponent);\r\nbegin\r\n  inherited Create(AOwner);\r\n\r\n  fCaseSensitive := True;\r\n\r\n  fCommentAttri := TSynHighlighterAttributes.Create(SYNS_AttrComment, SYNS_FriendlyAttrComment);\r\n  fCommentAttri.Style:= [fsItalic];\r\n  fIdentifierAttri := TSynHighlighterAttributes.Create(SYNS_AttrIdentifier, SYNS_FriendlyAttrIdentifier);\r\n  fInvalidAttri := TSynHighlighterAttributes.Create(SYNS_AttrIllegalChar, SYNS_FriendlyAttrIllegalChar);\r\n  fKeyAttri := TSynHighlighterAttributes.Create(SYNS_AttrReservedWord, SYNS_FriendlyAttrReservedWord);\r\n  fKeyAttri.Style:= [fsBold];\r\n  fNumberAttri := TSynHighlighterAttributes.Create(SYNS_AttrNumber, SYNS_FriendlyAttrNumber);\r\n  fSpaceAttri := TSynHighlighterAttributes.Create(SYNS_AttrSpace, SYNS_FriendlyAttrSpace);\r\n  fStringAttri := TSynHighlighterAttributes.Create(SYNS_AttrString, SYNS_FriendlyAttrString);\r\n  fSymbolAttri := TSynHighlighterAttributes.Create(SYNS_AttrSymbol, SYNS_FriendlyAttrSymbol);\r\n\r\n  AddAttribute(fCommentAttri);\r\n  AddAttribute(fIdentifierAttri);\r\n  AddAttribute(fInvalidAttri);\r\n  AddAttribute(fKeyAttri);\r\n  AddAttribute(fNumberAttri);\r\n  AddAttribute(fSpaceAttri);\r\n  AddAttribute(fStringAttri);\r\n  AddAttribute(fSymbolAttri);\r\n\r\n  SetAttributesOnChange(DefHighlightChange);\r\n  InitIdent;\r\n  fRange         := rsUnknown;\r\n  fDefaultFilter := SYNS_FilterGWS;\r\nend; { Create }\r\n\r\nprocedure TSynGWScriptSyn.AnsiCProc;\r\nbegin\r\n  fTokenID := tkComment;\r\n  case FLine[Run] of\r\n    #0:\r\n      begin\r\n        NullProc;\r\n        exit;\r\n      end;\r\n    #10:\r\n      begin\r\n        LFProc;\r\n        exit;\r\n      end;\r\n    #13:\r\n      begin\r\n        CRProc;\r\n        exit;\r\n      end;\r\n  end;\r\n\r\n  while FLine[Run] <> #0 do\r\n    case FLine[Run] of\r\n      '*':\r\n        if fLine[Run + 1] = '/' then begin\r\n          inc(Run, 2);\r\n          fRange := rsUnKnown;\r\n          break;\r\n        end else\r\n          inc(Run);\r\n      #10: break;\r\n      #13: break;\r\n    else inc(Run);\r\n    end;\r\nend;\r\n\r\nprocedure TSynGWScriptSyn.AndSymbolProc;\r\nbegin\r\n  fTokenID := tkSymbol;\r\n  case FLine[Run + 1] of\r\n    '=':                               {and assign}\r\n      begin\r\n        inc(Run, 2);\r\n        FExtTokenID := xtkAndAssign;\r\n      end;\r\n    '&':                               {logical and}\r\n      begin\r\n        inc(Run, 2);\r\n        FExtTokenID := xtkLogAnd;\r\n      end;\r\n  else                                 {and}\r\n    begin\r\n      inc(Run);\r\n      FExtTokenID := xtkAnd;\r\n    end;\r\n  end;\r\nend;\r\n\r\nprocedure TSynGWScriptSyn.AsciiCharProc;\r\nbegin\r\n  fTokenID := tkString;\r\n  repeat\r\n    if fLine[Run] = '\\' then begin\r\n      if CharInSet(fLine[Run + 1], [#39, '\\']) then\r\n        inc(Run);\r\n    end;\r\n    inc(Run);\r\n  until IsLineEnd(Run) or (fLine[Run] = #39);\r\n  if fLine[Run] = #39 then\r\n    inc(Run);\r\nend;\r\n\r\nprocedure TSynGWScriptSyn.AtSymbolProc;\r\nbegin\r\n  fTokenID := tkUnknown;\r\n  inc(Run);\r\nend;\r\n\r\nprocedure TSynGWScriptSyn.BraceCloseProc;\r\nbegin\r\n  inc(Run);\r\n  fTokenId := tkSymbol;\r\n  FExtTokenID := xtkBraceClose;\r\n  fRange := rsUnknown;\r\nend;\r\n\r\nprocedure TSynGWScriptSyn.BraceOpenProc;\r\nbegin\r\n  inc(Run);\r\n  fTokenId := tkSymbol;\r\n  FExtTokenID := xtkBraceOpen;\r\nend;\r\n\r\nprocedure TSynGWScriptSyn.CRProc;\r\nbegin\r\n  fTokenID := tkSpace;\r\n  Inc(Run);\r\n  if fLine[Run + 1] = #10 then Inc(Run);\r\nend;\r\n\r\nprocedure TSynGWScriptSyn.ColonProc;\r\nbegin\r\n  fTokenID := tkSymbol;\r\n  Case FLine[Run + 1] of\r\n    ':':                               {scope resolution operator}\r\n      begin\r\n        inc(Run, 2);\r\n        FExtTokenID := xtkScopeResolution;\r\n      end;\r\n  else                                 {colon}\r\n    begin\r\n      inc(Run);\r\n      FExtTokenID := xtkColon;\r\n    end;\r\n  end;\r\nend;\r\n\r\nprocedure TSynGWScriptSyn.CommaProc;\r\nbegin\r\n  inc(Run);\r\n  fTokenID := tkSymbol;\r\n  FExtTokenID := xtkComma;\r\nend;\r\n\r\nprocedure TSynGWScriptSyn.EqualProc;\r\nbegin\r\n  fTokenID := tkSymbol;\r\n  case FLine[Run + 1] of\r\n    '=':                               {logical equal}\r\n      begin\r\n        inc(Run, 2);\r\n        FExtTokenID := xtkLogEqual;\r\n      end;\r\n  else                                 {assign}\r\n    begin\r\n      inc(Run);\r\n      FExtTokenID := xtkAssign;\r\n    end;\r\n  end;\r\nend;\r\n\r\nprocedure TSynGWScriptSyn.GreaterProc;\r\nbegin\r\n  fTokenID := tkSymbol;\r\n  Case FLine[Run + 1] of\r\n    '=':                               {greater than or equal to}\r\n      begin\r\n        inc(Run, 2);\r\n        FExtTokenID := xtkGreaterThanEqual;\r\n      end;\r\n    '>':\r\n      begin\r\n        if FLine[Run + 2] = '=' then   {shift right assign}\r\n        begin\r\n          inc(Run, 3);\r\n          FExtTokenID := xtkShiftRightAssign;\r\n        end\r\n        else                           {shift right}\r\n        begin\r\n          inc(Run, 2);\r\n          FExtTokenID := xtkShiftRight;\r\n        end;\r\n      end;\r\n  else                                 {greater than}\r\n    begin\r\n      inc(Run);\r\n      FExtTokenID := xtkGreaterThan;\r\n    end;\r\n  end;\r\nend;\r\n\r\nprocedure TSynGWScriptSyn.QuestionProc;\r\nbegin\r\n  fTokenID := tkSymbol;                {conditional}\r\n  FExtTokenID := xtkQuestion;\r\n  inc(Run);\r\nend;\r\n\r\nprocedure TSynGWScriptSyn.IdentProc;\r\nbegin\r\n  fTokenID := IdentKind((fLine + Run));\r\n  inc(Run, fStringLen);\r\n  while IsIdentChar(fLine[Run]) do inc(Run);\r\nend;\r\n\r\nprocedure TSynGWScriptSyn.LFProc;\r\nbegin\r\n  fTokenID := tkSpace;\r\n  inc(Run);\r\nend;\r\n\r\nprocedure TSynGWScriptSyn.LowerProc;\r\nbegin\r\n  fTokenID := tkSymbol;\r\n  case FLine[Run + 1] of\r\n    '=':                               {less than or equal to}\r\n      begin\r\n        inc(Run, 2);\r\n        FExtTokenID := xtkLessThanEqual;\r\n      end;\r\n    '<':\r\n      begin\r\n        if FLine[Run + 2] = '=' then   {shift left assign}\r\n        begin\r\n          inc(Run, 3);\r\n          FExtTokenID := xtkShiftLeftAssign;\r\n        end\r\n        else                           {shift left}\r\n        begin\r\n          inc(Run, 2);\r\n          FExtTokenID := xtkShiftLeft;\r\n        end;\r\n      end;\r\n  else                                 {less than}\r\n    begin\r\n      inc(Run);\r\n      FExtTokenID := xtkLessThan;\r\n    end;\r\n  end;\r\nend;\r\n\r\nprocedure TSynGWScriptSyn.MinusProc;\r\nbegin\r\n  fTokenID := tkSymbol;\r\n  case FLine[Run + 1] of\r\n    '=':                               {subtract assign}\r\n      begin\r\n        inc(Run, 2);\r\n        FExtTokenID := xtkSubtractAssign;\r\n      end;\r\n    '-':                               {decrement}\r\n      begin\r\n        inc(Run, 2);\r\n        FExtTokenID := xtkDecrement;\r\n      end;\r\n    '>':                               {arrow}\r\n      begin\r\n        inc(Run, 2);\r\n        FExtTokenID := xtkArrow;\r\n      end;\r\n  else                                 {subtract}\r\n    begin\r\n      inc(Run);\r\n      FExtTokenID := xtkSubtract;\r\n    end;\r\n  end;\r\nend;\r\n\r\nprocedure TSynGWScriptSyn.ModSymbolProc;\r\nbegin\r\n  fTokenID := tkSymbol;\r\n  case FLine[Run + 1] of\r\n    '=':                               {mod assign}\r\n      begin\r\n        inc(Run, 2);\r\n        FExtTokenID := xtkModAssign;\r\n      end;\r\n  else                                 {mod}\r\n    begin\r\n      inc(Run);\r\n      FExtTokenID := xtkMod;\r\n    end;\r\n  end;\r\nend;\r\n\r\nprocedure TSynGWScriptSyn.NotSymbolProc;\r\nbegin\r\n  fTokenID := tkSymbol;\r\n  case FLine[Run + 1] of\r\n    '=':                               {not equal}\r\n      begin\r\n        inc(Run, 2);\r\n        FExtTokenID := xtkNotEqual;\r\n      end;\r\n  else                                 {not}\r\n    begin\r\n      inc(Run);\r\n      FExtTokenID := xtkLogComplement;\r\n    end;\r\n  end;\r\nend;\r\n\r\nprocedure TSynGWScriptSyn.NullProc;\r\nbegin\r\n  fTokenID := tkNull;\r\n  inc(Run);\r\nend;\r\n\r\nprocedure TSynGWScriptSyn.NumberProc;\r\n\r\n  function IsNumberChar: Boolean;\r\n  begin\r\n    case fLine[Run] of\r\n      '0'..'9', 'A'..'F', 'a'..'f', '.', 'u', 'U', 'l', 'L', 'x', 'X':\r\n        Result := True;\r\n      else\r\n        Result := False;\r\n    end;\r\n  end;\r\n\r\nbegin\r\n  inc(Run);\r\n  fTokenID := tkNumber;\r\n  while IsNumberChar do\r\n  begin\r\n    case FLine[Run] of\r\n      '.':\r\n        if FLine[Run + 1] = '.' then break;\r\n    end;\r\n    inc(Run);\r\n  end;\r\nend;\r\n\r\nprocedure TSynGWScriptSyn.OrSymbolProc;\r\nbegin\r\n  fTokenID := tkSymbol;\r\n  case FLine[Run + 1] of\r\n    '=':                               {or assign}\r\n      begin\r\n        inc(Run, 2);\r\n        FExtTokenID := xtkIncOrAssign;\r\n      end;\r\n    '|':                               {logical or}\r\n      begin\r\n        inc(Run, 2);\r\n        FExtTokenID := xtkLogOr;\r\n      end;\r\n  else                                 {or}\r\n    begin\r\n      inc(Run);\r\n      FExtTokenID := xtkIncOr;\r\n    end;\r\n  end;\r\nend;\r\n\r\nprocedure TSynGWScriptSyn.PlusProc;\r\nbegin\r\n  fTokenID := tkSymbol;\r\n  case FLine[Run + 1] of\r\n    '=':                               {add assign}\r\n      begin\r\n        inc(Run, 2);\r\n        FExtTokenID := xtkAddAssign;\r\n      end;\r\n    '+':                               {increment}\r\n      begin\r\n        inc(Run, 2);\r\n        FExtTokenID := xtkIncrement;\r\n      end;\r\n  else                                 {add}\r\n    begin\r\n      inc(Run);\r\n      FExtTokenID := xtkAdd;\r\n    end;\r\n  end;\r\nend;\r\n\r\nprocedure TSynGWScriptSyn.PointProc;\r\nbegin\r\n  fTokenID := tkSymbol;\r\n  if (FLine[Run + 1] = '.') and (FLine[Run + 2] = '.') then\r\n    begin                              {ellipse}\r\n      inc(Run, 3);\r\n      FExtTokenID := xtkEllipse;\r\n    end\r\n  else                                 {point}\r\n    begin\r\n      inc(Run);\r\n      FExtTokenID := xtkPoint;\r\n    end;\r\nend;\r\n\r\nprocedure TSynGWScriptSyn.RoundCloseProc;\r\nbegin\r\n  inc(Run);\r\n  fTokenID := tkSymbol;\r\n  FExtTokenID := xtkRoundClose;\r\nend;\r\n\r\nprocedure TSynGWScriptSyn.RoundOpenProc;\r\nbegin\r\n  inc(Run);\r\n  FTokenID := tkSymbol;\r\n  FExtTokenID := xtkRoundOpen;\r\nend;\r\n\r\nprocedure TSynGWScriptSyn.SemiColonProc;\r\nbegin\r\n  inc(Run);\r\n  fTokenID := tkSymbol;\r\n  FExtTokenID := xtkSemiColon;\r\n  fRange := rsUnknown;\r\nend;\r\n\r\nprocedure TSynGWScriptSyn.SlashProc;\r\nbegin\r\n  case FLine[Run + 1] of\r\n    '/':                               {c++ style comments}\r\n      begin\r\n        fTokenID := tkComment;\r\n        inc(Run, 2);\r\n       while not IsLineEnd(Run) do Inc(Run);\r\n      end;\r\n    '*':                               {c style comments}\r\n      begin\r\n        fTokenID := tkComment;\r\n        fRange := rsAnsiC;\r\n        inc(Run, 2);\r\n        while fLine[Run] <> #0 do\r\n          case fLine[Run] of\r\n            '*':\r\n              if fLine[Run + 1] = '/' then\r\n              begin\r\n                inc(Run, 2);\r\n                fRange := rsUnKnown;\r\n                break;\r\n              end else inc(Run);\r\n            #10: break;\r\n            #13: break;\r\n          else inc(Run);\r\n          end;\r\n      end;\r\n    '=':                               {divide assign}\r\n      begin\r\n        inc(Run, 2);\r\n        fTokenID := tkSymbol;\r\n        FExtTokenID := xtkDivideAssign;\r\n      end;\r\n  else                                 {divide}\r\n    begin\r\n      inc(Run);\r\n      fTokenID := tkSymbol;\r\n      FExtTokenID := xtkDivide;\r\n    end;\r\n  end;\r\nend;\r\n\r\nprocedure TSynGWScriptSyn.SpaceProc;\r\nbegin\r\n  inc(Run);\r\n  fTokenID := tkSpace;\r\n  while (FLine[Run] <= #32) and not IsLineEnd(Run) do inc(Run);\r\nend;\r\n\r\nprocedure TSynGWScriptSyn.SquareCloseProc;\r\nbegin\r\n  inc(Run);\r\n  fTokenID := tkSymbol;\r\n  FExtTokenID := xtkSquareClose;\r\nend;\r\n\r\nprocedure TSynGWScriptSyn.SquareOpenProc;\r\nbegin\r\n  inc(Run);\r\n  fTokenID := tkSymbol;\r\n  FExtTokenID := xtkSquareOpen;\r\nend;\r\n\r\nprocedure TSynGWScriptSyn.StarProc;\r\nbegin\r\n  fTokenID := tkSymbol;\r\n  case FLine[Run + 1] of\r\n    '=':                               {multiply assign}\r\n      begin\r\n        inc(Run, 2);\r\n        FExtTokenID := xtkMultiplyAssign;\r\n      end;\r\n  else                                 {star}\r\n    begin\r\n      inc(Run);\r\n      FExtTokenID := xtkStar;\r\n    end;\r\n  end;\r\nend;\r\n\r\nprocedure TSynGWScriptSyn.StringProc;\r\nbegin\r\n  fTokenID := tkString;\r\n  if (FLine[Run + 1] = #34) and (FLine[Run + 2] = #34) then inc(Run, 2);\r\n  repeat\r\n    case FLine[Run] of\r\n      #0, #10, #13: break;\r\n      #92:                             {backslash}\r\n        case FLine[Run + 1] of\r\n          #34: inc(Run);               {escaped quote doesn't count}\r\n          #92: inc(Run);               {escaped backslash doesn't count}\r\n        end;\r\n    end;\r\n    inc(Run);\r\n  until FLine[Run] = #34;\r\n  if FLine[Run] <> #0 then inc(Run);\r\nend;\r\n\r\nprocedure TSynGWScriptSyn.TildeProc;\r\nbegin\r\n  inc(Run);                            {bitwise complement}\r\n  fTokenId := tkSymbol;\r\n  FExtTokenID := xtkBitComplement;\r\nend;\r\n\r\nprocedure TSynGWScriptSyn.XOrSymbolProc;\r\nbegin\r\n  fTokenID := tkSymbol;\r\n  Case FLine[Run + 1] of\r\n  \t'=':                               {xor assign}\r\n      begin\r\n        inc(Run, 2);\r\n        FExtTokenID := xtkXorAssign;\r\n      end;\r\n  else                                 {xor}\r\n    begin\r\n      inc(Run);\r\n      FExtTokenID := xtkXor;\r\n    end;\r\n  end;\r\nend;\r\n\r\nprocedure TSynGWScriptSyn.UnknownProc;\r\nbegin\r\n  inc(Run);\r\n  fTokenID := tkUnknown;\r\nend;\r\n\r\nprocedure TSynGWScriptSyn.Next;\r\nbegin\r\n  fTokenPos := Run;\r\n  case fRange of\r\n    rsAnsiC : AnsiCProc;\r\n  else\r\n    begin\r\n      fRange := rsUnknown;\r\n      case fLine[Run] of\r\n        '&': AndSymbolProc;\r\n        #39: AsciiCharProc;\r\n        '@': AtSymbolProc;\r\n        '}': BraceCloseProc;\r\n        '{': BraceOpenProc;\r\n        #13: CRProc;\r\n        ':': ColonProc;\r\n        ',': CommaProc;\r\n        '=': EqualProc;\r\n        '>': GreaterProc;\r\n        '?': QuestionProc;\r\n        'A'..'Z', 'a'..'z', '_': IdentProc;\r\n        #10: LFProc;\r\n        '<': LowerProc;\r\n        '-': MinusProc;\r\n        '%': ModSymbolProc;\r\n        '!': NotSymbolProc;\r\n        #0: NullProc;\r\n        '0'..'9': NumberProc;\r\n        '|': OrSymbolProc;\r\n        '+': PlusProc;\r\n        '.': PointProc;\r\n        ')': RoundCloseProc;\r\n        '(': RoundOpenProc;\r\n        ';': SemiColonProc;\r\n        '/': SlashProc;\r\n        #1..#9, #11, #12, #14..#32: SpaceProc;\r\n        ']': SquareCloseProc;\r\n        '[': SquareOpenProc;\r\n        '*': StarProc;\r\n        #34: StringProc;\r\n        '~': TildeProc;\r\n        '^': XOrSymbolProc;\r\n        else UnknownProc;\r\n      end;\r\n    end;\r\n  end;\r\n  inherited;\r\nend;\r\n\r\nfunction TSynGWScriptSyn.GetEol: Boolean;\r\nbegin\r\n  Result := Run = fLineLen + 1;\r\nend;\r\n\r\nfunction TSynGWScriptSyn.GetRange: Pointer;\r\nbegin\r\n  Result := Pointer(fRange);\r\nend;\r\n\r\nfunction TSynGWScriptSyn.GetTokenID: TtkTokenKind;\r\nbegin\r\n  Result := fTokenId;\r\nend;\r\n\r\nfunction TSynGWScriptSyn.GetExtTokenID: TxtkTokenKind;\r\nbegin\r\n  Result := FExtTokenID;\r\nend;\r\n\r\nfunction TSynGWScriptSyn.GetTokenAttribute: TSynHighlighterAttributes;\r\nbegin\r\n  case fTokenID of\r\n    tkComment: Result := fCommentAttri;\r\n    tkIdentifier: Result := fIdentifierAttri;\r\n    tkKey: Result := fKeyAttri;\r\n    tkNumber: Result := fNumberAttri;\r\n    tkSpace: Result := fSpaceAttri;\r\n    tkString: Result := fStringAttri;\r\n    tkSymbol: Result := fSymbolAttri;\r\n    tkUnknown: Result := fInvalidAttri;\r\n    else Result := nil;\r\n  end;\r\nend;\r\n\r\nfunction TSynGWScriptSyn.GetTokenKind: integer;\r\nbegin\r\n  Result := Ord(GetTokenID);\r\nend;\r\n\r\nprocedure TSynGWScriptSyn.ResetRange;\r\nbegin\r\n  fRange:= rsUnknown;\r\nend;\r\n\r\nprocedure TSynGWScriptSyn.SetRange(Value: Pointer);\r\nbegin\r\n  fRange := TRangeState(Value);\r\nend;\r\n\r\nfunction TSynGWScriptSyn.IsFilterStored: Boolean;\r\nbegin\r\n  Result := fDefaultFilter <> SYNS_FilterGWS;\r\nend;\r\n\r\nclass function TSynGWScriptSyn.GetLanguageName: string;\r\nbegin\r\n  Result := SYNS_LangGWS;\r\nend;\r\n\r\nfunction TSynGWScriptSyn.GetDefaultAttribute (Index: integer): TSynHighlighterAttributes;\r\nbegin\r\n  case Index of\r\n    SYN_ATTR_COMMENT    : Result := fCommentAttri;\r\n    SYN_ATTR_IDENTIFIER : Result := fIdentifierAttri;\r\n    SYN_ATTR_KEYWORD    : Result := fKeyAttri;\r\n    SYN_ATTR_STRING     : Result := fStringAttri;\r\n    SYN_ATTR_WHITESPACE : Result := fSpaceAttri;\r\n    SYN_ATTR_SYMBOL     : Result := fSymbolAttri;\r\n  else\r\n    Result := nil;\r\n  end;\r\nend;\r\n\r\nclass function TSynGWScriptSyn.GetFriendlyLanguageName: UnicodeString;\r\nbegin\r\n  Result := SYNS_FriendlyLangGWS;\r\nend;\r\n\r\ninitialization\r\n{$IFNDEF SYN_CPPB_1}\r\n  RegisterPlaceableHighlighter (TSynGWScriptSyn);\r\n{$ENDIF}\r\nend.\r\n"
  },
  {
    "path": "External/SynEdit/Source/SynHighlighterGalaxy.pas",
    "content": "{-------------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: SynHighlighterGalaxy.pas, released 2000-04-07.\r\nThe Original Code is based on the mkGalaxySyn.pas file from the\r\nmwEdit component suite by Martin Waldenburg and other developers, the Initial\r\nAuthor of this file is Martijn van der Kooij.\r\nUnicode translation by Mal Hrz.\r\nAll Rights Reserved.\r\n\r\nContributors to the SynEdit and mwEdit projects are listed in the\r\nContributors.txt file.\r\n\r\nAlternatively, the contents of this file may be used under the terms of the\r\nGNU General Public License Version 2 or later (the \"GPL\"), in which case\r\nthe provisions of the GPL are applicable instead of those above.\r\nIf you wish to allow use of your version of this file only under the terms\r\nof the GPL and not to allow others to use your version of this file\r\nunder the MPL, indicate your decision by deleting the provisions above and\r\nreplace them with the notice and other provisions required by the GPL.\r\nIf you do not delete the provisions above, a recipient may use your version\r\nof this file under either the MPL or the GPL.\r\n\r\n$Id: SynHighlighterGalaxy.pas,v 1.12.2.8 2008/09/14 16:25:00 maelh Exp $\r\n\r\nYou may retrieve the latest version of this file at the SynEdit home page,\r\nlocated at http://SynEdit.SourceForge.net\r\n\r\nKnown Issues:\r\n-------------------------------------------------------------------------------}\r\n{\r\n@abstract(Provides a Galaxy highlighter for SynEdit)\r\n@author(Martijn van der Kooij, converted to SynEdit by David Muir )\r\n@created(May 1999, converted to SynEdit June 19, 2000)\r\n@lastmod(2000-06-23)\r\nThe SynHighlighterGalaxy unit provides SynEdit with a Galaxy highlighter.\r\nGalaxy is a PBEM game for 10 to 500+ players, to see it wokring goto: http://members.tripod.com/~erisande/kooij.html .\r\nThe keywords in the string list KeyWords have to be in lowercase and sorted.\r\n}\r\n\r\n{$IFNDEF QSYNHIGHLIGHTERGALAXY}\r\nunit SynHighlighterGalaxy;\r\n{$ENDIF}\r\n\r\n{$I SynEdit.inc}\r\n\r\ninterface\r\n\r\nuses\r\n{$IFDEF SYN_CLX}\r\n  QGraphics,\r\n  QSynEditHighlighter,\r\n  QSynUnicode,\r\n{$ELSE}\r\n  Windows,\r\n  Graphics,\r\n  SynEditHighlighter,\r\n  SynUnicode,\r\n{$ENDIF}\r\n  SysUtils, Classes;\r\n\r\ntype\r\n  TtkTokenKind = (tkComment, tkIdentifier, tkKey, tkNull, tkSpace, tkMessage,\r\n    tkUnknown);\r\n\r\n  TRangeState = (rsUnKnown, rsMessageStyle);\r\n\r\ntype\r\n  TSynGalaxySyn = class(TSynCustomHighlighter)\r\n  private\r\n    fRange: TRangeState;\r\n    FTokenID: TtkTokenKind;\r\n    fMessageAttri: TSynHighlighterAttributes;\r\n    fSymbolAttri: TSynHighlighterAttributes;\r\n    fKeyAttri: TSynHighlighterAttributes;\r\n    fCommentAttri: TSynHighlighterAttributes;\r\n    fSpaceAttri: TSynHighlighterAttributes;\r\n    fIdentifierAttri: TSynHighlighterAttributes;\r\n    fKeyWords: TUnicodeStrings;\r\n    procedure PointCommaProc;\r\n    procedure CRProc;\r\n    procedure IdentProc;\r\n    procedure LFProc;\r\n    procedure NullProc;\r\n    procedure SpaceProc;\r\n    procedure StringProc;\r\n    procedure UnknownProc;\r\n    procedure MessageStyleProc;\r\n    procedure SetKeyWords(const Value: TUnicodeStrings);\r\n  protected\r\n    function IsFilterStored: Boolean; override;\r\n  public\r\n    class function GetLanguageName: string; override;\r\n    class function GetFriendlyLanguageName: UnicodeString; override;\r\n  public\r\n    constructor Create(AOwner: TComponent); override;\r\n    destructor Destroy; override;\r\n    function GetDefaultAttribute(Index: integer): TSynHighlighterAttributes;\r\n      override;\r\n    function GetEol: Boolean; override;\r\n    function GetRange: Pointer; override;\r\n    function GetTokenID: TtkTokenKind;\r\n    function GetTokenAttribute: TSynHighlighterAttributes; override;\r\n    function GetTokenKind: integer; override;\r\n    function IsIdentChar(AChar: WideChar): Boolean; override;\r\n    function IsKeyword(const AKeyword: UnicodeString): Boolean; override;\r\n    procedure Next; override;\r\n    procedure SetRange(Value: Pointer); override;\r\n    procedure ResetRange; override;\r\n    {$IFNDEF SYN_CLX}\r\n    function SaveToRegistry(RootKey: HKEY; Key: string): boolean; override;\r\n    function LoadFromRegistry(RootKey: HKEY; Key: string): boolean; override;\r\n    {$ENDIF}\r\n  published\r\n    property CommentAttri: TSynHighlighterAttributes read fCommentAttri\r\n      write fCommentAttri;\r\n    property IdentifierAttri: TSynHighlighterAttributes read fIdentifierAttri\r\n      write fIdentifierAttri;\r\n    property KeyAttri: TSynHighlighterAttributes read fKeyAttri write fKeyAttri;\r\n    property KeyWords: TUnicodeStrings read fKeyWords write SetKeyWords;\r\n    property SpaceAttri: TSynHighlighterAttributes read fSpaceAttri\r\n      write fSpaceAttri;\r\n    property MessageAttri: TSynHighlighterAttributes read fMessageAttri\r\n      write fMessageAttri;\r\n  end;\r\n\r\nimplementation\r\n\r\nuses\r\n{$IFDEF SYN_CLX}\r\n  QSynEditStrConst;\r\n{$ELSE}\r\n  SynEditStrConst;\r\n{$ENDIF}\r\n\r\nfunction TSynGalaxySyn.IsIdentChar(AChar: WideChar): Boolean;\r\nbegin\r\n  case AChar of\r\n   '_', '0'..'9', 'a'..'z', 'A'..'Z', '#':\r\n      Result := True;\r\n    else\r\n      Result := False;\r\n  end;\r\nend;\r\n\r\nfunction TSynGalaxySyn.IsKeyword(const AKeyword: UnicodeString): Boolean;\r\nvar\r\n  First, Last, I, Compare: Integer;\r\n  Token: UnicodeString;\r\nbegin\r\n  First := 0;\r\n  Last := fKeywords.Count - 1;\r\n  Result := False;\r\n  Token := SynWideUpperCase(AKeyword);\r\n  while First <= Last do\r\n  begin\r\n    I := (First + Last) shr 1;\r\n    Compare := WideCompareStr(fKeywords[i], Token);\r\n    if Compare = 0 then\r\n    begin\r\n      Result := True;\r\n      break;\r\n    end else\r\n      if Compare < 0 then First := I + 1 else Last := I - 1;\r\n  end;\r\nend; { IsKeyWord }\r\n\r\nconstructor TSynGalaxySyn.Create(AOwner: TComponent);\r\nbegin\r\n  inherited Create(AOwner);\r\n\r\n  fCaseSensitive := False;\r\n\r\n  fKeyWords := TUnicodeStringList.Create;\r\n  TUnicodeStringList(fKeyWords).Sorted := True;\r\n  TUnicodeStringList(fKeyWords).Duplicates := dupIgnore;\r\n  TUnicodeStringList(fKeyWords).CommaText :=\r\n    '#end,#galaxy,a,anonymous,autounload,b,battleprotocol,c,cap,cargo,col,' +\r\n    'compress,d,drive,e,emp,f,fleet,fleettables,g,galaxytv,gplus,groupforecast,' +\r\n    'h,i,j,l,m,machinereport,mat,n,namecase,no,o,options,p,planetforecast,' +\r\n    'prodtable,produce,q,r,routesforecast,s,send,shields,shiptypeforecast,' +\r\n    'sortgroups,t,twocol,u,underscores,v,w,war,weapons,x,y,z';\r\n  fCommentAttri := TSynHighlighterAttributes.Create(SYNS_AttrComment, SYNS_FriendlyAttrComment);\r\n  fCommentAttri.Style := [fsItalic];\r\n  AddAttribute(fCommentAttri);\r\n  fIdentifierAttri := TSynHighlighterAttributes.Create(SYNS_AttrIdentifier, SYNS_FriendlyAttrIdentifier);\r\n  AddAttribute(fIdentifierAttri);\r\n  fKeyAttri := TSynHighlighterAttributes.Create(SYNS_AttrReservedWord, SYNS_FriendlyAttrReservedWord);\r\n  fKeyAttri.Style := [fsBold];\r\n  AddAttribute(fKeyAttri);\r\n  fSpaceAttri := TSynHighlighterAttributes.Create(SYNS_AttrSpace, SYNS_FriendlyAttrSpace);\r\n  AddAttribute(fSpaceAttri);\r\n  fMessageAttri := TSynHighlighterAttributes.Create(SYNS_AttrMessage, SYNS_FriendlyAttrMessage);\r\n  AddAttribute(fMessageAttri);\r\n  fSymbolAttri := TSynHighlighterAttributes.Create(SYNS_AttrSymbol, SYNS_FriendlyAttrSymbol);\r\n  AddAttribute(fSymbolAttri);\r\n  SetAttributesOnChange(DefHighlightChange);\r\n\r\n  fRange := rsUnknown;\r\n  fDefaultFilter := SYNS_FilterGalaxy;\r\nend; { Create }\r\n\r\ndestructor TSynGalaxySyn.Destroy;\r\nbegin\r\n  fKeyWords.Free;\r\n  inherited Destroy;\r\nend; { Destroy }\r\n\r\nprocedure TSynGalaxySyn.MessageStyleProc;\r\nbegin\r\n  fTokenID := tkMessage;\r\n  case FLine[Run] of\r\n    #0:\r\n      begin\r\n        NullProc;\r\n        exit;\r\n      end;\r\n    #10:\r\n      begin\r\n        LFProc;\r\n        exit;\r\n      end;\r\n\r\n    #13:\r\n      begin\r\n        CRProc;\r\n        exit;\r\n      end;\r\n  end;\r\n\r\n  if (Run = 0) and (FLine[Run] = '@') then begin\r\n    fRange := rsUnKnown;\r\n    inc(Run);\r\n  end else\r\n    while FLine[Run] <> #0 do\r\n      inc(Run);\r\nend;\r\n\r\nprocedure TSynGalaxySyn.PointCommaProc;                                         \r\nbegin\r\n  fTokenID := tkComment;\r\n  fRange := rsUnknown;\r\n  repeat\r\n    inc(Run);\r\n  until fLine[Run] = #0;\r\nend;\r\n\r\nprocedure TSynGalaxySyn.CRProc;\r\nbegin\r\n  fTokenID := tkSpace;\r\n  Inc(Run);\r\n  if fLine[Run] = #10 then\r\n    Inc(Run);\r\nend;\r\n\r\nprocedure TSynGalaxySyn.IdentProc;\r\nbegin\r\n  while IsIdentChar(fLine[Run]) do\r\n    Inc(Run);\r\n  if IsKeyWord(GetToken) then\r\n    fTokenId := tkKey\r\n  else\r\n    fTokenId := tkIdentifier;\r\nend;\r\n\r\nprocedure TSynGalaxySyn.LFProc;\r\nbegin\r\n  fTokenID := tkSpace;\r\n  inc(Run);\r\nend;\r\n\r\nprocedure TSynGalaxySyn.NullProc;\r\nbegin\r\n  fTokenID := tkNull;\r\n  inc(Run);\r\nend;\r\n\r\nprocedure TSynGalaxySyn.SpaceProc;\r\nbegin\r\n  inc(Run);\r\n  fTokenID := tkSpace;\r\n  while (FLine[Run] <= #32) and not IsLineEnd(Run) do inc(Run);\r\nend;\r\n\r\nprocedure TSynGalaxySyn.StringProc;\r\nbegin\r\n  if (Run = 0) and (fTokenID <> tkMessage) then\r\n  begin\r\n    fTokenID := tkMessage;\r\n    fRange := rsMessageStyle;\r\n  end;\r\n  inc(Run);\r\nend;\r\n\r\nprocedure TSynGalaxySyn.UnknownProc;\r\nbegin\r\n  inc(Run);\r\n  fTokenID := tkUnKnown;\r\nend;\r\n\r\nprocedure TSynGalaxySyn.Next;\r\nbegin\r\n  fTokenPos := Run;\r\n  if fRange = rsMessageStyle then\r\n    MessageStyleProc\r\n  else\r\n    case fLine[Run] of\r\n      ';': PointCommaProc;                                      \r\n      #13: CRProc;\r\n      '#','A'..'Z', 'a'..'z', '_': IdentProc;\r\n      #10: LFProc;\r\n      #0: NullProc;\r\n      #1..#9, #11, #12, #14..#32: SpaceProc;\r\n      '@': StringProc;\r\n      else UnknownProc;\r\n    end;\r\n  inherited;\r\nend;\r\n\r\nfunction TSynGalaxySyn.GetDefaultAttribute(Index: integer): TSynHighlighterAttributes;\r\nbegin\r\n  case Index of\r\n    SYN_ATTR_COMMENT: Result := fCommentAttri;\r\n    SYN_ATTR_IDENTIFIER: Result := fIdentifierAttri;\r\n    SYN_ATTR_KEYWORD: Result := fKeyAttri;\r\n    SYN_ATTR_WHITESPACE: Result := fSpaceAttri;\r\n    SYN_ATTR_SYMBOL: Result := fSymbolAttri;\r\n  else\r\n    Result := nil;\r\n  end;\r\nend;\r\n\r\nfunction TSynGalaxySyn.GetEol: Boolean;\r\nbegin\r\n  Result := Run = fLineLen + 1;\r\nend;\r\n\r\nfunction TSynGalaxySyn.GetRange: Pointer;\r\nbegin\r\n  Result := Pointer(fRange);\r\nend;\r\n\r\nfunction TSynGalaxySyn.GetTokenID: TtkTokenKind;\r\nbegin\r\n  Result := fTokenId;\r\nend;\r\n\r\nfunction TSynGalaxySyn.GetTokenAttribute: TSynHighlighterAttributes;\r\nbegin\r\n  case fTokenID of\r\n    tkComment: Result := fCommentAttri;\r\n    tkIdentifier: Result := fIdentifierAttri;\r\n    tkKey: Result := fKeyAttri;\r\n    tkMessage: Result := fMessageAttri;\r\n    tkSpace: Result := fSpaceAttri;\r\n    tkUnknown: Result := fSymbolAttri;\r\n  else\r\n    Result := nil;\r\n  end;\r\nend;\r\n\r\nfunction TSynGalaxySyn.GetTokenKind: integer;\r\nbegin\r\n  Result := Ord(fTokenId);\r\nend;\r\n\r\nprocedure TSynGalaxySyn.ResetRange;\r\nbegin\r\n  fRange := rsUnknown;\r\nend;\r\n\r\nprocedure TSynGalaxySyn.SetRange(Value: Pointer);\r\nbegin\r\n  fRange := TRangeState(Value);\r\nend;\r\n\r\nprocedure TSynGalaxySyn.SetKeyWords(const Value: TUnicodeStrings);\r\nvar\r\n  i: Integer;\r\nbegin\r\n  if Value <> nil then\r\n    begin\r\n      Value.BeginUpdate;\r\n      for i := 0 to Value.Count - 1 do\r\n        Value[i] := SynWideUpperCase(Value[i]);\r\n      Value.EndUpdate;\r\n    end;\r\n  fKeyWords.Assign(Value);\r\n  DefHighLightChange(nil);\r\nend;\r\n\r\nfunction TSynGalaxySyn.IsFilterStored: Boolean;\r\nbegin\r\n  Result := fDefaultFilter <> SYNS_FilterGalaxy;\r\nend;\r\n\r\nclass function TSynGalaxySyn.GetLanguageName: string;\r\nbegin\r\n  Result := SYNS_LangGalaxy;\r\nend;\r\n\r\n{$IFNDEF SYN_CLX}\r\nfunction TSynGalaxySyn.LoadFromRegistry(RootKey: HKEY; Key: string): boolean;\r\nvar\r\n  r: TBetterRegistry;\r\nbegin\r\n  r:= TBetterRegistry.Create;\r\n  try\r\n    r.RootKey := RootKey;\r\n    if r.OpenKeyReadOnly(Key) then\r\n    begin\r\n      if r.ValueExists('KeyWords') then KeyWords.Text:= r.ReadString('KeyWords');\r\n      Result := inherited LoadFromRegistry(RootKey, Key);\r\n    end\r\n    else\r\n      Result := False;\r\n  finally\r\n    r.Free;\r\n  end;\r\nend;\r\n\r\nfunction TSynGalaxySyn.SaveToRegistry(RootKey: HKEY; Key: string): boolean;\r\nvar\r\n  r: TBetterRegistry;\r\nbegin\r\n  r:= TBetterRegistry.Create;\r\n  try\r\n    r.RootKey := RootKey;\r\n    if r.OpenKey(Key,true) then\r\n    begin\r\n      Result := true;\r\n      r.WriteString('KeyWords', KeyWords.Text);\r\n      Result := inherited SaveToRegistry(RootKey, Key);\r\n    end\r\n    else\r\n      Result := false;\r\n  finally\r\n    r.Free;\r\n  end;\r\nend;\r\n{$ENDIF}\r\n\r\nclass function TSynGalaxySyn.GetFriendlyLanguageName: UnicodeString;\r\nbegin\r\n  Result := SYNS_FriendlyLangGalaxy;\r\nend;\r\n\r\ninitialization\r\n{$IFNDEF SYN_CPPB_1}\r\n  RegisterPlaceableHighlighter(TSynGalaxySyn);\r\n{$ENDIF}\r\nend.\r\n"
  },
  {
    "path": "External/SynEdit/Source/SynHighlighterGeneral.pas",
    "content": "{-------------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: SynHighlighterGeneral.pas, released 2000-04-07.\r\nThe Original Code is based on the mwGeneralSyn.pas file from the\r\nmwEdit component suite by Martin Waldenburg and other developers, the Initial\r\nAuthor of this file is Martin Waldenburg.\r\nPortions written by Martin Waldenburg are copyright 1999 Martin Waldenburg.\r\nUnicode translation by Mal Hrz.\r\nAll Rights Reserved.\r\n\r\nContributors to the SynEdit and mwEdit projects are listed in the\r\nContributors.txt file.\r\n\r\nAlternatively, the contents of this file may be used under the terms of the\r\nGNU General Public License Version 2 or later (the \"GPL\"), in which case\r\nthe provisions of the GPL are applicable instead of those above.\r\nIf you wish to allow use of your version of this file only under the terms\r\nof the GPL and not to allow others to use your version of this file\r\nunder the MPL, indicate your decision by deleting the provisions above and\r\nreplace them with the notice and other provisions required by the GPL.\r\nIf you do not delete the provisions above, a recipient may use your version\r\nof this file under either the MPL or the GPL.\r\n\r\n$Id: SynHighlighterGeneral.pas,v 1.12 2011/04/14 15:12:54 Egg Exp $\r\n\r\nYou may retrieve the latest version of this file at the SynEdit home page,\r\nlocated at http://SynEdit.SourceForge.net\r\n\r\nKnown Issues:\r\n-------------------------------------------------------------------------------}\r\n{\r\n@abstract(Provides a customizable highlighter for SynEdit)\r\n@author(Martin Waldenburg, converted to SynEdit by Michael Hieke)\r\n@created(1999)\r\n@lastmod(2000-06-23)\r\nThe SynHighlighterGeneral unit provides a customizable highlighter for SynEdit.\r\n}\r\n\r\n{$IFNDEF QSYNHIGHLIGHTERGENERAL}\r\nunit SynHighlighterGeneral;\r\n{$ENDIF}\r\n\r\n{$I SynEdit.inc}\r\n\r\ninterface\r\n\r\nuses\r\n{$IFDEF SYN_CLX}\r\n  QGraphics,\r\n  QSynEditTypes,\r\n  QSynEditHighlighter,\r\n  QSynUnicode,\r\n{$ELSE}\r\n  Windows,\r\n  Graphics,\r\n  SynEditTypes,\r\n  SynEditHighlighter,\r\n  SynUnicode,\r\n{$ENDIF}\r\n  SysUtils,\r\n  Classes;\r\n\r\ntype\r\n  TtkTokenKind = (tkComment, tkIdentifier, tkKey, tkNull, tkNumber,\r\n    tkPreprocessor, tkSpace, tkString, tkSymbol, tkUnknown);\r\n\r\n  TCommentStyle = (csAnsiStyle, csPasStyle, csCStyle, csAsmStyle, csBasStyle,\r\n    csCPPStyle);\r\n  TCommentStyles = set of TCommentStyle;\r\n\r\n  TRangeState = (rsANil, rsAnsi, rsPasStyle, rsCStyle, rsUnKnown);\r\n\r\n  TStringDelim = (sdSingleQuote, sdDoubleQuote, sdSingleAndDoubleQuote);\r\n\r\n  TGetTokenAttributeEvent = procedure (attribute : TSynHighlighterAttributes) of object;\r\n\r\nconst\r\n   cDefaultIdentChars = '_0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ' +\r\n                         'abcdefghijklmnopqrstuvwxyz';\r\n\r\ntype\r\n  TSynGeneralSyn = class(TSynCustomHighlighter)\r\n  private\r\n    fIdentChars: UnicodeString;\r\n    fRange: TRangeState;\r\n    fTokenID: TtkTokenKind;\r\n    fCommentAttri: TSynHighlighterAttributes;\r\n    fIdentifierAttri: TSynHighlighterAttributes;\r\n    fKeyAttri: TSynHighlighterAttributes;\r\n    fNumberAttri: TSynHighlighterAttributes;\r\n    fPreprocessorAttri: TSynHighlighterAttributes;                         \r\n    fSpaceAttri: TSynHighlighterAttributes;\r\n    fStringAttri: TSynHighlighterAttributes;\r\n    fSymbolAttri: TSynHighlighterAttributes;\r\n    fKeyWords: TUnicodeStrings;\r\n    fComments: TCommentStyles;\r\n    fStringDelim: TStringDelim;\r\n    fDetectPreprocessor: Boolean;\r\n    fOnGetTokenAttribute: TGetTokenAttributeEvent;\r\n    FStringMultiLine : Boolean;\r\n    procedure AsciiCharProc;\r\n    procedure BraceOpenProc;\r\n    procedure PointCommaProc;\r\n    procedure CRProc;\r\n    procedure IdentProc;\r\n    procedure IntegerProc;\r\n    procedure LFProc;\r\n    procedure NullProc;\r\n    procedure NumberProc;\r\n    procedure RoundOpenProc;\r\n    procedure SlashProc;\r\n    procedure SpaceProc;\r\n    procedure StringProc;\r\n    procedure UnknownProc;\r\n    procedure AnsiProc;\r\n    procedure PasStyleProc;\r\n    procedure CStyleProc;\r\n    procedure SetKeyWords(const Value: TUnicodeStrings);\r\n    procedure SetComments(Value: TCommentStyles);\r\n    function GetStringDelim: TStringDelim;\r\n    procedure SetStringDelim(const Value: TStringDelim);\r\n    function GetIdentifierChars: UnicodeString;\r\n    procedure SetIdentifierChars(const Value: UnicodeString);\r\n    function StoreIdentChars : Boolean;\r\n    procedure SetDetectPreprocessor(Value: boolean);\r\n  public\r\n    class function GetLanguageName: string; override;\r\n    class function GetFriendlyLanguageName: UnicodeString; override;\r\n    function IsStringDelim(aChar : WideChar) : Boolean;\r\n  public\r\n    constructor Create(AOwner: TComponent); override;\r\n    destructor Destroy; override;\r\n    function GetDefaultAttribute(Index: integer): TSynHighlighterAttributes;\r\n      override;\r\n    function GetEol: Boolean; override;\r\n    function GetRange: Pointer; override;\r\n    function GetTokenID: TtkTokenKind;\r\n    function GetCharBeforeToken(offset : Integer = -1) : WideChar;\r\n    function GetCharAfterToken(offset : Integer = 1) : WideChar;\r\n    function GetTokenAttribute: TSynHighlighterAttributes; override;\r\n    function GetTokenKind: integer; override;\r\n    function IsIdentChar(AChar: WideChar): Boolean; override;\r\n    function IsKeyword(const AKeyword: UnicodeString): Boolean; override;\r\n    function IsWordBreakChar(AChar: WideChar): Boolean; override;\r\n    procedure Next; override;\r\n    procedure ResetRange; override;\r\n    procedure SetRange(Value: Pointer); override;\r\n    {$IFNDEF SYN_CLX}\r\n    function SaveToRegistry(RootKey: HKEY; Key: string): boolean; override;\r\n    function LoadFromRegistry(RootKey: HKEY; Key: string): boolean; override;\r\n    {$ENDIF}\r\n    property OnGetTokenAttribute : TGetTokenAttributeEvent read fOnGetTokenAttribute write fOnGetTokenAttribute;\r\n    property StringMultiLine : Boolean read FStringMultiLine write FStringMultiLine;\r\n  published\r\n    property CommentAttri: TSynHighlighterAttributes read fCommentAttri\r\n      write fCommentAttri;\r\n    property Comments: TCommentStyles read fComments write SetComments default [];\r\n    property DetectPreprocessor: boolean read fDetectPreprocessor\r\n      write SetDetectPreprocessor;\r\n    property IdentifierAttri: TSynHighlighterAttributes read fIdentifierAttri\r\n      write fIdentifierAttri;\r\n    property IdentifierChars: UnicodeString read GetIdentifierChars\r\n      write SetIdentifierChars stored StoreIdentChars;\r\n    property KeyAttri: TSynHighlighterAttributes read fKeyAttri write fKeyAttri;\r\n    property KeyWords: TUnicodeStrings read fKeyWords write SetKeyWords;\r\n    property NumberAttri: TSynHighlighterAttributes read fNumberAttri\r\n      write fNumberAttri;\r\n    property PreprocessorAttri: TSynHighlighterAttributes\r\n      read fPreprocessorAttri write fPreprocessorAttri;\r\n    property SpaceAttri: TSynHighlighterAttributes read fSpaceAttri\r\n      write fSpaceAttri;\r\n    property StringAttri: TSynHighlighterAttributes read fStringAttri\r\n      write fStringAttri;\r\n    property SymbolAttri: TSynHighlighterAttributes read fSymbolAttri\r\n      write fSymbolAttri;\r\n    property StringDelim: TStringDelim read GetStringDelim write SetStringDelim\r\n      default sdSingleQuote;\r\n  end;\r\n\r\nimplementation\r\n\r\nuses\r\n{$IFDEF SYN_CLX}\r\n  QSynEditStrConst;\r\n{$ELSE}\r\n  SynEditStrConst;\r\n{$ENDIF}\r\n\r\nfunction TSynGeneralSyn.IsIdentChar(AChar: WideChar): Boolean;\r\nvar\r\n  i: Integer;\r\nbegin\r\n  Result := False;\r\n  for i := 1 to Length(fIdentChars) do\r\n    if AChar = fIdentChars[i] then\r\n    begin\r\n      Result := True;\r\n      Exit;\r\n    end;\r\nend;\r\n\r\nfunction TSynGeneralSyn.IsKeyword(const AKeyword: UnicodeString): Boolean;\r\nvar\r\n  First, Last, I, Compare: Integer;\r\n  Token: UnicodeString;\r\nbegin\r\n  First := 0;\r\n  Last := fKeywords.Count - 1;\r\n  Result := False;\r\n  Token := SynWideUpperCase(AKeyword);\r\n  while First <= Last do\r\n  begin\r\n    I := (First + Last) shr 1;\r\n    Compare := WideCompareText(fKeywords[i], Token);\r\n    if Compare = 0 then\r\n    begin\r\n      Result := True;\r\n      break;\r\n    end\r\n    else if Compare < 0 then\r\n      First := I + 1\r\n    else\r\n      Last := I - 1;\r\n  end;\r\nend; { IsKeyWord }\r\n\r\nfunction TSynGeneralSyn.IsWordBreakChar(AChar: WideChar): Boolean;\r\nbegin\r\n  Result := inherited IsWordBreakChar(AChar) and not IsIdentChar(AChar);\r\nend;\r\n\r\nconstructor TSynGeneralSyn.Create(AOwner: TComponent);\r\nbegin\r\n  inherited Create(AOwner);\r\n  fKeyWords := TUnicodeStringList.Create;\r\n  TUnicodeStringList(fKeyWords).Sorted := True;\r\n  TUnicodeStringList(fKeyWords).Duplicates := dupIgnore;\r\n  fCommentAttri := TSynHighlighterAttributes.Create(SYNS_AttrComment, SYNS_FriendlyAttrComment);\r\n  fCommentAttri.Style := [fsItalic];\r\n  AddAttribute(fCommentAttri);\r\n  fIdentifierAttri := TSynHighlighterAttributes.Create(SYNS_AttrIdentifier, SYNS_FriendlyAttrIdentifier);\r\n  AddAttribute(fIdentifierAttri);\r\n  fKeyAttri := TSynHighlighterAttributes.Create(SYNS_AttrReservedWord, SYNS_FriendlyAttrReservedWord);\r\n  fKeyAttri.Style := [fsBold];\r\n  AddAttribute(fKeyAttri);\r\n  fNumberAttri := TSynHighlighterAttributes.Create(SYNS_AttrNumber, SYNS_FriendlyAttrNumber);\r\n  AddAttribute(fNumberAttri);\r\n  fSpaceAttri := TSynHighlighterAttributes.Create(SYNS_AttrSpace, SYNS_FriendlyAttrSpace);\r\n  AddAttribute(fSpaceAttri);\r\n  fStringAttri := TSynHighlighterAttributes.Create(SYNS_AttrString, SYNS_FriendlyAttrString);\r\n  AddAttribute(fStringAttri);\r\n  fSymbolAttri := TSynHighlighterAttributes.Create(SYNS_AttrSymbol, SYNS_FriendlyAttrSymbol);\r\n  AddAttribute(fSymbolAttri);\r\n  fPreprocessorAttri := TSynHighlighterAttributes.Create(SYNS_AttrPreprocessor, SYNS_FriendlyAttrPreprocessor);\r\n  AddAttribute(fPreprocessorAttri);\r\n  SetAttributesOnChange(DefHighlightChange);\r\n\r\n  fStringDelim := sdSingleQuote;\r\n  fIdentChars := cDefaultIdentChars;\r\n  fRange := rsUnknown;\r\nend; { Create }\r\n\r\ndestructor TSynGeneralSyn.Destroy;\r\nbegin\r\n  fKeyWords.Free;\r\n  inherited Destroy;\r\nend; { Destroy }\r\n\r\nprocedure TSynGeneralSyn.AnsiProc;\r\nbegin\r\n  case fLine[Run] of\r\n     #0: NullProc;\r\n    #10: LFProc;\r\n    #13: CRProc;\r\n  else\r\n    fTokenID := tkComment;\r\n    repeat\r\n      if (fLine[Run] = '*') and (fLine[Run + 1] = ')') then\r\n      begin\r\n        fRange := rsUnKnown;\r\n        Inc(Run, 2);\r\n        break;\r\n      end;\r\n      Inc(Run);\r\n    until IsLineEnd(Run);\r\n  end;\r\nend;\r\n\r\nprocedure TSynGeneralSyn.PasStyleProc;\r\nbegin\r\n  case fLine[Run] of\r\n     #0: NullProc;\r\n    #10: LFProc;\r\n    #13: CRProc;\r\n  else\r\n    fTokenID := tkComment;\r\n    repeat\r\n      if fLine[Run] = '}' then\r\n      begin\r\n        fRange := rsUnKnown;\r\n        Inc(Run);\r\n        break;\r\n      end;\r\n      Inc(Run);\r\n    until IsLineEnd(Run);\r\n  end;\r\nend;\r\n\r\nprocedure TSynGeneralSyn.CStyleProc;\r\nbegin\r\n  case fLine[Run] of\r\n     #0: NullProc;\r\n    #10: LFProc;\r\n    #13: CRProc;\r\n  else\r\n    fTokenID := tkComment;\r\n    repeat\r\n      if (fLine[Run] = '*') and (fLine[Run + 1] = '/') then\r\n      begin\r\n        fRange := rsUnKnown;\r\n        Inc(Run, 2);\r\n        break;\r\n      end;\r\n      Inc(Run);\r\n    until IsLineEnd(Run);\r\n  end;\r\nend;\r\n\r\nprocedure TSynGeneralSyn.AsciiCharProc;\r\nbegin\r\n  if fDetectPreprocessor then\r\n  begin\r\n    fTokenID := tkPreprocessor;\r\n    repeat\r\n      inc(Run);\r\n    until IsLineEnd(Run);\r\n  end\r\n  else\r\n  begin\r\n    fTokenID := tkString;\r\n    repeat\r\n      inc(Run);\r\n    until not CharInSet(fLine[Run], ['0'..'9']);\r\n  end;\r\nend;\r\n\r\nprocedure TSynGeneralSyn.BraceOpenProc;\r\nbegin\r\n  if csPasStyle in fComments then\r\n  begin\r\n    fTokenID := tkComment;\r\n    fRange := rsPasStyle;\r\n    inc(Run);\r\n    while FLine[Run] <> #0 do\r\n      case FLine[Run] of\r\n        '}':\r\n          begin\r\n            fRange := rsUnKnown;\r\n            inc(Run);\r\n            break;\r\n          end;\r\n        #10: break;\r\n\r\n        #13: break;\r\n      else\r\n        inc(Run);\r\n      end;\r\n  end\r\n  else\r\n  begin\r\n    inc(Run);\r\n    fTokenID := tkSymbol;\r\n  end;\r\nend;\r\n\r\nprocedure TSynGeneralSyn.PointCommaProc;\r\nbegin\r\n  if (csASmStyle in fComments) or (csBasStyle in fComments) then\r\n  begin\r\n    fTokenID := tkComment;\r\n    fRange := rsUnknown;\r\n    inc(Run);\r\n    while FLine[Run] <> #0 do\r\n    begin\r\n      fTokenID := tkComment;\r\n      inc(Run);\r\n    end;\r\n  end\r\n  else\r\n  begin\r\n    inc(Run);\r\n    fTokenID := tkSymbol;\r\n  end;\r\nend;\r\n\r\nprocedure TSynGeneralSyn.CRProc;\r\nbegin\r\n  fTokenID := tkSpace;\r\n  Inc(Run);\r\n  if fLine[Run] = #10 then Inc(Run);\r\nend;\r\n\r\nprocedure TSynGeneralSyn.IdentProc;\r\nbegin\r\n  while IsIdentChar(fLine[Run]) do inc(Run);\r\n  if IsKeyWord(GetToken) then\r\n    fTokenId := tkKey\r\n  else\r\n    fTokenId := tkIdentifier;\r\nend;\r\n\r\nprocedure TSynGeneralSyn.IntegerProc;\r\n\r\n  function IsIntegerChar: Boolean;\r\n  begin\r\n    case fLine[Run] of\r\n      '0'..'9', 'A'..'F', 'a'..'f':\r\n        Result := True;\r\n      else\r\n        Result := False;\r\n    end;\r\n  end;\r\n\r\nbegin\r\n  inc(Run);\r\n  fTokenID := tkNumber;\r\n  while IsIntegerChar do inc(Run);\r\nend;\r\n\r\nprocedure TSynGeneralSyn.LFProc;\r\nbegin\r\n  fTokenID := tkSpace;\r\n  inc(Run);\r\nend;\r\n\r\nprocedure TSynGeneralSyn.NullProc;\r\nbegin\r\n  fTokenID := tkNull;\r\n  inc(Run);\r\nend;\r\n\r\nprocedure TSynGeneralSyn.NumberProc;\r\n\r\n  function IsNumberChar: Boolean;\r\n  begin\r\n    case fLine[Run] of\r\n      '0'..'9', '.', 'e', 'E', 'x':\r\n        Result := True;\r\n      else\r\n        Result := False;\r\n    end;\r\n  end;\r\n\r\nbegin\r\n  inc(Run);\r\n  fTokenID := tkNumber;\r\n  while IsNumberChar do\r\n  begin\r\n    case FLine[Run] of\r\n      'x': begin // handle C style hex numbers\r\n             IntegerProc;\r\n             break;\r\n           end;\r\n      '.':\r\n        if FLine[Run + 1] = '.' then break;\r\n    end;\r\n    inc(Run);\r\n  end;\r\nend;\r\n\r\nprocedure TSynGeneralSyn.RoundOpenProc;\r\nbegin\r\n  inc(Run);\r\n  if csAnsiStyle in fComments then\r\n  begin\r\n    case fLine[Run] of\r\n      '*':\r\n        begin\r\n          fTokenID := tkComment;\r\n          fRange := rsAnsi;\r\n          inc(Run);\r\n          while fLine[Run] <> #0 do\r\n            case fLine[Run] of\r\n              '*':\r\n                if fLine[Run + 1] = ')' then\r\n                begin\r\n                  fRange := rsUnKnown;\r\n                  inc(Run, 2);\r\n                  break;\r\n                end else inc(Run);\r\n              #10: break;\r\n              #13: break;\r\n            else inc(Run);\r\n            end;\r\n        end;\r\n      '.':\r\n        begin\r\n          inc(Run);\r\n          fTokenID := tkSymbol;\r\n        end;\r\n    else\r\n      begin\r\n        FTokenID := tkSymbol;\r\n      end;\r\n    end;\r\n  end else fTokenId := tkSymbol;\r\nend;\r\n\r\nprocedure TSynGeneralSyn.SlashProc;\r\nbegin\r\n  Inc(Run);\r\n  case FLine[Run] of\r\n    '/':\r\n      begin\r\n        if csCPPStyle in fComments then\r\n        begin\r\n          fTokenID := tkComment;\r\n          Inc(Run);\r\n          while FLine[Run] <> #0 do\r\n          begin\r\n            case FLine[Run] of\r\n              #10, #13: break;\r\n            end;\r\n            inc(Run);\r\n          end;\r\n        end\r\n        else\r\n          fTokenId := tkSymbol;\r\n      end;\r\n    '*':\r\n      begin\r\n        if csCStyle in fComments then\r\n        begin\r\n          fTokenID := tkComment;\r\n          fRange := rsCStyle;\r\n          Inc(Run);\r\n          while fLine[Run] <> #0 do\r\n            case fLine[Run] of\r\n              '*':\r\n                if fLine[Run + 1] = '/' then\r\n                begin\r\n                  fRange := rsUnKnown;\r\n                  inc(Run, 2);\r\n                  break;\r\n                end else inc(Run);\r\n              #10, #13:\r\n                break;\r\n              else\r\n                Inc(Run);\r\n            end;\r\n        end\r\n        else\r\n          fTokenId := tkSymbol;\r\n      end;\r\n    else\r\n      fTokenID := tkSymbol;\r\n  end;\r\nend;\r\n\r\nprocedure TSynGeneralSyn.SpaceProc;\r\nbegin\r\n  inc(Run);\r\n  fTokenID := tkSpace;\r\n  while (FLine[Run] <= #32) and not IsLineEnd(Run) do inc(Run);\r\nend;\r\n\r\nprocedure TSynGeneralSyn.StringProc;\r\nvar\r\n   delim : WideChar;\r\nbegin\r\n  fTokenID := tkString;\r\n  if IsStringDelim(fLine[Run + 1]) and IsStringDelim(fLine[Run + 2]) then\r\n    Inc(Run, 2);\r\n  delim:=fLine[Run];\r\n  repeat\r\n    case FLine[Run] of\r\n      #0 :  break;\r\n      #10, #13: if not StringMultiLine then break;\r\n    end;\r\n    inc(Run);\r\n  until FLine[Run] = delim;\r\n  if FLine[Run] <> #0 then inc(Run);\r\nend;\r\n\r\nprocedure TSynGeneralSyn.UnknownProc;\r\nbegin\r\n  inc(Run);\r\n  fTokenID := tkUnknown;\r\nend;\r\n\r\nprocedure TSynGeneralSyn.Next;\r\nbegin\r\n  fTokenPos := Run;\r\n  case fRange of\r\n    rsAnsi: AnsiProc;\r\n    rsPasStyle: PasStyleProc;\r\n    rsCStyle: CStyleProc;\r\n  else\r\n    if IsStringDelim(fLine[Run]) then\r\n      StringProc\r\n    else\r\n      case fLine[Run] of\r\n        '#': AsciiCharProc;\r\n        '{': BraceOpenProc;\r\n        ';': PointCommaProc;\r\n        #13: CRProc;\r\n        'A'..'Z', 'a'..'z', '_': IdentProc;\r\n        '$': IntegerProc;\r\n        #10: LFProc;\r\n        #0: NullProc;\r\n        '0'..'9': NumberProc;\r\n        '(': RoundOpenProc;\r\n        '/': SlashProc;\r\n        #1..#9, #11, #12, #14..#32: SpaceProc;\r\n        else UnknownProc;\r\n      end;\r\n  end;\r\n  inherited;\r\nend;\r\n\r\nfunction TSynGeneralSyn.GetDefaultAttribute(Index: integer): TSynHighlighterAttributes;\r\nbegin\r\n  case Index of\r\n    SYN_ATTR_COMMENT: Result := fCommentAttri;\r\n    SYN_ATTR_IDENTIFIER: Result := fIdentifierAttri;\r\n    SYN_ATTR_KEYWORD: Result := fKeyAttri;\r\n    SYN_ATTR_STRING: Result := fStringAttri;\r\n    SYN_ATTR_WHITESPACE: Result := fSpaceAttri;\r\n    SYN_ATTR_SYMBOL: Result := fSymbolAttri;\r\n  else\r\n    Result := nil;\r\n  end;\r\nend;\r\n\r\nfunction TSynGeneralSyn.GetEol: Boolean;\r\nbegin\r\n  Result := Run = fLineLen + 1;\r\nend;\r\n\r\nfunction TSynGeneralSyn.GetRange: Pointer;\r\nbegin\r\n  Result := Pointer(fRange);\r\nend;\r\n\r\nfunction TSynGeneralSyn.GetTokenID: TtkTokenKind;\r\nbegin\r\n  Result := fTokenId;\r\nend;\r\n\r\n// GetCharBeforeToken\r\n//\r\nfunction TSynGeneralSyn.GetCharBeforeToken(offset : Integer = -1) : WideChar;\r\nbegin\r\n   if fTokenPos+offset>=0 then\r\n      Result:=FLine[fTokenPos+offset]\r\n   else Result:=#0;\r\nend;\r\n\r\n// GetCharAfterToken\r\n//\r\nfunction TSynGeneralSyn.GetCharAfterToken(offset : Integer = 1) : WideChar;\r\nbegin\r\n   Result:=FLine[fTokenPos+offset];\r\nend;\r\n\r\nfunction TSynGeneralSyn.GetTokenAttribute: TSynHighlighterAttributes;\r\nbegin\r\n  case fTokenID of\r\n    tkComment: Result := fCommentAttri;\r\n    tkIdentifier: Result := fIdentifierAttri;\r\n    tkKey: Result := fKeyAttri;\r\n    tkNumber: Result := fNumberAttri;\r\n    tkPreprocessor: Result := fPreprocessorAttri;                         \r\n    tkSpace: Result := fSpaceAttri;\r\n    tkString: Result := fStringAttri;\r\n    tkSymbol: Result := fSymbolAttri;\r\n    tkUnknown: Result := fSymbolAttri;\r\n  else\r\n    Result := nil;\r\n  end;\r\n  if Assigned(fOnGetTokenAttribute) then\r\n    fOnGetTokenAttribute(Result);\r\nend;\r\n\r\nfunction TSynGeneralSyn.GetTokenKind: integer;\r\nbegin\r\n  Result := Ord(fTokenId);\r\nend;\r\n\r\nprocedure TSynGeneralSyn.ResetRange;\r\nbegin\r\n  fRange := rsUnknown;\r\nend;\r\n\r\nprocedure TSynGeneralSyn.SetRange(Value: Pointer);\r\nbegin\r\n  fRange := TRangeState(Value);\r\nend;\r\n\r\nprocedure TSynGeneralSyn.SetKeyWords(const Value: TUnicodeStrings);\r\nvar\r\n  i: Integer;\r\nbegin\r\n  if Value <> nil then\r\n    begin \r\n      Value.BeginUpdate;\r\n      for i := 0 to Value.Count - 1 do\r\n        Value[i] := SynWideUpperCase(Value[i]);\r\n      Value.EndUpdate;\r\n    end;\r\n\r\n  TUnicodeStringList(fKeyWords).Sorted:=False;\r\n  fKeyWords.Assign(Value);\r\n  TUnicodeStringList(fKeyWords).Sorted:=True;\r\n\r\n  DefHighLightChange(nil);\r\nend;\r\n\r\nprocedure TSynGeneralSyn.SetComments(Value: TCommentStyles);\r\nbegin\r\n  if fComments <> Value then\r\n  begin\r\n    fComments := Value;\r\n    DefHighLightChange(Self);\r\n  end;\r\nend;\r\n\r\nclass function TSynGeneralSyn.GetLanguageName: string;\r\nbegin\r\n  Result := SYNS_LangGeneral;\r\nend;\r\n\r\n{$IFNDEF SYN_CLX}\r\nfunction TSynGeneralSyn.LoadFromRegistry(RootKey: HKEY; Key: string): boolean;\r\nvar\r\n  r: TBetterRegistry;\r\nbegin\r\n  r:= TBetterRegistry.Create;\r\n  try\r\n    r.RootKey := RootKey;\r\n    if r.OpenKeyReadOnly(Key) then begin\r\n      if r.ValueExists('KeyWords') then KeyWords.Text:= r.ReadString('KeyWords');\r\n      Result := inherited LoadFromRegistry(RootKey, Key);\r\n    end\r\n    else Result := false;\r\n  finally r.Free; end;\r\nend;\r\n\r\nfunction TSynGeneralSyn.SaveToRegistry(RootKey: HKEY; Key: string): boolean;\r\nvar\r\n  r: TBetterRegistry;\r\nbegin\r\n  r:= TBetterRegistry.Create;\r\n  try\r\n    r.RootKey := RootKey;\r\n    if r.OpenKey(Key,true) then begin\r\n      Result := true;\r\n      r.WriteString('KeyWords', KeyWords.Text);\r\n      Result := inherited SaveToRegistry(RootKey, Key);\r\n    end\r\n    else Result := false;\r\n  finally r.Free; end;\r\nend;\r\n{$ENDIF}\r\n\r\nfunction TSynGeneralSyn.GetStringDelim: TStringDelim;\r\nbegin\r\n  Result:=fStringDelim;\r\nend;\r\n\r\nprocedure TSynGeneralSyn.SetStringDelim(const Value: TStringDelim);\r\nbegin\r\n   fStringDelim:=Value;\r\nend;\r\n\r\nfunction TSynGeneralSyn.GetIdentifierChars: UnicodeString;\r\nbegin\r\n  Result := fIdentChars;\r\nend;\r\n\r\nprocedure TSynGeneralSyn.SetIdentifierChars(const Value: UnicodeString);\r\nbegin\r\n  fIdentChars := Value;\r\nend;\r\n\r\nfunction TSynGeneralSyn.StoreIdentChars : Boolean;\r\nbegin\r\n   Result := (fIdentChars<>cDefaultIdentChars);\r\nend;\r\n\r\nprocedure TSynGeneralSyn.SetDetectPreprocessor(Value: boolean);\r\nbegin\r\n  if Value <> fDetectPreprocessor then\r\n  begin\r\n    fDetectPreprocessor := Value;\r\n    DefHighlightChange(Self);\r\n  end;\r\nend;\r\n\r\nclass function TSynGeneralSyn.GetFriendlyLanguageName: UnicodeString;\r\nbegin\r\n  Result := SYNS_FriendlyLangGeneral;\r\nend;\r\n\r\n// IsStringDelim\r\n//\r\nfunction TSynGeneralSyn.IsStringDelim(aChar : WideChar) : Boolean;\r\nbegin\r\n   case fStringDelim of\r\n      sdSingleQuote : Result:=(aChar='''');\r\n      sdDoubleQuote : Result:=(aChar='\"');\r\n   else\r\n      Result:=(aChar='''') or (aChar='\"');\r\n   end;\r\nend;\r\n\r\ninitialization\r\n{$IFNDEF SYN_CPPB_1}                                                    \r\n  RegisterPlaceableHighlighter(TSynGeneralSyn);\r\n{$ENDIF}\r\nend.\r\n"
  },
  {
    "path": "External/SynEdit/Source/SynHighlighterHC11.pas",
    "content": "{-------------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: SynHighlighterHC11.pas, released 2000-04-21.\r\nThe Original Code is based on the CIHC11Syn.pas file from the\r\nmwEdit component suite by Martin Waldenburg and other developers, the Initial\r\nAuthor of this file is Nils Springob.\r\nUnicode translation by Mal Hrz.\r\nAll Rights Reserved.\r\n\r\nContributors to the SynEdit and mwEdit projects are listed in the\r\nContributors.txt file.\r\n\r\nAlternatively, the contents of this file may be used under the terms of the\r\nGNU General Public License Version 2 or later (the \"GPL\"), in which case\r\nthe provisions of the GPL are applicable instead of those above.\r\nIf you wish to allow use of your version of this file only under the terms\r\nof the GPL and not to allow others to use your version of this file\r\nunder the MPL, indicate your decision by deleting the provisions above and\r\nreplace them with the notice and other provisions required by the GPL.\r\nIf you do not delete the provisions above, a recipient may use your version\r\nof this file under either the MPL or the GPL.\r\n\r\n$Id: SynHighlighterHC11.pas,v 1.13.2.5 2008/09/14 16:25:00 maelh Exp $\r\n\r\nYou may retrieve the latest version of this file at the SynEdit home page,\r\nlocated at http://SynEdit.SourceForge.net\r\n\r\nKnown Issues:\r\n-------------------------------------------------------------------------------}\r\n{\r\n@abstract(Provides a 68HC11 Assembler Language syntax highlighter for SynEdit)\r\n@author(Nils Springob , converted to SynEdit by Bruno Mikkelsen )\r\n@created(January 2000, converted to SynEdit April 21, 2000)\r\n@lastmod(2000-06-23)\r\nThe SynHighlighterHC11 unit provides SynEdit with a 68HC11 Assembler (.asm) highlighter.\r\nThe highlighter supports all 68HC11 op codes.\r\nThanks to Martin Waldenburg, David Muir, Hideo Koiso and Nick Hoddinott.\r\n}\r\n\r\n{$IFNDEF QSYNHIGHLIGHTERHC11}\r\nunit SynHighlighterHC11;\r\n{$ENDIF}\r\n\r\n{$I SynEdit.inc}\r\n\r\ninterface\r\n\r\nuses\r\n{$IFDEF SYN_CLX}\r\n  QGraphics,\r\n  QSynEditHighlighter,\r\n  QSynEditTypes,\r\n  QSynHighlighterHashEntries,\r\n  QSynUnicode,\r\n{$ELSE}\r\n  Graphics,\r\n  SynEditHighlighter,\r\n  SynEditTypes,\r\n  SynHighlighterHashEntries,\r\n  SynUnicode,\r\n{$ENDIF}\r\n  SysUtils,\r\n  Classes;\r\n\r\ntype\r\n  TtkTokenKind = (tkComment, tkDirective, tkIdentifier, tkKey, tkNull, tkNumber,\r\n    tkSpace, tkString, tkSymbol, tkUnknown);\r\n\r\n  TkwKeyWordType = (kwNone, kwOperand, kwOperandOver, kwNoOperand);\r\n\r\n  PHashListEntry = ^THashListEntry;\r\n  THashListEntry = record\r\n    Next: PHashListEntry;\r\n    Token: UnicodeString;\r\n    Kind: TtkTokenKind;\r\n    Op: Boolean;\r\n  end;\r\n\r\n  TSynHC11Syn = class(TSynCustomHighLighter)\r\n  private\r\n    FTokenID: TtkTokenKind;\r\n    FKeyWordType: TkwKeyWordType;\r\n    fCommentAttri: TSynHighlighterAttributes;\r\n    fDirecAttri: TSynHighlighterAttributes;\r\n    fIdentifierAttri: TSynHighlighterAttributes;\r\n    fInvalidAttri: TSynHighlighterAttributes;\r\n    fKeyAttri: TSynHighlighterAttributes;\r\n    fNumberAttri: TSynHighlighterAttributes;\r\n    fSpaceAttri: TSynHighlighterAttributes;\r\n    fStringAttri: TSynHighlighterAttributes;\r\n    fSymbolAttri: TSynHighlighterAttributes;\r\n    fKeywords: TSynHashEntryList;\r\n    procedure DoAddKeyword(AKeyword: UnicodeString; AKind: Integer);\r\n    function HashKey(Str: PWideChar): Integer;\r\n    function IdentKind(MayBe: PWideChar): TtkTokenKind;\r\n    procedure SymAsciiCharProc;\r\n    procedure SymbolProc;\r\n    procedure SymDollarProc;\r\n    procedure SymCRProc;\r\n    procedure SymIdentProc;\r\n    procedure SymLFProc;\r\n    procedure SymPercentProc;\r\n    procedure SymNullProc;\r\n    procedure SymNumberProc;\r\n    procedure SymSpaceProc;\r\n    procedure SymStarProc;\r\n    procedure SymStringProc;\r\n    procedure SymUnknownProc;\r\n  protected\r\n    function GetSampleSource: UnicodeString; override;\r\n    function IsFilterStored: Boolean; override;\r\n  public\r\n    class function GetLanguageName: string; override;\r\n    class function GetFriendlyLanguageName: UnicodeString; override;\r\n  public\r\n    constructor Create(AOwner: TComponent); override;\r\n    destructor Destroy; override;\r\n    function GetDefaultAttribute(Index: integer): TSynHighlighterAttributes;\r\n      override;\r\n    function GetEol: Boolean; override;\r\n    function GetTokenID: TtkTokenKind;\r\n    function GetTokenAttribute: TSynHighlighterAttributes; override;\r\n    function GetTokenKind: integer; override;\r\n    procedure Next; override;\r\n  published\r\n    property CommentAttri: TSynHighlighterAttributes read fCommentAttri\r\n      write fCommentAttri;\r\n    property DirecAttri: TSynHighlighterAttributes read fDirecAttri\r\n      write fDirecAttri;\r\n    property IdentifierAttri: TSynHighlighterAttributes read fIdentifierAttri\r\n      write fIdentifierAttri;\r\n    property InvalidAttri: TSynHighlighterAttributes read fInvalidAttri\r\n      write fInvalidAttri;\r\n    property KeyAttri: TSynHighlighterAttributes read fKeyAttri write fKeyAttri;\r\n    property NumberAttri: TSynHighlighterAttributes read fNumberAttri\r\n      write fNumberAttri;\r\n    property SpaceAttri: TSynHighlighterAttributes read fSpaceAttri\r\n      write fSpaceAttri;\r\n    property StringAttri: TSynHighlighterAttributes read fStringAttri\r\n      write fStringAttri;\r\n    property SymbolAttri: TSynHighlighterAttributes read fSymbolAttri\r\n      write fSymbolAttri;\r\n  end;\r\n\r\nimplementation\r\n\r\nuses\r\n{$IFDEF SYN_CLX}\r\n  QSynEditStrConst;\r\n{$ELSE}\r\n  SynEditStrConst;\r\n{$ENDIF}\r\n\r\nconst\r\n  { TODO: seems as if the Ansi version ignores the underscores and therfore\r\n    highlights more KeyWords than this(=Unicode) version.\r\n    Also the SampleSource uses EQU_ and EQU, so it isn't clear what is\r\n    the correct syntax: with other without the underscores.\r\n  }\r\n  KeyWords: UnicodeString = (\r\n    'ABA,ABX,ABY,ADCA_,ADCB_,ADDA_,ADDB_,ADDD_,ANDA_,ANDB_,ASLA,ASLB,' +\r\n    'ASL_,ASLD,ASRA,ASRB,ASR_,BCC_,BCLR_,BCS_,BEQ_,BGE_,BGT_,BHI_,BHS' +\r\n    '_,BITA_,BITB_,BLE_,BLO_,BLS_,BLT_,BMI_,BNE_,BPL_,BRA_,BRCLR_,BRN' +\r\n    '_,BRSET_,BSET_,BSR_,BVC_,BVS_,CBA,CLC,CLI,CLRA,CLRB,CLR_,CLV,CMP' +\r\n    'A_,CMPB_,COMA,COMB,COM_,CPD_,CPX_,CPY_,DAA,DECA,DECB,DEC_,DES,DE' +\r\n    'X,DEY,EORA_,EORB_,FDIV,IDIV,INCA,INCB,INC_,INS,INX,INY,JMP_,JSR_' +\r\n    ',LDAA_,LDAB_,LDD_,LDS_,LDX_,LDY_,LSLA,LSLB,LSL_,LSLD,LSRA,LSRB,L' +\r\n    'SR_,LSRD,MUL,NEGA,NEGB,NEG_,NOP,ORAA_,ORAB_,PSHA,PSHB,PSHX,PSHY,' +\r\n    'PULA,PULB,PULX,PULY,ROLA,ROLB,ROL_,RORA,RORB,ROR_,RTI,RTS,SBA,SB' +\r\n    'CA_,SBCB_,SEC,SEI,SEV,STAA_,STAB_,STD_,STOP,STS_,STX_,STY_,SUBA_' +\r\n    ',SUBB_,SUBD_,SWI,TAB,TAP,TBA,TEST,' +\r\n    'TPA,TSTA,TSTB,TST_,TSX,TSY,TXS,TYS,WAI,XGDX,XGDY,' + // end commands\r\n    'FCC_,FCB_,BSZ_,FDB_' // codegenerating directives\r\n  );\r\n\r\n  Directives: UnicodeString = (\r\n    'EQU_,OPT_,PAGE,ORG_,RMB_,END'  // directives\r\n  );\r\n\r\nprocedure TSynHC11Syn.DoAddKeyword(AKeyword: UnicodeString; AKind: Integer);\r\nvar\r\n  HashValue: Integer;\r\nbegin\r\n  HashValue := HashKey(PWideChar(AKeyword));\r\n  fKeywords[HashValue] := TSynHashEntry.Create(AKeyword, AKind);\r\nend;\r\n\r\nfunction TSynHC11Syn.HashKey(Str: PWideChar): Integer;\r\n\r\n  function GetOrd: Integer;\r\n  begin\r\n    case Str^ of\r\n      'a'..'z': Result := 1 + Ord(Str^) - Ord('a');\r\n      'A'..'Z': Result := 1 + Ord(Str^) - Ord('A');\r\n      '0'..'9': Result := 28 + Ord(Str^) - Ord('0');\r\n      '_': Result := 27;\r\n      else Result := 0;\r\n    end\r\n  end;\r\n\r\nbegin\r\n  Result := 0;\r\n  while IsIdentChar(Str^) do\r\n  begin\r\n{$IFOPT Q-}\r\n    Result := 7 * Result + GetOrd;\r\n{$ELSE}\r\n    Result := (7 * Result + GetOrd) and $FFFFFF;\r\n{$ENDIF}\r\n    Inc(Str);\r\n  end;\r\n  Result := Result and $FF; // 255\r\n  fStringLen := Str - fToIdent;\r\nend;\r\n\r\nfunction TSynHC11Syn.IdentKind(MayBe: PWideChar): TtkTokenKind;\r\nvar\r\n  Entry: TSynHashEntry;\r\nbegin\r\n  fToIdent := MayBe;\r\n  Entry := fKeywords[HashKey(MayBe)];\r\n  while Assigned(Entry) do\r\n  begin\r\n    if Entry.KeywordLen > fStringLen then\r\n      break\r\n    else if Entry.KeywordLen = fStringLen then\r\n      if IsCurrentToken(Entry.Keyword) then\r\n      begin\r\n        Result := TtkTokenKind(Entry.Kind);\r\n        exit;\r\n      end;\r\n    Entry := Entry.Next;\r\n  end;\r\n  Result := tkIdentifier;\r\nend;\r\n\r\nconstructor TSynHC11Syn.Create(AOwner: TComponent);\r\nbegin\r\n  inherited Create(AOwner);\r\n\r\n  fCaseSensitive := True;\r\n\r\n  fKeywords := TSynHashEntryList.Create;\r\n  fCommentAttri := TSynHighlighterAttributes.Create(SYNS_AttrComment, SYNS_FriendlyAttrComment);\r\n  fCommentAttri.Style:= [fsItalic];\r\n  AddAttribute(fCommentAttri);\r\n  fIdentifierAttri := TSynHighlighterAttributes.Create(SYNS_AttrIdentifier, SYNS_FriendlyAttrIdentifier);\r\n  AddAttribute(fIdentifierAttri);\r\n  fInvalidAttri := TSynHighlighterAttributes.Create(SYNS_AttrIllegalChar, SYNS_FriendlyAttrIllegalChar);\r\n  AddAttribute(fInvalidAttri);\r\n  fKeyAttri := TSynHighlighterAttributes.Create(SYNS_AttrReservedWord, SYNS_FriendlyAttrReservedWord);\r\n  fKeyAttri.Style:= [fsBold];\r\n  AddAttribute(fKeyAttri);\r\n  fNumberAttri := TSynHighlighterAttributes.Create(SYNS_AttrNumber, SYNS_FriendlyAttrNumber);\r\n  AddAttribute(fNumberAttri);\r\n  fSpaceAttri := TSynHighlighterAttributes.Create(SYNS_AttrSpace, SYNS_FriendlyAttrSpace);\r\n  AddAttribute(fSpaceAttri);\r\n  fStringAttri := TSynHighlighterAttributes.Create(SYNS_AttrString, SYNS_FriendlyAttrString);\r\n  AddAttribute(fStringAttri);\r\n  fSymbolAttri := TSynHighlighterAttributes.Create(SYNS_AttrSymbol, SYNS_FriendlyAttrSymbol);\r\n  AddAttribute(fSymbolAttri);\r\n  fDirecAttri := TSynHighlighterAttributes.Create(SYNS_AttrPreprocessor, SYNS_FriendlyAttrPreprocessor);\r\n  AddAttribute(fDirecAttri);\r\n  SetAttributesOnChange(DefHighlightChange);\r\n\r\n  EnumerateKeywords(Ord(tkKey), Keywords, IsIdentChar, DoAddKeyword);\r\n  EnumerateKeywords(Ord(tkDirective), Directives, IsIdentChar, DoAddKeyword);\r\n  fDefaultFilter := SYNS_FilterAsm68HC11;\r\nend; { Create }\r\n\r\ndestructor TSynHC11Syn.Destroy;\r\nbegin\r\n  fKeywords.Free;\r\n  inherited Destroy;\r\nend;\r\n\r\nprocedure TSynHC11Syn.SymAsciiCharProc;\r\nbegin\r\n  fTokenID := tkString;\r\n  if (FLine[Run + 1] = #39) and (FLine[Run + 2] = #39) then inc(Run, 2);\r\n  repeat\r\n    case FLine[Run] of\r\n      #0, #10, #13:\r\n      begin\r\n        FKeyWordType:=kwNone;\r\n        break;\r\n      end;\r\n    end;\r\n    inc(Run);\r\n  until FLine[Run] = #39;\r\n  if FLine[Run] <> #0 then inc(Run);\r\nend;\r\n\r\nprocedure TSynHC11Syn.SymbolProc;\r\nbegin\r\n  fTokenID := tkSymbol;\r\n  inc(Run);\r\nend;\r\n\r\nprocedure TSynHC11Syn.SymDollarProc;\r\nbegin\r\n  fTokenID := tkNumber;\r\n  inc(Run);\r\n  while CharInSet(FLine[Run], ['0'..'9', 'A'..'F', 'a'..'f']) do\r\n  begin\r\n    inc(Run);\r\n  end;\r\nend;\r\n\r\nprocedure TSynHC11Syn.SymCRProc;\r\nbegin\r\n  fTokenID := tkSpace;\r\n  FKeyWordType := kwNone;\r\n  inc(Run);\r\n  if fLine[Run] = #10 then inc(Run);\r\nend;\r\n\r\nprocedure TSynHC11Syn.SymIdentProc;\r\nbegin\r\n  fTokenID := IdentKind(fLine + Run);\r\n  inc(Run, fStringLen);\r\n  while IsIdentChar(fLine[Run]) do inc(Run);\r\nend;\r\n\r\nprocedure TSynHC11Syn.SymLFProc;\r\nbegin\r\n  FKeyWordType := kwNone;\r\n  fTokenID := tkSpace;\r\n  inc(Run);\r\nend;\r\n\r\nprocedure TSynHC11Syn.SymPercentProc;\r\nbegin\r\n  inc(Run);\r\n  fTokenID := tkNumber;\r\n  while CharInSet(FLine[Run], ['0'..'1']) do\r\n    inc(Run);\r\nend;\r\n\r\nprocedure TSynHC11Syn.SymNullProc;\r\nbegin\r\n  fTokenID := tkNull;\r\n  inc(Run);\r\nend;\r\n\r\nprocedure TSynHC11Syn.SymNumberProc;\r\nbegin\r\n  inc(Run);\r\n  fTokenID := tkNumber;\r\n  while CharInSet(FLine[Run], ['0'..'9']) do\r\n    inc(Run);\r\nend;\r\n\r\nprocedure TSynHC11Syn.SymSpaceProc;\r\nbegin\r\n  inc(Run);\r\n  if FKeyWordType in [kwOperandOver, kwNoOperand] then\r\n  begin\r\n    FKeyWordType := kwNone;\r\n    fTokenID := tkComment;\r\n    while not IsLineEnd(Run) do\r\n      Inc(Run);\r\n  end\r\n  else\r\n  begin\r\n    if FKeyWordType = kwOperand then\r\n      FKeyWordType := kwOperandOver;\r\n    fTokenID := tkSpace;\r\n    while (fLine[Run] <= #32) and not IsLineEnd(Run) do\r\n      inc(Run);\r\n  end;\r\nend;\r\n\r\nprocedure TSynHC11Syn.SymStarProc;\r\nbegin\r\n  inc(Run);\r\n  if FKeyWordType = kwOperandOver then\r\n    fTokenID := tkSymbol\r\n  else\r\n  begin\r\n    fTokenID := tkComment;\r\n    while not IsLineEnd(Run) do\r\n      inc(Run);\r\n  end;\r\nend;\r\n\r\nprocedure TSynHC11Syn.SymStringProc;\r\nbegin\r\n  fTokenID := tkString;\r\n  if (FLine[Run + 1] = #34) and (FLine[Run + 2] = #34) then inc(Run, 2);\r\n  repeat\r\n    case FLine[Run] of\r\n      #0, #10, #13: break;\r\n    end;\r\n    inc(Run);\r\n  until FLine[Run] = #34;\r\n  if FLine[Run] <> #0 then inc(Run);\r\nend;\r\n\r\nprocedure TSynHC11Syn.SymUnknownProc;\r\nbegin\r\n  inc(Run);\r\n  fTokenID := tkUnknown;\r\nend;\r\n\r\nprocedure TSynHC11Syn.Next;\r\nbegin\r\n  fTokenPos := Run;\r\n  case fLine[Run] of\r\n    #39: SymAsciiCharProc;\r\n    '$': SymDollarProc;\r\n    #13: SymCRProc;\r\n    'A'..'Z', 'a'..'z', '_': SymIdentProc;\r\n    #10: SymLFProc;\r\n    '%': SymPercentProc;\r\n    #0: SymNullProc;\r\n    '0'..'9': SymNumberProc;\r\n    #1..#9, #11, #12, #14..#32: SymSpaceProc;\r\n    '*': SymStarProc;\r\n    #34: SymStringProc;\r\n    '#', ':', ',', ';', '(', ')': SymbolProc;\r\n    else SymUnknownProc;\r\n  end;\r\n  inherited;\r\nend;\r\n\r\nfunction TSynHC11Syn.GetDefaultAttribute(Index: integer): TSynHighlighterAttributes;\r\nbegin\r\n  case Index of\r\n    SYN_ATTR_COMMENT: Result := fCommentAttri;\r\n    SYN_ATTR_IDENTIFIER: Result := fIdentifierAttri;\r\n    SYN_ATTR_KEYWORD: Result := fKeyAttri;\r\n    SYN_ATTR_STRING: Result := fStringAttri;\r\n    SYN_ATTR_WHITESPACE: Result := fSpaceAttri;\r\n    SYN_ATTR_SYMBOL: Result := fSymbolAttri;\r\n  else\r\n    Result := nil;\r\n  end;\r\nend;\r\n\r\nfunction TSynHC11Syn.GetEol: Boolean;\r\nbegin\r\n  Result := Run = fLineLen + 1;\r\nend;\r\n\r\nfunction TSynHC11Syn.GetTokenAttribute: TSynHighlighterAttributes;\r\nbegin\r\n  case fTokenID of\r\n    tkComment: Result := fCommentAttri;\r\n    tkDirective: Result := fDirecAttri;\r\n    tkIdentifier: Result := fIdentifierAttri;\r\n    tkKey: Result := fKeyAttri;\r\n    tkNumber: Result := fNumberAttri;\r\n    tkSpace: Result := fSpaceAttri;\r\n    tkString: Result := fStringAttri;\r\n    tkSymbol: Result := fSymbolAttri;\r\n    tkUnknown: Result := fIdentifierAttri;\r\n    else Result := nil;\r\n  end;\r\nend;\r\n\r\nfunction TSynHC11Syn.GetTokenKind: integer;\r\nbegin\r\n  Result := Ord(fTokenId);\r\nend;\r\n\r\nfunction TSynHC11Syn.GetTokenID: TtkTokenKind;\r\nbegin\r\n  Result := fTokenId;\r\nend;\r\n\r\nfunction TSynHC11Syn.IsFilterStored: Boolean;\r\nbegin\r\n  Result := fDefaultFilter <> SYNS_FilterAsm68HC11;\r\nend;\r\n\r\nclass function TSynHC11Syn.GetLanguageName: string;\r\nbegin\r\n  Result := SYNS_Lang68HC11;\r\nend;\r\n\r\nfunction TSynHC11Syn.GetSampleSource: UnicodeString;\r\nbegin\r\n  Result :=\r\n    '* TX.ASM'#13#10 +\r\n    'MAINORG EQU_    $F800'#13#10 +\r\n    '        ORG     $F800'#13#10 +\r\n    'MAIN    EQU     *        ;Start assembling here'#13#10 +\r\n    '        STAA    SCCR2'#13#10 +\r\n    'loop:'#13#10 +\r\n    '        LDAA    #$05'#13#10 +\r\n    '\tBRA\tloop\t\t;Do it again'#13#10 +\r\n    '\tORG\t$FFFE\t\t;Reset vector interrupt setup'#13#10 +\r\n    '\tEND';\r\nend;\r\n\r\nclass function TSynHC11Syn.GetFriendlyLanguageName: UnicodeString;\r\nbegin\r\n  Result := SYNS_FriendlyLang68HC11;\r\nend;\r\n\r\ninitialization\r\n{$IFNDEF SYN_CPPB_1}\r\n  RegisterPlaceableHighlighter(TSynHC11Syn);\r\n{$ENDIF}\r\nend.\r\n"
  },
  {
    "path": "External/SynEdit/Source/SynHighlighterHP48.pas",
    "content": "{-------------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: SynHighlighterHP48.pas, released 2000-06-23.\r\nThe Original Code is based on the cbHPSyn.pas file from the\r\nmwEdit component suite by Martin Waldenburg and other developers, the Initial\r\nAuthor of this file is Cyrille de Brebisson.\r\nUnicode translation by Mal Hrz.\r\nAll Rights Reserved.\r\n\r\nContributors to the SynEdit and mwEdit projects are listed in the\r\nContributors.txt file.\r\n\r\nAlternatively, the contents of this file may be used under the terms of the\r\nGNU General Public License Version 2 or later (the \"GPL\"), in which case\r\nthe provisions of the GPL are applicable instead of those above.\r\nIf you wish to allow use of your version of this file only under the terms\r\nof the GPL and not to allow others to use your version of this file\r\nunder the MPL, indicate your decision by deleting the provisions above and\r\nreplace them with the notice and other provisions required by the GPL.\r\nIf you do not delete the provisions above, a recipient may use your version\r\nof this file under either the MPL or the GPL.\r\n\r\n$Id: SynHighlighterHP48.pas,v 1.10.2.9 2008/09/14 16:25:00 maelh Exp $\r\n\r\nYou may retrieve the latest version of this file at the SynEdit home page,\r\nlocated at http://SynEdit.SourceForge.net\r\n\r\nKnown Issues:\r\n-------------------------------------------------------------------------------}\r\n{\r\n@abstract(Provides SynEdit with a HP48 assembler syntax highlighter.)\r\n@author(Cyrille de Brebisson , converted to SynEdit by David Muir )\r\n@created(1998-12, converted to SynEdit 2000-06-23)\r\n@lastmod(2012-09-12)\r\nThe unit SynHighlighterHP48 provides SynEdit with a HP48 assembler highlighter.\r\n}\r\n\r\n{$IFNDEF QSYNHIGHLIGHTERHP48}\r\nunit SynHighlighterHP48;\r\n{$ENDIF}\r\n\r\n{$I SynEdit.inc}\r\n\r\ninterface\r\n\r\nuses\r\n{$IFDEF SYN_CLX}\r\n  QGraphics,\r\n  QSynEditHighlighter,\r\n  QSynUnicode,  \r\n{$ELSE}\r\n  Windows,\r\n  Graphics,\r\n  SynEditHighlighter,\r\n  SynUnicode,\r\n{$ENDIF}\r\n  SysUtils,\r\n  Classes;\r\n\r\nconst\r\n  NbSubList = 128;\r\n\r\ntype\r\n  TSpeedStringList = class;\r\n\r\n  TSpeedListObject = class\r\n  protected\r\n    FName: UnicodeString;\r\n    FSpeedList: TSpeedStringList;\r\n    FObject: TObject;\r\n    procedure SetName(const Value: UnicodeString); virtual;\r\n  public\r\n    property Name: UnicodeString read FName write SetName;\r\n    constructor Create(name: UnicodeString);\r\n    destructor Destroy; override;\r\n    property SpeedList: TSpeedStringList read FSpeedList write FSpeedList;\r\n    property Pointer: TObject read FObject write FObject;\r\n  end;\r\n\r\n  PSpeedListObjects = ^TSpeedListObjects;\r\n  TSpeedListObjects = array[0..0] of TSpeedListObject;\r\n\r\n  TSpeedStringList = class\r\n  private\r\n    function GetText: UnicodeString;\r\n    procedure SetText(const Value: UnicodeString);\r\n    function GetInObject(Index: Integer): TObject;\r\n    procedure SetInObject(Index: Integer; const Value: TObject);\r\n  protected\r\n    FOnChange: TNotifyEvent;\r\n    SumOfUsed: array[0..NbSubList - 1] of Integer;\r\n    DatasUsed: array[0..NbSubList - 1] of Integer;\r\n    Datas: array[0..NbSubList - 1] of PSpeedListObjects;\r\n    LengthDatas: array[0..NbSubList - 1] of Integer;\r\n    procedure Changed; virtual;\r\n    function Get(Index: Integer): UnicodeString; virtual;\r\n    function GetObject(Index: Integer): TSpeedListObject;\r\n    function GetCount: Integer;\r\n    function GetStringList: TUnicodeStrings;\r\n    procedure SetStringList(const Value: TUnicodeStrings);\r\n  public\r\n    procedure NameChange(const obj: TSpeedListObject; const NewName: UnicodeString);\r\n    procedure ObjectDeleted(const obj: TSpeedListObject);\r\n\r\n    destructor Destroy; override;\r\n    constructor Create;\r\n    function AddObj(const Value: TSpeedListObject): Integer;\r\n    function Add(const Value: UnicodeString): TSpeedListObject;\r\n    procedure Clear;\r\n    function Find(const Name: UnicodeString): TSpeedListObject;\r\n    property OnChange: TNotifyEvent read FOnChange write FOnChange;\r\n    property Objects[Index: Integer]: TSpeedListObject read GetObject;\r\n    property InObject[Index: Integer]: TObject read GetInObject write SetInObject;\r\n    property Strings[Index: Integer]: UnicodeString read Get; default;\r\n    property Count: Integer read GetCount;\r\n    property StringList: TUnicodeStrings read GetStringList write SetStringList;\r\n    property Text: UnicodeString read GetText write SetText;\r\n  end;\r\n\r\n  TtkTokenKind = (tkNull, tkAsmKey, tkAsm, tkAsmComment, tksAsmKey, tksAsm,\r\n    tksAsmComment, tkRplKey, tkRpl, tkRplComment);\r\n\r\n  TRangeState = (rsRpl, rsComRpl, rssasm1, rssasm2, rssasm3, rsAsm, rsComAsm2,\r\n    rsComAsm1);\r\n\r\n  TSynHP48Syn = class(TSynCustomHighLighter)\r\n  private\r\n    fTockenKind: TtkTokenKind;\r\n    fRange: TRangeState;\r\n    Attribs: array[TtkTokenKind] of TSynHighlighterAttributes;\r\n    FRplKeyWords: TSpeedStringList;\r\n    FAsmKeyWords: TSpeedStringList;\r\n    FSAsmNoField: TSpeedStringList;\r\n    FBaseRange: TRangeState;\r\n    function GetAttrib(Index: integer): TSynHighlighterAttributes;\r\n    procedure SetAttrib(Index: integer; Value: TSynHighlighterAttributes);\r\n\r\n    function NullProc: TtkTokenKind;\r\n    function SpaceProc: TtkTokenKind;\r\n    function ParOpenProc: TtkTokenKind;\r\n    function RplComProc: TtkTokenKind;\r\n    function AsmComProc(c: WideChar): TtkTokenKind;\r\n    function PersentProc: TtkTokenKind;\r\n    function IdentProc: TtkTokenKind;\r\n    function SlashProc: TtkTokenKind;\r\n    function SasmProc1: TtkTokenKind;\r\n    function SasmProc2: TtkTokenKind;\r\n    function SasmProc3: TtkTokenKind;\r\n    procedure EndOfToken;\r\n    procedure SetHighLightChange;\r\n    function Next1: TtkTokenKind;\r\n    procedure Next2(tkk: TtkTokenKind);\r\n    function GetTokenFromRange: TtkTokenKind;\r\n    function StarProc: TtkTokenKind;\r\n  protected\r\n    function GetAttribCount: integer; override;\r\n    function GetAttribute(idx: integer): TSynHighlighterAttributes; override;\r\n    function IsFilterStored: Boolean; override;\r\n    function IsLineEnd(Run: Integer): Boolean; override;\r\n  public\r\n    class function GetLanguageName: string; override;\r\n    class function GetFriendlyLanguageName: UnicodeString; override;\r\n  public\r\n    constructor Create(AOwner: TComponent); override;\r\n    destructor Destroy; override;\r\n    function GetDefaultAttribute(Index: integer): TSynHighlighterAttributes;\r\n      override;\r\n    function GetEol: Boolean; override;\r\n    procedure DoSetLine(const Value: UnicodeString; LineNumber: Integer); override;\r\n    procedure Next; override;\r\n\r\n    function GetToken: UnicodeString; override;\r\n    function GetTokenAttribute: TSynHighlighterAttributes; override;\r\n    function GetTokenKind: integer; override;\r\n\r\n    function GetRange: Pointer; override;\r\n    procedure SetRange(Value: Pointer); override;\r\n    procedure ResetRange; override;\r\n    {$IFNDEF SYN_CLX}\r\n    function SaveToRegistry(RootKey: HKEY; Key: string): boolean; override;\r\n    function LoadFromRegistry(RootKey: HKEY; Key: string): boolean; override;\r\n    {$ENDIF}\r\n    procedure Assign(Source: TPersistent); override;\r\n    property AsmKeyWords: TSpeedStringList read FAsmKeyWords;\r\n    property SAsmFoField: TSpeedStringList read FSAsmNoField;\r\n    property RplKeyWords: TSpeedStringList read FRplKeyWords;\r\n  published\r\n    property AsmKey: TSynHighlighterAttributes index Ord(tkAsmKey)\r\n      read GetAttrib write SetAttrib;\r\n    property AsmTxt: TSynHighlighterAttributes index Ord(tkAsm)\r\n      read GetAttrib write SetAttrib;\r\n    property AsmComment: TSynHighlighterAttributes index Ord(tkAsmComment)\r\n      read GetAttrib write SetAttrib;\r\n    property sAsmKey: TSynHighlighterAttributes index Ord(tksAsmKey)\r\n      read GetAttrib write SetAttrib;\r\n    property sAsmTxt: TSynHighlighterAttributes index Ord(tksAsm)\r\n      read GetAttrib write SetAttrib;\r\n    property sAsmComment: TSynHighlighterAttributes index Ord(tksAsmComment)\r\n      read GetAttrib write SetAttrib;\r\n    property RplKey: TSynHighlighterAttributes index Ord(tkRplKey)\r\n      read GetAttrib write SetAttrib;\r\n    property RplTxt: TSynHighlighterAttributes index Ord(tkRpl)\r\n      read GetAttrib write SetAttrib;\r\n    property RplComment: TSynHighlighterAttributes index Ord(tkRplComment)\r\n      read GetAttrib write SetAttrib;\r\n    property BaseRange: TRangeState read FBaseRange write FBaseRange;\r\n  end;\r\n\r\nimplementation\r\n\r\nuses\r\n{$IFDEF UNICODE}\r\n  WideStrUtils,\r\n{$ENDIF}\r\n{$IFDEF SYN_CLX}\r\n  QSynEditStrConst;\r\n{$ELSE}\r\n  SynEditStrConst;\r\n{$ENDIF}\r\n\r\nconst\r\n  DefaultAsmKeyWords: UnicodeString = '!RPL'#13#10'ENDCODE'#13#10'{'#13#10'}'#13#10 +\r\n  'GOTO'#13#10'GOSUB'#13#10'GOSBVL'#13#10'GOVLNG'#13#10'GOLONG'#13#10'SKIP' +\r\n    #13#10'SKIPYES' + #13#10'->'#13#10'SKUB'#13#10'SKUBL'#13#10'SKC'#13#10'SKNC'#13#10'SKELSE' +\r\n    #13#10'SKEC'#13#10'SKENC'#13#10'SKLSE'#13#10 + 'GOTOL'#13#10'GOSUBL'#13#10 +\r\n    'RTN'#13#10'RTNC'#13#10'RTNNC'#13#10'RTNSC'#13#10'RTNCC'#13#10'RTNSXM'#13#10'RTI';\r\n  OtherAsmKeyWords: array[0..5] of UnicodeString = ('UP', 'EXIT', 'UPC', 'EXITC', 'UPNC', 'EXITNC');\r\n  DefaultRplKeyWords: UnicodeString =\r\n    'CODEM'#13#10'ASSEMBLEM'#13#10'CODE'#13#10'ASSEMBLE'#13#10'IT'#13#10'ITE'#13#10'case'#13#10'::'#13#10';'#13#10'?SEMI'#13#10''''#13#10'#=case'#13#10'{'#13#10'}'#13#10'NAMELESS'#13#10'LOCAL'#13#10'LOCALNAME'#13#10'LABEL'#13#10 +\r\n    'LOCALLABEL'#13#10'xNAME'#13#10'tNAME' + 'COLA'#13#10'NULLNAME'#13#10'xROMID'#13#10'#0=ITE'#13#10'#ITE'#13#10'2''RCOLARPITE'#13#10'ANDITE'#13#10'COLAITE'#13#10'COLARPITE'#13#10'DUP#0=ITE'#13#10 +\r\n    'EQITE'#13#10'ITE'#13#10'RPITE'#13#10'SysITE'#13#10'UNxSYMRPITE'#13#10'UserITE'#13#10'snnSYMRPITE'#13#10'snsSYMRPITE'#13#10'ssnSYMRPITE'#13#10'sssSYMRPITE'#13#10'$_EXIT'#13#10'DA1OK?NOTIT'#13#10'DA2aOK?NOTIT'#13#10 +\r\n    'DA2bOK?NOTIT'#13#10'DA3OK?NOTIT'#13#10'DO#EXIT'#13#10'DO$EXIT'#13#10'DO%EXIT'#13#10'DOHXSEXIT'#13#10'DUP#0=IT'#13#10'EQIT'#13#10'GCDHEULPEXIT'#13#10'GSPLIT'#13#10'NOT_IT'#13#10'POINTEXIT'#13#10'POLYARIT'#13#10'RPIT'#13#10 +\r\n    'parleftIT'#13#10'parrightIT'#13#10''''#13#10'IT'#13#10'ITE'#13#10'SEMI'#13#10'UNTIL'#13#10'LOOP'#13#10'?SEMI'#13#10'NOT?SEMI'#13#10'#0=case'#13#10'#1=case'#13#10'#<>case'#13#10'#2case'#13#10'#>33case'#13#10'#>case'#13#10'%-1=case'#13#10'%0=case'#13#10'%1=case'#13#10'%2=case'#13#10'AEQ1stcase'#13#10'AEQopscase'#13#10'ANDNOTcase'#13#10'ANDcase'#13#10'C%-1=case'#13#10 +\r\n    'C%0=case'#13#10'C%1=case'#13#10'C%2=case'#13#10'COLANOTcase'#13#10'COLAcase'#13#10'DUP#0=case'#13#10'EQUALNOTcase'#13#10'EQUALcase'#13#10'EQUALcasedrop'#13#10'EQUALcasedrp'#13#10'EQcase'#13#10'EQcaseDROP'#13#10 +\r\n    'EQcasedrop'#13#10'EnvNGcase'#13#10'M-1stcasechs'#13#10'MEQ*case'#13#10'MEQ+case'#13#10'MEQ-case'#13#10'MEQ/case'#13#10'MEQ1stcase'#13#10'MEQCHScase'#13#10'MEQFCNcase'#13#10'MEQINVcase'#13#10'MEQSQcase'#13#10'MEQ^case'#13#10 +\r\n    'MEQopscase'#13#10'Mid1stcase'#13#10'NOTBAKcase'#13#10'NOTLIBcase'#13#10'NOTLISTcase'#13#10'NOTMATRIXcase'#13#10'NOTROMPcase'#13#10'NOTSECOcase'#13#10'NOTTYPEcase'#13#10'NOTcase'#13#10'NOTcase2DROP'#13#10'NOTcase2drop'#13#10 +\r\n    'NOTcaseDROP'#13#10'NOTcaseFALSE'#13#10'NOTcaseTRUE'#13#10'NOTcasedrop'#13#10'NULLargcase'#13#10'NcaseSIZEERR'#13#10'NcaseTYPEERR'#13#10'NoEdit?case'#13#10'ORcase'#13#10'OVER#=case'#13#10'REALcase'#13#10'REQcase'#13#10 +\r\n    'REQcasedrop'#13#10'Z-1=case'#13#10'Z0=case'#13#10'Z1=case'#13#10'accNBAKcase'#13#10'accNLIBcase'#13#10'case'#13#10'case2DROP'#13#10'case2drop'#13#10'case2drpfls'#13#10'caseDEADKEY'#13#10'caseDROP'#13#10'caseDoBadKey'#13#10 +\r\n    'caseDrpBadKy'#13#10'caseERRJMP'#13#10'caseFALSE'#13#10'caseSIZEERR'#13#10'caseTRUE'#13#10'casedrop'#13#10'casedrpfls'#13#10'casedrptru'#13#10'caseout'#13#10'cxcasecheck'#13#10'dARRYcase'#13#10'dIDNTNcase'#13#10'dLISTcase'#13#10 +\r\n    'dMATRIXcase'#13#10'dREALNcase'#13#10'dREALcase'#13#10'dZINTNcase'#13#10'delimcase'#13#10'estcase'#13#10'idntcase'#13#10'idntlamcase'#13#10'j#-1=case'#13#10'j#0=case'#13#10'j#1=case'#13#10'j%-1=case'#13#10'j%0=case'#13#10 +\r\n    'j%1=case'#13#10'jEQcase'#13#10'jZ-1=case'#13#10'jZ0=case'#13#10'jZ1=case'#13#10'namelscase'#13#10'need''case'#13#10'negrealcase'#13#10'ngsizecase'#13#10'nonopcase'#13#10'nonrmcase'#13#10'num#-1=case'#13#10'num#0=case'#13#10 +\r\n    'num#1=case'#13#10'num-1=case'#13#10'num0=case'#13#10'num0case'#13#10'num1=case'#13#10'num2=case'#13#10'numb1stcase'#13#10'rebuildcase'#13#10'tok=casedrop'#13#10'wildcase'#13#10'zerdercase'#13#10;\r\n  SasmNoField: UnicodeString = 'LOOP'#13#10'RTNSXM'#13#10'RTN'#13#10'RTNSC'#13#10'RTNCC'#13#10'SETDEC'#13#10'SETHEX'#13#10'RSTK=C'#13#10'C=RSTK'#13#10'CLRST'#13#10'C=ST'#13#10'ST=C'#13#10'CSTEX'#13#10 +\r\n  'RTI'#13#10'R0=A'#13#10'R1=A'#13#10'R2=A'#13#10'R3=A'#13#10'R4=A'#13#10'R0=C'#13#10'R1=C'#13#10'R2=C'#13#10'R3=C'#13#10'R4=C'#13#10'A=R0'#13#10'A=R1'#13#10'A=R2'#13#10'A=R3'#13#10'A=R4'#13#10 +\r\n    'C=R0'#13#10'C=R1'#13#10'C=R2'#13#10'C=R3'#13#10'C=R4'#13#10'AR0EX'#13#10'AR1EX'#13#10'AR2EX'#13#10'AR3EX'#13#10'AR4EX'#13#10'CR0EX'#13#10'CR1EX'#13#10'CR2EX'#13#10'CR3EX'#13#10'CR4EX'#13#10 +\r\n    'D0=A'#13#10'D0=C'#13#10'D1=A'#13#10'D1=C'#13#10'AD0EX'#13#10'AD1EX'#13#10'CD0EX'#13#10'CD1EX'#13#10'D0=AS'#13#10'D1=AS'#13#10'D0=CS'#13#10'D1=CD'#13#10'CD1XS'#13#10'CD0XS'#13#10'AD1XS'#13#10'AD0XS'#13#10 +\r\n    'RTNC'#13#10'RTNNC'#13#10'OUT=CS'#13#10'OUT=C'#13#10'A=IN'#13#10'C=IN'#13#10'SHUTDN'#13#10'INTON'#13#10'C=ID'#13#10'CONFIG'#13#10'UNCNFG'#13#10'RSI'#13#10'PC=(A)'#13#10'PC=(C)'#13#10'INTOFF'#13#10 +\r\n    'C+P+1'#13#10'RESET'#13#10'SREQ?'#13#10'ASLC'#13#10'BSLC'#13#10'CSLC'#13#10'DSLC'#13#10'ASRC'#13#10'BSRC'#13#10'CSRC'#13#10'DSRC'#13#10'ASRB'#13#10'BSRB'#13#10'CSRB'#13#10'DSRB'#13#10'PC=A'#13#10'PC=C'#13#10 +\r\n    'A=PC'#13#10'C=PC'#13#10'APCEX'#13#10'CPCEX'#13#10'XM=0'#13#10'SB=0'#13#10'SR=0'#13#10'MP=0'#13#10'CLRHST'#13#10'?XM=0'#13#10'?SR=0'#13#10'?MP=0'#13#10'?SB=0'#13#10'RTNYES'#13#10'SKIPYES{'#13#10'{'#13#10'}'#13#10'UP'#13#10'EXIT'#13#10'EXITNC'#13#10'EXITC'#13#10'UPC'#13#10'UPNC' +\r\n    '}SKELSE{'#13#10'SKC{'#13#10'SKNC{'#13#10'SKUB{'#13#10'SKUBL{'#13#10'SKIPC{'#13#10'SKIPNC{'#13#10'EXIT2'#13#10'EXIT3'#13#10'UP2'#13#10'UP3'#13#10'}SKLSE{'#13#10'}SKEC{'#13#10'}SKENC{'#13#10;\r\n\r\nfunction StringCrc(S: UnicodeString): integer;\r\nvar\r\n  i: integer;\r\nbegin\r\n  result := 0;\r\n  for i := 1 to length(s) do begin\r\n    result := (result shr 4) xor (((result xor ord(s[i])) and $F) * $1081);\r\n    result := (result shr 4) xor (((result xor (ord(s[i]) shr 4)) and $F) * $1081);\r\n  end;\r\nend;\r\n\r\n{ TSpeedListObject }\r\n\r\nconstructor TSpeedListObject.create(name: UnicodeString);\r\nbegin\r\n  inherited create;\r\n  FName := name;\r\nend;\r\n\r\ndestructor TSpeedListObject.destroy;\r\nbegin\r\n  if Assigned(FSpeedList) then\r\n    FSpeedList.ObjectDeleted(Self);\r\n  inherited destroy;\r\nend;\r\n\r\nprocedure TSpeedListObject.SetName(const Value: UnicodeString);\r\nbegin\r\n  FName := Value;\r\n  if FSpeedList <> nil then\r\n    FSpeedList.NameChange(Self, Value);\r\nend;\r\n\r\n{ TSpeedStringList }\r\n\r\nfunction TSpeedStringList.AddObj(const Value: TSpeedListObject): Integer;\r\nvar\r\n  crc: integer;\r\n  i: integer;\r\nbegin\r\n  crc := StringCrc(Value.Name) mod High(Datas) + 1;\r\n  if DatasUsed[crc] = lengthDatas[crc] then begin\r\n    ReallocMem(datas[crc], (lengthDatas[crc] * 2 + 1) * SizeOf(datas[1][0]));\r\n    lengthDatas[crc] := lengthDatas[crc] * 2 + 1;\r\n  end;\r\n  Datas[crc][DatasUsed[crc]] := Value;\r\n  result := SumOfUsed[crc] + DatasUsed[crc];\r\n  inc(DatasUsed[crc]);\r\n  for i := crc + 1 to High(SumOfUsed) do\r\n    inc(SumOfUsed[i]);\r\n  Value.SpeedList := Self;\r\nend;\r\n\r\nfunction TSpeedStringList.Add(const Value: UnicodeString): TSpeedListObject;\r\nbegin\r\n  result := TSpeedListObject.Create(value);\r\n  AddObj(Result);\r\nend;\r\n\r\nprocedure TSpeedStringList.Changed;\r\nbegin\r\n  if Assigned(FOnChange) then\r\n    FOnChange(Self);\r\nend;\r\n\r\nprocedure TSpeedStringList.Clear;\r\nvar\r\n  i, j: integer;\r\nbegin\r\n  for i := low(datas) to high(datas) do begin\r\n    for j := 0 to DatasUsed[i] - 1 do\r\n      datas[i][j].free;\r\n    datasUsed[i] := 0;\r\n    ReallocMem(datas[i], 0);\r\n    lengthDatas[i] := 0;\r\n    SumOfUsed[i] := 0;\r\n  end;\r\n  Changed;\r\nend;\r\n\r\nconstructor TSpeedStringList.create;\r\nvar\r\n  i: integer;\r\nbegin\r\n  inherited Create;\r\n  for i := Low(Datas) to high(datas) do begin\r\n    SumOfUsed[i] := 0;\r\n    DatasUsed[i] := 0;\r\n    lengthDatas[i] := 0;\r\n    datas[i] := nil;\r\n  end;\r\nend;\r\n\r\ndestructor TSpeedStringList.Destroy;\r\nbegin\r\n  Clear;\r\n  inherited destroy;\r\nend;\r\n\r\nfunction TSpeedStringList.Find(const name: UnicodeString): TSpeedListObject;\r\nvar\r\n  crc: integer;\r\n  i: integer;\r\nbegin\r\n  crc := StringCrc(name) mod High(Datas) + 1;\r\n  for i := 0 to DatasUsed[crc] - 1 do\r\n    if Datas[crc][i].name = name then begin\r\n      result := Datas[crc][i];\r\n      exit;\r\n    end;\r\n  result := nil;\r\nend;\r\n\r\nfunction TSpeedStringList.Get(Index: Integer): UnicodeString;\r\nvar\r\n  i: integer;\r\nbegin\r\n  for i := low(SumOfUsed) + 1 to High(SumOfUsed) do\r\n    if Index > SumOfUsed[i] then begin\r\n      result := Datas[i - 1][Index - SumOfUsed[i - 1]].name;\r\n      exit;\r\n    end;\r\n  result := '';\r\nend;\r\n\r\nfunction TSpeedStringList.GetCount: integer;\r\nbegin\r\n  result := SumOfUsed[High(datas)] + DatasUsed[High(Datas)];\r\nend;\r\n\r\nfunction TSpeedStringList.GetInObject(Index: Integer): TObject;\r\nvar\r\n  i: integer;\r\nbegin\r\n  for i := low(SumOfUsed) + 1 to High(SumOfUsed) do\r\n    if Index > SumOfUSed[i] then begin\r\n      result := Datas[i - 1][Index - SumOfUsed[i - 1]].pointer;\r\n      exit;\r\n    end;\r\n  result := nil;\r\nend;\r\n\r\nfunction TSpeedStringList.GetObject(Index: Integer): TSpeedListObject;\r\nvar\r\n  i: integer;\r\nbegin\r\n  for i := low(SumOfUsed) + 1 to High(SumOfUsed) do\r\n    if Index > SumOfUSed[i] then begin\r\n      result := Datas[i - 1][Index - SumOfUsed[i - 1]];\r\n      exit;\r\n    end;\r\n  result := nil;\r\nend;\r\n\r\nfunction TSpeedStringList.GetStringList: TUnicodeStrings;\r\nvar\r\n  i, j: integer;\r\nbegin\r\n  result := TUnicodeStringList.Create;\r\n  for i := Low(Datas) to High(Datas) do\r\n    for j := 0 to DatasUsed[i] - 1 do\r\n      result.add(datas[i][j].name);\r\nend;\r\n\r\nfunction TSpeedStringList.GetText: UnicodeString;\r\nbegin\r\n  with StringList do begin\r\n    result := Text;\r\n    free;\r\n  end;\r\nend;\r\n\r\nprocedure TSpeedStringList.NameChange(const Obj: TSpeedListObject; const NewName: UnicodeString);\r\nvar\r\n  crc: integer;\r\n  i: integer;\r\n  j: integer;\r\nbegin\r\n  crc := StringCrc(obj.Name) mod High(Datas) + 1;\r\n  for i := 0 to DatasUsed[crc] - 1 do\r\n    if Datas[crc][i] = Obj then begin\r\n      for j := i + 1 to DatasUsed[crc] - 1 do\r\n        Datas[i - 1] := Datas[i];\r\n      for j := crc + 1 to High(Datas) do\r\n        dec(SumOfUsed[j]);\r\n      if DatasUsed[crc] < lengthDatas[crc] div 2 then begin\r\n        ReallocMem(Datas[crc], DatasUsed[crc] * SizeOf(Datas[crc][0]));\r\n        lengthDatas[crc] := DatasUsed[crc];\r\n      end;\r\n      AddObj(Obj);\r\n      exit;\r\n    end;\r\nend;\r\n\r\nprocedure TSpeedStringList.ObjectDeleted(const obj: TSpeedListObject);\r\nvar\r\n  crc: integer;\r\n  i: integer;\r\n  j: integer;\r\nbegin\r\n  crc := StringCrc(obj.Name) mod High(Datas) + 1;\r\n  for i := 0 to DatasUsed[crc] - 1 do\r\n    if Datas[crc][i] = Obj then begin\r\n      for j := i + 1 to DatasUsed[crc] - 1 do\r\n        if i > 0 then\r\n          Datas[i - 1] := Datas[i];\r\n      for j := crc + 1 to High(Datas) do\r\n        dec(SumOfUsed[j]);\r\n      Obj.FSpeedList := nil;\r\n      exit;\r\n    end;\r\nend;\r\n\r\nprocedure TSpeedStringList.SetInObject(Index: Integer;\r\n  const Value: TObject);\r\nvar\r\n  i: integer;\r\nbegin\r\n  for i := low(SumOfUsed) + 1 to High(SumOfUsed) do\r\n    if Index > SumOfUSed[i] then begin\r\n      Datas[i - 1][Index - SumOfUsed[i - 1]].pointer := value;\r\n      exit;\r\n    end;\r\nend;\r\n\r\nprocedure TSpeedStringList.SetStringList(const value: TUnicodeStrings);\r\nvar\r\n  i: integer;\r\nbegin\r\n  clear;\r\n  for i := 0 to Value.Count - 1 do\r\n    AddObj(TSpeedListObject.Create(value[i]));\r\nend;\r\n\r\nprocedure TSpeedStringList.SetText(const Value: UnicodeString);\r\nvar\r\n  s: TUnicodeStrings;\r\nbegin\r\n  s := TUnicodeStringList.Create;\r\n  try\r\n    s.Text := Value;\r\n    StringList := s;\r\n  finally\r\n    s.Free;\r\n  end;\r\nend;\r\n\r\n{ TSynHP48Syn }\r\n\r\nconstructor TSynHP48Syn.Create(AOwner: TComponent);\r\nvar\r\n  j, k: integer;\r\nbegin\r\n  Attribs[tkNull] := TSynHighlighterAttributes.Create(SYNS_AttrNull, SYNS_FriendlyAttrNull);\r\n  Attribs[tkAsmKey] := TSynHighlighterAttributes.Create(SYNS_AttrAsmKey, SYNS_FriendlyAttrAsmKey);\r\n  Attribs[tkAsm] := TSynHighlighterAttributes.Create(SYNS_AttrAsm, SYNS_FriendlyAttrAsm);\r\n  Attribs[tkAsmComment] := TSynHighlighterAttributes.Create(SYNS_AttrAsmComment, SYNS_FriendlyAttrAsmComment);\r\n  Attribs[tksAsmKey] := TSynHighlighterAttributes.Create(SYNS_AttrSASMKey, SYNS_FriendlyAttrSASMKey);\r\n  Attribs[tksAsm] := TSynHighlighterAttributes.Create(SYNS_AttrSASM, SYNS_FriendlyAttrSASM);\r\n  Attribs[tksAsmComment] := TSynHighlighterAttributes.Create(SYNS_AttrSASMComment, SYNS_FriendlyAttrSASMComment);\r\n  Attribs[tkRplKey] := TSynHighlighterAttributes.Create(SYNS_AttrRplKey, SYNS_FriendlyAttrRplKey);\r\n  Attribs[tkRpl] := TSynHighlighterAttributes.Create(SYNS_AttrRpl, SYNS_FriendlyAttrRpl);\r\n  Attribs[tkRplComment] := TSynHighlighterAttributes.Create(SYNS_AttrRplComment, SYNS_FriendlyAttrRplComment);\r\n\r\n  inherited Create(AOwner);\r\n  SetHighlightChange;\r\n  FAsmKeyWords := TSpeedStringList.Create;\r\n  FAsmKeyWords.Text := DefaultAsmKeyWords;\r\n  for j := low(OtherAsmKeyWords) to High(OtherAsmKeyWords) do begin\r\n    FAsmKeyWords.AddObj(TSpeedListObject.Create(OtherAsmKeyWords[j]));\r\n    for k := 1 to 8 do\r\n      FAsmKeyWords.AddObj(TSpeedListObject.Create(OtherAsmKeyWords[j] + IntToStr(k)));\r\n  end;\r\n  FRplKeyWords := TSpeedStringList.Create;\r\n  FRplKeyWords.Text := DefaultRplKeyWords;\r\n  FSAsmNoField := TSpeedStringList.Create;\r\n  FSAsmNoField.Text := SAsmNoField;\r\n  BaseRange := rsRpl;\r\n  fRange := rsRpl;\r\n  fDefaultFilter := SYNS_FilterHP48;\r\nend; { Create }\r\n\r\ndestructor TSynHP48Syn.Destroy;\r\nvar\r\n  i: TtkTokenKind;\r\nbegin\r\n  for i := low(TtkTokenKind) to High(TtkTokenKind) do\r\n    Attribs[i].Free;\r\n  FAsmKeyWords.Free;\r\n  FRplKeyWords.Free;\r\n  FSAsmNoField.free;\r\n  inherited Destroy;\r\nend; { Destroy }\r\n\r\nfunction TSynHP48Syn.AsmComProc(c: WideChar): TtkTokenKind;\r\nbegin\r\n  Result := tkAsmComment;\r\n  if (Run > Length(fLineStr)) then\r\n    Result := NullProc\r\n  else\r\n    while Run <= Length(fLineStr) do\r\n      if ((run = 1) or (fLineStr[run - 1] <= ' ')) and\r\n        (fLineStr[Run] = '*') and\r\n        ((run < Length(fLineStr)) and (fLineStr[run + 1] = c)) and\r\n        ((run + 1 = Length(fLineStr)) or (fLineStr[run + 2] <= ' ')) then begin\r\n        inc(run, 2);\r\n        fRange := rsAsm;\r\n        break;\r\n      end\r\n      else\r\n        inc(Run);\r\nend;\r\n\r\nfunction TSynHP48Syn.RplComProc: TtkTokenKind;\r\nbegin\r\n  Result := tkRplComment;\r\n  if (Run > Length(fLineStr)) then\r\n    Result := NullProc\r\n  else\r\n    while Run <= Length(fLineStr) do\r\n      if fLineStr[Run] = ')' then begin\r\n        inc(run);\r\n        fRange := rsRpl;\r\n        break;\r\n      end\r\n      else\r\n        inc(Run);\r\nend;\r\n\r\nfunction TSynHP48Syn.SlashProc: TtkTokenKind;\r\nbegin\r\n  if fRange = rsRpl then\r\n    Result := IdentProc\r\n  else if ((Run = 1) or (fLineStr[Run - 1] <= ' ')) and\r\n    (fLineStr[Run] = '/') and\r\n    (run < Length(fLineStr)) and\r\n    (fLineStr[run + 1] = '*') and\r\n    ((run + 1 = Length(fLineStr)) or (fLineStr[Run + 2] <= ' ')) then begin\r\n    inc(Run, 2);\r\n    Result := tkAsmComment;\r\n    fRange := rsComAsm2;\r\n  end\r\n  else if (run < Length(fLineStr)) and (fLineStr[Run + 1] = '/') then begin\r\n    inc(Run, 2);\r\n    Result := tkAsmComment;\r\n    while (run <= Length(fLineStr)) do\r\n      if CharInSet(fLineStr[Run], [#10, #13]) then\r\n      begin\r\n        inc(Run);\r\n        break;\r\n      end\r\n      else\r\n        inc(Run);\r\n  end\r\n  else\r\n    Result := IdentProc\r\nend;\r\n\r\nfunction TSynHP48Syn.ParOpenProc: TtkTokenKind;\r\nbegin\r\n  if fRange = rsRpl then\r\n    if ((Run = 1) and ((Length(fLineStr) = 1) or (fLineStr[Run + 1] <= ' '))) or\r\n      ((fLineStr[Run - 1] <= ' ') and ((Length(fLineStr) = Run) or (fLineStr[Run + 1] <= ' '))) then begin\r\n      inc(Run);\r\n      Result := tkRplComment;\r\n      fRange := rsComRpl;\r\n    end\r\n    else\r\n      Result := IdentProc\r\n  else if ((run = 1) or (fLineStr[run - 1] <= ' ')) and\r\n    (fLineStr[Run] = '(') and\r\n    (run < Length(fLineStr)) and\r\n    (fLineStr[run + 1] = '*') and\r\n    ((run + 2 > Length(fLineStr)) or (fLineStr[run + 2] <= ' ')) then begin\r\n    inc(Run, 2);\r\n    Result := tkAsmComment;\r\n    fRange := rsComAsm1;\r\n  end\r\n  else\r\n    Result := IdentProc\r\nend;\r\n\r\nfunction TSynHP48Syn.PersentProc: TtkTokenKind;\r\nbegin\r\n  if fRange = rsAsm then begin\r\n    inc(Run);\r\n    Result := tkAsmComment;\r\n    while (run <= Length(fLineStr)) do\r\n      case fLineStr[Run] of\r\n        #10, #13: begin\r\n            inc(Run);\r\n            break;\r\n          end;\r\n      else\r\n        inc(Run);\r\n      end;\r\n  end\r\n  else\r\n    Result := IdentProc;\r\nend;\r\n\r\nfunction TSynHP48Syn.StarProc: TtkTokenKind;\r\nbegin\r\n  if fRange = rsRpl then begin\r\n    inc(Run);\r\n    Result := tkRplComment;\r\n    while (run <= Length(fLineStr)) do\r\n      case fLineStr[Run] of\r\n        #10, #13: begin\r\n            inc(Run);\r\n            break;\r\n          end;\r\n      else\r\n        inc(Run);\r\n      end;\r\n  end\r\n  else\r\n    Result := IdentProc;\r\nend;\r\n\r\nfunction TSynHP48Syn.IdentProc: TtkTokenKind;\r\nvar\r\n  i: integer;\r\n  s: UnicodeString;\r\nbegin\r\n  i := Run;\r\n  EndOfToken;\r\n  s := Copy(fLineStr, i, run - i);\r\n  if fRange = rsAsm then\r\n    if FAsmKeyWords.Find(s) <> nil then\r\n      if (s = '!RPL') or (s = 'ENDCODE') then begin\r\n        fRange := rsRpl;\r\n        result := tkAsmKey;\r\n      end\r\n      else\r\n        result := tkAsmKey\r\n    else if fLineStr[i] <> '*' then\r\n      result := tkAsm\r\n    else\r\n      result := tkAsmKey\r\n  else if FRplKeyWords.Find(s) <> nil then\r\n    if (s = 'CODEM') or (s = 'ASSEMBLEM') then begin\r\n      fRange := rsAsm;\r\n      result := tkAsmKey;\r\n    end\r\n    else if (s = 'CODE') or (s = 'ASSEMBLE') then begin\r\n      fRange := rssAsm1;\r\n      result := tksAsmKey;\r\n    end\r\n    else\r\n      result := tkRplKey\r\n  else\r\n    result := tkRpl;\r\nend;\r\n\r\nfunction TSynHP48Syn.GetTokenFromRange: TtkTokenKind;\r\nbegin\r\n  case frange of\r\n    rsAsm: result := tkAsm;\r\n    rssAsm1: result := tksAsmKey;\r\n    rssAsm2: result := tksAsm;\r\n    rssAsm3: result := tksAsmComment;\r\n    rsRpl: result := tkRpl;\r\n    rsComRpl: result := tkRplComment;\r\n    rsComAsm1, rsComAsm2: result := tkAsmComment;\r\n  else\r\n    result := tkNull;\r\n  end;\r\nend;\r\n\r\nfunction TSynHP48Syn.NullProc: TtkTokenKind;\r\nbegin\r\n  Result := tkNull;\r\n  inc(Run);\r\nend;\r\n\r\nfunction TSynHP48Syn.SpaceProc: TtkTokenKind;\r\nbegin\r\n  inc(Run);\r\n  while (Run <= Length(fLineStr)) and CharInSet(fLineStr[Run], [#1..#32]) do\r\n    inc(Run);\r\n  result := GetTokenFromRange;\r\nend;\r\n\r\nfunction TSynHP48Syn.Next1: TtkTokenKind;\r\nbegin\r\n  fTokenPos := Run - 1;\r\n  if Run > Length(fLineStr) then\r\n    result := NullProc\r\n  else if fRange = rsComRpl then\r\n    result := RplComProc\r\n  else if fRange = rsComAsm1 then\r\n    result := AsmComProc(')')\r\n  else if fRange = rsComAsm2 then\r\n    result := AsmComProc('/')\r\n  else if frange = rssasm1 then\r\n    result := SasmProc1\r\n  else if frange = rssasm2 then\r\n    result := sasmproc2\r\n  else if frange = rssasm3 then\r\n    result := sasmproc3\r\n  else if CharInSet(fLineStr[Run], [#1..#32]) then\r\n    result := SpaceProc\r\n  else if fLineStr[Run] = '(' then\r\n    result := ParOpenProc\r\n  else if fLineStr[Run] = '%' then\r\n    result := PersentProc\r\n  else if fLineStr[Run] = '/' then\r\n    result := SlashProc\r\n  else if (run = 1) and (fRange = rsRpl) and (fLineStr[1] = '*') then\r\n    result := StarProc\r\n  else\r\n    result := IdentProc;\r\nend;\r\n\r\nprocedure TSynHP48Syn.Next2(tkk: TtkTokenKind);\r\nbegin\r\n  fTockenKind := tkk;\r\nend;\r\n\r\nprocedure TSynHP48Syn.Next;\r\nbegin\r\n  Next2(Next1);\r\n  inherited;\r\nend;\r\n\r\nfunction TSynHP48Syn.GetEol: Boolean;\r\nbegin\r\n  Result := Run = fLineLen + 2;\r\nend;\r\n\r\nfunction TSynHP48Syn.GetRange: Pointer;\r\nbegin\r\n  Result := Pointer(fRange);\r\nend;\r\n\r\nprocedure TSynHP48Syn.SetRange(Value: Pointer);\r\nbegin\r\n  fRange := TRangeState(Value);\r\nend;\r\n\r\nprocedure TSynHP48Syn.ResetRange;\r\nbegin\r\n  fRange := BaseRange;\r\nend;\r\n\r\nfunction TSynHP48Syn.GetAttrib(Index: integer): TSynHighlighterAttributes;\r\nbegin\r\n  Result := Attribs[TtkTokenKind(Index)];\r\nend;\r\n\r\nprocedure TSynHP48Syn.SetAttrib(Index: integer; Value: TSynHighlighterAttributes);\r\nbegin\r\n  Attribs[TtkTokenKind(Index)].Assign(Value);\r\nend;\r\n\r\nprocedure TSynHP48Syn.EndOfToken;\r\nbegin\r\n  while (Run <= Length(fLineStr)) and (fLineStr[Run] > ' ') do\r\n    Inc(Run);\r\nend;\r\n\r\n{$IFNDEF SYN_CLX}\r\nfunction TSynHP48Syn.LoadFromRegistry(RootKey: HKEY; Key: string): boolean;\r\nvar\r\n  r: TBetterRegistry;\r\nbegin\r\n  r := TBetterRegistry.Create;\r\n  try\r\n    r.RootKey := RootKey;\r\n    if r.OpenKeyReadOnly(Key) then begin\r\n      if r.ValueExists('AsmKeyWordList')\r\n        then AsmKeywords.Text := r.ReadString('AsmKeyWordList');\r\n      if r.ValueExists('RplKeyWordList')\r\n        then RplKeywords.Text := r.ReadString('RplKeyWordList');\r\n      Result := inherited LoadFromRegistry(RootKey, Key);\r\n    end\r\n    else\r\n      Result := false;\r\n  finally r.Free;\r\n  end;\r\nend;\r\n\r\nfunction TSynHP48Syn.SaveToRegistry(RootKey: HKEY; Key: string): boolean;\r\nvar\r\n  r: TBetterRegistry;\r\nbegin\r\n  r := TBetterRegistry.Create;\r\n  try\r\n    r.RootKey := RootKey;\r\n    if r.OpenKey(Key, true) then begin\r\n      Result := true;\r\n      r.WriteString('AsmKeyWordList', AsmKeywords.Text);\r\n      r.WriteString('RplKeyWordList', RplKeywords.Text);\r\n      Result := inherited SaveToRegistry(RootKey, Key);\r\n    end\r\n    else\r\n      Result := false;\r\n  finally r.Free;\r\n  end;\r\nend;\r\n{$ENDIF}\r\n\r\nprocedure TSynHP48Syn.Assign(Source: TPersistent);\r\nvar\r\n  i: TtkTokenKind;\r\nbegin\r\n  if Source is TSynHP48Syn then begin\r\n    for i := Low(Attribs) to High(Attribs) do begin\r\n      Attribs[i].Background := TSynHP48Syn(source).Attribs[i].Background;\r\n      Attribs[i].Foreground := TSynHP48Syn(source).Attribs[i].Foreground;\r\n      Attribs[i].Style := TSynHP48Syn(source).Attribs[i].Style;\r\n    end;\r\n    AsmKeyWords.Text := TSynHP48Syn(source).AsmKeyWords.Text;\r\n    RplKeyWords.Text := TSynHP48Syn(source).RplKeyWords.Text;\r\n  end\r\n  else\r\n    inherited Assign(Source);\r\nend;\r\n\r\nfunction TSynHP48Syn.GetAttribCount: integer;\r\nbegin\r\n  Result := Ord(High(Attribs)) - Ord(Low(Attribs)) + 1;\r\nend;\r\n\r\nfunction TSynHP48Syn.GetAttribute(idx: integer): TSynHighlighterAttributes;\r\nbegin // sorted by name\r\n  if (idx <= Ord(High(TtkTokenKind))) then\r\n    Result := Attribs[TtkTokenKind(idx)]\r\n  else\r\n    Result := nil;\r\nend;\r\n\r\nfunction TSynHP48Syn.IsFilterStored: Boolean;\r\nbegin\r\n  Result := fDefaultFilter <> SYNS_FilterHP48;\r\nend;\r\n\r\nclass function TSynHP48Syn.GetLanguageName: string;\r\nbegin\r\n  Result := SYNS_LangHP48;\r\nend;\r\n\r\nprocedure TSynHP48Syn.SetHighLightChange;\r\nvar\r\n  i: TtkTokenKind;\r\nbegin\r\n  for i := Low(Attribs) to High(Attribs) do begin\r\n    Attribs[i].OnChange := DefHighLightChange;\r\n    Attribs[i].InternalSaveDefaultValues;\r\n  end;\r\nend;\r\n\r\nfunction TSynHP48Syn.SasmProc1: TtkTokenKind;\r\nvar\r\n  i: integer;\r\n  s: UnicodeString;\r\nbegin\r\n  Result := tksAsmKey;\r\n  if run > Length(fLineStr) then\r\n    exit;\r\n  if fLineStr[Run] = '*' then begin\r\n    frange := rssasm3;\r\n    result := tksAsmComment;\r\n    exit;\r\n  end;\r\n  if fLineStr[Run] >= ' ' then begin\r\n    i := run;\r\n    while (run <= Length(fLineStr)) and (fLineStr[run] > ' ') do\r\n      inc(run);\r\n    s := Copy(fLineStr, i, run - i);\r\n    if (s = 'RPL') or (s = 'ENDCODE') then begin\r\n      frange := rsRpl;\r\n      exit;\r\n    end;\r\n  end;\r\n  while (run <= Length(fLineStr)) and (fLineStr[run] <= ' ') and (fLineStr[run] <> #10) do\r\n    inc(run);\r\n  if run <= Length(fLineStr) then\r\n    frange := rssasm2\r\n  else\r\n    frange := rssasm1;\r\nend;\r\n\r\nfunction TSynHP48Syn.SasmProc2: TtkTokenKind;\r\nvar\r\n  i: integer;\r\n  s: UnicodeString;\r\nbegin\r\n  Result := tksAsm;\r\n  while (run <= Length(fLineStr)) and (fLineStr[run] <= ' ') and (fLineStr[run] <> #10) do\r\n    inc(run);\r\n  if run > 30 then begin\r\n    frange := rssasm3;\r\n    exit;\r\n  end;\r\n  i := run;\r\n  while (run <= Length(fLineStr)) and (fLineStr[run] > ' ') do\r\n    inc(run);\r\n  s := Copy(fLineStr, i, run - i);\r\n  if (s = 'ENDCODE') or (s = 'RPL') then begin\r\n    frange := rsRpl;\r\n    result := tksAsmKey;\r\n  end\r\n  else begin\r\n    if FSAsmNoField.Find(s) = nil then begin\r\n      while (run <= Length(fLineStr)) and (fLineStr[run] <= ' ') and (fLineStr[run] <> #10) do\r\n        inc(run);\r\n      while (run <= Length(fLineStr)) and (fLineStr[run] > ' ') do\r\n        inc(run);\r\n      while (run <= Length(fLineStr)) and (fLineStr[run] <= ' ') and (fLineStr[run] <> #10) do\r\n        inc(run);\r\n    end;\r\n    if run <= Length(fLineStr) then\r\n      frange := rssasm3\r\n    else\r\n      frange := rssasm1;\r\n  end;\r\nend;\r\n\r\nfunction TSynHP48Syn.SasmProc3: TtkTokenKind;\r\nbegin\r\n  Result := tksAsmComment;\r\n  while (run <= Length(fLineStr)) and (fLineStr[run] <> #10) do\r\n    inc(run);\r\n  if run <= Length(fLineStr) then inc(run);\r\n  frange := rssasm1;\r\nend;\r\n\r\nfunction TSynHP48Syn.GetTokenAttribute: TSynHighlighterAttributes;\r\nbegin\r\n  Result := GetAttrib(Ord(fTockenKind));\r\nend;\r\n\r\nfunction TSynHP48Syn.GetTokenKind: integer;\r\nbegin\r\n  Result := Ord(fTockenKind);\r\nend;\r\n\r\nfunction TSynHP48Syn.GetDefaultAttribute(Index: integer): TSynHighlighterAttributes;\r\nbegin\r\n  Result := nil;\r\nend;\r\n\r\n// reimplement functions to handle the non-standard use of 1-based Run\r\n// (instead of the standard 0-based Run)\r\n\r\nprocedure TSynHP48Syn.DoSetLine(const Value: UnicodeString;\r\n  LineNumber: Integer);\r\nbegin\r\n  inherited;\r\n  Run := 1;\r\n  fOldRun := Run;\r\nend;\r\n\r\nfunction TSynHP48Syn.GetToken: UnicodeString;\r\nvar\r\n  Len: Integer;\r\nbegin\r\n  Len := (Run - 1) - fTokenPos;\r\n  SetLength(Result, Len);\r\n  if Len > 0 then\r\n    WStrLCopy(@Result[1], fCasedLine + fTokenPos, Len);\r\nend;\r\n\r\nfunction TSynHP48Syn.IsLineEnd(Run: Integer): Boolean;\r\nbegin\r\n  Result := (Run - 1 >= fLineLen) or (fLine[Run - 1] = #10) or (fLine[Run - 1] = #13);\r\nend;\r\n\r\n{$IFNDEF SYN_CPPB_1}\r\nclass function TSynHP48Syn.GetFriendlyLanguageName: UnicodeString;\r\nbegin\r\n  Result := SYNS_FriendlyLangHP48;\r\nend;\r\n\r\ninitialization\r\n  RegisterPlaceableHighlighter(TSynHP48Syn);\r\n{$ENDIF}\r\nend.\r\n"
  },
  {
    "path": "External/SynEdit/Source/SynHighlighterHashEntries.pas",
    "content": "{-------------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: SynHighlighterHashEntries.pas, released 2000-04-21.\r\n\r\nThe Initial Author of this file is Michael Hieke.\r\nPortions created by Michael Hieke are Copyright 2000 Michael Hieke.\r\nUnicode translation by Mal Hrz.\r\nAll Rights Reserved.\r\n\r\nContributors to the SynEdit project are listed in the Contributors.txt file.\r\n\r\nAlternatively, the contents of this file may be used under the terms of the\r\nGNU General Public License Version 2 or later (the \"GPL\"), in which case\r\nthe provisions of the GPL are applicable instead of those above.\r\nIf you wish to allow use of your version of this file only under the terms\r\nof the GPL and not to allow others to use your version of this file\r\nunder the MPL, indicate your decision by deleting the provisions above and\r\nreplace them with the notice and other provisions required by the GPL.\r\nIf you do not delete the provisions above, a recipient may use your version\r\nof this file under either the MPL or the GPL.\r\n\r\n$Id: SynHighlighterHashEntries.pas,v 1.5.2.3 2008/09/14 16:25:00 maelh Exp $\r\n\r\nYou may retrieve the latest version of this file at the SynEdit home page,\r\nlocated at http://SynEdit.SourceForge.net\r\n\r\nKnown Issues:\r\n-------------------------------------------------------------------------------}\r\n\r\n{\r\n@abstract(Support classes for SynEdit highlighters that create the keyword lists at runtime.)\r\n@author(Michael Hieke)\r\n@created(2000-04-21)\r\n@lastmod(2001-09-07)\r\nThe classes in this unit can be used to use the hashing algorithm while still\r\nhaving the ability to change the set of keywords.\r\n}\r\n\r\n{$IFNDEF QSYNHIGHLIGHTERHASHENTRIES}\r\nunit SynHighlighterHashEntries;\r\n{$ENDIF}\r\n\r\n{$I SynEdit.inc}\r\n\r\ninterface\r\n\r\nuses\r\n{$IFDEF SYN_CLX}\r\n  QSynEditTypes,\r\n  QSynUnicode,  \r\n{$ELSE}\r\n  SynEditTypes,\r\n  SynUnicode,\r\n{$ENDIF}\r\n  Classes;\r\n\r\ntype\r\n  { Class to hold the keyword to recognize, its length and its token kind. The\r\n    keywords that have the same hashvalue are stored in a single-linked list,\r\n    with the Next property pointing to the next entry. The entries are ordered\r\n    over the keyword length. }\r\n  TSynHashEntry = class(TObject)\r\n  protected\r\n    { Points to the next keyword entry with the same hashvalue. }\r\n    fNext: TSynHashEntry;\r\n    { Length of the keyword. }\r\n    fKeyLen: integer;\r\n    { The keyword itself. }\r\n    fKeyword: UnicodeString;\r\n    { Keyword token kind, has to be typecasted to the real token kind type. }\r\n    fKind: integer;\r\n  public\r\n    { Adds a keyword entry with the same hashvalue. Depending on the length of\r\n      the two keywords it might return Self and store NewEntry in the Next\r\n      pointer, or return NewEntry and make the Next property of NewEntry point\r\n      to Self. This way the order of keyword length is preserved. }\r\n    function AddEntry(NewEntry: TSynHashEntry): TSynHashEntry; virtual;\r\n    { Creates a keyword entry for the given keyword and token kind. }\r\n    constructor Create(const AKey: UnicodeString; AKind: integer);\r\n    { Destroys the keyword entry and all other keyword entries Next points to. }\r\n    destructor Destroy; override;\r\n  public\r\n    { The keyword itself. }\r\n    property Keyword: UnicodeString read fKeyword;\r\n    { Length of the keyword. }\r\n    property KeywordLen: integer read fKeyLen;\r\n    { Keyword token kind, has to be typecasted to the real token kind type. }\r\n    property Kind: integer read fKind;\r\n    { Points to the next keyword entry with the same hashvalue. }\r\n    property Next: TSynHashEntry read fNext;\r\n  end;\r\n\r\n\r\n{$IFNDEF SYN_COMPILER_4_UP}\r\n  {$IFNDEF SYN_CPPB_3}\r\n    {$DEFINE LIST_CLEAR_NOT_VIRTUAL}\r\n  {$ENDIF}\r\n{$ENDIF}\r\n\r\n  { A list of keyword entries, stored as single-linked lists under the hashvalue\r\n    of the keyword. }\r\n  TSynHashEntryList = class(TList)\r\n  protected\r\n    { Returns the first keyword entry for a given hashcalue, or nil. }\r\n    function Get(HashKey: Integer): TSynHashEntry;\r\n    { Adds a keyword entry under its hashvalue. Will grow the list count when\r\n      necessary, so the maximum hashvalue should be limited outside. The correct\r\n      order of keyword entries is maintained. }\r\n    procedure Put(HashKey: Integer; Entry: TSynHashEntry);\r\n  public\r\n{$IFDEF LIST_CLEAR_NOT_VIRTUAL}\r\n    { Overridden destructor clears the list and frees all contained keyword\r\n      entries. }\r\n    destructor Destroy; override;\r\n    { Clears the list and frees all contained keyword entries. }\r\n    procedure DeleteEntries;\r\n{$ELSE}\r\n    { Clears the list and frees all contained keyword entries. }\r\n    procedure Clear; override;\r\n{$ENDIF}\r\n  public\r\n    { Type-safe access to the first keyword entry for a hashvalue. }\r\n    property Items[Index: integer]: TSynHashEntry read Get write Put; default;\r\n  end;\r\n\r\n  { Procedural type for adding keyword entries to a TSynHashEntryList when\r\n    iterating over all the keywords contained in a string. }\r\n  TEnumerateKeywordEvent = procedure(AKeyword: UnicodeString; AKind: integer)\r\n    of object;\r\n\r\n{ This procedure will call AKeywordProc for all keywords in KeywordList. A\r\n  keyword is considered any number of successive chars that are contained in\r\n  Identifiers, with chars not contained in Identifiers before and after them. }\r\nprocedure EnumerateKeywords(AKind: integer; KeywordList: UnicodeString;\r\n  IsIdentChar: TCategoryMethod; AKeywordProc: TEnumerateKeywordEvent);\r\n\r\nimplementation\r\n\r\nuses\r\n  SysUtils;\r\n\r\nprocedure EnumerateKeywords(AKind: integer; KeywordList: UnicodeString;\r\n  IsIdentChar: TCategoryMethod; AKeywordProc: TEnumerateKeywordEvent);\r\nvar\r\n  pStart, pEnd: PWideChar;\r\n  Keyword: UnicodeString;\r\nbegin\r\n  if Assigned(AKeywordProc) and (KeywordList <> '') then\r\n  begin\r\n    pEnd := PWideChar(KeywordList);\r\n    pStart := pEnd;\r\n    repeat\r\n      // skip over chars that are not in Identifiers\r\n      while (pStart^ <> #0) and not IsIdentChar(pStart^) do\r\n        Inc(pStart);\r\n      if pStart^ = #0 then break;\r\n      // find the last char that is in Identifiers\r\n      pEnd := pStart + 1;\r\n      while (pEnd^ <> #0) and IsIdentChar(pEnd^) do\r\n        Inc(pEnd);\r\n      // call the AKeywordProc with the keyword\r\n      SetString(Keyword, pStart, pEnd - pStart);\r\n      AKeywordProc(Keyword, AKind);\r\n      Keyword := '';\r\n      // pEnd points to a char not in Identifiers, restart after that\r\n      pStart := pEnd + 1;\r\n    until (pStart^ = #0) or (pEnd^ = #0);\r\n  end;\r\nend;\r\n\r\n{ TSynHashEntry }\r\n\r\nconstructor TSynHashEntry.Create(const AKey: UnicodeString; AKind: integer);\r\nbegin\r\n  inherited Create;\r\n  fKeyLen := Length(AKey);\r\n  fKeyword := AKey;\r\n  fKind := AKind;\r\nend;\r\n\r\ndestructor TSynHashEntry.Destroy;\r\nbegin\r\n  fNext.Free;\r\n  inherited Destroy;\r\nend;\r\n\r\nfunction TSynHashEntry.AddEntry(NewEntry: TSynHashEntry): TSynHashEntry;\r\nbegin\r\n  Result := Self;\r\n  if Assigned(NewEntry) then\r\n  begin\r\n    if WideCompareText(NewEntry.Keyword, fKeyword) = 0 then\r\n      raise Exception.CreateFmt('Keyword \"%s\" already in list', [fKeyword]);\r\n    if NewEntry.fKeyLen < fKeyLen then\r\n    begin\r\n      NewEntry.fNext := Self;\r\n      Result := NewEntry;\r\n    end else if Assigned(fNext) then\r\n      fNext := fNext.AddEntry(NewEntry)\r\n    else\r\n      fNext := NewEntry;\r\n  end;\r\nend;\r\n\r\n{ TSynHashEntryList }\r\n\r\n{$IFDEF LIST_CLEAR_NOT_VIRTUAL}\r\ndestructor TSynHashEntryList.Destroy;\r\nbegin\r\n  DeleteEntries;\r\n  inherited Destroy;\r\nend;\r\n\r\nprocedure TSynHashEntryList.DeleteEntries;\r\n{$ELSE}\r\nprocedure TSynHashEntryList.Clear;\r\n{$ENDIF}\r\nvar\r\n  i: integer;\r\nbegin\r\n  for i := 0 to Count - 1 do\r\n    TSynHashEntry(Items[i]).Free;\r\n  inherited Clear;\r\nend;\r\n\r\nfunction TSynHashEntryList.Get(HashKey: Integer): TSynHashEntry;\r\nbegin\r\n  if (HashKey >= 0) and (HashKey < Count) then\r\n    Result := inherited Items[HashKey]\r\n  else\r\n    Result := nil;\r\nend;\r\n\r\nprocedure TSynHashEntryList.Put(HashKey: Integer; Entry: TSynHashEntry);\r\nvar\r\n  ListEntry: TSynHashEntry;\r\nbegin\r\n  if HashKey >= Count then\r\n    Count := HashKey + 1;\r\n  ListEntry := TSynHashEntry(inherited Items[HashKey]);\r\n  // if there is already a hashentry for this hashvalue let it decide\r\n  // where to put the new entry in its single linked list\r\n  if Assigned(ListEntry) then\r\n    Entry := ListEntry.AddEntry(Entry);\r\n  inherited Items[HashKey] := Entry;\r\nend;\r\n\r\nend.\r\n\r\n"
  },
  {
    "path": "External/SynEdit/Source/SynHighlighterHaskell.pas",
    "content": "{-------------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: SynHighlighterHaskell.pas, released 2001-10-28\r\nThe Original Code is based on the SynHighlighterCpp.pas, released 2000-04-10\r\nwhich in turn was based on the dcjCppSyn.pas file from the mwEdit component\r\nsuite by Martin Waldenburg and other developers, the Initial Author of this file\r\nis Michael Trier.\r\nUnicode translation by Mal Hrz.\r\nAll Rights Reserved.\r\n\r\nContributors to the SynEdit and mwEdit projects are listed in the\r\nContributors.txt file.\r\n\r\nAlternatively, the contents of this file may be used under the terms of the\r\nGNU General Public License Version 2 or later (the \"GPL\"), in which case\r\nthe provisions of the GPL are applicable instead of those above.\r\nIf you wish to allow use of your version of this file only under the terms\r\nof the GPL and not to allow others to use your version of this file\r\nunder the MPL, indicate your decision by deleting the provisions above and\r\nreplace them with the notice and other provisions required by the GPL.\r\nIf you do not delete the provisions above, a recipient may use your version\r\nof this file under either the MPL or the GPL.\r\n\r\nYou may retrieve the latest version of SynEdit from the SynEdit home page,\r\nlocated at http://SynEdit.SourceForge.net\r\n\r\nYou may retrieve the latest version of this file from\r\nhttp://www.ashleybrown.co.uk/synedit/\r\n\r\n-------------------------------------------------------------------------------}\r\n{\r\n@abstract(Provides a Haskell syntax highlighter for SynEdit)\r\n@author(Ashley Brown)\r\n@created(2001)\r\n@lastmod(2000-10-26)\r\nThe SynHighlighterHaskell unit provides SynEdit with a Haskell syntax highlighter.\r\nBased on SynHighlighterCpp.\r\n\r\nhttp://haskell.org/\r\nhttp://www.ashleybrown.co.uk/\r\nashley@ashleybrown.co.uk\r\n}\r\n\r\n{$IFNDEF QSYNHIGHLIGHTERHASKELL}\r\nunit SynHighlighterHaskell;\r\n{$ENDIF}\r\n\r\n{$I SynEdit.inc}\r\n\r\ninterface\r\n\r\nuses\r\n{$IFDEF SYN_CLX}\r\n  QGraphics,\r\n  QSynEditTypes,\r\n  QSynEditHighlighter,\r\n  QSynUnicode,\r\n{$ELSE}\r\n  Graphics,\r\n  SynEditTypes,\r\n  SynEditHighlighter,\r\n  SynUnicode,\r\n{$ENDIF}\r\n  SysUtils,\r\n  Classes;\r\n\r\ntype\r\n  TtkTokenKind = (tkComment, tkIdentifier, tkKey, tkNull,\r\n    tkNumber, tkSpace, tkString, tkSymbol, tkUnknown);\r\n\r\n  TxtkTokenKind = (\r\n    xtkAdd, xtkAddAssign, xtkAnd, xtkAndAssign, xtkArrow, xtkAssign,\r\n    xtkBitComplement, xtkBraceClose, xtkBraceOpen, xtkColon, xtkComma,\r\n    xtkDecrement, xtkDivide, xtkDivideAssign, xtkEllipse, xtkGreaterThan,\r\n    xtkGreaterThanEqual, xtkIncOr, xtkIncOrAssign, xtkIncrement, xtkLessThan,\r\n    xtkLessThanEqual, xtkLogAnd, xtkLogComplement, xtkLogEqual, xtkLogOr,\r\n    xtkMod, xtkModAssign, xtkMultiplyAssign, xtkNotEqual, xtkPoint, xtkQuestion,\r\n    xtkRoundClose, xtkRoundOpen, xtkScopeResolution, xtkSemiColon, xtkShiftLeft,\r\n    xtkShiftLeftAssign, xtkShiftRight, xtkShiftRightAssign, xtkSquareClose,\r\n    xtkSquareOpen, xtkStar, xtkSubtract, xtkSubtractAssign, xtkXor,\r\n    xtkXorAssign);\r\n\r\n  TRangeState = (rsUnknown, rsAnsiC, rsAnsiCAsm, rsAnsiCAsmBlock, rsAsm,\r\n    rsAsmBlock, rsDirective, rsDirectiveComment, rsString34, rsString39);\r\n\r\n  PIdentFuncTableFunc = ^TIdentFuncTableFunc;\r\n  TIdentFuncTableFunc = function (Index: Integer): TtkTokenKind of object;\r\n\r\n  TSynHaskellSyn = class(TSynCustomHighlighter)\r\n  private\r\n    fAsmStart: Boolean;\r\n    fRange: TRangeState;\r\n    FTokenID: TtkTokenKind;\r\n    FExtTokenID: TxtkTokenKind;\r\n    fIdentFuncTable: array[0..28] of TIdentFuncTableFunc;\r\n    fCommentAttri: TSynHighlighterAttributes;\r\n    fIdentifierAttri: TSynHighlighterAttributes;\r\n    fKeyAttri: TSynHighlighterAttributes;\r\n    fNumberAttri: TSynHighlighterAttributes;\r\n    fSpaceAttri: TSynHighlighterAttributes;\r\n    fStringAttri: TSynHighlighterAttributes;\r\n    fSymbolAttri: TSynHighlighterAttributes;\r\n    function AltFunc(Index: Integer): TtkTokenKind;\r\n    function KeyWordFunc(Index: Integer): TtkTokenKind;\r\n    function HashKey(Str: PWideChar): Cardinal;\r\n    function IdentKind(MayBe: PWideChar): TtkTokenKind;\r\n    procedure InitIdent;\r\n    procedure AnsiCProc;\r\n    procedure AndSymbolProc;\r\n    procedure AsciiCharProc;\r\n    procedure AtSymbolProc;\r\n    procedure BraceCloseProc;\r\n    procedure BraceOpenProc;\r\n    procedure CRProc;\r\n    procedure ColonProc;\r\n    procedure CommaProc;\r\n    procedure EqualProc;\r\n    procedure GreaterProc;\r\n    procedure IdentProc;\r\n    procedure LFProc;\r\n    procedure LowerProc;\r\n    procedure MinusProc;\r\n    procedure ModSymbolProc;\r\n    procedure NotSymbolProc;\r\n    procedure NullProc;\r\n    procedure NumberProc;\r\n    procedure OrSymbolProc;\r\n    procedure PlusProc;\r\n    procedure PointProc;\r\n    procedure QuestionProc;\r\n    procedure RoundCloseProc;\r\n    procedure RoundOpenProc;\r\n    procedure SemiColonProc;\r\n    procedure SlashProc;\r\n    procedure SpaceProc;\r\n    procedure SquareCloseProc;\r\n    procedure SquareOpenProc;\r\n    procedure StarProc;\r\n    procedure StringProc;\r\n    procedure TildeProc;\r\n    procedure XOrSymbolProc;\r\n    procedure UnknownProc;\r\n  protected\r\n    function GetSampleSource: UnicodeString; override;\r\n    function GetExtTokenID: TxtkTokenKind;\r\n    function IsFilterStored: Boolean; override;\r\n  public\r\n    class function GetCapabilities: TSynHighlighterCapabilities; override;\r\n    class function GetLanguageName: string; override;\r\n    class function GetFriendlyLanguageName: UnicodeString; override;\r\n  public\r\n    constructor Create(AOwner: TComponent); override;\r\n    function GetDefaultAttribute(Index: integer): TSynHighlighterAttributes;\r\n      override;\r\n    function GetEol: Boolean; override;\r\n    function GetRange: Pointer; override;\r\n    function GetTokenID: TtkTokenKind;\r\n    function GetTokenAttribute: TSynHighlighterAttributes; override;\r\n    function GetTokenKind: integer; override;\r\n    function IsIdentChar(AChar: WideChar): Boolean; override;\r\n    procedure Next; override;\r\n    procedure SetRange(Value: Pointer); override;\r\n    procedure ResetRange; override;\r\n    procedure EnumUserSettings(settings: TStrings); override;\r\n    property ExtTokenID: TxtkTokenKind read GetExtTokenID;\r\n  published\r\n    property CommentAttri: TSynHighlighterAttributes read fCommentAttri\r\n      write fCommentAttri;\r\n    property IdentifierAttri: TSynHighlighterAttributes read fIdentifierAttri\r\n      write fIdentifierAttri;\r\n    property KeyAttri: TSynHighlighterAttributes read fKeyAttri write fKeyAttri;\r\n    property NumberAttri: TSynHighlighterAttributes read fNumberAttri\r\n      write fNumberAttri;\r\n    property SpaceAttri: TSynHighlighterAttributes read fSpaceAttri\r\n      write fSpaceAttri;\r\n    property StringAttri: TSynHighlighterAttributes read fStringAttri\r\n      write fStringAttri;\r\n    property SymbolAttri: TSynHighlighterAttributes read fSymbolAttri\r\n      write fSymbolAttri;\r\n  end;\r\n\r\nimplementation\r\n\r\nuses\r\n{$IFDEF SYN_CLX}\r\n  QSynEditStrConst;\r\n{$ELSE}\r\n  Windows,\r\n  SynEditStrConst;\r\n{$ENDIF}\r\n\r\nconst\r\n  KeyWords: array[0..23] of UnicodeString = (\r\n    'Bool', 'Char', 'class', 'data', 'deriving', 'Double', 'else', 'False', \r\n    'Float', 'if', 'import', 'in', 'instance', 'Int', 'Integer', 'IO', 'let', \r\n    'module', 'otherwise', 'String', 'then', 'True', 'type', 'where' \r\n  );\r\n\r\n  KeyIndices: array[0..28] of Integer = (\r\n    2, 23, 10, 16, 7, -1, 22, 8, 14, 17, 5, 4, 11, -1, 1, 9, 12, 0, -1, 6, -1, \r\n    3, 15, 18, 20, -1, 13, 19, 21 \r\n  );\r\n\r\n{$Q-}\r\nfunction TSynHaskellSyn.HashKey(Str: PWideChar): Cardinal;\r\nbegin\r\n  Result := 0;\r\n  while IsIdentChar(Str^) do\r\n  begin\r\n    Result := Result * 904 + Ord(Str^) * 779;\r\n    inc(Str);\r\n  end;\r\n  Result := Result mod 29;\r\n  fStringLen := Str - fToIdent;\r\nend;\r\n{$Q+}\r\n\r\nfunction TSynHaskellSyn.IdentKind(MayBe: PWideChar): TtkTokenKind;\r\nvar\r\n  Key: Cardinal;\r\nbegin\r\n  fToIdent := MayBe;\r\n  Key := HashKey(MayBe);\r\n  if Key <= High(fIdentFuncTable) then\r\n    Result := fIdentFuncTable[Key](KeyIndices[Key])\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nprocedure TSynHaskellSyn.InitIdent;\r\nvar\r\n  i: Integer;\r\nbegin\r\n  for i := Low(fIdentFuncTable) to High(fIdentFuncTable) do\r\n    if KeyIndices[i] = -1 then\r\n      fIdentFuncTable[i] := AltFunc;\r\n\r\n  for i := Low(fIdentFuncTable) to High(fIdentFuncTable) do\r\n    if @fIdentFuncTable[i] = nil then\r\n      fIdentFuncTable[i] := KeyWordFunc;\r\nend;\r\n\r\nfunction TSynHaskellSyn.AltFunc(Index: Integer): TtkTokenKind;\r\nbegin\r\n  Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynHaskellSyn.KeyWordFunc(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier\r\nend;\r\n\r\nconstructor TSynHaskellSyn.Create(AOwner: TComponent);\r\nbegin\r\n  inherited Create(AOwner);\r\n\r\n  fCaseSensitive := True;\r\n\r\n  fCommentAttri := TSynHighlighterAttributes.Create(SYNS_AttrComment, SYNS_FriendlyAttrComment);\r\n  fCommentAttri.Style := [fsItalic];\r\n  AddAttribute(fCommentAttri);\r\n  fIdentifierAttri := TSynHighlighterAttributes.Create(SYNS_AttrIdentifier, SYNS_FriendlyAttrIdentifier);\r\n  AddAttribute(fIdentifierAttri);\r\n  fKeyAttri := TSynHighlighterAttributes.Create(SYNS_AttrReservedWord, SYNS_FriendlyAttrReservedWord);\r\n  fKeyAttri.Style:= [fsBold];\r\n  AddAttribute(fKeyAttri);\r\n  fNumberAttri := TSynHighlighterAttributes.Create(SYNS_AttrNumber, SYNS_FriendlyAttrNumber);\r\n  AddAttribute(fNumberAttri);\r\n  fSpaceAttri := TSynHighlighterAttributes.Create(SYNS_AttrSpace, SYNS_FriendlyAttrSpace);\r\n  AddAttribute(fSpaceAttri);\r\n  fStringAttri := TSynHighlighterAttributes.Create(SYNS_AttrString, SYNS_FriendlyAttrString);\r\n  AddAttribute(fStringAttri);\r\n  fSymbolAttri := TSynHighlighterAttributes.Create(SYNS_AttrSymbol, SYNS_FriendlyAttrSymbol);\r\n  AddAttribute(fSymbolAttri);\r\n  SetAttributesOnChange(DefHighlightChange);\r\n  InitIdent;\r\n  fRange := rsUnknown;\r\n  fAsmStart := False;\r\n  fDefaultFilter := SYNS_FilterHaskell;\r\nend; { Create }\r\n\r\nprocedure TSynHaskellSyn.AnsiCProc;\r\nbegin\r\n  fTokenID := tkComment;\r\n  case FLine[Run] of\r\n    #0:\r\n      begin\r\n        NullProc;\r\n        exit;\r\n      end;\r\n    #10:\r\n      begin\r\n        LFProc;\r\n        exit;\r\n      end;\r\n    #13:\r\n      begin\r\n        CRProc;\r\n        exit;\r\n      end;\r\n  end;\r\n\r\n  while FLine[Run] <> #0 do\r\n    case FLine[Run] of\r\n      '*':\r\n        if fLine[Run + 1] = '/' then\r\n        begin\r\n          inc(Run, 2);\r\n          if fRange = rsAnsiCAsm then\r\n            fRange := rsAsm\r\n          else if fRange = rsAnsiCAsmBlock then\r\n            fRange := rsAsmBlock\r\n          else if fRange = rsDirectiveComment then\r\n            fRange := rsDirective\r\n          else\r\n            fRange := rsUnKnown;\r\n          break;\r\n        end else\r\n          inc(Run);\r\n      #10: break;\r\n      #13: break;\r\n    else inc(Run);\r\n    end;\r\nend;\r\n\r\nprocedure TSynHaskellSyn.AndSymbolProc;\r\nbegin\r\n  fTokenID := tkSymbol;\r\n  case FLine[Run + 1] of\r\n    '=':                               {and assign}\r\n      begin\r\n        inc(Run, 2);\r\n        FExtTokenID := xtkAndAssign;\r\n      end;\r\n    '&':                               {logical and}\r\n      begin\r\n        inc(Run, 2);\r\n        FExtTokenID := xtkLogAnd;\r\n      end;\r\n  else                                 {and}\r\n    begin\r\n      inc(Run);\r\n      FExtTokenID := xtkAnd;\r\n    end;\r\n  end;\r\nend;\r\n\r\nprocedure TSynHaskellSyn.AsciiCharProc;\r\nbegin\r\n  fTokenID := tkString;\r\n  repeat\r\n    if fLine[Run] = '\\' then begin\r\n      if CharInSet(fLine[Run + 1], [#39, '\\']) then\r\n        inc(Run);\r\n    end;\r\n    inc(Run);\r\n  until IsLineEnd(Run) or (fLine[Run] = #39);\r\n  if fLine[Run] = #39 then\r\n    inc(Run);\r\nend;\r\n\r\nprocedure TSynHaskellSyn.AtSymbolProc;\r\nbegin\r\n  fTokenID := tkUnknown;\r\n  inc(Run);\r\nend;\r\n\r\nprocedure TSynHaskellSyn.BraceCloseProc;\r\nbegin\r\n  inc(Run);\r\n  fTokenId := tkSymbol;\r\n  FExtTokenID := xtkBraceClose;\r\n  if fRange = rsAsmBlock then fRange := rsUnknown;\r\nend;\r\n\r\nprocedure TSynHaskellSyn.BraceOpenProc;\r\nbegin\r\n  inc(Run);\r\n  fTokenId := tkSymbol;\r\n  FExtTokenID := xtkBraceOpen;\r\n  if fRange = rsAsm then\r\n  begin\r\n    fRange := rsAsmBlock;\r\n    fAsmStart := True;\r\n  end;\r\nend;\r\n\r\nprocedure TSynHaskellSyn.CRProc;\r\nbegin\r\n  fTokenID := tkSpace;\r\n  Inc(Run);\r\n  if fLine[Run + 1] = #10 then Inc(Run);\r\nend;\r\n\r\nprocedure TSynHaskellSyn.ColonProc;\r\nbegin\r\n  fTokenID := tkSymbol;\r\n  Case FLine[Run + 1] of\r\n    ':':                               {scope resolution operator}\r\n      begin\r\n        inc(Run, 2);\r\n        FExtTokenID := xtkScopeResolution;\r\n      end;\r\n  else                                 {colon}\r\n    begin\r\n      inc(Run);\r\n      FExtTokenID := xtkColon;\r\n    end;\r\n  end;\r\nend;\r\n\r\nprocedure TSynHaskellSyn.CommaProc;\r\nbegin\r\n  inc(Run);\r\n  fTokenID := tkSymbol;\r\n  FExtTokenID := xtkComma;\r\nend;\r\n\r\nprocedure TSynHaskellSyn.EqualProc;\r\nbegin\r\n  fTokenID := tkSymbol;\r\n  case FLine[Run + 1] of\r\n    '=':                               {logical equal}\r\n      begin\r\n        inc(Run, 2);\r\n        FExtTokenID := xtkLogEqual;\r\n      end;\r\n  else                                 {assign}\r\n    begin\r\n      inc(Run);\r\n      FExtTokenID := xtkAssign;\r\n    end;\r\n  end;\r\nend;\r\n\r\nprocedure TSynHaskellSyn.GreaterProc;\r\nbegin\r\n  fTokenID := tkSymbol;\r\n  Case FLine[Run + 1] of\r\n    '=':                               {greater than or equal to}\r\n      begin\r\n        inc(Run, 2);\r\n        FExtTokenID := xtkGreaterThanEqual;\r\n      end;\r\n    '>':\r\n      begin\r\n        if FLine[Run + 2] = '=' then   {shift right assign}\r\n        begin\r\n          inc(Run, 3);\r\n          FExtTokenID := xtkShiftRightAssign;\r\n        end\r\n        else                           {shift right}\r\n        begin\r\n          inc(Run, 2);\r\n          FExtTokenID := xtkShiftRight;\r\n        end;\r\n      end;\r\n  else                                 {greater than}\r\n    begin\r\n      inc(Run);\r\n      FExtTokenID := xtkGreaterThan;\r\n    end;\r\n  end;\r\nend;\r\n\r\nprocedure TSynHaskellSyn.QuestionProc;\r\nbegin\r\n  fTokenID := tkSymbol;                {conditional}\r\n  FExtTokenID := xtkQuestion;\r\n  inc(Run);\r\nend;\r\n\r\nprocedure TSynHaskellSyn.IdentProc;\r\nbegin\r\n  fTokenID := IdentKind((fLine + Run));\r\n  inc(Run, fStringLen);\r\n  while IsIdentChar(fLine[Run]) do inc(Run);\r\nend;\r\n\r\nprocedure TSynHaskellSyn.LFProc;\r\nbegin\r\n  fTokenID := tkSpace;\r\n  inc(Run);\r\nend;\r\n\r\nprocedure TSynHaskellSyn.LowerProc;\r\nbegin\r\n  fTokenID := tkSymbol;\r\n  case FLine[Run + 1] of\r\n    '=':                               {less than or equal to}\r\n      begin\r\n        inc(Run, 2);\r\n        FExtTokenID := xtkLessThanEqual;\r\n      end;\r\n    '<':\r\n      begin\r\n        if FLine[Run + 2] = '=' then   {shift left assign}\r\n        begin\r\n          inc(Run, 3);\r\n          FExtTokenID := xtkShiftLeftAssign;\r\n        end\r\n        else                           {shift left}\r\n        begin\r\n          inc(Run, 2);\r\n          FExtTokenID := xtkShiftLeft;\r\n        end;\r\n      end;\r\n  else                                 {less than}\r\n    begin\r\n      inc(Run);\r\n      FExtTokenID := xtkLessThan;\r\n    end;\r\n  end;\r\nend;\r\n\r\nprocedure TSynHaskellSyn.MinusProc;\r\nbegin\r\n  fTokenID := tkSymbol;\r\n  case FLine[Run + 1] of\r\n    '=':                               {subtract assign}\r\n      begin\r\n        inc(Run, 2);\r\n        FExtTokenID := xtkSubtractAssign;\r\n      end;\r\n    '-':                               {decrement}\r\n      begin\r\n        fTokenID := tkComment;\r\n        inc(Run, 2);\r\n        while not IsLineEnd(Run) do Inc(Run);\r\n      end;\r\n    '>':                               {arrow}\r\n      begin\r\n        inc(Run, 2);\r\n        FExtTokenID := xtkArrow;\r\n      end;\r\n  else                                 {subtract}\r\n    begin\r\n      inc(Run);\r\n      FExtTokenID := xtkSubtract;\r\n    end;\r\n  end;\r\nend;\r\n\r\nprocedure TSynHaskellSyn.ModSymbolProc;\r\nbegin\r\n  fTokenID := tkSymbol;\r\n  case FLine[Run + 1] of\r\n    '=':                               {mod assign}\r\n      begin\r\n        inc(Run, 2);\r\n        FExtTokenID := xtkModAssign;\r\n      end;\r\n  else                                 {mod}\r\n    begin\r\n      inc(Run);\r\n      FExtTokenID := xtkMod;\r\n    end;\r\n  end;\r\nend;\r\n\r\nprocedure TSynHaskellSyn.NotSymbolProc;\r\nbegin\r\n  fTokenID := tkSymbol;\r\n  case FLine[Run + 1] of\r\n    '=':                               {not equal}\r\n      begin\r\n        inc(Run, 2);\r\n        FExtTokenID := xtkNotEqual;\r\n      end;\r\n  else                                 {not}\r\n    begin\r\n      inc(Run);\r\n      FExtTokenID := xtkLogComplement;\r\n    end;\r\n  end;\r\nend;\r\n\r\nprocedure TSynHaskellSyn.NullProc;\r\nbegin\r\n  fTokenID := tkNull;\r\n  inc(Run);\r\nend;\r\n\r\nprocedure TSynHaskellSyn.NumberProc;\r\n\r\n  function IsNumberChar: Boolean;\r\n  begin\r\n    case fLine[Run] of\r\n      '0'..'9', 'A'..'F', 'a'..'f', '.', 'u', 'U', 'l', 'L', 'x', 'X':\r\n        Result := True;\r\n      else\r\n        Result := False;\r\n    end;\r\n  end;\r\n\r\nbegin\r\n  inc(Run);\r\n  fTokenID := tkNumber;\r\n  while IsNumberChar do\r\n  begin\r\n    case FLine[Run] of\r\n      '.':\r\n        if FLine[Run + 1] = '.' then break;\r\n    end;\r\n    inc(Run);\r\n  end;\r\nend;\r\n\r\nprocedure TSynHaskellSyn.OrSymbolProc;\r\nbegin\r\n  fTokenID := tkSymbol;\r\n  case FLine[Run + 1] of\r\n    '=':                               {or assign}\r\n      begin\r\n        inc(Run, 2);\r\n        FExtTokenID := xtkIncOrAssign;\r\n      end;\r\n    '|':                               {logical or}\r\n      begin\r\n        inc(Run, 2);\r\n        FExtTokenID := xtkLogOr;\r\n      end;\r\n  else                                 {or}\r\n    begin\r\n      inc(Run);\r\n      FExtTokenID := xtkIncOr;\r\n    end;\r\n  end;\r\nend;\r\n\r\nprocedure TSynHaskellSyn.PlusProc;\r\nbegin\r\n  fTokenID := tkSymbol;\r\n  case FLine[Run + 1] of\r\n    '=':                               {add assign}\r\n      begin\r\n        inc(Run, 2);\r\n        FExtTokenID := xtkAddAssign;\r\n      end;\r\n    '+':                               {increment}\r\n      begin\r\n        inc(Run, 2);\r\n        FExtTokenID := xtkIncrement;\r\n      end;\r\n  else                                 {add}\r\n    begin\r\n      inc(Run);\r\n      FExtTokenID := xtkAdd;\r\n    end;\r\n  end;\r\nend;\r\n\r\nprocedure TSynHaskellSyn.PointProc;\r\nbegin\r\n  fTokenID := tkSymbol;\r\n  if (FLine[Run + 1] = '.') and (FLine[Run + 2] = '.') then\r\n    begin                              {ellipse}\r\n      inc(Run, 3);\r\n      FExtTokenID := xtkEllipse;\r\n    end\r\n  else                                 {point}\r\n    begin\r\n      inc(Run);\r\n      FExtTokenID := xtkPoint;\r\n    end;\r\nend;\r\n\r\nprocedure TSynHaskellSyn.RoundCloseProc;\r\nbegin\r\n  inc(Run);\r\n  fTokenID := tkSymbol;\r\n  FExtTokenID := xtkRoundClose;\r\nend;\r\n\r\nprocedure TSynHaskellSyn.RoundOpenProc;\r\nbegin\r\n  inc(Run);\r\n  FTokenID := tkSymbol;\r\n  FExtTokenID := xtkRoundOpen;\r\nend;\r\n\r\nprocedure TSynHaskellSyn.SemiColonProc;\r\nbegin\r\n  inc(Run);\r\n  fTokenID := tkSymbol;\r\n  FExtTokenID := xtkSemiColon;\r\n  if fRange = rsAsm then fRange := rsUnknown;\r\nend;\r\n\r\nprocedure TSynHaskellSyn.SlashProc;\r\nbegin\r\n  case FLine[Run + 1] of\r\n    '=':                               {divide assign}\r\n      begin\r\n        inc(Run, 2);\r\n        fTokenID := tkSymbol;\r\n        FExtTokenID := xtkDivideAssign;\r\n      end;\r\n  else                                 {divide}\r\n    begin\r\n      inc(Run);\r\n      fTokenID := tkSymbol;\r\n      FExtTokenID := xtkDivide;\r\n    end;\r\n  end;\r\nend;\r\n\r\nprocedure TSynHaskellSyn.SpaceProc;\r\nbegin\r\n  inc(Run);\r\n  fTokenID := tkSpace;\r\n  while (FLine[Run] <= #32) and not IsLineEnd(Run) do inc(Run);\r\nend;\r\n\r\nprocedure TSynHaskellSyn.SquareCloseProc;\r\nbegin\r\n  inc(Run);\r\n  fTokenID := tkSymbol;\r\n  FExtTokenID := xtkSquareClose;\r\nend;\r\n\r\nprocedure TSynHaskellSyn.SquareOpenProc;\r\nbegin\r\n  inc(Run);\r\n  fTokenID := tkSymbol;\r\n  FExtTokenID := xtkSquareOpen;\r\nend;\r\n\r\nprocedure TSynHaskellSyn.StarProc;\r\nbegin\r\n  fTokenID := tkSymbol;\r\n  case FLine[Run + 1] of\r\n    '=':                               {multiply assign}\r\n      begin\r\n        inc(Run, 2);\r\n        FExtTokenID := xtkMultiplyAssign;\r\n      end;\r\n  else                                 {star}\r\n    begin\r\n      inc(Run);\r\n      FExtTokenID := xtkStar;\r\n    end;\r\n  end;\r\nend;\r\n\r\nprocedure TSynHaskellSyn.StringProc;\r\nbegin\r\n  fTokenID := tkString;\r\n  repeat\r\n    if fLine[Run] = '\\' then begin\r\n      if CharInSet(fLine[Run + 1], [#34, '\\']) then\r\n        Inc(Run);\r\n    end;\r\n    inc(Run);\r\n  until IsLineEnd(Run) or (fLine[Run] = #34);\r\n  if FLine[Run] = #34 then\r\n    inc(Run);\r\nend;\r\n\r\nprocedure TSynHaskellSyn.TildeProc;\r\nbegin\r\n  inc(Run);                            {bitwise complement}\r\n  fTokenId := tkSymbol;\r\n  FExtTokenID := xtkBitComplement;\r\nend;\r\n\r\nprocedure TSynHaskellSyn.XOrSymbolProc;\r\nbegin\r\n  fTokenID := tkSymbol;\r\n  Case FLine[Run + 1] of\r\n    '=':                               {xor assign}\r\n      begin\r\n        inc(Run, 2);\r\n        FExtTokenID := xtkXorAssign;\r\n      end;\r\n  else                                 {xor}\r\n    begin\r\n      inc(Run);\r\n      FExtTokenID := xtkXor;\r\n    end;\r\n  end;\r\nend;\r\n\r\nprocedure TSynHaskellSyn.UnknownProc;\r\nbegin\r\n  inc(Run);\r\n  fTokenID := tkUnknown;\r\nend;\r\n\r\nprocedure TSynHaskellSyn.Next;\r\nbegin\r\n  fAsmStart := False;\r\n  fTokenPos := Run;\r\n  case fRange of\r\n    rsAnsiC, rsAnsiCAsm,\r\n    rsAnsiCAsmBlock: AnsiCProc;\r\n  else\r\n    begin\r\n      fRange := rsUnknown;\r\n      case fLine[Run] of\r\n        '&': AndSymbolProc;\r\n        #39: AsciiCharProc;\r\n        '@': AtSymbolProc;\r\n        '}': BraceCloseProc;\r\n        '{': BraceOpenProc;\r\n        #13: CRProc;\r\n        ':': ColonProc;\r\n        ',': CommaProc;\r\n        '=': EqualProc;\r\n        '>': GreaterProc;\r\n        '?': QuestionProc;\r\n        'A'..'Z', 'a'..'z', '_': IdentProc;\r\n        #10: LFProc;\r\n        '<': LowerProc;\r\n        '-': MinusProc;\r\n        '%': ModSymbolProc;\r\n        '!': NotSymbolProc;\r\n        #0: NullProc;\r\n        '0'..'9': NumberProc;\r\n        '|': OrSymbolProc;\r\n        '+': PlusProc;\r\n        '.': PointProc;\r\n        ')': RoundCloseProc;\r\n        '(': RoundOpenProc;\r\n        ';': SemiColonProc;\r\n        '/': SlashProc;\r\n        #1..#9, #11, #12, #14..#32: SpaceProc;\r\n        ']': SquareCloseProc;\r\n        '[': SquareOpenProc;\r\n        '*': StarProc;\r\n        #34: StringProc;\r\n        '~': TildeProc;\r\n        '^': XOrSymbolProc;\r\n        else UnknownProc;\r\n      end;\r\n    end;\r\n  end;\r\n  inherited;\r\nend;\r\n\r\nfunction TSynHaskellSyn.GetDefaultAttribute(Index: integer): TSynHighlighterAttributes;\r\nbegin\r\n  case Index of\r\n    SYN_ATTR_COMMENT: Result := fCommentAttri;\r\n    SYN_ATTR_IDENTIFIER: Result := fIdentifierAttri;\r\n    SYN_ATTR_KEYWORD: Result := fKeyAttri;\r\n    SYN_ATTR_STRING: Result := fStringAttri;\r\n    SYN_ATTR_WHITESPACE: Result := fSpaceAttri;\r\n    else Result := nil;\r\n  end;\r\nend;\r\n\r\nfunction TSynHaskellSyn.GetEol: Boolean;\r\nbegin\r\n  Result := Run = fLineLen + 1;\r\nend;\r\n\r\nfunction TSynHaskellSyn.GetRange: Pointer;\r\nbegin\r\n  Result := Pointer(fRange);\r\nend;\r\n\r\nfunction TSynHaskellSyn.GetTokenID: TtkTokenKind;\r\nbegin\r\n  Result := fTokenId;\r\nend;\r\n\r\nfunction TSynHaskellSyn.GetExtTokenID: TxtkTokenKind;\r\nbegin\r\n  Result := FExtTokenID;\r\nend;\r\n\r\nfunction TSynHaskellSyn.GetTokenAttribute: TSynHighlighterAttributes;\r\nbegin\r\n  case fTokenID of\r\n    tkComment: Result := fCommentAttri;\r\n    tkIdentifier: Result := fIdentifierAttri;\r\n    tkKey: Result := fKeyAttri;\r\n    tkNumber: Result := fNumberAttri;\r\n    tkSpace: Result := fSpaceAttri;\r\n    tkString: Result := fStringAttri;\r\n    tkSymbol: Result := fSymbolAttri;\r\n    else Result := nil;\r\n  end;\r\nend;\r\n\r\nfunction TSynHaskellSyn.GetTokenKind: integer;\r\nbegin\r\n  Result := Ord(GetTokenID);\r\nend;\r\n\r\nprocedure TSynHaskellSyn.ResetRange;\r\nbegin\r\n  fRange:= rsUnknown;\r\nend;\r\n\r\nprocedure TSynHaskellSyn.SetRange(Value: Pointer);\r\nbegin\r\n  fRange := TRangeState(Value);\r\nend;\r\n\r\nprocedure TSynHaskellSyn.EnumUserSettings(settings: TStrings);\r\nbegin\r\n  {$IFNDEF SYN_CLX}\r\n  { returns the user settings that exist in the registry }\r\n  with TBetterRegistry.Create do\r\n  begin\r\n    try\r\n      RootKey := HKEY_LOCAL_MACHINE;\r\n      if OpenKeyReadOnly('\\SOFTWARE\\Borland\\C++Builder') then\r\n      begin\r\n        try\r\n          GetKeyNames(settings);\r\n        finally\r\n          CloseKey;\r\n        end;\r\n      end;\r\n    finally\r\n      Free;\r\n    end;\r\n  end;\r\n  {$ENDIF}\r\nend;\r\n\r\nfunction TSynHaskellSyn.IsFilterStored: Boolean;\r\nbegin\r\n  Result := fDefaultFilter <> SYNS_FilterHaskell;\r\nend;\r\n\r\nfunction TSynHaskellSyn.IsIdentChar(AChar: WideChar): Boolean;\r\nbegin\r\n  case AChar of\r\n    '_', '0'..'9', 'a'..'z', 'A'..'Z', #39:\r\n      Result := True;\r\n    else\r\n      Result := False;\r\n  end;\r\nend;\r\n\r\nclass function TSynHaskellSyn.GetLanguageName: string;\r\nbegin\r\n  Result := SYNS_LangHaskell;\r\nend;\r\n\r\nclass function TSynHaskellSyn.GetCapabilities: TSynHighlighterCapabilities;\r\nbegin\r\n  Result := inherited GetCapabilities + [hcUserSettings];\r\nend;\r\n\r\nfunction TSynHaskellSyn.GetSampleSource: UnicodeString;\r\nbegin\r\n  Result := '-- Haskell Sample Source'#13#10 +\r\n            'tail :: [a] -> [a]'#13#10 +\r\n            'tail (x:xs) = xs'#13#10 +\r\n            '';\r\nend;\r\n\r\nclass function TSynHaskellSyn.GetFriendlyLanguageName: UnicodeString;\r\nbegin\r\n  Result := SYNS_FriendlyLangHaskell;\r\nend;\r\n\r\ninitialization\r\n{$IFNDEF SYN_CPPB_1}\r\n  RegisterPlaceableHighlighter(TSynHaskellSyn);\r\n{$ENDIF}\r\nend.\r\n"
  },
  {
    "path": "External/SynEdit/Source/SynHighlighterHtml.pas",
    "content": "{-------------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: SynHighlighterHTML.pas, released 2000-04-10.\r\nThe Original Code is based on the hkHTMLSyn.pas file from the\r\nmwEdit component suite by Martin Waldenburg and other developers, the Initial\r\nAuthor of this file is Hideo Koiso.\r\nUnicode translation by Mal Hrz.\r\nHTML5 tags added by CodehunterWorks\r\nAll Rights Reserved.\r\n\r\nContributors to the SynEdit and mwEdit projects are listed in the\r\nContributors.txt file.\r\n\r\nAlternatively, the contents of this file may be used under the terms of the\r\nGNU General Public License Version 2 or later (the \"GPL\"), in which case\r\nthe provisions of the GPL are applicable instead of those above.\r\nIf you wish to allow use of your version of this file only under the terms\r\nof the GPL and not to allow others to use your version of this file\r\nunder the MPL, indicate your decision by deleting the provisions above and\r\nreplace them with the notice and other provisions required by the GPL.\r\nIf you do not delete the provisions above, a recipient may use your version\r\nof this file under either the MPL or the GPL.\r\n\r\n$Id: SynHighlighterHtml.pas,v 1.24.3 2012/09/13 12:05:00 codehunterworks Exp $\r\n\r\nYou may retrieve the latest version of this file at the SynEdit home page,\r\nlocated at http://SynEdit.SourceForge.net\r\n\r\nKnown Issues:\r\n-------------------------------------------------------------------------------}\r\n{\r\n@abstract(Provides an HTML highlighter for SynEdit)\r\n@author(Hideo Koiso, converted to SynEdit by Michael Hieke)\r\n@created(1999-11-02, converted to SynEdit 2000-04-10)\r\n@lastmod(2012-09-13)\r\nThe SynHighlighterHTML unit provides SynEdit with an HTML highlighter.\r\n}\r\n\r\n{$IFNDEF QSYNHIGHLIGHTERHTML}\r\nunit SynHighlighterHtml;\r\n{$ENDIF}\r\n\r\ninterface\r\n\r\n{$I SynEdit.inc}\r\n\r\nuses\r\n{$IFDEF UNICODE}\r\n  WideStrUtils,\r\n{$ENDIF}\r\n{$IFDEF SYN_CLX}\r\n  QGraphics,\r\n  QSynEditTypes,\r\n  QSynEditHighlighter,\r\n  QSynUnicode,\r\n{$ELSE}\r\n  Graphics,\r\n  SynEditTypes,\r\n  SynEditHighlighter,\r\n  SynUnicode,\r\n{$ENDIF}\r\n  SysUtils,\r\n  Classes;\r\n\r\nconst\r\n  MAX_ESCAPEAMPS = 249;\r\n\r\n  EscapeAmps: array[0..MAX_ESCAPEAMPS - 1] of PWideChar = (\r\n    ('Α'),         { ?        }  { greek capital alpha }\r\n    ('Β'),          { ?        }  { greek capital beta }\r\n    ('Γ'),         { G        }  { greek capital gamma }\r\n    ('Δ'),         { ?        }  { greek capital delta }\r\n    ('Ε'),       { ?        }  { greek capital epsilon }\r\n    ('Ζ'),          { ?        }  { greek capital zeta }\r\n    ('Η'),           { ?        }  { greek capital eta }\r\n    ('Θ'),         { T        }  { greek capital theta }\r\n    ('Ι'),          { ?        }  { greek capital iota }\r\n    ('Κ'),         { ?        }  { greek capital kappa }\r\n    ('Λ'),        { ?        }  { greek capital lambda }\r\n    ('Μ'),            { ?        }  { greek capital mu }\r\n    ('Ν'),            { ?        }  { greek capital nu }\r\n    ('Ξ'),            { ?        }  { greek capital xi }\r\n    ('Ο'),       { ?        }  { greek capital omicron }\r\n    ('Π'),            { ?        }  { greek capital pi }\r\n    ('Ρ'),           { ?        }  { greek capital rho }\r\n    ('Σ'),         { S        }  { greek capital sigma }\r\n    ('Τ'),           { ?        }  { greek capital tau }\r\n    ('Υ'),       { ?        }  { greek capital upsilon }\r\n    ('Φ'),           { F        }  { greek capital phi }\r\n    ('Χ'),           { ?        }  { greek capital chi }\r\n    ('Ψ'),           { ?        }  { greek capital psi }\r\n    ('Ω'),         { O        }  { greek capital omega }\r\n    ('α'),         { a        }  { greek small alpha }\r\n    ('β'),          {         }  { greek small beta }\r\n    ('γ'),         { ?        }  { greek small gamma }\r\n    ('δ'),         { d        }  { greek small delta }\r\n    ('ε'),       { e        }  { greek small epsilon }\r\n    ('ζ'),          { ?        }  { greek small zeta }\r\n    ('η'),           { ?        }  { greek small eta }\r\n    ('θ'),         { ?        }  { greek small theta }\r\n    ('ι'),          { ?        }  { greek small iota }\r\n    ('κ'),         { ?        }  { greek small kappa }\r\n    ('λ'),        { ?        }  { greek small lambda }\r\n    ('μ'),            {         }  { greek small mu }\r\n    ('ν'),            { ?        }  { greek small nu }\r\n    ('ξ'),            { ?        }  { greek small xi }\r\n    ('ο'),       { ?        }  { greek small omicron }\r\n    ('π'),            { p        }  { greek small pi }\r\n    ('ρ'),           { ?        }  { greek small rho }\r\n    ('ς'),        { ?        }  { greek small final sigma }\r\n    ('σ'),         { s        }  { greek small sigma }\r\n    ('τ'),           { t        }  { greek small tau }\r\n    ('υ'),       { ?        }  { greek small upsilon }\r\n    ('φ'),           { f        }  { greek small phi }\r\n    ('χ'),           { ?        }  { greek small chi }\r\n    ('ψ'),           { ?        }  { greek small psi }\r\n    ('ω'),         { ?        }  { greek small omega }\r\n    ('ϑ'),      { ?        }  { greek small theta symbol }\r\n    ('ϒ'),         { ?        }  { greek upsilon with hook symbol }\r\n    ('ϖ'),           { ?        }  { greek pi symbol }\r\n    ('•'),          {         }  { bullet }\r\n    ('…'),        {         }  { horizontal ellipsis }\r\n    ('′'),         { '        }  { prime }\r\n    ('″'),         { \"        }  { double prime }\r\n    ('‾'),         { ?        }  { overline, = spacing overscore }\r\n    ('⁄'),         { /        }  { fraction slash }\r\n    ('℘'),        { P        }  { script capital P }\r\n    ('ℑ'),         { I        }  { imaginary part }\r\n    ('ℜ'),          { R        }  { real part }\r\n    ('™'),         {         }  { trademark sign }\r\n    ('ℵ'),       { ?        }  { first transfinite cardinal }\r\n    ('←'),          { ?        }  { leftwards arrow }\r\n    ('↑'),          { ?        }  { upwards arrow }\r\n    ('→'),          { ?        }  { rightwards arrow }\r\n    ('↓'),          { ?        }  { downwards arrow }\r\n    ('↔'),          { ?        }  { left right arrow }\r\n    ('↵'),         { ?        }  { carriage return arrow }\r\n    ('⇐'),          { ?        }  { leftwards double arrow }\r\n    ('⇑'),          { ?        }  { upwards double arrow }\r\n    ('⇒'),          { ?        }  { rightwards double arrow }\r\n    ('⇓'),          { ?        }  { downwards double arrow }\r\n    ('⇔'),          { ?        }  { left right double arrow }\r\n    ('∀'),        { ?        }  { for all }\r\n    ('∂'),          { ?        }  { partial differential }\r\n    ('∃'),         { ?        }  { there exists }\r\n    ('∅'),         {         }  { empty set }\r\n    ('∇'),         { ?        }  { backward difference }\r\n    ('∈'),          { ?        }  { element of }\r\n    ('∉'),         { ?        }  { not an element of }\r\n    ('∋'),            { ?        }  { contains as member }\r\n    ('∏'),          { ?        }  { n-ary product }\r\n    ('∑'),           { ?        }  { n-ary sumation }\r\n    ('−'),         { -        }  { minus sign }\r\n    ('∗'),        { *        }  { asterisk operator }\r\n    ('√'),         { v        }  { square root }\r\n    ('∝'),          { ?        }  { proportional to }\r\n    ('∞'),         { 8        }  { infinity }\r\n    ('∠'),           { ?        }  { angle }\r\n    ('∧'),           { ?        }  { logical and }\r\n    ('∨'),            { ?        }  { logical or }\r\n    ('∩'),           { n        }  { intersection }\r\n    ('∪'),           { ?        }  { union }\r\n    ('∫'),           { ?        }  { integral }\r\n    ('∴'),        { ?        }  { therefore }\r\n    ('∼'),           { ~        }  { similar to = tilde operator }\r\n    ('≅'),          { ?        }  { approximately equal to }\r\n    ('≈'),         {         }  { almost euqal to }\r\n    ('≠'),            { ?        }  { not equal to }\r\n    ('≡'),         { =        }  { identical to }\r\n    ('≤'),            { =        }  { less-than or equal to }\r\n    ('≥'),            { =        }  { greater-than or equal to }\r\n    ('⊂'),           { ?        }  { subset of }\r\n    ('⊃'),           { ?        }  { superset of }\r\n    ('⊄'),          { ?        }  { not a subset of }\r\n    ('⊆'),          { ?        }  { subset of or equal to }\r\n    ('⊇'),          { ?        }  { superset of or equal to }\r\n    ('⊕'),         { ?        }  { circled plus }\r\n    ('⊗'),        { ?        }  { circled times }\r\n    ('⊥'),          { ?        }  { orthogonal to = perpendicular }\r\n    ('⋅'),          {         }  { dot operator }\r\n    ('⌈'),         { ?        }  { left ceiling }\r\n    ('⌉'),         { ?        }  { right ceiling }\r\n    ('⌊'),        { ?        }  { left floor }\r\n    ('⌋'),        { ?        }  { right floor }\r\n    ('⟨'),          { <        }  { left-pointing angle bracket }\r\n    ('⟩'),          { >        }  { right-pointing angle bracket }\r\n    ('◊'),           { ?        }  { lozenge }\r\n    ('♠'),        { ?        }  { black spade suit }\r\n    ('♣'),         { ?        }  { black club suit }\r\n    ('♥'),        { ?        }  { black heart suit }\r\n    ('♦'),         { ?        }  { black diamond suit }\r\n    ('‘'),         {         }  { left single quote  }\r\n    ('’'),         {         }  { right single quote }\r\n    ('‚'),         {         }  { single low-9 quote }\r\n    ('“'),         {         }  { left double quote }\r\n    ('”'),         {         }  { right double quote }\r\n    ('„'),         {         }  { double low-9 quote }\r\n    ('†'),        {         }  { dagger }\r\n    ('‡'),        {         }  { double dagger }\r\n    ('‰'),        {         }  { per mill sign }\r\n    ('‹'),        {         }  { single left-pointing angle quote }\r\n    ('›'),        {         }  { single right-pointing angle quote }\r\n    ('"'),          { " \" }  { double quotation mark }\r\n    ('&'),           { & & }  { ampersand }\r\n    ('<'),            { < < }  { less-than sign }\r\n    ('>'),            { >        }  { greater-than sign }\r\n    ('–'),         { –  }  { en dash }\r\n    ('—'),         { —  }  { em dash }\r\n    (' '),          {     }  { nonbreaking space }\r\n    (' '),        {          }  { thin space }\r\n    (' '),          {          }  { en space }\r\n    (' '),          {          }  { em space }\r\n    ('¡'),         { ¡ ! }  { inverted exclamation }\r\n    ('¢'),          { ¢ c }  { cent sign }\r\n    ('£'),         { £ L }  { pound sterling }\r\n    ('¤'),        { ¤  }  { general currency sign }\r\n    ('¥'),           { ¥ Y }  { yen sign }\r\n    ('¦'),        { ¦  }  { broken vertical bar }\r\n    ('&brkbar;'),        { ¦  }  { broken vertical bar }\r\n    ('§'),          { §  }  { section sign }\r\n    ('¨'),           { ¨  }  { umlaut }\r\n    ('¨'),           { ¨  }  { umlaut }\r\n    ('©'),          { ©  }  { copyright }\r\n    ('ª'),          { ª a }  { feminine ordinal }\r\n    ('«'),         { «  }  { left angle quote }\r\n    ('¬'),           { ¬  }  { not sign }\r\n    ('­'),           { ­  }  { soft hyphen }\r\n    ('®'),           { ®  }  { registered trademark }\r\n    ('¯'),          { ¯  }  { macron accent }\r\n    ('&hibar;'),         { ¯  }  { macron accent }\r\n    ('°'),           { °  }  { degree sign }\r\n    ('±'),        { ±  }  { plus or minus }\r\n    ('²'),          { ² 2 }  { superscript two }\r\n    ('³'),          { ³ 3 }  { superscript three }\r\n    ('´'),         { ´  }  { acute accent }\r\n    ('µ'),         { µ  }  { micro sign }\r\n    ('¶'),          { ¶  }  { paragraph sign }\r\n    ('·'),        { ·  }  { middle dot }\r\n    ('¸'),         { ¸  }  { cedilla }\r\n    ('¹'),          { ¹ 1 }  { superscript one }\r\n    ('º'),          { º o }  { masculine ordinal }\r\n    ('»'),         { »  }  { right angle quote }\r\n    ('¼'),        { ¼ 1 }  { one-fourth }\r\n    ('½'),        { ½ 1 }  { one-half }\r\n    ('¾'),        { ¾ 3 }  { three-fourths }\r\n    ('¿'),        { ¿ ? }  { inverted question mark }\r\n    ('À'),        { À A }  { uppercase A, grave accent }\r\n    ('Á'),        { Á  }  { uppercase A, acute accent }\r\n    ('Â'),         {   }  { uppercase A, circumflex accent }\r\n    ('Ã'),        { à A }  { uppercase A, tilde }\r\n    ('Ä'),          { Ä  }  { uppercase A, umlaut }\r\n    ('Å'),         { Å A }  { uppercase A, ring }\r\n    ('Æ'),         { Æ A }  { uppercase AE }\r\n    ('Ç'),        { Ç  }  { uppercase C, cedilla }\r\n    ('È'),        { È E }  { uppercase E, grave accent }\r\n    ('É'),        { É  }  { uppercase E, acute accent }\r\n    ('Ê'),         { Ê E }  { uppercase E, circumflex accent }\r\n    ('Ë'),          { Ë  }  { uppercase E, umlaut }\r\n    ('Ì'),        { Ì I }  { uppercase I, grave accent }\r\n    ('Í'),        { Í  }  { uppercase I, acute accent }\r\n    ('Î'),         { Î  }  { uppercase I, circumflex accent }\r\n    ('Ï'),          { Ï I }  { uppercase I, umlaut }\r\n    ('Ð'),           { Ð ? }  { uppercase Eth, Icelandic }\r\n    ('Ñ'),        { Ñ N }  { uppercase N, tilde }\r\n    ('Ò'),        { Ò O }  { uppercase O, grave accent }\r\n    ('Ó'),        { Ó  }  { uppercase O, acute accent }\r\n    ('Ô'),         { Ô  }  { uppercase O, circumflex accent }\r\n    ('Õ'),        { Õ O }  { uppercase O, tilde }\r\n    ('Ö'),          { Ö  }  { uppercase O, umlaut }\r\n    ('×'),         { ×  }  { multiplication sign }\r\n    ('Ø'),        { Ø O }  { uppercase O, slash }\r\n    ('Ù'),        { Ù U }  { uppercase U, grave accent }\r\n    ('Ú'),        { Ú  }  { uppercase U, acute accent }\r\n    ('Û'),         { Û U }  { uppercase U, circumflex accent }\r\n    ('Ü'),          { Ü  }  { uppercase U, umlaut }\r\n    ('Ý'),        { Ý  }  { uppercase Y, acute accent }\r\n    ('Þ'),         { Þ ? }  { uppercase THORN, Icelandic }\r\n    ('ß'),         { ß  }  { lowercase sharps, German }\r\n    ('à'),        { à  }  { lowercase a, grave accent }\r\n    ('á'),        { á  }  { lowercase a, acute accent }\r\n    ('â'),         { â  }  { lowercase a, circumflex accent }\r\n    ('ã'),        { ã  }  { lowercase a, tilde }\r\n    ('ä'),          { ä  }  { lowercase a, umlaut }\r\n    ('å'),         { å  }  { lowercase a, ring }\r\n    ('æ'),         { æ a }  { lowercase ae }\r\n    ('ç'),        { ç  }  { lowercase c, cedilla }\r\n    ('è'),        { è e }  { lowercase e, grave accent }\r\n    ('é'),        { é  }  { lowercase e, acute accent }\r\n    ('ê'),         { ê  }  { lowercase e, circumflex accent }\r\n    ('ë'),          { ë  }  { lowercase e, umlaut }\r\n    ('ì'),        { ì i }  { lowercase i, grave accent }\r\n    ('í'),        { í  }  { lowercase i, acute accent }\r\n    ('î'),         { î  }  { lowercase i, circumflex accent }\r\n    ('ï'),          { ï i }  { lowercase i, umlaut }\r\n    ('ð'),           { ð ? }  { lowercase eth, Icelandic }\r\n    ('ñ'),        { ñ  }  { lowercase n, tilde }\r\n    ('ò'),        { ò o }  { lowercase o, grave accent }\r\n    ('ó'),        { ó  }  { lowercase o, acute accent }\r\n    ('ô'),         { ô  }  { lowercase o, circumflex accent }\r\n    ('õ'),        { õ o }  { lowercase o, tilde }\r\n    ('ö'),          { ö  }  { lowercase o, umlaut }\r\n    ('÷'),        { ÷  }  { division sign }\r\n    ('ø'),        { ø o }  { lowercase o, slash }\r\n    ('ù'),        { ù u }  { lowercase u, grave accent }\r\n    ('ú'),        { ú  }  { lowercase u, acute accent }\r\n    ('û'),         { û u }  { lowercase u, circumflex accent }\r\n    ('ü'),          { ü  }  { lowercase u, umlaut }\r\n    ('ý'),        { ý  }  { lowercase y, acute accent }\r\n    ('þ'),         { þ ? }  { lowercase thorn, Icelandic }\r\n    ('ÿ'),          { ÿ y }  { lowercase y, umlaut }\r\n    ('€'),          {         }  { euro sign }\r\n    ('Œ'),         {         }  { capital ligature OE }\r\n    ('œ'),         {         }  { small ligature oe }\r\n    ('š'),        {         }  { small S with caron }\r\n    ('Š'),        {         }  { capital S with caron }\r\n    ('ƒ'),          {         }  { function }\r\n    ('ˆ')           {         }  { circumflex accent }\r\n  );\r\n\r\n\r\ntype\r\n  TtkTokenKind = (tkAmpersand, tkComment, tkIdentifier, tkKey, tkNull,\r\n    tkSpace, tkSymbol, tkText, tkUndefKey, tkValue);\r\n\r\n  TRangeState = (rsAmpersand, rsComment, rsKey, rsParam, rsText,\r\n    rsUnKnown, rsValue, rsQuoteValue, rsDoubleQuoteValue);\r\n\r\n  PIdentFuncTableFunc = ^TIdentFuncTableFunc;\r\n  TIdentFuncTableFunc = function (Index: Integer): TtkTokenKind of object;\r\n\r\n  TSynHTMLSyn = class(TSynCustomHighlighter)\r\n  private\r\n    fAndCode: Integer;\r\n    fRange: TRangeState;\r\n//    fIdentFuncTable: array[0..1542] of TIdentFuncTableFunc;\r\n    fIdentFuncTable: array[0..2178] of TIdentFuncTableFunc;\r\n    fTokenID: TtkTokenKind;\r\n    fAndAttri: TSynHighlighterAttributes;\r\n    fCommentAttri: TSynHighlighterAttributes;\r\n    fIdentifierAttri: TSynHighlighterAttributes;\r\n    fKeyAttri: TSynHighlighterAttributes;\r\n    fSpaceAttri: TSynHighlighterAttributes;\r\n    fSymbolAttri: TSynHighlighterAttributes;\r\n    fTextAttri: TSynHighlighterAttributes;\r\n    fUndefKeyAttri: TSynHighlighterAttributes;\r\n    fValueAttri: TSynHighlighterAttributes;\r\n    function AltFunc(Index: Integer): TtkTokenKind;\r\n    function KeyWordFunc(Index: Integer): TtkTokenKind;\r\n    function HashKey(Str: PWideChar): Cardinal;\r\n    function IdentKind(MayBe: PWideChar): TtkTokenKind;\r\n    procedure InitIdent;\r\n    procedure TextProc;\r\n    procedure CommentProc;\r\n    procedure BraceCloseProc;\r\n    procedure BraceOpenProc;\r\n    procedure CRProc;\r\n    procedure EqualProc;\r\n    procedure IdentProc;\r\n    procedure LFProc;\r\n    procedure NullProc;\r\n    procedure SpaceProc;\r\n    procedure StringProc;\r\n    procedure AmpersandProc;\r\n  protected\r\n    function GetSampleSource: UnicodeString; override;\r\n    function IsFilterStored: Boolean; override;\r\n    procedure NextProcedure;\r\n  public\r\n    class function GetLanguageName: string; override;\r\n    class function GetFriendlyLanguageName: UnicodeString; override;\r\n  public\r\n    constructor Create(AOwner: TComponent); override;\r\n    function GetDefaultAttribute(Index: integer): TSynHighlighterAttributes;\r\n      override;\r\n    function GetEol: Boolean; override;\r\n    function GetRange: Pointer; override;\r\n    function GetTokenID: TtkTokenKind;\r\n    function GetTokenAttribute: TSynHighlighterAttributes; override;\r\n    function GetTokenKind: Integer; override;\r\n    function IsIdentChar(AChar: WideChar): Boolean; override;\r\n    procedure Next; override;\r\n    procedure SetRange(Value: Pointer); override;\r\n    procedure ResetRange; override;\r\n  published\r\n    property AndAttri: TSynHighlighterAttributes read fAndAttri write fAndAttri;\r\n    property CommentAttri: TSynHighlighterAttributes read fCommentAttri\r\n      write fCommentAttri;\r\n    property IdentifierAttri: TSynHighlighterAttributes read fIdentifierAttri\r\n      write fIdentifierAttri;\r\n    property KeyAttri: TSynHighlighterAttributes read fKeyAttri write fKeyAttri;\r\n    property SpaceAttri: TSynHighlighterAttributes read fSpaceAttri\r\n      write fSpaceAttri;\r\n    property SymbolAttri: TSynHighlighterAttributes read fSymbolAttri\r\n      write fSymbolAttri;\r\n    property TextAttri: TSynHighlighterAttributes read fTextAttri\r\n      write fTextAttri;\r\n    property UndefKeyAttri: TSynHighlighterAttributes read fUndefKeyAttri\r\n      write fUndefKeyAttri;\r\n    property ValueAttri: TSynHighlighterAttributes read fValueAttri\r\n      write fValueAttri;\r\n  end;\r\n\r\nimplementation\r\n\r\nuses\r\n{$IFDEF SYN_CLX}\r\n  QSynEditStrConst;\r\n{$ELSE}\r\n  SynEditStrConst;\r\n{$ENDIF}\r\n\r\nconst\r\n//  KeyWords: array[0..201] of UnicodeString = (\r\n//    '!doctype', '/a', '/abbr', '/acronym', '/address', '/applet', '/b', '/bdo',\r\n//    '/big', '/blink', '/blockquote', '/body', '/button', '/caption', '/center',\r\n//    '/cite', '/code', '/colgroup', '/comment', '/dd', '/del', '/dfn', '/dir',\r\n//    '/div', '/dl', '/dt', '/em', '/embed', '/fieldset', '/font', '/form',\r\n//    '/frameset', '/h1', '/h2', '/h3', '/h4', '/h5', '/h6', '/head', '/html',\r\n//    '/i', '/iframe', '/ilayer', '/ins', '/kbd', '/label', '/layer', '/legend',\r\n//    '/li', '/listing', '/map', '/marquee', '/menu', '/multicol', '/nobr',\r\n//    '/noembed', '/noframes', '/nolayer', '/noscript', '/object', '/ol',\r\n//    '/optgroup', '/option', '/p', '/pre', '/q', '/s', '/samp', '/script',\r\n//    '/select', '/server', '/small', '/span', '/strike', '/strong', '/style',\r\n//    '/sub', '/sup', '/table', '/tbody', '/td', '/textarea', '/tfoot', '/th',\r\n//    '/thead', '/title', '/tr', '/tt', '/u', '/ul', '/var', '/xmp', 'a', 'abbr',\r\n//    'acronym', 'address', 'applet', 'area', 'b', 'base', 'basefont', 'bdo',\r\n//    'bgsound', 'big', 'blink', 'blockquote', 'body', 'br', 'button', 'caption',\r\n//    'center', 'cite', 'code', 'col', 'colgroup', 'comment', 'dd', 'del', 'dfn',\r\n//    'dir', 'div', 'dl', 'dt', 'em', 'embed', 'fieldset', 'font', 'form',\r\n//    'frame', 'frameset', 'h1', 'h2', 'h3', 'h4', 'h5', 'h6', 'head', 'hr',\r\n//    'html', 'i', 'iframe', 'ilayer', 'img', 'input', 'ins', 'isindex', 'kbd',\r\n//    'keygen', 'label', 'layer', 'legend', 'li', 'link', 'listing', 'map',\r\n//    'marquee', 'menu', 'meta', 'multicol', 'nextid', 'nobr', 'noembed',\r\n//    'noframes', 'nolayer', 'noscript', 'object', 'ol', 'optgroup', 'option',\r\n//    'p', 'param', 'plaintext', 'pre', 'q', 's', 'samp', 'script', 'select',\r\n//    'server', 'small', 'spacer', 'span', 'strike', 'strong', 'style', 'sub',\r\n//    'sup', 'table', 'tbody', 'td', 'textarea', 'tfoot', 'th', 'thead', 'title',\r\n//    'tr', 'tt', 'u', 'ul', 'var', 'wbr', 'xmp'\r\n//  );\r\n//\r\n//  KeyIndices: array[0..1542] of Integer = (\r\n//    -1, -1, 182, -1, -1, -1, 97, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,\r\n//    -1, -1, -1, 33, -1, -1, -1, -1, 40, -1, -1, -1, -1, -1, 137, 189, -1, -1,\r\n//    -1, -1, -1, -1, -1, -1, 191, -1, -1, -1, -1, -1, -1, -1, 52, 170, -1, -1,\r\n//    -1, -1, -1, -1, -1, -1, -1, 5, 55, -1, 83, -1, -1, 34, -1, 198, -1, -1, -1,\r\n//    -1, -1, -1, -1, 82, -1, -1, -1, -1, -1, 74, 111, -1, 62, -1, -1, -1, -1, -1,\r\n//    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 93, -1, -1, -1, -1, -1, -1, -1, -1,\r\n//    -1, -1, 35, 72, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 130,\r\n//    190, -1, 117, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,\r\n//    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 36, -1, -1, 157, -1, -1, -1,\r\n//    -1, -1, 13, 114, -1, -1, -1, -1, 131, -1, -1, -1, -1, -1, -1, 21, -1, -1,\r\n//    -1, 161, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 139, -1,\r\n//    -1, -1, -1, 37, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 192, -1, -1,\r\n//    132, 103, -1, -1, -1, 199, -1, -1, -1, -1, -1, -1, -1, 129, -1, -1, -1, -1,\r\n//    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,\r\n//    -1, -1, -1, -1, -1, -1, -1, -1, -1, 133, -1, -1, -1, -1, -1, -1, -1, -1, 54,\r\n//    -1, -1, -1, -1, -1, 42, -1, -1, -1, -1, -1, -1, -1, -1, -1, 109, -1, -1, -1,\r\n//    148, -1, -1, -1, -1, -1, -1, -1, 96, -1, -1, -1, -1, -1, -1, -1, -1, 134,\r\n//    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 183, -1, -1, 168, -1, 45,\r\n//    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 179, -1, -1, 63, -1,\r\n//    -1, -1, -1, -1, -1, -1, -1, -1, 135, -1, -1, -1, -1, -1, -1, 60, -1, -1, -1,\r\n//    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 71, -1, -1, -1, -1, -1, -1, -1,\r\n//    -1, -1, -1, -1, -1, -1, 65, -1, -1, -1, -1, -1, -1, -1, 125, -1, -1, -1, -1,\r\n//    -1, -1, -1, -1, -1, 4, -1, -1, 39, -1, -1, -1, -1, 128, 20, -1, -1, 51, -1,\r\n//    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 176, -1, -1, -1, -1, -1, -1, -1, -1,\r\n//    -1, -1, -1, -1, -1, -1, -1, 112, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,\r\n//    180, -1, -1, -1, -1, -1, 172, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 107,\r\n//    -1, -1, -1, -1, 66, -1, -1, -1, 59, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,\r\n//    -1, -1, -1, -1, -1, -1, -1, -1, 162, -1, 8, -1, -1, -1, -1, -1, -1, 166, -1,\r\n//    -1, -1, 169, 141, 86, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 95, -1, -1,\r\n//    -1, -1, -1, -1, -1, 56, -1, -1, -1, -1, -1, 124, -1, -1, -1, -1, -1, -1, -1,\r\n//    -1, -1, -1, -1, -1, -1, 19, -1, -1, 41, -1, 173, -1, -1, -1, -1, -1, -1, -1,\r\n//    -1, -1, 88, -1, -1, -1, -1, -1, 27, -1, -1, -1, -1, -1, -1, -1, -1, -1, 186,\r\n//    -1, -1, -1, -1, -1, -1, -1, -1, 3, -1, -1, -1, -1, -1, -1, -1, -1, 200, -1,\r\n//    -1, -1, 87, 181, -1, -1, -1, -1, 119, -1, -1, -1, 57, -1, -1, -1, 104, -1,\r\n//    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 47, -1, 26, -1, -1, -1, -1, -1,\r\n//    -1, -1, -1, -1, -1, -1, -1, -1, -1, 174, -1, -1, -1, -1, -1, -1, -1, -1, -1,\r\n//    -1, -1, -1, 201, -1, -1, -1, 195, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,\r\n//    58, 50, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 49, -1, -1, -1, 101,\r\n//    -1, -1, -1, -1, -1, -1, -1, -1, -1, 116, -1, -1, -1, -1, 113, 187, -1, -1,\r\n//    -1, 94, -1, -1, -1, -1, -1, 165, -1, -1, -1, -1, -1, -1, -1, 69, -1, -1, -1,\r\n//    -1, -1, 167, -1, -1, 163, -1, -1, 197, -1, -1, -1, -1, 78, -1, 68, -1, -1,\r\n//    -1, -1, -1, -1, 145, -1, -1, 196, -1, -1, -1, -1, 12, -1, -1, -1, 160, -1,\r\n//    61, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 123,\r\n//    -1, -1, -1, -1, -1, -1, 76, 120, -1, 140, -1, -1, -1, -1, -1, -1, -1, -1,\r\n//    -1, -1, 10, -1, -1, -1, -1, -1, 153, -1, -1, -1, -1, -1, -1, -1, 30, -1, -1,\r\n//    -1, -1, -1, -1, 142, -1, -1, -1, -1, -1, 99, -1, -1, -1, -1, -1, -1, -1, -1,\r\n//    -1, -1, -1, -1, -1, 0, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 152, -1, 171,\r\n//    -1, -1, -1, -1, -1, 11, -1, -1, -1, -1, -1, 150, -1, -1, -1, -1, -1, -1, -1,\r\n//    -1, -1, -1, -1, -1, -1, -1, -1, -1, 14, -1, -1, -1, -1, -1, -1, -1, -1, -1,\r\n//    22, -1, -1, -1, -1, -1, 138, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,\r\n//    24, -1, 70, -1, -1, -1, -1, -1, -1, 29, -1, -1, -1, -1, -1, -1, -1, -1, -1,\r\n//    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 38, -1, -1, -1, -1, -1, -1, -1,\r\n//    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 53, -1, -1, 177, -1, -1, -1, -1, -1,\r\n//    -1, -1, -1, -1, -1, -1, -1, -1, 7, -1, -1, -1, -1, -1, -1, -1, -1, 100, -1,\r\n//    -1, -1, -1, -1, -1, -1, -1, -1, -1, 108, -1, -1, -1, -1, -1, -1, -1, -1, -1,\r\n//    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,\r\n//    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 144, -1, -1, -1,\r\n//    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 90, -1, -1,\r\n//    -1, 121, 159, 102, -1, -1, -1, -1, -1, -1, -1, -1, -1, 23, -1, -1, -1, -1,\r\n//    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 155, 149, -1, -1, -1, -1, -1,\r\n//    -1, -1, -1, -1, -1, 15, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,\r\n//    -1, -1, -1, 81, 2, -1, 110, -1, -1, -1, 46, -1, -1, -1, -1, -1, -1, -1, -1,\r\n//    -1, -1, -1, -1, -1, -1, 146, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,\r\n//    178, -1, -1, -1, -1, -1, 17, -1, -1, -1, -1, -1, 143, -1, -1, -1, -1, -1,\r\n//    -1, -1, -1, -1, -1, -1, -1, -1, 1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,\r\n//    -1, -1, -1, -1, -1, -1, -1, 164, -1, -1, -1, 48, -1, -1, -1, -1, -1, -1, 9,\r\n//    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 31, -1, 6, -1, -1,\r\n//    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,\r\n//    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,\r\n//    -1, -1, -1, 188, -1, -1, -1, -1, -1, -1, -1, 25, -1, -1, 73, -1, -1, -1, -1,\r\n//    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 64,\r\n//    79, -1, -1, -1, -1, -1, -1, -1, -1, -1, 127, -1, -1, -1, 18, -1, -1, -1, -1,\r\n//    -1, -1, -1, -1, -1, 43, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,\r\n//    -1, -1, 184, -1, -1, -1, 175, -1, -1, 193, -1, 92, 151, 154, -1, -1, -1, -1,\r\n//    106, -1, -1, -1, -1, -1, -1, -1, -1, -1, 194, -1, -1, -1, -1, -1, -1, -1,\r\n//    -1, 75, -1, -1, -1, -1, -1, -1, 84, -1, -1, -1, -1, -1, 28, -1, -1, -1, -1,\r\n//    -1, -1, 98, -1, 80, -1, -1, -1, 85, -1, -1, -1, -1, 67, -1, 118, -1, -1, -1,\r\n//    -1, -1, -1, -1, -1, 126, -1, -1, -1, -1, -1, 77, -1, -1, 122, 44, -1, -1,\r\n//    -1, -1, -1, 89, -1, -1, -1, 115, 136, -1, -1, -1, -1, -1, -1, -1, -1, -1,\r\n//    -1, -1, -1, -1, -1, -1, -1, 105, -1, -1, -1, -1, -1, -1, -1, -1, 147, -1,\r\n//    16, 185, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,\r\n//    158, -1, -1, -1, -1, -1, -1, -1, 32, -1, -1, -1, -1, -1, -1, -1, -1, -1, 91,\r\n//    -1, -1, 156, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1\r\n//  );\r\n\r\n  KeyWords: array[0..256] of UnicodeString = (\r\n    '!doctype', '/!doctype', '/a', '/abbr', '/acronym', '/address', '/applet',\r\n    '/area', '/article', '/aside', '/audio', '/b', '/base', '/basefont', '/bb',\r\n    '/bdo', '/big', '/blockquote', '/body', '/button', '/canvas', '/caption',\r\n    '/center', '/cite', '/code', '/col', '/colgroup', '/command', '/datalist',\r\n    '/dd', '/del', '/details', '/dfn', '/dialog', '/dir', '/div', '/dl', '/dt',\r\n    '/em', '/embed', '/fieldset', '/figcaption', '/figure', '/font', '/footer',\r\n    '/form', '/frame', '/frameset', '/h1', '/h2', '/h3', '/h4', '/h5', '/h6',\r\n    '/head', '/header', '/hgroup', '/html', '/i', '/iframe', '/img', '/input',\r\n    '/ins', '/kbd', '/keygen', '/label', '/layer', '/legend', '/li', '/link',\r\n    '/map', '/mark', '/marquee', '/menu', '/meta', '/meter', '/multicol',\r\n    '/nav', '/nobr', '/noembed', '/noframes', '/nolayer', '/noscript',\r\n    '/object', '/ol', '/optgroup', '/option', '/output', '/p', '/param', '/pre',\r\n    '/progress', '/q', '/rp', '/rt', '/ruby', '/s', '/samp', '/script',\r\n    '/section', '/select', '/server', '/small', '/source', '/span', '/strike',\r\n    '/strong', '/style', '/sub', '/summary', '/sup', '/table', '/tbody', '/td',\r\n    '/textarea', '/tfoot', '/th', '/thead', '/time', '/title', '/tr', '/track',\r\n    '/tt', '/u', '/ul', '/var', '/video', '/wbr', '/xmp', 'a', 'abbr',\r\n    'acronym', 'address', 'applet', 'area', 'article', 'aside', 'audio', 'b',\r\n    'base', 'basefont', 'bb', 'bdo', 'big', 'blockquote', 'body', 'button',\r\n    'canvas', 'caption', 'center', 'cite', 'code', 'col', 'colgroup', 'command',\r\n    'datalist', 'dd', 'del', 'details', 'dfn', 'dialog', 'dir', 'div', 'dl',\r\n    'dt', 'em', 'embed', 'fieldset', 'figcaption', 'figure', 'font', 'footer',\r\n    'form', 'frame', 'frameset', 'h1', 'h2', 'h3', 'h4', 'h5', 'h6', 'head',\r\n    'header', 'hgroup', 'html', 'i', 'iframe', 'img', 'input', 'ins', 'kbd',\r\n    'keygen', 'label', 'layer', 'legend', 'li', 'link', 'map', 'mark',\r\n    'marquee', 'menu', 'meta', 'meter', 'multicol', 'nav', 'nobr', 'noembed',\r\n    'noframes', 'nolayer', 'noscript', 'object', 'ol', 'optgroup', 'option',\r\n    'output', 'p', 'param', 'pre', 'progress', 'q', 'rp', 'rt', 'ruby', 's',\r\n    'samp', 'script', 'section', 'select', 'server', 'small', 'source', 'span',\r\n    'strike', 'strong', 'style', 'sub', 'summary', 'sup', 'synedit', 'table',\r\n    'tbody', 'td', 'textarea', 'tfoot', 'th', 'thead', 'time', 'title', 'tr',\r\n    'track', 'tt', 'u', 'ul', 'var', 'video', 'wbr', 'xmp'\r\n  );\r\n\r\n  KeyIndices: array[0..2178] of Integer = (\r\n    -1, -1, -1, 3, -1, -1, 231, 250, -1, -1, -1, 212, -1, -1, -1, -1, -1, -1,\r\n    -1, -1, 175, -1, -1, -1, -1, -1, 128, -1, -1, -1, -1, 155, -1, -1, -1, -1,\r\n    -1, -1, -1, 83, -1, 201, 122, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,\r\n    -1, 48, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,\r\n    -1, -1, -1, -1, -1, -1, -1, -1, 70, -1, -1, -1, -1, -1, -1, 183, -1, -1, -1,\r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,\r\n    -1, -1, -1, -1, -1, -1, -1, -1, 216, -1, -1, -1, -1, -1, -1, 31, -1, -1, -1,\r\n    -1, 89, -1, -1, -1, 234, -1, -1, 188, -1, -1, -1, -1, -1, -1, -1, -1, 107,\r\n    -1, -1, 61, -1, -1, -1, -1, -1, 21, -1, -1, -1, 8, -1, -1, -1, -1, -1, -1,\r\n    -1, -1, -1, -1, -1, -1, 225, -1, -1, 150, -1, -1, 91, -1, -1, -1, 88, -1,\r\n    -1, -1, 158, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 59, -1,\r\n    -1, -1, 137, 12, -1, 67, -1, -1, 47, -1, -1, -1, -1, -1, 10, -1, -1, 135,\r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,\r\n    -1, -1, -1, -1, 218, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 170, -1,\r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,\r\n    174, -1, 7, -1, -1, -1, 142, -1, -1, -1, -1, -1, -1, -1, -1, 133, -1, -1,\r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 232, -1, -1, -1,\r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, 77, -1, -1, -1, 178, -1, -1, -1, -1, -1,\r\n    -1, 209, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 130, -1, 162,\r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 51, -1, -1, -1, 237, -1, -1, -1,\r\n    17, -1, -1, -1, -1, -1, 32, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 79, -1,\r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,\r\n    -1, -1, 157, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,\r\n    210, -1, -1, -1, 104, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,\r\n    -1, -1, -1, -1, 206, -1, -1, -1, -1, -1, -1, -1, -1, 165, -1, -1, -1, -1,\r\n    -1, -1, -1, 254, -1, -1, -1, -1, -1, -1, 73, -1, -1, -1, -1, 126, -1, -1,\r\n    -1, -1, -1, -1, -1, 24, -1, -1, 238, -1, 96, -1, 38, -1, -1, -1, -1, -1, -1,\r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,\r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, 248, -1, -1, -1, 156, -1, 103, -1, -1,\r\n    -1, -1, -1, -1, -1, -1, 239, 211, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,\r\n    111, -1, -1, -1, -1, -1, -1, -1, 120, -1, -1, -1, 29, -1, -1, -1, -1, -1,\r\n    -1, -1, -1, -1, -1, 71, 84, -1, -1, -1, -1, -1, 87, -1, -1, -1, -1, 186, -1,\r\n    -1, -1, -1, -1, -1, -1, -1, 243, -1, -1, -1, -1, 20, -1, -1, -1, -1, -1, -1,\r\n    115, -1, -1, -1, -1, -1, -1, 26, 138, -1, -1, -1, -1, -1, -1, -1, 163, -1,\r\n    -1, 144, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,\r\n    -1, 181, 22, -1, -1, -1, -1, 255, -1, -1, -1, -1, -1, -1, 36, -1, -1, 240,\r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 112, -1, -1, -1, -1, -1, -1,\r\n    153, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 34, -1, -1, -1,\r\n    -1, -1, -1, -1, 106, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 256,\r\n    -1, 164, -1, -1, -1, -1, -1, -1, -1, -1, -1, 192, 145, -1, -1, -1, -1, -1,\r\n    -1, -1, -1, -1, -1, 65, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 37,\r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 114, -1, 197,\r\n    63, -1, -1, -1, -1, -1, -1, 64, -1, -1, -1, -1, -1, -1, 202, -1, -1, -1, -1,\r\n    -1, -1, -1, -1, -1, -1, -1, 75, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,\r\n    -1, -1, -1, 44, -1, 200, -1, -1, 2, -1, -1, -1, -1, -1, -1, -1, -1, -1, 151,\r\n    -1, -1, -1, -1, -1, -1, 242, -1, -1, -1, -1, -1, -1, -1, -1, 193, 176, -1,\r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, 66, -1, -1, -1, -1, -1, 220, -1, -1, -1,\r\n    141, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 49, -1, -1, -1, -1,\r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, 81, -1, -1, 93, 76, -1, -1, 14, -1, -1,\r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, 58, -1, -1, -1, -1, 230, -1, 198, -1,\r\n    -1, -1, -1, -1, -1, 69, -1, -1, -1, -1, 101, -1, -1, -1, -1, -1, -1, -1, -1,\r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, 244, -1, -1, -1, -1, 208, -1, -1, -1,\r\n    -1, -1, -1, -1, 100, 203, 5, -1, -1, -1, -1, -1, 41, -1, -1, -1, -1, -1, -1,\r\n    -1, -1, -1, -1, -1, -1, -1, 116, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,\r\n    -1, -1, -1, -1, 25, -1, -1, -1, -1, -1, 45, 92, -1, -1, -1, -1, 80, 204, -1,\r\n    -1, -1, -1, -1, 42, -1, -1, -1, -1, -1, 132, -1, 249, -1, -1, -1, -1, -1,\r\n    -1, -1, 82, -1, 16, -1, 121, 86, -1, -1, -1, 224, -1, 195, -1, -1, -1, -1,\r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 159, -1, -1, 54,\r\n    -1, -1, -1, -1, -1, -1, -1, -1, 207, -1, -1, 68, -1, -1, -1, -1, -1, -1,\r\n    252, -1, 233, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 56, -1, -1,\r\n    -1, -1, -1, -1, -1, -1, 251, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 124,\r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 108, -1, -1, -1, -1, -1, -1,\r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, 179, 18, -1, -1, -1, -1, -1, -1, -1, -1,\r\n    -1, -1, -1, -1, 191, -1, -1, -1, -1, -1, 99, -1, -1, -1, -1, -1, -1, -1, -1,\r\n    -1, -1, -1, -1, -1, -1, 52, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 90,\r\n    171, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 72,\r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 168, -1, -1, -1, 226, -1, -1, -1,\r\n    -1, -1, -1, -1, -1, -1, -1, 222, -1, -1, -1, -1, -1, 253, -1, -1, -1, -1,\r\n    -1, -1, -1, -1, -1, -1, -1, 246, -1, -1, -1, -1, -1, -1, -1, -1, -1, 196,\r\n    -1, -1, -1, -1, -1, -1, 199, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,\r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 6, -1, -1,\r\n    -1, -1, 0, -1, -1, 229, -1, -1, 228, -1, -1, -1, -1, -1, 215, -1, 125, 102,\r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,\r\n    -1, -1, 227, -1, 172, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 194, -1, -1,\r\n    -1, -1, -1, -1, -1, 184, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,\r\n    -1, -1, -1, 161, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,\r\n    -1, -1, -1, 169, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,\r\n    -1, -1, -1, -1, -1, 213, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,\r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,\r\n    -1, 205, -1, -1, 190, -1, -1, -1, 97, -1, -1, -1, -1, -1, 33, -1, -1, -1,\r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,\r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 247, -1, -1, -1, -1, -1,\r\n    -1, -1, -1, -1, -1, -1, 119, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,\r\n    -1, -1, -1, -1, -1, 55, -1, 19, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,\r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,\r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,\r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,\r\n    -1, -1, -1, -1, -1, -1, -1, -1, 148, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,\r\n    -1, -1, 223, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 11, -1, -1, -1,\r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 187, -1, -1, -1,\r\n    95, -1, 136, -1, 177, -1, -1, -1, -1, -1, -1, -1, -1, -1, 9, -1, -1, -1,\r\n    118, -1, -1, -1, -1, -1, -1, 152, -1, -1, -1, -1, -1, -1, 40, -1, -1, -1,\r\n    -1, -1, -1, 50, -1, -1, -1, -1, -1, -1, -1, -1, 4, -1, -1, -1, -1, -1, -1,\r\n    -1, -1, -1, -1, -1, -1, -1, 143, -1, -1, -1, -1, -1, -1, -1, 214, -1, 166,\r\n    60, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 39, -1, -1, -1, -1, 147, -1, -1,\r\n    -1, -1, -1, 15, -1, -1, 167, -1, -1, 173, -1, -1, -1, -1, -1, -1, -1, 131,\r\n    -1, -1, -1, 46, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 57, -1,\r\n    -1, -1, -1, -1, -1, -1, 149, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,\r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 235, 35, -1, -1, -1, -1,\r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 110, -1, -1, -1, -1, -1, -1, -1,\r\n    27, -1, -1, -1, -1, -1, -1, -1, 160, -1, -1, -1, -1, -1, 74, -1, -1, -1, -1,\r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 78, -1, -1, -1, 30, -1,\r\n    217, -1, -1, -1, -1, -1, 189, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,\r\n    -1, -1, -1, -1, -1, 154, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,\r\n    182, -1, 146, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,\r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, 139, -1, -1, 98, -1, -1, -1, -1, 129,\r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 62, -1, -1, -1, -1, 180, -1, -1,\r\n    245, -1, -1, -1, -1, -1, -1, 241, -1, -1, -1, -1, 117, -1, 221, -1, -1, -1,\r\n    -1, -1, 23, -1, 13, -1, -1, -1, -1, -1, -1, -1, -1, -1, 53, -1, 1, -1, -1,\r\n    -1, -1, -1, -1, -1, 113, -1, -1, 134, -1, -1, -1, 94, -1, -1, -1, -1, -1,\r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,\r\n    -1, 185, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 140, -1, -1, -1,\r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, 43, -1, -1, -1, -1, -1, 109, -1, -1, -1,\r\n    -1, -1, 105, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,\r\n    -1, -1, -1, -1, -1, 85, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,\r\n    -1, -1, 127, -1, -1, -1, 28, -1, -1, -1, -1, 123, -1, -1, -1, -1, -1, -1,\r\n    -1, 236, -1, 219, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,\r\n    -1, -1, -1, -1, -1\r\n  );\r\n\r\n{$Q-}\r\nfunction TSynHTMLSyn.HashKey(Str: PWideChar): Cardinal;\r\nbegin\r\n//  Result := 0;\r\n//  while IsIdentChar(Str^) or CharInSet(Str^, ['!', '/']) do\r\n//  begin\r\n//    Result := Result * 932 + Ord(Str^) * 46;\r\n//    inc(Str);\r\n//  end;\r\n//  Result := Result mod 1543;\r\n//  fStringLen := Str - fToIdent;\r\n\r\n  Result := 0;\r\n  while IsIdentChar(Str^) do\r\n  begin\r\n    Result := Result * 627 + Ord(Str^) * 829;\r\n    inc(Str);\r\n  end;\r\n  Result := Result mod 2179;\r\n  fStringLen := Str - fToIdent;\r\nend;\r\n{$Q+}\r\n\r\nfunction TSynHTMLSyn.IdentKind(MayBe: PWideChar): TtkTokenKind;\r\nvar\r\n  Key: Cardinal;\r\nbegin\r\n  fToIdent := MayBe;\r\n  Key := HashKey(MayBe);\r\n  if Key <= High(fIdentFuncTable) then\r\n    Result := fIdentFuncTable[Key](KeyIndices[Key])\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nprocedure TSynHTMLSyn.InitIdent;\r\nvar\r\n  i: Integer;\r\nbegin\r\n  for i := Low(fIdentFuncTable) to High(fIdentFuncTable) do\r\n    if KeyIndices[i] = -1 then\r\n      fIdentFuncTable[i] := AltFunc;\r\n\r\n  for i := Low(fIdentFuncTable) to High(fIdentFuncTable) do\r\n    if @fIdentFuncTable[i] = nil then\r\n      fIdentFuncTable[i] := KeyWordFunc;\r\nend;\r\n\r\nfunction TSynHTMLSyn.AltFunc(Index: Integer): TtkTokenKind;\r\nbegin\r\n  Result := tkUndefKey;\r\nend;\r\n\r\nfunction TSynHTMLSyn.KeyWordFunc(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkUndefKey;\r\nend;\r\n\r\nconstructor TSynHTMLSyn.Create(AOwner: TComponent);\r\nbegin\r\n  inherited Create(AOwner);\r\n\r\n  fCaseSensitive := False;\r\n\r\n  fCommentAttri := TSynHighlighterAttributes.Create(SYNS_AttrComment, SYNS_FriendlyAttrComment);\r\n  AddAttribute(fCommentAttri);\r\n\r\n  fIdentifierAttri := TSynHighlighterAttributes.Create(SYNS_AttrIdentifier, SYNS_FriendlyAttrIdentifier);\r\n  fIdentifierAttri.Style := [fsBold];\r\n  AddAttribute(fIdentifierAttri);\r\n\r\n  fKeyAttri := TSynHighlighterAttributes.Create(SYNS_AttrReservedWord, SYNS_FriendlyAttrReservedWord);\r\n  fKeyAttri.Style := [fsBold];\r\n  fKeyAttri.Foreground := $00ff0080;\r\n  AddAttribute(fKeyAttri);\r\n\r\n  fSpaceAttri := TSynHighlighterAttributes.Create(SYNS_AttrSpace, SYNS_FriendlyAttrSpace);\r\n  AddAttribute(fSpaceAttri);\r\n\r\n  fSymbolAttri := TSynHighlighterAttributes.Create(SYNS_AttrSymbol, SYNS_FriendlyAttrSymbol);\r\n  fSymbolAttri.Style := [fsBold];\r\n  AddAttribute(fSymbolAttri);\r\n\r\n  fTextAttri := TSynHighlighterAttributes.Create(SYNS_AttrText, SYNS_FriendlyAttrText);\r\n  AddAttribute(fTextAttri);\r\n\r\n  fUndefKeyAttri := TSynHighlighterAttributes.Create(SYNS_AttrUnknownWord, SYNS_FriendlyAttrUnknownWord);\r\n  fUndefKeyAttri.Style := [fsBold];\r\n  fUndefKeyAttri.Foreground := clRed;\r\n  AddAttribute(fUndefKeyAttri);\r\n\r\n  fValueAttri := TSynHighlighterAttributes.Create(SYNS_AttrValue, SYNS_FriendlyAttrValue);\r\n  fValueAttri.Foreground := $00ff8000;\r\n  AddAttribute(fValueAttri);\r\n\r\n  fAndAttri := TSynHighlighterAttributes.Create(SYNS_AttrEscapeAmpersand, SYNS_FriendlyAttrEscapeAmpersand);\r\n  fAndAttri.Style := [fsBold];\r\n  fAndAttri.Foreground := $0000ff00;\r\n  AddAttribute(fAndAttri);\r\n  SetAttributesOnChange(DefHighlightChange);\r\n\r\n  InitIdent;\r\n  fRange := rsText;\r\n  fDefaultFilter := SYNS_FilterHTML;\r\n  fAndCode := -1;\r\nend;\r\n\r\nprocedure TSynHTMLSyn.BraceCloseProc;\r\nbegin\r\n  fRange := rsText;\r\n  fTokenId := tkSymbol;\r\n  Inc(Run);\r\nend;\r\n\r\nprocedure TSynHTMLSyn.CommentProc;\r\nbegin\r\n  fTokenID := tkComment;\r\n\r\n  if IsLineEnd(Run) then\r\n  begin\r\n    NextProcedure;\r\n    Exit;\r\n  end;\r\n\r\n  while not IsLineEnd(Run) do\r\n  begin\r\n    if (fLine[Run] = '>') and (fLine[Run - 1] = '-') and (fLine[Run - 2] = '-') then\r\n    begin\r\n      fRange := rsText;\r\n      Inc(Run);\r\n      break;\r\n    end;\r\n    Inc(Run);\r\n  end;\r\nend;\r\n\r\nprocedure TSynHTMLSyn.BraceOpenProc;\r\nbegin\r\n  Inc(Run);\r\n  if (fLine[Run] = '!') and (fLine[Run + 1] = '-') and (fLine[Run + 2] = '-') then\r\n  begin\r\n    fRange := rsComment;\r\n    fTokenID := tkComment;\r\n    Inc(Run, 3);\r\n  end\r\n  else\r\n  begin\r\n    fRange := rsKey;\r\n    fTokenID := tkSymbol;\r\n  end;\r\nend;\r\n\r\nprocedure TSynHTMLSyn.CRProc;\r\nbegin\r\n  fTokenID := tkSpace;\r\n  Inc(Run);\r\n  if fLine[Run] = #10 then Inc(Run);\r\nend;\r\n\r\nprocedure TSynHTMLSyn.EqualProc;\r\nbegin\r\n  fRange := rsValue;\r\n  fTokenID := tkSymbol;\r\n  Inc(Run);\r\nend;\r\n\r\nprocedure TSynHTMLSyn.IdentProc;\r\nbegin\r\n  case fRange of\r\n  rsKey:\r\n    begin\r\n      fRange := rsParam;\r\n      fTokenID := IdentKind((fLine + Run));\r\n      Inc(Run, fStringLen);\r\n    end;\r\n  rsValue:\r\n    begin\r\n      fRange := rsParam;\r\n      fTokenID := tkValue;\r\n      repeat\r\n        Inc(Run);\r\n      until (fLine[Run] <= #32) or (fLine[Run] = '>');\r\n    end;\r\n  else\r\n    fTokenID := tkIdentifier;\r\n    repeat\r\n      Inc(Run);\r\n    until (fLine[Run] <= #32) or (fLine[Run] = '=') or (fLine[Run] = '\"') or\r\n      (fLine[Run] = '>');\r\n  end;\r\nend;\r\n\r\nprocedure TSynHTMLSyn.LFProc;\r\nbegin\r\n  fTokenID := tkSpace;\r\n  Inc(Run);\r\nend;\r\n\r\nprocedure TSynHTMLSyn.NullProc;\r\nbegin\r\n  fTokenID := tkNull;\r\n  inc(Run);\r\nend;\r\n\r\nprocedure TSynHTMLSyn.TextProc;\r\n\r\n  function IsStopChar: Boolean;\r\n  begin\r\n    case fLine[Run] of\r\n      #0..#31, '<', '&':\r\n        Result := True;\r\n      else\r\n        Result := False;\r\n    end;\r\n  end;\r\n\r\n  function IsNumberChar: Boolean;\r\n  begin\r\n    case fLine[Run] of\r\n      '0'..'9', 'A'..'F', 'a'..'f':\r\n        Result := True;\r\n      else\r\n        Result := False;\r\n    end;\r\n  end;\r\n\r\nvar\r\n  i: Integer;\r\nbegin\r\n  if CharInSet(fLine[Run], [#0..#31, '<']) then\r\n  begin\r\n    NextProcedure;\r\n    exit;\r\n  end;\r\n\r\n  fTokenID := tkText;\r\n\r\n  while True do\r\n  begin\r\n    while not IsStopChar do Inc(Run);\r\n\r\n    if (fLine[Run] = '&') then\r\n    begin\r\n      if (fLine[Run + 1] = '#') then\r\n      begin\r\n        fAndCode := -1;\r\n        i := Run;\r\n        inc(Run, 2);\r\n        if CharInSet(fLine[Run], ['X', 'x']) then\r\n        begin\r\n          inc(Run);\r\n          while IsNumberChar do\r\n            inc(Run);\r\n        end\r\n        else\r\n          while CharInSet(fLine[Run], ['0'..'9']) do\r\n            inc(Run);\r\n        if (fLine[Run] = ';') then\r\n        begin\r\n          inc(Run);\r\n          Run := i;\r\n          fRange := rsAmpersand;\r\n        end;\r\n        break;\r\n      end\r\n      else\r\n        for i := Low(EscapeAmps) To High(EscapeAmps) do\r\n          if (WStrLComp((fLine + Run), EscapeAmps[i], WStrLen(EscapeAmps[i])) = 0) then\r\n          begin\r\n            fAndCode := i;\r\n            fRange := rsAmpersand;\r\n            Exit;\r\n          end;\r\n\r\n      Inc(Run);\r\n    end\r\n    else\r\n      Break;\r\n  end;\r\nend;\r\n\r\nprocedure TSynHTMLSyn.AmpersandProc;\r\n\r\n  function IsNumberChar: Boolean;\r\n  begin\r\n    case fLine[Run] of\r\n      '0'..'9', 'A'..'F', 'a'..'f':\r\n        Result := True;\r\n      else\r\n        Result := False;\r\n    end;\r\n  end;\r\n\r\nbegin\r\n  if fRange <> rsAmpersand then\r\n  begin\r\n    if fRange = rsKey then\r\n    begin\r\n      Inc(Run);\r\n      fRange := rsText;\r\n      fTokenID := tkText;\r\n    end\r\n    else\r\n      IdentProc;\r\n    Exit;\r\n  end;\r\n\r\n  case fAndCode of\r\n  Low(EscapeAmps)..High(EscapeAmps):\r\n    begin\r\n      fTokenID := tkAmpersand;\r\n      Inc(Run, WStrLen(EscapeAmps[fAndCode]));\r\n    end;\r\n    else begin\r\n      if (fLine[Run + 1] = '#') then\r\n      begin\r\n        fAndCode := -1;\r\n        inc(Run, 2);\r\n        if CharInSet(fLine[Run], ['X', 'x']) then\r\n        begin\r\n          inc(Run);\r\n          while IsNumberChar do\r\n            inc(Run);\r\n        end\r\n        else\r\n          while CharInSet(fLine[Run], ['0'..'9']) do\r\n            inc(Run);\r\n        if (fLine[Run] = ';') then begin\r\n          inc(Run);\r\n          fTokenID := tkAmpersand;\r\n        end else\r\n          fTokenID := tkText;\r\n      end;\r\n    end;\r\n  end;\r\n  fAndCode := -1;\r\n  fRange := rsText;\r\nend;\r\n\r\nprocedure TSynHTMLSyn.SpaceProc;\r\nbegin\r\n  inc(Run);\r\n  fTokenID := tkSpace;\r\n  while fLine[Run] <= #32 do\r\n  begin\r\n    if CharInSet(fLine[Run], [#0, #9, #10, #13]) then break;\r\n    Inc(Run);\r\n  end;\r\nend;\r\n\r\nprocedure TSynHTMLSyn.StringProc;\r\nvar\r\n  iOpenChar: WideChar;\r\nbegin\r\n  case fRange of\r\n    rsQuoteValue:\r\n      begin\r\n        iOpenChar := #39;\r\n        fTokenID := tkValue;\r\n      end;\r\n    rsDoubleQuoteValue:\r\n      begin\r\n        iOpenChar := '\"';\r\n        fTokenID := tkValue;\r\n      end;\r\n    else\r\n    begin\r\n      iOpenChar := fLine[Run];\r\n      if fRange = rsValue then\r\n      begin\r\n        if iOpenChar = '\"' then\r\n          fRange := rsDoubleQuoteValue\r\n        else\r\n          fRange := rsQuoteValue;\r\n        fTokenID := tkValue;\r\n      end else\r\n      begin\r\n        IdentProc;\r\n        Exit;\r\n      end;\r\n      Inc(Run); { jumps over the opening char }\r\n    end;\r\n  end;\r\n\r\n  while not IsLineEnd(Run) do\r\n  begin\r\n    if fLine[Run] = iOpenChar then\r\n    begin\r\n      Inc(Run);  { jumps over the closing char }\r\n      if fRange in [rsDoubleQuoteValue, rsQuoteValue] then\r\n        fRange := rsParam\r\n      else\r\n        fRange := rsText;\r\n      break;\r\n    end;\r\n    Inc(Run);\r\n  end;\r\nend;\r\n\r\nfunction TSynHTMLSyn.IsIdentChar(AChar: WideChar): Boolean;\r\nbegin\r\n  case AChar of\r\n    '_', '/', '0'..'9', 'A'..'Z', 'a'..'z':\r\n      Result := True;\r\n    else\r\n      Result := False;\r\n  end;\r\nend;\r\n\r\n\r\nprocedure TSynHTMLSyn.Next;\r\nbegin\r\n  fTokenPos := Run;\r\n  case fRange of\r\n    rsText:\r\n      TextProc;\r\n    rsComment:\r\n      CommentProc;\r\n    rsQuoteValue, rsDoubleQuoteValue:\r\n      if IsLineEnd(Run) then\r\n        NextProcedure\r\n      else\r\n        StringProc;\r\n    else\r\n      NextProcedure;\r\n  end;\r\n\r\n  // ensure that one call of Next is enough to reach next token\r\n  if (fOldRun = Run) and not GetEol then Next;\r\n\r\n  inherited;\r\nend;\r\n\r\nprocedure TSynHTMLSyn.NextProcedure;\r\nbegin\r\n  case fLine[Run] of\r\n    #0: NullProc;\r\n    #10: LFProc;\r\n    #13: CRProc;\r\n    #1..#9, #11, #12, #14..#32: SpaceProc;\r\n    '&': AmpersandProc;\r\n    '\"', #39: StringProc;\r\n    '<': BraceOpenProc;\r\n    '>': BraceCloseProc;\r\n    '=': EqualProc;\r\n    else IdentProc;\r\n  end;\r\nend;\r\n\r\nfunction TSynHTMLSyn.GetDefaultAttribute(Index: integer): TSynHighlighterAttributes;\r\nbegin\r\n  case Index of\r\n    SYN_ATTR_COMMENT: Result := fCommentAttri;\r\n    SYN_ATTR_IDENTIFIER: Result := fIdentifierAttri;\r\n    SYN_ATTR_KEYWORD: Result := fKeyAttri;\r\n    SYN_ATTR_WHITESPACE: Result := fSpaceAttri;\r\n    SYN_ATTR_SYMBOL: Result := fSymbolAttri;\r\n  else\r\n    Result := nil;\r\n  end;\r\nend;\r\n\r\nfunction TSynHTMLSyn.GetEol: Boolean;\r\nbegin\r\n  Result := Run = fLineLen + 1;\r\nend;\r\n\r\nfunction TSynHTMLSyn.GetTokenID: TtkTokenKind;\r\nbegin\r\n  Result := fTokenId;\r\nend;\r\n\r\nfunction TSynHTMLSyn.GetTokenAttribute: TSynHighlighterAttributes;\r\nbegin\r\n  case fTokenID of\r\n    tkAmpersand: Result := fAndAttri;\r\n    tkComment: Result := fCommentAttri;\r\n    tkIdentifier: Result := fIdentifierAttri;\r\n    tkKey: Result := fKeyAttri;\r\n    tkSpace: Result := fSpaceAttri;\r\n    tkSymbol: Result := fSymbolAttri;\r\n    tkText: Result := fTextAttri;\r\n    tkUndefKey: Result := fUndefKeyAttri;\r\n    tkValue: Result := fValueAttri;\r\n    else Result := nil;\r\n  end;\r\nend;\r\n\r\nfunction TSynHTMLSyn.GetTokenKind: integer;\r\nbegin\r\n  Result := Ord(fTokenId);\r\nend;\r\n\r\nfunction TSynHTMLSyn.GetRange: Pointer;\r\nbegin\r\n  Result := Pointer(fRange);\r\nend;\r\n\r\nprocedure TSynHTMLSyn.SetRange(Value: Pointer);\r\nbegin\r\n  fRange := TRangeState(Value);\r\nend;\r\n\r\nprocedure TSynHTMLSyn.ResetRange;\r\nbegin\r\n  fRange:= rsText;\r\nend;\r\n\r\nfunction TSynHTMLSyn.IsFilterStored: Boolean;\r\nbegin\r\n  Result := fDefaultFilter <> SYNS_FilterHTML;\r\nend;\r\n\r\nclass function TSynHTMLSyn.GetLanguageName: string;\r\nbegin\r\n  Result := SYNS_LangHTML;\r\nend;\r\n\r\nfunction TSynHTMLSyn.GetSampleSource: UnicodeString;\r\nbegin\r\n  Result := ''#13#10 +\r\n            #13#10 +\r\n            ''#13#10 +\r\n            ''#13#10 +\r\n            '  
    '#13#10 +\r\n            '    '#13#10 +\r\n            '  
    '#13#10 +\r\n            '  Sample HTML code © 2001'#13#10 +\r\n            ''#13#10 +\r\n            '';\r\nend;\r\n\r\nclass function TSynHTMLSyn.GetFriendlyLanguageName: UnicodeString;\r\nbegin\r\n  Result := SYNS_FriendlyLangHTML;\r\nend;\r\n\r\ninitialization\r\n{$IFNDEF SYN_CPPB_1}\r\n  RegisterPlaceableHighlighter(TSynHTMLSyn);\r\n{$ENDIF}\r\nend."
  },
  {
    "path": "External/SynEdit/Source/SynHighlighterIDL.pas",
    "content": "{-------------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nCode template generated with SynGen.\r\nThe original code is: SynHighlighterIDL.pas, released 2001-10-15.\r\nDescription: CORBA IDL Parser/Highlighter\r\nThe initial author of this file is P.L. Polak.\r\nUnicode translation by Mal Hrz.\r\nCopyright (c) 2001, all rights reserved.\r\n\r\nContributors to the SynEdit and mwEdit projects are listed in the\r\nContributors.txt file.\r\n\r\nAlternatively, the contents of this file may be used under the terms of the\r\nGNU General Public License Version 2 or later (the \"GPL\"), in which case\r\nthe provisions of the GPL are applicable instead of those above.\r\nIf you wish to allow use of your version of this file only under the terms\r\nof the GPL and not to allow others to use your version of this file\r\nunder the MPL, indicate your decision by deleting the provisions above and\r\nreplace them with the notice and other provisions required by the GPL.\r\nIf you do not delete the provisions above, a recipient may use your version\r\nof this file under either the MPL or the GPL.\r\n\r\n$Id: SynHighlighterIDL.pas,v 1.8.2.7 2008/09/14 16:25:00 maelh Exp $\r\n\r\nYou may retrieve the latest version of this file at the SynEdit home page,\r\nlocated at http://SynEdit.SourceForge.net\r\n\r\n-------------------------------------------------------------------------------}\r\n\r\n{$IFNDEF QSYNHIGHLIGHTERIDL}\r\nunit SynHighlighterIDL;\r\n{$ENDIF}\r\n\r\n{$I SynEdit.inc}\r\n\r\ninterface\r\n\r\nuses\r\n{$IFDEF SYN_CLX}\r\n  QGraphics,\r\n  QSynEditTypes,\r\n  QSynEditHighlighter,\r\n  QSynUnicode,\r\n{$ELSE}\r\n  Graphics,\r\n  SynEditTypes,\r\n  SynEditHighlighter,\r\n  SynUnicode,\r\n{$ENDIF}\r\n  SysUtils,\r\n  Classes;\r\n\r\nType\r\n  TtkTokenKind = (\r\n    tkComment,\r\n    tkDatatype,\r\n    tkIdentifier,\r\n    tkKey,\r\n    tkNull,\r\n    tkNumber,\r\n    tkPreprocessor,\r\n    tkSpace,\r\n    tkString,\r\n    tkSymbol,\r\n    tkUnknown);\r\n\r\n  TRangeState = (rsUnKnown, rsComment, rsString, rsChar);\r\n\r\n  PIdentFuncTableFunc = ^TIdentFuncTableFunc;\r\n  TIdentFuncTableFunc = function (Index: Integer): TtkTokenKind of object;\r\n\r\ntype\r\n  TSynIdlSyn = class(TSynCustomHighlighter)\r\n  private\r\n    fRange: TRangeState;\r\n    fTokenID: TtkTokenKind;\r\n    fIdentFuncTable: array[0..100] of TIdentFuncTableFunc;\r\n    fCommentAttri: TSynHighlighterAttributes;\r\n    fDatatypeAttri: TSynHighlighterAttributes;\r\n    fIdentifierAttri: TSynHighlighterAttributes;\r\n    fKeyAttri: TSynHighlighterAttributes;\r\n    fNumberAttri: TSynHighlighterAttributes;\r\n    fPreprocessorAttri: TSynHighlighterAttributes;\r\n    fSpaceAttri: TSynHighlighterAttributes;\r\n    fStringAttri: TSynHighlighterAttributes;\r\n    fSymbolAttri: TSynHighlighterAttributes;\r\n    function AltFunc(Index: Integer): TtkTokenKind;\r\n    procedure IdentProc;\r\n    procedure SymbolProc;\r\n    procedure UnknownProc;\r\n    function FuncAbstract(Index: Integer): TtkTokenKind;\r\n    function FuncAny(Index: Integer): TtkTokenKind;\r\n    function FuncAttribute(Index: Integer): TtkTokenKind;\r\n    function FuncBoolean(Index: Integer): TtkTokenKind;\r\n    function FuncCase(Index: Integer): TtkTokenKind;\r\n    function FuncChar(Index: Integer): TtkTokenKind;\r\n    function FuncConst(Index: Integer): TtkTokenKind;\r\n    function FuncContext(Index: Integer): TtkTokenKind;\r\n    function FuncCustom(Index: Integer): TtkTokenKind;\r\n    function FuncDefault(Index: Integer): TtkTokenKind;\r\n    function FuncDouble(Index: Integer): TtkTokenKind;\r\n    function FuncEnum(Index: Integer): TtkTokenKind;\r\n    function FuncException(Index: Integer): TtkTokenKind;\r\n    function FuncFactory(Index: Integer): TtkTokenKind;\r\n    function FuncFalse(Index: Integer): TtkTokenKind;\r\n    function FuncFixed(Index: Integer): TtkTokenKind;\r\n    function FuncFloat(Index: Integer): TtkTokenKind;\r\n    function FuncIn(Index: Integer): TtkTokenKind;\r\n    function FuncInout(Index: Integer): TtkTokenKind;\r\n    function FuncInterface(Index: Integer): TtkTokenKind;\r\n    function FuncLocal(Index: Integer): TtkTokenKind;\r\n    function FuncLong(Index: Integer): TtkTokenKind;\r\n    function FuncModule(Index: Integer): TtkTokenKind;\r\n    function FuncNative(Index: Integer): TtkTokenKind;\r\n    function FuncObject(Index: Integer): TtkTokenKind;\r\n    function FuncOctet(Index: Integer): TtkTokenKind;\r\n    function FuncOneway(Index: Integer): TtkTokenKind;\r\n    function FuncOut(Index: Integer): TtkTokenKind;\r\n    function FuncPrivate(Index: Integer): TtkTokenKind;\r\n    function FuncPublic(Index: Integer): TtkTokenKind;\r\n    function FuncRaises(Index: Integer): TtkTokenKind;\r\n    function FuncReadonly(Index: Integer): TtkTokenKind;\r\n    function FuncSequence(Index: Integer): TtkTokenKind;\r\n    function FuncShort(Index: Integer): TtkTokenKind;\r\n    function FuncString(Index: Integer): TtkTokenKind;\r\n    function FuncStruct(Index: Integer): TtkTokenKind;\r\n    function FuncSupports(Index: Integer): TtkTokenKind;\r\n    function FuncSwitch(Index: Integer): TtkTokenKind;\r\n    function FuncTrue(Index: Integer): TtkTokenKind;\r\n    function FuncTruncatable(Index: Integer): TtkTokenKind;\r\n    function FuncTypedef(Index: Integer): TtkTokenKind;\r\n    function FuncUnion(Index: Integer): TtkTokenKind;\r\n    function FuncUnsigned(Index: Integer): TtkTokenKind;\r\n    function FuncValuebase(Index: Integer): TtkTokenKind;\r\n    function FuncValuetype(Index: Integer): TtkTokenKind;\r\n    function FuncVoid(Index: Integer): TtkTokenKind;\r\n    function FuncWchar(Index: Integer): TtkTokenKind;\r\n    function FuncWstring(Index: Integer): TtkTokenKind;\r\n    function HashKey(Str: PWideChar): Cardinal;\r\n    function IdentKind(MayBe: PWideChar): TtkTokenKind;\r\n    procedure InitIdent;\r\n    procedure NullProc;\r\n    procedure NumberProc;\r\n    procedure SpaceProc;\r\n    procedure CRProc;\r\n    procedure LFProc;\r\n    procedure CommentOpenProc;\r\n    procedure CommentProc;\r\n    procedure StringOpenProc;\r\n    procedure StringProc;\r\n    procedure CharOpenProc;\r\n    procedure CharProc;\r\n    procedure PreProcessorProc;\r\n  protected\r\n    function GetSampleSource: UnicodeString; override;\r\n    function IsFilterStored: Boolean; override;\r\n  public\r\n    constructor Create(AOwner: TComponent); override;\r\n    class function GetLanguageName: string; override;\r\n    class function GetFriendlyLanguageName: UnicodeString; override;\r\n    function GetRange: Pointer; override;\r\n    procedure ResetRange; override;\r\n    procedure SetRange(Value: Pointer); override;\r\n    function GetDefaultAttribute(Index: integer): TSynHighlighterAttributes; override;\r\n    function GetEol: Boolean; override;\r\n    function GetTokenID: TtkTokenKind;\r\n    function GetTokenAttribute: TSynHighlighterAttributes; override;\r\n    function GetTokenKind: integer; override;\r\n    function IsIdentChar(AChar: WideChar): Boolean; override;\r\n    procedure Next; override;\r\n  published\r\n    property CommentAttri: TSynHighlighterAttributes read fCommentAttri write fCommentAttri;\r\n    property DatatypeAttri: TSynHighlighterAttributes read fDatatypeAttri write fDatatypeAttri;\r\n    property IdentifierAttri: TSynHighlighterAttributes read fIdentifierAttri write fIdentifierAttri;\r\n    property KeyAttri: TSynHighlighterAttributes read fKeyAttri write fKeyAttri;\r\n    property NumberAttri: TSynHighlighterAttributes read fNumberAttri write fNumberAttri;\r\n    property PreprocessorAttri: TSynHighlighterAttributes read fPreprocessorAttri write fPreprocessorAttri;\r\n    property SpaceAttri: TSynHighlighterAttributes read fSpaceAttri write fSpaceAttri;\r\n    property StringAttri: TSynHighlighterAttributes read fStringAttri write fStringAttri;\r\n    property SymbolAttri: TSynHighlighterAttributes read fSymbolAttri write fSymbolAttri;\r\n  end;\r\n\r\nimplementation\r\n\r\nuses\r\n{$IFDEF SYN_CLX}\r\n  QSynEditStrConst;\r\n{$ELSE}\r\n  SynEditStrConst;\r\n{$ENDIF}\r\n\r\nconst\r\n  KeyWords: array[0..47] of UnicodeString = (\r\n    'abstract', 'any', 'attribute', 'boolean', 'case', 'char', 'const', \r\n    'context', 'custom', 'default', 'double', 'enum', 'exception', 'factory', \r\n    'FALSE', 'fixed', 'float', 'in', 'inout', 'interface', 'local', 'long', \r\n    'module', 'native', 'Object', 'octet', 'oneway', 'out', 'private', 'public', \r\n    'raises', 'readonly', 'sequence', 'short', 'string', 'struct', 'supports', \r\n    'switch', 'TRUE', 'truncatable', 'typedef', 'union', 'unsigned', \r\n    'ValueBase', 'valuetype', 'void', 'wchar', 'wstring' \r\n  );\r\n\r\n  KeyIndices: array[0..100] of Integer = (\r\n    5, 19, 17, 7, -1, -1, -1, -1, -1, 15, 18, -1, 37, -1, 24, -1, -1, -1, 44, \r\n    -1, 11, 31, -1, 25, 33, -1, -1, 42, 39, -1, -1, 36, 46, -1, 27, -1, 43, 28, \r\n    26, 20, -1, 1, 32, 6, -1, 14, 8, -1, -1, -1, -1, 0, 35, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, 45, 22, 47, -1, -1, 12, 4, -1, -1, -1, 10, -1, -1, 3, -1, 9, -1, \r\n    34, 30, 13, -1, 2, 21, 16, -1, 29, 40, -1, -1, -1, -1, -1, -1, -1, 23, -1, \r\n    38, -1, -1, 41 \r\n  );\r\n\r\n{$Q-}\r\nfunction TSynIdlSyn.HashKey(Str: PWideChar): Cardinal;\r\nbegin\r\n  Result := 0;\r\n  while IsIdentChar(Str^) do\r\n  begin\r\n    Result := Result * 612 + Ord(Str^) * 199;\r\n    inc(Str);\r\n  end;\r\n  Result := Result mod 101;\r\n  fStringLen := Str - fToIdent;\r\nend;\r\n{$Q+}\r\n\r\nfunction TSynIdlSyn.IdentKind(MayBe: PWideChar): TtkTokenKind;\r\nvar\r\n  Key: Cardinal;\r\nbegin\r\n  fToIdent := MayBe;\r\n  Key := HashKey(MayBe);\r\n  if Key <= High(fIdentFuncTable) then\r\n    Result := fIdentFuncTable[Key](KeyIndices[Key])\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nprocedure TSynIdlSyn.InitIdent;\r\nvar\r\n  i: Integer;\r\nbegin\r\n  for i := Low(fIdentFuncTable) to High(fIdentFuncTable) do\r\n    if KeyIndices[i] = -1 then\r\n      fIdentFuncTable[i] := AltFunc;\r\n\r\n  fIdentFuncTable[51] := FuncAbstract;\r\n  fIdentFuncTable[41] := FuncAny;\r\n  fIdentFuncTable[82] := FuncAttribute;\r\n  fIdentFuncTable[74] := FuncBoolean;\r\n  fIdentFuncTable[67] := FuncCase;\r\n  fIdentFuncTable[0] := FuncChar;\r\n  fIdentFuncTable[43] := FuncConst;\r\n  fIdentFuncTable[3] := FuncContext;\r\n  fIdentFuncTable[46] := FuncCustom;\r\n  fIdentFuncTable[76] := FuncDefault;\r\n  fIdentFuncTable[71] := FuncDouble;\r\n  fIdentFuncTable[20] := FuncEnum;\r\n  fIdentFuncTable[66] := FuncException;\r\n  fIdentFuncTable[80] := FuncFactory;\r\n  fIdentFuncTable[45] := FuncFalse;\r\n  fIdentFuncTable[9] := FuncFixed;\r\n  fIdentFuncTable[84] := FuncFloat;\r\n  fIdentFuncTable[2] := FuncIn;\r\n  fIdentFuncTable[10] := FuncInout;\r\n  fIdentFuncTable[1] := FuncInterface;\r\n  fIdentFuncTable[39] := FuncLocal;\r\n  fIdentFuncTable[83] := FuncLong;\r\n  fIdentFuncTable[62] := FuncModule;\r\n  fIdentFuncTable[95] := FuncNative;\r\n  fIdentFuncTable[14] := FuncObject;\r\n  fIdentFuncTable[23] := FuncOctet;\r\n  fIdentFuncTable[38] := FuncOneway;\r\n  fIdentFuncTable[34] := FuncOut;\r\n  fIdentFuncTable[37] := FuncPrivate;\r\n  fIdentFuncTable[86] := FuncPublic;\r\n  fIdentFuncTable[79] := FuncRaises;\r\n  fIdentFuncTable[21] := FuncReadonly;\r\n  fIdentFuncTable[42] := FuncSequence;\r\n  fIdentFuncTable[24] := FuncShort;\r\n  fIdentFuncTable[78] := FuncString;\r\n  fIdentFuncTable[52] := FuncStruct;\r\n  fIdentFuncTable[31] := FuncSupports;\r\n  fIdentFuncTable[12] := FuncSwitch;\r\n  fIdentFuncTable[97] := FuncTrue;\r\n  fIdentFuncTable[28] := FuncTruncatable;\r\n  fIdentFuncTable[87] := FuncTypedef;\r\n  fIdentFuncTable[100] := FuncUnion;\r\n  fIdentFuncTable[27] := FuncUnsigned;\r\n  fIdentFuncTable[36] := FuncValuebase;\r\n  fIdentFuncTable[18] := FuncValuetype;\r\n  fIdentFuncTable[61] := FuncVoid;\r\n  fIdentFuncTable[32] := FuncWchar;\r\n  fIdentFuncTable[63] := FuncWstring;\r\nend;\r\n\r\nfunction TSynIdlSyn.AltFunc(Index: Integer): TtkTokenKind;\r\nbegin\r\n  Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynIdlSyn.FuncAbstract(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynIdlSyn.FuncAny(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkDatatype\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynIdlSyn.FuncAttribute(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynIdlSyn.FuncBoolean(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkDatatype\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynIdlSyn.FuncCase(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynIdlSyn.FuncChar(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkDatatype\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynIdlSyn.FuncConst(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynIdlSyn.FuncContext(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynIdlSyn.FuncCustom(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynIdlSyn.FuncDefault(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynIdlSyn.FuncDouble(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkDatatype\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynIdlSyn.FuncEnum(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynIdlSyn.FuncException(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynIdlSyn.FuncFactory(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynIdlSyn.FuncFalse(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynIdlSyn.FuncFixed(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkDatatype\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynIdlSyn.FuncFloat(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkDatatype\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynIdlSyn.FuncIn(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynIdlSyn.FuncInout(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynIdlSyn.FuncInterface(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynIdlSyn.FuncLocal(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynIdlSyn.FuncLong(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkDatatype\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynIdlSyn.FuncModule(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynIdlSyn.FuncNative(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynIdlSyn.FuncObject(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynIdlSyn.FuncOctet(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkDatatype\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynIdlSyn.FuncOneway(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynIdlSyn.FuncOut(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynIdlSyn.FuncPrivate(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynIdlSyn.FuncPublic(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynIdlSyn.FuncRaises(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynIdlSyn.FuncReadonly(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynIdlSyn.FuncSequence(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynIdlSyn.FuncShort(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkDatatype\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynIdlSyn.FuncString(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkDatatype\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynIdlSyn.FuncStruct(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynIdlSyn.FuncSupports(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynIdlSyn.FuncSwitch(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynIdlSyn.FuncTrue(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynIdlSyn.FuncTruncatable(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynIdlSyn.FuncTypedef(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynIdlSyn.FuncUnion(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynIdlSyn.FuncUnsigned(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynIdlSyn.FuncValuebase(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynIdlSyn.FuncValuetype(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynIdlSyn.FuncVoid(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkDatatype\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynIdlSyn.FuncWchar(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkDatatype\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynIdlSyn.FuncWstring(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkDatatype\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nprocedure TSynIdlSyn.SpaceProc;\r\nbegin\r\n  inc(Run);\r\n  fTokenID := tkSpace;\r\n  while (FLine[Run] <= #32) and not IsLineEnd(Run) do inc(Run);\r\nend;\r\n\r\nprocedure TSynIdlSyn.NullProc;\r\nbegin\r\n  fTokenID := tkNull;\r\n  inc(Run);\r\nend;\r\n\r\nprocedure TSynIdlSyn.NumberProc;\r\n\r\n  function IsNumberChar: Boolean;\r\n  begin\r\n    case fLine[Run] of\r\n      '0'..'9', '.', 'e', 'E':\r\n        Result := True;\r\n      else\r\n        Result := False;\r\n    end;\r\n  end;\r\n\r\nbegin\r\n  inc(Run);\r\n  fTokenID := tkNumber;\r\n  while IsNumberChar do\r\n  begin\r\n    case FLine[Run] of\r\n      '.': if FLine[Run + 1] = '.' then\r\n             Break;\r\n    end;\r\n    inc(Run);\r\n  end;\r\nend; { NumberProc }\r\n\r\n\r\nprocedure TSynIdlSyn.CRProc;\r\nbegin\r\n  fTokenID := tkSpace;\r\n  inc(Run);\r\n  if fLine[Run] = #10 then\r\n    inc(Run);\r\nend;\r\n\r\nprocedure TSynIdlSyn.LFProc;\r\nbegin\r\n  fTokenID := tkSpace;\r\n  inc(Run);\r\nend;\r\n\r\nprocedure TSynIdlSyn.CommentOpenProc;\r\nbegin\r\n  Inc(Run);\r\n  if (fLine[Run] = '*') then\r\n  begin\r\n    fRange := rsComment;\r\n    CommentProc;\r\n    fTokenID := tkComment;\r\n  end\r\n  else if (fLine[Run] = '/') then\r\n  begin\r\n    while not IsLineEnd(Run) do\r\n      Inc(Run);\r\n    fTokenID := tkComment;\r\n  end\r\n  else\r\n    fTokenID := tkSymbol;\r\nend;\r\n\r\nprocedure TSynIdlSyn.CommentProc;\r\nbegin\r\n  case fLine[Run] of\r\n     #0: NullProc;\r\n    #10: LFProc;\r\n    #13: CRProc;\r\n  else\r\n    begin\r\n      fTokenID := tkComment;\r\n      repeat\r\n        if (fLine[Run] = '*') and\r\n           (fLine[Run + 1] = '/') then\r\n        begin\r\n          Inc(Run, 2);\r\n          fRange := rsUnKnown;\r\n          Break;\r\n        end;\r\n        if not IsLineEnd(Run) then\r\n          Inc(Run);\r\n      until IsLineEnd(Run);\r\n    end;\r\n  end;\r\nend;\r\n\r\nprocedure TSynIdlSyn.StringOpenProc;\r\nbegin\r\n  Inc(Run);\r\n  fRange := rsString;\r\n  StringProc;\r\n  fTokenID := tkString;\r\nend;\r\n\r\nprocedure TSynIdlSyn.StringProc;\r\nbegin\r\n  fTokenID := tkString;\r\n  repeat\r\n    if (fLine[Run] = '\"') then\r\n    begin\r\n      Inc(Run);\r\n      fRange := rsUnKnown;\r\n      Break;\r\n    end\r\n    else if (fLine[Run] = '\\') then\r\n      Inc(Run);\r\n    if not IsLineEnd(Run) then\r\n      Inc(Run);\r\n  until IsLineEnd(Run);\r\nend;\r\n\r\nprocedure TSynIdlSyn.CharOpenProc;\r\nbegin\r\n  Inc(Run);\r\n  fRange := rsChar;\r\n  CharProc;\r\n  fTokenID := tkString;\r\nend;\r\n\r\nprocedure TSynIdlSyn.CharProc;\r\nbegin\r\n  fTokenID := tkString;\r\n  repeat\r\n    if (fLine[Run] = '''') then\r\n    begin\r\n      Inc(Run);\r\n      fRange := rsUnKnown;\r\n      Break;\r\n    end;\r\n    if not IsLineEnd(Run) then\r\n      Inc(Run);\r\n  until IsLineEnd(Run);\r\nend;\r\n\r\nprocedure TSynIdlSyn.PreProcessorProc;\r\n\r\n  function IsWhiteChar: Boolean;\r\n  begin\r\n    case fLine[Run] of\r\n      #0, #9, #10, #13, #32:\r\n        Result := True;\r\n      else\r\n        Result := False;\r\n    end;\r\n  end;\r\n\r\nvar\r\n  Directive: String;\r\nbegin\r\n  Directive := '';\r\n  while not IsWhiteChar do\r\n  begin\r\n    Directive := Directive + fLine[Run];\r\n    Inc(Run);\r\n  end;\r\n  if (WideCompareStr(Directive, '#include') = 0) then\r\n    fTokenID := tkPreprocessor\r\n  else if (WideCompareStr(Directive, '#pragma') = 0) then\r\n    fTokenID := tkPreprocessor\r\n  else\r\n    fTokenID := tkIdentifier;\r\nend; { PreProcessorProc }\r\n\r\n\r\nconstructor TSynIdlSyn.Create(AOwner: TComponent);\r\nbegin\r\n  inherited Create(AOwner);\r\n\r\n  fCaseSensitive := True;\r\n\r\n  fCommentAttri := TSynHighLighterAttributes.Create(SYNS_AttrComment, SYNS_FriendlyAttrComment);\r\n  fCommentAttri.Style := [fsItalic];\r\n  fCommentAttri.Foreground := clNavy;\r\n  AddAttribute(fCommentAttri);\r\n\r\n  fDatatypeAttri := TSynHighLighterAttributes.Create(SYNS_AttrDatatype, SYNS_FriendlyAttrDatatype);\r\n  fDatatypeAttri.Style := [fsBold];\r\n  fDatatypeAttri.Foreground := clTeal;\r\n  AddAttribute(fDatatypeAttri);\r\n\r\n  fIdentifierAttri := TSynHighLighterAttributes.Create(SYNS_AttrIdentifier, SYNS_FriendlyAttrIdentifier);\r\n  AddAttribute(fIdentifierAttri);\r\n\r\n  fKeyAttri := TSynHighLighterAttributes.Create(SYNS_AttrReservedWord, SYNS_FriendlyAttrReservedWord);\r\n  fKeyAttri.Style := [fsBold];\r\n  AddAttribute(fKeyAttri);\r\n\r\n  fNumberAttri := TSynHighLighterAttributes.Create(SYNS_AttrNumber, SYNS_FriendlyAttrNumber);\r\n  fNumberAttri.Foreground := clBlue;\r\n  AddAttribute(fNumberAttri);\r\n\r\n  fPreprocessorAttri := TSynHighLighterAttributes.Create(SYNS_AttrPreprocessor, SYNS_FriendlyAttrPreprocessor);\r\n  fPreprocessorAttri.Foreground := clRed;\r\n  AddAttribute(fPreprocessorAttri);\r\n\r\n  fSpaceAttri := TSynHighLighterAttributes.Create(SYNS_AttrSpace, SYNS_FriendlyAttrSpace);\r\n  AddAttribute(fSpaceAttri);\r\n\r\n  fStringAttri := TSynHighLighterAttributes.Create(SYNS_AttrString, SYNS_FriendlyAttrString);\r\n  fStringAttri.Foreground := clBlue;\r\n  AddAttribute(fStringAttri);\r\n\r\n  fSymbolAttri := TSynHighLighterAttributes.Create(SYNS_AttrSymbol, SYNS_FriendlyAttrSymbol);\r\n  AddAttribute(fSymbolAttri);\r\n\r\n  SetAttributesOnChange(DefHighlightChange);\r\n  InitIdent;\r\n  fDefaultFilter := SYNS_FilterCORBAIDL;\r\n  fRange := rsUnknown;\r\nend;\r\n\r\nprocedure TSynIdlSyn.IdentProc;\r\nbegin\r\n  fTokenID := IdentKind((fLine + Run));\r\n  inc(Run, fStringLen);\r\n  while IsIdentChar(fLine[Run]) do\r\n    Inc(Run);\r\nend;\r\n\r\nprocedure TSynIdlSyn.SymbolProc;\r\nbegin\r\n  Inc(Run);\r\n  fTokenID := tkSymbol;\r\nend;\r\n\r\nprocedure TSynIdlSyn.UnknownProc;\r\nbegin\r\n  inc(Run);\r\n  fTokenID := tkUnknown;\r\nend;\r\n\r\nprocedure TSynIdlSyn.Next;\r\nbegin\r\n  fTokenPos := Run;\r\n  case fRange of\r\n    rsComment: CommentProc;\r\n  else\r\n    begin\r\n      fRange := rsUnknown;\r\n      case fLine[Run] of\r\n        #0: NullProc;\r\n        #10: LFProc;\r\n        #13: CRProc;\r\n        '/': CommentOpenProc;\r\n        '\"': StringOpenProc;\r\n        '''': CharOpenProc;\r\n        '#': PreProcessorProc;\r\n        #1..#9, #11, #12, #14..#32: SpaceProc;\r\n        'A'..'Z', 'a'..'z', '_': IdentProc;\r\n        '0'..'9': NumberProc;\r\n        '-', '+', '*', '\\', ',', '.', '[', ']', '{', '}', '<', '>', '(', ')',\r\n        '=', '?', ':', ';' : SymbolProc;\r\n      else\r\n        UnknownProc;\r\n      end;\r\n    end;\r\n  end;\r\n  inherited;\r\nend;\r\n\r\nfunction TSynIdlSyn.GetDefaultAttribute(Index: integer): TSynHighLighterAttributes;\r\nbegin\r\n  case Index of\r\n    SYN_ATTR_COMMENT: Result := fCommentAttri;\r\n    SYN_ATTR_IDENTIFIER: Result := fIdentifierAttri;\r\n    SYN_ATTR_KEYWORD: Result := fKeyAttri;\r\n    SYN_ATTR_STRING: Result := fStringAttri;\r\n    SYN_ATTR_WHITESPACE: Result := fSpaceAttri;\r\n    SYN_ATTR_SYMBOL: Result := fSymbolAttri;\r\n  else\r\n    Result := nil;\r\n  end;\r\nend;\r\n\r\nfunction TSynIdlSyn.GetEol: Boolean;\r\nbegin\r\n  Result := Run = fLineLen + 1;\r\nend;\r\n\r\nfunction TSynIdlSyn.GetTokenID: TtkTokenKind;\r\nbegin\r\n  Result := fTokenId;\r\nend;\r\n\r\nfunction TSynIdlSyn.GetTokenAttribute: TSynHighLighterAttributes;\r\nbegin\r\n  case GetTokenID of\r\n    tkComment: Result := fCommentAttri;\r\n    tkDatatype: Result := fDatatypeAttri;\r\n    tkIdentifier: Result := fIdentifierAttri;\r\n    tkKey: Result := fKeyAttri;\r\n    tkNumber: Result := fNumberAttri;\r\n    tkPreprocessor: Result := fPreprocessorAttri;\r\n    tkSpace: Result := fSpaceAttri;\r\n    tkString: Result := fStringAttri;\r\n    tkSymbol: Result := fSymbolAttri;\r\n    tkUnknown: Result := fIdentifierAttri;\r\n  else\r\n    Result := nil;\r\n  end;\r\nend;\r\n\r\nfunction TSynIdlSyn.GetTokenKind: integer;\r\nbegin\r\n  Result := Ord(fTokenId);\r\nend;\r\n\r\nfunction TSynIdlSyn.GetSampleSource: UnicodeString;\r\nbegin\r\n  Result := '/* CORBA IDL sample source */'#13#10 +\r\n            '#include '#13#10 +\r\n            #13#10 +\r\n            'const string TestString = \"Hello World\";'#13#10 +\r\n            'const long TestLong = 10;'#13#10 +\r\n            #13#10 +\r\n            'module TestModule {'#13#10 +\r\n            '  interface DemoInterface {'#13#10 +\r\n            '    boolean HelloWorld(in string Message);'#13#10 +\r\n            '  }'#13#10 +\r\n            '}';\r\nend;\r\n\r\nfunction TSynIdlSyn.IsFilterStored: Boolean;\r\nbegin\r\n  Result := fDefaultFilter <> SYNS_FilterCORBAIDL;\r\nend;\r\n\r\nfunction TSynIdlSyn.IsIdentChar(AChar: WideChar): Boolean;\r\nbegin\r\n  case AChar of\r\n    '_', 'a'..'z', 'A'..'Z':\r\n      Result := True;\r\n    else\r\n      Result := False;\r\n  end;\r\nend;\r\n\r\nclass function TSynIdlSyn.GetLanguageName: string;\r\nbegin\r\n  Result := SYNS_LangCORBAIDL;\r\nend;\r\n\r\nprocedure TSynIdlSyn.ResetRange;\r\nbegin\r\n  fRange := rsUnknown;\r\nend;\r\n\r\nprocedure TSynIdlSyn.SetRange(Value: Pointer);\r\nbegin\r\n  fRange := TRangeState(Value);\r\nend;\r\n\r\nfunction TSynIdlSyn.GetRange: Pointer;\r\nbegin\r\n  Result := Pointer(fRange);\r\nend;\r\n\r\nclass function TSynIdlSyn.GetFriendlyLanguageName: UnicodeString;\r\nbegin\r\n  Result := SYNS_FriendlyLangCORBAIDL;\r\nend;\r\n\r\ninitialization\r\n{$IFNDEF SYN_CPPB_1}\r\n  RegisterPlaceableHighlighter(TSynIdlSyn);\r\n{$ENDIF}\r\nend.\r\n"
  },
  {
    "path": "External/SynEdit/Source/SynHighlighterIni.pas",
    "content": "{-------------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: SynHighlighterIni.pas, released 2000-04-21.\r\nThe Original Code is based on the izIniSyn.pas file from the\r\nmwEdit component suite by Martin Waldenburg and other developers, the Initial\r\nAuthor of this file is Igor P. Zenkov.\r\nUnicode translation by Mal Hrz.\r\nAll Rights Reserved.\r\n\r\nContributors to the SynEdit and mwEdit projects are listed in the\r\nContributors.txt file.\r\n\r\nAlternatively, the contents of this file may be used under the terms of the\r\nGNU General Public License Version 2 or later (the \"GPL\"), in which case\r\nthe provisions of the GPL are applicable instead of those above.\r\nIf you wish to allow use of your version of this file only under the terms\r\nof the GPL and not to allow others to use your version of this file\r\nunder the MPL, indicate your decision by deleting the provisions above and\r\nreplace them with the notice and other provisions required by the GPL.\r\nIf you do not delete the provisions above, a recipient may use your version\r\nof this file under either the MPL or the GPL.\r\n\r\n$Id: SynHighlighterIni.pas,v 1.13.2.5 2008/09/14 16:25:00 maelh Exp $\r\n\r\nYou may retrieve the latest version of this file at the SynEdit home page,\r\nlocated at http://SynEdit.SourceForge.net\r\n\r\nKnown Issues:\r\n-------------------------------------------------------------------------------}\r\n{\r\n@abstract(Provides an Ini-files highlighter for SynEdit)\r\n@author(Igor P. Zenkov, converted to SynEdit by Bruno Mikkelsen )\r\n@created(1999-11-02, converted to SynEdit 2000-04-21)\r\n@lastmod(2000-04-21)\r\nThe SynHighlighterIni unit provides SynEdit with an Ini-files highlighter.\r\nThanks to Primoz Gabrijelcic, Martin Waldenburg and Michael Hieke.\r\n}\r\n\r\n{$IFNDEF QSYNHIGHLIGHTERINI}\r\nunit SynHighlighterIni;\r\n{$ENDIF}\r\n\r\n{$I SynEdit.inc}\r\n\r\ninterface\r\n\r\nuses\r\n{$IFDEF SYN_CLX}\r\n  QGraphics,\r\n  QSynEditTypes,\r\n  QSynEditHighlighter,\r\n  QSynUnicode,\r\n{$ELSE}\r\n  Graphics,\r\n  SynEditTypes,\r\n  SynEditHighlighter,\r\n  SynUnicode,\r\n{$ENDIF}\r\n  Classes;\r\n\r\ntype\r\n  TtkTokenKind = (tkComment, tkText, tkSection, tkKey, tkNull, tkNumber,\r\n    tkSpace, tkString, tkSymbol, tkUnknown);\r\n\r\ntype\r\n  TSynIniSyn = class(TSynCustomHighlighter)\r\n  private\r\n    FTokenID: TtkTokenKind;\r\n    fCommentAttri: TSynHighlighterAttributes;\r\n    fTextAttri: TSynHighlighterAttributes;\r\n    fSectionAttri: TSynHighlighterAttributes;\r\n    fKeyAttri: TSynHighlighterAttributes;\r\n    fNumberAttri: TSynHighlighterAttributes;\r\n    fSpaceAttri: TSynHighlighterAttributes;\r\n    fStringAttri: TSynHighlighterAttributes;\r\n    fSymbolAttri: TSynHighlighterAttributes;\r\n    procedure SectionOpenProc;\r\n    procedure KeyProc;\r\n    procedure CRProc;\r\n    procedure EqualProc;\r\n    procedure TextProc;\r\n    procedure LFProc;\r\n    procedure NullProc;\r\n    procedure NumberProc;\r\n    procedure SemiColonProc;\r\n    procedure SpaceProc;\r\n    procedure StringProc;  // \"\"\r\n    procedure StringProc1; // ''\r\n  protected\r\n    function GetSampleSource: UnicodeString; override;\r\n    function IsFilterStored: Boolean; override;\r\n  public\r\n    class function GetLanguageName: string; override;\r\n    class function GetFriendlyLanguageName: UnicodeString; override;\r\n  public\r\n    constructor Create(AOwner: TComponent); override;\r\n    function GetDefaultAttribute(Index: integer): TSynHighlighterAttributes;   \r\n      override;\r\n    function GetEol: Boolean; override;\r\n    function GetTokenID: TtkTokenKind;\r\n    function GetTokenAttribute: TSynHighlighterAttributes; override;\r\n    function GetTokenKind: integer; override;\r\n    procedure Next; override;\r\n  published\r\n    property CommentAttri: TSynHighlighterAttributes read fCommentAttri\r\n      write fCommentAttri;\r\n    property TextAttri: TSynHighlighterAttributes read fTextAttri\r\n      write fTextAttri;\r\n    property SectionAttri: TSynHighlighterAttributes read fSectionAttri\r\n      write fSectionAttri;\r\n    property KeyAttri: TSynHighlighterAttributes read fKeyAttri\r\n      write fKeyAttri;\r\n    property NumberAttri: TSynHighlighterAttributes read fNumberAttri\r\n      write fNumberAttri;\r\n    property SpaceAttri: TSynHighlighterAttributes read fSpaceAttri\r\n      write fSpaceAttri;\r\n    property StringAttri: TSynHighlighterAttributes read fStringAttri\r\n      write fStringAttri;\r\n    property SymbolAttri: TSynHighlighterAttributes read fSymbolAttri\r\n      write fSymbolAttri;\r\n  end;\r\n\r\nimplementation\r\n\r\nuses\r\n{$IFDEF SYN_CLX}\r\n  QSynEditStrConst;\r\n{$ELSE}\r\n  SynEditStrConst;\r\n{$ENDIF}\r\n\r\nconstructor TSynIniSyn.Create(AOwner: TComponent);\r\nbegin\r\n  inherited Create(AOwner);\r\n  fCommentAttri := TSynHighlighterAttributes.Create(SYNS_AttrComment, SYNS_FriendlyAttrComment);\r\n  fCommentAttri.Style := [fsItalic];\r\n  fCommentAttri.Foreground := clGreen;\r\n  AddAttribute(fCommentAttri);\r\n  fTextAttri := TSynHighlighterAttributes.Create(SYNS_AttrText, SYNS_FriendlyAttrText);\r\n  AddAttribute(fTextAttri);\r\n  fSectionAttri := TSynHighlighterAttributes.Create(SYNS_AttrSection, SYNS_FriendlyAttrSection);\r\n  fSectionAttri.Style := [fsBold];\r\n  AddAttribute(fSectionAttri);\r\n  fKeyAttri := TSynHighlighterAttributes.Create(SYNS_AttrKey, SYNS_FriendlyAttrKey);\r\n  AddAttribute(fKeyAttri);\r\n  fNumberAttri := TSynHighlighterAttributes.Create(SYNS_AttrNumber, SYNS_FriendlyAttrNumber);\r\n  AddAttribute(fNumberAttri);\r\n  fSpaceAttri := TSynHighlighterAttributes.Create(SYNS_AttrSpace, SYNS_FriendlyAttrSpace);\r\n  AddAttribute(fSpaceAttri);\r\n  fStringAttri := TSynHighlighterAttributes.Create(SYNS_AttrString, SYNS_FriendlyAttrString);\r\n  AddAttribute(fStringAttri);\r\n  fSymbolAttri := TSynHighlighterAttributes.Create(SYNS_AttrSymbol, SYNS_FriendlyAttrSymbol);\r\n  AddAttribute(fSymbolAttri);\r\n  SetAttributesOnChange(DefHighlightChange);\r\n\r\n  fDefaultFilter := SYNS_FilterINI;\r\nend; { Create }\r\n\r\nprocedure TSynIniSyn.SectionOpenProc;\r\nbegin\r\n  // if it is not column 0 mark as tkText and get out of here\r\n  if Run > 0 then\r\n  begin\r\n    fTokenID := tkText;\r\n    inc(Run);\r\n    Exit;\r\n  end;\r\n\r\n  // this is column 0 ok it is a Section\r\n  fTokenID := tkSection;\r\n  inc(Run);\r\n  while FLine[Run] <> #0 do\r\n    case FLine[Run] of\r\n      ']':\r\n        begin\r\n          inc(Run);\r\n          break\r\n        end;\r\n      #10: break;\r\n      #13: break;\r\n    else inc(Run);\r\n    end;\r\nend;\r\n\r\nprocedure TSynIniSyn.CRProc;\r\nbegin\r\n  fTokenID := tkSpace;\r\n  case FLine[Run + 1] of\r\n    #10: inc(Run, 2);\r\n    else inc(Run);\r\n  end;\r\nend;\r\n\r\nprocedure TSynIniSyn.EqualProc;\r\nbegin\r\n  inc(Run);\r\n  fTokenID := tkSymbol;\r\nend;\r\n\r\nprocedure TSynIniSyn.KeyProc;\r\nbegin\r\n  fTokenID := tkKey;\r\n  inc(Run);\r\n  while FLine[Run] <> #0 do\r\n    case FLine[Run] of\r\n      '=': break;\r\n      #10: break;\r\n      #13: break;\r\n      else inc(Run);\r\n    end;\r\nend;\r\n\r\nprocedure TSynIniSyn.TextProc;\r\n\r\n  function IsTextChar: Boolean;\r\n  begin\r\n    case fLine[Run] of\r\n      'a'..'z', 'A'..'Z', '0'..'9':\r\n        Result := True;\r\n      else\r\n        Result := False;\r\n    end;\r\n  end;\r\n\r\nbegin\r\n  if Run = 0 then\r\n    KeyProc\r\n  else\r\n  begin\r\n    fTokenID := tkText;\r\n    inc(Run);\r\n    while FLine[Run] <> #0 do\r\n      if IsTextChar then\r\n        inc(Run)\r\n      else\r\n        break;\r\n  end;\r\nend;\r\n\r\nprocedure TSynIniSyn.LFProc;\r\nbegin\r\n  fTokenID := tkSpace;\r\n  inc(Run);\r\nend;\r\n\r\nprocedure TSynIniSyn.NullProc;\r\nbegin\r\n  fTokenID := tkNull;\r\n  inc(Run);\r\nend;\r\n\r\nprocedure TSynIniSyn.NumberProc;\r\n\r\n  function IsNumberChar: Boolean;\r\n  begin\r\n    case fLine[Run] of\r\n      '0'..'9', '.', 'e', 'E':\r\n        Result := True;\r\n      else\r\n        Result := False;\r\n    end;\r\n  end;\r\n\r\n  function IsAlphaChar: Boolean;\r\n  begin\r\n    case fLine[Run] of\r\n      'a'..'z', 'A'..'Z':\r\n        Result := True;\r\n      else\r\n        Result := False;\r\n    end;\r\n  end;\r\n\r\nbegin\r\n  if Run = 0 then\r\n    KeyProc\r\n  else\r\n  begin\r\n    inc(Run);\r\n    fTokenID := tkNumber;\r\n    while IsNumberChar do inc(Run);\r\n    if IsAlphaChar then TextProc;\r\n  end;\r\nend;\r\n\r\n// ;\r\nprocedure TSynIniSyn.SemiColonProc;\r\nbegin\r\n  // if it is not column 0 mark as tkText and get out of here\r\n  if Run > 0 then\r\n  begin\r\n    fTokenID := tkText;\r\n    inc(Run);\r\n    Exit;\r\n  end;\r\n\r\n  // this is column 0 ok it is a comment\r\n  fTokenID := tkComment;\r\n  inc(Run);\r\n  while FLine[Run] <> #0 do\r\n    case FLine[Run] of\r\n      #10: break;\r\n      #13: break;\r\n      else inc(Run);\r\n    end;\r\nend;\r\n\r\nprocedure TSynIniSyn.SpaceProc;\r\nbegin\r\n  inc(Run);\r\n  fTokenID := tkSpace;\r\n  while (FLine[Run] <= #32) and not IsLineEnd(Run) do inc(Run);\r\nend;\r\n\r\n// \"\"\r\nprocedure TSynIniSyn.StringProc;\r\nbegin\r\n  fTokenID := tkString;\r\n  if (FLine[Run + 1] = #34) and (FLine[Run + 2] = #34) then inc(Run, 2);\r\n  repeat\r\n    case FLine[Run] of\r\n      #0, #10, #13: break;\r\n    end;\r\n    inc(Run);\r\n  until FLine[Run] = #34;\r\n  if FLine[Run] <> #0 then inc(Run);\r\nend;\r\n\r\n// ''\r\nprocedure TSynIniSyn.StringProc1;\r\nbegin\r\n  fTokenID := tkString;\r\n  if (FLine[Run + 1] = #39) and (FLine[Run + 2] = #39) then inc(Run, 2);\r\n  repeat\r\n    case FLine[Run] of\r\n      #0, #10, #13: break;\r\n    end;\r\n    inc(Run);\r\n  until FLine[Run] = #39;\r\n  if FLine[Run] <> #0 then inc(Run);\r\nend;\r\n\r\nprocedure TSynIniSyn.Next;\r\nbegin\r\n  fTokenPos := Run;\r\n  case fLine[Run] of\r\n    #0: NullProc;\r\n    #10: LFProc;\r\n    #13: CRProc;\r\n    #34: StringProc;\r\n    #39: StringProc1;\r\n    '0'..'9': NumberProc;\r\n    #59: SemiColonProc;\r\n    #61: EqualProc;\r\n    #91: SectionOpenProc;\r\n    #1..#9, #11, #12, #14..#32: SpaceProc;\r\n    else TextProc;\r\n  end;\r\n  inherited;\r\nend;\r\n\r\nfunction TSynIniSyn.GetDefaultAttribute(Index: integer): TSynHighlighterAttributes;\r\nbegin\r\n  case Index of\r\n    SYN_ATTR_COMMENT: Result := fCommentAttri;\r\n    SYN_ATTR_KEYWORD: Result := fKeyAttri;\r\n    SYN_ATTR_STRING: Result := fStringAttri;\r\n    SYN_ATTR_WHITESPACE: Result := fSpaceAttri;\r\n    SYN_ATTR_SYMBOL: Result := fSymbolAttri;\r\n  else\r\n    Result := nil;\r\n  end;\r\nend;\r\n\r\nfunction TSynIniSyn.GetEol: Boolean;\r\nbegin\r\n  Result := Run = fLineLen + 1;\r\nend;\r\n\r\nfunction TSynIniSyn.GetTokenID: TtkTokenKind;\r\nbegin\r\n  Result := fTokenId;\r\nend;\r\n\r\nfunction TSynIniSyn.GetTokenAttribute: TSynHighlighterAttributes;\r\nbegin\r\n  case fTokenID of\r\n    tkComment: Result := fCommentAttri;\r\n    tkText: Result := fTextAttri;\r\n    tkSection: Result := fSectionAttri;\r\n    tkKey: Result := fKeyAttri;\r\n    tkNumber: Result := fNumberAttri;\r\n    tkSpace: Result := fSpaceAttri;\r\n    tkString: Result := fStringAttri;\r\n    tkSymbol: Result := fSymbolAttri;\r\n    tkUnknown: Result := fTextAttri;\r\n    else Result := nil;\r\n  end;\r\nend;\r\n\r\nfunction TSynIniSyn.GetTokenKind: integer;\r\nbegin\r\n  Result := Ord(fTokenId);\r\nend;\r\n\r\nfunction TSynIniSyn.IsFilterStored: Boolean;\r\nbegin\r\n  Result := fDefaultFilter <> SYNS_FilterINI;\r\nend;\r\n\r\nclass function TSynIniSyn.GetLanguageName: string;\r\nbegin\r\n  Result := SYNS_LangINI;\r\nend;\r\n\r\nfunction TSynIniSyn.GetSampleSource: UnicodeString;\r\nbegin\r\n  Result := '; Syntax highlighting'#13#10+\r\n            '[Section]'#13#10+\r\n            'Key=value'#13#10+\r\n            'String=\"Arial\"'#13#10+\r\n            'Number=123456';\r\nend;\r\n\r\n{$IFNDEF SYN_CPPB_1}\r\nclass function TSynIniSyn.GetFriendlyLanguageName: UnicodeString;\r\nbegin\r\n  Result := SYNS_FriendlyLangINI;\r\nend;\r\n\r\ninitialization\r\n  RegisterPlaceableHighlighter(TSynIniSyn);\r\n{$ENDIF}\r\nend.\r\n"
  },
  {
    "path": "External/SynEdit/Source/SynHighlighterInno.pas",
    "content": "{-------------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: SynHighlighterInno.pas, released 2000-05-01.\r\nThe Initial Author of this file is Satya.\r\nPortions created by Satya are Copyright 2000 Satya.\r\nUnicode translation by Mal Hrz.\r\nAll Rights Reserved.\r\n\r\nContributors to the SynEdit project are listed in the Contributors.txt file.\r\n\r\nAlternatively, the contents of this file may be used under the terms of the\r\nGNU General Public License Version 2 or later (the \"GPL\"), in which case\r\nthe provisions of the GPL are applicable instead of those above.\r\nIf you wish to allow use of your version of this file only under the terms\r\nof the GPL and not to allow others to use your version of this file\r\nunder the MPL, indicate your decision by deleting the provisions above and\r\nreplace them with the notice and other provisions required by the GPL.\r\nIf you do not delete the provisions above, a recipient may use your version\r\nof this file under either the MPL or the GPL.\r\n\r\n$Id: SynHighlighterInno.pas,v 1.22.2.9 2008/09/14 16:25:00 maelh Exp $\r\n\r\nYou may retrieve the latest version of this file at the SynEdit home page,\r\nlocated at http://SynEdit.SourceForge.net\r\n\r\nKnown Issues:\r\n-------------------------------------------------------------------------------}\r\n{\r\n@abstract(Provides an Inno script file highlighter for SynEdit)\r\n@author(Satya)\r\n@created(2000-05-01)\r\n@lastmod(2001-01-23)\r\nThe SynHighlighterInno unit provides an Inno script file highlighter for SynEdit.\r\nCheck out http://www.jrsoftware.org for the free Inno Setup program,\r\nand http://www.wintax.nl/isx/ for My Inno Setup Extensions.\r\n}\r\n\r\n{$IFNDEF QSYNHIGHLIGHTERINNO}\r\nunit SynHighlighterInno;\r\n{$ENDIF}\r\n\r\n{$I SynEdit.inc}\r\n\r\ninterface\r\n\r\nuses\r\n{$IFDEF SYN_CLX}\r\n  QGraphics,\r\n  QSynEditTypes,\r\n  QSynEditHighlighter,\r\n  QSynHighlighterHashEntries,\r\n  QSynUnicode,\r\n{$ELSE}\r\n  Graphics,\r\n  SynEditTypes,\r\n  SynEditHighlighter,\r\n  SynHighlighterHashEntries,\r\n  SynUnicode,\r\n{$ENDIF}\r\n  SysUtils,\r\n  Classes;\r\n\r\ntype\r\n  TtkTokenKind = (tkComment, tkConstant, tkIdentifier, tkKey, tkKeyOrParameter,\r\n    tkNull, tkNumber, tkParameter, tkSection, tkSpace, tkString, tkSymbol,\r\n    tkUnknown);\r\n\r\n  TSynInnoSyn = class(TSynCustomHighlighter)\r\n  private\r\n    fTokenID: TtkTokenKind;\r\n    fConstantAttri: TSynHighlighterAttributes;\r\n    fCommentAttri: TSynHighlighterAttributes;\r\n    fSectionAttri: TSynHighlighterAttributes;\r\n    fParamAttri: TSynHighlighterAttributes;\r\n    fIdentifierAttri: TSynHighlighterAttributes;\r\n    fInvalidAttri: TSynHighlighterAttributes;\r\n    fKeyAttri: TSynHighlighterAttributes;\r\n    fNumberAttri: TSynHighlighterAttributes;\r\n    fSpaceAttri: TSynHighlighterAttributes;\r\n    fStringAttri: TSynHighlighterAttributes;\r\n    fSymbolAttri: TSynHighlighterAttributes;\r\n    fKeywords: TSynHashEntryList;\r\n    function HashKey(Str: PWideChar): Integer;\r\n    function IdentKind(MayBe: PWideChar): TtkTokenKind;\r\n    procedure SymbolProc;\r\n    procedure CRProc;\r\n    procedure IdentProc;\r\n    procedure LFProc;\r\n    procedure NullProc;\r\n    procedure NumberProc;\r\n    procedure SectionProc;\r\n    procedure SpaceProc;\r\n    procedure EqualProc;\r\n    procedure ConstantProc;\r\n    procedure SemiColonProc;\r\n    procedure StringProc;\r\n    procedure UnknownProc;\r\n    procedure DoAddKeyword(AKeyword: UnicodeString; AKind: integer);\r\n  protected\r\n    function IsCurrentToken(const Token: UnicodeString): Boolean; override;\r\n    function IsFilterStored: Boolean; override;\r\n  public\r\n    class function GetLanguageName: string; override;\r\n    class function GetFriendlyLanguageName: UnicodeString; override;\r\n  public\r\n    constructor Create(AOwner: TComponent); override;\r\n    destructor Destroy; override;\r\n    function GetDefaultAttribute(Index: Integer): TSynHighlighterAttributes;\r\n      override;\r\n    function GetEol: Boolean; override;\r\n    function GetTokenAttribute: TSynHighlighterAttributes; override;\r\n    function GetTokenID: TtkTokenKind;\r\n    function GetTokenKind: integer; override;\r\n    procedure Next; override;\r\n  published\r\n    property ConstantAttri: TSynHighlighterAttributes read fConstantAttri\r\n      write fConstantAttri;\r\n    property CommentAttri: TSynHighlighterAttributes read fCommentAttri\r\n      write fCommentAttri;\r\n    property IdentifierAttri: TSynHighlighterAttributes read fIdentifierAttri\r\n      write fIdentifierAttri;\r\n    property InvalidAttri: TSynHighlighterAttributes read fInvalidAttri\r\n      write fInvalidAttri;\r\n    property KeyAttri: TSynHighlighterAttributes read fKeyAttri write fKeyAttri;\r\n    property NumberAttri: TSynHighlighterAttributes read fNumberAttri\r\n      write fNumberAttri;\r\n    property ParameterAttri: TSynHighlighterAttributes read fParamAttri\r\n      write fParamAttri;\r\n    property SectionAttri: TSynHighlighterAttributes read fSectionAttri\r\n      write fSectionAttri;\r\n    property SpaceAttri: TSynHighlighterAttributes read fSpaceAttri\r\n      write fSpaceAttri;\r\n    property StringAttri: TSynHighlighterAttributes read fStringAttri\r\n      write fStringAttri;\r\n    property SymbolAttri: TSynHighlighterAttributes read fSymbolAttri\r\n      write fSymbolAttri;\r\n  end;\r\n\r\nimplementation\r\n\r\nuses\r\n{$IFDEF SYN_CLX}\r\n  QSynEditStrConst;\r\n{$ELSE}\r\n  SynEditStrConst;\r\n{$ENDIF}\r\n\r\nconst\r\n  {Note: new 'Section names' and the new 'Constants' need not be added\r\n         as they are highlighted automatically}\r\n\r\n  {Ref:  Keywords and Parameters are updated as they last appeared in\r\n         Inno Setup / ISX version 1.3.26}\r\n\r\n  Keywords: UnicodeString =\r\n    'adminprivilegesrequired,allownoicons,allowrootdirectory,allowuncpath,' +\r\n    'alwayscreateuninstallicon,alwaysrestart,alwaysshowcomponentslist,' +\r\n    'alwaysshowdironreadypage,alwaysshowgrouponreadypage,' +\r\n    'alwaysusepersonalgroup,appcopyright,appid,appmutex,appname,apppublisher,' +\r\n    'apppublisherurl,appsupporturl,appupdatesurl,appvername,appversion,' +\r\n    'attribs,backcolor,backcolor2,backcolordirection,backsolid,bits,' +\r\n    'changesassociations,check,codefile,comment,components,compression,compresslevel,copymode,'+\r\n    'createappdir,createuninstallregkey,defaultdirname,defaultgroupname,' +\r\n    'description,destdir,destname,direxistswarning,disableappenddir,' +\r\n    'disabledirexistswarning,disabledirpage,disablefinishedpage,' +\r\n    'disableprogramgrouppage,disablereadymemo,disablereadypage,' +\r\n    'disablestartupprompt,diskclustersize,disksize,diskspacemblabel,' +\r\n    'diskspanning,dontmergeduplicatefiles,enabledirdoesntexistwarning,' +\r\n    'extradiskspacerequired,filename,flags,flatcomponentslist,fontinstall,' +\r\n    'groupdescription,hotkey,iconfilename,iconindex,infoafterfile,infobeforefile,' +\r\n    'installmode,internalcompresslevel,key,licensefile,messagesfile,minversion,name,' +\r\n    'onlybelowversion,outputbasefilename,outputdir,overwriteuninstregentries,' +\r\n    'parameters,password,reservebytes,root,runonceid,section,' +\r\n    'showcomponentsizes,source,sourcedir,statusmsg,subkey,tasks,type,types,' +\r\n    'uninstalldisplayicon,uninstalldisplayname,uninstallfilesdir,' +\r\n    'uninstalliconname,uninstalllogmode,uninstallstyle,uninstallable,' +\r\n    'updateuninstalllogappname,usepreviousappdir,usepreviousgroup,' +\r\n    'useprevioustasks,useprevioussetuptype,usesetupldr,valuedata,valuename,' +\r\n    'valuetype,windowresizable,windowshowcaption,windowstartmaximized,' +\r\n    'windowvisible,wizardimagebackcolor,wizardimagefile,wizardsmallimagefile,' +\r\n    'wizardstyle,workingdir';\r\n\r\n  Parameters: UnicodeString =\r\n    'hkcc,hkcr,hkcu,hklm,hku,alwaysoverwrite,alwaysskipifsameorolder,append,' +\r\n    'binary,classic,closeonexit,comparetimestampalso,confirmoverwrite,' +\r\n    'createkeyifdoesntexist,createonlyiffileexists,createvalueifdoesntexist,' +\r\n    'deleteafterinstall,deletekey,deletevalue,dirifempty,dontcloseonexit,' +\r\n    'dontcreatekey,disablenouninstallwarning,dword,exclusive,expandsz,' +\r\n    'external,files,filesandordirs,fixed,fontisnttruetype,iscustom,isreadme,' +\r\n    'modern,multisz,new,noerror,none,normal,nowait,onlyifdestfileexists,' +\r\n    'onlyifdoesntexist,overwrite,overwritereadonly,postinstall,' +\r\n    'preservestringtype,regserver,regtypelib,restart,restartreplace,' +\r\n    'runmaximized,runminimized,sharedfile,shellexec,showcheckbox,' +\r\n    'skipifnotsilent,skipifsilent,silent,skipifdoesntexist,' +\r\n    'skipifsourcedoesntexist,unchecked,uninsalwaysuninstall,' +\r\n    'uninsclearvalue,uninsdeleteentry,uninsdeletekey,uninsdeletekeyifempty,' +\r\n    'uninsdeletesection,uninsdeletesectionifempty,uninsdeletevalue,' +\r\n    'uninsneveruninstall,useapppaths,verysilent,waituntilidle';\r\n\r\n  KeyOrParameter: UnicodeString = 'string';\r\n\r\nfunction TSynInnoSyn.HashKey(Str: PWideChar): Integer;\r\n\r\n  function GetOrd: Integer;\r\n  begin\r\n     case Str^ of\r\n       '_': Result := 1;\r\n       'a'..'z': Result := 2 + Ord(Str^) - Ord('a');\r\n       'A'..'Z': Result := 2 + Ord(Str^) - Ord('A');\r\n       else Result := 0;\r\n     end;\r\n  end;\r\n\r\nbegin\r\n  Result := 0;\r\n  while IsIdentChar(Str^) do\r\n  begin\r\n{$IFOPT Q-}\r\n    Result := 7 * Result + GetOrd;\r\n{$ELSE}\r\n    Result := (7 * Result + GetOrd) and $FFFFFF;\r\n{$ENDIF}\r\n    inc(Str);\r\n  end;\r\n  Result := Result and $1FF; // 511\r\n  fStringLen := Str - fToIdent;\r\nend;\r\n\r\nfunction TSynInnoSyn.IdentKind(MayBe: PWideChar): TtkTokenKind;\r\nvar\r\n  Entry: TSynHashEntry;\r\nbegin\r\n  fToIdent := MayBe;\r\n  Entry := fKeywords[HashKey(MayBe)];\r\n  while Assigned(Entry) do\r\n  begin\r\n    if Entry.KeywordLen > fStringLen then\r\n      break\r\n    else if Entry.KeywordLen = fStringLen then\r\n      if IsCurrentToken(Entry.Keyword) then\r\n      begin\r\n        Result := TtkTokenKind(Entry.Kind);\r\n        exit;\r\n      end;\r\n    Entry := Entry.Next;\r\n  end;\r\n  Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynInnoSyn.IsCurrentToken(const Token: UnicodeString): Boolean;\r\n  var\r\n  I: Integer;\r\n  Temp: PWideChar;\r\nbegin\r\n  Temp := fToIdent;\r\n  if Length(Token) = fStringLen then\r\n  begin\r\n    Result := True;\r\n    for i := 1 to fStringLen do\r\n    begin\r\n      if SynWideLowerCase(Temp^)[1] <> SynWideLowerCase(Token[i])[1] then\r\n      begin\r\n        Result := False;\r\n        break;\r\n      end;\r\n      inc(Temp);\r\n    end;\r\n  end\r\n  else\r\n    Result := False;\r\nend;\r\n\r\nconstructor TSynInnoSyn.Create(AOwner: TComponent);\r\nbegin\r\n  inherited Create(AOwner);\r\n  fCaseSensitive := False;\r\n\r\n  fKeywords := TSynHashEntryList.Create;\r\n\r\n  fCommentAttri := TSynHighlighterAttributes.Create(SYNS_AttrComment, SYNS_FriendlyAttrComment);\r\n  fCommentAttri.Style := [fsItalic];\r\n  fCommentAttri.Foreground := clGray;\r\n  AddAttribute(fCommentAttri);\r\n\r\n  fIdentifierAttri := TSynHighlighterAttributes.Create(SYNS_AttrIdentifier, SYNS_FriendlyAttrIdentifier);\r\n  AddAttribute(fIdentifierAttri);\r\n\r\n  fInvalidAttri := TSynHighlighterAttributes.Create(SYNS_AttrIllegalChar, SYNS_FriendlyAttrIllegalChar);\r\n  AddAttribute(fInvalidAttri);\r\n\r\n  fKeyAttri := TSynHighlighterAttributes.Create(SYNS_AttrReservedWord, SYNS_FriendlyAttrReservedWord);\r\n  fKeyAttri.Style := [fsBold];\r\n  fKeyAttri.Foreground := clNavy;\r\n  AddAttribute(fKeyAttri);\r\n\r\n  fNumberAttri := TSynHighlighterAttributes.Create(SYNS_AttrNumber, SYNS_FriendlyAttrNumber);\r\n  fNumberAttri.Foreground := clMaroon;\r\n  AddAttribute(fNumberAttri);\r\n\r\n  fSpaceAttri := TSynHighlighterAttributes.Create(SYNS_AttrSpace, SYNS_FriendlyAttrSpace);\r\n  AddAttribute(fSpaceAttri);\r\n\r\n  fStringAttri := TSynHighlighterAttributes.Create(SYNS_AttrString, SYNS_FriendlyAttrString);\r\n  fStringAttri.Foreground := clBlue;\r\n  AddAttribute(fStringAttri);\r\n\r\n  fConstantAttri := TSynHighlighterAttributes.Create(SYNS_AttrDirective, SYNS_FriendlyAttrDirective);\r\n  fConstantAttri.Style := [fsBold, fsItalic];\r\n  fConstantAttri.Foreground := clTeal;\r\n  AddAttribute(fConstantAttri);\r\n\r\n  fSymbolAttri := TSynHighlighterAttributes.Create(SYNS_AttrSymbol, SYNS_FriendlyAttrSymbol);\r\n  AddAttribute(fSymbolAttri);\r\n\r\n  //Parameters\r\n  fParamAttri := TSynHighlighterAttributes.Create(SYNS_AttrPreprocessor, SYNS_FriendlyAttrPreprocessor);\r\n  fParamAttri.Style := [fsBold];\r\n  fParamAttri.Foreground := clOlive;\r\n  AddAttribute(fParamAttri);\r\n\r\n  fSectionAttri := TSynHighlighterAttributes.Create(SYNS_AttrSection, SYNS_FriendlyAttrSection);\r\n  fSectionAttri.Style := [fsBold];\r\n  fSectionAttri.Foreground := clRed;\r\n  AddAttribute(fSectionAttri);\r\n\r\n  SetAttributesOnChange(DefHighlightChange);\r\n  EnumerateKeywords(Ord(tkKey), Keywords, IsIdentChar, DoAddKeyword);\r\n  EnumerateKeywords(Ord(tkParameter), Parameters, IsIdentChar, DoAddKeyword);\r\n  EnumerateKeywords(Ord(tkKeyOrParameter), KeyOrParameter, IsIdentChar,\r\n    DoAddKeyword);\r\n  fDefaultFilter := SYNS_FilterInno;\r\nend;\r\n\r\ndestructor TSynInnoSyn.Destroy;\r\nbegin\r\n  fKeywords.Free;\r\n  inherited Destroy;\r\nend;\r\n\r\nprocedure TSynInnoSyn.SymbolProc;\r\nbegin\r\n  fTokenID := tkSymbol;\r\n  inc(Run);\r\nend;\r\n\r\nprocedure TSynInnoSyn.CRProc;\r\nbegin\r\n  fTokenID := tkSpace;\r\n  inc(Run);\r\n  if fLine[Run] = #10 then inc(Run);\r\nend;\r\n\r\nprocedure TSynInnoSyn.EqualProc;\r\nbegin\r\n// If any word has equal (=) symbol,\r\n// then the immediately followed text is treated as string\r\n// (though it does not have quotes)\r\n  fTokenID := tkString;\r\n  repeat\r\n    Inc(Run);\r\n    if fLine[Run] = ';' then\r\n    begin\r\n      Inc(Run);\r\n      break;\r\n    end;\r\n  until IsLineEnd(Run);\r\nend;\r\n\r\nprocedure TSynInnoSyn.IdentProc;\r\nvar\r\n  LookAhead: integer;\r\nbegin\r\n  fTokenID := IdentKind((fLine + Run));\r\n  inc(Run, fStringLen);\r\n  if fTokenID = tkKeyOrParameter then\r\n  begin\r\n    LookAhead := Run;\r\n    while CharInSet(fLine[LookAhead], [#9, ' ']) do\r\n      Inc(LookAhead);\r\n    if fLine[LookAhead] = ':' then\r\n      fTokenID := tkKey\r\n    else\r\n      fTokenID := tkParameter;\r\n  end;\r\nend;\r\n\r\nprocedure TSynInnoSyn.SectionProc;\r\nbegin\r\n  // if it is not column 0 mark as tkParameter and get out of here\r\n  if Run > 0 then\r\n  begin\r\n    fTokenID := tkUnknown;\r\n    inc(Run);\r\n    Exit;\r\n  end;\r\n\r\n  // this is column 0 ok it is a Section\r\n  fTokenID := tkSection;\r\n  repeat\r\n    Inc(Run);\r\n    if fLine[Run] = ']' then\r\n    begin\r\n      Inc(Run);\r\n      break;\r\n    end;\r\n  until IsLineEnd(Run);\r\nend;\r\n\r\nprocedure TSynInnoSyn.LFProc;\r\nbegin\r\n  fTokenID := tkSpace;\r\n  inc(Run);\r\nend;\r\n\r\nprocedure TSynInnoSyn.NullProc;\r\nbegin\r\n  fTokenID := tkNull;\r\n  inc(Run);\r\nend;\r\n\r\nprocedure TSynInnoSyn.NumberProc;\r\nbegin\r\n  fTokenID := tkNumber;\r\n  repeat\r\n    Inc(Run);\r\n  until not CharInSet(fLine[Run], ['0'..'9']);\r\nend;\r\n\r\nprocedure TSynInnoSyn.ConstantProc;\r\nvar\r\n  BraceLevel, LastOpenBrace: Integer;\r\nbegin\r\n  { Much of this is based on code from the SkipPastConst function in IS's\r\n    CmnFunc2 unit. [jr] }\r\n  if fLine[Run + 1] = '{' then\r\n  begin\r\n    { '{{' is not a constant }\r\n    fTokenID := tkUnknown;\r\n    Inc(Run, 2);\r\n    Exit;\r\n  end;\r\n  fTokenID := tkConstant;\r\n  BraceLevel := 1;\r\n  LastOpenBrace := Low(Integer);\r\n  repeat\r\n    Inc(Run);\r\n    case fLine[Run] of\r\n      '{': begin\r\n             if LastOpenBrace <> Run - 1 then\r\n             begin\r\n               Inc(BraceLevel);\r\n               LastOpenBrace := Run;\r\n             end\r\n             else\r\n               { Skip over '{{' when in an embedded constant }\r\n               Dec(BraceLevel);\r\n           end;\r\n      '}': begin\r\n             Dec (BraceLevel);\r\n             if BraceLevel = 0 then\r\n             begin\r\n               Inc(Run);\r\n               Break;\r\n             end;\r\n           end;\r\n    end;\r\n  until IsLineEnd(Run);\r\nend;\r\n\r\nprocedure TSynInnoSyn.SpaceProc;\r\nbegin\r\n  fTokenID := tkSpace;\r\n  repeat\r\n    Inc(Run);\r\n  until (fLine[Run] > #32) or IsLineEnd(Run);\r\nend;\r\n\r\nprocedure TSynInnoSyn.SemiColonProc;\r\nvar\r\n  I: Integer;\r\nbegin\r\n  for I := Run-1 downto 0 do\r\n    if fLine[I] > ' ' then begin\r\n      // If the semicolon is not the first non-whitespace character on the\r\n      // line, then it isn't the start of a comment.\r\n      fTokenID := tkUnknown;\r\n      inc(Run);\r\n      Exit;\r\n    end;\r\n  fTokenID := tkComment;\r\n  repeat\r\n    Inc(Run);\r\n  until IsLineEnd(Run);\r\nend;\r\n\r\nprocedure TSynInnoSyn.StringProc;\r\nbegin\r\n  fTokenID := tkString;\r\n  repeat\r\n    Inc(Run);\r\n    if fLine[Run] = '\"' then begin\r\n      Inc(Run);\r\n      if fLine[Run] <> '\"' then // embedded \"\" does not end the string\r\n        break;\r\n    end;\r\n  until IsLineEnd(Run);\r\nend;\r\n\r\nprocedure TSynInnoSyn.UnknownProc;\r\nbegin\r\n  inc(Run);\r\n  fTokenID := tkUnknown;\r\nend;\r\n\r\nprocedure TSynInnoSyn.Next;\r\nbegin\r\n  fTokenPos := Run;\r\n  case fLine[Run] of\r\n    #13: CRProc;\r\n    'A'..'Z', 'a'..'z', '_': IdentProc;\r\n    #10: LFProc;\r\n    #0: NullProc;\r\n    '0'..'9': NumberProc;\r\n    #1..#9, #11, #12, #14..#32: SpaceProc;\r\n    #59 {';'}: SemiColonProc;\r\n    #61 {'='}: EqualProc;\r\n    #34: StringProc;\r\n    '#', ':', ',', '(', ')': SymbolProc;\r\n    '{': ConstantProc;\r\n    #91 {'['} : SectionProc;\r\n    else UnknownProc;\r\n  end;\r\n  inherited;\r\nend;\r\n\r\nfunction TSynInnoSyn.GetDefaultAttribute(Index: integer):\r\n  TSynHighlighterAttributes;\r\nbegin\r\n  case Index of\r\n    SYN_ATTR_COMMENT: Result := fCommentAttri;\r\n    SYN_ATTR_IDENTIFIER: Result := fIdentifierAttri;\r\n    SYN_ATTR_KEYWORD: Result := fKeyAttri;\r\n    SYN_ATTR_STRING: Result := fStringAttri;\r\n    SYN_ATTR_WHITESPACE: Result := fSpaceAttri;\r\n    SYN_ATTR_SYMBOL: Result := fSymbolAttri;\r\n  else\r\n    Result := nil;\r\n  end;\r\nend;\r\n\r\nfunction TSynInnoSyn.GetEol: Boolean;\r\nbegin\r\n  Result := Run = fLineLen + 1;\r\nend;\r\n\r\nfunction TSynInnoSyn.GetTokenAttribute: TSynHighlighterAttributes;\r\nbegin\r\n  case fTokenID of\r\n    tkComment: Result := fCommentAttri;\r\n    tkParameter: Result := fParamAttri;\r\n    tkSection: Result := fSectionAttri;\r\n    tkIdentifier: Result := fIdentifierAttri;\r\n    tkKey: Result := fKeyAttri;\r\n    tkNumber: Result := fNumberAttri;\r\n    tkSpace: Result := fSpaceAttri;\r\n    tkString: Result := fStringAttri;\r\n    tkConstant: Result := fConstantAttri;\r\n    tkSymbol: Result := fSymbolAttri;\r\n    tkUnknown: Result := fIdentifierAttri;\r\n  else\r\n    Result := nil;\r\n  end;\r\nend;\r\n\r\nfunction TSynInnoSyn.GetTokenKind: integer;\r\nbegin\r\n  Result := Ord(fTokenId);\r\nend;\r\n\r\nfunction TSynInnoSyn.GetTokenID: TtkTokenKind;\r\nbegin\r\n  Result := fTokenId;\r\nend;\r\n\r\nfunction TSynInnoSyn.IsFilterStored: Boolean;\r\nbegin\r\n  Result := fDefaultFilter <> SYNS_FilterInno;\r\nend;\r\n\r\nclass function TSynInnoSyn.GetLanguageName: string;\r\nbegin\r\n  Result := SYNS_LangInno;\r\nend;\r\n\r\nprocedure TSynInnoSyn.DoAddKeyword(AKeyword: UnicodeString; AKind: integer);\r\nvar\r\n  HashValue: Integer;\r\nbegin\r\n  HashValue := HashKey(PWideChar(AKeyword));\r\n  fKeywords[HashValue] := TSynHashEntry.Create(AKeyword, AKind);\r\nend;\r\n\r\nclass function TSynInnoSyn.GetFriendlyLanguageName: UnicodeString;\r\nbegin\r\n  Result := SYNS_FriendlyLangInno;\r\nend;\r\n\r\ninitialization\r\n{$IFNDEF SYN_CPPB_1}\r\n  RegisterPlaceableHighlighter(TSynInnoSyn);\r\n{$ENDIF}\r\nend.\r\n"
  },
  {
    "path": "External/SynEdit/Source/SynHighlighterJScript.pas",
    "content": "{-------------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: SynHighlighterJScript.pas, released 2000-04-14.\r\nThe Original Code is based on the mwJScript.pas file from the\r\nmwEdit component suite by Martin Waldenburg and other developers, the Initial\r\nAuthor of this file is Tony de Buys.\r\nUnicode translation by Mal Hrz.\r\nAll Rights Reserved.\r\n\r\nContributors to the SynEdit and mwEdit projects are listed in the\r\nContributors.txt file.\r\n\r\nAlternatively, the contents of this file may be used under the terms of the\r\nGNU General Public License Version 2 or later (the \"GPL\"), in which case\r\nthe provisions of the GPL are applicable instead of those above.\r\nIf you wish to allow use of your version of this file only under the terms\r\nof the GPL and not to allow others to use your version of this file\r\nunder the MPL, indicate your decision by deleting the provisions above and\r\nreplace them with the notice and other provisions required by the GPL.\r\nIf you do not delete the provisions above, a recipient may use your version\r\nof this file under either the MPL or the GPL.\r\n\r\n$Id: SynHighlighterJScript.pas,v 1.21.2.8 2008/09/14 16:25:00 maelh Exp $\r\n\r\nYou may retrieve the latest version of this file at the SynEdit home page,\r\nlocated at http://SynEdit.SourceForge.net\r\n\r\nKnown Issues:\r\n-------------------------------------------------------------------------------}\r\n{\r\n@abstract(Provides a JavaScript/JScript highlighter for SynEdit)\r\n@author(Tony De Buys [tony@lad.co.za], converted to SynEdit by David Muir )\r\n@created(December 1999, converted to SynEdit April 14, 2000)\r\n@lastmod(2000-06-23)\r\nThe SynHighlighterJScript unit provides SynEdit with a JScript/JavaScript (.js) highlighter.\r\nThe highlighter formats JavaScript source code highlighting keywords, strings, numbers and characters.\r\n}\r\n\r\n{$IFNDEF QSYNHIGHLIGHTERJSCRIPT}\r\nunit SynHighlighterJScript;\r\n{$ENDIF}\r\n\r\n{$I SynEdit.inc}\r\n\r\ninterface\r\n\r\nuses\r\n{$IFDEF SYN_CLX}\r\n  QGraphics,\r\n  QSynEditTypes,\r\n  QSynEditHighlighter,\r\n  QSynUnicode,\r\n{$ELSE}\r\n  Graphics,\r\n  Registry,\r\n  SynEditTypes,\r\n  SynEditHighlighter,\r\n  SynUnicode,\r\n{$ENDIF}\r\n  SysUtils, Classes;\r\n\r\ntype\r\n  TtkTokenKind = (tkComment, tkIdentifier, tkKey, tkNull, tkNumber, tkSpace,\r\n    tkString, tkSymbol, tkUnknown, tkNonReservedKey, tkEvent);\r\n\r\n  TRangeState = (rsUnknown, rsANSI);\r\n\r\n  PIdentFuncTableFunc = ^TIdentFuncTableFunc;\r\n  TIdentFuncTableFunc = function (Index: Integer): TtkTokenKind of object;\r\n\r\ntype\r\n  TSynJScriptSyn = class(TSynCustomHighLighter)\r\n  private\r\n    fRange: TRangeState;\r\n    FTokenID: TtkTokenKind;\r\n    fIdentFuncTable: array[0..5152] of TIdentFuncTableFunc;\r\n    fCommentAttri: TSynHighlighterAttributes;\r\n    fIdentifierAttri: TSynHighlighterAttributes;\r\n    fKeyAttri: TSynHighlighterAttributes;\r\n    fNonReservedKeyAttri: TSynHighlighterAttributes;\r\n    fEventAttri: TSynHighlighterAttributes;\r\n    fNumberAttri: TSynHighlighterAttributes;\r\n    fSpaceAttri: TSynHighlighterAttributes;\r\n    fStringAttri: TSynHighlighterAttributes;\r\n    fSymbolAttri: TSynHighlighterAttributes;\r\n    function AltFunc(Index: Integer): TtkTokenKind;\r\n    function FuncAbs(Index: Integer): TtkTokenKind;\r\n    function FuncAbstract(Index: Integer): TtkTokenKind;\r\n    function FuncAcos(Index: Integer): TtkTokenKind;\r\n    function FuncAction(Index: Integer): TtkTokenKind;\r\n    function FuncAlert(Index: Integer): TtkTokenKind;\r\n    function FuncAlign(Index: Integer): TtkTokenKind;\r\n    function FuncAlinkcolor(Index: Integer): TtkTokenKind;\r\n    function FuncAll(Index: Integer): TtkTokenKind;\r\n    function FuncAnchor(Index: Integer): TtkTokenKind;\r\n    function FuncAnchors(Index: Integer): TtkTokenKind;\r\n    function FuncAppcodename(Index: Integer): TtkTokenKind;\r\n    function FuncApplet(Index: Integer): TtkTokenKind;\r\n    function FuncApplets(Index: Integer): TtkTokenKind;\r\n    function FuncAppname(Index: Integer): TtkTokenKind;\r\n    function FuncAppversion(Index: Integer): TtkTokenKind;\r\n    function FuncArea(Index: Integer): TtkTokenKind;\r\n    function FuncArguments(Index: Integer): TtkTokenKind;\r\n    function FuncArray(Index: Integer): TtkTokenKind;\r\n    function FuncAsin(Index: Integer): TtkTokenKind;\r\n    function FuncAtan(Index: Integer): TtkTokenKind;\r\n    function FuncAtan2(Index: Integer): TtkTokenKind;\r\n    function FuncBack(Index: Integer): TtkTokenKind;\r\n    function FuncBackground(Index: Integer): TtkTokenKind;\r\n    function FuncBgcolor(Index: Integer): TtkTokenKind;\r\n    function FuncBig(Index: Integer): TtkTokenKind;\r\n    function FuncBlink(Index: Integer): TtkTokenKind;\r\n    function FuncBlur(Index: Integer): TtkTokenKind;\r\n    function FuncBody(Index: Integer): TtkTokenKind;\r\n    function FuncBold(Index: Integer): TtkTokenKind;\r\n    function FuncBoolean(Index: Integer): TtkTokenKind;\r\n    function FuncBoolean2(Index: Integer): TtkTokenKind;\r\n    function FuncBorder(Index: Integer): TtkTokenKind;\r\n    function FuncBottom(Index: Integer): TtkTokenKind;\r\n    function FuncBreak(Index: Integer): TtkTokenKind;\r\n    function FuncButton(Index: Integer): TtkTokenKind;\r\n    function FuncByte(Index: Integer): TtkTokenKind;\r\n    function FuncCall(Index: Integer): TtkTokenKind;\r\n    function FuncCallee(Index: Integer): TtkTokenKind;\r\n    function FuncCaller(Index: Integer): TtkTokenKind;\r\n    function FuncCaptureevents(Index: Integer): TtkTokenKind;\r\n    function FuncCase(Index: Integer): TtkTokenKind;\r\n    function FuncCatch(Index: Integer): TtkTokenKind;\r\n    function FuncCeil(Index: Integer): TtkTokenKind;\r\n    function FuncChar(Index: Integer): TtkTokenKind;\r\n    function FuncCharat(Index: Integer): TtkTokenKind;\r\n    function FuncCharcodeat(Index: Integer): TtkTokenKind;\r\n    function FuncCheckbox(Index: Integer): TtkTokenKind;\r\n    function FuncChecked(Index: Integer): TtkTokenKind;\r\n    function FuncClass(Index: Integer): TtkTokenKind;\r\n    function FuncClear(Index: Integer): TtkTokenKind;\r\n    function FuncClearinterval(Index: Integer): TtkTokenKind;\r\n    function FuncCleartimeout(Index: Integer): TtkTokenKind;\r\n    function FuncClick(Index: Integer): TtkTokenKind;\r\n    function FuncClose(Index: Integer): TtkTokenKind;\r\n    function FuncClosed(Index: Integer): TtkTokenKind;\r\n    function FuncColor(Index: Integer): TtkTokenKind;\r\n    function FuncComplete(Index: Integer): TtkTokenKind;\r\n    function FuncConcat(Index: Integer): TtkTokenKind;\r\n    function FuncConfirm(Index: Integer): TtkTokenKind;\r\n    function FuncConst(Index: Integer): TtkTokenKind;\r\n    function FuncConstructor(Index: Integer): TtkTokenKind;\r\n    function FuncContinue(Index: Integer): TtkTokenKind;\r\n    function FuncCookie(Index: Integer): TtkTokenKind;\r\n    function FuncCos(Index: Integer): TtkTokenKind;\r\n    function FuncCurrent(Index: Integer): TtkTokenKind;\r\n    function FuncDate(Index: Integer): TtkTokenKind;\r\n    function FuncDebugger(Index: Integer): TtkTokenKind;\r\n    function FuncDefault(Index: Integer): TtkTokenKind;\r\n    function FuncDefaultchecked(Index: Integer): TtkTokenKind;\r\n    function FuncDefaultselected(Index: Integer): TtkTokenKind;\r\n    function FuncDefaultstatus(Index: Integer): TtkTokenKind;\r\n    function FuncDefaultvalue(Index: Integer): TtkTokenKind;\r\n    function FuncDelete(Index: Integer): TtkTokenKind;\r\n    function FuncDescription(Index: Integer): TtkTokenKind;\r\n    function FuncDisplay(Index: Integer): TtkTokenKind;\r\n    function FuncDo(Index: Integer): TtkTokenKind;\r\n    function FuncDocument(Index: Integer): TtkTokenKind;\r\n    function FuncDomain(Index: Integer): TtkTokenKind;\r\n    function FuncDouble(Index: Integer): TtkTokenKind;\r\n    function FuncE(Index: Integer): TtkTokenKind;\r\n    function FuncElements(Index: Integer): TtkTokenKind;\r\n    function FuncElse(Index: Integer): TtkTokenKind;\r\n    function FuncEmbed(Index: Integer): TtkTokenKind;\r\n    function FuncEmbeds(Index: Integer): TtkTokenKind;\r\n    function FuncEnabledplugin(Index: Integer): TtkTokenKind;\r\n    function FuncEncoding(Index: Integer): TtkTokenKind;\r\n    function FuncEnum(Index: Integer): TtkTokenKind;\r\n    function FuncEscape(Index: Integer): TtkTokenKind;\r\n    function FuncEval(Index: Integer): TtkTokenKind;\r\n    function FuncEvent(Index: Integer): TtkTokenKind;\r\n    function FuncExp(Index: Integer): TtkTokenKind;\r\n    function FuncExport(Index: Integer): TtkTokenKind;\r\n    function FuncExtends(Index: Integer): TtkTokenKind;\r\n    function FuncFalse(Index: Integer): TtkTokenKind;\r\n    function FuncFgcolor(Index: Integer): TtkTokenKind;\r\n    function FuncFilename(Index: Integer): TtkTokenKind;\r\n    function FuncFileupload(Index: Integer): TtkTokenKind;\r\n    function FuncFinal(Index: Integer): TtkTokenKind;\r\n    function FuncFinally(Index: Integer): TtkTokenKind;\r\n    function FuncFind(Index: Integer): TtkTokenKind;\r\n    function FuncFixed(Index: Integer): TtkTokenKind;\r\n    function FuncFloat(Index: Integer): TtkTokenKind;\r\n    function FuncFloat2(Index: Integer): TtkTokenKind;\r\n    function FuncFloor(Index: Integer): TtkTokenKind;\r\n    function FuncFocus(Index: Integer): TtkTokenKind;\r\n    function FuncFontcolor(Index: Integer): TtkTokenKind;\r\n    function FuncFontsize(Index: Integer): TtkTokenKind;\r\n    function FuncFor(Index: Integer): TtkTokenKind;\r\n    function FuncForm(Index: Integer): TtkTokenKind;\r\n    function FuncForms(Index: Integer): TtkTokenKind;\r\n    function FuncForward(Index: Integer): TtkTokenKind;\r\n    function FuncFrame(Index: Integer): TtkTokenKind;\r\n    function FuncFrames(Index: Integer): TtkTokenKind;\r\n    function FuncFromcharcode(Index: Integer): TtkTokenKind;\r\n    function FuncFunction(Index: Integer): TtkTokenKind;\r\n    function FuncFunction2(Index: Integer): TtkTokenKind;    \r\n    function FuncGetdate(Index: Integer): TtkTokenKind;\r\n    function FuncGetday(Index: Integer): TtkTokenKind;\r\n    function FuncGetelementbyid(Index: Integer): TtkTokenKind;\r\n    function FuncGetfullyear(Index: Integer): TtkTokenKind;\r\n    function FuncGethours(Index: Integer): TtkTokenKind;\r\n    function FuncGetmilliseconds(Index: Integer): TtkTokenKind;\r\n    function FuncGetminutes(Index: Integer): TtkTokenKind;\r\n    function FuncGetmonth(Index: Integer): TtkTokenKind;\r\n    function FuncGetseconds(Index: Integer): TtkTokenKind;\r\n    function FuncGettime(Index: Integer): TtkTokenKind;\r\n    function FuncGettimezoneoffset(Index: Integer): TtkTokenKind;\r\n    function FuncGetutcdate(Index: Integer): TtkTokenKind;\r\n    function FuncGetutcday(Index: Integer): TtkTokenKind;\r\n    function FuncGetutcfullyear(Index: Integer): TtkTokenKind;\r\n    function FuncGetutchours(Index: Integer): TtkTokenKind;\r\n    function FuncGetutcmilliseconds(Index: Integer): TtkTokenKind;\r\n    function FuncGetutcminutes(Index: Integer): TtkTokenKind;\r\n    function FuncGetutcmonth(Index: Integer): TtkTokenKind;\r\n    function FuncGetutcseconds(Index: Integer): TtkTokenKind;\r\n    function FuncGetyear(Index: Integer): TtkTokenKind;\r\n    function FuncGlobal(Index: Integer): TtkTokenKind;\r\n    function FuncGo(Index: Integer): TtkTokenKind;\r\n    function FuncGoto(Index: Integer): TtkTokenKind;\r\n    function FuncHandleevent(Index: Integer): TtkTokenKind;\r\n    function FuncHash(Index: Integer): TtkTokenKind;\r\n    function FuncHeight(Index: Integer): TtkTokenKind;\r\n    function FuncHidden(Index: Integer): TtkTokenKind;\r\n    function FuncHistory(Index: Integer): TtkTokenKind;\r\n    function FuncHome(Index: Integer): TtkTokenKind;\r\n    function FuncHost(Index: Integer): TtkTokenKind;\r\n    function FuncHostname(Index: Integer): TtkTokenKind;\r\n    function FuncHref(Index: Integer): TtkTokenKind;\r\n    function FuncHspace(Index: Integer): TtkTokenKind;\r\n    function FuncIf(Index: Integer): TtkTokenKind;\r\n    function FuncImage(Index: Integer): TtkTokenKind;\r\n    function FuncImages(Index: Integer): TtkTokenKind;\r\n    function FuncImplements(Index: Integer): TtkTokenKind;\r\n    function FuncImport(Index: Integer): TtkTokenKind;\r\n    function FuncIn(Index: Integer): TtkTokenKind;\r\n    function FuncIndex(Index: Integer): TtkTokenKind;\r\n    function FuncIndexof(Index: Integer): TtkTokenKind;\r\n    function FuncInfinity(Index: Integer): TtkTokenKind;\r\n    function FuncInnerheight(Index: Integer): TtkTokenKind;\r\n    function FuncInnerwidth(Index: Integer): TtkTokenKind;\r\n    function FuncInput(Index: Integer): TtkTokenKind;\r\n    function FuncInstanceof(Index: Integer): TtkTokenKind;\r\n    function FuncInt(Index: Integer): TtkTokenKind;\r\n    function FuncInterface(Index: Integer): TtkTokenKind;\r\n    function FuncIsfinite(Index: Integer): TtkTokenKind;\r\n    function FuncIsnan(Index: Integer): TtkTokenKind;\r\n    function FuncItalics(Index: Integer): TtkTokenKind;\r\n    function FuncJava(Index: Integer): TtkTokenKind;\r\n    function FuncJavaenabled(Index: Integer): TtkTokenKind;\r\n    function FuncJoin(Index: Integer): TtkTokenKind;\r\n    function FuncLastindexof(Index: Integer): TtkTokenKind;\r\n    function FuncLastmodified(Index: Integer): TtkTokenKind;\r\n    function FuncLayer(Index: Integer): TtkTokenKind;\r\n    function FuncLayers(Index: Integer): TtkTokenKind;\r\n    function FuncLeft(Index: Integer): TtkTokenKind;\r\n    function FuncLength(Index: Integer): TtkTokenKind;\r\n    function FuncLink(Index: Integer): TtkTokenKind;\r\n    function FuncLinkcolor(Index: Integer): TtkTokenKind;\r\n    function FuncLinks(Index: Integer): TtkTokenKind;\r\n    function FuncLn10(Index: Integer): TtkTokenKind;\r\n    function FuncLn2(Index: Integer): TtkTokenKind;\r\n    function FuncLocation(Index: Integer): TtkTokenKind;\r\n    function FuncLocationbar(Index: Integer): TtkTokenKind;\r\n    function FuncLog(Index: Integer): TtkTokenKind;\r\n    function FuncLog10e(Index: Integer): TtkTokenKind;\r\n    function FuncLog2e(Index: Integer): TtkTokenKind;\r\n    function FuncLogon(Index: Integer): TtkTokenKind;\r\n    function FuncLong(Index: Integer): TtkTokenKind;\r\n    function FuncLowsrc(Index: Integer): TtkTokenKind;\r\n    function FuncMatch(Index: Integer): TtkTokenKind;\r\n    function FuncMath(Index: Integer): TtkTokenKind;\r\n    function FuncMax(Index: Integer): TtkTokenKind;\r\n    function FuncMax_value(Index: Integer): TtkTokenKind;\r\n    function FuncMenubar(Index: Integer): TtkTokenKind;\r\n    function FuncMethod(Index: Integer): TtkTokenKind;\r\n    function FuncMimetype(Index: Integer): TtkTokenKind;\r\n    function FuncMimetypes(Index: Integer): TtkTokenKind;\r\n    function FuncMin(Index: Integer): TtkTokenKind;\r\n    function FuncMin_value(Index: Integer): TtkTokenKind;\r\n    function FuncMoveby(Index: Integer): TtkTokenKind;\r\n    function FuncMoveto(Index: Integer): TtkTokenKind;\r\n    function FuncName(Index: Integer): TtkTokenKind;\r\n    function FuncNan(Index: Integer): TtkTokenKind;\r\n    function FuncNative(Index: Integer): TtkTokenKind;\r\n    function FuncNavigator(Index: Integer): TtkTokenKind;\r\n    function FuncNegative_infinity(Index: Integer): TtkTokenKind;\r\n    function FuncNetscape(Index: Integer): TtkTokenKind;\r\n    function FuncNew(Index: Integer): TtkTokenKind;\r\n    function FuncNext(Index: Integer): TtkTokenKind;\r\n    function FuncNull(Index: Integer): TtkTokenKind;\r\n    function FuncNull2(Index: Integer): TtkTokenKind;\r\n    function FuncNumber(Index: Integer): TtkTokenKind;\r\n    function FuncObject(Index: Integer): TtkTokenKind;\r\n    function FuncOnabort(Index: Integer): TtkTokenKind;\r\n    function FuncOnblur(Index: Integer): TtkTokenKind;\r\n    function FuncOnchange(Index: Integer): TtkTokenKind;\r\n    function FuncOnclick(Index: Integer): TtkTokenKind;\r\n    function FuncOndblclick(Index: Integer): TtkTokenKind;\r\n    function FuncOnerror(Index: Integer): TtkTokenKind;\r\n    function FuncOnfocus(Index: Integer): TtkTokenKind;\r\n    function FuncOnkeydown(Index: Integer): TtkTokenKind;\r\n    function FuncOnkeypress(Index: Integer): TtkTokenKind;\r\n    function FuncOnkeyup(Index: Integer): TtkTokenKind;\r\n    function FuncOnload(Index: Integer): TtkTokenKind;\r\n    function FuncOnmousedown(Index: Integer): TtkTokenKind;\r\n    function FuncOnmousemove(Index: Integer): TtkTokenKind;\r\n    function FuncOnmouseout(Index: Integer): TtkTokenKind;\r\n    function FuncOnmouseover(Index: Integer): TtkTokenKind;\r\n    function FuncOnmouseup(Index: Integer): TtkTokenKind;\r\n    function FuncOnreset(Index: Integer): TtkTokenKind;\r\n    function FuncOnselect(Index: Integer): TtkTokenKind;\r\n    function FuncOnsubmit(Index: Integer): TtkTokenKind;\r\n    function FuncOnunload(Index: Integer): TtkTokenKind;\r\n    function FuncOpen(Index: Integer): TtkTokenKind;\r\n    function FuncOpener(Index: Integer): TtkTokenKind;\r\n    function FuncOption(Index: Integer): TtkTokenKind;\r\n    function FuncOptions(Index: Integer): TtkTokenKind;\r\n    function FuncOuterheight(Index: Integer): TtkTokenKind;\r\n    function FuncOuterwidth(Index: Integer): TtkTokenKind;\r\n    function FuncPackage(Index: Integer): TtkTokenKind;\r\n    function FuncPackages(Index: Integer): TtkTokenKind;\r\n    function FuncPagex(Index: Integer): TtkTokenKind;\r\n    function FuncPagexoffset(Index: Integer): TtkTokenKind;\r\n    function FuncPagey(Index: Integer): TtkTokenKind;\r\n    function FuncPageyoffset(Index: Integer): TtkTokenKind;\r\n    function FuncParent(Index: Integer): TtkTokenKind;\r\n    function FuncParse(Index: Integer): TtkTokenKind;\r\n    function FuncParsefloat(Index: Integer): TtkTokenKind;\r\n    function FuncParseint(Index: Integer): TtkTokenKind;\r\n    function FuncPassword(Index: Integer): TtkTokenKind;\r\n    function FuncPathname(Index: Integer): TtkTokenKind;\r\n    function FuncPersonalbar(Index: Integer): TtkTokenKind;\r\n    function FuncPi(Index: Integer): TtkTokenKind;\r\n    function FuncPlatform(Index: Integer): TtkTokenKind;\r\n    function FuncPlugin(Index: Integer): TtkTokenKind;\r\n    function FuncPlugins(Index: Integer): TtkTokenKind;\r\n    function FuncPort(Index: Integer): TtkTokenKind;\r\n    function FuncPositive_infinity(Index: Integer): TtkTokenKind;\r\n    function FuncPow(Index: Integer): TtkTokenKind;\r\n    function FuncPrevious(Index: Integer): TtkTokenKind;\r\n    function FuncPrint(Index: Integer): TtkTokenKind;\r\n    function FuncPrivate(Index: Integer): TtkTokenKind;\r\n    function FuncPrompt(Index: Integer): TtkTokenKind;\r\n    function FuncProtected(Index: Integer): TtkTokenKind;\r\n    function FuncProtocol(Index: Integer): TtkTokenKind;\r\n    function FuncPrototype(Index: Integer): TtkTokenKind;\r\n    function FuncPublic(Index: Integer): TtkTokenKind;\r\n    function FuncRadio(Index: Integer): TtkTokenKind;\r\n    function FuncRandom(Index: Integer): TtkTokenKind;\r\n    function FuncReferrer(Index: Integer): TtkTokenKind;\r\n    function FuncRefresh(Index: Integer): TtkTokenKind;\r\n    function FuncRegexp(Index: Integer): TtkTokenKind;\r\n    function FuncReleaseevents(Index: Integer): TtkTokenKind;\r\n    function FuncReload(Index: Integer): TtkTokenKind;\r\n    function FuncReplace(Index: Integer): TtkTokenKind;\r\n    function FuncReset(Index: Integer): TtkTokenKind;\r\n    function FuncResizeby(Index: Integer): TtkTokenKind;\r\n    function FuncResizeto(Index: Integer): TtkTokenKind;\r\n    function FuncReturn(Index: Integer): TtkTokenKind;\r\n    function FuncReverse(Index: Integer): TtkTokenKind;\r\n    function FuncRight(Index: Integer): TtkTokenKind;\r\n    function FuncRound(Index: Integer): TtkTokenKind;\r\n    function FuncRouteevent(Index: Integer): TtkTokenKind;\r\n    function FuncScreen(Index: Integer): TtkTokenKind;\r\n    function FuncScroll(Index: Integer): TtkTokenKind;\r\n    function FuncScrollbars(Index: Integer): TtkTokenKind;\r\n    function FuncScrollby(Index: Integer): TtkTokenKind;\r\n    function FuncScrollto(Index: Integer): TtkTokenKind;\r\n    function FuncSearch(Index: Integer): TtkTokenKind;\r\n    function FuncSelect(Index: Integer): TtkTokenKind;\r\n    function FuncSelected(Index: Integer): TtkTokenKind;\r\n    function FuncSelectedindex(Index: Integer): TtkTokenKind;\r\n    function FuncSelf(Index: Integer): TtkTokenKind;\r\n    function FuncSetdate(Index: Integer): TtkTokenKind;\r\n    function FuncSetfullyear(Index: Integer): TtkTokenKind;\r\n    function FuncSethours(Index: Integer): TtkTokenKind;\r\n    function FuncSetinterval(Index: Integer): TtkTokenKind;\r\n    function FuncSetmilliseconds(Index: Integer): TtkTokenKind;\r\n    function FuncSetminutes(Index: Integer): TtkTokenKind;\r\n    function FuncSetmonth(Index: Integer): TtkTokenKind;\r\n    function FuncSetseconds(Index: Integer): TtkTokenKind;\r\n    function FuncSettime(Index: Integer): TtkTokenKind;\r\n    function FuncSettimeout(Index: Integer): TtkTokenKind;\r\n    function FuncSetutcdate(Index: Integer): TtkTokenKind;\r\n    function FuncSetutcfullyear(Index: Integer): TtkTokenKind;\r\n    function FuncSetutchours(Index: Integer): TtkTokenKind;\r\n    function FuncSetutcmilliseconds(Index: Integer): TtkTokenKind;\r\n    function FuncSetutcminutes(Index: Integer): TtkTokenKind;\r\n    function FuncSetutcmonth(Index: Integer): TtkTokenKind;\r\n    function FuncSetutcseconds(Index: Integer): TtkTokenKind;\r\n    function FuncSetyear(Index: Integer): TtkTokenKind;\r\n    function FuncShort(Index: Integer): TtkTokenKind;\r\n    function FuncSin(Index: Integer): TtkTokenKind;\r\n    function FuncSlice(Index: Integer): TtkTokenKind;\r\n    function FuncSmall(Index: Integer): TtkTokenKind;\r\n    function FuncSort(Index: Integer): TtkTokenKind;\r\n    function FuncSplit(Index: Integer): TtkTokenKind;\r\n    function FuncSqrt(Index: Integer): TtkTokenKind;\r\n    function FuncSqrt1_2(Index: Integer): TtkTokenKind;\r\n    function FuncSqrt2(Index: Integer): TtkTokenKind;\r\n    function FuncSrc(Index: Integer): TtkTokenKind;\r\n    function FuncStart(Index: Integer): TtkTokenKind;\r\n    function FuncStatic(Index: Integer): TtkTokenKind;\r\n    function FuncStatus(Index: Integer): TtkTokenKind;\r\n    function FuncStatusbar(Index: Integer): TtkTokenKind;\r\n    function FuncStop(Index: Integer): TtkTokenKind;\r\n    function FuncStrike(Index: Integer): TtkTokenKind;\r\n    function FuncString(Index: Integer): TtkTokenKind;\r\n    function FuncStyle(Index: Integer): TtkTokenKind;\r\n    function FuncSub(Index: Integer): TtkTokenKind;\r\n    function FuncSubmit(Index: Integer): TtkTokenKind;\r\n    function FuncSubstr(Index: Integer): TtkTokenKind;\r\n    function FuncSubstring(Index: Integer): TtkTokenKind;\r\n    function FuncSuffixes(Index: Integer): TtkTokenKind;\r\n    function FuncSup(Index: Integer): TtkTokenKind;\r\n    function FuncSuper(Index: Integer): TtkTokenKind;\r\n    function FuncSwitch(Index: Integer): TtkTokenKind;\r\n    function FuncSynchronized(Index: Integer): TtkTokenKind;\r\n    function FuncTags(Index: Integer): TtkTokenKind;\r\n    function FuncTaint(Index: Integer): TtkTokenKind;\r\n    function FuncTaintenabled(Index: Integer): TtkTokenKind;\r\n    function FuncTan(Index: Integer): TtkTokenKind;\r\n    function FuncTarget(Index: Integer): TtkTokenKind;\r\n    function FuncText(Index: Integer): TtkTokenKind;\r\n    function FuncTextarea(Index: Integer): TtkTokenKind;\r\n    function FuncThis(Index: Integer): TtkTokenKind;\r\n    function FuncThrow(Index: Integer): TtkTokenKind;\r\n    function FuncThrows(Index: Integer): TtkTokenKind;\r\n    function FuncTitle(Index: Integer): TtkTokenKind;\r\n    function FuncTogmtstring(Index: Integer): TtkTokenKind;\r\n    function FuncTolocalestring(Index: Integer): TtkTokenKind;\r\n    function FuncTolowercase(Index: Integer): TtkTokenKind;\r\n    function FuncToolbar(Index: Integer): TtkTokenKind;\r\n    function FuncTop(Index: Integer): TtkTokenKind;\r\n    function FuncTosource(Index: Integer): TtkTokenKind;\r\n    function FuncTostring(Index: Integer): TtkTokenKind;\r\n    function FuncTouppercase(Index: Integer): TtkTokenKind;\r\n    function FuncToutcstring(Index: Integer): TtkTokenKind;\r\n    function FuncTransient(Index: Integer): TtkTokenKind;\r\n    function FuncTrue(Index: Integer): TtkTokenKind;\r\n    function FuncTry(Index: Integer): TtkTokenKind;\r\n    function FuncType(Index: Integer): TtkTokenKind;\r\n    function FuncTypeof(Index: Integer): TtkTokenKind;\r\n    function FuncUndefined(Index: Integer): TtkTokenKind;\r\n    function FuncUnescape(Index: Integer): TtkTokenKind;\r\n    function FuncUntaint(Index: Integer): TtkTokenKind;\r\n    function FuncUnwatch(Index: Integer): TtkTokenKind;\r\n    function FuncUrl(Index: Integer): TtkTokenKind;\r\n    function FuncUseragent(Index: Integer): TtkTokenKind;\r\n    function FuncUtc(Index: Integer): TtkTokenKind;\r\n    function FuncValue(Index: Integer): TtkTokenKind;\r\n    function FuncValueof(Index: Integer): TtkTokenKind;\r\n    function FuncVar(Index: Integer): TtkTokenKind;\r\n    function FuncVisibility(Index: Integer): TtkTokenKind;\r\n    function FuncVlinkcolor(Index: Integer): TtkTokenKind;\r\n    function FuncVoid(Index: Integer): TtkTokenKind;\r\n    function FuncVspace(Index: Integer): TtkTokenKind;\r\n    function FuncWatch(Index: Integer): TtkTokenKind;\r\n    function FuncWhile(Index: Integer): TtkTokenKind;\r\n    function FuncWidth(Index: Integer): TtkTokenKind;\r\n    function FuncWindow(Index: Integer): TtkTokenKind;\r\n    function FuncWith(Index: Integer): TtkTokenKind;\r\n    function FuncWrite(Index: Integer): TtkTokenKind;\r\n    function FuncWriteln(Index: Integer): TtkTokenKind;\r\n    function FuncZindex(Index: Integer): TtkTokenKind;\r\n    function HashKey(Str: PWideChar): Cardinal;\r\n    function IdentKind(MayBe: PWideChar): TtkTokenKind;\r\n    procedure InitIdent;\r\n    procedure AndSymbolProc;\r\n    procedure CommentProc;\r\n    procedure CRProc;\r\n    procedure IdentProc;\r\n    procedure LFProc;\r\n    procedure MinusProc;\r\n    procedure ModSymbolProc;\r\n    procedure NullProc;\r\n    procedure NumberProc;\r\n    procedure OrSymbolProc;\r\n    procedure PlusProc;\r\n    procedure PointProc;\r\n    procedure SlashProc;\r\n    procedure SpaceProc;\r\n    procedure StarProc;\r\n    procedure StringProc;\r\n    procedure SymbolProc;\r\n    procedure UnknownProc;\r\n  protected\r\n    function GetSampleSource: UnicodeString; override;\r\n    function IsFilterStored: Boolean; override;\r\n  public\r\n    class function GetLanguageName: string; override;\r\n    class function GetFriendlyLanguageName: UnicodeString; override;\r\n  public\r\n    constructor Create(AOwner: TComponent); override;\r\n    function GetDefaultAttribute(Index: integer): TSynHighlighterAttributes;\r\n      override;\r\n    function GetEol: Boolean; override;\r\n    function GetRange: Pointer; override;\r\n    function GetTokenID: TtkTokenKind;\r\n    function GetTokenAttribute: TSynHighlighterAttributes; override;\r\n    function GetTokenKind: integer; override;\r\n    procedure Next; override;\r\n    procedure SetRange(Value: Pointer); override;\r\n    procedure ResetRange; override;\r\n  published\r\n    property CommentAttri: TSynHighlighterAttributes read fCommentAttri\r\n      write fCommentAttri;\r\n    property IdentifierAttri: TSynHighlighterAttributes read fIdentifierAttri\r\n      write fIdentifierAttri;\r\n    property KeyAttri: TSynHighlighterAttributes read fKeyAttri write fKeyAttri;\r\n    property NonReservedKeyAttri: TSynHighlighterAttributes read fNonReservedKeyAttri write fNonReservedKeyAttri;\r\n    property EventAttri: TSynHighlighterAttributes read fEventAttri write fEventAttri;\r\n    property NumberAttri: TSynHighlighterAttributes read fNumberAttri\r\n      write fNumberAttri;\r\n    property SpaceAttri: TSynHighlighterAttributes read fSpaceAttri\r\n      write fSpaceAttri;\r\n    property StringAttri: TSynHighlighterAttributes read fStringAttri\r\n      write fStringAttri;\r\n    property SymbolAttri: TSynHighlighterAttributes read fSymbolAttri\r\n      write fSymbolAttri;\r\n  end;\r\n\r\nimplementation\r\n\r\nuses\r\n{$IFDEF SYN_CLX}\r\n  QSynEditStrConst, Variants;\r\n{$ELSE}\r\n  SynEditStrConst;\r\n{$ENDIF}\r\n\r\nconst\r\n  KeyWords: array[0..398] of UnicodeString = (\r\n    'abs', 'abstract', 'acos', 'action', 'alert', 'align', 'alinkColor', 'all',\r\n    'All', 'anchor', 'Anchor', 'anchors', 'appCodeName', 'Applet', 'applets',\r\n    'appName', 'appVersion', 'Area', 'arguments', 'Arguments', 'Array', 'asin',\r\n    'atan', 'atan2', 'back', 'background', 'bgColor', 'big', 'blink', 'blur',\r\n    'body', 'bold', 'boolean', 'Boolean', 'border', 'bottom', 'break', 'Button',\r\n    'byte', 'call', 'callee', 'caller', 'captureEvents', 'case', 'catch',\r\n    'ceil', 'char', 'charAt', 'charCodeAt', 'Checkbox', 'checked', 'class',\r\n    'clear', 'clearInterval', 'clearTimeout', 'click', 'close', 'closed',\r\n    'color', 'complete', 'concat', 'confirm', 'const', 'constructor',\r\n    'continue', 'cookie', 'cos', 'current', 'Date', 'debugger', 'default',\r\n    'defaultChecked', 'defaultSelected', 'defaultStatus', 'defaultValue',\r\n    'delete', 'description', 'display', 'do', 'document', 'domain', 'double',\r\n    'E', 'elements', 'else', 'Embed', 'embeds', 'enabledPlugin', 'encoding',\r\n    'enum', 'escape', 'eval', 'event', 'exp', 'export', 'extends', 'false',\r\n    'fgColor', 'filename', 'FileUpload', 'final', 'finally', 'find', 'fixed',\r\n    'float', 'Float', 'floor', 'focus', 'fontcolor', 'fontsize', 'for', 'form',\r\n    'Form', 'forms', 'forward', 'Frame', 'frames', 'fromCharCode', 'function',\r\n    'Function', 'getDate', 'getDay', 'getElementById', 'getFullYear',\r\n    'getHours', 'getMilliseconds', 'getMinutes', 'getMonth', 'getSeconds',\r\n    'getTime', 'getTimezoneOffset', 'getUTCDate', 'getUTCDay', 'getUTCFullYear',\r\n    'getUTCHours', 'getUTCMilliseconds', 'getUTCMinutes', 'getUTCMonth',\r\n    'getUTCSeconds', 'getYear', 'Global', 'go', 'goto', 'handleEvent', 'hash',\r\n    'height', 'Hidden', 'history', 'History', 'home', 'host', 'hostname',\r\n    'href', 'hspace', 'if', 'Image', 'images', 'implements', 'import', 'in',\r\n    'index', 'indexOf', 'Infinity', 'innerHeight', 'innerWidth', 'input',\r\n    'instanceof', 'int', 'interface', 'isFinite', 'isNaN', 'italics', 'java',\r\n    'javaEnabled', 'join', 'lastIndexOf', 'lastModified', 'Layer', 'layers',\r\n    'left', 'length', 'link', 'Link', 'linkColor', 'links', 'LN10', 'LN2',\r\n    'location', 'Location', 'locationbar', 'log', 'LOG10E', 'LOG2E', 'logon',\r\n    'long', 'lowsrc', 'match', 'Math', 'max', 'MAX_VALUE', 'menubar', 'method',\r\n    'MimeType', 'mimeTypes', 'min', 'MIN_VALUE', 'moveBy', 'moveTo', 'name',\r\n    'NaN', 'native', 'navigator', 'Navigator', 'NEGATIVE_INFINITY', 'netscape',\r\n    'new', 'next', 'null', 'Null', 'Number', 'Object', 'onAbort', 'onBlur',\r\n    'onChange', 'onClick', 'onDblClick', 'onError', 'onFocus', 'onKeyDown',\r\n    'onKeyPress', 'onKeyUp', 'onLoad', 'onMouseDown', 'onMouseMove',\r\n    'onMouseOut', 'onMouseOver', 'onMouseUp', 'onReset', 'onSelect', 'onSubmit',\r\n    'onUnload', 'open', 'opener', 'Option', 'options', 'outerHeight',\r\n    'outerWidth', 'package', 'Packages', 'pageX', 'pageXOffset', 'pageY',\r\n    'pageYOffset', 'parent', 'parse', 'parseFloat', 'parseInt', 'Password',\r\n    'pathname', 'personalbar', 'PI', 'platform', 'Plugin', 'plugins', 'port',\r\n    'POSITIVE_INFINITY', 'pow', 'previous', 'print', 'private', 'prompt',\r\n    'protected', 'protocol', 'prototype', 'public', 'Radio', 'random',\r\n    'referrer', 'refresh', 'RegExp', 'releaseEvents', 'reload', 'replace',\r\n    'reset', 'Reset', 'resizeBy', 'resizeTo', 'return', 'reverse', 'right',\r\n    'round', 'routeEvent', 'screen', 'scroll', 'scrollbars', 'scrollBy',\r\n    'scrollTo', 'search', 'select', 'Select', 'selected', 'selectedIndex',\r\n    'self', 'setDate', 'setFullYear', 'setHours', 'setInterval',\r\n    'setMilliseconds', 'setMinutes', 'setMonth', 'setSeconds', 'setTime',\r\n    'setTimeout', 'setUTCDate', 'setUTCFullYear', 'setUTCHours',\r\n    'setUTCMilliseconds', 'setUTCMinutes', 'setUTCMonth', 'setUTCSeconds',\r\n    'setYear', 'short', 'sin', 'slice', 'small', 'sort', 'split', 'sqrt',\r\n    'SQRT1_2', 'SQRT2', 'src', 'start', 'static', 'status', 'statusbar', 'stop',\r\n    'strike', 'String', 'style', 'sub', 'submit', 'Submit', 'substr',\r\n    'substring', 'suffixes', 'sup', 'super', 'switch', 'synchronized', 'tags',\r\n    'taint', 'taintEnabled', 'tan', 'target', 'text', 'Text', 'Textarea',\r\n    'this', 'throw', 'throws', 'title', 'toGMTString', 'toLocaleString',\r\n    'toLowerCase', 'toolbar', 'top', 'toSource', 'toString', 'toUpperCase',\r\n    'toUTCString', 'transient', 'true', 'try', 'type', 'typeof', 'undefined',\r\n    'Undefined', 'unescape', 'untaint', 'unwatch', 'URL', 'userAgent', 'UTC',\r\n    'value', 'valueOf', 'var', 'visibility', 'vlinkColor', 'void', 'vspace',\r\n    'watch', 'while', 'width', 'window', 'Window', 'with', 'write', 'writeln',\r\n    'zIndex'\r\n  );\r\n\r\n  KeyIndices: array[0..5152] of Integer = (\r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, 231, -1, -1, -1, -1, -1, 296, -1, -1,\r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,\r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 55,\r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,\r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,\r\n    -1, -1, -1, -1, -1, -1, 292, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,\r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 168, -1, -1, -1, -1, -1, -1, -1,\r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 208, -1, -1, -1,\r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 200, -1, -1, -1, -1,\r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,\r\n    -1, -1, -1, -1, -1, -1, 295, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,\r\n    -1, -1, -1, -1, -1, -1, 75, 351, -1, -1, -1, -1, -1, -1, 315, 37, -1, -1,\r\n    -1, -1, -1, -1, -1, -1, -1, 239, -1, -1, -1, -1, -1, 326, -1, -1, -1, 31,\r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,\r\n    -1, -1, -1, -1, -1, -1, 143, -1, 99, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,\r\n    -1, 339, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,\r\n    -1, -1, -1, -1, -1, -1, -1, -1, 241, -1, -1, -1, -1, -1, -1, -1, -1, -1, 3,\r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,\r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 235, -1,\r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,\r\n    -1, -1, -1, 145, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,\r\n    -1, -1, 204, -1, -1, -1, -1, -1, -1, -1, -1, 110, -1, -1, -1, -1, -1, -1,\r\n    -1, -1, 16, 52, 389, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,\r\n    259, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,\r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,\r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 331, 30, -1, -1, -1, -1, -1, -1,\r\n    -1, 10, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,\r\n    -1, -1, -1, -1, -1, -1, -1, -1, 304, -1, 396, 2, -1, -1, 323, -1, -1, -1,\r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 167,\r\n    -1, -1, -1, -1, -1, -1, -1, 122, -1, -1, -1, -1, -1, -1, -1, -1, -1, 34, -1,\r\n    -1, -1, -1, 203, -1, -1, -1, -1, -1, -1, 38, -1, -1, -1, -1, -1, 83, -1, -1,\r\n    -1, -1, -1, 101, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,\r\n    268, -1, -1, -1, -1, -1, -1, -1, -1, 182, -1, -1, -1, -1, -1, 246, 18, -1,\r\n    -1, -1, -1, -1, 209, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,\r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 220, 161,\r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 134, -1, -1, -1, -1,\r\n    -1, -1, -1, -1, -1, -1, -1, -1, 332, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,\r\n    -1, -1, -1, 229, -1, -1, -1, -1, -1, -1, -1, 157, 319, -1, 210, -1, -1, -1,\r\n    -1, -1, -1, -1, -1, -1, -1, 234, -1, -1, -1, -1, -1, -1, -1, -1, -1, 105,\r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 381, 78, -1,\r\n    -1, -1, -1, -1, -1, -1, 257, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,\r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,\r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,\r\n    -1, -1, -1, -1, 219, -1, -1, -1, -1, -1, -1, -1, -1, 62, -1, -1, -1, -1, -1,\r\n    -1, -1, -1, -1, 196, -1, -1, -1, -1, -1, 379, -1, -1, -1, -1, -1, -1, -1,\r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 363, -1, -1, -1, -1, -1,\r\n    -1, -1, -1, -1, 309, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,\r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,\r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, 386, 146, -1, -1, -1, -1, -1, -1, -1,\r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 103, -1, -1, -1, -1, -1, -1,\r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,\r\n    -1, 269, -1, -1, -1, 199, 172, -1, 15, 123, -1, -1, -1, -1, -1, -1, -1, 136,\r\n    -1, -1, -1, 128, -1, -1, -1, -1, 366, -1, -1, 185, -1, -1, -1, -1, 153, -1,\r\n    -1, -1, -1, 388, -1, -1, 165, -1, -1, -1, -1, -1, -1, 338, -1, -1, -1, -1,\r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 360, -1, -1,\r\n    194, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 77, -1, -1,\r\n    -1, -1, -1, -1, -1, -1, -1, -1, 307, -1, -1, -1, -1, -1, -1, -1, 258, -1,\r\n    -1, -1, 96, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 180, -1, -1,\r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, 69, -1, -1, -1, -1, -1, -1, 129, -1, -1,\r\n    -1, -1, -1, -1, -1, -1, 120, -1, -1, 95, -1, 233, -1, -1, -1, -1, -1, -1,\r\n    -1, -1, 40, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 160, -1, -1, -1, -1,\r\n    -1, -1, -1, -1, -1, 90, 282, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,\r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 341, 232, 121, 155, -1,\r\n    -1, -1, -1, -1, 247, -1, -1, -1, -1, 67, -1, -1, -1, -1, -1, -1, -1, -1, -1,\r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,\r\n    -1, -1, -1, -1, -1, -1, -1, 327, -1, -1, -1, -1, -1, -1, -1, -1, -1, 74, -1,\r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,\r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 170, -1, -1, -1, -1, 298, -1,\r\n    -1, -1, -1, -1, -1, -1, 114, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,\r\n    -1, -1, -1, -1, -1, -1, 94, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,\r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 271, -1, -1, -1,\r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 324, -1, -1, -1,\r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,\r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,\r\n    -1, -1, 70, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,\r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,\r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,\r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 197, -1, -1, -1, -1, -1, -1, -1, -1,\r\n    -1, -1, 91, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,\r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, 106, -1, -1, 237, -1, -1, -1, -1, -1, 6,\r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,\r\n    -1, -1, -1, -1, -1, -1, -1, 240, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,\r\n    -1, -1, -1, -1, 250, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,\r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,\r\n    -1, -1, -1, 205, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 238, -1, -1, -1,\r\n    -1, -1, -1, -1, -1, 275, -1, -1, -1, -1, -1, -1, -1, -1, -1, 287, -1, -1,\r\n    -1, -1, -1, -1, -1, 227, -1, -1, 383, -1, -1, -1, -1, -1, -1, -1, -1, -1,\r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,\r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,\r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,\r\n    58, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,\r\n    -1, -1, 29, 148, 171, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,\r\n    -1, -1, -1, -1, 392, -1, -1, -1, -1, -1, 125, -1, -1, -1, -1, -1, -1, -1,\r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,\r\n    -1, -1, -1, -1, -1, 201, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,\r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 135, -1, -1, 212,\r\n    -1, -1, -1, -1, -1, -1, 14, -1, -1, -1, -1, -1, -1, -1, -1, -1, 272, -1, -1,\r\n    -1, -1, -1, -1, -1, -1, 27, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 334,\r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,\r\n    -1, 289, -1, -1, -1, -1, 312, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,\r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 385, -1, -1,\r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 51, -1, -1, -1,\r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, 104, -1, -1, -1, -1, -1, -1, 371, 76,\r\n    -1, -1, 330, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,\r\n    -1, -1, -1, -1, -1, -1, 68, -1, -1, -1, -1, -1, -1, 225, -1, -1, -1, -1, -1,\r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 119, -1, -1, -1, -1,\r\n    -1, -1, -1, -1, -1, -1, 13, -1, -1, -1, 156, -1, 23, -1, -1, -1, -1, -1, -1,\r\n    -1, -1, 280, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 178, -1, -1,\r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,\r\n    -1, -1, 277, -1, -1, -1, -1, -1, -1, 17, -1, -1, -1, -1, -1, -1, -1, 93, -1,\r\n    -1, -1, -1, -1, -1, -1, 202, -1, 5, 343, -1, -1, -1, -1, -1, -1, -1, -1, -1,\r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 255, -1, -1, -1, -1, -1, -1, -1,\r\n    -1, 43, -1, -1, -1, 44, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,\r\n    -1, -1, -1, -1, -1, -1, -1, -1, 50, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,\r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,\r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 1, -1, -1, -1, -1, -1,\r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,\r\n    -1, -1, -1, -1, -1, -1, 333, -1, -1, -1, -1, -1, 12, -1, -1, -1, -1, 139,\r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 320, -1, -1, -1, -1, -1, -1,\r\n    214, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 152, -1, -1, -1,\r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,\r\n    -1, 278, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 302, 316, -1, -1,\r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 137, -1, -1, -1,\r\n    254, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,\r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,\r\n    -1, -1, 86, -1, -1, -1, -1, -1, -1, -1, -1, 345, -1, -1, 144, -1, -1, -1, 7,\r\n    -1, -1, 306, -1, -1, -1, -1, 113, -1, -1, -1, -1, -1, -1, 308, -1, -1, -1,\r\n    -1, 357, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,\r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 36, -1, -1, -1, -1, -1, -1, -1, -1,\r\n    -1, -1, -1, 361, -1, -1, -1, -1, -1, -1, -1, 195, -1, -1, -1, -1, -1, -1,\r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 387, -1,\r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, 169, -1, -1, -1, -1, -1, -1, -1, -1, -1,\r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, 376, -1, -1, -1, -1, 188, -1, -1, -1,\r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 359, 98, -1, -1, -1,\r\n    -1, -1, -1, -1, 11, -1, -1, -1, -1, -1, 116, -1, -1, -1, -1, -1, -1, -1, -1,\r\n    -1, 299, -1, -1, -1, 369, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,\r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,\r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,\r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,\r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,\r\n    -1, 54, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,\r\n    -1, 147, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,\r\n    -1, -1, -1, 118, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,\r\n    356, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,\r\n    -1, -1, -1, -1, -1, -1, 8, -1, 300, -1, -1, 228, 59, -1, -1, -1, -1, -1, -1,\r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,\r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 213, -1, -1, -1, -1, -1, -1, -1,\r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 179, -1, -1, -1, -1, -1,\r\n    -1, -1, 176, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 350, -1, -1, -1, -1,\r\n    -1, -1, 284, -1, -1, -1, 256, -1, -1, 276, -1, -1, -1, -1, -1, -1, -1, -1,\r\n    190, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,\r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 102, -1, 230, -1, -1, -1,\r\n    -1, -1, -1, -1, -1, -1, -1, -1, 35, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,\r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 72, -1, 71, 26, -1, -1, -1, -1,\r\n    -1, -1, 60, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,\r\n    -1, -1, -1, -1, 322, -1, -1, 175, -1, -1, 393, -1, 124, 85, -1, -1, -1, -1,\r\n    -1, -1, -1, -1, 150, -1, 236, -1, -1, -1, -1, -1, -1, -1, -1, -1, 140, -1,\r\n    -1, -1, -1, -1, -1, 183, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,\r\n    -1, -1, -1, -1, -1, -1, -1, 111, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,\r\n    -1, -1, -1, -1, -1, -1, -1, 20, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,\r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,\r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,\r\n    42, 244, -1, -1, -1, -1, -1, -1, -1, 47, 313, -1, 41, -1, -1, -1, -1, -1,\r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,\r\n    -1, -1, -1, -1, -1, 63, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 64,\r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,\r\n    294, -1, -1, -1, -1, -1, -1, -1, -1, 374, -1, -1, -1, -1, -1, -1, -1, 245,\r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, 177, -1, -1, -1, -1, -1, -1, -1, -1, -1,\r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,\r\n    -1, -1, 347, -1, -1, -1, -1, -1, -1, -1, 391, -1, -1, -1, -1, -1, -1, -1,\r\n    217, -1, -1, -1, 87, -1, -1, -1, 329, -1, -1, -1, -1, -1, -1, -1, -1, -1,\r\n    39, -1, -1, -1, -1, -1, -1, -1, -1, 189, -1, -1, 222, -1, -1, -1, -1, -1,\r\n    -1, -1, -1, -1, -1, -1, -1, 174, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,\r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,\r\n    274, -1, -1, -1, -1, 33, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,\r\n    382, -1, -1, -1, 138, 226, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,\r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,\r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,\r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 192, -1, -1, -1, -1, -1, -1,\r\n    -1, -1, -1, 24, -1, -1, -1, -1, -1, -1, -1, -1, 100, -1, -1, -1, -1, -1, -1,\r\n    -1, -1, 318, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 335,\r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,\r\n    -1, -1, -1, -1, 260, -1, -1, -1, -1, -1, -1, 191, -1, -1, -1, -1, -1, -1,\r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,\r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 288, -1, -1, -1, -1, -1, -1, -1,\r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,\r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 342, -1, -1, -1, -1, -1, -1,\r\n    61, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 377, -1, -1, -1,\r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 132, -1, -1, -1, -1,\r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,\r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,\r\n    -1, -1, -1, 158, -1, -1, 166, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,\r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 73, -1, -1, -1, -1, -1, -1, -1, 57,\r\n    -1, -1, -1, 211, -1, -1, -1, -1, 243, -1, -1, -1, -1, -1, 264, -1, -1, -1,\r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,\r\n    -1, -1, -1, -1, -1, -1, -1, -1, 321, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,\r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 207, -1, -1,\r\n    216, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,\r\n    149, -1, -1, -1, -1, -1, 89, -1, -1, -1, -1, -1, -1, -1, 48, -1, -1, 293,\r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, 117, -1, -1, -1, -1, 242, -1, -1, -1,\r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,\r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 56,\r\n    -1, 154, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,\r\n    -1, -1, -1, -1, 92, 193, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,\r\n    325, 126, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,\r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,\r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, 206, -1, -1, -1, -1, -1, -1, -1, -1, -1,\r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 372, -1, -1, -1, 380, -1, -1,\r\n    352, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,\r\n    -1, -1, 263, -1, -1, -1, -1, -1, -1, -1, 373, -1, -1, -1, -1, -1, -1, -1,\r\n    -1, -1, -1, 286, -1, 46, -1, -1, -1, -1, 184, -1, -1, -1, -1, -1, -1, 19,\r\n    -1, -1, -1, 25, -1, -1, -1, -1, -1, -1, -1, 367, -1, -1, -1, -1, -1, 270,\r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 283,\r\n    -1, -1, -1, -1, -1, -1, -1, -1, 151, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,\r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 65, -1, -1, -1,\r\n    -1, -1, -1, -1, 398, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 252,\r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 355, -1, -1, 365, -1, -1, -1,\r\n    -1, -1, -1, -1, -1, 28, -1, -1, 378, -1, -1, -1, -1, 354, -1, -1, -1, -1,\r\n    -1, -1, -1, -1, 349, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 97, -1,\r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 107, -1, -1, -1, -1, 285,\r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 21, -1, -1, -1, -1,\r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 215, -1, -1, -1, -1,\r\n    -1, -1, -1, -1, -1, -1, -1, -1, 198, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,\r\n    -1, -1, 81, 394, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,\r\n    -1, -1, -1, -1, -1, -1, -1, 32, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,\r\n    -1, -1, -1, -1, -1, 358, -1, -1, -1, -1, -1, -1, -1, 173, -1, -1, -1, -1,\r\n    -1, -1, -1, -1, -1, -1, 224, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,\r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 181, -1, -1, -1, -1,\r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,\r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 375,\r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,\r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,\r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,\r\n    -1, -1, -1, -1, -1, 4, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,\r\n    -1, 9, -1, -1, -1, -1, -1, 305, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 141,\r\n    281, 115, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 84, -1, -1, -1, -1, -1,\r\n    -1, -1, 261, -1, -1, -1, -1, 265, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,\r\n    273, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 362, -1, 290, -1, 66, -1, -1,\r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 112, -1, -1, -1, -1,\r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,\r\n    131, -1, 279, -1, -1, -1, 249, -1, -1, -1, -1, -1, -1, 223, -1, -1, -1, -1,\r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 49, -1, -1, -1, -1, -1, -1, -1,\r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 297, -1, -1, -1, -1,\r\n    127, -1, -1, 142, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,\r\n    -1, -1, -1, -1, -1, -1, -1, 53, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,\r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,\r\n    -1, -1, -1, -1, -1, -1, 364, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,\r\n    -1, -1, -1, 88, -1, -1, -1, -1, -1, -1, 248, -1, -1, -1, -1, -1, -1, -1, -1,\r\n    -1, -1, -1, 395, 251, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,\r\n    -1, 45, -1, -1, -1, -1, -1, -1, -1, -1, 80, -1, -1, -1, -1, -1, -1, -1, -1,\r\n    -1, -1, -1, -1, -1, 310, -1, 218, -1, -1, -1, -1, -1, -1, 187, -1, -1, -1,\r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, 130, 390, -1, -1, -1, -1, -1, -1, -1,\r\n    328, -1, 221, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,\r\n    -1, -1, -1, -1, -1, -1, 336, -1, -1, -1, -1, -1, -1, 311, -1, -1, -1, -1,\r\n    -1, -1, -1, -1, 303, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,\r\n    -1, -1, -1, 108, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 344, -1, -1, -1,\r\n    -1, -1, -1, -1, -1, -1, -1, 337, -1, -1, -1, -1, -1, 262, -1, -1, -1, -1,\r\n    -1, -1, -1, 267, -1, -1, -1, -1, -1, -1, -1, 253, -1, -1, -1, -1, -1, -1,\r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 397, -1, -1,\r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,\r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,\r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,\r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 162, -1,\r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 109, -1, -1, -1, -1, -1, -1,\r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 346, -1, -1, -1, -1,\r\n    -1, -1, -1, -1, -1, -1, -1, -1, 0, -1, 348, 159, -1, -1, -1, -1, -1, -1, -1,\r\n    368, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 370, -1, -1, -1, -1,\r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 164, -1, 314, -1, -1,\r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,\r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, 291, -1, -1, -1, -1, -1, -1, 384, -1,\r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, 82, -1, -1, -1, -1, -1, -1, 340, -1, -1,\r\n    -1, -1, -1, -1, 317, -1, 79, -1, -1, -1, -1, 133, -1, -1, -1, -1, -1, -1,\r\n    353, -1, 301, -1, -1, -1, -1, -1, -1, 163, -1, -1, -1, -1, -1, -1, -1, -1,\r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 22, -1, -1, -1, -1, -1, -1,\r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 266, -1, -1, -1, -1, -1,\r\n    -1, -1, -1, -1, -1, -1, 186, -1, -1, -1\r\n  );\r\n\r\n{$Q-}\r\nfunction TSynJScriptSyn.HashKey(Str: PWideChar): Cardinal;\r\nbegin\r\n  Result := 0;\r\n  while IsIdentChar(Str^) do\r\n  begin\r\n    Result := Result * 751 + Ord(Str^) * 148;\r\n    inc(Str);\r\n  end;\r\n  Result := Result mod 5153;\r\n  fStringLen := Str - fToIdent;\r\nend;\r\n{$Q+}\r\n\r\nfunction TSynJScriptSyn.IdentKind(MayBe: PWideChar): TtkTokenKind;\r\nvar\r\n  Key: Cardinal;\r\nbegin\r\n  fToIdent := MayBe;\r\n  Key := HashKey(MayBe);\r\n  if Key <= High(fIdentFuncTable) then\r\n    Result := fIdentFuncTable[Key](KeyIndices[Key])\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nprocedure TSynJScriptSyn.InitIdent;\r\nvar\r\n  i: Integer;\r\nbegin\r\n  for i := Low(fIdentFuncTable) to High(fIdentFuncTable) do\r\n    if KeyIndices[i] = -1 then\r\n      fIdentFuncTable[i] := AltFunc;\r\n\r\n  fIdentFuncTable[4966] := FuncAbs;\r\n  fIdentFuncTable[2170] := FuncAbstract;\r\n  fIdentFuncTable[520] := FuncAcos;\r\n  fIdentFuncTable[319] := FuncAction;\r\n  fIdentFuncTable[4368] := FuncAlert;\r\n  fIdentFuncTable[2070] := FuncAlign;\r\n  fIdentFuncTable[1500] := FuncAlinkcolor;\r\n  fIdentFuncTable[2362] := FuncAll;\r\n  fIdentFuncTable[2706] := FuncAll;\r\n  fIdentFuncTable[4383] := FuncAnchor;\r\n  fIdentFuncTable[491] := FuncAnchor;\r\n  fIdentFuncTable[2516] := FuncAnchors;\r\n  fIdentFuncTable[2207] := FuncAppcodename;\r\n  fIdentFuncTable[1993] := FuncApplet;\r\n  fIdentFuncTable[1805] := FuncApplets;\r\n  fIdentFuncTable[965] := FuncAppname;\r\n  fIdentFuncTable[416] := FuncAppversion;\r\n  fIdentFuncTable[2052] := FuncArea;\r\n  fIdentFuncTable[618] := FuncArguments;\r\n  fIdentFuncTable[3950] := FuncArguments;\r\n  fIdentFuncTable[2987] := FuncArray;\r\n  fIdentFuncTable[4131] := FuncAsin;\r\n  fIdentFuncTable[5117] := FuncAtan;\r\n  fIdentFuncTable[1999] := FuncAtan2;\r\n  fIdentFuncTable[3356] := FuncBack;\r\n  fIdentFuncTable[3954] := FuncBackground;\r\n  fIdentFuncTable[2882] := FuncBgcolor;\r\n  fIdentFuncTable[1824] := FuncBig;\r\n  fIdentFuncTable[4067] := FuncBlink;\r\n  fIdentFuncTable[1709] := FuncBlur;\r\n  fIdentFuncTable[483] := FuncBody;\r\n  fIdentFuncTable[243] := FuncBold;\r\n  fIdentFuncTable[4200] := FuncBoolean;\r\n  fIdentFuncTable[3265] := FuncBoolean2;\r\n  fIdentFuncTable[563] := FuncBorder;\r\n  fIdentFuncTable[2857] := FuncBottom;\r\n  fIdentFuncTable[2410] := FuncBreak;\r\n  fIdentFuncTable[223] := FuncButton;\r\n  fIdentFuncTable[575] := FuncByte;\r\n  fIdentFuncTable[3204] := FuncCall;\r\n  fIdentFuncTable[1125] := FuncCallee;\r\n  fIdentFuncTable[3049] := FuncCaller;\r\n  fIdentFuncTable[3037] := FuncCaptureevents;\r\n  fIdentFuncTable[2101] := FuncCase;\r\n  fIdentFuncTable[2105] := FuncCatch;\r\n  fIdentFuncTable[4662] := FuncCeil;\r\n  fIdentFuncTable[3938] := FuncChar;\r\n  fIdentFuncTable[3046] := FuncCharat;\r\n  fIdentFuncTable[3724] := FuncCharcodeat;\r\n  fIdentFuncTable[4522] := FuncCheckbox;\r\n  fIdentFuncTable[2127] := FuncChecked;\r\n  fIdentFuncTable[1908] := FuncClass;\r\n  fIdentFuncTable[417] := FuncClear;\r\n  fIdentFuncTable[4574] := FuncClearinterval;\r\n  fIdentFuncTable[2626] := FuncCleartimeout;\r\n  fIdentFuncTable[55] := FuncClick;\r\n  fIdentFuncTable[3783] := FuncClose;\r\n  fIdentFuncTable[3615] := FuncClosed;\r\n  fIdentFuncTable[1688] := FuncColor;\r\n  fIdentFuncTable[2712] := FuncComplete;\r\n  fIdentFuncTable[2889] := FuncConcat;\r\n  fIdentFuncTable[3503] := FuncConfirm;\r\n  fIdentFuncTable[820] := FuncConst;\r\n  fIdentFuncTable[3079] := FuncConstructor;\r\n  fIdentFuncTable[3092] := FuncContinue;\r\n  fIdentFuncTable[4022] := FuncCookie;\r\n  fIdentFuncTable[4452] := FuncCos;\r\n  fIdentFuncTable[1188] := FuncCurrent;\r\n  fIdentFuncTable[1955] := FuncDate;\r\n  fIdentFuncTable[1095] := FuncDebugger;\r\n  fIdentFuncTable[1389] := FuncDefault;\r\n  fIdentFuncTable[2881] := FuncDefaultchecked;\r\n  fIdentFuncTable[2879] := FuncDefaultselected;\r\n  fIdentFuncTable[3607] := FuncDefaultstatus;\r\n  fIdentFuncTable[1234] := FuncDefaultvalue;\r\n  fIdentFuncTable[214] := FuncDelete;\r\n  fIdentFuncTable[1929] := FuncDescription;\r\n  fIdentFuncTable[1046] := FuncDisplay;\r\n  fIdentFuncTable[748] := FuncDo;\r\n  fIdentFuncTable[5075] := FuncDocument;\r\n  fIdentFuncTable[4671] := FuncDomain;\r\n  fIdentFuncTable[4176] := FuncDouble;\r\n  fIdentFuncTable[5059] := FuncE;\r\n  fIdentFuncTable[581] := FuncElements;\r\n  fIdentFuncTable[4413] := FuncElse;\r\n  fIdentFuncTable[2919] := FuncEmbed;\r\n  fIdentFuncTable[2346] := FuncEmbeds;\r\n  fIdentFuncTable[3190] := FuncEnabledplugin;\r\n  fIdentFuncTable[4627] := FuncEncoding;\r\n  fIdentFuncTable[3716] := FuncEnum;\r\n  fIdentFuncTable[1147] := FuncEscape;\r\n  fIdentFuncTable[1465] := FuncEval;\r\n  fIdentFuncTable[3807] := FuncEvent;\r\n  fIdentFuncTable[2060] := FuncExp;\r\n  fIdentFuncTable[1298] := FuncExport;\r\n  fIdentFuncTable[1114] := FuncExtends;\r\n  fIdentFuncTable[1069] := FuncFalse;\r\n  fIdentFuncTable[4097] := FuncFgcolor;\r\n  fIdentFuncTable[2508] := FuncFilename;\r\n  fIdentFuncTable[271] := FuncFileupload;\r\n  fIdentFuncTable[3365] := FuncFinal;\r\n  fIdentFuncTable[587] := FuncFinally;\r\n  fIdentFuncTable[2843] := FuncFind;\r\n  fIdentFuncTable[931] := FuncFixed;\r\n  fIdentFuncTable[1921] := FuncFloat;\r\n  fIdentFuncTable[730] := FuncFloat2;\r\n  fIdentFuncTable[1491] := FuncFloor;\r\n  fIdentFuncTable[4111] := FuncFocus;\r\n  fIdentFuncTable[4774] := FuncFontcolor;\r\n  fIdentFuncTable[4932] := FuncFontsize;\r\n  fIdentFuncTable[407] := FuncFor;\r\n  fIdentFuncTable[2968] := FuncForm;\r\n  fIdentFuncTable[4469] := FuncForm;\r\n  fIdentFuncTable[2370] := FuncForms;\r\n  fIdentFuncTable[1279] := FuncForward;\r\n  fIdentFuncTable[4402] := FuncFrame;\r\n  fIdentFuncTable[2522] := FuncFrames;\r\n  fIdentFuncTable[3737] := FuncFromcharcode;\r\n  fIdentFuncTable[2666] := FuncFunction;\r\n  fIdentFuncTable[1982] := FuncFunction2;\r\n  fIdentFuncTable[1111] := FuncGetdate;\r\n  fIdentFuncTable[1176] := FuncGetday;\r\n  fIdentFuncTable[553] := FuncGetelementbyid;\r\n  fIdentFuncTable[966] := FuncGetfullyear;\r\n  fIdentFuncTable[2918] := FuncGethours;\r\n  fIdentFuncTable[1735] := FuncGetmilliseconds;\r\n  fIdentFuncTable[3823] := FuncGetminutes;\r\n  fIdentFuncTable[4549] := FuncGetmonth;\r\n  fIdentFuncTable[978] := FuncGetseconds;\r\n  fIdentFuncTable[1102] := FuncGettime;\r\n  fIdentFuncTable[4707] := FuncGettimezoneoffset;\r\n  fIdentFuncTable[4493] := FuncGetutcdate;\r\n  fIdentFuncTable[3536] := FuncGetutcday;\r\n  fIdentFuncTable[5080] := FuncGetutcfullyear;\r\n  fIdentFuncTable[671] := FuncGetutchours;\r\n  fIdentFuncTable[1795] := FuncGetutcmilliseconds;\r\n  fIdentFuncTable[974] := FuncGetutcminutes;\r\n  fIdentFuncTable[2302] := FuncGetutcmonth;\r\n  fIdentFuncTable[3282] := FuncGetutcseconds;\r\n  fIdentFuncTable[2212] := FuncGetyear;\r\n  fIdentFuncTable[2940] := FuncGlobal;\r\n  fIdentFuncTable[4400] := FuncGo;\r\n  fIdentFuncTable[4552] := FuncGoto;\r\n  fIdentFuncTable[269] := FuncHandleevent;\r\n  fIdentFuncTable[2358] := FuncHash;\r\n  fIdentFuncTable[380] := FuncHeight;\r\n  fIdentFuncTable[911] := FuncHidden;\r\n  fIdentFuncTable[2645] := FuncHistory;\r\n  fIdentFuncTable[1710] := FuncHistory;\r\n  fIdentFuncTable[3710] := FuncHome;\r\n  fIdentFuncTable[2928] := FuncHost;\r\n  fIdentFuncTable[3996] := FuncHostname;\r\n  fIdentFuncTable[2246] := FuncHref;\r\n  fIdentFuncTable[991] := FuncHspace;\r\n  fIdentFuncTable[3785] := FuncIf;\r\n  fIdentFuncTable[1177] := FuncImage;\r\n  fIdentFuncTable[1997] := FuncImages;\r\n  fIdentFuncTable[706] := FuncImplements;\r\n  fIdentFuncTable[3582] := FuncImport;\r\n  fIdentFuncTable[4969] := FuncIn;\r\n  fIdentFuncTable[1137] := FuncIndex;\r\n  fIdentFuncTable[656] := FuncIndexof;\r\n  fIdentFuncTable[4918] := FuncInfinity;\r\n  fIdentFuncTable[5096] := FuncInnerheight;\r\n  fIdentFuncTable[5008] := FuncInnerwidth;\r\n  fIdentFuncTable[999] := FuncInput;\r\n  fIdentFuncTable[3585] := FuncInstanceof;\r\n  fIdentFuncTable[545] := FuncInt;\r\n  fIdentFuncTable[124] := FuncInterface;\r\n  fIdentFuncTable[2465] := FuncIsfinite;\r\n  fIdentFuncTable[1266] := FuncIsnan;\r\n  fIdentFuncTable[1711] := FuncItalics;\r\n  fIdentFuncTable[963] := FuncJava;\r\n  fIdentFuncTable[4225] := FuncJavaenabled;\r\n  fIdentFuncTable[3229] := FuncJoin;\r\n  fIdentFuncTable[2913] := FuncLastindexof;\r\n  fIdentFuncTable[2778] := FuncLastmodified;\r\n  fIdentFuncTable[3139] := FuncLayer;\r\n  fIdentFuncTable[2021] := FuncLayers;\r\n  fIdentFuncTable[2770] := FuncLeft;\r\n  fIdentFuncTable[1083] := FuncLength;\r\n  fIdentFuncTable[4263] := FuncLink;\r\n  fIdentFuncTable[611] := FuncLink;\r\n  fIdentFuncTable[2947] := FuncLinkcolor;\r\n  fIdentFuncTable[3943] := FuncLinks;\r\n  fIdentFuncTable[986] := FuncLn10;\r\n  fIdentFuncTable[5149] := FuncLn2;\r\n  fIdentFuncTable[4694] := FuncLocation;\r\n  fIdentFuncTable[2489] := FuncLocation;\r\n  fIdentFuncTable[3213] := FuncLocationbar;\r\n  fIdentFuncTable[2812] := FuncLog;\r\n  fIdentFuncTable[3420] := FuncLog10e;\r\n  fIdentFuncTable[3346] := FuncLog2e;\r\n  fIdentFuncTable[3808] := FuncLogon;\r\n  fIdentFuncTable[1030] := FuncLong;\r\n  fIdentFuncTable[2430] := FuncLowsrc;\r\n  fIdentFuncTable[830] := FuncMatch;\r\n  fIdentFuncTable[1454] := FuncMath;\r\n  fIdentFuncTable[4163] := FuncMax;\r\n  fIdentFuncTable[962] := FuncMax_value;\r\n  fIdentFuncTable[165] := FuncMenubar;\r\n  fIdentFuncTable[1767] := FuncMethod;\r\n  fIdentFuncTable[2068] := FuncMimetype;\r\n  fIdentFuncTable[568] := FuncMimetypes;\r\n  fIdentFuncTable[398] := FuncMin;\r\n  fIdentFuncTable[1580] := FuncMin_value;\r\n  fIdentFuncTable[3868] := FuncMoveby;\r\n  fIdentFuncTable[3688] := FuncMoveto;\r\n  fIdentFuncTable[147] := FuncName;\r\n  fIdentFuncTable[624] := FuncNan;\r\n  fIdentFuncTable[709] := FuncNative;\r\n  fIdentFuncTable[3619] := FuncNavigator;\r\n  fIdentFuncTable[1798] := FuncNavigator;\r\n  fIdentFuncTable[2749] := FuncNegative_infinity;\r\n  fIdentFuncTable[2232] := FuncNetscape;\r\n  fIdentFuncTable[4150] := FuncNew;\r\n  fIdentFuncTable[3691] := FuncNext;\r\n  fIdentFuncTable[3186] := FuncNull;\r\n  fIdentFuncTable[4687] := FuncNull2;\r\n  fIdentFuncTable[811] := FuncNumber;\r\n  fIdentFuncTable[655] := FuncObject;\r\n  fIdentFuncTable[4718] := FuncOnabort;\r\n  fIdentFuncTable[3216] := FuncOnblur;\r\n  fIdentFuncTable[4506] := FuncOnchange;\r\n  fIdentFuncTable[4236] := FuncOnclick;\r\n  fIdentFuncTable[1962] := FuncOndblclick;\r\n  fIdentFuncTable[3283] := FuncOnerror;\r\n  fIdentFuncTable[1618] := FuncOnfocus;\r\n  fIdentFuncTable[2711] := FuncOnkeydown;\r\n  fIdentFuncTable[698] := FuncOnkeypress;\r\n  fIdentFuncTable[2845] := FuncOnkeyup;\r\n  fIdentFuncTable[9] := FuncOnload;\r\n  fIdentFuncTable[1175] := FuncOnmousedown;\r\n  fIdentFuncTable[1116] := FuncOnmousemove;\r\n  fIdentFuncTable[720] := FuncOnmouseout;\r\n  fIdentFuncTable[356] := FuncOnmouseover;\r\n  fIdentFuncTable[2930] := FuncOnmouseup;\r\n  fIdentFuncTable[1494] := FuncOnreset;\r\n  fIdentFuncTable[1591] := FuncOnselect;\r\n  fIdentFuncTable[233] := FuncOnsubmit;\r\n  fIdentFuncTable[1527] := FuncOnunload;\r\n  fIdentFuncTable[309] := FuncOpen;\r\n  fIdentFuncTable[3742] := FuncOpener;\r\n  fIdentFuncTable[3624] := FuncOption;\r\n  fIdentFuncTable[3038] := FuncOptions;\r\n  fIdentFuncTable[3129] := FuncOuterheight;\r\n  fIdentFuncTable[617] := FuncOuterwidth;\r\n  fIdentFuncTable[1183] := FuncPackage;\r\n  fIdentFuncTable[4634] := FuncPackages;\r\n  fIdentFuncTable[4499] := FuncPagex;\r\n  fIdentFuncTable[1543] := FuncPagexoffset;\r\n  fIdentFuncTable[4647] := FuncPagey;\r\n  fIdentFuncTable[4043] := FuncPageyoffset;\r\n  fIdentFuncTable[4818] := FuncParent;\r\n  fIdentFuncTable[2306] := FuncParse;\r\n  fIdentFuncTable[2092] := FuncParsefloat;\r\n  fIdentFuncTable[2800] := FuncParseint;\r\n  fIdentFuncTable[756] := FuncPassword;\r\n  fIdentFuncTable[1065] := FuncPathname;\r\n  fIdentFuncTable[433] := FuncPersonalbar;\r\n  fIdentFuncTable[3413] := FuncPi;\r\n  fIdentFuncTable[4421] := FuncPlatform;\r\n  fIdentFuncTable[4802] := FuncPlugin;\r\n  fIdentFuncTable[3917] := FuncPlugins;\r\n  fIdentFuncTable[3630] := FuncPort;\r\n  fIdentFuncTable[4426] := FuncPositive_infinity;\r\n  fIdentFuncTable[5137] := FuncPow;\r\n  fIdentFuncTable[4810] := FuncPrevious;\r\n  fIdentFuncTable[602] := FuncPrint;\r\n  fIdentFuncTable[958] := FuncPrivate;\r\n  fIdentFuncTable[3968] := FuncPrompt;\r\n  fIdentFuncTable[1326] := FuncProtected;\r\n  fIdentFuncTable[1815] := FuncProtocol;\r\n  fIdentFuncTable[4437] := FuncPrototype;\r\n  fIdentFuncTable[3260] := FuncPublic;\r\n  fIdentFuncTable[1600] := FuncRadio;\r\n  fIdentFuncTable[2803] := FuncRandom;\r\n  fIdentFuncTable[2045] := FuncReferrer;\r\n  fIdentFuncTable[2270] := FuncRefresh;\r\n  fIdentFuncTable[4495] := FuncRegexp;\r\n  fIdentFuncTable[2008] := FuncReleaseevents;\r\n  fIdentFuncTable[4401] := FuncReload;\r\n  fIdentFuncTable[1148] := FuncReplace;\r\n  fIdentFuncTable[3987] := FuncReset;\r\n  fIdentFuncTable[2796] := FuncReset;\r\n  fIdentFuncTable[4116] := FuncResizeby;\r\n  fIdentFuncTable[3936] := FuncResizeto;\r\n  fIdentFuncTable[1610] := FuncReturn;\r\n  fIdentFuncTable[3457] := FuncReverse;\r\n  fIdentFuncTable[1857] := FuncRight;\r\n  fIdentFuncTable[4450] := FuncRound;\r\n  fIdentFuncTable[5041] := FuncRouteevent;\r\n  fIdentFuncTable[100] := FuncScreen;\r\n  fIdentFuncTable[3727] := FuncScroll;\r\n  fIdentFuncTable[3112] := FuncScrollbars;\r\n  fIdentFuncTable[195] := FuncScrollby;\r\n  fIdentFuncTable[15] := FuncScrollto;\r\n  fIdentFuncTable[4544] := FuncSearch;\r\n  fIdentFuncTable[1271] := FuncSelect;\r\n  fIdentFuncTable[2532] := FuncSelect;\r\n  fIdentFuncTable[2708] := FuncSelected;\r\n  fIdentFuncTable[5089] := FuncSelectedindex;\r\n  fIdentFuncTable[2283] := FuncSelf;\r\n  fIdentFuncTable[4756] := FuncSetdate;\r\n  fIdentFuncTable[517] := FuncSetfullyear;\r\n  fIdentFuncTable[4389] := FuncSethours;\r\n  fIdentFuncTable[2365] := FuncSetinterval;\r\n  fIdentFuncTable[1057] := FuncSetmilliseconds;\r\n  fIdentFuncTable[2377] := FuncSetminutes;\r\n  fIdentFuncTable[867] := FuncSetmonth;\r\n  fIdentFuncTable[4685] := FuncSetseconds;\r\n  fIdentFuncTable[4747] := FuncSettime;\r\n  fIdentFuncTable[1862] := FuncSettimeout;\r\n  fIdentFuncTable[3047] := FuncSetutcdate;\r\n  fIdentFuncTable[5010] := FuncSetutcfullyear;\r\n  fIdentFuncTable[222] := FuncSetutchours;\r\n  fIdentFuncTable[2284] := FuncSetutcmilliseconds;\r\n  fIdentFuncTable[5073] := FuncSetutcminutes;\r\n  fIdentFuncTable[3374] := FuncSetutcmonth;\r\n  fIdentFuncTable[707] := FuncSetutcseconds;\r\n  fIdentFuncTable[2225] := FuncSetyear;\r\n  fIdentFuncTable[3661] := FuncShort;\r\n  fIdentFuncTable[2910] := FuncSin;\r\n  fIdentFuncTable[523] := FuncSlice;\r\n  fIdentFuncTable[1345] := FuncSmall;\r\n  fIdentFuncTable[3822] := FuncSort;\r\n  fIdentFuncTable[239] := FuncSplit;\r\n  fIdentFuncTable[1224] := FuncSqrt;\r\n  fIdentFuncTable[4716] := FuncSqrt1_2;\r\n  fIdentFuncTable[3194] := FuncSqrt2;\r\n  fIdentFuncTable[1932] := FuncSrc;\r\n  fIdentFuncTable[482] := FuncStart;\r\n  fIdentFuncTable[684] := FuncStatic;\r\n  fIdentFuncTable[2201] := FuncStatus;\r\n  fIdentFuncTable[1836] := FuncStatusbar;\r\n  fIdentFuncTable[3389] := FuncStop;\r\n  fIdentFuncTable[4740] := FuncStrike;\r\n  fIdentFuncTable[4796] := FuncString;\r\n  fIdentFuncTable[1006] := FuncStyle;\r\n  fIdentFuncTable[283] := FuncSub;\r\n  fIdentFuncTable[5066] := FuncSubmit;\r\n  fIdentFuncTable[1174] := FuncSubmit;\r\n  fIdentFuncTable[3496] := FuncSubstr;\r\n  fIdentFuncTable[2071] := FuncSubstring;\r\n  fIdentFuncTable[4785] := FuncSuffixes;\r\n  fIdentFuncTable[2355] := FuncSup;\r\n  fIdentFuncTable[4953] := FuncSuper;\r\n  fIdentFuncTable[3170] := FuncSwitch;\r\n  fIdentFuncTable[4968] := FuncSynchronized;\r\n  fIdentFuncTable[4084] := FuncTags;\r\n  fIdentFuncTable[2789] := FuncTaint;\r\n  fIdentFuncTable[215] := FuncTaintenabled;\r\n  fIdentFuncTable[3896] := FuncTan;\r\n  fIdentFuncTable[5087] := FuncTarget;\r\n  fIdentFuncTable[4075] := FuncText;\r\n  fIdentFuncTable[4055] := FuncText;\r\n  fIdentFuncTable[2681] := FuncTextarea;\r\n  fIdentFuncTable[2382] := FuncThis;\r\n  fIdentFuncTable[4217] := FuncThrow;\r\n  fIdentFuncTable[2507] := FuncThrows;\r\n  fIdentFuncTable[1027] := FuncTitle;\r\n  fIdentFuncTable[2422] := FuncTogmtstring;\r\n  fIdentFuncTable[4448] := FuncTolocalestring;\r\n  fIdentFuncTable[857] := FuncTolowercase;\r\n  fIdentFuncTable[4611] := FuncToolbar;\r\n  fIdentFuncTable[4058] := FuncTop;\r\n  fIdentFuncTable[983] := FuncTosource;\r\n  fIdentFuncTable[3962] := FuncTostring;\r\n  fIdentFuncTable[4977] := FuncTouppercase;\r\n  fIdentFuncTable[2536] := FuncToutcstring;\r\n  fIdentFuncTable[4990] := FuncTransient;\r\n  fIdentFuncTable[1928] := FuncTrue;\r\n  fIdentFuncTable[3889] := FuncTry;\r\n  fIdentFuncTable[3925] := FuncType;\r\n  fIdentFuncTable[3121] := FuncTypeof;\r\n  fIdentFuncTable[4305] := FuncUndefined;\r\n  fIdentFuncTable[2484] := FuncUndefined;\r\n  fIdentFuncTable[3518] := FuncUnescape;\r\n  fIdentFuncTable[4070] := FuncUntaint;\r\n  fIdentFuncTable[836] := FuncUnwatch;\r\n  fIdentFuncTable[3893] := FuncUrl;\r\n  fIdentFuncTable[747] := FuncUseragent;\r\n  fIdentFuncTable[3278] := FuncUtc;\r\n  fIdentFuncTable[1621] := FuncValue;\r\n  fIdentFuncTable[5048] := FuncValueof;\r\n  fIdentFuncTable[1890] := FuncVar;\r\n  fIdentFuncTable[910] := FuncVisibility;\r\n  fIdentFuncTable[2454] := FuncVlinkcolor;\r\n  fIdentFuncTable[996] := FuncVoid;\r\n  fIdentFuncTable[418] := FuncVspace;\r\n  fIdentFuncTable[4708] := FuncWatch;\r\n  fIdentFuncTable[3178] := FuncWhile;\r\n  fIdentFuncTable[1729] := FuncWidth;\r\n  fIdentFuncTable[2916] := FuncWindow;\r\n  fIdentFuncTable[4177] := FuncWindow;\r\n  fIdentFuncTable[4646] := FuncWith;\r\n  fIdentFuncTable[519] := FuncWrite;\r\n  fIdentFuncTable[4841] := FuncWriteln;\r\n  fIdentFuncTable[4030] := FuncZindex;\r\nend;\r\n\r\nfunction TSynJScriptSyn.AltFunc(Index: Integer): TtkTokenKind;\r\nbegin\r\n  Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncAbs(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncAbstract(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncAcos(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncAction(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncAlert(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncAlign(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncAlinkcolor(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncAll(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncAnchor(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncAnchors(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncAppcodename(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncApplet(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncApplets(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncAppname(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncAppversion(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncArea(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncArguments(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncArray(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncAsin(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncAtan(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncAtan2(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncBack(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncBackground(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncBgcolor(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncBig(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncBlink(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncBlur(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncBody(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncBold(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncBoolean(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncBoolean2(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\n\r\nfunction TSynJScriptSyn.FuncBorder(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncBottom(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncBreak(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncButton(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncByte(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncCall(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncCallee(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncCaller(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncCaptureevents(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncCase(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncCatch(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncCeil(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncChar(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncCharat(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncCharcodeat(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncCheckbox(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncChecked(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncClass(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncClear(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncClearinterval(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncCleartimeout(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncClick(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncClose(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncClosed(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncColor(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncComplete(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncConcat(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncConfirm(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncConst(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncConstructor(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncContinue(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncCookie(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncCos(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncCurrent(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncDate(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncDebugger(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncDefault(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncDefaultchecked(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncDefaultselected(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncDefaultstatus(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncDefaultvalue(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncDelete(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncDescription(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncDisplay(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncDo(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncDocument(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncDomain(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncDouble(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncE(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncElements(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncElse(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncEmbed(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncEmbeds(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncEnabledplugin(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncEncoding(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncEnum(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncEscape(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncEval(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncEvent(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncExp(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncExport(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncExtends(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncFalse(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncFgcolor(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncFilename(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncFileupload(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncFinal(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncFinally(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncFind(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncFixed(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncFloat(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncFloat2(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncFloor(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncFocus(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncFontcolor(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncFontsize(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncFor(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncForm(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncForms(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncForward(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncFrame(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncFrames(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncFromcharcode(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncFunction(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncFunction2(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncGetdate(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncGetday(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncGetelementbyid(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncGetfullyear(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncGethours(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncGetmilliseconds(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncGetminutes(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncGetmonth(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncGetseconds(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncGettime(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncGettimezoneoffset(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncGetutcdate(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncGetutcday(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncGetutcfullyear(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncGetutchours(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncGetutcmilliseconds(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncGetutcminutes(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncGetutcmonth(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncGetutcseconds(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncGetyear(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncGlobal(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncGo(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncGoto(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncHandleevent(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncHash(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncHeight(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncHidden(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncHistory(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncHome(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncHost(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncHostname(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncHref(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncHspace(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncIf(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncImage(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncImages(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncImplements(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncImport(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncIn(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncIndex(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncIndexof(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncInfinity(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncInnerheight(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncInnerwidth(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncInput(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncInstanceof(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncInt(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncInterface(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncIsfinite(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncIsnan(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncItalics(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncJava(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncJavaenabled(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncJoin(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncLastindexof(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncLastmodified(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncLayer(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncLayers(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncLeft(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncLength(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncLink(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncLinkcolor(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncLinks(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncLn10(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncLn2(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncLocation(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncLocationbar(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncLog(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncLog10e(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncLog2e(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncLogon(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncLong(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncLowsrc(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncMatch(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncMath(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncMax(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncMax_value(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncMenubar(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncMethod(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncMimetype(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncMimetypes(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncMin(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncMin_value(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncMoveby(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncMoveto(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncName(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncNan(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncNative(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncNavigator(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncNegative_infinity(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncNetscape(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncNew(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncNext(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncNull(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncNull2(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncNumber(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncObject(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncOnabort(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkEvent\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncOnblur(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkEvent\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncOnchange(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkEvent\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncOnclick(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkEvent\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncOndblclick(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkEvent\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncOnerror(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkEvent\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncOnfocus(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkEvent\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncOnkeydown(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkEvent\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncOnkeypress(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkEvent\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncOnkeyup(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkEvent\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncOnload(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkEvent\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncOnmousedown(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkEvent\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncOnmousemove(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkEvent\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncOnmouseout(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkEvent\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncOnmouseover(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkEvent\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncOnmouseup(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkEvent\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncOnreset(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkEvent\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncOnselect(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkEvent\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncOnsubmit(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkEvent\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncOnunload(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkEvent\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncOpen(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncOpener(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncOption(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncOptions(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncOuterheight(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncOuterwidth(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncPackage(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncPackages(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncPagex(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncPagexoffset(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncPagey(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncPageyoffset(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncParent(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncParse(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncParsefloat(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncParseint(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncPassword(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncPathname(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncPersonalbar(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncPi(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncPlatform(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncPlugin(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncPlugins(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncPort(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncPositive_infinity(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncPow(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncPrevious(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncPrint(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncPrivate(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncPrompt(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncProtected(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncProtocol(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncPrototype(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncPublic(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncRadio(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncRandom(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncReferrer(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncRefresh(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncRegexp(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncReleaseevents(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncReload(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncReplace(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncReset(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncResizeby(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncResizeto(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncReturn(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncReverse(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncRight(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncRound(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncRouteevent(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncScreen(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncScroll(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncScrollbars(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncScrollby(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncScrollto(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncSearch(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncSelect(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncSelected(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncSelectedindex(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncSelf(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncSetdate(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncSetfullyear(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncSethours(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncSetinterval(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncSetmilliseconds(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncSetminutes(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncSetmonth(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncSetseconds(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncSettime(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncSettimeout(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncSetutcdate(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncSetutcfullyear(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncSetutchours(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncSetutcmilliseconds(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncSetutcminutes(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncSetutcmonth(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncSetutcseconds(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncSetyear(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncShort(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncSin(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncSlice(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncSmall(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncSort(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncSplit(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncSqrt(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncSqrt1_2(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncSqrt2(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncSrc(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncStart(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncStatic(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncStatus(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncStatusbar(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncStop(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncStrike(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncString(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncStyle(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncSub(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncSubmit(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncSubstr(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncSubstring(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncSuffixes(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncSup(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncSuper(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncSwitch(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncSynchronized(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncTags(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncTaint(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncTaintenabled(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncTan(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncTarget(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncText(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncTextarea(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncThis(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncThrow(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncThrows(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncTitle(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncTogmtstring(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncTolocalestring(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncTolowercase(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncToolbar(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncTop(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncTosource(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncTostring(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncTouppercase(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncToutcstring(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncTransient(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncTrue(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncTry(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncType(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncTypeof(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncUndefined(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncUnescape(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncUntaint(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncUnwatch(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncUrl(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncUseragent(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncUtc(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncValue(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncValueof(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncVar(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncVisibility(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncVlinkcolor(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncVoid(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncVspace(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncWatch(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncWhile(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncWidth(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncWindow(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncWith(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncWrite(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncWriteln(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJScriptSyn.FuncZindex(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkNonReservedKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nconstructor TSynJScriptSyn.Create(AOwner: TComponent);\r\nbegin\r\n  inherited Create(AOwner);\r\n\r\n  fCaseSensitive := True;\r\n\r\n  fCommentAttri := TSynHighlighterAttributes.Create(SYNS_AttrComment, SYNS_FriendlyAttrComment);\r\n  fCommentAttri.Style := [fsItalic];\r\n  AddAttribute(fCommentAttri);\r\n  fIdentifierAttri := TSynHighlighterAttributes.Create(SYNS_AttrIdentifier, SYNS_FriendlyAttrIdentifier);\r\n  AddAttribute(fIdentifierAttri);\r\n  fKeyAttri := TSynHighlighterAttributes.Create(SYNS_AttrReservedWord, SYNS_FriendlyAttrReservedWord);\r\n  fKeyAttri.Style := [fsBold];\r\n  AddAttribute(fKeyAttri);\r\n  fNonReservedKeyAttri := TSynHighlighterAttributes.Create(SYNS_AttrNonReservedKeyword, SYNS_FriendlyAttrNonReservedKeyword);\r\n  AddAttribute(fNonReservedKeyAttri);\r\n  fEventAttri := TSynHighlighterAttributes.Create(SYNS_AttrEvent, SYNS_FriendlyAttrEvent);\r\n  AddAttribute(fEventAttri);\r\n  fNumberAttri := TSynHighlighterAttributes.Create(SYNS_AttrNumber, SYNS_FriendlyAttrNumber);\r\n  AddAttribute(fNumberAttri);\r\n  fSpaceAttri := TSynHighlighterAttributes.Create(SYNS_AttrSpace, SYNS_FriendlyAttrSpace);\r\n  AddAttribute(fSpaceAttri);\r\n  fStringAttri := TSynHighlighterAttributes.Create(SYNS_AttrString, SYNS_FriendlyAttrString);\r\n  AddAttribute(fStringAttri);\r\n  fSymbolAttri := TSynHighlighterAttributes.Create(SYNS_AttrSymbol, SYNS_FriendlyAttrSymbol);\r\n  AddAttribute(fSymbolAttri);\r\n  SetAttributesOnChange(DefHighlightChange);\r\n  InitIdent;\r\n  fDefaultFilter := SYNS_FilterJScript;\r\n  fRange := rsUnknown;\r\nend;\r\n\r\nprocedure TSynJScriptSyn.AndSymbolProc;\r\nbegin\r\n  fTokenID := tkSymbol;\r\n  inc(Run);\r\n  if CharInSet(fLine[Run], ['=', '&']) then inc(Run);\r\nend;\r\n\r\nprocedure TSynJScriptSyn.CommentProc;\r\nbegin\r\n  if fLine[Run] = #0 then\r\n    NullProc\r\n  else\r\n  begin\r\n    fTokenID := tkComment;\r\n    repeat\r\n      if (fLine[Run] = '*') and (fLine[Run + 1] = '/') then\r\n      begin\r\n        fRange := rsUnKnown;\r\n        inc(Run, 2);\r\n        break;\r\n      end;\r\n      inc(Run);\r\n    until IsLineEnd(Run);\r\n  end;\r\nend;\r\n\r\nprocedure TSynJScriptSyn.CRProc;\r\nbegin\r\n  fTokenID := tkSpace;\r\n  inc(Run);\r\n  if fLine[Run] = #10 then inc(Run);\r\nend;\r\n\r\nprocedure TSynJScriptSyn.IdentProc;\r\nbegin\r\n  fTokenID := IdentKind((fLine + Run));\r\n  inc(Run, fStringLen);\r\n  while IsIdentChar(fLine[Run]) do inc(Run);\r\nend;\r\n\r\nprocedure TSynJScriptSyn.LFProc;\r\nbegin\r\n  fTokenID := tkSpace;\r\n  inc(Run);\r\nend;\r\n\r\nprocedure TSynJScriptSyn.MinusProc;\r\nbegin\r\n  fTokenID := tkSymbol;\r\n  inc(Run);\r\n  if CharInSet(fLine[Run], ['=', '-', '>']) then inc(Run);\r\nend;\r\n\r\nprocedure TSynJScriptSyn.ModSymbolProc;\r\nbegin\r\n  fTokenID := tkSymbol;\r\n  inc(Run);\r\n  if fLine[Run] = '=' then inc(Run);\r\nend;\r\n\r\nprocedure TSynJScriptSyn.NullProc;\r\nbegin\r\n  fTokenID := tkNull;\r\n  inc(Run);\r\nend;\r\n\r\nprocedure TSynJScriptSyn.NumberProc;\r\n\r\n  function IsNumberChar: Boolean;\r\n  begin\r\n    case fLine[Run] of\r\n      '0'..'9', '.', 'a'..'f', 'A'..'F', 'x', 'X':\r\n        Result := True;\r\n      else\r\n        Result := False;\r\n    end;\r\n  end;\r\n\r\n  function IsHexChar(Run: Integer): Boolean;\r\n  begin\r\n    case fLine[Run] of\r\n      '0'..'9', 'a'..'f', 'A'..'F':\r\n        Result := True;\r\n      else\r\n        Result := False;\r\n    end;\r\n  end;\r\n\r\nvar\r\n  idx1: Integer; // token[1]\r\n  isHex: Boolean;\r\nbegin\r\n  fTokenID := tkNumber;\r\n  isHex := False;\r\n  idx1 := Run;\r\n  Inc(Run);\r\n  while IsNumberChar do\r\n  begin\r\n    case FLine[Run] of\r\n      '.':\r\n        if FLine[Succ(Run)] = '.' then\r\n          Break;\r\n      'a'..'f', 'A'..'F':\r\n        if not isHex then\r\n          Break;\r\n      'x', 'X':\r\n        begin\r\n          if (FLine[idx1] <> '0') or (Run > Succ(idx1)) then\r\n            Break;\r\n          if not IsHexChar(Succ(Run)) then\r\n            Break;\r\n          isHex := True;\r\n        end;\r\n    end;\r\n    Inc(Run);\r\n  end;\r\nend;\r\n\r\nprocedure TSynJScriptSyn.OrSymbolProc;\r\nbegin\r\n  fTokenID := tkSymbol;\r\n  inc(Run);\r\n  if CharInSet(fLine[Run], ['=', '|']) then inc(Run);\r\nend;\r\n\r\nprocedure TSynJScriptSyn.PlusProc;\r\nbegin\r\n  fTokenID := tkSymbol;\r\n  inc(Run);\r\n  if CharInSet(fLine[Run], ['=', '+']) then inc(Run);\r\nend;\r\n\r\nprocedure TSynJScriptSyn.PointProc;\r\nbegin\r\n  fTokenID := tkSymbol;\r\n  inc(Run);\r\n  if (fLine[Run] = '.') and (fLine[Run + 1] = '.') then inc(Run, 2);\r\nend;\r\n\r\nprocedure TSynJScriptSyn.SlashProc;\r\nbegin\r\n  Inc(Run);\r\n  case fLine[Run] of\r\n    '/': begin\r\n           fTokenID := tkComment;\r\n           repeat\r\n             Inc(Run);\r\n           until IsLineEnd(Run);\r\n         end;\r\n    '*': begin\r\n           fTokenID := tkComment;\r\n           fRange := rsAnsi;\r\n           repeat\r\n             Inc(Run);\r\n             if (fLine[Run] = '*') and (fLine[Run + 1] = '/') then begin\r\n               fRange := rsUnKnown;\r\n               Inc(Run, 2);\r\n               break;\r\n             end;\r\n           until IsLineEnd(Run);\r\n         end;\r\n    '=': begin\r\n           Inc(Run);\r\n           fTokenID := tkSymbol;\r\n         end;\r\n    else\r\n      fTokenID := tkSymbol;\r\n  end;\r\nend;\r\n\r\nprocedure TSynJScriptSyn.SpaceProc;\r\nbegin\r\n  inc(Run);\r\n  fTokenID := tkSpace;\r\n  while (FLine[Run] <= #32) and not IsLineEnd(Run) do inc(Run);\r\nend;\r\n\r\nprocedure TSynJScriptSyn.StarProc;\r\nbegin\r\n  fTokenID := tkSymbol;\r\n  inc(Run);\r\n  if fLine[Run] = '=' then inc(Run);\r\nend;\r\n\r\nprocedure TSynJScriptSyn.StringProc;\r\nvar\r\n  l_strChar: UnicodeString;\r\nbegin\r\n  fTokenID := tkString;\r\n  l_strChar := FLine[Run];   // We could have '\"' or #39\r\n  if (FLine[Run + 1] = l_strChar) and (FLine[Run + 2] = l_strChar) then inc(Run, 2);\r\n  repeat\r\n    if IsLineEnd(Run) then break;\r\n    inc(Run);\r\n  until (FLine[Run] = l_strChar) and (FLine[Pred(Run)] <> '\\');\r\n  if not IsLineEnd(Run) then\r\n    Inc(Run);\r\nend;\r\n\r\nprocedure TSynJScriptSyn.SymbolProc;\r\nbegin\r\n  inc(Run);\r\n  fTokenId := tkSymbol;\r\nend;\r\n\r\nprocedure TSynJScriptSyn.UnknownProc;\r\nbegin\r\n  inc(Run);\r\n  fTokenID := tkUnknown;\r\nend;\r\n\r\nprocedure TSynJScriptSyn.Next;\r\nbegin\r\n  fTokenPos := Run;\r\n  if fRange = rsANSI then\r\n    CommentProc\r\n  else\r\n    case fLine[Run] of\r\n      '&': AndSymbolProc;\r\n      #13: CRProc;\r\n      'A'..'Z', 'a'..'z', '_': IdentProc;\r\n      #10: LFProc;\r\n      '-': MinusProc;\r\n      '%': ModSymbolProc;\r\n      #0: NullProc;\r\n      '0'..'9': NumberProc;\r\n      '|': OrSymbolProc;\r\n      '+': PlusProc;\r\n      '.': PointProc;\r\n      '/': SlashProc;\r\n      #1..#9, #11, #12, #14..#32: SpaceProc;\r\n      '*': StarProc;\r\n      '\"', #39: StringProc;\r\n      '~', '{', '}', ',', '(', ')', '[', ']', '<', '>', ':', '?', ';', '!', '=':\r\n        SymbolProc;\r\n      else UnknownProc;\r\n    end;\r\n  inherited;\r\nend;\r\n\r\nfunction TSynJScriptSyn.GetDefaultAttribute(Index: integer): TSynHighlighterAttributes;\r\nbegin\r\n  case Index of\r\n    SYN_ATTR_COMMENT: Result := fCommentAttri;\r\n    SYN_ATTR_IDENTIFIER: Result := fIdentifierAttri;\r\n    SYN_ATTR_KEYWORD: Result := fKeyAttri;\r\n    SYN_ATTR_STRING: Result := fStringAttri;\r\n    SYN_ATTR_WHITESPACE: Result := fSpaceAttri;\r\n    SYN_ATTR_SYMBOL: Result := fSymbolAttri;\r\n  else\r\n    Result := nil;\r\n  end;\r\nend;\r\n\r\nfunction TSynJScriptSyn.GetEol: Boolean;\r\nbegin\r\n  Result := Run = fLineLen + 1;\r\nend;\r\n\r\nfunction TSynJScriptSyn.GetRange: Pointer;\r\nbegin\r\n  Result := Pointer(fRange);\r\nend;\r\n\r\nfunction TSynJScriptSyn.GetTokenID: TtkTokenKind;\r\nbegin\r\n  Result := fTokenId;\r\nend;\r\n\r\nfunction TSynJScriptSyn.GetTokenAttribute: TSynHighlighterAttributes;\r\nbegin\r\n  case GetTokenID of\r\n    tkComment: Result := fCommentAttri;\r\n    tkIdentifier: Result := fIdentifierAttri;\r\n    tkKey: Result := fKeyAttri;\r\n    tkNonReservedKey: Result := fNonReservedKeyAttri;\r\n    tkEvent: Result := fEventAttri;\r\n    tkNumber: Result := fNumberAttri;\r\n    tkSpace: Result := fSpaceAttri;\r\n    tkString: Result := fStringAttri;\r\n    tkSymbol: Result := fSymbolAttri;\r\n    tkUnknown: Result := fIdentifierAttri;\r\n    else Result := nil;\r\n  end;\r\nend;\r\n\r\nfunction TSynJScriptSyn.GetTokenKind: integer;\r\nbegin\r\n  Result := Ord(fTokenId);\r\nend;\r\n\r\nprocedure TSynJScriptSyn.ResetRange;\r\nbegin\r\n  fRange := rsUnknown;\r\nend;\r\n\r\nprocedure TSynJScriptSyn.SetRange(Value: Pointer);\r\nbegin\r\n  fRange := TRangeState(Value);\r\nend;\r\n\r\nfunction TSynJScriptSyn.IsFilterStored: Boolean;\r\nbegin\r\n  Result := fDefaultFilter <> SYNS_FilterJScript;\r\nend;\r\n\r\nclass function TSynJScriptSyn.GetLanguageName: string;\r\nbegin\r\n  Result := SYNS_LangJScript;\r\nend;\r\n\r\nfunction TSynJScriptSyn.GetSampleSource: UnicodeString;\r\nbegin\r\n  Result := '// Syntax highlighting'#13#10+\r\n            'function printNumber()'#13#10+\r\n            '{'#13#10+\r\n            '  var number = 1234;'#13#10+\r\n            '  var x;'#13#10+\r\n            '  document.write(\"The number is \" + number);'#13#10+\r\n            '  for (var i = 0; i <= number; i++)'#13#10+\r\n            '  {'#13#10+\r\n            '    x++;'#13#10+\r\n            '    x--;'#13#10+\r\n            '    x += 1.0;'#13#10+\r\n            '  }'#13#10+\r\n            '  i += @; // illegal character'#13#10+\r\n            '}'#13#10+\r\n            'body.onLoad = printNumber;';\r\nend;\r\n\r\nclass function TSynJScriptSyn.GetFriendlyLanguageName: UnicodeString;\r\nbegin\r\n  Result := SYNS_FriendlyLangJScript;\r\nend;\r\n\r\ninitialization\r\n{$IFNDEF SYN_CPPB_1}\r\n  RegisterPlaceableHighlighter(TSynJScriptSyn);\r\n{$ENDIF}\r\nend.\r\n"
  },
  {
    "path": "External/SynEdit/Source/SynHighlighterJava.pas",
    "content": "{-------------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: SynHighlighterJava.pas, released 2000-04-10.\r\nThe Original Code is based on the DcjSynJava.pas file from the\r\nmwEdit component suite by Martin Waldenburg and other developers, the Initial\r\nAuthor of this file is Michael Trier.\r\nUnicode translation by Mal Hrz.\r\nAll Rights Reserved.\r\n\r\nContributors to the SynEdit and mwEdit projects are listed in the\r\nContributors.txt file.\r\n\r\nAlternatively, the contents of this file may be used under the terms of the\r\nGNU General Public License Version 2 or later (the \"GPL\"), in which case\r\nthe provisions of the GPL are applicable instead of those above.\r\nIf you wish to allow use of your version of this file only under the terms\r\nof the GPL and not to allow others to use your version of this file\r\nunder the MPL, indicate your decision by deleting the provisions above and\r\nreplace them with the notice and other provisions required by the GPL.\r\nIf you do not delete the provisions above, a recipient may use your version\r\nof this file under either the MPL or the GPL.\r\n\r\n$Id: SynHighlighterJava.pas,v 1.18.2.10 2008/09/14 16:25:00 maelh Exp $\r\n\r\nYou may retrieve the latest version of this file at the SynEdit home page,\r\nlocated at http://SynEdit.SourceForge.net\r\n\r\nKnown Issues:\r\n-------------------------------------------------------------------------------}\r\n{\r\n@abstract(Provides a Java highlighter for SynEdit)\r\n@author(Michael Trier)\r\n@created(December 1998, converted to SynEdit 2000-04-10 by Michael Hieke)\r\n@lastmod(2000-06-23)\r\nThe SynHighlighterJava unit provides SynEdit with a Java source (.java) highlighter.\r\n}\r\n\r\n{$IFNDEF QSYNHIGHLIGHTERJAVA}\r\nunit SynHighlighterJava;\r\n{$ENDIF}\r\n\r\n{$I SynEdit.inc}\r\n\r\ninterface\r\n\r\nuses\r\n{$IFDEF SYN_CLX}\r\n  QGraphics,\r\n  QSynEditTypes,\r\n  QSynEditHighlighter,\r\n  QSynUnicode,\r\n{$ELSE}\r\n  Graphics,\r\n  SynEditTypes,\r\n  SynEditHighlighter,\r\n  SynUnicode,\r\n{$ENDIF}\r\n  SysUtils, Classes;\r\n\r\ntype\r\n  TtkTokenKind = (tkComment, tkDocument, tkIdentifier, tkInvalid, tkKey,\r\n    tkNull, tkNumber, tkSpace, tkString, tkSymbol, tkUnknown);\r\n\r\n  TxtkTokenKind = (\r\n    xtkAdd, xtkAddAssign, xtkAnd, xtkAndAssign, xtkAssign, xtkBitComplement,\r\n    xtkBraceClose, xtkBraceOpen, xtkColon, xtkCondAnd, xtkCondOr, xtkDecrement,\r\n    xtkDivide, xtkDivideAssign, xtkGreaterThan, xtkGreaterThanEqual, xtkIncOr,\r\n    xtkIncOrAssign, xtkIncrement, xtkLessThan, xtkLessThanEqual,\r\n    xtkLogComplement, xtkLogEqual, xtkMultiply, xtkMultiplyAssign, xtkNotEqual,\r\n    xtkPoint, xtkQuestion, xtkRemainder, xtkRemainderAssign, xtkRoundClose,\r\n    xtkRoundOpen, xtkSemiColon, xtkShiftLeft, xtkShiftLeftAssign, xtkShiftRight,\r\n    xtkShiftRightAssign, xtkSquareClose, xtkSquareOpen, xtkSubtract,\r\n    xtkSubtractAssign, xtkUnsignShiftRight, xtkUnsignShiftRightAssign, xtkXor,\r\n    xtkXorAssign, xtkComma);\r\n\r\n  TRangeState = (rsANil, rsComment, rsDocument, rsUnknown);\r\n\r\n  PIdentFuncTableFunc = ^TIdentFuncTableFunc;\r\n  TIdentFuncTableFunc = function (Index: Integer): TtkTokenKind of object;\r\n\r\n  TSynJavaSyn = class(TSynCustomHighlighter)\r\n  private\r\n    fRange: TRangeState;\r\n    FRoundCount: Integer;\r\n    FSquareCount: Integer;\r\n    FTokenID: TtkTokenKind;\r\n    FExtTokenID: TxtkTokenKind;\r\n    fIdentFuncTable: array[0..112] of TIdentFuncTableFunc;\r\n    fCommentAttri: TSynHighlighterAttributes;\r\n    fDocumentAttri: TSynHighlighterAttributes;\r\n    fIdentifierAttri: TSynHighlighterAttributes;\r\n    fInvalidAttri: TSynHighlighterAttributes;\r\n    fKeyAttri: TSynHighlighterAttributes;\r\n    fNumberAttri: TSynHighlighterAttributes;\r\n    fSpaceAttri: TSynHighlighterAttributes;\r\n    fStringAttri: TSynHighlighterAttributes;\r\n    fSymbolAttri: TSynHighlighterAttributes;\r\n    function AltFunc(Index: Integer): TtkTokenKind;\r\n    function KeyWordFunc(Index: Integer): TtkTokenKind;\r\n    function HashKey(Str: PWideChar): Cardinal;\r\n    function IdentKind(MayBe: PWideChar): TtkTokenKind;\r\n    procedure InitIdent;\r\n    procedure CommentProc;\r\n    procedure AndSymbolProc;\r\n    procedure AsciiCharProc;\r\n    procedure AtSymbolProc;\r\n    procedure BraceCloseProc;\r\n    procedure BraceOpenProc;\r\n    procedure CRProc;\r\n    procedure ColonProc;\r\n    procedure CommaProc;\r\n    procedure EqualProc;\r\n    procedure GreaterProc;\r\n    procedure IdentProc;\r\n    procedure LFProc;\r\n    procedure LowerProc;\r\n    procedure MinusProc;\r\n    procedure MultiplyProc;\r\n    procedure NotSymbolProc;\r\n    procedure NullProc;\r\n    procedure NumberProc;\r\n    procedure OrSymbolProc;\r\n    procedure PlusProc;\r\n    procedure PointProc;\r\n    procedure PoundProc;\r\n    procedure QuestionProc;\r\n    procedure RemainderSymbolProc;\r\n    procedure RoundCloseProc;\r\n    procedure RoundOpenProc;\r\n    procedure SemiColonProc;\r\n    procedure SlashProc;\r\n    procedure SpaceProc;\r\n    procedure SquareCloseProc;\r\n    procedure SquareOpenProc;\r\n    procedure StringProc;\r\n    procedure TildeProc;\r\n    procedure XOrSymbolProc;\r\n    procedure UnknownProc;\r\n  protected\r\n    function GetSampleSource: UnicodeString; override;\r\n    function GetExtTokenID: TxtkTokenKind;\r\n    function IsFilterStored: Boolean; override;\r\n  public\r\n    class function GetLanguageName: string; override;\r\n    class function GetFriendlyLanguageName: UnicodeString; override;\r\n  public\r\n    constructor Create(AOwner: TComponent); override;\r\n    function GetDefaultAttribute(Index: integer): TSynHighlighterAttributes;    \r\n      override;\r\n    function GetEol: Boolean; override;\r\n    function GetRange: Pointer; override;\r\n    function GetTokenID: TtkTokenKind;\r\n    function GetTokenAttribute: TSynHighlighterAttributes; override;\r\n    function GetTokenKind: integer; override;\r\n    function IsIdentChar(AChar: WideChar): Boolean; override;\r\n    procedure Next; override;\r\n    procedure SetRange(Value: Pointer); override;\r\n    procedure ResetRange; override;\r\n    property ExtTokenID: TxtkTokenKind read GetExtTokenID;\r\n  published\r\n    property CommentAttri: TSynHighlighterAttributes read fCommentAttri\r\n      write fCommentAttri;\r\n    property DocumentAttri: TSynHighlighterAttributes read fDocumentAttri\r\n      write fDocumentAttri;\r\n    property IdentifierAttri: TSynHighlighterAttributes read fIdentifierAttri\r\n      write fIdentifierAttri;\r\n    property InvalidAttri: TSynHighlighterAttributes read fInvalidAttri\r\n      write fInvalidAttri;\r\n    property KeyAttri: TSynHighlighterAttributes read fKeyAttri write fKeyAttri;\r\n    property NumberAttri: TSynHighlighterAttributes read fNumberAttri\r\n      write fNumberAttri;\r\n    property SpaceAttri: TSynHighlighterAttributes read fSpaceAttri\r\n      write fSpaceAttri;\r\n    property StringAttri: TSynHighlighterAttributes read fStringAttri\r\n      write fStringAttri;\r\n    property SymbolAttri: TSynHighlighterAttributes read fSymbolAttri\r\n      write fSymbolAttri;\r\n  end;\r\n\r\nimplementation\r\n\r\nuses\r\n{$IFDEF SYN_CLX}\r\n  QSynEditStrConst;\r\n{$ELSE}\r\n  SynEditStrConst;\r\n{$ENDIF}\r\n\r\nconst\r\n  KeyWords: array[0..51] of UnicodeString = (\r\n    'abstract', 'assert', 'boolean', 'break', 'byte', 'case', 'catch', 'char', \r\n    'class', 'const', 'continue', 'default', 'do', 'double', 'else', 'extends', \r\n    'false', 'final', 'finally', 'float', 'for', 'goto', 'if', 'implements', \r\n    'import', 'instanceof', 'int', 'interface', 'long', 'native', 'new', 'null', \r\n    'package', 'private', 'protected', 'public', 'return', 'short', 'static', \r\n    'strictfp', 'super', 'switch', 'synchronized', 'this', 'throw', 'throws', \r\n    'transient', 'true', 'try', 'void', 'volatile', 'while' \r\n  );\r\n\r\n  KeyIndices: array[0..112] of Integer = (\r\n    1, -1, -1, 45, -1, -1, 39, -1, -1, -1, 9, 36, 26, -1, -1, 4, 27, 5, 50, 25, \r\n    33, -1, 18, -1, 17, 6, 28, -1, -1, -1, 51, -1, -1, -1, -1, 21, 48, -1, 7, 3, \r\n    -1, -1, -1, 49, 41, -1, 35, -1, 46, 40, -1, -1, -1, 42, -1, -1, -1, -1, -1, \r\n    -1, 43, -1, -1, -1, -1, -1, 13, 24, -1, 37, -1, -1, 31, 11, -1, 22, -1, -1, \r\n    -1, 44, -1, 10, 19, 8, -1, -1, 38, 15, -1, -1, 34, -1, 14, -1, -1, -1, 0, \r\n    12, -1, 20, -1, 23, -1, 47, -1, -1, 29, 30, -1, -1, 16, 32, 2 \r\n  );\r\n\r\n{$Q-}\r\nfunction TSynJavaSyn.HashKey(Str: PWideChar): Cardinal;\r\nbegin\r\n  Result := 0;\r\n  while IsIdentChar(Str^) do\r\n  begin\r\n    Result := Result * 598 + Ord(Str^) * 349;\r\n    inc(Str);\r\n  end;\r\n  Result := Result mod 113;\r\n  fStringLen := Str - fToIdent;\r\nend;\r\n{$Q+}\r\n\r\nfunction TSynJavaSyn.IdentKind(MayBe: PWideChar): TtkTokenKind;\r\nvar\r\n  Key: Cardinal;\r\nbegin\r\n  fToIdent := MayBe;\r\n  Key := HashKey(MayBe);\r\n  if Key <= High(fIdentFuncTable) then\r\n    Result := fIdentFuncTable[Key](KeyIndices[Key])\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nprocedure TSynJavaSyn.InitIdent;\r\nvar\r\n  i: Integer;\r\nbegin\r\n  for i := Low(fIdentFuncTable) to High(fIdentFuncTable) do\r\n    if KeyIndices[i] = -1 then\r\n      fIdentFuncTable[i] := AltFunc;\r\n\r\n  for i := Low(fIdentFuncTable) to High(fIdentFuncTable) do\r\n    if @fIdentFuncTable[i] = nil then\r\n      fIdentFuncTable[i] := KeyWordFunc;\r\nend;\r\n\r\nfunction TSynJavaSyn.AltFunc(Index: Integer): TtkTokenKind;\r\nbegin\r\n  Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynJavaSyn.KeyWordFunc(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier\r\nend;\r\n\r\nconstructor TSynJavaSyn.Create(AOwner: TComponent);\r\nbegin\r\n  inherited Create(AOwner);\r\n\r\n  fCaseSensitive := True;\r\n\r\n  fCommentAttri := TSynHighlighterAttributes.Create(SYNS_AttrComment, SYNS_FriendlyAttrComment);\r\n  fCommentAttri.Style := [fsItalic];\r\n  AddAttribute(fCommentAttri);\r\n  fDocumentAttri := TSynHighlighterAttributes.Create(SYNS_AttrDocumentation, SYNS_FriendlyAttrDocumentation);\r\n  fDocumentAttri.Style := [fsItalic];\r\n  AddAttribute(fDocumentAttri);\r\n  fIdentifierAttri := TSynHighlighterAttributes.Create(SYNS_AttrIdentifier, SYNS_FriendlyAttrIdentifier);\r\n  AddAttribute(fIdentifierAttri);\r\n  fInvalidAttri := TSynHighlighterAttributes.Create(SYNS_AttrInvalidSymbol, SYNS_FriendlyAttrInvalidSymbol);\r\n  AddAttribute(fInvalidAttri);\r\n  fKeyAttri := TSynHighlighterAttributes.Create(SYNS_AttrReservedWord, SYNS_FriendlyAttrReservedWord);\r\n  fKeyAttri.Style := [fsBold];\r\n  AddAttribute(fKeyAttri);\r\n  fNumberAttri := TSynHighlighterAttributes.Create(SYNS_AttrNumber, SYNS_FriendlyAttrNumber);\r\n  AddAttribute(fNumberAttri);\r\n  fSpaceAttri := TSynHighlighterAttributes.Create(SYNS_AttrSpace, SYNS_FriendlyAttrSpace);\r\n  AddAttribute(fSpaceAttri);\r\n  fStringAttri := TSynHighlighterAttributes.Create(SYNS_AttrString, SYNS_FriendlyAttrString);\r\n  AddAttribute(fStringAttri);\r\n  fSymbolAttri := TSynHighlighterAttributes.Create(SYNS_AttrSymbol, SYNS_FriendlyAttrSymbol);\r\n  AddAttribute(fSymbolAttri);\r\n  fRange := rsUnknown;\r\n  SetAttributesOnChange(DefHighlightChange);\r\n\r\n  InitIdent;\r\n  fDefaultFilter := SYNS_FilterJava;\r\nend; { Create }\r\n\r\nprocedure TSynJavaSyn.CommentProc;\r\nbegin\r\n  if fRange = rsComment then\r\n    fTokenID := tkComment\r\n  else\r\n    fTokenID := tkDocument;\r\n  case FLine[Run] of\r\n    #0:\r\n      begin\r\n        NullProc;\r\n        exit;\r\n      end;\r\n    #10:\r\n      begin\r\n        LFProc;\r\n        exit;\r\n      end;\r\n    #13:\r\n      begin\r\n        CRProc;\r\n        exit;\r\n      end;\r\n  end;\r\n\r\n  while not IsLineEnd(Run) do\r\n    case FLine[Run] of\r\n      '*':\r\n        if fLine[Run + 1] = '/' then\r\n        begin\r\n          inc(Run, 2);\r\n          fRange := rsUnknown;\r\n          break;\r\n        end\r\n        else inc(Run);\r\n    else inc(Run);\r\n    end;\r\nend;\r\n\r\nprocedure TSynJavaSyn.AndSymbolProc;\r\nbegin\r\n  case FLine[Run + 1] of\r\n    '=':                               {and assign}\r\n      begin\r\n        inc(Run, 2);\r\n        fTokenID := tkSymbol;\r\n        FExtTokenID := xtkAndAssign;\r\n      end;\r\n    '&':                               {conditional and}\r\n      begin\r\n        inc(Run, 2);\r\n        fTokenID := tkSymbol;\r\n        FExtTokenID := xtkCondAnd;\r\n      end;\r\n  else                                 {and}\r\n    begin\r\n      inc(Run);\r\n      fTokenID := tkSymbol;\r\n      FExtTokenID := xtkAnd;\r\n    end;\r\n  end;\r\nend;\r\n\r\nprocedure TSynJavaSyn.AsciiCharProc;\r\nbegin\r\n  fTokenID := tkString;\r\n  repeat\r\n    if IsLineEnd(Run) then break;\r\n    if fLine[Run] = #92 then\r\n      Inc(Run); // backslash, if we have an escaped single character, skip to the next\r\n    if not IsLineEnd(Run) then inc(Run); //Add check here to prevent overrun from backslash being last char\r\n  until FLine[Run] = #39;\r\n  if not IsLineEnd(Run) then inc(Run);\r\nend;\r\n\r\nprocedure TSynJavaSyn.AtSymbolProc;\r\nbegin\r\n  fTokenID := tkInvalid;\r\n  inc(Run);\r\nend;\r\n\r\nprocedure TSynJavaSyn.BraceCloseProc;\r\nbegin\r\n  inc(Run);\r\n  fTokenId := tkSymbol;\r\n  FExtTokenID := xtkBraceClose;\r\nend;\r\n\r\nprocedure TSynJavaSyn.BraceOpenProc;\r\nbegin\r\n  inc(Run);\r\n  fTokenId := tkSymbol;\r\n  FExtTokenID := xtkBraceOpen;\r\nend;\r\n\r\nprocedure TSynJavaSyn.CRProc;\r\nbegin\r\n  fTokenID := tkSpace;\r\n  Case FLine[Run + 1] of\r\n    #10: inc(Run, 2);\r\n  else inc(Run);\r\n  end;\r\nend;\r\n\r\nprocedure TSynJavaSyn.ColonProc;\r\nbegin\r\n  inc(Run);                            {colon - conditional}\r\n  fTokenID := tkSymbol;\r\n  FExtTokenID := xtkColon;\r\nend;\r\n\r\nprocedure TSynJavaSyn.CommaProc;\r\nbegin\r\n  inc(Run);\r\n  fTokenID := tkSymbol;\r\n  fExtTokenID := xtkComma;\r\nend;\r\n\r\nprocedure TSynJavaSyn.EqualProc;\r\nbegin\r\n  case FLine[Run + 1] of\r\n    '=':                               {logical equal}\r\n      begin\r\n        inc(Run, 2);\r\n        fTokenID := tkSymbol;\r\n        FExtTokenID := xtkLogEqual;\r\n      end;\r\n  else                                 {assign}\r\n    begin\r\n      inc(Run);\r\n      fTokenID := tkSymbol;\r\n      FExtTokenID := xtkAssign;\r\n    end;\r\n  end;\r\nend;\r\n\r\nprocedure TSynJavaSyn.GreaterProc;\r\nbegin\r\n  Case FLine[Run + 1] of\r\n    '=':                               {greater than or equal to}\r\n      begin\r\n        inc(Run, 2);\r\n        fTokenID := tkSymbol;\r\n        FExtTokenID := xtkGreaterThanEqual;\r\n      end;\r\n    '>':\r\n      begin\r\n        Case FLine[Run + 2] of\r\n          '=':                         {shift right assign}\r\n            begin\r\n            inc(Run, 3);\r\n            FExtTokenID := xtkShiftRightAssign;\r\n            end;\r\n          '>':\r\n            if FLine[Run + 3] = '=' then\r\n            begin\r\n              inc(Run, 4);             {unsigned shift right assign}\r\n              FExtTokenID := xtkUnsignShiftRightAssign;\r\n            end\r\n            else\r\n            begin\r\n              inc(Run, 3);             {unsigned shift right}\r\n              FExtTokenID := xtkUnsignShiftRight;\r\n            end;\r\n        else                           {shift right}\r\n          begin\r\n            inc(Run, 2);\r\n            FExtTokenID := xtkShiftRight;\r\n          end;\r\n        end;\r\n        fTokenID := tkSymbol;\r\n      end;\r\n  else                                 {greater than}\r\n    begin\r\n      inc(Run);\r\n      fTokenID := tkSymbol;\r\n      FExtTokenID := xtkGreaterThan;\r\n    end;\r\n  end;\r\nend;\r\n\r\nprocedure TSynJavaSyn.IdentProc;\r\nbegin\r\n  fTokenID := IdentKind((fLine + Run));\r\n  inc(Run, fStringLen);\r\n  while IsIdentChar(fLine[Run]) do inc(Run);\r\nend;\r\n\r\nprocedure TSynJavaSyn.LFProc;\r\nbegin\r\n  fTokenID := tkSpace;\r\n  inc(Run);\r\nend;\r\n\r\nprocedure TSynJavaSyn.LowerProc;\r\nbegin\r\n  case FLine[Run + 1] of\r\n    '=':                               {less than or equal to}\r\n      begin\r\n        inc(Run, 2);\r\n        fTokenID := tkSymbol;\r\n        FExtTokenID := xtkLessThanEqual;\r\n      end;\r\n    '<':\r\n      begin\r\n        if FLine[Run + 2] = '=' then   {shift left assign}\r\n        begin\r\n          inc(Run, 3);\r\n          FExtTokenID := xtkShiftLeftAssign;\r\n        end\r\n        else                           {shift left}\r\n        begin\r\n          inc(Run, 2);\r\n          FExtTokenID := xtkShiftLeft;\r\n        end;\r\n        fTokenID := tkSymbol;\r\n      end;\r\n  else                                 {less than}\r\n    begin\r\n      inc(Run);\r\n      fTokenID := tkSymbol;\r\n      FExtTokenID := xtkLessThan;\r\n    end;\r\n  end;\r\nend;\r\n\r\nprocedure TSynJavaSyn.MinusProc;\r\nbegin\r\n  case FLine[Run + 1] of\r\n    '=':                               {subtract assign}\r\n      begin\r\n        inc(Run, 2);\r\n        fTokenID := tkSymbol;\r\n        FExtTokenID := xtkSubtractAssign;\r\n      end;\r\n    '-':                               {decrement}\r\n      begin\r\n        inc(Run, 2);\r\n        fTokenID := tkSymbol;\r\n        FExtTokenID := xtkDecrement;\r\n      end;\r\n  else                                 {subtract}\r\n    begin\r\n      inc(Run);\r\n      fTokenID := tkSymbol;\r\n      FExtTokenID := xtkSubtract;\r\n    end;\r\n  end;\r\nend;\r\n\r\nprocedure TSynJavaSyn.MultiplyProc;\r\nbegin\r\n  case FLine[Run + 1] of\r\n    '=':                               {multiply assign}\r\n      begin\r\n        inc(Run, 2);\r\n        fTokenID := tkSymbol;\r\n        FExtTokenID := xtkMultiplyAssign;\r\n      end;\r\n  else                                 {multiply}\r\n    begin\r\n      inc(Run);\r\n      fTokenID := tkSymbol;\r\n      FExtTokenID := xtkMultiply;\r\n    end;\r\n  end;\r\nend;\r\n\r\nprocedure TSynJavaSyn.NotSymbolProc;\r\nbegin\r\n  case FLine[Run + 1] of\r\n    '=':                               {not equal}\r\n      begin\r\n        inc(Run, 2);\r\n        fTokenID := tkSymbol;\r\n        FExtTokenID := xtkNotEqual;\r\n      end;\r\n  else                                 {logical complement}\r\n    begin\r\n      inc(Run);\r\n      fTokenID := tkSymbol;\r\n      FExtTokenID := xtkLogComplement;\r\n    end;\r\n  end;\r\nend;\r\n\r\nprocedure TSynJavaSyn.NullProc;\r\nbegin\r\n  fTokenID := tkNull;\r\n  inc(Run);\r\nend;\r\n\r\nprocedure TSynJavaSyn.NumberProc;\r\n\r\n  function IsNumberChar: Boolean;\r\n  begin\r\n    case fLine[Run] of\r\n      '0'..'9', '.', '-', 'l', 'L', 'x', 'X', 'A'..'F', 'a'..'f':\r\n        Result := True;\r\n      else\r\n        Result := False;\r\n    end;\r\n  end;\r\n\r\nbegin\r\n  inc(Run);\r\n  fTokenID := tkNumber;\r\n  while IsNumberChar do\r\n  begin\r\n    case FLine[Run] of\r\n      '.':\r\n        if FLine[Run + 1] = '.' then break;\r\n    end;\r\n    inc(Run);\r\n  end;\r\nend;\r\n\r\nprocedure TSynJavaSyn.OrSymbolProc;\r\nbegin\r\n  case FLine[Run + 1] of\r\n    '=':                               {inclusive or assign}\r\n      begin\r\n        inc(Run, 2);\r\n        fTokenID := tkSymbol;\r\n        FExtTokenID := xtkIncOrAssign;\r\n      end;\r\n    '|':                               {conditional or}\r\n      begin\r\n        inc(Run, 2);\r\n        fTokenID := tkSymbol;\r\n        FExtTokenID := xtkCondOr;\r\n      end;\r\n  else                                 {inclusive or}\r\n    begin\r\n      inc(Run);\r\n      fTokenID := tkSymbol;\r\n      FExtTokenID := xtkIncOr;\r\n    end;\r\n  end;\r\nend;\r\n\r\nprocedure TSynJavaSyn.PlusProc;\r\nbegin\r\n  case FLine[Run + 1] of\r\n    '=':                               {add assign}\r\n      begin\r\n        inc(Run, 2);\r\n        fTokenID := tkSymbol;\r\n        FExtTokenID := xtkAddAssign;\r\n      end;\r\n    '+':                               {increment}\r\n      begin\r\n        inc(Run, 2);\r\n        fTokenID := tkSymbol;\r\n        FExtTokenID := xtkIncrement;\r\n      end;\r\n  else                                 {add}\r\n    begin\r\n      inc(Run);\r\n      fTokenID := tkSymbol;\r\n      FExtTokenID := xtkAdd;\r\n    end;\r\n  end;\r\nend;\r\n\r\nprocedure TSynJavaSyn.PointProc;\r\nbegin\r\n  inc(Run);                            {point}\r\n  if CharInSet(FLine[Run], ['0'..'9']) then\r\n  begin\r\n    NumberProc;\r\n    Exit;\r\n  end;\r\n  fTokenID := tkSymbol;\r\n  FExtTokenID := xtkPoint;\r\nend;\r\n\r\nprocedure TSynJavaSyn.PoundProc;\r\nbegin\r\n  inc(Run);\r\n  fTokenID := tkInvalid;\r\nend;\r\n\r\nprocedure TSynJavaSyn.QuestionProc;\r\nbegin\r\n  fTokenID := tkSymbol;                {question mark - conditional}\r\n  FExtTokenID := xtkQuestion;\r\n  inc(Run);\r\nend;\r\n\r\nprocedure TSynJavaSyn.RemainderSymbolProc;\r\nbegin\r\n  case FLine[Run + 1] of\r\n    '=':                               {remainder assign}\r\n      begin\r\n        inc(Run, 2);\r\n        fTokenID := tkSymbol;\r\n        FExtTokenID := xtkRemainderAssign;\r\n      end;\r\n  else                                 {remainder}\r\n    begin\r\n      inc(Run);\r\n      fTokenID := tkSymbol;\r\n      FExtTokenID := xtkRemainder;\r\n    end;\r\n  end;\r\nend;\r\n\r\nprocedure TSynJavaSyn.RoundCloseProc;\r\nbegin\r\n  inc(Run);\r\n  fTokenID := tkSymbol;\r\n  FExtTokenID := xtkRoundClose;\r\n  dec(FRoundCount);\r\nend;\r\n\r\nprocedure TSynJavaSyn.RoundOpenProc;\r\nbegin\r\n  inc(Run);\r\n  FTokenID := tkSymbol;\r\n  FExtTokenID := xtkRoundOpen;\r\n  inc(FRoundCount);\r\nend;\r\n\r\nprocedure TSynJavaSyn.SemiColonProc;\r\nbegin\r\n  inc(Run);                            {semicolon}\r\n  fTokenID := tkSymbol;\r\n  FExtTokenID := xtkSemiColon;\r\nend;\r\n\r\nprocedure TSynJavaSyn.SlashProc;\r\nbegin\r\n  case FLine[Run + 1] of\r\n    '/':                               {c++ style comments}\r\n      begin\r\n        inc(Run, 2);\r\n        fTokenID := tkComment;\r\n        while not IsLineEnd(Run) do\r\n        begin\r\n          inc(Run);\r\n        end;\r\n      end;\r\n    '*':\r\n      begin\r\n        if (fLine[Run+2] = '*') and (fLine[Run+3] <> '/')then     {documentation comment}\r\n        begin\r\n          fRange := rsDocument;\r\n          fTokenID := tkDocument;\r\n          inc(Run);\r\n        end\r\n        else                           {c style comment}\r\n        begin\r\n          fRange := rsComment;\r\n          fTokenID := tkComment;\r\n        end;\r\n\r\n        inc(Run, 2);\r\n        while not IsLineEnd(Run) do\r\n          case fLine[Run] of\r\n            '*':\r\n              if fLine[Run + 1] = '/' then\r\n              begin\r\n                inc(Run, 2);\r\n                fRange := rsUnknown;\r\n                break;\r\n              end else inc(Run);\r\n          else\r\n            inc(Run);\r\n          end;\r\n      end;\r\n    '=':                               {division assign}\r\n      begin\r\n        inc(Run, 2);\r\n        fTokenID := tkSymbol;\r\n        FExtTokenID := xtkDivideAssign;\r\n      end;\r\n  else                                 {division}\r\n    begin\r\n      inc(Run);\r\n      fTokenID := tkSymbol;\r\n      FExtTokenID := xtkDivide;\r\n    end;\r\n  end;\r\nend;\r\n\r\nprocedure TSynJavaSyn.SpaceProc;\r\nbegin\r\n  inc(Run);\r\n  fTokenID := tkSpace;\r\n  while (FLine[Run] <= #32) and not IsLineEnd(Run) do inc(Run);\r\nend;\r\n\r\nprocedure TSynJavaSyn.SquareCloseProc;\r\nbegin\r\n  inc(Run);\r\n  fTokenID := tkSymbol;\r\n  FExtTokenID := xtkSquareClose;\r\n  dec(FSquareCount);\r\nend;\r\n\r\nprocedure TSynJavaSyn.SquareOpenProc;\r\nbegin\r\n  inc(Run);\r\n  fTokenID := tkSymbol;\r\n  FExtTokenID := xtkSquareOpen;\r\n  inc(FSquareCount);\r\nend;\r\n\r\nprocedure TSynJavaSyn.StringProc;\r\nbegin\r\n  fTokenID := tkString;\r\n  if (FLine[Run + 1] = #34) and (FLine[Run + 2] = #34) then inc(Run, 2);\r\n  repeat\r\n    if IsLineEnd(Run) then break;\r\n    case FLine[Run] of\r\n      #92: Inc(Run);  // Backslash, if we have an escaped charcter it can be skipped\r\n    end;\r\n    if not IsLineEnd(Run) then inc(Run); //Add check here to prevent overrun from backslash being last char\r\n  until FLine[Run] = #34;\r\n  if not IsLineEnd(Run) then inc(Run);\r\nend;\r\n\r\nprocedure TSynJavaSyn.TildeProc;\r\nbegin\r\n  inc(Run);                            {bitwise complement}\r\n  fTokenId := tkSymbol;\r\n  FExtTokenID := xtkBitComplement;\r\nend;\r\n\r\nprocedure TSynJavaSyn.XOrSymbolProc;\r\nbegin\r\n  Case FLine[Run + 1] of\r\n    '=':                               {xor assign}\r\n      begin\r\n        inc(Run, 2);\r\n        fTokenID := tkSymbol;\r\n        FExtTokenID := xtkXorAssign;\r\n      end;\r\n  else                                 {xor}\r\n    begin\r\n      inc(Run);\r\n      fTokenID := tkSymbol;\r\n      FExtTokenID := xtkXor;\r\n    end;\r\n  end;\r\nend;\r\n\r\nprocedure TSynJavaSyn.UnknownProc;\r\nbegin\r\n  inc(Run);\r\n  fTokenID := tkUnknown;\r\nend;\r\n\r\nprocedure TSynJavaSyn.Next;\r\nbegin\r\n  fTokenPos := Run;\r\n  case fRange of\r\n    rsComment: CommentProc;\r\n    rsDocument: CommentProc;\r\n    else\r\n    begin\r\n      fRange := rsUnknown;\r\n      case fLine[Run] of\r\n        '&': AndSymbolProc;\r\n        #39: AsciiCharProc;\r\n        '@': AtSymbolProc;\r\n        '}': BraceCloseProc;\r\n        '{': BraceOpenProc;\r\n        #13: CRProc;\r\n        ':': ColonProc;\r\n        ',': CommaProc;\r\n        '=': EqualProc;\r\n        '>': GreaterProc;\r\n        'A'..'Z', 'a'..'z', '_', '$', ''..'', ''..'', ''..'': IdentProc;\r\n        #10: LFProc;\r\n        '<': LowerProc;\r\n        '-': MinusProc;\r\n        '*': MultiplyProc;\r\n        '!': NotSymbolProc;\r\n        #0: NullProc;\r\n        '0'..'9': NumberProc;\r\n        '|': OrSymbolProc;\r\n        '+': PlusProc;\r\n        '.': PointProc;\r\n        '#': PoundProc;\r\n        '?': QuestionProc;\r\n        '%': RemainderSymbolProc;\r\n        ')': RoundCloseProc;\r\n        '(': RoundOpenProc;\r\n        ';': SemiColonProc;\r\n        '/': SlashProc;\r\n        #1..#9, #11, #12, #14..#32: SpaceProc;\r\n        ']': SquareCloseProc;\r\n        '[': SquareOpenProc;\r\n        #34: StringProc;\r\n        '~': TildeProc;\r\n        '^': XOrSymbolProc;\r\n        else UnknownProc;\r\n      end;\r\n    end;\r\n  end;\r\n\r\n  inherited;\r\nend;\r\n\r\nfunction TSynJavaSyn.GetDefaultAttribute(Index: integer): TSynHighlighterAttributes;\r\nbegin\r\n  case Index of\r\n    SYN_ATTR_COMMENT: Result := fCommentAttri;\r\n    SYN_ATTR_IDENTIFIER: Result := fIdentifierAttri;\r\n    SYN_ATTR_KEYWORD: Result := fKeyAttri;\r\n    SYN_ATTR_STRING: Result := fStringAttri;\r\n    SYN_ATTR_WHITESPACE: Result := fSpaceAttri;\r\n    SYN_ATTR_SYMBOL: Result := fSymbolAttri;\r\n    else Result := nil;\r\n  end;\r\nend;\r\n\r\nfunction TSynJavaSyn.GetEol: Boolean;\r\nbegin\r\n  Result := Run = fLineLen + 1;\r\nend;\r\n\r\nfunction TSynJavaSyn.GetRange: Pointer;\r\nbegin\r\n  Result := Pointer(fRange);\r\nend;\r\n\r\nprocedure TSynJavaSyn.ResetRange;\r\nbegin\r\n  fRange := rsUnknown;\r\nend;\r\n\r\nprocedure TSynJavaSyn.SetRange(Value: Pointer);\r\nbegin\r\n  fRange := TRangeState(Value);\r\nend;\r\n\r\nfunction TSynJavaSyn.GetTokenID: TtkTokenKind;\r\nbegin\r\n  Result := fTokenId;\r\nend;\r\n\r\nfunction TSynJavaSyn.GetExtTokenID: TxtkTokenKind;\r\nbegin\r\n  Result := FExtTokenID;\r\nend;\r\n\r\nfunction TSynJavaSyn.GetTokenAttribute: TSynHighlighterAttributes;\r\nbegin\r\n  case fTokenID of\r\n    tkComment: Result := fCommentAttri;\r\n    tkDocument: Result := fDocumentAttri;\r\n    tkIdentifier: Result := fIdentifierAttri;\r\n    tkInvalid: Result := fInvalidAttri;\r\n    tkKey: Result := fKeyAttri;\r\n    tkNumber: Result := fNumberAttri;\r\n    tkSpace: Result := fSpaceAttri;\r\n    tkString: Result := fStringAttri;\r\n    tkSymbol: Result := fSymbolAttri;\r\n    tkUnknown: Result := fInvalidAttri;\r\n    else Result := nil;\r\n  end;\r\nend;\r\n\r\nfunction TSynJavaSyn.GetTokenKind: integer;\r\nbegin\r\n  Result := Ord(fTokenId);\r\nend;\r\n\r\nfunction TSynJavaSyn.IsFilterStored: Boolean;\r\nbegin\r\n  Result := fDefaultFilter <> SYNS_FilterJava;\r\nend;\r\n\r\nfunction TSynJavaSyn.IsIdentChar(AChar: WideChar): Boolean;\r\nbegin\r\n  case AChar of\r\n    '_', '$', '0'..'9', 'a'..'z', 'A'..'Z', ''..'', ''..'', ''..'':\r\n      Result := True;\r\n    else\r\n      Result := False;\r\n  end;\r\nend;\r\n\r\nclass function TSynJavaSyn.GetLanguageName: string;\r\nbegin\r\n  Result := SYNS_LangJava;\r\nend;\r\n\r\nfunction TSynJavaSyn.GetSampleSource: UnicodeString;\r\nbegin\r\n  Result := '/* Java syntax highlighting */'#13#10 +\r\n            'import java.util.*;'#13#10 +\r\n            #13#10 +\r\n            '/** Example class */'#13#10 +\r\n            'public class Sample {'#13#10 +\r\n            '  public static void main(String[] args) {'#13#10 +\r\n            '    int i = 0;'#13#10 +\r\n            '    for(i = 0; i < 10; i++)'#13#10 +\r\n            '      System.out.println(\"Hello world\");'#13#10 +\r\n            '  }'#13#10 +\r\n            '}';\r\nend;\r\n\r\nclass function TSynJavaSyn.GetFriendlyLanguageName: UnicodeString;\r\nbegin\r\n  Result := SYNS_FriendlyLangJava;\r\nend;\r\n\r\ninitialization\r\n{$IFNDEF SYN_CPPB_1}\r\n  RegisterPlaceableHighlighter(TSynJavaSyn);\r\n{$ENDIF}\r\nend.\r\n"
  },
  {
    "path": "External/SynEdit/Source/SynHighlighterKix.pas",
    "content": "{-------------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: SynHighlighterKix.pas, released 2000-05-05.\r\nThe Original Code is based on the jsKixSyn.pas file from the\r\nmwEdit component suite by Martin Waldenburg and other developers, the Initial\r\nAuthor of this file is Jeff D. Smith.\r\nUnicode translation by Mal Hrz.\r\nAll Rights Reserved.\r\n\r\nContributors to the SynEdit and mwEdit projects are listed in the\r\nContributors.txt file.\r\n\r\nAlternatively, the contents of this file may be used under the terms of the\r\nGNU General Public License Version 2 or later (the \"GPL\"), in which case\r\nthe provisions of the GPL are applicable instead of those above.\r\nIf you wish to allow use of your version of this file only under the terms\r\nof the GPL and not to allow others to use your version of this file\r\nunder the MPL, indicate your decision by deleting the provisions above and\r\nreplace them with the notice and other provisions required by the GPL.\r\nIf you do not delete the provisions above, a recipient may use your version\r\nof this file under either the MPL or the GPL.\r\n\r\n$Id: SynHighlighterKix.pas,v 1.12.2.6 2008/09/14 16:25:00 maelh Exp $\r\n\r\nYou may retrieve the latest version of this file at the SynEdit home page,\r\nlocated at http://SynEdit.SourceForge.net\r\n\r\nKnown Issues:\r\n-------------------------------------------------------------------------------}\r\n{\r\n@abstract(Provides a Kix syntax highlighter for SynEdit)\r\n@author(Jeff D. Smith)\r\n@created(1999, converted to SynEdit 2000-05-05)\r\n@lastmod(2000-06-23)\r\nThe SynHighlighterKix unit provides SynEdit with a Kix script file syntax highlighter.\r\n}\r\n\r\n{$IFNDEF QSYNHIGHLIGHTERKIX}\r\nunit SynHighlighterKix;\r\n{$ENDIF}\r\n\r\n{$I SynEdit.inc}\r\n\r\ninterface\r\n\r\nuses\r\n{$IFDEF SYN_CLX}\r\n  QGraphics,\r\n  QSynEditTypes,\r\n  QSynEditHighlighter,\r\n  QSynUnicode,\r\n{$ELSE}\r\n  Graphics,\r\n  SynEditTypes,\r\n  SynEditHighlighter,\r\n  SynUnicode,\r\n{$ENDIF}\r\n  SysUtils,\r\n  Classes;\r\n\r\ntype\r\n  TtkTokenKind = (tkComment, tkIdentifier, tkKey, tkMiscellaneous, tkNull,\r\n    tkNumber, tkSpace, tkString, tkSymbol, tkVariable, tkUnknown);\r\n\r\n  PIdentFuncTableFunc = ^TIdentFuncTableFunc;\r\n  TIdentFuncTableFunc = function (Index: Integer): TtkTokenKind of object;\r\n\r\ntype\r\n  TSynKixSyn = class(TSynCustomHighlighter)\r\n  private\r\n    fTokenID: TtkTokenKind;\r\n    fIdentFuncTable: array[0..970] of TIdentFuncTableFunc;\r\n    fCommentAttri: TSynHighlighterAttributes;\r\n    fIdentifierAttri: TSynHighlighterAttributes;\r\n    fKeyAttri: TSynHighlighterAttributes;\r\n    fMiscellaneousAttri: TSynHighlighterAttributes;\r\n    fNumberAttri: TSynHighlighterAttributes;\r\n    fSpaceAttri: TSynHighlighterAttributes;\r\n    fStringAttri: TSynHighlighterAttributes;\r\n    fSymbolAttri: TSynHighlighterAttributes;\r\n    fVariableAttri: TSynHighlighterAttributes;\r\n    function AltFunc(Index: Integer): TtkTokenKind;\r\n    function KeyWordFunc(Index: Integer): TtkTokenKind;\r\n    function HashKey(Str: PWideChar): Cardinal;\r\n    function IdentKind(MayBe: PWideChar): TtkTokenKind;\r\n    procedure InitIdent;\r\n    procedure AsciiCharProc;\r\n    procedure VariableProc;\r\n    procedure CRProc;\r\n    procedure IdentProc;\r\n    procedure MacroProc;\r\n    procedure PrintProc;\r\n    procedure LFProc;\r\n    procedure NullProc;\r\n    procedure NumberProc;\r\n    procedure CommentProc;\r\n    procedure SpaceProc;\r\n    procedure StringProc;\r\n    procedure UnknownProc;\r\n  protected\r\n    function GetSampleSource: UnicodeString; override;\r\n    function IsFilterStored: Boolean; override;\r\n  public\r\n    class function GetLanguageName: string; override;\r\n    class function GetFriendlyLanguageName: UnicodeString; override;\r\n  public\r\n    constructor Create(AOwner: TComponent); override;\r\n    function GetDefaultAttribute(Index: integer): TSynHighlighterAttributes;\r\n      override;\r\n    function GetEol: Boolean; override;\r\n    function GetTokenID: TtkTokenKind;\r\n    function GetTokenAttribute: TSynHighlighterAttributes; override;\r\n    function GetTokenKind: integer; override;\r\n    procedure Next; override;\r\n  published\r\n    property CommentAttri: TSynHighlighterAttributes read fCommentAttri\r\n      write fCommentAttri;\r\n    property IdentifierAttri: TSynHighlighterAttributes read fIdentifierAttri\r\n      write fIdentifierAttri;\r\n    property KeyAttri: TSynHighlighterAttributes read fKeyAttri write fKeyAttri;\r\n    property MiscellaneousAttri: TSynHighlighterAttributes\r\n      read fMiscellaneousAttri write fMiscellaneousAttri;\r\n    property NumberAttri: TSynHighlighterAttributes read fNumberAttri\r\n      write fNumberAttri;\r\n    property SpaceAttri: TSynHighlighterAttributes read fSpaceAttri\r\n      write fSpaceAttri;\r\n    property StringAttri: TSynHighlighterAttributes read fStringAttri\r\n      write fStringAttri;\r\n    property SymbolAttri: TSynHighlighterAttributes read fSymbolAttri\r\n      write fSymbolAttri;\r\n    property VariableAttri: TSynHighlighterAttributes read fVariableAttri\r\n      write fVariableAttri;\r\n  end;\r\n\r\nimplementation\r\n\r\nuses\r\n{$IFDEF SYN_CLX}\r\n  QSynEditStrConst;\r\n{$ELSE}\r\n  SynEditStrConst;\r\n{$ENDIF}\r\n\r\nconst\r\n  KeyWords: array[0..168] of UnicodeString = (\r\n    'addkey', 'addprinterconnection', 'addprogramgroup', 'addprogramitem', \r\n    'address', 'asc', 'at', 'backupeventlog', 'beep', 'big', 'box', 'break', \r\n    'call', 'case', 'cd', 'chr', 'cleareventlog', 'close', 'cls', 'color', \r\n    'comment', 'comparefiletimes', 'cookie1', 'copy', 'curdir', 'date', 'day', \r\n    'dectohex', 'del', 'delkey', 'delprinterconnection', 'delprogramgroup', \r\n    'delprogramitem', 'deltree', 'delvalue', 'dim', 'dir', 'display', 'do', \r\n    'domain', 'dos', 'else', 'endif', 'endselect', 'enumgroup', 'enumkey', \r\n    'enumlocalgroup', 'enumvalue', 'error', 'execute', 'exist', 'existkey', \r\n    'exit', 'expandenvironmentvars', 'flushkb', 'fullname', 'get', \r\n    'getdiskspace', 'getfileattr', 'getfilesize', 'getfiletime', \r\n    'getfileversion', 'gets', 'global', 'go', 'gosub', 'goto', 'homedir', \r\n    'homedrive', 'homeshr', 'hostname', 'if', 'ingroup', 'instr', 'inwin', \r\n    'ipaddress', 'kix', 'lanroot', 'lcase', 'ldomain', 'ldrive', 'len', 'lm', \r\n    'loadhive', 'loadkey', 'logevent', 'logoff', 'longhomedir', 'loop', \r\n    'lserver', 'ltrim', 'maxpwage', 'md', 'mdayno', 'messagebox', 'month', \r\n    'monthno', 'olecallfunc', 'olecallproc', 'olecreateobject', 'oleenumobject', \r\n    'olegetobject', 'olegetproperty', 'olegetsubobject', 'oleputproperty', \r\n    'olereleaseobject', 'open', 'password', 'play', 'primarygroup', 'priv', \r\n    'pwage', 'quit', 'ras', 'rd', 'readline', 'readprofilestring', 'readtype', \r\n    'readvalue', 'redirectoutput', 'return', 'rnd', 'rserver', 'rtrim', 'run', \r\n    'savekey', 'scriptdir', 'select', 'sendkeys', 'sendmessage', 'serror', \r\n    'set', 'setascii', 'setconsole', 'setdefaultprinter', 'setfileattr', \r\n    'setfocus', 'setl', 'setm', 'settime', 'setwallpaper', 'shell', \r\n    'showprogramgroup', 'shutdown', 'sid', 'site', 'sleep', 'small', 'srnd', \r\n    'startdir', 'substr', 'syslang', 'time', 'ucase', 'unloadhive', 'until', \r\n    'use', 'userid', 'userlang', 'val', 'wdayno', 'while', 'wksta', 'writeline', \r\n    'writeprofilestring', 'writevalue', 'wuserid', 'ydayno', 'year' \r\n  );\r\n\r\n  KeyIndices: array[0..970] of Integer = (\r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 95, -1, -1, -1, -1, -1, -1, 10, \r\n    -1, 29, 25, -1, -1, -1, 151, -1, -1, 22, -1, -1, -1, -1, -1, -1, -1, 64, -1, \r\n    -1, 76, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 97, 135, -1, -1, -1, 89, \r\n    -1, -1, -1, -1, -1, 48, -1, -1, -1, 164, -1, -1, -1, -1, -1, -1, -1, 52, -1, \r\n    -1, -1, -1, -1, 153, -1, 17, -1, -1, -1, -1, -1, -1, -1, 18, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, 67, -1, -1, 101, -1, -1, -1, -1, -1, -1, 111, 159, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, 63, -1, -1, -1, -1, -1, -1, -1, -1, 15, -1, \r\n    0, -1, -1, -1, -1, -1, 96, -1, -1, 133, -1, -1, 117, 129, -1, -1, -1, 9, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 66, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, 36, -1, -1, 88, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 11, -1, -1, -1, \r\n    -1, -1, 150, -1, 72, -1, -1, -1, -1, -1, -1, 142, 94, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 80, 137, -1, -1, 118, -1, -1, 112, \r\n    -1, 85, -1, -1, -1, 2, -1, -1, -1, -1, -1, -1, 70, 30, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, 157, -1, 90, -1, 24, 91, -1, 131, -1, -1, -1, -1, -1, 147, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    43, -1, -1, -1, -1, -1, -1, -1, 161, -1, -1, -1, -1, -1, -1, 165, -1, -1, \r\n    -1, -1, -1, -1, -1, 44, -1, -1, -1, -1, -1, -1, -1, 78, -1, -1, 127, 158, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 109, -1, \r\n    -1, -1, 116, 100, -1, -1, -1, -1, -1, -1, -1, 119, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, 93, -1, -1, -1, -1, -1, -1, 41, 79, -1, 156, -1, -1, 7, -1, -1, -1, \r\n    -1, -1, 12, -1, -1, -1, -1, -1, -1, -1, 74, -1, -1, -1, -1, -1, -1, 81, -1, \r\n    31, -1, 148, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 39, -1, -1, -1, -1, -1, \r\n    32, -1, 121, -1, -1, 86, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 68, -1, -1, -1, 105, -1, -1, -1, -1, \r\n    -1, -1, 33, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 138, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, 61, -1, -1, -1, -1, -1, -1, -1, -1, 59, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 168, 160, -1, -1, -1, -1, \r\n    -1, -1, -1, 26, -1, 14, -1, -1, 108, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, 132, -1, -1, 50, -1, -1, 126, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, 141, -1, -1, -1, -1, -1, -1, -1, 130, 84, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 71, -1, -1, -1, -1, 45, \r\n    107, 13, -1, -1, -1, 65, -1, -1, -1, -1, 34, -1, -1, -1, -1, 143, -1, -1, \r\n    -1, 128, -1, 73, 134, 27, -1, -1, -1, -1, -1, 120, -1, 57, -1, -1, -1, 51, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, 82, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    123, -1, -1, -1, -1, -1, -1, -1, 46, -1, -1, -1, -1, 49, -1, -1, -1, -1, -1, \r\n    54, 77, -1, -1, 98, -1, -1, -1, -1, -1, 113, -1, -1, 104, -1, 1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, 163, -1, 136, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, 4, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 6, -1, 19, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, 38, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 5, -1, -1, -1, 102, \r\n    -1, -1, 23, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    92, -1, -1, -1, -1, -1, -1, -1, -1, 146, -1, -1, -1, -1, 103, -1, 99, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, 140, -1, -1, -1, -1, 155, 56, 115, -1, -1, \r\n    -1, -1, -1, -1, 162, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, 125, -1, -1, -1, -1, 42, 58, -1, -1, -1, -1, -1, -1, -1, 167, -1, \r\n    -1, -1, 87, -1, -1, -1, 53, -1, -1, -1, -1, -1, -1, -1, 47, -1, -1, -1, -1, \r\n    16, -1, -1, -1, -1, -1, -1, -1, -1, -1, 35, 154, -1, 75, -1, 110, -1, 83, \r\n    -1, -1, -1, -1, -1, 3, -1, -1, -1, -1, -1, 144, -1, -1, 8, -1, -1, -1, 114, \r\n    -1, -1, -1, 152, -1, -1, -1, -1, 20, 145, 60, -1, -1, 28, -1, 55, -1, -1, \r\n    -1, -1, -1, 124, -1, -1, -1, -1, 106, -1, -1, -1, -1, 139, -1, -1, -1, 69, \r\n    -1, -1, 122, 166, -1, 62, 149, 21, 37, -1, -1, -1, -1, 40, -1, -1, -1, -1, \r\n    -1, -1, -1 \r\n  );\r\n\r\n{$Q-}\r\nfunction TSynKixSyn.HashKey(Str: PWideChar): Cardinal;\r\nbegin\r\n  Result := 0;\r\n  while IsIdentChar(Str^) do\r\n  begin\r\n    Result := Result * 949 + Ord(Str^) * 246;\r\n    inc(Str);\r\n  end;\r\n  Result := Result mod 971;\r\n  fStringLen := Str - fToIdent;\r\nend;\r\n{$Q+}\r\n\r\nfunction TSynKixSyn.IdentKind(MayBe: PWideChar): TtkTokenKind;\r\nvar\r\n  Key: Cardinal;\r\nbegin\r\n  fToIdent := MayBe;\r\n  Key := HashKey(MayBe);\r\n  if Key <= High(fIdentFuncTable) then\r\n    Result := fIdentFuncTable[Key](KeyIndices[Key])\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nprocedure TSynKixSyn.InitIdent;\r\nvar\r\n  i: Integer;\r\nbegin\r\n  for i := Low(fIdentFuncTable) to High(fIdentFuncTable) do\r\n    if KeyIndices[i] = -1 then\r\n      fIdentFuncTable[i] := AltFunc;\r\n\r\n  for i := Low(fIdentFuncTable) to High(fIdentFuncTable) do\r\n    if @fIdentFuncTable[i] = nil then\r\n      fIdentFuncTable[i] := KeyWordFunc;\r\nend;\r\n\r\nfunction TSynKixSyn.AltFunc(Index: Integer): TtkTokenKind;\r\nbegin\r\n  Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynKixSyn.KeyWordFunc(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nconstructor TSynKixSyn.Create(AOwner: TComponent);\r\nbegin\r\n  inherited Create(AOwner);\r\n\r\n  fCaseSensitive := False;\r\n\r\n  fCommentAttri := TSynHighlighterAttributes.Create(SYNS_AttrComment, SYNS_FriendlyAttrComment);\r\n  fCommentAttri.Style := [fsItalic];\r\n  AddAttribute(fCommentAttri);\r\n  fIdentifierAttri := TSynHighlighterAttributes.Create(SYNS_AttrIdentifier, SYNS_FriendlyAttrIdentifier);\r\n  AddAttribute(fIdentifierAttri);\r\n  fKeyAttri := TSynHighlighterAttributes.Create(SYNS_AttrKey, SYNS_FriendlyAttrKey);\r\n  fKeyAttri.Style := [fsBold];\r\n  AddAttribute(fKeyAttri);\r\n  fMiscellaneousAttri := TSynHighlighterAttributes.Create(SYNS_AttrMiscellaneous, SYNS_FriendlyAttrMiscellaneous);\r\n  AddAttribute(fMiscellaneousAttri);\r\n  fNumberAttri := TSynHighlighterAttributes.Create(SYNS_AttrNumber, SYNS_FriendlyAttrNumber);\r\n  AddAttribute(fNumberAttri);\r\n  fSpaceAttri := TSynHighlighterAttributes.Create(SYNS_AttrSpace, SYNS_FriendlyAttrSpace);\r\n  AddAttribute(fSpaceAttri);\r\n  fStringAttri := TSynHighlighterAttributes.Create(SYNS_AttrString, SYNS_FriendlyAttrString);\r\n  AddAttribute(fStringAttri);\r\n  fSymbolAttri := TSynHighlighterAttributes.Create(SYNS_AttrSymbol, SYNS_FriendlyAttrSymbol);\r\n  AddAttribute(fSymbolAttri);\r\n  fVariableAttri := TSynHighlighterAttributes.Create(SYNS_AttrVariable, SYNS_FriendlyAttrVariable);\r\n  AddAttribute(fVariableAttri);\r\n\r\n  SetAttributesOnChange(DefHighlightChange);\r\n  InitIdent;\r\n  fDefaultFilter := SYNS_FilterKIX;\r\nend;\r\n\r\nprocedure TSynKixSyn.AsciiCharProc;\r\nbegin\r\n  fTokenID := tkString;\r\n  inc(Run);\r\n  while CharInSet(FLine[Run], ['0'..'9']) do inc(Run);\r\nend;\r\n\r\nprocedure TSynKixSyn.CRProc;\r\nbegin\r\n  fTokenID := tkSpace;\r\n  inc(Run);\r\n  if fLine[Run] = #10 then inc(Run);\r\nend;\r\n\r\nprocedure TSynKixSyn.IdentProc;\r\nbegin\r\n  fTokenID := IdentKind((fLine + Run));\r\n  inc(Run, fStringLen);\r\n  while IsIdentChar(fLine[Run]) do inc(Run);\r\nend;\r\n\r\nprocedure TSynKixSyn.MacroProc;\r\n\r\n  function IsMacroChar: Boolean;\r\n  begin\r\n    case fLine[Run] of\r\n      '0'..'9', 'A'..'Z', 'a'..'z':\r\n        Result := True;\r\n      else\r\n        Result := False;\r\n    end;\r\n  end;\r\n\r\nbegin\r\n  inc(Run);\r\n  fTokenID := tkMiscellaneous;\r\n  while IsMacroChar do inc(Run);\r\nend;\r\n\r\nprocedure TSynKixSyn.LFProc;\r\nbegin\r\n  fTokenID := tkSpace;\r\n  inc(Run);\r\nend;\r\n\r\nprocedure TSynKixSyn.PrintProc;\r\nbegin\r\n  fTokenID := tkKey;\r\n  inc(Run);\r\nend;\r\n\r\nprocedure TSynKixSyn.VariableProc;\r\nbegin\r\n  fTokenId := tkVariable;\r\n  inc(run);\r\n  while IsIdentChar(FLine[Run]) do inc(run);\r\nend;\r\n\r\nprocedure TSynKixSyn.NullProc;\r\nbegin\r\n  fTokenID := tkNull;\r\n  inc(Run);\r\nend;\r\n\r\nprocedure TSynKixSyn.NumberProc;\r\n\r\n  function IsNumberChar: Boolean;\r\n  begin\r\n    case fLine[Run] of\r\n      '0'..'9', '.', 'e', 'E':\r\n        Result := True;\r\n      else\r\n        Result := False;\r\n    end;\r\n  end;\r\n\r\nbegin\r\n  inc(Run);\r\n  fTokenID := tkNumber;\r\n  while IsNumberChar do\r\n  begin\r\n    case FLine[Run] of\r\n      '.':\r\n        if FLine[Run + 1] = '.' then break;\r\n    end;\r\n    inc(Run);\r\n  end;\r\nend;\r\n\r\nprocedure TSynKixSyn.CommentProc;\r\nbegin\r\n  fTokenID := tkComment;\r\n  repeat\r\n    inc(Run);\r\n  until IsLineEnd(Run);\r\nend;\r\n\r\nprocedure TSynKixSyn.SpaceProc;\r\nbegin\r\n  inc(Run);\r\n  fTokenID := tkSpace;\r\n  while (FLine[Run] <= #32) and not IsLineEnd(Run) do inc(Run);\r\nend;\r\n\r\nprocedure TSynKixSyn.StringProc;\r\nvar\r\n  C: WideChar;\r\nbegin\r\n  fTokenID := tkString;\r\n  C := fline[run];\r\n  repeat\r\n    case FLine[Run] of\r\n      #0, #10, #13: break;\r\n    end;\r\n    inc(Run);\r\n  until FLine[Run] = C;\r\n  if FLine[Run] <> #0 then inc(Run);\r\nend;\r\n\r\nprocedure TSynKixSyn.UnknownProc;\r\nbegin\r\n  inc(Run);\r\n  fTokenID := tkUnknown;\r\nend;\r\n\r\nprocedure TSynKixSyn.Next;\r\nbegin\r\n  fTokenPos := Run;\r\n  case fLine[Run] of\r\n    '#': AsciiCharProc;\r\n    #13: CRProc;\r\n    'A'..'Z', 'a'..'z', '_': IdentProc;\r\n    #10: LFProc;\r\n    #0: NullProc;\r\n    '0'..'9': NumberProc;\r\n    ';': CommentProc;\r\n    #1..#9, #11, #12, #14..#32: SpaceProc;\r\n    '\"','''': StringProc;\r\n    '@': MacroProc;\r\n    '?': PrintProc;\r\n    '$': VariableProc;\r\n    else UnknownProc;\r\n  end;\r\n  inherited;\r\nend;\r\n\r\nfunction TSynKixSyn.GetDefaultAttribute(Index: Integer): TSynHighlighterAttributes;\r\nbegin\r\n  case Index of\r\n    SYN_ATTR_COMMENT: Result := fCommentAttri;\r\n    SYN_ATTR_IDENTIFIER: Result := fIdentifierAttri;\r\n    SYN_ATTR_KEYWORD: Result := fKeyAttri;\r\n    SYN_ATTR_STRING: Result := fStringAttri;\r\n    SYN_ATTR_WHITESPACE: Result := fSpaceAttri;\r\n    SYN_ATTR_SYMBOL: Result := fSymbolAttri;\r\n    else Result := nil;\r\n  end;\r\nend;\r\n\r\nfunction TSynKixSyn.GetEol: Boolean;\r\nbegin\r\n  Result := Run = fLineLen + 1;\r\nend;\r\n\r\nfunction TSynKixSyn.GetTokenID: TtkTokenKind;\r\nbegin\r\n  Result := fTokenId;\r\nend;\r\n\r\nfunction TSynKixSyn.GetTokenAttribute: TSynHighlighterAttributes;\r\nbegin\r\n  case GetTokenID of\r\n    tkComment: Result := fCommentAttri;\r\n    tkIdentifier: Result := fIdentifierAttri;\r\n    tkKey: Result := fKeyAttri;\r\n    tkMiscellaneous: Result := fMiscellaneousAttri;\r\n    tkNumber: Result := fNumberAttri;\r\n    tkSpace: Result := fSpaceAttri;\r\n    tkString: Result := fStringAttri;\r\n    tkSymbol: Result := fSymbolAttri;\r\n    tkVariable: Result := fVariableAttri;\r\n    tkUnknown: Result := fIdentifierAttri;\r\n    else Result := nil;\r\n  end;\r\nend;\r\n\r\nfunction TSynKixSyn.GetTokenKind: integer;\r\nbegin\r\n  Result := Ord(fTokenId);\r\nend;\r\n\r\nclass function TSynKixSyn.GetLanguageName: string;\r\nbegin\r\n  Result := SYNS_LangKIX;\r\nend;\r\n\r\nfunction TSynKixSyn.IsFilterStored: Boolean;\r\nbegin\r\n  Result := fDefaultFilter <> SYNS_FilterKIX;\r\nend;\r\n\r\nfunction TSynKixSyn.GetSampleSource: UnicodeString;\r\nbegin\r\n  Result := '; KiXtart sample source'#13#10 +\r\n            'break on'#13#10 +\r\n            'color b/n'#13#10 +\r\n            #13#10 +\r\n            'AT(1, 30) \"Hello World!\"'#13#10 +\r\n            '$USERID = @USERID'#13#10 +\r\n            'AT(1, 30) $USERID';\r\nend;\r\n\r\nclass function TSynKixSyn.GetFriendlyLanguageName: UnicodeString;\r\nbegin\r\n  Result := SYNS_FriendlyLangKIX;\r\nend;\r\n\r\ninitialization\r\n{$IFNDEF SYN_CPPB_1}\r\n  RegisterPlaceableHighlighter(TSynKixSyn);\r\n{$ENDIF}\r\nend.\r\n"
  },
  {
    "path": "External/SynEdit/Source/SynHighlighterLDraw.pas",
    "content": "{-------------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nCode template generated with SynGen.\r\nThe original code is: SynHighlighterLDraw.pas, released 2003-04-12.\r\nDescription: LDraw Parser/Highlighter\r\nThe initial author of this file is Orion Pobursky.\r\nCopyright (c) 2003, all rights reserved.\r\nUnicode translation by Mal Hrz.\r\n\r\nContributors to the SynEdit and mwEdit projects are listed in the\r\nContributors.txt file.\r\n\r\nAlternatively, the contents of this file may be used under the terms of the\r\nGNU General Public License Version 2 or later (the \"GPL\"), in which case\r\nthe provisions of the GPL are applicable instead of those above.\r\nIf you wish to allow use of your version of this file only under the terms\r\nof the GPL and not to allow others to use your version of this file\r\nunder the MPL, indicate your decision by deleting the provisions above and\r\nreplace them with the notice and other provisions required by the GPL.\r\nIf you do not delete the provisions above, a recipient may use your version\r\nof this file under either the MPL or the GPL.\r\n\r\n$Id: SynHighlighterLDraw.pas,v 1.7.2.7 2008/09/14 16:25:00 maelh Exp $\r\n\r\nYou may retrieve the latest version of this file at the SynEdit home page,\r\nlocated at http://SynEdit.SourceForge.net\r\n\r\n-------------------------------------------------------------------------------}\r\n{\r\n@abstract(Provides an LDraw syntax highlighter for SynEdit)\r\n@author(Orion Pobursky)\r\n@created(03/01/2003)\r\n@lastmod(07/05/2003)\r\nThe SynHighlighterLDraw unit provides SynEdit with a LEGO LDraw (.ldr / .dat) highlighter.\r\n}\r\n\r\n{$IFNDEF QSYNHIGHLIGHTERLDRAW}\r\nunit SynHighlighterLDraw;\r\n{$ENDIF}\r\n\r\n{$I SynEdit.inc}\r\n\r\ninterface\r\n\r\nuses\r\n{$IFDEF SYN_CLX}\r\n  Qt, QControls, QGraphics,\r\n  QSynEditHighlighter,\r\n  QSynEditTypes,\r\n  QSynUnicode,\r\n{$ELSE}\r\n  Windows, Controls, Graphics,\r\n  SynEditHighlighter, SynEditTypes,\r\n  SynUnicode,\r\n{$ENDIF}\r\n  SysUtils,\r\n  Classes;\r\n\r\ntype\r\n  TtkTokenKind = (\r\n    tkColor,\r\n    tkComment,\r\n    tkFirstTri,\r\n    tkFourthTri,\r\n    tkIdentifier,\r\n    tkKey,\r\n    tkLine,\r\n    tkNull,\r\n    tkOpLine,\r\n    tkQuad,\r\n    tkSecondTri,\r\n    tkThirdTri,\r\n    tkTriangle,\r\n    tkUnknown);\r\n\r\n  TRangeState = (rsUnKnown);\r\n\r\n  PIdentFuncTableFunc = ^TIdentFuncTableFunc;\r\n  TIdentFuncTableFunc = function (Index: Integer): TtkTokenKind of object;\r\n\r\ntype\r\n  TSynLDRSyn = class(TSynCustomHighlighter)\r\n  private\r\n    fRange: TRangeState;\r\n    fTokenID: TtkTokenKind;\r\n    fIdentFuncTable: array[0..1] of TIdentFuncTableFunc;\r\n    fColorAttri: TSynHighlighterAttributes;\r\n    fCommentAttri: TSynHighlighterAttributes;\r\n    fFirstTriAttri: TSynHighlighterAttributes;\r\n    fFourthTriAttri: TSynHighlighterAttributes;\r\n    fIdentifierAttri: TSynHighlighterAttributes;\r\n    fKeyAttri: TSynHighlighterAttributes;\r\n    fLineAttri: TSynHighlighterAttributes;\r\n    fOpLineAttri: TSynHighlighterAttributes;\r\n    fQuadAttri: TSynHighlighterAttributes;\r\n    fSecondTriAttri: TSynHighlighterAttributes;\r\n    fThirdTriAttri: TSynHighlighterAttributes;\r\n    fTriangleAttri: TSynHighlighterAttributes;\r\n    function AltFunc(Index: Integer): TtkTokenKind;\r\n    function FuncAuthor(Index: Integer): TtkTokenKind;\r\n    function HashKey(Str: PWideChar): Cardinal;\r\n    function IdentKind(MayBe: PWideChar): TtkTokenKind;\r\n    procedure InitIdent;\r\n    procedure IdentProc;\r\n    procedure Number1Proc;\r\n    procedure UnknownProc;\r\n    procedure NullProc;\r\n    procedure CRProc;\r\n    procedure LFProc;\r\n    function FirstChar(DatLine: PWideChar): WideChar;\r\n  protected\r\n    function GetSampleSource: UnicodeString; override;\r\n    function IsFilterStored: Boolean; override;\r\n  public\r\n    constructor Create(AOwner: TComponent); override;\r\n    class function GetLanguageName: string; override;\r\n    class function GetFriendlyLanguageName: UnicodeString; override;\r\n    function GetRange: Pointer; override;\r\n    procedure ResetRange; override;\r\n    procedure SetRange(Value: Pointer); override;\r\n    function GetDefaultAttribute(Index: integer): TSynHighlighterAttributes; override;\r\n    function GetEol: Boolean; override;\r\n    function GetKeyWords(TokenKind: Integer): UnicodeString; override;\r\n    function GetTokenID: TtkTokenKind;\r\n    function GetTokenAttribute: TSynHighlighterAttributes; override;\r\n    function GetTokenKind: integer; override;\r\n    function IsIdentChar(AChar: WideChar): Boolean; override;\r\n    procedure Next; override;\r\n  published\r\n    property ColorAttri: TSynHighlighterAttributes read fColorAttri write fColorAttri;\r\n    property CommentAttri: TSynHighlighterAttributes read fCommentAttri write fCommentAttri;\r\n    property FirstTriAttri: TSynHighlighterAttributes read fFirstTriAttri write fFirstTriAttri;\r\n    property FourthTriAttri: TSynHighlighterAttributes read fFourthTriAttri write fFourthTriAttri;\r\n    property IdentifierAttri: TSynHighlighterAttributes read fIdentifierAttri write fIdentifierAttri;\r\n    property KeyAttri: TSynHighlighterAttributes read fKeyAttri write fKeyAttri;\r\n    property LineAttri: TSynHighlighterAttributes read fLineAttri write fLineAttri;\r\n    property OpLineAttri: TSynHighlighterAttributes read fOpLineAttri write fOpLineAttri;\r\n    property QuadAttri: TSynHighlighterAttributes read fQuadAttri write fQuadAttri;\r\n    property SecondTriAttri: TSynHighlighterAttributes read fSecondTriAttri write fSecondTriAttri;\r\n    property ThirdTriAttri: TSynHighlighterAttributes read fThirdTriAttri write fThirdTriAttri;\r\n    property TriangleAttri: TSynHighlighterAttributes read fTriangleAttri write fTriangleAttri;\r\n  end;\r\n\r\nimplementation\r\n\r\nuses\r\n{$IFDEF SYN_CLX}\r\n  QSynEditStrConst;\r\n{$ELSE}\r\n  SynEditStrConst;\r\n{$ENDIF}\r\n\r\nconst\r\n  KeyWords: array[0..0] of UnicodeString = (\r\n    'author' \r\n  );\r\n\r\n  KeyIndices: array[0..1] of Integer = (\r\n    -1, 0 \r\n  );\r\n\r\n{$Q-}\r\nfunction TSynLDRSyn.HashKey(Str: PWideChar): Cardinal;\r\nbegin\r\n  Result := 0;\r\n  while IsIdentChar(Str^) do\r\n  begin\r\n    Result := Result + Ord(Str^);\r\n    inc(Str);\r\n  end;\r\n  Result := Result mod 2;\r\n  fStringLen := Str - fToIdent;\r\nend;\r\n{$Q+}\r\n\r\nfunction TSynLDRSyn.IdentKind(MayBe: PWideChar): TtkTokenKind;\r\nvar\r\n  Key: Cardinal;\r\nbegin\r\n  fToIdent := MayBe;\r\n  Key := HashKey(MayBe);\r\n  if Key <= High(fIdentFuncTable) then\r\n    Result := fIdentFuncTable[Key](KeyIndices[Key])\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nprocedure TSynLDRSyn.InitIdent;\r\nvar\r\n  i: Integer;\r\nbegin\r\n  for i := Low(fIdentFuncTable) to High(fIdentFuncTable) do\r\n    if KeyIndices[i] = -1 then\r\n      fIdentFuncTable[i] := AltFunc;\r\n\r\n  fIdentFuncTable[1] := FuncAuthor;\r\nend;\r\n\r\n{$IFDEF SYN_CLX}\r\nfunction RGB(const R, G, B: Byte):  TColor;\r\nbegin\r\n  Result := R or (G shl 8) or (B shl 16)\r\nend;\r\n{$ENDIF}\r\n\r\nfunction TSynLDRSyn.AltFunc(Index: Integer): TtkTokenKind;\r\nbegin\r\n  Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynLDRSyn.FuncAuthor(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nprocedure TSynLDRSyn.NullProc;\r\nbegin\r\n  fTokenID := tkNull;\r\n  inc(Run);\r\nend;\r\n\r\nprocedure TSynLDRSyn.CRProc;\r\nbegin\r\n  fTokenID := tkUnknown;\r\n  inc(Run);\r\n  if fLine[Run] = #10 then\r\n    inc(Run);\r\nend;\r\n\r\nprocedure TSynLDRSyn.LFProc;\r\nbegin\r\n  fTokenID := tkUnknown;\r\n  inc(Run);\r\nend;\r\n\r\nconstructor TSynLDRSyn.Create(AOwner: TComponent);\r\n\r\n  {$IFDEF SYN_KYLIX}\r\n  function RGB(r, g, b: Byte): LongWord;\r\n  begin\r\n    Result := (r or (g shl 8) or (b shl 16));\r\n  end;\r\n  {$ENDIF}\r\n\r\nbegin\r\n  inherited Create(AOwner);\r\n  fColorAttri := TSynHighLighterAttributes.Create(SYNS_AttrColor, SYNS_FriendlyAttrColor);\r\n  fColorAttri.Foreground := clNavy;\r\n  AddAttribute(fColorAttri);\r\n\r\n  fCommentAttri := TSynHighLighterAttributes.Create(SYNS_AttrComment, SYNS_FriendlyAttrComment);\r\n  fCommentAttri.Foreground := clBlue;\r\n  AddAttribute(fCommentAttri);\r\n\r\n  fFirstTriAttri := TSynHighLighterAttributes.Create(SYNS_AttrFirstTri, SYNS_FriendlyAttrFirstTri);\r\n  fFirstTriAttri.Foreground := RGB(206,111,73);\r\n  AddAttribute(fFirstTriAttri);\r\n\r\n  fFourthTriAttri := TSynHighLighterAttributes.Create(SYNS_AttrFourthTri, SYNS_FriendlyAttrFourthTri);\r\n  fFourthTriAttri.Foreground := RGB(54,99,12);\r\n  AddAttribute(fFourthTriAttri);\r\n\r\n  fIdentifierAttri := TSynHighLighterAttributes.Create(SYNS_AttrIdentifier, SYNS_FriendlyAttrIdentifier);\r\n  AddAttribute(fIdentifierAttri);\r\n\r\n  fKeyAttri := TSynHighLighterAttributes.Create(SYNS_AttrReservedWord, SYNS_FriendlyAttrReservedWord);\r\n  fKeyAttri.Style := [fsBold];\r\n  AddAttribute(fKeyAttri);\r\n\r\n  fLineAttri := TSynHighLighterAttributes.Create(SYNS_AttrLine, SYNS_FriendlyAttrLine);\r\n  fLineAttri.Foreground := clBlack;\r\n  AddAttribute(fLineAttri);\r\n\r\n  fOpLineAttri := TSynHighLighterAttributes.Create(SYNS_AttrOpLine, SYNS_FriendlyAttrOpLine);\r\n  fOpLineAttri.Foreground := clBlack;\r\n  AddAttribute(fOpLineAttri);\r\n\r\n  fQuadAttri := TSynHighLighterAttributes.Create(SYNS_AttrQuad, SYNS_FriendlyAttrQuad);\r\n  fQuadAttri.Foreground := clRed;\r\n  AddAttribute(fQuadAttri);\r\n\r\n  fSecondTriAttri := TSynHighLighterAttributes.Create(SYNS_AttrSecondTri, SYNS_FriendlyAttrSecondTri);\r\n  fSecondTriAttri.Foreground := RGB(54,99,12);\r\n  AddAttribute(fSecondTriAttri);\r\n\r\n  fThirdTriAttri := TSynHighLighterAttributes.Create(SYNS_AttrThirdTri, SYNS_FriendlyAttrThirdTri);\r\n  fThirdTriAttri.Foreground := RGB(206,111,73);\r\n  AddAttribute(fThirdTriAttri);\r\n\r\n  fTriangleAttri := TSynHighLighterAttributes.Create(SYNS_AttrTriangle, SYNS_FriendlyAttrTriangle);\r\n  fTriangleAttri.Foreground := clBlack;\r\n  AddAttribute(fTriangleAttri);\r\n\r\n  SetAttributesOnChange(DefHighlightChange);\r\n  InitIdent;\r\n  fDefaultFilter := SYNS_FilterLDraw;\r\n  fRange := rsUnknown;\r\nend;\r\n\r\nfunction TSynLDRSyn.FirstChar(DatLine: PWideChar): WideChar;\r\nvar\r\n  i: Integer;\r\nbegin\r\n  i := 0;\r\n  while DatLine[i] = ' ' do inc(i);\r\n  Result := DatLine[i];\r\nend;\r\n\r\nprocedure TSynLDRSyn.IdentProc;\r\nbegin\r\n  if FirstChar(fLine) = '0' then\r\n  begin\r\n    fTokenID := tkComment;\r\n    while (fLine[Run] <> #10) and (fLine[Run] <> #13)\r\n          and (fLine[Run] <> #0) do inc(Run);\r\n  end\r\n  else\r\n  begin\r\n    fTokenID := IdentKind((fLine + Run));\r\n  inc(Run, fStringLen);\r\n  while IsIdentChar(fLine[Run]) do\r\n    Inc(Run);\r\n  end;\r\nend;\r\n\r\nprocedure TSynLDRSyn.Number1Proc;\r\n\r\n  function ArgNumber(DatLine: PWideChar): Byte;\r\n  var\r\n   i: Integer;\r\n   b: Boolean;\r\n  begin\r\n    i := 0;\r\n    Result := 0;\r\n    b := False;\r\n    while i <= Run do\r\n    begin\r\n      if DatLine[i] = ' ' then\r\n      begin\r\n        inc(i);\r\n        b := False;\r\n      end\r\n      else\r\n      begin\r\n        if not b then inc(Result);\r\n        b := True;\r\n        inc(i)\r\n      end;\r\n    end;\r\n  end;\r\n\r\nbegin\r\n  case ArgNumber(fLine) of\r\n    1: begin\r\n         case fLine[Run] of\r\n           '0': fTokenID := tkComment;\r\n           '1': fTokenID := tkIdentifier;\r\n           '2': fTokenID := tkLine;\r\n           '3': fTokenID := tkTriangle;\r\n           '4': fTokenID := tkQuad;\r\n           '5': fTokenID := tkOpLine;\r\n         end;\r\n       end; \r\n    2: if FirstChar(fLine) <> '0' then fTokenID := tkColor \r\n         else fTokenID := tkComment; \r\n    3..5: if FirstChar(fLine) <> '0' then fTokenID := tkFirstTri\r\n            else fTokenID := tkComment; \r\n    6..8: if FirstChar(fLine) <> '0' then fTokenID := tkSecondTri\r\n            else fTokenID := tkComment; \r\n    9..11: if FirstChar(fLine) <> '0' then fTokenID := tkThirdTri\r\n             else fTokenID := tkComment; \r\n    12..14: if FirstChar(fLine) <> '0' then fTokenID := tkFourthTri\r\n             else fTokenID := tkComment; \r\n    else\r\n      fTokenID := tkIdentifier;\r\n  end;\r\n  while CharInSet(FLine[Run], ['0'..'9', '.']) do inc(Run);\r\nend;\r\n\r\nprocedure TSynLDRSyn.UnknownProc;\r\nbegin\r\n  inc(Run);\r\n  fTokenID := tkUnknown;\r\nend;\r\n\r\nprocedure TSynLDRSyn.Next;\r\nbegin\r\n  fTokenPos := Run;\r\n  case fLine[Run] of\r\n    #0: NullProc;\r\n    #10: LFProc;\r\n    #13: CRProc;\r\n    'A'..'Z', 'a'..'z', '_': IdentProc;\r\n    '0'..'9': Number1Proc;\r\n    else UnknownProc;\r\n  end;\r\n  inherited;\r\nend;\r\n\r\nfunction TSynLDRSyn.GetDefaultAttribute(Index: integer): TSynHighLighterAttributes;\r\nbegin\r\n  case Index of\r\n    SYN_ATTR_COMMENT: Result := fCommentAttri;\r\n    SYN_ATTR_IDENTIFIER: Result := fIdentifierAttri;\r\n    SYN_ATTR_KEYWORD: Result := fKeyAttri;\r\n  else\r\n    Result := nil;\r\n  end;\r\nend;\r\n\r\nfunction TSynLDRSyn.GetEol: Boolean;\r\nbegin\r\n  Result := Run = fLineLen + 1;\r\nend;\r\n\r\nfunction TSynLDRSyn.GetKeyWords(TokenKind: Integer): UnicodeString;\r\nbegin\r\n  Result := 'Author';\r\nend;\r\n\r\nfunction TSynLDRSyn.GetTokenID: TtkTokenKind;\r\nbegin\r\n  Result := fTokenId;\r\nend;\r\n\r\nfunction TSynLDRSyn.GetTokenAttribute: TSynHighLighterAttributes;\r\nbegin\r\n  case GetTokenID of\r\n    tkColor: Result := fColorAttri;\r\n    tkComment: Result := fCommentAttri;\r\n    tkFirstTri: Result := fFirstTriAttri;\r\n    tkFourthTri: Result := fFourthTriAttri;\r\n    tkIdentifier: Result := fIdentifierAttri;\r\n    tkKey: Result := fKeyAttri;\r\n    tkLine: Result := fLineAttri;\r\n    tkOpLine: Result := fOpLineAttri;\r\n    tkQuad: Result := fQuadAttri;\r\n    tkSecondTri: Result := fSecondTriAttri;\r\n    tkThirdTri: Result := fThirdTriAttri;\r\n    tkTriangle: Result := fTriangleAttri;\r\n    tkUnknown: Result := fIdentifierAttri;\r\n  else\r\n    Result := nil;\r\n  end;\r\nend;\r\n\r\nfunction TSynLDRSyn.GetTokenKind: integer;\r\nbegin\r\n  Result := Ord(fTokenId);\r\nend;\r\n\r\nfunction TSynLDRSyn.GetSampleSource: UnicodeString;\r\nbegin\r\n  Result := #13#10 +\r\n            'Sample source for: '#13#10 +\r\n            'Ldraw Parser/Highlighter'#13#10 +\r\n            '0 Comment'#13#10 +\r\n            '1 16 0 0 0 1 0 0 0 1 0 0 0 1 stud.dat'#13#10 +\r\n            '2 16 0 0 0 1 1 1'#13#10 +\r\n            '3 16 0 0 0 1 1 1 2 2 2'#13#10 +\r\n            '4 16 0 0 0 1 1 1 2 2 2 3 3 3'#13#10 +\r\n            '5 16 0 0 0 1 1 1 2 2 2 3 3 3';\r\nend;\r\n\r\nfunction TSynLDRSyn.IsFilterStored: Boolean;\r\nbegin\r\n  Result := fDefaultFilter <> SYNS_FilterLDraw;\r\nend;\r\n\r\nfunction TSynLDRSyn.IsIdentChar(AChar: WideChar): Boolean;\r\nbegin\r\n  case AChar of\r\n    '_', 'A'..'Z', 'a'..'z':\r\n      Result := True;\r\n    else\r\n      Result := False;\r\n  end;\r\nend;\r\n\r\nclass function TSynLDRSyn.GetLanguageName: string;\r\nbegin\r\n  Result := SYNS_LangLDraw;\r\nend;\r\n\r\nprocedure TSynLDRSyn.ResetRange;\r\nbegin\r\n  fRange := rsUnknown;\r\nend;\r\n\r\nprocedure TSynLDRSyn.SetRange(Value: Pointer);\r\nbegin\r\n  fRange := TRangeState(Value);\r\nend;\r\n\r\nfunction TSynLDRSyn.GetRange: Pointer;\r\nbegin\r\n  Result := Pointer(fRange);\r\nend;\r\n\r\nclass function TSynLDRSyn.GetFriendlyLanguageName: UnicodeString;\r\nbegin\r\n  Result := SYNS_FriendlyLangLDraw;\r\nend;\r\n\r\ninitialization\r\n{$IFNDEF SYN_CPPB_1}\r\n  RegisterPlaceableHighlighter(TSynLDRSyn);\r\n{$ENDIF}\r\nend.\r\n"
  },
  {
    "path": "External/SynEdit/Source/SynHighlighterLLVM.pas",
    "content": "{-------------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nCode template generated with SynGen.\r\nThe original code is: C:\\Users\\Public\\Code\\SynEdit\\SynGen\\LLVM_IR.pas, released 2013-03-30.\r\nDescription: Syntax Parser/Highlighter\r\nThe initial author of this file is Christian.\r\nCopyright (c) 2013, all rights reserved.\r\n\r\nContributors to the SynEdit and mwEdit projects are listed in the\r\nContributors.txt file.\r\n\r\nAlternatively, the contents of this file may be used under the terms of the\r\nGNU General Public License Version 2 or later (the \"GPL\"), in which case\r\nthe provisions of the GPL are applicable instead of those above.\r\nIf you wish to allow use of your version of this file only under the terms\r\nof the GPL and not to allow others to use your version of this file\r\nunder the MPL, indicate your decision by deleting the provisions above and\r\nreplace them with the notice and other provisions required by the GPL.\r\nIf you do not delete the provisions above, a recipient may use your version\r\nof this file under either the MPL or the GPL.\r\n\r\n$Id: $\r\n\r\nYou may retrieve the latest version of this file at the SynEdit home page,\r\nlocated at http://SynEdit.SourceForge.net\r\n\r\n-------------------------------------------------------------------------------}\r\n\r\n{$IFNDEF QLLVM_IR}\r\nunit SynHighlighterLLVM;\r\n{$ENDIF}\r\n\r\n{$I SynEdit.inc}\r\n\r\ninterface\r\n\r\nuses\r\n{$IFDEF SYN_CLX}\r\n  QGraphics,\r\n  QSynEditTypes,\r\n  QSynEditHighlighter,\r\n  QSynUnicode,\r\n{$ELSE}\r\n  Graphics,\r\n  SynEditTypes,\r\n  SynEditHighlighter,\r\n  SynUnicode,\r\n{$ENDIF}\r\n  SysUtils,\r\n  Classes;\r\n\r\ntype\r\n  TtkTokenKind = (\r\n    tkBoolean,\r\n    tkComment,\r\n    tkConstant,\r\n    tkFloat,\r\n    tkHex,\r\n    tkIdentifier,\r\n    tkInstruction,\r\n    tkKey,\r\n    tkLabel,\r\n    tkNumber,\r\n    tkNull,\r\n    tkSpace,\r\n    tkString,\r\n    tkSymbol,\r\n    tkType,\r\n    tkUnnamedIdentifier,\r\n    tkUnknown);\r\n\r\n  TRangeState = (rsUnKnown, rsSingleComment, rsString);\r\n\r\n  TProcTableProc = procedure of object;\r\n\r\n  PIdentFuncTableFunc = ^TIdentFuncTableFunc;\r\n  TIdentFuncTableFunc = function (Index: Integer): TtkTokenKind of object;\r\n\r\ntype\r\n  TSynLLVMIRSyn = class(TSynCustomHighlighter)\r\n  private\r\n    fRange: TRangeState;\r\n    fTokenID: TtkTokenKind;\r\n    fIdentFuncTable: array[0..1552] of TIdentFuncTableFunc;\r\n    fBooleanAttri: TSynHighlighterAttributes;\r\n    fCommentAttri: TSynHighlighterAttributes;\r\n    fConstantAttri: TSynHighlighterAttributes;\r\n    fIdentifierAttri: TSynHighlighterAttributes;\r\n    fInstructionAttri: TSynHighlighterAttributes;\r\n    fKeyAttri: TSynHighlighterAttributes;\r\n    fSpaceAttri: TSynHighlighterAttributes;\r\n    fStringAttri: TSynHighlighterAttributes;\r\n    fLabelAttri: TSynHighlighterAttributes;\r\n    fNumberAttri: TSynHighlighterAttributes;\r\n    fTypesAttri: TSynHighlighterAttributes;\r\n    function HashKey(Str: PWideChar): Cardinal;\r\n    function FuncBoolean(Index: Integer): TtkTokenKind;\r\n    function FuncConstant(Index: Integer): TtkTokenKind;\r\n    function FuncInstruction(Index: Integer): TtkTokenKind;\r\n    function FuncKey(Index: Integer): TtkTokenKind;\r\n    function FuncType(Index: Integer): TtkTokenKind;\r\n    procedure IdentProc;\r\n    procedure UnknownProc;\r\n    function AltFunc(Index: Integer): TtkTokenKind;\r\n    procedure InitIdent;\r\n    function IdentKind(MayBe: PWideChar): TtkTokenKind;\r\n    procedure NullProc;\r\n    procedure SpaceProc;\r\n    procedure CRProc;\r\n    procedure LFProc;\r\n    procedure IntegerTypeProc;\r\n    procedure SingleCommentOpenProc;\r\n    procedure SingleCommentProc;\r\n    procedure StringOpenProc;\r\n    procedure StringProc;\r\n    procedure AtTypeProc;\r\n    procedure PercentTypeProc;\r\n    procedure NumberProc;\r\n  protected\r\n    function GetSampleSource: UnicodeString; override;\r\n    function IsFilterStored: Boolean; override;\r\n  public\r\n    constructor Create(AOwner: TComponent); override;\r\n    class function GetFriendlyLanguageName: UnicodeString; override;\r\n    class function GetLanguageName: string; override;\r\n    function GetRange: Pointer; override;\r\n    procedure ResetRange; override;\r\n    procedure SetRange(Value: Pointer); override;\r\n    function GetDefaultAttribute(Index: Integer): TSynHighlighterAttributes; override;\r\n    function GetEol: Boolean; override;\r\n    function GetKeyWords(TokenKind: Integer): UnicodeString; override;\r\n    function GetTokenID: TtkTokenKind;\r\n    function GetTokenAttribute: TSynHighlighterAttributes; override;\r\n    function GetTokenKind: Integer; override;\r\n    function IsIdentChar(AChar: WideChar): Boolean; override;\r\n    procedure Next; override;\r\n  published\r\n    property BooleanAttribute: TSynHighlighterAttributes read fBooleanAttri write fBooleanAttri;\r\n    property CommentAttribute: TSynHighlighterAttributes read fCommentAttri write fCommentAttri;\r\n    property ConstantAttribute: TSynHighlighterAttributes read fConstantAttri write fConstantAttri;\r\n    property IdentifierAttribute: TSynHighlighterAttributes read fIdentifierAttri write fIdentifierAttri;\r\n    property InstructionAttribute: TSynHighlighterAttributes read fInstructionAttri write fInstructionAttri;\r\n    property KeywordAttribute: TSynHighlighterAttributes read fKeyAttri write fKeyAttri;\r\n    property LabelAttribute: TSynHighlighterAttributes read fLabelAttri write fLabelAttri;\r\n    property NumberAttribute: TSynHighlighterAttributes read fNumberAttri write fNumberAttri;\r\n    property SpaceAttribute: TSynHighlighterAttributes read fSpaceAttri write fSpaceAttri;\r\n    property StringAttribute: TSynHighlighterAttributes read fStringAttri write fStringAttri;\r\n    property TypesAttribute: TSynHighlighterAttributes read fTypesAttri write fTypesAttri;\r\n  end;\r\n\r\nimplementation\r\n\r\nuses\r\n{$IFDEF SYN_CLX}\r\n  QSynEditStrConst;\r\n{$ELSE}\r\n  SynEditStrConst;\r\n{$ENDIF}\r\n\r\nresourcestring\r\n  SYNS_FilterLLVMIR = 'LLVM IR files (*.ll)|*.ll';\r\n  SYNS_LangLLVMIR = 'LLVM IR';\r\n  SYNS_FriendlyLangLLVMIR = 'LLVM Intermediate Representation';\r\n  SYNS_AttrConstant = 'Constant';\r\n  SYNS_FriendlyAttrConstant = 'Constant';\r\n  SYNS_AttrInstructions = 'Instructions';\r\n  SYNS_FriendlyAttrInstructions = 'Instructions';\r\n\r\nconst\r\n  // as this language is case-insensitive keywords *must* be in lowercase\r\n  KeyWords: array[0..216] of UnicodeString = (\r\n    'acq_rel', 'acquire', 'add', 'addrspace', 'alias', 'align', 'alignstack',\r\n    'alloca', 'alwaysinline', 'and', 'appending', 'arcp', 'arm_aapcs_vfpcc', \r\n    'arm_aapcscc', 'arm_apcscc', 'ashr', 'asm', 'atomic', 'atomicrmw',\r\n    'available_externally', 'bitcast', 'blockaddress', 'br', 'byval', 'c', \r\n    'call', 'catch', 'cc', 'ccc', 'cleanup', 'cmpxchg', 'coldcc', 'common', \r\n    'constant', 'datalayout', 'declare', 'default', 'define', 'deplibs', \r\n    'dllexport', 'dllimport', 'double', 'eq', 'exact', 'except', 'extern_weak',\r\n    'external', 'extractelement', 'extractvalue', 'fadd', 'false', 'fast',\r\n    'fastcc', 'fcmp', 'fdiv', 'fence', 'filter', 'float', 'fmul', 'fp128',\r\n    'fpext', 'fptosi', 'fptoui', 'fptrunc', 'free', 'frem', 'fsub', 'gc',\r\n    'getelementptr', 'global', 'half', 'hidden', 'icmp', 'inbounds',\r\n    'indirectbr', 'initialexec', 'inlinehint', 'inreg', 'insertelement', \r\n    'insertvalue', 'intel_ocl_bicc', 'inteldialect', 'internal', 'inttoptr', \r\n    'invoke', 'label', 'landingpad', 'linker_private', 'linker_private_weak', \r\n    'linker_private_weak_def_auto', 'linkonce', 'linkonce_odr', \r\n    'linkonce_odr_auto_hide', 'load', 'localdynamic', 'localexec', 'lshr',\r\n    'malloc', 'max', 'metadata', 'min', 'minsize', 'module', 'monotonic', \r\n    'msp430_intrcc', 'mul', 'naked', 'nand', 'ne', 'nest', 'ninf', 'nnan', \r\n    'noalias', 'nocapture', 'noimplicitfloat', 'noinline', 'nonlazybind', \r\n    'noredzone', 'noreturn', 'nounwind', 'nsw', 'nsz', 'null', 'nuw', 'oeq', \r\n    'oge', 'ogt', 'ole', 'olt', 'one', 'opaque', 'optsize', 'or', 'ord', \r\n    'personality', 'phi', 'ppc_fp128', 'private', 'protected', 'ptrtoint',\r\n    'ptx_device', 'ptx_kernel', 'readnone', 'readonly', 'release', 'resume', \r\n    'ret', 'returns_twice', 'sanitize_address', 'sanitize_memory', \r\n    'sanitize_thread', 'sdiv', 'section', 'select', 'seq_cst', 'sext', 'sge',\r\n    'sgt', 'shl', 'shufflevector', 'sideeffect', 'signext', 'singlethread', \r\n    'sitofp', 'sle', 'slt', 'spir_func', 'spir_kernel', 'srem', 'sret', 'ssp', \r\n    'sspreq', 'sspstrong', 'store', 'sub', 'switch', 'tail', 'target', \r\n    'thread_local', 'to', 'triple', 'true', 'trunc', 'type', 'udiv', 'ueq', \r\n    'uge', 'ugt', 'uitofp', 'ule', 'ult', 'umax', 'umin', 'undef', 'une', \r\n    'unnamed_addr', 'uno', 'unordered', 'unreachable', 'unwind', 'urem', \r\n    'uwtable', 'va_arg', 'void', 'volatile', 'weak', 'weak_odr', \r\n    'x86_fastcallcc', 'x86_fp80', 'x86_mmx', 'x86_stdcallcc', 'x86_thiscallcc', \r\n    'xchg', 'xor', 'zeroext', 'zeroinitializer', 'zext'\r\n  );\r\n\r\n  KeyIndices: array[0..1552] of Integer = (\r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 124, -1, -1, \r\n    64, 40, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 11, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, 9, -1, -1, -1, -1, -1, 183, -1, -1, -1, 168, -1, -1, \r\n    79, -1, -1, -1, -1, 186, -1, -1, -1, -1, -1, 209, 37, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 166, -1, -1, -1, -1, -1, -1, -1, \r\n    211, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 8, -1, -1, -1, -1, -1,\r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 100, 62, -1, \r\n    -1, -1, -1, -1, -1, 91, -1, -1, -1, -1, -1, -1, -1, 33, -1, -1, -1, -1, -1, \r\n    -1, 182, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, 169, -1, -1, -1, -1, 26, 78, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, 116, 143, 93, -1, -1, -1, -1, -1, 165, -1, -1, \r\n    132, -1, -1, -1, -1, 195, -1, -1, -1, -1, 41, -1, -1, -1, -1, -1, 173, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 36, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, 119, -1, -1, 146, -1, -1, -1, -1, -1, -1, 205, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, 120, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, 151, -1, -1, -1, -1, -1, -1, -1, -1, 85, -1, -1, -1, -1, \r\n    207, -1, -1, -1, 111, -1, -1, -1, -1, -1, -1, 128, -1, -1, -1, -1, 106, -1, \r\n    -1, 23, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 89, -1, -1, 161, -1, -1, -1, \r\n    -1, -1, -1, -1, 17, -1, -1, -1, -1, -1, -1, 24, -1, -1, -1, -1, -1, 10, -1, \r\n    133, -1, -1, 122, 65, -1, -1, 53, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, 170, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,\r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 197, 144, -1, \r\n    -1, -1, -1, -1, -1, 57, -1, -1, -1, -1, 189, -1, -1, -1, -1, -1, -1, -1, \r\n    159, -1, -1, -1, -1, -1, -1, -1, -1, 59, -1, 35, -1, -1, 131, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 99, -1, -1, -1, -1, -1, 147, -1,\r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, 77, -1, 196, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, 141, -1, -1, -1, -1, -1, 188, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, 202, -1, -1, -1, -1, -1, 32, -1, -1, -1, \r\n    -1, 187, -1, -1, -1, -1, -1, -1, -1, -1, -1, 191, -1, -1, -1, -1, -1, 18, \r\n    -1, -1, -1, -1, -1, 74, -1, -1, -1, -1, -1, -1, -1, -1, 81, -1, -1, -1, -1,\r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 39, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, 25, -1, -1, -1, -1, -1, 199, 185, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, 55, 129, -1, 12, -1, -1, -1, 54, -1, 215, -1, \r\n    -1, -1, -1, -1, -1, -1, 115, -1, -1, -1, -1, -1, -1, -1, 109, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, 1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, 94, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, 145, -1, -1, -1, -1, -1, -1, -1, -1, -1,\r\n    -1, 75, -1, -1, -1, 138, -1, -1, 160, -1, -1, -1, -1, -1, -1, -1, 34, -1, \r\n    -1, -1, -1, -1, 162, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, 180, -1, -1, -1, -1, -1, -1, -1, -1, 153, -1, -1, -1, -1, -1, -1, -1, \r\n    203, 88, -1, -1, -1, 42, -1, 50, -1, -1, 45, 80, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, 137, -1, -1, 73, 167, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, 130, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 82, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, 2, -1, -1, 71, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    52, -1, -1, -1, -1, -1, -1, 90, -1, -1, -1, -1, -1, -1, 201, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, 113, -1, -1, -1, -1, -1, -1, -1, -1, -1, 48, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, 156, -1, -1, -1, -1, -1, -1, -1, -1, -1, 61, -1, \r\n    -1, 5, -1, 3, -1, 190, -1, -1, -1, -1, -1, -1, -1, 212, -1, -1, 174, -1, -1, \r\n    28, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, 178, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 83, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, 87, -1, -1, -1, -1, -1, -1, 98, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, 193, -1, -1, -1, 21, -1, -1, 121, -1, -1, 214, -1, \r\n    84, 70, -1, -1, 47, -1, -1, -1, -1, -1, 38, -1, 16, -1, -1, -1, -1, -1, -1, \r\n    125, -1, -1, -1, -1, -1, -1, 134, 181, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 154, 123, -1, -1, -1, -1, \r\n    -1, 216, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    206, -1, -1, -1, -1, -1, -1, -1, -1, 49, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, 104, -1, -1, -1, -1, -1, -1, -1, 31, -1, -1, -1, 30, 213, -1, \r\n    -1, -1, -1, -1, 46, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, 118, -1, -1, -1, -1, -1, -1, -1, -1, 68, -1, -1, 136, -1, -1, -1, -1, \r\n    -1, -1, -1, 6, 102, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 135, -1, \r\n    -1, -1, 66, 105, -1, -1, 198, -1, -1, -1, -1, -1, -1, -1, -1, 172, -1, 19,\r\n    -1, -1, 114, -1, -1, -1, -1, -1, -1, 175, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    117, 194, -1, -1, 72, -1, -1, -1, -1, -1, 152, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, 107, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 29, -1, -1, 15, -1, \r\n    171, -1, -1, 192, -1, 200, -1, -1, 148, -1, -1, 86, 76, 63, -1, 14, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 164, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 67, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, 27, -1, -1, -1, -1, -1, 155, 184, -1, 97, -1, -1, \r\n    -1, -1, 149, -1, 176, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, 4, -1, -1, -1, -1, 163, -1, -1, -1, -1, -1,\r\n    210, -1, 44, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 108, -1, \r\n    -1, -1, -1, -1, -1, 157, -1, -1, 142, -1, 7, 51, -1, 177, -1, -1, -1, -1, \r\n    69, -1, -1, -1, -1, -1, -1, -1, 22, -1, 127, 204, -1, -1, 158, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, 140, -1, 179, -1, -1, -1, 58, -1, -1, 208, 139, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, 92, 43, -1, -1, 110, 0, -1, -1, -1, 96, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, 20, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 112, \r\n    126, 95, -1, -1, -1, -1, -1, 13, -1, -1, -1, -1, -1, -1, 150, -1, -1, -1, \r\n    -1, -1, 56, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 103, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, 101, -1, 60 \r\n  );\r\n\r\nconstructor TSynLLVMIRSyn.Create(AOwner: TComponent);\r\nbegin\r\n  inherited Create(AOwner);\r\n  fCaseSensitive := True;\r\n\r\n  fBooleanAttri := TSynHighLighterAttributes.Create(SYNS_AttrBoolean, SYNS_FriendlyAttrBoolean);\r\n  fBooleanAttri.Foreground := clNavy;\r\n  AddAttribute(fBooleanAttri);\r\n\r\n  fCommentAttri := TSynHighLighterAttributes.Create(SYNS_AttrComment, SYNS_FriendlyAttrComment);\r\n  fCommentAttri.Foreground := $B0A060;\r\n  fCommentAttri.Style := [fsItalic];\r\n  AddAttribute(fCommentAttri);\r\n\r\n  fConstantAttri := TSynHighLighterAttributes.Create(SYNS_AttrConstant, SYNS_FriendlyAttrConstant);\r\n  fConstantAttri.Foreground := clNavy;\r\n  AddAttribute(fConstantAttri);\r\n\r\n  fIdentifierAttri := TSynHighLighterAttributes.Create(SYNS_AttrIdentifier, SYNS_FriendlyAttrIdentifier);\r\n  fIdentifierAttri.Foreground := $D560BB;\r\n  AddAttribute(fIdentifierAttri);\r\n\r\n  fInstructionAttri := TSynHighLighterAttributes.Create(SYNS_AttrInstructions, SYNS_FriendlyAttrInstructions);\r\n  fInstructionAttri.Foreground := $207000;\r\n  fInstructionAttri.Style := [fsBold];\r\n  AddAttribute(fInstructionAttri);\r\n\r\n  fKeyAttri := TSynHighLighterAttributes.Create(SYNS_AttrReservedWord, SYNS_FriendlyAttrReservedWord);\r\n  fKeyAttri.Foreground := $207000;\r\n  fKeyAttri.Style := [fsBold];\r\n  AddAttribute(fKeyAttri);\r\n\r\n  fLabelAttri := TSynHighLighterAttributes.Create(SYNS_AttrLabel, SYNS_FriendlyAttrLAbel);\r\n  fLabelAttri.Foreground := $702000;\r\n  fLabelAttri.Style := [fsBold];\r\n  AddAttribute(fLabelAttri);\r\n\r\n  fNumberAttri := TSynHighlighterAttributes.Create(SYNS_AttrNumber, SYNS_FriendlyAttrNumber);\r\n  fNumberAttri.Foreground := $70A040;\r\n  AddAttribute(fNumberAttri);\r\n\r\n  fSpaceAttri := TSynHighLighterAttributes.Create(SYNS_AttrSpace, SYNS_FriendlyAttrSpace);\r\n  AddAttribute(fSpaceAttri);\r\n\r\n  fStringAttri := TSynHighLighterAttributes.Create(SYNS_AttrString, SYNS_FriendlyAttrString);\r\n  fStringAttri.Foreground := $A07040;\r\n  AddAttribute(fStringAttri);\r\n\r\n  fTypesAttri := TSynHighLighterAttributes.Create(SYNS_AttrBasicTypes, SYNS_FriendlyAttrBasicTypes);\r\n  fTypesAttri.Foreground := $002090;\r\n  fTypesAttri.Style := [fsBold];\r\n  AddAttribute(fTypesAttri);\r\n\r\n  SetAttributesOnChange(DefHighlightChange);\r\n  InitIdent;\r\n  fDefaultFilter := SYNS_FilterLLVMIR;\r\n  fRange := rsUnknown;\r\nend;\r\n\r\nprocedure TSynLLVMIRSyn.InitIdent;\r\nvar\r\n  i: Integer;\r\nbegin\r\n  for i := Low(fIdentFuncTable) to High(fIdentFuncTable) do\r\n    if KeyIndices[i] = -1 then\r\n      fIdentFuncTable[i] := AltFunc;\r\n\r\n  fIdentFuncTable[1458] := FuncKey; // acq95rel\r\n  fIdentFuncTable[659] := FuncKey; // acquire\r\n  fIdentFuncTable[843] := FuncInstruction; // add\r\n  fIdentFuncTable[916] := FuncKey; // addrspace\r\n  fIdentFuncTable[1346] := FuncKey; // alias\r\n  fIdentFuncTable[914] := FuncKey; // align\r\n  fIdentFuncTable[1158] := FuncKey; // alignstack\r\n  fIdentFuncTable[1385] := FuncInstruction; // alloca\r\n  fIdentFuncTable[107] := FuncKey; // alwaysinline\r\n  fIdentFuncTable[44] := FuncInstruction; // and\r\n  fIdentFuncTable[372] := FuncKey; // appending\r\n  fIdentFuncTable[32] := FuncInstruction; // arcp\r\n  fIdentFuncTable[624] := FuncKey; // arm95aapcs95vfpcc\r\n  fIdentFuncTable[1512] := FuncKey; // arm95aapcscc\r\n  fIdentFuncTable[1261] := FuncKey; // arm95apcscc\r\n  fIdentFuncTable[1244] := FuncInstruction; // ashr\r\n  fIdentFuncTable[1019] := FuncKey; // asm\r\n  fIdentFuncTable[359] := FuncKey; // atomic\r\n  fIdentFuncTable[557] := FuncInstruction; // atomicrmw\r\n  fIdentFuncTable[1191] := FuncKey; // available95externally\r\n  fIdentFuncTable[1489] := FuncInstruction; // bitcast\r\n  fIdentFuncTable[999] := FuncKey; // blockaddress\r\n  fIdentFuncTable[1401] := FuncInstruction; // br\r\n  fIdentFuncTable[337] := FuncKey; // byval\r\n  fIdentFuncTable[366] := FuncKey; // c\r\n  fIdentFuncTable[598] := FuncInstruction; // call\r\n  fIdentFuncTable[179] := FuncKey; // catch\r\n  fIdentFuncTable[1308] := FuncKey; // cc\r\n  fIdentFuncTable[932] := FuncKey; // ccc\r\n  fIdentFuncTable[1241] := FuncKey; // cleanup\r\n  fIdentFuncTable[1115] := FuncInstruction; // cmpxchg\r\n  fIdentFuncTable[1111] := FuncKey; // coldcc\r\n  fIdentFuncTable[536] := FuncKey; // common\r\n  fIdentFuncTable[145] := FuncKey; // constant\r\n  fIdentFuncTable[723] := FuncKey; // datalayout\r\n  fIdentFuncTable[458] := FuncKey; // declare\r\n  fIdentFuncTable[238] := FuncKey; // default\r\n  fIdentFuncTable[69] := FuncKey; // define\r\n  fIdentFuncTable[1017] := FuncKey; // deplibs\r\n  fIdentFuncTable[589] := FuncKey; // dllexport\r\n  fIdentFuncTable[20] := FuncKey; // dllimport\r\n  fIdentFuncTable[217] := FuncType; // double\r\n  fIdentFuncTable[767] := FuncInstruction; // eq\r\n  fIdentFuncTable[1454] := FuncInstruction; // exact\r\n  fIdentFuncTable[1359] := FuncKey; // except\r\n  fIdentFuncTable[772] := FuncKey; // extern95weak\r\n  fIdentFuncTable[1122] := FuncKey; // external\r\n  fIdentFuncTable[1011] := FuncInstruction; // extractelement\r\n  fIdentFuncTable[889] := FuncInstruction; // extractvalue\r\n  fIdentFuncTable[1090] := FuncInstruction; // fadd\r\n  fIdentFuncTable[769] := FuncBoolean; // false\r\n  fIdentFuncTable[1386] := FuncInstruction; // fast\r\n  fIdentFuncTable[856] := FuncKey; // fastcc\r\n  fIdentFuncTable[381] := FuncInstruction; // fcmp\r\n  fIdentFuncTable[628] := FuncInstruction; // fdiv\r\n  fIdentFuncTable[621] := FuncInstruction; // fence\r\n  fIdentFuncTable[1525] := FuncKey; // filter\r\n  fIdentFuncTable[434] := FuncType; // float\r\n  fIdentFuncTable[1424] := FuncInstruction; // fmul\r\n  fIdentFuncTable[456] := FuncType; // fp128\r\n  fIdentFuncTable[1552] := FuncInstruction; // fpext\r\n  fIdentFuncTable[911] := FuncInstruction; // fptosi\r\n  fIdentFuncTable[130] := FuncInstruction; // fptoui\r\n  fIdentFuncTable[1259] := FuncInstruction; // fptrunc\r\n  fIdentFuncTable[19] := FuncInstruction; // free\r\n  fIdentFuncTable[378] := FuncInstruction; // frem\r\n  fIdentFuncTable[1176] := FuncInstruction; // fsub\r\n  fIdentFuncTable[1299] := FuncKey; // gc\r\n  fIdentFuncTable[1147] := FuncInstruction; // getelementptr\r\n  fIdentFuncTable[1393] := FuncKey; // global\r\n  fIdentFuncTable[1008] := FuncType; // half\r\n  fIdentFuncTable[846] := FuncKey; // hidden\r\n  fIdentFuncTable[1214] := FuncInstruction; // icmp\r\n  fIdentFuncTable[789] := FuncInstruction; // inbounds\r\n  fIdentFuncTable[563] := FuncInstruction; // indirectbr\r\n  fIdentFuncTable[708] := FuncKey; // initialexec\r\n  fIdentFuncTable[1258] := FuncKey; // inlinehint\r\n  fIdentFuncTable[493] := FuncKey; // inreg\r\n  fIdentFuncTable[180] := FuncInstruction; // insertelement\r\n  fIdentFuncTable[57] := FuncInstruction; // insertvalue\r\n  fIdentFuncTable[773] := FuncKey; // intel95ocl95bicc\r\n  fIdentFuncTable[572] := FuncKey; // inteldialect\r\n  fIdentFuncTable[828] := FuncKey; // internal\r\n  fIdentFuncTable[965] := FuncInstruction; // inttoptr\r\n  fIdentFuncTable[1007] := FuncInstruction; // invoke\r\n  fIdentFuncTable[313] := FuncType; // label\r\n  fIdentFuncTable[1257] := FuncInstruction; // landingpad\r\n  fIdentFuncTable[977] := FuncKey; // linker95private\r\n  fIdentFuncTable[763] := FuncKey; // linker95private95weak\r\n  fIdentFuncTable[348] := FuncKey; // linker95private95weak95def95auto\r\n  fIdentFuncTable[863] := FuncKey; // linkonce\r\n  fIdentFuncTable[137] := FuncKey; // linkonce95odr\r\n  fIdentFuncTable[1453] := FuncKey; // linkonce95odr95auto95hide\r\n  fIdentFuncTable[198] := FuncInstruction; // load\r\n  fIdentFuncTable[671] := FuncKey; // localdynamic\r\n  fIdentFuncTable[1506] := FuncKey; // localexec\r\n  fIdentFuncTable[1462] := FuncInstruction; // lshr\r\n  fIdentFuncTable[1317] := FuncInstruction; // malloc\r\n  fIdentFuncTable[984] := FuncInstruction; // max\r\n  fIdentFuncTable[476] := FuncType; // metadata\r\n  fIdentFuncTable[129] := FuncInstruction; // min\r\n  fIdentFuncTable[1550] := FuncKey; // minsize\r\n  fIdentFuncTable[1159] := FuncKey; // module\r\n  fIdentFuncTable[1540] := FuncKey; // monotonic\r\n  fIdentFuncTable[1103] := FuncKey; // msp43095intrcc\r\n  fIdentFuncTable[1177] := FuncInstruction; // mul\r\n  fIdentFuncTable[334] := FuncKey; // naked\r\n  fIdentFuncTable[1229] := FuncInstruction; // nand\r\n  fIdentFuncTable[1373] := FuncInstruction; // ne\r\n  fIdentFuncTable[646] := FuncKey; // nest\r\n  fIdentFuncTable[1457] := FuncInstruction; // ninf\r\n  fIdentFuncTable[322] := FuncInstruction; // nnan\r\n  fIdentFuncTable[1504] := FuncKey; // noalias\r\n  fIdentFuncTable[879] := FuncKey; // nocapture\r\n  fIdentFuncTable[1194] := FuncKey; // noimplicitfloat\r\n  fIdentFuncTable[638] := FuncKey; // noinline\r\n  fIdentFuncTable[196] := FuncKey; // nonlazybind\r\n  fIdentFuncTable[1210] := FuncKey; // noredzone\r\n  fIdentFuncTable[1138] := FuncKey; // noreturn\r\n  fIdentFuncTable[248] := FuncKey; // nounwind\r\n  fIdentFuncTable[285] := FuncInstruction; // nsw\r\n  fIdentFuncTable[1002] := FuncInstruction; // nsz\r\n  fIdentFuncTable[377] := FuncConstant; // null\r\n  fIdentFuncTable[1057] := FuncInstruction; // nuw\r\n  fIdentFuncTable[16] := FuncInstruction; // oeq\r\n  fIdentFuncTable[1026] := FuncInstruction; // oge\r\n  fIdentFuncTable[1505] := FuncInstruction; // ogt\r\n  fIdentFuncTable[1403] := FuncInstruction; // ole\r\n  fIdentFuncTable[329] := FuncInstruction; // olt\r\n  fIdentFuncTable[622] := FuncInstruction; // one\r\n  fIdentFuncTable[801] := FuncType; // opaque\r\n  fIdentFuncTable[461] := FuncKey; // optsize\r\n  fIdentFuncTable[207] := FuncInstruction; // or\r\n  fIdentFuncTable[374] := FuncInstruction; // ord\r\n  fIdentFuncTable[1033] := FuncKey; // personality\r\n  fIdentFuncTable[1172] := FuncInstruction; // phi\r\n  fIdentFuncTable[1150] := FuncType; // ppc95fp128\r\n  fIdentFuncTable[786] := FuncKey; // private\r\n  fIdentFuncTable[712] := FuncKey; // protected\r\n  fIdentFuncTable[1428] := FuncInstruction; // ptrtoint\r\n  fIdentFuncTable[1418] := FuncKey; // ptx95device\r\n  fIdentFuncTable[507] := FuncKey; // ptx95kernel\r\n  fIdentFuncTable[1383] := FuncKey; // readnone\r\n  fIdentFuncTable[197] := FuncKey; // readonly\r\n  fIdentFuncTable[427] := FuncKey; // release\r\n  fIdentFuncTable[697] := FuncInstruction; // resume\r\n  fIdentFuncTable[251] := FuncInstruction; // ret\r\n  fIdentFuncTable[482] := FuncKey; // returns95twice\r\n  fIdentFuncTable[1254] := FuncKey; // sanitize95address\r\n  fIdentFuncTable[1322] := FuncKey; // sanitize95memory\r\n  fIdentFuncTable[1519] := FuncKey; // sanitize95thread\r\n  fIdentFuncTable[304] := FuncInstruction; // sdiv\r\n  fIdentFuncTable[1220] := FuncKey; // section\r\n  fIdentFuncTable[754] := FuncInstruction; // select\r\n  fIdentFuncTable[1056] := FuncKey; // seq95cst\r\n  fIdentFuncTable[1314] := FuncInstruction; // sext\r\n  fIdentFuncTable[901] := FuncInstruction; // sge\r\n  fIdentFuncTable[1380] := FuncInstruction; // sgt\r\n  fIdentFuncTable[1407] := FuncInstruction; // shl\r\n  fIdentFuncTable[447] := FuncInstruction; // shufflevector\r\n  fIdentFuncTable[715] := FuncKey; // sideeffect\r\n  fIdentFuncTable[351] := FuncKey; // signext\r\n  fIdentFuncTable[729] := FuncKey; // singlethread\r\n  fIdentFuncTable[1351] := FuncInstruction; // sitofp\r\n  fIdentFuncTable[1278] := FuncInstruction; // sle\r\n  fIdentFuncTable[204] := FuncInstruction; // slt\r\n  fIdentFuncTable[86] := FuncInstruction; // spir95func\r\n  fIdentFuncTable[790] := FuncInstruction; // spir95kernel\r\n  fIdentFuncTable[54] := FuncInstruction; // srem\r\n  fIdentFuncTable[174] := FuncKey; // sret\r\n  fIdentFuncTable[397] := FuncKey; // ssp\r\n  fIdentFuncTable[1246] := FuncKey; // sspreq\r\n  fIdentFuncTable[1189] := FuncKey; // sspstrong\r\n  fIdentFuncTable[223] := FuncInstruction; // store\r\n  fIdentFuncTable[929] := FuncInstruction; // sub\r\n  fIdentFuncTable[1201] := FuncInstruction; // switch\r\n  fIdentFuncTable[1324] := FuncKey; // tail\r\n  fIdentFuncTable[1388] := FuncKey; // target\r\n  fIdentFuncTable[952] := FuncKey; // thread95local\r\n  fIdentFuncTable[1420] := FuncKey; // to\r\n  fIdentFuncTable[745] := FuncKey; // triple\r\n  fIdentFuncTable[1034] := FuncBoolean; // true\r\n  fIdentFuncTable[152] := FuncInstruction; // trunc\r\n  fIdentFuncTable[50] := FuncInstruction; // type\r\n  fIdentFuncTable[1315] := FuncInstruction; // udiv\r\n  fIdentFuncTable[605] := FuncInstruction; // ueq\r\n  fIdentFuncTable[62] := FuncInstruction; // uge\r\n  fIdentFuncTable[541] := FuncInstruction; // ugt\r\n  fIdentFuncTable[513] := FuncInstruction; // uitofp\r\n  fIdentFuncTable[439] := FuncInstruction; // ule\r\n  fIdentFuncTable[918] := FuncInstruction; // ult\r\n  fIdentFuncTable[551] := FuncInstruction; // umax\r\n  fIdentFuncTable[1249] := FuncInstruction; // umin\r\n  fIdentFuncTable[995] := FuncConstant; // undef\r\n  fIdentFuncTable[1211] := FuncInstruction; // une\r\n  fIdentFuncTable[212] := FuncKey; // unnamed95addr\r\n  fIdentFuncTable[495] := FuncInstruction; // uno\r\n  fIdentFuncTable[426] := FuncKey; // unordered\r\n  fIdentFuncTable[1180] := FuncInstruction; // unreachable\r\n  fIdentFuncTable[604] := FuncInstruction; // unwind\r\n  fIdentFuncTable[1251] := FuncInstruction; // urem\r\n  fIdentFuncTable[870] := FuncKey; // uwtable\r\n  fIdentFuncTable[530] := FuncInstruction; // va95arg\r\n  fIdentFuncTable[762] := FuncType; // void\r\n  fIdentFuncTable[1404] := FuncKey; // volatile\r\n  fIdentFuncTable[258] := FuncKey; // weak\r\n  fIdentFuncTable[1081] := FuncKey; // weak95odr\r\n  fIdentFuncTable[318] := FuncKey; // x8695fastcallcc\r\n  fIdentFuncTable[1427] := FuncType; // x8695fp80\r\n  fIdentFuncTable[68] := FuncType; // x8695mmx\r\n  fIdentFuncTable[1357] := FuncKey; // x8695stdcallcc\r\n  fIdentFuncTable[94] := FuncKey; // x8695thiscallcc\r\n  fIdentFuncTable[926] := FuncInstruction; // xchg\r\n  fIdentFuncTable[1116] := FuncInstruction; // xor\r\n  fIdentFuncTable[1005] := FuncKey; // zeroext\r\n  fIdentFuncTable[630] := FuncConstant; // zeroinitializer\r\n  fIdentFuncTable[1063] := FuncInstruction; // zext\r\nend;\r\n\r\n{$Q-}\r\nfunction TSynLLVMIRSyn.HashKey(Str: PWideChar): Cardinal;\r\nbegin\r\n  Result := 0;\r\n  while IsIdentChar(Str^) do\r\n  begin\r\n    Result := Result * 359 + Ord(Str^) * 239;\r\n    Inc(Str);\r\n  end;\r\n  Result := Result mod 1553;\r\n  fStringLen := Str - fToIdent;\r\nend;\r\n{$Q+}\r\n\r\nfunction TSynLLVMIRSyn.FuncBoolean(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkBoolean\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynLLVMIRSyn.FuncConstant(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkConstant\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynLLVMIRSyn.FuncInstruction(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkInstruction\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynLLVMIRSyn.FuncKey(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynLLVMIRSyn.FuncType(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkType\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynLLVMIRSyn.AltFunc(Index: Integer): TtkTokenKind;\r\nbegin\r\n  Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynLLVMIRSyn.IdentKind(MayBe: PWideChar): TtkTokenKind;\r\nvar\r\n  Key: Cardinal;\r\nbegin\r\n  fToIdent := MayBe;\r\n  Key := HashKey(MayBe);\r\n  if Key <= High(fIdentFuncTable) then\r\n    Result := fIdentFuncTable[Key](KeyIndices[Key])\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nprocedure TSynLLVMIRSyn.SpaceProc;\r\nbegin\r\n  inc(Run);\r\n  fTokenID := tkSpace;\r\n  while (FLine[Run] <= #32) and not IsLineEnd(Run) do inc(Run);\r\nend;\r\n\r\nprocedure TSynLLVMIRSyn.NullProc;\r\nbegin\r\n  fTokenID := tkNull;\r\n  inc(Run);\r\nend;\r\n\r\nprocedure TSynLLVMIRSyn.CRProc;\r\nbegin\r\n  fTokenID := tkSpace;\r\n  inc(Run);\r\n  if fLine[Run] = #10 then\r\n    inc(Run);\r\nend;\r\n\r\nprocedure TSynLLVMIRSyn.LFProc;\r\nbegin\r\n  fTokenID := tkSpace;\r\n  inc(Run);\r\nend;\r\n\r\nprocedure TSynLLVMIRSyn.IntegerTypeProc;\r\nbegin\r\n  case FLine[Succ(Run)] of\r\n    '0'..'9':\r\n      begin\r\n        fTokenID := tkType;\r\n        repeat\r\n          Inc(Run);\r\n          case fLine[Run] of\r\n            '0'..'9':;\r\n          else\r\n            Exit;\r\n          end;\r\n        until IsLineEnd(Run);\r\n      end\r\n  else\r\n    IdentProc;\r\n  end;\r\nend;\r\n\r\nprocedure TSynLLVMIRSyn.AtTypeProc;\r\nbegin\r\n  // @ = global identifiers\r\n  fTokenID := tkUnknown;\r\n\r\n  Inc(Run);\r\n  if IsLineEnd(Run) then\r\n    Exit;\r\n\r\n  case fLine[Run] of\r\n    '0'..'9': fTokenID := tkUnnamedIdentifier;\r\n    '-', '_', 'A'..'Z', 'a'..'z': fTokenID := tkIdentifier;\r\n    '\"':\r\n      begin\r\n        Inc(Run);\r\n        StringProc;\r\n        fTokenID := tkIdentifier;\r\n        Exit;\r\n      end;\r\n  end;\r\n\r\n  repeat\r\n    Inc(Run);\r\n    case fLine[Run] of\r\n      '0'..'9', '-', '_', '.', 'A'..'Z', 'a'..'z':;\r\n    else\r\n      Exit;\r\n    end;\r\n  until IsLineEnd(Run);\r\nend;\r\n\r\nprocedure TSynLLVMIRSyn.PercentTypeProc;\r\nbegin\r\n  // % = local identifiers\r\n  fTokenID := tkUnknown;\r\n\r\n  Inc(Run);\r\n  if IsLineEnd(Run) then\r\n    Exit;\r\n\r\n  case fLine[Run] of\r\n    '0'..'9': fTokenID := tkUnnamedIdentifier;\r\n    '-', '_', '.', 'A'..'Z', 'a'..'z': fTokenID := tkIdentifier;\r\n    '\"':\r\n      begin\r\n        Inc(Run);\r\n        StringProc;\r\n        fTokenID := tkIdentifier;\r\n        Exit;\r\n      end;\r\n  end;\r\n\r\n  repeat\r\n    Inc(Run);\r\n    case fLine[Run] of\r\n      '0'..'9', '-', '_', '.', 'A'..'Z', 'a'..'z':;\r\n    else\r\n      Exit;\r\n    end;\r\n  until IsLineEnd(Run);\r\nend;\r\n\r\nprocedure TSynLLVMIRSyn.SingleCommentOpenProc;\r\nbegin\r\n  Inc(Run);\r\n  fRange := rsSingleComment;\r\n  SingleCommentProc;\r\n  fTokenID := tkComment;\r\nend;\r\n\r\nprocedure TSynLLVMIRSyn.SingleCommentProc;\r\nbegin\r\n  fTokenID := tkComment;\r\n  while not IsLineEnd(Run) do\r\n    Inc(Run);\r\nend;\r\n\r\nprocedure TSynLLVMIRSyn.StringOpenProc;\r\nbegin\r\n  Inc(Run);\r\n  fRange := rsString;\r\n  StringProc;\r\n  fTokenID := tkString;\r\nend;\r\n\r\nprocedure TSynLLVMIRSyn.StringProc;\r\nbegin\r\n  case fLine[Run] of\r\n     #0: NullProc;\r\n    #10: LFProc;\r\n    #13: CRProc;\r\n  else\r\n    begin\r\n      fTokenID := tkString;\r\n      repeat\r\n        if (fLine[Run] = '\"') then\r\n        begin\r\n          Inc(Run, 1);\r\n          fRange := rsUnKnown;\r\n          Break;\r\n        end;\r\n        if not IsLineEnd(Run) then\r\n          Inc(Run);\r\n      until IsLineEnd(Run);\r\n    end;\r\n  end;\r\nend;\r\n\r\nprocedure TSynLLVMIRSyn.NumberProc;\r\n\r\n  function IsNumberChar(Run: Integer): Boolean;\r\n  begin\r\n    case fLine[Run] of\r\n      '0'..'9', 'A'..'F', 'a'..'f', '.', 'x', 'X', '-', '+':\r\n        Result := True;\r\n      else\r\n        Result := False;\r\n    end;\r\n  end;\r\n\r\n  function IsDigitPlusMinusChar(Run: Integer): Boolean;\r\n  begin\r\n    case fLine[Run] of\r\n      '0'..'9', '+', '-':\r\n        Result := True;\r\n      else\r\n        Result := False;\r\n    end;\r\n  end;\r\n\r\n  function IsHexDigit(Run: Integer): Boolean;\r\n  begin\r\n    case fLine[Run] of\r\n      '0'..'9', 'a'..'f', 'A'..'F':\r\n        Result := True;\r\n      else\r\n        Result := False;\r\n    end;\r\n  end;\r\n\r\n  function IsAlphaUncerscore(Run: Integer): Boolean;\r\n  begin\r\n    case fLine[Run] of\r\n      'A'..'Z', 'a'..'z', '_':\r\n        Result := True;\r\n      else\r\n        Result := False;\r\n    end;\r\n  end;\r\n\r\nvar\r\n  idx1: Integer; // token[1]\r\n  i: Integer;\r\nbegin\r\n  idx1 := Run;\r\n  Inc(Run);\r\n  fTokenID := tkNumber;\r\n  while IsNumberChar(Run) do\r\n  begin\r\n    case FLine[Run] of\r\n      '.':\r\n        if FLine[Succ(Run)] = '.' then\r\n          Break\r\n        else\r\n          if (fTokenID <> tkHex) then\r\n            fTokenID := tkFloat\r\n          else // invalid\r\n          begin\r\n            fTokenID := tkUnknown;\r\n            Exit;\r\n          end;\r\n      '-', '+':\r\n        begin\r\n          if fTokenID <> tkFloat then // number <> float. an arithmetic operator\r\n            Exit;\r\n          if not CharInSet(FLine[Pred(Run)], ['e', 'E']) then\r\n            Exit; // number = float, but no exponent. an arithmetic operator\r\n          if not IsDigitPlusMinusChar(Succ(Run)) then // invalid\r\n          begin\r\n            Inc(Run);\r\n            fTokenID := tkUnknown;\r\n            Exit;\r\n          end\r\n        end;\r\n      '0'..'9': ;\r\n      'a'..'d', 'f', 'A'..'D', 'F':\r\n        if fTokenID <> tkHex then // invalid char\r\n          Break;\r\n      'e', 'E':\r\n        if (fTokenID <> tkHex) then\r\n          if CharInSet(FLine[Pred(Run)], ['0'..'9']) then // exponent\r\n          begin\r\n            for i := idx1 to Pred(Run) do\r\n              if CharInSet(FLine[i], ['e', 'E']) then // too many exponents\r\n              begin\r\n                fTokenID := tkUnknown;\r\n                Exit;\r\n              end;\r\n            if not IsDigitPlusMinusChar(Succ(Run)) then\r\n              Break\r\n            else\r\n              fTokenID := tkFloat\r\n          end\r\n          else // invalid char\r\n            Break;\r\n      'x', 'X':\r\n        if (Run = Succ(idx1)) and   // 0x... 'x' must be second char\r\n           (FLine[idx1] = '0') and  // 0x...\r\n           IsHexDigit(Succ(Run)) then // 0x... must be continued with a number\r\n             fTokenID := tkHex\r\n           else // invalid char\r\n           begin\r\n             if not IsIdentChar(fLine[Succ(Run)]) and\r\n                CharInSet(FLine[Succ(idx1)], ['x', 'X']) then\r\n             begin\r\n               Inc(Run); // highlight 'x' too\r\n               fTokenID := tkUnknown;\r\n             end;\r\n             Break;\r\n           end;\r\n    end; // case\r\n    Inc(Run);\r\n  end; // while\r\n  if IsAlphaUncerscore(Run) then\r\n    fTokenID := tkUnknown;\r\nend;\r\n\r\nprocedure TSynLLVMIRSyn.IdentProc;\r\nbegin\r\n  fTokenID := IdentKind(fLine + Run);\r\n  Inc(Run, fStringLen);\r\n  while IsIdentChar(fLine[Run]) do\r\n    Inc(Run);\r\n\r\n  if fLine[Run] = ':' then\r\n  begin\r\n    fTokenID := tkLabel;\r\n    Inc(Run);\r\n  end;\r\nend;\r\n\r\nprocedure TSynLLVMIRSyn.UnknownProc;\r\nbegin\r\n  inc(Run);\r\n  fTokenID := tkUnknown;\r\nend;\r\n\r\nprocedure TSynLLVMIRSyn.Next;\r\nbegin\r\n  fTokenPos := Run;\r\n  case fRange of\r\n    rsString: StringProc;\r\n  else\r\n    case fLine[Run] of\r\n      #0: NullProc;\r\n      #10: LFProc;\r\n      #13: CRProc;\r\n      ';': SingleCommentOpenProc;\r\n      '\"': StringOpenProc;\r\n      #1..#9, #11, #12, #14..#32: SpaceProc;\r\n      '0'..'9': NumberProc;\r\n      'A'..'Z', 'a'..'h', 'j'..'z', '_': IdentProc;\r\n      'i': IntegerTypeProc;\r\n      '@': AtTypeProc;\r\n      '%': PercentTypeProc;\r\n    else\r\n      UnknownProc;\r\n    end;\r\n  end;\r\n  inherited;\r\nend;\r\n\r\nfunction TSynLLVMIRSyn.GetDefaultAttribute(Index: Integer): TSynHighLighterAttributes;\r\nbegin\r\n  case Index of\r\n    SYN_ATTR_COMMENT: Result := fCommentAttri;\r\n    SYN_ATTR_IDENTIFIER: Result := fIdentifierAttri;\r\n    SYN_ATTR_KEYWORD: Result := fKeyAttri;\r\n    SYN_ATTR_STRING: Result := fStringAttri;\r\n    SYN_ATTR_WHITESPACE: Result := fSpaceAttri;\r\n  else\r\n    Result := nil;\r\n  end;\r\nend;\r\n\r\nfunction TSynLLVMIRSyn.GetEol: Boolean;\r\nbegin\r\n  Result := Run = fLineLen + 1;\r\nend;\r\n\r\nfunction TSynLLVMIRSyn.GetKeyWords(TokenKind: Integer): UnicodeString;\r\nbegin\r\n  Result := \r\n    'acq_rel,acquire,add,addrspace,alias,align,alignstack,alloca,alwaysinl' +\r\n    'ine,and,appending,arcp,arm_aapcs_vfpcc,arm_aapcscc,arm_apcscc,ashr,asm' +\r\n    ',atomic,atomicrmw,available_externally,bitcast,blockaddress,br,byval,c' +\r\n    ',call,catch,cc,ccc,cleanup,cmpxchg,coldcc,common,constant,datalayout,d' +\r\n    'eclare,default,define,deplibs,dllexport,dllimport,double,eq,exact,exce' +\r\n    'pt,extern_weak,external,extractelement,extractvalue,fadd,false,fast,fa' +\r\n    'stcc,fcmp,fdiv,fence,filter,float,fmul,fp128,fpext,fptosi,fptoui,fptru' +\r\n    'nc,free,frem,fsub,gc,getelementptr,global,half,hidden,icmp,inbounds,in' +\r\n    'directbr,initialexec,inlinehint,inreg,insertelement,insertvalue,intel_' +\r\n    'ocl_bicc,inteldialect,internal,inttoptr,invoke,label,landingpad,linker' +\r\n    '_private,linker_private_weak,linker_private_weak_def_auto,linkonce,lin' +\r\n    'konce_odr,linkonce_odr_auto_hide,load,localdynamic,localexec,lshr,mall' +\r\n    'oc,max,metadata,min,minsize,module,monotonic,msp430_intrcc,mul,naked,n' +\r\n    'and,ne,nest,ninf,nnan,noalias,nocapture,noimplicitfloat,noinline,nonla' +\r\n    'zybind,noredzone,noreturn,nounwind,nsw,nsz,null,nuw,oeq,oge,ogt,ole,ol' +\r\n    't,one,opaque,optsize,or,ord,personality,phi,ppc_fp128,private,protecte' +\r\n    'd,ptrtoint,ptx_device,ptx_kernel,readnone,readonly,release,resume,ret,' +\r\n    'returns_twice,sanitize_address,sanitize_memory,sanitize_thread,sdiv,se' +\r\n    'ction,select,seq_cst,sext,sge,sgt,shl,shufflevector,sideeffect,signext' +\r\n    ',singlethread,sitofp,sle,slt,spir_func,spir_kernel,srem,sret,ssp,sspre' +\r\n    'q,sspstrong,store,sub,switch,tail,target,thread_local,to,triple,true,t' +\r\n    'runc,type,udiv,ueq,uge,ugt,uitofp,ule,ult,umax,umin,undef,une,unnamed_' +\r\n    'addr,uno,unordered,unreachable,unwind,urem,uwtable,va_arg,void,volatil' +\r\n    'e,weak,weak_odr,x86_fastcallcc,x86_fp80,x86_mmx,x86_stdcallcc,x86_this' +\r\n    'callcc,xchg,xor,zeroext,zeroinitializer,zext';\r\nend;\r\n\r\nfunction TSynLLVMIRSyn.GetTokenID: TtkTokenKind;\r\nbegin\r\n  Result := fTokenId;\r\nend;\r\n\r\nfunction TSynLLVMIRSyn.GetTokenAttribute: TSynHighLighterAttributes;\r\nbegin\r\n  case GetTokenID of\r\n    tkBoolean: Result := fBooleanAttri;\r\n    tkComment: Result := fCommentAttri;\r\n    tkConstant: Result := fConstantAttri;\r\n    tkIdentifier, tkUnnamedIdentifier: Result := fIdentifierAttri;\r\n    tkInstruction: Result := fInstructionAttri;\r\n    tkKey: Result := fKeyAttri;\r\n    tkLabel: Result := fLabelAttri;\r\n    tkNumber, tkFloat, tkHex: Result := fNumberAttri;\r\n    tkSpace: Result := fSpaceAttri;\r\n    tkString: Result := fStringAttri;\r\n    tkType: Result := fTypesAttri;\r\n    tkUnknown: Result := fIdentifierAttri;\r\n  else\r\n    Result := nil;\r\n  end;\r\nend;\r\n\r\nfunction TSynLLVMIRSyn.GetTokenKind: Integer;\r\nbegin\r\n  Result := Ord(fTokenId);\r\nend;\r\n\r\nfunction TSynLLVMIRSyn.IsIdentChar(AChar: WideChar): Boolean;\r\nbegin\r\n  case AChar of\r\n    '_', '.', '0'..'9', 'a'..'z', 'A'..'Z':\r\n      Result := True;\r\n    else\r\n      Result := False;\r\n  end;\r\nend;\r\n\r\nfunction TSynLLVMIRSyn.GetSampleSource: UnicodeString;\r\nbegin\r\n  Result :=\r\n    '; Declare the string constant as global constant' + #10#13 + '@.msg = ' +\r\n    'internal constant [13 x i8] c\"Hello World!\\00\"' + #10#13 + #10#13 +\r\n    '; External declaration of puts function' + #10#13 + 'declare i32 ' +\r\n    '@puts(i8*)' + #10#13 + #10#13 + '; Definition of main function' + #10#13 +\r\n    'define i32 @main() {' + #10#13 + 'entry:' + #10#13 + #9 +\r\n    '; Convert [13 x i8]* to i8 *...' + #10#13 + #9 +\r\n    '%cast210 = getelementptr inbounds ([13 x i8]* @.msg, i32 0, i32 0)' +\r\n    #10#13 + #10#13 + #9 + '; Call puts function to write out the string to ' +\r\n    'stdout' + #10#13 + #9 + 'call i32 @puts(i8* %cast210)' + #10#13 +\r\n    #9 + 'ret i32 0' + #10#13 + '}';\r\n\r\nend;\r\n\r\nfunction TSynLLVMIRSyn.IsFilterStored: Boolean;\r\nbegin\r\n  Result := fDefaultFilter <> SYNS_FilterLLVMIR;\r\nend;\r\n\r\nclass function TSynLLVMIRSyn.GetFriendlyLanguageName: UnicodeString;\r\nbegin\r\n  Result := SYNS_FriendlyLangLLVMIR;\r\nend;\r\n\r\nclass function TSynLLVMIRSyn.GetLanguageName: string;\r\nbegin\r\n  Result := SYNS_LangLLVMIR;\r\nend;\r\n\r\nprocedure TSynLLVMIRSyn.ResetRange;\r\nbegin\r\n  fRange := rsUnknown;\r\nend;\r\n\r\nprocedure TSynLLVMIRSyn.SetRange(Value: Pointer);\r\nbegin\r\n  fRange := TRangeState(Value);\r\nend;\r\n\r\nfunction TSynLLVMIRSyn.GetRange: Pointer;\r\nbegin\r\n  Result := Pointer(fRange);\r\nend;\r\n\r\ninitialization\r\n{$IFNDEF SYN_CPPB_1}\r\n  RegisterPlaceableHighlighter(TSynLLVMIRSyn);\r\n{$ENDIF}\r\nend.\r\n"
  },
  {
    "path": "External/SynEdit/Source/SynHighlighterM3.pas",
    "content": "{-------------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: SynHighlighterM3.pas, released 2000-11-23.\r\nUnicode translation by Mal Hrz.\r\n\r\nContributors to the SynEdit and mwEdit projects are listed in the\r\nContributors.txt file.\r\n\r\nAlternatively, the contents of this file may be used under the terms of the\r\nGNU General Public License Version 2 or later (the \"GPL\"), in which case\r\nthe provisions of the GPL are applicable instead of those above.\r\nIf you wish to allow use of your version of this file only under the terms\r\nof the GPL and not to allow others to use your version of this file\r\nunder the MPL, indicate your decision by deleting the provisions above and\r\nreplace them with the notice and other provisions required by the GPL.\r\nIf you do not delete the provisions above, a recipient may use your version\r\nof this file under either the MPL or the GPL.\r\n\r\n$Id: SynHighlighterM3.pas,v 1.11.2.5 2008/09/14 16:25:00 maelh Exp $\r\n\r\nYou may retrieve the latest version of this file at the SynEdit home page,\r\nlocated at http://SynEdit.SourceForge.net\r\n\r\nKnown Issues:\r\n-------------------------------------------------------------------------------}\r\n{\r\n@abstract(Provides a Modula-3 syntax highlighter for SynEdit)\r\n@author(Martin Pley )\r\n@created(January 2000, converted to SynEdit November 23, 2000)\r\n@lastmod(2000-11-23)\r\nThe SynHighlighterM3 unit provides SynEdit with a Modula-3 (.m3) highlighter.\r\n}\r\n\r\n{$IFNDEF QSYNHIGHLIGHTERM3}\r\nunit SynHighlighterM3;\r\n{$ENDIF}\r\n\r\n{$I SynEdit.inc}\r\n\r\ninterface\r\n\r\nuses\r\n{$IFDEF SYN_CLX}\r\n  QGraphics,\r\n  QSynEditTypes,\r\n  QSynEditHighlighter,\r\n  QSynHighlighterHashEntries,\r\n  QSynUnicode,\r\n{$ELSE}\r\n  Graphics,\r\n  Registry,\r\n  SynEditTypes,\r\n  SynEditHighlighter,\r\n  SynHighlighterHashEntries,\r\n  SynUnicode,\r\n{$ENDIF}\r\n  SysUtils,\r\n  Classes;\r\n\r\ntype\r\n  TtkTokenKind = (tkComment, tkIdentifier, tkKey, tkNull, tkNumber, tkPragma,\r\n    tkReserved, tkSpace, tkString, tkSymbol, tkUnknown, tkSyntaxError);\r\n\r\n  TTokenRange = (trNone, trComment, trPragma);\r\n\r\n  TRangeState = packed record\r\n    case Boolean of\r\n      False: (p: Pointer);\r\n      True: (TokenRange: Word; Level: Word);\r\n    end;\r\n\r\n  TSynM3Syn = class(TSynCustomHighLighter)\r\n  private\r\n    fRange: TRangeState;\r\n    FTokenID: TtkTokenKind;\r\n    fCommentAttri: TSynHighlighterAttributes;\r\n    fIdentifierAttri: TSynHighlighterAttributes;\r\n    fKeyAttri: TSynHighlighterAttributes;\r\n    fNumberAttri: TSynHighlighterAttributes;\r\n    fPragmaAttri: TSynHighlighterAttributes;\r\n    fReservedAttri: TSynHighlighterAttributes;\r\n    fSpaceAttri: TSynHighlighterAttributes;\r\n    fStringAttri: TSynHighlighterAttributes;\r\n    fSymbolAttri: TSynHighlighterAttributes;\r\n    fSyntaxErrorAttri: TSynHighlighterAttributes;\r\n    fKeywords: TSynHashEntryList;\r\n    procedure DoAddKeyword(AKeyword: UnicodeString; AKind: integer);\r\n    function HashKey(Str: PWideChar): integer;\r\n    function IdentKind(MayBe: PWideChar): TtkTokenKind;\r\n    procedure SymAsciiCharProc;\r\n    procedure SymCommentHelpProc;\r\n    procedure SymCRProc;\r\n    procedure SymIdentProc;\r\n    procedure SymLFProc;\r\n    procedure SymNestedHelperProc(AOpenChar, ACloseChar: WideChar);\r\n    procedure SymNullProc;\r\n    procedure SymNumberProc;\r\n    procedure SymPragmaProc;\r\n    procedure SymPragmaHelpProc;\r\n    procedure SymRoundOpenProc;\r\n    procedure SymSpaceProc;\r\n    procedure SymStringProc;\r\n    procedure SymSymbolProc;\r\n    procedure SymUnknownProc;\r\n  protected\r\n    function IsFilterStored: Boolean; override;\r\n  public\r\n    class function GetLanguageName: string; override;\r\n    class function GetFriendlyLanguageName: UnicodeString; override;\r\n{$IFDEF SYN_DEVELOPMENT_CHECKS}\r\n  public\r\n    property _Keywords: TSynHashEntryList read fKeywords;\r\n{$ENDIF}\r\n  public\r\n    constructor Create(AOwner: TComponent); override;\r\n    destructor Destroy; override;\r\n    function GetDefaultAttribute(Index: integer): TSynHighlighterAttributes;\r\n      override;\r\n    function GetEol: Boolean; override;\r\n    function GetRange: Pointer; override;\r\n    function GetTokenID: TtkTokenKind;\r\n    function GetTokenAttribute: TSynHighlighterAttributes; override;\r\n    function GetTokenKind: integer; override;\r\n    procedure Next; override;\r\n    procedure ResetRange; override;\r\n    procedure SetRange(Value: Pointer); override;\r\n  published\r\n    property CommentAttri: TSynHighlighterAttributes read fCommentAttri\r\n      write fCommentAttri;\r\n    property IdentifierAttri: TSynHighlighterAttributes read fIdentifierAttri\r\n      write fIdentifierAttri;\r\n    property KeyAttri: TSynHighlighterAttributes read fKeyAttri write fKeyAttri;\r\n    property NumberAttri: TSynHighlighterAttributes read fNumberAttri\r\n      write fNumberAttri;\r\n    property PragmaAttri: TSynHighlighterAttributes read fPragmaAttri\r\n      write fPragmaAttri;\r\n    property ReservedAttri: TSynHighlighterAttributes read fReservedAttri\r\n      write fReservedAttri;\r\n    property SpaceAttri: TSynHighlighterAttributes read fSpaceAttri\r\n      write fSpaceAttri;\r\n    property StringAttri: TSynHighlighterAttributes read fStringAttri\r\n      write fStringAttri;\r\n    property SymbolAttri: TSynHighlighterAttributes read fSymbolAttri\r\n      write fSymbolAttri;\r\n    property SyntaxErrorAttri: TSynHighlighterAttributes read fSyntaxErrorAttri\r\n      write fSyntaxErrorAttri;\r\n  end;\r\n\r\nimplementation\r\n\r\nuses\r\n{$IFDEF SYN_CLX}\r\n  QSynEditStrConst;\r\n{$ELSE}\r\n  SynEditStrConst;\r\n{$ENDIF}\r\n\r\nconst\r\n  Keywords: UnicodeString =\r\n    'AS,AND,ANY,ARRAY,BEGIN,BITS,BRANDED,BY,CASE,CONST,DIV,DO,ELSE,ELSIF,END,' +\r\n    'EVAL,EXCEPT,EXCEPTION,EXIT,EXPORTS,FINALLY,FOR,FROM,GENERIC,IF,IMPORT,' +\r\n    'IN,INTERFACE,LOCK,LOOP,METHODS,MOD,MODULE,NOT,OBJECT,OF,OR,OVERRIDES,' +\r\n    'PROCEDURE,RAISE,RAISES,READONLY,RECORD,REF,REPEAT,RETURN,REVEAL,ROOT,' +\r\n    'SET,THEN,TO,TRY,TYPE,TYPECASE,UNSAFE,UNTIL,UNTRACED,VALUE,VAR,WHILE,WITH';\r\n\r\n  ReservedWords: UnicodeString =\r\n    'ABS,ADDRESS,ADR,ADRSIZE,BITSIZE,BOOLEAN,BYTESIZE,CARDINAL,CEILING,CHAR,' +\r\n    'DEC,DISPOSE,FALSE,FIRST,FLOAT,FLOOR,INC,INTEGER,ISTYPE,LAST,LONGFLOAT,' +\r\n    'LONGREAL,LOOPHOLE,MAX,MIN,MUTEX,NARROW,NEW,NIL,NULL,NUMBER,ORD,REAL,' +\r\n    'REFANY,ROUND,SUBARRAY,TEXT,TRUE,TRUNC,TYPECODE,VAL';\r\n\r\nprocedure TSynM3Syn.DoAddKeyword(AKeyword: UnicodeString; AKind: integer);\r\nvar\r\n  HashValue: integer;\r\nbegin\r\n  HashValue := HashKey(PWideChar(AKeyword));\r\n  fKeywords[HashValue] := TSynHashEntry.Create(AKeyword, AKind);\r\nend;\r\n\r\nfunction TSynM3Syn.HashKey(Str: PWideChar): Integer;\r\n\r\n  function GetOrd: Integer;\r\n  begin\r\n    case Str^ of\r\n      'a'..'z': Result := 1 + Ord(Str^) - Ord('a');\r\n      'A'..'Z': Result := 1 + Ord(Str^) - Ord('A');\r\n      '0'..'9': Result := 28 + Ord(Str^) - Ord('0');\r\n      '_': Result := 27;\r\n      else Result := 0;\r\n    end\r\n  end;\r\n\r\nbegin\r\n  Result := 0;\r\n  while IsIdentChar(Str^) do\r\n  begin\r\n{$IFOPT Q-}\r\n    Result := 7 * Result + GetOrd;\r\n{$ELSE}\r\n    Result := (7 * Result + GetOrd) and $FFFFFF;\r\n{$ENDIF}\r\n    Inc(Str);\r\n  end;\r\n  Result := Result and $FF; // 255\r\n  fStringLen := Str - fToIdent;\r\nend;\r\n\r\nfunction TSynM3Syn.IdentKind(MayBe: PWideChar): TtkTokenKind;\r\nvar\r\n  Entry: TSynHashEntry;\r\nbegin\r\n  fToIdent := MayBe;\r\n  Entry := fKeywords[HashKey(MayBe)];\r\n  while Assigned(Entry) do\r\n  begin\r\n    if Entry.KeywordLen > fStringLen then\r\n      break\r\n    else if Entry.KeywordLen = fStringLen then\r\n      if IsCurrentToken(Entry.Keyword) then\r\n      begin\r\n        Result := TtkTokenKind(Entry.Kind);\r\n        exit;\r\n      end;\r\n    Entry := Entry.Next;\r\n  end;\r\n  Result := tkIdentifier;\r\nend;\r\n\r\nconstructor TSynM3Syn.Create(AOwner: TComponent);\r\nbegin\r\n  inherited Create(AOwner);\r\n\r\n  fCaseSensitive := True;\r\n\r\n  fKeywords := TSynHashEntryList.Create;\r\n  fCommentAttri := TSynHighlighterAttributes.Create(SYNS_AttrComment, SYNS_FriendlyAttrComment);\r\n  fCommentAttri.Style:= [fsItalic];\r\n  AddAttribute(fCommentAttri);\r\n  fIdentifierAttri := TSynHighlighterAttributes.Create(SYNS_AttrIdentifier, SYNS_FriendlyAttrIdentifier);\r\n  AddAttribute(fIdentifierAttri);\r\n  fKeyAttri := TSynHighlighterAttributes.Create(SYNS_AttrKey, SYNS_FriendlyAttrKey);\r\n  fKeyAttri.Style:= [fsBold];\r\n  AddAttribute(fKeyAttri);\r\n  fNumberAttri := TSynHighlighterAttributes.Create(SYNS_AttrNumber, SYNS_FriendlyAttrNumber);\r\n  AddAttribute(fNumberAttri);\r\n  fPragmaAttri := TSynHighlighterAttributes.Create(SYNS_AttrPreprocessor, SYNS_FriendlyAttrPreprocessor);\r\n  fPragmaAttri.Style:= [fsBold];\r\n  AddAttribute(fPragmaAttri);\r\n  fReservedAttri := TSynHighlighterAttributes.Create(SYNS_AttrReservedWord, SYNS_FriendlyAttrReservedWord);\r\n  AddAttribute(fReservedAttri);\r\n  fSpaceAttri := TSynHighlighterAttributes.Create(SYNS_AttrSpace, SYNS_FriendlyAttrSpace);\r\n  AddAttribute(fSpaceAttri);\r\n  fStringAttri := TSynHighlighterAttributes.Create(SYNS_AttrString, SYNS_FriendlyAttrString);\r\n  AddAttribute(fStringAttri);\r\n  fSymbolAttri := TSynHighlighterAttributes.Create(SYNS_AttrSymbol, SYNS_FriendlyAttrSymbol);\r\n  AddAttribute(fSymbolAttri);\r\n  fSyntaxErrorAttri := TSynHighlighterAttributes.Create(SYNS_AttrSyntaxError, SYNS_FriendlyAttrSyntaxError);\r\n  fSyntaxErrorAttri.Foreground := clRed;\r\n  AddAttribute(fSyntaxErrorAttri);\r\n  SetAttributesOnChange(DefHighlightChange);\r\n\r\n  EnumerateKeywords(Ord(tkKey), Keywords, IsIdentChar, DoAddKeyword);\r\n  EnumerateKeywords(Ord(tkReserved), ReservedWords, IsIdentChar, DoAddKeyword);\r\n  fDefaultFilter := SYNS_FilterModula3;\r\nend;\r\n\r\ndestructor TSynM3Syn.Destroy;\r\nbegin\r\n  fKeywords.Free;\r\n  inherited Destroy;\r\nend;\r\n\r\nprocedure TSynM3Syn.SymAsciiCharProc;\r\nbegin\r\n  fTokenID := tkString;\r\n  Inc(Run);\r\n  while not IsLineEnd(Run) do\r\n  begin\r\n    case fLine[Run] of\r\n      '\\': if fLine[Run + 1] = #39 then\r\n             Inc(Run);\r\n      #39: begin\r\n             Inc(Run);\r\n             if fLine[Run] <> #39 then\r\n               break;\r\n           end;\r\n    end;\r\n    Inc(Run);\r\n  end;\r\nend;\r\n\r\nprocedure TSynM3Syn.SymCommentHelpProc;\r\nbegin\r\n  fTokenID := tkComment;\r\n  SymNestedHelperProc('(', ')');\r\nend;\r\n\r\nprocedure TSynM3Syn.SymCRProc;\r\nbegin\r\n  fTokenID := tkSpace;\r\n  Inc(Run);\r\n  if fLine[Run] = #10 then\r\n    Inc(Run);\r\nend;\r\n\r\nprocedure TSynM3Syn.SymIdentProc;\r\nbegin\r\n  fTokenID := IdentKind(fLine + Run);\r\n  Inc(Run, fStringLen);\r\n  while IsIdentChar(fLine[Run]) do\r\n    Inc(Run);\r\nend;\r\n\r\nprocedure TSynM3Syn.SymLFProc;\r\nbegin\r\n  fTokenID := tkSpace;\r\n  Inc(Run);\r\nend;\r\n\r\nprocedure TSynM3Syn.SymNestedHelperProc(AOpenChar, ACloseChar: WideChar);\r\nbegin\r\n  case fLine[Run] of\r\n     #0: SymNullProc;\r\n    #10: SymLFProc;\r\n    #13: SymCRProc;\r\n  else\r\n    repeat\r\n      if fLine[Run]= AOpenChar then\r\n      begin\r\n        Inc(Run);\r\n        if fLine[Run] = '*' then\r\n        begin\r\n          Inc(Run);\r\n          Inc(fRange.Level);\r\n        end;\r\n      end\r\n      else if fLine[Run] = '*' then\r\n      begin\r\n        Inc(Run);\r\n        if fLine[Run] = ACloseChar then\r\n        begin\r\n          Inc(Run);\r\n          if fRange.Level > 0 then\r\n            Dec(fRange.Level);\r\n          if fRange.Level = 0 then\r\n          begin\r\n            fRange.TokenRange := Ord(trNone);\r\n            break\r\n          end;\r\n        end;\r\n      end\r\n      else\r\n        Inc(Run);\r\n    until IsLineEnd(Run);\r\n  end;\r\nend;\r\n\r\nprocedure TSynM3Syn.SymNullProc;\r\nbegin\r\n  fTokenID := tkNull;\r\n  inc(Run);\r\nend;\r\n\r\nprocedure TSynM3Syn.SymNumberProc;\r\nvar\r\n  BasedNumber: Boolean;\r\n  MaxDigit: Integer;\r\n\r\n  function IsValidDigit(AChar: WideChar): Boolean;\r\n  var\r\n    Digit: Integer;\r\n  begin\r\n    case AChar of\r\n      '0'..'9': Digit := Ord(AChar) - Ord('0');\r\n      'a'..'f': Digit := Ord(AChar) - Ord('a');\r\n      'A'..'F': Digit := Ord(AChar) - Ord('A');\r\n      else Digit := -1;\r\n    end;\r\n    Result := (Digit >= 0) and (Digit <= MaxDigit);\r\n  end;\r\n\r\n  function IsExponentChar: Boolean;\r\n  begin\r\n    case fLine[Run] of\r\n      'd', 'D', 'e', 'E', 'x', 'X':\r\n        Result := True;\r\n      else\r\n        Result := False;\r\n    end;\r\n  end;\r\n\r\n\r\nbegin\r\n  fTokenID := tkNumber;\r\n  BasedNumber := False;\r\n  MaxDigit := 9;\r\n  // skip leading zeros, but they can be numbers too\r\n  while fLine[Run] = '0' do\r\n    Inc(Run);\r\n  if not IsIdentChar(fLine[Run]) then\r\n    exit;\r\n  // check for numbers with a base prefix\r\n  if CharInSet(fLine[Run], ['2'..'9']) and (fLine[Run + 1] = '_') then\r\n  begin\r\n    BasedNumber := True;\r\n    MaxDigit := Ord(fLine[Run]) - Ord('0') - 1;\r\n    Inc(Run, 2);\r\n  end\r\n  else if (fLine[Run] = '1') and CharInSet(fLine[Run + 1], ['0'..'6'])\r\n    and (fLine[Run + 2] = '_') then\r\n  begin\r\n    BasedNumber := True;\r\n    MaxDigit := 10 + Ord(fLine[Run + 1]) - Ord('0') - 1;\r\n    Inc(Run, 3);\r\n  end;\r\n  if BasedNumber then\r\n  begin\r\n    // advance over all valid digits, but at least one has to be there\r\n    if IsValidDigit(fLine[Run]) then\r\n    begin\r\n      repeat\r\n        Inc(Run);\r\n      until not IsValidDigit(fLine[Run]);\r\n    end\r\n    else\r\n      fTokenID := tkSyntaxError;\r\n  end\r\n  else\r\n  begin\r\n    // \"normal\" numbers\r\n    repeat\r\n      Inc(Run);\r\n    until not CharInSet(fLine[Run], ['0'..'9']);\r\n    // can include a decimal point and an exponent\r\n    if fLine[Run] = '.' then\r\n    begin\r\n      Inc(Run);\r\n      if CharInSet(fLine[Run], ['0'..'9']) then\r\n      begin\r\n        repeat\r\n          Inc(Run);\r\n        until not CharInSet(fLine[Run], ['0'..'9']);\r\n      end\r\n      else\r\n        fTokenID := tkSyntaxError; // must be a number after the '.'\r\n    end;\r\n    // can include an exponent\r\n    if IsExponentChar then\r\n    begin\r\n      Inc(Run);\r\n      if CharInSet(fLine[Run], ['+', '-']) then\r\n        Inc(Run);\r\n      if CharInSet(fLine[Run], ['0'..'9']) then\r\n      begin\r\n        repeat\r\n          Inc(Run);\r\n        until not CharInSet(fLine[Run], ['0'..'9']);\r\n      end\r\n      else // exponent must include a number\r\n        fTokenID := tkSyntaxError;\r\n    end;\r\n  end;\r\n  // it's a syntax error if there are any Identifier chars left\r\n  if IsIdentChar(fLine[Run]) then\r\n  begin\r\n    fTokenID := tkSyntaxError;\r\n    repeat\r\n      Inc(Run);\r\n    until not IsIdentChar(fLine[Run]);\r\n  end;\r\nend;\r\n\r\nprocedure TSynM3Syn.SymPragmaProc;\r\nbegin\r\n  Inc(Run);\r\n  if fLine[Run] = '*' then\r\n  begin\r\n    Inc(Run);\r\n    fRange.TokenRange := Ord(trPragma);\r\n    Inc(fRange.Level);\r\n    if IsLineEnd(Run) then\r\n      fTokenID := tkPragma\r\n    else\r\n      SymPragmaHelpProc;\r\n  end else\r\n    fTokenID := tkSymbol;\r\nend;\r\n\r\nprocedure TSynM3Syn.SymPragmaHelpProc;\r\nbegin\r\n  fTokenID := tkPragma;\r\n  SymNestedHelperProc('<', '>');\r\nend;\r\n\r\nprocedure TSynM3Syn.SymRoundOpenProc;\r\nbegin\r\n  Inc(Run);\r\n  if fLine[Run] = '*' then\r\n  begin\r\n    Inc(Run);\r\n    fRange.TokenRange := Ord(trComment);\r\n    Inc(fRange.Level);\r\n    if IsLineEnd(Run) then\r\n      fTokenID := tkComment\r\n    else\r\n      SymCommentHelpProc;\r\n  end\r\n  else\r\n  begin\r\n    fTokenID := tkSymbol;\r\n    if fLine[Run] = '.' then\r\n      Inc(Run);\r\n  end;\r\nend;\r\n\r\nprocedure TSynM3Syn.SymSpaceProc;\r\nbegin\r\n  inc(Run);\r\n  fTokenID := tkSpace;\r\n  while (FLine[Run] <= #32) and not IsLineEnd(Run) do inc(Run);\r\nend;\r\n\r\nprocedure TSynM3Syn.SymStringProc;\r\nbegin\r\n  fTokenID := tkString;\r\n  Inc(Run);\r\n  while not IsLineEnd(Run) do\r\n  begin\r\n    case fLine[Run] of\r\n      #34: begin\r\n             Inc(Run);\r\n             break;\r\n           end;\r\n      '\\': if CharInSet(fLine[Run + 1], [#34, '\\']) then\r\n             Inc(Run);\r\n    end;\r\n    Inc(Run);\r\n  end;\r\nend;\r\n\r\nprocedure TSynM3Syn.SymSymbolProc;\r\nbegin\r\n  Inc(Run);\r\n  fTokenID := tkSymbol;\r\nend;\r\n\r\nprocedure TSynM3Syn.SymUnknownProc;\r\nbegin\r\n  Inc(Run);\r\n  fTokenID := tkUnknown;\r\nend;\r\n\r\nprocedure TSynM3Syn.Next;\r\nbegin\r\n  fTokenPos := Run;\r\n  case TTokenRange(fRange.TokenRange) of\r\n    trComment: SymCommentHelpProc;\r\n    trPragma: SymPragmaHelpProc;\r\n  else\r\n    case fLine[Run] of\r\n      #39: SymAsciiCharProc;\r\n      #13: SymCRProc;\r\n      'A'..'Z', 'a'..'z', '_': SymIdentProc;\r\n      #10: SymLFProc;\r\n       #0: SymNullProc;\r\n      '0'..'9': SymNumberProc;\r\n      '(': SymRoundOpenProc;\r\n      #1..#9, #11, #12, #14..#32: SymSpaceProc;\r\n      '{','}','|','!', #35..#38, #42..#47, #58, #59, #61..#64, #91..#94, ')': SymSymbolProc;\r\n      '<': SymPragmaProc;\r\n      #34: SymStringProc;\r\n      else SymUnknownProc;\r\n    end;\r\n  end;\r\n  inherited;\r\nend;\r\n\r\nfunction TSynM3Syn.GetDefaultAttribute(Index: integer):\r\n  TSynHighlighterAttributes;\r\nbegin\r\n  case Index of\r\n    SYN_ATTR_COMMENT: Result := fCommentAttri;\r\n    SYN_ATTR_IDENTIFIER: Result := fIdentifierAttri;\r\n    SYN_ATTR_KEYWORD: Result := fKeyAttri;\r\n    SYN_ATTR_STRING: Result := fStringAttri;\r\n    SYN_ATTR_WHITESPACE: Result := fSpaceAttri;\r\n    SYN_ATTR_SYMBOL: Result := fSymbolAttri;\r\n  else\r\n    Result := nil;\r\n  end;\r\nend;\r\n\r\nfunction TSynM3Syn.GetEol: Boolean;\r\nbegin\r\n  Result := Run = fLineLen + 1;\r\nend;\r\n\r\nfunction TSynM3Syn.IsFilterStored: Boolean;\r\nbegin\r\n  Result := fDefaultFilter <> SYNS_FilterModula3;\r\nend;\r\n\r\nclass function TSynM3Syn.GetLanguageName: string;\r\nbegin\r\n  Result := SYNS_LangModula3;\r\nend;\r\n\r\nfunction TSynM3Syn.GetRange: pointer;\r\nbegin\r\n  result := fRange.p;\r\nend;\r\n\r\nfunction TSynM3Syn.GetTokenAttribute: TSynHighlighterAttributes;\r\nbegin\r\n  case fTokenID of\r\n    tkComment: Result := fCommentAttri;\r\n    tkIdentifier: Result := fIdentifierAttri;\r\n    tkKey: Result := fKeyAttri;\r\n    tkNumber: Result := fNumberAttri;\r\n    tkPragma: Result:= fPragmaAttri;\r\n    tkReserved: Result := fReservedAttri;\r\n    tkSpace: Result := fSpaceAttri;\r\n    tkString: Result := fStringAttri;\r\n    tkSymbol: Result := fSymbolAttri;\r\n    tkSyntaxError: Result := fSyntaxErrorAttri;\r\n    tkUnknown: Result := fIdentifierAttri;\r\n  else\r\n    Result := nil;\r\n  end;\r\nend;\r\n\r\nfunction TSynM3Syn.GetTokenID: TtkTokenKind;\r\nbegin\r\n  Result := fTokenId;\r\nend;\r\n\r\nfunction TSynM3Syn.GetTokenKind: integer;\r\nbegin\r\n  Result := Ord(fTokenId);\r\nend;\r\n\r\nprocedure TSynM3Syn.ResetRange;\r\nbegin\r\n  fRange.p := nil;\r\nend;\r\n\r\nprocedure TSynM3Syn.SetRange(Value: pointer);\r\nbegin\r\n  fRange.p := Value;\r\nend;\r\n\r\nclass function TSynM3Syn.GetFriendlyLanguageName: UnicodeString;\r\nbegin\r\n  Result := SYNS_FriendlyLangModula3;\r\nend;\r\n\r\ninitialization\r\n{$IFNDEF SYN_CPPB_1}\r\n  RegisterPlaceableHighlighter(TSynM3Syn);\r\n{$ENDIF}\r\nend.\r\n"
  },
  {
    "path": "External/SynEdit/Source/SynHighlighterManager.pas",
    "content": "{-------------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: SynHighlighterManager.pas, released 2000-04-14.\r\n\r\nThe Original Code is based on mwHighlighterManager.pas by Primoz Gabrijelcic,\r\npart of the mwEdit component suite.\r\nAll Rights Reserved.\r\n\r\nContributors to the SynEdit and mwEdit projects are listed in the\r\nContributors.txt file.\r\n\r\nAlternatively, the contents of this file may be used under the terms of the\r\nGNU General Public License Version 2 or later (the \"GPL\"), in which case\r\nthe provisions of the GPL are applicable instead of those above.\r\nIf you wish to allow use of your version of this file only under the terms\r\nof the GPL and not to allow others to use your version of this file\r\nunder the MPL, indicate your decision by deleting the provisions above and\r\nreplace them with the notice and other provisions required by the GPL.\r\nIf you do not delete the provisions above, a recipient may use your version\r\nof this file under either the MPL or the GPL.\r\n\r\n$Id: SynHighlighterManager.pas,v 1.7.2.2 2008/03/01 18:32:02 maelh Exp $\r\n\r\nYou may retrieve the latest version of this file at the SynEdit home page,\r\nlocated at http://SynEdit.SourceForge.net\r\n\r\nKnown Issues:\r\n  - does not work when dropped on a frame in Delphi 5\r\n-------------------------------------------------------------------------------}\r\n{\r\n@abstract(Provides a component to manage many highlighters in a single project.)\r\n@author(Primoz Gabrijelcic)\r\n@created(1999, converted to SynEdit 2000-04-14)\r\n@lastmod(2000-04-14)\r\nProvides a component to manage many highlighters in a single project.\r\n}\r\n\r\n{$IFNDEF QSYNHIGHLIGHTERMANAGER}\r\nunit SynHighlighterManager;\r\n{$ENDIF}\r\n\r\n{$I SynEdit.inc}\r\n\r\ninterface\r\n\r\nuses\r\n  Classes;\r\n\r\ntype\r\n  {:Highlighter manager.
    \r\n    Design-only component, designed to simplify work with highlighter components.
    \r\n    When placed on the form, SynHighlighterManager scans the form for highlighter\r\n    components (descendants of TSynCustomHighlighter). Next it presents the user with\r\n    small form containing checkboxed list and some buttons. User can select (by\r\n    checking/unchecking list items) highlighter that should be placed onto the\r\n    form. After user clicks OK, SynHighlighterManager synchronises highlighter\r\n    components on the form with required state.
    \r\n    Built-in tricks:
    \r\n    - SynHighlighterManager never covers existing TComponent with a highlighter.
    \r\n    - SynHighlighterManager scans the form for TSynCustomHighlighter descendants and\r\n      uses topmost and leftmost component as a starting point for insertion. If\r\n      no TSynCustomHighlighter components are found, first highlighter will be placed\r\n      at coordinates (8,8).
    \r\n    Known issues:
    \r\n    - If you place TSynHighlighterManager by double-clicking its icon in\r\n      component palette, it will function normally, except that when all is\r\n      done, Delphi will disply small window with title \"Error\" and message\r\n      \"Operation aborted\". Purely cosmetic issue for which there is no obvious\r\n      workaround. Live with it.
    \r\n    Last change: 2000-01-21\r\n\r\n    @author Primoz Gabrijelcic\r\n    @version 0.1\r\n    @component\r\n    @see TSynEditHighlighter\r\n  :}\r\n  TSynHighlighterManager = class(TComponent)\r\n  public\r\n    constructor Create(AOwner: TComponent); override;\r\n  published\r\n  end;\r\n\r\nimplementation\r\n\r\nuses\r\n{$IFDEF SYN_COMPILER_6_UP}\r\n  DesignIntf,\r\n{$ELSE}\r\n  DsgnIntf,\r\n{$ENDIF}\r\n{$IFDEF SYN_CLX}\r\n  Qt,\r\n  QForms,\r\n  QControls,\r\n  QStdCtrls,\r\n  QCheckLst,\r\n  Types,\r\n  QSynEditHighlighter,\r\n  QSynEditStrConst,\r\n{$ELSE}\r\n  Windows,\r\n  Forms,\r\n  Controls,\r\n  StdCtrls,\r\n  CheckLst,\r\n  SynEditHighlighter,\r\n  SynEditStrConst,\r\n{$ENDIF}\r\n  SysUtils;\r\n\r\ntype\r\n  TSynHighlighterForm = class(TForm)\r\n    clbHighlighters: TCheckListBox;\r\n    btnSelectAll: TButton;\r\n    btnDeselectAll: TButton;\r\n    btnOK: TButton;\r\n    btnCancel: TButton;\r\n    Highlight: TSynHighlighterList;\r\n    constructor Create(highlighters: TSynHighlighterList);\r\n      {$IFDEF SYN_COMPILER_4_UP}reintroduce;{$ENDIF}\r\n    procedure   LoadForm;\r\n    procedure   SelectAll(Sender: TObject);\r\n    procedure   DeselectAll(Sender: TObject);\r\n  end;\r\n\r\n  {$IFDEF SYN_COMPILER_4_UP}\r\n    {$IFDEF SYN_COMPILER_6_UP}\r\n      TDesignerClass = IDesigner;\r\n    {$ELSE}\r\n      TDesignerClass = IFormDesigner;\r\n    {$ENDIF}\r\n  {$ELSE}\r\n    TDesignerClass = TFormDesigner;\r\n  {$ENDIF}\r\n\r\n{ TSynHighlighterManager }\r\n\r\nconstructor TSynHighlighterManager.Create(AOwner: TComponent);\r\nvar\r\n  form: TCustomForm;\r\n  dsgn: TDesignerClass;\r\n  highlight: TSynHighlighterList;\r\n  synForm: TSynHighlighterForm;\r\n\r\n  procedure CheckExisting;\r\n  var\r\n    i: integer;\r\n    j: integer;\r\n  begin\r\n    for i := 0 to form.ComponentCount-1 do begin\r\n      j := highlight.FindByClass(form.Components[i]);\r\n      if j >= 0 then begin\r\n        j := synForm.clbHighlighters.Items.IndexOf(highlight[j].GetFriendlyLanguageName);\r\n        if j >= 0 then\r\n          synForm.clbHighlighters.Checked[j] := true;\r\n      end;\r\n    end; //for\r\n  end;\r\n\r\n  function FindHighlighterComp(hlClass: TSynCustomHighlighterClass): integer;\r\n  var\r\n    i: integer;\r\n  begin\r\n    Result := -1;\r\n    for i := 0 to form.ComponentCount-1 do begin\r\n      if form.Components[i] is hlClass then begin\r\n        Result := i;\r\n        Exit;\r\n      end;\r\n    end; //for\r\n  end;\r\n\r\n  procedure PlaceNew;\r\n  var\r\n    i: integer;\r\n    high: integer;\r\n    comp: integer;\r\n    xpos, ypos: integer;\r\n    xstart: integer;\r\n\r\n    procedure GetStartCoordinates;\r\n    var\r\n      compTop: integer;\r\n      compLeft: integer;\r\n      i: integer;\r\n    begin\r\n      xpos := -1;\r\n      ypos := -1;\r\n      for i := 0 to form.ComponentCount-1 do begin\r\n        if form.Components[i] is TSynCustomHighlighterClass then begin\r\n          compLeft := LongRec(form.Components[i].DesignInfo).Lo;\r\n          compTop  := LongRec(form.Components[i].DesignInfo).Hi;\r\n          if (xpos < 0) or (compLeft < xpos) then\r\n            xpos := compLeft;\r\n          if (ypos < 0) or (compTop < ypos) then\r\n            ypos := compTop;\r\n        end;\r\n      end; //for\r\n      if xpos < 0 then\r\n        xpos := 8;\r\n      if ypos < 0 then\r\n        ypos := 8;\r\n      xstart := xpos;\r\n    end;\r\n\r\n    procedure IncCoordinates;\r\n    begin\r\n      Inc(xpos,32);\r\n      if (xpos+32) >= form.ClientWidth then begin\r\n        xpos := xstart;\r\n        Inc(ypos,32);\r\n      end;\r\n    end;\r\n\r\n    function CoordinatesTaken: boolean;\r\n    var\r\n      compTop: integer;\r\n      compLeft: integer;\r\n      compRect: TRect;\r\n      testRect: TRect;\r\n      interRect: TRect;\r\n      i: integer;\r\n    begin\r\n      Result := false;\r\n      testRect := Rect(xpos,ypos,xpos+31,ypos+31);\r\n      for i := 0 to form.ComponentCount-1 do begin\r\n        if (form.Components[i] <> self) and (not (form.Components[i] is TControl)) then begin\r\n          compLeft := LongRec(form.Components[i].DesignInfo).Lo;\r\n          compTop  := LongRec(form.Components[i].DesignInfo).Hi;\r\n          compRect := Rect(compLeft,compTop,compLeft+31,compTop+31);\r\n          if IntersectRect(interRect,testRect,compRect) then begin\r\n            Result := true;\r\n            Exit;\r\n          end;\r\n        end;\r\n      end; //for\r\n    end;\r\n\r\n    procedure GetFreeCoordinates;\r\n    begin\r\n      while CoordinatesTaken do\r\n        IncCoordinates;\r\n    end;\r\n\r\n  begin\r\n    GetStartCoordinates;\r\n    // Iterate over TCheckListBox, not over GetPlaceableHighlighters to ensure\r\n    // inserted highlighters to be sorted by name.\r\n    // Iterate twice - delete highlighters in first pass (to make place), create\r\n    // in second.\r\n    for i := 0 to synForm.clbHighlighters.Items.Count-1 do begin\r\n      if not synForm.clbHighlighters.Checked[i] then begin // unchecked - remove\r\n        high := highlight.FindByFriendlyName(synForm.clbHighlighters.Items[i]);\r\n        if high >= 0 then begin\r\n          comp := FindHighlighterComp(highlight[high]);\r\n          if comp >= 0 then\r\n            form.Components[comp].Free;\r\n        end;\r\n      end;\r\n    end; //for\r\n    for i := 0 to synForm.clbHighlighters.Items.Count-1 do begin\r\n      if synForm.clbHighlighters.Checked[i] then begin // checked - add\r\n        high := highlight.FindByFriendlyName(synForm.clbHighlighters.Items[i]);\r\n        if high >= 0 then begin\r\n          if FindHighlighterComp(highlight[high]) < 0 then begin\r\n            GetFreeCoordinates;\r\n            dsgn.CreateComponent(highlight[high],AOwner,xpos,ypos,24,24);\r\n            IncCoordinates;\r\n          end;\r\n        end;\r\n      end;\r\n    end; //for\r\n  end;\r\n\r\nbegin\r\n  inherited;\r\n  if (csDesigning in ComponentState) and (AOwner is TCustomForm) then begin\r\n    form := TCustomForm(AOwner);\r\n{$IFDEF SYN_CLX}\r\n    dsgn := form.DesignerHook as TDesignerClass;\r\n{$ELSE}\r\n    dsgn := form.Designer as TDesignerClass;\r\n{$ENDIF}\r\n    highlight := GetPlaceableHighlighters;\r\n    if highlight.Count = 0 then\r\n{$IFDEF SYN_CLX}\r\n      Application.MessageBox('No highlighters found!','Highlighter Manager', [smbOK], smsWarning)\r\n{$ELSE}\r\n      Application.MessageBox('No highlighters found!','Highlighter Manager', MB_OK + MB_ICONEXCLAMATION)\r\n{$ENDIF}\r\n    else\r\n    begin\r\n      synForm := TSynHighlighterForm.Create(highlight);\r\n      try\r\n        CheckExisting;\r\n        if synForm.ShowModal = mrOK then\r\n          PlaceNew;\r\n      finally\r\n        synForm.Free;\r\n      end;\r\n    end;\r\n  end;\r\n  SysUtils.Abort;\r\nend;\r\n\r\n{ TSynHighlighterForm }\r\n\r\nconstructor TSynHighlighterForm.Create(highlighters: TSynHighlighterList);\r\nbegin\r\n  CreateNew(nil);\r\n  Caption := 'Highlighter Manager';\r\n  Width  := 410;\r\n  Height := 243;\r\n  Position := poScreenCenter;\r\n{$IFDEF SYN_CLX}\r\n  BorderStyle := fbsDialog;\r\n{$ELSE}\r\n  BorderStyle := bsDialog;\r\n{$ENDIF}\r\n\r\n  Highlight := highlighters;\r\n  \r\n//object clbHighlighters: TCheckListBox\r\n//  Left = 8\r\n//  Top = 8\r\n//  Width = 305\r\n//  Height = 201\r\n//  ItemHeight = 13\r\n//  TabOrder = 0\r\n//end\r\n\r\n//object btnSelectAll: TButton\r\n//  Left = 320\r\n//  Top = 8\r\n//  Width = 75\r\n//  Height = 25\r\n//  Caption = '&Select All'\r\n//  TabOrder = 1\r\n//end\r\n\r\n//object btnDeselectAll: TButton\r\n//  Left = 320\r\n//  Top = 40\r\n//  Width = 75\r\n//  Height = 25\r\n//  Caption = '&Deselect All'\r\n//  TabOrder = 2\r\n//end\r\n\r\n//object btnOK: TButton\r\n//  Left = 320\r\n//  Top = 152\r\n//  Width = 75\r\n//  Height = 25\r\n//  Caption = 'OK'\r\n//  Default = True\r\n//  ModalResult = 1\r\n//  TabOrder = 3\r\n//end\r\n\r\n//object btnCancel: TButton\r\n//  Left = 320\r\n//  Top = 184\r\n//  Width = 75\r\n//  Height = 25\r\n//  Caption = 'Cancel'\r\n//  ModalResult = 2\r\n//  TabOrder = 4\r\n//end\r\n\r\n  clbHighlighters := TCheckListBox.Create(Self);\r\n  btnSelectAll := TButton.Create(Self);\r\n  btnDeselectAll := TButton.Create(Self);\r\n  btnOK := TButton.Create(Self);\r\n  btnCancel := TButton.Create(Self);\r\n  with clbHighlighters do\r\n  begin\r\n    Name := 'clbHighlighters';\r\n    Parent := Self;\r\n    Left := 8;\r\n    Top := 8;\r\n    Width := 305;\r\n    Height := 201;\r\n    ItemHeight := 13;\r\n    Sorted := true;\r\n    TabOrder := 0;\r\n  end;\r\n  with btnSelectAll do\r\n  begin\r\n    Name := 'btnSelectAll';\r\n    Parent := Self;\r\n    Left := 320;\r\n    Top := 8;\r\n    Width := 75;\r\n    Height := 25;\r\n    Caption := '&Select All';\r\n    TabOrder := 1;\r\n    OnClick := SelectAll;\r\n  end;\r\n  with btnDeselectAll do\r\n  begin\r\n    Name := 'btnDeselectAll';\r\n    Parent := Self;\r\n    Left := 320;\r\n    Top := 40;\r\n    Width := 75;\r\n    Height := 25;\r\n    Caption := '&Deselect All';\r\n    TabOrder := 2;\r\n    OnClick := DeselectAll;\r\n  end;\r\n  with btnOK do\r\n  begin\r\n    Name := 'btnOK';\r\n    Parent := Self;\r\n    Left := 320;\r\n    Top := 152;\r\n    Width := 75;\r\n    Height := 25;\r\n    Caption := 'OK';\r\n    Default := True;\r\n    ModalResult := 1;\r\n    TabOrder := 3;\r\n  end;\r\n  with btnCancel do\r\n  begin\r\n    Name := 'btnCancel';\r\n    Parent := Self;\r\n    Left := 320;\r\n    Top := 184;\r\n    Width := 75;\r\n    Height := 25;\r\n    Caption := 'Cancel';\r\n    ModalResult := 2;\r\n    TabOrder := 4;\r\n  end;\r\n  LoadForm;\r\nend;\r\n\r\nprocedure TSynHighlighterForm.DeselectAll(Sender: TObject);\r\nvar\r\n  i: integer;\r\nbegin\r\n  for i := 0 to clbHighlighters.Items.Count-1 do\r\n    clbHighlighters.Checked[i] := false;\r\nend;\r\n\r\nprocedure TSynHighlighterForm.LoadForm;\r\nvar\r\n  i: integer;\r\nbegin\r\n  clbHighlighters.Clear;\r\n  for i := 0 to Highlight.Count-1 do begin\r\n    clbHighlighters.Items.Add(Highlight[i].GetFriendlyLanguageName); \r\n  end; //for\r\nend;\r\n\r\nprocedure TSynHighlighterForm.SelectAll(Sender: TObject);\r\nvar\r\n  i: integer;\r\nbegin\r\n  for i := 0 to clbHighlighters.Items.Count-1 do\r\n    clbHighlighters.Checked[i] := true;\r\nend;\r\n\r\nend.\r\n"
  },
  {
    "path": "External/SynEdit/Source/SynHighlighterModelica.pas",
    "content": "{-------------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: SynHighlighterModelica.pas, released 2000-11-09.\r\nThe Initial Author of this file is Falko Jens Wagner.\r\nPortions created by Falko Jens Wagner are Copyright 2000 Falko Jens Wagner.\r\nUnicode translation by Mal Hrz.\r\nAll Rights Reserved.\r\n\r\nContributors to the SynEdit project are listed in the Contributors.txt file.\r\n\r\nAlternatively, the contents of this file may be used under the terms of the\r\nGNU General Public License Version 2 or later (the \"GPL\"), in which case\r\nthe provisions of the GPL are applicable instead of those above.\r\nIf you wish to allow use of your version of this file only under the terms\r\nof the GPL and not to allow others to use your version of this file\r\nunder the MPL, indicate your decision by deleting the provisions above and\r\nreplace them with the notice and other provisions required by the GPL.\r\nIf you do not delete the provisions above, a recipient may use your version\r\nof this file under either the MPL or the GPL.\r\n\r\n$Id: SynHighlighterModelica.pas,v 1.12.2.6 2008/09/14 16:25:00 maelh Exp $\r\n\r\nYou may retrieve the latest version of this file at the SynEdit home page,\r\nlocated at http://SynEdit.SourceForge.net\r\n\r\nKnown Issues:\r\n-------------------------------------------------------------------------------}\r\n\r\n{$IFNDEF QSYNHIGHLIGHTERMODELICA}\r\nunit SynHighlighterModelica;\r\n{$ENDIF}\r\n\r\n{$I SynEdit.inc}\r\n\r\ninterface\r\n\r\nuses\r\n{$IFDEF SYN_CLX}\r\n  QGraphics,\r\n  QSynEditTypes,\r\n  QSynEditHighlighter,\r\n  QSynUnicode,\r\n{$ELSE}\r\n  Graphics,\r\n  Registry,\r\n  SynEditTypes,\r\n  SynEditHighlighter,\r\n  SynUnicode,\r\n{$ENDIF}\r\n  SysUtils,\r\n  Classes;\r\n\r\ntype\r\n  TtkTokenKind = (tkComment, tkDirective, tkIdentifier, tkKey, tkNull, tkNumber,\r\n    tkSpace, tkString, tkSymbol, tkUnknown);\r\n\r\n  TRangeState = (rsUnknown, rsString39, rsString34, rsComment);\r\n\r\n  PIdentFuncTableFunc = ^TIdentFuncTableFunc;\r\n  TIdentFuncTableFunc = function (Index: Integer): TtkTokenKind of object;\r\n\r\ntype\r\n  TSynModelicaSyn = class(TSynCustomHighlighter)\r\n  private\r\n    fRange: TRangeState;\r\n    fTokenID: TtkTokenKind;\r\n    fIdentFuncTable: array[0..96] of TIdentFuncTableFunc;\r\n    fCommentAttri: TSynHighlighterAttributes;\r\n    fDirectiveAttri: TSynHighlighterAttributes;\r\n    fIdentifierAttri: TSynHighlighterAttributes;\r\n    fKeyAttri: TSynHighlighterAttributes;\r\n    fNumberAttri: TSynHighlighterAttributes;\r\n    fSpaceAttri: TSynHighlighterAttributes;\r\n    fStringAttri: TSynHighlighterAttributes;\r\n    fSymbolAttri: TSynHighlighterAttributes;\r\n    function AltFunc(Index: Integer): TtkTokenKind;\r\n    function KeyWordFunc(Index: Integer): TtkTokenKind;\r\n    function HashKey(Str: PWideChar): Cardinal;\r\n    function IdentKind(MayBe: PWideChar): TtkTokenKind;\r\n    procedure InitIdent;\r\n    procedure AndSymbolProc;\r\n    procedure AsciiCharProc;\r\n    procedure CRProc;\r\n    procedure ColonProc;\r\n    procedure DirectiveProc;\r\n    procedure GreaterProc;\r\n    procedure IdentProc;\r\n    procedure LFProc;\r\n    procedure LowerProc;\r\n    procedure MinusProc;\r\n    procedure NullProc;\r\n    procedure NumberProc;\r\n    procedure OrSymbolProc;\r\n    procedure PlusProc;\r\n    procedure PointProc;\r\n    procedure SlashProc;\r\n    procedure SpaceProc;\r\n    procedure StringProc;\r\n    procedure SymbolProc;\r\n    procedure SymbolProcWithEqual;\r\n    procedure UnknownProc;\r\n    procedure AnsiCProc;\r\n    procedure String34Proc;\r\n    procedure String39Proc;\r\n  protected\r\n    function IsFilterStored: Boolean; override;\r\n  public\r\n    class function GetLanguageName: string; override;\r\n    class function GetFriendlyLanguageName: UnicodeString; override;\r\n  public\r\n    constructor Create(AOwner: TComponent); override;\r\n    function GetDefaultAttribute(Index: integer): TSynHighlighterAttributes;\r\n      override;\r\n    function GetEol: boolean; override;\r\n    function GetRange: Pointer; override;\r\n    function GetTokenID: TtkTokenKind;\r\n    function GetTokenAttribute: TSynHighlighterAttributes; override;\r\n    function GetTokenKind: integer; override;\r\n    procedure Next; override;\r\n    procedure SetRange(Value: Pointer); override;\r\n    procedure ResetRange; override;\r\n  published\r\n    property CommentAttri: TSynHighlighterAttributes read fCommentAttri\r\n      write fCommentAttri;\r\n    property DirectiveAttri: TSynHighlighterAttributes read fDirectiveAttri\r\n      write fDirectiveAttri;\r\n    property IdentifierAttri: TSynHighlighterAttributes read fIdentifierAttri\r\n      write fIdentifierAttri;\r\n    property KeyAttri: TSynHighlighterAttributes read fKeyAttri write fKeyAttri;\r\n    property NumberAttri: TSynHighlighterAttributes read fNumberAttri\r\n      write fNumberAttri;\r\n    property SpaceAttri: TSynHighlighterAttributes read fSpaceAttri\r\n      write fSpaceAttri;\r\n    property StringAttri: TSynHighlighterAttributes read fStringAttri\r\n      write fStringAttri;\r\n    property SymbolAttri: TSynHighlighterAttributes read fSymbolAttri\r\n      write fSymbolAttri;\r\n  end;\r\n\r\nimplementation\r\n\r\nuses\r\n{$IFDEF SYN_CLX}\r\n  QSynEditStrConst;\r\n{$ELSE}\r\n  SynEditStrConst;\r\n{$ENDIF}\r\n\r\nconst\r\n  KeyWords: array[0..47] of UnicodeString = (\r\n    'algorithm', 'and', 'annotation', 'assert', 'block', 'Boolean', 'class', \r\n    'connect', 'connector', 'constant', 'der', 'discrete', 'else', 'elseif', \r\n    'end', 'equation', 'extends', 'external', 'false', 'final', 'flow', 'for', \r\n    'function', 'if', 'in', 'input', 'Integer', 'loop', 'model', 'nondiscrete', \r\n    'not', 'or', 'output', 'package', 'parameter', 'partial', 'protected', \r\n    'public', 'Real', 'record', 'redeclare', 'replaceable', 'terminate', 'then', \r\n    'true', 'type', 'when', 'while' \r\n  );\r\n\r\n  KeyIndices: array[0..96] of Integer = (\r\n    -1, 8, 41, 46, -1, 21, -1, 30, 5, -1, 45, -1, -1, 23, 7, -1, -1, 17, 15, -1, \r\n    -1, 10, -1, -1, -1, 3, -1, 18, -1, 28, -1, -1, 47, -1, -1, -1, -1, -1, 39, \r\n    16, 27, 25, -1, 4, 22, -1, 43, -1, 37, 40, -1, -1, 31, -1, 42, -1, -1, 26, \r\n    14, 24, 44, -1, -1, -1, -1, 11, 33, 0, -1, -1, -1, -1, 36, 19, -1, 38, -1, \r\n    32, -1, -1, 29, -1, -1, -1, 6, 35, 12, 1, -1, -1, -1, 20, 34, -1, 13, 9, 2 \r\n  );\r\n\r\n{$Q-}\r\nfunction TSynModelicaSyn.HashKey(Str: PWideChar): Cardinal;\r\nbegin\r\n  Result := 0;\r\n  while IsIdentChar(Str^) do\r\n  begin\r\n    Result := Result * 598 + Ord(Str^) * 127;\r\n    inc(Str);\r\n  end;\r\n  Result := Result mod 97;\r\n  fStringLen := Str - fToIdent;\r\nend;\r\n{$Q+}\r\n\r\nfunction TSynModelicaSyn.IdentKind(MayBe: PWideChar): TtkTokenKind;\r\nvar\r\n  Key: Cardinal;\r\nbegin\r\n  fToIdent := MayBe;\r\n  Key := HashKey(MayBe);\r\n  if Key <= High(fIdentFuncTable) then\r\n    Result := fIdentFuncTable[Key](KeyIndices[Key])\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nprocedure TSynModelicaSyn.InitIdent;\r\nvar\r\n  i: Integer;\r\nbegin\r\n  for i := Low(fIdentFuncTable) to High(fIdentFuncTable) do\r\n    if KeyIndices[i] = -1 then\r\n      fIdentFuncTable[i] := AltFunc;\r\n\r\n  for i := Low(fIdentFuncTable) to High(fIdentFuncTable) do\r\n    if @fIdentFuncTable[i] = nil then\r\n      fIdentFuncTable[i] := KeyWordFunc;\r\nend;\r\n\r\nfunction TSynModelicaSyn.AltFunc(Index: Integer): TtkTokenKind;\r\nbegin\r\n  Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynModelicaSyn.KeyWordFunc(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier\r\nend;\r\n\r\nconstructor TSynModelicaSyn.Create(AOwner: TComponent);\r\nbegin\r\n  inherited Create(AOwner);\r\n\r\n  fCaseSensitive := True;\r\n\r\n  fCommentAttri := TSynHighlighterAttributes.Create(SYNS_AttrComment, SYNS_FriendlyAttrComment);\r\n  fCommentAttri.Style := [fsItalic];\r\n  AddAttribute(fCommentAttri);\r\n  fDirectiveAttri := TSynHighlighterAttributes.Create(SYNS_AttrDirective, SYNS_FriendlyAttrDirective);\r\n  AddAttribute(fDirectiveAttri);\r\n  fIdentifierAttri := TSynHighlighterAttributes.Create(SYNS_AttrIdentifier, SYNS_FriendlyAttrIdentifier);\r\n  AddAttribute(fIdentifierAttri);\r\n  fKeyAttri := TSynHighlighterAttributes.Create(SYNS_AttrReservedWord, SYNS_FriendlyAttrReservedWord);\r\n  fKeyAttri.Style := [fsBold];\r\n  AddAttribute(fKeyAttri);\r\n  fNumberAttri := TSynHighlighterAttributes.Create(SYNS_AttrNumber, SYNS_FriendlyAttrNumber);\r\n  AddAttribute(fNumberAttri);\r\n  fSpaceAttri := TSynHighlighterAttributes.Create(SYNS_AttrSpace, SYNS_FriendlyAttrSpace);\r\n  AddAttribute(fSpaceAttri);\r\n  fStringAttri := TSynHighlighterAttributes.Create(SYNS_AttrString, SYNS_FriendlyAttrString);\r\n  AddAttribute(fStringAttri);\r\n  fSymbolAttri := TSynHighlighterAttributes.Create(SYNS_AttrSymbol, SYNS_FriendlyAttrSymbol);\r\n  AddAttribute(fSymbolAttri);\r\n  SetAttributesOnChange(DefHighlightChange);\r\n  InitIdent;\r\n  fDefaultFilter := SYNS_FilterModelica;\r\n  fRange := rsUnknown;\r\nend;\r\n\r\nprocedure TSynModelicaSyn.AndSymbolProc;\r\nbegin\r\n  Inc(Run);\r\n  fTokenID := tkSymbol;\r\n  if CharInSet(fLine[Run], ['=', '&']) then\r\n    Inc(Run);\r\nend;\r\n\r\nprocedure TSynModelicaSyn.AsciiCharProc;\r\nbegin\r\n  fRange := rsString39;\r\n  fTokenID := tkString;\r\n  repeat\r\n    Inc(Run);\r\n  until IsLineEnd(Run) or (fLine[Run] = #39);\r\n  if fLine[Run] = #39 then\r\n  begin\r\n    fRange := rsUnknown;\r\n    Inc(Run);\r\n  end;\r\nend;\r\n\r\nprocedure TSynModelicaSyn.CRProc;\r\nbegin\r\n  fTokenID := tkSpace;\r\n  Inc(Run);\r\n  if fLine[Run] = #10 then\r\n    Inc(Run);\r\nend;\r\n\r\nprocedure TSynModelicaSyn.ColonProc;\r\nbegin\r\n  Inc(Run);\r\n  fTokenID := tkSymbol;\r\n  if fLine[Run] = ':' then\r\n    Inc(Run);\r\nend;\r\n\r\nprocedure TSynModelicaSyn.DirectiveProc;\r\nbegin\r\n  fTokenID := tkDirective;\r\n  repeat\r\n    Inc(Run);\r\n  until IsLineEnd(Run);\r\nend;\r\n\r\nprocedure TSynModelicaSyn.GreaterProc;\r\nbegin\r\n  Inc(Run);\r\n  fTokenID := tkSymbol;\r\n  case fLine[Run] of\r\n    '=': Inc(Run);\r\n    '>': begin\r\n           Inc(Run);\r\n           if fLine[Run] = '=' then\r\n             Inc(Run);\r\n         end;\r\n  end;\r\nend;\r\n\r\nprocedure TSynModelicaSyn.IdentProc;\r\nbegin\r\n  fTokenID := IdentKind((fLine + Run));\r\n  inc(Run, fStringLen);\r\n  while IsIdentChar(fLine[Run]) do inc(Run);\r\nend;\r\n\r\nprocedure TSynModelicaSyn.LFProc;\r\nbegin\r\n  fTokenID := tkSpace;\r\n  inc(Run);\r\nend;\r\n\r\nprocedure TSynModelicaSyn.LowerProc;\r\nbegin\r\n  Inc(Run);\r\n  fTokenID := tkSymbol;\r\n  case fLine[Run] of\r\n    '=': Inc(Run);\r\n    '<': begin\r\n           Inc(Run);\r\n           if fLine[Run] = '=' then\r\n             Inc(Run);\r\n         end;\r\n  end;\r\nend;\r\n\r\nprocedure TSynModelicaSyn.MinusProc;\r\nbegin\r\n  Inc(Run);\r\n  fTokenID := tkSymbol;\r\n  if CharInSet(fLine[Run], ['=', '-', '>']) then\r\n    Inc(Run);\r\nend;\r\n\r\nprocedure TSynModelicaSyn.NullProc;\r\nbegin\r\n  fTokenID := tkNull;\r\n  inc(Run);\r\nend;\r\n\r\nprocedure TSynModelicaSyn.NumberProc;\r\n\r\n  function IsNumberChar: Boolean;\r\n  begin\r\n    case fLine[Run] of\r\n      '0'..'9', '.', 'u', 'U', 'l', 'L', 'x', 'X', 'e', 'E', 'f', 'F':\r\n        Result := True;\r\n      else\r\n        Result := False;\r\n    end;\r\n  end;\r\n\r\nbegin\r\n  inc(Run);\r\n  fTokenID := tkNumber;\r\n  while IsNumberChar do\r\n  begin\r\n    case FLine[Run] of\r\n      '.':\r\n        if FLine[Run + 1] = '.' then break;\r\n    end;\r\n    inc(Run);\r\n  end;\r\nend;\r\n\r\nprocedure TSynModelicaSyn.OrSymbolProc;\r\nbegin\r\n  Inc(Run);\r\n  fTokenID := tkSymbol;\r\n  if CharInSet(fLine[Run], ['=', '|']) then\r\n    Inc(Run);\r\nend;\r\n\r\nprocedure TSynModelicaSyn.PlusProc;\r\nbegin\r\n  Inc(Run);\r\n  fTokenID := tkSymbol;\r\n  if CharInSet(fLine[Run], ['=', '+']) then\r\n    Inc(Run);\r\nend;\r\n\r\nprocedure TSynModelicaSyn.PointProc;\r\nbegin\r\n  Inc(Run);\r\n  fTokenID := tkSymbol;\r\n  if (fLine[Run] = '.') and (fLine[Run + 1] = '.') then\r\n    Inc(Run, 2);\r\nend;\r\n\r\nprocedure TSynModelicaSyn.SlashProc;\r\nbegin\r\n  Inc(Run);\r\n  case fLine[Run] of\r\n    '/':\r\n      begin\r\n        fTokenID := tkComment;\r\n        repeat\r\n          Inc(Run);\r\n        until IsLineEnd(Run);\r\n      end;\r\n    '*':\r\n      begin\r\n        fRange := rsComment;\r\n        inc(Run);\r\n        if IsLineEnd(Run) then\r\n          fTokenID := tkComment\r\n        else\r\n          AnsiCProc;\r\n      end;\r\n  else\r\n    fTokenID := tkSymbol;\r\n    if fLine[Run] = '=' then\r\n      Inc(Run);\r\n  end;\r\nend;\r\n\r\nprocedure TSynModelicaSyn.SpaceProc;\r\nbegin\r\n  fTokenID := tkSpace;\r\n  repeat\r\n    Inc(Run);\r\n  until (fLine[Run] > #32) or IsLineEnd(Run);\r\nend;\r\n\r\nprocedure TSynModelicaSyn.StringProc;\r\nbegin\r\n  fRange := rsString34;\r\n  Inc(Run);\r\n  if IsLineEnd(Run) then\r\n    fTokenID := tkString\r\n  else\r\n    String34Proc;\r\nend;\r\n\r\nprocedure TSynModelicaSyn.SymbolProc;\r\nbegin\r\n  Inc(Run);\r\n  fTokenId := tkSymbol;\r\nend;\r\n\r\nprocedure TSynModelicaSyn.SymbolProcWithEqual;\r\nbegin\r\n  Inc(Run);\r\n  fTokenID := tkSymbol;\r\n  if fLine[Run] = '=' then\r\n    Inc(Run);\r\nend;\r\n\r\nprocedure TSynModelicaSyn.UnknownProc;\r\nbegin\r\n  inc(Run);\r\n  fTokenID := tkUnknown;\r\nend;\r\n\r\nprocedure TSynModelicaSyn.AnsiCProc;\r\nbegin\r\n  case fLine[Run] of\r\n     #0: NullProc;\r\n    #10: LFProc;\r\n    #13: CRProc;\r\n  else\r\n    fTokenID := tkComment;\r\n    repeat\r\n      if (fLine[Run] = '*') and (fLine[Run + 1] = '/') then begin\r\n        inc(Run, 2);\r\n        fRange := rsUnknown;\r\n        break;\r\n      end;\r\n      Inc(Run);\r\n    until IsLineEnd(Run);\r\n  end;\r\nend;\r\n\r\nprocedure TSynModelicaSyn.String39Proc;\r\nbegin\r\n  case fLine[Run] of\r\n     #0: NullProc;\r\n    #10: LFProc;\r\n    #13: CRProc;\r\n  else\r\n    fTokenID := tkString;\r\n    repeat\r\n      if fLine[Run] = #39 then begin\r\n        inc(Run);\r\n        fRange := rsUnknown;\r\n        break;\r\n      end;\r\n      Inc(Run);\r\n    until IsLineEnd(Run);\r\n  end;\r\nend;\r\n\r\nprocedure TSynModelicaSyn.String34Proc;\r\nbegin\r\n  case fLine[Run] of\r\n     #0: NullProc;\r\n    #10: LFProc;\r\n    #13: CRProc;\r\n  else\r\n    fTokenID := tkString;\r\n    repeat\r\n      case fLine[Run] of\r\n        #34:\r\n          begin\r\n            Inc(Run);\r\n            fRange := rsUnknown;\r\n            break;\r\n          end;\r\n        #92:\r\n          begin\r\n            Inc(Run);\r\n            if fLine[Run] = #34 then\r\n              Inc(Run);\r\n          end;\r\n      else\r\n        Inc(Run);\r\n      end;\r\n    until IsLineEnd(Run);\r\n  end;\r\nend;\r\n\r\nprocedure TSynModelicaSyn.Next;\r\nbegin\r\n  fTokenPos := Run;\r\n  case fRange of\r\n    rsComment: AnsiCProc;\r\n    rsString39: String39Proc;\r\n    rsString34: String34Proc;\r\n  else\r\n    fRange := rsUnknown;\r\n    case fLine[Run] of\r\n      '&': AndSymbolProc;\r\n      #39: AsciiCharProc;\r\n      #13: CRProc;\r\n      ':': ColonProc;\r\n      '#': DirectiveProc;\r\n      '>': GreaterProc;\r\n      'A'..'Z', 'a'..'z', '_': IdentProc;\r\n      #10: LFProc;\r\n      '<': LowerProc;\r\n      '-': MinusProc;\r\n      #0: NullProc;\r\n      '0'..'9': NumberProc;\r\n      '|': OrSymbolProc;\r\n      '+': PlusProc;\r\n      '.': PointProc;\r\n      '/': SlashProc;\r\n      #1..#9, #11, #12, #14..#32: SpaceProc;\r\n      #34: StringProc;\r\n      '~', '[', ']', '@', '{', '}', '(', ')', ';', ',': SymbolProc;\r\n      '*', '^', '=', '%', '!': SymbolProcWithEqual;\r\n      else UnknownProc;\r\n    end;\r\n  end;\r\n  inherited;\r\nend;\r\n\r\nfunction TSynModelicaSyn.GetDefaultAttribute(Index: integer): TSynHighlighterAttributes;\r\nbegin\r\n  case Index of\r\n    SYN_ATTR_COMMENT: Result := fCommentAttri;\r\n    SYN_ATTR_IDENTIFIER: Result := fIdentifierAttri;\r\n    SYN_ATTR_KEYWORD: Result := fKeyAttri;\r\n    SYN_ATTR_STRING: Result := fStringAttri;\r\n    SYN_ATTR_WHITESPACE: Result := fSpaceAttri;\r\n    SYN_ATTR_SYMBOL: Result := fSymbolAttri;\r\n  else\r\n    Result := nil;\r\n  end;\r\nend;\r\n\r\nfunction TSynModelicaSyn.GetEol: boolean;\r\nbegin\r\n  Result := Run = fLineLen + 1;\r\nend;\r\n\r\nfunction TSynModelicaSyn.GetRange: Pointer;\r\nbegin\r\n  Result := Pointer(fRange);\r\nend;\r\n\r\nfunction TSynModelicaSyn.GetTokenID: TtkTokenKind;\r\nbegin\r\n  Result := fTokenId;\r\nend;\r\n\r\nfunction TSynModelicaSyn.GetTokenAttribute: TSynHighlighterAttributes;\r\nbegin\r\n  case GetTokenID of\r\n    tkComment: Result := fCommentAttri;\r\n    tkDirective: Result := fDirectiveAttri;\r\n    tkIdentifier: Result := fIdentifierAttri;\r\n    tkKey: Result := fKeyAttri;\r\n    tkNumber: Result := fNumberAttri;\r\n    tkSpace: Result := fSpaceAttri;\r\n    tkString: Result := fStringAttri;\r\n    tkSymbol: Result := fSymbolAttri;\r\n    tkUnknown: Result := fIdentifierAttri;\r\n  else\r\n    Result := nil;\r\n  end;\r\nend;\r\n\r\nfunction TSynModelicaSyn.GetTokenKind: integer;\r\nbegin\r\n  Result := Ord(fTokenId);\r\nend;\r\n\r\nprocedure TSynModelicaSyn.ResetRange;\r\nbegin\r\n  fRange := rsUnknown;\r\nend;\r\n\r\nprocedure TSynModelicaSyn.SetRange(Value: Pointer);\r\nbegin\r\n  fRange := TRangeState(Value);\r\nend;\r\n\r\nfunction TSynModelicaSyn.IsFilterStored: Boolean;\r\nbegin\r\n  Result := fDefaultFilter <> SYNS_FilterModelica;\r\nend;\r\n\r\nclass function TSynModelicaSyn.GetLanguageName: string;\r\nbegin\r\n  Result := SYNS_LangModelica;\r\nend;\r\n\r\nclass function TSynModelicaSyn.GetFriendlyLanguageName: UnicodeString;\r\nbegin\r\n  Result := SYNS_FriendlyLangModelica;\r\nend;\r\n\r\ninitialization\r\n{$IFNDEF SYN_CPPB_1}\r\n  RegisterPlaceableHighlighter(TSynModelicaSyn);\r\n{$ENDIF}\r\nend.\r\n"
  },
  {
    "path": "External/SynEdit/Source/SynHighlighterMsg.pas",
    "content": "{-------------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nCode template generated with SynGen.\r\nThe original code is: SynHighlighterMsg.pas, released 2001-10-03.\r\nDescription: SynGen Msg file highlighter\r\nThe initial author of this file is P.L. Polak.\r\nCopyright (c) 2001, all rights reserved.\r\nUnicode translation by Mal Hrz.\r\n\r\nContributors to the SynEdit and mwEdit projects are listed in the\r\nContributors.txt file.\r\n\r\nAlternatively, the contents of this file may be used under the terms of the\r\nGNU General Public License Version 2 or later (the \"GPL\"), in which case\r\nthe provisions of the GPL are applicable instead of those above.\r\nIf you wish to allow use of your version of this file only under the terms\r\nof the GPL and not to allow others to use your version of this file\r\nunder the MPL, indicate your decision by deleting the provisions above and\r\nreplace them with the notice and other provisions required by the GPL.\r\nIf you do not delete the provisions above, a recipient may use your version\r\nof this file under either the MPL or the GPL.\r\n\r\n$Id: SynHighlighterMsg.pas,v 1.8.2.6 2008/09/14 16:25:00 maelh Exp $\r\n\r\nYou may retrieve the latest version of this file at the SynEdit home page,\r\nlocated at http://SynEdit.SourceForge.net\r\n\r\n-------------------------------------------------------------------------------}\r\n\r\n{$IFNDEF QSYNHIGHLIGHTERMSG}\r\nunit SynHighlighterMsg;\r\n{$ENDIF}\r\n\r\n{$I SynEdit.inc}\r\n\r\ninterface\r\n\r\nuses\r\n{$IFDEF SYN_CLX}\r\n  QGraphics,\r\n  QSynEditTypes,\r\n  QSynEditHighlighter,\r\n  QSynUnicode,\r\n{$ELSE}\r\n  Graphics,\r\n  SynEditTypes,\r\n  SynEditHighlighter,\r\n  SynUnicode,\r\n{$ENDIF}\r\n  SysUtils,\r\n  Classes;\r\n\r\ntype\r\n  TtkTokenKind = (\r\n    tkComment,\r\n    tkIdentifier,\r\n    tkKey,\r\n    tkNull,\r\n    tkSpace,\r\n    tkString,\r\n    tkSymbol,\r\n    tkTerminator,\r\n    tkUnknown);\r\n\r\n  TRangeState = (rsUnKnown, rsBraceComment, rsString);\r\n\r\n  PIdentFuncTableFunc = ^TIdentFuncTableFunc;\r\n  TIdentFuncTableFunc = function (Index: Integer): TtkTokenKind of object;\r\n\r\n  TSynMsgSyn = class(TSynCustomHighlighter)\r\n  private\r\n    fRange: TRangeState;\r\n    fTokenID: TtkTokenKind;\r\n    fIdentFuncTable: array[0..6] of TIdentFuncTableFunc;\r\n    fCommentAttri: TSynHighlighterAttributes;\r\n    fIdentifierAttri: TSynHighlighterAttributes;\r\n    fKeyAttri: TSynHighlighterAttributes;\r\n    fSpaceAttri: TSynHighlighterAttributes;\r\n    fStringAttri: TSynHighlighterAttributes;\r\n    fSymbolAttri: TSynHighlighterAttributes;\r\n    fTerminatorAttri: TSynHighlighterAttributes;\r\n    function AltFunc(Index: Integer): TtkTokenKind;\r\n    function FuncBeginproc(Index: Integer): TtkTokenKind;\r\n    function FuncChars(Index: Integer): TtkTokenKind;\r\n    function FuncEnclosedby(Index: Integer): TtkTokenKind;\r\n    function FuncEndproc(Index: Integer): TtkTokenKind;\r\n    function FuncKeys(Index: Integer): TtkTokenKind;\r\n    function FuncSamplesource(Index: Integer): TtkTokenKind;\r\n    function FuncTokentypes(Index: Integer): TtkTokenKind;\r\n    function HashKey(Str: PWideChar): Cardinal;\r\n    function IdentKind(MayBe: PWideChar): TtkTokenKind;\r\n    procedure InitIdent;\r\n    procedure IdentProc;\r\n    procedure SymbolProc;\r\n    procedure TerminatorProc;\r\n    procedure UnknownProc;\r\n    procedure NullProc;\r\n    procedure SpaceProc;\r\n    procedure CRProc;\r\n    procedure LFProc;\r\n    procedure BraceCommentOpenProc;\r\n    procedure BraceCommentProc;\r\n    procedure StringOpenProc;\r\n    procedure StringProc;\r\n  protected\r\n    function GetSampleSource: UnicodeString; override;\r\n    function IsFilterStored: Boolean; override;\r\n  public\r\n    constructor Create(AOwner: TComponent); override;\r\n    class function GetLanguageName: string; override;\r\n    class function GetFriendlyLanguageName: UnicodeString; override;\r\n    function GetRange: Pointer; override;\r\n    procedure ResetRange; override;\r\n    procedure SetRange(Value: Pointer); override;\r\n    function GetDefaultAttribute(Index: integer): TSynHighlighterAttributes; override;\r\n    function GetEol: Boolean; override;\r\n    function GetTokenID: TtkTokenKind;\r\n    function GetTokenAttribute: TSynHighlighterAttributes; override;\r\n    function GetTokenKind: integer; override;\r\n    function IsIdentChar(AChar: WideChar): Boolean; override;\r\n    procedure Next; override;\r\n  published\r\n    property CommentAttri: TSynHighlighterAttributes read fCommentAttri write fCommentAttri;\r\n    property IdentifierAttri: TSynHighlighterAttributes read fIdentifierAttri write fIdentifierAttri;\r\n    property KeyAttri: TSynHighlighterAttributes read fKeyAttri write fKeyAttri;\r\n    property SpaceAttri: TSynHighlighterAttributes read fSpaceAttri write fSpaceAttri;\r\n    property StringAttri: TSynHighlighterAttributes read fStringAttri write fStringAttri;\r\n    property SymbolAttri: TSynHighlighterAttributes read fSymbolAttri write fSymbolAttri;\r\n    property TerminatorAttri: TSynHighlighterAttributes read fTerminatorAttri write fTerminatorAttri;\r\n  end;\r\n\r\nimplementation\r\n\r\nuses\r\n{$IFDEF SYN_CLX}\r\n  QSynEditStrConst;\r\n{$ELSE}\r\n  SynEditStrConst;\r\n{$ENDIF}\r\n\r\nconst\r\n  KeyWords: array[0..6] of UnicodeString = (\r\n    'beginproc', 'chars', 'enclosedby', 'endproc', 'keys', 'samplesource', \r\n    'tokentypes' \r\n  );\r\n\r\n  KeyIndices: array[0..6] of Integer = (\r\n    2, 1, 6, 4, 0, 5, 3 \r\n  );\r\n\r\n{$Q-}\r\nfunction TSynMsgSyn.HashKey(Str: PWideChar): Cardinal;\r\nbegin\r\n  Result := 0;\r\n  while IsIdentChar(Str^) do\r\n  begin\r\n    Result := Result * 182 + Ord(Str^);\r\n    inc(Str);\r\n  end;\r\n  Result := Result mod 7;\r\n  fStringLen := Str - fToIdent;\r\nend;\r\n{$Q+}\r\n\r\nfunction TSynMsgSyn.IdentKind(MayBe: PWideChar): TtkTokenKind;\r\nvar\r\n  Key: Cardinal;\r\nbegin\r\n  fToIdent := MayBe;\r\n  Key := HashKey(MayBe);\r\n  if Key <= High(fIdentFuncTable) then\r\n    Result := fIdentFuncTable[Key](KeyIndices[Key])\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nprocedure TSynMsgSyn.InitIdent;\r\nvar\r\n  i: Integer;\r\nbegin\r\n  for i := Low(fIdentFuncTable) to High(fIdentFuncTable) do\r\n    if KeyIndices[i] = -1 then\r\n      fIdentFuncTable[i] := AltFunc;\r\n\r\n  fIdentFuncTable[4] := FuncBeginproc;\r\n  fIdentFuncTable[1] := FuncChars;\r\n  fIdentFuncTable[0] := FuncEnclosedby;\r\n  fIdentFuncTable[6] := FuncEndproc;\r\n  fIdentFuncTable[3] := FuncKeys;\r\n  fIdentFuncTable[5] := FuncSamplesource;\r\n  fIdentFuncTable[2] := FuncTokentypes;\r\nend;\r\n\r\nfunction TSynMsgSyn.AltFunc(Index: Integer): TtkTokenKind;\r\nbegin\r\n  Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynMsgSyn.FuncBeginproc(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynMsgSyn.FuncChars(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynMsgSyn.FuncEnclosedby(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynMsgSyn.FuncEndproc(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynMsgSyn.FuncKeys(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynMsgSyn.FuncSamplesource(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynMsgSyn.FuncTokentypes(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nprocedure TSynMsgSyn.SpaceProc;\r\nbegin\r\n  inc(Run);\r\n  fTokenID := tkSpace;\r\n  while (FLine[Run] <= #32) and not IsLineEnd(Run) do inc(Run);\r\nend;\r\n\r\nprocedure TSynMsgSyn.NullProc;\r\nbegin\r\n  fTokenID := tkNull;\r\n  inc(Run);\r\nend;\r\n\r\nprocedure TSynMsgSyn.CRProc;\r\nbegin\r\n  fTokenID := tkSpace;\r\n  inc(Run);\r\n  if fLine[Run] = #10 then\r\n    inc(Run);\r\nend;\r\n\r\nprocedure TSynMsgSyn.LFProc;\r\nbegin\r\n  fTokenID := tkSpace;\r\n  inc(Run);\r\nend;\r\n\r\nprocedure TSynMsgSyn.BraceCommentOpenProc;\r\nbegin\r\n  Inc(Run);\r\n  fRange := rsBraceComment;\r\n  BraceCommentProc;\r\n  fTokenID := tkComment;\r\nend;\r\n\r\nprocedure TSynMsgSyn.BraceCommentProc;\r\nbegin\r\n  case fLine[Run] of\r\n     #0: NullProc;\r\n    #10: LFProc;\r\n    #13: CRProc;\r\n  else\r\n    begin\r\n      fTokenID := tkComment;\r\n      repeat\r\n        if (fLine[Run] = '}') then\r\n        begin\r\n          Inc(Run, 1);\r\n          fRange := rsUnKnown;\r\n          Break;\r\n        end;\r\n        if not IsLineEnd(Run) then\r\n          Inc(Run);\r\n      until IsLineEnd(Run);\r\n    end;\r\n  end;\r\nend;\r\n\r\nprocedure TSynMsgSyn.StringOpenProc;\r\nbegin\r\n  Inc(Run);\r\n  fRange := rsString;\r\n  StringProc;\r\n  fTokenID := tkString;\r\nend;\r\n\r\nprocedure TSynMsgSyn.StringProc;\r\nbegin\r\n  fTokenID := tkString;\r\n  repeat\r\n    if (fLine[Run] = '''') then\r\n    begin\r\n      Inc(Run, 1);\r\n      fRange := rsUnKnown;\r\n      Break;\r\n    end;\r\n    if not IsLineEnd(Run) then\r\n      Inc(Run);\r\n  until IsLineEnd(Run);\r\nend;\r\n\r\nconstructor TSynMsgSyn.Create(AOwner: TComponent);\r\nbegin\r\n  inherited Create(AOwner);\r\n\r\n  fCaseSensitive := False;\r\n\r\n  fCommentAttri := TSynHighLighterAttributes.Create(SYNS_AttrComment, SYNS_FriendlyAttrComment);\r\n  fCommentAttri.Style := [fsItalic];\r\n  fCommentAttri.Foreground := clNavy;\r\n  AddAttribute(fCommentAttri);\r\n\r\n  fIdentifierAttri := TSynHighLighterAttributes.Create(SYNS_AttrIdentifier, SYNS_FriendlyAttrIdentifier);\r\n  AddAttribute(fIdentifierAttri);\r\n\r\n  fKeyAttri := TSynHighLighterAttributes.Create(SYNS_AttrReservedWord, SYNS_FriendlyAttrReservedWord);\r\n  fKeyAttri.Style := [fsBold];\r\n  AddAttribute(fKeyAttri);\r\n\r\n  fSpaceAttri := TSynHighLighterAttributes.Create(SYNS_AttrSpace, SYNS_FriendlyAttrSpace);\r\n  AddAttribute(fSpaceAttri);\r\n\r\n  fStringAttri := TSynHighLighterAttributes.Create(SYNS_AttrString, SYNS_FriendlyAttrString);\r\n  AddAttribute(fStringAttri);\r\n\r\n  fSymbolAttri := TSynHighLighterAttributes.Create(SYNS_AttrSymbol, SYNS_FriendlyAttrSymbol);\r\n  AddAttribute(fSymbolAttri);\r\n\r\n  fTerminatorAttri := TSynHighLighterAttributes.Create(SYNS_AttrTerminator, SYNS_FriendlyAttrTerminator);\r\n  AddAttribute(fTerminatorAttri);\r\n\r\n  SetAttributesOnChange(DefHighlightChange);\r\n  InitIdent;\r\n  fDefaultFilter := SYNS_FilterSynGenMsgfiles;\r\n  fRange := rsUnknown;\r\nend;\r\n\r\nprocedure TSynMsgSyn.IdentProc;\r\nbegin\r\n  fTokenID := IdentKind(fLine + Run);\r\n  inc(Run, fStringLen);\r\n  while IsIdentChar(fLine[Run]) do\r\n    Inc(Run);\r\nend;\r\n\r\nprocedure TSynMsgSyn.SymbolProc;\r\nbegin\r\n  Inc(Run);\r\n  fTokenID := tkSymbol;\r\nend;\r\n\r\nprocedure TSynMsgSyn.TerminatorProc;\r\nbegin\r\n  Inc(Run);\r\n  if (fLine[Run] = '>') and (fLine[Run + 1] = '<') and (fLine[Run + 2] = '|') then\r\n  begin\r\n    fTokenID := tkTerminator;\r\n    Inc(Run, 3);\r\n  end\r\n  else\r\n    fTokenID := tkSymbol;\r\nend;\r\n\r\nprocedure TSynMsgSyn.UnknownProc;\r\nbegin\r\n  inc(Run);\r\n  fTokenID := tkUnknown;\r\nend;\r\n\r\nprocedure TSynMsgSyn.Next;\r\nbegin\r\n  fTokenPos := Run;\r\n  case fRange of\r\n    rsBraceComment: BraceCommentProc;\r\n  else\r\n    begin\r\n      fRange := rsUnknown;\r\n      case fLine[Run] of\r\n        #0: NullProc;\r\n        #10: LFProc;\r\n        #13: CRProc;\r\n        '{': BraceCommentOpenProc;\r\n        '''': StringOpenProc;\r\n        #1..#9, #11, #12, #14..#32: SpaceProc;\r\n        'A'..'Z', 'a'..'z', '_': IdentProc;\r\n        '-', '+', '*', '/', '\\', ',', '\"', '[', ']', ':', ';': SymbolProc;\r\n        '|': TerminatorProc;\r\n        else UnknownProc;\r\n      end;\r\n    end;\r\n  end;\r\n  inherited;\r\nend;\r\n\r\nfunction TSynMsgSyn.GetDefaultAttribute(Index: integer): TSynHighLighterAttributes;\r\nbegin\r\n  case Index of\r\n    SYN_ATTR_COMMENT: Result := fCommentAttri;\r\n    SYN_ATTR_IDENTIFIER: Result := fIdentifierAttri;\r\n    SYN_ATTR_KEYWORD: Result := fKeyAttri;\r\n    SYN_ATTR_STRING: Result := fStringAttri;\r\n    SYN_ATTR_WHITESPACE: Result := fSpaceAttri;\r\n    SYN_ATTR_SYMBOL: Result := fSymbolAttri;\r\n  else\r\n    Result := nil;\r\n  end;\r\nend;\r\n\r\nfunction TSynMsgSyn.GetEol: Boolean;\r\nbegin\r\n  Result := Run = fLineLen + 1;\r\nend;\r\n\r\nfunction TSynMsgSyn.GetTokenID: TtkTokenKind;\r\nbegin\r\n  Result := fTokenId;\r\nend;\r\n\r\nfunction TSynMsgSyn.GetTokenAttribute: TSynHighLighterAttributes;\r\nbegin\r\n  case GetTokenID of\r\n    tkComment: Result := fCommentAttri;\r\n    tkIdentifier: Result := fIdentifierAttri;\r\n    tkKey: Result := fKeyAttri;\r\n    tkSpace: Result := fSpaceAttri;\r\n    tkString: Result := fStringAttri;\r\n    tkSymbol: Result := fSymbolAttri;\r\n    tkTerminator: Result := fTerminatorAttri;\r\n    tkUnknown: Result := fIdentifierAttri;\r\n  else\r\n    Result := nil;\r\n  end;\r\nend;\r\n\r\nfunction TSynMsgSyn.GetTokenKind: integer;\r\nbegin\r\n  Result := Ord(fTokenId);\r\nend;\r\n\r\nfunction TSynMsgSyn.GetSampleSource: UnicodeString;\r\nbegin\r\n  Result := 'TSynSampleSyn   {first identifier is the class name }'#13#10 +\r\n            'tk              {second identifier is the prefix }'#13#10 +\r\n            'IdentStart ''a''..''z'':: ''a''..''z''::'#13#10 +\r\n            'KEYS'#13#10 +\r\n            'Sample'#13#10 +\r\n            'Source'#13#10 +\r\n            '|><|';\r\nend;\r\n\r\nfunction TSynMsgSyn.IsFilterStored: Boolean;\r\nbegin\r\n  Result := fDefaultFilter <> SYNS_FilterSynGenMsgfiles;\r\nend;\r\n\r\nfunction TSynMsgSyn.IsIdentChar(AChar: WideChar): Boolean;\r\nbegin\r\n  case AChar of\r\n    '_', 'A'..'Z', 'a'..'z':\r\n      Result := True;\r\n    else\r\n      Result := False;\r\n  end;\r\nend;\r\n\r\nclass function TSynMsgSyn.GetLanguageName: string;\r\nbegin\r\n  Result := SYNS_LangSynGenMsgfiles;\r\nend;\r\n\r\nprocedure TSynMsgSyn.ResetRange;\r\nbegin\r\n  fRange := rsUnknown;\r\nend;\r\n\r\nprocedure TSynMsgSyn.SetRange(Value: Pointer);\r\nbegin\r\n  fRange := TRangeState(Value);\r\nend;\r\n\r\nfunction TSynMsgSyn.GetRange: Pointer;\r\nbegin\r\n  Result := Pointer(fRange);\r\nend;\r\n\r\nclass function TSynMsgSyn.GetFriendlyLanguageName: UnicodeString;\r\nbegin\r\n  Result := SYNS_FriendlyLangSynGenMsgfiles;\r\nend;\r\n\r\ninitialization\r\n{$IFNDEF SYN_CPPB_1}\r\n  RegisterPlaceableHighlighter(TSynMsgSyn);\r\n{$ENDIF}\r\nend.\r\n"
  },
  {
    "path": "External/SynEdit/Source/SynHighlighterMulti.pas",
    "content": "{-------------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: SynHighlighterMulti.pas, released 2000-06-23.\r\nThe Original Code is based on mwMultiSyn.pas by Willo van der Merwe, part of the\r\nmwEdit component suite.\r\nUnicode translation by Mal Hrz.\r\n\r\nContributors to the SynEdit and mwEdit projects are listed in the\r\nContributors.txt file.\r\n\r\nAlternatively, the contents of this file may be used under the terms of the\r\nGNU General Public License Version 2 or later (the \"GPL\"), in which case\r\nthe provisions of the GPL are applicable instead of those above.\r\nIf you wish to allow use of your version of this file only under the terms\r\nof the GPL and not to allow others to use your version of this file\r\nunder the MPL, indicate your decision by deleting the provisions above and\r\nreplace them with the notice and other provisions required by the GPL.\r\nIf you do not delete the provisions above, a recipient may use your version\r\nof this file under either the MPL or the GPL.\r\n\r\n$Id: SynHighlighterMulti.pas,v 1.34.2.11 2008/09/14 16:25:00 maelh Exp $\r\n\r\nYou may retrieve the latest version of this file at the SynEdit home page,\r\nlocated at http://SynEdit.SourceForge.net\r\n\r\nKnown Issues:\r\n-------------------------------------------------------------------------------}\r\n{\r\n@abstract(Provides a Multiple-highlighter syntax highlighter for SynEdit)\r\n@author(Willo van der Merwe , converted to SynEdit by David Muir )\r\n@created(1999, converted to SynEdit 2000-06-23)\r\n@lastmod(2000-06-23)\r\nThe SynHighlighterMulti unit provides SynEdit with a multiple-highlighter syntax highlighter.\r\nThis highlighter can be used to highlight text in which several languages are present, such as HTML.\r\nFor example, in HTML as well as HTML tags there can also be JavaScript and/or VBScript present.\r\n}\r\n\r\n{$IFNDEF QSYNHIGHLIGHTERMULTI}\r\nunit SynHighlighterMulti;\r\n{$ENDIF}\r\n\r\n{$I SynEdit.inc}\r\n\r\ninterface\r\n\r\nuses\r\n{$IFDEF SYN_CLX}\r\n  QSynEditTypes,\r\n  QSynEditHighlighter,\r\n  QSynUnicode,  \r\n{$ELSE}\r\n  Windows,\r\n  SynEditTypes,\r\n  SynEditHighlighter,\r\n  SynUnicode,\r\n{$ENDIF}\r\n  Classes;\r\n\r\ntype\r\n  TOnCheckMarker = procedure (Sender: TObject; var StartPos, MarkerLen: Integer;\r\n    var MarkerText: UnicodeString; Line: Integer) of object;\r\n\r\n  TScheme = class(TCollectionItem)\r\n  private\r\n    fEndExpr: UnicodeString;\r\n    fStartExpr: UnicodeString;\r\n    fHighlighter: TSynCustomHighLighter;\r\n    fMarkerAttri: TSynHighlighterAttributes;\r\n    fSchemeName: TComponentName;\r\n    fCaseSensitive: Boolean;\r\n    fOnCheckStartMarker: TOnCheckMarker;\r\n    fOnCheckEndMarker: TOnCheckMarker;\r\n    function ConvertExpression(const Value: UnicodeString): UnicodeString;\r\n    procedure MarkerAttriChanged(Sender: TObject);\r\n    procedure SetMarkerAttri(const Value: TSynHighlighterAttributes);\r\n    procedure SetHighlighter(const Value: TSynCustomHighlighter);\r\n    procedure SetEndExpr(const Value: UnicodeString);\r\n    procedure SetStartExpr(const Value: UnicodeString);\r\n    procedure SetCaseSensitive(const Value: Boolean);\r\n  protected\r\n    procedure DefineProperties(Filer: TFiler); override;\r\n{$IFDEF SYN_COMPILER_3_UP}\r\n    function GetDisplayName: string; override;\r\n    procedure SetDisplayName(const Value: string); override;\r\n{$ENDIF}\r\n  public\r\n    constructor Create(Collection: TCollection); override;\r\n    destructor Destroy; override;\r\n  published\r\n    property CaseSensitive: Boolean read fCaseSensitive write SetCaseSensitive\r\n      default True;\r\n    property StartExpr: UnicodeString read fStartExpr write SetStartExpr;\r\n    property EndExpr: UnicodeString read fEndExpr write SetEndExpr;\r\n    property Highlighter: TSynCustomHighlighter read fHighlighter\r\n      write SetHighlighter;\r\n    property MarkerAttri: TSynHighlighterAttributes read fMarkerAttri\r\n      write SetMarkerAttri;\r\n    property SchemeName: TComponentName read fSchemeName write fSchemeName;\r\n    property OnCheckStartMarker: TOnCheckMarker read fOnCheckStartMarker write fOnCheckStartMarker;\r\n    property OnCheckEndMarker: TOnCheckMarker read fOnCheckEndMarker write fOnCheckEndMarker;\r\n  end;\r\n\r\n  TgmSchemeClass = class of TScheme;\r\n\r\n  TSynMultiSyn = class;\r\n\r\n  TSchemes = class(TCollection)\r\n  private\r\n    fOwner: TSynMultiSyn;\r\n    function GetItems(Index: integer): TScheme;\r\n    procedure SetItems(Index: integer; const Value: TScheme);\r\n{$IFDEF SYN_COMPILER_3_UP}\r\n  protected\r\n    function GetOwner: TPersistent; override;\r\n    procedure Update(Item: TCollectionItem); override;\r\n{$ENDIF}\r\n  public\r\n    constructor Create(aOwner: TSynMultiSyn);\r\n    property Items[aIndex: integer]: TScheme read GetItems write SetItems;\r\n      default;\r\n  end;\r\n\r\n  TMarker = class\r\n  protected\r\n    fScheme: Integer;\r\n    fStartPos: Integer;\r\n    fMarkerLen: Integer;\r\n    fMarkerText: UnicodeString;\r\n    fIsOpenMarker: Boolean;\r\n  public\r\n    constructor Create(aScheme, aStartPos, aMarkerLen: Integer;\r\n      aIsOpenMarker: Boolean; const aMarkerText: UnicodeString);\r\n  end;\r\n\r\n\r\n  TRangeOperation = (roGet, roSet);\r\n\r\n{$IFDEF SYN_COMPILER_16_UP}\r\n  TRangeUNativeInt = NativeUInt;\r\n{$ELSE}\r\n  TRangeUNativeInt = Cardinal;\r\n{$ENDIF}\r\n  TRangeProc = procedure (Operation: TRangeOperation; var Range: TRangeUNativeInt) of object;\r\n\r\n  TCustomRangeEvent = procedure (Sender: TSynMultiSyn; Operation: TRangeOperation;\r\n    var Range: pointer) of object;\r\n\r\n  {\r\n  * Usage notes *\r\n    If you don't need to nest MultiSyns as Schemes, just as DefaultHighlighter,\r\n  you can nest up to 2 MultiSyns, each of them containing up to 7 Schemes. This\r\n  is the way MultiSyn works best. (implemented in NewRangeProc)\r\n    If you need to use a MultiSyn nested as Scheme, then you can nest up to\r\n  5 MultiSyns, but Ranges aren't persisted across occurrences of Schemes that\r\n  have multiple lines. (implemented in OldRangeProc)\r\n    Clarification: when I say \"you can nest up to X\" MultiSyns, I mean having\r\n  X+1 levels of MultiSyns.\r\n\r\n  MultiSyn doesn't work by default with dynamic highlighters; you must use\r\n  OnCustomRange. This is because dynamic highlighters' Ranges are pointers,\r\n  but MultiSyn needs Ranges to be ordinal values smaller than 16 (4 bits).\r\n\r\n  OnCustomRange:\r\n    When Operation is roGet, user should store in the 'Range' parameter the\r\n    information to allow restoring the current state of the highlighter.\r\n    When Operation is roSet, user should restore highlighter state (CurrScheme,\r\n    DefaultHighlighter.Range and, if the case, Schemes[CurrScheme].Range)\r\n    according to 'Range' value.\r\n  CurrScheme:\r\n    Index of the scheme that is currently parsing. DefaultHighlighter maps to -1.\r\n\r\n  * Implementation notes *\r\n  fTmpRange:\r\n    Using the OldRangeProc, fTmpRange was the only way to restore the Range\r\n    of the DefaultHighlighter after a Scheme spanned across multiple lines.\r\n    With the NewRangeProc, the only use for it is restoring DefaultHighLighter's\r\n    Range in case a nested MultiSyn uses the highlighter too.\r\n  }\r\n\r\n  TSynMultiSyn = class(TSynCustomHighlighter)\r\n  private\r\n    fRangeProc: TRangeProc;\r\n    fDefaultLanguageName: string;\r\n    fMarkers: TList;\r\n    fMarker: TMarker;\r\n    fNextMarker: integer;\r\n    fCurrScheme: integer;\r\n    fTmpRange: pointer;\r\n    fOnCustomRange: TCustomRangeEvent;\r\n    fLineStr: UnicodeString;\r\n    procedure SetDefaultHighlighter(const Value: TSynCustomHighLighter);\r\n    function GetMarkers(Index: Integer): TMarker;\r\n    property Markers[Index: Integer]: TMarker read GetMarkers;\r\n    procedure DoCheckMarker(Scheme:TScheme; StartPos, MarkerLen: Integer;\r\n      const MarkerText: UnicodeString; Start: Boolean; Line: Integer);\r\n    procedure SetOnCustomRange(const Value: TCustomRangeEvent);\r\n  protected\r\n    fSchemes: TSchemes;\r\n    fDefaultHighlighter: TSynCustomHighLighter;\r\n    fLineNumber: Integer;\r\n    fSampleSource: UnicodeString;\r\n    procedure Loaded; override;\r\n    procedure SetSchemes(const Value: TSchemes);\r\n    procedure ClearMarkers;\r\n    function GetDefaultAttribute(Index: integer): TSynHighlighterAttributes; override;\r\n    function GetAttribCount: integer; override;\r\n    function GetAttribute(Index: integer): TSynHighlighterAttributes; override;\r\n    procedure HookHighlighter(aHL: TSynCustomHighlighter);\r\n    procedure UnhookHighlighter(aHL: TSynCustomHighlighter);\r\n    procedure Notification(aComp: TComponent; aOp: TOperation); override;\r\n    function GetSampleSource: UnicodeString; override;\r\n    procedure SetSampleSource(Value: UnicodeString); override;\r\n    procedure DoSetLine(const Value: UnicodeString; LineNumber: Integer); override;\r\n    //\r\n    procedure OldRangeProc(Operation: TRangeOperation; var Range: TRangeUNativeInt);\r\n    procedure NewRangeProc(Operation: TRangeOperation; var Range: TRangeUNativeInt);\r\n    procedure UserRangeProc(Operation: TRangeOperation; var Range: TRangeUNativeInt);\r\n  public\r\n    class function GetLanguageName: string; override;\r\n    class function GetFriendlyLanguageName: UnicodeString; override;\r\n  public\r\n    constructor Create(AOwner: TComponent); override;\r\n    destructor Destroy; override;\r\n    function GetEol: Boolean; override;\r\n    function GetExpandedToken: UnicodeString; override;\r\n    function GetRange: Pointer; override;\r\n    function GetToken: UnicodeString; override;\r\n    function GetTokenAttribute: TSynHighlighterAttributes; override;\r\n    function GetTokenKind: integer; override;\r\n    procedure Next; override;\r\n    procedure SetRange(Value: Pointer); override;\r\n    procedure ResetRange; override;\r\n    function UpdateRangeProcs: Boolean;\r\n    property CurrScheme: Integer read fCurrScheme write fCurrScheme;\r\n    property CurrLine: UnicodeString read fLineStr;\r\n{$IFNDEF SYN_CLX}\r\n    function LoadFromRegistry(RootKey: HKEY; Key: string): Boolean; override;\r\n    function SaveToRegistry(RootKey: HKEY; Key: string): Boolean; override;\r\n{$ENDIF}\r\n    function IsIdentChar(AChar: WideChar): Boolean; override;\r\n  published\r\n    property Schemes: TSchemes read fSchemes write SetSchemes;\r\n    property DefaultHighlighter: TSynCustomHighLighter read fDefaultHighlighter\r\n      write SetDefaultHighlighter;\r\n    property DefaultLanguageName: string read fDefaultLanguageName\r\n      write fDefaultLanguageName;\r\n    property OnCustomRange: TCustomRangeEvent read fOnCustomRange write SetOnCustomRange;\r\n  end;\r\n\r\nimplementation\r\n\r\nuses\r\n{$IFDEF SYN_CLX}\r\n  QGraphics,\r\n  QSynEditMiscProcs,\r\n  QSynRegExpr,\r\n  QSynEditStrConst,\r\n{$ELSE}\r\n  Graphics,\r\n  SynEditMiscProcs,\r\n  SynRegExpr,\r\n  SynEditStrConst,\r\n{$ENDIF}\r\n  SysUtils;\r\n\r\nprocedure CheckExpression(const Expr: UnicodeString);\r\nvar\r\n  Parser: TRegExpr;\r\nbegin\r\n  Parser := TRegExpr.Create;\r\n  try\r\n    Parser.Expression := Expr;\r\n    try\r\n      Parser.Compile;\r\n    except\r\n      on E: ERegExpr do\r\n      begin\r\n        if E.ErrorCode < 1000 then\r\n          E.Message := Format('\"%s\" is not a valid Regular Expression.'#13'Error (pos %d): %s',\r\n            [Expr, E.CompilerErrorPos, Copy(Parser.ErrorMsg(E.ErrorCode), 16, MaxInt)]);\r\n        raise;\r\n      end;\r\n    end;\r\n  finally\r\n    Parser.Free;\r\n  end;\r\nend;\r\n\r\n{ TMarker }\r\n\r\nconstructor TMarker.Create(aScheme, aStartPos,\r\n  aMarkerLen: Integer; aIsOpenMarker: Boolean; const aMarkerText: UnicodeString);\r\nbegin\r\n  fScheme := aScheme;\r\n  fStartPos := aStartPos;\r\n  fMarkerLen := aMarkerLen;\r\n  fIsOpenMarker := aIsOpenMarker;\r\n  fMarkerText := aMarkerText;\r\nend;\r\n\r\n{ TSynMultiSyn }\r\n\r\nprocedure TSynMultiSyn.ClearMarkers;\r\nvar\r\n  i: Integer;\r\nbegin\r\n  for i := 0 to fMarkers.Count - 1 do\r\n    TObject(fMarkers[i]).Free;\r\n  fMarkers.Clear;\r\nend;\r\n\r\nconstructor TSynMultiSyn.Create(AOwner: TComponent);\r\nbegin\r\n  inherited Create(AOwner);\r\n  fSchemes := TSchemes.Create(Self);\r\n  fCurrScheme := -1;\r\n  fMarkers := TList.Create;\r\n  fRangeProc := NewRangeProc;\r\nend;\r\n\r\ndestructor TSynMultiSyn.Destroy;\r\nbegin\r\n  ClearMarkers;\r\n  { unhook notification handlers }\r\n  Schemes.Clear;\r\n  DefaultHighlighter := nil;\r\n  inherited Destroy;\r\n  fSchemes.Free;\r\n  fMarkers.Free;\r\nend;\r\n\r\nfunction TSynMultiSyn.GetAttribCount: Integer;\r\nvar\r\n  i: Integer;\r\nbegin\r\n  Result := Schemes.Count;\r\n  if DefaultHighlighter <> nil then\r\n    Inc(Result, DefaultHighlighter.AttrCount);\r\n  for i := 0 to Schemes.Count - 1 do\r\n    if Schemes[i].Highlighter <> nil then\r\n      Inc(Result, Schemes[i].Highlighter.AttrCount);\r\nend;\r\n\r\nfunction TSynMultiSyn.GetAttribute(Index: Integer): TSynHighlighterAttributes;\r\nvar\r\n  i: Integer;\r\n  HL: TSynCustomHighlighter;\r\nbegin\r\n  if Index < Schemes.Count then\r\n    Result := Schemes[Index].MarkerAttri\r\n  else\r\n  begin\r\n    Dec(Index, Schemes.Count);\r\n    if DefaultHighlighter <> nil then\r\n      if Index < DefaultHighlighter.AttrCount then\r\n      begin\r\n        Result := DefaultHighlighter.Attribute[Index];\r\n        Exit;\r\n      end\r\n      else\r\n        Dec(Index, DefaultHighlighter.AttrCount);\r\n    for i := 0 to Schemes.Count - 1 do\r\n    begin\r\n      HL := Schemes[i].Highlighter;\r\n      if HL <> nil then\r\n        if Index < HL.AttrCount then\r\n        begin\r\n          Result := HL.Attribute[Index];\r\n          Exit;\r\n        end\r\n        else\r\n          Dec(Index, HL.AttrCount);\r\n    end;\r\n    Result := nil;\r\n  end;\r\nend;\r\n\r\nfunction TSynMultiSyn.GetDefaultAttribute(Index: integer): TSynHighlighterAttributes;\r\nvar\r\n  HL: TSynCustomHighlighter;\r\nbegin\r\n  if (CurrScheme >= 0) and (Schemes[CurrScheme].Highlighter <> nil) then\r\n    HL := Schemes[CurrScheme].Highlighter\r\n  else\r\n    HL := DefaultHighlighter;\r\n  { the typecast to TSynMultiSyn is only necessary because the\r\n  GetDefaultAttribute method is protected.\r\n  And don't worry: this really works }\r\n  if HL <> nil then\r\n    Result := TSynMultiSyn(HL).GetDefaultAttribute(Index)\r\n  else\r\n    Result := nil;\r\nend;\r\n\r\nfunction TSynMultiSyn.GetEol: Boolean;\r\nbegin\r\n  if fMarker <> nil then\r\n    Result := False\r\n  else if fCurrScheme >= 0 then\r\n    Result := Schemes[CurrScheme].Highlighter.GetEol\r\n  else if DefaultHighlighter <> nil then\r\n    Result := DefaultHighlighter.GetEol\r\n  else\r\n    Result := Run > fLineLen + 1;\r\nend;\r\n\r\nclass function TSynMultiSyn.GetLanguageName: string;\r\nbegin\r\n  Result := SYNS_LangGeneralMulti;\r\nend;\r\n\r\nfunction TSynMultiSyn.GetMarkers(Index: integer): TMarker;\r\nbegin\r\n  Result := TMarker(fMarkers[Index]);\r\nend;\r\n\r\nprocedure TSynMultiSyn.OldRangeProc(Operation: TRangeOperation; var Range: TRangeUNativeInt);\r\nconst\r\n  MaxNestedMultiSyn = 6;\r\n  { number of bits of the Range that will be used to store the SchemeIndex }\r\n  SchemeIndexSize = 4;\r\n  MaxSchemeCount = (1 shl SchemeIndexSize) - 1;\r\n  { number of bits of the Range that will be used to store the SchemeRange }\r\n  SchemeRangeSize = 8;\r\n  MaxSchemeRange = (1 shl SchemeRangeSize) - 1;\r\nvar\r\n  iHL: TSynCustomHighlighter;\r\n  iSchemeIndex: cardinal;\r\n  iSchemeRange: cardinal;\r\nbegin\r\n  if Operation = roGet then\r\n  begin\r\n    if (fCurrScheme < 0) then\r\n      iHL := DefaultHighlighter\r\n    else\r\n      iHL := Schemes[fCurrScheme].Highlighter;\r\n    iSchemeIndex := fCurrScheme + 2;\r\n    Assert(iSchemeIndex <= MaxSchemeCount);\r\n    if iHL <> nil then\r\n    begin\r\n      iSchemeRange := cardinal(iHL.GetRange);\r\n      Assert((iSchemeRange <= MaxSchemeRange) or (iHL is TSynMultiSyn));\r\n    end\r\n    else\r\n      iSchemeRange := 0;\r\n    { checks the limit of nested MultiSyns }\r\n    Assert(iSchemeRange shr ((MaxNestedMultiSyn - 1) * SchemeIndexSize + SchemeRangeSize) = 0);\r\n    iSchemeRange := (iSchemeRange shl SchemeIndexSize) or iSchemeIndex;\r\n    Range := iSchemeRange;\r\n  end\r\n  else\r\n  begin\r\n    if Range = 0 then\r\n      Exit;\r\n    iSchemeRange := cardinal(Range);\r\n    fCurrScheme := integer(iSchemeRange and MaxSchemeCount) - 2;\r\n    iSchemeRange := iSchemeRange shr SchemeIndexSize;\r\n    if (CurrScheme < 0) then\r\n    begin\r\n      if DefaultHighlighter <> nil then\r\n        DefaultHighlighter.SetRange(pointer(iSchemeRange));\r\n    end\r\n    else\r\n      Schemes[CurrScheme].Highlighter.SetRange(pointer(iSchemeRange));\r\n  end;\r\nend;\r\n\r\nfunction TSynMultiSyn.GetToken: UnicodeString;\r\nbegin\r\n  if DefaultHighlighter = nil then\r\n    Result := fLineStr\r\n  else\r\n    Result := inherited GetToken;\r\nend;\r\n\r\nfunction TSynMultiSyn.GetTokenAttribute: TSynHighlighterAttributes;\r\nbegin\r\n  if fMarker <> nil then\r\n    Result := Schemes[fMarker.fScheme].MarkerAttri\r\n  else if CurrScheme >= 0 then\r\n    Result := Schemes[CurrScheme].Highlighter.GetTokenAttribute\r\n  else if DefaultHighlighter <> nil then\r\n    Result := DefaultHighlighter.GetTokenAttribute\r\n  else\r\n    Result := nil;\r\nend;\r\n\r\nfunction TSynMultiSyn.GetTokenKind: integer;\r\nbegin\r\n  if fMarker <> nil then\r\n    Result := 0\r\n  else if fCurrScheme >= 0 then\r\n    Result := Schemes[fCurrScheme].Highlighter.GetTokenKind\r\n  else if DefaultHighlighter <> nil then\r\n    Result := DefaultHighlighter.GetTokenKind\r\n  else\r\n    Result := 0;\r\nend;\r\n\r\nprocedure TSynMultiSyn.HookHighlighter(aHL: TSynCustomHighlighter);\r\nbegin\r\n  aHL.FreeNotification(Self);\r\n  aHL.HookAttrChangeEvent(DefHighlightChange);\r\nend;\r\n\r\nprocedure TSynMultiSyn.Next;\r\nvar\r\n  iToken, TmpLine, ExpandedTmpLine: UnicodeString;\r\n  iHL: TSynCustomHighlighter;\r\nbegin\r\n  if DefaultHighlighter = nil then\r\n  begin\r\n    if Run > 0 then\r\n      Inc(Run)\r\n    else\r\n      Run := Length(fLineStr) + 1;\r\n    inherited;\r\n    Exit;\r\n  end;\r\n\r\n  if (fNextMarker < fMarkers.Count) and (Run + 1 >= Markers[fNextMarker].fStartPos) then\r\n  begin\r\n    fMarker := Markers[fNextMarker];\r\n    if fMarker.fIsOpenMarker then\r\n    begin\r\n      fCurrScheme := fMarker.fScheme;\r\n      fTmpRange := DefaultHighlighter.GetRange;\r\n      Schemes[CurrScheme].Highlighter.ResetRange;\r\n    end;\r\n    Inc(fNextMarker);\r\n    fTokenPos := Run;\r\n    Inc(Run, fMarker.fMarkerLen);\r\n    inherited;\r\n    Exit;\r\n  end;\r\n\r\n  if Run = 0 then\r\n  begin\r\n    if CurrScheme >= 0 then\r\n      iHL := Schemes[CurrScheme].Highlighter\r\n    else\r\n      iHL := DefaultHighlighter;\r\n\r\n    if fMarkers.Count = 0 then\r\n      TmpLine := fLineStr\r\n    else\r\n      TmpLine := Copy(fLineStr, 1, Markers[fNextMarker].fStartPos - 1);\r\n      \r\n    if fExpandedLine <> nil then\r\n    begin\r\n      if fMarkers.Count = 0 then\r\n        ExpandedTmpLine := fExpandedLineStr\r\n      else\r\n        ExpandedTmpLine := Copy(fExpandedLineStr, 1,\r\n          PosToExpandedPos(Markers[fNextMarker].fStartPos - 1));\r\n      iHL.SetLineExpandedAtWideGlyphs(TmpLine, ExpandedTmpLine, fLineNumber);\r\n    end\r\n    else\r\n      iHL.SetLine(TmpLine, fLineNumber);\r\n  end\r\n  else if fMarker <> nil then\r\n  begin\r\n    if not fMarker.fIsOpenMarker then\r\n    begin\r\n      fCurrScheme := -1;\r\n      DefaultHighlighter.SetRange(fTmpRange);\r\n    end;\r\n    fMarker := nil;\r\n\r\n    if CurrScheme >= 0 then\r\n      iHL := Schemes[CurrScheme].Highlighter\r\n    else\r\n      iHL := DefaultHighlighter;\r\n\r\n    if fNextMarker < fMarkers.Count then\r\n      TmpLine := Copy(fLineStr, Run + 1, Markers[fNextMarker].fStartPos - Run - 1)\r\n    else\r\n      TmpLine := Copy(fLineStr, Run + 1, MaxInt);\r\n\r\n    if fExpandedLine <> nil then\r\n    begin\r\n      if fNextMarker < fMarkers.Count then\r\n        ExpandedTmpLine := Copy(fExpandedLineStr, ExpandedRun + 1,\r\n          PosToExpandedPos(Markers[fNextMarker].fStartPos - Run - 1))\r\n      else\r\n        ExpandedTmpLine := Copy(fExpandedLineStr, ExpandedRun + 1, MaxInt);\r\n\r\n      iHL.SetLineExpandedAtWideGlyphs(TmpLine, ExpandedTmpLine, fLineNumber);\r\n    end\r\n    else\r\n      iHL.SetLine(TmpLine, fLineNumber);\r\n  end\r\n  else\r\n  begin\r\n    if CurrScheme >= 0 then\r\n      iHL := Schemes[CurrScheme].Highlighter\r\n    else\r\n      iHL := DefaultHighlighter;\r\n    iHL.Next;\r\n  end;\r\n\r\n  fTokenPos := iHL.GetTokenPos;\r\n  iToken := iHL.GetToken;\r\n  if fNextMarker > 0 then\r\n    with Markers[fNextMarker - 1] do\r\n      Inc(fTokenPos, fStartPos + fMarkerLen - 1);\r\n  Inc(Run, (fTokenPos - Run) + Length(iToken));\r\n  inherited;\r\nend;\r\n\r\nprocedure TSynMultiSyn.Notification(aComp: TComponent; aOp: TOperation);\r\nvar\r\n  i: Integer;\r\nbegin\r\n  inherited;\r\n  // 'opRemove' doesn't mean the component is being destroyed. It means it's\r\n  // being removed from its Owner's list of Components.\r\n  if (aOp = opRemove) and (aComp is TSynCustomHighlighter) and\r\n    (csDestroying in aComp.ComponentState) then\r\n  begin\r\n    if DefaultHighlighter = aComp then\r\n      DefaultHighlighter := nil;\r\n    for i := 0 to Schemes.Count - 1 do\r\n      if Schemes[i].Highlighter = aComp then\r\n        Schemes[i].Highlighter := nil;\r\n  end;\r\nend;\r\n\r\nprocedure TSynMultiSyn.ResetRange;\r\nbegin\r\n  fCurrScheme := -1;\r\n  if DefaultHighlighter <> nil then\r\n  begin\r\n    DefaultHighlighter.ResetRange;\r\n    fTmpRange := DefaultHighlighter.GetRange;\r\n  end;\r\nend;\r\n\r\nprocedure TSynMultiSyn.SetDefaultHighlighter(\r\n  const Value: TSynCustomHighLighter);\r\nconst\r\n  sDefaultHlSetToSelf = 'A SynMultiSyn cannot be its own DefaultHighlighter.';\r\nbegin\r\n  if DefaultHighlighter <> Value then begin\r\n    if Value = Self then\r\n      raise Exception.Create(sDefaultHlSetToSelf);\r\n    if DefaultHighlighter <> nil then\r\n      UnhookHighlighter(DefaultHighlighter);\r\n    fDefaultHighlighter := Value;\r\n    if DefaultHighlighter <> nil then\r\n      HookHighlighter(DefaultHighlighter);\r\n    DefHighlightChange(Self);\r\n  end;\r\nend;\r\n\r\nprocedure TSynMultiSyn.DoCheckMarker(Scheme:TScheme; StartPos, MarkerLen: Integer;\r\n  const MarkerText: UnicodeString; Start: Boolean; Line: Integer);\r\nvar\r\n  aStartPos: Integer;\r\n  aMarkerLen: Integer;\r\n  aMarkerText: UnicodeString;\r\nbegin\r\n  aStartPos := StartPos;\r\n  aMarkerLen := MarkerLen;\r\n  aMarkerText := MarkerText;\r\n  if Start and Assigned(Scheme.OnCheckStartMarker) then\r\n    Scheme.OnCheckStartMarker(Self, aStartPos, aMarkerLen, aMarkerText, Line)\r\n  else if not Start and Assigned(Scheme.OnCheckEndMarker) then\r\n    Scheme.OnCheckEndMarker(Self, aStartPos, aMarkerLen, aMarkerText, Line);\r\n  if (aMarkerText <> '') and (aMarkerLen > 0) then\r\n  begin\r\n    fMarkers.Add(TMarker.Create(Scheme.Index, aStartPos, aMarkerLen, Start,\r\n      aMarkerText));\r\n  end;\r\nend;\r\n\r\nprocedure TSynMultiSyn.SetSchemes(const Value: TSchemes);\r\nbegin\r\n  fSchemes.Assign(Value);\r\nend;\r\n\r\nprocedure TSynMultiSyn.UnhookHighlighter(aHL: TSynCustomHighlighter);\r\nbegin\r\n  aHL.UnhookAttrChangeEvent(DefHighlightChange);\r\n{$IFDEF SYN_COMPILER_5_UP}\r\n  aHL.RemoveFreeNotification(Self);\r\n{$ENDIF}\r\nend;\r\n\r\nfunction TSynMultiSyn.GetSampleSource: UnicodeString;\r\nbegin\r\n  Result := fSampleSource;\r\nend;\r\n\r\nprocedure TSynMultiSyn.SetSampleSource(Value: UnicodeString);\r\nbegin\r\n  fSampleSource := Value;\r\nend;\r\n\r\n{$IFNDEF SYN_CLX}\r\nfunction TSynMultiSyn.LoadFromRegistry(RootKey: HKEY;\r\n  Key: string): Boolean;\r\nvar\r\n  r: TBetterRegistry;\r\n  i: Integer;\r\nbegin\r\n  if DefaultHighlighter <> nil then\r\n    Result := DefaultHighlighter.LoadFromRegistry(RootKey, Key + '\\DefaultHighlighter')\r\n  else\r\n    Result := False;\r\n  r := TBetterRegistry.Create;\r\n  try\r\n    r.RootKey := RootKey;\r\n    for i := 0 to Schemes.Count-1 do\r\n      if (Schemes[i].SchemeName <> '') and\r\n        r.OpenKeyReadOnly(Key + '\\' + Schemes[i].SchemeName) then\r\n      begin\r\n        Result := Schemes[i].MarkerAttri.LoadFromRegistry(r) and Result;\r\n        r.CloseKey;\r\n        Result := (Schemes[i].Highlighter <> nil) and\r\n          Schemes[i].Highlighter.LoadFromRegistry(RootKey,\r\n          Key + '\\' + Schemes[i].SchemeName) and Result;\r\n      end\r\n      else\r\n        Result := False;\r\n  finally\r\n    r.Free;\r\n  end;\r\nend;\r\n\r\nfunction TSynMultiSyn.SaveToRegistry(RootKey: HKEY; Key: string): Boolean;\r\nvar\r\n  r: TBetterRegistry;\r\n  i: integer;\r\nbegin\r\n  if DefaultHighlighter <> nil then\r\n    Result := DefaultHighlighter.SaveToRegistry(RootKey, Key + '\\DefaultHighlighter')\r\n  else\r\n    Result := False;\r\n  r := TBetterRegistry.Create;\r\n  try\r\n    r.RootKey := RootKey;\r\n    for i := 0 to Schemes.Count-1 do\r\n      if (Schemes[i].SchemeName <> '') and\r\n        r.OpenKey(Key + '\\' + Schemes[i].SchemeName, True) then\r\n      begin\r\n        Result := Schemes[i].MarkerAttri.SaveToRegistry(r) and Result;\r\n        r.CloseKey;\r\n        Result := (Schemes[i].Highlighter <> nil) and\r\n          Schemes[i].Highlighter.SaveToRegistry(RootKey,\r\n          Key + '\\' + Schemes[i].SchemeName) and Result;\r\n      end\r\n      else\r\n        Result := False;\r\n  finally\r\n    r.Free;\r\n  end;\r\nend;\r\n{$ENDIF}\r\n\r\nfunction TSynMultiSyn.GetRange: Pointer;\r\nbegin\r\n  Result := nil;\r\n  fRangeProc(roGet, TRangeUNativeInt(Result));\r\nend;\r\n\r\nprocedure TSynMultiSyn.SetRange(Value: Pointer);\r\nbegin\r\n  fRangeProc(roSet, TRangeUNativeInt(Value));\r\nend;\r\n\r\nprocedure TSynMultiSyn.NewRangeProc(Operation: TRangeOperation; var Range: TRangeUNativeInt);\r\nconst\r\n  SchemeIndexSize = 3;\r\n  MaxSchemeCount = (1 shl SchemeIndexSize) - 1;\r\n  SchemeRangeSize = 4;\r\n  MaxSchemeRange = (1 shl SchemeRangeSize) - 1;\r\nbegin\r\n  if Operation = roGet then\r\n  begin\r\n    if DefaultHighlighter <> nil then\r\n      Range := cardinal(DefaultHighlighter.GetRange)\r\n    else\r\n      Range := 0;\r\n    if CurrScheme >= 0 then\r\n    begin\r\n      Assert(cardinal(Schemes[CurrScheme].Highlighter.GetRange) <= MaxSchemeRange);\r\n      Range := Range shl SchemeRangeSize;\r\n      Range := Range or cardinal(Schemes[CurrScheme].Highlighter.GetRange);\r\n    end;\r\n    Assert(CurrScheme <= MaxSchemeCount);\r\n    Range := Range shl SchemeIndexSize;\r\n    Range := Range or cardinal(CurrScheme + 1);\r\n  end\r\n  else\r\n  begin\r\n    CurrScheme := integer(Range and MaxSchemeCount) - 1;\r\n    Range := Range shr SchemeIndexSize;\r\n    if CurrScheme >= 0 then\r\n    begin\r\n      Schemes[CurrScheme].Highlighter.SetRange(pointer(Range and MaxSchemeRange));\r\n      Range := Range shr SchemeRangeSize;\r\n    end;\r\n    if DefaultHighlighter <> nil then\r\n    begin\r\n      fTmpRange := pointer(Range);\r\n      DefaultHighlighter.SetRange(fTmpRange);\r\n    end;\r\n  end;\r\nend;\r\n\r\nfunction TSynMultiSyn.UpdateRangeProcs: boolean;\r\n// determines the appropriate RangeProcs and returns whether they were changed\r\nvar\r\n  i: Integer;\r\n  OldProc: TRangeProc;\r\nbegin\r\n  OldProc := fRangeProc;\r\n  if Assigned(OnCustomRange) then\r\n    fRangeProc := UserRangeProc\r\n  else begin\r\n    fRangeProc := NewRangeProc;\r\n    for i := 0 to Schemes.Count -1 do\r\n      if Schemes[i].Highlighter is TSynMultiSyn then\r\n      begin\r\n        fRangeProc := OldRangeProc;\r\n        break;\r\n      end;\r\n  end;\r\n  Result := TMethod(OldProc).Code <> TMethod(fRangeProc).Code;\r\n  if Result then\r\n    DefHighlightChange(Self);\r\nend;\r\n\r\nprocedure TSynMultiSyn.UserRangeProc(Operation: TRangeOperation; var Range: TRangeUNativeInt);\r\nbegin\r\n  OnCustomRange(Self, Operation, pointer(Range));\r\n  if (Operation = roSet) and (DefaultHighlighter <> nil) then\r\n    fTmpRange := DefaultHighlighter.GetRange;\r\nend;\r\n\r\nprocedure TSynMultiSyn.SetOnCustomRange(const Value: TCustomRangeEvent);\r\nbegin\r\n  if (TMethod(OnCustomRange).Code <> TMethod(Value).Code) or\r\n    (TMethod(OnCustomRange).Data <> TMethod(Value).Data) then\r\n  begin\r\n    fOnCustomRange := Value;\r\n    UpdateRangeProcs;\r\n  end;\r\nend;\r\n\r\nprocedure TSynMultiSyn.Loaded;\r\nbegin\r\n  inherited;\r\n  DefHighlightChange(Self);\r\nend;\r\n\r\nfunction TSynMultiSyn.IsIdentChar(AChar: WideChar): Boolean;\r\nbegin\r\n  if CurrScheme >= 0 then\r\n    Result := Schemes[CurrScheme].Highlighter.IsIdentChar(AChar)\r\n  else if DefaultHighlighter <> nil then\r\n    Result := DefaultHighlighter.IsIdentChar(AChar)\r\n  else\r\n    Result := inherited IsIdentChar(AChar);\r\nend;\r\n\r\nclass function TSynMultiSyn.GetFriendlyLanguageName: UnicodeString;\r\nbegin\r\n  Result := SYNS_FriendlyLangGeneralMulti;\r\nend;\r\n\r\nprocedure TSynMultiSyn.DoSetLine(const Value: UnicodeString; LineNumber: Integer);\r\nvar\r\n  iParser: TRegExpr;\r\n  iScheme: TScheme;\r\n  iExpr: UnicodeString;\r\n  iLine: UnicodeString;\r\n  iEaten: Integer;\r\n  i: Integer;\r\nbegin\r\n  ClearMarkers;\r\n\r\n  iParser := TRegExpr.Create;\r\n  try\r\n    iEaten := 0;\r\n    iLine := Value;\r\n    if CurrScheme >= 0\r\n    then\r\n      iScheme := fSchemes[CurrScheme]\r\n    else\r\n      iScheme := nil;\r\n    while iLine <> '' do\r\n      if iScheme <> nil then\r\n      begin\r\n        iParser.Expression := iScheme.EndExpr;\r\n        iParser.ModifierI := not iScheme.CaseSensitive;\r\n        if iParser.Exec(iLine) then\r\n        begin\r\n          iExpr := Copy(Value, iParser.MatchPos[0] + iEaten, iParser.MatchLen[0]);\r\n          DoCheckMarker(iScheme, iParser.MatchPos[0] + iEaten, iParser.MatchLen[0],\r\n            iExpr, False, LineNumber);\r\n          Delete(iLine, 1, iParser.MatchPos[0] - 1 + iParser.MatchLen[0]);\r\n          Inc(iEaten, iParser.MatchPos[0] - 1 + iParser.MatchLen[0]);\r\n          iScheme := nil;\r\n        end\r\n        else\r\n          break;\r\n      end\r\n      else\r\n      begin\r\n        for i := 0 to Schemes.Count - 1 do\r\n        begin\r\n          iScheme := Schemes[i];\r\n          if (iScheme.StartExpr = '') or (iScheme.EndExpr = '') or\r\n            (iScheme.Highlighter = nil) or (not iScheme.Highlighter.Enabled) then\r\n          begin\r\n            continue;\r\n          end;\r\n          iParser.Expression := iScheme.StartExpr;\r\n          iParser.ModifierI := not iScheme.CaseSensitive;\r\n          if iParser.Exec(iLine) then begin\r\n            iExpr := Copy(Value, iParser.MatchPos[0] + iEaten, iParser.MatchLen[0]);\r\n            DoCheckMarker(iScheme, iParser.MatchPos[0] + iEaten, iParser.MatchLen[0],\r\n              iExpr, True, LineNumber);\r\n            Delete(iLine, 1, iParser.MatchPos[0] - 1 + iParser.MatchLen[0]);\r\n            Inc(iEaten, iParser.MatchPos[0] - 1 + iParser.MatchLen[0]);\r\n            break;\r\n          end;\r\n        end; {for}\r\n        if i >= Schemes.Count then\r\n          break;\r\n      end; {else}\r\n\r\n  finally\r\n    iParser.Free;\r\n  end;\r\n\r\n  fLineStr := Value;\r\n  fLine := PWideChar(fLineStr);\r\n  fCasedLineStr := '';\r\n  fCasedLine := PWideChar(fLineStr);\r\n\r\n  fMarker := nil;\r\n  Run := 0;\r\n  ExpandedRun := 0;\r\n  fOldRun := Run;\r\n  fTokenPos := 0;\r\n  fExpandedTokenPos := 0;\r\n  fNextMarker := 0;\r\n  fLineNumber := LineNumber;\r\nend;\r\n\r\nfunction TSynMultiSyn.GetExpandedToken: UnicodeString;\r\nbegin\r\n  if (DefaultHighlighter = nil) and (fExpandedLine <> nil) then\r\n    Result := fExpandedLineStr\r\n  else\r\n    Result := inherited GetExpandedToken;\r\nend;\r\n\r\n{ TSchemes }\r\n\r\nconstructor TSchemes.Create(aOwner: TSynMultiSyn);\r\nbegin\r\n  inherited Create(TScheme);\r\n  fOwner := aOwner;\r\nend;\r\n\r\nfunction TSchemes.GetItems(Index: Integer): TScheme;\r\nbegin\r\n  Result := inherited Items[Index] as TScheme;\r\nend;\r\n\r\n{$IFDEF SYN_COMPILER_3_UP}\r\nfunction TSchemes.GetOwner: TPersistent;\r\nbegin\r\n  Result := fOwner;\r\nend;\r\n{$ENDIF}\r\n\r\nprocedure TSchemes.SetItems(Index: Integer; const Value: TScheme);\r\nbegin\r\n  inherited Items[Index] := Value;\r\nend;\r\n\r\n{$IFDEF SYN_COMPILER_3_UP}\r\nprocedure TSchemes.Update(Item: TCollectionItem);\r\nbegin\r\n  if Item <> nil then\r\n    fOwner.DefHighlightChange(Item)\r\n  else // pass the MultiSyn as the Sender so Editors reparse their text\r\n    fOwner.DefHighlightChange(fOwner);\r\nend;\r\n{$ENDIF}\r\n\r\n{ TScheme }\r\n\r\nfunction TScheme.ConvertExpression(const Value: UnicodeString): UnicodeString;\r\nbegin\r\n  if not CaseSensitive then\r\n    Result := SynWideUpperCase(Value)\r\n  else\r\n    Result := Value;\r\nend;\r\n\r\nconstructor TScheme.Create(Collection: TCollection);\r\nbegin\r\n  inherited Create(Collection);\r\n  fCaseSensitive := True;\r\n  fMarkerAttri := TSynHighlighterAttributes.Create(SYNS_AttrMarker, SYNS_FriendlyAttrMarker);\r\n  fMarkerAttri.OnChange := MarkerAttriChanged;\r\n  MarkerAttri.Background := clYellow;\r\n  MarkerAttri.Style := [fsBold];\r\n  MarkerAttri.InternalSaveDefaultValues;\r\nend;\r\n\r\ndestructor TScheme.Destroy;\r\nbegin\r\n  { unhook notification handlers }\r\n  Highlighter := nil;\r\n  inherited Destroy;\r\n  fMarkerAttri.Free;\r\nend;\r\n\r\nprocedure TScheme.DefineProperties(Filer: TFiler);\r\nbegin\r\n  inherited;\r\n{$IFNDEF UNICODE}\r\n  UnicodeDefineProperties(Filer, Self);\r\n{$ENDIF}\r\nend;\r\n\r\n{$IFDEF SYN_COMPILER_3_UP}\r\nfunction TScheme.GetDisplayName: string;\r\nbegin\r\n  if SchemeName <> '' then\r\n    Result := SchemeName\r\n  else\r\n    Result := inherited GetDisplayName;\r\nend;\r\n{$ENDIF SYN_COMPILER_3_UP}\r\n\r\nprocedure TScheme.MarkerAttriChanged(Sender: TObject);\r\nbegin\r\n  Changed(False);\r\nend;\r\n\r\nprocedure TScheme.SetCaseSensitive(const Value: Boolean);\r\nbegin\r\n  if fCaseSensitive <> Value then\r\n  begin\r\n    fCaseSensitive := Value;\r\n    Changed(True);\r\n  end;\r\nend;\r\n\r\n{$IFDEF SYN_COMPILER_3_UP}\r\nprocedure TScheme.SetDisplayName(const Value: string);\r\nbegin\r\n  SchemeName := Value;\r\nend;\r\n{$ENDIF SYN_COMPILER_3_UP}\r\n\r\nprocedure TScheme.SetEndExpr(const Value: UnicodeString);\r\nvar\r\n  OldValue: UnicodeString;\r\nbegin\r\n  if fEndExpr <> Value then\r\n  begin\r\n    if Value <> '' then\r\n      CheckExpression(Value);\r\n    OldValue := fEndExpr;\r\n    fEndExpr := Value;\r\n    if ConvertExpression(OldValue) <> ConvertExpression(Value) then\r\n      Changed(True);\r\n  end;\r\nend;\r\n\r\nprocedure TScheme.SetHighlighter(const Value: TSynCustomHighLighter);\r\nvar\r\n  iOwner: TSynMultiSyn;\r\n  iAlreadyRepainted: Boolean;\r\nbegin\r\n  if Highlighter <> Value then\r\n  begin\r\n    iOwner := TSchemes(Collection).fOwner;\r\n    if (Highlighter <> nil) and (Highlighter <> iOwner) then\r\n      iOwner.UnhookHighlighter(Highlighter);\r\n    fHighlighter := Value;\r\n    if (Highlighter <> nil) and (Highlighter <> iOwner) then\r\n      iOwner.HookHighlighter(Highlighter);\r\n    if Highlighter is TSynMultiSyn then\r\n      iAlreadyRepainted := iOwner.UpdateRangeProcs\r\n    else\r\n      iAlreadyRepainted := False;\r\n    if not iAlreadyRepainted then\r\n      Changed(True);\r\n  end;\r\nend;\r\n\r\nprocedure TScheme.SetMarkerAttri(const Value: TSynHighlighterAttributes);\r\nbegin\r\n  fMarkerAttri.Assign(Value);\r\nend;\r\n\r\nprocedure TScheme.SetStartExpr(const Value: UnicodeString);\r\nvar\r\n  OldValue: UnicodeString;\r\nbegin\r\n  if fStartExpr <> Value then\r\n  begin\r\n    if Value <> '' then\r\n      CheckExpression(Value);\r\n    OldValue := fStartExpr;\r\n    fStartExpr := Value;\r\n    if ConvertExpression(Value) <> ConvertExpression(OldValue) then\r\n      Changed(True);\r\n  end;\r\nend;\r\n\r\nend.\r\n"
  },
  {
    "path": "External/SynEdit/Source/SynHighlighterPHP.pas",
    "content": "{-------------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: SynHighlighterPHP.pas, released 2000-04-21.\r\nThe Original Code is based on the wmPHPSyn.pas file from the\r\nmwEdit component suite by Martin Waldenburg and other developers, the Initial\r\nAuthor of this file is Willo van der Merwe.\r\n\"Heredoc\" syntax highlighting implementation by Marko Njezic.\r\nUnicode translation by Ma?l H?rz.\r\nPHP5 keywords added by CodehunterWorks.\r\nAll Rights Reserved.\r\n\r\nContributors to the SynEdit and mwEdit projects are listed in the\r\nContributors.txt file.\r\n\r\nAlternatively, the contents of this file may be used under the terms of the\r\nGNU General Public License Version 2 or later (the \"GPL\"), in which case\r\nthe provisions of the GPL are applicable instead of those above.\r\nIf you wish to allow use of your version of this file only under the terms\r\nof the GPL and not to allow others to use your version of this file\r\nunder the MPL, indicate your decision by deleting the provisions above and\r\nreplace them with the notice and other provisions required by the GPL.\r\nIf you do not delete the provisions above, a recipient may use your version\r\nof this file under either the MPL or the GPL.\r\n\r\n$Id: SynHighlighterPHP.pas,v 1.22.3.0 2012/09/11 16:25:00 codehunterworks Exp $\r\n\r\nYou may retrieve the latest version of this file at the SynEdit home page,\r\nlocated at http://SynEdit.SourceForge.net\r\n\r\nKnown Issues:\r\n-------------------------------------------------------------------------------}\r\n{\r\n@abstract(Provides a PHP syntax highlighter for SynEdit)\r\n@author(Willo van der Merwe , converted to SynEdit by Bruno Mikkelsen )\r\n@created(1999, converted to SynEdit 2000-04-21)\r\n@lastmod(2000-06-23)\r\nThe SynHighlighterPHP unit provides SynEdit with a PHP syntax highlighter.\r\nThanks to Martin Waldenburg.\r\n}\r\n\r\n{$IFNDEF QSYNHIGHLIGHTERPHP}\r\nunit SynHighlighterPHP;\r\n{$ENDIF}\r\n\r\n{$I SynEdit.inc}\r\n\r\ninterface\r\n\r\nuses\r\n{$IFDEF SYN_CLX}\r\n  QGraphics,\r\n  QSynEditTypes,\r\n  QSynEditHighlighter,\r\n  QSynUnicode,\r\n{$ELSE}\r\n  Graphics,\r\n  Registry,\r\n  SynEditTypes,\r\n  SynEditHighlighter,\r\n  SynUnicode,\r\n{$ENDIF}\r\n  SysUtils,\r\n  Classes;\r\n\r\ntype\r\n  TtkTokenKind = (tkComment, tkIdentifier, tkKey, tkNull,\r\n    tkNumber, tkSpace, tkString, tkSymbol, tkUnknown, tkVariable);\r\n\r\n{$IFDEF SYN_HEREDOC}\r\n  TRangeState = (rsUnKnown, rsString39, rsString34, rsComment, rsVarExpansion,\r\n    rsHeredoc);\r\n\r\n  TRangePointer = packed record\r\n    case Boolean of\r\n      True: (Ptr: Pointer);\r\n      False: (Range: Byte; Length: Byte; Checksum: Word);\r\n    end;\r\n{$ELSE}\r\n  TRangeState = (rsUnKnown, rsString39, rsString34, rsComment, rsVarExpansion);\r\n{$ENDIF}\r\n\r\n  PIdentFuncTableFunc = ^TIdentFuncTableFunc;\r\n  TIdentFuncTableFunc = function (Index: Integer): TtkTokenKind of object;\r\n\r\ntype\r\n  TSynPHPSyn = class(TSynCustomHighlighter)\r\n  private\r\n    fRange: TRangeState;\r\n{$IFDEF SYN_HEREDOC}\r\n    fHeredocLength: Byte;\r\n    fHeredocChecksum: Word;\r\n{$ENDIF}\r\n    FTokenID: TtkTokenKind;\r\n    fIdentFuncTable: array[0..255] of TIdentFuncTableFunc;\r\n    fCommentAttri: TSynHighlighterAttributes;\r\n    fIdentifierAttri: TSynHighlighterAttributes;\r\n    fKeyAttri: TSynHighlighterAttributes;\r\n    fNumberAttri: TSynHighlighterAttributes;\r\n    fSpaceAttri: TSynHighlighterAttributes;\r\n    fStringAttri: TSynHighlighterAttributes;\r\n    fSymbolAttri: TSynHighlighterAttributes;\r\n    fVariableAttri: TSynHighlighterAttributes;\r\n    function AltFunc(Index: Integer): TtkTokenKind;\r\n    function KeyWordFunc(Index: Integer): TtkTokenKind;\r\n    function HashKey(Str: PWideChar): Cardinal;\r\n    function IdentKind(MayBe: PWideChar): TtkTokenKind;\r\n    procedure InitIdent;\r\n    procedure AndSymbolProc;\r\n    procedure AtSymbolProc;\r\n    procedure BraceCloseProc;\r\n    procedure BraceOpenProc;\r\n    procedure CRProc;\r\n    procedure ColonProc;\r\n    procedure CommaProc;\r\n    procedure EqualProc;\r\n    procedure GreaterProc;\r\n    procedure IdentProc;\r\n    procedure LFProc;\r\n    procedure LowerProc;\r\n    procedure MinusProc;\r\n    procedure MultiplyProc;\r\n    procedure NotSymbolProc;\r\n    procedure NullProc;\r\n    procedure NumberProc;\r\n    procedure OrSymbolProc;\r\n    procedure PlusProc;\r\n    procedure PointProc;\r\n    procedure PoundProc;\r\n    procedure QuestionProc;\r\n    procedure RemainderSymbolProc;\r\n    procedure RoundCloseProc;\r\n    procedure RoundOpenProc;\r\n    procedure SemiColonProc;\r\n    procedure SlashProc;\r\n    procedure SpaceProc;\r\n    procedure SquareCloseProc;\r\n    procedure SquareOpenProc;\r\n    procedure StringProc;\r\n    procedure VarExpansionProc;\r\n    procedure TildeProc;\r\n    procedure VariableProc;\r\n    procedure XOrSymbolProc;\r\n    procedure UnknownProc;\r\n    procedure AnsiCProc;\r\n    procedure String39Proc;\r\n    procedure String34Proc;\r\n{$IFDEF SYN_HEREDOC}\r\n    procedure HeredocProc;\r\n{$ENDIF}\r\n  protected\r\n    function GetSampleSource: UnicodeString; override;\r\n    function IsFilterStored: Boolean; override;\r\n    procedure NextProcedure;\r\n  public\r\n    class function GetLanguageName: string; override;\r\n    class function GetFriendlyLanguageName: UnicodeString; override;\r\n  public\r\n    constructor Create(AOwner: TComponent); override;\r\n    function GetDefaultAttribute(Index: integer): TSynHighlighterAttributes;\r\n      override;\r\n    function GetEol: Boolean; override;\r\n    function GetRange: Pointer; override;\r\n    function GetTokenID: TtkTokenKind;\r\n    function GetTokenAttribute: TSynHighlighterAttributes; override;\r\n    function GetTokenKind: integer; override;\r\n    procedure Next; override;\r\n    procedure SetRange(Value: Pointer); override;\r\n    procedure ResetRange; override;\r\n  published\r\n    property CommentAttri: TSynHighlighterAttributes read fCommentAttri\r\n      write fCommentAttri;\r\n    property IdentifierAttri: TSynHighlighterAttributes read fIdentifierAttri\r\n      write fIdentifierAttri;\r\n    property KeyAttri: TSynHighlighterAttributes read fKeyAttri write fKeyAttri;\r\n    property NumberAttri: TSynHighlighterAttributes read fNumberAttri\r\n      write fNumberAttri;\r\n    property SpaceAttri: TSynHighlighterAttributes read fSpaceAttri\r\n      write fSpaceAttri;\r\n    property StringAttri: TSynHighlighterAttributes read fStringAttri\r\n      write fStringAttri;\r\n    property SymbolAttri: TSynHighlighterAttributes read fSymbolAttri\r\n      write fSymbolAttri;\r\n    property VariableAttri: TSynHighlighterAttributes read fVariableAttri\r\n      write fVariableAttri;\r\n  end;\r\n\r\nimplementation\r\n\r\nuses\r\n{$IFDEF SYN_CLX}\r\n  QSynEditMiscProcs,\r\n  QSynEditStrConst;\r\n{$ELSE}\r\n  SynEditMiscProcs,\r\n  SynEditStrConst;\r\n{$ENDIF}\r\n\r\nconst\r\n  KeyWords: array[0..73] of UnicodeString = (\r\n    '__class__', '__dir__', '__file__', '__function__', '__halt_compiler',\r\n    '__line__', '__method__', '__namespace__', 'abstract', 'and', 'array', 'as',\r\n    'break', 'case', 'catch', 'class', 'clone', 'const', 'continue', 'declare',\r\n    'default', 'die', 'do', 'echo', 'else', 'elseif', 'empty', 'enddeclare',\r\n    'endfor', 'endforeach', 'endif', 'endswitch', 'endwhile', 'eval', 'exit',\r\n    'extends', 'false', 'final', 'for', 'foreach', 'function', 'global', 'goto',\r\n    'if', 'implements', 'include', 'include_once', 'instanceof', 'interface',\r\n    'isset', 'list', 'namespace', 'new', 'null', 'old_function', 'or', 'print',\r\n    'private', 'protected', 'public', 'require', 'require_once', 'return',\r\n    'static', 'switch', 'synedit', 'throw', 'true', 'try', 'unset', 'use',\r\n    'var', 'while', 'xor'\r\n  );\r\n\r\n  KeyIndices: array[0..222] of Integer = (\r\n    -1, -1, 69, -1, -1, 1, 19, -1, -1, -1, -1, -1, -1, 35, -1, 17, -1, -1, 53,\r\n    6, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 46, -1, -1, -1,\r\n    52, 36, -1, -1, 66, -1, 62, -1, 38, 15, 44, -1, -1, -1, -1, 32, -1, -1, 24,\r\n    48, -1, -1, 56, 45, 65, 40, -1, -1, -1, -1, -1, -1, -1, 67, -1, -1, -1, -1,\r\n    -1, 60, -1, -1, -1, -1, -1, 31, 11, -1, 33, 20, 49, -1, -1, -1, 21, -1, -1,\r\n    -1, 54, -1, -1, -1, -1, -1, 29, -1, 64, -1, 23, -1, -1, 14, -1, -1, 42, -1,\r\n    -1, 0, 25, 50, -1, 58, 4, 27, -1, -1, 7, -1, -1, -1, -1, -1, 63, -1, 34, -1,\r\n    -1, -1, -1, -1, -1, -1, -1, 28, 13, 47, 51, -1, -1, 2, -1, 37, -1, -1, 71,\r\n    3, -1, 30, -1, 43, -1, -1, -1, -1, 57, 8, -1, -1, -1, -1, 41, 10, -1, 12,\r\n    72, -1, -1, -1, -1, -1, -1, 73, -1, -1, -1, -1, 5, -1, 22, -1, -1, -1, 70,\r\n    9, 18, -1, -1, -1, -1, -1, 59, 26, -1, -1, 16, -1, 68, -1, 61, -1, -1, -1,\r\n    39, -1, -1, -1, -1, -1, -1, -1, -1, 55, -1, -1, -1\r\n  );\r\n\r\n{$Q-}\r\nfunction TSynPHPSyn.HashKey(Str: PWideChar): Cardinal;\r\nbegin\r\n  Result := 0;\r\n  while IsIdentChar(Str^) do\r\n  begin\r\n    Result := Result * 252 + Ord(Str^) * 595;\r\n    inc(Str);\r\n  end;\r\n  Result := Result mod 223;\r\n  fStringLen := Str - fToIdent;\r\nend;{$Q+}\r\n\r\nfunction TSynPHPSyn.IdentKind(MayBe: PWideChar): TtkTokenKind;\r\nvar\r\n  Key: Cardinal;\r\nbegin\r\n  fToIdent := MayBe;\r\n  Key := HashKey(MayBe);\r\n  if Key <= High(fIdentFuncTable) then\r\n    Result := fIdentFuncTable[Key](KeyIndices[Key])\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nprocedure TSynPHPSyn.InitIdent;\r\nvar\r\n  i: Integer;\r\nbegin\r\n  for i := Low(fIdentFuncTable) to High(fIdentFuncTable) do\r\n    if KeyIndices[i] = -1 then\r\n      fIdentFuncTable[i] := AltFunc;\r\n\r\n  for i := Low(fIdentFuncTable) to High(fIdentFuncTable) do\r\n    if @fIdentFuncTable[i] = nil then\r\n      fIdentFuncTable[i] := KeyWordFunc;\r\nend;\r\n\r\nfunction TSynPHPSyn.AltFunc(Index: Integer): TtkTokenKind;\r\nbegin\r\n  Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPHPSyn.KeyWordFunc(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then begin\r\n    Result := tkKey;\r\n  end else begin\r\n    Result := tkIdentifier;\r\n  end;\r\nend;\r\n\r\nconstructor TSynPHPSyn.Create(AOwner: TComponent);\r\nbegin\r\n  inherited Create(AOwner);\r\n\r\n  fCaseSensitive := False;\r\n\r\n  fCommentAttri := TSynHighlighterAttributes.Create(SYNS_AttrComment, SYNS_FriendlyAttrComment);\r\n  fCommentAttri.Style := [fsItalic];\r\n  AddAttribute(fCommentAttri);\r\n  fIdentifierAttri := TSynHighlighterAttributes.Create(SYNS_AttrIdentifier, SYNS_FriendlyAttrIdentifier);\r\n  AddAttribute(fIdentifierAttri);\r\n  fKeyAttri := TSynHighlighterAttributes.Create(SYNS_AttrReservedWord, SYNS_FriendlyAttrReservedWord);\r\n  fKeyAttri.Style := [fsBold];\r\n  AddAttribute(fKeyAttri);\r\n  fNumberAttri := TSynHighlighterAttributes.Create(SYNS_AttrNumber, SYNS_FriendlyAttrNumber);\r\n  AddAttribute(fNumberAttri);\r\n  fSpaceAttri := TSynHighlighterAttributes.Create(SYNS_AttrSpace, SYNS_FriendlyAttrSpace);\r\n  AddAttribute(fSpaceAttri);\r\n  fStringAttri := TSynHighlighterAttributes.Create(SYNS_AttrString, SYNS_FriendlyAttrString);\r\n  AddAttribute(fStringAttri);\r\n  fSymbolAttri := TSynHighlighterAttributes.Create(SYNS_AttrSymbol, SYNS_FriendlyAttrSymbol);\r\n  AddAttribute(fSymbolAttri);\r\n  fVariableAttri := TSynHighlighterAttributes.Create(SYNS_AttrVariable, SYNS_FriendlyAttrVariable);\r\n  AddAttribute(fVariableAttri);\r\n  SetAttributesOnChange(DefHighlightChange);\r\n  InitIdent;\r\n  fDefaultFilter := SYNS_FilterPHP;\r\n  fRange := rsUnknown;\r\nend;\r\n\r\nprocedure TSynPHPSyn.AndSymbolProc;\r\nbegin\r\n  case FLine[Run + 1] of\r\n    '=':                               {and assign}\r\n      begin\r\n        inc(Run, 2);\r\n        fTokenID := tkSymbol;\r\n      end;\r\n    '&':                               {conditional and}\r\n      begin\r\n        inc(Run, 2);\r\n        fTokenID := tkSymbol;\r\n      end;\r\n  else                                 {and}\r\n    begin\r\n      inc(Run);\r\n      fTokenID := tkSymbol;\r\n    end;\r\n  end;\r\nend;\r\n\r\nprocedure TSynPHPSyn.AtSymbolProc;\r\nbegin\r\n  inc(Run);\r\n  fTokenId := tkSymbol;\r\nend;\r\n\r\nprocedure TSynPHPSyn.BraceCloseProc;\r\nbegin\r\n  inc(Run);\r\n  fTokenId := tkSymbol;\r\nend;\r\n\r\nprocedure TSynPHPSyn.BraceOpenProc;\r\nbegin\r\n  inc(Run);\r\n  fTokenId := tkSymbol;\r\nend;\r\n\r\nprocedure TSynPHPSyn.CRProc;\r\nbegin\r\n  fTokenID := tkSpace;\r\n  Case FLine[Run + 1] of\r\n    #10: inc(Run, 2);\r\n  else inc(Run);\r\n  end;\r\nend;\r\n\r\nprocedure TSynPHPSyn.ColonProc;\r\nbegin\r\n  inc(Run);                            {colon - conditional}\r\n  fTokenID := tkSymbol;\r\nend;\r\n\r\nprocedure TSynPHPSyn.CommaProc;\r\nbegin\r\n  inc(Run);\r\n  fTokenID := tkSymbol;\r\nend;\r\n\r\nprocedure TSynPHPSyn.EqualProc;\r\nbegin\r\n  case FLine[Run + 1] of\r\n    '=':                               {logical equal}\r\n      begin\r\n        inc(Run, 2);\r\n        fTokenID := tkSymbol;\r\n      end;\r\n    '>':                               {Hash operator}\r\n      begin\r\n        inc(Run, 2);\r\n        fTokenID := tkSymbol;\r\n      end;\r\n  else                                 {assign}\r\n    begin\r\n      inc(Run);\r\n      fTokenID := tkSymbol;\r\n    end;\r\n  end;\r\nend;\r\n\r\nprocedure TSynPHPSyn.GreaterProc;\r\nbegin\r\n  case FLine[Run + 1] of\r\n    '=':                               {greater than or equal to}\r\n      begin\r\n        inc(Run, 2);\r\n        fTokenID := tkSymbol;\r\n      end;\r\n    '>':\r\n      begin\r\n        inc(Run, 2);\r\n        fTokenID := tkSymbol;\r\n      end;\r\n  else                                 {greater than}\r\n    begin\r\n      inc(Run);\r\n      fTokenID := tkSymbol;\r\n    end;\r\n  end;\r\nend;\r\n\r\nprocedure TSynPHPSyn.IdentProc;\r\nbegin\r\n  fTokenID := IdentKind((fLine + Run));\r\n  inc(Run, fStringLen);\r\n  while IsIdentChar(fLine[Run]) do inc(Run);\r\nend;\r\n\r\nprocedure TSynPHPSyn.LFProc;\r\nbegin\r\n  fTokenID := tkSpace;\r\n  inc(Run);\r\nend;\r\n\r\nprocedure TSynPHPSyn.LowerProc;\r\n{$IFDEF SYN_HEREDOC}\r\nvar\r\n  i, Len : Integer;\r\n{$ENDIF}\r\nbegin\r\n  case FLine[Run + 1] of\r\n    '=':                               {less than or equal to}\r\n      begin\r\n        inc(Run, 2);\r\n        fTokenID := tkSymbol;\r\n      end;\r\n    '<':\r\n      begin\r\n        fTokenID := tkSymbol;\r\n{$IFDEF SYN_HEREDOC}\r\n        if (FLine[Run + 2] = '<') and IsIdentChar(FLine[Run + 3]) then\r\n        begin\r\n          inc(Run, 3);\r\n\r\n          i := Run;\r\n          while IsIdentChar(FLine[i]) do Inc(i);\r\n          Len := i - Run;\r\n\r\n          if Len > 255 then\r\n          begin\r\n            fTokenID := tkUnknown;\r\n            Exit;\r\n          end;\r\n\r\n          fRange := rsHeredoc;\r\n          fHeredocLength := Len;\r\n          fHeredocChecksum := CalcFCS(FLine[Run], Len);\r\n\r\n          Inc(Run, Len);\r\n          fTokenID := tkString;\r\n        end\r\n        else\r\n{$ENDIF}\r\n        if FLine[Run + 2] = '=' then   {shift left assign}\r\n        begin\r\n          inc(Run, 3)\r\n        end\r\n        else                           {shift left}\r\n        begin\r\n          inc(Run, 2);\r\n        end;\r\n      end;\r\n  else                                 {less than}\r\n    begin\r\n      inc(Run);\r\n      fTokenID := tkSymbol;\r\n    end;\r\n  end;\r\nend;\r\n\r\nprocedure TSynPHPSyn.MinusProc;\r\nbegin\r\n  case FLine[Run + 1] of\r\n    '=':                               {subtract assign}\r\n      begin\r\n        inc(Run, 2);\r\n        fTokenID := tkSymbol;\r\n      end;\r\n    '-':                               {decrement}\r\n      begin\r\n        inc(Run, 2);\r\n        fTokenID := tkSymbol;\r\n      end;\r\n    '>':                               {Class operator}\r\n      begin\r\n        inc(Run, 2);\r\n        fTokenID := tkSymbol;\r\n      end;\r\n  else                                 {subtract}\r\n    begin\r\n      inc(Run);\r\n      fTokenID := tkSymbol;\r\n    end;\r\n  end;\r\nend;\r\n\r\nprocedure TSynPHPSyn.MultiplyProc;\r\nbegin\r\n  case FLine[Run + 1] of\r\n    '=':                               {multiply assign}\r\n      begin\r\n        inc(Run, 2);\r\n        fTokenID := tkSymbol;\r\n      end;\r\n  else                                 {multiply}\r\n    begin\r\n      inc(Run);\r\n      fTokenID := tkSymbol;\r\n    end;\r\n  end;\r\nend;\r\n\r\nprocedure TSynPHPSyn.NotSymbolProc;\r\nbegin\r\n  case FLine[Run + 1] of\r\n    '=':                               {not equal}\r\n      begin\r\n        inc(Run, 2);\r\n        fTokenID := tkSymbol;\r\n      end;\r\n  else                                 {logical complement}\r\n    begin\r\n      inc(Run);\r\n      fTokenID := tkSymbol;\r\n    end;\r\n  end;\r\nend;\r\n\r\nprocedure TSynPHPSyn.NullProc;\r\nbegin\r\n  fTokenID := tkNull;\r\n  inc(Run);\r\nend;\r\n\r\nprocedure TSynPHPSyn.NumberProc;\r\n\r\n  function IsNumberChar: Boolean;\r\n  begin\r\n    case fLine[Run] of\r\n      '0'..'9', '.', '-', 'l', 'L', 'x', 'X', 'A'..'F', 'a'..'f':\r\n        Result := True;\r\n      else\r\n        Result := False;\r\n    end;\r\n  end;\r\n\r\nbegin\r\n  inc(Run);\r\n  fTokenID := tkNumber;\r\n  while IsNumberChar do\r\n  begin\r\n    case FLine[Run] of\r\n      '.':\r\n        if FLine[Run + 1] = '.' then break;\r\n    end;\r\n    inc(Run);\r\n  end;\r\nend;\r\n\r\nprocedure TSynPHPSyn.OrSymbolProc;\r\nbegin\r\n  case FLine[Run + 1] of\r\n    '=':                               {inclusive or assign}\r\n      begin\r\n        inc(Run, 2);\r\n        fTokenID := tkSymbol;\r\n      end;\r\n    '|':                               {conditional or}\r\n      begin\r\n        inc(Run, 2);\r\n        fTokenID := tkSymbol;\r\n      end;\r\n  else                                 {inclusive or}\r\n    begin\r\n      inc(Run);\r\n      fTokenID := tkSymbol;\r\n    end;\r\n  end;\r\nend;\r\n\r\nprocedure TSynPHPSyn.PlusProc;\r\nbegin\r\n  case FLine[Run + 1] of\r\n    '=':                               {add assign}\r\n      begin\r\n        inc(Run, 2);\r\n        fTokenID := tkSymbol;\r\n      end;\r\n    '+':                               {increment}\r\n      begin\r\n        inc(Run, 2);\r\n        fTokenID := tkSymbol;\r\n      end;\r\n  else                                 {add}\r\n    begin\r\n      inc(Run);\r\n      fTokenID := tkSymbol;\r\n    end;\r\n  end;\r\nend;\r\n\r\nprocedure TSynPHPSyn.PointProc;\r\nbegin\r\n  inc(Run);                            {point}\r\n  fTokenID := tkSymbol;\r\nend;\r\n\r\nprocedure TSynPHPSyn.PoundProc;\r\nbegin\r\n  repeat\r\n    inc(Run);\r\n  until IsLineEnd(Run);\r\n  fTokenID := tkComment;\r\nend;\r\n\r\nprocedure TSynPHPSyn.QuestionProc;\r\nbegin\r\n  fTokenID := tkSymbol;                {question mark - conditional}\r\n  inc(Run);\r\nend;\r\n\r\nprocedure TSynPHPSyn.RemainderSymbolProc;\r\nbegin\r\n  case FLine[Run + 1] of\r\n    '=':                               {remainder assign}\r\n      begin\r\n        inc(Run, 2);\r\n        fTokenID := tkSymbol;\r\n      end;\r\n  else                                 {remainder}\r\n    begin\r\n      inc(Run);\r\n      fTokenID := tkSymbol;\r\n    end;\r\n  end;\r\nend;\r\n\r\nprocedure TSynPHPSyn.RoundCloseProc;\r\nbegin\r\n  inc(Run);\r\n  fTokenID := tkSymbol;\r\nend;\r\n\r\nprocedure TSynPHPSyn.RoundOpenProc;\r\nbegin\r\n  inc(Run);\r\n  FTokenID := tkSymbol;\r\nend;\r\n\r\nprocedure TSynPHPSyn.SemiColonProc;\r\nbegin\r\n  inc(Run);                            {semicolon}\r\n  fTokenID := tkSymbol;\r\nend;\r\n\r\nprocedure TSynPHPSyn.SlashProc;\r\nbegin\r\n  case FLine[Run + 1] of\r\n    '/':                               {c++ style comments}\r\n      begin\r\n        inc(Run, 2);\r\n        fTokenID := tkComment;\r\n        while not IsLineEnd(Run) do\r\n          inc(Run);\r\n      end;\r\n    '*':\r\n      begin\r\n        fRange := rsComment;\r\n        inc(Run);\r\n        fTokenID := tkComment;       {c style comment}\r\n\r\n        inc(Run);\r\n        while not IsLineEnd(Run) do\r\n          if fLine[Run] = '*' then\r\n          begin\r\n            if fLine[Run + 1] = '/' then\r\n            begin\r\n              fRange := rsUnKnown;\r\n              inc(Run, 2);\r\n              break;\r\n            end\r\n            else\r\n              inc(Run)\r\n          end\r\n          else\r\n            inc(Run);\r\n      end;\r\n    '=':                               {division assign}\r\n      begin\r\n        inc(Run, 2);\r\n        fTokenID := tkSymbol;\r\n      end;\r\n  else                                 {division}\r\n    begin\r\n      inc(Run);\r\n      fTokenID := tkSymbol;\r\n    end;\r\n  end;\r\nend;\r\n\r\nprocedure TSynPHPSyn.SpaceProc;\r\nbegin\r\n  inc(Run);\r\n  fTokenID := tkSpace;\r\n  while (FLine[Run] <= #32) and not IsLineEnd(Run) do inc(Run);\r\nend;\r\n\r\nprocedure TSynPHPSyn.SquareCloseProc;\r\nbegin\r\n  inc(Run);\r\n  fTokenID := tkSymbol;\r\nend;\r\n\r\nprocedure TSynPHPSyn.SquareOpenProc;\r\nbegin\r\n  inc(Run);\r\n  fTokenID := tkSymbol;\r\nend;\r\n\r\nprocedure TSynPHPSyn.StringProc;\r\n\r\n  function IsEscaped: Boolean;\r\n  var\r\n    iFirstSlashPos: Integer;\r\n  begin\r\n    iFirstSlashPos := Run -1;\r\n    while (iFirstSlashPos > 0) and (FLine[iFirstSlashPos] = '\\') do\r\n      Dec(iFirstSlashPos);\r\n    Result := (Run - iFirstSlashPos + 1) mod 2 <> 0;\r\n  end;\r\n\r\nvar\r\n  iCloseChar: WideChar;\r\nbegin\r\n  if IsLineEnd(Run) and (fTokenPos = Run) then\r\n  begin\r\n    NextProcedure;\r\n    Exit;\r\n  end;\r\n  fTokenID := tkString;\r\n  if fRange = rsString39 then\r\n    iCloseChar := #39\r\n  else\r\n    iCloseChar := #34;\r\n  while not IsLineEnd(Run) do\r\n  begin\r\n    if (FLine[Run] = iCloseChar) and not IsEscaped then\r\n      break;\r\n    if (FLine[Run] = '$') and (iCloseChar = '\"') and\r\n      ((FLine[Run + 1] = '{') or IsIdentChar(FLine[Run + 1])) then\r\n    begin\r\n      if (Run > 1) and (FLine[Run -1] = '{') then { complex syntax }\r\n        Dec(Run);\r\n      if not IsEscaped then\r\n      begin\r\n        { break the token to process the variable }\r\n        fRange := rsVarExpansion;\r\n        Exit;\r\n      end\r\n      else if FLine[Run] = '{' then\r\n        Inc(Run); { restore Run if we previously deincremented it }\r\n    end;\r\n    Inc(Run);\r\n  end;\r\n  if (FLine[Run] = iCloseChar) then\r\n    fRange := rsUnKnown;\r\n  if not IsLineEnd(Run) then inc(Run);\r\nend;\r\n\r\nprocedure TSynPHPSyn.VarExpansionProc;\r\ntype\r\n  TExpansionSyntax = (esNormal, esComplex, esBrace);\r\nvar\r\n  iSyntax: TExpansionSyntax;\r\n  iOpenBraces: integer;\r\n  iOpenBrackets: integer;\r\n  iTempRun: integer;\r\nbegin\r\n  fRange := rsString34; { var expansion only occurs in double quoted strings }\r\n  FTokenID := tkVariable;\r\n  if FLine[Run] = '{' then\r\n  begin\r\n    iSyntax := esComplex;\r\n    Inc(Run, 2); { skips '{$' }\r\n  end\r\n  else\r\n  begin\r\n    Inc( Run );\r\n    if FLine[Run] = '{' then\r\n    begin\r\n      iSyntax := esBrace;\r\n      Inc(Run);\r\n    end\r\n    else\r\n      iSyntax := esNormal;\r\n  end;\r\n  if iSyntax in [esBrace, esComplex] then\r\n  begin\r\n    iOpenBraces := 1;\r\n    while not IsLineEnd(Run) do\r\n    begin\r\n      if FLine[Run] = '}' then\r\n      begin\r\n        Dec(iOpenBraces);\r\n        if iOpenBraces = 0 then\r\n        begin\r\n          Inc(Run);\r\n          break;\r\n        end;\r\n      end;\r\n      if FLine[Run] = '{' then\r\n        Inc(iOpenBraces);\r\n      Inc(Run);\r\n    end;\r\n  end\r\n  else\r\n  begin\r\n    while IsIdentChar(FLine[Run]) do\r\n      Inc(Run);\r\n    iOpenBrackets := 0;\r\n    iTempRun := Run;\r\n    { process arrays and objects }\r\n    while not IsLineEnd(iTempRun) do\r\n    begin\r\n      if FLine[iTempRun] = '[' then\r\n      begin\r\n        Inc( iTempRun );\r\n        if FLine[iTempRun] = #39 then\r\n        begin\r\n          Inc(iTempRun);\r\n          while not IsLineEnd(iTempRun) and (FLine[iTempRun] <> #39) do\r\n            Inc(iTempRun);\r\n          if (FLine[iTempRun] = #39) and (fLine[iTempRun + 1 ] = ']') then\r\n          begin\r\n            Inc(iTempRun, 2);\r\n            Run := iTempRun;\r\n            continue;\r\n          end\r\n          else\r\n            break;\r\n        end\r\n        else\r\n          Inc(iOpenBrackets);\r\n      end\r\n      else if (FLine[iTempRun] = '-') and (FLine[iTempRun +1] = '>') then\r\n        Inc(iTempRun, 2)\r\n      else\r\n        break;\r\n\r\n      if not IsIdentChar(FLine[iTempRun]) then\r\n        break\r\n      else\r\n        repeat\r\n          Inc(iTempRun);\r\n        until not IsIdentChar(FLine[iTempRun]);\r\n\r\n      while FLine[iTempRun] = ']' do\r\n      begin\r\n        if iOpenBrackets = 0 then\r\n          break;\r\n        Dec(iOpenBrackets);\r\n        Inc(iTempRun);\r\n      end;\r\n      if iOpenBrackets = 0 then\r\n        Run := iTempRun;\r\n    end;\r\n  end;\r\nend;\r\n\r\nprocedure TSynPHPSyn.TildeProc;\r\nbegin\r\n  inc(Run);                            {bitwise complement}\r\n  fTokenId := tkSymbol;\r\nend;\r\n\r\nprocedure TSynPHPSyn.VariableProc;\r\nbegin\r\n  fTokenID := tkVariable;\r\n  inc(Run);\r\n  while IsIdentChar(fLine[Run]) do inc(Run);\r\nend;\r\n\r\nprocedure TSynPHPSyn.XOrSymbolProc;\r\nbegin\r\n  Case FLine[Run + 1] of\r\n    '=':                               {xor assign}\r\n      begin\r\n        inc(Run, 2);\r\n        fTokenID := tkSymbol;\r\n      end;\r\n  else                                 {xor}\r\n    begin\r\n      inc(Run);\r\n      fTokenID := tkSymbol;\r\n    end;\r\n  end;\r\nend;\r\n\r\nprocedure TSynPHPSyn.UnknownProc;\r\nbegin\r\n  inc(Run);\r\n  fTokenID := tkUnknown;\r\nend;\r\n\r\nprocedure TSynPHPSyn.AnsiCProc;\r\nbegin\r\n  fTokenID := tkComment;\r\n  case FLine[Run] of\r\n    #0:\r\n      begin\r\n        NullProc;\r\n        exit;\r\n      end;\r\n    #10:\r\n      begin\r\n        LFProc;\r\n        exit;\r\n      end;\r\n    #13:\r\n      begin\r\n        CRProc;\r\n        exit;\r\n      end;\r\n  end;\r\n\r\n  while not IsLineEnd(Run) do\r\n    if FLine[Run] = '*' then\r\n    begin\r\n      if fLine[Run + 1] = '/' then\r\n      begin\r\n        inc(Run, 2);\r\n        fRange := rsUnKnown;\r\n        break;\r\n      end\r\n      else\r\n        inc(Run);\r\n    end\r\n    else\r\n      inc(Run);\r\nend;\r\n\r\nprocedure TSynPHPSyn.String39Proc;\r\nbegin\r\n  fRange := rsString39;\r\n  Inc( Run );\r\n  StringProc;\r\nend;\r\n\r\nprocedure TSynPHPSyn.String34Proc;\r\nbegin\r\n  fRange := rsString34;\r\n  Inc( Run );\r\n  StringProc;\r\nend;\r\n\r\n{$IFDEF SYN_HEREDOC}\r\nprocedure TSynPHPSyn.HeredocProc;\r\n\r\n  procedure SkipToEOL;\r\n  begin\r\n    case FLine[Run] of\r\n       #0: NullProc;\r\n      #10: LFProc;\r\n      #13: CRProc;\r\n    else\r\n      repeat\r\n        inc(Run);\r\n      until IsLineEnd(Run);\r\n    end;\r\n  end;\r\n\r\nvar\r\n  i: Integer;\r\nbegin\r\n  if IsLineEnd(Run) and (fTokenPos = Run) then\r\n  begin\r\n    NextProcedure;\r\n    Exit;\r\n  end;\r\n  fTokenID := tkString;\r\n\r\n  if Run = 0 then\r\n  begin\r\n    i := 0;\r\n\r\n    while not (IsLineEnd(FLine[i]) or (FLine[i] = ';')) do\r\n    begin\r\n      if i > fHeredocLength then\r\n      begin\r\n        SkipToEOL;\r\n        Exit;\r\n      end;\r\n      Inc(i);\r\n    end;\r\n\r\n    if i <> fHeredocLength then\r\n    begin\r\n      SkipToEOL;\r\n      Exit;\r\n    end;\r\n\r\n    if (CalcFCS(FLine[0], i) = fHeredocChecksum) then\r\n    begin\r\n      fRange := rsUnknown;\r\n      Run := i;\r\n      Exit;\r\n    end;\r\n  end;\r\n\r\n  SkipToEOL;\r\nend;\r\n{$ENDIF}\r\n\r\nprocedure TSynPHPSyn.Next;\r\nbegin\r\n  fTokenPos := Run;\r\n  case fRange of\r\n    rsComment: AnsiCProc;\r\n    rsString39, rsString34: StringProc;\r\n    rsVarExpansion: VarExpansionProc;\r\n{$IFDEF SYN_HEREDOC}\r\n    rsHeredoc: HeredocProc;\r\n{$ENDIF}\r\n    else\r\n    begin\r\n      fRange := rsUnknown;\r\n      NextProcedure;\r\n    end;\r\n  end;\r\n\r\n  // ensure that one call of Next is enough to reach next token\r\n  if (fOldRun = Run) and not GetEol then Next;\r\n\r\n  inherited;\r\nend;\r\n\r\nprocedure TSynPHPSyn.NextProcedure;\r\nbegin\r\n  case fLine[Run] of\r\n    '&': AndSymbolProc;\r\n    #39: String39Proc; // single quote\r\n    '@': AtSymbolProc;\r\n    '}': BraceCloseProc;\r\n    '{': BraceOpenProc;\r\n    #13: CRProc;\r\n    ':': ColonProc;\r\n    ',': CommaProc;\r\n    '=': EqualProc;\r\n    '>': GreaterProc;\r\n    'A'..'Z', 'a'..'z', '_': IdentProc;\r\n    #10: LFProc;\r\n    '<': LowerProc;\r\n    '-': MinusProc;\r\n    '*': MultiplyProc;\r\n    '!': NotSymbolProc;\r\n    #0: NullProc;\r\n    '0'..'9': NumberProc;\r\n    '|': OrSymbolProc;\r\n    '+': PlusProc;\r\n    '.': PointProc;\r\n    '#': PoundProc;\r\n    '?': QuestionProc;\r\n    '%': RemainderSymbolProc;\r\n    ')': RoundCloseProc;\r\n    '(': RoundOpenProc;\r\n    ';': SemiColonProc;\r\n    '/': SlashProc;\r\n    #1..#9, #11, #12, #14..#32: SpaceProc;\r\n    ']': SquareCloseProc;\r\n    '[': SquareOpenProc;\r\n    #34: String34Proc; // double quote\r\n    '~': TildeProc;\r\n    '$': VariableProc;\r\n    '^': XOrSymbolProc;\r\n    else UnknownProc;\r\n  end;\r\nend;\r\n\r\nfunction TSynPHPSyn.GetDefaultAttribute(Index: integer): TSynHighlighterAttributes;\r\nbegin\r\n  case Index of\r\n    SYN_ATTR_COMMENT: Result := fCommentAttri;\r\n    SYN_ATTR_IDENTIFIER: Result := fIdentifierAttri;\r\n    SYN_ATTR_KEYWORD: Result := fKeyAttri;\r\n    SYN_ATTR_STRING: Result := fStringAttri;\r\n    SYN_ATTR_WHITESPACE: Result := fSpaceAttri;\r\n    SYN_ATTR_SYMBOL: Result := fSymbolAttri;\r\n  else\r\n    Result := nil;\r\n  end;\r\nend;\r\n\r\nfunction TSynPHPSyn.GetEol: Boolean;\r\nbegin\r\n  Result := Run = fLineLen + 1;\r\nend;\r\n\r\nfunction TSynPHPSyn.GetRange: Pointer;\r\n{$IFDEF SYN_HEREDOC}\r\nvar\r\n  RangePointer: TRangePointer;\r\n{$ENDIF}\r\nbegin\r\n{$IFDEF SYN_HEREDOC}\r\n  RangePointer.Range := Ord(fRange);\r\n  RangePointer.Length := 0;\r\n  RangePointer.Checksum := 0;\r\n  if fRange = rsHeredoc then\r\n  begin\r\n    RangePointer.Length := fHeredocLength;\r\n    RangePointer.Checksum := fHeredocChecksum;\r\n  end;\r\n  Result := RangePointer.Ptr;\r\n{$ELSE}\r\n  Result := Pointer(fRange);\r\n{$ENDIF}\r\nend;\r\n\r\nfunction TSynPHPSyn.GetTokenID: TtkTokenKind;\r\nbegin\r\n  Result := fTokenId;\r\nend;\r\n\r\nfunction TSynPHPSyn.GetTokenAttribute: TSynHighlighterAttributes;\r\nbegin\r\n  case GetTokenID of\r\n    tkComment: Result := fCommentAttri;\r\n    tkIdentifier: Result := fIdentifierAttri;\r\n    tkKey: Result := fKeyAttri;\r\n    tkNumber: Result := fNumberAttri;\r\n    tkSpace: Result := fSpaceAttri;\r\n    tkString: Result := fStringAttri;\r\n    tkSymbol: Result := fSymbolAttri;\r\n    tkVariable: Result := fVariableAttri;\r\n    tkUnknown: Result := fIdentifierAttri;\r\n    else Result := nil;\r\n  end;\r\nend;\r\n\r\nfunction TSynPHPSyn.GetTokenKind: integer;\r\nbegin\r\n  Result := Ord(fTokenId);\r\nend;\r\n\r\nprocedure TSynPHPSyn.ResetRange;\r\nbegin\r\n  fRange := rsUnknown;\r\n{$IFDEF SYN_HEREDOC}\r\n  fHeredocLength := 0;\r\n  fHeredocChecksum := 0;\r\n{$ENDIF}\r\nend;\r\n\r\nprocedure TSynPHPSyn.SetRange(Value: Pointer);\r\n{$IFDEF SYN_HEREDOC}\r\nvar\r\n  RangePointer: TRangePointer;\r\n{$ENDIF}\r\nbegin\r\n{$IFDEF SYN_HEREDOC}\r\n  RangePointer := TRangePointer(Value);\r\n  fRange := TRangeState(RangePointer.Range);\r\n  fHeredocLength := 0;\r\n  fHeredocChecksum := 0;\r\n  if fRange = rsHeredoc then\r\n  begin\r\n    fHeredocLength := RangePointer.Length;\r\n    fHeredocChecksum := RangePointer.Checksum;\r\n  end;\r\n{$ELSE}\r\n  fRange := TRangeState(Value);\r\n{$ENDIF}\r\nend;\r\n\r\nfunction TSynPHPSyn.IsFilterStored: Boolean;\r\nbegin\r\n  Result := fDefaultFilter <> SYNS_FilterPHP;\r\nend;\r\n\r\nclass function TSynPHPSyn.GetLanguageName: string;\r\nbegin\r\n  Result := SYNS_LangPHP;\r\nend;\r\n\r\nfunction TSynPHPSyn.GetSampleSource: UnicodeString;\r\nbegin\r\n  Result := '// Syntax highlighting'#13#10+\r\n            'function printNumber()'#13#10+\r\n            '{'#13#10+\r\n            '  $number = 1234;'#13#10+\r\n            '  print \"The number is $number\";'#13#10+\r\n            '  for ($i = 0; $i <= $number; $i++)'#13#10+\r\n            '  {'#13#10+\r\n            '    $x++;'#13#10+\r\n            '    $x--;'#13#10+\r\n            '    $x += 1.0;'#13#10+\r\n            '  }'#13#10+\r\n            '}';\r\n\r\nend;\r\n\r\nclass function TSynPHPSyn.GetFriendlyLanguageName: UnicodeString;\r\nbegin\r\n  Result := SYNS_FriendlyLangPHP;\r\nend;\r\n\r\ninitialization\r\n{$IFNDEF SYN_CPPB_1}\r\n  RegisterPlaceableHighlighter(TSynPHPSyn);\r\n{$ENDIF}\r\nend."
  },
  {
    "path": "External/SynEdit/Source/SynHighlighterPas.pas",
    "content": "{------------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: SynHighlighterPas.pas, released 2000-04-17.\r\nThe Original Code is based on the mwPasSyn.pas file from the\r\nmwEdit component suite by Martin Waldenburg and other developers, the Initial\r\nAuthor of this file is Martin Waldenburg.\r\nPortions created by Martin Waldenburg are Copyright (C) 1998 Martin Waldenburg.\r\nUnicode translation by Mal Hrz.\r\nAll Rights Reserved.\r\n\r\nContributors to the SynEdit and mwEdit projects are listed in the\r\nContributors.txt file.\r\n\r\nAlternatively, the contents of this file may be used under the terms of the\r\nGNU General Public License Version 2 or later (the \"GPL\"), in which case\r\nthe provisions of the GPL are applicable instead of those above.\r\nIf you wish to allow use of your version of this file only under the terms\r\nof the GPL and not to allow others to use your version of this file\r\nunder the MPL, indicate your decision by deleting the provisions above and\r\nreplace them with the notice and other provisions required by the GPL.\r\nIf you do not delete the provisions above, a recipient may use your version\r\nof this file under either the MPL or the GPL.\r\n\r\n$Id: SynHighlighterPas.pas,v 1.27.2.10 2009/02/23 15:43:50 maelh Exp $\r\n\r\nYou may retrieve the latest version of this file at the SynEdit home page,\r\nlocated at http://SynEdit.SourceForge.net\r\n\r\nKnown Issues:\r\n-------------------------------------------------------------------------------}\r\n{\r\n@abstract(Provides a Pascal/Delphi syntax highlighter for SynEdit)\r\n@author(Martin Waldenburg)\r\n@created(1998, converted to SynEdit 2000-04-07)\r\n@lastmod(2004-03-19)\r\nThe SynHighlighterPas unit provides SynEdit with a Object Pascal syntax highlighter.\r\nTwo extra properties included (DelphiVersion, PackageSource):\r\n  DelphiVersion - Allows you to enable/disable the highlighting of various\r\n                  language enhancements added in the different Delphi versions.\r\n  PackageSource - Allows you to enable/disable the highlighting of package keywords\r\n}\r\n\r\n{$IFNDEF QSYNHIGHLIGHTERPAS}\r\nunit SynHighlighterPas;\r\n{$ENDIF}\r\n\r\n{$I SynEdit.inc}\r\n\r\ninterface\r\n\r\nuses\r\n{$IFDEF SYN_CLX}\r\n  QGraphics,\r\n  QSynEditTypes,\r\n  QSynEditHighlighter,\r\n  QSynUnicode,\r\n{$ELSE}\r\n  Windows,\r\n  Graphics,\r\n  SynEditTypes,\r\n  SynEditHighlighter,\r\n  SynUnicode,\r\n{$ENDIF}\r\n  SysUtils,\r\n  Classes;\r\n\r\ntype\r\n  TtkTokenKind = (tkAsm, tkComment, tkIdentifier, tkKey, tkNull, tkNumber,\r\n    tkSpace, tkString, tkSymbol, tkUnknown, tkFloat, tkHex, tkDirec, tkChar);\r\n\r\n  TRangeState = (rsANil, rsAnsi, rsAnsiAsm, rsAsm, rsBor, rsBorAsm, rsProperty,\r\n    rsExports, rsDirective, rsDirectiveAsm, rsUnKnown);\r\n\r\n  PIdentFuncTableFunc = ^TIdentFuncTableFunc;\r\n  TIdentFuncTableFunc = function (Index: Integer): TtkTokenKind of object;\r\n\r\n  TDelphiVersion = (dvDelphi1, dvDelphi2, dvDelphi3, dvDelphi4, dvDelphi5,\r\n    dvDelphi6, dvDelphi7, dvDelphi8, dvDelphi2005);\r\n\r\nconst\r\n  LastDelphiVersion = dvDelphi2005;\r\n  BDSVersionPrefix = 'BDS';\r\n\r\ntype\r\n  TSynPasSyn = class(TSynCustomHighlighter)\r\n  private\r\n    fAsmStart: Boolean;\r\n    fRange: TRangeState;\r\n    fIdentFuncTable: array[0..388] of TIdentFuncTableFunc;\r\n    fTokenID: TtkTokenKind;\r\n    fStringAttri: TSynHighlighterAttributes;\r\n    fCharAttri: TSynHighlighterAttributes;\r\n    fNumberAttri: TSynHighlighterAttributes;\r\n    fFloatAttri: TSynHighlighterAttributes;                                                 \r\n    fHexAttri: TSynHighlighterAttributes;\r\n    fKeyAttri: TSynHighlighterAttributes;\r\n    fSymbolAttri: TSynHighlighterAttributes;\r\n    fAsmAttri: TSynHighlighterAttributes;\r\n    fCommentAttri: TSynHighlighterAttributes;\r\n    fDirecAttri: TSynHighlighterAttributes;\r\n    fIdentifierAttri: TSynHighlighterAttributes;\r\n    fSpaceAttri: TSynHighlighterAttributes;\r\n    fDelphiVersion: TDelphiVersion;\r\n    fPackageSource: Boolean;\r\n    function AltFunc(Index: Integer): TtkTokenKind;\r\n    function KeyWordFunc(Index: Integer): TtkTokenKind;\r\n    function FuncAsm(Index: Integer): TtkTokenKind;\r\n    function FuncAutomated(Index: Integer): TtkTokenKind;\r\n    function FuncCdecl(Index: Integer): TtkTokenKind;\r\n    function FuncContains(Index: Integer): TtkTokenKind;\r\n    function FuncDeprecated(Index: Integer): TtkTokenKind;\r\n    function FuncDispid(Index: Integer): TtkTokenKind;\r\n    function FuncDispinterface(Index: Integer): TtkTokenKind;\r\n    function FuncEnd(Index: Integer): TtkTokenKind;\r\n    function FuncExports(Index: Integer): TtkTokenKind;\r\n    function FuncFinal(Index: Integer): TtkTokenKind;\r\n    function FuncFinalization(Index: Integer): TtkTokenKind;\r\n    function FuncHelper(Index: Integer): TtkTokenKind;\r\n    function FuncImplements(Index: Integer): TtkTokenKind;\r\n    function FuncIndex(Index: Integer): TtkTokenKind;\r\n    function FuncName(Index: Integer): TtkTokenKind;\r\n    function FuncNodefault(Index: Integer): TtkTokenKind;\r\n    function FuncOperator(Index: Integer): TtkTokenKind;\r\n    function FuncOverload(Index: Integer): TtkTokenKind;\r\n    function FuncPackage(Index: Integer): TtkTokenKind;\r\n    function FuncPlatform(Index: Integer): TtkTokenKind;\r\n    function FuncProperty(Index: Integer): TtkTokenKind;\r\n    function FuncRead(Index: Integer): TtkTokenKind;\r\n    function FuncReadonly(Index: Integer): TtkTokenKind;\r\n    function FuncReintroduce(Index: Integer): TtkTokenKind;\r\n    function FuncRequires(Index: Integer): TtkTokenKind;\r\n    function FuncResourcestring(Index: Integer): TtkTokenKind;\r\n    function FuncSafecall(Index: Integer): TtkTokenKind;\r\n    function FuncSealed(Index: Integer): TtkTokenKind;\r\n    function FuncStdcall(Index: Integer): TtkTokenKind;\r\n    function FuncStored(Index: Integer): TtkTokenKind;\r\n    function FuncStringresource(Index: Integer): TtkTokenKind;\r\n    function FuncThreadvar(Index: Integer): TtkTokenKind;\r\n    function FuncWrite(Index: Integer): TtkTokenKind;\r\n    function FuncWriteonly(Index: Integer): TtkTokenKind;\r\n    function HashKey(Str: PWideChar): Cardinal;\r\n    function IdentKind(MayBe: PWideChar): TtkTokenKind;\r\n    procedure InitIdent;\r\n    procedure AddressOpProc;\r\n    procedure AsciiCharProc;\r\n    procedure AnsiProc;\r\n    procedure BorProc;\r\n    procedure BraceOpenProc;\r\n    procedure ColonOrGreaterProc;\r\n    procedure CRProc;\r\n    procedure IdentProc;\r\n    procedure IntegerProc;\r\n    procedure LFProc;\r\n    procedure LowerProc;\r\n    procedure NullProc;\r\n    procedure NumberProc;\r\n    procedure PointProc;\r\n    procedure RoundOpenProc;\r\n    procedure SemicolonProc;\r\n    procedure SlashProc;\r\n    procedure SpaceProc;\r\n    procedure StringProc;\r\n    procedure SymbolProc;\r\n    procedure UnknownProc;\r\n    procedure SetDelphiVersion(const Value: TDelphiVersion);\r\n    procedure SetPackageSource(const Value: Boolean);\r\n  protected\r\n    function GetSampleSource: UnicodeString; override;\r\n    function IsFilterStored: Boolean; override;\r\n  public\r\n    class function GetCapabilities: TSynHighlighterCapabilities; override;\r\n    class function GetLanguageName: string; override;\r\n    class function GetFriendlyLanguageName: UnicodeString; override;\r\n  public\r\n    constructor Create(AOwner: TComponent); override;\r\n    function GetDefaultAttribute(Index: Integer): TSynHighlighterAttributes;\r\n      override;\r\n    function GetEol: Boolean; override;\r\n    function GetRange: Pointer; override;\r\n    function GetTokenAttribute: TSynHighlighterAttributes; override;\r\n    function GetTokenID: TtkTokenKind;\r\n    function GetTokenKind: Integer; override;\r\n    procedure Next; override;\r\n    procedure ResetRange; override;\r\n    procedure SetRange(Value: Pointer); override;\r\n    function UseUserSettings(VersionIndex: Integer): Boolean; override;\r\n    procedure EnumUserSettings(DelphiVersions: TStrings); override;\r\n  published\r\n    property AsmAttri: TSynHighlighterAttributes read fAsmAttri write fAsmAttri;\r\n    property CommentAttri: TSynHighlighterAttributes read fCommentAttri\r\n      write fCommentAttri;\r\n    property DirectiveAttri: TSynHighlighterAttributes read fDirecAttri\r\n      write fDirecAttri;\r\n    property IdentifierAttri: TSynHighlighterAttributes read fIdentifierAttri\r\n      write fIdentifierAttri;\r\n    property KeyAttri: TSynHighlighterAttributes read fKeyAttri write fKeyAttri;\r\n    property NumberAttri: TSynHighlighterAttributes read fNumberAttri\r\n      write fNumberAttri;\r\n    property FloatAttri: TSynHighlighterAttributes read fFloatAttri\r\n      write fFloatAttri;\r\n    property HexAttri: TSynHighlighterAttributes read fHexAttri\r\n      write fHexAttri;\r\n    property SpaceAttri: TSynHighlighterAttributes read fSpaceAttri\r\n      write fSpaceAttri;\r\n    property StringAttri: TSynHighlighterAttributes read fStringAttri\r\n      write fStringAttri;\r\n    property CharAttri: TSynHighlighterAttributes read fCharAttri\r\n      write fCharAttri;\r\n    property SymbolAttri: TSynHighlighterAttributes read fSymbolAttri\r\n      write fSymbolAttri;\r\n    property DelphiVersion: TDelphiVersion read fDelphiVersion write SetDelphiVersion\r\n      default LastDelphiVersion;\r\n    property PackageSource: Boolean read fPackageSource write SetPackageSource default True;\r\n  end;\r\n\r\nimplementation\r\n\r\nuses\r\n{$IFDEF SYN_CLX}\r\n  QSynEditStrConst;\r\n{$ELSE}\r\n  SynEditStrConst;\r\n{$ENDIF}\r\n\r\nconst\r\n  // if the language is case-insensitive keywords *must* be in lowercase\r\n  KeyWords: array[0..110] of UnicodeString = (\r\n    'absolute', 'abstract', 'and', 'array', 'as', 'asm', 'assembler',\r\n    'automated', 'begin', 'case', 'cdecl', 'class', 'const', 'constructor',\r\n    'contains', 'default', 'deprecated', 'destructor', 'dispid',\r\n    'dispinterface', 'div', 'do', 'downto', 'dynamic', 'else', 'end', 'except',\r\n    'export', 'exports', 'external', 'far', 'file', 'final', 'finalization',\r\n    'finally', 'for', 'forward', 'function', 'goto', 'helper', 'if',\r\n    'implementation', 'implements', 'in', 'index', 'inherited',\r\n    'initialization', 'inline', 'interface', 'is', 'label', 'library',\r\n    'message', 'mod', 'name', 'near', 'nil', 'nodefault', 'not', 'object', 'of',\r\n    'on', 'operator', 'or', 'out', 'overload', 'override', 'package', 'packed',\r\n    'pascal', 'platform', 'private', 'procedure', 'program', 'property',\r\n    'protected', 'public', 'published', 'raise', 'read', 'readonly', 'record',\r\n    'register', 'reintroduce', 'repeat', 'requires', 'resourcestring',\r\n    'safecall', 'sealed', 'set', 'shl', 'shr', 'stdcall', 'stored', 'string',\r\n    'stringresource', 'then', 'threadvar', 'to', 'try', 'type', 'unit', 'until',\r\n    'uses', 'var', 'virtual', 'while', 'with', 'write', 'writeonly', 'xor'\r\n  );\r\n\r\n  KeyIndices: array[0..388] of Integer = (\r\n    -1, -1, -1, 105, -1, 51, -1, 108, -1, -1, -1, -1, -1, 75, -1, -1, 46, -1,\r\n    -1, 103, -1, -1, -1, -1, 55, -1, -1, -1, -1, 76, -1, -1, 96, 14, -1, 31, 3,\r\n    102, -1, -1, -1, 7, -1, -1, -1, -1, -1, -1, -1, -1, -1, 78, -1, -1, 25, -1,\r\n    -1, 56, 65, 95, -1, -1, -1, 34, -1, 85, -1, -1, -1, -1, -1, -1, -1, -1, -1,\r\n    -1, 22, -1, -1, -1, -1, -1, -1, 80, -1, -1, -1, -1, 50, -1, -1, 109, 98, -1,\r\n    86, -1, 13, -1, -1, -1, 107, -1, -1, 60, -1, 0, 64, -1, -1, -1, -1, 8, 10,\r\n    -1, -1, -1, 67, -1, -1, -1, 74, -1, 17, -1, 73, 69, -1, 68, -1, -1, -1, -1,\r\n    -1, -1, -1, -1, -1, 16, -1, -1, 23, 39, -1, 35, 30, -1, -1, -1, 70, -1, 37,\r\n    -1, -1, 89, 71, 84, 72, -1, 29, 40, -1, -1, -1, 32, -1, -1, -1, 94, -1, -1,\r\n    87, -1, -1, -1, -1, -1, -1, 77, -1, -1, -1, -1, -1, -1, 11, 57, 41, 6, -1,\r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 24, -1, -1, -1, -1, 97, -1, -1, -1,\r\n    -1, -1, -1, -1, -1, -1, 44, 12, -1, -1, 101, -1, 58, -1, -1, -1, 99, -1, -1,\r\n    -1, -1, 53, 20, -1, -1, -1, 36, -1, -1, 63, -1, -1, -1, -1, -1, -1, -1, -1,\r\n    -1, -1, -1, -1, -1, -1, -1, 45, -1, -1, -1, -1, 27, -1, -1, -1, -1, -1, 59,\r\n    -1, 110, -1, 15, -1, 52, -1, -1, -1, -1, 5, 48, -1, -1, -1, 81, -1, 28, -1,\r\n    -1, -1, 2, -1, 1, -1, 106, -1, -1, -1, -1, 90, -1, 83, -1, -1, -1, -1, -1,\r\n    79, -1, -1, 33, 62, -1, -1, -1, -1, -1, -1, 4, -1, -1, -1, -1, -1, -1, 88,\r\n    61, 54, -1, 42, -1, -1, -1, 66, -1, -1, -1, 92, 100, -1, -1, -1, -1, -1, 18,\r\n    -1, -1, 26, 47, 38, -1, -1, 93, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,\r\n    9, -1, 91, -1, -1, -1, -1, -1, -1, 49, -1, 21, -1, -1, -1, -1, -1, -1, 43,\r\n    -1, 82, -1, 19, 104, -1, -1, -1, -1, -1\r\n  );\r\n\r\n{$Q-}\r\nfunction TSynPasSyn.HashKey(Str: PWideChar): Cardinal;\r\nbegin\r\n  Result := 0;\r\n  while IsIdentChar(Str^) do\r\n  begin\r\n    Result := Result * 812 + Ord(Str^) * 76;\r\n    inc(Str);\r\n  end;\r\n  Result := Result mod 389;\r\n  fStringLen := Str - fToIdent;\r\nend;\r\n{$Q+}\r\n\r\nfunction TSynPasSyn.IdentKind(MayBe: PWideChar): TtkTokenKind;\r\nvar\r\n  Key: Cardinal;\r\nbegin\r\n  fToIdent := MayBe;\r\n  Key := HashKey(MayBe);\r\n  if Key <= High(fIdentFuncTable) then\r\n    Result := fIdentFuncTable[Key](KeyIndices[Key])\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nprocedure TSynPasSyn.InitIdent;\r\nvar\r\n  i: Integer;\r\nbegin\r\n  for i := Low(fIdentFuncTable) to High(fIdentFuncTable) do\r\n    if KeyIndices[i] = -1 then\r\n      fIdentFuncTable[i] := AltFunc;\r\n\r\n  fIdentFuncTable[275] := FuncAsm;\r\n  fIdentFuncTable[41] := FuncAutomated;\r\n  fIdentFuncTable[112] := FuncCdecl;\r\n  fIdentFuncTable[33] := FuncContains;\r\n  fIdentFuncTable[137] := FuncDeprecated;\r\n  fIdentFuncTable[340] := FuncDispid;\r\n  fIdentFuncTable[382] := FuncDispinterface;\r\n  fIdentFuncTable[54] := FuncEnd;\r\n  fIdentFuncTable[282] := FuncExports;\r\n  fIdentFuncTable[163] := FuncFinal;\r\n  fIdentFuncTable[306] := FuncFinalization;\r\n  fIdentFuncTable[141] := FuncHelper;\r\n  fIdentFuncTable[325] := FuncImplements;\r\n  fIdentFuncTable[214] := FuncIndex;\r\n  fIdentFuncTable[323] := FuncName;\r\n  fIdentFuncTable[185] := FuncNodefault;\r\n  fIdentFuncTable[307] := FuncOperator;\r\n  fIdentFuncTable[58] := FuncOverload;\r\n  fIdentFuncTable[116] := FuncPackage;\r\n  fIdentFuncTable[148] := FuncPlatform;\r\n  fIdentFuncTable[120] := FuncProperty;\r\n  fIdentFuncTable[303] := FuncRead;\r\n  fIdentFuncTable[83] := FuncReadonly;\r\n  fIdentFuncTable[297] := FuncReintroduce;\r\n  fIdentFuncTable[65] := FuncRequires;\r\n  fIdentFuncTable[94] := FuncResourcestring;\r\n  fIdentFuncTable[170] := FuncSafecall;\r\n  fIdentFuncTable[321] := FuncSealed;\r\n  fIdentFuncTable[333] := FuncStdcall;\r\n  fIdentFuncTable[348] := FuncStored;\r\n  fIdentFuncTable[59] := FuncStringresource;\r\n  fIdentFuncTable[204] := FuncThreadvar;\r\n  fIdentFuncTable[7] := FuncWrite;\r\n  fIdentFuncTable[91] := FuncWriteonly;\r\n\r\n  for i := Low(fIdentFuncTable) to High(fIdentFuncTable) do\r\n    if @fIdentFuncTable[i] = nil then\r\n      fIdentFuncTable[i] := KeyWordFunc;\r\nend;\r\n\r\nfunction TSynPasSyn.AltFunc(Index: Integer): TtkTokenKind;\r\nbegin\r\n  Result := tkIdentifier\r\nend;\r\n\r\nfunction TSynPasSyn.KeyWordFunc(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier\r\nend;\r\n\r\nfunction TSynPasSyn.FuncAsm(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n  begin\r\n    Result := tkKey;\r\n    fRange := rsAsm;\r\n    fAsmStart := True;\r\n  end\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPasSyn.FuncAutomated(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if (DelphiVersion >= dvDelphi3) and IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPasSyn.FuncCdecl(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if (DelphiVersion >= dvDelphi2) and IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPasSyn.FuncContains(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if PackageSource and IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPasSyn.FuncDeprecated(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if (DelphiVersion >= dvDelphi6) and IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPasSyn.FuncDispid(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if (DelphiVersion >= dvDelphi3) and IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPasSyn.FuncDispinterface(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if (DelphiVersion >= dvDelphi3) and IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPasSyn.FuncEnd(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n  begin\r\n    Result := tkKey;\r\n    fRange := rsUnknown;\r\n  end\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPasSyn.FuncExports(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n  begin\r\n    Result := tkKey;\r\n    fRange := rsExports;\r\n  end\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPasSyn.FuncFinal(Index: Integer): TtkTokenKind;\r\nbegin\r\n if (DelphiVersion >= dvDelphi8) and IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPasSyn.FuncFinalization(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if (DelphiVersion >= dvDelphi2) and IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPasSyn.FuncHelper(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if (DelphiVersion >= dvDelphi8) and IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPasSyn.FuncImplements(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if (fRange = rsProperty) and (DelphiVersion >= dvDelphi4) and IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPasSyn.FuncIndex(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if (fRange in [rsProperty, rsExports]) and IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPasSyn.FuncName(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if (fRange = rsExports) and IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPasSyn.FuncNodefault(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if (fRange = rsProperty) and IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPasSyn.FuncOperator(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if (DelphiVersion >= dvDelphi8) and IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPasSyn.FuncOverload(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if (DelphiVersion >= dvDelphi4) and IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPasSyn.FuncPackage(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if PackageSource and IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPasSyn.FuncPlatform(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if (DelphiVersion >= dvDelphi6) and IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPasSyn.FuncProperty(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n  begin\r\n    Result := tkKey;\r\n    fRange := rsProperty;\r\n  end\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPasSyn.FuncRead(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if (fRange = rsProperty) and IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPasSyn.FuncReadonly(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if (DelphiVersion >= dvDelphi3) and (fRange = rsProperty) and IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPasSyn.FuncReintroduce(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if (DelphiVersion >= dvDelphi4) and IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPasSyn.FuncRequires(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if PackageSource and IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPasSyn.FuncResourcestring(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if (DelphiVersion >= dvDelphi3) and IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPasSyn.FuncSafecall(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if (DelphiVersion >= dvDelphi3) and IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPasSyn.FuncSealed(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if (DelphiVersion >= dvDelphi8) and IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPasSyn.FuncStdcall(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if (DelphiVersion >= dvDelphi2) and IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPasSyn.FuncStored(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if (fRange = rsProperty) and IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPasSyn.FuncStringresource(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if (DelphiVersion >= dvDelphi3) and IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPasSyn.FuncThreadvar(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if (DelphiVersion >= dvDelphi3) and IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPasSyn.FuncWrite(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if (fRange = rsProperty) and IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPasSyn.FuncWriteonly(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if (DelphiVersion >= dvDelphi3) and (fRange = rsProperty) and IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nconstructor TSynPasSyn.Create(AOwner: TComponent);\r\nbegin\r\n  inherited Create(AOwner);\r\n  fCaseSensitive := False;\r\n\r\n  fDelphiVersion := LastDelphiVersion;\r\n  fPackageSource := True;\r\n\r\n  fAsmAttri := TSynHighlighterAttributes.Create(SYNS_AttrAssembler, SYNS_FriendlyAttrAssembler);\r\n  AddAttribute(fAsmAttri);\r\n  fCommentAttri := TSynHighlighterAttributes.Create(SYNS_AttrComment, SYNS_FriendlyAttrComment);\r\n  fCommentAttri.Style:= [fsItalic];\r\n  AddAttribute(fCommentAttri);\r\n  fDirecAttri := TSynHighlighterAttributes.Create(SYNS_AttrPreprocessor, SYNS_FriendlyAttrPreprocessor);\r\n  fDirecAttri.Style:= [fsItalic];\r\n  AddAttribute(fDirecAttri);\r\n  fIdentifierAttri := TSynHighlighterAttributes.Create(SYNS_AttrIdentifier, SYNS_FriendlyAttrIdentifier);\r\n  AddAttribute(fIdentifierAttri);\r\n  fKeyAttri := TSynHighlighterAttributes.Create(SYNS_AttrReservedWord, SYNS_FriendlyAttrReservedWord);\r\n  fKeyAttri.Style:= [fsBold];\r\n  AddAttribute(fKeyAttri);\r\n  fNumberAttri := TSynHighlighterAttributes.Create(SYNS_AttrNumber, SYNS_FriendlyAttrNumber);\r\n  AddAttribute(fNumberAttri);\r\n  fFloatAttri := TSynHighlighterAttributes.Create(SYNS_AttrFloat, SYNS_FriendlyAttrFloat);\r\n  AddAttribute(fFloatAttri);\r\n  fHexAttri := TSynHighlighterAttributes.Create(SYNS_AttrHexadecimal, SYNS_FriendlyAttrHexadecimal);\r\n  AddAttribute(fHexAttri);\r\n  fSpaceAttri := TSynHighlighterAttributes.Create(SYNS_AttrSpace, SYNS_FriendlyAttrSpace);\r\n  AddAttribute(fSpaceAttri);\r\n  fStringAttri := TSynHighlighterAttributes.Create(SYNS_AttrString, SYNS_FriendlyAttrString);\r\n  AddAttribute(fStringAttri);\r\n  fCharAttri := TSynHighlighterAttributes.Create(SYNS_AttrCharacter, SYNS_FriendlyAttrCharacter);\r\n  AddAttribute(fCharAttri);\r\n  fSymbolAttri := TSynHighlighterAttributes.Create(SYNS_AttrSymbol, SYNS_FriendlyAttrSymbol);\r\n  AddAttribute(fSymbolAttri);\r\n  SetAttributesOnChange(DefHighlightChange);\r\n\r\n  InitIdent;\r\n  fRange := rsUnknown;\r\n  fAsmStart := False;\r\n  fDefaultFilter := SYNS_FilterPascal;\r\nend;\r\n\r\nprocedure TSynPasSyn.AddressOpProc;\r\nbegin\r\n  fTokenID := tkSymbol;\r\n  inc(Run);\r\n  if fLine[Run] = '@' then inc(Run);\r\nend;\r\n\r\nprocedure TSynPasSyn.AsciiCharProc;\r\n\r\n  function IsAsciiChar: Boolean;\r\n  begin\r\n    case fLine[Run] of\r\n      '0'..'9', '$', 'A'..'F', 'a'..'f':\r\n        Result := True;\r\n      else\r\n        Result := False;\r\n    end;\r\n  end;\r\n  \r\nbegin\r\n  fTokenID := tkChar;\r\n  Inc(Run);\r\n  while IsAsciiChar do\r\n    Inc(Run);\r\nend;\r\n\r\nprocedure TSynPasSyn.BorProc;\r\nbegin\r\n  case fLine[Run] of\r\n     #0: NullProc;\r\n    #10: LFProc;\r\n    #13: CRProc;\r\n  else\r\n    begin\r\n      if fRange in [rsDirective, rsDirectiveAsm] then\r\n        fTokenID := tkDirec\r\n      else\r\n        fTokenID := tkComment;\r\n      repeat\r\n        if fLine[Run] = '}' then\r\n        begin\r\n          Inc(Run);\r\n          if fRange in [rsBorAsm, rsDirectiveAsm] then\r\n            fRange := rsAsm\r\n          else\r\n            fRange := rsUnKnown;\r\n          break;\r\n        end;\r\n        Inc(Run);\r\n      until IsLineEnd(Run);\r\n    end;\r\n  end;\r\nend;\r\n\r\nprocedure TSynPasSyn.BraceOpenProc;\r\nbegin\r\n  if (fLine[Run + 1] = '$') then\r\n  begin\r\n    if fRange = rsAsm then\r\n      fRange := rsDirectiveAsm\r\n    else\r\n      fRange := rsDirective;\r\n  end\r\n  else\r\n  begin\r\n    if fRange = rsAsm then\r\n      fRange := rsBorAsm\r\n    else\r\n      fRange := rsBor;\r\n  end;\r\n  BorProc;\r\nend;\r\n\r\nprocedure TSynPasSyn.ColonOrGreaterProc;\r\nbegin\r\n  fTokenID := tkSymbol;\r\n  inc(Run);\r\n  if fLine[Run] = '=' then inc(Run);\r\nend;\r\n\r\nprocedure TSynPasSyn.CRProc;\r\nbegin\r\n  fTokenID := tkSpace;\r\n  inc(Run);\r\n  if fLine[Run] = #10 then\r\n    Inc(Run);\r\nend;\r\n\r\nprocedure TSynPasSyn.IdentProc;\r\nbegin\r\n  fTokenID := IdentKind(fLine + Run);\r\n  inc(Run, fStringLen);\r\n  while IsIdentChar(fLine[Run]) do\r\n    Inc(Run);\r\nend;\r\n\r\nprocedure TSynPasSyn.IntegerProc;\r\n\r\n  function IsIntegerChar: Boolean;\r\n  begin\r\n    case fLine[Run] of\r\n      '0'..'9', 'A'..'F', 'a'..'f':\r\n        Result := True;\r\n      else\r\n        Result := False;\r\n    end;\r\n  end;\r\n  \r\nbegin\r\n  inc(Run);\r\n  fTokenID := tkHex;\r\n  while IsIntegerChar do\r\n    Inc(Run);\r\nend;\r\n\r\nprocedure TSynPasSyn.LFProc;\r\nbegin\r\n  fTokenID := tkSpace;\r\n  inc(Run);\r\nend;\r\n\r\nprocedure TSynPasSyn.LowerProc;\r\nbegin\r\n  fTokenID := tkSymbol;\r\n  inc(Run);\r\n  if (fLine[Run] = '=') or (fLine[Run] = '>') then\r\n    Inc(Run);\r\nend;\r\n\r\nprocedure TSynPasSyn.NullProc;\r\nbegin\r\n  fTokenID := tkNull;\r\n  inc(Run);\r\nend;\r\n\r\nprocedure TSynPasSyn.NumberProc;\r\n\r\n  function IsNumberChar: Boolean;\r\n  begin\r\n    case fLine[Run] of\r\n      '0'..'9', '.', 'e', 'E', '-', '+':\r\n        Result := True;\r\n      else\r\n        Result := False;\r\n    end;\r\n  end;\r\n\r\nbegin\r\n  Inc(Run);\r\n  fTokenID := tkNumber;\r\n  while IsNumberChar do\r\n  begin\r\n    case fLine[Run] of\r\n      '.':\r\n        if fLine[Run + 1] = '.' then\r\n          Break\r\n        else\r\n          fTokenID := tkFloat;\r\n      'e', 'E': fTokenID := tkFloat;\r\n      '-', '+':\r\n        begin\r\n          if fTokenID <> tkFloat then // arithmetic\r\n            Break;\r\n          if (FLine[Run - 1] <> 'e') and (FLine[Run - 1] <> 'E') then\r\n            Break; //float, but it ends here\r\n        end;\r\n    end;\r\n    Inc(Run);\r\n  end;\r\nend; \r\n\r\nprocedure TSynPasSyn.PointProc;\r\nbegin\r\n  fTokenID := tkSymbol;\r\n  inc(Run);\r\n  if (fLine[Run] = '.') or (fLine[Run - 1] = ')') then\r\n    Inc(Run);\r\nend; \r\n\r\nprocedure TSynPasSyn.AnsiProc;\r\nbegin\r\n  case fLine[Run] of\r\n     #0: NullProc;\r\n    #10: LFProc;\r\n    #13: CRProc;\r\n  else\r\n    fTokenID := tkComment;\r\n    repeat\r\n      if (fLine[Run] = '*') and (fLine[Run + 1] = ')') then begin\r\n        Inc(Run, 2);\r\n        if fRange = rsAnsiAsm then\r\n          fRange := rsAsm\r\n        else\r\n          fRange := rsUnKnown;\r\n        break;\r\n      end;\r\n      Inc(Run);\r\n    until IsLineEnd(Run);\r\n  end;\r\nend;\r\n\r\nprocedure TSynPasSyn.RoundOpenProc;\r\nbegin\r\n  Inc(Run);\r\n  case fLine[Run] of\r\n    '*':\r\n      begin\r\n        Inc(Run);\r\n        if fRange = rsAsm then\r\n          fRange := rsAnsiAsm\r\n        else\r\n          fRange := rsAnsi;\r\n        fTokenID := tkComment;\r\n        if not IsLineEnd(Run) then\r\n          AnsiProc;\r\n      end;\r\n    '.':\r\n      begin\r\n        inc(Run);\r\n        fTokenID := tkSymbol;\r\n      end;\r\n  else\r\n    fTokenID := tkSymbol;\r\n  end;\r\nend;\r\n\r\nprocedure TSynPasSyn.SemicolonProc;\r\nbegin\r\n  Inc(Run);\r\n  fTokenID := tkSymbol;\r\n  if fRange in [rsProperty, rsExports] then\r\n    fRange := rsUnknown;\r\nend;\r\n\r\nprocedure TSynPasSyn.SlashProc;\r\nbegin\r\n  Inc(Run);\r\n  if (fLine[Run] = '/') and (fDelphiVersion > dvDelphi1) then\r\n  begin\r\n    fTokenID := tkComment;\r\n    repeat\r\n      Inc(Run);\r\n    until IsLineEnd(Run);\r\n  end\r\n  else\r\n    fTokenID := tkSymbol;\r\nend;\r\n\r\nprocedure TSynPasSyn.SpaceProc;\r\nbegin\r\n  inc(Run);\r\n  fTokenID := tkSpace;\r\n  while (FLine[Run] <= #32) and not IsLineEnd(Run) do inc(Run);\r\nend;\r\n\r\nprocedure TSynPasSyn.StringProc;\r\nbegin\r\n  fTokenID := tkString;\r\n  Inc(Run);\r\n  while not IsLineEnd(Run) do\r\n  begin\r\n    if fLine[Run] = #39 then begin\r\n      Inc(Run);\r\n      if fLine[Run] <> #39 then\r\n        break;\r\n    end;\r\n    Inc(Run);\r\n  end;\r\nend;\r\n\r\nprocedure TSynPasSyn.SymbolProc;\r\nbegin\r\n  inc(Run);\r\n  fTokenID := tkSymbol;\r\nend;\r\n\r\nprocedure TSynPasSyn.UnknownProc;\r\nbegin\r\n  inc(Run);\r\n  fTokenID := tkUnknown;\r\nend;\r\n\r\nprocedure TSynPasSyn.Next;\r\nbegin\r\n  fAsmStart := False;\r\n  fTokenPos := Run;\r\n  case fRange of\r\n    rsAnsi, rsAnsiAsm:\r\n      AnsiProc;\r\n    rsBor, rsBorAsm, rsDirective, rsDirectiveAsm:\r\n      BorProc;\r\n    else\r\n      case fLine[Run] of\r\n        #0: NullProc;\r\n        #10: LFProc;\r\n        #13: CRProc;\r\n        #1..#9, #11, #12, #14..#32: SpaceProc;\r\n        '#': AsciiCharProc;\r\n        '$': IntegerProc;\r\n        #39: StringProc;\r\n        '0'..'9': NumberProc;\r\n        'A'..'Z', 'a'..'z', '_': IdentProc;\r\n        '{': BraceOpenProc;\r\n        '}', '!', '\"', '%', '&', '('..'/', ':'..'@', '['..'^', '`', '~':\r\n          begin\r\n            case fLine[Run] of\r\n              '(': RoundOpenProc;\r\n              '.': PointProc;\r\n              ';': SemicolonProc;\r\n              '/': SlashProc;\r\n              ':', '>': ColonOrGreaterProc;\r\n              '<': LowerProc;\r\n              '@': AddressOpProc;\r\n              else\r\n                 SymbolProc;\r\n            end;\r\n          end;\r\n        else\r\n          UnknownProc;\r\n      end;\r\n  end;\r\n  inherited;\r\nend;\r\n\r\nfunction TSynPasSyn.GetDefaultAttribute(Index: Integer):\r\n  TSynHighlighterAttributes;\r\nbegin\r\n  case Index of\r\n    SYN_ATTR_COMMENT: Result := fCommentAttri;\r\n    SYN_ATTR_IDENTIFIER: Result := fIdentifierAttri;\r\n    SYN_ATTR_KEYWORD: Result := fKeyAttri;\r\n    SYN_ATTR_STRING: Result := fStringAttri;\r\n    SYN_ATTR_WHITESPACE: Result := fSpaceAttri;\r\n    SYN_ATTR_SYMBOL: Result := fSymbolAttri;\r\n  else\r\n    Result := nil;\r\n  end;\r\nend;\r\n\r\nfunction TSynPasSyn.GetEol: Boolean;\r\nbegin\r\n  Result := Run = fLineLen + 1;\r\nend;\r\n\r\nfunction TSynPasSyn.GetTokenID: TtkTokenKind;\r\nbegin\r\n  if not fAsmStart and (fRange = rsAsm)\r\n    and not (fTokenId in [tkNull, tkComment, tkDirec, tkSpace])\r\n  then\r\n    Result := tkAsm\r\n  else\r\n    Result := fTokenId;\r\nend;\r\n\r\nfunction TSynPasSyn.GetTokenAttribute: TSynHighlighterAttributes;\r\nbegin\r\n  case GetTokenID of\r\n    tkAsm: Result := fAsmAttri;\r\n    tkComment: Result := fCommentAttri;\r\n    tkDirec: Result := fDirecAttri;\r\n    tkIdentifier: Result := fIdentifierAttri;\r\n    tkKey: Result := fKeyAttri;\r\n    tkNumber: Result := fNumberAttri;\r\n    tkFloat: Result := fFloatAttri;\r\n    tkHex: Result := fHexAttri;\r\n    tkSpace: Result := fSpaceAttri;\r\n    tkString: Result := fStringAttri;\r\n    tkChar: Result := fCharAttri;\r\n    tkSymbol: Result := fSymbolAttri;\r\n    tkUnknown: Result := fSymbolAttri;\r\n  else\r\n    Result := nil;\r\n  end;\r\nend;\r\n\r\nfunction TSynPasSyn.GetTokenKind: Integer;\r\nbegin\r\n  Result := Ord(GetTokenID);\r\nend;\r\n\r\nfunction TSynPasSyn.GetRange: Pointer;\r\nbegin\r\n  Result := Pointer(fRange);\r\nend;\r\n\r\nprocedure TSynPasSyn.SetRange(Value: Pointer);\r\nbegin\r\n  fRange := TRangeState(Value);\r\nend;\r\n\r\nprocedure TSynPasSyn.ResetRange;\r\nbegin\r\n  fRange:= rsUnknown;\r\nend;\r\n\r\nprocedure TSynPasSyn.EnumUserSettings(DelphiVersions: TStrings);\r\n\r\n  procedure LoadKeyVersions(const Key, Prefix: string);\r\n  var\r\n    Versions: TStringList;\r\n    i: Integer;\r\n  begin\r\n    with TBetterRegistry.Create do\r\n    begin\r\n      try\r\n        RootKey := HKEY_LOCAL_MACHINE;\r\n        if OpenKeyReadOnly(Key) then\r\n        begin\r\n          try\r\n            Versions := TStringList.Create;\r\n            try\r\n              GetKeyNames(Versions);\r\n              for i := 0 to Versions.Count - 1 do\r\n                DelphiVersions.Add(Prefix + Versions[i]);\r\n            finally\r\n              FreeAndNil(Versions);\r\n            end;\r\n          finally\r\n            CloseKey;\r\n          end;\r\n        end;\r\n      finally\r\n        Free;\r\n      end;\r\n    end;\r\n  end;\r\n\r\nbegin\r\n  { returns the user settings that exist in the registry }\r\n{$IFNDEF SYN_CLX}\r\n  // See UseUserSettings below where these strings are used\r\n  LoadKeyVersions('\\SOFTWARE\\Borland\\Delphi', '');\r\n  LoadKeyVersions('\\SOFTWARE\\Borland\\BDS', BDSVersionPrefix);\r\n  LoadKeyVersions('\\SOFTWARE\\CodeGear\\BDS', BDSVersionPrefix);\r\n  LoadKeyVersions('\\SOFTWARE\\Embarcadero\\BDS', BDSVersionPrefix);\r\n\r\n{$ENDIF}\r\nend;\r\n\r\nfunction TSynPasSyn.UseUserSettings(VersionIndex: Integer): Boolean;\r\n// Possible parameter values:\r\n//   index into TStrings returned by EnumUserSettings\r\n// Possible return values:\r\n//   True : settings were read and used\r\n//   False: problem reading settings or invalid version specified - old settings\r\n//          were preserved\r\n\r\n{$IFNDEF SYN_CLX}\r\n  function ReadDelphiSettings(settingIndex: Integer): Boolean;\r\n\r\n    function ReadDelphiSetting(settingTag: string; attri: TSynHighlighterAttributes; key: string): Boolean;\r\n    var\r\n      Version: Currency;\r\n      VersionStr: string;\r\n\r\n      function ReadDelphi2Or3(settingTag: string; attri: TSynHighlighterAttributes; name: string): Boolean;\r\n      var\r\n        i: Integer;\r\n      begin\r\n        for i := 1 to Length(name) do\r\n          if name[i] = ' ' then name[i] := '_';\r\n        Result := attri.LoadFromBorlandRegistry(HKEY_CURRENT_USER,\r\n                '\\Software\\Borland\\Delphi\\'+settingTag+'\\Highlight',name,True);\r\n      end; { ReadDelphi2Or3 }\r\n\r\n      function ReadDelphi4OrMore(settingTag: string; attri: TSynHighlighterAttributes; key: string): Boolean;\r\n      begin\r\n        Result := attri.LoadFromBorlandRegistry(HKEY_CURRENT_USER,\r\n               '\\Software\\Borland\\Delphi\\'+settingTag+'\\Editor\\Highlight',key,False);\r\n      end; { ReadDelphi4OrMore }\r\n\r\n      function ReadDelphi8To2007(settingTag: string; attri: TSynHighlighterAttributes; key: string): Boolean;\r\n      begin\r\n        Result := attri.LoadFromBorlandRegistry(HKEY_CURRENT_USER,\r\n               '\\Software\\Borland\\BDS\\'+settingTag+'\\Editor\\Highlight',key,False);\r\n      end; { ReadDelphi8OrMore }\r\n\r\n      function ReadDelphi2009OrMore(settingTag: string; attri: TSynHighlighterAttributes; key: string): Boolean;\r\n      begin\r\n        Result := attri.LoadFromBorlandRegistry(HKEY_CURRENT_USER,\r\n               '\\Software\\CodeGear\\BDS\\'+settingTag+'\\Editor\\Highlight',key,False);\r\n      end; { ReadDelphi2009OrMore }\r\n\r\n      function ReadDelphiXEOrMore(settingTag: string; attri: TSynHighlighterAttributes; key: string): Boolean;\r\n      begin\r\n        Result := attri.LoadFromBorlandRegistry(HKEY_CURRENT_USER,\r\n               '\\Software\\Embarcadero\\BDS\\'+settingTag+'\\Editor\\Highlight',key,False);\r\n      end; { ReadDelphi2009OrMore }\r\n\r\n\r\n    begin { ReadDelphiSetting }\r\n      try\r\n        if Pos('BDS', settingTag) = 1 then // BDS product\r\n        begin\r\n          VersionStr := Copy(settingTag, Length(BDSVersionPrefix) + 1, 999);\r\n          Version := 0;\r\n          if not TryStrToCurr(StringReplace(VersionStr, '.', {$IFDEF SYN_COMPILER_15_UP}FormatSettings.{$ENDIF}DecimalSeparator, []), Version) then\r\n          begin\r\n            Result := False;\r\n            Exit;\r\n          end;\r\n          if Version >= 8 then\r\n            Result := ReadDelphiXEOrMore(VersionStr, attri, key)\r\n          else\r\n            if Version >= 6 then\r\n              Result := ReadDelphi2009OrMore(VersionStr, attri, key)\r\n            else\r\n              Result := ReadDelphi8To2007(VersionStr, attri, key);\r\n        end\r\n        else begin // Borland Delphi 7 or earlier\r\n          if (settingTag[1] = '2') or (settingTag[1] = '3')\r\n            then Result := ReadDelphi2Or3(settingTag, attri, key)\r\n            else Result := ReadDelphi4OrMore(settingTag, attri, key);\r\n        end;\r\n      except Result := False; end;\r\n    end; { ReadDelphiSetting }\r\n\r\n  var\r\n    tmpAsmAttri, tmpCommentAttri, tmpIdentAttri, tmpKeyAttri, tmpNumberAttri,\r\n    tmpSpaceAttri, tmpStringAttri, tmpSymbolAttri: TSynHighlighterAttributes;\r\n    iVersions: TStringList;\r\n    iVersionTag: string;\r\n  begin { ReadDelphiSettings }\r\n    {$IFDEF SYN_COMPILER_7_UP}\r\n    {$IFNDEF SYN_COMPILER_9_UP}\r\n    Result := False; // Silence the compiler warning\r\n    {$ENDIF}\r\n    {$ENDIF}\r\n    iVersions := TStringList.Create;\r\n    try\r\n      EnumUserSettings(iVersions);\r\n      if (settingIndex < 0) or (settingIndex >= iVersions.Count) then\r\n      begin\r\n        Result := False;\r\n        Exit;\r\n      end;\r\n      iVersionTag := iVersions[settingIndex];\r\n    finally\r\n      iVersions.Free;\r\n    end;\r\n    tmpAsmAttri     := TSynHighlighterAttributes.Create('', '');\r\n    tmpCommentAttri := TSynHighlighterAttributes.Create('', '');\r\n    tmpIdentAttri   := TSynHighlighterAttributes.Create('', '');\r\n    tmpKeyAttri     := TSynHighlighterAttributes.Create('', '');\r\n    tmpNumberAttri  := TSynHighlighterAttributes.Create('', '');\r\n    tmpSpaceAttri   := TSynHighlighterAttributes.Create('', '');\r\n    tmpStringAttri  := TSynHighlighterAttributes.Create('', '');\r\n    tmpSymbolAttri  := TSynHighlighterAttributes.Create('', '');\r\n\r\n    Result := ReadDelphiSetting(iVersionTag, tmpAsmAttri,'Assembler') and\r\n      ReadDelphiSetting(iVersionTag, tmpCommentAttri,'Comment') and\r\n      ReadDelphiSetting(iVersionTag, tmpIdentAttri,'Identifier') and\r\n      ReadDelphiSetting(iVersionTag, tmpKeyAttri,'Reserved word') and\r\n      ReadDelphiSetting(iVersionTag, tmpNumberAttri,'Number') and\r\n      ReadDelphiSetting(iVersionTag, tmpSpaceAttri,'Whitespace') and\r\n      ReadDelphiSetting(iVersionTag, tmpStringAttri,'String') and\r\n      ReadDelphiSetting(iVersionTag, tmpSymbolAttri,'Symbol');\r\n\r\n    if Result then\r\n    begin\r\n      fAsmAttri.AssignColorAndStyle(tmpAsmAttri);\r\n      fCharAttri.AssignColorAndStyle(tmpStringAttri); { Delphi lacks Char attribute }\r\n      fCommentAttri.AssignColorAndStyle(tmpCommentAttri);\r\n      fDirecAttri.AssignColorAndStyle(tmpCommentAttri); { Delphi lacks Directive attribute }\r\n      fFloatAttri.AssignColorAndStyle(tmpNumberAttri); { Delphi lacks Float attribute }\r\n      fHexAttri.AssignColorAndStyle(tmpNumberAttri); { Delphi lacks Hex attribute }\r\n      fIdentifierAttri.AssignColorAndStyle(tmpIdentAttri);\r\n      fKeyAttri.AssignColorAndStyle(tmpKeyAttri);\r\n      fNumberAttri.AssignColorAndStyle(tmpNumberAttri);\r\n      fSpaceAttri.AssignColorAndStyle(tmpSpaceAttri);\r\n      fStringAttri.AssignColorAndStyle(tmpStringAttri);\r\n      fSymbolAttri.AssignColorAndStyle(tmpSymbolAttri);\r\n    end;\r\n    tmpAsmAttri.Free;\r\n    tmpCommentAttri.Free;\r\n    tmpIdentAttri.Free;\r\n    tmpKeyAttri.Free;\r\n    tmpNumberAttri.Free;\r\n    tmpSpaceAttri.Free;\r\n    tmpStringAttri.Free;\r\n    tmpSymbolAttri.Free;\r\n  end;\r\n{$ENDIF}\r\n\r\nbegin\r\n{$IFNDEF SYN_CLX}\r\n  Result := ReadDelphiSettings(VersionIndex);\r\n{$ELSE}\r\n  Result := False;\r\n{$ENDIF}\r\nend;\r\n\r\nfunction TSynPasSyn.GetSampleSource: UnicodeString;                                   \r\nbegin\r\n  Result := '{ Syntax highlighting }'#13#10 +\r\n             'procedure TForm1.Button1Click(Sender: TObject);'#13#10 +\r\n             'var'#13#10 +\r\n             '  Number, I, X: Integer;'#13#10 +\r\n             'begin'#13#10 +\r\n             '  Number := 123456;'#13#10 +\r\n             '  Caption := ''The Number is'' + #32 + IntToStr(Number);'#13#10 +\r\n             '  for I := 0 to Number do'#13#10 +\r\n             '  begin'#13#10 +\r\n             '    Inc(X);'#13#10 +\r\n             '    Dec(X);'#13#10 +\r\n             '    X := X + 1.0;'#13#10 +\r\n             '    X := X - $5E;'#13#10 +\r\n             '  end;'#13#10 +\r\n             '  {$R+}'#13#10 +\r\n             '  asm'#13#10 +\r\n             '    mov AX, 1234H'#13#10 +\r\n             '    mov Number, AX'#13#10 +\r\n             '  end;'#13#10 +\r\n             '  {$R-}'#13#10 +\r\n             'end;';\r\nend;\r\n\r\n\r\nclass function TSynPasSyn.GetLanguageName: string;\r\nbegin\r\n  Result := SYNS_LangPascal;\r\nend;\r\n\r\nclass function TSynPasSyn.GetCapabilities: TSynHighlighterCapabilities;\r\nbegin\r\n  Result := inherited GetCapabilities + [hcUserSettings];\r\nend;\r\n\r\nfunction TSynPasSyn.IsFilterStored: Boolean;\r\nbegin\r\n  Result := fDefaultFilter <> SYNS_FilterPascal;\r\nend;\r\n\r\nprocedure TSynPasSyn.SetDelphiVersion(const Value: TDelphiVersion);\r\nbegin\r\n  if fDelphiVersion <> Value then\r\n  begin\r\n    fDelphiVersion := Value;\r\n    if (fDelphiVersion < dvDelphi3) and fPackageSource then\r\n      fPackageSource := False;\r\n    DefHighlightChange(Self);\r\n  end;\r\nend;\r\n\r\nprocedure TSynPasSyn.SetPackageSource(const Value: Boolean);\r\nbegin\r\n  if fPackageSource <> Value then\r\n  begin\r\n    fPackageSource := Value;\r\n    if fPackageSource and (fDelphiVersion < dvDelphi3) then\r\n      fDelphiVersion := dvDelphi3;\r\n    DefHighlightChange(Self);\r\n  end;\r\nend;\r\n\r\nclass function TSynPasSyn.GetFriendlyLanguageName: UnicodeString;\r\nbegin\r\n  Result := SYNS_FriendlyLangPascal;\r\nend;\r\n\r\ninitialization\r\n{$IFNDEF SYN_CPPB_1}\r\n  RegisterPlaceableHighlighter(TSynPasSyn);\r\n{$ENDIF}\r\nend.\r\n\r\n"
  },
  {
    "path": "External/SynEdit/Source/SynHighlighterPerl.pas",
    "content": "{-------------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: SynHighlighterPerl.pas, released 2000-04-10.\r\nThe Original Code is based on the DcjSynPerl.pas file from the\r\nmwEdit component suite by Martin Waldenburg and other developers, the Initial\r\nAuthor of this file is Michael Trier.\r\nUnicode translation by Mal Hrz.\r\nAll Rights Reserved.\r\n\r\nContributors to the SynEdit and mwEdit projects are listed in the\r\nContributors.txt file.\r\n\r\nAlternatively, the contents of this file may be used under the terms of the\r\nGNU General Public License Version 2 or later (the \"GPL\"), in which case\r\nthe provisions of the GPL are applicable instead of those above.\r\nIf you wish to allow use of your version of this file only under the terms\r\nof the GPL and not to allow others to use your version of this file\r\nunder the MPL, indicate your decision by deleting the provisions above and\r\nreplace them with the notice and other provisions required by the GPL.\r\nIf you do not delete the provisions above, a recipient may use your version\r\nof this file under either the MPL or the GPL.\r\n\r\n$Id: SynHighlighterPerl.pas,v 1.14.2.8 2008/09/14 16:25:01 maelh Exp $\r\n\r\nYou may retrieve the latest version of this file at the SynEdit home page,\r\nlocated at http://SynEdit.SourceForge.net\r\n\r\nKnown Issues:\r\n  - Using q, qq, qw, qx, m, s, tr will not properly parse the contained\r\n    information.\r\n  - Not very optimized.\r\n-------------------------------------------------------------------------------}\r\n{\r\n@abstract(Provides a Perl syntax highlighter for SynEdit)\r\n@author(Michael Trier)\r\n@created(1999, converted to SynEdit 2000-04-10 by Michael Hieke)\r\n@lastmod(2000-06-23)\r\nThe SynHighlighterPerl unit provides SynEdit with a Perl syntax highlighter.\r\n}\r\n\r\n{$IFNDEF QSYNHIGHLIGHTERPERL}\r\nunit SynHighlighterPerl;\r\n{$ENDIF}\r\n\r\n{$I SynEdit.inc}\r\n\r\ninterface\r\n\r\nuses\r\n{$IFDEF SYN_CLX}\r\n  QGraphics,\r\n  QSynEditTypes,\r\n  QSynEditHighlighter,\r\n  QSynUnicode,\r\n{$ELSE}\r\n  Graphics,\r\n  SynEditTypes,\r\n  SynEditHighlighter,\r\n  SynUnicode,\r\n{$ENDIF}\r\n  SysUtils,\r\n  Classes;\r\n\r\ntype\r\n  TtkTokenKind = (tkComment, tkIdentifier, tkKey, tkNull, tkNumber, tkOperator,\r\n    tkPragma, tkSpace, tkString, tkSymbol, tkUnknown, tkVariable);\r\n\r\n  PIdentFuncTableFunc = ^TIdentFuncTableFunc;\r\n  TIdentFuncTableFunc = function (Index: Integer): TtkTokenKind of object;\r\n\r\n  TSynPerlSyn = class(TSynCustomHighlighter)\r\n  private\r\n    FTokenID: TtkTokenKind;\r\n    fIdentFuncTable: array[0..2422] of TIdentFuncTableFunc;\r\n    fCommentAttri: TSynHighlighterAttributes;\r\n    fIdentifierAttri: TSynHighlighterAttributes;\r\n    fInvalidAttri: TSynHighlighterAttributes;\r\n    fKeyAttri: TSynHighlighterAttributes;\r\n    fNumberAttri: TSynHighlighterAttributes;\r\n    fOperatorAttri: TSynHighlighterAttributes;\r\n    fPragmaAttri: TSynHighlighterAttributes;\r\n    fSpaceAttri: TSynHighlighterAttributes;\r\n    fStringAttri: TSynHighlighterAttributes;\r\n    fSymbolAttri: TSynHighlighterAttributes;\r\n    fVariableAttri: TSynHighlighterAttributes;\r\n    function AltFunc(Index: Integer): TtkTokenKind;\r\n    function Func36accumulator(Index: Integer): TtkTokenKind;\r\n    function Func36arg(Index: Integer): TtkTokenKind;\r\n    function Func36argv(Index: Integer): TtkTokenKind;\r\n    function Func36basetime(Index: Integer): TtkTokenKind;\r\n    function Func36child95error(Index: Integer): TtkTokenKind;\r\n    function Func36debugging(Index: Integer): TtkTokenKind;\r\n    function Func36effective95group95id(Index: Integer): TtkTokenKind;\r\n    function Func36effective95user95id(Index: Integer): TtkTokenKind;\r\n    function Func36egid(Index: Integer): TtkTokenKind;\r\n    function Func36env(Index: Integer): TtkTokenKind;\r\n    function Func36errno(Index: Integer): TtkTokenKind;\r\n    function Func36euid(Index: Integer): TtkTokenKind;\r\n    function Func36eval95error(Index: Integer): TtkTokenKind;\r\n    function Func36executable95name(Index: Integer): TtkTokenKind;\r\n    function Func36format95formfeed(Index: Integer): TtkTokenKind;\r\n    function Func36format95line95break95characters(Index: Integer): TtkTokenKind;\r\n    function Func36format95lines95left(Index: Integer): TtkTokenKind;\r\n    function Func36format95lines95per95page(Index: Integer): TtkTokenKind;\r\n    function Func36format95name(Index: Integer): TtkTokenKind;\r\n    function Func36format95page95number(Index: Integer): TtkTokenKind;\r\n    function Func36format95top95name(Index: Integer): TtkTokenKind;\r\n    function Func36gid(Index: Integer): TtkTokenKind;\r\n    function Func36inplace95edit(Index: Integer): TtkTokenKind;\r\n    function Func36input95line95number(Index: Integer): TtkTokenKind;\r\n    function Func36input95record95separator(Index: Integer): TtkTokenKind;\r\n    function Func36last95paren95match(Index: Integer): TtkTokenKind;\r\n    function Func36list95separator(Index: Integer): TtkTokenKind;\r\n    function Func36match(Index: Integer): TtkTokenKind;\r\n    function Func36multiline95matching(Index: Integer): TtkTokenKind;\r\n    function Func36nr(Index: Integer): TtkTokenKind;\r\n    function Func36ofmt(Index: Integer): TtkTokenKind;\r\n    function Func36ors(Index: Integer): TtkTokenKind;\r\n    function Func36os95error(Index: Integer): TtkTokenKind;\r\n    function Func36output95autoflush(Index: Integer): TtkTokenKind;\r\n    function Func36output95field95separator(Index: Integer): TtkTokenKind;\r\n    function Func36perl95version(Index: Integer): TtkTokenKind;\r\n    function Func36perldb(Index: Integer): TtkTokenKind;\r\n    function Func36pid(Index: Integer): TtkTokenKind;\r\n    function Func36postmatch(Index: Integer): TtkTokenKind;\r\n    function Func36prematch(Index: Integer): TtkTokenKind;\r\n    function Func36process95id(Index: Integer): TtkTokenKind;\r\n    function Func36program95name(Index: Integer): TtkTokenKind;\r\n    function Func36real95group95id(Index: Integer): TtkTokenKind;\r\n    function Func36real95user95id(Index: Integer): TtkTokenKind;\r\n    function Func36rs(Index: Integer): TtkTokenKind;\r\n    function Func36sig(Index: Integer): TtkTokenKind;\r\n    function Func36subscript95separator(Index: Integer): TtkTokenKind;\r\n    function Func36subsep(Index: Integer): TtkTokenKind;\r\n    function Func36system95fd95max(Index: Integer): TtkTokenKind;\r\n    function Func36uid(Index: Integer): TtkTokenKind;\r\n    function Func36warning(Index: Integer): TtkTokenKind;\r\n    function Func37inc(Index: Integer): TtkTokenKind;\r\n    function Func64argv(Index: Integer): TtkTokenKind;\r\n    function Func64inc(Index: Integer): TtkTokenKind;\r\n    function FuncAbs(Index: Integer): TtkTokenKind;\r\n    function FuncAccept(Index: Integer): TtkTokenKind;\r\n    function FuncAlarm(Index: Integer): TtkTokenKind;\r\n    function FuncAnd(Index: Integer): TtkTokenKind;\r\n    function FuncAtan2(Index: Integer): TtkTokenKind;\r\n    function FuncBind(Index: Integer): TtkTokenKind;\r\n    function FuncBinmode(Index: Integer): TtkTokenKind;\r\n    function FuncBless(Index: Integer): TtkTokenKind;\r\n    function FuncCaller(Index: Integer): TtkTokenKind;\r\n    function FuncChdir(Index: Integer): TtkTokenKind;\r\n    function FuncChmod(Index: Integer): TtkTokenKind;\r\n    function FuncChomp(Index: Integer): TtkTokenKind;\r\n    function FuncChop(Index: Integer): TtkTokenKind;\r\n    function FuncChown(Index: Integer): TtkTokenKind;\r\n    function FuncChr(Index: Integer): TtkTokenKind;\r\n    function FuncChroot(Index: Integer): TtkTokenKind;\r\n    function FuncClose(Index: Integer): TtkTokenKind;\r\n    function FuncClosedir(Index: Integer): TtkTokenKind;\r\n    function FuncCmp(Index: Integer): TtkTokenKind;\r\n    function FuncConnect(Index: Integer): TtkTokenKind;\r\n    function FuncConstant(Index: Integer): TtkTokenKind;\r\n    function FuncCos(Index: Integer): TtkTokenKind;\r\n    function FuncCrypt(Index: Integer): TtkTokenKind;\r\n    function FuncDbmclose(Index: Integer): TtkTokenKind;\r\n    function FuncDbmopen(Index: Integer): TtkTokenKind;\r\n    function FuncDefined(Index: Integer): TtkTokenKind;\r\n    function FuncDelete(Index: Integer): TtkTokenKind;\r\n    function FuncDiagnostics(Index: Integer): TtkTokenKind;\r\n    function FuncDie(Index: Integer): TtkTokenKind;\r\n    function FuncDo(Index: Integer): TtkTokenKind;\r\n    function FuncDump(Index: Integer): TtkTokenKind;\r\n    function FuncEach(Index: Integer): TtkTokenKind;\r\n    function FuncElse(Index: Integer): TtkTokenKind;\r\n    function FuncElsif(Index: Integer): TtkTokenKind;\r\n    function FuncEndgrent(Index: Integer): TtkTokenKind;\r\n    function FuncEndhostent(Index: Integer): TtkTokenKind;\r\n    function FuncEndnetent(Index: Integer): TtkTokenKind;\r\n    function FuncEndprotoent(Index: Integer): TtkTokenKind;\r\n    function FuncEndpwent(Index: Integer): TtkTokenKind;\r\n    function FuncEndservent(Index: Integer): TtkTokenKind;\r\n    function FuncEof(Index: Integer): TtkTokenKind;\r\n    function FuncEq(Index: Integer): TtkTokenKind;\r\n    function FuncEval(Index: Integer): TtkTokenKind;\r\n    function FuncExec(Index: Integer): TtkTokenKind;\r\n    function FuncExists(Index: Integer): TtkTokenKind;\r\n    function FuncExit(Index: Integer): TtkTokenKind;\r\n    function FuncExp(Index: Integer): TtkTokenKind;\r\n    function FuncFcntl(Index: Integer): TtkTokenKind;\r\n    function FuncFileno(Index: Integer): TtkTokenKind;\r\n    function FuncFlock(Index: Integer): TtkTokenKind;\r\n    function FuncFor(Index: Integer): TtkTokenKind;\r\n    function FuncForeach(Index: Integer): TtkTokenKind;\r\n    function FuncFork(Index: Integer): TtkTokenKind;\r\n    function FuncFormat(Index: Integer): TtkTokenKind;\r\n    function FuncFormline(Index: Integer): TtkTokenKind;\r\n    function FuncGe(Index: Integer): TtkTokenKind;\r\n    function FuncGetc(Index: Integer): TtkTokenKind;\r\n    function FuncGetgrent(Index: Integer): TtkTokenKind;\r\n    function FuncGetgrgid(Index: Integer): TtkTokenKind;\r\n    function FuncGetgrnam(Index: Integer): TtkTokenKind;\r\n    function FuncGethostbyaddr(Index: Integer): TtkTokenKind;\r\n    function FuncGethostbyname(Index: Integer): TtkTokenKind;\r\n    function FuncGethostent(Index: Integer): TtkTokenKind;\r\n    function FuncGetlogin(Index: Integer): TtkTokenKind;\r\n    function FuncGetnetbyaddr(Index: Integer): TtkTokenKind;\r\n    function FuncGetnetbyname(Index: Integer): TtkTokenKind;\r\n    function FuncGetnetent(Index: Integer): TtkTokenKind;\r\n    function FuncGetpeername(Index: Integer): TtkTokenKind;\r\n    function FuncGetpgrp(Index: Integer): TtkTokenKind;\r\n    function FuncGetppid(Index: Integer): TtkTokenKind;\r\n    function FuncGetpriority(Index: Integer): TtkTokenKind;\r\n    function FuncGetprotobyname(Index: Integer): TtkTokenKind;\r\n    function FuncGetprotobynumber(Index: Integer): TtkTokenKind;\r\n    function FuncGetprotoent(Index: Integer): TtkTokenKind;\r\n    function FuncGetpwent(Index: Integer): TtkTokenKind;\r\n    function FuncGetpwnam(Index: Integer): TtkTokenKind;\r\n    function FuncGetpwuid(Index: Integer): TtkTokenKind;\r\n    function FuncGetservbyname(Index: Integer): TtkTokenKind;\r\n    function FuncGetservbyport(Index: Integer): TtkTokenKind;\r\n    function FuncGetservent(Index: Integer): TtkTokenKind;\r\n    function FuncGetsockname(Index: Integer): TtkTokenKind;\r\n    function FuncGetsockopt(Index: Integer): TtkTokenKind;\r\n    function FuncGlob(Index: Integer): TtkTokenKind;\r\n    function FuncGmtime(Index: Integer): TtkTokenKind;\r\n    function FuncGoto(Index: Integer): TtkTokenKind;\r\n    function FuncGrep(Index: Integer): TtkTokenKind;\r\n    function FuncGt(Index: Integer): TtkTokenKind;\r\n    function FuncHex(Index: Integer): TtkTokenKind;\r\n    function FuncIf(Index: Integer): TtkTokenKind;\r\n    function FuncImport(Index: Integer): TtkTokenKind;\r\n    function FuncIndex(Index: Integer): TtkTokenKind;\r\n    function FuncInt(Index: Integer): TtkTokenKind;\r\n    function FuncInteger(Index: Integer): TtkTokenKind;\r\n    function FuncIoctl(Index: Integer): TtkTokenKind;\r\n    function FuncJoin(Index: Integer): TtkTokenKind;\r\n    function FuncKeys(Index: Integer): TtkTokenKind;\r\n    function FuncKill(Index: Integer): TtkTokenKind;\r\n    function FuncLast(Index: Integer): TtkTokenKind;\r\n    function FuncLc(Index: Integer): TtkTokenKind;\r\n    function FuncLcfirst(Index: Integer): TtkTokenKind;\r\n    function FuncLe(Index: Integer): TtkTokenKind;\r\n    function FuncLength(Index: Integer): TtkTokenKind;\r\n    function FuncLess(Index: Integer): TtkTokenKind;\r\n    function FuncLink(Index: Integer): TtkTokenKind;\r\n    function FuncListen(Index: Integer): TtkTokenKind;\r\n    function FuncLocal(Index: Integer): TtkTokenKind;\r\n    function FuncLocale(Index: Integer): TtkTokenKind;\r\n    function FuncLocaltime(Index: Integer): TtkTokenKind;\r\n    function FuncLog(Index: Integer): TtkTokenKind;\r\n    function FuncLstat(Index: Integer): TtkTokenKind;\r\n    function FuncLt(Index: Integer): TtkTokenKind;\r\n    function FuncM(Index: Integer): TtkTokenKind;\r\n    function FuncMap(Index: Integer): TtkTokenKind;\r\n    function FuncMkdir(Index: Integer): TtkTokenKind;\r\n    function FuncMsgctl(Index: Integer): TtkTokenKind;\r\n    function FuncMsgget(Index: Integer): TtkTokenKind;\r\n    function FuncMsgrcv(Index: Integer): TtkTokenKind;\r\n    function FuncMsgsnd(Index: Integer): TtkTokenKind;\r\n    function FuncMy(Index: Integer): TtkTokenKind;\r\n    function FuncNe(Index: Integer): TtkTokenKind;\r\n    function FuncNext(Index: Integer): TtkTokenKind;\r\n    function FuncNo(Index: Integer): TtkTokenKind;\r\n    function FuncNot(Index: Integer): TtkTokenKind;\r\n    function FuncOct(Index: Integer): TtkTokenKind;\r\n    function FuncOpen(Index: Integer): TtkTokenKind;\r\n    function FuncOpendir(Index: Integer): TtkTokenKind;\r\n    function FuncOr(Index: Integer): TtkTokenKind;\r\n    function FuncOrd(Index: Integer): TtkTokenKind;\r\n    function FuncPack(Index: Integer): TtkTokenKind;\r\n    function FuncPackage(Index: Integer): TtkTokenKind;\r\n    function FuncPipe(Index: Integer): TtkTokenKind;\r\n    function FuncPop(Index: Integer): TtkTokenKind;\r\n    function FuncPos(Index: Integer): TtkTokenKind;\r\n    function FuncPrint(Index: Integer): TtkTokenKind;\r\n    function FuncPush(Index: Integer): TtkTokenKind;\r\n    function FuncQ(Index: Integer): TtkTokenKind;\r\n    function FuncQq(Index: Integer): TtkTokenKind;\r\n    function FuncQuotemeta(Index: Integer): TtkTokenKind;\r\n    function FuncQw(Index: Integer): TtkTokenKind;\r\n    function FuncQx(Index: Integer): TtkTokenKind;\r\n    function FuncRand(Index: Integer): TtkTokenKind;\r\n    function FuncRead(Index: Integer): TtkTokenKind;\r\n    function FuncReaddir(Index: Integer): TtkTokenKind;\r\n    function FuncReadlink(Index: Integer): TtkTokenKind;\r\n    function FuncRecv(Index: Integer): TtkTokenKind;\r\n    function FuncRedo(Index: Integer): TtkTokenKind;\r\n    function FuncRef(Index: Integer): TtkTokenKind;\r\n    function FuncRename(Index: Integer): TtkTokenKind;\r\n    function FuncRequire(Index: Integer): TtkTokenKind;\r\n    function FuncReset(Index: Integer): TtkTokenKind;\r\n    function FuncReturn(Index: Integer): TtkTokenKind;\r\n    function FuncReverse(Index: Integer): TtkTokenKind;\r\n    function FuncRewinddir(Index: Integer): TtkTokenKind;\r\n    function FuncRindex(Index: Integer): TtkTokenKind;\r\n    function FuncRmdir(Index: Integer): TtkTokenKind;\r\n    function FuncScalar(Index: Integer): TtkTokenKind;\r\n    function FuncSeek(Index: Integer): TtkTokenKind;\r\n    function FuncSeekdir(Index: Integer): TtkTokenKind;\r\n    function FuncSelect(Index: Integer): TtkTokenKind;\r\n    function FuncSemctl(Index: Integer): TtkTokenKind;\r\n    function FuncSemget(Index: Integer): TtkTokenKind;\r\n    function FuncSemop(Index: Integer): TtkTokenKind;\r\n    function FuncSend(Index: Integer): TtkTokenKind;\r\n    function FuncSetgrent(Index: Integer): TtkTokenKind;\r\n    function FuncSethostent(Index: Integer): TtkTokenKind;\r\n    function FuncSetnetent(Index: Integer): TtkTokenKind;\r\n    function FuncSetpgrp(Index: Integer): TtkTokenKind;\r\n    function FuncSetpriority(Index: Integer): TtkTokenKind;\r\n    function FuncSetprotoent(Index: Integer): TtkTokenKind;\r\n    function FuncSetpwent(Index: Integer): TtkTokenKind;\r\n    function FuncSetservent(Index: Integer): TtkTokenKind;\r\n    function FuncSetsockopt(Index: Integer): TtkTokenKind;\r\n    function FuncShift(Index: Integer): TtkTokenKind;\r\n    function FuncShmctl(Index: Integer): TtkTokenKind;\r\n    function FuncShmget(Index: Integer): TtkTokenKind;\r\n    function FuncShmread(Index: Integer): TtkTokenKind;\r\n    function FuncShmwrite(Index: Integer): TtkTokenKind;\r\n    function FuncShutdown(Index: Integer): TtkTokenKind;\r\n    function FuncSigtrap(Index: Integer): TtkTokenKind;\r\n    function FuncSin(Index: Integer): TtkTokenKind;\r\n    function FuncSleep(Index: Integer): TtkTokenKind;\r\n    function FuncSocket(Index: Integer): TtkTokenKind;\r\n    function FuncSocketpair(Index: Integer): TtkTokenKind;\r\n    function FuncSort(Index: Integer): TtkTokenKind;\r\n    function FuncSplice(Index: Integer): TtkTokenKind;\r\n    function FuncSplit(Index: Integer): TtkTokenKind;\r\n    function FuncSprintf(Index: Integer): TtkTokenKind;\r\n    function FuncSqrt(Index: Integer): TtkTokenKind;\r\n    function FuncSrand(Index: Integer): TtkTokenKind;\r\n    function FuncStat(Index: Integer): TtkTokenKind;\r\n    function FuncStrict(Index: Integer): TtkTokenKind;\r\n    function FuncStudy(Index: Integer): TtkTokenKind;\r\n    function FuncSub(Index: Integer): TtkTokenKind;\r\n    function FuncSubs(Index: Integer): TtkTokenKind;\r\n    function FuncSubstr(Index: Integer): TtkTokenKind;\r\n    function FuncSymlink(Index: Integer): TtkTokenKind;\r\n    function FuncSyscall(Index: Integer): TtkTokenKind;\r\n    function FuncSysread(Index: Integer): TtkTokenKind;\r\n    function FuncSystem(Index: Integer): TtkTokenKind;\r\n    function FuncSyswrite(Index: Integer): TtkTokenKind;\r\n    function FuncTell(Index: Integer): TtkTokenKind;\r\n    function FuncTelldir(Index: Integer): TtkTokenKind;\r\n    function FuncTie(Index: Integer): TtkTokenKind;\r\n    function FuncTime(Index: Integer): TtkTokenKind;\r\n    function FuncTimes(Index: Integer): TtkTokenKind;\r\n    function FuncTr(Index: Integer): TtkTokenKind;\r\n    function FuncTruncate(Index: Integer): TtkTokenKind;\r\n    function FuncUc(Index: Integer): TtkTokenKind;\r\n    function FuncUcfirst(Index: Integer): TtkTokenKind;\r\n    function FuncUmask(Index: Integer): TtkTokenKind;\r\n    function FuncUndef(Index: Integer): TtkTokenKind;\r\n    function FuncUnless(Index: Integer): TtkTokenKind;\r\n    function FuncUnlink(Index: Integer): TtkTokenKind;\r\n    function FuncUnpack(Index: Integer): TtkTokenKind;\r\n    function FuncUnshift(Index: Integer): TtkTokenKind;\r\n    function FuncUntie(Index: Integer): TtkTokenKind;\r\n    function FuncUse(Index: Integer): TtkTokenKind;\r\n    function FuncUtime(Index: Integer): TtkTokenKind;\r\n    function FuncValues(Index: Integer): TtkTokenKind;\r\n    function FuncVars(Index: Integer): TtkTokenKind;\r\n    function FuncVec(Index: Integer): TtkTokenKind;\r\n    function FuncWait(Index: Integer): TtkTokenKind;\r\n    function FuncWaitpid(Index: Integer): TtkTokenKind;\r\n    function FuncWantarray(Index: Integer): TtkTokenKind;\r\n    function FuncWarn(Index: Integer): TtkTokenKind;\r\n    function FuncWhile(Index: Integer): TtkTokenKind;\r\n    function FuncWrite(Index: Integer): TtkTokenKind;\r\n    function FuncXor(Index: Integer): TtkTokenKind;\r\n    function HashKey(Str: PWideChar): Cardinal;\r\n    function IdentKind(MayBe: PWideChar): TtkTokenKind;\r\n    procedure InitIdent;\r\n    procedure AndSymbolProc;\r\n    procedure CRProc;\r\n    procedure ColonProc;\r\n    procedure CommentProc;\r\n    procedure EqualProc;\r\n    procedure GreaterProc;\r\n    procedure IdentProc;\r\n    procedure LFProc;\r\n    procedure LowerProc;\r\n    procedure MinusProc;\r\n    procedure NotSymbolProc;\r\n    procedure NullProc;\r\n    procedure NumberProc;\r\n    procedure OrSymbolProc;\r\n    procedure PlusProc;\r\n    procedure SlashProc;\r\n    procedure SpaceProc;\r\n    procedure StarProc;\r\n    procedure StringInterpProc;\r\n    procedure StringLiteralProc;\r\n    procedure SymbolProc;\r\n    procedure XOrSymbolProc;\r\n    procedure UnknownProc;\r\n  protected\r\n    function GetSampleSource: UnicodeString; override;\r\n    function IsFilterStored: Boolean; override;\r\n  public\r\n    class function GetLanguageName: string; override;\r\n    class function GetFriendlyLanguageName: UnicodeString; override;\r\n  public\r\n    constructor Create(AOwner: TComponent); override;\r\n    function GetDefaultAttribute(Index: integer): TSynHighlighterAttributes;\r\n      override;\r\n    function GetEol: Boolean; override;\r\n    function GetTokenID: TtkTokenKind;\r\n    function GetTokenAttribute: TSynHighlighterAttributes; override;\r\n    function GetTokenKind: integer; override;\r\n    function IsIdentChar(AChar: WideChar): Boolean; override;\r\n    procedure Next; override;\r\n  published\r\n    property CommentAttri: TSynHighlighterAttributes read fCommentAttri\r\n      write fCommentAttri;\r\n    property IdentifierAttri: TSynHighlighterAttributes read fIdentifierAttri\r\n      write fIdentifierAttri;\r\n    property InvalidAttri: TSynHighlighterAttributes read fInvalidAttri\r\n      write fInvalidAttri;\r\n    property KeyAttri: TSynHighlighterAttributes read fKeyAttri write fKeyAttri;\r\n    property NumberAttri: TSynHighlighterAttributes read fNumberAttri\r\n      write fNumberAttri;\r\n    property OperatorAttri: TSynHighlighterAttributes read fOperatorAttri\r\n      write fOperatorAttri;\r\n    property PragmaAttri: TSynHighlighterAttributes read fPragmaAttri\r\n      write fPragmaAttri;\r\n    property SpaceAttri: TSynHighlighterAttributes read fSpaceAttri\r\n      write fSpaceAttri;\r\n    property StringAttri: TSynHighlighterAttributes read fStringAttri\r\n      write fStringAttri;\r\n    property SymbolAttri: TSynHighlighterAttributes read fSymbolAttri\r\n      write fSymbolAttri;\r\n    property VariableAttri: TSynHighlighterAttributes read fVariableAttri\r\n      write fVariableAttri;\r\n  end;\r\n\r\nimplementation\r\n\r\nuses\r\n{$IFDEF SYN_CLX}\r\n  QSynEditStrConst;\r\n{$ELSE}\r\n  SynEditStrConst;\r\n{$ENDIF}\r\n\r\nconst\r\n  KeyWords: array[0..281] of UnicodeString = (\r\n    '$ACCUMULATOR', '$ARG', '$ARGV', '$BASETIME', '$CHILD_ERROR', '$DEBUGGING', \r\n    '$EFFECTIVE_GROUP_ID', '$EFFECTIVE_USER_ID', '$EGID', '$ENV', '$ERRNO', \r\n    '$EUID', '$EVAL_ERROR', '$EXECUTABLE_NAME', '$FORMAT_FORMFEED', \r\n    '$FORMAT_LINE_BREAK_CHARACTERS', '$FORMAT_LINES_LEFT', \r\n    '$FORMAT_LINES_PER_PAGE', '$FORMAT_NAME', '$FORMAT_PAGE_NUMBER', \r\n    '$FORMAT_TOP_NAME', '$GID', '$INPLACE_EDIT', '$INPUT_LINE_NUMBER', \r\n    '$INPUT_RECORD_SEPARATOR', '$LAST_PAREN_MATCH', '$LIST_SEPARATOR', '$MATCH', \r\n    '$MULTILINE_MATCHING', '$NR', '$OFMT', '$ORS', '$OS_ERROR', \r\n    '$OUTPUT_AUTOFLUSH', '$OUTPUT_FIELD_SEPARATOR', '$PERL_VERSION', '$PERLDB', \r\n    '$PID', '$POSTMATCH', '$PREMATCH', '$PROCESS_ID', '$PROGRAM_NAME', \r\n    '$REAL_GROUP_ID', '$REAL_USER_ID', '$RS', '$SIG', '$SUBSCRIPT_SEPARATOR', \r\n    '$SUBSEP', '$SYSTEM_FD_MAX', '$UID', '$WARNING', '%INC', '@ARGV', '@INC', \r\n    'abs', 'accept', 'alarm', 'and', 'atan2', 'bind', 'binmode', 'bless', \r\n    'caller', 'chdir', 'chmod', 'chomp', 'chop', 'chown', 'chr', 'chroot', \r\n    'close', 'closedir', 'cmp', 'connect', 'constant', 'cos', 'crypt', \r\n    'dbmclose', 'dbmopen', 'defined', 'delete', 'diagnostics', 'die', 'do', \r\n    'dump', 'each', 'else', 'elsif', 'endgrent', 'endhostent', 'endnetent', \r\n    'endprotoent', 'endpwent', 'endservent', 'eof', 'eq', 'eval', 'exec', \r\n    'exists', 'exit', 'exp', 'fcntl', 'fileno', 'flock', 'for', 'foreach', \r\n    'fork', 'format', 'formline', 'ge', 'getc', 'getgrent', 'getgrgid', \r\n    'getgrnam', 'gethostbyaddr', 'gethostbyname', 'gethostent', 'getlogin', \r\n    'getnetbyaddr', 'getnetbyname', 'getnetent', 'getpeername', 'getpgrp', \r\n    'getppid', 'getpriority', 'getprotobyname', 'getprotobynumber', \r\n    'getprotoent', 'getpwent', 'getpwnam', 'getpwuid', 'getservbyname', \r\n    'getservbyport', 'getservent', 'getsockname', 'getsockopt', 'glob', \r\n    'gmtime', 'goto', 'grep', 'gt', 'hex', 'if', 'import', 'index', 'int', \r\n    'integer', 'ioctl', 'join', 'keys', 'kill', 'last', 'lc', 'lcfirst', 'le', \r\n    'length', 'less', 'link', 'listen', 'local', 'locale', 'localtime', 'log', \r\n    'lstat', 'lt', 'm', 'map', 'mkdir', 'msgctl', 'msgget', 'msgrcv', 'msgsnd', \r\n    'my', 'ne', 'next', 'no', 'not', 'oct', 'open', 'opendir', 'or', 'ord', \r\n    'pack', 'package', 'pipe', 'pop', 'pos', 'print', 'push', 'q', 'qq', \r\n    'quotemeta', 'qw', 'qx', 'rand', 'read', 'readdir', 'readlink', 'recv', \r\n    'redo', 'ref', 'rename', 'require', 'reset', 'return', 'reverse', \r\n    'rewinddir', 'rindex', 'rmdir', 'scalar', 'seek', 'seekdir', 'select', \r\n    'semctl', 'semget', 'semop', 'send', 'setgrent', 'sethostent', 'setnetent', \r\n    'setpgrp', 'setpriority', 'setprotoent', 'setpwent', 'setservent', \r\n    'setsockopt', 'shift', 'shmctl', 'shmget', 'shmread', 'shmwrite', \r\n    'shutdown', 'sigtrap', 'sin', 'sleep', 'socket', 'socketpair', 'sort', \r\n    'splice', 'split', 'sprintf', 'sqrt', 'srand', 'stat', 'strict', 'study', \r\n    'sub', 'subs', 'substr', 'symlink', 'syscall', 'sysread', 'system', \r\n    'syswrite', 'tell', 'telldir', 'tie', 'time', 'times', 'tr', 'truncate', \r\n    'uc', 'ucfirst', 'umask', 'undef', 'unless', 'unlink', 'unpack', 'unshift', \r\n    'untie', 'use', 'utime', 'values', 'vars', 'vec', 'wait', 'waitpid', \r\n    'wantarray', 'warn', 'while', 'write', 'xor' \r\n  );\r\n\r\n  KeyIndices: array[0..2422] of Integer = (\r\n    -1, -1, 1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    62, -1, -1, -1, -1, -1, -1, 133, -1, -1, -1, -1, -1, -1, -1, -1, 10, -1, -1, \r\n    -1, -1, -1, -1, 212, 189, -1, -1, -1, -1, -1, -1, -1, 111, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, 55, -1, 242, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, 34, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 77, 247, \r\n    -1, -1, 102, -1, -1, -1, -1, -1, -1, -1, -1, -1, 60, -1, -1, -1, -1, -1, -1, \r\n    155, -1, -1, -1, -1, -1, -1, -1, -1, 9, -1, -1, -1, -1, -1, -1, -1, 254, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, 253, -1, 273, -1, -1, -1, 180, -1, -1, -1, -1, \r\n    41, -1, -1, 18, -1, 173, -1, -1, -1, -1, -1, -1, -1, -1, -1, 243, -1, 132, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 17, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 172, -1, 45, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 44, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 46, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, 208, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, 281, -1, 142, -1, -1, -1, -1, 233, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 23, -1, 7, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, 87, 179, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    161, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 0, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 256, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 165, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, 198, -1, -1, -1, -1, -1, 116, 124, -1, -1, 203, 47, -1, -1, -1, -1, \r\n    150, -1, -1, -1, 205, -1, -1, 152, -1, -1, 271, -1, -1, -1, -1, 76, 92, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 186, -1, -1, -1, 207, -1, -1, -1, \r\n    -1, -1, 72, -1, -1, -1, -1, -1, -1, -1, 175, -1, -1, -1, -1, -1, -1, 153, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, 11, -1, 170, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, 258, -1, -1, -1, -1, 99, -1, -1, -1, -1, 22, -1, -1, 33, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, 135, -1, -1, -1, -1, -1, -1, -1, -1, 227, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    259, 228, -1, -1, -1, -1, 115, -1, -1, 215, -1, -1, -1, -1, -1, -1, -1, 167, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 158, 40, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 174, -1, 169, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 4, -1, -1, -1, 59, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 197, -1, -1, 32, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 261, -1, -1, \r\n    276, -1, -1, -1, -1, -1, -1, -1, -1, 266, -1, -1, -1, -1, 101, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 144, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 75, -1, -1, 38, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, 134, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 190, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    2, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 262, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, 239, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, 202, -1, -1, 70, -1, -1, -1, -1, -1, -1, -1, -1, -1, 49, -1, -1, -1, -1, \r\n    -1, -1, -1, 112, -1, -1, 20, -1, -1, -1, -1, -1, 238, -1, -1, 8, -1, 249, \r\n    -1, -1, -1, -1, -1, -1, 246, -1, 232, 216, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, 146, 54, -1, -1, -1, -1, -1, -1, -1, -1, 39, -1, -1, -1, -1, -1, -1, \r\n    218, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    214, -1, -1, -1, -1, 277, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, 31, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 89, 183, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 6, -1, -1, -1, 79, -1, -1, -1, \r\n    -1, -1, 86, 63, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 53, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, 267, 48, 131, 91, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, 69, -1, -1, -1, -1, -1, 94, -1, -1, -1, -1, -1, -1, -1, 270, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, 109, -1, 166, -1, 73, -1, -1, -1, -1, -1, \r\n    -1, -1, 43, -1, -1, -1, -1, -1, -1, 279, -1, 26, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, 68, -1, 280, -1, -1, -1, -1, 61, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, 278, -1, 184, -1, -1, -1, -1, -1, -1, -1, -1, 206, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, 264, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    163, -1, -1, -1, -1, 52, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 81, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, 176, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, 21, -1, -1, -1, -1, -1, 117, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, 250, -1, -1, -1, -1, -1, -1, -1, 244, -1, -1, -1, \r\n    -1, -1, 129, -1, -1, -1, -1, -1, 95, -1, 234, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, 231, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 230, -1, 138, -1, -1, \r\n    -1, -1, -1, 191, -1, 200, -1, -1, -1, 125, -1, -1, 268, 108, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, 178, -1, -1, -1, -1, -1, -1, -1, 185, -1, -1, 66, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, 194, -1, 222, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, 143, -1, 226, 182, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 16, \r\n    -1, -1, -1, -1, -1, -1, 251, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, 192, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    113, -1, -1, -1, -1, -1, -1, -1, 37, -1, 71, -1, 15, -1, -1, -1, 154, 257, \r\n    -1, -1, -1, -1, 209, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, 160, -1, -1, -1, 126, -1, -1, -1, -1, -1, 58, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, 140, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    240, -1, -1, -1, -1, -1, -1, 241, -1, -1, -1, -1, -1, -1, 275, -1, -1, -1, \r\n    -1, -1, -1, -1, 36, -1, -1, -1, -1, -1, -1, -1, -1, 139, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, 100, -1, -1, 13, -1, -1, -1, -1, -1, -1, -1, 177, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, 223, -1, -1, -1, -1, -1, -1, 130, -1, -1, 97, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 224, -1, -1, -1, -1, -1, 196, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 120, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, 114, -1, 148, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, 93, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, 168, -1, -1, -1, 274, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, 137, 35, 159, -1, -1, -1, -1, -1, -1, -1, 260, -1, \r\n    -1, -1, -1, -1, 24, -1, 118, 245, -1, -1, 88, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, 211, 119, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, 187, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, 217, -1, -1, -1, -1, -1, 237, -1, -1, -1, -1, 188, 147, \r\n    -1, 50, -1, -1, -1, -1, -1, -1, 103, -1, -1, -1, -1, -1, 96, 181, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 14, -1, -1, -1, \r\n    -1, 210, 27, -1, 136, -1, -1, 106, -1, -1, -1, -1, -1, -1, -1, 107, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 236, -1, -1, -1, \r\n    -1, 141, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 85, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, 25, -1, 164, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 265, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, 193, -1, -1, -1, -1, 67, -1, -1, -1, -1, -1, \r\n    121, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 78, \r\n    -1, -1, -1, 51, -1, -1, -1, -1, -1, -1, -1, -1, 151, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 98, 213, -1, -1, -1, -1, 5, \r\n    -1, 219, -1, -1, -1, -1, 162, -1, -1, -1, -1, -1, 74, -1, -1, -1, -1, -1, \r\n    -1, -1, 221, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, 12, -1, 255, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 272, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, 56, -1, -1, -1, -1, 83, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    82, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 195, 225, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 30, -1, -1, -1, -1, -1, -1, 171, \r\n    -1, -1, -1, 157, 149, -1, -1, -1, -1, -1, -1, 127, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, 42, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, 252, -1, -1, -1, 65, 28, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    229, -1, -1, -1, -1, -1, -1, -1, 199, -1, -1, -1, 105, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, 64, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 248, -1, -1, -1, -1, 104, -1, -1, \r\n    -1, -1, -1, -1, 3, -1, -1, -1, -1, -1, -1, -1, 269, -1, -1, -1, -1, -1, -1, \r\n    -1, 220, 110, -1, -1, -1, 128, -1, -1, -1, -1, 235, 263, -1, -1, -1, -1, -1, \r\n    -1, -1, 201, -1, -1, -1, -1, -1, 29, -1, 156, -1, -1, -1, 19, -1, 123, -1, \r\n    204, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, 122, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, 57, -1, -1, 145, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, 84, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 90, -1, -1, -1, -1, -1, \r\n    80, -1, -1, -1, -1 \r\n  );\r\n\r\n{$Q-}\r\nfunction TSynPerlSyn.HashKey(Str: PWideChar): Cardinal;\r\nbegin\r\n  Result := 0;\r\n  while IsIdentChar(Str^) or CharInSet(Str^, ['$', '%', '@']) do\r\n  begin\r\n    Result := Result * 975 + Ord(Str^) * 515;\r\n    inc(Str);\r\n  end;\r\n  Result := Result mod 2423;\r\n  fStringLen := Str - fToIdent;\r\nend;\r\n{$Q+}\r\n\r\nfunction TSynPerlSyn.IdentKind(MayBe: PWideChar): TtkTokenKind;\r\nvar\r\n  Key: Cardinal;\r\nbegin\r\n  fToIdent := MayBe;\r\n  Key := HashKey(MayBe);\r\n  if Key <= High(fIdentFuncTable) then\r\n    Result := fIdentFuncTable[Key](KeyIndices[Key])\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nprocedure TSynPerlSyn.InitIdent;\r\nvar\r\n  i: Integer;\r\nbegin\r\n  for i := Low(fIdentFuncTable) to High(fIdentFuncTable) do\r\n    if KeyIndices[i] = -1 then\r\n      fIdentFuncTable[i] := AltFunc;\r\n\r\n  fIdentFuncTable[368] := Func36accumulator;\r\n  fIdentFuncTable[2] := Func36arg;\r\n  fIdentFuncTable[804] := Func36argv;\r\n  fIdentFuncTable[2272] := Func36basetime;\r\n  fIdentFuncTable[626] := Func36child95error;\r\n  fIdentFuncTable[2026] := Func36debugging;\r\n  fIdentFuncTable[981] := Func36effective95group95id;\r\n  fIdentFuncTable[317] := Func36effective95user95id;\r\n  fIdentFuncTable[876] := Func36egid;\r\n  fIdentFuncTable[141] := Func36env;\r\n  fIdentFuncTable[35] := Func36errno;\r\n  fIdentFuncTable[495] := Func36euid;\r\n  fIdentFuncTable[2067] := Func36eval95error;\r\n  fIdentFuncTable[1589] := Func36executable95name;\r\n  fIdentFuncTable[1835] := Func36format95formfeed;\r\n  fIdentFuncTable[1465] := Func36format95line95break95characters;\r\n  fIdentFuncTable[1415] := Func36format95lines95left;\r\n  fIdentFuncTable[201] := Func36format95lines95per95page;\r\n  fIdentFuncTable[172] := Func36format95name;\r\n  fIdentFuncTable[2319] := Func36format95page95number;\r\n  fIdentFuncTable[867] := Func36format95top95name;\r\n  fIdentFuncTable[1237] := Func36gid;\r\n  fIdentFuncTable[519] := Func36inplace95edit;\r\n  fIdentFuncTable[315] := Func36input95line95number;\r\n  fIdentFuncTable[1733] := Func36input95record95separator;\r\n  fIdentFuncTable[1923] := Func36last95paren95match;\r\n  fIdentFuncTable[1093] := Func36list95separator;\r\n  fIdentFuncTable[1841] := Func36match;\r\n  fIdentFuncTable[2201] := Func36multiline95matching;\r\n  fIdentFuncTable[2313] := Func36nr;\r\n  fIdentFuncTable[2149] := Func36ofmt;\r\n  fIdentFuncTable[955] := Func36ors;\r\n  fIdentFuncTable[648] := Func36os95error;\r\n  fIdentFuncTable[522] := Func36output95autoflush;\r\n  fIdentFuncTable[97] := Func36output95field95separator;\r\n  fIdentFuncTable[1718] := Func36perl95version;\r\n  fIdentFuncTable[1568] := Func36perldb;\r\n  fIdentFuncTable[1461] := Func36pid;\r\n  fIdentFuncTable[723] := Func36postmatch;\r\n  fIdentFuncTable[908] := Func36prematch;\r\n  fIdentFuncTable[594] := Func36process95id;\r\n  fIdentFuncTable[169] := Func36program95name;\r\n  fIdentFuncTable[2182] := Func36real95group95id;\r\n  fIdentFuncTable[1084] := Func36real95user95id;\r\n  fIdentFuncTable[238] := Func36rs;\r\n  fIdentFuncTable[220] := Func36sig;\r\n  fIdentFuncTable[261] := Func36subscript95separator;\r\n  fIdentFuncTable[427] := Func36subsep;\r\n  fIdentFuncTable[1016] := Func36system95fd95max;\r\n  fIdentFuncTable[856] := Func36uid;\r\n  fIdentFuncTable[1803] := Func36warning;\r\n  fIdentFuncTable[1992] := Func37inc;\r\n  fIdentFuncTable[1181] := Func64argv;\r\n  fIdentFuncTable[1004] := Func64inc;\r\n  fIdentFuncTable[899] := FuncAbs;\r\n  fIdentFuncTable[79] := FuncAccept;\r\n  fIdentFuncTable[2102] := FuncAlarm;\r\n  fIdentFuncTable[2365] := FuncAnd;\r\n  fIdentFuncTable[1501] := FuncAtan2;\r\n  fIdentFuncTable[630] := FuncBind;\r\n  fIdentFuncTable[125] := FuncBinmode;\r\n  fIdentFuncTable[1110] := FuncBless;\r\n  fIdentFuncTable[19] := FuncCaller;\r\n  fIdentFuncTable[992] := FuncChdir;\r\n  fIdentFuncTable[2236] := FuncChmod;\r\n  fIdentFuncTable[2200] := FuncChomp;\r\n  fIdentFuncTable[1341] := FuncChop;\r\n  fIdentFuncTable[1964] := FuncChown;\r\n  fIdentFuncTable[1103] := FuncChr;\r\n  fIdentFuncTable[1046] := FuncChroot;\r\n  fIdentFuncTable[846] := FuncClose;\r\n  fIdentFuncTable[1463] := FuncClosedir;\r\n  fIdentFuncTable[470] := FuncCmp;\r\n  fIdentFuncTable[1076] := FuncConnect;\r\n  fIdentFuncTable[2039] := FuncConstant;\r\n  fIdentFuncTable[720] := FuncCos;\r\n  fIdentFuncTable[447] := FuncCrypt;\r\n  fIdentFuncTable[111] := FuncDbmclose;\r\n  fIdentFuncTable[1988] := FuncDbmopen;\r\n  fIdentFuncTable[985] := FuncDefined;\r\n  fIdentFuncTable[2418] := FuncDelete;\r\n  fIdentFuncTable[1194] := FuncDiagnostics;\r\n  fIdentFuncTable[2120] := FuncDie;\r\n  fIdentFuncTable[2107] := FuncDo;\r\n  fIdentFuncTable[2381] := FuncDump;\r\n  fIdentFuncTable[1909] := FuncEach;\r\n  fIdentFuncTable[991] := FuncElse;\r\n  fIdentFuncTable[341] := FuncElsif;\r\n  fIdentFuncTable[1739] := FuncEndgrent;\r\n  fIdentFuncTable[967] := FuncEndhostent;\r\n  fIdentFuncTable[2412] := FuncEndnetent;\r\n  fIdentFuncTable[1018] := FuncEndprotoent;\r\n  fIdentFuncTable[448] := FuncEndpwent;\r\n  fIdentFuncTable[1681] := FuncEndservent;\r\n  fIdentFuncTable[1052] := FuncEof;\r\n  fIdentFuncTable[1278] := FuncEq;\r\n  fIdentFuncTable[1816] := FuncEval;\r\n  fIdentFuncTable[1618] := FuncExec;\r\n  fIdentFuncTable[2020] := FuncExists;\r\n  fIdentFuncTable[514] := FuncExit;\r\n  fIdentFuncTable[1586] := FuncExp;\r\n  fIdentFuncTable[686] := FuncFcntl;\r\n  fIdentFuncTable[115] := FuncFileno;\r\n  fIdentFuncTable[1810] := FuncFlock;\r\n  fIdentFuncTable[2265] := FuncFor;\r\n  fIdentFuncTable[2225] := FuncForeach;\r\n  fIdentFuncTable[1846] := FuncFork;\r\n  fIdentFuncTable[1854] := FuncFormat;\r\n  fIdentFuncTable[1319] := FuncFormline;\r\n  fIdentFuncTable[1072] := FuncGe;\r\n  fIdentFuncTable[2289] := FuncGetc;\r\n  fIdentFuncTable[51] := FuncGetgrent;\r\n  fIdentFuncTable[864] := FuncGetgrgid;\r\n  fIdentFuncTable[1453] := FuncGetgrnam;\r\n  fIdentFuncTable[1663] := FuncGethostbyaddr;\r\n  fIdentFuncTable[567] := FuncGethostbyname;\r\n  fIdentFuncTable[422] := FuncGethostent;\r\n  fIdentFuncTable[1243] := FuncGetlogin;\r\n  fIdentFuncTable[1735] := FuncGetnetbyaddr;\r\n  fIdentFuncTable[1749] := FuncGetnetbyname;\r\n  fIdentFuncTable[1647] := FuncGetnetent;\r\n  fIdentFuncTable[1970] := FuncGetpeername;\r\n  fIdentFuncTable[2348] := FuncGetpgrp;\r\n  fIdentFuncTable[2321] := FuncGetppid;\r\n  fIdentFuncTable[423] := FuncGetpriority;\r\n  fIdentFuncTable[1315] := FuncGetprotobyname;\r\n  fIdentFuncTable[1495] := FuncGetprotobynumber;\r\n  fIdentFuncTable[2168] := FuncGetprotoent;\r\n  fIdentFuncTable[2293] := FuncGetpwent;\r\n  fIdentFuncTable[1272] := FuncGetpwnam;\r\n  fIdentFuncTable[1615] := FuncGetpwuid;\r\n  fIdentFuncTable[1017] := FuncGetservbyname;\r\n  fIdentFuncTable[186] := FuncGetservbyport;\r\n  fIdentFuncTable[26] := FuncGetservent;\r\n  fIdentFuncTable[737] := FuncGetsockname;\r\n  fIdentFuncTable[531] := FuncGetsockopt;\r\n  fIdentFuncTable[1843] := FuncGlob;\r\n  fIdentFuncTable[1717] := FuncGmtime;\r\n  fIdentFuncTable[1303] := FuncGoto;\r\n  fIdentFuncTable[1577] := FuncGrep;\r\n  fIdentFuncTable[1528] := FuncGt;\r\n  fIdentFuncTable[1896] := FuncHex;\r\n  fIdentFuncTable[292] := FuncIf;\r\n  fIdentFuncTable[1381] := FuncImport;\r\n  fIdentFuncTable[708] := FuncIndex;\r\n  fIdentFuncTable[2368] := FuncInt;\r\n  fIdentFuncTable[898] := FuncInteger;\r\n  fIdentFuncTable[1801] := FuncIoctl;\r\n  fIdentFuncTable[1665] := FuncJoin;\r\n  fIdentFuncTable[2161] := FuncKeys;\r\n  fIdentFuncTable[432] := FuncKill;\r\n  fIdentFuncTable[2001] := FuncLast;\r\n  fIdentFuncTable[439] := FuncLc;\r\n  fIdentFuncTable[485] := FuncLcfirst;\r\n  fIdentFuncTable[1469] := FuncLe;\r\n  fIdentFuncTable[132] := FuncLength;\r\n  fIdentFuncTable[2315] := FuncLess;\r\n  fIdentFuncTable[2160] := FuncLink;\r\n  fIdentFuncTable[593] := FuncListen;\r\n  fIdentFuncTable[1719] := FuncLocal;\r\n  fIdentFuncTable[1491] := FuncLocale;\r\n  fIdentFuncTable[357] := FuncLocaltime;\r\n  fIdentFuncTable[2033] := FuncLog;\r\n  fIdentFuncTable[1176] := FuncLstat;\r\n  fIdentFuncTable[1925] := FuncLt;\r\n  fIdentFuncTable[406] := FuncM;\r\n  fIdentFuncTable[1074] := FuncMap;\r\n  fIdentFuncTable[578] := FuncMkdir;\r\n  fIdentFuncTable[1701] := FuncMsgctl;\r\n  fIdentFuncTable[613] := FuncMsgget;\r\n  fIdentFuncTable[497] := FuncMsgrcv;\r\n  fIdentFuncTable[2156] := FuncMsgsnd;\r\n  fIdentFuncTable[218] := FuncMy;\r\n  fIdentFuncTable[174] := FuncNe;\r\n  fIdentFuncTable[611] := FuncNext;\r\n  fIdentFuncTable[478] := FuncNo;\r\n  fIdentFuncTable[1217] := FuncNot;\r\n  fIdentFuncTable[1597] := FuncOct;\r\n  fIdentFuncTable[1330] := FuncOpen;\r\n  fIdentFuncTable[342] := FuncOpendir;\r\n  fIdentFuncTable[164] := FuncOr;\r\n  fIdentFuncTable[1817] := FuncOrd;\r\n  fIdentFuncTable[1384] := FuncPack;\r\n  fIdentFuncTable[968] := FuncPackage;\r\n  fIdentFuncTable[1125] := FuncPipe;\r\n  fIdentFuncTable[1338] := FuncPop;\r\n  fIdentFuncTable[460] := FuncPos;\r\n  fIdentFuncTable[1768] := FuncPrint;\r\n  fIdentFuncTable[1800] := FuncPush;\r\n  fIdentFuncTable[43] := FuncQ;\r\n  fIdentFuncTable[777] := FuncQq;\r\n  fIdentFuncTable[1309] := FuncQuotemeta;\r\n  fIdentFuncTable[1444] := FuncQw;\r\n  fIdentFuncTable[1959] := FuncQx;\r\n  fIdentFuncTable[1367] := FuncRand;\r\n  fIdentFuncTable[2133] := FuncRead;\r\n  fIdentFuncTable[1635] := FuncReaddir;\r\n  fIdentFuncTable[645] := FuncReadlink;\r\n  fIdentFuncTable[416] := FuncRecv;\r\n  fIdentFuncTable[2221] := FuncRedo;\r\n  fIdentFuncTable[1311] := FuncRef;\r\n  fIdentFuncTable[2307] := FuncRename;\r\n  fIdentFuncTable[843] := FuncRequire;\r\n  fIdentFuncTable[426] := FuncReset;\r\n  fIdentFuncTable[2323] := FuncReturn;\r\n  fIdentFuncTable[436] := FuncReverse;\r\n  fIdentFuncTable[1134] := FuncRewinddir;\r\n  fIdentFuncTable[464] := FuncRindex;\r\n  fIdentFuncTable[272] := FuncRmdir;\r\n  fIdentFuncTable[1475] := FuncScalar;\r\n  fIdentFuncTable[1840] := FuncSeek;\r\n  fIdentFuncTable[1748] := FuncSeekdir;\r\n  fIdentFuncTable[42] := FuncSelect;\r\n  fIdentFuncTable[2021] := FuncSemctl;\r\n  fIdentFuncTable[933] := FuncSemget;\r\n  fIdentFuncTable[570] := FuncSemop;\r\n  fIdentFuncTable[888] := FuncSend;\r\n  fIdentFuncTable[1789] := FuncSetgrent;\r\n  fIdentFuncTable[915] := FuncSethostent;\r\n  fIdentFuncTable[2028] := FuncSetnetent;\r\n  fIdentFuncTable[2288] := FuncSetpgrp;\r\n  fIdentFuncTable[2047] := FuncSetpriority;\r\n  fIdentFuncTable[1369] := FuncSetprotoent;\r\n  fIdentFuncTable[1608] := FuncSetpwent;\r\n  fIdentFuncTable[1629] := FuncSetservent;\r\n  fIdentFuncTable[2134] := FuncSetsockopt;\r\n  fIdentFuncTable[1383] := FuncShift;\r\n  fIdentFuncTable[540] := FuncShmctl;\r\n  fIdentFuncTable[562] := FuncShmget;\r\n  fIdentFuncTable[2213] := FuncShmread;\r\n  fIdentFuncTable[1301] := FuncShmwrite;\r\n  fIdentFuncTable[1289] := FuncShutdown;\r\n  fIdentFuncTable[887] := FuncSigtrap;\r\n  fIdentFuncTable[297] := FuncSin;\r\n  fIdentFuncTable[1280] := FuncSleep;\r\n  fIdentFuncTable[2298] := FuncSocket;\r\n  fIdentFuncTable[1891] := FuncSocketpair;\r\n  fIdentFuncTable[1795] := FuncSort;\r\n  fIdentFuncTable[873] := FuncSplice;\r\n  fIdentFuncTable[830] := FuncSplit;\r\n  fIdentFuncTable[1546] := FuncSprintf;\r\n  fIdentFuncTable[1553] := FuncSqrt;\r\n  fIdentFuncTable[81] := FuncSrand;\r\n  fIdentFuncTable[184] := FuncStat;\r\n  fIdentFuncTable[1266] := FuncStrict;\r\n  fIdentFuncTable[1736] := FuncStudy;\r\n  fIdentFuncTable[885] := FuncSub;\r\n  fIdentFuncTable[112] := FuncSubs;\r\n  fIdentFuncTable[2260] := FuncSubstr;\r\n  fIdentFuncTable[878] := FuncSymlink;\r\n  fIdentFuncTable[1258] := FuncSyscall;\r\n  fIdentFuncTable[1422] := FuncSysread;\r\n  fIdentFuncTable[2196] := FuncSystem;\r\n  fIdentFuncTable[158] := FuncSyswrite;\r\n  fIdentFuncTable[149] := FuncTell;\r\n  fIdentFuncTable[2069] := FuncTelldir;\r\n  fIdentFuncTable[387] := FuncTie;\r\n  fIdentFuncTable[1470] := FuncTime;\r\n  fIdentFuncTable[509] := FuncTimes;\r\n  fIdentFuncTable[561] := FuncTr;\r\n  fIdentFuncTable[1727] := FuncTruncate;\r\n  fIdentFuncTable[669] := FuncUc;\r\n  fIdentFuncTable[819] := FuncUcfirst;\r\n  fIdentFuncTable[2299] := FuncUmask;\r\n  fIdentFuncTable[1162] := FuncUndef;\r\n  fIdentFuncTable[1946] := FuncUnless;\r\n  fIdentFuncTable[681] := FuncUnlink;\r\n  fIdentFuncTable[1015] := FuncUnpack;\r\n  fIdentFuncTable[1318] := FuncUnshift;\r\n  fIdentFuncTable[2280] := FuncUntie;\r\n  fIdentFuncTable[1060] := FuncUse;\r\n  fIdentFuncTable[442] := FuncUtime;\r\n  fIdentFuncTable[2080] := FuncValues;\r\n  fIdentFuncTable[160] := FuncVars;\r\n  fIdentFuncTable[1705] := FuncVec;\r\n  fIdentFuncTable[1560] := FuncWait;\r\n  fIdentFuncTable[672] := FuncWaitpid;\r\n  fIdentFuncTable[938] := FuncWantarray;\r\n  fIdentFuncTable[1123] := FuncWarn;\r\n  fIdentFuncTable[1091] := FuncWhile;\r\n  fIdentFuncTable[1105] := FuncWrite;\r\n  fIdentFuncTable[290] := FuncXor;\r\nend;\r\n\r\nfunction TSynPerlSyn.AltFunc(Index: Integer): TtkTokenKind;\r\nbegin\r\n  Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.Func36accumulator(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkVariable\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.Func36arg(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkVariable\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.Func36argv(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkVariable\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.Func36basetime(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkVariable\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.Func36child95error(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkVariable\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.Func36debugging(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkVariable\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.Func36effective95group95id(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkVariable\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.Func36effective95user95id(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkVariable\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.Func36egid(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkVariable\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.Func36env(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkVariable\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.Func36errno(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkVariable\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.Func36euid(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkVariable\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.Func36eval95error(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkVariable\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.Func36executable95name(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkVariable\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.Func36format95formfeed(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkVariable\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.Func36format95line95break95characters(Index: Integer):\r\n  TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkVariable\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.Func36format95lines95left(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkVariable\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.Func36format95lines95per95page(Index: Integer):\r\n  TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkVariable\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.Func36format95name(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkVariable\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.Func36format95page95number(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkVariable\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.Func36format95top95name(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkVariable\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.Func36gid(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkVariable\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.Func36inplace95edit(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkVariable\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.Func36input95line95number(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkVariable\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.Func36input95record95separator(Index: Integer):\r\n  TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkVariable\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.Func36last95paren95match(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkVariable\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.Func36list95separator(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkVariable\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.Func36match(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkVariable\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.Func36multiline95matching(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkVariable\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.Func36nr(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkVariable\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.Func36ofmt(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkVariable\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.Func36ors(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkVariable\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.Func36os95error(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkVariable\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.Func36output95autoflush(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkVariable\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.Func36output95field95separator(Index: Integer):\r\n  TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkVariable\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.Func36perl95version(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkVariable\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.Func36perldb(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkVariable\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.Func36pid(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkVariable\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.Func36postmatch(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkVariable\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.Func36prematch(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkVariable\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.Func36process95id(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkVariable\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.Func36program95name(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkVariable\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.Func36real95group95id(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkVariable\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.Func36real95user95id(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkVariable\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.Func36rs(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkVariable\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.Func36sig(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkVariable\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.Func36subscript95separator(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkVariable\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.Func36subsep(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkVariable\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.Func36system95fd95max(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkVariable\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.Func36uid(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkVariable\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.Func36warning(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkVariable\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.Func37inc(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkVariable\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.Func64argv(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkVariable\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.Func64inc(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkVariable\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.FuncAbs(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.FuncAccept(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.FuncAlarm(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.FuncAnd(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkOperator\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.FuncAtan2(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.FuncBind(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.FuncBinmode(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.FuncBless(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.FuncCaller(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.FuncChdir(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.FuncChmod(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.FuncChomp(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.FuncChop(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.FuncChown(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.FuncChr(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.FuncChroot(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.FuncClose(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.FuncClosedir(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.FuncCmp(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkOperator\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.FuncConnect(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.FuncConstant(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkPragma\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.FuncCos(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.FuncCrypt(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.FuncDbmclose(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.FuncDbmopen(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.FuncDefined(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.FuncDelete(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.FuncDiagnostics(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkPragma\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.FuncDie(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.FuncDo(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.FuncDump(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.FuncEach(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.FuncElse(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.FuncElsif(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.FuncEndgrent(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.FuncEndhostent(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.FuncEndnetent(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.FuncEndprotoent(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.FuncEndpwent(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.FuncEndservent(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.FuncEof(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.FuncEq(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkOperator\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.FuncEval(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.FuncExec(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.FuncExists(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.FuncExit(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.FuncExp(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.FuncFcntl(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.FuncFileno(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.FuncFlock(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.FuncFor(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.FuncForeach(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.FuncFork(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.FuncFormat(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.FuncFormline(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.FuncGe(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkOperator\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.FuncGetc(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.FuncGetgrent(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.FuncGetgrgid(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.FuncGetgrnam(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.FuncGethostbyaddr(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.FuncGethostbyname(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.FuncGethostent(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.FuncGetlogin(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.FuncGetnetbyaddr(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.FuncGetnetbyname(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.FuncGetnetent(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.FuncGetpeername(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.FuncGetpgrp(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.FuncGetppid(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.FuncGetpriority(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.FuncGetprotobyname(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.FuncGetprotobynumber(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.FuncGetprotoent(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.FuncGetpwent(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.FuncGetpwnam(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.FuncGetpwuid(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.FuncGetservbyname(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.FuncGetservbyport(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.FuncGetservent(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.FuncGetsockname(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.FuncGetsockopt(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.FuncGlob(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.FuncGmtime(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.FuncGoto(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.FuncGrep(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.FuncGt(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkOperator\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.FuncHex(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.FuncIf(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.FuncImport(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.FuncIndex(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.FuncInt(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.FuncInteger(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkPragma\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.FuncIoctl(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.FuncJoin(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.FuncKeys(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.FuncKill(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.FuncLast(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.FuncLc(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.FuncLcfirst(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.FuncLe(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkOperator\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.FuncLength(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.FuncLess(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkPragma\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.FuncLink(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.FuncListen(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.FuncLocal(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.FuncLocale(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkPragma\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.FuncLocaltime(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.FuncLog(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.FuncLstat(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.FuncLt(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkOperator\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.FuncM(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.FuncMap(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.FuncMkdir(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.FuncMsgctl(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.FuncMsgget(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.FuncMsgrcv(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.FuncMsgsnd(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.FuncMy(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.FuncNe(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkOperator\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.FuncNext(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.FuncNo(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.FuncNot(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkOperator\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.FuncOct(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.FuncOpen(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.FuncOpendir(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.FuncOr(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkOperator\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.FuncOrd(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.FuncPack(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.FuncPackage(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.FuncPipe(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.FuncPop(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.FuncPos(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.FuncPrint(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.FuncPush(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.FuncQ(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.FuncQq(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.FuncQuotemeta(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.FuncQw(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.FuncQx(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.FuncRand(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.FuncRead(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.FuncReaddir(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.FuncReadlink(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.FuncRecv(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.FuncRedo(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.FuncRef(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.FuncRename(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.FuncRequire(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.FuncReset(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.FuncReturn(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.FuncReverse(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.FuncRewinddir(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.FuncRindex(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.FuncRmdir(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.FuncScalar(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.FuncSeek(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.FuncSeekdir(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.FuncSelect(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.FuncSemctl(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.FuncSemget(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.FuncSemop(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.FuncSend(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.FuncSetgrent(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.FuncSethostent(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.FuncSetnetent(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.FuncSetpgrp(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.FuncSetpriority(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.FuncSetprotoent(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.FuncSetpwent(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.FuncSetservent(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.FuncSetsockopt(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.FuncShift(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.FuncShmctl(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.FuncShmget(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.FuncShmread(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.FuncShmwrite(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.FuncShutdown(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.FuncSigtrap(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkPragma\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.FuncSin(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.FuncSleep(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.FuncSocket(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.FuncSocketpair(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.FuncSort(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.FuncSplice(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.FuncSplit(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.FuncSprintf(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.FuncSqrt(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.FuncSrand(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.FuncStat(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.FuncStrict(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkPragma\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.FuncStudy(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.FuncSub(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.FuncSubs(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkPragma\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.FuncSubstr(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.FuncSymlink(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.FuncSyscall(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.FuncSysread(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.FuncSystem(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.FuncSyswrite(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.FuncTell(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.FuncTelldir(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.FuncTie(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.FuncTime(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.FuncTimes(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.FuncTr(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.FuncTruncate(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.FuncUc(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.FuncUcfirst(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.FuncUmask(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.FuncUndef(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.FuncUnless(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.FuncUnlink(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.FuncUnpack(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.FuncUnshift(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.FuncUntie(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.FuncUse(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.FuncUtime(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.FuncValues(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.FuncVars(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkPragma\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.FuncVec(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.FuncWait(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.FuncWaitpid(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.FuncWantarray(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.FuncWarn(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.FuncWhile(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.FuncWrite(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynPerlSyn.FuncXor(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkOperator\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nconstructor TSynPerlSyn.Create(AOwner: TComponent);\r\nbegin\r\n  inherited Create(AOwner);\r\n\r\n  fCaseSensitive := True;\r\n\r\n  fCommentAttri := TSynHighlighterAttributes.Create(SYNS_AttrComment, SYNS_FriendlyAttrComment);\r\n  fCommentAttri.Style:= [fsItalic];\r\n  AddAttribute(fCommentAttri);\r\n  fIdentifierAttri := TSynHighlighterAttributes.Create(SYNS_AttrIdentifier, SYNS_FriendlyAttrIdentifier);\r\n  AddAttribute(fIdentifierAttri);\r\n  fInvalidAttri := TSynHighlighterAttributes.Create(SYNS_AttrIllegalChar, SYNS_FriendlyAttrIllegalChar);\r\n  AddAttribute(fInvalidAttri);\r\n  fKeyAttri := TSynHighlighterAttributes.Create(SYNS_AttrReservedWord, SYNS_FriendlyAttrReservedWord);\r\n  fKeyAttri.Style:= [fsBold];\r\n  AddAttribute(fKeyAttri);\r\n  fNumberAttri := TSynHighlighterAttributes.Create(SYNS_AttrNumber, SYNS_FriendlyAttrNumber);\r\n  AddAttribute(fNumberAttri);\r\n  fOperatorAttri := TSynHighlighterAttributes.Create(SYNS_AttrOperator, SYNS_FriendlyAttrOperator);\r\n  AddAttribute(fOperatorAttri);\r\n  fPragmaAttri := TSynHighlighterAttributes.Create(SYNS_AttrPragma, SYNS_FriendlyAttrPragma);\r\n  fPragmaAttri.Style := [fsBold];\r\n  AddAttribute(fPragmaAttri);\r\n  fSpaceAttri := TSynHighlighterAttributes.Create(SYNS_AttrSpace, SYNS_FriendlyAttrSpace);\r\n  AddAttribute(fSpaceAttri);\r\n  fStringAttri := TSynHighlighterAttributes.Create(SYNS_AttrString, SYNS_FriendlyAttrString);\r\n  AddAttribute(fStringAttri);\r\n  fSymbolAttri := TSynHighlighterAttributes.Create(SYNS_AttrSymbol, SYNS_FriendlyAttrSymbol);\r\n  AddAttribute(fSymbolAttri);\r\n  fVariableAttri := TSynHighlighterAttributes.Create(SYNS_AttrVariable, SYNS_FriendlyAttrVariable);\r\n  fVariableAttri.Style := [fsBold];\r\n  AddAttribute(fVariableAttri);\r\n  SetAttributesOnChange(DefHighlightChange);\r\n  InitIdent;\r\n  fDefaultFilter := SYNS_FilterPerl;\r\nend; { Create }\r\n\r\nprocedure TSynPerlSyn.AndSymbolProc;\r\nbegin\r\n  case FLine[Run + 1] of\r\n    '=':                               {bit and assign}\r\n      begin\r\n        inc(Run, 2);\r\n        fTokenID := tkSymbol;\r\n      end;\r\n    '&':\r\n      begin\r\n        if FLine[Run + 2] = '=' then   {logical and assign}\r\n          inc(Run, 3)\r\n        else                           {logical and}\r\n          inc(Run, 2);\r\n        fTokenID := tkSymbol;\r\n      end;\r\n  else                                 {bit and}\r\n    begin\r\n      inc(Run);\r\n      fTokenID := tkSymbol;\r\n    end;\r\n  end;\r\nend;\r\n\r\nprocedure TSynPerlSyn.CRProc;\r\nbegin\r\n  fTokenID := tkSpace;\r\n  Case FLine[Run + 1] of\r\n    #10: inc(Run, 2);\r\n  else inc(Run);\r\n  end;\r\nend;\r\n\r\nprocedure TSynPerlSyn.ColonProc;\r\nbegin\r\n  Case FLine[Run + 1] of\r\n    ':':                               {double colon}\r\n      begin\r\n        inc(Run, 2);\r\n        fTokenID := tkSymbol;\r\n      end;\r\n  else                                 {colon}\r\n    begin\r\n      inc(Run);\r\n      fTokenID := tkSymbol;\r\n    end;\r\n  end;\r\nend;\r\n\r\nprocedure TSynPerlSyn.CommentProc;\r\nbegin\r\n  fTokenID := tkComment;\r\n  repeat\r\n    case FLine[Run] of\r\n      #0, #10, #13: break;\r\n    end;\r\n    inc(Run);\r\n  until FLine[Run] = #0;\r\nend;\r\n\r\nprocedure TSynPerlSyn.EqualProc;\r\nbegin\r\n  case FLine[Run + 1] of\r\n    '=':                               {logical equal}\r\n      begin\r\n        inc(Run, 2);\r\n        fTokenID := tkSymbol;\r\n      end;\r\n    '>':                               {digraph}\r\n      begin\r\n        inc(Run, 2);\r\n        fTokenID := tkSymbol;\r\n      end;\r\n    '~':                               {bind scalar to pattern}\r\n      begin\r\n        inc(Run, 2);\r\n        fTokenID := tkSymbol;\r\n      end;\r\n  else                                 {assign}\r\n    begin\r\n      inc(Run);\r\n      fTokenID := tkSymbol;\r\n    end;\r\n  end;\r\nend;\r\n\r\nprocedure TSynPerlSyn.GreaterProc;\r\nbegin\r\n  Case FLine[Run + 1] of\r\n    '=':                               {greater than or equal to}\r\n      begin\r\n        inc(Run, 2);\r\n        fTokenID := tkSymbol;\r\n      end;\r\n    '>':\r\n      begin\r\n        if FLine[Run + 2] = '=' then   {shift right assign}\r\n          inc(Run, 3)\r\n        else                           {shift right}\r\n          inc(Run, 2);\r\n        fTokenID := tkSymbol;\r\n      end;\r\n  else                                 {greater than}\r\n    begin\r\n      inc(Run);\r\n      fTokenID := tkSymbol;\r\n    end;\r\n  end;\r\nend;\r\n\r\nprocedure TSynPerlSyn.IdentProc;\r\nbegin\r\n  case FLine[Run] of\r\n    '$':\r\n      begin\r\n        Case FLine[Run + 1] of\r\n          '!'..'+', '-'..'@', '['..']', '_', '`', '|', '~':\r\n            begin                      {predefined variables}\r\n              inc(Run, 2);\r\n              fTokenID := tkVariable;\r\n              exit;\r\n            end;\r\n          '^':\r\n            begin\r\n              Case FLine[Run + 2] of\r\n                'A', 'D', 'F', 'I', 'L', 'P', 'T', 'W', 'X':\r\n                  begin                {predefined variables}\r\n                    inc(Run, 3);\r\n                    fTokenID := tkVariable;\r\n                    exit;\r\n                  end;\r\n                #0, #10, #13:          {predefined variables}\r\n                  begin\r\n                    inc(Run, 2);\r\n                    fTokenID := tkVariable;\r\n                    exit;\r\n                  end;\r\n              end;\r\n            end;\r\n        end;\r\n      end;\r\n    '%':\r\n      begin\r\n        Case FLine[Run + 1] of\r\n          '=':                         {mod assign}\r\n            begin\r\n              inc(Run, 2);\r\n              fTokenID := tkSymbol;\r\n              exit;\r\n            end;\r\n          #0, #10, #13:                {mod}\r\n            begin\r\n              inc(Run);\r\n              fTokenID := tkSymbol;\r\n              exit;\r\n            end;\r\n        end;\r\n      end;\r\n    'x':\r\n      begin\r\n        Case FLine[Run + 1] of\r\n          '=':                         {repetition assign}\r\n            begin\r\n              inc(Run, 2);\r\n              fTokenID := tkSymbol;\r\n              exit;\r\n            end;\r\n          #0, #10, #13:                {repetition}\r\n            begin\r\n              inc(Run);\r\n              fTokenID := tkSymbol;\r\n              exit;\r\n            end;\r\n        end;\r\n      end;\r\n  end;\r\n  {regular identifier}\r\n  fTokenID := IdentKind((fLine + Run));\r\n  inc(Run, fStringLen);\r\n  while IsIdentChar(fLine[Run]) do inc(Run);\r\nend;\r\n\r\nprocedure TSynPerlSyn.LFProc;\r\nbegin\r\n  fTokenID := tkSpace;\r\n  inc(Run);\r\nend;\r\n\r\nprocedure TSynPerlSyn.LowerProc;\r\nbegin\r\n  case FLine[Run + 1] of\r\n    '=':\r\n      begin\r\n        if FLine[Run + 2] = '>' then   {compare - less than, equal, greater}\r\n          inc(Run, 3)\r\n        else                           {less than or equal to}\r\n          inc(Run, 2);\r\n        fTokenID := tkSymbol;\r\n      end;\r\n    '<':\r\n      begin\r\n        if FLine[Run + 2] = '=' then   {shift left assign}\r\n          inc(Run, 3)\r\n        else                           {shift left}\r\n          inc(Run, 2);\r\n        fTokenID := tkSymbol;\r\n      end;\r\n  else                                 {less than}\r\n    begin\r\n      inc(Run);\r\n      fTokenID := tkSymbol;\r\n    end;\r\n  end;\r\nend;\r\n\r\nprocedure TSynPerlSyn.MinusProc;\r\nbegin\r\n  case FLine[Run + 1] of\r\n    '=':                               {subtract assign}\r\n      begin\r\n        inc(Run, 2);\r\n        fTokenID := tkSymbol;\r\n      end;\r\n    '-':                               {decrement}\r\n      begin\r\n        inc(Run, 2);\r\n        fTokenID := tkSymbol;\r\n      end;\r\n    '>':                               {arrow}\r\n      begin\r\n        inc(Run, 2);\r\n        fTokenID := tkSymbol;\r\n      end;\r\n  else                                 {subtract}\r\n    begin\r\n      inc(Run);\r\n      fTokenID := tkSymbol;\r\n    end;\r\n  end;\r\nend;\r\n\r\nprocedure TSynPerlSyn.NotSymbolProc;\r\nbegin\r\n  case FLine[Run + 1] of\r\n    '~':                               {logical negated bind like =~}\r\n      begin\r\n        inc(Run, 2);\r\n        fTokenID := tkSymbol;\r\n      end;\r\n    '=':                               {not equal}\r\n      begin\r\n        inc(Run, 2);\r\n        fTokenID := tkSymbol;\r\n      end;\r\n  else                                 {not}\r\n    begin\r\n      inc(Run);\r\n      fTokenID := tkSymbol;\r\n    end;\r\n  end;\r\nend;\r\n\r\nprocedure TSynPerlSyn.NullProc;\r\nbegin\r\n  fTokenID := tkNull;\r\n  inc(Run);\r\nend;\r\n\r\nprocedure TSynPerlSyn.NumberProc;\r\n\r\n  function IsNumberChar: Boolean;\r\n  begin\r\n    case fLine[Run] of\r\n      '0'..'9', '-', '_', '.', 'A'..'F', 'a'..'f', 'x', 'X':\r\n        Result := True;\r\n      else\r\n        Result := False;\r\n    end;\r\n  end;\r\n\r\nbegin\r\n  if FLine[Run] = '.' then\r\n  begin\r\n    case FLine[Run + 1] of\r\n      '.':\r\n        begin\r\n          inc(Run, 2);\r\n          if FLine[Run] = '.' then     {sed range}\r\n            inc(Run);\r\n\r\n          fTokenID := tkSymbol;        {range}\r\n          exit;\r\n        end;\r\n      '=':\r\n        begin\r\n          inc(Run, 2);\r\n          fTokenID := tkSymbol;        {concatenation assign}\r\n          exit;\r\n        end;\r\n      'a'..'z', 'A'..'Z', '_':\r\n        begin\r\n          fTokenID := tkSymbol;        {concatenation}\r\n          inc(Run);\r\n          exit;\r\n        end;\r\n    end;\r\n  end;\r\n  inc(Run);\r\n  fTokenID := tkNumber;\r\n  while IsNumberChar do\r\n  begin\r\n    case FLine[Run] of\r\n      '.':\r\n        if FLine[Run + 1] = '.' then break;\r\n      '-':                             {check for e notation}\r\n        if not ((FLine[Run + 1] = 'e') or (FLine[Run + 1] = 'E')) then break;\r\n    end;\r\n    inc(Run);\r\n  end;\r\nend;\r\n\r\nprocedure TSynPerlSyn.OrSymbolProc;\r\nbegin\r\n  case FLine[Run + 1] of\r\n    '=':                               {bit or assign}\r\n      begin\r\n        inc(Run, 2);\r\n        fTokenID := tkSymbol;\r\n      end;\r\n    '|':\r\n      begin\r\n        if FLine[Run + 2] = '=' then   {logical or assign}\r\n          inc(Run, 3)\r\n        else                           {logical or}\r\n          inc(Run, 2);\r\n        fTokenID := tkSymbol;\r\n      end;\r\n  else                                 {bit or}\r\n    begin\r\n      inc(Run);\r\n      fTokenID := tkSymbol;\r\n    end;\r\n  end;\r\nend;\r\n\r\nprocedure TSynPerlSyn.PlusProc;\r\nbegin\r\n  case FLine[Run + 1] of\r\n    '=':                               {add assign}\r\n      begin\r\n        inc(Run, 2);\r\n        fTokenID := tkSymbol;\r\n      end;\r\n    '+':                               {increment}\r\n      begin\r\n        inc(Run, 2);\r\n        fTokenID := tkSymbol;\r\n      end;\r\n  else                                 {add}\r\n    begin\r\n      inc(Run);\r\n      fTokenID := tkSymbol;\r\n    end;\r\n  end;\r\nend;\r\n\r\nprocedure TSynPerlSyn.SlashProc;\r\nbegin\r\n  case FLine[Run + 1] of\r\n    '=':                               {division assign}\r\n      begin\r\n        inc(Run, 2);\r\n        fTokenID := tkSymbol;\r\n      end;\r\n  else                                 {division}\r\n    begin\r\n      inc(Run);\r\n      fTokenID := tkSymbol;\r\n    end;\r\n  end;\r\nend;\r\n\r\nprocedure TSynPerlSyn.SpaceProc;\r\nbegin\r\n  inc(Run);\r\n  fTokenID := tkSpace;\r\n  while (FLine[Run] <= #32) and not IsLineEnd(Run) do inc(Run);\r\nend;\r\n\r\nprocedure TSynPerlSyn.StarProc;\r\nbegin\r\n  case FLine[Run + 1] of\r\n    '=':                               {multiply assign}\r\n      begin\r\n        inc(Run, 2);\r\n        fTokenID := tkSymbol;\r\n      end;\r\n    '*':\r\n      begin\r\n        if FLine[Run + 2] = '=' then   {exponentiation assign}\r\n          inc(Run, 3)\r\n        else                           {exponentiation}\r\n          inc(Run, 2);\r\n        fTokenID := tkSymbol;\r\n      end;\r\n  else                                 {multiply}\r\n    begin\r\n      inc(Run);\r\n      fTokenID := tkSymbol;\r\n    end;\r\n  end;\r\nend;\r\n\r\nprocedure TSynPerlSyn.StringInterpProc;\r\nvar\r\n  fBackslashCount : Integer;\r\nbegin\r\n  fTokenID := tkString;\r\n  if (FLine[Run + 1] = #34) and (FLine[Run + 2] = #34) then inc(Run, 2);\r\n  repeat\r\n    case FLine[Run] of\r\n      #0, #10, #13: break;\r\n      #92:\r\n        { If we're looking at a backslash, and the following character is an\r\n          end quote, and it's preceeded by an odd number of backslashes, then\r\n          it shouldn't mark the end of the string.  If it's preceeded by an\r\n          even number, then it should. }\r\n        if (FLine[Run + 1] = #34) then\r\n          begin\r\n            fBackslashCount := 1;\r\n\r\n            while ((Run > fBackslashCount) and (FLine[Run - fBackslashCount] = #92)) do\r\n              fBackslashCount := fBackslashCount + 1;\r\n\r\n            if (fBackslashCount mod 2 = 1) then inc(Run)\r\n          end;\r\n    end;\r\n    inc(Run);\r\n  until FLine[Run] = #34;\r\n  if FLine[Run] <> #0 then inc(Run);\r\nend;\r\n\r\nprocedure TSynPerlSyn.StringLiteralProc;\r\nbegin\r\n  fTokenID := tkString;\r\n  repeat\r\n    case FLine[Run] of\r\n      #0, #10, #13: break;\r\n    end;\r\n    inc(Run);\r\n  until FLine[Run] = #39;\r\n  if FLine[Run] <> #0 then inc(Run);\r\nend;\r\n\r\nprocedure TSynPerlSyn.SymbolProc;\r\nbegin\r\n  inc(Run);\r\n  fTokenId := tkSymbol;\r\nend;\r\n\r\nprocedure TSynPerlSyn.XOrSymbolProc;\r\nbegin\r\n  Case FLine[Run + 1] of\r\n    '=':                               {xor assign}\r\n      begin\r\n        inc(Run, 2);\r\n        fTokenID := tkSymbol;\r\n      end;\r\n  else                                 {xor}\r\n    begin\r\n      inc(Run);\r\n      fTokenID := tkSymbol;\r\n    end;\r\n  end;\r\nend;\r\n\r\nprocedure TSynPerlSyn.UnknownProc;\r\nbegin\r\n  inc(Run);\r\n  fTokenID := tkUnknown;\r\nend;\r\n\r\nprocedure TSynPerlSyn.Next;\r\nbegin\r\n  fTokenPos := Run;\r\n  case fLine[Run] of\r\n    '&': AndSymbolProc;\r\n    #13: CRProc;\r\n    ':': ColonProc;\r\n    '#': CommentProc;\r\n    '=': EqualProc;\r\n    '>': GreaterProc;\r\n    '%', '@', '$', 'A'..'Z', 'a'..'z', '_': IdentProc;\r\n    #10: LFProc;\r\n    '<': LowerProc;\r\n    '-': MinusProc;\r\n    '!': NotSymbolProc;\r\n    #0: NullProc;\r\n    '0'..'9', '.': NumberProc;\r\n    '|': OrSymbolProc;\r\n    '+': PlusProc;\r\n    '/': SlashProc;\r\n    #1..#9, #11, #12, #14..#32: SpaceProc;\r\n    '*': StarProc;\r\n    #34: StringInterpProc;\r\n    #39: StringLiteralProc;\r\n    '^': XOrSymbolProc;\r\n    '(', ')', '[', ']', '\\', '{', '}', ',', ';', '?', '~': SymbolProc;\r\n    else UnknownProc;\r\n  end;\r\n  inherited;\r\nend;\r\n\r\nfunction TSynPerlSyn.GetDefaultAttribute(Index: integer): TSynHighlighterAttributes;\r\nbegin\r\n  case Index of\r\n    SYN_ATTR_COMMENT: Result := fCommentAttri;\r\n    SYN_ATTR_IDENTIFIER: Result := fIdentifierAttri;\r\n    SYN_ATTR_KEYWORD: Result := fKeyAttri;\r\n    SYN_ATTR_STRING: Result := fStringAttri;\r\n    SYN_ATTR_WHITESPACE: Result := fSpaceAttri;\r\n    SYN_ATTR_SYMBOL: Result := fSymbolAttri;\r\n  else\r\n    Result := nil;\r\n  end;\r\nend;\r\n\r\nfunction TSynPerlSyn.GetEol: Boolean;\r\nbegin\r\n  Result := Run = fLineLen + 1;\r\nend;\r\n\r\nfunction TSynPerlSyn.GetTokenID: TtkTokenKind;\r\nbegin\r\n  Result := fTokenId;\r\nend;\r\n\r\nfunction TSynPerlSyn.GetTokenAttribute: TSynHighlighterAttributes;\r\nbegin\r\n  case fTokenID of\r\n    tkComment: Result := fCommentAttri;\r\n    tkIdentifier: Result := fIdentifierAttri;\r\n    tkKey: Result := fKeyAttri;\r\n    tkNumber: Result := fNumberAttri;\r\n    tkOperator: Result := fOperatorAttri;\r\n    tkPragma: Result := fPragmaAttri;\r\n    tkSpace: Result := fSpaceAttri;\r\n    tkString: Result := fStringAttri;\r\n    tkSymbol: Result := fSymbolAttri;\r\n    tkUnknown: Result := fInvalidAttri;\r\n    tkVariable: Result := fVariableAttri;\r\n    else Result := nil;\r\n  end;\r\nend;\r\n\r\nfunction TSynPerlSyn.GetTokenKind: integer;\r\nbegin\r\n  Result := Ord(fTokenId);\r\nend;\r\n\r\nfunction TSynPerlSyn.GetSampleSource: UnicodeString;\r\nbegin\r\n  Result :=\r\n    '#!/bin/perl'#13#10 +\r\n    'require \"cgi-lib.pl\";'#13#10 +\r\n    'use sigtrap;'#13#10 +\r\n    'do ''envars.pl'';'#13#10 +\r\n    '$_ = $password1;'#13#10 +\r\n    'sub WriteBack {'#13#10 +\r\n    '        while ($_ ne \"fred\")    {'#13#10 +\r\n    '                sleep 5;'#13#10 +\r\n    '        }'#13#10 +\r\n    '}';\r\nend;\r\n\r\nfunction TSynPerlSyn.IsFilterStored: Boolean;\r\nbegin\r\n  Result := fDefaultFilter <> SYNS_FilterPerl;\r\nend;\r\n\r\nfunction TSynPerlSyn.IsIdentChar(AChar: WideChar): Boolean;\r\nbegin\r\n  case AChar of\r\n    '%', '@', '$', '_', '0'..'9', 'a'..'z', 'A'..'Z':\r\n      Result := True;\r\n    else\r\n      Result := False;\r\n  end;\r\nend;\r\n\r\nclass function TSynPerlSyn.GetLanguageName: string;\r\nbegin\r\n  Result := SYNS_LangPerl;\r\nend;\r\n\r\nclass function TSynPerlSyn.GetFriendlyLanguageName: UnicodeString;\r\nbegin\r\n  Result := SYNS_FriendlyLangPerl;\r\nend;\r\n\r\ninitialization\r\n{$IFNDEF SYN_CPPB_1}\r\n  RegisterPlaceableHighlighter(TSynPerlSyn);\r\n{$ENDIF}\r\nend.\r\n"
  },
  {
    "path": "External/SynEdit/Source/SynHighlighterProgress.pas",
    "content": "{-------------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: SynHighlighterProgress.pas, released 2000-04-20.\r\nThe Initial Author of the Original Code is Bruno Mikkelsen.\r\nPortions written by Bruno Mikkelsen are copyright 2000 Bruno Mikkelsen.\r\nUnicode translation by Mal Hrz.\r\nAll Rights Reserved.\r\n\r\nContributors to the SynEdit and mwEdit projects are listed in the\r\nContributors.txt file.\r\n\r\nAlternatively, the contents of this file may be used under the terms of the\r\nGNU General Public License Version 2 or later (the \"GPL\"), in which case\r\nthe provisions of the GPL are applicable instead of those above.\r\nIf you wish to allow use of your version of this file only under the terms\r\nof the GPL and not to allow others to use your version of this file\r\nunder the MPL, indicate your decision by deleting the provisions above and\r\nreplace them with the notice and other provisions required by the GPL.\r\nIf you do not delete the provisions above, a recipient may use your version\r\nof this file under either the MPL or the GPL.\r\n\r\n$Id: SynHighlighterProgress.pas,v 1.16.2.8 2009/09/28 19:16:08 maelh Exp $\r\n\r\nYou may retrieve the latest version of this file at the SynEdit home page,\r\nlocated at http://SynEdit.SourceForge.net\r\n\r\nKnown Issues:\r\n-------------------------------------------------------------------------------}\r\n{\r\n@abstract(Provides a Progress Syntax highlighter for SynEdit)\r\n@author(Bruno Mikkelsen )\r\n@created(2000-04-16)\r\n@lastmod(2000-06-20)\r\nThe SynHighlighterProgress provides SynEdit with a syntax highlighter for the\r\nProgress programming language.\r\nThanks to Michael Hieke for providing a sample highlighter on which this\r\nhighlighter is based.\r\n}\r\n\r\n{$IFNDEF QSYNHIGHLIGHTERPROGRESS}\r\nunit SynHighlighterProgress;\r\n{$ENDIF}\r\n\r\n{$I SynEdit.inc}\r\n\r\ninterface\r\n\r\nuses\r\n{$IFDEF SYN_CLX}\r\n  QGraphics,\r\n  QSynEditTypes,\r\n  QSynEditHighlighter,\r\n  QSynHighlighterHashEntries,\r\n  QSynUnicode,\r\n{$ELSE}\r\n  Graphics,\r\n  SynEditTypes,\r\n  SynEditHighlighter,\r\n  SynHighlighterHashEntries,\r\n  SynUnicode,\r\n{$ENDIF}\r\n  SysUtils,\r\n  Classes;\r\n\r\ntype\r\n  {Enumerates the different tokens in Progress.}\r\n  TtkTokenKind = (tkComment, tkEvent, tkIdentifier, tkInclude, tkKey,\r\n    tkNonReserved, tkNull, tkNumber, tkPreprocessor, tkSpace, tkDataType,\r\n    tkString, tkSymbol, tkUnknown);\r\n\r\n  {Enumerates the ranges in Progress syntax.}\r\n  TRangeState = (rsNone, rsInclude, rsPreprocessorDef, rsPreprocessor,\r\n    rsComment);\r\n\r\n  {Used to hold extra rangeinfo in the Lines.Objects pointer.}\r\n  TRangeInfo = packed record\r\n    case boolean of\r\n      False: (Ptr: Pointer);\r\n      True: (Range: Word; Level: Word);\r\n  end;\r\n\r\n  PIdentFuncTableFunc = ^TIdentFuncTableFunc;\r\n  TIdentFuncTableFunc = function (Index: Integer): TtkTokenKind of object;\r\n\r\ntype\r\n  TSynProgressSyn = class(TSynCustomHighLighter)\r\n  private\r\n    fRange: TRangeState;\r\n    fCommentLevel: Integer;\r\n    fIncludeLevel: Integer;\r\n    fPreProcessorLevel: Integer;\r\n    FTokenID: TtkTokenKind;\r\n    fCommentAttri: TSynHighlighterAttributes;\r\n    fEventAttri: TSynHighlighterAttributes;\r\n    fIdentifierAttri: TSynHighlighterAttributes;\r\n    fIncludeAttri: TSynHighlighterAttributes;\r\n    fKeyAttri: TSynHighlighterAttributes;\r\n    fNonReservedKeyAttri: TSynHighlighterAttributes;\r\n    fNumberAttri: TSynHighlighterAttributes;\r\n    fPreprocessorAttri: TSynHighlighterAttributes;\r\n    fSpaceAttri: TSynHighlighterAttributes;\r\n    fStringAttri: TSynHighlighterAttributes;\r\n    fDataTypeAttri: TSynHighlighterAttributes;\r\n    fSymbolAttri: TSynHighlighterAttributes;\r\n    fHashList: TSynHashEntryList;\r\n    procedure DoAddKeyword(AKeyword: UnicodeString; AKind: Integer);\r\n    function HashKey(Str: PWideChar): Integer;\r\n    function IdentKind(MayBe: PWideChar): TtkTokenKind;\r\n    procedure AsciiCharProc;\r\n    procedure CommentRangeProc;\r\n    procedure IncludeRangeProc;\r\n    procedure PreprocessorRangeProc;\r\n    procedure PreprocessorDefinitionProc;\r\n    procedure PreprocessorDefinitionRangeProc;\r\n    procedure BraceOpenProc;\r\n    procedure IdentProc;\r\n    procedure NullProc;\r\n    procedure NumberProc;\r\n    procedure SlashProc;\r\n    procedure SpaceProc;\r\n    procedure StringProc;\r\n    procedure UnknownProc;\r\n    procedure SymbolProc;\r\n  protected\r\n    function GetDefaultAttribute(Index: integer): TSynHighlighterAttributes;\r\n      override;\r\n    function GetSampleSource: UnicodeString; override;\r\n    function IsFilterStored: Boolean; override;\r\n  public\r\n    class function GetLanguageName: string; override;\r\n    class function GetFriendlyLanguageName: UnicodeString; override;\r\n{$IFDEF DEBUG}\r\n  public\r\n    property Keywords: TSynHashEntryList read fHashList;\r\n{$ENDIF}\r\n  public\r\n    constructor Create(AOwner: TComponent); override;\r\n    destructor Destroy; override;\r\n    function GetEol: Boolean; override;\r\n    function GetRange: Pointer; override;\r\n    function GetTokenID: TtkTokenKind;\r\n    function GetTokenAttribute: TSynHighlighterAttributes; override;\r\n    function GetTokenKind: integer; override;\r\n    function IsIdentChar(AChar: WideChar): Boolean; override;\r\n    procedure Next; override;\r\n    procedure SetRange(Value: Pointer); override;\r\n    procedure ResetRange; override;\r\n  published\r\n    property CommentAttri: TSynHighlighterAttributes read fCommentAttri\r\n      write fCommentAttri;\r\n    property EventAttri: TSynHighlighterAttributes read fEventAttri\r\n      write fEventAttri;\r\n    property IdentifierAttri: TSynHighlighterAttributes read fIdentifierAttri\r\n      write fIdentifierAttri;\r\n    property IncludeAttri: TSynHighlighterAttributes read fIncludeAttri\r\n      write fIncludeAttri;\r\n    property KeyAttri: TSynHighlighterAttributes read fKeyAttri write fKeyAttri;\r\n    property NonReservedKeyAttri: TSynHighlighterAttributes\r\n      read fNonReservedKeyAttri write fNonReservedKeyAttri;\r\n    property NumberAttri: TSynHighlighterAttributes read fNumberAttri\r\n      write fNumberAttri;\r\n    property PreprocessorAttri: TSynHighlighterAttributes\r\n      read fPreprocessorAttri write fPreprocessorAttri;\r\n    property SpaceAttri: TSynHighlighterAttributes read fSpaceAttri\r\n      write fSpaceAttri;\r\n    property StringAttri: TSynHighlighterAttributes read fStringAttri\r\n      write fStringAttri;\r\n    property DataTypeAttri: TSynHighlighterAttributes read fDataTypeAttri\r\n      write fDataTypeAttri;\r\n    property SymbolAttri: TSynHighlighterAttributes read fSymbolAttri\r\n      write fSymbolAttri;\r\n  end;\r\n\r\nconst\r\n  DefaultKeywords: UnicodeString =\r\n                    'accum accumulate active-window add alias ' +\r\n                    'all alter ambig ambiguous analyze ' +\r\n                    'analyze-resume analyze-suspend and any apply ' +\r\n                    'as asc ascending assign at ' +\r\n                    'attr-space authorization auto-return avail available ' +\r\n                    'background before-hide begins bell between ' +\r\n                    'bin blank break btos by ' +\r\n                    'byte call can-do can-find case ' +\r\n                    'case-sensitive center centered check chr ' +\r\n                    'clear clipboard col colon color ' +\r\n                    'column column-label columns compiler control ' +\r\n                    'count-of cpstream create ctos current ' +\r\n                    'current-changed current-lang current-language current-window cursor ' +\r\n                    'database dataservers dbcodepage dbcollation dbname ' +\r\n                    'dbparam dbrestrictions dbtaskid dbtype dbversion ' +\r\n                    'dde deblank debug-list debugger decimals ' +\r\n                    'declare def default default-noxlate default-window ' +\r\n                    'define delete delimiter desc descending ' +\r\n                    'dict dictionary disable disconnect disp ' +\r\n                    'display distinct do dos down ' +\r\n                    'drop each editing else ' +\r\n                    'elseif enable encode end endif ' +\r\n                    'entry error-status escape etime except ' +\r\n                    'exclusive exclusive-lock exists export false ' +\r\n                    'fetch field fields file-info file-information ' +\r\n                    'fill find find-case-sensitive find-global find-next-occurrence ' +\r\n                    'find-prev-occurrence find-select find-wrap-around first first-of ' +\r\n                    'focus font font-based-grid for form ' +\r\n                    'format frame frame-col frame-db frame-down ' +\r\n                    'frame-field frame-file frame-index frame-line frame-name ' +\r\n                    'frame-row frame-val frame-value from from-chars ' +\r\n                    'from-pixels gateways get-byte get-codepages get-collations ' +\r\n                    'get-key-value getbyte glob global ' +\r\n                    'global-define go-on go-pending grant graphic-edge ' +\r\n                    'group having header help hide ' +\r\n                    'if import in index ' +\r\n                    'indicator input input-output insert into ' +\r\n                    'is is-attr-space join kblabel key-code ' +\r\n                    'key-function key-label keycode keyfunction keylabel ' +\r\n                    'keys keyword label last last-event ' +\r\n                    'last-key last-of lastkey ldbname leave ' +\r\n                    'library like line-count line-counter line-number ' +\r\n                    'listing locked long lookup machine-class ' +\r\n                    'map max-button member memptr message ' +\r\n                    'message-lines mouse mpe new next ' +\r\n                    'next-prompt no no-attr-space no-error no-fill ' +\r\n                    'no-help no-hide no-label no-labels no-lobs no-lock ' +\r\n                    'no-map no-message no-pause no-prefetch no-undo ' +\r\n                    'no-validate no-wait not null num-aliases ' +\r\n                    'num-dbs num-entries of off old ' +\r\n                    'on open opsys option ' +\r\n                    'or os-append os-command os-copy os-create-dir ' +\r\n                    'os-delete os-dir os-rename os2 os400 ' +\r\n                    'otherwise output overlay page page-bottom ' +\r\n                    'page-num page-number page-top param parameter ' +\r\n                    'pause pdbname persistent pixels preprocess ' +\r\n                    'privileges proc-handle proc-status process program-name ' +\r\n                    'progress prompt prompt-for promsgs propath ' +\r\n                    'proversion put put-byte put-key-value putbyte ' +\r\n                    'query query-tuning quit r-index rcode-information ' +\r\n                    'readkey recid record-length rectangle ' +\r\n                    'release repeat reposition retain retry ' +\r\n                    'return revert revoke run save ' +\r\n                    'schema scop scoped scoped-define screen ' +\r\n                    'screen-io screen-lines scroll sdbname search ' +\r\n                    'seek select self sequence session ' +\r\n                    'set setuserid share share-lock shared ' +\r\n                    'short show-stats skip some space ' +\r\n                    'status stream stream-io string-xref system-dialog ' +\r\n                    'table tab-stop term terminal text text-cursor ' +\r\n                    'text-height text-seg-growth then this-procedure ' +\r\n                    'time title to top-only trans ' +\r\n                    'transaction trigger triggers trim true ' +\r\n                    'undefine underline undo unformatted union ' +\r\n                    'unique unix unless-hidden unsigned-short up ' +\r\n                    'update use-index use-revvideo use-underline user ' +\r\n                    'userid using v6frame value values ' +\r\n                    'view view-as vms wait-for web-context ' +\r\n                    'when where while widget-id window window-maximized ' +\r\n                    'window-minimized window-normal with work-table workfile ' +\r\n                    'write xcode xref yes _actailog ' +\r\n                    '_actbilog _actbuffer _actindex _actiofile _actiotype ' +\r\n                    '_actlock _actother _actpws _actrecord _actserver ' +\r\n                    '_actspace _actsummary _block _buffstatus _cbit ' +\r\n                    '_checkpoint _connect _control _db _dbstatus ' +\r\n                    '_dcm _field _field-trig _file _file-trig ' +\r\n                    '_filelist _index _index-field _license _list ' +\r\n                    '_lock _lockreq _logging _memory _msg ' +\r\n                    '_mstrblk _pcontrol _segments _sequence _serial-num ' +\r\n                    '_servers _startup _trace _trans _user ' +\r\n                    '_userio _userlock _view _view-col _view-ref';\r\n\r\n  DefaultNonReservedKeywords: UnicodeString =\r\n                               'abs absolute accelerator across add-events-procedure ' +\r\n                               'add-first add-interval add-last advise alert-box allow-replication ' +\r\n                               'ansi-only anywhere append appl-alert appl-alert-boxes ' +\r\n                               'application as-cursor ask-overwrite attachment auto-endkey ' +\r\n                               'auto-end-key auto-go auto-indent auto-resize auto-zap ' +\r\n                               'available-formats average avg backwards base-key ' +\r\n                               'batch batch-mode bgc bgcolor ' +\r\n                               'binary bind-where block-iteration-display border-bottom border-bottom-chars ' +\r\n                               'border-bottom-pixels border-left border-left-chars border-left-pixels border-right ' +\r\n                               'border-right-chars border-right-pixels border-top border-top-chars border-top-pixels ' +\r\n                               'both bottom box box-select box-selectable ' +\r\n                               'browse browse-header btn-down-arrow btn-left-arrow btn-right-arrow ' +\r\n                               'btn-up-arrow buffer buffer-chars buffer-compare buffer-copy ' +\r\n                               'buffer-lines button buttons cache cache-size ' +\r\n                               'cancel-break cancel-button can-query can-set caps ' +\r\n                               'cdecl character_length charset checked clear-select ' +\r\n                               'clear-selection code codepage codepage-convert col-of ' +\r\n                               'colon-align colon-aligned color-table column-bgcolor column-dcolor ' +\r\n                               'column-fgcolor column-font column-label-bgcolor column-label-dcolor column-label-fgcolor ' +\r\n                               'column-label-font column-of column-scrolling com1 com2 ' +\r\n                               'com3 com4 com5 com6 com7 ' +\r\n                               'com8 com9 combo-box command complete ' +\r\n                               'com-self con connect connected ' +\r\n                               'constrained contains contents context context-popup ' +\r\n                               'control-container convert convert-3d-colors convert-to-offset count copy-lob ' +\r\n                               'cpcase cpcoll cpinternal cplog cpprint ' +\r\n                               'cprcodein cprcodeout cpterm crc-value create-control ' +\r\n                               'create-result-list-entry create-test-file current_date current-column ' +\r\n                               'current-iteration current-result-row current-row-modified current-value cursor-char ' +\r\n                               'cursor-line cursor-offset data-entry-return data-type date-format ' +\r\n                               'day db-references dcolor dde-error dde-id ' +\r\n                               'dde-item dde-name dde-topic debug default-button ' +\r\n                               'default-extension defined delete-current-row delete-selected-row delete-selected-rows ' +\r\n                               'deselect-focused-row deselect-rows deselect-selected-row design-mode dialog-box ' +\r\n                               'dialog-help dir disabled display-message display-type ' +\r\n                               'drag-enabled drop-down drop-down-list dump dynamic dynamic-function ' +\r\n                               'echo edge edge-chars edge-pixels edit-can-undo ' +\r\n                               'editor edit-undo empty end-key entered ' +\r\n                               'eq error error-col error-column error-row ' +\r\n                               'events event-type exp expand extended ' +\r\n                               'extent external extract fetch-selected-row fgc ' +\r\n                               'fgcolor file filename file-create-date file-create-time file-mod-date file-mod-time file-name ' +\r\n                               'file-offset file-size file-type filled fill-in filters ' +\r\n                               'first-child first-column first-proc first-procedure first-server ' +\r\n                               'first-tab-item fixed-only focused-row font-table force-file ' +\r\n                               'foreground forwards frame-spacing frame-x frame-y ' +\r\n                               'frequency from-current full-height full-height-chars full-height-pixels ' +\r\n                               'full-pathname full-width full-width-chars full-width-pixels function ' +\r\n                               'ge get-blue get-blue-value get-char-property get-double ' +\r\n                               'get-dynamic get-file get-float get-green get-green-value ' +\r\n                               'get-iteration get-license get-long get-message get-number ' +\r\n                               'get-pointer-value get-red get-red-value get-repositioned-row get-selected ' +\r\n                               'get-selected-widget get-short get-signature get-size get-string ' +\r\n                               'get-tab-item get-text-height get-text-height-chars get-text-height-pixels get-text-width ' +\r\n                               'get-text-width-chars get-text-width-pixels get-unsigned-short grayed grid-factor-h ' +\r\n                               'grid-factor-horizontal grid-factor-v grid-factor-vertical grid-set grid-snap ' +\r\n                               'grid-unit-height grid-unit-height-chars grid-unit-height-pixels grid-unit-width grid-unit-width-chars ' +\r\n                               'grid-unit-width-pixels grid-visible gt height height-chars ' +\r\n                               'height-pixels help-context hidden horizontal hwnd ' +\r\n                               'image image-down image-insensitive image-size image-size-chars ' +\r\n                               'image-size-pixels image-up immediate-display indexed-reposition index-hint ' +\r\n                               'info information init initial initial-dir ' +\r\n                               'initial-filter initiate inner inner-chars inner-lines input-value ' +\r\n                               'insert-backtab insert-file insert-row insert-string insert-tab instantiating-procedure ' +\r\n                               'internal-entries is-lead-byte is-row-selected is-selected item ' +\r\n                               'items-per-row join-by-sqldb keep-frame-z-order keep-messages keep-tab-order ' +\r\n                               'key keyword-all label-bgc label-bgcolor label-dc ' +\r\n                               'label-dcolor label-fgc label-fgcolor label-font label-pfc ' +\r\n                               'label-pfcolor labels languages large large-to-small ' +\r\n                               'last-child last-proc last-procedure last-server last-tab-item ' +\r\n                               'lc le leading left-aligned left-trim ' +\r\n                               'length line list-events list-items list-item-pairs list-query-attrs ' +\r\n                               'list-set-attrs list-widgets load load-control loadcontrols ' +\r\n                               'load-icon load-image load-image-down load-image-insensitive load-image-up ' +\r\n                               'load-mouse-pointer load-small-icon log-id lookahead lower ' +\r\n                               'lpt0 lpt1 lpt2 lpt3 lpt4 ' +\r\n                               'lpt5 lpt6 lpt7 lpt8 lpt9 ' +\r\n                               'lt manual-highlight margin-extra margin-height margin-height-chars ' +\r\n                               'margin-height-pixels margin-width margin-width-chars margin-width-pixels matches ' +\r\n                               'max max-chars max-data-guess max-height ' +\r\n                               'max-height-chars max-height-pixels maximize maximum max-rows ' +\r\n                               'max-size max-value max-width max-width-chars max-width-pixels ' +\r\n                               'memory menu menubar menu-bar menu-item ' +\r\n                               'menu-key menu-mouse message-area message-area-font message-line ' +\r\n                               'min min-height min-height-chars min-height-pixels minimum ' +\r\n                               'min-size min-value min-width min-width-chars min-width-pixels ' +\r\n                               'mod modified modulo month mouse-pointer ' +\r\n                               'movable move-after move-after-tab-item move-before move-before-tab-item ' +\r\n                               'move-column move-to-bottom move-to-eof move-to-top multiple ' +\r\n                               'multiple-key multitasking-interval must-exist name native ' +\r\n                               'ne new-row next-column next-sibling next-tab-item ' +\r\n                               'next-value no-apply no-assign no-bind-where no-box ' +\r\n                               'no-column-scrolling no-convert no-current-value no-debug no-drag ' +\r\n                               'no-echo no-focus no-index-hint no-join-by-sqldb no-lookahead ' +\r\n                               'no-return-value no-row-markers no-scrolling no-separate-connection no-separators ' +\r\n                               'no-underline no-word-wrap num-buttons num-columns num-copies ' +\r\n                               'numeric numeric-format num-formats num-items num-iterations ' +\r\n                               'num-lines num-locked-columns num-messages num-results num-selected ' +\r\n                               'num-selected-rows num-selected-widgets num-tabs num-to-retain octet_length ' +\r\n                               'ok ok-cancel on-frame on-frame-border ordinal ' +\r\n                               'orientation os-drives os-error ' +\r\n                               'os-getenv outer outer-join override owner ' +\r\n                               'paged page-size page-width parent partial-key ' +\r\n                               'pascal password-field pathname pfc pfcolor pinnable ' +\r\n                               'pixels-per-col pixels-per-column pixels-per-row popup-menu popup-only ' +\r\n                               'position precision preselect prev prev-column ' +\r\n                               'prev-sibling prev-tab-item primary printer-control-handle printer-name ' +\r\n                               'printer-port printer-setup private private-data prn procedure ' +\r\n                               'progress-source proxy put-double put-float put-long ' +\r\n                               'put-short put-string put-unsigned-short query-off-end question ' +\r\n                               'radio-buttons radio-set random raw-transfer read-file ' +\r\n                               'read-only real recursive refresh refreshable ' +\r\n                               'remote remove-events-list replace replace-selection-text replication-create ' +\r\n                               'replication-delete replication-write request resizable resize ' +\r\n                               'retry-cancel return-inserted returns return-to-start-dir return-value ' +\r\n                               'right-aligned right-trim round row ' +\r\n                               'row-markers row-of rule rule-row rule-y ' +\r\n                               'save-file screen-value scrollable scrollbar-h scrollbar-horizontal ' +\r\n                               'scroll-bars scrollbar-v scrollbar-vertical scroll-delta scrolled-row-pos ' +\r\n                               'scrolled-row-position scroll-horiz-value scrolling scroll-offset scroll-to-current-row ' +\r\n                               'scroll-to-item scroll-to-selected-row scroll-vert-value se-check-pools section ' +\r\n                               'se-enable-off se-enable-on selectable selected selected-items ' +\r\n                               'select-focused-row selection-end selection-list selection-start selection-text ' +\r\n                               'select-next-row select-prev-row select-repositioned-row select-row send ' +\r\n                               'sensitive se-num-pools separate-connection separators server ' +\r\n                               'set-blue set-blue-value set-break set-cell-focus set-contents ' +\r\n                               'set-dynamic set-green set-green-value set-leakpoint set-pointer-value ' +\r\n                               'set-property set-red set-red-value set-repositioned-row set-selection ' +\r\n                               'set-size set-wait-state se-use-message side-label-handle side-labels ' +\r\n                               'silent simple single size size-chars ' +\r\n                               'size-pixels slider smallint sort source ' +\r\n                               'sql sqrt start status-area status-area-font ' +\r\n                               'status-bar stdcall stenciled stopped stored-procedure ' +\r\n                               'string sub-average sub-count sub-max sub-maximum ' +\r\n                               'sub-menu sub-menu-help sub-min sub-minimum substitute ' +\r\n                               'substr substring sub-total subtype sum ' +\r\n                               'suppress-warnings system-alert-boxes system-help tab-position target ' +\r\n                               'temp-dir temp-directory temp-table terminate text-selected ' +\r\n                               'three-d through thru tic-marks time-source ' +\r\n                               'title-bgc title-bgcolor title-dc title-dcolor title-fgc ' +\r\n                               'title-fgcolor title-font today toggle-box ' +\r\n                               'tool-bar tooltip tooltips top topic ' +\r\n                               'to-rowid total trailing trunc truncate ' +\r\n                               'type unbuffered unique-id unload upper ' +\r\n                               'use use-dict-exps use-filename use-text v6display ' +\r\n                               'validate validate-condition validate-message valid-event valid-handle ' +\r\n                               'var variable vertical virtual-height virtual-height-chars ' +\r\n                               'virtual-height-pixels virtual-width virtual-width-chars virtual-width-pixels visible ' +\r\n                               'wait warning weekday widget-enter widget-leave ' +\r\n                               'widget-pool width width-chars width-pixels window-name ' +\r\n                               'window-state window-system word-wrap x ' +\r\n                               'x-of y year year-offset yes-no ' +\r\n                               'yes-no-cancel y-of';\r\n\r\n  DefaultEvents: UnicodeString =\r\n                    'abort any-key any-printable append-line backspace ' +\r\n                    'back-tab block blue bottom-column break-line ' +\r\n                    'bs cancel cancel-move cancel-pick cancel-resize ' +\r\n                    'choices choose close compile container-event ' +\r\n                    'copy cr ctrl-alt-del ctrl-break ctrl-g ' +\r\n                    'ctrl-j ctrl-l cursor-down cursor-left cursor-right ' +\r\n                    'cursor-up cut data-refresh-line data-refresh-page dde-notify ' +\r\n                    'default-action default-pop-up del del-char delete-char ' +\r\n                    'delete-character delete-column delete-end-line delete-field delete-line ' +\r\n                    'delete-word del-line deselect deselect-extend deselection ' +\r\n                    'deselection-extend dismiss-menu dos-end down-arrow editor-backtab ' +\r\n                    'editor-tab empty-selection end-box-selection end-error endkey ' +\r\n                    'end-move end-resize end-search enter enter-menubar ' +\r\n                    'erase esc execute exit ' +\r\n                    'ff find-next find-previous focus-in formfeed ' +\r\n                    'forward get go goto help-key ' +\r\n                    'home horiz-end horiz-home horiz-scroll-drag ins ' +\r\n                    'ins-char insert-column insert-field insert-field-data insert-field-label ' +\r\n                    'insert-here insert-mode ins-line iteration-changed left ' +\r\n                    'left-arrow left-end left-mouse-click left-mouse-dblclick left-mouse-down ' +\r\n                    'left-mouse-up lf line-del line-down line-erase ' +\r\n                    'linefeed line-ins line-left line-right line-up ' +\r\n                    'main-menu menu-drop middle-mouse-click middle-mouse-dblclick middle-mouse-down ' +\r\n                    'middle-mouse-up mouse-extend-click mouse-extend-dblclick mouse-extend-down mouse-extend-drag ' +\r\n                    'mouse-extend-up mouse-menu-click mouse-menu-dblclick mouse-menu-down mouse-menu-drag ' +\r\n                    'mouse-menu-up mouse-move mouse-move-click mouse-move-dblclick mouse-move-down ' +\r\n                    'mouse-move-drag mouse-move-up mouse-select-click mouse-select-dblclick mouse-select-down ' +\r\n                    'mouse-select-drag mouse-select-up move new-line next-error ' +\r\n                    'next-frame next-page next-scrn next-word object ' +\r\n                    'off-end off-home open-line-above options out-of-data ' +\r\n                    'page-down page-erase page-left page-right page-right-text ' +\r\n                    'page-up parent-window-close paste pgdn pgup ' +\r\n                    'pick pick-area pick-both popup-menu-key prev-frame ' +\r\n                    'prev-page prev-scrn prev-word recall red ' +\r\n                    'remove reports reset resume-display ' +\r\n                    'right right-arrow right-end right-mouse-click ' +\r\n                    'right-mouse-dblclick right-mouse-down right-mouse-up row-display row-entry ' +\r\n                    'row-leave save-as scrollbar-drag scroll-left ' +\r\n                    'scroll-mode scroll-notify scroll-right select-extend selection ' +\r\n                    'selection-extend settings shift-tab start-box-selection start-extend-box-selection ' +\r\n                    'start-move start-resize start-search stop stop-display ' +\r\n                    'tab top-column u1 u10 u2 ' +\r\n                    'u3 u4 u5 u6 u7 ' +\r\n                    'u8 u9 unix-end up-arrow value-changed ' +\r\n                    'white window-close window-resized window-restored';\r\n\r\n  DefaultDataTypes: UnicodeString =\r\n    'char character com-handle component-handle date datetime datetime-tz dec ' +\r\n    'decimal double float handle int ' +\r\n    'integer int64 log logical longchar raw rowid ' +\r\n    'widget widget-handle';\r\n\r\nimplementation\r\n\r\nuses\r\n{$IFDEF SYN_CLX}\r\n  QSynEditStrConst;\r\n{$ELSE}\r\n  SynEditStrConst;\r\n{$ENDIF}\r\n\r\nfunction TSynProgressSyn.HashKey(Str: PWideChar): Integer;\r\n\r\n  function GetOrd: Integer;\r\n  begin\r\n    case Str^ of\r\n      'a'..'z': Result := 1 + Ord(Str^) - Ord('a');\r\n      'A'..'Z': Result := 1 + Ord(Str^) - Ord('A');\r\n      '0'..'9': Result := 27 + Ord(Str^) - Ord('0');\r\n      '_': Result := 37;\r\n      '-': Result := 38;\r\n      else Result := 0;\r\n    end;\r\n  end;\r\n\r\nbegin                       \r\n  Result := 0;\r\n  while IsIdentChar(Str^) do\r\n  begin\r\n{$IFOPT Q-}\r\n    Result := 3 * Result + GetOrd;\r\n{$ELSE}\r\n    Result := (3 * Result + GetOrd) and $FFFFFF;\r\n{$ENDIF}\r\n    inc(Str);\r\n  end;\r\n  Result := Result and $3FF;\r\n  fStringLen := Str - fToIdent;\r\nend;\r\n\r\nfunction TSynProgressSyn.IdentKind(MayBe: PWideChar): TtkTokenKind;\r\nvar\r\n  Entry: TSynHashEntry;\r\nbegin\r\n  fToIdent := MayBe;\r\n  Entry := fHashList[HashKey(MayBe)];\r\n  while Assigned(Entry) do\r\n  begin\r\n    if Entry.KeywordLen > fStringLen then\r\n      break\r\n    else if Entry.KeywordLen = fStringLen then\r\n      if IsCurrentToken(Entry.Keyword) then\r\n      begin\r\n        Result := TtkTokenKind(Entry.Kind);\r\n        exit;\r\n      end;\r\n    Entry := Entry.Next;\r\n  end;\r\n  Result := tkIdentifier;\r\nend;\r\n\r\nprocedure TSynProgressSyn.DoAddKeyword(AKeyword: UnicodeString; AKind: Integer);\r\nvar\r\n  HashValue: Integer;\r\nbegin\r\n  HashValue := HashKey(PWideChar(AKeyword));\r\n  fHashList[HashValue] := TSynHashEntry.Create(AKeyword, AKind);\r\nend;\r\n\r\nconstructor TSynProgressSyn.Create(AOwner: TComponent);\r\nbegin\r\n  inherited Create(AOwner);\r\n\r\n  fCaseSensitive := False;\r\n\r\n  fHashList := TSynHashEntryList.Create;\r\n\r\n  fCommentAttri := TSynHighlighterAttributes.Create(SYNS_AttrComment, SYNS_FriendlyAttrComment);\r\n  fCommentAttri.Foreground := clRed;\r\n  AddAttribute(fCommentAttri);\r\n\r\n  fEventAttri := TSynHighlighterAttributes.Create(SYNS_AttrEvent, SYNS_FriendlyAttrEvent);\r\n  fEventAttri.Foreground := clOlive;\r\n  AddAttribute(fEventAttri);\r\n\r\n  fIdentifierAttri := TSynHighlighterAttributes.Create(SYNS_AttrIdentifier, SYNS_FriendlyAttrIdentifier);\r\n  fIdentifierAttri.Foreground := clNavy;\r\n  AddAttribute(fIdentifierAttri);\r\n\r\n  fIncludeAttri := TSynHighlighterAttributes.Create(SYNS_AttrInclude, SYNS_FriendlyAttrInclude);\r\n  fIncludeAttri.Foreground := clPurple;\r\n  AddAttribute(fIncludeAttri);\r\n\r\n  fKeyAttri := TSynHighlighterAttributes.Create(SYNS_AttrReservedWord, SYNS_FriendlyAttrReservedWord);\r\n  fKeyAttri.Foreground := clMaroon;\r\n  AddAttribute(fKeyAttri);\r\n\r\n  fNonreservedKeyAttri := TSynHighlighterAttributes.Create(SYNS_AttrNonReservedKeyword, SYNS_FriendlyAttrNonReservedKeyword);\r\n  fNonReservedKeyAttri.Foreground := clTeal;\r\n  AddAttribute(fNonReservedKeyAttri);\r\n\r\n  fNumberAttri := TSynHighlighterAttributes.Create(SYNS_AttrNumber, SYNS_FriendlyAttrNumber);\r\n  fNumberAttri.Foreground := clMaroon;\r\n  AddAttribute(fNumberAttri);\r\n\r\n  fPreprocessorAttri := TSynHighlighterAttributes.Create(SYNS_AttrPreprocessor, SYNS_FriendlyAttrPreprocessor);\r\n  fPreprocessorAttri.Foreground := clPurple;\r\n  AddAttribute(fPreProcessorAttri);\r\n\r\n  fSpaceAttri := TSynHighlighterAttributes.Create(SYNS_AttrSpace, SYNS_FriendlyAttrSpace);\r\n  AddAttribute(fSpaceAttri);\r\n\r\n  fDataTypeAttri := TSynHighlighterAttributes.Create(SYNS_AttrDataType, SYNS_FriendlyAttrDataType);\r\n  fDataTypeAttri.Foreground := clSilver;\r\n  AddAttribute(fDataTypeAttri);\r\n\r\n  fStringAttri := TSynHighlighterAttributes.Create(SYNS_AttrString, SYNS_FriendlyAttrString);\r\n  fStringAttri.Foreground := clBlue;\r\n  AddAttribute(fStringAttri);\r\n\r\n  fSymbolAttri := TSynHighlighterAttributes.Create(SYNS_AttrSymbol, SYNS_FriendlyAttrSymbol);\r\n  AddAttribute(fSymbolAttri);\r\n\r\n  fDefaultFilter := SYNS_FilterProgress;\r\n\r\n  EnumerateKeywords(Ord(tkKey), DefaultKeywords, IsIdentChar, DoAddKeyword);\r\n  EnumerateKeywords(Ord(tkNonReserved), DefaultNonReservedKeywords,\r\n    IsIdentChar, DoAddKeyword);\r\n  EnumerateKeywords(Ord(tkEvent), DefaultEvents, IsIdentChar, DoAddKeyword);\r\n  EnumerateKeywords(Ord(tkDataType), DefaultDataTypes, IsIdentChar,\r\n    DoAddKeyword);\r\n  SetAttributesOnChange(DefHighlightChange);\r\nend;\r\n\r\ndestructor TSynProgressSyn.Destroy;\r\nbegin\r\n  fHashList.Free;\r\n  inherited Destroy;\r\nend;\r\n\r\nprocedure TSynProgressSyn.IdentProc;\r\nbegin\r\n  fTokenID := IdentKind(fLine + Run);\r\n  inc(Run, fStringLen);\r\nend;\r\n\r\nprocedure TSynProgressSyn.NullProc;\r\nbegin\r\n  fTokenID := tkNull;\r\n  inc(Run);\r\nend;\r\n\r\nprocedure TSynProgressSyn.NumberProc;\r\nvar\r\n  p: PWideChar;\r\nbegin\r\n  fTokenID := tkNumber;\r\n  p := PWideChar(@fLine[Run]);\r\n  repeat\r\n    Inc(p);\r\n  until not CharInSet(p^, ['0'..'9']);\r\n  Run := p - fLine;\r\nend;\r\n\r\nprocedure TSynProgressSyn.PreprocessorDefinitionProc;\r\nvar\r\n  p: PWideChar;\r\nbegin\r\n  fTokenID := tkPreprocessor;\r\n  p := PWideChar(@fLine[Run]);\r\n  while p^ <> #0 do\r\n  begin\r\n    case p^ of\r\n      '~': if (p + 1)^ = #0 then\r\n             fRange := rsPreprocessorDef;\r\n    end;\r\n    inc(p);\r\n  end;\r\n  Run := p - fLine;\r\nend;\r\n\r\nprocedure TSynProgressSyn.SpaceProc;\r\nbegin\r\n  inc(Run);\r\n  fTokenID := tkSpace;\r\n  while (FLine[Run] <= #32) and not IsLineEnd(Run) do inc(Run);\r\nend;\r\n\r\nprocedure TSynProgressSyn.StringProc;\r\nvar\r\n  p: PWideChar;\r\nbegin\r\n  fTokenID := tkString;\r\n  p := PWideChar(@fLine[Run]);\r\n  repeat\r\n    Inc(p);\r\n  until (p^ = #0) or (p^ = '\"');\r\n  if (p^ = '\"') then Inc(p);\r\n  Run := p - fLine;\r\nend;\r\n\r\nprocedure TSynProgressSyn.SymbolProc;\r\nbegin\r\n  inc(Run);\r\n  fTokenID := tkSymbol;\r\nend;\r\n\r\nprocedure TSynProgressSyn.UnknownProc;\r\nbegin\r\n  inc(Run);\r\n  fTokenID := tkUnknown;\r\nend;\r\n\r\nprocedure TSynProgressSyn.AsciiCharProc;\r\nvar\r\n  p: PWideChar;\r\nbegin\r\n  fTokenID := tkString;\r\n  p := PWideChar(@fLine[Run]);\r\n  repeat\r\n    inc(p);\r\n  until (p^ = #0) or (p^ = '''');\r\n  if (p^ = '''') then Inc(p);\r\n  Run := p - fLine;\r\nend;\r\n\r\nprocedure TSynProgressSyn.SlashProc;\r\nvar\r\n  p: PWideChar;\r\nbegin\r\n  p := PWideChar(@fLine[Run]);\r\n  inc(p);\r\n  case p^ of\r\n    '*': begin  {c style comments}\r\n           fTokenID := tkComment;\r\n           fRange := rsComment;\r\n           fCommentLevel := 1;\r\n           inc(p);\r\n           while (p^ <> #0) and (fRange = rsComment) do\r\n           begin\r\n             case p^ of\r\n               '*': begin\r\n                      inc(p);\r\n                      if p^ = '/' then\r\n                      begin\r\n                        inc(p);\r\n                        dec(fCommentLevel);\r\n                        if FCommentLevel = 0 then\r\n                          fRange := rsNone;\r\n                      end;\r\n                    end;\r\n               '/': begin\r\n                      inc(p);\r\n                      if p^ = '*' then\r\n                      begin\r\n                        inc(p);\r\n                        inc(fCommentLevel); // Max 65535 commentlevels.\r\n                      end;\r\n                    end;\r\n             else\r\n               inc(p);\r\n             end;\r\n           end;\r\n         end;\r\n  else  {division}\r\n    fTokenID := tkSymbol;\r\n  end;\r\n  Run := p - fLine;\r\nend;\r\n\r\nprocedure TSynProgressSyn.CommentRangeProc;\r\nvar\r\n  p: PWideChar;\r\nbegin\r\n  fTokenID := tkComment;\r\n  p := PWideChar(@fLine[Run]);\r\n\r\n  if p^ = #0 then\r\n  begin\r\n    NullProc;\r\n    exit;\r\n  end;\r\n\r\n  while (p^ <> #0) and (fRange = rsComment) do\r\n  begin\r\n    case p^ of\r\n      '*': begin\r\n             inc(p);\r\n             if p^ = '/' then\r\n             begin\r\n               inc(p);\r\n               dec(fCommentLevel);\r\n               if fCommentLevel = 0 then\r\n                 fRange := rsNone;\r\n             end;\r\n           end;\r\n      '/': begin\r\n             inc(p);\r\n             if p^ = '*' then\r\n             begin\r\n               inc(p);\r\n               inc(fCommentLevel);\r\n             end;\r\n           end;\r\n    else\r\n      inc(p);\r\n    end;\r\n  end;\r\n  Run := p - fLine;\r\nend;\r\n\r\nprocedure TSynProgressSyn.IncludeRangeProc;\r\nvar\r\n  p: PWideChar;\r\nbegin\r\n  fTokenID := tkInclude;\r\n  p := PWideChar(@fLine[Run]);\r\n\r\n  if p^ = #0 then\r\n  begin\r\n    NullProc;\r\n    exit;\r\n  end;\r\n\r\n  while p^ <> #0 do\r\n  begin\r\n    case p^ of\r\n      '}': begin\r\n             dec(fIncludeLevel);\r\n             if fIncludeLevel = 0 then\r\n             begin\r\n               fRange := rsNone;\r\n               break;\r\n             end\r\n             else\r\n               inc(p);\r\n           end;\r\n    else\r\n      inc(p);\r\n    end;\r\n  end;\r\n  Run := p - fLine;\r\nend;\r\n\r\nprocedure TSynProgressSyn.PreprocessorRangeProc;\r\nvar\r\n  p: PWideChar;\r\nbegin\r\n  fTokenID := tkPreprocessor;\r\n  p := PWideChar(@fLine[Run]);\r\n\r\n  if p^ = #0 then\r\n  begin\r\n    NullProc;\r\n    exit;\r\n  end;\r\n\r\n  while (p^ <> #0) and (fRange = rsPreprocessor) do\r\n  begin\r\n    case p^ of\r\n      '{': inc(fPreprocessorLevel);\r\n      '}': begin\r\n             dec(fPreprocessorLevel);\r\n             if fPreprocessorLevel = 0 then\r\n               fRange := rsNone;\r\n           end;\r\n    end;\r\n    inc(p);\r\n  end;\r\n  Run := p - fLine;\r\nend;\r\n\r\nprocedure TSynProgressSyn.PreprocessorDefinitionRangeProc;\r\nvar\r\n  p: PWideChar;\r\nbegin\r\n  fTokenID := tkPreprocessor;\r\n  p := PWideChar(@fLine[Run]);\r\n\r\n  if Run = 0 then\r\n    fRange := rsNone;\r\n\r\n  if p^ = #0 then\r\n  begin\r\n    NullProc;\r\n    exit;\r\n  end;\r\n\r\n  while p^ <> #0 do\r\n  begin\r\n    case p^ of\r\n      '~': if (p+1)^ = #0 then\r\n             fRange := rsPreprocessorDef;\r\n    end;\r\n    inc(p);\r\n  end;\r\n  Run := p - fLine;\r\nend;\r\n\r\nprocedure TSynProgressSyn.BraceOpenProc;\r\nvar\r\n  p: PWideChar;\r\n\r\n  function LevelCount: Integer;\r\n  begin\r\n    if fTokenID = tkInclude then\r\n      Result := fIncludeLevel\r\n    else\r\n      Result := fPreprocessorLevel;\r\n  end;\r\n\r\nbegin\r\n  p := PWideChar(@fLine[Run]);\r\n\r\n  inc(p);\r\n  case p^ of\r\n    'A'..'Z', 'a'..'z', '_': fTokenID := tkInclude;\r\n    '&'                    : fTokenID := tkPreprocessor;\r\n  else\r\n    fTokenID := tkUnknown;\r\n  end;\r\n\r\n  case fTokenID of\r\n    tkInclude     : fIncludeLevel      := 1;\r\n    tkPreprocessor: fPreprocessorLevel := 1;\r\n  end;\r\n\r\n  while LevelCount > 0 do\r\n  begin\r\n    case p^ of\r\n      #0 : begin\r\n             if fTokenID = tkInclude then\r\n               fRange := rsInclude\r\n             else\r\n               fRange := rsPreprocessor;\r\n             break;\r\n           end;\r\n      '}': case fTokenID of\r\n             tkInclude     : dec(fIncludeLevel);\r\n             tkPreprocessor: dec(fPreprocessorLevel);\r\n           end;\r\n      '{': case fTokenID of\r\n             tkInclude     : inc(fIncludeLevel);\r\n             tkPreprocessor: inc(fPreprocessorLevel);\r\n           end;\r\n    end;\r\n    inc(p);\r\n  end;\r\n  Run := p - fLine;\r\nend;\r\n\r\nprocedure TSynProgressSyn.Next;\r\nbegin\r\n  fTokenPos := Run;\r\n  case fRange of\r\n    rsInclude: IncludeRangeProc;\r\n    rsPreprocessor: PreprocessorRangeProc;\r\n    rsPreprocessorDef: PreprocessorDefinitionRangeProc;\r\n    rsComment: CommentRangeProc;\r\n  else\r\n    case fLine[Run] of\r\n      #0: NullProc;\r\n      #1..#9, #11, #12, #14..#32: SpaceProc;\r\n      'A'..'Z','a'..'z','_': IdentProc;\r\n      '0'..'9': NumberProc;\r\n      '''': AsciiCharProc;\r\n      '\"': StringProc;\r\n      '{': BraceOpenProc;\r\n      '+','-','*','@',':','=','<','>','.','^','(',')','[',']': SymbolProc;\r\n      '&': PreprocessorDefinitionProc;\r\n      '/': SlashProc;\r\n      else UnknownProc;\r\n    end;\r\n  end;\r\n  inherited;\r\nend;\r\n\r\nfunction TSynProgressSyn.GetDefaultAttribute(Index: integer): TSynHighlighterAttributes;\r\nbegin\r\n  Result := nil;\r\nend;\r\n\r\nfunction TSynProgressSyn.GetEol: Boolean;\r\nbegin\r\n  Result := Run = fLineLen + 1;\r\nend;\r\n\r\nfunction TSynProgressSyn.GetRange: Pointer;\r\nvar\r\n  rng: TRangeInfo;\r\nbegin\r\n  rng.Range := Ord(fRange);\r\n  rng.Level := 0;\r\n  case fRange of\r\n    rsComment: rng.Level := fCommentLevel;\r\n    rsInclude: rng.Level := fIncludeLevel;\r\n    rsPreProcessor: rng.Level := fPreProcessorLevel;\r\n  end;\r\n  Result := rng.Ptr;\r\nend;\r\n\r\nfunction TSynProgressSyn.GetTokenID: TtkTokenKind;\r\nbegin\r\n  Result := fTokenId;\r\nend;\r\n\r\nfunction TSynProgressSyn.GetTokenAttribute: TSynHighlighterAttributes;\r\nbegin\r\n  case GetTokenID of\r\n    tkComment: Result := fCommentAttri;\r\n    tkEvent: Result := fEventAttri;\r\n    tkIdentifier: Result := fIdentifierAttri;\r\n    tkInclude: Result := fIncludeAttri;\r\n    tkKey: Result := fKeyAttri;\r\n    tkNonReserved: Result := fNonReservedKeyAttri;\r\n    tkNumber: Result := fNumberAttri;\r\n    tkPreprocessor: Result := fPreprocessorAttri;\r\n    tkSpace: Result := fSpaceAttri;\r\n    tkDataType: Result := fDataTypeAttri;\r\n    tkString: Result := fStringAttri;\r\n    tkSymbol: Result := fSymbolAttri;\r\n    tkUnknown: Result := fSymbolAttri;\r\n    else Result := nil;\r\n  end;\r\nend;\r\n\r\nfunction TSynProgressSyn.GetTokenKind: integer;\r\nbegin\r\n  Result := Ord(fTokenId);\r\nend;\r\n\r\nprocedure TSynProgressSyn.ResetRange;\r\nbegin\r\n  fRange := rsNone;\r\n  fCommentLevel := 0;\r\n  fIncludeLevel := 0;\r\n  fPreprocessorLevel := 0;\r\nend;\r\n\r\nprocedure TSynProgressSyn.SetRange(Value: Pointer);\r\nvar\r\n  rng: TRangeInfo;\r\nbegin\r\n  rng := TRangeInfo(Value);\r\n  fRange := TRangeState(rng.Range);\r\n  fCommentLevel := 0;\r\n  fIncludeLevel := 0;\r\n  fPreprocessorLevel := 0;\r\n  case fRange of\r\n    rsComment: fCommentLevel := rng.Level;\r\n    rsInclude: fIncludeLevel := rng.Level;\r\n    rsPreProcessor: fPreprocessorLevel := rng.Level;\r\n  end;\r\nend;\r\n\r\nfunction TSynProgressSyn.IsFilterStored: Boolean;\r\nbegin\r\n  Result := fDefaultFilter <> SYNS_FilterProgress;\r\nend;\r\n\r\nfunction TSynProgressSyn.IsIdentChar(AChar: WideChar): Boolean;\r\nbegin\r\n  case AChar of\r\n    '-', '_', '0'..'9', 'A'..'Z', 'a'..'z':\r\n      Result := True;\r\n    else\r\n      Result := False;\r\n  end;\r\nend;\r\n\r\nclass function TSynProgressSyn.GetLanguageName: string;\r\nbegin\r\n  Result := SYNS_LangProgress;\r\nend;\r\n\r\nfunction TSynProgressSyn.GetSampleSource: UnicodeString;\r\nbegin\r\n  Result := '&scoped-define FirstChar 65'#13#10+\r\n            '&scoped-define LastChar  90'#13#10+\r\n            #13#10+\r\n            'def var i as int no-undo.'#13#10+\r\n            'def var s as char no-undo.'#13#10+\r\n            #13#10+\r\n            'function GetRandomChar returns char (input SomeValue as int):'#13#10+\r\n            '  return chr(random({&FirstChar}, {&LastChar})).'#13#10+\r\n            'end.'#13#10+\r\n            #13#10+\r\n            'procedure ClearString:'#13#10+\r\n            '  def input-output param str as char no-undo.'#13#10+\r\n            '  str = \"\".'#13#10+\r\n            'end.'#13#10+\r\n            #13#10+\r\n            'run ClearString(input-output s).'#13#10+\r\n            'do i = 1 to 100:'#13#10+\r\n            '  s = s + GetRandomChar(17).'#13#10+\r\n            'end.'#13#10+\r\n            'display s.';\r\nend;\r\n\r\nclass function TSynProgressSyn.GetFriendlyLanguageName: UnicodeString;\r\nbegin\r\n  Result := SYNS_FriendlyLangProgress;\r\nend;\r\n\r\ninitialization\r\n{$IFNDEF SYN_CPPB_1}\r\n  RegisterPlaceableHighlighter(TSynProgressSyn);\r\n{$ENDIF}\r\nend.\r\n"
  },
  {
    "path": "External/SynEdit/Source/SynHighlighterPython.pas",
    "content": "{-------------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: SynHighlighterPython.pas, released 2000-06-23.\r\nThe Original Code is based on the odPySyn.pas file from the\r\nmwEdit component suite by Martin Waldenburg and other developers, the Initial\r\nAuthor of this file is Olivier Deckmyn.\r\nPortions created by M.Utku Karatas and Dennis Chuah.\r\nUnicode translation by Mal Hrz.\r\nAll Rights Reserved.\r\n\r\nContributors to the SynEdit and mwEdit projects are listed in the\r\nContributors.txt file.\r\n\r\nAlternatively, the contents of this file may be used under the terms of the\r\nGNU General Public License Version 2 or later (the \"GPL\"), in which case\r\nthe provisions of the GPL are applicable instead of those above.\r\nIf you wish to allow use of your version of this file only under the terms\r\nof the GPL and not to allow others to use your version of this file\r\nunder the MPL, indicate your decision by deleting the provisions above and\r\nreplace them with the notice and other provisions required by the GPL.\r\nIf you do not delete the provisions above, a recipient may use your version\r\nof this file under either the MPL or the GPL.\r\n\r\n$Id: SynHighlighterPython.pas,v 1.18.2.7 2008/09/14 16:25:02 maelh Exp $\r\n\r\nYou may retrieve the latest version of this file at the SynEdit home page,\r\nlocated at http://SynEdit.SourceForge.net\r\n\r\nKnown Issues:\r\n-------------------------------------------------------------------------------}\r\n{\r\n@abstract(A Python language highlighter for SynEdit)\r\n@author(Olivier Deckmyn, converted to SynEdit by David Muir )\r\n@created(unknown, converted to SynEdit on 2000-06-23)\r\n@lastmod(2003-02-13)\r\nThe SynHighlighterPython implements a highlighter for Python for the SynEdit projects.\r\n}\r\n\r\n{$IFNDEF QSYNHIGHLIGHTERPYTHON}\r\nunit SynHighlighterPython;\r\n{$ENDIF}\r\n\r\n{$I SynEdit.inc}\r\n\r\ninterface\r\n\r\nuses\r\n{$IFDEF SYN_CLX}\r\n  QGraphics,\r\n  QSynEditHighlighter,\r\n  QSynEditTypes,\r\n  QSynUnicode,  \r\n{$ELSE}\r\n  Graphics,\r\n  SynEditHighlighter,\r\n  SynEditTypes,\r\n  SynUnicode,\r\n{$ENDIF}\r\n  SysUtils,\r\n  Classes;\r\n\r\nconst\r\n  ALPHA_CHARS = ['_', 'a'..'z', 'A'..'Z'];\r\n\r\ntype\r\n  TtkTokenKind = (tkComment, tkIdentifier, tkKey, tkNull, tkNumber, tkSpace,\r\n    tkString, tkSymbol, tkNonKeyword, tkTrippleQuotedString,\r\n    tkSystemDefined, tkHex, tkOct, tkFloat, tkUnknown);\r\n\r\n  TRangeState = (rsANil, rsComment, rsUnKnown, rsMultilineString, rsMultilineString2,\r\n                 rsMultilineString3 //this is to indicate if a string is made multiline by backslash char at line end (as in C++ highlighter)\r\n                );\r\n\r\ntype\r\n  TSynPythonSyn = class(TSynCustomHighLighter)\r\n  private\r\n    fStringStarter: WideChar;  // used only for rsMultilineString3 stuff\r\n    fRange: TRangeState;\r\n    FTokenID: TtkTokenKind;\r\n    FKeywords: TUnicodeStringList;\r\n    fStringAttri: TSynHighlighterAttributes;\r\n    fDocStringAttri: TSynHighlighterAttributes;\r\n    fNumberAttri: TSynHighlighterAttributes;\r\n    fHexAttri: TSynHighlighterAttributes;\r\n    fOctalAttri: TSynHighlighterAttributes;\r\n    fFloatAttri: TSynHighlighterAttributes;\r\n    fKeyAttri: TSynHighlighterAttributes;\r\n    fNonKeyAttri: TSynHighlighterAttributes;\r\n    fSystemAttri: TSynHighlighterAttributes;\r\n    fSymbolAttri: TSynHighlighterAttributes;\r\n    fCommentAttri: TSynHighlighterAttributes;\r\n    fIdentifierAttri: TSynHighlighterAttributes;\r\n    fSpaceAttri: TSynHighlighterAttributes;\r\n    fErrorAttri: TSynHighlighterAttributes;\r\n    function IdentKind(MayBe: PWideChar): TtkTokenKind;\r\n    procedure SymbolProc;\r\n    procedure CRProc;\r\n    procedure CommentProc;\r\n    procedure GreaterProc;\r\n    procedure IdentProc;\r\n    procedure LFProc;\r\n    procedure LowerProc;\r\n    procedure NullProc;\r\n    procedure NumberProc;\r\n    procedure SpaceProc;\r\n    procedure PreStringProc;\r\n    procedure UnicodeStringProc;\r\n    procedure StringProc;\r\n    procedure String2Proc;\r\n    procedure StringEndProc(EndChar: WideChar);\r\n    procedure UnknownProc;\r\n  protected\r\n    function GetSampleSource: UnicodeString; override;\r\n    function IsFilterStored: Boolean; override;\r\n    function GetKeywordIdentifiers: TUnicodeStringList;\r\n    property Keywords: TUnicodeStringList read FKeywords;\r\n    property TokenID: TtkTokenKind read FTokenID;\r\n  public\r\n    class function GetLanguageName: string; override;\r\n    class function GetFriendlyLanguageName: UnicodeString; override;\r\n  public\r\n    constructor Create(AOwner: TComponent); override;\r\n    destructor Destroy; override;\r\n    function GetDefaultAttribute(Index: integer): TSynHighlighterAttributes;\r\n      override;\r\n    function GetEol: Boolean; override;\r\n    function GetRange: Pointer; override;\r\n    function GetTokenID: TtkTokenKind;\r\n    function GetTokenAttribute: TSynHighlighterAttributes; override;\r\n    function GetTokenKind: integer; override;\r\n    procedure Next; override;\r\n    procedure SetRange(Value: Pointer); override;\r\n    procedure ResetRange; override;\r\n  published\r\n    property CommentAttri: TSynHighlighterAttributes read fCommentAttri\r\n    write fCommentAttri;\r\n    property IdentifierAttri: TSynHighlighterAttributes read fIdentifierAttri\r\n    write fIdentifierAttri;\r\n    property KeyAttri: TSynHighlighterAttributes read fKeyAttri write fKeyAttri;\r\n    property NonKeyAttri: TSynHighlighterAttributes read fNonKeyAttri\r\n      write fNonKeyAttri;\r\n    property SystemAttri: TSynHighlighterAttributes read fSystemAttri\r\n      write fSystemAttri;\r\n    property NumberAttri: TSynHighlighterAttributes read fNumberAttri\r\n    write fNumberAttri;\r\n    property HexAttri: TSynHighlighterAttributes read fHexAttri\r\n      write fHexAttri;\r\n    property OctalAttri: TSynHighlighterAttributes read fOctalAttri\r\n      write fOctalAttri;\r\n    property FloatAttri: TSynHighlighterAttributes read fFloatAttri\r\n      write fFloatAttri;\r\n    property SpaceAttri: TSynHighlighterAttributes read fSpaceAttri\r\n    write fSpaceAttri;\r\n    property StringAttri: TSynHighlighterAttributes read fStringAttri\r\n    write fStringAttri;\r\n    property DocStringAttri: TSynHighlighterAttributes read fDocStringAttri\r\n      write fDocStringAttri;\r\n    property SymbolAttri: TSynHighlighterAttributes read fSymbolAttri\r\n    write fSymbolAttri;\r\n    property ErrorAttri: TSynHighlighterAttributes read fErrorAttri\r\n      write fErrorAttri;\r\n  end;\r\n\r\nimplementation\r\n\r\nuses\r\n{$IFDEF SYN_CLX}\r\n  QSynEditStrConst;\r\n{$ELSE}\r\n  SynEditStrConst;\r\n{$ENDIF}\r\n\r\nvar\r\n  GlobalKeywords: TUnicodeStringList;\r\n\r\nfunction TSynPythonSyn.GetKeywordIdentifiers: TUnicodeStringList;\r\nconst\r\n  // No need to localise keywords!\r\n\r\n  // List of keywords\r\n  KEYWORDCOUNT = 29;\r\n  KEYWORDS: array [1..KEYWORDCOUNT] of UnicodeString =\r\n    (\r\n    'and',\r\n    'assert',\r\n    'break',\r\n    'class',\r\n    'continue',\r\n    'def',\r\n    'del',\r\n    'elif',\r\n    'else',\r\n    'except',\r\n    'exec',\r\n    'finally',\r\n    'for',\r\n    'from',\r\n    'global',\r\n    'if',\r\n    'import',\r\n    'in',\r\n    'is',\r\n    'lambda',\r\n    'not',\r\n    'or',\r\n    'pass',\r\n    'print',\r\n    'raise',\r\n    'return',\r\n    'try',\r\n    'while',\r\n    'yield'\r\n    );\r\n\r\n  // List of non-keyword identifiers\r\n  NONKEYWORDCOUNT = 66;\r\n  NONKEYWORDS: array [1..NONKEYWORDCOUNT] of UnicodeString =\r\n    (\r\n    '__future__',\r\n    '__import__',\r\n    'abs',\r\n    'apply',\r\n    'as',\r\n    'buffer',\r\n    'callable',\r\n    'chr',\r\n    'cmp',\r\n    'coerce',\r\n    'compile',\r\n    'complex',\r\n    'delattr',\r\n    'dict',\r\n    'dir',\r\n    'divmod',\r\n    'eval',\r\n    'execfile',\r\n    'False',\r\n    'file',\r\n    'filter',\r\n    'float',\r\n    'getattr',\r\n    'globals',\r\n    'hasattr',\r\n    'hash',\r\n    'help',\r\n    'hex',\r\n    'id',\r\n    'input',\r\n    'int',\r\n    'intern',\r\n    'isinstance',\r\n    'issubclass',\r\n    'iter',\r\n    'len',\r\n    'list',\r\n    'locals',\r\n    'long',\r\n    'None',\r\n    'NotImplemented',\r\n    'map',\r\n    'max',\r\n    'min',\r\n    'oct',\r\n    'open',\r\n    'ord',\r\n    'pow',\r\n    'range',\r\n    'raw_input',\r\n    'reduce',\r\n    'reload',\r\n    'repr',\r\n    'round',\r\n    'self',\r\n    'setattr',\r\n    'slice',\r\n    'str',\r\n    'True',\r\n    'tuple',\r\n    'type',\r\n    'unichr',\r\n    'unicode',\r\n    'vars',\r\n    'xrange',\r\n    'zip'\r\n    );\r\nvar\r\n  f: Integer;\r\nbegin\r\n  if not Assigned (GlobalKeywords) then\r\n  begin\r\n    // Create the string list of keywords - only once\r\n    GlobalKeywords := TUnicodeStringList.Create;\r\n\r\n    for f := 1 to KEYWORDCOUNT do\r\n      GlobalKeywords.AddObject(KEYWORDS[f], Pointer(Ord(tkKey)));\r\n    for f := 1 to NONKEYWORDCOUNT do\r\n      GlobalKeywords.AddObject(NONKEYWORDS[f], Pointer(Ord(tkNonKeyword)));\r\n  end; // if\r\n  Result := GlobalKeywords;\r\nend;\r\n\r\nfunction TSynPythonSyn.IdentKind(MayBe: PWideChar): TtkTokenKind;\r\nvar\r\n  i: Integer;\r\n  temp: PWideChar;\r\n  s: UnicodeString;\r\nbegin\r\n  // Extract the identifier out - it is assumed to terminate in a\r\n  //   non-alphanumeric character\r\n  fToIdent := MayBe;\r\n  temp := MayBe;\r\n  while IsIdentChar(temp^) do\r\n    Inc(temp);\r\n  fStringLen := temp - fToIdent;\r\n\r\n  // Check to see if it is a keyword\r\n  SetString(s, fToIdent, fStringLen);\r\n  if FKeywords.Find(s, i) then\r\n  begin\r\n    // TUnicodeStringList is not case sensitive!\r\n    if s <> FKeywords[i] then\r\n      i := -1;\r\n  end\r\n  else\r\n    i := -1;\r\n\r\n  if i <> -1 then\r\n    Result := TtkTokenKind(FKeywords.Objects[i])\r\n\r\n  // Check if it is a system identifier (__*__)\r\n  else if (fStringLen >= 5) and\r\n     (MayBe[0] = '_') and (MayBe[1] = '_') and (MayBe[2] <> '_') and\r\n     (MayBe[fStringLen - 1] = '_') and (MayBe[fStringLen - 2] = '_') and\r\n     (MayBe[fStringLen - 3] <> '_') then\r\n    Result := tkSystemDefined\r\n\r\n  // Else, hey, it is an ordinary run-of-the-mill identifier!\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n  \r\nconstructor TSynPythonSyn.Create(AOwner: TComponent);\r\nbegin\r\n  inherited Create(AOwner);\r\n\r\n  fCaseSensitive := True;\r\n\r\n  FKeywords := TUnicodeStringList.Create;\r\n  FKeywords.Sorted := True; \r\n  FKeywords.Duplicates := dupError;\r\n  FKeywords.Assign (GetKeywordIdentifiers);\r\n\r\n  fRange := rsUnknown;\r\n  fCommentAttri := TSynHighlighterAttributes.Create(SYNS_AttrComment, SYNS_FriendlyAttrComment);\r\n  fCommentAttri.Foreground := clGray;\r\n  fCommentAttri.Style := [fsItalic];\r\n  AddAttribute(fCommentAttri);\r\n  fIdentifierAttri := TSynHighlighterAttributes.Create(SYNS_AttrIdentifier, SYNS_FriendlyAttrIdentifier);\r\n  AddAttribute(fIdentifierAttri);\r\n  fKeyAttri := TSynHighlighterAttributes.Create(SYNS_AttrReservedWord, SYNS_FriendlyAttrReservedWord);\r\n  fKeyAttri.Style := [fsBold];\r\n  AddAttribute(fKeyAttri);\r\n  fNonKeyAttri := TSynHighlighterAttributes.Create (SYNS_AttrNonReservedKeyword, SYNS_FriendlyAttrNonReservedKeyword);\r\n  fNonKeyAttri.Foreground := clNavy;\r\n  fNonKeyAttri.Style := [fsBold];\r\n  AddAttribute (fNonKeyAttri);\r\n  fSystemAttri := TSynHighlighterAttributes.Create (SYNS_AttrSystem, SYNS_FriendlyAttrSystem);\r\n  fSystemAttri.Style := [fsBold];\r\n  AddAttribute (fSystemAttri);\r\n  fNumberAttri := TSynHighlighterAttributes.Create(SYNS_AttrNumber, SYNS_FriendlyAttrNumber);\r\n  fNumberAttri.Foreground := clBlue;\r\n  AddAttribute(fNumberAttri);\r\n  fHexAttri := TSynHighlighterAttributes.Create(SYNS_AttrHexadecimal, SYNS_FriendlyAttrHexadecimal);\r\n  fHexAttri.Foreground := clBlue;\r\n  AddAttribute(fHexAttri);\r\n  fOctalAttri := TSynHighlighterAttributes.Create(SYNS_AttrOctal, SYNS_FriendlyAttrOctal);\r\n  fOctalAttri.Foreground := clBlue;\r\n  AddAttribute(fOctalAttri);\r\n  fFloatAttri := TSynHighlighterAttributes.Create(SYNS_AttrFloat, SYNS_FriendlyAttrFloat);\r\n  fFloatAttri.Foreground := clBlue;\r\n  AddAttribute(fFloatAttri);\r\n  fSpaceAttri := TSynHighlighterAttributes.Create(SYNS_AttrSpace, SYNS_FriendlyAttrSpace);\r\n  AddAttribute(fSpaceAttri);\r\n  fStringAttri := TSynHighlighterAttributes.Create(SYNS_AttrString, SYNS_FriendlyAttrString);\r\n  fStringAttri.Foreground := clBlue;\r\n  AddAttribute(fStringAttri);\r\n  fDocStringAttri := TSynHighlighterAttributes.Create(SYNS_AttrDocumentation, SYNS_FriendlyAttrDocumentation);\r\n  fDocStringAttri.Foreground := clTeal;\r\n  AddAttribute(fDocStringAttri);\r\n  fSymbolAttri := TSynHighlighterAttributes.Create(SYNS_AttrSymbol, SYNS_FriendlyAttrSymbol);\r\n  AddAttribute(fSymbolAttri);\r\n  fErrorAttri := TSynHighlighterAttributes.Create(SYNS_AttrSyntaxError, SYNS_FriendlyAttrSyntaxError);\r\n  fErrorAttri.Foreground := clRed;\r\n  AddAttribute(fErrorAttri);\r\n  SetAttributesOnChange(DefHighlightChange);\r\n  fDefaultFilter := SYNS_FilterPython;\r\nend; { Create }\r\n\r\ndestructor TSynPythonSyn.Destroy;\r\nbegin\r\n  FKeywords.Free;\r\n  inherited;\r\nend;\r\n\r\nprocedure TSynPythonSyn.SymbolProc;\r\nbegin\r\n  inc(Run);\r\n  fTokenID := tkSymbol;\r\nend;\r\n\r\nprocedure TSynPythonSyn.CRProc;\r\nbegin\r\n  fTokenID := tkSpace;\r\n  case FLine[Run + 1] of\r\n    #10: inc(Run, 2);\r\n  else\r\n    inc(Run);\r\n  end;\r\nend;\r\n\r\nprocedure TSynPythonSyn.CommentProc;\r\nbegin\r\n  fTokenID := tkComment;\r\n  inc(Run);\r\n  while not IsLineEnd(Run) do\r\n    inc(Run);\r\nend;\r\n\r\nprocedure TSynPythonSyn.GreaterProc;\r\nbegin\r\n  case FLine[Run + 1] of\r\n    '=': begin\r\n        inc(Run, 2);\r\n        fTokenID := tkSymbol;\r\n      end;\r\n  else begin\r\n      inc(Run);\r\n      fTokenID := tkSymbol;\r\n    end;\r\n  end;\r\nend;\r\n\r\nprocedure TSynPythonSyn.IdentProc;\r\nbegin\r\n  fTokenID := IdentKind((fLine + Run));\r\n  inc(Run, fStringLen);\r\nend;\r\n\r\nprocedure TSynPythonSyn.LFProc;\r\nbegin\r\n  fTokenID := tkSpace;\r\n  inc(Run);\r\nend;\r\n\r\nprocedure TSynPythonSyn.LowerProc;\r\nbegin\r\n  case FLine[Run + 1] of\r\n    '=': begin\r\n        inc(Run, 2);\r\n        fTokenID := tkSymbol;\r\n      end;\r\n    '>': begin\r\n        inc(Run, 2);\r\n        fTokenID := tkSymbol;\r\n      end\r\n  else begin\r\n      inc(Run);\r\n      fTokenID := tkSymbol;\r\n    end;\r\n  end;\r\nend;\r\n\r\nprocedure TSynPythonSyn.NullProc;\r\nbegin\r\n  fTokenID := tkNull;\r\n  inc(Run);\r\nend;\r\n\r\nprocedure TSynPythonSyn.NumberProc;\r\ntype\r\n  TNumberState =\r\n    (\r\n    nsStart,\r\n    nsDotFound,\r\n    nsFloatNeeded,\r\n    nsHex,\r\n    nsOct,\r\n    nsExpFound\r\n    );\r\n\r\nvar\r\n  temp: WideChar;\r\n  State: TNumberState;\r\n\r\n  function CheckSpecialCases: Boolean;\r\n  begin\r\n    case temp of\r\n      // Look for dot (.)\r\n      '.': begin\r\n        // .45\r\n        if CharInSet(FLine[Run], ['0'..'9']) then\r\n        begin\r\n          Inc (Run);\r\n          fTokenID := tkFloat;\r\n          State := nsDotFound;\r\n\r\n        // Non-number dot\r\n        end else begin\r\n          // Ellipsis\r\n          if (FLine[Run] = '.') and (FLine[Run+1] = '.') then\r\n            Inc (Run, 2);\r\n          fTokenID := tkSymbol;\r\n          Result := False;\r\n          Exit;\r\n        end; // if\r\n      end; // DOT\r\n\r\n      // Look for zero (0)\r\n      '0': begin\r\n        temp := FLine[Run];\r\n        // 0x123ABC\r\n        if CharInSet(temp, ['x', 'X']) then begin\r\n          Inc (Run);\r\n          fTokenID := tkHex;\r\n          State := nsHex;\r\n        // 0.45\r\n        end else if temp = '.' then begin\r\n          Inc (Run);\r\n          State := nsDotFound;\r\n          fTokenID := tkFloat;\r\n        end else if CharInSet(temp, ['0'..'9']) then begin\r\n          Inc (Run);\r\n          // 0123 or 0123.45\r\n          if CharInSet(temp, ['0'..'7']) then begin\r\n            fTokenID := tkOct;\r\n            State := nsOct;\r\n          // 0899.45\r\n          end else begin\r\n            fTokenID := tkFloat;\r\n            State := nsFloatNeeded;\r\n          end; // if\r\n        end; // if\r\n      end; // ZERO\r\n    end; // case\r\n\r\n    Result := True;\r\n  end; // CheckSpecialCases\r\n\r\n  function HandleBadNumber: Boolean;\r\n  begin\r\n    Result := False;\r\n    fTokenID := tkUnknown;\r\n    // Ignore all tokens till end of \"number\"\r\n    while IsIdentChar(FLine[Run]) or (FLine[Run] = '.') do\r\n      Inc (Run);\r\n  end; // HandleBadNumber\r\n\r\n  function HandleExponent: Boolean;\r\n  begin\r\n    State := nsExpFound;\r\n    fTokenID := tkFloat;\r\n    // Skip e[+/-]\r\n    if CharInSet(FLine[Run+1], ['+', '-']) then\r\n      Inc (Run);\r\n    // Invalid token : 1.0e\r\n    if not CharInSet(FLine[Run+1], ['0'..'9']) then begin\r\n      Inc (Run);\r\n      Result := HandleBadNumber;\r\n      Exit;\r\n    end; // if\r\n\r\n    Result := True;\r\n  end; // HandleExponent\r\n\r\n  function HandleDot: Boolean;\r\n  begin\r\n    // Check for ellipsis\r\n    Result := (FLine[Run+1] <> '.') or (FLine[Run+2] <> '.');\r\n    if Result then begin\r\n      State := nsDotFound;\r\n      fTokenID := tkFloat;\r\n    end; // if\r\n  end; // HandleDot\r\n\r\n  function CheckStart: Boolean;\r\n  begin\r\n    // 1234\r\n    if CharInSet(temp, ['0'..'9']) then begin\r\n      Result := True;\r\n    //123e4\r\n    end else if CharInSet(temp, ['e', 'E']) then begin\r\n      Result := HandleExponent;\r\n    // 123.45j\r\n    end else if CharInSet(temp, ['j', 'J']) then begin\r\n      Inc (Run);\r\n      fTokenID := tkFloat;\r\n      Result := False;\r\n    // 123.45\r\n    end else if temp = '.' then begin\r\n      Result := HandleDot;\r\n    // Error!\r\n    end else if IsIdentChar(temp) then begin\r\n      Result := HandleBadNumber;\r\n    // End of number\r\n    end else begin\r\n      Result := False;\r\n    end; // if\r\n  end; // CheckStart\r\n\r\n  function CheckDotFound: Boolean;\r\n  begin\r\n    // 1.0e4\r\n    if CharInSet(temp, ['e', 'E']) then begin\r\n      Result := HandleExponent;\r\n    // 123.45\r\n    end else if CharInSet(temp, ['0'..'9']) then begin\r\n      Result := True;\r\n    // 123.45j\r\n    end else if CharInSet(temp, ['j', 'J']) then begin\r\n      Inc (Run);\r\n      Result := False;\r\n    // 123.45.45: Error!\r\n    end else if temp = '.' then begin\r\n      Result := False;\r\n      if HandleDot then\r\n        HandleBadNumber;\r\n    // Error!\r\n    end else if IsIdentChar(temp) then begin\r\n      Result := HandleBadNumber;\r\n    // End of number\r\n    end else begin\r\n      Result := False;\r\n    end; // if\r\n  end; // CheckDotFound\r\n\r\n  function CheckFloatNeeded: Boolean;\r\n  begin\r\n    // 091.0e4\r\n    if CharInSet(temp, ['e', 'E']) then begin\r\n      Result := HandleExponent;\r\n    // 0912345\r\n    end else if CharInSet(temp, ['0'..'9']) then begin\r\n      Result := True;\r\n    // 09123.45\r\n    end else if temp = '.' then begin\r\n      Result := HandleDot or HandleBadNumber; // Bad octal\r\n    // 09123.45j\r\n    end else if CharInSet(temp, ['j', 'J']) then begin\r\n      Inc (Run);\r\n      Result := False;\r\n    // End of number (error: Bad oct number) 0912345\r\n    end else begin\r\n      Result := HandleBadNumber;\r\n    end;\r\n  end; // CheckFloatNeeded\r\n\r\n  function CheckHex: Boolean;\r\n  begin\r\n    // 0x123ABC\r\n    if CharInSet(temp, ['a'..'f', 'A'..'F', '0'..'9']) then\r\n    begin\r\n      Result := True;\r\n    // 0x123ABCL\r\n    end else if CharInSet(temp, ['l', 'L']) then begin\r\n      Inc (Run);\r\n      Result := False;\r\n    // 0x123.45: Error!\r\n    end else if temp = '.' then begin\r\n      Result := False;\r\n      if HandleDot then\r\n        HandleBadNumber;\r\n    // Error!\r\n    end else if IsIdentChar(temp) then begin\r\n      Result := HandleBadNumber;\r\n    // End of number\r\n    end else begin\r\n      Result := False;\r\n    end; // if\r\n  end; // CheckHex\r\n\r\n  function CheckOct: Boolean;\r\n  begin\r\n    // 012345\r\n    if CharInSet(temp, ['0'..'9']) then begin\r\n      if not CharInSet(temp, ['0'..'7']) then begin\r\n        State := nsFloatNeeded;\r\n        fTokenID := tkFloat;\r\n      end; // if\r\n      Result := True;\r\n    // 012345L\r\n    end else if CharInSet(temp, ['l', 'L']) then begin\r\n      Inc (Run);\r\n      Result := False;\r\n    // 0123e4\r\n    end else if CharInSet(temp, ['e', 'E']) then begin\r\n      Result := HandleExponent;\r\n    // 0123j\r\n    end else if CharInSet(temp, ['j', 'J']) then begin\r\n      Inc (Run);\r\n      fTokenID := tkFloat;\r\n      Result := False;\r\n    // 0123.45\r\n    end else if temp = '.' then begin\r\n      Result := HandleDot;\r\n    // Error!\r\n    end else if IsIdentChar(temp) then begin\r\n      Result := HandleBadNumber;\r\n    // End of number\r\n    end else begin\r\n      Result := False;\r\n    end; // if\r\n  end; // CheckOct\r\n\r\n  function CheckExpFound: Boolean;\r\n  begin\r\n    // 1e+123\r\n    if CharInSet(temp, ['0'..'9']) then begin\r\n      Result := True;\r\n    // 1e+123j\r\n    end else if CharInSet(temp, ['j', 'J']) then begin\r\n      Inc (Run);\r\n      Result := False;\r\n    // 1e4.5: Error!\r\n    end else if temp = '.' then begin\r\n      Result := False;\r\n      if HandleDot then\r\n        HandleBadNumber;\r\n    // Error!\r\n    end else if IsIdentChar(temp) then begin\r\n      Result := HandleBadNumber;\r\n    // End of number\r\n    end else begin\r\n      Result := False;\r\n    end; // if\r\n  end; // CheckExpFound\r\n\r\nbegin\r\n  State := nsStart;\r\n  fTokenID := tkNumber;\r\n\r\n  temp := FLine[Run];\r\n  Inc (Run);\r\n\r\n  // Special cases\r\n  if not CheckSpecialCases then\r\n    Exit;\r\n\r\n  // Use a state machine to parse numbers\r\n  while True do begin\r\n    temp := FLine[Run];\r\n\r\n    case State of\r\n      nsStart:\r\n        if not CheckStart then Exit;\r\n      nsDotFound:\r\n        if not CheckDotFound then Exit;\r\n      nsFloatNeeded:\r\n        if not CheckFloatNeeded then Exit;\r\n      nsHex:\r\n        if not CheckHex then Exit;\r\n      nsOct:\r\n        if not CheckOct then Exit;\r\n      nsExpFound:\r\n        if not CheckExpFound then Exit;\r\n    end; // case\r\n\r\n    Inc (Run);\r\n  end; // while\r\nend;\r\n\r\nprocedure TSynPythonSyn.SpaceProc;\r\nbegin\r\n  inc(Run);\r\n  fTokenID := tkSpace;\r\n  while (FLine[Run] <= #32) and not IsLineEnd(Run) do inc(Run);\r\nend;\r\n\r\nprocedure TSynPythonSyn.String2Proc;\r\nvar\r\n  fBackslashCount: Integer;\r\nbegin\r\n  fTokenID := tkString;\r\n  if (FLine[Run + 1] = '\"') and (FLine[Run + 2] = '\"') then\r\n  begin\r\n    fTokenID := tkTrippleQuotedString;\r\n    inc(Run, 3);\r\n\r\n    fRange := rsMultilineString2;\r\n    while fLine[Run] <> #0 do\r\n    begin\r\n      case fLine[Run] of\r\n\r\n        '\\':begin\r\n               { If we're looking at a backslash, and the following character is an\r\n               end quote, and it's preceeded by an odd number of backslashes, then\r\n               it shouldn't mark the end of the string.  If it's preceeded by an\r\n               even number, then it should. !!!THIS RULE DOESNT APPLY IN RAW STRINGS}\r\n               if FLine[Run + 1] = '\"' then\r\n                 begin\r\n                   fBackslashCount := 1;\r\n\r\n                   while ((Run > fBackslashCount) and (FLine[Run - fBackslashCount] = '\\')) do\r\n                     fBackslashCount := fBackslashCount + 1;\r\n\r\n                   if (fBackslashCount mod 2 = 1) then inc(Run)\r\n               end;\r\n               inc(Run);\r\n            end;// '\\':\r\n\r\n        '\"':\r\n          if (fLine[Run + 1] = '\"') and (fLine[Run + 2] = '\"') then begin\r\n            fRange := rsUnKnown;\r\n            inc(Run, 3);\r\n            exit;\r\n          end else\r\n            inc(Run);\r\n        #10: exit;\r\n        #13: exit;\r\n        else\r\n          inc(Run);\r\n      end;\r\n    end;\r\n  end\r\n      else //if short string\r\n  repeat\r\n    case FLine[Run] of\r\n      #0, #10, #13:\r\n        begin\r\n          if FLine[Run-1] = '\\' then\r\n          begin\r\n            fStringStarter := '\"';\r\n            fRange := rsMultilineString3;\r\n          end;\r\n          Break;\r\n        end;\r\n      {The same backslash stuff above...}\r\n      '\\':begin\r\n             if FLine[Run + 1] = '\"' then\r\n               begin\r\n                 fBackslashCount := 1;\r\n\r\n                 while ((Run > fBackslashCount) and (FLine[Run - fBackslashCount] = '\\')) do\r\n                   fBackslashCount := fBackslashCount + 1;\r\n\r\n                 if (fBackslashCount mod 2 = 1) then inc(Run)\r\n             end;\r\n             inc(Run);\r\n          end;// '\\':\r\n\r\n      else inc(Run);\r\n    end; //case\r\n  until (FLine[Run] = '\"');\r\n  if FLine[Run] <> #0 then inc(Run);\r\nend;\r\n\r\nprocedure TSynPythonSyn.PreStringProc;\r\nvar\r\n  temp: WideChar;\r\nbegin\r\n  // Handle python raw strings\r\n  // r\"\"\r\n  temp := FLine[Run + 1];\r\n  if temp = '''' then\r\n  begin\r\n    Inc (Run);\r\n    StringProc;\r\n  end\r\n  else if temp = '\"' then\r\n  begin\r\n    Inc (Run);\r\n    String2Proc;\r\n  end\r\n  else\r\n  begin\r\n    // If not followed by quote char, must be ident\r\n    IdentProc;\r\n  end; // if\r\nend;\r\n\r\nprocedure TSynPythonSyn.UnicodeStringProc;\r\nbegin\r\n  // Handle python raw and unicode strings\r\n  // Valid syntax: u\"\", or ur\"\"\r\n  if CharInSet(FLine[Run + 1], ['r', 'R']) and\r\n    CharInSet(FLine[Run + 2], ['''', '\"']) then\r\n  begin\r\n    // for ur, Remove the \"u\" and...\r\n    Inc (Run);\r\n  end;\r\n  // delegate to raw strings\r\n  PreStringProc;\r\nend;\r\n\r\nprocedure TSynPythonSyn.StringProc;\r\nvar\r\n  fBackslashCount: Integer;\r\nbegin\r\n  fTokenID := tkString;\r\n  if (FLine[Run + 1] = #39) and (FLine[Run + 2] = #39) then begin\r\n    fTokenID := tkTrippleQuotedString;\r\n    inc(Run, 3);\r\n\r\n    fRange:=rsMultilineString;\r\n    while fLine[Run] <> #0 do begin\r\n      case fLine[Run] of\r\n\r\n        '\\': begin\r\n             { If we're looking at a backslash, and the following character is an\r\n             end quote, and it's preceeded by an odd number of backslashes, then\r\n             it shouldn't mark the end of the string.  If it's preceeded by an\r\n             even number, then it should. !!!THIS RULE DOESNT APPLY IN RAW STRINGS}\r\n              if FLine[Run + 1] = #39 then\r\n                begin\r\n                  fBackslashCount := 1;\r\n\r\n                  while ((Run > fBackslashCount) and (FLine[Run - fBackslashCount] = '\\')) do\r\n                    fBackslashCount := fBackslashCount + 1;\r\n\r\n                  if (fBackslashCount mod 2 = 1) then inc(Run)\r\n              end;\r\n              inc(Run);\r\n            end;// '\\':\r\n\r\n        #39:\r\n          if (fLine[Run + 1] = #39) and (fLine[Run + 2] = #39) then begin\r\n            fRange := rsUnKnown;\r\n            inc(Run, 3);\r\n            EXIT;\r\n          end else\r\n            inc(Run);\r\n        #10: EXIT;\r\n        #13: EXIT;\r\n        else\r\n          inc(Run);\r\n      end;\r\n    end;\r\n  end\r\n      else //if short string\r\n  repeat\r\n    case FLine[Run] of\r\n      #0, #10, #13 : begin\r\n        if FLine[Run-1] = '\\' then begin\r\n          fStringStarter := #39;\r\n          fRange := rsMultilineString3;\r\n        end;\r\n        BREAK;\r\n        end;\r\n\r\n      {The same backslash stuff above...}\r\n      '\\':begin\r\n             if FLine[Run + 1] = #39 then\r\n               begin\r\n                 fBackslashCount := 1;\r\n\r\n                 while ((Run > fBackslashCount) and (FLine[Run - fBackslashCount] = '\\')) do\r\n                   fBackslashCount := fBackslashCount + 1;\r\n\r\n                 if (fBackslashCount mod 2 = 1) then inc(Run)\r\n             end;\r\n             inc(Run);\r\n          end;// '\\':\r\n\r\n      else inc(Run);\r\n    end; //case\r\n  until (FLine[Run] = #39);\r\n  if FLine[Run] <> #0 then inc(Run);\r\nend;\r\n\r\nprocedure TSynPythonSyn.StringEndProc(EndChar: WideChar);\r\nvar\r\n  fBackslashCount: Integer;\r\nbegin\r\n  if fRange = rsMultilineString3 then\r\n    fTokenID := tkString\r\n  else\r\n    fTokenID := tkTrippleQuotedString;\r\n\r\n  case FLine[Run] of\r\n    #0:\r\n      begin\r\n        NullProc;\r\n        EXIT;\r\n      end;\r\n    #10:\r\n      begin\r\n        LFProc;\r\n        EXIT;\r\n    end;\r\n    #13:\r\n      begin\r\n        CRProc;\r\n        EXIT;\r\n      end;\r\n  end;\r\n\r\n  if fRange = rsMultilineString3 then begin\r\n    repeat\r\n      if FLine[Run]=fStringStarter then begin\r\n        inc(Run);\r\n        fRange:=rsUnknown;\r\n        EXIT;\r\n      end else if FLine[Run]='\\' then ;  {The same backslash stuff above...}\r\n          begin\r\n             if FLine[Run + 1] = fStringStarter then\r\n               begin\r\n                 fBackslashCount := 1;\r\n\r\n                 while ((Run > fBackslashCount) and (FLine[Run - fBackslashCount] = '\\')) do\r\n                   fBackslashCount := fBackslashCount + 1;\r\n\r\n                 if (fBackslashCount mod 2 = 1) then inc(Run);\r\n             end;\r\n           end;// if FLine[Run]...\r\n\r\n      inc(Run);\r\n    until IsLineEnd(Run);\r\n    if FLine[Run-1]<>'\\' then begin\r\n      fRange:=rsUnknown;\r\n      EXIT;\r\n    end;\r\n  end else\r\n  repeat\r\n    if FLine[Run] = '\\' then\r\n    begin\r\n       if FLine[Run + 1] = EndChar then\r\n         begin\r\n           fBackslashCount := 1;\r\n\r\n           while ((Run > fBackslashCount) and (FLine[Run - fBackslashCount] = '\\')) do\r\n             fBackslashCount := fBackslashCount + 1;\r\n\r\n           if (fBackslashCount mod 2 = 1) then inc(Run, 2);\r\n       end;\r\n     end;// if FLine[Run]...\r\n    if (FLine[Run]=EndChar) and (FLine[Run+1]=EndChar) and (FLine[Run+2]=EndChar) then begin\r\n      inc(Run,3);\r\n      fRange:=rsUnknown;\r\n      EXIT;\r\n    end;\r\n    inc(Run);\r\n  until IsLineEnd(Run);\r\nend;\r\n\r\nprocedure TSynPythonSyn.UnknownProc;\r\nbegin\r\n  inc(Run);\r\n  fTokenID := tkUnknown;\r\nend;\r\n\r\nprocedure TSynPythonSyn.Next;\r\nbegin\r\n  fTokenPos := Run;\r\n\r\n  case fRange of\r\n    rsMultilineString:\r\n      StringEndProc(#39);\r\n    rsMultilineString2:\r\n      StringEndProc('\"');\r\n    rsMultilineString3:\r\n      StringEndProc(fStringStarter);\r\n    else\r\n      case fLine[Run] of\r\n        '&', '}', '{', ':', ',', ']', '[', '*', '`',\r\n        '^', ')', '(', ';', '/', '=', '-', '+', '!', '\\',\r\n        '%', '|', '~' :\r\n          SymbolProc;\r\n        #13: CRProc;\r\n        '#': CommentProc;\r\n        '>': GreaterProc;\r\n        'A'..'Q', 'S', 'T', 'V'..'Z', 'a'..'q', 's', 't', 'v'..'z', '_': IdentProc;\r\n        #10: LFProc;\r\n        '<': LowerProc;\r\n        #0: NullProc;\r\n        '.', '0'..'9': NumberProc;\r\n        #1..#9, #11, #12, #14..#32: SpaceProc;\r\n        'r', 'R': PreStringProc;\r\n        'u', 'U': UnicodeStringProc;\r\n        '''': StringProc;\r\n        '\"': String2Proc;\r\n        else UnknownProc;\r\n      end;\r\n  end;\r\n  inherited;\r\nend;\r\n\r\nfunction TSynPythonSyn.GetDefaultAttribute(Index: integer): TSynHighlighterAttributes;\r\nbegin\r\n  case Index of\r\n    SYN_ATTR_COMMENT: Result := fCommentAttri;\r\n    SYN_ATTR_KEYWORD: Result := fKeyAttri;\r\n    SYN_ATTR_WHITESPACE: Result := fSpaceAttri;\r\n    SYN_ATTR_SYMBOL: Result := fSymbolAttri;\r\n  else\r\n    Result := nil;\r\n  end;\r\nend;\r\n\r\nfunction TSynPythonSyn.GetEol: Boolean;\r\nbegin\r\n  Result := Run = fLineLen + 1;\r\nend;\r\n\r\nfunction TSynPythonSyn.GetRange: Pointer;\r\nbegin\r\n  Result := Pointer(fRange);\r\nend;\r\n\r\nfunction TSynPythonSyn.GetTokenID: TtkTokenKind;\r\nbegin\r\n  Result := fTokenId;\r\nend;\r\n\r\nfunction TSynPythonSyn.GetTokenAttribute: TSynHighlighterAttributes;\r\nbegin\r\n  case fTokenID of\r\n    tkComment: Result := fCommentAttri;\r\n    tkIdentifier: Result := fIdentifierAttri;\r\n    tkKey: Result := fKeyAttri;\r\n    tkNonKeyword: Result := fNonKeyAttri;\r\n    tkSystemDefined: Result := fSystemAttri;\r\n    tkNumber: Result := fNumberAttri;\r\n    tkHex: Result := fHexAttri;\r\n    tkOct: Result := fOctalAttri;\r\n    tkFloat: Result := fFloatAttri;\r\n    tkSpace: Result := fSpaceAttri;\r\n    tkString: Result := fStringAttri;\r\n    tkTrippleQuotedString: Result := fDocStringAttri;\r\n    tkSymbol: Result := fSymbolAttri;\r\n    tkUnknown: Result := fErrorAttri;\r\n  else\r\n    Result := nil;\r\n  end;\r\nend;\r\n\r\nfunction TSynPythonSyn.GetTokenKind: integer;\r\nbegin\r\n  Result := Ord(fTokenId);\r\nend;\r\n\r\nprocedure TSynPythonSyn.ResetRange;\r\nbegin\r\n  fRange := rsUnknown;\r\nend;\r\n\r\nprocedure TSynPythonSyn.SetRange(Value: Pointer);\r\nbegin\r\n  fRange := TRangeState(Value);\r\nend;\r\n\r\nfunction TSynPythonSyn.IsFilterStored: Boolean;\r\nbegin\r\n  Result := fDefaultFilter <> SYNS_FilterPython;\r\nend;\r\n\r\nclass function TSynPythonSyn.GetLanguageName: string;\r\nbegin\r\n  Result := SYNS_LangPython;\r\nend;\r\n\r\nfunction TSynPythonSyn.GetSampleSource: UnicodeString;\r\nbegin\r\n  Result :=\r\n    '#!/usr/local/bin/python'#13#10 +\r\n    'import string, sys'#13#10 +\r\n    '\"\"\" If no arguments were given, print a helpful message \"\"\"'#13#10 +\r\n    'if len(sys.argv)==1:'#13#10 +\r\n    '    print ''Usage: celsius temp1 temp2 ...'''#13#10 +\r\n    '    sys.exit(0)';\r\nend;\r\n\r\nclass function TSynPythonSyn.GetFriendlyLanguageName: UnicodeString;\r\nbegin\r\n  Result := SYNS_FriendlyLangPython;\r\nend;\r\n\r\ninitialization\r\n{$IFNDEF SYN_CPPB_1}\r\n  RegisterPlaceableHighlighter(TSynPythonSyn);\r\n{$ENDIF}\r\nfinalization\r\n  GlobalKeywords.Free;\r\nend.\r\n"
  },
  {
    "path": "External/SynEdit/Source/SynHighlighterRC.pas",
    "content": "{-------------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: SynHighlighterRC.pas, released 2004-06-12.\r\nThe initial author of this file is Yiannis Mandravellos.\r\nUnicode translation by Mal Hrz.\r\nAll Rights Reserved.\r\n\r\nContributors to the SynEdit project are listed in the Contributors.txt file.\r\n\r\nAlternatively, the contents of this file may be used under the terms of the\r\nGNU General Public License Version 2 or later (the \"GPL\"), in which case\r\nthe provisions of the GPL are applicable instead of those above.\r\nIf you wish to allow use of your version of this file only under the terms\r\nof the GPL and not to allow others to use your version of this file\r\nunder the MPL, indicate your decision by deleting the provisions above and\r\nreplace them with the notice and other provisions required by the GPL.\r\nIf you do not delete the provisions above, a recipient may use your version\r\nof this file under either the MPL or the GPL.\r\n\r\n$Id: SynHighlighterRC.pas,v 1.6.2.8 2008/09/14 16:25:02 maelh Exp $\r\n\r\nYou may retrieve the latest version of SynEdit from the SynEdit home page,\r\nlocated at http://SynEdit.SourceForge.net\r\n\r\n-------------------------------------------------------------------------------}\r\n\r\n{$IFNDEF QSYNHIGHLIGHTERRC}\r\nunit SynHighlighterRC;\r\n{$ENDIF}\r\n\r\n{$I SynEdit.inc}\r\n\r\ninterface\r\n\r\nuses\r\n{$IFDEF SYN_CLX}\r\n  QGraphics, \r\n  QSynEditTypes, \r\n  QSynEditHighlighter,\r\n  QSynUnicode,\r\n{$ELSE}\r\n  Windows, Controls,\r\n  Graphics,\r\n  SynEditTypes,\r\n  SynEditHighlighter,\r\n  SynUnicode,   \r\n{$ENDIF}\r\n  SysUtils,\r\n  Classes;\r\n\r\ntype\r\n TtkTokenKind = (tkComment, tkDirective, tkIdentifier, tkKey, tkNull,\r\n                 tkNumber, tkSpace, tkString, tkSymbol, tkUnknown);\r\n\r\n TRangeState = (rsUnknown, rsDirective, rsComment);\r\n\r\n  PIdentFuncTableFunc = ^TIdentFuncTableFunc;\r\n  TIdentFuncTableFunc = function (Index: Integer): TtkTokenKind of object;\r\n\r\n TSynRCSyn = class(TSynCustomHighlighter)\r\n  private\r\n   fRange: TRangeState;\r\n   fTokenID: TtkTokenKind;\r\n   fIdentFuncTable: array[0..240] of TIdentFuncTableFunc;\r\n   fCommentAttri: TSynHighlighterAttributes;\r\n   fDirecAttri: TSynHighlighterAttributes;\r\n   fIdentifierAttri: TSynHighlighterAttributes;\r\n   fKeyAttri: TSynHighlighterAttributes;\r\n   fNumberAttri: TSynHighlighterAttributes;\r\n   fSpaceAttri: TSynHighlighterAttributes;\r\n   fStringAttri: TSynHighlighterAttributes;\r\n   fSymbolAttri: TSynHighlighterAttributes;\r\n   function AltFunc(Index: Integer): TtkTokenKind;\r\n   function KeyWordFunc(Index: Integer): TtkTokenKind;\r\n   function HashKey(Str: PWideChar): Cardinal;\r\n   function IdentKind(MayBe: PWideChar): TtkTokenKind;\r\n   procedure InitIdent;\r\n   procedure CommentProc;\r\n   procedure CRProc;\r\n   procedure DirectiveProc;\r\n   procedure IdentProc;\r\n   procedure LFProc;\r\n   procedure NullProc;\r\n   procedure NumberProc;\r\n   procedure QuoteProc;\r\n   procedure SlashProc;\r\n   procedure SpaceProc;\r\n   procedure SymbolProc;\r\n   procedure UnknownProc;\r\n  protected\r\n   function GetSampleSource: UnicodeString; override;\r\n   function IsFilterStored: Boolean; override;\r\n  public\r\n   class function GetCapabilities: TSynHighlighterCapabilities; override;\r\n   class function GetLanguageName: string; override;\r\n   class function GetFriendlyLanguageName: UnicodeString; override;\r\n  public\r\n   constructor Create(aOwner: TComponent); override;\r\n   destructor Destroy; override;\r\n   function GetDefaultAttribute(index: integer): TSynHighlighterAttributes; override;\r\n   function GetEol: boolean; override;\r\n   function GetRange: pointer; override;\r\n   function GetTokenID: TtkTokenKind;\r\n   function GetTokenAttribute: TSynHighlighterAttributes; override;\r\n   function GetTokenKind: integer; override;\r\n   procedure Next; override;\r\n   procedure SetRange(value: pointer); override;\r\n   procedure ResetRange; override;\r\n   function UseUserSettings(SettingIndex: integer): boolean; override;\r\n   procedure EnumUserSettings(Settings: TStrings); override;\r\n  published\r\n   property CommentAttri: TSynHighlighterAttributes read fCommentAttri write fCommentAttri;\r\n   property DirecAttri: TSynHighlighterAttributes read fDirecAttri write fDirecAttri;\r\n   property IdentifierAttri: TSynHighlighterAttributes read fIdentifierAttri write fIdentifierAttri;\r\n   property KeyAttri: TSynHighlighterAttributes read fKeyAttri write fKeyAttri;\r\n   property NumberAttri: TSynHighlighterAttributes read fNumberAttri write fNumberAttri;\r\n   property SpaceAttri: TSynHighlighterAttributes read fSpaceAttri write fSpaceAttri;\r\n   property StringAttri: TSynHighlighterAttributes read fStringAttri write fStringAttri;\r\n   property SymbolAttri: TSynHighlighterAttributes read fSymbolAttri write fSymbolAttri;\r\n end;\r\n\r\nimplementation\r\n\r\nuses\r\n{$IFDEF SYN_CLX}\r\n  QSynEditStrConst;\r\n{$ELSE}\r\n  SynEditStrConst;\r\n{$ENDIF}\r\n\r\nconst\r\n  KeyWords: array[0..77] of UnicodeString = (\r\n    'ACCELERATORS', 'ALT', 'ASCII', 'AUTO3STATE', 'AUTOCHECKBOX', \r\n    'AUTORADIOBUTTON', 'BITMAP', 'BLOCK', 'CAPTION', 'CHARACTERISTICS', \r\n    'CHECKBOX', 'CHECKED', 'CLASS', 'COMBOBOX', 'COMMENTS', 'COMPANYNAME', \r\n    'CONTROL', 'CTEXT', 'CURSOR', 'DEFPUSHBUTTON', 'DIALOG', 'DIALOGEX', \r\n    'DISCARDABLE', 'EDITTEXT', 'EXSTYLE', 'FILEDESCRIPTION', 'FILEFLAGS', \r\n    'FILEFLAGSMASK', 'FILEOS', 'FILESUBTYPE', 'FILETYPE', 'FILEVERSION', \r\n    'FIXED', 'FONT', 'GRAYED', 'GROUPBOX', 'HELP', 'ICON', 'IMPURE', 'INACTIVE', \r\n    'INTERNALNAME', 'LANGUAGE', 'LEGALCOPYRIGHT', 'LEGALTRADEMARKS', 'LISTBOX', \r\n    'LOADONCALL', 'LTEXT', 'MENU', 'MENUBARBREAK', 'MENUBREAK', 'MENUEX', \r\n    'MENUITEM', 'MESSAGETABLE', 'MOVEABLE', 'NOINVERT', 'ORIGINALFILENAME', \r\n    'POPUP', 'PRELOAD', 'PRIVATEBUILD', 'PRODUCTNAME', 'PRODUCTVERSION', 'PURE', \r\n    'PUSHBOX', 'PUSHBUTTON', 'RADIOBUTTON', 'RCDATA', 'RTEXT', 'SCROLLBAR', \r\n    'SEPARATOR', 'SHIFT', 'SPECIALBUILD', 'STATE3', 'STRINGTABLE', 'STYLE', \r\n    'VALUE', 'VERSION', 'VERSIONINFO', 'VIRTKEY' \r\n  );\r\n\r\n  KeyIndices: array[0..240] of Integer = (\r\n    -1, -1, -1, 35, -1, 57, 54, -1, -1, -1, 74, -1, -1, -1, 64, -1, -1, -1, -1, \r\n    9, 68, -1, 41, -1, -1, 10, -1, -1, 13, 24, -1, -1, -1, 42, -1, -1, -1, -1, \r\n    -1, 61, -1, -1, 20, 67, -1, -1, -1, -1, -1, -1, -1, -1, 2, -1, -1, 23, -1, \r\n    -1, -1, -1, -1, 48, -1, 12, -1, -1, -1, -1, -1, -1, -1, 75, 73, 14, -1, 77, \r\n    -1, 4, 63, -1, -1, -1, -1, 65, 19, 27, -1, 31, 38, -1, -1, -1, -1, -1, 50, \r\n    -1, -1, -1, 28, -1, -1, -1, -1, -1, -1, -1, 8, 6, 18, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, 49, 76, -1, 59, -1, -1, 52, 47, 29, -1, -1, -1, \r\n    -1, -1, -1, -1, 56, -1, -1, 44, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, 1, -1, -1, 71, 17, 32, 34, -1, 45, -1, -1, -1, 70, -1, 3, \r\n    -1, 62, 43, 5, -1, -1, 33, 0, 51, 16, 69, -1, -1, -1, 39, -1, -1, 7, -1, 11, \r\n    -1, -1, -1, 21, -1, 40, -1, -1, 36, -1, -1, -1, -1, -1, -1, -1, -1, -1, 53, \r\n    -1, 26, -1, 66, 25, -1, -1, 72, -1, -1, 60, 15, -1, -1, -1, -1, 55, -1, -1, \r\n    -1, 30, -1, -1, -1, 46, -1, 58, -1, 37, 22, -1 \r\n  );\r\n\r\n{ TSynRCSyn }\r\n\r\n{$Q-}\r\nfunction TSynRCSyn.HashKey(Str: PWideChar): Cardinal;\r\nbegin\r\n  Result := 0;\r\n  while IsIdentChar(Str^) do\r\n  begin\r\n    Result := Result * 25 + Ord(Str^) * 298;\r\n    inc(Str);\r\n  end;\r\n  Result := Result mod 241;\r\n  fStringLen := Str - fToIdent;\r\nend;\r\n{$Q+}\r\n\r\nfunction TSynRCSyn.IdentKind(MayBe: PWideChar): TtkTokenKind;\r\nvar\r\n  Key: Cardinal;\r\nbegin\r\n  fToIdent := MayBe;\r\n  Key := HashKey(MayBe);\r\n  if Key <= High(fIdentFuncTable) then\r\n    Result := fIdentFuncTable[Key](KeyIndices[Key])\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nprocedure TSynRCSyn.InitIdent;\r\nvar\r\n  i: Integer;\r\nbegin\r\n  for i := Low(fIdentFuncTable) to High(fIdentFuncTable) do\r\n    if KeyIndices[i] = -1 then\r\n      fIdentFuncTable[i] := AltFunc;\r\n\r\n  for i := Low(fIdentFuncTable) to High(fIdentFuncTable) do\r\n    if @fIdentFuncTable[i] = nil then\r\n      fIdentFuncTable[i] := KeyWordFunc;\r\nend;\r\n\r\nfunction TSynRCSyn.AltFunc(Index: Integer): TtkTokenKind;\r\nbegin\r\n  Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynRCSyn.KeyWordFunc(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier\r\nend;\r\n\r\nconstructor TSynRCSyn.Create(aOwner: TComponent);\r\nbegin\r\n  inherited;\r\n\r\n  fCaseSensitive := True;\r\n\r\n  fCommentAttri := TSynHighlighterAttributes.Create(SYNS_AttrComment, SYNS_FriendlyAttrComment);\r\n  AddAttribute(fCommentAttri);\r\n\r\n  fDirecAttri := TSynHighlighterAttributes.Create(SYNS_AttrPreprocessor, SYNS_FriendlyAttrPreprocessor);\r\n  AddAttribute(fDirecAttri);\r\n\r\n  fIdentifierAttri := TSynHighlighterAttributes.Create(SYNS_AttrIdentifier, SYNS_FriendlyAttrIdentifier);\r\n  AddAttribute(fIdentifierAttri);\r\n\r\n  fKeyAttri := TSynHighlighterAttributes.Create(SYNS_AttrReservedWord, SYNS_FriendlyAttrReservedWord);\r\n  fKeyAttri.Style := [fsBold];\r\n  AddAttribute(fKeyAttri);\r\n\r\n  fNumberAttri := TSynHighlighterAttributes.Create(SYNS_AttrNumber, SYNS_FriendlyAttrNumber);\r\n  AddAttribute(fNumberAttri);\r\n\r\n  fSpaceAttri := TSynHighlighterAttributes.Create(SYNS_AttrSpace, SYNS_FriendlyAttrSpace);\r\n  AddAttribute(fSpaceAttri);\r\n\r\n  fStringAttri := TSynHighlighterAttributes.Create(SYNS_AttrString, SYNS_FriendlyAttrString);\r\n  AddAttribute(fStringAttri);\r\n\r\n  fSymbolAttri := TSynHighlighterAttributes.Create(SYNS_AttrSymbol, SYNS_FriendlyAttrSymbol);\r\n  AddAttribute(fSymbolAttri);\r\n  SetAttributesOnChange(DefHighlightChange);\r\n  InitIdent;\r\n  fRange := rsUnknown;\r\n  fDefaultFilter := SYNS_FilterRC;\r\nend;\r\n\r\ndestructor TSynRCSyn.Destroy;\r\nbegin\r\n  inherited;\r\nend;\r\n\r\nprocedure TSynRCSyn.QuoteProc;\r\nbegin\r\n  fTokenId:= tkString;\r\n  repeat\r\n   inc(Run);\r\n  until IsLineEnd(Run) or (fLine[Run] = #34);\r\n  if fLine[Run] = #34 then\r\n    inc(Run);\r\nend;\r\n\r\nprocedure TSynRCSyn.SlashProc;\r\nbegin\r\n  case fLine[Run + 1] of\r\n   #13: CRPRoc;\r\n   #10: LFProc;\r\n   '/':\r\n    begin\r\n      fTokenId := tkComment;\r\n      inc(Run, 2);\r\n      while not IsLineEnd(Run) do inc(Run);\r\n    end;\r\n   '*':\r\n    begin\r\n      fTokenID := tkComment;\r\n      fRange := rsComment;\r\n      inc(Run, 2);\r\n      while fLine[Run] <> #0 do\r\n       case fLine[Run] of\r\n        '*':\r\n         if fLine[Run + 1] = '/' then\r\n          begin\r\n            inc(Run, 2);\r\n            fRange := rsUnknown;\r\n            break;\r\n          end\r\n         else inc(Run);\r\n        #10, #13: break;\r\n       else\r\n        inc(Run);\r\n       end;\r\n    end;\r\n  else\r\n   fTokenId := tkSymbol;\r\n   inc(Run);  \r\n  end\r\nend;\r\n\r\nprocedure TSynRCSyn.CommentProc;\r\nbegin\r\n  fTokenId := tkComment;\r\n  case fLine[Run] of\r\n   #0: NullProc;\r\n  #13: CRProc;\r\n  #10: LFProc;\r\n  else\r\n   fTokenId := tkComment;\r\n   repeat\r\n    if (fLine[Run] = '*') and (fLine[Run +1] = '/') then\r\n     begin\r\n       inc(Run, 2);\r\n       fRange := rsUnknown;\r\n       break;\r\n     end\r\n    else\r\n     inc(Run);\r\n   until IsLineEnd(Run);\r\n  end;\r\nend;\r\n\r\nprocedure TSynRCSyn.DirectiveProc;\r\nbegin\r\n  fTokenId := tkDirective;\r\n  repeat\r\n   if (fLine[Run] = '/') then\r\n    begin\r\n      if fLine[Run +1] = '/' then\r\n       begin\r\n         fRange := rsUnknown;\r\n         exit;\r\n       end\r\n      else\r\n       if fLine[Run +1] = '*' then\r\n        begin\r\n          fRange := rsComment;\r\n          exit;\r\n        end\r\n    end;\r\n   inc(Run);\r\n  until IsLineEnd(Run);\r\nend;\r\n\r\nprocedure TSynRCSyn.IdentProc;\r\nbegin\r\n  fTokenId := IdentKind((fLine + Run));\r\n  inc(Run, fStringLen);\r\n  while IsIdentChar(fLine[Run]) do inc(Run);\r\nend;\r\n\r\nprocedure TSynRCSyn.CRProc;\r\nbegin\r\n  fTokenID := tkSpace;\r\n  inc(Run);\r\n  if fLine[Run] = #10 then\r\n   inc(Run);\r\nend;\r\n\r\nprocedure TSynRCSyn.LFProc;\r\nbegin\r\n  inc(Run);\r\n  fTokenID := tkSpace;\r\nend;\r\n\r\nprocedure TSynRCSyn.SpaceProc;\r\nbegin\r\n  inc(Run);\r\n  fTokenId := tkSpace;\r\n  while (FLine[Run] <= #32) and not IsLineEnd(Run) do inc(Run);\r\nend;\r\n\r\nprocedure TSynRCSyn.NullProc;\r\nbegin\r\n  fTokenId := tkNull;\r\n  inc(Run);\r\nend;\r\n\r\nprocedure TSynRCSyn.NumberProc;\r\n\r\n  function IsNumberChar: Boolean;\r\n  begin\r\n    case fLine[Run] of\r\n      '0'..'9', '.', 'u', 'U', 'x', 'X',\r\n      'A'..'F', 'a'..'f', 'L', 'l', '-', '+':\r\n        Result := True;\r\n      else\r\n        Result := False;\r\n    end;\r\n  end;\r\n\r\nbegin\r\n  inc(Run);\r\n  fTokenID := tkNumber;\r\n  while IsNumberChar do\r\n   begin\r\n     case fLine[Run] of\r\n      '.': if fLine[Run + 1] = '.' then break;\r\n     end;\r\n     inc(Run);\r\n   end;\r\nend;\r\n\r\nprocedure TSynRCSyn.SymbolProc;\r\nbegin\r\n  inc(Run);\r\n  fTokenID := tkSymbol;\r\nend;\r\n\r\nprocedure TSynRCSyn.UnknownProc;\r\nbegin\r\n  inc(Run);\r\n  fTokenID := tkUnknown;\r\nend;\r\n\r\nprocedure TSynRCSyn.Next;\r\nbegin\r\n  fTokenPos := Run;\r\n  case fRange of\r\n    rsDirective: DirectiveProc;\r\n    rsComment: CommentProc;\r\n    else\r\n      case fLine[Run] of\r\n        #0: NullProc;\r\n        #13: CRProc;\r\n        #10: LFProc;\r\n        '/': SlashProc;\r\n        '\"': QuoteProc;\r\n        '#': DirectiveProc;\r\n        'A'..'Z', 'a'..'z', '_': IdentProc;\r\n        '0'..'9': NumberProc;\r\n        #1..#9, #11, #12, #14..#32: SpaceProc;\r\n        '|', ',', '{', '}': SymbolProc;\r\n        else UnknownProc;\r\n      end;\r\n  end;\r\n  inherited;\r\nend;\r\n\r\nfunction TSynRCSyn.GetDefaultAttribute(Index: Integer): TSynHighlighterAttributes;\r\nbegin\r\n  case Index of\r\n    SYN_ATTR_COMMENT: Result := fCommentAttri;\r\n    SYN_ATTR_IDENTIFIER: Result := fIdentifierAttri;\r\n    SYN_ATTR_KEYWORD: Result := fKeyAttri;\r\n    SYN_ATTR_STRING: Result := fStringAttri;\r\n    SYN_ATTR_WHITESPACE: Result := fSpaceAttri;\r\n    SYN_ATTR_SYMBOL: Result := fSymbolAttri;\r\n    else Result := nil;\r\n  end;\r\nend;\r\n\r\nfunction TSynRCSyn.GetEol: boolean;\r\nbegin\r\n  Result := Run = fLineLen + 1;\r\nend;\r\n\r\nfunction TSynRCSyn.GetRange: pointer;\r\nbegin\r\n  Result := pointer(fRange);\r\nend;\r\n\r\nfunction TSynRCSyn.GetTokenID: TtkTokenKind;\r\nbegin\r\n  Result := fTokenID;\r\nend;\r\n\r\nfunction TSynRCSyn.GetTokenAttribute: TSynHighlighterAttributes;\r\nbegin\r\n  case fTokenID of\r\n    tkComment: Result := fCommentAttri;\r\n    tkDirective: Result := fDirecAttri;\r\n    tkIdentifier: Result := fIdentifierAttri;\r\n    tkKey: Result := fKeyAttri;\r\n    tkNumber: Result := fNumberAttri;\r\n    tkSpace: Result := fSpaceAttri;\r\n    tkString: Result := fStringAttri;\r\n    tkSymbol: Result := fSymbolAttri;\r\n    tkUnknown: Result := fSymbolAttri;\r\n    else Result := nil;\r\n  end;\r\nend;\r\n\r\nfunction TSynRCSyn.GetTokenKind: Integer;\r\nbegin\r\n  Result := ord(GetTokenID);\r\nend;\r\n\r\nprocedure TSynRCSyn.ResetRange;\r\nbegin\r\n  fRange := rsUnknown;\r\nend;\r\n\r\nprocedure TSynRCSyn.SetRange(Value: Pointer);\r\nbegin\r\n  fRange := TRangeState(Value);\r\nend;\r\n\r\nprocedure TSynRCSyn.EnumUserSettings(Settings: TStrings);\r\nbegin\r\n  // ** ??\r\nend;\r\n\r\nfunction TSynRCSyn.UseUserSettings(SettingIndex: integer): boolean;\r\nbegin\r\n  Result := False;\r\nend;\r\n\r\nclass function TSynRCSyn.GetCapabilities: TSynHighlighterCapabilities;\r\nbegin\r\n  Result := inherited GetCapabilities;\r\nend;\r\n\r\nfunction TSynRCSyn.IsFilterStored: Boolean;\r\nbegin\r\n  Result := fDefaultFilter <> SYNS_FilterRC;\r\nend;\r\n\r\nclass function TSynRCSyn.GetLanguageName: string;\r\nbegin\r\n  Result := SYNS_LangRC;\r\nend;\r\n\r\nfunction TSynRCSyn.GetSampleSource: UnicodeString;\r\nbegin\r\n  Result := '';\r\nend;\r\n\r\nclass function TSynRCSyn.GetFriendlyLanguageName: UnicodeString;\r\nbegin\r\n  Result := SYNS_FriendlyLangRC;\r\nend;\r\n\r\ninitialization\r\n{$IFNDEF SYN_CPPB_1}\r\n  RegisterPlaceableHighlighter(TSynRCSyn);\r\n{$ENDIF}\r\nend.\r\n"
  },
  {
    "path": "External/SynEdit/Source/SynHighlighterRuby.pas",
    "content": "{-------------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: SynHighlighterRuby.pas, released 2001-11-13.\r\nThe Initial Author of this file is Stefan Ascher.\r\nPortions by Jan Verhoeven (http://jansfreeware.com/jfdelphi.htm)\r\n\"Heredoc\" syntax highlighting implementation by Marko Njezic.\r\nUnicode translation by Mal Hrz.\r\nAll Rights Reserved.\r\n\r\nContributors to the SynEdit and mwEdit projects are listed in the\r\nContributors.txt file.\r\n\r\nAlternatively, the contents of this file may be used under the terms of the\r\nGNU General Public License Version 2 or later (the \"GPL\"), in which case\r\nthe provisions of the GPL are applicable instead of those above.\r\nIf you wish to allow use of your version of this file only under the terms\r\nof the GPL and not to allow others to use your version of this file\r\nunder the MPL, indicate your decision by deleting the provisions above and\r\nreplace them with the notice and other provisions required by the GPL.\r\nIf you do not delete the provisions above, a recipient may use your version\r\nof this file under either the MPL or the GPL.\r\n\r\n$Id: SynHighlighterRuby.pas,v 1.10.2.9 2008/09/14 16:25:03 maelh Exp $\r\n\r\nYou may retrieve the latest version of this file at the SynEdit home page,\r\nlocated at http://SynEdit.SourceForge.net\r\n\r\nKnown Issues:\r\n-------------------------------------------------------------------------------}\r\n{\r\n@abstract(Provides a Ruby highlighter for SynEdit)\r\n@author(Stefan Ascher )\r\n@created(21 May 2001)\r\n@lastmod(2001-11-13)\r\nThe SynHighlighterVisualLisp unit provides SynEdit with a Ruby highlighter.\r\n}\r\n\r\n{$IFNDEF QSYNHIGHLIGHTERRUBY}\r\nunit SynHighlighterRuby;\r\n{$ENDIF}\r\n\r\n{$I SynEdit.inc}\r\n\r\ninterface\r\n\r\nuses\r\n{$IFDEF SYN_CLX}\r\n  QGraphics,\r\n  QSynEditTypes,\r\n  QSynEditHighlighter,\r\n  QSynUnicode,  \r\n{$ELSE}\r\n  Graphics,\r\n  SynEditTypes,\r\n  SynEditHighlighter,\r\n  SynUnicode,\r\n{$ENDIF}\r\n  SysUtils,\r\n  Classes;\r\n\r\ntype\r\n  TtkTokenKind = (tkComment, tkIdentifier, tkKey, tkNull, tkNumber, tkSecondKey,\r\n    tkSpace, tkString, tkSymbol, tkUnknown);\r\n\r\n{$IFDEF SYN_HEREDOC}\r\n  TRangeState = (rsUnknown, rsHeredoc, rsIndentedHeredoc);\r\n\r\n  TRangePointer = packed record\r\n    case Boolean of\r\n      True: (Ptr: Pointer);\r\n      False: (Range: Byte; Length: Byte; Checksum: Word);\r\n    end;\r\n{$ELSE}\r\n  TRangeState = (rsUnknown);\r\n{$ENDIF}\r\n\r\ntype\r\n  TSynRubySyn = class(TSynCustomHighlighter)\r\n  private\r\n    fRange: TRangeState;\r\n{$IFDEF SYN_HEREDOC}\r\n    fHeredocLength: Byte;\r\n    fHeredocChecksum: Word;\r\n{$ENDIF}\r\n    FTokenID: TtkTokenKind;\r\n    fStringAttri: TSynHighlighterAttributes;\r\n    fSymbolAttri: TSynHighlighterAttributes;\r\n    fKeyAttri: TSynHighlighterAttributes;\r\n    fSecondKeyAttri: TSynHighlighterAttributes;\r\n    fNumberAttri: TSynHighlighterAttributes;\r\n    fCommentAttri: TSynHighlighterAttributes;\r\n    fSpaceAttri: TSynHighlighterAttributes;\r\n    fIdentifierAttri: TSynHighlighterAttributes;\r\n    fKeyWords: TUnicodeStrings;\r\n    fSecondKeys: TUnicodeStrings;\r\n    procedure BraceOpenProc;\r\n    procedure PointCommaProc;\r\n    procedure CRProc;\r\n    procedure IdentProc;\r\n    procedure LFProc;\r\n    procedure LowerProc;\r\n    procedure NullProc;\r\n    procedure NumberProc;\r\n    procedure RoundOpenProc;\r\n    procedure SlashProc;\r\n    procedure SpaceProc;\r\n    procedure StringProc;\r\n    procedure UnknownProc;\r\n{$IFDEF SYN_HEREDOC}\r\n    procedure HeredocProc;\r\n{$ENDIF}\r\n    procedure SetSecondKeys(const Value: TUnicodeStrings);\r\n  protected\r\n    function GetSampleSource: UnicodeString; override;\r\n    function IsFilterStored: Boolean; override;\r\n    procedure NextProcedure;\r\n  public\r\n    class function GetLanguageName: string; override;\r\n    class function GetFriendlyLanguageName: UnicodeString; override;\r\n  public\r\n    constructor Create(AOwner: TComponent); override;\r\n    destructor Destroy; override;\r\n    function GetDefaultAttribute(Index: integer): TSynHighlighterAttributes;\r\n      override;\r\n    function GetEol: Boolean; override;\r\n    function GetRange: Pointer; override;\r\n    function GetTokenID: TtkTokenKind;\r\n    function IsKeyword(const AKeyword: UnicodeString): boolean; override;\r\n    function IsSecondKeyWord(aToken: UnicodeString): Boolean;\r\n    function GetTokenAttribute: TSynHighlighterAttributes; override;\r\n    function GetTokenKind: integer; override;\r\n    procedure Next; override;\r\n    procedure SetRange(Value: Pointer); override;\r\n    procedure ResetRange; override;\r\n  published\r\n    property CommentAttri: TSynHighlighterAttributes read fCommentAttri\r\n      write fCommentAttri;\r\n    property IdentifierAttri: TSynHighlighterAttributes read fIdentifierAttri\r\n      write fIdentifierAttri;\r\n    property KeyAttri: TSynHighlighterAttributes read fKeyAttri write fKeyAttri;\r\n    property SecondKeyAttri: TSynHighlighterAttributes read fSecondKeyAttri\r\n      write fSecondKeyAttri;\r\n    property SecondKeyWords: TUnicodeStrings read fSecondKeys write SetSecondKeys;\r\n    property NumberAttri: TSynHighlighterAttributes read fNumberAttri\r\n      write fNumberAttri;\r\n    property SpaceAttri: TSynHighlighterAttributes read fSpaceAttri\r\n      write fSpaceAttri;\r\n    property StringAttri: TSynHighlighterAttributes read fStringAttri\r\n      write fStringAttri;\r\n    property SymbolAttri: TSynHighlighterAttributes read fSymbolAttri\r\n      write fSymbolAttri;\r\n  end;\r\n\r\nimplementation\r\n\r\nuses\r\n{$IFDEF SYN_CLX}\r\n  QSynEditMiscProcs,\r\n  QSynEditStrConst;\r\n{$ELSE}\r\n  SynEditMiscProcs,\r\n  SynEditStrConst;\r\n{$ENDIF}\r\n\r\nconst\r\n  RubyKeysCount = 43;\r\n  RubyKeys: array[1..RubyKeysCount] of UnicodeString = (\r\n    'alias', 'attr', 'begin', 'break', 'case', 'class', 'def', 'do', 'else',\r\n    'elsif', 'end', 'ensure', 'exit', 'extend', 'false', 'for', 'gets', 'if',\r\n    'in', 'include', 'load', 'loop', 'module', 'next', 'nil', 'not', 'print',\r\n    'private', 'public', 'puts', 'raise', 'redo', 'require', 'rescue', 'retry',\r\n    'return', 'self', 'then', 'true', 'unless', 'when', 'while', 'yield');\r\n\r\nfunction TSynRubySyn.IsKeyword(const AKeyword: UnicodeString): Boolean;\r\nvar\r\n  First, Last, I, Compare: Integer;\r\n  Token: UnicodeString;\r\nbegin\r\n  First := 0;\r\n  Last := fKeywords.Count - 1;\r\n  Result := False;\r\n  Token := SynWideUpperCase(AKeyword);\r\n\r\n  while First <= Last do\r\n  begin\r\n    I := (First + Last) shr 1;\r\n    Compare := WideCompareStr(fKeywords[I], Token);\r\n    if Compare = 0 then\r\n    begin\r\n      Result := True;\r\n      break;\r\n    end\r\n    else if Compare < 0 then\r\n      First := I + 1\r\n    else\r\n      Last := I - 1;\r\n  end;\r\nend; { IsKeyWord }\r\n\r\nfunction TSynRubySyn.IsSecondKeyWord(aToken: UnicodeString): Boolean;\r\nvar\r\n  First, Last, I, Compare: Integer;\r\n  Token: UnicodeString;\r\nbegin\r\n  First := 0;\r\n  Last := fSecondKeys.Count - 1;\r\n  Result := False;\r\n  Token := SynWideUpperCase(aToken);\r\n  while First <= Last do\r\n  begin\r\n    I := (First + Last) shr 1;\r\n    Compare := WideCompareStr(fSecondKeys[i], Token);\r\n    if Compare = 0 then\r\n    begin\r\n      Result := True;\r\n      break;\r\n    end\r\n    else if Compare < 0 then\r\n      First := I + 1\r\n    else\r\n      Last := I - 1;\r\n  end;\r\nend; { IsSecondKeyWord }\r\n\r\nconstructor TSynRubySyn.Create(AOwner: TComponent);\r\nvar\r\n  i: integer;\r\nbegin\r\n  inherited Create(AOwner);\r\n\r\n  fCaseSensitive := False;\r\n\r\n  fKeyWords := TUnicodeStringList.Create;\r\n  TUnicodeStringList(fKeyWords).Sorted := True;\r\n  TUnicodeStringList(fKeyWords).Duplicates := dupIgnore;\r\n  fSecondKeys := TUnicodeStringList.Create;\r\n  TUnicodeStringList(fSecondKeys).Sorted := True;\r\n  TUnicodeStringList(fSecondKeys).Duplicates := dupIgnore;\r\n  if not (csDesigning in ComponentState) then\r\n    for i := 1 to RubyKeysCount do\r\n      fKeyWords.Add(RubyKeys[i]);\r\n\r\n  fCommentAttri := TSynHighlighterAttributes.Create(SYNS_AttrComment, SYNS_FriendlyAttrComment);\r\n  fCommentAttri.Foreground := clMaroon;\r\n  AddAttribute(fCommentAttri);\r\n  fIdentifierAttri := TSynHighlighterAttributes.Create(SYNS_AttrIdentifier, SYNS_FriendlyAttrIdentifier);\r\n  AddAttribute(fIdentifierAttri);\r\n  fKeyAttri := TSynHighlighterAttributes.Create(SYNS_AttrReservedWord, SYNS_FriendlyAttrReservedWord);\r\n  fKeyAttri.Foreground := clBlue;\r\n  AddAttribute(fKeyAttri);\r\n  fSecondKeyAttri := TSynHighlighterAttributes.Create(SYNS_AttrSecondReservedWord, SYNS_FriendlyAttrSecondReservedWord);\r\n  AddAttribute(fSecondKeyAttri);\r\n  fNumberAttri := TSynHighlighterAttributes.Create(SYNS_AttrNumber, SYNS_FriendlyAttrNumber);\r\n  fNumberAttri.Foreground := clGreen;\r\n  AddAttribute(fNumberAttri);\r\n  fSpaceAttri := TSynHighlighterAttributes.Create(SYNS_AttrSpace, SYNS_FriendlyAttrSpace);\r\n  AddAttribute(fSpaceAttri);\r\n  fStringAttri := TSynHighlighterAttributes.Create(SYNS_AttrString, SYNS_FriendlyAttrString);\r\n  fStringAttri.Foreground := clPurple;\r\n  AddAttribute(fStringAttri);\r\n  fSymbolAttri := TSynHighlighterAttributes.Create(SYNS_AttrSymbol, SYNS_FriendlyAttrSymbol);\r\n  fSymbolAttri.Foreground := clBlue;\r\n  AddAttribute(fSymbolAttri);\r\n  SetAttributesOnChange(DefHighlightChange);\r\n\r\n  fRange := rsUnknown;\r\n  fDefaultFilter := SYNS_FilterRuby;\r\nend; { Create }\r\n\r\ndestructor TSynRubySyn.Destroy;\r\nbegin\r\n  fKeyWords.Free;\r\n  fSecondKeys.Free;\r\n  inherited Destroy;\r\nend; { Destroy }\r\n\r\nprocedure TSynRubySyn.BraceOpenProc;\r\nbegin\r\n  inc(Run);\r\n  fTokenID := tkSymbol;\r\nend;\r\n\r\nprocedure TSynRubySyn.PointCommaProc;\r\nbegin\r\n  inc(Run);\r\n  fTokenID := tkSymbol;\r\nend;\r\n\r\nprocedure TSynRubySyn.CRProc;\r\nbegin\r\n  fTokenID := tkSpace;\r\n  case FLine[Run + 1] of\r\n    #10: inc(Run, 2);\r\n  else inc(Run);\r\n  end;\r\nend;\r\n\r\nprocedure TSynRubySyn.IdentProc;\r\nbegin\r\n  while IsIdentChar(fLine[Run]) do inc(Run);\r\n  if IsKeyWord(GetToken) then\r\n  begin\r\n    fTokenId := tkKey;\r\n    Exit;\r\n  end\r\n  else fTokenId := tkIdentifier;\r\n  if IsSecondKeyWord(GetToken) then\r\n    fTokenId := tkSecondKey\r\n  else\r\n    fTokenId := tkIdentifier;\r\nend;\r\n\r\nprocedure TSynRubySyn.LFProc;\r\nbegin\r\n  fTokenID := tkSpace;\r\n  inc(Run);\r\nend;\r\n\r\nprocedure TSynRubySyn.LowerProc;\r\n{$IFDEF SYN_HEREDOC}\r\nvar\r\n  i, Len, SkipRun: Integer;\r\n  IndentedHeredoc: Boolean;\r\n  QuoteChar: WideChar;\r\n{$ENDIF}\r\nbegin\r\n{$IFDEF SYN_HEREDOC}\r\n  if FLine[Run + 1] = '<' then\r\n  begin\r\n    fTokenID := tkSymbol;\r\n\r\n    SkipRun := 0;\r\n    QuoteChar := #0;\r\n    if (FLine[Run + 2] = '-') and (FLine[Run + 3] in\r\n      [WideChar('\"'), WideChar(''''), WideChar('`')]) then\r\n    begin\r\n      SkipRun := 2;\r\n      QuoteChar := FLine[Run + 3];\r\n    end\r\n    else\r\n    if (FLine[Run + 2] in [WideChar('-'), WideChar('\"'), WideChar(''''), WideChar('`')]) then\r\n    begin\r\n      SkipRun := 1;\r\n      if FLine[Run + 2] <> '-' then\r\n        QuoteChar := FLine[Run + 2];\r\n    end;\r\n    IndentedHeredoc := (SkipRun > 0) and (FLine[Run + 2] = '-');\r\n\r\n    if IsIdentChar(FLine[Run + SkipRun + 2]) then\r\n    begin\r\n      inc(Run, 2);\r\n\r\n      i := Run;\r\n      while IsIdentChar(FLine[SkipRun + i]) do Inc(i);\r\n      Len := i - Run;\r\n\r\n      if Len > 255 then\r\n      begin\r\n        fTokenID := tkUnknown;\r\n        Exit;\r\n      end;\r\n\r\n      if (QuoteChar <> #0) and (FLine[Run + SkipRun + Len] <> QuoteChar) then\r\n      begin\r\n        fTokenID := tkUnknown;\r\n        Exit;\r\n      end;\r\n\r\n      if IndentedHeredoc then\r\n        fRange := rsIndentedHeredoc\r\n      else\r\n        fRange := rsHeredoc;\r\n      fHeredocLength := Len;\r\n      fHeredocChecksum := CalcFCS(FLine[Run + SkipRun], Len);\r\n\r\n      Inc(Run, SkipRun + Len);\r\n      fTokenID := tkString;\r\n    end\r\n    else\r\n      inc(Run, 2);\r\n  end\r\n  else\r\n{$ENDIF}\r\n  begin\r\n    inc(Run);\r\n    fTokenID := tkSymbol;\r\n  end;\r\nend;\r\n\r\nprocedure TSynRubySyn.NullProc;\r\nbegin\r\n  fTokenID := tkNull;\r\n  inc(Run);\r\nend;\r\n\r\nprocedure TSynRubySyn.NumberProc;\r\n\r\n  function IsNumberChar: Boolean;\r\n  begin\r\n    case fLine[Run] of\r\n      '0'..'9', '.', 'e', 'E':\r\n        Result := True;\r\n      else\r\n        Result := False;\r\n    end;\r\n  end;\r\n\r\nbegin\r\n  inc(Run);\r\n  fTokenID := tkNumber;\r\n  while IsNumberChar do\r\n  begin\r\n    case FLine[Run] of\r\n      '.':\r\n        if FLine[Run + 1] = '.' then break;\r\n    end;\r\n    inc(Run);\r\n  end;\r\nend;\r\n\r\nprocedure TSynRubySyn.RoundOpenProc;\r\nbegin\r\n  inc(Run);\r\n  fTokenId := tkSymbol;\r\nend;\r\n\r\nprocedure TSynRubySyn.SlashProc;\r\nbegin\r\n  case FLine[Run] of\r\n    '/':\r\n      begin\r\n        inc(Run);\r\n        fTokenId := tkSymbol;\r\n      end;\r\n    '*':\r\n      begin\r\n        inc(Run);\r\n        fTokenId := tkSymbol;\r\n      end;\r\n  else\r\n    begin\r\n      fTokenID := tkComment;\r\n      while FLine[Run] <> #0 do\r\n      begin\r\n        case FLine[Run] of\r\n          #10, #13: break;\r\n        end;\r\n        inc(Run);\r\n      end;\r\n    end;\r\n  end;\r\nend;\r\n\r\nprocedure TSynRubySyn.SpaceProc;\r\nbegin\r\n  inc(Run);\r\n  fTokenID := tkSpace;\r\n  while (FLine[Run] <= #32) and not IsLineEnd(Run) do inc(Run);\r\nend;\r\n\r\nprocedure TSynRubySyn.StringProc;\r\nvar\r\n  QuoteChar: WideChar;\r\nbegin\r\n// Ha, ha, Strings in Ruby (could be anything)!!!!\r\n\r\n//There are three more ways to construct string literals: %q, %Q, and ``here\r\n//documents.''\r\n//\r\n//%q and %Q start delimited single- and double-quoted strings.\r\n//\r\n//%q/general single-quoted string/  general single-quoted string\r\n//%Q!general double-quoted string!  general double-quoted string\r\n//%Q{Seconds/day: #{24*60*60}}      Seconds/day: 86400\r\n//\r\n//The character following the ``q'' or ``Q'' is the delimiter. If it is an\r\n//opening bracket, brace, parenthesis, or less-than sign, the string is read\r\n//until the matching close symbol is found. Otherwise the string is read until\r\n//the next occurrence of the same delimiter.\r\n\r\n  fTokenID := tkString;\r\n  QuoteChar := FLine[Run];      // either \" or '\r\n  if (FLine[Run + 1] = QuoteChar) and (FLine[Run + 2] = QuoteChar)\r\n    then inc(Run, 2);\r\n  repeat\r\n    case FLine[Run] of\r\n      #0, #10, #13: break;\r\n    end;\r\n    inc(Run);\r\n  until FLine[Run] = QuoteChar;\r\n  if FLine[Run] <> #0 then inc(Run);\r\nend;\r\n\r\nprocedure TSynRubySyn.UnknownProc;\r\nbegin\r\n  inc(Run);\r\n  fTokenID := tkUnknown;\r\nend;\r\n\r\n{$IFDEF SYN_HEREDOC}\r\nprocedure TSynRubySyn.HeredocProc;\r\n\r\n  procedure SkipToEOL;\r\n  begin\r\n    case FLine[Run] of\r\n       #0: NullProc;\r\n      #10: LFProc;\r\n      #13: CRProc;\r\n    else\r\n      repeat\r\n        inc(Run);\r\n      until IsLineEnd(Run);\r\n    end;\r\n  end;\r\n\r\nvar\r\n  i : Integer;\r\nbegin\r\n  if IsLineEnd(Run) and (fTokenPos = Run) then\r\n  begin\r\n    NextProcedure;\r\n    Exit;\r\n  end;\r\n  fTokenID := tkString;\r\n\r\n  if fRange = rsIndentedHeredoc then\r\n    while FLine[Run] in [WideChar(#9), WideChar(#32)] do Inc(Run);\r\n\r\n  if ((Run = 0) and (fRange = rsHeredoc)) or (fRange = rsIndentedHeredoc) then\r\n  begin\r\n    i := 0;\r\n\r\n    while not IsLineEnd(FLine[Run + i]) do\r\n    begin\r\n      if i > fHeredocLength then\r\n      begin\r\n        SkipToEOL;\r\n        Exit;\r\n      end;\r\n      Inc(i);\r\n    end;\r\n\r\n    if i <> fHeredocLength then\r\n    begin\r\n      SkipToEOL;\r\n      Exit;\r\n    end;\r\n\r\n    if (CalcFCS(FLine[Run], i) = fHeredocChecksum) then\r\n    begin\r\n      fRange := rsUnknown;\r\n      Run := Run + i;\r\n      Exit;\r\n    end;\r\n  end;\r\n\r\n  SkipToEOL;\r\nend;\r\n{$ENDIF}\r\n\r\nprocedure TSynRubySyn.Next;\r\nbegin\r\n  fTokenPos := Run;\r\n{$IFDEF SYN_HEREDOC}\r\n  if fRange in [rsHeredoc, rsIndentedHeredoc] then\r\n    HeredocProc\r\n  else\r\n{$ENDIF}\r\n    NextProcedure;\r\n  inherited;\r\nend;\r\n\r\nprocedure TSynRubySyn.NextProcedure;\r\nbegin\r\n  case fLine[Run] of\r\n    '<': LowerProc;\r\n    '#': SlashProc;\r\n    '{': BraceOpenProc;\r\n    ';': PointCommaProc;\r\n    #13: CRProc;\r\n    'A'..'Z', 'a'..'z', '_': IdentProc;\r\n    #10: LFProc;\r\n    #0: NullProc;\r\n    '0'..'9': NumberProc;\r\n    '(': RoundOpenProc;\r\n    '/': SlashProc;\r\n    #1..#9, #11, #12, #14..#32: SpaceProc;\r\n    #34, #39: StringProc;\r\n    else UnknownProc;\r\n  end;\r\nend;\r\n\r\nfunction TSynRubySyn.GetDefaultAttribute(Index: integer): TSynHighlighterAttributes;\r\nbegin\r\n  case Index of\r\n    SYN_ATTR_COMMENT: Result := fCommentAttri;\r\n    SYN_ATTR_IDENTIFIER: Result := fIdentifierAttri;\r\n    SYN_ATTR_KEYWORD: Result := fKeyAttri;\r\n    SYN_ATTR_STRING: Result := fStringAttri;\r\n    SYN_ATTR_WHITESPACE: Result := fSpaceAttri;\r\n  else\r\n    Result := nil;\r\n  end;\r\nend;\r\n\r\nfunction TSynRubySyn.GetEol: Boolean;\r\nbegin\r\n  Result := Run = fLineLen + 1;\r\nend;\r\n\r\nfunction TSynRubySyn.GetRange: Pointer;\r\n{$IFDEF SYN_HEREDOC}\r\nvar\r\n  RangePointer: TRangePointer;\r\n{$ENDIF}\r\nbegin\r\n{$IFDEF SYN_HEREDOC}\r\n  RangePointer.Range := Ord(fRange);\r\n  RangePointer.Length := 0;\r\n  RangePointer.Checksum := 0;\r\n  if fRange in [rsHeredoc, rsIndentedHeredoc] then\r\n  begin\r\n    RangePointer.Length := fHeredocLength;\r\n    RangePointer.Checksum := fHeredocChecksum;\r\n  end;\r\n  Result := RangePointer.Ptr;\r\n{$ELSE}\r\n  Result := Pointer(fRange);\r\n{$ENDIF}\r\nend;\r\n\r\nfunction TSynRubySyn.GetTokenID: TtkTokenKind;\r\nbegin\r\n  Result := fTokenId;\r\nend;\r\n\r\nfunction TSynRubySyn.GetTokenAttribute: TSynHighlighterAttributes;\r\nbegin\r\n  case fTokenID of\r\n    tkComment: Result := fCommentAttri;\r\n    tkIdentifier: Result := fIdentifierAttri;\r\n    tkKey: Result := fKeyAttri;\r\n    tkSecondKey: Result := fSecondKeyAttri;\r\n    tkNumber: Result := fNumberAttri;\r\n    tkSpace: Result := fSpaceAttri;\r\n    tkString: Result := fStringAttri;\r\n    tkSymbol: Result := fSymbolAttri;\r\n    tkUnknown: Result := fSymbolAttri;\r\n  else\r\n    Result := nil;\r\n  end;\r\nend;\r\n\r\nfunction TSynRubySyn.GetTokenKind: integer;\r\nbegin\r\n  Result := Ord(fTokenId);\r\nend;\r\n\r\nprocedure TSynRubySyn.ResetRange;\r\nbegin\r\n  fRange := rsUnknown;\r\n{$IFDEF SYN_HEREDOC}\r\n  fHeredocLength := 0;\r\n  fHeredocChecksum := 0;\r\n{$ENDIF}\r\nend;\r\n\r\nprocedure TSynRubySyn.SetRange(Value: Pointer);\r\n{$IFDEF SYN_HEREDOC}\r\nvar\r\n  RangePointer: TRangePointer;\r\n{$ENDIF}\r\nbegin\r\n{$IFDEF SYN_HEREDOC}\r\n  RangePointer := TRangePointer(Value);\r\n  fRange := TRangeState(RangePointer.Range);\r\n  fHeredocLength := 0;\r\n  fHeredocChecksum := 0;\r\n  if fRange in [rsHeredoc, rsIndentedHeredoc] then\r\n  begin\r\n    fHeredocLength := RangePointer.Length;\r\n    fHeredocChecksum := RangePointer.Checksum;\r\n  end;\r\n{$ELSE}\r\n  fRange := TRangeState(Value);\r\n{$ENDIF}\r\nend;\r\n\r\nprocedure TSynRubySyn.SetSecondKeys(const Value: TUnicodeStrings);\r\nvar\r\n  i: Integer;\r\nbegin\r\n  if Value <> nil then\r\n    begin\r\n      Value.BeginUpdate;\r\n      for i := 0 to Value.Count - 1 do\r\n        Value[i] := SynWideUpperCase(Value[i]);\r\n      Value.EndUpdate;\r\n    end;\r\n  fSecondKeys.Assign(Value);\r\n  DefHighLightChange(nil);\r\nend;\r\n\r\nfunction TSynRubySyn.IsFilterStored: Boolean;\r\nbegin\r\n  Result := fDefaultFilter <> SYNS_FilterRuby;\r\nend;\r\n\r\nclass function TSynRubySyn.GetLanguageName: string;\r\nbegin\r\n  Result := SYNS_LangRuby;\r\nend;\r\n\r\nfunction TSynRubySyn.GetSampleSource: UnicodeString;\r\nbegin\r\n  Result :=\r\n    '# Factorial'+#13#10+\r\n    'def fact(n)'+#13#10+\r\n    '  if n == 0'+#13#10+\r\n    '    1'+#13#10+\r\n    '  else'+#13#10+\r\n    '    n * fact(n-1)'+#13#10+\r\n    '  end'+#13#10+\r\n    'end'+#13#10+\r\n    'print fact(ARGV[0].to_i), \"\\n\"';\r\nend;\r\n\r\nclass function TSynRubySyn.GetFriendlyLanguageName: UnicodeString;\r\nbegin\r\n  Result := SYNS_FriendlyLangRuby;\r\nend;\r\n\r\ninitialization\r\n{$IFNDEF SYN_CPPB_1}\r\n  RegisterPlaceableHighlighter(TSynRubySyn);\r\n{$ENDIF}\r\nend.\r\n"
  },
  {
    "path": "External/SynEdit/Source/SynHighlighterSDD.pas",
    "content": "{-------------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: SynHighlighterSDD.pas, released 2001-08-20.\r\nThe Initial Author of this file is Pieter Polak.\r\nUnicode translation by Mal Hrz.\r\nAll Rights Reserved.\r\n\r\nContributors to the SynEdit and mwEdit projects are listed in the\r\nContributors.txt file.\r\n\r\nAlternatively, the contents of this file may be used under the terms of the\r\nGNU General Public License Version 2 or later (the \"GPL\"), in which case\r\nthe provisions of the GPL are applicable instead of those above.\r\nIf you wish to allow use of your version of this file only under the terms\r\nof the GPL and not to allow others to use your version of this file\r\nunder the MPL, indicate your decision by deleting the provisions above and\r\nreplace them with the notice and other provisions required by the GPL.\r\nIf you do not delete the provisions above, a recipient may use your version\r\nof this file under either the MPL or the GPL.\r\n\r\n$Id: SynHighlighterSDD.pas,v 1.13.2.6 2008/09/14 16:25:03 maelh Exp $\r\n\r\nYou may retrieve the latest version of this file at the SynEdit home page,\r\nlocated at http://SynEdit.SourceForge.net\r\n\r\n-------------------------------------------------------------------------------}\r\n\r\n{$IFNDEF QSYNHIGHLIGHTERSDD}\r\nunit SynHighlighterSDD;\r\n{$ENDIF}\r\n\r\n{$I SynEdit.inc}\r\n\r\ninterface\r\n\r\nuses\r\n{$IFDEF SYN_CLX}\r\n  QGraphics,\r\n  QSynEditTypes,\r\n  QSynEditHighlighter,\r\n  QSynUnicode,\r\n{$ELSE}\r\n  Windows,\r\n  Graphics,\r\n  SynEditTypes,\r\n  SynEditHighlighter,\r\n  SynUnicode,\r\n{$ENDIF}\r\n  SysUtils,\r\n  Classes;\r\n\r\ntype\r\n  TtkTokenKind = (\r\n    tkComment,\r\n    tkIdentifier,\r\n    tkKey,\r\n    tkDatatype,\r\n    tkNumber,\r\n    tkNull,\r\n    tkSpace,\r\n    tkSymbol,\r\n    tkUnknown);\r\n\r\n  PIdentFuncTableFunc = ^TIdentFuncTableFunc;\r\n  TIdentFuncTableFunc = function (Index: Integer): TtkTokenKind of object;\r\n\r\n  TRangeState = (rsComment, rsUnKnown);\r\n\r\ntype\r\n  TSynSDDSyn = class(TSynCustomHighlighter)\r\n  private\r\n    fRange: TRangeState;\r\n    fTokenID: TtkTokenKind;\r\n    fIdentFuncTable: array[0..36] of TIdentFuncTableFunc;\r\n    fCommentAttri: TSynHighlighterAttributes;\r\n    fIdentifierAttri: TSynHighlighterAttributes;\r\n    fKeyAttri: TSynHighlighterAttributes;\r\n    fDatatypeAttri: TSynHighlighterAttributes;\r\n    fNumberAttri: TSynHighlighterAttributes;\r\n    fSpaceAttri: TSynHighlighterAttributes;\r\n    fSymbolAttri: TSynHighlighterAttributes;\r\n    function AltFunc(Index: Integer): TtkTokenKind;\r\n    function FuncArray(Index: Integer): TtkTokenKind;\r\n    function FuncBinarydata(Index: Integer): TtkTokenKind;\r\n    function FuncBlock(Index: Integer): TtkTokenKind;\r\n    function FuncByte(Index: Integer): TtkTokenKind;\r\n    function FuncDatabase(Index: Integer): TtkTokenKind;\r\n    function FuncDate(Index: Integer): TtkTokenKind;\r\n    function FuncEnd(Index: Integer): TtkTokenKind;\r\n    function FuncEndblock(Index: Integer): TtkTokenKind;\r\n    function FuncInteger(Index: Integer): TtkTokenKind;\r\n    function FuncKeys(Index: Integer): TtkTokenKind;\r\n    function FuncLongint(Index: Integer): TtkTokenKind;\r\n    function FuncMemotext(Index: Integer): TtkTokenKind;\r\n    function FuncObject(Index: Integer): TtkTokenKind;\r\n    function FuncObjects(Index: Integer): TtkTokenKind;\r\n    function FuncOf(Index: Integer): TtkTokenKind;\r\n    function FuncOwner(Index: Integer): TtkTokenKind;\r\n    function FuncPartition(Index: Integer): TtkTokenKind;\r\n    function FuncPartitions(Index: Integer): TtkTokenKind;\r\n    function FuncPrimary(Index: Integer): TtkTokenKind;\r\n    function FuncReal(Index: Integer): TtkTokenKind;\r\n    function FuncSecondary(Index: Integer): TtkTokenKind;\r\n    function FuncSpec(Index: Integer): TtkTokenKind;\r\n    function FuncString(Index: Integer): TtkTokenKind;\r\n    function FuncSuperblock(Index: Integer): TtkTokenKind;\r\n    function FuncSuperspec(Index: Integer): TtkTokenKind;\r\n    function FuncTime(Index: Integer): TtkTokenKind;\r\n    function FuncVar(Index: Integer): TtkTokenKind;\r\n    function HashKey(Str: PWideChar): Cardinal;\r\n    function IdentKind(MayBe: PWideChar): TtkTokenKind;\r\n    procedure InitIdent;\r\n    procedure BraceOpenProc;\r\n    procedure BraceCommentProc;\r\n    procedure NumberProc;                                                    \r\n    procedure CRProc;\r\n    procedure LFProc;\r\n    procedure IdentProc;\r\n    procedure NullProc;\r\n    procedure SpaceProc;\r\n    procedure UnknownProc;\r\n    procedure SymbolProc;\r\n  protected\r\n    function GetSampleSource: UnicodeString; override;\r\n    function IsFilterStored: Boolean; override;\r\n  public\r\n    class function GetLanguageName: string; override;\r\n    class function GetFriendlyLanguageName: UnicodeString; override;   \r\n    function GetRange: Pointer; override;\r\n    procedure ResetRange; override;\r\n    procedure SetRange(Value: Pointer); override;\r\n  public\r\n    constructor Create(AOwner: TComponent); override;\r\n    function GetDefaultAttribute(Index: integer): TSynHighlighterAttributes;\r\n      override;\r\n    function GetEol: Boolean; override;\r\n    function GetTokenID: TtkTokenKind;\r\n    function GetTokenAttribute: TSynHighlighterAttributes; override;\r\n    function GetTokenKind: integer; override;\r\n    procedure Next; override;\r\n  published\r\n    property CommentAttri: TSynHighlighterAttributes read fCommentAttri write fCommentAttri;\r\n    property IdentifierAttri: TSynHighlighterAttributes read fIdentifierAttri write fIdentifierAttri;\r\n    property KeyAttri: TSynHighlighterAttributes read fKeyAttri write fKeyAttri;\r\n    property DatatypeAttri: TSynHighlighterAttributes read fDatatypeAttri write fDatatypeAttri;\r\n    property SpaceAttri: TSynHighlighterAttributes read fSpaceAttri write fSpaceAttri;\r\n    property NumberAttri: TSynHighlighterAttributes read fNumberAttri write fNumberAttri;\r\n    property SymbolAttri: TSynHighlighterAttributes read fSymbolAttri write fSymbolAttri;\r\n  end;\r\n\r\nimplementation\r\n\r\nuses\r\n{$IFDEF SYN_CLX}\r\n  QSynEditStrConst;\r\n{$ELSE}\r\n  SynEditStrConst;\r\n{$ENDIF}\r\n\r\nconst\r\n  KeyWords: array[0..26] of UnicodeString = (\r\n    'array', 'binarydata', 'block', 'byte', 'database', 'date', 'end',\r\n    'endblock', 'integer', 'keys', 'longint', 'memotext', 'object', 'objects',\r\n    'of', 'owner', 'partition', 'partitions', 'primary', 'real', 'secondary',\r\n    'spec', 'string', 'superblock', 'superspec', 'time', 'var'\r\n  );\r\n\r\n  KeyIndices: array[0..36] of Integer = (\r\n    8, 3, 18, 0, 25, 14, 16, 22, 5, 19, 10, 20, -1, -1, 2, 26, -1, 21, -1, 12,\r\n    1, 17, 15, -1, 9, -1, 11, 7, -1, 4, 6, -1, 13, -1, -1, 24, 23\r\n  );\r\n\r\n{$Q-}\r\nfunction TSynSDDSyn.HashKey(Str: PWideChar): Cardinal;\r\nbegin\r\n  Result := 0;\r\n  while IsIdentChar(Str^) do\r\n  begin\r\n    Result := Result * 813 + Ord(Str^) * 168;\r\n    inc(Str);\r\n  end;\r\n  Result := Result mod 37;\r\n  fStringLen := Str - fToIdent;\r\nend;\r\n{$Q+}\r\n\r\nfunction TSynSDDSyn.IdentKind(MayBe: PWideChar): TtkTokenKind;\r\nvar\r\n  Key: Cardinal;\r\nbegin\r\n  fToIdent := MayBe;\r\n  Key := HashKey(MayBe);\r\n  if Key <= High(fIdentFuncTable) then\r\n    Result := fIdentFuncTable[Key](KeyIndices[Key])\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nprocedure TSynSDDSyn.InitIdent;\r\nvar\r\n  i: Integer;\r\nbegin\r\n  for i := Low(fIdentFuncTable) to High(fIdentFuncTable) do\r\n    if KeyIndices[i] = -1 then\r\n      fIdentFuncTable[i] := AltFunc;\r\n\r\n  fIdentFuncTable[3] := FuncArray;\r\n  fIdentFuncTable[20] := FuncBinarydata;\r\n  fIdentFuncTable[14] := FuncBlock;\r\n  fIdentFuncTable[1] := FuncByte;\r\n  fIdentFuncTable[29] := FuncDatabase;\r\n  fIdentFuncTable[8] := FuncDate;\r\n  fIdentFuncTable[30] := FuncEnd;\r\n  fIdentFuncTable[27] := FuncEndblock;\r\n  fIdentFuncTable[0] := FuncInteger;\r\n  fIdentFuncTable[24] := FuncKeys;\r\n  fIdentFuncTable[10] := FuncLongint;\r\n  fIdentFuncTable[26] := FuncMemotext;\r\n  fIdentFuncTable[19] := FuncObject;\r\n  fIdentFuncTable[32] := FuncObjects;\r\n  fIdentFuncTable[5] := FuncOf;\r\n  fIdentFuncTable[22] := FuncOwner;\r\n  fIdentFuncTable[6] := FuncPartition;\r\n  fIdentFuncTable[21] := FuncPartitions;\r\n  fIdentFuncTable[2] := FuncPrimary;\r\n  fIdentFuncTable[9] := FuncReal;\r\n  fIdentFuncTable[11] := FuncSecondary;\r\n  fIdentFuncTable[17] := FuncSpec;\r\n  fIdentFuncTable[7] := FuncString;\r\n  fIdentFuncTable[36] := FuncSuperblock;\r\n  fIdentFuncTable[35] := FuncSuperspec;\r\n  fIdentFuncTable[4] := FuncTime;\r\n  fIdentFuncTable[15] := FuncVar;\r\nend;\r\n\r\nfunction TSynSDDSyn.AltFunc(Index: Integer): TtkTokenKind;\r\nbegin\r\n  Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynSDDSyn.FuncArray(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkDatatype\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynSDDSyn.FuncBinarydata(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkDatatype\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynSDDSyn.FuncBlock(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynSDDSyn.FuncByte(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkDatatype\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynSDDSyn.FuncDatabase(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynSDDSyn.FuncDate(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkDatatype\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynSDDSyn.FuncEnd(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynSDDSyn.FuncEndblock(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynSDDSyn.FuncInteger(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkDatatype\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynSDDSyn.FuncKeys(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynSDDSyn.FuncLongint(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkDatatype\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynSDDSyn.FuncMemotext(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkDatatype\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynSDDSyn.FuncObject(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynSDDSyn.FuncObjects(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynSDDSyn.FuncOf(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynSDDSyn.FuncOwner(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynSDDSyn.FuncPartition(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynSDDSyn.FuncPartitions(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynSDDSyn.FuncPrimary(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynSDDSyn.FuncReal(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkDatatype\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynSDDSyn.FuncSecondary(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynSDDSyn.FuncSpec(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynSDDSyn.FuncString(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkDatatype\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynSDDSyn.FuncSuperblock(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynSDDSyn.FuncSuperspec(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynSDDSyn.FuncTime(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkDatatype\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynSDDSyn.FuncVar(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nconstructor TSynSDDSyn.Create(AOwner: TComponent);\r\nbegin\r\n  inherited Create(AOwner);\r\n\r\n  fCaseSensitive := False;\r\n\r\n  fCommentAttri := TSynHighLighterAttributes.Create(SYNS_AttrComment, SYNS_FriendlyAttrComment);\r\n  fCommentAttri.Foreground := clNavy;\r\n  fCommentAttri.Style := [fsItalic];\r\n  AddAttribute(fCommentAttri);\r\n\r\n  fIdentifierAttri := TSynHighLighterAttributes.Create(SYNS_AttrIdentifier, SYNS_FriendlyAttrIdentifier);\r\n  AddAttribute(fIdentifierAttri);\r\n\r\n  fKeyAttri := TSynHighLighterAttributes.Create(SYNS_AttrReservedWord, SYNS_FriendlyAttrReservedWord);\r\n  fKeyAttri.Style := [fsBold];\r\n  fKeyAttri.Foreground := clGreen;\r\n  AddAttribute(fKeyAttri);\r\n\r\n  fDatatypeAttri := TSynHighlighterAttributes.Create(SYNS_AttrDataType, SYNS_FriendlyAttrDataType);\r\n  fDatatypeAttri.Style := [fsBold];\r\n  fDatatypeAttri.Foreground := clTeal;\r\n  AddAttribute(fDatatypeAttri);\r\n\r\n  fSpaceAttri := TSynHighLighterAttributes.Create(SYNS_AttrSpace, SYNS_FriendlyAttrSpace);\r\n  AddAttribute(fSpaceAttri);\r\n\r\n  fNumberAttri := TSynHighLighterAttributes.Create(SYNS_AttrNumber, SYNS_FriendlyAttrNumber);\r\n  fNumberAttri.Foreground := clBlue;\r\n  AddAttribute(fNumberAttri);\r\n\r\n  fSymbolAttri := TSynHighLighterAttributes.Create(SYNS_AttrSymbol, SYNS_FriendlyAttrSymbol);\r\n  AddAttribute(fSymbolAttri);\r\n  \r\n  SetAttributesOnChange(DefHighlightChange);\r\n  InitIdent;\r\n  fDefaultFilter := SYNS_FilterSDD;\r\n  fRange := rsUnknown;\r\nend; { Create }\r\n\r\nprocedure TSynSDDSyn.BraceOpenProc;\r\nbegin\r\n  fRange := rsComment;\r\n  BraceCommentProc;\r\n  fTokenID := tkComment;\r\nend; { BraceOpenProc }\r\n\r\nprocedure TSynSDDSyn.IdentProc;\r\nbegin\r\n  fTokenID := IdentKind((fLine + Run));\r\n  inc(Run, fStringLen);\r\n  while IsIdentChar(fLine[Run]) do\r\n    Inc(Run);\r\nend; { IdentProc }\r\n\r\nprocedure TSynSDDSyn.NullProc;\r\nbegin\r\n  fTokenID := tkNull;\r\n  inc(Run);\r\nend; { NullProc }\r\n\r\nprocedure TSynSDDSyn.SpaceProc;\r\nbegin\r\n  fTokenID := tkSpace;\r\n  repeat\r\n    inc(Run);\r\n  until not CharInSet(fLine[Run], [#1..#32]);\r\nend; { SpaceProc }\r\n\r\nprocedure TSynSDDSyn.BraceCommentProc;\r\nbegin\r\n  case fLine[Run] of\r\n     #0: NullProc;\r\n    #10: LFProc;\r\n    #13: CRProc;\r\n  else\r\n    begin\r\n      fTokenID := tkComment;\r\n      repeat\r\n        if fLine[Run] = '}' then\r\n        begin\r\n          Inc(Run);\r\n          fRange := rsUnKnown;\r\n          Break;\r\n        end;\r\n        Inc(Run);\r\n      until IsLineEnd(Run);\r\n    end;\r\n  end;\r\nend; { BraceCommentProc }\r\n\r\nprocedure TSynSDDSyn.UnknownProc;\r\nbegin\r\n  inc(Run);\r\n  fTokenID := tkUnknown;\r\nend; { UnknownProc }\r\n\r\nprocedure TSynSDDSyn.Next;\r\nbegin\r\n  fTokenPos := Run;\r\n  case fRange of\r\n    rsComment: BraceCommentProc;\r\n  else\r\n    case fLine[Run] of\r\n      '{': BraceOpenProc;\r\n      '}', '!', '%', '&', '('..'/', ':'..'@', '['..'^', '`', '~': SymbolProc;\r\n      'A'..'Z', 'a'..'z', '_': IdentProc;\r\n      '0'..'9' : NumberProc;\r\n      #0: NullProc;\r\n      #1..#32: SpaceProc;\r\n      else UnknownProc;\r\n    end;\r\n  end;\r\n  inherited;\r\nend; { Next }\r\n\r\nprocedure TSynSDDSyn.CRProc;\r\nbegin\r\n  fTokenID := tkSpace;\r\n  Inc(Run);\r\n  if fLine[Run] = #10 then\r\n    inc(Run);\r\nend; { CRProc }\r\n\r\nprocedure TSynSDDSyn.LFProc;\r\nbegin\r\n  fTokenID := tkSpace;\r\n  inc(Run);\r\nend; { LFProc }\r\n\r\nfunction TSynSDDSyn.GetSampleSource: UnicodeString;\r\nbegin\r\n  Result := '{ Semanta data dictionary }'#13#10 +\r\n            'database Sample.001;'#13#10 +\r\n            'owner = COAS;'#13#10 +\r\n            #13#10 +\r\n            'objects'#13#10 +\r\n            '  Test = object'#13#10 +\r\n            '    Code : string[4];'#13#10 +\r\n            '    Name : string[80];'#13#10 +\r\n            '  end;'#13#10 +\r\n            'keys'#13#10 +\r\n            '  primary Test.Index = [Code];'#13#10 +\r\n            'end.';\r\nend; { GetSampleSource }\r\n\r\nfunction TSynSDDSyn.GetDefaultAttribute(Index: Integer): TSynHighLighterAttributes;\r\nbegin\r\n  case Index of\r\n    SYN_ATTR_COMMENT: Result := fCommentAttri;\r\n    SYN_ATTR_IDENTIFIER: Result := fIdentifierAttri;\r\n    SYN_ATTR_KEYWORD: Result := fKeyAttri;\r\n    SYN_ATTR_WHITESPACE: Result := fSpaceAttri;\r\n    SYN_ATTR_SYMBOL: Result := fSymbolAttri;\r\n  else\r\n    Result := nil;\r\n  end;\r\nend; { GetDefaultAttribute }\r\n\r\nfunction TSynSDDSyn.GetEol: Boolean;\r\nbegin\r\n  Result := Run = fLineLen + 1;\r\nend; { GetEol }\r\n\r\nfunction TSynSDDSyn.GetTokenID: TtkTokenKind;\r\nbegin\r\n  Result := fTokenId;\r\nend; { GetTokenId }\r\n\r\nfunction TSynSDDSyn.GetTokenAttribute: TSynHighLighterAttributes;\r\nbegin\r\n  case GetTokenID of\r\n    tkComment: Result := fCommentAttri;\r\n    tkIdentifier: Result := fIdentifierAttri;\r\n    tkKey: Result := fKeyAttri;\r\n    tkDatatype: Result := fDatatypeAttri;\r\n    tkSpace: Result := fSpaceAttri;\r\n    tkNumber: Result := fNumberAttri;\r\n    tkUnknown: Result := fIdentifierAttri;\r\n    tkSymbol: Result := fSymbolAttri;\r\n  else\r\n    Result := nil;\r\n  end;\r\nend; { GetTokenAttribute }\r\n\r\nfunction TSynSDDSyn.GetTokenKind: integer;\r\nbegin\r\n  Result := Ord(fTokenId);\r\nend; { GetTokenKind }\r\n\r\nprocedure TSynSDDSyn.ResetRange;\r\nbegin\r\n  inherited;\r\n  fRange := rsUnknown;\r\nend; { ResetRange }\r\n\r\nprocedure TSynSDDSyn.SetRange(Value: Pointer);\r\nbegin\r\n  inherited;\r\n  fRange := TRangeState(Value);\r\nend; { SetRange }\r\n\r\nfunction TSynSDDSyn.GetRange: Pointer;\r\nbegin\r\n  Result := Pointer(fRange);\r\nend; { GetRange }\r\n\r\nclass function TSynSDDSyn.GetLanguageName: string;\r\nbegin\r\n  Result := SYNS_LangSDD;\r\nend; { GetLanguageName }\r\n\r\nprocedure TSynSDDSyn.NumberProc;\r\n\r\n  function IsNumberChar: Boolean;\r\n  begin\r\n    case fLine[Run] of\r\n      '0'..'9', '.', 'e', 'E':\r\n        Result := True;\r\n      else\r\n        Result := False;\r\n    end;\r\n  end;\r\n\r\nbegin\r\n  inc(Run);\r\n  fTokenID := tkNumber;\r\n  while IsNumberChar do\r\n  begin\r\n    case FLine[Run] of\r\n      '.': if FLine[Run + 1] = '.' then\r\n             Break;\r\n    end;\r\n    inc(Run);\r\n  end;\r\nend; { NumberProc }\r\n\r\nfunction TSynSDDSyn.IsFilterStored: Boolean;\r\nbegin\r\n  Result := fDefaultFilter <> SYNS_FilterSDD;\r\nend; { IsFilterStored }\r\n\r\nprocedure TSynSDDSyn.SymbolProc;\r\nbegin\r\n  inc(Run);\r\n  fTokenID := tkSymbol;\r\nend;\r\n\r\nclass function TSynSDDSyn.GetFriendlyLanguageName: UnicodeString;\r\nbegin\r\n  Result := SYNS_FriendlyLangSDD;\r\nend;\r\n\r\ninitialization\r\n{$IFNDEF SYN_CPPB_1}\r\n  RegisterPlaceableHighlighter(TSynSDDSyn);\r\n{$ENDIF}\r\nend.\r\n"
  },
  {
    "path": "External/SynEdit/Source/SynHighlighterSQL.pas",
    "content": "{-------------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: SynHighlighterSQL.pas, released 2000-04-21.\r\nThe Original Code is based on the wmSQLSyn.pas and wmSybaseSyn.pas files from\r\nthe mwEdit component suite by Martin Waldenburg and other developers, the\r\nInitial Author of these files is Willo van der Merwe. Initial Author of\r\nSynHighlighterSQL.pas is Michael Hieke.\r\nPortions created by Willo van der Merwe are Copyright 1999 Willo van der Merwe.\r\nPortions created by Michael Hieke are Copyright 2000 Michael Hieke.\r\nUnicode translation by Mal Hrz.\r\nAll Rights Reserved.\r\n\r\nContributors to the SynEdit and mwEdit projects are listed in the\r\nContributors.txt file.\r\n\r\nAlternatively, the contents of this file may be used under the terms of the\r\nGNU General Public License Version 2 or later (the \"GPL\"), in which case\r\nthe provisions of the GPL are applicable instead of those above.\r\nIf you wish to allow use of your version of this file only under the terms\r\nof the GPL and not to allow others to use your version of this file\r\nunder the MPL, indicate your decision by deleting the provisions above and\r\nreplace them with the notice and other provisions required by the GPL.\r\nIf you do not delete the provisions above, a recipient may use your version\r\nof this file under either the MPL or the GPL.\r\n\r\n$Id: SynHighlighterSQL.pas,v 1.39.2.14 2008/09/14 16:25:03 maelh Exp $\r\n\r\nYou may retrieve the latest version of this file at the SynEdit home page,\r\nlocated at http://SynEdit.SourceForge.net\r\n\r\nKnown Issues:\r\n-------------------------------------------------------------------------------}\r\n{\r\n@abstract(SQL highlighter for SynEdit with support for different dialects.)\r\n@author(Michael Hieke)\r\n@created(2000-04-21)\r\n@lastmod(2000-11-16)\r\nThe SynHighlighterSQL implements a highlighter for SQL for the SynEdit projects.\r\nDifferent SQL dialects can be selected via the Dialect property.\r\n}\r\n\r\n{$IFNDEF QSYNHIGHLIGHTERSQL}\r\nunit SynHighlighterSQL;\r\n{$ENDIF}\r\n\r\n{$I SynEdit.inc}\r\n\r\ninterface\r\n\r\nuses\r\n{$IFDEF SYN_CLX}\r\n  Types,\r\n  QGraphics,\r\n  QSynEditTypes,\r\n  QSynEditHighlighter,\r\n  QSynHighlighterHashEntries,\r\n  QSynUnicode,\r\n{$ELSE}\r\n  Graphics,\r\n  Registry,\r\n  SynEditTypes,\r\n  SynEditHighlighter,\r\n  SynHighlighterHashEntries,\r\n  SynUnicode,\r\n{$ENDIF}\r\n  SysUtils,\r\n  Classes;\r\n\r\ntype\r\n  TtkTokenKind = (tkComment, tkDatatype, tkDefaultPackage, tkException,\r\n    tkFunction, tkIdentifier, tkKey, tkNull, tkNumber, tkSpace, tkPLSQL,\r\n    tkSQLPlus, tkString, tkSymbol, tkTableName, tkUnknown, tkVariable,\r\n    tkConditionalComment, tkDelimitedIdentifier);\r\n\r\n  TRangeState = (rsUnknown, rsComment, rsString, rsConditionalComment);\r\n\r\n  TSQLDialect = (sqlStandard, sqlInterbase6, sqlMSSQL7, sqlMySQL, sqlOracle,\r\n    sqlSybase, sqlIngres, sqlMSSQL2K, sqlPostgres, sqlNexus);\r\n\r\ntype\r\n  TSynSQLSyn = class(TSynCustomHighlighter)\r\n  private\r\n    fRange: TRangeState;\r\n    fTokenID: TtkTokenKind;\r\n    fKeywords: TSynHashEntryList;\r\n    fTableNames: TUnicodeStrings;\r\n    fFunctionNames: TUniCodeStrings;\r\n    fDialect: TSQLDialect;\r\n    fCommentAttri: TSynHighlighterAttributes;\r\n    fConditionalCommentAttri: TSynHighlighterAttributes;\r\n    fDataTypeAttri: TSynHighlighterAttributes;\r\n    fDefaultPackageAttri: TSynHighlighterAttributes;\r\n    fDelimitedIdentifierAttri: TSynHighlighterAttributes;\r\n    fExceptionAttri: TSynHighlighterAttributes;\r\n    fFunctionAttri: TSynHighlighterAttributes;\r\n    fIdentifierAttri: TSynHighlighterAttributes;\r\n    fKeyAttri: TSynHighlighterAttributes;\r\n    fNumberAttri: TSynHighlighterAttributes;\r\n    fPLSQLAttri: TSynHighlighterAttributes;\r\n    fSpaceAttri: TSynHighlighterAttributes;\r\n    fSQLPlusAttri: TSynHighlighterAttributes;\r\n    fStringAttri: TSynHighlighterAttributes;\r\n    fSymbolAttri: TSynHighlighterAttributes;\r\n    fTableNameAttri: TSynHighlighterAttributes;\r\n    fVariableAttri: TSynHighlighterAttributes;\r\n    function HashKey(Str: PWideChar): Integer;\r\n    function IdentKind(MayBe: PWideChar): TtkTokenKind;\r\n    procedure DoAddKeyword(AKeyword: UnicodeString; AKind: integer);\r\n    procedure SetDialect(Value: TSQLDialect);\r\n    procedure SetTableNames(const Value: TUnicodeStrings);\r\n    procedure SetFunctionNames(const Value: TUnicodeStrings);\r\n    procedure PutFunctionNamesInKeywordList;\r\n    procedure TableNamesChanged(Sender: TObject);\r\n    procedure InitializeKeywordLists;\r\n    procedure PutTableNamesInKeywordList;\r\n    procedure AndSymbolProc;\r\n    procedure AsciiCharProc;\r\n    procedure CRProc;\r\n    procedure EqualProc;\r\n    procedure GreaterProc;\r\n    procedure IdentProc;\r\n    procedure LFProc;\r\n    procedure LowerProc;\r\n    procedure MinusProc;\r\n    procedure HashProc;\r\n    procedure NullProc;\r\n    procedure NumberProc;\r\n    procedure OrSymbolProc;\r\n    procedure PlusProc;\r\n    procedure SlashProc;\r\n    procedure SpaceProc;\r\n    procedure QuoteProc;\r\n    procedure BacktickProc;\r\n    procedure BracketProc;\r\n    procedure SymbolProc;\r\n    procedure SymbolAssignProc;\r\n    procedure VariableProc;\r\n    procedure UnknownProc;\r\n    procedure AnsiCProc;\r\n  protected\r\n    function GetSampleSource: UnicodeString; override;\r\n    function IsFilterStored: Boolean; override;\r\n  public\r\n    class function GetLanguageName: string; override;\r\n    class function GetFriendlyLanguageName: UnicodeString; override;\r\n  public\r\n    constructor Create(AOwner: TComponent); override;\r\n    destructor Destroy; override;\r\n    procedure Assign(Source: TPersistent); override;\r\n    function GetDefaultAttribute(Index: Integer): TSynHighlighterAttributes;\r\n      override;\r\n    function GetEol: Boolean; override;\r\n    function GetKeyWords(TokenKind: Integer): UnicodeString; override;\r\n    function GetRange: Pointer; override;\r\n    function GetTokenAttribute: TSynHighlighterAttributes; override;\r\n    function GetTokenID: TtkTokenKind;\r\n    function GetTokenKind: Integer; override;\r\n    function IsIdentChar(AChar: WideChar): Boolean; override;\r\n    function IsKeyword(const AKeyword: UnicodeString): Boolean; override;\r\n    procedure Next; override;\r\n    procedure ResetRange; override;\r\n    procedure SetRange(Value: Pointer); override;\r\n  published\r\n    property CommentAttri: TSynHighlighterAttributes read fCommentAttri\r\n      write fCommentAttri;\r\n    property ConditionalCommentAttri: TSynHighlighterAttributes\r\n      read fConditionalCommentAttri write fConditionalCommentAttri;\r\n    property DataTypeAttri: TSynHighlighterAttributes read fDataTypeAttri\r\n      write fDataTypeAttri;\r\n    property DefaultPackageAttri: TSynHighlighterAttributes\r\n      read fDefaultPackageAttri write fDefaultPackageAttri;\r\n    property DelimitedIdentifierAttri: TSynHighlighterAttributes\r\n      read fDelimitedIdentifierAttri write fDelimitedIdentifierAttri;\r\n    property ExceptionAttri: TSynHighlighterAttributes read fExceptionAttri\r\n      write fExceptionAttri;\r\n    property FunctionAttri: TSynHighlighterAttributes read fFunctionAttri\r\n      write fFunctionAttri;\r\n    property IdentifierAttri: TSynHighlighterAttributes read fIdentifierAttri\r\n      write fIdentifierAttri;\r\n    property KeyAttri: TSynHighlighterAttributes read fKeyAttri write fKeyAttri;\r\n    property NumberAttri: TSynHighlighterAttributes read fNumberAttri\r\n      write fNumberAttri;\r\n    property PLSQLAttri: TSynHighlighterAttributes read fPLSQLAttri\r\n      write fPLSQLAttri;\r\n    property SpaceAttri: TSynHighlighterAttributes read fSpaceAttri\r\n      write fSpaceAttri;\r\n    property SQLPlusAttri: TSynHighlighterAttributes read fSQLPlusAttri\r\n      write fSQLPlusAttri;\r\n    property StringAttri: TSynHighlighterAttributes read fStringAttri\r\n      write fStringAttri;\r\n    property SymbolAttri: TSynHighlighterAttributes read fSymbolAttri\r\n      write fSymbolAttri;\r\n    property TableNameAttri: TSynHighlighterAttributes read fTableNameAttri\r\n      write fTableNameAttri;\r\n    property TableNames: TUnicodeStrings read fTableNames write SetTableNames;\r\n    property FunctionNames: TUnicodeStrings read fFunctionNames write SetFunctionNames;\r\n    property VariableAttri: TSynHighlighterAttributes read fVariableAttri\r\n      write fVariableAttri;\r\n    property SQLDialect: TSQLDialect read fDialect write SetDialect\r\n      default sqlStandard;\r\n  end;\r\n\r\nimplementation\r\n\r\nuses\r\n{$IFDEF SYN_CLX}\r\n  QSynEditStrConst;\r\n{$ELSE}\r\n  SynEditStrConst;\r\n{$ENDIF}\r\n\r\nconst\r\n//---\"Standard\" (ANSI SQL keywords (Version 1, 2 and 3) (www.sql.org)-----------\r\n  StandardKW: UnicodeString =\r\n    'absolute,action,active,actor,add,after,alias,all,allocate,alter,' +\r\n    'and,any,are,as,asc,ascending,assertion,async,at,attributes,auto,' +\r\n    'base_name,before,begin,between,bit,bit_length,boolean,both,breadth,by,' +\r\n    'cache,call,cascade,cascaded,case,cast,catalog,char_length,' +\r\n    'character_length,check,coalesce,collate,collation,column,commit,' +\r\n    'committed,completion,computed,conditional,connect,connection,constraint,' +\r\n    'constraints,containing,convert,corresponding,count,create,cross,current,' +\r\n    'current_date,current_path,current_time,current_timestamp,current_user,' +\r\n    'cursor,cycle,data,database,date,day,deallocate,debug,declare,default,' +\r\n    'deferrable,deferred,delete,depth,desc,descending,describe,descriptor,' +\r\n    'destroy,diagnostics,dictionary,disconnect,distinct,do,domain,' +\r\n    'drop,each,element,else,elseif,end,end-exec,entry_point,equals,escape,' +\r\n    'except,exception,execute,exists,exit,external,extract,factor,false,' +\r\n    'filter,first,for,foreign,from,full,function,general,generator,get,' +\r\n    'global,grant,group,having,hold,hour,identity,if,ignore,immediate,in,' +\r\n    'inactive,index,initially,inner,input,insensitive,insert,instead,' +\r\n    'intersect,interval,into,is,isolation,join,key,last,leading,leave,left,' +\r\n    'less,level,like,limit,list,local,loop,lower,match,merge,minute,modify,' +\r\n    'month,names,national,natural,nchar,new,new_table,next,no,none,not,null,' +\r\n    'nullif,object,octet_length,of,off,old,old_table,on,only,operation,' +\r\n    'operator,operators,or,order,others,outer,output,overlaps,pad,' +\r\n    'parameter,parameters,partial,password,path,pendant,plan,position,' +\r\n    'postfix,prefix,preorder,prepare,preserve,primary,prior,private,' +\r\n    'privileges,procedure,protected,read,recursive,ref,referencing,relative,' +\r\n    'replace,resignal,restrict,retain,return,returns,revoke,right,role,' +\r\n    'rollback,routine,row,rows,savepoint,schema,scroll,search,second,select,' +\r\n    'sensitive,sequence,session,session_user,set,shadow,shared,signal,' +\r\n    'similar,size,snapshot,some,space,sqlexception,sqlstate,sqlwarning,start,' +\r\n    'state,structure,substring,suspend,symbol,system_user,table,temporary,' +\r\n    'term,test,then,there,time,timestamp,timezone_hour,timezone_minute,to,' +\r\n    'trailing,transaction,translate,translation,trigger,trim,true,tuple,type,' +\r\n    'uncommitted,under,union,unique,unknown,update,upper,usage,user,using,' +\r\n    'value,varchar,variable,varying,view,virtual,visible,wait,when,where,' +\r\n    'while,with,without,work,write,year,zone';\r\n\r\n//---Sybase keywords------------------------------------------------------------\r\n  SybaseKW: UnicodeString =\r\n    'absolute,action,add,after,alias,all,allocate,alter,and,any,are,' +\r\n    'arith_overflow,as,asc,assertion,async,at,authorization,avg,before,begin,' +\r\n    'between,bit,bit_length,boolean,both,breadth,break,browse,bulk,by,call,' +\r\n    'cascade,cascaded,case,cast,catalog,char,char_convert,char_length,' +\r\n    'character,character_length,check,checkpoint,close,clustered,coalesce,' +\r\n    'collate,collation,column,commit,completion,compute,confirm,' +\r\n    'connect,connection,constraint,constraints,continue,controlrow,convert,' +\r\n    'corresponding,count,create,cross,current,current_date,current_time,' +\r\n    'current_timestamp,current_user,cursor,cycle,data,database,date,day,dbcc,' +\r\n    'deallocate,dec,decimal,declare,default,deferrable,deferred,delete,depth,' +\r\n    'desc,describe,descriptor,diagnostics,dictionary,dis,disconnect,distinct,' +\r\n    'domain,double,drop,dummy,dump,each,else,elseif,en,end,endtran,equals,' +\r\n    'errlvl,errordata,errorexit,escape,except,exception,exclusive,exec,' +\r\n    'execute,exists,exit,exp_row_size,external,extract,false,fetch,' +\r\n    'fillfactor,first,float,for,foreign,found,from,full,general,get,global,' +\r\n    'go,goto,grant,group,having,holdlock,hour,identity,identity_gap,' +\r\n    'identity_insert,identity_start,if,ignore,immediate,in,index,indicator,' +\r\n    'initially,inner,input,insensitive,insert,install,int,integer,intersect,' +\r\n    'interval,into,is,isolation,jar,join,key,kill,language,last,leading,' +\r\n    'leave,left,less,level,like,limit,lineno,load,local,lock,loop,lower,' +\r\n    'match,max,max_rows_per_page,min,minute,mirror,mirrorexit,modify,module,' +\r\n    'month,names,national,natural,nchar,new,next,no,noholdlock,nonclustered,' +\r\n    'none,not,null,nullif,numeric,numeric_truncation,object,' +\r\n    'octet_length,of,off,offsets,oid,old,on,once,online,only,open,operation,' +\r\n    'operators,option,or,order,others,outer,output,over,overlaps,pad,' +\r\n    'parameters,partial,partition,pendant,perm,permanent,plan,position,' +\r\n    'precision,preorder,prepare,preserve,primary,print,prior,private,' +\r\n    'privileges,proc,procedure,processexit,protected,proxy_table,public,' +\r\n    'quiesce,raiserror,read,readpast,readtext,real,reconfigure,recursive,' +\r\n    'ref,reference,referencing,relative,remove,reorg,replace,replication,' +\r\n    'reservepagegap,resignal,restrict,return,returns,revoke,right,role,' +\r\n    'rollback,routine,row,rowcount,rows,rule,save,savepoint,schema,scroll,' +\r\n    'search,second,section,select,sensitive,sequence,session_user,set,' +\r\n    'setuser,shared,shutdown,signal,similar,size,smallint,some,space,sql,' +\r\n    'sqlcode,sqlerror,sqlexception,sqlstate,statistics,stripe,structure,' +\r\n    'substring,sum,syb_identity,syb_restree,system_user,table,temp,temporary,' +\r\n    'test,textsize,then,there,time,timestamp,timezone_hour,timezone_minute,' +\r\n    'to,trailing,tran,transaction,translate,translation,trigger,trim,true,' +\r\n    'truncate,tsequal,type,under,union,unique,unknown,unpartition,update,' +\r\n    'upper,usage,use,user,user_option,using,value,values,varchar,variable,' +\r\n    'varying,view,virtual,visible,wait,waitfor,when,whenever,where,while,' +\r\n    'with,without,work,write,writetext,year,zone';\r\n\r\n//---Oracle---------------------------------------------------------------------\r\n  // Oracle SQL keywords\r\n  OracleKW: UnicodeString =\r\n    'ACCESS,ACCESSED,ACCOUNT,ACTIVATE,ACTIVE_INSTANCE_COUNT,ADD,ADMIN,ADVISE,' +\r\n    'AGENT,ALL,ALLOCATE,ALTER,ANALYZE,ANCILLARY,AND,ANY,AQ_TM_PROCESSES,' +\r\n    'ARCHIVE_LAG_TARGET,ARCHIVELOG,AS,ASC,ASSOCIATE,ATTRIBUTES,AUDIT,' +\r\n    'AUDIT_FILE_DEST,AUDIT_SYS_OPERATIONS,AUDIT_TRAIL,AUTHENTICATED,AUTHID,' +\r\n    'AUTOALLOCATE,AUTOEXTEND,AUTOMATIC,BACKGROUND_CORE_DUMP,' +\r\n    'BACKGROUND_DUMP_DEST,BACKUP,BACKUP_TAPE_IO_SLAVES,BECOME,BEFORE,' +\r\n    'BEHALF,BETWEEN,BINDING,BITMAP,BITMAP_MERGE_AREA_SIZE,BLANK_TRIMMING,' +\r\n    'BLOCK,BLOCKSIZE,BUFFER_POOL,BUFFER_POOL_KEEP,BUFFER_POOL_RECYCLE,BY,' +\r\n    'CACHE,CANCEL,CASCADE,CAST,CATEGORY,CHAINED,CHANGE,CHARACTER,CHECK,' +\r\n    'CHECKPOINT,CHILD,CHUNK,CIRCUITS,CLASS,CLONE,CLUSTER,CLUSTER_DATABASE,' +\r\n    'CLUSTER_DATABASE_INSTANCES,CLUSTER_INTERCONNECTS,COALESCE,COBOL,' +\r\n    'COLUMN,COLUMNS,COMMENT,COMMIT_POINT_STRENGTH,COMPATIBLE,COMPILE,' +\r\n    'COMPLETE,COMPOSITE_LIMIT,COMPRESS,COMPUTE,CONNECT,' +\r\n    'CONNECT_TIME,CONSIDER,CONSTRAINT,CONSTRAINTS,CONTENTS,CONTEXT,CONTINUE,' +\r\n    'CONTROL,CONTROL_FILE_RECORD_KEEP_TIME,CONTROL_FILES,CONTROLFILE,' +\r\n    'CORE_DUMP_DEST,COST,CPU_COUNT,CPU_PER_CALL,CPU_PER_SESSION,CREATE,' +\r\n    'CREATE_BITMAP_AREA_SIZE,CREATE_STORED_OUTLINES,CURRENT,CURRENT_USER,' +\r\n    'CURSOR_SHARING,CURSOR_SPACE_FOR_TIME,CYCLE,DANGLING,DATAFILE,' +\r\n    'DB_BLOCK_BUFFERS,DB_BLOCK_CHECKING,DB_BLOCK_CHECKSUM,DB_BLOCK_SIZE,' +\r\n    'DB_CACHE_ADVICE,DB_CACHE_SIZE,DB_CREATE_FILE_DEST,DB_DOMAIN,' +\r\n    'DB_FILE_MULTIBLOCK_READ_COUNT,DB_FILE_NAME_CONVERT,DB_FILES,' +\r\n    'DB_KEEP_CACHE_SIZE,DB_NAME,DB_RECYCLE_CACHE_SIZE,DB_WRITER_PROCESSES,' +\r\n    'DBLINK_ENCRYPT_LOGIN,DBWR_IO_SLAVES,DEALLOCATE,DEBUG,DEFAULT,DEFERRED,' +\r\n    'DEFINER,DELETE,DEMAND,DETERMINES,DG_BROKER_START,DICTIONARY,DIMENSION,' +\r\n    'DIRECTORY,DISABLE,DISASSOCIATE,DISK_ASYNCH_IO,DISMOUNT,DISPATCHERS,' +\r\n    'DISTINCT,DISTRIBUTED,DISTRIBUTED_LOCK_TIMEOUT,DML,DML_LOCKS,DOCUMENT,' +\r\n    'DROP,DRS_START,ELSE,ENABLE,ENQUEUE_RESOURCES,ESCAPE,ESTIMATE,EVENT,' +\r\n    'EVENTS,EXCEPT,EXCEPTIONS,EXCHANGE,EXCLUDING,EXCLUSIVE,EXISTS,EXPIRE,' +\r\n    'EXPLAIN,EXTENT,EXTERNALLY,FAILED_LOGIN_ATTEMPTS,FAL_CLIENT,FAL_SERVER,' +\r\n    'FAST,FAST_START_IO_TARGET,FAST_START_MTTR_TARGET,' +\r\n    'FAST_START_PARALLEL_ROLLBACK,FILE,FILE_MAPPING,FILESYSTEMIO_OPTIONS,' +\r\n    'FIXED_DATE,FLUSH,FOR,FORCE,FOREIGN,FORTRAN,FREELIST,FREELISTS,FRESH,' +\r\n    'FROM,FROM_TZ,FUNCTIONS,GC_FILES_TO_LOCKS,GENERATED,GLOBAL,' +\r\n    'GLOBAL_CONTEXT_POOL_SIZE,GLOBAL_NAME,GLOBAL_NAMES,GLOBALLY,GO,GRANT,' +\r\n    'GROUP,GROUPS,HASH,HASH_AREA_SIZE,HASH_JOIN_ENABLED,HASHKEYS,HAVING,HEAP,' +\r\n    'HI_SHARED_MEMORY_ADDRESS,HIERARCHY,HS_AUTOREGISTER,IDENTIFIED,IDLE_TIME,' +\r\n    'IFILE,IMMEDIATE,IN,INCLUDING,INCREMENT,INDEX,INDEXTYPE,INDEXTYPES,' +\r\n    'INFILE,INITIAL,INITIALIZED,INITIALLY,INITRANS,INSERT,INSTANCE,' +\r\n    'INSTANCE_GROUPS,INSTANCE_NAME,INSTANCE_NUMBER,INT,INTERSECT,INTO,' +\r\n    'INVALIDATE,IS,ISOLATION,JAVA,JAVA_MAX_SESSIONSPACE_SIZE,JAVA_POOL_SIZE,' +\r\n    'JAVA_SOFT_SESSIONSPACE_LIMIT,JOB_QUEUE_PROCESSES,JOIN,KEEP,KEY,KILL,' +\r\n    'LARGE_POOL_SIZE,LAYERLISTS,LEVEL,LIBRARY,LICENSE_MAX_SESSIONS,' +\r\n    'LICENSE_MAX_USERS,LICENSE_SESSIONS_WARNING,LIKE,LIMIT,LINK,LIST,LOB,' +\r\n    'LOCAL,LOCAL_LISTENER,LOCATOR,LOCK,LOCK_NAME_SPACE,LOCK_SGA,' +\r\n    'LOG_ARCHIVE_DEST,LOG_ARCHIVE_DUPLEX_DEST,LOG_ARCHIVE_FORMAT,' +\r\n    'LOG_ARCHIVE_MAX_PROCESSES,LOG_ARCHIVE_MIN_SUCCEED_DEST,' +\r\n    'LOG_ARCHIVE_START,LOG_ARCHIVE_TRACE,LOG_BUFFER,LOG_CHECKPOINT_INTERVAL,' +\r\n    'LOG_CHECKPOINT_TIMEOUT,LOG_CHECKPOINTS_TO_ALERT,LOG_FILE_NAME_CONVERT,' +\r\n    'LOG_PARALLELISM,LOGFILE,LOGGING,LOGICAL_READS_PER_CALL,' +\r\n    'LOGICAL_READS_PER_SESSION,LOGMNR_MAX_PERSISTENT_SESSIONS,MANAGE,MANAGED,' +\r\n    'MANUAL,MAP,MASTER,MATCHED,MATERIALIZED,MAX_COMMIT_PROPAGATION_DELAY,' +\r\n    'MAX_DISPATCHERS,MAX_DUMP_FILE_SIZE,MAX_ENABLED_ROLES,' +\r\n    'MAX_ROLLBACK_SEGMENTS,MAX_SHARED_SERVERS,MAXDATAFILES,MAXEXTENTS,' +\r\n    'MAXINSTANCES,MAXLOGFILES,MAXLOGHISTORY,MAXLOGMEMBERS,MAXSIZE,MAXTRANS,' +\r\n    'MAXVALUE,MEMBER,MERGE,MINEXTENTS,MINIMIZE,MINIMUM,MINUS,MINVALUE,MODE,' +\r\n    'MODIFY,MODULE,MONITORING,MOUNT,MOVE,MOVEMENT,MULTISET,NAMED,NATIONAL,' +\r\n    'NESTED,NEVER,NEXT,NLS_CALENDAR,NLS_COMP,NLS_CURRENCY,NLS_DATE_FORMAT,' +\r\n    'NLS_DATE_LANGUAGE,NLS_DUAL_CURRENCY,NLS_ISO_CURRENCY,NLS_LANGUAGE,' +\r\n    'NLS_LENGTH_SEMANTICS,NLS_NCHAR_CONV_EXCP,NLS_NUMERIC_CHARACTERS,' +\r\n    'NLS_TERRITORY,NLS_TIMESTAMP_FORMAT,NLS_TIMESTAMP_TZ_FORMAT,NO,' +\r\n    'NOARCHIVELOG,NOAUDIT,NOCACHE,NOCOMPRESS,NOCOPY,NOCYCLE,NOFORCE,' +\r\n    'NOLOGGING,NOMAXVALUE,NOMINIMIZE,NOMINVALUE,NOMONITORING,NONE,' +\r\n    'NOORDER,NORELY,NORESETLOGS,NOREVERSE,NORMAL,NOROWDEPENDENCIES,NOSORT,' +\r\n    'NOT,NOTHING,NOVALIDATE,NOWAIT,NULL,O7_DICTIONARY_ACCESSIBILITY,' +\r\n    'OBJECT_CACHE_MAX_SIZE_PERCENT,OBJECT_CACHE_OPTIMAL_SIZE,OF,OFFLINE,OID,' +\r\n    'OLAP_PAGE_POOL_SIZE,ON,ONLINE,ONLY,OPEN_CURSORS,OPEN_LINKS,' +\r\n    'OPEN_LINKS_PER_INSTANCE,OPERATOR,OPTIMAL,OPTIMIZER_DYNAMIC_SAMPLING,' +\r\n    'OPTIMIZER_FEATURES_ENABLE,OPTIMIZER_INDEX_CACHING,' +\r\n    'OPTIMIZER_INDEX_COST_ADJ,OPTIMIZER_MAX_PERMUTATIONS,OPTIMIZER_MODE,' +\r\n    'OPTION,OR,ORACLE_TRACE_COLLECTION_NAME,ORACLE_TRACE_COLLECTION_PATH,' +\r\n    'ORACLE_TRACE_COLLECTION_SIZE,ORACLE_TRACE_ENABLE,' +\r\n    'ORACLE_TRACE_FACILITY_NAME,ORACLE_TRACE_FACILITY_PATH,ORDER,' +\r\n    'OS_AUTHENT_PREFIX,OS_ROLES,OUTLINE,OVERFLOW,OWN,PACKAGES,PARALLEL,' +\r\n    'PARALLEL_ADAPTIVE_MULTI_USER,PARALLEL_AUTOMATIC_TUNING,' +\r\n    'PARALLEL_EXECUTION_MESSAGE_SIZE,PARALLEL_INSTANCE_GROUP,' +\r\n    'PARALLEL_MAX_SERVERS,PARALLEL_MIN_PERCENT,PARALLEL_MIN_SERVERS,' +\r\n    'PARALLEL_THREADS_PER_CPU,PARAMETERS,PARTITION_VIEW_ENABLED,PARTITIONS,' +\r\n    'PASSWORD,PASSWORD_GRACE_TIME,PASSWORD_LIFE_TIME,PASSWORD_LOCK_TIME,' +\r\n    'PASSWORD_REUSE_MAX,PASSWORD_REUSE_TIME,PASSWORD_VERIFY_FUNCTION,' +\r\n    'PCTFREE,PCTINCREASE,PCTTHRESHOLD,PCTUSED,PCTVERSION,PERCENT,PERMANENT,' +\r\n    'PGA_AGGREGATE_TARGET,PIPELINED,PLAN,PLI,PLSQL_COMPILER_FLAGS,' +\r\n    'PLSQL_NATIVE_C_COMPILER,PLSQL_NATIVE_LIBRARY_DIR,' +\r\n    'PLSQL_NATIVE_LIBRARY_SUBDIR_COUNT,PLSQL_NATIVE_LINKER,' +\r\n    'PLSQL_NATIVE_MAKE_FILE_NAME,PLSQL_NATIVE_MAKE_UTILITY,' +\r\n    'PLSQL_V2_COMPATIBILITY,POST_TRANSACTION,PRE_PAGE_SGA,PREBUILD,PRECISION,' +\r\n    'PRIMARY,PRIOR,PRIVATE_SGA,PRIVILEGES,PROCESSES,PROFILE,PUBLIC,QUERY,' +\r\n    'QUERY_REWRITE_ENABLED,QUERY_REWRITE_INTEGRITY,QUIESCE,QUOTA,' +\r\n    'RDBMS_SERVER_DN,READ,READ_ONLY_OPEN_DELAYED,REBUILD,RECORDS_PER_BLOCK,' +\r\n    'RECOVER,RECOVERABLE,RECOVERY,RECOVERY_PARALLELISM,RECYCLE,REDUCED,' +\r\n    'REFERENCES,REFRESH,REGISTER,RELY,REMOTE_ARCHIVE_ENABLE,' +\r\n    'REMOTE_DEPENDENCIES_MODE,REMOTE_LISTENER,REMOTE_LOGIN_PASSWORDFILE,' +\r\n    'REMOTE_OS_AUTHENT,REMOTE_OS_ROLES,RENAME,' +\r\n    'REPLICATION_DEPENDENCY_TRACKING,RESET,RESETLOGS,RESIZE,RESOLVE,RESOLVER,' +\r\n    'RESOURCE,RESOURCE_LIMIT,RESOURCE_MANAGER_PLAN,RESTRICT,RESTRICTED,' +\r\n    'RESUMABLE,RESUME,REUSE,REVOKE,REWRITE,RNDS,RNPS,ROLE,ROLES,' +\r\n    'ROLLBACK_SEGMENTS,ROW,ROW_LOCKING,ROWDEPENDENCIES,ROWLABEL,ROWNUM,' +\r\n    'ROWS,SAMPLE,SCN,SCOPE,SECTION,SEGMENT,SELECT,SELECTIVITY,SEQUENCE,' +\r\n    'SERIAL_REUSE,SERVICE_NAMES,SESSION,SESSION_CACHED_CURSORS,' +\r\n    'SESSION_MAX_OPEN_FILES,SESSIONS,SESSIONS_PER_USER,SGA_MAX_SIZE,' +\r\n    'SHADOW_CORE_DUMP,SHARE,SHARED,SHARED_MEMORY_ADDRESS,SHARED_POOL,' +\r\n    'SHARED_POOL_RESERVED_SIZE,SHARED_POOL_SIZE,SHARED_SERVER_SESSIONS,' +\r\n    'SHARED_SERVERS,SHRINK,SIZE,SNAPSHOT,SOME,SORT,SORT_AREA_RETAINED_SIZE,' +\r\n    'SORT_AREA_SIZE,SOURCE,SPECIFICATION,SPECIFIED,SPFILE,SPLIT,SQL_TRACE,' +\r\n    'SQL92_SECURITY,STANDBY,STANDBY_ARCHIVE_DEST,STANDBY_FILE_MANAGEMENT,' +\r\n    'STAR_TRANSFORMATION_ENABLED,START,START_DATE,STATIC,STATISTICS,' +\r\n    'STATISTICS_LEVEL,STOP,STORAGE,STRUCTURE,SUBPARTITION,SUBPARTITIONS,' +\r\n    'SUCCESSFUL,SUSPEND,SWITCH,SYNONYM,SYSTEM,TABLE,TABLESPACE,' +\r\n    'TAPE_ASYNCH_IO,TEMPFILE,TEMPORARY,THE,THEN,THREAD,THROUGH,TIME,' +\r\n    'TIMED_OS_STATISTICS,TIMED_STATISTICS,TIMEOUT,TO,TRACE_ENABLED,' +\r\n    'TRACEFILE_IDENTIFIER,TRACING,TRANSACTION,TRANSACTION_AUDITING,' +\r\n    'TRANSACTIONS,TRANSACTIONS_PER_ROLLBACK_SEGMENT,TRIGGER,TRUNCATE,TRUST,' +\r\n    'TYPES,UNARCHIVED,UNDER,UNDO,UNDO_MANAGEMENT,UNDO_RETENTION,' +\r\n    'UNDO_SUPPRESS_ERRORS,UNDO_TABLESPACE,UNIFORM,UNION,UNIQUE,UNLIMITED,' +\r\n    'UNLOCK,UNQUIESCE,UNRECOVERABLE,UNTIL,UNUSABLE,UNUSED,UPDATE,USAGE,' +\r\n    'USE_INDIRECT_DATA_BUFFERS,USER_DUMP_DEST,VALIDATE,VALIDATION,VALUES,' +\r\n    'VARGRAPHIC,VARRAY,VIEW,WHERE,WITH,WITHOUT,WNDS,WNPS,' +\r\n    'WORKAREA_SIZE_POLICY';\r\n\r\n//---Postgresql-----------------------------------------------------------------\r\n  //Postgresql Keywords\r\n  PostgresKW: UnicodeString =\r\n    'IF,LOOP,ABORT,ABSOLUTE,ACCESS,ACTION,ADA,ADD,ADMIN,AFTER,AGGREGATE,ALIAS' +\r\n    ',ALLOCATE,ALTER,ANALYSE,ANALYZE,AND,ARE,AS,ASC,ASENSITIVE' +\r\n    ',ASSERTION,ASSIGNMENT,ASYMMETRIC,AT,ATOMIC,AUTHORIZATION,BACKWARD' +\r\n    ',BEFORE,BEGIN,BETWEEN' +\r\n    ',BOTH,BREADTH,BY,C,CACHE,CALL,CALLED,CARDINALITY,CASCADE,CASCADED,CASE' +\r\n    ',CAST,CATALOG,CATALOG_NAME,CHAIN,CHARACTERISTICS' +\r\n    ',CHARACTER_SET_CATALOG,CHARACTER_SET_NAME,CHARACTER_SET_SCHEMA' +\r\n    ',CHECK,CHECKED,CHECKPOINT,CLASS,CLASS_ORIGIN,CLOB,CLOSE,CLUSTER,COBOL,COLLATE' +\r\n    ',COLLATION,COLLATION_CATALOG,COLLATION_NAME,COLLATION_SCHEMA,COLUMN,COLUMN_NAME' +\r\n    ',COMMAND_Function,COMMAND_Function_CODE,COMMENT,COMMIT,COMMITTED,COMPLETION' +\r\n    ',CONDITION_NUMBER,CONNECT,CONNECTION,CONNECTION_NAME,CONSTRAINT,CONSTRAINTS' +\r\n    ',CONSTRAINT_CATALOG,CONSTRAINT_NAME,CONSTRAINT_SCHEMA,CONSTRUCTOR,CONTAINS' +\r\n    ',CONTINUE,CONVERSION,COPY,CORRESPONDING,CREATE,CREATEDB,CREATEUSER' +\r\n    ',CROSS,CUBE,CURRENT,CURRENT_PATH,CURRENT_ROLE' +\r\n    ',CURSOR,CURSOR_NAME,CYCLE,DATA,DATABASE,DATETIME_INTERVAL_CODE' +\r\n    ',DATETIME_INTERVAL_PRECISION,DAY,DEALLOCATE,DEC,DECLARE,DEFAULT,DEFERRABLE' +\r\n    ',DEFERRED,DEFINED,DEFINER,DELETE,DELIMITER,DELIMITERS,DEPTH,DEREF,DESC,DESCRIBE' +\r\n    ',DESCRIPTOR,DESTROY,DESTRUCTOR,DETERMINISTIC,DIAGNOSTICS,DICTIONARY,DISCONNECT' +\r\n    ',DISPATCH,DISTINCT,DO,DOMAIN,DROP,DYNAMIC,DYNAMIC_Function,DYNAMIC_Function_CODE' +\r\n    ',EACH,ELSE,ELSIF,ELSEIF,ENCODING,ENCRYPTED,END,EQUALS,ESCAPE,EXCEPT,EXCEPTION' +\r\n    ',EXCLUSIVE,EXEC,EXECUTE,EXISTING,EXPLAIN,EXTERNAL,FALSE,FETCH' +\r\n    ',FINAL,FIRST,FOR,FORCE,FOREIGN,FORTRAN,FORWARD,FOUND,FREE,FREEZE,FROM' +\r\n    ',FULL,Function,G,GENERAL,GENERATED,GET,GLOBAL,GO,GOTO,GRANT,GRANTED,GROUP' +\r\n    ',GROUPING,HANDLER,HAVING,HIERARCHY,HOLD,HOUR,IDENTITY,IGNORE,ILIKE' +\r\n    ',IMMEDIATE,IMMUTABLE,IMPLEMENTATION,IMPLICIT,INCREMENT,INDEX,INDICATOR' +\r\n    ',INFIX,INHERITS,INITIALIZE,INITIALLY,INNER,INOUT,INPUT,INSENSITIVE,INSERT' +\r\n    ',INSTANCE,INSTANTIABLE,INSTEAD,INT,INTERSECT,INTO,INVOKER' +\r\n    ',IS,ISNULL,ISOLATION,ITERATE,JOIN,K,KEY,KEY_MEMBER,KEY_TYPE,LANCOMPILER,LANGUAGE' +\r\n    ',LARGE,LAST,LATERAL,LEADING,LEFT,LESS,LEVEL,LIKE,LIMIT,LISTEN,LOAD,LOCAL' +\r\n    ' LOCATION,LOCATOR,LOCK,M,MAP,MATCH,MAXVALUE,MESSAGE_LENGTH' +\r\n    ',MESSAGE_OCTET_LENGTH,MESSAGE_TEXT,METHOD,MINUTE,MINVALUE,MODE,MODIFIES' +\r\n    ',MODIFY,MODULE,MONTH,MORE,MOVE,MUMPS,NAME,NAMES,NATIONAL,NATURAL,NCHAR,NCLOB' +\r\n    ',NEW,NEXT,NO,NOCREATEDB,NOCREATEUSER,NONE,NOT,NOTHING,NOTIFY,NOTNULL,NULL,NULLABLE' +\r\n    ',NUMBER,OBJECT,OF,OFF,OFFSET,OIDS,OLD,ON,ONLY,OPEN' +\r\n    ',OPERATION,Operator,OPTION,OPTIONS,OR,ORDER,ORDINALITY,OUT,OUTER,OUTPUT,OVERLAPS' +\r\n    ',OVERRIDING,OWNER,PAD,PARAMETER,PARAMETERS,PARAMETER_MODE,PARAMETER_NAME,PARAMETER_ORDINAL_POSITION' +\r\n    ',PARAMETER_SPECIFIC_CATALOG,PARAMETER_SPECIFIC_NAME,PARAMETER_SPECIFIC_SCHEMA,PARTIAL,PASCAL,PASSWORD' +\r\n    ',PENDANT,PLACING,PLI,POSTFIX,PRECISION,PREFIX,PREORDER,PREPARE,PRESERVE,PRIMARY' +\r\n    ',PRIOR,PRIVILEGES,PROCEDURAL,PROCEDURE,PUBLIC,READ,READS,RECHECK,RECURSIVE,REF,REFERENCES' +\r\n    ',REFERENCING,REINDEX,RELATIVE,RENAME ,REPEATABLE,RESET,RESTRICT,RESULT,RETURN,RETURNED_LENGTH' +\r\n    ',RETURNED_OCTET_LENGTH,RETURNED_SQLSTATE,RETURNS,REVOKE,RIGHT,ROLE,ROLLBACK,ROLLUP,ROUTINE,ROUTINE_CATALOG' +\r\n    ',ROUTINE_NAME,ROUTINE_SCHEMA,ROW,ROWS,ROW_COUNT,RULE,SAVEPOINT,SCALE,SCHEMA,SCHEMA_NAME' +\r\n    ',SCOPE,SCROLL,SEARCH,SECOND,SECTION,SECURITY,SELECT,SELF,SENSITIVE,SEQUENCE,SERIALIZABLE,SERVER_NAME' +\r\n    ',SESSION,SET,SETOF,SETS,SHARE,SHOW,SIMILAR,SIMPLE,SIZE,SOURCE,SPACE' +\r\n    ',SPECIFIC,SPECIFICTYPE,SPECIFIC_NAME,SQLCODE,SQLERROR,SQLEXCEPTION,SQLSTATE,SQLWARNING' +\r\n    ',STABLE,START,STATE,STATEMENT,STATIC,STATISTICS,STDIN,STDOUT,STORAGE,STRICT,STRUCTURE' +\r\n    ',STYLE,SUBCLASS_ORIGIN,SUBLIST,SYMMETRIC,SYSID,SYSTEM,SYSTEM_USER,TABLE' +\r\n    ',TABLE_NAME,TEMP,TEMPLATE,TEMPORARY,TERMINATE,THAN,THEN,TIMEZONE_HOUR' +\r\n    ',TIMEZONE_MINUTE,TO,TOAST,TRAILING,TRANSACTION,TRANSACTIONS_COMMITTED,TRANSACTIONS_ROLLED_BACK' +\r\n    ',TRANSACTION_ACTIVE,TRANSFORM,TRANSFORMS,TRANSLATION,TREAT,TRIGGER_CATALOG' +\r\n    ',TRIGGER_NAME,TRIGGER_SCHEMA,TRUE,TRUNCATE,TRUSTED,TYPE,UNCOMMITTED,UNDER,UNENCRYPTED,UNION'+\r\n    ',UNIQUE,UNKNOWN,UNLISTEN,UNNAMED,UNNEST,UNTIL,UPDATE,USAGE,USER_DEFINED_TYPE_CATALOG' +\r\n    ',USER_DEFINED_TYPE_NAME,USER_DEFINED_TYPE_SCHEMA,USING,VACUUM,VALID,VALIDATOR,VALUE,VALUES' +\r\n    ',VARIABLE,VARYING,VERBOSE,VIEW,VOLATILE,WHEN,WHENEVER,WHERE,WITH,WITHOUT,WORK,WRITE,YEAR,ZONE';\r\n\r\n  //Postgresql Functions\r\n  PostgresFunctions: UnicodeString =\r\n    'abs,cbrt,ceil,ceiling,degrees,exp,floor,ln,log,mod,pi,power,radians,random,'+\r\n    'round,setseed,sign,sqrt,trunc,width_bucket,acos,asin,atan,atan2,cos,cot,'+\r\n    'sin,tan,bit_length,char_length,character_length,convert,lower,octet_length,'+\r\n    'overlay,position,substring,trim,upper,ascii,btrim,chr,decode,'+\r\n    'encode,initcap,length,lpad,ltrim,md5,pg_client_encoding,quote_ident,quote_literal,'+\r\n    'replace,rpad,rtrim,split_part,strpos,substr,to_ascii,to_hex,translate,get_byte,'+\r\n    'set_byte,get_bit,set_bit,to_char,to_date,'+\r\n    'to_timestamp,to_number,age,date_part,date_trunc,extract,now,'+\r\n    'timeofday,isfinite,area,box_intersect,center,diameter,height,isclosed,isopen,'+\r\n    'npoints,pclose,popen,radius,width,'+\r\n    'broadcast,'+\r\n    'host,masklen,set_masklen,netmask,hostmask,network,abbrev,family,nextval,'+\r\n    'currval,setval,coalesce,nullif,array_cat ,array_append ,array_prepend ,array_dims,'+\r\n    'array_lower ,array_upper ,array_to_string ,string_to_array ,avg,bit_and,bit_or,bool_and,'+\r\n    'bool_or,count,every,max,min,stddev,sum,variance,exists ,in ,some,'+\r\n    'all ,generate_series,current_database,current_schema,'+\r\n    'current_schemas,,inet_client_addr,inet_client_port,inet_server_addr,inet_server_port,'+\r\n    'version,has_table_privilege,has_database_privilege,'+\r\n    'has_function_privilege,has_language_privilege,'+\r\n    'has_schema_privilege,has_tablespace_privilege,'+\r\n    'pg_table_is_visible,pg_type_is_visible,pg_function_is_visible,pg_operator_is_visible,'+\r\n    'pg_opclass_is_visible,pg_conversion_is_visible,format_type,pg_get_viewdef,'+\r\n    'pg_get_ruledef,pg_get_indexdef,'+\r\n    'pg_get_triggerdef,pg_get_constraintdef,pg_get_expr,'+\r\n    'pg_get_userbyid,pg_get_serial_sequence,pg_tablespace_databases,obj_description,'+\r\n    'col_description,current_setting,set_config,pg_cancel_backend,pg_start_backup,pg_stop_backup,'+\r\n    'current_user,current_date,current_time,current_timestamp,localtime,localtimestamp,session_user,user';\r\n\r\n  //Postgresql Types\r\n  PostgresTypes: UnicodeString =\r\n    'smallint,integer,bigint,decimal,numeric,real,double,serial,bigserial,'+\r\n    'character,varchar,char,text,bytea,timestamp, interval,date,'+\r\n    'time,boolean,point,line,lseg,box,path,polygon,circle,cidr,inet,'+\r\n    'macaddr,BIT,bitvar,ARRAY,oid,regproc,regprocedure,regoper,regoperator,regclass,'+\r\n    'regtype,any,anyarray,anyelement,cstring,internal,language_handler,record,'+\r\n    'trigger,void,opaque,refcursor,binary,blob,int4,int2,int8,float,float4,float8';\r\n\r\n  //Postgresql Exceptions\r\n  PostgresExceptions: UnicodeString =\r\n    '$BODY$,SUCCESSFUL_COMPLETION,WARNING,DYNAMIC_RESULT_SETS_RETURNED,IMPLICIT_ZERO_BIT_PADDING,NULL_VALUE_ELIMINATED_IN_SET_FUNCTION,'+\r\n    'PRIVILEGE_NOT_GRANTED,PRIVILEGE_NOT_REVOKED,STRING_DATA_RIGHT_TRUNCATION,DEPRECATED_FEATURE,NO_DATA,NO_ADDITIONAL_DYNAMIC_RESULT_SETS_RETURNED,'+\r\n    'SQL_STATEMENT_NOT_YET_COMPLETE,CONNECTION_EXCEPTION,CONNECTION_DOES_NOT_EXIST,CONNECTION_FAILURE,SQLCLIENT_UNABLE_TO_ESTABLISH_SQLCONNECTION,'+\r\n    'SQLSERVER_REJECTED_ESTABLISHMENT_OF_SQLCONNECTION,TRANSACTION_RESOLUTION_UNKNOWN,PROTOCOL_VIOLATION,TRIGGERED_ACTION_EXCEPTION,'+\r\n    'FEATURE_NOT_SUPPORTED,INVALID_TRANSACTION_INITIATION,LOCATOR_EXCEPTION,INVALID_LOCATOR_SPECIFICATION,INVALID_GRANTOR,INVALID_GRANT_OPERATION,'+\r\n    'INVALID_ROLE_SPECIFICATION,CARDINALITY_VIOLATION,DATA_EXCEPTION,ARRAY_SUBSCRIPT_ERROR,CHARACTER_NOT_IN_REPERTOIRE,DATETIME_FIELD_OVERFLOW,'+\r\n    'DIVISION_BY_ZERO,ERROR_IN_ASSIGNMENT,ESCAPE_CHARACTER_CONFLICT,INDICATOR_OVERFLOW,INTERVAL_FIELD_OVERFLOW,INVALID_ARGUMENT_FOR_LOGARITHM,'+\r\n    'INVALID_ARGUMENT_FOR_POWER_FUNCTION,INVALID_ARGUMENT_FOR_WIDTH_BUCKET_FUNCTION,INVALID_CHARACTER_VALUE_FOR_CAST,INVALID_DATETIME_FORMAT,'+\r\n    'INVALID_ESCAPE_CHARACTER,INVALID_ESCAPE_OCTET,INVALID_ESCAPE_SEQUENCE,INVALID_INDICATOR_PARAMETER_VALUE,INVALID_LIMIT_VALUE,'+\r\n    'INVALID_PARAMETER_VALUE,INVALID_REGULAR_EXPRESSION,INVALID_TIME_ZONE_DISPLACEMENT_VALUE,INVALID_USE_OF_ESCAPE_CHARACTER,'+\r\n    'MOST_SPECIFIC_TYPE_MISMATCH,NULL_VALUE_NOT_ALLOWED,NULL_VALUE_NO_INDICATOR_PARAMETER,NUMERIC_VALUE_OUT_OF_RANGE,STRING_DATA_LENGTH_MISMATCH,'+\r\n    'SUBSTRING_ERROR,TRIM_ERROR,UNTERMINATED_C_STRING,ZERO_LENGTH_CHARACTER_STRING,FLOATING_POINT_EXCEPTION,'+\r\n    'INVALID_TEXT_REPRESENTATION,INVALID_BINARY_REPRESENTATION,BAD_COPY_FILE_FORMAT,UNTRANSLATABLE_CHARACTER,INTEGRITY_CONSTRAINT_VIOLATION,'+\r\n    'RESTRICT_VIOLATION,NOT_NULL_VIOLATION,FOREIGN_KEY_VIOLATION,UNIQUE_VIOLATION,CHECK_VIOLATION,INVALID_CURSOR_STATE,INVALID_TRANSACTION_STATE,'+\r\n    'ACTIVE_SQL_TRANSACTION,BRANCH_TRANSACTION_ALREADY_ACTIVE,HELD_CURSOR_REQUIRES_SAME_ISOLATION_LEVEL,INAPPROPRIATE_ACCESS_MODE_FOR_BRANCH_TRANSACTION,'+\r\n    'INAPPROPRIATE_ISOLATION_LEVEL_FOR_BRANCH_TRANSACTION,NO_ACTIVE_SQL_TRANSACTION_FOR_BRANCH_TRANSACTION,READ_ONLY_SQL_TRANSACTION,'+\r\n    'SCHEMA_AND_DATA_STATEMENT_MIXING_NOT_SUPPORTED,NO_ACTIVE_SQL_TRANSACTION,IN_FAILED_SQL_TRANSACTION,INVALID_SQL_STATEMENT_NAME,TRIGGERED_DATA_CHANGE_VIOLATION,'+\r\n    'INVALID_AUTHORIZATION_SPECIFICATION,DEPENDENT_PRIVILEGE_DESCRIPTORS_STILL_EXIST,DEPENDENT_OBJECTS_STILL_EXIST,INVALID_TRANSACTION_TERMINATION,'+\r\n    'SQL_ROUTINE_EXCEPTION,FUNCTION_EXECUTED_NO_RETURN_STATEMENT,MODIFYING_SQL_DATA_NOT_PERMITTED,PROHIBITED_SQL_STATEMENT_ATTEMPTED,READING_SQL_DATA_NOT_PERMITTED,'+\r\n    'INVALID_CURSOR_NAME,EXTERNAL_ROUTINE_EXCEPTION,CONTAINING_SQL_NOT_PERMITTED,'+\r\n    'EXTERNAL_ROUTINE_INVOCATION_EXCEPTION,INVALID_SQLSTATE_RETURNED,TRIGGER_PROTOCOL_VIOLATED,'+\r\n    'SRF_PROTOCOL_VIOLATED,SAVEPOINT_EXCEPTION,INVALID_SAVEPOINT_SPECIFICATION,INVALID_CATALOG_NAME,INVALID_SCHEMA_NAME,TRANSACTION_ROLLBACK,'+\r\n    'TRANSACTION_INTEGRITY_CONSTRAINT_VIOLATION,SERIALIZATION_FAILURE,STATEMENT_COMPLETION_UNKNOWN,DEADLOCK_DETECTED,SYNTAX_ERROR_OR_ACCESS_RULE_VIOLATION,'+\r\n    'SYNTAX_ERROR,INSUFFICIENT_PRIVILEGE,CANNOT_COERCE,GROUPING_ERROR,INVALID_FOREIGN_KEY,INVALID_NAME,NAME_TOO_LONG,RESERVED_NAME,DATATYPE_MISMATCH,'+\r\n    'INDETERMINATE_DATATYPE,WRONG_OBJECT_TYPE,UNDEFINED_COLUMN,UNDEFINED_FUNCTION,UNDEFINED_TABLE,UNDEFINED_PARAMETER,UNDEFINED_OBJECT,'+\r\n    'DUPLICATE_COLUMN,DUPLICATE_CURSOR,DUPLICATE_DATABASE,DUPLICATE_FUNCTION,DUPLICATE_PREPARED_STATEMENT,DUPLICATE_SCHEMA,DUPLICATE_TABLE,'+\r\n    'DUPLICATE_ALIAS,DUPLICATE_OBJECT,AMBIGUOUS_COLUMN,AMBIGUOUS_FUNCTION,AMBIGUOUS_PARAMETER,AMBIGUOUS_ALIAS,INVALID_COLUMN_REFERENCE,'+\r\n    'INVALID_COLUMN_DEFINITION,INVALID_CURSOR_DEFINITION,INVALID_DATABASE_DEFINITION,INVALID_FUNCTION_DEFINITION,INVALID_PREPARED_STATEMENT_DEFINITION,'+\r\n    'INVALID_SCHEMA_DEFINITION,INVALID_TABLE_DEFINITION,INVALID_OBJECT_DEFINITION,WITH_CHECK_OPTION_VIOLATION,INSUFFICIENT_RESOURCES,'+\r\n    'DISK_FULL,OUT_OF_MEMORY,TOO_MANY_CONNECTIONS,PROGRAM_LIMIT_EXCEEDED,STATEMENT_TOO_COMPLEX,TOO_MANY_COLUMNS,TOO_MANY_ARGUMENTS,'+\r\n    'OBJECT_NOT_IN_PREREQUISITE_STATE,OBJECT_IN_USE,CANT_CHANGE_RUNTIME_PARAM,LOCK_NOT_AVAILABLE,OPERATOR_INTERVENTION,QUERY_CANCELED,'+\r\n    'ADMIN_SHUTDOWN,CRASH_SHUTDOWN,CANNOT_CONNECT_NOW,IO_ERROR,UNDEFINED_FILE,DUPLICATE_FILE,CONFIG_FILE_ERROR,LOCK_FILE_EXISTS,'+\r\n    'PLPGSQL_ERROR,RAISE_EXCEPTION,INTERNAL_ERROR,DATA_CORRUPTED,INDEX_CORRUPTED';\r\n\r\n  // PLSQL keywords\r\n  OraclePLSQLKW: UnicodeString =\r\n    'ABORT,ACCEPT,AFTER,ARRAY,ARRAYLEN,ASSERT,ASSIGN,AT,AUTHORIZATION,' +\r\n    'AUTONOMOUS_TRANSACTION,BASE_TABLE,BEGIN,BODY,BULK,BULK_ROWCOUNT,CALL,' +\r\n    'CALLING,CASE,CHAR_BASE,CHARSETFORM,CHARSETID,CLOSE,CLUSTERS,COLAUTH,' +\r\n    'COLLECT,COMMIT,CONNECTION,CONSTANT,COOKIE,COOKIE_TABLE,CRASH,CURRVAL,' +\r\n    'CURSOR,DATA_BASE,DATABASE,DBA,DEBUGOFF,DEBUGON,DECLARE,DEFINITION,' +\r\n    'DELAY,DELTA,DEQUEUE_OPTIONS_T,DETERMINISTIC,DIGITS,DISPOSE,DO,EACH,' +\r\n    'ELSIF,END,ENQUEUE_OPTIONS_T,ENTRY,EXCEPTION,EXCEPTION_INIT,EXIT,' +\r\n    'EXTERNAL,FALSE,FETCH,FIXED,FORALL,FORM,FOUND,FUNCTION,GENERIC,GOTO,IF,' +\r\n    'INDEXES,INDICATOR,INSTEAD,INTERFACE,ISOPEN,LANGUAGE,LCR$_DDL_RECORD,' +\r\n    'LCR$_ROW_LIST,LCR$_ROW_RECORD,LCR$_ROW_UNIT,LIMITED,LOOP,MAXLEN,' +\r\n    'MESSAGE_PROPERTIES_T,MGW_BASIC_MSG_T,MGW_MQSERIES_PROPERTIES,' +\r\n    'MGW_NAME_TYPE_ARRAY_T,MGW_NAME_VALUE_T,MGW_PROPERTIES,MGW_PROPERTY,' +\r\n    'MGW_RAW_VALUE_T,MGW_TEXT_VALUE_T,NAME,NEW,NEXTVAL,NOTFOUND,' +\r\n    'NUMBER_BASE,OLD,OPEN,OUT,PACKAGE,PARALLEL_ENABLE,PARTITION,PASCAL,' +\r\n    'PRAGMA,PRIVATE,PROCEDURE,RAISE,RANGE,RE$ATTRIBUTE_VALUE,' +\r\n    'RE$ATTRIBUTE_VALUE_LIST,RE$COLUMN_VALUE,RE$COLUMN_VALUE_LIST,' +\r\n    'RE$NAME_ARRAY,RE$NV_ARRAY,RE$NV_LIST,RE$NV_NODE,RE$RULE_HIT,' +\r\n    'RE$RULE_HIT_LIST,RE$TABLE_ALIAS,RE$TABLE_ALIAS_LIST,' +\r\n    'RE$TABLE_VALUE,RE$TABLE_VALUE_LIST,RE$VARIABLE_TYPE,' +\r\n    'RE$VARIABLE_TYPE_LIST,RE$VARIABLE_VALUE,RE$VARIABLE_VALUE_LIST,RECORD,' +\r\n    'REF,REFERENCING,RELEASE,REMR,REQ,RESP,RESTRICT_REFERENCES,RETURN,' +\r\n    'REVERSE,ROLLBACK,ROWCOUNT,ROWTYPE,RUNTIME_INFO,SAVEPOINT,SCHEMA,' +\r\n    'SELF,SEPARATE,SERIALLY_REUSABLE,SPACE,SQL,SQLERROR,STATEMENT,STRUCT,' +\r\n    'SUBTYPE,TABAUTH,TABLES,TASK,TDO,TERMINATE,TRUE,TYPE,USE,VARYING,VIEWS,' +\r\n    'WHEN,WHILE,WORK,WRITE,XOR';\r\n\r\n  // Oracle data types\r\n  OracleTypes: UnicodeString =\r\n    'ANYDATA,ANYDATASET,ANYTYPE,BFILE,BINARY_INTEGER,BLOB,BOOLEAN,CHAR,CLOB,' +\r\n    'DATE,DAY,DBURIType,DEC,DECIMAL,DOUBLE,FLOAT,HTTPURIType,INTEGER,LONG,' +\r\n    'MLSLABEL,MONTH,NATURAL,NATURALN,NCHAR,NCLOB,NUMBER,NUMERIC,' +\r\n    'NVARCHAR2,PLS_INTEGER,POSITIVE,POSITIVEN,RAW,REAL,ROWID,SECOND,SMALLINT,' +\r\n    'TIMESTAMP,URIType,UROWID,VARCHAR,VARCHAR2,XDBURIType,XMLDATA,XMLType,' +\r\n    'YEAR,ZONE';\r\n\r\n  // Oracle built in exceptions\r\n  OracleExceptions: UnicodeString =\r\n    'ACCESS_INTO_NULL,COLLECTION_IS_NULL,CURSOR_ALREADY_OPEN,' +\r\n    'DUP_VAL_ON_INDEX,INVALID_CURSOR,INVALID_NUMBER,LOGIN_DENIED,' +\r\n    'NO_DATA_FOUND,NOT_LOGGED_ON,OTHERS,PROGRAM_ERROR,ROWTYPE_MISMATCH,' +\r\n    'STORAGE_ERROR,SUBSCRIPT_BEYOND_COUNT,SUBSCRIPT_OUTSIDE_LIMIT,' +\r\n    'SYS_INVALID_ROWID,TIMEOUT_ON_RESOURCE,TOO_MANY_ROWS,VALUE_ERROR,' +\r\n    'ZERO_DIVIDE';\r\n\r\n  // Oracle built in functions\r\n  OracleFunctions: UnicodeString =\r\n    'ABS,ACOS,ADD_MONTHS,AGGREGATE,ANALYTIC,ASCII,ASCIISTR,ASIN,ATAN,ATAN2,' +\r\n    'AVERAGE,AVG,BASE64_DECODE,BASE64_ENCODE,BEGIN_REQUEST,BFILENAME,' +\r\n    'BIN_TO_NUM,BIT_AND,BIT_COMPLEMENT,BIT_OR,BIT_XOR,BITAND,' +\r\n    'CAST_FROM_BINARY_INTEGER,CAST_FROM_NUMBER,CAST_TO_BINARY_INTEGER,' +\r\n    'CAST_TO_NUMBER,CAST_TO_RAW,CAST_TO_VARCHAR2,CEIL,CHARTOROWID,CHR,' +\r\n    'COLUMN_PRESENT,COMPARE,COMPARE_TEMPLATES,COMPOSE,CONCAT,CONVERSION,' +\r\n    'CONVERT,CONVERT_ANYDATA_TO_LCR_DDL,CONVERT_ANYDATA_TO_LCR_ROW,' +\r\n    'COPIES,COPY_TEMPLATE,CORR,COS,COSH,COUNT,COVAR_POP,COVAR_SAMP,' +\r\n    'CREATE_OBJECT_FROM_EXISTING,CREATE_PIPE,CREATE_REFRESH_TEMPLATE,' +\r\n    'CREATE_TEMPLATE_OBJECT,CREATE_TEMPLATE_PARM,CREATE_USER_AUTHORIZATION,' +\r\n    'CREATE_USER_PARM_VALUE,CRLF,CUBE,CUME_DIST,CURRENT_DATE,' +\r\n    'CURRENT_INSTANCE,CURRENT_TIMESTAMP,DATA_BLOCK_ADDRESS_BLOCK,' +\r\n    'DATA_BLOCK_ADDRESS_FILE,DBTIMEZONE,DECODE,DECOMPOSE,DELETE_BREAKPOINT,' +\r\n    'DELETE_OER_BREAKPOINT,DENSE_RANK,DEPTH,DEREF,DISABLE_BREAKPOINT,' +\r\n    'DISABLED,DISPLAY,DROP_ALL,DROP_ELEMENT,DROP_FILE,DUMP,' +\r\n    'EMPTY_BLOB,EMPTY_CLOB,ENABLE_BREAKPOINT,EQUALS_PATH,ESTIMATE_CPU_UNITS,' +\r\n    'EXCLUDE_PUSH,EXECUTE_AND_FETCH,EXECUTE_NON_QUERY,EXISTSNODE,EXP,EXTEND,' +\r\n    'EXTRACT,EXTRACTVALUE,FCOPY,FETCH_ROW,FETCH_ROWS,FGETPOS,FILEEXISTS,' +\r\n    'FILEISOPEN,FIRST,FIRST_VALUE,FLOOR,FLUSH_DATA,FOPEN,FOPEN_NCHAR,' +\r\n    'FORMAT_CALL_STACK,FORMAT_ERROR_STACK,FREMOVE,FRENAME,FROM_REMOTE,FSEEK,' +\r\n    'GET_ARG_FORM,GET_ARG_TYPE,GET_COOKIE_COUNT,GET_COOKIES,' +\r\n    'GET_DETAILED_SQLCODE,GET_DETAILED_SQLERRM,GET_ERROR_MESSAGE,' +\r\n    'GET_HASH_VALUE,GET_HEADER_COUNT,GET_INDEXES,GET_INFORMATION,' +\r\n    'GET_OBJECT_NULL_VECTOR_ARG,GET_PARAMETER_VALUE,' +\r\n    'GET_PERSISTENT_CONN_COUNT,GET_RAW,GET_RESPONSE,GET_RUNTIME_INFO,' +\r\n    'GET_RUNTIME_PARM_ID,GET_SESSION_TIMEOUT,GET_SYSTEM_CHANGE_NUMBER,' +\r\n    'GET_TAG,GET_TIME,GET_TIMEOUT,GET_TIMEOUT_BEHAVIOR,GET_VALUE,' +\r\n    'GETCHUNKSIZE,GETLENGTH,GLB,GREATEST,GREATEST_LB,GROUP_ID,GROUPING,' +\r\n    'GROUPING_ID,HEXTORAW,I_AM_A_REFRESH,INITCAP,INITIALIZE,' +\r\n    'INSTANTIATE_OFFLINE,INSTANTIATE_ONLINE,INSTR,INSTRB,' +\r\n    'INTERNAL_VERSION_CHECK,IS_CLUSTER_DATABASE,IS_LOCATOR,IS_OPEN,' +\r\n    'IS_ROLE_ENABLED,IS_SESSION_ALIVE,IS_TRIGGER_FIRE_ONCE,ISTEMPORARY,LAG,' +\r\n    'LAST,LAST_DAY,LAST_ERROR_POSITION,LAST_ROW_COUNT,LAST_ROW_ID,' +\r\n    'LAST_SQL__CODE,LAST_VALUE,LEAD,LEAST,LEAST_LB,LENGTH,LENGTHB,LINEAR,LN,' +\r\n    'LOCAL_TRANSACTION_ID,LOCALTIMESTAMP,LOG,LOWER,LPAD,LTRIM,LUB,' +\r\n    'MAKE_DATA_BLOCK_ADDRESS,MAKE_REF,MAP_ALL,MAP_ELEMENT,MAP_FILE,' +\r\n    'MAP_OBJECT,MAX,MIN,MINE_VALUE,MISCELLANEOUS,MOD,MONTHS_BETWEEN,NCHR,' +\r\n    'NEW_TIME,NEXT_DAY,NEXT_ITEM_TYPE,NLS_CHARSET_DECL_LEN,NLS_CHARSET_ID,' +\r\n    'NLS_CHARSET_NAME,NLS_INITCAP,NLS_LOWER,NLS_SORT,NLS_UPPER,NLSSORT,NTILE,' +\r\n    'NULLIF,NUMTODSINTERVAL,NUMTOYMINTERVAL,NVARRAY_FIND_NAME,' +\r\n    'NVARRAY_FIND_NAME_TYPE,NVARRAY_GET,NVARRAY_GET_BOOLEAN,NVARRAY_GET_BYTE,' +\r\n    'NVARRAY_GET_DATE,NVARRAY_GET_DOUBLE,NVARRAY_GET_FLOAT,' +\r\n    'NVARRAY_GET_INTEGER,NVARRAY_GET_LONG,NVARRAY_GET_RAW,NVARRAY_GET_SHORT,' +\r\n    'NVARRAY_GET_TEXT,NVL,NVL2,OBJECT,OPEN_CURSOR,OVER,OVERLAY,PATH,' +\r\n    'PAUSE_PROFILER,PERCENT_RANK,PERCENTILE_CONT,PERCENTILE_DISC,PMARKER,' +\r\n    'PORT_STRING,POWER,PURGE,PUSH,PUT_RAW,QUOTED_PRINTABLE_DECODE,' +\r\n    'QUOTED_PRINTABLE_ENCODE,RANDOM,RANK,RATIO_TO_REPORT,RATION_TO_REPORT,' +\r\n    'RAWTOHEX,RAWTONHEX,RECEIVE_MESSAGE,REFERENCE,REFTOHEX,REGR_AVGX,' +\r\n    'REGR_AVGY,REGR_COUNT,REGR_INTERCEPT,REGR_R2,REGR_SLOPE,REGR_SXX,' +\r\n    'REGR_SXY,REGR_SYY,REGRESSION,REMOVE_PIPE,REPLACE,REPLICATION_IS_ON,' +\r\n    'REQUEST,REQUEST_PIECES,RESTORE,RESUME_PROFILER,RETURNING,ROLLUP,ROUND,' +\r\n    'ROW_NUMBER,ROWID_BLOCK_NUMBER,ROWID_CREATE,ROWID_OBJECT,' +\r\n    'ROWID_RELATIVE_FNO,ROWID_ROW_NUMBER,ROWID_TO_ABSOLUTE_FNO,' +\r\n    'ROWID_TO_EXTENDED,ROWID_TO_RESTRICTED,ROWID_TYPE,ROWID_VERIFY,' +\r\n    'ROWIDTOCHAR,ROWIDTONCHAR,RPAD,RTRIM,SEND_MESSAGE,SESSIONTIMEZONE,' +\r\n    'SET_BREAKPOINT,SET_OER_BREAKPOINT,SET_TIMEOUT,SET_VALUE,SIGN,SIN,SINH,' +\r\n    'SOUNDEX,SPACE_ERROR_INFO,SQLCODE,SQLERRM,SQRT,START_PROFILER,STDDEV,' +\r\n    'STDDEV_POP,STDDEV_SAMP,STDDEVP,STDDEVS,STEP_ID,STOP_PROFILER,SUBSTR,' +\r\n    'SUBSTRB,SUM,SYNCHRONIZE,SYS_CONNECT_BY_PATH,SYS_CONTEXT,SYS_DBURIGEN,' +\r\n    'SYS_EXTRACT_UTC,SYS_GUID,SYS_TYPEID,SYS_XMLAGG,SYS_XMLGEN,SYSDATE,' +\r\n    'SYSTIMESTAMP,TAN,TANH,TO_CHAR,TO_CLOB,TO_DATE,TO_DSINTERVAL,TO_LABEL,' +\r\n    'TO_LOB,TO_MULTI_BYTE,TO_NCHAR,TO_NCLOB,TO_NUMBER,TO_SINGLE_BYTE,' +\r\n    'TO_TIMESTAMP,TO_TIMESTAMP_TZ,TO_YMINTERVAL,TRANSLATE,TRANSLITERATE,' +\r\n    'TREAT,TRIM,TRUNC,TZ_OFFSET,UID,UNDER_PATH,UNESCAPE,UNIQUE_SESSION_ID,' +\r\n    'UNIQUE_SESSION_NAME,UNISTR,UPDATEXML,UPPER,USER,USERENV,USING,UUDECODE,' +\r\n    'UUENCODE,VALUE,VAR_POP,VAR_SAMP,VARIANCE,VARP,VARS,VSIZE,WIDTH_BUCKET,' +\r\n    'XMLAGG,XMLCOLATTVAL,XMLCONCAT,XMLELEMENT,XMLFOREST,XMLSEQUENCE,' +\r\n    'XMLTRANSFORM,XRANGE';\r\n\r\n  OracleDefaultPackages: UnicodeString =\r\n    'DBMS_ALERT,DBMS_APPLICATION_INFO,DBMS_APPLY_ADM,DBMS_AQ,' +\r\n    'DBMS_AQ_EXP_HISTORY_TABLES,DBMS_AQ_EXP_INDEX_TABLES,' +\r\n    'DBMS_AQ_EXP_QUEUE_TABLES,DBMS_AQ_EXP_QUEUES,' +\r\n    'DBMS_AQ_EXP_SUBSCRIBER_TABLES,DBMS_AQ_EXP_TIMEMGR_TABLES,' +\r\n    'DBMS_AQ_EXP_ZECURITY,DBMS_AQ_IMP_INTERNAL,DBMS_AQ_IMP_ZECURITY,' +\r\n    'DBMS_AQ_IMPORT_INTERNAL,DBMS_AQ_SYS_EXP_ACTIONS,' +\r\n    'DBMS_AQ_SYS_EXP_INTERNAL,DBMS_AQ_SYS_IMP_INTERNAL,DBMS_AQADM,' +\r\n    'DBMS_AQADM_SYS,DBMS_AQADM_SYSCALLS,DBMS_AQELM,DBMS_AQIN,' +\r\n    'DBMS_AQJMS,DBMS_BACKUP_RESTORE,DBMS_CAPTURE_ADM,DBMS_DDL,' +\r\n    'DBMS_DEBUG,DBMS_DEFER,DBMS_DEFER_IMPORT_INTERNAL,DBMS_DEFER_QUERY,' +\r\n    'DBMS_DEFER_SYS,DBMS_DESCRIBE,DBMS_DISTRIBUTED_TRUST_ADMIN,' +\r\n    'DBMS_EXPORT_EXTENSION,DBMS_FGA,DBMS_FLASHBACK,DBMS_HS_PASSTHROUGH,' +\r\n    'DBMS_IJOB,DBMS_INTERNAL_TRIGGER,DBMS_IOT,DBMS_IREFRESH,DBMS_ISNAPSHOT,' +\r\n    'DBMS_JAVA_TEST,DBMS_JOB,DBMS_LDAP,DBMS_LIBCACHE,DBMS_LOB,DBMS_LOCK,' +\r\n    'DBMS_LOGMNR,DBMS_LOGMNR_CDC_PUBLISH,DBMS_LOGMNR_CDC_SUBSCRIBE,' +\r\n    'DBMS_LOGMNR_D,DBMS_LOGSTDBY,DBMS_METADATA,DBMS_MGWADM,' +\r\n    'DBMS_MGWMSG,DBMS_MVIEW,DBMS_OBFUSCATION_TOOLKIT,DBMS_ODCI,' +\r\n    'DBMS_OFFLINE_OG,DBMS_OFFLINE_SNAPSHOT,DBMS_OLAP,' +\r\n    'DBMS_ORACLE_TRACE_AGENT,DBMS_ORACLE_TRACE_USER,DBMS_OUTLN,' +\r\n    'DBMS_OUTLN_EDIT,DBMS_OUTPUT,DBMS_PCLXUTIL,DBMS_PICKLER,DBMS_PIPE,' +\r\n    'DBMS_PITR,DBMS_PLUGTS,DBMS_PROFILER,DBMS_PROPAGATION_ADM,' +\r\n    'DBMS_PRVTAQIM,DBMS_PRVTAQIP,DBMS_PRVTAQIS,DBMS_PRVTRMIE,DBMS_PSP,' +\r\n    'DBMS_PSWMG_IMPORT,DBMS_RANDOM,DBMS_RCVMAN,DBMS_RECTIFIER_DIFF,' +\r\n    'DBMS_REDEFINITION,DBMS_REFRESH,DBMS_REFRESH_EXP_LWM,' +\r\n    'DBMS_REFRESH_EXP_SITES,DBMS_REPAIR,DBMS_REPCAT,DBMS_REPCAT_ADMIN,' +\r\n    'DBMS_REPCAT_AUTH,DBMS_REPCAT_INSTANTIATE,DBMS_REPCAT_RGT,DBMS_REPUTIL,' +\r\n    'DBMS_RESOURCE_MANAGER,DBMS_RESOURCE_MANAGER_PRIVS,DBMS_RESUMABLE,' +\r\n    'DBMS_RLS,DBMS_RMGR_GROUP_EXPORT,DBMS_RMGR_PACT_EXPORT,' +\r\n    'DBMS_RMGR_PLAN_EXPORT,DBMS_RMIN,DBMS_ROWID,DBMS_RULE,DBMS_RULE_ADM,' +\r\n    'DBMS_RULE_EXIMP,DBMS_SESSION,DBMS_SHARED_POOL,DBMS_SNAP_INTERNAL,' +\r\n    'DBMS_SNAP_REPAPI,DBMS_SNAPSHOT,DBMS_SNAPSHOT_UTL,DBMS_SPACE,' +\r\n    'DBMS_SPACE_ADMIN,DBMS_SQL,DBMS_STANDARD,DBMS_STATS,DBMS_STORAGE_MAP,' +\r\n    'DBMS_STREAMS,DBMS_STREAMS_ADM,DBMS_SUMADV,DBMS_SUMMARY,' +\r\n    'DBMS_SUMREF_CHILD,DBMS_SUMREF_PARENT,DBMS_SUMREF_UTIL,' +\r\n    'DBMS_SUMREF_UTIL2,DBMS_SUMVDM,DBMS_SYS_ERROR,DBMS_SYS_SQL,' +\r\n    'DBMS_SYSTEM,DBMS_TRACE,DBMS_TRANSACTION,DBMS_TRANSFORM,DBMS_TTS,' +\r\n    'DBMS_TYPES,DBMS_UTILITY,DBMS_WM,DBMS_XDB,DBMS_XDB_VERSION,DBMS_XDBT,' +\r\n    'DBMS_XMLDOM,DBMS_XMLGEN,DBMS_XMLPARSER,DBMS_XMLQUERY,' +\r\n    'DBMS_XMLSAVE,DBMS_XPLAN,DBMS_XSLPROCESSOR,DBMS_ZHELP,DBMS_ZHELP_IR,' +\r\n    'DBMSZEXP_SYSPKGGRNT,DEBUG_EXTPROC,DIANA,DIUTIL,ODCICONST,OUTLN_PKG,' +\r\n    'PBREAK,PBRPH,PBSDE,PBUTL,PIDL,PLITBLM,SDO_CS,SDO_GEOM,SDO_LRS,' +\r\n    'SDO_MIGRATE,SDO_TUNE,SDO_UTIL,STANDARD,SYS_STUB_FOR_PURITY_ANALYSIS,' +\r\n    'UTL_COLL,UTL_ENCODE,UTL_FILE,UTL_FILE_DIR,UTL_HTTP,UTL_INADDR,UTL_PG,' +\r\n    'UTL_RAW,UTL_REF,UTL_SMTP,UTL_TCP,UTL_URL';\r\n\r\n  OracleSQLPlusCommands: UnicodeString =\r\n    'APP,APPINFO,AQ$_AGENT,AQ$_AGENT_LIST_T,AQ$_DESCRIPTOR,AQ$_POST_INFO,' +\r\n    'AQ$_POST_INFO_LIST,AQ$_RECIPIENT_LIST_T,AQ$_REG_INFO,AQ$_REG_INFO_LIST,' +\r\n    'AQ$_SUBSCRIBER_LIST_T,ARCHIVE,ARRAYSIZE,ATTRIBUTE,AUTOCOMMIT,AUTOP,' +\r\n    'AUTOPRINT,AUTORECOVERY,AUTOT,AUTOTRACE,BLO,BLOCKTERMINATOR,BRE,BREAK,' +\r\n    'BTI,BTITLE,BUFFER,CL,CLEAR,CLOSECURSOR,CMDS,CMDSEP,COL,COLSEP,COM,COMP,' +\r\n    'COMPAT,COMPATIBILITY,CON,CONN,COPY,COPYC,COPYCOMMIT,COPYTYPECHECK,DEF,' +\r\n    'DEFINE,DESC,DESCR,DESCRI,DESCRIB,DESCRIBE,DISC,DISCO,DISCON,DISCONN,' +\r\n    'DISCONNE,DISCONNEC,DISCONNECT,EA,ECHO,EDITF,EDITFILE,EMB,' +\r\n    'EMBEDDED,ESC,EXEC,EXECUTE,FAILURE,FEED,FEEDBACK,FLAGGER,FLU,FULL,GET,' +\r\n    'HEA,HEADING,HEADS,HEADSEP,HELP,HO,HOST,INPUT,INTERMED,INTERMEDIATE,INV,' +\r\n    'INVISIBLE,LIN,LINESIZE,LO,LOBOF,LOBOFFSET,LOGON,LOGSOURCE,LONGC,' +\r\n    'LONGCHUNKSIZE,MARKUP,MAXDATA,MIX,MIXED,NATIVE,NEWP,NEWPAGE,NUM,' +\r\n    'NUMF,NUMFORMAT,NUMWIDTH,OFF,OSERROR,PAGES,PAGESIZE,PASSW,PAU,PAUSE,' +\r\n    'PPRINT,PRI,PRINT,PROMPT,RECSEP,RECSEPCHAR,REPF,REPFOOTER,REPH,REPHEADER,' +\r\n    'RUN,SAVE,SCAN,SERVEROUTPUT,SET,SHIFT,SHIFTINOUT,SHO,SHOW,SHUTDOWN,' +\r\n    'SILENT,SPOOL,SQLBL,SQLBLANKLINES,SQLC,SQLCASE,SQLCO,SQLCONTINUE,SQLN,' +\r\n    'SQLNUMBER,SQLP,SQLPRE,SQLPREFIX,SQLPROMPT,SQLT,SQLTERMINATOR,STA,' +\r\n    'STARTUP,STATEMENT_ID,STORE,SUCCESS,SUF,SUFFIX,TAB,TERM,TERMOUT,TI,TIMI,' +\r\n    'TIMING,TRIMOUT,TRIMS,TRIMSPOOL,TTI,TTITLE,UND,UNDEF,UNDEFINE,' +\r\n    'UNDERLINE,UP,VAR,VARIABLE,VER,VERIFY,VERSION,VIS,VISIBLE,WHENEVER,WR,' +\r\n    'WRA,WRAP,WRAPPED';\r\n\r\n  OracleCommentKW: UnicodeString =\r\n    'REM,REMA,REMAR,REMARK';\r\n\r\n//---MS-SQL 7-------------------------------------------------------------------\r\n  // keywords\r\n  MSSQL7KW: UnicodeString =\r\n    'ABSOLUTE,ADD,ALL,ALTER,ANY,AS,ASC,AUTHORIZATION,AVG,BACKUP,BEGIN,' +\r\n    'BETWEEN,BREAK,BROWSE,BULK,BY,CASCADE,CHECK,CHECKPOINT,CLOSE,CLUSTERED,' +\r\n    'COLUMN,COMMIT,COMMITTED,COMPUTE,CONFIRM,CONSTRAINT,CONTAINS,' +\r\n    'CONTAINSTABLE,CONTINUE,CONTROLROW,COUNT,CREATE,CROSS,CURRENT,' +\r\n    'CURRENT_DATE,CURRENT_TIME,CURSOR,DATABASE,DBCC,DEALLOCATE,DECLARE,' +\r\n    'DEFAULT,DELETE,DENY,DESC,DISK,DISTINCT,DISTRIBUTED,DOUBLE,DROP,DUMMY,' +\r\n    'DUMP,ELSE,END,ERRLVL,ERROREXIT,ESCAPE,EXCEPT,EXEC,EXECUTE,EXISTS,EXIT,' +\r\n    'FETCH,FILE,FILLFACTOR,FIRST,FLOPPY,FOR,FOREIGN,FREETEXT,FREETEXTTABLE,' +\r\n    'FROM,FULL,GLOBAL,GOTO,GRANT,GROUP,HAVING,HOLDLOCK,IDENTITY,IDENTITYCOL,' +\r\n    'IDENTITY_INSERT,IF,IN,INDEX,INNER,INSERT,INTERSECT,INTO,IS,ISOLATION,' +\r\n    'JOIN,KEY,KILL,LAST,LEFT,LEVEL,LIKE,LINENO,LOAD,MAX,MIN,MIRROREXIT,' +\r\n    'NATIONAL,NEXT,NOCHECK,NONCLUSTERED,NOT,NULL,OF,OFF,OFFSETS,ON,ONCE,' +\r\n    'ONLY,OPEN,OPENDATASOURCE,OPENQUERY,OPENROWSET,OPTION,OR,ORDER,OUTER,' +\r\n    'OVER,PERCENT,PERM,PERMANENT,PIPE,PLAN,PRECISION,PREPARE,PRIMARY,PRINT,' +\r\n    'PRIOR,PRIVILEGES,PROC,PROCEDURE,PROCESSEXIT,PUBLIC,RAISERROR,READ,' +\r\n    'READTEXT,RECONFIGURE,REFERENCES,RELATIVE,REPEATABLE,REPLICATION,RESTORE,' +\r\n    'RESTRICT,RETURN,REVOKE,RIGHT,ROLLBACK,ROWCOUNT,ROWGUIDCOL,RULE,SAVE,' +\r\n    'SCHEMA,SELECT,SERIALIZABLE,SET,SETUSER,SHUTDOWN,SOME,STATISTICS,SUM,' +\r\n    'TABLE,TAPE,TEMP,TEMPORARY,TEXTSIZE,THEN,TO,TOP,TRAN,TRANSACTION,TRIGGER,' +\r\n    'TRUNCATE,TSEQUAL,UNCOMMITTED,UNION,UNIQUE,UPDATE,UPDATETEXT,USE,USER,' +\r\n    'VALUES,VARYING,VIEW,WAITFOR,WHEN,WHERE,WHILE,WITH,WORK,WRITETEXT';\r\n\r\n  // functions\r\n  MSSQL7Functions: UnicodeString =\r\n    '@@CONNECTIONS,@@CPU_BUSY,@@CURSOR_ROWS,@@DATEFIRST,@@DBTS,@@ERROR,' +\r\n    '@@FETCH_STATUS,@@IDENTITY,@@IDLE,@@IO_BUSY,@@LANGID,@@LANGUAGE,' +\r\n    '@@LOCK_TIMEOUT,@@MAX_CONNECTIONS,@@MAX_PRECISION,@@NESTLEVEL,@@OPTIONS,' +\r\n    '@@PACKET_ERRORS,@@PACK_RECEIVED,@@PACK_SENT,@@PROCID,@@REMSERVER,' +\r\n    '@@ROWCOUNT,@@SERVERNAME,@@SERVICENAME,@@SPID,@@TEXTSIZE,@@TIMETICKS,' +\r\n    '@@TOTAL_ERRORS,@@TOTAL_READ,@@TOTAL_WRITE,@@TRANCOUNT,@@VERSION,ABS,' +\r\n    'ACOS,AND,APP_NAME,ASCII,ASIN,ATAN,ATN2,CASE,CAST,CEILING,CHARINDEX,' +\r\n    'COALESCE,COLUMNPROPERTY,COL_LENGTH,COL_NAME,CONVERT,COS,COT,' +\r\n    'CURRENT_TIMESTAMP,CURRENT_USER,CURSOR_STATUS,DATABASEPROPERTY,' +\r\n    'DATALENGTH,DATEADD,DATEDIFF,DATENAME,DATEPART,DAY,DB_ID,DB_NAME,' +\r\n    'DEGREES,DIFFERENCE,EXP,FILEGROUPPROPERTY,FILEGROUP_ID,FILEGROUP_NAME,' +\r\n    'FILEPROPERTY,FILE_ID,FILE_NAME,FLOOR,FORMATMESSAGE,' +\r\n    'FULLTEXTCATALOGPROPERTY,FULLTEXTSERVICEPROPERTY,GETANSINULL,GETDATE,' +\r\n    'HOST_ID,HOST_NAME,IDENT_INCR,IDENT_SEED,INDEXPROPERTY,INDEX_COL,' +\r\n    'ISDATE,ISNULL,ISNUMERIC,IS_MEMBER,IS_SRVROLEMEMBER,LEN,LOG,LOG10,LOWER,' +\r\n    'LTRIM,MONTH,NEWID,NULLIF,OBJECTPROPERTY,OBJECT_ID,OBJECT_NAME,PARSENAME,' +\r\n    'PATINDEX,PERMISSIONS,PI,POWER,QUOTENAME,RADIANS,RAND,REPLACE,REPLICATE,' +\r\n    'REVERSE,ROUND,RTRIM,SESSION_USER,SIGN,SIN,SOUNDEX,SPACE,SQRT,SQUARE,' +\r\n    'STATS_DATE,STR,STUFF,SUBSTRING,SUSER_ID,SUSER_NAME,SUSER_SID,' +\r\n    'SUSER_SNAME,SYSTEM_USER,TAN,TEXTPTR,TEXTVALID,TYPEPROPERTY,UNICODE,' +\r\n    'UPPER,USER_ID,USER_NAME,YEAR';\r\n\r\n  // types\r\n  MSSQL7Types: UnicodeString =\r\n    'BINARY,BIT,CHAR,DATETIME,DECIMAL,FLOAT,IMAGE,INT,MONEY,NCHAR,NTEXT,' +\r\n    'NUMERIC,NVARCHAR,REAL,SMALLDATETIME,SMALLINT,SMALLMONEY,SYSNAME,TEXT,' +\r\n    'TIMESTAMP,TINYINT,UNIQUEIDENTIFIER,VARBINARY,VARCHAR';\r\n\r\n//---MS-SQL2K-------------------------------------------------------------------\r\n  // keywords\r\n  MSSQL2000KW: UnicodeString =\r\n    'ADD,ALL,ALTER,AND,ANY,AS,ASC,AUTHORIZATION,BACKUP,' +\r\n    'BEGIN,BETWEEN,BREAK,BROWSE,BULK,BY,CASCADE,CASE,' +\r\n    'CHECK,CHECKPOINT,CLOSE,CLUSTERED,COLLATE,' +\r\n    'COLUMN,COMMIT,COMPUTE,CONSTRAINT,CONTAINS,CONTAINSTABLE,' +\r\n    'CONTINUE,CREATE,CROSS,CURRENT,CURSOR,DATABASE,' +\r\n    'DBCC,DEALLOCATE,DECLARE,DEFAULT,DELETE,DENY,DESC,DISK,' +\r\n    'DISTINCT,DISTRIBUTED,DOUBLE,DROP,DUMMY,DUMP,ELSE,END,' +\r\n    'ERRLVL,ESCAPE,EXCEPT,EXEC,EXECUTE,EXISTS,EXIT,FETCH,FILE,' +\r\n    'FILLFACTOR,FOR,FOREIGN,FORMSOF,FREETEXT,FREETEXTTABLE,FROM,FULL,' +\r\n    'FUNCTION,GOTO,GRANT,GROUP,HAVING,HOLDLOCK,IDENTITY,' +\r\n    'IDENTITYCOL,IDENTITY_INSERT,IF,IN,INFLECTIONAL,INDEX,INNER,INSERT,' +\r\n    'INTERSECT,INTO,IS,ISABOUT,JOIN,KEY,KILL,LEFT,LIKE,LINENO,LOAD,' +\r\n    'NATIONAL,NOCHECK,NONCLUSTERED,NOT,NULL,NULLIF,OF,OFF,' +\r\n    'OFFSETS,ON,OPEN,OPENDATASOURCE,OPENQUERY,OPENROWSET,OPENXML,' +\r\n    'OPTION,OR,ORDER,OUTER,OVER,PERCENT,PLAN,PRECISION,' +\r\n    'PRIMARY,PRINT,PROC,PROCEDURE,PUBLIC,RAISERROR,READ,' +\r\n    'READTEXT,RECONFIGURE,REFERENCES,REPLICATION,RESTORE,' +\r\n    'RESTRICT,RETURN,REVOKE,RIGHT,ROLLBACK,ROWCOUNT,ROWGUIDCOL,' +\r\n    'RULE,SAVE,SCHEMA,SELECT,SESSION_USER,SET,SETUSER,SHUTDOWN,' +\r\n    'SOME,STATISTICS,TABLE,TEXTSIZE,THEN,TO,TOP,TRAN,TRANSACTION,' +\r\n    'TRIGGER,TRUNCATE,TSEQUAL,UNION,UNIQUE,UPDATE,UPDATETEXT,' +\r\n    'USE,USER,VALUES,VARYING,VIEW,WAITFOR,WEIGHT,WHEN,WHERE,WHILE,' +\r\n    'WITH,WRITETEXT';\r\n\r\n  // functions\r\n  MSSQL2000Functions: UnicodeString =\r\n    '@@CONNECTIONS,@@CPU_BUSY,@@CURSOR_ROWS,@@DATEFIRST,@@DBTS,@@ERROR,' +\r\n    '@@FETCH_STATUS,@@IDENTITY,@@IDLE,@@IO_BUSY,@@LANGID,@@LANGUAGE,' +\r\n    '@@LOCK_TIMEOUT,@@MAX_CONNECTIONS,@@MAX_PRECISION,@@NESTLEVEL,@@OPTIONS,' +\r\n    '@@PACKET_ERRORS,@@PACK_RECEIVED,@@PACK_SENT,@@PROCID,@@REMSERVER,' +\r\n    '@@ROWCOUNT,@@SERVERNAME,@@SERVICENAME,@@SPID,@@TEXTSIZE,@@TIMETICKS,' +\r\n    '@@TOTAL_ERRORS,@@TOTAL_READ,@@TOTAL_WRITE,@@TRANCOUNT,@@VERSION,' +\r\n    'ABS,ACOS,APP_NAME,ASCII,ASIN,ATAN,ATN2,AVG,BINARY_CHECKSUM,CAST,' +\r\n    'CEILING,CHARINDEX,CHECKSUM,CHECKSUM_AGG,COALESCE,COLLATIONPROPERTY,' +\r\n    'COLUMNPROPERTY,COL_LENGTH,COL_NAME,CONVERT,COS,COT,COUNT,' +\r\n    'COUNT_BIG,CURRENT_DATE,CURRENT_TIME,CURRENT_TIMESTAMP,' +\r\n    'CURRENT_USER,CURSOR_STATUS,DATABASEPROPERTY,DATABASEPROPERTYEX,' +\r\n    'DATALENGTH,DATEADD,DATEDIFF,DATENAME,DATEPART,DAY,DB_ID,DB_NAME,DEGREES,' +\r\n    'DIFFERENCE,EXP,FILEGROUPPROPERTY,FILEGROUP_ID,FILEGROUP_NAME,' +\r\n    'FILEPROPERTY,FILE_ID,FILE_NAME,FLOOR,fn_helpcollations,' +\r\n    'fn_listextendedproperty,fn_servershareddrives,fn_trace_geteventinfo,' +\r\n    'fn_trace_getfilterinfo,fn_trace_getinfo,fn_trace_gettable,' +\r\n    'fn_virtualfilestats,FORMATMESSAGE,FULLTEXTCATALOGPROPERTY,' +\r\n    'FULLTEXTSERVICEPROPERTY,GETANSINULL,GETDATE,GETUTCDATE,GROUPING,' +\r\n    'HAS_DBACCESS,HOST_ID,HOST_NAME,IDENT_CURRENT,IDENT_INCR,IDENT_SEED,' +\r\n    'INDEXKEY_PROPERTY,INDEXPROPERTY,INDEX_COL,ISDATE,ISNULL,ISNUMERIC,' +\r\n    'IS_MEMBER,IS_SRVROLEMEMBER,LEN,LOG,LOG10,LOWER,LTRIM,MAX,MIN,MONTH,' +\r\n    'NEWID,OBJECTPROPERTY,OBJECT_ID,OBJECT_NAME,PARSENAME,PATINDEX,' +\r\n    'PERMISSIONS,PI,POWER,QUOTENAME,RADIANS,RAND,REPLACE,REPLICATE,REVERSE,' +\r\n    'ROUND,ROWCOUNT_BIG,RTRIM,SCOPE_IDENTITY,SERVERPROPERTY,SESSIONPROPERTY,' +\r\n    'SIGN,SIN,SOUNDEX,SPACE,SQL_VARIANT_PROPERTY,SQRT,SQUARE,' +\r\n    'STATS_DATE,STDEV,STDEVP,STR,STUFF,SUBSTRING,SUM,SUSER_SID,SUSER_SNAME,' +\r\n    'SYSTEM_USER,TAN,TEXTPTR,TEXTVALID,TYPEPROPERTY,UNICODE,UPPER,' +\r\n    'USER_ID,USER_NAME,VAR,VARP,YEAR';\r\n\r\n  // types\r\n  MSSQL2000Types: UnicodeString =\r\n    'bigint,binary,bit,char,character,datetime,' +\r\n    'dec,decimal,float,image,int,' +\r\n    'integer,money,nchar,ntext,numeric,nvarchar,real,' +\r\n    'rowversion,smalldatetime,smallint,smallmoney,' +\r\n    'sql_variant,sysname,text,timestamp,tinyint,uniqueidentifier,' +\r\n    'varbinary,varchar';\r\n\r\n//---Interbase 6----------------------------------------------------------------\r\n  // functions\r\n  Interbase6Functions: UnicodeString = 'AVG,CAST,COUNT,GEN_ID,MAX,MIN,SUM,UPPER';\r\n\r\n  // keywords\r\n  Interbase6KW: UnicodeString = 'ACTIVE,ADD,AFTER,ALL,ALTER,AND,ANY,AS,ASC,' +\r\n    'ASCENDING,AT,AUTO,AUTODDL,BASED,BASENAME,BASE_NAME,BEFORE,BEGIN,BETWEEN,' +\r\n    'BLOBEDIT,BUFFER,BY,CACHE,CHARACTER_LENGTH,CHAR_LENGTH,CHECK,' +\r\n    'CHECK_POINT_LEN,CHECK_POINT_LENGTH,COLLATE,COLLATION,COLUMN,COMMIT,' +\r\n    'COMMITED,COMPILETIME,COMPUTED,CLOSE,CONDITIONAL,CONNECT,CONSTRAINT,' +\r\n    'CONTAINING,CONTINUE,CREATE,CURRENT,CURRENT_DATE,CURRENT_TIME,' +\r\n    'CURRENT_TIMESTAMP,CURSOR,DATABASE,DAY,DB_KEY,DEBUG,DEC,DECLARE,DEFAULT,' +\r\n    'DELETE,DESC,DESCENDING,DESCRIBE,DESCRIPTOR,DISCONNECT,DISTINCT,DO,' +\r\n    'DOMAIN,DROP,ECHO,EDIT,ELSE,END,ENTRY_POINT,ESCAPE,EVENT,EXCEPTION,' +\r\n    'EXECUTE,EXISTS,EXIT,EXTERN,EXTERNAL,EXTRACT,FETCH,FILE,FILTER,FOR,' +\r\n    'FOREIGN,FOUND,FROM,FULL,FUNCTION,GDSCODE,GENERATOR,GLOBAL,GOTO,GRANT,' +\r\n    'GROUP,GROUP_COMMIT_WAIT,GROUP_COMMIT_WAIT_TIME,HAVING,HELP,HOUR,IF,' +\r\n    'IMMEDIATE,IN,INACTIVE,INDEX,INDICATOR,INIT,INNER,INPUT,INPUT_TYPE,' +\r\n    'INSERT,INT,INTO,IS,ISOLATION,ISQL,JOIN,KEY,LC_MESSAGES,LC_TYPE,LEFT,' +\r\n    'LENGTH,LEV,LEVEL,LIKE,LOGFILE,LOG_BUFFER_SIZE,LOG_BUF_SIZE,LONG,MANUAL,' +\r\n    'MAXIMUM,MAXIMUM_SEGMENT,MAX_SEGMENT,MERGE,MESSAGE,MINIMUM,MINUTE,' +\r\n    'MODULE_NAME,MONTH,NAMES,NATIONAL,NATURAL,NCHAR,NO,NOAUTO,NOT,NULL,' +\r\n    'NUM_LOG_BUFFS,NUM_LOG_BUFFERS,OCTET_LENGTH,OF,ON,ONLY,OPEN,OPTION,OR,' +\r\n    'ORDER,OUTER,OUTPUT,OUTPUT_TYPE,OVERFLOW,PAGE,PAGELENGTH,PAGES,PAGE_SIZE,' +\r\n    'PARAMETER,PASSWORD,PLAN,POSITION,POST_EVENT,PRECISION,PREPARE,PROCEDURE,' +\r\n    'PROTECTED,PRIMARY,PRIVILEGES,PUBLIC,QUIT,RAW_PARTITIONS,READ,REAL,' +\r\n    'RECORD_VERSION,REFERENCES,RELEASE,RESERV,RESERVING,RETAIN,RETURN,' +\r\n    'RETURNING_VALUES,RETURNS,REVOKE,RIGHT,ROLLBACK,RUNTIME,SCHEMA,SECOND,' +\r\n    'SEGMENT,SELECT,SET,SHADOW,SHARED,SHELL,SHOW,SINGULAR,SIZE,SNAPSHOT,SOME,' +\r\n    'SORT,SQL,SQLCODE,SQLERROR,SQLWARNING,STABILITY,STARTING,STARTS,' +\r\n    'STATEMENT,STATIC,STATISTICS,SUB_TYPE,SUSPEND,TABLE,TERMINATOR,THEN,TO,' +\r\n    'TRANSACTION,TRANSLATE,TRANSLATION,TRIGGER,TRIM,TYPE,UNCOMMITTED,UNION,' +\r\n    'UNIQUE,UPDATE,USER,USING,VALUE,VALUES,VARIABLE,VARYING,VERSION,VIEW,' +\r\n    'WAIT,WEEKDAY,WHEN,WHENEVER,WHERE,WHILE,WITH,WORK,WRITE,YEAR,YEARDAY';\r\n\r\n  // types\r\n  Interbase6Types: UnicodeString =\r\n    'BLOB,CHAR,CHARACTER,DATE,DECIMAL,DOUBLE,FLOAT,INTEGER,' +\r\n    'NUMERIC,SMALLINT,TIME,TIMESTAMP,VARCHAR';\r\n\r\n//---MySQL----------------------------------------------------------------------\r\n  // keywords\r\n  MySqlKW: UnicodeString =\r\n    'ACTION,AFTER,AGAINST,AGGREGATE,ALGORITHM,ALL,ALTER,ANALYZE,AND,ANY,AS,' +\r\n    'ASC,AT,AUTO_INCREMENT,AVG_ROW_LENGTH,BACKUP,BEFORE,BEGIN,BENCHMARK,BETWEEN,BINLOG,BIT,' +\r\n    'BOOL,BOTH,BY,CACHE,CALL,CASCADE,CASCADED,CHANGE,CHARACTER,CHARSET,CHECK,' +\r\n    'CHECKSUM,CLIENT,COLLATE,COLLATION,COLUMN,COLUMNS,COMMENT,COMMIT,' +\r\n    'COMMITTED,COMPLETION,CONCURRENT,CONNECTION,CONSISTENT,CONSTRAINT,' +\r\n    'CONVERT,CONTAINS,CONTENTS,CREATE,CROSS,DATA,DATABASE,DATABASES,' +\r\n    'DEALLOCATE,DEC,DEFAULT,DEFINER,DELAYED,DELAY_KEY_WRITE,DELETE,DESC,' +\r\n    'DETERMINISTIC,DIRECTORY,DISABLE,DISCARD,DESCRIBE,DISTINCT,DISTINCTROW,' +\r\n    'DIV,DROP,DUAL,DUMPFILE,DUPLICATE,EACH,ELSE,ENABLE,ENCLOSED,END,ENDS,' +\r\n    'ENGINE,ENGINES,ESCAPE,ESCAPED,ERRORS,EVENT,EVENTS,EVERY,EXECUTE,EXISTS,' +\r\n    'EXPANSION,EXPLAIN,FALSE,FIELDS,FILE,FIRST,FLUSH,FOR,FORCE,FOREIGN,FROM,' +\r\n    'FULL,FULLTEXT,FUNCTION,FUNCTIONS,GLOBAL,GRANT,GRANTS,GROUP,HAVING,HELP,' +\r\n    'HIGH_PRIORITY,HOSTS,IDENTIFIED,IGNORE,INDEX,INFILE,INNER,INSERT,' +\r\n    'INSERT_METHOD,INSTALL,INT1,INT2,INT3,INT4,INT8,INTO,IO_THREAD,IS,' +\r\n    'ISOLATION,INVOKER,JOIN,KEY,KEYS,KILL,LAST,LEADING,LEAVES,LEVEL,LESS,' +\r\n    'LIKE,LIMIT,LINEAR,LINES,LIST,LOAD,LOCAL,LOCK,LOGS,LONG,LOW_PRIORITY,' +\r\n    'MASTER,MASTER_HOST,MASTER_LOG_FILE,MASTER_LOG_POS,MASTER_CONNECT_RETRY,' +\r\n    'MASTER_PASSWORD,MASTER_PORT,MASTER_SSL,MASTER_SSL_CA,MASTER_SSL_CAPATH,' +\r\n    'MASTER_SSL_CERT,MASTER_SSL_CIPHER,MASTER_SSL_KEY,MASTER_USER,MATCH,' +\r\n    'MAX_ROWS,MAXVALUE,MIDDLEINT,MIN_ROWS,MOD,MODE,MODIFY,MODIFIES,NAMES,' +\r\n    'NATURAL,NEW,NO,NODEGROUP,NOT,NULL,OJ,OFFSET,OLD,ON,OPTIMIZE,OPTION,' +\r\n    'OPTIONALLY,OPEN,OR,ORDER,OUTER,OUTFILE,PACK_KEYS,PARTIAL,PARTITION,' +\r\n    'PARTITIONS,PLUGIN,PLUGINS,PREPARE,PRESERVE,PRIMARY,PRIVILEGES,PROCEDURE,' +\r\n    'PROCESS,PROCESSLIST,QUERY,RAID_CHUNKS,RAID_CHUNKSIZE,RAID_TYPE,RANGE,' +\r\n    'READ,REBUILD,REFERENCES,REGEXP,RELAY_LOG_FILE,RELAY_LOG_POS,RELOAD,' +\r\n    'RENAME,REORGANIZE,REPAIR,REPEATABLE,REPLACE,REPLICATION,RESTRICT,RESET,' +\r\n    'RESTORE,RETURN,RETURNS,REVOKE,RLIKE,ROLLBACK,ROLLUP,ROUTINE,ROW,' +\r\n    'ROW_FORMAT,ROWS,SAVEPOINT,SCHEDULE,SCHEMA,SCHEMAS,SECURITY,SELECT,' +\r\n    'SERIALIZABLE,SESSION,SET,SHARE,SHOW,SHUTDOWN,SIMPLE,SLAVE,SNAPSHOT,' +\r\n    'SONAME,SQL,SQL_BIG_RESULT,SQL_BUFFER_RESULT,SQL_CACHE,' +\r\n    'SQL_CALC_FOUND_ROWS,SQL_NO_CACHE,SQL_SMALL_RESULT,SQL_THREAD,START,' +\r\n    'STARTING,STARTS,STATUS,STOP,STORAGE,STRAIGHT_JOIN,SUBPARTITION,' +\r\n    'SUBPARTITIONS,SUPER,TABLE,TABLES,TABLESPACE,TEMPORARY,TERMINATED,THAN,' +\r\n    'THEN,TO,TRAILING,TRANSACTION,TRIGGER,TRIGGERS,TRUE,TYPE,UNCOMMITTED,' +\r\n    'UNINSTALL,UNIQUE,UNLOCK,UPDATE,UPGRADE,UNION,USAGE,USE,USING,VALUES,' +\r\n    'VARIABLES,VARYING,VIEW,WARNINGS,WHERE,WITH,WORK,WRITE';\r\n\r\n  // PLSQL keywords\r\n  MySQLPLSQLKW: UnicodeString =\r\n    'CLOSE,CONDITION,CONTINUE,CURSOR,DECLARE,DO,EXIT,FETCH,FOUND,GOTO,' +\r\n    'HANDLER,ITERATE,LANGUAGE,LEAVE,LOOP,UNTIL,WHILE';\r\n\r\n  MySQLTypes: UnicodeString =\r\n\r\n    // Table Engines\r\n    'ARCHIVE,BDB,BERKELEYDB,BLACKHOLE,CSV,EXAMPLE,FEDERATED,HEAP,INNOBASE,' +\r\n    'InnoDB,ISAM,MEMORY,MERGE,MRG_ISAM,MRG_MYISAM,MyISAM,NDB,NDBCLUSTER,' +\r\n\r\n    // Index Types\r\n    'BTREE,HASH,' +\r\n\r\n    // Column Types\r\n    'bigint,blob,char,date,datetime,decimal,double,enum,float,' +\r\n    'geometry,geometrycollection,int,integer,linestring,longblob,longtext,' +\r\n    'mediumblob,mediumint,mediumtext,multilinestring,multipoint,multipolygon,' +\r\n    'national,numeric,point,polygon,precision,real,serial,signed,smallint,' +\r\n    'string,text,time,timestamp,tinyblob,tinyint,tinytext,unicode,unsigned,' +\r\n    'varbinary,varchar,year,zerofill,' +\r\n\r\n    // Row Formats\r\n    'COMPACT,COMPRESSED,DYNAMIC,FIXED,REDUNDANT,' +\r\n\r\n    // Raid Types\r\n    'RAID0,STRIPED,' +\r\n\r\n    // View Algorythm\r\n    'UNDEFINED,TEMPTABLE,' +\r\n\r\n    // Charsets\r\n    'armscii8,big5,binary,cp1250,cp1251,cp1256,cp1257,cp850,cp852,cp866,' +\r\n    'cp932,croat,czech,danish,dec8,dos,estonia,eucjpms,euckr,euc_kr,gb2312,' +\r\n    'gbk,geostd8,german1,greek,hp8,hebrew,hungarian,keybcs2,koi8_ru,koi8_ukr,' +\r\n    'koi8r,koi8u,latin1,latin1_de,latin2,latin5,latin7,macce,macroman,sjis,' +\r\n    'swe7,tis620,ucs2,ujis,usa7,utf8,win1250,win1251,win1251ukr,' +\r\n\r\n    '_armscii8,_big5,_binary,_cp1250,_cp1251,_cp1256,_cp1257,_cp850,_cp852,' +\r\n    '_cp866,_cp932,_croat,_czech,_danish,_dec8,_dos,_estonia,_eucjpms,_euckr,' +\r\n    '_euc_kr,_gb2312,_gbk,_geostd8,_german1,_greek,_hp8,_hebrew,_hungarian,' +\r\n    '_keybcs2,_koi8_ru,_koi8_ukr,_koi8r,_koi8u,_latin1,_latin1_de,_latin2,' +\r\n    '_latin5,_latin7,_macce,_macroman,_sjis,_swe7,_tis620,_ucs2,_ujis,_usa7,' +\r\n    '_utf8,_win1250,_win1251,_win1251ukr,' +\r\n\r\n    // Collations\r\n    'armscii8_bin,armscii8_general_ci,ascii_bin,ascii_general_ci,big5_bin,' +\r\n    'big5_chinese_ci,cp1250_bin,cp1250_croatian_ci,cp1250_czech_cs,' +\r\n    'cp1250_general_ci,cp1250_polish_ci,cp1251_bin,cp1251_bulgarian_ci,' +\r\n    'cp1251_general_ci,cp1251_general_cs,cp1251_ukrainian_ci,cp1256_bin,' +\r\n    'cp1256_general_ci,cp1257_bin,cp1257_general_ci,cp1257_lithuanian_ci,' +\r\n    'cp850_bin,cp850_general_ci,cp852_bin,cp852_general_ci,cp866_bin,' +\r\n    'cp866_general_ci,cp932_bin,cp932_japanese_ci,dec8_bin,dec8_swedish_ci,' +\r\n    'eucjpms_bin,eucjpms_japanese_ci,euckr_bin,euckr_korean_ci,gb2312_bin,' +\r\n    'gb2312_chinese_ci,gbk_bin,gbk_chinese_ci,geostd8_bin,geostd8_general_ci,' +\r\n    'greek_bin,greek_general_ci,hebrew_bin,hebrew_general_ci,hp8_bin,' +\r\n    'hp8_english_ci,keybcs2_bin,keybcs2_general_ci,koi8r_bin,' +\r\n    'koi8r_general_ci,koi8u_bin,koi8u_general_ci,latin1_bin,latin1_danish_ci,' +\r\n    'latin1_general_ci,latin1_general_cs,latin1_german1_ci,latin1_german2_ci,' +\r\n    'latin1_spanish_ci,latin1_swedish_ci,latin2_bin,latin2_croatian_ci,' +\r\n    'latin2_czech_cs,latin2_general_ci,latin2_hungarian_ci,latin5_bin,' +\r\n    'latin5_turkish_ci,latin7_bin,latin7_estonian_cs,latin7_general_ci,' +\r\n    'latin7_general_cs,macce_bin,macce_general_ci,macroman_bin,' +\r\n    'macroman_general_ci,sjis_bin,sjis_japanese_ci,swe7_bin,swe7_swedish_ci,' +\r\n    'tis620_bin,tis620_thai_ci,ucs2_bin,ucs2_czech_ci,ucs2_danish_ci,' +\r\n    'ucs2_esperanto_ci,ucs2_estonian_ci,ucs2_general_ci,ucs2_hungarian_ci,' +\r\n    'ucs2_icelandic_ci,ucs2_latvian_ci,ucs2_lithuanian_ci,ucs2_persian_ci,' +\r\n    'ucs2_polish_ci,ucs2_romanian_ci,ucs2_roman_ci,ucs2_slovak_ci,' +\r\n    'ucs2_slovenian_ci,ucs2_spanish2_ci,ucs2_spanish_ci,ucs2_swedish_ci,' +\r\n    'ucs2_turkish_ci,ucs2_unicode_ci,ujis_bin,ujis_japanese_ci,utf8_bin,' +\r\n    'utf8_czech_ci,utf8_danish_ci,utf8_esperanto_ci,utf8_estonian_ci,' +\r\n    'utf8_general_ci,utf8_hungarian_ci,utf8_icelandic_ci,utf8_latvian_ci,' +\r\n    'utf8_lithuanian_ci,utf8_persian_ci,utf8_polish_ci,utf8_romanian_ci,' +\r\n    'utf8_roman_ci,utf8_slovak_ci,utf8_slovenian_ci,utf8_spanish2_ci,' +\r\n    'utf8_spanish_ci,utf8_swedish_ci,utf8_turkish_ci,utf8_unicode_ci,';\r\n\r\n  // functions\r\n  MySQLFunctions: UnicodeString =\r\n    'ABS,ACOS,ADD,ADDDATE,ADDTIME,ASCII,ASIN,ATAN,ATAN2,AVG,BIN,BIT_AND,' +\r\n    'BIT_COUNT,BIT_LENGTH,BIT_OR,BIT_XOR,CASE,CAST,CHARACTER_LENGTH,CEILING,' +\r\n    'CHAR_LENGTH,COALESCE,COERCIBILITY,COMPRESS,CONCAT,CONCAT_WS,' +\r\n    'CONNECTION_ID,CONV,CONVERT_TZ,COS,COT,COUNT,CRC32,CURDATE,CURRENT_DATE,' +\r\n    'CURRENT_TIME,CURRENT_TIMESTAMP,CURRENT_USER,CURTIME,DATE_ADD,' +\r\n    'DATE_FORMAT,DATE_SUB,DATEDIFF,DAY,DAYNAME,DAYOFMONTH,DAYOFWEEK,' +\r\n    'DAYOFYEAR,DAY_HOUR,DAY_MINUTE,DAY_SECOND,DECODE,DEGREES,ELT,ENCODE,' +\r\n    'ENCRYPT,EXP,EXPORT_SET,EXTRACT,EXTRACTVALUE,FIELD,FIND_IN_SET,FLOOR,' +\r\n    'FORMAT,FOUND_ROWS,FROM_DAYS,FROM_UNIXTIME,GET_FORMAT,GET_LOCK,GREATEST,' +\r\n    'GROUP_CONCAT,HEX,HOUR,HOUR_MINUTE,HOUR_SECOND,IF,IFNULL,IN,INET_ATON,' +\r\n    'INSERT_ID,INSTR,INTERVAL,ISNULL,IS_FREE_LOCK,IS_USED_LOCK,LAST_DAY,' +\r\n    'LAST_INSERT_ID,LCASE,LEAST,LEFT,LENGTH,LN,LOAD_FILE,LOCALTIME,' +\r\n    'LOCALTIMESTAMP,LOCATE,LOG,LOG10,LOG2,LOWER,LPAD,LTRIM,MAKEDATE,MAKETIME,' +\r\n    'MAKE_SET,MASTER_POS_LOG,MASTER_POS_WAIT,MAX,MD5,MICROSECOND,MID,MIN,' +\r\n    'MINUTE,MINUTE_SECOND,MONTH,MONTHNAME,NOW,NULLIF,OCT,OCTET_LENGTH,ORD,' +\r\n    'PASSWORD,PERIOD_ADD,PERIOD_DIFF,PI,POSITION,POW,POWER,QUARTER,QUOTE,' +\r\n    'RADIANS,RAND,RELEASE_LOCK,REPEAT,REVERSE,RIGHT,ROUND,ROW_COUNT,' +\r\n    'RPAD,RTRIM,SECOND,SEC_TO_TIME,SESSION_USER,SIGN,SIN,SOUNDEX,SLEEP,SPACE,' +\r\n    'SPATIAL,SQRT,STD,STDDEV,STDDEV_POP,STDDEV_SAMP,STRCMP,STR_TO_DATE,' +\r\n    'SUBDATE,SUBSTRING,SUBSTRING_INDEX,SUBTIME,SUM,SYSDATE,SYSTEM_USER,TAN,' +\r\n    'TIMEDIFF,TIMESTAMPADD,TIMESTAMPDIFF,TIME_FORMAT,TIME_TO_SEC,TO_DAYS,' +\r\n    'TRIM,TRUNCATE,UCASE,UNCOMPRESS,UNCOMPRESSED_LENGTH,UNHEX,UNIX_TIMESTAMP,' +\r\n    'UPDATEXML,UPPER,USER,UTC_DATE,UTC_TIME,UTC_TIMESTAMP,UUID,VARIANCE,' +\r\n    'VAR_POP,VAR_SAMP,VERSION,WEEK,WEEKDAY,WEEKOFYEAR,WHEN,YEARWEEK,YEAR_MONTH';\r\n\r\n//---Ingres---------------------------------------------------------------------\r\n  // keywords\r\n  IngresKW: UnicodeString =\r\n    'ABORT,ACTIVATE,ADD,ADDFORM,AFTER,AGGREGATE,ALL,ALTER,AND,APPEND,ARRAY,' +\r\n    'AS,ASC,AT,AUDIT_LOG,AUTHORIZATION,AUTOCOMMIT,AVGU,BEFORE,BEGIN,BETWEEN,' +\r\n    'BREAKDISPLAY,BY,BYREF,CACHE,CALL,CALLFRAME,CALLPROC,CASCADE,CHECK,CLEAR,' +\r\n    'CLEARROW,CLOSE,COLUMN,COMMAND,COMMENT,COMMIT,CONNECT,CONSTRAINT,' +\r\n    'CONTINUE,COPY,COUNTU,CPUFACTOR,CREATE,CURRENT,CURRENT_USER,CURSOR,DATA,' +\r\n    'DATAHANDLER,DATE_FORMAT,DBEVENT,DDL_CONCURRENCY,DEADLOCK,DECLARE,' +\r\n    'DEFAULT,DEFERRED,DEFINE,DELETE,DELETEROW,DESC,DESCRIBE,DESCRIPTOR,' +\r\n    'DESTROY,DIRECT,DISABLE,DISCONNECT,DISPLAY,DISTINCT,DISTRIBUTE,DO,DOWN,' +\r\n    'DROP,ELSE,ELSEIF,ENABLE,END,ENDDATA,ENDDISPLAY,ENDFORMS,ENDIF,ENDLOOP,' +\r\n    'ENDRETRIEVE,ENDSELECT,ENDWHILE,ERROR,ESCAPE,EXCLUDE,EXCLUDING,EXEC,' +\r\n    'EXECUTE,EXISTS,EXIT,FETCH,FIELD,FINALIZE,FOR,FOREIGN,FORMDATA,FORMINIT,' +\r\n    'FORMS,FROM,FULL,GET,GETFORM,GETOPER,GETROW,GLOBAL,GOTO,GRANT,GRANTED,' +\r\n    'HAVING,HELP,HELP_FORMS,HELP_FRS,HELPFILE,IDENTIFIED,IF,IIMESSAGE,' +\r\n    'IIPRINTF,IIPROMPT,IISTATEMENT,IMMEDIATE,IMPORT,IN,INCLUDE,INDEX,' +\r\n    'INDICATOR,INGRES,INITIALIZE,INITTABLE,INNER,INQUIRE_EQUEL,INQUIRE_FORMS,' +\r\n    'INQUIRE_FRS,INQUIRE_INGRES,INSERT,INSERTROW,INSTALLATION,INTEGRITY,INTO,' +\r\n    'IO_TRACE,IS,J_FREESZ1,J_FREESZ2,J_FREESZ3,J_FREESZ4,J_SORTBUFSZ,' +\r\n    'JCPUFACTOR,JOIN,JOINOP,JOURNALING,KEY,LEVEL,LIKE,LINK,LOADTABLE,LOCAL,' +\r\n    'LOCATION,LOCK_TRACE,LOG_TRACE,LOGDBEVENTS,LOGGING,MAXCOST,MAXCPU,' +\r\n    'MAXPAGE,MENUITEM,MESSAGE,MODE,MODIFY,MODULE,MONEY_FORMAT,MONEY_PREC,' +\r\n    'MOVE,NATURAL,NEXT,NODEADLOCK,NOECHO,NOIO_TRACE,NOJIONOP,NOJOURNALING,' +\r\n    'NOLOCK_TRACE,NOLOG_TRACE,NOLOGDBEVENTS,NOLOGGING,NOMAXCOST,NOMAXCPU,' +\r\n    'NOMAXIO,NOMAXPAGE,NOMAXQUERY,NOMAXROW,NOOPTIMIZEONLY,NOPRINTDBEVENTS,' +\r\n    'NOPRINTQRY,NOPRINTRULES,NOQEP,NORULES,NOSQL,NOSTATISTICS,NOT,NOTRACE,' +\r\n    'NULL,OF,ON,ONLY,OPEN,OPTIMIZEONLY,OPTION,OR,ORDER,OUT,PARAM,PERMIT,' +\r\n    'PREPARE,PRESERVE,PRIMARY,PRINT,PRINTDBEVENTS,PRINTQRY,PRINTSCREEN,' +\r\n    'PRIVILEGES,PROCEDURE,PROMPT,PUBLIC,PUT,PUTFORM,PUTOPER,PUTROW,QBUFSIZE,' +\r\n    'QEP,QRY,QUALIFICATION,QUERY_SIZE,RAISE,RANGE,READONLY,REDISPLAY,' +\r\n    'REFERENCES,REFERENCING,REGISTER,RELOCATE,REMOVE,RENAME,REPEAT,REPEATED,' +\r\n    'REPLACE,REPLICATE,RESTRICT,RESULT_STRUCTURE,RESUME,RET_INTO,RETRIEVE,' +\r\n    'RETURN,RETURNING,REVOKE,ROLLBACK,ROWS,RULE,RUN,SAVE,SAVEPOINT,SCHEMA,' +\r\n    'SCREEN,SCROLL,SCROLLDOWN,SCROLLUP,SECTION,SECURITY_ALARM,SECURITY_AUDIT,' +\r\n    'SELECT,SESSION,SET,SET_4GL,SET_EQUAL,SET_FORMS,SET_FRS,SET_INGRES,' +\r\n    'SET_SQL,SHORT_REMARK,SLEEP,SOME,SORT,SORTBUFSIZE,SQL,STATISTICS,STOP,' +\r\n    'SUBMENU,SUMU,SYNONYM,SYSTEM,TABLE,TABLEDATA,TEWMPORARY,THEN,TO,TRACE,' +\r\n    'TRANSACTION,TYPE,UNION,UNIQUE,UNLOADTABLE,UNTIL,UP,UPDATE,USER,USING,' +\r\n    'VALIDATE,VALIDROW,VALUES,VIEW,WHEN,WHENEVER,WHERE,WHILE,WITH,WORK';\r\n\r\n  // types\r\n  IngresTypes: UnicodeString =\r\n    'BYTE,C,CHAR,CHARACTER,DATE,DECIMAL,FLOAT,FLOAT4,FLOAT8,INTEGER,INTEGER1,' +\r\n    'INTEGER2,INTEGER4,LONG,MONEY,OBJECT_KEY,SECURITY_LABEL,SHORT,SMALLINT,' +\r\n    'TABLE_KEY,TEXT,VARCHAR,VARYING';\r\n\r\n  // functions\r\n  IngresFunctions: UnicodeString =\r\n    '_BINTIM,_CPU_MS,_DATE,_DIO_CNT,_ET_SEC,_PFAULT_CNT,_TIME,_VERSION,ABS,' +\r\n    'ANY,ATAN,AUTOCOMMIT_STATE,AVG,BIOCNT,CHAREXTRACT,COLLATION,CONCAT,' +\r\n    'CONNECT_TIME_LIMIT,COS,COUNT,CREATE_PROCEDURE,CREATE_TABLE,DATABASE,' +\r\n    'DATE_GMT,DATE_PART,DATE_TRUNC,DB_ADMIN,DB_DELIMITED_CASE,DB_NAME_CASE,' +\r\n    'DBA,DBMS_BIO,DBMS_CPU,DBMS_DIO,DBMSINFO,DOW,EXP,FLATTEN_AGGREGATE,' +\r\n    'FLATTEN_NONE,FLATTEN_OPTIMIZE,FLATTEN_SINGLETON,GROUP,HEX,' +\r\n    'IDLE_TIME_LIMIT,IFNULL,INITIAL_USER,INQUIRE_SQL,INT1,INT2,INT4,INTERVAL,' +\r\n    'LANGUAGE,LEFT,LENGTH,LOCATE,LOCKMODE,LOG,LONG_BYTE,LONG_VARCHAR,' +\r\n    'LOWERCASE,MAX,MAXCONNECT,MAXIDLE,MAXIO,MAXQUERY,MAXROW,MIN,MOD,NOTRIM,' +\r\n    'ON_ERROR_STATE,PAD,QUERY_IO_LIMIT,QUERY_LANGUAGE,QUERY_ROW_LIMIT,RIGHT,' +\r\n    'ROLE,SECURITY_AUDIT_LOG,SECURITY_AUDIT_STATE,SECURITY_PRIV,' +\r\n    'SELECT_SYSCAT,SERVER_CLASS,SESSION_ID,SESSION_PRIORITY,' +\r\n    'SESSION_PRIORITY_LIMIT,SESSION_PRIV,SESSION_SECLABEL,SESSION_USER,SHIFT,' +\r\n    'SIN,SIZE,SQRT,SQUEEZE,SUM,SYSTEM_USER,TABLE_STATISTICS,TERMINAL,' +\r\n    'TRANSACTION_STATE,TRIM,UPDATE_ROWCNT,UPDATE_SYSCAT,UPPERCASE,USERNAME,' +\r\n    'VARBYTE';\r\n\r\n//---Nexus----------------------------------------------------------------------\r\n  // keywords\r\n  NexusKW: UnicodeString =\r\n    'ABSOLUTE,AFTER,ALTER,ANY,ASC,ASSERT,ATOMIC,' +\r\n    'ADD,ALL,AND,AS,ASSEMBLY,AUTHORIZATION,BEFORE,' +\r\n    'BETWEEN,BINARY,BLOCK,BY,BEGIN,' +\r\n    'BLOCKSIZE,CALL,CASCADE,CAST,,' +\r\n    'CHARACTERS,CLR,CLOSE,CODEPAGE,COLLATION,COMMIT,CONTAINS,' +\r\n    'CROSS,CALLED,CASE,CATCH,' +\r\n    'CHECK,COALESCE,COLLATE,COLUMN,CONSTRAINT,' +\r\n    'CREATE,CURSOR,DATA,DECLARE,' +\r\n    'DELETE,DESC,DETERMINISTIC,DO,DROP,DAY,DEFAULT,DELETING,' +\r\n    'DESCRIPTION,DISTINCT,EACH,ELSEIF,ENCRYPT,END,EQUIVALENT,' +\r\n    'ESCAPE,EXECUTE,EXISTS,ELSE,EMPTY,ENCRYPTION,ENGINE,' +\r\n    'EXCEPT,EXTERNAL,FALSE,FETCH,FETCH_STATUS,FOR,FROM,FUNCTION,FIRST,FOREIGN,' +\r\n    'FULL,HAVING,HOUR,GLOBAL,GROW,GROUP,GROWSIZE,IDENTITY,IGNORE,' +\r\n    'IMMEDIATE,IN,INITIAL,INNER,INPUT,INSERTING,INTERVAL,IS,IF,INDEX,' +\r\n    'INITIALSIZE,INOUT,INSERT,INTERSECT,INTO,ITERATE,JOIN,' +\r\n    'KANA,KEY,LANGUAGE,LEAVE,LIKE,LOCALE,' +\r\n    'LARGE,LAST,LEFT,LOCAL,MATCH,' +\r\n    'MINUTE,MODIFIES,MONTH,NAME,NATURAL,NEXT,NONSPACE,' +\r\n    'NULLIF,NATIONAL,' +\r\n    'NEW,NO,NORESTRICT,NOT,NULL,NULLS,OBJECT,OCTETS,OF,ON,OUT,OCTET_LENGTH,' +\r\n    'ODD,OLD,OPEN,OR,ORDER,OUTER,PARTIAL,PERCENT,PRECISION,' +\r\n    'PRIOR,PROCEDURE,PASSWORDS,PRIMARY,REFERENCES,RELATIVE,REMOVE,RESTRICT,' +\r\n    'RETURNS,ROLLBACK,ROUTINE,READS,' +\r\n    'REFERENCING,REPEAT,RETURN,RIGHT,ROW,SECOND,' +\r\n    'SERIALIZABLE,SET,SIMPLE,SNAPSHOT,SORT,' +\r\n    'STRING,SELECT,SIGNAL,' +\r\n    'SOME,SQL,START,STORAGE,SYMBOLS,TABLE,' +\r\n    'TOP,TRANSACTION,TRY,THEN,' +\r\n    'TO,TRIGGER,TRUE,TYPE,UNION,UNKNOWN,UPDATE,' +\r\n    'UNIQUE,UNTIL,UPDATING,USE,VALUES,VARYING,' +\r\n    'VIEW,WHEN,WHILE,WITH,WORK,WHERE,WIDTH,YEAR';\r\n\r\n  // functions\r\n  NexusFunctions: UnicodeString =\r\n    'ABS,ATAN,ATAN2,ATN2,AVG,BOTH,BROUND,CEIL,CEILING,CHAR_LENGTH,CHARACTER_LENGTH,'+\r\n    'CHR,COS,COUNT,CURRENT_DATE,CURRENT_TIME,CURRENT_TIMESTAMP,CURRENT_USER,ERROR_MESSAGE,EXP,EXTRACT,'+\r\n    'FLOOR,LASTAUTOINC,LEADING,LIST,LN,LOCALTIME,LOCALTIMESTAMP,LOWER,MAX,MED,MIN,MOD,NEWGUID,OCTECT,'+\r\n    'OCTECT_LENGTH,ORD,PI,POSITION,POWER,RAND,ROUND,ROWSAFFECTED,ROWSREAD,SESSION_USER,SIN,SQRT,STD,'+\r\n    'SUBSTRING,SUM,SYSTEM_ROW#,TOSTRING,TOSTRINGLEN,TRAILING,TRIM,UPPER,USER,USING';\r\n\r\n  // types\r\n  NexusTypes: UnicodeString =\r\n    'CHARACTER,CHAR,NULLSTRING,SHORTSTRING,SINGLECHAR,VARCHAR,' +\r\n    'CLOB,TEXT,NSINGLECHAR,NCHAR,' +\r\n    'NVARCHAR,NCLOB,BLOB,IMAGE,NUMERIC,DECIMAL,DEC,BYTE,TINYINT,SHORTINT,SMALLINT,INTEGER,INT,' +\r\n    'AUTOINC,BIGINT,LARGEINT,WORD,DWORD,FLOAT,REAL,DOUBLE,EXTENDED,MONEY,' +\r\n    'BOOLEAN,BOOL,DATE,TIME,TIMESTAMP,DATETIME,GUID,BYTEARRAY,RECREV';\r\n\r\nfunction TSynSQLSyn.HashKey(Str: PWideChar): Integer;\r\nvar\r\n  FoundDoubleMinus: Boolean;\r\n\r\n  function GetOrd: Integer;\r\n  begin\r\n    case Str^ of\r\n      '_': Result := 1;\r\n      'a'..'z': Result := 2 + Ord(Str^) - Ord('a');\r\n      'A'..'Z': Result := 2 + Ord(Str^) - Ord('A');\r\n      '@':\r\n        if fDialect in [sqlMSSQL7, sqlMSSQL2K] then\r\n          Result := 24\r\n        else\r\n          Result := 0;\r\n      else Result := 0;\r\n    end;\r\n  end;\r\n\r\nbegin\r\n  Result := 0;\r\n  while IsIdentChar(Str^) do\r\n  begin\r\n    FoundDoubleMinus := (Str^ = '-') and ((Str + 1)^ = '-');\r\n    if FoundDoubleMinus then Break;\r\n{$IFOPT Q-}\r\n    Result := 2 * Result + GetOrd;\r\n{$ELSE}\r\n    Result := (2 * Result + GetOrd) and $FFFFFF;\r\n{$ENDIF}\r\n    inc(Str);\r\n  end;\r\n  Result := Result and $FF; // 255\r\n  fStringLen := Str - fToIdent;\r\nend;\r\n\r\nfunction TSynSQLSyn.IdentKind(MayBe: PWideChar): TtkTokenKind;\r\nvar\r\n  Entry: TSynHashEntry;\r\nbegin\r\n  fToIdent := MayBe;\r\n  Entry := fKeywords[HashKey(MayBe)];\r\n  while Assigned(Entry) do\r\n  begin\r\n    if Entry.KeywordLen > fStringLen then\r\n      break\r\n    else if Entry.KeywordLen = fStringLen then\r\n      if IsCurrentToken(Entry.Keyword) then\r\n      begin\r\n        Result := TtkTokenKind(Entry.Kind);\r\n        exit;\r\n      end;\r\n    Entry := Entry.Next;\r\n  end;\r\n  Result := tkIdentifier;\r\nend;\r\n\r\nconstructor TSynSQLSyn.Create(AOwner: TComponent);\r\nbegin\r\n  inherited Create(AOwner);\r\n\r\n  fCaseSensitive := False;\r\n\r\n  fKeywords := TSynHashEntryList.Create;\r\n  fTableNames := TUnicodeStringList.Create;\r\n  TUnicodeStringList(fTableNames).OnChange := TableNamesChanged;\r\n\r\n  fFunctionNames := TunicodeStringList.Create;\r\n  TUnicodeStringList(fFunctionNames).OnChange := TableNamesChanged;\r\n\r\n  fCommentAttri := TSynHighlighterAttributes.Create(SYNS_AttrComment, SYNS_FriendlyAttrComment);\r\n  fCommentAttri.Style := [fsItalic];\r\n  AddAttribute(fCommentAttri);\r\n  fConditionalCommentAttri := TSynHighlighterAttributes.Create(SYNS_AttrConditionalComment, SYNS_FriendlyAttrConditionalComment);\r\n  fConditionalCommentAttri.Style := [fsItalic];\r\n  AddAttribute(fConditionalCommentAttri);\r\n  \r\n  fDataTypeAttri := TSynHighlighterAttributes.Create(SYNS_AttrDataType, SYNS_FriendlyAttrDataType);\r\n  fDataTypeAttri.Style := [fsBold];\r\n  AddAttribute(fDataTypeAttri);\r\n  fDefaultPackageAttri :=\r\n    TSynHighlighterAttributes.Create(SYNS_AttrDefaultPackage, SYNS_FriendlyAttrDefaultPackage);\r\n  fDefaultPackageAttri.Style := [fsBold];\r\n  AddAttribute(fDefaultPackageAttri);\r\n  fDelimitedIdentifierAttri := TSynHighlighterAttributes.Create(SYNS_AttrDelimitedIdentifier, SYNS_FriendlyAttrDelimitedIdentifier);\r\n  AddAttribute(fDelimitedIdentifierAttri);  \r\n  fExceptionAttri := TSynHighlighterAttributes.Create(SYNS_AttrException, SYNS_FriendlyAttrException);\r\n  fExceptionAttri.Style := [fsItalic];\r\n  AddAttribute(fExceptionAttri);\r\n  fFunctionAttri := TSynHighlighterAttributes.Create(SYNS_AttrFunction, SYNS_FriendlyAttrFunction);\r\n  fFunctionAttri.Style := [fsBold];\r\n  AddAttribute(fFunctionAttri);\r\n  fIdentifierAttri := TSynHighlighterAttributes.Create(SYNS_AttrIdentifier, SYNS_FriendlyAttrIdentifier);\r\n  AddAttribute(fIdentifierAttri);\r\n  fKeyAttri := TSynHighlighterAttributes.Create(SYNS_AttrReservedWord, SYNS_FriendlyAttrReservedWord);\r\n  fKeyAttri.Style := [fsBold];\r\n  AddAttribute(fKeyAttri);\r\n  fNumberAttri := TSynHighlighterAttributes.Create(SYNS_AttrNumber, SYNS_FriendlyAttrNumber);\r\n  AddAttribute(fNumberAttri);\r\n  fPLSQLAttri := TSynHighlighterAttributes.Create(SYNS_AttrPLSQL, SYNS_FriendlyAttrPLSQL);\r\n  fPLSQLAttri.Style := [fsBold];\r\n  AddAttribute(fPLSQLAttri);\r\n  fSpaceAttri := TSynHighlighterAttributes.Create(SYNS_AttrSpace, SYNS_FriendlyAttrSpace);\r\n  AddAttribute(fSpaceAttri);\r\n  fSQLPlusAttri:=TSynHighlighterAttributes.Create(SYNS_AttrSQLPlus, SYNS_FriendlyAttrSQLPlus);\r\n  fSQLPlusAttri.Style := [fsBold];\r\n  AddAttribute(fSQLPlusAttri);\r\n  fStringAttri := TSynHighlighterAttributes.Create(SYNS_Attrstring, SYNS_FriendlyAttrstring);\r\n  AddAttribute(fStringAttri);\r\n  fSymbolAttri := TSynHighlighterAttributes.Create(SYNS_AttrSymbol, SYNS_FriendlyAttrSymbol);\r\n  AddAttribute(fSymbolAttri);\r\n  fTableNameAttri := TSynHighlighterAttributes.Create(SYNS_AttrTableName, SYNS_FriendlyAttrTableName);\r\n  AddAttribute(fTableNameAttri);\r\n  fVariableAttri := TSynHighlighterAttributes.Create(SYNS_AttrVariable, SYNS_FriendlyAttrVariable);\r\n  AddAttribute(fVariableAttri);\r\n  SetAttributesOnChange(DefHighlightChange);\r\n  fDefaultFilter := SYNS_FilterSQL;\r\n  fRange := rsUnknown;\r\n  fDialect := sqlStandard;\r\n  InitializeKeywordLists;\r\nend;\r\n\r\ndestructor TSynSQLSyn.Destroy;\r\nbegin\r\n  fKeywords.Free;\r\n  fTableNames.Free;\r\n  fFunctionNames.Free;\r\n  inherited Destroy;\r\nend;\r\n\r\nprocedure TSynSQLSyn.Assign(Source: TPersistent);\r\nbegin\r\n  inherited Assign(Source);\r\n  if (Source is TSynSQLSyn) then\r\n    SQLDialect := TSynSQLSyn(Source).SQLDialect;\r\nend;\r\n\r\nprocedure TSynSQLSyn.AndSymbolProc;\r\nbegin\r\n  fTokenID := tkSymbol;\r\n  Inc(Run);\r\n  if CharInSet(fLine[Run], ['=', '&']) then Inc(Run);\r\nend;\r\n\r\nprocedure TSynSQLSyn.AsciiCharProc;\r\nbegin\r\n  // Oracle SQL allows strings to go over multiple lines\r\n  if fLine[Run] = #0 then\r\n    NullProc\r\n  else begin\r\n    fTokenID := tkString;\r\n    // else it's end of multiline string\r\n    if SQLDialect <> sqlMySql then\r\n    begin\r\n      if (Run > 0) or (fRange <> rsString) or (fLine[Run] <> #39) then\r\n      begin\r\n        fRange := rsString;\r\n        repeat\r\n          Inc(Run);\r\n        until IsLineEnd(Run) or (fLine[Run] = #39);\r\n      end;\r\n      if fLine[Run] = #39 then\r\n      begin\r\n        Inc(Run);\r\n        fRange := rsUnknown;\r\n      end;\r\n    end\r\n    else\r\n    begin\r\n      if (Run > 0) or (fRange <> rsString) or\r\n        ((fLine[Run] <> #39) and (fLine[Run - 1] <> '\\')) then\r\n      begin\r\n        fRange := rsString;\r\n        repeat\r\n          if (fLine[Run] <> '\\') and (fLine[Run + 1] = #39) then\r\n          begin\r\n            Inc(Run);\r\n            break;\r\n          end;\r\n          Inc(Run);\r\n        until IsLineEnd(Run);\r\n      end;\r\n      if (fLine[Run] = #39) and not(fLine[Run-1] = '\\') then\r\n      begin\r\n        Inc(Run);\r\n        fRange := rsUnknown;\r\n      end;\r\n    end;\r\n  end;\r\nend;\r\n\r\nprocedure TSynSQLSyn.CRProc;\r\nbegin\r\n  fTokenID := tkSpace;\r\n  Inc(Run);\r\n  if fLine[Run] = #10 then Inc(Run);\r\nend;\r\n\r\nprocedure TSynSQLSyn.EqualProc;\r\nbegin\r\n  fTokenID := tkSymbol;\r\n  Inc(Run);\r\n  if CharInSet(fLine[Run], ['=', '>']) then Inc(Run);\r\nend;\r\n\r\nprocedure TSynSQLSyn.GreaterProc;\r\nbegin\r\n  fTokenID := tkSymbol;\r\n  Inc(Run);\r\n  if CharInSet(fLine[Run], ['=', '>']) then Inc(Run);\r\nend;\r\n\r\nprocedure TSynSQLSyn.IdentProc;\r\nvar\r\n  FoundDoubleMinus: Boolean;\r\nbegin\r\n  fTokenID := IdentKind((fLine + Run));\r\n  inc(Run, fStringLen);\r\n  if fTokenID = tkComment then\r\n  begin\r\n    while not IsLineEnd(Run) do\r\n      Inc(Run);\r\n  end\r\n  else\r\n    while IsIdentChar(fLine[Run]) do\r\n    begin\r\n      FoundDoubleMinus := (fLine[Run] = '-') and (fLine[Run + 1] = '-');\r\n      if FoundDoubleMinus then Break;\r\n      inc(Run);\r\n    end;\r\nend;\r\n\r\nprocedure TSynSQLSyn.LFProc;\r\nbegin\r\n  fTokenID := tkSpace;\r\n  inc(Run);\r\nend;\r\n\r\nprocedure TSynSQLSyn.LowerProc;\r\nbegin\r\n  fTokenID := tkSymbol;\r\n  Inc(Run);\r\n  case fLine[Run] of\r\n    '=': Inc(Run);\r\n    '<': begin\r\n           Inc(Run);\r\n           if fLine[Run] = '=' then Inc(Run);\r\n         end;\r\n  end;\r\nend;\r\n\r\nprocedure TSynSQLSyn.MinusProc;\r\nbegin\r\n  Inc(Run);\r\n  if fLine[Run] = '-' then\r\n  begin\r\n    fTokenID := tkComment;\r\n    repeat\r\n      Inc(Run);\r\n    until IsLineEnd(Run);\r\n  end\r\n  else\r\n    fTokenID := tkSymbol;\r\nend;\r\n\r\nprocedure TSynSQLSyn.HashProc;\r\nbegin\r\n  if SQLDialect = sqlMySql then\r\n  begin\r\n    fTokenID := tkComment;\r\n    repeat\r\n      Inc(Run);\r\n    until IsLineEnd(Run);\r\n  end\r\n  else\r\n  begin\r\n    Inc(Run);\r\n    fTokenID := tkUnknown;\r\n  end;\r\nend;\r\n\r\nprocedure TSynSQLSyn.NullProc;\r\nbegin\r\n  fTokenID := tkNull;\r\n  inc(Run);\r\nend;\r\n\r\nprocedure TSynSQLSyn.NumberProc;\r\n\r\n  function IsNumberChar: Boolean;\r\n  begin\r\n    case fLine[Run] of\r\n      '0'..'9', '.', '-':\r\n        Result := True;\r\n      else\r\n        Result := False;\r\n    end;\r\n  end;\r\n\r\nbegin\r\n  inc(Run);\r\n  fTokenID := tkNumber;\r\n  while IsNumberChar do\r\n  begin\r\n    case FLine[Run] of\r\n      '.':\r\n        if FLine[Run + 1] = '.' then break;\r\n    end;\r\n    inc(Run);\r\n  end;\r\nend;\r\n\r\nprocedure TSynSQLSyn.OrSymbolProc;\r\nbegin\r\n  fTokenID := tkSymbol;\r\n  Inc(Run);\r\n  if CharInSet(fLine[Run], ['=', '|']) then Inc(Run);\r\nend;\r\n\r\nprocedure TSynSQLSyn.PlusProc;\r\nbegin\r\n  fTokenID := tkSymbol;\r\n  Inc(Run);\r\n  if CharInSet(fLine[Run], ['=', '+']) then Inc(Run);\r\nend;\r\n\r\nprocedure TSynSQLSyn.SlashProc;\r\nbegin\r\n  Inc(Run);\r\n  case fLine[Run] of\r\n    '*':\r\n      begin\r\n        if (SQLDialect = sqlMySql) and (fLine[Run + 1] = '!') then\r\n        begin\r\n          fRange := rsConditionalComment;\r\n          fTokenID := tkConditionalComment;\r\n        end\r\n        else\r\n        begin\r\n          fRange := rsComment;\r\n          fTokenID := tkComment;\r\n        end;\r\n        repeat\r\n          Inc(Run);\r\n          if (fLine[Run] = '*') and (fLine[Run + 1] = '/') then begin\r\n            fRange := rsUnknown;\r\n            Inc(Run, 2);\r\n            break;\r\n          end;\r\n        until IsLineEnd(Run);\r\n      end;\r\n    '=':\r\n      begin\r\n        Inc(Run);\r\n        fTokenID := tkSymbol;\r\n      end;\r\n    '/':\r\n      begin\r\n        if (SQLDialect = sqlNexus)  then\r\n        begin\r\n          fTokenID := tkComment;\r\n          repeat\r\n            Inc(Run);\r\n          until IsLineEnd(Run);\r\n        end;\r\n      end\r\n    else\r\n      fTokenID := tkSymbol;\r\n  end;\r\nend;\r\n\r\nprocedure TSynSQLSyn.SpaceProc;\r\nbegin\r\n  inc(Run);\r\n  fTokenID := tkSpace;\r\n  while (FLine[Run] <= #32) and not IsLineEnd(Run) do inc(Run);\r\nend;\r\n\r\nprocedure TSynSQLSyn.QuoteProc;\r\nbegin\r\n  fTokenID := tkDelimitedIdentifier;\r\n  Inc(Run);\r\n  while not IsLineEnd(Run) do\r\n  begin\r\n    if fLine[Run] = #34 then\r\n    begin\r\n      Inc(Run);\r\n      if fLine[Run] <> #34 then\r\n        Break;\r\n    end;\r\n    Inc(Run);\r\n  end;\r\nend;\r\n\r\nprocedure TSynSQLSyn.BacktickProc;\r\nbegin\r\n  if SQLDialect = sqlMySql then\r\n  begin\r\n    fTokenID := tkDelimitedIdentifier;\r\n    Inc(Run);\r\n    while not IsLineEnd(Run) do\r\n    begin\r\n      if fLine[Run] = '`' then\r\n      begin\r\n        Inc(Run);\r\n        if fLine[Run] <> '`' then\r\n          Break;\r\n      end;\r\n      Inc(Run);\r\n    end;\r\n  end\r\n  else\r\n  begin\r\n    Inc(Run);\r\n    fTokenID := tkUnknown;\r\n  end;\r\nend;\r\n\r\nprocedure TSynSQLSyn.BracketProc;\r\nbegin\r\n  if SQLDialect in [sqlMSSQL7, sqlMSSQL2K] then\r\n  begin\r\n    fTokenID := tkDelimitedIdentifier;\r\n    Inc(Run);\r\n    while not IsLineEnd(Run) do\r\n    begin\r\n      if fLine[Run] = ']' then\r\n      begin\r\n        Inc(Run);\r\n        if fLine[Run] <> ']' then\r\n          Break;\r\n      end;\r\n      Inc(Run);\r\n    end;\r\n  end\r\n  else\r\n  begin\r\n    Inc(Run);\r\n    fTokenID := tkSymbol;\r\n  end;\r\nend;\r\n\r\nprocedure TSynSQLSyn.SymbolProc;\r\nbegin\r\n  Inc(Run);\r\n  fTokenID := tkSymbol;\r\nend;\r\n\r\nprocedure TSynSQLSyn.SymbolAssignProc;\r\nbegin\r\n  fTokenID := tkSymbol;\r\n  Inc(Run);\r\n  if fLine[Run] = '=' then Inc(Run);\r\nend;\r\n\r\nprocedure TSynSQLSyn.VariableProc;\r\nvar\r\n  i: integer;\r\n  FoundDoubleMinus: Boolean;\r\nbegin\r\n  // MS SQL Server uses @@ to indicate system functions/variables\r\n  if (SQLDialect in [sqlMSSQL7, sqlMSSQL2K]) and (fLine[Run] = '@') and (fLine[Run + 1] = '@') then\r\n    IdentProc\r\n  else if (SQLDialect in [sqlMySql, sqlOracle]) and (fLine[Run] = '@') then\r\n    SymbolProc\r\n  // Oracle uses the ':' character to indicate bind variables\r\n  // Ingres II also uses the ':' character to indicate variables\r\n  else if not (SQLDialect in [sqlOracle, sqlIngres]) and (fLine[Run] = ':') then\r\n    SymbolProc\r\n  else\r\n  begin\r\n    fTokenID := tkVariable;\r\n    i := Run;\r\n    repeat\r\n      FoundDoubleMinus := (fLine[i] = '-') and (fLine[i + 1] = '-');\r\n      if FoundDoubleMinus then Break;\r\n      Inc(i);\r\n    until not IsIdentChar(fLine[i]);\r\n    Run := i;\r\n  end;\r\nend;\r\n\r\nprocedure TSynSQLSyn.UnknownProc;\r\nbegin\r\n  Inc(Run);\r\n  fTokenID := tkUnknown;\r\nend;\r\n\r\nprocedure TSynSQLSyn.AnsiCProc;\r\nbegin\r\n  case fLine[Run] of\r\n     #0: NullProc;\r\n    #10: LFProc;\r\n    #13: CRProc;\r\n    else\r\n    begin\r\n      if fRange = rsConditionalComment then\r\n        fTokenID := tkConditionalComment\r\n      else\r\n        fTokenID := tkComment;\r\n      repeat\r\n        if (fLine[Run] = '*') and (fLine[Run + 1] = '/') then\r\n        begin\r\n          fRange := rsUnknown;\r\n          Inc(Run, 2);\r\n          Break;\r\n        end;\r\n        Inc(Run);\r\n      until IsLineEnd(Run);\r\n    end;\r\n  end;\r\nend;\r\n\r\nfunction TSynSQLSyn.IsKeyword(const AKeyword: UnicodeString): Boolean;\r\nvar\r\n  tk: TtkTokenKind;\r\nbegin\r\n  tk := IdentKind(PWideChar(AKeyword));\r\n  Result := tk in [tkDatatype, tkException, tkFunction, tkKey, tkPLSQL,\r\n    tkDefaultPackage];\r\nend;\r\n\r\nprocedure TSynSQLSyn.Next;\r\nbegin\r\n  fTokenPos := Run;\r\n  case fRange of\r\n    rsComment, rsConditionalComment:\r\n      AnsiCProc;\r\n    rsString:\r\n      AsciiCharProc;\r\n  else\r\n    case fLine[Run] of\r\n      #0: NullProc;\r\n      #10: LFProc;\r\n      #13: CRProc;\r\n      #39: AsciiCharProc;\r\n      '=': EqualProc;\r\n      '>': GreaterProc;\r\n      '<': LowerProc;\r\n      '-': MinusProc;\r\n      '#': HashProc;\r\n      '|': OrSymbolProc;\r\n      '+': PlusProc;\r\n      '/': SlashProc;\r\n      '&': AndSymbolProc;\r\n      #34: QuoteProc;\r\n      '`': BacktickProc;\r\n      '[': BracketProc;\r\n      ':', '@': VariableProc;\r\n      'A'..'Z', 'a'..'z', '_': IdentProc;\r\n      '0'..'9': NumberProc;\r\n      #1..#9, #11, #12, #14..#32: SpaceProc;\r\n      '^', '%', '*', '!': SymbolAssignProc;\r\n      '{', '}', '.', ',', ';', '?', '(', ')', ']', '~': SymbolProc;\r\n      else UnknownProc;\r\n    end;\r\n  end;\r\n  inherited;\r\nend;\r\n\r\nfunction TSynSQLSyn.GetDefaultAttribute(Index: integer):\r\n  TSynHighlighterAttributes;\r\nbegin\r\n  case Index of\r\n    SYN_ATTR_COMMENT: Result := fCommentAttri;\r\n    SYN_ATTR_IDENTIFIER: Result := fIdentifierAttri;\r\n    SYN_ATTR_KEYWORD: Result := fKeyAttri;\r\n    SYN_ATTR_STRING: Result := fStringAttri;\r\n    SYN_ATTR_WHITESPACE: Result := fSpaceAttri;\r\n    SYN_ATTR_SYMBOL: Result := fSymbolAttri;\r\n  else\r\n    Result := nil;\r\n  end;\r\nend;\r\n\r\nfunction TSynSQLSyn.GetEol: Boolean;\r\nbegin\r\n  Result := Run = fLineLen + 1;\r\nend;\r\n\r\nfunction TSynSQLSyn.GetRange: Pointer;\r\nbegin\r\n  Result := Pointer(fRange);\r\nend;\r\n\r\nfunction TSynSQLSyn.GetTokenID: TtkTokenKind;\r\nbegin\r\n  Result := fTokenId;\r\nend;\r\n\r\nfunction TSynSQLSyn.GetTokenAttribute: TSynHighlighterAttributes;\r\nbegin\r\n  case GetTokenID of\r\n    tkComment: Result := fCommentAttri;\r\n    tkConditionalComment: Result := fConditionalCommentAttri;\r\n    tkDatatype: Result := fDataTypeAttri;\r\n    tkDefaultPackage: Result := fDefaultPackageAttri;\r\n    tkDelimitedIdentifier: Result := fDelimitedIdentifierAttri;\r\n    tkException: Result := fExceptionAttri;\r\n    tkFunction: Result := fFunctionAttri;\r\n    tkIdentifier: Result := fIdentifierAttri;\r\n    tkKey: Result := fKeyAttri;\r\n    tkNumber: Result := fNumberAttri;\r\n    tkPLSQL: Result := fPLSQLAttri;\r\n    tkSpace: Result := fSpaceAttri;\r\n    tkSQLPlus: Result := fSQLPlusAttri;\r\n    tkString: Result := fStringAttri;\r\n    tkSymbol: Result := fSymbolAttri;\r\n    tkTableName: Result := fTableNameAttri;\r\n    tkVariable: Result := fVariableAttri;\r\n    tkUnknown: Result := fIdentifierAttri;\r\n  else\r\n    Result := nil;\r\n  end;\r\nend;\r\n\r\nfunction TSynSQLSyn.GetTokenKind: integer;\r\nbegin\r\n  Result := Ord(fTokenId);\r\nend;\r\n\r\nprocedure TSynSQLSyn.ResetRange;\r\nbegin\r\n  fRange := rsUnknown;\r\nend;\r\n\r\nprocedure TSynSQLSyn.SetRange(Value: Pointer);\r\nbegin\r\n  fRange := TRangeState(Value);\r\nend;\r\n\r\nfunction TSynSQLSyn.IsFilterStored: Boolean;\r\nbegin\r\n  Result := fDefaultFilter <> SYNS_FilterSQL;\r\nend;\r\n\r\nfunction TSynSQLSyn.IsIdentChar(AChar: WideChar): Boolean;\r\nbegin\r\n  case AChar of\r\n    'a'..'z', 'A'..'Z', '0'..'9', '_':\r\n      Result := True;\r\n    '-':\r\n      Result := fDialect = sqlStandard;\r\n    '#', '$':                          // TODO: check this case, ANSI code wasn't clear here if this is exclusively Oracle\r\n      Result := fDialect in [sqlOracle, sqlNexus];\r\n    '@':\r\n      Result := fDialect in [sqlMSSQL7, sqlMSSQL2K];\r\n     '!', '^', '{', '}','~':\r\n      Result := fDialect = sqlNexus\r\n    else\r\n      Result := False;\r\n  end;\r\nend;\r\n\r\nclass function TSynSQLSyn.GetLanguageName: string;\r\nbegin\r\n  Result := SYNS_LangSQL;\r\nend;\r\n\r\nprocedure TSynSQLSyn.DoAddKeyword(AKeyword: UnicodeString; AKind: integer);\r\nvar\r\n  HashValue: Integer;\r\nbegin\r\n  AKeyword := SynWideLowerCase(AKeyword);\r\n  HashValue := HashKey(PWideChar(AKeyword));\r\n  fKeywords[HashValue] := TSynHashEntry.Create(AKeyword, AKind);\r\nend;\r\n\r\nprocedure TSynSQLSyn.SetTableNames(const Value: TUnicodeStrings);\r\nbegin\r\n  fTableNames.Assign(Value);\r\nend;\r\n\r\nprocedure TSynSQLSyn.TableNamesChanged(Sender: TObject);\r\nbegin\r\n  InitializeKeywordLists;\r\nend;\r\n\r\nprocedure TSynSQLSyn.PutTableNamesInKeywordList;\r\nvar\r\n  i: Integer;\r\n  Entry: TSynHashEntry;\r\nbegin\r\n  for i := 0 to fTableNames.Count - 1 do\r\n  begin\r\n    Entry := fKeywords[HashKey(PWideChar(fTableNames[i]))];\r\n    while Assigned(Entry) do\r\n    begin\r\n      if SynWideLowerCase(Entry.Keyword) = SynWideLowerCase(fTableNames[i]) then\r\n        Break;\r\n      Entry := Entry.Next;\r\n    end;\r\n    if not Assigned(Entry) then\r\n      DoAddKeyword(fTableNames[i], Ord(tkTableName));\r\n  end;\r\nend;\r\n\r\nprocedure TSynSQLSyn.PutFunctionNamesInKeywordList;\r\nvar\r\n  i: Integer;\r\n  Entry: TSynHashEntry;\r\nbegin\r\n  for i := 0 to (fFunctionNames.Count - 1) do\r\n  begin\r\n    Entry := fKeywords[HashKey(PWideChar(fFunctionNames[i]))];\r\n    while Assigned(Entry) do\r\n    begin\r\n      if SynWideLowerCase(Entry.Keyword) = SynWideLowerCase(fFunctionNames[i]) then\r\n        Break;\r\n      Entry := Entry.Next;\r\n    end;\r\n    if not Assigned(Entry) then\r\n      DoAddKeyword(fFunctionNames[i], Ord(tkFunction));\r\n  end;\r\nend;\r\n\r\nprocedure TSynSQLSyn.InitializeKeywordLists;\r\nvar\r\n  I: Integer;\r\nbegin\r\n  fKeywords.Clear;\r\n\r\n  for I := 0 to Ord(High(TtkTokenKind)) - 1 do\r\n    EnumerateKeywords(I, GetKeywords(I), IsIdentChar, DoAddKeyword);\r\n\r\n  PutTableNamesInKeywordList;\r\n  PutFunctionNamesInKeywordList;\r\n  DefHighlightChange(Self);\r\nend;\r\n\r\nprocedure TSynSQLSyn.SetDialect(Value: TSQLDialect);\r\nbegin\r\n  if (Value <> fDialect) then\r\n  begin\r\n    fDialect := Value;\r\n    InitializeKeywordLists;\r\n  end;\r\nend;\r\n\r\nprocedure TSynSQLSyn.SetFunctionNames(const Value: TUnicodeStrings);\r\nbegin\r\n  fFunctionNames := Value;\r\nend;\r\n\r\nfunction TSynSQLSyn.GetSampleSource: UnicodeString;\r\nbegin\r\n  Result := '';\r\n  case fDialect of\r\n    sqlPostgres:\r\n      Result := '-- ANSI SQL sample source'#13#10 +\r\n        'SELECT *'#13#10 +\r\n        'FROM planets'#13#10 +\r\n        'WHERE diameter < 13000'#13#10 +\r\n        '  AND name <> ''Earth''';\r\n    sqlStandard:\r\n      Result := '-- ANSI SQL sample source'#13#10 +\r\n        'SELECT *'#13#10 +\r\n        'FROM planets'#13#10 +\r\n        'WHERE diameter < 13000'#13#10 +\r\n        '  AND name <> ''Earth''';\r\n    sqlInterbase6:\r\n      Result := '/* Interbase sample source */'#13#10 +\r\n        'SET TERM !! ;'#13#10 +\r\n        #13#10 +\r\n        'CREATE PROCEDURE HelloWorld(P_MSG VARCHAR(80)) AS'#13#10 +\r\n        'BEGIN'#13#10 +\r\n        '  EXECUTE PROCEDURE WRITELN(:P_MSG);'#13#10 +\r\n        'END !!'#13#10 +\r\n        #13#10 +\r\n        'SET TERM ; !!';\r\n    sqlMySQL:\r\n      Result := '/* MySQL sample source*/'#13#10 +\r\n        'SET @variable = 1;'#13#10 +\r\n        #13#10 +\r\n        'CREATE /*!32302 TEMPORARY */ TABLE t (a INT);'#13#10 +\r\n        #13#10 +\r\n        'CREATE TABLE sample ('#13#10 +\r\n        '        id INT NOT NULL,'#13#10 +\r\n        '        first_name CHAR(30) NOT NULL,'#13#10 +\r\n        '        PRIMARY KEY (id),'#13#10 +\r\n        '        INDEX name (first_name));'#13#10 +\r\n        #13#10 +\r\n        'SELECT DATE_ADD(''1997-12-31 23:59:59'','#13#10 +\r\n        '        INTERVAL 1 SECOND);'#13#10 +\r\n        #13#10 +\r\n        '# End of sample';\r\n    sqlOracle:\r\n      Result := 'PROMPT Oracle sample source'#13#10 +\r\n        'declare'#13#10 +\r\n        '  x varchar2(2000);'#13#10 +\r\n        'begin   -- Show some text here'#13#10 +\r\n        '  select to_char(count(*)) into x'#13#10 +\r\n        '  from tab;'#13#10 +\r\n        #13#10 +\r\n        '  dbms_output.put_line(''Hello World: '' || x);'#13#10 +\r\n        'exception'#13#10 +\r\n        '  when others then'#13#10 +\r\n        '    null;'#13#10 +\r\n        'end;';\r\n    sqlSybase:\r\n      Result := '/* SyBase example source */'#13#10 +\r\n        'declare @Integer        int'#13#10 +\r\n        #13#10 +\r\n        '/* Good for positive numbers only. */'#13#10 +\r\n        'select @Integer = 1000'#13#10 +\r\n        #13#10 +\r\n        'select \"Positives Only\" ='#13#10 +\r\n        '  right(replicate(\"0\",12) + '#13#10 +\r\n        '    convert(varchar, @Integer),12)'#13#10 +\r\n        #13#10 +\r\n        '/* Good for positive and negative numbers. */'#13#10 +\r\n        'select @Integer = -1000'#13#10 +\r\n        #13#10 +\r\n        'select \"Both Signs\" ='#13#10 +\r\n        '  substring( \"- +\", (sign(@Integer) + 2), 1) +'#13#10 +\r\n        '  right(replicate(\"0\",12) + '#13#10 +\r\n        '    convert(varchar, abs(@Integer)),12)'#13#10 +\r\n        #13#10 +\r\n        'select @Integer = 1000'#13#10 +\r\n        #13#10 +\r\n        'select \"Both Signs\" ='#13#10 +\r\n        '  substring( \"- +\", (sign(@Integer) + 2), 1) +'#13#10 +\r\n        '  right(replicate(\"0\",12) + '#13#10 +\r\n        '    convert(varchar, abs(@Integer)),12)'#13#10 +\r\n        #13#10 +\r\n        'go';\r\n    sqlIngres:\r\n      Result := '/* Ingres example source */'#13#10 +\r\n        'DELETE'#13#10 +\r\n        'FROM t1'#13#10 +\r\n        'WHERE EXISTS'#13#10 +\r\n        '(SELECT t2.column1, t2.column2'#13#10 +\r\n        'FROM t2'#13#10 +\r\n        'WHERE t1.column1 = t2.column1 and'#13#10 +\r\n        't1.column2 = t2.column2)';\r\n    sqlMSSQL7:\r\n      Result := '/* SQL Server 7 example source */'#13#10 +\r\n        'SET QUOTED_IDENTIFIER ON'#13#10 +\r\n        'GO'#13#10 +\r\n        'SET ANSI_NULLS OFF'#13#10 +\r\n        'GO'#13#10 +\r\n        #13#10 +\r\n        '/* Object:  Stored Procedure dbo.sp_PPQInsertOrder */'#13#10 +\r\n        'CREATE PROCEDURE sp_PPQInsertOrder'#13#10 +\r\n        '  @Name    varchar(25),'#13#10 +\r\n        '  @Address varchar(255),'#13#10 +\r\n        '  @ZipCode varchar(15)'#13#10 +\r\n        'AS'#13#10 +\r\n        '  INSERT INTO PPQOrders(Name, Address, ZipCode, OrderDate)'#13#10 +\r\n        '  VALUES (@Name, @Address, @ZipCode, GetDate())'#13#10 +\r\n        #13#10 +\r\n        '  SELECT SCOPE_IDENTITY()'#13#10 +\r\n        'GO';\r\n    sqlMSSQL2K:\r\n      Result := '/* SQL Server2000 example source */'#13#10 +\r\n        'SET QUOTED_IDENTIFIER ON'#13#10 +\r\n        'GO'#13#10 +\r\n        'SET ANSI_NULLS OFF'#13#10 +\r\n        'GO'#13#10 +\r\n        #13#10 +\r\n        '/* Object:  Stored Procedure dbo.sp_PPQInsertOrder */'#13#10 +\r\n        'CREATE PROCEDURE sp_PPQInsertOrder'#13#10 +\r\n        '  @Name    varchar(25),'#13#10 +\r\n        '  @Address varchar(255),'#13#10 +\r\n        '  @ZipCode varchar(15)'#13#10 +\r\n        'AS'#13#10 +\r\n        '  INSERT INTO PPQOrders(Name, Address, ZipCode, OrderDate)'#13#10 +\r\n        '  VALUES (@Name, @Address, @ZipCode, GetDate())'#13#10 +\r\n        #13#10 +\r\n        '  SELECT SCOPE_IDENTITY()'#13#10 +\r\n        'GO';\r\n  end;\r\nend;\r\n\r\nclass function TSynSQLSyn.GetFriendlyLanguageName: UnicodeString;\r\nbegin\r\n  Result := SYNS_FriendlyLangSQL;\r\nend;\r\n\r\nfunction TSynSQLSyn.GetKeyWords(TokenKind: Integer): UnicodeString;\r\nbegin\r\n  Result := '';\r\n\r\n  case fDialect of\r\n    sqlPostgres:\r\n      begin\r\n        case TtkTokenKind(TokenKind) of\r\n          tkDatatype: Result := PostgresTypes;\r\n          tkKey: Result := PostgresKW;\r\n          tkFunction: Result := PostgresFunctions;\r\n          tkException: Result := PostgresExceptions;\r\n        end;\r\n      end;\r\n    sqlIngres:\r\n      case TtkTokenKind(TokenKind) of\r\n        tkDatatype: Result := IngresTypes;\r\n        tkKey: Result := IngresKW;\r\n        tkFunction: Result := IngresFunctions;\r\n      end;\r\n    sqlInterbase6:\r\n      case TtkTokenKind(TokenKind) of\r\n        tkDatatype: Result := Interbase6Types;\r\n        tkFunction: Result := Interbase6Functions;\r\n        tkKey: Result := Interbase6KW;\r\n      end;\r\n    sqlMSSQL7:\r\n      case TtkTokenKind(TokenKind) of\r\n        tkKey: Result := MSSQL7KW;\r\n        tkDatatype: Result := MSSQL7Types;\r\n        tkFunction: Result := MSSQL7Functions;\r\n      end;\r\n    sqlMSSQL2K:\r\n      case TtkTokenKind(TokenKind) of\r\n        tkKey: Result := MSSQL2000KW;\r\n        tkDataType: Result := MSSQL2000Types;\r\n        tkFunction: Result := MSSQL2000Functions;\r\n      end;\r\n    sqlMySql:\r\n      case TtkTokenKind(TokenKind) of\r\n        tkKey: Result := MySqlKW;\r\n        tkDatatype: Result := MySqlTypes;\r\n        tkFunction: Result := MySqlFunctions;\r\n        tkPLSQL: Result := MySQLPLSQLKW;\r\n      end;\r\n    sqlOracle:\r\n      case TtkTokenKind(TokenKind) of\r\n        tkKey: Result := OracleKW;\r\n        tkDatatype: Result := OracleTypes;\r\n        tkException: Result := OracleExceptions;\r\n        tkFunction: Result := OracleFunctions;\r\n        tkComment: Result := OracleCommentKW;\r\n        tkDefaultPackage: Result := OracleDefaultPackages;\r\n        tkPLSQL: Result := OraclePLSQLKW;\r\n        tkSQLPlus: Result := OracleSQLPlusCommands;\r\n      end;\r\n    sqlStandard:\r\n      if TtkTokenKind(TokenKind) = tkKey then\r\n        Result := StandardKW;\r\n    sqlSybase:\r\n      if TtkTokenKind(TokenKind) = tkKey then\r\n        Result := SybaseKW;\r\n    sqlNexus:\r\n      case TtkTokenKind(TokenKind) of\r\n        tkKey: Result := NexusKW;\r\n        tkDatatype: Result := NexusTypes;\r\n        tkFunction: Result := NexusFunctions;\r\n      end;\r\n  end;\r\nend;\r\n\r\ninitialization\r\n{$IFNDEF SYN_CPPB_1}\r\n  RegisterPlaceableHighlighter(TSynSQLSyn);\r\n{$ENDIF}\r\nend.\r\n\r\n"
  },
  {
    "path": "External/SynEdit/Source/SynHighlighterST.pas",
    "content": "{-------------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: SynHighlighterST.pas, released 2002-07.\r\nST stands for Structured Text, and it is part of IEC1131 standard for\r\nprogramming PLCs.\r\nAuthor of this file is Ruggero Bandera.\r\nPortions created by Ruggero Bandera are Copyright (C) 2002 Ruggero Bandera.\r\nUnicode translation by Mal Hrz.\r\nAll Rights Reserved.\r\n\r\nContributors to the SynEdit and mwEdit projects are listed in the\r\nContributors.txt file.\r\n\r\nAlternatively, the contents of this file may be used under the terms of the\r\nGNU General Public License Version 2 or later (the \"GPL\"), in which case\r\nthe provisions of the GPL are applicable instead of those above.\r\nIf you wish to allow use of your version of this file only under the terms\r\nof the GPL and not to allow others to use your version of this file\r\nunder the MPL, indicate your decision by deleting the provisions above and\r\nreplace them with the notice and other provisions required by the GPL.\r\nIf you do not delete the provisions above, a recipient may use your version\r\nof this file under either the MPL or the GPL.\r\n\r\n$Id: SynHighlighterST.pas,v 1.9.2.6 2008/09/14 16:25:03 maelh Exp $ by Ruggero Bandera\r\n\r\nYou may retrieve the latest version of this file at the SynEdit home page,\r\nlocated at http://SynEdit.SourceForge.net\r\n\r\nKnown Issues:\r\n-------------------------------------------------------------------------------}\r\n\r\n{$IFNDEF QSYNHIGHLIGHTERST}\r\nunit SynHighlighterST;\r\n{$ENDIF}\r\n\r\n{$I SynEdit.inc}\r\n\r\ninterface\r\n\r\nuses\r\n{$IFDEF SYN_CLX}\r\n  QGraphics,\r\n  QSynEditTypes,\r\n  QSynEditHighlighter,\r\n  QSynUnicode,\r\n{$ELSE}\r\n  Windows,\r\n  Controls,\r\n  Graphics,\r\n  SynEditTypes,\r\n  SynEditHighlighter,\r\n  SynUnicode,\r\n{$ENDIF}\r\n  SysUtils,\r\n  Classes;\r\n\r\ntype\r\n  TtkTokenKind = (tkAsm, tkComment, tkIdentifier, tkKey, tkNull, tkNumber,\r\n    tkSpace, tkString, tkSymbol, tkUnknown);\r\n\r\n  TRangeState = (rsANil, rsAnsi, rsAnsiAsm, rsAsm, rsBor, rsBorAsm, rsProperty,\r\n    rsUnKnown);\r\n\r\n  PIdentFuncTableFunc = ^TIdentFuncTableFunc;\r\n  TIdentFuncTableFunc = function (Index: Integer): TtkTokenKind of object;\r\n\r\n  TSynSTSyn = class(TSynCustomHighlighter)\r\n  private\r\n    fAsmStart: Boolean;\r\n    fRange: TRangeState;\r\n    fIdentFuncTable: array[0..210] of TIdentFuncTableFunc;\r\n    FTokenID: TtkTokenKind;\r\n    fStringAttri: TSynHighlighterAttributes;\r\n    fNumberAttri: TSynHighlighterAttributes;\r\n    fKeyAttri: TSynHighlighterAttributes;\r\n    fSymbolAttri: TSynHighlighterAttributes;\r\n    fAsmAttri: TSynHighlighterAttributes;\r\n    fCommentAttri: TSynHighlighterAttributes;\r\n    fIdentifierAttri: TSynHighlighterAttributes;\r\n    fSpaceAttri: TSynHighlighterAttributes;\r\n    function AltFunc(Index: Integer): TtkTokenKind;\r\n    function KeyWordFunc(Index: Integer): TtkTokenKind;\r\n    function HashKey(Str: PWideChar): Cardinal;\r\n    function IdentKind(MayBe: PWideChar): TtkTokenKind;\r\n    procedure InitIdent;\r\n    procedure AddressOpProc;\r\n    procedure AsciiCharProc;\r\n    procedure AnsiProc;\r\n    procedure BorProc;\r\n    procedure BraceOpenProc;\r\n    procedure ColonOrGreaterProc;\r\n    procedure CRProc;\r\n    procedure IdentProc;\r\n    procedure IntegerProc;\r\n    procedure LFProc;\r\n    procedure LowerProc;\r\n    procedure NullProc;\r\n    procedure NumberProc;\r\n    procedure PointProc;\r\n    procedure RoundOpenProc;\r\n    procedure SemicolonProc;\r\n    procedure SlashProc;\r\n    procedure SpaceProc;\r\n    procedure StringProc;\r\n    procedure SymbolProc;\r\n    procedure UnknownProc;\r\n  protected\r\n    function IsFilterStored: Boolean; override;\r\n  public\r\n    class function GetLanguageName: string; override;\r\n    class function GetFriendlyLanguageName: UnicodeString; override;\r\n  public\r\n    constructor Create(AOwner: TComponent); override;\r\n    function GetDefaultAttribute(Index: integer): TSynHighlighterAttributes;\r\n      override;\r\n    function GetEol: Boolean; override;\r\n    function GetRange: Pointer; override;\r\n    function GetTokenAttribute: TSynHighlighterAttributes; override;\r\n    function GetTokenID: TtkTokenKind;\r\n    function GetTokenKind: integer; override;\r\n    procedure Next; override;\r\n    procedure ResetRange; override;\r\n    procedure SetRange(Value: Pointer); override;\r\n  published\r\n    property AsmAttri: TSynHighlighterAttributes read fAsmAttri write fAsmAttri;\r\n    property CommentAttri: TSynHighlighterAttributes read fCommentAttri\r\n      write fCommentAttri;\r\n    property IdentifierAttri: TSynHighlighterAttributes read fIdentifierAttri\r\n      write fIdentifierAttri;\r\n    property KeyAttri: TSynHighlighterAttributes read fKeyAttri write fKeyAttri;\r\n    property NumberAttri: TSynHighlighterAttributes read fNumberAttri\r\n      write fNumberAttri;\r\n    property SpaceAttri: TSynHighlighterAttributes read fSpaceAttri\r\n      write fSpaceAttri;\r\n    property StringAttri: TSynHighlighterAttributes read fStringAttri\r\n      write fStringAttri;\r\n    property SymbolAttri: TSynHighlighterAttributes read fSymbolAttri\r\n      write fSymbolAttri;\r\n  end;\r\n\r\nimplementation\r\n\r\nuses\r\n{$IFDEF SYN_CLX}\r\n  QSynEditStrConst;\r\n{$ELSE}\r\n  SynEditStrConst;\r\n{$ENDIF}\r\n\r\nconst\r\n  KeyWords: array[0..74] of UnicodeString = (\r\n    'action', 'and', 'any', 'any_num', 'array', 'at', 'bool', 'by', 'byte', \r\n    'case', 'configuration', 'constant', 'dint', 'do', 'dword', 'else', 'elsif', \r\n    'end_action', 'end_case', 'end_configuration', 'end_for', 'end_if', \r\n    'end_repeat', 'end_resource', 'end_step', 'end_struct', 'end_transition', \r\n    'end_type', 'end_var', 'end_while', 'exit', 'external', 'finally', 'for', \r\n    'from', 'function', 'goto', 'if', 'index', 'initial_step', 'initialization', \r\n    'int', 'label', 'not', 'of', 'on', 'or', 'program', 'real', 'repeat', \r\n    'resource', 'retain', 'return', 'sint', 'step', 'string', 'struct', 'then', \r\n    'time', 'to', 'transition', 'type', 'udint', 'uint', 'until', 'usint', \r\n    'var', 'var_external', 'var_global', 'var_in_out', 'var_input', \r\n    'var_output', 'while', 'word', 'xor' \r\n  );\r\n\r\n  KeyIndices: array[0..210] of Integer = (\r\n    -1, -1, -1, -1, -1, 55, 39, -1, -1, -1, -1, 51, -1, -1, -1, -1, 57, 49, 4, \r\n    -1, 17, -1, -1, -1, -1, -1, -1, 24, -1, -1, -1, -1, -1, -1, 61, -1, -1, -1, \r\n    47, -1, -1, -1, 58, 70, 38, -1, -1, 35, -1, -1, -1, 28, 12, -1, -1, -1, -1, \r\n    -1, -1, 64, -1, -1, 1, -1, -1, 69, 27, 45, -1, 2, -1, -1, -1, 3, 9, -1, 37, \r\n    13, 63, -1, -1, 8, -1, -1, -1, -1, -1, 60, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    10, -1, -1, -1, -1, -1, -1, -1, -1, -1, 18, 25, 20, -1, 53, 14, -1, -1, -1, \r\n    0, -1, -1, 26, 41, 42, 62, -1, -1, -1, 66, 21, 36, -1, -1, 30, -1, 73, 22, \r\n    -1, 16, -1, -1, -1, -1, 74, -1, -1, 23, -1, 29, 50, -1, -1, -1, -1, -1, 68, \r\n    -1, -1, 19, -1, 15, 11, -1, 48, -1, 72, -1, 43, -1, -1, -1, -1, 67, 31, -1, \r\n    32, -1, -1, 6, -1, -1, 7, 65, -1, -1, 33, -1, -1, -1, -1, -1, -1, -1, 5, -1, \r\n    40, 52, 34, -1, -1, -1, -1, -1, -1, -1, 56, -1, -1, 44, 54, -1, 71, 46, 59 \r\n  );\r\n\r\n{$Q-}\r\nfunction TSynSTSyn.HashKey(Str: PWideChar): Cardinal;\r\nbegin\r\n  Result := 0;\r\n  while IsIdentChar(Str^) do\r\n  begin\r\n    Result := Result * 381 + Ord(Str^) * 141;\r\n    inc(Str);\r\n  end;\r\n  Result := Result mod 211;\r\n  fStringLen := Str - fToIdent;\r\nend;\r\n{$Q+}\r\n\r\nfunction TSynSTSyn.IdentKind(MayBe: PWideChar): TtkTokenKind;\r\nvar\r\n  Key: Cardinal;\r\nbegin\r\n  fToIdent := MayBe;\r\n  Key := HashKey(MayBe);\r\n  if Key <= High(fIdentFuncTable) then\r\n    Result := fIdentFuncTable[Key](KeyIndices[Key])\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nprocedure TSynSTSyn.InitIdent;\r\nvar\r\n  i: Integer;\r\nbegin\r\n  for i := Low(fIdentFuncTable) to High(fIdentFuncTable) do\r\n    if KeyIndices[i] = -1 then\r\n      fIdentFuncTable[i] := AltFunc;\r\n\r\n  for i := Low(fIdentFuncTable) to High(fIdentFuncTable) do\r\n    if @fIdentFuncTable[i] = nil then\r\n      fIdentFuncTable[i] := KeyWordFunc;\r\nend;\r\n\r\nfunction TSynSTSyn.AltFunc(Index: Integer): TtkTokenKind;\r\nbegin\r\n  Result := tkIdentifier\r\nend;\r\n\r\nfunction TSynSTSyn.KeyWordFunc(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier\r\nend;\r\n\r\nconstructor TSynSTSyn.Create(AOwner: TComponent);\r\nbegin\r\n  inherited Create(AOwner);\r\n\r\n  fCaseSensitive := False;\r\n\r\n  fAsmAttri := TSynHighlighterAttributes.Create(SYNS_AttrAssembler, SYNS_FriendlyAttrAssembler);\r\n  AddAttribute(fAsmAttri);\r\n  fCommentAttri := TSynHighlighterAttributes.Create(SYNS_AttrComment, SYNS_FriendlyAttrComment);\r\n  fCommentAttri.Style:= [fsItalic];\r\n  AddAttribute(fCommentAttri);\r\n  fIdentifierAttri := TSynHighlighterAttributes.Create(SYNS_AttrIdentifier, SYNS_FriendlyAttrIdentifier);\r\n  AddAttribute(fIdentifierAttri);\r\n  fKeyAttri := TSynHighlighterAttributes.Create(SYNS_AttrReservedWord, SYNS_FriendlyAttrReservedWord);\r\n  fKeyAttri.Style:= [fsBold];\r\n  AddAttribute(fKeyAttri);\r\n  fNumberAttri := TSynHighlighterAttributes.Create(SYNS_AttrNumber, SYNS_FriendlyAttrNumber);\r\n  AddAttribute(fNumberAttri);\r\n  fSpaceAttri := TSynHighlighterAttributes.Create(SYNS_AttrSpace, SYNS_FriendlyAttrSpace);\r\n  AddAttribute(fSpaceAttri);\r\n  fStringAttri := TSynHighlighterAttributes.Create(SYNS_AttrString, SYNS_FriendlyAttrString);\r\n  AddAttribute(fStringAttri);\r\n  fSymbolAttri := TSynHighlighterAttributes.Create(SYNS_AttrSymbol, SYNS_FriendlyAttrSymbol);\r\n  AddAttribute(fSymbolAttri);\r\n  SetAttributesOnChange(DefHighlightChange);\r\n\r\n  InitIdent;\r\n  fRange := rsUnknown;\r\n  fAsmStart := False;\r\n  fDefaultFilter := SYNS_FilterST;\r\nend; { Create }\r\n\r\nprocedure TSynSTSyn.AddressOpProc;\r\nbegin\r\n  fTokenID := tkSymbol;\r\n  inc(Run);\r\n  if fLine[Run] = '@' then inc(Run);\r\nend;\r\n\r\nprocedure TSynSTSyn.AsciiCharProc;\r\nbegin\r\n  fTokenID := tkString;\r\n  inc(Run);\r\n  while CharInSet(FLine[Run], ['0'..'9']) do inc(Run);\r\nend;\r\n\r\nprocedure TSynSTSyn.BorProc;\r\nbegin\r\n  case fLine[Run] of\r\n     #0: NullProc;\r\n    #10: LFProc;\r\n    #13: CRProc;\r\n    else begin\r\n      fTokenID := tkComment;\r\n      repeat\r\n        if fLine[Run] = '}' then begin\r\n          Inc(Run);\r\n          if fRange = rsBorAsm then\r\n            fRange := rsAsm\r\n          else\r\n            fRange := rsUnKnown;\r\n          break;\r\n        end;\r\n        Inc(Run);\r\n      until IsLineEnd(Run);\r\n    end;\r\n  end;\r\nend;\r\n\r\nprocedure TSynSTSyn.BraceOpenProc;\r\nbegin\r\n  if fRange = rsAsm then\r\n    fRange := rsBorAsm\r\n  else\r\n    fRange := rsBor;\r\n  BorProc;\r\nend;\r\n\r\nprocedure TSynSTSyn.ColonOrGreaterProc;\r\nbegin\r\n  fTokenID := tkSymbol;\r\n  inc(Run);\r\n  if fLine[Run] = '=' then inc(Run);\r\nend;\r\n\r\nprocedure TSynSTSyn.CRProc;\r\nbegin\r\n  fTokenID := tkSpace;\r\n  inc(Run);\r\n  if fLine[Run] = #10 then inc(Run);\r\nend;\r\n\r\nprocedure TSynSTSyn.IdentProc;\r\nbegin\r\n  fTokenID := IdentKind((fLine + Run));\r\n  inc(Run, fStringLen);\r\n  while IsIdentChar(fLine[Run]) do inc(Run);\r\nend;\r\n\r\nprocedure TSynSTSyn.IntegerProc;\r\n\r\n  function IsIntegerChar: Boolean;\r\n  begin\r\n    case fLine[Run] of\r\n      '0'..'9', 'A'..'F', 'a'..'f':\r\n        Result := True;\r\n      else\r\n        Result := False;\r\n    end;\r\n  end;\r\n\r\nbegin\r\n  inc(Run);\r\n  fTokenID := tkNumber;\r\n  while IsIntegerChar do inc(Run);\r\nend;\r\n\r\nprocedure TSynSTSyn.LFProc;\r\nbegin\r\n  fTokenID := tkSpace;\r\n  inc(Run);\r\nend;\r\n\r\nprocedure TSynSTSyn.LowerProc;\r\nbegin\r\n  fTokenID := tkSymbol;\r\n  inc(Run);\r\n  if CharInSet(fLine[Run], ['=', '>']) then inc(Run);\r\nend;\r\n\r\nprocedure TSynSTSyn.NullProc;\r\nbegin\r\n  fTokenID := tkNull;\r\n  inc(Run);\r\nend;\r\n\r\nprocedure TSynSTSyn.NumberProc;\r\n\r\n  function IsNumberChar: Boolean;\r\n  begin\r\n    case fLine[Run] of\r\n      '0'..'9', '.', 'e', 'E':\r\n        Result := True;\r\n      else\r\n        Result := False;\r\n    end;\r\n  end;\r\n\r\nbegin\r\n  inc(Run);\r\n  fTokenID := tkNumber;\r\n  while IsNumberChar do\r\n  begin\r\n    case FLine[Run] of\r\n      '.':\r\n        if FLine[Run + 1] = '.' then break;\r\n    end;\r\n    inc(Run);\r\n  end;\r\nend;\r\n\r\nprocedure TSynSTSyn.PointProc;\r\nbegin\r\n  fTokenID := tkSymbol;\r\n  inc(Run);\r\n  if CharInSet(fLine[Run], ['.', ')']) then inc(Run);\r\nend;\r\n\r\nprocedure TSynSTSyn.AnsiProc;\r\nbegin\r\n  case fLine[Run] of\r\n     #0: NullProc;\r\n    #10: LFProc;\r\n    #13: CRProc;\r\n  else\r\n    fTokenID := tkComment;\r\n    repeat\r\n      if (fLine[Run] = '*') and (fLine[Run + 1] = ')') then begin\r\n        Inc(Run, 2);\r\n        if fRange = rsAnsiAsm then\r\n          fRange := rsAsm\r\n        else\r\n          fRange := rsUnKnown;\r\n        break;\r\n      end;\r\n      Inc(Run);\r\n    until IsLineEnd(Run);\r\n  end;\r\nend;\r\n\r\nprocedure TSynSTSyn.RoundOpenProc;\r\nbegin\r\n  Inc(Run);\r\n  case fLine[Run] of\r\n    '*':\r\n      begin\r\n        Inc(Run);\r\n        if fRange = rsAsm then\r\n          fRange := rsAnsiAsm\r\n        else\r\n          fRange := rsAnsi;\r\n        fTokenID := tkComment;\r\n        if not IsLineEnd(Run) then\r\n          AnsiProc;\r\n      end;\r\n    '.':\r\n      begin\r\n        inc(Run);\r\n        fTokenID := tkSymbol;\r\n      end;\r\n  else\r\n    fTokenID := tkSymbol;\r\n  end;\r\nend;\r\n\r\nprocedure TSynSTSyn.SemicolonProc;\r\nbegin\r\n  Inc(Run);\r\n  fTokenID := tkSymbol;\r\n  if fRange = rsProperty then\r\n    fRange := rsUnknown;\r\nend;\r\n\r\nprocedure TSynSTSyn.SlashProc;\r\nbegin\r\n  Inc(Run);\r\n  if fLine[Run] = '/' then begin\r\n    fTokenID := tkComment;\r\n    repeat\r\n      Inc(Run);\r\n    until IsLineEnd(Run);\r\n  end else\r\n    fTokenID := tkSymbol;\r\nend;\r\n\r\nprocedure TSynSTSyn.SpaceProc;\r\nbegin\r\n  inc(Run);\r\n  fTokenID := tkSpace;\r\n  while (FLine[Run] <= #32) and not IsLineEnd(Run) do inc(Run);\r\nend;\r\n\r\nprocedure TSynSTSyn.StringProc;\r\nbegin\r\n  fTokenID := tkString;\r\n  Inc(Run);\r\n  while not IsLineEnd(Run) do\r\n  begin\r\n    if fLine[Run] = #39 then\r\n    begin\r\n      Inc(Run);\r\n      if fLine[Run] <> #39 then\r\n        break;\r\n    end;\r\n    Inc(Run);\r\n  end;\r\nend;\r\n\r\nprocedure TSynSTSyn.SymbolProc;\r\nbegin\r\n  inc(Run);\r\n  fTokenID := tkSymbol;\r\nend;\r\n\r\nprocedure TSynSTSyn.UnknownProc;\r\nbegin\r\n  inc(Run);\r\n  fTokenID := tkUnknown;\r\nend;\r\n\r\nprocedure TSynSTSyn.Next;\r\nbegin\r\n  fAsmStart := False;\r\n  fTokenPos := Run;\r\n  case fRange of\r\n    rsAnsi, rsAnsiAsm:\r\n      AnsiProc;\r\n    rsBor, rsBorAsm:\r\n      BorProc;\r\n  else\r\n    case fLine[Run] of\r\n      #0: NullProc;\r\n      #10: LFProc;\r\n      #13: CRProc;\r\n      #1..#9, #11, #12, #14..#32: SpaceProc;\r\n      '#': AsciiCharProc;\r\n      '$': IntegerProc;\r\n      #39: StringProc;\r\n      '0'..'9': NumberProc;\r\n      'A'..'Z', 'a'..'z', '_': IdentProc;\r\n      '{': BraceOpenProc;\r\n      '}', '!', '\"', '%', '&', '('..'/', ':'..'@', '['..'^', '`', '~':\r\n        begin\r\n          case fLine[Run] of\r\n            '(': RoundOpenProc;\r\n            '.': PointProc;\r\n            ';': SemicolonProc;\r\n            '/': SlashProc;\r\n            ':', '>': ColonOrGreaterProc;\r\n            '<': LowerProc;\r\n            '@': AddressOpProc;\r\n          else\r\n            SymbolProc;\r\n          end;\r\n        end;\r\n      else\r\n        UnknownProc;\r\n    end;\r\n  end;\r\n  inherited;\r\nend;\r\n\r\nfunction TSynSTSyn.GetDefaultAttribute(Index: Integer): TSynHighlighterAttributes;\r\nbegin\r\n  case Index of\r\n    SYN_ATTR_COMMENT: Result := fCommentAttri;\r\n    SYN_ATTR_IDENTIFIER: Result := fIdentifierAttri;\r\n    SYN_ATTR_KEYWORD: Result := fKeyAttri;\r\n    SYN_ATTR_STRING: Result := fStringAttri;\r\n    SYN_ATTR_WHITESPACE: Result := fSpaceAttri;\r\n  else\r\n    Result := nil;\r\n  end;\r\nend;\r\n\r\nfunction TSynSTSyn.GetEol: Boolean;\r\nbegin\r\n  Result := Run = fLineLen + 1;\r\nend;\r\n\r\nfunction TSynSTSyn.GetTokenID: TtkTokenKind;\r\nbegin\r\n  if not fAsmStart and (fRange = rsAsm)\r\n    and not (fTokenId in [tkNull, tkComment, tkSpace])\r\n  then\r\n    Result := tkAsm\r\n  else\r\n    Result := fTokenId;\r\nend;\r\n\r\nfunction TSynSTSyn.GetTokenAttribute: TSynHighlighterAttributes;\r\nbegin\r\n  case GetTokenID of\r\n    tkAsm: Result := fAsmAttri;\r\n    tkComment: Result := fCommentAttri;\r\n    tkIdentifier: Result := fIdentifierAttri;\r\n    tkKey: Result := fKeyAttri;\r\n    tkNumber: Result := fNumberAttri;\r\n    tkSpace: Result := fSpaceAttri;\r\n    tkString: Result := fStringAttri;\r\n    tkSymbol: Result := fSymbolAttri;\r\n    tkUnknown: Result := fSymbolAttri;\r\n  else\r\n    Result := nil;\r\n  end;\r\nend;\r\n\r\nfunction TSynSTSyn.GetTokenKind: integer;\r\nbegin\r\n  Result := Ord(GetTokenID);\r\nend;\r\n\r\nfunction TSynSTSyn.GetRange: Pointer;\r\nbegin\r\n  Result := Pointer(fRange);\r\nend;\r\n\r\nprocedure TSynSTSyn.SetRange(Value: Pointer);\r\nbegin\r\n  fRange := TRangeState(Value);\r\nend;\r\n\r\nprocedure TSynSTSyn.ResetRange;\r\nbegin\r\n  fRange:= rsUnknown;\r\nend;\r\n\r\nclass function TSynSTSyn.GetLanguageName: string;\r\nbegin\r\n  Result := SYNS_LangST;\r\nend;\r\n\r\nfunction TSynSTSyn.IsFilterStored: boolean;\r\nbegin\r\n  Result := fDefaultFilter <> SYNS_FilterST;\r\nend;\r\n\r\nclass function TSynSTSyn.GetFriendlyLanguageName: UnicodeString;\r\nbegin\r\n  Result := SYNS_FriendlyLangST;\r\nend;\r\n\r\ninitialization\r\n{$IFNDEF SYN_CPPB_1}\r\n  RegisterPlaceableHighlighter(TSynSTSyn);\r\n{$ENDIF}\r\nend.\r\n"
  },
  {
    "path": "External/SynEdit/Source/SynHighlighterSml.pas",
    "content": "{-------------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: SynHighlighterSML.pas, released 2000-04-17.\r\nThe Original Code is based on the dmMLSyn.pas file from the\r\nmwEdit component suite by Martin Waldenburg and other developers, the Initial\r\nAuthor of this file is David H. Muir.\r\nUnicode translation by Mal Hrz.\r\nAll Rights Reserved.\r\n\r\nContributors to the SynEdit and mwEdit projects are listed in the\r\nContributors.txt file.\r\n\r\nAlternatively, the contents of this file may be used under the terms of the\r\nGNU General Public License Version 2 or later (the \"GPL\"), in which case\r\nthe provisions of the GPL are applicable instead of those above.\r\nIf you wish to allow use of your version of this file only under the terms\r\nof the GPL and not to allow others to use your version of this file\r\nunder the MPL, indicate your decision by deleting the provisions above and\r\nreplace them with the notice and other provisions required by the GPL.\r\nIf you do not delete the provisions above, a recipient may use your version\r\nof this file under either the MPL or the GPL.\r\n\r\n$Id: SynHighlighterSml.pas,v 1.14.2.6 2008/09/14 16:25:03 maelh Exp $\r\n\r\nYou may retrieve the latest version of this file at the SynEdit home page,\r\nlocated at http://SynEdit.SourceForge.net\r\n\r\nKnown Issues:\r\n-------------------------------------------------------------------------------}\r\n{\r\n@abstract(Provides SynEdit with a Standard ML syntax highlighter, with extra options for the standard Basis library.)\r\n@author(David H Muir )\r\n@created(1999)\r\n@lastmod(2000-06-23)\r\nThe SynHighlighterSML.pas unit provides SynEdit text control with a Standard ML highlighter.  Many formatting attributes can\r\nbe specified, and there is an option to include extra keywords and operators only found in the Basis library, this option can\r\nbe disabled for backwards compatibility with older ML compilers that do not have support for the Basis Library.\r\n}\r\n\r\n{$IFNDEF QSYNHIGHLIGHTERSML}\r\nunit SynHighlighterSml;\r\n{$ENDIF}\r\n\r\n{$I SynEdit.inc}\r\n\r\ninterface\r\n\r\nuses\r\n{$IFDEF SYN_CLX}\r\n  QGraphics,\r\n  QSynEditTypes,\r\n  QSynEditHighlighter,\r\n  QSynUnicode,\r\n{$ELSE}\r\n  Graphics,\r\n  Registry,\r\n  SynEditTypes,\r\n  SynEditHighlighter,\r\n  SynUnicode,\r\n{$ENDIF}\r\n  SysUtils,\r\n  Classes;\r\n\r\nType\r\n  TtkTokenKind = (tkCharacter, tkComment, tkIdentifier, tkKey, tkNull, tkNumber,\r\n    tkOperator, tkSpace, tkString, tkSymbol, tkSyntaxError, tkUnknown);\r\n\r\n  TRangeState = (rsUnknown, rsComment, rsMultilineString);\r\n\r\n  PIdentFuncTableFunc = ^TIdentFuncTableFunc;\r\n  TIdentFuncTableFunc = function (Index: Integer): TtkTokenKind of object;\r\n\r\ntype\r\n  TSynSMLSyn = class(TSynCustomHighlighter)\r\n  private\r\n    fBasis: Boolean;\r\n    fRange: TRangeState;\r\n    FTokenID: TtkTokenKind;\r\n    fIdentFuncTable: array[0..70] of TIdentFuncTableFunc;\r\n    fCharacterAttri: TSynHighlighterAttributes;\r\n    fCommentAttri: TSynHighlighterAttributes;\r\n    fIdentifierAttri: TSynHighlighterAttributes;\r\n    fKeyAttri: TSynHighlighterAttributes;\r\n    fNumberAttri: TSynHighlighterAttributes;\r\n    fOperatorAttri: TSynHighlighterAttributes;\r\n    fSpaceAttri: TSynHighlighterAttributes;\r\n    fStringAttri: TSynHighlighterAttributes;\r\n    fSymbolAttri: TSynHighlighterAttributes;\r\n    fSyntaxErrorAttri: TSynHighlighterAttributes;\r\n    function IsValidMLCharacter: Boolean;\r\n    function AltFunc(Index: Integer): TtkTokenKind;\r\n    function KeyWordFunc(Index: Integer): TtkTokenKind;\r\n    function HashKey(Str: PWideChar): Cardinal;\r\n    function IdentKind(MayBe: PWideChar): TtkTokenKind;\r\n    procedure InitIdent;\r\n    procedure CRProc;\r\n    procedure CharacterProc;\r\n    procedure ColonProc;\r\n    procedure CommentProc;\r\n    procedure IdentProc;\r\n    procedure LFProc;\r\n    procedure NullProc;\r\n    procedure NumberProc;\r\n    procedure OperatorProc;\r\n    procedure RoundBracketOpenProc;\r\n    procedure SpaceProc;\r\n    procedure StringProc;\r\n    procedure SymbolProc;\r\n    procedure UnknownProc;\r\n    procedure BasisOpProc;\r\n    procedure StringEndProc;\r\n    procedure PoundProc;\r\n  protected\r\n    function GetSampleSource: UnicodeString; override;\r\n    function IsFilterStored: Boolean; override;\r\n  public\r\n    class function GetLanguageName: string; override;\r\n    class function GetFriendlyLanguageName: UnicodeString; override;\r\n    function GetRange: Pointer; override;\r\n    procedure ResetRange; override;\r\n    procedure SetRange(Value: Pointer); override;\r\n  public\r\n    constructor Create(AOwner: TComponent); override;\r\n    function GetDefaultAttribute(Index: Integer): TSynHighlighterAttributes;\r\n      override;\r\n    function GetEol: Boolean; override;\r\n    function GetTokenID: TtkTokenKind;\r\n    function GetTokenAttribute: TSynHighlighterAttributes; override;\r\n    function GetTokenKind: integer; override;\r\n    function IsIdentChar(AChar: WideChar): Boolean; override;\r\n    procedure Next; override;\r\n  published\r\n    property CharacterAttri: TSynHighlighterAttributes read fCharacterAttri\r\n      write fCharacterAttri;\r\n    property CommentAttri: TSynHighlighterAttributes read fCommentAttri\r\n      write fCommentAttri;\r\n    property IdentifierAttri: TSynHighlighterAttributes read fIdentifierAttri\r\n      write fIdentifierAttri;\r\n    property KeyAttri: TSynHighlighterAttributes read fKeyAttri write fKeyAttri;\r\n    property NumberAttri: TSynHighlighterAttributes read fNumberAttri\r\n      write fNumberAttri;\r\n    property OperatorAttri: TSynHighlighterAttributes read fOperatorAttri\r\n      write fOperatorAttri;\r\n    property SpaceAttri: TSynHighlighterAttributes read fSpaceAttri\r\n      write fSpaceAttri;\r\n    property StringAttri: TSynHighlighterAttributes read fStringAttri\r\n      write fStringAttri;\r\n    property SymbolAttri: TSynHighlighterAttributes read fSymbolAttri\r\n      write fSymbolAttri;\r\n    property SyntaxErrorAttri: TSynHighlighterAttributes read fSyntaxErrorAttri\r\n      write fSyntaxErrorAttri;\r\n    property Basis: Boolean read FBasis write FBasis default True;\r\n  end;\r\n\r\nimplementation\r\n\r\nuses\r\n{$IFDEF SYN_CLX}\r\n  QSynEditStrConst;\r\n{$ELSE}\r\n  SynEditStrConst;\r\n{$ENDIF}\r\n\r\nconst\r\n  KeyWords: array[0..40] of UnicodeString = (\r\n    'abstype', 'and', 'andalso', 'as', 'case', 'datatype', 'do', 'else', 'end', \r\n    'eqtype', 'exception', 'fn', 'fun', 'functor', 'handle', 'if', 'in', \r\n    'include', 'infix', 'infixr', 'let', 'local', 'nonfix', 'of', 'op', 'open', \r\n    'orelse', 'raise', 'rec', 'sharing', 'sig', 'signature', 'struct', \r\n    'structure', 'then', 'type', 'val', 'where', 'while', 'with', 'withtype' \r\n  );\r\n\r\n  KeyIndices: array[0..70] of Integer = (\r\n    28, -1, -1, -1, 23, 4, 19, -1, -1, 32, 8, 6, -1, 33, 0, -1, 14, -1, 2, -1, \r\n    -1, 29, 35, -1, -1, -1, -1, 13, -1, -1, 9, -1, 11, 30, 1, -1, 25, 36, -1, \r\n    -1, -1, 40, -1, 7, -1, 16, 26, 37, -1, 15, 21, -1, 18, 12, 5, -1, -1, 10, \r\n    22, 27, 34, 17, -1, 20, -1, 39, -1, 3, 38, 31, 24 \r\n  );\r\n\r\n{$Q-}\r\nfunction TSynSMLSyn.HashKey(Str: PWideChar): Cardinal;\r\nbegin\r\n  Result := 0;\r\n  while IsIdentChar(Str^) do\r\n  begin\r\n    Result := Result * 157 + Ord(Str^) * 35;\r\n    inc(Str);\r\n  end;\r\n  Result := Result mod 71;\r\n  fStringLen := Str - fToIdent;\r\nend;\r\n{$Q+}\r\n\r\nfunction TSynSMLSyn.IdentKind(MayBe: PWideChar): TtkTokenKind;\r\nvar\r\n  Key: Cardinal;\r\nbegin\r\n  fToIdent := MayBe;\r\n  Key := HashKey(MayBe);\r\n  if Key <= High(fIdentFuncTable) then\r\n    Result := fIdentFuncTable[Key](KeyIndices[Key])\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nprocedure TSynSMLSyn.InitIdent;\r\nvar\r\n  i: Integer;\r\nbegin\r\n  for i := Low(fIdentFuncTable) to High(fIdentFuncTable) do\r\n    if KeyIndices[i] = -1 then\r\n      fIdentFuncTable[i] := AltFunc;\r\n\r\n  for i := Low(fIdentFuncTable) to High(fIdentFuncTable) do\r\n    if @fIdentFuncTable[i] = nil then\r\n      fIdentFuncTable[i] := KeyWordFunc;\r\nend;\r\n\r\nfunction TSynSMLSyn.IsValidMLCharacter: Boolean;\r\n\r\n function IsABNRTChar(Run: Integer): Boolean;\r\n  begin\r\n    case fLine[Run] of\r\n      'a', 'b', 'n', 'r', 't':\r\n        Result := True;\r\n      else\r\n        Result := False;\r\n    end;\r\n  end;\r\n\r\nvar\r\n  ASCIIStr: UnicodeString;\r\n  ASCIICode, Error: Integer;\r\nbegin\r\n  Result := False;\r\n  if (fLine[Run] = '\"') then\r\n    if (Run > 2) and (fLine[Run - 1] <> '\\') and (fLine[Run - 2] = '\"') then\r\n      Result := True\r\n    else if (Run > 3) and (fLine[Run - 1] = '\\') and (fLine[Run - 2] = '\\')\r\n      and (fLine[Run - 3] = '\"') then\r\n      Result := True\r\n    else if (Run > 3) and IsABNRTChar(Run - 1) and\r\n      (fLine[Run - 2] = '\\') and (fLine[Run - 3] = '\"') then\r\n      Result := True\r\n    else if (Run > 5) and (fLine[Run - 4] = '\\') and (fLine[Run - 5] = '\"') then\r\n    begin\r\n      ASCIIStr := copy(fLine, Run - 2, 3);\r\n      Val(ASCIIStr, ASCIICode, Error);\r\n      if (Error = 0) and (ASCIICode >= 0) and (ASCIICode <= 255) then\r\n        Result := True\r\n    end\r\nend;\r\n\r\nfunction TSynSMLSyn.AltFunc(Index: Integer): TtkTokenKind;\r\nbegin\r\n  Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynSMLSyn.KeyWordFunc(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier\r\nend;\r\n\r\nconstructor TSynSMLSyn.Create(AOwner: TComponent);\r\nbegin\r\n  inherited Create(AOwner);\r\n\r\n  fCaseSensitive := True;\r\n\r\n  fCharacterAttri := TSynHighlighterAttributes.Create(SYNS_AttrCharacter, SYNS_FriendlyAttrCharacter);\r\n  fCharacterAttri.Foreground := clBlue;\r\n  AddAttribute(fCharacterAttri);\r\n  fCommentAttri := TSynHighlighterAttributes.Create(SYNS_AttrComment, SYNS_FriendlyAttrComment);\r\n  fCommentAttri.Style := [fsItalic];\r\n  fCommentAttri.Foreground := clNavy;\r\n  AddAttribute(fCommentAttri);\r\n  fIdentifierAttri := TSynHighlighterAttributes.Create(SYNS_AttrIdentifier, SYNS_FriendlyAttrIdentifier);\r\n  AddAttribute(fIdentifierAttri);\r\n  fKeyAttri := TSynHighlighterAttributes.Create(SYNS_AttrReservedWord, SYNS_FriendlyAttrReservedWord);\r\n  fKeyAttri.Style := [fsBold];\r\n  fKeyAttri.Foreground := clGreen;\r\n  AddAttribute(fKeyAttri);\r\n  fNumberAttri := TSynHighlighterAttributes.Create(SYNS_AttrNumber, SYNS_FriendlyAttrNumber);\r\n  fNumberAttri.Foreground := clRed;\r\n  AddAttribute(fNumberAttri);\r\n  fOperatorAttri := TSynHighlighterAttributes.Create(SYNS_AttrOperator, SYNS_FriendlyAttrOperator);\r\n  fOperatorAttri.Foreground := clMaroon;\r\n  AddAttribute(fOperatorAttri);\r\n  fSpaceAttri := TSynHighlighterAttributes.Create(SYNS_AttrSpace, SYNS_FriendlyAttrSpace);\r\n  AddAttribute(fSpaceAttri);\r\n  fStringAttri := TSynHighlighterAttributes.Create(SYNS_AttrString, SYNS_FriendlyAttrString);\r\n  fStringAttri.Foreground := clBlue;\r\n  AddAttribute(fStringAttri);\r\n  fSymbolAttri := TSynHighlighterAttributes.Create(SYNS_AttrSymbol, SYNS_FriendlyAttrSymbol);\r\n  AddAttribute(fSymbolAttri);\r\n  fSyntaxErrorAttri := TSynHighlighterAttributes.Create(SYNS_AttrSyntaxError, SYNS_FriendlyAttrSyntaxError);\r\n  fSyntaxErrorAttri.Foreground := clRed;\r\n  fSyntaxErrorAttri.Style := [fsBold];\r\n  AddAttribute(fSyntaxErrorAttri);\r\n  SetAttributesOnChange(DefHighlightChange);\r\n  InitIdent;        \r\n  fDefaultFilter := SYNS_FilterSML;\r\n  Basis := True;\r\nend;\r\n\r\nprocedure TSynSMLSyn.CRProc;\r\nbegin\r\n  fTokenID := tkSpace;\r\n  Case FLine[Run + 1] of\r\n    #10: inc(Run, 2);\r\n  else inc(Run);\r\n  end;\r\nend;\r\n\r\nprocedure TSynSMLSyn.ColonProc;\r\nbegin\r\n  inc(Run);\r\n  if Basis and (fLine[Run] = ':') then\r\n  begin\r\n    fTokenID := tkOperator;\r\n    inc(Run);\r\n  end\r\n  else fTokenID := tkSymbol;\r\nend;\r\n\r\nprocedure TSynSMLSyn.IdentProc;\r\nbegin\r\n  fTokenID := IdentKind((fLine + Run));\r\n  inc(Run, fStringLen);\r\n  while IsIdentChar(fLine[Run]) do inc(Run);\r\nend;\r\n\r\nprocedure TSynSMLSyn.LFProc;\r\nbegin\r\n  fTokenID := tkSpace;\r\n  inc(Run);\r\nend;\r\n\r\nprocedure TSynSMLSyn.NullProc;\r\nbegin\r\n  fTokenID := tkNull;\r\n  inc(Run);\r\nend;\r\n\r\nprocedure TSynSMLSyn.NumberProc;\r\n\r\n  function IsNumberChar: Boolean;\r\n  begin\r\n    case fLine[Run] of\r\n      '0'..'9', '.', 'u', 'U', 'l', 'L', 'x', 'X', 'e', 'E', 'f', 'F':\r\n        Result := True;\r\n      else\r\n        Result := False;\r\n    end;\r\n  end;\r\n\r\nbegin\r\n  inc(Run);\r\n  fTokenID := tkNumber;\r\n  while IsNumberChar do\r\n  begin\r\n    case FLine[Run] of\r\n      '.':  if FLine[Run + 1] = '.' then break;\r\n    end;\r\n    inc(Run);\r\n  end;\r\nend;\r\n\r\nprocedure TSynSMLSyn.OperatorProc;\r\nbegin\r\n  inc(Run);\r\n  fTokenID := tkOperator;\r\nend;\r\n\r\nprocedure TSynSMLSyn.SpaceProc;\r\nbegin\r\n  inc(Run);\r\n  fTokenID := tkSpace;\r\n  while (FLine[Run] <= #32) and not IsLineEnd(Run) do inc(Run);\r\nend;\r\n\r\nprocedure TSynSMLSyn.StringProc;\r\nbegin\r\n  fTokenID := tkString;\r\n  repeat\r\n    if fLine[Run] = '\\' then\r\n    begin\r\n      case fLine[Run + 1] of\r\n        '\"', '\\':\r\n          Inc(Run);\r\n        #00:\r\n          begin\r\n            Inc(Run);\r\n            fRange := rsMultilineString;\r\n            Exit;\r\n          end;\r\n      end;\r\n    end;\r\n    inc(Run);\r\n  until IsLineEnd(Run) or (fLine[Run] = '\"');\r\n  if FLine[Run] = '\"' then\r\n    inc(Run);\r\nend;\r\n\r\nprocedure TSynSMLSyn.StringEndProc;\r\nbegin\r\n  fTokenID := tkString;\r\n\r\n  case FLine[Run] of\r\n    #0:\r\n      begin\r\n        NullProc;\r\n        Exit;\r\n      end;\r\n    #10:\r\n      begin\r\n        LFProc;\r\n        Exit;\r\n      end;\r\n    #13:\r\n      begin\r\n        CRProc;\r\n        Exit;\r\n      end;\r\n  end;\r\n\r\n  fRange := rsUnknown;\r\n\r\n  repeat\r\n    case FLine[Run] of\r\n      #0, #10, #13: Break;\r\n      '\\':\r\n        begin\r\n          case fLine[Run + 1] of\r\n            '\"', '\\':\r\n              Inc(Run);\r\n            #00:\r\n              begin\r\n                Inc(Run);\r\n                fRange := rsMultilineString;\r\n                Exit;\r\n              end;\r\n          end;\r\n        end;\r\n      '\"': Break;\r\n    end;\r\n    inc(Run);\r\n  until IsLineEnd(Run) or (fLine[Run] = '\"');\r\n  if FLine[Run] = '\"' then\r\n    inc(Run);\r\nend;\r\n\r\nprocedure TSynSMLSyn.SymbolProc;\r\nbegin\r\n  inc(Run);\r\n  fTokenID := tkSymbol;\r\nend;\r\n\r\nprocedure TSynSMLSyn.UnknownProc;\r\nbegin\r\n  inc(Run);\r\n  fTokenID := tkUnknown;\r\nend;\r\n\r\nprocedure TSynSMLSyn.BasisOpProc;\r\nbegin\r\n  inc(Run);\r\n  if Basis then fTokenID := tkOperator else fTokenID := tkIdentifier;\r\nend;\r\n\r\nprocedure TSynSMLSyn.PoundProc;\r\nbegin\r\n  Inc(Run);\r\n  if (fLine[Run] = '\"') then\r\n    CharacterProc\r\n  else\r\n    fTokenID := tkIdentifier;\r\nend;\r\n\r\nprocedure TSynSMLSyn.CharacterProc;\r\nbegin\r\n  case fLine[Run] of\r\n     #0: NullProc;\r\n    #10: LFProc;\r\n    #13: CRProc;\r\n  else\r\n    begin\r\n      repeat\r\n        Inc(Run);\r\n      until IsLineEnd(Run) or (fLine[Run] = '\"');\r\n\r\n      if IsValidMLCharacter then\r\n        fTokenID := tkCharacter\r\n      else\r\n      begin\r\n        if fLine[Run] = '\"' then Inc(Run);\r\n        fTokenID := tkSyntaxError;\r\n      end;\r\n    end\r\n  end\r\nend;\r\n\r\nprocedure TSynSMLSyn.RoundBracketOpenProc;\r\nbegin\r\n  Inc(Run);\r\n  if (fLine[Run] = '*') then\r\n  begin\r\n    fRange := rsComment;\r\n    CommentProc;\r\n    fTokenID := tkComment;\r\n  end\r\n  else\r\n    fTokenID := tkIdentifier;\r\nend;\r\n\r\nprocedure TSynSMLSyn.CommentProc;\r\nbegin\r\n  case fLine[Run] of\r\n     #0: NullProc;\r\n    #10: LFProc;\r\n    #13: CRProc;\r\n  else\r\n    begin\r\n      fTokenID := tkComment;\r\n      repeat\r\n        if (fLine[Run] = '*') and\r\n           (fLine[Run + 1] = ')') then\r\n        begin\r\n          Inc(Run, 2);\r\n          fRange := rsUnknown;\r\n          Break;\r\n        end;\r\n        if not IsLineEnd(Run) then\r\n          Inc(Run);\r\n      until IsLineEnd(Run);\r\n    end;\r\n  end;\r\nend;\r\n\r\nprocedure TSynSMLSyn.Next;\r\nbegin\r\n  fTokenPos := Run;\r\n  case fRange of\r\n    rsComment: CommentProc;\r\n    rsMultilineString: StringEndProc; \r\n  else\r\n    begin\r\n      fRange := rsUnknown;\r\n\r\n      case fLine[Run] of\r\n        #13: CRProc;\r\n        '#': PoundProc;\r\n        ':': ColonProc;\r\n        'A'..'Z', 'a'..'z', '_': IdentProc;\r\n        #10: LFProc;\r\n        #0: NullProc;\r\n        '0'..'9': NumberProc;\r\n        #1..#9, #11, #12, #14..#32: SpaceProc;\r\n        '\"': StringProc;\r\n        '@', '^': BasisOpProc;\r\n        '(': RoundBracketOpenProc;\r\n        '+', '-', '~', '*', '/', '=', '<', '>': OperatorProc;\r\n        ',', '.',  ';': SymbolProc;\r\n        else UnknownProc;\r\n      end;\r\n    end;\r\n  end;\r\n  inherited;\r\nend;\r\n\r\nfunction TSynSMLSyn.GetDefaultAttribute(Index: Integer): TSynHighlighterAttributes;\r\nbegin\r\n  case Index of\r\n    SYN_ATTR_COMMENT: Result := fCommentAttri;\r\n    SYN_ATTR_IDENTIFIER: Result := fIdentifierAttri;\r\n    SYN_ATTR_KEYWORD: Result := fKeyAttri;\r\n    SYN_ATTR_STRING: Result := fStringAttri;\r\n    SYN_ATTR_WHITESPACE: Result := fSpaceAttri;\r\n    SYN_ATTR_SYMBOL: Result := fSymbolAttri;\r\n  else\r\n    Result := nil;\r\n  end;\r\nend;\r\n\r\nfunction TSynSMLSyn.GetEol: Boolean;\r\nbegin\r\n  Result := Run = fLineLen + 1;\r\nend;\r\n\r\nfunction TSynSMLSyn.GetTokenID: TtkTokenKind;\r\nbegin\r\n  Result := fTokenId;\r\nend;\r\n\r\nfunction TSynSMLSyn.GetTokenAttribute: TSynHighlighterAttributes;\r\nbegin\r\n  case GetTokenID of\r\n    tkCharacter: Result := fCharacterAttri;\r\n    tkComment: Result := fCommentAttri;\r\n    tkIdentifier: Result := fIdentifierAttri;\r\n    tkKey: Result := fKeyAttri;\r\n    tkNumber: Result := fNumberAttri;\r\n    tkOperator: Result := fOperatorAttri;\r\n    tkSpace: Result := fSpaceAttri;\r\n    tkString: Result := fStringAttri;\r\n    tkSymbol: Result := fSymbolAttri;\r\n    tkSyntaxError: Result := fSyntaxErrorAttri;\r\n    tkUnknown: Result := fIdentifierAttri;\r\n    else Result := nil;\r\n  end;\r\nend;\r\n\r\nfunction TSynSMLSyn.GetTokenKind: integer;\r\nbegin\r\n  Result := Ord(fTokenId);\r\nend;\r\n\r\nfunction TSynSMLSyn.IsFilterStored: Boolean;\r\nbegin\r\n  Result := fDefaultFilter <> SYNS_FilterSML;\r\nend;\r\n\r\nfunction TSynSMLSyn.IsIdentChar(AChar: WideChar): Boolean;\r\nbegin\r\n  case AChar of\r\n    #39, '_', '0'..'9', 'a'..'z', 'A'..'Z':\r\n      Result := True;\r\n    else\r\n      Result := False;\r\n  end;\r\nend;\r\n\r\nclass function TSynSMLSyn.GetLanguageName: string;\r\nbegin\r\n  Result := SYNS_LangSML;\r\nend;\r\n\r\nfunction TSynSMLSyn.GetSampleSource: UnicodeString;\r\nbegin\r\n  Result := '(* Syntax highlighting *)'#13#10 +\r\n            'load \"Real\";'#13#10 +\r\n            'fun PrintNumber(x: int) ='#13#10 +\r\n            '  let'#13#10 +\r\n            '    val Number = real(x) / 10.0;'#13#10 +\r\n            '    val Text = \"The Number is \" ^ Real.toString(~Number) ^ \"\\n\";'#13#10 +\r\n            '  in'#13#10 +\r\n            '    print Text;'#13#10 +\r\n            '    if x = 0 then () else PrintNumber(x-1)'#13#10+\r\n            '  end;' \r\nend;\r\n\r\nprocedure TSynSMLSyn.ResetRange;\r\nbegin\r\n  fRange := rsUnknown;\r\nend;\r\n\r\nprocedure TSynSMLSyn.SetRange(Value: Pointer);\r\nbegin\r\n  fRange := TRangeState(Value);\r\nend;\r\n\r\nfunction TSynSMLSyn.GetRange: Pointer;\r\nbegin\r\n  Result := Pointer(fRange);\r\nend;\r\n\r\nclass function TSynSMLSyn.GetFriendlyLanguageName: UnicodeString;\r\nbegin\r\n  Result := SYNS_FriendlyLangSML;\r\nend;\r\n\r\ninitialization\r\n{$IFNDEF SYN_CPPB_1}\r\n  RegisterPlaceableHighlighter(TSynSMLSyn);\r\n{$ENDIF}\r\nend.\r\n"
  },
  {
    "path": "External/SynEdit/Source/SynHighlighterTclTk.pas",
    "content": "{-------------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: SynHighlighterTclTk.pas, released 2000-05-05.\r\nThe Original Code is based on the siTclTkSyn.pas file from the\r\nmwEdit component suite by Martin Waldenburg and other developers, the Initial\r\nAuthor of this file is Igor Shitikov.\r\nUnicode translation by Mal Hrz.\r\nAll Rights Reserved.\r\n\r\nContributors to the SynEdit and mwEdit projects are listed in the\r\nContributors.txt file.\r\n\r\nAlternatively, the contents of this file may be used under the terms of the\r\nGNU General Public License Version 2 or later (the \"GPL\"), in which case\r\nthe provisions of the GPL are applicable instead of those above.\r\nIf you wish to allow use of your version of this file only under the terms\r\nof the GPL and not to allow others to use your version of this file\r\nunder the MPL, indicate your decision by deleting the provisions above and\r\nreplace them with the notice and other provisions required by the GPL.\r\nIf you do not delete the provisions above, a recipient may use your version\r\nof this file under either the MPL or the GPL.\r\n\r\n$Id: SynHighlighterTclTk.pas,v 1.18.2.12 2008/09/14 16:25:03 maelh Exp $\r\n\r\nYou may retrieve the latest version of this file at the SynEdit home page,\r\nlocated at http://SynEdit.SourceForge.net\r\n\r\nKnown Issues:\r\n-------------------------------------------------------------------------------}\r\n{\r\n@abstract(Provides a TCL/Tk highlighter for SynEdit)\r\n@author(Igor Shitikov, converted to SynEdit by David Muir )\r\n@created(5 December 1999, converted to SynEdit April 18, 2000)\r\n@lastmod(2000-06-23)\r\nThe SynHighlighterTclTk unit provides SynEdit with a TCL/Tk highlighter.\r\n}\r\n\r\n{$IFNDEF QSYNHIGHLIGHTERTCLTK}\r\nunit SynHighlighterTclTk;\r\n{$ENDIF}\r\n\r\n{$I SynEdit.inc}\r\n\r\ninterface\r\n\r\nuses\r\n{$IFDEF SYN_CLX}\r\n  QGraphics,\r\n  QSynEditTypes,\r\n  QSynEditHighlighter,\r\n  QSynUnicode,\r\n{$ELSE}\r\n  Windows,\r\n  Graphics,\r\n  SynEditTypes,\r\n  SynEditHighlighter,\r\n  SynUnicode,\r\n{$ENDIF}\r\n  SysUtils,\r\n  Classes;\r\n\r\ntype\r\n  TtkTokenKind = (tkSymbol, tkKey, tkComment, tkIdentifier, tkNull, tkNumber, tkSecondKey,\r\n    tkTixKey, tkSpace, tkString, tkOptions, tkVariable, tkWidgetKey, tkPath, tkUnknown);\r\n\r\n  TRangeState = (rsUnknown, rsAnsi, rsPasStyle, rsCStyle);\r\n\r\ntype\r\n  TSynTclTkSyn = class(TSynCustomHighlighter)\r\n  private\r\n    fRange: TRangeState;\r\n    FTokenID: TtkTokenKind;\r\n    fStringAttri: TSynHighlighterAttributes;\r\n    fSymbolAttri: TSynHighlighterAttributes;\r\n    fKeyAttri: TSynHighlighterAttributes;\r\n    fSecondKeyAttri: TSynHighlighterAttributes;\r\n    fNumberAttri: TSynHighlighterAttributes;\r\n    fCommentAttri: TSynHighlighterAttributes;\r\n    fSpaceAttri: TSynHighlighterAttributes;\r\n    fIdentifierAttri: TSynHighlighterAttributes;\r\n    fOptionsAttri: TSynHighlighterAttributes;\r\n    fVariableAttri: TSynHighlighterAttributes;\r\n    fPathAttri: TSynHighlighterAttributes;\r\n    fKeyWords: TUnicodeStrings;\r\n    fSecondKeys: TUnicodeStrings;\r\n    fTixWords: TUnicodeStrings;\r\n    fTixKeyAttri: TSynHighlighterAttributes;\r\n    fWidgetWords: TUnicodeStrings;\r\n    fWidgetKeyAttri: TSynHighlighterAttributes;\r\n    procedure BraceOpenProc;\r\n    procedure PointCommaProc;\r\n    procedure CRProc;\r\n    procedure IdentProc;\r\n    procedure LFProc;\r\n    procedure NullProc;\r\n    procedure NumberProc;\r\n    procedure RoundOpenProc;\r\n    procedure SlashProc;\r\n    procedure SpaceProc;\r\n    procedure StringProc;\r\n    procedure UnknownProc;\r\n    procedure AnsiProc;\r\n    procedure PasStyleProc;\r\n    procedure CStyleProc;\r\n    procedure VariableProc;\r\n    procedure PathProc;\r\n    procedure MinusProc;\r\n    procedure SymbolProc;\r\n    procedure SetKeyWords(const Value: TUnicodeStrings);\r\n    procedure SetSecondKeys(const Value: TUnicodeStrings);\r\n    function IsKeywordListStored: Boolean;\r\n    function IsSecondKeywordListStored: Boolean;\r\n    function InternalIsKeyword(const AKeyword: UnicodeString;\r\n        KeyWordList: TUnicodeStrings; ACaseSensitive: Boolean = False): Boolean;\r\n  protected\r\n    function GetSampleSource: UnicodeString; override;\r\n    function IsFilterStored: Boolean; override;\r\n  public\r\n    class function GetLanguageName: string; override;\r\n    class function GetFriendlyLanguageName: UnicodeString; override;\r\n  public\r\n    constructor Create(AOwner: TComponent); override;\r\n    destructor Destroy; override;\r\n    function GetDefaultAttribute(Index: integer): TSynHighlighterAttributes;\r\n      override;\r\n    function GetEol: Boolean; override;\r\n    function GetRange: Pointer; override;\r\n    function GetTokenID: TtkTokenKind;\r\n    function IsKeyword(const AKeyword: UnicodeString): Boolean; override;\r\n    function GetTokenAttribute: TSynHighlighterAttributes; override;\r\n    function GetTokenKind: integer; override;\r\n    procedure Next; override;\r\n    procedure SetRange(Value: Pointer); override;\r\n    procedure ResetRange; override;\r\n    {$IFNDEF SYN_CLX}\r\n    function SaveToRegistry(RootKey: HKEY; Key: string): boolean; override;\r\n    function LoadFromRegistry(RootKey: HKEY; Key: string): Boolean; override;\r\n    {$ENDIF}\r\n  published\r\n    property CommentAttri: TSynHighlighterAttributes read fCommentAttri\r\n      write fCommentAttri;\r\n    property IdentifierAttri: TSynHighlighterAttributes read fIdentifierAttri\r\n      write fIdentifierAttri;\r\n    property KeyAttri: TSynHighlighterAttributes read fKeyAttri write fKeyAttri;\r\n    property KeyWords: TUnicodeStrings read fKeyWords write SetKeyWords\r\n      stored IsKeywordListStored;\r\n    property SecondKeyAttri: TSynHighlighterAttributes read fSecondKeyAttri\r\n      write fSecondKeyAttri;\r\n    property SecondKeyWords: TUnicodeStrings read fSecondKeys write SetSecondKeys\r\n      stored IsSecondKeywordListStored;\r\n    property TixKeyAttri: TSynHighlighterAttributes read fTixKeyAttri\r\n      write fTixKeyAttri;\r\n    property TixWords: TUnicodeStrings read fTixWords;\r\n    property WidgetKeyAttri: TSynHighlighterAttributes read fWidgetKeyAttri\r\n      write fWidgetKeyAttri;\r\n    property WidgetWords: TUnicodeStrings read fWidgetWords;\r\n\r\n    property NumberAttri: TSynHighlighterAttributes read fNumberAttri\r\n      write fNumberAttri;\r\n    property SpaceAttri: TSynHighlighterAttributes read fSpaceAttri\r\n      write fSpaceAttri;\r\n    property StringAttri: TSynHighlighterAttributes read fStringAttri\r\n      write fStringAttri;\r\n    property SymbolAttri: TSynHighlighterAttributes read fSymbolAttri\r\n      write fSymbolAttri;\r\n    property OptionsAttri: TSynHighlighterAttributes read fOptionsAttri\r\n      write fOptionsAttri;\r\n    property PathAttri: TSynHighlighterAttributes read fPathAttri\r\n      write fPathAttri;\r\n    property VariableAttri: TSynHighlighterAttributes read fVariableAttri\r\n      write fVariableAttri;\r\n  end;\r\n\r\nimplementation\r\n\r\nuses\r\n{$IFDEF SYN_CLX}\r\n  QSynEditStrConst;\r\n{$ELSE}\r\n  SynEditStrConst;\r\n{$ENDIF}\r\n\r\nconst\r\n  TclTkKeys: array[0..128] of UnicodeString = (\r\n    'after', 'append', 'array', 'auto_execok', 'auto_import', 'auto_load', \r\n    'auto_mkindex', 'auto_mkindex_old', 'auto_qualify', 'auto_reset', 'base', \r\n    'bgerror', 'binary', 'body', 'break', 'catch', 'cd', 'class', 'clock', \r\n    'close', 'code', 'concat', 'configbody', 'constructor', 'continue', 'dde', \r\n    'delete', 'destructor', 'else', 'elseif', 'encoding', 'ensemble', 'eof', \r\n    'error', 'eval', 'exec', 'exit', 'expr', 'fblocked', 'fconfigure', 'fcopy', \r\n    'file', 'fileevent', 'filename', 'find', 'flush', 'for', 'foreach', \r\n    'format', 'gets', 'glob', 'global', 'history', 'http', 'if', 'incr', 'info', \r\n    'inherit', 'interp', 'is', 'join', 'lappend', 'lindex', 'linsert', 'list', \r\n    'llength', 'load', 'local', 'lrange', 'lreplace', 'lsearch', 'lset', \r\n    'lsort', 'memory', 'method', 'msgcat', 'namespace', 'open', 'package', \r\n    'parray', 'pid', 'pkg_mkindex', 'private', 'proc', 'protected', 'public', \r\n    'puts', 'pwd', 're_syntax', 'read', 'regexp', 'registry', 'regsub', \r\n    'rename', 'resource', 'return', 'safe', 'safebase', 'scan', 'scope', 'seek', \r\n    'set', 'socket', 'source', 'split', 'string', 'subst', 'switch', 'tcl', \r\n    'tcl_endofword', 'tcl_findlibrary', 'tcl_startofnextword', \r\n    'tcl_startofpreviousword', 'tcl_wordbreakafter', 'tcl_wordbreakbefore', \r\n    'tcltest', 'tclvars', 'tell', 'then', 'time', 'trace', 'unknown', 'unset', \r\n    'update', 'uplevel', 'upvar', 'variable', 'vwait', 'while' \r\n  );\r\n   \r\n  SecondTclTkKeys: array[0..91] of UnicodeString = (\r\n    'bell', 'bind', 'bindidproc', 'bindproc', 'bindtags', 'bitmap', 'button', \r\n    'canvas', 'checkbutton', 'clipboard', 'colors', 'combobox', 'console', \r\n    'cursors', 'debug', 'destroy', 'entry', 'event', 'exp_after', 'exp_before', \r\n    'exp_continue', 'exp_internal', 'exp_send', 'expect', 'focus', 'font', \r\n    'frame', 'grab', 'grid', 'image', 'interact', 'interpreter', 'keysyms', \r\n    'label', 'labelframe', 'listbox', 'loadtk', 'log_file', 'log_user', 'lower', \r\n    'menu', 'menubutton', 'message', 'namespupd', 'option', 'options', 'pack', \r\n    'panedwindow', 'photo', 'place', 'radiobutton', 'raise', 'rgb', 'scale', \r\n    'scrollbar', 'selection', 'send', 'send_error', 'send_log', 'send_tty', \r\n    'send_user', 'sendout', 'sleep', 'spawn', 'spinbox', 'stty', 'text', 'tk', \r\n    'tk_bisque', 'tk_choosecolor', 'tk_choosedirectory', 'tk_dialog', \r\n    'tk_focusfollowsmouse', 'tk_focusnext', 'tk_focusprev', 'tk_getopenfile', \r\n    'tk_getsavefile', 'tk_menusetfocus', 'tk_messagebox', 'tk_optionmenu', \r\n    'tk_popup', 'tk_setpalette', 'tk_textcopy', 'tk_textcut', 'tk_textpaste', \r\n    'tkerror', 'tkvars', 'tkwait', 'toplevel', 'wait', 'winfo', 'wm' \r\n  );\r\n\r\n  TixKeys: array[0..43] of UnicodeString = (\r\n    'compound', 'pixmap', 'tix', 'tixballoon', 'tixbuttonbox', 'tixchecklist', \r\n    'tixcombobox', 'tixcontrol', 'tixdestroy', 'tixdirlist', \r\n    'tixdirselectdialog', 'tixdirtree', 'tixdisplaystyle', 'tixexfileselectbox', \r\n    'tixexfileselectdialog', 'tixfileentry', 'tixfileselectbox', \r\n    'tixfileselectdialog', 'tixform', 'tixgetboolean', 'tixgetint', 'tixgrid', \r\n    'tixhlist', 'tixinputonly', 'tixlabelentry', 'tixlabelframe', \r\n    'tixlistnotebook', 'tixmeter', 'tixmwm', 'tixnbframe', 'tixnotebook', \r\n    'tixoptionmenu', 'tixpanedwindow', 'tixpopupmenu', 'tixscrolledhlist', \r\n    'tixscrolledlistbox', 'tixscrolledtext', 'tixscrolledwindow', 'tixselect', \r\n    'tixstdbuttonbox', 'tixtlist', 'tixtree', 'tixutils', 'tixwish' \r\n  );\r\n  \r\n  WidgetKeys: array[0..32] of UnicodeString = (\r\n    'ArrowButton', 'Button', 'ButtonBox', 'BWidget', 'ComboBox', 'Dialog', \r\n    'DragSite', 'DropSite', 'DynamicHelp', 'Entry', 'Label', 'LabelEntry', \r\n    'LabelFrame', 'ListBox', 'MainFrame', 'MessageDlg', 'NoteBook', \r\n    'PagesManager', 'PanedWindow', 'PasswdDlg', 'ProgressBar', 'ProgressDlg', \r\n    'ScrollableFrame', 'ScrollableWindow', 'ScrolledWindow', 'ScrollView', \r\n    'SelectColor', 'SelectFont', 'Separator', 'SpinBox', 'TitleFrame', 'Tree', \r\n    'Widget' \r\n  );\r\n\r\nfunction TSynTclTkSyn.InternalIsKeyword(const AKeyword: UnicodeString;\r\n  KeyWordList: TUnicodeStrings; ACaseSensitive: Boolean = False): Boolean;\r\nvar\r\n  First, Last, I, Compare: Integer;\r\n  Token: UnicodeString;\r\nbegin\r\n  First := 0;\r\n  Last := KeyWordList.Count - 1;\r\n  Result := False;\r\n  if ACaseSensitive then\r\n    Token := AKeyword\r\n  else\r\n    Token := SynWideLowerCase(AKeyword);\r\n  while First <= Last do\r\n  begin\r\n    I := (First + Last) shr 1;\r\n    Compare := WideCompareStr(KeyWordList[i], Token);\r\n    if Compare = 0 then\r\n    begin\r\n      Result := True;\r\n      break;\r\n    end\r\n    else\r\n      if Compare < 0 then First := I + 1 else Last := I - 1;\r\n  end;\r\nend;\r\n\r\nfunction TSynTclTkSyn.IsKeyword(const AKeyword: UnicodeString): Boolean;\r\nbegin\r\n  Result := InternalIsKeyword(AKeyword, fWidgetWords, True) or\r\n    InternalIsKeyword(AKeyword, fTixWords) or\r\n    InternalIsKeyword(AKeyword, fKeyWords) or\r\n    InternalIsKeyword(AKeyword, fSecondKeys);\r\nend;\r\n\r\nconstructor TSynTclTkSyn.Create(AOwner: TComponent);\r\nvar\r\n  i: Integer;\r\nbegin\r\n  inherited Create(AOwner);\r\n\r\n  fCaseSensitive := False;\r\n\r\n  fKeyWords := TUnicodeStringList.Create;\r\n  TUnicodeStringList(fKeyWords).Sorted := True;\r\n  TUnicodeStringList(fKeyWords).Duplicates := dupIgnore;\r\n  fSecondKeys := TUnicodeStringList.Create;\r\n  TUnicodeStringList(fSecondKeys).Sorted := True;\r\n  TUnicodeStringList(fSecondKeys).Duplicates := dupIgnore;\r\n  fTixWords := TUnicodeStringList.Create;\r\n  TUnicodeStringList(fTixWords).Sorted := True;\r\n  TUnicodeStringList(fTixWords).Duplicates := dupIgnore;\r\n  fWidgetWords := TUnicodeStringList.Create;\r\n  TUnicodeStringList(fWidgetWords).Sorted := True;\r\n  TUnicodeStringList(fWidgetWords).Duplicates := dupIgnore;\r\n  fKeyWords.BeginUpdate;\r\n  for i := Low(TclTkKeys) to High(TclTkKeys) do\r\n    FKeyWords.Add(TclTkKeys[i]);\r\n  fKeyWords.EndUpdate;\r\n  fSecondKeys.BeginUpdate;\r\n  for i := Low(SecondTclTkKeys) to High(SecondTclTkKeys) do\r\n    fSecondKeys.Add(SecondTclTkKeys[i]);\r\n  fSecondKeys.EndUpdate;\r\n  fTixWords.BeginUpdate;\r\n  for i := Low(TixKeys) to High(TixKeys) do\r\n    FTixWords.Add(TixKeys[i]);\r\n  fTixWords.EndUpdate;\r\n  fWidgetWords.BeginUpdate;\r\n  for i := Low(WidgetKeys) to High(WidgetKeys) do\r\n    FWidgetWords.Add(WidgetKeys[i]);\r\n  fWidgetWords.EndUpdate;\r\n\r\n  fCommentAttri := TSynHighlighterAttributes.Create(SYNS_AttrComment, SYNS_FriendlyAttrComment);\r\n  fCommentAttri.Style := [fsItalic];\r\n  AddAttribute(fCommentAttri);\r\n  fIdentifierAttri := TSynHighlighterAttributes.Create(SYNS_AttrIdentifier, SYNS_FriendlyAttrIdentifier);\r\n  AddAttribute(fIdentifierAttri);\r\n  fKeyAttri := TSynHighlighterAttributes.Create(SYNS_AttrReservedWord, SYNS_FriendlyAttrReservedWord);\r\n  fKeyAttri.Style := [fsBold];\r\n  AddAttribute(fKeyAttri);\r\n  fSecondKeyAttri := TSynHighlighterAttributes.Create(SYNS_AttrSecondReservedWord, SYNS_FriendlyAttrSecondReservedWord);\r\n  fSecondKeyAttri.Style := [fsBold];\r\n  AddAttribute(fSecondKeyAttri);\r\n\r\n  fTixKeyAttri := TSynHighlighterAttributes.Create(SYNS_AttrTixKeyWords, SYNS_FriendlyAttrTixKeyWords);\r\n  fTixKeyAttri.Style := [fsBold, fsItalic];\r\n  AddAttribute(fTixKeyAttri);\r\n\r\n  fWidgetKeyAttri := TSynHighlighterAttributes.Create(SYNS_AttrWidgetWords, SYNS_FriendlyAttrWidgetWords);\r\n  fWidgetKeyAttri.Style := [fsBold, fsItalic];\r\n  AddAttribute(fWidgetKeyAttri);\r\n\r\n  fNumberAttri := TSynHighlighterAttributes.Create(SYNS_AttrNumber, SYNS_FriendlyAttrNumber);\r\n  AddAttribute(fNumberAttri);\r\n  fSpaceAttri := TSynHighlighterAttributes.Create(SYNS_AttrSpace, SYNS_FriendlyAttrSpace);\r\n  AddAttribute(fSpaceAttri);\r\n  fStringAttri := TSynHighlighterAttributes.Create(SYNS_AttrString, SYNS_FriendlyAttrString);\r\n  AddAttribute(fStringAttri);\r\n  fSymbolAttri := TSynHighlighterAttributes.Create(SYNS_AttrSymbol, SYNS_FriendlyAttrSymbol);\r\n  AddAttribute(fSymbolAttri);\r\n  SetAttributesOnChange(DefHighlightChange);\r\n  fOptionsAttri := TSynHighlighterAttributes.Create(SYNS_AttrOptions, SYNS_FriendlyAttrOptions);\r\n  AddAttribute(fOptionsAttri);\r\n  fVariableAttri := TSynHighlighterAttributes.Create(SYNS_AttrVariable, SYNS_FriendlyAttrVariable);\r\n  AddAttribute(fVariableAttri);\r\n  fPathAttri := TSynHighlighterAttributes.Create(SYNS_AttrPath, SYNS_FriendlyAttrPath);\r\n  AddAttribute(fPathAttri);\r\n\r\n  fRange := rsUnknown;\r\n  fDefaultFilter := SYNS_FilterTclTk;\r\nend;\r\n\r\ndestructor TSynTclTkSyn.Destroy;\r\nbegin\r\n  fWidgetWords.Free;\r\n  fTixWords.Free;\r\n  fSecondKeys.Free;\r\n  fKeyWords.Free;\r\n  inherited Destroy;\r\nend;\r\n\r\nprocedure TSynTclTkSyn.AnsiProc;\r\nbegin\r\n  fTokenID := tkComment;\r\n  case FLine[Run] of\r\n    #0:\r\n      begin\r\n        NullProc;\r\n        exit;\r\n      end;\r\n    #10:\r\n      begin\r\n        LFProc;\r\n        exit;\r\n      end;\r\n\r\n    #13:\r\n      begin\r\n        CRProc;\r\n        exit;\r\n      end;\r\n  end;\r\n\r\n  while not IsLineEnd(Run) do\r\n    if fLine[Run] = '*' then\r\n    begin\r\n      if fLine[Run + 1] = ')' then\r\n      begin\r\n        fRange := rsUnKnown;\r\n        inc(Run, 2);\r\n        break;\r\n      end\r\n      else\r\n        inc(Run)\r\n    end\r\n    else\r\n      inc(Run);\r\nend;\r\n\r\nprocedure TSynTclTkSyn.PasStyleProc;\r\nbegin\r\n  fTokenID := tkComment;\r\n  case FLine[Run] of\r\n    #0:\r\n      begin\r\n        NullProc;\r\n        exit;\r\n      end;\r\n    #10:\r\n      begin\r\n        LFProc;\r\n        exit;\r\n      end;\r\n\r\n    #13:\r\n      begin\r\n        CRProc;\r\n        exit;\r\n      end;\r\n  end;\r\n\r\n  while not IsLineEnd(Run) do\r\n    if FLine[Run] = '}' then\r\n    begin\r\n      fRange := rsUnKnown;\r\n      inc(Run);\r\n      break;\r\n    end\r\n    else\r\n      inc(Run);\r\nend;\r\n\r\nprocedure TSynTclTkSyn.CStyleProc;\r\nbegin\r\n  fTokenID := tkComment;\r\n  case FLine[Run] of\r\n    #0:\r\n      begin\r\n        NullProc;\r\n        exit;\r\n      end;\r\n    #10:\r\n      begin\r\n        LFProc;\r\n        exit;\r\n      end;\r\n\r\n    #13:\r\n      begin\r\n        CRProc;\r\n        exit;\r\n      end;\r\n  end;\r\n\r\n  while not IsLineEnd(Run) do\r\n    if fLine[Run] = '*' then\r\n    begin\r\n      if fLine[Run + 1] = '/' then\r\n      begin\r\n        fRange := rsUnKnown;\r\n        inc(Run, 2);\r\n        break;\r\n      end\r\n      else inc(Run)\r\n    end\r\n    else\r\n      inc(Run);\r\nend;\r\n\r\nprocedure TSynTclTkSyn.BraceOpenProc;\r\nbegin\r\n  inc(Run);\r\n  fTokenID := tkSymbol;\r\nend;\r\n\r\nprocedure TSynTclTkSyn.PointCommaProc;\r\nbegin\r\n  inc(Run);\r\n  fTokenID := tkSymbol;\r\nend;\r\n\r\nprocedure TSynTclTkSyn.CRProc;\r\nbegin\r\n  fTokenID := tkSpace;\r\n  case FLine[Run + 1] of\r\n    #10: inc(Run, 2);\r\n    else inc(Run);\r\n  end;\r\nend;\r\n\r\nprocedure TSynTclTkSyn.IdentProc;\r\nbegin\r\n  while IsIdentChar(fLine[Run]) do inc(Run);\r\n  if InternalIsKeyword(GetToken, fWidgetWords, True) then\r\n    fTokenId := tkWidgetKey\r\n  else if InternalIsKeyword(GetToken, fTixWords) then\r\n    fTokenId := tkTixKey\r\n  else if InternalIsKeyword(GetToken, fKeyWords) then\r\n    fTokenId := tkKey\r\n  else if InternalIsKeyword(GetToken, fSecondKeys) then\r\n    fTokenId := tkSecondKey\r\n  else\r\n    fTokenId := tkIdentifier;\r\nend;\r\n\r\nprocedure TSynTclTkSyn.LFProc;\r\nbegin\r\n  fTokenID := tkSpace;\r\n  inc(Run);\r\nend;\r\n\r\nprocedure TSynTclTkSyn.NullProc;\r\nbegin\r\n  fTokenID := tkNull;\r\n  inc(Run);\r\nend;\r\n\r\nprocedure TSynTclTkSyn.NumberProc;\r\n\r\n  function IsNumberChar: Boolean;\r\n  begin\r\n    case fLine[Run] of\r\n      '0'..'9', '.', 'e', 'E':\r\n        Result := True;\r\n      else\r\n        Result := False;\r\n    end;\r\n  end;\r\n\r\nbegin\r\n  inc(Run);\r\n  fTokenID := tkNumber;\r\n  while IsNumberChar do\r\n  begin\r\n    case FLine[Run] of\r\n      '.':\r\n        if FLine[Run + 1] = '.' then break;\r\n    end;\r\n    inc(Run);\r\n  end;\r\nend;\r\n\r\nprocedure TSynTclTkSyn.RoundOpenProc;\r\nbegin\r\n  inc(Run);\r\n  fTokenId := tkSymbol;\r\nend;\r\n\r\nprocedure TSynTclTkSyn.SlashProc;\r\nbegin\r\n  if FLine[Run] = '#' then\r\n  begin\r\n    fTokenID := tkComment;\r\n    while not IsLineEnd(Run) do Inc(Run);\r\n  end\r\n  else\r\n  begin\r\n    FTokenID := tkSymbol;\r\n    Inc(Run);\r\n  end;\r\nend;\r\n\r\nprocedure TSynTclTkSyn.SpaceProc;\r\nbegin\r\n  inc(Run);\r\n  fTokenID := tkSpace;\r\n  while (FLine[Run] <= #32) and not IsLineEnd(Run) do inc(Run);\r\nend;\r\n\r\nprocedure TSynTclTkSyn.StringProc;\r\nbegin\r\n  fTokenID := tkString;\r\n  if (FLine[Run + 1] = #34) and (FLine[Run + 2] = #34) then\r\n    inc(Run, 2);\r\n  repeat\r\n    if IsLineEnd(Run) then break;\r\n    inc(Run);\r\n  until (FLine[Run] = #34) and (FLine[Pred(Run)] <> '\\');\r\n  if not IsLineEnd(Run) then inc(Run);\r\nend;\r\n\r\nprocedure TSynTclTkSyn.UnknownProc;\r\nbegin\r\n  inc(Run);\r\n  fTokenID := tkUnKnown;\r\nend;\r\n\r\nprocedure TSynTclTkSyn.Next;\r\nbegin\r\n  fTokenPos := Run;\r\n  case fRange of\r\n    rsAnsi: AnsiProc;\r\n    rsPasStyle: PasStyleProc;\r\n    rsCStyle: CStyleProc;\r\n    else\r\n      case fLine[Run] of\r\n        '-': MinusProc;\r\n        '#': SlashProc;\r\n        '{': BraceOpenProc;\r\n        ';': PointCommaProc;\r\n        #13: CRProc;\r\n        'A'..'Z', 'a'..'z', '_': IdentProc;\r\n        #10: LFProc;\r\n        #0: NullProc;\r\n        '0'..'9':  NumberProc;\r\n        '(': RoundOpenProc;\r\n        '/': SlashProc;\r\n        '[', ']', ')', '}': SymbolProc;\r\n        #1..#9, #11, #12, #14..#32: SpaceProc;\r\n        #34: StringProc;\r\n        '$': VariableProc;\r\n        '.': PathProc;\r\n        else UnknownProc;\r\n      end;\r\n  end;\r\n  inherited;\r\nend;\r\n\r\nfunction TSynTclTkSyn.GetDefaultAttribute(Index: integer): TSynHighlighterAttributes;\r\nbegin\r\n  case Index of\r\n    SYN_ATTR_COMMENT: Result := fCommentAttri;\r\n    SYN_ATTR_IDENTIFIER: Result := fIdentifierAttri;\r\n    SYN_ATTR_KEYWORD: Result := fKeyAttri;\r\n    SYN_ATTR_STRING: Result := fStringAttri;\r\n    SYN_ATTR_WHITESPACE: Result := fSpaceAttri;\r\n    SYN_ATTR_SYMBOL: Result := fSymbolAttri;\r\n  else\r\n    Result := nil;\r\n  end;\r\nend;\r\n\r\nfunction TSynTclTkSyn.GetEol: Boolean;\r\nbegin\r\n  Result := Run = fLineLen + 1;\r\nend;\r\n\r\nfunction TSynTclTkSyn.GetRange: Pointer;\r\nbegin\r\n  Result := Pointer(fRange);\r\nend;\r\n\r\nfunction TSynTclTkSyn.GetTokenID: TtkTokenKind;\r\nbegin\r\n  Result := fTokenId;\r\nend;\r\n\r\nfunction TSynTclTkSyn.GetTokenAttribute: TSynHighlighterAttributes;\r\nbegin\r\n  case fTokenID of\r\n    tkComment: Result := fCommentAttri;\r\n    tkIdentifier: Result := fIdentifierAttri;\r\n    tkKey: Result := fKeyAttri;\r\n    tkSecondKey: Result := fSecondKeyAttri;\r\n    tkTixKey: Result := fTixKeyAttri;\r\n    tkWidgetKey: Result := fWidgetKeyAttri;\r\n    tkNumber: Result := fNumberAttri;\r\n    tkSpace: Result := fSpaceAttri;\r\n    tkString: Result := fStringAttri;\r\n    tkSymbol: Result := fSymbolAttri;\r\n    tkOptions: Result := fOptionsAttri;\r\n    tkVariable: Result := fVariableAttri;\r\n    tkPath: Result := fPathAttri;\r\n    tkUnknown: Result := fSymbolAttri;\r\n  else\r\n    Result := nil;\r\n  end;\r\nend;\r\n\r\nfunction TSynTclTkSyn.GetTokenKind: integer;\r\nbegin\r\n  Result := Ord(fTokenId);\r\nend;\r\n\r\nprocedure TSynTclTkSyn.ResetRange;\r\nbegin\r\n  fRange := rsUnknown;\r\nend;\r\n\r\nprocedure TSynTclTkSyn.SetRange(Value: Pointer);\r\nbegin\r\n  fRange := TRangeState(Value);\r\nend;\r\n\r\nprocedure TSynTclTkSyn.SetKeyWords(const Value: TUnicodeStrings);\r\nvar\r\n  i: Integer;\r\nbegin\r\n  if Value <> nil then\r\n    begin\r\n      Value.BeginUpdate;\r\n      for i := 0 to Value.Count - 1 do\r\n        Value[i] := SynWideUpperCase(Value[i]);\r\n      Value.EndUpdate;\r\n    end;\r\n  fKeyWords.Assign(Value);\r\n  DefHighLightChange(nil);\r\nend;\r\n\r\nprocedure TSynTclTkSyn.SetSecondKeys(const Value: TUnicodeStrings);\r\nvar\r\n  i: Integer;\r\nbegin\r\n  if Value <> nil then\r\n    begin\r\n      Value.BeginUpdate;\r\n      for i := 0 to Value.Count - 1 do\r\n        Value[i] := SynWideUpperCase(Value[i]);\r\n      Value.EndUpdate;\r\n    end;\r\n  fSecondKeys.Assign(Value);\r\n  DefHighLightChange(nil);\r\nend;\r\n\r\nfunction TSynTclTkSyn.IsFilterStored: Boolean;\r\nbegin\r\n  Result := fDefaultFilter <> SYNS_FilterTclTk;\r\nend;\r\n\r\nclass function TSynTclTkSyn.GetLanguageName: string;\r\nbegin\r\n  Result := SYNS_LangTclTk;\r\nend;\r\n\r\n{$IFNDEF SYN_CLX}\r\nfunction TSynTclTkSyn.LoadFromRegistry(RootKey: HKEY; Key: string): Boolean;\r\nvar\r\n  r: TBetterRegistry;\r\nbegin\r\n  r := TBetterRegistry.Create;\r\n  try\r\n    r.RootKey := RootKey;\r\n    if r.OpenKeyReadOnly(Key) then\r\n    begin\r\n      if r.ValueExists('KeyWords') then KeyWords.Text := r.ReadString('KeyWords');\r\n      Result := inherited LoadFromRegistry(RootKey, Key);\r\n    end\r\n    else\r\n      Result := False;\r\n  finally\r\n    r.Free;\r\n  end;\r\nend;\r\n\r\nfunction TSynTclTkSyn.SaveToRegistry(RootKey: HKEY; Key: string): boolean;     \r\nvar\r\n  r: TBetterRegistry;\r\nbegin\r\n  r:= TBetterRegistry.Create;\r\n  try\r\n    r.RootKey := RootKey;\r\n    if r.OpenKey(Key,true) then begin\r\n      Result := true;\r\n      r.WriteString('KeyWords', KeyWords.Text);\r\n      Result := inherited SaveToRegistry(RootKey, Key);\r\n    end\r\n    else Result := false;\r\n  finally r.Free; end;\r\nend;\r\n{$ENDIF}\r\n\r\nfunction TSynTclTkSyn.IsKeywordListStored: Boolean;\r\nvar\r\n  Keys: TUnicodeStringList;\r\n  DefKey: Integer;\r\n  Index: Integer;\r\nbegin\r\n  Keys := TUnicodeStringList.Create;\r\n  try\r\n    Keys.Assign(KeyWords);\r\n    Index := 0;\r\n    for DefKey := Low(TclTkKeys) to High(TclTkKeys) do\r\n    begin\r\n      if not Keys.Find(TclTkKeys[DefKey], Index) then\r\n      begin\r\n        Result := True;\r\n        Exit;\r\n      end;\r\n      Keys.Delete(Index);\r\n    end;\r\n    Result := Keys.Count <> 0;\r\n  finally\r\n    Keys.Free;\r\n  end;\r\nend;\r\n\r\nfunction TSynTclTkSyn.GetSampleSource: UnicodeString;\r\nbegin\r\n  Result :=\r\n    '#!/usr/local/tclsh8.0'#13#10 +\r\n    'if {$argc < 2} {'#13#10 +\r\n    '\tputs stderr \"Usage: $argv0 parameter\"'#13#10 +\r\n    '\texit 1'#13#10 +\r\n    '}';\r\nend;\r\n\r\nclass function TSynTclTkSyn.GetFriendlyLanguageName: UnicodeString;\r\nbegin\r\n  Result := SYNS_FriendlyLangTclTk;\r\nend;\r\n\r\nprocedure TSynTclTkSyn.MinusProc;\r\nconst\r\n  EmptyChars = [' ', #9, #0, #10, #13];\r\nvar\r\n  OK: Boolean;\r\nbegin\r\n  OK := False;\r\n  Inc(Run);\r\n  { minus like symbol }\r\n  if CharInSet(fLine[Run], ['0'..'9']) then\r\n    FTokenID := tkSymbol\r\n  else\r\n  { special option -- }\r\n  if (fLine[Run] = '-') and CharInSet(fLine[Run + 1], EmptyChars) then\r\n  begin\r\n    OK := True;\r\n    Inc(Run);\r\n  end\r\n  { normal options -options }\r\n  else begin\r\n    if CharInSet(fLine[Run], ['a'..'z', 'A'..'Z']) then\r\n    begin\r\n      Inc(Run);\r\n      while CharInSet(FLine[Run], ['a'..'z', 'A'..'Z']) do\r\n        Inc(Run);\r\n      OK := CharInSet(fLine[Run], EmptyChars);\r\n    end\r\n    { bad option syntax }\r\n    else\r\n      while not CharInSet(FLine[Run], EmptyChars) do\r\n        Inc(Run);\r\n  end;\r\n  if OK then\r\n    FTokenID := tkOptions\r\n  else\r\n    FTokenID := tkUnknown;\r\nend;\r\n\r\nprocedure TSynTclTkSyn.PathProc;\r\nbegin\r\n  if CharInSet(FLine[Run + 1], ['a'..'z', 'A'..'Z']) then\r\n  begin\r\n    fTokenID := tkPath;\r\n    Inc(Run);\r\n    while CharInSet(FLine[Run], ['a'..'z', 'A'..'Z', '0'..'9']) do Inc(Run);\r\n  end\r\n  else\r\n  begin\r\n    FTokenID := tkSymbol;\r\n    Inc(Run);\r\n  end;\r\nend;\r\n\r\nprocedure TSynTclTkSyn.VariableProc;\r\nbegin\r\n  fTokenId := tkVariable;\r\n  Inc(Run);\r\n  while CharInSet(FLine[Run], ['_', '0'..'9', 'A'..'Z', 'a'..'z']) do Inc(Run);\r\nend;\r\n\r\nfunction TSynTclTkSyn.IsSecondKeywordListStored: Boolean;\r\nvar\r\n  Keys: TUnicodeStringList;\r\n  DefKey: Integer;\r\n  Index: Integer;\r\nbegin\r\n  Keys := TUnicodeStringList.Create;\r\n  try\r\n    Keys.Assign(SecondKeyWords);\r\n    Index := 0;\r\n    for DefKey := Low(SecondTclTkKeys) to High(SecondTclTkKeys) do\r\n    begin\r\n      if not Keys.Find(SecondTclTkKeys[DefKey], Index) then\r\n      begin\r\n        Result := True;\r\n        Exit;\r\n      end;\r\n      Keys.Delete(Index);\r\n    end;\r\n    Result := Keys.Count <> 0;\r\n  finally\r\n    Keys.Free;\r\n  end;\r\nend;\r\n\r\nprocedure TSynTclTkSyn.SymbolProc;\r\nbegin\r\n  FTokenID := tkSymbol;\r\n  Inc(Run);\r\nend;\r\n\r\ninitialization\r\n{$IFNDEF SYN_CPPB_1}\r\n  RegisterPlaceableHighlighter(TSynTclTkSyn);\r\n{$ENDIF}\r\nend.\r\n"
  },
  {
    "path": "External/SynEdit/Source/SynHighlighterTeX.pas",
    "content": "{------------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: SynHighlighterTex.pas, released 2002-09-18.\r\nAuthor of this file is Soeren Sproessig.\r\nUnicode translation by Mal Hrz.\r\nAll Rights Reserved.\r\n\r\nContributors to the SynEdit and mwEdit projects are listed in the\r\nContributors.txt file.\r\n\r\nAlternatively, the contents of this file may be used under the terms of the\r\nGNU General Public License Version 2 or later (the \"GPL\"), in which case\r\nthe provisions of the GPL are applicable instead of those above.\r\nIf you wish to allow use of your version of this file only under the terms\r\nof the GPL and not to allow others to use your version of this file\r\nunder the MPL, indicate your decision by deleting the provisions above and\r\nreplace them with the notice and other provisions required by the GPL.\r\nIf you do not delete the provisions above, a recipient may use your version\r\nof this file under either the MPL or the GPL.\r\n\r\n$Id: SynHighlighterTeX.pas,v 1.5.2.5 2008/09/14 16:25:03 maelh Exp $\r\n\r\nYou may retrieve the latest version of this file from sproessig@bs-webdesign.de\r\n\r\nThe unit SynHighlighterTeX provides SynEdit with a TeX highlighter.\r\n\r\nKnown Issues:\r\n-------------------------------------------------------------------------------}\r\n\r\n{$IFNDEF QSYNHIGHLIGHTERTEX}\r\nunit SynHighlighterTeX;\r\n{$ENDIF}\r\n\r\n{$I SynEdit.inc}\r\n\r\ninterface\r\n\r\nuses\r\n{$IFDEF SYN_CLX}\r\n  QGraphics,\r\n  QSynEditTypes,\r\n  QSynEditHighlighter,\r\n  QSynUnicode,\r\n{$ELSE}\r\n  Graphics,\r\n  SynEditTypes,\r\n  SynEditHighlighter,\r\n  SynUnicode,\r\n{$ENDIF}\r\n  Classes;\r\n\r\ntype\r\n  TtkTokenKind = (tkBrace, tkBracket, tkNull, tkSpace, tkText, tkComment,\r\n                  tkControlSequence, tkMathMode);\r\n\r\ntype\r\n  TSynTeXSyn = class(TSynCustomHighlighter)\r\n  private\r\n    fTokenID: TtkTokenKind;\r\n    fTextAttri: TSynHighlighterAttributes;\r\n    fControlSequenceAttri: TSynHighlighterAttributes;\r\n    fMathmodeAttri: TSynHighlighterAttributes;\r\n    fCommentAttri: TSynHighlighterAttributes;\r\n    fSpaceAttri: TSynHighlighterAttributes;\r\n    fBracketAttri: TSynHighlighterAttributes;\r\n    fBraceAttri: TSynHighlighterAttributes;\r\n\r\n    function CreateHighlighterAttributes(Name: string; FriendlyName: UnicodeString;\r\n      Foreground, Background: TColor; FontStyles: TFontStyles): TSynHighlighterAttributes;\r\n    procedure CRProc;\r\n    procedure TextProc;\r\n    procedure LFProc;\r\n    procedure NullProc;\r\n    procedure CommentProc;\r\n    procedure SpaceProc;\r\n    procedure ControlSequenceProc;\r\n    procedure BraceOpenProc;\r\n    procedure BraceCloseProc;\r\n    procedure BracketOpenProc;\r\n    procedure BracketCloseProc;\r\n    procedure MathmodeProc;\r\n  protected\r\n    function GetSampleSource: UnicodeString; override;\r\n    function IsFilterStored: Boolean; override;\r\n  public\r\n    class function GetLanguageName: string; override;\r\n    class function GetFriendlyLanguageName: UnicodeString; override;    \r\n  public\r\n    constructor Create(AOwner: TComponent); override;\r\n    function GetDefaultAttribute(Index: integer): TSynHighlighterAttributes;\r\n      override;\r\n    function GetEol: Boolean; override;\r\n    function GetTokenID: TtkTokenKind;\r\n    function GetTokenAttribute: TSynHighlighterAttributes; override;\r\n    function GetTokenKind: integer; override;\r\n    procedure Next; override;\r\n  published\r\n    property CommentAttri : TSynHighlighterAttributes read fCommentAttri\r\n      write fCommentAttri;\r\n    property TextAttri: TSynHighlighterAttributes read fTextAttri\r\n      write fTextAttri;\r\n    property ControlSequenceAttri: TSynHighlighterAttributes read\r\nfControlSequenceAttri\r\n      write fControlSequenceAttri;\r\n    property MathmodeAttri: TSynHighlighterAttributes read fMathmodeAttri\r\n      write fMathmodeAttri;\r\n    property SpaceAttri: TSynHighlighterAttributes read fSpaceAttri\r\n      write fSpaceAttri;\r\n    property BraceAttri: TSynHighlighterAttributes read fBraceAttri\r\n      write fBraceAttri;\r\n    property BracketAttri: TSynHighlighterAttributes read fBracketAttri\r\n      write fBracketAttri;\r\n  end;\r\n\r\nimplementation\r\n\r\nuses\r\n{$IFDEF SYN_CLX}\r\n  QSynEditStrConst;\r\n{$ELSE}\r\n  SynEditStrConst;\r\n{$ENDIF}\r\n\r\nconstructor TSynTeXSyn.Create(AOwner: TComponent);\r\nbegin\r\n  inherited Create(AOwner);\r\n\r\n  fCommentAttri := CreateHighlighterAttributes(SYNS_AttrComment, SYNS_FriendlyAttrComment, clTeal, clNone, []);\r\n  AddAttribute(fCommentAttri);\r\n\r\n  fTextAttri := CreateHighlighterAttributes(SYNS_AttrText, SYNS_FriendlyAttrText, clBlack, clNone, []);\r\n  AddAttribute(fTextAttri);\r\n\r\n  fMathmodeAttri := CreateHighlighterAttributes(SYNS_AttrMathmode, SYNS_FriendlyAttrMathmode, clOlive, clNone,\r\n    [fsbold]);\r\n  AddAttribute(fMathmodeAttri);\r\n\r\n  fSpaceAttri := CreateHighlighterAttributes(SYNS_AttrSpace, SYNS_FriendlyAttrSpace, clNone, clWhite, []);\r\n  AddAttribute(fSpaceAttri);\r\n\r\n  fControlSequenceAttri := CreateHighlighterAttributes(SYNS_AttrTexCommand, SYNS_FriendlyAttrTexCommand, clBlue,\r\n    clWhite, [fsBold]);\r\n  AddAttribute(fControlSequenceAttri);\r\n\r\n  fBracketAttri := CreateHighlighterAttributes(SYNS_AttrSquareBracket, SYNS_FriendlyAttrSquareBracket, clPurple,\r\n    clNone, []);\r\n  AddAttribute(fBracketAttri);\r\n\r\n  fBraceAttri:= CreateHighlighterAttributes(SYNS_AttrRoundBracket, SYNS_FriendlyAttrRoundBracket, clRed,\r\n    clNone, [fsBold]);\r\n  AddAttribute(fBraceAttri);\r\n\r\n  SetAttributesOnChange(DefHighlightChange);\r\n  fDefaultFilter := SYNS_FilterTeX;\r\nend;  { Create }\r\n\r\nprocedure TSynTeXSyn.CRProc;\r\nbegin\r\n  fTokenID := tkSpace;\r\n  case FLine[Run + 1] of\r\n    #10: inc(Run, 2);\r\n    else inc(Run);\r\n  end;\r\nend;  { CRProc }\r\n\r\n\r\nprocedure TSynTeXSyn.SpaceProc;\r\nbegin\r\n  fTokenID := tkSpace;\r\n  inc(Run);\r\n  while (FLine[Run] <= #32) and not IsLineEnd(Run) do inc(Run);\r\nend;  { SpaceProc }\r\n\r\nprocedure TSynTeXSyn.TextProc;\r\nbegin\r\n  fTokenID := tkText;\r\n  inc(Run);\r\nend;  { TextProc }\r\n\r\nprocedure TSynTeXSyn.LFProc;\r\nbegin\r\n  fTokenID := tkSpace;\r\n  inc(Run);\r\nend;  { SpaceProc }\r\n\r\nprocedure TSynTeXSyn.BraceOpenProc;\r\nbegin\r\n  fTokenID := tkBrace;\r\n  inc(Run);\r\nend;  { BraceOpen }\r\n\r\nprocedure TSynTeXSyn.BraceCloseProc;\r\nbegin\r\n  fTokenID := tkBrace;\r\n  inc(Run);\r\nend;  { BraceClose }\r\n\r\nprocedure TSynTeXSyn.BracketOpenProc;\r\nbegin\r\n  fTokenID := tkBracket;\r\n  inc(Run);\r\nend;  { BracketOpen }\r\n\r\nprocedure TSynTeXSyn.BracketCloseProc;\r\nbegin\r\n  fTokenID := tkBracket;\r\n  inc(Run);\r\nend;  { BracketClose }\r\n\r\nprocedure TSynTeXSyn.NullProc;\r\nbegin\r\n  fTokenID := tkNull;\r\n  inc(Run);\r\nend;  { NullProc }\r\n\r\nprocedure TSynTeXSyn.CommentProc;\r\nbegin\r\n fTokenID := tkComment;\r\n repeat\r\n    case fLine[Run] of\r\n      #0, #10: Break;\r\n    end;\r\n    inc(Run);\r\n  until fLine[Run] = #13;\r\n  Exit;\r\nend;  { CommentProc }\r\n\r\nprocedure TSynTeXSyn.MathModeProc;\r\nbegin\r\n fTokenID := tkMathMode;\r\n Inc(Run);\r\nend;  { MathModeProc }\r\n\r\nprocedure TSynTeXSyn.ControlSequenceProc;\r\nbegin\r\n fTokenID := tkControlSequence;\r\n repeat\r\n   case fLine[Run] of\r\n     #0..#31: Break;  //No Control Chars !\r\n     #48..#57: Break;  //No Numbers !\r\n     #33..#47, #58..#64,               //Just the Characters that\r\n     #91, #93,#94, #123,              //only can follow to '\\'\r\n     #125, #126:\r\n       begin\r\n         if (fLine[Run-1]='\\') then\r\n           Inc(Run,1);\r\n         Break;\r\n       end;\r\n   end;\r\n   Inc(Run);\r\n until fLine[Run] = #32;\r\n exit;\r\nend;  { ControlSequenceProc }\r\n\r\nprocedure TSynTeXSyn.Next;\r\nbegin\r\n  fTokenPos := Run;\r\n  case  fLine[Run] of\r\n    #0: NullProc;\r\n    #10: LFProc;\r\n    #13: CRProc;\r\n    #37: CommentProc;\r\n    #92: ControlSequenceProc;\r\n    #123: BraceOpenProc;\r\n    #125: BraceCloseProc;\r\n    #91: BracketOpenProc;\r\n    #93: BracketCloseProc;\r\n    #1..#9, #11, #12, #14..#32: SpaceProc;\r\n    #36: MathmodeProc;\r\n    else TextProc;\r\n  end;\r\n  inherited;\r\nend;  { Next }\r\n\r\nfunction TSynTeXSyn.GetDefaultAttribute(Index: integer):\r\n  TSynHighlighterAttributes;\r\nbegin\r\n  case Index of\r\n    SYN_ATTR_COMMENT: Result := fCommentAttri;\r\n    SYN_ATTR_WHITESPACE: Result := fSpaceAttri;\r\n    else Result := nil;\r\n  end;\r\nend;\r\n\r\nfunction TSynTeXSyn.GetEol: Boolean;\r\nbegin\r\n  Result := Run = fLineLen + 1;\r\nend;  { GetDefaultAttribute }\r\n\r\nfunction TSynTeXSyn.GetTokenID: TtkTokenKind;\r\nbegin\r\n  Result := fTokenId;\r\nend;  { GetTokenID }\r\n\r\nfunction TSynTeXSyn.GetTokenAttribute: TSynHighlighterAttributes;\r\nbegin\r\n  case fTokenID of\r\n    tkComment: Result := fCommentAttri;\r\n    tkText: Result := fTextAttri;\r\n    tkControlSequence: Result := fControlSequenceAttri;\r\n    tkMathMode: Result := fMathmodeAttri;\r\n    tkSpace: Result := fSpaceAttri;\r\n    tkBrace: Result := fBraceAttri;\r\n    tkBracket: Result := fBracketAttri;\r\n  else\r\n    Result := nil;\r\n  end;\r\nend;  { GetTokenAttribute }\r\n\r\nfunction TSynTeXSyn.GetTokenKind: integer;\r\nbegin\r\n  Result := Ord(fTokenId);\r\nend;  { GetTokenKind }\r\n\r\nfunction TSynTeXSyn.IsFilterStored: Boolean;\r\nbegin\r\n  Result := fDefaultFilter <> SYNS_FilterTeX;\r\nend;\r\n\r\nclass function TSynTeXSyn.GetLanguageName: string;\r\nbegin\r\n  Result := SYNS_LangTeX;\r\nend;  { GetLanguageName }\r\n\r\nfunction TSynTeXSyn.CreateHighlighterAttributes(Name: string; FriendlyName: UnicodeString;\r\n  Foreground, Background: TColor; FontStyles: TFontStyles): TSynHighlighterAttributes;\r\nbegin\r\n  Result := TSynHighlighterAttributes.Create(Name, FriendlyName);\r\n  if Foreground <> clNone then Result.Foreground := Foreground;\r\n  if Background <> clNone then Result.Background := Background;\r\n  Result.Style := FontStyles;\r\nend;\r\n\r\nfunction TSynTeXSyn.GetSampleSource: UnicodeString;\r\nbegin\r\n  Result:='\\documentclass[a4paper]{article}'+#13#10+\r\n          '% LaTeX sample source'+#13#10+\r\n          '\\begin{document}'+#13#10+\r\n          'Here is a formula: $ (2x + 3)*5y $'+#13#10+\r\n          '\\end{document}';\r\nend;\r\n\r\n{$IFNDEF SYN_CPPB_1}\r\nclass function TSynTeXSyn.GetFriendlyLanguageName: UnicodeString;\r\nbegin\r\n  Result := SYNS_FriendlyLangTeX;\r\nend;\r\n\r\ninitialization\r\n  RegisterPlaceableHighlighter(TSynTeXSyn);\r\n{$ENDIF}\r\nend.\r\n"
  },
  {
    "path": "External/SynEdit/Source/SynHighlighterUNIXShellScript.pas",
    "content": "{-------------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: SynHighlighterUNIXShellScript.pas, released 2001-11-13.\r\nThe Initial Author of this file is Stefan Ascher.\r\nPortions by Jan Verhoeven (http://jansfreeware.com/jfdelphi.htm)\r\n\"Heredoc\" syntax highlighting implementation by Marko Njezic.\r\nUnicode translation by Mal Hrz.\r\nAll Rights Reserved.\r\n\r\nContributors to the SynEdit and mwEdit projects are listed in the\r\nContributors.txt file.\r\n\r\nAlternatively, the contents of this file may be used under the terms of the\r\nGNU General Public License Version 2 or later (the \"GPL\"), in which case\r\nthe provisions of the GPL are applicable instead of those above.\r\nIf you wish to allow use of your version of this file only under the terms\r\nof the GPL and not to allow others to use your version of this file\r\nunder the MPL, indicate your decision by deleting the provisions above and\r\nreplace them with the notice and other provisions required by the GPL.\r\nIf you do not delete the provisions above, a recipient may use your version\r\nof this file under either the MPL or the GPL.\r\n\r\n$Id: SynHighlighterUNIXShellScript.pas,v 1.7.2.11 2008/09/14 16:25:03 maelh Exp $\r\n\r\nYou may retrieve the latest version of this file at the SynEdit home page,\r\nlocated at http://SynEdit.SourceForge.net\r\n\r\nKnown Issues:\r\n-------------------------------------------------------------------------------}\r\n{\r\n@abstract(Provides a UNIX Shell Script highlighter for SynEdit)\r\n@author(Stefan Ascher )\r\n@created(10 November 2001)\r\n@lastmod(2001-11-13)\r\nThe SynHighlighterUNIXShellScript unit provides SynEdit with a UNIX Shell Script highlighter.\r\n}\r\n\r\n{$IFNDEF QSYNHIGHLIGHTERUNIXSHELLSCRIPT}\r\nunit SynHighlighterUNIXShellScript;\r\n{$ENDIF}\r\n\r\n{$I SynEdit.inc}\r\n\r\ninterface\r\n\r\nuses\r\n{$IFDEF SYN_CLX}\r\n  QGraphics,\r\n  QSynEditTypes,\r\n  QSynEditHighlighter,\r\n  QSynUnicode,\r\n{$ELSE}\r\n  Graphics,\r\n  SynEditTypes,\r\n  SynEditHighlighter,\r\n  SynUnicode,\r\n{$ENDIF}\r\n  SysUtils,\r\n  Classes;\r\n\r\ntype\r\n  TtkTokenKind = (tkComment, tkIdentifier, tkKey, tkNull, tkNumber, tkSecondKey,\r\n    tkSpace, tkString, tkSymbol, tkVariable, tkUnknown);\r\n\r\n{$IFDEF SYN_HEREDOC}\r\n  TRangeState = (rsUnknown, rsHeredoc, rsIndentedHeredoc);\r\n\r\n  TRangePointer = packed record\r\n    case Boolean of\r\n      True: (Ptr: Pointer);\r\n      False: (Range: Byte; Length: Byte; Checksum: Word);\r\n    end;\r\n{$ELSE}\r\n  TRangeState = (rsUnknown);\r\n{$ENDIF}\r\n\r\ntype\r\n  TSynUNIXShellScriptSyn = class(TSynCustomHighlighter)\r\n  private\r\n    fRange: TRangeState;\r\n{$IFDEF SYN_HEREDOC}\r\n    fHeredocLength: Byte;\r\n    fHeredocChecksum: Word;\r\n{$ENDIF}\r\n    FTokenID: TtkTokenKind;\r\n    fStringAttri: TSynHighlighterAttributes;\r\n    fSymbolAttri: TSynHighlighterAttributes;\r\n    fKeyAttri: TSynHighlighterAttributes;\r\n    fSecondKeyAttri: TSynHighlighterAttributes;\r\n    fNumberAttri: TSynHighlighterAttributes;\r\n    fCommentAttri: TSynHighlighterAttributes;\r\n    fSpaceAttri: TSynHighlighterAttributes;\r\n    fIdentifierAttri: TSynHighlighterAttributes;\r\n    fVarAttri: TSynHighlighterAttributes;\r\n    procedure BraceOpenProc;\r\n    procedure PointCommaProc;\r\n    procedure CRProc;\r\n    procedure IdentProc;\r\n    procedure LFProc;\r\n    procedure LowerProc;\r\n    procedure NullProc;\r\n    procedure NumberProc;\r\n    procedure RoundOpenProc;\r\n    procedure SlashProc;\r\n    procedure SpaceProc;\r\n    procedure SymbolProc;\r\n    procedure StringProc;\r\n    procedure UnknownProc;\r\n    procedure DollarProc;\r\n    procedure DotProc;\r\n{$IFDEF SYN_HEREDOC}\r\n    procedure HeredocProc;\r\n{$ENDIF}\r\n  protected\r\n    function GetSampleSource: UnicodeString; override;\r\n    function IsFilterStored: Boolean; override;\r\n    procedure NextProcedure;\r\n  public\r\n    class function GetLanguageName: string; override;\r\n    class function GetFriendlyLanguageName: UnicodeString; override;\r\n  public\r\n    constructor Create(AOwner: TComponent); override;\r\n    destructor Destroy; override;\r\n    function GetDefaultAttribute(Index: integer): TSynHighlighterAttributes;\r\n      override;\r\n    function GetEol: Boolean; override;\r\n    function GetRange: Pointer; override;\r\n    function GetTokenID: TtkTokenKind;\r\n    function IsKeyword(const AKeyword: UnicodeString): Boolean; override;\r\n    function IsSecondKeyWord(AToken: UnicodeString): Boolean;\r\n    function GetTokenAttribute: TSynHighlighterAttributes; override;\r\n    function GetTokenKind: Integer; override;\r\n    procedure Next; override;\r\n    procedure SetRange(Value: Pointer); override;\r\n    procedure ResetRange; override;\r\n  published\r\n    property CommentAttri: TSynHighlighterAttributes read fCommentAttri\r\n      write fCommentAttri;\r\n    property IdentifierAttri: TSynHighlighterAttributes read fIdentifierAttri\r\n      write fIdentifierAttri;\r\n    property KeyAttri: TSynHighlighterAttributes read fKeyAttri write fKeyAttri;\r\n    property SecondKeyAttri: TSynHighlighterAttributes read fSecondKeyAttri\r\n      write fSecondKeyAttri;\r\n    property NumberAttri: TSynHighlighterAttributes read fNumberAttri\r\n      write fNumberAttri;\r\n    property SpaceAttri: TSynHighlighterAttributes read fSpaceAttri\r\n      write fSpaceAttri;\r\n    property StringAttri: TSynHighlighterAttributes read fStringAttri\r\n      write fStringAttri;\r\n    property SymbolAttri: TSynHighlighterAttributes read fSymbolAttri\r\n      write fSymbolAttri;\r\n    property VarAttri: TSynHighlighterAttributes read fVarAttri\r\n      write fVarAttri;\r\n  end;\r\n\r\nimplementation\r\n\r\nuses\r\n{$IFDEF SYN_CLX}\r\n  QSynEditMiscProcs,\r\n  QSynEditStrConst;\r\n{$ELSE}\r\n  SynEditMiscProcs,\r\n  SynEditStrConst;\r\n{$ENDIF}\r\n\r\nconst\r\n  ShellScriptKeys: array[0..109] of UnicodeString = (\r\n    'awk', 'banner', 'basename', 'bdiff', 'bg', 'break', 'case', 'cat', 'cc',\r\n    'cd', 'chdir', 'chgrp', 'chmod', 'chown', 'clear', 'compress', 'continue',\r\n    'cp', 'cpio', 'cut', 'date', 'dd', 'df', 'diff', 'do', 'done', 'dtpad',\r\n    'echo', 'elif', 'else', 'esac', 'eval', 'exit', 'export', 'expr', 'fg',\r\n    'fi', 'finger', 'fold', 'for', 'ftp', 'g++', 'gcc', 'getopts', 'grep',\r\n    'gzip', 'hash', 'head', 'if', 'in', 'jobs', 'kill', 'ld', 'ln', 'login',\r\n    'ls', 'make', 'mkdir', 'mt', 'mv', 'newgrp', 'nohup', 'od', 'paste', 'perl',\r\n    'pg', 'ping', 'pr', 'ps', 'pwd', 'rcp', 'read', 'remsh', 'return', 'rm',\r\n    'rsh', 'rwho', 'sed', 'set', 'sh', 'shift', 'stop', 'strings', 'strip',\r\n    'sync', 'tail', 'tar', 'telnet', 'test', 'then', 'times', 'tput', 'trap',\r\n    'true', 'tty', 'type', 'ulimit', 'umask', 'unset', 'until', 'uudecode',\r\n    'uuencode', 'vi', 'wait', 'wc', 'while', 'who', 'xtern', 'zcat', 'zip'\r\n  );\r\n\r\n  ShellScriptSecondKeys: array[0..22] of UnicodeString = (\r\n    'cdpath', 'editor', 'home', 'ifs', 'lang', 'lc_messages', 'lc_type',\r\n    'ld_library_path', 'logname', 'mail', 'mailcheck', 'mailpath', 'manpath',\r\n    'path', 'ps1', 'ps2', 'pwd', 'shacct', 'shell', 'shlib_path', 'term',\r\n    'termcap', 'tz'\r\n  );\r\n\r\nfunction TSynUNIXShellScriptSyn.IsKeyword(const AKeyword: UnicodeString): Boolean;\r\nvar\r\n  First, Last, I, Compare: Integer;\r\n  Token: UnicodeString;\r\nbegin\r\n  First := 0;\r\n  Last := High(ShellScriptKeys);\r\n  Result := False;\r\n  Token := SynWideLowerCase(AKeyword);\r\n\r\n  while First <= Last do\r\n  begin\r\n    I := (First + Last) shr 1;\r\n    Compare := WideCompareStr(ShellScriptKeys[I], Token);\r\n    if Compare = 0 then\r\n    begin\r\n      Result := True;\r\n      break;\r\n    end\r\n    else\r\n      if Compare < 0 then First := I + 1 else Last := I - 1;\r\n  end;\r\nend; { IsKeyWord }\r\n\r\nfunction TSynUNIXShellScriptSyn.IsSecondKeyWord(AToken: UnicodeString): Boolean;\r\nvar\r\n  First, Last, I, Compare: Integer;\r\n  Token: UnicodeString;\r\nbegin\r\n  First := 0;\r\n  Last := High(ShellScriptSecondKeys);\r\n  Result := False;\r\n  Token := SynWideLowerCase(AToken);\r\n  while First <= Last do\r\n  begin\r\n    I := (First + Last) shr 1;\r\n    Compare := WideCompareStr(ShellScriptSecondKeys[i], Token);\r\n    if Compare = 0 then\r\n    begin\r\n      Result := True;\r\n      break;\r\n    end\r\n    else\r\n      if Compare < 0 then First := I + 1 else Last := I - 1;\r\n  end;\r\nend; { IsSecondKeyWord }\r\n\r\nconstructor TSynUNIXShellScriptSyn.Create(AOwner: TComponent);\r\nbegin\r\n  inherited Create(AOwner);\r\n  fCaseSensitive := False;\r\n  fCommentAttri := TSynHighlighterAttributes.Create(SYNS_AttrComment, SYNS_FriendlyAttrComment);\r\n  fCommentAttri.Foreground := clGreen;\r\n  AddAttribute(fCommentAttri);\r\n  fIdentifierAttri := TSynHighlighterAttributes.Create(SYNS_AttrIdentifier, SYNS_FriendlyAttrIdentifier);\r\n  AddAttribute(fIdentifierAttri);\r\n  fKeyAttri := TSynHighlighterAttributes.Create(SYNS_AttrReservedWord, SYNS_FriendlyAttrReservedWord);\r\n  fKeyAttri.Foreground := clNavy;\r\n  fKeyAttri.Style := [fsBold];\r\n  AddAttribute(fKeyAttri);\r\n  fSecondKeyAttri := TSynHighlighterAttributes.Create(SYNS_AttrSecondReservedWord, SYNS_FriendlyAttrSecondReservedWord);\r\n  AddAttribute(fSecondKeyAttri);\r\n  fNumberAttri := TSynHighlighterAttributes.Create(SYNS_AttrNumber, SYNS_FriendlyAttrNumber);\r\n  fNumberAttri.Foreground := clBlue;\r\n  AddAttribute(fNumberAttri);\r\n  fSpaceAttri := TSynHighlighterAttributes.Create(SYNS_AttrSpace, SYNS_FriendlyAttrSpace);\r\n  AddAttribute(fSpaceAttri);\r\n  fStringAttri := TSynHighlighterAttributes.Create(SYNS_AttrString, SYNS_FriendlyAttrString);\r\n  fStringAttri.Foreground := clMaroon;\r\n  AddAttribute(fStringAttri);\r\n  fSymbolAttri := TSynHighlighterAttributes.Create(SYNS_AttrSymbol, SYNS_FriendlyAttrSymbol);\r\n  fSymbolAttri.Foreground := clRed;\r\n  AddAttribute(fSymbolAttri);\r\n  fVarAttri := TSynHighlighterAttributes.Create(SYNS_AttrVariable, SYNS_FriendlyAttrVariable);\r\n  fVarAttri.Foreground := clPurple;\r\n  AddAttribute(fVarAttri);\r\n  SetAttributesOnChange(DefHighlightChange);\r\n\r\n  fRange := rsUnknown;\r\n  fDefaultFilter := SYNS_FilterUNIXShellScript;\r\nend; { Create }\r\n\r\ndestructor TSynUNIXShellScriptSyn.Destroy;\r\nbegin\r\n  inherited Destroy;\r\nend; { Destroy }\r\n\r\nprocedure TSynUNIXShellScriptSyn.DollarProc;\r\nvar\r\n  cc: WideChar;\r\nbegin\r\n  inc(Run);\r\n  fTokenID := tkVariable;\r\n  if IsLineEnd(Run) then Exit;\r\n  cc := FLine[Run];\r\n  inc(Run);\r\n  if (cc = '{') then\r\n  begin\r\n    // ${var}\r\n    while IsIdentChar(FLine[Run]) do\r\n    begin\r\n      if IsLineEnd(Run) then break;\r\n      inc(Run);\r\n    end;\r\n    if FLine[Run] = '}' then Inc(Run);\r\n  end\r\n  else\r\n    // $var\r\n    while IsIdentChar(FLine[Run]) do\r\n      inc(Run);\r\nend;\r\n\r\nprocedure TSynUNIXShellScriptSyn.DotProc;\r\n\r\n  function TestDot: Boolean;\r\n  var\r\n    i: Integer;\r\n  begin\r\n    result := False;\r\n    i := Run;\r\n    inc(i);\r\n    while CharInSet(FLine[i], ['a'..'z', 'A'..'Z']) do\r\n      inc(i);\r\n    if i > (Run + 1) then\r\n      Result := True;\r\n    if Result then\r\n      Run := i;\r\n  end;\r\n  \r\nbegin\r\n  // Don't highlight filenames like filename.zip\r\n  if TestDot then\r\n    fTokenID := tkIdentifier\r\n  else\r\n  begin\r\n    inc(Run);\r\n    fTokenID := tkSymbol;\r\n  end;\r\nend;\r\n\r\nprocedure TSynUNIXShellScriptSyn.BraceOpenProc;\r\nbegin\r\n  inc(Run);\r\n  fTokenID := tkSymbol;\r\nend;\r\n\r\nprocedure TSynUNIXShellScriptSyn.PointCommaProc;\r\nbegin\r\n  inc(Run);\r\n  fTokenID := tkSymbol;\r\nend;\r\n\r\nprocedure TSynUNIXShellScriptSyn.CRProc;\r\nbegin\r\n  fTokenID := tkSpace;\r\n  case FLine[Run + 1] of\r\n    #10: inc(Run, 2);\r\n    else inc(Run);\r\n  end;\r\nend;\r\n\r\nprocedure TSynUNIXShellScriptSyn.IdentProc;\r\nbegin\r\n  while IsIdentChar(fLine[Run]) do inc(Run);\r\n  if IsKeyWord(GetToken) then\r\n  begin\r\n    fTokenId := tkKey;\r\n    Exit;\r\n  end\r\n  else\r\n    fTokenId := tkIdentifier;\r\n    \r\n  if IsSecondKeyWord(GetToken) then\r\n    fTokenId := tkSecondKey\r\n  else if fLine[Run] = '=' then\r\n    FTokenID := tkVariable\r\n  else\r\n    fTokenId := tkIdentifier;\r\nend;\r\n\r\nprocedure TSynUNIXShellScriptSyn.LFProc;\r\nbegin\r\n  fTokenID := tkSpace;\r\n  inc(Run);\r\nend;\r\n\r\nprocedure TSynUNIXShellScriptSyn.LowerProc;\r\n{$IFDEF SYN_HEREDOC}\r\n\r\n  // In UNIX Shell, Heredoc delimiter can be pretty much anything and the list\r\n  // of alpha-numeric characters is extended with a few common special characters\r\n  function IsAlphaNumChar(Run: Integer): Boolean;\r\n  begin\r\n    case fLine[Run] of\r\n      'A'..'Z', 'a'..'z', '0'..'9', '_', '-', '+', '!', '#', '%':\r\n        Result := True;\r\n      else\r\n        Result := False;\r\n    end;\r\n  end;\r\n\r\nvar\r\n  i, Len, SkipRun: Integer;\r\n  IndentedHeredoc: Boolean;\r\n  QuoteChar: WideChar;\r\n{$ENDIF}\r\nbegin\r\n{$IFDEF SYN_HEREDOC}\r\n  if FLine[Run + 1] = '<' then\r\n  begin\r\n    fTokenID := tkSymbol;\r\n\r\n    SkipRun := 0;\r\n    QuoteChar := #0;\r\n    if (FLine[Run + 2] = '-') and (FLine[Run + 3] in\r\n      [WideChar('\"'), WideChar(''''), WideChar('`'), WideChar('\\')]) then\r\n    begin\r\n      SkipRun := 2;\r\n      if FLine[Run + 3] <> '\\' then\r\n        QuoteChar := FLine[Run + 3];\r\n    end\r\n    else if (FLine[Run + 2] in\r\n      [WideChar('-'), WideChar('\"'), WideChar(''''), WideChar('`'), WideChar('\\')]) then\r\n    begin\r\n      SkipRun := 1;\r\n      if not (FLine[Run + 2] in [WideChar('-'), WideChar('\\')]) then\r\n        QuoteChar := FLine[Run + 2];\r\n    end;\r\n    IndentedHeredoc := (SkipRun > 0) and (FLine[Run + 2] = '-');\r\n\r\n    if IsAlphaNumChar(Run + SkipRun + 2) then\r\n    begin\r\n      inc(Run, 2);\r\n\r\n      i := Run;\r\n      while IsAlphaNumChar(SkipRun + i) do Inc(i);\r\n      Len := i - Run;\r\n\r\n      if Len > 255 then\r\n      begin\r\n        fTokenID := tkUnknown;\r\n        Exit;\r\n      end;\r\n\r\n      if (QuoteChar <> #0) and (FLine[Run + SkipRun + Len] <> QuoteChar) then\r\n      begin\r\n        fTokenID := tkUnknown;\r\n        Exit;\r\n      end;\r\n\r\n      if IndentedHeredoc then\r\n        fRange := rsIndentedHeredoc\r\n      else\r\n        fRange := rsHeredoc;\r\n      fHeredocLength := Len;\r\n      fHeredocChecksum := CalcFCS(FLine[Run + SkipRun], Len);\r\n\r\n      Inc(Run, SkipRun + Len);\r\n      fTokenID := tkString;\r\n    end\r\n    else\r\n      inc(Run, 2);\r\n  end\r\n  else\r\n{$ENDIF}\r\n  begin\r\n    inc(Run);\r\n    fTokenID := tkSymbol;\r\n  end;\r\nend;\r\n\r\nprocedure TSynUNIXShellScriptSyn.NullProc;\r\nbegin\r\n  fTokenID := tkNull;\r\n  inc(Run);\r\nend;\r\n\r\nprocedure TSynUNIXShellScriptSyn.NumberProc;\r\n\r\n  function IsNumberChar: Boolean;\r\n  begin\r\n    case fLine[Run] of\r\n      '0'..'9', '.', 'e', 'E':\r\n        Result := True;\r\n      else\r\n        Result := False;\r\n    end;\r\n  end;\r\n\r\nbegin\r\n  inc(Run);\r\n  fTokenID := tkNumber;\r\n  while IsNumberChar do\r\n  begin\r\n    case FLine[Run] of\r\n      '.':\r\n        if FLine[Run + 1] = '.' then break;\r\n    end;\r\n    inc(Run);\r\n  end;\r\nend;\r\n\r\nprocedure TSynUNIXShellScriptSyn.RoundOpenProc;\r\nbegin\r\n  inc(Run);\r\n  fTokenId := tkSymbol;\r\nend;\r\n\r\nprocedure TSynUNIXShellScriptSyn.SlashProc;\r\nbegin\r\n  if FLine[Run] = '#' then\r\n  begin\r\n    // Perl Styled Comment\r\n    inc(Run);\r\n    fTokenID := tkComment;\r\n    while not IsLineEnd(Run) do\r\n    begin\r\n      inc(Run);\r\n    end;\r\n  end\r\n  else\r\n  begin\r\n    inc(Run);\r\n    fTokenID := tkSymbol;\r\n  end;\r\nend;\r\n\r\nprocedure TSynUNIXShellScriptSyn.SpaceProc;\r\nbegin\r\n  inc(Run);\r\n  fTokenID := tkSpace;\r\n  while (FLine[Run] <= #32) and not IsLineEnd(Run) do inc(Run);\r\nend;\r\n\r\nprocedure TSynUNIXShellScriptSyn.StringProc;\r\nvar\r\n  QuoteChar: WideChar;\r\nbegin\r\n// Single and Double Quotes.\r\n\r\n  fTokenID := tkString;\r\n  QuoteChar := FLine[Run];      // either \" or '\r\n  if (FLine[Run + 1] = QuoteChar) and (FLine[Run + 2] = QuoteChar)\r\n    then inc(Run, 2);\r\n  repeat\r\n    if IsLineEnd(Run) then break;\r\n    inc(Run);\r\n  until FLine[Run] = QuoteChar;\r\n  if not IsLineEnd(Run) then inc(Run);\r\nend;\r\n\r\nprocedure TSynUNIXShellScriptSyn.UnknownProc;\r\nbegin\r\n  inc(Run);\r\n  fTokenID := tkUnknown;\r\nend;\r\n\r\n{$IFDEF SYN_HEREDOC}\r\nprocedure TSynUNIXShellScriptSyn.HeredocProc;\r\n\r\n  procedure SkipToEOL;\r\n  begin\r\n    case FLine[Run] of\r\n       #0: NullProc;\r\n      #10: LFProc;\r\n      #13: CRProc;\r\n      else\r\n        repeat\r\n          inc(Run);\r\n        until IsLineEnd(Run);\r\n    end;\r\n  end;\r\n\r\nvar\r\n  i: Integer;\r\nbegin\r\n  if IsLineEnd(Run) and (fTokenPos = Run) then\r\n  begin\r\n    NextProcedure;\r\n    Exit;\r\n  end;\r\n  fTokenID := tkString;\r\n\r\n  if fRange = rsIndentedHeredoc then\r\n    while FLine[Run] in [WideChar(#9), WideChar(#32)] do Inc(Run);\r\n\r\n  if ((Run = 0) and (fRange = rsHeredoc)) or (fRange = rsIndentedHeredoc) then\r\n  begin\r\n    i := 0;\r\n\r\n    while not IsLineEnd(FLine[Run + i]) do\r\n    begin\r\n      if i > fHeredocLength then\r\n      begin\r\n        SkipToEOL;\r\n        Exit;\r\n      end;\r\n      Inc(i);\r\n    end;\r\n\r\n    if i <> fHeredocLength then\r\n    begin\r\n      SkipToEOL;\r\n      Exit;\r\n    end;\r\n\r\n    if (CalcFCS(FLine[Run], i) = fHeredocChecksum) then\r\n    begin\r\n      fRange := rsUnknown;\r\n      Run := Run + i;\r\n      Exit;\r\n    end;\r\n  end;\r\n\r\n  SkipToEOL;\r\nend;\r\n{$ENDIF}\r\n\r\nprocedure TSynUNIXShellScriptSyn.Next;\r\nbegin\r\n  fTokenPos := Run;\r\n{$IFDEF SYN_HEREDOC}\r\n  if fRange in [rsHeredoc, rsIndentedHeredoc] then\r\n    HeredocProc\r\n  else\r\n{$ENDIF}\r\n    NextProcedure;\r\n  inherited;\r\nend;\r\n\r\nprocedure TSynUNIXShellScriptSyn.NextProcedure;\r\nbegin\r\n  case fLine[Run] of\r\n    '<': LowerProc;\r\n    '#': SlashProc;\r\n    '{': BraceOpenProc;\r\n    ';': PointCommaProc;\r\n    '.': DotProc;\r\n    #13: CRProc;\r\n    'A'..'Z', 'a'..'z', '_': IdentProc;\r\n    #10: LFProc;\r\n    #0: NullProc;\r\n    '0'..'9': NumberProc;\r\n    '(': RoundOpenProc;\r\n    '/': SlashProc;\r\n    '$': DollarProc;\r\n    #1..#9, #11, #12, #14..#32: SpaceProc;\r\n    #34, #39: StringProc;\r\n    '}', ')', '!', '%', '&',':','@','[',']','^','`','~': SymbolProc;\r\n    else UnknownProc;\r\n  end;\r\nend;\r\n\r\nfunction TSynUNIXShellScriptSyn.GetDefaultAttribute(Index: integer): TSynHighlighterAttributes;\r\nbegin\r\n  case Index of\r\n    SYN_ATTR_COMMENT: Result := fCommentAttri;\r\n    SYN_ATTR_IDENTIFIER: Result := fIdentifierAttri;\r\n    SYN_ATTR_KEYWORD: Result := fKeyAttri;\r\n    SYN_ATTR_STRING: Result := fStringAttri;\r\n    SYN_ATTR_WHITESPACE: Result := fSpaceAttri;\r\n    SYN_ATTR_SYMBOL: Result := fSymbolAttri;\r\n  else\r\n    Result := nil;\r\n  end;\r\nend;\r\n\r\nfunction TSynUNIXShellScriptSyn.GetEol: Boolean;\r\nbegin\r\n  Result := Run = fLineLen + 1;\r\nend;\r\n\r\nfunction TSynUNIXShellScriptSyn.GetRange: Pointer;\r\n{$IFDEF SYN_HEREDOC}\r\nvar\r\n  RangePointer: TRangePointer;\r\n{$ENDIF}\r\nbegin\r\n{$IFDEF SYN_HEREDOC}\r\n  RangePointer.Range := Ord(fRange);\r\n  RangePointer.Length := 0;\r\n  RangePointer.Checksum := 0;\r\n  if fRange in [rsHeredoc, rsIndentedHeredoc] then\r\n  begin\r\n    RangePointer.Length := fHeredocLength;\r\n    RangePointer.Checksum := fHeredocChecksum;\r\n  end;\r\n  Result := RangePointer.Ptr;\r\n{$ELSE}\r\n  Result := Pointer(fRange);\r\n{$ENDIF}\r\nend;\r\n\r\nfunction TSynUNIXShellScriptSyn.GetTokenID: TtkTokenKind;\r\nbegin\r\n  Result := fTokenId;\r\nend;\r\n\r\nfunction TSynUNIXShellScriptSyn.GetTokenAttribute: TSynHighlighterAttributes;\r\nbegin\r\n  case fTokenID of\r\n    tkComment: Result := fCommentAttri;\r\n    tkIdentifier: Result := fIdentifierAttri;\r\n    tkKey: Result := fKeyAttri;\r\n    tkSecondKey: Result := fSecondKeyAttri;\r\n    tkNumber: Result := fNumberAttri;\r\n    tkSpace: Result := fSpaceAttri;\r\n    tkString: Result := fStringAttri;\r\n    tkSymbol: Result := fSymbolAttri;\r\n    tkVariable: Result := fVarAttri;\r\n    tkUnknown: Result := fSymbolAttri;\r\n  else\r\n    Result := nil;\r\n  end;\r\nend;\r\n\r\nfunction TSynUNIXShellScriptSyn.GetTokenKind: integer;\r\nbegin\r\n  Result := Ord(fTokenId);\r\nend;\r\n\r\nprocedure TSynUNIXShellScriptSyn.ResetRange;\r\nbegin\r\n  fRange := rsUnknown;\r\n{$IFDEF SYN_HEREDOC}\r\n  fHeredocLength := 0;\r\n  fHeredocChecksum := 0;\r\n{$ENDIF}\r\nend;\r\n\r\nprocedure TSynUNIXShellScriptSyn.SetRange(Value: Pointer);\r\n{$IFDEF SYN_HEREDOC}\r\nvar\r\n  RangePointer : TRangePointer;\r\n{$ENDIF}\r\nbegin\r\n{$IFDEF SYN_HEREDOC}\r\n  RangePointer := TRangePointer(Value);\r\n  fRange := TRangeState(RangePointer.Range);\r\n  fHeredocLength := 0;\r\n  fHeredocChecksum := 0;\r\n  if fRange in [rsHeredoc, rsIndentedHeredoc] then\r\n  begin\r\n    fHeredocLength := RangePointer.Length;\r\n    fHeredocChecksum := RangePointer.Checksum;\r\n  end;\r\n{$ELSE}\r\n  fRange := TRangeState(Value);\r\n{$ENDIF}\r\nend;\r\n\r\nfunction TSynUNIXShellScriptSyn.IsFilterStored: Boolean;\r\nbegin\r\n  Result := fDefaultFilter <> SYNS_FilterUNIXShellScript;\r\nend;\r\n\r\nclass function TSynUNIXShellScriptSyn.GetLanguageName: string;\r\nbegin\r\n  Result := SYNS_LangNameUNIXShellScript;\r\nend;\r\n\r\nfunction TSynUNIXShellScriptSyn.GetSampleSource: UnicodeString;\r\nbegin\r\n  Result := '######################################'#13#10 +\r\n            '# Here is a comment about some stuff #'#13#10 +\r\n            '######################################'#13#10 +\r\n            ''#13#10 +\r\n            'case $BUILD_MODE in'#13#10 +\r\n            '  full )'#13#10 +\r\n            '      MyFirstFunction'#13#10 +\r\n            '      ;;'#13#10 +\r\n            '  rekit)'#13#10 +\r\n            '      MySecondFunction'#13#10 +\r\n            '    ;;'#13#10 +\r\n            '  installer)'#13#10 +\r\n            '      MyThirdFunction'#13#10 +\r\n            '    ;;'#13#10 +\r\n            'esac';\r\nend;\r\n\r\nclass function TSynUNIXShellScriptSyn.GetFriendlyLanguageName: UnicodeString;\r\nbegin\r\n  Result := SYNS_FriendlyLangNameUNIXShellScript;\r\nend;\r\n\r\nprocedure TSynUNIXShellScriptSyn.SymbolProc;\r\nbegin\r\n  inc(Run);\r\n  fTokenID := tkSymbol;\r\nend;\r\n\r\ninitialization\r\n{$IFNDEF SYN_CPPB_1}\r\n  RegisterPlaceableHighlighter(TSynUNIXShellScriptSyn);\r\n{$ENDIF}\r\nend.\r\n"
  },
  {
    "path": "External/SynEdit/Source/SynHighlighterURI.pas",
    "content": "{-------------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: SynHighlighterURI.pas, released 2003-04-10.\r\nThe initial author of this file is Mal Hrz.\r\nUnicode translation by Mal Hrz.\r\nAll Rights Reserved.\r\n\r\nContributors to the SynEdit project are listed in the Contributors.txt file.\r\n\r\nAlternatively, the contents of this file may be used under the terms of the\r\nGNU General Public License Version 2 or later (the \"GPL\"), in which case\r\nthe provisions of the GPL are applicable instead of those above.\r\nIf you wish to allow use of your version of this file only under the terms\r\nof the GPL and not to allow others to use your version of this file\r\nunder the MPL, indicate your decision by deleting the provisions above and\r\nreplace them with the notice and other provisions required by the GPL.\r\nIf you do not delete the provisions above, a recipient may use your version\r\nof this file under either the MPL or the GPL.\r\n\r\n$Id: SynHighlighterURI.pas,v 1.16.2.9 2008/09/14 16:25:03 maelh Exp $\r\n\r\nYou may retrieve the latest version of SynEdit from the SynEdit home page,\r\nlocated at http://SynEdit.SourceForge.net\r\n\r\n-------------------------------------------------------------------------------}\r\n{\r\n@abstract(Provides an URI syntax highlighter for SynEdit)\r\n@author(Mal Hrz)\r\n@created(2003)\r\n@lastmod(2004-03-19)\r\nhttp://www.mh-net.de.vu\r\n\r\nThe SynHighlighterURI unit implements an URI syntax highlighter for SynEdit.\r\n\r\nRecognition of URIs is based on the information provided in the document\r\n\"Uniform Resource Identifiers (URI): Generic Syntax\" of \"The Internet Society\",\r\nthat can be found at http://www.ietf.org/rfc/rfc2396.txt.\r\n\r\nAlso interesting is http://www.freesoft.org/CIE/RFC/1738/33.htm which describes\r\ngeneral URL syntax and major protocols.\r\n\r\nthese protocols are recognized:\r\n-------------------------------\r\nhttp://\r\nhttps://\r\nftp://\r\nmailto:\r\nnews: or news://\r\nnntp://\r\ntelnet://\r\ngopher://\r\nprospero://\r\nwais://\r\n\r\nas well as commonly used shorthands:\r\n------------------------------------\r\nsomeone@somewhere.org\r\nwww.host.org\r\n}\r\n\r\n{$IFNDEF QSYNHIGHLIGHTERURI}\r\nunit SynHighlighterURI;\r\n{$ENDIF}\r\n\r\n{$I SynEdit.inc}\r\n\r\ninterface\r\n\r\nuses\r\n{$IFDEF SYN_CLX}\r\n  QGraphics,\r\n  QSynEditTypes,\r\n  QSynEditHighlighter,\r\n  QSynUnicode,\r\n{$ELSE}\r\n  Graphics,\r\n  SynEditTypes,\r\n  SynEditHighlighter,\r\n  SynUnicode,\r\n{$ENDIF}\r\n  SysUtils,\r\n  Classes;\r\n\r\ntype\r\n  TtkTokenKind = (tkNull, tkSpace, tkFtpLink, tkGopherLink,\r\n    tkHttpLink, tkHttpsLink, tkMailtoLink, tkNewsLink, tkNntpLink,\r\n    tkProsperoLink, tkTelnetLink, tkWaisLink, tkWebLink, tkUnknown, tkNullChar);\r\n\r\n  PIdentFuncTableFunc = ^TIdentFuncTableFunc;\r\n  TIdentFuncTableFunc = function (Key: Integer): TtkTokenKind of object;\r\n\r\n  TAlreadyVisitedURIFunc = function (URI: UnicodeString): Boolean of object;\r\n\r\n  TSynURISyn = class(TSynCustomHighlighter)\r\n  private\r\n    fMayBeProtocol: PWideChar;\r\n    fTokenID: TtkTokenKind;\r\n    fIdentFuncTable: array[0..15] of TIdentFuncTableFunc;\r\n    fIdentifierAttri: TSynHighlighterAttributes;\r\n    fSpaceAttri: TSynHighlighterAttributes;\r\n    fURIAttri: TSynHighlighterAttributes;\r\n    fVisitedURIAttri: TSynHighlighterAttributes;\r\n    fAlreadyVisitedURI: TAlreadyVisitedURIFunc;\r\n\r\n    function HashKey(Str: PWideChar): Integer;\r\n    procedure InitIdent;\r\n\r\n    procedure CRProc;\r\n    procedure LFProc;\r\n    procedure NullProc;\r\n    procedure ProtocolProc;\r\n    procedure SpaceProc;\r\n    procedure UnknownProc;\r\n\r\n    function AltFunc(Key: Integer): TtkTokenKind;\r\n    function FuncFtp(Key: Integer): TtkTokenKind;\r\n    function FuncGopher(Key: Integer): TtkTokenKind;\r\n    function FuncHttp(Key: Integer): TtkTokenKind;\r\n    function FuncHttps(Key: Integer): TtkTokenKind;\r\n    function FuncMailto(Key: Integer): TtkTokenKind;\r\n    function FuncNews(Key: Integer): TtkTokenKind;\r\n    function FuncNntp(Key: Integer): TtkTokenKind;\r\n    function FuncProspero(Key: Integer): TtkTokenKind;\r\n    function FuncTelnet(Key: Integer): TtkTokenKind;\r\n    function FuncWais(Key: Integer): TtkTokenKind;\r\n    function FuncWeb(Key: Integer): TtkTokenKind;\r\n\r\n    function IsAlphaNum(AChar: WideChar): Boolean;\r\n    function IsMark(AChar: WideChar): Boolean;\r\n    function IsReserved(AChar: WideChar): Boolean;\r\n    function IsUnreserved(AChar: WideChar): Boolean;\r\n    function IsURIChar(AChar: WideChar): Boolean;\r\n    function IsNeverAtEnd(AChar: WideChar): Boolean;\r\n    function IsEMailAddressChar(AChar: WideChar): Boolean;\r\n    function IsNeverAtEMailAddressEnd(AChar: WideChar): Boolean;\r\n\r\n    function IsValidEmailAddress: Boolean;\r\n    function IsValidURI: Boolean;\r\n    function IsValidWebLink: Boolean;\r\n\r\n    procedure SetURIAttri(const Value: TSynHighlighterAttributes);\r\n    procedure SetVisitedURIAttri(const Value: TSynHighlighterAttributes);\r\n  protected\r\n    function GetSampleSource: UnicodeString; override;\r\n    function IsCurrentToken(const Token: UnicodeString): Boolean; override;\r\n    function IsFilterStored: Boolean; override;\r\n    procedure SetAlreadyVisitedURIFunc(Value: TAlreadyVisitedURIFunc);\r\n  public\r\n    class function GetLanguageName: string; override;\r\n    class function GetFriendlyLanguageName: UnicodeString; override;\r\n  public\r\n    constructor Create(AOwner: TComponent); override;\r\n    destructor Destroy; override;\r\n    function GetDefaultAttribute(Index: Integer): TSynHighlighterAttributes;\r\n      override;\r\n    function GetEol: Boolean; override;\r\n    function GetTokenID: TtkTokenKind;\r\n    function GetTokenAttribute: TSynHighlighterAttributes; override;\r\n    function GetTokenKind: Integer; override;\r\n    function IsIdentChar(AChar: WideChar): Boolean; override;\r\n    procedure Next; override;\r\n  published\r\n    property URIAttri: TSynHighlighterAttributes read fURIAttri write SetURIAttri;\r\n    property VisitedURIAttri: TSynHighlighterAttributes read fVisitedURIAttri\r\n      write SetVisitedURIAttri;\r\n  end;\r\n\r\nconst\r\n  SYN_ATTR_URI = 6;\r\n  SYN_ATTR_VISITEDURI = 7;\r\n\r\nimplementation\r\n\r\nuses\r\n{$IFDEF SYN_CLX}\r\n  QSynEditStrConst, SynUnicode;\r\n{$ELSE}\r\n  SynEditStrConst;\r\n{$ENDIF}\r\n\r\nconst\r\n  KeyWords: array[0..15] of UnicodeString = (\r\n    '', 'http://', '', 'https://', 'news:', 'gopher://', '', 'prospero://',\r\n    'news://', 'www', 'nntp://', 'ftp://', 'wais://', '', 'telnet://', 'mailto:'\r\n  );\r\n\r\nfunction TSynURISyn.HashKey(Str: PWideChar): Integer;\r\nbegin\r\n  Result := 0;\r\n  while CharInSet(Str^, ['A'..'Z', 'a'..'z']) do\r\n  begin\r\n    Result := (Result * 3 + Ord(Str^) div 9) mod 16;\r\n    inc(Str);\r\n  end;\r\n\r\n  if Str^ = ':' then\r\n  begin\r\n    Result := (Result * 3 + Ord(Str^) div 9) mod 16;\r\n    inc(Str);\r\n  end;\r\n\r\n  if Str^ = '/' then\r\n  begin\r\n    Result := (Result * 3 + Ord(Str^) div 9) mod 16;\r\n    inc(Str);\r\n  end;\r\n\r\n  if Str^ = '/' then\r\n  begin\r\n    Result := (Result * 3 + Ord(Str^) div 9) mod 16;\r\n    inc(Str);\r\n  end;\r\n\r\n  fStringLen := Str - fMayBeProtocol;\r\nend;\r\n\r\nprocedure TSynURISyn.InitIdent;\r\nvar\r\n  i: Integer;\r\nbegin\r\n  for i := Low(fIdentFuncTable) to High(fIdentFuncTable) do\r\n    fIdentFuncTable[i] := AltFunc;\r\n  \r\n  fIdentFuncTable[11] := FuncFtp;\r\n  fIdentFuncTable[5] := FuncGopher;\r\n  fIdentFuncTable[1] := FuncHttp;\r\n  fIdentFuncTable[3] := FuncHttps;\r\n  fIdentFuncTable[15] := FuncMailto;\r\n  fIdentFuncTable[4] := FuncNews;\r\n  fIdentFuncTable[8] := FuncNews;\r\n  fIdentFuncTable[10] := FuncNntp;\r\n  fIdentFuncTable[7] := FuncProspero;\r\n  fIdentFuncTable[14] := FuncTelnet;\r\n  fIdentFuncTable[12] := FuncWais;\r\n  fIdentFuncTable[9] := FuncWeb;\r\nend;\r\n\r\nfunction TSynURISyn.IsCurrentToken(const Token: UnicodeString): Boolean;\r\nvar\r\n  I: Integer;\r\n  Temp: PWideChar;\r\nbegin\r\n  Temp := fMayBeProtocol;\r\n  if Length(Token) = fStringLen then\r\n  begin\r\n    Result := True;\r\n    for i := 1 to fStringLen do\r\n    begin\r\n      if Temp^ <> Token[i] then\r\n      begin\r\n        Result := False;\r\n        break;\r\n      end;\r\n      inc(Temp);\r\n    end;\r\n  end\r\n  else\r\n    Result := False;\r\nend;\r\n\r\nfunction TSynURISyn.AltFunc(Key: Integer): TtkTokenKind;\r\nbegin\r\n  Result := tkUnknown;\r\nend;\r\n\r\nconstructor TSynURISyn.Create(AOwner: TComponent);\r\nbegin\r\n  inherited Create(AOwner);\r\n  fCaseSensitive := False;\r\n\r\n  fSpaceAttri := TSynHighlighterAttributes.Create(SYNS_AttrSpace, SYNS_FriendlyAttrSpace);\r\n  fIdentifierAttri := TSynHighlighterAttributes.Create(SYNS_AttrIdentifier, SYNS_FriendlyAttrIdentifier);\r\n\r\n  fURIAttri := TSynHighlighterAttributes.Create(SYNS_AttrURI, SYNS_FriendlyAttrURI);\r\n  fURIAttri.Foreground := clBlue;\r\n  fURIAttri.Style := [fsUnderline];\r\n  AddAttribute(fURIAttri);\r\n\r\n  fVisitedURIAttri := TSynHighlighterAttributes.Create(SYNS_AttrVisitedURI, SYNS_FriendlyAttrVisitedURI);\r\n  fVisitedURIAttri.Foreground := clPurple;\r\n  fVisitedURIAttri.Style := [fsUnderline];\r\n  AddAttribute(fVisitedURIAttri);\r\n\r\n  SetAttributesOnChange(DefHighlightChange);\r\n  InitIdent;\r\n  fDefaultFilter := SYNS_FilterURI;\r\nend;\r\n\r\ndestructor TSynURISyn.Destroy; \r\nbegin\r\n  inherited;\r\n  //the other attributes are automatically freed because of AddAttribute()\r\n  fSpaceAttri.Free;\r\n  fIdentifierAttri.Free;\r\nend;\r\n\r\nprocedure TSynURISyn.CRProc;\r\nbegin\r\n  fTokenID := tkSpace;\r\n  inc(Run);\r\n  if fLine[Run] = #10 then\r\n    Inc(Run);\r\nend;\r\n\r\nprocedure TSynURISyn.LFProc;\r\nbegin\r\n  fTokenID := tkSpace;\r\n  inc(Run);\r\nend;\r\n\r\nprocedure TSynURISyn.NullProc;\r\nbegin\r\n  if Run < fLineLen + 1 then\r\n  begin\r\n    inc(Run);\r\n    fTokenID := tkNullChar;\r\n  end\r\n  else\r\n    fTokenID := tkNull\r\nend;\r\n\r\nprocedure TSynURISyn.SpaceProc;\r\nbegin\r\n  inc(Run);\r\n  fTokenID := tkSpace;\r\n  while (FLine[Run] <= #32) and not IsLineEnd(Run) do inc(Run);\r\nend;\r\n\r\nprocedure TSynURISyn.UnknownProc;\r\nbegin\r\n  inc(Run);\r\n  fTokenID := tkUnknown;\r\nend;\r\n\r\nprocedure TSynURISyn.Next;\r\nbegin\r\n  fTokenPos := Run;\r\n  case fLine[Run] of\r\n    #13: CRProc;\r\n    #10: LFProc;\r\n    #0: NullProc;\r\n    #1..#9, #11, #12, #14..#32: SpaceProc;\r\n    'A'..'Z', 'a'..'z': ProtocolProc;\r\n    else\r\n      UnknownProc;\r\n  end;\r\n  inherited;\r\nend;\r\n\r\nfunction TSynURISyn.GetDefaultAttribute(Index: Integer): TSynHighlighterAttributes;\r\nbegin\r\n  case Index of\r\n    SYN_ATTR_IDENTIFIER: Result := fIdentifierAttri;\r\n    SYN_ATTR_WHITESPACE: Result := fSpaceAttri;\r\n    SYN_ATTR_URI: Result := fURIAttri;\r\n    SYN_ATTR_VISITEDURI: Result := fVisitedURIAttri;\r\n  else\r\n    Result := nil;\r\n  end;\r\nend;\r\n\r\nfunction TSynURISyn.GetEol: Boolean;\r\nbegin\r\n  Result := Run = fLineLen + 1;\r\nend;\r\n\r\nfunction TSynURISyn.GetTokenAttribute: TSynHighlighterAttributes;\r\nvar\r\n  Visited: Boolean;\r\nbegin\r\n  case GetTokenID of\r\n    tkSpace: Result := fSpaceAttri;\r\n    tkFtpLink, tkGopherLink, tkHttpLink, tkHttpsLink, tkMailtoLink, tkNewsLink,\r\n    tkNntpLink, tkProsperoLink, tkTelnetLink, tkWaisLink, tkWebLink:\r\n    begin\r\n      Visited := False;\r\n      if Assigned(FAlreadyVisitedURI) then\r\n        Visited := FAlreadyVisitedURI(GetToken);\r\n      if Visited then\r\n        Result := fVisitedURIAttri\r\n      else\r\n        Result := fURIAttri;\r\n    end;\r\n    tkUnknown: Result := fIdentifierAttri;\r\n    else Result := nil;\r\n  end;\r\nend;\r\n\r\nfunction TSynURISyn.GetTokenID: TtkTokenKind;\r\nbegin\r\n  Result := fTokenId;\r\nend;\r\n\r\nfunction TSynURISyn.GetTokenKind: Integer;\r\nbegin\r\n  Result := Ord(fTokenId);\r\nend;\r\n\r\nclass function TSynURISyn.GetLanguageName: string;\r\nbegin\r\n  Result := SYNS_LangURI;\r\nend;\r\n\r\nfunction TSynURISyn.GetSampleSource: UnicodeString;\r\nbegin\r\n  Result := 'Universal Resource Identifier highlighting'#13#10#13#10 +\r\n            'http://www.somewhere.org'#13#10 +\r\n            'ftp://superhost.org/downloads/gems.zip'#13#10 +\r\n            'www.w3c.org'#13#10 +\r\n            'mailto:big@lebowski.edu'#13#10 +\r\n            'douglas@adams.lod'#13#10 +\r\n            'news:comp.lang.pascal.borland';\r\nend;\r\n\r\nfunction TSynURISyn.IsFilterStored: Boolean;\r\nbegin\r\n  Result := fDefaultFilter <> SYNS_FilterURI;\r\nend;\r\n\r\nfunction TSynURISyn.IsIdentChar(AChar: WideChar): Boolean;\r\nbegin\r\n  Result := SynIsCharAlphaNumeric(AChar);\r\nend;\r\n\r\nprocedure TSynURISyn.SetAlreadyVisitedURIFunc(Value: TAlreadyVisitedURIFunc);\r\nbegin\r\n  FAlreadyVisitedURI := Value;\r\nend;\r\n\r\nprocedure TSynURISyn.SetURIAttri(const Value: TSynHighlighterAttributes);\r\nbegin\r\n  fURIAttri.Assign(Value);\r\nend;\r\n\r\nprocedure TSynURISyn.SetVisitedURIAttri(const Value: TSynHighlighterAttributes);\r\nbegin\r\n  fVisitedURIAttri.Assign(Value);\r\nend;\r\n\r\nprocedure TSynURISyn.ProtocolProc;\r\nvar\r\n  Key: Integer;\r\nbegin\r\n  if IsValidEmailAddress then\r\n    fTokenID := tkMailtoLink\r\n  else\r\n  begin\r\n    fMayBeProtocol := fLine + Run;\r\n    Key := HashKey(fMayBeProtocol);\r\n    inc(Run, fStringLen);\r\n\r\n    if Key <= 15 then\r\n      fTokenID := fIdentFuncTable[Key](Key)\r\n    else\r\n      fTokenID := tkUnknown;\r\n  end;\r\nend;\r\n\r\nfunction TSynURISyn.FuncFtp(Key: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Key]) and IsValidURI then\r\n    Result := tkFtpLink\r\n  else\r\n    Result := tkUnknown;\r\nend;\r\n\r\nfunction TSynURISyn.FuncGopher(Key: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Key]) and IsValidURI then\r\n    Result := tkGopherLink\r\n  else\r\n    Result := tkUnknown;\r\nend;\r\n\r\nfunction TSynURISyn.FuncHttp(Key: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Key]) and IsValidURI then\r\n    Result := tkHttpLink\r\n  else\r\n    Result := tkUnknown;\r\nend;\r\n\r\nfunction TSynURISyn.FuncHttps(Key: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Key]) and IsValidURI then\r\n    Result := tkHttpsLink\r\n  else\r\n    Result := tkUnknown;\r\nend;\r\n\r\nfunction TSynURISyn.FuncMailto(Key: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Key]) and IsValidURI then\r\n    Result := tkMailtoLink\r\n  else\r\n    Result := tkUnknown;\r\nend;\r\n\r\nfunction TSynURISyn.FuncNews(Key: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Key]) and IsValidURI then\r\n    Result := tkNewsLink\r\n  else\r\n    Result := tkUnknown;\r\nend;\r\n\r\nfunction TSynURISyn.FuncNntp(Key: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Key]) and IsValidURI then\r\n    Result := tkNntpLink\r\n  else\r\n    Result := tkUnknown;\r\nend;\r\n\r\nfunction TSynURISyn.FuncProspero(Key: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Key]) and IsValidURI then\r\n    Result := tkProsperoLink\r\n  else\r\n    Result := tkUnknown;\r\nend;\r\n\r\nfunction TSynURISyn.FuncTelnet(Key: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Key]) and IsValidURI then\r\n    Result := tkTelnetLink\r\n  else\r\n    Result := tkUnknown;\r\nend;\r\n\r\nfunction TSynURISyn.FuncWais(Key: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Key]) and IsValidURI then\r\n    Result := tkWaisLink\r\n  else\r\n    Result := tkUnknown;\r\nend;\r\n\r\nfunction TSynURISyn.FuncWeb(Key: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Key]) and IsValidWebLink then\r\n    Result := tkWebLink\r\n  else\r\n    Result := tkUnknown;\r\nend;\r\n\r\n\r\nfunction TSynURISyn.IsAlphaNum(AChar: WideChar): Boolean;\r\nbegin\r\n  Result := SynIsCharAlphaNumeric(AChar);\r\nend;\r\n\r\nfunction TSynURISyn.IsMark(AChar: WideChar): Boolean;\r\nbegin\r\n  case AChar of\r\n    '-', '_', '.', '!', '~', '*', '''', '(' , ')':\r\n      Result := True;\r\n    else\r\n      Result := False;\r\n  end;\r\nend;\r\n\r\nfunction TSynURISyn.IsReserved(AChar: WideChar): Boolean;\r\nbegin\r\n  case AChar of\r\n    ';', '/', '?', ':', '@', '&', '=', '+', '$', ',', '%', '#':\r\n      Result := True;\r\n    else\r\n      Result := False;\r\n  end;\r\nend;\r\n\r\nfunction TSynURISyn.IsUnreserved(AChar: WideChar): Boolean;\r\nbegin\r\n  Result := IsAlphaNum(AChar) or IsMark(AChar);\r\nend;\r\n\r\nfunction TSynURISyn.IsURIChar(AChar: WideChar): Boolean;\r\nbegin\r\n  Result := IsReserved(AChar) or IsUnreserved(AChar);\r\nend;\r\n\r\nfunction TSynURISyn.IsNeverAtEnd(AChar: WideChar): Boolean;\r\nbegin\r\n  Result := (IsMark(AChar) and (AChar <> '''')) or\r\n            (IsReserved(AChar) and (AChar <> '/') and (AChar <> '$'));\r\nend;\r\n\r\nfunction TSynURISyn.IsEMailAddressChar(AChar: WideChar): Boolean;\r\nbegin\r\n  case AChar of\r\n    '.', '_', '-', '@':\r\n      Result := True;\r\n    else\r\n      Result := IsAlphaNum(AChar);\r\n  end;\r\nend;\r\n\r\nfunction TSynURISyn.IsNeverAtEMailAddressEnd(AChar: WideChar): Boolean;\r\nbegin\r\n  Result := (AChar = '.') or (AChar = '@');\r\nend;\r\n\r\nfunction TSynURISyn.IsValidEmailAddress: Boolean;\r\nvar\r\n  StartPos, AtPos, DotPos: Integer;\r\nbegin\r\n  StartPos := Run;\r\n\r\n  AtPos := -1;\r\n  DotPos := -1;\r\n  while IsEMailAddressChar(fLine[Run]) do\r\n  begin\r\n    if fLine[Run] = '@' then\r\n      AtPos := Run\r\n    else if fLine[Run] = '.' then\r\n      // reject array of dots: \"neighbour\" dots are not allowed\r\n      if (Run = StartPos) or (DotPos >= 0) and (DotPos = Run - 1) then\r\n        break\r\n      else\r\n        DotPos := Run;\r\n    Inc(Run);\r\n  end;\r\n\r\n  while (Run > StartPos) and (IsNeverAtEMailAddressEnd(fLine[Run - 1])) do\r\n    dec(Run);\r\n\r\n  while (DotPos >= Run) or (DotPos > -1) and (fLine[DotPos] <> '.') do\r\n    Dec(DotPos);\r\n\r\n  Result := (StartPos < AtPos) and (AtPos < Run - 1) and (DotPos > AtPos + 1);\r\n  if not Result then Run := StartPos;\r\nend;\r\n\r\nfunction TSynURISyn.IsValidURI: Boolean;\r\nvar\r\n  ProtocolEndPos, DotPos: Integer;\r\n\r\n  function IsRelativePath: Boolean;\r\n  begin\r\n    Result := (DotPos - 1 >= 0) and\r\n      ((fLine[DotPos - 1] = '/') and (fLine[DotPos + 2] = '/')) or\r\n      ((fLine[DotPos - 1] = '\\') and (fLine[DotPos + 2] = '\\'));\r\n  end;\r\n\r\nbegin\r\n  ProtocolEndPos := Run;\r\n\r\n  DotPos := -1;\r\n  while IsURIChar(fLine[Run]) do\r\n  begin\r\n    if fLine[Run] = '.' then\r\n      // reject array of dots: \"neighbour\" dots are not allowed\r\n      if (DotPos >= 0) and (DotPos = Run - 1) and not IsRelativePath then\r\n        break\r\n      else\r\n        DotPos := Run;\r\n    inc(Run);\r\n  end;\r\n\r\n  while (Run > ProtocolEndPos) and IsNeverAtEnd(fLine[Run - 1]) do\r\n    dec(Run);\r\n\r\n  Result := Run > ProtocolEndPos;\r\nend;\r\n\r\nfunction TSynURISyn.IsValidWebLink: Boolean;\r\nvar\r\n  WWWEndPos, DotPos, SecondDotPos: Integer;\r\n\r\n  function IsRelativePath: Boolean;\r\n  begin\r\n    Result := (DotPos - 1 >= 0) and\r\n      ((fLine[DotPos - 1] = '/') and (fLine[DotPos + 2] = '/')) or\r\n      ((fLine[DotPos - 1] = '\\') and (fLine[DotPos + 2] = '\\'));\r\n  end;\r\n\r\nbegin\r\n  WWWEndPos := Run;\r\n\r\n  DotPos := -1;\r\n  SecondDotPos := -1;\r\n  while IsURIChar(fLine[Run]) do\r\n  begin\r\n    if fLine[Run] = '.' then\r\n      // reject array of dots: \"neighbour\" dots are not allowed\r\n      if (DotPos >= 0) and (DotPos = Run - 1) and not IsRelativePath then\r\n        break\r\n      else\r\n      begin\r\n        DotPos := Run;\r\n        if SecondDotPos = -2 then SecondDotPos := DotPos;\r\n        if SecondDotPos = -1 then SecondDotPos := -2;\r\n      end;\r\n    inc(Run);\r\n  end;\r\n\r\n  while (Run > WWWEndPos) and IsNeverAtEnd(fLine[Run - 1]) do\r\n    dec(Run);\r\n\r\n  Result := (Run > WWWEndPos) and (fLine[WWWEndPos] = '.') and\r\n            (SecondDotPos > WWWEndPos + 1) and (SecondDotPos < Run);\r\nend;\r\n\r\nclass function TSynURISyn.GetFriendlyLanguageName: UnicodeString;\r\nbegin\r\n  Result := SYNS_FriendlyLangURI;\r\nend;\r\n\r\ninitialization\r\n{$IFNDEF SYN_CPPB_1}\r\n  RegisterPlaceableHighlighter(TSynURISyn);\r\n{$ENDIF}\r\nend.\r\n"
  },
  {
    "path": "External/SynEdit/Source/SynHighlighterUnreal.pas",
    "content": "{-------------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n                                          PP - 2001/10/24:\r\nThe Original Code is based on the UnrealSyn.pas file from the\r\nmwEdit component suite by Martin Waldenburg and other developers, the Initial\r\nAuthor of this file is Dean Harmon.\r\nUnicode translation by Mal Hrz.\r\nAll Rights Reserved.\r\n\r\nContributors to the SynEdit and mwEdit projects are listed in the\r\nContributors.txt file.\r\n\r\nAlternatively, the contents of this file may be used under the terms of the\r\nGNU General Public License Version 2 or later (the \"GPL\"), in which case\r\nthe provisions of the GPL are applicable instead of those above.\r\nIf you wish to allow use of your version of this file only under the terms\r\nof the GPL and not to allow others to use your version of this file\r\nunder the MPL, indicate your decision by deleting the provisions above and\r\nreplace them with the notice and other provisions required by the GPL.\r\nIf you do not delete the provisions above, a recipient may use your version\r\nof this file under either the MPL or the GPL.\r\n\r\n$Id: SynHighlighterUnreal.pas,v 1.17.2.8 2008/09/14 16:25:03 maelh Exp $\r\n\r\nYou may retrieve the latest version of this file at the SynEdit home page,\r\nlocated at http://SynEdit.SourceForge.net\r\n\r\nKnown Issues:\r\n-------------------------------------------------------------------------------}\r\n{\r\n@abstract(Provides a Unreal syntax highlighter for SynEdit)\r\n@author(Dean Harmon)\r\n@created(2000)\r\n@lastmod(2001-06-29)\r\n}\r\n\r\n{$IFNDEF QSYNHIGHLIGHTERUNREAL}\r\nunit SynHighlighterUnreal;\r\n{$ENDIF}\r\n\r\n{$I SynEdit.inc}\r\n\r\ninterface\r\n\r\nuses\r\n{$IFDEF SYN_CLX}\r\n  QGraphics,\r\n  QSynEditHighlighter,\r\n  QSynEditTypes,\r\n  QSynUnicode,\r\n{$ELSE}\r\n  Graphics,\r\n  Registry,\r\n  Windows, // registry constants\r\n  SynEditHighlighter,\r\n  SynEditTypes,\r\n  SynUnicode,\r\n{$ENDIF}\r\n  SysUtils,\r\n  Classes;\r\n\r\ntype\r\n  TtkTokenKind = (\r\n    tkComment,\r\n    tkDirective,\r\n    tkIdentifier,\r\n    tkKey,\r\n    tkKey2,\r\n    tkNull,\r\n    tkNumber,\r\n    tkSpace,\r\n    tkString,\r\n    tkString2,\r\n    tkSymbol,\r\n    tkUnknown);\r\n\r\n  TxtkTokenKind = (\r\n    xtkAdd, xtkAddAssign, xtkAnd, xtkAndAssign, xtkArrow, xtkAssign,\r\n    xtkBitComplement, xtkBraceClose, xtkBraceOpen, xtkColon, xtkComma,\r\n    xtkDecrement, xtkDivide, xtkDivideAssign, xtkEllipse, xtkGreaterThan,\r\n    xtkGreaterThanEqual, xtkIncOr, xtkIncOrAssign, xtkIncrement, xtkLessThan,\r\n    xtkLessThanEqual, xtkLogAnd, xtkLogComplement, xtkLogEqual, xtkLogOr,\r\n    xtkMod, xtkModAssign, xtkMultiplyAssign, xtkNotEqual, xtkPoint, xtkQuestion,\r\n    xtkRoundClose, xtkRoundOpen, xtkScopeResolution, xtkSemiColon, xtkShiftLeft,\r\n    xtkShiftLeftAssign, xtkShiftRight, xtkShiftRightAssign, xtkSquareClose,\r\n    xtkSquareOpen, xtkStar, xtkSubtract, xtkSubtractAssign, xtkXor,\r\n    xtkXorAssign);\r\n\r\n  TRangeState = (rsANil, rsAnsiC, rsDirective, rsDirectiveComment, rsUnKnown);\r\n\r\n  PIdentFuncTableFunc = ^TIdentFuncTableFunc;\r\n  TIdentFuncTableFunc = function (Index: Integer): TtkTokenKind of object;\r\n\r\n  TSynUnrealSyn = class(TSynCustomHighlighter)\r\n  private\r\n    fRange: TRangeState;\r\n    FRoundCount: Integer;\r\n    FSquareCount: Integer;\r\n    FTokenID: TtkTokenKind;\r\n    FExtTokenID: TxtkTokenKind;\r\n    fIdentFuncTable: array[0..732] of TIdentFuncTableFunc;\r\n    fCommentAttri: TSynHighlighterAttributes;\r\n    fDirecAttri: TSynHighlighterAttributes;\r\n    fIdentifierAttri: TSynHighlighterAttributes;\r\n    fInvalidAttri: TSynHighlighterAttributes;\r\n    fKeyAttri: TSynHighlighterAttributes;\r\n    fKey2Attri: TSynHighlighterAttributes;\r\n    fNumberAttri: TSynHighlighterAttributes;\r\n    fSpaceAttri: TSynHighlighterAttributes;\r\n    fStringAttri: TSynHighlighterAttributes;\r\n    fString2Attri: TSynHighlighterAttributes;\r\n    fSymbolAttri: TSynHighlighterAttributes;\r\n    function AltFunc(Index: Integer): TtkTokenKind;\r\n    function FuncAbstract(Index: Integer): TtkTokenKind;\r\n    function FuncAlways(Index: Integer): TtkTokenKind;\r\n    function FuncArray(Index: Integer): TtkTokenKind;\r\n    function FuncArraycount(Index: Integer): TtkTokenKind;\r\n    function FuncAssert(Index: Integer): TtkTokenKind;\r\n    function FuncAuto(Index: Integer): TtkTokenKind;\r\n    function FuncAutomated(Index: Integer): TtkTokenKind;\r\n    function FuncBool(Index: Integer): TtkTokenKind;\r\n    function FuncBoundingbox(Index: Integer): TtkTokenKind;\r\n    function FuncBoundingvolume(Index: Integer): TtkTokenKind;\r\n    function FuncBreak(Index: Integer): TtkTokenKind;\r\n    function FuncButton(Index: Integer): TtkTokenKind;\r\n    function FuncByte(Index: Integer): TtkTokenKind;\r\n    function FuncCache(Index: Integer): TtkTokenKind;\r\n    function FuncCacheexempt(Index: Integer): TtkTokenKind;\r\n    function FuncCase(Index: Integer): TtkTokenKind;\r\n    function FuncCatch(Index: Integer): TtkTokenKind;\r\n    function FuncClass(Index: Integer): TtkTokenKind;\r\n    function FuncCoerce(Index: Integer): TtkTokenKind;\r\n    function FuncCollapsecategories(Index: Integer): TtkTokenKind;\r\n    function FuncColor(Index: Integer): TtkTokenKind;\r\n    function FuncConfig(Index: Integer): TtkTokenKind;\r\n    function FuncConst(Index: Integer): TtkTokenKind;\r\n    function FuncContinue(Index: Integer): TtkTokenKind;\r\n    function FuncCoords(Index: Integer): TtkTokenKind;\r\n    function FuncCpptext(Index: Integer): TtkTokenKind;\r\n    function FuncCross(Index: Integer): TtkTokenKind;\r\n    function FuncDefault(Index: Integer): TtkTokenKind;\r\n    function FuncDefaultproperties(Index: Integer): TtkTokenKind;\r\n    function FuncDelegate(Index: Integer): TtkTokenKind;\r\n    function FuncDelete(Index: Integer): TtkTokenKind;\r\n    function FuncDependson(Index: Integer): TtkTokenKind;\r\n    function FuncDeprecated(Index: Integer): TtkTokenKind;\r\n    function FuncDo(Index: Integer): TtkTokenKind;\r\n    function FuncDontcollapsecategories(Index: Integer): TtkTokenKind;\r\n    function FuncDot(Index: Integer): TtkTokenKind;\r\n    function FuncEach(Index: Integer): TtkTokenKind;\r\n    function FuncEdfindable(Index: Integer): TtkTokenKind;\r\n    function FuncEditconst(Index: Integer): TtkTokenKind;\r\n    function FuncEditconstarray(Index: Integer): TtkTokenKind;\r\n    function FuncEditinline(Index: Integer): TtkTokenKind;\r\n    function FuncEditinlinenew(Index: Integer): TtkTokenKind;\r\n    function FuncEditinlinenotify(Index: Integer): TtkTokenKind;\r\n    function FuncEditinlineuse(Index: Integer): TtkTokenKind;\r\n    function FuncElse(Index: Integer): TtkTokenKind;\r\n    function FuncEnum(Index: Integer): TtkTokenKind;\r\n    function FuncEnumcount(Index: Integer): TtkTokenKind;\r\n    function FuncEvent(Index: Integer): TtkTokenKind;\r\n    function FuncExec(Index: Integer): TtkTokenKind;\r\n    function FuncExpands(Index: Integer): TtkTokenKind;\r\n    function FuncExplicit(Index: Integer): TtkTokenKind;\r\n    function FuncExport(Index: Integer): TtkTokenKind;\r\n    function FuncExportstructs(Index: Integer): TtkTokenKind;\r\n    function FuncExtends(Index: Integer): TtkTokenKind;\r\n    function FuncFalse(Index: Integer): TtkTokenKind;\r\n    function FuncFinal(Index: Integer): TtkTokenKind;\r\n    function FuncFloat(Index: Integer): TtkTokenKind;\r\n    function FuncFor(Index: Integer): TtkTokenKind;\r\n    function FuncForeach(Index: Integer): TtkTokenKind;\r\n    function FuncFunction(Index: Integer): TtkTokenKind;\r\n    function FuncGlobal(Index: Integer): TtkTokenKind;\r\n    function FuncGlobalconfig(Index: Integer): TtkTokenKind;\r\n    function FuncGoto(Index: Integer): TtkTokenKind;\r\n    function FuncGuid(Index: Integer): TtkTokenKind;\r\n    function FuncHidecategories(Index: Integer): TtkTokenKind;\r\n    function FuncHidedropdown(Index: Integer): TtkTokenKind;\r\n    function FuncHideparent(Index: Integer): TtkTokenKind;\r\n    function FuncIf(Index: Integer): TtkTokenKind;\r\n    function FuncIgnores(Index: Integer): TtkTokenKind;\r\n    function FuncImport(Index: Integer): TtkTokenKind;\r\n    function FuncInit(Index: Integer): TtkTokenKind;\r\n    function FuncInput(Index: Integer): TtkTokenKind;\r\n    function FuncInsert(Index: Integer): TtkTokenKind;\r\n    function FuncInstanced(Index: Integer): TtkTokenKind;\r\n    function FuncInt(Index: Integer): TtkTokenKind;\r\n    function FuncIntrinsic(Index: Integer): TtkTokenKind;\r\n    function FuncInvariant(Index: Integer): TtkTokenKind;\r\n    function FuncIterator(Index: Integer): TtkTokenKind;\r\n    function FuncLatent(Index: Integer): TtkTokenKind;\r\n    function FuncLength(Index: Integer): TtkTokenKind;\r\n    function FuncLocal(Index: Integer): TtkTokenKind;\r\n    function FuncLocalized(Index: Integer): TtkTokenKind;\r\n    function FuncLong(Index: Integer): TtkTokenKind;\r\n    function FuncMesh(Index: Integer): TtkTokenKind;\r\n    function FuncModel(Index: Integer): TtkTokenKind;\r\n    function FuncMutable(Index: Integer): TtkTokenKind;\r\n    function FuncName(Index: Integer): TtkTokenKind;\r\n    function FuncNative(Index: Integer): TtkTokenKind;\r\n    function FuncNativereplication(Index: Integer): TtkTokenKind;\r\n    function FuncNew(Index: Integer): TtkTokenKind;\r\n    function FuncNoexport(Index: Integer): TtkTokenKind;\r\n    function FuncNone(Index: Integer): TtkTokenKind;\r\n    function FuncNoteditinlinenew(Index: Integer): TtkTokenKind;\r\n    function FuncNotplaceable(Index: Integer): TtkTokenKind;\r\n    function FuncNousercreate(Index: Integer): TtkTokenKind;\r\n    function FuncOperator(Index: Integer): TtkTokenKind;\r\n    function FuncOptional(Index: Integer): TtkTokenKind;\r\n    function FuncOut(Index: Integer): TtkTokenKind;\r\n    function FuncParseconfig(Index: Integer): TtkTokenKind;\r\n    function FuncPerobjectconfig(Index: Integer): TtkTokenKind;\r\n    function FuncPlaceable(Index: Integer): TtkTokenKind;\r\n    function FuncPlane(Index: Integer): TtkTokenKind;\r\n    function FuncPointer(Index: Integer): TtkTokenKind;\r\n    function FuncPostoperator(Index: Integer): TtkTokenKind;\r\n    function FuncPreoperator(Index: Integer): TtkTokenKind;\r\n    function FuncPrivate(Index: Integer): TtkTokenKind;\r\n    function FuncProtected(Index: Integer): TtkTokenKind;\r\n    function FuncRegister(Index: Integer): TtkTokenKind;\r\n    function FuncReliable(Index: Integer): TtkTokenKind;\r\n    function FuncRemove(Index: Integer): TtkTokenKind;\r\n    function FuncReplication(Index: Integer): TtkTokenKind;\r\n    function FuncReturn(Index: Integer): TtkTokenKind;\r\n    function FuncRng(Index: Integer): TtkTokenKind;\r\n    function FuncRot(Index: Integer): TtkTokenKind;\r\n    function FuncRotator(Index: Integer): TtkTokenKind;\r\n    function FuncSafereplace(Index: Integer): TtkTokenKind;\r\n    function FuncScale(Index: Integer): TtkTokenKind;\r\n    function FuncScriptconst(Index: Integer): TtkTokenKind;\r\n    function FuncSelf(Index: Integer): TtkTokenKind;\r\n    function FuncShowcategories(Index: Integer): TtkTokenKind;\r\n    function FuncSimulated(Index: Integer): TtkTokenKind;\r\n    function FuncSingular(Index: Integer): TtkTokenKind;\r\n    function FuncSkip(Index: Integer): TtkTokenKind;\r\n    function FuncSound(Index: Integer): TtkTokenKind;\r\n    function FuncState(Index: Integer): TtkTokenKind;\r\n    function FuncStatic(Index: Integer): TtkTokenKind;\r\n    function FuncStop(Index: Integer): TtkTokenKind;\r\n    function FuncString(Index: Integer): TtkTokenKind;\r\n    function FuncStruct(Index: Integer): TtkTokenKind;\r\n    function FuncSuper(Index: Integer): TtkTokenKind;\r\n    function FuncSwitch(Index: Integer): TtkTokenKind;\r\n    function FuncTexture(Index: Integer): TtkTokenKind;\r\n    function FuncTransient(Index: Integer): TtkTokenKind;\r\n    function FuncTravel(Index: Integer): TtkTokenKind;\r\n    function FuncTrue(Index: Integer): TtkTokenKind;\r\n    function FuncUnreliable(Index: Integer): TtkTokenKind;\r\n    function FuncUntil(Index: Integer): TtkTokenKind;\r\n    function FuncVar(Index: Integer): TtkTokenKind;\r\n    function FuncVect(Index: Integer): TtkTokenKind;\r\n    function FuncVector(Index: Integer): TtkTokenKind;\r\n    function FuncVoid(Index: Integer): TtkTokenKind;\r\n    function FuncWhile(Index: Integer): TtkTokenKind;\r\n    function FuncWithin(Index: Integer): TtkTokenKind;\r\n    function HashKey(Str: PWideChar): Cardinal;\r\n    function IdentKind(MayBe: PWideChar): TtkTokenKind;\r\n    procedure InitIdent;\r\n    procedure AnsiCProc;\r\n    procedure AndSymbolProc;\r\n    procedure AsciiCharProc;\r\n    procedure BraceCloseProc;\r\n    procedure BraceOpenProc;\r\n    procedure CRProc;\r\n    procedure ColonProc;\r\n    procedure CommaProc;\r\n    procedure DirectiveProc;\r\n    procedure EqualProc;\r\n    procedure GreaterProc;\r\n    procedure IdentProc;\r\n    procedure LFProc;\r\n    procedure LowerProc;\r\n    procedure MinusProc;\r\n    procedure ModSymbolProc;\r\n    procedure NotSymbolProc;\r\n    procedure NullProc;\r\n    procedure NumberProc;\r\n    procedure OrSymbolProc;\r\n    procedure PlusProc;\r\n    procedure PointProc;\r\n    procedure QuestionProc;\r\n    procedure RoundCloseProc;\r\n    procedure RoundOpenProc;\r\n    procedure SemiColonProc;\r\n    procedure SlashProc;\r\n    procedure SpaceProc;\r\n    procedure SquareCloseProc;\r\n    procedure SquareOpenProc;\r\n    procedure StarProc;\r\n    procedure StringProc;\r\n    procedure DollarSignProc;\r\n    procedure TildeProc;\r\n    procedure XOrSymbolProc;\r\n    procedure UnknownProc;\r\n  protected\r\n    function GetExtTokenID: TxtkTokenKind;\r\n    function GetSampleSource: UnicodeString; override;\r\n    function IsFilterStored: Boolean; override;\r\n    procedure NextProcedure;\r\n  public\r\n    class function GetCapabilities: TSynHighlighterCapabilities; override;\r\n    class function GetLanguageName: string; override;\r\n    class function GetFriendlyLanguageName: UnicodeString; override;\r\n  public\r\n    constructor Create(AOwner: TComponent); override;\r\n    function GetDefaultAttribute(Index: integer): TSynHighlighterAttributes;\r\n      override;\r\n    function GetEol: Boolean; override;\r\n    function GetRange: Pointer; override;\r\n    function GetTokenID: TtkTokenKind;\r\n    function GetTokenAttribute: TSynHighlighterAttributes; override;\r\n    function GetTokenKind: integer; override;\r\n    procedure Next; override;\r\n    procedure SetRange(Value: Pointer); override;\r\n    procedure ResetRange; override;\r\n    function UseUserSettings(settingIndex: integer): boolean; override;\r\n    procedure EnumUserSettings(settings: TStrings); override;\r\n    property ExtTokenID: TxtkTokenKind read GetExtTokenID;\r\n  published\r\n    property CommentAttri: TSynHighlighterAttributes read fCommentAttri\r\n      write fCommentAttri;\r\n    property DirecAttri: TSynHighlighterAttributes read fDirecAttri\r\n      write fDirecAttri;\r\n    property IdentifierAttri: TSynHighlighterAttributes read fIdentifierAttri\r\n      write fIdentifierAttri;\r\n    property InvalidAttri: TSynHighlighterAttributes read fInvalidAttri\r\n      write fInvalidAttri;\r\n    property KeyAttri: TSynHighlighterAttributes read fKeyAttri write fKeyAttri;\r\n    property Key2Attri: TSynHighlighterAttributes read fKey2Attri write fKey2Attri;\r\n    property NumberAttri: TSynHighlighterAttributes read fNumberAttri\r\n      write fNumberAttri;\r\n    property SpaceAttri: TSynHighlighterAttributes read fSpaceAttri\r\n      write fSpaceAttri;\r\n    property StringAttri: TSynHighlighterAttributes read fStringAttri\r\n      write fStringAttri;\r\n    property SingleStringAttri: TSynHighlighterAttributes read fString2Attri\r\n      write fString2Attri;\r\n    property SymbolAttri: TSynHighlighterAttributes read fSymbolAttri\r\n      write fSymbolAttri;\r\n  end;\r\n\r\nimplementation\r\n\r\nuses\r\n{$IFDEF SYN_CLX}\r\n  QSynEditStrConst;\r\n{$ELSE}\r\n  SynEditStrConst;\r\n{$ENDIF}\r\n\r\nconst\r\n  KeyWords: array[0..142] of UnicodeString = (\r\n    'abstract', 'always', 'array', 'arraycount', 'assert', 'auto', 'automated', \r\n    'bool', 'boundingbox', 'boundingvolume', 'break', 'button', 'byte', 'cache', \r\n    'cacheexempt', 'case', 'catch', 'class', 'coerce', 'collapsecategories', \r\n    'color', 'config', 'const', 'continue', 'coords', 'cpptext', 'cross', \r\n    'default', 'defaultproperties', 'delegate', 'delete', 'dependson', \r\n    'deprecated', 'do', 'dontcollapsecategories', 'dot', 'each', 'edfindable', \r\n    'editconst', 'editconstarray', 'editinline', 'editinlinenew', \r\n    'editinlinenotify', 'editinlineuse', 'else', 'enum', 'enumcount', 'event', \r\n    'exec', 'expands', 'explicit', 'export', 'exportstructs', 'extends', \r\n    'false', 'final', 'float', 'for', 'foreach', 'function', 'global', \r\n    'globalconfig', 'goto', 'guid', 'hidecategories', 'hidedropdown', \r\n    'hideparent', 'if', 'ignores', 'import', 'init', 'input', 'insert', \r\n    'instanced', 'int', 'intrinsic', 'invariant', 'iterator', 'latent', \r\n    'length', 'local', 'localized', 'long', 'mesh', 'model', 'mutable', 'name', \r\n    'native', 'nativereplication', 'new', 'noexport', 'none', \r\n    'noteditinlinenew', 'notplaceable', 'nousercreate', 'operator', 'optional', \r\n    'out', 'parseconfig', 'perobjectconfig', 'placeable', 'plane', 'pointer', \r\n    'postoperator', 'preoperator', 'private', 'protected', 'register', \r\n    'reliable', 'remove', 'replication', 'return', 'rng', 'rot', 'rotator', \r\n    'safereplace', 'scale', 'scriptconst', 'self', 'showcategories', \r\n    'simulated', 'singular', 'skip', 'sound', 'state', 'static', 'stop', \r\n    'string', 'struct', 'super', 'switch', 'texture', 'transient', 'travel', \r\n    'true', 'unreliable', 'until', 'var', 'vect', 'vector', 'void', 'while', \r\n    'within' \r\n  );\r\n\r\n  KeyIndices: array[0..732] of Integer = (\r\n    -1, -1, -1, -1, -1, -1, 78, -1, -1, -1, -1, 25, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, 79, -1, -1, -1, -1, -1, -1, -1, -1, 104, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 36, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, 34, -1, -1, -1, 18, -1, -1, -1, -1, -1, 30, 1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 63, -1, -1, -1, -1, 114, \r\n    -1, -1, 121, -1, -1, -1, -1, -1, 105, -1, -1, 108, -1, 135, 9, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, 117, 33, 109, -1, -1, -1, -1, -1, -1, 90, -1, -1, \r\n    -1, -1, -1, 106, -1, -1, -1, -1, -1, -1, -1, 124, -1, -1, -1, -1, 19, -1, \r\n    -1, -1, -1, 81, -1, 82, -1, -1, -1, -1, 40, 15, -1, -1, -1, 52, -1, 80, -1, \r\n    -1, -1, -1, -1, -1, 136, -1, -1, 61, -1, 113, -1, -1, -1, 83, -1, -1, -1, \r\n    -1, -1, -1, 27, -1, -1, 133, -1, -1, -1, -1, 62, -1, -1, -1, -1, -1, -1, -1, \r\n    76, -1, -1, -1, -1, -1, -1, -1, 126, -1, -1, -1, -1, -1, 2, -1, -1, -1, -1, \r\n    51, -1, -1, -1, -1, 44, -1, 22, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, 20, -1, -1, -1, 8, -1, -1, -1, 110, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, 96, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 65, -1, -1, \r\n    -1, -1, -1, -1, -1, 39, 24, -1, -1, -1, -1, 54, -1, 4, 123, -1, -1, -1, -1, \r\n    -1, -1, 50, 141, -1, -1, -1, -1, -1, -1, -1, 87, -1, -1, 21, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 60, -1, -1, -1, -1, -1, 85, -1, \r\n    -1, -1, -1, -1, 70, -1, 68, 131, -1, -1, 69, -1, -1, -1, -1, -1, 128, 26, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, 7, -1, -1, 142, -1, -1, 122, -1, 74, -1, -1, \r\n    -1, -1, -1, -1, -1, 13, -1, -1, -1, -1, 101, 119, -1, -1, 94, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, 100, -1, -1, -1, -1, -1, 89, -1, -1, 0, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 29, -1, -1, 92, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, 112, -1, -1, -1, -1, 67, -1, -1, 45, -1, \r\n    116, -1, -1, 132, 28, -1, -1, -1, 31, -1, -1, -1, 77, -1, -1, -1, -1, -1, \r\n    91, -1, 37, -1, -1, -1, -1, 35, -1, 6, -1, -1, -1, -1, -1, -1, -1, 97, -1, \r\n    -1, -1, -1, -1, 53, -1, 84, -1, -1, -1, -1, 56, 14, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, 23, -1, 107, -1, -1, -1, -1, 98, -1, -1, 75, -1, -1, -1, -1, \r\n    -1, 88, -1, -1, 103, -1, -1, 93, -1, -1, -1, -1, -1, -1, -1, -1, -1, 59, \r\n    139, 11, 42, -1, -1, 95, -1, -1, -1, -1, -1, 3, -1, -1, -1, 38, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, 16, -1, 46, -1, -1, -1, -1, -1, 102, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 111, -1, -1, 41, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, 48, 64, -1, -1, -1, -1, 86, -1, 58, 43, 72, -1, -1, 66, \r\n    137, 71, -1, -1, -1, -1, -1, 129, -1, -1, -1, -1, -1, -1, -1, -1, 17, 130, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, 120, -1, 73, -1, -1, 118, -1, -1, -1, \r\n    -1, -1, -1, 138, -1, -1, -1, 55, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, 10, -1, -1, -1, -1, -1, 5, -1, -1, -1, -1, -1, -1, -1, -1, -1, 115, -1, \r\n    -1, -1, -1, 32, 47, 49, -1, -1, -1, -1, -1, -1, -1, 57, -1, -1, -1, -1, -1, \r\n    -1, 125, 134, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 99, 12, -1, 127, \r\n    140, -1, -1 \r\n  );\r\n\r\n{$Q-}\r\nfunction TSynUnrealSyn.HashKey(Str: PWideChar): Cardinal;\r\nbegin\r\n  Result := 0;\r\n  while IsIdentChar(Str^) do\r\n  begin\r\n    Result := Result * 41 + Ord(Str^) * 701;\r\n    inc(Str);\r\n  end;\r\n  Result := Result mod 733;\r\n  fStringLen := Str - fToIdent;\r\nend;\r\n{$Q+}\r\n\r\nfunction TSynUnrealSyn.IdentKind(MayBe: PWideChar): TtkTokenKind;\r\nvar\r\n  Key: Cardinal;\r\nbegin\r\n  fToIdent := MayBe;\r\n  Key := HashKey(MayBe);\r\n  if Key <= High(fIdentFuncTable) then\r\n    Result := fIdentFuncTable[Key](KeyIndices[Key])\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nprocedure TSynUnrealSyn.InitIdent;\r\nvar\r\n  i: Integer;\r\nbegin\r\n  for i := Low(fIdentFuncTable) to High(fIdentFuncTable) do\r\n    if KeyIndices[i] = -1 then\r\n      fIdentFuncTable[i] := AltFunc;\r\n\r\n  fIdentFuncTable[410] := FuncAbstract;\r\n  fIdentFuncTable[71] := FuncAlways;\r\n  fIdentFuncTable[219] := FuncArray;\r\n  fIdentFuncTable[554] := FuncArraycount;\r\n  fIdentFuncTable[294] := FuncAssert;\r\n  fIdentFuncTable[681] := FuncAuto;\r\n  fIdentFuncTable[477] := FuncAutomated;\r\n  fIdentFuncTable[364] := FuncBool;\r\n  fIdentFuncTable[249] := FuncBoundingbox;\r\n  fIdentFuncTable[109] := FuncBoundingvolume;\r\n  fIdentFuncTable[675] := FuncBreak;\r\n  fIdentFuncTable[544] := FuncButton;\r\n  fIdentFuncTable[727] := FuncByte;\r\n  fIdentFuncTable[380] := FuncCache;\r\n  fIdentFuncTable[499] := FuncCacheexempt;\r\n  fIdentFuncTable[160] := FuncCase;\r\n  fIdentFuncTable[567] := FuncCatch;\r\n  fIdentFuncTable[635] := FuncClass;\r\n  fIdentFuncTable[64] := FuncCoerce;\r\n  fIdentFuncTable[147] := FuncCollapsecategories;\r\n  fIdentFuncTable[245] := FuncColor;\r\n  fIdentFuncTable[314] := FuncConfig;\r\n  fIdentFuncTable[231] := FuncConst;\r\n  fIdentFuncTable[510] := FuncContinue;\r\n  fIdentFuncTable[287] := FuncCoords;\r\n  fIdentFuncTable[11] := FuncCpptext;\r\n  fIdentFuncTable[355] := FuncCross;\r\n  fIdentFuncTable[189] := FuncDefault;\r\n  fIdentFuncTable[454] := FuncDefaultproperties;\r\n  fIdentFuncTable[425] := FuncDelegate;\r\n  fIdentFuncTable[70] := FuncDelete;\r\n  fIdentFuncTable[458] := FuncDependson;\r\n  fIdentFuncTable[696] := FuncDeprecated;\r\n  fIdentFuncTable[120] := FuncDo;\r\n  fIdentFuncTable[60] := FuncDontcollapsecategories;\r\n  fIdentFuncTable[475] := FuncDot;\r\n  fIdentFuncTable[49] := FuncEach;\r\n  fIdentFuncTable[470] := FuncEdfindable;\r\n  fIdentFuncTable[558] := FuncEditconst;\r\n  fIdentFuncTable[286] := FuncEditconstarray;\r\n  fIdentFuncTable[159] := FuncEditinline;\r\n  fIdentFuncTable[596] := FuncEditinlinenew;\r\n  fIdentFuncTable[545] := FuncEditinlinenotify;\r\n  fIdentFuncTable[614] := FuncEditinlineuse;\r\n  fIdentFuncTable[229] := FuncElse;\r\n  fIdentFuncTable[448] := FuncEnum;\r\n  fIdentFuncTable[569] := FuncEnumcount;\r\n  fIdentFuncTable[697] := FuncEvent;\r\n  fIdentFuncTable[605] := FuncExec;\r\n  fIdentFuncTable[698] := FuncExpands;\r\n  fIdentFuncTable[302] := FuncExplicit;\r\n  fIdentFuncTable[224] := FuncExport;\r\n  fIdentFuncTable[164] := FuncExportstructs;\r\n  fIdentFuncTable[491] := FuncExtends;\r\n  fIdentFuncTable[292] := FuncFalse;\r\n  fIdentFuncTable[662] := FuncFinal;\r\n  fIdentFuncTable[498] := FuncFloat;\r\n  fIdentFuncTable[706] := FuncFor;\r\n  fIdentFuncTable[613] := FuncForeach;\r\n  fIdentFuncTable[542] := FuncFunction;\r\n  fIdentFuncTable[330] := FuncGlobal;\r\n  fIdentFuncTable[176] := FuncGlobalconfig;\r\n  fIdentFuncTable[197] := FuncGoto;\r\n  fIdentFuncTable[89] := FuncGuid;\r\n  fIdentFuncTable[606] := FuncHidecategories;\r\n  fIdentFuncTable[278] := FuncHidedropdown;\r\n  fIdentFuncTable[618] := FuncHideparent;\r\n  fIdentFuncTable[445] := FuncIf;\r\n  fIdentFuncTable[344] := FuncIgnores;\r\n  fIdentFuncTable[348] := FuncImport;\r\n  fIdentFuncTable[342] := FuncInit;\r\n  fIdentFuncTable[620] := FuncInput;\r\n  fIdentFuncTable[615] := FuncInsert;\r\n  fIdentFuncTable[648] := FuncInstanced;\r\n  fIdentFuncTable[372] := FuncInt;\r\n  fIdentFuncTable[520] := FuncIntrinsic;\r\n  fIdentFuncTable[205] := FuncInvariant;\r\n  fIdentFuncTable[462] := FuncIterator;\r\n  fIdentFuncTable[6] := FuncLatent;\r\n  fIdentFuncTable[24] := FuncLength;\r\n  fIdentFuncTable[166] := FuncLocal;\r\n  fIdentFuncTable[152] := FuncLocalized;\r\n  fIdentFuncTable[154] := FuncLong;\r\n  fIdentFuncTable[182] := FuncMesh;\r\n  fIdentFuncTable[493] := FuncModel;\r\n  fIdentFuncTable[336] := FuncMutable;\r\n  fIdentFuncTable[611] := FuncName;\r\n  fIdentFuncTable[311] := FuncNative;\r\n  fIdentFuncTable[526] := FuncNativereplication;\r\n  fIdentFuncTable[407] := FuncNew;\r\n  fIdentFuncTable[128] := FuncNoexport;\r\n  fIdentFuncTable[468] := FuncNone;\r\n  fIdentFuncTable[428] := FuncNoteditinlinenew;\r\n  fIdentFuncTable[532] := FuncNotplaceable;\r\n  fIdentFuncTable[389] := FuncNousercreate;\r\n  fIdentFuncTable[548] := FuncOperator;\r\n  fIdentFuncTable[265] := FuncOptional;\r\n  fIdentFuncTable[485] := FuncOut;\r\n  fIdentFuncTable[517] := FuncParseconfig;\r\n  fIdentFuncTable[726] := FuncPerobjectconfig;\r\n  fIdentFuncTable[401] := FuncPlaceable;\r\n  fIdentFuncTable[385] := FuncPlane;\r\n  fIdentFuncTable[575] := FuncPointer;\r\n  fIdentFuncTable[529] := FuncPostoperator;\r\n  fIdentFuncTable[33] := FuncPreoperator;\r\n  fIdentFuncTable[103] := FuncPrivate;\r\n  fIdentFuncTable[134] := FuncProtected;\r\n  fIdentFuncTable[512] := FuncRegister;\r\n  fIdentFuncTable[106] := FuncReliable;\r\n  fIdentFuncTable[121] := FuncRemove;\r\n  fIdentFuncTable[253] := FuncReplication;\r\n  fIdentFuncTable[593] := FuncReturn;\r\n  fIdentFuncTable[440] := FuncRng;\r\n  fIdentFuncTable[178] := FuncRot;\r\n  fIdentFuncTable[94] := FuncRotator;\r\n  fIdentFuncTable[691] := FuncSafereplace;\r\n  fIdentFuncTable[450] := FuncScale;\r\n  fIdentFuncTable[119] := FuncScriptconst;\r\n  fIdentFuncTable[651] := FuncSelf;\r\n  fIdentFuncTable[386] := FuncShowcategories;\r\n  fIdentFuncTable[646] := FuncSimulated;\r\n  fIdentFuncTable[97] := FuncSingular;\r\n  fIdentFuncTable[370] := FuncSkip;\r\n  fIdentFuncTable[295] := FuncSound;\r\n  fIdentFuncTable[142] := FuncState;\r\n  fIdentFuncTable[713] := FuncStatic;\r\n  fIdentFuncTable[213] := FuncStop;\r\n  fIdentFuncTable[729] := FuncString;\r\n  fIdentFuncTable[354] := FuncStruct;\r\n  fIdentFuncTable[626] := FuncSuper;\r\n  fIdentFuncTable[636] := FuncSwitch;\r\n  fIdentFuncTable[345] := FuncTexture;\r\n  fIdentFuncTable[453] := FuncTransient;\r\n  fIdentFuncTable[192] := FuncTravel;\r\n  fIdentFuncTable[714] := FuncTrue;\r\n  fIdentFuncTable[108] := FuncUnreliable;\r\n  fIdentFuncTable[173] := FuncUntil;\r\n  fIdentFuncTable[619] := FuncVar;\r\n  fIdentFuncTable[658] := FuncVect;\r\n  fIdentFuncTable[543] := FuncVector;\r\n  fIdentFuncTable[730] := FuncVoid;\r\n  fIdentFuncTable[303] := FuncWhile;\r\n  fIdentFuncTable[367] := FuncWithin;\r\nend;\r\n\r\nfunction TSynUnrealSyn.AltFunc(Index: Integer): TtkTokenKind;\r\nbegin\r\n  Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynUnrealSyn.FuncAbstract(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey2\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynUnrealSyn.FuncAlways(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey2\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynUnrealSyn.FuncArray(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynUnrealSyn.FuncArraycount(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynUnrealSyn.FuncAssert(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynUnrealSyn.FuncAuto(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynUnrealSyn.FuncAutomated(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynUnrealSyn.FuncBool(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynUnrealSyn.FuncBoundingbox(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynUnrealSyn.FuncBoundingvolume(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynUnrealSyn.FuncBreak(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynUnrealSyn.FuncButton(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynUnrealSyn.FuncByte(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynUnrealSyn.FuncCache(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynUnrealSyn.FuncCacheexempt(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynUnrealSyn.FuncCase(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynUnrealSyn.FuncCatch(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynUnrealSyn.FuncClass(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynUnrealSyn.FuncCoerce(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynUnrealSyn.FuncCollapsecategories(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynUnrealSyn.FuncColor(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynUnrealSyn.FuncConfig(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynUnrealSyn.FuncConst(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey2\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynUnrealSyn.FuncContinue(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynUnrealSyn.FuncCoords(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynUnrealSyn.FuncCpptext(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\n\r\nend;\r\n\r\nfunction TSynUnrealSyn.FuncCross(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkSymbol\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynUnrealSyn.FuncDefault(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynUnrealSyn.FuncDefaultproperties(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynUnrealSyn.FuncDelegate(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey2\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynUnrealSyn.FuncDelete(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynUnrealSyn.FuncDependson(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynUnrealSyn.FuncDeprecated(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey2\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynUnrealSyn.FuncDo(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynUnrealSyn.FuncDontcollapsecategories(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynUnrealSyn.FuncDot(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkSymbol\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynUnrealSyn.FuncEach(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynUnrealSyn.FuncEdfindable(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey2\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynUnrealSyn.FuncEditconst(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey2\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynUnrealSyn.FuncEditconstarray(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey2\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynUnrealSyn.FuncEditinline(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey2\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynUnrealSyn.FuncEditinlinenew(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey2\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynUnrealSyn.FuncEditinlinenotify(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey2\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynUnrealSyn.FuncEditinlineuse(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey2\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynUnrealSyn.FuncElse(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynUnrealSyn.FuncEnum(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynUnrealSyn.FuncEnumcount(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynUnrealSyn.FuncEvent(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynUnrealSyn.FuncExec(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynUnrealSyn.FuncExpands(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynUnrealSyn.FuncExplicit(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynUnrealSyn.FuncExport(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynUnrealSyn.FuncExportstructs(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynUnrealSyn.FuncExtends(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynUnrealSyn.FuncFalse(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynUnrealSyn.FuncFinal(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey2\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynUnrealSyn.FuncFloat(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynUnrealSyn.FuncFor(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynUnrealSyn.FuncForeach(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynUnrealSyn.FuncFunction(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynUnrealSyn.FuncGlobal(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynUnrealSyn.FuncGlobalconfig(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynUnrealSyn.FuncGoto(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynUnrealSyn.FuncGuid(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynUnrealSyn.FuncHidecategories(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynUnrealSyn.FuncHidedropdown(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynUnrealSyn.FuncHideparent(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynUnrealSyn.FuncIf(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynUnrealSyn.FuncIgnores(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynUnrealSyn.FuncImport(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynUnrealSyn.FuncInit(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynUnrealSyn.FuncInput(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynUnrealSyn.FuncInsert(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynUnrealSyn.FuncInstanced(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey2\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynUnrealSyn.FuncInt(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynUnrealSyn.FuncIntrinsic(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey2\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynUnrealSyn.FuncInvariant(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey2\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynUnrealSyn.FuncIterator(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynUnrealSyn.FuncLatent(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey2\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynUnrealSyn.FuncLength(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynUnrealSyn.FuncLocal(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynUnrealSyn.FuncLocalized(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey2\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynUnrealSyn.FuncLong(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynUnrealSyn.FuncMesh(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynUnrealSyn.FuncModel(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynUnrealSyn.FuncMutable(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynUnrealSyn.FuncName(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynUnrealSyn.FuncNative(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey2\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynUnrealSyn.FuncNativereplication(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey2\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynUnrealSyn.FuncNew(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynUnrealSyn.FuncNoexport(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey2\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynUnrealSyn.FuncNone(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynUnrealSyn.FuncNoteditinlinenew(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynUnrealSyn.FuncNotplaceable(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey2\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynUnrealSyn.FuncNousercreate(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey2\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynUnrealSyn.FuncOperator(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynUnrealSyn.FuncOptional(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynUnrealSyn.FuncOut(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynUnrealSyn.FuncParseconfig(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynUnrealSyn.FuncPerobjectconfig(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynUnrealSyn.FuncPlaceable(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey2\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynUnrealSyn.FuncPlane(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynUnrealSyn.FuncPointer(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynUnrealSyn.FuncPostoperator(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynUnrealSyn.FuncPreoperator(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynUnrealSyn.FuncPrivate(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey2\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynUnrealSyn.FuncProtected(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey2\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynUnrealSyn.FuncRegister(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynUnrealSyn.FuncReliable(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey2\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynUnrealSyn.FuncRemove(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey2\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynUnrealSyn.FuncReplication(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey2\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynUnrealSyn.FuncReturn(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynUnrealSyn.FuncRng(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynUnrealSyn.FuncRot(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynUnrealSyn.FuncRotator(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynUnrealSyn.FuncSafereplace(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey2\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynUnrealSyn.FuncScale(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynUnrealSyn.FuncScriptconst(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynUnrealSyn.FuncSelf(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynUnrealSyn.FuncShowcategories(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynUnrealSyn.FuncSimulated(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey2\r\n  else\r\n    Result := tkIdentifier;\r\n\r\nend;\r\n\r\nfunction TSynUnrealSyn.FuncSingular(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey2\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynUnrealSyn.FuncSkip(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynUnrealSyn.FuncSound(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynUnrealSyn.FuncState(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynUnrealSyn.FuncStatic(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey2\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynUnrealSyn.FuncStop(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynUnrealSyn.FuncString(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynUnrealSyn.FuncStruct(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynUnrealSyn.FuncSuper(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey2\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynUnrealSyn.FuncSwitch(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynUnrealSyn.FuncTexture(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynUnrealSyn.FuncTransient(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey2\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynUnrealSyn.FuncTravel(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynUnrealSyn.FuncTrue(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynUnrealSyn.FuncUnreliable(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey2\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynUnrealSyn.FuncUntil(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynUnrealSyn.FuncVar(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynUnrealSyn.FuncVect(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynUnrealSyn.FuncVector(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynUnrealSyn.FuncVoid(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynUnrealSyn.FuncWhile(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynUnrealSyn.FuncWithin(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nconstructor TSynUnrealSyn.Create(AOwner: TComponent);\r\nbegin\r\n  inherited Create(AOwner);\r\n\r\n  fCaseSensitive := False;\r\n\r\n  fCommentAttri := TSynHighlighterAttributes.Create(SYNS_AttrComment, SYNS_FriendlyAttrComment);\r\n  fCommentAttri.Style:= [fsItalic];\r\n  AddAttribute(fCommentAttri);\r\n  fIdentifierAttri := TSynHighlighterAttributes.Create(SYNS_AttrIdentifier, SYNS_FriendlyAttrIdentifier);\r\n  AddAttribute(fIdentifierAttri);\r\n  fInvalidAttri := TSynHighlighterAttributes.Create(SYNS_AttrIllegalChar, SYNS_FriendlyAttrIllegalChar);\r\n  AddAttribute(fInvalidAttri);\r\n  fKeyAttri := TSynHighlighterAttributes.Create(SYNS_AttrReservedWord, SYNS_FriendlyAttrReservedWord);\r\n  fKeyAttri.Style:= [fsBold];\r\n  AddAttribute(fKeyAttri);\r\n  fKey2Attri := TSynHighlighterAttributes.Create(SYNS_AttrSecondReservedWord, SYNS_FriendlyAttrSecondReservedWord);\r\n  fKey2Attri.Style:= [fsBold];\r\n  AddAttribute(fKey2Attri);\r\n  fNumberAttri := TSynHighlighterAttributes.Create(SYNS_AttrNumber, SYNS_FriendlyAttrNumber);\r\n  AddAttribute(fNumberAttri);\r\n  fSpaceAttri := TSynHighlighterAttributes.Create(SYNS_AttrSpace, SYNS_FriendlyAttrSpace);\r\n  AddAttribute(fSpaceAttri);\r\n  fStringAttri := TSynHighlighterAttributes.Create(SYNS_AttrString, SYNS_FriendlyAttrString);\r\n  AddAttribute(fStringAttri);\r\n  fString2Attri := TSynHighlighterAttributes.Create(SYNS_AttrSingleString, SYNS_FriendlyAttrSingleString);\r\n  AddAttribute(fString2Attri);\r\n  fSymbolAttri := TSynHighlighterAttributes.Create(SYNS_AttrSymbol, SYNS_FriendlyAttrSymbol);\r\n  AddAttribute(fSymbolAttri);\r\n  fDirecAttri := TSynHighlighterAttributes.Create(SYNS_AttrDirective, SYNS_FriendlyAttrDirective);\r\n  AddAttribute(fDirecAttri);\r\n  SetAttributesOnChange(DefHighlightChange);\r\n  InitIdent;\r\n  fRange := rsUnknown;\r\n  fDefaultFilter := SYNS_FilterCPP;\r\nend; { Create }\r\n\r\nprocedure TSynUnrealSyn.AnsiCProc;\r\nbegin\r\n  fTokenID := tkComment;\r\n  case FLine[Run] of\r\n    #0:\r\n      begin\r\n        NullProc;\r\n        exit;\r\n      end;\r\n    #10:\r\n      begin\r\n        LFProc;\r\n        exit;\r\n      end;\r\n    #13:\r\n      begin\r\n        CRProc;\r\n        exit;\r\n      end;\r\n  end;\r\n\r\n  while not IsLineEnd(Run) do\r\n    case FLine[Run] of\r\n      '*':\r\n        if fLine[Run + 1] = '/' then\r\n        begin\r\n          inc(Run, 2);\r\n          if fRange = rsDirectiveComment then                              \r\n            fRange := rsDirective\r\n          else\r\n            fRange := rsUnKnown;\r\n          break;\r\n        end else\r\n          inc(Run);\r\n      #10: break;\r\n      #13: break;\r\n    else inc(Run);\r\n    end;\r\nend;\r\n\r\nprocedure TSynUnrealSyn.AndSymbolProc;\r\nbegin\r\n  fTokenID := tkSymbol;\r\n  case FLine[Run + 1] of\r\n    '=':                               {and assign}\r\n      begin\r\n        inc(Run, 2);\r\n        FExtTokenID := xtkAndAssign;\r\n      end;\r\n    '&':                               {logical and}\r\n      begin\r\n        inc(Run, 2);\r\n        FExtTokenID := xtkLogAnd;\r\n      end;\r\n  else                                 {and}\r\n    begin\r\n      inc(Run);\r\n      FExtTokenID := xtkAnd;\r\n    end;\r\n  end;\r\nend;\r\n\r\nprocedure TSynUnrealSyn.AsciiCharProc;\r\nbegin\r\n  fTokenID := tkString2;\r\n  repeat\r\n    if IsLineEnd(Run) then break;\r\n    if FLine[Run] = #92 then                             {backslash}\r\n        {if we have an escaped single quote it doesn't count}\r\n      if FLine[Run + 1] = #39 then inc(Run);\r\n    inc(Run);\r\n  until FLine[Run] = #39;\r\n  if not IsLineEnd(Run) then inc(Run);\r\nend;\r\n\r\nprocedure TSynUnrealSyn.BraceCloseProc;\r\nbegin\r\n  inc(Run);\r\n  fTokenId := tkSymbol;\r\n  FExtTokenID := xtkBraceClose;\r\nend;\r\n\r\nprocedure TSynUnrealSyn.BraceOpenProc;\r\nbegin\r\n  inc(Run);\r\n  fTokenId := tkSymbol;\r\n  FExtTokenID := xtkBraceOpen;\r\nend;\r\n\r\nprocedure TSynUnrealSyn.CRProc;\r\nbegin\r\n  fTokenID := tkSpace;\r\n  Inc(Run);\r\n  if fLine[Run + 1] = #10 then Inc(Run);\r\nend;\r\n\r\nprocedure TSynUnrealSyn.ColonProc;\r\nbegin\r\n  fTokenID := tkSymbol;\r\n  Case FLine[Run + 1] of\r\n    ':':                               {scope resolution operator}\r\n      begin\r\n        inc(Run, 2);\r\n        FExtTokenID := xtkScopeResolution;\r\n      end;\r\n  else                                 {colon}\r\n    begin\r\n      inc(Run);\r\n      FExtTokenID := xtkColon;\r\n    end;\r\n  end;\r\nend;\r\n\r\nprocedure TSynUnrealSyn.CommaProc;\r\nbegin\r\n  inc(Run);\r\n  fTokenID := tkSymbol;\r\n  FExtTokenID := xtkComma;\r\nend;\r\n\r\nprocedure TSynUnrealSyn.DirectiveProc;\r\nbegin\r\n  if IsLineEnd(Run) then\r\n  begin\r\n    if (Run <= 0) then\r\n      fRange := rsUnknown;\r\n    NextProcedure;\r\n  end\r\n  else\r\n  begin\r\n    fTokenID := tkDirective;\r\n    while TRUE do\r\n      case fLine[Run] of\r\n        '/': // comment?\r\n          begin\r\n            if fLine[Run + 1] = '/' then // is end of directive as well\r\n              break\r\n            else if fLine[Run + 1] = '*' then\r\n            begin // might be embedded only\r\n              fRange := rsDirectiveComment;\r\n              break;\r\n            end else\r\n              Inc(Run);\r\n          end;\r\n        #0, #10, #13:\r\n          begin\r\n            fRange := rsUnknown;\r\n            break;\r\n          end;\r\n        else Inc(Run);\r\n      end;\r\n  end;\r\nend;\r\n\r\nprocedure TSynUnrealSyn.EqualProc;\r\nbegin\r\n  fTokenID := tkSymbol;\r\n  case FLine[Run + 1] of\r\n    '=':                               {logical equal}\r\n      begin\r\n        inc(Run, 2);\r\n        FExtTokenID := xtkLogEqual;\r\n      end;\r\n  else                                 {assign}\r\n    begin\r\n      inc(Run);\r\n      FExtTokenID := xtkAssign;\r\n    end;\r\n  end;\r\nend;\r\n\r\nprocedure TSynUnrealSyn.GreaterProc;\r\nbegin\r\n  fTokenID := tkSymbol;\r\n  case FLine[Run + 1] of\r\n    '=':                               {greater than or equal to}\r\n      begin\r\n        inc(Run, 2);\r\n        FExtTokenID := xtkGreaterThanEqual;\r\n      end;\r\n    '>':\r\n      begin\r\n        if FLine[Run + 2] = '=' then   {shift right assign}\r\n        begin\r\n          inc(Run, 3);\r\n          FExtTokenID := xtkShiftRightAssign;\r\n        end\r\n        else                           {shift right}\r\n        begin\r\n          inc(Run, 2);\r\n          FExtTokenID := xtkShiftRight;\r\n        end;\r\n      end;\r\n  else                                 {greater than}\r\n    begin\r\n      inc(Run);\r\n      FExtTokenID := xtkGreaterThan;\r\n    end;\r\n  end;\r\nend;\r\n\r\nprocedure TSynUnrealSyn.QuestionProc;\r\nbegin\r\n  fTokenID := tkSymbol;                {conditional}\r\n  FExtTokenID := xtkQuestion;\r\n  inc(Run);\r\nend;\r\n\r\nprocedure TSynUnrealSyn.IdentProc;\r\nbegin\r\n  fTokenID := IdentKind((fLine + Run));\r\n  inc(Run, fStringLen);\r\n  while IsIdentChar(fLine[Run]) do inc(Run);\r\nend;\r\n\r\nprocedure TSynUnrealSyn.LFProc;\r\nbegin\r\n  fTokenID := tkSpace;\r\n  inc(Run);\r\nend;\r\n\r\nprocedure TSynUnrealSyn.LowerProc;\r\nbegin\r\n  fTokenID := tkSymbol;\r\n  case FLine[Run + 1] of\r\n    '=':                               {less than or equal to}\r\n      begin\r\n        inc(Run, 2);\r\n        FExtTokenID := xtkLessThanEqual;\r\n      end;\r\n    '<':\r\n      begin\r\n        if FLine[Run + 2] = '=' then   {shift left assign}\r\n        begin\r\n          inc(Run, 3);\r\n          FExtTokenID := xtkShiftLeftAssign;\r\n        end\r\n        else                           {shift left}\r\n        begin\r\n          inc(Run, 2);\r\n          FExtTokenID := xtkShiftLeft;\r\n        end;\r\n      end;\r\n  else                                 {less than}\r\n    begin\r\n      inc(Run);\r\n      FExtTokenID := xtkLessThan;\r\n    end;\r\n  end;\r\nend;\r\n\r\nprocedure TSynUnrealSyn.MinusProc;\r\nbegin\r\n  fTokenID := tkSymbol;\r\n  case FLine[Run + 1] of\r\n    '=':                               {subtract assign}\r\n      begin\r\n        inc(Run, 2);\r\n        FExtTokenID := xtkSubtractAssign;\r\n      end;\r\n    '-':                               {decrement}\r\n      begin\r\n        inc(Run, 2);\r\n        FExtTokenID := xtkDecrement;\r\n      end;\r\n    '>':                               {arrow}\r\n      begin\r\n        inc(Run, 2);\r\n        FExtTokenID := xtkArrow;\r\n      end;\r\n  else                                 {subtract}\r\n    begin\r\n      inc(Run);\r\n      FExtTokenID := xtkSubtract;\r\n    end;\r\n  end;\r\nend;\r\n\r\nprocedure TSynUnrealSyn.ModSymbolProc;\r\nbegin\r\n  fTokenID := tkSymbol;\r\n  case FLine[Run + 1] of\r\n    '=':                               {mod assign}\r\n      begin\r\n        inc(Run, 2);\r\n        FExtTokenID := xtkModAssign;\r\n      end;\r\n  else                                 {mod}\r\n    begin\r\n      inc(Run);\r\n      FExtTokenID := xtkMod;\r\n    end;\r\n  end;\r\nend;\r\n\r\nprocedure TSynUnrealSyn.NotSymbolProc;\r\nbegin\r\n  fTokenID := tkSymbol;\r\n  case FLine[Run + 1] of\r\n    '=':                               {not equal}\r\n      begin\r\n        inc(Run, 2);\r\n        FExtTokenID := xtkNotEqual;\r\n      end;\r\n  else                                 {not}\r\n    begin\r\n      inc(Run);\r\n      FExtTokenID := xtkLogComplement;\r\n    end;\r\n  end;\r\nend;\r\n\r\nprocedure TSynUnrealSyn.NullProc;\r\nbegin\r\n  fTokenID := tkNull;\r\n  inc(Run);\r\nend;\r\n\r\nprocedure TSynUnrealSyn.NumberProc;\r\n\r\n  function IsNumberChar: Boolean;\r\n  begin\r\n    case fLine[Run] of\r\n      '0'..'9', 'A'..'F', 'a'..'f', '.', 'u', 'U', 'l', 'L', 'x', 'X':\r\n        Result := True;\r\n      else\r\n        Result := False;\r\n    end;\r\n  end;\r\n\r\nbegin\r\n  inc(Run);\r\n  fTokenID := tkNumber;\r\n  while IsNumberChar do\r\n  begin\r\n    case FLine[Run] of\r\n      '.':\r\n        if FLine[Run + 1] = '.' then break;\r\n    end;\r\n    inc(Run);\r\n  end;\r\nend;\r\n\r\nprocedure TSynUnrealSyn.OrSymbolProc;\r\nbegin\r\n  fTokenID := tkSymbol;\r\n  case FLine[Run + 1] of\r\n    '=':                               {or assign}\r\n      begin\r\n        inc(Run, 2);\r\n        FExtTokenID := xtkIncOrAssign;\r\n      end;\r\n    '|':                               {logical or}\r\n      begin\r\n        inc(Run, 2);\r\n        FExtTokenID := xtkLogOr;\r\n      end;\r\n  else                                 {or}\r\n    begin\r\n      inc(Run);\r\n      FExtTokenID := xtkIncOr;\r\n    end;\r\n  end;\r\nend;\r\n\r\nprocedure TSynUnrealSyn.PlusProc;\r\nbegin\r\n  fTokenID := tkSymbol;\r\n  case FLine[Run + 1] of\r\n    '=':                               {add assign}\r\n      begin\r\n        inc(Run, 2);\r\n        FExtTokenID := xtkAddAssign;\r\n      end;\r\n    '+':                               {increment}\r\n      begin\r\n        inc(Run, 2);\r\n        FExtTokenID := xtkIncrement;\r\n      end;\r\n  else                                 {add}\r\n    begin\r\n      inc(Run);\r\n      FExtTokenID := xtkAdd;\r\n    end;\r\n  end;\r\nend;\r\n\r\nprocedure TSynUnrealSyn.PointProc;\r\nbegin\r\n  fTokenID := tkSymbol;\r\n  if (FLine[Run + 1] = '.') and (FLine[Run + 2] = '.') then\r\n    begin                              {ellipse}\r\n      inc(Run, 3);\r\n      FExtTokenID := xtkEllipse;\r\n    end\r\n  else                                 {point}\r\n    begin\r\n      inc(Run);\r\n      FExtTokenID := xtkPoint;\r\n    end;\r\nend;\r\n\r\nprocedure TSynUnrealSyn.RoundCloseProc;\r\nbegin\r\n  inc(Run);\r\n  fTokenID := tkSymbol;\r\n  FExtTokenID := xtkRoundClose;\r\n  dec(FRoundCount);\r\nend;\r\n\r\nprocedure TSynUnrealSyn.RoundOpenProc;\r\nbegin\r\n  inc(Run);\r\n  FTokenID := tkSymbol;\r\n  FExtTokenID := xtkRoundOpen;\r\n  inc(FRoundCount);\r\nend;\r\n\r\nprocedure TSynUnrealSyn.SemiColonProc;\r\nbegin\r\n  inc(Run);\r\n  fTokenID := tkSymbol;\r\n  FExtTokenID := xtkSemiColon;\r\nend;\r\n\r\nprocedure TSynUnrealSyn.SlashProc;\r\nbegin\r\n  case FLine[Run + 1] of\r\n    '/':                               {c++ style comments}\r\n      begin\r\n        fTokenID := tkComment;\r\n        inc(Run, 2);\r\n       while not IsLineEnd(Run) do Inc(Run);\r\n      end;\r\n    '*':                               {c style comments}\r\n      begin\r\n        fTokenID := tkComment;\r\n        if fRange <> rsDirectiveComment then                               \r\n          fRange := rsAnsiC;\r\n        inc(Run, 2);\r\n        while not IsLineEnd(Run) do\r\n          case fLine[Run] of\r\n            '*':\r\n              if fLine[Run + 1] = '/' then\r\n              begin\r\n                inc(Run, 2);\r\n                if fRange = rsDirectiveComment then\r\n                  fRange := rsDirective\r\n                else\r\n                  fRange := rsUnKnown;\r\n                break;\r\n              end else inc(Run);\r\n            #10, #13:\r\n              begin\r\n                if fRange = rsDirectiveComment then\r\n                  fRange := rsAnsiC;\r\n                break;\r\n              end;\r\n          else inc(Run);\r\n          end;\r\n      end;\r\n    '=':                               {divide assign}\r\n      begin\r\n        inc(Run, 2);\r\n        fTokenID := tkSymbol;\r\n        FExtTokenID := xtkDivideAssign;\r\n      end;\r\n  else                                 {divide}\r\n    begin\r\n      inc(Run);\r\n      fTokenID := tkSymbol;\r\n      FExtTokenID := xtkDivide;\r\n    end;\r\n  end;\r\nend;\r\n\r\nprocedure TSynUnrealSyn.SpaceProc;\r\nbegin\r\n  inc(Run);\r\n  fTokenID := tkSpace;\r\n  while (FLine[Run] <= #32) and not IsLineEnd(Run) do inc(Run);\r\nend;\r\n\r\nprocedure TSynUnrealSyn.SquareCloseProc;\r\nbegin\r\n  inc(Run);\r\n  fTokenID := tkSymbol;\r\n  FExtTokenID := xtkSquareClose;\r\n  dec(FSquareCount);\r\nend;\r\n\r\nprocedure TSynUnrealSyn.SquareOpenProc;\r\nbegin\r\n  inc(Run);\r\n  fTokenID := tkSymbol;\r\n  FExtTokenID := xtkSquareOpen;\r\n  inc(FSquareCount);\r\nend;\r\n\r\nprocedure TSynUnrealSyn.StarProc;\r\nbegin\r\n  fTokenID := tkSymbol;\r\n  case FLine[Run + 1] of\r\n    '=':                               {multiply assign}\r\n      begin\r\n        inc(Run, 2);\r\n        FExtTokenID := xtkMultiplyAssign;\r\n      end;\r\n  else                                 {star}\r\n    begin\r\n      inc(Run);\r\n      FExtTokenID := xtkStar;\r\n    end;\r\n  end;\r\nend;\r\n\r\nprocedure TSynUnrealSyn.StringProc;\r\nbegin\r\n  fTokenID := tkString;\r\n  if (FLine[Run + 1] = #34) and (FLine[Run + 2] = #34) then inc(Run, 2);\r\n  repeat\r\n    if IsLineEnd(Run) then break;\r\n    if FLine[Run] = #92 then                             {backslash}\r\n        case FLine[Run + 1] of\r\n          #10: inc(Run);               {line continuation character}\r\n          #34: inc(Run);               {escaped quote doesn't count}\r\n          #92: inc(Run);\r\n        end;\r\n    inc(Run);\r\n  until FLine[Run] = #34;\r\n  if not IsLineEnd(Run) then inc(Run);\r\nend;\r\n\r\nprocedure TSynUnrealSyn.DollarSignProc;\r\nbegin\r\n  fTokenID := tkSymbol;\r\n  inc(run);\r\nend;\r\n\r\n\r\nprocedure TSynUnrealSyn.TildeProc;\r\nbegin\r\n  inc(Run);                            {bitwise complement}\r\n  fTokenId := tkSymbol;\r\n  FExtTokenID := xtkBitComplement;\r\nend;\r\n\r\nprocedure TSynUnrealSyn.XOrSymbolProc;\r\nbegin\r\n  fTokenID := tkSymbol;\r\n  Case FLine[Run + 1] of\r\n  \t'=':                               {xor assign}\r\n      begin\r\n        inc(Run, 2);\r\n        FExtTokenID := xtkXorAssign;\r\n      end;\r\n  else                                 {xor}\r\n    begin\r\n      inc(Run);\r\n      FExtTokenID := xtkXor;\r\n    end;\r\n  end;\r\nend;\r\n\r\nprocedure TSynUnrealSyn.UnknownProc;\r\nbegin\r\n  inc(Run);\r\n  fTokenID := tkUnknown;\r\nend;\r\n\r\nprocedure TSynUnrealSyn.Next;\r\nbegin\r\n  fTokenPos := Run;\r\n  case fRange of\r\n    rsAnsiC, rsDirectiveComment: AnsiCProc;\r\n    rsDirective: DirectiveProc;\r\n  else\r\n    begin\r\n      fRange := rsUnknown;\r\n      NextProcedure\r\n    end;\r\n  end;\r\n  inherited;\r\nend;\r\n\r\nprocedure TSynUnrealSyn.NextProcedure;\r\nbegin\r\n  case fLine[Run] of\r\n    '&': AndSymbolProc;\r\n    #39: AsciiCharProc;\r\n    '}': BraceCloseProc;\r\n    '{': BraceOpenProc;\r\n    #13: CRProc;\r\n    ':': ColonProc;\r\n    ',': CommaProc;\r\n    '#': DirectiveProc;\r\n    '=': EqualProc;\r\n    '>': GreaterProc;\r\n    '?': QuestionProc;\r\n    'A'..'Z', 'a'..'z', '_': IdentProc;\r\n    #10: LFProc;\r\n    '<': LowerProc;\r\n    '-': MinusProc;\r\n    '%': ModSymbolProc;\r\n    '!': NotSymbolProc;\r\n    #0: NullProc;\r\n    '0'..'9': NumberProc;\r\n    '|': OrSymbolProc;\r\n    '+': PlusProc;\r\n    '.': PointProc;\r\n    ')': RoundCloseProc;\r\n    '(': RoundOpenProc;\r\n    ';': SemiColonProc;\r\n    '/': SlashProc;\r\n    #1..#9, #11, #12, #14..#32: SpaceProc;\r\n    ']': SquareCloseProc;\r\n    '[': SquareOpenProc;\r\n    '*': StarProc;\r\n    #34: StringProc;\r\n    '$', '@': DollarSignProc;\r\n    '~': TildeProc;\r\n    '^': XOrSymbolProc;\r\n    else UnknownProc;\r\n  end;\r\nend;\r\n\r\nfunction TSynUnrealSyn.GetDefaultAttribute(Index: integer): TSynHighlighterAttributes;\r\nbegin\r\n  case Index of\r\n    SYN_ATTR_COMMENT: Result := fCommentAttri;\r\n    SYN_ATTR_KEYWORD: Result := fKeyAttri;\r\n    SYN_ATTR_WHITESPACE: Result := fSpaceAttri;\r\n    SYN_ATTR_STRING: Result := fStringAttri;\r\n    SYN_ATTR_IDENTIFIER: Result := fIdentifierAttri;\r\n    SYN_ATTR_SYMBOL: Result := fSymbolAttri;\r\n  else\r\n    Result := nil;\r\n  end;\r\nend;\r\n\r\nfunction TSynUnrealSyn.GetEol: Boolean;\r\nbegin\r\n  Result := Run = fLineLen + 1;\r\nend;\r\n\r\nfunction TSynUnrealSyn.GetRange: Pointer;\r\nbegin\r\n  Result := Pointer(fRange);\r\nend;\r\n\r\nfunction TSynUnrealSyn.GetTokenID: TtkTokenKind;\r\nbegin\r\n  Result := fTokenId;\r\nend;\r\n\r\nfunction TSynUnrealSyn.GetExtTokenID: TxtkTokenKind;\r\nbegin\r\n  Result := FExtTokenID;\r\nend;\r\n\r\n\r\nfunction TSynUnrealSyn.IsFilterStored: Boolean;\r\nbegin\r\n  Result := fDefaultFilter <> SYNS_FilterCPP;\r\nend; { IsFilterStored }\r\n\r\n\r\nfunction TSynUnrealSyn.GetTokenAttribute: TSynHighlighterAttributes;\r\nbegin\r\n  case fTokenID of\r\n    tkComment: Result := fCommentAttri;\r\n    tkDirective: Result := fDirecAttri;\r\n    tkIdentifier: Result := fIdentifierAttri;\r\n    tkKey: Result := fKeyAttri;\r\n    tkKey2: Result := fKey2Attri;\r\n    tkNumber: Result := fNumberAttri;\r\n    tkSpace: Result := fSpaceAttri;\r\n    tkString: Result := fStringAttri;\r\n    tkString2: Result := fString2Attri;\r\n    tkSymbol: Result := fSymbolAttri;\r\n    tkUnknown: Result := fInvalidAttri;\r\n    else Result := nil;\r\n  end;\r\nend;\r\n\r\nfunction TSynUnrealSyn.GetTokenKind: integer;\r\nbegin\r\n  Result := Ord(GetTokenID);\r\nend;\r\n\r\nprocedure TSynUnrealSyn.ResetRange;\r\nbegin\r\n  fRange:= rsUnknown;\r\nend;\r\n\r\nprocedure TSynUnrealSyn.SetRange(Value: Pointer);\r\nbegin\r\n  fRange := TRangeState(Value);\r\nend;\r\n\r\nprocedure TSynUnrealSyn.EnumUserSettings(settings: TStrings);\r\nbegin\r\n  { returns the user settings that exist in the registry }\r\n{$IFNDEF SYN_CLX}\r\n  with TBetterRegistry.Create do\r\n  begin\r\n    try\r\n      RootKey := HKEY_LOCAL_MACHINE;\r\n      if OpenKeyReadOnly('\\SOFTWARE\\Borland\\C++Builder') then\r\n      begin\r\n        try\r\n          GetKeyNames(settings);\r\n        finally\r\n          CloseKey;\r\n        end;\r\n      end;\r\n    finally\r\n      Free;\r\n    end;\r\n  end;\r\n{$ENDIF}\r\nend;\r\n\r\nfunction TSynUnrealSyn.UseUserSettings(settingIndex: integer): boolean;\r\n// Possible parameter values:\r\n//   index into TStrings returned by EnumUserSettings\r\n// Possible return values:\r\n//   true : settings were read and used\r\n//   false: problem reading settings or invalid version specified - old settings\r\n//          were preserved\r\n\r\n{$IFNDEF SYN_CLX}\r\n  function ReadCPPBSettings(settingIndex: integer): boolean;\r\n\r\n    function ReadCPPBSetting(settingTag: string; attri: TSynHighlighterAttributes; key: string): boolean;\r\n\r\n      function ReadCPPB1(settingTag: string; attri: TSynHighlighterAttributes; name: string): boolean;\r\n      var\r\n        i: integer;\r\n      begin\r\n        for i := 1 to Length(name) do\r\n          if name[i] = ' ' then name[i] := '_';\r\n        Result := attri.LoadFromBorlandRegistry(HKEY_CURRENT_USER,\r\n             '\\SOFTWARE\\Borland\\C++Builder\\'+settingTag+'\\Highlight',name,true);\r\n      end; { ReadCPPB1 }\r\n\r\n      function ReadCPPB3OrMore(settingTag: string; attri: TSynHighlighterAttributes; key: string): boolean;\r\n      begin\r\n        Result := attri.LoadFromBorlandRegistry(HKEY_CURRENT_USER,\r\n                 '\\Software\\Borland\\C++Builder\\'+settingTag+'\\Editor\\Highlight',\r\n                 key,false);\r\n      end; { ReadCPPB3OrMore }\r\n\r\n    begin { ReadCPPBSetting }\r\n      try\r\n        if (settingTag[1] = '1')\r\n          then Result := ReadCPPB1(settingTag,attri,key)\r\n          else Result := ReadCPPB3OrMore(settingTag,attri,key);\r\n      except Result := false; end;\r\n    end; { ReadCPPBSetting }\r\n\r\n  var\r\n    tmpStringAttri    : TSynHighlighterAttributes;\r\n    tmpNumberAttri    : TSynHighlighterAttributes;\r\n    tmpKeyAttri       : TSynHighlighterAttributes;\r\n    tmpSymbolAttri    : TSynHighlighterAttributes;\r\n    tmpCommentAttri   : TSynHighlighterAttributes;\r\n    tmpIdentifierAttri: TSynHighlighterAttributes;\r\n    tmpInvalidAttri   : TSynHighlighterAttributes;\r\n    tmpSpaceAttri     : TSynHighlighterAttributes;\r\n    tmpDirecAttri     : TSynHighlighterAttributes;\r\n    sl                 : TStringList;\r\n\r\n  begin { ReadCPPBSettings }\r\n    sl := TStringList.Create;\r\n    try\r\n      EnumUserSettings(sl);\r\n      if settingIndex >= sl.Count then Result := false\r\n      else begin\r\n        tmpStringAttri    := TSynHighlighterAttributes.Create('', '');\r\n        tmpNumberAttri    := TSynHighlighterAttributes.Create('', '');\r\n        tmpKeyAttri       := TSynHighlighterAttributes.Create('', '');\r\n        tmpSymbolAttri    := TSynHighlighterAttributes.Create('', '');\r\n        tmpCommentAttri   := TSynHighlighterAttributes.Create('', '');\r\n        tmpIdentifierAttri:= TSynHighlighterAttributes.Create('', '');\r\n        tmpInvalidAttri   := TSynHighlighterAttributes.Create('', '');\r\n        tmpSpaceAttri     := TSynHighlighterAttributes.Create('', '');\r\n        tmpDirecAttri     := TSynHighlighterAttributes.Create('', '');\r\n        tmpStringAttri    .Assign(fStringAttri);\r\n        tmpNumberAttri    .Assign(fNumberAttri);\r\n        tmpKeyAttri       .Assign(fKeyAttri);\r\n        tmpSymbolAttri    .Assign(fSymbolAttri);\r\n        tmpCommentAttri   .Assign(fCommentAttri);\r\n        tmpIdentifierAttri.Assign(fIdentifierAttri);\r\n        tmpInvalidAttri   .Assign(fInvalidAttri);\r\n        tmpSpaceAttri     .Assign(fSpaceAttri);\r\n        tmpDirecAttri     .Assign(fDirecAttri);\r\n        Result := ReadCPPBSetting(sl[settingIndex],fCommentAttri,'Comment')       and\r\n                  ReadCPPBSetting(sl[settingIndex],fIdentifierAttri,'Identifier') and\r\n                  ReadCPPBSetting(sl[settingIndex],fInvalidAttri,'Illegal Char')  and\r\n                  ReadCPPBSetting(sl[settingIndex],fKeyAttri,'Reserved word')     and\r\n                  ReadCPPBSetting(sl[settingIndex],fNumberAttri,'Integer')        and\r\n                  ReadCPPBSetting(sl[settingIndex],fSpaceAttri,'Whitespace')      and\r\n                  ReadCPPBSetting(sl[settingIndex],fStringAttri,'String')         and\r\n                  ReadCPPBSetting(sl[settingIndex],fSymbolAttri,'Symbol')         and\r\n                  ReadCPPBSetting(sl[settingIndex],fDirecAttri,'Preprocessor');\r\n        if not Result then begin\r\n          fStringAttri    .Assign(tmpStringAttri);\r\n          fString2Attri   .Assign(tmpStringAttri);\r\n          fNumberAttri    .Assign(tmpNumberAttri);\r\n          fKeyAttri       .Assign(tmpKeyAttri);\r\n          fKey2Attri      .Assign(tmpKeyAttri);\r\n          fSymbolAttri    .Assign(tmpSymbolAttri);\r\n          fCommentAttri   .Assign(tmpCommentAttri);\r\n          fIdentifierAttri.Assign(tmpIdentifierAttri);\r\n          fInvalidAttri.Assign(tmpInvalidAttri);\r\n          fSpaceAttri     .Assign(tmpSpaceAttri);\r\n          fDirecAttri     .Assign(tmpDirecAttri);\r\n        end;\r\n        tmpStringAttri    .Free;\r\n        tmpNumberAttri    .Free;\r\n        tmpKeyAttri       .Free;\r\n        tmpSymbolAttri    .Free;\r\n        tmpCommentAttri   .Free;\r\n        tmpIdentifierAttri.Free;\r\n        tmpInvalidAttri   .Free;\r\n        tmpSpaceAttri     .Free;\r\n        tmpDirecAttri     .Free;\r\n      end;\r\n    finally\r\n      sl.Free;\r\n    end;\r\n  end; { ReadCPPBSettings }\r\n{$ENDIF}\r\n\r\nbegin\r\n{$IFDEF SYN_CLX}\r\n  Result := False;\r\n{$ELSE}\r\n  Result := ReadCPPBSettings(settingIndex);\r\n{$ENDIF}\r\nend; { TSynUnrealSyn.UseUserSettings }\r\n\r\nclass function TSynUnrealSyn.GetLanguageName: string;\r\nbegin\r\n  Result := SYNS_LangUnreal;\r\nend;\r\n\r\nclass function TSynUnrealSyn.GetCapabilities: TSynHighlighterCapabilities;\r\nbegin\r\n  Result := inherited GetCapabilities + [hcUserSettings];\r\nend;\r\n\r\nfunction TSynUnrealSyn.GetSampleSource: UnicodeString;\r\nbegin\r\n  Result := '//----Comment-----------------------------------------------------------'#13#10+\r\n            'class TestObject expands Object native;'#13#10+\r\n            #13#10+\r\n            '#exec MESH    IMPORT     MESH=Something ANIVFILE=MODELS\\Something.3D DATAFILE=MODELS\\Something.3D X=0 Y=0 Z=0 MLOD=0'#13#10+\r\n            #13#10+\r\n            'var() Sound HitSound;'#13#10+\r\n            'function Cast()'#13#10+\r\n            '{'#13#10+\r\n            '  Super.Cast();'#13#10+\r\n            '  CastTime = 50;'#13#10+\r\n            '  GatherEffect = Spawn( class''SomethingCorona'',,, GetStartLoc(), Pawn(Owner).ViewRotation );'#13#10+\r\n            '  GatherEffect.SetFollowPawn( Pawn(Owner) );'#13#10+\r\n            '}'#13#10+\r\n            #13#10+\r\n            'defaultproperties'#13#10+\r\n            '{'#13#10+\r\n            '  PickupMessage=\"You have picked up a thing.\"'#13#10+\r\n            '}';\r\nend;\r\n\r\nclass function TSynUnrealSyn.GetFriendlyLanguageName: UnicodeString;\r\nbegin\r\n  Result := SYNS_FriendlyLangUnreal;\r\nend;\r\n\r\ninitialization\r\n{$IFNDEF SYN_CPPB_1}\r\n  RegisterPlaceableHighlighter(TSynUnrealSyn);\r\n{$ENDIF}\r\nend.\r\n"
  },
  {
    "path": "External/SynEdit/Source/SynHighlighterVB.pas",
    "content": "{-------------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: SynHighlighterVB.pas, released 2000-04-20.\r\nThe Original Code is based on the wbADSP21xxSyn.pas file from the\r\nmwEdit component suite by Martin Waldenburg and other developers, the Initial\r\nAuthor of this file is Max Horvth.\r\nUnicode translation by Mal Hrz.\r\nAll Rights Reserved.\r\n\r\nContributors to the SynEdit and mwEdit projects are listed in the\r\nContributors.txt file.\r\n\r\nAlternatively, the contents of this file may be used under the terms of the\r\nGNU General Public License Version 2 or later (the \"GPL\"), in which case\r\nthe provisions of the GPL are applicable instead of those above.\r\nIf you wish to allow use of your version of this file only under the terms\r\nof the GPL and not to allow others to use your version of this file\r\nunder the MPL, indicate your decision by deleting the provisions above and\r\nreplace them with the notice and other provisions required by the GPL.\r\nIf you do not delete the provisions above, a recipient may use your version\r\nof this file under either the MPL or the GPL.\r\n\r\n$Id: SynHighlighterVB.pas,v 1.14.2.7 2008/09/14 16:25:03 maelh Exp $\r\n\r\nYou may retrieve the latest version of this file at the SynEdit home page,\r\nlocated at http://SynEdit.SourceForge.net\r\n\r\nKnown Issues:\r\n-------------------------------------------------------------------------------}\r\n{\r\n@abstract(Provides a Visual Basic highlighter for SynEdit)\r\n@author(Max Horvth , converted to SynEdit by David Muir )\r\n@created(5 December 1999, converted to SynEdit April 21, 2000)\r\n@lastmod(2000-06-23)\r\nThe SynHighlighterVB unit provides SynEdit with a Visual Basic (.bas) highlighter.\r\n}\r\n\r\n{$IFNDEF QSYNHIGHLIGHTERVB}\r\nunit SynHighlighterVB;\r\n{$ENDIF}\r\n\r\n{$I SynEdit.inc}\r\n\r\ninterface\r\n\r\nuses\r\n{$IFDEF SYN_CLX}\r\n  Qt, QControls, QGraphics,\r\n  QSynEditHighlighter,\r\n  QSynEditTypes,\r\n  QSynUnicode,\r\n{$ELSE}\r\n  Windows, Messages, Controls, Graphics, Registry,\r\n  SynEditHighlighter,\r\n  SynEditTypes,\r\n  SynUnicode,\r\n{$ENDIF}\r\n  SysUtils,\r\n  Classes;\r\n\r\ntype\r\n  TtkTokenKind = (tkComment, tkIdentifier, tkKey, tkNull, tkNumber, tkSpace,\r\n    tkString, tkSymbol, tkUnknown);\r\n\r\n  PIdentFuncTableFunc = ^TIdentFuncTableFunc;\r\n  TIdentFuncTableFunc = function (Index: Integer): TtkTokenKind of object;\r\n\r\ntype\r\n  TSynVBSyn = class(TSynCustomHighlighter)\r\n  private\r\n    FTokenID: TtkTokenKind;\r\n    fIdentFuncTable: array[0..1422] of TIdentFuncTableFunc;\r\n    fCommentAttri: TSynHighlighterAttributes;\r\n    fIdentifierAttri: TSynHighlighterAttributes;\r\n    fKeyAttri: TSynHighlighterAttributes;\r\n    fNumberAttri: TSynHighlighterAttributes;\r\n    fSpaceAttri: TSynHighlighterAttributes;\r\n    fStringAttri: TSynHighlighterAttributes;\r\n    fSymbolAttri: TSynHighlighterAttributes;\r\n    function AltFunc(Index: Integer): TtkTokenKind;\r\n    function KeyWordFunc(Index: Integer): TtkTokenKind;\r\n    function FuncRem(Index: Integer): TtkTokenKind;\r\n    function HashKey(Str: PWideChar): Cardinal;\r\n    function IdentKind(MayBe: PWideChar): TtkTokenKind;\r\n    procedure InitIdent;\r\n    procedure SymbolProc;\r\n    procedure ApostropheProc;\r\n    procedure CRProc;\r\n    procedure DateProc;\r\n    procedure GreaterProc;\r\n    procedure IdentProc;\r\n    procedure LFProc;\r\n    procedure LowerProc;\r\n    procedure NullProc;\r\n    procedure NumberProc;\r\n    procedure SpaceProc;\r\n    procedure StringProc;\r\n    procedure UnknownProc;\r\n  protected\r\n    function GetSampleSource: UnicodeString; override;\r\n    function IsFilterStored: Boolean; override;\r\n  public\r\n    class function GetLanguageName: string; override;\r\n    class function GetFriendlyLanguageName: UnicodeString; override;\r\n  public\r\n    constructor Create(AOwner: TComponent); override;\r\n    function GetDefaultAttribute(Index: integer): TSynHighlighterAttributes;\r\n      override;\r\n    function GetEol: Boolean; override;\r\n    function GetTokenID: TtkTokenKind;\r\n    function GetTokenAttribute: TSynHighlighterAttributes; override;\r\n    function GetTokenKind: integer; override;\r\n    procedure Next; override;\r\n  published\r\n    property CommentAttri: TSynHighlighterAttributes read fCommentAttri\r\n      write fCommentAttri;\r\n    property IdentifierAttri: TSynHighlighterAttributes read fIdentifierAttri\r\n      write fIdentifierAttri;\r\n    property KeyAttri: TSynHighlighterAttributes read fKeyAttri write fKeyAttri;\r\n    property NumberAttri: TSynHighlighterAttributes read fNumberAttri\r\n      write fNumberAttri;\r\n    property SpaceAttri: TSynHighlighterAttributes read fSpaceAttri\r\n      write fSpaceAttri;\r\n    property StringAttri: TSynHighlighterAttributes read fStringAttri\r\n      write fStringAttri;\r\n    property SymbolAttri: TSynHighlighterAttributes read fSymbolAttri\r\n      write fSymbolAttri;\r\n  end;\r\n\r\nimplementation\r\n\r\nuses\r\n{$IFDEF SYN_CLX}\r\n  QSynEditStrConst;\r\n{$ELSE}\r\n  SynEditStrConst;\r\n{$ENDIF}\r\n\r\nconst\r\n  KeyWords: array[0..213] of UnicodeString = (\r\n    'abs', 'and', 'appactivate', 'array', 'as', 'asc', 'atn', 'attribute', \r\n    'base', 'beep', 'begin', 'boolean', 'byte', 'call', 'case', 'cbool', \r\n    'cbyte', 'ccur', 'cdate', 'cdbl', 'chdir', 'chdrive', 'chr', 'cint', \r\n    'circle', 'class', 'clear', 'clng', 'close', 'command', 'compare', 'const', \r\n    'cos', 'createobject', 'csng', 'cstr', 'curdir', 'currency', 'cvar', \r\n    'cverr', 'date', 'dateadd', 'datediff', 'datepart', 'dateserial', \r\n    'datevalue', 'ddb', 'deftype', 'dim', 'dir', 'do', 'doevents', 'double', \r\n    'each', 'else', 'elseif', 'empty', 'end', 'environ', 'eof', 'eqv', 'erase', \r\n    'err', 'error', 'exit', 'exp', 'explicit', 'fileattr', 'filecopy', \r\n    'filedatetime', 'filelen', 'fix', 'for', 'form', 'format', 'freefile', \r\n    'function', 'fv', 'get', 'getattr', 'getobject', 'gosub', 'goto', 'hex', \r\n    'hour', 'if', 'iif', 'imp', 'input', 'instr', 'int', 'integer', 'ipmt', \r\n    'irr', 'is', 'isarray', 'isdate', 'isempty', 'iserror', 'ismissing', \r\n    'isnull', 'isnumeric', 'isobject', 'kill', 'lbound', 'lcase', 'left', 'len', \r\n    'let', 'line', 'loc', 'lock', 'lof', 'log', 'long', 'loop', 'lset', 'ltrim', \r\n    'me', 'mid', 'minute', 'mirr', 'mkdir', 'mod', 'module', 'month', 'msgbox', \r\n    'name', 'new', 'next', 'not', 'nothing', 'now', 'nper', 'npv', 'object', \r\n    'oct', 'on', 'open', 'option', 'or', 'pmt', 'ppmt', 'print', 'private', \r\n    'property', 'pset', 'public', 'put', 'pv', 'qbcolor', 'raise', 'randomize', \r\n    'rate', 'redim', 'rem', 'reset', 'resume', 'return', 'rgb', 'right', \r\n    'rmdir', 'rnd', 'rset', 'rtrim', 'second', 'seek', 'select', 'sendkeys', \r\n    'set', 'setattr', 'sgn', 'shell', 'sin', 'single', 'sln', 'space', 'spc', \r\n    'sqr', 'static', 'stop', 'str', 'strcomp', 'strconv', 'string', 'sub', \r\n    'switch', 'syd', 'system', 'tab', 'tan', 'then', 'time', 'timer', \r\n    'timeserial', 'timevalue', 'to', 'trim', 'typename', 'ubound', 'ucase', \r\n    'unlock', 'until', 'val', 'variant', 'vartype', 'version', 'weekday', \r\n    'wend', 'while', 'width', 'with', 'write', 'xor' \r\n  );\r\n\r\n  KeyIndices: array[0..1422] of Integer = (\r\n    -1, 117, 59, -1, 10, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 152, -1, -1, \r\n    -1, 22, -1, -1, -1, -1, 111, -1, -1, -1, -1, -1, -1, -1, -1, 115, 19, -1, \r\n    -1, -1, 160, -1, -1, -1, -1, -1, -1, -1, -1, 14, -1, -1, 34, -1, 54, -1, -1, \r\n    31, 161, -1, 87, -1, 173, -1, -1, -1, -1, 76, -1, -1, -1, 138, -1, -1, -1, \r\n    -1, -1, 176, -1, 177, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 193, -1, \r\n    178, -1, -1, -1, -1, -1, -1, 72, -1, -1, -1, -1, -1, -1, 131, -1, -1, -1, \r\n    -1, -1, -1, 188, -1, -1, -1, -1, -1, -1, -1, 194, 209, -1, -1, -1, 88, -1, \r\n    120, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 170, -1, -1, -1, -1, 185, -1, \r\n    -1, -1, -1, 198, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, 73, -1, 157, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    67, -1, -1, -1, 130, -1, 82, -1, -1, 99, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, 186, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 168, -1, -1, -1, \r\n    206, 40, -1, -1, 143, 202, -1, -1, -1, -1, -1, 158, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, 114, -1, -1, -1, 89, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 174, -1, 146, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, 97, 69, -1, 29, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 127, -1, -1, -1, -1, 184, -1, -1, \r\n    -1, 153, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, 199, 48, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, 112, 90, -1, -1, -1, -1, -1, -1, 179, -1, -1, -1, -1, -1, -1, -1, 119, \r\n    -1, -1, -1, 25, -1, -1, -1, -1, -1, 74, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, 125, -1, -1, -1, -1, -1, -1, -1, 126, -1, -1, -1, 65, -1, -1, \r\n    -1, 134, -1, -1, 8, -1, -1, -1, -1, -1, -1, -1, 155, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, 150, -1, -1, -1, -1, -1, -1, -1, 86, -1, 147, 148, -1, -1, -1, \r\n    -1, -1, 107, 164, 203, -1, 102, -1, -1, -1, -1, -1, -1, -1, -1, 103, -1, -1, \r\n    -1, -1, -1, 68, -1, -1, 101, 32, 201, -1, -1, -1, -1, -1, -1, 95, -1, -1, \r\n    124, 0, -1, -1, -1, -1, -1, -1, -1, -1, -1, 79, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, 172, -1, 23, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, 207, -1, -1, -1, -1, -1, -1, -1, 175, -1, 129, -1, \r\n    -1, -1, -1, -1, -1, -1, 30, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, 58, -1, -1, 141, -1, -1, -1, 181, -1, -1, -1, 166, 80, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, 197, -1, -1, 133, 28, -1, -1, -1, 21, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, 66, -1, -1, -1, -1, -1, -1, -1, -1, 36, -1, -1, \r\n    -1, -1, -1, -1, 104, -1, 12, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    92, -1, -1, 180, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, 108, -1, 151, -1, -1, -1, -1, -1, -1, -1, -1, -1, 9, -1, \r\n    156, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 205, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, 136, 55, -1, -1, -1, -1, 35, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    53, -1, -1, -1, -1, -1, -1, -1, -1, 100, -1, -1, -1, 51, 70, -1, -1, -1, -1, \r\n    204, -1, -1, -1, -1, -1, -1, 24, -1, -1, 71, -1, -1, -1, -1, -1, 45, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 210, -1, 94, 84, \r\n    -1, -1, 189, -1, -1, -1, -1, -1, 128, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, 122, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 83, -1, \r\n    -1, -1, -1, -1, -1, -1, 38, -1, 213, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, 162, -1, -1, -1, -1, -1, -1, -1, -1, -1, 17, -1, -1, -1, 47, 18, \r\n    187, -1, -1, 137, 105, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, 42, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, 182, -1, 4, 75, -1, -1, -1, -1, -1, -1, 118, -1, -1, -1, -1, \r\n    -1, 20, 60, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 62, -1, -1, -1, \r\n    -1, -1, -1, 93, 98, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 81, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, 110, -1, -1, -1, -1, -1, -1, -1, -1, -1, 167, -1, -1, \r\n    -1, 26, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 132, -1, -1, 196, -1, -1, -1, 85, \r\n    -1, -1, -1, -1, 140, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 78, 11, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 200, -1, -1, \r\n    169, -1, -1, -1, -1, 159, -1, -1, 56, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, 211, -1, -1, -1, -1, -1, -1, 2, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, 44, -1, -1, -1, -1, 61, 15, -1, 27, -1, -1, -1, -1, 6, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, 113, 39, -1, -1, -1, -1, -1, 91, -1, -1, 77, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, 64, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, 171, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    145, -1, 195, 52, -1, -1, -1, -1, -1, -1, -1, -1, 1, -1, -1, -1, -1, -1, -1, \r\n    57, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, 7, -1, -1, 33, -1, -1, -1, -1, -1, -1, 142, -1, -1, -1, -1, -1, 96, -1, \r\n    106, -1, 139, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, 212, 5, -1, 190, -1, -1, 49, 50, -1, -1, -1, -1, -1, -1, 46, 3, -1, \r\n    109, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 165, -1, -1, \r\n    -1, 16, -1, -1, -1, -1, -1, 144, -1, 192, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, 183, -1, -1, -1, 13, 135, -1, -1, -1, -1, 121, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, 63, -1, -1, -1, 163, -1, -1, -1, -1, -1, -1, -1, \r\n    41, 149, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 123, -1, -1, -1, 208, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 191, -1, -1, \r\n    43, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 116, -1, -1, -1, \r\n    37, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 154, -1 \r\n  );\r\n\r\n{$Q-}\r\nfunction TSynVBSyn.HashKey(Str: PWideChar): Cardinal;\r\nbegin\r\n  Result := 0;\r\n  while IsIdentChar(Str^) do\r\n  begin\r\n    Result := Result * 251 + Ord(Str^) * 749;\r\n    inc(Str);\r\n  end;\r\n  Result := Result mod 1423;\r\n  fStringLen := Str - fToIdent;\r\nend;\r\n{$Q+}\r\n\r\nfunction TSynVBSyn.IdentKind(MayBe: PWideChar): TtkTokenKind;\r\nvar\r\n  Key: Cardinal;\r\nbegin\r\n  fToIdent := MayBe;\r\n  Key := HashKey(MayBe);\r\n  if Key <= High(fIdentFuncTable) then\r\n    Result := fIdentFuncTable[Key](KeyIndices[Key])\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nprocedure TSynVBSyn.InitIdent;\r\nvar\r\n  i: Integer;\r\nbegin\r\n  for i := Low(fIdentFuncTable) to High(fIdentFuncTable) do\r\n    if KeyIndices[i] = -1 then\r\n      fIdentFuncTable[i] := AltFunc;\r\n\r\n  fIdentFuncTable[436] := FuncRem;\r\n\r\n  for i := Low(fIdentFuncTable) to High(fIdentFuncTable) do\r\n    if @fIdentFuncTable[i] = nil then\r\n      fIdentFuncTable[i] := KeyWordFunc;\r\nend;\r\n\r\nfunction TSynVBSyn.AltFunc(Index: Integer): TtkTokenKind;\r\nbegin\r\n  Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynVBSyn.KeyWordFunc(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier\r\nend;\r\n\r\nfunction TSynVBSyn.FuncRem(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n  begin\r\n    ApostropheProc;\r\n    fStringLen := 0;\r\n    Result := tkComment;\r\n  end\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nconstructor TSynVBSyn.Create(AOwner: TComponent);\r\nbegin\r\n  inherited Create(AOwner);\r\n\r\n  fCaseSensitive := False;\r\n\r\n  fCommentAttri := TSynHighlighterAttributes.Create(SYNS_AttrComment, SYNS_FriendlyAttrComment);\r\n  fCommentAttri.Style:= [fsItalic];\r\n  AddAttribute(fCommentAttri);\r\n  fIdentifierAttri := TSynHighlighterAttributes.Create(SYNS_AttrIdentifier, SYNS_FriendlyAttrIdentifier);\r\n  AddAttribute(fIdentifierAttri);\r\n  fKeyAttri := TSynHighlighterAttributes.Create(SYNS_AttrReservedWord, SYNS_FriendlyAttrReservedWord);\r\n  fKeyAttri.Style:= [fsBold];\r\n  AddAttribute(fKeyAttri);\r\n  fNumberAttri := TSynHighlighterAttributes.Create(SYNS_AttrNumber, SYNS_FriendlyAttrNumber);\r\n  AddAttribute(fNumberAttri);\r\n  fSpaceAttri := TSynHighlighterAttributes.Create(SYNS_AttrSpace, SYNS_FriendlyAttrSpace);\r\n  AddAttribute(fSpaceAttri);\r\n  fStringAttri := TSynHighlighterAttributes.Create(SYNS_AttrString, SYNS_FriendlyAttrString);\r\n  AddAttribute(fStringAttri);\r\n  fSymbolAttri := TSynHighlighterAttributes.Create(SYNS_AttrSymbol, SYNS_FriendlyAttrSymbol);\r\n  AddAttribute(fSymbolAttri);\r\n  SetAttributesOnChange(DefHighlightChange);\r\n  InitIdent;\r\n  fDefaultFilter := SYNS_FilterVisualBASIC;\r\nend;\r\n\r\nprocedure TSynVBSyn.SymbolProc;\r\nbegin\r\n  inc(Run);\r\n  fTokenId := tkSymbol;\r\nend;\r\n\r\nprocedure TSynVBSyn.ApostropheProc;\r\nbegin\r\n  fTokenID := tkComment;\r\n  repeat\r\n    Inc(Run);\r\n  until IsLineEnd(Run);\r\nend;\r\n\r\nprocedure TSynVBSyn.CRProc;\r\nbegin\r\n  fTokenID := tkSpace;\r\n  Inc(Run);\r\n  if fLine[Run] = #10 then Inc(Run);\r\nend;\r\n\r\nprocedure TSynVBSyn.DateProc;\r\nbegin\r\n  fTokenID := tkString;\r\n  repeat\r\n    if IsLineEnd(Run) then break;\r\n    inc(Run);\r\n  until FLine[Run] = '#';\r\n  if not IsLineEnd(Run) then inc(Run);\r\nend;\r\n\r\nprocedure TSynVBSyn.GreaterProc;\r\nbegin\r\n  fTokenID := tkSymbol;\r\n  Inc(Run);\r\n  if fLine[Run] = '=' then Inc(Run);\r\nend;\r\n\r\nprocedure TSynVBSyn.IdentProc;\r\nbegin\r\n  fTokenID := IdentKind(fLine + Run);\r\n  inc(Run, fStringLen);\r\n  while IsIdentChar(fLine[Run]) do inc(Run);\r\nend;\r\n\r\nprocedure TSynVBSyn.LFProc;\r\nbegin\r\n  fTokenID := tkSpace;\r\n  inc(Run);\r\nend;\r\n\r\nprocedure TSynVBSyn.LowerProc;\r\nbegin\r\n  fTokenID := tkSymbol;\r\n  Inc(Run);\r\n  if CharInSet(fLine[Run], ['=', '>']) then Inc(Run);\r\nend;\r\n\r\nprocedure TSynVBSyn.NullProc;\r\nbegin\r\n  fTokenID := tkNull;\r\n  inc(Run);\r\nend;\r\n\r\nprocedure TSynVBSyn.NumberProc;\r\n\r\n  function IsNumberChar: Boolean;\r\n  begin\r\n    case fLine[Run] of\r\n      '0'..'9', '.', 'e', 'E':\r\n        Result := True;\r\n      else\r\n        Result := False;\r\n    end;\r\n  end;\r\n\r\nbegin\r\n  inc(Run);\r\n  fTokenID := tkNumber;\r\n  while IsNumberChar do inc(Run);\r\nend;\r\n\r\nprocedure TSynVBSyn.SpaceProc;\r\nbegin\r\n  inc(Run);\r\n  fTokenID := tkSpace;\r\n  while (FLine[Run] <= #32) and not IsLineEnd(Run) do inc(Run);\r\nend;\r\n\r\nprocedure TSynVBSyn.StringProc;\r\nbegin\r\n  fTokenID := tkString;\r\n  if (FLine[Run + 1] = #34) and (FLine[Run + 2] = #34) then inc(Run, 2);\r\n  repeat\r\n    if IsLineEnd(Run) then break;\r\n    inc(Run);\r\n  until FLine[Run] = #34;\r\n  if not IsLineEnd(Run) then inc(Run);\r\nend;\r\n\r\nprocedure TSynVBSyn.UnknownProc;\r\nbegin\r\n  inc(Run);\r\n  fTokenID := tkUnknown;\r\nend;\r\n\r\nprocedure TSynVBSyn.Next;\r\nbegin\r\n  fTokenPos := Run;\r\n  case fLine[Run] of\r\n    '&': SymbolProc;\r\n    #39: ApostropheProc;\r\n    '}': SymbolProc;\r\n    '{': SymbolProc;\r\n    #13: CRProc;\r\n    ':': SymbolProc;\r\n    ',': SymbolProc;\r\n    '#': DateProc;\r\n    '=': SymbolProc;\r\n    '^': SymbolProc;\r\n    '>': GreaterProc;\r\n    'A'..'Z', 'a'..'z', '_': IdentProc;\r\n    #10: LFProc;\r\n    '<': LowerProc;\r\n    '-': SymbolProc;\r\n    #0: NullProc;\r\n    '0'..'9': NumberProc;\r\n    '+': SymbolProc;\r\n    '.': SymbolProc;\r\n    ')': SymbolProc;\r\n    '(': SymbolProc;\r\n    ';': SymbolProc;\r\n    '/': SymbolProc;\r\n    #1..#9, #11, #12, #14..#32: SpaceProc;\r\n    '*': SymbolProc;\r\n    #34: StringProc;\r\n    else UnknownProc;\r\n  end;\r\n  inherited;\r\nend;\r\n\r\nfunction TSynVBSyn.GetDefaultAttribute(Index: integer):\r\n  TSynHighlighterAttributes;\r\nbegin\r\n  case Index of\r\n    SYN_ATTR_COMMENT: Result := fCommentAttri;\r\n    SYN_ATTR_IDENTIFIER: Result := fIdentifierAttri;\r\n    SYN_ATTR_KEYWORD: Result := fKeyAttri;\r\n    SYN_ATTR_STRING: Result := fStringAttri;\r\n    SYN_ATTR_WHITESPACE: Result := fSpaceAttri;\r\n    SYN_ATTR_SYMBOL: Result := fSymbolAttri;\r\n  else\r\n    Result := nil;\r\n  end;\r\nend;\r\n\r\nfunction TSynVBSyn.GetEol: Boolean;\r\nbegin\r\n  Result := Run = fLineLen + 1;\r\nend;\r\n\r\nfunction TSynVBSyn.GetTokenID: TtkTokenKind;\r\nbegin\r\n  Result := fTokenId;\r\nend;\r\n\r\nfunction TSynVBSyn.GetTokenAttribute: TSynHighlighterAttributes;\r\nbegin\r\n  case GetTokenID of\r\n    tkComment: Result := fCommentAttri;\r\n    tkIdentifier: Result := fIdentifierAttri;\r\n    tkKey: Result := fKeyAttri;\r\n    tkNumber: Result := fNumberAttri;\r\n    tkSpace: Result := fSpaceAttri;\r\n    tkString: Result := fStringAttri;\r\n    tkSymbol: Result := fSymbolAttri;\r\n    tkUnknown: Result := fIdentifierAttri;\r\n    else Result := nil;\r\n  end;\r\nend;\r\n\r\nfunction TSynVBSyn.GetTokenKind: integer;\r\nbegin\r\n  Result := Ord(fTokenId);\r\nend;\r\n\r\nfunction TSynVBSyn.IsFilterStored: Boolean;\r\nbegin\r\n  Result := fDefaultFilter <> SYNS_FilterVisualBASIC;\r\nend;\r\n\r\nclass function TSynVBSyn.GetLanguageName: string;\r\nbegin\r\n  Result := SYNS_LangVisualBASIC;\r\nend;\r\n\r\nfunction TSynVBSyn.GetSampleSource: UnicodeString;\r\nbegin\r\n  Result := ''' Syntax highlighting'#13#10+\r\n            'Function PrintNumber'#13#10+\r\n            '  Dim Number'#13#10+\r\n            '  Dim X'#13#10+\r\n            ''#13#10+\r\n            '  Number = 123456'#13#10+\r\n            '  Response.Write \"The number is \" & number'#13#10+\r\n            ''#13#10+\r\n            '  For I = 0 To Number'#13#10+\r\n            '    X = X + &h4c'#13#10+\r\n            '    X = X - &o8'#13#10+\r\n            '    X = X + 1.0'#13#10+\r\n            '  Next'#13#10+\r\n            ''#13#10+\r\n            '  I = I + @;  '' illegal character'#13#10+\r\n            'End Function';\r\nend;\r\n\r\nclass function TSynVBSyn.GetFriendlyLanguageName: UnicodeString;\r\nbegin\r\n  Result := SYNS_FriendlyLangVisualBASIC;\r\nend;\r\n\r\ninitialization\r\n{$IFNDEF SYN_CPPB_1}\r\n  RegisterPlaceableHighlighter(TSynVBSyn);\r\n{$ENDIF}\r\nend.\r\n"
  },
  {
    "path": "External/SynEdit/Source/SynHighlighterVBScript.pas",
    "content": "{-------------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: SynHighlighterVBScript.pas, released 2000-04-18.\r\nThe Original Code is based on the lbVBSSyn.pas file from the\r\nmwEdit component suite by Martin Waldenburg and other developers, the Initial\r\nAuthor of this file is Luiz C. Vaz de Brito.\r\nUnicode translation by Mal Hrz.\r\nAll Rights Reserved.\r\n\r\nContributors to the SynEdit and mwEdit projects are listed in the\r\nContributors.txt file.\r\n\r\nAlternatively, the contents of this file may be used under the terms of the\r\nGNU General Public License Version 2 or later (the \"GPL\"), in which case\r\nthe provisions of the GPL are applicable instead of those above.\r\nIf you wish to allow use of your version of this file only under the terms\r\nof the GPL and not to allow others to use your version of this file\r\nunder the MPL, indicate your decision by deleting the provisions above and\r\nreplace them with the notice and other provisions required by the GPL.\r\nIf you do not delete the provisions above, a recipient may use your version\r\nof this file under either the MPL or the GPL.\r\n\r\n$Id: SynHighlighterVBScript.pas,v 1.14.2.7 2008/09/14 16:25:03 maelh Exp $\r\n\r\nYou may retrieve the latest version of this file at the SynEdit home page,\r\nlocated at http://SynEdit.SourceForge.net\r\n\r\nKnown Issues:\r\n-------------------------------------------------------------------------------}\r\n{\r\n@abstract(Provides a VBScript highlighter for SynEdit)\r\n@author(Luiz C. Vaz de Brito, converted to SynEdit by David Muir )\r\n@created(20 January 1999, converted to SynEdit April 18, 2000)\r\n@lastmod(2000-06-23)\r\nThe SynHighlighterVBScript unit provides SynEdit with a VisualBasic Script (.vbs) highlighter.\r\nThanks to Primoz Gabrijelcic and Martin Waldenburg.\r\n}\r\n\r\n{$IFNDEF QSYNHIGHLIGHTERVBSCRIPT}\r\nunit SynHighlighterVBScript;\r\n{$ENDIF}\r\n\r\n{$I SynEdit.inc}\r\n\r\ninterface\r\n\r\nuses\r\n{$IFDEF SYN_CLX}\r\n  QGraphics,\r\n  QSynEditHighlighter,\r\n  QSynEditTypes,\r\n  QSynUnicode,\r\n{$ELSE}\r\n  Graphics,\r\n  Registry,\r\n  SynEditHighlighter,\r\n  SynEditTypes,\r\n  SynUnicode,\r\n{$ENDIF}\r\n  SysUtils,\r\n  Classes;\r\n\r\ntype\r\n  TtkTokenKind = (tkComment, tkIdentifier, tkKey, tkNull, tkNumber, tkSpace,\r\n    tkString, tkSymbol, tkUnknown);\r\n\r\n  PIdentFuncTableFunc = ^TIdentFuncTableFunc;\r\n  TIdentFuncTableFunc = function (Index: Integer): TtkTokenKind of object;\r\n\r\ntype\r\n  TSynVBScriptSyn = class(TSynCustomHighLighter)\r\n  private\r\n    FTokenID: TtkTokenKind;\r\n    fCommentAttri: TSynHighlighterAttributes;\r\n    fIdentifierAttri: TSynHighlighterAttributes;\r\n    fKeyAttri: TSynHighlighterAttributes;\r\n    fNumberAttri: TSynHighlighterAttributes;\r\n    fSpaceAttri: TSynHighlighterAttributes;\r\n    fStringAttri: TSynHighlighterAttributes;\r\n    fSymbolAttri: TSynHighlighterAttributes;\r\n    fIdentFuncTable: array[0..268] of TIdentFuncTableFunc;\r\n    function AltFunc(Index: Integer): TtkTokenKind;\r\n    function KeyWordFunc(Index: Integer): TtkTokenKind;\r\n    function FuncRem(Index: Integer): TtkTokenKind;\r\n    function HashKey(Str: PWideChar): Cardinal;\r\n    function IdentKind(MayBe: PWideChar): TtkTokenKind;\r\n    procedure InitIdent;\r\n    procedure ApostropheProc;\r\n    procedure CRProc;\r\n    procedure DateProc;\r\n    procedure GreaterProc;\r\n    procedure IdentProc;\r\n    procedure LFProc;\r\n    procedure LowerProc;\r\n    procedure NullProc;\r\n    procedure NumberProc;\r\n    procedure SpaceProc;\r\n    procedure StringProc;\r\n    procedure SymbolProc;\r\n    procedure UnknownProc;\r\n  protected\r\n    function GetSampleSource: UnicodeString; override;\r\n    function IsFilterStored: Boolean; override;\r\n  public\r\n    class function GetLanguageName: string; override;\r\n    class function GetFriendlyLanguageName: UnicodeString; override;\r\n  public\r\n    constructor Create(AOwner: TComponent); override;\r\n    function GetDefaultAttribute(Index: integer): TSynHighlighterAttributes;\r\n      override;\r\n    function GetEol: Boolean; override;\r\n    function GetTokenID: TtkTokenKind;\r\n    function GetTokenAttribute: TSynHighlighterAttributes; override;\r\n    function GetTokenKind: integer; override;\r\n    procedure Next; override;\r\n  published\r\n    property CommentAttri: TSynHighlighterAttributes read fCommentAttri\r\n      write fCommentAttri;\r\n    property IdentifierAttri: TSynHighlighterAttributes read fIdentifierAttri\r\n      write fIdentifierAttri;\r\n    property KeyAttri: TSynHighlighterAttributes read fKeyAttri write fKeyAttri;\r\n    property NumberAttri: TSynHighlighterAttributes read fNumberAttri\r\n      write fNumberAttri;\r\n    property SpaceAttri: TSynHighlighterAttributes read fSpaceAttri\r\n      write fSpaceAttri;\r\n    property StringAttri: TSynHighlighterAttributes read fStringAttri\r\n      write fStringAttri;\r\n    property SymbolAttri: TSynHighlighterAttributes read fSymbolAttri\r\n      write fSymbolAttri;\r\n  end;\r\n\r\nimplementation\r\n\r\nuses\r\n{$IFDEF SYN_CLX}\r\n  QSynEditStrConst;\r\n{$ELSE}\r\n  SynEditStrConst;\r\n{$ENDIF}\r\n\r\nconst\r\n  KeyWords: array[0..83] of UnicodeString = (\r\n    'and', 'as', 'boolean', 'byref', 'byte', 'byval', 'call', 'case', 'class', \r\n    'const', 'currency', 'debug', 'dim', 'do', 'double', 'each', 'else', \r\n    'elseif', 'empty', 'end', 'endif', 'enum', 'eqv', 'erase', 'error', 'event', \r\n    'exit', 'explicit', 'false', 'for', 'function', 'get', 'goto', 'if', 'imp', \r\n    'implements', 'in', 'integer', 'is', 'let', 'like', 'long', 'loop', 'lset', \r\n    'me', 'mod', 'new', 'next', 'not', 'nothing', 'null', 'on', 'option', \r\n    'optional', 'or', 'paramarray', 'preserve', 'private', 'property', 'public', \r\n    'raiseevent', 'randomize', 'redim', 'rem', 'resume', 'rset', 'select', \r\n    'set', 'shared', 'single', 'static', 'stop', 'sub', 'then', 'to', 'true', \r\n    'type', 'typeof', 'until', 'variant', 'wend', 'while', 'with', 'xor' \r\n  );\r\n\r\n  KeyIndices: array[0..268] of Integer = (\r\n    -1, -1, -1, -1, -1, -1, -1, -1, 56, -1, 77, -1, 78, -1, 37, 19, 75, -1, -1, \r\n    -1, -1, -1, -1, -1, 12, -1, 66, -1, -1, -1, -1, -1, 35, -1, -1, -1, 46, 41, \r\n    36, -1, -1, 83, 33, 40, 34, -1, -1, -1, -1, 54, 24, 51, -1, -1, -1, -1, -1, \r\n    -1, -1, 76, -1, 68, -1, 1, -1, 7, -1, -1, 8, -1, -1, -1, -1, -1, -1, -1, -1, \r\n    -1, 57, -1, 79, -1, -1, -1, 5, -1, -1, -1, -1, 4, -1, -1, -1, 43, 72, -1, \r\n    44, -1, -1, -1, -1, -1, -1, -1, 48, -1, -1, 69, -1, -1, 16, 70, 80, -1, 53, \r\n    47, 58, -1, -1, -1, -1, -1, -1, 63, -1, -1, -1, -1, 59, -1, 65, 39, -1, -1, \r\n    -1, -1, 6, -1, 55, -1, 67, -1, -1, -1, -1, -1, -1, 22, -1, -1, -1, 74, 50, \r\n    -1, -1, -1, 64, -1, -1, -1, -1, -1, -1, 31, 20, 23, -1, -1, 61, 27, 38, -1, \r\n    -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 10, -1, \r\n    -1, -1, 3, -1, -1, 71, -1, -1, -1, -1, 11, 0, -1, -1, 82, 13, 15, 2, 30, 29, \r\n    14, -1, -1, 42, 49, 81, -1, 9, -1, -1, 62, 25, 60, -1, -1, 45, -1, -1, -1, \r\n    -1, -1, -1, -1, -1, 26, 28, -1, -1, -1, -1, 21, -1, -1, -1, -1, -1, -1, -1, \r\n    17, -1, -1, -1, -1, -1, 32, -1, -1, -1, -1, -1, -1, -1, -1, 52, 73, -1, -1, \r\n    18 \r\n  );\r\n\r\n{$Q-}\r\nfunction TSynVBScriptSyn.HashKey(Str: PWideChar): Cardinal;\r\nbegin\r\n  Result := 0;\r\n  while IsIdentChar(Str^) do\r\n  begin\r\n    Result := Result * 713 + Ord(Str^) * 134;\r\n    inc(Str);\r\n  end;\r\n  Result := Result mod 269;\r\n  fStringLen := Str - fToIdent;\r\nend;\r\n{$Q+}\r\n\r\nfunction TSynVBScriptSyn.IdentKind(MayBe: PWideChar): TtkTokenKind;\r\nvar\r\n  Key: Cardinal;\r\nbegin\r\n  fToIdent := MayBe;\r\n  Key := HashKey(MayBe);\r\n  if Key <= High(fIdentFuncTable) then\r\n    Result := fIdentFuncTable[Key](KeyIndices[Key])\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nprocedure TSynVBScriptSyn.InitIdent;\r\nvar\r\n  i: Integer;\r\nbegin\r\n  for i := Low(fIdentFuncTable) to High(fIdentFuncTable) do\r\n    if KeyIndices[i] = -1 then\r\n      fIdentFuncTable[i] := AltFunc;\r\n\r\n  fIdentFuncTable[123] := FuncRem;\r\n\r\n  for i := Low(fIdentFuncTable) to High(fIdentFuncTable) do\r\n    if @fIdentFuncTable[i] = nil then\r\n      fIdentFuncTable[i] := KeyWordFunc;\r\nend;\r\n\r\nfunction TSynVBScriptSyn.AltFunc(Index: Integer): TtkTokenKind;\r\nbegin\r\n  Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynVBScriptSyn.KeyWordFunc(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier\r\nend;\r\n\r\nfunction TSynVBScriptSyn.FuncRem(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n  begin\r\n    ApostropheProc;\r\n    fStringLen := 0;\r\n    Result := tkComment;\r\n  end\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nconstructor TSynVBScriptSyn.Create(AOwner: TComponent);\r\nbegin\r\n  inherited Create(AOwner);\r\n\r\n  fCaseSensitive := False;\r\n\r\n  fCommentAttri := TSynHighlighterAttributes.Create(SYNS_AttrComment, SYNS_FriendlyAttrComment);\r\n  fCommentAttri.Style := [fsItalic];\r\n  AddAttribute(fCommentAttri);\r\n  fIdentifierAttri := TSynHighlighterAttributes.Create(SYNS_AttrIdentifier, SYNS_FriendlyAttrIdentifier);\r\n  AddAttribute(fIdentifierAttri);\r\n  fKeyAttri := TSynHighlighterAttributes.Create(SYNS_AttrReservedWord, SYNS_FriendlyAttrReservedWord);\r\n  fKeyAttri.Style := [fsBold];\r\n  AddAttribute(fKeyAttri);\r\n  fNumberAttri := TSynHighlighterAttributes.Create(SYNS_AttrNumber, SYNS_FriendlyAttrNumber);\r\n  AddAttribute(fNumberAttri);\r\n  fSpaceAttri := TSynHighlighterAttributes.Create(SYNS_AttrSpace, SYNS_FriendlyAttrSpace);\r\n  AddAttribute(fSpaceAttri);\r\n  fStringAttri := TSynHighlighterAttributes.Create(SYNS_AttrString, SYNS_FriendlyAttrString);\r\n  AddAttribute(fStringAttri);\r\n  fSymbolAttri := TSynHighlighterAttributes.Create(SYNS_AttrSymbol, SYNS_FriendlyAttrSymbol);\r\n  AddAttribute(fSymbolAttri);\r\n  SetAttributesOnChange(DefHighlightChange);\r\n  fDefaultFilter := SYNS_FilterVBScript;\r\n  InitIdent;\r\nend;\r\n\r\nprocedure TSynVBScriptSyn.ApostropheProc;\r\nbegin\r\n  fTokenID := tkComment;\r\n  repeat\r\n    inc(Run);\r\n  until IsLineEnd(Run);\r\nend;\r\n\r\nprocedure TSynVBScriptSyn.CRProc;\r\nbegin\r\n  fTokenID := tkSpace;\r\n  inc(Run);\r\n  if fLine[Run] = #10 then inc(Run);\r\nend;\r\n\r\nprocedure TSynVBScriptSyn.DateProc;\r\nbegin\r\n  fTokenID := tkString;\r\n  repeat\r\n    if IsLineEnd(Run) then break;\r\n    inc(Run);\r\n  until FLine[Run] = '#';\r\n  if not IsLineEnd(Run) then inc(Run);\r\nend;\r\n\r\nprocedure TSynVBScriptSyn.GreaterProc;\r\nbegin\r\n  fTokenID := tkSymbol;\r\n  Inc(Run);\r\n  if fLine[Run] = '=' then Inc(Run);\r\nend;\r\n\r\nprocedure TSynVBScriptSyn.IdentProc;\r\nbegin\r\n  fTokenID := IdentKind((fLine + Run));\r\n  inc(Run, fStringLen);\r\n  while IsIdentChar(fLine[Run]) do inc(Run);\r\nend;\r\n\r\nprocedure TSynVBScriptSyn.LFProc;\r\nbegin\r\n  fTokenID := tkSpace;\r\n  inc(Run);\r\nend;\r\n\r\nprocedure TSynVBScriptSyn.LowerProc;\r\nbegin\r\n  fTokenID := tkSymbol;\r\n  Inc(Run);\r\n  if CharInSet(fLine[Run], ['=', '>']) then Inc(Run);\r\nend;\r\n\r\nprocedure TSynVBScriptSyn.NullProc;\r\nbegin\r\n  fTokenID := tkNull;\r\n  inc(Run);\r\nend;\r\n\r\nprocedure TSynVBScriptSyn.NumberProc;\r\n\r\n  function IsNumberChar: Boolean;\r\n  begin\r\n    case fLine[Run] of\r\n      '0'..'9', '.', 'e', 'E':\r\n        Result := True;\r\n      else\r\n        Result := False;\r\n    end;\r\n  end;\r\n\r\nbegin\r\n  inc(Run);\r\n  fTokenID := tkNumber;\r\n  while IsNumberChar do inc(Run);\r\nend;\r\n\r\nprocedure TSynVBScriptSyn.SpaceProc;\r\nbegin\r\n  inc(Run);\r\n  fTokenID := tkSpace;\r\n  while (FLine[Run] <= #32) and not IsLineEnd(Run) do inc(Run);\r\nend;\r\n\r\nprocedure TSynVBScriptSyn.StringProc;\r\nbegin\r\n  fTokenID := tkString;\r\n  if (FLine[Run + 1] = #34) and (FLine[Run + 2] = #34) then inc(Run, 2);\r\n  repeat\r\n    if IsLineEnd(Run) then break;\r\n    inc(Run);\r\n  until FLine[Run] = #34;\r\n  if not IsLineEnd(Run) then inc(Run);\r\nend;\r\n\r\nprocedure TSynVBScriptSyn.SymbolProc;\r\nbegin\r\n  inc(Run);\r\n  fTokenID := tkSymbol;\r\nend;\r\n\r\nprocedure TSynVBScriptSyn.UnknownProc;\r\nbegin\r\n  inc(Run);\r\n  fTokenID := tkIdentifier;\r\nend;\r\n\r\nprocedure TSynVBScriptSyn.Next;\r\nbegin\r\n  fTokenPos := Run;\r\n  case fLine[Run] of\r\n    #39: ApostropheProc;\r\n    #13: CRProc;\r\n    '#': DateProc;\r\n    '>': GreaterProc;\r\n    'A'..'Z', 'a'..'z', '_': IdentProc;\r\n    #10: LFProc;\r\n    '<': LowerProc;\r\n    #0: NullProc;\r\n    '0'..'9': NumberProc;\r\n    #1..#9, #11, #12, #14..#32: SpaceProc;\r\n    #34: StringProc;\r\n    '&', '{', '}', ':', ',', '=', '^', '-',\r\n    '+', '.', '(', ')', ';', '/', '*': SymbolProc;\r\n    else UnknownProc;\r\n  end;\r\n  inherited;\r\nend;\r\n\r\nfunction TSynVBScriptSyn.GetDefaultAttribute(Index: integer):\r\n  TSynHighlighterAttributes;\r\nbegin\r\n  case Index of\r\n    SYN_ATTR_COMMENT: Result := fCommentAttri;\r\n    SYN_ATTR_IDENTIFIER: Result := fIdentifierAttri;\r\n    SYN_ATTR_KEYWORD: Result := fKeyAttri;\r\n    SYN_ATTR_STRING: Result := fStringAttri;\r\n    SYN_ATTR_WHITESPACE: Result := fSpaceAttri;\r\n    SYN_ATTR_SYMBOL: Result := fSymbolAttri;\r\n  else\r\n    Result := nil;\r\n  end;\r\nend;\r\n\r\nfunction TSynVBScriptSyn.GetEol: Boolean;\r\nbegin\r\n  Result := Run = fLineLen + 1;\r\nend;\r\n\r\nfunction TSynVBScriptSyn.GetTokenID: TtkTokenKind;\r\nbegin\r\n  Result := fTokenId;\r\nend;\r\n\r\nfunction TSynVBScriptSyn.GetTokenAttribute: TSynHighlighterAttributes;\r\nbegin\r\n  case fTokenID of\r\n    tkComment: Result := fCommentAttri;\r\n    tkIdentifier: Result := fIdentifierAttri;\r\n    tkKey: Result := fKeyAttri;\r\n    tkNumber: Result := fNumberAttri;\r\n    tkSpace: Result := fSpaceAttri;\r\n    tkString: Result := fStringAttri;\r\n    tkSymbol: Result := fSymbolAttri;\r\n    tkUnknown: Result := fIdentifierAttri;\r\n    else Result := nil;\r\n  end;\r\nend;\r\n\r\nfunction TSynVBScriptSyn.GetTokenKind: integer;\r\nbegin\r\n  Result := Ord(fTokenId);\r\nend;\r\n\r\nfunction TSynVBScriptSyn.IsFilterStored: Boolean;\r\nbegin\r\n  Result := fDefaultFilter <> SYNS_FilterVBScript;\r\nend;\r\n\r\nclass function TSynVBScriptSyn.GetLanguageName: string;\r\nbegin\r\n  Result := SYNS_LangVBSScript;\r\nend;\r\n\r\nfunction TSynVBScriptSyn.GetSampleSource: UnicodeString;\r\nbegin\r\n  Result := ''' Syntax highlighting'#13#10 +\r\n            'function printNumber()'#13#10 +\r\n            '  number = 12345'#13#10 +\r\n            '  document.write(\"The number is \" + number)'#13#10 +\r\n            '  for i = 0 to 10'#13#10 +\r\n            '    x = x + 1.0'#13#10 +\r\n            '  next'#13#10 +\r\n            'end function';\r\nend;\r\n\r\nclass function TSynVBScriptSyn.GetFriendlyLanguageName: UnicodeString;\r\nbegin\r\n  Result := SYNS_FriendlyLangVBSScript;\r\nend;\r\n\r\ninitialization\r\n{$IFNDEF SYN_CPPB_1}\r\n  RegisterPlaceableHighlighter(TSynVBScriptSyn);\r\n{$ENDIF}\r\nend.\r\n"
  },
  {
    "path": "External/SynEdit/Source/SynHighlighterVrml97.pas",
    "content": "{-------------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: SynHighlighterVrml.pas, released 2002-10-21.\r\nThe Original Code is based on: SynHighlighterJScript.pas, released 2000-04-14.\r\nThe Original Code is based on the mwJScript.pas file from the\r\nmwEdit component suite by Martin Waldenburg and other developers, the Initial\r\nAuthor of this file is Tony de Buys.\r\nUnicode translation by Mal Hrz.\r\nAll Rights Reserved.\r\n\r\nContributors to the SynEdit and mwEdit projects are listed in the\r\nContributors.txt file.\r\n\r\nAlternatively, the contents of this file may be used under the terms of the\r\nGNU General Public License Version 2 or later (the \"GPL\"), in which case\r\nthe provisions of the GPL are applicable instead of those above.\r\nIf you wish to allow use of your version of this file only under the terms\r\nof the GPL and not to allow others to use your version of this file\r\nunder the MPL, indicate your decision by deleting the provisions above and\r\nreplace them with the notice and other provisions required by the GPL.\r\nIf you do not delete the provisions above, a recipient may use your version\r\nof this file under either the MPL or the GPL.\r\n\r\n$Id: SynHighlighterVrml97.pas,v 1.6.2.8 2008/09/14 16:25:03 maelh Exp $\r\n\r\nYou may retrieve the latest version of this file at the SynEdit home page,\r\nlocated at http://SynEdit.SourceForge.net\r\n\r\nKnown Issues:\r\n-------------------------------------------------------------------------------}\r\n{\r\n@abstract(Provides a Vrml97/X3D/JavaScript highlighter for SynEdit)\r\n@author(Massimo Maria Ghisalberti (nissl@mammuth.it)\r\n@created(november 2002 [December 1999, converted to SynEdit April 14, 2000])\r\n@lastmod(2002-11-03)\r\nThe SynHighlighterVrml97 unit provides SynEdit with a Vrml97/X3D/JavaScript (.wrl;*.x3d) highlighter.\r\nThe highlighter formats Vrml97/X3D source code highlighting keywords, strings, numbers and characters.\r\n}\r\n\r\n{ TODO: The Ansi version kept unclear to the status of following tokens:\r\n\r\n  Token       Ambiguity\r\n  =====       =========\r\n  bottom      tkVrmlAttribute or tkNonReservedKey\r\n  description tkVrmlAttribute or tkNonReservedKey\r\n  height      tkVrmlAttribute or tkNonReservedKey\r\n  location    tkVrmlAttribute or tkNonReservedKey\r\n  style       tkVrmlAttribute or tkNonReservedKey\r\n  type        tkVrmlAttribute or tkNonReservedKey\r\n\r\n  NULL        tkVrmlParameter or tkVrmlProto\r\n  FALSE       tkVrmlParameter or tkVrmlProto\r\n  \r\n  Text        tkVrmlShape or tkNonReservedKey\r\n\r\n  I took always the first one as this produces the same results as in the\r\n  Ansi-version, because the other cases were never reached (due to the way\r\n  the if construct was used).\r\n}\r\n\r\n{$IFNDEF QSYNHIGHLIGHTERVRML97}\r\nunit SynHighlighterVrml97;\r\n{$ENDIF}\r\n\r\n{$I SynEdit.inc}\r\n\r\ninterface\r\n\r\nuses\r\n{$IFDEF SYN_CLX}\r\n  Qt,\r\n  QControls,\r\n  QGraphics,\r\n  QSynEditTypes,\r\n  QSynEditHighlighter,\r\n  QSynHighlighterHashEntries,\r\n  QSynUnicode,\r\n{$ELSE}\r\n  Windows,\r\n  Messages,\r\n  Registry,\r\n  Controls,\r\n  Graphics,\r\n  SynEditTypes,\r\n  SynEditHighlighter,\r\n  SynHighlighterHashEntries,\r\n  SynUnicode,  \r\n{$ENDIF}\r\n  SysUtils,\r\n  Classes;\r\n\r\ntype\r\n  TtkTokenKind = (\r\n    tkComment,\r\n    tkIdentifier,\r\n    tkKey,\r\n    tkNull,\r\n    tkNumber,\r\n    tkSpace,\r\n    tkString,\r\n    tkSymbol,\r\n    tkUnknown,\r\n    tkNonReservedKey,\r\n    tkEvent,\r\n    tkVrmlAppearance,\r\n    tkVrmlAttribute,\r\n    tkVrmlDefinition,\r\n    tkVrmlEvent,\r\n    tkVrmlGrouping,\r\n    tkVrmlInterpolator,\r\n    tkVrmlLight,\r\n    tkVrmlNode,\r\n    tkVrmlParameter,\r\n    tkVrmlproto,\r\n    tkVrmlSensor,\r\n    tkVrmlShape,\r\n    tkVrmlShape_Hint,\r\n    tkVrmlTime_dependent,\r\n    tkVrmlViewpoint,\r\n    tkVrmlWorldInfo,\r\n    tkX3DDocType,\r\n    tkX3DHeader);\r\n\r\n  TRangeState = (rsNormalText, rsComment, rsX3DHeader, rsX3DDocType);\r\n\r\ntype\r\n  TSynVrml97Syn = class(TSynCustomHighLighter)\r\n  private\r\n    fRange :TRangeState;\r\n    isDoctype :boolean;\r\n    FTokenID :TtkTokenKind;\r\n    fCommentAttri :TSynHighlighterAttributes;\r\n    fIdentifierAttri :TSynHighlighterAttributes;\r\n    fKeyAttri :TSynHighlighterAttributes;\r\n    fNonReservedKeyAttri :TSynHighlighterAttributes;\r\n    fEventAttri :TSynHighlighterAttributes;\r\n    fNumberAttri :TSynHighlighterAttributes;\r\n    fSpaceAttri :TSynHighlighterAttributes;\r\n    fStringAttri :TSynHighlighterAttributes;\r\n    fSymbolAttri :TSynHighlighterAttributes;\r\n\r\n    fVrmlAppearanceAttri :TSynHighlighterAttributes;\r\n    fVrmlAttributeAttri :TSynHighlighterAttributes;\r\n    fVrmlDefinitionAttri :TSynHighlighterAttributes;\r\n    fVrmlEventAttri :TSynHighlighterAttributes;\r\n    fVrmlGroupingAttri :TSynHighlighterAttributes;\r\n    fVrmlInterpolatorAttri :TSynHighlighterAttributes;\r\n    fVrmlLightAttri :TSynHighlighterAttributes;\r\n    fVrmlNodeAttri :TSynHighlighterAttributes;\r\n    fVrmlParameterAttri :TSynHighlighterAttributes;\r\n    fVrmlprotoAttri :TSynHighlighterAttributes;\r\n    fVrmlSensorAttri :TSynHighlighterAttributes;\r\n    fVrmlShapeAttri :TSynHighlighterAttributes;\r\n    fVrmlShape_HintAttri :TSynHighlighterAttributes;\r\n    fVrmlTime_dependentAttri :TSynHighlighterAttributes;\r\n    fVrmlViewpointAttri :TSynHighlighterAttributes;\r\n    fVrmlWorldInfoAttri :TSynHighlighterAttributes;\r\n    fX3DDocTypeAttri :TSynHighlighterAttributes;\r\n    fX3DHeaderAttri :TSynHighlighterAttributes;\r\n\r\n    fKeywords: TSynHashEntryList;\r\n    procedure DoAddKeyword(AKeyword: UnicodeString; AKind: integer);\r\n    function HashKey(Str: PWideChar): Integer;\r\n    function IdentKind(MayBe: PWideChar): TtkTokenKind;\r\n    procedure AndSymbolProc;\r\n    procedure CommentProc;\r\n    procedure DiesisCommentProc;\r\n    procedure X3DDocTypeOpenProc;\r\n    procedure X3DDocTypeProc;\r\n    procedure X3DHeaderOpenProc;\r\n    procedure X3DHeaderProc;\r\n    procedure InCommentProc;\r\n    procedure CRProc;\r\n    procedure IdentProc;\r\n    procedure LFProc;\r\n    procedure MinusProc;\r\n    procedure ModSymbolProc;\r\n    procedure NullProc;\r\n    procedure NumberProc;\r\n    procedure OrSymbolProc;\r\n    procedure PlusProc;\r\n    procedure PointProc;\r\n    procedure SlashProc;\r\n    procedure SpaceProc;\r\n    procedure StarProc;\r\n    procedure StringProc;\r\n    procedure SymbolProc;\r\n    procedure UnknownProc;\r\n    function NextTokenIs(T: UnicodeString) :Boolean;\r\n  protected\r\n    function GetSampleSource: UnicodeString; override;\r\n    function IsFilterStored: Boolean; override;\r\n  public\r\n    class function GetLanguageName: string; override;\r\n    class function GetFriendlyLanguageName: UnicodeString; override;\r\n  public\r\n    constructor Create(AOwner: TComponent); override;\r\n    destructor Destroy; override;\r\n    function GetDefaultAttribute(Index :integer) :TSynHighlighterAttributes;\r\n      override;\r\n    function GetEol :Boolean; override;\r\n    function GetRange :Pointer; override;\r\n    function GetTokenID :TtkTokenKind;\r\n    function GetTokenAttribute :TSynHighlighterAttributes; override;\r\n    function GetTokenKind :integer; override;\r\n    procedure Next; override;\r\n    procedure SetRange(Value :Pointer); override;\r\n    procedure ResetRange; override;\r\n  published\r\n    property NonReservedKeyAttri :TSynHighlighterAttributes read fNonReservedKeyAttri write fNonReservedKeyAttri;\r\n    property NumberAttri :TSynHighlighterAttributes read fNumberAttri write fNumberAttri;\r\n    property SpaceAttri :TSynHighlighterAttributes read fSpaceAttri write fSpaceAttri;\r\n    property StringAttri :TSynHighlighterAttributes read fStringAttri write fStringAttri;\r\n    property SymbolAttri :TSynHighlighterAttributes read fSymbolAttri write fSymbolAttri;\r\n    property CommentAttri :TSynHighlighterAttributes read fCommentAttri write fCommentAttri;\r\n    property IdentifierAttri :TSynHighlighterAttributes read fIdentifierAttri write fIdentifierAttri;\r\n    property EcmaScriptKeyAttri :TSynHighlighterAttributes read fKeyAttri write fKeyAttri;\r\n    property EcmaScriptEventAttri :TSynHighlighterAttributes read fEventAttri write fEventAttri;\r\n\r\n    property VrmlAppearanceAttri :TSynHighlighterAttributes read fVrmlAppearanceAttri write fVrmlAppearanceAttri;\r\n    property VrmlAttributeAttri :TSynHighlighterAttributes read fVrmlAttributeAttri write fVrmlAttributeAttri;\r\n    property VrmlDefinitionAttri :TSynHighlighterAttributes read fVrmlDefinitionAttri write fVrmlDefinitionAttri;\r\n    property VrmlEventAttri :TSynHighlighterAttributes read fVrmlEventAttri write fVrmlEventAttri;\r\n    property VrmlGroupingAttri :TSynHighlighterAttributes read fVrmlGroupingAttri write fVrmlGroupingAttri;\r\n    property VrmlInterpolatorAttri :TSynHighlighterAttributes read fVrmlInterpolatorAttri write fVrmlInterpolatorAttri;\r\n    property VrmlLightAttri :TSynHighlighterAttributes read fVrmlLightAttri write fVrmlLightAttri;\r\n    property VrmlNodeAttri :TSynHighlighterAttributes read fVrmlNodeAttri write fVrmlNodeAttri;\r\n    property VrmlParameterAttri :TSynHighlighterAttributes read fVrmlParameterAttri write fVrmlParameterAttri;\r\n    property VrmlprotoAttri :TSynHighlighterAttributes read fVrmlprotoAttri write fVrmlprotoAttri;\r\n    property VrmlSensorAttri :TSynHighlighterAttributes read fVrmlSensorAttri write fVrmlSensorAttri;\r\n    property VrmlShapeAttri :TSynHighlighterAttributes read fVrmlShapeAttri write fVrmlShapeAttri;\r\n    property VrmlShape_HintAttri :TSynHighlighterAttributes read fVrmlShape_HintAttri write fVrmlShape_HintAttri;\r\n    property VrmlTime_dependentAttri :TSynHighlighterAttributes read fVrmlTime_dependentAttri write fVrmlTime_dependentAttri;\r\n    property VrmlViewpointAttri :TSynHighlighterAttributes read fVrmlViewpointAttri write fVrmlViewpointAttri;\r\n    property VrmlWorldInfoAttri :TSynHighlighterAttributes read fVrmlWorldInfoAttri write fVrmlWorldInfoAttri;\r\n    property X3DDocTypeAttri :TSynHighlighterAttributes read fX3DDocTypeAttri write fX3DDocTypeAttri;\r\n    property X3DHeaderAttri :TSynHighlighterAttributes read fX3DHeaderAttri write fX3DHeaderAttri;\r\n  end;\r\n\r\nimplementation\r\n\r\nuses\r\n{$IFDEF SYN_CLX}\r\n  QSynEditStrConst;\r\n{$ELSE}\r\n  SynEditStrConst;\r\n{$ENDIF}\r\n\r\nconst\r\n  Events: UnicodeString =\r\n    'onAbort, onBlur, onChange, onClick, onDblClick, onError, onFocus, ' +\r\n    'onKeyDown, onKeyPress, onKeyUp, onLoad, onMouseDown, onMouseMove, ' +\r\n    'onMouseOut, onMouseOver, onMouseUp, onReset, onSelect, onSubmit, ' +\r\n    'onUnload';\r\n\r\n  KeyWords: UnicodeString =\r\n    'abstract, boolean, break, byte, callee, case, catch, char, class, ' +\r\n    'const, constructor, continue, debugger, default, delete, do, DOCTYPE, ' +\r\n    'double, else, enum, export, extends, false, final, finally, float, for, ' +\r\n    'function, goto, head, if, implements, import, in, instanceof, int, ' +\r\n    'interface, long, meta, NaN, native, new, null, package, private, ' +\r\n    'protected, prototype, public, PUBLIC, return, short, start, static, ' +\r\n    'super, switch, synchronized, this, throw, throws, transient, true, try, ' +\r\n    'typeof, var, void, while, with, xml';\r\n\r\n  NonReservedKeys: UnicodeString =\r\n    'abs, acos, action, alert, align, alinkColor, all, All, anchor, anchors, ' +\r\n    'appCodeName, Applet, applets, appName, appVersion, Area, arguments, ' +\r\n    'Arguments, Array, asin, atan, atan2, back, background, bgColor, big, ' +\r\n    'blink, blur, body, bold, Boolean, border, Button, call, caller, ' +\r\n    'captureEvents, ceil, charAt, charCodeAt, Checkbox, checked, clear, ' +\r\n    'clearInterval, clearTimeout, click, close, closed, complete, concat, ' +\r\n    'confirm, content, cookie, cos, current, Date, defaultChecked, ' +\r\n    'defaultSelected, defaultStatus, defaultValue, display, document, ' +\r\n    'domain, E, elements, Embed, embeds, enabledPlugin, encoding, escape, ' +\r\n    'eval, event, exp, fgColor, filename, FileUpload, find, fixed, Float, ' +\r\n    'floor, focus, fontcolor, fontsize, form, Form, forms, forward, Frame, ' +\r\n    'frames, fromCharCode, Function, getDate, getDay, getElementById, ' +\r\n    'getFullYear, getHours, getMilliseconds, getMinutes, getMonth, ' +\r\n    'getSeconds, getTime, getTimezoneOffset, getUTCDate, getUTCDay, ' +\r\n    'getUTCFullYear, getUTCHours, getUTCMilliseconds, getUTCMinutes, ' +\r\n    'getUTCMonth, getUTCSeconds, getYear, Global, go, handleEvent, hash, ' +\r\n    'Hidden, history, History, home, host, hostname, href, hspace, Image, ' +\r\n    'images, index, indexOf, Infinity, innerHeight, innerWidth, input, ' +\r\n    'isFinite, isNaN, italics, java, javaEnabled, join, lastIndexOf, ' +\r\n    'lastModified, Layer, layers, left, link, Link, linkColor, links, LN10, ' +\r\n    'LN2, Location, locationbar, log, LOG10E, LOG2E, logon, lowsrc, match, ' +\r\n    'Math, max, MAX_VALUE, menubar, method, MimeType, mimeTypes, min, ' +\r\n    'MIN_VALUE, moveBy, moveTo, name, navigator, Navigator, ' +\r\n    'NEGATIVE_INFINITY, netscape, next, Null, Number, Object, open, opener, ' +\r\n    'Option, options, outerHeight, outerWidth, Packages, pageX, pageXOffset, ' +\r\n    'pageY, pageYOffset, parent, parse, parseFloat, parseInt, Password, ' +\r\n    'pathname, personalbar, PI, platform, Plugin, plugins, port, ' +\r\n    'POSITIVE_INFINITY, pow, previous, print, prompt, protocol, Radio, ' +\r\n    'random, referrer, refresh, RegExp, releaseEvents, reload, replace, ' +\r\n    'reset, Reset, resizeBy, resizeTo, reverse, right, round, routeEvent, ' +\r\n    'screen, scroll, scrollbars, scrollBy, scrollTo, search, select, Select, ' +\r\n    'selected, selectedIndex, self, setDate, setFullYear, setHours, ' +\r\n    'setInterval, setMilliseconds, setMinutes, setMonth, setSeconds, ' +\r\n    'setTime, setTimeout, setUTCDate, setUTCFullYear, setUTCHours, ' +\r\n    'setUTCMilliseconds, setUTCMinutes, setUTCMonth, setUTCSeconds, setYear, ' +\r\n    'sin, slice, small, sort, split, sqrt, SQRT1_2, SQRT2, src, status, ' +\r\n    'statusbar, stop, strike, String, sub, submit, Submit, substr, ' +\r\n    'substring, suffixes, sup, tags, taint, taintEnabled, tan, target, text, ' +\r\n    'Textarea, title, toGMTString, toLocaleString, toLowerCase, toolbar, ' +\r\n    'toSource, toString, toUpperCase, toUTCString, undefined, Undefined, ' +\r\n    'unescape, untaint, unwatch, URL, userAgent, UTC, value, valueOf, ' +\r\n    'version, visibility, vlinkColor, vspace, watch, width, window, Window, ' +\r\n    'write, writeln, zIndex';\r\n\r\n  VrmlAppearances: UnicodeString =\r\n    'Appearance, ImageTexture, Material, NurbsTextureSurface, PixelTexture, ' +\r\n    'TextureBackground, TextureCoordinate, TextureCoordinateGenerator, ' +\r\n    'TextureTransform';\r\n\r\n  VrmlAttributes: UnicodeString =\r\n    'addChildren, ambientIntensity, appearance, attenuation, autoOffset, ' +\r\n    'avatarSize, axisOfRotation, backUrl, bboxCenter, bboxSize, beamWidth, ' +\r\n    'beginCap, bindTime, bottom, bottomRadius, bottomUrl, ccw, center, children, ' +\r\n    'choice, collide, collideTime, color, colorIndex, colorPerVertex, ' +\r\n    'ColorRGBA, convex, coord, coordIndex, creaseAngle, crossSection, ' +\r\n    'cutOffAngle, cycleInterval, cycleTime, description, diffuseColor, direction, ' +\r\n    'directOutput, diskAngle, duration_changed, emissiveColor, enabled, ' +\r\n    'endCap, enterTime, eventName, eventType, exitTime, family, fieldName, ' +\r\n    'fieldOfView, fieldType, FillProperties, fogType, fontStyle, ' +\r\n    'fraction_changed, frontUrl, GeoCoordinate, GeoElevationGrid, ' +\r\n    'GeoLocation, GeoLOD, GeoMetadata, geometry, GeoOrigin, groundAngle, ' +\r\n    'groundColor, headlight, height, hitNormal_changed, hitPoint_changed, ' +\r\n    'hitTexCoord_changed, horizontal, image, info, intensity, isActive, ' +\r\n    'isBound, isOver, jump, justify, key, keyValue, language, leftToRight, ' +\r\n    'leftUrl, length, level, LineProperties, location, loop, material, maxAngle, ' +\r\n    'maxBack, maxExtent, maxFront, maxPosition, minAngle, minBack, minFront, ' +\r\n    'minPosition, MultiTexture, MultiTextureCoordinate, mustEvaluate, ' +\r\n    'normal, normalIndex, normalPerVertex, offset, on, orientation, ' +\r\n    'orientation_changed, parameter, pitch, point, position, ' +\r\n    'position_changed, priority, proxy, radius, range, removeChildren, ' +\r\n    'repeatS, repeatT, rightUrl, rotation, rotation_changed, scale, ' +\r\n    'scaleOrientation, set_bind, set_colorIndex, set_coordIndex, ' +\r\n    'set_crossSection, set_fraction, set_height, set_normalIndex, ' +\r\n    'set_orientation, set_scale, set_spine, set_texCoordIndex, shininess, ' +\r\n    'side, size, skyAngle, skyColor, solid, source, spacing, spatialize, ' +\r\n    'specularColor, speed, spine, startTime, stopTime, string, style, texCoord, ' +\r\n    'texCoordIndex, texture, textureTransform, time, top, topToBottom, ' +\r\n    'topUrl, touchTime, trackPoint_changed, translation, ' +\r\n    'translation_changed, transparency, type, url, value_changed, vector, ' +\r\n    'visibilityLimit, visibilityRange, whichChoice, xDimension, xSpacing, ' +\r\n    'zDimension, zSpacing';\r\n\r\n  VrmlDefinitions: UnicodeString =\r\n    'MFColor, MFFloat, MFInt32, MFNode, MFRotation, MFString, MFTime, ' +\r\n    'MFVec2f, MFVec3f, SFBool, SFColor, SFFloat, SFImage, SFInt32, SFNode, ' +\r\n    'SFRotation, SFString, SFTime, SFVec2f, SFVec3f';\r\n\r\n  VrmlEvents: UnicodeString =\r\n    'eventIn, eventOut, exposedField, field';\r\n\r\n  VrmlGroupings: UnicodeString =\r\n    'Anchor, Billboard, Collision, ESPDUTransform, Group, Inline, LOD, ' +\r\n    'NurbsGroup, ReceiverPdu, SignalPdu, StaticGroup, Switch, Transform, ' +\r\n    'Transform2D, TransmitterPdu';\r\n\r\n  VrmlInterpolators: UnicodeString =\r\n    'ColorInterpolator, CoordinateInterpolator, CoordinateInterpolator2D, ' +\r\n    'GeoPositionInterpolator, NormalInterpolator, NurbsPositionInterpolator, ' +\r\n    'OrientationInterpolator, PositionInterpolator, PositionInterpolator2D, ' +\r\n    'ScalarInterpolator';\r\n\r\n  VrmlLights: UnicodeString =\r\n    'DirectionalLight, PointLight, SpotLight';\r\n\r\n  VrmlNodes: UnicodeString =\r\n    'Background, Color, Coordinate, CoordinateDeformer, Fog, FontStyle, ' +\r\n    'Joint, NavigationInfo, Normal, Script, Site, Sound';\r\n\r\n  VrmlParameters: UnicodeString =\r\n    'ALL, AUTO, BINDINGS, BOLD, BOTTOM, CENTER, CLAMP, CLOCKWISE, CONVEX, ' +\r\n    'COUNTERCLOCKWISE, CULLING, DEFAULT, DEFAULTS, Displacer, ENUMS, FACE, FALSE, ' +\r\n    'FAMILY, FILE, FORMAT, ITALIC, JUSTIFICATION, LEFT, NONE, NULL, OFF, ON, ' +\r\n    'OVERALL, PARTS, PER_FACE, PER_FACE_INDEXED, PER_PART, PER_PART_INDEXED, ' +\r\n    'PER_VERTEX, PER_VERTEX_INDEXED, REPEAT, RIGHT, SHAPE, SIDES, SOLID, ' +\r\n    'STYLE, TRUE, TYPE, UNKNOWN_FACE_TYPE, UNKNOWN_ORDERING, ' +\r\n    'UNKNOWN_SHAPE_TYPE, WRAP';\r\n\r\n  VrmlProtos: UnicodeString =\r\n    'DEF, EXTERNPROTO, IS, PROTO, ROUTE, Scene, TO, USE, VRML, X3D, ' +\r\n    'X3DAppearanceNode, X3DAppearanceChildNode, X3DBackgroundNode, X3DBindableNode, ' +\r\n    'X3DBoundedObject, X3DChildNode, X3DColorNode, X3DComposedGeometryNode, ' +\r\n    'X3DCoordinateNode, X3DDragSensorNode, X3DEnvironmentalSensorNode, ' +\r\n    'X3DFontStyleNode, X3DGeometry2DNode, X3DGeometry3DNode, ' +\r\n    'X3DGeometryNode, X3DGeometryPropertyNode, X3DGroupingNode, ' +\r\n    'X3DInterpolatorNode, X3DKeyDeviceSensorNode, X3DLightNode, ' +\r\n    'X3DMaterialNode, X3DNetworkSensorNode, X3DNode, X3DNormalNode, ' +\r\n    'X3DParametricGeometryNode, X3DPointingDeviceSensorNode, ' +\r\n    'X3DPrototypeInstance, X3DScriptNode, X3DSensorNode, X3DSequencerNode, ' +\r\n    'X3DShapeNode, X3DSoundNode, X3DSoundSourceNode, X3DTexture2DNode, ' +\r\n    'X3DTextureCoordinateNode, X3DTextureNode, X3DTextureTransform2DNode, ' +\r\n    'X3DTextureTransformNode, X3DTimeDependentNode, X3DTouchSensorNode, ' +\r\n    'X3DTriggerNode, X3DUrlObject';\r\n\r\n  VrmlSensors: UnicodeString =\r\n    'BooleanFilter, BooleanSequencer, BooleanToggle, BooleanTrigger, ' +\r\n    'CylinderSensor, GeoTouchSensor, IntegerTrigger, KeySensor, LoadSensor, ' +\r\n    'PlaneSensor, ProximitySensor, SphereSensor, StringSensor, TimeSensor, ' +\r\n    'TouchSensor, VisibilitySensor';\r\n\r\n  VrmlShapes: UnicodeString =\r\n    'Arc2D, ArcClose2D, Box, Circle2D, Cone, Contour2D, ContourPolyline2D, ' +\r\n    'Cylinder, Disk2D, ElevationGrid, Humanoid, NurbsCurve, NurbsCurve2D, ' +\r\n    'NurbsSurface, PointSet, Polyline2D, Polypoint2D, Rectangle2D, Segment, ' +\r\n    'Shape, Shape2D, Sphere, Text, TriangleFanSet, TriangleSet, TriangleSet2D, ' +\r\n    'TriangleStripSet, TrimmedSurface';\r\n\r\n  VrmlShape_Hints: UnicodeString =\r\n    'Extrusion, IndexedFaceSet, IndexedLineSet';\r\n\r\n  VrmlTime_dependents: UnicodeString =\r\n    'AudioClip, IntegerSequencer, MovieTexture, TimeTrigger';\r\n\r\n  VrmlViewpoints: UnicodeString =\r\n    'GeoViewpoint, Viewpoint';\r\n\r\n  VrmlWorldInfos: UnicodeString =\r\n    'WorldInfo';\r\n\r\n\r\nprocedure TSynVrml97Syn.DoAddKeyword(AKeyword: UnicodeString; AKind: integer);\r\nvar\r\n  HashValue: integer;\r\nbegin\r\n  HashValue := HashKey(PWideChar(AKeyword));\r\n  fKeywords[HashValue] := TSynHashEntry.Create(AKeyword, AKind);\r\nend;\r\n\r\nfunction TSynVrml97Syn.HashKey(Str: PWideChar): Integer;\r\n\r\n  function GetOrd: Integer;\r\n  begin\r\n    case Str^ of\r\n      'a'..'z': Result := 1 + Ord(Str^) - Ord('a');\r\n      'A'..'Z': Result := 27 + Ord(Str^) - Ord('A');\r\n      '0'..'9': Result := 54 + Ord(Str^) - Ord('0');\r\n      '_': Result := 53;\r\n      else Result := 0;\r\n    end\r\n  end;\r\n\r\nbegin\r\n  Result := 0;\r\n  while IsIdentChar(Str^) do\r\n  begin\r\n{$IFOPT Q-}\r\n    Result := 7 * Result + GetOrd;\r\n{$ELSE}\r\n    Result := (7 * Result + GetOrd) and $FFFFFF;\r\n{$ENDIF}\r\n    Inc(Str);\r\n  end;\r\n  Result := Result and $FF; // 255\r\n  fStringLen := Str - fToIdent;\r\nend;\r\n\r\nfunction TSynVrml97Syn.IdentKind(MayBe: PWideChar): TtkTokenKind;\r\nvar\r\n  Entry: TSynHashEntry;\r\nbegin\r\n  fToIdent := MayBe;\r\n  Entry := fKeywords[HashKey(MayBe)];\r\n  while Assigned(Entry) do\r\n  begin\r\n    if Entry.KeywordLen > fStringLen then\r\n      break\r\n    else if Entry.KeywordLen = fStringLen then\r\n      if IsCurrentToken(Entry.Keyword) then\r\n      begin\r\n        Result := TtkTokenKind(Entry.Kind);\r\n        exit;\r\n      end;\r\n    Entry := Entry.Next;\r\n  end;\r\n  Result := tkIdentifier;\r\nend;\r\n\r\nconstructor TSynVrml97Syn.Create(AOwner :TComponent);\r\nbegin\r\n  inherited Create(AOwner);\r\n\r\n  fCaseSensitive := True;\r\n\r\n  fKeywords := TSynHashEntryList.Create;\r\n  isDoctype := False;\r\n  fCommentAttri := TSynHighlighterAttributes.Create(SYNS_AttrComment, SYNS_FriendlyAttrComment);\r\n  fCommentAttri.Style := [fsItalic];\r\n  fCommentAttri.Foreground := clNavy;\r\n  fCommentAttri.Background := clGray;\r\n  AddAttribute(fCommentAttri);\r\n\r\n  fIdentifierAttri := TSynHighlighterAttributes.Create(SYNS_AttrIdentifier, SYNS_FriendlyAttrIdentifier);\r\n  fIdentifierAttri.Style := [];\r\n  fIdentifierAttri.Foreground := clNavy;\r\n  fIdentifierAttri.Background := clWhite;\r\n  AddAttribute(fIdentifierAttri);\r\n\r\n  fKeyAttri := TSynHighlighterAttributes.Create(SYNS_AttrReservedWord, SYNS_FriendlyAttrReservedWord);\r\n  fKeyAttri.Style := [fsBold];\r\n  fKeyAttri.Foreground := clRed;\r\n  fKeyAttri.Background := clWhite;\r\n  AddAttribute(fKeyAttri);\r\n\r\n  fNonReservedKeyAttri := TSynHighlighterAttributes.Create(SYNS_AttrNonReservedKeyword, SYNS_FriendlyAttrNonReservedKeyword);\r\n  fNonReservedKeyAttri.Style := [fsItalic];\r\n  fNonReservedKeyAttri.Foreground := clBlack;\r\n  fNonReservedKeyAttri.Background := clWhite;\r\n  AddAttribute(fNonReservedKeyAttri);\r\n\r\n  fEventAttri := TSynHighlighterAttributes.Create(SYNS_AttrEvent, SYNS_FriendlyAttrEvent);\r\n  fEventAttri.Style := [fsItalic];\r\n  fEventAttri.Foreground := clNavy;\r\n  fEventAttri.Background := clWhite;\r\n  AddAttribute(fEventAttri);\r\n\r\n  fNumberAttri := TSynHighlighterAttributes.Create(SYNS_AttrNumber, SYNS_FriendlyAttrNumber);\r\n  fEventAttri.Style := [fsItalic];\r\n  fEventAttri.Foreground := clNavy;\r\n  fEventAttri.Background := clWhite;\r\n  AddAttribute(fNumberAttri);\r\n\r\n  fSpaceAttri := TSynHighlighterAttributes.Create(SYNS_AttrSpace, SYNS_FriendlyAttrSpace);\r\n  fSpaceAttri.Style := [fsItalic];\r\n  fSpaceAttri.Foreground := clNavy;\r\n  AddAttribute(fSpaceAttri);\r\n\r\n  fStringAttri := TSynHighlighterAttributes.Create(SYNS_AttrString, SYNS_FriendlyAttrString);\r\n  fStringAttri.Style := [fsItalic];\r\n  fStringAttri.Foreground := clNavy;\r\n  fStringAttri.Background := clWhite;\r\n  AddAttribute(fStringAttri);\r\n\r\n  fSymbolAttri := TSynHighlighterAttributes.Create(SYNS_AttrSymbol, SYNS_FriendlyAttrSymbol);\r\n  fSymbolAttri.Style := [fsItalic];\r\n  fSymbolAttri.Foreground := clNavy;\r\n  fSymbolAttri.Background := clWhite;\r\n  AddAttribute(fSymbolAttri);\r\n  //-- vrml\r\n  fVrmlAppearanceAttri := TSynHighlighterAttributes.Create(SYNS_AttrVrmlAppearance, SYNS_FriendlyAttrVrmlAppearance);\r\n  fVrmlAppearanceAttri.Style := [fsItalic];\r\n  fVrmlAppearanceAttri.Foreground := clNavy;\r\n  fVrmlAppearanceAttri.Background := clWhite;\r\n  AddAttribute(fVrmlAppearanceAttri);\r\n\r\n  fVrmlAttributeAttri := TSynHighlighterAttributes.Create(SYNS_AttrVrmlAttribute, SYNS_FriendlyAttrVrmlAttribute);\r\n  fVrmlAttributeAttri.Style := [fsItalic];\r\n  fVrmlAttributeAttri.Foreground := clNavy;\r\n  fVrmlAttributeAttri.Background := clGray;\r\n  AddAttribute(fVrmlAttributeAttri);\r\n\r\n  fVrmlDefinitionAttri := TSynHighlighterAttributes.Create(SYNS_AttrVrmlDefinition, SYNS_FriendlyAttrVrmlDefinition);\r\n  fVrmlDefinitionAttri.Style := [fsItalic];\r\n  fVrmlDefinitionAttri.Foreground := clNavy;\r\n  fVrmlDefinitionAttri.Background := clRed;\r\n  AddAttribute(fVrmlDefinitionAttri);\r\n\r\n  fVrmlEventAttri := TSynHighlighterAttributes.Create(SYNS_AttrVrmlEvent, SYNS_FriendlyAttrVrmlEvent);\r\n  fVrmlEventAttri.Style := [fsBold];\r\n  fVrmlEventAttri.Foreground := clRed;\r\n  fVrmlEventAttri.Background := clWhite;\r\n  AddAttribute(fVrmlEventAttri);\r\n\r\n  fVrmlGroupingAttri := TSynHighlighterAttributes.Create(SYNS_AttrVrmlGrouping, SYNS_FriendlyAttrVrmlGrouping);\r\n  fVrmlGroupingAttri.Style := [fsBold];\r\n  fVrmlGroupingAttri.Foreground := clNavy;\r\n  fVrmlGroupingAttri.Background := clWhite;\r\n  AddAttribute(fVrmlGroupingAttri);\r\n\r\n  fVrmlInterpolatorAttri := TSynHighlighterAttributes.Create(SYNS_AttrVrmlInterpolator, SYNS_FriendlyAttrVrmlInterpolator);\r\n  fVrmlInterpolatorAttri.Style := [fsItalic];\r\n  fVrmlInterpolatorAttri.Foreground := clLime;\r\n  fVrmlInterpolatorAttri.Background := clWhite;\r\n  AddAttribute(fVrmlInterpolatorAttri);\r\n\r\n  fVrmlLightAttri := TSynHighlighterAttributes.Create(SYNS_AttrVrmlLight, SYNS_FriendlyAttrVrmlLight);\r\n  fVrmlLightAttri.Style := [fsItalic];\r\n  fVrmlLightAttri.Foreground := clTeal;\r\n  fVrmlLightAttri.Background := clWhite;\r\n  AddAttribute(fVrmlLightAttri);\r\n\r\n  fVrmlNodeAttri := TSynHighlighterAttributes.Create(SYNS_AttrVrmlNode, SYNS_FriendlyAttrVrmlNode);\r\n  fVrmlNodeAttri.Style := [fsItalic, fsBold];\r\n  fVrmlNodeAttri.Foreground := clGreen;\r\n  fVrmlNodeAttri.Background := clWhite;\r\n  AddAttribute(fVrmlNodeAttri);\r\n\r\n  fVrmlParameterAttri := TSynHighlighterAttributes.Create(SYNS_AttrVrmlParameter, SYNS_FriendlyAttrVrmlParameter);\r\n  fVrmlParameterAttri.Style := [fsBold];\r\n  fVrmlParameterAttri.Foreground := $F0CAA6; //clSkyBlue\r\n  fVrmlParameterAttri.Background := clWhite;\r\n  AddAttribute(fVrmlParameterAttri);\r\n\r\n  fVrmlprotoAttri := TSynHighlighterAttributes.Create(SYNS_AttrVrmlProto, SYNS_FriendlyAttrVrmlProto);\r\n  fVrmlprotoAttri.Style := [fsBold];\r\n  fVrmlprotoAttri.Foreground := clRed;\r\n  fVrmlprotoAttri.Background := clWhite;\r\n  AddAttribute(fVrmlprotoAttri);\r\n\r\n  fVrmlSensorAttri := TSynHighlighterAttributes.Create(SYNS_AttrVrmlSensor, SYNS_FriendlyAttrVrmlSensor);\r\n  fVrmlSensorAttri.Style := [fsBold];\r\n  fVrmlSensorAttri.Foreground := clOlive;\r\n  fVrmlSensorAttri.Background := clWhite;\r\n  AddAttribute(fVrmlSensorAttri);\r\n\r\n  fVrmlShapeAttri := TSynHighlighterAttributes.Create(SYNS_AttrVrmlShape, SYNS_FriendlyAttrVrmlShape);\r\n  fVrmlShapeAttri.Style := [fsBold];\r\n  fVrmlShapeAttri.Foreground := clPurple;\r\n  fVrmlShapeAttri.Background := clWhite;\r\n  AddAttribute(fVrmlShapeAttri);\r\n\r\n  fVrmlShape_HintAttri := TSynHighlighterAttributes.Create(SYNS_AttrVrmlShape_Hint, SYNS_FriendlyAttrVrmlShape_Hint);\r\n  fVrmlShape_HintAttri.Style := [fsItalic];\r\n  fVrmlShape_HintAttri.Foreground := clPurple;\r\n  fVrmlShape_HintAttri.Background := clWhite;\r\n  AddAttribute(fVrmlShape_HintAttri);\r\n\r\n  fVrmlTime_dependentAttri := TSynHighlighterAttributes.Create(SYNS_AttrVrmlTime_dependent, SYNS_FriendlyAttrVrmlTime_dependent);\r\n  fVrmlTime_dependentAttri.Style := [fsItalic];\r\n  fVrmlTime_dependentAttri.Foreground := clOlive;\r\n  fVrmlTime_dependentAttri.Background := clWhite;\r\n  AddAttribute(fVrmlTime_dependentAttri);\r\n\r\n  fVrmlViewpointAttri := TSynHighlighterAttributes.Create(SYNS_AttrVrmlViewpoint, SYNS_FriendlyAttrVrmlViewpoint);\r\n  fVrmlViewpointAttri.Style := [fsItalic];\r\n  fVrmlViewpointAttri.Foreground := clGreen;\r\n  fVrmlViewpointAttri.Background := clWhite;\r\n  AddAttribute(fVrmlViewpointAttri);\r\n\r\n  fVrmlWorldInfoAttri := TSynHighlighterAttributes.Create(SYNS_AttrVrmlWorldInfo, SYNS_FriendlyAttrVrmlWorldInfo);\r\n  fVrmlWorldInfoAttri.Style := [fsItalic];\r\n  fVrmlWorldInfoAttri.Foreground := clMaroon;\r\n  fVrmlWorldInfoAttri.Background := clWhite;\r\n  AddAttribute(fVrmlWorldInfoAttri);\r\n\r\n  fX3DDocTypeAttri := TSynHighLighterAttributes.Create(SYNS_AttrX3DDocType, SYNS_FriendlyAttrX3DDocType);\r\n  fX3DDocTypeAttri.Style := [fsItalic];\r\n  fX3DDocTypeAttri.Foreground := clMaroon;\r\n  fX3DDocTypeAttri.Background := clWhite;\r\n  AddAttribute(fX3DDocTypeAttri);\r\n\r\n  fX3DHeaderAttri := TSynHighLighterAttributes.Create(SYNS_AttrX3DHeader, SYNS_FriendlyAttrX3DHeader);\r\n  fX3DHeaderAttri.Style := [fsItalic];\r\n  fX3DHeaderAttri.Foreground := clMaroon;\r\n  fX3DHeaderAttri.Background := clWhite;\r\n  AddAttribute(fX3DHeaderAttri);\r\n  SetAttributesOnChange(DefHighlightChange);\r\n\r\n  EnumerateKeywords(Ord(tkEvent), Events, IsIdentChar, DoAddKeyword);\r\n  EnumerateKeywords(Ord(tkKey), KeyWords, IsIdentChar, DoAddKeyword);\r\n  EnumerateKeywords(Ord(tkNonReservedKey), NonReservedKeys, IsIdentChar, DoAddKeyword);\r\n  EnumerateKeywords(Ord(tkVrmlAppearance), VrmlAppearances, IsIdentChar, DoAddKeyword);\r\n  EnumerateKeywords(Ord(tkVrmlAttribute), VrmlAttributes, IsIdentChar, DoAddKeyword);\r\n  EnumerateKeywords(Ord(tkVrmlDefinition), VrmlDefinitions, IsIdentChar, DoAddKeyword);\r\n  EnumerateKeywords(Ord(tkVrmlEvent), VrmlEvents, IsIdentChar, DoAddKeyword);\r\n  EnumerateKeywords(Ord(tkVrmlGrouping), VrmlGroupings, IsIdentChar, DoAddKeyword);\r\n  EnumerateKeywords(Ord(tkVrmlInterpolator), VrmlInterpolators, IsIdentChar, DoAddKeyword);\r\n  EnumerateKeywords(Ord(tkVrmlLight), VrmlLights, IsIdentChar, DoAddKeyword);\r\n  EnumerateKeywords(Ord(tkVrmlNode), VrmlNodes, IsIdentChar, DoAddKeyword);\r\n  EnumerateKeywords(Ord(tkVrmlParameter), VrmlParameters, IsIdentChar, DoAddKeyword);\r\n  EnumerateKeywords(Ord(tkVrmlproto), VrmlProtos, IsIdentChar, DoAddKeyword);\r\n  EnumerateKeywords(Ord(tkVrmlSensor), VrmlSensors, IsIdentChar, DoAddKeyword);\r\n  EnumerateKeywords(Ord(tkVrmlShape), VrmlShapes, IsIdentChar, DoAddKeyword);\r\n  EnumerateKeywords(Ord(tkVrmlShape_Hint), VrmlShape_Hints, IsIdentChar, DoAddKeyword);\r\n  EnumerateKeywords(Ord(tkVrmlTime_dependent), VrmlTime_dependents, IsIdentChar, DoAddKeyword);\r\n  EnumerateKeywords(Ord(tkVrmlViewpoint), VrmlViewpoints, IsIdentChar, DoAddKeyword);\r\n  EnumerateKeywords(Ord(tkVrmlWorldInfo), VrmlWorldInfos, IsIdentChar, DoAddKeyword);\r\n\r\n  fDefaultFilter := SYNS_FilterVrml97;\r\n  fRange := rsNormalText;\r\nend;\r\n\r\ndestructor TSynVrml97Syn.Destroy;\r\nbegin\r\n  fKeywords.Free;\r\n  inherited Destroy;\r\nend;\r\n\r\nprocedure TSynVrml97Syn.AndSymbolProc;\r\nbegin\r\n  fTokenID := tkSymbol;\r\n  inc(Run);\r\n  if CharInSet(fLine[Run], ['=', '&']) then inc(Run);\r\nend;\r\n\r\nfunction TSynVrml97Syn.NextTokenIs(T: UnicodeString): Boolean;\r\nvar\r\n  I, Len: Integer;\r\nbegin\r\n  Result := True;\r\n  Len := Length(T);\r\n  for I := 1 to Len do\r\n    if (fLine[Run + I] <> T[I]) then\r\n    begin\r\n      Result := False;\r\n      Break;\r\n    end;\r\nend;\r\n\r\nprocedure TSynVrml97Syn.InCommentProc;\r\nbegin\r\n  if (fLine[Run + 1] = '-') and (fLine[Run + 2] = '-') then\r\n    begin\r\n      Inc(Run);\r\n      fTokenID := tkComment;\r\n      fRange := rsComment;\r\n      Inc(Run, 2);\r\n      repeat\r\n        Inc(Run);\r\n        if (fLine[Run] = '-') and (fLine[Run + 1] = '-') then\r\n          begin\r\n            fRange := rsNormalText;\r\n            Inc(Run, 2);\r\n            break;\r\n          end;\r\n      until IsLineEnd(Run);\r\n      Exit;\r\n    end;\r\nend;\r\n\r\nprocedure TSynVrml97Syn.DiesisCommentProc;\r\nbegin\r\n  if fLine[Run] = #0 then\r\n    NullProc\r\n  else\r\n    begin\r\n      fTokenID := tkComment;\r\n      repeat\r\n        inc(Run);\r\n      until IsLineEnd(Run);\r\n    end;\r\nend;\r\n\r\nprocedure TSynVrml97Syn.X3DHeaderOpenProc;\r\nbegin\r\n  Inc(Run);\r\n  fRange := rsX3DHeader;\r\n  X3DHeaderProc;\r\n  fTokenID := tkX3DHeader;\r\nend;\r\n\r\nprocedure TSynVrml97Syn.X3DHeaderProc;\r\nbegin\r\n  case fLine[Run] of\r\n    #0 :NullProc;\r\n    #10 :LFProc;\r\n    #13 :CRProc;\r\n    else\r\n      begin\r\n        fTokenID := tkX3DHeader;\r\n        repeat\r\n          if (fLine[Run] = '?') then\r\n            begin\r\n              Inc(Run, 1);\r\n              fRange := rsNormalText;\r\n              Break;\r\n            end;\r\n          if not IsLineEnd(Run) then\r\n            Inc(Run);\r\n        until IsLineEnd(Run);\r\n      end;\r\n  end;\r\nend;\r\n\r\nprocedure TSynVrml97Syn.X3DDocTypeOpenProc;\r\nbegin\r\n  if NextTokenIs('DOCTYPE') then\r\n    begin\r\n      fRange := rsX3DDocType;\r\n      X3DDocTypeProc;\r\n      fTokenID := tkX3DDocType;\r\n    end\r\n  else\r\n    if NextTokenIs('--') then\r\n      begin\r\n        fRange := rsComment;\r\n        InCommentProc;\r\n        fTokenID := tkComment;\r\n      end\r\n    else\r\n    begin\r\n      fTokenID := tkSymbol;\r\n      inc(Run);\r\n    end;\r\nend;\r\n\r\nprocedure TSynVrml97Syn.X3DDocTypeProc;\r\nbegin\r\n  case fLine[Run] of\r\n    #0 :NullProc;\r\n    #10 :LFProc;\r\n    #13 :CRProc;\r\n    else\r\n      begin\r\n        fTokenID := tkX3DDocType;\r\n        repeat\r\n          if (fLine[Run + 1] = '>') then\r\n            begin\r\n              Inc(Run, 1);\r\n              fRange := rsNormalText;\r\n              Break;\r\n            end;\r\n          if not IsLineEnd(Run) then\r\n            Inc(Run);\r\n        until IsLineEnd(Run);\r\n      end;\r\n  end;\r\nend;\r\n\r\nprocedure TSynVrml97Syn.CommentProc;\r\nbegin\r\n  if fLine[Run] = #0 then\r\n    NullProc\r\n  else\r\n    begin\r\n      fTokenID := tkComment;\r\n      repeat\r\n        if ((fLine[Run] = '*') and (fLine[Run + 1] = '/'))\r\n          or\r\n          ((fLine[Run] = '-') and (fLine[Run + 1] = '-')) then\r\n          begin\r\n            fRange := rsNormalText;\r\n            inc(Run, 2);\r\n            break;\r\n          end;\r\n        inc(Run);\r\n      until IsLineEnd(Run);\r\n    end;\r\nend;\r\n\r\nprocedure TSynVrml97Syn.CRProc;\r\nbegin\r\n  fTokenID := tkSpace;\r\n  inc(Run);\r\n  if fLine[Run] = #10 then inc(Run);\r\nend;\r\n\r\nprocedure TSynVrml97Syn.IdentProc;\r\nbegin\r\n  fTokenID := IdentKind(fLine + Run);\r\n  inc(Run, fStringLen);\r\n  while IsIdentChar(fLine[Run]) do\r\n    inc(Run);\r\nend;\r\n\r\nprocedure TSynVrml97Syn.LFProc;\r\nbegin\r\n  fTokenID := tkSpace;\r\n  inc(Run);\r\nend;\r\n\r\nprocedure TSynVrml97Syn.MinusProc;\r\nbegin\r\n  fTokenID := tkSymbol;\r\n  inc(Run);\r\n  if CharInSet(fLine[Run], ['=', '-', '>']) then inc(Run);\r\nend;\r\n\r\nprocedure TSynVrml97Syn.ModSymbolProc;\r\nbegin\r\n  fTokenID := tkSymbol;\r\n  inc(Run);\r\n  if fLine[Run] = '=' then inc(Run);\r\nend;\r\n\r\nprocedure TSynVrml97Syn.NullProc;\r\nbegin\r\n  fTokenID := tkNull;\r\n  inc(Run);\r\nend;\r\n\r\nprocedure TSynVrml97Syn.NumberProc;\r\n\r\n  function IsNumberChar: Boolean;\r\n  begin\r\n    case fLine[Run] of\r\n      '0'..'9', '.', 'a'..'f', 'A'..'F', 'x', 'X':\r\n        Result := True;\r\n      else\r\n        Result := False;\r\n    end;\r\n  end;\r\n\r\nvar\r\n  idx1: Integer; // token[1]\r\n  isHex: Boolean;\r\nbegin\r\n  fTokenID := tkNumber;\r\n  isHex := False;\r\n  idx1 := Run;\r\n  Inc(Run);\r\n  while IsNumberChar do\r\n  begin\r\n    case FLine[Run] of\r\n      '.' :\r\n        if FLine[Succ(Run)] = '.' then\r\n          Break;\r\n      'a'..'f', 'A'..'F' :\r\n        if not isHex then\r\n          Break;\r\n      'x', 'X' :\r\n        begin\r\n          if (FLine[idx1] <> '0') or (Run > Succ(idx1)) then\r\n            Break;\r\n          if not CharInSet(FLine[Succ(Run)], ['0'..'9', 'a'..'f', 'A'..'F']) then\r\n          begin\r\n            Break;\r\n          end;\r\n          isHex := True;\r\n        end;\r\n    end;\r\n    Inc(Run);\r\n  end;\r\nend;\r\n\r\nprocedure TSynVrml97Syn.OrSymbolProc;\r\nbegin\r\n  fTokenID := tkSymbol;\r\n  inc(Run);\r\n  if CharInSet(fLine[Run], ['=', '|']) then inc(Run);\r\nend;\r\n\r\nprocedure TSynVrml97Syn.PlusProc;\r\nbegin\r\n  fTokenID := tkSymbol;\r\n  inc(Run);\r\n  if CharInSet(fLine[Run], ['=', '+']) then inc(Run);\r\nend;\r\n\r\nprocedure TSynVrml97Syn.PointProc;\r\nbegin\r\n  fTokenID := tkSymbol;\r\n  inc(Run);\r\n  if (fLine[Run] = '.') and (fLine[Run + 1] = '.') then inc(Run, 2);\r\nend;\r\n\r\nprocedure TSynVrml97Syn.SlashProc;\r\nbegin\r\n  Inc(Run);\r\n  case fLine[Run] of\r\n    '/' :\r\n      begin\r\n        fTokenID := tkComment;\r\n        repeat\r\n          Inc(Run);\r\n        until IsLineEnd(Run);\r\n      end;\r\n    '*' :\r\n      begin\r\n        fTokenID := tkComment;\r\n        fRange := rsComment;\r\n        repeat\r\n          Inc(Run);\r\n          if (fLine[Run] = '*') and (fLine[Run + 1] = '/') then\r\n            begin\r\n              fRange := rsNormalText;\r\n              Inc(Run, 2);\r\n              break;\r\n            end;\r\n        until IsLineEnd(Run);\r\n      end;\r\n    '=' :\r\n      begin\r\n        Inc(Run);\r\n        fTokenID := tkSymbol;\r\n      end;\r\n    else\r\n      fTokenID := tkSymbol;\r\n  end;\r\nend;\r\n\r\nprocedure TSynVrml97Syn.SpaceProc;\r\nbegin\r\n  inc(Run);\r\n  fTokenID := tkSpace;\r\n  while (FLine[Run] <= #32) and not IsLineEnd(Run) do inc(Run);\r\nend;\r\n\r\nprocedure TSynVrml97Syn.StarProc;\r\nbegin\r\n  fTokenID := tkSymbol;\r\n  inc(Run);\r\n  if fLine[Run] = '=' then inc(Run);\r\nend;\r\n\r\nprocedure TSynVrml97Syn.StringProc;\r\nvar\r\n  l_strChar: UnicodeString;\r\nbegin\r\n  fTokenID := tkString;\r\n  l_strChar := FLine[Run]; // We could have '\"' or #39\r\n  if (FLine[Run + 1] = l_strChar) and (FLine[Run + 2] = l_strChar) then inc(Run, 2);\r\n  repeat\r\n    if IsLineEnd(Run) then break;\r\n    inc(Run);\r\n  until (FLine[Run] = l_strChar) and (FLine[Pred(Run)] <> '\\');\r\n  if not IsLineEnd(Run) then\r\n    Inc(Run);\r\nend;\r\n\r\nprocedure TSynVrml97Syn.SymbolProc;\r\nbegin\r\n  inc(Run);\r\n  fTokenId := tkSymbol;\r\nend;\r\n\r\nprocedure TSynVrml97Syn.UnknownProc;\r\nbegin\r\n  inc(Run);\r\n  fTokenID := tkUnknown;\r\nend;\r\n\r\nprocedure TSynVrml97Syn.Next;\r\nbegin\r\n  fTokenPos := Run;\r\n  case fRange of\r\n    rsX3DHeader: X3DHeaderProc;\r\n    rsX3DDocType: X3DDocTypeProc;\r\n    rsComment: CommentProc;\r\n    else\r\n      case fLine[Run] of\r\n        '&': AndSymbolProc;\r\n        #13: CRProc;\r\n        '#': DiesisCommentProc;\r\n        'A'..'Z', 'a'..'z', '_': IdentProc;\r\n        #10: LFProc;\r\n        '-': MinusProc;\r\n        '%': ModSymbolProc;\r\n        #0: NullProc;\r\n        '0'..'9': NumberProc;\r\n        '|': OrSymbolProc;\r\n        '+': PlusProc;\r\n        '.': PointProc;\r\n        '/': SlashProc;\r\n        #1..#9, #11, #12, #14..#32: SpaceProc;\r\n        '*': StarProc;\r\n        '\"', #39: StringProc;\r\n        '?': X3DHeaderOpenProc;\r\n        '!': X3DDocTypeOpenProc;\r\n        '~', '{', '}', ',', '(', ')', '[', ']', ':', ';', '=', '<', '>': SymbolProc;\r\n        else UnknownProc;\r\n      end;\r\n  end;\r\n  inherited;\r\nend;\r\n\r\nfunction TSynVrml97Syn.GetDefaultAttribute(Index :integer) :TSynHighlighterAttributes;\r\nbegin\r\n  case Index of\r\n    SYN_ATTR_COMMENT: Result := fCommentAttri;\r\n    SYN_ATTR_IDENTIFIER: Result := fIdentifierAttri;\r\n    SYN_ATTR_KEYWORD: Result := fKeyAttri;\r\n    SYN_ATTR_STRING: Result := fStringAttri;\r\n    SYN_ATTR_WHITESPACE: Result := fSpaceAttri;\r\n    SYN_ATTR_SYMBOL: Result := fSymbolAttri;\r\n    else\r\n      Result := nil;\r\n  end;\r\nend;\r\n\r\nfunction TSynVrml97Syn.GetEol :Boolean;\r\nbegin\r\n  Result := fTokenID = tkNull;\r\nend;\r\n\r\nfunction TSynVrml97Syn.GetRange :Pointer;\r\nbegin\r\n  Result := Pointer(fRange);\r\nend;\r\n\r\nfunction TSynVrml97Syn.GetTokenID :TtkTokenKind;\r\nbegin\r\n  Result := fTokenId;\r\nend;\r\n\r\nfunction TSynVrml97Syn.GetTokenAttribute :TSynHighlighterAttributes;\r\nbegin\r\n  case GetTokenID of\r\n    tkComment: Result := fCommentAttri;\r\n    tkIdentifier: Result := fIdentifierAttri;\r\n    tkKey: Result := fKeyAttri;\r\n    tkNonReservedKey: Result := fNonReservedKeyAttri;\r\n    tkEvent: Result := fEventAttri;\r\n    tkNumber: Result := fNumberAttri;\r\n    tkSpace: Result := fSpaceAttri;\r\n    tkString: Result := fStringAttri;\r\n    tkSymbol: Result := fSymbolAttri;\r\n    tkUnknown: Result := fIdentifierAttri;\r\n    // vrml\r\n    tkVrmlAppearance: Result := fVrmlAppearanceAttri;\r\n    tkVrmlAttribute: Result := fVrmlAttributeAttri;\r\n    tkVrmlDefinition: Result := fVrmlDefinitionAttri;\r\n    tkVrmlEvent: Result := fVrmlEventAttri;\r\n    tkVrmlGrouping: Result := fVrmlGroupingAttri;\r\n    tkVrmlInterpolator: Result := fVrmlInterpolatorAttri;\r\n    tkVrmlLight: Result := fVrmlLightAttri;\r\n    tkVrmlNode: Result := fVrmlNodeAttri;\r\n    tkVrmlParameter: Result := fVrmlParameterAttri;\r\n    tkVrmlproto: Result := fVrmlprotoAttri;\r\n    tkVrmlSensor: Result := fVrmlSensorAttri;\r\n    tkVrmlShape: Result := fVrmlShapeAttri;\r\n    tkVrmlShape_Hint: Result := fVrmlShape_HintAttri;\r\n    tkVrmlTime_dependent: Result := fVrmlTime_dependentAttri;\r\n    tkVrmlViewpoint: Result := fVrmlViewpointAttri;\r\n    tkVrmlWorldInfo: Result := fVrmlWorldInfoAttri;\r\n    tkX3DDocType: Result := fX3DDocTypeAttri;\r\n    tkX3DHeader: Result := fX3DHeaderAttri;\r\n    //--\r\n    else\r\n      Result := nil;\r\n  end;\r\nend;\r\n\r\nfunction TSynVrml97Syn.GetTokenKind :integer;\r\nbegin\r\n  Result := Ord(fTokenId);\r\nend;\r\n\r\nprocedure TSynVrml97Syn.ResetRange;\r\nbegin\r\n  fRange := rsNormalText;\r\nend;\r\n\r\nprocedure TSynVrml97Syn.SetRange(Value: Pointer);\r\nbegin\r\n  fRange := TRangeState(Value);\r\nend;\r\n\r\nfunction TSynVrml97Syn.IsFilterStored: Boolean;\r\nbegin\r\n  Result := fDefaultFilter <> SYNS_FilterVrml97;\r\nend;\r\n\r\nclass function TSynVrml97Syn.GetLanguageName: string;\r\nbegin\r\n  Result := SYNS_LangVrml97;\r\nend;\r\n\r\nfunction TSynVrml97Syn.GetSampleSource: UnicodeString;\r\nbegin\r\n  Result :=\r\n    '#VRML V2.0 utf8'#13#10 +\r\n    'Transform {'#13#10 +\r\n    '  children ['#13#10 +\r\n    '    NavigationInfo { headlight FALSE } # We''ll add our own light'#13#10 +\r\n    ''#13#10 +\r\n    '    DirectionalLight {        # First child'#13#10 +\r\n    '        direction 0 0 -1      # Light illuminating the scene'#13#10 +\r\n    '    }'#13#10 +\r\n    ''#13#10 +\r\n    '    Transform {               # Second child - a red sphere'#13#10 +\r\n    '      translation 3 0 1'#13#10 +\r\n    '      children ['#13#10 +\r\n    '        Shape {'#13#10 +\r\n    '          geometry Sphere { radius 2.3 }'#13#10 +\r\n    '          appearance Appearance {'#13#10 +\r\n    '            material Material { diffuseColor 1 0 0 }   # Red'#13#10 +\r\n    '         }'#13#10 +\r\n    '        }'#13#10 +\r\n    '      ]'#13#10 +\r\n    '    }'#13#10 +\r\n    ''#13#10 +\r\n    '    Transform {               # Third child - a blue box '#13#10 +\r\n    '      translation -2.4 .2 1'#13#10 +\r\n    '      rotation     0 1 1  .9'#13#10 +\r\n    '      children ['#13#10 +\r\n    '        Shape {'#13#10 +\r\n    '          geometry Box {}'#13#10 +\r\n    '          appearance Appearance {'#13#10 +\r\n    '            material Material { diffuseColor 0 0 1 }  # Blue'#13#10 +\r\n    '         }'#13#10 +\r\n    '        }'#13#10 +\r\n    '      ]'#13#10 +\r\n    '    }'#13#10 +\r\n    ''#13#10 +\r\n    '  ] # end of children for world'#13#10 +\r\n    '}'#13#10 +\r\n    'DEF Example_2 Script {'#13#10 +\r\n    '    field   SFNode myself USE Example_2'#13#10 +\r\n    '    field   SFNode root USE ROOT_TRANSFORM'#13#10 +\r\n    '    field   MFString url \"foo.wrl\"'#13#10 +\r\n    '    eventIn MFNode   nodesLoaded'#13#10 +\r\n    '    eventIn SFBool   trigger_event'#13#10 +\r\n    ''#13#10 +\r\n    '    url \"javascript:'#13#10 +\r\n    '        function trigger_event(value, ts){'#13#10 +\r\n    '            // do something and then fetch values'#13#10 +\r\n    '            Browser.createVRMLFromURL(url, myself, ''nodesLoaded'');'#13#10 +\r\n    '        }'#13#10 +\r\n    ''#13#10 +\r\n    '        function nodesLoaded(value, timestamp){'#13#10 +\r\n    '            if (value.length > 5) {'#13#10 +\r\n    '                 // do something more than 5 nodes in this MFNode...'#13#10 +\r\n    '            }'#13#10 +\r\n    '            root.addChildren = value;'#13#10 +\r\n    '        }\"'#13#10 +\r\n    '}';\r\nend;\r\n\r\nclass function TSynVrml97Syn.GetFriendlyLanguageName: UnicodeString;\r\nbegin\r\n  Result := SYNS_FriendlyLangVrml97;\r\nend;\r\n\r\ninitialization\r\n{$IFNDEF SYN_CPPB_1}\r\n  RegisterPlaceableHighlighter(TSynVrml97Syn);\r\n{$ENDIF}\r\nend.\r\n"
  },
  {
    "path": "External/SynEdit/Source/SynHighlighterWebIDL.pas",
    "content": "{-------------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nCode template generated with SynGen.\r\nThe original code is: SynHighlighterWebIDL.pas, released 2013-02-14.\r\nDescription: Syntax Parser/Highlighter\r\nThe initial author of this file is Christian-W. Budde.\r\nCopyright (c) 2013, all rights reserved.\r\n\r\nContributors to the SynEdit and mwEdit projects are listed in the\r\nContributors.txt file.\r\n\r\nAlternatively, the contents of this file may be used under the terms of the\r\nGNU General Public License Version 2 or later (the \"GPL\"), in which case\r\nthe provisions of the GPL are applicable instead of those above.\r\nIf you wish to allow use of your version of this file only under the terms\r\nof the GPL and not to allow others to use your version of this file\r\nunder the MPL, indicate your decision by deleting the provisions above and\r\nreplace them with the notice and other provisions required by the GPL.\r\nIf you do not delete the provisions above, a recipient may use your version\r\nof this file under either the MPL or the GPL.\r\n\r\n$Id: $\r\n\r\nYou may retrieve the latest version of this file at the SynEdit home page,\r\nlocated at http://SynEdit.SourceForge.net\r\n\r\n-------------------------------------------------------------------------------}\r\n\r\n{$IFNDEF QWEBIDL}\r\nunit SynHighlighterWebIDL;\r\n{$ENDIF}\r\n\r\n{$I SynEdit.inc}\r\n\r\ninterface\r\n\r\nuses\r\n{$IFDEF SYN_CLX}\r\n  QGraphics,\r\n  QSynEditTypes,\r\n  QSynEditHighlighter,\r\n  QSynUnicode,\r\n{$ELSE}\r\n  Graphics,\r\n  SynEditTypes,\r\n  SynEditHighlighter,\r\n  SynUnicode,\r\n{$ENDIF}\r\n  SysUtils,\r\n  Classes;\r\n\r\ntype\r\n  TtkTokenKind = (\r\n    tkArguments,\r\n    tkComment,\r\n    tkExtendedAttributes,\r\n    tkIdentifier,\r\n    tkKey,\r\n    tkNull,\r\n    tkNumber,\r\n    tkSpace,\r\n    tkString,\r\n    tkTypes,\r\n    tkSymbol,\r\n    tkUnknown);\r\n\r\n  TstkSymbolTokenKind = (\r\n    stkBraceOpen,\r\n    stkBraceClose,\r\n    stkSquareOpen,\r\n    stkSquareClose,\r\n    stkQuestionMark,\r\n    stkColon,\r\n    stkGreater,\r\n    stkLess\r\n  );\r\n\r\n  TRangeState = (rsUnknown, rsSingleComment, rsCStyleComment, rsString,\r\n    rsExtendedAttributes);\r\n\r\n  TProcTableProc = procedure of object;\r\n\r\n  PIdentFuncTableFunc = ^TIdentFuncTableFunc;\r\n  TIdentFuncTableFunc = function (Index: Integer): TtkTokenKind of object;\r\n\r\ntype\r\n  TSynWebIDLSyn = class(TSynCustomHighlighter)\r\n  private\r\n    fRange: TRangeState;\r\n    fTokenID: TtkTokenKind;\r\n    fSymbolTokenID: TstkSymbolTokenKind;\r\n    fIdentFuncTable: array [0..58] of TIdentFuncTableFunc;\r\n    fArgumentsAttri: TSynHighlighterAttributes;\r\n    fExtendedAttri: TSynHighlighterAttributes;\r\n    fCommentAttri: TSynHighlighterAttributes;\r\n    fIdentifierAttri: TSynHighlighterAttributes;\r\n    fKeyAttri: TSynHighlighterAttributes;\r\n    fNumberAttri: TSynHighlighterAttributes;\r\n    fSpaceAttri: TSynHighlighterAttributes;\r\n    fStringAttri: TSynHighlighterAttributes;\r\n    fSymbolAttri: TSynHighlighterAttributes;\r\n    fTypesAttri: TSynHighlighterAttributes;\r\n    function HashKey(Str: PWideChar): Cardinal;\r\n    function FuncAny(Index: Integer): TtkTokenKind;\r\n    function FuncAttribute(Index: Integer): TtkTokenKind;\r\n    function FuncBoolean(Index: Integer): TtkTokenKind;\r\n    function FuncByte(Index: Integer): TtkTokenKind;\r\n    function FuncBytestring(Index: Integer): TtkTokenKind;\r\n    function FuncCallback(Index: Integer): TtkTokenKind;\r\n    function FuncConst(Index: Integer): TtkTokenKind;\r\n    function FuncCreator(Index: Integer): TtkTokenKind;\r\n    function FuncDate(Index: Integer): TtkTokenKind;\r\n    function FuncDeleter(Index: Integer): TtkTokenKind;\r\n    function FuncDictionary(Index: Integer): TtkTokenKind;\r\n    function FuncDomstring(Index: Integer): TtkTokenKind;\r\n    function FuncDouble(Index: Integer): TtkTokenKind;\r\n    function FuncEnum(Index: Integer): TtkTokenKind;\r\n    function FuncException(Index: Integer): TtkTokenKind;\r\n    function FuncFloat(Index: Integer): TtkTokenKind;\r\n    function FuncGetter(Index: Integer): TtkTokenKind;\r\n    function FuncImplements(Index: Integer): TtkTokenKind;\r\n    function FuncInherit(Index: Integer): TtkTokenKind;\r\n    function FuncInterface(Index: Integer): TtkTokenKind;\r\n    function FuncLegacycaller(Index: Integer): TtkTokenKind;\r\n    function FuncLong(Index: Integer): TtkTokenKind;\r\n    function FuncObject(Index: Integer): TtkTokenKind;\r\n    function FuncOctet(Index: Integer): TtkTokenKind;\r\n    function FuncOptional(Index: Integer): TtkTokenKind;\r\n    function FuncPartial(Index: Integer): TtkTokenKind;\r\n    function FuncReadonly(Index: Integer): TtkTokenKind;\r\n    function FuncRegexp(Index: Integer): TtkTokenKind;\r\n    function FuncSequence(Index: Integer): TtkTokenKind;\r\n    function FuncSetter(Index: Integer): TtkTokenKind;\r\n    function FuncShort(Index: Integer): TtkTokenKind;\r\n    function FuncStatic(Index: Integer): TtkTokenKind;\r\n    function FuncStringifier(Index: Integer): TtkTokenKind;\r\n    function FuncTypedef(Index: Integer): TtkTokenKind;\r\n    function FuncUnresticted(Index: Integer): TtkTokenKind;\r\n    function FuncUnrestricted(Index: Integer): TtkTokenKind;\r\n    function FuncUnsigned(Index: Integer): TtkTokenKind;\r\n    function FuncVoid(Index: Integer): TtkTokenKind;\r\n    procedure IdentProc;\r\n    procedure UnknownProc;\r\n    function AltFunc(Index: Integer): TtkTokenKind;\r\n    procedure InitIdent;\r\n    function IdentKind(MayBe: PWideChar): TtkTokenKind;\r\n    procedure BraceCloseProc;\r\n    procedure BraceOpenProc;\r\n    procedure ColonProc;\r\n    procedure CRProc;\r\n    procedure CStyleCommentProc;\r\n    procedure GreaterProc;\r\n    procedure LessProc;\r\n    procedure LFProc;\r\n    procedure NullProc;\r\n    procedure NumberProc;\r\n    procedure QuestionMarkProc;\r\n    procedure SlashProc;\r\n    procedure SpaceProc;\r\n    procedure SquareCloseProc;\r\n    procedure SquareOpenProc;\r\n    procedure StringOpenProc;\r\n    procedure StringProc;\r\n  protected\r\n    function GetSampleSource: UnicodeString; override;\r\n    function IsFilterStored: Boolean; override;\r\n  public\r\n    constructor Create(AOwner: TComponent); override;\r\n    class function GetFriendlyLanguageName: UnicodeString; override;\r\n    class function GetLanguageName: string; override;\r\n    function GetRange: Pointer; override;\r\n    procedure ResetRange; override;\r\n    procedure SetRange(Value: Pointer); override;\r\n    function GetDefaultAttribute(Index: Integer): TSynHighlighterAttributes; override;\r\n    function GetEol: Boolean; override;\r\n    function GetKeyWords(TokenKind: Integer): UnicodeString; override;\r\n    function GetTokenID: TtkTokenKind;\r\n    function GetTokenAttribute: TSynHighlighterAttributes; override;\r\n    function GetTokenKind: Integer; override;\r\n    function IsIdentChar(AChar: WideChar): Boolean; override;\r\n    procedure Next; override;\r\n  published\r\n    property ArgumentsAttri: TSynHighlighterAttributes read fArgumentsAttri write fArgumentsAttri;\r\n    property CommentAttri: TSynHighlighterAttributes read fCommentAttri write fCommentAttri;\r\n    property ExtendedAttri: TSynHighlighterAttributes read fExtendedAttri write fExtendedAttri;\r\n    property IdentifierAttri: TSynHighlighterAttributes read fIdentifierAttri write fIdentifierAttri;\r\n    property KeyAttri: TSynHighlighterAttributes read fKeyAttri write fKeyAttri;\r\n    property NumberAttri: TSynHighlighterAttributes read fNumberAttri write fNumberAttri;\r\n    property SpaceAttri: TSynHighlighterAttributes read fSpaceAttri write fSpaceAttri;\r\n    property StringAttri: TSynHighlighterAttributes read fStringAttri write fStringAttri;\r\n    property SymbolAttri: TSynHighlighterAttributes read fSymbolAttri write fSymbolAttri;\r\n    property TypesAttri: TSynHighlighterAttributes read fTypesAttri write fTypesAttri;\r\n  end;\r\n\r\nimplementation\r\n\r\nuses\r\n{$IFDEF SYN_CLX}\r\n  QSynEditStrConst;\r\n{$ELSE}\r\n  SynEditStrConst;\r\n{$ENDIF}\r\n\r\nresourcestring\r\n  SYNS_FilterWebIDL = 'Web IDL (*.idl)|*.idl';\r\n  SYNS_LangWebIDL = 'Web IDL';\r\n  SYNS_FriendlyLangWebIDL = 'Web IDL';\r\n  SYNS_AttrArguments = 'Arguments';\r\n  SYNS_FriendlyAttrArguments = 'Arguments';\r\n  SYNS_AttrExtended = 'Extended';\r\n  SYNS_FriendlyAttrExtended = 'Extended';\r\n\r\nconst\r\n  // as this language is case-insensitive keywords *must* be in lowercase\r\n  KeyWords: array[0..37] of UnicodeString = (\r\n    'any', 'attribute', 'boolean', 'byte', 'bytestring', 'callback', 'const',\r\n    'creator', 'date', 'deleter', 'dictionary', 'domstring', 'double', 'enum',\r\n    'exception', 'float', 'getter', 'implements', 'inherit', 'interface',\r\n    'legacycaller', 'long', 'object', 'octet', 'optional', 'partial',\r\n    'readonly', 'regexp', 'sequence', 'setter', 'short', 'static',\r\n    'stringifier', 'typedef', 'unresticted', 'unrestricted', 'unsigned', 'void'\r\n  );\r\n\r\n  KeyIndices: array[0..58] of Integer = (\r\n    14, 28, 4, 37, 21, -1, -1, 12, 17, -1, -1, 22, -1, 3, -1, -1, 29, -1, 27,\r\n    31, -1, 1, 20, -1, 24, 15, 2, -1, -1, -1, -1, 23, -1, 19, 0, 13, 11, 16, 34,\r\n    10, 36, 25, -1, 30, -1, 33, 32, 6, -1, 9, 7, -1, 8, -1, 26, 18, -1, 5, 35\r\n  );\r\n\r\nconstructor TSynWebIDLSyn.Create(AOwner: TComponent);\r\nbegin\r\n  inherited Create(AOwner);\r\n  fCaseSensitive := False;\r\n\r\n  fArgumentsAttri := TSynHighLighterAttributes.Create(SYNS_AttrArguments,\r\n    SYNS_FriendlyAttrArguments);\r\n  fArgumentsAttri.Style := [fsBold];\r\n  fArgumentsAttri.Foreground := clNavy;\r\n  AddAttribute(fArgumentsAttri);\r\n\r\n  fCommentAttri := TSynHighLighterAttributes.Create(SYNS_AttrComment,\r\n    SYNS_FriendlyAttrComment);\r\n  fCommentAttri.Style := [fsItalic];\r\n  fCommentAttri.Foreground := clGreen;\r\n  AddAttribute(fCommentAttri);\r\n\r\n  fExtendedAttri := TSynHighlighterAttributes.Create(SYNS_AttrExtended,\r\n    SYNS_FriendlyAttrExtended);\r\n  fExtendedAttri.Style := [fsBold, fsItalic];\r\n  fExtendedAttri.Foreground := clMaroon;\r\n  AddAttribute(fExtendedAttri);\r\n\r\n  fIdentifierAttri := TSynHighLighterAttributes.Create(SYNS_AttrIdentifier,\r\n    SYNS_FriendlyAttrIdentifier);\r\n  AddAttribute(fIdentifierAttri);\r\n\r\n  fKeyAttri := TSynHighLighterAttributes.Create(SYNS_AttrReservedWord,\r\n    SYNS_FriendlyAttrReservedWord);\r\n  fKeyAttri.Style := [fsBold];\r\n  fKeyAttri.Foreground := clNavy;\r\n  AddAttribute(fKeyAttri);\r\n\r\n  fNumberAttri := TSynHighlighterAttributes.Create(SYNS_AttrNumber, SYNS_FriendlyAttrNumber);\r\n  fNumberAttri.Foreground := clBlue;\r\n  AddAttribute(fNumberAttri);\r\n\r\n  fSpaceAttri := TSynHighLighterAttributes.Create(SYNS_AttrSpace, SYNS_FriendlyAttrSpace);\r\n  AddAttribute(fSpaceAttri);\r\n\r\n  fStringAttri := TSynHighLighterAttributes.Create(SYNS_AttrString, SYNS_FriendlyAttrString);\r\n  fStringAttri.Foreground := clPurple;\r\n  AddAttribute(fStringAttri);\r\n\r\n  fSymbolAttri := TSynHighLighterAttributes.Create(SYNS_AttrSymbol, SYNS_FriendlyAttrSymbol);\r\n  fSymbolAttri.Style := [fsBold];\r\n  fSymbolAttri.Foreground := clMaroon;\r\n  AddAttribute(fSymbolAttri);\r\n\r\n  fTypesAttri := TSynHighLighterAttributes.Create(SYNS_AttrDataType, SYNS_FriendlyAttrDataType);\r\n  fTypesAttri.Foreground := clNavy;\r\n  AddAttribute(fTypesAttri);\r\n\r\n  SetAttributesOnChange(DefHighlightChange);\r\n  InitIdent;\r\n  fDefaultFilter := SYNS_FilterWebIDL;\r\n  fRange := rsUnknown;\r\nend;\r\n\r\nprocedure TSynWebIDLSyn.InitIdent;\r\nvar\r\n  i: Integer;\r\nbegin\r\n  for i := Low(fIdentFuncTable) to High(fIdentFuncTable) do\r\n    if KeyIndices[i] = -1 then\r\n      fIdentFuncTable[i] := AltFunc;\r\n\r\n  fIdentFuncTable[34] := FuncAny;\r\n  fIdentFuncTable[21] := FuncAttribute;\r\n  fIdentFuncTable[26] := FuncBoolean;\r\n  fIdentFuncTable[13] := FuncByte;\r\n  fIdentFuncTable[2] := FuncBytestring;\r\n  fIdentFuncTable[57] := FuncCallback;\r\n  fIdentFuncTable[47] := FuncConst;\r\n  fIdentFuncTable[50] := FuncCreator;\r\n  fIdentFuncTable[52] := FuncDate;\r\n  fIdentFuncTable[49] := FuncDeleter;\r\n  fIdentFuncTable[39] := FuncDictionary;\r\n  fIdentFuncTable[36] := FuncDomstring;\r\n  fIdentFuncTable[7] := FuncDouble;\r\n  fIdentFuncTable[35] := FuncEnum;\r\n  fIdentFuncTable[0] := FuncException;\r\n  fIdentFuncTable[25] := FuncFloat;\r\n  fIdentFuncTable[37] := FuncGetter;\r\n  fIdentFuncTable[8] := FuncImplements;\r\n  fIdentFuncTable[55] := FuncInherit;\r\n  fIdentFuncTable[33] := FuncInterface;\r\n  fIdentFuncTable[22] := FuncLegacycaller;\r\n  fIdentFuncTable[4] := FuncLong;\r\n  fIdentFuncTable[11] := FuncObject;\r\n  fIdentFuncTable[31] := FuncOctet;\r\n  fIdentFuncTable[24] := FuncOptional;\r\n  fIdentFuncTable[41] := FuncPartial;\r\n  fIdentFuncTable[54] := FuncReadonly;\r\n  fIdentFuncTable[18] := FuncRegexp;\r\n  fIdentFuncTable[1] := FuncSequence;\r\n  fIdentFuncTable[16] := FuncSetter;\r\n  fIdentFuncTable[43] := FuncShort;\r\n  fIdentFuncTable[19] := FuncStatic;\r\n  fIdentFuncTable[46] := FuncStringifier;\r\n  fIdentFuncTable[45] := FuncTypedef;\r\n  fIdentFuncTable[38] := FuncUnresticted;\r\n  fIdentFuncTable[58] := FuncUnrestricted;\r\n  fIdentFuncTable[40] := FuncUnsigned;\r\n  fIdentFuncTable[3] := FuncVoid;\r\nend;\r\n\r\nprocedure TSynWebIDLSyn.ColonProc;\r\nbegin\r\n  Inc(Run);\r\n  fTokenId := tkSymbol;\r\n  fSymbolTokenID := stkColon;\r\nend;\r\n\r\n{$Q-}\r\nfunction TSynWebIDLSyn.HashKey(Str: PWideChar): Cardinal;\r\nbegin\r\n  Result := 0;\r\n  while IsIdentChar(Str^) do\r\n  begin\r\n    Result := Result * 622 + Ord(Str^) * 657;\r\n    inc(Str);\r\n  end;\r\n  Result := Result mod 59;\r\n  fStringLen := Str - fToIdent;\r\nend;\r\n{$Q+}\r\n\r\nfunction TSynWebIDLSyn.FuncAny(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkTypes\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynWebIDLSyn.FuncAttribute(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkArguments\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynWebIDLSyn.FuncBoolean(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkTypes\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynWebIDLSyn.FuncByte(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkTypes\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynWebIDLSyn.FuncBytestring(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkTypes\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynWebIDLSyn.FuncCallback(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynWebIDLSyn.FuncConst(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkArguments\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynWebIDLSyn.FuncCreator(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkArguments\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynWebIDLSyn.FuncDate(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkTypes\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynWebIDLSyn.FuncDeleter(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkArguments\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynWebIDLSyn.FuncDictionary(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynWebIDLSyn.FuncDomstring(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkTypes\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynWebIDLSyn.FuncDouble(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkTypes\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynWebIDLSyn.FuncEnum(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynWebIDLSyn.FuncException(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynWebIDLSyn.FuncFloat(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkTypes\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynWebIDLSyn.FuncGetter(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkArguments\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynWebIDLSyn.FuncImplements(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkArguments\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynWebIDLSyn.FuncInherit(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkArguments\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynWebIDLSyn.FuncInterface(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynWebIDLSyn.FuncLegacycaller(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkArguments\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynWebIDLSyn.FuncLong(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkTypes\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynWebIDLSyn.FuncObject(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkTypes\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynWebIDLSyn.FuncOctet(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkTypes\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynWebIDLSyn.FuncOptional(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkArguments\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynWebIDLSyn.FuncPartial(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkKey\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynWebIDLSyn.FuncReadonly(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkArguments\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynWebIDLSyn.FuncRegexp(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkTypes\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynWebIDLSyn.FuncSequence(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkTypes\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynWebIDLSyn.FuncSetter(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkArguments\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynWebIDLSyn.FuncShort(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkTypes\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynWebIDLSyn.FuncStatic(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkArguments\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynWebIDLSyn.FuncStringifier(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkArguments\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynWebIDLSyn.FuncTypedef(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkArguments\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynWebIDLSyn.FuncUnresticted(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkTypes\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynWebIDLSyn.FuncUnrestricted(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkArguments\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynWebIDLSyn.FuncUnsigned(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkTypes\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynWebIDLSyn.FuncVoid(Index: Integer): TtkTokenKind;\r\nbegin\r\n  if IsCurrentToken(KeyWords[Index]) then\r\n    Result := tkTypes\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynWebIDLSyn.AltFunc(Index: Integer): TtkTokenKind;\r\nbegin\r\n  Result := tkIdentifier;\r\nend;\r\n\r\nfunction TSynWebIDLSyn.IdentKind(MayBe: PWideChar): TtkTokenKind;\r\nvar\r\n  Key: Cardinal;\r\nbegin\r\n  fToIdent := MayBe;\r\n  Key := HashKey(MayBe);\r\n  if Key <= High(fIdentFuncTable) then\r\n    Result := fIdentFuncTable[Key](KeyIndices[Key])\r\n  else\r\n    Result := tkIdentifier;\r\nend;\r\n\r\nprocedure TSynWebIDLSyn.SpaceProc;\r\nbegin\r\n  inc(Run);\r\n  fTokenID := tkSpace;\r\n  while (FLine[Run] <= #32) and not IsLineEnd(Run) do inc(Run);\r\nend;\r\n\r\nprocedure TSynWebIDLSyn.NullProc;\r\nbegin\r\n  fTokenID := tkNull;\r\n  inc(Run);\r\nend;\r\n\r\nprocedure TSynWebIDLSyn.NumberProc;\r\n\r\n  function IsNumberChar: Boolean;\r\n  begin\r\n    case fLine[Run] of\r\n      '0'..'9', '.', 'a'..'f', 'A'..'F', 'x', 'X':\r\n        Result := True;\r\n      else\r\n        Result := False;\r\n    end;\r\n  end;\r\n\r\n  function IsHexChar(Run: Integer): Boolean;\r\n  begin\r\n    case fLine[Run] of\r\n      '0'..'9', 'a'..'f', 'A'..'F':\r\n        Result := True;\r\n      else\r\n        Result := False;\r\n    end;\r\n  end;\r\n\r\nvar\r\n  idx1: Integer; // token[1]\r\n  isHex: Boolean;\r\nbegin\r\n  fTokenID := tkNumber;\r\n  isHex := False;\r\n  idx1 := Run;\r\n  Inc(Run);\r\n  while IsNumberChar do\r\n  begin\r\n    case FLine[Run] of\r\n      '.':\r\n        if FLine[Succ(Run)] = '.' then\r\n          Break;\r\n      'a'..'f', 'A'..'F':\r\n        if not isHex then\r\n          Break;\r\n      'x', 'X':\r\n        begin\r\n          if (FLine[idx1] <> '0') or (Run > Succ(idx1)) then\r\n            Break;\r\n          if not IsHexChar(Succ(Run)) then\r\n            Break;\r\n          isHex := True;\r\n        end;\r\n    end;\r\n    Inc(Run);\r\n  end;\r\nend;\r\n\r\nprocedure TSynWebIDLSyn.QuestionMarkProc;\r\nbegin\r\n  Inc(Run);\r\n  fTokenID := tkSymbol;\r\n  fSymbolTokenID := stkQuestionMark;\r\nend;\r\n\r\nprocedure TSynWebIDLSyn.CRProc;\r\nbegin\r\n  fTokenID := tkSpace;\r\n  inc(Run);\r\n  if fLine[Run] = #10 then\r\n    inc(Run);\r\nend;\r\n\r\nprocedure TSynWebIDLSyn.GreaterProc;\r\nbegin\r\n  Inc(Run);\r\n  fTokenId := tkSymbol;\r\n  fSymbolTokenID := stkGreater;\r\nend;\r\n\r\nprocedure TSynWebIDLSyn.LessProc;\r\nbegin\r\n  Inc(Run);\r\n  fTokenId := tkSymbol;\r\n  fSymbolTokenID := stkLess;\r\nend;\r\n\r\nprocedure TSynWebIDLSyn.LFProc;\r\nbegin\r\n  fTokenID := tkSpace;\r\n  inc(Run);\r\nend;\r\n\r\nprocedure TSynWebIDLSyn.SlashProc;\r\nbegin\r\n  Inc(Run);\r\n  case fLine[Run] of\r\n    '/':\r\n      begin\r\n        repeat\r\n          Inc(Run);\r\n        until IsLineEnd(Run);\r\n        fRange := rsSingleComment;\r\n        fTokenID := tkComment;\r\n      end;\r\n    '*':\r\n      begin\r\n        Inc(Run, 1);\r\n        fRange := rsCStyleComment;\r\n        fTokenID := tkComment;\r\n      end\r\n    else\r\n      fTokenID := tkIdentifier;\r\n  end;\r\nend;\r\n\r\nprocedure TSynWebIDLSyn.CStyleCommentProc;\r\nbegin\r\n  case fLine[Run] of\r\n     #0: NullProc;\r\n    #10: LFProc;\r\n    #13: CRProc;\r\n  else\r\n    begin\r\n      fTokenID := tkComment;\r\n      repeat\r\n        if (fLine[Run] = '*') and\r\n           (fLine[Run + 1] = '/') then\r\n        begin\r\n          Inc(Run, 2);\r\n          fRange := rsUnKnown;\r\n          Break;\r\n        end;\r\n        if not IsLineEnd(Run) then\r\n          Inc(Run);\r\n      until IsLineEnd(Run);\r\n    end;\r\n  end;\r\nend;\r\n\r\nprocedure TSynWebIDLSyn.StringOpenProc;\r\nbegin\r\n  Inc(Run);\r\n  fRange := rsString;\r\n  fTokenID := tkString;\r\nend;\r\n\r\nprocedure TSynWebIDLSyn.StringProc;\r\nbegin\r\n  case fLine[Run] of\r\n     #0: NullProc;\r\n    #10: LFProc;\r\n    #13: CRProc;\r\n  else\r\n    begin\r\n      fTokenID := tkString;\r\n      repeat\r\n        if (fLine[Run] = '\"') then\r\n        begin\r\n          Inc(Run, 1);\r\n          fRange := rsUnKnown;\r\n          Break;\r\n        end;\r\n        if not IsLineEnd(Run) then\r\n          Inc(Run);\r\n      until IsLineEnd(Run);\r\n    end;\r\n  end;\r\nend;\r\n\r\nprocedure TSynWebIDLSyn.IdentProc;\r\nbegin\r\n  fTokenID := IdentKind((fLine + Run));\r\n  Inc(Run, fStringLen);\r\n  while IsIdentChar(fLine[Run]) do\r\n    Inc(Run);\r\nend;\r\n\r\nprocedure TSynWebIDLSyn.BraceOpenProc;\r\nbegin\r\n  Inc(Run);\r\n  fTokenId := tkSymbol;\r\n  fSymbolTokenID := stkBraceOpen;\r\nend;\r\n\r\nprocedure TSynWebIDLSyn.BraceCloseProc;\r\nbegin\r\n  Inc(Run);\r\n  fTokenId := tkSymbol;\r\n  fSymbolTokenID := stkBraceClose;\r\nend;\r\n\r\nprocedure TSynWebIDLSyn.SquareOpenProc;\r\nbegin\r\n  Inc(Run);\r\n  fTokenID := tkSymbol;\r\n  fSymbolTokenID := stkSquareOpen;\r\n  fRange := rsExtendedAttributes;\r\nend;\r\n\r\nprocedure TSynWebIDLSyn.SquareCloseProc;\r\nbegin\r\n  Inc(Run);\r\n  fTokenID := tkSymbol;\r\n  fSymbolTokenID := stkSquareClose;\r\n  fRange := rsUnknown\r\nend;\r\n\r\nprocedure TSynWebIDLSyn.UnknownProc;\r\nbegin\r\n  inc(Run);\r\n  fTokenID := tkUnknown;\r\nend;\r\n\r\nprocedure TSynWebIDLSyn.Next;\r\nbegin\r\n  fTokenPos := Run;\r\n  case fRange of\r\n    rsCStyleComment: CStyleCommentProc;\r\n    rsString: StringProc;\r\n  else\r\n    case fLine[Run] of\r\n      #0: NullProc;\r\n      #10: LFProc;\r\n      #13: CRProc;\r\n      '/': SlashProc;\r\n      '\"': StringOpenProc;\r\n      #1..#9, #11, #12, #14..#32: SpaceProc;\r\n      '0'..'9': NumberProc;\r\n      'A'..'Z', 'a'..'z', '_': IdentProc;\r\n      '{': BraceOpenProc;\r\n      '}': BraceCloseProc;\r\n      ']': SquareCloseProc;\r\n      '[': SquareOpenProc;\r\n      '?': QuestionMarkProc;\r\n      ':': ColonProc;\r\n      '>': GreaterProc;\r\n      '<': LessProc;\r\n    else\r\n      UnknownProc;\r\n    end;\r\n  end;\r\n  inherited;\r\nend;\r\n\r\nfunction TSynWebIDLSyn.GetDefaultAttribute(Index: Integer): TSynHighLighterAttributes;\r\nbegin\r\n  case Index of\r\n    SYN_ATTR_COMMENT: Result := fCommentAttri;\r\n    SYN_ATTR_IDENTIFIER: Result := fIdentifierAttri;\r\n    SYN_ATTR_KEYWORD: Result := fKeyAttri;\r\n    SYN_ATTR_STRING: Result := fStringAttri;\r\n    SYN_ATTR_WHITESPACE: Result := fSpaceAttri;\r\n    SYN_ATTR_SYMBOL: Result := fSymbolAttri;\r\n  else\r\n    Result := nil;\r\n  end;\r\nend;\r\n\r\nfunction TSynWebIDLSyn.GetEol: Boolean;\r\nbegin\r\n  Result := Run = fLineLen + 1;\r\nend;\r\n\r\nfunction TSynWebIDLSyn.GetKeyWords(TokenKind: Integer): UnicodeString;\r\nbegin\r\n  Result :=\r\n    'any,attribute,boolean,byte,ByteString,callback,const,creator,Date,del' +\r\n    'eter,dictionary,DOMString,double,enum,exception,float,getter,implement' +\r\n    's,inherit,interface,legacycaller,long,object,octet,optional,partial,re' +\r\n    'adonly,RegExp,sequence,setter,short,static,stringifier,typedef,unresti' +\r\n    'cted,unrestricted,unsigned,void';\r\nend;\r\n\r\nfunction TSynWebIDLSyn.GetTokenID: TtkTokenKind;\r\nbegin\r\n  Result := fTokenId;\r\n  if (fRange = rsExtendedAttributes) and not ((fTokenID = tkSymbol) and\r\n    (fSymbolTokenID = stkSquareOpen)) then\r\n    Result := tkExtendedAttributes;\r\nend;\r\n\r\nfunction TSynWebIDLSyn.GetTokenAttribute: TSynHighLighterAttributes;\r\nbegin\r\n  case GetTokenID of\r\n    tkArguments: Result := fArgumentsAttri;\r\n    tkComment: Result := fCommentAttri;\r\n    tkExtendedAttributes: Result := fExtendedAttri;\r\n    tkIdentifier: Result := fIdentifierAttri;\r\n    tkKey: Result := fKeyAttri;\r\n    tkNumber: Result := fNumberAttri;\r\n    tkSpace: Result := fSpaceAttri;\r\n    tkString: Result := fStringAttri;\r\n    tkSymbol: Result := fSymbolAttri;\r\n    tkTypes: Result := fTypesAttri;\r\n    tkUnknown: Result := fIdentifierAttri;\r\n  else\r\n    Result := nil;\r\n  end;\r\nend;\r\n\r\nfunction TSynWebIDLSyn.GetTokenKind: Integer;\r\nbegin\r\n  Result := Ord(fTokenId);\r\nend;\r\n\r\nfunction TSynWebIDLSyn.IsIdentChar(AChar: WideChar): Boolean;\r\nbegin\r\n  case AChar of\r\n    '_', '0'..'9', 'a'..'z', 'A'..'Z':\r\n      Result := True;\r\n    else\r\n      Result := False;\r\n  end;\r\nend;\r\n\r\nfunction TSynWebIDLSyn.GetSampleSource: UnicodeString;\r\nbegin\r\n  Result :=\r\n    '/* WEB IDL sample source */'#13#10 +\r\n    '[Constructor]'#13#10 +\r\n    'interface GraphicalWindow {'#13#10 +\r\n    '  readonly attribute unsigned long width;'#13#10 +\r\n    '  readonly attribute unsigned long height;'#13#10 +\r\n    #13#10 +\r\n    '  attribute Paint currentPaint;'#13#10 +\r\n    #13#10 +\r\n    '  void drawRectangle(float x, float y, float width, float height);' +\r\n    #13#10#13#10 +\r\n    '  void drawText(float x, float y, DOMString text);'#13#10 +\r\n    '};';\r\nend;\r\n\r\nfunction TSynWebIDLSyn.IsFilterStored: Boolean;\r\nbegin\r\n  Result := fDefaultFilter <> SYNS_FilterWebIDL;\r\nend;\r\n\r\nclass function TSynWebIDLSyn.GetFriendlyLanguageName: UnicodeString;\r\nbegin\r\n  Result := SYNS_FriendlyLangWebIDL;\r\nend;\r\n\r\nclass function TSynWebIDLSyn.GetLanguageName: string;\r\nbegin\r\n  Result := SYNS_LangWebIDL;\r\nend;\r\n\r\nprocedure TSynWebIDLSyn.ResetRange;\r\nbegin\r\n  fRange := rsUnknown;\r\nend;\r\n\r\nprocedure TSynWebIDLSyn.SetRange(Value: Pointer);\r\nbegin\r\n  fRange := TRangeState(Value);\r\nend;\r\n\r\nfunction TSynWebIDLSyn.GetRange: Pointer;\r\nbegin\r\n  Result := Pointer(fRange);\r\nend;\r\n\r\ninitialization\r\n{$IFNDEF SYN_CPPB_1}\r\n  RegisterPlaceableHighlighter(TSynWebIDLSyn);\r\n{$ENDIF}\r\nend.\r\n"
  },
  {
    "path": "External/SynEdit/Source/SynHighlighterXML.pas",
    "content": "{-------------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: SynHighlighterXML.pas, released 2000-11-20.\r\nThe Initial Author of this file is Jeff Rafter.\r\nUnicode translation by Mal Hrz.\r\nAll Rights Reserved.\r\n\r\nContributors to the SynEdit and mwEdit projects are listed in the\r\nContributors.txt file.\r\n\r\nAlternatively, the contents of this file may be used under the terms of the\r\nGNU General Public License Version 2 or later (the \"GPL\"), in which case\r\nthe provisions of the GPL are applicable instead of those above.\r\nIf you wish to allow use of your version of this file only under the terms\r\nof the GPL and not to allow others to use your version of this file\r\nunder the MPL, indicate your decision by deleting the provisions above and\r\nreplace them with the notice and other provisions required by the GPL.\r\nIf you do not delete the provisions above, a recipient may use your version\r\nof this file under either the MPL or the GPL.\r\n\r\n$Id: SynHighlighterXML.pas,v 1.11.2.6 2008/09/14 16:25:03 maelh Exp $\r\n\r\nYou may retrieve the latest version of this file at the SynEdit home page,\r\nlocated at http://SynEdit.SourceForge.net\r\n\r\nHistory:\r\n-------------------------------------------------------------------------------\r\n2000-11-30 Removed mHashTable and MakeIdentTable per Michael Hieke\r\n\r\nKnown Issues:\r\n- Nothing is really constrained (properly) to valid name chars\r\n- Entity Refs are not constrained to valid name chars\r\n- Support for \"Combining Chars and Extender Chars\" in names are lacking\r\n- The internal DTD is not parsed (and not handled correctly)\r\n-------------------------------------------------------------------------------}\r\n{\r\n@abstract(Provides an XML highlighter for SynEdit)\r\n@author(Jeff Rafter-- Phil 4:13, based on SynHighlighterHTML by Hideo Koiso)\r\n@created(2000-11-17)\r\n@lastmod(2001-03-12)\r\nThe SynHighlighterXML unit provides SynEdit with an XML highlighter.\r\n}\r\n\r\n{$IFNDEF QSYNHIGHLIGHTERXML}\r\nunit SynHighlighterXML;\r\n{$ENDIF}\r\n\r\ninterface\r\n\r\n{$I SynEdit.inc}\r\n\r\nuses\r\n{$IFDEF SYN_CLX}\r\n  Qt, QControls, QGraphics,\r\n  QSynEditTypes,\r\n  QSynEditHighlighter,\r\n  QSynUnicode,\r\n{$ELSE}\r\n  Windows, Messages, Controls, Graphics, Registry,\r\n  SynEditTypes,\r\n  SynEditHighlighter,\r\n  SynUnicode,\r\n{$ENDIF}\r\n  SysUtils,\r\n  Classes;\r\n\r\ntype\r\n  TtkTokenKind = (tkAposAttrValue, tkAposEntityRef, tkAttribute, tkCDATA,\r\n    tkComment, tkElement, tkEntityRef, tkEqual, tkNull, tkProcessingInstruction,\r\n    tkQuoteAttrValue, tkQuoteEntityRef, tkSpace, tkSymbol, tkText,\r\n    //\r\n    tknsAposAttrValue, tknsAposEntityRef, tknsAttribute, tknsEqual,\r\n    tknsQuoteAttrValue, tknsQuoteEntityRef,\r\n    //These are unused at the moment\r\n    tkDocType\r\n    {tkDocTypeAposAttrValue, tkDocTypeAposEntityRef, tkDocTypeAttribute,\r\n     tkDocTypeElement, tkDocTypeEqual tkDocTypeQuoteAttrValue,\r\n     tkDocTypeQuoteEntityRef}\r\n  );\r\n\r\n  TRangeState = (rsAposAttrValue, rsAPosEntityRef, rsAttribute, rsCDATA,\r\n    rsComment, rsElement, rsEntityRef, rsEqual, rsProcessingInstruction,\r\n    rsQuoteAttrValue, rsQuoteEntityRef, rsText,\r\n    //\r\n    rsnsAposAttrValue, rsnsAPosEntityRef, rsnsEqual, rsnsQuoteAttrValue,\r\n    rsnsQuoteEntityRef,\r\n    //These are unused at the moment\r\n    rsDocType, rsDocTypeSquareBraces\r\n    {rsDocTypeAposAttrValue, rsDocTypeAposEntityRef, rsDocTypeAttribute,\r\n     rsDocTypeElement, rsDocTypeEqual, rsDocTypeQuoteAttrValue,\r\n     rsDocTypeQuoteEntityRef}\r\n  );\r\n\r\n  TSynXMLSyn = class(TSynCustomHighlighter)\r\n  private\r\n    fRange: TRangeState;\r\n    fTokenID: TtkTokenKind;\r\n    fElementAttri: TSynHighlighterAttributes;\r\n    fSpaceAttri: TSynHighlighterAttributes;\r\n    fTextAttri: TSynHighlighterAttributes;\r\n    fEntityRefAttri: TSynHighlighterAttributes;\r\n    fProcessingInstructionAttri: TSynHighlighterAttributes;\r\n    fCDATAAttri: TSynHighlighterAttributes;\r\n    fCommentAttri: TSynHighlighterAttributes;\r\n    fDocTypeAttri: TSynHighlighterAttributes;\r\n    fAttributeAttri: TSynHighlighterAttributes;\r\n    fnsAttributeAttri: TSynHighlighterAttributes;\r\n    fAttributeValueAttri: TSynHighlighterAttributes;\r\n    fnsAttributeValueAttri: TSynHighlighterAttributes;\r\n    fSymbolAttri: TSynHighlighterAttributes;\r\n    FWantBracesParsed: Boolean;\r\n    procedure NullProc;\r\n    procedure CarriageReturnProc;\r\n    procedure LineFeedProc;\r\n    procedure SpaceProc;\r\n    procedure LessThanProc;\r\n    procedure GreaterThanProc;\r\n    procedure CommentProc;\r\n    procedure ProcessingInstructionProc;\r\n    procedure DocTypeProc;\r\n    procedure CDATAProc;\r\n    procedure TextProc;\r\n    procedure ElementProc;\r\n    procedure AttributeProc;\r\n    procedure QAttributeValueProc;\r\n    procedure AAttributeValueProc;\r\n    procedure EqualProc;\r\n    procedure IdentProc;\r\n    procedure NextProcedure;\r\n    function NextTokenIs(Token: UnicodeString): Boolean;\r\n    procedure EntityRefProc;\r\n    procedure QEntityRefProc;\r\n    procedure AEntityRefProc;\r\n  protected\r\n    function GetSampleSource: UnicodeString; override;\r\n    function IsFilterStored: Boolean; override;\r\n    function IsNameChar: Boolean; virtual;\r\n  public\r\n    class function GetLanguageName: string; override;\r\n    class function GetFriendlyLanguageName: UnicodeString; override;\r\n  public\r\n    constructor Create(AOwner: TComponent); override;\r\n    function GetDefaultAttribute(Index: integer): TSynHighlighterAttributes;\r\n      override;\r\n    function GetEol: Boolean; override;\r\n    function GetRange: Pointer; override;\r\n    function GetTokenID: TtkTokenKind;\r\n    function GetTokenAttribute: TSynHighlighterAttributes; override;\r\n    function GetTokenKind: integer; override;\r\n    procedure Next; override;\r\n    procedure SetRange(Value: Pointer); override;\r\n    procedure ResetRange; override;\r\n  published\r\n    property ElementAttri: TSynHighlighterAttributes read fElementAttri\r\n      write fElementAttri;\r\n    property AttributeAttri: TSynHighlighterAttributes read fAttributeAttri\r\n      write fAttributeAttri;\r\n    property NamespaceAttributeAttri: TSynHighlighterAttributes\r\n      read fnsAttributeAttri write fnsAttributeAttri;\r\n    property AttributeValueAttri: TSynHighlighterAttributes\r\n      read fAttributeValueAttri write fAttributeValueAttri;\r\n    property NamespaceAttributeValueAttri: TSynHighlighterAttributes\r\n      read fnsAttributeValueAttri write fnsAttributeValueAttri;\r\n    property TextAttri: TSynHighlighterAttributes read fTextAttri\r\n      write fTextAttri;\r\n    property CDATAAttri: TSynHighlighterAttributes read fCDATAAttri\r\n      write fCDATAAttri;\r\n    property EntityRefAttri: TSynHighlighterAttributes read fEntityRefAttri\r\n      write fEntityRefAttri;\r\n    property ProcessingInstructionAttri: TSynHighlighterAttributes\r\n      read fProcessingInstructionAttri write fProcessingInstructionAttri;\r\n    property CommentAttri: TSynHighlighterAttributes read fCommentAttri\r\n      write fCommentAttri;\r\n    property DocTypeAttri: TSynHighlighterAttributes read fDocTypeAttri\r\n      write fDocTypeAttri;\r\n    property SpaceAttri: TSynHighlighterAttributes read fSpaceAttri\r\n      write fSpaceAttri;\r\n    property SymbolAttri: TSynHighlighterAttributes read fSymbolAttri\r\n      write fSymbolAttri;\r\n    property WantBracesParsed : Boolean read FWantBracesParsed\r\n      write FWantBracesParsed default True;\r\n  end;\r\n\r\nimplementation\r\n\r\nuses\r\n{$IFDEF SYN_CLX}\r\n  QSynEditStrConst;\r\n{$ELSE}\r\n  SynEditStrConst;\r\n{$ENDIF}\r\n\r\nconstructor TSynXMLSyn.Create(AOwner: TComponent);\r\nbegin\r\n  inherited Create(AOwner);\r\n\r\n  fCaseSensitive := True;\r\n\r\n  fElementAttri := TSynHighlighterAttributes.Create(SYNS_AttrElementName, SYNS_FriendlyAttrElementName);\r\n  fTextAttri := TSynHighlighterAttributes.Create(SYNS_AttrText, SYNS_FriendlyAttrText);\r\n  fSpaceAttri := TSynHighlighterAttributes.Create(SYNS_AttrWhitespace, SYNS_FriendlyAttrWhitespace);\r\n  fEntityRefAttri := TSynHighlighterAttributes.Create(SYNS_AttrEntityReference, SYNS_FriendlyAttrEntityReference);\r\n  fProcessingInstructionAttri := TSynHighlighterAttributes.Create(\r\n    SYNS_AttrProcessingInstr, SYNS_FriendlyAttrProcessingInstr);\r\n  fCDATAAttri := TSynHighlighterAttributes.Create(SYNS_AttrCDATASection, SYNS_FriendlyAttrCDATASection);\r\n  fCommentAttri := TSynHighlighterAttributes.Create(SYNS_AttrComment, SYNS_FriendlyAttrComment);\r\n  fDocTypeAttri := TSynHighlighterAttributes.Create(SYNS_AttrDOCTYPESection, SYNS_FriendlyAttrDOCTYPESection);\r\n  fAttributeAttri := TSynHighlighterAttributes.Create(SYNS_AttrAttributeName, SYNS_FriendlyAttrAttributeName);\r\n  fnsAttributeAttri := TSynHighlighterAttributes.Create(\r\n    SYNS_AttrNamespaceAttrName, SYNS_FriendlyAttrNamespaceAttrName);\r\n  fAttributeValueAttri := TSynHighlighterAttributes.Create(\r\n    SYNS_AttrAttributeValue, SYNS_FriendlyAttrAttributeValue);\r\n  fnsAttributeValueAttri := TSynHighlighterAttributes.Create(\r\n    SYNS_AttrNamespaceAttrValue, SYNS_FriendlyAttrNamespaceAttrValue);\r\n  fSymbolAttri := TSynHighlighterAttributes.Create(SYNS_AttrSymbol, SYNS_FriendlyAttrSymbol);\r\n\r\n  fElementAttri.Foreground := clMaroon;\r\n  fElementAttri.Style := [fsBold];\r\n\r\n  fDocTypeAttri.Foreground := clblue;\r\n  fDocTypeAttri.Style := [fsItalic];\r\n\r\n  fCDATAAttri.Foreground := clOlive;\r\n  fCDATAAttri.Style := [fsItalic];\r\n\r\n  fEntityRefAttri.Foreground := clblue;\r\n  fEntityRefAttri.Style := [fsbold];\r\n\r\n  fProcessingInstructionAttri.Foreground:= clblue;\r\n  fProcessingInstructionAttri.Style:= [];\r\n\r\n  fTextAttri.Foreground := clBlack;\r\n  fTextAttri.Style := [fsBold];\r\n\r\n  fAttributeAttri.Foreground := clMaroon;\r\n  fAttributeAttri.Style := [];\r\n\r\n  fnsAttributeAttri.Foreground := clRed;\r\n  fnsAttributeAttri.Style := [];\r\n\r\n  fAttributeValueAttri.Foreground := clNavy;\r\n  fAttributeValueAttri.Style := [fsBold];\r\n\r\n  fnsAttributeValueAttri.Foreground := clRed;\r\n  fnsAttributeValueAttri.Style := [fsBold];\r\n\r\n  fCommentAttri.Background := clSilver;\r\n  fCommentAttri.Foreground := clGray;\r\n  fCommentAttri.Style := [fsbold, fsItalic];\r\n\r\n  fSymbolAttri.Foreground := clblue;\r\n  fSymbolAttri.Style := [];\r\n\r\n  AddAttribute(fSymbolAttri);\r\n  AddAttribute(fProcessingInstructionAttri);\r\n  AddAttribute(fDocTypeAttri);\r\n  AddAttribute(fCommentAttri);\r\n  AddAttribute(fElementAttri);\r\n  AddAttribute(fAttributeAttri);\r\n  AddAttribute(fnsAttributeAttri);\r\n  AddAttribute(fAttributeValueAttri);\r\n  AddAttribute(fnsAttributeValueAttri);\r\n  AddAttribute(fEntityRefAttri);\r\n  AddAttribute(fCDATAAttri);\r\n  AddAttribute(fSpaceAttri);\r\n  AddAttribute(fTextAttri);\r\n\r\n  SetAttributesOnChange(DefHighlightChange);\r\n\r\n  fRange := rsText;\r\n  fDefaultFilter := SYNS_FilterXML;\r\nend;\r\n\r\nprocedure TSynXMLSyn.NullProc;\r\nbegin\r\n  fTokenID := tkNull;\r\n  inc(Run);\r\nend;\r\n\r\nprocedure TSynXMLSyn.CarriageReturnProc;\r\nbegin\r\n  fTokenID := tkSpace;\r\n  Inc(Run);\r\n  if fLine[Run] = #10 then Inc(Run);\r\nend;\r\n\r\nprocedure TSynXMLSyn.LineFeedProc;\r\nbegin\r\n  fTokenID := tkSpace;\r\n  Inc(Run);\r\nend;\r\n\r\nprocedure TSynXMLSyn.SpaceProc;\r\nbegin\r\n  inc(Run);\r\n  fTokenID := tkSpace;\r\n  while fLine[Run] <= #32 do\r\n  begin\r\n    if CharInSet(fLine[Run], [#0, #9, #10, #13]) then break;\r\n    Inc(Run);\r\n  end;\r\nend;\r\n\r\nprocedure TSynXMLSyn.LessThanProc;\r\nbegin\r\n  Inc(Run);\r\n  if (fLine[Run] = '/') then\r\n    Inc(Run);\r\n\r\n  if (fLine[Run] = '!') then\r\n  begin\r\n    if NextTokenIs('--') then\r\n    begin\r\n      fTokenID := tkSymbol;\r\n      fRange := rsComment;\r\n      Inc(Run, 3);\r\n    end\r\n    else if NextTokenIs('DOCTYPE') then\r\n    begin\r\n      fTokenID := tkDocType;\r\n      fRange := rsDocType;\r\n      Inc(Run, 7);\r\n    end\r\n    else if NextTokenIs('[CDATA[') then\r\n    begin\r\n      fTokenID := tkCDATA;\r\n      fRange := rsCDATA;\r\n      Inc(Run, 7);\r\n    end\r\n    else\r\n    begin\r\n      fTokenID := tkSymbol;\r\n      fRange := rsElement;\r\n      Inc(Run);\r\n    end;\r\n  end\r\n  else if fLine[Run]= '?' then\r\n  begin\r\n    fTokenID := tkProcessingInstruction;\r\n    fRange := rsProcessingInstruction;\r\n    Inc(Run);\r\n  end\r\n  else\r\n  begin\r\n    fTokenID := tkSymbol;\r\n    fRange := rsElement;\r\n  end;\r\nend;\r\n\r\nprocedure TSynXMLSyn.GreaterThanProc;\r\nbegin\r\n  fTokenId := tkSymbol;\r\n  fRange:= rsText;\r\n  Inc(Run);\r\nend;\r\n\r\nprocedure TSynXMLSyn.CommentProc;\r\nbegin\r\n  if (fLine[Run] = '-') and (fLine[Run + 1] = '-') and (fLine[Run + 2] = '>') then\r\n  begin\r\n    fTokenID := tkSymbol;\r\n    fRange := rsText;\r\n    Inc(Run, 3);\r\n    Exit;\r\n  end;\r\n\r\n  fTokenID := tkComment;\r\n\r\n  if IsLineEnd(Run) then\r\n  begin\r\n    NextProcedure;\r\n    Exit;\r\n  end;\r\n\r\n  while not IsLineEnd(Run) do\r\n  begin\r\n    if (fLine[Run] = '-') and (fLine[Run + 1] = '-') and (fLine[Run + 2] = '>') then\r\n    begin\r\n      fRange := rsComment;\r\n      break;\r\n    end;\r\n    Inc(Run);\r\n  end;\r\nend;\r\n\r\nprocedure TSynXMLSyn.ProcessingInstructionProc;\r\nbegin\r\n  fTokenID := tkProcessingInstruction;\r\n  if IsLineEnd(Run) then\r\n  begin\r\n    NextProcedure;\r\n    Exit;\r\n  end;\r\n\r\n  while not IsLineEnd(Run) do\r\n  begin\r\n    if (fLine[Run] = '>') and (fLine[Run - 1] = '?')\r\n    then\r\n    begin\r\n      fRange := rsText;\r\n      Inc(Run);\r\n      break;\r\n    end;\r\n    Inc(Run);\r\n  end;\r\nend;\r\n\r\nprocedure TSynXMLSyn.DocTypeProc;\r\nbegin\r\n  fTokenID := tkDocType;\r\n\r\n  if IsLineEnd(Run) then\r\n  begin\r\n    NextProcedure;\r\n    Exit;\r\n  end;\r\n\r\n  case fRange of\r\n    rsDocType:\r\n      begin\r\n        while not IsLineEnd(Run) do\r\n        begin\r\n          case fLine[Run] of\r\n            '[': begin\r\n                   while True do\r\n                   begin\r\n                     inc(Run);\r\n                     case fLine[Run] of\r\n                       ']':\r\n                         begin\r\n                           Inc(Run);\r\n                           Exit;\r\n                         end;\r\n                       #0, #10, #13:\r\n                         begin\r\n                           fRange := rsDocTypeSquareBraces;\r\n                           Exit;\r\n                         end;\r\n                     end;\r\n                   end;\r\n                 end;\r\n            '>': begin\r\n                   fRange := rsAttribute;\r\n                   Inc(Run);\r\n                   Break;\r\n                 end;\r\n          end;\r\n          inc(Run);\r\n        end;\r\n    end;\r\n    rsDocTypeSquareBraces:\r\n      begin\r\n        while not IsLineEnd(Run) do\r\n        begin\r\n          if (fLine[Run] = ']') then\r\n          begin\r\n            fRange := rsDocType;\r\n            Inc(Run);\r\n            Exit;\r\n          end;\r\n          inc(Run);\r\n        end;\r\n      end;\r\n  end;\r\nend;\r\n\r\nprocedure TSynXMLSyn.CDATAProc;\r\nbegin\r\n  fTokenID := tkCDATA;\r\n  if IsLineEnd(Run) then\r\n  begin\r\n    NextProcedure;\r\n    Exit;\r\n  end;\r\n\r\n  while not IsLineEnd(Run) do\r\n  begin\r\n    if (fLine[Run] = '>') and (fLine[Run - 1] = ']')\r\n    then\r\n    begin\r\n      fRange := rsText;\r\n      Inc(Run);\r\n      break;\r\n    end;\r\n    Inc(Run);\r\n  end;\r\nend;\r\n\r\nprocedure TSynXMLSyn.ElementProc;\r\nbegin\r\n  if fLine[Run] = '/' then Inc(Run);\r\n  while IsNameChar do Inc(Run);\r\n  fRange := rsAttribute;\r\n  fTokenID := tkElement;\r\nend;\r\n\r\nprocedure TSynXMLSyn.AttributeProc;\r\nbegin\r\n  //Check if we are starting on a closing quote\r\n  if CharInSet(fLine[Run], [#34, #39]) then\r\n  begin\r\n    fTokenID := tkSymbol;\r\n    fRange := rsAttribute;\r\n    Inc(Run);\r\n    Exit;\r\n  end;\r\n  //Read the name\r\n  while IsNameChar do Inc(Run);\r\n  //Check if this is an xmlns: attribute\r\n  if (Pos('xmlns', GetToken) > 0) then\r\n  begin\r\n    fTokenID := tknsAttribute;\r\n    fRange := rsnsEqual;\r\n  end\r\n  else\r\n  begin\r\n    fTokenID := tkAttribute;\r\n    fRange := rsEqual;\r\n  end;\r\nend;\r\n\r\nprocedure TSynXMLSyn.EqualProc;\r\nbegin\r\n  if fRange = rsnsEqual then\r\n    fTokenID := tknsEqual\r\n  else\r\n    fTokenID := tkEqual;\r\n\r\n  while not IsLineEnd(Run) do\r\n  begin\r\n    if (fLine[Run] = '/') then\r\n    begin\r\n      fTokenID := tkSymbol;\r\n      fRange := rsElement;\r\n      Inc(Run);\r\n      Exit;\r\n    end\r\n    else if (fLine[Run] = #34) then\r\n    begin\r\n      if fRange = rsnsEqual then\r\n        fRange := rsnsQuoteAttrValue\r\n      else\r\n        fRange := rsQuoteAttrValue;\r\n      Inc(Run);\r\n      Exit;\r\n    end\r\n    else if (fLine[Run] = #39) then\r\n    begin\r\n      if fRange = rsnsEqual then\r\n        fRange := rsnsAPosAttrValue\r\n      else\r\n        fRange := rsAPosAttrValue;\r\n      Inc(Run);\r\n      Exit;\r\n    end;\r\n    Inc(Run);\r\n  end;\r\nend;\r\n\r\nprocedure TSynXMLSyn.QAttributeValueProc;\r\nbegin\r\n  if fRange = rsnsQuoteAttrValue then\r\n    fTokenID := tknsQuoteAttrValue\r\n  else\r\n    fTokenID := tkQuoteAttrValue;\r\n\r\n  while not (IsLineEnd(Run) or (fLine[Run] = '&') or (fLine[Run] = #34)) do\r\n    Inc(Run);\r\n\r\n  if fLine[Run] = '&' then\r\n  begin\r\n    if fRange = rsnsQuoteAttrValue then\r\n      fRange := rsnsQuoteEntityRef\r\n    else\r\n      fRange := rsQuoteEntityRef;\r\n    Exit;\r\n  end\r\n  else if fLine[Run] <> #34 then\r\n    Exit;\r\n\r\n  fRange := rsAttribute;\r\nend;\r\n\r\nprocedure TSynXMLSyn.AAttributeValueProc;\r\nbegin\r\n  if fRange = rsnsAPosAttrValue then\r\n    fTokenID := tknsAPosAttrValue\r\n  else\r\n    fTokenID := tkAPosAttrValue;\r\n\r\n  while not (IsLineEnd(Run) or (fLine[Run] = '&') or (fLine[Run] = #39)) do\r\n    Inc(Run);\r\n\r\n  if fLine[Run] = '&' then\r\n  begin\r\n    if fRange = rsnsAPosAttrValue then\r\n      fRange := rsnsAPosEntityRef\r\n    else\r\n      fRange := rsAPosEntityRef;\r\n    Exit;\r\n  end\r\n  else if fLine[Run] <> #39 then\r\n    Exit;\r\n\r\n  fRange := rsAttribute;\r\nend;\r\n\r\nprocedure TSynXMLSyn.TextProc;\r\nbegin\r\n  if (fLine[Run] <= #31) or (fLine[Run] = '<') then\r\n  begin\r\n    NextProcedure;\r\n    exit;\r\n  end;\r\n\r\n  fTokenID := tkText;\r\n  while not ((fLine[Run] <= #31) or (fLine[Run] = '<') or (fLine[Run] = '&')) do\r\n    Inc(Run);\r\n\r\n  if (fLine[Run] = '&') then\r\n  begin\r\n    fRange := rsEntityRef;\r\n    Exit;\r\n  end;\r\nend;\r\n\r\nprocedure TSynXMLSyn.EntityRefProc;\r\nbegin\r\n  fTokenID := tkEntityRef;\r\n  fRange := rsEntityRef;\r\n  while not ((fLine[Run] <= #32) or (fLine[Run] = ';')) do Inc(Run);\r\n  if (fLine[Run] = ';') then Inc(Run);\r\n  fRange := rsText;\r\nend;\r\n\r\nprocedure TSynXMLSyn.QEntityRefProc;\r\nbegin\r\n  if fRange = rsnsQuoteEntityRef then\r\n    fTokenID := tknsQuoteEntityRef\r\n  else\r\n    fTokenID := tkQuoteEntityRef;\r\n\r\n  while not ((fLine[Run] <= #32) or (fLine[Run] = ';')) do Inc(Run);\r\n  if (fLine[Run] = ';') then Inc(Run);\r\n\r\n  if fRange = rsnsQuoteEntityRef then\r\n    fRange := rsnsQuoteAttrValue\r\n  else\r\n    fRange := rsQuoteAttrValue;\r\nend;\r\n\r\nprocedure TSynXMLSyn.AEntityRefProc;\r\nbegin\r\n  if fRange = rsnsAPosEntityRef then\r\n    fTokenID := tknsAPosEntityRef\r\n  else\r\n    fTokenID := tkAPosEntityRef;\r\n\r\n  while not ((fLine[Run] <= #32) or (fLine[Run] = ';')) do Inc(Run);\r\n  if (fLine[Run] = ';') then Inc(Run);\r\n\r\n  if fRange = rsnsAPosEntityRef then\r\n    fRange := rsnsAPosAttrValue\r\n  else\r\n    fRange := rsAPosAttrValue;\r\nend;\r\n\r\nprocedure TSynXMLSyn.IdentProc;\r\nbegin\r\n  case fRange of\r\n    rsElement:\r\n      begin\r\n        ElementProc;\r\n      end;\r\n    rsAttribute:\r\n      begin\r\n        AttributeProc;\r\n      end;\r\n    rsEqual, rsnsEqual:\r\n      begin\r\n        EqualProc;\r\n      end;\r\n    rsQuoteAttrValue, rsnsQuoteAttrValue:\r\n      begin\r\n        QAttributeValueProc;\r\n      end;\r\n    rsAposAttrValue, rsnsAPosAttrValue:\r\n      begin\r\n        AAttributeValueProc;\r\n      end;\r\n    rsQuoteEntityRef, rsnsQuoteEntityRef:\r\n      begin\r\n        QEntityRefProc;\r\n      end;\r\n    rsAposEntityRef, rsnsAPosEntityRef:\r\n      begin\r\n        AEntityRefProc;\r\n      end;\r\n    rsEntityRef:\r\n      begin\r\n        EntityRefProc;\r\n      end;\r\n    else ;\r\n  end;\r\nend;\r\n\r\nprocedure TSynXMLSyn.Next;\r\nbegin\r\n  fTokenPos := Run;\r\n  case fRange of\r\n    rsText: TextProc;\r\n    rsComment: CommentProc;\r\n    rsProcessingInstruction: ProcessingInstructionProc;\r\n    rsDocType, rsDocTypeSquareBraces: DocTypeProc;\r\n    rsCDATA: CDATAProc;\r\n    else NextProcedure;\r\n  end;\r\n  // ensure that one call of Next is enough to reach next token\r\n  if (fOldRun = Run) and not GetEol then Next;\r\n  inherited;\r\nend;\r\n\r\nprocedure TSynXMLSyn.NextProcedure;\r\nbegin\r\n  case fLine[Run] of\r\n    #0: NullProc;\r\n    #10: LineFeedProc;\r\n    #13: CarriageReturnProc;\r\n    #1..#9, #11, #12, #14..#32: SpaceProc;\r\n    '<': LessThanProc;\r\n    '>': GreaterThanProc;\r\n    else IdentProc;\r\n  end;\r\nend;\r\n\r\nfunction TSynXMLSyn.NextTokenIs(Token: UnicodeString): Boolean;\r\nvar\r\n  I, Len: Integer;\r\nbegin\r\n  Result := True;\r\n  Len := Length(Token);\r\n  for I := 1 to Len do\r\n    if (fLine[Run + I] <> Token[I]) then\r\n    begin\r\n      Result:= False;\r\n      Break;\r\n    end;\r\nend;\r\n\r\nfunction TSynXMLSyn.GetDefaultAttribute(Index: Integer): TSynHighlighterAttributes;\r\nbegin\r\n  case Index of\r\n    SYN_ATTR_COMMENT: Result := fCommentAttri;\r\n    SYN_ATTR_IDENTIFIER: Result := fAttributeAttri;\r\n    SYN_ATTR_KEYWORD: Result := fElementAttri;\r\n    SYN_ATTR_WHITESPACE: Result := fSpaceAttri;\r\n    SYN_ATTR_SYMBOL: Result := fSymbolAttri;\r\n  else\r\n    Result := nil;\r\n  end;\r\nend;\r\n\r\nfunction TSynXMLSyn.GetEol: Boolean;\r\nbegin\r\n  Result := Run = fLineLen + 1;\r\nend;\r\n\r\nfunction TSynXMLSyn.GetTokenID: TtkTokenKind;\r\nbegin\r\n  Result := fTokenId;\r\nend;\r\n\r\nfunction TSynXMLSyn.GetTokenAttribute: TSynHighlighterAttributes;\r\nbegin\r\n  case fTokenID of\r\n    tkElement: Result:= fElementAttri;\r\n    tkAttribute: Result:= fAttributeAttri;\r\n    tknsAttribute: Result:= fnsAttributeAttri;\r\n    tkEqual: Result:= fSymbolAttri;\r\n    tknsEqual: Result:= fSymbolAttri;\r\n    tkQuoteAttrValue: Result:= fAttributeValueAttri;\r\n    tkAPosAttrValue: Result:= fAttributeValueAttri;\r\n    tknsQuoteAttrValue: Result:= fnsAttributeValueAttri;\r\n    tknsAPosAttrValue: Result:= fnsAttributeValueAttri;\r\n    tkText: Result:= fTextAttri;\r\n    tkCDATA: Result:= fCDATAAttri;\r\n    tkEntityRef: Result:= fEntityRefAttri;\r\n    tkQuoteEntityRef: Result:= fEntityRefAttri;\r\n    tkAposEntityRef: Result:= fEntityRefAttri;\r\n    tknsQuoteEntityRef: Result:= fEntityRefAttri;\r\n    tknsAposEntityRef: Result:= fEntityRefAttri;\r\n    tkProcessingInstruction: Result:= fProcessingInstructionAttri;\r\n    tkComment: Result:= fCommentAttri;\r\n    tkDocType: Result:= fDocTypeAttri;\r\n    tkSymbol: Result:= fSymbolAttri;\r\n    tkSpace: Result:= fSpaceAttri;\r\n  else\r\n    Result := nil;\r\n  end;\r\nend;\r\n\r\nfunction TSynXMLSyn.GetTokenKind: integer;\r\nbegin\r\n  Result := Ord(fTokenId);\r\nend;\r\n\r\nfunction TSynXMLSyn.GetRange: Pointer;\r\nbegin\r\n  Result := Pointer(fRange);\r\nend;\r\n\r\nprocedure TSynXMLSyn.SetRange(Value: Pointer);\r\nbegin\r\n  fRange := TRangeState(Value);\r\nend;\r\n\r\nprocedure TSynXMLSyn.ResetRange;\r\nbegin\r\n  fRange := rsText;\r\nend;\r\n\r\nfunction TSynXMLSyn.IsFilterStored: Boolean;\r\nbegin\r\n  Result := fDefaultFilter <> SYNS_FilterXML;\r\nend;\r\n\r\n{ TODO: In fact every Number also non-arabics and every letter also German umlauts\r\n  can be used. Something like IsAlphaNumericCharW should be used instead. }\r\nfunction TSynXMLSyn.IsNameChar: Boolean;\r\nbegin\r\n  case fLine[Run] of\r\n    '0'..'9', 'a'..'z', 'A'..'Z', '_', '.', ':', '-':\r\n      Result := True;\r\n    else if fLine[Run] > '' then // TODO: this here is very vague, see above\r\n      Result := True\r\n    else\r\n      Result := False;\r\n  end;\r\nend;\r\n\r\nclass function TSynXMLSyn.GetLanguageName: string;\r\nbegin\r\n  Result := SYNS_LangXML;\r\nend;\r\n\r\nfunction TSynXMLSyn.GetSampleSource: UnicodeString;\r\nbegin\r\n  Result:= ''#13#10+\r\n           ''#13#10+\r\n           ''#13#10+\r\n           ''#13#10+\r\n           '  '#13#10+\r\n           '';\r\nend;\r\n\r\n{$IFNDEF SYN_CPPB_1}\r\nclass function TSynXMLSyn.GetFriendlyLanguageName: UnicodeString;\r\nbegin\r\n  Result := SYNS_FriendlyLangXML;\r\nend;\r\n\r\ninitialization\r\n  RegisterPlaceableHighlighter(TSynXMLSyn);\r\n{$ENDIF}\r\nend.\r\n"
  },
  {
    "path": "External/SynEdit/Source/SynMacroRecorder.pas",
    "content": "{-------------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: SynMacroRecorder.pas, released 2001-10-17.\r\n\r\nAuthor of this file is Flvio Etrusco.\r\nPortions created by Flvio Etrusco are Copyright 2001 Flvio Etrusco.\r\nUnicode translation by Mal Hrz.\r\nAll Rights Reserved.\r\n\r\nContributors to the SynEdit project are listed in the Contributors.txt file.\r\n\r\nAlternatively, the contents of this file may be used under the terms of the\r\nGNU General Public License Version 2 or later (the \"GPL\"), in which case\r\nthe provisions of the GPL are applicable instead of those above.\r\nIf you wish to allow use of your version of this file only under the terms\r\nof the GPL and not to allow others to use your version of this file\r\nunder the MPL, indicate your decision by deleting the provisions above and\r\nreplace them with the notice and other provisions required by the GPL.\r\nIf you do not delete the provisions above, a recipient may use your version\r\nof this file under either the MPL or the GPL.\r\n\r\n$Id: SynMacroRecorder.pas,v 1.31.2.3 2008/09/14 16:25:03 maelh Exp $\r\n\r\nYou may retrieve the latest version of this file at the SynEdit home page,\r\nlocated at http://SynEdit.SourceForge.net\r\n\r\nKnown Issues:\r\n-------------------------------------------------------------------------------}\r\n\r\n{$IFNDEF QSYNMACRORECORDER}\r\nunit SynMacroRecorder;\r\n{$ENDIF}\r\n\r\n{$I SynEdit.inc}\r\n\r\ninterface\r\n\r\nuses\r\n{$IFDEF SYN_CLX}\r\n  QConsts,\r\n  QStdCtrls,\r\n  QControls,\r\n  Qt,\r\n  Types,\r\n  QGraphics,\r\n  QMenus,\r\n  QSynEdit,\r\n  QSynEditKeyCmds,\r\n  QSynEditPlugins,\r\n  QSynEditTypes,\r\n  QSynUnicode,\r\n{$ELSE}\r\n  StdCtrls,\r\n  Controls,\r\n  Windows,\r\n  Messages,\r\n  Graphics,\r\n  Menus,\r\n  SynEdit,\r\n  SynEditKeyCmds,\r\n  SynEditPlugins,\r\n  SynEditTypes,\r\n  SynUnicode,\r\n{$ENDIF}\r\n{$IFDEF UNICODE}\r\n  WideStrUtils,\r\n{$ENDIF}\r\n  Classes;\r\n\r\n{$IFDEF SYN_COMPILER_3_UP}\r\nresourcestring\r\n{$ELSE}\r\nconst\r\n{$ENDIF}\r\n  sCannotRecord = 'Cannot record macro; already recording or playing';\r\n  sCannotPlay = 'Cannot playback macro; already playing or recording';\r\n  sCannotPause = 'Can only pause when recording';\r\n  sCannotResume = 'Can only resume when paused';\r\n\r\ntype\r\n  TSynMacroState = (msStopped, msRecording, msPlaying, msPaused);\r\n  TSynMacroCommand = (mcRecord, mcPlayback);\r\n\r\n  TSynMacroEvent = class(TObject)\r\n  protected\r\n    fRepeatCount: Byte;\r\n    function GetAsString: UnicodeString; virtual; abstract;\r\n    procedure InitEventParameters(aStr: UnicodeString); virtual; abstract;\r\n  public\r\n    constructor Create; virtual;\r\n    procedure Initialize(aCmd: TSynEditorCommand; aChar: WideChar; aData: Pointer);\r\n      virtual; abstract;\r\n    { the CommandID must not be read inside LoadFromStream/SaveToStream. It's read by the\r\n    MacroRecorder component to decide which MacroEvent class to instanciate }\r\n    procedure LoadFromStream(aStream: TStream); virtual; abstract;\r\n    procedure SaveToStream(aStream: TStream); virtual; abstract;\r\n    procedure Playback(aEditor: TCustomSynEdit); virtual; abstract;\r\n    property AsString: UnicodeString read GetAsString;\r\n    property RepeatCount: Byte read fRepeatCount write fRepeatCount;\r\n  end;\r\n\r\n  TSynBasicEvent = class(TSynMacroEvent)\r\n  protected\r\n    fCommand: TSynEditorCommand;\r\n    function GetAsString: UnicodeString; override;\r\n    procedure InitEventParameters(aStr: UnicodeString); override;\r\n  public\r\n    procedure Initialize(aCmd: TSynEditorCommand; aChar: WideChar; aData: Pointer);\r\n      override;\r\n    procedure LoadFromStream(aStream: TStream); override;\r\n    procedure SaveToStream(aStream: TStream); override;\r\n    procedure Playback(aEditor: TCustomSynEdit); override;\r\n  public\r\n    property Command: TSynEditorCommand read fCommand write fCommand;\r\n  end;\r\n\r\n  TSynCharEvent = class(TSynMacroEvent)\r\n  protected\r\n    fKey: WideChar;\r\n    function GetAsString: UnicodeString; override;\r\n    procedure InitEventParameters(aStr: UnicodeString); override;\r\n  public\r\n    procedure Initialize(aCmd: TSynEditorCommand; aChar: WideChar; aData: Pointer);\r\n      override;\r\n    procedure LoadFromStream(aStream: TStream); override;\r\n    procedure SaveToStream(aStream: TStream); override;\r\n    procedure Playback(aEditor: TCustomSynEdit); override;\r\n  public\r\n    property Key: WideChar read fKey write fKey;\r\n  end;\r\n\r\n  TSynStringEvent = class(TSynMacroEvent)\r\n  protected\r\n    fString: UnicodeString;\r\n    function GetAsString: UnicodeString; override;\r\n    procedure InitEventParameters(aStr: UnicodeString); override;\r\n  public\r\n    procedure Initialize(aCmd: TSynEditorCommand; aChar: WideChar; aData: Pointer);\r\n      override;\r\n    procedure LoadFromStream(aStream: TStream); override;\r\n    procedure SaveToStream(aStream: TStream); override;\r\n    procedure Playback(aEditor: TCustomSynEdit); override;\r\n  public\r\n    property Value: UnicodeString read fString write fString;\r\n  end;\r\n\r\n  TSynPositionEvent = class(TSynBasicEvent)\r\n  protected\r\n    fPosition: TBufferCoord;\r\n    function GetAsString: UnicodeString; override;\r\n    procedure InitEventParameters(aStr: UnicodeString); override;\r\n  public\r\n    procedure Initialize(aCmd: TSynEditorCommand; aChar: WideChar; aData: Pointer);\r\n      override;\r\n    procedure LoadFromStream(aStream: TStream); override;\r\n    procedure SaveToStream(aStream: TStream); override;\r\n    procedure Playback(aEditor: TCustomSynEdit); override;\r\n  public\r\n    property Position: TBufferCoord read fPosition write fPosition;\r\n  end;\r\n\r\n  TSynDataEvent = class(TSynBasicEvent)\r\n  protected\r\n    fData: Pointer;\r\n  public\r\n    procedure Initialize(aCmd: TSynEditorCommand; aChar: WideChar; aData: Pointer);\r\n      override;\r\n    procedure LoadFromStream(aStream: TStream); override;\r\n    procedure SaveToStream(aStream: TStream); override;\r\n    procedure Playback(aEditor: TCustomSynEdit); override;\r\n  end;\r\n\r\n  TCustomSynMacroRecorder = class;\r\n\r\n  TSynUserCommandEvent = procedure (aSender: TCustomSynMacroRecorder;\r\n    aCmd: TSynEditorCommand; var aEvent: TSynMacroEvent) of object;\r\n\r\n  { TCustomSynMacroRecorder\r\n  OnStateChange:\r\n    occurs right after start playing, recording, pausing or stopping\r\n  SaveMarkerPos:\r\n    if true, Bookmark position is recorded in the macro. Otherwise, the Bookmark\r\n    is created in the position the Caret is at the time of playback.\r\n  }\r\n\r\n  TCustomSynMacroRecorder = class(TAbstractSynHookerPlugin)\r\n  private\r\n    fShortCuts: array [TSynMacroCommand] of TShortCut;\r\n    fOnStateChange: TNotifyEvent;\r\n    fOnUserCommand: TSynUserCommandEvent;\r\n    fMacroName: string;\r\n    fSaveMarkerPos: boolean;\r\n    function GetEvent(aIndex: integer): TSynMacroEvent;\r\n    function GetEventCount: integer;\r\n    function GetAsString: UnicodeString;\r\n    procedure SetAsString(const Value: UnicodeString);\r\n  protected\r\n    fCurrentEditor: TCustomSynEdit;\r\n    fState: TSynMacroState;\r\n    fEvents: TList;\r\n    fCommandIDs: array [TSynMacroCommand] of TSynEditorCommand;\r\n    procedure SetShortCut(const Index: Integer; const Value: TShortCut);\r\n    function GetIsEmpty: boolean;\r\n    procedure StateChanged;\r\n    procedure DoAddEditor(aEditor: TCustomSynEdit); override;\r\n    procedure DoRemoveEditor(aEditor: TCustomSynEdit); override;\r\n    procedure OnCommand(Sender: TObject; AfterProcessing: boolean;\r\n      var Handled: boolean; var Command: TSynEditorCommand; var aChar: WideChar;\r\n      Data: pointer; HandlerData: pointer); override;\r\n    function CreateMacroEvent(aCmd: TSynEditorCommand): TSynMacroEvent;\r\n  protected\r\n    property RecordCommandID: TSynEditorCommand read fCommandIDs[mcRecord];\r\n    property PlaybackCommandID: TSynEditorCommand read fCommandIDs[mcPlayback];\r\n  public\r\n    constructor Create(aOwner: TComponent); override;\r\n    destructor Destroy; override;\r\n    procedure Error(const aMsg: String);\r\n    procedure AddEditor(aEditor: TCustomSynEdit);\r\n    procedure RemoveEditor(aEditor: TCustomSynEdit);\r\n    procedure RecordMacro(aEditor: TCustomSynEdit);\r\n    procedure PlaybackMacro(aEditor: TCustomSynEdit);\r\n    procedure Stop;\r\n    procedure Pause;\r\n    procedure Resume;\r\n    property IsEmpty: boolean read GetIsEmpty;\r\n    property State: TSynMacroState read fState;\r\n    procedure Clear;\r\n    procedure AddEvent(aCmd: TSynEditorCommand; aChar: WideChar; aData: pointer);\r\n    procedure InsertEvent(aIndex: integer; aCmd: TSynEditorCommand; aChar: WideChar;\r\n      aData: pointer);\r\n    procedure AddCustomEvent(aEvent: TSynMacroEvent);\r\n    procedure InsertCustomEvent(aIndex: integer; aEvent: TSynMacroEvent);\r\n    procedure DeleteEvent(aIndex: integer);\r\n    procedure LoadFromStream(aSrc: TStream);\r\n    procedure LoadFromStreamEx(aSrc: TStream; aClear: boolean);\r\n    procedure SaveToStream(aDest: TStream);\r\n    procedure LoadFromFile(aFilename : string);\r\n    procedure SaveToFile(aFilename : string);\r\n    property EventCount: integer read GetEventCount;\r\n    property Events[aIndex: integer]: TSynMacroEvent read GetEvent;\r\n    property RecordShortCut: TShortCut index Ord(mcRecord)\r\n      read fShortCuts[mcRecord] write SetShortCut;\r\n    property PlaybackShortCut: TShortCut index Ord(mcPlayback)\r\n      read fShortCuts[mcPlayback] write SetShortCut;\r\n    property SaveMarkerPos: boolean read fSaveMarkerPos\r\n      write fSaveMarkerPos default False;\r\n    property AsString: UnicodeString read GetAsString write SetAsString;\r\n    property MacroName: string read fMacroName write fMacroName;\r\n    property OnStateChange: TNotifyEvent read fOnStateChange write fOnStateChange;\r\n    property OnUserCommand: TSynUserCommandEvent read fOnUserCommand\r\n      write fOnUserCommand;\r\n  end;\r\n\r\n  TSynMacroRecorder = class(TCustomSynMacroRecorder)\r\n  published\r\n    property SaveMarkerPos;\r\n    property RecordShortCut;\r\n    property PlaybackShortCut;\r\n    property OnStateChange;\r\n    property OnUserCommand;\r\n  end;\r\n\r\nimplementation\r\n\r\nuses\r\n{$IFDEF SYN_CLX}\r\n  QForms,\r\n  QSynEditMiscProcs,\r\n{$ELSE}\r\n  Forms,\r\n  SynEditMiscProcs,\r\n{$IFDEF SYN_COMPILER_6_UP}\r\n  RTLConsts,\r\n{$ENDIF}\r\n{$ENDIF}\r\n  SysUtils;\r\n\r\n{ TSynDataEvent }\r\n\r\nprocedure TSynDataEvent.Initialize(aCmd: TSynEditorCommand; aChar: WideChar;\r\n  aData: Pointer);\r\nbegin\r\n  fCommand := aCmd;\r\n  Assert(aChar = #0);\r\n  fData := aData;\r\nend;\r\n\r\nprocedure TSynDataEvent.LoadFromStream(aStream: TStream);\r\nbegin\r\n  aStream.Read(fData, SizeOf(fData));\r\nend;\r\n\r\nprocedure TSynDataEvent.Playback(aEditor: TCustomSynEdit);\r\nbegin\r\n  aEditor.CommandProcessor(Command, #0, fData);\r\nend;\r\n\r\nprocedure TSynDataEvent.SaveToStream(aStream: TStream);\r\nbegin\r\n  inherited;\r\n  aStream.Write(fData, SizeOf(fData));\r\nend;\r\n\r\n{ TCustomSynMacroRecorder }\r\n\r\nprocedure TCustomSynMacroRecorder.AddCustomEvent(aEvent: TSynMacroEvent);\r\nbegin\r\n  InsertCustomEvent(EventCount, aEvent);\r\nend;\r\n\r\nprocedure TCustomSynMacroRecorder.AddEditor(aEditor: TCustomSynEdit);\r\nbegin\r\n  inherited AddEditor(aEditor);\r\nend;\r\n\r\nprocedure TCustomSynMacroRecorder.AddEvent(aCmd: TSynEditorCommand;\r\n  aChar: WideChar; aData: pointer);\r\nbegin\r\n  InsertEvent(EventCount, aCmd, aChar, aData);\r\nend;\r\n\r\nprocedure TCustomSynMacroRecorder.Clear;\r\nvar\r\n  I: Integer;\r\n  Obj: TObject;\r\nbegin\r\n  if Assigned(fEvents) then\r\n  begin\r\n    for I := fEvents.Count-1 downto 0 do\r\n    begin\r\n      Obj := fEvents[I];\r\n      fEvents.Delete(I);\r\n      Obj.Free;\r\n    end;\r\n    FreeAndNil(fEvents);\r\n  end;\r\nend;\r\n\r\nconstructor TCustomSynMacroRecorder.Create(aOwner: TComponent);\r\nbegin\r\n  inherited;\r\n  fMacroName := 'unnamed';\r\n  fCommandIDs[mcRecord] := NewPluginCommand;\r\n  fCommandIDs[mcPlayback] := NewPluginCommand;\r\n  {$IFDEF SYN_CLX} \r\n  fShortCuts[mcRecord] := QMenus.ShortCut(Ord('R'), [ssCtrl, ssShift]);\r\n  fShortCuts[mcPlayback] := QMenus.ShortCut(Ord('P'), [ssCtrl, ssShift]);\r\n  {$ELSE}\r\n  fShortCuts[mcRecord] := Menus.ShortCut(Ord('R'), [ssCtrl, ssShift]);\r\n  fShortCuts[mcPlayback] := Menus.ShortCut(Ord('P'), [ssCtrl, ssShift]);\r\n  {$ENDIF}\r\nend;\r\n\r\nfunction TCustomSynMacroRecorder.CreateMacroEvent(aCmd: TSynEditorCommand): TSynMacroEvent;\r\n\r\n  function WantDefaultEvent(var aEvent: TSynMacroEvent): boolean;\r\n  begin\r\n    if Assigned(OnUserCommand) then\r\n      OnUserCommand(Self, aCmd, aEvent);\r\n    Result := aEvent = nil;\r\n  end;\r\n\r\nbegin\r\n  case aCmd of\r\n    ecGotoXY, ecSelGotoXY, ecSetMarker0..ecSetMarker9:\r\n      begin\r\n        Result := TSynPositionEvent.Create;\r\n        TSynPositionEvent(Result).Command := aCmd;\r\n      end;\r\n    ecChar:\r\n      Result := TSynCharEvent.Create;\r\n    ecString:\r\n      Result := TSynStringEvent.Create;\r\n    else begin\r\n      Result := nil;\r\n      if (aCmd < ecUserFirst) or WantDefaultEvent(Result) then\r\n      begin\r\n        Result := TSynBasicEvent.Create;\r\n        TSynBasicEvent(Result).Command := aCmd;\r\n      end;\r\n    end;\r\n  end;\r\nend;\r\n\r\nprocedure TCustomSynMacroRecorder.DeleteEvent(aIndex: integer);\r\nvar\r\n  iObj: Pointer;\r\nbegin\r\n  iObj := fEvents[aIndex];\r\n  fEvents.Delete(aIndex);\r\n  TObject(iObj).Free;\r\nend;\r\n\r\ndestructor TCustomSynMacroRecorder.Destroy;\r\nbegin\r\n  Clear;\r\n  inherited;\r\n  ReleasePluginCommand(PlaybackCommandID);\r\n  ReleasePluginCommand(RecordCommandID);\r\nend;\r\n\r\nprocedure TCustomSynMacroRecorder.DoAddEditor(aEditor: TCustomSynEdit);\r\nbegin\r\n  HookEditor(aEditor, RecordCommandID, 0, RecordShortCut);\r\n  HookEditor(aEditor, PlaybackCommandID, 0, PlaybackShortCut);\r\nend;\r\n\r\nprocedure TCustomSynMacroRecorder.DoRemoveEditor(aEditor: TCustomSynEdit);\r\nbegin\r\n  UnHookEditor(aEditor, RecordCommandID, RecordShortCut);\r\n  UnHookEditor(aEditor, PlaybackCommandID, PlaybackShortCut);\r\nend;\r\n\r\nprocedure TCustomSynMacroRecorder.Error(const aMsg: String);\r\nbegin\r\n  raise Exception.Create(aMsg);\r\nend;\r\n\r\nfunction TCustomSynMacroRecorder.GetEvent(aIndex: integer): TSynMacroEvent;\r\nbegin\r\n  Result := TSynMacroEvent(fEvents[aIndex]);\r\nend;\r\n\r\nfunction TCustomSynMacroRecorder.GetEventCount: integer;\r\nbegin\r\n  if fEvents = nil then\r\n    Result := 0\r\n  else\r\n    Result := fEvents.Count;\r\nend;\r\n\r\nfunction TCustomSynMacroRecorder.GetIsEmpty: boolean;\r\nbegin\r\n  Result := (fEvents = nil) or (fEvents.Count = 0);\r\nend;\r\n\r\nprocedure TCustomSynMacroRecorder.InsertCustomEvent(aIndex: integer;\r\n  aEvent: TSynMacroEvent);\r\nbegin\r\n  if fEvents = nil then\r\n    fEvents := TList.Create;\r\n  fEvents.Insert(aIndex, aEvent);\r\nend;\r\n\r\nprocedure TCustomSynMacroRecorder.InsertEvent(aIndex: integer;\r\n  aCmd: TSynEditorCommand; aChar: WideChar; aData: pointer);\r\nvar\r\n  iEvent: TSynMacroEvent;\r\nbegin\r\n  iEvent := CreateMacroEvent(aCmd);\r\n  try\r\n    iEvent.Initialize(aCmd, aChar, aData);\r\n    InsertCustomEvent(aIndex, iEvent);\r\n  except\r\n    iEvent.Free;\r\n    raise;\r\n  end;\r\nend;\r\n\r\nprocedure TCustomSynMacroRecorder.LoadFromStream(aSrc: TStream);\r\nbegin\r\n  LoadFromStreamEx(aSrc, True);\r\nend;\r\n\r\nprocedure TCustomSynMacroRecorder.LoadFromStreamEx(aSrc: TStream;\r\n  aClear: boolean);\r\nvar\r\n  iCommand: TSynEditorCommand;\r\n  iEvent: TSynMacroEvent;\r\n  cnt, i: Integer;\r\nbegin\r\n  Stop;\r\n  if aClear then\r\n    Clear;\r\n  fEvents := TList.Create;\r\n  aSrc.Read(cnt, sizeof(cnt));\r\n  i := 0;\r\n  fEvents.Capacity := aSrc.Size div SizeOf(TSynEditorCommand);\r\n  while (aSrc.Position < aSrc.Size) and (i < cnt) do\r\n  begin\r\n    aSrc.Read(iCommand, SizeOf(TSynEditorCommand));\r\n    iEvent := CreateMacroEvent(iCommand);\r\n    iEvent.Initialize(iCommand, #0, nil);\r\n    iEvent.LoadFromStream(aSrc);\r\n    fEvents.Add(iEvent);\r\n    Inc(i);\r\n  end;\r\nend;\r\n\r\n// TODO: Sender could be also something else then a TCustomSynedit(namely a TObject) but the code below assumes it is a TCustomSynedit even if Sender is of type TObject.\r\nprocedure TCustomSynMacroRecorder.OnCommand(Sender: TObject;\r\n  AfterProcessing: boolean; var Handled: boolean;\r\n  var Command: TSynEditorCommand; var aChar: WideChar; Data,\r\n  HandlerData: pointer);\r\nvar\r\n  iEvent: TSynMacroEvent;\r\nbegin\r\n  if AfterProcessing then\r\n  begin\r\n    if (Sender = fCurrentEditor) and (State = msRecording) and (not Handled) then\r\n    begin\r\n      iEvent := CreateMacroEvent(Command);\r\n      iEvent.Initialize(Command, aChar, Data);\r\n      fEvents.Add(iEvent);\r\n      if SaveMarkerPos and (Command >= ecSetMarker0) and\r\n        (Command <= ecSetMarker9) and (Data = nil) then\r\n      begin\r\n        TSynPositionEvent(iEvent).Position := fCurrentEditor.CaretXY;\r\n      end;\r\n    end;\r\n  end\r\n  else\r\n  begin\r\n    {not AfterProcessing}\r\n    case State of\r\n      msStopped:\r\n        if Command = RecordCommandID then\r\n        begin\r\n          RecordMacro(TCustomSynEdit(Sender));\r\n          Handled := True;\r\n        end\r\n        else if Command = PlaybackCommandID then\r\n        begin\r\n          PlaybackMacro(TCustomSynEdit(Sender));\r\n          Handled := True;\r\n        end;\r\n      msPlaying:\r\n        ;\r\n      msPaused:\r\n        if Command = PlaybackCommandID then\r\n        begin\r\n          Resume;\r\n          Handled := True;\r\n        end;\r\n      msRecording:\r\n        if Command = PlaybackCommandID then\r\n        begin\r\n          Pause;\r\n          Handled := True;\r\n        end\r\n        else if Command = RecordCommandID then\r\n        begin\r\n          Stop;\r\n          Handled := True;\r\n        end;\r\n    end;\r\n  end;\r\nend;\r\n\r\nprocedure TCustomSynMacroRecorder.Pause;\r\nbegin\r\n  if State <> msRecording then\r\n    Error(sCannotPause);\r\n  fState := msPaused;\r\n  StateChanged;\r\nend;\r\n\r\nprocedure TCustomSynMacroRecorder.PlaybackMacro(aEditor: TCustomSynEdit);\r\nvar\r\n  cEvent: integer;\r\nbegin\r\n  if State <> msStopped then\r\n    Error(sCannotPlay);\r\n  fState := msPlaying;\r\n  try\r\n    StateChanged;\r\n    for cEvent := 0 to EventCount -1 do\r\n    begin\r\n      Events[cEvent].Playback(aEditor);\r\n      if State <> msPlaying then\r\n        break;\r\n    end;\r\n  finally\r\n    if State = msPlaying then\r\n    begin\r\n      fState := msStopped;\r\n      StateChanged;\r\n    end;\r\n  end;\r\nend;\r\n\r\nprocedure TCustomSynMacroRecorder.RecordMacro(aEditor: TCustomSynEdit);\r\nbegin\r\n  if fState <> msStopped then\r\n    Error(sCannotRecord);\r\n  Clear;\r\n  fEvents := TList.Create;\r\n  fEvents.Capacity := 512;\r\n  fState := msRecording;\r\n  fCurrentEditor := aEditor;\r\n  StateChanged;\r\nend;\r\n\r\nprocedure TCustomSynMacroRecorder.RemoveEditor(aEditor: TCustomSynEdit);\r\nbegin\r\n  inherited RemoveEditor(aEditor);\r\nend;\r\n\r\nprocedure TCustomSynMacroRecorder.Resume;\r\nbegin\r\n  if fState <> msPaused then\r\n    Error(sCannotResume);\r\n  fState := msRecording;\r\n  StateChanged;\r\nend;\r\n\r\nprocedure TCustomSynMacroRecorder.SaveToStream(aDest: TStream);\r\nvar\r\n  cEvent, eCnt: integer;\r\nbegin\r\n  eCnt := EventCount;\r\n  aDest.Write(eCnt, sizeof(eCnt));\r\n  for cEvent := 0 to eCnt -1 do\r\n    Events[cEvent].SaveToStream(aDest);\r\nend;\r\n\r\nprocedure TCustomSynMacroRecorder.SetShortCut(const Index: Integer;\r\n  const Value: TShortCut);\r\nvar\r\n  cEditor: integer;\r\nbegin\r\n  if fShortCuts[TSynMacroCommand(Index)] <> Value then\r\n  begin\r\n    if Assigned(fEditors) then\r\n      if Value <> 0 then\r\n      begin\r\n        for cEditor := 0 to fEditors.Count -1 do\r\n          HookEditor(Editors[cEditor], fCommandIDs[TSynMacroCommand(Index)],\r\n            fShortCuts[TSynMacroCommand(Index)], Value);\r\n      end else\r\n      begin\r\n        for cEditor := 0 to fEditors.Count -1 do\r\n          UnHookEditor(Editors[cEditor], fCommandIDs[TSynMacroCommand(Index)],\r\n            fShortCuts[TSynMacroCommand(Index)]);\r\n      end;\r\n    fShortCuts[TSynMacroCommand(Index)] := Value;\r\n  end;\r\nend;\r\n\r\nprocedure TCustomSynMacroRecorder.StateChanged;\r\nbegin\r\n  if Assigned(OnStateChange) then\r\n    OnStateChange(Self);\r\nend;\r\n\r\nprocedure TCustomSynMacroRecorder.Stop;\r\nbegin\r\n  if fState = msStopped then\r\n    Exit;\r\n  fState := msStopped;\r\n  fCurrentEditor := nil;\r\n  if fEvents.Count = 0 then\r\n    FreeAndNil(fEvents);\r\n  StateChanged;\r\nend;\r\n\r\nfunction TCustomSynMacroRecorder.GetAsString: UnicodeString;\r\nvar\r\n  i: integer;\r\n  eStr: UnicodeString;\r\nbegin\r\n  Result := 'macro ' + MacroName + #13#10 + 'begin' + #13#10;\r\n  if Assigned(fEvents) then\r\n  begin\r\n    for i := 0 to fEvents.Count -1 do\r\n    begin\r\n      eStr := Events[i].AsString;\r\n      if eStr <> '' then\r\n        Result := Result + '  '  + eStr + #13#10;\r\n    end;\r\n  end;\r\n  Result := Result + 'end';\r\nend;\r\n\r\nprocedure TCustomSynMacroRecorder.SetAsString(const Value: UnicodeString);\r\nvar\r\n  i, p, Cmd: Integer;\r\n  S: TUnicodeStrings;\r\n  cmdStr: UnicodeString;\r\n  iEvent: TSynMacroEvent;\r\nbegin\r\n  Stop;\r\n  Clear;\r\n  fEvents := TList.Create;\r\n  // process file line by line and create events\r\n  S := TUnicodeStringList.Create;\r\n  try\r\n    S.Text := Value;\r\n    for i := 0 to S.Count - 1 do\r\n    begin\r\n      cmdStr := WideTrim(S[i]);\r\n      p := Pos(' ', cmdStr);\r\n      if p = 0 then p := Length(cmdStr) + 1;\r\n      Cmd := ecNone;\r\n      if IdentToEditorCommand(Copy(cmdStr, 1, p - 1), Longint(Cmd)) then  // D2 needs type-cast\r\n      begin\r\n        Delete(cmdStr, 1, p);\r\n        iEvent := CreateMacroEvent(Cmd);\r\n        try\r\n          fEvents.Add(iEvent);\r\n          iEvent.InitEventParameters(cmdStr);\r\n        except\r\n          iEvent.Free;\r\n        end;\r\n      end;\r\n    end;\r\n  finally\r\n    S.Free;\r\n  end;\r\nend;\r\n\r\nprocedure TCustomSynMacroRecorder.LoadFromFile(aFilename: string);\r\nvar\r\n  F : TFileStream;\r\nbegin\r\n  F := TFileStream.Create(aFilename, fmOpenRead);\r\n  try\r\n    LoadFromStream(F);\r\n    MacroName := ChangeFileExt(ExtractFileName(aFilename), '');\r\n  finally\r\n    F.Free;\r\n  end;\r\nend;\r\n\r\nprocedure TCustomSynMacroRecorder.SaveToFile(aFilename: string);\r\nvar\r\n  F : TFileStream;\r\nbegin\r\n  F := TFileStream.Create(aFilename, fmCreate);\r\n  try\r\n    SaveToStream(F);\r\n  finally\r\n    F.Free;\r\n  end;\r\nend;\r\n\r\n{ TSynBasicEvent }\r\n\r\nfunction TSynBasicEvent.GetAsString: UnicodeString;\r\nvar\r\n  Ident: string;\r\nbegin\r\n  EditorCommandToIdent(Command, Ident);\r\n  Result := Ident;\r\n  if RepeatCount > 1 then\r\n    Result := Result + ' ' + IntToStr(RepeatCount);\r\nend;\r\n\r\nprocedure TSynBasicEvent.InitEventParameters(aStr: UnicodeString);\r\nbegin\r\n  // basic events have no parameters but can contain an optional repeat count\r\n  RepeatCount := StrToIntDef(WideTrim(aStr), 1);\r\nend;\r\n\r\nprocedure TSynBasicEvent.Initialize(aCmd: TSynEditorCommand; aChar: WideChar;\r\n  aData: Pointer);\r\nbegin\r\n  Command := aCmd;\r\n{$IFDEF SYN_DEVELOPMENT_CHECKS}\r\n  if (aChar <> #0) or (aData <> nil) then\r\n    raise Exception.Create('TSynBasicEvent cannot handle Char <> #0 or Data <> nil');\r\n{$ENDIF}\r\nend;\r\n\r\nprocedure TSynBasicEvent.LoadFromStream(aStream: TStream);\r\nbegin\r\n  aStream.Read(fRepeatCount, SizeOf(fRepeatCount));\r\nend;\r\n\r\nprocedure TSynBasicEvent.Playback(aEditor: TCustomSynEdit);\r\nvar\r\n  i : Integer;\r\nbegin\r\n  for i := 1 to RepeatCount do\r\n    aEditor.CommandProcessor(Command, #0, nil);\r\nend;\r\n\r\nprocedure TSynBasicEvent.SaveToStream(aStream: TStream);\r\nbegin\r\n  aStream.Write(Command, SizeOf(TSynEditorCommand));\r\n  aStream.Write(RepeatCount, SizeOf(RepeatCount));\r\nend;\r\n\r\n{ TSynCharEvent }\r\n\r\nfunction TSynCharEvent.GetAsString: UnicodeString;\r\nvar\r\n  Ident: string;\r\nbegin\r\n  EditorCommandToIdent(ecChar, Ident);\r\n  Result := Ident + ' ' + Key;\r\n  if RepeatCount > 1 then\r\n    Result := Result + ' ' + IntToStr(RepeatCount);\r\nend;\r\n\r\nprocedure TSynCharEvent.InitEventParameters(aStr: UnicodeString);\r\nbegin\r\n  // aStr should be a Key value one character in length\r\n  // with an optional repeat count whitespace separated\r\n  if Length(aStr) >= 1 then\r\n    Key := aStr[1]\r\n  else\r\n    Key := ' ';\r\n  Delete(aStr, 1, 1); // if possible delete the first character\r\n  RepeatCount := StrToIntDef(WideTrim(aStr), 1);\r\nend;\r\n\r\nprocedure TSynCharEvent.Initialize(aCmd: TSynEditorCommand; aChar: WideChar;\r\n  aData: Pointer);\r\nbegin\r\n  Key := aChar;\r\n  Assert(aData = nil);\r\nend;\r\n\r\nprocedure TSynCharEvent.LoadFromStream(aStream: TStream);\r\nbegin\r\n  aStream.Read(fKey, SizeOf(Key));\r\n  aStream.Read(fRepeatCount, SizeOf(fRepeatCount));\r\nend;\r\n\r\nprocedure TSynCharEvent.Playback(aEditor: TCustomSynEdit);\r\nvar\r\n  i: Integer;\r\nbegin\r\n  for i := 1 to RepeatCount do\r\n    aEditor.CommandProcessor(ecChar, Key, nil);\r\nend;\r\n\r\nprocedure TSynCharEvent.SaveToStream(aStream: TStream);\r\nconst\r\n  iCharCommand: TSynEditorCommand = ecChar;\r\nbegin\r\n  aStream.Write(iCharCommand, SizeOf(TSynEditorCommand));\r\n  aStream.Write(Key, SizeOf(Key));\r\n  aStream.Write(RepeatCount, SizeOf(RepeatCount));\r\nend;\r\n\r\n{ TSynPositionEvent }\r\n\r\nfunction TSynPositionEvent.GetAsString: UnicodeString;\r\nbegin\r\n  Result := inherited GetAsString;\r\n  // add position data here\r\n  Result := Result + Format(' (%d, %d)', [Position.Char, Position.Line]);\r\n  if RepeatCount > 1 then\r\n    Result := Result + ' ' + IntToStr(RepeatCount);\r\nend;\r\n\r\nprocedure TSynPositionEvent.InitEventParameters(aStr: UnicodeString);\r\nvar\r\n  i, o, c, x, y: Integer;\r\n  valStr: UnicodeString;\r\nbegin\r\n  inherited;\r\n  // aStr should be (x, y) with optional repeat count whitespace separated\r\n  aStr := WideTrim(aStr);\r\n  i := Pos(',', aStr);\r\n  o := Pos('(', aStr);\r\n  c := Pos(')', aStr);\r\n  if (not ((i = 0) or (o = 0) or (c = 0))) and\r\n     ((i > o) and (i < c)) then\r\n  begin\r\n    valStr := Copy(aStr, o + 1, i - o - 1);\r\n    x := StrToIntDef(valStr, 1);\r\n    Delete(aStr, 1, i);\r\n    aStr := WideTrim(aStr);\r\n    c := Pos(')', aStr);\r\n    valStr := Copy(aStr, 1, c - 1);\r\n    y := StrToIntDef(valStr, 1);\r\n    Position := BufferCoord(x, y);\r\n    Delete(aStr, 1, c);\r\n    aStr := WideTrim(aStr);\r\n    RepeatCount := StrToIntDef(aStr, 1);\r\n  end;\r\nend;\r\n\r\nprocedure TSynPositionEvent.Initialize(aCmd: TSynEditorCommand;\r\n  aChar: WideChar; aData: Pointer);\r\nbegin\r\n  inherited;\r\n  if aData <> nil then\r\n    Position := TBufferCoord(aData^)\r\n  else\r\n    Position := BufferCoord(0, 0);\r\nend;\r\n\r\nprocedure TSynPositionEvent.LoadFromStream(aStream: TStream);\r\nbegin\r\n  aStream.Read(fPosition, SizeOf(Position));\r\nend;\r\n\r\nprocedure TSynPositionEvent.Playback(aEditor: TCustomSynEdit);\r\nbegin\r\n  if (Position.Char <> 0) or (Position.Line <> 0) then\r\n    aEditor.CommandProcessor(Command, #0, @Position)\r\n  else\r\n    aEditor.CommandProcessor(Command, #0, nil);\r\nend;\r\n\r\nprocedure TSynPositionEvent.SaveToStream(aStream: TStream);\r\nbegin\r\n  inherited;\r\n  aStream.Write(Position, SizeOf(Position));\r\nend;\r\n\r\n{ TSynStringEvent }\r\n\r\nfunction TSynStringEvent.GetAsString: UnicodeString;\r\nvar\r\n  Ident: string;\r\nbegin\r\n  EditorCommandToIdent(ecString, Ident);\r\n  Result := Ident + ' ' + WideQuotedStr(Value, #39);\r\n  if RepeatCount > 1 then\r\n    Result := Result + ' ' + IntToStr(RepeatCount);\r\nend;\r\n\r\nprocedure TSynStringEvent.InitEventParameters(aStr: UnicodeString);\r\nvar\r\n  o, c: Integer;\r\n  valStr: UnicodeString;\r\nbegin                      \r\n  // aStr = 'test' with optional whitespace separated repeat count\r\n  o := Pos('''', aStr);\r\n  c := WideLastDelimiter('''', aStr);\r\n  valStr := Copy(aStr, o + 1, c - o - 1);\r\n  Value := UnicodeStringReplace(valStr, '''''', '''', [rfReplaceAll]);\r\n  Delete(aStr, 1, c);\r\n  RepeatCount := StrToIntDef(WideTrim(aStr), 1);\r\nend;\r\n\r\nprocedure TSynStringEvent.Initialize(aCmd: TSynEditorCommand; aChar: WideChar;\r\n  aData: Pointer);\r\nbegin\r\n  Value := UnicodeString(aData);\r\nend;\r\n\r\nprocedure TSynStringEvent.LoadFromStream(aStream: TStream);\r\nvar\r\n  l: Integer;\r\n  Buff: PWideChar;\r\nbegin\r\n  aStream.Read(l, sizeof(l));\r\n  GetMem(Buff, l * sizeof(WideChar));\r\n  try\r\n  {$IFNDEF SYN_CLX}\r\n    FillMemory(Buff, l, 0);\r\n  {$ENDIF}\r\n    aStream.Read(Buff^, l * sizeof(WideChar));\r\n    fString := Buff;\r\n  finally\r\n    FreeMem(Buff);\r\n  end;\r\n  aStream.Read(fRepeatCount, sizeof(fRepeatCount));\r\nend;\r\n\r\nprocedure TSynStringEvent.Playback(aEditor: TCustomSynEdit);\r\nvar\r\n  i, j: Integer;\r\nbegin\r\n  for j := 1 to RepeatCount do\r\n  begin\r\n//    aEditor.CommandProcessor( ecString, #0, Pointer(Value) );\r\n    // SynEdit doesn't actually support the ecString command so we convert\r\n    // it into ecChar commands\r\n    for i := 1 to Length(Value) do\r\n      aEditor.CommandProcessor(ecChar, Value[i], nil);\r\n  end;\r\nend;\r\n\r\nprocedure TSynStringEvent.SaveToStream(aStream: TStream);\r\nconst\r\n  StrCommand: TSynEditorCommand = ecString;\r\nvar\r\n  l: Integer;\r\n  Buff: PWideChar;\r\nbegin\r\n  aStream.Write(StrCommand, SizeOf(StrCommand));\r\n  l := Length(Value) + 1;\r\n  aStream.Write(l, sizeof(l));\r\n  GetMem(Buff, l * sizeof(WideChar));\r\n  try\r\n  {$IFNDEF SYN_CLX}\r\n    FillMemory(Buff, l, 0);\r\n  {$ENDIF}\r\n    WStrCopy(Buff, PWideChar(Value));\r\n    aStream.Write(Buff^, l * sizeof(WideChar));\r\n  finally\r\n    FreeMem(Buff);\r\n  end;\r\n  aStream.Write(RepeatCount, sizeof(RepeatCount));\r\nend;\r\n\r\n\r\n{ TSynMacroEvent }\r\n\r\nconstructor TSynMacroEvent.Create;\r\nbegin\r\n  inherited Create;\r\n  fRepeatCount := 1;\r\nend;\r\n\r\nend.\r\n"
  },
  {
    "path": "External/SynEdit/Source/SynMemo.pas",
    "content": "{-------------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: SynMemo.pas, released 2000-04-07.\r\nThe Original Code is based on mwCustomEdit.pas by Martin Waldenburg, part of\r\nthe mwEdit component suite.\r\nPortions created by Martin Waldenburg are Copyright (C) 1998 Martin Waldenburg.\r\nUnicode translation by Mal Hrz.\r\nAll Rights Reserved.\r\n\r\nContributors to the SynEdit and mwEdit projects are listed in the\r\nContributors.txt file.\r\n\r\nAlternatively, the contents of this file may be used under the terms of the\r\nGNU General Public License Version 2 or later (the \"GPL\"), in which case\r\nthe provisions of the GPL are applicable instead of those above.\r\nIf you wish to allow use of your version of this file only under the terms\r\nof the GPL and not to allow others to use your version of this file\r\nunder the MPL, indicate your decision by deleting the provisions above and\r\nreplace them with the notice and other provisions required by the GPL.\r\nIf you do not delete the provisions above, a recipient may use your version\r\nof this file under either the MPL or the GPL.\r\n\r\n$Id: SynMemo.pas,v 1.15.2.3 2008/09/14 16:25:03 maelh Exp $\r\n\r\nYou may retrieve the latest version of this file at the SynEdit home page,\r\nlocated at http://SynEdit.SourceForge.net\r\n\r\nKnown Issues:\r\n  - several EM_XXX messages aren't handled yet;\r\n  - EM_XXX messages aren't implemented on CLX, although this could be useful;\r\n-------------------------------------------------------------------------------}\r\n\r\n{$IFNDEF QSYNMEMO}\r\nunit SynMemo;\r\n{$ENDIF}\r\n\r\n{$I SynEdit.inc}\r\n\r\ninterface\r\n\r\nuses\r\n{$IFDEF SYN_CLX}\r\n  Qt,\r\n  Types,\r\n  QSynEdit,\r\n  QSynEditTextBuffer,\r\n  QSynEditTypes,\r\n{$ELSE}\r\n  RichEdit,\r\n  Windows,\r\n  Messages,\r\n  SynEdit,\r\n  SynEditTextBuffer,\r\n  SynEditTypes,\r\n{$ENDIF}\r\n  SysUtils,\r\n  Classes;\r\n\r\ntype\r\n  TSynMemo = class(TSynEdit)\r\n{$IFNDEF SYN_CLX}\r\n  private\r\n    // EM_XXX see winuser.h (PSDK August 2001)\r\n    procedure EMGetSel(var Message: TMessage); message EM_GETSEL;\r\n    procedure EMSetSel(var Message: TMessage); message EM_SETSEL;\r\n    //procedure EMGetRect(var Message: TMessage); message EM_GETRECT;\r\n    //procedure EMSetRect(var Message: TMessage); message EM_SETRECT;\r\n    //procedure EMSetRectnp(var Message: TMessage); message EM_SETRECTNP;\r\n    //procedure EMScroll(var Message: TMessage); message EM_SCROLL;\r\n    //procedure EMLineScroll(var Message: TMessage); message EM_LINESCROLL;\r\n    //procedure EMScrollCaret(var Message: TMessage); message EM_SCROLLCARET;\r\n    procedure EMGetModify(var Message: TMessage); message EM_GETMODIFY;\r\n    procedure EMSetModify(var Message: TMessage); message EM_SETMODIFY;\r\n    procedure EMGetLineCount(var Message: TMessage); message EM_GETLINECOUNT;\r\n    //procedure EMLineIndex(var Message: TMessage); message EM_LINEINDEX;\r\n    //procedure EMSetHandle(var Message: TMessage); message EM_SETHANDLE;\r\n    //procedure EMGetHandle(var Message: TMessage); message EM_GETHANDLE;\r\n    //procedure EMGetThumb(var Message: TMessage); message EM_GETTHUMB;\r\n    //procedure EMLineLength(var Message: TMessage); message EM_LINELENGTH;\r\n    procedure EMGetSelText(var Message: TMessage); message EM_GETSELTEXT;       //richedit.h\r\n    procedure EMReplaceSel(var Message: TMessage); message EM_REPLACESEL;\r\n    procedure EMGetLine(var Message: TMessage); message EM_GETLINE;\r\n    //procedure EMLimitText(var Message: TMessage); message EM_LIMITTEXT;\r\n    procedure EMCanUndo(var Message: TMessage); message EM_CANUNDO;\r\n    procedure EMUndo(var Message: TMessage); message EM_UNDO;\r\n    //procedure EMFmtLines(var Message: TMessage); message EM_FMTLINES;\r\n    //procedure EMLineFromChar(var Message: TMessage); message EM_LINEFROMCHAR;\r\n    //procedure EMSetTabStops(var Message: TMessage); message EM_SETTABSTOPS;\r\n    //procedure EMSetPasswordChar(var Message: TMessage); message EM_SETPASSWORDCHAR;\r\n    //procedure EMEmptyUndoBuffer(var Message: TMessage); message EM_EMPTYUNDOBUFFER;\r\n    procedure EMGetFirstVisibleLine(var Message: TMessage); message EM_GETFIRSTVISIBLELINE;\r\n    //procedure EMSetReadOnly(var Message: TMessage); message EM_SETREADONLY;\r\n    //procedure EMSetWordBreakProc(var Message: TMessage); message EM_SETWORDBREAKPROC;\r\n    //procedure EMGetWordBreakProc(var Message: TMessage); message EM_GETWORDBREAKPROC;\r\n    //procedure EMGetPasswordChar(var Message: TMessage); message EM_GETPASSWORDCHAR;\r\n    //procedure EMSetMargins(var Message: TMessage); message EM_SETMARGINS;\r\n    //procedure EMGetMargins(var Message: TMessage); message EM_GETMARGINS;\r\n    //procedure EMSetLimitText(var Message: TMessage); message EM_SETLIMITTEXT;\r\n    //procedure EMGetLimitText(var Message: TMessage); message EM_GETLIMITTEXT;\r\n    //procedure EMPosFromChar(var Message: TMessage); message EM_POSFROMCHAR;\r\n    procedure EMCharFromPos(var Message: TMessage); message EM_CHARFROMPOS;\r\n    //procedure EMSetImestatus(var Message: TMessage); message EM_SETIMESTATUS;\r\n    //procedure EMGetImestatus(var Message: TMessage); message EM_GETIMESTATUS;\r\n\r\n    // EM_XXX see richedit.h (PSDK August 2001)\r\n{\r\n    procedure EMCANPASTE(var Message: TMessage); message EM_CANPASTE;\r\n    procedure EMDISPLAYBAND(var Message: TMessage); message EM_DISPLAYBAND;\r\n    procedure EMEXGETSEL(var Message: TMessage); message EM_EXGETSEL;\r\n    procedure EMEXLIMITTEXT(var Message: TMessage); message EM_EXLIMITTEXT;\r\n    procedure EMEXLINEFROMCHAR(var Message: TMessage); message EM_EXLINEFROMCHAR;\r\n    procedure EMEXSETSEL(var Message: TMessage); message EM_EXSETSEL;\r\n    procedure EMFINDTEXT(var Message: TMessage); message EM_FINDTEXT;\r\n    procedure EMFORMATRANGE(var Message: TMessage); message EM_FORMATRANGE;\r\n    procedure EMGETCHARFORMAT(var Message: TMessage); message EM_GETCHARFORMAT;\r\n    procedure EMGETEVENTMASK(var Message: TMessage); message EM_GETEVENTMASK;\r\n    procedure EMGETOLEINTERFACE(var Message: TMessage); message EM_GETOLEINTERFACE;\r\n    procedure EMGETPARAFORMAT(var Message: TMessage); message EM_GETPARAFORMAT;\r\n    procedure EMGETSELTEXT(var Message: TMessage); message EM_GETSELTEXT;\r\n    procedure EMHIDESELECTION(var Message: TMessage); message EM_HIDESELECTION;\r\n    procedure EMPASTESPECIAL(var Message: TMessage); message EM_PASTESPECIAL;\r\n    procedure EMREQUESTRESIZE(var Message: TMessage); message EM_REQUESTRESIZE;\r\n    procedure EMSELECTIONTYPE(var Message: TMessage); message EM_SELECTIONTYPE;\r\n    procedure EMSETBKGNDCOLOR(var Message: TMessage); message EM_SETBKGNDCOLOR;\r\n    procedure EMSETCHARFORMAT(var Message: TMessage); message EM_SETCHARFORMAT;\r\n    procedure EMSETEVENTMASK(var Message: TMessage); message EM_SETEVENTMASK;\r\n    procedure EMSETOLECALLBACK(var Message: TMessage); message EM_SETOLECALLBACK;\r\n    procedure EMSETPARAFORMAT(var Message: TMessage); message EM_SETPARAFORMAT;\r\n    procedure EMSETTARGETDEVICE(var Message: TMessage); message EM_SETTARGETDEVICE;\r\n    procedure EMSTREAMIN(var Message: TMessage); message EM_STREAMIN;\r\n    procedure EMSTREAMOUT(var Message: TMessage); message EM_STREAMOUT;\r\n    procedure EMGETTEXTRANGE(var Message: TMessage); message EM_GETTEXTRANGE;\r\n    procedure EMFINDWORDBREAK(var Message: TMessage); message EM_FINDWORDBREAK;\r\n    procedure EMSETOPTIONS(var Message: TMessage); message EM_SETOPTIONS;\r\n    procedure EMGETOPTIONS(var Message: TMessage); message EM_GETOPTIONS;\r\n    procedure EMFINDTEXTEX(var Message: TMessage); message EM_FINDTEXTEX;\r\n\r\n    procedure EMGETWORDBREAKPROCEX(var Message: TMessage); message EM_GETWORDBREAKPROCEX;\r\n    procedure EMSETWORDBREAKPROCEX(var Message: TMessage); message EM_SETWORDBREAKPROCEX;\r\n\r\n    // RichEdit 2.0 messages\r\n    procedure EMSETUNDOLIMIT(var Message: TMessage); message EM_SETUNDOLIMIT;\r\n    procedure EMREDO(var Message: TMessage); message EM_REDO;\r\n    procedure EMCANREDO(var Message: TMessage); message EM_CANREDO;\r\n    procedure EMGETUNDONAME(var Message: TMessage); message EM_GETUNDONAME;\r\n    procedure EMGETREDONAME(var Message: TMessage); message EM_GETREDONAME;\r\n    procedure EMSTOPGROUPTYPING(var Message: TMessage); message EM_STOPGROUPTYPING;\r\n\r\n    procedure EMSETTEXTMODE(var Message: TMessage); message EM_SETTEXTMODE;\r\n    procedure EMGETTEXTMODE(var Message: TMessage); message EM_GETTEXTMODE;\r\n\r\n    procedure EMAUTOURLDETECT(var Message: TMessage); message EM_AUTOURLDETECT;\r\n    procedure EMGETAUTOURLDETECT(var Message: TMessage); message EM_GETAUTOURLDETECT;\r\n    procedure EMSETPALETTE(var Message: TMessage); message EM_SETPALETTE;\r\n    procedure EMGETTEXTEX(var Message: TMessage); message EM_GETTEXTEX;\r\n    procedure EMGETTEXTLENGTHEX(var Message: TMessage); message EM_GETTEXTLENGTHEX;\r\n    procedure EMSHOWSCROLLBAR(var Message: TMessage); message EM_SHOWSCROLLBAR;\r\n    procedure EMSETTEXTEX(var Message: TMessage); message EM_SETTEXTEX;\r\n\r\n    // Far East specific messages\r\n    procedure EMSETPUNCTUATION(var Message: TMessage); message EM_SETPUNCTUATION;\r\n    procedure EMGETPUNCTUATION(var Message: TMessage); message EM_GETPUNCTUATION;\r\n    procedure EMSETWORDWRAPMODE(var Message: TMessage); message EM_SETWORDWRAPMODE;\r\n    procedure EMGETWORDWRAPMODE(var Message: TMessage); message EM_GETWORDWRAPMODE;\r\n    procedure EMSETIMECOLOR(var Message: TMessage); message EM_SETIMECOLOR;\r\n    procedure EMGETIMECOLOR(var Message: TMessage); message EM_GETIMECOLOR;\r\n    procedure EMSETIMEOPTIONS(var Message: TMessage); message EM_SETIMEOPTIONS;\r\n    procedure EMGETIMEOPTIONS(var Message: TMessage); message EM_GETIMEOPTIONS;\r\n    procedure EMCONVPOSITION(var Message: TMessage); message EM_CONVPOSITION;\r\n\r\n    procedure EMSETLANGOPTIONS(var Message: TMessage); message EM_SETLANGOPTIONS;\r\n    procedure EMGETLANGOPTIONS(var Message: TMessage); message EM_GETLANGOPTIONS;\r\n    procedure EMGETIMECOMPMODE(var Message: TMessage); message EM_GETIMECOMPMODE;\r\n\r\n    procedure EMFINDTEXTW(var Message: TMessage); message EM_FINDTEXTW;\r\n    procedure EMFINDTEXTEXW(var Message: TMessage); message EM_FINDTEXTEXW;\r\n\r\n    // RE3.0 FE messages\r\n    procedure EMRECONVERSION(var Message: TMessage); message EM_RECONVERSION;\r\n    procedure EMSETIMEMODEBIAS(var Message: TMessage); message EM_SETIMEMODEBIAS;\r\n    procedure EMGETIMEMODEBIAS(var Message: TMessage); message EM_GETIMEMODEBIAS;\r\n\r\n    // BiDi specific messages\r\n    procedure EMSETBIDIOPTIONS(var Message: TMessage); message EM_SETBIDIOPTIONS;\r\n    procedure EMGETBIDIOPTIONS(var Message: TMessage); message EM_GETBIDIOPTIONS;\r\n\r\n    procedure EMSETTYPOGRAPHYOPTIONS(var Message: TMessage); message EM_SETTYPOGRAPHYOPTIONS;\r\n    procedure EMGETTYPOGRAPHYOPTIONS(var Message: TMessage); message EM_GETTYPOGRAPHYOPTIONS;\r\n\r\n    // Extended edit style specific messages\r\n    procedure EMSETEDITSTYLE(var Message: TMessage); message EM_SETEDITSTYLE;\r\n    procedure EMGETEDITSTYLE(var Message: TMessage); message EM_GETEDITSTYLE;\r\n    }\r\n{$ENDIF NOT SYN_CLX}\r\n  end;\r\n\r\nimplementation\r\n\r\nuses\r\n{$IFDEF SYN_COMPILER_18_UP}\r\n  AnsiStrings,\r\n{$ENDIF}\r\n{$IFDEF UNICODE}\r\n  WideStrUtils,\r\n{$ENDIF}\r\n{$IFDEF SYN_CLX}\r\n  QSynUnicode,\r\n  QSynEditMiscProcs;\r\n{$ELSE}\r\n  SynUnicode,\r\n  SynEditMiscProcs;\r\n{$ENDIF}\r\n\r\n{$IFNDEF SYN_CLX}\r\n\r\n{ TSynMemo }\r\n\r\n// EM_GETSEL\r\n// wParam = (WPARAM) (LPDWORD) lpdwStart;      // receives starting position\r\n// lParam = (LPARAM) (LPDWORD) lpdwEnd;        // receives ending position\r\nprocedure TSynMemo.EMGetSel(var Message: TMessage);\r\nvar\r\n  s, e: integer;\r\nbegin\r\n  s := GetSelStart;\r\n  e := GetSelEnd;\r\n  if Message.wParam <> 0 then PDWORD(Message.wParam)^ := s;\r\n  if Message.lParam <> 0 then PDWORD(Message.lParam)^ := e;\r\n  Message.Result := MakeLong(s, e)\r\nend;\r\n\r\n// EM_SETSEL\r\n// wParam = (WPARAM) (INT) nStart;             // starting position\r\n// lParam = (LPARAM) (INT) nEnd;               // ending position\r\nprocedure TSynMemo.EMSetSel(var Message: TMessage);\r\nbegin\r\n  SetSelStart(Message.wParam);\r\n  SetSelEnd(Message.lParam);\r\nend;\r\n\r\nprocedure TSynMemo.EMSetModify(var Message: TMessage);\r\nbegin\r\n  Modified := Message.wParam <> 0;\r\nend;\r\n\r\nprocedure TSynMemo.EMGetModify(var Message: TMessage);\r\nbegin\r\n  Message.Result := Integer(Modified);\r\nend;\r\n\r\nprocedure TSynMemo.EMGetLineCount(var Message: TMessage);\r\nbegin\r\n  //(WPARAM) wParam,      // not used; must be zero\r\n  //(LPARAM) lParam       // not used; must be zero\r\n  Message.Result := Lines.Count;\r\nend;\r\n\r\nprocedure TSynMemo.EMGetSelText(var Message: TMessage);\r\nbegin\r\n  if Message.lParam <> 0 then\r\n  begin\r\n    if IsWindowUnicode(Handle) then\r\n      WStrLCopy(PWideChar(Message.lParam), PWideChar(SelText), Length(SelText))\r\n    else\r\n      {$IFDEF SYN_COMPILER_18_UP}AnsiStrings.{$ENDIF}StrLCopy(PAnsiChar(Message.lParam), PAnsiChar(AnsiString(SelText)), Length(SelText));\r\n    Message.Result := Length(SelText);\r\n  end;                          \r\nend;\r\n\r\n\r\n// EM_REPLACESEL\r\n// fCanUndo = (BOOL) wParam ;                  // flag that specifies whether replacement can be undone\r\n// lpszReplace = (LPCTSTR) lParam ;            // pointer to replacement text string\r\n// see PasteFromClipboard CF_TEXT - use common function ?\r\n// or use SetSelText/SetSelTextPrimitive (no undo)\r\nprocedure TSynMemo.EMReplaceSel(var Message: TMessage);\r\nvar\r\n  StartOfBlock: TBufferCoord;\r\n  EndOfBlock: TBufferCoord;\r\nbegin\r\n  if ReadOnly then exit;\r\n  DoOnPaintTransient(ttBefore);\r\n  BeginUndoBlock;\r\n  try\r\n    if SelAvail and (Message.WParam <> 0){???} then\r\n      UndoList.AddChange(crDelete, BlockBegin, BlockEnd, SelText, SelectionMode);\r\n    StartOfBlock := BlockBegin;\r\n    EndOfBlock := BlockEnd;\r\n    BlockBegin := StartOfBlock;\r\n    BlockEnd := EndOfBlock;\r\n    LockUndo;\r\n    try\r\n      if IsWindowUnicode(Handle) then\r\n        SelText := PWideChar(Message.lParam)\r\n      else\r\n        SelText := UnicodeString(PAnsiChar(Message.lParam))\r\n    finally\r\n      UnlockUndo;\r\n    end;\r\n    if (Message.WParam <> 0){???} then begin\r\n      UndoList.AddChange(crPaste, StartOfBlock, BlockEnd, SelText, smNormal);\r\n    end;\r\n  finally\r\n    EndUndoBlock;\r\n  end;\r\n  EnsureCursorPosVisible;\r\n  // Selection should have changed...\r\n  StatusChanged([scSelection]); \r\n\r\n  DoOnPaintTransient(ttAfter);\r\nend;\r\n\r\n// wParam = line number\r\n// lParam = line string (PAnsiChar/PWideChar)\r\n// no terminating #0\r\nprocedure TSynMemo.EMGetLine(var Message: TMessage);\r\nvar\r\n  DestAnsi, SourceAnsi: PAnsiChar;\r\n  DestWide, SourceWide: PWideChar;\r\nbegin\r\n  if {$IFNDEF SYN_COMPILER_16_UP}(Message.WParam >= 0) and {$ENDIF}(Integer(Message.WParam) < Lines.Count) then\r\n  begin\r\n    if IsWindowUnicode(Handle) then\r\n    begin\r\n      DestWide := PWideChar(Message.LParam);\r\n      SourceWide := PWideChar(Lines[Message.WParam]);\r\n      WStrLCopy(DestWide, SourceWide, PWord(Message.LParam)^);\r\n      Message.Result := WStrLen(DestWide);\r\n    end\r\n    else\r\n    begin\r\n      DestAnsi := PAnsiChar(Message.LParam);\r\n      SourceAnsi := PAnsiChar(AnsiString(Lines[Message.WParam]));\r\n      {$IFDEF SYN_COMPILER_18_UP}AnsiStrings.{$ENDIF}StrLCopy(DestAnsi, SourceAnsi, PWord(Message.LParam)^);\r\n      Message.Result := {$IFDEF SYN_COMPILER_18_UP}AnsiStrings.{$ENDIF}StrLen(DestAnsi);\r\n    end\r\n  end\r\n  else\r\n    Message.Result := 0;\r\nend;\r\n\r\n//(WPARAM) wParam,    // not used; must be zero\r\n//(LPARAM) lParam     // not used; must be zero\r\nprocedure TSynMemo.EMCanUndo(var Message: TMessage);\r\nbegin\r\n  Message.Result := Integer(CanUndo);\r\nend;\r\n\r\n//(WPARAM) wParam,    // not used; must be zero\r\n//(LPARAM) lParam     // not used; must be zero\r\nprocedure TSynMemo.EMUndo(var Message: TMessage);\r\nbegin\r\n  Message.Result := Integer(CanUndo);\r\n  Undo;\r\nend;\r\n\r\n//(WPARAM) wParam,          // not used; must be zero\r\n//(LPARAM) lParam           // not used; must be zero\r\nprocedure TSynMemo.EMGetFirstVisibleLine(var Message: TMessage);\r\nbegin\r\n  Message.Result := TopLine;\r\nend;\r\n\r\n//(WPARAM) wParam,    // not used; must be zero\r\n//(LPARAM) lParam     // point coordinates\r\nprocedure TSynMemo.EMCharFromPos(var Message: TMessage);\r\nvar\r\n  vPos: TBufferCoord;\r\n  i: Integer;\r\nbegin\r\n  vPos := DisplayToBufferPos(PixelsToRowColumn(Message.LParamLo, Message.LParamHi));\r\n\r\n  Dec(vPos.Line);\r\n  if vPos.Line >= Lines.Count then \r\n    vPos.Char := 1\r\n  else if vPos.Char > Length(Lines[vPos.Line]) then\r\n    vPos.Char := Length(Lines[vPos.Line]) + 1; // ???\r\n\r\n  i := vPos.Line;\r\n  while i > 0 do\r\n  begin\r\n    dec(i);\r\n    inc(vPos.Char, Length(Lines[i]) + 2);\r\n  end;\r\n\r\n  //todo: this can't be right, CharIndex can easily overflow\r\n  Message.Result := MakeLong(vPos.Char{CharIndex}, vPos.Line{Line zero based});\r\nend;\r\n\r\n{$ENDIF}\r\n\r\nend.\r\n\r\n"
  },
  {
    "path": "External/SynEdit/Source/SynRegExpr.pas",
    "content": "{$IFNDEF QSYNREGEXPR}\r\nunit SynRegExpr;\r\n{$ENDIF}\r\n\r\n{\r\n     TRegExpr class library\r\n     Delphi Regular Expressions\r\n\r\n Copyright (c) 1999-2004 Andrey V. Sorokin, St.Petersburg, Russia\r\n\r\n You may use this software in any kind of development,\r\n including comercial, redistribute, and modify it freely,\r\n under the following restrictions :\r\n 1. This software is provided as it is, without any kind of\r\n    warranty given. Use it at Your own risk.The author is not\r\n    responsible for any consequences of use of this software.\r\n 2. The origin of this software may not be mispresented, You\r\n    must not claim that You wrote the original software. If\r\n    You use this software in any kind of product, it would be\r\n    appreciated that there in a information box, or in the\r\n    documentation would be an acknowledgement like\r\n\r\n     Partial Copyright (c) 2004 Andrey V. Sorokin\r\n                                http://RegExpStudio.com\r\n                                mailto:anso@mail.ru\r\n\r\n 3. You may not have any income from distributing this source\r\n    (or altered version of it) to other developers. When You\r\n    use this product in a comercial package, the source may\r\n    not be charged seperatly.\r\n 4. Altered versions must be plainly marked as such, and must\r\n    not be misrepresented as being the original software.\r\n 5. RegExp Studio application and all the visual components as\r\n    well as documentation is not part of the TRegExpr library\r\n    and is not free for usage.\r\n\r\n                                    mailto:anso@mail.ru\r\n                                    http://RegExpStudio.com\r\n                                    http://anso.da.ru/\r\n}\r\n\r\ninterface\r\n\r\n{$INCLUDE SynEdit.inc}\r\n\r\n// ======== Determine compiler\r\n{$IFDEF VER80} Sorry, TRegExpr is for 32-bits Delphi only. Delphi 1 is not supported (and whos really care today?!). {$ENDIF}\r\n\r\n// ======== Define base compiler options\r\n{$BOOLEVAL OFF}\r\n{$EXTENDEDSYNTAX ON}\r\n{$LONGSTRINGS ON}\r\n{$OPTIMIZATION ON}\r\n{$IFDEF SYN_COMPILER_6_UP}\r\n  {$WARN SYMBOL_PLATFORM OFF} // Suppress .Net warnings\r\n{$ENDIF}\r\n{$IFDEF SYN_COMPILER_7_UP}\r\n  {$WARN UNSAFE_CAST OFF} // Suppress .Net warnings\r\n  {$WARN UNSAFE_TYPE OFF} // Suppress .Net warnings\r\n  {$WARN UNSAFE_CODE OFF} // Suppress .Net warnings\r\n{$ENDIF}\r\n{$IFDEF FPC}\r\n  {$MODE DELPHI} // Delphi-compatible mode in FreePascal\r\n{$ENDIF}\r\n\r\n// ======== Define options for TRegExpr engine\r\n{$DEFINE SynRegUniCode} // Unicode support\r\n{$DEFINE RegExpPCodeDump} // p-code dumping (see Dump method)\r\n{$IFNDEF FPC} // the option is not supported in FreePascal\r\n {$DEFINE reRealExceptionAddr} // exceptions will point to appropriate source line, not to Error procedure\r\n{$ENDIF}\r\n{$DEFINE ComplexBraces} // support braces in complex cases\r\n{$IFNDEF SynRegUniCode} // the option applicable only for non-UniCode mode\r\n {$DEFINE UseSetOfChar} // Significant optimization by using set of char\r\n{$ENDIF}\r\n{$IFDEF UseSetOfChar}\r\n {$DEFINE UseFirstCharSet} // Fast skip between matches for r.e. that starts with determined set of chars\r\n{$ENDIF}\r\n\r\n// ======== Define Pascal-language options\r\n// Define 'UseAsserts' option (do not edit this definitions).\r\n// Asserts used to catch 'strange bugs' in TRegExpr implementation (when something goes\r\n// completely wrong). You can swith asserts on/off with help of {$C+}/{$C-} compiler options.\r\n{$IFDEF SYN_COMPILER_3_UP} {$DEFINE UseAsserts} {$ENDIF}\r\n{$IFDEF FPC} {$DEFINE UseAsserts} {$ENDIF}\r\n\r\n// Define 'use subroutine parameters default values' option (do not edit this definition).\r\n{$IFDEF SYN_COMPILER_4_UP} {$DEFINE DefParam} {$ENDIF}\r\n\r\n// Define 'OverMeth' options, to use method overloading (do not edit this definitions).\r\n{$IFDEF SYN_COMPILER_5_UP} {$DEFINE OverMeth} {$ENDIF}\r\n{$IFDEF FPC} {$DEFINE OverMeth} {$ENDIF}\r\n\r\nuses\r\n{$IFDEF SYN_CLX}\r\n  QSynUnicode,\r\n{$ELSE}\r\n  SynUnicode,\r\n{$ENDIF}\r\n Classes,  // TStrings in Split method\r\n SysUtils; // Exception\r\n\r\ntype\r\n {$IFDEF SynRegUniCode}\r\n PRegExprChar = PWideChar;\r\n RegExprString = UnicodeString;\r\n REChar = WideChar;\r\n {$ELSE}\r\n PRegExprChar = PChar;\r\n RegExprString = AnsiString; //###0.952 was string\r\n REChar = Char;\r\n {$ENDIF}\r\n TREOp = REChar; // internal p-code type //###0.933\r\n PREOp = ^TREOp;\r\n TRENextOff = integer; // internal Next \"pointer\" (offset to current p-code) //###0.933\r\n PRENextOff = ^TRENextOff; // used for extracting Next \"pointers\" from compiled r.e. //###0.933\r\n TREBracesArg = integer; // type of {m,n} arguments\r\n PREBracesArg = ^TREBracesArg;\r\n\r\nconst\r\n REOpSz = SizeOf (TREOp) div SizeOf (REChar); // size of p-code in RegExprString units\r\n RENextOffSz = SizeOf (TRENextOff) div SizeOf (REChar); // size of Next 'pointer' -\"-\r\n REBracesArgSz = SizeOf (TREBracesArg) div SizeOf (REChar); // size of BRACES arguments -\"-\r\n\r\ntype\r\n TRegExprInvertCaseFunction = function (const Ch : REChar) : REChar\r\n                               of object;\r\n\r\nconst\r\n  EscChar = '\\'; // 'Escape'-char ('\\' in common r.e.) used for escaping metachars (\\w, \\d etc).\r\n  RegExprModifierI : boolean = False;    // default value for ModifierI\r\n  RegExprModifierR : boolean = True;     // default value for ModifierR\r\n  RegExprModifierS : boolean = True;     // default value for ModifierS\r\n  RegExprModifierG : boolean = True;     // default value for ModifierG\r\n  RegExprModifierM : boolean = False;    // default value for ModifierM\r\n  RegExprModifierX : boolean = False;    // default value for ModifierX\r\n  RegExprSpaceChars : RegExprString =    // default value for SpaceChars\r\n  ' '#$9#$A#$D#$C;\r\n  RegExprWordChars : RegExprString =     // default value for WordChars\r\n    '0123456789' //###0.940\r\n  + 'abcdefghijklmnopqrstuvwxyz'\r\n  + 'ABCDEFGHIJKLMNOPQRSTUVWXYZ_';\r\n  RegExprLineSeparators : RegExprString =// default value for LineSeparators\r\n   #$d#$a{$IFDEF SynRegUniCode}+#$b#$c#$2028#$2029#$85{$ENDIF}; //###0.947\r\n  RegExprLinePairedSeparator : RegExprString =// default value for LinePairedSeparator\r\n   #$d#$a;\r\n  { if You need Unix-styled line separators (only \\n), then use:\r\n  RegExprLineSeparators = #$a;\r\n  RegExprLinePairedSeparator = '';\r\n  }\r\n\r\n\r\nconst\r\n NSUBEXP = 15; // max number of subexpression //###0.929\r\n // Cannot be more than NSUBEXPMAX\r\n // Be carefull - don't use values which overflow CLOSE opcode\r\n // (in this case you'll get compiler erorr).\r\n // Big NSUBEXP will cause more slow work and more stack required\r\n NSUBEXPMAX = 255; // Max possible value for NSUBEXP. //###0.945\r\n // Don't change it! It's defined by internal TRegExpr design.\r\n\r\n MaxBracesArg = $7FFFFFFF - 1; // max value for {n,m} arguments //###0.933\r\n\r\n {$IFDEF ComplexBraces}\r\n LoopStackMax = 10; // max depth of loops stack //###0.925\r\n {$ENDIF}\r\n\r\n TinySetLen = 3;\r\n // if range includes more then TinySetLen chars, //###0.934\r\n // then use full (32 bytes) ANYOFFULL instead of ANYOF[BUT]TINYSET\r\n // !!! Attension ! If you change TinySetLen, you must\r\n // change code marked as \"//!!!TinySet\"\r\n\r\n\r\ntype\r\n\r\n{$IFDEF UseSetOfChar}\r\n PSetOfREChar = ^TSetOfREChar;\r\n TSetOfREChar = set of REChar;\r\n{$ENDIF}\r\n\r\n TRegExpr = class;\r\n\r\n TRegExprReplaceFunction = function (ARegExpr : TRegExpr): string\r\n                               of object;\r\n\r\n TRegExpr = class\r\n   private\r\n    startp : array [0 .. NSUBEXP - 1] of PRegExprChar; // founded expr starting points\r\n    endp : array [0 .. NSUBEXP - 1] of PRegExprChar; // founded expr end points\r\n\r\n    {$IFDEF ComplexBraces}\r\n    LoopStack : array [1 .. LoopStackMax] of integer; // state before entering loop\r\n    LoopStackIdx : integer; // 0 - out of all loops\r\n    {$ENDIF}\r\n\r\n    // The \"internal use only\" fields to pass info from compile\r\n    // to execute that permits the execute phase to run lots faster on\r\n    // simple cases.\r\n    regstart : REChar; // char that must begin a match; '\\0' if none obvious\r\n    reganch : REChar; // is the match anchored (at beginning-of-line only)?\r\n    regmust : PRegExprChar; // string (pointer into program) that match must include, or nil\r\n    regmlen : integer; // length of regmust string\r\n    // Regstart and reganch permit very fast decisions on suitable starting points\r\n    // for a match, cutting down the work a lot.  Regmust permits fast rejection\r\n    // of lines that cannot possibly match.  The regmust tests are costly enough\r\n    // that regcomp() supplies a regmust only if the r.e. contains something\r\n    // potentially expensive (at present, the only such thing detected is * or +\r\n    // at the start of the r.e., which can involve a lot of backup).  Regmlen is\r\n    // supplied because the test in regexec() needs it and regcomp() is computing\r\n    // it anyway.\r\n    {$IFDEF UseFirstCharSet} //###0.929\r\n    FirstCharSet : TSetOfREChar;\r\n    {$ENDIF}\r\n\r\n    // work variables for Exec's routins - save stack in recursion}\r\n    reginput : PRegExprChar; // String-input pointer.\r\n    fInputStart : PRegExprChar; // Pointer to first char of input string.\r\n    fInputEnd : PRegExprChar; // Pointer to char AFTER last char of input string\r\n\r\n    // work variables for compiler's routines\r\n    regparse : PRegExprChar;  // Input-scan pointer.\r\n    regnpar : integer; // count.\r\n    regdummy : REChar;\r\n    regcode : PRegExprChar;   // Code-emit pointer; @regdummy = don't.\r\n    regsize : integer; // Code size.\r\n\r\n    regexpbeg : PRegExprChar; // only for error handling. Contains\r\n    // pointer to beginning of r.e. while compiling\r\n    fExprIsCompiled : boolean; // true if r.e. successfully compiled\r\n\r\n    // programm is essentially a linear encoding\r\n    // of a nondeterministic finite-state machine (aka syntax charts or\r\n    // \"railroad normal form\" in parsing technology).  Each node is an opcode\r\n    // plus a \"next\" pointer, possibly plus an operand.  \"Next\" pointers of\r\n    // all nodes except BRANCH implement concatenation; a \"next\" pointer with\r\n    // a BRANCH on both ends of it is connecting two alternatives.  (Here we\r\n    // have one of the subtle syntax dependencies:  an individual BRANCH (as\r\n    // opposed to a collection of them) is never concatenated with anything\r\n    // because of operator precedence.)  The operand of some types of node is\r\n    // a literal string; for others, it is a node leading into a sub-FSM.  In\r\n    // particular, the operand of a BRANCH node is the first node of the branch.\r\n    // (NB this is *not* a tree structure:  the tail of the branch connects\r\n    // to the thing following the set of BRANCHes.)  The opcodes are:\r\n    programm : PRegExprChar; // Unwarranted chumminess with compiler.\r\n\r\n    fExpression : PRegExprChar; // source of compiled r.e.\r\n    fInputString : PRegExprChar; // input string\r\n\r\n    fLastError : integer; // see Error, LastError\r\n\r\n    fModifiers : integer; // modifiers\r\n    fCompModifiers : integer; // compiler's copy of modifiers\r\n    fProgModifiers : integer; // modifiers values from last programm compilation\r\n\r\n    fSpaceChars : RegExprString; //###0.927\r\n    fWordChars : RegExprString; //###0.929\r\n    fInvertCase : TRegExprInvertCaseFunction; //###0.927\r\n\r\n    fLineSeparators : RegExprString; //###0.941\r\n    fLinePairedSeparatorAssigned : boolean;\r\n    fLinePairedSeparatorHead,\r\n    fLinePairedSeparatorTail : REChar;\r\n    {$IFNDEF SynRegUniCode}\r\n    fLineSeparatorsSet : set of REChar;\r\n    {$ENDIF}\r\n\r\n    procedure InvalidateProgramm;\r\n    // Mark programm as have to be [re]compiled\r\n\r\n    function IsProgrammOk : boolean; //###0.941\r\n    // Check if we can use precompiled r.e. or\r\n    // [re]compile it if something changed\r\n\r\n    function GetExpression : RegExprString;\r\n    procedure SetExpression (const s : RegExprString);\r\n\r\n    function GetModifierStr : RegExprString;\r\n    class function ParseModifiersStr (const AModifiers : RegExprString;\r\n      var AModifiersInt : integer) : boolean; //###0.941 class function now\r\n    // Parse AModifiers string and return true and set AModifiersInt\r\n    // if it's in format 'ismxrg-ismxrg'.\r\n    procedure SetModifierStr (const AModifiers : RegExprString);\r\n\r\n    function GetModifier (AIndex : integer) : boolean;\r\n    procedure SetModifier (AIndex : integer; ASet : boolean);\r\n\r\n    procedure Error (AErrorID : integer); virtual; // error handler.\r\n    // Default handler raise exception ERegExpr with\r\n    // Message = ErrorMsg (AErrorID), ErrorCode = AErrorID\r\n    // and CompilerErrorPos = value of property CompilerErrorPos.\r\n\r\n\r\n    {==================== Compiler section ===================}\r\n    function CompileRegExpr (exp : PRegExprChar) : boolean;\r\n    // compile a regular expression into internal code\r\n\r\n    procedure Tail (p : PRegExprChar; val : PRegExprChar);\r\n    // set the next-pointer at the end of a node chain\r\n\r\n    procedure OpTail (p : PRegExprChar; val : PRegExprChar);\r\n    // regoptail - regtail on operand of first argument; nop if operandless\r\n\r\n    function EmitNode (op : TREOp) : PRegExprChar;\r\n    // regnode - emit a node, return location\r\n\r\n    procedure EmitC (b : REChar);\r\n    // emit (if appropriate) a byte of code\r\n\r\n    procedure InsertOperator (op : TREOp; opnd : PRegExprChar; sz : integer); //###0.90\r\n    // insert an operator in front of already-emitted operand\r\n    // Means relocating the operand.\r\n\r\n    function ParseReg (paren : integer; var flagp : integer) : PRegExprChar;\r\n    // regular expression, i.e. main body or parenthesized thing\r\n\r\n    function ParseBranch (var flagp : integer) : PRegExprChar;\r\n    // one alternative of an | operator\r\n\r\n    function ParsePiece (var flagp : integer) : PRegExprChar;\r\n    // something followed by possible [*+?]\r\n\r\n    function ParseAtom (var flagp : integer) : PRegExprChar;\r\n    // the lowest level\r\n\r\n    function GetCompilerErrorPos : integer;\r\n    // current pos in r.e. - for error hanling\r\n\r\n    {$IFDEF UseFirstCharSet} //###0.929\r\n    procedure FillFirstCharSet (prog : PRegExprChar);\r\n    {$ENDIF}\r\n\r\n    {===================== Mathing section ===================}\r\n    function regrepeat (p : PRegExprChar; AMax : integer) : integer;\r\n    // repeatedly match something simple, report how many\r\n\r\n    function regnext (p : PRegExprChar) : PRegExprChar;\r\n    // dig the \"next\" pointer out of a node\r\n\r\n    function MatchPrim (prog : PRegExprChar) : boolean;\r\n    // recursively matching routine\r\n\r\n    function ExecPrim (AOffset: integer) : boolean;\r\n    // Exec for stored InputString\r\n\r\n    {$IFDEF RegExpPCodeDump}\r\n    function DumpOp (op : REChar) : RegExprString;\r\n    {$ENDIF}\r\n\r\n    function GetSubExprMatchCount : integer;\r\n    function GetMatchPos (Idx : integer) : integer;\r\n    function GetMatchLen (Idx : integer) : integer;\r\n    function GetMatch (Idx : integer) : RegExprString;\r\n\r\n    function GetInputString : RegExprString;\r\n    procedure SetInputString (const AInputString : RegExprString);\r\n\r\n    {$IFNDEF UseSetOfChar}\r\n    function StrScanCI (s : PRegExprChar; ch : REChar) : PRegExprChar; //###0.928\r\n    {$ENDIF}\r\n\r\n    procedure SetLineSeparators (const AStr : RegExprString);\r\n    procedure SetLinePairedSeparator (const AStr : RegExprString);\r\n    function GetLinePairedSeparator : RegExprString;\r\n\r\n   public\r\n    constructor Create;\r\n    destructor Destroy; override;\r\n\r\n    class function VersionMajor : integer; //###0.944\r\n    class function VersionMinor : integer; //###0.944\r\n\r\n    property Expression : RegExprString read GetExpression write SetExpression;\r\n    // Regular expression.\r\n    // For optimization, TRegExpr will automatically compiles it into 'P-code'\r\n    // (You can see it with help of Dump method) and stores in internal\r\n    // structures. Real [re]compilation occures only when it really needed -\r\n    // while calling Exec[Next], Substitute, Dump, etc\r\n    // and only if Expression or other P-code affected properties was changed\r\n    // after last [re]compilation.\r\n    // If any errors while [re]compilation occures, Error method is called\r\n    // (by default Error raises exception - see below)\r\n\r\n    property ModifierStr : RegExprString read GetModifierStr write SetModifierStr;\r\n    // Set/get default values of r.e.syntax modifiers. Modifiers in\r\n    // r.e. (?ismx-ismx) will replace this default values.\r\n    // If you try to set unsupported modifier, Error will be called\r\n    // (by defaul Error raises exception ERegExpr).\r\n\r\n    property ModifierI : boolean index 1 read GetModifier write SetModifier;\r\n    // Modifier /i - caseinsensitive, initialized from RegExprModifierI\r\n\r\n    property ModifierR : boolean index 2 read GetModifier write SetModifier;\r\n    // Modifier /r - use r.e.syntax extended for russian,\r\n    // (was property ExtSyntaxEnabled in previous versions)\r\n    // If true, then -  additional include russian letter '',\r\n    // -  additional include '', and - include all russian symbols.\r\n    // You have to turn it off if it may interfere with you national alphabet.\r\n    // , initialized from RegExprModifierR\r\n\r\n    property ModifierS : boolean index 3 read GetModifier write SetModifier;\r\n    // Modifier /s - '.' works as any char (else as [^\\n]),\r\n    // , initialized from RegExprModifierS\r\n\r\n    property ModifierG : boolean index 4 read GetModifier write SetModifier;\r\n    // Switching off modifier /g switchs all operators in\r\n    // non-greedy style, so if ModifierG = False, then\r\n    // all '*' works as '*?', all '+' as '+?' and so on.\r\n    // , initialized from RegExprModifierG\r\n\r\n    property ModifierM : boolean index 5 read GetModifier write SetModifier;\r\n    // Treat string as multiple lines. That is, change `^' and `$' from\r\n    // matching at only the very start or end of the string to the start\r\n    // or end of any line anywhere within the string.\r\n    // , initialized from RegExprModifierM\r\n\r\n    property ModifierX : boolean index 6 read GetModifier write SetModifier;\r\n    // Modifier /x - eXtended syntax, allow r.e. text formatting,\r\n    // see description in the help. Initialized from RegExprModifierX\r\n\r\n    function Exec (const AInputString : RegExprString) : boolean; {$IFDEF OverMeth} overload;\r\n    {$IFNDEF FPC} // I do not know why FreePascal cannot overload methods with empty param list\r\n    function Exec : boolean; overload; //###0.949\r\n    {$ENDIF}\r\n    function Exec (AOffset: integer) : boolean; overload; //###0.949\r\n    {$ENDIF}\r\n    // match a programm against a string AInputString\r\n    // !!! Exec store AInputString into InputString property\r\n    // For Delphi 5 and higher available overloaded versions - first without\r\n    // parameter (uses already assigned to InputString property value)\r\n    // and second that has integer parameter and is same as ExecPos\r\n\r\n    function ExecNext : boolean;\r\n    // find next match:\r\n    //    ExecNext;\r\n    // works same as\r\n    //    if MatchLen [0] = 0 then ExecPos (MatchPos [0] + 1)\r\n    //     else ExecPos (MatchPos [0] + MatchLen [0]);\r\n    // but it's more simpler !\r\n    // Raises exception if used without preceeding SUCCESSFUL call to\r\n    // Exec* (Exec, ExecPos, ExecNext). So You always must use something like\r\n    // if Exec (InputString) then repeat { proceed results} until not ExecNext;\r\n\r\n    function ExecPos (AOffset: integer {$IFDEF DefParam}= 1{$ENDIF}) : boolean;\r\n    // find match for InputString starting from AOffset position\r\n    // (AOffset=1 - first char of InputString)\r\n\r\n    property InputString : RegExprString read GetInputString write SetInputString;\r\n    // returns current input string (from last Exec call or last assign\r\n    // to this property).\r\n    // Any assignment to this property clear Match* properties !\r\n\r\n    function Substitute (const ATemplate : RegExprString) : RegExprString;\r\n    // Returns ATemplate with '$&' or '$0' replaced by whole r.e.\r\n    // occurence and '$n' replaced by occurence of subexpression #n.\r\n    // Since v.0.929 '$' used instead of '\\' (for future extensions\r\n    // and for more Perl-compatibility) and accept more then one digit.\r\n    // If you want place into template raw '$' or '\\', use prefix '\\'\r\n    // Example: '1\\$ is $2\\\\rub\\\\' -> '1$ is \\rub\\'\r\n    // If you want to place raw digit after '$n' you must delimit\r\n    // n with curly braces '{}'.\r\n    // Example: 'a$12bc' -> 'abc'\r\n    // 'a${1}2bc' -> 'a2bc'.\r\n\r\n    procedure Split (AInputStr : RegExprString; APieces : TStrings);\r\n    // Split AInputStr into APieces by r.e. occurencies\r\n    // Internally calls Exec[Next]\r\n\r\n    function Replace (AInputStr : RegExprString;\r\n      const AReplaceStr : RegExprString;\r\n      AUseSubstitution : boolean{$IFDEF DefParam}= False{$ENDIF}) //###0.946\r\n     : RegExprString; {$IFDEF OverMeth} overload;\r\n    function Replace (AInputStr : RegExprString;\r\n      AReplaceFunc : TRegExprReplaceFunction)\r\n     : RegExprString; overload;\r\n    {$ENDIF}\r\n    function ReplaceEx (AInputStr : RegExprString;\r\n      AReplaceFunc : TRegExprReplaceFunction)\r\n     : RegExprString;\r\n    // Returns AInputStr with r.e. occurencies replaced by AReplaceStr\r\n    // If AUseSubstitution is true, then AReplaceStr will be used\r\n    // as template for Substitution methods.\r\n    // For example:\r\n    //  Expression := '({-i}block|var)\\s*\\(\\s*([^ ]*)\\s*\\)\\s*';\r\n    //  Replace ('BLOCK( test1)', 'def \"$1\" value \"$2\"', True);\r\n    //   will return:  def 'BLOCK' value 'test1'\r\n    //  Replace ('BLOCK( test1)', 'def \"$1\" value \"$2\"')\r\n    //   will return:  def \"$1\" value \"$2\"\r\n    // Internally calls Exec[Next]\r\n    // Overloaded version and ReplaceEx operate with call-back function,\r\n    // so You can implement really complex functionality.\r\n\r\n    property SubExprMatchCount : integer read GetSubExprMatchCount;\r\n    // Number of subexpressions has been found in last Exec* call.\r\n    // If there are no subexpr. but whole expr was found (Exec* returned True),\r\n    // then SubExprMatchCount=0, if no subexpressions nor whole\r\n    // r.e. found (Exec* returned false) then SubExprMatchCount=-1.\r\n    // Note, that some subexpr. may be not found and for such\r\n    // subexpr. MathPos=MatchLen=-1 and Match=''.\r\n    // For example: Expression := '(1)?2(3)?';\r\n    //  Exec ('123'): SubExprMatchCount=2, Match[0]='123', [1]='1', [2]='3'\r\n    //  Exec ('12'): SubExprMatchCount=1, Match[0]='12', [1]='1'\r\n    //  Exec ('23'): SubExprMatchCount=2, Match[0]='23', [1]='', [2]='3'\r\n    //  Exec ('2'): SubExprMatchCount=0, Match[0]='2'\r\n    //  Exec ('7') - return False: SubExprMatchCount=-1\r\n\r\n    property MatchPos [Idx : integer] : integer read GetMatchPos;\r\n    // pos of entrance subexpr. #Idx into tested in last Exec*\r\n    // string. First subexpr. have Idx=1, last - MatchCount,\r\n    // whole r.e. have Idx=0.\r\n    // Returns -1 if in r.e. no such subexpr. or this subexpr.\r\n    // not found in input string.\r\n\r\n    property MatchLen [Idx : integer] : integer read GetMatchLen;\r\n    // len of entrance subexpr. #Idx r.e. into tested in last Exec*\r\n    // string. First subexpr. have Idx=1, last - MatchCount,\r\n    // whole r.e. have Idx=0.\r\n    // Returns -1 if in r.e. no such subexpr. or this subexpr.\r\n    // not found in input string.\r\n    // Remember - MatchLen may be 0 (if r.e. match empty string) !\r\n\r\n    property Match [Idx : integer] : RegExprString read GetMatch;\r\n    // == copy (InputString, MatchPos [Idx], MatchLen [Idx])\r\n    // Returns '' if in r.e. no such subexpr. or this subexpr.\r\n    // not found in input string.\r\n\r\n    function LastError : integer;\r\n    // Returns ID of last error, 0 if no errors (unusable if\r\n    // Error method raises exception) and clear internal status\r\n    // into 0 (no errors).\r\n\r\n    function ErrorMsg (AErrorID : integer) : RegExprString; virtual;\r\n    // Returns Error message for error with ID = AErrorID.\r\n\r\n    property CompilerErrorPos : integer read GetCompilerErrorPos;\r\n    // Returns pos in r.e. there compiler stopped.\r\n    // Usefull for error diagnostics\r\n\r\n    property SpaceChars : RegExprString read fSpaceChars write fSpaceChars; //###0.927\r\n    // Contains chars, treated as /s (initially filled with RegExprSpaceChars\r\n    // global constant)\r\n\r\n    property WordChars : RegExprString read fWordChars write fWordChars; //###0.929\r\n    // Contains chars, treated as /w (initially filled with RegExprWordChars\r\n    // global constant)\r\n\r\n    property LineSeparators : RegExprString read fLineSeparators write SetLineSeparators; //###0.941\r\n    // line separators (like \\n in Unix)\r\n\r\n    property LinePairedSeparator : RegExprString read GetLinePairedSeparator write SetLinePairedSeparator; //###0.941\r\n    // paired line separator (like \\r\\n in DOS and Windows).\r\n    // must contain exactly two chars or no chars at all\r\n\r\n    class function InvertCaseFunction  (const Ch : REChar) : REChar;\r\n    // Converts Ch into upper case if it in lower case or in lower\r\n    // if it in upper (uses current system local setings)\r\n\r\n    property InvertCase : TRegExprInvertCaseFunction read fInvertCase write fInvertCase; //##0.935\r\n    // Set this property if you want to override case-insensitive functionality.\r\n    // Create set it to RegExprInvertCaseFunction (InvertCaseFunction by default)\r\n\r\n    procedure Compile; //###0.941\r\n    // [Re]compile r.e. Usefull for example for GUI r.e. editors (to check\r\n    // all properties validity).\r\n\r\n    {$IFDEF RegExpPCodeDump}\r\n    function Dump : RegExprString;\r\n    // dump a compiled regexp in vaguely comprehensible form\r\n    {$ENDIF}\r\n  end;\r\n\r\n ERegExpr = class (Exception)\r\n   public\r\n    ErrorCode : integer;\r\n    CompilerErrorPos : integer;\r\n  end;\r\n\r\nconst\r\n  RegExprInvertCaseFunction : TRegExprInvertCaseFunction = {$IFDEF FPC} nil {$ELSE} TRegExpr.InvertCaseFunction{$ENDIF};\r\n  // defaul for InvertCase property\r\n\r\nfunction ExecRegExpr (const ARegExpr, AInputStr : RegExprString) : boolean;\r\n// true if string AInputString match regular expression ARegExpr\r\n// ! will raise exeption if syntax errors in ARegExpr\r\n\r\nprocedure SplitRegExpr (const ARegExpr, AInputStr : RegExprString; APieces : TStrings);\r\n// Split AInputStr into APieces by r.e. ARegExpr occurencies\r\n\r\nfunction ReplaceRegExpr (const ARegExpr, AInputStr, AReplaceStr : RegExprString;\r\n      AUseSubstitution : boolean{$IFDEF DefParam}= False{$ENDIF}) : RegExprString; //###0.947\r\n// Returns AInputStr with r.e. occurencies replaced by AReplaceStr\r\n// If AUseSubstitution is true, then AReplaceStr will be used\r\n// as template for Substitution methods.\r\n// For example:\r\n//  ReplaceRegExpr ('({-i}block|var)\\s*\\(\\s*([^ ]*)\\s*\\)\\s*',\r\n//   'BLOCK( test1)', 'def \"$1\" value \"$2\"', True)\r\n//  will return:  def 'BLOCK' value 'test1'\r\n//  ReplaceRegExpr ('({-i}block|var)\\s*\\(\\s*([^ ]*)\\s*\\)\\s*',\r\n//   'BLOCK( test1)', 'def \"$1\" value \"$2\"')\r\n//   will return:  def \"$1\" value \"$2\"\r\n\r\nfunction QuoteRegExprMetaChars (const AStr : RegExprString) : RegExprString;\r\n// Replace all metachars with its safe representation,\r\n// for example 'abc$cd.(' converts into 'abc\\$cd\\.\\('\r\n// This function usefull for r.e. autogeneration from\r\n// user input\r\n\r\nfunction RegExprSubExpressions (const ARegExpr : string;\r\n ASubExprs : TStrings; AExtendedSyntax : boolean{$IFDEF DefParam}= False{$ENDIF}) : integer;\r\n// Makes list of subexpressions found in ARegExpr r.e.\r\n// In ASubExps every item represent subexpression,\r\n// from first to last, in format:\r\n//  String - subexpression text (without '()')\r\n//  low word of Object - starting position in ARegExpr, including '('\r\n//   if exists! (first position is 1)\r\n//  high word of Object - length, including starting '(' and ending ')'\r\n//   if exist!\r\n// AExtendedSyntax - must be True if modifier /m will be On while\r\n// using the r.e.\r\n// Usefull for GUI editors of r.e. etc (You can find example of using\r\n// in TestRExp.dpr project)\r\n// Returns\r\n//  0      Success. No unbalanced brackets was found;\r\n//  -1     There are not enough closing brackets ')';\r\n//  -(n+1) At position n was found opening '[' without  //###0.942\r\n//         corresponding closing ']';\r\n//  n      At position n was found closing bracket ')' without\r\n//         corresponding opening '('.\r\n// If Result <> 0, then ASubExpr can contain empty items or illegal ones\r\n\r\n\r\nimplementation\r\n\r\nuses\r\n{$IFDEF SYN_WIN32}\r\n Windows; // CharUpper/Lower\r\n{$ELSE}\r\n  Libc; //Qt.pas from Borland does not expose char handling functions\r\n{$ENDIF}\r\n\r\nconst\r\n TRegExprVersionMajor : integer = 0;\r\n TRegExprVersionMinor : integer = 952;\r\n // TRegExpr.VersionMajor/Minor return values of this constants\r\n\r\n MaskModI = 1;  // modifier /i bit in fModifiers\r\n MaskModR = 2;  // -\"- /r\r\n MaskModS = 4;  // -\"- /s\r\n MaskModG = 8;  // -\"- /g\r\n MaskModM = 16; // -\"- /m\r\n MaskModX = 32; // -\"- /x\r\n\r\n {$IFDEF SynRegUniCode}\r\n XIgnoredChars = ' '#9#$d#$a;\r\n {$ELSE}\r\n XIgnoredChars = [' ', #9, #$d, #$a];\r\n {$ENDIF}\r\n\r\n{=============================================================}\r\n{=================== UnicodeString functions ====================}\r\n{=============================================================}\r\n\r\n{$IFDEF SynRegUniCode}\r\n\r\nfunction StrPCopy (Dest: PRegExprChar; const Source: RegExprString): PRegExprChar;\r\n var\r\n  i, Len : Integer;\r\n begin\r\n  Len := length (Source); //###0.932\r\n  for i := 1 to Len do\r\n   Dest [i - 1] := Source [i];\r\n  Dest [Len] := #0;\r\n  Result := Dest;\r\n end; { of function StrPCopy\r\n--------------------------------------------------------------}\r\n\r\nfunction StrLCopy (Dest, Source: PRegExprChar; MaxLen: Cardinal): PRegExprChar;\r\n var i: Integer;\r\n begin\r\n  for i := 0 to MaxLen - 1 do\r\n   Dest [i] := Source [i];\r\n  Result := Dest;\r\n end; { of function StrLCopy\r\n--------------------------------------------------------------}\r\n\r\nfunction StrLen (Str: PRegExprChar): Cardinal;\r\n begin\r\n  Result:=0;\r\n  while Str [result] <> #0\r\n   do Inc (Result);\r\n end; { of function StrLen\r\n--------------------------------------------------------------}\r\n\r\nfunction StrPos (Str1, Str2: PRegExprChar): PRegExprChar;\r\n var n: Integer;\r\n begin\r\n  Result := nil;\r\n  n := Pos (RegExprString (Str2), RegExprString (Str1));\r\n  if n = 0\r\n   then EXIT;\r\n  Result := Str1 + n - 1;\r\n end; { of function StrPos\r\n--------------------------------------------------------------}\r\n\r\nfunction StrLComp (Str1, Str2: PRegExprChar; MaxLen: Cardinal): Integer;\r\n var S1, S2: RegExprString;\r\n begin\r\n  S1 := Str1;\r\n  S2 := Str2;\r\n  if Copy (S1, 1, MaxLen) > Copy (S2, 1, MaxLen)\r\n   then Result := 1\r\n   else\r\n    if Copy (S1, 1, MaxLen) < Copy (S2, 1, MaxLen)\r\n     then Result := -1\r\n     else Result := 0;\r\n end; { function StrLComp\r\n--------------------------------------------------------------}\r\n\r\nfunction StrScan (Str: PRegExprChar; Chr: WideChar): PRegExprChar;\r\n begin\r\n  Result := nil;\r\n  while (Str^ <> #0) and (Str^ <> Chr)\r\n   do Inc (Str);\r\n  if (Str^ <> #0)\r\n   then Result := Str;\r\n end; { of function StrScan\r\n--------------------------------------------------------------}\r\n\r\n{$ENDIF}\r\n\r\n\r\n{=============================================================}\r\n{===================== Global functions ======================}\r\n{=============================================================}\r\n\r\nfunction ExecRegExpr (const ARegExpr, AInputStr : RegExprString) : boolean;\r\n var r : TRegExpr;\r\n begin\r\n  r := TRegExpr.Create;\r\n  try\r\n    r.Expression := ARegExpr;\r\n    Result := r.Exec (AInputStr);\r\n    finally r.Free;\r\n   end;\r\n end; { of function ExecRegExpr\r\n--------------------------------------------------------------}\r\n\r\nprocedure SplitRegExpr (const ARegExpr, AInputStr : RegExprString; APieces : TStrings);\r\n var r : TRegExpr;\r\n begin\r\n  APieces.Clear;\r\n  r := TRegExpr.Create;\r\n  try\r\n    r.Expression := ARegExpr;\r\n    r.Split (AInputStr, APieces);\r\n    finally r.Free;\r\n   end;\r\n end; { of procedure SplitRegExpr\r\n--------------------------------------------------------------}\r\n\r\nfunction ReplaceRegExpr (const ARegExpr, AInputStr, AReplaceStr : RegExprString;\r\n      AUseSubstitution : boolean{$IFDEF DefParam}= False{$ENDIF}) : RegExprString;\r\n begin\r\n  with TRegExpr.Create do try\r\n    Expression := ARegExpr;\r\n    Result := Replace (AInputStr, AReplaceStr, AUseSubstitution);\r\n    finally Free;\r\n   end;\r\n end; { of function ReplaceRegExpr\r\n--------------------------------------------------------------}\r\n\r\nfunction QuoteRegExprMetaChars (const AStr : RegExprString) : RegExprString;\r\n const\r\n  RegExprMetaSet : RegExprString = '^$.[()|?+*'+EscChar+'{'\r\n  + ']}'; // - this last are additional to META.\r\n  // Very similar to META array, but slighly changed.\r\n  // !Any changes in META array must be synchronized with this set.\r\n var\r\n  i, i0, Len : integer;\r\n begin\r\n  Result := '';\r\n  Len := length (AStr);\r\n  i := 1;\r\n  i0 := i;\r\n  while i <= Len do begin\r\n    if Pos (AStr [i], RegExprMetaSet) > 0 then begin\r\n      Result := Result + System.Copy (AStr, i0, i - i0)\r\n                 + EscChar + AStr [i];\r\n      i0 := i + 1;\r\n     end;\r\n    inc (i);\r\n   end;\r\n  Result := Result + System.Copy (AStr, i0, MaxInt); // Tail\r\n end; { of function QuoteRegExprMetaChars\r\n--------------------------------------------------------------}\r\n\r\nfunction RegExprSubExpressions (const ARegExpr : string;\r\n ASubExprs : TStrings; AExtendedSyntax : boolean{$IFDEF DefParam}= False{$ENDIF}) : integer;\r\n type\r\n  TStackItemRec =  record //###0.945\r\n    SubExprIdx : integer;\r\n    StartPos : integer;\r\n   end;\r\n  TStackArray = packed array [0 .. NSUBEXPMAX - 1] of TStackItemRec;\r\n var\r\n  Len, SubExprLen : integer;\r\n  i, i0 : integer;\r\n  Modif : integer;\r\n  Stack : ^TStackArray; //###0.945\r\n  StackIdx, StackSz : integer;\r\n begin\r\n  Result := 0; // no unbalanced brackets found at this very moment\r\n\r\n  ASubExprs.Clear; // I don't think that adding to non empty list\r\n  // can be usefull, so I simplified algorithm to work only with empty list\r\n\r\n  Len := length (ARegExpr); // some optimization tricks\r\n\r\n  // first we have to calculate number of subexpression to reserve\r\n  // space in Stack array (may be we'll reserve more then need, but\r\n  // it's faster then memory reallocation during parsing)\r\n  StackSz := 1; // add 1 for entire r.e.\r\n  for i := 1 to Len do\r\n   if ARegExpr [i] = '('\r\n    then inc (StackSz);\r\n//  SetLength (Stack, StackSz); //###0.945\r\n  GetMem (Stack, SizeOf (TStackItemRec) * StackSz);\r\n  try\r\n\r\n  StackIdx := 0;\r\n  i := 1;\r\n  while (i <= Len) do begin\r\n    case ARegExpr [i] of\r\n      '(': begin\r\n        if (i < Len) and (ARegExpr [i + 1] = '?') then begin\r\n           // this is not subexpression, but comment or other\r\n           // Perl extension. We must check is it (?ismxrg-ismxrg)\r\n           // and change AExtendedSyntax if /x is changed.\r\n           inc (i, 2); // skip '(?'\r\n           i0 := i;\r\n           while (i <= Len) and (ARegExpr [i] <> ')')\r\n            do inc (i);\r\n           if i > Len\r\n            then Result := -1 // unbalansed '('\r\n            else\r\n             if TRegExpr.ParseModifiersStr (System.Copy (ARegExpr, i, i - i0), Modif)\r\n              then AExtendedSyntax := (Modif and MaskModX) <> 0;\r\n          end\r\n         else begin // subexpression starts\r\n           ASubExprs.Add (''); // just reserve space\r\n           with Stack [StackIdx] do begin\r\n             SubExprIdx := ASubExprs.Count - 1;\r\n             StartPos := i;\r\n            end;\r\n           inc (StackIdx);\r\n          end;\r\n       end;\r\n      ')': begin\r\n        if StackIdx = 0\r\n         then Result := i // unbalanced ')'\r\n         else begin\r\n           dec (StackIdx);\r\n           with Stack [StackIdx] do begin\r\n             SubExprLen := i - StartPos + 1;\r\n             ASubExprs.Objects [SubExprIdx] :=\r\n              TObject (StartPos or (SubExprLen ShL 16));\r\n             ASubExprs [SubExprIdx] := System.Copy (\r\n              ARegExpr, StartPos + 1, SubExprLen - 2); // add without brackets\r\n            end;\r\n          end;\r\n       end;\r\n      EscChar: inc (i); // skip quoted symbol\r\n      '[': begin\r\n        // we have to skip character ranges at once, because they can\r\n        // contain '#', and '#' in it must NOT be recognized as eXtended\r\n        // comment beginning!\r\n        i0 := i;\r\n        inc (i);\r\n        if ARegExpr [i] = ']' // cannot be 'emty' ranges - this interpretes\r\n         then inc (i);        // as ']' by itself\r\n        while (i <= Len) and (ARegExpr [i] <> ']') do\r\n         if ARegExpr [i] = EscChar //###0.942\r\n          then inc (i, 2) // skip 'escaped' char to prevent stopping at '\\]'\r\n          else inc (i);\r\n        if (i > Len) or (ARegExpr [i] <> ']') //###0.942\r\n         then Result := - (i0 + 1); // unbalansed '[' //###0.942\r\n       end;\r\n      '#': if AExtendedSyntax then begin\r\n        // skip eXtended comments\r\n        while (i <= Len) and (ARegExpr [i] <> #$d) and (ARegExpr [i] <> #$a)\r\n         // do not use [#$d, #$a] due to UniCode compatibility\r\n         do inc (i);\r\n        while (i + 1 <= Len) and ((ARegExpr [i + 1] = #$d) or (ARegExpr [i + 1] = #$a))\r\n         do inc (i); // attempt to work with different kinds of line separators\r\n        // now we are at the line separator that must be skipped.\r\n       end;\r\n      // here is no 'else' clause - we simply skip ordinary chars\r\n     end; // of case\r\n    inc (i); // skip scanned char\r\n    // ! can move after Len due to skipping quoted symbol\r\n   end;\r\n\r\n  // check brackets balance\r\n  if StackIdx <> 0\r\n   then Result := -1; // unbalansed '('\r\n\r\n  // check if entire r.e. added\r\n  if (ASubExprs.Count = 0)\r\n   or ((integer (ASubExprs.Objects [0]) and $FFFF) <> 1)\r\n   or (((integer (ASubExprs.Objects [0]) ShR 16) and $FFFF) <> Len)\r\n    // whole r.e. wasn't added because it isn't bracketed\r\n    // well, we add it now:\r\n    then ASubExprs.InsertObject (0, ARegExpr, TObject ((Len ShL 16) or 1));\r\n\r\n  finally FreeMem (Stack);\r\n  end;\r\n end; { of function RegExprSubExpressions\r\n--------------------------------------------------------------}\r\n\r\n\r\n\r\nconst\r\n MAGIC       = TREOp (216);// programm signature\r\n\r\n// name            opcode    opnd? meaning\r\n EEND        = TREOp (0);  // -    End of program\r\n BOL         = TREOp (1);  // -    Match \"\" at beginning of line\r\n EOL         = TREOp (2);  // -    Match \"\" at end of line\r\n ANY         = TREOp (3);  // -    Match any one character\r\n ANYOF       = TREOp (4);  // Str  Match any character in string Str\r\n ANYBUT      = TREOp (5);  // Str  Match any char. not in string Str\r\n BRANCH      = TREOp (6);  // Node Match this alternative, or the next\r\n BACK        = TREOp (7);  // -    Jump backward (Next < 0)\r\n EXACTLY     = TREOp (8);  // Str  Match string Str\r\n NOTHING     = TREOp (9);  // -    Match empty string\r\n STAR        = TREOp (10); // Node Match this (simple) thing 0 or more times\r\n PLUS        = TREOp (11); // Node Match this (simple) thing 1 or more times\r\n ANYDIGIT    = TREOp (12); // -    Match any digit (equiv [0-9])\r\n NOTDIGIT    = TREOp (13); // -    Match not digit (equiv [0-9])\r\n ANYLETTER   = TREOp (14); // -    Match any letter from property WordChars\r\n NOTLETTER   = TREOp (15); // -    Match not letter from property WordChars\r\n ANYSPACE    = TREOp (16); // -    Match any space char (see property SpaceChars)\r\n NOTSPACE    = TREOp (17); // -    Match not space char (see property SpaceChars)\r\n BRACES      = TREOp (18); // Node,Min,Max Match this (simple) thing from Min to Max times.\r\n                           //      Min and Max are TREBracesArg\r\n COMMENT     = TREOp (19); // -    Comment ;)\r\n EXACTLYCI   = TREOp (20); // Str  Match string Str case insensitive\r\n ANYOFCI     = TREOp (21); // Str  Match any character in string Str, case insensitive\r\n ANYBUTCI    = TREOp (22); // Str  Match any char. not in string Str, case insensitive\r\n LOOPENTRY   = TREOp (23); // Node Start of loop (Node - LOOP for this loop)\r\n LOOP        = TREOp (24); // Node,Min,Max,LoopEntryJmp - back jump for LOOPENTRY.\r\n                           //      Min and Max are TREBracesArg\r\n                           //      Node - next node in sequence,\r\n                           //      LoopEntryJmp - associated LOOPENTRY node addr\r\n ANYOFTINYSET= TREOp (25); // Chrs Match any one char from Chrs (exactly TinySetLen chars)\r\n ANYBUTTINYSET=TREOp (26); // Chrs Match any one char not in Chrs (exactly TinySetLen chars)\r\n ANYOFFULLSET= TREOp (27); // Set  Match any one char from set of char\r\n                           // - very fast (one CPU instruction !) but takes 32 bytes of p-code\r\n BSUBEXP     = TREOp (28); // Idx  Match previously matched subexpression #Idx (stored as REChar) //###0.936\r\n BSUBEXPCI   = TREOp (29); // Idx  -\"- in case-insensitive mode\r\n\r\n // Non-Greedy Style Ops //###0.940\r\n STARNG      = TREOp (30); // Same as START but in non-greedy mode\r\n PLUSNG      = TREOp (31); // Same as PLUS but in non-greedy mode\r\n BRACESNG    = TREOp (32); // Same as BRACES but in non-greedy mode\r\n LOOPNG      = TREOp (33); // Same as LOOP but in non-greedy mode\r\n\r\n // Multiline mode \\m\r\n BOLML       = TREOp (34);  // -    Match \"\" at beginning of line\r\n EOLML       = TREOp (35);  // -    Match \"\" at end of line\r\n ANYML       = TREOp (36);  // -    Match any one character\r\n\r\n // Word boundary\r\n BOUND       = TREOp (37);  // Match \"\" between words //###0.943\r\n NOTBOUND    = TREOp (38);  // Match \"\" not between words //###0.943\r\n\r\n // !!! Change OPEN value if you add new opcodes !!!\r\n\r\n OPEN        = TREOp (39); // -    Mark this point in input as start of \\n\r\n                           //      OPEN + 1 is \\1, etc.\r\n CLOSE       = TREOp (ord (OPEN) + NSUBEXP);\r\n                           // -    Analogous to OPEN.\r\n\r\n // !!! Don't add new OpCodes after CLOSE !!!\r\n\r\n// We work with p-code thru pointers, compatible with PRegExprChar.\r\n// Note: all code components (TRENextOff, TREOp, TREBracesArg, etc)\r\n// must have lengths that can be divided by SizeOf (REChar) !\r\n// A node is TREOp of opcode followed Next \"pointer\" of TRENextOff type.\r\n// The Next is a offset from the opcode of the node containing it.\r\n// An operand, if any, simply follows the node. (Note that much of\r\n// the code generation knows about this implicit relationship!)\r\n// Using TRENextOff=integer speed up p-code processing.\r\n\r\n// Opcodes description:\r\n//\r\n// BRANCH The set of branches constituting a single choice are hooked\r\n//      together with their \"next\" pointers, since precedence prevents\r\n//      anything being concatenated to any individual branch.  The\r\n//      \"next\" pointer of the last BRANCH in a choice points to the\r\n//      thing following the whole choice.  This is also where the\r\n//      final \"next\" pointer of each individual branch points; each\r\n//      branch starts with the operand node of a BRANCH node.\r\n// BACK Normal \"next\" pointers all implicitly point forward; BACK\r\n//      exists to make loop structures possible.\r\n// STAR,PLUS,BRACES '?', and complex '*' and '+', are implemented as\r\n//      circular BRANCH structures using BACK. Complex '{min,max}'\r\n//      - as pair LOOPENTRY-LOOP (see below). Simple cases (one\r\n//      character per match) are implemented with STAR, PLUS and\r\n//      BRACES for speed and to minimize recursive plunges.\r\n// LOOPENTRY,LOOP {min,max} are implemented as special pair\r\n//      LOOPENTRY-LOOP. Each LOOPENTRY initialize loopstack for\r\n//      current level.\r\n// OPEN,CLOSE are numbered at compile time.\r\n\r\n\r\n{=============================================================}\r\n{================== Error handling section ===================}\r\n{=============================================================}\r\n\r\nconst\r\n reeOk = 0;\r\n reeCompNullArgument = 100;\r\n reeCompRegexpTooBig = 101;\r\n reeCompParseRegTooManyBrackets = 102;\r\n reeCompParseRegUnmatchedBrackets = 103;\r\n reeCompParseRegUnmatchedBrackets2 = 104;\r\n reeCompParseRegJunkOnEnd = 105;\r\n reePlusStarOperandCouldBeEmpty = 106;\r\n reeNestedSQP = 107;\r\n reeBadHexDigit = 108;\r\n reeInvalidRange = 109;\r\n reeParseAtomTrailingBackSlash = 110;\r\n reeNoHexCodeAfterBSlashX = 111;\r\n reeHexCodeAfterBSlashXTooBig = 112;\r\n reeUnmatchedSqBrackets = 113;\r\n reeInternalUrp = 114;\r\n reeQPSBFollowsNothing = 115;\r\n reeTrailingBackSlash = 116;\r\n reeRarseAtomInternalDisaster = 119;\r\n reeBRACESArgTooBig = 122;\r\n reeBracesMinParamGreaterMax = 124;\r\n reeUnclosedComment = 125;\r\n reeComplexBracesNotImplemented = 126;\r\n reeUrecognizedModifier = 127;\r\n reeBadLinePairedSeparator = 128;\r\n reeRegRepeatCalledInappropriately = 1000;\r\n reeMatchPrimMemoryCorruption = 1001;\r\n reeMatchPrimCorruptedPointers = 1002;\r\n reeNoExpression = 1003;\r\n reeCorruptedProgram = 1004;\r\n reeNoInpitStringSpecified = 1005;\r\n reeOffsetMustBeGreaterThen0 = 1006;\r\n reeExecNextWithoutExec = 1007;\r\n reeGetInputStringWithoutInputString = 1008;\r\n reeDumpCorruptedOpcode = 1011;\r\n reeModifierUnsupported = 1013;\r\n reeLoopStackExceeded = 1014;\r\n reeLoopWithoutEntry = 1015;\r\n reeBadPCodeImported = 2000;\r\n\r\nfunction TRegExpr.ErrorMsg (AErrorID : integer) : RegExprString;\r\n begin\r\n  case AErrorID of\r\n    reeOk: Result := 'No errors';\r\n    reeCompNullArgument: Result := 'TRegExpr(comp): Null Argument';\r\n    reeCompRegexpTooBig: Result := 'TRegExpr(comp): Regexp Too Big';\r\n    reeCompParseRegTooManyBrackets: Result := 'TRegExpr(comp): ParseReg Too Many ()';\r\n    reeCompParseRegUnmatchedBrackets: Result := 'TRegExpr(comp): ParseReg Unmatched ()';\r\n    reeCompParseRegUnmatchedBrackets2: Result := 'TRegExpr(comp): ParseReg Unmatched ()';\r\n    reeCompParseRegJunkOnEnd: Result := 'TRegExpr(comp): ParseReg Junk On End';\r\n    reePlusStarOperandCouldBeEmpty: Result := 'TRegExpr(comp): *+ Operand Could Be Empty';\r\n    reeNestedSQP: Result := 'TRegExpr(comp): Nested *?+';\r\n    reeBadHexDigit: Result := 'TRegExpr(comp): Bad Hex Digit';\r\n    reeInvalidRange: Result := 'TRegExpr(comp): Invalid [] Range';\r\n    reeParseAtomTrailingBackSlash: Result := 'TRegExpr(comp): Parse Atom Trailing \\';\r\n    reeNoHexCodeAfterBSlashX: Result := 'TRegExpr(comp): No Hex Code After \\x';\r\n    reeHexCodeAfterBSlashXTooBig: Result := 'TRegExpr(comp): Hex Code After \\x Is Too Big';\r\n    reeUnmatchedSqBrackets: Result := 'TRegExpr(comp): Unmatched []';\r\n    reeInternalUrp: Result := 'TRegExpr(comp): Internal Urp';\r\n    reeQPSBFollowsNothing: Result := 'TRegExpr(comp): ?+*{ Follows Nothing';\r\n    reeTrailingBackSlash: Result := 'TRegExpr(comp): Trailing \\';\r\n    reeRarseAtomInternalDisaster: Result := 'TRegExpr(comp): RarseAtom Internal Disaster';\r\n    reeBRACESArgTooBig: Result := 'TRegExpr(comp): BRACES Argument Too Big';\r\n    reeBracesMinParamGreaterMax: Result := 'TRegExpr(comp): BRACE Min Param Greater then Max';\r\n    reeUnclosedComment: Result := 'TRegExpr(comp): Unclosed (?#Comment)';\r\n    reeComplexBracesNotImplemented: Result := 'TRegExpr(comp): If you want take part in beta-testing BRACES ''{min,max}'' and non-greedy ops ''*?'', ''+?'', ''??'' for complex cases - remove ''.'' from {.$DEFINE ComplexBraces}';\r\n    reeUrecognizedModifier: Result := 'TRegExpr(comp): Urecognized Modifier';\r\n    reeBadLinePairedSeparator: Result := 'TRegExpr(comp): LinePairedSeparator must countain two different chars or no chars at all';\r\n\r\n    reeRegRepeatCalledInappropriately: Result := 'TRegExpr(exec): RegRepeat Called Inappropriately';\r\n    reeMatchPrimMemoryCorruption: Result := 'TRegExpr(exec): MatchPrim Memory Corruption';\r\n    reeMatchPrimCorruptedPointers: Result := 'TRegExpr(exec): MatchPrim Corrupted Pointers';\r\n    reeNoExpression: Result := 'TRegExpr(exec): Not Assigned Expression Property';\r\n    reeCorruptedProgram: Result := 'TRegExpr(exec): Corrupted Program';\r\n    reeNoInpitStringSpecified: Result := 'TRegExpr(exec): No Input String Specified';\r\n    reeOffsetMustBeGreaterThen0: Result := 'TRegExpr(exec): Offset Must Be Greater Then 0';\r\n    reeExecNextWithoutExec: Result := 'TRegExpr(exec): ExecNext Without Exec[Pos]';\r\n    reeGetInputStringWithoutInputString: Result := 'TRegExpr(exec): GetInputString Without InputString';\r\n    reeDumpCorruptedOpcode: Result := 'TRegExpr(dump): Corrupted Opcode';\r\n    reeLoopStackExceeded: Result := 'TRegExpr(exec): Loop Stack Exceeded';\r\n    reeLoopWithoutEntry: Result := 'TRegExpr(exec): Loop Without LoopEntry !';\r\n\r\n    reeBadPCodeImported: Result := 'TRegExpr(misc): Bad p-code imported';\r\n    else Result := 'Unknown error';\r\n   end;\r\n end; { of procedure TRegExpr.Error\r\n--------------------------------------------------------------}\r\n\r\nfunction TRegExpr.LastError : integer;\r\n begin\r\n  Result := fLastError;\r\n  fLastError := reeOk;\r\n end; { of function TRegExpr.LastError\r\n--------------------------------------------------------------}\r\n\r\n\r\n{=============================================================}\r\n{===================== Common section ========================}\r\n{=============================================================}\r\n\r\nclass function TRegExpr.VersionMajor : integer; //###0.944\r\n begin\r\n  Result := TRegExprVersionMajor;\r\n end; { of class function TRegExpr.VersionMajor\r\n--------------------------------------------------------------}\r\n\r\nclass function TRegExpr.VersionMinor : integer; //###0.944\r\n begin\r\n  Result := TRegExprVersionMinor;\r\n end; { of class function TRegExpr.VersionMinor\r\n--------------------------------------------------------------}\r\n\r\nconstructor TRegExpr.Create;\r\n begin\r\n  inherited;\r\n  programm := nil;\r\n  fExpression := nil;\r\n  fInputString := nil;\r\n\r\n  regexpbeg := nil;\r\n  fExprIsCompiled := false;\r\n\r\n  ModifierI := RegExprModifierI;\r\n  ModifierR := RegExprModifierR;\r\n  ModifierS := RegExprModifierS;\r\n  ModifierG := RegExprModifierG;\r\n  ModifierM := RegExprModifierM; //###0.940\r\n\r\n  SpaceChars := RegExprSpaceChars; //###0.927\r\n  WordChars := RegExprWordChars; //###0.929\r\n  fInvertCase := RegExprInvertCaseFunction; //###0.927\r\n\r\n  fLineSeparators := RegExprLineSeparators; //###0.941\r\n  LinePairedSeparator := RegExprLinePairedSeparator; //###0.941\r\n end; { of constructor TRegExpr.Create\r\n--------------------------------------------------------------}\r\n\r\ndestructor TRegExpr.Destroy;\r\n begin\r\n  if programm <> nil\r\n   then FreeMem (programm);\r\n  if fExpression <> nil\r\n   then FreeMem (fExpression);\r\n  if fInputString <> nil\r\n   then FreeMem (fInputString);\r\n end; { of destructor TRegExpr.Destroy\r\n--------------------------------------------------------------}\r\n\r\nclass function TRegExpr.InvertCaseFunction (const Ch : REChar) : REChar;\r\n begin\r\n  {$IFDEF SynRegUniCode}\r\n  if Ch >= #128\r\n   then Result := Ch\r\n  else\r\n  {$ENDIF}\r\n   begin\r\n    Result := {$IFDEF FPC}AnsiUpperCase (Ch) [1]{$ELSE} {$IFDEF SYN_WIN32}REChar (CharUpper (PChar (Ch))){$ELSE}REChar (toupper (integer (Ch))){$ENDIF} {$ENDIF};\r\n    if Result = Ch\r\n     then Result := {$IFDEF FPC}AnsiLowerCase (Ch) [1]{$ELSE} {$IFDEF SYN_WIN32}REChar (CharLower (PChar (Ch))){$ELSE}REChar(tolower (integer (Ch))){$ENDIF} {$ENDIF};\r\n   end;\r\n end; { of function TRegExpr.InvertCaseFunction\r\n--------------------------------------------------------------}\r\n\r\nfunction TRegExpr.GetExpression : RegExprString;\r\n begin\r\n  if fExpression <> nil\r\n   then Result := fExpression\r\n   else Result := '';\r\n end; { of function TRegExpr.GetExpression\r\n--------------------------------------------------------------}\r\n\r\nprocedure TRegExpr.SetExpression (const s : RegExprString);\r\n var\r\n  Len : integer; //###0.950\r\n begin\r\n  if (s <> fExpression) or not fExprIsCompiled then begin\r\n    fExprIsCompiled := false;\r\n    if fExpression <> nil then begin\r\n      FreeMem (fExpression);\r\n      fExpression := nil;\r\n     end;\r\n    if s <> '' then begin\r\n      Len := length (s); //###0.950\r\n      GetMem (fExpression, (Len + 1) * SizeOf (REChar));\r\n//      StrPCopy (fExpression, s); //###0.950 replaced due to StrPCopy limitation of 255 chars\r\n      {$IFDEF SynRegUniCode}\r\n      StrPCopy (fExpression, Copy (s, 1, Len)); //###0.950\r\n      {$ELSE}\r\n      StrLCopy (fExpression, PRegExprChar (s), Len); //###0.950\r\n      {$ENDIF SynRegUniCode}\r\n\r\n      InvalidateProgramm; //###0.941\r\n     end;\r\n   end;\r\n end; { of procedure TRegExpr.SetExpression\r\n--------------------------------------------------------------}\r\n\r\nfunction TRegExpr.GetSubExprMatchCount : integer;\r\n begin\r\n  if Assigned (fInputString) then begin\r\n     Result := NSUBEXP - 1;\r\n     while (Result > 0) and ((startp [Result] = nil)\r\n                             or (endp [Result] = nil))\r\n      do dec (Result);\r\n    end\r\n   else Result := -1;\r\n end; { of function TRegExpr.GetSubExprMatchCount\r\n--------------------------------------------------------------}\r\n\r\nfunction TRegExpr.GetMatchPos (Idx : integer) : integer;\r\n begin\r\n  if (Idx >= 0) and (Idx < NSUBEXP) and Assigned (fInputString)\r\n     and Assigned (startp [Idx]) and Assigned (endp [Idx]) then begin\r\n     Result := (startp [Idx] - fInputString) + 1;\r\n    end\r\n   else Result := -1;\r\n end; { of function TRegExpr.GetMatchPos\r\n--------------------------------------------------------------}\r\n\r\nfunction TRegExpr.GetMatchLen (Idx : integer) : integer;\r\n begin\r\n  if (Idx >= 0) and (Idx < NSUBEXP) and Assigned (fInputString)\r\n     and Assigned (startp [Idx]) and Assigned (endp [Idx]) then begin\r\n     Result := endp [Idx] - startp [Idx];\r\n    end\r\n   else Result := -1;\r\n end; { of function TRegExpr.GetMatchLen\r\n--------------------------------------------------------------}\r\n\r\nfunction TRegExpr.GetMatch (Idx : integer) : RegExprString;\r\n begin\r\n  if (Idx >= 0) and (Idx < NSUBEXP) and Assigned (fInputString)\r\n     and Assigned (startp [Idx]) and Assigned (endp [Idx])\r\n   //then Result := copy (fInputString, MatchPos [Idx], MatchLen [Idx]) //###0.929\r\n   then SetString (Result, startp [idx], endp [idx] - startp [idx])\r\n   else Result := '';\r\n end; { of function TRegExpr.GetMatch\r\n--------------------------------------------------------------}\r\n\r\nfunction TRegExpr.GetModifierStr : RegExprString;\r\n begin\r\n  Result := '-';\r\n\r\n  if ModifierI\r\n   then Result := 'i' + Result\r\n   else Result := Result + 'i';\r\n  if ModifierR\r\n   then Result := 'r' + Result\r\n   else Result := Result + 'r';\r\n  if ModifierS\r\n   then Result := 's' + Result\r\n   else Result := Result + 's';\r\n  if ModifierG\r\n   then Result := 'g' + Result\r\n   else Result := Result + 'g';\r\n  if ModifierM\r\n   then Result := 'm' + Result\r\n   else Result := Result + 'm';\r\n  if ModifierX\r\n   then Result := 'x' + Result\r\n   else Result := Result + 'x';\r\n\r\n  if Result [length (Result)] = '-' // remove '-' if all modifiers are 'On'\r\n   then System.Delete (Result, length (Result), 1);\r\n end; { of function TRegExpr.GetModifierStr\r\n--------------------------------------------------------------}\r\n\r\nclass function TRegExpr.ParseModifiersStr (const AModifiers : RegExprString;\r\nvar AModifiersInt : integer) : boolean;\r\n// !!! Be carefull - this is class function and must not use object instance fields\r\n var\r\n  i : integer;\r\n  IsOn : boolean;\r\n  Mask : integer;\r\n begin\r\n  Result := true;\r\n  IsOn := true;\r\n{$IFDEF CPUX86}\r\n  Mask := 0; // prevent compiler warning\r\n{$ENDIF}\r\n  for i := 1 to length (AModifiers) do\r\n   if AModifiers [i] = '-'\r\n    then IsOn := false\r\n    else begin\r\n      if Pos (AModifiers [i], 'iI') > 0\r\n       then Mask := MaskModI\r\n      else if Pos (AModifiers [i], 'rR') > 0\r\n       then Mask := MaskModR\r\n      else if Pos (AModifiers [i], 'sS') > 0\r\n       then Mask := MaskModS\r\n      else if Pos (AModifiers [i], 'gG') > 0\r\n       then Mask := MaskModG\r\n      else if Pos (AModifiers [i], 'mM') > 0\r\n       then Mask := MaskModM\r\n      else if Pos (AModifiers [i], 'xX') > 0\r\n       then Mask := MaskModX\r\n      else begin\r\n        Result := false;\r\n        EXIT;\r\n       end;\r\n      if IsOn\r\n       then AModifiersInt := AModifiersInt or Mask\r\n       else AModifiersInt := AModifiersInt and not Mask;\r\n     end;\r\n end; { of function TRegExpr.ParseModifiersStr\r\n--------------------------------------------------------------}\r\n\r\nprocedure TRegExpr.SetModifierStr (const AModifiers : RegExprString);\r\n begin\r\n  if not ParseModifiersStr (AModifiers, fModifiers)\r\n   then Error (reeModifierUnsupported);\r\n end; { of procedure TRegExpr.SetModifierStr\r\n--------------------------------------------------------------}\r\n\r\nfunction TRegExpr.GetModifier (AIndex : integer) : boolean;\r\n var\r\n  Mask : integer;\r\n begin\r\n  Result := false;\r\n  case AIndex of\r\n    1: Mask := MaskModI;\r\n    2: Mask := MaskModR;\r\n    3: Mask := MaskModS;\r\n    4: Mask := MaskModG;\r\n    5: Mask := MaskModM;\r\n    6: Mask := MaskModX;\r\n    else begin\r\n      Error (reeModifierUnsupported);\r\n      EXIT;\r\n     end;\r\n   end;\r\n  Result := (fModifiers and Mask) <> 0;\r\n end; { of function TRegExpr.GetModifier\r\n--------------------------------------------------------------}\r\n\r\nprocedure TRegExpr.SetModifier (AIndex : integer; ASet : boolean);\r\n var\r\n  Mask : integer;\r\n begin\r\n  case AIndex of\r\n    1: Mask := MaskModI;\r\n    2: Mask := MaskModR;\r\n    3: Mask := MaskModS;\r\n    4: Mask := MaskModG;\r\n    5: Mask := MaskModM;\r\n    6: Mask := MaskModX;\r\n    else begin\r\n      Error (reeModifierUnsupported);\r\n      EXIT;\r\n     end;\r\n   end;\r\n  if ASet\r\n   then fModifiers := fModifiers or Mask\r\n   else fModifiers := fModifiers and not Mask;\r\n end; { of procedure TRegExpr.SetModifier\r\n--------------------------------------------------------------}\r\n\r\n\r\n{=============================================================}\r\n{==================== Compiler section =======================}\r\n{=============================================================}\r\n\r\nprocedure TRegExpr.InvalidateProgramm;\r\n begin\r\n  if programm <> nil then begin\r\n    FreeMem (programm);\r\n    programm := nil;\r\n   end;\r\n end; { of procedure TRegExpr.InvalidateProgramm\r\n--------------------------------------------------------------}\r\n\r\nprocedure TRegExpr.Compile; //###0.941\r\n begin\r\n  if fExpression = nil then begin // No Expression assigned\r\n    Error (reeNoExpression);\r\n    EXIT;\r\n   end;\r\n  CompileRegExpr (fExpression);\r\n end; { of procedure TRegExpr.Compile\r\n--------------------------------------------------------------}\r\n\r\nfunction TRegExpr.IsProgrammOk : boolean;\r\n {$IFNDEF SynRegUniCode}\r\n var\r\n  i : integer;\r\n {$ENDIF}\r\n begin\r\n  Result := false;\r\n\r\n  // check modifiers\r\n  if fModifiers <> fProgModifiers //###0.941\r\n   then InvalidateProgramm;\r\n\r\n  // can we optimize line separators by using sets?\r\n  {$IFNDEF SynRegUniCode}\r\n  fLineSeparatorsSet := [];\r\n  for i := 1 to length (fLineSeparators)\r\n   do System.Include (fLineSeparatorsSet, fLineSeparators [i]);\r\n  {$ENDIF}\r\n\r\n  // [Re]compile if needed\r\n  if programm = nil\r\n   then Compile; //###0.941\r\n\r\n  // check [re]compiled programm\r\n  if programm = nil\r\n   then EXIT // error was set/raised by Compile (was reeExecAfterCompErr)\r\n  else if programm [0] <> MAGIC // Program corrupted.\r\n   then Error (reeCorruptedProgram)\r\n  else Result := true;\r\n end; { of function TRegExpr.IsProgrammOk\r\n--------------------------------------------------------------}\r\n\r\nprocedure TRegExpr.Tail (p : PRegExprChar; val : PRegExprChar);\r\n// set the next-pointer at the end of a node chain\r\n var\r\n  scan : PRegExprChar;\r\n  temp : PRegExprChar;\r\n//  i : int64;\r\n begin\r\n  if p = @regdummy\r\n   then EXIT;\r\n  // Find last node.\r\n  scan := p;\r\n  REPEAT\r\n   temp := regnext (scan);\r\n   if temp = nil\r\n    then BREAK;\r\n   scan := temp;\r\n  UNTIL false;\r\n  // Set Next 'pointer'\r\n  if val < scan\r\n   then PRENextOff (scan + REOpSz)^ := - (scan - val) //###0.948\r\n   // work around PWideChar subtraction bug (Delphi uses\r\n   // shr after subtraction to calculate widechar distance %-( )\r\n   // so, if difference is negative we have .. the \"feature\" :(\r\n   // I could wrap it in $IFDEF UniCode, but I didn't because\r\n   // \"P  Q computes the difference between the address given\r\n   // by P (the higher address) and the address given by Q (the\r\n   // lower address)\" - Delphi help quotation.\r\n   else PRENextOff (scan + REOpSz)^ := val - scan; //###0.933\r\n end; { of procedure TRegExpr.Tail\r\n--------------------------------------------------------------}\r\n\r\nprocedure TRegExpr.OpTail (p : PRegExprChar; val : PRegExprChar);\r\n// regtail on operand of first argument; nop if operandless\r\n begin\r\n  // \"Operandless\" and \"op != BRANCH\" are synonymous in practice.\r\n  if (p = nil) or (p = @regdummy) or (PREOp (p)^ <> BRANCH)\r\n   then EXIT;\r\n  Tail (p + REOpSz + RENextOffSz, val); //###0.933\r\n end; { of procedure TRegExpr.OpTail\r\n--------------------------------------------------------------}\r\n\r\nfunction TRegExpr.EmitNode (op : TREOp) : PRegExprChar; //###0.933\r\n// emit a node, return location\r\n begin\r\n  Result := regcode;\r\n  if Result <> @regdummy then begin\r\n     PREOp (regcode)^ := op;\r\n     inc (regcode, REOpSz);\r\n     PRENextOff (regcode)^ := 0; // Next \"pointer\" := nil\r\n     inc (regcode, RENextOffSz);\r\n    end\r\n   else inc (regsize, REOpSz + RENextOffSz); // compute code size without code generation\r\n end; { of function TRegExpr.EmitNode\r\n--------------------------------------------------------------}\r\n\r\nprocedure TRegExpr.EmitC (b : REChar);\r\n// emit a byte to code\r\n begin\r\n  if regcode <> @regdummy then begin\r\n     regcode^ := b;\r\n     inc (regcode);\r\n    end\r\n   else inc (regsize); // Type of p-code pointer always is ^REChar\r\n end; { of procedure TRegExpr.EmitC\r\n--------------------------------------------------------------}\r\n\r\nprocedure TRegExpr.InsertOperator (op : TREOp; opnd : PRegExprChar; sz : integer);\r\n// insert an operator in front of already-emitted operand\r\n// Means relocating the operand.\r\n var\r\n  src, dst, place : PRegExprChar;\r\n  i : integer;\r\n begin\r\n  if regcode = @regdummy then begin\r\n    inc (regsize, sz);\r\n    EXIT;\r\n   end;\r\n  src := regcode;\r\n  inc (regcode, sz);\r\n  dst := regcode;\r\n  while src > opnd do begin\r\n    dec (dst);\r\n    dec (src);\r\n    dst^ := src^;\r\n   end;\r\n  place := opnd; // Op node, where operand used to be.\r\n  PREOp (place)^ := op;\r\n  inc (place, REOpSz);\r\n  for i := 1 + REOpSz to sz do begin\r\n    place^ := #0;\r\n    inc (place);\r\n   end;\r\n end; { of procedure TRegExpr.InsertOperator\r\n--------------------------------------------------------------}\r\n\r\nfunction strcspn (s1 : PRegExprChar; s2 : PRegExprChar) : integer;\r\n// find length of initial segment of s1 consisting\r\n// entirely of characters not from s2\r\n var scan1, scan2 : PRegExprChar;\r\n begin\r\n  Result := 0;\r\n  scan1 := s1;\r\n  while scan1^ <> #0 do begin\r\n    scan2 := s2;\r\n    while scan2^ <> #0 do\r\n     if scan1^ = scan2^\r\n      then EXIT\r\n      else inc (scan2);\r\n    inc (Result);\r\n    inc (scan1)\r\n   end;\r\n end; { of function strcspn\r\n--------------------------------------------------------------}\r\n\r\nconst\r\n// Flags to be passed up and down.\r\n HASWIDTH =   01; // Known never to match nil string.\r\n SIMPLE   =   02; // Simple enough to be STAR/PLUS/BRACES operand.\r\n SPSTART  =   04; // Starts with * or +.\r\n WORST    =   0;  // Worst case.\r\n META : array [0 .. 12] of REChar = (\r\n  '^', '$', '.', '[', '(', ')', '|', '?', '+', '*', EscChar, '{', #0);\r\n // Any modification must be synchronized with QuoteRegExprMetaChars !!!\r\n\r\n{$IFDEF SynRegUniCode}\r\n RusRangeLo : array [0 .. 33] of REChar =\r\n  (#$430,#$431,#$432,#$433,#$434,#$435,#$451,#$436,#$437,\r\n   #$438,#$439,#$43A,#$43B,#$43C,#$43D,#$43E,#$43F,\r\n   #$440,#$441,#$442,#$443,#$444,#$445,#$446,#$447,\r\n   #$448,#$449,#$44A,#$44B,#$44C,#$44D,#$44E,#$44F,#0);\r\n RusRangeHi : array [0 .. 33] of REChar =\r\n  (#$410,#$411,#$412,#$413,#$414,#$415,#$401,#$416,#$417,\r\n   #$418,#$419,#$41A,#$41B,#$41C,#$41D,#$41E,#$41F,\r\n   #$420,#$421,#$422,#$423,#$424,#$425,#$426,#$427,\r\n   #$428,#$429,#$42A,#$42B,#$42C,#$42D,#$42E,#$42F,#0);\r\n RusRangeLoLow = #$430{''};\r\n RusRangeLoHigh = #$44F{''};\r\n RusRangeHiLow = #$410{''};\r\n RusRangeHiHigh = #$42F{''};\r\n{$ELSE}\r\n RusRangeLo = '';\r\n RusRangeHi = 'Ũ';\r\n RusRangeLoLow = '';\r\n RusRangeLoHigh = '';\r\n RusRangeHiLow = '';\r\n RusRangeHiHigh = '';\r\n{$ENDIF}\r\n\r\nfunction TRegExpr.CompileRegExpr (exp : PRegExprChar) : boolean;\r\n// compile a regular expression into internal code\r\n// We can't allocate space until we know how big the compiled form will be,\r\n// but we can't compile it (and thus know how big it is) until we've got a\r\n// place to put the code.  So we cheat:  we compile it twice, once with code\r\n// generation turned off and size counting turned on, and once \"for real\".\r\n// This also means that we don't allocate space until we are sure that the\r\n// thing really will compile successfully, and we never have to move the\r\n// code and thus invalidate pointers into it.  (Note that it has to be in\r\n// one piece because free() must be able to free it all.)\r\n// Beware that the optimization-preparation code in here knows about some\r\n// of the structure of the compiled regexp.\r\n var\r\n  scan, longest : PRegExprChar;\r\n  len : cardinal;\r\n  flags : integer;\r\n begin\r\n  Result := false; // life too dark\r\n\r\n  regparse := nil; // for correct error handling\r\n  regexpbeg := exp;\r\n  try\r\n\r\n  if programm <> nil then begin\r\n    FreeMem (programm);\r\n    programm := nil;\r\n   end;\r\n\r\n  if exp = nil then begin\r\n    Error (reeCompNullArgument);\r\n    EXIT;\r\n   end;\r\n\r\n  fProgModifiers := fModifiers;\r\n  // well, may it's paranoia. I'll check it later... !!!!!!!!\r\n\r\n  // First pass: determine size, legality.\r\n  fCompModifiers := fModifiers;\r\n  regparse := exp;\r\n  regnpar := 1;\r\n  regsize := 0;\r\n  regcode := @regdummy;\r\n  EmitC (MAGIC);\r\n  if ParseReg (0, flags) = nil\r\n   then EXIT;\r\n\r\n  // Small enough for 2-bytes programm pointers ?\r\n  // ###0.933 no real p-code length limits now :)))\r\n//  if regsize >= 64 * 1024 then begin\r\n//    Error (reeCompRegexpTooBig);\r\n//    EXIT;\r\n//   end;\r\n\r\n  // Allocate space.\r\n  GetMem (programm, regsize * SizeOf (REChar));\r\n\r\n  // Second pass: emit code.\r\n  fCompModifiers := fModifiers;\r\n  regparse := exp;\r\n  regnpar := 1;\r\n  regcode := programm;\r\n  EmitC (MAGIC);\r\n  if ParseReg (0, flags) = nil\r\n   then EXIT;\r\n\r\n  // Dig out information for optimizations.\r\n  {$IFDEF UseFirstCharSet} //###0.929\r\n  FirstCharSet := [];\r\n  FillFirstCharSet (programm + REOpSz);\r\n  {$ENDIF}\r\n  regstart := #0; // Worst-case defaults.\r\n  reganch := #0;\r\n  regmust := nil;\r\n  regmlen := 0;\r\n  scan := programm + REOpSz; // First BRANCH.\r\n  if PREOp (regnext (scan))^ = EEND then begin // Only one top-level choice.\r\n    scan := scan + REOpSz + RENextOffSz;\r\n\r\n    // Starting-point info.\r\n    if PREOp (scan)^ = EXACTLY\r\n     then regstart := (scan + REOpSz + RENextOffSz)^\r\n     else if PREOp (scan)^ = BOL\r\n           then inc (reganch);\r\n\r\n    // If there's something expensive in the r.e., find the longest\r\n    // literal string that must appear and make it the regmust.  Resolve\r\n    // ties in favor of later strings, since the regstart check works\r\n    // with the beginning of the r.e. and avoiding duplication\r\n    // strengthens checking.  Not a strong reason, but sufficient in the\r\n    // absence of others.\r\n    if (flags and SPSTART) <> 0 then begin\r\n        longest := nil;\r\n        len := 0;\r\n        while scan <> nil do begin\r\n          if (PREOp (scan)^ = EXACTLY)\r\n             and (strlen (scan + REOpSz + RENextOffSz) >= len) then begin\r\n              longest := scan + REOpSz + RENextOffSz;\r\n              len := strlen (longest);\r\n           end;\r\n          scan := regnext (scan);\r\n         end;\r\n        regmust := longest;\r\n        regmlen := len;\r\n     end;\r\n   end;\r\n\r\n  Result := true;\r\n\r\n  finally begin\r\n    if not Result\r\n     then InvalidateProgramm;\r\n    regexpbeg := nil;\r\n    fExprIsCompiled := Result; //###0.944\r\n   end;\r\n  end;\r\n\r\n end; { of function TRegExpr.CompileRegExpr\r\n--------------------------------------------------------------}\r\n\r\nfunction TRegExpr.ParseReg (paren : integer; var flagp : integer) : PRegExprChar;\r\n// regular expression, i.e. main body or parenthesized thing\r\n// Caller must absorb opening parenthesis.\r\n// Combining parenthesis handling with the base level of regular expression\r\n// is a trifle forced, but the need to tie the tails of the branches to what\r\n// follows makes it hard to avoid.\r\n var\r\n  ret, br, ender : PRegExprChar;\r\n  parno : integer;\r\n  flags : integer;\r\n  SavedModifiers : integer;\r\n begin\r\n  Result := nil;\r\n  flagp := HASWIDTH; // Tentatively.\r\n  parno := 0; // eliminate compiler stupid warning\r\n  SavedModifiers := fCompModifiers;\r\n\r\n  // Make an OPEN node, if parenthesized.\r\n  if paren <> 0 then begin\r\n      if regnpar >= NSUBEXP then begin\r\n        Error (reeCompParseRegTooManyBrackets);\r\n        EXIT;\r\n       end;\r\n      parno := regnpar;\r\n      inc (regnpar);\r\n      ret := EmitNode (TREOp (ord (OPEN) + parno));\r\n    end\r\n   else ret := nil;\r\n\r\n  // Pick up the branches, linking them together.\r\n  br := ParseBranch (flags);\r\n  if br = nil then begin\r\n    Result := nil;\r\n    EXIT;\r\n   end;\r\n  if ret <> nil\r\n   then Tail (ret, br) // OPEN -> first.\r\n   else ret := br;\r\n  if (flags and HASWIDTH) = 0\r\n   then flagp := flagp and not HASWIDTH;\r\n  flagp := flagp or flags and SPSTART;\r\n  while (regparse^ = '|') do begin\r\n    inc (regparse);\r\n    br := ParseBranch (flags);\r\n    if br = nil then begin\r\n       Result := nil;\r\n       EXIT;\r\n      end;\r\n    Tail (ret, br); // BRANCH -> BRANCH.\r\n    if (flags and HASWIDTH) = 0\r\n     then flagp := flagp and not HASWIDTH;\r\n    flagp := flagp or flags and SPSTART;\r\n   end;\r\n\r\n  // Make a closing node, and hook it on the end.\r\n  if paren <> 0\r\n   then ender := EmitNode (TREOp (ord (CLOSE) + parno))\r\n   else ender := EmitNode (EEND);\r\n  Tail (ret, ender);\r\n\r\n  // Hook the tails of the branches to the closing node.\r\n  br := ret;\r\n  while br <> nil do begin\r\n    OpTail (br, ender);\r\n    br := regnext (br);\r\n   end;\r\n\r\n  // Check for proper termination.\r\n  if paren <> 0 then\r\n   if regparse^ <> ')' then begin\r\n      Error (reeCompParseRegUnmatchedBrackets);\r\n      EXIT;\r\n     end\r\n    else inc (regparse); // skip trailing ')'\r\n  if (paren = 0) and (regparse^ <> #0) then begin\r\n      if regparse^ = ')'\r\n       then Error (reeCompParseRegUnmatchedBrackets2)\r\n       else Error (reeCompParseRegJunkOnEnd);\r\n      EXIT;\r\n    end;\r\n  fCompModifiers := SavedModifiers; // restore modifiers of parent\r\n  Result := ret;\r\n end; { of function TRegExpr.ParseReg\r\n--------------------------------------------------------------}\r\n\r\nfunction TRegExpr.ParseBranch (var flagp : integer) : PRegExprChar;\r\n// one alternative of an | operator\r\n// Implements the concatenation operator.\r\n var\r\n  ret, chain, latest : PRegExprChar;\r\n  flags : integer;\r\n begin\r\n  flagp := WORST; // Tentatively.\r\n\r\n  ret := EmitNode (BRANCH);\r\n  chain := nil;\r\n  while (regparse^ <> #0) and (regparse^ <> '|')\r\n        and (regparse^ <> ')') do begin\r\n    latest := ParsePiece (flags);\r\n    if latest = nil then begin\r\n      Result := nil;\r\n      EXIT;\r\n     end;\r\n    flagp := flagp or flags and HASWIDTH;\r\n    if chain = nil // First piece.\r\n     then flagp := flagp or flags and SPSTART\r\n     else Tail (chain, latest);\r\n    chain := latest;\r\n   end;\r\n  if chain = nil // Loop ran zero times.\r\n   then EmitNode (NOTHING);\r\n  Result := ret;\r\n end; { of function TRegExpr.ParseBranch\r\n--------------------------------------------------------------}\r\n\r\nfunction TRegExpr.ParsePiece (var flagp : integer) : PRegExprChar;\r\n// something followed by possible [*+?{]\r\n// Note that the branching code sequences used for ? and the general cases\r\n// of * and + and { are somewhat optimized:  they use the same NOTHING node as\r\n// both the endmarker for their branch list and the body of the last branch.\r\n// It might seem that this node could be dispensed with entirely, but the\r\n// endmarker role is not redundant.\r\n function parsenum (AStart, AEnd : PRegExprChar) : TREBracesArg;\r\n  begin\r\n   Result := 0;\r\n   if AEnd - AStart + 1 > 8 then begin // prevent stupid scanning\r\n     Error (reeBRACESArgTooBig);\r\n     EXIT;\r\n    end;\r\n   while AStart <= AEnd do begin\r\n       Result := Result * 10 + (ord (AStart^) - ord ('0'));\r\n       inc (AStart);\r\n      end;\r\n   if (Result > MaxBracesArg) or (Result < 0) then begin\r\n     Error (reeBRACESArgTooBig);\r\n     EXIT;\r\n    end;\r\n  end;\r\n\r\n var\r\n  op : REChar;\r\n  NonGreedyOp, NonGreedyCh : boolean; //###0.940\r\n  TheOp : TREOp; //###0.940\r\n  NextNode : PRegExprChar;\r\n  flags : integer;\r\n  BracesMin, Bracesmax : TREBracesArg;\r\n  p, savedparse : PRegExprChar;\r\n\r\n procedure EmitComplexBraces (ABracesMin, ABracesMax : TREBracesArg;\r\n   ANonGreedyOp : boolean); //###0.940\r\n  {$IFDEF ComplexBraces}\r\n  var\r\n   off : integer;\r\n  {$ENDIF}\r\n   begin\r\n   {$IFNDEF ComplexBraces}\r\n   Error (reeComplexBracesNotImplemented);\r\n   {$ELSE}\r\n   if ANonGreedyOp\r\n    then TheOp := LOOPNG\r\n    else TheOp := LOOP;\r\n   InsertOperator (LOOPENTRY, Result, REOpSz + RENextOffSz);\r\n   NextNode := EmitNode (TheOp);\r\n   if regcode <> @regdummy then begin\r\n      off := (Result + REOpSz + RENextOffSz)\r\n       - (regcode - REOpSz - RENextOffSz); // back to Atom after LOOPENTRY\r\n      PREBracesArg (regcode)^ := ABracesMin;\r\n      inc (regcode, REBracesArgSz);\r\n      PREBracesArg (regcode)^ := ABracesMax;\r\n      inc (regcode, REBracesArgSz);\r\n      PRENextOff (regcode)^ := off;\r\n      inc (regcode, RENextOffSz);\r\n     end\r\n    else inc (regsize, REBracesArgSz * 2 + RENextOffSz);\r\n   Tail (Result, NextNode); // LOOPENTRY -> LOOP\r\n   if regcode <> @regdummy then\r\n    Tail (Result + REOpSz + RENextOffSz, NextNode); // Atom -> LOOP\r\n   {$ENDIF}\r\n  end;\r\n\r\n procedure EmitSimpleBraces (ABracesMin, ABracesMax : TREBracesArg;\r\n   ANonGreedyOp : boolean); //###0.940\r\n  begin\r\n   if ANonGreedyOp //###0.940\r\n    then TheOp := BRACESNG\r\n    else TheOp := BRACES;\r\n   InsertOperator (TheOp, Result, REOpSz + RENextOffSz + REBracesArgSz * 2);\r\n   if regcode <> @regdummy then begin\r\n     PREBracesArg (Result + REOpSz + RENextOffSz)^ := ABracesMin;\r\n     PREBracesArg (Result + REOpSz + RENextOffSz + REBracesArgSz)^ := ABracesMax;\r\n    end;\r\n  end;\r\n\r\n begin\r\n  Result := ParseAtom (flags);\r\n  if Result = nil\r\n   then EXIT;\r\n\r\n  op := regparse^;\r\n  if not ((op = '*') or (op = '+') or (op = '?') or (op = '{')) then begin\r\n    flagp := flags;\r\n    EXIT;\r\n   end;\r\n  if ((flags and HASWIDTH) = 0) and (op <> '?') then begin\r\n    Error (reePlusStarOperandCouldBeEmpty);\r\n    EXIT;\r\n   end;\r\n\r\n  case op of\r\n    '*': begin\r\n      flagp := WORST or SPSTART;\r\n      NonGreedyCh := (regparse + 1)^ = '?'; //###0.940\r\n      NonGreedyOp := NonGreedyCh or ((fCompModifiers and MaskModG) = 0); //###0.940\r\n      if (flags and SIMPLE) = 0 then begin\r\n         if NonGreedyOp //###0.940\r\n          then EmitComplexBraces (0, MaxBracesArg, NonGreedyOp)\r\n          else begin // Emit x* as (x&|), where & means \"self\".\r\n            InsertOperator (BRANCH, Result, REOpSz + RENextOffSz); // Either x\r\n            OpTail (Result, EmitNode (BACK)); // and loop\r\n            OpTail (Result, Result); // back\r\n            Tail (Result, EmitNode (BRANCH)); // or\r\n            Tail (Result, EmitNode (NOTHING)); // nil.\r\n           end\r\n        end\r\n       else begin // Simple\r\n         if NonGreedyOp //###0.940\r\n          then TheOp := STARNG\r\n          else TheOp := STAR;\r\n         InsertOperator (TheOp, Result, REOpSz + RENextOffSz);\r\n        end;\r\n      if NonGreedyCh //###0.940\r\n       then inc (regparse); // Skip extra char ('?')\r\n     end; { of case '*'}\r\n    '+': begin\r\n      flagp := WORST or SPSTART or HASWIDTH;\r\n      NonGreedyCh := (regparse + 1)^ = '?'; //###0.940\r\n      NonGreedyOp := NonGreedyCh or ((fCompModifiers and MaskModG) = 0); //###0.940\r\n      if (flags and SIMPLE) = 0 then begin\r\n         if NonGreedyOp //###0.940\r\n          then EmitComplexBraces (1, MaxBracesArg, NonGreedyOp)\r\n          else begin // Emit x+ as x(&|), where & means \"self\".\r\n            NextNode := EmitNode (BRANCH); // Either\r\n            Tail (Result, NextNode);\r\n            Tail (EmitNode (BACK), Result);    // loop back\r\n            Tail (NextNode, EmitNode (BRANCH)); // or\r\n            Tail (Result, EmitNode (NOTHING)); // nil.\r\n           end\r\n        end\r\n       else begin // Simple\r\n         if NonGreedyOp //###0.940\r\n          then TheOp := PLUSNG\r\n          else TheOp := PLUS;\r\n         InsertOperator (TheOp, Result, REOpSz + RENextOffSz);\r\n        end;\r\n      if NonGreedyCh //###0.940\r\n       then inc (regparse); // Skip extra char ('?')\r\n     end; { of case '+'}\r\n    '?': begin\r\n      flagp := WORST;\r\n      NonGreedyCh := (regparse + 1)^ = '?'; //###0.940\r\n      NonGreedyOp := NonGreedyCh or ((fCompModifiers and MaskModG) = 0); //###0.940\r\n      if NonGreedyOp then begin //###0.940  // We emit x?? as x{0,1}?\r\n         if (flags and SIMPLE) = 0\r\n          then EmitComplexBraces (0, 1, NonGreedyOp)\r\n          else EmitSimpleBraces (0, 1, NonGreedyOp);\r\n        end\r\n       else begin // greedy '?'\r\n         InsertOperator (BRANCH, Result, REOpSz + RENextOffSz); // Either x\r\n         Tail (Result, EmitNode (BRANCH));  // or\r\n         NextNode := EmitNode (NOTHING); // nil.\r\n         Tail (Result, NextNode);\r\n         OpTail (Result, NextNode);\r\n        end;\r\n      if NonGreedyCh //###0.940\r\n       then inc (regparse); // Skip extra char ('?')\r\n     end; { of case '?'}\r\n   '{': begin\r\n      savedparse := regparse;\r\n      // !!!!!!!!!!!!\r\n      // Filip Jirsak's note - what will happen, when we are at the end of regparse?\r\n      inc (regparse);\r\n      p := regparse;\r\n      while Pos (regparse^, '0123456789') > 0  //  MUST appear\r\n       do inc (regparse);\r\n      if (regparse^ <> '}') and (regparse^ <> ',') or (p = regparse) then begin\r\n        regparse := savedparse;\r\n        flagp := flags;\r\n        EXIT;\r\n       end;\r\n      BracesMin := parsenum (p, regparse - 1);\r\n      if regparse^ = ',' then begin\r\n         inc (regparse);\r\n         p := regparse;\r\n         while Pos (regparse^, '0123456789') > 0\r\n          do inc (regparse);\r\n         if regparse^ <> '}' then begin\r\n           regparse := savedparse;\r\n           EXIT;\r\n          end;\r\n         if p = regparse\r\n          then BracesMax := MaxBracesArg\r\n          else BracesMax := parsenum (p, regparse - 1);\r\n        end\r\n       else BracesMax := BracesMin; // {n} == {n,n}\r\n      if BracesMin > BracesMax then begin\r\n        Error (reeBracesMinParamGreaterMax);\r\n        EXIT;\r\n       end;\r\n      if BracesMin > 0\r\n       then flagp := WORST;\r\n      if BracesMax > 0\r\n       then flagp := flagp or HASWIDTH or SPSTART;\r\n\r\n      NonGreedyCh := (regparse + 1)^ = '?'; //###0.940\r\n      NonGreedyOp := NonGreedyCh or ((fCompModifiers and MaskModG) = 0); //###0.940\r\n      if (flags and SIMPLE) <> 0\r\n       then EmitSimpleBraces (BracesMin, BracesMax, NonGreedyOp)\r\n       else EmitComplexBraces (BracesMin, BracesMax, NonGreedyOp);\r\n      if NonGreedyCh //###0.940\r\n       then inc (regparse); // Skip extra char '?'\r\n     end; { of case '{'}\r\n//    else // here we can't be\r\n   end; { of case op}\r\n\r\n  inc (regparse);\r\n  if (regparse^ = '*') or (regparse^ = '+') or (regparse^ = '?') or (regparse^ = '{') then begin\r\n    Error (reeNestedSQP);\r\n    EXIT;\r\n   end;\r\n end; { of function TRegExpr.ParsePiece\r\n--------------------------------------------------------------}\r\n\r\nfunction TRegExpr.ParseAtom (var flagp : integer) : PRegExprChar;\r\n// the lowest level\r\n// Optimization:  gobbles an entire sequence of ordinary characters so that\r\n// it can turn them into a single node, which is smaller to store and\r\n// faster to run.  Backslashed characters are exceptions, each becoming a\r\n// separate node; the code is simpler that way and it's not worth fixing.\r\n var\r\n  ret : PRegExprChar;\r\n  flags : integer;\r\n  RangeBeg, RangeEnd : REChar;\r\n  CanBeRange : boolean;\r\n  len : integer;\r\n  ender : REChar;\r\n  begmodfs : PRegExprChar;\r\n\r\n  {$IFDEF UseSetOfChar} //###0.930\r\n  RangePCodeBeg : PRegExprChar;\r\n  RangePCodeIdx : integer;\r\n  RangeIsCI : boolean;\r\n  RangeSet : TSetOfREChar;\r\n  RangeLen : integer;\r\n  RangeChMin, RangeChMax : REChar;\r\n  {$ENDIF}\r\n\r\n procedure EmitExactly (ch : REChar);\r\n  begin\r\n   if (fCompModifiers and MaskModI) <> 0\r\n    then ret := EmitNode (EXACTLYCI)\r\n    else ret := EmitNode (EXACTLY);\r\n   EmitC (ch);\r\n   EmitC (#0);\r\n   flagp := flagp or HASWIDTH or SIMPLE;\r\n  end;\r\n\r\n procedure EmitStr (const s : RegExprString);\r\n  var i : integer;\r\n  begin\r\n   for i := 1 to length (s)\r\n    do EmitC (s [i]);\r\n  end;\r\n\r\n function HexDig (ch : REChar) : integer;\r\n  begin\r\n   Result := 0;\r\n   if (ch >= 'a') and (ch <= 'f')\r\n    then ch := REChar (ord (ch) - (ord ('a') - ord ('A')));\r\n   if (ch < '0') or (ch > 'F') or ((ch > '9') and (ch < 'A')) then begin\r\n     Error (reeBadHexDigit);\r\n     EXIT;\r\n    end;\r\n   Result := ord (ch) - ord ('0');\r\n   if ch >= 'A'\r\n    then Result := Result - (ord ('A') - ord ('9') - 1);\r\n  end;\r\n\r\n function EmitRange (AOpCode : REChar) : PRegExprChar;\r\n  begin\r\n   {$IFDEF UseSetOfChar}\r\n   case AOpCode of\r\n     ANYBUTCI, ANYBUT:\r\n       Result := EmitNode (ANYBUTTINYSET);\r\n     else // ANYOFCI, ANYOF\r\n       Result := EmitNode (ANYOFTINYSET);\r\n    end;\r\n   case AOpCode of\r\n     ANYBUTCI, ANYOFCI:\r\n       RangeIsCI := True;\r\n     else // ANYBUT, ANYOF\r\n       RangeIsCI := False;\r\n    end;\r\n   RangePCodeBeg := regcode;\r\n   RangePCodeIdx := regsize;\r\n   RangeLen := 0;\r\n   RangeSet := [];\r\n   RangeChMin := #255;\r\n   RangeChMax := #0;\r\n   {$ELSE}\r\n   Result := EmitNode (AOpCode);\r\n   // ToDo:\r\n   // !!!!!!!!!!!!! Implement ANYOF[BUT]TINYSET generation for UniCode !!!!!!!!!!\r\n   {$ENDIF}\r\n  end;\r\n\r\n{$IFDEF UseSetOfChar}\r\n procedure EmitRangeCPrim (b : REChar); //###0.930\r\n  begin\r\n   if b in RangeSet\r\n    then EXIT;\r\n   inc (RangeLen);\r\n   if b < RangeChMin\r\n    then RangeChMin := b;\r\n   if b > RangeChMax\r\n    then RangeChMax := b;\r\n   Include (RangeSet, b);\r\n  end;\r\n {$ENDIF}\r\n\r\n procedure EmitRangeC (b : REChar);\r\n  {$IFDEF UseSetOfChar}\r\n  var\r\n   Ch : REChar;\r\n  {$ENDIF}\r\n  begin\r\n   CanBeRange := false;\r\n   {$IFDEF UseSetOfChar}\r\n    if b <> #0 then begin\r\n       EmitRangeCPrim (b); //###0.930\r\n       if RangeIsCI\r\n        then EmitRangeCPrim (InvertCase (b)); //###0.930\r\n      end\r\n     else begin\r\n       {$IFDEF UseAsserts}\r\n       Assert (RangeLen > 0, 'TRegExpr.ParseAtom(subroutine EmitRangeC): empty range'); // impossible, but who knows..\r\n       Assert (RangeChMin <= RangeChMax, 'TRegExpr.ParseAtom(subroutine EmitRangeC): RangeChMin > RangeChMax'); // impossible, but who knows..\r\n       {$ENDIF}\r\n       if RangeLen <= TinySetLen then begin // emit \"tiny set\"\r\n          if regcode = @regdummy then begin\r\n            regsize := RangePCodeIdx + TinySetLen; // RangeChMin/Max !!!\r\n            EXIT;\r\n           end;\r\n          regcode := RangePCodeBeg;\r\n          for Ch := RangeChMin to RangeChMax do //###0.930\r\n           if Ch in RangeSet then begin\r\n             regcode^ := Ch;\r\n             inc (regcode);\r\n            end;\r\n          // fill rest:\r\n          while regcode < RangePCodeBeg + TinySetLen do begin\r\n            regcode^ := RangeChMax;\r\n            inc (regcode);\r\n           end;\r\n         end\r\n        else begin\r\n          if regcode = @regdummy then begin\r\n            regsize := RangePCodeIdx + SizeOf (TSetOfREChar);\r\n            EXIT;\r\n           end;\r\n          if (RangePCodeBeg - REOpSz - RENextOffSz)^ = ANYBUTTINYSET\r\n           then RangeSet := [#0 .. #255] - RangeSet;\r\n          PREOp (RangePCodeBeg - REOpSz - RENextOffSz)^ := ANYOFFULLSET;\r\n          regcode := RangePCodeBeg;\r\n          Move (RangeSet, regcode^, SizeOf (TSetOfREChar));\r\n          inc (regcode, SizeOf (TSetOfREChar));\r\n         end;\r\n      end;\r\n   {$ELSE}\r\n   EmitC (b);\r\n   {$ENDIF}\r\n  end;\r\n\r\n procedure EmitSimpleRangeC (b : REChar);\r\n  begin\r\n   RangeBeg := b;\r\n   EmitRangeC (b);\r\n   CanBeRange := true;\r\n  end;\r\n\r\n procedure EmitRangeStr (const s : RegExprString);\r\n  var i : integer;\r\n  begin\r\n   for i := 1 to length (s)\r\n    do EmitRangeC (s [i]);\r\n  end;\r\n\r\n function UnQuoteChar (var APtr : PRegExprChar) : REChar; //###0.934\r\n  begin\r\n   case APtr^ of\r\n     't': Result := #$9;  // tab (HT/TAB)\r\n     'n': Result := #$a;  // newline (NL)\r\n     'r': Result := #$d;  // car.return (CR)\r\n     'f': Result := #$c;  // form feed (FF)\r\n     'a': Result := #$7;  // alarm (bell) (BEL)\r\n     'e': Result := #$1b; // escape (ESC)\r\n     'x': begin // hex char\r\n       Result := #0;\r\n       inc (APtr);\r\n       if APtr^ = #0 then begin\r\n         Error (reeNoHexCodeAfterBSlashX);\r\n         EXIT;\r\n        end;\r\n       if APtr^ = '{' then begin // \\x{nnnn} //###0.936\r\n          REPEAT\r\n           inc (APtr);\r\n           if APtr^ = #0 then begin\r\n             Error (reeNoHexCodeAfterBSlashX);\r\n             EXIT;\r\n            end;\r\n           if APtr^ <> '}' then begin\r\n              if (Ord (Result)\r\n                  ShR (SizeOf (REChar) * 8 - 4)) and $F <> 0 then begin\r\n                Error (reeHexCodeAfterBSlashXTooBig);\r\n                EXIT;\r\n               end;\r\n              Result := REChar ((Ord (Result) ShL 4) or HexDig (APtr^));\r\n              // HexDig will cause Error if bad hex digit found\r\n             end\r\n            else BREAK;\r\n          UNTIL False;\r\n         end\r\n        else begin\r\n          Result := REChar (HexDig (APtr^));\r\n          // HexDig will cause Error if bad hex digit found\r\n          inc (APtr);\r\n          if APtr^ = #0 then begin\r\n            Error (reeNoHexCodeAfterBSlashX);\r\n            EXIT;\r\n           end;\r\n          Result := REChar ((Ord (Result) ShL 4) or HexDig (APtr^));\r\n          // HexDig will cause Error if bad hex digit found\r\n         end;\r\n      end;\r\n     else Result := APtr^;\r\n    end;\r\n  end;\r\n\r\n begin\r\n  Result := nil;\r\n  flagp := WORST; // Tentatively.\r\n\r\n  inc (regparse);\r\n  case (regparse - 1)^ of\r\n    '^': if ((fCompModifiers and MaskModM) = 0)\r\n           or ((fLineSeparators = '') and not fLinePairedSeparatorAssigned)\r\n          then ret := EmitNode (BOL)\r\n          else ret := EmitNode (BOLML);\r\n    '$': if ((fCompModifiers and MaskModM) = 0)\r\n           or ((fLineSeparators = '') and not fLinePairedSeparatorAssigned)\r\n          then ret := EmitNode (EOL)\r\n          else ret := EmitNode (EOLML);\r\n    '.':\r\n       if (fCompModifiers and MaskModS) <> 0 then begin\r\n          ret := EmitNode (ANY);\r\n          flagp := flagp or HASWIDTH or SIMPLE;\r\n         end\r\n        else begin // not /s, so emit [^:LineSeparators:]\r\n          ret := EmitNode (ANYML);\r\n          flagp := flagp or HASWIDTH; // not so simple ;)\r\n//          ret := EmitRange (ANYBUT);\r\n//          EmitRangeStr (LineSeparators); //###0.941\r\n//          EmitRangeStr (LinePairedSeparator); // !!! isn't correct if have to accept only paired\r\n//          EmitRangeC (#0);\r\n//          flagp := flagp or HASWIDTH or SIMPLE;\r\n         end;\r\n    '[': begin\r\n        if regparse^ = '^' then begin // Complement of range.\r\n           if (fCompModifiers and MaskModI) <> 0\r\n            then ret := EmitRange (ANYBUTCI)\r\n            else ret := EmitRange (ANYBUT);\r\n           inc (regparse);\r\n          end\r\n         else\r\n          if (fCompModifiers and MaskModI) <> 0\r\n           then ret := EmitRange (ANYOFCI)\r\n           else ret := EmitRange (ANYOF);\r\n\r\n        CanBeRange := false;\r\n\r\n        if (regparse^ = ']') then begin\r\n          EmitSimpleRangeC (regparse^); // []-a] -> ']' .. 'a'\r\n          inc (regparse);\r\n         end;\r\n\r\n        while (regparse^ <> #0) and (regparse^ <> ']') do begin\r\n          if (regparse^ = '-')\r\n              and ((regparse + 1)^ <> #0) and ((regparse + 1)^ <> ']')\r\n              and CanBeRange then begin\r\n             inc (regparse);\r\n             RangeEnd := regparse^;\r\n             if RangeEnd = EscChar then begin\r\n               {$IFDEF SynRegUniCode} //###0.935\r\n               if (ord ((regparse + 1)^) < 256)\r\n                  and (ansichar ((regparse + 1)^)\r\n                        in ['d', 'D', 's', 'S', 'w', 'W']) then begin\r\n               {$ELSE}\r\n               if (regparse + 1)^ in ['d', 'D', 's', 'S', 'w', 'W'] then begin\r\n               {$ENDIF}\r\n                 EmitRangeC ('-'); // or treat as error ?!!\r\n                 CONTINUE;\r\n                end;\r\n               inc (regparse);\r\n               RangeEnd := UnQuoteChar (regparse);\r\n              end;\r\n\r\n             // r.e.ranges extension for russian\r\n             if ((fCompModifiers and MaskModR) <> 0)\r\n                and (RangeBeg = RusRangeLoLow) and (RangeEnd = RusRangeLoHigh) then begin\r\n               EmitRangeStr (RusRangeLo);\r\n              end\r\n             else if ((fCompModifiers and MaskModR) <> 0)\r\n                 and (RangeBeg = RusRangeHiLow) and (RangeEnd = RusRangeHiHigh) then begin\r\n               EmitRangeStr (RusRangeHi);\r\n              end\r\n             else if ((fCompModifiers and MaskModR) <> 0)\r\n                  and (RangeBeg = RusRangeLoLow) and (RangeEnd = RusRangeHiHigh) then begin\r\n               EmitRangeStr (RusRangeLo);\r\n               EmitRangeStr (RusRangeHi);\r\n              end\r\n             else begin // standard r.e. handling\r\n               if RangeBeg > RangeEnd then begin\r\n                 Error (reeInvalidRange);\r\n                 EXIT;\r\n                end;\r\n               inc (RangeBeg);\r\n               EmitRangeC (RangeEnd); // prevent infinite loop if RangeEnd=$ff\r\n               while RangeBeg < RangeEnd do begin //###0.929\r\n                 EmitRangeC (RangeBeg);\r\n                 inc (RangeBeg);\r\n                end;\r\n              end;\r\n             inc (regparse);\r\n            end\r\n           else begin\r\n             if regparse^ = EscChar then begin\r\n                inc (regparse);\r\n                if regparse^ = #0 then begin\r\n                  Error (reeParseAtomTrailingBackSlash);\r\n                  EXIT;\r\n                 end;\r\n                case regparse^ of // r.e.extensions\r\n                  'd': EmitRangeStr ('0123456789');\r\n                  'w': EmitRangeStr (WordChars);\r\n                  's': EmitRangeStr (SpaceChars);\r\n                  else EmitSimpleRangeC (UnQuoteChar (regparse));\r\n                 end; { of case}\r\n               end\r\n              else EmitSimpleRangeC (regparse^);\r\n             inc (regparse);\r\n            end;\r\n         end; { of while}\r\n        EmitRangeC (#0);\r\n        if regparse^ <> ']' then begin\r\n          Error (reeUnmatchedSqBrackets);\r\n          EXIT;\r\n         end;\r\n        inc (regparse);\r\n        flagp := flagp or HASWIDTH or SIMPLE;\r\n      end;\r\n    '(': begin\r\n        if regparse^ = '?' then begin\r\n           // check for extended Perl syntax : (?..)\r\n           if (regparse + 1)^ = '#' then begin // (?#comment)\r\n              inc (regparse, 2); // find closing ')'\r\n              while (regparse^ <> #0) and (regparse^ <> ')')\r\n               do inc (regparse);\r\n              if regparse^ <> ')' then begin\r\n                Error (reeUnclosedComment);\r\n                EXIT;\r\n               end;\r\n              inc (regparse); // skip ')'\r\n              ret := EmitNode (COMMENT); // comment\r\n             end\r\n           else begin // modifiers ?\r\n             inc (regparse); // skip '?'\r\n             begmodfs := regparse;\r\n             while (regparse^ <> #0) and (regparse^ <> ')')\r\n              do inc (regparse);\r\n             if (regparse^ <> ')')\r\n                or not ParseModifiersStr (copy (begmodfs, 1, (regparse - begmodfs)), fCompModifiers) then begin\r\n               Error (reeUrecognizedModifier);\r\n               EXIT;\r\n              end;\r\n             inc (regparse); // skip ')'\r\n             ret := EmitNode (COMMENT); // comment\r\n//             Error (reeQPSBFollowsNothing);\r\n//             EXIT;\r\n            end;\r\n          end\r\n         else begin\r\n           ret := ParseReg (1, flags);\r\n           if ret = nil then begin\r\n             Result := nil;\r\n             EXIT;\r\n            end;\r\n           flagp := flagp or flags and (HASWIDTH or SPSTART);\r\n          end;\r\n      end;\r\n    #0, '|', ')': begin // Supposed to be caught earlier.\r\n       Error (reeInternalUrp);\r\n       EXIT;\r\n      end;\r\n    '?', '+', '*': begin\r\n       Error (reeQPSBFollowsNothing);\r\n       EXIT;\r\n      end;\r\n    EscChar: begin\r\n        if regparse^ = #0 then begin\r\n          Error (reeTrailingBackSlash);\r\n          EXIT;\r\n         end;\r\n        case regparse^ of // r.e.extensions\r\n          'b': ret := EmitNode (BOUND); //###0.943\r\n          'B': ret := EmitNode (NOTBOUND); //###0.943\r\n          'A': ret := EmitNode (BOL); //###0.941\r\n          'Z': ret := EmitNode (EOL); //###0.941\r\n          'd': begin // r.e.extension - any digit ('0' .. '9')\r\n             ret := EmitNode (ANYDIGIT);\r\n             flagp := flagp or HASWIDTH or SIMPLE;\r\n            end;\r\n          'D': begin // r.e.extension - not digit ('0' .. '9')\r\n             ret := EmitNode (NOTDIGIT);\r\n             flagp := flagp or HASWIDTH or SIMPLE;\r\n            end;\r\n          's': begin // r.e.extension - any space char\r\n             {$IFDEF UseSetOfChar}\r\n             ret := EmitRange (ANYOF);\r\n             EmitRangeStr (SpaceChars);\r\n             EmitRangeC (#0);\r\n             {$ELSE}\r\n             ret := EmitNode (ANYSPACE);\r\n             {$ENDIF}\r\n             flagp := flagp or HASWIDTH or SIMPLE;\r\n            end;\r\n          'S': begin // r.e.extension - not space char\r\n             {$IFDEF UseSetOfChar}\r\n             ret := EmitRange (ANYBUT);\r\n             EmitRangeStr (SpaceChars);\r\n             EmitRangeC (#0);\r\n             {$ELSE}\r\n             ret := EmitNode (NOTSPACE);\r\n             {$ENDIF}\r\n             flagp := flagp or HASWIDTH or SIMPLE;\r\n            end;\r\n          'w': begin // r.e.extension - any english char / digit / '_'\r\n             {$IFDEF UseSetOfChar}\r\n             ret := EmitRange (ANYOF);\r\n             EmitRangeStr (WordChars);\r\n             EmitRangeC (#0);\r\n             {$ELSE}\r\n             ret := EmitNode (ANYLETTER);\r\n             {$ENDIF}\r\n             flagp := flagp or HASWIDTH or SIMPLE;\r\n            end;\r\n          'W': begin // r.e.extension - not english char / digit / '_'\r\n             {$IFDEF UseSetOfChar}\r\n             ret := EmitRange (ANYBUT);\r\n             EmitRangeStr (WordChars);\r\n             EmitRangeC (#0);\r\n             {$ELSE}\r\n             ret := EmitNode (NOTLETTER);\r\n             {$ENDIF}\r\n             flagp := flagp or HASWIDTH or SIMPLE;\r\n            end;\r\n           '1' .. '9': begin //###0.936\r\n             if (fCompModifiers and MaskModI) <> 0\r\n              then ret := EmitNode (BSUBEXPCI)\r\n              else ret := EmitNode (BSUBEXP);\r\n             EmitC (REChar (ord (regparse^) - ord ('0')));\r\n             flagp := flagp or HASWIDTH or SIMPLE;\r\n            end;\r\n          else EmitExactly (UnQuoteChar (regparse));\r\n         end; { of case}\r\n        inc (regparse);\r\n      end;\r\n    else begin\r\n      dec (regparse);\r\n      if ((fCompModifiers and MaskModX) <> 0) and // check for eXtended syntax\r\n          ((regparse^ = '#')\r\n           or ({$IFDEF SynRegUniCode}StrScan (XIgnoredChars, regparse^) <> nil //###0.947\r\n               {$ELSE}regparse^ in XIgnoredChars{$ENDIF})) then begin //###0.941 \\x\r\n         if regparse^ = '#' then begin // Skip eXtended comment\r\n            // find comment terminator (group of \\n and/or \\r)\r\n            while (regparse^ <> #0) and (regparse^ <> #$d) and (regparse^ <> #$a)\r\n             do inc (regparse);\r\n            while (regparse^ = #$d) or (regparse^ = #$a) // skip comment terminator\r\n             do inc (regparse); // attempt to support different type of line separators\r\n           end\r\n          else begin // Skip the blanks!\r\n            while {$IFDEF SynRegUniCode}StrScan (XIgnoredChars, regparse^) <> nil //###0.947\r\n                  {$ELSE}regparse^ in XIgnoredChars{$ENDIF}\r\n             do inc (regparse);\r\n           end;\r\n         ret := EmitNode (COMMENT); // comment\r\n        end\r\n       else begin\r\n         len := strcspn (regparse, META);\r\n         if len <= 0 then\r\n          if regparse^ <> '{' then begin\r\n             Error (reeRarseAtomInternalDisaster);\r\n             EXIT;\r\n            end\r\n           else len := strcspn (regparse + 1, META) + 1; // bad {n,m} - compile as EXATLY\r\n         ender := (regparse + len)^;\r\n         if (len > 1)\r\n            and ((ender = '*') or (ender = '+') or (ender = '?') or (ender = '{'))\r\n          then dec (len); // Back off clear of ?+*{ operand.\r\n         flagp := flagp or HASWIDTH;\r\n         if len = 1\r\n         then flagp := flagp or SIMPLE;\r\n         if (fCompModifiers and MaskModI) <> 0\r\n          then ret := EmitNode (EXACTLYCI)\r\n          else ret := EmitNode (EXACTLY);\r\n         while (len > 0)\r\n          and (((fCompModifiers and MaskModX) = 0) or (regparse^ <> '#')) do begin\r\n           if ((fCompModifiers and MaskModX) = 0) or not ( //###0.941\r\n              {$IFDEF SynRegUniCode}StrScan (XIgnoredChars, regparse^) <> nil //###0.947\r\n              {$ELSE}regparse^ in XIgnoredChars{$ENDIF} )\r\n            then EmitC (regparse^);\r\n           inc (regparse);\r\n           dec (len);\r\n          end;\r\n         EmitC (#0);\r\n        end; { of if not comment}\r\n     end; { of case else}\r\n   end; { of case}\r\n\r\n  Result := ret;\r\n end; { of function TRegExpr.ParseAtom\r\n--------------------------------------------------------------}\r\n\r\nfunction TRegExpr.GetCompilerErrorPos : integer;\r\n begin\r\n  Result := 0;\r\n  if (regexpbeg = nil) or (regparse = nil)\r\n   then EXIT; // not in compiling mode ?\r\n  Result := regparse - regexpbeg;\r\n end; { of function TRegExpr.GetCompilerErrorPos\r\n--------------------------------------------------------------}\r\n\r\n\r\n{=============================================================}\r\n{===================== Matching section ======================}\r\n{=============================================================}\r\n\r\n{$IFNDEF UseSetOfChar}\r\nfunction TRegExpr.StrScanCI (s : PRegExprChar; ch : REChar) : PRegExprChar; //###0.928 - now method of TRegExpr\r\n begin\r\n  while (s^ <> #0) and (s^ <> ch) and (s^ <> InvertCase (ch))\r\n   do inc (s);\r\n  if s^ <> #0\r\n   then Result := s\r\n   else Result := nil;\r\n end; { of function TRegExpr.StrScanCI\r\n--------------------------------------------------------------}\r\n{$ENDIF}\r\n\r\nfunction TRegExpr.regrepeat (p : PRegExprChar; AMax : integer) : integer;\r\n// repeatedly match something simple, report how many\r\n var\r\n  scan : PRegExprChar;\r\n  opnd : PRegExprChar;\r\n  TheMax : integer;\r\n  {Ch,} InvCh : REChar; //###0.931\r\n  sestart, seend : PRegExprChar; //###0.936\r\n begin\r\n  Result := 0;\r\n  scan := reginput;\r\n  opnd := p + REOpSz + RENextOffSz; //OPERAND\r\n  TheMax := fInputEnd - scan;\r\n  if TheMax > AMax\r\n   then TheMax := AMax;\r\n  case PREOp (p)^ of\r\n    ANY: begin\r\n    // note - ANYML cannot be proceeded in regrepeat because can skip\r\n    // more than one char at once\r\n      Result := TheMax;\r\n      inc (scan, Result);\r\n     end;\r\n    EXACTLY: begin // in opnd can be only ONE char !!!\r\n//      Ch := opnd^; // store in register //###0.931\r\n      while (Result < TheMax) and (opnd^ = scan^) do begin\r\n        inc (Result);\r\n        inc (scan);\r\n       end;\r\n     end;\r\n    EXACTLYCI: begin // in opnd can be only ONE char !!!\r\n//      Ch := opnd^; // store in register //###0.931\r\n      while (Result < TheMax) and (opnd^ = scan^) do begin // prevent unneeded InvertCase //###0.931\r\n        inc (Result);\r\n        inc (scan);\r\n       end;\r\n      if Result < TheMax then begin //###0.931\r\n        InvCh := InvertCase (opnd^); // store in register\r\n        while (Result < TheMax) and\r\n              ((opnd^ = scan^) or (InvCh = scan^)) do begin\r\n          inc (Result);\r\n          inc (scan);\r\n         end;\r\n       end;\r\n     end;\r\n    BSUBEXP: begin //###0.936\r\n      sestart := startp [ord (opnd^)];\r\n      if sestart = nil\r\n       then EXIT;\r\n      seend := endp [ord (opnd^)];\r\n      if seend = nil\r\n       then EXIT;\r\n      REPEAT\r\n        opnd := sestart;\r\n        while opnd < seend do begin\r\n          if (scan >= fInputEnd) or (scan^ <> opnd^)\r\n           then EXIT;\r\n          inc (scan);\r\n          inc (opnd);\r\n         end;\r\n        inc (Result);\r\n        reginput := scan;\r\n      UNTIL Result >= AMax;\r\n     end;\r\n    BSUBEXPCI: begin //###0.936\r\n      sestart := startp [ord (opnd^)];\r\n      if sestart = nil\r\n       then EXIT;\r\n      seend := endp [ord (opnd^)];\r\n      if seend = nil\r\n       then EXIT;\r\n      REPEAT\r\n        opnd := sestart;\r\n        while opnd < seend do begin\r\n          if (scan >= fInputEnd) or\r\n             ((scan^ <> opnd^) and (scan^ <> InvertCase (opnd^)))\r\n           then EXIT;\r\n          inc (scan);\r\n          inc (opnd);\r\n         end;\r\n        inc (Result);\r\n        reginput := scan;\r\n      UNTIL Result >= AMax;\r\n     end;\r\n    ANYDIGIT:\r\n      while (Result < TheMax) and\r\n         (scan^ >= '0') and (scan^ <= '9') do begin\r\n        inc (Result);\r\n        inc (scan);\r\n       end;\r\n    NOTDIGIT:\r\n      while (Result < TheMax) and\r\n         ((scan^ < '0') or (scan^ > '9')) do begin\r\n        inc (Result);\r\n        inc (scan);\r\n       end;\r\n    {$IFNDEF UseSetOfChar} //###0.929\r\n    ANYLETTER:\r\n      while (Result < TheMax) and\r\n       (Pos (scan^, fWordChars) > 0) //###0.940\r\n     {  ((scan^ >= 'a') and (scan^ <= 'z') !! I've forgotten (>='0') and (<='9')\r\n       or (scan^ >= 'A') and (scan^ <= 'Z') or (scan^ = '_'))} do begin\r\n        inc (Result);\r\n        inc (scan);\r\n       end;\r\n    NOTLETTER:\r\n      while (Result < TheMax) and\r\n       (Pos (scan^, fWordChars) <= 0)  //###0.940\r\n     {   not ((scan^ >= 'a') and (scan^ <= 'z') !! I've forgotten (>='0') and (<='9')\r\n         or (scan^ >= 'A') and (scan^ <= 'Z')\r\n         or (scan^ = '_'))} do begin\r\n        inc (Result);\r\n        inc (scan);\r\n       end;\r\n    ANYSPACE:\r\n      while (Result < TheMax) and\r\n         (Pos (scan^, fSpaceChars) > 0) do begin\r\n        inc (Result);\r\n        inc (scan);\r\n       end;\r\n    NOTSPACE:\r\n      while (Result < TheMax) and\r\n         (Pos (scan^, fSpaceChars) <= 0) do begin\r\n        inc (Result);\r\n        inc (scan);\r\n       end;\r\n    {$ENDIF}\r\n    ANYOFTINYSET: begin\r\n      while (Result < TheMax) and //!!!TinySet\r\n       ((scan^ = opnd^) or (scan^ = (opnd + 1)^)\r\n        or (scan^ = (opnd + 2)^)) do begin\r\n        inc (Result);\r\n        inc (scan);\r\n       end;\r\n     end;\r\n    ANYBUTTINYSET: begin\r\n      while (Result < TheMax) and //!!!TinySet\r\n       (scan^ <> opnd^) and (scan^ <> (opnd + 1)^)\r\n        and (scan^ <> (opnd + 2)^) do begin\r\n        inc (Result);\r\n        inc (scan);\r\n       end;\r\n     end;\r\n    {$IFDEF UseSetOfChar} //###0.929\r\n    ANYOFFULLSET: begin\r\n      while (Result < TheMax) and\r\n       (scan^ in PSetOfREChar (opnd)^) do begin\r\n        inc (Result);\r\n        inc (scan);\r\n       end;\r\n     end;\r\n    {$ELSE}\r\n    ANYOF:\r\n      while (Result < TheMax) and\r\n         (StrScan (opnd, scan^) <> nil) do begin\r\n        inc (Result);\r\n        inc (scan);\r\n       end;\r\n    ANYBUT:\r\n      while (Result < TheMax) and\r\n         (StrScan (opnd, scan^) = nil) do begin\r\n        inc (Result);\r\n        inc (scan);\r\n       end;\r\n    ANYOFCI:\r\n      while (Result < TheMax) and (StrScanCI (opnd, scan^) <> nil) do begin\r\n        inc (Result);\r\n        inc (scan);\r\n       end;\r\n    ANYBUTCI:\r\n      while (Result < TheMax) and (StrScanCI (opnd, scan^) = nil) do begin\r\n        inc (Result);\r\n        inc (scan);\r\n       end;\r\n    {$ENDIF}\r\n    else begin // Oh dear. Called inappropriately.\r\n      Result := 0; // Best compromise.\r\n      Error (reeRegRepeatCalledInappropriately);\r\n      EXIT;\r\n     end;\r\n   end; { of case}\r\n  reginput := scan;\r\n end; { of function TRegExpr.regrepeat\r\n--------------------------------------------------------------}\r\n\r\nfunction TRegExpr.regnext (p : PRegExprChar) : PRegExprChar;\r\n// dig the \"next\" pointer out of a node\r\n var offset : TRENextOff;\r\n begin\r\n  if p = @regdummy then begin\r\n    Result := nil;\r\n    EXIT;\r\n   end;\r\n  offset := PRENextOff (p + REOpSz)^; //###0.933 inlined NEXT\r\n  if offset = 0\r\n   then Result := nil\r\n   else Result := p + offset;\r\n end; { of function TRegExpr.regnext\r\n--------------------------------------------------------------}\r\n\r\nfunction TRegExpr.MatchPrim (prog : PRegExprChar) : boolean;\r\n// recursively matching routine\r\n// Conceptually the strategy is simple:  check to see whether the current\r\n// node matches, call self recursively to see whether the rest matches,\r\n// and then act accordingly.  In practice we make some effort to avoid\r\n// recursion, in particular by going through \"ordinary\" nodes (that don't\r\n// need to know whether the rest of the match failed) by a loop instead of\r\n// by recursion.\r\n var\r\n  scan : PRegExprChar; // Current node.\r\n  next : PRegExprChar; // Next node.\r\n  len : integer;\r\n  opnd : PRegExprChar;\r\n  no : integer;\r\n  save : PRegExprChar;\r\n  nextch : REChar;\r\n  BracesMin, BracesMax : integer; // we use integer instead of TREBracesArg for better support */+\r\n  {$IFDEF ComplexBraces}\r\n  SavedLoopStack : array [1 .. LoopStackMax] of integer; // :(( very bad for recursion\r\n  SavedLoopStackIdx : integer; //###0.925\r\n  {$ENDIF}\r\n begin\r\n  Result := false;\r\n  scan := prog;\r\n\r\n  while scan <> nil do begin\r\n     len := PRENextOff (scan + 1)^; //###0.932 inlined regnext\r\n     if len = 0\r\n      then next := nil\r\n      else next := scan + len;\r\n\r\n     case scan^ of\r\n         NOTBOUND, //###0.943 //!!! think about UseSetOfChar !!!\r\n         BOUND:\r\n         if (scan^ = BOUND)\r\n          xor (\r\n          ((reginput = fInputStart) or (Pos ((reginput - 1)^, fWordChars) <= 0))\r\n            and (reginput^ <> #0) and (Pos (reginput^, fWordChars) > 0)\r\n           or\r\n            (reginput <> fInputStart) and (Pos ((reginput - 1)^, fWordChars) > 0)\r\n            and ((reginput^ = #0) or (Pos (reginput^, fWordChars) <= 0)))\r\n          then EXIT;\r\n\r\n         BOL: if reginput <> fInputStart\r\n               then EXIT;\r\n         EOL: if reginput^ <> #0\r\n               then EXIT;\r\n         BOLML: if reginput > fInputStart then begin\r\n            nextch := (reginput - 1)^;\r\n            if (nextch <> fLinePairedSeparatorTail)\r\n               or ((reginput - 1) <= fInputStart)\r\n               or ((reginput - 2)^ <> fLinePairedSeparatorHead)\r\n              then begin\r\n               if (nextch = fLinePairedSeparatorHead)\r\n                 and (reginput^ = fLinePairedSeparatorTail)\r\n                then EXIT; // don't stop between paired separator\r\n               if\r\n                 {$IFNDEF SynRegUniCode}\r\n                 not (nextch in fLineSeparatorsSet)\r\n                 {$ELSE}\r\n                 (pos (nextch, fLineSeparators) <= 0)\r\n                 {$ENDIF}\r\n                then EXIT;\r\n              end;\r\n           end;\r\n         EOLML: if reginput^ <> #0 then begin\r\n            nextch := reginput^;\r\n            if (nextch <> fLinePairedSeparatorHead)\r\n               or ((reginput + 1)^ <> fLinePairedSeparatorTail)\r\n             then begin\r\n               if (nextch = fLinePairedSeparatorTail)\r\n                 and (reginput > fInputStart)\r\n                 and ((reginput - 1)^ = fLinePairedSeparatorHead)\r\n                then EXIT; // don't stop between paired separator\r\n               if\r\n                 {$IFNDEF SynRegUniCode}\r\n                 not (nextch in fLineSeparatorsSet)\r\n                 {$ELSE}\r\n                 (pos (nextch, fLineSeparators) <= 0)\r\n                 {$ENDIF}\r\n                then EXIT;\r\n              end;\r\n           end;\r\n         ANY: begin\r\n            if reginput^ = #0\r\n             then EXIT;\r\n            inc (reginput);\r\n           end;\r\n         ANYML: begin //###0.941\r\n            if (reginput^ = #0)\r\n             or ((reginput^ = fLinePairedSeparatorHead)\r\n                 and ((reginput + 1)^ = fLinePairedSeparatorTail))\r\n             or {$IFNDEF SynRegUniCode} (reginput^ in fLineSeparatorsSet)\r\n                {$ELSE} (pos (reginput^, fLineSeparators) > 0) {$ENDIF}\r\n             then EXIT;\r\n            inc (reginput);\r\n           end;\r\n         ANYDIGIT: begin\r\n            if (reginput^ = #0) or (reginput^ < '0') or (reginput^ > '9')\r\n             then EXIT;\r\n            inc (reginput);\r\n           end;\r\n         NOTDIGIT: begin\r\n            if (reginput^ = #0) or ((reginput^ >= '0') and (reginput^ <= '9'))\r\n             then EXIT;\r\n            inc (reginput);\r\n           end;\r\n         {$IFNDEF UseSetOfChar} //###0.929\r\n         ANYLETTER: begin\r\n            if (reginput^ = #0) or (Pos (reginput^, fWordChars) <= 0) //###0.943\r\n             then EXIT;\r\n            inc (reginput);\r\n           end;\r\n         NOTLETTER: begin\r\n            if (reginput^ = #0) or (Pos (reginput^, fWordChars) > 0) //###0.943\r\n             then EXIT;\r\n            inc (reginput);\r\n           end;\r\n         ANYSPACE: begin\r\n            if (reginput^ = #0) or not (Pos (reginput^, fSpaceChars) > 0) //###0.943\r\n             then EXIT;\r\n            inc (reginput);\r\n           end;\r\n         NOTSPACE: begin\r\n            if (reginput^ = #0) or (Pos (reginput^, fSpaceChars) > 0) //###0.943\r\n             then EXIT;\r\n            inc (reginput);\r\n           end;\r\n         {$ENDIF}\r\n         EXACTLYCI: begin\r\n            opnd := scan + REOpSz + RENextOffSz; // OPERAND\r\n            // Inline the first character, for speed.\r\n            if (opnd^ <> reginput^)\r\n               and (InvertCase (opnd^) <> reginput^)\r\n             then EXIT;\r\n            len := strlen (opnd);\r\n            //###0.929 begin\r\n            no := len;\r\n            save := reginput;\r\n            while no > 1 do begin\r\n              inc (save);\r\n              inc (opnd);\r\n              if (opnd^ <> save^)\r\n                 and (InvertCase (opnd^) <> save^)\r\n               then EXIT;\r\n              dec (no);\r\n             end;\r\n            //###0.929 end\r\n            inc (reginput, len);\r\n           end;\r\n         EXACTLY: begin\r\n            opnd := scan + REOpSz + RENextOffSz; // OPERAND\r\n            // Inline the first character, for speed.\r\n            if opnd^ <> reginput^\r\n             then EXIT;\r\n            len := strlen (opnd);\r\n            //###0.929 begin\r\n            no := len;\r\n            save := reginput;\r\n            while no > 1 do begin\r\n              inc (save);\r\n              inc (opnd);\r\n              if opnd^ <> save^\r\n               then EXIT;\r\n              dec (no);\r\n             end;\r\n            //###0.929 end\r\n            inc (reginput, len);\r\n           end;\r\n         BSUBEXP: begin //###0.936\r\n           no := ord ((scan + REOpSz + RENextOffSz)^);\r\n           if startp [no] = nil\r\n            then EXIT;\r\n           if endp [no] = nil\r\n            then EXIT;\r\n           save := reginput;\r\n           opnd := startp [no];\r\n           while opnd < endp [no] do begin\r\n             if (save >= fInputEnd) or (save^ <> opnd^)\r\n              then EXIT;\r\n             inc (save);\r\n             inc (opnd);\r\n            end;\r\n           reginput := save;\r\n          end;\r\n         BSUBEXPCI: begin //###0.936\r\n           no := ord ((scan + REOpSz + RENextOffSz)^);\r\n           if startp [no] = nil\r\n            then EXIT;\r\n           if endp [no] = nil\r\n            then EXIT;\r\n           save := reginput;\r\n           opnd := startp [no];\r\n           while opnd < endp [no] do begin\r\n             if (save >= fInputEnd) or\r\n                ((save^ <> opnd^) and (save^ <> InvertCase (opnd^)))\r\n              then EXIT;\r\n             inc (save);\r\n             inc (opnd);\r\n            end;\r\n           reginput := save;\r\n          end;\r\n         ANYOFTINYSET: begin\r\n           if (reginput^ = #0) or //!!!TinySet\r\n             ((reginput^ <> (scan + REOpSz + RENextOffSz)^)\r\n             and (reginput^ <> (scan + REOpSz + RENextOffSz + 1)^)\r\n             and (reginput^ <> (scan + REOpSz + RENextOffSz + 2)^))\r\n            then EXIT;\r\n           inc (reginput);\r\n          end;\r\n         ANYBUTTINYSET: begin\r\n           if (reginput^ = #0) or //!!!TinySet\r\n             (reginput^ = (scan + REOpSz + RENextOffSz)^)\r\n             or (reginput^ = (scan + REOpSz + RENextOffSz + 1)^)\r\n             or (reginput^ = (scan + REOpSz + RENextOffSz + 2)^)\r\n            then EXIT;\r\n           inc (reginput);\r\n          end;\r\n         {$IFDEF UseSetOfChar} //###0.929\r\n         ANYOFFULLSET: begin\r\n           if (reginput^ = #0)\r\n              or not (reginput^ in PSetOfREChar (scan + REOpSz + RENextOffSz)^)\r\n            then EXIT;\r\n           inc (reginput);\r\n          end;\r\n         {$ELSE}\r\n         ANYOF: begin\r\n            if (reginput^ = #0) or (StrScan (scan + REOpSz + RENextOffSz, reginput^) = nil)\r\n             then EXIT;\r\n            inc (reginput);\r\n           end;\r\n         ANYBUT: begin\r\n            if (reginput^ = #0) or (StrScan (scan + REOpSz + RENextOffSz, reginput^) <> nil)\r\n             then EXIT;\r\n            inc (reginput);\r\n           end;\r\n         ANYOFCI: begin\r\n            if (reginput^ = #0) or (StrScanCI (scan + REOpSz + RENextOffSz, reginput^) = nil)\r\n             then EXIT;\r\n            inc (reginput);\r\n           end;\r\n         ANYBUTCI: begin\r\n            if (reginput^ = #0) or (StrScanCI (scan + REOpSz + RENextOffSz, reginput^) <> nil)\r\n             then EXIT;\r\n            inc (reginput);\r\n           end;\r\n         {$ENDIF}\r\n         NOTHING: ;\r\n         COMMENT: ;\r\n         BACK: ;\r\n         Succ (OPEN) .. TREOp (Ord (OPEN) + NSUBEXP - 1) : begin //###0.929\r\n            no := ord (scan^) - ord (OPEN);\r\n//            save := reginput;\r\n            save := startp [no]; //###0.936\r\n            startp [no] := reginput; //###0.936\r\n            Result := MatchPrim (next);\r\n            if not Result //###0.936\r\n             then startp [no] := save;\r\n//            if Result and (startp [no] = nil)\r\n//             then startp [no] := save;\r\n             // Don't set startp if some later invocation of the same\r\n             // parentheses already has.\r\n            EXIT;\r\n           end;\r\n         Succ (CLOSE) .. TREOp (Ord (CLOSE) + NSUBEXP - 1): begin //###0.929\r\n            no := ord (scan^) - ord (CLOSE);\r\n//            save := reginput;\r\n            save := endp [no]; //###0.936\r\n            endp [no] := reginput; //###0.936\r\n            Result := MatchPrim (next);\r\n            if not Result //###0.936\r\n             then endp [no] := save;\r\n//            if Result and (endp [no] = nil)\r\n//             then endp [no] := save;\r\n             // Don't set endp if some later invocation of the same\r\n             // parentheses already has.\r\n            EXIT;\r\n           end;\r\n         BRANCH: begin\r\n            if (next^ <> BRANCH) // No choice.\r\n             then next := scan + REOpSz + RENextOffSz // Avoid recursion\r\n             else begin\r\n               REPEAT\r\n                save := reginput;\r\n                Result := MatchPrim (scan + REOpSz + RENextOffSz);\r\n                if Result\r\n                 then EXIT;\r\n                reginput := save;\r\n                scan := regnext (scan);\r\n               UNTIL (scan = nil) or (scan^ <> BRANCH);\r\n               EXIT;\r\n              end;\r\n           end;\r\n         {$IFDEF ComplexBraces}\r\n         LOOPENTRY: begin //###0.925\r\n           no := LoopStackIdx;\r\n           inc (LoopStackIdx);\r\n           if LoopStackIdx > LoopStackMax then begin\r\n             Error (reeLoopStackExceeded);\r\n             EXIT;\r\n            end;\r\n           save := reginput;\r\n           LoopStack [LoopStackIdx] := 0; // init loop counter\r\n           Result := MatchPrim (next); // execute LOOP\r\n           LoopStackIdx := no; // cleanup\r\n           if Result\r\n            then EXIT;\r\n           reginput := save;\r\n           EXIT;\r\n          end;\r\n         LOOP, LOOPNG: begin //###0.940\r\n           if LoopStackIdx <= 0 then begin\r\n             Error (reeLoopWithoutEntry);\r\n             EXIT;\r\n            end;\r\n           opnd := scan + PRENextOff (scan + REOpSz + RENextOffSz + 2 * REBracesArgSz)^;\r\n           BracesMin := PREBracesArg (scan + REOpSz + RENextOffSz)^;\r\n           BracesMax := PREBracesArg (scan + REOpSz + RENextOffSz + REBracesArgSz)^;\r\n           save := reginput;\r\n           if LoopStack [LoopStackIdx] >= BracesMin then begin // Min alredy matched - we can work\r\n              if scan^ = LOOP then begin\r\n                 // greedy way - first try to max deep of greed ;)\r\n                 if LoopStack [LoopStackIdx] < BracesMax then begin\r\n                   inc (LoopStack [LoopStackIdx]);\r\n                   no := LoopStackIdx;\r\n                   Result := MatchPrim (opnd);\r\n                   LoopStackIdx := no;\r\n                   if Result\r\n                    then EXIT;\r\n                   reginput := save;\r\n                  end;\r\n                 dec (LoopStackIdx); // Fail. May be we are too greedy? ;)\r\n                 Result := MatchPrim (next);\r\n                 if not Result\r\n                  then reginput := save;\r\n                 EXIT;\r\n                end\r\n               else begin\r\n                 // non-greedy - try just now\r\n                 Result := MatchPrim (next);\r\n                 if Result\r\n                  then EXIT\r\n                  else reginput := save; // failed - move next and try again\r\n                 if LoopStack [LoopStackIdx] < BracesMax then begin\r\n                   inc (LoopStack [LoopStackIdx]);\r\n                   no := LoopStackIdx;\r\n                   Result := MatchPrim (opnd);\r\n                   LoopStackIdx := no;\r\n                   if Result\r\n                    then EXIT;\r\n                   reginput := save;\r\n                  end;\r\n                 dec (LoopStackIdx); // Failed - back up\r\n                 EXIT;\r\n                end\r\n             end\r\n            else begin // first match a min_cnt times\r\n              inc (LoopStack [LoopStackIdx]);\r\n              no := LoopStackIdx;\r\n              Result := MatchPrim (opnd);\r\n              LoopStackIdx := no;\r\n              if Result\r\n               then EXIT;\r\n              dec (LoopStack [LoopStackIdx]);\r\n              reginput := save;\r\n              EXIT;\r\n             end;\r\n          end;\r\n         {$ENDIF}\r\n         STAR, PLUS, BRACES, STARNG, PLUSNG, BRACESNG: begin\r\n           // Lookahead to avoid useless match attempts when we know\r\n           // what character comes next.\r\n           nextch := #0;\r\n           if next^ = EXACTLY\r\n            then nextch := (next + REOpSz + RENextOffSz)^;\r\n           BracesMax := MaxInt; // infinite loop for * and + //###0.92\r\n           if (scan^ = STAR) or (scan^ = STARNG)\r\n            then BracesMin := 0  // STAR\r\n            else if (scan^ = PLUS) or (scan^ = PLUSNG)\r\n             then BracesMin := 1 // PLUS\r\n             else begin // BRACES\r\n               BracesMin := PREBracesArg (scan + REOpSz + RENextOffSz)^;\r\n               BracesMax := PREBracesArg (scan + REOpSz + RENextOffSz + REBracesArgSz)^;\r\n              end;\r\n           save := reginput;\r\n           opnd := scan + REOpSz + RENextOffSz;\r\n           if (scan^ = BRACES) or (scan^ = BRACESNG)\r\n            then inc (opnd, 2 * REBracesArgSz);\r\n\r\n           if (scan^ = PLUSNG) or (scan^ = STARNG) or (scan^ = BRACESNG) then begin\r\n             // non-greedy mode\r\n              BracesMax := regrepeat (opnd, BracesMax); // don't repeat more than BracesMax\r\n              // Now we know real Max limit to move forward (for recursion 'back up')\r\n              // In some cases it can be faster to check only Min positions first,\r\n              // but after that we have to check every position separtely instead\r\n              // of fast scannig in loop.\r\n              no := BracesMin;\r\n              while no <= BracesMax do begin\r\n                reginput := save + no;\r\n                // If it could work, try it.\r\n                if (nextch = #0) or (reginput^ = nextch) then begin\r\n                  {$IFDEF ComplexBraces}\r\n                  System.Move (LoopStack, SavedLoopStack, SizeOf (LoopStack)); //###0.925\r\n                  SavedLoopStackIdx := LoopStackIdx;\r\n                  {$ENDIF}\r\n                  if MatchPrim (next) then begin\r\n                    Result := true;\r\n                    EXIT;\r\n                   end;\r\n                  {$IFDEF ComplexBraces}\r\n                  System.Move (SavedLoopStack, LoopStack, SizeOf (LoopStack));\r\n                  LoopStackIdx := SavedLoopStackIdx;\r\n                  {$ENDIF}\r\n                 end;\r\n                inc (no); // Couldn't or didn't - move forward.\r\n               end; { of while}\r\n              EXIT;\r\n             end\r\n            else begin // greedy mode\r\n              no := regrepeat (opnd, BracesMax); // don't repeat more than max_cnt\r\n              while no >= BracesMin do begin\r\n                // If it could work, try it.\r\n                if (nextch = #0) or (reginput^ = nextch) then begin\r\n                  {$IFDEF ComplexBraces}\r\n                  System.Move (LoopStack, SavedLoopStack, SizeOf (LoopStack)); //###0.925\r\n                  SavedLoopStackIdx := LoopStackIdx;\r\n                  {$ENDIF}\r\n                  if MatchPrim (next) then begin\r\n                    Result := true;\r\n                    EXIT;\r\n                   end;\r\n                  {$IFDEF ComplexBraces}\r\n                  System.Move (SavedLoopStack, LoopStack, SizeOf (LoopStack));\r\n                  LoopStackIdx := SavedLoopStackIdx;\r\n                  {$ENDIF}\r\n                 end;\r\n                dec (no); // Couldn't or didn't - back up.\r\n                reginput := save + no;\r\n               end; { of while}\r\n              EXIT;\r\n             end;\r\n          end;\r\n         EEND: begin\r\n           Result := true;  // Success!\r\n           EXIT;\r\n          end;\r\n        else begin\r\n            Error (reeMatchPrimMemoryCorruption);\r\n            EXIT;\r\n          end;\r\n        end; { of case scan^}\r\n        scan := next;\r\n    end; { of while scan <> nil}\r\n\r\n  // We get here only if there's trouble -- normally \"case EEND\" is the\r\n  // terminating point.\r\n  Error (reeMatchPrimCorruptedPointers);\r\n end; { of function TRegExpr.MatchPrim\r\n--------------------------------------------------------------}\r\n\r\n{$IFDEF UseFirstCharSet} //###0.929\r\nprocedure TRegExpr.FillFirstCharSet (prog : PRegExprChar);\r\n var\r\n  scan : PRegExprChar; // Current node.\r\n  next : PRegExprChar; // Next node.\r\n  opnd : PRegExprChar;\r\n  min_cnt : integer;\r\n begin\r\n  scan := prog;\r\n  while scan <> nil do begin\r\n     next := regnext (scan);\r\n     case PREOp (scan)^ of\r\n         BSUBEXP, BSUBEXPCI: begin //###0.938\r\n           FirstCharSet := [#0 .. #255]; // :((( we cannot\r\n           // optimize r.e. if it starts with back reference\r\n           EXIT;\r\n          end;\r\n         BOL, BOLML: ; // EXIT; //###0.937\r\n         EOL, EOLML: begin //###0.948 was empty in 0.947, was EXIT in 0.937\r\n           Include (FirstCharSet, #0);\r\n           if ModifierM\r\n            then begin\r\n              opnd := PRegExprChar (LineSeparators);\r\n              while opnd^ <> #0 do begin\r\n                Include (FirstCharSet, opnd^);\r\n                inc (opnd);\r\n              end;\r\n            end;\r\n           EXIT;\r\n         end;\r\n         BOUND, NOTBOUND: ; //###0.943 ?!!\r\n         ANY, ANYML: begin // we can better define ANYML !!!\r\n           FirstCharSet := [#0 .. #255]; //###0.930\r\n           EXIT;\r\n          end;\r\n         ANYDIGIT: begin\r\n           FirstCharSet := FirstCharSet + ['0' .. '9'];\r\n           EXIT;\r\n          end;\r\n         NOTDIGIT: begin\r\n           FirstCharSet := FirstCharSet + ([#0 .. #255] - ['0' .. '9']); //###0.948 FirstCharSet was forgotten\r\n           EXIT;\r\n          end;\r\n         EXACTLYCI: begin\r\n           Include (FirstCharSet, (scan + REOpSz + RENextOffSz)^);\r\n           Include (FirstCharSet, InvertCase ((scan + REOpSz + RENextOffSz)^));\r\n           EXIT;\r\n          end;\r\n         EXACTLY: begin\r\n           Include (FirstCharSet, (scan + REOpSz + RENextOffSz)^);\r\n           EXIT;\r\n          end;\r\n         ANYOFFULLSET: begin\r\n           FirstCharSet := FirstCharSet + PSetOfREChar (scan + REOpSz + RENextOffSz)^;\r\n           EXIT;\r\n          end;\r\n         ANYOFTINYSET: begin\r\n           //!!!TinySet\r\n           Include (FirstCharSet, (scan + REOpSz + RENextOffSz)^);\r\n           Include (FirstCharSet, (scan + REOpSz + RENextOffSz + 1)^);\r\n           Include (FirstCharSet, (scan + REOpSz + RENextOffSz + 2)^);\r\n           // ...                                                      // up to TinySetLen\r\n           EXIT;\r\n          end;\r\n         ANYBUTTINYSET: begin\r\n           //!!!TinySet\r\n           FirstCharSet := FirstCharSet + ([#0 .. #255] - [ //###0.948 FirstCharSet was forgotten\r\n            (scan + REOpSz + RENextOffSz)^,\r\n            (scan + REOpSz + RENextOffSz + 1)^,\r\n            (scan + REOpSz + RENextOffSz + 2)^]);\r\n           // ...                                                      // up to TinySetLen\r\n           EXIT;\r\n          end;\r\n         NOTHING: ;\r\n         COMMENT: ;\r\n         BACK: ;\r\n         Succ (OPEN) .. TREOp (Ord (OPEN) + NSUBEXP - 1) : begin //###0.929\r\n            FillFirstCharSet (next);\r\n            EXIT;\r\n           end;\r\n         Succ (CLOSE) .. TREOp (Ord (CLOSE) + NSUBEXP - 1): begin //###0.929\r\n            FillFirstCharSet (next);\r\n            EXIT;\r\n           end;\r\n         BRANCH: begin\r\n            if (PREOp (next)^ <> BRANCH) // No choice.\r\n             then next := scan + REOpSz + RENextOffSz // Avoid recursion.\r\n             else begin\r\n               REPEAT\r\n                FillFirstCharSet (scan + REOpSz + RENextOffSz);\r\n                scan := regnext (scan);\r\n               UNTIL (scan = nil) or (PREOp (scan)^ <> BRANCH);\r\n               EXIT;\r\n              end;\r\n           end;\r\n         {$IFDEF ComplexBraces}\r\n         LOOPENTRY: begin //###0.925\r\n//           LoopStack [LoopStackIdx] := 0; //###0.940 line removed\r\n           FillFirstCharSet (next); // execute LOOP\r\n           EXIT;\r\n          end;\r\n         LOOP, LOOPNG: begin //###0.940\r\n           opnd := scan + PRENextOff (scan + REOpSz + RENextOffSz + REBracesArgSz * 2)^;\r\n           min_cnt := PREBracesArg (scan + REOpSz + RENextOffSz)^;\r\n           FillFirstCharSet (opnd);\r\n           if min_cnt = 0\r\n            then FillFirstCharSet (next);\r\n           EXIT;\r\n          end;\r\n         {$ENDIF}\r\n         STAR, STARNG: //###0.940\r\n           FillFirstCharSet (scan + REOpSz + RENextOffSz);\r\n         PLUS, PLUSNG: begin //###0.940\r\n           FillFirstCharSet (scan + REOpSz + RENextOffSz);\r\n           EXIT;\r\n          end;\r\n         BRACES, BRACESNG: begin //###0.940\r\n           opnd := scan + REOpSz + RENextOffSz + REBracesArgSz * 2;\r\n           min_cnt := PREBracesArg (scan + REOpSz + RENextOffSz)^; // BRACES\r\n           FillFirstCharSet (opnd);\r\n           if min_cnt > 0\r\n            then EXIT;\r\n          end;\r\n         EEND: begin\r\n            FirstCharSet := [#0 .. #255]; //###0.948\r\n            EXIT;\r\n           end;\r\n        else begin\r\n            Error (reeMatchPrimMemoryCorruption);\r\n            EXIT;\r\n          end;\r\n        end; { of case scan^}\r\n        scan := next;\r\n    end; { of while scan <> nil}\r\n end; { of procedure FillFirstCharSet\r\n--------------------------------------------------------------}\r\n{$ENDIF}\r\n\r\nfunction TRegExpr.Exec (const AInputString : RegExprString) : boolean;\r\n begin\r\n  InputString := AInputString;\r\n  Result := ExecPrim (1);\r\n end; { of function TRegExpr.Exec\r\n--------------------------------------------------------------}\r\n\r\n{$IFDEF OverMeth}\r\n{$IFNDEF FPC}\r\nfunction TRegExpr.Exec : boolean;\r\n begin\r\n  Result := ExecPrim (1);\r\n end; { of function TRegExpr.Exec\r\n--------------------------------------------------------------}\r\n{$ENDIF}\r\nfunction TRegExpr.Exec (AOffset: integer) : boolean;\r\n begin\r\n  Result := ExecPrim (AOffset);\r\n end; { of function TRegExpr.Exec\r\n--------------------------------------------------------------}\r\n{$ENDIF}\r\n\r\nfunction TRegExpr.ExecPos (AOffset: integer {$IFDEF DefParam}= 1{$ENDIF}) : boolean;\r\n begin\r\n  Result := ExecPrim (AOffset);\r\n end; { of function TRegExpr.ExecPos\r\n--------------------------------------------------------------}\r\n\r\nfunction TRegExpr.ExecPrim (AOffset: integer) : boolean;\r\n procedure ClearMatchs;\r\n  // Clears matchs array\r\n  var i : integer;\r\n  begin\r\n   for i := 0 to NSUBEXP - 1 do begin\r\n     startp [i] := nil;\r\n     endp [i] := nil;\r\n    end;\r\n  end; { of procedure ClearMatchs;\r\n..............................................................}\r\n function RegMatch (str : PRegExprChar) : boolean;\r\n  // try match at specific point\r\n  begin\r\n   //###0.949 removed clearing of start\\endp\r\n   reginput := str;\r\n   Result := MatchPrim (programm + REOpSz);\r\n   if Result then begin\r\n     startp [0] := str;\r\n     endp [0] := reginput;\r\n    end;\r\n  end; { of function RegMatch\r\n..............................................................}\r\n var\r\n  s : PRegExprChar;\r\n  StartPtr: PRegExprChar;\r\n  InputLen : integer;\r\n begin\r\n  Result := false; // Be paranoid...\r\n\r\n  ClearMatchs; //###0.949\r\n  // ensure that Match cleared either if optimization tricks or some error\r\n  // will lead to leaving ExecPrim without actual search. That is\r\n  // importent for ExecNext logic and so on.\r\n\r\n  if not IsProgrammOk //###0.929\r\n   then EXIT;\r\n\r\n  // Check InputString presence\r\n  if not Assigned (fInputString) then begin\r\n    Error (reeNoInpitStringSpecified);\r\n    EXIT;\r\n   end;\r\n\r\n  InputLen := length (fInputString);\r\n\r\n  //Check that the start position is not negative\r\n  if AOffset < 1 then begin\r\n    Error (reeOffsetMustBeGreaterThen0);\r\n    EXIT;\r\n   end;\r\n  // Check that the start position is not longer than the line\r\n  // If so then exit with nothing found\r\n  if AOffset > (InputLen + 1) // for matching empty string after last char.\r\n   then EXIT;\r\n\r\n  StartPtr := fInputString + AOffset - 1;\r\n\r\n  // If there is a \"must appear\" string, look for it.\r\n  if regmust <> nil then begin\r\n    s := StartPtr;\r\n    REPEAT\r\n     s := StrScan (s, regmust [0]);\r\n     if s <> nil then begin\r\n       if StrLComp (s, regmust, regmlen) = 0\r\n        then BREAK; // Found it.\r\n       inc (s);\r\n      end;\r\n    UNTIL s = nil;\r\n    if s = nil // Not present.\r\n     then EXIT;\r\n   end;\r\n\r\n  // Mark beginning of line for ^ .\r\n  fInputStart := fInputString;\r\n\r\n  // Pointer to end of input stream - for\r\n  // pascal-style string processing (may include #0)\r\n  fInputEnd := fInputString + InputLen;\r\n\r\n  {$IFDEF ComplexBraces}\r\n  // no loops started\r\n  LoopStackIdx := 0; //###0.925\r\n  {$ENDIF}\r\n\r\n  // Simplest case:  anchored match need be tried only once.\r\n  if reganch <> #0 then begin\r\n    Result := RegMatch (StartPtr);\r\n    EXIT;\r\n   end;\r\n\r\n  // Messy cases:  unanchored match.\r\n  s := StartPtr;\r\n  if regstart <> #0 then // We know what char it must start with.\r\n    REPEAT\r\n     s := StrScan (s, regstart);\r\n     if s <> nil then begin\r\n       Result := RegMatch (s);\r\n       if Result\r\n        then EXIT\r\n        else ClearMatchs; //###0.949\r\n       inc (s);\r\n      end;\r\n    UNTIL s = nil\r\n   else begin // We don't - general case.\r\n     repeat //###0.948\r\n       {$IFDEF UseFirstCharSet}\r\n       if s^ in FirstCharSet\r\n        then Result := RegMatch (s);\r\n       {$ELSE}\r\n       Result := RegMatch (s);\r\n       {$ENDIF}\r\n       if Result or (s^ = #0) // Exit on a match or after testing the end-of-string.\r\n        then EXIT\r\n        else ClearMatchs; //###0.949\r\n       inc (s);\r\n     until false;\r\n(*  optimized and fixed by Martin Fuller - empty strings\r\n    were not allowed to pass thru in UseFirstCharSet mode\r\n     {$IFDEF UseFirstCharSet} //###0.929\r\n     while s^ <> #0 do begin\r\n       if s^ in FirstCharSet\r\n        then Result := RegMatch (s);\r\n       if Result\r\n        then EXIT;\r\n       inc (s);\r\n      end;\r\n     {$ELSE}\r\n     REPEAT\r\n      Result := RegMatch (s);\r\n      if Result\r\n       then EXIT;\r\n      inc (s);\r\n     UNTIL s^ = #0;\r\n     {$ENDIF}\r\n*)\r\n    end;\r\n  // Failure\r\n end; { of function TRegExpr.ExecPrim\r\n--------------------------------------------------------------}\r\n\r\nfunction TRegExpr.ExecNext : boolean;\r\n var offset : integer;\r\n begin\r\n  Result := false;\r\n  if not Assigned (startp[0]) or not Assigned (endp[0]) then begin\r\n    Error (reeExecNextWithoutExec);\r\n    EXIT;\r\n   end;\r\n//  Offset := MatchPos [0] + MatchLen [0];\r\n//  if MatchLen [0] = 0\r\n  Offset := endp [0] - fInputString + 1; //###0.929\r\n  if endp [0] = startp [0] //###0.929\r\n   then inc (Offset); // prevent infinite looping if empty string match r.e.\r\n  Result := ExecPrim (Offset);\r\n end; { of function TRegExpr.ExecNext\r\n--------------------------------------------------------------}\r\n\r\nfunction TRegExpr.GetInputString : RegExprString;\r\n begin\r\n  if not Assigned (fInputString) then begin\r\n    Error (reeGetInputStringWithoutInputString);\r\n    EXIT;\r\n   end;\r\n  Result := fInputString;\r\n end; { of function TRegExpr.GetInputString\r\n--------------------------------------------------------------}\r\n\r\nprocedure TRegExpr.SetInputString (const AInputString : RegExprString);\r\n var\r\n  Len : integer;\r\n  i : integer;\r\n begin\r\n  // clear Match* - before next Exec* call it's undefined\r\n  for i := 0 to NSUBEXP - 1 do begin\r\n    startp [i] := nil;\r\n    endp [i] := nil;\r\n   end;\r\n\r\n  // need reallocation of input string buffer ?\r\n  Len := length (AInputString);\r\n  if Assigned (fInputString) and (Length (fInputString) <> Len) then begin\r\n    FreeMem (fInputString);\r\n    fInputString := nil;\r\n   end;\r\n  // buffer [re]allocation\r\n  if not Assigned (fInputString)\r\n   then GetMem (fInputString, (Len + 1) * SizeOf (REChar));\r\n\r\n  // copy input string into buffer\r\n  {$IFDEF SynRegUniCode}\r\n//  StrPCopy (fInputString, Copy (AInputString, 1, Len)); //###0.927\r\n  StrPCopy (fInputString, AInputString); //KV Copy above is wastefull.  Do not really understand why is there.\r\n  {$ELSE}\r\n  StrLCopy (fInputString, PRegExprChar (AInputString), Len);\r\n  {$ENDIF}\r\n\r\n  {\r\n  fInputString : string;\r\n  fInputStart, fInputEnd : PRegExprChar;\r\n\r\n  SetInputString:\r\n  fInputString := AInputString;\r\n  UniqueString (fInputString);\r\n  fInputStart := PChar (fInputString);\r\n  Len := length (fInputString);\r\n  fInputEnd := PRegExprChar (integer (fInputStart) + Len); ??\r\n  !! startp/endp      ?\r\n  }\r\n end; { of procedure TRegExpr.SetInputString\r\n--------------------------------------------------------------}\r\n\r\nprocedure TRegExpr.SetLineSeparators (const AStr : RegExprString);\r\n begin\r\n  if AStr <> fLineSeparators then begin\r\n    fLineSeparators := AStr;\r\n    InvalidateProgramm;\r\n   end;\r\n end; { of procedure TRegExpr.SetLineSeparators\r\n--------------------------------------------------------------}\r\n\r\nprocedure TRegExpr.SetLinePairedSeparator (const AStr : RegExprString);\r\n begin\r\n  if length (AStr) = 2 then begin\r\n     if AStr [1] = AStr [2] then begin\r\n      // it's impossible for our 'one-point' checking to support\r\n      // two chars separator for identical chars\r\n       Error (reeBadLinePairedSeparator);\r\n       EXIT;\r\n      end;\r\n     if not fLinePairedSeparatorAssigned\r\n      or (AStr [1] <> fLinePairedSeparatorHead)\r\n      or (AStr [2] <> fLinePairedSeparatorTail) then begin\r\n       fLinePairedSeparatorAssigned := true;\r\n       fLinePairedSeparatorHead := AStr [1];\r\n       fLinePairedSeparatorTail := AStr [2];\r\n       InvalidateProgramm;\r\n      end;\r\n    end\r\n   else if length (AStr) = 0 then begin\r\n     if fLinePairedSeparatorAssigned then begin\r\n       fLinePairedSeparatorAssigned := false;\r\n       InvalidateProgramm;\r\n      end;\r\n    end\r\n   else Error (reeBadLinePairedSeparator);\r\n end; { of procedure TRegExpr.SetLinePairedSeparator\r\n--------------------------------------------------------------}\r\n\r\nfunction TRegExpr.GetLinePairedSeparator : RegExprString;\r\n begin\r\n  if fLinePairedSeparatorAssigned then begin\r\n     {$IFDEF SynRegUniCode}\r\n     // Here is some UniCode 'magic'\r\n     // If You do know better decision to concatenate\r\n     // two WideChars, please, let me know!\r\n     Result := fLinePairedSeparatorHead; //###0.947\r\n     Result := Result + fLinePairedSeparatorTail;\r\n     {$ELSE}\r\n     Result := fLinePairedSeparatorHead + fLinePairedSeparatorTail;\r\n     {$ENDIF}\r\n    end\r\n   else Result := '';\r\n end; { of function TRegExpr.GetLinePairedSeparator\r\n--------------------------------------------------------------}\r\n\r\nfunction TRegExpr.Substitute (const ATemplate : RegExprString) : RegExprString;\r\n// perform substitutions after a regexp match\r\n// completely rewritten in 0.929\r\n var\r\n  TemplateLen : integer;\r\n  TemplateBeg, TemplateEnd : PRegExprChar;\r\n  p, p0, ResultPtr : PRegExprChar;\r\n  ResultLen : integer;\r\n  n : integer;\r\n  Ch : REChar;\r\n function ParseVarName (var APtr : PRegExprChar) : integer;\r\n  // extract name of variable (digits, may be enclosed with\r\n  // curly braces) from APtr^, uses TemplateEnd !!!\r\n  const\r\n   Digits = ['0' .. '9'];\r\n  var\r\n   p : PRegExprChar;\r\n   Delimited : boolean;\r\n  begin\r\n   Result := 0;\r\n   p := APtr;\r\n   Delimited := (p < TemplateEnd) and (p^ = '{');\r\n   if Delimited\r\n    then inc (p); // skip left curly brace\r\n   if (p < TemplateEnd) and (p^ = '&')\r\n    then inc (p) // this is '$&' or '${&}'\r\n    else\r\n     while (p < TemplateEnd) and\r\n      {$IFDEF SynRegUniCode} //###0.935\r\n      (ord (p^) < 256) and (ansichar (p^) in Digits)\r\n      {$ELSE}\r\n      (p^ in Digits)\r\n      {$ENDIF}\r\n       do begin\r\n       Result := Result * 10 + (ord (p^) - ord ('0')); //###0.939\r\n       inc (p);\r\n      end;\r\n   if Delimited then\r\n    if (p < TemplateEnd) and (p^ = '}')\r\n     then inc (p) // skip right curly brace\r\n     else p := APtr; // isn't properly terminated\r\n   if p = APtr\r\n    then Result := -1; // no valid digits found or no right curly brace\r\n   APtr := p;\r\n  end;\r\n begin\r\n  // Check programm and input string\r\n  if not IsProgrammOk\r\n   then EXIT;\r\n  if not Assigned (fInputString) then begin\r\n    Error (reeNoInpitStringSpecified);\r\n    EXIT;\r\n   end;\r\n  // Prepare for working\r\n  TemplateLen := length (ATemplate);\r\n  if TemplateLen = 0 then begin // prevent nil pointers\r\n    Result := '';\r\n    EXIT;\r\n   end;\r\n  TemplateBeg := pointer (ATemplate);\r\n  TemplateEnd := TemplateBeg + TemplateLen;\r\n  // Count result length for speed optimization.\r\n  ResultLen := 0;\r\n  p := TemplateBeg;\r\n  while p < TemplateEnd do begin\r\n    Ch := p^;\r\n    inc (p);\r\n    if Ch = '$'\r\n     then n := ParseVarName (p)\r\n     else n := -1;\r\n    if n >= 0 then begin\r\n       if (n < NSUBEXP) and Assigned (startp [n]) and Assigned (endp [n])\r\n        then inc (ResultLen, endp [n] - startp [n]);\r\n      end\r\n     else begin\r\n       if (Ch = EscChar) and (p < TemplateEnd)\r\n        then inc (p); // quoted or special char followed\r\n       inc (ResultLen);\r\n      end;\r\n   end;\r\n  // Get memory. We do it once and it significant speed up work !\r\n  if ResultLen = 0 then begin\r\n    Result := '';\r\n    EXIT;\r\n   end;\r\n  SetString (Result, nil, ResultLen);\r\n  // Fill Result\r\n  ResultPtr := pointer (Result);\r\n  p := TemplateBeg;\r\n  while p < TemplateEnd do begin\r\n    Ch := p^;\r\n    inc (p);\r\n    if Ch = '$'\r\n     then n := ParseVarName (p)\r\n     else n := -1;\r\n    if n >= 0 then begin\r\n       p0 := startp [n];\r\n       if (n < NSUBEXP) and Assigned (p0) and Assigned (endp [n]) then\r\n        while p0 < endp [n] do begin\r\n          ResultPtr^ := p0^;\r\n          inc (ResultPtr);\r\n          inc (p0);\r\n         end;\r\n      end\r\n     else begin\r\n       if (Ch = EscChar) and (p < TemplateEnd) then begin // quoted or special char followed\r\n         Ch := p^;\r\n         inc (p);\r\n        end;\r\n       ResultPtr^ := Ch;\r\n       inc (ResultPtr);\r\n      end;\r\n   end;\r\n end; { of function TRegExpr.Substitute\r\n--------------------------------------------------------------}\r\n\r\nprocedure TRegExpr.Split (AInputStr : RegExprString; APieces : TStrings);\r\n var PrevPos : integer;\r\n begin\r\n  PrevPos := 1;\r\n  if Exec (AInputStr) then\r\n   REPEAT\r\n    APieces.Add (System.Copy (AInputStr, PrevPos, MatchPos [0] - PrevPos));\r\n    PrevPos := MatchPos [0] + MatchLen [0];\r\n   UNTIL not ExecNext;\r\n  APieces.Add (System.Copy (AInputStr, PrevPos, MaxInt)); // Tail\r\n end; { of procedure TRegExpr.Split\r\n--------------------------------------------------------------}\r\n\r\nfunction TRegExpr.Replace (AInputStr : RegExprString; const AReplaceStr : RegExprString;\r\n      AUseSubstitution : boolean{$IFDEF DefParam}= False{$ENDIF}) : RegExprString;\r\n var\r\n  PrevPos : integer;\r\n begin\r\n  Result := '';\r\n  PrevPos := 1;\r\n  if Exec (AInputStr) then\r\n   REPEAT\r\n    Result := Result + System.Copy (AInputStr, PrevPos,\r\n      MatchPos [0] - PrevPos);\r\n    if AUseSubstitution //###0.946\r\n    then Result := Result + Substitute (AReplaceStr)\r\n    else Result := Result + AReplaceStr;\r\n    PrevPos := MatchPos [0] + MatchLen [0];\r\n   UNTIL not ExecNext;\r\n  Result := Result + System.Copy (AInputStr, PrevPos, MaxInt); // Tail\r\n end; { of function TRegExpr.Replace\r\n--------------------------------------------------------------}\r\n\r\nfunction TRegExpr.ReplaceEx (AInputStr : RegExprString;\r\n      AReplaceFunc : TRegExprReplaceFunction)\r\n     : RegExprString;\r\n var\r\n  PrevPos : integer;\r\n begin\r\n  Result := '';\r\n  PrevPos := 1;\r\n  if Exec (AInputStr) then\r\n   REPEAT\r\n    Result := Result + System.Copy (AInputStr, PrevPos,\r\n      MatchPos [0] - PrevPos)\r\n     + AReplaceFunc (Self);\r\n    PrevPos := MatchPos [0] + MatchLen [0];\r\n   UNTIL not ExecNext;\r\n  Result := Result + System.Copy (AInputStr, PrevPos, MaxInt); // Tail\r\n end; { of function TRegExpr.ReplaceEx\r\n--------------------------------------------------------------}\r\n\r\n\r\n{$IFDEF OverMeth}\r\nfunction TRegExpr.Replace (AInputStr : RegExprString;\r\n      AReplaceFunc : TRegExprReplaceFunction)\r\n     : RegExprString;\r\n begin\r\n  ReplaceEx (AInputStr, AReplaceFunc);\r\n end; { of function TRegExpr.Replace\r\n--------------------------------------------------------------}\r\n{$ENDIF}\r\n\r\n{=============================================================}\r\n{====================== Debug section ========================}\r\n{=============================================================}\r\n\r\n{$IFDEF RegExpPCodeDump}\r\nfunction TRegExpr.DumpOp (op : TREOp) : RegExprString;\r\n// printable representation of opcode\r\n begin\r\n  case op of\r\n    BOL:          Result := 'BOL';\r\n    EOL:          Result := 'EOL';\r\n    BOLML:        Result := 'BOLML';\r\n    EOLML:        Result := 'EOLML';\r\n    BOUND:        Result := 'BOUND'; //###0.943\r\n    NOTBOUND:     Result := 'NOTBOUND'; //###0.943\r\n    ANY:          Result := 'ANY';\r\n    ANYML:        Result := 'ANYML'; //###0.941\r\n    ANYLETTER:    Result := 'ANYLETTER';\r\n    NOTLETTER:    Result := 'NOTLETTER';\r\n    ANYDIGIT:     Result := 'ANYDIGIT';\r\n    NOTDIGIT:     Result := 'NOTDIGIT';\r\n    ANYSPACE:     Result := 'ANYSPACE';\r\n    NOTSPACE:     Result := 'NOTSPACE';\r\n    ANYOF:        Result := 'ANYOF';\r\n    ANYBUT:       Result := 'ANYBUT';\r\n    ANYOFCI:      Result := 'ANYOF/CI';\r\n    ANYBUTCI:     Result := 'ANYBUT/CI';\r\n    BRANCH:       Result := 'BRANCH';\r\n    EXACTLY:      Result := 'EXACTLY';\r\n    EXACTLYCI:    Result := 'EXACTLY/CI';\r\n    NOTHING:      Result := 'NOTHING';\r\n    COMMENT:      Result := 'COMMENT';\r\n    BACK:         Result := 'BACK';\r\n    EEND:         Result := 'END';\r\n    BSUBEXP:      Result := 'BSUBEXP';\r\n    BSUBEXPCI:    Result := 'BSUBEXP/CI';\r\n    Succ (OPEN) .. TREOp (Ord (OPEN) + NSUBEXP - 1): //###0.929\r\n                  Result := Format ('OPEN[%d]', [ord (op) - ord (OPEN)]);\r\n    Succ (CLOSE) .. TREOp (Ord (CLOSE) + NSUBEXP - 1): //###0.929\r\n                  Result := Format ('CLOSE[%d]', [ord (op) - ord (CLOSE)]);\r\n    STAR:         Result := 'STAR';\r\n    PLUS:         Result := 'PLUS';\r\n    BRACES:       Result := 'BRACES';\r\n    {$IFDEF ComplexBraces}\r\n    LOOPENTRY:    Result := 'LOOPENTRY'; //###0.925\r\n    LOOP:         Result := 'LOOP'; //###0.925\r\n    LOOPNG:       Result := 'LOOPNG'; //###0.940\r\n    {$ENDIF}\r\n    ANYOFTINYSET: Result:= 'ANYOFTINYSET';\r\n    ANYBUTTINYSET:Result:= 'ANYBUTTINYSET';\r\n    {$IFDEF UseSetOfChar} //###0.929\r\n    ANYOFFULLSET: Result:= 'ANYOFFULLSET';\r\n    {$ENDIF}\r\n    STARNG:       Result := 'STARNG'; //###0.940\r\n    PLUSNG:       Result := 'PLUSNG'; //###0.940\r\n    BRACESNG:     Result := 'BRACESNG'; //###0.940\r\n    else Error (reeDumpCorruptedOpcode);\r\n   end; {of case op}\r\n  Result := ':' + Result;\r\n end; { of function TRegExpr.DumpOp\r\n--------------------------------------------------------------}\r\n\r\nfunction TRegExpr.Dump : RegExprString;\r\n// dump a regexp in vaguely comprehensible form\r\n var\r\n  s : PRegExprChar;\r\n  op : TREOp; // Arbitrary non-END op.\r\n  next : PRegExprChar;\r\n  i : integer;\r\n  Diff : integer;\r\n{$IFDEF UseSetOfChar} //###0.929\r\n  Ch : REChar;\r\n{$ENDIF}\r\n begin\r\n  if not IsProgrammOk //###0.929\r\n   then EXIT;\r\n\r\n  op := EXACTLY;\r\n  Result := '';\r\n  s := programm + REOpSz;\r\n  while op <> EEND do begin // While that wasn't END last time...\r\n     op := s^;\r\n     Result := Result + Format ('%2d%s', [s - programm, DumpOp (s^)]); // Where, what.\r\n     next := regnext (s);\r\n     if next = nil // Next ptr.\r\n      then Result := Result + ' (0)'\r\n      else begin\r\n        if next > s //###0.948 PWideChar subtraction workaround (see comments in Tail method for details)\r\n         then Diff := next - s\r\n         else Diff := - (s - next);\r\n        Result := Result + Format (' (%d) ', [(s - programm) + Diff]);\r\n       end;\r\n     inc (s, REOpSz + RENextOffSz);\r\n     if (op = ANYOF) or (op = ANYOFCI) or (op = ANYBUT) or (op = ANYBUTCI)\r\n        or (op = EXACTLY) or (op = EXACTLYCI) then begin\r\n         // Literal string, where present.\r\n         while s^ <> #0 do begin\r\n           Result := Result + s^;\r\n           inc (s);\r\n          end;\r\n         inc (s);\r\n      end;\r\n     if (op = ANYOFTINYSET) or (op = ANYBUTTINYSET) then begin\r\n       for i := 1 to TinySetLen do begin\r\n         Result := Result + s^;\r\n         inc (s);\r\n        end;\r\n      end;\r\n     if (op = BSUBEXP) or (op = BSUBEXPCI) then begin\r\n       Result := Result + ' \\' + IntToStr (Ord (s^));\r\n       inc (s);\r\n      end;\r\n     {$IFDEF UseSetOfChar} //###0.929\r\n     if op = ANYOFFULLSET then begin\r\n       for Ch := #0 to #255 do\r\n        if Ch in PSetOfREChar (s)^ then\r\n         if Ch < ' '\r\n          then Result := Result + '#' + IntToStr (Ord (Ch)) //###0.936\r\n          else Result := Result + Ch;\r\n       inc (s, SizeOf (TSetOfREChar));\r\n      end;\r\n     {$ENDIF}\r\n     if (op = BRACES) or (op = BRACESNG) then begin //###0.941\r\n       // show min/max argument of BRACES operator\r\n       Result := Result + Format ('{%d,%d}', [PREBracesArg (s)^, PREBracesArg (s + REBracesArgSz)^]);\r\n       inc (s, REBracesArgSz * 2);\r\n      end;\r\n     {$IFDEF ComplexBraces}\r\n     if (op = LOOP) or (op = LOOPNG) then begin //###0.940\r\n       Result := Result + Format (' -> (%d) {%d,%d}', [\r\n        (s - programm - (REOpSz + RENextOffSz)) + PRENextOff (s + 2 * REBracesArgSz)^,\r\n        PREBracesArg (s)^, PREBracesArg (s + REBracesArgSz)^]);\r\n       inc (s, 2 * REBracesArgSz + RENextOffSz);\r\n      end;\r\n     {$ENDIF}\r\n     Result := Result + #$d#$a;\r\n   end; { of while}\r\n\r\n  // Header fields of interest.\r\n\r\n  if regstart <> #0\r\n   then Result := Result + 'start ' + regstart;\r\n  if reganch <> #0\r\n   then Result := Result + 'anchored ';\r\n  if regmust <> nil\r\n   then Result := Result + 'must have ' + regmust;\r\n  {$IFDEF UseFirstCharSet} //###0.929\r\n  Result := Result + #$d#$a'FirstCharSet:';\r\n  for Ch := #0 to #255 do\r\n   if Ch in FirstCharSet\r\n    then begin\r\n      if Ch < ' '\r\n       then Result := Result + '#' + IntToStr(Ord(Ch)) //###0.948\r\n       else Result := Result + Ch;\r\n    end;\r\n  {$ENDIF}\r\n  Result := Result + #$d#$a;\r\n end; { of function TRegExpr.Dump\r\n--------------------------------------------------------------}\r\n{$ENDIF}\r\n\r\n{$IFDEF reRealExceptionAddr}\r\n{$OPTIMIZATION ON}\r\n// ReturnAddr works correctly only if compiler optimization is ON\r\n// I placed this method at very end of unit because there are no\r\n// way to restore compiler optimization flag ...\r\n{$ENDIF}\r\nprocedure TRegExpr.Error (AErrorID : integer);\r\n{$IFDEF reRealExceptionAddr}\r\n function ReturnAddr : pointer; //###0.938\r\n  asm\r\n   mov  eax,[ebp+4]\r\n  end;\r\n{$ENDIF}\r\n var\r\n  e : ERegExpr;\r\n begin\r\n  fLastError := AErrorID; // dummy stub - useless because will raise exception\r\n  if AErrorID < 1000 // compilation error ?\r\n   then e := ERegExpr.Create (ErrorMsg (AErrorID) // yes - show error pos\r\n             + ' (pos ' + IntToStr (CompilerErrorPos) + ')')\r\n   else e := ERegExpr.Create (ErrorMsg (AErrorID));\r\n  e.ErrorCode := AErrorID;\r\n  e.CompilerErrorPos := CompilerErrorPos;\r\n  raise e\r\n   {$IFDEF reRealExceptionAddr}\r\n   At ReturnAddr; //###0.938\r\n   {$ENDIF}\r\n end; { of procedure TRegExpr.Error\r\n--------------------------------------------------------------}\r\n\r\n(*\r\n  PCode persistence:\r\n   FirstCharSet\r\n   programm, regsize\r\n   regstart // -> programm\r\n   reganch // -> programm\r\n   regmust, regmlen // -> programm\r\n   fExprIsCompiled\r\n*)\r\n\r\n// be carefull - placed here code will be always compiled with\r\n// compiler optimization flag\r\n\r\n{$IFDEF FPC}\r\ninitialization\r\n RegExprInvertCaseFunction := TRegExpr.InvertCaseFunction;\r\n\r\n{$ENDIF}\r\nend.\r\n\r\n"
  },
  {
    "path": "External/SynEdit/Source/SynTextDrawer.pas",
    "content": "{==============================================================================\r\n  Content:  TheTextDrawer, a helper class for drawing of\r\n            fixed-pitched font characters\r\n ==============================================================================\r\n  The contents of this file are subject to the Mozilla Public License Ver. 1.0\r\n  (the \"License\"); you may not use this file except in compliance with the\r\n  License. You may obtain a copy of the License at http://www.mozilla.org/MPL/\r\n\r\n  Software distributed under the License is distributed on an \"AS IS\" basis,\r\n  WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for\r\n  the specific language governing rights and limitations under the License.\r\n ==============================================================================\r\n  The Original Code is HANAI Tohru's private delphi library.\r\n ==============================================================================\r\n  The Initial Developer of the Original Code is HANAI Tohru (Japan)\r\n  Portions created by HANAI Tohru are Copyright (C) 1999.\r\n  All Rights Reserved.\r\n ==============================================================================\r\n  Contributor(s):   HANAI Tohru\r\n  Unicode translation by Mal Hrz.\r\n ==============================================================================\r\n  History:  01/19/1999  HANAI Tohru\r\n                        Initial Version\r\n            02/13/1999  HANAI Tohru\r\n                        Changed default intercharacter spacing\r\n            09/09/1999  HANAI Tohru\r\n                        Redesigned all. Simplified interfaces.\r\n                        When drawing text now it uses TextOut + SetTextCharacter-\r\n                        Extra insted ExtTextOut since ExtTextOut has a little\r\n                        heavy behavior.\r\n            09/10/1999  HANAI Tohru\r\n                        Added code to call ExtTextOut because there is a problem\r\n                        when TextOut called with italicized raster type font.\r\n                        After this changing, ExtTextOut is called without the\r\n                        last parameter `lpDx' and be with SetTextCharacterExtra.\r\n                        This pair performs faster than with `lpDx'.\r\n            09/14/1999  HANAI Tohru\r\n                        Changed code for saving/restoring DC\r\n            09/15/1999  HANAI Tohru\r\n                        Added X/Y parameters to ExtTextOut.\r\n            09/16/1999  HANAI Tohru\r\n                        Redesigned for multi-bytes character drawing.\r\n            09/19/1999  HANAI Tohru\r\n                        Since TheTextDrawer grew fat it was split into three\r\n                        classes - TheFontStock, TheTextDrawer and TheTextDrawerEx.\r\n                        Currently it should avoid TheTextDrawer because it is\r\n                        slower than TheTextDrawer.\r\n            09/25/1999  HANAI Tohru\r\n                        Added internally definition of LeadBytes for Delphi 2\r\n            10/01/1999  HANAI Tohru\r\n                        To save font resources, now all fonts data are shared\r\n                        among all of TheFontStock instances. With this changing,\r\n                        there added a new class `TheFontsInfoManager' to manage\r\n                        those shared data.\r\n            10/09/1999  HANAI Tohru\r\n                        Added BaseStyle property to TheFontFont class.\r\n ==============================================================================}\r\n\r\n// $Id: SynTextDrawer.pas,v 1.6.2.17 2008/09/17 13:59:12 maelh Exp $\r\n\r\n// SynEdit note: The name had to be changed to get SynEdit to install \r\n//   together with mwEdit into the same Delphi installation\r\n\r\nunit SynTextDrawer;\r\n\r\n{$I SynEdit.inc}\r\n\r\ninterface\r\n\r\nuses\r\n  SynUnicode,\r\n  SysUtils,\r\n  Classes,\r\n  Windows,\r\n  Graphics,\r\n  Math;\r\n\r\nconst\r\n  FontStyleCount = Ord(High(TFontStyle)) +1;\r\n  FontStyleCombineCount = (1 shl FontStyleCount);\r\n  \r\ntype\r\n  PIntegerArray = ^TIntegerArray;\r\n  TIntegerArray = array[0..MaxInt div SizeOf(Integer) - 1] of Integer;\r\n\r\n  TheStockFontPatterns = 0..FontStyleCombineCount -1;\r\n\r\n  PheFontData = ^TheFontData;\r\n  TheFontData = record\r\n    Style: TFontStyles;\r\n    Handle: HFont;\r\n    CharAdv: Integer;\r\n    CharHeight: Integer;\r\n  end;\r\n\r\n  PheFontsData = ^TheFontsData;\r\n  TheFontsData = array[TheStockFontPatterns] of TheFontData;\r\n\r\n  PheSharedFontsInfo = ^TheSharedFontsInfo;\r\n  TheSharedFontsInfo = record\r\n    // reference counters\r\n    RefCount: Integer;\r\n    LockCount: Integer;\r\n    // font information\r\n    BaseFont: TFont;\r\n    BaseLF: TLogFont;\r\n    IsTrueType: Boolean;\r\n    FontsData: TheFontsData;\r\n  end;\r\n\r\n  { TheStockFontManager }\r\n\r\n  TheFontsInfoManager = class\r\n  private\r\n    FFontsInfo: TList;\r\n    function FindFontsInfo(const LF: TLogFont): PheSharedFontsInfo;\r\n    function CreateFontsInfo(ABaseFont: TFont;\r\n      const LF: TLogFont): PheSharedFontsInfo;\r\n    procedure DestroyFontHandles(pFontsInfo: PheSharedFontsInfo);\r\n    procedure RetrieveLogFontForComparison(ABaseFont: TFont; var LF: TLogFont);\r\n  public\r\n    constructor Create;\r\n    destructor Destroy; override;\r\n    procedure LockFontsInfo(pFontsInfo: PheSharedFontsInfo);\r\n    procedure UnLockFontsInfo(pFontsInfo: PheSharedFontsInfo);\r\n    function GetFontsInfo(ABaseFont: TFont): PheSharedFontsInfo;\r\n    procedure ReleaseFontsInfo(pFontsInfo: PheSharedFontsInfo);\r\n  end;\r\n\r\n  { TheFontStock }\r\n\r\n  TTextOutOptions = set of (tooOpaque, tooClipped);\r\n\r\n  TheExtTextOutProc = procedure (X, Y: Integer; fuOptions: TTextOutOptions;\r\n    const ARect: TRect; const Text: UnicodeString; Length: Integer) of object;\r\n\r\n  EheFontStockException = class(Exception);\r\n\r\n  TheFontStock = class\r\n  private\r\n    // private DC\r\n    FDC: HDC;\r\n    FDCRefCount: Integer;\r\n\r\n    // Shared fonts\r\n    FpInfo: PheSharedFontsInfo;\r\n    FUsingFontHandles: Boolean;\r\n\r\n    // Current font\r\n    FCrntFont: HFONT;\r\n    FCrntStyle: TFontStyles;\r\n    FpCrntFontData: PheFontData;\r\n    // local font info\r\n    FBaseLF: TLogFont;\r\n    function GetBaseFont: TFont;\r\n    function GetIsTrueType: Boolean;\r\n  protected\r\n    function InternalGetDC: HDC; virtual;\r\n    procedure InternalReleaseDC(Value: HDC); virtual;\r\n    function InternalCreateFont(Style: TFontStyles): HFONT; virtual;\r\n    function CalcFontAdvance(DC: HDC; pCharHeight: PInteger): Integer; virtual;\r\n    function GetCharAdvance: Integer; virtual;\r\n    function GetCharHeight: Integer; virtual;\r\n    function GetFontData(idx: Integer): PheFontData; virtual;\r\n    procedure UseFontHandles;\r\n    procedure ReleaseFontsInfo;\r\n    procedure SetBaseFont(Value: TFont); virtual;\r\n    procedure SetStyle(Value: TFontStyles); virtual;\r\n    property FontData[idx: Integer]: PheFontData read GetFontData;\r\n    property FontsInfo: PheSharedFontsInfo read FpInfo;\r\n  public\r\n    constructor Create(InitialFont: TFont); virtual;\r\n    destructor Destroy; override;\r\n    procedure ReleaseFontHandles; virtual;\r\n    property BaseFont: TFont read GetBaseFont;\r\n    property Style: TFontStyles read FCrntStyle write SetStyle;\r\n    property FontHandle: HFONT read FCrntFont;\r\n    property CharAdvance: Integer read GetCharAdvance;\r\n    property CharHeight: Integer read GetCharHeight;\r\n    property IsTrueType: Boolean read GetIsTrueType;\r\n  end;\r\n\r\n  { TheTextDrawer }\r\n  EheTextDrawerException = class(Exception);\r\n\r\n  TheTextDrawer = class(TObject)\r\n  private\r\n    FDC: HDC;\r\n    FSaveDC: Integer;\r\n\r\n    // Font information\r\n    FFontStock: TheFontStock;\r\n    FStockBitmap: TBitmap;\r\n    FCalcExtentBaseStyle: TFontStyles;\r\n    FBaseCharWidth: Integer;\r\n    FBaseCharHeight: Integer;\r\n\r\n    // current font and properties\r\n    FCrntFont: HFONT;\r\n    FETODist: PIntegerArray;\r\n\r\n    // current font attributes\r\n    FColor: TColor;\r\n    FBkColor: TColor;\r\n    FCharExtra: Integer;\r\n\r\n    // Begin/EndDrawing calling count\r\n    FDrawingCount: Integer;\r\n\r\n    // GetCharABCWidthsW cache\r\n    FCharABCWidthCache : array [0..127] of TABC;\r\n    FCharWidthCache : array [0..127] of Integer;\r\n\r\n  protected\r\n    procedure ReleaseETODist; virtual;\r\n    procedure AfterStyleSet; virtual;\r\n    procedure DoSetCharExtra(Value: Integer); virtual;\r\n    procedure FlushCharABCWidthCache;\r\n    function GetCachedABCWidth(c : Cardinal; var abc : TABC) : Boolean;\r\n    property StockDC: HDC read FDC;\r\n    property DrawingCount: Integer read FDrawingCount;\r\n    property FontStock: TheFontStock read FFontStock;\r\n    property BaseCharWidth: Integer read FBaseCharWidth;\r\n    property BaseCharHeight: Integer read FBaseCharHeight;\r\n\r\n  public\r\n    constructor Create(CalcExtentBaseStyle: TFontStyles; BaseFont: TFont); virtual;\r\n    destructor Destroy; override;\r\n    function GetCharWidth: Integer; virtual;\r\n    function GetCharHeight: Integer; virtual;\r\n    procedure BeginDrawing(DC: HDC); virtual;\r\n    procedure EndDrawing; virtual;\r\n    procedure TextOut(X, Y: Integer; Text: PWideChar; Length: Integer); virtual;\r\n    procedure ExtTextOut(X, Y: Integer; Options: TTextOutOptions; ARect: TRect;\r\n      Text: PWideChar; Length: Integer); virtual;\r\n    function TextExtent(const Text: UnicodeString): TSize; overload;\r\n    function TextExtent(Text: PWideChar; Count: Integer): TSize; overload;\r\n    function TextWidth(const Text: UnicodeString): Integer; overload;\r\n    function TextWidth(Text: PWideChar; Count: Integer): Integer; overload;\r\n    procedure SetBaseFont(Value: TFont); virtual;\r\n    procedure SetBaseStyle(const Value: TFontStyles); virtual;\r\n    procedure SetStyle(Value: TFontStyles); virtual;\r\n    procedure SetForeColor(Value: TColor); virtual;\r\n    procedure SetBackColor(Value: TColor); virtual;\r\n    procedure SetCharExtra(Value: Integer); virtual;\r\n    procedure ReleaseTemporaryResources; virtual;\r\n    property CharWidth: Integer read GetCharWidth;\r\n    property CharHeight: Integer read GetCharHeight;\r\n    property BaseFont: TFont write SetBaseFont;\r\n    property BaseStyle: TFontStyles write SetBaseStyle;\r\n    property ForeColor: TColor write SetForeColor;\r\n    property BackColor: TColor write SetBackColor;\r\n    property Style: TFontStyles write SetStyle;\r\n    property CharExtra: Integer read FCharExtra write SetCharExtra;\r\n  end;\r\n\r\nfunction GetFontsInfoManager: TheFontsInfoManager;\r\n\r\nfunction UniversalExtTextOut(DC: HDC; X, Y: Integer; Options: TTextOutOptions;\r\n  Rect: TRect; Str: PWideChar; Count: Integer; ETODist: PIntegerArray): Boolean;\r\n\r\nimplementation\r\n\r\nuses System.UITypes, Types // PV\r\n{$IFDEF SYN_UNISCRIBE}\r\n  , SynUsp10\r\n{$ENDIF}\r\n;\r\n\r\nvar\r\n  gFontsInfoManager: TheFontsInfoManager;\r\n\r\n{ utility routines }\r\n\r\nfunction GetFontsInfoManager: TheFontsInfoManager;\r\nbegin\r\n  if not Assigned(gFontsInfoManager) then\r\n    gFontsInfoManager := TheFontsInfoManager.Create;\r\n  Result := gFontsInfoManager;\r\nend;\r\n\r\nfunction Min(x, y: integer): integer;\r\nbegin\r\n  if x < y then Result := x else Result := y;\r\nend;\r\n\r\n// UniversalExtTextOut uses UniScribe where available for the best possible\r\n// output quality. This also avoids a bug in (Ext)TextOut that surfaces when\r\n// displaying a combination of Chinese and Korean text.\r\n//\r\n// See here for details: http://groups.google.com/group/microsoft.public.win32.programmer.international/browse_thread/thread/77cd596f2b96dc76/146300208098285c?lnk=st&q=font+substitution+problem#146300208098285c\r\nfunction UniversalExtTextOut(DC: HDC; X, Y: Integer; Options: TTextOutOptions;\r\n  Rect: TRect; Str: PWideChar; Count: Integer; ETODist: PIntegerArray): Boolean;\r\n{$IFDEF SYN_UNISCRIBE}\r\nconst\r\n  SSAnalyseFlags = SSA_GLYPHS or SSA_FALLBACK or SSA_LINK;\r\n  SpaceString: UnicodeString = ' ';\r\n{$ENDIF}\r\nvar\r\n  TextOutFlags: DWORD;\r\n{$IFDEF SYN_UNISCRIBE}\r\n  GlyphBufferSize: Integer;\r\n  saa: TScriptStringAnalysis;\r\n{$ENDIF}\r\nbegin\r\n  TextOutFlags := 0;\r\n  if tooOpaque in Options then\r\n    TextOutFlags := TextOutFlags or ETO_OPAQUE;\r\n  if tooClipped in Options then\r\n    TextOutFlags := TextOutFlags or ETO_CLIPPED;\r\n\r\n{$IFDEF SYN_UNISCRIBE}\r\n  if Usp10IsInstalled then\r\n  begin\r\n    // UniScribe requires that the string contains at least one character.\r\n    // If UniversalExtTextOut should be used to fill the background we can just\r\n    // pass a string made of a space.\r\n    if Count <= 0 then\r\n      if tooOpaque in Options then\r\n      begin\r\n        // Clipping is necessary, since depending on X, Y the space will be\r\n        // printed outside Rect and potentially fill more than we want.\r\n        TextOutFlags := TextOutFlags or ETO_CLIPPED;\r\n        Str := PWideChar(SpaceString);\r\n        Count := 1;\r\n      end\r\n      else\r\n      begin\r\n        Result := False;\r\n        Exit;\r\n      end;\r\n\r\n    // According to the MS Windows SDK (1.5 * Count + 16) is the recommended\r\n    // value for GlyphBufferSize (see documentation of cGlyphs parameter of\r\n    // ScriptStringAnalyse function)\r\n    GlyphBufferSize := (3 * Count) div 2 + 16;\r\n    \r\n    Result := Succeeded(ScriptStringAnalyse(DC, Str, Count, GlyphBufferSize, -1,\r\n      SSAnalyseFlags, 0, nil, nil, Pointer(ETODist), nil, nil, @saa));\r\n    Result := Result and Succeeded(ScriptStringOut(saa, X, Y, TextOutFlags,\r\n      @Rect, 0, 0, False));\r\n    Result := Result and Succeeded(ScriptStringFree(@saa));\r\n  end\r\n  else\r\n{$ENDIF}\r\n  begin\r\n    Result := ExtTextOutW(DC, X, Y, TextOutFlags, @Rect, Str, Count,\r\n      Pointer(ETODist));\r\n  end;\r\nend;\r\n\r\n{ TheFontsInfoManager }\r\n\r\nprocedure TheFontsInfoManager.LockFontsInfo(\r\n  pFontsInfo: PheSharedFontsInfo);\r\nbegin\r\n  Inc(pFontsInfo^.LockCount);\r\nend;\r\n\r\nconstructor TheFontsInfoManager.Create;\r\nbegin\r\n  inherited;\r\n\r\n  FFontsInfo := TList.Create;\r\nend;\r\n\r\nfunction TheFontsInfoManager.CreateFontsInfo(ABaseFont: TFont;\r\n  const LF: TLogFont): PheSharedFontsInfo;\r\nbegin\r\n  New(Result);\r\n  FillChar(Result^, SizeOf(TheSharedFontsInfo), 0);\r\n  with Result^ do\r\n    try\r\n      BaseFont := TFont.Create;\r\n      BaseFont.Assign(ABaseFont);\r\n      BaseLF := LF;\r\n      IsTrueType := (0 <> (TRUETYPE_FONTTYPE and LF.lfPitchAndFamily));\r\n  except\r\n    Result^.BaseFont.Free;\r\n    Dispose(Result);\r\n    raise;\r\n  end;\r\nend;\r\n\r\nprocedure TheFontsInfoManager.UnlockFontsInfo(\r\n  pFontsInfo: PheSharedFontsInfo);\r\nbegin\r\n  with pFontsInfo^ do\r\n  begin\r\n    Dec(LockCount);\r\n    if 0 = LockCount then\r\n      DestroyFontHandles(pFontsInfo);\r\n  end;\r\nend;\r\n\r\ndestructor TheFontsInfoManager.Destroy;\r\nbegin\r\n  gFontsInfoManager := nil;\r\n  \r\n  if Assigned(FFontsInfo) then\r\n  begin\r\n    while FFontsInfo.Count > 0 do\r\n    begin\r\n      ASSERT(1 = PheSharedFontsInfo(FFontsInfo[FFontsInfo.Count - 1])^.RefCount);\r\n      ReleaseFontsInfo(PheSharedFontsInfo(FFontsInfo[FFontsInfo.Count - 1]));\r\n    end;\r\n    FFontsInfo.Free;\r\n  end;\r\n\r\n  inherited;\r\nend;\r\n\r\nprocedure TheFontsInfoManager.DestroyFontHandles(\r\n  pFontsInfo: PheSharedFontsInfo);\r\nvar\r\n  i: Integer;\r\nbegin\r\n  with pFontsInfo^ do\r\n    for i := Low(TheStockFontPatterns) to High(TheStockFontPatterns) do\r\n      with FontsData[i] do\r\n        if Handle <> 0 then\r\n        begin\r\n          DeleteObject(Handle);\r\n          Handle := 0;\r\n        end;\r\nend;\r\n\r\nfunction TheFontsInfoManager.FindFontsInfo(\r\n  const LF: TLogFont): PheSharedFontsInfo;\r\nvar\r\n  i: Integer;\r\nbegin\r\n  for i := 0 to FFontsInfo.Count - 1 do\r\n  begin\r\n    Result := PheSharedFontsInfo(FFontsInfo[i]);\r\n    if CompareMem(@(Result^.BaseLF), @LF, SizeOf(TLogFont)) then\r\n      Exit;\r\n  end;\r\n  Result := nil;\r\nend;\r\n\r\nfunction TheFontsInfoManager.GetFontsInfo(ABaseFont: TFont): PheSharedFontsInfo;\r\nvar\r\n  LF: TLogFont;\r\nbegin\r\n  ASSERT(Assigned(ABaseFont));\r\n\r\n  RetrieveLogFontForComparison(ABaseFont, LF);\r\n  Result := FindFontsInfo(LF);\r\n  if not Assigned(Result) then\r\n  begin\r\n    Result := CreateFontsInfo(ABaseFont, LF);\r\n    FFontsInfo.Add(Result);\r\n  end;\r\n\r\n  if Assigned(Result) then\r\n    Inc(Result^.RefCount);\r\nend;\r\n\r\nprocedure TheFontsInfoManager.ReleaseFontsInfo(pFontsInfo: PheSharedFontsInfo);\r\nbegin\r\n  ASSERT(Assigned(pFontsInfo));\r\n\r\n  with pFontsInfo^ do\r\n  begin\r\n{$IFDEF HE_ASSERT}\r\n    ASSERT(LockCount < RefCount,\r\n      'Call DeactivateFontsInfo before calling this.');\r\n{$ELSE}\r\n    ASSERT(LockCount < RefCount);\r\n{$ENDIF}\r\n    if RefCount > 1 then\r\n      Dec(RefCount)\r\n    else\r\n    begin\r\n      FFontsInfo.Remove(pFontsInfo);\r\n      // free all objects\r\n      BaseFont.Free;\r\n      Dispose(pFontsInfo);\r\n    end;\r\n  end;\r\nend;\r\n\r\nprocedure TheFontsInfoManager.RetrieveLogFontForComparison(ABaseFont: TFont;\r\n  var LF: TLogFont);\r\nvar\r\n  pEnd: PChar;\r\nbegin\r\n  GetObject(ABaseFont.Handle, SizeOf(TLogFont), @LF);\r\n  with LF do\r\n  begin\r\n    lfItalic := 0;\r\n    lfUnderline := 0;\r\n    lfStrikeOut := 0;\r\n    pEnd := StrEnd(lfFaceName);\r\n    FillChar(pEnd[1], @lfFaceName[High(lfFaceName)] - pEnd, 0);\r\n  end;\r\nend;\r\n\r\n{ TheFontStock }\r\n\r\n// CalcFontAdvance : Calculation a advance of a character of a font.\r\n//  [*]hCalcFont will be selected as FDC's font if FDC wouldn't be zero.\r\nfunction TheFontStock.CalcFontAdvance(DC: HDC; pCharHeight: PInteger): Integer;\r\nvar\r\n  TM: TTextMetric;\r\n  ABC: TABC;\r\n  HasABC: Boolean;\r\nbegin\r\n  // Calculate advance of a character.\r\n  // The following code uses ABC widths instead TextMetric.tmAveCharWidth\r\n  // because ABC widths always tells truth but tmAveCharWidth does not.\r\n  // A true-type font will have ABC widths but others like raster type will not\r\n  // so if the function fails then use TextMetric.tmAveCharWidth.\r\n  GetTextMetrics(DC, TM);\r\n  HasABC := GetCharABCWidths(DC, Ord('M'), Ord('M'), ABC);\r\n  if not HasABC then\r\n  begin\r\n    with ABC do\r\n    begin\r\n      abcA := 0;\r\n      abcB := TM.tmAveCharWidth;\r\n      abcC := 0;\r\n    end;\r\n    TM.tmOverhang := 0;\r\n  end;\r\n\r\n  // Result(CharWidth)\r\n  with ABC do\r\n    Result := abcA + Integer(abcB) + abcC + TM.tmOverhang;\r\n  // pCharHeight\r\n  if Assigned(pCharHeight) then\r\n    pCharHeight^ := Abs(TM.tmHeight) {+ TM.tmInternalLeading};\r\nend;\r\n\r\nconstructor TheFontStock.Create(InitialFont: TFont);\r\nbegin\r\n  inherited Create;\r\n\r\n  SetBaseFont(InitialFont);\r\nend;\r\n\r\ndestructor TheFontStock.Destroy;\r\nbegin\r\n  ReleaseFontsInfo;\r\n  ASSERT(FDCRefCount = 0);\r\n\r\n  inherited;\r\nend;\r\n\r\nfunction TheFontStock.GetBaseFont: TFont;\r\nbegin\r\n  Result := FpInfo^.BaseFont;\r\nend;\r\n\r\nfunction TheFontStock.GetCharAdvance: Integer;\r\nbegin\r\n  Result := FpCrntFontData^.CharAdv;\r\nend;\r\n\r\nfunction TheFontStock.GetCharHeight: Integer;\r\nbegin\r\n  Result := FpCrntFontData^.CharHeight;\r\nend;\r\n\r\nfunction TheFontStock.GetFontData(idx: Integer): PheFontData;\r\nbegin\r\n  Result := @FpInfo^.FontsData[idx];\r\nend;\r\n\r\nfunction TheFontStock.GetIsTrueType: Boolean;\r\nbegin\r\n  Result := FpInfo^.IsTrueType\r\nend;\r\n\r\nfunction TheFontStock.InternalCreateFont(Style: TFontStyles): HFONT;\r\nconst\r\n  Bolds: array[Boolean] of Integer = (400, 700);\r\nbegin\r\n  with FBaseLF do\r\n  begin\r\n    lfWeight := Bolds[fsBold in Style];\r\n    lfItalic := Ord(BOOL(fsItalic in Style));\r\n    lfUnderline := Ord(BOOL(fsUnderline in Style));\r\n    lfStrikeOut := Ord(BOOL(fsStrikeOut in Style));\r\n  end;\r\n  Result := CreateFontIndirect(FBaseLF);\r\nend;\r\n\r\nfunction TheFontStock.InternalGetDC: HDC;\r\nbegin\r\n  if FDCRefCount = 0 then\r\n  begin\r\n    ASSERT(FDC = 0);\r\n    FDC := GetDC(0);\r\n  end;\r\n  Inc(FDCRefCount);\r\n  Result := FDC;\r\nend;\r\n\r\nprocedure TheFontStock.InternalReleaseDC(Value: HDC);\r\nbegin\r\n  Dec(FDCRefCount);\r\n  if FDCRefCount <= 0 then\r\n  begin\r\n    ASSERT((FDC <> 0) and (FDC = Value));\r\n    ReleaseDC(0, FDC);\r\n    FDC := 0;\r\n    ASSERT(FDCRefCount = 0);\r\n  end;\r\nend;\r\n\r\nprocedure TheFontStock.ReleaseFontHandles;\r\nbegin\r\n  if FUsingFontHandles then\r\n    with GetFontsInfoManager do\r\n    begin\r\n      UnlockFontsInfo(FpInfo);\r\n      FUsingFontHandles := False;\r\n    end;\r\nend;\r\n\r\nprocedure TheFontStock.ReleaseFontsInfo;\r\nbegin\r\n  if Assigned(FpInfo) then\r\n    with GetFontsInfoManager do\r\n    begin\r\n      if FUsingFontHandles then\r\n      begin\r\n        UnlockFontsInfo(FpInfo);\r\n        FUsingFontHandles := False;\r\n      end;\r\n      ReleaseFontsInfo(FpInfo);\r\n      FpInfo := nil;\r\n    end;\r\nend;\r\n\r\nprocedure TheFontStock.SetBaseFont(Value: TFont);\r\nvar\r\n  pInfo: PheSharedFontsInfo;\r\nbegin\r\n  if Assigned(Value) then\r\n  begin\r\n    pInfo := GetFontsInfoManager.GetFontsInfo(Value);\r\n    if pInfo = FpInfo then\r\n      GetFontsInfoManager.ReleaseFontsInfo(pInfo)\r\n    else\r\n    begin\r\n      ReleaseFontsInfo;\r\n      FpInfo := pInfo;\r\n      FBaseLF := FpInfo^.BaseLF;\r\n      SetStyle(Value.Style);\r\n    end;\r\n  end\r\n  else\r\n    raise EheFontStockException.Create('SetBaseFont: ''Value'' must be specified.');\r\nend;\r\n\r\nprocedure TheFontStock.SetStyle(Value: TFontStyles);\r\nvar\r\n  idx: Integer;\r\n  DC: HDC;\r\n  hOldFont: HFONT;\r\n  p: PheFontData;\r\nbegin\r\n{$IFDEF HE_ASSERT}\r\n  ASSERT(SizeOf(TFontStyles) = 1,\r\n    'TheTextDrawer.SetStyle: There''s more than four font styles but the current '+\r\n    'code expects only four styles.');\r\n{$ELSE}\r\n  ASSERT(SizeOf(TFontStyles) = 1);\r\n{$ENDIF}\r\n\r\n  idx := Byte(Value);\r\n  ASSERT(idx <= High(TheStockFontPatterns));\r\n\r\n  UseFontHandles;\r\n  p := FontData[idx];\r\n  if FpCrntFontData = p then\r\n    Exit;\r\n\r\n  FpCrntFontData := p;\r\n  with p^ do\r\n    if Handle <> 0 then\r\n    begin\r\n      FCrntFont := Handle;\r\n      FCrntStyle := Style;\r\n      Exit;\r\n    end;\r\n\r\n  // create font\r\n  FCrntFont := InternalCreateFont(Value);\r\n  DC := InternalGetDC;\r\n  hOldFont := SelectObject(DC, FCrntFont);\r\n\r\n  // retrieve height and advances of new font\r\n  with FpCrntFontData^ do\r\n  begin\r\n    Handle := FCrntFont;\r\n    CharAdv := CalcFontAdvance(DC, @CharHeight);\r\n  end;\r\n\r\n  SelectObject(DC, hOldFont);\r\n  InternalReleaseDC(DC);\r\nend;\r\n\r\nprocedure TheFontStock.UseFontHandles;\r\nbegin\r\n  if not FUsingFontHandles then\r\n    with GetFontsInfoManager do\r\n    begin\r\n      LockFontsInfo(FpInfo);\r\n      FUsingFontHandles := True;\r\n    end;\r\nend;\r\n\r\n{ TheTextDrawer }\r\n\r\nconstructor TheTextDrawer.Create(CalcExtentBaseStyle: TFontStyles; BaseFont: TFont);\r\nbegin\r\n  inherited Create;\r\n\r\n  FFontStock := TheFontStock.Create(BaseFont);\r\n  FStockBitmap := TBitmap.Create;\r\n  FCalcExtentBaseStyle := CalcExtentBaseStyle;\r\n  SetBaseFont(BaseFont);\r\n  FColor := clWindowText;\r\n  FBkColor := clWindow;\r\nend;\r\n\r\ndestructor TheTextDrawer.Destroy;\r\nbegin\r\n  FStockBitmap.Free;\r\n  FFontStock.Free;\r\n  ReleaseETODist;\r\n  \r\n  inherited;\r\nend;\r\n\r\nprocedure TheTextDrawer.ReleaseETODist;\r\nbegin\r\n  if Assigned(FETODist) then\r\n  begin\r\n    FreeMem(FETODist);\r\n    FETODist := nil;\r\n  end;\r\nend;\r\n\r\nprocedure TheTextDrawer.BeginDrawing(DC: HDC);\r\nbegin\r\n  if (FDC = DC) then\r\n    ASSERT(FDC <> 0)\r\n  else\r\n  begin\r\n    ASSERT((FDC = 0) and (DC <> 0) and (FDrawingCount = 0));\r\n    FDC := DC;\r\n    FSaveDC := SaveDC(DC);\r\n    SelectObject(DC, FCrntFont);\r\n    Windows.SetTextColor(DC, ColorToRGB(FColor));\r\n    Windows.SetBkColor(DC, ColorToRGB(FBkColor));\r\n    DoSetCharExtra(FCharExtra);\r\n  end;\r\n  Inc(FDrawingCount);\r\nend;\r\n\r\nprocedure TheTextDrawer.EndDrawing;\r\nbegin\r\n  ASSERT(FDrawingCount >= 1);\r\n  Dec(FDrawingCount);\r\n  if FDrawingCount <= 0 then\r\n  begin\r\n    if FDC <> 0 then\r\n      RestoreDC(FDC, FSaveDC);\r\n    FSaveDC := 0;\r\n    FDC := 0;\r\n    FDrawingCount := 0;\r\n  end;\r\nend;\r\n\r\nfunction TheTextDrawer.GetCharWidth: Integer;\r\nbegin\r\n  Result := FBaseCharWidth + FCharExtra;\r\nend;\r\n\r\nfunction TheTextDrawer.GetCharHeight: Integer;\r\nbegin\r\n  Result := FBaseCharHeight;\r\nend;\r\n\r\nprocedure TheTextDrawer.SetBaseFont(Value: TFont);\r\nbegin\r\n  if Assigned(Value) then\r\n  begin\r\n    FlushCharABCWidthCache;\r\n    ReleaseETODist;\r\n    FStockBitmap.Canvas.Font.Assign(Value);\r\n    FStockBitmap.Canvas.Font.Style := [];\r\n    with FFontStock do\r\n    begin\r\n      SetBaseFont(Value);\r\n      Style := FCalcExtentBaseStyle;\r\n      FBaseCharWidth := CharAdvance;\r\n      FBaseCharHeight := CharHeight;\r\n    end;\r\n    SetStyle(Value.Style);\r\n  end\r\n  else\r\n    raise EheTextDrawerException.Create('SetBaseFont: ''Value'' must be specified.');\r\nend;\r\n\r\nprocedure TheTextDrawer.SetBaseStyle(const Value: TFontStyles);\r\nbegin\r\n  if FCalcExtentBaseStyle <> Value then\r\n  begin\r\n    FCalcExtentBaseStyle := Value;\r\n    FlushCharABCWidthCache;\r\n    ReleaseETODist;\r\n    with FFontStock do\r\n    begin\r\n      Style := Value;\r\n      FBaseCharWidth := CharAdvance;\r\n      FBaseCharHeight := CharHeight;\r\n    end;\r\n  end;\r\nend;\r\n\r\nprocedure TheTextDrawer.SetStyle(Value: TFontStyles);\r\nbegin\r\n  with FFontStock do\r\n  begin\r\n    SetStyle(Value);\r\n    Self.FCrntFont := FontHandle;\r\n  end;\r\n  AfterStyleSet;\r\nend;\r\n\r\nprocedure TheTextDrawer.AfterStyleSet;\r\nbegin\r\n  if FDC <> 0 then\r\n    SelectObject(FDC, FCrntFont);\r\nend;\r\n\r\nprocedure TheTextDrawer.SetForeColor(Value: TColor);\r\nbegin\r\n  if FColor <> Value then\r\n  begin\r\n    FColor := Value;\r\n    if FDC <> 0 then\r\n      SetTextColor(FDC, ColorToRGB(Value));\r\n  end;\r\nend;\r\n\r\nprocedure TheTextDrawer.SetBackColor(Value: TColor);\r\nbegin\r\n  if FBkColor <> Value then\r\n  begin\r\n    FBkColor := Value;\r\n    if FDC <> 0 then\r\n      Windows.SetBkColor(FDC, ColorToRGB(Value));\r\n  end;\r\nend;\r\n\r\nprocedure TheTextDrawer.SetCharExtra(Value: Integer);\r\nbegin\r\n  if FCharExtra <> Value then\r\n  begin\r\n    FCharExtra := Value;\r\n    DoSetCharExtra(FCharExtra);\r\n  end;\r\nend;\r\n\r\nprocedure TheTextDrawer.DoSetCharExtra(Value: Integer);\r\nbegin\r\n  if FDC <> 0 then\r\n    SetTextCharacterExtra(FDC, Value);\r\nend;\r\n\r\nprocedure TheTextDrawer.FlushCharABCWidthCache;\r\nbegin\r\n   FillChar(FCharABCWidthCache, SizeOf(TABC)*Length(FCharABCWidthCache), 0);\r\n   FillChar(FCharWidthCache, SizeOf(Integer)*Length(FCharWidthCache), 0);\r\nend;\r\n\r\nfunction TheTextDrawer.GetCachedABCWidth(c : Cardinal; var abc : TABC) : Boolean;\r\nbegin\r\n   if c>High(FCharABCWidthCache) then begin\r\n      Result:=GetCharABCWidthsW(FDC, c, c, abc);\r\n      Exit;\r\n   end;\r\n   abc:=FCharABCWidthCache[c];\r\n   if (abc.abcA or Integer(abc.abcB) or abc.abcC)=0 then begin\r\n      Result:=GetCharABCWidthsW(FDC, c, c, abc);\r\n      if Result then\r\n         FCharABCWidthCache[c]:=abc;\r\n   end else Result:=True;\r\nend;\r\n\r\nprocedure TheTextDrawer.TextOut(X, Y: Integer; Text: PWideChar;\r\n  Length: Integer);\r\nvar\r\n  r: TRect;\r\nbegin\r\n  r := Rect(X, Y, X, Y);\r\n  UniversalExtTextOut(FDC, X, Y, [], r, Text, Length, nil);\r\nend;\r\n\r\nprocedure TheTextDrawer.ExtTextOut(X, Y: Integer; Options: TTextOutOptions;\r\n  ARect: TRect; Text: PWideChar; Length: Integer);\r\n\r\n  procedure InitETODist(CharWidth: Integer);\r\n  var\r\n    Size: TSize;\r\n    i: Integer;\r\n  begin\r\n    ReallocMem(FETODist, Length * SizeOf(Integer));\r\n    for i := 0 to Length - 1 do\r\n    begin\r\n      Size := TextExtent(PWideChar(@Text[i]), 1);\r\n      if Size.cx <> CharWidth then\r\n         FETODist[i] := Ceil(Size.cx / CharWidth) * CharWidth\r\n      else FETODist[i] := CharWidth;\r\n    end;\r\n  end;\r\n\r\n  procedure AdjustLastCharWidthAndRect;\r\n  var\r\n    LastChar: Cardinal;\r\n    RealCharWidth, CharWidth: Integer;\r\n    CharInfo: TABC;\r\n    tm: TTextMetricA;\r\n  begin\r\n    if Length <= 0 then Exit;\r\n    \r\n    LastChar := Ord(Text[Length - 1]);\r\n    CharWidth := FETODist[Length - 1];\r\n    RealCharWidth := CharWidth;\r\n    if Win32PlatformIsUnicode then\r\n    begin\r\n      if GetCachedABCWidth(LastChar, CharInfo) then\r\n      begin\r\n        RealCharWidth := CharInfo.abcA + Integer(CharInfo.abcB);\r\n        if CharInfo.abcC >= 0 then\r\n          Inc(RealCharWidth, CharInfo.abcC);\r\n      end\r\n      else if LastChar < Ord(High(AnsiChar)) then\r\n      begin\r\n        GetTextMetricsA(FDC, tm);\r\n        RealCharWidth := tm.tmAveCharWidth + tm.tmOverhang;\r\n      end;\r\n    end\r\n    else if WideChar(LastChar) <= High(AnsiChar) then\r\n    begin\r\n      if GetCharABCWidthsA(FDC, LastChar, LastChar, CharInfo) then\r\n      begin\r\n        RealCharWidth := CharInfo.abcA + Integer(CharInfo.abcB);\r\n        if CharInfo.abcC >= 0 then\r\n          Inc(RealCharWidth, CharInfo.abcC);\r\n      end\r\n      else if LastChar < Ord(High(AnsiChar)) then\r\n      begin\r\n        GetTextMetricsA(FDC, tm);\r\n        RealCharWidth := tm.tmAveCharWidth + tm.tmOverhang;\r\n      end;\r\n    end;\r\n    if RealCharWidth > CharWidth then\r\n      Inc(ARect.Right, RealCharWidth - CharWidth);\r\n    FETODist[Length - 1] := Max(RealCharWidth, CharWidth);\r\n  end;\r\n\r\nbegin\r\n  InitETODist(GetCharWidth);\r\n  AdjustLastCharWidthAndRect;\r\n  UniversalExtTextOut(FDC, X, Y, Options, ARect, Text, Length, FETODist);\r\nend;\r\n\r\nprocedure TheTextDrawer.ReleaseTemporaryResources;\r\nbegin\r\n  FFontStock.ReleaseFontHandles;\r\nend;\r\n\r\nfunction TheTextDrawer.TextExtent(const Text: UnicodeString): TSize;\r\nbegin\r\n  Result := SynUnicode.TextExtent(FStockBitmap.Canvas, Text);\r\nend;\r\n\r\nfunction TheTextDrawer.TextExtent(Text: PWideChar; Count: Integer): TSize;\r\nbegin\r\n  Result := SynUnicode.GetTextSize(FStockBitmap.Canvas.Handle, Text, Count);\r\nend;\r\n\r\nfunction TheTextDrawer.TextWidth(const Text: UnicodeString): Integer;\r\nvar\r\n   c : Cardinal;\r\nbegin\r\n   if Length(Text)=1 then begin\r\n      c:=Ord(Text[1]);\r\n      if c<=High(FCharWidthCache) then begin\r\n         Result:=FCharWidthCache[c];\r\n         if Result=0 then begin\r\n            Result:=SynUnicode.TextExtent(FStockBitmap.Canvas, Text).cX;\r\n            FCharWidthCache[c]:=Result;\r\n         end;\r\n         Exit;\r\n      end;\r\n   end;\r\n   Result := SynUnicode.TextExtent(FStockBitmap.Canvas, Text).cX;\r\nend;\r\n\r\nfunction TheTextDrawer.TextWidth(Text: PWideChar; Count: Integer): Integer;\r\nbegin\r\n  Result := SynUnicode.GetTextSize(FStockBitmap.Canvas.Handle, Text, Count).cX;\r\nend;\r\n\r\ninitialization\r\n\r\nfinalization\r\n  gFontsInfoManager.Free;\r\n\r\nend.\r\n"
  },
  {
    "path": "External/SynEdit/Source/SynURIOpener.pas",
    "content": "{-------------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: SynURIOpener.pas, released 2003-09-25.\r\nThe Initial Author of this file is Mal Hrz.\r\nUnicode translation by Mal Hrz.\r\nAll Rights Reserved.\r\n\r\nContributors to the SynEdit project are listed in the Contributors.txt file.\r\n\r\nAlternatively, the contents of this file may be used under the terms of the\r\nGNU General Public License Version 2 or later (the \"GPL\"), in which case\r\nthe provisions of the GPL are applicable instead of those above.\r\nIf you wish to allow use of your version of this file only under the terms\r\nof the GPL and not to allow others to use your version of this file\r\nunder the MPL, indicate your decision by deleting the provisions above and\r\nreplace them with the notice and other provisions required by the GPL.\r\nIf you do not delete the provisions above, a recipient may use your version\r\nof this file under either the MPL or the GPL.\r\n\r\nYou may retrieve the latest version of SynEdit from the SynEdit home page,\r\nlocated at http://SynEdit.SourceForge.net\r\n\r\n-------------------------------------------------------------------------------}\r\n{\r\n@abstract(Plugin for SynEdit to make links (URIs) clickable)\r\n@author(Mal Hrz)\r\n@created(2003)\r\n@lastmod(2004-03-19)\r\nThe SynURIOpener unit extends SynEdit to make links highlighted by SynURISyn\r\nclickable.\r\n\r\nhttp://www.mh-net.de.vu\r\n}\r\n\r\n{$IFNDEF QSYNURIOPENER}\r\nunit SynURIOpener;\r\n{$ENDIF}\r\n\r\n{$I SynEdit.inc}\r\n              \r\ninterface\r\n\r\nuses\r\n  {$IFDEF SYN_LINUX}\r\n  Xlib,\r\n  {$ELSE}\r\n  Windows,\r\n  {$ENDIF}\r\n  {$IFDEF SYN_CLX}\r\n  Types,\r\n  Qt,\r\n  QControls,\r\n  QSynEditTypes,\r\n  QSynEdit,\r\n  QSynHighlighterURI,\r\n  QSynUnicode,\r\n  {$ELSE}\r\n  Controls,\r\n  SynEditTypes,\r\n  SynEdit,\r\n  SynHighlighterURI,\r\n  SynUnicode,\r\n  {$ENDIF}\r\n  Classes;\r\n\r\ntype\r\n  TSynURIOpener = class(TComponent)\r\n  private\r\n    FControlDown: Boolean;\r\n    FCtrlActivatesLinks: Boolean;\r\n    FEditor: TCustomSynEdit;\r\n    FMouseDownX: Integer;\r\n    FMouseDownY: Integer;\r\n\r\n    FURIHighlighter: TSynURISyn;\r\n    FVisitedURIs: TStringList;\r\n    {$IFDEF SYN_LINUX}\r\n    FFtpClientCmd: string;\r\n    FGopherClientCmd: string;\r\n    FMailClientCmd: string;\r\n    FNewsClientCmd: string;\r\n    FNntpClientCmd: string;\r\n    FProsperoClientCmd: string;\r\n    FTelnetClientCmd: string;\r\n    FWaisClientCmd: string;\r\n    FWebBrowserCmd: string;\r\n    {$ENDIF}\r\n    procedure OpenLink(URI: string; LinkType: Integer);\r\n    function MouseInSynEdit: Boolean;\r\n  protected\r\n    procedure NewKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);\r\n    procedure NewKeyUp(Sender: TObject; var Key: Word; Shift: TShiftState);\r\n    procedure NewMouseCursor(Sender: TObject; const aLineCharPos: TBufferCoord;\r\n      var aCursor: TCursor);\r\n    procedure NewMouseDown(Sender: TObject; Button: TMouseButton;\r\n      Shift: TShiftState; X, Y: Integer);\r\n    procedure NewMouseUp(Sender: TObject; Button: TMouseButton;\r\n      Shift: TShiftState; X, Y: Integer);\r\n\r\n    procedure Notification(AComponent: TComponent; Operation: TOperation); override;\r\n\r\n    procedure SetEditor(const Value: TCustomSynEdit);\r\n    procedure SetURIHighlighter(const Value: TSynURISyn);\r\n  public\r\n    constructor Create(AOwner: TComponent); override;\r\n    destructor Destroy; override;\r\n    function VisitedURI(URI: UnicodeString): Boolean;\r\n  published\r\n    property CtrlActivatesLinks: Boolean read FCtrlActivatesLinks\r\n      write FCtrlActivatesLinks default True;\r\n    property Editor: TCustomSynEdit read FEditor write SetEditor;\r\n    property URIHighlighter: TSynURISyn read FURIHighlighter \r\n      write SetURIHighlighter;\r\n    {$IFDEF SYN_LINUX}\r\n    // examples how to set WebBrowserCmd; %s is the placeholder for the URI\r\n    // 'kfmclient openURL %s'\r\n    // 'mozilla %s'\r\n    // 'netscape %s'\r\n    // 'kfmclient exec %s' similar to Windows ShellExecute\r\n    //\r\n    // You should let the user set these properties as there is no command\r\n    // or environment variable valid/available on all UN*X-systems.\r\n    // It depends on what window-manager and browser is installed.\r\n    property FtpClientCmd: string read FFtpClientCmd write FFtpClientCmd;\r\n    property GopherClientCmd: string read FGopherClientCmd write FGopherClientCmd;\r\n    property MailClientCmd: string read FMailClientCmd write FMailClientCmd;\r\n    property NewsClientCmd: string read FNewsClientCmd write FNewsClientCmd;\r\n    property NntpClientCmd: string read FNntpClientCmd write FNntpClientCmd;\r\n    property ProsperoClientCmd: string read FProsperoClientCmd write FProsperoClientCmd;\r\n    property TelnetClientCmd: string read FTelnetClientCmd write FTelnetClientCmd;\r\n    property WaisClientCmd: string read FWaisClientCmd write FWaisClientCmd;\r\n    property WebBrowserCmd: string read FWebBrowserCmd write FWebBrowserCmd;\r\n    {$ENDIF}\r\n  end;\r\n\r\n\r\nimplementation\r\n\r\nuses\r\n  {$IFDEF SYN_LINUX}\r\n  Libc,\r\n  {$ELSE}\r\n  ShellAPI,\r\n  {$ENDIF}\r\n  {$IFDEF SYN_CLX}\r\n  QForms,\r\n  QSynEditHighlighter,\r\n  QSynEditKeyConst,\r\n  {$ELSE}\r\n  Forms,\r\n  SynEditHighlighter,\r\n  SynEditKeyConst,\r\n  {$ENDIF}\r\n  SysUtils;\r\n\r\ntype\r\n  TAccessCustomSynEdit = class(TCustomSynEdit);\r\n  TAccessSynURISyn = class(TSynURISyn);\r\n\r\n{ TSynURIOpener }\r\n\r\nconstructor TSynURIOpener.Create(AOwner: TComponent);\r\nbegin\r\n  inherited;\r\n  FCtrlActivatesLinks := True;\r\n  FVisitedURIs := TStringList.Create;\r\n  FVisitedURIs.Sorted := True;\r\nend;\r\n\r\ndestructor TSynURIOpener.Destroy;\r\nbegin\r\n  FVisitedURIs.Free;\r\n  inherited;\r\nend;\r\n\r\nfunction TSynURIOpener.MouseInSynEdit: Boolean;\r\nvar\r\n  pt: TPoint;\r\nbegin\r\n  {$IFDEF SYN_COMPILER_6_UP}\r\n  pt := Mouse.CursorPos;\r\n  {$ELSE}\r\n  GetCursorPos(pt);\r\n  {$ENDIF}\r\n  Result := PtInRect(FEditor.ClientRect, FEditor.ScreenToClient(pt))\r\nend;\r\n\r\nprocedure TSynURIOpener.NewKeyDown(Sender: TObject; var Key: Word;\r\n  Shift: TShiftState);\r\nbegin\r\n  if (Key = SYNEDIT_CONTROL) and not FControlDown and MouseInSynEdit then\r\n  begin\r\n    FControlDown := True;\r\n    TAccessCustomSynEdit(FEditor).UpdateMouseCursor;\r\n  end;\r\nend;\r\n\r\nprocedure TSynURIOpener.NewKeyUp(Sender: TObject; var Key: Word;\r\n  Shift: TShiftState);\r\nbegin\r\n  if (Key = SYNEDIT_CONTROL) and FControlDown then\r\n  begin\r\n    FControlDown := False;\r\n    TAccessCustomSynEdit(FEditor).UpdateMouseCursor;\r\n  end;\r\nend;\r\n\r\nfunction IsControlPressed: Boolean;\r\n{$IFDEF SYN_LINUX}\r\nvar\r\n  keymap: TXQueryKeyMap;\r\n{$ENDIF}\r\nbegin\r\n{$IFDEF SYN_LINUX}\r\n  XQueryKeymap(Xlib.PDisplay(QtDisplay), keymap);\r\n  Result := (Byte(keymap[4]) and $20 = $20);\r\n{$ELSE}\r\n  Result := GetAsyncKeyState(VK_CONTROL) <> 0;\r\n{$ENDIF}\r\nend;\r\n\r\nprocedure TSynURIOpener.NewMouseCursor(Sender: TObject;\r\n  const aLineCharPos: TBufferCoord; var aCursor: TCursor);\r\nvar\r\n  TokenType, Start: Integer;\r\n  Token: UnicodeString;\r\n  Attri: TSynHighlighterAttributes;\r\nbegin\r\n  FControlDown := IsControlPressed;\r\n  if not(FCtrlActivatesLinks and not FControlDown or\r\n    (csDesigning in FEditor.ComponentState)) and FEditor.Focused\r\n  then\r\n    with FEditor do\r\n    begin\r\n      GetHighlighterAttriAtRowColEx(aLineCharPos, Token, TokenType, Start, Attri);\r\n      if Assigned(URIHighlighter) and ((Attri = URIHighlighter.URIAttri) or\r\n        (Attri = URIHighlighter.VisitedURIAttri)) and\r\n        not((eoDragDropEditing in Options) and IsPointInSelection(aLineCharPos))\r\n      then\r\n        aCursor := crHandPoint\r\n    end\r\nend;\r\n\r\nprocedure TSynURIOpener.NewMouseDown(Sender: TObject; Button: TMouseButton;\r\n  Shift: TShiftState; X, Y: Integer);\r\nbegin\r\n  if (Button = mbLeft) and not(FCtrlActivatesLinks) or FControlDown then\r\n  begin\r\n    FMouseDownX := X;\r\n    FMouseDownY := Y;\r\n  end\r\nend;\r\n\r\nprocedure TSynURIOpener.NewMouseUp(Sender: TObject; Button: TMouseButton;\r\n  Shift: TShiftState; X, Y: Integer);\r\nvar\r\n  ptLineCol: TBufferCoord;\r\n  TokenType, Start: Integer;\r\n  Token: UnicodeString;\r\n  Attri: TSynHighlighterAttributes;\r\nbegin\r\n  if (Button <> mbLeft) or (FCtrlActivatesLinks and not FControlDown) or\r\n    (Abs(FMouseDownX - X) > 4) or (Abs(FMouseDownY - Y) > 4) then exit;\r\n\r\n  with TAccessCustomSynEdit(FEditor) do\r\n  begin\r\n    if (eoDragDropEditing in Options) and IsPointInSelection(ptLineCol) then\r\n      exit;\r\n\r\n    if X >= fGutterWidth then\r\n    begin\r\n      ptLineCol := DisplayToBufferPos(PixelsToRowColumn(X,Y));\r\n\r\n      GetHighlighterAttriAtRowColEx(ptLineCol, Token, TokenType, Start, Attri);\r\n      if Assigned(URIHighlighter) and ((Attri = URIHighlighter.URIAttri) or\r\n        (Attri = URIHighlighter.VisitedURIAttri)) and\r\n        not((eoDragDropEditing in Options) and IsPointInSelection(ptLineCol)) then\r\n      begin\r\n        OpenLink(Token, TokenType);\r\n        InvalidateLine(ptLineCol.Line);\r\n      end;\r\n    end\r\n  end;\r\nend;\r\n\r\nprocedure TSynURIOpener.Notification(AComponent: TComponent;\r\n  Operation: TOperation);\r\nbegin\r\n  inherited;\r\n  if (Operation = opRemove) and Assigned(Editor) and (AComponent = Editor) then\r\n    Editor := nil;\r\n  if (Operation = opRemove) and Assigned(URIHighlighter) and\r\n    (AComponent = URIHighlighter)\r\n  then\r\n    URIHighlighter := nil;\r\nend;\r\n\r\nprocedure TSynURIOpener.OpenLink(URI: string; LinkType: Integer);\r\n{$IFDEF SYN_LINUX}\r\nvar\r\n  CmdLine: string;\r\n{$ENDIF}\r\nbegin\r\n  FVisitedURIs.Add(URI);\r\n\r\n  case TtkTokenKind(LinkType) of\r\n    tkMailtoLink:\r\n      if (Pos('mailto:', URI) <> 1) then URI := 'mailto:' + URI;\r\n    tkWebLink:\r\n       URI := 'http://' + URI;\r\n  end;\r\n  {$IFDEF SYN_LINUX}\r\n  case TtkTokenKind(LinkType) of\r\n    tkFtpLink:\r\n      CmdLine := Format(FFtpClientCmd, [URI]);\r\n    tkGopherLink:\r\n      CmdLine := Format(FGopherClientCmd, [URI]);\r\n    tkMailtoLink:\r\n      CmdLine := Format(FMailClientCmd, [URI]);\r\n    tkNewsLink:\r\n      CmdLine := Format(FNewsClientCmd, [URI]);\r\n    tkNntpLink:\r\n      CmdLine := Format(FNntpClientCmd, [URI]);\r\n    tkProsperoLink:\r\n      CmdLine := Format(FProsperoClientCmd, [URI]);\r\n    tkTelnetLink:\r\n      CmdLine := Format(FTelnetClientCmd, [URI]);\r\n    tkWaisLink:\r\n      CmdLine := Format(FWaisClientCmd, [URI]);\r\n    tkWebLink, tkHttpLink, tkHttpsLink:\r\n      CmdLine := Format(FWebBrowserCmd, [URI]);\r\n  end;\r\n  Libc.system(PAnsiChar(CmdLine + ' &')); // add an ampersand to return immediately\r\n  {$ELSE}\r\n  ShellExecute(0, nil, PChar(URI), nil, nil, 1{SW_SHOWNORMAL});\r\n  {$ENDIF}\r\nend;\r\n\r\nprocedure TSynURIOpener.SetEditor(const Value: TCustomSynEdit);\r\nbegin\r\n  if Editor <> Value then\r\n  begin\r\n    if not(csDesigning in ComponentState) and Assigned(FEditor) then\r\n    begin\r\n      with FEditor do\r\n      begin\r\n        RemoveKeyDownHandler(NewKeyDown);\r\n        RemoveKeyUpHandler(NewKeyUp);\r\n        RemoveMouseCursorHandler(NewMouseCursor);\r\n        RemoveMouseDownHandler(NewMouseDown);\r\n        RemoveMouseUpHandler(NewMouseUp);\r\n      end;\r\n    end;\r\n\r\n    FEditor := Value;\r\n\r\n    if not(csDesigning in ComponentState) and Assigned(FEditor) then\r\n    begin\r\n      with FEditor do\r\n      begin\r\n        AddKeyDownHandler(NewKeyDown);\r\n        AddKeyUpHandler(NewKeyUp);\r\n        AddMouseCursorHandler(NewMouseCursor);\r\n        AddMouseDownHandler(NewMouseDown);\r\n        AddMouseUpHandler(NewMouseUp);\r\n      end;\r\n    end;\r\n  end;\r\nend;\r\n\r\nprocedure TSynURIOpener.SetURIHighlighter(const Value: TSynURISyn);\r\nbegin\r\n  if not(csDesigning in ComponentState) and Assigned(URIHighlighter) then\r\n    TAccessSynURISyn(FURIHighlighter).SetAlreadyVisitedURIFunc(nil);\r\n\r\n  FURIHighlighter := Value;\r\n\r\n  if not(csDesigning in ComponentState) and  Assigned(URIHighlighter) then\r\n    TAccessSynURISyn(FURIHighlighter).SetAlreadyVisitedURIFunc(VisitedURI);\r\nend;\r\n\r\nfunction TSynURIOpener.VisitedURI(URI: UnicodeString): Boolean;\r\nvar\r\n  Dummy: Integer;\r\nbegin\r\n  Result := FVisitedURIs.Find(URI, Dummy);\r\nend;\r\n\r\n{$IFNDEF SYN_CLX}\r\nconst\r\n  IDC_LINK = MakeIntResource(32649);\r\n\r\nvar\r\n  CursorHandle: THandle;\r\n\r\ninitialization\r\n  CursorHandle := LoadCursor(0, IDC_LINK);\r\n  if CursorHandle <> 0 then\r\n    Screen.Cursors[crHandPoint] := CursorHandle;\r\n{$ENDIF}\r\n\r\nend.\r\n"
  },
  {
    "path": "External/SynEdit/Source/SynUnicode.pas",
    "content": "{-------------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is SynUnicode.pas by Mal Hrz, released 2004-05-30.\r\nAll Rights Reserved.\r\nTUnicodeStrings/TUnicodeStringList-code (originally written by Mike Lischke) is based\r\non JclUnicode.pas which is part of the JCL (www.delphi-jedi.org).\r\n\r\nContributors to the SynEdit and mwEdit projects are listed in the\r\nContributors.txt file.\r\n\r\nAlternatively, the contents of this file may be used under the terms of the\r\nGNU General Public License Version 2 or later (the \"GPL\"), in which case\r\nthe provisions of the GPL are applicable instead of those above.\r\nIf you wish to allow use of your version of this file only under the terms\r\nof the GPL and not to allow others to use your version of this file\r\nunder the MPL, indicate your decision by deleting the provisions above and\r\nreplace them with the notice and other provisions required by the GPL.\r\nIf you do not delete the provisions above, a recipient may use your version\r\nof this file under either the MPL or the GPL.\r\n\r\n$Id: SynUnicode.pas,v 1.1.3.19 2012/11/07 08:54:20 CodehunterWorks Exp $\r\n\r\nYou may retrieve the latest version of this file at the SynEdit home page,\r\nlocated at http://SynEdit.SourceForge.net\r\n\r\nProvides:\r\n- Unicode(PWideChar) versions of the most important PAnsiChar-functions in\r\n  SysUtils and some functions unavailable in Delphi 5.\r\n- An adapted and lighter version of TUnicodeStrings/TUnicodeStringList taken\r\n  from JCL, but made portable.\r\n- function for loading and saving of Unicode files, and detecting the encoding\r\n- Unicode clipboard support\r\n- Unicode-version of TCanvas-methods\r\n- Some character constants like CR&LF.\r\n\r\nLast Changes:\r\n- 1.1.3.19: Added TUnicodeStringList.CustomSort\r\n-------------------------------------------------------------------------------}\r\n\r\n{$IFNDEF QSYNUNICODE}\r\nunit SynUnicode;\r\n{$ENDIF}\r\n\r\n{$I SynEdit.inc}\r\n\r\ninterface\r\n\r\nuses\r\n  {$IFDEF SYN_WIN32}\r\n  Windows,\r\n  {$ENDIF}\r\n  {$IFDEF SYN_CLX}\r\n  QGraphics,\r\n  QClipbrd,  \r\n  {$ELSE}\r\n  Messages,\r\n  Controls,\r\n  Forms,\r\n  Graphics,\r\n  Clipbrd,  \r\n  {$ENDIF}\r\n  {$IFDEF SYN_COMPILER_6_UP}\r\n  Types,\r\n  {$ENDIF}\r\n  Classes,\r\n  SysUtils,\r\n  TypInfo;\r\n\r\n{$IFNDEF SYN_COMPILER_6_UP}\r\ntype\r\n  UTF8String = type string;\r\n  PUTF8String = ^UTF8String;\r\n{$ENDIF}\r\n{$IFNDEF UNICODE}\r\ntype\r\n  UnicodeString = WideString;\r\n{$ENDIF}\r\n\r\nconst\r\n  SLineBreak = {$IFDEF SYN_LINUX} #10 {$ELSE} #13#10 {$ENDIF};\r\n  UTF8BOM: array[0..2] of Byte = ($EF, $BB, $BF);\r\n  UTF16BOMLE: array[0..1] of Byte = ($FF, $FE);\r\n  UTF16BOMBE: array[0..1] of Byte = ($FE, $FF);\r\n  UTF32BOMLE: array[0..3] of Byte = ($FF, $FE, $00, $00);\r\n  UTF32BOMBE: array[0..3] of Byte = ($00, $00, $FE, $FF);\r\n\r\nconst\r\n  // constants describing range of the Unicode Private Use Area (Unicode 3.2)\r\n  PrivateUseLow = WideChar($E000);\r\n  PrivateUseHigh = WideChar($F8FF);\r\n  // filler char: helper for painting wide glyphs \r\n  FillerChar = PrivateUseLow;\r\n\r\nconst\r\n  WideNull = WideChar(#0);\r\n  WideTabulator = WideChar(#9);\r\n  WideSpace = WideChar(#32);\r\n\r\n  // logical line breaks\r\n  WideLF = WideChar(#10);\r\n  WideLineFeed = WideChar(#10);\r\n  WideVerticalTab = WideChar(#11);\r\n  WideFormFeed = WideChar(#12);\r\n  WideCR = WideChar(#13);\r\n  WideCarriageReturn = WideChar(#13);\r\n  WideCRLF = UnicodeString(#13#10);\r\n  WideLineSeparator = WideChar($2028);\r\n  WideParagraphSeparator = WideChar($2029);\r\n\r\n  // byte order marks for Unicode files\r\n  // Unicode text files (in UTF-16 format) should contain $FFFE as first character to\r\n  // identify such a file clearly. Depending on the system where the file was created\r\n  // on this appears either in big endian or little endian style.\r\n  BOM_LSB_FIRST = WideChar($FEFF);\r\n  BOM_MSB_FIRST = WideChar($FFFE);\r\n\r\ntype\r\n  TSaveFormat = (sfUTF16LSB, sfUTF16MSB, sfUTF8, sfAnsi);\r\n\r\nconst\r\n  sfUnicodeLSB = sfUTF16LSB;\r\n  sfUnicodeMSB = sfUTF16MSB;\r\n\r\ntype\r\n  TFontCharSet = 0..255;\r\n\r\n{$IFDEF UNICODE}\r\n  TUnicodeStrings = TStrings;\r\n{$ELSE}\r\n{ TUnicodeStrings }\r\n\r\n  TUnicodeStrings = class;\r\n\r\n  // Event used to give the application a chance to switch the way of how to save\r\n  // the text in TUnicodeStrings if the text contains characters not only from the\r\n  // ANSI block but the save type is ANSI. On triggering the event the application\r\n  // can change the property SaveUnicode as needed. This property is again checked\r\n  // after the callback returns.\r\n  TConfirmConversionEvent = procedure (Sender: TUnicodeStrings; var Allowed: Boolean) of object;\r\n\r\n  TUnicodeStrings = class(TPersistent)\r\n  private\r\n    FUpdateCount: Integer;\r\n    FSaved: Boolean;        // set in SaveToStream, True in case saving was successfull otherwise False\r\n    FOnConfirmConversion: TConfirmConversionEvent;\r\n    FSaveFormat: TSaveFormat;  // overrides the FSaveUnicode flag, initialized when a file is loaded,\r\n                               // expect losses if it is set to sfAnsi before saving\r\n    function GetCommaText: UnicodeString;\r\n    function GetName(Index: Integer): UnicodeString;\r\n    function GetValue(const Name: UnicodeString): UnicodeString;\r\n    procedure ReadData(Reader: TReader);\r\n    procedure SetCommaText(const Value: UnicodeString);\r\n    procedure SetValue(const Name, Value: UnicodeString);\r\n    procedure WriteData(Writer: TWriter);\r\n    function GetSaveUnicode: Boolean;\r\n    procedure SetSaveUnicode(const Value: Boolean);\r\n  protected\r\n    procedure DefineProperties(Filer: TFiler); override;\r\n    procedure DoConfirmConversion(var Allowed: Boolean); virtual;\r\n    procedure Error(const Msg: string; Data: Integer);\r\n    function Get(Index: Integer): UnicodeString; virtual; abstract;\r\n    function GetCapacity: Integer; virtual;\r\n    function GetCount: Integer; virtual; abstract;\r\n    function GetObject(Index: Integer): TObject; virtual;\r\n    function GetTextStr: UnicodeString; virtual;\r\n    procedure Put(Index: Integer; const S: UnicodeString); virtual; abstract;\r\n    procedure PutObject(Index: Integer; AObject: TObject); virtual; abstract;\r\n    procedure SetCapacity(NewCapacity: Integer); virtual;\r\n    procedure SetUpdateState(Updating: Boolean); virtual;\r\n  public\r\n    constructor Create;\r\n\r\n    function Add(const S: UnicodeString): Integer; virtual;\r\n    function AddObject(const S: UnicodeString; AObject: TObject): Integer; virtual;\r\n    procedure Append(const S: UnicodeString);\r\n    procedure AddStrings(Strings: TStrings); overload; virtual;\r\n    procedure AddStrings(Strings: TUnicodeStrings); overload; virtual;\r\n    procedure Assign(Source: TPersistent); override;\r\n    procedure AssignTo(Dest: TPersistent); override;\r\n    procedure BeginUpdate;\r\n    procedure Clear; virtual; abstract;\r\n    procedure Delete(Index: Integer); virtual; abstract;\r\n    procedure EndUpdate;\r\n    function Equals(Strings: TUnicodeStrings): Boolean;\r\n    procedure Exchange(Index1, Index2: Integer); virtual;\r\n    function GetSeparatedText(Separators: UnicodeString): UnicodeString; virtual;\r\n    function GetText: PWideChar; virtual;\r\n    function IndexOf(const S: UnicodeString): Integer; virtual;\r\n    function IndexOfName(const Name: UnicodeString): Integer;\r\n    function IndexOfObject(AObject: TObject): Integer;\r\n    procedure Insert(Index: Integer; const S: UnicodeString); virtual; abstract;\r\n    procedure InsertObject(Index: Integer; const S: UnicodeString; AObject: TObject);\r\n    procedure LoadFromFile(const FileName: TFileName); virtual;\r\n    procedure LoadFromStream(Stream: TStream); virtual;\r\n    procedure Move(CurIndex, NewIndex: Integer); virtual;\r\n    procedure SaveToFile(const FileName: TFileName); virtual;\r\n    procedure SaveToStream(Stream: TStream; WithBOM: Boolean = True); virtual;\r\n    procedure SetTextStr(const Value: UnicodeString); virtual;\r\n\r\n    property Capacity: Integer read GetCapacity write SetCapacity;\r\n    property CommaText: UnicodeString read GetCommaText write SetCommaText;\r\n    property Count: Integer read GetCount;\r\n    property Names[Index: Integer]: UnicodeString read GetName;\r\n    property Objects[Index: Integer]: TObject read GetObject write PutObject;\r\n    property Values[const Name: UnicodeString]: UnicodeString read GetValue write SetValue;\r\n    property Saved: Boolean read FSaved;\r\n    property SaveUnicode: Boolean read GetSaveUnicode write SetSaveUnicode default True;\r\n    property SaveFormat: TSaveFormat read FSaveFormat write FSaveFormat default sfUnicodeLSB;\r\n    property Strings[Index: Integer]: UnicodeString read Get write Put; default;\r\n    property Text: UnicodeString read GetTextStr write SetTextStr;\r\n\r\n    property OnConfirmConversion: TConfirmConversionEvent read FOnConfirmConversion write FOnConfirmConversion;\r\n  end;\r\n{$ENDIF}\r\n\r\n{$IFDEF UNICODE}\r\n  TUnicodeStringList = TStringList;\r\n{$ELSE}\r\n{ TUnicodeStringList }\r\n  \r\n  //----- TUnicodeStringList class\r\n  TDynWideCharArray = array of WideChar;\r\n  TUnicodeStringItem = record\r\n    {$IFDEF OWN_UnicodeString_MEMMGR}\r\n    FString: PWideChar; // \"array of WideChar\";\r\n    {$ELSE}\r\n    FString: UnicodeString;\r\n    {$ENDIF OWN_UnicodeString_MEMMGR}\r\n    FObject: TObject;\r\n  end;\r\n\r\n  TUnicodeStringList = class;\r\n  TUnicodeStringItemList = array of TUnicodeStringItem;\r\n  TUnicodeStringListSortCompare = function (AString1, AString2: UnicodeString): Integer;\r\n\r\n  TUnicodeStringList = class(TUnicodeStrings)\r\n  private\r\n    FList: TUnicodeStringItemList;\r\n    FCount: Integer;\r\n    FSorted: Boolean;\r\n    FDuplicates: TDuplicates;\r\n    FOnChange: TNotifyEvent;\r\n    FOnChanging: TNotifyEvent;\r\n    procedure ExchangeItems(Index1, Index2: Integer);\r\n    procedure Grow;\r\n    procedure QuickSort(L, R: Integer); overload;\r\n    procedure QuickSort(L, R: Integer; SCompare: TUnicodeStringListSortCompare); overload;\r\n    procedure InsertItem(Index: Integer; const S: UnicodeString);\r\n    procedure SetSorted(Value: Boolean);\r\n    {$IFDEF OWN_UnicodeString_MEMMGR}\r\n    procedure SetListString(Index: Integer; const S: UnicodeString);\r\n    {$ENDIF OWN_UnicodeString_MEMMGR}\r\n  protected\r\n    procedure Changed; virtual;\r\n    procedure Changing; virtual;\r\n    function Get(Index: Integer): UnicodeString; override;\r\n    function GetCapacity: Integer; override;\r\n    function GetCount: Integer; override;\r\n    function GetObject(Index: Integer): TObject; override;\r\n    procedure Put(Index: Integer; const S: UnicodeString); override;\r\n    procedure PutObject(Index: Integer; AObject: TObject); override;\r\n    procedure SetCapacity(NewCapacity: Integer); override;\r\n    procedure SetUpdateState(Updating: Boolean); override;\r\n  public\r\n    destructor Destroy; override;\r\n\r\n    function Add(const S: UnicodeString): Integer; override;\r\n    procedure Clear; override;\r\n    procedure Delete(Index: Integer); override;\r\n    procedure Exchange(Index1, Index2: Integer); override;\r\n    function Find(const S: UnicodeString; var Index: Integer): Boolean; virtual;\r\n    function IndexOf(const S: UnicodeString): Integer; override;\r\n    procedure Insert(Index: Integer; const S: UnicodeString); override;\r\n    procedure Sort; virtual;\r\n    procedure CustomSort(Compare: TUnicodeStringListSortCompare); virtual;\r\n\r\n    property Duplicates: TDuplicates read FDuplicates write FDuplicates;\r\n    property Sorted: Boolean read FSorted write SetSorted;\r\n    property OnChange: TNotifyEvent read FOnChange write FOnChange;\r\n    property OnChanging: TNotifyEvent read FOnChanging write FOnChanging;\r\n  end;\r\n{$ENDIF}\r\n\r\n{$IFNDEF UNICODE}\r\n{ PWideChar versions of important PAnsiChar functions from SysUtils }\r\nfunction WStrLen(const Str: PWideChar): Cardinal;\r\nfunction WStrEnd(const Str: PWideChar): PWideChar;\r\nfunction WStrMove(Dest: PWideChar; const Source: PWideChar; Count: Integer): PWideChar;\r\nfunction WStrCopy(Dest: PWideChar; const Source: PWideChar): PWideChar;\r\nfunction WStrLCopy(Dest: PWideChar; const Source: PWideChar; MaxLen: Cardinal): PWideChar;\r\nfunction WStrCat(Dest: PWideChar; const Source: PWideChar): PWideChar;\r\nfunction WStrScan(const Str: PWideChar; Chr: WideChar): PWideChar;\r\nfunction WStrAlloc(Size: Cardinal): PWideChar;\r\nfunction WStrNew(const Str: PWideChar): PWideChar;\r\nprocedure WStrDispose(Str: PWideChar);\r\n{$ENDIF}\r\n\r\n\r\n{$IFNDEF SYN_COMPILER_6_UP}\r\n{$IFDEF SYN_WIN32} // Kylix should have that from version 1 on\r\nfunction UnicodeToUtf8(Dest: PAnsiChar; MaxDestBytes: Cardinal;\r\n  Source: PWideChar; SourceChars: Cardinal): Cardinal;\r\nfunction Utf8ToUnicode(Dest: PWideChar; MaxDestChars: Cardinal;\r\n  Source: PAnsiChar; SourceBytes: Cardinal): Cardinal;\r\nfunction UTF8Encode(const WS: UnicodeString): UTF8String;\r\nfunction UTF8Decode(const S: UTF8String): UnicodeString;\r\nfunction AnsiToUtf8(const S: string): UTF8String;\r\nfunction Utf8ToAnsi(const S: UTF8String): string;\r\n\r\nfunction WideCompareStr(const S1, S2: UnicodeString): Integer;\r\nfunction WideCompareText(const S1, S2: UnicodeString): Integer;\r\n{$ENDIF}\r\n{$ENDIF}\r\n\r\n// Kylix has them, but Delphi 5 doesn't and Delphi 6&7 versions are buggy\r\n// in Win9X (fix taken from Troy Wolbrinks TntUnicode-package)\r\n{$IFDEF SYN_WIN32}\r\n{$IFNDEF UNICODE}\r\nvar\r\n  DefaultSystemCodePage: Cardinal; // implicitly used when converting AnsiString <--> UnicodeString.\r\n{$ENDIF}\r\n  \r\nfunction WCharUpper(lpsz: PWideChar): PWideChar;\r\nfunction WCharUpperBuff(lpsz: PWideChar; cchLength: DWORD): DWORD;\r\nfunction WCharLower(lpsz: PWideChar): PWideChar;\r\nfunction WCharLowerBuff(lpsz: PWideChar; cchLength: DWORD): DWORD;\r\n{$ENDIF}\r\nfunction SynWideUpperCase(const S: UnicodeString): UnicodeString;\r\nfunction SynWideLowerCase(const S: UnicodeString): UnicodeString;\r\nfunction SynIsCharAlpha(const C: WideChar): Boolean;\r\nfunction SynIsCharAlphaNumeric(const C: WideChar): Boolean;\r\n{$IFNDEF UNICODE}\r\nfunction CharInSet(C: AnsiChar; const CharSet: TSysCharSet): Boolean; overload; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\nfunction CharInSet(C: WideChar; const CharSet: TSysCharSet): Boolean; overload; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}\r\n{$ENDIF}\r\n\r\nfunction WideLastDelimiter(const Delimiters, S: UnicodeString): Integer;\r\nfunction UnicodeStringReplace(const S, OldPattern, NewPattern: UnicodeString;\r\n  Flags: TReplaceFlags): UnicodeString;\r\n\r\n{ functions taken from JCLUnicode.pas }\r\nfunction WStrComp(Str1, Str2: PWideChar): Integer;\r\nfunction WStrLComp(Str1, Str2: PWideChar; MaxLen: Cardinal): Integer;\r\nprocedure StrSwapByteOrder(Str: PWideChar);\r\nfunction WideQuotedStr(const S: UnicodeString; Quote: WideChar): UnicodeString;\r\nfunction WideExtractQuotedStr(var Src: PWideChar; Quote: WideChar): UnicodeString;\r\nfunction UnicodeStringOfChar(C: WideChar; Count: Cardinal): UnicodeString;\r\nfunction WideTrim(const S: UnicodeString): UnicodeString;\r\nfunction WideTrimLeft(const S: UnicodeString): UnicodeString;\r\nfunction WideTrimRight(const S: UnicodeString): UnicodeString;\r\n{$IFDEF SYN_WIN32}\r\nfunction CharSetFromLocale(Language: LCID): TFontCharSet;\r\nfunction CodePageFromLocale(Language: LCID): Integer;\r\nfunction KeyboardCodePage: Word;\r\nfunction KeyUnicode(C: AnsiChar): WideChar;\r\nfunction StringToUnicodeStringEx(const S: AnsiString; CodePage: Word): UnicodeString;\r\nfunction UnicodeStringToStringEx(const WS: UnicodeString; CodePage: Word): AnsiString;\r\n{$ENDIF}\r\n\r\n{ functions providing same behavior on Win9x and WinNT based systems}\r\nfunction GetTextSize(DC: HDC; Str: PWideChar; Count: Integer): TSize;\r\n\r\n{ Unicode versions of TCanvas-methods }\r\nfunction TextExtent(ACanvas: TCanvas; const Text: UnicodeString): TSize;\r\nfunction TextWidth(ACanvas: TCanvas; const Text: UnicodeString): Integer;\r\nfunction TextHeight(ACanvas: TCanvas; const Text: UnicodeString): Integer;\r\nprocedure TextOut(ACanvas: TCanvas; X, Y: Integer; const Text: UnicodeString);\r\nprocedure TextRect(ACanvas: TCanvas; Rect: TRect; X, Y: Integer;\r\n  const Text: UnicodeString);\r\n\r\n{ Unicode streaming-support }\r\ntype\r\n  TSynEncoding = (seUTF8, seUTF16LE, seUTF16BE, seAnsi);\r\n  TSynEncodings = set of TSynEncoding;\r\n\r\n{$IFDEF UNICODE}\r\n  TWideFileStream = TFileStream;\r\n{$ELSE}\r\n  TWideFileStream = class(THandleStream)\r\n  public\r\n    constructor Create(const FileName: UnicodeString; Mode: Word); overload;\r\n    constructor Create(const FileName: UnicodeString; Mode: Word; Rights: Cardinal); overload;\r\n    destructor Destroy; override;\r\n  end;\r\n\r\nfunction WideFileOpen(const FileName: UnicodeString; Mode: LongWord): Integer;\r\nfunction WideFileCreate(const FileName: UnicodeString): Integer; overload;\r\nfunction WideFileCreate(const FileName: UnicodeString; Rights: Integer): Integer; overload;\r\n{$ENDIF}\r\n\r\nfunction IsAnsiOnly(const WS: UnicodeString): Boolean;\r\nfunction IsUTF8(Stream: TStream; out WithBOM: Boolean): Boolean; overload;\r\nfunction IsUTF8(const FileName: UnicodeString; out WithBOM: Boolean): Boolean; overload;\r\nfunction GetEncoding(const FileName: UnicodeString; out WithBOM: Boolean): TSynEncoding; overload;\r\nfunction GetEncoding(Stream: TStream; out WithBOM: Boolean): TSynEncoding; overload;\r\nprocedure SaveToFile(const WS: UnicodeString; const FileName: UnicodeString;\r\n  Encoding: TSynEncoding; WithBom: Boolean = True); overload;\r\nprocedure SaveToFile(UnicodeStrings: TUnicodeStrings; const FileName: UnicodeString;\r\n  Encoding: TSynEncoding; WithBom: Boolean = True); overload;\r\nfunction LoadFromFile(UnicodeStrings: TUnicodeStrings; const FileName: UnicodeString;\r\n  out WithBOM: Boolean): TSynEncoding; overload;\r\nfunction LoadFromFile(UnicodeStrings: TUnicodeStrings; const FileName: UnicodeString;\r\n  Encoding: TSynEncoding; out WithBOM: Boolean): TSynEncoding; overload;\r\nprocedure SaveToStream(const WS: UnicodeString; Stream: TStream;\r\n  Encoding: TSynEncoding; WithBom: Boolean  = True); overload;\r\nprocedure SaveToStream(UnicodeStrings: TUnicodeStrings; Stream: TStream;\r\n  Encoding: TSynEncoding; WithBom: Boolean  = True); overload;\r\nfunction LoadFromStream(UnicodeStrings: TUnicodeStrings; Stream: TStream;\r\n  out WithBOM: Boolean): TSynEncoding; overload;\r\nfunction LoadFromStream(UnicodeStrings: TUnicodeStrings; Stream: TStream;\r\n  Encoding: TSynEncoding; out WithBOM: Boolean): TSynEncoding; overload;\r\nfunction LoadFromStream(UnicodeStrings: TUnicodeStrings; Stream: TStream;\r\n  Encoding: TSynEncoding): TSynEncoding; overload;\r\n\r\nfunction ClipboardProvidesText: Boolean;\r\nfunction GetClipboardText: UnicodeString;\r\nprocedure SetClipboardText(const Text: UnicodeString);\r\n\r\n{ misc functions }\r\n{$IFNDEF UNICODE}\r\n{$IFNDEF SYN_COMPILER_6_UP}\r\nfunction GetWideStrProp(Instance: TObject; PropInfo: PPropInfo): UnicodeString;\r\nprocedure SetWideStrProp(Instance: TObject; PropInfo: PPropInfo; const Value: UnicodeString);\r\n{$ENDIF}\r\nprocedure UnicodeDefineProperties(Filer: TFiler; Instance: TPersistent);\r\n{$ENDIF}\r\n{$IFDEF SYN_WIN32}\r\nfunction IsWideCharMappableToAnsi(const WC: WideChar): Boolean;\r\nfunction IsUnicodeStringMappableToAnsi(const WS: UnicodeString): Boolean;\r\n{$ENDIF}\r\n\r\n{$IFDEF SYN_WIN32}\r\nvar\r\n  Win32PlatformIsUnicode: Boolean;\r\n{$ENDIF}\r\n\r\nimplementation\r\n\r\nuses\r\n  {$IFDEF SYN_CLX}\r\n  QSynEditTextBuffer,\r\n  {$ELSE}\r\n  SynEditTextBuffer,\r\n    {$IFDEF SYN_UNISCRIBE}\r\n    SynUsp10,\r\n    {$ENDIF}\r\n  {$ENDIF}\r\n  Math,\r\n  {$IFDEF SYN_LINUX}\r\n  Libc,\r\n  {$ENDIF}\r\n  {$IFDEF USE_TNT_RUNTIME_SUPPORT}\r\n  TntSysUtils, TntClasses,\r\n  {$ENDIF}\r\n  SysConst,\r\n  {$IFDEF SYN_COMPILER_6_UP}\r\n  RTLConsts;\r\n  {$ELSE}\r\n    {$IFDEF SYN_CLX}\r\n    QConsts;\r\n    {$ELSE}\r\n    Consts;\r\n    {$ENDIF}\r\n  {$ENDIF}\r\n\r\n{$IFNDEF UNICODE}\r\n{ TUnicodeStrings }\r\n\r\nconstructor TUnicodeStrings.Create;\r\nbegin\r\n  inherited;\r\n  FSaveFormat := sfUnicodeLSB;\r\nend;\r\n\r\nfunction TUnicodeStrings.GetSaveUnicode: Boolean;\r\nbegin\r\n  Result := SaveFormat in [sfUTF16LSB, sfUTF16MSB, sfUTF8];\r\nend;\r\n\r\nprocedure TUnicodeStrings.SetSaveUnicode(const Value: Boolean);\r\nbegin\r\n  if Value then\r\n    SaveFormat := sfUnicodeLSB\r\n  else\r\n    SaveFormat := sfAnsi;\r\nend;\r\n\r\nfunction TUnicodeStrings.Add(const S: UnicodeString): Integer;\r\nbegin\r\n  Result := GetCount;\r\n  Insert(Result, S);\r\nend;\r\n\r\nfunction TUnicodeStrings.AddObject(const S: UnicodeString; AObject: TObject): Integer;\r\nbegin\r\n  Result := Add(S);\r\n  PutObject(Result, AObject);\r\nend;\r\n\r\nprocedure TUnicodeStrings.Append(const S: UnicodeString);\r\nbegin\r\n  Add(S);\r\nend;\r\n\r\nprocedure TUnicodeStrings.AddStrings(Strings: TStrings);\r\nvar\r\n  I: Integer;\r\n{$IFDEF SYN_WIN32}\r\n  S: UnicodeString;\r\n  CP: Integer;\r\n{$ENDIF}\r\nbegin\r\n  BeginUpdate;\r\n  try\r\n    {$IFDEF SYN_WIN32}\r\n    CP := CodePageFromLocale(GetThreadLocale);\r\n    for I := 0 to Strings.Count - 1 do\r\n    begin\r\n      S := StringToUnicodeStringEx(Strings[I], CP);\r\n      AddObject(S, Strings.Objects[I]);\r\n    end;\r\n    {$ELSE}\r\n    for I := 0 to Strings.Count - 1 do\r\n      AddObject(Strings[I], Strings.Objects[I]);\r\n    {$ENDIF}\r\n  finally\r\n    EndUpdate;\r\n  end;\r\nend;\r\n\r\nprocedure TUnicodeStrings.AddStrings(Strings: TUnicodeStrings);\r\nvar\r\n  I: Integer;\r\nbegin\r\n  Assert(Strings <> nil);\r\n  \r\n  BeginUpdate;\r\n  try\r\n    for I := 0 to Strings.Count - 1 do\r\n      AddObject(Strings[I], Strings.Objects[I]);\r\n  finally\r\n    EndUpdate;\r\n  end;\r\nend;\r\n\r\nprocedure TUnicodeStrings.Assign(Source: TPersistent);\r\n// usual assignment routine, but able to assign wide and small strings\r\nbegin\r\n  if Source is TUnicodeStrings then\r\n  begin\r\n    BeginUpdate;\r\n    try\r\n      Clear;\r\n      AddStrings(TUnicodeStrings(Source));\r\n    finally\r\n      EndUpdate;\r\n    end;\r\n  end\r\n  else\r\n  begin\r\n    if Source is TStrings then\r\n    begin\r\n      BeginUpdate;\r\n      try\r\n        Clear;\r\n        AddStrings(TStrings(Source));\r\n      finally\r\n        EndUpdate;\r\n      end;\r\n    end\r\n    else\r\n      inherited Assign(Source);\r\n  end; \r\nend;\r\n\r\nprocedure TUnicodeStrings.AssignTo(Dest: TPersistent);\r\n// need to do also assignment to old style TStrings, but this class doesn't know\r\n// TUnicodeStrings, so we need to do it from here\r\nvar\r\n  I: Integer;\r\nbegin\r\n  if Dest is TStrings then\r\n  begin\r\n    with Dest as TStrings do\r\n    begin\r\n      BeginUpdate;\r\n      try\r\n        Clear;\r\n        for I := 0 to Self.Count - 1 do\r\n          AddObject(Self[I], Self.Objects[I]);\r\n      finally\r\n        EndUpdate;\r\n      end;\r\n    end;\r\n  end\r\n  else\r\n  begin\r\n    if Dest is TUnicodeStrings then\r\n    begin\r\n      with Dest as TUnicodeStrings do\r\n      begin\r\n        BeginUpdate;\r\n        try\r\n          Clear;\r\n          AddStrings(Self);\r\n        finally\r\n          EndUpdate;\r\n        end;\r\n      end;\r\n    end\r\n    else\r\n      inherited;\r\n  end;\r\nend;\r\n\r\nprocedure TUnicodeStrings.BeginUpdate;\r\nbegin\r\n  if FUpdateCount = 0 then\r\n    SetUpdateState(True);\r\n  Inc(FUpdateCount);\r\nend;\r\n\r\nprocedure TUnicodeStrings.DefineProperties(Filer: TFiler);\r\n// Defines a private property for the content of the list.\r\n// There's a bug in the handling of text DFMs in Classes.pas which prevents\r\n// UnicodeStrings from loading under some circumstances. Zbysek Hlinka\r\n// (zhlinka att login dott cz) brought this to my attention and supplied also a solution.\r\n// See ReadData and WriteData methods for implementation details.\r\n\r\n  function DoWrite: Boolean;\r\n  begin\r\n    if Filer.Ancestor <> nil then\r\n    begin\r\n      Result := True;\r\n      if Filer.Ancestor is TUnicodeStrings then\r\n        Result := not Equals(TUnicodeStrings(Filer.Ancestor))\r\n    end\r\n    else\r\n      Result := Count > 0;\r\n  end;\r\n\r\nbegin\r\n  Filer.DefineProperty('UnicodeStrings', ReadData, WriteData, DoWrite);\r\nend;\r\n\r\nprocedure TUnicodeStrings.DoConfirmConversion(var Allowed: Boolean);\r\nbegin\r\n  if Assigned(FOnConfirmConversion) then\r\n    FOnConfirmConversion(Self, Allowed);\r\nend;\r\n\r\nprocedure TUnicodeStrings.EndUpdate;\r\nbegin\r\n  Dec(FUpdateCount);\r\n  if FUpdateCount = 0 then\r\n    SetUpdateState(False);\r\nend;\r\n\r\nfunction TUnicodeStrings.Equals(Strings: TUnicodeStrings): Boolean;\r\nvar\r\n  I, Count: Integer;\r\nbegin\r\n  Assert(Strings <> nil);\r\n\r\n  Result := False;\r\n  Count := GetCount;\r\n  if Count <> Strings.GetCount then\r\n    Exit;\r\n  for I := 0 to Count - 1 do\r\n    if Get(I) <> Strings.Get(I) then\r\n      Exit;\r\n  Result := True;\r\nend;\r\n\r\nprocedure TUnicodeStrings.Error(const Msg: string; Data: Integer);\r\n\r\n  function ReturnAddr: Pointer;\r\n  asm\r\n          MOV     EAX, [EBP + 4]\r\n  end;\r\n\r\nbegin\r\n  raise EStringListError.CreateFmt(Msg, [Data]) at ReturnAddr;\r\nend;\r\n\r\nprocedure TUnicodeStrings.Exchange(Index1, Index2: Integer);\r\nvar\r\n  TempObject: TObject;\r\n  TempString: UnicodeString;\r\nbegin\r\n  BeginUpdate;\r\n  try\r\n    TempString := Strings[Index1];\r\n    TempObject := Objects[Index1];\r\n    Strings[Index1] := Strings[Index2];\r\n    Objects[Index1] := Objects[Index2];\r\n    Strings[Index2] := TempString;\r\n    Objects[Index2] := TempObject;\r\n  finally\r\n    EndUpdate;\r\n  end;\r\nend;\r\n\r\nfunction TUnicodeStrings.GetCapacity: Integer;\r\n// Descendants may optionally override/replace this default implementation.\r\nbegin\r\n  Result := Count;\r\nend;\r\n\r\nfunction TUnicodeStrings.GetCommaText: UnicodeString;\r\nvar\r\n  S: UnicodeString;\r\n  P: PWideChar;\r\n  I, Count: Integer;\r\nbegin\r\n  Count := GetCount;\r\n  if (Count = 1) and (Get(0) = '') then\r\n    Result := '\"\"'\r\n  else\r\n  begin\r\n    Result := '';\r\n    for I := 0 to Count - 1 do\r\n    begin\r\n      S := Get(I);\r\n      P := PWideChar(S);\r\n      while not (P^ in [WideNull..WideSpace, WideChar('\"'), WideChar(',')]) do\r\n        Inc(P);\r\n      if P^ <> WideNull then\r\n        S := WideQuotedStr(S, '\"');\r\n      Result := Result + S + ',';\r\n    end;\r\n    System.Delete(Result, Length(Result), 1);\r\n  end;\r\nend;\r\n\r\nfunction TUnicodeStrings.GetName(Index: Integer): UnicodeString;\r\nvar\r\n  P: Integer;\r\nbegin\r\n  Result := Get(Index);\r\n  P := Pos('=', Result);\r\n  if P > 0 then\r\n    SetLength(Result, P - 1)\r\n  else\r\n    Result := '';\r\nend;\r\n\r\nfunction TUnicodeStrings.GetObject(Index: Integer): TObject;\r\nbegin\r\n  Result := nil;\r\nend;\r\n\r\nfunction TUnicodeStrings.GetSeparatedText(Separators: UnicodeString): UnicodeString;\r\n// Same as GetText but with customizable separator characters.\r\nvar\r\n  I, L,\r\n  Size,\r\n  Count,\r\n  SepSize: Integer;\r\n  P: PWideChar;\r\n  S: UnicodeString;\r\nbegin\r\n  Count := GetCount;\r\n  SepSize := Length(Separators);\r\n  Size := 0;\r\n  for I := 0 to Count - 1 do\r\n    Inc(Size, Length(Get(I)) + SepSize);\r\n    \r\n  // set one separator less, the last line does not need a trailing separator\r\n  SetLength(Result, Size - SepSize);\r\n  if Size > 0 then\r\n  begin\r\n    P := Pointer(Result);\r\n    I := 0;\r\n    while True do\r\n    begin\r\n      S := Get(I);\r\n      L := Length(S);\r\n      if L <> 0 then\r\n      begin\r\n        // add current string\r\n        System.Move(Pointer(S)^, P^, 2 * L);\r\n        Inc(P, L);\r\n      end;\r\n      Inc(I);\r\n      if I = Count then\r\n        Break;\r\n        \r\n      // add separators\r\n      System.Move(Pointer(Separators)^, P^, SizeOf(WideChar) * SepSize);\r\n      Inc(P, SepSize);\r\n    end;\r\n  end;\r\nend;\r\n\r\nfunction TUnicodeStrings.GetTextStr: UnicodeString;\r\nbegin\r\n  Result := GetSeparatedText(WideCRLF);\r\nend;\r\n\r\nfunction TUnicodeStrings.GetText: PWideChar;\r\nbegin\r\n  Result := WStrNew(PWideChar(GetTextStr));\r\nend;\r\n\r\nfunction TUnicodeStrings.GetValue(const Name: UnicodeString): UnicodeString;\r\nvar\r\n  I: Integer;\r\nbegin\r\n  I := IndexOfName(Name);\r\n  if I >= 0 then\r\n    Result := Copy(Get(I), Length(Name) + 2, MaxInt)\r\n  else\r\n    Result := '';\r\nend;\r\n\r\nfunction TUnicodeStrings.IndexOf(const S: UnicodeString): Integer;\r\nbegin\r\n  for Result := 0 to GetCount - 1 do\r\n    if WideCompareText(Get(Result), S) = 0 then\r\n      Exit;\r\n  Result := -1;\r\nend;\r\n\r\nfunction TUnicodeStrings.IndexOfName(const Name: UnicodeString): Integer;\r\nvar\r\n  P: Integer;\r\n  S: UnicodeString;\r\nbegin\r\n  for Result := 0 to GetCount - 1 do\r\n  begin\r\n    S := Get(Result);\r\n    P := Pos('=', S);\r\n    if (P > 0) and (WideCompareText(Copy(S, 1, P - 1), Name) = 0) then\r\n      Exit;\r\n  end;\r\n  Result := -1;\r\nend;\r\n\r\nfunction TUnicodeStrings.IndexOfObject(AObject: TObject): Integer;\r\nbegin\r\n  for Result := 0 to GetCount - 1 do\r\n    if GetObject(Result) = AObject then\r\n      Exit;\r\n  Result := -1;\r\nend;\r\n\r\nprocedure TUnicodeStrings.InsertObject(Index: Integer; const S: UnicodeString; AObject: TObject);\r\nbegin\r\n  Insert(Index, S);\r\n  PutObject(Index, AObject);\r\nend;\r\n\r\nprocedure TUnicodeStrings.LoadFromFile(const FileName: TFileName);\r\nvar\r\n  Stream: TStream;\r\nbegin\r\n  Stream := TFileStream.Create(FileName, fmOpenRead or fmShareDenyNone);\r\n  try\r\n    LoadFromStream(Stream);\r\n  finally\r\n    Stream.Free;\r\n  end;\r\nend;\r\n\r\nprocedure TUnicodeStrings.LoadFromStream(Stream: TStream);\r\n// usual loader routine, but enhanced to handle byte order marks in stream\r\nvar\r\n  Size,\r\n  BytesRead: Integer;\r\n  ByteOrderMask: array[0..5] of Byte; // BOM size is max 5 bytes (cf: wikipedia)\r\n                                      // but it is easier to implement with a multiple of 2\r\n  Loaded: Boolean;\r\n  SW: UnicodeString;\r\n  SA: AnsiString;\r\nbegin\r\n  BeginUpdate;\r\n  try\r\n    Loaded := False;\r\n\r\n    Size := Stream.Size - Stream.Position;\r\n    BytesRead := Stream.Read(ByteOrderMask[0], SizeOf(ByteOrderMask));\r\n\r\n    // UTF16 LSB = Unicode LSB/LE\r\n    if (BytesRead >= 2) and (ByteOrderMask[0] = UTF16BOMLE[0])\r\n      and (ByteOrderMask[1] = UTF16BOMLE[1]) then\r\n    begin\r\n      FSaveFormat := sfUTF16LSB;\r\n      SetLength(SW, (Size - 2) div SizeOf(WideChar));\r\n      Assert((Size and 1) <> 1, 'Number of chars must be a multiple of 2');\r\n      if BytesRead > 2 then\r\n      begin\r\n        System.Move(ByteOrderMask[2], SW[1], BytesRead - 2); // max 4 bytes = 2 widechars\r\n        if Size > BytesRead then\r\n          // first 2 chars (maximum) were copied by System.Move\r\n          Stream.Read(SW[3], Size - BytesRead);\r\n      end;\r\n      SetTextStr(SW);\r\n      Loaded := True;\r\n    end;\r\n\r\n    // UTF16 MSB = Unicode MSB/BE\r\n    if (BytesRead >= 2) and (ByteOrderMask[0] = UTF16BOMBE[0])\r\n      and (ByteOrderMask[1] = UTF16BOMBE[1]) then\r\n    begin\r\n      FSaveFormat := sfUTF16MSB;\r\n      SetLength(SW, (Size - 2) div SizeOf(WideChar));\r\n      Assert((Size and 1) <> 1, 'Number of chars must be a multiple of 2');\r\n      if BytesRead > 2 then\r\n      begin\r\n        System.Move(ByteOrderMask[2], SW[1] ,BytesRead - 2); // max 4 bytes = 2 widechars\r\n        if Size > BytesRead then\r\n          // first 2 chars (maximum) were copied by System.Move\r\n          Stream.Read(SW[3], Size - BytesRead);\r\n        StrSwapByteOrder(PWideChar(SW));\r\n      end;\r\n      SetTextStr(SW);\r\n      Loaded := True;\r\n    end;\r\n\r\n    // UTF8\r\n    if (BytesRead >= 3) and (ByteOrderMask[0] = UTF8BOM[0])\r\n      and (ByteOrderMask[1] = UTF8BOM[1]) and (ByteOrderMask[2] = UTF8BOM[2]) then\r\n    begin\r\n      FSaveFormat := sfUTF8;\r\n      SetLength(SA, (Size - 3) div SizeOf(AnsiChar));\r\n      if BytesRead > 3 then\r\n      begin\r\n        System.Move(ByteOrderMask[3], SA[1], BytesRead - 3); // max 3 bytes = 3 chars\r\n        if Size > BytesRead then\r\n          // first 3 chars were copied by System.Move\r\n          Stream.Read(SA[4], Size - BytesRead);\r\n        SW := UTF8Decode(SA);\r\n      end;\r\n      SetTextStr(SW);\r\n      Loaded := True;\r\n    end;\r\n\r\n    // default case (Ansi)\r\n    if not Loaded then\r\n    begin\r\n      FSaveFormat := sfAnsi;\r\n      SetLength(SA, Size div SizeOf(AnsiChar));\r\n      if BytesRead > 0 then\r\n      begin\r\n        System.Move(ByteOrderMask[0], SA[1], BytesRead); // max 6 bytes = 6 chars\r\n        if Size > BytesRead then\r\n          Stream.Read(SA[7], Size - BytesRead); // first 6 chars were copied by System.Move\r\n      end;\r\n      SetTextStr(SA);\r\n    end;\r\n  finally\r\n    EndUpdate;\r\n  end;\r\nend;\r\n\r\nprocedure TUnicodeStrings.Move(CurIndex, NewIndex: Integer);\r\nvar\r\n  TempObject: TObject;\r\n  TempString: UnicodeString;\r\nbegin\r\n  if CurIndex <> NewIndex then\r\n  begin\r\n    BeginUpdate;\r\n    try\r\n      TempString := Get(CurIndex);\r\n      TempObject := GetObject(CurIndex);\r\n      Delete(CurIndex);\r\n      InsertObject(NewIndex, TempString, TempObject);\r\n    finally\r\n      EndUpdate;\r\n    end;\r\n  end;\r\nend;\r\n\r\nprocedure TUnicodeStrings.ReadData(Reader: TReader);\r\nbegin\r\n  case Reader.NextValue of\r\n    vaLString, vaString:\r\n      SetTextStr(Reader.ReadString);\r\n  else\r\n    SetTextStr(Reader.ReadWideString);\r\n  end;\r\nend;\r\n\r\nprocedure TUnicodeStrings.SaveToFile(const FileName: TFileName);\r\nvar\r\n  Stream: TStream;\r\nbegin\r\n  Stream := TFileStream.Create(FileName, fmCreate);\r\n  try\r\n    SaveToStream(Stream);\r\n  finally\r\n    Stream.Free;\r\n  end;\r\nend;\r\n\r\nprocedure TUnicodeStrings.SaveToStream(Stream: TStream; WithBOM: Boolean = True);\r\n// Saves the currently loaded text into the given stream. WithBOM determines whether to write a\r\n// byte order mark or not. Note: when saved as ANSI text there will never be a BOM.\r\nvar\r\n  SW: UnicodeString;\r\n  SA: AnsiString;\r\n  Allowed: Boolean;\r\n  Run: PWideChar;\r\nbegin\r\n  // The application can decide in which format to save the content.\r\n  // If FSaveUnicode is False then all strings are saved in standard ANSI format\r\n  // which is also loadable by TStrings but you should be aware that all Unicode\r\n  // strings are then converted to ANSI based on the current system locale.\r\n  // An extra event is supplied to ask the user about the potential loss of\r\n  // information when converting Unicode to ANSI strings.\r\n  SW := GetTextStr;\r\n  Allowed := True;\r\n  FSaved := False; // be pessimistic\r\n  // A check for potential information loss makes only sense if the application has\r\n  // set an event to be used as call back to ask about the conversion.\r\n  if not SaveUnicode and Assigned(FOnConfirmConversion) then\r\n  begin\r\n    // application requests to save only ANSI characters, so check the text and\r\n    // call back in case information could be lost\r\n    Run := PWideChar(SW);\r\n    // only ask if there's at least one Unicode character in the text\r\n    while Run^ in [WideChar(#1)..WideChar(#255)] do\r\n      Inc(Run);\r\n    // Note: The application can still set FSaveUnicode to True in the callback.\r\n    if Run^ <> WideNull then\r\n      DoConfirmConversion(Allowed);\r\n  end;\r\n\r\n  if Allowed then\r\n  begin\r\n    // only save if allowed\r\n    case SaveFormat of\r\n      sfUTF16LSB:\r\n        begin\r\n          if WithBOM then\r\n            Stream.WriteBuffer(UTF16BOMLE[0], SizeOf(UTF16BOMLE));\r\n          Stream.WriteBuffer(SW[1], Length(SW) * SizeOf(WideChar));\r\n          FSaved := True;\r\n        end;\r\n      sfUTF16MSB:\r\n        begin\r\n          if WithBOM then\r\n            Stream.WriteBuffer(UTF16BOMBE[0], SizeOf(UTF16BOMBE));\r\n          StrSwapByteOrder(PWideChar(SW));\r\n          Stream.WriteBuffer(SW[1], Length(SW) * SizeOf(WideChar));\r\n          FSaved := True;\r\n        end;\r\n      sfUTF8:\r\n        begin\r\n          if WithBOM then\r\n            Stream.WriteBuffer(UTF8BOM[0], SizeOf(UTF8BOM));\r\n          SA := UTF8Encode(SW);\r\n          Stream.WriteBuffer(SA[1], Length(SA) * SizeOf(AnsiChar));\r\n          FSaved := True;\r\n        end;\r\n      sfAnsi:\r\n        begin\r\n          SA := SW;\r\n          Stream.WriteBuffer(SA[1], Length(SA) * SizeOf(AnsiChar));\r\n          FSaved := True;\r\n        end;\r\n    end;\r\n  end;\r\nend;\r\n\r\nprocedure TUnicodeStrings.SetCapacity(NewCapacity: Integer);\r\nbegin\r\n  // do nothing - descendants may optionally implement this method\r\nend;\r\n\r\nprocedure TUnicodeStrings.SetCommaText(const Value: UnicodeString);\r\nvar\r\n  P, P1: PWideChar;\r\n  S: UnicodeString;\r\nbegin\r\n  BeginUpdate;\r\n  try\r\n    Clear;\r\n    P := PWideChar(Value);\r\n    while P^ in [WideChar(#1)..WideSpace] do\r\n      Inc(P);\r\n    while P^ <> WideNull do\r\n    begin\r\n      if P^ = '\"' then\r\n        S := WideExtractQuotedStr(P, '\"')\r\n      else\r\n      begin\r\n        P1 := P;\r\n        while (P^ > WideSpace) and (P^ <> ',') do \r\n          Inc(P);\r\n        SetString(S, P1, P - P1);\r\n      end;\r\n      Add(S);\r\n\r\n      while P^ in [WideChar(#1)..WideSpace] do\r\n        Inc(P);\r\n      if P^ = ',' then\r\n      begin\r\n        repeat\r\n          Inc(P);\r\n        until not (P^ in [WideChar(#1)..WideSpace]);\r\n      end;\r\n    end;\r\n  finally\r\n    EndUpdate;\r\n  end;\r\nend;\r\n\r\nprocedure TUnicodeStrings.SetTextStr(const Value: UnicodeString);\r\nvar\r\n  Head,\r\n  Tail: PWideChar;\r\n  S: UnicodeString;\r\nbegin\r\n  BeginUpdate;\r\n  try\r\n    Clear;\r\n    Head := PWideChar(Value);\r\n    while Head^ <> WideNull do\r\n    begin\r\n      Tail := Head;\r\n      while not (Tail^ in [WideNull, WideLineFeed, WideCarriageReturn, WideVerticalTab, WideFormFeed]) and\r\n        (Tail^ <> WideLineSeparator) and (Tail^ <> WideParagraphSeparator) do\r\n        Inc(Tail);\r\n      SetString(S, Head, Tail - Head);\r\n      Add(S);\r\n      Head := Tail;\r\n      if Head^ <> WideNull then\r\n      begin\r\n        Inc(Head);\r\n        if (Tail^ = WideCarriageReturn) and (Head^ = WideLineFeed) then\r\n          Inc(Head);\r\n      end;\r\n    end;\r\n  finally\r\n    EndUpdate;\r\n  end;\r\nend;\r\n\r\nprocedure TUnicodeStrings.SetUpdateState(Updating: Boolean);\r\nbegin\r\nend;\r\n\r\nprocedure TUnicodeStrings.SetValue(const Name, Value: UnicodeString);\r\nvar\r\n  I : Integer;\r\nbegin\r\n  I := IndexOfName(Name);\r\n  if Value <> '' then\r\n  begin\r\n    if I < 0 then\r\n      I := Add('');\r\n    Put(I, Name + '=' + Value);\r\n  end\r\n  else\r\n  begin\r\n    if I >= 0 then\r\n      Delete(I);\r\n  end;\r\nend;\r\n\r\nprocedure TUnicodeStrings.WriteData(Writer: TWriter);\r\nbegin\r\n  Writer.WriteWideString(GetTextStr);\r\nend;\r\n\r\n\r\n{ TUnicodeStringList }\r\n\r\ndestructor TUnicodeStringList.Destroy;\r\nbegin\r\n  FOnChange := nil;\r\n  FOnChanging := nil;\r\n  Clear;\r\n  inherited;\r\nend;\r\n\r\nfunction TUnicodeStringList.Add(const S: UnicodeString): Integer;\r\nbegin\r\n  if not Sorted then\r\n    Result := FCount\r\n  else\r\n  begin\r\n    if Find(S, Result) then\r\n    begin\r\n      case Duplicates of\r\n        dupIgnore:\r\n          Exit;\r\n        dupError:\r\n          Error(SDuplicateString, 0);\r\n      end;\r\n    end;\r\n  end;\r\n  InsertItem(Result, S);\r\nend;\r\n\r\nprocedure TUnicodeStringList.Changed;\r\nbegin\r\n  if (FUpdateCount = 0) and Assigned(FOnChange) then\r\n    FOnChange(Self);\r\nend;\r\n\r\nprocedure TUnicodeStringList.Changing;\r\nbegin\r\n  if (FUpdateCount = 0) and Assigned(FOnChanging) then\r\n    FOnChanging(Self);\r\nend;\r\n\r\nprocedure TUnicodeStringList.Clear;\r\n{$IFDEF OWN_UnicodeString_MEMMGR}\r\nvar\r\n  I: Integer;\r\n{$ENDIF OWN_UnicodeString_MEMMGR}\r\nbegin\r\n  if FCount <> 0 then\r\n  begin\r\n    Changing;\r\n    {$IFDEF OWN_UnicodeString_MEMMGR}\r\n    for I := 0 to FCount - 1 do\r\n      with FList[I] do\r\n        if TDynWideCharArray(FString) <> nil then\r\n          TDynWideCharArray(FString) := nil;\r\n    {$ENDIF OWN_UnicodeString_MEMMGR}\r\n    // this will automatically finalize the array\r\n    FList := nil;\r\n    FCount := 0;\r\n    SetCapacity(0);\r\n    Changed;\r\n  end;\r\nend;\r\n\r\nprocedure TUnicodeStringList.Delete(Index: Integer);\r\nbegin\r\n  if Cardinal(Index) >= Cardinal(FCount) then\r\n    Error(SListIndexError, Index);\r\n  Changing;\r\n\r\n  {$IFDEF OWN_UnicodeString_MEMMGR}\r\n  SetListString(Index, '');\r\n  {$ELSE}\r\n  FList[Index].FString := '';\r\n  {$ENDIF OWN_UnicodeString_MEMMGR}\r\n  Dec(FCount);\r\n  if Index < FCount then\r\n  begin\r\n    System.Move(FList[Index + 1], FList[Index], (FCount - Index) * SizeOf(TUnicodeStringItem));\r\n    Pointer(FList[FCount].FString) := nil; // avoid freeing the string, the address is now used in another element\r\n  end;\r\n  Changed;\r\nend;\r\n\r\nprocedure TUnicodeStringList.Exchange(Index1, Index2: Integer);\r\nbegin\r\n  if Cardinal(Index1) >= Cardinal(FCount) then\r\n    Error(SListIndexError, Index1);\r\n  if Cardinal(Index2) >= Cardinal(FCount) then\r\n    Error(SListIndexError, Index2);\r\n  Changing;\r\n  ExchangeItems(Index1, Index2);\r\n  Changed;\r\nend;\r\n\r\nprocedure TUnicodeStringList.ExchangeItems(Index1, Index2: Integer);\r\nvar\r\n  Temp: TUnicodeStringItem;\r\nbegin\r\n  Temp := FList[Index1];\r\n  FList[Index1] := FList[Index2];\r\n  FList[Index2] := Temp;\r\nend;\r\n\r\nfunction TUnicodeStringList.Find(const S: UnicodeString; var Index: Integer): Boolean;\r\nvar\r\n  L, H, I, C: Integer;\r\nbegin\r\n  Result := False;\r\n  L := 0;\r\n  H := FCount - 1;\r\n  while L <= H do\r\n  begin\r\n    I := (L + H) shr 1;\r\n    C := WideCompareText(FList[I].FString, S);\r\n    if C < 0 then\r\n      L := I+1\r\n    else\r\n    begin\r\n      H := I - 1;\r\n      if C = 0 then\r\n      begin\r\n        Result := True;\r\n        if Duplicates <> dupAccept then\r\n          L := I;\r\n      end;\r\n    end;\r\n  end;\r\n  Index := L;\r\nend;\r\n\r\nfunction TUnicodeStringList.Get(Index: Integer): UnicodeString;\r\n{$IFDEF OWN_UnicodeString_MEMMGR}\r\nvar\r\n  Len: Integer;\r\n{$ENDIF OWN_UnicodeString_MEMMGR}\r\nbegin\r\n  if Cardinal(Index) >= Cardinal(FCount) then\r\n    Error(SListIndexError, Index);\r\n  {$IFDEF OWN_UnicodeString_MEMMGR}\r\n  with FList[Index] do\r\n  begin\r\n    Len := Length(TDynWideCharArray(FString));\r\n    if Len > 0 then\r\n    begin\r\n      SetLength(Result, Len - 1); // exclude #0\r\n      if Result <> '' then\r\n        System.Move(FString^, Result[1], Len * SizeOf(WideChar));\r\n    end\r\n    else\r\n      Result := '';\r\n  end;\r\n  {$ELSE}\r\n  Result := FList[Index].FString;\r\n  {$ENDIF OWN_UnicodeString_MEMMGR}\r\nend;\r\n\r\nfunction TUnicodeStringList.GetCapacity: Integer;\r\nbegin\r\n  Result := Length(FList);\r\nend;\r\n\r\nfunction TUnicodeStringList.GetCount: Integer;\r\nbegin\r\n  Result := FCount;\r\nend;\r\n\r\nfunction TUnicodeStringList.GetObject(Index: Integer): TObject;\r\nbegin\r\n  if Cardinal(Index) >= Cardinal(FCount) then\r\n    Error(SListIndexError, Index);\r\n  Result := FList[Index].FObject;\r\nend;\r\n\r\nprocedure TUnicodeStringList.Grow;\r\nvar\r\n  Delta,\r\n  Len: Integer;\r\nbegin\r\n  Len := Length(FList);\r\n  if Len > 64 then\r\n    Delta := Len div 4\r\n  else\r\n  begin\r\n    if Len > 8 then\r\n      Delta := 16\r\n    else\r\n      Delta := 4;\r\n  end;\r\n  SetCapacity(Len + Delta);\r\nend;\r\n\r\nfunction TUnicodeStringList.IndexOf(const S: UnicodeString): Integer;\r\nbegin\r\n  if not Sorted then\r\n    Result := inherited IndexOf(S)\r\n  else\r\n    if not Find(S, Result) then\r\n      Result := -1;\r\nend;\r\n\r\nprocedure TUnicodeStringList.Insert(Index: Integer; const S: UnicodeString);\r\nbegin\r\n  if Sorted then\r\n    Error(SSortedListError, 0);\r\n  if Cardinal(Index) > Cardinal(FCount) then\r\n    Error(SListIndexError, Index);\r\n  InsertItem(Index, S);\r\nend;\r\n\r\n{$IFDEF OWN_UnicodeString_MEMMGR}\r\nprocedure TUnicodeStringList.SetListString(Index: Integer; const S: UnicodeString);\r\nvar\r\n  Len: Integer;\r\n  A: TDynWideCharArray;\r\nbegin\r\n  with FList[Index] do\r\n  begin\r\n    Pointer(A) := TDynWideCharArray(FString);\r\n    if A <> nil then\r\n      A := nil; // free memory\r\n\r\n    Len := Length(S);\r\n    if Len > 0 then\r\n    begin\r\n      SetLength(A, Len + 1); // include #0\r\n      System.Move(S[1], A[0], Len * SizeOf(WideChar));\r\n      A[Len] := #0;\r\n    end;\r\n\r\n    FString := PWideChar(A);\r\n    Pointer(A) := nil; // do not release the array on procedure exit\r\n  end;\r\nend;\r\n{$ENDIF OWN_UnicodeString_MEMMGR}\r\n\r\nprocedure TUnicodeStringList.InsertItem(Index: Integer; const S: UnicodeString);\r\nbegin\r\n  Changing;\r\n  if FCount = Length(FList) then\r\n    Grow;\r\n  if Index < FCount then\r\n    System.Move(FList[Index], FList[Index + 1], (FCount - Index) * SizeOf(TUnicodeStringItem));\r\n  with FList[Index] do\r\n  begin\r\n    Pointer(FString) := nil; // avoid freeing the string, the address is now used in another element\r\n    FObject := nil;\r\n    {$IFDEF OWN_UnicodeString_MEMMGR}\r\n      SetListString(Index, S);\r\n    {$ELSE}\r\n      FString := S;\r\n    {$ENDIF OWN_UnicodeString_MEMMGR}\r\n  end;\r\n  Inc(FCount);\r\n  Changed;\r\nend;\r\n\r\nprocedure TUnicodeStringList.Put(Index: Integer; const S: UnicodeString);\r\nbegin\r\n  if Sorted then\r\n    Error(SSortedListError, 0);\r\n  if Cardinal(Index) >= Cardinal(FCount) then\r\n    Error(SListIndexError, Index);\r\n  Changing;\r\n\r\n  {$IFDEF OWN_UnicodeString_MEMMGR}\r\n    SetListString(Index, S);\r\n  {$ELSE}\r\n    FList[Index].FString := S;\r\n  {$ENDIF OWN_UnicodeString_MEMMGR}\r\n  Changed;\r\nend;\r\n\r\nprocedure TUnicodeStringList.PutObject(Index: Integer; AObject: TObject);\r\nbegin\r\n  if Cardinal(Index) >= Cardinal(FCount) then\r\n    Error(SListIndexError, Index);\r\n  Changing;\r\n  FList[Index].FObject := AObject;\r\n  Changed;\r\nend;\r\n\r\nprocedure TUnicodeStringList.QuickSort(L, R: Integer);\r\nvar\r\n  I, J: Integer;\r\n  P: UnicodeString;\r\nbegin\r\n  repeat\r\n    I := L;\r\n    J := R;\r\n    P := FList[(L + R) shr 1].FString;\r\n    repeat\r\n      while WideCompareText(FList[I].FString, P) < 0 do\r\n        Inc(I);\r\n      while WideCompareText(FList[J].FString, P) > 0 do\r\n        Dec(J);\r\n      if I <= J then\r\n      begin\r\n        ExchangeItems(I, J);\r\n        Inc(I);\r\n        Dec(J);\r\n      end;\r\n    until I > J;\r\n    if L < J then\r\n      QuickSort(L, J);\r\n    L := I;\r\n  until I >= R;\r\nend;\r\n\r\nprocedure TUnicodeStringList.QuickSort(L, R: Integer; SCompare: TUnicodeStringListSortCompare);\r\nvar\r\n  I, J: Integer;\r\n  P: UnicodeString;\r\nbegin\r\n  repeat\r\n    I := L;\r\n    J := R;\r\n    P := FList[(L + R) shr 1].FString;\r\n    repeat\r\n      while SCompare(FList[I].FString, P) < 0 do\r\n        Inc(I);\r\n      while SCompare(FList[J].FString, P) > 0 do\r\n        Dec(J);\r\n      if I <= J then\r\n      begin\r\n        ExchangeItems(I, J);\r\n        Inc(I);\r\n        Dec(J);\r\n      end;\r\n    until I > J;\r\n    if L < J then\r\n      QuickSort(L, J);\r\n    L := I;\r\n  until I >= R;\r\nend;\r\n\r\nprocedure TUnicodeStringList.CustomSort(Compare: TUnicodeStringListSortCompare);\r\nbegin\r\n  if not Sorted and (FCount > 1) then\r\n  begin\r\n    Changing;\r\n    QuickSort(0, FCount - 1, Compare);\r\n    Changed;\r\n  end;\r\nend;\r\n\r\nprocedure TUnicodeStringList.SetCapacity(NewCapacity: Integer);\r\nbegin\r\n  SetLength(FList, NewCapacity);\r\n  if NewCapacity < FCount then\r\n    FCount := NewCapacity;\r\nend;\r\n\r\nprocedure TUnicodeStringList.SetSorted(Value: Boolean);\r\nbegin\r\n  if FSorted <> Value then\r\n  begin\r\n    if Value then\r\n      Sort;\r\n    FSorted := Value;\r\n  end;\r\nend;\r\n\r\nprocedure TUnicodeStringList.SetUpdateState(Updating: Boolean);\r\nbegin\r\n  if Updating then\r\n    Changing\r\n  else\r\n    Changed;\r\nend;\r\n\r\nprocedure TUnicodeStringList.Sort;\r\nbegin\r\n  if not Sorted and (FCount > 1) then\r\n  begin\r\n    Changing;\r\n    QuickSort(0, FCount - 1);\r\n    Changed;\r\n  end;\r\nend;\r\n{$ENDIF}\r\n\r\nfunction WStrLen(const Str: PWideChar): Cardinal;\r\nasm\r\n        MOV     EDX,EDI\r\n        MOV     EDI,EAX\r\n        MOV     ECX,0FFFFFFFFH\r\n        XOR     AX,AX\r\n        REPNE   SCASW\r\n        MOV     EAX,0FFFFFFFEH\r\n        SUB     EAX,ECX\r\n        MOV     EDI,EDX\r\nend;\r\n\r\nfunction WStrEnd(const Str: PWideChar): PWideChar;\r\nasm\r\n        MOV     EDX,EDI\r\n        MOV     EDI,EAX\r\n        MOV     ECX,0FFFFFFFFH\r\n        XOR     AX,AX\r\n        REPNE   SCASW\r\n        LEA     EAX,[EDI-2]\r\n        MOV     EDI,EDX\r\nend;\r\n\r\nfunction WStrMove(Dest: PWideChar; const Source: PWideChar; Count: Integer): PWideChar;\r\nbegin\r\n  Result := Dest;\r\n  System.Move(Source^, Dest^, Count * SizeOf(WideChar));\r\nend;\r\n\r\nfunction WStrCopy(Dest: PWideChar; const Source: PWideChar): PWideChar;\r\n{$IFDEF SYN_COMPILER_16_UP}\r\nbegin\r\n  Result := SysUtils.StrCopy(Dest, Source)\r\n{$ELSE}\r\nasm\r\n        PUSH    EDI\r\n        PUSH    ESI\r\n        MOV     ESI,EAX\r\n        MOV     EDI,EDX\r\n        MOV     ECX,0FFFFFFFFH\r\n        XOR     AX,AX\r\n        REPNE   SCASW\r\n        NOT     ECX\r\n        MOV     EDI,ESI\r\n        MOV     ESI,EDX\r\n        MOV     EDX,ECX\r\n        MOV     EAX,EDI\r\n        SHR     ECX,1\r\n        REP     MOVSD\r\n        MOV     ECX,EDX\r\n        AND     ECX,1\r\n        REP     MOVSW\r\n        POP     ESI\r\n        POP     EDI\r\n{$ENDIF}\r\nend;\r\n\r\nfunction WStrLCopy(Dest: PWideChar; const Source: PWideChar; MaxLen: Cardinal): PWideChar;\r\n{$IFDEF SYN_COMPILER_16_UP}\r\nbegin\r\n  Result := SysUtils.StrLCopy(Dest, Source, MaxLen)\r\n{$ELSE}\r\nasm\r\n        PUSH    EDI\r\n        PUSH    ESI\r\n        PUSH    EBX\r\n        MOV     ESI,EAX\r\n        MOV     EDI,EDX\r\n        MOV     EBX,ECX\r\n        XOR     AX,AX\r\n        TEST    ECX,ECX\r\n        JZ      @@1\r\n        REPNE   SCASW\r\n        JNE     @@1\r\n        INC     ECX\r\n@@1:    SUB     EBX,ECX\r\n        MOV     EDI,ESI\r\n        MOV     ESI,EDX\r\n        MOV     EDX,EDI\r\n        MOV     ECX,EBX\r\n        SHR     ECX,1\r\n        REP     MOVSD\r\n        MOV     ECX,EBX\r\n        AND     ECX,1\r\n        REP     MOVSW\r\n        STOSW\r\n        MOV     EAX,EDX\r\n        POP     EBX\r\n        POP     ESI\r\n        POP     EDI\r\n{$ENDIF}\r\nend;\r\n\r\nfunction WStrCat(Dest: PWideChar; const Source: PWideChar): PWideChar;\r\nbegin\r\n  WStrCopy(WStrEnd(Dest), Source);\r\n  Result := Dest;\r\nend;\r\n\r\nfunction WStrScan(const Str: PWideChar; Chr: WideChar): PWideChar;\r\nbegin\r\n  Result := Str;\r\n  while Result^ <> Chr do\r\n  begin\r\n    if Result^ = #0 then\r\n    begin\r\n      Result := nil;\r\n      Exit;\r\n    end;\r\n    Inc(Result);\r\n  end;\r\nend;\r\n\r\nfunction WStrAlloc(Size: Cardinal): PWideChar;\r\nbegin\r\n  Size := SizeOf(WideChar) * Size + SizeOf(Cardinal);\r\n  GetMem(Result, Size);\r\n  Cardinal(Pointer(Result)^) := Size;\r\n  Inc(PByte(Result), SizeOf(Cardinal));\r\nend;\r\n\r\nfunction WStrNew(const Str: PWideChar): PWideChar;\r\nvar\r\n  Size: Cardinal;\r\nbegin\r\n  if Str = nil then\r\n    Result := nil\r\n  else\r\n  begin\r\n    Size := WStrLen(Str) + 1;\r\n    Result := WStrMove(WStrAlloc(Size), Str, Size);\r\n  end;\r\nend;\r\n\r\nprocedure WStrDispose(Str: PWideChar);\r\nbegin\r\n  if Str <> nil then\r\n  begin\r\n    Dec(PByte(Str), SizeOf(Cardinal));\r\n    FreeMem(Str, Cardinal(Pointer(Str)^));\r\n  end;\r\nend;\r\n\r\n{$IFNDEF SYN_COMPILER_6_UP}\r\n{$IFDEF SYN_WIN32}\r\nfunction UnicodeToUtf8(Dest: PAnsiChar; MaxDestBytes: Cardinal;\r\n  Source: PWideChar; SourceChars: Cardinal): Cardinal;\r\nvar\r\n  i, count: Cardinal;\r\n  c: Cardinal;\r\nbegin\r\n  Result := 0;\r\n  if Source = nil then Exit;\r\n  count := 0;\r\n  i := 0;\r\n  if Dest <> nil then\r\n  begin\r\n    while (i < SourceChars) and (count < MaxDestBytes) do\r\n    begin\r\n      c := Cardinal(Source[i]);\r\n      Inc(i);\r\n      if c <= $7F then\r\n      begin\r\n        Dest[count] := Char(c);\r\n        Inc(count);\r\n      end\r\n      else if c > $7FF then\r\n      begin\r\n        if count + 3 > MaxDestBytes then\r\n          break;\r\n        Dest[count] := Char($E0 or (c shr 12));\r\n        Dest[count+1] := Char($80 or ((c shr 6) and $3F));\r\n        Dest[count+2] := Char($80 or (c and $3F));\r\n        Inc(count,3);\r\n      end\r\n      else //  $7F < Source[i] <= $7FF\r\n      begin\r\n        if count + 2 > MaxDestBytes then\r\n          break;\r\n        Dest[count] := Char($C0 or (c shr 6));\r\n        Dest[count+1] := Char($80 or (c and $3F));\r\n        Inc(count,2);\r\n      end;\r\n    end;\r\n    if count >= MaxDestBytes then count := MaxDestBytes-1;\r\n    Dest[count] := #0;\r\n  end\r\n  else\r\n  begin\r\n    while i < SourceChars do\r\n    begin\r\n      c := Integer(Source[i]);\r\n      Inc(i);\r\n      if c > $7F then\r\n      begin\r\n        if c > $7FF then\r\n          Inc(count);\r\n        Inc(count);\r\n      end;\r\n      Inc(count);\r\n    end;\r\n  end;\r\n  Result := count+1;  // convert zero based index to byte count\r\nend;\r\n\r\nfunction Utf8ToUnicode(Dest: PWideChar; MaxDestChars: Cardinal;\r\n  Source: PAnsiChar; SourceBytes: Cardinal): Cardinal;\r\nvar\r\n  i, count: Cardinal;\r\n  c: Byte;\r\n  wc: Cardinal;\r\nbegin\r\n  if Source = nil then\r\n  begin\r\n    Result := 0;\r\n    Exit;\r\n  end;\r\n  Result := Cardinal(-1);\r\n  count := 0;\r\n  i := 0;\r\n  if Dest <> nil then\r\n  begin\r\n    while (i < SourceBytes) and (count < MaxDestChars) do\r\n    begin\r\n      wc := Cardinal(Source[i]);\r\n      Inc(i);\r\n      if (wc and $80) <> 0 then\r\n      begin\r\n        if i >= SourceBytes then Exit;          // incomplete multibyte char\r\n        wc := wc and $3F;\r\n        if (wc and $20) <> 0 then\r\n        begin\r\n          c := Byte(Source[i]);\r\n          Inc(i);\r\n          if (c and $C0) <> $80 then Exit;      // malformed trail byte or out of range char\r\n          if i >= SourceBytes then Exit;        // incomplete multibyte char\r\n          wc := (wc shl 6) or (c and $3F);\r\n        end;\r\n        c := Byte(Source[i]);\r\n        Inc(i);\r\n        if (c and $C0) <> $80 then Exit;       // malformed trail byte\r\n\r\n        Dest[count] := WideChar((wc shl 6) or (c and $3F));\r\n      end\r\n      else\r\n        Dest[count] := WideChar(wc);\r\n      Inc(count);\r\n    end;\r\n    if count >= MaxDestChars then count := MaxDestChars-1;\r\n    Dest[count] := #0;\r\n  end\r\n  else\r\n  begin\r\n    while (i < SourceBytes) do\r\n    begin\r\n      c := Byte(Source[i]);\r\n      Inc(i);\r\n      if (c and $80) <> 0 then\r\n      begin\r\n        if i >= SourceBytes then Exit;          // incomplete multibyte char\r\n        c := c and $3F;\r\n        if (c and $20) <> 0 then\r\n        begin\r\n          c := Byte(Source[i]);\r\n          Inc(i);\r\n          if (c and $C0) <> $80 then Exit;      // malformed trail byte or out of range char\r\n          if i >= SourceBytes then Exit;        // incomplete multibyte char\r\n        end;\r\n        c := Byte(Source[i]);\r\n        Inc(i);\r\n        if (c and $C0) <> $80 then Exit;       // malformed trail byte\r\n      end;\r\n      Inc(count);\r\n    end;\r\n  end;\r\n  Result := count+1;\r\nend;\r\n\r\nfunction Utf8Encode(const WS: UnicodeString): UTF8String;\r\nvar\r\n  L: Integer;\r\n  Temp: UTF8String;\r\nbegin\r\n  Result := '';\r\n  if WS = '' then Exit;\r\n  SetLength(Temp, Length(WS) * 3); // SetLength includes space for null terminator\r\n\r\n  L := UnicodeToUtf8(PAnsiChar(Temp), Length(Temp)+1, PWideChar(WS), Length(WS));\r\n  if L > 0 then\r\n    SetLength(Temp, L-1)\r\n  else\r\n    Temp := '';\r\n  Result := Temp;\r\nend;\r\n\r\nfunction Utf8Decode(const S: UTF8String): UnicodeString;\r\nvar\r\n  L: Integer;\r\n  Temp: UnicodeString;\r\nbegin\r\n  Result := '';\r\n  if S = '' then Exit;\r\n  SetLength(Temp, Length(S));\r\n\r\n  L := Utf8ToUnicode(PWideChar(Temp), Length(Temp)+1, PAnsiChar(S), Length(S));\r\n  if L > 0 then\r\n    SetLength(Temp, L-1)\r\n  else\r\n    Temp := '';\r\n  Result := Temp;\r\nend;\r\n\r\nfunction AnsiToUtf8(const S: string): UTF8String;\r\nbegin\r\n  Result := Utf8Encode(S);\r\nend;\r\n\r\nfunction Utf8ToAnsi(const S: UTF8String): string;\r\nbegin\r\n  Result := Utf8Decode(S);\r\nend;\r\n\r\nfunction DumbItDownFor95(const S1, S2: UnicodeString; CmpFlags: Integer): Integer;\r\nvar\r\n  a1, a2: AnsiString;\r\nbegin\r\n  a1 := s1;\r\n  a2 := s2;\r\n  Result := CompareStringA(LOCALE_USER_DEFAULT, CmpFlags, PAnsiChar(a1),\r\n    Length(a1), PAnsiChar(a2), Length(a2)) - 2;\r\nend;\r\n\r\nfunction WideCompareStr(const S1, S2: UnicodeString): Integer;\r\nbegin\r\n  SetLastError(0);\r\n  Result := CompareStringW(LOCALE_USER_DEFAULT, 0, PWideChar(S1), Length(S1),\r\n    PWideChar(S2), Length(S2)) - 2;\r\n  case GetLastError of\r\n    0: ;\r\n    ERROR_CALL_NOT_IMPLEMENTED: Result := DumbItDownFor95(S1, S2, 0);\r\n  else\r\n    RaiseLastWin32Error;\r\n  end;\r\nend;\r\n\r\nfunction WideCompareText(const S1, S2: UnicodeString): Integer;\r\nbegin\r\n  SetLastError(0);\r\n  Result := CompareStringW(LOCALE_USER_DEFAULT, NORM_IGNORECASE, PWideChar(S1),\r\n    Length(S1), PWideChar(S2), Length(S2)) - 2;\r\n  case GetLastError of\r\n    0: ;\r\n    ERROR_CALL_NOT_IMPLEMENTED: Result := DumbItDownFor95(S1, S2, NORM_IGNORECASE);\r\n  else\r\n    RaiseLastWin32Error;\r\n  end;\r\nend;\r\n{$ENDIF}\r\n{$ENDIF}\r\n\r\n{$IFDEF SYN_WIN32}\r\n// The Win9X fix for SynWideUpperCase and SynWideLowerCase was taken\r\n// from Troy Wolbrinks, TntUnicode-package.\r\n\r\nfunction WCharUpper(lpsz: PWideChar): PWideChar;\r\nvar\r\n  AStr: AnsiString;\r\n  WStr: UnicodeString;\r\nbegin\r\n  if Win32PlatformIsUnicode then\r\n    Result := Windows.CharUpperW(lpsz)\r\n  else\r\n  begin\r\n    if HiWord(Cardinal(lpsz)) = 0 then\r\n    begin\r\n      // literal char mode\r\n      Result := lpsz;\r\n      if IsWideCharMappableToAnsi(WideChar(lpsz)) then\r\n      begin\r\n        AStr := AnsiString(WideChar(lpsz)); // single character may be more than one byte\r\n        Windows.CharUpperA(PAnsiChar(AStr));\r\n        WStr := UnicodeString(AStr); // should always be single wide char\r\n        if Length(WStr) = 1 then\r\n          Result := PWideChar(WStr[1]);\r\n      end\r\n    end\r\n    else\r\n    begin\r\n      // null-terminated string mode\r\n      Result := lpsz;\r\n      while lpsz^ <> #0 do\r\n      begin\r\n        {$IFDEF SYN_CLX}\r\n        lpsz^ := WideChar(QSynUnicode.WCharUpper(PWideChar(lpsz^)));\r\n        {$ELSE}\r\n        lpsz^ := WideChar(SynUnicode.WCharUpper(PWideChar(lpsz^)));\r\n        {$ENDIF}\r\n        Inc(lpsz);\r\n      end;\r\n    end;\r\n  end;\r\nend;\r\n\r\nfunction WCharUpperBuff(lpsz: PWideChar; cchLength: DWORD): DWORD;\r\nvar\r\n  i: integer;\r\nbegin\r\n  if Win32PlatformIsUnicode then\r\n    Result := Windows.CharUpperBuffW(lpsz, cchLength)\r\n  else\r\n  begin\r\n    Result := cchLength;\r\n    for i := 1 to cchLength do\r\n    begin\r\n      {$IFDEF SYN_CLX}\r\n      lpsz^ := WideChar(QSynUnicode.WCharUpper(PWideChar(lpsz^)));\r\n      {$ELSE}\r\n      lpsz^ := WideChar(SynUnicode.WCharUpper(PWideChar(lpsz^)));\r\n      {$ENDIF}\r\n      Inc(lpsz);\r\n    end;\r\n  end;\r\nend;\r\n\r\nfunction WCharLower(lpsz: PWideChar): PWideChar;\r\nvar\r\n  AStr: AnsiString;\r\n  WStr: UnicodeString;\r\nbegin\r\n  if Win32PlatformIsUnicode then\r\n    Result := Windows.CharLowerW(lpsz)\r\n  else\r\n  begin\r\n    if HiWord(Cardinal(lpsz)) = 0 then\r\n    begin\r\n      // literal char mode\r\n      Result := lpsz;\r\n      if IsWideCharMappableToAnsi(WideChar(lpsz)) then\r\n      begin\r\n        AStr := AnsiString(WideChar(lpsz)); // single character may be more than one byte\r\n        Windows.CharLowerA(PAnsiChar(AStr));\r\n        WStr := UnicodeString(AStr); // should always be single wide char\r\n        if Length(WStr) = 1 then\r\n          Result := PWideChar(WStr[1]);\r\n      end\r\n    end\r\n    else\r\n    begin\r\n      // null-terminated string mode\r\n      Result := lpsz;\r\n      while lpsz^ <> #0 do\r\n      begin\r\n        {$IFDEF SYN_CLX}\r\n        lpsz^ := WideChar(QSynUnicode.WCharLower(PWideChar(lpsz^)));\r\n        {$ELSE}\r\n        lpsz^ := WideChar(SynUnicode.WCharLower(PWideChar(lpsz^)));\r\n        {$ENDIF}\r\n        Inc(lpsz);\r\n      end;\r\n    end;\r\n  end;\r\nend;\r\n\r\nfunction WCharLowerBuff(lpsz: PWideChar; cchLength: DWORD): DWORD;\r\nvar\r\n  i: integer;\r\nbegin\r\n  if Win32PlatformIsUnicode then\r\n    Result := Windows.CharLowerBuffW(lpsz, cchLength)\r\n  else\r\n  begin\r\n    Result := cchLength;\r\n    for i := 1 to cchLength do\r\n    begin\r\n      {$IFDEF SYN_CLX}\r\n      lpsz^ := WideChar(QSynUnicode.WCharLower(PWideChar(lpsz^)));\r\n      {$ELSE}\r\n      lpsz^ := WideChar(SynUnicode.WCharLower(PWideChar(lpsz^)));\r\n      {$ENDIF}\r\n      Inc(lpsz);\r\n    end;\r\n  end;\r\nend;\r\n\r\nfunction SynWideUpperCase(const S: UnicodeString): UnicodeString;\r\nvar\r\n  Len: Integer;\r\nbegin\r\n  Len := Length(S);\r\n  SetString(Result, PWideChar(S), Len);\r\n  if Len > 0 then\r\n    {$IFDEF SYN_CLX} QSynUnicode. {$ELSE} SynUnicode. {$ENDIF}\r\n    WCharUpperBuff(Pointer(Result), Len);\r\nend;\r\n\r\nfunction SynWideLowerCase(const S: UnicodeString): UnicodeString;\r\nvar\r\n  Len: Integer;\r\nbegin\r\n  Len := Length(S);\r\n  SetString(Result, PWideChar(S), Len);\r\n  if Len > 0 then\r\n    {$IFDEF SYN_CLX} QSynUnicode. {$ELSE} SynUnicode. {$ENDIF}\r\n    WCharLowerBuff(Pointer(Result), Len);\r\nend;\r\n{$ELSE}\r\nfunction SynWideUpperCase(const S: UnicodeString): UnicodeString;\r\nbegin\r\n  Result := WideUpperCase(S);\r\nend;\r\n\r\nfunction SynWideLowerCase(const S: UnicodeString): UnicodeString;\r\nbegin\r\n  Result := WideLowerCase(S);\r\nend;\r\n{$ENDIF}\r\n\r\n{$IFDEF SYN_WIN32}\r\nfunction SynIsCharAlpha(const C: WideChar): Boolean;\r\nbegin\r\n  if Win32PlatformIsUnicode then\r\n    Result := IsCharAlphaW(C)\r\n  else\r\n    // returns false if C is not mappable to ANSI\r\n    Result := IsCharAlphaA(AnsiChar(C));\r\nend;\r\n\r\nfunction SynIsCharAlphaNumeric(const C: WideChar): Boolean;\r\nbegin\r\n  if Win32PlatformIsUnicode then\r\n    Result := IsCharAlphaNumericW(C)\r\n  else\r\n    // returns false if C is not mappable to ANSI\r\n    Result := IsCharAlphaNumericA(AnsiChar(C));\r\nend;\r\n{$ELSE}\r\nfunction SynIsCharAlpha(const C: WideChar): Boolean;\r\nbegin\r\n  Result := IsAlpha(Integer(ch)) <> 0;\r\nend;\r\n\r\nfunction SynIsCharAlphaNumeric(const C: WideChar): Boolean;\r\nbegin\r\n  Result := IsAlNum(Integer(ch)) <> 0;\r\nend;\r\n{$ENDIF}\r\n\r\n{$IFNDEF UNICODE}\r\nfunction CharInSet(C: AnsiChar; const CharSet: TSysCharSet): Boolean;\r\nbegin\r\n  Result := C in CharSet;\r\nend;\r\n\r\nfunction CharInSet(C: WideChar; const CharSet: TSysCharSet): Boolean;\r\nbegin\r\n  Result := (C < #$0100) and (AnsiChar(C) in CharSet);\r\nend;\r\n{$ENDIF}\r\n\r\nfunction WideLastDelimiter(const Delimiters, S: UnicodeString): Integer;\r\nvar\r\n  P: PWideChar;\r\nbegin\r\n  Result := Length(S);\r\n  P := PWideChar(Delimiters);\r\n  while Result > 0 do\r\n  begin\r\n    if (S[Result] <> #0) and (WStrScan(P, S[Result]) <> nil) then\r\n      Exit;\r\n    Dec(Result);\r\n  end;\r\nend;\r\n\r\nfunction UnicodeStringReplace(const S, OldPattern, NewPattern: UnicodeString;\r\n  Flags: TReplaceFlags): UnicodeString;\r\nvar\r\n  SearchStr, Patt, NewStr: UnicodeString;\r\n  Offset: Integer;\r\nbegin\r\n  if rfIgnoreCase in Flags then\r\n  begin\r\n    SearchStr := SynWideUpperCase(S);\r\n    Patt := SynWideUpperCase(OldPattern);\r\n  end\r\n  else\r\n  begin\r\n    SearchStr := S;\r\n    Patt := OldPattern;\r\n  end;\r\n  NewStr := S;\r\n  Result := '';\r\n  while SearchStr <> '' do\r\n  begin\r\n    Offset := Pos(Patt, SearchStr);\r\n    if Offset = 0 then\r\n    begin\r\n      Result := Result + NewStr;\r\n      Break;\r\n    end;\r\n    Result := Result + Copy(NewStr, 1, Offset - 1) + NewPattern;\r\n    NewStr := Copy(NewStr, Offset + Length(OldPattern), MaxInt);\r\n    if not (rfReplaceAll in Flags) then\r\n    begin\r\n      Result := Result + NewStr;\r\n      Break;\r\n    end;\r\n    SearchStr := Copy(SearchStr, Offset + Length(Patt), MaxInt);\r\n  end;\r\nend;\r\n\r\nconst\r\n  // data used to bring UTF-16 coded strings into correct UTF-32 order for correct comparation\r\n  UTF16Fixup: array[0..31] of Word = (\r\n    0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,\r\n    0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,\r\n    $2000, $F800, $F800, $F800, $F800\r\n  );\r\n\r\n// Binary comparation of Str1 and Str2 with surrogate fix-up.\r\n// Returns < 0 if Str1 is smaller in binary order than Str2, = 0 if both strings are\r\n// equal and > 0 if Str1 is larger than Str2.\r\n//\r\n// This code is based on an idea of Markus W. Scherer (IBM).\r\n// Note: The surrogate fix-up is necessary because some single value code points have\r\n//       larger values than surrogates which are in UTF-32 actually larger.\r\nfunction WStrComp(Str1, Str2: PWideChar): Integer;\r\nvar\r\n  C1, C2: Word;\r\n  Run1, Run2: PWideChar;\r\nbegin\r\n  Run1 := Str1;\r\n  Run2 := Str2;\r\n  repeat\r\n    C1 := Word(Run1^);\r\n    C1 := Word(C1 + UTF16Fixup[C1 shr 11]);\r\n    C2 := Word(Run2^);\r\n    C2 := Word(C2 + UTF16Fixup[C2 shr 11]);\r\n\r\n    // now C1 and C2 are in UTF-32-compatible order\r\n    Result := Integer(C1) - Integer(C2);\r\n    if(Result <> 0) or (C1 = 0) or (C2 = 0) then\r\n      Break;\r\n    Inc(Run1);\r\n    Inc(Run2);\r\n  until False;\r\n\r\n  // If the strings have different lengths but the comparation returned equity so far\r\n  // then adjust the result so that the longer string is marked as the larger one.\r\n  if Result = 0 then\r\n    Result := (Run1 - Str1) - (Run2 - Str2);\r\nend;\r\n\r\n// compares strings up to MaxLen code points\r\n// see also StrCompW\r\nfunction WStrLComp(Str1, Str2: PWideChar; MaxLen: Cardinal): Integer;\r\nvar\r\n  C1, C2: Word;\r\nbegin\r\n  if MaxLen > 0 then\r\n  begin\r\n    repeat\r\n      C1 := Word(Str1^);\r\n      C1 := Word(C1 + UTF16Fixup[C1 shr 11]);\r\n      C2 := Word(Str2^);\r\n      C2 := Word(C2 + UTF16Fixup[C2 shr 11]);\r\n\r\n      // now C1 and C2 are in UTF-32-compatible order\r\n      { TODO : surrogates take up 2 words and are counted twice here, count them only once }\r\n      Result := Integer(C1) - Integer(C2);\r\n      Dec(MaxLen);\r\n      if(Result <> 0) or (C1 = 0) or (C2 = 0) or (MaxLen = 0) then\r\n        Break;\r\n      Inc(Str1);\r\n      Inc(Str2);\r\n    until False;\r\n  end\r\n  else\r\n    Result := 0;\r\nend;\r\n\r\n// exchanges in each character of the given string the low order and high order\r\n// byte to go from LSB to MSB and vice versa.\r\n// EAX contains address of string\r\nprocedure StrSwapByteOrder(Str: PWideChar);\r\n{$IFDEF SYN_COMPILER_16_UP}\r\nvar\r\n  P: PWord;\r\nbegin\r\n  P := PWord(Str);\r\n  while P^ <> 0 do \r\n  begin\r\n    P^ := MakeWord(HiByte(P^), LoByte(P^));\r\n    Inc(P);\r\n  end;\r\n{$ELSE}\r\nasm\r\n       PUSH    ESI\r\n       PUSH    EDI\r\n       MOV     ESI, EAX\r\n       MOV     EDI, ESI\r\n       XOR     EAX, EAX // clear high order byte to be able to use 32bit operand below\r\n@@1:\r\n       LODSW\r\n       OR      EAX, EAX\r\n       JZ      @@2\r\n       XCHG    AL, AH\r\n       STOSW\r\n       JMP     @@1\r\n\r\n\r\n@@2:\r\n       POP     EDI\r\n       POP     ESI\r\n{$ENDIF}\r\nend;\r\n\r\n// works like QuotedStr from SysUtils.pas but can insert any quotation character\r\nfunction WideQuotedStr(const S: UnicodeString; Quote: WideChar): UnicodeString;\r\nvar\r\n  P, Src,\r\n  Dest: PWideChar;\r\n  AddCount: Integer;\r\nbegin\r\n  AddCount := 0;\r\n  P := WStrScan(PWideChar(S), Quote);\r\n  while (P <> nil) do\r\n  begin\r\n    Inc(P);\r\n    Inc(AddCount);\r\n    P := WStrScan(P, Quote);\r\n  end;\r\n\r\n  if AddCount = 0 then\r\n    Result := Quote + S + Quote\r\n  else\r\n  begin\r\n    SetLength(Result, Length(S) + AddCount + 2);\r\n    Dest := PWideChar(Result);\r\n    Dest^ := Quote;\r\n    Inc(Dest);\r\n    Src := PWideChar(S);\r\n    P := WStrScan(Src, Quote);\r\n    repeat\r\n      Inc(P);\r\n      Move(Src^, Dest^, 2 * (P - Src));\r\n      Inc(Dest, P - Src);\r\n      Dest^ := Quote;\r\n      Inc(Dest);\r\n      Src := P;\r\n      P := WStrScan(Src, Quote);\r\n    until P = nil;\r\n    P := WStrEnd(Src);\r\n    Move(Src^, Dest^, 2 * (P - Src));\r\n    Inc(Dest, P - Src);\r\n    Dest^ := Quote;\r\n  end;\r\nend;\r\n\r\n// extracts a string enclosed in quote characters given by Quote\r\nfunction WideExtractQuotedStr(var Src: PWideChar; Quote: WideChar): UnicodeString;\r\nvar\r\n  P, Dest: PWideChar;\r\n  DropCount: Integer;\r\nbegin\r\n  Result := '';\r\n  if (Src = nil) or (Src^ <> Quote) then\r\n    Exit;\r\n\r\n  Inc(Src);\r\n  DropCount := 1;\r\n  P := Src;\r\n  Src := WStrScan(Src, Quote);\r\n\r\n  while Src <> nil do   // count adjacent pairs of quote chars\r\n  begin\r\n    Inc(Src);\r\n    if Src^ <> Quote then\r\n      Break;\r\n    Inc(Src);\r\n    Inc(DropCount);\r\n    Src := WStrScan(Src, Quote);\r\n  end;\r\n\r\n  if Src = nil then\r\n    Src := WStrEnd(P);\r\n  if (Src - P) <= 1 then\r\n    Exit;\r\n\r\n  if DropCount = 1 then\r\n    SetString(Result, P, Src - P - 1)\r\n  else\r\n  begin\r\n    SetLength(Result, Src - P - DropCount);\r\n    Dest := PWideChar(Result);\r\n    Src := WStrScan(P, Quote);\r\n    while Src <> nil do\r\n    begin\r\n      Inc(Src);\r\n      if Src^ <> Quote then\r\n        Break;\r\n      Move(P^, Dest^, 2 * (Src - P));\r\n      Inc(Dest, Src - P);\r\n      Inc(Src);\r\n      P := Src;\r\n      Src := WStrScan(Src, Quote);\r\n    end;\r\n    if Src = nil then\r\n      Src := WStrEnd(P);\r\n    Move(P^, Dest^, 2 * (Src - P - 1));\r\n  end;\r\nend;\r\n\r\n// returns a string of Count characters filled with C\r\nfunction UnicodeStringOfChar(C: WideChar; Count: Cardinal): UnicodeString;\r\nvar\r\n  I: Integer;\r\nbegin\r\n  SetLength(Result, Count);\r\n  for I := 1 to Count do\r\n    Result[I] := C;\r\nend;\r\n\r\nfunction WideTrim(const S: UnicodeString): UnicodeString;\r\nvar\r\n  I, L: Integer;\r\nbegin\r\n  L := Length(S);\r\n  I := 1;\r\n  while (I <= L) and (S[I] <= ' ') do Inc(I);\r\n  if I > L then\r\n    Result := ''\r\n  else\r\n  begin\r\n    while S[L] <= ' ' do Dec(L);\r\n    Result := Copy(S, I, L - I + 1);\r\n  end;\r\nend;\r\n\r\nfunction WideTrimLeft(const S: UnicodeString): UnicodeString;\r\nvar\r\n  I, L: Integer;\r\nbegin\r\n  L := Length(S);\r\n  I := 1;\r\n  while (I <= L) and (S[I] <= ' ') do Inc(I);\r\n  Result := Copy(S, I, Maxint);\r\nend;\r\n\r\nfunction WideTrimRight(const S: UnicodeString): UnicodeString;\r\nvar\r\n  I: Integer;\r\nbegin\r\n  I := Length(S);\r\n  while (I > 0) and (S[I] <= ' ') do Dec(I);\r\n  Result := Copy(S, 1, I);\r\nend;\r\n\r\n{$IFDEF SYN_WIN32}\r\nfunction TranslateCharsetInfoEx(lpSrc: PDWORD; var lpCs: TCharsetInfo; dwFlags: DWORD): BOOL; stdcall;\r\n  external 'gdi32.dll' name 'TranslateCharsetInfo';\r\n\r\nfunction CharSetFromLocale(Language: LCID): TFontCharSet;\r\nvar\r\n  CP: Cardinal;\r\n  CSI: TCharsetInfo;\r\nbegin\r\n  CP:= CodePageFromLocale(Language);\r\n  TranslateCharsetInfoEx(Pointer(CP), CSI, TCI_SRCCODEPAGE);\r\n  Result:= CSI.ciCharset;\r\nend;\r\n\r\n// determines the code page for a given locale\r\nfunction CodePageFromLocale(Language: LCID): Integer;\r\nvar\r\n  Buf: array[0..6] of Char;\r\nbegin\r\n  GetLocaleInfo(Language, LOCALE_IDefaultAnsiCodePage, Buf, 6);\r\n  Result := StrToIntDef(Buf, GetACP);\r\nend;\r\n\r\nfunction KeyboardCodePage: Word;\r\nbegin\r\n  Result := CodePageFromLocale(GetKeyboardLayout(0) and $FFFF);\r\nend;\r\n\r\n// converts the given character (as it comes with a WM_CHAR message) into its\r\n// corresponding Unicode character depending on the active keyboard layout\r\nfunction KeyUnicode(C: AnsiChar): WideChar;\r\nbegin\r\n  MultiByteToWideChar(KeyboardCodePage, MB_USEGLYPHCHARS, @C, 1, @Result, 1);\r\nend;\r\n\r\nfunction StringToUnicodeStringEx(const S: AnsiString; CodePage: Word): UnicodeString;\r\nvar\r\n  InputLength,\r\n  OutputLength: Integer;\r\nbegin\r\n  InputLength := Length(S);\r\n  OutputLength := MultiByteToWideChar(CodePage, 0, PAnsiChar(S), InputLength,\r\n    nil, 0);\r\n  SetLength(Result, OutputLength);\r\n  MultiByteToWideChar(CodePage, 0, PAnsiChar(S), InputLength, PWideChar(Result),\r\n    OutputLength);\r\nend;\r\n\r\nfunction UnicodeStringToStringEx(const WS: UnicodeString; CodePage: Word): AnsiString;\r\nvar\r\n  InputLength,\r\n  OutputLength: Integer;\r\nbegin\r\n  InputLength := Length(WS);\r\n  OutputLength := WideCharToMultiByte(CodePage, 0, PWideChar(WS), InputLength,\r\n    nil, 0, nil, nil);\r\n  SetLength(Result, OutputLength);\r\n  WideCharToMultiByte(CodePage, 0, PWideChar(WS), InputLength, PAnsiChar(Result),\r\n    OutputLength, nil, nil);\r\nend;\r\n{$ENDIF}\r\n\r\nfunction GetTextSize(DC: HDC; Str: PWideChar; Count: Integer): TSize;\r\n{$IFDEF SYN_UNISCRIBE}\r\nconst\r\n  SSAnalyseFlags = SSA_GLYPHS or SSA_FALLBACK or SSA_LINK;\r\n{$ENDIF}\r\nvar\r\n  tm: TTextMetricA;\r\n  {$IFDEF SYN_UNISCRIBE}\r\n  GlyphBufferSize: Integer;\r\n  saa: TScriptStringAnalysis;\r\n  lpSize: PSize;\r\n  {$ENDIF}\r\nbegin\r\n  Result.cx := 0;\r\n  Result.cy := 0;\r\n\r\n{$IFDEF SYN_UNISCRIBE}\r\n  if Usp10IsInstalled then\r\n  begin\r\n    if Count <= 0 then Exit;\r\n\r\n    // According to the MS Windows SDK (1.5 * Count + 16) is the recommended\r\n    // value for GlyphBufferSize (see documentation of cGlyphs parameter of\r\n    // ScriptStringAnalyse function)\r\n    GlyphBufferSize := (3 * Count) div 2 + 16;\r\n    \r\n    if Succeeded(ScriptStringAnalyse(DC, Str, Count, GlyphBufferSize, -1,\r\n      SSAnalyseFlags, 0, nil, nil, nil, nil, nil, @saa)) then\r\n    begin\r\n      lpSize := ScriptString_pSize(saa);\r\n      if lpSize <> nil then\r\n      begin\r\n        Result := lpSize^;\r\n        if Result.cx = 0 then\r\n        begin\r\n          GetTextMetricsA(DC, tm);\r\n          Result.cx := tm.tmAveCharWidth;\r\n        end;\r\n      end;\r\n      ScriptStringFree(@saa);\r\n    end;\r\n  end\r\n  else\r\n{$ENDIF}\r\n  begin\r\n    GetTextExtentPoint32W(DC, Str, Count, Result);\r\n    if not Win32PlatformIsUnicode then\r\n    begin\r\n      GetTextMetricsA(DC, tm);\r\n      if tm.tmPitchAndFamily and TMPF_TRUETYPE <> 0 then\r\n        Result.cx := Result.cx - tm.tmOverhang\r\n      else\r\n        Result.cx := tm.tmAveCharWidth * Count;\r\n    end;\r\n  end;\r\nend;\r\n\r\ntype\r\n  TAccessCanvas = class(TCanvas)\r\n  end;\r\n\r\nfunction TextExtent(ACanvas: TCanvas; const Text: UnicodeString): TSize;\r\nbegin\r\n{$IFDEF SYN_CLX}\r\n  Result := ACanvas.TextExtent(Text);\r\n{$ELSE}\r\n  with TAccessCanvas(ACanvas) do\r\n  begin\r\n    RequiredState([csHandleValid, csFontValid]);\r\n    Result := GetTextSize(Handle, PWideChar(Text), Length(Text));\r\n  end;\r\n{$ENDIF}\r\nend;\r\n\r\nfunction TextWidth(ACanvas: TCanvas; const Text: UnicodeString): Integer;\r\nbegin\r\n{$IFDEF SYN_CLX}\r\n  Result := ACanvas.TextExtent(Text).cX;\r\n{$ELSE}\r\n  Result := TextExtent(ACanvas, Text).cX;\r\n{$ENDIF}\r\nend;\r\n\r\nfunction TextHeight(ACanvas: TCanvas; const Text: UnicodeString): Integer;\r\nbegin\r\n{$IFDEF SYN_CLX}\r\n  Result := ACanvas.TextExtent(Text).cY;\r\n{$ELSE}\r\n  Result := TextExtent(ACanvas, Text).cY;\r\n{$ENDIF}\r\nend;\r\n\r\nprocedure TextOut(ACanvas: TCanvas; X, Y: Integer; const Text: UnicodeString);\r\nbegin\r\n{$IFDEF SYN_CLX}\r\n  ACanvas.TextOut(X, Y, Text);\r\n{$ELSE}\r\n  with TAccessCanvas(ACanvas) do\r\n  begin\r\n    Changing;\r\n    RequiredState([csHandleValid, csFontValid, csBrushValid]);\r\n    if CanvasOrientation = coRightToLeft then\r\n      Inc(X, SynUnicode.TextWidth(ACanvas, Text) + 1);\r\n    Windows.ExtTextOutW(Handle, X, Y, TextFlags, nil, PWideChar(Text),\r\n     Length(Text), nil);\r\n    MoveTo(X + SynUnicode.TextWidth(ACanvas, Text), Y);\r\n    Changed;\r\n  end;\r\n{$ENDIF}\r\nend;\r\n\r\nprocedure TextRect(ACanvas: TCanvas; Rect: TRect; X, Y: Integer;\r\n  const Text: UnicodeString);\r\n{$IFNDEF SYN_CLX}\r\nvar\r\n  Options: Longint;\r\n{$ENDIF}\r\nbegin\r\n{$IFDEF SYN_CLX}\r\n  ACanvas.TextRect(Rect, X, Y, Text);\r\n{$ELSE}\r\n  with TAccessCanvas(ACanvas) do\r\n  begin\r\n    Changing;\r\n    RequiredState([csHandleValid, csFontValid, csBrushValid]);\r\n    Options := ETO_CLIPPED or TextFlags;\r\n    if Brush.Style <> bsClear then\r\n      Options := Options or ETO_OPAQUE;\r\n    if ((TextFlags and ETO_RTLREADING) <> 0) and\r\n       (CanvasOrientation = coRightToLeft)\r\n    then\r\n      Inc(X, SynUnicode.TextWidth(ACanvas, Text) + 1);\r\n    Windows.ExtTextOutW(Handle, X, Y, Options, @Rect, PWideChar(Text),\r\n      Length(Text), nil);\r\n    Changed;\r\n  end;\r\n{$ENDIF}\r\nend;\r\n\r\n{$IFNDEF UNICODE}\r\n{ TWideFileStream }\r\n\r\nconstructor TWideFileStream.Create(const FileName: UnicodeString; Mode: Word);\r\nbegin\r\n{$IFDEF SYN_WIN32}\r\n  Create(Filename, Mode, 0);\r\n{$ELSE}\r\n  Create(Filename, Mode, FileAccessRights);\r\n{$ENDIF}\r\nend;\r\n\r\nconstructor TWideFileStream.Create(const FileName: UnicodeString; Mode: Word;\r\n  Rights: Cardinal);\r\n{$IFDEF USE_TNT_RUNTIME_SUPPORT}\r\nvar\r\n  ErrorMessage: UnicodeString;\r\n{$ENDIF}\r\nbegin\r\n  if ((Mode and fmCreate) = fmCreate) then\r\n  begin\r\n    inherited Create(WideFileCreate(FileName, Rights));\r\n    if Handle < 0 then\r\n    begin\r\n{$IFDEF USE_TNT_RUNTIME_SUPPORT}\r\n  {$IFDEF SYN_COMPILER_7_UP}\r\n      ErrorMessage := WideSysErrorMessage(GetLastError);\r\n      raise EWideFCreateError.CreateResFmt(PResStringRec(@SFCreateErrorEx),\r\n        [WideExpandFileName(FileName), ErrorMessage]);\r\n  {$ELSE}\r\n      raise EWideFCreateError.CreateResFmt(@SFCreateError, [FileName]);\r\n  {$ENDIF}\r\n{$ELSE}\r\n  {$IFDEF SYN_COMPILER_7_UP}\r\n      raise EFCreateError.CreateResFmt(PResStringRec(@SFCreateErrorEx),\r\n        [ExpandFileName(FileName), SysErrorMessage(GetLastError)]);\r\n  {$ELSE}\r\n      raise EFCreateError.CreateResFmt(PResStringRec(@SFCreateError), [FileName]);\r\n  {$ENDIF}\r\n{$ENDIF}\r\n    end\r\n  end\r\n  else\r\n  begin\r\n    inherited Create(WideFileOpen(FileName, Mode));\r\n    if Handle < 0 then\r\n    begin\r\n{$IFDEF USE_TNT_RUNTIME_SUPPORT}\r\n  {$IFDEF SYN_COMPILER_7_UP}\r\n      ErrorMessage := WideSysErrorMessage(GetLastError);\r\n      raise EWideFOpenError.CreateResFmt(PResStringRec(@SFOpenErrorEx),\r\n        [WideExpandFileName(FileName), ErrorMessage]);\r\n  {$ELSE}\r\n      raise EWideFOpenError.CreateResFmt(@SFOpenError, [FileName]);\r\n  {$ENDIF}\r\n{$ELSE}\r\n  {$IFDEF SYN_COMPILER_7_UP}\r\n      raise EFOpenError.CreateResFmt(PResStringRec(@SFOpenErrorEx),\r\n        [ExpandFileName(FileName), SysErrorMessage(GetLastError)]);\r\n  {$ELSE}\r\n      raise EFOpenError.CreateResFmt(PResStringRec(@SFOpenError), [FileName]);\r\n  {$ENDIF}\r\n{$ENDIF}\r\n    end;\r\n  end;\r\nend;\r\n\r\ndestructor TWideFileStream.Destroy;\r\nbegin\r\n  if Handle >= 0 then FileClose(Handle);\r\n  inherited Destroy;\r\nend;\r\n\r\nfunction WideFileOpen(const FileName: UnicodeString; Mode: LongWord): Integer;\r\n{$IFDEF SYN_WIN32}\r\nconst\r\n  AccessMode: array[0..2] of LongWord = (\r\n    GENERIC_READ,\r\n    GENERIC_WRITE,\r\n    GENERIC_READ or GENERIC_WRITE);\r\n  ShareMode: array[0..4] of LongWord = (\r\n    0,\r\n    0,\r\n    FILE_SHARE_READ,\r\n    FILE_SHARE_WRITE,\r\n    FILE_SHARE_READ or FILE_SHARE_WRITE);\r\nbegin\r\n  Result := -1;\r\n  if ((Mode and 3) <= fmOpenReadWrite) and\r\n    ((Mode and $F0) <= fmShareDenyNone) then\r\n  begin\r\n    if Win32PlatformIsUnicode then\r\n      Result := Integer(CreateFileW(PWideChar(FileName), AccessMode[Mode and 3],\r\n        ShareMode[(Mode and $F0) shr 4], nil, OPEN_EXISTING,\r\n        FILE_ATTRIBUTE_NORMAL, 0))\r\n    else\r\n      Result := Integer(CreateFileA(PAnsiChar(AnsiString(FileName)), AccessMode[Mode and 3],\r\n        ShareMode[(Mode and $F0) shr 4], nil, OPEN_EXISTING,\r\n        FILE_ATTRIBUTE_NORMAL, 0));\r\n  end;\r\nend;\r\n{$ENDIF}\r\n{$IFDEF SYN_LINUX}\r\nconst\r\n  ShareMode: array[0..fmShareDenyNone shr 4] of Byte = (\r\n    0,        //No share mode specified\r\n    F_WRLCK,  //fmShareExclusive\r\n    F_RDLCK,  //fmShareDenyWrite\r\n    0);       //fmShareDenyNone\r\nvar\r\n  FileHandle, Tvar: Integer;\r\n  LockVar: TFlock;\r\n  smode: Byte;\r\nbegin\r\n  Result := -1;\r\n  if FileExists(FileName) and\r\n     ((Mode and 3) <= fmOpenReadWrite) and\r\n     ((Mode and $F0) <= fmShareDenyNone) then\r\n  begin\r\n    FileHandle := open(PChar(AnsiString(FileName)), (Mode and 3), FileAccessRights);\r\n\r\n    if FileHandle = -1 then  Exit;\r\n\r\n    smode := Mode and $F0 shr 4;\r\n    if ShareMode[smode] <> 0 then\r\n    begin\r\n      with LockVar do\r\n      begin\r\n        l_whence := SEEK_SET;\r\n        l_start := 0;\r\n        l_len := 0;\r\n        l_type := ShareMode[smode];\r\n      end;\r\n      Tvar :=  fcntl(FileHandle, F_SETLK, LockVar);\r\n      if Tvar = -1 then\r\n      begin\r\n        __close(FileHandle);\r\n        Exit;\r\n      end;\r\n    end;\r\n    Result := FileHandle;\r\n  end;\r\nend;\r\n{$ENDIF}\r\n\r\nfunction WideFileCreate(const FileName: UnicodeString): Integer;\r\n{$IFDEF SYN_WIN32}\r\nbegin\r\n  if Win32PlatformIsUnicode then\r\n    Result := Integer(CreateFileW(PWideChar(FileName), GENERIC_READ or GENERIC_WRITE,\r\n      0, nil, CREATE_ALWAYS, FILE_ATTRIBUTE_NORMAL, 0))\r\n  else\r\n    Result := Integer(CreateFileA(PAnsiChar(AnsiString(FileName)), GENERIC_READ or GENERIC_WRITE,\r\n      0, nil, CREATE_ALWAYS, FILE_ATTRIBUTE_NORMAL, 0));\r\nend;\r\n{$ENDIF}\r\n{$IFDEF SYN_LINUX}\r\nbegin\r\n  Result := FileCreate(FileName, FileAccessRights);\r\nend;\r\n{$ENDIF}\r\n\r\nfunction WideFileCreate(const FileName: UnicodeString; Rights: Integer): Integer;\r\n{$IFDEF SYN_WIN32}\r\nbegin\r\n  Result := WideFileCreate(FileName);\r\nend;\r\n{$ENDIF}\r\n{$IFDEF SYN_LINUX}\r\nbegin\r\n  Result := Integer(open(PChar(AnsiString(FileName)), O_RDWR or O_CREAT or O_TRUNC, Rights));\r\nend;\r\n{$ENDIF}\r\n{$ENDIF}\r\n\r\nfunction IsAnsiOnly(const WS: UnicodeString): Boolean;\r\n{$IFDEF SYN_WIN32}\r\nbegin\r\n  Result := IsUnicodeStringMappableToAnsi(WS);\r\nend;\r\n{$ELSE}\r\nvar\r\n  Run: PWideChar;\r\nbegin\r\n  Run := PWideChar(WS);\r\n  while Run^ in [WideChar(#1)..WideChar(#255)] do\r\n    Inc(Run);\r\n  Result := Run^ = WideNull;\r\nend;\r\n{$ENDIF}\r\n\r\nfunction IsUTF8(const FileName: UnicodeString; out WithBOM: Boolean): Boolean;\r\nvar\r\n  Stream: TStream;\r\nbegin\r\n  Stream := TWideFileStream.Create(FileName, fmOpenRead or fmShareDenyWrite);\r\n  try\r\n    Result := IsUTF8(Stream, WithBOM);\r\n  finally\r\n    Stream.Free;\r\n  end;\r\nend;\r\n\r\n// checks for a BOM in UTF-8 format or searches the first 4096 bytes for\r\n// typical UTF-8 octet sequences\r\nfunction IsUTF8(Stream: TStream; out WithBOM: Boolean): Boolean;\r\nconst\r\n  MinimumCountOfUTF8Strings = 1;\r\n  MaxBufferSize = $4000;\r\nvar\r\n  Buffer: array of Byte;\r\n  BufferSize, i, FoundUTF8Strings: Integer;\r\n\r\n  // 3 trailing bytes are the maximum in valid UTF-8 streams,\r\n  // so a count of 4 trailing bytes is enough to detect invalid UTF-8 streams\r\n  function CountOfTrailingBytes: Integer;\r\n  begin\r\n    Result := 0;\r\n    inc(i);\r\n    while (i < BufferSize) and (Result < 4) do\r\n    begin\r\n      if Buffer[i] in [$80..$BF] then\r\n        inc(Result)\r\n      else\r\n        Break;\r\n      inc(i);\r\n    end;\r\n  end;\r\n\r\nbegin\r\n  // if Stream is nil, let Delphi raise the exception, by accessing Stream,\r\n  // to signal an invalid result\r\n\r\n  // start analysis at actual Stream.Position\r\n  BufferSize := Min(MaxBufferSize, Stream.Size - Stream.Position);\r\n\r\n  // if no special characteristics are found it is not UTF-8\r\n  Result := False;\r\n  WithBOM := False;\r\n\r\n  if BufferSize > 0 then\r\n  begin\r\n    SetLength(Buffer, BufferSize);\r\n    Stream.ReadBuffer(Buffer[0], BufferSize);\r\n    Stream.Seek(-BufferSize, soFromCurrent);\r\n\r\n    { first search for BOM }\r\n\r\n    if (BufferSize >= Length(UTF8BOM)) and CompareMem(@Buffer[0], @UTF8BOM[0], Length(UTF8BOM)) then\r\n    begin\r\n      WithBOM := True;\r\n      Result := True;\r\n      Exit;\r\n    end;\r\n\r\n    { If no BOM was found, check for leading/trailing byte sequences,\r\n      which are uncommon in usual non UTF-8 encoded text.\r\n\r\n      NOTE: There is no 100% save way to detect UTF-8 streams. The bigger\r\n            MinimumCountOfUTF8Strings, the lower is the probability of\r\n            a false positive. On the other hand, a big MinimumCountOfUTF8Strings\r\n            makes it unlikely to detect files with only little usage of non\r\n            US-ASCII chars, like usual in European languages. }\r\n\r\n    FoundUTF8Strings := 0;\r\n    i := 0;\r\n    while i < BufferSize do\r\n    begin\r\n      case Buffer[i] of\r\n        $00..$7F: // skip US-ASCII characters as they could belong to various charsets\r\n          ;\r\n        $C2..$DF:\r\n          if CountOfTrailingBytes = 1 then\r\n            inc(FoundUTF8Strings)\r\n          else\r\n            Break;\r\n        $E0:\r\n          begin\r\n            inc(i);\r\n            if (i < BufferSize) and (Buffer[i] in [$A0..$BF]) and (CountOfTrailingBytes = 1) then\r\n              inc(FoundUTF8Strings)\r\n            else\r\n              Break;\r\n          end;\r\n        $E1..$EC, $EE..$EF:\r\n          if CountOfTrailingBytes = 2 then\r\n            inc(FoundUTF8Strings)\r\n          else\r\n            Break;\r\n        $ED:\r\n          begin\r\n            inc(i);\r\n            if (i < BufferSize) and (Buffer[i] in [$80..$9F]) and (CountOfTrailingBytes = 1) then\r\n              inc(FoundUTF8Strings)\r\n            else\r\n              Break;\r\n          end;\r\n        $F0:\r\n          begin\r\n            inc(i);\r\n            if (i < BufferSize) and (Buffer[i] in [$90..$BF]) and (CountOfTrailingBytes = 2) then\r\n              inc(FoundUTF8Strings)\r\n            else\r\n              Break;\r\n          end;\r\n        $F1..$F3:\r\n          if CountOfTrailingBytes = 3 then\r\n            inc(FoundUTF8Strings)\r\n          else\r\n            Break;\r\n        $F4:\r\n          begin\r\n            inc(i);\r\n            if (i < BufferSize) and (Buffer[i] in [$80..$8F]) and (CountOfTrailingBytes = 2) then\r\n              inc(FoundUTF8Strings)\r\n            else\r\n              Break;\r\n          end;\r\n        $C0, $C1, $F5..$FF: // invalid UTF-8 bytes\r\n          Break;\r\n        $80..$BF: // trailing bytes are consumed when handling leading bytes,\r\n                   // any occurence of \"orphaned\" trailing bytes is invalid UTF-8\r\n          Break;\r\n      end;\r\n\r\n      if FoundUTF8Strings = MinimumCountOfUTF8Strings then\r\n      begin\r\n        Result := True;\r\n        Break;\r\n      end;\r\n\r\n      inc(i);\r\n    end;\r\n  end;\r\nend;\r\n\r\nfunction GetEncoding(const FileName: UnicodeString; out WithBOM: Boolean): TSynEncoding;\r\nvar\r\n  Stream: TStream;\r\nbegin\r\n  Stream := TWideFileStream.Create(FileName, fmOpenRead or fmShareDenyWrite);\r\n  try\r\n    Result := GetEncoding(Stream, WithBOM);\r\n  finally\r\n    Stream.Free;\r\n  end;\r\nend;\r\n\r\nfunction GetEncoding(Stream: TStream; out WithBOM: Boolean): TSynEncoding;\r\nvar\r\n  BOM: WideChar;\r\n  Size: Integer;\r\nbegin\r\n  // if Stream is nil, let Delphi raise the exception, by accessing Stream,\r\n  // to signal an invalid result\r\n  \r\n  // start analysis at actual Stream.Position\r\n  Size := Stream.Size - Stream.Position;\r\n\r\n  // if no special characteristics are found it is probably ANSI\r\n  Result := seAnsi;\r\n\r\n  if IsUTF8(Stream, WithBOM) then\r\n  begin\r\n    Result := seUTF8;\r\n    Exit;\r\n  end;\r\n\r\n  { try to detect UTF-16 by finding a BOM in UTF-16 format }\r\n\r\n  if Size >= 2 then\r\n  begin\r\n    Stream.ReadBuffer(BOM, sizeof(BOM));\r\n    Stream.Seek(-sizeof(BOM), soFromCurrent);\r\n    if BOM = WideChar(UTF16BOMLE) then\r\n    begin\r\n      Result := seUTF16LE;\r\n      WithBOM := True;\r\n      Exit;\r\n    end\r\n    else if BOM = WideChar(UTF16BOMBE) then\r\n    begin\r\n      Result := seUTF16BE;\r\n      WithBOM := True;\r\n      Exit;\r\n    end\r\n  end;\r\nend;\r\n\r\nprocedure SaveToFile(const WS: UnicodeString; const FileName: UnicodeString;\r\n  Encoding: TSynEncoding; WithBom: Boolean = True);\r\nvar\r\n  Stream: TStream;\r\nbegin\r\n  Stream := TWideFileStream.Create(FileName, fmCreate);\r\n  try\r\n    SaveToStream(WS, Stream, Encoding, WithBom);\r\n  finally\r\n    Stream.Free;\r\n  end;\r\nend;\r\n\r\nprocedure SaveToFile(UnicodeStrings: TUnicodeStrings; const FileName: UnicodeString;\r\n  Encoding: TSynEncoding; WithBom: Boolean = True);\r\nvar\r\n  Stream: TStream;\r\nbegin\r\n  Stream := TWideFileStream.Create(FileName, fmCreate);\r\n  try\r\n    SaveToStream(UnicodeStrings, Stream, Encoding, WithBom);\r\n  finally\r\n    Stream.Free;\r\n  end;\r\nend;\r\n\r\nfunction LoadFromFile(UnicodeStrings: TUnicodeStrings; const FileName: UnicodeString;\r\n  out WithBOM: Boolean): TSynEncoding;\r\nvar\r\n  Stream: TStream;\r\nbegin\r\n  Stream := TWideFileStream.Create(FileName, fmOpenRead or fmShareDenyWrite);\r\n  try\r\n    Result := LoadFromStream(UnicodeStrings, Stream, WithBOM);\r\n  finally\r\n    Stream.Free;\r\n  end;\r\nend;\r\n\r\nfunction LoadFromFile(UnicodeStrings: TUnicodeStrings; const FileName: UnicodeString;\r\n  Encoding: TSynEncoding; out WithBOM: Boolean): TSynEncoding;\r\nvar\r\n  Stream: TStream;\r\nbegin\r\n  Stream := TWideFileStream.Create(FileName, fmOpenRead or fmShareDenyWrite);\r\n  try\r\n    Result := LoadFromStream(UnicodeStrings, Stream, Encoding, WithBOM);\r\n  finally\r\n    Stream.Free;\r\n  end;\r\nend;\r\n\r\nprocedure SaveToStream(const WS: UnicodeString; Stream: TStream; Encoding: TSynEncoding;\r\n  WithBom: Boolean  = True);\r\nvar\r\n  UTF16BOM: UnicodeString;\r\n\r\n  UTF8Str: UTF8String;\r\n  AnsiStr: AnsiString;\r\nbegin\r\n  if WithBom then\r\n    case Encoding of\r\n      seUTF8:\r\n        Stream.WriteBuffer(UTF8BOM, 3);\r\n      seUTF16LE:\r\n        begin\r\n          UTF16BOM := BOM_LSB_FIRST;\r\n          Stream.WriteBuffer(PWideChar(UTF16BOM)^, 2);\r\n        end;\r\n      seUTF16BE:\r\n        begin\r\n          UTF16BOM := BOM_MSB_FIRST;\r\n          Stream.WriteBuffer(PWideChar(UTF16BOM)^, 2);\r\n        end;\r\n    end;\r\n\r\n  case Encoding of\r\n    seUTF8:\r\n      begin\r\n        UTF8Str := UTF8Encode(WS);\r\n        Stream.WriteBuffer(UTF8Str[1], Length(UTF8Str));\r\n      end;\r\n    seUTF16LE:\r\n      Stream.WriteBuffer(WS[1], Length(WS) * sizeof(WideChar));\r\n    seUTF16BE:\r\n      begin\r\n        StrSwapByteOrder(PWideChar(WS));\r\n        Stream.WriteBuffer(WS[1], Length(WS) * sizeof(WideChar));\r\n      end;\r\n    seAnsi:\r\n      begin\r\n        AnsiStr := AnsiString(PWideChar(WS));\r\n        Stream.WriteBuffer(AnsiStr[1], Length(AnsiStr));\r\n      end;\r\n  end;\r\nend;\r\n\r\ntype\r\n  TSynEditStringListAccess = class(TSynEditStringList);\r\n\r\nprocedure SaveToStream(UnicodeStrings: TUnicodeStrings; Stream: TStream;\r\n  Encoding: TSynEncoding; WithBom: Boolean = True);\r\nvar\r\n  SText: UnicodeString;\r\n  SaveFStreaming: Boolean;\r\nbegin\r\n  // if UnicodeStrings or Stream is nil, let Delphi raise the exception to flag the error\r\n\r\n  if UnicodeStrings is TSynEditStringList then\r\n  begin\r\n    SaveFStreaming := TSynEditStringListAccess(UnicodeStrings).FStreaming;\r\n    TSynEditStringListAccess(UnicodeStrings).FStreaming := True;\r\n    SText := UnicodeStrings.Text;\r\n    TSynEditStringListAccess(UnicodeStrings).FStreaming := SaveFStreaming;\r\n  end\r\n  else\r\n    SText := UnicodeStrings.Text;\r\n  SaveToStream(SText, Stream, Encoding, WithBom);\r\nend;\r\n\r\nfunction LoadFromStream(UnicodeStrings: TUnicodeStrings; Stream: TStream;\r\n  out WithBOM: Boolean): TSynEncoding;\r\nvar\r\n  Dummy: Boolean;\r\nbegin\r\n  Result := LoadFromStream(UnicodeStrings, Stream, GetEncoding(Stream, WithBOM),\r\n    Dummy);\r\nend;\r\n\r\nfunction LoadFromStream(UnicodeStrings: TUnicodeStrings; Stream: TStream;\r\n  Encoding: TSynEncoding): TSynEncoding; overload;\r\nvar\r\n  Dummy: Boolean;\r\nbegin\r\n  Result := LoadFromStream(UnicodeStrings, Stream, Encoding, Dummy);\r\nend;\r\n\r\nfunction LoadFromStream(UnicodeStrings: TUnicodeStrings; Stream: TStream;\r\n  Encoding: TSynEncoding; out WithBOM: Boolean): TSynEncoding;\r\nvar\r\n  WideStr: UnicodeString;\r\n  UTF8Str: UTF8String;\r\n  AnsiStr: AnsiString;\r\n  Size: Integer;\r\n\r\n  function SkipBOM: Boolean;\r\n  var\r\n    BOM: array of Byte;\r\n  begin\r\n    Result := False;\r\n    case Encoding of\r\n      seUTF8:\r\n        begin\r\n          SetLength(BOM, Min(Length(UTF8BOM), Size));\r\n          Stream.ReadBuffer(BOM[0], Length(BOM));\r\n          if (Length(BOM) <> Length(UTF8BOM)) or\r\n            not CompareMem(@BOM[0], @UTF8BOM[0], Length(UTF8BOM))\r\n          then\r\n            Stream.Seek(-Length(BOM), soCurrent)\r\n          else\r\n            Result := True;\r\n        end;\r\n      seUTF16LE:\r\n        begin\r\n          SetLength(BOM, Min(Length(UTF16BOMLE), Size));\r\n          Stream.ReadBuffer(BOM[0], Length(BOM));\r\n          if (Length(BOM) <> Length(UTF16BOMLE)) or\r\n            not CompareMem(@BOM[0], @UTF16BOMLE[0], Length(UTF16BOMLE))\r\n          then\r\n            Stream.Seek(-Length(BOM), soCurrent)\r\n          else\r\n            Result := True;\r\n        end;\r\n      seUTF16BE:\r\n        begin\r\n          SetLength(BOM, Min(Length(UTF16BOMBE), Size));\r\n          Stream.ReadBuffer(BOM[0], Length(BOM));\r\n          if (Length(BOM) <> Length(UTF16BOMBE)) or\r\n            not CompareMem(@BOM[0], @UTF16BOMBE[0], Length(UTF16BOMBE))\r\n          then\r\n            Stream.Seek(-Length(BOM), soCurrent)\r\n          else\r\n            Result := True;\r\n        end;\r\n    end;\r\n    Size := Stream.Size - Stream.Position;\r\n  end;\r\n\r\nbegin\r\n  // if UnicodeStrings or Stream is nil, let Delphi raise the exception to\r\n  // signal an invalid result\r\n  UnicodeStrings.BeginUpdate;\r\n  try\r\n    Result := Encoding;\r\n    // start decoding at actual Stream.Position\r\n    Size := Stream.Size - Stream.Position;\r\n\r\n    // skip BOM, if it exists\r\n    WithBOM := SkipBOM;\r\n\r\n    case Result of\r\n      seUTF8:\r\n        begin\r\n          SetLength(UTF8Str, Size);\r\n          Stream.ReadBuffer(UTF8Str[1], Size);\r\n{$IFDEF UNICODE}\r\n          UnicodeStrings.Text := UTF8ToUnicodeString(UTF8Str);\r\n{$ELSE}\r\n          UnicodeStrings.Text := UTF8Decode(UTF8Str);\r\n          UnicodeStrings.SaveFormat := sfUTF8;\r\n{$ENDIF}\r\n        end;\r\n      seUTF16LE:\r\n        begin\r\n          SetLength(WideStr, Size div 2);\r\n          Stream.ReadBuffer(WideStr[1], Size);\r\n          UnicodeStrings.Text := WideStr;\r\n{$IFNDEF UNICODE}\r\n          UnicodeStrings.SaveFormat := sfUTF16LSB;\r\n{$ENDIF}\r\n        end;\r\n      seUTF16BE:\r\n        begin\r\n          SetLength(WideStr, Size div 2);\r\n          Stream.ReadBuffer(WideStr[1], Size);\r\n          StrSwapByteOrder(PWideChar(WideStr));\r\n          UnicodeStrings.Text := WideStr;\r\n{$IFNDEF UNICODE}\r\n          UnicodeStrings.SaveFormat := sfUTF16MSB;\r\n{$ENDIF}\r\n        end;\r\n      seAnsi:\r\n        begin\r\n          SetLength(AnsiStr, Size);\r\n          Stream.ReadBuffer(AnsiStr[1], Size);\r\n          UnicodeStrings.Text := UnicodeString(AnsiStr);\r\n{$IFNDEF UNICODE}\r\n          UnicodeStrings.SaveFormat := sfAnsi;\r\n{$ENDIF}\r\n        end;\r\n    end;\r\n  finally\r\n    UnicodeStrings.EndUpdate\r\n  end\r\nend;\r\n\r\nfunction ClipboardProvidesText: Boolean;\r\nbegin\r\n{$IFDEF SYN_CLX}\r\n  Result := Clipboard.Provides('text/plain');\r\n{$ELSE}\r\n  Result := IsClipboardFormatAvailable(CF_TEXT) or IsClipboardFormatAvailable(CF_UNICODETEXT);\r\n{$ENDIF}\r\nend;\r\n\r\nfunction GetClipboardText: UnicodeString;\r\n{$IFDEF SYN_CLX}\r\nbegin\r\n  Result := Clipboard.AsText;\r\nend;\r\n{$ELSE}\r\nvar\r\n  Mem: HGLOBAL;\r\n  LocaleID: LCID;\r\n  P: PByte;\r\nbegin\r\n  Result := '';\r\n  Clipboard.Open;\r\n  try\r\n    if Clipboard.HasFormat(CF_UNICODETEXT) then\r\n    begin\r\n      Mem := Clipboard.GetAsHandle(CF_UNICODETEXT);\r\n        try\r\n          if Mem <> 0 then\r\n            Result := PWideChar(GlobalLock(Mem));\r\n        finally\r\n          if Mem <> 0 then GlobalUnlock(Mem);\r\n        end;\r\n    end\r\n    else\r\n    begin\r\n      LocaleID := 0;\r\n      Mem := Clipboard.GetAsHandle(CF_LOCALE);\r\n      try\r\n        if Mem <> 0 then LocaleID := PInteger(GlobalLock(Mem))^;\r\n      finally\r\n        if Mem <> 0 then GlobalUnlock(Mem);\r\n      end;\r\n\r\n      Mem := Clipboard.GetAsHandle(CF_TEXT);\r\n      try\r\n        if Mem <> 0 then\r\n        begin\r\n          P := GlobalLock(Mem);\r\n          Result := StringToUnicodeStringEx(PAnsiChar(P), CodePageFromLocale(LocaleID));\r\n        end\r\n      finally\r\n        if Mem <> 0 then GlobalUnlock(Mem);\r\n      end;\r\n    end;\r\n  finally\r\n    Clipboard.Close;\r\n  end;\r\nend;\r\n{$ENDIF}\r\n\r\nprocedure SetClipboardText(const Text: UnicodeString);\r\n{$IFDEF SYN_CLX}\r\nbegin\r\n  Clipboard.AsText := Text;\r\nend;\r\n{$ELSE}\r\nvar\r\n  Mem: HGLOBAL;\r\n  P: PByte;\r\n  SLen: Integer;\r\nbegin\r\n  if Text = '' then Exit;\r\n  SLen := Length(Text);\r\n  Clipboard.Open;\r\n  try\r\n    Clipboard.Clear;\r\n\r\n    // set ANSI text only on Win9X, WinNT automatically creates ANSI from Unicode\r\n    if Win32Platform <> VER_PLATFORM_WIN32_NT then\r\n    begin\r\n      Mem := GlobalAlloc(GMEM_MOVEABLE or GMEM_DDESHARE, SLen + 1);\r\n      if Mem <> 0 then\r\n      begin\r\n        P := GlobalLock(Mem);\r\n        try\r\n          if P <> nil then\r\n          begin\r\n            Move(PAnsiChar(AnsiString(Text))^, P^, SLen + 1);\r\n            Clipboard.SetAsHandle(CF_TEXT, Mem);\r\n          end;\r\n        finally\r\n          GlobalUnlock(Mem);\r\n        end;\r\n      end;\r\n    end;\r\n\r\n    // set unicode text, this also works on Win9X, even if the clipboard-viewer\r\n    // can't show it, Word 2000+ can paste it including the unicode only characters\r\n    Mem := GlobalAlloc(GMEM_MOVEABLE or GMEM_DDESHARE,\r\n      (SLen + 1) * sizeof(WideChar));\r\n    if Mem <> 0 then\r\n    begin\r\n      P := GlobalLock(Mem);\r\n      try\r\n        if P <> nil then\r\n        begin\r\n          Move(PWideChar(Text)^, P^, (SLen + 1) * sizeof(WideChar));\r\n          Clipboard.SetAsHandle(CF_UNICODETEXT, Mem);\r\n        end;\r\n      finally\r\n        GlobalUnlock(Mem);\r\n      end;\r\n    end;\r\n    // Don't free Mem!  It belongs to the clipboard now, and it will free it\r\n    // when it is done with it.\r\n  finally\r\n    Clipboard.Close;\r\n  end;\r\nend;\r\n{$ENDIF}\r\n\r\n{$IFNDEF UNICODE}\r\n{$IFNDEF SYN_COMPILER_6_UP}\r\nprocedure AssignWideStr(var Dest: UnicodeString; const Source: UnicodeString);\r\nbegin\r\n  Dest := Source;\r\nend;\r\n\r\nprocedure IntGetWideStrProp(Instance: TObject; PropInfo: PPropInfo;\r\n  var Value: UnicodeString); assembler;\r\nasm\r\n        { ->    EAX Pointer to instance         }\r\n        {       EDX Pointer to property info    }\r\n        {       ECX Pointer to result string    }\r\n\r\n        PUSH    ESI\r\n        PUSH    EDI\r\n        MOV     EDI,EDX\r\n\r\n        MOV     EDX,[EDI].TPropInfo.Index       { pass index in EDX }\r\n        CMP     EDX,$80000000\r\n        JNE     @@hasIndex\r\n        MOV     EDX,ECX                         { pass value in EDX }\r\n@@hasIndex:\r\n        MOV     ESI,[EDI].TPropInfo.GetProc\r\n        CMP     [EDI].TPropInfo.GetProc.Byte[3],$FE\r\n        JA      @@isField\r\n        JB      @@isStaticMethod\r\n\r\n@@isVirtualMethod:\r\n        MOVSX   ESI,SI                          { sign extend slot offset }\r\n        ADD     ESI,[EAX]                       { vmt + slot offset }\r\n        CALL    DWORD PTR [ESI]\r\n        JMP     @@exit\r\n\r\n@@isStaticMethod:\r\n        CALL    ESI\r\n        JMP     @@exit\r\n\r\n@@isField:\r\n  AND  ESI,$00FFFFFF\r\n  MOV  EDX,[EAX+ESI]\r\n  MOV  EAX,ECX\r\n  CALL  AssignWideStr\r\n\r\n@@exit:\r\n        POP     EDI\r\n        POP     ESI\r\nend;\r\n\r\nfunction GetWideStrProp(Instance: TObject; PropInfo: PPropInfo): UnicodeString;\r\nbegin\r\n  IntGetWideStrProp(Instance, PropInfo, Result);\r\nend;\r\n\r\nprocedure SetWideStrProp(Instance: TObject; PropInfo: PPropInfo;\r\n  const Value: UnicodeString); assembler;\r\nasm\r\n        { ->    EAX Pointer to instance         }\r\n        {       EDX Pointer to property info    }\r\n        {       ECX Pointer to string value     }\r\n\r\n        PUSH    ESI\r\n        PUSH    EDI\r\n        MOV     ESI,EDX\r\n\r\n        MOV     EDX,[ESI].TPropInfo.Index       { pass index in EDX }\r\n        CMP     EDX,$80000000\r\n        JNE     @@hasIndex\r\n        MOV     EDX,ECX                         { pass value in EDX }\r\n@@hasIndex:\r\n        MOV     EDI,[ESI].TPropInfo.SetProc\r\n        CMP     [ESI].TPropInfo.SetProc.Byte[3],$FE\r\n        JA      @@isField\r\n        JB      @@isStaticMethod\r\n\r\n@@isVirtualMethod:\r\n        MOVSX   EDI,DI\r\n        ADD     EDI,[EAX]\r\n        CALL    DWORD PTR [EDI]\r\n        JMP     @@exit\r\n\r\n@@isStaticMethod:\r\n        CALL    EDI\r\n        JMP     @@exit\r\n\r\n@@isField:\r\n  AND  EDI,$00FFFFFF\r\n  ADD  EAX,EDI\r\n  MOV  EDX,ECX\r\n  CALL  AssignWideStr\r\n\r\n@@exit:\r\n        POP     EDI\r\n        POP     ESI\r\nend;\r\n{$ENDIF}\r\n\r\ntype\r\n  TUnicodeStringPropertyFiler = class\r\n  private\r\n    FInstance: TPersistent;\r\n    FPropInfo: PPropInfo;\r\n    procedure ReadData(Reader: TReader);\r\n    procedure WriteData(Writer: TWriter);\r\n  public\r\n    procedure DefineProperties(Filer: TFiler; Instance: TPersistent; PropName: AnsiString);\r\n  end;\r\n\r\n  TWideCharPropertyFiler = class\r\n  private\r\n    FInstance: TPersistent;\r\n    FPropInfo: PPropInfo;\r\n    FWriter: TWriter;\r\n    procedure GetLookupInfo(var Ancestor: TPersistent;\r\n      var Root, LookupRoot, RootAncestor: TComponent);\r\n    procedure ReadData(Reader: TReader);\r\n    procedure WriteData(Writer: TWriter);\r\n    function ReadChar(Reader: TReader): WideChar;\r\n  public\r\n    procedure DefineProperties(Filer: TFiler; Instance: TPersistent; PropName: AnsiString);\r\n  end;\r\n\r\ntype\r\n  TGetLookupInfoEvent = procedure(var Ancestor: TPersistent;\r\n    var Root, LookupRoot, RootAncestor: TComponent) of object;\r\n\r\nfunction AncestorIsValid(Ancestor: TPersistent; Root, RootAncestor: TComponent): Boolean;\r\nbegin\r\n  Result := (Ancestor <> nil) and (RootAncestor <> nil) and\r\n            Root.InheritsFrom(RootAncestor.ClassType);\r\nend;\r\n\r\nfunction IsDefaultOrdPropertyValue(Instance: TObject; PropInfo: PPropInfo;\r\n  OnGetLookupInfo: TGetLookupInfoEvent): Boolean;\r\nvar\r\n  Ancestor: TPersistent;\r\n  LookupRoot: TComponent;\r\n  RootAncestor: TComponent;\r\n  Root: TComponent;\r\n  AncestorValid: Boolean;\r\n  Value: Longint;\r\n  Default: LongInt;\r\nbegin\r\n  Ancestor := nil;\r\n  Root := nil;\r\n  LookupRoot := nil;\r\n  RootAncestor := nil;\r\n\r\n  if Assigned(OnGetLookupInfo) then\r\n    OnGetLookupInfo(Ancestor, Root, LookupRoot, RootAncestor);\r\n\r\n  AncestorValid := AncestorIsValid(Ancestor, Root, RootAncestor);\r\n\r\n  Result := True;\r\n  if (PropInfo^.GetProc <> nil) and (PropInfo^.SetProc <> nil) then\r\n  begin\r\n    Value := GetOrdProp(Instance, PropInfo);\r\n    if AncestorValid then\r\n      Result := Value = GetOrdProp(Ancestor, PropInfo)\r\n    else\r\n    begin\r\n      Default := PPropInfo(PropInfo)^.Default;\r\n      Result :=  (Default <> LongInt($80000000)) and (Value = Default);\r\n    end;\r\n  end;\r\nend;\r\n\r\nprocedure ReadError(S: string);\r\nbegin\r\n  raise EReadError.Create(S);\r\nend;\r\n\r\nprocedure PropValueError;\r\nbegin\r\n  ReadError(SInvalidPropertyValue);\r\nend;\r\n\r\n{ TUnicodeStringPropertyFiler }\r\n\r\nprocedure TUnicodeStringPropertyFiler.DefineProperties(Filer: TFiler; Instance: TPersistent;\r\n  PropName: AnsiString);\r\n\r\n  function HasData: Boolean;\r\n  var\r\n    CurrPropValue: UnicodeString;\r\n  begin\r\n    // must be stored\r\n    Result := IsStoredProp(Instance, FPropInfo);\r\n    if Result\r\n    and (Filer.Ancestor <> nil)\r\n    and (GetPropInfo(Filer.Ancestor, PropName, [tkWString]) <> nil) then\r\n    begin\r\n      // must be different than ancestor\r\n      CurrPropValue := GetWideStrProp(Instance, FPropInfo);\r\n      Result := CurrPropValue <> GetWideStrProp(Filer.Ancestor, GetPropInfo(Filer.Ancestor, PropName));\r\n    end;\r\n    if Result then\r\n      Result := GetWideStrProp(Instance, FPropInfo) <> '';\r\n  end;\r\n\r\nbegin\r\n  FInstance := Instance;\r\n  FPropInfo := GetPropInfo(Instance, PropName, [tkWString]);\r\n  if FPropInfo <> nil then\r\n    // must be published (and of type UnicodeString)\r\n    Filer.DefineProperty(PropName + 'W', ReadData, WriteData, HasData);\r\n  FInstance := nil;\r\n  FPropInfo := nil;\r\nend;\r\n\r\nprocedure TUnicodeStringPropertyFiler.ReadData(Reader: TReader);\r\nbegin\r\n  case Reader.NextValue of\r\n    vaLString, vaString:\r\n      SetWideStrProp(FInstance, FPropInfo, Reader.ReadString);\r\n  else\r\n    SetWideStrProp(FInstance, FPropInfo, Reader.ReadWideString);\r\n  end;\r\nend;\r\n\r\nprocedure TUnicodeStringPropertyFiler.WriteData(Writer: TWriter);\r\nbegin\r\n  Writer.WriteWideString(GetWideStrProp(FInstance, FPropInfo));\r\nend;\r\n\r\n{ TWideCharPropertyFiler }\r\n\r\nprocedure TWideCharPropertyFiler.GetLookupInfo(var Ancestor: TPersistent;\r\n  var Root, LookupRoot, RootAncestor: TComponent);\r\nbegin\r\n  Ancestor := FWriter.Ancestor;\r\n  Root := FWriter.Root;\r\n  LookupRoot := FWriter.LookupRoot;\r\n  RootAncestor := FWriter.RootAncestor;\r\nend;\r\n\r\nfunction TWideCharPropertyFiler.ReadChar(Reader: TReader): WideChar;\r\nvar\r\n  Temp: UnicodeString;\r\nbegin\r\n  case Reader.NextValue of\r\n    vaWString:\r\n      Temp := Reader.ReadWideString;\r\n    vaString:\r\n      Temp := Reader.ReadString;\r\n    else\r\n      PropValueError;\r\n  end;\r\n\r\n  if Length(Temp) > 1 then\r\n    PropValueError;\r\n  Result := Temp[1];\r\nend;\r\n\r\nprocedure TWideCharPropertyFiler.ReadData(Reader: TReader);\r\nbegin\r\n  SetOrdProp(FInstance, FPropInfo, Ord(ReadChar(Reader)));\r\nend;\r\n\r\ntype\r\n  TAccessWriter = class(TWriter)\r\n  end;\r\n\r\nprocedure TWideCharPropertyFiler.WriteData(Writer: TWriter);\r\nvar\r\n  L: Integer;\r\n  Temp: UnicodeString;\r\nbegin\r\n  Temp := WideChar(GetOrdProp(FInstance, FPropInfo));\r\n\r\n  TAccessWriter(Writer).WriteValue(vaWString);\r\n  L := Length(Temp);\r\n  Writer.Write(L, SizeOf(Integer));\r\n  Writer.Write(Pointer(@Temp[1])^, L * 2);\r\nend;\r\n\r\nprocedure TWideCharPropertyFiler.DefineProperties(Filer: TFiler;\r\n  Instance: TPersistent; PropName: AnsiString);\r\n\r\n  function HasData: Boolean;\r\n  var\r\n    CurrPropValue: Integer;\r\n  begin\r\n    // must be stored\r\n    Result := IsStoredProp(Instance, FPropInfo);\r\n    if Result and (Filer.Ancestor <> nil) and\r\n      (GetPropInfo(Filer.Ancestor, PropName, [tkWChar]) <> nil) then\r\n    begin\r\n      // must be different than ancestor\r\n      CurrPropValue := GetOrdProp(Instance, FPropInfo);\r\n      Result := CurrPropValue <> GetOrdProp(Filer.Ancestor, GetPropInfo(Filer.Ancestor, PropName));\r\n    end;\r\n\r\n    if Result and (Filer is TWriter) then\r\n    begin\r\n      FWriter := TWriter(Filer);\r\n      Result := not IsDefaultOrdPropertyValue(Instance, FPropInfo, GetLookupInfo);\r\n    end;\r\n  end;\r\n\r\nbegin\r\n  FInstance := Instance;\r\n  FPropInfo := GetPropInfo(Instance, PropName, [tkWChar]);\r\n  if FPropInfo <> nil then // must be published (and of type WideChar)\r\n  begin\r\n    // W suffix causes Delphi's native streaming system to ignore the property\r\n    // and let us do the reading.\r\n    Filer.DefineProperty(PropName + 'W', ReadData, WriteData, HasData);\r\n  end;\r\n  FInstance := nil;\r\n  FPropInfo := nil;\r\nend;\r\n\r\nprocedure UnicodeDefineProperties(Filer: TFiler; Instance: TPersistent);\r\nvar\r\n  I, Count: Integer;\r\n  PropInfo: PPropInfo;\r\n  PropList: PPropList;\r\n  UnicodeStringFiler: TUnicodeStringPropertyFiler;\r\n  WideCharFiler: TWideCharPropertyFiler;\r\nbegin\r\n  Count := GetTypeData(Instance.ClassInfo)^.PropCount;\r\n  if Count > 0 then\r\n  begin\r\n    UnicodeStringFiler := TUnicodeStringPropertyFiler.Create;\r\n    try\r\n      WideCharFiler := TWideCharPropertyFiler.Create;\r\n      try\r\n        GetMem(PropList, Count * SizeOf(Pointer));\r\n        try\r\n          GetPropInfos(Instance.ClassInfo, PropList);\r\n          for I := 0 to Count - 1 do\r\n          begin\r\n            PropInfo := PropList^[I];\r\n            if (PropInfo = nil) then\r\n              break;\r\n            if (PropInfo.PropType^.Kind = tkWString) then\r\n              UnicodeStringFiler.DefineProperties(Filer, Instance, PropInfo.Name)\r\n            else if (PropInfo.PropType^.Kind = tkWChar) then\r\n              WideCharFiler.DefineProperties(Filer, Instance, PropInfo.Name)\r\n          end;\r\n        finally\r\n          FreeMem(PropList, Count * SizeOf(Pointer));\r\n        end;\r\n      finally\r\n        WideCharFiler.Free;\r\n      end;\r\n    finally\r\n      UnicodeStringFiler.Free;\r\n    end;\r\n  end;\r\nend;\r\n{$ENDIF}\r\n\r\n{$IFDEF SYN_WIN32}\r\nfunction IsWideCharMappableToAnsi(const WC: WideChar): Boolean;\r\nvar\r\n  UsedDefaultChar: BOOL;\r\nbegin\r\n  WideCharToMultiByte(DefaultSystemCodePage, 0, PWideChar(@WC), 1, nil, 0, nil,\r\n    @UsedDefaultChar);\r\n  Result := not UsedDefaultChar;\r\nend;\r\n\r\nfunction IsUnicodeStringMappableToAnsi(const WS: UnicodeString): Boolean;\r\nvar\r\n  UsedDefaultChar: BOOL;\r\nbegin\r\n  WideCharToMultiByte(DefaultSystemCodePage, 0, PWideChar(WS), Length(WS), nil, 0,\r\n    nil, @UsedDefaultChar);\r\n  Result := not UsedDefaultChar;\r\nend;\r\n{$ENDIF}\r\n\r\ninitialization\r\n{$IFDEF SYN_WIN32}\r\n  Win32PlatformIsUnicode := (Win32Platform = VER_PLATFORM_WIN32_NT);\r\n  {$IFNDEF UNICODE}\r\n  DefaultSystemCodePage := GetACP;\r\n  {$ENDIF}\r\n{$ENDIF}\r\n\r\nend.\r\n"
  },
  {
    "path": "External/SynEdit/Source/SynUsp10.pas",
    "content": "{******************************************************************************}\r\n{*                                                                            *}\r\n{*  Copyright (c) Microsoft Corporation. All rights reserved.                 *}\r\n{*                                                                            *}\r\n{*  File:       usp10.h                                                       *}\r\n{*  Content:    USP - Unicode Complex Script processor                        *}\r\n{*                                                                            *}\r\n{*  Delphi / FreePascal adaptation by Alexey Barkovoy (clootie@clootie.ru)    *}\r\n(*                                                                            *)\r\n{*  The original version from Alexey Barkovoy can be downloaded from:         *}\r\n{*     http://clootie.ru                                                      *}\r\n(*                                                                            *)\r\n(*  Dynamic linking logic (similar to what the JCL does) by Mal Hrz.        *)\r\n(*                                                                            *)\r\n(*  Latest version can be downloaded from http://mh-nexus.de/unisynedit.htm   *)\r\n(*  or checked out from the Unicode branch of SynEdit CVS.                    *) \r\n(*                                                                            *)\r\n{******************************************************************************}\r\n{                                                                              }\r\n{ The contents of this file are used with permission, subject to the Mozilla   }\r\n{ Public License Version 1.1 (the \"License\"); you may not use this file except }\r\n{ in compliance with the License. You may obtain a copy of the License at      }\r\n{ http://www.mozilla.org/MPL/MPL-1.1.html                                      }\r\n{                                                                              }\r\n{ Software distributed under the License is distributed on an \"AS IS\" basis,   }\r\n{ WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for }\r\n{ the specific language governing rights and limitations under the License.    }\r\n{                                                                              }\r\n{ Alternatively, the contents of this file may be used under the terms of the  }\r\n{ GNU Lesser General Public License (the  \"LGPL License\"), in which case the   }\r\n{ provisions of the LGPL License are applicable instead of those above.        }\r\n{ If you wish to allow use of your version of this file only under the terms   }\r\n{ of the LGPL License and not to allow others to use your version of this file }\r\n{ under the MPL, indicate your decision by deleting  the provisions above and  }\r\n{ replace  them with the notice and other provisions required by the LGPL      }\r\n{ License.  If you do not delete the provisions above, a recipient may use     }\r\n{ your version of this file under either the MPL or the LGPL License.          }\r\n{                                                                              }\r\n{ For more information about the LGPL: http://www.gnu.org/copyleft/lesser.html }\r\n{                                                                              }\r\n{******************************************************************************}\r\n\r\n// $Id: SynUsp10.pas,v 1.1.2.2 2008/09/17 13:59:12 maelh Exp $\r\n\r\n{$IFDEF FPC}\r\n{$mode objfpc}\r\n{$ENDIF}\r\n\r\n// necessary for dynamic linking\r\n{$STACKFRAMES ON}\r\n{$WARNINGS OFF}\r\n\r\nunit SynUsp10;\r\n\r\ninterface\r\n\r\nuses\r\n  Windows;\r\n\r\nconst\r\n  ///// Uniscribe build number\r\n  USPBUILD = 0400;\r\n\r\n\r\n\r\n  /////   USP - Unicode Complex Script processor\r\n  //\r\n  //      Copyright (c) Microsoft Corporation. All rights reserved.\r\n\r\n\r\n\r\n\r\n  /////   SCRIPT\r\n  //\r\n  //      The SCRIPT enum is an opaque type used internally to identify\r\n  //      which shaping engine functions are used to process a given run.\r\n  //\r\n  //\r\n  SCRIPT_UNDEFINED  = 0;\r\n  //\r\n  //p     SCRIPT_UNDEFINED: This is the only public script ordinal. May be\r\n  //      forced into the eScript field of a SCRIPT_ANALYSIS to disable shaping.\r\n  //      SCRIPT_UNDEFINED is supported by all fonts - ScriptShape will display\r\n  //      whatever glyph is defined in the font CMAP table, or, if none, the\r\n  //      missing glyph.\r\n\r\n\r\n\r\n\r\n\r\n\r\n\r\n  /////   USP Status Codes\r\n  //\r\n  USP_E_SCRIPT_NOT_IN_FONT   = DWord((SEVERITY_ERROR shl 31) or (FACILITY_ITF shl 16)) or $200; // MAKE_HRESULT(SEVERITY_ERROR,FACILITY_ITF,0x200)    // Script doesn't exist in font\r\n\r\n\r\n\r\n\r\n\r\n\r\n  /////   SCRIPT_CACHE\r\n  //\r\n  //      Many script APIs take a combination of HDC and SCRIPT_CACHE parameter.\r\n  //\r\n  //      A SCRIPT_CACHE is an opaque pointer to a Uniscribe font metric cache\r\n  //      structure.\r\n\r\ntype\r\n  SCRIPT_CACHE = Pointer;\r\n  {$EXTERNALSYM SCRIPT_CACHE}\r\n  TScriptCache = SCRIPT_CACHE;\r\n  PScriptCache = ^TScriptCache;\r\n\r\n\r\n//      The client must allocate and retain one SCRIPT_CACHE variable for each\r\n//      character style used. It must be initialised by the client to NULL.\r\n//\r\n//      APIs are passed an HDC and the address of a SCRIPT_CACHE variable.\r\n//      Uniscribe will first attempt to access font data via the SCRIPT_CACHE\r\n//      and will only inspect the HDC if the required data is not already\r\n//      cached.\r\n//\r\n//      The HDC may be passed as NULL. If data required by Uniscribe is\r\n//      already cached, the HDC won't be accessed and operation continues\r\n//      normally.\r\n//\r\n//      If the HDC is passed as NULL, and Uniscribe needs to access it for\r\n//      any reason, Uniscribe will return E_PENDING.\r\n//\r\n//      E_PENDING is returned quickly, allowing the client to avoid time\r\n//      consuming SelectObject calls. The following example applies to all\r\n//      APIs that take a SCRIPT_CACHE and an optional HDC.\r\n//\r\n//c     hr = ScriptShape(NULL, &sc, ..);\r\n//c     if (hr == E_PENDING) {\r\n//c         ... select font into hdc ...\r\n//c         hr = ScriptShape(hdc, &sc, ...);\r\n//c     }\r\n\r\n\r\n\r\n\r\n\r\n\r\n/////   ScriptFreeCache\r\n//\r\n//      The client may free a SCRIPT_CACHE at any time. Uniscribe maintains\r\n//      reference counts in it's font and shaper caches, and frees font data\r\n//      only when all sizes of the font are free, and shaper data only when\r\n//      all fonts it supports are freed.\r\n//\r\n//      The client should free the SCRIPT_CACHE for a style when it discards\r\n//      that style.\r\n//\r\n//      ScriptFreeCache always sets it's parameter to NULL to help avoid\r\n//      mis-referencing.\r\n\r\n\r\nfunction ScriptFreeCache(\r\n    psc: PScriptCache //InOut  Cache handle\r\n ): HRESULT; stdcall;\r\n\r\n\r\n\r\n\r\n\r\n\r\ntype\r\n  /////   SCRIPT_CONTROL\r\n  //\r\n  //      The SCRIPT_CONTROL structure provides itemization control flags to the\r\n  //      ScriptItemize function.\r\n  //\r\n  //\r\n\r\n  TScriptControl_enum = (\r\n    fContextDigits,       // Means use previous script instead of uDefaultLanguage\r\n    // The following flags provide legacy support for GetCharacterPlacement features\r\n    fInvertPreBoundDir,   // Reading order of virtual item immediately prior to string\r\n    fInvertPostBoundDir,  // Reading order of virtual item immediately following string\r\n    fLinkStringBefore,    // Equivalent to presence of ZWJ before string\r\n    fLinkStringAfter,     // Equivalent to presence of ZWJ after string\r\n    fNeutralOverride,     // Causes all neutrals to be strong in the current embedding direction\r\n    fNumericOverride,     // Causes all numerals to be strong in the current embedding direction\r\n    fLegacyBidiClass      // Causes plus and minus to be reated as neutrals, slash as a common separator\r\n  );\r\n  TScriptControl_set = set of TScriptControl_enum;\r\n\r\n  PScriptControl = ^TScriptControl;\r\n  tag_SCRIPT_CONTROL = packed record\r\n    uDefaultLanguage: Word;     // For NADS, also default for context\r\n    fFlags: TScriptControl_set;\r\n    fReserved: Byte;\r\n  end;\r\n(*  uDefaultLanguage: DWORD    {:16}; // For NADS, also default for context\r\n    fContextDigits: DWORD      {:1};  // Means use previous script instead of uDefaultLanguage\r\n\r\n    // The following flags provide legacy support for GetCharacterPlacement features\r\n    fInvertPreBoundDir: DWORD  {:1};  // Reading order of virtual item immediately prior to string\r\n    fInvertPostBoundDir: DWORD {:1};  // Reading order of virtual item immediately following string\r\n    fLinkStringBefore: DWORD   {:1};  // Equivalent to presence of ZWJ before string\r\n    fLinkStringAfter: DWORD    {:1};  // Equivalent to presence of ZWJ after string\r\n    fNeutralOverride: DWORD    {:1};  // Causes all neutrals to be strong in the current embedding direction\r\n    fNumericOverride: DWORD    {:1};  // Causes all numerals to be strong in the current embedding direction\r\n    fLegacyBidiClass: DWORD    {:1};  // Causes plus and minus to be reated as neutrals, slash as a common separator\r\n    fReserved: DWORD           {:8};\r\n  end; *)\r\n  {$EXTERNALSYM tag_SCRIPT_CONTROL}\r\n  SCRIPT_CONTROL = tag_SCRIPT_CONTROL;\r\n  {$EXTERNALSYM SCRIPT_CONTROL}\r\n  TScriptControl = tag_SCRIPT_CONTROL;\r\n\r\n//\r\n//\r\n//p     uDefaultLanguage: Language to use when Unicode values are ambiguous.\r\n//              Used by numeric processing to select digit shape when\r\n//              fDigitSubstitute (see SCRIPT_STATE) is in force.\r\n//\r\n//p     fContextDigits: Specifies that national digits are chosen according to\r\n//              the nearest previous strong text, rather than using\r\n//              uDefaultLanguage.\r\n//\r\n//p     fInvertPreBoundDir: By default text at the start of the string is\r\n//              laid out as if it follows strong text of the same direction\r\n//              as the base embedding level. Set fInvertPreBoundDir to change\r\n//              the initial context to the opposite of the base embedding\r\n//              level. This flag is for GetCharacterPlacement legacy support.\r\n//\r\n//p     fInvertPostBoundDir: By default text at the end of the string is\r\n//              laid out as if it preceeds strong text of the same direction\r\n//              as the base embedding level. Set fInvertPostBoundDir to change\r\n//              the final context to the opposite of the base embedding\r\n//              level. This flag is for GetCharacterPlacement legacy support.\r\n//\r\n//p     fLinkStringBefore: Causes the first character of the string to be\r\n//              shaped as if were joined to a previous character.\r\n//\r\n//p     fLinkStringAfter: Causes the last character of the string to be\r\n//              shaped as if were joined to a following character.\r\n//\r\n//p     fNeutralOverride: Causes all neutral characters in the string to be\r\n//              treated as if they were strong characters of their enclosing\r\n//              embedding level. This effectively locks neutrals in place,\r\n//              reordering occuring only between neutrals.\r\n//\r\n//p     fNumericOverride: Causes all numeric characters in the string to be\r\n//              treated as if they were strong characters of their enclosing\r\n//              embedding level. This effectively locks numerics in place,\r\n//              reordering occuring only between numerics.\r\n//\r\n//p     fReserved: Reserved. Always initialise to 0.\r\n\r\n\r\n\r\n\r\n\r\n\r\n  /////   SCRIPT_STATE\r\n  //\r\n  //      The SCRIPT_STATE structure is used both to initialise the unicode\r\n  //      algorithm state as an input parameter to ScriptItemize, and is also\r\n  //      a component of each item analysis returned by ScriptItemize.\r\n  //\r\n  //\r\n  TScriptState_enum = (\r\n    uBidiLevel_reserved1, uBidiLevel_r2, uBidiLevel_r3, uBidiLevel_r4, uBidiLevel_r5,\r\n    fOverrideDirection, // Set when in LRO/RLO embedding\r\n    fInhibitSymSwap,    // Set by U+206A (ISS), cleared by U+206B (ASS)\r\n    fCharShape,         // Set by U+206D (AAFS), cleared by U+206C (IAFS)\r\n    fDigitSubstitute,   // Set by U+206E (NADS), cleared by U+206F (NODS)\r\n    fInhibitLigate,     // Equiv !GCP_Ligate, no Unicode control chars yet\r\n    fDisplayZWG,        // Equiv GCP_DisplayZWG, no Unicode control characters yet\r\n    fArabicNumContext,  // For EN->AN Unicode rule\r\n    fGcpClusters        // For Generating Backward Compatible GCP Clusters (legacy Apps)\r\n  );\r\n  TScriptState_set = set of TScriptState_enum;\r\n\r\n  PScriptState = ^TScriptState;\r\n  tag_SCRIPT_STATE = packed record\r\n   case Byte of\r\n    0: (uBidiLevel: Byte)    {:5};  // Unicode Bidi algorithm embedding level (0-16)\r\n    1: (fFlags: TScriptState_set)\r\n  end;\r\n(*  uBidiLevel: Word         {:5};  // Unicode Bidi algorithm embedding level (0-16)\r\n    fOverrideDirection: Word {:1};  // Set when in LRO/RLO embedding\r\n    fInhibitSymSwap: Word    {:1};  // Set by U+206A (ISS), cleared by U+206B (ASS)\r\n    fCharShape: Word         {:1};  // Set by U+206D (AAFS), cleared by U+206C (IAFS)\r\n    fDigitSubstitute: Word   {:1};  // Set by U+206E (NADS), cleared by U+206F (NODS)\r\n    fInhibitLigate: Word     {:1};  // Equiv !GCP_Ligate, no Unicode control chars yet\r\n    fDisplayZWG: Word        {:1};  // Equiv GCP_DisplayZWG, no Unicode control characters yet\r\n    fArabicNumContext: Word  {:1};  // For EN->AN Unicode rule\r\n    fGcpClusters: Word       {:1};  // For Generating Backward Compatible GCP Clusters (legacy Apps)\r\n    fReserved: Word          {:1};\r\n    fEngineReserved: Word    {:2};  // For use by shaping engine\r\n  end; *)\r\n  {$EXTERNALSYM tag_SCRIPT_STATE}\r\n  SCRIPT_STATE = tag_SCRIPT_STATE;\r\n  {$EXTERNALSYM SCRIPT_STATE}\r\n  TScriptState = tag_SCRIPT_STATE;\r\n\r\nconst\r\n  MASK_uBidiLevel = $1F; // Mask to apply to TScriptState.uBidiLevel\r\ntype\r\n\r\n//\r\n//\r\n//p     uBidiLevel: The embedding level associated with all characters in this\r\n//              run according to the Unicode bidi algorithm. When passed to\r\n//              ScriptItemize, should be initialised to 0 for an LTR base\r\n//              embedding level, or 1 for RTL.\r\n//\r\n//p     fOverrideDirection: TRUE if this level is an override level (LRO/RLO).\r\n//              In an override level, characters are layed out purely\r\n//              left to right, or purely right to left. No reordering of digits\r\n//              or strong characters of opposing direction takes place.\r\n//              Note that this initial value is reset by LRE, RLE, LRO or\r\n//              RLO codes in the string.\r\n//\r\n//p     fInhibitSymSwap: TRUE if the shaping engine is to bypass mirroring of\r\n//              Unicode Mirrored glyphs such as brackets. Set by Unicode\r\n//              character ISS, cleared by ASS.\r\n//\r\n//p     fCharShape: TRUE if character codes in the Arabic Presentation Forms\r\n//              areas of Unicode should be shaped. (Not implemented).\r\n//\r\n//p     fDigitSubstitute: TRUE if character codes U+0030 through U+0039\r\n//              (European digits) are to be substituted by national digits.\r\n//              Set by Unicode NADS, Cleared by NODS.\r\n//\r\n//p     fInhibitLigate: TRUE if ligatures are not to be used in the shaping\r\n//              of Arabic or Hebrew characters.\r\n//\r\n//p     fDisplayZWG: TRUE if control characters are to be shaped as\r\n//              representational glyphs. (Normally, control characters are\r\n//              shaped to the blank glyph and given a width of zero).\r\n//\r\n//p     fArabicNumContext: TRUE indicates prior strong characters were Arabic\r\n//              for the purposes of rule P0 on page 3-19 of 'The Unicode\r\n//              Standard, version 2.0'. Should normally be set TRUE before\r\n//              itemizing an RTL paragraph in an Arabic language, FALSE\r\n//              otherwise.\r\n//\r\n//p     fGcpClusters: For GetCharaterPlacement legacy support only.\r\n//              Initialise to TRUE to request ScriptShape to generate\r\n//              the LogClust array the same way as GetCharacterPlacement\r\n//              does in Arabic and Hebrew Windows95. Affects only Arabic\r\n//              and Hebrew items.\r\n//\r\n//p     fReserved: Reserved. Always initialise to 0.\r\n//\r\n//p     fEngineReserved: Reserved. Always initialise to 0.\r\n\r\n\r\n\r\n\r\n\r\n\r\n  /////   SCRIPT_ANALYSIS\r\n  //\r\n  //      Each analysed item is described by a SCRIPT_ANALYSIS structure.\r\n  //      It also includes a copy of the Unicode algorithm state (SCRIPT_STATE).\r\n  //\r\n  //\r\n  TScriptAnalysis_enum = (\r\n    eScript_r1, eScript_r2, eScript_r3, eScript_r4, eScript_r5,  // first 10 bits\r\n    eScript_r6, eScript_r7, eScript_r8, eScript_r9, eScript_r10, // are reserved\r\n    fRTL,             // Rendering direction\r\n    fLayoutRTL,       // Set for GCP classes ARABIC/HEBREW and LOCALNUMBER\r\n    fLinkBefore,      // Implies there was a ZWJ before this item\r\n    fLinkAfter,       // Implies there is a ZWJ following this item.\r\n    fLogicalOrder,    // Set by client as input to ScriptShape/Place\r\n    fNoGlyphIndex     // Generated by ScriptShape/Place - this item does not use glyph indices\r\n  );\r\n  TScriptAnalysis_set = set of TScriptAnalysis_enum;\r\n\r\n  PScriptAnalysis = ^TScriptAnalysis;\r\n  tag_SCRIPT_ANALYSIS = packed record\r\n   case Byte of\r\n    0: (eScript: Word)   {:10};    // Shaping engine\r\n    1: (fFlags: TScriptAnalysis_set;\r\n        s: TScriptState)\r\n  end;\r\n(*  eScript: Word         {:10};    // Shaping engine\r\n    fRTL: Word            {:1};     // Rendering direction\r\n    fLayoutRTL: Word      {:1};     // Set for GCP classes ARABIC/HEBREW and LOCALNUMBER\r\n    fLinkBefore: Word     {:1};     // Implies there was a ZWJ before this item\r\n    fLinkAfter: Word      {:1};     // Implies there is a ZWJ following this item.\r\n    fLogicalOrder: Word   {:1};     // Set by client as input to ScriptShape/Place\r\n    fNoGlyphIndex: Word   {:1};     // Generated by ScriptShape/Place - this item does not use glyph indices\r\n    s: TScriptState;\r\n  end; *)\r\n  {$EXTERNALSYM tag_SCRIPT_ANALYSIS}\r\n  SCRIPT_ANALYSIS = tag_SCRIPT_ANALYSIS;\r\n  {$EXTERNALSYM SCRIPT_ANALYSIS}\r\n  TScriptAnalysis = tag_SCRIPT_ANALYSIS;\r\n\r\nconst\r\n  MASK_eScript = $3FF; // Mask to apply to TScriptAnalysis.eScript\r\ntype\r\n\r\n//\r\n//\r\n//p     eScript: Opaque value identifying which engine Uniscribe will use to\r\n//              Shape, Place and TextOut this item. The value of eScript is\r\n//              undefined, and will change in future releases, but attributes\r\n//              of eScript may be obtained by calling ScriptGetProperties.\r\n//\r\n//p     fRTL: Rendering direction. Normally identical to the parity of the\r\n//              Unicode embedding level, but may differ if overridden by\r\n//              GetCharacterPlacement legacy support.\r\n//\r\n//p     fLayoutRTL: Logical direction - whether conceptually part of a\r\n//              left-to-right sequenece or a right-to-left sequence. Although\r\n//              this is usually the same as fRTL, for a number in a\r\n//              right-to-left run, fRTL is False (because digits are always\r\n//              displayed LTR), but fLayoutRTL is True (because the number is\r\n//              read as part of the right-to-left sequence).\r\n//\r\n//p     fLinkBefore: If set, the shaping engine will shape the first character\r\n//              of this item as if it were joining with a previous character.\r\n//              Set by ScriptItemize, may be overriden before calling ScriptShape.\r\n//\r\n//p     fLinkAfter: If set, the shaping engine will shape the last character\r\n//              of this item as if it were joining with a subsequient character.\r\n//              Set by ScriptItemize, may be overriden before calling ScriptShape.\r\n//\r\n//p     fLogicalOrder: If set, the shaping engine will generate all glyph\r\n//              related arrays in logical order. By default glyph related\r\n//              arrays are in visual order, the first array entry corresponding\r\n//              to the leftmost glyph.\r\n//              Set to FALSE by ScriptItemize, may be overriden before calling\r\n//              ScriptShape.\r\n//\r\n//p     fNoGlyphIndex: May be set TRUE on input to ScriptShape to disable use\r\n//              of glyphs for this item. Additionally, ScriptShape will set it\r\n//              TRUE for hdcs containing symbolic, unrecognised and device fonts.\r\n//              Disabling glyphing disables complex script shaping. When set,\r\n//              shaping and placing for this item is implemented directly by\r\n//              calls to GetTextExtentExPoint and ExtTextOut.\r\n/////   SCRIPT_ITEM\r\n//\r\n//      The SCRIPT_ITEM structure includes a SCRIPT_ANALYSIS with the string\r\n//      ofset of the first character of the item.\r\n//\r\n//\r\n\r\n  PScriptItem = ^TScriptItem;\r\n  tag_SCRIPT_ITEM = record\r\n    iCharPos: Integer;      // Logical offset to first character in this item\r\n    a: TScriptAnalysis;\r\n  end;\r\n  {$EXTERNALSYM tag_SCRIPT_ITEM}\r\n  SCRIPT_ITEM = tag_SCRIPT_ITEM;\r\n  {$EXTERNALSYM SCRIPT_ITEM}\r\n  TScriptItem = SCRIPT_ITEM;\r\n\r\n//\r\n//\r\n//p     iCharPos: Offset from beginning of itemised string to first character\r\n//              of this item, counted in Unicode codepoints (i.e. words).\r\n//\r\n//p     a: Script analysis structure containing analysis specific to this\r\n//              item, to be passed to ScriptShape, ScriptPlace etc.\r\n\r\n\r\n\r\n\r\n\r\n\r\n/////   ScriptItemize - break text into items\r\n//\r\n//      Breaks a run of unicode into individually shapeable items.\r\n//      Items are delimited by\r\n//\r\n//      o Change of shaping engine\r\n//      o Change of direction\r\n//\r\n//      The client may create multiple runs from each item returned by\r\n//      ScriptItemize, but should not combine multiple items into a single run.\r\n//\r\n//      Later the client will call ScriptShape for each run (when measuring or\r\n//      rendering), and must pass the SCRIPT_ANALYSIS that ScriptItemize\r\n//      returned.\r\n\r\n\r\nfunction ScriptItemize(\r\n    const pwcInChars: PWideChar;     // In   Unicode string to be itemized\r\n    cInChars: Integer;               // In   Codepoint count to itemize\r\n    cMaxItems: Integer;              // In   Max length of itemization array\r\n    const psControl: PScriptControl; // In   Analysis control (optional)\r\n    const psState: PScriptState;     // In   Initial bidi algorithm state (optional)\r\n    pItems: PScriptItem;             // Out  Array to receive itemization\r\n    pcItems: PInteger                // Out  Count of items processed (optional)\r\n ): HRESULT; stdcall;\r\n{$EXTERNALSYM ScriptItemize}\r\n\r\n\r\n\r\n\r\n\r\n\r\n/////\r\n//\r\n//\r\n//      Returns E_INVALIDARG if pwcInChars == NULL or cInChars == 0\r\n//          or pItems == NULL or cMaxItems < 2.\r\n//\r\n//      Returns E_OUTOFMEMORY if the output buffer length (cMaxItems) is\r\n//          insufficient. Note that in this case, as in all error cases, no\r\n//          items have been fully processed so no part of the output array\r\n//          contains defined values.\r\n//\r\n//      If psControl and psState are NULL on entry, ScriptItemize\r\n//      breaks the unicode string purely by character code.  If they are all\r\n//      non-null, it performs a full Unicode bidi analysis.\r\n//\r\n//      ScriptItemize always adds a terminal item to the item analysis array\r\n//      (pItems) such that the length of an item at pItem is always available as:\r\n//\r\n//c     pItem[1].iCharPos - pItem[0].iCharPos\r\n//\r\n//      For this reason, it is invalid to call ScriptItemize with a buffer\r\n//      of less than two SCRIPT_ANALYSIS items.\r\n//\r\n//      To perform a correct Unicode Bidi analysis, the SCRIPT_STATE should\r\n//      be initialised according to the paragraph reading order at paragraph\r\n//      start, and ScriptItemize should be passed the whole paragraph.\r\n//\r\n//      fRTL and fNumeric together provide the same classification as\r\n//      the lpClass output from GetCharacterPlacement.\r\n//\r\n//      European digits U+0030 through U+0039 may be rendered as national\r\n//      digits as follows:\r\n//\r\n//t     fDigitSubstitute | FContextDigits | Digit shapes displayed for Unicode U+0030 through U+0039\r\n//t     ---------------- | -------------- | ------------------------------------\r\n//t     False            | Any            | Western (European / American) digits\r\n//t     True             | False          | As specified in SCRIPT_CONTROL.uDefaultLanguage\r\n//t     True             | True           | As prior strong text, defaulting to SCRIPT_CONTROL.uDefaultLanguage\r\n//\r\n//\r\n//      For fContextDigits, any Western digits (U+0030 - U+0039) encountered\r\n//      before the first strongly directed character are substituted by the\r\n//      traditional digits of the SCRIPT_CONTROL.uDefaultLanguage when that\r\n//      language is written in the same direction as SCRIPT_STATE.uBidiLevel.\r\n//\r\n//      Thus, in a right-to-left string, if SCRIPT_CONTROL.uDefaultLanguage is\r\n//      1 (LANG_ARABIC), then leading Western digits will be substituted by\r\n//      traditional Arabic digits.\r\n//\r\n//      However, also in a right-to-left string, if SCRIPT_CONTROL.uDefaultLanguage\r\n//      is 0x1e (LANG_THAI), then no substitution occurs on leading Western\r\n//      digits because the Thai language is written left-to-right.\r\n//\r\n//      Following strongly directed characters, digits are substituted\r\n//      by the traditional digits associated with the closest prior strongly\r\n//      directed character.\r\n//\r\n//      The left-to-right mark (LRM) and right-to-left mark (RLM) are strong\r\n//      characters whose language depends on the SCRIPT_CONTROL.uDefaultLangauge.\r\n//\r\n//      If SCRIPT_CONTROL.uDefaultLangauge is a left-to-right langauge, then\r\n//      LRM causes subsequent Western digits to be substituted by the\r\n//      traditional digits associated with that language, while Western\r\n//      digits following RLM are not substituted.\r\n//\r\n//      Conversly, if SCRIPT_CONTROL.uDefaultLangauge is a right-to-left\r\n//      langauge, then Western digits following LRM are not substituted, while\r\n//      Western digits following RLM are substituted by the traditional digits\r\n//      associated with that language.\r\n//\r\n//\r\n//\r\n//      Effect of Unicode control characters on SCRIPT_STATE:\r\n//\r\n//t     SCRIPT_STATE flag | Set by | Cleared by\r\n//t     ----------------- | ------   ----------\r\n//t     fDigitSubstitute  |  NADS  |   NODS\r\n//t     fInhibitSymSwap   |  ISS   |   ASS\r\n//t     fCharShape        |  AAFS  |   IAFS\r\n//\r\n//      SCRIPT_STATE.fArabicNumContext controls the Unicode EN->AN rule.\r\n//      It should normally be initialised to TRUE\r\n//      before itemizing an RTL paragraph in an Arabic language, FALSE\r\n//      otherwise.\r\n/////   ScriptLayout\r\n//\r\n//      The ScriptLayout function converts an array of run embedding levels to\r\n//      a map of visual to logical position, and/or logical to visual position.\r\n//\r\n//      pbLevel must contain the embedding levels for all runs on the line,\r\n//      ordered logically.\r\n//\r\n//      On output, piVisualToLogical[0] is the logical index of the run to\r\n//      display at the far left. Subsequent entries should be displayed\r\n//      progressing from left to right.\r\n//\r\n//      piLogicalToVisual[0] is the relative visual position where the first\r\n//      logical run should be displayed - the leftmost display position being zero.\r\n//\r\n//      The caller may request either piLogicalToVisual or piVisualToLogical\r\n//      or both.\r\n//\r\n//      Note: No other input is required since the embedding levels give all\r\n//      necessary information for layout.\r\n\r\n\r\nfunction ScriptLayout(\r\n    cRuns: Integer;               // In   Number of runs to process\r\n    const pbLevel: PByte;         // In   Array of run embedding levels\r\n    piVisualToLogical: PInteger;  // Out  List of run indices in visual order\r\n    piLogicalToVisual: PInteger   // Out  List of visual run positions\r\n ): HRESULT; stdcall;\r\n{$EXTERNALSYM ScriptLayout}\r\n\r\n\r\n\r\n\r\n\r\ntype\r\n\r\n  /////   SCRIPT_JUSTIFY\r\n  //\r\n  //      The script justification enumeration provides the client with the\r\n  //      glyph characteristic information it needs to implement justification.\r\n\r\n  PScriptJustify = ^TScriptJustify;\r\n  tag_SCRIPT_JUSTIFY = (\r\n    SCRIPT_JUSTIFY_NONE           {= 0},   // Justification can't be applied at this glyph\r\n    SCRIPT_JUSTIFY_ARABIC_BLANK   {= 1},   // This glyph represents a blank in an Arabic run\r\n    SCRIPT_JUSTIFY_CHARACTER      {= 2},   // Inter-character justification point follows this glyph\r\n    SCRIPT_JUSTIFY_RESERVED1      {= 3},   // Reserved #1\r\n    SCRIPT_JUSTIFY_BLANK          {= 4},   // This glyph represents a blank outside an Arabic run\r\n    SCRIPT_JUSTIFY_RESERVED2      {= 5},   // Reserved #2\r\n    SCRIPT_JUSTIFY_RESERVED3      {= 6},   // Reserved #3\r\n    SCRIPT_JUSTIFY_ARABIC_NORMAL  {= 7},   // Normal Middle-Of-Word glyph that connects to the right (begin)\r\n    SCRIPT_JUSTIFY_ARABIC_KASHIDA {= 8},   // Kashida(U+640) in middle of word\r\n    SCRIPT_JUSTIFY_ARABIC_ALEF    {= 9},   // Final form of Alef-like (U+627, U+625, U+623, U+632)\r\n    SCRIPT_JUSTIFY_ARABIC_HA      {= 10},  // Final form of Ha (U+647)\r\n    SCRIPT_JUSTIFY_ARABIC_RA      {= 11},  // Final form of Ra (U+631)\r\n    SCRIPT_JUSTIFY_ARABIC_BA      {= 12},  // Middle-Of-Word form of Ba (U+628)\r\n    SCRIPT_JUSTIFY_ARABIC_BARA    {= 13},  // Ligature of alike (U+628,U+631)\r\n    SCRIPT_JUSTIFY_ARABIC_SEEN    {= 14},  // Highest priority: Initial shape of Seen(U+633) (end)\r\n    SCRIPT_JUSTIFY_RESERVED4      {= 15}   // Reserved #4\r\n  );\r\n  SCRIPT_JUSTIFY = tag_SCRIPT_JUSTIFY;\r\n  {$EXTERNALSYM SCRIPT_JUSTIFY}\r\n  TScriptJustify = SCRIPT_JUSTIFY;\r\n\r\n\r\n\r\n  /////   SCRIPT_VISATTR\r\n  //\r\n  //      The visual (glyph) attribute buffer generated by ScriptShape\r\n  //      identifies clusters and justification points:\r\n\r\n  TScriptVisAttr_enum = (\r\n    uJustification_r1, uJustification_r2, uJustification_r3, uJustification_r4,\r\n    fClusterStart,     {:1}  // First glyph of representation of cluster\r\n    fDiacritic,        {:1}  // Diacritic\r\n    fZeroWidth,        {:1}  // Blank, ZWJ, ZWNJ etc, with no width\r\n    fReserved          {:1}  // General reserved\r\n  );\r\n  TScriptVisAttr_set = set of TScriptVisAttr_enum;\r\n\r\n  PScriptVisAttr = ^TScriptVisAttr;\r\n  tag_SCRIPT_VISATTR = packed record\r\n   case Byte of\r\n    0: (uJustification: Byte) {:4};  // Justification class\r\n    1: (fFlags: TScriptVisAttr_set;\r\n        fShapeReserved: Byte) {:8};  // Reserved for use by shaping engines\r\n  end;\r\n(*  uJustification: Word   {:4};  // Justification class\r\n    fClusterStart: Word    {:1};  // First glyph of representation of cluster\r\n    fDiacritic: Word       {:1};  // Diacritic\r\n    fZeroWidth: Word       {:1};  // Blank, ZWJ, ZWNJ etc, with no width\r\n    fReserved: Word        {:1};  // General reserved\r\n    fShapeReserved: Word   {:8};  // Reserved for use by shaping engines\r\n  end; *)\r\n  SCRIPT_VISATTR = tag_SCRIPT_VISATTR;\r\n  {$EXTERNALSYM SCRIPT_VISATTR}\r\n  TScriptVisAttr = SCRIPT_VISATTR;\r\n\r\nconst\r\n  MASK_uJustification = $F; // Mask to apply to TScriptVisAttr.uJustification\r\n\r\n//\r\n//\r\n//p     uJustification: Justification class for this glyph. See SCRIPT_JUSTIFY.\r\n//\r\n//p     fClusterStart: Set for the logically first glyph in every cluster,\r\n//          even for clusters containing just one glyph.\r\n//\r\n//p     fDiacritic: Set for glyphs that combine with base characters.\r\n//\r\n//p     fZeroWidth: Set by the shaping engine for some, but not all, zero\r\n//          width characters.\r\n\r\n\r\n/////   ScriptShape\r\n//\r\n//      The ScriptShape function takes a Unicode run and generates glyphs and\r\n//      visual attributes.\r\n//\r\n//      The number of glyphs generated varies according to the script and the\r\n//      font. Only for simple scripts and fonts does each Unicode code point\r\n//      generates a single glyph.\r\n//\r\n//      There is no limit on the number of glyphs generated by a codepoint.\r\n//      For example, a sophisticated complex script font might choose to\r\n//      constuct characters from components, and so generate many times as\r\n//      many glyphs as characters.\r\n//\r\n//      There are also special cases like invalid character representations,\r\n//      where extra glyphs are added to represent the invalid sequence.\r\n//\r\n//      A reasonable guess might be to provide a glyph buffer 1.5 times the\r\n//      length of the character buffer, plus a 16 glyph fixed addition for\r\n//      rare cases like invalid sequenece representation.\r\n//\r\n//      If ScriptShape returns E_OUTOFMEMORY it will be necessary to recall\r\n//      it, possibly more than once, until a large enough buffer is found.\r\n\r\n\r\nfunction ScriptShape(\r\n    hdc: HDC;                    // In    Optional (see under caching)\r\n    psc: PScriptCache;           // InOut Cache handle\r\n    const pwcChars: PWideChar;   // In    Logical unicode run\r\n    cChars: Integer;             // In    Length of unicode run\r\n    cMaxGlyphs: Integer;         // In    Max glyphs to generate\r\n    psa: PScriptAnalysis;        // InOut Result of ScriptItemize (may have fNoGlyphIndex set)\r\n    pwOutGlyphs: PWord;          // Out   Output glyph buffer\r\n    pwLogClust: PWord;           // Out   Logical clusters\r\n    psva: PScriptVisAttr;        // Out   Visual glyph attributes\r\n    pcGlyphs: PInteger           // Out   Count of glyphs generated\r\n ): HRESULT; stdcall;\r\n{$EXTERNALSYM ScriptShape}\r\n\r\n\r\n\r\n\r\n\r\n\r\n/////\r\n//\r\n//      Returns E_OUTOFMEMORY if the output buffer length (cMaxGlyphs) is\r\n//          insufficient. Note that in this case, as in all error cases, the\r\n//          content of all output parameters are undefined.\r\n//\r\n//p     psa: Pass the SCRIPT_ANALYSIS field of the SCRIPT_ITEM entry for this\r\n//          item. (The SCRIPT_ITEM array is returned by ScriptItemize.)\r\n//\r\n//      Clusters are sequenced uniformly within the run, as are glyphs within\r\n//      the cluster - the fRTL item flag (from ScriptItemize) identifies\r\n//      whether left to right, or right to left.\r\n//\r\n//p     pwLogClust: has cChars elements - each entry in pwLogClust corresponds\r\n//          to a character in the input string (pwcChars). The value in each\r\n//          pwLogCLust entry is the offset of the first glyph in the cluster\r\n//          that contains this character.\r\n//\r\n//      Example: In the following example, there are four clusters:\r\n//      1st cluster: one character represented by one glyph\r\n//      2nd cluster: one character represented by 3 glyphs\r\n//      3rd cluster: three characters represented by one glyph\r\n//      4th cluster: 2 characters represented by three glyphs\r\n//\r\n//      Glyph array: (cg means cluster n glyph m)\r\n//c        0      1    2    3      4      5    6    7\r\n//c     -------------------------------------------------\r\n//c     | c1g1 | c2g1 c2g2 c2g3 | c3g1 | c4g1 c4g2 c4g3 |\r\n//c     -------------------------------------------------\r\n//\r\n//      Character array: (cu means cluster n Unicode codepoint m)\r\n//c        0      1      2    3    4      5    6\r\n//c     --------------------------------------------\r\n//c     | c1u1 | c2u1 | c3u1 c3u2 c3u3 | c4u1 c4u2 |\r\n//c     --------------------------------------------\r\n//\r\n//      LogClust: (one entry per character gives 1st glyph in cluster\r\n//c     --------------------------------------------\r\n//c     |   0  |   1  |   4    4    4  |   5    5  |\r\n//c     --------------------------------------------\r\n//\r\n//      Note that for an RTL run (SCRIPT_ANALYSIS.a.fRTL == TRUE) and when\r\n//      fLogicalOrder == FALSE (the default), glyphs are generated in visual\r\n//      order - the reverse of the codepoint order, and the values in the\r\n//      LogClust array will be descending.\r\n//\r\n//\r\n//p     psva: has one visual attribute per glyph and so has maxGlyphs entries.\r\n//\r\n//\r\n//      ScriptShape may set the fNoGlyphIndex flag in psa if the font or\r\n//      OS cannot support glyph indices.\r\n//\r\n//      If fLogicalOrder is requested in psa, glyphs will be always be\r\n//      generated in the same order as the original Unicode characters.\r\n//\r\n//      If fLogicalOrder is not set, right to left items are generated in\r\n//      reverse order, so ScriptTextOut does not need to reverse them before\r\n//      calling ExtTextOut.\r\n/////   ScriptPlace\r\n//\r\n//      The ScriptPlace function takes the output of a ScriptShape call and\r\n//      generates glyph advance width and 2D offset information.\r\n//\r\n//      The composite ABC width for the whole item identifies how much the\r\n//      glyphs overhang to the left of the start position and to the right of\r\n//      the length implied by the sum of the advance widths.\r\n//\r\n//      The total advance width of the line is exactly abcA + abcB + abcC.\r\n//\r\n//      abcA and abcC are maintained internally by Uniscribe as proportions\r\n//      of the cell height represented in 8 bits and are thus roughly +/- 1%.\r\n//      The total width returned (as the sum of piAdvance, and as the sum of\r\n//      abcA+abcB+abcC) is accurate to the resolution of the TrueType shaping\r\n//      engine.\r\n//\r\n//      All glyph related arrays are in visual order unless the fLogicalOrder\r\n//      flag is set in psa.\r\n\r\ntype\r\n  PGOffset = ^TGOffset;\r\n  tagGOFFSET = record\r\n    du:  Longint;\r\n    dv:  Longint;\r\n  end;\r\n  GOFFSET = tagGOFFSET;\r\n  {$EXTERNALSYM GOFFSET}\r\n  TGOffset = tagGOFFSET;\r\n\r\n\r\nfunction ScriptPlace(\r\n    hdc: HDC;                   // In    Optional (see under caching)\r\n    psc: PScriptCache;          // InOut Cache handle\r\n    const pwGlyphs: PWord;      // In    Glyph buffer from prior ScriptShape call\r\n    cGlyphs: Integer;           // In    Number of glyphs\r\n    const psva: PScriptVisAttr; // In    Visual glyph attributes\r\n    psa: PScriptAnalysis;       // InOut Result of ScriptItemize (may have fNoGlyphIndex set)\r\n    piAdvance: PInteger;        // Out   Advance wdiths\r\n    pGoffset: PGOffset;         // Out   x,y offset for combining glyph\r\n    pABC: PABC                  // Out   Composite ABC for the whole run (Optional)\r\n ): HRESULT; stdcall;\r\n{$EXTERNALSYM ScriptPlace}\r\n\r\n\r\n\r\n\r\n\r\n\r\n/////   ScriptTextOut\r\n//\r\n//      The ScriptTextOut function takes the output of both ScriptShape and\r\n//      ScriptPlace calls and calls the operating system ExtTextOut function\r\n//      appropriately. If the last parameter is not null, GDI's ExtTextOutW calls\r\n//      are routed to this function.\r\n//\r\n//      All arrays are in visual order unless the fLogicalOrder flag is set in\r\n//      psa.\r\n\r\n\r\nfunction ScriptTextOut(\r\n    const hdc: HDC;                // In     OS handle to device context (required)\r\n    psc: PScriptCache;             // InOut  Cache handle\r\n    x: Integer;                    // In     x,y position for first glyph\r\n    y: Integer;                    // In\r\n    fuOptions: LongWord;           // In     ExtTextOut options\r\n    const lprc: PRect;             // In     optional clipping/opaquing rectangle\r\n    const psa: PScriptAnalysis;    // In     Result of ScriptItemize\r\n    const pwcReserved: PWideChar;  // In     Reserved (requires NULL)\r\n    iReserved: Integer;            // In     Reserved (requires 0)\r\n    const pwGlyphs: PWord;         // In     Glyph buffer from prior ScriptShape call\r\n    cGlyphs: Integer;              // In     Number of glyphs\r\n    const piAdvance: PInteger;     // In     Advance widths from ScriptPlace\r\n    const piJustify: PInteger;     // In     Justified advance widths (optional)\r\n    const pGoffset: PGOffset       // In     x,y offset for combining glyph\r\n ): HRESULT; stdcall;\r\n\r\n\r\n\r\n\r\n\r\n\r\n/////\r\n//\r\n//      The caller should normally use SetTextAlign(hdc, TA_RIGHT) before\r\n//      calling ScriptTextOut with an RTL item inlogical order.\r\n//\r\n//      The piJustify array provides requested cell widths for each glyph.\r\n//      When the piJustify width of a glyph differs from the unjustified\r\n//      width (in PiAdvance), space is added to or removed from the glyph\r\n//      cell at it's trailing edge. The glyph is always aligned with the\r\n//      leading edge of it's cell. (This rule applies even in visual order.)\r\n//\r\n//      When a glyph cell is extended the extra space is uaually made up by\r\n//      the addition of white space, however for Arabic scripts, the extra\r\n//      space is made up by one or more kashida glyphs, unless the extra space\r\n//      is insufficient for the shortest kashida glyph in the font. (The\r\n//      width of the shortest kashida is available by calling\r\n//      ScriptGetFontProperties.)\r\n//\r\n//      piJustify should only be passed if re-justification of the string is\r\n//      required. Normally pass NULL to this parameter.\r\n//\r\n//      fuOptions may contain ETO_CLIPPED or ETO_OPAQUE (or neither or both).\r\n//\r\n//      Do not use ScriptTextOut to write to a metafile unless you are sure\r\n//      that the metafile will eventually be played back without any font\r\n//      substitution. ScriptTextOut record glyph numbers in the metafile.\r\n//      Since glyph numbers vary considerably from one font to another\r\n//      such a metafile is unlikely to play back correctly when differant\r\n//      fonts are substituted.\r\n//\r\n//      For example when a metafile is played back at a different scale\r\n//      CreateFont requests recorded in the metafile may resolve to bitmap\r\n//      instead of truetype fonts, or if the metafile is played back on\r\n//      a different machine requested fonts may not be installed.//\r\n//\r\n//      To write complex scripts in a metafile in a font independant manner,\r\n//      use ExtTextOut to write the logical characters directly, so that\r\n//      glyph generation and placement does not occur until the text is\r\n//      played back.\r\n/////   ScriptJustify\r\n//\r\n//      ScriptJustify provides a simple minded implementation of multilingual\r\n//      justification.\r\n//\r\n//      Sophisticated text formatters may prefer to generate their own delta\r\n//      dx array by combining their own features with the information returned\r\n//      by ScriptShape in the SCRIPT_VISATTR array.\r\n//\r\n//      ScriptJustify establishes how much adjustment to make at each glyph\r\n//      position on the line. It interprets the SCRIPT_VISATTR array generated\r\n//      by a call to ScriptShape, and gives top priority to kashida, then uses\r\n//      inter word spacing if there's no kashida points, then uses\r\n//      intercharacter spacing if there are no inter-word points.\r\n//\r\n//      The justified advance widths generated in ScriptJustify should be\r\n//      passed to ScriptTextOut in the piJustify paramter.\r\n//\r\n//      ScriptJustify creates a justify array containing updated advance\r\n//      widths for each glyph. Where a glyphs advance width is increased, it\r\n//      is expected that the extra width will be rendered to the right of the\r\n//      glyph, with as white space or, for Arabic text, as kashida.\r\n/////\r\nfunction ScriptJustify(\r\n    const psva:  PScriptVisAttr;  // In   Collected visual attributes for entire line\r\n    const piAdvance: PInteger;    // In   Advance widths from ScriptPlace\r\n    cGlyphs: Integer;             // In   Size of all arrays\r\n    iDx: Integer;                 // In   Desired width change, either increase or descrease\r\n    iMinKashida: Integer;         // In   Minimum length of continuous kashida glyph to generate\r\n    piJustify: PInteger           // Out  Updated advance widths to pass to ScriptTextOut\r\n ): HRESULT; stdcall;\r\n\r\n\r\n\r\n\r\ntype\r\n  /////   SCRIPT_LOGATTR\r\n  //\r\n  //      The SCRIPT_LOGATTR structure describes attributes of logical\r\n  //      characters useful when editing and formatting text.\r\n  //\r\n  //      Note that for wordbreaking and linebreaking, if the first character of\r\n  //      the run passed in is not whitespace, the client needs to check whether\r\n  //      the last character of the previous run is whitespace to determine if\r\n  //      the first character of this run is the start of a word.\r\n  //\r\n  //\r\n  TScriptLogAttr_enum = (\r\n    fSoftBreak,  // Potential linebreak point\r\n    fWhiteSpace, // A unicode whitespace character, except NBSP, ZWNBSP\r\n    fCharStop,   // Valid cursor position (for left/right arrow)\r\n    fWordStop,   // Valid cursor position (for ctrl + left/right arrow)\r\n    fInvalid     // Invalid character sequence\r\n  );\r\n\r\n  PScriptLogAttr = ^TScriptLogAttr;\r\n  tag_SCRIPT_LOGATTR = set of TScriptLogAttr_enum;\r\n(*  fSoftBreak: Byte      {:1};     // Potential linebreak point\r\n    fWhiteSpace: Byte     {:1};     // A unicode whitespace character, except NBSP, ZWNBSP\r\n    fCharStop: Byte       {:1};     // Valid cursor position (for left/right arrow)\r\n    fWordStop: Byte       {:1};     // Valid cursor position (for ctrl + left/right arrow)\r\n    fInvalid: Byte        {:1};     // Invalid character sequence\r\n    fReserved: Byte       {:3;}\r\n  end; *)\r\n  {$EXTERNALSYM tag_SCRIPT_LOGATTR}\r\n  SCRIPT_LOGATTR = tag_SCRIPT_LOGATTR;\r\n  {$EXTERNALSYM SCRIPT_LOGATTR}\r\n  TScriptLogAttr = SCRIPT_LOGATTR;\r\n\r\n  \r\n//\r\n//\r\n//p     fSoftBreak: It would be valid to break the line in front of this\r\n//              character. This flag is set on the first character of\r\n//              South-East Asian words. Note that when linebreaking the\r\n//              client would usually also treat any nonblank following a blank\r\n//              as a softbreak position, by inspecting the fWhiteSPace flag\r\n//              below.\r\n//\r\n//p     fWhiteSpace: This character is one of the many Unicode character\r\n//              that are classified as breakable whitespace.\r\n//\r\n//p     fCharStop: Valid cursor position. Set on most characters, but not\r\n//              on codepoints inside Indian and South East Asian character\r\n//              clusters. May be used to implement left and right arrow\r\n//              operation in editors.\r\n//\r\n//p     fWordStop: Valid position following word advance/retire commonly\r\n//              implemented at ctrl/left-arrow and ctrl/right-arrow.\r\n//              May be used to implement ctrl+left and ctrl+right arrow\r\n//              operation in editors. As with fSoftBreak clients should\r\n//              normally also inspect the fWhiteSpace flag and treat the\r\n//              first character after a run of whitespace as the start of a\r\n//              word.\r\n//\r\n//p     fInvalid: Marks characters which form an invalid or undisplayable\r\n//              combination. Scripts which can set this flag have the flag\r\n//              fInvalidLogAttr set in their SCRIPT_PROPERTIES.\r\n\r\n\r\n\r\n\r\n\r\n\r\n/////   ScriptBreak\r\n//\r\n//      The ScriptBreak function returns cursor movement and formatting break\r\n//      positions for an item as an array of SCRIPT_LOGATTRs. To support\r\n//      mixed formatting within a single word correctly, ScriptBreak should\r\n//      be passed whole items as returned by ScriptItemize.\r\n//\r\n//      ScriptBreak does not require an hdc and does not execute glyph shaping.\r\n//\r\n//      The fCharStop flag marks cluster boundaries for those scripts where\r\n//      it is conventional to restrict from moving inside clusters. The same\r\n//      boundaries could also be inferred by inspecting the pLogCLust array\r\n//      returned by ScriptShape, however ScriptBreak is considerably faster in\r\n//      implementation and does not require an hdc to be prepared.\r\n//\r\n//      The fWordStop, fSoftBreak and fWhiteSpace flags are only available\r\n//      through ScriptBreak.\r\n//\r\n//      Most shaping engines that identify invalid sequences do so by setting\r\n//      the fInvalid flag in ScriptBreak. The fInvalidLogAttr flag in\r\n//      ScriptProperties identifies which scripts do this.\r\n\r\n\r\nfunction ScriptBreak(\r\n    const pwcChars: PWideChar;  // In   Logical unicode item\r\n    cChars: Integer;    // In   Length of unicode item\r\n    const psa: PScriptAnalysis;       // In   Result of earlier ScriptItemize call\r\n    psla: PScriptLogAttr     // Out  Logical character attributes\r\n ): HRESULT; stdcall;\r\n{$EXTERNALSYM ScriptBreak}\r\n\r\n\r\n\r\n\r\n\r\n/////   ScriptCPtoX\r\n//\r\n//      The ScriptCPtoX function returns the x offset from the left end\r\n//      (!fLogical) or leading edge (fLogical) of a run to either the leading\r\n//      or the trailing edge of a logical character cluster.\r\n//\r\n//      iCP is the offset of any logical character in the cluster.\r\n//\r\n//      For scripts where the caret may conventionally be placed into the\r\n//      middle of clusters (e.g. Arabic, Hebrew), the returned X may be\r\n//      an interpolated position for any codepoint in the line.\r\n//\r\n//      For scripts where the caret is conventionally snapped to the boundaries\r\n//      of clusters, (e.g. Thai, Indian), the resulting X position will be\r\n//      snapped to the requested edge of the cluster containing CP.\r\n\r\n\r\nfunction ScriptCPtoX(\r\n    iCP: Integer;               // In   Logical character position in run\r\n    fTrailing: BOOL;            // In   Which edge (default - leading)\r\n    cChars: Integer;            // In   Count of logical codepoints in run\r\n    cGlyphs: Integer;           // In   Count of glyphs in run\r\n    const pwLogClust: PWord;    // In   Logical clusters\r\n    const psva: PScriptVisAttr; // In   Visual glyph attributes array\r\n    const piAdvance: PInteger;  // In   Advance widths\r\n    const psa: PScriptAnalysis; // In   Script analysis from item attributes\r\n    piX: PInteger               // Out  Resulting X position\r\n ): HRESULT; stdcall;\r\n\r\n\r\n\r\n\r\n\r\n\r\n/////   ScriptXtoCP\r\n//\r\n//      The ScriptXtoCP function converts an x offset from the left end\r\n//      (!fLogical) or leading edge (fLogical) of a run to a logical\r\n//      character position and a flag that indicates whether the X position\r\n//      fell in the leading or the trailing half of the character.\r\n//\r\n//      For scripts where the cursor may conventionally be placed into the\r\n//      middle of clusters (e.g. Arabic, Hebrew), the returned CP may be\r\n//      for any codepoint in the line, and fTrailing will be either zero\r\n//      or one.\r\n//\r\n//      For scripts where the cursor is conventionally snapped to the\r\n//      boundaries of a cluster, the returned CP is always the position of\r\n//      the logically first codepoint in a cluster, and fTrailing is either\r\n//      zero, or the number of codepoints in the cluster.\r\n//\r\n//      Thus the appropriate cursor position for a mouse hit is always the\r\n//      returned CP plus the value of fTrailing.\r\n//\r\n//      If the X positition passed is not in the item at all, the resulting\r\n//      position will be the trailing edge of character -1 (for X positions\r\n//      before the item), or the leading edge of character 'cChars' (for\r\n//      X positions following the item).\r\n\r\n\r\nfunction ScriptXtoCP(\r\n    iX: Integer;                 // In   X offset from left of run\r\n    cChars: Integer;             // In   Count of logical codepoints in run\r\n    cGlyphs: Integer;            // In   Count of glyphs in run\r\n    const pwLogClust: PWord;     // In   Logical clusters\r\n    const psva: PScriptVisAttr;  // In   Visual glyph attributes\r\n    const piAdvance: Integer;    // In   Advance widths\r\n    const psa:  PScriptAnalysis; // In   Script analysis from item attributes\r\n    piCP: PInteger;              // Out  Resulting character position\r\n    piTrailing: PInteger         // Out  Leading or trailing half flag\r\n ): HRESULT; stdcall;\r\n\r\n\r\n\r\n\r\n\r\n\r\n/////   Relationship between caret positions, justifications points and clusters\r\n//\r\n//\r\n//t     Job                              | Uniscribe support\r\n//t     -------------------------------- | --------------------------------------------------------\r\n//t     Caret move by character cluster  | LogClust or VISATTR.fClusterStart or LOGATTR.fCharStop\r\n//t     Line breaking between characters | LogClust or VISATTR.fClusterStart or LOGATTR.fCharStop\r\n//t     Caret move by word               | LOGATTR.fWordStop\r\n//t     Line breaking between words      | LOGATTR.fWordStop\r\n//t     Justification                    | VISATTR.uJustification\r\n//\r\n//\r\n//\r\n/////   Character clusters\r\n//\r\n//      Character clusters are glyph sequences that cannot be split between\r\n//      lines.\r\n//\r\n//      Some languages (e.g. Thai, Indic) restrict caret placement to points\r\n//      betwen clusters. This applies both to keyboard initiated caret\r\n//      movement (e.g. cursor keys) and pointing and clicking with the mouse\r\n//      (hit testing).\r\n//\r\n//      Uniscribe provides cluster information in both the visual and logical\r\n//      attributes. If you've called ScriptShape you'll find the cluster\r\n//      information represented both by sequences of the same value in the\r\n//      pwLogClust array, and by the fClusterStart flag in the psva\r\n//      SCRIPT_VISATTR array.\r\n//\r\n//      ScriptBreak also returns the fCharStop flag in the SCRIPT_LOGATTR\r\n//      array to identify cluster positions.\r\n//\r\n//\r\n//\r\n/////   Word break points\r\n//\r\n//      Valid positions for moving the caret when moving in whole words are\r\n//      marked by the fWordStop flag returned by ScriptBreak.\r\n//\r\n//      Valid positions for breaking lines between words are marked by the\r\n//      fSoftBreak flag returned by ScriptBreak.\r\n//\r\n//\r\n//\r\n/////   Justification\r\n//\r\n//      Justification space or kashida should be inserted where identified by\r\n//      the uJustificaion field of the SCRIPT_VISATTR.\r\n//\r\n//      When performing inter-character justification, insert extra space\r\n//      only after glyphs marked with uJustify == SCRIPT_JUSTIFY_CHARACTER.\r\n//\r\n//\r\n//\r\n/////   Script specific processing\r\n//\r\n//      Uniscribe provides information about special processing for each\r\n//      script in the SCRIPT_PROPERTIES array.\r\n//\r\n//      Use the following code during initialisation to get a pointer to\r\n//      the SCRIPT_PROPERTIES array:\r\n//\r\n//c     const SCRIPT_PROPERTIES **g_ppScriptProperties; // Array of pointers to properties\r\n//c     int iMaxScript;\r\n//c     HRESULT hr;\r\n//\r\n//c     hr = ScriptGetProperties(&g_ppScriptProperties, &g_iMaxScript);\r\n//\r\n//      Then inspect the properties of the script of an item 'iItem' as follows:\r\n//\r\n//c     hr = ScriptItemize( ... , pItems, ... );\r\n//c     ...\r\n//c     if (g_ppScriptProperties[pItems[iItem].a.eScript]->fNeedsCaretInfo) {\r\n//c         // Use ScriptBreak to restrict the caret from entering clusters (for example).\r\n//c     }\r\n//\r\n//\r\n//      SCRIPT_PROPERTIES.fNeedsCaretInfo\r\n//\r\n//      Caret placement should be restricted to cluster\r\n//      edges for scripts such as Thai and Indian. The fNeedsCaretInfo flag\r\n//      in SCRIPT_PROPERTIES identifies such languages.\r\n//\r\n//      Note that ScriptXtoCP and ScriptCPtoX automatically apply caret\r\n//      placement restictions.\r\n//\r\n//\r\n//      SCRIPT_PROPERTIES.fNeedsWordBreaking\r\n//\r\n//      For most scripts, word break placement  may be\r\n//      identified by scanning for characters marked as fWhiteSpace in\r\n//      SCRIPT_LOGATTR, or for glyphs marked as uJustify ==\r\n//      SCRIPT_JUSTIFY_BLANK or SCRIPT_JUSTIFY_ARABIC_BLANK in SCRIPT_VISATTR.\r\n//\r\n//      For languages such as Thai, it is also necessary to call ScriptBreak,\r\n//      and include character positions marked as fWordStop in SCRIPT_LOGATTR.\r\n//      Such scripts are marked as fNeedsWordbreaking in SCRIPT_PROPERTIES.\r\n//\r\n//\r\n//      SCRIPT_PROPERTIES.fNeedsCharacterJustify\r\n//\r\n//      Languages such as Thai also require inter-character spacing when\r\n//      justifying (where uJustify == SCRIPT_JUSTIFY_CHARACTER in the\r\n//      SCRIPT_VISATTR). Such languages are marked as fNeedsCharacterJustify\r\n//      in SCRIPT_PROPERTIES.\r\n//\r\n//\r\n//      SCRIPT_PROPERTIES.fAmbiguousCharSet\r\n//\r\n//      Many Uniscribe scripts do not correspond directly to 8 bit character\r\n//      sets. For example Unicode characters in the range U+100 through U+024F\r\n//      represent extended latin shapes used for many languages, including\r\n//      those supported by EASTEUROPE_CHARSET, TURKISH_CHARSET and\r\n//      VIETNAMESE_CHARSET. However many of these characters are supported by\r\n//      more han one of thsese charsets.\r\n//      fAmbiguousCharset is set for any script token which could contain\r\n//      characters from a number of these charsets. In these cases the bCharSet\r\n//      field may contain ANSI_CHARSET or DEFAULT_CHARSET. The Uniscribe client\r\n//      will generally need to apply futher processing to determine which charset\r\n//      to use when requesting a font suitable for this run. For example it\r\n//      determine that the run consists of multiple languages and split it up\r\n//      to use a different font for each language.\r\n\r\n\r\n\r\n\r\n\r\n\r\n/////   Notes on ScriptXtoCP and ScriptCPtoX\r\n//\r\n//      Both functions work only within runs and require the results of a\r\n//      previous ScriptShape call.\r\n//\r\n//      The client must establish which run a given cursor offset or x\r\n//      position is within before passing it to ScriptCPtoX or ScriptXtoCP.\r\n//\r\n//      Cluster information in the logical cluster array is used to share\r\n//      the width of a cluster of glyphs equally among the logical characters\r\n//      they represent.\r\n//\r\n//      For example, the lam alif glyph is divided into four areas: the\r\n//      leading half of the lam, the trailing half of the lam, the leading\r\n//      half of the alif and the trailing half of the alif.\r\n//\r\n//      ScriptXtoCP Understands the caret position conventions of each script.\r\n//      For Indian and Thai, caret positions are snapped to cluster boundaries,\r\n//      for Arabic and Hebrew, caret positions are interpolated within clusters.\r\n//\r\n//\r\n/////   Translating mouse hit 'x' offset to caret position\r\n//\r\n//      Conventionally, caret position 'cp' may be selected by clicking either\r\n//      on the trailing half of character 'cp-1' or on the leading half of\r\n//      character 'cp'. This may easily be implemented as follows:\r\n//\r\n//c     int iCharPos;\r\n//c     int iCaretPos\r\n//c     int fTrailing;\r\n//\r\n//c     ScriptXtoCP(iMouseX, ..., &iCharPos, &fTrailing);\r\n//c     iCaretPos = iCharPos + fTrailing;\r\n//\r\n//      For scripts that snap the caret to cluster boundaries, ScriptXtoCP\r\n//      returns ftrailing set to either 0, or the width of the cluster in\r\n//      codepoints. Thus the above code correctly returns only valid\r\n//      caret positions.\r\n//\r\n//\r\n/////   Displaying the caret in bidi strings\r\n//\r\n//      In unidirectional text, the leading edge of a character is at the same\r\n//      place as the trailing edge of the previous character, so there is no\r\n//      ambiguity in placing the caret between characters.\r\n//\r\n//      In bidirectional text, the caret position between runs of opposing\r\n//      direction may be ambiguous.\r\n//\r\n//      For example in the left to right paragraph 'helloMAALAS', the last\r\n//      letter of 'hello' immediately preceeds the first letter of 'salaam'.\r\n//      The best position to display the caret depends on whether it is\r\n//      considered to follow the 'o' of 'hello', or to preceed the 's' of\r\n//      'salaam'.\r\n//\r\n/////   Commonly used caret positioning conventions\r\n//\r\n//t     Situation       | Visual caret placement\r\n//t     ---------       | -------------------------------------------\r\n//t     Typing          | Trailing edge of last character typed\r\n//t     Pasting         | Trailing edge of last character pasted\r\n//t     Caret advancing | Trailing edge of last character passed over\r\n//t     Caret retiring  | Leading edge of last character passed over\r\n//t     Home            | Leading edge of line\r\n//t     End             | Trailing edge of line\r\n//\r\n//      The caret may be positioned as follows:\r\n//\r\n//c     if (advancing) {\r\n//c         ScriptCPtoX(iCharPos-1, TRUE, ..., &iCaretX);\r\n//c     } else {\r\n//c         ScriptCPtoX(iCharPos, FALSE, ..., &iCaretX);\r\n//c     }\r\n//\r\n//      Or, more simply, given an fAdvancing BOOL restricted to TRUE or FALSE:\r\n//\r\n//c     ScriptCPtoX(iCharPos-fAdvancing, fAdvancing, ..., &iCaretX);\r\n//\r\n//      ScriptCPtoX handles out of range positions logically: it returns the\r\n//      leading edge of the run for iCharPos <0, and the trailing edge of the\r\n//      run for iCharPos >=length.\r\n/////   ScriptGetLogicalWidths\r\n//\r\n//      Converts visual withs in piAdvance into logical widths,\r\n//      one per original character, in logical order.\r\n//\r\n//      Ligature glyphs widths are divided evenly amongst the characters\r\n//      they represent.\r\n\r\n\r\nfunction ScriptGetLogicalWidths(\r\n    const psa: PScriptAnalysis;     // In   Script analysis from item attributes\r\n    cChars: Integer;                // In   Count of logical codepoints in run\r\n    cGlyphs: Integer;               // In   Count of glyphs in run\r\n    const piGlyphWidth: PInteger;   // In   Advance widths\r\n    const pwLogClust: PWord;        // In   Logical clusters\r\n    const psva: PScriptVisAttr;     // In   Visual glyph attributes\r\n    piDx: PInteger                  // Out  Logical widths\r\n ): HRESULT; stdcall;\r\n\r\n\r\n\r\n\r\n\r\n\r\n/////\r\n//      ScriptGetLogicalWidths is useful for recording widths in a\r\n//      font independant manner. By passing the recorded logical widths\r\n//      to ScriptApplyLogicalWidths, a block of text can be replayed in the\r\n//      same boundaries with acceptable loss of quality even when the original\r\n//      font is not available.\r\n/////   ScriptApplyLogicalWidth\r\n//\r\n//      Accepts an array of advance widths in logical order, corresponding\r\n//      one to one with codepoints, and generates an array of glyph widths\r\n//      suitable for passing to the piJustify parameter of ScriptTextOut.\r\n//\r\n//      ScriptApplyLogicalWidth may be used to reapply logical widths\r\n//      obtained with ScriptGetLogicalWidths. It may be useful in situations\r\n//      such as metafiling, where it is necessary to record and reapply\r\n//      advance width information in a font independant manner.\r\n\r\n\r\n\r\nfunction ScriptApplyLogicalWidth(\r\n    const piDx: PInteger;        // In     Logical dx array to apply\r\n    cChars: Integer;             // In     Count of logical codepoints in run\r\n    cGlyphs: Integer;            // In     Glyph count\r\n    const pwLogClust: PWORD;     // In     Logical clusters\r\n    const psva: PScriptVisAttr;  // In     Visual attributes from ScriptShape/Place\r\n    const piAdvance: PInteger;   // In     Glyph advance widths from ScriptPlace\r\n    const psa:  PScriptAnalysis; // In     Script analysis from item attributes\r\n    pABC: PABC;                  // InOut  Updated item ABC width (optional)\r\n    piJustify: PInteger          // Out    Resulting glyph advance widths for ScriptTextOut\r\n ): HRESULT; stdcall;\r\n\r\n\r\n\r\n\r\n\r\n\r\n/////\r\n//p     piDx: Pointer to an array of dx widths in logical order, one per codepoint.\r\n//\r\n//p     cChars: Count of the logical codepoints in the run.\r\n//\r\n//p     cGlyphs: Glyph count.\r\n//\r\n//p     pwLogClust: Pointer to an array of logical clusters from ScriptShape\r\n//\r\n//p     psva: Pointer to an array of visual attributes from ScriptShape and\r\n//          updated by ScriptPlace.\r\n//\r\n//p     piAdvance: Pointer to an array of glyph advance widths from ScriptPlace.\r\n//\r\n//p     psa: Pointer to a SCRIPT_ANALYSIS structure from ScriptItemize and\r\n//          updated by ScriptShape and SriptPlace..\r\n//\r\n//p     pABC: Pointer to the run overall ABC width (optional). If present,\r\n//          when the function is called, it should contain the run ABC width\r\n//          returned by ScriptPlace; when the function returns, the ABC width\r\n//          has been updated to match the new widths.\r\n//\r\n//p     piJustify:Pointer to an array of the resulting glyph advance widths.\r\n//          This is suitable for passing to the piJustify parameter of ScriptTextOut.\r\n/////   ScriptGetCMap\r\n//\r\n//      ScriptGetCMap may be used to determine which characters in a run\r\n//      are supported by the selected font.\r\n//\r\n//      It returns glyph indices of Unicode characters according to Truetype\r\n//      Cmap table, or standard Cmap implemented for old style fonts. The\r\n//      glyph indices are returned in the same order as the input string.\r\n//\r\n//      The caller may scan the returned glyph buffer looking for the default\r\n//      glyph to determine which characters are not available. (The default\r\n//      glyph index for the selected font should be determined by calling\r\n//      ScriptGetFontProperties).\r\n//\r\n//      The return value indicates the presence of any missing glyphs.\r\n\r\nconst\r\n  SGCM_RTL  = $00000001;      // Return mirrored glyph for mirrorable Unicode codepoints\r\n\r\n\r\nfunction ScriptGetCMap(\r\n    hdc: HDC;                     // In    Optional (see notes on caching)\r\n    psc: PScriptCache;            // InOut Address of Cache handle\r\n    const pwcInChars: PWideChar;  // In    Unicode codepoint(s) to look up\r\n    cChars: Integer;              // In    Number of characters\r\n    dwFlags: DWORD;               // In    Flags such as SGCM_RTL\r\n    pwOutGlyphs: PWord            // Out   Array of glyphs, one per input character\r\n ): HRESULT; stdcall;\r\n\r\n\r\n\r\n\r\n\r\n/////\r\n//  returns S_OK     - All unicode codepoints were present in the font\r\n//          S_FALSE  - Some of the Unicode codepoints were mapped to the default glyph\r\n//          E_HANDLE - font or system does not support glyph indices\r\n/////   ScriptGetGlyphABCWidth\r\n//\r\n//      Returns ABC width of a given glyph.\r\n//      May be useful for drawing glyph charts. Should not be used for\r\n//      run of the mill complex script text formatting.\r\n\r\n\r\nfunction ScriptGetGlyphABCWidth(\r\n    hdc: HDC;            // In    Optional (see notes on caching)\r\n    psc: PScriptCache;   // InOut Address of Cache handle\r\n    wGlyph: Word;        // In    Glyph\r\n    pABC: PABC           // Out   ABC width\r\n ): HRESULT; stdcall;\r\n\r\n\r\n\r\n\r\n\r\ntype\r\n  /////\r\n  //  returns S_OK     - Glyph width returned\r\n  //          E_HANDLE - font or system does not support glyph indices\r\n  /////   SCRIPT_PROPERTIES\r\n  //\r\n\r\n  TScriptProperties_enum = (\r\n    fNumeric,              {:1}\r\n    fComplex,              {:1}  // Script requires special shaping or layout\r\n    fNeedsWordBreaking,    {:1}  // Requires ScriptBreak for word breaking information\r\n    fNeedsCaretInfo,       {:1}  // Requires caret restriction to cluster boundaries\r\n    bCharSet,              {:8}  // Charset to use when creating font\r\n    fControl,              {:1}  // Contains only control characters\r\n    fPrivateUseArea,       {:1}  // This item is from the Unicode range U+E000 through U+F8FF\r\n    fNeedsCharacterJustify,{:1}  // Requires inter-character justification\r\n    fInvalidGlyph,         {:1}  // Invalid combinations generate glyph wgInvalid in the glyph buffer\r\n    fInvalidLogAttr,       {:1}  // Invalid combinations are marked by fInvalid in the logical attributes\r\n    fCDM,                  {:1}  // Contains Combining Diacritical Marks\r\n    fAmbiguousCharSet,     {:1}  // Script does not correspond 1//:1 with a charset\r\n    fClusterSizeVaries,    {:1}  // Measured cluster width depends on adjacent clusters\r\n    fRejectInvalid         {:1}  // Invalid combinations should be rejected\r\n  );\r\n  TScriptProperties_set = set of TScriptProperties_enum;\r\n\r\n  PScriptProperties = ^TScriptProperties;\r\n  SCRIPT_PROPERTIES = packed record\r\n    langid: Word                  {:16}; // Primary and sublanguage associated with script\r\n    fFlags: TScriptProperties_set;\r\n  end;\r\n(*  langid: DWORD                 {:16}; // Primary and sublanguage associated with script\r\n    fNumeric: DWORD               {:1};\r\n    fComplex: DWORD               {:1};  // Script requires special shaping or layout\r\n    fNeedsWordBreaking: DWORD     {:1};  // Requires ScriptBreak for word breaking information\r\n    fNeedsCaretInfo: DWORD        {:1};  // Requires caret restriction to cluster boundaries\r\n    bCharSet: DWORD               {:8};  // Charset to use when creating font\r\n    fControl: DWORD               {:1};  // Contains only control characters\r\n    fPrivateUseArea: DWORD        {:1};  // This item is from the Unicode range U+E000 through U+F8FF\r\n    fNeedsCharacterJustify: DWORD {:1};  // Requires inter-character justification\r\n    fInvalidGlyph: DWORD          {:1};  // Invalid combinations generate glyph wgInvalid in the glyph buffer\r\n    fInvalidLogAttr: DWORD        {:1};  // Invalid combinations are marked by fInvalid in the logical attributes\r\n    fCDM: DWORD                   {:1};  // Contains Combining Diacritical Marks\r\n    fAmbiguousCharSet: DWORD      {:1};  // Script does not correspond 1//:1 with a charset\r\n    fClusterSizeVaries: DWORD     {:1};  // Measured cluster width depends on adjacent clusters\r\n    fRejectInvalid: DWORD         {:1};  // Invalid combinations should be rejected\r\n  end; *)\r\n  {$EXTERNALSYM SCRIPT_PROPERTIES}\r\n  TScriptProperties = SCRIPT_PROPERTIES;\r\n  \r\n//\r\n//p     langid: Language associated with this script. When a script is used for many languages,\r\n//          langid id represents a default language. For example, Western script is represented\r\n//          by LANG_ENGLISH although it is also used for French, German, Spanish etc.\r\n//\r\n//p     fNumeric: Script contains numerics and characters used in conjunction with numerics\r\n//          by the rules of the Unicode bidirectional algorithm. For example\r\n//          dollar sign and period are classified as numeric when adjacent to or in between\r\n//          digits.\r\n//\r\n//p     fComplex: Indicates a script that requires complex script handling. If fComplex is false\r\n//          the script contains no combining characters and requires no contextual shaping or reordering.\r\n//\r\n//p     fNeedsWordBreaking: A script, such as Thai, which requires algorithmic wordbreaking.\r\n//          Use ScriptBreak to obtain a wordbreak points using the standard system wordbreaker.\r\n//\r\n//p     fNeedsCaretInfo: A script, such as Thai and Indian, where the caret may not be placed\r\n//          inside a cluster. To determine valid caret positions inspect the fCharStop flag in the\r\n//          logical attributes returned by ScriptBreak, or compare adjacent values in the pwLogClust\r\n//          array returned by ScriptShape.\r\n//\r\n//p     bCharSet: Nominal charset associated with script. May be used in a logfont when creating\r\n//          a font suitable for displaying this script. Note that for new scripts where there\r\n//          is no charset defined, bCharSet may be innapropriate and DEFAULT_CHARSET should\r\n//          be used instead - see the description of fAmbiguousCharSet below.\r\n//\r\n//p     fControl: contains control characters.\r\n//\r\n//p     fPrivateUseArea: The Unicode range U+E000 through U+F8FF.\r\n//\r\n//p     fNeedsCharacterJustify: A script, such as Thai, where justification is conventionally\r\n//          achieved by increasing the space between all letters, not just between words.\r\n//\r\n//p     fInvalidGlyph: A script for which ScriptShape generates an invalid glyph\r\n//          to represent invalid sequences. The glyph index of the invalid glyph for\r\n//          a particular font may be obtained by calling ScriptGetFontProperties.\r\n//\r\n//p     fInvalidLogAttr: A script for which ScriptBreak sets the fInvalid flag\r\n//          in the logical attributes to mark invalid sequences.\r\n//\r\n//p     fCDM: Implies that an item analysed by ScriptItemize included combining\r\n//          diacritical marks (U+0300 through U+36F).\r\n//\r\n//p     fAmbiguousCharSet: No single legacy charset supports this script.\r\n//          For example the extended Latin Extended-A Unicode range includes\r\n//          characters from the EASTUROPE_CHARSET, the TURKISH_CHARSET and the\r\n//          BALTIC_CHARSET. It also contains characters that are not available\r\n//          in any legacy charset. Use DEFAULT_CHARSET when creating fonts to\r\n//          display parts of this run.\r\n//\r\n//p     fClusterSizeVaries: A script, such as Arabic, where contextual shaping\r\n//          may cause a string to increase in size when removing characters.\r\n//\r\n//p     fRejectInvalid: A script, such as Thai, where invalid sequences conventionally\r\n//          cause an editor such as notepad to beep, and ignore keypresses.\r\n\r\n\r\n/////   ScriptGetProperties\r\n//\r\n//      ScriptGetProperties returns the address of a table that maps a\r\n//      script in a SCRIPT_ANALYSIS uScript field to properties including\r\n//      the primary language associated with that script, whether it's\r\n//      numeric and whether it's complex.\r\n\r\n\r\nfunction ScriptGetProperties(\r\n    out ppSp: PScriptProperties;   // Out  Receives pointer to table of pointers to properties indexed by script\r\n    out piNumScripts: Integer      // Out  Receives number of scripts (valid values are 0 through NumScripts-1)\r\n ): HRESULT; stdcall;\r\n\r\n\r\n\r\n\r\n\r\ntype\r\n  /////   SCRIPT_FONTPROPERTIES\r\n  //\r\n  PScriptFontProperties = ^TScriptFontProperties;\r\n  SCRIPT_FONTPROPERTIES = record\r\n    cBytes: Integer;      // Structure length\r\n    wgBlank: Word;        // Blank glyph\r\n    wgDefault: Word;      // Glyph used for Unicode values not present in the font\r\n    wgInvalid: Word;      // Glyph used for invalid character combinations (especially in Thai)\r\n    wgKashida: Word;      // Shortest continuous kashida glyph in the font, -1 if doesn't exist\r\n    iKashidaWidth: Integer;// Widths of shortest continuous kashida glyph in the font\r\n  end;\r\n  {$EXTERNALSYM SCRIPT_FONTPROPERTIES}\r\n  TScriptFontProperties = SCRIPT_FONTPROPERTIES;\r\n\r\n\r\n/////   ScriptGetFontProperties\r\n//\r\n//      Returns information from the font cache\r\n\r\n\r\nfunction ScriptGetFontProperties(\r\n    hdc: HDC;                    // In    Optional (see notes on caching)\r\n    psc: PScriptCache;           // InOut Address of Cache handle\r\n    sfp:  PScriptFontProperties  // Out   Receives properties for this font\r\n ): HRESULT; stdcall;\r\n\r\n\r\n\r\n\r\n\r\n\r\n/////   ScriptCacheGetHeight\r\n//\r\n//\r\n\r\n\r\nfunction ScriptCacheGetHeight(\r\n    hdc: HDC;            // In    Optional (see notes on caching)\r\n    psc: PScriptCache;   // InOut Address of Cache handle\r\n    tmHeight: PLongint   // Out   Receives font height in pixels\r\n ): HRESULT; stdcall;\r\n\r\n\r\n\r\n\r\nconst\r\n  /////   ScriptStringAnalyse\r\n  //\r\n  //\r\n  SSA_PASSWORD         = $00000001;  // Input string contains a single character to be duplicated iLength times\r\n  SSA_TAB              = $00000002;  // Expand tabs\r\n  SSA_CLIP             = $00000004;  // Clip string at iReqWidth\r\n  SSA_FIT              = $00000008;  // Justify string to iReqWidth\r\n  SSA_DZWG             = $00000010;  // Provide representation glyphs for control characters\r\n  SSA_FALLBACK         = $00000020;  // Use fallback fonts\r\n  SSA_BREAK            = $00000040;  // Return break flags (character and word stops)\r\n  SSA_GLYPHS           = $00000080;  // Generate glyphs, positions and attributes\r\n  SSA_RTL              = $00000100;  // Base embedding level 1\r\n  SSA_GCP              = $00000200;  // Return missing glyphs and LogCLust with GetCharacterPlacement conventions\r\n  SSA_HOTKEY           = $00000400;  // Replace '&' with underline on subsequent codepoint\r\n  SSA_METAFILE         = $00000800;  // Write items with ExtTextOutW Unicode calls, not glyphs\r\n  SSA_LINK             = $00001000;  // Apply FE font linking/association to non-complex text\r\n  SSA_HIDEHOTKEY       = $00002000;  // Remove first '&' from displayed string\r\n  SSA_HOTKEYONLY       = $00002400;  // Display underline only.\r\n\r\n  SSA_FULLMEASURE      = $04000000;  // Internal - calculate full width and out the number of chars can fit in iReqWidth.\r\n  SSA_LPKANSIFALLBACK  = $08000000;  // Internal - enable FallBack for all LPK Ansi calls Except BiDi hDC calls\r\n  SSA_PIDX             = $10000000;  // Internal\r\n  SSA_LAYOUTRTL        = $20000000;  // Internal - Used when DC is mirrored\r\n  SSA_DONTGLYPH        = $40000000;  // Internal - Used only by GDI during metafiling - Use ExtTextOutA for positioning\r\n  SSA_NOKASHIDA        = $80000000;  // Internal - Used by GCP to justify the non Arabic glyphs only.\r\n//\r\n//\r\n//p     SSA_HOTKEY: Note that SSA_HOTKEY and SSA_HIDEHOTKEY remove the\r\n//          hotkey '&' character from further processing, so functions\r\n//          such as ScriptString_pLogAttr return arrays based on a string\r\n//          which excludes the '&'.\r\n\r\n\r\n\r\ntype\r\n  /////   SCRIPT_TABDEF\r\n  //\r\n  //      Defines tabstop positions for ScriptStringAnalyse (ignored unless SSA_TAB passed)\r\n  //\r\n  PScriptTabDef = ^TScriptTabDef;\r\n  tag_SCRIPT_TABDEF = record\r\n    cTabStops: Integer;        // Number of entries in pTabStops array\r\n    iScale: Integer;           // Scale factor for pTabStops (see below)\r\n    pTabStops: PInteger;       // Pointer to array of one or more tab stops\r\n    iTabOrigin: Integer;       // Initial offset for tab stops (logical units)\r\n  end;\r\n  {$EXTERNALSYM tag_SCRIPT_TABDEF}\r\n  SCRIPT_TABDEF = tag_SCRIPT_TABDEF;\r\n  {$EXTERNALSYM SCRIPT_TABDEF}\r\n  TScriptTabDef = tag_SCRIPT_TABDEF;\r\n\r\n//\r\n//\r\n//p     cTabStops: Number of entries in the pTabStops array. If zero, tabstops\r\n//          are every 8 average character widths. If one, all tabstops are\r\n//          the length of the first entry in pTabStops. If more than one,\r\n//          the first cTabStops are as specified in the pTabStops array,\r\n//          subsequent tabstops are every 8 average characters from the last\r\n//          tabstop in the array.\r\n//\r\n//p     iScale: Scale factor for iTabOrigin and pTabStops entries. Values are\r\n//          converted to device coordinates by multiplying by iScale then\r\n//          dividing by 4. If values are already in device units, set iScale to\r\n//          4. If values are in dialog units, set iScale to the average char\r\n//          width of the dialog font. If values are multiples of the average\r\n//          character width for the selected font, set iScale to 0.\r\n//\r\n//p     pTabStops: Array of cTabStops entries. Each entry specifies a\r\n//          tabstop position. Positive values give nearedge alignment,\r\n//          negative values give faredge alignment.\r\n//\r\n//p     iTabOrigin: Tabs are considered to start iTabOrigin before the\r\n//          beginning of the string. Helps with multiple tabbed\r\n//          outputs on the same line.\r\n\r\n\r\n\r\n\r\n\r\n\r\n/////   ScriptStringAnalyse\r\n//\r\n//      cString - Input string must contain at least one character\r\n//\r\n//      hdc - required if SSA_GLYPH requested. Optional for SSA_BREAK.\r\n//      If present the current font in the hdc is inspected and if a symbolic\r\n//      font the character string is treated as a single neutral SCRIPT_UNDEFINED item.\r\n//\r\n//      Note that the uBidiLevel field in the initial SCRIPT_STATE value\r\n//      is ignored - the uBidiLevel used is derived from the SSA_RTL\r\n//      flag in combination with the layout of the hdc.\r\n\r\n\r\n  SCRIPT_STRING_ANALYSIS = Pointer;\r\n  {$EXTERNALSYM SCRIPT_STRING_ANALYSIS}\r\n  TScriptStringAnalysis = SCRIPT_STRING_ANALYSIS;\r\n  PScriptStringAnalysis = ^TScriptStringAnalysis;\r\n\r\n\r\nfunction ScriptStringAnalyse(\r\n    hdc: HDC;                  //In  Device context (required)\r\n    const pString: Pointer;    //In  String in 8 or 16 bit characters\r\n    cString: Integer;          //In  Length in characters (Must be at least 1)\r\n    cGlyphs: Integer;          //In  Required glyph buffer size (default cString*1.5 + 16)\r\n    iCharset: Integer;         //In  Charset if an ANSI string, -1 for a Unicode string\r\n    dwFlags: DWORD;            //In  Analysis required\r\n    iReqWidth: Integer;        //In  Required width for fit and/or clip\r\n    psControl: PScriptControl; //In  Analysis control (optional)\r\n    psState: PScriptState;     //In  Analysis initial state (optional)\r\n    const piDx: PInteger;      //In  Requested logical dx array\r\n    pTabdef: PScriptTabDef;    //In  Tab positions (optional)\r\n    const pbInClass: PByte;    //In  Legacy GetCharacterPlacement character classifications (deprecated)\r\n\r\n    pssa:  PScriptStringAnalysis //Out Analysis of string\r\n ): HRESULT; stdcall;\r\n\r\n\r\n\r\n\r\n\r\n\r\n/////   ScriptStringFree - free a string analysis\r\n//\r\n//\r\n\r\n\r\nfunction ScriptStringFree(\r\n    pssa: PScriptStringAnalysis  //InOut Address of pointer to analysis\r\n ): HRESULT; stdcall;\r\n\r\n\r\n\r\n\r\n\r\n\r\n/////   ScriptStringSize\r\n//\r\n//      returns a pointer to the size (width and height) of an analysed string\r\n//\r\n//      Note that the SIZE pointer remains valid only until the\r\n//      SCRIPT_STRING_ANALYSIS is passed to ScriptStringFree.\r\n\r\n\r\nfunction ScriptString_pSize(\r\n    ssa: TScriptStringAnalysis\r\n ): {const} PSize; stdcall;\r\n\r\n\r\n\r\n\r\n\r\n\r\n/////   ScriptString_pcOutChars\r\n//\r\n//      returns pointer to length of string after clipping (requires SSA_CLIP set)\r\n//\r\n//      Note that the int pointer remains valid only until the\r\n//      SCRIPT_STRING_ANALYSIS is passed to ScriptStringFree.\r\n\r\n\r\nfunction ScriptString_pcOutChars(\r\n    ssa: TScriptStringAnalysis\r\n ): {const} PInteger; stdcall;\r\n\r\n\r\n\r\n\r\n\r\n\r\n/////   ScriptString_pLogAttr\r\n//\r\n//      returns pointer to logical attributes buffer in a SCRIPT_STRING_ANALYSIS\r\n//\r\n//      Note that the buffer pointer remains valid only until the\r\n//      SCRIPT_STRING_ANALYSIS is passed to ScriptStringFree.\r\n//\r\n//      The logical attribute array contains *ScriptString_pcOutChars(ssa)\r\n//      entries.\r\n\r\n\r\nfunction ScriptString_pLogAttr(\r\n    ssa: TScriptStringAnalysis\r\n ): {const} PScriptLogAttr; stdcall;\r\n\r\n\r\n\r\n\r\n\r\n\r\n/////   ScriptStringGetOrder\r\n//\r\n//      Creates an array mapping original character position to glyph position.\r\n//\r\n//      Treats clusters as they were in legacy systems - Unless a cluster\r\n//      contains more glyphs than codepoints, each glyph is referenced at\r\n//      least once from the puOrder array.\r\n//\r\n//      Requires SSA_GLYPHS requested in original ScriptStringAnalyse call.\r\n//\r\n//      The puOrder parameter should address a buffer containing room for\r\n//      at least *ScriptString_pcOutChars(ssa) ints.\r\n\r\n\r\nfunction ScriptStringGetOrder(\r\n    ssa: TScriptStringAnalysis;\r\n    puOrder: PLongWord\r\n ): HRESULT; stdcall;\r\n\r\n\r\n\r\n\r\n\r\n\r\n/////   ScriptStringCPtoX\r\n//\r\n//      Return x coordinate for leading or trailing edge of character icp.\r\n\r\n\r\nfunction ScriptStringCPtoX(\r\n    ssa: TScriptStringAnalysis;        //In  String analysis\r\n    icp: Integer;                      //In  Caret character position\r\n    fTrailing: BOOL;                   //In  Which edge of icp\r\n    out pX: Integer                    //Out Corresponding x offset\r\n ): HRESULT; stdcall;\r\n\r\n\r\n\r\n\r\n\r\n/////   ScriptStringXtoCP\r\n//\r\n//\r\n\r\n\r\nfunction ScriptStringXtoCP(\r\n    ssa: TScriptStringAnalysis;        // In\r\n    iX: Integer;                       // In\r\n    piCh: PInteger;                    // Out\r\n    piTrailing: PInteger               // Out\r\n ): HRESULT; stdcall;\r\n\r\n\r\n\r\n\r\n\r\n/////   ScriptStringGetLogicalWidths\r\n//\r\n//      Converts visual withs in psa->piAdvance into logical widths,\r\n//      one per original character, in logical order.\r\n//\r\n//      Requires SSA_GLYPHS requested in original ScriptStringAnalyse call.\r\n//\r\n//      The piDx parameter should address a buffer containing room for\r\n//      at least *ScriptString_pcOutChars(ssa) ints.\r\n\r\n\r\nfunction ScriptStringGetLogicalWidths(\r\n    ssa: TScriptStringAnalysis;\r\n    out piDx: Integer): HRESULT; stdcall;\r\n\r\n\r\n\r\n\r\n\r\n\r\n/////   ScriptStringValidate\r\n//\r\n//      Scans the string analysis for invalid glyphs.\r\n//\r\n//      Only glyphs generated by scripts that can generate invalid glyphs\r\n//      are scanned.\r\n//\r\n//      returns S_OK    - no invalid glyphs are present\r\n//              S_FALSE - one or more invalid glyphs are present\r\n\r\n\r\nfunction ScriptStringValidate(\r\n    ssa: TScriptStringAnalysis): HRESULT; stdcall;\r\n\r\n\r\n\r\n\r\n\r\n\r\n/////   ScriptStringOut\r\n//\r\n//      Displays the string generated by a prior ScriptStringAnalyze call,\r\n//      then optionally adds highlighting corresponding to a logical selection.\r\n//\r\n//      Requires SSA_GLYPHS requested in original ScriptStringAnalyse call.\r\n\r\n\r\nfunction ScriptStringOut(\r\n    ssa: TScriptStringAnalysis;         //In  Analysis with glyphs\r\n    iX: Integer;                        //In\r\n    iY: Integer;                        //In\r\n    uOptions: LongWord;                 //In  ExtTextOut options\r\n    const prc: PRect;                   //In  Clipping rectangle (iff ETO_CLIPPED)\r\n    iMinSel: Integer;                   //In  Logical selection. Set iMinSel>=iMaxSel for no selection\r\n    iMaxSel: Integer;                   //In\r\n    fDisabled: BOOL                     //In  If disabled, only the background is highlighted.\r\n ): HRESULT; stdcall;\r\n\r\n\r\n\r\n\r\n\r\nconst\r\n  /////\r\n  //      uOptions may nclude only ETO_CLIPPED or ETO_OPAQUE.\r\n  /////   ScriptIsComplex\r\n  //\r\n  //      Determines whether a Unicode string requires complex script processing\r\n  //\r\n  //      The dwFlags parameter may include the following requests\r\n  //\r\n  SIC_COMPLEX     = 1;   // Treat complex script letters as complex\r\n  SIC_ASCIIDIGIT  = 2;   // Treat digits U+0030 through U+0039 as complex\r\n  SIC_NEUTRAL     = 4;   // Treat neutrals as complex\r\n  \r\n//\r\n//      SIC_COMPLEX: Should normally set. Causes complex script letters to\r\n//      be treated as complex.\r\n//\r\n//      SIC_ASCIIDIGIT: Set this flag if the string would be displayed with\r\n//      digit substitution enabled. If you are following the users NLS\r\n//      settings using the ScriptRecordDigitSubstitution API, you can pass\r\n//      scriptDigitSubstitute.DigitSubstitute != SCRIPT_DIGITSUBSTITUTE_NONE.\r\n//\r\n//      SIC_NEUTRAL: Set this flag if you may be displaying the string with\r\n//      right-to-left reading order. When this flag is set, neutral characters\r\n//      are considered as complex.\r\n//\r\n//\r\n//      Returns S_OK     if string requires complex script processing,\r\n//              S_FALSE  if string contains only characters laid out side by\r\n//                       side from left to right.\r\n\r\n\r\nfunction ScriptIsComplex(\r\n    const pwcInChars: PWideChar;     //In  String to be tested\r\n    cInChars: Integer;               //In  Length in characters\r\n    dwFlags: DWORD                   //In  Flags (see above)\r\n ): HRESULT; stdcall;\r\n\r\n\r\n\r\n\r\n\r\ntype\r\n  /////   ScriptRecordDigitSubstitution\r\n  //\r\n  //      Reads NLS native digit and digit substitution settings and records\r\n  //      them in the SCRIPT_DIGITSUBSTITUTE structure.\r\n  //\r\n  //\r\n  PScriptDigitSubstitute = ^TScriptDigitSubstitute;\r\n  tag_SCRIPT_DIGITSUBSTITUTE = packed record\r\n    NationalDigitLanguage: Word    {:16};   // Language for native substitution\r\n    TraditionalDigitLanguage: Word {:16};   // Language for traditional substitution\r\n    DigitSubstitute: Byte          {:8};    // Substitution type\r\n    bReserved: Byte;\r\n    wReserved: Word;\r\n    dwReserved: DWORD;                       // Reserved\r\n  end;\r\n(*  NationalDigitLanguage: DWORD    {:16};   // Language for native substitution\r\n    TraditionalDigitLanguage: DWORD {:16};   // Language for traditional substitution\r\n    DigitSubstitute: DWORD          {:8};    // Substitution type\r\n    dwReserved: DWORD;                       // Reserved\r\n  end; *)\r\n  {$EXTERNALSYM tag_SCRIPT_DIGITSUBSTITUTE}\r\n  SCRIPT_DIGITSUBSTITUTE = tag_SCRIPT_DIGITSUBSTITUTE;\r\n  {$EXTERNALSYM SCRIPT_DIGITSUBSTITUTE}\r\n  TScriptDigitSubstitute = tag_SCRIPT_DIGITSUBSTITUTE;\r\n  \r\n//\r\n//\r\n//p     NationalDigitLanguage: Standard digits for the selected locale as\r\n//          defined by the countries standard setting authority.\r\n//\r\n//p     TraditionalDigitLangauge: Digits originally used with the locales\r\n//          script.\r\n//\r\n//p     DigitSubstitute: Selects between None, Context, National and\r\n//          Traditional. See ScriptApplyDigitSubstitution below for\r\n//          constant definitions.\r\n//\r\n//      Although most complex scripts have their own associated digits, many\r\n//      countries using those scripts use western (so called\r\n//      'Arabic') digits as their standard. NationalDigitLanguage reflects the\r\n//      digits used as standard, and is set from\r\n//      the NLS data for the locale.\r\n//      On Windows 2000 the national digit langauge can be\r\n//      adjusted to any digit script with the control panel/regional\r\n//      options/numbers/Standard digits listbox.\r\n//\r\n//      The TraditionalDigitLanguage for a locale is derived directly from the\r\n//      script used by that locale.\r\n\r\n\r\nfunction ScriptRecordDigitSubstitution(\r\n    Locale: LCID;                     // In   LOCALE_USER_DEFAULT or desired locale\r\n    out psds: TScriptDigitSubstitute  // Out  Digit substitution settings\r\n ): HRESULT; stdcall;\r\n\r\n\r\n\r\n\r\n\r\n/////\r\n//p     Locale: NLS locale to be queried. Should usually be set to\r\n//          LOCALE_USER_DEFAULT. Alternatively may be passed as a locale\r\n//          combined with LOCALE_NOUSEROVERRIDE to obtain default settings\r\n//          for a given locale. Note that context digit substitution is\r\n//          supported only in ARABIC and FARSI locales. In other locales,\r\n//          context digit is mapped to no substitution.\r\n//\r\n//p     psds: Pointer to SCRIPT_DIGITSUBSTITUTE. This structure may be passed\r\n//          later to ScriptApplyDigitSubstitution.\r\n//\r\n//p     returns: E_INVALIDARG if Locale is invalid or not installed. E_POINTER\r\n//          if psds is NULL. Otherwise S_OK.\r\n//\r\n//      For performance reasons, you should not call\r\n//      ScriptRecordDigitSubstitution frequently. In particular it would be a\r\n//      considerable overhead to call it every time you call ScriptItemize\r\n//      or ScriptStringAnalyse.\r\n//\r\n//      Instead, you may choose to save the SCRIPT_DIGITSUBSTITUTE\r\n//      structure, and update it only when you receive a\r\n//      WM_SETTINGCHANGE message or when a RegNotifyChangeKeyValue\r\n//      call in a dedicated thread indicates a change in the registry\r\n//      under HKCU\\Control Panel\\\\International.\r\n//\r\n//      The normal way to call this function is simply\r\n//\r\n//c     SCRIPT_DIGITSUBSTITUTE sds;\r\n//c     ScriptRecordDigitSubstitution(LOCALE_USER_DEFAULT, &sds);\r\n//\r\n//      Then every time you itemize, you'd use the results like this:\r\n//\r\n//c     SCRIPT_CONTROL  sc = {0};\r\n//c     SCRIPT_STATE    ss = {0};\r\n//\r\n//c     ScriptApplyDigitSubstitution(&sds, &sc, &ss);\r\n//\r\n//\r\n/////   ScriptApplyDigitSubstitution\r\n//\r\n//      Aplies the digit substitution settings recorded in a\r\n//      SCRIPT_DIGIT_SUBSTITUTE structure to the SCRIPT_CONTROL and\r\n//      SCRIPT_STATE structures.\r\n//\r\n//      The DigitSubstitute field of the SCRIPT_DIGITSUBSTITUTE structure\r\n//      is normally set by ScriptRecordDigitSubstitution, however it may\r\n//      be replaced by any one of the following values:\r\n//\r\n//\r\nconst\r\n  SCRIPT_DIGITSUBSTITUTE_CONTEXT      = 0;  // Substitute to match preceeding letters\r\n  SCRIPT_DIGITSUBSTITUTE_NONE         = 1;  // No substitution\r\n  SCRIPT_DIGITSUBSTITUTE_NATIONAL     = 2;  // Substitute with official national digits\r\n  SCRIPT_DIGITSUBSTITUTE_TRADITIONAL  = 3;  // Substitute with traditional digits of the locale\r\n//\r\n//\r\n//p     SCRIPT_DIGITSUBSTITUTE_CONTEXT: Digits U+0030 - U+0039 will be\r\n//          substituted according to the language of prior letters. Before\r\n//          any letters, digits will be substituted according to the\r\n//          TraditionalDigitLangauge field of the SCRIPT_DIGIT_SUBSTITUTE\r\n//          structure. This field is normally set to the primary language of\r\n//          the Locale passed to ScriptRecordDigitSubstitution.\r\n//\r\n//p     SCRIPT_DIGITSUBSTITUTE_NONE: Digits will not be substituted. Unicode\r\n//          values U+0030 to U+0039 will be displayed with Arabic (i.e.\r\n//          Western) numerals.\r\n//\r\n//p     SCRIPT_DIGITSUBSTITUTE_NATIONAL: Digits U+0030 - U+0039 will be\r\n//          substituted according to the NationalDigitLangauge field of\r\n//          the SCRIPT_DIGIT_SUBSTITUTE structure. This field is normally\r\n//          set to the national digits returned for the NLS LCTYPE\r\n//          LOCALE_SNATIVEDIGITS by ScriptRecordDigitSubstitution.\r\n//\r\n//p     SCRIPT_DIGITSUBSTITUTE_TRADITIONAL: Digits U+0030 - U+0039 will be\r\n//          substituted according to the TraditionalDigitLangauge field of\r\n//          the SCRIPT_DIGIT_SUBSTITUTE structure. This field is normally\r\n//          set to the primary language of the Locale passed to\r\n//          ScriptRecordDigitSubstitution.\r\n\r\n\r\nfunction ScriptApplyDigitSubstitution(\r\n    const psds: PScriptDigitSubstitute;   // In   Digit substitution settings\r\n    psc: PScriptControl;                  // Out  Script control structure\r\n    pss: PScriptState                     // Out  Script state structure\r\n ): HRESULT; stdcall;\r\n\r\n\r\n\r\n\r\n\r\n\r\n/////\r\n//p     psds: Pointer to SCRIPT_DIGITSUBSTITUTE structure recorded earlier.\r\n//          If NULL, ScriptApplyDigitSubstitution calls\r\n//          ScriptRecordDigitSubstitution with LOCALE_USER_DEFAULT.\r\n//\r\n//p     psc: SCRIPT_CONTROL structure. The fContextDigits and uDefaultLanguage\r\n//          fields will be updated.\r\n//\r\n//p     pss: SCRIPT_CONTROL structure. The fDigitSubstitute field will be\r\n//          updated.\r\n//\r\n//p     returns: E_INVALIDARG if the DigitSubstitute field of the\r\n//          SCRIPT_DIGITSUBSTITUTE structure is unrecognised, else S_OK;\r\n\r\nvar\r\n  Usp10IsInstalled: Boolean;\r\n\r\nimplementation\r\n\r\nuses\r\n  SysUtils;\r\n\r\nconst\r\n  Usp10DLL = 'usp10.dll';\r\n\r\nvar\r\n  Usp10DllModule: HMODULE = 0;\r\n\r\nfunction GetUsp10DllModule: HMODULE;\r\nbegin\r\n  if Usp10DllModule = 0 then\r\n  begin\r\n    Usp10DllModule := SafeLoadLibrary(Usp10DLL);\r\n    if Usp10DllModule <= HINSTANCE_ERROR then\r\n      Usp10DllModule := 0;\r\n  end;\r\n  Result := Usp10DllModule;\r\nend;\r\n\r\nprocedure GetProcedureAddress(var P: Pointer; const ModuleName, ProcName: string);\r\nbegin\r\n  if not Assigned(P) then\r\n  begin\r\n    P := Pointer(GetProcAddress(Usp10DllModule, PAnsiChar(AnsiString(ProcName))));\r\n    if not Assigned(P) or (Usp10DllModule = 0) then\r\n      RaiseLastOSError;\r\n  end;\r\nend;\r\n\r\nvar\r\n  _ScriptFreeCache: Pointer = nil;\r\n\r\nfunction ScriptFreeCache;\r\nbegin\r\n  if _ScriptFreeCache = nil then\r\n    GetProcedureAddress(_ScriptFreeCache, Usp10DLL, 'ScriptFreeCache');\r\n  asm\r\n    MOV ESP, EBP\r\n    POP EBP\r\n    JMP [_ScriptFreeCache]\r\n  end;\r\nend;\r\n\r\nvar\r\n  _ScriptItemize: Pointer = nil;\r\n\r\nfunction ScriptItemize;\r\nbegin\r\n  if _ScriptItemize = nil then\r\n    GetProcedureAddress(_ScriptItemize, Usp10DLL, 'ScriptItemize');\r\n  asm\r\n    MOV ESP, EBP\r\n    POP EBP\r\n    JMP [_ScriptItemize]\r\n  end;\r\nend;\r\n\r\nvar\r\n  _ScriptLayout: Pointer = nil;\r\n\r\nfunction ScriptLayout;\r\nbegin\r\n  if _ScriptLayout = nil then\r\n    GetProcedureAddress(_ScriptLayout, Usp10DLL, 'ScriptLayout');\r\n  asm\r\n    MOV ESP, EBP\r\n    POP EBP\r\n    JMP [_ScriptLayout]\r\n  end;\r\nend;\r\n\r\nvar\r\n  _ScriptShape: Pointer = nil;\r\n\r\nfunction ScriptShape;\r\nbegin\r\n  if _ScriptShape = nil then\r\n    GetProcedureAddress(_ScriptShape, Usp10DLL, 'ScriptShape');\r\n  asm\r\n    MOV ESP, EBP\r\n    POP EBP\r\n    JMP [_ScriptShape]\r\n  end;\r\nend;\r\n\r\nvar\r\n  _ScriptPlace: Pointer = nil;\r\n\r\nfunction ScriptPlace;\r\nbegin\r\n  if _ScriptPlace = nil then\r\n    GetProcedureAddress(_ScriptPlace, Usp10DLL, 'ScriptPlace');\r\n  asm\r\n    MOV ESP, EBP\r\n    POP EBP\r\n    JMP [_ScriptPlace]\r\n  end;\r\nend;\r\n\r\nvar\r\n  _ScriptTextOut: Pointer = nil;\r\n\r\nfunction ScriptTextOut;\r\nbegin\r\n  if _ScriptTextOut = nil then\r\n    GetProcedureAddress(_ScriptTextOut, Usp10DLL, 'ScriptTextOut');\r\n  asm\r\n    MOV ESP, EBP\r\n    POP EBP\r\n    JMP [_ScriptTextOut]\r\n  end;\r\nend;\r\n\r\nvar\r\n  _ScriptJustify: Pointer = nil;\r\n\r\nfunction ScriptJustify;\r\nbegin\r\n  if _ScriptJustify = nil then\r\n    GetProcedureAddress(_ScriptJustify, Usp10DLL, 'ScriptJustify');\r\n  asm\r\n    MOV ESP, EBP\r\n    POP EBP\r\n    JMP [_ScriptJustify]\r\n  end;\r\nend;\r\n\r\nvar\r\n  _ScriptBreak: Pointer = nil;\r\n\r\nfunction ScriptBreak;\r\nbegin\r\n  if _ScriptBreak = nil then\r\n    GetProcedureAddress(_ScriptBreak, Usp10DLL, 'ScriptBreak');\r\n  asm\r\n    MOV ESP, EBP\r\n    POP EBP\r\n    JMP [_ScriptBreak]\r\n  end;\r\nend;\r\n\r\nvar\r\n  _ScriptCPtoX: Pointer = nil;\r\n\r\nfunction ScriptCPtoX;\r\nbegin\r\n  if _ScriptCPtoX = nil then\r\n    GetProcedureAddress(_ScriptCPtoX, Usp10DLL, 'ScriptCPtoX');\r\n  asm\r\n    MOV ESP, EBP\r\n    POP EBP\r\n    JMP [_ScriptCPtoX]\r\n  end;\r\nend;\r\n\r\nvar\r\n  _ScriptXtoCP: Pointer = nil;\r\n\r\nfunction ScriptXtoCP;\r\nbegin\r\n  if _ScriptXtoCP = nil then\r\n    GetProcedureAddress(_ScriptXtoCP, Usp10DLL, 'ScriptXtoCP');\r\n  asm\r\n    MOV ESP, EBP\r\n    POP EBP\r\n    JMP [_ScriptXtoCP]\r\n  end;\r\nend;\r\n\r\nvar\r\n  _ScriptGetLogicalWidths: Pointer = nil;\r\n\r\nfunction ScriptGetLogicalWidths;\r\nbegin\r\n  if _ScriptGetLogicalWidths = nil then\r\n    GetProcedureAddress(_ScriptGetLogicalWidths, Usp10DLL, 'ScriptGetLogicalWidths');\r\n  asm\r\n    MOV ESP, EBP\r\n    POP EBP\r\n    JMP [_ScriptGetLogicalWidths]\r\n  end;\r\nend;\r\n\r\nvar\r\n  _ScriptApplyLogicalWidth: Pointer = nil;\r\n\r\nfunction ScriptApplyLogicalWidth;\r\nbegin\r\n  if _ScriptApplyLogicalWidth = nil then\r\n    GetProcedureAddress(_ScriptApplyLogicalWidth, Usp10DLL, 'ScriptApplyLogicalWidth');\r\n  asm\r\n    MOV ESP, EBP\r\n    POP EBP\r\n    JMP [_ScriptApplyLogicalWidth]\r\n  end;\r\nend;\r\n\r\nvar\r\n  _ScriptGetCMap: Pointer = nil;\r\n\r\nfunction ScriptGetCMap;\r\nbegin\r\n  if _ScriptGetCMap = nil then\r\n    GetProcedureAddress(_ScriptGetCMap, Usp10DLL, 'ScriptGetCMap');\r\n  asm\r\n    MOV ESP, EBP\r\n    POP EBP\r\n    JMP [_ScriptGetCMap]\r\n  end;\r\nend;\r\n\r\nvar\r\n  _ScriptGetGlyphABCWidth: Pointer = nil;\r\n\r\nfunction ScriptGetGlyphABCWidth;\r\nbegin\r\n  if _ScriptGetGlyphABCWidth = nil then\r\n    GetProcedureAddress(_ScriptGetGlyphABCWidth, Usp10DLL, 'ScriptGetGlyphABCWidth');\r\n  asm\r\n    MOV ESP, EBP\r\n    POP EBP\r\n    JMP [_ScriptGetGlyphABCWidth]\r\n  end;\r\nend;\r\n\r\nvar\r\n  _ScriptGetProperties: Pointer = nil;\r\n\r\nfunction ScriptGetProperties;\r\nbegin\r\n  if _ScriptGetProperties = nil then\r\n    GetProcedureAddress(_ScriptGetProperties, Usp10DLL, 'ScriptGetProperties');\r\n  asm\r\n    MOV ESP, EBP\r\n    POP EBP\r\n    JMP [_ScriptGetProperties]\r\n  end;\r\nend;\r\n\r\nvar\r\n  _ScriptGetFontProperties: Pointer = nil;\r\n\r\nfunction ScriptGetFontProperties;\r\nbegin\r\n  if _ScriptGetFontProperties = nil then\r\n    GetProcedureAddress(_ScriptGetFontProperties, Usp10DLL, 'ScriptGetFontProperties');\r\n  asm\r\n    MOV ESP, EBP\r\n    POP EBP\r\n    JMP [_ScriptGetFontProperties]\r\n  end;\r\nend;\r\n\r\nvar\r\n  _ScriptCacheGetHeight: Pointer = nil;\r\n\r\nfunction ScriptCacheGetHeight;\r\nbegin\r\n  if _ScriptCacheGetHeight = nil then\r\n    GetProcedureAddress(_ScriptCacheGetHeight, Usp10DLL, 'ScriptCacheGetHeight');\r\n  asm\r\n    MOV ESP, EBP\r\n    POP EBP\r\n    JMP [_ScriptCacheGetHeight]\r\n  end;\r\nend;\r\n\r\nvar\r\n  _ScriptStringAnalyse: Pointer = nil;\r\n\r\nfunction ScriptStringAnalyse;\r\nbegin\r\n  if _ScriptStringAnalyse = nil then\r\n    GetProcedureAddress(_ScriptStringAnalyse, Usp10DLL, 'ScriptStringAnalyse');\r\n  asm\r\n    MOV ESP, EBP\r\n    POP EBP\r\n    JMP [_ScriptStringAnalyse]\r\n  end;\r\nend;\r\n\r\nvar\r\n  _ScriptStringFree: Pointer = nil;\r\n\r\nfunction ScriptStringFree;\r\nbegin\r\n  if _ScriptStringFree = nil then\r\n    GetProcedureAddress(_ScriptStringFree, Usp10DLL, 'ScriptStringFree');\r\n  asm\r\n    MOV ESP, EBP\r\n    POP EBP\r\n    JMP [_ScriptStringFree]\r\n  end;\r\nend;\r\n\r\nvar\r\n  _ScriptString_pSize: Pointer = nil;\r\n\r\nfunction ScriptString_pSize;\r\nbegin\r\n  if _ScriptString_pSize = nil then\r\n    GetProcedureAddress(_ScriptString_pSize, Usp10DLL, 'ScriptString_pSize');\r\n  asm\r\n    MOV ESP, EBP\r\n    POP EBP\r\n    JMP [_ScriptString_pSize]\r\n  end;\r\nend;\r\n\r\nvar\r\n  _ScriptString_pcOutChars: Pointer = nil;\r\n\r\nfunction ScriptString_pcOutChars;\r\nbegin\r\n  if _ScriptString_pcOutChars = nil then\r\n    GetProcedureAddress(_ScriptString_pcOutChars, Usp10DLL, 'ScriptString_pcOutChars');\r\n  asm\r\n    MOV ESP, EBP\r\n    POP EBP\r\n    JMP [_ScriptString_pcOutChars]\r\n  end;\r\nend;\r\n\r\nvar\r\n  _ScriptString_pLogAttr: Pointer = nil;\r\n\r\nfunction ScriptString_pLogAttr;\r\nbegin\r\n  if _ScriptString_pLogAttr = nil then\r\n    GetProcedureAddress(_ScriptString_pLogAttr, Usp10DLL, 'ScriptString_pLogAttr');\r\n  asm\r\n    MOV ESP, EBP\r\n    POP EBP\r\n    JMP [_ScriptString_pLogAttr]\r\n  end;\r\nend;\r\n\r\nvar\r\n  _ScriptStringGetOrder: Pointer = nil;\r\n\r\nfunction ScriptStringGetOrder;\r\nbegin\r\n  if _ScriptStringGetOrder = nil then\r\n    GetProcedureAddress(_ScriptStringGetOrder, Usp10DLL, 'ScriptStringGetOrder');\r\n  asm\r\n    MOV ESP, EBP\r\n    POP EBP\r\n    JMP [_ScriptStringGetOrder]\r\n  end;\r\nend;\r\n\r\nvar\r\n  _ScriptStringCPtoX: Pointer = nil;\r\n\r\nfunction ScriptStringCPtoX;\r\nbegin\r\n  if _ScriptStringCPtoX = nil then\r\n    GetProcedureAddress(_ScriptStringCPtoX, Usp10DLL, 'ScriptStringCPtoX');\r\n  asm\r\n    MOV ESP, EBP\r\n    POP EBP\r\n    JMP [_ScriptStringCPtoX]\r\n  end;\r\nend;\r\n\r\nvar\r\n  _ScriptStringXtoCP: Pointer = nil;\r\n\r\nfunction ScriptStringXtoCP;\r\nbegin\r\n  if _ScriptStringXtoCP = nil then\r\n    GetProcedureAddress(_ScriptStringXtoCP, Usp10DLL, 'ScriptStringXtoCP');\r\n  asm\r\n    MOV ESP, EBP\r\n    POP EBP\r\n    JMP [_ScriptStringXtoCP]\r\n  end;\r\nend;\r\n\r\nvar\r\n  _ScriptStringGetLogicalWidths: Pointer = nil;\r\n\r\nfunction ScriptStringGetLogicalWidths;\r\nbegin\r\n  if _ScriptStringGetLogicalWidths = nil then\r\n    GetProcedureAddress(_ScriptStringGetLogicalWidths, Usp10DLL, 'ScriptStringGetLogicalWidths');\r\n  asm\r\n    MOV ESP, EBP\r\n    POP EBP\r\n    JMP [_ScriptStringGetLogicalWidths]\r\n  end;\r\nend;\r\n\r\nvar\r\n  _ScriptStringValidate: Pointer = nil;\r\n\r\nfunction ScriptStringValidate;\r\nbegin\r\n  if _ScriptStringValidate = nil then\r\n    GetProcedureAddress(_ScriptStringValidate, Usp10DLL, 'ScriptStringValidate');\r\n  asm\r\n    MOV ESP, EBP\r\n    POP EBP\r\n    JMP [_ScriptStringValidate]\r\n  end;\r\nend;\r\n\r\nvar\r\n  _ScriptStringOut: Pointer = nil;\r\n\r\nfunction ScriptStringOut;\r\nbegin\r\n  if _ScriptStringOut = nil then\r\n    GetProcedureAddress(_ScriptStringOut, Usp10DLL, 'ScriptStringOut');\r\n  asm\r\n    MOV ESP, EBP\r\n    POP EBP\r\n    JMP [_ScriptStringOut]\r\n  end;\r\nend;\r\n\r\nvar\r\n  _ScriptIsComplex: Pointer = nil;\r\n\r\nfunction ScriptIsComplex;\r\nbegin\r\n  if _ScriptIsComplex = nil then\r\n    GetProcedureAddress(_ScriptIsComplex, Usp10DLL, 'ScriptIsComplex');\r\n  asm\r\n    MOV ESP, EBP\r\n    POP EBP\r\n    JMP [_ScriptIsComplex]\r\n  end;\r\nend;\r\n\r\nvar\r\n  _ScriptRecordDigitSubstitution: Pointer = nil;\r\n\r\nfunction ScriptRecordDigitSubstitution;\r\nbegin\r\n  if _ScriptRecordDigitSubstitution = nil then\r\n    GetProcedureAddress(_ScriptRecordDigitSubstitution, Usp10DLL, 'ScriptRecordDigitSubstitution');\r\n  asm\r\n    MOV ESP, EBP\r\n    POP EBP\r\n    JMP [_ScriptRecordDigitSubstitution]\r\n  end;\r\nend;\r\n\r\nvar\r\n  _ScriptApplyDigitSubstitution: Pointer = nil;\r\n\r\nfunction ScriptApplyDigitSubstitution;\r\nbegin\r\n  if _ScriptApplyDigitSubstitution = nil then\r\n    GetProcedureAddress(_ScriptApplyDigitSubstitution, Usp10DLL, 'ScriptApplyDigitSubstitution');\r\n  asm\r\n    MOV ESP, EBP\r\n    POP EBP\r\n    JMP [_ScriptApplyDigitSubstitution]\r\n  end;\r\nend;\r\n\r\ninitialization\r\n  Usp10DllModule := GetUsp10DllModule;\r\n  Usp10IsInstalled := Usp10DllModule <> 0;\r\n\r\nfinalization\r\n  if Usp10DllModule <> 0 then FreeLibrary(Usp10DllModule);\r\n\r\nend.\r\n"
  },
  {
    "path": "External/SynEdit/Source/kTextDrawer.pas",
    "content": "{-------------------------------------------------------------------------------\r\nThe contents of this file are subject to the Mozilla Public License\r\nVersion 1.1 (the \"License\"); you may not use this file except in compliance\r\nwith the License. You may obtain a copy of the License at\r\nhttp://www.mozilla.org/MPL/\r\n\r\nSoftware distributed under the License is distributed on an \"AS IS\" basis,\r\nWITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for\r\nthe specific language governing rights and limitations under the License.\r\n\r\nThe Original Code is: SynEdit.pas, released 2000-04-07.\r\nThe Original Code is based on mwCustomEdit.pas by Martin Waldenburg, part of\r\nthe mwEdit component suite.\r\nPortions created by Martin Waldenburg are Copyright (C) 1998 Martin Waldenburg.\r\nAll Rights Reserved.\r\n\r\nContributors to the SynEdit and mwEdit projects are listed in the\r\nContributors.txt file.\r\n\r\nAlternatively, the contents of this file may be used under the terms of the\r\nGNU General Public License Version 2 or later (the \"GPL\"), in which case\r\nthe provisions of the GPL are applicable instead of those above.\r\nIf you wish to allow use of your version of this file only under the terms\r\nof the GPL and not to allow others to use your version of this file\r\nunder the MPL, indicate your decision by deleting the provisions above and\r\nreplace them with the notice and other provisions required by the GPL.\r\nIf you do not delete the provisions above, a recipient may use your version\r\nof this file under either the MPL or the GPL.\r\n\r\n$Id: kTextDrawer.pas,v 1.10.2.3 2008/09/14 16:25:03 maelh Exp $\r\n\r\nYou may retrieve the latest version of this file at the SynEdit home page,\r\nlocated at http://SynEdit.SourceForge.net\r\n\r\nKnown Issues:\r\n-------------------------------------------------------------------------------}\r\nunit kTextDrawer;\r\n\r\n{$I SynEdit.inc}\r\n\r\ninterface\r\n\r\nuses\r\n  Types,\r\n  Qt,\r\n  QGraphics,\r\n  QForms,\r\n  QControls,\r\n  Classes,\r\n  QStdCtrls;\r\n\r\nconst\r\n  ETO_OPAQUE = 1;\r\n  ETO_CLIPPED = 2;\r\n\r\n  CYHSCROLL = 16;\r\n  CXVSCROLL = 16;\r\n  MaxShortInt = High(ShortInt);\r\n\r\n// system metics\r\n  SM_CXDRAG = 1;\r\n  SM_CYDRAG = 2;\r\n\r\ntype\r\n  UINT = DWORD;\r\n\r\n  // this is to get around some weirdness with the Kylix font code\r\n  // where the style given by the font object isn't correct\r\n  TFontHolder = class\r\n    style: TFontStyles;\r\n    font: TFont;\r\n\r\n    constructor Create(aFont: TFont; aStyle: TFontStyles);\r\n  end;\r\n\r\n  TheTextDrawer = class(TObject)\r\n  private\r\n    // Font information\r\n    fBaseFont: TFont;\r\n\r\n    // current font and properties\r\n    fCurrentStyle: TFontStyles;\r\n    fCurrentFont: TFont;\r\n    fCurrentColor: TColor;\r\n\r\n    // current font attributes\r\n    FBkColor: TColor;\r\n    fCharWidth: integer;\r\n    fCharHeight: integer;\r\n    fakeBold: boolean;  // true if the font can't be bold\r\n\r\n    // Begin/EndDrawing calling count\r\n    FDrawingCount: Integer;\r\n    fCanvas: TCanvas;\r\n\r\n    fFontList: TList;\r\n    function GetFont(Index: integer): TFont;\r\n    function GetFontCount: integer;\r\n    function GetFontStyle(Index: integer): TFontStyles;\r\n    function FindFont(aStyle: TFontStyles; aColor: TColor): TFont;\r\n\r\n    property Fonts[Index: integer]: TFont read getFont;\r\n    property FontCount: integer read getFontCount;\r\n    property FontStyle[Index: integer]: TFontStyles read GetFontStyle;\r\n  protected\r\n    procedure UpdateCurrentFont;\r\n    procedure UpdateFontMetrics;\r\n    procedure ClearFontList;\r\n  public\r\n    constructor Create(CalcExtentBaseStyle: TFontStyles; ABaseFont: TFont); virtual;\r\n    destructor Destroy; override;\r\n    function GetCharWidth: Integer; virtual;\r\n    function GetCharHeight: Integer; virtual;\r\n    procedure BeginDrawing(ACanvas : TCanvas); overload; virtual;\r\n\r\n    procedure EndDrawing; virtual;\r\n    procedure TextOut(X, Y: Integer; Text: PWideChar; Length: Integer); virtual;\r\n    procedure ExtTextOut(X, Y: Integer; fuOptions: UINT; const ARect: TRect;\r\n      Text: PWideChar; Length: Integer); virtual;\r\n    procedure SetBaseFont(Value: TFont); virtual;\r\n    procedure SetBaseStyle(const Value: TFontStyles); virtual;\r\n    procedure SetStyle(Value: TFontStyles); virtual;\r\n    procedure SetForeColor(Value: TColor); virtual;\r\n    procedure SetBackColor(Value: TColor); virtual;\r\n    procedure SetCharExtra(Value: Integer); virtual;\r\n    property CharWidth: Integer read GetCharWidth;\r\n    property CharHeight: Integer read GetCharHeight;\r\n    property BaseFont: TFont write SetBaseFont;\r\n    property BaseStyle: TFontStyles write SetBaseStyle;\r\n    property ForeColor: TColor write SetForeColor;\r\n    property BackColor: TColor write SetBackColor;\r\n    property Style: TFontStyles write SetStyle;\r\n  end;\r\n\r\n  TCaret = class(TComponent)\r\n  private\r\n    FActive: Boolean;\r\n    FRect: TRect;\r\n    FInternalShowCount: Integer;\r\n    FOwnerCanvas: TControlCanvas;\r\n    FShowCount: Integer;\r\n    procedure ForceInternalInvisible;\r\n    procedure ForceInternalVisible;\r\n    function GetTopLeft: TPoint;\r\n    procedure Paint;\r\n    procedure SetTopLeft(const Value: TPoint);\r\n    procedure InternalHide;\r\n    procedure InternalShow;\r\n    function Visible: Boolean;\r\n  public\r\n    constructor Create(AOwner: TWidgetControl; Width, Height: Integer); reintroduce;\r\n    destructor Destroy; override;\r\n    procedure Hide;\r\n    procedure Show;\r\n    procedure Toggle;\r\n    property Active: Boolean read FActive;\r\n    property OwnerCanvas: TControlCanvas read FOwnerCanvas;\r\n    property TopLeft: TPoint read GetTopLeft write SetTopLeft;\r\n  end;\r\n\r\n  TSynEditScrollBar = class(TScrollBar)\r\n  public\r\n    constructor Create(AOwner: TComponent); override;\r\n  end;\r\n\r\nprocedure InternalFillRect(Canvas: TCanvas; rect: TRect);\r\nfunction GetSystemMetrics(Metric: Integer): Integer;\r\n\r\nprocedure CreateCaret(Control: TWidgetControl; dummy, Width, Height: Integer);\r\nprocedure SetCaretPos(X, Y: Integer);\r\nprocedure ShowCaret(Control: TWidgetControl);\r\nprocedure HideCaret(Control: TWidgetControl);\r\nprocedure DestroyCaret;\r\nprocedure ScrollWindow(Control: TWidgetControl; DeltaX, DeltaY: Integer; Rect: PRect);\r\n\r\nimplementation\r\n\r\nuses\r\n{$IFDEF SYN_KYLIX}\r\n  libc,\r\n{$ENDIF}\r\n  QExtCtrls;\r\n\r\ntype\r\n  TCaretManager = class\r\n  private\r\n    fBlinkTimer: TTimer;\r\n    fCurrentCaret: TCaret;\r\n    procedure HandleTimer(Sender : TObject);\r\n    procedure SetCurrentCaret(const Value: TCaret);\r\n  public\r\n    constructor Create;\r\n    destructor Destroy; override;\r\n    procedure ResetTimer;\r\n    property CurrentCaret: TCaret read fCurrentCaret write SetCurrentCaret;\r\n  end;\r\n\r\nvar\r\n  CaretManager: TCaretManager;\r\n\r\nfunction FindCaret(Control: TWidgetControl): TCaret;\r\nvar\r\n  i: Integer;\r\nbegin\r\n  Result := nil;\r\n\r\n  for i := 0 to Control.ComponentCount - 1 do\r\n    if Control.Components[i] is TCaret then\r\n    begin\r\n      Result := TCaret(Control.Components[i]);\r\n      break;\r\n    end;\r\nend;\r\n\r\nprocedure CreateCaret(Control: TWidgetControl; dummy, Width, Height: Integer);\r\nvar\r\n  Caret: TCaret;\r\nbegin\r\n  Caret := FindCaret(Control);\r\n  if Assigned(Caret) then\r\n    Caret.Free;\r\n  Caret := TCaret.Create(Control, Width, Height);\r\n\r\n  CaretManager.CurrentCaret := Caret;\r\nend;\r\n\r\nprocedure DestroyCaret;\r\nbegin\r\n  if CaretManager.CurrentCaret <> nil then\r\n  begin\r\n    CaretManager.CurrentCaret.Free;\r\n    CaretManager.CurrentCaret := nil;\r\n  end;\r\nend;\r\n\r\nprocedure ScrollWindow(Control: TWidgetControl; DeltaX, DeltaY: Integer; Rect: PRect);\r\nvar\r\n  Caret: TCaret;\r\n  NewTopLeft: TPoint;\r\n  CaretWasActive: Boolean;\r\nbegin\r\n  Caret := FindCaret(Control);\r\n  CaretWasActive := False;\r\n  if Assigned(Caret) then\r\n  begin\r\n    CaretWasActive := Caret.Active;\r\n    if CaretWasActive then Caret.Hide;\r\n    NewTopLeft := Point(Caret.TopLeft.X + DeltaX, Caret.TopLeft.Y + DeltaY);\r\n    if NewTopLeft.X < Rect.Left then\r\n      NewTopLeft.X := -Caret.FRect.Left - 1;\r\n    if NewTopLeft.Y < Rect.Top then\r\n      NewTopLeft.Y := -Caret.FRect.Bottom - 1;\r\n    Caret.TopLeft := NewTopLeft;\r\n  end;\r\n  QWidget_Scroll(Control.Handle, DeltaX, DeltaY, Rect);\r\n  if Assigned(Caret) and CaretWasActive then Caret.Show;\r\nend;\r\n\r\nprocedure SetCaretPos(X, Y: Integer);\r\nvar\r\n  Caret: TCaret;\r\nbegin\r\n  Caret := CaretManager.CurrentCaret;\r\n  if Assigned(Caret) then\r\n    Caret.TopLeft := Point(X, Y);\r\nend;\r\n\r\nprocedure ShowCaret(Control: TWidgetControl);\r\nvar\r\n  Caret: TCaret;\r\nbegin\r\n  Caret := FindCaret(Control);\r\n  if Assigned(Caret) then\r\n    Caret.Show;\r\nend;\r\n\r\nprocedure HideCaret(Control: TWidgetControl);\r\nvar\r\n  Caret: TCaret;\r\nbegin\r\n  Caret := FindCaret(Control);\r\n  if Assigned(Caret) then\r\n    Caret.Hide;\r\nend;\r\n\r\nprocedure InternalFillRect(canvas: TCanvas; rect: TRect);\r\nbegin\r\n  canvas.FillRect(rect);\r\nend;\r\n\r\nfunction GetSystemMetrics(metric: integer): integer;\r\nbegin\r\n  case metric of\r\n    SM_CXDRAG: result := 2;\r\n    SM_CYDRAG: result := 2;\r\n  else\r\n    result := -1;\r\n  end;\r\nend;\r\n\r\n{ TheTextDrawer }\r\n\r\nprocedure TheTextDrawer.BeginDrawing(ACanvas: TCanvas);\r\nbegin\r\n  if fDrawingCount = 0 then\r\n  begin\r\n    UpdateCurrentFont;\r\n    fCanvas := ACanvas;\r\n    fCanvas.Font := fCurrentFont;\r\n       \r\n    fCanvas.Brush.Color := FBkColor;\r\n  end;\r\n\r\n  inc(FDrawingCount);\r\nend;\r\n\r\nprocedure TheTextDrawer.ClearFontList;\r\nvar\r\n  i: integer;\r\nbegin\r\n  for i := 0 to FontCount - 1 do\r\n  begin\r\n    Fonts[i].Free;\r\n    TFontHolder(fFontList[i]).Free;\r\n  end;\r\n\r\n  fFontList.Clear;\r\nend;\r\n\r\nconstructor TheTextDrawer.Create(CalcExtentBaseStyle: TFontStyles; ABaseFont: TFont);\r\nbegin\r\n  fBaseFont := TFont.Create;\r\n  fFontList := TList.Create;\r\n\r\n  BaseFont := ABaseFont;\r\n  BaseStyle := CalcExtentBaseStyle;\r\nend;\r\n\r\ndestructor TheTextDrawer.Destroy;\r\nbegin\r\n  fBaseFont.Free;\r\n  ClearFontList;\r\n  fFontList.Free;\r\n\r\n  inherited Destroy;\r\nend;\r\n\r\nprocedure TheTextDrawer.EndDrawing;\r\nbegin\r\n  if FDrawingCount > 0 then\r\n    dec(FDrawingCount);\r\n\r\n  if FDrawingCount = 0 then\r\n    fCanvas := nil;\r\nend;\r\n\r\nprocedure TheTextDrawer.ExtTextOut(X, Y: Integer; fuOptions: UINT;\r\n  const ARect: TRect; Text: PWideChar; Length: Integer);\r\nbegin\r\n  if fCanvas <> nil then\r\n    begin\r\n//      fCanvas.Brush.Color := random($ffffff);\r\n      fCanvas.Brush.Style := bsSolid;\r\n      fCanvas.FillRect(ARect);\r\n\r\n      if Text <> nil then\r\n        begin\r\n          if Length = -1 then\r\n            fCanvas.TextRect(ARect, X, Y, Text)\r\n          else\r\n            fCanvas.TextRect(ARect, X, Y, copy(Text, 1, Length));\r\n\r\n          if fakeBold then\r\n            if Length = -1 then\r\n              fCanvas.TextRect(ARect, X + 1, Y, Text)\r\n            else\r\n              fCanvas.TextRect(ARect, X + 1, Y, copy(Text, 1, Length));\r\n        end;\r\n    end;\r\nend;\r\n\r\nfunction TheTextDrawer.FindFont(aStyle: TFontStyles; aColor: TColor): TFont;\r\nvar\r\n  i: integer;\r\nbegin\r\n  Result := nil;\r\n\r\n  for i := 0 to FontCount - 1 do\r\n    if (FontStyle[i] = aStyle) and (Fonts[i].Color = aColor) then\r\n    begin\r\n      Result := Fonts[i];\r\n      break;\r\n    end;\r\n\r\n  if Result = nil then\r\n    begin\r\n      Result := TFont.Create;\r\n      Result.Assign(fBaseFont);\r\n      Result.Style := aStyle;\r\n      Result.Color := aColor;\r\n      fFontList.Add(TFontHolder.Create(Result, aStyle));\r\n    end;\r\nend;\r\n\r\nfunction TheTextDrawer.GetCharHeight: Integer;\r\nbegin\r\n  Result := fCharHeight;\r\nend;\r\n\r\nfunction TheTextDrawer.GetCharWidth: Integer;\r\nbegin\r\n  Result := fCharWidth;\r\nend;\r\n\r\nfunction TheTextDrawer.GetFont(Index: integer): TFont;\r\nbegin\r\n  Result := TFontHolder(fFontList[Index]).font;\r\nend;\r\n\r\nfunction TheTextDrawer.GetFontCount: integer;\r\nbegin\r\n  Result := fFontList.Count;\r\nend;\r\n\r\nfunction TheTextDrawer.GetFontStyle(Index: integer): TFontStyles;\r\nbegin\r\n  Result := TFontHolder(fFontList[Index]).style;\r\nend;\r\n\r\nprocedure TheTextDrawer.SetBackColor(Value: TColor);\r\nbegin\r\n  if FBkColor <> Value then\r\n  begin\r\n    FBkColor := Value;\r\n\r\n    if fCanvas <> nil then\r\n      fCanvas.Brush.Color := Value;\r\n  end;\r\nend;\r\n\r\nprocedure TheTextDrawer.SetBaseFont(Value: TFont);\r\nbegin\r\n  if Value <> nil then\r\n  begin\r\n    fBaseFont.Assign(Value);\r\n    UpdateFontMetrics;\r\n    UpdateCurrentFont;\r\n  end;\r\nend;\r\n\r\nprocedure TheTextDrawer.SetBaseStyle(const Value: TFontStyles);\r\nbegin\r\n  fBaseFont.Style := Value;\r\n  UpdateFontMetrics;\r\nend;\r\n\r\nprocedure TheTextDrawer.SetCharExtra(Value: Integer);\r\nbegin\r\n  // do nothing\r\nend;\r\n\r\nprocedure TheTextDrawer.SetForeColor(Value: TColor);\r\nbegin\r\n  fCurrentColor := Value;\r\n  UpdateCurrentFont;\r\nend;\r\n\r\nprocedure TheTextDrawer.SetStyle(Value: TFontStyles);\r\nbegin\r\n  fCurrentStyle := Value;\r\n  UpdateCurrentFont;\r\nend;\r\n\r\nprocedure TheTextDrawer.TextOut(X, Y: Integer; Text: PWideChar;\r\n  Length: Integer);\r\nbegin\r\n  if fCanvas <> nil then\r\n    begin\r\n      fCanvas.Brush.Style := bsSolid;\r\n\r\n      if Text <> nil then\r\n        begin\r\n          if Length = -1 then\r\n            fCanvas.TextOut(X, Y, Text)\r\n          else\r\n            fCanvas.TextOut(X, Y, copy(Text, 1, Length));\r\n\r\n\r\n          if fakeBold then\r\n            if Length = -1 then\r\n              fCanvas.TextOut(X + 1, Y, Text)\r\n            else\r\n              fCanvas.TextOut(X + 1, Y, copy(Text, 1, Length));\r\n        end;\r\n    end;\r\nend;\r\n\r\nprocedure TheTextDrawer.UpdateCurrentFont;\r\nbegin\r\n  fCurrentFont := FindFont(fCurrentStyle, fCurrentColor);\r\n  QFont_setFixedPitch(fCurrentFont.Handle, True);\r\n\r\n  if fCanvas <> nil then\r\n    fCanvas.Font.Assign(fCurrentFont);\r\n\r\n  // Make sure that we can draw bold text even if the current font\r\n  // doesn't want to do it\r\n  fakeBold := (fsBold in fCurrentStyle) and not (fsBold in fCurrentFont.Style);\r\nend;\r\n\r\nprocedure TheTextDrawer.UpdateFontMetrics;\r\nvar\r\n  fm: QFontMetricsH;\r\n  ch: WideChar;\r\n  w: Integer;\r\n  fi: QFontInfoH;\r\n  family: UnicodeString;\r\nbegin\r\n  fi := QFontInfo_create(fBaseFont.Handle);\r\n  try\r\n    // make sure that the font object is refering to the same\r\n    // font that Qt is actually using, otherwise the width functions\r\n    // don't seem to work properly :(\r\n    if not QFontInfo_exactMatch(fi) then\r\n      begin\r\n        fBaseFont.Size := QFontInfo_pointSize(fi);\r\n        QFontInfo_family(fi, @family);\r\n        fBaseFont.Name := family;\r\n      end;\r\n  finally\r\n    QFontInfo_destroy(fi);\r\n  end;\r\n\r\n  fm := QFontMetrics_create(fBaseFont.Handle);\r\n  try\r\n    ch := 'W';\r\n\r\n    w := QFontMetrics_width(fm, @ch);\r\n    fCharWidth := w;\r\n    fCharHeight := QFontMetrics_height(fm);\r\n  finally\r\n    QFontMetrics_destroy(fm);\r\n  end;\r\n\r\n  ClearFontList;\r\nend;\r\n\r\n{ TCaret }\r\n\r\nconstructor TCaret.Create(AOwner: TWidgetControl; Width, Height: Integer);\r\nbegin\r\n  inherited Create(AOwner);\r\n  FRect.Right := Width;\r\n  FRect.Bottom := Height;\r\n  FOwnerCanvas := TControlCanvas.Create;\r\n  TControlCanvas(FOwnerCanvas).Control := AOwner;\r\nend;\r\n\r\ndestructor TCaret.Destroy;\r\nbegin\r\n  if CaretManager.CurrentCaret = Self then\r\n    CaretManager.CurrentCaret := nil;\r\n  FActive := False;\r\n  ForceInternalInvisible;\r\n  inherited Destroy;\r\n  FOwnerCanvas.Free;\r\nend;\r\n\r\nprocedure TCaret.ForceInternalInvisible;\r\nbegin\r\n  while FInternalShowCount >= 1 do InternalHide;\r\nend;\r\n\r\nprocedure TCaret.ForceInternalVisible;\r\nbegin\r\n  while FInternalShowCount <= 0 do InternalShow;\r\nend;\r\n\r\nfunction TCaret.GetTopLeft: TPoint;\r\nbegin\r\n  Result := FRect.TopLeft;\r\nend;\r\n\r\nprocedure TCaret.Hide;\r\nbegin\r\n  dec(FShowCount);\r\n  if FShowCount = 0 then\r\n  begin\r\n     FActive := False;\r\n    ForceInternalInvisible;\r\n  end;\r\nend;\r\n\r\nprocedure TCaret.InternalHide;\r\nbegin\r\n  dec(FInternalShowCount);\r\n  if FInternalShowCount = 0 then\r\n    Paint;\r\nend;\r\n\r\nprocedure TCaret.InternalShow;\r\nbegin\r\n  inc(FInternalShowCount);\r\n  if FInternalShowCount = 1 then\r\n    Paint;\r\nend;\r\n\r\nprocedure TCaret.Paint;\r\nvar\r\n  OldCopyMode: TCopyMode;\r\nbegin\r\n  if Assigned(Owner)then\r\n    with OwnerCanvas do\r\n    begin\r\n      OldCopyMode := CopyMode;\r\n      CopyMode := cmDstInvert;\r\n      CopyRect(FRect, OwnerCanvas, FRect);\r\n      CopyMode := OldCopyMode;\r\n    end;\r\nend;\r\n\r\nprocedure TCaret.SetTopLeft(const Value: TPoint);\r\nbegin\r\n  if (FRect.Left = Value.X) and (FRect.Top = Value.Y) then exit;\r\n\r\n  if FActive then InternalHide;\r\n  FRect.Right := FRect.Right + (Value.X - FRect.Left);\r\n  FRect.Left := Value.X;\r\n  FRect.Bottom := FRect.Bottom + (Value.Y - FRect.Top);\r\n  FRect.Top := Value.Y;\r\n  if FActive then\r\n  begin\r\n    ForceInternalVisible;\r\n    CaretManager.ResetTimer;\r\n  end;\r\nend;\r\n\r\nprocedure TCaret.Show;\r\nbegin\r\n  if FShowCount < 1 then\r\n  begin\r\n    inc(FShowCount);\r\n    if FShowCount = 1 then\r\n    begin\r\n      FActive := True;\r\n      ForceInternalVisible;\r\n      CaretManager.ResetTimer;\r\n    end;\r\n  end;\r\nend;\r\n\r\nprocedure TCaret.Toggle;\r\nbegin\r\n  if Active then\r\n    if Visible then InternalHide else InternalShow;\r\nend;\r\n\r\nfunction TCaret.Visible: Boolean;\r\nbegin\r\n  Result := FInternalShowCount > 0;\r\nend;\r\n\r\n{ TFontHolder }\r\n\r\nconstructor TFontHolder.Create(aFont: TFont; aStyle: TFontStyles);\r\nbegin\r\n  Font := aFont;\r\n  Style:= aStyle;\r\nend;\r\n\r\n{ TCaretManager }\r\n\r\nconstructor TCaretManager.Create;\r\nbegin\r\n  fBlinkTimer := TTimer.Create(nil);\r\n  fBlinkTimer.Enabled := False;\r\n  fBlinkTimer.Interval := QApplication_cursorFlashTime div 2;\r\n  fBlinkTimer.OnTimer := HandleTimer;\r\nend;\r\n\r\ndestructor TCaretManager.Destroy;\r\nbegin\r\n  fBlinkTimer.Free;\r\n  inherited Destroy;\r\nend;\r\n\r\nprocedure TCaretManager.HandleTimer(Sender: TObject);\r\nbegin\r\n  if Assigned(CurrentCaret) then\r\n    CurrentCaret.Toggle;\r\nend;\r\n\r\nprocedure TCaretManager.ResetTimer;\r\nbegin\r\n  fBlinkTimer.Enabled := False;\r\n  fBlinkTimer.Enabled := True;\r\nend;\r\n\r\nprocedure TCaretManager.SetCurrentCaret(const Value: TCaret);\r\nbegin\r\n  if fCurrentCaret <> Value then\r\n  begin\r\n    fCurrentCaret := Value;\r\n    fBlinkTimer.Enabled := (CurrentCaret <> nil) and CurrentCaret.Active;\r\n  end;\r\nend;\r\n\r\n{ TSynEditScrollBar }\r\n\r\nconstructor TSynEditScrollBar.Create(AOwner: TComponent);\r\nbegin\r\n  inherited Create(AOwner);\r\n  ControlStyle := ControlStyle + [csNoFocus];\r\n  TabStop := False;\r\n  Visible := False;\r\nend;\r\n\r\ninitialization\r\n  CaretManager := TCaretManager.Create;\r\nfinalization\r\n  CaretManager.Free;\r\nend.\r\n"
  },
  {
    "path": "External/VirtualTreeView/Source/VTAccessibility.pas",
    "content": "unit VTAccessibility;\r\n\r\n// This unit implements iAccessible interfaces for the VirtualTree visual components\r\n// and the currently focused node.\r\n//\r\n// Written by Marco Zehe. (c) 2007\r\n\r\ninterface\r\n\r\nuses\r\n  Winapi.Windows, System.Classes, Winapi.ActiveX, System.Types, Winapi.oleacc,\r\n  VirtualTrees, VTAccessibilityFactory, Vcl.Controls;\r\n\r\ntype\r\n  TVirtualTreeAccessibility = class(TInterfacedObject, IDispatch, IAccessible)\r\n  private\r\n    FVirtualTree: TVirtualStringTree;\r\n  public\r\n    constructor Create(AVirtualTree: TVirtualStringTree);\r\n\r\n    { IAccessibility }\r\n    function Get_accParent(out ppdispParent: IDispatch): HResult; stdcall;\r\n    function Get_accChildCount(out pcountChildren: Integer): HResult; stdcall;\r\n    function Get_accChild(varChild: OleVariant; out ppdispChild: IDispatch): HResult; stdcall;\r\n    function Get_accName(varChild: OleVariant; out pszName: WideString): HResult; stdcall;\r\n    function Get_accValue(varChild: OleVariant; out pszValue: WideString): HResult; stdcall;\r\n    function Get_accDescription(varChild: OleVariant; out pszDescription: WideString): HResult; stdcall;\r\n    function Get_accRole(varChild: OleVariant; out pvarRole: OleVariant): HResult; stdcall;\r\n    function Get_accState(varChild: OleVariant; out pvarState: OleVariant): HResult; stdcall;\r\n    function Get_accHelp(varChild: OleVariant; out pszHelp: WideString): HResult; stdcall;\r\n    function Get_accHelpTopic(out pszHelpFile: WideString; varChild: OleVariant;\r\n                              out pidTopic: Integer): HResult; stdcall;\r\n    function Get_accKeyboardShortcut(varChild: OleVariant; out pszKeyboardShortcut: WideString): HResult; stdcall;\r\n    function Get_accFocus(out pvarChild: OleVariant): HResult; stdcall;\r\n    function Get_accSelection(out pvarChildren: OleVariant): HResult; stdcall;\r\n    function Get_accDefaultAction(varChild: OleVariant; out pszDefaultAction: WideString): HResult; stdcall;\r\n    function accSelect(flagsSelect: Integer; varChild: OleVariant): HResult; stdcall;\r\n    function accLocation(out pxLeft: Integer; out pyTop: Integer; out pcxWidth: Integer;\r\n                         out pcyHeight: Integer; varChild: OleVariant): HResult; stdcall;\r\n    function accNavigate(navDir: Integer; varStart: OleVariant; out pvarEndUpAt: OleVariant): HResult; stdcall;\r\n    function accHitTest(xLeft: Integer; yTop: Integer; out pvarChild: OleVariant): HResult; stdcall;\r\n    function accDoDefaultAction(varChild: OleVariant): HResult; stdcall;\r\n    function Set_accName(varChild: OleVariant; const pszName: WideString): HResult; stdcall;\r\n    function Set_accValue(varChild: OleVariant; const pszValue: WideString): HResult; stdcall;\r\n    {IDispatch}\r\n    function GetIDsOfNames(const IID: TGUID; Names: Pointer;\r\n      NameCount: Integer; LocaleID: Integer; DispIDs: Pointer): HRESULT; stdcall;\r\n    function GetTypeInfo(Index: Integer; LocaleID: Integer;\r\n      out TypeInfo): HRESULT; stdcall;\r\n    function GetTypeInfoCount(out Count: Integer): HRESULT; stdcall;\r\n    function Invoke(DispID: Integer; const IID: TGUID; LocaleID: Integer;\r\n      Flags: Word; var Params; VarResult: Pointer; ExcepInfo: Pointer;\r\n      ArgErr: Pointer): HRESULT; stdcall;\r\n  end;\r\n\r\n  TVirtualTreeItemAccessibility = class(TVirtualTreeAccessibility, IAccessible)\r\n    public\r\n    { IAccessibility }\r\n    function Get_accParent(out ppdispParent: IDispatch): HResult; stdcall;\r\n    function Get_accChildCount(out pcountChildren: Integer): HResult; stdcall;\r\n    function Get_accChild(varChild: OleVariant; out ppdispChild: IDispatch): HResult; stdcall;\r\n    function Get_accName(varChild: OleVariant; out pszName: WideString): HResult; stdcall;\r\n    function Get_accValue(varChild: OleVariant; out pszValue: WideString): HResult; stdcall;\r\n    function Get_accDescription(varChild: OleVariant; out pszDescription: WideString): HResult; stdcall;\r\n    function Get_accRole(varChild: OleVariant; out pvarRole: OleVariant): HResult; stdcall;\r\n    function Get_accState(varChild: OleVariant; out pvarState: OleVariant): HResult; stdcall;\r\n    function accLocation(out pxLeft: Integer;\r\n      out pyTop: Integer; out pcxWidth: Integer;\r\n      out pcyHeight: Integer; varChild: OleVariant): HResult; stdcall;\r\n    function Get_accFocus(out pvarChild: OleVariant): HRESULT; stdcall;\r\n  end;\r\n\r\n  TVTMultiColumnItemAccessibility = class(TVirtualTreeItemAccessibility, IAccessible)\r\n  strict private\r\n    function GetItemDescription(varChild: OleVariant; out pszDescription: WideString; IncludeMainColumn: boolean): HResult; stdcall;\r\n  public\r\n    { IAccessibility }\r\n    function Get_accName(varChild: OleVariant; out pszName: WideString): HResult; stdcall;\r\n    function Get_accDescription(varChild: OleVariant; out pszDescription: WideString): HResult; stdcall;\r\n  end;\r\n\r\n  TVTDefaultAccessibleProvider = class(TInterfacedObject, IVTAccessibleProvider)\r\n  public\r\n    function CreateIAccessible(ATree: TBaseVirtualTree): IAccessible;\r\n  end;\r\n\r\n  TVTDefaultAccessibleItemProvider = class(TInterfacedObject, IVTAccessibleProvider)\r\n  public\r\n    function CreateIAccessible(ATree: TBaseVirtualTree): IAccessible;\r\n  end;\r\n\r\n  TVTMultiColumnAccessibleItemProvider = class(TInterfacedObject, IVTAccessibleProvider)\r\n  public\r\n    function CreateIAccessible(ATree: TBaseVirtualTree): IAccessible;\r\n  end;\r\n\r\nimplementation\r\n\r\nuses\r\n  System.SysUtils, Vcl.Forms, System.Variants, System.Math;\r\n\r\n{ TVirtualTreeAccessibility }\r\n//----------------------------------------------------------------------------------------------------------------------\r\nconstructor TVirtualTreeAccessibility.Create(AVirtualTree: TVirtualStringTree);\r\n// assigns the parent and current fields, and lets the control's IAccessible object know its address.\r\nbegin\r\n  inherited Create;\r\n  FVirtualTree := AVirtualTree;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TVirtualTreeAccessibility.accDoDefaultAction(varChild: OleVariant): HResult;\r\n// a default action is not supported.\r\nbegin\r\n  Result := DISP_E_MEMBERNOTFOUND;\r\nend;\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TVirtualTreeAccessibility.accHitTest(xLeft: Integer; yTop: Integer; out pvarChild: OleVariant): HResult;\r\n// returns the iAccessible object at the given point, if applicable.\r\nvar\r\n  Pt: TPoint;\r\n  HitInfo: THitInfo;\r\nbegin\r\n  Result := S_FALSE;\r\n  if FVirtualTree <> nil then\r\n  begin\r\n//    VariantInit(pvarChild);\r\n//    TVarData(pvarChild).VType := VT_I4;\r\n    Pt := fVirtualTree.ScreenToClient(Point(xLeft, yTop));\r\n    if fVirtualTree.FocusedNode <> nil then\r\n    begin\r\n      fVirtualTree.GetHitTestInfoAt(xLeft, yTop, false, HitInfo);\r\n      if FVirtualTree.FocusedNode = HitInfo.HitNode then\r\n      begin\r\n        pvarChild := FVirtualTree.AccessibleItem;\r\n        Result := S_OK;\r\n        exit;\r\n      end;\r\n    end;\r\n    if PtInRect(FVirtualTree.BoundsRect, Pt) then\r\n    begin\r\n      pvarChild := CHILDID_SELF;\r\n      Result := S_OK;\r\n    end;\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\nfunction TVirtualTreeAccessibility.accLocation(out pxLeft: Integer;\r\n  out pyTop: Integer; out pcxWidth: Integer;\r\n  out pcyHeight: Integer; varChild: OleVariant): HResult;\r\n// returns the location of the VirtualStringTree object.\r\nvar\r\n  P: TPoint;\r\nbegin\r\n  Result := S_FALSE;\r\n  if varChild = CHILDID_SELF then\r\n  begin\r\n    if FVirtualTree <> nil then\r\n    begin\r\n      P := FVirtualTree.ClientToScreen(FVirtualTree.ClientRect.TopLeft);\r\n      pxLeft := P.X;\r\n      pyTop := P.Y;\r\n      pcxWidth := FVirtualTree.Width;\r\n      pcyHeight := FVirtualTree.Height;\r\n      Result := S_OK;\r\n    end;\r\n  end\r\n  else if VarType(varchild) = VT_I4 then\r\n  begin\r\n    // return the location of the focused node\r\n    if (FVirtualTree <> nil) and (FVirtualTree.AccessibleItem <> nil) then\r\n    begin\r\n      Result := FVirtualTree.AccessibleItem.accLocation(pxLeft, pyTop, pcxWidth, pcyHeight, CHILDID_SELF);\r\n    end;\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\nfunction TVirtualTreeAccessibility.accNavigate(navDir: Integer; varStart: OleVariant;\r\n  out pvarEndUpAt: OleVariant): HResult;\r\n// This is not supported.\r\nbegin\r\n  Result := DISP_E_MEMBERNOTFOUND;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\nfunction TVirtualTreeAccessibility.Get_accSelection(out pvarChildren: OleVariant): HResult;\r\n// returns the selected child ID, if any.\r\nbegin\r\n  Result := s_false;\r\n  if FVirtualTree <> nil then\r\n    if fVirtualTree.FocusedNode <> nil then\r\n    begin\r\n      pvarChildren := 1;\r\n      result := s_OK;\r\n    end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\nfunction TVirtualTreeAccessibility.GetIDsOfNames(const IID: TGUID;\r\n  Names: Pointer; NameCount, LocaleID: Integer; DispIDs: Pointer): HRESULT;\r\n// Not supported.\r\nbegin\r\n  Result := E_NOTIMPL;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\nfunction TVirtualTreeAccessibility.GetTypeInfo(Index, LocaleID: Integer;\r\n  out TypeInfo): HRESULT;\r\n// not supported.\r\nbegin\r\n  Result := E_NOTIMPL;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\nfunction TVirtualTreeAccessibility.GetTypeInfoCount(\r\n  out Count: Integer): HRESULT;\r\n// not supported.\r\nbegin\r\n  Result := E_NOTIMPL;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\nfunction TVirtualTreeAccessibility.Get_accChild(varChild: OleVariant; out ppdispChild: IDispatch): HResult;\r\n// returns the iAccessible child, whicfh represents the focused item.\r\nbegin\r\n  if varChild = CHILDID_SELF then\r\n  begin\r\n    ppdispChild := FVirtualTree.AccessibleItem;\r\n    Result := S_OK;\r\n  end\r\n  else\r\n    Result := E_INVALIDARG\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\nfunction TVirtualTreeAccessibility.Get_accChildCount(out pcountChildren: Integer): HResult;\r\n// Returns the number 1 for the one child: The focused item.\r\nbegin\r\n  pcountChildren := 1;\r\n  Result := S_OK;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\nfunction TVirtualTreeAccessibility.Get_accDefaultAction(varChild: OleVariant; out pszDefaultAction: WideString): HResult;\r\n// Not supported.\r\nbegin\r\n  Result := DISP_E_MEMBERNOTFOUND;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\nfunction TVirtualTreeAccessibility.Get_accDescription(varChild: OleVariant; out pszDescription: WideString): HResult;\r\n// returns the hint of the control, if assigned.\r\nbegin\r\n  pszDescription := '';\r\n  Result := S_FALSE;\r\n  if varChild = CHILDID_SELF then\r\n  begin\r\n    if FVirtualTree <> nil then\r\n      pszDescription := GetLongHint(fVirtualTree.Hint);\r\n  end;\r\n  if Length(pszDescription) > 0 then\r\n    Result := S_OK;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\nfunction TVirtualTreeAccessibility.Get_accFocus(out pvarChild: OleVariant): HResult;\r\n// returns the child ID of 1, if assigned.\r\nbegin\r\n  Result := s_false;\r\n  if fVirtualTree <> nil then\r\n  begin\r\n    if FVirtualTree.FocusedNode <> nil then\r\n      pvarChild := FVirtualTree.AccessibleItem\r\n    else\r\n      pvarChild := childid_self;\r\n      result := S_OK;\r\n    end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\nfunction TVirtualTreeAccessibility.Get_accHelp(varChild: OleVariant; out pszHelp: WideString): HResult;\r\n// Not supported.\r\nbegin\r\n  Result := DISP_E_MEMBERNOTFOUND;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\nfunction TVirtualTreeAccessibility.Get_accHelpTopic(out pszHelpFile: WideString; varChild: OleVariant;\r\n                          out pidTopic: Integer): HResult;\r\n// Returns the HelpContext ID, if present. \r\nbegin\r\n  pszHelpFile := '';\r\n  pidTopic := 0;\r\n  Result := S_OK;\r\n  if varChild = CHILDID_SELF then\r\n    if FVirtualTree <> nil then\r\n    begin\r\n      pszHelpFile := Application.HelpFile;\r\n      pidTopic := FVirtualTree.HelpContext;\r\n    end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\nfunction TVirtualTreeAccessibility.Get_accKeyboardShortcut(varChild: OleVariant; out pszKeyboardShortcut: WideString): HResult;\r\n// Not supported.\r\nbegin\r\n  pszKeyboardShortcut := '';\r\n  Result := S_FALSE;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\nfunction TVirtualTreeAccessibility.Get_accName(varChild: OleVariant; out pszName: WideString): HResult;\r\n// if set, returns the new published AccessibleName property.\r\n// if not set, tries the name and class name properties.\r\n// otherwise, returns the default text.\r\nbegin\r\n  pszName := '';\r\n  Result := S_FALSE;\r\n  if varChild = CHILDID_SELF then\r\n  begin\r\n    if FVirtualTree <> nil then\r\n    begin\r\n      if FVirtualTree.AccessibleName <> '' then\r\n        pszName := FVirtualTree.AccessibleName\r\n      else if FVirtualTree.Name <> '' then\r\n        pszName := FVirtualTree.Name\r\n      else if FVirtualTree.ClassName <> '' then\r\n        pszName := FVirtualTree.ClassName\r\n      else\r\n        PSZName := FVirtualTree.DefaultText;\r\n      result := S_OK;\r\n    end;\r\n  end\r\n  else if varType(varChild) = VT_I4 then\r\n  begin\r\n    // return the name for the inner accessible item\r\n    if (FVirtualTree <> nil) and (FVirtualTree.AccessibleItem <> nil) then\r\n    begin\r\n      Result := FVirtualTree.AccessibleItem.Get_accName(CHILDID_SELF, pszName);\r\n    end;\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\nfunction TVirtualTreeAccessibility.Get_accParent(out ppdispParent: IDispatch): HResult;\r\n// Returns false, the tree itself does not have a parent.\r\nvar\r\n  hParent: HWND;\r\nbegin\r\n  Result := E_INVALIDARG;\r\n  ppdispParent := nil;\r\n\r\n  // Addition - Simon Moscrop 7/5/2009\r\n  if (FVirtualTree.HandleAllocated) then\r\n  begin\r\n    (* return the accesible object from the 'parent' which is the window of the\r\n       tree itself! (This doesn't initially appear correct but it seems to\r\n       be exactly what all the other controls do! To verfify try pointing the\r\n       ms accessibility explorer at a simple button control which has been dropped\r\n       onto a form.\r\n       *)\r\n    hParent := FVirtualTree.Handle;\r\n    RESULT := AccessibleObjectFromWindow(hParent,CHILDID_SELF,IID_IAccessible,pointeR(ppDispParent));\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\nfunction TVirtualTreeAccessibility.Get_accRole(varChild: OleVariant; out pvarRole: OleVariant): HResult;\r\n// tells MSAA that it is a TreeView.\r\nbegin\r\n  Result := S_OK;\r\n//  VariantInit(pvarRole);\r\n//  TVarData(pvarRole).VType := VT_I4;\r\n  if varChild = CHILDID_SELF then\r\n  begin\r\n    if FVirtualTree <> nil then\r\n      pvarRole := ROLE_SYSTEM_OUTLINE;\r\n  end\r\n  else if VarType(varChild) = VT_I4 then\r\n  begin\r\n    // return the role of the inner accessible object\r\n    if (FVirtualTree <> nil) and (FVirtualTree.FocusedNode <> nil) then\r\n      pvarRole := ROLE_SYSTEM_OUTLINEITEM\r\n    else\r\n      RESULT := S_FALSE;\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\nfunction TVirtualTreeAccessibility.accSelect(flagsSelect: Integer; varChild: OleVariant): HResult;\r\nvar\r\n  lIndexToSelect: Cardinal;\r\n  i: Integer;\r\n  lNode: PVirtualNode;\r\nbegin\r\n  lIndexToSelect := varChild;\r\n  if lIndexToSelect >= Self.FVirtualTree.TotalCount then\r\n    Exit(E_INVALIDARG);\r\n  lNode := FVirtualTree.GetFirst();\r\n  for i := 0 to Integer(lIndexToSelect) - 1 do\r\n    lNode := FVirtualTree.GetNext(lNode);\r\n  Result := E_NOTIMPL;\r\n  if (flagsSelect and SELFLAG_TAKEFOCUS) <> 0then begin\r\n    FVirtualTree.FocusedNode := lNode;\r\n    Result := S_OK;\r\n  end;//if SELFLAG_TAKEFOCUS\r\n  if (flagsSelect and SELFLAG_TAKESELECTION) <> 0 then begin\r\n    FVirtualTree.ClearSelection();\r\n    FVirtualTree.Selected[lNode] := True;\r\n    Result := S_OK;\r\n  end;//if SELFLAG_TAKEFOCUS\r\n  if (flagsSelect and SELFLAG_ADDSELECTION) <> 0 then begin\r\n    FVirtualTree.Selected[lNode] := True;\r\n    Result := S_OK;\r\n  end;\r\n  if (flagsSelect and SELFLAG_REMOVESELECTION) <> 0 then begin\r\n    FVirtualTree.Selected[lNode] := False;\r\n    Result := S_OK;\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\nfunction TVirtualTreeAccessibility.Get_accState(varChild: OleVariant; out pvarState: OleVariant): HResult;\r\n// returns the state of the control.\r\nconst\r\n  IsEnabled: array[Boolean] of Integer = (STATE_SYSTEM_UNAVAILABLE, 0);\r\n  HasPopup: array[Boolean] of Integer = (0, STATE_SYSTEM_HASPOPUP);\r\n  IsVisible: array[Boolean] of Integer = (STATE_SYSTEM_INVISIBLE, 0);\r\nbegin\r\n  Result := S_OK;\r\n//  VariantInit(pvarState);\r\n//  TVarData(pvarState).VType := VT_I4;\r\n  if varChild = CHILDID_SELF then\r\n  begin\r\n    if FVirtualTree <> nil then\r\n    begin\r\n      pvarState := STATE_SYSTEM_FOCUSED or STATE_SYSTEM_FOCUSABLE or STATE_SYSTEM_HOTTRACKED;\r\n      pvarState := pvarState or IsVisible[FVirtualTree.Visible];\r\n      pvarState := pvarState or IsEnabled[FVirtualTree.Enabled];\r\n    end\r\n    else\r\n      Result := E_INVALIDARG;\r\n  end\r\n  else if VarType(VarChild) = VT_I4 then\r\n  begin\r\n    // return the state of the inner accessible item\r\n    if (FVirtualTree <> nil) and (FVirtualTree.AccessibleItem <> nil) then\r\n    begin\r\n      Result := FVirtualTree.AccessibleItem.Get_accState(CHILDID_SELF, pVarState);\r\n    end\r\n    else\r\n      RESULT := E_INVALIDARG;\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\nfunction TVirtualTreeAccessibility.Get_accValue(varChild: OleVariant; out pszValue: WideString): HResult;\r\n// the TreeView control itself does not have a value, returning false here.\r\nbegin\r\n  RESULT := S_FALSE;\r\n  \r\n  pszValue := '';\r\n  if VarType(varChild) = VT_I4 then\r\n    if varChild = CHILDID_SELF then\r\n       Result := S_FALSE\r\n    else if (FVirtualTree <> nil) and (FVirtualTree.AccessibleItem <> nil) then\r\n      RESULT := FVirtualTree.AccessibleItem.Get_accValue(CHILDID_SELF,pszValue);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\nfunction TVirtualTreeAccessibility.Invoke(DispID: Integer; const IID: TGUID;\r\n  LocaleID: Integer; Flags: Word; var Params; VarResult, ExcepInfo,\r\n  ArgErr: Pointer): HRESULT;\r\n// not supported.\r\nbegin\r\n  Result := E_NOTIMPL;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\nfunction TVirtualTreeAccessibility.Set_accName(varChild: OleVariant; const pszName: WideString): HResult; stdcall;\r\n// not supported.\r\nbegin\r\n  Result := DISP_E_MEMBERNOTFOUND;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\nfunction TVirtualTreeAccessibility.Set_accValue(varChild: OleVariant; const pszValue: WideString): HResult;\r\n// not supported.\r\nbegin\r\n  Result := DISP_E_MEMBERNOTFOUND\r\nend;\r\n\r\n{ TVirtualTreeItemAccessibility }\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\nfunction TVirtualTreeItemAccessibility.accLocation(out pxLeft, pyTop, pcxWidth,\r\n  pcyHeight: Integer; varChild: OleVariant): HResult;\r\n// returns the location of the current accessible item.\r\nvar\r\n  P: TPoint;\r\n  DisplayRect: TRect;\r\nbegin\r\n  Result := S_FALSE;\r\n  if varChild = CHILDID_SELF then\r\n  begin\r\n    if FVirtualTree.FocusedNode <> nil then\r\n    begin\r\n      DisplayRect := FVirtualTree.GetDisplayRect(FVirtualTree.FocusedNode, FVirtualTree.Header.Columns.GetFirstVisibleColumn, True, False);//Use first visible column instead of -1\r\n      P := FVirtualTree.ClientToScreen(DisplayRect.TopLeft);\r\n      pxLeft := P.X;\r\n      pyTop := P.Y;\r\n      pcxWidth := DisplayRect.Right - DisplayRect.Left;\r\n      pcyHeight := DisplayRect.Bottom - DisplayRect.Top;\r\n      Result := S_OK;\r\n    end;\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\nfunction TVirtualTreeItemAccessibility.Get_accChild(varChild: OleVariant; out ppdispChild: IDispatch): HResult;\r\n// the item does not have children. Returning false.\r\nbegin\r\n  ppdispChild := nil;\r\n  Result := S_FALSE;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\nfunction TVirtualTreeItemAccessibility.Get_accChildCount(out pcountChildren: Integer): HResult;\r\n// the item itself does not have children, returning 0.\r\nbegin\r\n  pcountChildren := 0;\r\n  Result := S_OK;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\nfunction TVirtualTreeItemAccessibility.Get_accDescription(varChild: OleVariant; out pszDescription: WideString): HResult;\r\n// not supported for an item.\r\nbegin\r\n  Result := DISP_E_MEMBERNOTFOUND;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\nfunction TVirtualTreeItemAccessibility.Get_accFocus(out pvarChild: OleVariant): HResult;\r\nbegin\r\n  // must override this or we get an infinite loop when using MS narrator\r\n  // when navigating using the arrow keys.\r\n  RESULT := S_FALSE;\r\n  if FVirtualTree.FocusedNode <> nil then\r\n  begin\r\n    pvarChild := CHILDID_SELF;\r\n    RESULT := S_OK;\r\n  end;\r\nend;\r\n\r\nfunction TVirtualTreeItemAccessibility.Get_accName(varChild: OleVariant; out pszName: WideString): HResult;\r\n// the name is the node's caption.\r\nvar\r\n  kind: TVTImageKind;\r\n  ImgText: WideString;\r\nbegin\r\n  pszName := '';\r\n  Result := S_FALSE;\r\n  if varChild = childid_self then\r\n  begin\r\n    if FVirtualTree <> nil then\r\n      if FVirtualTree.FocusedNode <> nil then\r\n      begin\r\n        for kind := ikNormal to ikOverlay do\r\n        begin\r\n          ImgText := FVirtualTree.ImageText[FVirtualTree.FocusedNode, Kind, FVirtualTree.Header.MainColumn];\r\n          if ImgText <> '' then\r\n            pszName := pszName + ImgText  + '  ';\r\n        end;\r\n        pszName := pszName + FVirtualTree.Text[FVirtualTree.FocusedNode, FVirtualTree.Header.MainColumn];\r\n        result := S_OK;\r\n      end\r\n      else begin\r\n        PSZName := FVirtualTree.DefaultText;\r\n        result := S_OK;\r\n      end;\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\nfunction TVirtualTreeItemAccessibility.Get_accParent(out ppdispParent: IDispatch): HResult;\r\n// tells MSAA that the VritualStringTree is its parent.\r\nbegin\r\n  result := S_FALSE;\r\n  if FVirtualTree <> nil then\r\n  begin\r\n    ppdispParent := FVirtualTree.Accessible;\r\n    Result := S_OK;\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\nfunction TVirtualTreeItemAccessibility.Get_accRole(varChild: OleVariant; out pvarRole: OleVariant): HResult;\r\n// tells MSAA that it is a TreeView item as opposed to the TreeView itself.\r\nbegin\r\n  Result := S_OK;\r\n//  VariantInit(pvarRole);\r\n//  TVarData(pvarRole).VType := VT_I4;\r\n  if varChild = childid_self then\r\n  begin\r\n    if FVirtualTree <> nil then\r\n      pvarRole := ROLE_SYSTEM_OUTLINEITEM;\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\nfunction TVirtualTreeItemAccessibility.Get_accState(varChild: OleVariant; out pvarState: OleVariant): HResult;\r\n// Tells MSAA the state the item is in.\r\nconst\r\n  IsEnabled: array[Boolean] of Integer = (STATE_SYSTEM_UNAVAILABLE, 0);\r\n  HasPopup: array[Boolean] of Integer = (0, STATE_SYSTEM_HASPOPUP);\r\n  IsVisible: array[Boolean] of Integer = (STATE_SYSTEM_INVISIBLE, 0);\r\n  IsChecked: array[Boolean] of Integer = (0, STATE_SYSTEM_CHECKED);\r\n  IsExpanded: array[Boolean] of Integer = (0, STATE_SYSTEM_EXPANDED);\r\n  IsCollapsed: array[Boolean] of Integer = (0, STATE_SYSTEM_COLLAPSED);\r\nbegin\r\n  Result := S_OK;\r\n//  VariantInit(pvarState);\r\n//  TVarData(pvarState).VType := VT_I4;\r\n  if varChild = childid_self then\r\n  begin\r\n    if FVirtualTree <> nil then\r\n    begin\r\n      pvarState := STATE_SYSTEM_FOCUSED or STATE_SYSTEM_FOCUSABLE or STATE_SYSTEM_HOTTRACKED;\r\n      pvarState := pvarState or IsVisible[FVirtualTree.Visible];\r\n      pvarState := pvarState or IsEnabled[FVirtualTree.Enabled];\r\n      if fVirtualTree.FocusedNode <> nil then\r\n      begin\r\n        pvarState := pvarState or IsChecked[csCheckedNormal = FVirtualTree.FocusedNode.CheckState];\r\n        pvarState := pvarState or IsExpanded[VSExpanded in FVirtualTree.FocusedNode.States];\r\n        if not (vsExpanded in FVirtualTree.FocusedNode.States) then\r\n          pvarState:= PvarState or IsCollapsed[vsHasChildren in FVirtualTree.FocusedNode.States];\r\n     end;\r\n    end\r\n    else\r\n      Result := E_INVALIDARG;\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\nfunction TVirtualTreeItemAccessibility.Get_accValue(varChild: OleVariant; out pszValue: WideString): HResult;\r\n// for a TreeView item, the value is the nesting level number, 0-based.\r\nbegin\r\n  pszValue := '';\r\n  Result := S_FALSE;\r\n  if varChild = childid_self then\r\n    if FVirtualTree <> nil then\r\n      if FVirtualTree.FocusedNode <> nil then\r\n      begin\r\n        PSZValue := IntToStr(FVirtualTree.GetNodeLevel(FVirtualTree.FocusedNode));\r\n        result := S_OK;\r\n      end;\r\nend;\r\n\r\n{ TVTMultiColumnItemAccessibility }\r\n\r\nfunction TVTMultiColumnItemAccessibility.GetItemDescription(\r\n  varChild: OleVariant; out pszDescription: WideString;\r\n  IncludeMainColumn: boolean): HResult;\r\nvar\r\n  I: Integer;\r\n  ImgText: WideString;\r\n  kind: TVTImageKind;\r\nbegin\r\n  pszDescription := '';\r\n  Result := S_FALSE;\r\n  if varChild = childid_self then\r\n  begin\r\n    if FVirtualTree <> nil then\r\n      if FVirtualTree.FocusedNode <> nil then\r\n      begin\r\n        if IncludeMainColumn then\r\n        begin\r\n          for kind := ikNormal to ikOverlay do\r\n          begin\r\n            ImgText := FVirtualTree.ImageText[FVirtualTree.FocusedNode, Kind, FVirtualTree.Header.MainColumn];\r\n            if ImgText <> '' then\r\n              ImgText := ImgText + '  ';\r\n          end;\r\n          pszDescription := ImgText + FVirtualTree.Text[FVirtualTree.FocusedNode, FVirtualTree.Header.MainColumn] + '; ';\r\n        end;\r\n        for I := 0 to FVirtualTree.Header.Columns.Count - 1 do\r\n          if (FVirtualTree.Header.MainColumn <> I) and (coVisible in FVirtualTree.Header.Columns[I].Options) then\r\n          begin\r\n            for kind := ikNormal to ikOverlay do\r\n            begin\r\n              ImgText := FVirtualTree.ImageText[FVirtualTree.FocusedNode, Kind, I];\r\n              if ImgText <> '' then\r\n                ImgText := ImgText + '  ';\r\n            end;\r\n            ImgText := ImgText + FVirtualTree.Text[FVirtualTree.FocusedNode, I];\r\n            if ImgText <> '' then\r\n              pszDescription := pszDescription\r\n               +FVirtualTree.Header.Columns[I].Text\r\n               +': '\r\n               + ImgText\r\n               +'; ';\r\n          end;\r\n          if pszDescription <> '' then\r\n            if pszDescription[Length(pszDescription)-1] = ';' then\r\n              Delete(pszDescription, length(pszDescription)-1, 2);\r\n        result := S_OK;\r\n      end\r\n      else begin\r\n        PSZDescription := FVirtualTree.DefaultText;\r\n        result := S_OK;\r\n      end;\r\n  end;\r\nend;\r\n\r\nfunction TVTMultiColumnItemAccessibility.Get_accDescription(\r\n  varChild: OleVariant; out pszDescription: WideString): HResult;\r\nbegin\r\n  result := GetItemDescription(varChild, pszDescription, false)\r\nend;\r\n\r\nfunction TVTMultiColumnItemAccessibility.Get_accName(varChild: OleVariant;\r\n  out pszName: WideString): HResult;\r\nbegin\r\n  result := GetItemDescription(varChild, pszName, true)\r\nend;\r\n\r\n{ TVTDefaultAccessibleProvider }\r\n\r\nfunction TVTDefaultAccessibleProvider.CreateIAccessible(ATree: TBaseVirtualTree): IAccessible;\r\nbegin\r\n  result := TVirtualTreeAccessibility.Create(TVirtualStringTree(ATree));\r\nend;\r\n\r\n{ TVTDefaultAccessibleItemProvider }\r\n\r\nfunction TVTDefaultAccessibleItemProvider.CreateIAccessible(ATree: TBaseVirtualTree): IAccessible;\r\nbegin\r\n  result := TVirtualTreeItemAccessibility.Create(TVirtualStringTree(ATree));\r\nend;\r\n\r\n{ TVTMultiColumnAccessibleItemProvider }\r\n\r\nfunction TVTMultiColumnAccessibleItemProvider.CreateIAccessible(ATree: TBaseVirtualTree): IAccessible;\r\nbegin\r\n  result := nil;\r\n  if TVirtualStringTree(ATree).Header.UseColumns then\r\n    result := TVTMultiColumnItemAccessibility.Create(TVirtualStringTree(ATree));\r\nend;\r\n\r\nvar\r\n  DefaultAccessibleProvider: TVTDefaultAccessibleProvider;\r\n  DefaultAccessibleItemProvider: TVTDefaultAccessibleItemProvider;\r\n  MultiColumnAccessibleProvider: TVTMultiColumnAccessibleItemProvider;\r\n\r\ninitialization\r\n  if DefaultAccessibleProvider = nil then\r\n  begin\r\n    DefaultAccessibleProvider := TVTDefaultAccessibleProvider.Create;\r\n    TVTAccessibilityFactory.GetAccessibilityFactory.RegisterAccessibleProvider(DefaultAccessibleProvider);\r\n  end;\r\n  if DefaultAccessibleItemProvider = nil then\r\n  begin\r\n    DefaultAccessibleItemProvider := TVTDefaultAccessibleItemProvider.Create;\r\n    TVTAccessibilityFactory.GetAccessibilityFactory.RegisterAccessibleProvider(DefaultAccessibleItemProvider);\r\n  end;\r\n  if MultiColumnAccessibleProvider = nil then\r\n  begin\r\n    MultiColumnAccessibleProvider := TVTMultiColumnAccessibleItemProvider.Create;\r\n    TVTAccessibilityFactory.GetAccessibilityFactory.RegisterAccessibleProvider(MultiColumnAccessibleProvider);\r\n  end;\r\nfinalization\r\n  TVTAccessibilityFactory.GetAccessibilityFactory.UnRegisterAccessibleProvider(MultiColumnAccessibleProvider);\r\n  MultiColumnAccessibleProvider := nil;\r\n  TVTAccessibilityFactory.GetAccessibilityFactory.UnRegisterAccessibleProvider(DefaultAccessibleItemProvider);\r\n  DefaultAccessibleItemProvider := nil;\r\n  TVTAccessibilityFactory.GetAccessibilityFactory.UnRegisterAccessibleProvider(DefaultAccessibleProvider);\r\n  DefaultAccessibleProvider := nil;\r\n\r\nend.\r\n\r\n\r\n\r\n"
  },
  {
    "path": "External/VirtualTreeView/Source/VTAccessibilityFactory.pas",
    "content": "unit VTAccessibilityFactory;\r\n\r\n// The contents of this file are subject to the Mozilla Public License\r\n// Version 1.1 (the \"License\"); you may not use this file except in compliance\r\n// with the License. You may obtain a copy of the License at http://www.mozilla.org/MPL/\r\n//\r\n// Alternatively, you may redistribute this library, use and/or modify it under the terms of the\r\n// GNU Lesser General Public License as published by the Free Software Foundation;\r\n// either version 2.1 of the License, or (at your option) any later version.\r\n// You may obtain a copy of the LGPL at http://www.gnu.org/copyleft/.\r\n//\r\n// Software distributed under the License is distributed on an \"AS IS\" basis,\r\n// WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for the\r\n// specific language governing rights and limitations under the License.\r\n//\r\n// The original code is VirtualTrees.pas, released September 30, 2000.\r\n//\r\n// The initial developer of the original code is digital publishing AG (Munich, Germany, www.digitalpublishing.de),\r\n// written by Mike Lischke (public@soft-gems.net, www.soft-gems.net).\r\n//\r\n// Portions created by digital publishing AG are Copyright\r\n// (C) 1999-2001 digital publishing AG. All Rights Reserved.\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\n\r\n// class to create IAccessibles for the tree passed into it.\r\n// If not already assigned, creates IAccessibles for the tree itself\r\n// and the focused item\r\n// the tree accessible is returned when the tree receives an WM_GETOBJECT message\r\n// the AccessibleItem is returned when the Accessible is being asked for the first child\r\n// To create your own IAccessibles, use the VTStandardAccessible unit as a reference,\r\n// and assign your Accessibles to the variables in the unit's initialization.\r\n// You only need to add the unit to your project, and voil, you have an accessible string tree!\r\n//\r\n// Written by Marco Zehe. (c) 2007\r\n\r\ninterface\r\n\r\nuses\r\n  System.Classes, Winapi.oleacc, VirtualTrees;\r\n\r\ntype\r\n  IVTAccessibleProvider = interface\r\n    function CreateIAccessible(ATree: TBaseVirtualTree): IAccessible;\r\n  end;\r\n\r\n  TVTAccessibilityFactory = class(TObject)\r\n  strict private class var\r\n    FAccessibilityAvailable: Boolean;\r\n    FVTAccessibleFactory: TVTAccessibilityFactory;\r\n  strict private\r\n    FAccessibleProviders: TInterfaceList;\r\n  private\r\n    class procedure FreeFactory;\r\n  public\r\n    constructor Create;\r\n    destructor Destroy; override;\r\n    function CreateIAccessible(ATree: TBaseVirtualTree): IAccessible;\r\n    class function GetAccessibilityFactory: TVTAccessibilityFactory; static;\r\n    procedure RegisterAccessibleProvider(const AProvider: IVTAccessibleProvider);\r\n    procedure UnRegisterAccessibleProvider(const AProvider: IVTAccessibleProvider);\r\n  end;\r\n\r\n  \r\nimplementation\r\n\r\n{ TVTAccessibilityFactory }\r\n\r\nconstructor TVTAccessibilityFactory.Create;\r\nbegin\r\n  inherited Create;\r\n  FAccessibleProviders := TInterfaceList.Create;\r\n  FAccessibleProviders.Clear;\r\nend;\r\n\r\nfunction TVTAccessibilityFactory.CreateIAccessible(\r\n  ATree: TBaseVirtualTree): IAccessible;\r\nvar\r\n  I: Integer;\r\n  TmpIAccessible: IAccessible;\r\n// returns an IAccessible.\r\n// 1. If the Accessible property of the passed-in tree is nil,\r\n// the first registered element will be returned.\r\n// Usually, this is the IAccessible that provides information about the tree itself.\r\n// If it is not nil, we'll check whether the AccessibleItem is nil.\r\n// If it is, we'll look in the registered IAccessibles for the appropriate one.\r\n// Each IAccessibleProvider will check the tree for properties to determine whether it is responsible.\r\n// We'll work top to bottom, from the most complicated to the most simple.\r\n// The index for these should all be greater than 0, e g the IAccessible for the tree itself should always be registered first, then any IAccessible items.\r\nbegin\r\n  Result := nil;\r\n  if ATree <> nil then\r\n  begin\r\n    if ATree.Accessible = nil then\r\n    begin\r\n      if FAccessibleProviders.Count > 0 then\r\n      begin\r\n        Result := IVTAccessibleProvider(FAccessibleProviders.Items[0]).CreateIAccessible(ATree);\r\n        Exit;\r\n      end;\r\n    end;\r\n    if ATree.AccessibleItem = nil then\r\n    begin\r\n      if FAccessibleProviders.Count > 0 then\r\n      begin\r\n        for I := FAccessibleProviders.Count - 1 downto 1 do\r\n        begin\r\n          TmpIAccessible := IVTAccessibleProvider(FAccessibleProviders.Items[I]).CreateIAccessible(ATree);\r\n          if TmpIAccessible <> nil then\r\n          begin\r\n            Result := TmpIAccessible;\r\n            Break;\r\n          end;\r\n        end;\r\n        if TmpIAccessible = nil then\r\n        begin\r\n          Result := IVTAccessibleProvider(FAccessibleProviders.Items[0]).CreateIAccessible(ATree);\r\n        end;\r\n      end;\r\n    end\r\n    else\r\n      Result := ATree.AccessibleItem;\r\n  end;\r\nend;\r\n\r\ndestructor TVTAccessibilityFactory.Destroy;\r\nbegin\r\n  FAccessibleProviders.Free;\r\n  FAccessibleProviders := nil;\r\n  inherited Destroy;\r\nend;\r\n\r\nclass procedure TVTAccessibilityFactory.FreeFactory;\r\nbegin\r\n  FVTAccessibleFactory.Free;\r\nend;\r\n\r\nprocedure TVTAccessibilityFactory.RegisterAccessibleProvider(const AProvider: IVTAccessibleProvider);\r\n// Ads a provider if it is not already registered\r\nbegin\r\n  if FAccessibleProviders.IndexOf(AProvider) < 0 then\r\n    FAccessibleProviders.Add(AProvider)\r\nend;\r\n\r\nprocedure TVTAccessibilityFactory.UnRegisterAccessibleProvider(const AProvider: IVTAccessibleProvider);\r\n// Unregisters/removes an IAccessible provider if it is present\r\nbegin\r\n  if FAccessibleProviders.IndexOf(AProvider) >= 0 then\r\n    FAccessibleProviders.Remove(AProvider);\r\nend;\r\n\r\nclass function TVTAccessibilityFactory.GetAccessibilityFactory: TVTAccessibilityFactory;\r\n// Accessibility helper function to create a singleton class that will create or return\r\n// the IAccessible interface for the tree and the focused node.\r\n\r\nbegin\r\n  // first, check if we've loaded the library already\r\n  if not FAccessibilityAvailable then\r\n    FAccessibilityAvailable := True;\r\n  if FAccessibilityAvailable then\r\n  begin\r\n    // Check to see if the class has already been created.\r\n    if FVTAccessibleFactory = nil then\r\n      FVTAccessibleFactory := TVTAccessibilityFactory.Create;\r\n    Result := FVTAccessibleFactory;\r\n  end\r\n  else\r\n    Result := nil;\r\nend;\r\n\r\ninitialization\r\n\r\nfinalization\r\n  TVTAccessibilityFactory.FreeFactory;\r\n\r\nend.\r\n\r\n\r\n"
  },
  {
    "path": "External/VirtualTreeView/Source/VTHeaderPopup.pas",
    "content": "unit VTHeaderPopup;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n//\r\n// Version 4.7.0\r\n//\r\n// The contents of this file are subject to the Mozilla Public License\r\n// Version 1.1 (the \"License\"); you may not use this file except in\r\n// compliance with the License. You may obtain a copy of the License at\r\n// http://www.mozilla.org/MPL/\r\n//\r\n// Alternatively, you may redistribute this library, use and/or modify it under the terms of the\r\n// GNU Lesser General Public License as published by the Free Software Foundation;\r\n// either version 2.1 of the License, or (at your option) any later version.\r\n// You may obtain a copy of the LGPL at http://www.gnu.org/copyleft/.\r\n//\r\n// Software distributed under the License is distributed on an \"AS IS\"\r\n// basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the\r\n// License for the specific language governing rights and limitations\r\n// under the License.\r\n//\r\n// The Original Code is VTHeaderPopup.pas.\r\n//\r\n// The Initial Developer of the Original Code is Ralf Junker . All Rights Reserved.\r\n//\r\n// September 2004:\r\n//  - Bug fix: TVTHeaderPopupMenu.OnMenuItemClick used the wrong Tag member for the event.\r\n// \r\n// Modified 12 Dec 2003 by Ralf Junker .\r\n//   - Added missing default storage specifier for Options property.\r\n//   - To avoid mixing up image lists of different trees sharing the same header \r\n//     popup, set the popup's image list to nil if hoShowImages is not in the \r\n//     tree's header options.\r\n//   - Added an additional check for the PopupComponent property before casting \r\n//     it hardly to a Virtual Treeview in OnMenuItemClick. See entry 31 Mar 2003.\r\n//\r\n// Modified 14 Sep 2003 by Mike Lischke .\r\n//   - Renamed event type name to be consistent with other event types (e.g. used in VT).\r\n//   - Added event for hiding/showing columns.\r\n//   - DoXXX method are now virtual.\r\n//   - Conditional code rearrangement to get back Ctrl+Shift+Up/Down navigation.\r\n//\r\n// Modified 31 Mar 2003 by Mike Lischke .\r\n//   - Added a check for the PopupComponent property before casting it hardly to \r\n//     a Virtual Treeview. People might (accidentally) misuse the header popup.\r\n//\r\n// Modified 20 Oct 2002 by Borut Maricic .\r\n//   - Added the possibility to use Troy Wolbrink's Unicode aware popup menu. \r\n//     Define the compiler symbol TNT to enable it. You can get Troy's Unicode\r\n//     controls collection from http://home.ccci.org/wolbrink/tnt/delphi_unicode_controls.htm.\r\n//\r\n// Modified 24 Feb 2002 by Ralf Junker .\r\n//   - Fixed a bug where the OnAddHeaderPopupItem would interfere with \r\n//     poAllowHideAll options.\r\n//   - All column indexes now consistently use TColumnIndex (instead of Integer).\r\n//\r\n// Modified 23 Feb 2002 by Ralf Junker .\r\n//   - Added option to show menu items in the same order as the columns or in \r\n//     original order.\r\n//   - Added option to prevent the user to hide all columns.\r\n//\r\n// Modified 17 Feb 2002 by Jim Kueneman .\r\n//   - Added the event to filter the items as they are added to the menu.\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\ninterface\r\n\r\nuses\r\n  Vcl.Menus, VirtualTrees;\r\n\r\ntype\r\n  TVTHeaderPopupOption = (\r\n    poOriginalOrder, // Show menu items in original column order as they were added to the tree.\r\n    poAllowHideAll,   // Allows to hide all columns, including the last one.\r\n    poResizeToFitItem // Adds an item which, if clicks, resizes all columns to fit by callung TVTHeader.AutoFitColumns\r\n  );\r\n  TVTHeaderPopupOptions = set of TVTHeaderPopupOption;\r\n\r\n  TAddPopupItemType = (\r\n    apNormal,\r\n    apDisabled,\r\n    apHidden\r\n  );\r\n\r\n  TAddHeaderPopupItemEvent = procedure(const Sender: TBaseVirtualTree; const Column: TColumnIndex;\r\n    var Cmd: TAddPopupItemType) of object;\r\n  TColumnChangeEvent = procedure(const Sender: TBaseVirtualTree; const Column: TColumnIndex; Visible: Boolean) of object;\r\n\r\n  TVTMenuItem = TMenuItem;\r\n\r\n  TVTHeaderPopupMenu = class(TPopupMenu)\r\n  strict private\r\n    FOptions: TVTHeaderPopupOptions;\r\n\r\n    FOnAddHeaderPopupItem: TAddHeaderPopupItemEvent;\r\n    FOnColumnChange: TColumnChangeEvent;\r\n  strict protected\r\n    procedure DoAddHeaderPopupItem(const Column: TColumnIndex; out Cmd: TAddPopupItemType); virtual;\r\n    procedure DoColumnChange(Column: TColumnIndex; Visible: Boolean); virtual;\r\n    procedure OnMenuItemClick(Sender: TObject);\r\n  public\r\n    procedure Popup(x, y: Integer); override;\r\n  published\r\n    property Options: TVTHeaderPopupOptions read FOptions write FOptions default [];\r\n\r\n    property OnAddHeaderPopupItem: TAddHeaderPopupItemEvent read FOnAddHeaderPopupItem write FOnAddHeaderPopupItem;\r\n    property OnColumnChange: TColumnChangeEvent read FOnColumnChange write FOnColumnChange;\r\n  end;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nimplementation\r\n\r\nuses\r\n  Winapi.Windows, System.Classes;\r\n\r\nconst\r\n  cResizeToFitMenuItemName = 'VT_ResizeToFitMenuItem';\r\n\r\n//----------------- TVTHeaderPopupMenu ---------------------------------------------------------------------------------\r\n\r\nprocedure TVTHeaderPopupMenu.DoAddHeaderPopupItem(const Column: TColumnIndex; out Cmd: TAddPopupItemType);\r\n\r\nbegin\r\n  Cmd := apNormal;\r\n  if Assigned(FOnAddHeaderPopupItem) then\r\n    FOnAddHeaderPopupItem((PopupComponent as TBaseVirtualTree), Column, Cmd);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TVTHeaderPopupMenu.DoColumnChange(Column: TColumnIndex; Visible: Boolean);\r\n\r\nbegin\r\n  if Assigned(FOnColumnChange) then\r\n    FOnColumnChange((PopupComponent as TBaseVirtualTree), Column, Visible);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TVTHeaderPopupMenu.OnMenuItemClick(Sender: TObject);\r\n\r\nbegin\r\n  if Assigned(PopupComponent) and (PopupComponent is TBaseVirtualTree) then begin\r\n    if TVTMenuItem(Sender).Name = cResizeToFitMenuItemName then begin\r\n      TBaseVirtualTree(PopupComponent).Header.AutoFitColumns();\r\n    end\r\n    else begin\r\n      with TVTMenuItem(Sender),\r\n        TBaseVirtualTree(PopupComponent).Header.Columns.Items[Tag] do\r\n      begin\r\n        if Checked then\r\n          Options := Options - [coVisible]\r\n        else\r\n          Options := Options + [coVisible];\r\n\r\n         DoColumnChange(TVTMenuItem(Sender).Tag, not Checked);\r\n      end;\r\n    end;//else\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TVTHeaderPopupMenu.Popup(x, y: Integer);\r\nresourcestring\r\n  sResizeToFit = '&Resize All Columns To Fit';\r\nvar\r\n  ColPos: TColumnPosition;\r\n  ColIdx: TColumnIndex;\r\n\r\n  NewMenuItem: TVTMenuItem;\r\n  Cmd: TAddPopupItemType;\r\n\r\n  VisibleCounter: Cardinal;\r\n  VisibleItem: TVTMenuItem;\r\n\r\nbegin\r\n  if Assigned(PopupComponent) and (PopupComponent is TBaseVirtualTree) then\r\n  begin\r\n    // Delete existing menu items.\r\n    while Items.Count > 0 do\r\n      Items[0].Free;\r\n\r\n    if poResizeToFitItem in Self.Options then begin\r\n      NewMenuItem := NewItem(sResizeToFit, 0, False, True, OnMenuItemClick, 0, cResizeToFitMenuItemName);\r\n      Items.Add(NewMenuItem);\r\n      Items.Add(NewLine());\r\n    end;//poResizeToFitItem\r\n\r\n    // Add column menu items.\r\n    with (PopupComponent as TBaseVirtualTree).Header do\r\n    begin\r\n      if hoShowImages in Options then\r\n        Self.Images := Images\r\n      else\r\n        // Remove a possible reference to image list of another tree previously assigned.\r\n        Self.Images := nil;\r\n      VisibleItem := nil;\r\n      VisibleCounter := 0;\r\n      for ColPos := 0 to Columns.Count - 1 do\r\n      begin\r\n        if poOriginalOrder in FOptions then\r\n          ColIdx := ColPos\r\n        else\r\n          ColIdx := Columns.ColumnFromPosition(ColPos);\r\n\r\n        with Columns[ColIdx] do\r\n        begin\r\n          if coVisible in Options then\r\n            Inc(VisibleCounter);\r\n          DoAddHeaderPopupItem(ColIdx, Cmd);\r\n          if Cmd <> apHidden then\r\n          begin\r\n            NewMenuItem := TVTMenuItem.Create(Self);\r\n            NewMenuItem.Tag := ColIdx;\r\n            NewMenuItem.Caption := Text;\r\n            NewMenuItem.Hint := Hint;\r\n            NewMenuItem.ImageIndex := ImageIndex;\r\n            NewMenuItem.Checked := coVisible in Options;\r\n            NewMenuItem.OnClick := OnMenuItemClick;\r\n            if Cmd = apDisabled then\r\n              NewMenuItem.Enabled := False\r\n            else\r\n              if coVisible in Options then\r\n                VisibleItem := NewMenuItem;\r\n            Items.Add(NewMenuItem);\r\n          end;\r\n        end;\r\n      end;\r\n\r\n      // Conditionally disable menu item of last enabled column.\r\n      if (VisibleCounter = 1) and (VisibleItem <> nil) and not (poAllowHideAll in FOptions) then\r\n        VisibleItem.Enabled := False;\r\n    end;\r\n  end;\r\n  \r\n  inherited;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nend.\r\n\r\n"
  },
  {
    "path": "External/VirtualTreeView/Source/VirtualTrees.Actions.pas",
    "content": "unit VirtualTrees.Actions;\n\ninterface\n\nuses\n  System.Classes,\n  System.Actions,\n  Vcl.ActnList,\n  VirtualTrees;\n\ntype\n  TVirtualTreeAction = class(TCustomAction)\n  strict private\n    fTree: TBaseVirtualTree; // Member variable for the property \"Control\"\n    fTreeAutoDetect: Boolean; // True if a potential Virtual TreeView should be detected automatically, false if a specific Tree was assigned to the property \"Tree\"\n    fOnAfterExecute: TNotifyEvent; // Member variable for the OnAfterExecute event\n    function GetSelectedOnly: Boolean; // Setter for the property \"SelectedOnly\"\n    procedure SetSelectedOnly(const Value: Boolean); // Getter for the property \"SelectedOnly\"\n  strict protected\n    fFilter: TVirtualNodeStates; // Apply only of nodes which match these states\n    procedure SetControl(Value: TBaseVirtualTree); // Setter for the property \"Control\"\n    procedure Notification(AComponent: TComponent; Operation: TOperation); override;\n    procedure DoAfterExecute; // Fires the event \"OnAfterExecute\"\n    property SelectedOnly: Boolean read GetSelectedOnly write SetSelectedOnly default False;\n  public\n    function HandlesTarget(Target: TObject): Boolean; override;\n    procedure UpdateTarget(Target: TObject); override;\n    procedure ExecuteTarget(Target: TObject); override;\n  published\n    constructor Create(AOwner: TComponent); override;\n    property Control: TBaseVirtualTree read fTree write SetControl;\n    property OnAfterExecute: TNotifyEvent read fOnAfterExecute write fOnAfterExecute; // Executed after the action was performed\n    property Caption;\n    property Enabled;\n    property HelpContext;\n    property HelpType;\n    property Hint;\n    property ImageIndex;\n    property ShortCut;\n    property SecondaryShortCuts;\n    property Visible;\n    property OnHint;\n  end;\n\n  TVirtualTreePerItemAction = class(TVirtualTreeAction)\n  strict private\n    fOnBeforeExecute: TNotifyEvent;\n  strict protected\n    fToExecute: TVTGetNodeProc; // method which is executed per item to perform this action\n    procedure DoBeforeExecute;\n  public\n    constructor Create(AOwner: TComponent); override;\n    procedure ExecuteTarget(Target: TObject); override;\n  published\n    property OnBeforeExecute: TNotifyEvent read fOnBeforeExecute write fOnBeforeExecute;\n  end;\n\n  // A standard action which checkmarks nodes in a virtual treeview\n  TVirtualTreeCheckAll = class(TVirtualTreePerItemAction)\n  protected\n    fDesiredCheckState: TCheckState;\n  public\n    constructor Create(AOwner: TComponent); override;\n  published\n    property SelectedOnly;\n  end;\n\n  // A standard action which unchecks nodes in a virtual treeview\n  TVirtualTreeUncheckAll = class(TVirtualTreeCheckAll)\n  public\n    constructor Create(AOwner: TComponent); override;\n  end;\n\n  TVirtualTreeSelectAll = class(TVirtualTreeAction)\n  public\n    procedure UpdateTarget(Target: TObject); override;\n    procedure ExecuteTarget(Target: TObject); override;\n  end;\n\n  // Base class for actions that are applied to selected nodes only\n  TVirtualTreeForSelectedAction = class(TVirtualTreeAction)\n  public\r\n    constructor Create(AOwner: TComponent); override;\r\n  end;\r\n\r\n  TVirtualTreeCopy = class(TVirtualTreeForSelectedAction)\n  public\n    procedure ExecuteTarget(Target: TObject); override;\n  end;\n\n  TVirtualTreeCut = class(TVirtualTreeForSelectedAction)\n  public\n    procedure ExecuteTarget(Target: TObject); override;\n  end;\n\n  TVirtualTreePaste = class(TVirtualTreeForSelectedAction)\n  public\n    procedure ExecuteTarget(Target: TObject); override;\n  end;\n\n  TVirtualTreeDelete = class(TVirtualTreeForSelectedAction)\n  public\n    procedure ExecuteTarget(Target: TObject); override;\n  end;\n\nprocedure Register;\n\n\nimplementation\n\nuses\n  Controls, Forms;\n\nprocedure Register;\nbegin\n  RegisterActions('VirtualTree', [TVirtualTreeCheckAll, TVirtualTreeUncheckAll, TVirtualTreeSelectAll, TVirtualTreeCopy, TVirtualTreeCut, TVirtualTreePaste, TVirtualTreeDelete], nil);\nend;\n\n{ TVirtualTreeAction }\n\nconstructor TVirtualTreeAction.Create(AOwner: TComponent);\nbegin\n  inherited Create(AOwner);\n  fTree := nil;\n  fFilter := [];\n  fOnAfterExecute := nil;\n  fTreeAutoDetect := True;\nend;\n\nfunction TVirtualTreeAction.GetSelectedOnly: Boolean;\nbegin\r\n  exit(TVirtualNodeState.vsSelected in fFilter);\r\nend;\r\n\r\nprocedure TVirtualTreeAction.SetSelectedOnly(const Value: Boolean);\nbegin\r\n  if Value then\r\n    Include(fFilter, TVirtualNodeState.vsSelected)\r\n  else\r\n    Exclude(fFilter, TVirtualNodeState.vsSelected);\r\nend;\r\n\r\nprocedure TVirtualTreeAction.DoAfterExecute;\nbegin\n  if Assigned(fOnAfterExecute) then\n    fOnAfterExecute(Self);\nend;\n\nfunction TVirtualTreeAction.HandlesTarget(Target: TObject): Boolean;\nbegin\n  Result := (Target is TBaseVirtualTree);\nend;\n\nprocedure TVirtualTreeAction.UpdateTarget(Target: TObject);\nbegin\n  if fTreeAutoDetect and (Target is TBaseVirtualTree) then\n    fTree := (Target as TBaseVirtualTree);\n  Enabled := Assigned(Control) and not Control.IsEmpty and (not SelectedOnly or (Control.SelectedCount > 0))\nend;\n\nprocedure TVirtualTreeAction.ExecuteTarget(Target: TObject);\nbegin\n  DoAfterExecute();\r\nend;\n\nprocedure TVirtualTreeAction.Notification(AComponent: TComponent; Operation: TOperation);\nbegin\n  inherited Notification(AComponent, Operation);\n  if (Operation = opRemove) and (AComponent = FTree) then\n    FTree := nil;\nend;\n\nprocedure TVirtualTreeAction.SetControl(Value: TBaseVirtualTree);\nbegin\n  if Value <> fTree then begin\n    fTree := Value;\n    if Assigned(fTree) then begin\n      fTree.FreeNotification(Self);// register Self as a component that should be notified when fTree is about to be destroyed.\n    end;//if\n    // Do not update the target of this action if it wa set explicitely by the developer\n    fTreeAutoDetect := not Assigned(fTree);\n  end;//if\nend;\n\n\n{ TVirtualTreePerItemAction }\n\nconstructor TVirtualTreePerItemAction.Create(AOwner: TComponent);\nbegin\r\n  inherited;\r\n  fToExecute := nil;\r\n  fOnBeforeExecute := nil;\r\nend;\r\n\r\nprocedure TVirtualTreePerItemAction.DoBeforeExecute;\nbegin\n  if Assigned(fOnBeforeExecute) then\n    fOnBeforeExecute(Self);\nend;\n\nprocedure TVirtualTreePerItemAction.ExecuteTarget(Target: TObject);\nvar\n  lOldCursor: TCursor;\nbegin\n  if Assigned(Self.Control) then\r\n    Target := Self.Control;\n  DoBeforeExecute();\n  lOldCursor := Screen.Cursor;\n  Screen.Cursor := crHourGlass;\n  Control.BeginUpdate();\n  try\n    Control.IterateSubtree(nil, Self.fToExecute, nil, fFilter);\n  finally\r\n    Control.EndUpdate;\r\n    Screen.Cursor := lOldCursor;\r\n  end;\n  Inherited ExecuteTarget(Target);\nend;\n\n{ TVirtualTreeCheckAll }\n\nconstructor TVirtualTreeCheckAll.Create(AOwner: TComponent);\nbegin\n  inherited Create(AOwner);\n  Hint := 'Check all items in the list';\n  Caption := 'Check &All';\n  fDesiredCheckState := csCheckedNormal;\n  fToExecute := procedure(Sender: TBaseVirtualTree; Node: PVirtualNode; Data: Pointer; var Abort: Boolean)\n                begin\n                  Control.CheckState[Node] := fDesiredCheckState;\n                end;\nend;\n\n\n{ TVirtualTreeUncheckAll }\n\nconstructor TVirtualTreeUncheckAll.Create(AOwner: TComponent);\nbegin\n  inherited Create(AOwner);\n  Hint := 'Uncheck all items in the list';\n  Caption := '&Uncheck All';\n  fDesiredCheckState := csUncheckedNormal;\nend;\n\n\n{ TVirtualStringSelectAll }\n\r\nprocedure TVirtualTreeSelectAll.UpdateTarget(Target: TObject);\nbegin\n  Inherited;\r\n  //Enabled := Enabled and (toMultiSelect in Control.TreeOptions.SelectionOptions)  // TreeOptions is protected  :-(\r\nend;\n\nprocedure TVirtualTreeSelectAll.ExecuteTarget(Target: TObject);\nbegin\r\n  Control.SelectAll(False);\r\n  inherited;\r\nend;\r\n\r\n\r\n{ TVirtualTreeForSelectedAction }\r\n\nconstructor TVirtualTreeForSelectedAction.Create(AOwner: TComponent);\nbegin\r\n  inherited;\r\n  SelectedOnly := True;\r\nend;\r\n\r\n\r\n{ TVirtualTreeCopy }\r\n\r\nprocedure TVirtualTreeCopy.ExecuteTarget(Target: TObject);\r\nbegin\r\n  Control.CopyToClipboard();\r\n  Inherited;\r\nend;\r\n\n\n{ TVirtualTreeCut }\n\r\nprocedure TVirtualTreeCut.ExecuteTarget(Target: TObject);\r\nbegin\r\n  Control.CutToClipboard();\r\n  Inherited;\r\nend;\r\n\n\n{ TVirtualTreePaste }\n\r\nprocedure TVirtualTreePaste.ExecuteTarget(Target: TObject);\r\nbegin\r\n  Control.PasteFromClipboard();\r\n  Inherited;\r\nend;\r\n\n\n{ TVirtualTreeDelete }\n\r\nprocedure TVirtualTreeDelete.ExecuteTarget(Target: TObject);\r\nbegin\r\n  Control.DeleteSelectedNodes();\r\n  Inherited;\r\nend;\n\n\nend.\n"
  },
  {
    "path": "External/VirtualTreeView/Source/VirtualTrees.Classes.pas",
    "content": "unit VirtualTrees.Classes;\r\n\r\n// The contents of this file are subject to the Mozilla Public License\r\n// Version 1.1 (the \"License\"); you may not use this file except in compliance\r\n// with the License. You may obtain a copy of the License at http://www.mozilla.org/MPL/\r\n//\r\n// Alternatively, you may redistribute this library, use and/or modify it under the terms of the\r\n// GNU Lesser General Public License as published by the Free Software Foundation;\r\n// either version 2.1 of the License, or (at your option) any later version.\r\n// You may obtain a copy of the LGPL at http://www.gnu.org/copyleft/.\r\n//\r\n// Software distributed under the License is distributed on an \"AS IS\" basis,\r\n// WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for the\r\n// specific language governing rights and limitations under the License.\r\n//\r\n// The original code is VirtualTrees.pas, released September 30, 2000.\r\n//\r\n// The initial developer of the original code is digital publishing AG (Munich, Germany, www.digitalpublishing.de),\r\n// written by Mike Lischke (public@soft-gems.net, www.soft-gems.net).\r\n//\r\n// Portions created by digital publishing AG are Copyright\r\n// (C) 1999-2001 digital publishing AG. All Rights Reserved.\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\ninterface\r\n\r\n{$WARN UNSAFE_TYPE OFF}\r\n{$WARN UNSAFE_CAST OFF}\r\n{$WARN UNSAFE_CODE OFF}\r\n\r\nuses\r\n  Winapi.Windows;\r\n\r\ntype\r\n  // Helper classes to speed up rendering text formats for clipboard and drag'n drop transfers.\r\n  TBufferedRawByteString = class\r\n  private\r\n    FStart,\r\n    FPosition,\r\n    FEnd: PAnsiChar;\r\n    function GetAsString: RawByteString;\r\n  public\r\n    destructor Destroy; override;\r\n\r\n    procedure Add(const S: RawByteString);\r\n    procedure AddNewLine;\r\n\r\n    property AsString: RawByteString read GetAsString;\r\n  end;\r\n\r\n  TBufferedString = class\r\n  private\r\n    FStart,\r\n    FPosition,\r\n    FEnd: PWideChar;\r\n    function GetAsString: string;\r\n  public\r\n    destructor Destroy; override;\r\n\r\n    procedure Add(const S: string);\r\n    procedure AddNewLine;\r\n\r\n    property AsString: string read GetAsString;\r\n  end;\r\n\r\n  TCriticalSection = class(TObject)\r\n  protected\r\n    FSection: TRTLCriticalSection;\r\n  public\r\n    constructor Create;\r\n    destructor Destroy; override;\r\n\r\n    procedure Enter;\r\n    procedure Leave;\r\n  end;\r\n\r\n\r\n\r\nimplementation\r\n\r\n//----------------- TBufferedRawByteString ------------------------------------------------------------------------------------\r\n\r\nconst\r\n  AllocIncrement = 2 shl 11;  // Must be a power of 2.\r\n\r\ndestructor TBufferedRawByteString.Destroy;\r\n\r\nbegin\r\n  FreeMem(FStart);\r\n  inherited;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TBufferedRawByteString.GetAsString: RawByteString;\r\n\r\nbegin\r\n  SetString(Result, FStart, FPosition - FStart);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBufferedRawByteString.Add(const S: RawByteString);\r\n\r\nvar\r\n  NewLen,\r\n  LastOffset,\r\n  Len: NativeInt;\r\n\r\nbegin\r\n  Len := Length(S);\r\n  // Make room for the new string.\r\n  if FEnd - FPosition <= Len then\r\n  begin\r\n    // Round up NewLen so it is always a multiple of AllocIncrement.\r\n    NewLen := FEnd - FStart + (Len + AllocIncrement - 1) and not (AllocIncrement - 1);\r\n    // Keep last offset to restore it correctly in the case that FStart gets a new memory block assigned.\r\n    LastOffset := FPosition - FStart;\r\n    ReallocMem(FStart, NewLen);\r\n    FPosition := FStart + LastOffset;\r\n    FEnd := FStart + NewLen;\r\n  end;\r\n  Move(PAnsiChar(S)^, FPosition^, Len);\r\n  Inc(FPosition, Len);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBufferedRawByteString.AddNewLine;\r\n\r\nvar\r\n  NewLen,\r\n  LastOffset: NativeInt;\r\n\r\nbegin\r\n  // Make room for the CR/LF characters.\r\n  if FEnd - FPosition <= 2 then\r\n  begin\r\n    // Round up NewLen so it is always a multiple of AllocIncrement.\r\n    NewLen := FEnd - FStart + (2 + AllocIncrement - 1) and not (AllocIncrement - 1);\r\n    // Keep last offset to restore it correctly in the case that FStart gets a new memory block assigned.\r\n    LastOffset := FPosition - FStart;\r\n    ReallocMem(FStart, NewLen);\r\n    FPosition := FStart + LastOffset;\r\n    FEnd := FStart + NewLen;\r\n  end;\r\n  FPosition^ := #13;\r\n  Inc(FPosition);\r\n  FPosition^ := #10;\r\n  Inc(FPosition);\r\nend;\r\n\r\n//----------------- TBufferedString --------------------------------------------------------------------------------\r\n\r\ndestructor TBufferedString.Destroy;\r\n\r\nbegin\r\n  FreeMem(FStart);\r\n  inherited;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TBufferedString.GetAsString: string;\r\n\r\nbegin\r\n  SetString(Result, FStart, FPosition - FStart);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBufferedString.Add(const S: string);\r\n\r\nvar\r\n  NewLen,\r\n  LastOffset,\r\n  Len: Integer;\r\n\r\nbegin\r\n  Len := Length(S);\r\n  if Len = 0 then\r\n    exit;//Nothing to do\r\n  // Make room for the new string.\r\n  if FEnd - FPosition <= Len then\r\n  begin\r\n    // Round up NewLen so it is always a multiple of AllocIncrement.\r\n    NewLen := FEnd - FStart + (Len + AllocIncrement - 1) and not (AllocIncrement - 1);\r\n    // Keep last offset to restore it correctly in the case that FStart gets a new memory block assigned.\r\n    LastOffset := FPosition - FStart;\r\n    ReallocMem(FStart, 2 * NewLen);\r\n    FPosition := FStart + LastOffset;\r\n    FEnd := FStart + NewLen;\r\n  end;\r\n  Move(PWideChar(S)^, FPosition^, 2 * Len);\r\n  Inc(FPosition, Len);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBufferedString.AddNewLine;\r\n\r\nvar\r\n  NewLen,\r\n  LastOffset: Integer;\r\n\r\nbegin\r\n  // Make room for the CR/LF characters.\r\n  if FEnd - FPosition <= 4 then\r\n  begin\r\n    // Round up NewLen so it is always a multiple of AllocIncrement.\r\n    NewLen := FEnd - FStart + (2 + AllocIncrement - 1) and not (AllocIncrement - 1);\r\n    // Keep last offset to restore it correctly in the case that FStart gets a new memory block assigned.\r\n    LastOffset := FPosition - FStart;\r\n    ReallocMem(FStart, 2 * NewLen);\r\n    FPosition := FStart + LastOffset;\r\n    FEnd := FStart + NewLen;\r\n  end;\r\n  FPosition^ := #13;\r\n  Inc(FPosition);\r\n  FPosition^ := #10;\r\n  Inc(FPosition);\r\nend;\r\n\r\n//----------------- TCriticalSection -----------------------------------------------------------------------------------\r\n\r\nconstructor TCriticalSection.Create;\r\n\r\nbegin\r\n  inherited Create;\r\n  InitializeCriticalSection(FSection);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\ndestructor TCriticalSection.Destroy;\r\n\r\nbegin\r\n  DeleteCriticalSection(FSection);\r\n\r\n  inherited Destroy;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TCriticalSection.Enter;\r\n\r\nbegin\r\n  EnterCriticalSection(FSection);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TCriticalSection.Leave;\r\n\r\nbegin\r\n  LeaveCriticalSection(FSection);\r\nend;\r\n\r\n\r\nend.\r\n"
  },
  {
    "path": "External/VirtualTreeView/Source/VirtualTrees.ClipBoard.pas",
    "content": "unit VirtualTrees.ClipBoard;\r\n\r\n// The contents of this file are subject to the Mozilla Public License\r\n// Version 1.1 (the \"License\"); you may not use this file except in compliance\r\n// with the License. You may obtain a copy of the License at http://www.mozilla.org/MPL/\r\n//\r\n// Alternatively, you may redistribute this library, use and/or modify it under the terms of the\r\n// GNU Lesser General Public License as published by the Free Software Foundation;\r\n// either version 2.1 of the License, or (at your option) any later version.\r\n// You may obtain a copy of the LGPL at http://www.gnu.org/copyleft/.\r\n//\r\n// Software distributed under the License is distributed on an \"AS IS\" basis,\r\n// WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for the\r\n// specific language governing rights and limitations under the License.\r\n//\r\n// The original code is VirtualTrees.pas, released September 30, 2000.\r\n//\r\n// The initial developer of the original code is digital publishing AG (Munich, Germany, www.digitalpublishing.de),\r\n// written by Mike Lischke (public@soft-gems.net, www.soft-gems.net).\r\n//\r\n// Portions created by digital publishing AG are Copyright\r\n// (C) 1999-2001 digital publishing AG. All Rights Reserved.\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\n\r\ninterface\r\n\r\nuses\r\n  Winapi.Windows,\r\n  Winapi.ActiveX,\r\n  System.Classes,\r\n  VirtualTrees;\r\n\r\ntype\r\n  TClipboardFormatEntry = record\r\n    ID: Word;\r\n    Description: string;\r\n  end;\r\n\r\nvar\r\n  ClipboardDescriptions: array [1..CF_MAX - 1] of TClipboardFormatEntry = (\r\n    (ID: CF_TEXT; Description: 'Plain text'), // Do not localize\r\n    (ID: CF_BITMAP; Description: 'Windows bitmap'), // Do not localize\r\n    (ID: CF_METAFILEPICT; Description: 'Windows metafile'), // Do not localize\r\n    (ID: CF_SYLK; Description: 'Symbolic link'), // Do not localize\r\n    (ID: CF_DIF; Description: 'Data interchange format'), // Do not localize\r\n    (ID: CF_TIFF; Description: 'Tiff image'), // Do not localize\r\n    (ID: CF_OEMTEXT; Description: 'OEM text'), // Do not localize\r\n    (ID: CF_DIB; Description: 'DIB image'), // Do not localize\r\n    (ID: CF_PALETTE; Description: 'Palette data'), // Do not localize\r\n    (ID: CF_PENDATA; Description: 'Pen data'), // Do not localize\r\n    (ID: CF_RIFF; Description: 'Riff audio data'), // Do not localize\r\n    (ID: CF_WAVE; Description: 'Wav audio data'), // Do not localize\r\n    (ID: CF_UNICODETEXT; Description: 'Unicode text'), // Do not localize\r\n    (ID: CF_ENHMETAFILE; Description: 'Enhanced metafile image'), // Do not localize\r\n    (ID: CF_HDROP; Description: 'File name(s)'), // Do not localize\r\n    (ID: CF_LOCALE; Description: 'Locale descriptor'), // Do not localize\r\n    (ID: CF_DIBV5; Description: 'DIB image V5') // Do not localize\r\n  );\r\n\r\n\r\n// OLE Clipboard and drag'n drop helper\r\nprocedure EnumerateVTClipboardFormats(TreeClass: TVirtualTreeClass; const List: TStrings); overload;\r\nprocedure EnumerateVTClipboardFormats(TreeClass: TVirtualTreeClass; var Formats: TFormatEtcArray); overload;\r\nfunction GetVTClipboardFormatDescription(AFormat: Word): string;\r\nprocedure RegisterVTClipboardFormat(AFormat: Word; TreeClass: TVirtualTreeClass; Priority: Cardinal); overload;\r\nfunction RegisterVTClipboardFormat(const Description: string; TreeClass: TVirtualTreeClass; Priority: Cardinal;\r\n                                   tymed: Integer = TYMED_HGLOBAL; ptd: PDVTargetDevice = nil;\r\n                                   dwAspect: Integer = DVASPECT_CONTENT; lindex: Integer = -1): Word; overload;\r\n\r\n//----------------- TClipboardFormats ----------------------------------------------------------------------------------\r\n\r\ntype\r\n  PClipboardFormatListEntry = ^TClipboardFormatListEntry;\r\n  TClipboardFormatListEntry = record\r\n    Description: string;               // The string used to register the format with Winapi.Windows.\r\n    TreeClass: TVirtualTreeClass;      // The tree class which supports rendering this format.\r\n    Priority: Cardinal;                // Number which determines the order of formats used in IDataObject.\r\n    FormatEtc: TFormatEtc;             // The definition of the format in the IDataObject.\r\n  end;\r\n\r\n  TClipboardFormatList = class\r\n  private\r\n    class var\r\n      FList : TList;\r\n  protected\r\n   class procedure Sort;\r\n  public\r\n    class procedure Add(const FormatString: string; AClass: TVirtualTreeClass; Priority: Cardinal; AFormatEtc: TFormatEtc);\r\n    class procedure Clear;\r\n    class procedure EnumerateFormats(TreeClass: TVirtualTreeClass; var Formats: TFormatEtcArray;  const AllowedFormats: TClipboardFormats = nil); overload;\r\n    class procedure EnumerateFormats(TreeClass: TVirtualTreeClass; const Formats: TStrings); overload;\r\n    class function FindFormat(const FormatString: string): PClipboardFormatListEntry; overload;\r\n    class function FindFormat(const FormatString: string; var Fmt: Word): TVirtualTreeClass; overload;\r\n    class function FindFormat(Fmt: Word; var Description: string): TVirtualTreeClass; overload;\r\n  end;\r\n\r\n\r\nimplementation\r\n\r\nuses\r\n  System.SysUtils;\r\n\r\n\r\nprocedure EnumerateVTClipboardFormats(TreeClass: TVirtualTreeClass; const List: TStrings);\r\n\r\nbegin\r\n  TClipboardFormatList.EnumerateFormats(TreeClass, List);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure EnumerateVTClipboardFormats(TreeClass: TVirtualTreeClass; var Formats: TFormatEtcArray);\r\n\r\nbegin\r\n  TClipboardFormatList.EnumerateFormats(TreeClass, Formats);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction GetVTClipboardFormatDescription(AFormat: Word): string;\r\n\r\nbegin\r\n  if TClipboardFormatList.FindFormat(AFormat, Result) = nil then\r\n    Result := '';\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure RegisterVTClipboardFormat(AFormat: Word; TreeClass: TVirtualTreeClass; Priority: Cardinal);\r\n\r\n// Registers the given clipboard format for the given TreeClass.\r\n\r\nvar\r\n  I: Integer;\r\n  Buffer: array[0..2048] of Char;\r\n  FormatEtc: TFormatEtc;\r\n\r\nbegin\r\n\r\n  // Assumes a HGlobal format.\r\n  FormatEtc.cfFormat := AFormat;\r\n  FormatEtc.ptd := nil;\r\n  FormatEtc.dwAspect := DVASPECT_CONTENT;\r\n  FormatEtc.lindex := -1;\r\n  FormatEtc.tymed := TYMED_HGLOBAL;\r\n\r\n  // Determine description string of the given format. For predefined formats we need the lookup table because they\r\n  // don't have a description string. For registered formats the description string is the string which was used\r\n  // to register them.\r\n  if AFormat < CF_MAX then\r\n  begin\r\n    for I := 1 to High(ClipboardDescriptions) do\r\n      if ClipboardDescriptions[I].ID = AFormat then\r\n      begin\r\n        TClipboardFormatList.Add(ClipboardDescriptions[I].Description, TreeClass, Priority, FormatEtc);\r\n        Break;\r\n      end;\r\n  end\r\n  else\r\n  begin\r\n    GetClipboardFormatName(AFormat, Buffer, Length(Buffer));\r\n    TClipboardFormatList.Add(Buffer, TreeClass, Priority, FormatEtc);\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction RegisterVTClipboardFormat(const Description: string; TreeClass: TVirtualTreeClass; Priority: Cardinal;\r\n  tymed: Integer = TYMED_HGLOBAL; ptd: PDVTargetDevice = nil; dwAspect: Integer = DVASPECT_CONTENT;\r\n  lindex: Integer = -1): Word;\r\n\r\n// Alternative method to register a certain clipboard format for a given tree class. Registration with the\r\n// clipboard is done here too and the assigned ID returned by the function.\r\n// tymed may contain or'ed TYMED constants which allows to register several storage formats for one clipboard format.\r\n\r\nvar\r\n  FormatEtc: TFormatEtc;\r\n\r\nbegin\r\n  Result := RegisterClipboardFormat(PChar(Description));\r\n  FormatEtc.cfFormat := Result;\r\n  FormatEtc.ptd := ptd;\r\n  FormatEtc.dwAspect := dwAspect;\r\n  FormatEtc.lindex := lindex;\r\n  FormatEtc.tymed := tymed;\r\n  TClipboardFormatList.Add(Description, TreeClass, Priority, FormatEtc);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nclass procedure TClipboardFormatList.Sort;\r\n\r\n// Sorts all entry for priority (increasing priority value).\r\n\r\n  //--------------- local function --------------------------------------------\r\n  procedure QuickSort(L, R: Integer);\r\n\r\n  var\r\n    I, J: Integer;\r\n    P, T: PClipboardFormatListEntry;\r\n\r\n  begin\r\n    repeat\r\n      I := L;\r\n      J := R;\r\n      P := FList[(L + R) shr 1];\r\n      repeat\r\n        while PClipboardFormatListEntry(FList[I]).Priority < P.Priority do\r\n          Inc(I);\r\n        while PClipboardFormatListEntry(FList[J]).Priority > P.Priority do\r\n          Dec(J);\r\n        if I <= J then\r\n        begin\r\n          T := FList[I];\r\n          FList[I] := FList[J];\r\n          FList[J] := T;\r\n          Inc(I);\r\n          Dec(J);\r\n        end;\r\n      until I > J;\r\n      if L < J then\r\n        QuickSort(L, J);\r\n      L := I;\r\n    until I >= R;\r\n  end;\r\n  //--------------- end local function ----------------------------------------\r\n\r\nbegin\r\n  if FList.Count > 1 then\r\n    QuickSort(0, FList.Count - 1);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nclass procedure TClipboardFormatList.Add(const FormatString: string; AClass: TVirtualTreeClass; Priority: Cardinal; AFormatEtc: TFormatEtc);\r\n\r\n// Adds the given data to the internal list. The priority value is used to sort formats for importance. Larger priority\r\n// values mean less priority.\r\n\r\nvar\r\n  Entry: PClipboardFormatListEntry;\r\n\r\nbegin\r\n  New(Entry);\r\n  Entry.Description := FormatString;\r\n  Entry.TreeClass := AClass;\r\n  Entry.Priority := Priority;\r\n  Entry.FormatEtc := AFormatEtc;\r\n  FList.Add(Entry);\r\n\r\n  Sort;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nclass procedure TClipboardFormatList.Clear;\r\n\r\nvar\r\n  I: Integer;\r\n\r\nbegin\r\n  for I := 0 to FList.Count - 1 do\r\n    Dispose(PClipboardFormatListEntry(FList[I]));\r\n  FList.Clear;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nclass procedure TClipboardFormatList.EnumerateFormats(TreeClass: TVirtualTreeClass; var Formats: TFormatEtcArray; const AllowedFormats: TClipboardFormats = nil);\r\n\r\n// Returns a list of format records for the given class. If assigned the AllowedFormats is used to limit the\r\n// enumerated formats to those described in the list.\r\n\r\nvar\r\n  I, Count: Integer;\r\n  Entry: PClipboardFormatListEntry;\r\n\r\nbegin\r\n  SetLength(Formats, FList.Count);\r\n  Count := 0;\r\n  for I := 0 to FList.Count - 1 do\r\n  begin\r\n    Entry := FList[I];\r\n    // Does the tree class support this clipboard format?\r\n    if TreeClass.InheritsFrom(Entry.TreeClass) then\r\n    begin\r\n      // Is this format allowed to be included?\r\n      if (AllowedFormats = nil) or (AllowedFormats.IndexOf(Entry.Description) > -1) then\r\n      begin\r\n        // The list could change before we use the FormatEtc so it is best not to pass a pointer to the true FormatEtc\r\n        // structure. Instead make a copy and send that.\r\n        Formats[Count] := Entry.FormatEtc;\r\n        Inc(Count);\r\n      end;\r\n    end;\r\n  end;\r\n  SetLength(Formats, Count);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nclass procedure TClipboardFormatList.EnumerateFormats(TreeClass: TVirtualTreeClass; const Formats: TStrings);\r\n\r\n// Returns a list of format descriptions for the given class.\r\n\r\nvar\r\n  I: Integer;\r\n  Entry: PClipboardFormatListEntry;\r\n\r\nbegin\r\n  for I := 0 to FList.Count - 1 do\r\n  begin\r\n    Entry := FList[I];\r\n    if TreeClass.InheritsFrom(Entry.TreeClass) then\r\n      Formats.Add(Entry.Description);\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nclass function TClipboardFormatList.FindFormat(const FormatString: string): PClipboardFormatListEntry;\r\n\r\nvar\r\n  I: Integer;\r\n  Entry: PClipboardFormatListEntry;\r\n\r\nbegin\r\n  Result := nil;\r\n  for I := FList.Count - 1 downto 0 do\r\n  begin\r\n    Entry := FList[I];\r\n    if CompareText(Entry.Description, FormatString) = 0 then\r\n    begin\r\n      Result := Entry;\r\n      Break;\r\n    end;\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nclass function TClipboardFormatList.FindFormat(const FormatString: string; var Fmt: Word): TVirtualTreeClass;\r\n\r\nvar\r\n  I: Integer;\r\n  Entry: PClipboardFormatListEntry;\r\n\r\nbegin\r\n  Result := nil;\r\n  for I := FList.Count - 1 downto 0 do\r\n  begin\r\n    Entry := FList[I];\r\n    if CompareText(Entry.Description, FormatString) = 0 then\r\n    begin\r\n      Result := Entry.TreeClass;\r\n      Fmt := Entry.FormatEtc.cfFormat;\r\n      Break;\r\n    end;\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nclass function TClipboardFormatList.FindFormat(Fmt: Word; var Description: string): TVirtualTreeClass;\r\n\r\nvar\r\n  I: Integer;\r\n  Entry: PClipboardFormatListEntry;\r\n\r\nbegin\r\n  Result := nil;\r\n  for I := FList.Count - 1 downto 0 do\r\n  begin\r\n    Entry := FList[I];\r\n    if Entry.FormatEtc.cfFormat = Fmt then\r\n    begin\r\n      Result := Entry.TreeClass;\r\n      Description := Entry.Description;\r\n      Break;\r\n    end;\r\n  end;\r\nend;\r\n\r\n\r\n//Note - not using class constructors as they are not supported on C++ Builder.\r\ninitialization\r\n  TClipboardFormatList.FList := TList.Create;\r\nfinalization\r\n  TClipboardFormatList.Clear;\r\n  TClipboardFormatList.FList.Free;\r\nend.\r\n"
  },
  {
    "path": "External/VirtualTreeView/Source/VirtualTrees.Export.pas",
    "content": "unit VirtualTrees.Export;\r\n\r\n{$WARN UNSAFE_CODE OFF}\r\n{$WARN IMPLICIT_STRING_CAST OFF}\r\n{$WARN IMPLICIT_STRING_CAST_LOSS OFF}\n\r\ninterface\r\n\r\nuses Winapi.Windows, System.SysUtils, Vcl.Graphics, System.Classes, Vcl.Forms,\r\n     Vcl.Controls, System.StrUtils, System.Generics.Collections,\r\n     VirtualTrees, VirtualTrees.Classes;\r\n\r\nfunction ContentToHTML(Tree: TCustomVirtualStringTree; Source: TVSTTextSourceType; const Caption: string = ''): String;\r\nfunction ContentToRTF(Tree: TCustomVirtualStringTree; Source: TVSTTextSourceType): RawByteString;\r\nfunction ContentToUnicodeString(Tree: TCustomVirtualStringTree; Source: TVSTTextSourceType; const Separator: string): string;\r\nfunction ContentToClipboard(Tree: TCustomVirtualStringTree; Format: Word; Source: TVSTTextSourceType): HGLOBAL;\r\nprocedure ContentToCustom(Tree: TCustomVirtualStringTree; Source: TVSTTextSourceType);\r\n\r\nimplementation\r\n\r\nuses\r\n  UITypes;\r\n\r\ntype\r\n  TCustomVirtualStringTreeCracker = class(TCustomVirtualStringTree)\r\n  end;\n\r\nconst\r\n  WideCR = Char(#13);\r\n  WideLF = Char(#10);\n\r\n\n\rfunction ContentToHTML(Tree: TCustomVirtualStringTree; Source: TVSTTextSourceType; const Caption: string): String;\r\n\n// Renders the current tree content (depending on Source) as HTML text encoded in UTF-8.\n// If Caption is not empty then it is used to create and fill the header for the table built here.\n// Based on ideas and code from Frank van den Bergh and Andreas H�rstemeier.\n\nvar\n  Buffer: TBufferedString;\n\n  //--------------- local functions -------------------------------------------\n\n  procedure WriteColorAsHex(Color: TColor);\n\n  var\n    WinColor: COLORREF;\n    I: Integer;\n    Component,\n    Value: Byte;\n\n  begin\n    Buffer.Add('#');\n    WinColor := ColorToRGB(Color);\n    I := 1;\n    while I <= 6 do\n    begin\n      Component := WinColor and $FF;\n\n      Value := 48 + (Component shr 4);\n      if Value > $39 then\n        Inc(Value, 7);\n      Buffer.Add(AnsiChar(Value));\n      Inc(I);\n\n      Value := 48 + (Component and $F);\n      if Value > $39 then\n        Inc(Value, 7);\n      Buffer.Add(AnsiChar(Value));\n      Inc(I);\n\n      WinColor := WinColor shr 8;\n    end;\n  end;\n\n  //---------------------------------------------------------------------------\n\n  procedure WriteStyle(const Name: String; Font: TFont);\n\n  // Creates a CSS style entry with the given name for the given font.\n  // If Name is empty then the entry is created as inline style.\n\n  begin\n    if Length(Name) = 0 then\n      Buffer.Add(' style=\"{')\n    else\n    begin\n      Buffer.Add('.');\n      Buffer.Add(Name);\n      Buffer.Add('{');\n    end;\n\n    Buffer.Add(Format('font-family: ''%s''; ', [Font.Name]));\n    if Font.Size < 0 then\n      Buffer.Add(Format('font-size: %dpx; ', [Font.Height]))\n    else\n      Buffer.Add(Format('font-size: %dpt; ', [Font.Size]));\n\n    Buffer.Add(Format('font-style: %s; ', [IfThen(fsItalic in Font.Style, 'italic', 'normal')]));\n    Buffer.Add(Format('font-weight: %s; ', [IfThen(fsBold in Font.Style, 'bold', 'normal')]));\n    Buffer.Add(Format('text-decoration: %s; ', [IfThen(fsUnderline in Font.Style, 'underline', 'none')]));\n\n    Buffer.Add('color: ');\n    WriteColorAsHex(Font.Color);\n    Buffer.Add(';}');\n    if Length(Name) = 0 then\n      Buffer.Add('\"');\n  end;\n\n  //--------------- end local functions ---------------------------------------\n\nvar\n  I, J : Integer;\n  Level, MaxLevel: Cardinal;\n  AddHeader: String;\n  Save, Run: PVirtualNode;\n  GetNextNode: TGetNextNodeProc;\n\n  RenderColumns: Boolean;\n  Columns: TColumnsArray;\n  ColumnColors: array of String;\n  Index: Integer;\n  IndentWidth,\n  LineStyleText: String;\n  Alignment: TAlignment;\n  BidiMode: TBidiMode;\n\n  CellPadding: String;\n  CrackTree: TCustomVirtualStringTreeCracker;\n  lGetCellTextEventArgs: TVSTGetCellTextEventArgs;\nbegin\r\n  CrackTree := TCustomVirtualStringTreeCracker(Tree);\r\n\n  CrackTree.StartOperation(TVTOperationKind.okExport);\n  Buffer := TBufferedString.Create;\n  lGetCellTextEventArgs.ExportType := TVTExportType.etHtml;\n  try\n    // For customization by the application or descendants we use again the redirected font change event.\n    CrackTree.RedirectFontChangeEvent(CrackTree.Canvas);\n\n    CellPadding := Format('padding-left: %dpx; padding-right: %0:dpx;', [CrackTree.Margin]);\n\n    IndentWidth := IntToStr(CrackTree.Indent);\n    AddHeader := ' ';\n    // Add title if adviced so by giving a caption.\n    if Length(Caption) > 0 then\n      AddHeader := AddHeader + 'caption=\"' + Caption + '\"';\n    if CrackTree.Borderstyle <> bsNone then\n      AddHeader := AddHeader + Format(' border=\"%d\" frame=box', [CrackTree.BorderWidth + 1]);\n\n    Buffer.Add('');\n\n    // Create HTML table based on the CrackTree structure. To simplify formatting we use styles defined in a small CSS area.\n    Buffer.Add('');\n    Buffer.AddNewLine;\n\n    // General table properties.\n    Buffer.Add('');\n    Buffer.AddNewLine;\n\n    Columns := nil;\n    ColumnColors := nil;\n    RenderColumns := CrackTree.Header.UseColumns;\n    if RenderColumns then\n    begin\n      Columns := CrackTree.Header.Columns.GetVisibleColumns;\n      SetLength(ColumnColors, Length(Columns));\n    end;\n\n    CrackTree.GetRenderStartValues(Source, Run, GetNextNode);\n    Save := Run;\n\n    MaxLevel := 0;\n    // The table consists of visible columns and rows as used in the CrackTree, but the main CrackTree column is splitted\n    // into several HTML columns to accomodate the indentation.\n    while Assigned(Run) and not CrackTree.OperationCanceled do\n    begin\n      if (CrackTree.CanExportNode(Run)) then\n      begin\n        Level := CrackTree.GetNodeLevel(Run);\n        if Level > MaxLevel then\n          MaxLevel := Level;\n      end;\n      Run := GetNextNode(Run);\n    end;\n\n    if RenderColumns then\n    begin\n      if Assigned(CrackTree.OnBeforeHeaderExport) then\n        CrackTree.OnBeforeHeaderExport(CrackTree, etHTML);\n      Buffer.Add('');\n      Buffer.AddNewLine;\n      // Make the first row in the HTML table an image of the CrackTree header.\n      for I := 0 to High(Columns) do\n      begin\n        if Assigned(CrackTree.OnBeforeColumnExport) then\n          CrackTree.OnBeforeColumnExport(CrackTree, etHTML, Columns[I]);\n        Buffer.Add('');\n        if Assigned(CrackTree.OnAfterColumnExport) then\n          CrackTree.OnAfterColumnExport(CrackTree, etHTML, Columns[I]);\n      end;\n      Buffer.Add('');\n      Buffer.AddNewLine;\n      if Assigned(CrackTree.OnAfterHeaderExport) then\n        CrackTree.OnAfterHeaderExport(CrackTree, etHTML);\n    end;\n\n    // Now go through the CrackTree.\n    Run := Save;\n    while Assigned(Run) and not CrackTree.OperationCanceled do\n    begin\n      if ((not CrackTree.CanExportNode(Run)) or (Assigned(CrackTree.OnBeforeNodeExport) and (not CrackTree.OnBeforeNodeExport(CrackTree, etHTML, Run)))) then\n      begin\n        Run := GetNextNode(Run);\n        Continue;\n      end;\n      Level := CrackTree.GetNodeLevel(Run);\n      Buffer.Add(' ');\n      Buffer.AddNewLine;\n\n      I := 0;\n      while (I < Length(Columns)) or not RenderColumns do\n      begin\n        if RenderColumns then\n          Index := Columns[I].Index\n        else\n          Index := NoColumn;\n\n        if not RenderColumns or (coVisible in Columns[I].Options) then\n        begin\n          // Call back the application to know about font customization.\n          CrackTree.Canvas.Font := CrackTree.Font;\n          CrackTree.FFontChanged := False;\n          CrackTree.DoPaintText(Run, CrackTree.Canvas, Index, ttNormal);\n\n          if Index = CrackTree.Header.MainColumn then\n          begin\n            // Create a cell for each indentation level.\n            if RenderColumns and not (coParentColor in Columns[I].Options) then\n            begin\n              for J := 1 to Level do\n              begin\n                Buffer.Add('');\n              end;\n            end\n            else\n            begin\n              for J := 1 to Level do\n                if J = 1 then\n                begin\n                  Buffer.Add(' ');\n                end\n                else\n                  Buffer.Add(' ');\n            end;\n          end;\n\n          if CrackTree.FFontChanged then\n          begin\n            Buffer.Add(' ');\n        end;\n\n        if not RenderColumns then\n          Break;\n        Inc(I);\n      end;\n      if Assigned(CrackTree.OnAfterNodeExport) then\n        CrackTree.OnAfterNodeExport(CrackTree, etHTML, Run);\n      Run := GetNextNode(Run);\n      Buffer.Add(' ');\n      Buffer.AddNewLine;\n    end;\n    Buffer.Add('
     bdLeftToRight then\n        begin\n          ChangeBidiModeAlignment(Alignment);\n          Buffer.Add(' dir=\"rtl\"');\n        end;\n\n          // Consider aligment.\n        case Alignment of\n          taRightJustify:\n            Buffer.Add(' align=right');\n          taCenter:\n            Buffer.Add(' align=center');\n        else\n          Buffer.Add(' align=left');\n        end;\n\n        Index := Columns[I].Index;\n        // Merge cells of the header emulation in the main column.\n        if (MaxLevel > 0) and (Index = CrackTree.Header.MainColumn) then\n        begin\n          Buffer.Add(' colspan=\"');\n          Buffer.Add(IntToStr(MaxLevel + 1));\n          Buffer.Add('\"');\n        end;\n\n        // The color of the header is usually clBtnFace.\n        Buffer.Add(' bgcolor=');\n        WriteColorAsHex(clBtnFace);\n\n        // Set column width in pixels.\n        Buffer.Add(' width=\"');\n        Buffer.Add(IntToStr(Columns[I].Width));\n        Buffer.Add('px\">');\n\n        if Length(Columns[I].Text) > 0 then\n          Buffer.Add(Columns[I].Text);\n        Buffer.Add('
        bdLeftToRight then\n          begin\n            ChangeBidiModeAlignment(Alignment);\n            Buffer.Add(' dir=\"rtl\"');\n          end;\n\n          // Consider aligment.\n          case Alignment of\n            taRightJustify:\n              Buffer.Add(' align=right');\n            taCenter:\n              Buffer.Add(' align=center');\n          else\n            Buffer.Add(' align=left');\n          end;\n          // Merge cells in the main column.\n          if (MaxLevel > 0) and (Index = CrackTree.Header.MainColumn) and (Level < MaxLevel) then\n          begin\n            Buffer.Add(' colspan=\"');\n            Buffer.Add(IntToStr(MaxLevel - Level + 1));\n            Buffer.Add('\"');\n          end;\n          if RenderColumns and not (coParentColor in Columns[I].Options) then\n          begin\n            Buffer.Add(' bgcolor=');\n            WriteColorAsHex(Columns[I].Color);\n          end;\n          Buffer.Add('>');\n          // Get the text\n          lGetCellTextEventArgs.Node := Run;\n          lGetCellTextEventArgs.Column := Index;\n          CrackTree.DoGetText(lGetCellTextEventArgs);\n          Buffer.Add(lGetCellTextEventArgs.CellText);\n          if not lGetCellTextEventArgs.StaticText.IsEmpty and (toShowStaticText in TStringTreeOptions(CrackTree.TreeOptions).StringOptions) then\n            Buffer.Add(' ' + lGetCellTextEventArgs.StaticText);\n          Buffer.Add('
    ');\n\n    CrackTree.RestoreFontChangeEvent(CrackTree.Canvas);\n\n    Result := Buffer.AsString;\n  finally\n    CrackTree.EndOperation(TVTOperationKind.okExport);\n    Buffer.Free;\n  end;\nend;\n\r\nfunction ContentToRTF(Tree: TCustomVirtualStringTree; Source: TVSTTextSourceType): RawByteString;\r\n\r\n// Renders the current tree content (depending on Source) as RTF (rich text).\n// Based on ideas and code from Frank van den Bergh and Andreas Hoerstemeier.\n\nvar\n  Fonts: TStringList;\n  Colors: TList;\n  CurrentFontIndex,\n  CurrentFontColor,\n  CurrentFontSize: Integer;\n  Buffer: TBufferedRawByteString;\n\n  //--------------- local functions -------------------------------------------\n\n  procedure SelectFont(const Font: string);\n\n  var\n    I: Integer;\n\n  begin\n    I := Fonts.IndexOf(Font);\n    if I > -1 then\n    begin\n      // Font has already been used\n      if I <> CurrentFontIndex then\n      begin\n        Buffer.Add('\\f');\n        Buffer.Add(IntToStr(I));\n        CurrentFontIndex := I;\n      end;\n    end\n    else\n    begin\n      I := Fonts.Add(Font);\n      Buffer.Add('\\f');\n      Buffer.Add(IntToStr(I));\n      CurrentFontIndex := I;\n    end;\n  end;\n\n  //---------------------------------------------------------------------------\n\n  procedure SelectColor(Color: TColor);\n\n  var\n    I: Integer;\n\n  begin\n    I := Colors.IndexOf(Color);\n    if I > -1 then\n    begin\n      // Color has already been used\n      if I <> CurrentFontColor then\n      begin\n        Buffer.Add('\\cf');\n        Buffer.Add(IntToStr(I + 1));\n        CurrentFontColor := I;\n      end;\n    end\n    else\n    begin\n      I := Colors.Add(Color);\n      Buffer.Add('\\cf');\n      Buffer.Add(IntToStr(I + 1));\n      CurrentFontColor := I;\n    end;\n  end;\n\n  //---------------------------------------------------------------------------\n\n  procedure TextPlusFont(const Text: string; Font: TFont);\n\n  var\n    UseUnderline,\n    UseItalic,\n    UseBold: Boolean;\n    I: Integer;\n\n  begin\n    if Length(Text) > 0 then\n    begin\n      UseUnderline := fsUnderline in Font.Style;\n      if UseUnderline then\n        Buffer.Add('\\ul');\n      UseItalic := fsItalic in Font.Style;\n      if UseItalic then\n        Buffer.Add('\\i');\n      UseBold := fsBold in Font.Style;\n      if UseBold then\n        Buffer.Add('\\b');\n      SelectFont(Font.Name);\n      SelectColor(Font.Color);\n      if Font.Size <> CurrentFontSize then\n      begin\n        // Font size must be given in half points.\n        Buffer.Add('\\fs');\n        Buffer.Add(IntToStr(2 * Font.Size));\n        CurrentFontSize := Font.Size;\n      end;\n      // Use escape sequences to note Unicode text.\n      Buffer.Add(' ');\n      // Note: Unicode values > 32767 must be expressed as negative numbers. This is implicitly done\n      //       by interpreting the wide chars (word values) as small integers.\n      for I := 1 to Length(Text) do\n      begin\n        if (Text[I] = WideLF) then\n          Buffer.Add( '{\\par}' )\n        else\n          if (Text[I] <> WideCR) then\n          begin\n            Buffer.Add(Format('\\u%d\\''3f', [SmallInt(Text[I])]));\n            Continue;\n          end;\n      end;\n      if UseUnderline then\n        Buffer.Add('\\ul0');\n      if UseItalic then\n        Buffer.Add('\\i0');\n      if UseBold then\n        Buffer.Add('\\b0');\n    end;\n  end;\n\n  //--------------- end local functions ---------------------------------------\n\nvar\n  Level, LastLevel: Integer;\n  I, J: Integer;\n  Save, Run: PVirtualNode;\n  GetNextNode: TGetNextNodeProc;\n  S, Tabs : RawByteString;\n  Twips: Integer;\n\n  RenderColumns: Boolean;\n  Columns: TColumnsArray;\n  Index: Integer;\n  Alignment: TAlignment;\n  BidiMode: TBidiMode;\n  LocaleBuffer: array [0..1] of Char;\n  CrackTree: TCustomVirtualStringTreeCracker;\n  lGetCellTextEventArgs: TVSTGetCellTextEventArgs;\r\nbegin\r\n  CrackTree := TCustomVirtualStringTreeCracker(Tree);\r\n\n  Buffer := TBufferedRawByteString.Create;\n  lGetCellTextEventArgs.ExportType := TVTExportType.etRtf;\n  CrackTree.StartOperation(TVTOperationKind.okExport);\n  try\n    // For customization by the application or descendants we use again the redirected font change event.\n    CrackTree.RedirectFontChangeEvent(CrackTree.Canvas);\n\n    Fonts := TStringList.Create;\n    Colors := TList.Create;\n    CurrentFontIndex := -1;\n    CurrentFontColor := -1;\n    CurrentFontSize := -1;\n\n    Columns := nil;\n    Tabs := '';\n    LastLevel := 0;\n\n    RenderColumns := CrackTree.Header.UseColumns;\n    if RenderColumns then\n      Columns := CrackTree.Header.Columns.GetVisibleColumns;\n\n    CrackTree.GetRenderStartValues(Source, Run, GetNextNode);\n    Save := Run;\n\n    // First make a table structure. The \\rtf and other header stuff is included\n    // when the font and color tables are created.\n    Buffer.Add('\\uc1\\trowd\\trgaph70');\n    J := 0;\n    if RenderColumns then\n    begin\n      for I := 0 to High(Columns) do\n      begin\n        Inc(J, Columns[I].Width);\n        // This value must be expressed in twips (1 inch = 1440 twips).\n        Twips := Round(1440 * J / Screen.PixelsPerInch);\n        Buffer.Add('\\cellx');\n        Buffer.Add(IntToStr(Twips));\n      end;\n    end\n    else\n    begin\n      Twips := Round(1440 * CrackTree.ClientWidth / Screen.PixelsPerInch);\n      Buffer.Add('\\cellx');\n      Buffer.Add(IntToStr(Twips));\n    end;\n\n    // Fill table header.\n    if RenderColumns then\n    begin\n      if Assigned(CrackTree.OnBeforeHeaderExport) then\n        CrackTree.OnBeforeHeaderExport(CrackTree, etRTF);\n      Buffer.Add('\\pard\\intbl');\n      for I := 0 to High(Columns) do\n      begin\n        if Assigned(CrackTree.OnBeforeColumnExport) then\n          CrackTree.OnBeforeColumnExport(CrackTree, etRTF, Columns[I]);\n        Alignment := Columns[I].CaptionAlignment;\n        BidiMode := Columns[I].BidiMode;\n\n        // Alignment is not supported with older RTF formats, however it will be ignored.\n        if BidiMode <> bdLeftToRight then\n          ChangeBidiModeAlignment(Alignment);\n        case Alignment of\n          taLeftJustify:\n            Buffer.Add('\\ql');\n          taRightJustify:\n            Buffer.Add('\\qr');\n          taCenter:\n            Buffer.Add('\\qc');\n        end;\n\n        TextPlusFont(Columns[I].Text, CrackTree.Header.Font);\n        Buffer.Add('\\cell');\n        if Assigned(CrackTree.OnAfterColumnExport) then\n          CrackTree.OnAfterColumnExport(CrackTree, etRTF, Columns[I]);\n      end;\n      Buffer.Add('\\row');\n      if Assigned(CrackTree.OnAfterHeaderExport) then\n        CrackTree.OnAfterHeaderExport(CrackTree, etRTF);\n    end;\n\n    // Now write the contents.\n    Run := Save;\n    while Assigned(Run) and not CrackTree.OperationCanceled do\n    begin\n      if ((not CrackTree.CanExportNode(Run)) or\n         (Assigned(CrackTree.OnBeforeNodeExport) and (not CrackTree.OnBeforeNodeExport(CrackTree, etRTF, Run)))) then\n      begin\n        Run := GetNextNode(Run);\n        Continue;\n      end;\n      I := 0;\n      while not RenderColumns or (I < Length(Columns)) do\n      begin\n        if RenderColumns then\n        begin\n          Index := Columns[I].Index;\n          Alignment := Columns[I].Alignment;\n          BidiMode := Columns[I].BidiMode;\n        end\n        else\n        begin\n          Index := NoColumn;\n          Alignment := CrackTree.Alignment;\n          BidiMode := CrackTree.BidiMode;\n        end;\n\n        if not RenderColumns or (coVisible in Columns[I].Options) then\n        begin\n          // Get the text\n          lGetCellTextEventArgs.Node := Run;\n          lGetCellTextEventArgs.Column := Index;\n          CrackTree.DoGetText(lGetCellTextEventArgs);\n          Buffer.Add('\\pard\\intbl');\n\n          // Alignment is not supported with older RTF formats, however it will be ignored.\n          if BidiMode <> bdLeftToRight then\n            ChangeBidiModeAlignment(Alignment);\n          case Alignment of\n            taRightJustify:\n              Buffer.Add('\\qr');\n            taCenter:\n              Buffer.Add('\\qc');\n          end;\n\n          // Call back the application to know about font customization.\n          CrackTree.Canvas.Font := CrackTree.Font;\n          CrackTree.FFontChanged := False;\n          CrackTree.DoPaintText(Run, CrackTree.Canvas, Index, ttNormal);\n\n          if Index = CrackTree.Header.MainColumn then\n          begin\n            Level := CrackTree.GetNodeLevel(Run);\n            if Level <> LastLevel then\n            begin\n              LastLevel := Level;\n              Tabs := '';\n              for J := 0 to Level - 1 do\n                Tabs := Tabs + '\\tab';\n            end;\n            if Level > 0 then\n            begin\n              Buffer.Add(Tabs);\n              Buffer.Add(' ');\n              TextPlusFont(lGetCellTextEventArgs.CellText, CrackTree.Canvas.Font);\n            end\n            else\n            begin\n              TextPlusFont(lGetCellTextEventArgs.CellText, CrackTree.Canvas.Font);\n            end;\n          end\n          else\n          begin\n            TextPlusFont(lGetCellTextEventArgs.CellText, CrackTree.Canvas.Font);\n          end;\n          if not lGetCellTextEventArgs.StaticText.IsEmpty and (toShowStaticText in TStringTreeOptions(CrackTree.TreeOptions).StringOptions) then\r\n          begin\n            CrackTree.DoPaintText(Run, CrackTree.Canvas, Index, ttStatic);\n            TextPlusFont(' ' + lGetCellTextEventArgs.StaticText, CrackTree.Canvas.Font);\n          end;//if static text\n          Buffer.Add('\\cell');\n        end;\n\n        if not RenderColumns then\n          Break;\n        Inc(I);\n      end;\n      Buffer.Add('\\row');\n      Buffer.AddNewLine;\n      if (Assigned(CrackTree.OnAfterNodeExport)) then\n        CrackTree.OnAfterNodeExport(CrackTree, etRTF, Run);\n      Run := GetNextNode(Run);\n    end;\n\n    Buffer.Add('\\pard\\par');\n\n    // Build lists with fonts and colors. They have to be at the start of the document.\n    S := '{\\rtf1\\ansi\\ansicpg1252\\deff0\\deflang1043{\\fonttbl';\n    for I := 0 to Fonts.Count - 1 do\n      S := S + Format('{\\f%d %s;}', [I, Fonts[I]]);\n    S := S + '}';\n\n    S := S + '{\\colortbl;';\n    for I := 0 to Colors.Count - 1 do\n    begin\n      J := ColorToRGB(TColor(Colors[I]));\n      S := S + Format('\\red%d\\green%d\\blue%d;', [J and $FF, (J shr 8) and $FF, (J shr 16) and $FF]);\n    end;\n    S := S + '}';\n    if (GetLocaleInfo(LOCALE_USER_DEFAULT, LOCALE_IMEASURE, @LocaleBuffer[0], Length(LocaleBuffer)) <> 0) and (LocaleBuffer[0] = '0'{metric}) then\n      S := S + '\\paperw16840\\paperh11907'// This sets A4 landscape format\n    else\n      S := S + '\\paperw15840\\paperh12240';//[JAM:marder]  This sets US Letter landscape format\n    // Make sure a small margin is used so that a lot of the table fits on a paper. This defines a margin of 0.5\"\n    S := S + '\\margl720\\margr720\\margt720\\margb720';\n    Result := S + Buffer.AsString + '}';\n    Fonts.Free;\n    Colors.Free;\n\n    CrackTree.RestoreFontChangeEvent(CrackTree.Canvas);\n  finally\n    CrackTree.EndOperation(TVTOperationKind.okExport);\n    Buffer.Free;\n  end;\nend;\n\r\n\rfunction ContentToUnicodeString(Tree: TCustomVirtualStringTree; Source: TVSTTextSourceType; const Separator: string): string;\n\n// Renders the current tree content (depending on Source) as Unicode text.\n// If an entry contains the separator char then it is wrapped with double quotation marks.\nvar\n  Buffer: TBufferedString;\n\n  procedure CheckQuotingAndAppend(const pText: string);\n  begin\n    // Wrap the text with quotation marks if it contains the separator character.\r\n    if Pos(Separator, pText) > 0 then\r\n      Buffer.Add(AnsiQuotedStr(pText, '\"'))\n    else\n      Buffer.Add(pText);\n  end;\r\n\nvar\n  RenderColumns: Boolean;\n  Tabs: string;\n  GetNextNode: TGetNextNodeProc;\n  Run, Save: PVirtualNode;\n\n  Columns: TColumnsArray;\n  LastColumn: TVirtualTreeColumn;\n  Level, MaxLevel: Cardinal;\n  Index,\n  I: Integer;\n  CrackTree: TCustomVirtualStringTreeCracker;\n  lGetCellTextEventArgs: TVSTGetCellTextEventArgs;\r\nbegin\r\n  CrackTree := TCustomVirtualStringTreeCracker(Tree);\r\n\n  Buffer := TBufferedString.Create;\n  lGetCellTextEventArgs.ExportType := TVTExportType.etText;\n  CrackTree.StartOperation(TVTOperationKind.okExport);\n  try\n    Columns := nil;\n    RenderColumns := CrackTree.Header.UseColumns;\n    if RenderColumns then\n      Columns := CrackTree.Header.Columns.GetVisibleColumns;\n\n    CrackTree.GetRenderStartValues(Source, Run, GetNextNode);\n    Save := Run;\n\n    // The text consists of visible groups representing the columns, which are separated by one or more separator\n    // characters. There are always MaxLevel separator chars in a line (main column only). Either before the caption\n    // to ident it or after the caption to make the following column aligned.\n    MaxLevel := 0;\n    while Assigned(Run) and not CrackTree.OperationCanceled do\n    begin\n      Level := CrackTree.GetNodeLevel(Run);\n      if Level > MaxLevel then\n        MaxLevel := Level;\n      Run := GetNextNode(Run);\n    end;\n\n    Tabs := DupeString(Separator, MaxLevel);\n\n    // First line is always the header if used.\n    if RenderColumns then\n    begin\n      LastColumn := Columns[High(Columns)];\n      for I := 0 to High(Columns) do\n      begin\n        Buffer.Add(Columns[I].Text);\n        if Columns[I] <> LastColumn then\n        begin\n          if Columns[I].Index = CrackTree.Header.MainColumn then\n          begin\n            Buffer.Add(Tabs);\n            Buffer.Add(Separator);\n          end\n          else\n            Buffer.Add(Separator);\n        end;\n      end;\n      Buffer.AddNewLine;\n    end\n    else\n      LastColumn := nil;\n\n    Run := Save;\n    if RenderColumns then\n    begin\n      while Assigned(Run)  and not CrackTree.OperationCanceled do\n      begin\n        for I := 0 to High(Columns) do\n        begin\n          if coVisible in Columns[I].Options then\n          begin\n            Index := Columns[I].Index;\n            lGetCellTextEventArgs.Node := Run;\n            lGetCellTextEventArgs.Column := Index;\n            CrackTree.DoGetText(lGetCellTextEventArgs);\n            if Index = CrackTree.Header.MainColumn then\n              Buffer.Add(Copy(Tabs, 1, Integer(CrackTree.GetNodeLevel(Run)) * Length(Separator)));\n            if not lGetCellTextEventArgs.StaticText.IsEmpty and (toShowStaticText in TStringTreeOptions(CrackTree.TreeOptions).StringOptions) then\n              CheckQuotingAndAppend(lGetCellTextEventArgs.CellText + ' ' + lGetCellTextEventArgs.StaticText)\n            else\n              CheckQuotingAndAppend(lGetCellTextEventArgs.CellText);\n            if Index = CrackTree.Header.MainColumn then\n              Buffer.Add(Copy(Tabs, 1, Integer(MaxLevel - CrackTree.GetNodeLevel(Run)) * Length(Separator)));\n\n            if Columns[I] <> LastColumn then\n              Buffer.Add(Separator);\n          end;\n        end;\n        Run := GetNextNode(Run);\n        Buffer.AddNewLine;\n      end;\n    end\n    else\n    begin\n      lGetCellTextEventArgs.Column := NoColumn;\n      while Assigned(Run) and not CrackTree.OperationCanceled do\n      begin\n        lGetCellTextEventArgs.Node := Run;\n        CrackTree.DoGetText(lGetCellTextEventArgs);\n        Level := CrackTree.GetNodeLevel(Run);\n        Buffer.Add(Copy(Tabs, 1, Integer(Level) * Length(Separator)));\n        Buffer.Add(lGetCellTextEventArgs.CellText);\n        Buffer.AddNewLine;\n\n        Run := GetNextNode(Run);\n      end;\n    end;\n    Result := Buffer.AsString;\n  finally\n    CrackTree.EndOperation(TVTOperationKind.okExport);\n    Buffer.Free;\n  end;\nend;\n\nfunction ContentToClipboard(Tree: TCustomVirtualStringTree; Format: Word; Source: TVSTTextSourceType): HGLOBAL;\n\n// This method constructs a shareable memory object filled with string data in the required format. Supported are:\n// CF_TEXT - plain ANSI text (Unicode text is converted using the user's current locale)\n// CF_UNICODETEXT - plain Unicode text\n// CF_CSV - comma separated plain ANSI text\n// CF_VRTF + CF_RTFNOOBS - rich text (plain ANSI)\n// CF_HTML - HTML text encoded using UTF-8\n//\n// Result is the handle to a globally allocated memory block which can directly be used for clipboard and drag'n drop\n// transfers. The caller is responsible for freeing the memory. If for some reason the content could not be rendered\n// the Result is 0.\n\n  //--------------- local function --------------------------------------------\n\n  procedure MakeFragment(var HTML: Utf8String);\n\n  // Helper routine to build a properly-formatted HTML fragment.\n\n  const\n    Version = 'Version:1.0'#13#10;\n    StartHTML = 'StartHTML:';\n    EndHTML = 'EndHTML:';\n    StartFragment = 'StartFragment:';\n    EndFragment = 'EndFragment:';\n    DocType = '';\n    HTMLIntro = '' +\n      '';\n    HTMLExtro = '';\n    NumberLengthAndCR = 10;\n\n    // Let the compiler determine the description length.\n    DescriptionLength = Length(Version) + Length(StartHTML) + Length(EndHTML) + Length(StartFragment) +\n      Length(EndFragment) + 4 * NumberLengthAndCR;\n\n  var\n    Description: Utf8String;\n    StartHTMLIndex,\n    EndHTMLIndex,\n    StartFragmentIndex,\n    EndFragmentIndex: Integer;\n\n  begin\n    // The HTML clipboard format is defined by using byte positions in the entire block where HTML text and\n    // fragments start and end. These positions are written in a description. Unfortunately the positions depend on the\n    // length of the description but the description may change with varying positions.\n    // To solve this dilemma the offsets are converted into fixed length strings which makes it possible to know\n    // the description length in advance.\n    StartHTMLIndex := DescriptionLength;              // position 0 after the description\n    StartFragmentIndex := StartHTMLIndex + Length(DocType) + Length(HTMLIntro);\n    EndFragmentIndex := StartFragmentIndex + Length(HTML);\n    EndHTMLIndex := EndFragmentIndex + Length(HTMLExtro);\n\n    Description := Version +\n    System.SysUtils.Format('%s%.8d', [StartHTML, StartHTMLIndex]) + #13#10 +\n    System.SysUtils.Format('%s%.8d', [EndHTML, EndHTMLIndex]) + #13#10 +\n    System.SysUtils.Format('%s%.8d', [StartFragment, StartFragmentIndex]) + #13#10 +\n    System.SysUtils.Format('%s%.8d', [EndFragment, EndFragmentIndex]) + #13#10;\n    HTML := Description + DocType + HTMLIntro + HTML + HTMLExtro;\n  end;\n\n  //--------------- end local function ----------------------------------------\n\nvar\n  Data: Pointer;\n  DataSize: Cardinal;\n  S: AnsiString;\n  WS: string;\n  lUtf8String: Utf8string;\n  P: Pointer;\n  CrackTree: TCustomVirtualStringTreeCracker;\nbegin\r\n  CrackTree := TCustomVirtualStringTreeCracker(Tree);\r\n\n  Result := 0;\n  DataSize := 0;\n  Data := nil;\n  case Format of\n    CF_TEXT:\n      begin\n        S := AnsiString(ContentToUnicodeString(CrackTree, Source, #9) + #0);\n        Data := PAnsiChar(S);\n        DataSize := Length(S);\n      end;\n    CF_UNICODETEXT:\n      begin\n        WS := ContentToUnicodeString(CrackTree, Source, #9) + #0;\n        Data := PWideChar(WS);\n        DataSize := 2 * Length(WS);\n      end;\n  else\n    if Format = CF_CSV then\n    begin\n      S := AnsiString(ContentToUnicodeString(CrackTree, Source, FormatSettings.ListSeparator) + #0);\n      Data := PAnsiChar(S);\n      DataSize := Length(S);\n    end// CF_CSV\n    else if (Format = CF_VRTF) or (Format = CF_VRTFNOOBJS) then\n    begin\n      S := ContentToRTF(CrackTree, Source) + #0;\n      Data := PAnsiChar(S);\n      DataSize := Length(S);\n    end\n    else if Format = CF_HTML then\n    begin\n      lUtf8String := ContentToHTML(CrackTree, Source);\n      // Build a valid HTML clipboard fragment.\n      MakeFragment(lUtf8String);\n      lUtf8String := lUtf8String + #0;\n      Data := PAnsiChar(lUtf8String);\n      DataSize := Length(lUtf8String);\n    end;\n  end;\n\n  if DataSize > 0 then\n  begin\n    Result := GlobalAlloc(GHND or GMEM_SHARE, DataSize);\n    P := GlobalLock(Result);\n    Move(Data^, P^, DataSize);\n    GlobalUnlock(Result);\n  end;\nend;\n\nprocedure ContentToCustom(Tree: TCustomVirtualStringTree; Source: TVSTTextSourceType);\n\n// Generic export procedure which polls the application at every stage of the export.\n\nvar\n  I: Integer;\n  Save, Run: PVirtualNode;\n  GetNextNode: TGetNextNodeProc;\n  RenderColumns: Boolean;\n  Columns: TColumnsArray;\n  CrackTree: TCustomVirtualStringTreeCracker;\nbegin\r\n  CrackTree := TCustomVirtualStringTreeCracker(Tree);\r\n\n  CrackTree.StartOperation(TVTOperationKind.okExport);\n  try\n    Columns := nil;\n    CrackTree.GetRenderStartValues(Source, Run, GetNextNode);\n    Save := Run;\n\n    RenderColumns := CrackTree.Header.UseColumns and ( hoVisible in CrackTree.Header.Options );\n\n    if Assigned(CrackTree.OnBeforeTreeExport) then\n      CrackTree.OnBeforeTreeExport(CrackTree, etCustom);\n\n    // Fill table header.\n    if RenderColumns then\n    begin\n      if Assigned(CrackTree.OnBeforeHeaderExport) then\n        CrackTree.OnBeforeHeaderExport(CrackTree, etCustom);\n\n      Columns := CrackTree.Header.Columns.GetVisibleColumns;\n      for I := 0 to High(Columns) do\n      begin\n        if Assigned(CrackTree.OnBeforeColumnExport) then\n          CrackTree.OnBeforeColumnExport(CrackTree, etCustom, Columns[I]);\n\n        if Assigned(CrackTree.OnColumnExport) then\n          CrackTree.OnColumnExport(CrackTree, etCustom, Columns[I]);\n\n        if Assigned(CrackTree.OnAfterColumnExport) then\n          CrackTree.OnAfterColumnExport(CrackTree, etCustom, Columns[I]);\n      end;\n\n      if Assigned(CrackTree.OnAfterHeaderExport) then\n        CrackTree.OnAfterHeaderExport(CrackTree, etCustom);\n    end;\n\n    // Now write the content.\n    Run := Save;\n    while Assigned(Run) and not CrackTree.OperationCanceled do\n    begin\n      if CrackTree.CanExportNode(Run) then\n      begin\n        if Assigned(CrackTree.OnBeforeNodeExport) then\n          CrackTree.OnBeforeNodeExport(CrackTree, etCustom, Run);\n\n        if Assigned(CrackTree.OnNodeExport) then\n          CrackTree.OnNodeExport(CrackTree, etCustom, Run);\n\n        if Assigned(CrackTree.OnAfterNodeExport) then\n          CrackTree.OnAfterNodeExport(CrackTree, etCustom, Run);\n      end;\n\n      Run := GetNextNode(Run);\n    end;\n\n    if Assigned(CrackTree.OnAfterTreeExport) then\n      CrackTree.OnAfterTreeExport(CrackTree, etCustom);\n  finally\n    CrackTree.EndOperation(TVTOperationKind.okExport);\n  end;\nend;\n\nend.\r\n"
  },
  {
    "path": "External/VirtualTreeView/Source/VirtualTrees.StyleHooks.pas",
    "content": "unit VirtualTrees.StyleHooks;\r\n\r\n// The contents of this file are subject to the Mozilla Public License\r\n// Version 1.1 (the \"License\"); you may not use this file except in compliance\r\n// with the License. You may obtain a copy of the License at http://www.mozilla.org/MPL/\r\n//\r\n// Alternatively, you may redistribute this library, use and/or modify it under the terms of the\r\n// GNU Lesser General Public License as published by the Free Software Foundation;\r\n// either version 2.1 of the License, or (at your option) any later version.\r\n// You may obtain a copy of the LGPL at http://www.gnu.org/copyleft/.\r\n//\r\n// Software distributed under the License is distributed on an \"AS IS\" basis,\r\n// WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for the\r\n// specific language governing rights and limitations under the License.\r\n//\r\n// The original code is VirtualTrees.pas, released September 30, 2000.\r\n//\r\n// The initial developer of the original code is digital publishing AG (Munich, Germany, www.digitalpublishing.de),\r\n// written by Mike Lischke (public@soft-gems.net, www.soft-gems.net).\r\n//\r\n// Portions created by digital publishing AG are Copyright\r\n// (C) 1999-2001 digital publishing AG. All Rights Reserved.\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\n\r\ninterface\r\n\r\n{$WARN UNSAFE_TYPE OFF}\r\n{$WARN UNSAFE_CAST OFF}\r\n{$WARN UNSAFE_CODE OFF}\r\n\r\nuses\r\n  Winapi.Windows,\r\n  Winapi.Messages,\r\n  Winapi.UxTheme,\r\n\r\n  System.Classes,\r\n  Vcl.Themes,\r\n  Vcl.Controls;\r\n\r\nconst\r\n  CM_UPDATE_VCLSTYLE_SCROLLBARS = CM_BASE + 2050;\r\n\r\ntype\r\n  // XE2+ VCL Style\r\n  TVclStyleScrollBarsHook = class(TMouseTrackControlStyleHook)\r\n  strict private type\r\n  {$REGION 'TVclStyleScrollBarWindow'}\r\n      TVclStyleScrollBarWindow = class(TWinControl)strict private FScrollBarWindowOwner: TVclStyleScrollBarsHook;\r\n    FScrollBarVertical: Boolean;\r\n    FScrollBarVisible: Boolean;\r\n    FScrollBarEnabled: Boolean;\r\n    procedure WMNCHitTest(var Msg: TWMNCHitTest); message WM_NCHITTEST;\r\n    procedure WMEraseBkgnd(var Msg: TMessage); message WM_ERASEBKGND;\r\n    procedure WMPaint(var Msg: TWMPaint); message WM_PAINT;\r\n  strict protected\r\n    procedure CreateParams(var Params: TCreateParams);\r\n    override;\r\n  public\r\n    constructor Create(AOwner: TComponent);\r\n    override;\r\n    property ScrollBarWindowOwner: TVclStyleScrollBarsHook read FScrollBarWindowOwner write FScrollBarWindowOwner;\r\n    property ScrollBarVertical: Boolean read FScrollBarVertical write FScrollBarVertical;\r\n    property ScrollBarVisible: Boolean read FScrollBarVisible write FScrollBarVisible;\r\n    property ScrollBarEnabled: Boolean read FScrollBarEnabled write FScrollBarEnabled;\r\n    end;\r\n  {$ENDREGION}\r\n  private\r\n    FHorzScrollBarDownButtonRect: TRect;\r\n    FHorzScrollBarDownButtonState: TThemedScrollBar;\r\n    FHorzScrollBarRect: TRect;\r\n    FHorzScrollBarSliderState: TThemedScrollBar;\r\n    FHorzScrollBarSliderTrackRect: TRect;\r\n    FHorzScrollBarUpButtonRect: TRect;\r\n    FHorzScrollBarUpButtonState: TThemedScrollBar;\r\n    FHorzScrollBarWindow: TVclStyleScrollBarWindow;\r\n    FLeftMouseButtonDown: Boolean;\r\n    FPrevScrollPos: Integer;\r\n    FScrollPos: Single;\r\n    FVertScrollBarDownButtonRect: TRect;\r\n    FVertScrollBarDownButtonState: TThemedScrollBar;\r\n    FVertScrollBarRect: TRect;\r\n    FVertScrollBarSliderState: TThemedScrollBar;\r\n    FVertScrollBarSliderTrackRect: TRect;\r\n    FVertScrollBarUpButtonRect: TRect;\r\n    FVertScrollBarUpButtonState: TThemedScrollBar;\r\n    FVertScrollBarWindow: TVclStyleScrollBarWindow;\r\n\r\n    procedure CMUpdateVclStyleScrollbars(var Message: TMessage); message CM_UPDATE_VCLSTYLE_SCROLLBARS;\r\n    procedure WMEraseBkgnd(var Message: TWMEraseBkgnd); message WM_ERASEBKGND;\r\n    procedure WMKeyDown(var Msg: TMessage); message WM_KEYDOWN;\r\n    procedure WMKeyUp(var Msg: TMessage); message WM_KEYUP;\r\n    procedure WMLButtonDown(var Msg: TWMMouse);  message WM_LBUTTONDOWN;\r\n    procedure WMLButtonUp(var Msg: TWMMouse); message WM_LBUTTONUP;\r\n    procedure WMNCLButtonDown(var Msg: TWMMouse); message WM_NCLBUTTONDOWN;\r\n    procedure WMNCMouseMove(var Msg: TWMMouse); message WM_NCMOUSEMOVE;\r\n    procedure WMNCLButtonUp(var Msg: TWMMouse); message WM_NCLBUTTONUP;\r\n    procedure WMNCPaint(var Msg: TMessage); message WM_NCPAINT;\r\n    procedure WMMouseMove(var Msg: TWMMouse); message WM_MOUSEMOVE;\r\n    procedure WMMouseWheel(var Msg: TMessage); message WM_MOUSEWHEEL;\r\n    procedure WMVScroll(var Msg: TMessage); message WM_VSCROLL;\r\n    procedure WMHScroll(var Msg: TMessage); message WM_HSCROLL;\r\n    procedure WMCaptureChanged(var Msg: TMessage); message WM_CAPTURECHANGED;\r\n    procedure WMNCLButtonDblClk(var Msg: TWMMouse); message WM_NCLBUTTONDBLCLK;\r\n    procedure WMSize(var Msg: TMessage); message WM_SIZE;\r\n    procedure WMMove(var Msg: TMessage); message WM_MOVE;\r\n    procedure WMPosChanged(var Msg: TMessage); message WM_WINDOWPOSCHANGED;\r\n  protected\r\n    procedure CalcScrollBarsRect; virtual;\r\n    procedure DrawHorzScrollBar(DC: HDC); virtual;\r\n    procedure DrawVertScrollBar(DC: HDC); virtual;\r\n    function GetHorzScrollBarSliderRect: TRect;\r\n    function GetVertScrollBarSliderRect: TRect;\r\n    procedure MouseLeave; override;\r\n    procedure PaintScrollBars; virtual;\r\n    function PointInTreeHeader(const P: TPoint): Boolean;\r\n    procedure UpdateScrollBarWindow;\r\n  public\r\n    constructor Create(AControl: TWinControl); override;\r\n    destructor Destroy; override;\r\n  end;\r\n\r\n\r\nimplementation\r\n\r\nuses\r\n  System.SysUtils,\r\n  System.Math,\r\n  System.Types,\r\n  Vcl.Graphics,\r\n  VirtualTrees;\r\n\r\ntype\r\n  TBaseVirtualTreeCracker = class(TBaseVirtualTree)\r\n  end;\r\n\r\n\r\n// XE2+ VCL Style\r\n{ TVclStyleScrollBarsHook }\r\n\r\nprocedure TVclStyleScrollBarsHook.CalcScrollBarsRect;\r\nvar\r\n  P: TPoint;\r\n  BorderValue: TSize;\r\n  BarInfo: TScrollBarInfo;\r\n  I: Integer;\r\n\r\n  procedure CalcVerticalRects;\r\n  begin\r\n    BarInfo.cbSize := SizeOf(BarInfo);\r\n    GetScrollBarInfo(Handle, Integer(OBJID_VSCROLL), BarInfo);\r\n    FVertScrollBarWindow.Visible :=\r\n      not(STATE_SYSTEM_INVISIBLE and BarInfo.rgstate[0] <> 0);\r\n    FVertScrollBarWindow.Enabled :=\r\n      not(STATE_SYSTEM_UNAVAILABLE and BarInfo.rgstate[0] <> 0);\r\n    if FVertScrollBarWindow.Visible then\r\n    begin\r\n      // ScrollBar Rect\r\n      P := BarInfo.rcScrollBar.TopLeft;\r\n      ScreenToClient(Handle, P);\r\n      FVertScrollBarRect.TopLeft := P;\r\n      P := BarInfo.rcScrollBar.BottomRight;\r\n      ScreenToClient(Handle, P);\r\n      FVertScrollBarRect.BottomRight := P;\r\n      OffsetRect(FVertScrollBarRect, BorderValue.cx, BorderValue.cy);\r\n\r\n      I := GetSystemMetrics(SM_CYVTHUMB);\r\n      // Down Button\r\n      FVertScrollBarDownButtonRect := FVertScrollBarRect;\r\n      FVertScrollBarDownButtonRect.Top :=\r\n        FVertScrollBarDownButtonRect.Bottom - I;\r\n\r\n      // UP Button\r\n      FVertScrollBarUpButtonRect := FVertScrollBarRect;\r\n      FVertScrollBarUpButtonRect.Bottom := FVertScrollBarUpButtonRect.Top + I;\r\n\r\n      FVertScrollBarSliderTrackRect := FVertScrollBarRect;\r\n      Inc(FVertScrollBarSliderTrackRect.Top, I);\r\n      Dec(FVertScrollBarSliderTrackRect.Bottom, I);\r\n    end;\r\n  end;\r\n\r\n  procedure CalcHorizontalRects;\r\n  begin\r\n    BarInfo.cbSize := SizeOf(BarInfo);\r\n    GetScrollBarInfo(Handle, Integer(OBJID_HSCROLL), BarInfo);\r\n    FHorzScrollBarWindow.Visible :=\r\n      not(STATE_SYSTEM_INVISIBLE and BarInfo.rgstate[0] <> 0);\r\n    FHorzScrollBarWindow.Enabled :=\r\n      not(STATE_SYSTEM_UNAVAILABLE and BarInfo.rgstate[0] <> 0);\r\n    if FHorzScrollBarWindow.Visible then\r\n    begin\r\n      // ScrollBar Rect\r\n      P := BarInfo.rcScrollBar.TopLeft;\r\n      ScreenToClient(Handle, P);\r\n      FHorzScrollBarRect.TopLeft := P;\r\n      P := BarInfo.rcScrollBar.BottomRight;\r\n      ScreenToClient(Handle, P);\r\n      FHorzScrollBarRect.BottomRight := P;\r\n      OffsetRect(FHorzScrollBarRect, BorderValue.cx, BorderValue.cy);\r\n\r\n      I := GetSystemMetrics(SM_CXHTHUMB);\r\n      // Down Button\r\n      FHorzScrollBarDownButtonRect := FHorzScrollBarRect;\r\n      FHorzScrollBarDownButtonRect.Left :=\r\n        FHorzScrollBarDownButtonRect.Right - I;\r\n\r\n      // UP Button\r\n      FHorzScrollBarUpButtonRect := FHorzScrollBarRect;\r\n      FHorzScrollBarUpButtonRect.Right := FHorzScrollBarUpButtonRect.Left + I;\r\n\r\n      FHorzScrollBarSliderTrackRect := FHorzScrollBarRect;\r\n      Inc(FHorzScrollBarSliderTrackRect.Left, I);\r\n      Dec(FHorzScrollBarSliderTrackRect.Right, I);\r\n    end;\r\n  end;\r\n\r\nbegin\r\n  BorderValue.cx := 0;\r\n  BorderValue.cy := 0;\r\n  if HasBorder then\r\n    if HasClientEdge then\r\n    begin\r\n      BorderValue.cx := GetSystemMetrics(SM_CXEDGE);\r\n      BorderValue.cy := GetSystemMetrics(SM_CYEDGE);\r\n    end;\r\n  CalcVerticalRects;\r\n  CalcHorizontalRects;\r\n\r\nend;\r\n\r\nconstructor TVclStyleScrollBarsHook.Create(AControl: TWinControl);\r\nbegin\r\n  inherited;\r\n  FVertScrollBarWindow := TVclStyleScrollBarWindow.CreateParented\r\n    (GetParent(Control.Handle));\r\n  FVertScrollBarWindow.ScrollBarWindowOwner := Self;\r\n  FVertScrollBarWindow.ScrollBarVertical := True;\r\n\r\n  FHorzScrollBarWindow := TVclStyleScrollBarWindow.CreateParented\r\n    (GetParent(Control.Handle));\r\n  FHorzScrollBarWindow.ScrollBarWindowOwner := Self;\r\n\r\n  FVertScrollBarSliderState := tsThumbBtnVertNormal;\r\n  FVertScrollBarUpButtonState := tsArrowBtnUpNormal;\r\n  FVertScrollBarDownButtonState := tsArrowBtnDownNormal;\r\n  FHorzScrollBarSliderState := tsThumbBtnHorzNormal;\r\n  FHorzScrollBarUpButtonState := tsArrowBtnLeftNormal;\r\n  FHorzScrollBarDownButtonState := tsArrowBtnRightNormal;\r\nend;\r\n\r\ndestructor TVclStyleScrollBarsHook.Destroy;\r\nbegin\r\n  FVertScrollBarWindow.ScrollBarWindowOwner := nil;\r\n  FreeAndNil(FVertScrollBarWindow);\r\n  FHorzScrollBarWindow.ScrollBarWindowOwner := nil;\r\n  FreeAndNil(FHorzScrollBarWindow);\r\n  inherited;\r\nend;\r\n\r\nprocedure TVclStyleScrollBarsHook.DrawHorzScrollBar(DC: HDC);\r\nvar\r\n  B: TBitmap;\r\n  Details: TThemedElementDetails;\r\n  R: TRect;\r\nbegin\r\n  if ((Handle = 0) or (DC = 0)) then\r\n    Exit;\r\n  if FHorzScrollBarWindow.Visible and StyleServices.Available and (seBorder in TBaseVirtualTree(Control).StyleElements) then\r\n  begin\r\n    B := TBitmap.Create;\r\n    try\r\n      B.Width := FHorzScrollBarRect.Width;\r\n      B.Height := FHorzScrollBarRect.Height;\r\n      MoveWindowOrg(B.Canvas.Handle, -FHorzScrollBarRect.Left,\r\n        -FHorzScrollBarRect.Top);\r\n      R := FHorzScrollBarRect;\r\n      R.Left := FHorzScrollBarUpButtonRect.Right;\r\n      R.Right := FHorzScrollBarDownButtonRect.Left;\r\n\r\n      Details := StyleServices.GetElementDetails(tsUpperTrackHorzNormal);\r\n      StyleServices.DrawElement(B.Canvas.Handle, Details, R);\r\n\r\n      if FHorzScrollBarWindow.Enabled then\r\n        Details := StyleServices.GetElementDetails(FHorzScrollBarSliderState);\r\n      StyleServices.DrawElement(B.Canvas.Handle, Details,\r\n        GetHorzScrollBarSliderRect);\r\n\r\n      if FHorzScrollBarWindow.Enabled then\r\n        Details := StyleServices.GetElementDetails(FHorzScrollBarUpButtonState)\r\n      else\r\n        Details := StyleServices.GetElementDetails(tsArrowBtnLeftDisabled);\r\n      StyleServices.DrawElement(B.Canvas.Handle, Details,\r\n        FHorzScrollBarUpButtonRect);\r\n\r\n      if FHorzScrollBarWindow.Enabled then\r\n        Details := StyleServices.GetElementDetails\r\n          (FHorzScrollBarDownButtonState)\r\n      else\r\n        Details := StyleServices.GetElementDetails(tsArrowBtnRightDisabled);\r\n      StyleServices.DrawElement(B.Canvas.Handle, Details,\r\n        FHorzScrollBarDownButtonRect);\r\n\r\n      MoveWindowOrg(B.Canvas.Handle, FHorzScrollBarRect.Left,\r\n        FHorzScrollBarRect.Top);\r\n      with FHorzScrollBarRect do\r\n        BitBlt(DC, Left, Top, B.Width, B.Height, B.Canvas.Handle, 0, 0,\r\n          SRCCOPY);\r\n    finally\r\n      B.Free;\r\n    end;\r\n  end;\r\nend;\r\n\r\nprocedure TVclStyleScrollBarsHook.DrawVertScrollBar(DC: HDC);\r\nvar\r\n  B: TBitmap;\r\n  Details: TThemedElementDetails;\r\n  R: TRect;\r\nbegin\r\n  if ((Handle = 0) or (DC = 0)) then\r\n    Exit;\r\n  if FVertScrollBarWindow.Visible and StyleServices.Available and\r\n    (seBorder in TBaseVirtualTree(Control).StyleElements) then\r\n  begin\r\n    B := TBitmap.Create;\r\n    try\r\n      B.Width := FVertScrollBarRect.Width;\r\n      B.Height := FVertScrollBarWindow.Height;\r\n      MoveWindowOrg(B.Canvas.Handle, -FVertScrollBarRect.Left,\r\n        -FVertScrollBarRect.Top);\r\n      R := FVertScrollBarRect;\r\n      R.Bottom := B.Height + FVertScrollBarRect.Top;\r\n      Details := StyleServices.GetElementDetails(tsUpperTrackVertNormal);\r\n      StyleServices.DrawElement(B.Canvas.Handle, Details, R);\r\n      R.Top := FVertScrollBarUpButtonRect.Bottom;\r\n      R.Bottom := FVertScrollBarDownButtonRect.Top;\r\n\r\n      Details := StyleServices.GetElementDetails(tsUpperTrackVertNormal);\r\n      StyleServices.DrawElement(B.Canvas.Handle, Details, R);\r\n\r\n      if FVertScrollBarWindow.Enabled then\r\n        Details := StyleServices.GetElementDetails(FVertScrollBarSliderState);\r\n      StyleServices.DrawElement(B.Canvas.Handle, Details,\r\n        GetVertScrollBarSliderRect);\r\n\r\n      if FVertScrollBarWindow.Enabled then\r\n        Details := StyleServices.GetElementDetails(FVertScrollBarUpButtonState)\r\n      else\r\n        Details := StyleServices.GetElementDetails(tsArrowBtnUpDisabled);\r\n      StyleServices.DrawElement(B.Canvas.Handle, Details,\r\n        FVertScrollBarUpButtonRect);\r\n\r\n      if FVertScrollBarWindow.Enabled then\r\n        Details := StyleServices.GetElementDetails\r\n          (FVertScrollBarDownButtonState)\r\n      else\r\n        Details := StyleServices.GetElementDetails(tsArrowBtnDownDisabled);\r\n      StyleServices.DrawElement(B.Canvas.Handle, Details,\r\n        FVertScrollBarDownButtonRect);\r\n\r\n      MoveWindowOrg(B.Canvas.Handle, FVertScrollBarRect.Left,\r\n        FVertScrollBarRect.Top);\r\n      with FVertScrollBarRect do\r\n        BitBlt(DC, Left, Top, B.Width, B.Height - TBaseVirtualTreeCracker(Control).BorderWidth, B.Canvas.Handle, 0, 0, SRCCOPY);\r\n    finally\r\n      B.Free;\r\n    end;\r\n  end;\r\nend;\r\n\r\nfunction TVclStyleScrollBarsHook.GetHorzScrollBarSliderRect: TRect;\r\nvar\r\n  P: TPoint;\r\n  BarInfo: TScrollBarInfo;\r\nbegin\r\n  if FHorzScrollBarWindow.Visible and FHorzScrollBarWindow.Enabled then\r\n  begin\r\n    BarInfo.cbSize := SizeOf(BarInfo);\r\n    GetScrollBarInfo(Handle, Integer(OBJID_HSCROLL), BarInfo);\r\n    P := BarInfo.rcScrollBar.TopLeft;\r\n    ScreenToClient(Handle, P);\r\n    Result.TopLeft := P;\r\n    P := BarInfo.rcScrollBar.BottomRight;\r\n    ScreenToClient(Handle, P);\r\n    Result.BottomRight := P;\r\n    Result.Left := BarInfo.xyThumbTop;\r\n    Result.Right := BarInfo.xyThumbBottom;\r\n    if HasBorder then\r\n      if HasClientEdge then\r\n        OffsetRect(Result, 2, 2)\r\n      else\r\n        OffsetRect(Result, 1, 1);\r\n  end\r\n  else\r\n    Result := Rect(0, 0, 0, 0);\r\nend;\r\n\r\nfunction TVclStyleScrollBarsHook.GetVertScrollBarSliderRect: TRect;\r\nvar\r\n  P: TPoint;\r\n  BarInfo: TScrollBarInfo;\r\nbegin\r\n  if FVertScrollBarWindow.Visible and FVertScrollBarWindow.Enabled then\r\n  begin\r\n    BarInfo.cbSize := SizeOf(BarInfo);\r\n    GetScrollBarInfo(Handle, Integer(OBJID_VSCROLL), BarInfo);\r\n    P := BarInfo.rcScrollBar.TopLeft;\r\n    ScreenToClient(Handle, P);\r\n    Result.TopLeft := P;\r\n    P := BarInfo.rcScrollBar.BottomRight;\r\n    ScreenToClient(Handle, P);\r\n    Result.BottomRight := P;\r\n    Result.Top := BarInfo.xyThumbTop;\r\n    Result.Bottom := BarInfo.xyThumbBottom;\r\n    if HasBorder then\r\n      if HasClientEdge then\r\n        OffsetRect(Result, 2, 2)\r\n      else\r\n        OffsetRect(Result, 1, 1);\r\n  end\r\n  else\r\n    Result := Rect(0, 0, 0, 0);\r\nend;\r\n\r\nprocedure TVclStyleScrollBarsHook.MouseLeave;\r\nbegin\r\n  inherited;\r\n  if FVertScrollBarSliderState = tsThumbBtnVertHot then\r\n    FVertScrollBarSliderState := tsThumbBtnVertNormal;\r\n\r\n  if FHorzScrollBarSliderState = tsThumbBtnHorzHot then\r\n    FHorzScrollBarSliderState := tsThumbBtnHorzNormal;\r\n\r\n  if FVertScrollBarUpButtonState = tsArrowBtnUpHot then\r\n    FVertScrollBarUpButtonState := tsArrowBtnUpNormal;\r\n\r\n  if FVertScrollBarDownButtonState = tsArrowBtnDownHot then\r\n    FVertScrollBarDownButtonState := tsArrowBtnDownNormal;\r\n\r\n  if FHorzScrollBarUpButtonState = tsArrowBtnLeftHot then\r\n    FHorzScrollBarUpButtonState := tsArrowBtnLeftNormal;\r\n\r\n  if FHorzScrollBarDownButtonState = tsArrowBtnRightHot then\r\n    FHorzScrollBarDownButtonState := tsArrowBtnRightNormal;\r\n\r\n  PaintScrollBars;\r\nend;\r\n\r\nprocedure TVclStyleScrollBarsHook.PaintScrollBars;\r\nbegin\r\n  FVertScrollBarWindow.Repaint;\r\n  FHorzScrollBarWindow.Repaint;\r\nend;\r\n\r\nfunction TVclStyleScrollBarsHook.PointInTreeHeader(const P: TPoint): Boolean;\r\nbegin\r\n  Result := TBaseVirtualTreeCracker(Control).Header.InHeader(P);\r\nend;\r\n\r\nprocedure TVclStyleScrollBarsHook.UpdateScrollBarWindow;\r\nvar\r\n  R: TRect;\r\n  Owner: TBaseVirtualTree;\r\n  HeaderHeight: Integer;\r\n  BorderWidth: Integer;\r\nbegin\r\n  Owner := TBaseVirtualTree(Control);\r\n  if (hoVisible in TBaseVirtualTreeCracker(Owner).Header.Options) then\r\n    HeaderHeight := TBaseVirtualTreeCracker(Owner).Header.Height\r\n  else\r\n    HeaderHeight := 0;\r\n  BorderWidth := 0;\r\n  // VertScrollBarWindow\r\n\r\n  if FVertScrollBarWindow.Visible and (seBorder in TBaseVirtualTree(Control).StyleElements)\r\n  then\r\n  begin\r\n    R := FVertScrollBarRect;\r\n    if Control.BiDiMode = bdRightToLeft then\r\n    begin\r\n      OffsetRect(R, -R.Left, 0);\r\n      if HasBorder then\r\n        OffsetRect(R, GetSystemMetrics(SM_CXEDGE), 0);\r\n    end;\r\n    if HasBorder then\r\n      BorderWidth := GetSystemMetrics(SM_CYEDGE) * 2;\r\n    ShowWindow(FVertScrollBarWindow.Handle, SW_SHOW);\r\n    SetWindowPos(FVertScrollBarWindow.Handle, HWND_TOP, Control.Left + R.Left +\r\n      TBaseVirtualTreeCracker(Control).BorderWidth, Control.Top + R.Top + HeaderHeight\r\n      + TBaseVirtualTreeCracker(Control).BorderWidth, R.Right - R.Left,\r\n      Control.Height - HeaderHeight - BorderWidth - TBaseVirtualTreeCracker(Control)\r\n      .BorderWidth, SWP_SHOWWINDOW);\r\n  end\r\n  else\r\n    ShowWindow(FVertScrollBarWindow.Handle, SW_HIDE);\r\n\r\n  // HorzScrollBarWindow\r\n  if FHorzScrollBarWindow.Visible and (seBorder in TBaseVirtualTree(Control).StyleElements)\r\n  then\r\n  begin\r\n    R := FHorzScrollBarRect;\r\n    if Control.BiDiMode = bdRightToLeft then\r\n      OffsetRect(R, FVertScrollBarRect.Width, 0);\r\n    ShowWindow(FHorzScrollBarWindow.Handle, SW_SHOW);\r\n    SetWindowPos(FHorzScrollBarWindow.Handle, HWND_TOP, Control.Left + R.Left +\r\n      TBaseVirtualTreeCracker(Control).BorderWidth, Control.Top + R.Top +\r\n      TBaseVirtualTreeCracker(Control).BorderWidth + HeaderHeight, R.Right - R.Left,\r\n      R.Bottom - R.Top, SWP_SHOWWINDOW);\r\n  end\r\n  else\r\n    ShowWindow(FHorzScrollBarWindow.Handle, SW_HIDE);\r\nend;\r\n\r\nprocedure TVclStyleScrollBarsHook.WMCaptureChanged(var Msg: TMessage);\r\nbegin\r\n  if FVertScrollBarWindow.Visible and FVertScrollBarWindow.Enabled then\r\n  begin\r\n    if FVertScrollBarUpButtonState = tsArrowBtnUpPressed then\r\n    begin\r\n      FVertScrollBarUpButtonState := tsArrowBtnUpNormal;\r\n      PaintScrollBars;\r\n    end;\r\n\r\n    if FVertScrollBarDownButtonState = tsArrowBtnDownPressed then\r\n    begin\r\n      FVertScrollBarDownButtonState := tsArrowBtnDownNormal;\r\n      PaintScrollBars;\r\n    end;\r\n  end;\r\n\r\n  if FHorzScrollBarWindow.Visible and FHorzScrollBarWindow.Enabled then\r\n  begin\r\n    if FHorzScrollBarUpButtonState = tsArrowBtnLeftPressed then\r\n    begin\r\n      FHorzScrollBarUpButtonState := tsArrowBtnLeftNormal;\r\n      PaintScrollBars;\r\n    end;\r\n\r\n    if FHorzScrollBarDownButtonState = tsArrowBtnRightPressed then\r\n    begin\r\n      FHorzScrollBarDownButtonState := tsArrowBtnRightNormal;\r\n      PaintScrollBars;\r\n    end;\r\n  end;\r\n\r\n  CallDefaultProc(TMessage(Msg));\r\n  Handled := True;\r\nend;\r\n\r\n\r\n  procedure TVclStyleScrollBarsHook.WMEraseBkgnd(var Message: TWMEraseBkgnd);\r\n  begin\r\n\r\n     Handled := True;\r\n  end;\r\n\r\n\r\nprocedure TVclStyleScrollBarsHook.WMHScroll(var Msg: TMessage);\r\nbegin\r\n  CallDefaultProc(TMessage(Msg));\r\n  PaintScrollBars;\r\n  Handled := True;\r\nend;\r\n\r\nprocedure TVclStyleScrollBarsHook.CMUpdateVclStyleScrollbars\r\n  (var Message: TMessage);\r\nbegin\r\n  CalcScrollBarsRect;\r\n  PaintScrollBars;\r\nend;\r\n\r\nprocedure TVclStyleScrollBarsHook.WMKeyDown(var Msg: TMessage);\r\nbegin\r\n  CallDefaultProc(TMessage(Msg));\r\n  PaintScrollBars;\r\n  Handled := True;\r\nend;\r\n\r\nprocedure TVclStyleScrollBarsHook.WMKeyUp(var Msg: TMessage);\r\nbegin\r\n  CallDefaultProc(TMessage(Msg));\r\n  PaintScrollBars;\r\n  Handled := True;\r\nend;\r\n\r\nprocedure TVclStyleScrollBarsHook.WMLButtonDown(var Msg: TWMMouse);\r\nbegin\r\n  CallDefaultProc(TMessage(Msg));\r\n  PaintScrollBars;\r\n  Handled := True;\r\nend;\r\n\r\nprocedure TVclStyleScrollBarsHook.WMLButtonUp(var Msg: TWMMouse);\r\nvar\r\n  P: TPoint;\r\nbegin\r\n  P := Point(Msg.XPos, Msg.YPos);\r\n  ScreenToClient(Handle, P);\r\n  if not PointInTreeHeader(P) then\r\n  begin\r\n    if FVertScrollBarWindow.Visible then\r\n    begin\r\n      if FVertScrollBarSliderState = tsThumbBtnVertPressed then\r\n      begin\r\n        PostMessage(Handle, WM_VSCROLL,\r\n          Integer(SmallPoint(SB_ENDSCROLL, 0)), 0);\r\n        FLeftMouseButtonDown := False;\r\n        FVertScrollBarSliderState := tsThumbBtnVertNormal;\r\n        PaintScrollBars;\r\n        Handled := True;\r\n        ReleaseCapture;\r\n        Exit;\r\n      end;\r\n\r\n      if FVertScrollBarUpButtonState = tsArrowBtnUpPressed then\r\n        FVertScrollBarUpButtonState := tsArrowBtnUpNormal;\r\n\r\n      if FVertScrollBarDownButtonState = tsArrowBtnDownPressed then\r\n        FVertScrollBarDownButtonState := tsArrowBtnDownNormal;\r\n    end;\r\n\r\n    if FHorzScrollBarWindow.Visible then\r\n    begin\r\n      if FHorzScrollBarSliderState = tsThumbBtnHorzPressed then\r\n      begin\r\n        PostMessage(Handle, WM_HSCROLL,\r\n          Integer(SmallPoint(SB_ENDSCROLL, 0)), 0);\r\n        FLeftMouseButtonDown := False;\r\n        FHorzScrollBarSliderState := tsThumbBtnHorzNormal;\r\n        PaintScrollBars;\r\n        Handled := True;\r\n        ReleaseCapture;\r\n        Exit;\r\n      end;\r\n\r\n      if FHorzScrollBarUpButtonState = tsArrowBtnLeftPressed then\r\n        FHorzScrollBarUpButtonState := tsArrowBtnLeftNormal;\r\n\r\n      if FHorzScrollBarDownButtonState = tsArrowBtnRightPressed then\r\n        FHorzScrollBarDownButtonState := tsArrowBtnRightNormal;\r\n    end;\r\n    PaintScrollBars;\r\n  end;\r\n  FLeftMouseButtonDown := False;\r\nend;\r\n\r\nprocedure TVclStyleScrollBarsHook.WMMouseMove(var Msg: TWMMouse);\r\nvar\r\n  SF: TScrollInfo;\r\nbegin\r\n  inherited;\r\n  if FVertScrollBarSliderState = tsThumbBtnVertPressed then\r\n  begin\r\n    SF.fMask := SIF_ALL;\r\n    SF.cbSize := SizeOf(SF);\r\n    GetScrollInfo(Handle, SB_VERT, SF);\r\n    if SF.nPos <> Round(FScrollPos) then\r\n      FScrollPos := SF.nPos;\r\n\r\n    FScrollPos := FScrollPos + (SF.nMax - SF.nMin) *\r\n      ((Mouse.CursorPos.Y - FPrevScrollPos) /\r\n      FVertScrollBarSliderTrackRect.Height);\r\n    if FScrollPos < SF.nMin then\r\n      FScrollPos := SF.nMin;\r\n    if FScrollPos > SF.nMax then\r\n      FScrollPos := SF.nMax;\r\n    if SF.nPage <> 0 then\r\n      if Round(FScrollPos) > SF.nMax - Integer(SF.nPage) + 1 then\r\n        FScrollPos := SF.nMax - Integer(SF.nPage) + 1;\r\n    FPrevScrollPos := Mouse.CursorPos.Y;\r\n    SF.nPos := Round(FScrollPos);\r\n\r\n    SetScrollInfo(Handle, SB_VERT, SF, False);\r\n    PostMessage(Handle, WM_VSCROLL, Integer(SmallPoint(SB_THUMBPOSITION,\r\n      Min(Round(FScrollPos), High(SmallInt)))), 0);\r\n    // Min() prevents range check error\r\n\r\n    PaintScrollBars;\r\n    Handled := True;\r\n    Exit;\r\n  end;\r\n\r\n  if FHorzScrollBarSliderState = tsThumbBtnHorzPressed then\r\n  begin\r\n    SF.fMask := SIF_ALL;\r\n    SF.cbSize := SizeOf(SF);\r\n    GetScrollInfo(Handle, SB_HORZ, SF);\r\n    if SF.nPos <> Round(FScrollPos) then\r\n      FScrollPos := SF.nPos;\r\n\r\n    FScrollPos := FScrollPos + (SF.nMax - SF.nMin) *\r\n      ((Mouse.CursorPos.X - FPrevScrollPos) /\r\n      FHorzScrollBarSliderTrackRect.Width);\r\n    if FScrollPos < SF.nMin then\r\n      FScrollPos := SF.nMin;\r\n    if FScrollPos > SF.nMax then\r\n      FScrollPos := SF.nMax;\r\n    if SF.nPage <> 0 then\r\n      if Round(FScrollPos) > SF.nMax - Integer(SF.nPage) + 1 then\r\n        FScrollPos := SF.nMax - Integer(SF.nPage) + 1;\r\n    FPrevScrollPos := Mouse.CursorPos.X;\r\n    SF.nPos := Round(FScrollPos);\r\n\r\n    SetScrollInfo(Handle, SB_HORZ, SF, False);\r\n    PostMessage(Handle, WM_HSCROLL, Integer(SmallPoint(SB_THUMBPOSITION,\r\n      Round(FScrollPos))), 0);\r\n\r\n    PaintScrollBars;\r\n    Handled := True;\r\n    Exit;\r\n  end;\r\n\r\n  if FHorzScrollBarSliderState = tsThumbBtnHorzHot then\r\n  begin\r\n    FHorzScrollBarSliderState := tsThumbBtnHorzNormal;\r\n    PaintScrollBars;\r\n  end\r\n  else if FVertScrollBarSliderState = tsThumbBtnVertHot then\r\n  begin\r\n    FVertScrollBarSliderState := tsThumbBtnVertNormal;\r\n    PaintScrollBars;\r\n  end\r\n  else if FHorzScrollBarUpButtonState = tsArrowBtnLeftHot then\r\n  begin\r\n    FHorzScrollBarUpButtonState := tsArrowBtnLeftNormal;\r\n    PaintScrollBars;\r\n  end\r\n  else if FHorzScrollBarDownButtonState = tsArrowBtnRightHot then\r\n  begin\r\n    FHorzScrollBarDownButtonState := tsArrowBtnRightNormal;\r\n    PaintScrollBars;\r\n  end\r\n  else if FVertScrollBarUpButtonState = tsArrowBtnUpHot then\r\n  begin\r\n    FVertScrollBarUpButtonState := tsArrowBtnUpNormal;\r\n    PaintScrollBars;\r\n  end\r\n  else if FVertScrollBarDownButtonState = tsArrowBtnDownHot then\r\n  begin\r\n    FVertScrollBarDownButtonState := tsArrowBtnDownNormal;\r\n    PaintScrollBars;\r\n  end;\r\n\r\n  CallDefaultProc(TMessage(Msg));\r\n  if FLeftMouseButtonDown then\r\n    PaintScrollBars;\r\n  Handled := True;\r\nend;\r\n\r\nprocedure TVclStyleScrollBarsHook.WMMouseWheel(var Msg: TMessage);\r\nbegin\r\n  CallDefaultProc(TMessage(Msg));\r\n  PaintScrollBars;\r\n  Handled := True;\r\nend;\r\n\r\nprocedure TVclStyleScrollBarsHook.WMNCLButtonDblClk(var Msg: TWMMouse);\r\nbegin\r\n  WMNCLButtonDown(Msg);\r\nend;\r\n\r\nprocedure TVclStyleScrollBarsHook.WMNCLButtonDown(var Msg: TWMMouse);\r\nvar\r\n  P: TPoint;\r\n  SF: TScrollInfo;\r\nbegin\r\n  P := Point(Msg.XPos, Msg.YPos);\r\n  ScreenToClient(Handle, P);\r\n\r\n  if HasBorder then\r\n    if HasClientEdge then\r\n    begin\r\n      P.X := P.X + 2;\r\n      P.Y := P.Y + 2;\r\n    end\r\n    else\r\n    begin\r\n      P.X := P.X + 1;\r\n      P.Y := P.Y + 1;\r\n    end;\r\n\r\n  if not PointInTreeHeader(P) then\r\n  begin\r\n    if FVertScrollBarWindow.Visible then\r\n    begin\r\n      if PtInRect(GetVertScrollBarSliderRect, P) then\r\n      begin\r\n        FLeftMouseButtonDown := True;\r\n        SF.fMask := SIF_ALL;\r\n        SF.cbSize := SizeOf(SF);\r\n        GetScrollInfo(Handle, SB_VERT, SF);\r\n        // FListPos := SF.nPos;\r\n        FScrollPos := SF.nPos;\r\n        FPrevScrollPos := Mouse.CursorPos.Y;\r\n        FVertScrollBarSliderState := tsThumbBtnVertPressed;\r\n        PaintScrollBars;\r\n        SetCapture(Handle);\r\n        Handled := True;\r\n        Exit;\r\n      end;\r\n\r\n      if FVertScrollBarWindow.Enabled then\r\n      begin\r\n        if PtInRect(FVertScrollBarDownButtonRect, P) then\r\n          FVertScrollBarDownButtonState := tsArrowBtnDownPressed;\r\n        if PtInRect(FVertScrollBarUpButtonRect, P) then\r\n          FVertScrollBarUpButtonState := tsArrowBtnUpPressed;\r\n      end;\r\n    end;\r\n\r\n    if FHorzScrollBarWindow.Visible then\r\n    begin\r\n      if PtInRect(GetHorzScrollBarSliderRect, P) then\r\n      begin\r\n        FLeftMouseButtonDown := True;\r\n        SF.fMask := SIF_ALL;\r\n        SF.cbSize := SizeOf(SF);\r\n        GetScrollInfo(Handle, SB_HORZ, SF);\r\n        // FListPos := SF.nPos;\r\n        FScrollPos := SF.nPos;\r\n        FPrevScrollPos := Mouse.CursorPos.X;\r\n        FHorzScrollBarSliderState := tsThumbBtnHorzPressed;\r\n        PaintScrollBars;\r\n        SetCapture(Handle);\r\n        Handled := True;\r\n        Exit;\r\n      end;\r\n\r\n      if FHorzScrollBarWindow.Enabled then\r\n      begin\r\n        if PtInRect(FHorzScrollBarDownButtonRect, P) then\r\n          FHorzScrollBarDownButtonState := tsArrowBtnRightPressed;\r\n        if PtInRect(FHorzScrollBarUpButtonRect, P) then\r\n          FHorzScrollBarUpButtonState := tsArrowBtnLeftPressed;\r\n      end;\r\n    end;\r\n    FLeftMouseButtonDown := True;\r\n    PaintScrollBars;\r\n  end;\r\nend;\r\n\r\nprocedure TVclStyleScrollBarsHook.WMNCLButtonUp(var Msg: TWMMouse);\r\nvar\r\n  P: TPoint;\r\n  B: Boolean;\r\nbegin\r\n  P := Point(Msg.XPos, Msg.YPos);\r\n  ScreenToClient(Handle, P);\r\n\r\n  if HasBorder then\r\n    if HasClientEdge then\r\n    begin\r\n      P.X := P.X + 2;\r\n      P.Y := P.Y + 2;\r\n    end\r\n    else\r\n    begin\r\n      P.X := P.X + 1;\r\n      P.Y := P.Y + 1;\r\n    end;\r\n\r\n  B := PointInTreeHeader(P);\r\n\r\n  if not B then\r\n  begin\r\n    if FVertScrollBarWindow.Visible then\r\n      if FVertScrollBarWindow.Enabled then\r\n      begin\r\n        if FVertScrollBarSliderState = tsThumbBtnVertPressed then\r\n        begin\r\n          FLeftMouseButtonDown := False;\r\n          FVertScrollBarSliderState := tsThumbBtnVertNormal;\r\n          PaintScrollBars;\r\n          Handled := True;\r\n          Exit;\r\n        end;\r\n\r\n        if PtInRect(FVertScrollBarDownButtonRect, P) then\r\n          FVertScrollBarDownButtonState := tsArrowBtnDownHot\r\n        else\r\n          FVertScrollBarDownButtonState := tsArrowBtnDownNormal;\r\n\r\n        if PtInRect(FVertScrollBarUpButtonRect, P) then\r\n          FVertScrollBarUpButtonState := tsArrowBtnUpHot\r\n        else\r\n          FVertScrollBarUpButtonState := tsArrowBtnUpNormal;\r\n      end;\r\n\r\n    if FHorzScrollBarWindow.Visible then\r\n      if FHorzScrollBarWindow.Enabled then\r\n      begin\r\n        if FHorzScrollBarSliderState = tsThumbBtnHorzPressed then\r\n        begin\r\n          FLeftMouseButtonDown := False;\r\n          FHorzScrollBarSliderState := tsThumbBtnHorzNormal;\r\n          PaintScrollBars;\r\n          Handled := True;\r\n          Exit;\r\n        end;\r\n\r\n        if PtInRect(FHorzScrollBarDownButtonRect, P) then\r\n          FHorzScrollBarDownButtonState := tsArrowBtnRightHot\r\n        else\r\n          FHorzScrollBarDownButtonState := tsArrowBtnRightNormal;\r\n\r\n        if PtInRect(FHorzScrollBarUpButtonRect, P) then\r\n          FHorzScrollBarUpButtonState := tsArrowBtnLeftHot\r\n        else\r\n          FHorzScrollBarUpButtonState := tsArrowBtnLeftNormal;\r\n      end;\r\n    CallDefaultProc(TMessage(Msg));\r\n  end;\r\n\r\n  if not B and (FHorzScrollBarWindow.Visible) or (FVertScrollBarWindow.Visible)\r\n  then\r\n    PaintScrollBars;\r\n  Handled := True;\r\nend;\r\n\r\nprocedure TVclStyleScrollBarsHook.WMNCMouseMove(var Msg: TWMMouse);\r\nvar\r\n  P: TPoint;\r\n  MustUpdateScroll: Boolean;\r\n  B: Boolean;\r\nbegin\r\n  inherited;\r\n  P := Point(Msg.XPos, Msg.YPos);\r\n  ScreenToClient(Handle, P);\r\n\r\n  if PointInTreeHeader(P) then\r\n  begin\r\n    CallDefaultProc(TMessage(Msg));\r\n    PaintScrollBars;\r\n    Handled := True;\r\n    Exit;\r\n  end;\r\n\r\n  if HasBorder then\r\n    if HasClientEdge then\r\n    begin\r\n      P.X := P.X + 2;\r\n      P.Y := P.Y + 2;\r\n    end\r\n    else\r\n    begin\r\n      P.X := P.X + 1;\r\n      P.Y := P.Y + 1;\r\n    end;\r\n\r\n  MustUpdateScroll := False;\r\n  if FVertScrollBarWindow.Enabled then\r\n  begin\r\n    B := PtInRect(GetVertScrollBarSliderRect, P);\r\n    if B and (FVertScrollBarSliderState = tsThumbBtnVertNormal) then\r\n    begin\r\n      FVertScrollBarSliderState := tsThumbBtnVertHot;\r\n      MustUpdateScroll := True;\r\n    end\r\n    else if not B and (FVertScrollBarSliderState = tsThumbBtnVertHot) then\r\n    begin\r\n      FVertScrollBarSliderState := tsThumbBtnVertNormal;\r\n      MustUpdateScroll := True;\r\n    end;\r\n\r\n    B := PtInRect(FVertScrollBarDownButtonRect, P);\r\n    if B and (FVertScrollBarDownButtonState = tsArrowBtnDownNormal) then\r\n    begin\r\n      FVertScrollBarDownButtonState := tsArrowBtnDownHot;\r\n      MustUpdateScroll := True;\r\n    end\r\n    else if not B and (FVertScrollBarDownButtonState = tsArrowBtnDownHot) then\r\n    begin\r\n      FVertScrollBarDownButtonState := tsArrowBtnDownNormal;\r\n      MustUpdateScroll := True;\r\n    end;\r\n    B := PtInRect(FVertScrollBarUpButtonRect, P);\r\n    if B and (FVertScrollBarUpButtonState = tsArrowBtnUpNormal) then\r\n    begin\r\n      FVertScrollBarUpButtonState := tsArrowBtnUpHot;\r\n      MustUpdateScroll := True;\r\n    end\r\n    else if not B and (FVertScrollBarUpButtonState = tsArrowBtnUpHot) then\r\n    begin\r\n      FVertScrollBarUpButtonState := tsArrowBtnUpNormal;\r\n      MustUpdateScroll := True;\r\n    end;\r\n  end;\r\n\r\n  if FHorzScrollBarWindow.Enabled then\r\n  begin\r\n    B := PtInRect(GetHorzScrollBarSliderRect, P);\r\n    if B and (FHorzScrollBarSliderState = tsThumbBtnHorzNormal) then\r\n    begin\r\n      FHorzScrollBarSliderState := tsThumbBtnHorzHot;\r\n      MustUpdateScroll := True;\r\n    end\r\n    else if not B and (FHorzScrollBarSliderState = tsThumbBtnHorzHot) then\r\n    begin\r\n      FHorzScrollBarSliderState := tsThumbBtnHorzNormal;\r\n      MustUpdateScroll := True;\r\n    end;\r\n\r\n    B := PtInRect(FHorzScrollBarDownButtonRect, P);\r\n    if B and (FHorzScrollBarDownButtonState = tsArrowBtnRightNormal) then\r\n    begin\r\n      FHorzScrollBarDownButtonState := tsArrowBtnRightHot;\r\n      MustUpdateScroll := True;\r\n    end\r\n    else if not B and (FHorzScrollBarDownButtonState = tsArrowBtnRightHot) then\r\n    begin\r\n      FHorzScrollBarDownButtonState := tsArrowBtnRightNormal;\r\n      MustUpdateScroll := True;\r\n    end;\r\n\r\n    B := PtInRect(FHorzScrollBarUpButtonRect, P);\r\n    if B and (FHorzScrollBarUpButtonState = tsArrowBtnLeftNormal) then\r\n    begin\r\n      FHorzScrollBarUpButtonState := tsArrowBtnLeftHot;\r\n      MustUpdateScroll := True;\r\n    end\r\n    else if not B and (FHorzScrollBarUpButtonState = tsArrowBtnLeftHot) then\r\n    begin\r\n      FHorzScrollBarUpButtonState := tsArrowBtnLeftNormal;\r\n      MustUpdateScroll := True;\r\n    end;\r\n  end;\r\n\r\n  if MustUpdateScroll then\r\n    PaintScrollBars;\r\nend;\r\n\r\nprocedure TVclStyleScrollBarsHook.WMNCPaint(var Msg: TMessage);\r\nbegin\r\n if (tsWindowCreating in TBaseVirtualTree(Control).TreeStates) then\r\n  begin\r\n    CalcScrollBarsRect;\r\n    UpdateScrollBarWindow;\r\n end;\r\nend;\r\n\r\nprocedure TVclStyleScrollBarsHook.WMSize(var Msg: TMessage);\r\nbegin\r\n  CallDefaultProc(TMessage(Msg));\r\n  CalcScrollBarsRect;\r\n  UpdateScrollBarWindow;\r\n  PaintScrollBars;\r\n  Handled := True;\r\nend;\r\n\r\nprocedure TVclStyleScrollBarsHook.WMMove(var Msg: TMessage);\r\nbegin\r\n  CallDefaultProc(TMessage(Msg));\r\n  if not(tsWindowCreating in TBaseVirtualTree(Control).TreeStates) then\r\n  begin\r\n    CalcScrollBarsRect;\r\n    UpdateScrollBarWindow;\r\n    PaintScrollBars;\r\n  end;\r\n  Handled := True;\r\nend;\r\n\r\nprocedure TVclStyleScrollBarsHook.WMPosChanged(var Msg: TMessage);\r\nbegin\r\n  WMMove(Msg);\r\nend;\r\n\r\nprocedure TVclStyleScrollBarsHook.WMVScroll(var Msg: TMessage);\r\nbegin\r\n  CallDefaultProc(TMessage(Msg));\r\n  PaintScrollBars;\r\n  Handled := True;\r\nend;\r\n\r\n{ TVclStyleScrollBarsHook.TVclStyleScrollBarWindow }\r\n\r\nconstructor TVclStyleScrollBarsHook.TVclStyleScrollBarWindow.Create\r\n  (AOwner: TComponent);\r\nbegin\r\n  inherited;\r\n  ControlStyle := ControlStyle + [csOverrideStylePaint];\r\n  FScrollBarWindowOwner := nil;\r\n  FScrollBarVertical := False;\r\n  FScrollBarVisible := False;\r\n  FScrollBarEnabled := False;\r\nend;\r\n\r\nprocedure TVclStyleScrollBarsHook.TVclStyleScrollBarWindow.CreateParams\r\n  (var Params: TCreateParams);\r\nbegin\r\n  inherited;\r\n  Params.Style := Params.Style or WS_CHILDWINDOW or WS_CLIPCHILDREN or\r\n    WS_CLIPSIBLINGS;\r\n  Params.ExStyle := Params.ExStyle or WS_EX_NOPARENTNOTIFY;\r\nend;\r\n\r\nprocedure TVclStyleScrollBarsHook.TVclStyleScrollBarWindow.WMEraseBkgnd\r\n  (var Msg: TMessage);\r\nbegin\r\n  Msg.Result := 1;\r\nend;\r\n\r\nprocedure TVclStyleScrollBarsHook.TVclStyleScrollBarWindow.WMNCHitTest\r\n  (var Msg: TWMNCHitTest);\r\nbegin\r\n  Msg.Result := HTTRANSPARENT;\r\nend;\r\n\r\nprocedure TVclStyleScrollBarsHook.TVclStyleScrollBarWindow.WMPaint\r\n  (var Msg: TWMPaint);\r\nvar\r\n  PS: TPaintStruct;\r\n  DC: HDC;\r\nbegin\r\n  BeginPaint(Handle, PS);\r\n  try\r\n    if FScrollBarWindowOwner <> nil then\r\n    begin\r\n      DC := GetWindowDC(Handle);\r\n      try\r\n        if FScrollBarVertical then\r\n        begin\r\n          MoveWindowOrg(DC, -FScrollBarWindowOwner.FVertScrollBarRect.Left,\r\n            -FScrollBarWindowOwner.FVertScrollBarRect.Top);\r\n          FScrollBarWindowOwner.DrawVertScrollBar(DC);\r\n        end\r\n        else\r\n        begin\r\n          MoveWindowOrg(DC, -FScrollBarWindowOwner.FHorzScrollBarRect.Left,\r\n            -FScrollBarWindowOwner.FHorzScrollBarRect.Top);\r\n          FScrollBarWindowOwner.DrawHorzScrollBar(DC);\r\n        end;\r\n      finally\r\n        ReleaseDC(Handle, DC);\r\n      end;\r\n    end;\r\n  finally\r\n    EndPaint(Handle, PS);\r\n  end;\r\nend;\r\n\r\ninitialization\r\n\r\n  TCustomStyleEngine.RegisterStyleHook(TVirtualStringTree, TVclStyleScrollBarsHook);\r\n  TCustomStyleEngine.RegisterStyleHook(TVirtualDrawTree, TVclStyleScrollBarsHook);\r\n\r\nend.\r\n\r\n"
  },
  {
    "path": "External/VirtualTreeView/Source/VirtualTrees.Utils.pas",
    "content": "unit VirtualTrees.Utils;\r\n\r\n// The contents of this file are subject to the Mozilla Public License\r\n// Version 1.1 (the \"License\"); you may not use this file except in compliance\r\n// with the License. You may obtain a copy of the License at http://www.mozilla.org/MPL/\r\n//\r\n// Alternatively, you may redistribute this library, use and/or modify it under the terms of the\r\n// GNU Lesser General Public License as published by the Free Software Foundation;\r\n// either version 2.1 of the License, or (at your option) any later version.\r\n// You may obtain a copy of the LGPL at http://www.gnu.org/copyleft/.\r\n//\r\n// Software distributed under the License is distributed on an \"AS IS\" basis,\r\n// WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for the\r\n// specific language governing rights and limitations under the License.\r\n//\r\n// The original code is VirtualTrees.pas, released September 30, 2000.\r\n//\r\n// The initial developer of the original code is digital publishing AG (Munich, Germany, www.digitalpublishing.de),\r\n// written by Mike Lischke (public@soft-gems.net, www.soft-gems.net).\r\n//\r\n// Portions created by digital publishing AG are Copyright\r\n// (C) 1999-2001 digital publishing AG. All Rights Reserved.\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\ninterface\r\n\r\n{$WARN UNSAFE_TYPE OFF}\r\n{$WARN UNSAFE_CAST OFF}\r\n{$WARN UNSAFE_CODE OFF}\r\n\r\nuses\r\n  Winapi.Windows,\r\n  System.Types,\r\n  Vcl.Graphics,\r\n  Vcl.ImgList;\r\n\r\n\r\ntype\r\n  // Describes the mode how to blend pixels.\r\n  TBlendMode = (\r\n    bmConstantAlpha,         // apply given constant alpha\r\n    bmPerPixelAlpha,         // use alpha value of the source pixel\r\n    bmMasterAlpha,           // use alpha value of source pixel and multiply it with the constant alpha value\r\n    bmConstantAlphaAndColor  // blend the destination color with the given constant color und the constant alpha value\r\n  );\r\n\r\nprocedure AlphaBlend(Source, Destination: HDC; R: TRect; Target: TPoint; Mode: TBlendMode; ConstantAlpha, Bias: Integer);\r\nfunction GetRGBColor(Value: TColor): DWORD;\r\nprocedure PrtStretchDrawDIB(Canvas: TCanvas; DestRect: TRect; ABitmap: TBitmap);\r\nfunction HasMMX: Boolean;\r\n\r\nprocedure SetBrushOrigin(Canvas: TCanvas; X, Y: Integer);\r\n\r\n\r\nprocedure SetCanvasOrigin(Canvas: TCanvas; X, Y: Integer);\r\n\r\n// Clip a given canvas to ClipRect while transforming the given rect to device coordinates.\r\nprocedure ClipCanvas(Canvas: TCanvas; ClipRect: TRect; VisibleRegion: HRGN = 0);\r\n\r\nprocedure DrawImage(ImageList: TCustomImageList; Index: Integer; Canvas: TCanvas; X, Y: Integer; Style: Cardinal; Enabled: Boolean);\r\n\r\n\r\n// Adjusts the given string S so that it fits into the given width. EllipsisWidth gives the width of\r\n// the three points to be added to the shorted string. If this value is 0 then it will be determined implicitely.\r\n// For higher speed (and multiple entries to be shorted) specify this value explicitely.\r\n// Note: It is assumed that the string really needs shortage. Check this in advance.\r\nfunction ShortenString(DC: HDC; const S: string; Width: Integer; EllipsisWidth: Integer = 0): string;\r\n\r\n// Wrap the given string S so that it fits into a space of given width.\r\n// RTL determines if right-to-left reading is active.\r\nfunction WrapString(DC: HDC; const S: string; const Bounds: TRect; RTL: Boolean; DrawFormat: Cardinal): string;\r\n\r\n// Calculates bounds of a drawing rectangle for the given string\r\nprocedure GetStringDrawRect(DC: HDC; const S: string; var Bounds: TRect; DrawFormat: Cardinal);\r\n\r\n// Converts the incoming rectangle so that left and top are always less than or equal to right and bottom.\r\nfunction OrderRect(const R: TRect): TRect;\r\n\r\n// Fills the given rectangles with values which can be used while dragging around an image\r\n// (used in DragMove of the drag manager and DragTo of the header columns).\r\nprocedure FillDragRectangles(DragWidth, DragHeight, DeltaX, DeltaY: Integer; var RClip, RScroll, RSamp1, RSamp2, RDraw1, RDraw2: TRect);\r\n\r\n\r\n\r\nimplementation\r\n\r\nuses\r\n  Winapi.CommCtrl,\r\n  System.SysUtils,\r\n  System.StrUtils,\r\n  System.Math;\r\n\r\nconst\r\n  WideLF = Char(#10);\r\n\r\n\r\nfunction OrderRect(const R: TRect): TRect;\r\n\r\nbegin\r\n  if R.Left < R.Right then\r\n  begin\r\n    Result.Left := R.Left;\r\n    Result.Right := R.Right;\r\n  end\r\n  else\r\n  begin\r\n    Result.Left := R.Right;\r\n    Result.Right := R.Left;\r\n  end;\r\n  if R.Top < R.Bottom then\r\n  begin\r\n    Result.Top := R.Top;\r\n    Result.Bottom := R.Bottom;\r\n  end\r\n  else\r\n  begin\r\n    Result.Top := R.Bottom;\r\n    Result.Bottom := R.Top;\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\n\r\nprocedure SetBrushOrigin(Canvas: TCanvas; X, Y: Integer);\r\n\r\n// Set the brush origin of a given canvas.\r\n\r\nvar\r\n  P: TPoint;\r\n\r\nbegin\r\n  P := Point(X, Y);\r\n  LPtoDP(Canvas.Handle, P, 1);\r\n  SetBrushOrgEx(Canvas.Handle, P.X, P.Y, nil);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure SetCanvasOrigin(Canvas: TCanvas; X, Y: Integer);\r\n\r\n// Set the coordinate space origin of a given canvas.\r\n\r\nvar\r\n  P: TPoint;\r\n\r\nbegin\r\n  // Reset origin as otherwise we would accumulate the origin shifts when calling LPtoDP.\r\n  SetWindowOrgEx(Canvas.Handle, 0, 0, nil);\r\n\r\n  // The shifting is expected in physical points, so we have to transform them accordingly.\r\n  P := Point(X, Y);\r\n  LPtoDP(Canvas.Handle, P, 1);\r\n\r\n  // Do the shift.\r\n  SetWindowOrgEx(Canvas.Handle, P.X, P.Y, nil);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure ClipCanvas(Canvas: TCanvas; ClipRect: TRect; VisibleRegion: HRGN = 0);\r\n\r\nvar\r\n  ClipRegion: HRGN;\r\n\r\nbegin\r\n  // Regions expect their coordinates in device coordinates, hence we have to transform the region rectangle.\r\n  LPtoDP(Canvas.Handle, ClipRect, 2);\r\n  ClipRegion := CreateRectRgnIndirect(ClipRect);\r\n  if VisibleRegion <> 0 then\r\n    CombineRgn(ClipRegion, ClipRegion, VisibleRegion, RGN_AND);\r\n  SelectClipRgn(Canvas.Handle, ClipRegion);\r\n  DeleteObject(ClipRegion);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\n\r\nprocedure GetStringDrawRect(DC: HDC; const S: string; var Bounds: TRect; DrawFormat: Cardinal);\r\n\r\nbegin\r\n  Bounds.Right := Bounds.Left + 1;\r\n  Bounds.Bottom := Bounds.Top + 1;\r\n\r\n  Winapi.Windows.DrawTextW(DC, PWideChar(S), Length(S), Bounds, DrawFormat or DT_CALCRECT);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\n\r\nfunction ShortenString(DC: HDC; const S: string; Width: Integer; EllipsisWidth: Integer = 0): string;\r\n\r\nvar\r\n  Size: TSize;\r\n  Len: Integer;\r\n  L, H, N, W: Integer;\r\n\r\nbegin\r\n  Len := Length(S);\r\n  if (Len = 0) or (Width <= 0) then\r\n    Result := ''\r\n  else\r\n  begin\r\n    // Determine width of triple point using the current DC settings (if not already done).\r\n    if EllipsisWidth = 0 then\r\n    begin\r\n      GetTextExtentPoint32W(DC, '...', 3, Size);\r\n      EllipsisWidth := Size.cx;\r\n    end;\r\n\r\n    if Width <= EllipsisWidth then\r\n      Result := ''\r\n    else\r\n    begin\r\n      // Do a binary search for the optimal string length which fits into the given width.\r\n      L := 0;\r\n      H := Len - 1;\r\n      while L < H do\r\n      begin\r\n        N := (L + H + 1) shr 1;\r\n        GetTextExtentPoint32W(DC, PWideChar(S), N, Size);\r\n        W := Size.cx + EllipsisWidth;\r\n        if W <= Width then\r\n          L := N\r\n        else\r\n          H := N - 1;\r\n      end;\r\n      Result := Copy(S, 1, L) + '...';\r\n    end;\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction WrapString(DC: HDC; const S: string; const Bounds: TRect; RTL: Boolean; DrawFormat: Cardinal): string;\r\n\r\nvar\r\n  Width,\r\n  Len,\r\n  WordCounter,\r\n  WordsInLine,\r\n  I, W: Integer;\r\n  Buffer,\r\n  Line: string;\r\n  Words: array of string;\r\n  R: TRect;\r\n\r\nbegin\r\n  Result := '';\r\n  // Leading and trailing are ignored.\r\n  Buffer := Trim(S);\r\n  Len := Length(Buffer);\r\n  if Len < 1 then\r\n    Exit;\r\n\r\n  Width := Bounds.Right - Bounds.Left;\r\n  R := Rect(0, 0, 0, 0);\r\n\r\n  // Count the words in the string.\r\n  WordCounter := 1;\r\n  for I := 1 to Len do\r\n    if Buffer[I] = ' ' then\r\n      Inc(WordCounter);\r\n  SetLength(Words, WordCounter);\r\n\r\n  if RTL then\r\n  begin\r\n    // At first we split the string into words with the last word being the\r\n    // first element in Words.\r\n    W := 0;\r\n    for I := 1 to Len do\r\n      if Buffer[I] = ' ' then\r\n        Inc(W)\r\n      else\r\n        Words[W] := Words[W] + Buffer[I];\r\n\r\n    // Compose Result.\r\n    while WordCounter > 0 do\r\n    begin\r\n      WordsInLine := 0;\r\n      Line := '';\r\n\r\n      while WordCounter > 0 do\r\n      begin\r\n        GetStringDrawRect(DC, Line + IfThen(WordsInLine > 0, ' ', '') + Words[WordCounter - 1], R, DrawFormat);\r\n        if R.Right > Width then\r\n        begin\r\n          // If at least one word fits into this line then continue with the next line.\r\n          if WordsInLine > 0 then\r\n            Break;\r\n\r\n          Buffer := Words[WordCounter - 1];\r\n          if Len > 1 then\r\n          begin\r\n            for Len := Length(Buffer) - 1 downto 2 do\r\n            begin\r\n              GetStringDrawRect(DC, RightStr(Buffer, Len), R, DrawFormat);\r\n              if R.Right <= Width then\r\n                Break;\r\n            end;\r\n          end\r\n          else\r\n            Len := Length(Buffer);\r\n\r\n          Line := Line + RightStr(Buffer, Max(Len, 1));\r\n          Words[WordCounter - 1] := LeftStr(Buffer, Length(Buffer) - Max(Len, 1));\r\n          if Words[WordCounter - 1] = '' then\r\n            Dec(WordCounter);\r\n          Break;\r\n        end\r\n        else\r\n        begin\r\n          Dec(WordCounter);\r\n          Line := Words[WordCounter] + IfThen(WordsInLine > 0, ' ', '') + Line;\r\n          Inc(WordsInLine);\r\n        end;\r\n      end;\r\n\r\n      Result := Result + Line + WideLF;\r\n    end;\r\n  end\r\n  else\r\n  begin\r\n    // At first we split the string into words with the last word being the\r\n    // first element in Words.\r\n    W := WordCounter - 1;\r\n    for I := 1 to Len do\r\n      if Buffer[I] = ' ' then\r\n        Dec(W)\r\n      else\r\n        Words[W] := Words[W] + Buffer[I];\r\n\r\n    // Compose Result.\r\n    while WordCounter > 0 do\r\n    begin\r\n      WordsInLine := 0;\r\n      Line := '';\r\n\r\n      while WordCounter > 0 do\r\n      begin\r\n        GetStringDrawRect(DC, Line + IfThen(WordsInLine > 0, ' ', '') + Words[WordCounter - 1], R, DrawFormat);\r\n        if R.Right > Width then\r\n        begin\r\n          // If at least one word fits into this line then continue with the next line.\r\n          if WordsInLine > 0 then\r\n            Break;\r\n\r\n          Buffer := Words[WordCounter - 1];\r\n          if Len > 1 then\r\n          begin\r\n            for Len := Length(Buffer) - 1 downto 2 do\r\n            begin\r\n              GetStringDrawRect(DC, LeftStr(Buffer, Len), R, DrawFormat);\r\n              if R.Right <= Width then\r\n                Break;\r\n            end;\r\n          end\r\n          else\r\n            Len := Length(Buffer);\r\n\r\n          Line := Line + LeftStr(Buffer, Max(Len, 1));\r\n          Words[WordCounter - 1] := RightStr(Buffer, Length(Buffer) - Max(Len, 1));\r\n          if Words[WordCounter - 1] = '' then\r\n            Dec(WordCounter);\r\n          Break;\r\n        end\r\n        else\r\n        begin\r\n          Dec(WordCounter);\r\n          Line := Line + IfThen(WordsInLine > 0, ' ', '') + Words[WordCounter];\r\n          Inc(WordsInLine);\r\n        end;\r\n      end;\r\n\r\n      Result := Result + Line + WideLF;\r\n    end;\r\n  end;\r\n\r\n  Len := Length(Result);\r\n  if Result[Len] = WideLF then\r\n    SetLength(Result, Len - 1);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\n\r\nfunction CalculateScanline(Bits: Pointer; Width, Height, Row: Integer): Pointer;\r\n\r\n// Helper function to calculate the start address for the given row.\r\n\r\nbegin\r\n  if Height > 0 then  // bottom-up DIB\r\n    Row := Height - Row - 1;\r\n  // Return DWORD aligned address of the requested scanline.\r\n  Result := PAnsiChar(Bits) + Row * ((Width * 32 + 31) and not 31) div 8;\r\nend;\r\n\r\n\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction GetBitmapBitsFromDeviceContext(DC: HDC; var Width, Height: Integer): Pointer;\r\n\r\n// Helper function used to retrieve the bitmap selected into the given device context. If there is a bitmap then\r\n// the function will return a pointer to its bits otherwise nil is returned.\r\n// Additionally the dimensions of the bitmap are returned.\r\n\r\nvar\r\n  Bitmap: HBITMAP;\r\n  DIB: TDIBSection;\r\n\r\nbegin\r\n  Result := nil;\r\n  Width := 0;\r\n  Height := 0;\r\n\r\n  Bitmap := GetCurrentObject(DC, OBJ_BITMAP);\r\n  if Bitmap <> 0 then\r\n  begin\r\n    if GetObject(Bitmap, SizeOf(DIB), @DIB) = SizeOf(DIB) then\r\n    begin\r\n      Assert(DIB.dsBm.bmPlanes * DIB.dsBm.bmBitsPixel = 32, 'Alpha blending error: bitmap must use 32 bpp.');\r\n      Result := DIB.dsBm.bmBits;\r\n      Width := DIB.dsBmih.biWidth;\r\n      Height := DIB.dsBmih.biHeight;\r\n    end;\r\n  end;\r\n  Assert(Result <> nil, 'Alpha blending DC error: no bitmap available.');\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure AlphaBlendLineConstant(Source, Destination: Pointer; Count: Integer; ConstantAlpha, Bias: Integer);\r\n\r\n// Blends a line of Count pixels from Source to Destination using a constant alpha value.\r\n// The layout of a pixel must be BGRA where A is ignored (but is calculated as the other components).\r\n// ConstantAlpha must be in the range 0..255 where 0 means totally transparent (destination pixel only)\r\n// and 255 totally opaque (source pixel only).\r\n// Bias is an additional value which gets added to every component and must be in the range -128..127\r\n//\r\n{$ifdef CPUX64}\r\n// RCX contains Source\r\n// RDX contains Destination\r\n// R8D contains Count\r\n// R9D contains ConstantAlpha\r\n// Bias is on the stack\r\n\r\nasm\r\n        //.NOFRAME\r\n\r\n        // Load XMM3 with the constant alpha value (replicate it for every component).\r\n        // Expand it to word size.\r\n        MOVD        XMM3, R9D  // ConstantAlpha\r\n        PUNPCKLWD   XMM3, XMM3\r\n        PUNPCKLDQ   XMM3, XMM3\r\n\r\n        // Load XMM5 with the bias value.\r\n        MOVD        XMM5, [Bias]\r\n        PUNPCKLWD   XMM5, XMM5\r\n        PUNPCKLDQ   XMM5, XMM5\r\n\r\n        // Load XMM4 with 128 to allow for saturated biasing.\r\n        MOV         R10D, 128\r\n        MOVD        XMM4, R10D\r\n        PUNPCKLWD   XMM4, XMM4\r\n        PUNPCKLDQ   XMM4, XMM4\r\n\r\n@1:     // The pixel loop calculates an entire pixel in one run.\r\n        // Note: The pixel byte values are expanded into the higher bytes of a word due\r\n        //       to the way unpacking works. We compensate for this with an extra shift.\r\n        MOVD        XMM1, DWORD PTR [RCX]   // data is unaligned\r\n        MOVD        XMM2, DWORD PTR [RDX]   // data is unaligned\r\n        PXOR        XMM0, XMM0    // clear source pixel register for unpacking\r\n        PUNPCKLBW   XMM0, XMM1{[RCX]}    // unpack source pixel byte values into words\r\n        PSRLW       XMM0, 8       // move higher bytes to lower bytes\r\n        PXOR        XMM1, XMM1    // clear target pixel register for unpacking\r\n        PUNPCKLBW   XMM1, XMM2{[RDX]}    // unpack target pixel byte values into words\r\n        MOVQ        XMM2, XMM1    // make a copy of the shifted values, we need them again\r\n        PSRLW       XMM1, 8       // move higher bytes to lower bytes\r\n\r\n        // calculation is: target = (alpha * (source - target) + 256 * target) / 256\r\n        PSUBW       XMM0, XMM1    // source - target\r\n        PMULLW      XMM0, XMM3    // alpha * (source - target)\r\n        PADDW       XMM0, XMM2    // add target (in shifted form)\r\n        PSRLW       XMM0, 8       // divide by 256\r\n\r\n        // Bias is accounted for by conversion of range 0..255 to -128..127,\r\n        // doing a saturated add and convert back to 0..255.\r\n        PSUBW     XMM0, XMM4\r\n        PADDSW    XMM0, XMM5\r\n        PADDW     XMM0, XMM4\r\n        PACKUSWB  XMM0, XMM0      // convert words to bytes with saturation\r\n        MOVD      DWORD PTR [RDX], XMM0     // store the result\r\n@3:\r\n        ADD       RCX, 4\r\n        ADD       RDX, 4\r\n        DEC       R8D\r\n        JNZ       @1\r\nend;\r\n{$else}\r\n// EAX contains Source\r\n// EDX contains Destination\r\n// ECX contains Count\r\n// ConstantAlpha and Bias are on the stack\r\n\r\nasm\r\n        PUSH    ESI                    // save used registers\r\n        PUSH    EDI\r\n\r\n        MOV     ESI, EAX               // ESI becomes the actual source pointer\r\n        MOV     EDI, EDX               // EDI becomes the actual target pointer\r\n\r\n        // Load MM6 with the constant alpha value (replicate it for every component).\r\n        // Expand it to word size.\r\n        MOV     EAX, [ConstantAlpha]\r\n        DB      $0F, $6E, $F0          /// MOVD      MM6, EAX\r\n        DB      $0F, $61, $F6          /// PUNPCKLWD MM6, MM6\r\n        DB      $0F, $62, $F6          /// PUNPCKLDQ MM6, MM6\r\n\r\n        // Load MM5 with the bias value.\r\n        MOV     EAX, [Bias]\r\n        DB      $0F, $6E, $E8          /// MOVD      MM5, EAX\r\n        DB      $0F, $61, $ED          /// PUNPCKLWD MM5, MM5\r\n        DB      $0F, $62, $ED          /// PUNPCKLDQ MM5, MM5\r\n\r\n        // Load MM4 with 128 to allow for saturated biasing.\r\n        MOV     EAX, 128\r\n        DB      $0F, $6E, $E0          /// MOVD      MM4, EAX\r\n        DB      $0F, $61, $E4          /// PUNPCKLWD MM4, MM4\r\n        DB      $0F, $62, $E4          /// PUNPCKLDQ MM4, MM4\r\n\r\n@1:     // The pixel loop calculates an entire pixel in one run.\r\n        // Note: The pixel byte values are expanded into the higher bytes of a word due\r\n        //       to the way unpacking works. We compensate for this with an extra shift.\r\n        DB      $0F, $EF, $C0          /// PXOR      MM0, MM0,   clear source pixel register for unpacking\r\n        DB      $0F, $60, $06          /// PUNPCKLBW MM0, [ESI], unpack source pixel byte values into words\r\n        DB      $0F, $71, $D0, $08     /// PSRLW     MM0, 8,     move higher bytes to lower bytes\r\n        DB      $0F, $EF, $C9          /// PXOR      MM1, MM1,   clear target pixel register for unpacking\r\n        DB      $0F, $60, $0F          /// PUNPCKLBW MM1, [EDI], unpack target pixel byte values into words\r\n        DB      $0F, $6F, $D1          /// MOVQ      MM2, MM1,   make a copy of the shifted values, we need them again\r\n        DB      $0F, $71, $D1, $08     /// PSRLW     MM1, 8,     move higher bytes to lower bytes\r\n\r\n        // calculation is: target = (alpha * (source - target) + 256 * target) / 256\r\n        DB      $0F, $F9, $C1          /// PSUBW     MM0, MM1,   source - target\r\n        DB      $0F, $D5, $C6          /// PMULLW    MM0, MM6,   alpha * (source - target)\r\n        DB      $0F, $FD, $C2          /// PADDW     MM0, MM2,   add target (in shifted form)\r\n        DB      $0F, $71, $D0, $08     /// PSRLW     MM0, 8,     divide by 256\r\n\r\n        // Bias is accounted for by conversion of range 0..255 to -128..127,\r\n        // doing a saturated add and convert back to 0..255.\r\n        DB      $0F, $F9, $C4          /// PSUBW     MM0, MM4\r\n        DB      $0F, $ED, $C5          /// PADDSW    MM0, MM5\r\n        DB      $0F, $FD, $C4          /// PADDW     MM0, MM4\r\n        DB      $0F, $67, $C0          /// PACKUSWB  MM0, MM0,   convert words to bytes with saturation\r\n        DB      $0F, $7E, $07          /// MOVD      [EDI], MM0, store the result\r\n@3:\r\n        ADD     ESI, 4\r\n        ADD     EDI, 4\r\n        DEC     ECX\r\n        JNZ     @1\r\n        POP     EDI\r\n        POP     ESI\r\nend;\r\n{$endif CPUX64}\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure AlphaBlendLinePerPixel(Source, Destination: Pointer; Count, Bias: Integer);\r\n\r\n// Blends a line of Count pixels from Source to Destination using the alpha value of the source pixels.\r\n// The layout of a pixel must be BGRA.\r\n// Bias is an additional value which gets added to every component and must be in the range -128..127\r\n//\r\n{$ifdef CPUX64}\r\n// RCX contains Source\r\n// RDX contains Destination\r\n// R8D contains Count\r\n// R9D contains Bias\r\n\r\nasm\r\n        //.NOFRAME\r\n\r\n        // Load XMM5 with the bias value.\r\n        MOVD        XMM5, R9D   // Bias\r\n        PUNPCKLWD   XMM5, XMM5\r\n        PUNPCKLDQ   XMM5, XMM5\r\n\r\n        // Load XMM4 with 128 to allow for saturated biasing.\r\n        MOV         R10D, 128\r\n        MOVD        XMM4, R10D\r\n        PUNPCKLWD   XMM4, XMM4\r\n        PUNPCKLDQ   XMM4, XMM4\r\n\r\n@1:     // The pixel loop calculates an entire pixel in one run.\r\n        // Note: The pixel byte values are expanded into the higher bytes of a word due\r\n        //       to the way unpacking works. We compensate for this with an extra shift.\r\n        MOVD        XMM1, DWORD PTR [RCX]   // data is unaligned\r\n        MOVD        XMM2, DWORD PTR [RDX]   // data is unaligned\r\n        PXOR        XMM0, XMM0    // clear source pixel register for unpacking\r\n        PUNPCKLBW   XMM0, XMM1{[RCX]}    // unpack source pixel byte values into words\r\n        PSRLW       XMM0, 8       // move higher bytes to lower bytes\r\n        PXOR        XMM1, XMM1    // clear target pixel register for unpacking\r\n        PUNPCKLBW   XMM1, XMM2{[RDX]}    // unpack target pixel byte values into words\r\n        MOVQ        XMM2, XMM1    // make a copy of the shifted values, we need them again\r\n        PSRLW       XMM1, 8       // move higher bytes to lower bytes\r\n\r\n        // Load XMM3 with the source alpha value (replicate it for every component).\r\n        // Expand it to word size.\r\n        MOVQ        XMM3, XMM0\r\n        PUNPCKHWD   XMM3, XMM3\r\n        PUNPCKHDQ   XMM3, XMM3\r\n\r\n        // calculation is: target = (alpha * (source - target) + 256 * target) / 256\r\n        PSUBW       XMM0, XMM1    // source - target\r\n        PMULLW      XMM0, XMM3    // alpha * (source - target)\r\n        PADDW       XMM0, XMM2    // add target (in shifted form)\r\n        PSRLW       XMM0, 8       // divide by 256\r\n\r\n        // Bias is accounted for by conversion of range 0..255 to -128..127,\r\n        // doing a saturated add and convert back to 0..255.\r\n        PSUBW       XMM0, XMM4\r\n        PADDSW      XMM0, XMM5\r\n        PADDW       XMM0, XMM4\r\n        PACKUSWB    XMM0, XMM0    // convert words to bytes with saturation\r\n        MOVD        DWORD PTR [RDX], XMM0   // store the result\r\n@3:\r\n        ADD         RCX, 4\r\n        ADD         RDX, 4\r\n        DEC         R8D\r\n        JNZ         @1\r\nend;\r\n{$else}\r\n// EAX contains Source\r\n// EDX contains Destination\r\n// ECX contains Count\r\n// Bias is on the stack\r\n\r\nasm\r\n        PUSH    ESI                    // save used registers\r\n        PUSH    EDI\r\n\r\n        MOV     ESI, EAX               // ESI becomes the actual source pointer\r\n        MOV     EDI, EDX               // EDI becomes the actual target pointer\r\n\r\n        // Load MM5 with the bias value.\r\n        MOV     EAX, [Bias]\r\n        DB      $0F, $6E, $E8          /// MOVD      MM5, EAX\r\n        DB      $0F, $61, $ED          /// PUNPCKLWD MM5, MM5\r\n        DB      $0F, $62, $ED          /// PUNPCKLDQ MM5, MM5\r\n\r\n        // Load MM4 with 128 to allow for saturated biasing.\r\n        MOV     EAX, 128\r\n        DB      $0F, $6E, $E0          /// MOVD      MM4, EAX\r\n        DB      $0F, $61, $E4          /// PUNPCKLWD MM4, MM4\r\n        DB      $0F, $62, $E4          /// PUNPCKLDQ MM4, MM4\r\n\r\n@1:     // The pixel loop calculates an entire pixel in one run.\r\n        // Note: The pixel byte values are expanded into the higher bytes of a word due\r\n        //       to the way unpacking works. We compensate for this with an extra shift.\r\n        DB      $0F, $EF, $C0          /// PXOR      MM0, MM0,   clear source pixel register for unpacking\r\n        DB      $0F, $60, $06          /// PUNPCKLBW MM0, [ESI], unpack source pixel byte values into words\r\n        DB      $0F, $71, $D0, $08     /// PSRLW     MM0, 8,     move higher bytes to lower bytes\r\n        DB      $0F, $EF, $C9          /// PXOR      MM1, MM1,   clear target pixel register for unpacking\r\n        DB      $0F, $60, $0F          /// PUNPCKLBW MM1, [EDI], unpack target pixel byte values into words\r\n        DB      $0F, $6F, $D1          /// MOVQ      MM2, MM1,   make a copy of the shifted values, we need them again\r\n        DB      $0F, $71, $D1, $08     /// PSRLW     MM1, 8,     move higher bytes to lower bytes\r\n\r\n        // Load MM6 with the source alpha value (replicate it for every component).\r\n        // Expand it to word size.\r\n        DB      $0F, $6F, $F0          /// MOVQ MM6, MM0\r\n        DB      $0F, $69, $F6          /// PUNPCKHWD MM6, MM6\r\n        DB      $0F, $6A, $F6          /// PUNPCKHDQ MM6, MM6\r\n\r\n        // calculation is: target = (alpha * (source - target) + 256 * target) / 256\r\n        DB      $0F, $F9, $C1          /// PSUBW     MM0, MM1,   source - target\r\n        DB      $0F, $D5, $C6          /// PMULLW    MM0, MM6,   alpha * (source - target)\r\n        DB      $0F, $FD, $C2          /// PADDW     MM0, MM2,   add target (in shifted form)\r\n        DB      $0F, $71, $D0, $08     /// PSRLW     MM0, 8,     divide by 256\r\n\r\n        // Bias is accounted for by conversion of range 0..255 to -128..127,\r\n        // doing a saturated add and convert back to 0..255.\r\n        DB      $0F, $F9, $C4          /// PSUBW     MM0, MM4\r\n        DB      $0F, $ED, $C5          /// PADDSW    MM0, MM5\r\n        DB      $0F, $FD, $C4          /// PADDW     MM0, MM4\r\n        DB      $0F, $67, $C0          /// PACKUSWB  MM0, MM0,   convert words to bytes with saturation\r\n        DB      $0F, $7E, $07          /// MOVD      [EDI], MM0, store the result\r\n@3:\r\n        ADD     ESI, 4\r\n        ADD     EDI, 4\r\n        DEC     ECX\r\n        JNZ     @1\r\n        POP     EDI\r\n        POP     ESI\r\nend;\r\n{$endif CPUX64}\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure EMMS;\r\n\r\n// Reset MMX state to use the FPU for other tasks again.\r\n\r\n{$ifdef CPUX64}\r\n  inline;\r\nbegin\r\nend;\r\n{$else}\r\nasm\r\n        DB      $0F, $77               /// EMMS\r\nend;\r\n{$endif CPUX64}\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure AlphaBlendLineMaster(Source, Destination: Pointer; Count: Integer; ConstantAlpha, Bias: Integer);\r\n\r\n// Blends a line of Count pixels from Source to Destination using the source pixel and a constant alpha value.\r\n// The layout of a pixel must be BGRA.\r\n// ConstantAlpha must be in the range 0..255.\r\n// Bias is an additional value which gets added to every component and must be in the range -128..127\r\n//\r\n{$ifdef CPUX64}\r\n// RCX contains Source\r\n// RDX contains Destination\r\n// R8D contains Count\r\n// R9D contains ConstantAlpha\r\n// Bias is on the stack\r\n\r\nasm\r\n        .SAVENV XMM6\r\n\r\n        // Load XMM3 with the constant alpha value (replicate it for every component).\r\n        // Expand it to word size.\r\n        MOVD        XMM3, R9D    // ConstantAlpha\r\n        PUNPCKLWD   XMM3, XMM3\r\n        PUNPCKLDQ   XMM3, XMM3\r\n\r\n        // Load XMM5 with the bias value.\r\n        MOV         R10D, [Bias]\r\n        MOVD        XMM5, R10D\r\n        PUNPCKLWD   XMM5, XMM5\r\n        PUNPCKLDQ   XMM5, XMM5\r\n\r\n        // Load XMM4 with 128 to allow for saturated biasing.\r\n        MOV         R10D, 128\r\n        MOVD        XMM4, R10D\r\n        PUNPCKLWD   XMM4, XMM4\r\n        PUNPCKLDQ   XMM4, XMM4\r\n\r\n@1:     // The pixel loop calculates an entire pixel in one run.\r\n        // Note: The pixel byte values are expanded into the higher bytes of a word due\r\n        //       to the way unpacking works. We compensate for this with an extra shift.\r\n        MOVD        XMM1, DWORD PTR [RCX]   // data is unaligned\r\n        MOVD        XMM2, DWORD PTR [RDX]   // data is unaligned\r\n        PXOR        XMM0, XMM0    // clear source pixel register for unpacking\r\n        PUNPCKLBW   XMM0, XMM1{[RCX]}     // unpack source pixel byte values into words\r\n        PSRLW       XMM0, 8       // move higher bytes to lower bytes\r\n        PXOR        XMM1, XMM1    // clear target pixel register for unpacking\r\n        PUNPCKLBW   XMM1, XMM2{[RCX]}     // unpack target pixel byte values into words\r\n        MOVQ        XMM2, XMM1    // make a copy of the shifted values, we need them again\r\n        PSRLW       XMM1, 8       // move higher bytes to lower bytes\r\n\r\n        // Load XMM6 with the source alpha value (replicate it for every component).\r\n        // Expand it to word size.\r\n        MOVQ        XMM6, XMM0\r\n        PUNPCKHWD   XMM6, XMM6\r\n        PUNPCKHDQ   XMM6, XMM6\r\n        PMULLW      XMM6, XMM3    // source alpha * master alpha\r\n        PSRLW       XMM6, 8       // divide by 256\r\n\r\n        // calculation is: target = (alpha * master alpha * (source - target) + 256 * target) / 256\r\n        PSUBW       XMM0, XMM1    // source - target\r\n        PMULLW      XMM0, XMM6    // alpha * (source - target)\r\n        PADDW       XMM0, XMM2    // add target (in shifted form)\r\n        PSRLW       XMM0, 8       // divide by 256\r\n\r\n        // Bias is accounted for by conversion of range 0..255 to -128..127,\r\n        // doing a saturated add and convert back to 0..255.\r\n        PSUBW       XMM0, XMM4\r\n        PADDSW      XMM0, XMM5\r\n        PADDW       XMM0, XMM4\r\n        PACKUSWB    XMM0, XMM0    // convert words to bytes with saturation\r\n        MOVD        DWORD PTR [RDX], XMM0   // store the result\r\n@3:\r\n        ADD         RCX, 4\r\n        ADD         RDX, 4\r\n        DEC         R8D\r\n        JNZ         @1\r\nend;\r\n{$else}\r\n// EAX contains Source\r\n// EDX contains Destination\r\n// ECX contains Count\r\n// ConstantAlpha and Bias are on the stack\r\n\r\nasm\r\n        PUSH    ESI                    // save used registers\r\n        PUSH    EDI\r\n\r\n        MOV     ESI, EAX               // ESI becomes the actual source pointer\r\n        MOV     EDI, EDX               // EDI becomes the actual target pointer\r\n\r\n        // Load MM6 with the constant alpha value (replicate it for every component).\r\n        // Expand it to word size.\r\n        MOV     EAX, [ConstantAlpha]\r\n        DB      $0F, $6E, $F0          /// MOVD      MM6, EAX\r\n        DB      $0F, $61, $F6          /// PUNPCKLWD MM6, MM6\r\n        DB      $0F, $62, $F6          /// PUNPCKLDQ MM6, MM6\r\n\r\n        // Load MM5 with the bias value.\r\n        MOV     EAX, [Bias]\r\n        DB      $0F, $6E, $E8          /// MOVD      MM5, EAX\r\n        DB      $0F, $61, $ED          /// PUNPCKLWD MM5, MM5\r\n        DB      $0F, $62, $ED          /// PUNPCKLDQ MM5, MM5\r\n\r\n        // Load MM4 with 128 to allow for saturated biasing.\r\n        MOV     EAX, 128\r\n        DB      $0F, $6E, $E0          /// MOVD      MM4, EAX\r\n        DB      $0F, $61, $E4          /// PUNPCKLWD MM4, MM4\r\n        DB      $0F, $62, $E4          /// PUNPCKLDQ MM4, MM4\r\n\r\n@1:     // The pixel loop calculates an entire pixel in one run.\r\n        // Note: The pixel byte values are expanded into the higher bytes of a word due\r\n        //       to the way unpacking works. We compensate for this with an extra shift.\r\n        DB      $0F, $EF, $C0          /// PXOR      MM0, MM0,   clear source pixel register for unpacking\r\n        DB      $0F, $60, $06          /// PUNPCKLBW MM0, [ESI], unpack source pixel byte values into words\r\n        DB      $0F, $71, $D0, $08     /// PSRLW     MM0, 8,     move higher bytes to lower bytes\r\n        DB      $0F, $EF, $C9          /// PXOR      MM1, MM1,   clear target pixel register for unpacking\r\n        DB      $0F, $60, $0F          /// PUNPCKLBW MM1, [EDI], unpack target pixel byte values into words\r\n        DB      $0F, $6F, $D1          /// MOVQ      MM2, MM1,   make a copy of the shifted values, we need them again\r\n        DB      $0F, $71, $D1, $08     /// PSRLW     MM1, 8,     move higher bytes to lower bytes\r\n\r\n        // Load MM7 with the source alpha value (replicate it for every component).\r\n        // Expand it to word size.\r\n        DB      $0F, $6F, $F8          /// MOVQ      MM7, MM0\r\n        DB      $0F, $69, $FF          /// PUNPCKHWD MM7, MM7\r\n        DB      $0F, $6A, $FF          /// PUNPCKHDQ MM7, MM7\r\n        DB      $0F, $D5, $FE          /// PMULLW    MM7, MM6,   source alpha * master alpha\r\n        DB      $0F, $71, $D7, $08     /// PSRLW     MM7, 8,     divide by 256\r\n\r\n        // calculation is: target = (alpha * master alpha * (source - target) + 256 * target) / 256\r\n        DB      $0F, $F9, $C1          /// PSUBW     MM0, MM1,   source - target\r\n        DB      $0F, $D5, $C7          /// PMULLW    MM0, MM7,   alpha * (source - target)\r\n        DB      $0F, $FD, $C2          /// PADDW     MM0, MM2,   add target (in shifted form)\r\n        DB      $0F, $71, $D0, $08     /// PSRLW     MM0, 8,     divide by 256\r\n\r\n        // Bias is accounted for by conversion of range 0..255 to -128..127,\r\n        // doing a saturated add and convert back to 0..255.\r\n        DB      $0F, $F9, $C4          /// PSUBW     MM0, MM4\r\n        DB      $0F, $ED, $C5          /// PADDSW    MM0, MM5\r\n        DB      $0F, $FD, $C4          /// PADDW     MM0, MM4\r\n        DB      $0F, $67, $C0          /// PACKUSWB  MM0, MM0,   convert words to bytes with saturation\r\n        DB      $0F, $7E, $07          /// MOVD      [EDI], MM0, store the result\r\n@3:\r\n        ADD     ESI, 4\r\n        ADD     EDI, 4\r\n        DEC     ECX\r\n        JNZ     @1\r\n        POP     EDI\r\n        POP     ESI\r\nend;\r\n{$endif CPUX64}\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure AlphaBlendLineMasterAndColor(Destination: Pointer; Count: Integer; ConstantAlpha, Color: Integer);\r\n\r\n// Blends a line of Count pixels in Destination against the given color using a constant alpha value.\r\n// The layout of a pixel must be BGRA and Color must be rrggbb00 (as stored by a COLORREF).\r\n// ConstantAlpha must be in the range 0..255.\r\n//\r\n{$ifdef CPUX64}\r\n// RCX contains Destination\r\n// EDX contains Count\r\n// R8D contains ConstantAlpha\r\n// R9D contains Color\r\n\r\nasm\r\n        //.NOFRAME\r\n\r\n        // The used formula is: target = (alpha * color + (256 - alpha) * target) / 256.\r\n        // alpha * color (factor 1) and 256 - alpha (factor 2) are constant values which can be calculated in advance.\r\n        // The remaining calculation is therefore: target = (F1 + F2 * target) / 256\r\n\r\n        // Load XMM3 with the constant alpha value (replicate it for every component).\r\n        // Expand it to word size. (Every calculation here works on word sized operands.)\r\n        MOVD        XMM3, R8D   // ConstantAlpha\r\n        PUNPCKLWD   XMM3, XMM3\r\n        PUNPCKLDQ   XMM3, XMM3\r\n\r\n        // Calculate factor 2.\r\n        MOV         R10D, $100\r\n        MOVD        XMM2, R10D\r\n        PUNPCKLWD   XMM2, XMM2\r\n        PUNPCKLDQ   XMM2, XMM2\r\n        PSUBW       XMM2, XMM3             // XMM2 contains now: 255 - alpha = F2\r\n\r\n        // Now calculate factor 1. Alpha is still in XMM3, but the r and b components of Color must be swapped.\r\n        BSWAP       R9D  // Color\r\n        ROR         R9D, 8\r\n        MOVD        XMM1, R9D              // Load the color and convert to word sized values.\r\n        PXOR        XMM4, XMM4\r\n        PUNPCKLBW   XMM1, XMM4\r\n        PMULLW      XMM1, XMM3             // XMM1 contains now: color * alpha = F1\r\n\r\n@1:     // The pixel loop calculates an entire pixel in one run.\r\n        MOVD        XMM0, DWORD PTR [RCX]\r\n        PUNPCKLBW   XMM0, XMM4\r\n\r\n        PMULLW      XMM0, XMM2             // calculate F1 + F2 * target\r\n        PADDW       XMM0, XMM1\r\n        PSRLW       XMM0, 8                // divide by 256\r\n\r\n        PACKUSWB    XMM0, XMM0             // convert words to bytes with saturation\r\n        MOVD        DWORD PTR [RCX], XMM0            // store the result\r\n\r\n        ADD         RCX, 4\r\n        DEC         EDX\r\n        JNZ         @1\r\nend;\r\n{$else}\r\n// EAX contains Destination\r\n// EDX contains Count\r\n// ECX contains ConstantAlpha\r\n// Color is passed on the stack\r\n\r\nasm\r\n        // The used formula is: target = (alpha * color + (256 - alpha) * target) / 256.\r\n        // alpha * color (factor 1) and 256 - alpha (factor 2) are constant values which can be calculated in advance.\r\n        // The remaining calculation is therefore: target = (F1 + F2 * target) / 256\r\n\r\n        // Load MM3 with the constant alpha value (replicate it for every component).\r\n        // Expand it to word size. (Every calculation here works on word sized operands.)\r\n        DB      $0F, $6E, $D9          /// MOVD      MM3, ECX\r\n        DB      $0F, $61, $DB          /// PUNPCKLWD MM3, MM3\r\n        DB      $0F, $62, $DB          /// PUNPCKLDQ MM3, MM3\r\n\r\n        // Calculate factor 2.\r\n        MOV     ECX, $100\r\n        DB      $0F, $6E, $D1          /// MOVD      MM2, ECX\r\n        DB      $0F, $61, $D2          /// PUNPCKLWD MM2, MM2\r\n        DB      $0F, $62, $D2          /// PUNPCKLDQ MM2, MM2\r\n        DB      $0F, $F9, $D3          /// PSUBW     MM2, MM3             // MM2 contains now: 255 - alpha = F2\r\n\r\n        // Now calculate factor 1. Alpha is still in MM3, but the r and b components of Color must be swapped.\r\n        MOV     ECX, [Color]\r\n        BSWAP   ECX\r\n        ROR     ECX, 8\r\n        DB      $0F, $6E, $C9          /// MOVD      MM1, ECX             // Load the color and convert to word sized values.\r\n        DB      $0F, $EF, $E4          /// PXOR      MM4, MM4\r\n        DB      $0F, $60, $CC          /// PUNPCKLBW MM1, MM4\r\n        DB      $0F, $D5, $CB          /// PMULLW    MM1, MM3             // MM1 contains now: color * alpha = F1\r\n\r\n@1:     // The pixel loop calculates an entire pixel in one run.\r\n        DB      $0F, $6E, $00          /// MOVD      MM0, [EAX]\r\n        DB      $0F, $60, $C4          /// PUNPCKLBW MM0, MM4\r\n\r\n        DB      $0F, $D5, $C2          /// PMULLW    MM0, MM2             // calculate F1 + F2 * target\r\n        DB      $0F, $FD, $C1          /// PADDW     MM0, MM1\r\n        DB      $0F, $71, $D0, $08     /// PSRLW     MM0, 8               // divide by 256\r\n\r\n        DB      $0F, $67, $C0          /// PACKUSWB  MM0, MM0             // convert words to bytes with saturation\r\n        DB      $0F, $7E, $00          /// MOVD      [EAX], MM0           // store the result\r\n\r\n        ADD     EAX, 4\r\n        DEC     EDX\r\n        JNZ     @1\r\nend;\r\n{$endif CPUX64}\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure AlphaBlend(Source, Destination: HDC; R: TRect; Target: TPoint; Mode: TBlendMode; ConstantAlpha, Bias: Integer);\r\n\r\n// Optimized alpha blend procedure using MMX instructions to perform as quick as possible.\r\n// For this procedure to work properly it is important that both source and target bitmap use the 32 bit color format.\r\n// R describes the source rectangle to work on.\r\n// Target is the place (upper left corner) in the target bitmap where to blend to. Note that source width + X offset\r\n// must be less or equal to the target width. Similar for the height.\r\n// If Mode is bmConstantAlpha then the blend operation uses the given ConstantAlpha value for all pixels.\r\n// If Mode is bmPerPixelAlpha then each pixel is blended using its individual alpha value (the alpha value of the source).\r\n// If Mode is bmMasterAlpha then each pixel is blended using its individual alpha value multiplied by ConstantAlpha.\r\n// If Mode is bmConstantAlphaAndColor then each destination pixel is blended using ConstantAlpha but also a constant\r\n// color which will be obtained from Bias. In this case no offset value is added, otherwise Bias is used as offset.\r\n// Blending of a color into target only (bmConstantAlphaAndColor) ignores Source (the DC) and Target (the position).\r\n// CAUTION: This procedure does not check whether MMX instructions are actually available! Call it only if MMX is really\r\n//          usable.\r\n\r\nvar\r\n  Y: Integer;\r\n  SourceRun,\r\n  TargetRun: PByte;\r\n\r\n  SourceBits,\r\n  DestBits: Pointer;\r\n  SourceWidth,\r\n  SourceHeight,\r\n  DestWidth,\r\n  DestHeight: Integer;\r\n\r\nbegin\r\n  if not IsRectEmpty(R) then\r\n  begin\r\n    // Note: it is tempting to optimize the special cases for constant alpha 0 and 255 by just ignoring soure\r\n    //       (alpha = 0) or simply do a blit (alpha = 255). But this does not take the bias into account.\r\n    case Mode of\r\n      bmConstantAlpha:\r\n        begin\r\n          // Get a pointer to the bitmap bits for the source and target device contexts.\r\n          // Note: this supposes that both contexts do actually have bitmaps assigned!\r\n          SourceBits := GetBitmapBitsFromDeviceContext(Source, SourceWidth, SourceHeight);\r\n          DestBits := GetBitmapBitsFromDeviceContext(Destination, DestWidth, DestHeight);\r\n          if Assigned(SourceBits) and Assigned(DestBits) then\r\n          begin\r\n            for Y := 0 to R.Bottom - R.Top - 1 do\r\n            begin\r\n              SourceRun := CalculateScanline(SourceBits, SourceWidth, SourceHeight, Y + R.Top);\r\n              Inc(SourceRun, 4 * R.Left);\r\n              TargetRun := CalculateScanline(DestBits, DestWidth, DestHeight, Y + Target.Y);\r\n              Inc(TargetRun, 4 * Target.X);\r\n              AlphaBlendLineConstant(SourceRun, TargetRun, R.Right - R.Left, ConstantAlpha, Bias);\r\n            end;\r\n          end;\r\n          EMMS;\r\n        end;\r\n      bmPerPixelAlpha:\r\n        begin\r\n          SourceBits := GetBitmapBitsFromDeviceContext(Source, SourceWidth, SourceHeight);\r\n          DestBits := GetBitmapBitsFromDeviceContext(Destination, DestWidth, DestHeight);\r\n          if Assigned(SourceBits) and Assigned(DestBits) then\r\n          begin\r\n            for Y := 0 to R.Bottom - R.Top - 1 do\r\n            begin\r\n              SourceRun := CalculateScanline(SourceBits, SourceWidth, SourceHeight, Y + R.Top);\r\n              Inc(SourceRun, 4 * R.Left);\r\n              TargetRun := CalculateScanline(DestBits, DestWidth, DestHeight, Y + Target.Y);\r\n              Inc(TargetRun, 4 * Target.X);\r\n              AlphaBlendLinePerPixel(SourceRun, TargetRun, R.Right - R.Left, Bias);\r\n            end;\r\n          end;\r\n          EMMS;\r\n        end;\r\n      bmMasterAlpha:\r\n        begin\r\n          SourceBits := GetBitmapBitsFromDeviceContext(Source, SourceWidth, SourceHeight);\r\n          DestBits := GetBitmapBitsFromDeviceContext(Destination, DestWidth, DestHeight);\r\n          if Assigned(SourceBits) and Assigned(DestBits) then\r\n          begin\r\n            for Y := 0 to R.Bottom - R.Top - 1 do\r\n            begin\r\n              SourceRun := CalculateScanline(SourceBits, SourceWidth, SourceHeight, Y + R.Top);\r\n              Inc(SourceRun, 4 * Target.X);\r\n              TargetRun := CalculateScanline(DestBits, DestWidth, DestHeight, Y + Target.Y);\r\n              AlphaBlendLineMaster(SourceRun, TargetRun, R.Right - R.Left, ConstantAlpha, Bias);\r\n            end;\r\n          end;\r\n          EMMS;\r\n        end;\r\n      bmConstantAlphaAndColor:\r\n        begin\r\n          // Source is ignored since there is a constant color value.\r\n          DestBits := GetBitmapBitsFromDeviceContext(Destination, DestWidth, DestHeight);\r\n          if Assigned(DestBits) then\r\n          begin\r\n            for Y := 0 to R.Bottom - R.Top - 1 do\r\n            begin\r\n              TargetRun := CalculateScanline(DestBits, DestWidth, DestHeight, Y + R.Top);\r\n              Inc(TargetRun, 4 * R.Left);\r\n              AlphaBlendLineMasterAndColor(TargetRun, R.Right - R.Left, ConstantAlpha, Bias);\r\n            end;\r\n          end;\r\n          EMMS;\r\n        end;\r\n    end;\r\n  end;\r\nend;\r\n\r\nfunction GetRGBColor(Value: TColor): DWORD;\r\n\r\n// Little helper to convert a Delphi color to an image list color.\r\n\r\nbegin\r\n  Result := ColorToRGB(Value);\r\n  case Result of\r\n    clNone:\r\n      Result := CLR_NONE;\r\n    clDefault:\r\n      Result := CLR_DEFAULT;\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure PrtStretchDrawDIB(Canvas: TCanvas; DestRect: TRect; ABitmap: TBitmap);\r\n\r\n// Stretch draw on to the new canvas.\r\n\r\nvar\r\n  Header,\r\n  Bits: Pointer;\r\n  HeaderSize,\r\n  BitsSize: Cardinal;\r\n\r\nbegin\r\n  GetDIBSizes(ABitmap.Handle, HeaderSize, BitsSize);\r\n\r\n  GetMem(Header, HeaderSize);\r\n  GetMem(Bits, BitsSize);\r\n  try\r\n    GetDIB(ABitmap.Handle, ABitmap.Palette, Header^, Bits^);\r\n    StretchDIBits(Canvas.Handle, DestRect.Left, DestRect.Top, DestRect.Right - DestRect.Left, DestRect.Bottom -\r\n      DestRect.Top, 0, 0, ABitmap.Width, ABitmap.Height, Bits, TBitmapInfo(Header^), DIB_RGB_COLORS, SRCCOPY);\r\n  finally\r\n    FreeMem(Header);\r\n    FreeMem(Bits);\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction HasMMX: Boolean;\r\n\r\n// Helper method to determine whether the current processor supports MMX.\r\n\r\n{$ifdef CPUX64}\r\nbegin\r\n  // We use SSE2 in the \"MMX-functions\"\r\n  Result := True;\r\nend;\r\n{$else}\r\nasm\r\n        PUSH    EBX\r\n        XOR     EAX, EAX     // Result := False\r\n        PUSHFD               // determine if the processor supports the CPUID command\r\n        POP     EDX\r\n        MOV     ECX, EDX\r\n        XOR     EDX, $200000\r\n        PUSH    EDX\r\n        POPFD\r\n        PUSHFD\r\n        POP     EDX\r\n        XOR     ECX, EDX\r\n        JZ      @1           // no CPUID support so we can't even get to the feature information\r\n        PUSH    EDX\r\n        POPFD\r\n\r\n        MOV     EAX, 1\r\n        DW      $A20F        // CPUID, EAX contains now version info and EDX feature information\r\n        MOV     EBX, EAX     // free EAX to get the result value\r\n        XOR     EAX, EAX     // Result := False\r\n        CMP     EBX, $50\r\n        JB      @1           // if processor family is < 5 then it is not a Pentium class processor\r\n        TEST    EDX, $800000\r\n        JZ      @1           // if the MMX bit is not set then we don't have MMX\r\n        INC     EAX          // Result := True\r\n@1:\r\n        POP     EBX\r\nend;\r\n{$endif CPUX64}\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\n\r\nprocedure FillDragRectangles(DragWidth, DragHeight, DeltaX, DeltaY: Integer; var RClip, RScroll, RSamp1, RSamp2, RDraw1, RDraw2: TRect);\r\n\r\nbegin\r\n  // ScrollDC limits\r\n  RClip := Rect(0, 0, DragWidth, DragHeight);\r\n  if DeltaX > 0 then\r\n  begin\r\n    // move to the left\r\n    if DeltaY = 0 then\r\n    begin\r\n      // move only to the left\r\n      // background movement\r\n      RScroll := Rect(0, 0, DragWidth - DeltaX, DragHeight);\r\n      RSamp1 := Rect(0, 0, DeltaX, DragHeight);\r\n      RDraw1 := Rect(DragWidth - DeltaX, 0, DeltaX, DragHeight);\r\n    end\r\n    else\r\n      if DeltaY < 0 then\r\n      begin\r\n        // move to bottom left\r\n        RScroll := Rect(0, -DeltaY, DragWidth - DeltaX, DragHeight);\r\n        RSamp1 := Rect(0, 0, DeltaX, DragHeight);\r\n        RSamp2 := Rect(DeltaX, DragHeight + DeltaY, DragWidth - DeltaX, -DeltaY);\r\n        RDraw1 := Rect(0, 0, DragWidth - DeltaX, -DeltaY);\r\n        RDraw2 := Rect(DragWidth - DeltaX, 0, DeltaX, DragHeight);\r\n      end\r\n      else\r\n      begin\r\n        // move to upper left\r\n        RScroll := Rect(0, 0, DragWidth - DeltaX, DragHeight - DeltaY);\r\n        RSamp1 := Rect(0, 0, DeltaX, DragHeight);\r\n        RSamp2 := Rect(DeltaX, 0, DragWidth - DeltaX, DeltaY);\r\n        RDraw1 := Rect(0, DragHeight - DeltaY, DragWidth - DeltaX, DeltaY);\r\n        RDraw2 := Rect(DragWidth - DeltaX, 0, DeltaX, DragHeight);\r\n      end;\r\n  end\r\n  else\r\n    if DeltaX = 0 then\r\n    begin\r\n      // vertical movement only\r\n      if DeltaY < 0 then\r\n      begin\r\n        // move downwards\r\n        RScroll := Rect(0, -DeltaY, DragWidth, DragHeight);\r\n        RSamp2 := Rect(0, DragHeight + DeltaY, DragWidth, -DeltaY);\r\n        RDraw2 := Rect(0, 0, DragWidth, -DeltaY);\r\n      end\r\n      else\r\n      begin\r\n        // move upwards\r\n        RScroll := Rect(0, 0, DragWidth, DragHeight - DeltaY);\r\n        RSamp2 := Rect(0, 0, DragWidth, DeltaY);\r\n        RDraw2 := Rect(0, DragHeight - DeltaY, DragWidth, DeltaY);\r\n      end;\r\n    end\r\n    else\r\n    begin\r\n      // move to the right\r\n      if DeltaY > 0 then\r\n      begin\r\n        // move up right\r\n        RScroll := Rect(-DeltaX, 0, DragWidth, DragHeight);\r\n        RSamp1 := Rect(0, 0, DragWidth + DeltaX, DeltaY);\r\n        RSamp2 := Rect(DragWidth + DeltaX, 0, -DeltaX, DragHeight);\r\n        RDraw1 := Rect(0, 0, -DeltaX, DragHeight);\r\n        RDraw2 := Rect(-DeltaX, DragHeight - DeltaY, DragWidth + DeltaX, DeltaY);\r\n      end\r\n      else\r\n        if DeltaY = 0 then\r\n        begin\r\n          // to the right only\r\n          RScroll := Rect(-DeltaX, 0, DragWidth, DragHeight);\r\n          RSamp1 := Rect(DragWidth + DeltaX, 0, -DeltaX, DragHeight);\r\n          RDraw1 := Rect(0, 0, -DeltaX, DragHeight);\r\n        end\r\n        else\r\n        begin\r\n          // move down right\r\n          RScroll := Rect(-DeltaX, -DeltaY, DragWidth, DragHeight);\r\n          RSamp1 := Rect(0, DragHeight + DeltaY, DragWidth + DeltaX, -DeltaY);\r\n          RSamp2 := Rect(DragWidth + DeltaX, 0, -DeltaX, DragHeight);\r\n          RDraw1 := Rect(0, 0, -DeltaX, DragHeight);\r\n          RDraw2 := Rect(-DeltaX, 0, DragWidth + DeltaX, -DeltaY);\r\n        end;\r\n    end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\ntype\r\n  TCustomImageListCast = class(TCustomImageList);\r\n\r\nprocedure DrawImage(ImageList: TCustomImageList; Index: Integer; Canvas: TCanvas; X, Y: Integer; Style: Cardinal; Enabled: Boolean);\r\n\r\n  procedure DrawDisabledImage(ImageList: TCustomImageList; Canvas: TCanvas; X, Y, Index: Integer);\r\n  var\r\n    Params: TImageListDrawParams;\r\n  begin\r\n    FillChar(Params, SizeOf(Params), 0);\r\n    Params.cbSize := SizeOf(Params);\r\n    Params.himl := ImageList.Handle;\r\n    Params.i := Index;\r\n    Params.hdcDst := Canvas.Handle;\r\n    Params.x := X;\r\n    Params.y := Y;\r\n    Params.fState := ILS_SATURATE;\r\n    ImageList_DrawIndirect(@Params);\r\n  end;\r\n\r\nbegin\r\n  if Enabled then\r\n    TCustomImageListCast(ImageList).DoDraw(Index, Canvas, X, Y, Style, Enabled)\r\n  else\r\n    DrawDisabledImage(ImageList, Canvas, X, Y, Index);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\n\r\nend.\r\n"
  },
  {
    "path": "External/VirtualTreeView/Source/VirtualTrees.WorkerThread.pas",
    "content": "unit VirtualTrees.WorkerThread;\r\n\r\ninterface\r\n\r\nuses\r\n  System.Classes,\r\n  VirtualTrees;\r\n\r\ntype\r\n  // internal worker thread\r\n  TWorkerThread = class(TThread)\r\n  private\r\n    FCurrentTree: TBaseVirtualTree;\r\n    FWaiterList: TThreadList;\r\n    FRefCount: Cardinal;\r\n  protected\r\n    procedure CancelValidation(Tree: TBaseVirtualTree);\r\n    procedure Execute; override;\r\n  public\r\n    constructor Create(CreateSuspended: Boolean);\r\n    destructor Destroy; override;\r\n\r\n    procedure AddTree(Tree: TBaseVirtualTree);\r\n    procedure RemoveTree(Tree: TBaseVirtualTree);\r\n\r\n    property CurrentTree: TBaseVirtualTree read FCurrentTree;\r\n  end;\r\n\r\n\r\nprocedure AddThreadReference;\r\nprocedure ReleaseThreadReference(Tree: TBaseVirtualTree);\r\n\r\n\r\nvar\r\n  WorkerThread: TWorkerThread;\r\n  WorkEvent: THandle;\r\n\r\n\r\nimplementation\r\n\r\nuses\r\n  Winapi.Windows,\r\n  System.Types,\r\n  System.SysUtils;\r\n\r\ntype\r\n  TBaseVirtualTreeCracker = class(TBaseVirtualTree)\r\n  end;\r\n\r\n//----------------- TWorkerThread --------------------------------------------------------------------------------------\r\n\r\nprocedure AddThreadReference;\r\nbegin\r\n  if not Assigned(WorkerThread) then\r\n  begin\r\n    // Create an event used to trigger our worker thread when something is to do.\r\n    WorkEvent := CreateEvent(nil, False, False, nil);\r\n    if WorkEvent = 0 then\r\n      RaiseLastOSError;\r\n\r\n    // Create worker thread, initialize it and send it to its wait loop.\r\n    WorkerThread := TWorkerThread.Create(False);\r\n  end;\r\n  Inc(WorkerThread.FRefCount);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure ReleaseThreadReference(Tree: TBaseVirtualTree);\r\n\r\nbegin\r\n  if Assigned(WorkerThread) then\r\n  begin\r\n    Dec(WorkerThread.FRefCount);\r\n\r\n    // Make sure there is no reference remaining to the releasing tree.\r\n    TBaseVirtualTreeCracker(Tree).InterruptValidation;\r\n\r\n    if WorkerThread.FRefCount = 0 then\r\n    begin\r\n      with WorkerThread do\r\n      begin\r\n        Terminate;\r\n        SetEvent(WorkEvent);\r\n      end;\r\n      FreeAndNil(WorkerThread);\r\n      CloseHandle(WorkEvent);\r\n    end;\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nconstructor TWorkerThread.Create(CreateSuspended: Boolean);\r\n\r\nbegin\r\n  inherited Create(CreateSuspended);\r\n  FWaiterList := TThreadList.Create;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\ndestructor TWorkerThread.Destroy;\r\n\r\nbegin\r\n  // First let the ancestor stop the thread before freeing our resources.\r\n  inherited;\r\n\r\n  FWaiterList.Free;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TWorkerThread.CancelValidation(Tree: TBaseVirtualTree);\r\n\r\nvar\r\n  Msg: TMsg;\r\n\r\nbegin\r\n  // Wait for any references to this tree to be released.\r\n  // Pump WM_CHANGESTATE messages so the thread doesn't block on SendMessage calls.\r\n  while FCurrentTree = Tree do\r\n  begin\r\n    if Tree.HandleAllocated and PeekMessage(Msg, Tree.Handle, WM_CHANGESTATE, WM_CHANGESTATE, PM_REMOVE) then\r\n    begin\r\n      TranslateMessage(Msg);\r\n      DispatchMessage(Msg);\r\n      Continue;\r\n    end;\r\n    if (toVariableNodeHeight in TBaseVirtualTreeCracker(Tree).TreeOptions.MiscOptions) then\r\n      CheckSynchronize(); // We need to call CheckSynchronize here because we are using TThread.Synchronize in TBaseVirtualTree.MeasureItemHeight()\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TWorkerThread.Execute;\r\n\r\n// Does some background tasks, like validating tree caches.\r\n\r\nvar\r\n  EnterStates,\r\n  LeaveStates: TChangeStates;\r\n  lCurrentTree: TBaseVirtualTree;\r\n\r\nbegin\r\n  TThread.NameThreadForDebugging('VirtualTrees.TWorkerThread');\r\n  while not Terminated do\r\n  begin\r\n    WaitForSingleObject(WorkEvent, INFINITE);\r\n    if not Terminated then\r\n    begin\r\n      // Get the next waiting tree.\r\n      with FWaiterList.LockList do\r\n      try\r\n        if Count > 0 then\r\n        begin\r\n          FCurrentTree := Items[0];\r\n          // Remove this tree from waiter list.\r\n          Delete(0);\r\n          // If there is yet another tree to work on then set the work event to keep looping.\r\n          if Count > 0 then\r\n            SetEvent(WorkEvent);\r\n        end\r\n        else\r\n          FCurrentTree := nil;\r\n      finally\r\n        FWaiterList.UnlockList;\r\n      end;\r\n\r\n      // Something to do?\r\n      if Assigned(FCurrentTree) then\r\n      begin\r\n        try\r\n          TBaseVirtualTreeCracker(FCurrentTree).ChangeTreeStatesAsync([csValidating], [csUseCache, csValidationNeeded]);\r\n          EnterStates := [];\r\n          if not (tsStopValidation in FCurrentTree.TreeStates) and TBaseVirtualTreeCracker(FCurrentTree).DoValidateCache then\r\n            EnterStates := [csUseCache];\r\n\r\n        finally\r\n          LeaveStates := [csValidating, csStopValidation];\r\n          TBaseVirtualTreeCracker(FCurrentTree).ChangeTreeStatesAsync(EnterStates, LeaveStates);\r\n          lCurrentTree := FCurrentTree; // Save reference in a local variable for later use\r\n          FCurrentTree := nil; //Clear variable to prevent deadlock in CancelValidation. See #434\r\n          Queue(TBaseVirtualTreeCracker(lCurrentTree).UpdateEditBounds);\r\n        end;\r\n      end;\r\n    end;\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TWorkerThread.AddTree(Tree: TBaseVirtualTree);\r\n\r\nbegin\r\n  Assert(Assigned(Tree), 'Tree must not be nil.');\r\n\r\n  // Remove validation stop flag, just in case it is still set.\r\n  TBaseVirtualTreeCracker(Tree).DoStateChange([], [tsStopValidation]);\r\n  with FWaiterList.LockList do\r\n  try\r\n    if IndexOf(Tree) = -1 then\r\n      Add(Tree);\r\n  finally\r\n    FWaiterList.UnlockList;\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TWorkerThread.RemoveTree(Tree: TBaseVirtualTree);\r\n\r\nbegin\r\n  Assert(Assigned(Tree), 'Tree must not be nil.');\r\n\r\n  with FWaiterList.LockList do\r\n  try\r\n    Remove(Tree);\r\n  finally\r\n    FWaiterList.UnlockList; // Seen several AVs in this line, was called from TWorkerThrea.Destroy. Joachim Marder.\r\n  end;\r\n  CancelValidation(Tree);\r\nend;\r\n\r\n\r\nend.\r\n"
  },
  {
    "path": "External/VirtualTreeView/Source/VirtualTrees.pas",
    "content": "unit VirtualTrees;\r\n\r\n// The contents of this file are subject to the Mozilla Public License\r\n// Version 1.1 (the \"License\"); you may not use this file except in compliance\r\n// with the License. You may obtain a copy of the License at http://www.mozilla.org/MPL/\r\n//\r\n// Alternatively, you may redistribute this library, use and/or modify it under the terms of the\r\n// GNU Lesser General Public License as published by the Free Software Foundation;\r\n// either version 2.1 of the License, or (at your option) any later version.\r\n// You may obtain a copy of the LGPL at http://www.gnu.org/copyleft/.\r\n//\r\n// Software distributed under the License is distributed on an \"AS IS\" basis,\r\n// WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for the\r\n// specific language governing rights and limitations under the License.\r\n//\r\n// The original code is VirtualTrees.pas, released September 30, 2000.\r\n//\r\n// The initial developer of the original code is digital publishing AG (Munich, Germany, www.digitalpublishing.de),\r\n// most code was written by Mike Lischke 2000-2009 (public@soft-gems.net, www.soft-gems.net)\r\n//\r\n// Portions created by digital publishing AG are Copyright\r\n// (C) 1999-2001 digital publishing AG. All Rights Reserved.\r\n//----------------------------------------------------------------------------------------------------------------------\r\n//\r\n// For a list of recent changes please see file CHANGES.TXT\r\n//\r\n// Credits for their valuable assistance and code donations go to:\r\n//   Freddy Ertl, Marian Aldenhvel, Thomas Bogenrieder, Jim Kuenemann, Werner Lehmann, Jens Treichler,\r\n//   Paul Gallagher (IBO tree), Ondrej Kelle, Ronaldo Melo Ferraz, Heri Bender, Roland Bedrftig (BCB)\r\n//   Anthony Mills, Alexander Egorushkin (BCB), Mathias Torell (BCB), Frank van den Bergh, Vadim Sedulin, Peter Evans,\r\n//   Milan Vandrovec (BCB), Steve Moss, Joe White, David Clark, Anders Thomsen, Igor Afanasyev, Eugene Programmer,\r\n//   Corbin Dunn, Richard Pringle, Uli Gerhardt, Azza, Igor Savkic, Daniel Bauten, Timo Tegtmeier, Dmitry Zegebart,\r\n//   Andreas Hausladen, Joachim Marder, Roman Kassebaum, Vincent Parret\r\n// Beta testers:\r\n//   Freddy Ertl, Hans-Jrgen Schnorrenberg, Werner Lehmann, Jim Kueneman, Vadim Sedulin, Moritz Franckenstein,\r\n//   Wim van der Vegt, Franc v/d Westelaken\r\n// Indirect contribution (via publicly accessible work of those persons):\r\n//   Alex Denissov, Hiroyuki Hori (MMXAsm expert)\r\n// Documentation:\r\n//   Markus Spoettl and toolsfactory GbR (http://www.doc-o-matic.com/, sponsoring Soft Gems development\r\n//   with a free copy of the Doc-O-Matic help authoring system), Sven H. (Step by step tutorial)\r\n// CLX:\r\n//   Dmitri Dmitrienko (initial developer)\r\n// Source repository:\r\n//   https://code.google.com/p/virtual-treeview/source/\r\n// Accessability implementation:\r\n//   Marco Zehe (with help from Sebastian Modersohn)\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\ninterface\r\n\r\n{$if CompilerVersion < 24}{$MESSAGE FATAL 'This version supports only RAD Studio XE3 and higher. Please use V5 from  http://www.jam-software.com/virtual-treeview/VirtualTreeViewV5.5.3.zip  or  https://github.com/Virtual-TreeView/Virtual-TreeView/archive/V5_stable.zip'}{$ifend}\r\n\r\n{$booleval off} // Use fastest possible boolean evaluation\r\n\r\n// For some things to work we need code, which is classified as being unsafe for .NET.\r\n{$WARN UNSAFE_TYPE OFF}\r\n{$WARN UNSAFE_CAST OFF}\r\n{$WARN UNSAFE_CODE OFF}\r\n\r\n{$LEGACYIFEND ON}\r\n{$WARN UNSUPPORTED_CONSTRUCT      OFF}\r\n\r\n{$HPPEMIT '#include '}\r\n{$HPPEMIT '#include '}\r\n{$HPPEMIT '#include '}\r\n{$HPPEMIT '#include '}\r\n{$ifdef BCB}\r\n  {$HPPEMIT '#pragma link \"VirtualTreesCR.lib\"'}\r\n{$else}\r\n  {$HPPEMIT '#pragma link \"VirtualTreesR.lib\"'}\r\n{$endif}\r\n\r\nuses\r\n  Winapi.Windows, Winapi.oleacc, Winapi.Messages, System.SysUtils, Vcl.Graphics,\r\n  Vcl.Controls, Vcl.Forms, Vcl.ImgList, Winapi.ActiveX, Vcl.StdCtrls, System.Classes,\r\n  Vcl.Menus, Vcl.Printers, System.Types, Winapi.CommCtrl, Vcl.Themes, Winapi.UxTheme,\r\n  Winapi.ShlObj, System.UITypes, System.Generics.Collections;\r\n\r\nconst\r\n  VTVersion = '6.2.1';\r\n\r\nconst\r\n  VTTreeStreamVersion = 2;\r\n  VTHeaderStreamVersion = 6;    // The header needs an own stream version to indicate changes only relevant to the header.\r\n\r\n  CacheThreshold = 2000;        // Number of nodes a tree must at least have to start caching and at the same\r\n                                // time the maximum number of nodes between two cache entries.\r\n  FadeAnimationStepCount = 255; // Number of animation steps for hint fading (0..255).\r\n  ShadowSize = 5;               // Size in pixels of the hint shadow. This value has no influence on Win2K and XP systems\r\n                                // as those OSes have native shadow support.\r\n\r\n  // Special identifiers for columns.\r\n  NoColumn = -1;\r\n  InvalidColumn = -2;\r\n\r\n  // Indices for check state images used for checking.\r\n  ckEmpty                  =  0;  // an empty image used as place holder\r\n  // radio buttons\r\n  ckRadioUncheckedNormal   =  1;\r\n  ckRadioUncheckedHot      =  2;\r\n  ckRadioUncheckedPressed  =  3;\r\n  ckRadioUncheckedDisabled =  4;\r\n  ckRadioCheckedNormal     =  5;\r\n  ckRadioCheckedHot        =  6;\r\n  ckRadioCheckedPressed    =  7;\r\n  ckRadioCheckedDisabled   =  8;\r\n  // check boxes\r\n  ckCheckUncheckedNormal   =  9;\r\n  ckCheckUncheckedHot      = 10;\r\n  ckCheckUncheckedPressed  = 11;\r\n  ckCheckUncheckedDisabled = 12;\r\n  ckCheckCheckedNormal     = 13;\r\n  ckCheckCheckedHot        = 14;\r\n  ckCheckCheckedPressed    = 15;\r\n  ckCheckCheckedDisabled   = 16;\r\n  ckCheckMixedNormal       = 17;\r\n  ckCheckMixedHot          = 18;\r\n  ckCheckMixedPressed      = 19;\r\n  ckCheckMixedDisabled     = 20;\r\n  // simple button\r\n  ckButtonNormal           = 21;\r\n  ckButtonHot              = 22;\r\n  ckButtonPressed          = 23;\r\n  ckButtonDisabled         = 24;\r\n\r\n  // Instead using a TTimer class for each of the various events I use Windows timers with messages\r\n  // as this is more economical.\r\n  ExpandTimer = 1;\r\n  EditTimer = 2;\r\n  HeaderTimer = 3;\r\n  ScrollTimer = 4;\r\n  ChangeTimer = 5;\r\n  StructureChangeTimer = 6;\r\n  SearchTimer = 7;\r\n  ThemeChangedTimer = 8;\r\n\r\n  ThemeChangedTimerDelay = 500;\r\n\r\n  // Need to use this message to release the edit link interface asynchronously.\r\n  WM_CHANGESTATE = WM_APP + 32;\r\n\r\n  // Virtual Treeview does not need to be subclassed by an eventual Theme Manager instance as it handles\r\n  // Windows XP theme painting itself. Hence the special message is used to prevent subclassing.\r\n  CM_DENYSUBCLASSING = CM_BASE + 2000;\r\n\r\n  // Decoupling message for auto-adjusting the internal edit window.\r\n  CM_AUTOADJUST = CM_BASE + 2005;\r\n\r\n\r\n\r\n  // VT's own clipboard formats,\r\n  // Note: The reference format is used internally to allow to link to a tree reference\r\n  //       to implement optimized moves and other back references.\r\n  CFSTR_VIRTUALTREE = 'Virtual Tree Data';\r\n  CFSTR_VTREFERENCE = 'Virtual Tree Reference';\r\n  CFSTR_HTML = 'HTML Format';\r\n  CFSTR_RTF = 'Rich Text Format';\r\n  CFSTR_RTFNOOBJS = 'Rich Text Format Without Objects';\r\n  CFSTR_CSV = 'CSV';\r\n\r\n  // Drag image helpers for Windows 2000 and up.\r\n  IID_IDropTargetHelper: TGUID = (D1: $4657278B; D2: $411B; D3: $11D2; D4: ($83, $9A, $00, $C0, $4F, $D9, $18, $D0));\r\n  IID_IDragSourceHelper: TGUID = (D1: $DE5BF786; D2: $477A; D3: $11D2; D4: ($83, $9D, $00, $C0, $4F, $D9, $18, $D0));\r\n  IID_IDropTarget: TGUID = (D1: $00000122; D2: $0000; D3: $0000; D4: ($C0, $00, $00, $00, $00, $00, $00, $46));\r\n\r\n  // Help identifiers for exceptions. Application developers are responsible to link them with actual help topics.\r\n  hcTFEditLinkIsNil      = 2000;\r\n  hcTFWrongMoveError     = 2001;\r\n  hcTFWrongStreamFormat  = 2002;\r\n  hcTFWrongStreamVersion = 2003;\r\n  hcTFStreamTooSmall     = 2004;\r\n  hcTFCorruptStream1     = 2005;\r\n  hcTFCorruptStream2     = 2006;\r\n  hcTFClipboardFailed    = 2007;\r\n  hcTFCannotSetUserData  = 2008;\r\n\r\n  // Header standard split cursor.\r\n  crHeaderSplit = TCursor(63);\r\n\r\n  // Height changing cursor.\r\n  crVertSplit = TCursor(62);\r\n\r\n  UtilityImageSize = 16; // Needed by descendants for hittests.\r\n\r\nvar // Clipboard format IDs used in OLE drag'n drop and clipboard transfers.\r\n  CF_VIRTUALTREE,\r\n  CF_VTREFERENCE,\r\n  CF_VRTF,\r\n  CF_VRTFNOOBJS,   // Unfortunately CF_RTF* is already defined as being\r\n                   // registration strings so I have to use different identifiers.\r\n  CF_HTML,\r\n  CF_CSV: Word;\r\n\r\n  MMXAvailable: Boolean; // necessary to know because the blend code uses MMX instructions\r\n  IsWinVistaOrAbove: Boolean;\r\n\r\n  {$MinEnumSize 1, make enumerations as small as possible}\r\n\r\ntype\r\n  // The exception used by the trees.\r\n  EVirtualTreeError = class(Exception);\r\n\r\n  PCardinal = ^Cardinal;\r\n\r\n  // Limits the speed interval which can be used for auto scrolling (milliseconds).\r\n  TAutoScrollInterval = 1..1000;\r\n\r\n  // Be careful when adding new states as this might change the size of the type which in turn\r\n  // changes the alignment in the node record as well as the stream chunks.\r\n  // Do not reorder the states and always add new states at the end of this enumeration in order to avoid\r\n  // breaking existing code.\r\n  TVirtualNodeState = (\r\n    vsInitialized,       // Set after the node has been initialized.\r\n    vsChecking,          // Node's check state is changing, avoid propagation.\r\n    vsCutOrCopy,         // Node is selected as cut or copy and paste source.\r\n    vsDisabled,          // Set if node is disabled.\r\n    vsDeleting,          // Set when the node is about to be freed.\r\n    vsExpanded,          // Set if the node is expanded.\r\n    vsHasChildren,       // Indicates the presence of child nodes without actually setting them.\r\n    vsVisible,           // Indicate whether the node is visible or not (independant of the expand states of its parents).\r\n    vsSelected,          // Set if the node is in the current selection.\r\n    vsOnFreeNodeCallRequired,   // Set if user data has been set which requires OnFreeNode.\r\n    vsAllChildrenHidden, // Set if vsHasChildren is set and no child node has the vsVisible flag set.\r\n    vsReleaseCallOnUserDataRequired, // Indicates that the user data is a reference to an interface which should be released.\r\n    vsMultiline,         // Node text is wrapped at the cell boundaries instead of being shorted.\r\n    vsHeightMeasured,    // Node height has been determined and does not need a recalculation.\r\n    vsToggling,          // Set when a node is expanded/collapsed to prevent recursive calls.\r\n    vsFiltered,          // Indicates that the node should not be painted (without effecting its children).\r\n    vsInitializing       // Set when the node is being initialized\r\n  );\r\n  TVirtualNodeStates = set of TVirtualNodeState;\r\n\r\n  // States used in InitNode to indicate states a node shall initially have.\r\n  TVirtualNodeInitState = (\r\n    ivsDisabled,\r\n    ivsExpanded,\r\n    ivsHasChildren,\r\n    ivsMultiline,\r\n    ivsSelected,\r\n    ivsFiltered,\r\n    ivsReInit\r\n  );\r\n  TVirtualNodeInitStates = set of TVirtualNodeInitState;\r\n\r\n  TScrollBarStyle = (\r\n    sbmRegular,\r\n    sbm3D\r\n  );\r\n\r\n  // Options per column.\r\n  TVTColumnOption = (\r\n    coAllowClick,            // Column can be clicked (must be enabled too).\r\n    coDraggable,             // Column can be dragged.\r\n    coEnabled,               // Column is enabled.\r\n    coParentBidiMode,        // Column uses the parent's bidi mode.\r\n    coParentColor,           // Column uses the parent's background color.\r\n    coResizable,             // Column can be resized.\r\n    coShowDropMark,          // Column shows the drop mark if it is currently the drop target.\r\n    coVisible,               // Column is shown.\r\n    coAutoSpring,            // Column takes part in the auto spring feature of the header (must be resizable too).\r\n    coFixed,                 // Column is fixed and can not be selected or scrolled etc.\r\n    coSmartResize,           // Column is resized to its largest entry which is in view (instead of its largest\r\n                             // visible entry).\r\n    coAllowFocus,            // Column can be focused.\r\n    coDisableAnimatedResize, // Column resizing is not animated.\r\n    coWrapCaption,           // Caption could be wrapped across several header lines to fit columns width.\r\n    coUseCaptionAlignment,   // Column's caption has its own aligment.\r\n    coEditable               // Column can be edited\r\n  );\r\n  TVTColumnOptions = set of TVTColumnOption;\r\n\r\n  // These flags are used to indicate where a click in the header happened.\r\n  TVTHeaderHitPosition = (\r\n    hhiNoWhere,         // No column is involved (possible only if the tree is smaller than the client area).\r\n    hhiOnColumn,        // On a column.\r\n    hhiOnIcon,          // On the bitmap associated with a column.\r\n    hhiOnCheckbox       // On the checkbox if enabled.\r\n  );\r\n  TVTHeaderHitPositions = set of TVTHeaderHitPosition;\r\n\r\n  // These flags are returned by the hit test method.\r\n  THitPosition = (\r\n    hiAbove,             // above the client area (if relative) or the absolute tree area\r\n    hiBelow,             // below the client area (if relative) or the absolute tree area\r\n    hiNowhere,           // no node is involved (possible only if the tree is not as tall as the client area)\r\n    hiOnItem,            // on the bitmaps/buttons or label associated with an item\r\n    hiOnItemButton,      // on the button associated with an item\r\n    hiOnItemButtonExact, // exactly on the button associated with an item\r\n    hiOnItemCheckbox,    // on the checkbox if enabled\r\n    hiOnItemIndent,      // in the indentation area in front of a node\r\n    hiOnItemLabel,       // on the normal text area associated with an item\r\n    hiOnItemLeft,        // in the area to the left of a node's text area (e.g. when right aligned or centered)\r\n    hiOnItemRight,       // in the area to the right of a node's text area (e.g. if left aligned or centered)\r\n    hiOnNormalIcon,      // on the \"normal\" image\r\n    hiOnStateIcon,       // on the state image\r\n    hiToLeft,            // to the left of the client area (if relative) or the absolute tree area\r\n    hiToRight,           // to the right of the client area (if relative) or the absolute tree area\r\n    hiUpperSplitter,     // in the upper splitter area of a node\r\n    hiLowerSplitter      // in the lower splitter area of a node\r\n  );\r\n  THitPositions = set of THitPosition;\r\n\r\n  TCheckType = (\r\n    ctNone,\r\n    ctTriStateCheckBox,\r\n    ctCheckBox,\r\n    ctRadioButton,\r\n    ctButton\r\n  );\r\n\r\n  // The check states include both, transient and fluent (temporary) states. The only temporary state defined so\r\n  // far is the pressed state.\r\n  TCheckState = (\r\n    csUncheckedNormal,  // unchecked and not pressed\r\n    csUncheckedPressed, // unchecked and pressed\r\n    csCheckedNormal,    // checked and not pressed\r\n    csCheckedPressed,   // checked and pressed\r\n    csMixedNormal,      // 3-state check box and not pressed\r\n    csMixedPressed      // 3-state check box and pressed\r\n  );\r\n\r\n  TCheckImageKind = (\r\n    ckLightCheck,     // gray cross\r\n    ckDarkCheck,      // black cross\r\n    ckLightTick,      // gray tick mark\r\n    ckDarkTick,       // black tick mark\r\n    ckFlat,           // flat images (no 3D border)\r\n    ckXP,             // Windows XP style\r\n    ckCustom,         // application defined check images\r\n    ckSystemFlat,     // Flat system defined check images.\r\n    ckSystemDefault   // Uses the system check images, theme aware.\r\n  );\r\n\r\n  // mode to describe a move action\r\n  TVTNodeAttachMode = (\r\n    amNoWhere,        // just for simplified tests, means to ignore the Add/Insert command\r\n    amInsertBefore,   // insert node just before destination (as sibling of destination)\r\n    amInsertAfter,    // insert node just after destionation (as sibling of destination)\r\n    amAddChildFirst,  // add node as first child of destination\r\n    amAddChildLast    // add node as last child of destination\r\n  );\r\n\r\n  // modes to determine drop position further\r\n  TDropMode = (\r\n    dmNowhere,\r\n    dmAbove,\r\n    dmOnNode,\r\n    dmBelow\r\n  );\r\n\r\n  // operations basically allowed during drag'n drop\r\n  TDragOperation = (\r\n    doCopy,\r\n    doMove,\r\n    doLink\r\n  );\r\n  TDragOperations = set of TDragOperation;\r\n\r\n  TVTImageKind = (\r\n    ikNormal,\r\n    ikSelected,\r\n    ikState,\r\n    ikOverlay\r\n  );\r\n\r\n  TVTHintMode = (\r\n    hmDefault,            // show the hint of the control\r\n    hmHint,               // show node specific hint string returned by the application\r\n    hmHintAndDefault,     // same as hmHint but show the control's hint if no node is concerned\r\n    hmTooltip             // show the text of the node if it isn't already fully shown\r\n  );\r\n\r\n  // Indicates how to format a tooltip.\r\n  TVTTooltipLineBreakStyle = (\r\n    hlbDefault,           // Use multi-line style of the node.\r\n    hlbForceSingleLine,   // Use single line hint.\r\n    hlbForceMultiLine     // Use multi line hint.\r\n  );\r\n\r\n  TMouseButtons = set of TMouseButton;\r\n\r\n  // Used to describe the action to do when using the OnBeforeItemErase event.\r\n  TItemEraseAction = (\r\n    eaColor,   // Use the provided color to erase the background instead the one of the tree.\r\n    eaDefault, // The tree should erase the item's background (bitmap or solid).\r\n    eaNone     // Do nothing. Let the application paint the background.\r\n  );\r\n\r\n\r\n  // There is a heap of switchable behavior in the tree. Since published properties may never exceed 4 bytes,\r\n  // which limits sets to at most 32 members, and because for better overview tree options are splitted\r\n  // in various sub-options and are held in a commom options class.\r\n  //\r\n  // Options to customize tree appearance:\r\n  TVTPaintOption = (\r\n    toHideFocusRect,           // Avoid drawing the dotted rectangle around the currently focused node.\r\n    toHideSelection,           // Selected nodes are drawn as unselected nodes if the tree is unfocused.\r\n    toHotTrack,                // Track which node is under the mouse cursor.\r\n    toPopupMode,               // Paint tree as would it always have the focus (useful for tree combo boxes etc.)\r\n    toShowBackground,          // Use the background image if there's one.\r\n    toShowButtons,             // Display collapse/expand buttons left to a node.\r\n    toShowDropmark,            // Show the dropmark during drag'n drop operations.\r\n    toShowHorzGridLines,       // Display horizontal lines to simulate a grid.\r\n    toShowRoot,                // Show lines also at top level (does not show the hidden/internal root node).\r\n    toShowTreeLines,           // Display tree lines to show hierarchy of nodes.\r\n    toShowVertGridLines,       // Display vertical lines (depending on columns) to simulate a grid.\r\n    toThemeAware,              // Draw UI elements (header, tree buttons etc.) according to the current theme if\r\n                               // enabled (Windows XP+ only, application must be themed).\r\n    toUseBlendedImages,        // Enable alpha blending for ghosted nodes or those which are being cut/copied.\r\n    toGhostedIfUnfocused,      // Ghosted images are still shown as ghosted if unfocused (otherwise the become non-ghosted\r\n                               // images).\r\n    toFullVertGridLines,       // Display vertical lines over the full client area, not only the space occupied by nodes.\r\n                               // This option only has an effect if toShowVertGridLines is enabled too.\r\n    toAlwaysHideSelection,     // Do not draw node selection, regardless of focused state.\r\n    toUseBlendedSelection,     // Enable alpha blending for node selections.\r\n    toStaticBackground,        // Show simple static background instead of a tiled one.\r\n    toChildrenAbove,           // Display child nodes above their parent.\r\n    toFixedIndent,             // Draw the tree with a fixed indent.\r\n    toUseExplorerTheme,        // Use the explorer theme if run under Windows Vista (or above).\r\n    toHideTreeLinesIfThemed,   // Do not show tree lines if theming is used.\r\n    toShowFilteredNodes        // Draw nodes even if they are filtered out.\r\n  );\r\n  TVTPaintOptions = set of TVTPaintOption;\r\n\r\n  // Options to toggle animation support:\r\n  TVTAnimationOption = (\r\n    toAnimatedToggle,          // Expanding and collapsing a node is animated (quick window scroll).\r\n    toAdvancedAnimatedToggle   // Do some advanced animation effects when toggling a node.\r\n  );\r\n  TVTAnimationOptions = set of TVTAnimationOption;\r\n\r\n  // Options which toggle automatic handling of certain situations:\r\n  TVTAutoOption = (\r\n    toAutoDropExpand,           // Expand node if it is the drop target for more than a certain time.\r\n    toAutoExpand,               // Nodes are expanded (collapsed) when getting (losing) the focus.\r\n    toAutoScroll,               // Scroll if mouse is near the border while dragging or selecting.\r\n    toAutoScrollOnExpand,       // Scroll as many child nodes in view as possible after expanding a node.\r\n    toAutoSort,                 // Sort tree when Header.SortColumn or Header.SortDirection change or sort node if\r\n                                // child nodes are added.\r\n    toAutoSpanColumns,          // Large entries continue into next column(s) if there's no text in them (no clipping).\r\n    toAutoTristateTracking,     // Checkstates are automatically propagated for tri state check boxes.\r\n    toAutoHideButtons,          // Node buttons are hidden when there are child nodes, but all are invisible.\r\n    toAutoDeleteMovedNodes,     // Delete nodes which where moved in a drag operation (if not directed otherwise).\r\n    toDisableAutoscrollOnFocus, // Disable scrolling a node or column into view if it gets focused.\r\n    toAutoChangeScale,          // Change default node height automatically if the system's font scale is set to big fonts.\r\n    toAutoFreeOnCollapse,       // Frees any child node after a node has been collapsed (HasChildren flag stays there).\r\n    toDisableAutoscrollOnEdit,  // Do not center a node horizontally when it is edited.\r\n    toAutoBidiColumnOrdering    // When set then columns (if any exist) will be reordered from lowest index to highest index\r\n                                // and vice versa when the tree's bidi mode is changed.\r\n  );\r\n  TVTAutoOptions = set of TVTAutoOption;\r\n\r\n  // Options which determine the tree's behavior when selecting nodes:\r\n  TVTSelectionOption = (\r\n    toDisableDrawSelection,    // Prevent user from selecting with the selection rectangle in multiselect mode.\r\n    toExtendedFocus,           // Entries other than in the main column can be selected, edited etc.\r\n    toFullRowSelect,           // Hit test as well as selection highlight are not constrained to the text of a node.\r\n    toLevelSelectConstraint,   // Constrain selection to the same level as the selection anchor.\r\n    toMiddleClickSelect,       // Allow selection, dragging etc. with the middle mouse button. This and toWheelPanning\r\n                               // are mutual exclusive.\r\n    toMultiSelect,             // Allow more than one node to be selected.\r\n    toRightClickSelect,        // Allow selection, dragging etc. with the right mouse button.\r\n    toSiblingSelectConstraint, // Constrain selection to nodes with same parent.\r\n    toCenterScrollIntoView,    // Center nodes vertically in the client area when scrolling into view.\r\n    toSimpleDrawSelection,     // Simplifies draw selection, so a node's caption does not need to intersect with the\r\n                               // selection rectangle.\r\n    toAlwaysSelectNode,        // If this flag is set to true, the tree view tries to always have a node selected.\r\n                               // This behavior is closer to the Windows TreeView and useful in Windows Explorer style applications.\r\n    toRestoreSelection         // Set to true if upon refill the previously selected nodes should be selected again.\r\n                               // The nodes will be identified by its caption only.\r\n  );\r\n  TVTSelectionOptions = set of TVTSelectionOption;\r\n\r\n  // Options which do not fit into any of the other groups:\r\n  TVTMiscOption = (\r\n    toAcceptOLEDrop,            // Register tree as OLE accepting drop target\r\n    toCheckSupport,             // Show checkboxes/radio buttons.\r\n    toEditable,                 // Node captions can be edited.\r\n    toFullRepaintOnResize,      // Fully invalidate the tree when its window is resized (CS_HREDRAW/CS_VREDRAW).\r\n    toGridExtensions,           // Use some special enhancements to simulate and support grid behavior.\r\n    toInitOnSave,               // Initialize nodes when saving a tree to a stream.\r\n    toReportMode,               // Tree behaves like TListView in report mode.\r\n    toToggleOnDblClick,         // Toggle node expansion state when it is double clicked.\r\n    toWheelPanning,             // Support for mouse panning (wheel mice only). This option and toMiddleClickSelect are\r\n                                // mutal exclusive, where panning has precedence.\r\n    toReadOnly,                 // The tree does not allow to be modified in any way. No action is executed and\r\n                                // node editing is not possible.\r\n    toVariableNodeHeight,       // When set then GetNodeHeight will trigger OnMeasureItem to allow variable node heights.\r\n    toFullRowDrag,              // Start node dragging by clicking anywhere in it instead only on the caption or image.\r\n                                // Must be used together with toDisableDrawSelection.\r\n    toNodeHeightResize,         // Allows changing a node's height via mouse.\r\n    toNodeHeightDblClickResize, // Allows to reset a node's height to FDefaultNodeHeight via a double click.\r\n    toEditOnClick,              // Editing mode can be entered with a single click\r\n    toEditOnDblClick,           // Editing mode can be entered with a double click\r\n    toReverseFullExpandHotKey   // Used to define Ctrl+'+' instead of Ctrl+Shift+'+' for full expand (and similar for collapsing)\r\n  );\r\n  TVTMiscOptions = set of TVTMiscOption;\r\n\r\n  // Options to control data export\r\n  TVTExportMode = (\r\n    emAll,        // export all records (regardless checked state)\r\n    emChecked,    // export checked records only\r\n    emUnchecked,   // export unchecked records only\r\n    emVisibleDueToExpansion, //Do not export nodes that are not visible because their parent is not expanded\r\n    emSelected // export selected nodes only\r\n  );\r\n\r\n  // Kinds of operations\r\n  TVTOperationKind = (\r\n    okAutoFitColumns,\r\n    okGetMaxColumnWidth,\r\n    okSortNode,\r\n    okSortTree,\r\n    okExport,\r\n    okExpand\r\n  );\r\n  TVTOperationKinds = set of TVTOperationKind;\r\n\r\nconst\r\n  DefaultPaintOptions = [toShowButtons, toShowDropmark, toShowTreeLines, toShowRoot, toThemeAware, toUseBlendedImages];\r\n  DefaultAnimationOptions = [];\r\n  DefaultAutoOptions = [toAutoDropExpand, toAutoTristateTracking, toAutoScrollOnExpand, toAutoDeleteMovedNodes, toAutoChangeScale, toAutoSort];\r\n  DefaultSelectionOptions = [];\r\n  DefaultMiscOptions = [toAcceptOLEDrop, toFullRepaintOnResize, toInitOnSave, toToggleOnDblClick, toWheelPanning,\r\n    toEditOnClick];\r\n  DefaultColumnOptions = [coAllowClick, coDraggable, coEnabled, coParentColor, coParentBidiMode, coResizable,\r\n    coShowDropmark, coVisible, coAllowFocus, coEditable];\r\n\r\ntype\r\n  TBaseVirtualTree = class;\r\n  TVirtualTreeClass = class of TBaseVirtualTree;\r\n\r\n  PVirtualNode = ^TVirtualNode;\r\n\r\n  TColumnIndex = type Integer;\r\n  TColumnPosition = type Cardinal;\r\n\r\n  // This record must already be defined here and not later because otherwise BCB users will not be able\r\n  // to compile (conversion done by BCB is wrong).\r\n  TCacheEntry = record\r\n    Node: PVirtualNode;\r\n    AbsoluteTop: Cardinal;\r\n  end;\r\n\r\n  TCache = array of TCacheEntry;\r\n  TNodeArray = array of PVirtualNode;\r\n\r\n  TCustomVirtualTreeOptions = class(TPersistent)\r\n  private\r\n    FOwner: TBaseVirtualTree;\r\n    FPaintOptions: TVTPaintOptions;\r\n    FAnimationOptions: TVTAnimationOptions;\r\n    FAutoOptions: TVTAutoOptions;\r\n    FSelectionOptions: TVTSelectionOptions;\r\n    FMiscOptions: TVTMiscOptions;\r\n    FExportMode: TVTExportMode;\r\n    procedure SetAnimationOptions(const Value: TVTAnimationOptions);\r\n    procedure SetAutoOptions(const Value: TVTAutoOptions);\r\n    procedure SetMiscOptions(const Value: TVTMiscOptions);\r\n    procedure SetPaintOptions(const Value: TVTPaintOptions);\r\n    procedure SetSelectionOptions(const Value: TVTSelectionOptions);\r\n  protected\r\n  public\r\n    constructor Create(AOwner: TBaseVirtualTree); virtual;\r\n    procedure AssignTo(Dest: TPersistent); override;\r\n    property AnimationOptions: TVTAnimationOptions read FAnimationOptions write SetAnimationOptions  default DefaultAnimationOptions;\r\n    property AutoOptions: TVTAutoOptions read FAutoOptions write SetAutoOptions default DefaultAutoOptions;\r\n    property ExportMode: TVTExportMode read FExportMode write FExportMode default emAll;\r\n    property MiscOptions: TVTMiscOptions read FMiscOptions write SetMiscOptions default DefaultMiscOptions;\r\n    property PaintOptions: TVTPaintOptions read FPaintOptions write SetPaintOptions default DefaultPaintOptions;\r\n    property SelectionOptions: TVTSelectionOptions read FSelectionOptions write SetSelectionOptions  default DefaultSelectionOptions;\r\n\r\n    property Owner: TBaseVirtualTree read FOwner;\r\n  end;\r\n\r\n  TTreeOptionsClass = class of TCustomVirtualTreeOptions;\r\n\r\n  TVirtualTreeOptions = class(TCustomVirtualTreeOptions)\r\n  published\r\n    property AnimationOptions;\r\n    property AutoOptions;\r\n    property ExportMode;\r\n    property MiscOptions;\r\n    property PaintOptions;\r\n    property SelectionOptions;\r\n  end;\r\n\r\n  // Used in the CF_VTREFERENCE clipboard format.\r\n  PVTReference = ^TVTReference;\r\n  TVTReference = record\r\n    Process: Cardinal;\r\n    Tree: TBaseVirtualTree;\r\n  end;\r\n\r\n  TVirtualNode = packed record\r\n    Index,                   // index of node with regard to its parent\r\n    ChildCount: Cardinal;    // number of child nodes\r\n    NodeHeight: Word;        // height in pixels\r\n    States: TVirtualNodeStates; // states describing various properties of the node (expanded, initialized etc.)\r\n    Align: Byte;             // line/button alignment\r\n    CheckState: TCheckState; // indicates the current check state (e.g. checked, pressed etc.)\r\n    CheckType: TCheckType;   // indicates which check type shall be used for this node\r\n    Dummy: Byte;             // dummy value to fill DWORD boundary\r\n    TotalCount,              // sum of this node, all of its child nodes and their child nodes etc.\r\n    TotalHeight: Cardinal;   // height in pixels this node covers on screen including the height of all of its\r\n                             // children\r\n    // Note: Some copy routines require that all pointers (as well as the data area) in a node are\r\n    //       located at the end of the node! Hence if you want to add new member fields (except pointers to internal\r\n    //       data) then put them before field Parent.\r\n    Parent,                  // reference to the node's parent (for the root this contains the treeview)\r\n    PrevSibling,             // link to the node's previous sibling or nil if it is the first node\r\n    NextSibling,             // link to the node's next sibling or nil if it is the last node\r\n    FirstChild,              // link to the node's first child...\r\n    LastChild: PVirtualNode; // link to the node's last child...\r\n  private\r\n    Data: record end;        // this is a placeholder, each node gets extra data determined by NodeDataSize\r\n  public\r\n    function IsAssigned(): Boolean; inline;\r\n    function GetData(): Pointer; overload; inline;\r\n    function GetData(): T; overload; inline;\r\n    procedure SetData(pUserData: Pointer); overload;\r\n    procedure SetData(pUserData: T); overload;\r\n    procedure SetData(const pUserData: IInterface); overload;\r\n  end;\r\n\r\n\r\n  // Structure used when info about a certain position in the header is needed.\r\n  TVTHeaderHitInfo = record\r\n    X,\r\n    Y: Integer;\r\n    Button: TMouseButton;\r\n    Shift: TShiftState;\r\n    Column: TColumnIndex;\r\n    HitPosition: TVTHeaderHitPositions;\r\n  end;\r\n\r\n  // Structure used when info about a certain position in the tree is needed.\r\n  THitInfo = record\r\n    HitNode: PVirtualNode;\r\n    HitPositions: THitPositions;\r\n    HitColumn: TColumnIndex;\r\n    HitPoint: TPoint;\r\n  end;\r\n\r\n  // auto scroll directions\r\n  TScrollDirections = set of (\r\n    sdLeft,\r\n    sdUp,\r\n    sdRight,\r\n    sdDown\r\n  );\r\n\r\n  // OLE drag'n drop support\r\n  TFormatEtcArray = array of TFormatEtc;\r\n  TFormatArray = array of Word;\r\n\r\n  // IDataObject.SetData support\r\n  TInternalStgMedium = packed record\r\n    Format: TClipFormat;\r\n    Medium: TStgMedium;\r\n  end;\r\n  TInternalStgMediumArray = array of TInternalStgMedium;\r\n\r\n  TEnumFormatEtc = class(TInterfacedObject, IEnumFormatEtc)\r\n  private\r\n    FTree: TBaseVirtualTree;\r\n    FFormatEtcArray: TFormatEtcArray;\r\n    FCurrentIndex: Integer;\r\n  public\r\n    constructor Create(Tree: TBaseVirtualTree; const AFormatEtcArray: TFormatEtcArray);\r\n\r\n    function Clone(out Enum: IEnumFormatEtc): HResult; stdcall;\r\n    function Next(celt: Integer; out elt; pceltFetched: PLongint): HResult; stdcall;\r\n    function Reset: HResult; stdcall;\r\n    function Skip(celt: Integer): HResult; stdcall;\r\n  end;\r\n\r\n  // ----- OLE drag'n drop handling\r\n\r\n  IVTDragManager = interface(IUnknown)\r\n    ['{C4B25559-14DA-446B-8901-0C879000EB16}']\r\n    procedure ForceDragLeave; stdcall;\r\n    function GetDataObject: IDataObject; stdcall;\r\n    function GetDragSource: TBaseVirtualTree; stdcall;\r\n    function GetDropTargetHelperSupported: Boolean; stdcall;\r\n    function GetIsDropTarget: Boolean; stdcall;\r\n\r\n    property DataObject: IDataObject read GetDataObject;\r\n    property DragSource: TBaseVirtualTree read GetDragSource;\r\n    property DropTargetHelperSupported: Boolean read GetDropTargetHelperSupported;\r\n    property IsDropTarget: Boolean read GetIsDropTarget;\r\n  end;\r\n\r\n  // This data object is used in two different places. One is for clipboard operations and the other while dragging.\r\n  TVTDataObject = class(TInterfacedObject, IDataObject)\r\n  private\r\n    FOwner: TBaseVirtualTree;          // The tree which provides clipboard or drag data.\r\n    FForClipboard: Boolean;            // Determines which data to render with GetData.\r\n    FFormatEtcArray: TFormatEtcArray;\r\n    FInternalStgMediumArray: TInternalStgMediumArray;  // The available formats in the DataObject\r\n    FAdviseHolder: IDataAdviseHolder;  // Reference to an OLE supplied implementation for advising.\r\n  protected\r\n    function CanonicalIUnknown(const TestUnknown: IUnknown): IUnknown;\r\n    function EqualFormatEtc(FormatEtc1, FormatEtc2: TFormatEtc): Boolean;\r\n    function FindFormatEtc(TestFormatEtc: TFormatEtc; const FormatEtcArray: TFormatEtcArray): integer;\r\n    function FindInternalStgMedium(Format: TClipFormat): PStgMedium;\r\n    function HGlobalClone(HGlobal: THandle): THandle;\r\n    function RenderInternalOLEData(const FormatEtcIn: TFormatEtc; var Medium: TStgMedium; var OLEResult: HResult): Boolean;\r\n    function StgMediumIncRef(const InStgMedium: TStgMedium; var OutStgMedium: TStgMedium;\r\n      CopyInMedium: Boolean; const DataObject: IDataObject): HRESULT;\r\n\r\n    property ForClipboard: Boolean read FForClipboard;\r\n    property FormatEtcArray: TFormatEtcArray read FFormatEtcArray write FFormatEtcArray;\r\n    property InternalStgMediumArray: TInternalStgMediumArray read FInternalStgMediumArray write FInternalStgMediumArray;\r\n    property Owner: TBaseVirtualTree read FOwner;\r\n  public\r\n    constructor Create(AOwner: TBaseVirtualTree; ForClipboard: Boolean); virtual;\r\n    destructor Destroy; override;\r\n\r\n    function DAdvise(const FormatEtc: TFormatEtc; advf: Integer; const advSink: IAdviseSink; out dwConnection: Integer):\r\n      HResult; virtual; stdcall;\r\n    function DUnadvise(dwConnection: Integer): HResult; virtual; stdcall;\r\n    function EnumDAdvise(out enumAdvise: IEnumStatData): HResult; virtual; stdcall;\r\n    function EnumFormatEtc(Direction: Integer; out EnumFormatEtc: IEnumFormatEtc): HResult; virtual; stdcall;\r\n    function GetCanonicalFormatEtc(const FormatEtc: TFormatEtc; out FormatEtcOut: TFormatEtc): HResult; virtual; stdcall;\r\n    function GetData(const FormatEtcIn: TFormatEtc; out Medium: TStgMedium): HResult; virtual; stdcall;\r\n    function GetDataHere(const FormatEtc: TFormatEtc; out Medium: TStgMedium): HResult; virtual; stdcall;\r\n    function QueryGetData(const FormatEtc: TFormatEtc): HResult; virtual; stdcall;\r\n    function SetData(const FormatEtc: TFormatEtc; var Medium: TStgMedium; DoRelease: BOOL): HResult; virtual; stdcall;\r\n  end;\r\n\r\n  // TVTDragManager is a class to manage drag and drop in a Virtual Treeview.\r\n  TVTDragManager = class(TInterfacedObject, IVTDragManager, IDropSource, IDropTarget)\r\n  private\r\n    FOwner,                            // The tree which is responsible for drag management.\r\n    FDragSource: TBaseVirtualTree;     // Reference to the source tree if the source was a VT, might be different than\r\n                                       // the owner tree.\r\n    FIsDropTarget: Boolean;            // True if the owner is currently the drop target.\r\n    FDataObject: IDataObject;          // A reference to the data object passed in by DragEnter (only used when the owner\r\n                                       // tree is the current drop target).\r\n    FDropTargetHelper: IDropTargetHelper; // Win2k > Drag image support\r\n    FFullDragging: BOOL;               // True, if full dragging is currently enabled in the system.\r\n\r\n    function GetDataObject: IDataObject; stdcall;\r\n    function GetDragSource: TBaseVirtualTree; stdcall;\r\n    function GetDropTargetHelperSupported: Boolean; stdcall;\r\n    function GetIsDropTarget: Boolean; stdcall;\r\n  public\r\n    constructor Create(AOwner: TBaseVirtualTree); virtual;\r\n    destructor Destroy; override;\r\n\r\n    function DragEnter(const DataObject: IDataObject; KeyState: Integer; Pt: TPoint;\r\n      var Effect: Longint): HResult; stdcall;\r\n    function DragLeave: HResult; stdcall;\r\n    function DragOver(KeyState: Integer; Pt: TPoint; var Effect: LongInt): HResult; stdcall;\r\n    function Drop(const DataObject: IDataObject; KeyState: Integer; Pt: TPoint; var Effect: Integer): HResult; stdcall;\r\n    procedure ForceDragLeave; stdcall;\r\n    function GiveFeedback(Effect: Integer): HResult; stdcall;\r\n    function QueryContinueDrag(EscapePressed: BOOL; KeyState: Integer): HResult; stdcall;\r\n  end;\r\n\r\n  PVTHintData = ^TVTHintData;\r\n  TVTHintData = record\r\n    Tree: TBaseVirtualTree;\r\n    Node: PVirtualNode;\r\n    Column: TColumnIndex;\r\n    HintRect: TRect;            // used for draw trees only, string trees get the size from the hint string\r\n    DefaultHint: string; // used only if there is no node specific hint string available\r\n                                // or a header hint is about to appear\r\n    HintText: string;    // set when size of the hint window is calculated\r\n    BidiMode: TBidiMode;\r\n    Alignment: TAlignment;\r\n    LineBreakStyle: TVTToolTipLineBreakStyle;\r\n  end;\r\n\r\n  // Determines the kind of animation when a hint is activated.\r\n  THintAnimationType = (\r\n    hatNone,                 // no animation at all, just display hint/tooltip\r\n    hatFade,                 // fade in the hint/tooltip, like in Windows 2000\r\n    hatSlide,                // slide in the hint/tooltip, like in Windows 98\r\n    hatSystemDefault         // use what the system is using (slide for Win9x, slide/fade for Win2K+, depends on settings)\r\n  );\r\n\r\n  // The trees need an own hint window class because of Unicode output and adjusted font.\r\n  TVirtualTreeHintWindow = class(THintWindow)\r\n  private\r\n    FHintData: TVTHintData;\r\n    FBackground,\r\n    FDrawBuffer,\r\n    FTarget: TBitmap;\r\n    FTextHeight: Integer;\r\n    function AnimationCallback(Step, StepSize: Integer; Data: Pointer): Boolean;\r\n    procedure CMTextChanged(var Message: TMessage); message CM_TEXTCHANGED;\r\n    function GetHintWindowDestroyed: Boolean;\r\n    procedure WMEraseBkgnd(var Message: TWMEraseBkgnd); message WM_ERASEBKGND;\r\n    procedure WMNCPaint(var Message: TMessage); message WM_NCPAINT;\r\n    procedure WMShowWindow(var Message: TWMShowWindow); message WM_SHOWWINDOW;\r\n  protected\r\n    procedure CreateParams(var Params: TCreateParams); override;\r\n    procedure InternalPaint(Step, StepSize: Integer);\r\n    procedure Paint; override;\r\n\r\n    property Background: TBitmap read FBackground;\r\n    property DrawBuffer: TBitmap read FDrawBuffer;\r\n    property HintData: TVTHintData read FHintData;\r\n    property HintWindowDestroyed: Boolean read GetHintWindowDestroyed;\r\n    property Target: TBitmap read FTarget;\r\n    property TextHeight: Integer read FTextHeight;\r\n  public\r\n    constructor Create(AOwner: TComponent); override;\r\n    destructor Destroy; override;\r\n\r\n    procedure ActivateHint(Rect: TRect; const AHint: string); override;\r\n    function CalcHintRect(MaxWidth: Integer; const AHint: string; AData: Pointer): TRect; override;\r\n    function IsHintMsg(var Msg: TMsg): Boolean; override;\r\n  end;\r\n\r\n  // Drag image support for the tree.\r\n  TVTTransparency = 0..255;\r\n  TVTBias = -128..127;\r\n\r\n  // Simple move limitation for the drag image.\r\n  TVTDragMoveRestriction = (\r\n    dmrNone,\r\n    dmrHorizontalOnly,\r\n    dmrVerticalOnly\r\n  );\r\n\r\n  TVTDragImageStates = set of (\r\n    disHidden,          // Internal drag image is currently hidden (always hidden if drag image helper interfaces are used).\r\n    disInDrag,          // Drag image class is currently being used.\r\n    disPrepared,        // Drag image class is prepared.\r\n    disSystemSupport    // Running on Windows 2000 or higher. System supports drag images natively.\r\n  );\r\n\r\n  // Class to manage header and tree drag image during a drag'n drop operation.\r\n  TVTDragImage = class\r\n  private\r\n    FOwner: TBaseVirtualTree;\r\n    FBackImage,                        // backup of overwritten screen area\r\n    FAlphaImage,                       // target for alpha blending\r\n    FDragImage: TBitmap;               // the actual drag image to blend to screen\r\n    FImagePosition,                    // position of image (upper left corner) in screen coordinates\r\n    FLastPosition: TPoint;             // last mouse position in screen coordinates\r\n    FTransparency: TVTTransparency;    // alpha value of the drag image (0 - fully transparent, 255 - fully opaque)\r\n    FPreBlendBias,                     // value to darken or lighten the drag image before it is blended\r\n    FPostBlendBias: TVTBias;           // value to darken or lighten the alpha blend result\r\n    FFade: Boolean;                    // determines whether to fade the drag image from center to borders or not\r\n    FRestriction: TVTDragMoveRestriction;  // determines in which directions the drag image can be moved\r\n    FColorKey: TColor;                 // color to make fully transparent regardless of any other setting\r\n    FStates: TVTDragImageStates;       // Determines the states of the drag image class.\r\n    function GetVisible: Boolean;      // True if the drag image is currently hidden (used only when dragging)\r\n  protected\r\n    procedure InternalShowDragImage(ScreenDC: HDC);\r\n    procedure MakeAlphaChannel(Source, Target: TBitmap);\r\n  public\r\n    constructor Create(AOwner: TBaseVirtualTree);\r\n    destructor Destroy; override;\r\n\r\n    function DragTo(P: TPoint; ForceRepaint: Boolean): Boolean;\r\n    procedure EndDrag;\r\n    function GetDragImageRect: TRect;\r\n    procedure HideDragImage;\r\n    procedure PrepareDrag(DragImage: TBitmap; ImagePosition, HotSpot: TPoint; const DataObject: IDataObject);\r\n    procedure RecaptureBackground(Tree: TBaseVirtualTree; R: TRect; VisibleRegion: HRGN; CaptureNCArea,\r\n      ReshowDragImage: Boolean);\r\n    procedure ShowDragImage;\r\n    function WillMove(P: TPoint): Boolean;\r\n\r\n    property ColorKey: TColor read FColorKey write FColorKey default clWindow;\r\n    property Fade: Boolean read FFade write FFade default False;\r\n    property MoveRestriction: TVTDragMoveRestriction read FRestriction write FRestriction default dmrNone;\r\n    property PostBlendBias: TVTBias read FPostBlendBias write FPostBlendBias default 0;\r\n    property PreBlendBias: TVTBias read FPreBlendBias write FPreBlendBias default 0;\r\n    property Transparency: TVTTransparency read FTransparency write FTransparency default 128;\r\n    property Visible: Boolean read GetVisible;\r\n  end;\r\n\r\n  // tree columns implementation\r\n  TVirtualTreeColumns = class;\r\n  TVTHeader = class;\r\n\r\n  TVirtualTreeColumnStyle = (\r\n    vsText,\r\n    vsOwnerDraw\r\n  );\r\n\r\n  TVTHeaderColumnLayout = (\r\n    blGlyphLeft,\r\n    blGlyphRight,\r\n    blGlyphTop,\r\n    blGlyphBottom\r\n  );\r\n\r\n  TSortDirection = (\r\n    sdAscending,\r\n    sdDescending\r\n  );\r\n\r\n  TVirtualTreeColumn = class(TCollectionItem)\r\n  private\r\n    FText,\r\n    FHint: string;\r\n    FLeft,\r\n    FWidth: Integer;\r\n    FPosition: TColumnPosition;\r\n    FMinWidth: Integer;\r\n    FMaxWidth: Integer;\r\n    FStyle: TVirtualTreeColumnStyle;\r\n    FImageIndex: TImageIndex;\r\n    FBiDiMode: TBiDiMode;\r\n    FLayout: TVTHeaderColumnLayout;\r\n    FMargin,\r\n    FSpacing: Integer;\r\n    FOptions: TVTColumnOptions;\r\n    FTag: NativeInt;\r\n    FAlignment: TAlignment;\r\n    FCaptionAlignment: TAlignment;     // Alignment of the caption.\r\n    FLastWidth: Integer;\r\n    FColor: TColor;\r\n    FBonusPixel: Boolean;\r\n    FSpringRest: Single;               // Accumulator for width adjustment when auto spring option is enabled.\r\n    FCaptionText: string;\r\n    FCheckBox: Boolean;\r\n    FCheckType: TCheckType;\r\n    FCheckState: TCheckState;\r\n    FImageRect: TRect;\r\n    FHasImage: Boolean;\r\n    FDefaultSortDirection: TSortDirection;\r\n    function GetCaptionAlignment: TAlignment;\r\n    function GetLeft: Integer;\r\n    function IsBiDiModeStored: Boolean;\r\n    function IsCaptionAlignmentStored: Boolean;\r\n    function IsColorStored: Boolean;\r\n    procedure SetAlignment(const Value: TAlignment);\r\n    procedure SetBiDiMode(Value: TBiDiMode);\r\n    procedure SetCaptionAlignment(const Value: TAlignment);\r\n    procedure SetCheckBox(Value: Boolean);\r\n    procedure SetCheckState(Value: TCheckState);\r\n    procedure SetCheckType(Value: TCheckType);\r\n    procedure SetColor(const Value: TColor);\r\n    procedure SetImageIndex(Value: TImageIndex);\r\n    procedure SetLayout(Value: TVTHeaderColumnLayout);\r\n    procedure SetMargin(Value: Integer);\r\n    procedure SetMaxWidth(Value: Integer);\r\n    procedure SetMinWidth(Value: Integer);\r\n    procedure SetOptions(Value: TVTColumnOptions);\r\n    procedure SetPosition(Value: TColumnPosition);\r\n    procedure SetSpacing(Value: Integer);\r\n    procedure SetStyle(Value: TVirtualTreeColumnStyle);\r\n    procedure SetWidth(Value: Integer);\r\n  protected\r\n    procedure ComputeHeaderLayout(DC: HDC; Client: TRect; UseHeaderGlyph, UseSortGlyph: Boolean;\r\n      var HeaderGlyphPos, SortGlyphPos: TPoint; var SortGlyphSize: TSize; var TextBounds: TRect; DrawFormat: Cardinal;\r\n      CalculateTextRect: Boolean = False);\r\n    procedure DefineProperties(Filer: TFiler); override;\r\n    procedure GetAbsoluteBounds(var Left, Right: Integer);\r\n    function GetDisplayName: string; override;\r\n    function GetText: string; virtual; // [IPK]\r\n    procedure SetText(const Value: string); virtual; // [IPK] private to protected & virtual\r\n    function GetOwner: TVirtualTreeColumns; reintroduce;\r\n    procedure ReadHint(Reader: TReader);\r\n    procedure ReadText(Reader: TReader);\r\n    procedure WriteHint(Writer: TWriter);\r\n    procedure WriteText(Writer: TWriter);\r\n    property HasImage: Boolean read FHasImage;\r\n    property ImageRect: TRect read FImageRect;\r\n  public\r\n    constructor Create(Collection: TCollection); override;\r\n    destructor Destroy; override;\r\n\r\n    procedure Assign(Source: TPersistent); override;\r\n    function Equals(OtherColumnObj: TObject): Boolean; override;\r\n    function GetRect: TRect; virtual;\r\n    procedure LoadFromStream(const Stream: TStream; Version: Integer);\r\n    procedure ParentBiDiModeChanged;\r\n    procedure ParentColorChanged;\r\n    procedure RestoreLastWidth;\r\n    procedure SaveToStream(const Stream: TStream);\r\n    function UseRightToLeftReading: Boolean;\r\n\r\n    property Left: Integer read GetLeft;\r\n    property Owner: TVirtualTreeColumns read GetOwner;\r\n  published\r\n    property Alignment: TAlignment read FAlignment write SetAlignment default taLeftJustify;\r\n    property BiDiMode: TBiDiMode read FBiDiMode write SetBiDiMode stored IsBiDiModeStored;\r\n    property CaptionAlignment: TAlignment read GetCaptionAlignment write SetCaptionAlignment\r\n      stored IsCaptionAlignmentStored default taLeftJustify;\r\n    property CaptionText: string read FCaptionText stored False;\r\n    property CheckType: TCheckType read FCheckType write SetCheckType default ctCheckBox;\r\n    property CheckState: TCheckState read FCheckState write SetCheckState default csUncheckedNormal;\r\n    property CheckBox: Boolean read FCheckBox write SetCheckBox default False;\r\n    property Color: TColor read FColor write SetColor stored IsColorStored;\r\n    property DefaultSortDirection: TSortDirection read FDefaultSortDirection write FDefaultSortDirection default sdAscending;\r\n    property Hint: string read FHint write FHint stored False;\r\n    property ImageIndex: TImageIndex read FImageIndex write SetImageIndex default -1;\r\n    property Layout: TVTHeaderColumnLayout read FLayout write SetLayout default blGlyphLeft;\r\n    property Margin: Integer read FMargin write SetMargin default 4;\r\n    property MaxWidth: Integer read FMaxWidth write SetMaxWidth default 10000;\r\n    property MinWidth: Integer read FMinWidth write SetMinWidth default 10;\r\n    property Options: TVTColumnOptions read FOptions write SetOptions default DefaultColumnOptions;\r\n    property Position: TColumnPosition read FPosition write SetPosition;\r\n    property Spacing: Integer read FSpacing write SetSpacing default 3;\r\n    property Style: TVirtualTreeColumnStyle read FStyle write SetStyle default vsText;\r\n    property Tag: NativeInt read FTag write FTag default 0;\r\n    property Text: string read GetText write SetText stored False; // Never let the VCL store the wide string,  // [IPK] FText changed to GetText\r\n                                                                     // it is simply unable to write it correctly.\r\n                                                                     // We use DefineProperties here.\r\n    property Width: Integer read FWidth write SetWidth default 50;\r\n  end;\r\n\r\n  TVirtualTreeColumnClass = class of TVirtualTreeColumn;\r\n\r\n  TColumnsArray = array of TVirtualTreeColumn;\r\n  TCardinalArray = array of Cardinal;\r\n  TIndexArray = array of TColumnIndex;\r\n\r\n  TVirtualTreeColumns = class(TCollection)\r\n  private\r\n    FHeader: TVTHeader;\r\n    FHeaderBitmap: TBitmap;               // backbuffer for drawing\r\n    FHoverIndex,                          // currently \"hot\" column\r\n    FDownIndex,                           // Column on which a mouse button is held down.\r\n    FTrackIndex: TColumnIndex;            // Index of column which is currently being resized.\r\n    FClickIndex: TColumnIndex;            // Index of the last clicked column.\r\n    FCheckBoxHit: Boolean;                // True if the last click was on a header checkbox.\r\n    FPositionToIndex: TIndexArray;\r\n    FDefaultWidth: Integer;               // the width columns are created with\r\n    FNeedPositionsFix: Boolean;           // True if FixPositions must still be called after DFM loading or Bidi mode change.\r\n    FClearing: Boolean;                   // True if columns are being deleted entirely.\r\n    FColumnPopupMenu: TPopupMenu; // Member for storing the TVTHeaderPopupMenu\r\n\r\n    function GetCount: Integer;\r\n    function GetItem(Index: TColumnIndex): TVirtualTreeColumn;\r\n    function GetNewIndex(P: TPoint; var OldIndex: TColumnIndex): Boolean;\r\n    procedure SetDefaultWidth(Value: Integer);\r\n    procedure SetItem(Index: TColumnIndex; Value: TVirtualTreeColumn);\r\n  protected\r\n    // drag support\r\n    FDragIndex: TColumnIndex;             // index of column currently being dragged\r\n    FDropTarget: TColumnIndex;            // current target column (index) while dragging\r\n    FDropBefore: Boolean;                 // True if drop position is in the left half of a column, False for the right\r\n                                          // side to drop the dragged column to\r\n\r\n    procedure AdjustAutoSize(CurrentIndex: TColumnIndex; Force: Boolean = False);\r\n    function AdjustDownColumn(P: TPoint): TColumnIndex;\r\n    function AdjustHoverColumn(P: TPoint): Boolean;\r\n    procedure AdjustPosition(Column: TVirtualTreeColumn; Position: Cardinal);\r\n    function CanSplitterResize(P: TPoint; Column: TColumnIndex): Boolean;\r\n    procedure DoCanSplitterResize(P: TPoint; Column: TColumnIndex; var Allowed: Boolean); virtual;\r\n    procedure DrawButtonText(DC: HDC; Caption: string; Bounds: TRect; Enabled, Hot: Boolean; DrawFormat: Cardinal;\r\n      WrapCaption: Boolean);\r\n    procedure FixPositions;\r\n    function GetColumnAndBounds(P: TPoint; var ColumnLeft, ColumnRight: Integer; Relative: Boolean = True): Integer;\r\n    function GetOwner: TPersistent; override;\r\n    procedure HandleClick(P: TPoint; Button: TMouseButton; Force, DblClick: Boolean); virtual;\r\n    procedure HeaderPopupMenuColumnChange(const Sender: TBaseVirtualTree; const Column: TColumnIndex; Visible: Boolean);\r\n    procedure IndexChanged(OldIndex, NewIndex: Integer);\r\n    procedure InitializePositionArray;\r\n    procedure Notify(Item: TCollectionItem; Action: System.Classes.TCollectionNotification); override;\r\n    procedure ReorderColumns(RTL: Boolean);\r\n    procedure Update(Item: TCollectionItem); override;\r\n    procedure UpdatePositions(Force: Boolean = False);\r\n\r\n    property HeaderBitmap: TBitmap read FHeaderBitmap;\r\n    property PositionToIndex: TIndexArray read FPositionToIndex;\r\n    property HoverIndex: TColumnIndex read FHoverIndex;\r\n    property DownIndex: TColumnIndex read FDownIndex;\r\n    property CheckBoxHit: Boolean read FCheckBoxHit;\r\n  public\r\n    constructor Create(AOwner: TVTHeader); virtual;\r\n    destructor Destroy; override;\r\n\r\n    function Add: TVirtualTreeColumn; virtual;\r\n    procedure AnimatedResize(Column: TColumnIndex; NewWidth: Integer);\r\n    procedure Assign(Source: TPersistent); override;\r\n    procedure Clear; virtual;\r\n    function ColumnFromPosition(P: TPoint; Relative: Boolean = True): TColumnIndex; overload; virtual;\r\n    function ColumnFromPosition(PositionIndex: TColumnPosition): TColumnIndex; overload; virtual;\r\n    function Equals(OtherColumnsObj: TObject): Boolean; override;\r\n    procedure GetColumnBounds(Column: TColumnIndex; var Left, Right: Integer);\r\n    function GetFirstVisibleColumn(ConsiderAllowFocus: Boolean = False): TColumnIndex;\r\n    function GetLastVisibleColumn(ConsiderAllowFocus: Boolean = False): TColumnIndex;\r\n    function GetFirstColumn: TColumnIndex;\r\n    function GetNextColumn(Column: TColumnIndex): TColumnIndex;\r\n    function GetNextVisibleColumn(Column: TColumnIndex; ConsiderAllowFocus: Boolean = False): TColumnIndex;\r\n    function GetPreviousColumn(Column: TColumnIndex): TColumnIndex;\r\n    function GetPreviousVisibleColumn(Column: TColumnIndex; ConsiderAllowFocus: Boolean = False): TColumnIndex;\r\n    function GetScrollWidth: Integer;\r\n    function GetVisibleColumns: TColumnsArray;\r\n    function GetVisibleFixedWidth: Integer;\r\n    function IsValidColumn(Column: TColumnIndex): Boolean;\r\n    procedure LoadFromStream(const Stream: TStream; Version: Integer);\r\n    procedure PaintHeader(DC: HDC; R: TRect; HOffset: Integer); overload; virtual;\r\n    procedure PaintHeader(TargetCanvas: TCanvas; R: TRect; const Target: TPoint;\r\n      RTLOffset: Integer = 0); overload; virtual;\r\n    procedure SaveToStream(const Stream: TStream);\r\n    function TotalWidth: Integer;\r\n\r\n    property Count: Integer read GetCount;\r\n    property ClickIndex: TColumnIndex read FClickIndex;\r\n    property DefaultWidth: Integer read FDefaultWidth write SetDefaultWidth default 50;\r\n    property Items[Index: TColumnIndex]: TVirtualTreeColumn read GetItem write SetItem; default;\r\n    property Header: TVTHeader read FHeader;\r\n    property TrackIndex: TColumnIndex read FTrackIndex;\r\n  end;\r\n\r\n  TVirtualTreeColumnsClass = class of TVirtualTreeColumns;\r\n\r\n  TVTConstraintPercent = 0..100;\r\n  TVTFixedAreaConstraints = class(TPersistent)\r\n  private\r\n    FHeader: TVTHeader;\r\n    FMaxHeightPercent,\r\n    FMaxWidthPercent,\r\n    FMinHeightPercent,\r\n    FMinWidthPercent: TVTConstraintPercent;\r\n    FOnChange: TNotifyEvent;\r\n    procedure SetConstraints(Index: Integer; Value: TVTConstraintPercent);\r\n  protected\r\n    procedure Change;\r\n    property Header: TVTHeader read FHeader;\r\n  public\r\n    constructor Create(AOwner: TVTHeader);\r\n\r\n    procedure Assign(Source: TPersistent); override;\r\n    property OnChange: TNotifyEvent read FOnChange write FOnChange;\r\n  published\r\n    property MaxHeightPercent: TVTConstraintPercent index 0 read FMaxHeightPercent write SetConstraints default 0;\r\n    property MaxWidthPercent: TVTConstraintPercent index 1 read FMaxWidthPercent write SetConstraints default 0;\r\n    property MinHeightPercent: TVTConstraintPercent index 2 read FMinHeightPercent write SetConstraints default 0;\r\n    property MinWidthPercent: TVTConstraintPercent index 3 read FMinWidthPercent write SetConstraints default 0;\r\n  end;\r\n\r\n  TVTHeaderStyle = (\r\n    hsThickButtons,    // TButton look and feel\r\n    hsFlatButtons,     // flatter look than hsThickButton, like an always raised flat TToolButton\r\n    hsPlates          // flat TToolButton look and feel (raise on hover etc.)\r\n  );\r\n\r\n  TVTHeaderOption = (\r\n    hoAutoResize,            // Adjust a column so that the header never exceeds the client width of the owner control.\r\n    hoColumnResize,          // Resizing columns with the mouse is allowed.\r\n    hoDblClickResize,        // Allows a column to resize itself to its largest entry.\r\n    hoDrag,                  // Dragging columns is allowed.\r\n    hoHotTrack,              // Header captions are highlighted when mouse is over a particular column.\r\n    hoOwnerDraw,             // Header items with the owner draw style can be drawn by the application via event.\r\n    hoRestrictDrag,          // Header can only be dragged horizontally.\r\n    hoShowHint,              // Show application defined header hint.\r\n    hoShowImages,            // Show header images.\r\n    hoShowSortGlyphs,        // Allow visible sort glyphs.\r\n    hoVisible,               // Header is visible.\r\n    hoAutoSpring,            // Distribute size changes of the header to all columns, which are sizable and have the\r\n                             // coAutoSpring option enabled.\r\n    hoFullRepaintOnResize,   // Fully invalidate the header (instead of subsequent columns only) when a column is resized.\r\n    hoDisableAnimatedResize, // Disable animated resize for all columns.\r\n    hoHeightResize,          // Allow resizing header height via mouse.\r\n    hoHeightDblClickResize,  // Allow the header to resize itself to its default height.\r\n    hoHeaderClickAutoSort,    // Clicks on the header will make the clicked column the SortColumn or toggle sort direction if\r\n                             // it already was the sort column\r\n    hoAutoColumnPopupMenu    // Show a context menu for activating and deactivating columns on right click\r\n  );\r\n  TVTHeaderOptions = set of TVTHeaderOption;\r\n\r\n  THeaderState = (\r\n    hsAutoSizing,              // auto size chain is in progess, do not trigger again on WM_SIZE\r\n    hsDragging,                // header dragging is in progress (only if enabled)\r\n    hsDragPending,             // left button is down, user might want to start dragging a column\r\n    hsLoading,                 // The header currently loads from stream, so updates are not necessary.\r\n    hsColumnWidthTracking,     // column resizing is in progress\r\n    hsColumnWidthTrackPending, // left button is down, user might want to start resize a column\r\n    hsHeightTracking,          // height resizing is in progress\r\n    hsHeightTrackPending,      // left button is down, user might want to start changing height\r\n    hsResizing,                // multi column resizing in progress\r\n    hsScaling,                 // the header is scaled after a change of FixedAreaConstraints or client size\r\n    hsNeedScaling              // the header needs to be scaled\r\n  );\r\n  THeaderStates = set of THeaderState;\r\n\r\n\r\n  TSmartAutoFitType = (\r\n    smaAllColumns,      // consider nodes in view only for all columns\r\n    smaNoColumn,        // consider nodes in view only for no column\r\n    smaUseColumnOption  // use coSmartResize of the corresponding column\r\n  );  // describes the used column resize behaviour for AutoFitColumns\r\n\r\n\r\n  TChangeReason = (\r\n    crIgnore,       // used as placeholder\r\n    crAccumulated,  // used for delayed changes\r\n    crChildAdded,   // one or more child nodes have been added\r\n    crChildDeleted, // one or more child nodes have been deleted\r\n    crNodeAdded,    // a node has been added\r\n    crNodeCopied,   // a node has been duplicated\r\n    crNodeMoved     // a node has been moved to a new place\r\n  ); // desribes what made a structure change event happen\r\n\r\n  TVTHeader = class(TPersistent)\r\n  private\r\n    FOwner: TBaseVirtualTree;\r\n    FColumns: TVirtualTreeColumns;\r\n    FHeight: Integer;\r\n    FFont: TFont;\r\n    FParentFont: Boolean;\r\n    FOptions: TVTHeaderOptions;\r\n    FStyle: TVTHeaderStyle;            // button style\r\n    FBackgroundColor: TColor;\r\n    FAutoSizeIndex: TColumnIndex;\r\n    FPopupMenu: TPopupMenu;\r\n    FMainColumn: TColumnIndex;         // the column which holds the tree\r\n    FMaxHeight: Integer;\r\n    FMinHeight: Integer;\r\n    FDefaultHeight: Integer;\r\n    FFixedAreaConstraints: TVTFixedAreaConstraints; // Percentages for the fixed area (header, fixed columns).\r\n    FImages: TCustomImageList;\r\n    FImageChangeLink: TChangeLink;     // connections to the image list to get notified about changes\r\n    fSplitterHitTolerance: Integer; // For property SplitterHitTolerance\r\n    FSortColumn: TColumnIndex;\r\n    FSortDirection: TSortDirection;\r\n    FDragImage: TVTDragImage;          // drag image management during header drag\r\n    FLastWidth: Integer;               // Used to adjust spring columns. This is the width of all visible columns,\r\n                                       // not the header rectangle.\r\n    procedure FontChanged(Sender: TObject);\r\n    function GetMainColumn: TColumnIndex;\r\n    function GetUseColumns: Boolean;\r\n    function IsFontStored: Boolean;\r\n    procedure SetAutoSizeIndex(Value: TColumnIndex);\r\n    procedure SetBackground(Value: TColor);\r\n    procedure SetColumns(Value: TVirtualTreeColumns);\r\n    procedure SetDefaultHeight(Value: Integer);\r\n    procedure SetFont(const Value: TFont);\r\n    procedure SetHeight(Value: Integer);\r\n    procedure SetImages(const Value: TCustomImageList);\r\n    procedure SetMainColumn(Value: TColumnIndex);\r\n    procedure SetMaxHeight(Value: Integer);\r\n    procedure SetMinHeight(Value: Integer);\r\n    procedure SetOptions(Value: TVTHeaderOptions);\r\n    procedure SetParentFont(Value: Boolean);\r\n    procedure SetSortColumn(Value: TColumnIndex);\r\n    procedure SetSortDirection(const Value: TSortDirection);\r\n    procedure SetStyle(Value: TVTHeaderStyle);\r\n  protected\r\n    FStates: THeaderStates;            // Used to keep track of internal states the header can enter.\r\n    FDragStart: TPoint;                // initial mouse drag position\r\n    FTrackStart: TPoint;               // client coordinates of the tracking start point\r\n    FTrackPoint: TPoint;               // Client coordinate where the tracking started.\r\n\r\n    function CanSplitterResize(P: TPoint): Boolean;\r\n    function CanWriteColumns: Boolean; virtual;\r\n    procedure ChangeScale(M, D: Integer); virtual;\r\n    function DetermineSplitterIndex(P: TPoint): Boolean; virtual;\r\n    procedure DoAfterAutoFitColumn(Column: TColumnIndex); virtual;\r\n    procedure DoAfterColumnWidthTracking(Column: TColumnIndex); virtual;\r\n    procedure DoAfterHeightTracking; virtual;\r\n    function DoBeforeAutoFitColumn(Column: TColumnIndex; SmartAutoFitType: TSmartAutoFitType): Boolean; virtual;\r\n    procedure DoBeforeColumnWidthTracking(Column: TColumnIndex; Shift: TShiftState); virtual;\r\n    procedure DoBeforeHeightTracking(Shift: TShiftState); virtual;\r\n    procedure DoCanSplitterResize(P: TPoint; var Allowed: Boolean); virtual;\r\n    function DoColumnWidthDblClickResize(Column: TColumnIndex; P: TPoint; Shift: TShiftState): Boolean; virtual;\r\n    function DoColumnWidthTracking(Column: TColumnIndex; Shift: TShiftState; var TrackPoint: TPoint; P: TPoint): Boolean; virtual;\r\n    function DoGetPopupMenu(Column: TColumnIndex; Position: TPoint): TPopupMenu; virtual;\r\n    function DoHeightTracking(var P: TPoint; Shift: TShiftState): Boolean; virtual;\r\n    function DoHeightDblClickResize(var P: TPoint; Shift: TShiftState): Boolean; virtual;\r\n    procedure DoSetSortColumn(Value: TColumnIndex); virtual;\r\n    procedure DragTo(P: TPoint);\r\n    procedure FixedAreaConstraintsChanged(Sender: TObject);\r\n    function GetColumnsClass: TVirtualTreeColumnsClass; virtual;\r\n    function GetOwner: TPersistent; override;\r\n    function GetShiftState: TShiftState;\r\n    function HandleHeaderMouseMove(var Message: TWMMouseMove): Boolean;\r\n    function HandleMessage(var Message: TMessage): Boolean; virtual;\r\n    procedure ImageListChange(Sender: TObject);\r\n    procedure PrepareDrag(P, Start: TPoint);\r\n    procedure ReadColumns(Reader: TReader);\r\n    procedure RecalculateHeader; virtual;\r\n    procedure RescaleHeader;\r\n    procedure UpdateMainColumn;\r\n    procedure UpdateSpringColumns;\r\n    procedure WriteColumns(Writer: TWriter);\r\n  public\r\n    constructor Create(AOwner: TBaseVirtualTree); virtual;\r\n    destructor Destroy; override;\r\n\r\n    function AllowFocus(ColumnIndex: TColumnIndex): Boolean;\r\n    procedure Assign(Source: TPersistent); override;\r\n    procedure AutoFitColumns(Animated: Boolean = True; SmartAutoFitType: TSmartAutoFitType = smaUseColumnOption;\r\n      RangeStartCol: Integer = NoColumn; RangeEndCol: Integer = NoColumn); virtual;\r\n    function InHeader(P: TPoint): Boolean; virtual;\r\n    function InHeaderSplitterArea(P: TPoint): Boolean; virtual;\r\n    procedure Invalidate(Column: TVirtualTreeColumn; ExpandToBorder: Boolean = False);\r\n    procedure LoadFromStream(const Stream: TStream); virtual;\r\n    function ResizeColumns(ChangeBy: Integer; RangeStartCol: TColumnIndex; RangeEndCol: TColumnIndex;\r\n      Options: TVTColumnOptions = [coVisible]): Integer;\r\n    procedure RestoreColumns;\r\n    procedure SaveToStream(const Stream: TStream); virtual;\r\n\r\n    property DragImage: TVTDragImage read FDragImage;\r\n    property States: THeaderStates read FStates;\r\n    property Treeview: TBaseVirtualTree read FOwner;\r\n    property UseColumns: Boolean read GetUseColumns;\r\n  published\r\n    property AutoSizeIndex: TColumnIndex read FAutoSizeIndex write SetAutoSizeIndex;\r\n    property Background: TColor read FBackgroundColor write SetBackground default clBtnFace;\r\n    property Columns: TVirtualTreeColumns read FColumns write SetColumns stored False; // Stored by the owner tree to support VFI.\r\n    property DefaultHeight: Integer read FDefaultHeight write SetDefaultHeight default 19;\r\n    property Font: TFont read FFont write SetFont stored IsFontStored;\r\n    property FixedAreaConstraints: TVTFixedAreaConstraints read FFixedAreaConstraints write FFixedAreaConstraints;\r\n    property Height: Integer read FHeight write SetHeight default 19;\r\n    property Images: TCustomImageList read FImages write SetImages;\r\n    property MainColumn: TColumnIndex read GetMainColumn write SetMainColumn default 0;\r\n    property MaxHeight: Integer read FMaxHeight write SetMaxHeight default 10000;\r\n    property MinHeight: Integer read FMinHeight write SetMinHeight default 10;\r\n    property Options: TVTHeaderOptions read FOptions write SetOptions default [hoColumnResize, hoDrag, hoShowSortGlyphs];\r\n    property ParentFont: Boolean read FParentFont write SetParentFont default False;\r\n    property PopupMenu: TPopupMenu read FPopupMenu write FPopupMenu;\r\n    property SortColumn: TColumnIndex read FSortColumn write SetSortColumn default NoColumn;\r\n    property SortDirection: TSortDirection read FSortDirection write SetSortDirection default sdAscending;\r\n    property SplitterHitTolerance: Integer read fSplitterHitTolerance write fSplitterHitTolerance default 8; // The area in pixels around a spliter which is sensitive for resizing\r\n    property Style: TVTHeaderStyle read FStyle write SetStyle default hsThickButtons;\r\n  end;\r\n\r\n  TVTHeaderClass = class of TVTHeader;\r\n\r\n  // Communication interface between a tree editor and the tree itself (declared as using stdcall in case it\r\n  // is implemented in a (C/C++) DLL). The GUID is not nessecary in Delphi but important for BCB users\r\n  // to allow QueryInterface and _uuidof calls.\r\n  IVTEditLink = interface\r\n    ['{2BE3EAFA-5ACB-45B4-9D9A-B58BCC496E17}']\r\n    function BeginEdit: Boolean; stdcall;                  // Called when editing actually starts.\r\n    function CancelEdit: Boolean; stdcall;                 // Called when editing has been cancelled by the tree.\r\n    function EndEdit: Boolean; stdcall;                    // Called when editing has been finished by the tree. Returns True if successful, False if edit mode is still active.\r\n    function PrepareEdit(Tree: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex): Boolean; stdcall;\r\n                                                           // Called after creation to allow a setup.\r\n    function GetBounds: TRect; stdcall;                    // Called to get the current size of the edit window\r\n                                                           // (only important if the edit resizes itself).\r\n    procedure ProcessMessage(var Message: TMessage); stdcall;\r\n                                                           // Used to forward messages to the edit window(s)-\r\n    procedure SetBounds(R: TRect); stdcall;                // Called to place the editor.\r\n  end;\r\n\r\n  // Indicates in the OnUpdating event what state the tree is currently in.\r\n  TVTUpdateState = (\r\n    usBegin,       // The tree just entered the update state (BeginUpdate call for the first time).\r\n    usBeginSynch,  // The tree just entered the synch update state (BeginSynch call for the first time).\r\n    usSynch,       // Begin/EndSynch has been called but the tree did not change the update state.\r\n    usUpdate,      // Begin/EndUpdate has been called but the tree did not change the update state.\r\n    usEnd,         // The tree just left the update state (EndUpdate called for the last level).\r\n    usEndSynch     // The tree just left the synch update state (EndSynch called for the last level).\r\n  );\r\n\r\n  // Used during owner draw of the header to indicate which drop mark for the column must be drawn.\r\n  TVTDropMarkMode = (\r\n    dmmNone,\r\n    dmmLeft,\r\n    dmmRight\r\n  );\r\n\r\n  // This structure carries all important information about header painting and is used in the advanced header painting.\r\n  THeaderPaintInfo = record\r\n    TargetCanvas: TCanvas;\r\n    Column: TVirtualTreeColumn;\r\n    PaintRectangle: TRect;\r\n    TextRectangle: TRect;\r\n    IsHoverIndex,\r\n    IsDownIndex,\r\n    IsEnabled,\r\n    ShowHeaderGlyph,\r\n    ShowSortGlyph,\r\n    ShowRightBorder: Boolean;\r\n    DropMark: TVTDropMarkMode;\r\n    GlyphPos,\r\n    SortGlyphPos: TPoint;\r\n  end;\r\n\r\n  // These elements are used both to query the application, which of them it wants to draw itself and to tell it during\r\n  // painting, which elements must be drawn during the advanced custom draw events.\r\n  THeaderPaintElements = set of (\r\n    hpeBackground,\r\n    hpeDropMark,\r\n    hpeHeaderGlyph,\r\n    hpeSortGlyph,\r\n    hpeText\r\n  );\r\n\r\n  // Various events must be handled at different places than they were initiated or need\r\n  // a persistent storage until they are reset.\r\n  TVirtualTreeStates = set of (\r\n    tsCancelHintAnimation,    // Set when a new hint is about to show but an old hint is still being animated.\r\n    tsChangePending,          // A selection change is pending.\r\n    tsCheckPropagation,       // Set during automatic check state propagation.\r\n    tsCollapsing,             // A full collapse operation is in progress.\r\n    tsToggleFocusedSelection, // Node selection was modifed using Ctrl-click. Change selection state on next mouse up.\r\n    tsClearPending,           // Need to clear the current selection on next mouse move.\r\n    tsClipboardFlushing,      // Set during flushing the clipboard to avoid freeing the content.\r\n    tsCopyPending,            // Indicates a pending copy operation which needs to be finished.\r\n    tsCutPending,             // Indicates a pending cut operation which needs to be finished.\r\n    tsDrawSelPending,         // Multiselection only. User held down the left mouse button on a free\r\n                              // area and might want to start draw selection.\r\n    tsDrawSelecting,          // Multiselection only. Draw selection has actually started.\r\n    tsEditing,                // Indicates that an edit operation is currently in progress.\r\n    tsEditPending,            // An mouse up start edit if dragging has not started.\r\n    tsExpanding,              // A full expand operation is in progress.\r\n    tsNodeHeightTracking,     // A node height changing operation is in progress.\r\n    tsNodeHeightTrackPending, // left button is down, user might want to start changing a node's height.\r\n    tsHint,                   // Set when our hint is visible or soon will be.\r\n    tsInAnimation,            // Set if the tree is currently in an animation loop.\r\n    tsIncrementalSearching,   // Set when the user starts incremental search.\r\n    tsIncrementalSearchPending, // Set in WM_KEYDOWN to tell to use the char in WM_CHAR for incremental search.\r\n    tsIterating,              // Set when IterateSubtree is currently in progress.\r\n    tsKeyCheckPending,        // A check operation is under way, initiated by a key press (space key). Ignore mouse.\r\n    tsLeftButtonDown,         // Set when the left mouse button is down.\r\n    tsLeftDblClick,           // Set when the left mouse button was doubly clicked.\r\n    tsMouseCheckPending,      // A check operation is under way, initiated by a mouse click. Ignore space key.\r\n    tsMiddleButtonDown,       // Set when the middle mouse button is down.\r\n    tsMiddleDblClick,         // Set when the middle mouse button was doubly clicked.\r\n    tsNeedRootCountUpdate,    // Set if while loading a root node count is set.\r\n    tsOLEDragging,            // OLE dragging in progress.\r\n    tsOLEDragPending,         // User has requested to start delayed dragging.\r\n    tsPainting,               // The tree is currently painting itself.\r\n    tsRightButtonDown,        // Set when the right mouse button is down.\r\n    tsRightDblClick,          // Set when the right mouse button was doubly clicked.\r\n    tsPopupMenuShown,         // The user clicked the right mouse button, which might cause a popup menu to appear.\r\n    tsScrolling,              // Set when autoscrolling is active.\r\n    tsScrollPending,          // Set when waiting for the scroll delay time to elapse.\r\n    tsSizing,                 // Set when the tree window is being resized. This is used to prevent recursive calls\r\n                              // due to setting the scrollbars when sizing.\r\n    tsStopValidation,         // Cache validation can be stopped (usually because a change has occured meanwhile).\r\n    tsStructureChangePending, // The structure of the tree has been changed while the update was locked.\r\n    tsSynchMode,              // Set when the tree is in synch mode, where no timer events are triggered.\r\n    tsThumbTracking,          // Stop updating the horizontal scroll bar while dragging the vertical thumb and vice versa.\r\n    tsToggling,               // A toggle operation (for some node) is in progress.\r\n    tsUpdateHiddenChildrenNeeded, // Pending update for the hidden children flag after massive visibility changes.\r\n    tsUpdating,               // The tree does currently not update its window because a BeginUpdate has not yet ended.\r\n    tsUseCache,               // The tree's node caches are validated and non-empty.\r\n    tsUserDragObject,         // Signals that the application created an own drag object in OnStartDrag.\r\n    tsUseThemes,              // The tree runs under WinXP+, is theme aware and themes are enabled.\r\n    tsValidating,             // The tree's node caches are currently validated.\r\n    tsPreviouslySelectedLocked,// The member FPreviouslySelected should not be changed\r\n    tsValidationNeeded,       // Something in the structure of the tree has changed. The cache needs validation.\r\n    tsVCLDragging,            // VCL drag'n drop in progress.\r\n    tsVCLDragPending,         // One-shot flag to avoid clearing the current selection on implicit mouse up for VCL drag.\r\n    tsVCLDragFinished,        // Flag to avoid triggering the OnColumnClick event twice\r\n    tsWheelPanning,           // Wheel mouse panning is active or soon will be.\r\n    tsWheelScrolling,         // Wheel mouse scrolling is active or soon will be.\r\n    tsWindowCreating,         // Set during window handle creation to avoid frequent unnecessary updates.\r\n    tsUseExplorerTheme        // The tree runs under WinVista+ and is using the explorer theme\r\n  );\r\n\r\n  TChangeStates = set of (\r\n    csStopValidation,         // Cache validation can be stopped (usually because a change has occured meanwhile).\r\n    csUseCache,               // The tree's node caches are validated and non-empty.\r\n    csValidating,             // The tree's node caches are currently validated.\r\n    csValidationNeeded        // Something in the structure of the tree has changed. The cache needs validation.\r\n  );\r\n\r\n  // determines whether and how the drag image is to show\r\n  TVTDragImageKind = (\r\n    diComplete,       // show a complete drag image with all columns, only visible columns are shown\r\n    diMainColumnOnly, // show only the main column (the tree column)\r\n    diNoImage         // don't show a drag image at all\r\n  );\r\n\r\n  // Switch for OLE and VCL drag'n drop. Because it is not possible to have both simultanously.\r\n  TVTDragType = (\r\n    dtOLE,\r\n    dtVCL\r\n  );\r\n\r\n  // options which determine what to draw in PaintTree\r\n  TVTInternalPaintOption = (\r\n    poBackground,       // draw background image if there is any and it is enabled\r\n    poColumnColor,      // erase node's background with the column's color\r\n    poDrawFocusRect,    // draw focus rectangle around the focused node\r\n    poDrawSelection,    // draw selected nodes with the normal selection color\r\n    poDrawDropMark,     // draw drop mark if a node is currently the drop target\r\n    poGridLines,        // draw grid lines if enabled\r\n    poMainOnly,         // draw only the main column\r\n    poSelectedOnly,     // draw only selected nodes\r\n    poUnbuffered        // draw directly onto the target canvas; especially useful when printing\r\n  );\r\n  TVTInternalPaintOptions = set of TVTInternalPaintOption;\r\n\r\n  // Determines the look of a tree's lines.\r\n  TVTLineStyle = (\r\n    lsCustomStyle,           // application provides a line pattern\r\n    lsDotted,                // usual dotted lines (default)\r\n    lsSolid                  // simple solid lines\r\n  );\r\n\r\n  // TVTLineType is used during painting a tree\r\n  TVTLineType = (\r\n    ltNone,          // no line at all\r\n    ltBottomRight,   // a line from bottom to the center and from there to the right\r\n    ltTopDown,       // a line from top to bottom\r\n    ltTopDownRight,  // a line from top to bottom and from center to the right\r\n    ltRight,         // a line from center to the right\r\n    ltTopRight,      // a line from bottom to center and from there to the right\r\n    // special styles for alternative drawings of tree lines\r\n    ltLeft,          // a line from top to bottom at the left\r\n    ltLeftBottom     // a combination of ltLeft and a line at the bottom from left to right\r\n  );\r\n\r\n  // Determines how to draw tree lines.\r\n  TVTLineMode = (\r\n    lmNormal,        // usual tree lines (as in TTreeview)\r\n    lmBands          // looks similar to a Nassi-Schneidermann diagram\r\n  );\r\n\r\n  // A collection of line type IDs which is used while painting a node.\r\n  TLineImage = array of TVTLineType;\r\n\r\n  TVTScrollIncrement = 1..10000;\r\n\r\n  // Export type\r\n  TVTExportType = (\r\n    etNone,  // No export, normal displaying on the screen\r\n    etRTF,   // contentToRTF\r\n    etHTML,  // contentToHTML\r\n    etText,  // contentToText\r\n    etExcel, // supported by external tools\r\n    etWord,  // supported by external tools\r\n    etCustom // supported by external tools\r\n  );\r\n\r\n  TVTNodeExportEvent   = function (Sender: TBaseVirtualTree; aExportType: TVTExportType; Node: PVirtualNode): Boolean of object;\r\n  TVTColumnExportEvent = procedure (Sender: TBaseVirtualTree; aExportType: TVTExportType; Column: TVirtualTreeColumn) of object;\r\n  TVTTreeExportEvent   = procedure(Sender: TBaseVirtualTree; aExportType: TVTExportType) of object;\r\n\r\n  // A class to manage scroll bar aspects.\r\n  TScrollBarOptions = class(TPersistent)\r\n  private\r\n    FAlwaysVisible: Boolean;\r\n    FOwner: TBaseVirtualTree;\r\n    FScrollBars: TScrollStyle;                   // used to hide or show vertical and/or horizontal scrollbar\r\n    FScrollBarStyle: TScrollBarStyle;            // kind of scrollbars to use\r\n    FIncrementX,\r\n    FIncrementY: TVTScrollIncrement;             // number of pixels to scroll in one step (when auto scrolling)\r\n    procedure SetAlwaysVisible(Value: Boolean);\r\n    procedure SetScrollBars(Value: TScrollStyle);\r\n    procedure SetScrollBarStyle(Value: TScrollBarStyle);\r\n  protected\r\n    function GetOwner: TPersistent; override;\r\n  public\r\n    constructor Create(AOwner: TBaseVirtualTree);\r\n\r\n    procedure Assign(Source: TPersistent); override;\r\n  published\r\n    property AlwaysVisible: Boolean read FAlwaysVisible write SetAlwaysVisible default False;\r\n    property HorizontalIncrement: TVTScrollIncrement read FIncrementX write FIncrementX default 20;\r\n    property ScrollBars: TScrollStyle read FScrollBars write SetScrollBars default ssBoth;\r\n    property ScrollBarStyle: TScrollBarStyle read FScrollBarStyle write SetScrollBarStyle default sbmRegular;\r\n    property VerticalIncrement: TVTScrollIncrement read FIncrementY write FIncrementY default 20;\r\n  end;\r\n\r\n  // class to collect all switchable colors into one place\r\n  TVTColors = class(TPersistent)\r\n  private\r\n    FOwner: TBaseVirtualTree;\r\n    FColors: array[0..16] of TColor; // [IPK] 15 -> 16\r\n    function GetColor(const Index: Integer): TColor;\r\n    procedure SetColor(const Index: Integer; const Value: TColor);\r\n    function GetBackgroundColor: TColor;\r\n    function GetHeaderFontColor: TColor;\r\n    function GetNodeFontColor: TColor;\r\n  public\r\n    constructor Create(AOwner: TBaseVirtualTree);\r\n\r\n    procedure Assign(Source: TPersistent); override;\r\n    property BackGroundColor: TColor read GetBackgroundColor;\r\n    property HeaderFontColor: TColor read  GetHeaderFontColor;\r\n    property NodeFontColor: TColor read GetNodeFontColor;\r\n  published\r\n    property BorderColor: TColor index 7 read GetColor write SetColor default clBtnFace;\r\n    property DisabledColor: TColor index 0 read GetColor write SetColor default clBtnShadow;\r\n    property DropMarkColor: TColor index 1 read GetColor write SetColor default clHighlight;\r\n    property DropTargetColor: TColor index 2 read GetColor write SetColor default clHighLight;\r\n    property DropTargetBorderColor: TColor index 11 read GetColor write SetColor default clHighLight;\r\n    property FocusedSelectionColor: TColor index 3 read GetColor write SetColor default clHighLight;\r\n    property FocusedSelectionBorderColor: TColor index 9 read GetColor write SetColor default clHighLight;\r\n    property GridLineColor: TColor index 4 read GetColor write SetColor default clBtnFace;\r\n    property HeaderHotColor: TColor index 14 read GetColor write SetColor default clBtnShadow;\r\n    property HotColor: TColor index 8 read GetColor write SetColor default clWindowText;\r\n    property SelectionRectangleBlendColor: TColor index 12 read GetColor write SetColor default clHighlight;\r\n    property SelectionRectangleBorderColor: TColor index 13 read GetColor write SetColor default clHighlight;\r\n    property SelectionTextColor: TColor index 15 read GetColor write SetColor default clHighlightText;\r\n    property TreeLineColor: TColor index 5 read GetColor write SetColor default clBtnShadow;\r\n    property UnfocusedColor: TColor index 16 read GetColor write SetColor default clBtnFace; // [IPK] Added\r\n    property UnfocusedSelectionColor: TColor index 6 read GetColor write SetColor default clBtnFace;\r\n    property UnfocusedSelectionBorderColor: TColor index 10 read GetColor write SetColor default clBtnFace;\r\n  end;\r\n\r\n  // For painting a node and its columns/cells a lot of information must be passed frequently around.\r\n  TVTImageInfo = record\r\n    Index: TImageIndex;           // Index in the associated image list.\r\n    XPos,                     // Horizontal position in the current target canvas.\r\n    YPos: Integer;            // Vertical position in the current target canvas.\r\n    Ghosted: Boolean;         // Flag to indicate that the image must be drawn slightly lighter.\r\n    Images: TCustomImageList; // The image list to be used for painting.\r\n    function Equals(const pImageInfo2: TVTImageInfo): Boolean;\r\n  end;\r\n\r\n  TVTImageInfoIndex = (\r\n    iiNormal,\r\n    iiState,\r\n    iiCheck,\r\n    iiOverlay\r\n  );\r\n\r\n  // Options which are used when modifying the scroll offsets.\r\n  TScrollUpdateOptions = set of (\r\n    suoRepaintHeader,        // if suoUpdateNCArea is also set then invalidate the header\r\n    suoRepaintScrollBars,    // if suoUpdateNCArea is also set then repaint both scrollbars after updating them\r\n    suoScrollClientArea,     // scroll and invalidate the proper part of the client area\r\n    suoUpdateNCArea          // update non-client area (scrollbars, header)\r\n  );\r\n\r\n  // Determines the look of a tree's buttons.\r\n  TVTButtonStyle = (\r\n    bsRectangle,             // traditional Windows look (plus/minus buttons)\r\n    bsTriangle               // traditional Macintosh look\r\n  );\r\n\r\n  // TButtonFillMode is only used when the button style is bsRectangle and determines how to fill the interior.\r\n  TVTButtonFillMode = (\r\n    fmTreeColor,             // solid color, uses the tree's background color\r\n    fmWindowColor,           // solid color, uses clWindow\r\n    fmShaded,                // color gradient, Windows XP style (legacy code, use toThemeAware on Windows XP instead)\r\n    fmTransparent            // transparent color, use the item's background color\r\n  );\r\n\r\n  TVTPaintInfo = record\r\n    Canvas: TCanvas;              // the canvas to paint on\r\n    PaintOptions: TVTInternalPaintOptions;  // a copy of the paint options passed to PaintTree\r\n    Node: PVirtualNode;           // the node to paint\r\n    Column: TColumnIndex;         // the node's column index to paint\r\n    Position: TColumnPosition;    // the column position of the node\r\n    CellRect,                     // the node cell\r\n    ContentRect: TRect;           // the area of the cell used for the node's content\r\n    NodeWidth: Integer;           // the actual node width\r\n    Alignment: TAlignment;        // how to align within the node rectangle\r\n    CaptionAlignment: TAlignment; // how to align text within the caption rectangle\r\n    BidiMode: TBidiMode;          // directionality to be used for painting\r\n    BrushOrigin: TPoint;          // the alignment for the brush used to draw dotted lines\r\n    ImageInfo: array[TVTImageInfoIndex] of TVTImageInfo; // info about each possible node image\r\n  end;\r\n\r\n  // Method called by the Animate routine for each animation step.\r\n  TVTAnimationCallback = function(Step, StepSize: Integer; Data: Pointer): Boolean of object;\r\n\r\n  TVTIncrementalSearch = (\r\n    isAll,                   // search every node in tree, initialize if necessary\r\n    isNone,                  // disable incremental search\r\n    isInitializedOnly,       // search only initialized nodes, skip others\r\n    isVisibleOnly            // search only visible nodes, initialize if necessary\r\n  );\r\n\r\n  // Determines which direction to use when advancing nodes during an incremental search.\r\n  TVTSearchDirection = (\r\n    sdForward,\r\n    sdBackward\r\n  );\r\n\r\n  // Determines where to start incremental searching for each key press.\r\n  TVTSearchStart = (\r\n    ssAlwaysStartOver,       // always use the first/last node (depending on direction) to search from\r\n    ssLastHit,               // use the last found node\r\n    ssFocusedNode            // use the currently focused node\r\n  );\r\n\r\n  // Determines how to use the align member of a node.\r\n  TVTNodeAlignment = (\r\n    naFromBottom,            // the align member specifies amount of units (usually pixels) from top border of the node\r\n    naFromTop,               // align is to be measured from bottom\r\n    naProportional           // align is to be measure in percent of the entire node height and relative to top\r\n  );\r\n\r\n  // Determines how to draw the selection rectangle used for draw selection.\r\n  TVTDrawSelectionMode = (\r\n    smDottedRectangle,       // same as DrawFocusRect\r\n    smBlendedRectangle       // alpha blending, uses special colors (see TVTColors)\r\n  );\r\n\r\n  // Determines for which purpose the cell paint event is called.\r\n  TVTCellPaintMode = (\r\n    cpmPaint,                // painting the cell\r\n    cpmGetContentMargin      // getting cell content margin\r\n  );\r\n\r\n  // Determines which sides of the cell content margin should be considered.\r\n  TVTCellContentMarginType = (\r\n    ccmtAllSides,            // consider all sides\r\n    ccmtTopLeftOnly,         // consider top margin and left margin only\r\n    ccmtBottomRightOnly      // consider bottom margin and right margin only\r\n  );\r\n\r\n  TClipboardFormats = class(TStringList)\r\n  private\r\n    FOwner: TBaseVirtualTree;\r\n  public\r\n    constructor Create(AOwner: TBaseVirtualTree); virtual;\r\n\r\n    function Add(const S: string): Integer; override;\r\n    procedure Insert(Index: Integer; const S: string); override;\r\n    property Owner: TBaseVirtualTree read FOwner;\r\n  end;\r\n\r\n  // ----- Event prototypes:\r\n\r\n  // node enumeration\r\n  TVTGetNodeProc = reference to procedure(Sender: TBaseVirtualTree; Node: PVirtualNode; Data: Pointer; var Abort: Boolean);\r\n  // node events\r\n  TVTChangingEvent = procedure(Sender: TBaseVirtualTree; Node: PVirtualNode; var Allowed: Boolean) of object;\r\n  TVTCheckChangingEvent = procedure(Sender: TBaseVirtualTree; Node: PVirtualNode; var NewState: TCheckState;\r\n    var Allowed: Boolean) of object;\r\n  TVTChangeEvent = procedure(Sender: TBaseVirtualTree; Node: PVirtualNode) of object;\r\n  TVTStructureChangeEvent = procedure(Sender: TBaseVirtualTree; Node: PVirtualNode; Reason: TChangeReason) of object;\r\n  TVTEditCancelEvent = procedure(Sender: TBaseVirtualTree; Column: TColumnIndex) of object;\r\n  TVTEditChangingEvent = procedure(Sender: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex;\r\n    var Allowed: Boolean) of object;\r\n  TVTEditChangeEvent = procedure(Sender: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex) of object;\r\n  TVTFreeNodeEvent = procedure(Sender: TBaseVirtualTree; Node: PVirtualNode) of object;\r\n  TVTFocusChangingEvent = procedure(Sender: TBaseVirtualTree; OldNode, NewNode: PVirtualNode; OldColumn,\r\n    NewColumn: TColumnIndex; var Allowed: Boolean) of object;\r\n  TVTFocusChangeEvent = procedure(Sender: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex) of object;\r\n  TVTAddToSelectionEvent = procedure(Sender: TBaseVirtualTree; Node: PVirtualNode) of object;\r\n  TVTRemoveFromSelectionEvent = procedure(Sender: TBaseVirtualTree; Node: PVirtualNode) of object;\r\n  TVTGetImageEvent = procedure(Sender: TBaseVirtualTree; Node: PVirtualNode; Kind: TVTImageKind; Column: TColumnIndex;\r\n    var Ghosted: Boolean; var ImageIndex: TImageIndex) of object;\r\n  TVTGetImageExEvent = procedure(Sender: TBaseVirtualTree; Node: PVirtualNode; Kind: TVTImageKind; Column: TColumnIndex;\r\n    var Ghosted: Boolean; var ImageIndex: TImageIndex; var ImageList: TCustomImageList) of object;\r\n  TVTGetImageTextEvent = procedure(Sender: TBaseVirtualTree; Node: PVirtualNode; Kind: TVTImageKind; Column: TColumnIndex;\r\n    var ImageText: string) of object;\r\n  TVTHotNodeChangeEvent = procedure(Sender: TBaseVirtualTree; OldNode, NewNode: PVirtualNode) of object;\r\n  TVTInitChildrenEvent = procedure(Sender: TBaseVirtualTree; Node: PVirtualNode; var ChildCount: Cardinal) of object;\r\n  TVTInitNodeEvent = procedure(Sender: TBaseVirtualTree; ParentNode, Node: PVirtualNode;\r\n    var InitialStates: TVirtualNodeInitStates) of object;\r\n  TVTPopupEvent = procedure(Sender: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex; const P: TPoint;\r\n    var AskParent: Boolean; var PopupMenu: TPopupMenu) of object;\r\n  TVTHelpContextEvent = procedure(Sender: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex;\r\n    var HelpContext: Integer) of object;\r\n  TVTCreateEditorEvent = procedure(Sender: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex;\r\n    out EditLink: IVTEditLink) of object;\r\n  TVTSaveTreeEvent = procedure(Sender: TBaseVirtualTree; Stream: TStream) of object;\r\n  TVTSaveNodeEvent = procedure(Sender: TBaseVirtualTree; Node: PVirtualNode; Stream: TStream) of object;\r\n\r\n  // header/column events\r\n  TVTHeaderClickEvent = procedure(Sender: TVTHeader; HitInfo: TVTHeaderHitInfo) of object;\r\n  TVTHeaderMouseEvent = procedure(Sender: TVTHeader; Button: TMouseButton; Shift: TShiftState; X, Y: Integer) of object;\r\n  TVTHeaderMouseMoveEvent = procedure(Sender: TVTHeader; Shift: TShiftState; X, Y: Integer) of object;\r\n  TVTBeforeHeaderHeightTrackingEvent = procedure(Sender: TVTHeader; Shift: TShiftState) of object;\r\n  TVTAfterHeaderHeightTrackingEvent = procedure(Sender: TVTHeader) of object;\r\n  TVTHeaderHeightTrackingEvent = procedure(Sender: TVTHeader; var P: TPoint; Shift: TShiftState; var Allowed: Boolean) of object;\r\n  TVTHeaderHeightDblClickResizeEvent = procedure(Sender: TVTHeader; var P: TPoint; Shift: TShiftState; var Allowed: Boolean) of object;\r\n  TVTHeaderNotifyEvent = procedure(Sender: TVTHeader; Column: TColumnIndex) of object;\r\n  TVTHeaderDraggingEvent = procedure(Sender: TVTHeader; Column: TColumnIndex; var Allowed: Boolean) of object;\r\n  TVTHeaderDraggedEvent = procedure(Sender: TVTHeader; Column: TColumnIndex; OldPosition: Integer) of object;\r\n  TVTHeaderDraggedOutEvent = procedure(Sender: TVTHeader; Column: TColumnIndex; DropPosition: TPoint) of object;\r\n  TVTHeaderPaintEvent = procedure(Sender: TVTHeader; HeaderCanvas: TCanvas; Column: TVirtualTreeColumn; R: TRect; Hover,\r\n    Pressed: Boolean; DropMark: TVTDropMarkMode) of object;\r\n  TVTHeaderPaintQueryElementsEvent = procedure(Sender: TVTHeader; var PaintInfo: THeaderPaintInfo;\r\n    var Elements: THeaderPaintElements) of object;\r\n  TVTAdvancedHeaderPaintEvent = procedure(Sender: TVTHeader; var PaintInfo: THeaderPaintInfo;\r\n    const Elements: THeaderPaintElements) of object;\r\n  TVTBeforeAutoFitColumnsEvent = procedure(Sender: TVTHeader; var SmartAutoFitType: TSmartAutoFitType) of object;\r\n  TVTBeforeAutoFitColumnEvent = procedure(Sender: TVTHeader; Column: TColumnIndex; var SmartAutoFitType: TSmartAutoFitType;\r\n    var Allowed: Boolean) of object;\r\n  TVTAfterAutoFitColumnEvent = procedure(Sender: TVTHeader; Column: TColumnIndex) of object;\r\n  TVTAfterAutoFitColumnsEvent = procedure(Sender: TVTHeader) of object;\r\n  TVTColumnClickEvent = procedure (Sender: TBaseVirtualTree; Column: TColumnIndex; Shift: TShiftState) of object;\r\n  TVTColumnDblClickEvent = procedure (Sender: TBaseVirtualTree; Column: TColumnIndex; Shift: TShiftState) of object;\r\n  TColumnChangeEvent = procedure(const Sender: TBaseVirtualTree; const Column: TColumnIndex; Visible: Boolean) of object;\r\n  TVTColumnWidthDblClickResizeEvent = procedure(Sender: TVTHeader; Column: TColumnIndex; Shift: TShiftState; P: TPoint;\r\n    var Allowed: Boolean) of object;\r\n  TVTBeforeColumnWidthTrackingEvent = procedure(Sender: TVTHeader; Column: TColumnIndex; Shift: TShiftState) of object;\r\n  TVTAfterColumnWidthTrackingEvent = procedure(Sender: TVTHeader; Column: TColumnIndex) of object;\r\n  TVTColumnWidthTrackingEvent = procedure(Sender: TVTHeader; Column: TColumnIndex; Shift: TShiftState; var TrackPoint: TPoint; P: TPoint;\r\n    var Allowed: Boolean) of object;\r\n  TVTGetHeaderCursorEvent = procedure(Sender: TVTHeader; var Cursor: HCURSOR) of object;\r\n  TVTBeforeGetMaxColumnWidthEvent = procedure(Sender: TVTHeader; Column: TColumnIndex; var UseSmartColumnWidth: Boolean) of object;\r\n  TVTAfterGetMaxColumnWidthEvent = procedure(Sender: TVTHeader; Column: TColumnIndex; var MaxWidth: Integer) of object;\r\n  TVTCanSplitterResizeColumnEvent = procedure(Sender: TVTHeader; P: TPoint; Column: TColumnIndex; var Allowed: Boolean) of object;\r\n  TVTCanSplitterResizeHeaderEvent = procedure(Sender: TVTHeader; P: TPoint; var Allowed: Boolean) of object;\r\n\r\n  // move, copy and node tracking events\r\n  TVTNodeMovedEvent = procedure(Sender: TBaseVirtualTree; Node: PVirtualNode) of object;\r\n  TVTNodeMovingEvent = procedure(Sender: TBaseVirtualTree; Node, Target: PVirtualNode;\r\n    var Allowed: Boolean) of object;\r\n  TVTNodeCopiedEvent = procedure(Sender: TBaseVirtualTree; Node: PVirtualNode) of object;\r\n  TVTNodeCopyingEvent = procedure(Sender: TBaseVirtualTree; Node, Target: PVirtualNode;\r\n    var Allowed: Boolean) of object;\r\n  TVTNodeClickEvent = procedure(Sender: TBaseVirtualTree; const HitInfo: THitInfo) of object;\r\n  TVTNodeHeightTrackingEvent = procedure(Sender: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex; Shift: TShiftState;\r\n    var TrackPoint: TPoint; P: TPoint; var Allowed: Boolean) of object;\r\n  TVTNodeHeightDblClickResizeEvent = procedure(Sender: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex;\r\n    Shift: TShiftState; P: TPoint; var Allowed: Boolean) of object;\r\n  TVTCanSplitterResizeNodeEvent = procedure(Sender: TBaseVirtualTree; P: TPoint; Node: PVirtualNode;\r\n    Column: TColumnIndex; var Allowed: Boolean) of object;\r\n\r\n  // drag'n drop/OLE events\r\n  TVTCreateDragManagerEvent = procedure(Sender: TBaseVirtualTree; out DragManager: IVTDragManager) of object;\r\n  TVTCreateDataObjectEvent = procedure(Sender: TBaseVirtualTree; out IDataObject: IDataObject) of object;\r\n  TVTDragAllowedEvent = procedure(Sender: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex;\r\n    var Allowed: Boolean) of object;\r\n  TVTDragOverEvent = procedure(Sender: TBaseVirtualTree; Source: TObject; Shift: TShiftState; State: TDragState;\r\n    Pt: TPoint; Mode: TDropMode; var Effect: Integer; var Accept: Boolean) of object;\r\n  TVTDragDropEvent = procedure(Sender: TBaseVirtualTree; Source: TObject; DataObject: IDataObject;\r\n    Formats: TFormatArray; Shift: TShiftState; Pt: TPoint; var Effect: Integer; Mode: TDropMode) of object;\r\n  TVTRenderOLEDataEvent = procedure(Sender: TBaseVirtualTree; const FormatEtcIn: TFormatEtc; out Medium: TStgMedium;\r\n    ForClipboard: Boolean; var Result: HRESULT) of object;\r\n  TVTGetUserClipboardFormatsEvent = procedure(Sender: TBaseVirtualTree; var Formats: TFormatEtcArray) of object;\r\n\r\n  // paint events\r\n  TVTBeforeItemEraseEvent = procedure(Sender: TBaseVirtualTree; TargetCanvas: TCanvas; Node: PVirtualNode; ItemRect: TRect;\r\n    var ItemColor: TColor; var EraseAction: TItemEraseAction) of object;\r\n  TVTAfterItemEraseEvent = procedure(Sender: TBaseVirtualTree; TargetCanvas: TCanvas; Node: PVirtualNode;\r\n    ItemRect: TRect) of object;\r\n  TVTBeforeItemPaintEvent = procedure(Sender: TBaseVirtualTree; TargetCanvas: TCanvas; Node: PVirtualNode;\r\n    ItemRect: TRect; var CustomDraw: Boolean) of object;\r\n  TVTAfterItemPaintEvent = procedure(Sender: TBaseVirtualTree; TargetCanvas: TCanvas; Node: PVirtualNode;\r\n    ItemRect: TRect) of object;\r\n  TVTBeforeCellPaintEvent = procedure(Sender: TBaseVirtualTree; TargetCanvas: TCanvas; Node: PVirtualNode;\r\n    Column: TColumnIndex; CellPaintMode: TVTCellPaintMode; CellRect: TRect; var ContentRect: TRect) of object;\r\n  TVTAfterCellPaintEvent = procedure(Sender: TBaseVirtualTree; TargetCanvas: TCanvas; Node: PVirtualNode;\r\n    Column: TColumnIndex; CellRect: TRect) of object;\r\n  TVTPaintEvent = procedure(Sender: TBaseVirtualTree; TargetCanvas: TCanvas) of object;\r\n  TVTBackgroundPaintEvent = procedure(Sender: TBaseVirtualTree; TargetCanvas: TCanvas; R: TRect;\r\n    var Handled: Boolean) of object;\r\n  TVTGetLineStyleEvent = procedure(Sender: TBaseVirtualTree; var Bits: Pointer) of object;\r\n  TVTMeasureItemEvent = procedure(Sender: TBaseVirtualTree; TargetCanvas: TCanvas; Node: PVirtualNode;\r\n    var NodeHeight: Integer) of object;\r\n\r\n  TVTPrepareButtonImagesEvent = procedure(Sender: TBaseVirtualTree; const APlusBM : TBitmap; const APlusHotBM :TBitmap;\r\n                                          const APlusSelectedHotBM :TBitmap; const AMinusBM : TBitmap; const AMinusHotBM : TBitmap;\r\n                                          const AMinusSelectedHotBM :TBitmap; var ASize : TSize) of object;\r\n\r\n  // search, sort\r\n  TVTCompareEvent = procedure(Sender: TBaseVirtualTree; Node1, Node2: PVirtualNode; Column: TColumnIndex;\r\n    var Result: Integer) of object;\r\n  TVTIncrementalSearchEvent = procedure(Sender: TBaseVirtualTree; Node: PVirtualNode; const SearchText: string;\r\n    var Result: Integer) of object;\r\n\r\n  // operations\r\n  TVTOperationEvent = procedure(Sender: TBaseVirtualTree; OperationKind: TVTOperationKind) of object;\r\n\r\n  TVTHintKind = (vhkText, vhkOwnerDraw);\r\n  TVTHintKindEvent = procedure(Sender: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex; var Kind: TVTHintKind) of object;\r\n  TVTDrawHintEvent = procedure(Sender: TBaseVirtualTree; HintCanvas: TCanvas; Node: PVirtualNode; R: TRect; Column: TColumnIndex) of object;\r\n  TVTGetHintSizeEvent = procedure(Sender: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex; var R: TRect) of object;\r\n\r\n  // miscellaneous\r\n  TVTBeforeDrawLineImageEvent = procedure(Sender: TBaseVirtualTree; Node: PVirtualNode; Level: Integer; var PosX: Integer) of object;\r\n  TVTGetNodeDataSizeEvent = procedure(Sender: TBaseVirtualTree; var NodeDataSize: Integer) of object;\r\n  TVTKeyActionEvent = procedure(Sender: TBaseVirtualTree; var CharCode: Word; var Shift: TShiftState;\r\n    var DoDefault: Boolean) of object;\r\n  TVTScrollEvent = procedure(Sender: TBaseVirtualTree; DeltaX, DeltaY: Integer) of object;\r\n  TVTUpdatingEvent = procedure(Sender: TBaseVirtualTree; State: TVTUpdateState) of object;\r\n  TVTGetCursorEvent = procedure(Sender: TBaseVirtualTree; var Cursor: TCursor) of object;\r\n  TVTStateChangeEvent = procedure(Sender: TBaseVirtualTree; Enter, Leave: TVirtualTreeStates) of object;\r\n  TVTGetCellIsEmptyEvent = procedure(Sender: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex;\r\n    var IsEmpty: Boolean) of object;\r\n  TVTScrollBarShowEvent = procedure(Sender: TBaseVirtualTree; Bar: Integer; Show: Boolean) of object;\r\n\r\n  // Helper types for node iterations.\r\n  TGetFirstNodeProc = function: PVirtualNode of object;\r\n  TGetNextNodeProc = function(Node: PVirtualNode; ConsiderChildrenAbove: Boolean = False): PVirtualNode of object;\r\n\r\n  TVZVirtualNodeEnumerationMode = (\r\n    vneAll,\r\n    vneChecked,\r\n    vneChild,\r\n    vneCutCopy,\r\n    vneInitialized,\r\n    vneLeaf,\r\n    vneLevel,\r\n    vneNoInit,\r\n    vneSelected,\r\n    vneVisible,\r\n    vneVisibleChild,\r\n    vneVisibleNoInitChild,\r\n    vneVisibleNoInit\r\n  );\r\n\r\n  PVTVirtualNodeEnumeration = ^TVTVirtualNodeEnumeration;\r\n\r\n  TVTVirtualNodeEnumerator = record\r\n  private\r\n    FNode: PVirtualNode;\r\n    FCanModeNext: Boolean;\r\n    FEnumeration: PVTVirtualNodeEnumeration;\r\n    function GetCurrent: PVirtualNode; inline;\r\n  public\r\n    function MoveNext: Boolean; inline;\r\n    property Current: PVirtualNode read GetCurrent;\r\n  end;\r\n\r\n  TVTVirtualNodeEnumeration = record\r\n  private\r\n    FMode: TVZVirtualNodeEnumerationMode;\r\n    FTree: TBaseVirtualTree;\r\n    // GetNextXxx parameters:\r\n    FConsiderChildrenAbove: Boolean;\r\n    FNode: PVirtualNode;\r\n    FNodeLevel: Cardinal;\r\n    FState: TCheckState;\r\n    FIncludeFiltered: Boolean;\r\n  public\r\n    function GetEnumerator: TVTVirtualNodeEnumerator;\r\n  private\r\n    function GetNext(Node: PVirtualNode): PVirtualNode;\r\n  end;\r\n\r\n\r\n  // ----- TBaseVirtualTree\r\n  TBaseVirtualTree = class(TCustomControl)\r\n  private\r\n    FTotalInternalDataSize: Cardinal;            // Cache of the sum of the necessary internal data size for all tree\r\n    FBorderStyle: TBorderStyle;\r\n    FHeader: TVTHeader;\r\n    FRoot: PVirtualNode;\r\n    FDefaultNodeHeight,\r\n    FIndent: Cardinal;\r\n    FOptions: TCustomVirtualTreeOptions;\r\n    FUpdateCount: Cardinal;                      // update stopper, updates of the tree control are only done if = 0\r\n    FSynchUpdateCount: Cardinal;                 // synchronizer, causes all events which are usually done via timers\r\n                                                 // to happen immediately, regardless of the normal update state\r\n    FNodeDataSize: Integer;                      // number of bytes to allocate with each node (in addition to its base\r\n                                                 // structure and the internal data), if -1 then do callback\r\n    FStates: TVirtualTreeStates;                 // various active/pending states the tree needs to consider\r\n    FLastSelected,\r\n    FFocusedNode: PVirtualNode;\r\n    FEditColumn,                                 // column to be edited (focused node)\r\n    FFocusedColumn: TColumnIndex;                // NoColumn if no columns are active otherwise the last hit column of\r\n                                                 // the currently focused node\r\n    FHeightTrackPoint: TPoint;                   // Starting point of a node's height changing operation.\r\n    FHeightTrackNode: PVirtualNode;              // Node which height is being changed.\r\n    FHeightTrackColumn: TColumnIndex;            // Initial column where the height changing operation takes place.\r\n    FScrollDirections: TScrollDirections;        // directions to scroll client area into depending on mouse position\r\n    FLastStructureChangeReason: TChangeReason;   // Used for delayed structure change event.\r\n    FLastStructureChangeNode,                    // dito\r\n    FLastChangedNode,                            // used for delayed change event\r\n    FCurrentHotNode: PVirtualNode;               // Node over which the mouse is hovering.\r\n    FCurrentHotColumn: TColumnIndex;             // Column over which the mouse is hovering.\r\n    FHotNodeButtonHit: Boolean;                  // Indicates wether the mouse is hovering over the hot node's button.\r\n    FLastSelRect,\r\n    FNewSelRect: TRect;                          // used while doing draw selection\r\n    FHotCursor: TCursor;                         // can be set to additionally indicate the current hot node\r\n    FAnimationType: THintAnimationType;          // none, fade in, slide in animation (just like those animations used\r\n                                                 // in Win98 (slide) and Windows 2000 (fade))\r\n    FHintMode: TVTHintMode;                      // determines the kind of the hint window\r\n    FHintData: TVTHintData;                      // used while preparing the hint window\r\n    FChangeDelay: Cardinal;                      // used to delay OnChange event\r\n    FEditDelay: Cardinal;                        // determines time to elapse before a node goes into edit mode\r\n    FPositionCache: TCache;                      // array which stores node references ordered by vertical positions\r\n                                                 // (see also DoValidateCache for more information)\r\n    FVisibleCount: Cardinal;                     // number of currently visible nodes\r\n    FStartIndex: Cardinal;                       // index to start validating cache from\r\n    FSelection: TNodeArray;                      // list of currently selected nodes\r\n    FSelectionCount: Integer;                    // number of currently selected nodes (size of FSelection might differ)\r\n    FSelectionLocked: Boolean;                   // prevents the tree from changing the selection \r\n    FRangeAnchor: PVirtualNode;                  // anchor node for selection with the keyboard, determines start of a\r\n                                                 // selection range\r\n    FCheckNode: PVirtualNode;                    // node which \"captures\" a check event\r\n    FPendingCheckState: TCheckState;             // the new state the check node will get if all went fine\r\n    FCheckPropagationCount: Cardinal;            // nesting level of check propagation (WL, 05.02.2004)\r\n    FLastSelectionLevel: Integer;                // keeps the last node level for constrained multiselection\r\n    FDrawSelShiftState: TShiftState;             // keeps the initial shift state when the user starts selection with\r\n                                                 // the mouse\r\n    FEditLink: IVTEditLink;                      // used to comunicate with an application defined editor\r\n    FTempNodeCache: TNodeArray;                  // used at various places to hold temporarily a bunch of node refs.\r\n    FTempNodeCount: Cardinal;                    // number of nodes in FTempNodeCache\r\n    FBackground: TPicture;                       // A background image loadable at design and runtime.\r\n    FMargin: Integer;                            // horizontal border distance\r\n    FTextMargin: Integer;                        // space between the node's text and its horizontal bounds\r\n    FBackgroundOffsetX,\r\n    FBackgroundOffsetY: Integer;                 // used to fine tune the position of the background image\r\n    FAnimationDuration: Cardinal;                // specifies how long an animation shall take (expanding, hint)\r\n    FWantTabs: Boolean;                          // If True then the tree also consumes the tab key.\r\n    FNodeAlignment: TVTNodeAlignment;            // determines how to interpret the align member of a node\r\n    FHeaderRect: TRect;                          // Space which the header currently uses in the control (window coords).\r\n    FLastHintRect: TRect;                        // Area which the mouse must leave to reshow a hint.\r\n    FUpdateRect: TRect;\r\n    FEmptyListMessage: string;            // Optional message that will be displayed if no nodes exist in the control.\r\n\r\n    // paint support and images\r\n    FPlusBM,\r\n    FMinusBM,                                    // small bitmaps used for tree buttons\r\n    FHotPlusBM,\r\n    FHotMinusBM,\r\n    FSelectedHotPlusBM,\r\n    FSelectedHotMinusBM: TBitmap;                // small bitmaps used for hot tree buttons\r\n    FImages,                                     // normal images in the tree\r\n    FStateImages,                                // state images in the tree\r\n    FCustomCheckImages: TCustomImageList;        // application defined check images\r\n    FCheckImageKind: TCheckImageKind;            // light or dark, cross marks or tick marks\r\n    FCheckImages: TCustomImageList;              // Reference to global image list to be used for the check images.\r\n    FImageChangeLink,\r\n    FStateChangeLink,\r\n    FCustomCheckChangeLink: TChangeLink;         // connections to the image lists\r\n    FOldFontChange: TNotifyEvent;                // helper method pointer for tracking font changes in the off screen buffer\r\n    FColors: TVTColors;                          // class comprising all customizable colors in the tree\r\n    FButtonStyle: TVTButtonStyle;                // style of the tree buttons\r\n    FButtonFillMode: TVTButtonFillMode;          // for rectangular tree buttons only: how to fill them\r\n    FLineStyle: TVTLineStyle;                    // style of the tree lines\r\n    FLineMode: TVTLineMode;                      // tree lines or bands etc.\r\n    FDottedBrush: HBRUSH;                        // used to paint dotted lines without special pens\r\n    FSelectionCurveRadius: Cardinal;             // radius for rounded selection rectangles\r\n    FSelectionBlendFactor: Byte;                 // Determines the factor by which the selection rectangle is to be\r\n                                                 // faded if enabled.\r\n    FDrawSelectionMode: TVTDrawSelectionMode;    // determines the paint mode for draw selection\r\n\r\n    // alignment and directionality support\r\n    FAlignment: TAlignment;                      // default alignment of the tree if no columns are shown\r\n\r\n    // drag'n drop and clipboard support\r\n    FDragImageKind: TVTDragImageKind;            // determines whether or not and what to show in the drag image\r\n    FDragOperations: TDragOperations;            // determines which operations are allowed during drag'n drop\r\n    FDragThreshold: Integer;                     // used to determine when to actually start a drag'n drop operation\r\n    FDragManager: IVTDragManager;                // drag'n drop, cut'n paste\r\n    FDropTargetNode: PVirtualNode;               // node currently selected as drop target\r\n    FLastDropMode: TDropMode;                    // set while dragging and used to track changes\r\n    FDragSelection: TNodeArray;                  // temporary copy of FSelection used during drag'n drop\r\n    FLastDragEffect: Integer;                    // The last executed drag effect\r\n    FDragType: TVTDragType;                      // used to switch between OLE and VCL drag'n drop\r\n    FDragImage: TVTDragImage;                    // drag image management\r\n    FDragWidth,\r\n    FDragHeight: Integer;                        // size of the drag image, the larger the more CPU power is needed\r\n    FClipboardFormats: TClipboardFormats;        // a list of clipboard format descriptions enabled for this tree\r\n    FLastVCLDragTarget: PVirtualNode;            // A node cache for VCL drag'n drop (keywords: DragLeave on DragDrop).\r\n    FVCLDragEffect: Integer;                     // A cache for VCL drag'n drop to keep the current drop effect.\r\n\r\n    // scroll support\r\n    FScrollBarOptions: TScrollBarOptions;        // common properties of horizontal and vertical scrollbar\r\n    FAutoScrollInterval: TAutoScrollInterval;    // determines speed of auto scrolling\r\n    FAutoScrollDelay: Cardinal;                  // amount of milliseconds to wait until autoscrolling becomes active\r\n    FAutoExpandDelay: Cardinal;                  // amount of milliseconds to wait until a node is expanded if it is the\r\n                                                 // drop target\r\n    FOffsetX: Integer;\r\n    FOffsetY: Integer;                           // Determines left and top scroll offset.\r\n    FEffectiveOffsetX: Integer;                  // Actual position of the horizontal scroll bar (varies depending on bidi mode).\r\n    FRangeX,\r\n    FRangeY: Cardinal;                           // current virtual width and height of the tree\r\n    FBottomSpace: Cardinal;                      // Extra space below the last node.\r\n\r\n    FDefaultPasteMode: TVTNodeAttachMode;        // Used to determine where to add pasted nodes to.\r\n    FSingletonNodeArray: TNodeArray;             // Contains only one element for quick addition of single nodes\r\n                                                 // to the selection.\r\n    FDragScrollStart: Cardinal;                  // Contains the start time when a tree does auto scrolling as drop target.\r\n\r\n    // search\r\n    FIncrementalSearch: TVTIncrementalSearch;    // Used to determine whether and how incremental search is to be used.\r\n    FSearchTimeout: Cardinal;                    // Number of milliseconds after which to stop incremental searching.\r\n    FSearchBuffer: string;                 // Collects a sequence of keypresses used to do incremental searching.\r\n    FLastSearchNode: PVirtualNode;               // Reference to node which was last found as search fit.\r\n    FSearchDirection: TVTSearchDirection;        // Direction to incrementally search the tree.\r\n    FSearchStart: TVTSearchStart;                // Where to start iteration on each key press.\r\n\r\n    // miscellanous\r\n    FPanningWindow: HWND;                        // Helper window for wheel panning\r\n    FPanningCursor: HCURSOR;                     // Current wheel panning cursor.\r\n    FPanningImage: TBitmap;                      // A little 32x32 bitmap to indicate the panning reference point.\r\n    FLastClickPos: TPoint;                       // Used for retained drag start and wheel mouse scrolling.\r\n    FOperationCount: Cardinal;                   // Counts how many nested long-running operations are in progress.\r\n    FOperationCanceled: Boolean;                 // Used to indicate that a long-running operation should be canceled.\r\n    FChangingTheme: Boolean;                     // Used to indicate that a theme change is goi ng on\r\n    FNextNodeToSelect: PVirtualNode;             // Next tree node that we would like to select if the current one gets deleted or looses selection for other reasons.\r\n\r\n    // MSAA support\r\n    FAccessible: IAccessible;                    // The IAccessible interface to the window itself.\r\n    FAccessibleItem: IAccessible;                // The IAccessible to the item that currently has focus.\r\n    FAccessibleName: string;                     // The name the window is given for screen readers.\r\n\r\n    // export\r\n    FOnBeforeNodeExport: TVTNodeExportEvent;     // called before exporting a node\r\n    FOnNodeExport: TVTNodeExportEvent;\r\n    FOnAfterNodeExport: TVTNodeExportEvent;      // called after exporting a node\r\n    FOnBeforeColumnExport: TVTColumnExportEvent; // called before exporting a column\r\n    FOnColumnExport: TVTColumnExportEvent;\r\n    FOnAfterColumnExport: TVTColumnExportEvent;  // called after  exporting a column\r\n    FOnBeforeTreeExport: TVTTreeExportEvent;     // called before starting the export\r\n    FOnAfterTreeExport: TVTTreeExportEvent;      // called after finishing the export\r\n    FOnBeforeHeaderExport: TVTTreeExportEvent;   // called before exporting the header\r\n    FOnAfterHeaderExport: TVTTreeExportEvent;    // called after exporting the header\r\n\r\n    // common events\r\n    FOnChange: TVTChangeEvent;                   // selection change\r\n    FOnStructureChange: TVTStructureChangeEvent; // structural change like adding nodes etc.\r\n    FOnInitChildren: TVTInitChildrenEvent;       // called when a node's children are needed (expanding etc.)\r\n    FOnInitNode: TVTInitNodeEvent;               // called when a node needs to be initialized (child count etc.)\r\n    FOnFreeNode: TVTFreeNodeEvent;               // called when a node is about to be destroyed, user data can and should\r\n                                                 // be freed in this event\r\n    FOnGetImage: TVTGetImageEvent;               // Used to retrieve the image index of a given node.\r\n    FOnGetImageEx: TVTGetImageExEvent;           // Used to retrieve the image index of a given node along with a custom\r\n                                                 // image list.\r\n    FOnGetImageText: TVTGetImageTextEvent;       // Used to retrieve the image alternative text of a given node.\r\n                                                 // Used by the accessibility interface to provide useful text for status images.\r\n    FOnHotChange: TVTHotNodeChangeEvent;         // called when the current \"hot\" node (that is, the node under the mouse)\r\n                                                 // changes and hot tracking is enabled\r\n    FOnExpanding,                                // called just before a node is expanded\r\n    FOnCollapsing: TVTChangingEvent;             // called just before a node is collapsed\r\n    FOnChecking: TVTCheckChangingEvent;          // called just before a node's check state is changed\r\n    FOnExpanded,                                 // called after a node has been expanded\r\n    FOnCollapsed,                                // called after a node has been collapsed\r\n    FOnChecked: TVTChangeEvent;                  // called after a node's check state has been changed\r\n    FOnResetNode: TVTChangeEvent;                // called when a node is set to be uninitialized\r\n    FOnNodeMoving: TVTNodeMovingEvent;           // called just before a node is moved from one parent node to another\r\n                                                 // (this can be cancelled)\r\n    FOnNodeMoved: TVTNodeMovedEvent;             // called after a node and its children have been moved to another\r\n                                                 // parent node (probably another tree, but within the same application)\r\n    FOnNodeCopying: TVTNodeCopyingEvent;         // called when a node is copied to another parent node (probably in\r\n                                                 // another tree, but within the same application, can be cancelled)\r\n    FOnNodeClick: TVTNodeClickEvent;             // called when the user clicks on a node\r\n    FOnNodeDblClick: TVTNodeClickEvent;          // called when the user double clicks on a node\r\n    FOnCanSplitterResizeNode: TVTCanSplitterResizeNodeEvent;       // called to query the application wether resizing a node is allowed\r\n    FOnNodeHeightTracking: TVTNodeHeightTrackingEvent;             // called when a node's height is being changed via mouse\r\n    FOnNodeHeightDblClickResize: TVTNodeHeightDblClickResizeEvent; // called when a node's vertical splitter is double clicked\r\n    FOnNodeCopied: TVTNodeCopiedEvent;           // call after a node has been copied\r\n    FOnEditing: TVTEditChangingEvent;            // called just before a node goes into edit mode\r\n    FOnEditCancelled: TVTEditCancelEvent;        // called when editing has been cancelled\r\n    FOnEdited: TVTEditChangeEvent;               // called when editing has successfully been finished\r\n    FOnFocusChanging: TVTFocusChangingEvent;     // called when the focus is about to go to a new node and/or column\r\n                                                 // (can be cancelled)\r\n    FOnFocusChanged: TVTFocusChangeEvent;        // called when the focus goes to a new node and/or column\r\n    FOnAddToSelection: TVTAddToSelectionEvent;           // called when a node is added to the selection\r\n    FOnRemoveFromSelection: TVTRemoveFromSelectionEvent; // called when a node is removed from the selection\r\n    FOnGetPopupMenu: TVTPopupEvent;              // called when the popup for a node or the header needs to be shown\r\n    FOnGetHelpContext: TVTHelpContextEvent;      // called when a node specific help theme should be called\r\n    FOnCreateEditor: TVTCreateEditorEvent;       // called when a node goes into edit mode, this allows applications\r\n                                                 // to supply their own editor\r\n    FOnLoadNode,                                 // called after a node has been loaded from a stream (file, clipboard,\r\n                                                 // OLE drag'n drop) to allow an application to load their own data\r\n                                                 // saved in OnSaveNode\r\n    FOnSaveNode: TVTSaveNodeEvent;               // called when a node needs to be serialized into a stream\r\n                                                 // (see OnLoadNode) to give the application the opportunity to save\r\n                                                 // their node specific, persistent data (note: never save memory\r\n                                                 // references)\r\n    FOnLoadTree,                                 // called after the tree has been loaded from a stream to allow an\r\n                                                 // application to load their own data saved in OnSaveTree\r\n    FOnSaveTree: TVTSaveTreeEvent;               // called after the tree has been saved to a stream to allow an\r\n                                                 // application to save its own data\r\n\r\n    // header/column mouse events\r\n    FOnAfterAutoFitColumn: TVTAfterAutoFitColumnEvent;\r\n    FOnAfterAutoFitColumns: TVTAfterAutoFitColumnsEvent;\r\n    FOnBeforeAutoFitColumns: TVTBeforeAutoFitColumnsEvent;\r\n    FOnBeforeAutoFitColumn: TVTBeforeAutoFitColumnEvent;\r\n    FOnHeaderClick: TVTHeaderClickEvent;\r\n    FOnHeaderDblClick: TVTHeaderClickEvent;\r\n    FOnAfterHeaderHeightTracking: TVTAfterHeaderHeightTrackingEvent;\r\n    FOnBeforeHeaderHeightTracking: TVTBeforeHeaderHeightTrackingEvent;\r\n    FOnHeaderHeightTracking: TVTHeaderHeightTrackingEvent;\r\n    FOnHeaderHeightDblClickResize: TVTHeaderHeightDblClickResizeEvent;\r\n    FOnHeaderMouseDown,\r\n    FOnHeaderMouseUp: TVTHeaderMouseEvent;\r\n    FOnHeaderMouseMove: TVTHeaderMouseMoveEvent;\r\n    FOnAfterGetMaxColumnWidth: TVTAfterGetMaxColumnWidthEvent;\r\n    FOnBeforeGetMaxColumnWidth: TVTBeforeGetMaxColumnWidthEvent;\r\n    FOnColumnClick: TVTColumnClickEvent;\r\n    FOnColumnDblClick: TVTColumnDblClickEvent;\r\n    FOnColumnResize: TVTHeaderNotifyEvent;\r\n    fOnColumnVisibilityChanged: TColumnChangeEvent;\r\n    FOnColumnWidthDblClickResize: TVTColumnWidthDblClickResizeEvent;\r\n    FOnAfterColumnWidthTracking: TVTAfterColumnWidthTrackingEvent;\r\n    FOnBeforeColumnWidthTracking: TVTBeforeColumnWidthTrackingEvent;\r\n    FOnColumnWidthTracking: TVTColumnWidthTrackingEvent;\r\n    FOnGetHeaderCursor: TVTGetHeaderCursorEvent; // triggered to allow the app. to use customized cursors for the header\r\n    FOnCanSplitterResizeColumn: TVTCanSplitterResizeColumnEvent;\r\n    FOnCanSplitterResizeHeader: TVTCanSplitterResizeHeaderEvent;\r\n\r\n    // paint events\r\n    FOnAfterPaint,                               // triggered when the tree has entirely been painted\r\n    FOnBeforePaint: TVTPaintEvent;               // triggered when the tree is about to be painted\r\n    FOnAfterItemPaint: TVTAfterItemPaintEvent;   // triggered after an item has been painted\r\n    FOnBeforeItemPaint: TVTBeforeItemPaintEvent; // triggered when an item is about to be painted\r\n    FOnBeforeItemErase: TVTBeforeItemEraseEvent; // triggered when an item's background is about to be erased\r\n    FOnAfterItemErase: TVTAfterItemEraseEvent;   // triggered after an item's background has been erased\r\n    FOnAfterCellPaint: TVTAfterCellPaintEvent;   // triggered after a column of an item has been painted\r\n    FOnBeforeCellPaint: TVTBeforeCellPaintEvent; // triggered when a column of an item is about to be painted\r\n    FOnHeaderDraw: TVTHeaderPaintEvent;          // Used when owner draw is enabled for the header and a column is set\r\n                                                 // to owner draw mode.\r\n    FOnPrepareButtonImages : TVTPrepareButtonImagesEvent; //allow use to customise plus/minus bitmap images\r\n    FOnHeaderDrawQueryElements: TVTHeaderPaintQueryElementsEvent; // Used for advanced header painting to query the\r\n                                                 // application for the elements, which are drawn by it and which should\r\n                                                 // be drawn by the tree.\r\n    FOnAdvancedHeaderDraw: TVTAdvancedHeaderPaintEvent; // Used when owner draw is enabled for the header and a column\r\n                                                 // is set to owner draw mode. But only if OnHeaderDrawQueryElements\r\n                                                 // returns at least one element to be drawn by the application.\r\n                                                 // In this case OnHeaderDraw is not used.\r\n    FOnGetLineStyle: TVTGetLineStyleEvent;       // triggered when a custom line style is used and the pattern brush\r\n                                                 // needs to be build\r\n    FOnPaintBackground: TVTBackgroundPaintEvent; // triggered if a part of the tree's background must be erased which is\r\n                                                 // not covered by any node\r\n    FOnMeasureItem: TVTMeasureItemEvent;         // Triggered when a node is about to be drawn and its height was not yet\r\n                                                 // determined by the application.\r\n\r\n    // drag'n drop events\r\n    FOnCreateDragManager: TVTCreateDragManagerEvent; // called to allow for app./descendant defined drag managers\r\n    FOnCreateDataObject: TVTCreateDataObjectEvent; // called to allow for app./descendant defined data objects\r\n    FOnDragAllowed: TVTDragAllowedEvent;         // used to get permission for manual drag in mouse down\r\n    FOnDragOver: TVTDragOverEvent;               // called for every mouse move\r\n    FOnDragDrop: TVTDragDropEvent;               // called on release of mouse button (if drop was allowed)\r\n    FOnHeaderDragged: TVTHeaderDraggedEvent;     // header (column) drag'n drop\r\n    FOnHeaderDraggedOut: TVTHeaderDraggedOutEvent; // header (column) drag'n drop, which did not result in a valid drop.\r\n    FOnHeaderDragging: TVTHeaderDraggingEvent;   // header (column) drag'n drop\r\n    FOnRenderOLEData: TVTRenderOLEDataEvent;     // application/descendant defined clipboard formats\r\n    FOnGetUserClipboardFormats: TVTGetUserClipboardFormatsEvent; // gives application/descendants the opportunity to\r\n                                                 // add own clipboard formats on the fly\r\n\r\n    // miscellanous events\r\n    FOnGetNodeDataSize: TVTGetNodeDataSizeEvent; // Called if NodeDataSize is -1.\r\n    FOnBeforeDrawLineImage: TVTBeforeDrawLineImageEvent; // Called to allow adjusting the indention of treelines.\r\n    FOnKeyAction: TVTKeyActionEvent;             // Used to selectively prevent key actions (full expand on Ctrl+'+' etc.).\r\n    FOnScroll: TVTScrollEvent;                   // Called when one or both paint offsets changed.\r\n    FOnUpdating: TVTUpdatingEvent;               // Called from BeginUpdate, EndUpdate, BeginSynch and EndSynch.\r\n    FOnGetCursor: TVTGetCursorEvent;             // Called to allow the app. to set individual cursors.\r\n    FOnStateChange: TVTStateChangeEvent;         // Called whenever a state in the tree changes.\r\n    FOnGetCellIsEmpty: TVTGetCellIsEmptyEvent;   // Called when the tree needs to know if a cell is empty.\r\n    FOnShowScrollBar: TVTScrollBarShowEvent;     // Called when a scrollbar is changed in its visibility.\r\n\r\n    // search, sort\r\n    FOnCompareNodes: TVTCompareEvent;            // used during sort\r\n    FOnDrawHint: TVTDrawHintEvent;\r\n    FOnGetHintSize: TVTGetHintSizeEvent;\r\n    FOnGetHintKind: TVTHintKindEvent;\r\n    FOnIncrementalSearch: TVTIncrementalSearchEvent; // triggered on every key press (not key down)\r\n    FOnMouseEnter: TNotifyEvent;\r\n    FOnMouseLeave: TNotifyEvent;\r\n\r\n    // operations\r\n    FOnStartOperation: TVTOperationEvent;        // Called when an operation starts\r\n    FOnEndOperation: TVTOperationEvent;          // Called when an operation ends\r\n\r\n    FVclStyleEnabled: Boolean;\r\n\r\n    procedure CMStyleChanged(var Message: TMessage); message CM_STYLECHANGED;\r\n    procedure CMParentDoubleBufferedChange(var Message: TMessage); message CM_PARENTDOUBLEBUFFEREDCHANGED;\r\n\r\n    procedure AdjustCoordinatesByIndent(var PaintInfo: TVTPaintInfo; Indent: Integer);\r\n    procedure AdjustTotalCount(Node: PVirtualNode; Value: Integer; relative: Boolean = False);\r\n    procedure AdjustTotalHeight(Node: PVirtualNode; Value: Integer; relative: Boolean = False);\r\n    function CalculateCacheEntryCount: Integer;\r\n    procedure CalculateVerticalAlignments(ShowImages, ShowStateImages: Boolean; Node: PVirtualNode; var VAlign,\r\n      VButtonAlign: Integer);\r\n    function ChangeCheckState(Node: PVirtualNode; Value: TCheckState): Boolean;\r\n    function CollectSelectedNodesLTR(MainColumn, NodeLeft, NodeRight: Integer; Alignment: TAlignment; OldRect,\r\n      NewRect: TRect): Boolean;\r\n    function CollectSelectedNodesRTL(MainColumn, NodeLeft, NodeRight: Integer; Alignment: TAlignment; OldRect,\r\n      NewRect: TRect): Boolean;\r\n    procedure ClearNodeBackground(const PaintInfo: TVTPaintInfo; UseBackground, Floating: Boolean; R: TRect);\r\n    function CompareNodePositions(Node1, Node2: PVirtualNode; ConsiderChildrenAbove: Boolean = False): Integer;\r\n    procedure DrawLineImage(const PaintInfo: TVTPaintInfo; X, Y, H, VAlign: Integer; Style: TVTLineType; Reverse: Boolean);\r\n    function FindInPositionCache(Node: PVirtualNode; var CurrentPos: Cardinal): PVirtualNode; overload;\r\n    function FindInPositionCache(Position: Cardinal; var CurrentPos: Cardinal): PVirtualNode; overload;\r\n    procedure FixupTotalCount(Node: PVirtualNode);\r\n    procedure FixupTotalHeight(Node: PVirtualNode);\r\n    function GetBottomNode: PVirtualNode;\r\n    function GetCheckedCount: Integer;\r\n    function GetCheckState(Node: PVirtualNode): TCheckState;\r\n    function GetCheckType(Node: PVirtualNode): TCheckType;\r\n    function GetChildCount(Node: PVirtualNode): Cardinal;\r\n    function GetChildrenInitialized(Node: PVirtualNode): Boolean;\r\n    function GetCutCopyCount: Integer;\r\n    function GetDisabled(Node: PVirtualNode): Boolean;\r\n    function GetDragManager: IVTDragManager;\r\n    function GetExpanded(Node: PVirtualNode): Boolean;\r\n    function GetFiltered(Node: PVirtualNode): Boolean;\r\n    function GetFullyVisible(Node: PVirtualNode): Boolean;\r\n    function GetHasChildren(Node: PVirtualNode): Boolean;\r\n    function GetMultiline(Node: PVirtualNode): Boolean;\r\n    function GetNodeHeight(Node: PVirtualNode): Cardinal;\r\n    function GetNodeParent(Node: PVirtualNode): PVirtualNode;\r\n    function GetOffsetXY: TPoint;\r\n    function GetRootNodeCount: Cardinal;\r\n    function GetSelected(Node: PVirtualNode): Boolean;\r\n    function GetTopNode: PVirtualNode;\r\n    function GetTotalCount: Cardinal;\r\n    function GetVerticalAlignment(Node: PVirtualNode): Byte;\r\n    function GetVisible(Node: PVirtualNode): Boolean;\r\n    function GetVisiblePath(Node: PVirtualNode): Boolean;\r\n    procedure HandleClickSelection(LastFocused, NewNode: PVirtualNode; Shift: TShiftState; DragPending: Boolean);\r\n    function HandleDrawSelection(X, Y: Integer): Boolean;\r\n    function HasVisibleNextSibling(Node: PVirtualNode): Boolean;\r\n    function HasVisiblePreviousSibling(Node: PVirtualNode): Boolean;\r\n    procedure ImageListChange(Sender: TObject);\r\n    procedure InitializeFirstColumnValues(var PaintInfo: TVTPaintInfo);\r\n    procedure InitRootNode(OldSize: Cardinal = 0);\r\n    function IsFirstVisibleChild(Parent, Node: PVirtualNode): Boolean;\r\n    function IsLastVisibleChild(Parent, Node: PVirtualNode): Boolean;\r\n    function MakeNewNode: PVirtualNode;\r\n    function PackArray({*}const TheArray: TNodeArray; Count: Integer): Integer;\r\n    procedure PrepareBitmaps(NeedButtons, NeedLines: Boolean);\r\n    procedure ReadOldOptions(Reader: TReader);\r\n    procedure SetAlignment(const Value: TAlignment);\r\n    procedure SetAnimationDuration(const Value: Cardinal);\r\n    procedure SetBackground(const Value: TPicture);\r\n    procedure SetBackgroundOffset(const Index, Value: Integer);\r\n    procedure SetBorderStyle(Value: TBorderStyle);\r\n    procedure SetBottomNode(Node: PVirtualNode);\r\n    procedure SetBottomSpace(const Value: Cardinal);\r\n    procedure SetButtonFillMode(const Value: TVTButtonFillMode);\r\n    procedure SetButtonStyle(const Value: TVTButtonStyle);\r\n    procedure SetCheckImageKind(Value: TCheckImageKind);\r\n    procedure SetCheckState(Node: PVirtualNode; Value: TCheckState);\r\n    procedure SetCheckType(Node: PVirtualNode; Value: TCheckType);\r\n    procedure SetClipboardFormats(const Value: TClipboardFormats);\r\n    procedure SetColors(const Value: TVTColors);\r\n    procedure SetCustomCheckImages(const Value: TCustomImageList);\r\n    procedure SetDefaultNodeHeight(Value: Cardinal);\r\n    procedure SetDisabled(Node: PVirtualNode; Value: Boolean);\r\n    procedure SetEmptyListMessage(const Value: string);\r\n    procedure SetExpanded(Node: PVirtualNode; Value: Boolean);\r\n    procedure SetFocusedColumn(Value: TColumnIndex);\r\n    procedure SetFocusedNode(Value: PVirtualNode);\r\n    procedure SetFullyVisible(Node: PVirtualNode; Value: Boolean);\r\n    procedure SetHasChildren(Node: PVirtualNode; Value: Boolean);\r\n    procedure SetHeader(const Value: TVTHeader);\r\n    procedure SetFiltered(Node: PVirtualNode; Value: Boolean);\r\n    procedure SetImages(const Value: TCustomImageList);\r\n    procedure SetIndent(Value: Cardinal);\r\n    procedure SetLineMode(const Value: TVTLineMode);\r\n    procedure SetLineStyle(const Value: TVTLineStyle);\r\n    procedure SetMargin(Value: Integer);\r\n    procedure SetMultiline(Node: PVirtualNode; const Value: Boolean);\r\n    procedure SetNodeAlignment(const Value: TVTNodeAlignment);\r\n    procedure SetNodeDataSize(Value: Integer);\r\n    procedure SetNodeHeight(Node: PVirtualNode; Value: Cardinal);\r\n    procedure SetNodeParent(Node: PVirtualNode; const Value: PVirtualNode);\r\n    procedure SetOffsetX(const Value: Integer);\r\n    procedure SetOffsetXY(const Value: TPoint);\r\n    procedure SetOffsetY(const Value: Integer);\r\n    procedure SetOptions(const Value: TCustomVirtualTreeOptions);\r\n    procedure SetRootNodeCount(Value: Cardinal);\r\n    procedure SetScrollBarOptions(Value: TScrollBarOptions);\r\n    procedure SetSearchOption(const Value: TVTIncrementalSearch);\r\n    procedure SetSelected(Node: PVirtualNode; Value: Boolean);\r\n    procedure SetSelectionCurveRadius(const Value: Cardinal);\r\n    procedure SetStateImages(const Value: TCustomImageList);\r\n    procedure SetTextMargin(Value: Integer);\r\n    procedure SetTopNode(Node: PVirtualNode);\r\n    procedure SetUpdateState(Updating: Boolean);\r\n    procedure SetVerticalAlignment(Node: PVirtualNode; Value: Byte);\r\n    procedure SetVisible(Node: PVirtualNode; Value: Boolean);\r\n    procedure SetVisiblePath(Node: PVirtualNode; Value: Boolean);\r\n    procedure StaticBackground(Source: TBitmap; Target: TCanvas; OffsetPosition: TPoint; R: TRect);\r\n    procedure StopTimer(ID: Integer);\r\n    procedure SetWindowTheme(const Theme: string);\r\n    procedure TileBackground(Source: TBitmap; Target: TCanvas; Offset: TPoint; R: TRect);\r\n    function ToggleCallback(Step, StepSize: Integer; Data: Pointer): Boolean;\r\n\r\n    procedure CMColorChange(var Message: TMessage); message CM_COLORCHANGED;\r\n    procedure CMCtl3DChanged(var Message: TMessage); message CM_CTL3DCHANGED;\r\n    procedure CMBiDiModeChanged(var Message: TMessage); message CM_BIDIMODECHANGED;\r\n    procedure CMBorderChanged(var Message: TMessage); message CM_BORDERCHANGED;\r\n    procedure CMDenySubclassing(var Message: TMessage); message CM_DENYSUBCLASSING;\r\n    procedure CMDrag(var Message: TCMDrag); message CM_DRAG;\r\n    procedure CMEnabledChanged(var Message: TMessage); message CM_ENABLEDCHANGED;\r\n    procedure CMFontChanged(var Message: TMessage); message CM_FONTCHANGED;\r\n    procedure CMHintShow(var Message: TCMHintShow); message CM_HINTSHOW;\r\n    procedure CMHintShowPause(var Message: TCMHintShowPause); message CM_HINTSHOWPAUSE;\r\n    procedure CMMouseEnter(var Message: TMessage); message CM_MOUSEENTER;\r\n    procedure CMMouseLeave(var Message: TMessage); message CM_MOUSELEAVE;\r\n    procedure CMMouseWheel(var Message: TCMMouseWheel); message CM_MOUSEWHEEL;\r\n    procedure CMSysColorChange(var Message: TMessage); message CM_SYSCOLORCHANGE;\r\n    procedure TVMGetItem(var Message: TMessage); message TVM_GETITEM;\r\n    procedure TVMGetItemRect(var Message: TMessage); message TVM_GETITEMRECT;\r\n    procedure TVMGetNextItem(var Message: TMessage); message TVM_GETNEXTITEM;\r\n    procedure WMCancelMode(var Message: TWMCancelMode); message WM_CANCELMODE;\r\n    procedure WMChangeState(var Message: TMessage); message WM_CHANGESTATE;\r\n    procedure WMChar(var Message: TWMChar); message WM_CHAR;\r\n    procedure WMContextMenu(var Message: TWMContextMenu); message WM_CONTEXTMENU;\r\n    procedure WMCopy(var Message: TWMCopy); message WM_COPY;\r\n    procedure WMCut(var Message: TWMCut); message WM_CUT;\r\n    procedure WMEnable(var Message: TWMEnable); message WM_ENABLE;\r\n    procedure WMEraseBkgnd(var Message: TWMEraseBkgnd); message WM_ERASEBKGND;\r\n    procedure WMGetDlgCode(var Message: TWMGetDlgCode); message WM_GETDLGCODE;\r\n    procedure WMGetObject(var Message: TMessage); message WM_GETOBJECT;\r\n    procedure WMHScroll(var Message: TWMHScroll); message WM_HSCROLL;\r\n    procedure WMKeyDown(var Message: TWMKeyDown); message WM_KEYDOWN;\r\n    procedure WMKeyUp(var Message: TWMKeyUp); message WM_KEYUP;\r\n    procedure WMKillFocus(var Msg: TWMKillFocus); message WM_KILLFOCUS;\r\n    procedure WMLButtonDblClk(var Message: TWMLButtonDblClk); message WM_LBUTTONDBLCLK;\r\n    procedure WMLButtonDown(var Message: TWMLButtonDown); message WM_LBUTTONDOWN;\r\n    procedure WMLButtonUp(var Message: TWMLButtonUp); message WM_LBUTTONUP;\r\n    procedure WMMButtonDblClk(var Message: TWMMButtonDblClk); message WM_MBUTTONDBLCLK;\r\n    procedure WMMButtonDown(var Message: TWMMButtonDown); message WM_MBUTTONDOWN;\r\n    procedure WMMButtonUp(var Message: TWMMButtonUp); message WM_MBUTTONUP;\r\n    procedure WMNCCalcSize(var Message: TWMNCCalcSize); message WM_NCCALCSIZE;\r\n    procedure WMNCDestroy(var Message: TWMNCDestroy); message WM_NCDESTROY;\r\n    procedure WMNCHitTest(var Message: TWMNCHitTest); message WM_NCHITTEST;\r\n    procedure WMNCPaint(var Message: TWMNCPaint); message WM_NCPAINT;\r\n    procedure WMPaint(var Message: TWMPaint); message WM_PAINT;\r\n    procedure WMPaste(var Message: TWMPaste); message WM_PASTE;\r\n    procedure WMPrint(var Message: TWMPrint); message WM_PRINT;\r\n    procedure WMPrintClient(var Message: TWMPrintClient); message WM_PRINTCLIENT;\r\n    procedure WMRButtonDblClk(var Message: TWMRButtonDblClk); message WM_RBUTTONDBLCLK;\r\n    procedure WMRButtonDown(var Message: TWMRButtonDown); message WM_RBUTTONDOWN;\r\n    procedure WMRButtonUp(var Message: TWMRButtonUp); message WM_RBUTTONUP;\r\n    procedure WMSetCursor(var Message: TWMSetCursor); message WM_SETCURSOR;\r\n    procedure WMSetFocus(var Msg: TWMSetFocus); message WM_SETFOCUS;\r\n    procedure WMSize(var Message: TWMSize); message WM_SIZE;\r\n    procedure WMTimer(var Message: TWMTimer); message WM_TIMER;\r\n    procedure WMThemeChanged(var Message: TMessage); message WM_THEMECHANGED;\r\n    procedure WMVScroll(var Message: TWMVScroll); message WM_VSCROLL;\r\n    function GetRangeX: Cardinal;\r\n    function GetDoubleBuffered: Boolean;\r\n    procedure SetDoubleBuffered(const Value: Boolean);\r\n\r\n  protected\r\n    FFontChanged: Boolean;                       // flag for keeping informed about font changes in the off screen buffer   // [IPK] - private to protected\r\n    procedure AutoScale(); virtual;\r\n    procedure AddToSelection(Node: PVirtualNode); overload; virtual;\r\n    procedure AddToSelection(const NewItems: TNodeArray; NewLength: Integer; ForceInsert: Boolean = False); overload; virtual;\r\n    procedure AdjustImageBorder(Images: TCustomImageList; BidiMode: TBidiMode; VAlign: Integer; var R: TRect;\r\n      var ImageInfo: TVTImageInfo); virtual;\r\n    procedure AdjustPaintCellRect(var PaintInfo: TVTPaintInfo; var NextNonEmpty: TColumnIndex); virtual;\r\n    procedure AdjustPanningCursor(X, Y: Integer); virtual;\r\n    procedure AdviseChangeEvent(StructureChange: Boolean; Node: PVirtualNode; Reason: TChangeReason); virtual;\r\n    function AllocateInternalDataArea(Size: Cardinal): Cardinal; virtual;\r\n    procedure Animate(Steps, Duration: Cardinal; Callback: TVTAnimationCallback; Data: Pointer); virtual;\r\n    function CalculateSelectionRect(X, Y: Integer): Boolean; virtual;\r\n    function CanAutoScroll: Boolean; virtual;\r\n    function CanShowDragImage: Boolean; virtual;\r\n    function CanSplitterResizeNode(P: TPoint; Node: PVirtualNode; Column: TColumnIndex): Boolean;\r\n    procedure Change(Node: PVirtualNode); virtual;\r\n    procedure ChangeTreeStatesAsync(EnterStates, LeaveStates: TChangeStates);\r\n    procedure ChangeScale(M, D: Integer); override;\r\n    function CheckParentCheckState(Node: PVirtualNode; NewCheckState: TCheckState): Boolean; virtual;\r\n    procedure ClearTempCache; virtual;\r\n    function ColumnIsEmpty(Node: PVirtualNode; Column: TColumnIndex): Boolean; virtual;\r\n    function ComputeRTLOffset(ExcludeScrollBar: Boolean = False): Integer; virtual;\r\n    function CountLevelDifference(Node1, Node2: PVirtualNode): Integer; virtual;\r\n    function CountVisibleChildren(Node: PVirtualNode): Cardinal; virtual;\r\n    procedure CreateParams(var Params: TCreateParams); override;\r\n    procedure CreateWnd; override;\r\n    procedure DefineProperties(Filer: TFiler); override;\r\n    procedure DeleteNode(Node: PVirtualNode; Reindex: Boolean; ParentClearing: Boolean); overload;\r\n    function DetermineDropMode(const P: TPoint; var HitInfo: THitInfo; var NodeRect: TRect): TDropMode; virtual;\r\n    procedure DetermineHiddenChildrenFlag(Node: PVirtualNode); virtual;\r\n    procedure DetermineHiddenChildrenFlagAllNodes; virtual;\r\n    procedure DetermineHitPositionLTR(var HitInfo: THitInfo; Offset, Right: Integer; Alignment: TAlignment); virtual;\r\n    procedure DetermineHitPositionRTL(var HitInfo: THitInfo; Offset, Right: Integer; Alignment: TAlignment); virtual;\r\n    function DetermineLineImageAndSelectLevel(Node: PVirtualNode; var LineImage: TLineImage): Integer; virtual;\r\n    function DetermineNextCheckState(CheckType: TCheckType; CheckState: TCheckState): TCheckState; virtual;\r\n    function DetermineScrollDirections(X, Y: Integer): TScrollDirections; virtual;\r\n    procedure DoAdvancedHeaderDraw(var PaintInfo: THeaderPaintInfo; const Elements: THeaderPaintElements); virtual;\r\n    procedure DoAfterCellPaint(Canvas: TCanvas; Node: PVirtualNode; Column: TColumnIndex; CellRect: TRect); virtual;\r\n    procedure DoAfterItemErase(Canvas: TCanvas; Node: PVirtualNode; ItemRect: TRect); virtual;\r\n    procedure DoAfterItemPaint(Canvas: TCanvas; Node: PVirtualNode; ItemRect: TRect); virtual;\r\n    procedure DoAfterPaint(Canvas: TCanvas); virtual;\r\n    procedure DoAutoScroll(X, Y: Integer); virtual;\r\n    function DoBeforeDrag(Node: PVirtualNode; Column: TColumnIndex): Boolean; virtual;\r\n    procedure DoBeforeCellPaint(Canvas: TCanvas; Node: PVirtualNode; Column: TColumnIndex;\r\n      CellPaintMode: TVTCellPaintMode; CellRect: TRect; var ContentRect: TRect); virtual;\r\n    procedure DoBeforeItemErase(Canvas: TCanvas; Node: PVirtualNode; ItemRect: TRect; var Color: TColor;\r\n      var EraseAction: TItemEraseAction); virtual;\r\n    function DoBeforeItemPaint(Canvas: TCanvas; Node: PVirtualNode; ItemRect: TRect): Boolean; virtual;\r\n    procedure DoBeforePaint(Canvas: TCanvas); virtual;\r\n    function DoCancelEdit: Boolean; virtual;\r\n    procedure DoCanEdit(Node: PVirtualNode; Column: TColumnIndex; var Allowed: Boolean); virtual;\r\n    procedure DoCanSplitterResizeNode(P: TPoint; Node: PVirtualNode; Column: TColumnIndex;\r\n      var Allowed: Boolean); virtual;\r\n    procedure DoChange(Node: PVirtualNode); virtual;\r\n    procedure DoCheckClick(Node: PVirtualNode; NewCheckState: TCheckState); virtual;\r\n    procedure DoChecked(Node: PVirtualNode); virtual;\r\n    function DoChecking(Node: PVirtualNode; var NewCheckState: TCheckState): Boolean; virtual;\r\n    procedure DoCollapsed(Node: PVirtualNode); virtual;\r\n    function DoCollapsing(Node: PVirtualNode): Boolean; virtual;\r\n    procedure DoColumnClick(Column: TColumnIndex; Shift: TShiftState); virtual;\r\n    procedure DoColumnDblClick(Column: TColumnIndex; Shift: TShiftState); virtual;\r\n    procedure DoColumnResize(Column: TColumnIndex); virtual;\r\n    procedure DoColumnVisibilityChanged(const Column: TColumnIndex; Visible: Boolean);\r\n    function DoCompare(Node1, Node2: PVirtualNode; Column: TColumnIndex): Integer; virtual;\r\n    function DoCreateDataObject: IDataObject; virtual;\r\n    function DoCreateDragManager: IVTDragManager; virtual;\r\n    function DoCreateEditor(Node: PVirtualNode; Column: TColumnIndex): IVTEditLink; virtual;\r\n    procedure DoDragging(P: TPoint); virtual;\r\n    procedure DoDragExpand; virtual;\r\n    procedure DoBeforeDrawLineImage(Node: PVirtualNode; Level: Integer; var XPos: Integer); virtual;\r\n    function DoDragOver(Source: TObject; Shift: TShiftState; State: TDragState; Pt: TPoint; Mode: TDropMode;\r\n      var Effect: Integer): Boolean; virtual;\r\n    procedure DoDragDrop(Source: TObject; const DataObject: IDataObject; const Formats: TFormatArray; Shift: TShiftState; Pt: TPoint;\r\n      var Effect: Integer; Mode: TDropMode); virtual;\r\n    procedure DoDrawHint(Canvas: TCanvas; Node: PVirtualNode; R: TRect; Column:\r\n        TColumnIndex);\r\n    procedure DoEdit; virtual;\r\n    procedure DoEndDrag(Target: TObject; X, Y: Integer); override;\r\n    function DoEndEdit: Boolean; virtual;\r\n    procedure DoEndOperation(OperationKind: TVTOperationKind); virtual;\r\n    procedure DoEnter(); override;\r\n    procedure DoExpanded(Node: PVirtualNode); virtual;\r\n    function DoExpanding(Node: PVirtualNode): Boolean; virtual;\r\n    procedure DoFocusChange(Node: PVirtualNode; Column: TColumnIndex); virtual;\r\n    function DoFocusChanging(OldNode, NewNode: PVirtualNode; OldColumn, NewColumn: TColumnIndex): Boolean; virtual;\r\n    procedure DoFocusNode(Node: PVirtualNode; Ask: Boolean); virtual;\r\n    procedure DoFreeNode(Node: PVirtualNode); virtual;\r\n    function DoGetAnimationType: THintAnimationType; virtual;\r\n    function DoGetCellContentMargin(Node: PVirtualNode; Column: TColumnIndex;\r\n      CellContentMarginType: TVTCellContentMarginType = ccmtAllSides; Canvas: TCanvas = nil): TPoint; virtual;\r\n    procedure DoGetCursor(var Cursor: TCursor); virtual;\r\n    procedure DoGetHeaderCursor(var Cursor: HCURSOR); virtual;\r\n    procedure DoGetHintSize(Node: PVirtualNode; Column: TColumnIndex; var R:\r\n        TRect); virtual;\r\n    procedure DoGetHintKind(Node: PVirtualNode; Column: TColumnIndex; var Kind:\r\n        TVTHintKind);\r\n    function DoGetImageIndex(Node: PVirtualNode; Kind: TVTImageKind; Column: TColumnIndex;\r\n      var Ghosted: Boolean; var Index: TImageIndex): TCustomImageList; virtual;\r\n    procedure DoGetImageText(Node: PVirtualNode; Kind: TVTImageKind; Column: TColumnIndex;\r\n      var ImageText: string); virtual;\r\n    procedure DoGetLineStyle(var Bits: Pointer); virtual;\r\n    function DoGetNodeHint(Node: PVirtualNode; Column: TColumnIndex; var LineBreakStyle: TVTTooltipLineBreakStyle): string; virtual;\r\n    function DoGetNodeTooltip(Node: PVirtualNode; Column: TColumnIndex; var LineBreakStyle: TVTTooltipLineBreakStyle): string; virtual;\r\n    function DoGetNodeExtraWidth(Node: PVirtualNode; Column: TColumnIndex; Canvas: TCanvas = nil): Integer; virtual;\r\n    function DoGetNodeWidth(Node: PVirtualNode; Column: TColumnIndex; Canvas: TCanvas = nil): Integer; virtual;\r\n    function DoGetPopupMenu(Node: PVirtualNode; Column: TColumnIndex; Position: TPoint): TPopupMenu; virtual;\r\n    procedure DoGetUserClipboardFormats(var Formats: TFormatEtcArray); virtual;\r\n    procedure DoHeaderClick(const HitInfo: TVTHeaderHitInfo); virtual;\r\n    procedure DoHeaderDblClick(const HitInfo: TVTHeaderHitInfo); virtual;\r\n    procedure DoHeaderDragged(Column: TColumnIndex; OldPosition: TColumnPosition); virtual;\r\n    procedure DoHeaderDraggedOut(Column: TColumnIndex; DropPosition: TPoint); virtual;\r\n    function DoHeaderDragging(Column: TColumnIndex): Boolean; virtual;\r\n    procedure DoHeaderDraw(Canvas: TCanvas; Column: TVirtualTreeColumn; R: TRect; Hover, Pressed: Boolean;\r\n      DropMark: TVTDropMarkMode); virtual;\r\n    procedure DoHeaderDrawQueryElements(var PaintInfo: THeaderPaintInfo; var Elements: THeaderPaintElements); virtual;\r\n    procedure DoHeaderMouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); virtual;\r\n    procedure DoHeaderMouseMove(Shift: TShiftState; X, Y: Integer); virtual;\r\n    procedure DoHeaderMouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); virtual;\r\n    procedure DoHotChange(Old, New: PVirtualNode); virtual;\r\n    function DoIncrementalSearch(Node: PVirtualNode; const Text: string): Integer; virtual;\r\n    function DoInitChildren(Node: PVirtualNode; var ChildCount: Cardinal): Boolean; virtual;\r\n    procedure DoInitNode(Parent, Node: PVirtualNode; var InitStates: TVirtualNodeInitStates); virtual;\r\n    function DoKeyAction(var CharCode: Word; var Shift: TShiftState): Boolean; virtual;\r\n    procedure DoLoadUserData(Node: PVirtualNode; Stream: TStream); virtual;\r\n    procedure DoMeasureItem(TargetCanvas: TCanvas; Node: PVirtualNode; var NodeHeight: Integer); virtual;\r\n    procedure DoMouseEnter(); virtual;\r\n    procedure DoMouseLeave(); virtual;\r\n    procedure DoNodeCopied(Node: PVirtualNode); virtual;\r\n    function DoNodeCopying(Node, NewParent: PVirtualNode): Boolean; virtual;\r\n    procedure DoNodeClick(const HitInfo: THitInfo); virtual;\r\n    procedure DoNodeDblClick(const HitInfo: THitInfo); virtual;\r\n    function DoNodeHeightDblClickResize(Node: PVirtualNode; Column: TColumnIndex; Shift: TShiftState;\r\n      P: TPoint): Boolean; virtual;\r\n    function DoNodeHeightTracking(Node: PVirtualNode; Column: TColumnIndex;  Shift: TShiftState;\r\n      var TrackPoint: TPoint; P: TPoint): Boolean; virtual;\r\n    procedure DoNodeMoved(Node: PVirtualNode); virtual;\r\n    function DoNodeMoving(Node, NewParent: PVirtualNode): Boolean; virtual;\r\n    function DoPaintBackground(Canvas: TCanvas; R: TRect): Boolean; virtual;\r\n    procedure DoPaintDropMark(Canvas: TCanvas; Node: PVirtualNode; R: TRect); virtual;\r\n    procedure DoPaintNode(var PaintInfo: TVTPaintInfo); virtual;\r\n    procedure DoPopupMenu(Node: PVirtualNode; Column: TColumnIndex; Position: TPoint); virtual;\r\n    procedure DoRemoveFromSelection(Node: PVirtualNode); virtual;\r\n    function DoRenderOLEData(const FormatEtcIn: TFormatEtc; out Medium: TStgMedium;\r\n      ForClipboard: Boolean): HRESULT; virtual;\r\n    procedure DoReset(Node: PVirtualNode); virtual;\r\n    procedure DoSaveUserData(Node: PVirtualNode; Stream: TStream); virtual;\r\n    procedure DoScroll(DeltaX, DeltaY: Integer); virtual;\r\n    function DoSetOffsetXY(Value: TPoint; Options: TScrollUpdateOptions; ClipRect: PRect = nil): Boolean; virtual;\r\n    procedure DoShowScrollBar(Bar: Integer; Show: Boolean); virtual;\r\n    procedure DoStartDrag(var DragObject: TDragObject); override;\r\n    procedure DoStartOperation(OperationKind: TVTOperationKind); virtual;\r\n    procedure DoStateChange(Enter: TVirtualTreeStates; Leave: TVirtualTreeStates = []); virtual;\r\n    procedure DoStructureChange(Node: PVirtualNode; Reason: TChangeReason); virtual;\r\n    procedure DoTimerScroll; virtual;\r\n    procedure DoUpdating(State: TVTUpdateState); virtual;\r\n    function DoValidateCache: Boolean; virtual;\r\n    procedure DragAndDrop(AllowedEffects: DWord; const DataObject: IDataObject; var DragEffect: Integer); virtual;\r\n    procedure DragCanceled; override;\r\n    function DragDrop(const DataObject: IDataObject; KeyState: Integer; Pt: TPoint;\r\n      var Effect: Integer): HResult; reintroduce; virtual;\r\n    function DragEnter(KeyState: Integer; Pt: TPoint; var Effect: Integer): HResult; virtual;\r\n    procedure DragFinished; virtual;\r\n    procedure DragLeave; virtual;\r\n    function DragOver(Source: TObject; KeyState: Integer; DragState: TDragState; Pt: TPoint;\r\n      var Effect: Integer): HResult; reintroduce; virtual;\r\n    procedure DrawDottedHLine(const PaintInfo: TVTPaintInfo; Left, Right, Top: Integer); virtual;\r\n    procedure DrawDottedVLine(const PaintInfo: TVTPaintInfo; Top, Bottom, Left: Integer; UseSelectedBkColor: Boolean = False); virtual;\r\n    procedure EndOperation(OperationKind: TVTOperationKind);\r\n    procedure EnsureNodeFocused(); virtual;\r\n    function FindNodeInSelection(P: PVirtualNode; var Index: Integer; LowBound, HighBound: Integer): Boolean; virtual;\r\n    procedure FinishChunkHeader(Stream: TStream; StartPos, EndPos: Integer); virtual;\r\n    procedure FontChanged(AFont: TObject); virtual;\r\n    function GetBorderDimensions: TSize; virtual;\r\n    function GetCheckImage(Node: PVirtualNode; ImgCheckType: TCheckType = ctNone;\r\n      ImgCheckState: TCheckState = csUncheckedNormal; ImgEnabled: Boolean = True): Integer; virtual;\r\n    class function GetCheckImageListFor(Kind: TCheckImageKind): TCustomImageList; virtual;\r\n    function GetColumnClass: TVirtualTreeColumnClass; virtual;\r\n    function GetDefaultHintKind: TVTHintKind; virtual;\r\n    function GetHeaderClass: TVTHeaderClass; virtual;\r\n    function GetHintWindowClass: THintWindowClass; virtual;\r\n    procedure GetImageIndex(var Info: TVTPaintInfo; Kind: TVTImageKind; InfoIndex: TVTImageInfoIndex;\r\n      DefaultImages: TCustomImageList); virtual;\r\n    function GetNodeImageSize(Node: PVirtualNode): TSize; virtual;\r\n    function GetMaxRightExtend: Cardinal; virtual;\r\n    procedure GetNativeClipboardFormats(var Formats: TFormatEtcArray); virtual;\r\n    function GetOperationCanceled: Boolean;\r\n    function GetOptionsClass: TTreeOptionsClass; virtual;\r\n    function GetTreeFromDataObject(const DataObject: IDataObject): TBaseVirtualTree; virtual;\r\n    procedure HandleHotTrack(X, Y: Integer); virtual;\r\n    procedure HandleIncrementalSearch(CharCode: Word); virtual;\r\n    procedure HandleMouseDblClick(var Message: TWMMouse; const HitInfo: THitInfo); virtual;\r\n    procedure HandleMouseDown(var Message: TWMMouse; var HitInfo: THitInfo); virtual;\r\n    procedure HandleMouseUp(var Message: TWMMouse; const HitInfo: THitInfo); virtual;\r\n    function HasImage(Node: PVirtualNode; Kind: TVTImageKind; Column: TColumnIndex): Boolean; virtual;\r\n    function HasPopupMenu(Node: PVirtualNode; Column: TColumnIndex; Pos: TPoint): Boolean; virtual;\r\n    procedure InitChildren(Node: PVirtualNode); virtual;\r\n    procedure InitNode(Node: PVirtualNode); virtual;\r\n    procedure InternalAddFromStream(Stream: TStream; Version: Integer; Node: PVirtualNode); virtual;\r\n    function InternalAddToSelection(Node: PVirtualNode; ForceInsert: Boolean): Boolean; overload;\r\n    function InternalAddToSelection(const NewItems: TNodeArray; NewLength: Integer;\r\n      ForceInsert: Boolean): Boolean; overload;\r\n    procedure InternalCacheNode(Node: PVirtualNode); virtual;\r\n    procedure InternalClearSelection; virtual;\r\n    procedure InternalConnectNode(Node, Destination: PVirtualNode; Target: TBaseVirtualTree; Mode: TVTNodeAttachMode); virtual;\r\n    function InternalData(Node: PVirtualNode): Pointer;\r\n    procedure InternalDisconnectNode(Node: PVirtualNode; KeepFocus: Boolean; Reindex: Boolean = True; ParentClearing: Boolean = False); virtual;\r\n    procedure InternalRemoveFromSelection(Node: PVirtualNode); virtual;\r\n    procedure InterruptValidation;\r\n    procedure InvalidateCache;\r\n    procedure Loaded; override;\r\n    procedure MainColumnChanged; virtual;\r\n    procedure MarkCutCopyNodes; virtual;\r\n    procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;\r\n    procedure Notification(AComponent: TComponent; Operation: TOperation); override;\r\n    procedure OriginalWMNCPaint(DC: HDC); virtual;\r\n    procedure Paint; override;\r\n    procedure PaintCheckImage(Canvas: TCanvas; const ImageInfo: TVTImageInfo; Selected: Boolean); virtual;\r\n    procedure PaintImage(var PaintInfo: TVTPaintInfo; ImageInfoIndex: TVTImageInfoIndex; DoOverlay: Boolean); virtual;\r\n    procedure PaintNodeButton(Canvas: TCanvas; Node: PVirtualNode; Column: TColumnIndex; const R: TRect; ButtonX,\r\n      ButtonY: Integer; BidiMode: TBiDiMode); virtual;\r\n    procedure PaintTreeLines(const PaintInfo: TVTPaintInfo; VAlignment, IndentSize: Integer; const LineImage: TLineImage); virtual;\r\n    procedure PaintSelectionRectangle(Target: TCanvas; WindowOrgX: Integer; const SelectionRect: TRect;\r\n      TargetRect: TRect); virtual;\r\n    procedure PanningWindowProc(var Message: TMessage); virtual;\r\n    procedure PrepareCell(var PaintInfo: TVTPaintInfo; WindowOrgX, MaxWidth: Integer); virtual;\r\n    function ReadChunk(Stream: TStream; Version: Integer; Node: PVirtualNode; ChunkType,\r\n      ChunkSize: Integer): Boolean; virtual;\r\n    procedure ReadNode(Stream: TStream; Version: Integer; Node: PVirtualNode); virtual;\r\n    procedure RedirectFontChangeEvent(Canvas: TCanvas); virtual;\r\n    procedure RemoveFromSelection(Node: PVirtualNode); virtual;\r\n    procedure UpdateNextNodeToSelect(Node: PVirtualNode); virtual;\r\n    function RenderOLEData(const FormatEtcIn: TFormatEtc; out Medium: TStgMedium; ForClipboard: Boolean): HResult; virtual;\r\n    procedure ResetRangeAnchor; virtual;\r\n    procedure RestoreFontChangeEvent(Canvas: TCanvas); virtual;\r\n    procedure SelectNodes(StartNode, EndNode: PVirtualNode; AddOnly: Boolean); virtual;\r\n    procedure SetChildCount(Node: PVirtualNode; NewChildCount: Cardinal); virtual;\r\n    procedure SetFocusedNodeAndColumn(Node: PVirtualNode; Column: TColumnIndex); virtual;\r\n    procedure SkipNode(Stream: TStream); virtual;\r\n    procedure StartOperation(OperationKind: TVTOperationKind);\r\n    procedure StartWheelPanning(Position: TPoint); virtual;\r\n    procedure StopWheelPanning; virtual;\r\n    procedure StructureChange(Node: PVirtualNode; Reason: TChangeReason); virtual;\r\n    function SuggestDropEffect(Source: TObject; Shift: TShiftState; Pt: TPoint; AllowedEffects: Integer): Integer; virtual;\r\n    procedure ToggleSelection(StartNode, EndNode: PVirtualNode); virtual;\r\n    procedure UnselectNodes(StartNode, EndNode: PVirtualNode); virtual;\r\n    procedure UpdateColumnCheckState(Col: TVirtualTreeColumn);\r\n    procedure UpdateDesigner; virtual;\r\n    procedure UpdateEditBounds; virtual;\r\n    procedure UpdateHeaderRect; virtual;\r\n    procedure UpdateStyleElements; override;\r\n    procedure UpdateWindowAndDragImage(const Tree: TBaseVirtualTree; TreeRect: TRect; UpdateNCArea,\r\n      ReshowDragImage: Boolean); virtual;\r\n    procedure ValidateCache; virtual;\r\n    procedure ValidateNodeDataSize(var Size: Integer); virtual;\r\n    procedure WndProc(var Message: TMessage); override;\r\n    procedure WriteChunks(Stream: TStream; Node: PVirtualNode); virtual;\r\n    procedure WriteNode(Stream: TStream; Node: PVirtualNode); virtual;\r\n\r\n    procedure VclStyleChanged; virtual;\r\n    property VclStyleEnabled: Boolean read FVclStyleEnabled;\r\n    property TotalInternalDataSize: Cardinal read FTotalInternalDataSize;\r\n\r\n    property Alignment: TAlignment read FAlignment write SetAlignment default taLeftJustify;\r\n    property AnimationDuration: Cardinal read FAnimationDuration write SetAnimationDuration default 200;\r\n    property AutoExpandDelay: Cardinal read FAutoExpandDelay write FAutoExpandDelay default 1000;\r\n    property AutoScrollDelay: Cardinal read FAutoScrollDelay write FAutoScrollDelay default 1000;\r\n    property AutoScrollInterval: TAutoScrollInterval read FAutoScrollInterval write FAutoScrollInterval default 1;\r\n    property Background: TPicture read FBackground write SetBackground;\r\n    property BackgroundOffsetX: Integer index 0 read FBackgroundOffsetX write SetBackgroundOffset default 0;\r\n    property BackgroundOffsetY: Integer index 1 read FBackgroundOffsetY write SetBackgroundOffset default 0;\r\n    property BorderStyle: TBorderStyle read FBorderStyle write SetBorderStyle default bsSingle;\r\n    property BottomSpace: Cardinal read FBottomSpace write SetBottomSpace default 0;\r\n    property ButtonFillMode: TVTButtonFillMode read FButtonFillMode write SetButtonFillMode default fmTreeColor;\r\n    property ButtonStyle: TVTButtonStyle read FButtonStyle write SetButtonStyle default bsRectangle;\r\n    property ChangeDelay: Cardinal read FChangeDelay write FChangeDelay default 0;\r\n    property CheckImageKind: TCheckImageKind read FCheckImageKind write SetCheckImageKind default ckSystemDefault;\r\n    property ClipboardFormats: TClipboardFormats read FClipboardFormats write SetClipboardFormats;\r\n    property Colors: TVTColors read FColors write SetColors;\r\n    property CustomCheckImages: TCustomImageList read FCustomCheckImages write SetCustomCheckImages;\r\n    property DefaultHintKind: TVTHintKind read GetDefaultHintKind;\r\n    property DefaultNodeHeight: Cardinal read FDefaultNodeHeight write SetDefaultNodeHeight default 18;\r\n    property DefaultPasteMode: TVTNodeAttachMode read FDefaultPasteMode write FDefaultPasteMode default amAddChildLast;\r\n    property DragHeight: Integer read FDragHeight write FDragHeight default 350;\r\n    property DragImageKind: TVTDragImageKind read FDragImageKind write FDragImageKind default diComplete;\r\n    property DragOperations: TDragOperations read FDragOperations write FDragOperations default [doCopy, doMove];\r\n    property DragSelection: TNodeArray read FDragSelection;\r\n    property LastDragEffect: Integer read FLastDragEffect;\r\n    property DragType: TVTDragType read FDragType write FDragType default dtOLE;\r\n    property DragWidth: Integer read FDragWidth write FDragWidth default 200;\r\n    property DrawSelectionMode: TVTDrawSelectionMode read FDrawSelectionMode write FDrawSelectionMode\r\n      default smDottedRectangle;\r\n    property EditColumn: TColumnIndex read FEditColumn write FEditColumn;\r\n    property EditDelay: Cardinal read FEditDelay write FEditDelay default 1000;\r\n    property EffectiveOffsetX: Integer read FEffectiveOffsetX;\r\n    property HeaderRect: TRect read FHeaderRect;\r\n    property HintAnimation: THintAnimationType read FAnimationType write FAnimationType default hatSystemDefault;\r\n    property HintMode: TVTHintMode read FHintMode write FHintMode default hmDefault;\r\n    property HintData: TVTHintData read FHintData write FHintData;\r\n    property HotCursor: TCursor read FHotCursor write FHotCursor default crDefault;\r\n    property Images: TCustomImageList read FImages write SetImages;\r\n    property IncrementalSearch: TVTIncrementalSearch read FIncrementalSearch write SetSearchOption default isNone;\r\n    property IncrementalSearchDirection: TVTSearchDirection read FSearchDirection write FSearchDirection default sdForward;\r\n    property IncrementalSearchStart: TVTSearchStart read FSearchStart write FSearchStart default ssFocusedNode;\r\n    property IncrementalSearchTimeout: Cardinal read FSearchTimeout write FSearchTimeout default 1000;\r\n    property Indent: Cardinal read FIndent write SetIndent default 18;\r\n    property LastClickPos: TPoint read FLastClickPos write FLastClickPos;\r\n    property LastDropMode: TDropMode read FLastDropMode write FLastDropMode;\r\n    property LastHintRect: TRect read FLastHintRect write FLastHintRect;\r\n    property LineMode: TVTLineMode read FLineMode write SetLineMode default lmNormal;\r\n    property LineStyle: TVTLineStyle read FLineStyle write SetLineStyle default lsDotted;\r\n    property Margin: Integer read FMargin write SetMargin default 4;\r\n    property NextNodeToSelect: PVirtualNode read FNextNodeToSelect; // Next tree node that we would like to select if the current one gets deleted\r\n    property NodeAlignment: TVTNodeAlignment read FNodeAlignment write SetNodeAlignment default naProportional;\r\n    property NodeDataSize: Integer read FNodeDataSize write SetNodeDataSize default -1;\r\n    property OperationCanceled: Boolean read GetOperationCanceled;\r\n    property HotMinusBM: TBitmap read FHotMinusBM;\r\n    property HotPlusBM: TBitmap read FHotPlusBM;\r\n    property MinusBM: TBitmap read FMinusBM;\r\n    property PlusBM: TBitmap read FPlusBM;\r\n    property RangeX: Cardinal read GetRangeX;// Returns the width of the virtual tree in pixels, (not ClientWidth). If there are columns it returns the total width of all of them; otherwise it returns the maximum of the all the line's data widths.\r\n    property RangeY: Cardinal read FRangeY;\r\n    property RootNodeCount: Cardinal read GetRootNodeCount write SetRootNodeCount default 0;\r\n    property ScrollBarOptions: TScrollBarOptions read FScrollBarOptions write SetScrollBarOptions;\r\n    property SelectionBlendFactor: Byte read FSelectionBlendFactor write FSelectionBlendFactor default 128;\r\n    property SelectionCurveRadius: Cardinal read FSelectionCurveRadius write SetSelectionCurveRadius default 0;\r\n    property StateImages: TCustomImageList read FStateImages write SetStateImages;\r\n    property TextMargin: Integer read FTextMargin write SetTextMargin default 4;\r\n    property TreeOptions: TCustomVirtualTreeOptions read FOptions write SetOptions;\r\n    property WantTabs: Boolean read FWantTabs write FWantTabs default False;\r\n\r\n    property OnAddToSelection: TVTAddToSelectionEvent read FOnAddToSelection write FOnAddToSelection;\r\n    property OnAdvancedHeaderDraw: TVTAdvancedHeaderPaintEvent read FOnAdvancedHeaderDraw write FOnAdvancedHeaderDraw;\r\n    property OnAfterAutoFitColumn: TVTAfterAutoFitColumnEvent read FOnAfterAutoFitColumn write FOnAfterAutoFitColumn;\r\n    property OnAfterAutoFitColumns: TVTAfterAutoFitColumnsEvent read FOnAfterAutoFitColumns write FOnAfterAutoFitColumns;\r\n    property OnAfterCellPaint: TVTAfterCellPaintEvent read FOnAfterCellPaint write FOnAfterCellPaint;\r\n    property OnAfterColumnExport : TVTColumnExportEvent read FOnAfterColumnExport write FOnAfterColumnExport;\r\n    property OnAfterColumnWidthTracking: TVTAfterColumnWidthTrackingEvent read FOnAfterColumnWidthTracking write FOnAfterColumnWidthTracking;\r\n    property OnAfterGetMaxColumnWidth: TVTAfterGetMaxColumnWidthEvent read FOnAfterGetMaxColumnWidth write FOnAfterGetMaxColumnWidth;\r\n    property OnAfterHeaderExport: TVTTreeExportEvent read FOnAfterHeaderExport write FOnAfterHeaderExport;\r\n    property OnAfterHeaderHeightTracking: TVTAfterHeaderHeightTrackingEvent read FOnAfterHeaderHeightTracking\r\n      write FOnAfterHeaderHeightTracking;\r\n    property OnAfterItemErase: TVTAfterItemEraseEvent read FOnAfterItemErase write FOnAfterItemErase;\r\n    property OnAfterItemPaint: TVTAfterItemPaintEvent read FOnAfterItemPaint write FOnAfterItemPaint;\r\n    property OnAfterNodeExport: TVTNodeExportEvent read FOnAfterNodeExport write FOnAfterNodeExport;\r\n    property OnAfterPaint: TVTPaintEvent read FOnAfterPaint write FOnAfterPaint;\r\n    property OnAfterTreeExport: TVTTreeExportEvent read FOnAfterTreeExport write FOnAfterTreeExport;\r\n    property OnBeforeAutoFitColumn: TVTBeforeAutoFitColumnEvent read FOnBeforeAutoFitColumn write FOnBeforeAutoFitColumn;\r\n    property OnBeforeAutoFitColumns: TVTBeforeAutoFitColumnsEvent read FOnBeforeAutoFitColumns write FOnBeforeAutoFitColumns;\r\n    property OnBeforeCellPaint: TVTBeforeCellPaintEvent read FOnBeforeCellPaint write FOnBeforeCellPaint;\r\n    property OnBeforeColumnExport: TVTColumnExportEvent read FOnBeforeColumnExport write FOnBeforeColumnExport;\r\n    property OnBeforeColumnWidthTracking: TVTBeforeColumnWidthTrackingEvent read FOnBeforeColumnWidthTracking\r\n      write FOnBeforeColumnWidthTracking;\r\n    property OnBeforeDrawTreeLine: TVTBeforeDrawLineImageEvent read FOnBeforeDrawLineImage write FOnBeforeDrawLineImage;\r\n    property OnBeforeGetMaxColumnWidth: TVTBeforeGetMaxColumnWidthEvent read FOnBeforeGetMaxColumnWidth write FOnBeforeGetMaxColumnWidth;\r\n    property OnBeforeHeaderExport: TVTTreeExportEvent read FOnBeforeHeaderExport write FOnBeforeHeaderExport;\r\n    property OnBeforeHeaderHeightTracking: TVTBeforeHeaderHeightTrackingEvent read FOnBeforeHeaderHeightTracking\r\n      write FOnBeforeHeaderHeightTracking;\r\n    property OnBeforeItemErase: TVTBeforeItemEraseEvent read FOnBeforeItemErase write FOnBeforeItemErase;\r\n    property OnBeforeItemPaint: TVTBeforeItemPaintEvent read FOnBeforeItemPaint write FOnBeforeItemPaint;\r\n    property OnBeforeNodeExport: TVTNodeExportEvent read FOnBeforeNodeExport write FOnBeforeNodeExport;\r\n    property OnBeforePaint: TVTPaintEvent read FOnBeforePaint write FOnBeforePaint;\r\n    property OnBeforeTreeExport: TVTTreeExportEvent read FOnBeforeTreeExport write FOnBeforeTreeExport;\r\n    property OnCanSplitterResizeColumn: TVTCanSplitterResizeColumnEvent read FOnCanSplitterResizeColumn write FOnCanSplitterResizeColumn;\r\n    property OnCanSplitterResizeHeader: TVTCanSplitterResizeHeaderEvent read FOnCanSplitterResizeHeader write FOnCanSplitterResizeHeader;\r\n    property OnCanSplitterResizeNode: TVTCanSplitterResizeNodeEvent read FOnCanSplitterResizeNode write FOnCanSplitterResizeNode;\r\n    property OnChange: TVTChangeEvent read FOnChange write FOnChange;\r\n    property OnChecked: TVTChangeEvent read FOnChecked write FOnChecked;\r\n    property OnChecking: TVTCheckChangingEvent read FOnChecking write FOnChecking;\r\n    property OnCollapsed: TVTChangeEvent read FOnCollapsed write FOnCollapsed;\r\n    property OnCollapsing: TVTChangingEvent read FOnCollapsing write FOnCollapsing;\r\n    property OnColumnClick: TVTColumnClickEvent read FOnColumnClick write FOnColumnClick;\r\n    property OnColumnDblClick: TVTColumnDblClickEvent read FOnColumnDblClick write FOnColumnDblClick;\r\n    property OnColumnExport : TVTColumnExportEvent read FOnColumnExport write FOnColumnExport;\r\n    property OnColumnResize: TVTHeaderNotifyEvent read FOnColumnResize write FOnColumnResize;\r\n    property OnColumnVisibilityChanged: TColumnChangeEvent read fOnColumnVisibilityChanged write fOnColumnVisibilityChanged;\r\n    property OnColumnWidthDblClickResize: TVTColumnWidthDblClickResizeEvent read FOnColumnWidthDblClickResize\r\n      write FOnColumnWidthDblClickResize;\r\n    property OnColumnWidthTracking: TVTColumnWidthTrackingEvent read FOnColumnWidthTracking write FOnColumnWidthTracking;\r\n    property OnCompareNodes: TVTCompareEvent read FOnCompareNodes write FOnCompareNodes;\r\n    property OnCreateDataObject: TVTCreateDataObjectEvent read FOnCreateDataObject write FOnCreateDataObject;\r\n    property OnCreateDragManager: TVTCreateDragManagerEvent read FOnCreateDragManager write FOnCreateDragManager;\r\n    property OnCreateEditor: TVTCreateEditorEvent read FOnCreateEditor write FOnCreateEditor;\r\n    property OnDragAllowed: TVTDragAllowedEvent read FOnDragAllowed write FOnDragAllowed;\r\n    property OnDragOver: TVTDragOverEvent read FOnDragOver write FOnDragOver;\r\n    property OnDragDrop: TVTDragDropEvent read FOnDragDrop write FOnDragDrop;\r\n    property OnDrawHint: TVTDrawHintEvent read FOnDrawHint write FOnDrawHint;\r\n    property OnEditCancelled: TVTEditCancelEvent read FOnEditCancelled write FOnEditCancelled;\r\n    property OnEditing: TVTEditChangingEvent read FOnEditing write FOnEditing;\r\n    property OnEdited: TVTEditChangeEvent read FOnEdited write FOnEdited;\r\n    property OnEndOperation: TVTOperationEvent read FOnEndOperation write FOnEndOperation;\r\n    property OnExpanded: TVTChangeEvent read FOnExpanded write FOnExpanded;\r\n    property OnExpanding: TVTChangingEvent read FOnExpanding write FOnExpanding;\r\n    property OnFocusChanged: TVTFocusChangeEvent read FOnFocusChanged write FOnFocusChanged;\r\n    property OnFocusChanging: TVTFocusChangingEvent read FOnFocusChanging write FOnFocusChanging;\r\n    property OnFreeNode: TVTFreeNodeEvent read FOnFreeNode write FOnFreeNode;\r\n    property OnGetCellIsEmpty: TVTGetCellIsEmptyEvent read FOnGetCellIsEmpty write FOnGetCellIsEmpty;\r\n    property OnGetCursor: TVTGetCursorEvent read FOnGetCursor write FOnGetCursor;\r\n    property OnGetHeaderCursor: TVTGetHeaderCursorEvent read FOnGetHeaderCursor write FOnGetHeaderCursor;\r\n    property OnGetHelpContext: TVTHelpContextEvent read FOnGetHelpContext write FOnGetHelpContext;\r\n    property OnGetHintSize: TVTGetHintSizeEvent read FOnGetHintSize write\r\n        FOnGetHintSize;\r\n    property OnGetHintKind: TVTHintKindEvent read FOnGetHintKind write\r\n        FOnGetHintKind;\r\n    property OnGetImageIndex: TVTGetImageEvent read FOnGetImage write FOnGetImage;\r\n    property OnGetImageIndexEx: TVTGetImageExEvent read FOnGetImageEx write FOnGetImageEx;\r\n    property OnGetImageText: TVTGetImageTextEvent read FOnGetImageText write FOnGetImageText;\r\n    property OnGetLineStyle: TVTGetLineStyleEvent read FOnGetLineStyle write FOnGetLineStyle;\r\n    property OnGetNodeDataSize: TVTGetNodeDataSizeEvent read FOnGetNodeDataSize write FOnGetNodeDataSize;\r\n    property OnGetPopupMenu: TVTPopupEvent read FOnGetPopupMenu write FOnGetPopupMenu;\r\n    property OnGetUserClipboardFormats: TVTGetUserClipboardFormatsEvent read FOnGetUserClipboardFormats\r\n      write FOnGetUserClipboardFormats;\r\n    property OnHeaderClick: TVTHeaderClickEvent read FOnHeaderClick write FOnHeaderClick;\r\n    property OnHeaderDblClick: TVTHeaderClickEvent read FOnHeaderDblClick write FOnHeaderDblClick;\r\n    property OnHeaderDragged: TVTHeaderDraggedEvent read FOnHeaderDragged write FOnHeaderDragged;\r\n    property OnHeaderDraggedOut: TVTHeaderDraggedOutEvent read FOnHeaderDraggedOut write FOnHeaderDraggedOut;\r\n    property OnHeaderDragging: TVTHeaderDraggingEvent read FOnHeaderDragging write FOnHeaderDragging;\r\n    property OnHeaderDraw: TVTHeaderPaintEvent read FOnHeaderDraw write FOnHeaderDraw;\r\n    property OnHeaderDrawQueryElements: TVTHeaderPaintQueryElementsEvent read FOnHeaderDrawQueryElements\r\n      write FOnHeaderDrawQueryElements;\r\n    property OnHeaderHeightTracking: TVTHeaderHeightTrackingEvent read FOnHeaderHeightTracking\r\n      write FOnHeaderHeightTracking;\r\n    property OnHeaderHeightDblClickResize: TVTHeaderHeightDblClickResizeEvent read FOnHeaderHeightDblClickResize\r\n      write FOnHeaderHeightDblClickResize;\r\n    property OnHeaderMouseDown: TVTHeaderMouseEvent read FOnHeaderMouseDown write FOnHeaderMouseDown;\r\n    property OnHeaderMouseMove: TVTHeaderMouseMoveEvent read FOnHeaderMouseMove write FOnHeaderMouseMove;\r\n    property OnHeaderMouseUp: TVTHeaderMouseEvent read FOnHeaderMouseUp write FOnHeaderMouseUp;\r\n    property OnHotChange: TVTHotNodeChangeEvent read FOnHotChange write FOnHotChange;\r\n    property OnIncrementalSearch: TVTIncrementalSearchEvent read FOnIncrementalSearch write FOnIncrementalSearch;\r\n    property OnInitChildren: TVTInitChildrenEvent read FOnInitChildren write FOnInitChildren;\r\n    property OnInitNode: TVTInitNodeEvent read FOnInitNode write FOnInitNode;\r\n    property OnKeyAction: TVTKeyActionEvent read FOnKeyAction write FOnKeyAction;\r\n    property OnLoadNode: TVTSaveNodeEvent read FOnLoadNode write FOnLoadNode;\r\n    property OnLoadTree: TVTSaveTreeEvent read FOnLoadTree write FOnLoadTree;\r\n    property OnMeasureItem: TVTMeasureItemEvent read FOnMeasureItem write FOnMeasureItem;\r\n    property OnMouseEnter: TNotifyEvent read FOnMouseEnter write FOnMouseEnter;\r\n    property OnMouseLeave: TNotifyEvent read FOnMouseLeave write FOnMouseLeave;\r\n    property OnNodeClick: TVTNodeClickEvent read FOnNodeClick write FOnNodeClick;\r\n    property OnNodeCopied: TVTNodeCopiedEvent read FOnNodeCopied write FOnNodeCopied;\r\n    property OnNodeCopying: TVTNodeCopyingEvent read FOnNodeCopying write FOnNodeCopying;\r\n    property OnNodeDblClick: TVTNodeClickEvent read FOnNodeDblClick write FOnNodeDblClick;\r\n    property OnNodeExport: TVTNodeExportEvent read FOnNodeExport write FOnNodeExport;\r\n    property OnNodeHeightTracking: TVTNodeHeightTrackingEvent read FOnNodeHeightTracking write FOnNodeHeightTracking;\r\n    property OnNodeHeightDblClickResize: TVTNodeHeightDblClickResizeEvent read FOnNodeHeightDblClickResize\r\n      write FOnNodeHeightDblClickResize;\r\n    property OnNodeMoved: TVTNodeMovedEvent read FOnNodeMoved write FOnNodeMoved;\r\n    property OnNodeMoving: TVTNodeMovingEvent read FOnNodeMoving write FOnNodeMoving;\r\n    property OnPaintBackground: TVTBackgroundPaintEvent read FOnPaintBackground write FOnPaintBackground;\r\n    property OnPrepareButtonBitmaps : TVTPrepareButtonImagesEvent read FOnPrepareButtonImages write FOnPrepareButtonImages;\r\n    property OnRemoveFromSelection: TVTRemoveFromSelectionEvent read FOnRemoveFromSelection write FOnRemoveFromSelection;\r\n    property OnRenderOLEData: TVTRenderOLEDataEvent read FOnRenderOLEData write FOnRenderOLEData;\r\n    property OnResetNode: TVTChangeEvent read FOnResetNode write FOnResetNode;\r\n    property OnSaveNode: TVTSaveNodeEvent read FOnSaveNode write FOnSaveNode;\r\n    property OnSaveTree: TVTSaveTreeEvent read FOnSaveTree write FOnSaveTree;\r\n    property OnScroll: TVTScrollEvent read FOnScroll write FOnScroll;\r\n    property OnShowScrollBar: TVTScrollBarShowEvent read FOnShowScrollBar write FOnShowScrollBar;\r\n    property OnStartOperation: TVTOperationEvent read FOnStartOperation write FOnStartOperation;\r\n    property OnStateChange: TVTStateChangeEvent read FOnStateChange write FOnStateChange;\r\n    property OnStructureChange: TVTStructureChangeEvent read FOnStructureChange write FOnStructureChange;\r\n    property OnUpdating: TVTUpdatingEvent read FOnUpdating write FOnUpdating;\r\n  public\r\n    constructor Create(AOwner: TComponent); override;\r\n    destructor Destroy; override;\r\n    function AbsoluteIndex(Node: PVirtualNode): Cardinal;\r\n    function AddChild(Parent: PVirtualNode; UserData: Pointer = nil): PVirtualNode; overload; virtual;\r\n    function AddChild(Parent: PVirtualNode; const UserData: IInterface): PVirtualNode; overload;\r\n    function AddChild(Parent: PVirtualNode; const UserData: TObject): PVirtualNode; overload;\r\n    procedure AddFromStream(Stream: TStream; TargetNode: PVirtualNode);\r\n    procedure AfterConstruction; override;\r\n    procedure Assign(Source: TPersistent); override;\r\n    procedure BeginDrag(Immediate: Boolean; Threshold: Integer = -1);\r\n    procedure BeginSynch;\r\n    procedure BeginUpdate; virtual;\r\n    procedure CancelCutOrCopy;\r\n    function CancelEditNode: Boolean;\r\n    procedure CancelOperation;\r\n    function CanEdit(Node: PVirtualNode; Column: TColumnIndex): Boolean; virtual;\r\n    function CanFocus: Boolean; override;\r\n    procedure Clear; virtual;\r\n    procedure ClearChecked;\r\n    procedure ClearSelection;\r\n    function CopyTo(Source: PVirtualNode; Tree: TBaseVirtualTree; Mode: TVTNodeAttachMode;\r\n      ChildrenOnly: Boolean): PVirtualNode; overload;\r\n    function CopyTo(Source, Target: PVirtualNode; Mode: TVTNodeAttachMode;\r\n      ChildrenOnly: Boolean): PVirtualNode; overload;\r\n    procedure CopyToClipboard; virtual;\r\n    procedure CutToClipboard; virtual;\r\n    procedure DeleteChildren(Node: PVirtualNode; ResetHasChildren: Boolean = False);\r\n    procedure DeleteNode(Node: PVirtualNode); overload; inline;\r\n    procedure DeleteSelectedNodes; virtual;\r\n    function Dragging: Boolean;\r\n    function EditNode(Node: PVirtualNode; Column: TColumnIndex): Boolean; virtual;\r\n    function EndEditNode: Boolean;\r\n    procedure EndSynch;\r\n    procedure EndUpdate; virtual;\r\n    procedure EnsureNodeSelected(); virtual;\r\n    function ExecuteAction(Action: TBasicAction): Boolean; override;\r\n    procedure FinishCutOrCopy;\r\n    procedure FlushClipboard;\r\n    procedure FullCollapse(Node: PVirtualNode = nil);  virtual;\r\n    procedure FullExpand(Node: PVirtualNode = nil); virtual;\r\n    function GetControlsAlignment: TAlignment; override;\r\n    function GetDisplayRect(Node: PVirtualNode; Column: TColumnIndex; TextOnly: Boolean; Unclipped: Boolean = False;\r\n      ApplyCellContentMargin: Boolean = False): TRect;\r\n    function GetEffectivelyFiltered(Node: PVirtualNode): Boolean;\r\n    function GetEffectivelyVisible(Node: PVirtualNode): Boolean;\r\n    function GetFirst(ConsiderChildrenAbove: Boolean = False): PVirtualNode;\r\n    function GetFirstChecked(State: TCheckState = csCheckedNormal; ConsiderChildrenAbove: Boolean = False): PVirtualNode;\r\n    function GetFirstChild(Node: PVirtualNode): PVirtualNode;\r\n    function GetFirstChildNoInit(Node: PVirtualNode): PVirtualNode;\r\n    function GetFirstCutCopy(ConsiderChildrenAbove: Boolean = False): PVirtualNode;\r\n    function GetFirstInitialized(ConsiderChildrenAbove: Boolean = False): PVirtualNode;\r\n    function GetFirstLeaf: PVirtualNode;\r\n    function GetFirstLevel(NodeLevel: Cardinal): PVirtualNode;\r\n    function GetFirstNoInit(ConsiderChildrenAbove: Boolean = False): PVirtualNode;\r\n    function GetFirstSelected(ConsiderChildrenAbove: Boolean = False): PVirtualNode;\r\n    function GetFirstVisible(Node: PVirtualNode = nil; ConsiderChildrenAbove: Boolean = True;\r\n      IncludeFiltered: Boolean = False): PVirtualNode;\r\n    function GetFirstVisibleChild(Node: PVirtualNode; IncludeFiltered: Boolean = False): PVirtualNode;\r\n    function GetFirstVisibleChildNoInit(Node: PVirtualNode; IncludeFiltered: Boolean = False): PVirtualNode;\r\n    function GetFirstVisibleNoInit(Node: PVirtualNode = nil; ConsiderChildrenAbove: Boolean = True;\r\n      IncludeFiltered: Boolean = False): PVirtualNode;\r\n    procedure GetHitTestInfoAt(X, Y: Integer; Relative: Boolean; var HitInfo: THitInfo); virtual;\r\n    function GetLast(Node: PVirtualNode = nil; ConsiderChildrenAbove: Boolean = False): PVirtualNode;\r\n    function GetLastInitialized(Node: PVirtualNode = nil; ConsiderChildrenAbove: Boolean = False): PVirtualNode;\r\n    function GetLastNoInit(Node: PVirtualNode = nil; ConsiderChildrenAbove: Boolean = False): PVirtualNode;\r\n    function GetLastChild(Node: PVirtualNode): PVirtualNode;\r\n    function GetLastChildNoInit(Node: PVirtualNode): PVirtualNode;\r\n    function GetLastVisible(Node: PVirtualNode = nil; ConsiderChildrenAbove: Boolean = True;\r\n      IncludeFiltered: Boolean = False): PVirtualNode;\r\n    function GetLastVisibleChild(Node: PVirtualNode; IncludeFiltered: Boolean = False): PVirtualNode;\r\n    function GetLastVisibleChildNoInit(Node: PVirtualNode; IncludeFiltered: Boolean = False): PVirtualNode;\r\n    function GetLastVisibleNoInit(Node: PVirtualNode = nil; ConsiderChildrenAbove: Boolean = True;\r\n      IncludeFiltered: Boolean = False): PVirtualNode;\r\n    function GetMaxColumnWidth(Column: TColumnIndex; UseSmartColumnWidth: Boolean = False): Integer; virtual;\r\n    function GetNext(Node: PVirtualNode; ConsiderChildrenAbove: Boolean = False): PVirtualNode;\r\n    function GetNextChecked(Node: PVirtualNode; State: TCheckState = csCheckedNormal;\r\n      ConsiderChildrenAbove: Boolean = False): PVirtualNode; overload;\r\n    function GetNextChecked(Node: PVirtualNode; ConsiderChildrenAbove: Boolean): PVirtualNode; overload;\r\n    function GetNextCutCopy(Node: PVirtualNode; ConsiderChildrenAbove: Boolean = False): PVirtualNode;\r\n    function GetNextInitialized(Node: PVirtualNode; ConsiderChildrenAbove: Boolean = False): PVirtualNode;\r\n    function GetNextLeaf(Node: PVirtualNode): PVirtualNode;\r\n    function GetNextLevel(Node: PVirtualNode; NodeLevel: Cardinal): PVirtualNode;\r\n    function GetNextNoInit(Node: PVirtualNode; ConsiderChildrenAbove: Boolean = False): PVirtualNode;\r\n    function GetNextSelected(Node: PVirtualNode; ConsiderChildrenAbove: Boolean = False): PVirtualNode;\r\n    function GetNextSibling(Node: PVirtualNode): PVirtualNode;\r\n    function GetNextSiblingNoInit(Node: PVirtualNode): PVirtualNode;\r\n    function GetNextVisible(Node: PVirtualNode; ConsiderChildrenAbove: Boolean = True): PVirtualNode;\r\n    function GetNextVisibleNoInit(Node: PVirtualNode; ConsiderChildrenAbove: Boolean = True): PVirtualNode;\r\n    function GetNextVisibleSibling(Node: PVirtualNode; IncludeFiltered: Boolean = False): PVirtualNode;\r\n    function GetNextVisibleSiblingNoInit(Node: PVirtualNode; IncludeFiltered: Boolean = False): PVirtualNode;\r\n    function GetNodeAt(const P: TPoint): PVirtualNode; overload; inline;\r\n    function GetNodeAt(X, Y: Integer): PVirtualNode; overload;\r\n    function GetNodeAt(X, Y: Integer; Relative: Boolean; var NodeTop: Integer): PVirtualNode; overload;\r\n    function GetNodeData(Node: PVirtualNode): Pointer; overload;\r\n    function GetNodeData(pNode: PVirtualNode): T; overload; inline;\r\n    function GetSelectedData(): TArray; overload;\r\n    function GetInterfaceFromNodeData(pNode: PVirtualNode): T; overload; inline;\r\n    function GetNodeDataAt(pXCoord: Integer; pYCoord: Integer): T;\r\n    function GetFirstSelectedNodeData(): T;\r\n    function GetNodeLevel(Node: PVirtualNode): Cardinal;\r\n    function GetPrevious(Node: PVirtualNode; ConsiderChildrenAbove: Boolean = False): PVirtualNode;\r\n    function GetPreviousChecked(Node: PVirtualNode; State: TCheckState = csCheckedNormal;\r\n      ConsiderChildrenAbove: Boolean = False): PVirtualNode;\r\n    function GetPreviousCutCopy(Node: PVirtualNode; ConsiderChildrenAbove: Boolean = False): PVirtualNode;\r\n    function GetPreviousInitialized(Node: PVirtualNode; ConsiderChildrenAbove: Boolean = False): PVirtualNode;\r\n    function GetPreviousLeaf(Node: PVirtualNode): PVirtualNode;\r\n    function GetPreviousLevel(Node: PVirtualNode; NodeLevel: Cardinal): PVirtualNode;\r\n    function GetPreviousNoInit(Node: PVirtualNode; ConsiderChildrenAbove: Boolean = False): PVirtualNode;\r\n    function GetPreviousSelected(Node: PVirtualNode; ConsiderChildrenAbove: Boolean = False): PVirtualNode;\r\n    function GetPreviousSibling(Node: PVirtualNode): PVirtualNode;\r\n    function GetPreviousSiblingNoInit(Node: PVirtualNode): PVirtualNode;\r\n    function GetPreviousVisible(Node: PVirtualNode; ConsiderChildrenAbove: Boolean = True): PVirtualNode;\r\n    function GetPreviousVisibleNoInit(Node: PVirtualNode; ConsiderChildrenAbove: Boolean = True): PVirtualNode;\r\n    function GetPreviousVisibleSibling(Node: PVirtualNode; IncludeFiltered: Boolean = False): PVirtualNode;\r\n    function GetPreviousVisibleSiblingNoInit(Node: PVirtualNode; IncludeFiltered: Boolean = False): PVirtualNode;\r\n    function GetSortedCutCopySet(Resolve: Boolean): TNodeArray;\r\n    function GetSortedSelection(Resolve: Boolean): TNodeArray;\r\n    procedure GetTextInfo(Node: PVirtualNode; Column: TColumnIndex; const AFont: TFont; var R: TRect;\r\n      var Text: string); virtual;\r\n    function GetTreeRect: TRect;\r\n    function GetVisibleParent(Node: PVirtualNode; IncludeFiltered: Boolean = False): PVirtualNode;\r\n    function HasAsParent(Node, PotentialParent: PVirtualNode): Boolean;\r\n    function InsertNode(Node: PVirtualNode; Mode: TVTNodeAttachMode; UserData: Pointer = nil): PVirtualNode;\r\n    procedure InvalidateChildren(Node: PVirtualNode; Recursive: Boolean);\r\n    procedure InvalidateColumn(Column: TColumnIndex);\r\n    function InvalidateNode(Node: PVirtualNode): TRect; virtual;\r\n    procedure InvalidateToBottom(Node: PVirtualNode);\r\n    procedure InvertSelection(VisibleOnly: Boolean);\r\n    function IsEditing: Boolean;\r\n    function IsMouseSelecting: Boolean;\r\n    function IsEmpty: Boolean;\r\n    function IterateSubtree(Node: PVirtualNode; Callback: TVTGetNodeProc; Data: Pointer; Filter: TVirtualNodeStates = [];\r\n      DoInit: Boolean = False; ChildNodesOnly: Boolean = False): PVirtualNode;\r\n    procedure LoadFromFile(const FileName: TFileName); virtual;\r\n    procedure LoadFromStream(Stream: TStream); virtual;\r\n    procedure MeasureItemHeight(const Canvas: TCanvas; Node: PVirtualNode); virtual;\r\n    procedure MoveTo(Source, Target: PVirtualNode; Mode: TVTNodeAttachMode; ChildrenOnly: Boolean); overload;\r\n    procedure MoveTo(Node: PVirtualNode; Tree: TBaseVirtualTree; Mode: TVTNodeAttachMode;\r\n      ChildrenOnly: Boolean); overload;\r\n    procedure PaintTree(TargetCanvas: TCanvas; Window: TRect; Target: TPoint; PaintOptions: TVTInternalPaintOptions;\r\n      PixelFormat: TPixelFormat = pfDevice); virtual;\r\n    function PasteFromClipboard: Boolean; virtual;\r\n    procedure PrepareDragImage(HotSpot: TPoint; const DataObject: IDataObject);\r\n    procedure Print(Printer: TPrinter; PrintHeader: Boolean);\r\n    function ProcessDrop(const DataObject: IDataObject; TargetNode: PVirtualNode; var Effect: Integer; Mode:\r\n      TVTNodeAttachMode): Boolean;\r\n    function ProcessOLEData(Source: TBaseVirtualTree; const DataObject: IDataObject; TargetNode: PVirtualNode;\r\n                            Mode: TVTNodeAttachMode; Optimized: Boolean): Boolean;\r\n    procedure RepaintNode(Node: PVirtualNode);\r\n    procedure ReinitChildren(Node: PVirtualNode; Recursive: Boolean); virtual;\r\n    procedure ReinitNode(Node: PVirtualNode; Recursive: Boolean); virtual;\r\n    procedure ResetNode(Node: PVirtualNode); virtual;\r\n    procedure SaveToFile(const FileName: TFileName);\r\n    procedure SaveToStream(Stream: TStream; Node: PVirtualNode = nil); virtual;\r\n    function ScrollIntoView(Node: PVirtualNode; Center: Boolean; Horizontally: Boolean = False): Boolean; overload;\r\n    function ScrollIntoView(Column: TColumnIndex; Center: Boolean): Boolean; overload;\r\n    procedure SelectAll(VisibleOnly: Boolean);\r\n    procedure SetCheckStateForAll(aCheckState: TCheckState; pSelectedOnly: Boolean);\r\n    procedure SetNodeData(pNode: PVirtualNode; pUserData: Pointer); overload; inline;\r\n    procedure SetNodeData(pNode: PVirtualNode; const pUserData: IInterface); overload; inline;\r\n    procedure SetNodeData(pNode: PVirtualNode; pUserData: T); overload;\r\n    procedure Sort(Node: PVirtualNode; Column: TColumnIndex; Direction: TSortDirection; DoInit: Boolean = True); virtual;\r\n    procedure SortTree(Column: TColumnIndex; Direction: TSortDirection; DoInit: Boolean = True); virtual;\r\n    procedure ToggleNode(Node: PVirtualNode);\r\n    procedure UpdateHorizontalRange;\r\n    procedure UpdateHorizontalScrollBar(DoRepaint: Boolean);\r\n    procedure UpdateRanges;\r\n    procedure UpdateScrollBars(DoRepaint: Boolean); virtual;\r\n    procedure UpdateVerticalRange;\r\n    procedure UpdateVerticalScrollBar(DoRepaint: Boolean);\r\n    function UseRightToLeftReading: Boolean;\r\n    procedure ValidateChildren(Node: PVirtualNode; Recursive: Boolean);\r\n    procedure ValidateNode(Node: PVirtualNode; Recursive: Boolean);\r\n\r\n    { Enumerations }\r\n    function Nodes(ConsiderChildrenAbove: Boolean = False): TVTVirtualNodeEnumeration;\r\n    function CheckedNodes(State: TCheckState = csCheckedNormal; ConsiderChildrenAbove: Boolean = False): TVTVirtualNodeEnumeration;\r\n    function ChildNodes(Node: PVirtualNode): TVTVirtualNodeEnumeration;\r\n    function CutCopyNodes(ConsiderChildrenAbove: Boolean = False): TVTVirtualNodeEnumeration;\r\n    function InitializedNodes(ConsiderChildrenAbove: Boolean = False): TVTVirtualNodeEnumeration;\r\n    function LeafNodes: TVTVirtualNodeEnumeration;\r\n    function LevelNodes(NodeLevel: Cardinal): TVTVirtualNodeEnumeration;\r\n    function NoInitNodes(ConsiderChildrenAbove: Boolean = False): TVTVirtualNodeEnumeration;\r\n    function SelectedNodes(ConsiderChildrenAbove: Boolean = False): TVTVirtualNodeEnumeration;\r\n    function VisibleNodes(Node: PVirtualNode = nil; ConsiderChildrenAbove: Boolean = True;\r\n      IncludeFiltered: Boolean = False): TVTVirtualNodeEnumeration;\r\n    function VisibleChildNodes(Node: PVirtualNode; IncludeFiltered: Boolean = False): TVTVirtualNodeEnumeration;\r\n    function VisibleChildNoInitNodes(Node: PVirtualNode; IncludeFiltered: Boolean = False): TVTVirtualNodeEnumeration;\r\n    function VisibleNoInitNodes(Node: PVirtualNode = nil; ConsiderChildrenAbove: Boolean = True;\r\n      IncludeFiltered: Boolean = False): TVTVirtualNodeEnumeration;\r\n    property Accessible: IAccessible read FAccessible write FAccessible;\r\n    property AccessibleItem: IAccessible read FAccessibleItem write FAccessibleItem;\r\n    property AccessibleName: string read FAccessibleName write FAccessibleName;\r\n    property BottomNode: PVirtualNode read GetBottomNode write SetBottomNode;\r\n    property CheckedCount: Integer read GetCheckedCount;\r\n    property CheckImages: TCustomImageList read FCheckImages;\r\n    property CheckState[Node: PVirtualNode]: TCheckState read GetCheckState write SetCheckState;\r\n    property CheckType[Node: PVirtualNode]: TCheckType read GetCheckType write SetCheckType;\r\n    property ChildCount[Node: PVirtualNode]: Cardinal read GetChildCount write SetChildCount;\r\n    property ChildrenInitialized[Node: PVirtualNode]: Boolean read GetChildrenInitialized;\r\n    property CutCopyCount: Integer read GetCutCopyCount;\r\n    property DragImage: TVTDragImage read FDragImage;\r\n    property DragManager: IVTDragManager read GetDragManager;\r\n    property DropTargetNode: PVirtualNode read FDropTargetNode write FDropTargetNode;\r\n    property EditLink: IVTEditLink read FEditLink;\r\n    property EmptyListMessage: string read FEmptyListMessage write SetEmptyListMessage;\r\n    property Expanded[Node: PVirtualNode]: Boolean read GetExpanded write SetExpanded;\r\n    property FocusedColumn: TColumnIndex read FFocusedColumn write SetFocusedColumn default InvalidColumn;\r\n    property FocusedNode: PVirtualNode read FFocusedNode write SetFocusedNode;\r\n    property Font;\r\n    property FullyVisible[Node: PVirtualNode]: Boolean read GetFullyVisible write SetFullyVisible;\r\n    property HasChildren[Node: PVirtualNode]: Boolean read GetHasChildren write SetHasChildren;\r\n    property Header: TVTHeader read FHeader write SetHeader;\r\n    property HotNode: PVirtualNode read FCurrentHotNode;\r\n    property IsDisabled[Node: PVirtualNode]: Boolean read GetDisabled write SetDisabled;\r\n    property IsEffectivelyFiltered[Node: PVirtualNode]: Boolean read GetEffectivelyFiltered;\r\n    property IsEffectivelyVisible[Node: PVirtualNode]: Boolean read GetEffectivelyVisible;\r\n    property IsFiltered[Node: PVirtualNode]: Boolean read GetFiltered write SetFiltered;\r\n    property IsVisible[Node: PVirtualNode]: Boolean read GetVisible write SetVisible;\r\n    property MultiLine[Node: PVirtualNode]: Boolean read GetMultiline write SetMultiline;\r\n    property NodeHeight[Node: PVirtualNode]: Cardinal read GetNodeHeight write SetNodeHeight;\r\n    property NodeParent[Node: PVirtualNode]: PVirtualNode read GetNodeParent write SetNodeParent;\r\n    property OffsetX: Integer read FOffsetX write SetOffsetX;\r\n    property OffsetXY: TPoint read GetOffsetXY write SetOffsetXY;\r\n    property OffsetY: Integer read FOffsetY write SetOffsetY;\r\n    property OperationCount: Cardinal read FOperationCount;\r\n    property RootNode: PVirtualNode read FRoot;\r\n    property SearchBuffer: string read FSearchBuffer;\r\n    property Selected[Node: PVirtualNode]: Boolean read GetSelected write SetSelected;\r\n    property SelectionLocked: Boolean read FSelectionLocked write FSelectionLocked;\r\n    property TotalCount: Cardinal read GetTotalCount;\r\n    property TreeStates: TVirtualTreeStates read FStates write FStates;\r\n    property SelectedCount: Integer read FSelectionCount;\r\n    property TopNode: PVirtualNode read GetTopNode write SetTopNode;\r\n    property VerticalAlignment[Node: PVirtualNode]: Byte read GetVerticalAlignment write SetVerticalAlignment;\r\n    property VisibleCount: Cardinal read FVisibleCount;\r\n    property VisiblePath[Node: PVirtualNode]: Boolean read GetVisiblePath write SetVisiblePath;\r\n    property UpdateCount: Cardinal read FUpdateCount;\r\n    property DoubleBuffered: Boolean read GetDoubleBuffered write SetDoubleBuffered default True;\r\n  end;\r\n\r\n\r\n  // --------- TCustomVirtualStringTree\r\n\r\n  // Options regarding strings (useful only for the string tree and descendants):\r\n  TVTStringOption = (\r\n    toSaveCaptions,          // If set then the caption is automatically saved with the tree node, regardless of what is\r\n                             // saved in the user data.\r\n    toShowStaticText,        // Show static text in a caption which can be differently formatted than the caption\r\n                             // but cannot be edited.\r\n    toAutoAcceptEditChange   // Automatically accept changes during edit if the user finishes editing other then\r\n                             // VK_RETURN or ESC. If not set then changes are cancelled.\r\n  );\r\n  TVTStringOptions = set of TVTStringOption;\r\n\r\nconst\r\n  DefaultStringOptions = [toSaveCaptions, toAutoAcceptEditChange];\r\n\r\ntype\r\n  TCustomStringTreeOptions = class(TCustomVirtualTreeOptions)\r\n  private\r\n    FStringOptions: TVTStringOptions;\r\n    procedure SetStringOptions(const Value: TVTStringOptions);\r\n  protected\r\n    property StringOptions: TVTStringOptions read FStringOptions write SetStringOptions default DefaultStringOptions;\r\n  public\r\n    constructor Create(AOwner: TBaseVirtualTree); override;\r\n\r\n    procedure AssignTo(Dest: TPersistent); override;\r\n  end;\r\n\r\n  TStringTreeOptions = class(TCustomStringTreeOptions)\r\n  published\r\n    property AnimationOptions;\r\n    property AutoOptions;\r\n    property ExportMode;\r\n    property MiscOptions;\r\n    property PaintOptions;\r\n    property SelectionOptions;\r\n    property StringOptions;\r\n  end;\r\n\r\n  TCustomVirtualStringTree = class;\r\n\r\n  // Edit support Classes.\r\n  TStringEditLink = class;\r\n\r\n  TVTEdit = class(TCustomEdit)\r\n  private\r\n    procedure CMAutoAdjust(var Message: TMessage); message CM_AUTOADJUST;\r\n    procedure CMExit(var Message: TMessage); message CM_EXIT;\r\n    procedure CMRelease(var Message: TMessage); message CM_RELEASE;\r\n    procedure CNCommand(var Message: TWMCommand); message CN_COMMAND;\r\n    procedure WMChar(var Message: TWMChar); message WM_CHAR;\r\n    procedure WMDestroy(var Message: TWMDestroy); message WM_DESTROY;\r\n    procedure WMGetDlgCode(var Message: TWMGetDlgCode); message WM_GETDLGCODE;\r\n    procedure WMKeyDown(var Message: TWMKeyDown); message WM_KEYDOWN;\r\n  protected\r\n    FRefLink: IVTEditLink;\r\n    FLink: TStringEditLink;\r\n    procedure AutoAdjustSize; virtual;\r\n    procedure CreateParams(var Params: TCreateParams); override;\r\n  public\r\n    constructor Create(Link: TStringEditLink); reintroduce;\r\n\r\n    procedure Release; virtual;\r\n\r\n    property AutoSelect;\r\n    property AutoSize;\r\n    property BorderStyle;\r\n    property CharCase;\r\n    property HideSelection;\r\n    property MaxLength;\r\n    property OEMConvert;\r\n    property PasswordChar;\r\n  end;\r\n\r\n  TStringEditLink = class(TInterfacedObject, IVTEditLink)\r\n  private\r\n    FEdit: TVTEdit;                  // A normal custom edit control.\r\n  protected\r\n    FTree: TCustomVirtualStringTree; // A back reference to the tree calling.\r\n    FNode: PVirtualNode;             // The node to be edited.\r\n    FColumn: TColumnIndex;           // The column of the node.\r\n    FAlignment: TAlignment;\r\n    FTextBounds: TRect;              // Smallest rectangle around the text.\r\n    FStopping: Boolean;              // Set to True when the edit link requests stopping the edit action.\r\n    procedure SetEdit(const Value: TVTEdit); // Setter for the FEdit member;\r\n  public\r\n    constructor Create; virtual;\r\n    destructor Destroy; override;\r\n    property Node  : PVirtualNode read FNode; // [IPK] Make FNode accessible\r\n    property Column: TColumnIndex read FColumn; // [IPK] Make Column(Index) accessible \r\n\r\n    function BeginEdit: Boolean; virtual; stdcall;\r\n    function CancelEdit: Boolean; virtual; stdcall;\r\n    property Edit: TVTEdit read FEdit write SetEdit;\r\n    function EndEdit: Boolean; virtual; stdcall;\r\n    function GetBounds: TRect; virtual; stdcall;\r\n    function PrepareEdit(Tree: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex): Boolean; virtual; stdcall;\r\n    procedure ProcessMessage(var Message: TMessage); virtual; stdcall;\r\n    procedure SetBounds(R: TRect); virtual; stdcall;\r\n  end;\r\n\r\n  // Describes the type of text to return in the text and draw info retrival events.\r\n  TVSTTextType = (\r\n    ttNormal,      // normal label of the node, this is also the text which can be edited\r\n    ttStatic       // static (non-editable) text after the normal text\r\n  );\r\n\r\n  // Describes the source to use when converting a string tree into a string for clipboard etc.\r\n  TVSTTextSourceType = (\r\n    tstAll,             // All nodes are rendered. Initialization is done on the fly.\r\n    tstInitialized,     // Only initialized nodes are rendered.\r\n    tstSelected,        // Only selected nodes are rendered.\r\n    tstCutCopySet,      // Only nodes currently marked as being in the cut/copy clipboard set are rendered.\r\n    tstVisible,         // Only visible nodes are rendered.\r\n    tstChecked          // Only checked nodes are rendered\r\n  );\r\n\r\n  TVTPaintText = procedure(Sender: TBaseVirtualTree; const TargetCanvas: TCanvas; Node: PVirtualNode; Column: TColumnIndex;\r\n    TextType: TVSTTextType) of object;\r\n  TVSTGetTextEvent = procedure(Sender: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex;\r\n    TextType: TVSTTextType; var CellText: string) of object;\r\n  TVSTGetHintEvent = procedure(Sender: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex;\r\n    var LineBreakStyle: TVTTooltipLineBreakStyle; var HintText: string) of object;\r\n  // New text can only be set for variable caption.\r\n  TVSTNewTextEvent = procedure(Sender: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex;\r\n    NewText: string) of object;\r\n  TVSTShortenStringEvent = procedure(Sender: TBaseVirtualTree; TargetCanvas: TCanvas; Node: PVirtualNode;\r\n    Column: TColumnIndex; const S: string; TextSpace: Integer; var Result: string;\r\n    var Done: Boolean) of object;\r\n  TVTMeasureTextEvent = procedure(Sender: TBaseVirtualTree; TargetCanvas: TCanvas; Node: PVirtualNode;\r\n    Column: TColumnIndex; const Text: string; var Extent: Integer) of object;\r\n  TVTDrawTextEvent = procedure(Sender: TBaseVirtualTree; TargetCanvas: TCanvas; Node: PVirtualNode;\r\n    Column: TColumnIndex; const Text: string; const CellRect: TRect; var DefaultDraw: Boolean) of object;\r\n\r\n  /// Event arguments of the OnGetCellText event\r\n  TVSTGetCellTextEventArgs = record\r\n    Node: PVirtualNode;\r\n    Column: TColumnIndex;\r\n    CellText: string;\r\n    StaticText: string;\r\n    ExportType: TVTExportType;\r\n    constructor Create(pNode: PVirtualNode; pColumn: TColumnIndex; pExportType: TVTExportType = TVTExportType.etNone);\r\n  end;\r\n\r\n  /// Event signature which is called when text is painted on the canvas or needed for the export.\r\n  TVSTGetCellTextEvent = procedure(Sender: TCustomVirtualStringTree; var E: TVSTGetCellTextEventArgs) of object;\r\n\r\n  TCustomVirtualStringTree = class(TBaseVirtualTree)\r\n  private\r\n    FInternalDataOffset: Cardinal;        // offset to the internal data of the string tree\r\n    FDefaultText: string;                   // text to show if there's no OnGetText event handler (e.g. at design time)\r\n    FTextHeight: Integer;                          // true size of the font\r\n    FEllipsisWidth: Integer;                       // width of '...' for the current font\r\n\r\n    FOnPaintText: TVTPaintText;                    // triggered before either normal or fixed text is painted to allow\r\n                                                   // even finer customization (kind of sub cell painting)\r\n    FOnGetText: TVSTGetTextEvent;                  // used to retrieve the string to be displayed for a specific node\r\n    fOnGetCellText: TVSTGetCellTextEvent;             // used to retrieve the normal and static text of a tree node\r\n    FOnGetHint: TVSTGetHintEvent;                  // used to retrieve the hint to be displayed for a specific node\r\n    FOnNewText: TVSTNewTextEvent;                  // used to notify the application about an edited node caption\r\n    FOnShortenString: TVSTShortenStringEvent;      // used to allow the application a customized string shortage\r\n    FOnMeasureTextWidth: TVTMeasureTextEvent;      // used to adjust the width of the cells\r\n    FOnMeasureTextHeight: TVTMeasureTextEvent;\r\n    FOnDrawText: TVTDrawTextEvent;                 // used to custom draw the node text\r\n    function GetImageText(Node: PVirtualNode; Kind: TVTImageKind;\r\n      Column: TColumnIndex): string;\r\n    function GetOptions: TCustomStringTreeOptions;\r\n    function GetStaticText(Node: PVirtualNode; Column: TColumnIndex): string;\r\n    function GetText(Node: PVirtualNode; Column: TColumnIndex): string;\r\n    procedure ReadText(Reader: TReader);\r\n    procedure ResetInternalData(Node: PVirtualNode; Recursive: Boolean);\r\n    procedure SetDefaultText(const Value: string);\r\n    procedure SetOptions(const Value: TCustomStringTreeOptions);\r\n    procedure SetText(Node: PVirtualNode; Column: TColumnIndex; const Value: string);\r\n    procedure WriteText(Writer: TWriter);\r\n\r\n    procedure WMSetFont(var Msg: TWMSetFont); message WM_SETFONT;\r\n    procedure GetDataFromGrid(const AStrings : TStringList; const IncludeHeading : Boolean = True);\r\n  protected\r\n    FPreviouslySelected: TStringList;\r\n    procedure InitializeTextProperties(var PaintInfo: TVTPaintInfo); // [IPK] - private to protected\r\n    procedure PaintNormalText(var PaintInfo: TVTPaintInfo; TextOutFlags: Integer; Text: string); virtual; // [IPK] - private to protected\r\n    procedure PaintStaticText(const PaintInfo: TVTPaintInfo; TextOutFlags: Integer; const Text: string); virtual; // [IPK] - private to protected\r\n    procedure AdjustPaintCellRect(var PaintInfo: TVTPaintInfo; var NextNonEmpty: TColumnIndex); override;\r\n    function CanExportNode(Node: PVirtualNode): Boolean;\r\n    function CalculateStaticTextWidth(Canvas: TCanvas; Node: PVirtualNode; Column: TColumnIndex; const Text: string): Integer; virtual;\r\n    function CalculateTextWidth(Canvas: TCanvas; Node: PVirtualNode; Column: TColumnIndex; const Text: string): Integer; virtual;\r\n    function ColumnIsEmpty(Node: PVirtualNode; Column: TColumnIndex): Boolean; override;\r\n    procedure DefineProperties(Filer: TFiler); override;\r\n    function DoCreateEditor(Node: PVirtualNode; Column: TColumnIndex): IVTEditLink; override;\r\n    function DoGetNodeHint(Node: PVirtualNode; Column: TColumnIndex; var LineBreakStyle: TVTTooltipLineBreakStyle): string; override;\r\n    function DoGetNodeTooltip(Node: PVirtualNode; Column: TColumnIndex; var LineBreakStyle: TVTTooltipLineBreakStyle): string; override;\r\n    function DoGetNodeExtraWidth(Node: PVirtualNode; Column: TColumnIndex; Canvas: TCanvas = nil): Integer; override;\r\n    function DoGetNodeWidth(Node: PVirtualNode; Column: TColumnIndex; Canvas: TCanvas = nil): Integer; override;\r\n    procedure DoGetText(var pEventArgs: TVSTGetCellTextEventArgs); virtual;\r\n    function DoIncrementalSearch(Node: PVirtualNode; const Text: string): Integer; override;\r\n    procedure DoNewText(Node: PVirtualNode; Column: TColumnIndex; const Text: string); virtual;\r\n    procedure DoPaintNode(var PaintInfo: TVTPaintInfo); override;\r\n    procedure DoPaintText(Node: PVirtualNode; const Canvas: TCanvas; Column: TColumnIndex;\r\n      TextType: TVSTTextType); virtual;\r\n    function DoShortenString(Canvas: TCanvas; Node: PVirtualNode; Column: TColumnIndex; const S: string; Width: Integer;\r\n      EllipsisWidth: Integer = 0): string; virtual;\r\n    procedure DoTextDrawing(var PaintInfo: TVTPaintInfo; const Text: string; CellRect: TRect; DrawFormat: Cardinal); virtual;\r\n    function DoTextMeasuring(Canvas: TCanvas; Node: PVirtualNode; Column: TColumnIndex; const Text: string): TSize; virtual;\r\n    function GetOptionsClass: TTreeOptionsClass; override;\r\n    procedure GetRenderStartValues(Source: TVSTTextSourceType; var Node: PVirtualNode;\r\n      var NextNodeProc: TGetNextNodeProc);\r\n    function InternalData(Node: PVirtualNode): Pointer;\r\n    procedure MainColumnChanged; override;\r\n    function ReadChunk(Stream: TStream; Version: Integer; Node: PVirtualNode; ChunkType,\r\n      ChunkSize: Integer): Boolean; override;\r\n    procedure ReadOldStringOptions(Reader: TReader);\r\n    function RenderOLEData(const FormatEtcIn: TFormatEtc; out Medium: TStgMedium; ForClipboard: Boolean): HResult; override;\r\n    procedure SetChildCount(Node: PVirtualNode; NewChildCount: Cardinal); override;\r\n    procedure WriteChunks(Stream: TStream; Node: PVirtualNode); override;\r\n\r\n    property DefaultText: string read FDefaultText write SetDefaultText stored False;\r\n    property EllipsisWidth: Integer read FEllipsisWidth;\r\n    property TreeOptions: TCustomStringTreeOptions read GetOptions write SetOptions;\r\n\r\n    property OnGetHint: TVSTGetHintEvent read FOnGetHint write FOnGetHint;\r\n    property OnGetText: TVSTGetTextEvent read FOnGetText write FOnGetText;\r\n    property OnGetCellText: TVSTGetCellTextEvent read fOnGetCellText write fOnGetCellText;\r\n    property OnNewText: TVSTNewTextEvent read FOnNewText write FOnNewText;\r\n    property OnPaintText: TVTPaintText read FOnPaintText write FOnPaintText;\r\n    property OnShortenString: TVSTShortenStringEvent read FOnShortenString write FOnShortenString;\r\n    property OnMeasureTextWidth: TVTMeasureTextEvent read FOnMeasureTextWidth write FOnMeasureTextWidth;\r\n    property OnMeasureTextHeight: TVTMeasureTextEvent read FOnMeasureTextHeight write FOnMeasureTextHeight;\r\n    property OnDrawText: TVTDrawTextEvent read FOnDrawText write FOnDrawText;\r\n  public\r\n    constructor Create(AOwner: TComponent); override;\r\n    destructor Destroy(); override;\r\n    function AddChild(Parent: PVirtualNode; UserData: Pointer = nil): PVirtualNode; override;\r\n    function ComputeNodeHeight(Canvas: TCanvas; Node: PVirtualNode; Column: TColumnIndex; S: string = ''): Integer; virtual;\r\n    function ContentToClipboard(Format: Word; Source: TVSTTextSourceType): HGLOBAL;\r\n    procedure ContentToCustom(Source: TVSTTextSourceType);\r\n    function ContentToHTML(Source: TVSTTextSourceType; const Caption: string = ''): String;\r\n    function ContentToRTF(Source: TVSTTextSourceType): RawByteString;\r\n    function ContentToText(Source: TVSTTextSourceType; Separator: Char): String; overload;\r\n    function ContentToUnicode(Source: TVSTTextSourceType; Separator: WideChar): string; overload; deprecated 'Use ContentToText instead';\r\n    function ContentToText(Source: TVSTTextSourceType; const Separator: string): string; overload;\r\n    procedure GetTextInfo(Node: PVirtualNode; Column: TColumnIndex; const AFont: TFont; var R: TRect;\r\n      var Text: string); override;\r\n    function InvalidateNode(Node: PVirtualNode): TRect; override;\r\n    function Path(Node: PVirtualNode; Column: TColumnIndex; Delimiter: Char): string;\r\n    procedure ReinitNode(Node: PVirtualNode; Recursive: Boolean); override;\r\n    procedure AddToSelection(Node: PVirtualNode); override;\r\n    procedure RemoveFromSelection(Node: PVirtualNode); override;\r\n    function SaveToCSVFile(const FileNameWithPath : TFileName; const IncludeHeading : Boolean) : Boolean;\r\n    property ImageText[Node: PVirtualNode; Kind: TVTImageKind; Column: TColumnIndex]: string read GetImageText;\r\n    property StaticText[Node: PVirtualNode; Column: TColumnIndex]: string read GetStaticText;\r\n    property Text[Node: PVirtualNode; Column: TColumnIndex]: string read GetText write SetText;\r\n  end;\r\n\r\n  [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n  TVirtualStringTree = class(TCustomVirtualStringTree)\r\n  private\r\n   \r\n    function GetOptions: TStringTreeOptions;\r\n    procedure SetOptions(const Value: TStringTreeOptions);\r\n  protected\r\n    function GetOptionsClass: TTreeOptionsClass; override;\r\n  public\r\n\r\n    property Canvas;\r\n    property RangeX;\r\n    property LastDragEffect;\r\n  published\r\n    property AccessibleName;\r\n    property Action;\r\n    property Align;\r\n    property Alignment;\r\n    property Anchors;\r\n    property AnimationDuration;\r\n    property AutoExpandDelay;\r\n    property AutoScrollDelay;\r\n    property AutoScrollInterval;\r\n    property Background;\r\n    property BackgroundOffsetX;\r\n    property BackgroundOffsetY;\r\n    property BiDiMode;\r\n    property BevelEdges;\r\n    property BevelInner;\r\n    property BevelOuter;\r\n    property BevelKind;\r\n    property BevelWidth;\r\n    property BorderStyle;\r\n    property BottomSpace;\r\n    property ButtonFillMode;\r\n    property ButtonStyle;\r\n    property BorderWidth;\r\n    property ChangeDelay;\r\n    property CheckImageKind;\r\n    property ClipboardFormats;\r\n    property Color;\r\n    property Colors;\r\n    property Constraints;\r\n    property Ctl3D;\r\n    property CustomCheckImages;\r\n    property DefaultNodeHeight;\r\n    property DefaultPasteMode;\r\n    property DefaultText;\r\n    property DragCursor;\r\n    property DragHeight;\r\n    property DragKind;\r\n    property DragImageKind;\r\n    property DragMode;\r\n    property DragOperations;\r\n    property DragType;\r\n    property DragWidth;\r\n    property DrawSelectionMode;\r\n    property EditDelay;\r\n    property EmptyListMessage;\r\n    property Enabled;\r\n    property Font;\r\n    property Header;\r\n    property HintAnimation;\r\n    property HintMode;\r\n    property HotCursor;\r\n    property Images;\r\n    property IncrementalSearch;\r\n    property IncrementalSearchDirection;\r\n    property IncrementalSearchStart;\r\n    property IncrementalSearchTimeout;\r\n    property Indent;\r\n    property LineMode;\r\n    property LineStyle;\r\n    property Margin;\r\n    property NodeAlignment;\r\n    property NodeDataSize;\r\n    property OperationCanceled;\r\n    property ParentBiDiMode;\r\n    property ParentColor default False;\r\n    property ParentCtl3D;\r\n    property ParentFont;\r\n    property ParentShowHint;\r\n    property PopupMenu;\r\n    property RootNodeCount;\r\n    property ScrollBarOptions;\r\n    property SelectionBlendFactor;\r\n    property SelectionCurveRadius;\r\n    property ShowHint;\r\n    property StateImages;\r\n    property StyleElements;\r\n    property TabOrder;\r\n    property TabStop default True;\r\n    property TextMargin;\r\n    property TreeOptions: TStringTreeOptions read GetOptions write SetOptions;\r\n    property Visible;\r\n    property WantTabs;\r\n\r\n    property OnAddToSelection;\r\n    property OnAdvancedHeaderDraw;\r\n    property OnAfterAutoFitColumn;\r\n    property OnAfterAutoFitColumns;\r\n    property OnAfterCellPaint;\r\n    property OnAfterColumnExport;\r\n    property OnAfterColumnWidthTracking;\r\n    property OnAfterGetMaxColumnWidth;\r\n    property OnAfterHeaderExport;\r\n    property OnAfterHeaderHeightTracking;\r\n    property OnAfterItemErase;\r\n    property OnAfterItemPaint;\r\n    property OnAfterNodeExport;\r\n    property OnAfterPaint;\r\n    property OnAfterTreeExport;\r\n    property OnBeforeAutoFitColumn;\r\n    property OnBeforeAutoFitColumns;\r\n    property OnBeforeCellPaint;\r\n    property OnBeforeColumnExport;\r\n    property OnBeforeColumnWidthTracking;\r\n    property OnBeforeDrawTreeLine;\r\n    property OnBeforeGetMaxColumnWidth;\r\n    property OnBeforeHeaderExport;\r\n    property OnBeforeHeaderHeightTracking;\r\n    property OnBeforeItemErase;\r\n    property OnBeforeItemPaint;\r\n    property OnBeforeNodeExport;\r\n    property OnBeforePaint;\r\n    property OnBeforeTreeExport;\r\n    property OnCanSplitterResizeColumn;\r\n    property OnCanSplitterResizeHeader;\r\n    property OnCanSplitterResizeNode;\r\n    property OnChange;\r\n    property OnChecked;\r\n    property OnChecking;\r\n    property OnClick;\r\n    property OnCollapsed;\r\n    property OnCollapsing;\r\n    property OnColumnClick;\r\n    property OnColumnDblClick;\r\n    property OnColumnExport;\r\n    property OnColumnResize;\r\n    property OnColumnVisibilityChanged;\r\n    property OnColumnWidthDblClickResize;\r\n    property OnColumnWidthTracking;\r\n    property OnCompareNodes;\r\n    property OnContextPopup;\r\n    property OnCreateDataObject;\r\n    property OnCreateDragManager;\r\n    property OnCreateEditor;\r\n    property OnDblClick;\r\n    property OnDragAllowed;\r\n    property OnDragOver;\r\n    property OnDragDrop;\r\n    property OnDrawHint;\r\n    property OnDrawText;\r\n    property OnEditCancelled;\r\n    property OnEdited;\r\n    property OnEditing;\r\n    property OnEndDock;\r\n    property OnEndDrag;\r\n    property OnEndOperation;\r\n    property OnEnter;\r\n    property OnExit;\r\n    property OnExpanded;\r\n    property OnExpanding;\r\n    property OnFocusChanged;\r\n    property OnFocusChanging;\r\n    property OnFreeNode;\r\n    property OnGetCellText;\r\n    property OnGetCellIsEmpty;\r\n    property OnGetCursor;\r\n    property OnGetHeaderCursor;\r\n    property OnGetText;\r\n    property OnPaintText;\r\n    property OnGetHelpContext;\r\n    property OnGetHintKind;\r\n    property OnGetHintSize;\r\n    property OnGetImageIndex;\r\n    property OnGetImageIndexEx;\r\n    property OnGetImageText;\r\n    property OnGetHint;\r\n    property OnGetLineStyle;\r\n    property OnGetNodeDataSize;\r\n    property OnGetPopupMenu;\r\n    property OnGetUserClipboardFormats;\r\n    property OnHeaderClick;\r\n    property OnHeaderDblClick;\r\n    property OnHeaderDragged;\r\n    property OnHeaderDraggedOut;\r\n    property OnHeaderDragging;\r\n    property OnHeaderDraw;\r\n    property OnHeaderDrawQueryElements;\r\n    property OnHeaderHeightDblClickResize;\r\n    property OnHeaderHeightTracking;\r\n    property OnHeaderMouseDown;\r\n    property OnHeaderMouseMove;\r\n    property OnHeaderMouseUp;\r\n    property OnHotChange;\r\n    property OnIncrementalSearch;\r\n    property OnInitChildren;\r\n    property OnInitNode;\r\n    property OnKeyAction;\r\n    property OnKeyDown;\r\n    property OnKeyPress;\r\n    property OnKeyUp;\r\n    property OnLoadNode;\r\n    property OnLoadTree;\r\n    property OnMeasureItem;\r\n    property OnMeasureTextWidth;\r\n    property OnMeasureTextHeight;\r\n    property OnMouseDown;\r\n    property OnMouseMove;\r\n    property OnMouseUp;\r\n    property OnMouseWheel;\r\n    property OnMouseEnter;\r\n    property OnMouseLeave;\r\n    property OnNewText;\r\n    property OnNodeClick;\r\n    property OnNodeCopied;\r\n    property OnNodeCopying;\r\n    property OnNodeDblClick;\r\n    property OnNodeExport;\r\n    property OnNodeHeightDblClickResize;\r\n    property OnNodeHeightTracking;\r\n    property OnNodeMoved;\r\n    property OnNodeMoving;\r\n    property OnPaintBackground;\r\n    property OnPrepareButtonBitmaps;\r\n    property OnRemoveFromSelection;\r\n    property OnRenderOLEData;\r\n    property OnResetNode;\r\n    property OnResize;\r\n    property OnSaveNode;\r\n    property OnSaveTree;\r\n    property OnScroll;\r\n    property OnShortenString;\r\n    property OnShowScrollBar;\r\n    property OnStartDock;\r\n    property OnStartDrag;\r\n    property OnStartOperation;\r\n    property OnStateChange;\r\n    property OnStructureChange;\r\n    property OnUpdating;\r\n    property OnCanResize;\r\n    property OnGesture;\r\n    property Touch;\r\n  end;\r\n\r\n  TVTDrawNodeEvent = procedure(Sender: TBaseVirtualTree; const PaintInfo: TVTPaintInfo) of object;\r\n  TVTGetCellContentMarginEvent = procedure(Sender: TBaseVirtualTree; HintCanvas: TCanvas; Node: PVirtualNode;\r\n    Column: TColumnIndex; CellContentMarginType: TVTCellContentMarginType; var CellContentMargin: TPoint) of object;\r\n  TVTGetNodeWidthEvent = procedure(Sender: TBaseVirtualTree; HintCanvas: TCanvas; Node: PVirtualNode;\r\n    Column: TColumnIndex; var NodeWidth: Integer) of object;\r\n\r\n  // Tree descendant to let an application draw its stuff itself.\r\n  TCustomVirtualDrawTree = class(TBaseVirtualTree)\r\n  private\r\n    FOnDrawNode: TVTDrawNodeEvent;\r\n    FOnGetCellContentMargin: TVTGetCellContentMarginEvent;\r\n    FOnGetNodeWidth: TVTGetNodeWidthEvent;\r\n  protected\r\n    function DoGetCellContentMargin(Node: PVirtualNode; Column: TColumnIndex;\r\n      CellContentMarginType: TVTCellContentMarginType = ccmtAllSides; Canvas: TCanvas = nil): TPoint; override;\r\n    function DoGetNodeWidth(Node: PVirtualNode; Column: TColumnIndex; Canvas: TCanvas = nil): Integer; override;\r\n    procedure DoPaintNode(var PaintInfo: TVTPaintInfo); override;\r\n    function GetDefaultHintKind: TVTHintKind; override;\r\n\r\n    property OnDrawNode: TVTDrawNodeEvent read FOnDrawNode write FOnDrawNode;\r\n    property OnGetCellContentMargin: TVTGetCellContentMarginEvent read FOnGetCellContentMargin write FOnGetCellContentMargin;\r\n    property OnGetNodeWidth: TVTGetNodeWidthEvent read FOnGetNodeWidth write FOnGetNodeWidth;\r\n  end;\r\n\r\n  [ComponentPlatformsAttribute(pidWin32 or pidWin64)]\r\n  TVirtualDrawTree = class(TCustomVirtualDrawTree)\r\n  private\r\n    function GetOptions: TVirtualTreeOptions;\r\n    procedure SetOptions(const Value: TVirtualTreeOptions);\r\n  protected\r\n    function GetOptionsClass: TTreeOptionsClass; override;\r\n  public\r\n    property Canvas;\r\n    property LastDragEffect;\r\n  published\r\n    property Action;\r\n    property Align;\r\n    property Alignment;\r\n    property Anchors;\r\n    property AnimationDuration;\r\n    property AutoExpandDelay;\r\n    property AutoScrollDelay;\r\n    property AutoScrollInterval;\r\n    property Background;\r\n    property BackgroundOffsetX;\r\n    property BackgroundOffsetY;\r\n    property BiDiMode;\r\n    property BevelEdges;\r\n    property BevelInner;\r\n    property BevelOuter;\r\n    property BevelKind;\r\n    property BevelWidth;\r\n    property BorderStyle;\r\n    property BottomSpace;\r\n    property ButtonFillMode;\r\n    property ButtonStyle;\r\n    property BorderWidth;\r\n    property ChangeDelay;\r\n    property CheckImageKind;\r\n    property ClipboardFormats;\r\n    property Color;\r\n    property Colors;\r\n    property Constraints;\r\n    property Ctl3D;\r\n    property CustomCheckImages;\r\n    property DefaultNodeHeight;\r\n    property DefaultPasteMode;\r\n    property DragCursor;\r\n    property DragHeight;\r\n    property DragKind;\r\n    property DragImageKind;\r\n    property DragMode;\r\n    property DragOperations;\r\n    property DragType;\r\n    property DragWidth;\r\n    property DrawSelectionMode;\r\n    property EditDelay;\r\n    property Enabled;\r\n    property Font;\r\n    property Header;\r\n    property HintAnimation;\r\n    property HintMode;\r\n    property HotCursor;\r\n    property Images;\r\n    property IncrementalSearch;\r\n    property IncrementalSearchDirection;\r\n    property IncrementalSearchStart;\r\n    property IncrementalSearchTimeout;\r\n    property Indent;\r\n    property LineMode;\r\n    property LineStyle;\r\n    property Margin;\r\n    property NodeAlignment;\r\n    property NodeDataSize;\r\n    property OperationCanceled;\r\n    property ParentBiDiMode;\r\n    property ParentColor default False;\r\n    property ParentCtl3D;\r\n    property ParentFont;\r\n    property ParentShowHint;\r\n    property PopupMenu;\r\n    property RootNodeCount;\r\n    property ScrollBarOptions;\r\n    property SelectionBlendFactor;\r\n    property SelectionCurveRadius;\r\n    property ShowHint;\r\n    property StateImages;\r\n    property TabOrder;\r\n    property TabStop default True;\r\n    property TextMargin;\r\n    property TreeOptions: TVirtualTreeOptions read GetOptions write SetOptions;\r\n    property Visible;\r\n    property WantTabs;\r\n\r\n    property OnAddToSelection;\r\n    property OnAdvancedHeaderDraw;\r\n    property OnAfterAutoFitColumn;\r\n    property OnAfterAutoFitColumns;\r\n    property OnAfterCellPaint;\r\n    property OnAfterColumnExport;\r\n    property OnAfterColumnWidthTracking;\r\n    property OnAfterGetMaxColumnWidth;\r\n    property OnAfterHeaderExport;\r\n    property OnAfterHeaderHeightTracking;\r\n    property OnAfterItemErase;\r\n    property OnAfterItemPaint;\r\n    property OnAfterNodeExport;\r\n    property OnAfterPaint;\r\n    property OnAfterTreeExport;\r\n    property OnBeforeAutoFitColumn;\r\n    property OnBeforeAutoFitColumns;\r\n    property OnBeforeCellPaint;\r\n    property OnBeforeColumnExport;\r\n    property OnBeforeColumnWidthTracking;\r\n    property OnBeforeDrawTreeLine;\r\n    property OnBeforeGetMaxColumnWidth;\r\n    property OnBeforeHeaderExport;\r\n    property OnBeforeHeaderHeightTracking;\r\n    property OnBeforeItemErase;\r\n    property OnBeforeItemPaint;\r\n    property OnBeforeNodeExport;\r\n    property OnBeforePaint;\r\n    property OnBeforeTreeExport;\r\n    property OnCanSplitterResizeColumn;\r\n    property OnCanSplitterResizeHeader;\r\n    property OnCanSplitterResizeNode;\r\n    property OnChange;\r\n    property OnChecked;\r\n    property OnChecking;\r\n    property OnClick;\r\n    property OnCollapsed;\r\n    property OnCollapsing;\r\n    property OnColumnClick;\r\n    property OnColumnDblClick;\r\n    property OnColumnExport;\r\n    property OnColumnResize;\r\n    property OnColumnVisibilityChanged;\r\n    property OnColumnWidthDblClickResize;\r\n    property OnColumnWidthTracking;\r\n    property OnCompareNodes;\r\n    property OnContextPopup;\r\n    property OnCreateDataObject;\r\n    property OnCreateDragManager;\r\n    property OnCreateEditor;\r\n    property OnDblClick;\r\n    property OnDragAllowed;\r\n    property OnDragOver;\r\n    property OnDragDrop;\r\n    property OnDrawHint;\r\n    property OnDrawNode;\r\n    property OnEdited;\r\n    property OnEditing;\r\n    property OnEndDock;\r\n    property OnEndDrag;\r\n    property OnEndOperation;\r\n    property OnEnter;\r\n    property OnExit;\r\n    property OnExpanded;\r\n    property OnExpanding;\r\n    property OnFocusChanged;\r\n    property OnFocusChanging;\r\n    property OnFreeNode;\r\n    property OnGetCellIsEmpty;\r\n    property OnGetCursor;\r\n    property OnGetHeaderCursor;\r\n    property OnGetHelpContext;\r\n    property OnGetHintKind;\r\n    property OnGetHintSize;\r\n    property OnGetImageIndex;\r\n    property OnGetImageIndexEx;\r\n    property OnGetLineStyle;\r\n    property OnGetNodeDataSize;\r\n    property OnGetNodeWidth;\r\n    property OnGetPopupMenu;\r\n    property OnGetUserClipboardFormats;\r\n    property OnHeaderClick;\r\n    property OnHeaderDblClick;\r\n    property OnHeaderDragged;\r\n    property OnHeaderDraggedOut;\r\n    property OnHeaderDragging;\r\n    property OnHeaderDraw;\r\n    property OnHeaderDrawQueryElements;\r\n    property OnHeaderHeightTracking;\r\n    property OnHeaderHeightDblClickResize;\r\n    property OnHeaderMouseDown;\r\n    property OnHeaderMouseMove;\r\n    property OnHeaderMouseUp;\r\n    property OnHotChange;\r\n    property OnIncrementalSearch;\r\n    property OnInitChildren;\r\n    property OnInitNode;\r\n    property OnKeyAction;\r\n    property OnKeyDown;\r\n    property OnKeyPress;\r\n    property OnKeyUp;\r\n    property OnLoadNode;\r\n    property OnLoadTree;\r\n    property OnMeasureItem;\r\n    property OnMouseDown;\r\n    property OnMouseMove;\r\n    property OnMouseUp;\r\n    property OnMouseWheel;\r\n    property OnNodeClick;\r\n    property OnNodeCopied;\r\n    property OnNodeCopying;\r\n    property OnNodeDblClick;\r\n    property OnNodeExport;\r\n    property OnNodeHeightTracking;\r\n    property OnNodeHeightDblClickResize;\r\n    property OnNodeMoved;\r\n    property OnNodeMoving;\r\n    property OnPaintBackground;\r\n    property OnPrepareButtonBitmaps;\r\n    property OnRemoveFromSelection;\r\n    property OnRenderOLEData;\r\n    property OnResetNode;\r\n    property OnResize;\r\n    property OnSaveNode;\r\n    property OnSaveTree;\r\n    property OnScroll;\r\n    property OnShowScrollBar;\r\n    property OnStartDock;\r\n    property OnStartDrag;\r\n    property OnStartOperation;\r\n    property OnStateChange;\r\n    property OnStructureChange;\r\n    property OnUpdating;\r\n    property OnCanResize;\r\n    property OnGesture;\r\n    property Touch;\r\n    property StyleElements;\r\n  end;\r\n\r\n\r\n\r\n// utility routines\r\nfunction TreeFromNode(Node: PVirtualNode): TBaseVirtualTree;\r\n\r\nfunction GetUtilityImages: TCustomImageList;\r\nprocedure ShowError(const Msg: string; HelpContext: Integer);  // [IPK] Surface this to interface\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nimplementation\r\n\r\n{$R VirtualTrees.res}\r\n\r\nuses\r\n  Vcl.Consts,\r\n  System.Math,\r\n  Vcl.AxCtrls,                 // TOLEStream\r\n  Winapi.MMSystem,             // for animation timer (does not include further resources)\r\n  System.TypInfo,              // for migration stuff\r\n  Vcl.ActnList,\r\n  Vcl.StdActns,                // for standard action support\r\n  System.StrUtils,\r\n  VTAccessibilityFactory,\r\n  Vcl.GraphUtil,               // accessibility helper class\r\n  VirtualTrees.StyleHooks,\r\n  VirtualTrees.Classes,\r\n  VirtualTrees.WorkerThread,\r\n  VirtualTrees.ClipBoard,\r\n  VirtualTrees.Utils, VTHeaderPopup, VirtualTrees.Export;\r\n\r\n\r\nresourcestring\r\n  // Localizable strings.\r\n  SEditLinkIsNil = 'Edit link must not be nil.';\r\n  SWrongMoveError = 'Target node cannot be a child node of the node to be moved.';\r\n  SWrongStreamFormat = 'Unable to load tree structure, the format is wrong.';\r\n  SWrongStreamVersion = 'Unable to load tree structure, the version is unknown.';\r\n  SStreamTooSmall = 'Unable to load tree structure, not enough data available.';\r\n  SCorruptStream1 = 'Stream data corrupt. A node''s anchor chunk is missing.';\r\n  SCorruptStream2 = 'Stream data corrupt. Unexpected data after node''s end position.';\r\n  SClipboardFailed = 'Clipboard operation failed.';\r\n\r\nconst\r\n  ClipboardStates = [tsCopyPending, tsCutPending];\r\n  DefaultScrollUpdateFlags = [suoRepaintHeader, suoRepaintScrollBars, suoScrollClientArea, suoUpdateNCArea];\r\n  TreeNodeSize = (SizeOf(TVirtualNode) + (SizeOf(Pointer) - 1)) and not (SizeOf(Pointer) - 1); // used for node allocation and access to internal data\r\n\r\n  // Lookup to quickly convert a specific check state into its pressed counterpart and vice versa.\r\n  PressedState: array[TCheckState] of TCheckState = (\r\n    csUncheckedPressed, csUncheckedPressed, csCheckedPressed, csCheckedPressed, csMixedPressed, csMixedPressed\r\n  );\r\n  UnpressedState: array[TCheckState] of TCheckState = (\r\n    csUncheckedNormal, csUncheckedNormal, csCheckedNormal, csCheckedNormal, csMixedNormal, csMixedNormal\r\n  );\r\n  MouseButtonDown = [tsLeftButtonDown, tsMiddleButtonDown, tsRightButtonDown];\r\n\r\n  // Do not modify the copyright in any way! Usage of this unit is prohibited without the copyright notice\r\n  // in the compiled binary file.\r\n  Copyright: string = 'Virtual Treeview  1999, 2010 Mike Lischke';\r\n\r\nvar\r\n  StandardOLEFormat: TFormatEtc = (\r\n    // Format must later be set.\r\n    cfFormat: 0;\r\n    // No specific target device to render on.\r\n    ptd: nil;\r\n    // Normal content to render.\r\n    dwAspect: DVASPECT_CONTENT;\r\n    // No specific page of multipage data (we don't use multipage data by default).\r\n    lindex: -1;\r\n    // Acceptable storage formats are IStream and global memory. The first is preferred.\r\n    tymed: TYMED_ISTREAM or TYMED_HGLOBAL;\r\n  );\r\n\r\ntype\r\n  // protection against TRect record method that cause problems with with-statements\r\n  TWithSafeRect = record\r\n    case Integer of\r\n      0: (Left, Top, Right, Bottom: Integer);\r\n      1: (TopLeft, BottomRight: TPoint);\r\n  end;\r\n\r\ntype // streaming support\r\n  TMagicID = array[0..5] of WideChar;\r\n\r\n  TChunkHeader = record\r\n    ChunkType,\r\n    ChunkSize: Integer;      // contains the size of the chunk excluding the header\r\n  end;\r\n\r\n  // base information about a node\r\n  TBaseChunkBody = packed record\r\n    ChildCount,\r\n    NodeHeight: Cardinal;\r\n    States: TVirtualNodeStates;\r\n    Align: Byte;\r\n    CheckState: TCheckState;\r\n    CheckType: TCheckType;\r\n    Reserved: Cardinal;\r\n  end;\r\n\r\n  TBaseChunk = packed record\r\n    Header: TChunkHeader;\r\n    Body: TBaseChunkBody;\r\n  end;\r\n\r\n  // Toggle animation modes.\r\n  TToggleAnimationMode = (\r\n    tamScrollUp,\r\n    tamScrollDown,\r\n    tamNoScroll\r\n  );\r\n\r\n  // Internally used data for animations.\r\n  TToggleAnimationData = record\r\n    Window: HWND;                 // copy of the tree's window handle\r\n    DC: HDC;                      // the DC of the window to erase uncovered parts\r\n    Brush: HBRUSH;                // the brush to be used to erase uncovered parts\r\n    R1,\r\n    R2: TRect;                    // animation rectangles\r\n    Mode1,\r\n    Mode2: TToggleAnimationMode;  // animation modes\r\n    ScaleFactor: Double;          // the factor between the missing step size when doing two animations\r\n    MissedSteps: Double;\r\n  end;\r\n\r\n  TCanvasEx = class(TCanvas);\r\n\r\nconst\r\n  MagicID: TMagicID = (#$2045, 'V', 'T', WideChar(VTTreeStreamVersion), ' ', #$2046);\r\n\r\n  // chunk IDs\r\n  NodeChunk = 1;\r\n  BaseChunk = 2;        // chunk containing node state, check state, child node count etc.\r\n                        // this chunk is immediately followed by all child nodes\r\n  CaptionChunk = 3;     // used by the string tree to store a node's caption\r\n  UserChunk = 4;        // used for data supplied by the application\r\n\r\n  RTLFlag: array[Boolean] of Integer = (0, ETO_RTLREADING);\r\n  AlignmentToDrawFlag: array[TAlignment] of Cardinal = (DT_LEFT, DT_RIGHT, DT_CENTER);\r\n\r\n  WideCR = Char(#13);\r\n  WideLF = Char(#10);\r\n\r\nvar\r\n  Watcher: TCriticalSection;\r\n  LightCheckImages,                    // global light check images\r\n  DarkCheckImages,                     // global heavy check images\r\n  LightTickImages,                     // global light tick images\r\n  DarkTickImages,                      // global heavy check images\r\n  FlatImages,                          // global flat check images\r\n  XPImages,                            // global XP style check images\r\n  UtilityImages,                       // some small additional images (e.g for header dragging)\r\n  SystemCheckImages,                   // global system check images\r\n  SystemFlatCheckImages: TImageList;   // global flat system check images\r\n  Initialized: Boolean = False;        // True if global structures have been initialized.\r\n  NeedToUnitialize: Boolean = False;   // True if the OLE subsystem could be initialized successfully.\r\n\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\n\r\n//----------------- utility functions ----------------------------------------------------------------------------------\r\n\r\nfunction GetUtilityImages: TCustomImageList; // [IPK]\r\n\r\nbegin\r\n  Result := UtilityImages; \r\nend; \r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure ShowError(const Msg: string; HelpContext: Integer);\r\n\r\nbegin\r\n  raise EVirtualTreeError.CreateHelp(Msg, HelpContext);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TreeFromNode(Node: PVirtualNode): TBaseVirtualTree;\r\n\r\n// Returns the tree the node currently belongs to or nil if the node is not attached to a tree.\r\n\r\nbegin\r\n  Assert(Assigned(Node), 'Node must not be nil.');\r\n\r\n  // The root node is marked by having its NextSibling (and PrevSibling) pointing to itself.\r\n  while Assigned(Node) and (Node.NextSibling <> Node) do\r\n    Node := Node.Parent;\r\n  if Assigned(Node) then\r\n    Result := TBaseVirtualTree(Node.Parent)\r\n  else\r\n    Result := nil;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\n\r\nprocedure QuickSort(const TheArray: TNodeArray; L, R: Integer);\r\n\r\nvar\r\n  I, J: Integer;\r\n  P, T: Pointer;\r\n\r\nbegin\r\n  repeat\r\n    I := L;\r\n    J := R;\r\n    P := TheArray[(L + R) shr 1];\r\n    repeat\r\n      while PAnsiChar(TheArray[I]) < PAnsiChar(P) do\r\n        Inc(I);\r\n      while PAnsiChar(TheArray[J]) > PAnsiChar(P) do\r\n        Dec(J);\r\n      if I <= J then\r\n      begin\r\n        T := TheArray[I];\r\n        TheArray[I] := TheArray[J];\r\n        TheArray[J] := T;\r\n        Inc(I);\r\n        Dec(J);\r\n      end;\r\n    until I > J;\r\n    if L < J then\r\n      QuickSort(TheArray, L, J);\r\n    L := I;\r\n  until I >= R;\r\nend;\r\n\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\n\r\n\r\n\r\nconst\r\n  Grays: array[0..3] of TColor = (clWhite, clSilver, clGray, clBlack);\r\n  SysGrays: array[0..3] of TColor = (clWindow, clBtnFace, clBtnShadow, clBtnText);\r\n\r\nprocedure ConvertImageList(IL: TImageList; const ImageName: string; ColorRemapping: Boolean = True);\r\n\r\n// Loads a bunch of images given by ImageName into IL. If ColorRemapping = True then a mapping of gray values to\r\n// system colors is performed.\r\n\r\nvar\r\n  Images,\r\n  OneImage: TBitmap;\r\n  I: Integer;\r\n  MaskColor: TColor;\r\n  Source,\r\n  Dest: TRect;\r\n\r\nbegin\r\n  Watcher.Enter;\r\n  try\r\n    // Since we want the image list appearing in the correct system colors, we have to remap its colors.\r\n    Images := TBitmap.Create;\r\n    OneImage := TBitmap.Create;\r\n    if ColorRemapping then\r\n      Images.Handle := CreateMappedRes(FindClassHInstance(TBaseVirtualTree), PChar(ImageName), Grays, SysGrays)\r\n    else\r\n      Images.Handle := LoadBitmap(FindClassHInstance(TBaseVirtualTree), PChar(ImageName));\r\n\r\n    try\r\n      Assert(Images.Height > 0, 'Internal image \"' + ImageName + '\" is missing or corrupt.');\r\n      if Images.Height = 0 then\r\n        Exit;// This should never happen, it prevents a division by zero exception below in the for loop, which we have seen in a few cases\r\n      // It is assumed that the image height determines also the width of one entry in the image list.\r\n      IL.Clear;\r\n      IL.Height := Images.Height;\r\n      IL.Width := Images.Height;\r\n      OneImage.Width := IL.Width;\r\n      OneImage.Height := IL.Height;\r\n      MaskColor := Images.Canvas.Pixels[0, 0]; // this is usually clFuchsia\r\n      Dest := Rect(0, 0, IL.Width, IL.Height);\r\n      for I := 0 to (Images.Width div Images.Height) - 1 do\r\n      begin\r\n        Source := Rect(I * IL.Width, 0, (I + 1) * IL.Width, IL.Height);\r\n        OneImage.Canvas.CopyRect(Dest, Images.Canvas, Source);\r\n        IL.AddMasked(OneImage, MaskColor);\r\n      end;\r\n    finally\r\n      Images.Free;\r\n      OneImage.Free;\r\n    end;\r\n  finally\r\n    Watcher.Leave;\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure CreateSystemImageSet(var IL: TImageList; Flags: Cardinal; Flat: Boolean);\r\n\r\n// Creates a system check image set.\r\n// Note: the DarkCheckImages and FlatImages image lists must already be filled, as some images from them are copied here.\r\n\r\nconst\r\n  MaskColor: TColor = clRed;\r\n\r\nvar\r\n  BM: TBitmap;\r\n\r\n  //--------------- local functions -------------------------------------------\r\n\r\n  procedure AddNodeImages(IL: TImageList);\r\n\r\n  var\r\n    I: Integer;\r\n    OffsetX,\r\n    OffsetY: Integer;\r\n\r\n  begin\r\n    // The offsets are used to center the node images in case the sizes differ.\r\n    OffsetX := (IL.Width - DarkCheckImages.Width) div 2;\r\n    OffsetY := (IL.Height - DarkCheckImages.Height) div 2;\r\n    for I := 21 to 24 do\r\n    begin\r\n      BM.Canvas.FillRect(Rect(0, 0, BM.Width, BM.Height));\r\n      if Flat then\r\n        FlatImages.Draw(BM.Canvas, OffsetX, OffsetY, I)\r\n      else\r\n        DarkCheckImages.Draw(BM.Canvas, OffsetX, OffsetY, I);\r\n      IL.AddMasked(BM, MaskColor);\r\n    end;\r\n  end;\r\n\r\n  //---------------------------------------------------------------------------\r\n\r\n  procedure AddSystemImage(IL: TImageList; Index: Integer);\r\n\r\n  var\r\n    ButtonState: Cardinal;\r\n    ButtonType: Cardinal;\r\n\r\n  begin\r\n    BM.Canvas.FillRect(Rect(0, 0, BM.Width, BM.Height));\r\n    if Index < 8 then\r\n      ButtonType := DFCS_BUTTONRADIO\r\n    else\r\n      ButtonType := DFCS_BUTTONCHECK;\r\n    if Index >= 16 then\r\n      ButtonType := ButtonType or DFCS_BUTTON3STATE;\r\n\r\n    case Index mod 4 of\r\n      0:\r\n        ButtonState := 0;\r\n      1:\r\n        ButtonState := DFCS_HOT;\r\n      2:\r\n        ButtonState := DFCS_PUSHED;\r\n      else\r\n        ButtonState := DFCS_INACTIVE;\r\n    end;\r\n    if Index in [4..7, 12..19] then\r\n      ButtonState := ButtonState or DFCS_CHECKED;\r\n    if Flat then\r\n      ButtonState := ButtonState or DFCS_FLAT;\r\n    DrawFrameControl(BM.Canvas.Handle, Rect(0, 0, BM.Width, BM.Height), DFC_BUTTON, ButtonType or ButtonState);\r\n    IL.AddMasked(BM, MaskColor);\r\n  end;\r\n\r\n  //--------------- end local functions ---------------------------------------\r\n\r\nvar\r\n  I, Width, Height: Integer;\r\n\r\nbegin\r\n  Width := GetSystemMetrics(SM_CXMENUCHECK);\r\n  Height := GetSystemMetrics(SM_CYMENUCHECK);\r\n  IL := TImageList.CreateSize(Width, Height);\r\n  with IL do\r\n    Handle := ImageList_Create(Width, Height, Flags, 0, AllocBy);\r\n  IL.Masked := True;\r\n  IL.BkColor := clWhite;\r\n\r\n  // Create a temporary bitmap, which holds the intermediate images.\r\n  BM := TBitmap.Create;\r\n  try\r\n    // Make the bitmap the same size as the image list is to avoid problems when adding.\r\n    BM.Width := IL.Width;\r\n    BM.Height := IL.Height;\r\n    BM.Canvas.Brush.Color := MaskColor;\r\n    BM.Canvas.Brush.Style := bsSolid;\r\n    BM.Canvas.FillRect(Rect(0, 0, BM.Width, BM.Height));\r\n    IL.AddMasked(BM, MaskColor);\r\n\r\n    // Add the 20 system checkbox and radiobutton images.\r\n    for I := 0 to 19 do\r\n      AddSystemImage(IL, I);\r\n    // Add the 4 node images from the dark check set.\r\n    AddNodeImages(IL);\r\n\r\n  finally\r\n    BM.Free;\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\n\r\n\r\n\r\n\r\nprocedure InitializeGlobalStructures;\r\n\r\n// initialization of stuff global to the unit\r\n\r\nvar\r\n  Flags: Cardinal;\r\n\r\nbegin\r\n  Initialized := True;\r\n\r\n  // For the drag image a fast MMX blend routine is used. We have to make sure MMX is available.\r\n  MMXAvailable := HasMMX;\r\n  IsWinVistaOrAbove := (Win32MajorVersion >= 6);\r\n\r\n  // Initialize OLE subsystem for drag'n drop and clipboard operations.\r\n  NeedToUnitialize := not IsLibrary and Succeeded(OleInitialize(nil));\r\n\r\n  // Register the tree reference clipboard format. Others will be handled in InternalClipboarFormats.\r\n  CF_VTREFERENCE := RegisterClipboardFormat(CFSTR_VTREFERENCE);\r\n\r\n  // Load all internal image lists and convert their colors to current desktop color scheme.\r\n  // In order to use high color images we have to create the image list handle ourselves.\r\n  Flags := ILC_COLOR32 or ILC_MASK;\r\n  LightCheckImages := TImageList.Create(nil);\r\n  with LightCheckImages do\r\n    Handle := ImageList_Create(16, 16, Flags, 0, AllocBy);\r\n  ConvertImageList(LightCheckImages, 'VT_CHECK_LIGHT');\r\n\r\n  DarkCheckImages := TImageList.CreateSize(16, 16);\r\n  with DarkCheckImages do\r\n    Handle := ImageList_Create(16, 16, Flags, 0, AllocBy);\r\n  ConvertImageList(DarkCheckImages, 'VT_CHECK_DARK');\r\n\r\n  LightTickImages := TImageList.CreateSize(16, 16);\r\n  with LightTickImages do\r\n    Handle := ImageList_Create(16, 16, Flags, 0, AllocBy);\r\n  ConvertImageList(LightTickImages, 'VT_TICK_LIGHT');\r\n\r\n  DarkTickImages := TImageList.CreateSize(16, 16);\r\n  with DarkTickImages do\r\n    Handle := ImageList_Create(16, 16, Flags, 0, AllocBy);\r\n  ConvertImageList(DarkTickImages, 'VT_TICK_DARK');\r\n\r\n  FlatImages := TImageList.CreateSize(16, 16);\r\n  with FlatImages do\r\n    Handle := ImageList_Create(16, 16, Flags, 0, AllocBy);\r\n  ConvertImageList(FlatImages, 'VT_FLAT');\r\n\r\n  XPImages := TImageList.CreateSize(16, 16);\r\n  with XPImages do\r\n    Handle := ImageList_Create(16, 16, Flags, 0, AllocBy);\r\n  ConvertImageList(XPImages, 'VT_XP', False);\r\n\r\n  UtilityImages := TImageList.CreateSize(UtilityImageSize, UtilityImageSize);\r\n  with UtilityImages do\r\n    Handle := ImageList_Create(UtilityImageSize, UtilityImageSize, Flags, 0, AllocBy);\r\n  ConvertImageList(UtilityImages, 'VT_UTILITIES');\r\n\r\n  CreateSystemImageSet(SystemCheckImages, Flags, False);\r\n  CreateSystemImageSet(SystemFlatCheckImages, Flags, True);\r\n\r\n  // Delphi (at least version 6 and lower) does not provide a standard split cursor.\r\n  // Hence we have to load our own.\r\n  Screen.Cursors[crHeaderSplit] := LoadCursor(HInstance, 'VT_HEADERSPLIT');\r\n  Screen.Cursors[crVertSplit] := LoadCursor(HInstance, 'VT_VERTSPLIT');\r\n\r\n  // Clipboard format registration.\r\n  // Native clipboard format. Needs a new identifier and has an average priority to allow other formats to take over.\r\n  // This format is supposed to use the IStream storage format but unfortunately this does not work when\r\n  // OLEFlushClipboard is used. Hence it is disabled until somebody finds a solution.\r\n  CF_VIRTUALTREE := RegisterVTClipboardFormat(CFSTR_VIRTUALTREE, TBaseVirtualTree, 50, TYMED_HGLOBAL {or TYMED_ISTREAM});\r\n  // Specialized string tree formats.\r\n  CF_HTML := RegisterVTClipboardFormat(CFSTR_HTML, TCustomVirtualStringTree, 80);\r\n  CF_VRTFNOOBJS := RegisterVTClipboardFormat(CFSTR_RTFNOOBJS, TCustomVirtualStringTree, 84);\r\n  CF_VRTF := RegisterVTClipboardFormat(CFSTR_RTF, TCustomVirtualStringTree, 85);\r\n  CF_CSV := RegisterVTClipboardFormat(CFSTR_CSV, TCustomVirtualStringTree, 90);\r\n  // Predefined clipboard formats. Just add them to the internal list.\r\n  RegisterVTClipboardFormat(CF_TEXT, TCustomVirtualStringTree, 100);\r\n  RegisterVTClipboardFormat(CF_UNICODETEXT, TCustomVirtualStringTree, 95);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure FinalizeGlobalStructures;\r\n\r\nvar\r\n  HintWasEnabled: Boolean;\r\n\r\nbegin\r\n  LightCheckImages.Free;\r\n  LightCheckImages := nil;\r\n  DarkCheckImages.Free;\r\n  DarkCheckImages := nil;\r\n  LightTickImages.Free;\r\n  LightTickImages := nil;\r\n  DarkTickImages.Free;\r\n  DarkTickImages := nil;\r\n  FlatImages.Free;\r\n  FlatImages := nil;\r\n  XPImages.Free;\r\n  XPImages := nil;\r\n  UtilityImages.Free;\r\n  UtilityImages := nil;\r\n  SystemCheckImages.Free;\r\n  SystemCheckImages := nil;\r\n  SystemFlatCheckImages.Free;\r\n  SystemFlatCheckImages := nil;\r\n\r\n  if NeedToUnitialize then\r\n    OleUninitialize;\r\n\r\n  // If VT is used in a package and its special hint window was used then the last instance of this\r\n  // window is not freed correctly (bug in the VCL). We explicitely tell the application to free it\r\n  // otherwise an AV is raised due to access to an invalid memory area.\r\n  if ModuleIsPackage then\r\n  begin\r\n    HintWasEnabled := Application.ShowHint;\r\n    Application.ShowHint := False;\r\n    if HintWasEnabled then\r\n      Application.ShowHint := True;\r\n  end;\r\nend;\r\n\r\n\r\n\r\n\r\n//----------------- TCustomVirtualTreeOptions --------------------------------------------------------------------------\r\n\r\nconstructor TCustomVirtualTreeOptions.Create(AOwner: TBaseVirtualTree);\r\n\r\nbegin\r\n  FOwner := AOwner;\r\n\r\n  FPaintOptions := DefaultPaintOptions;\r\n  FAnimationOptions := DefaultAnimationOptions;\r\n  FAutoOptions := DefaultAutoOptions;\r\n  FSelectionOptions := DefaultSelectionOptions;\r\n  FMiscOptions := DefaultMiscOptions;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TCustomVirtualTreeOptions.SetAnimationOptions(const Value: TVTAnimationOptions);\r\n\r\nbegin\r\n  FAnimationOptions := Value;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TCustomVirtualTreeOptions.SetAutoOptions(const Value: TVTAutoOptions);\r\n\r\nvar\r\n  ChangedOptions: TVTAutoOptions;\r\n\r\nbegin\r\n  if FAutoOptions <> Value then\r\n  begin\r\n    // Exclusive ORing to get all entries wich are in either set but not in both.\r\n    ChangedOptions := FAutoOptions + Value - (FAutoOptions * Value);\r\n    FAutoOptions := Value;\r\n    with FOwner do\r\n      if (toAutoSpanColumns in ChangedOptions) and not (csLoading in ComponentState) and HandleAllocated then\r\n        Invalidate;\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TCustomVirtualTreeOptions.SetMiscOptions(const Value: TVTMiscOptions);\r\n\r\nvar\r\n  ToBeSet,\r\n  ToBeCleared: TVTMiscOptions;\r\n\r\nbegin\r\n  if FMiscOptions <> Value then\r\n  begin\r\n    ToBeSet := Value - FMiscOptions;\r\n    ToBeCleared := FMiscOptions - Value;\r\n    FMiscOptions := Value;\r\n\r\n    with FOwner do\r\n      if not (csLoading in ComponentState) and HandleAllocated then\r\n      begin\r\n        if toCheckSupport in ToBeSet + ToBeCleared then\r\n          Invalidate;\r\n        if not (csDesigning in ComponentState) then\r\n        begin\r\n          if toAcceptOLEDrop in ToBeCleared then\r\n            RevokeDragDrop(Handle);\r\n          if toFullRepaintOnResize in ToBeSet + ToBeCleared then\r\n            RecreateWnd;\r\n          if toAcceptOLEDrop in ToBeSet then\r\n            RegisterDragDrop(Handle, DragManager as IDropTarget);\r\n          if toVariableNodeHeight in ToBeSet then begin\r\n            BeginUpdate();\r\n            try\r\n              ReInitNode(nil, True);\r\n            finally\r\n              EndUpdate();\r\n            end;//try..finally\r\n          end;//if toVariableNodeHeight\r\n        end;\r\n      end;\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TCustomVirtualTreeOptions.SetPaintOptions(const Value: TVTPaintOptions);\r\n\r\nvar\r\n  ToBeSet,\r\n  ToBeCleared: TVTPaintOptions;\r\n  Run: PVirtualNode;\r\n  HandleWasAllocated: Boolean;\r\n\r\nbegin\r\n  if FPaintOptions <> Value then\r\n  begin\r\n    ToBeSet := Value - FPaintOptions;\r\n    ToBeCleared := FPaintOptions - Value;\r\n    FPaintOptions := Value;\r\n    if (toFixedIndent in ToBeSet) then\r\n    begin\r\n      // Fixes issue #388\r\n      Include(FPaintOptions, toShowRoot);\r\n      Include(ToBeSet, toShowRoot);\r\n    end;//if\r\n    with FOwner do\r\n    begin\r\n      HandleWasAllocated := HandleAllocated;\r\n\r\n      if not (csLoading in ComponentState) and (toShowFilteredNodes in ToBeSet + ToBeCleared) then\r\n      begin\r\n        if HandleWasAllocated then\r\n          BeginUpdate;\r\n        InterruptValidation;\r\n        Run := GetFirstNoInit;\r\n        while Assigned(Run) do\r\n        begin\r\n          if (vsFiltered in Run.States) then\r\n          begin\r\n            if FullyVisible[Run] then\r\n            begin\r\n              if toShowFilteredNodes in ToBeSet then\r\n                Inc(FVisibleCount)\r\n              else\r\n                Dec(FVisibleCount);\r\n            end;\r\n            if toShowFilteredNodes in ToBeSet then\r\n              AdjustTotalHeight(Run, Run.NodeHeight, True)\r\n            else\r\n              AdjustTotalHeight(Run, -Run.NodeHeight, True);\r\n          end;\r\n          Run := GetNextNoInit(Run);\r\n        end;\r\n        if HandleWasAllocated then\r\n          EndUpdate;\r\n      end;\r\n\r\n      if HandleAllocated then\r\n      begin\r\n        if IsWinVistaOrAbove and ((tsUseThemes in FStates) or\r\n           ((toThemeAware in ToBeSet) and StyleServices.Enabled)) and\r\n           (toUseExplorerTheme in (ToBeSet + ToBeCleared)) and not VclStyleEnabled then\r\n        begin\r\n          if (toUseExplorerTheme in ToBeSet) then\r\n          begin\r\n            SetWindowTheme('explorer');\r\n            DoStateChange([tsUseExplorerTheme]);\r\n          end\r\n          else\r\n            if toUseExplorerTheme in ToBeCleared then\r\n            begin\r\n              SetWindowTheme('');\r\n              DoStateChange([], [tsUseExplorerTheme]);\r\n            end;\r\n        end;\r\n\r\n        if not (csLoading in ComponentState) then\r\n        begin\r\n          if ((toThemeAware in ToBeSet + ToBeCleared) or (toUseExplorerTheme in ToBeSet + ToBeCleared) or VclStyleEnabled) then\r\n          begin\r\n            if ((toThemeAware in ToBeSet) and StyleServices.Enabled) then\r\n              DoStateChange([tsUseThemes])\r\n            else\r\n              if (toThemeAware in ToBeCleared) then\r\n              DoStateChange([], [tsUseThemes]);\r\n\r\n            PrepareBitmaps(True, False);\r\n            RedrawWindow(Handle, nil, 0, RDW_INVALIDATE or RDW_VALIDATE or RDW_FRAME);\r\n          end;\r\n\r\n          if toChildrenAbove in ToBeSet + ToBeCleared then\r\n          begin\r\n            InvalidateCache;\r\n            if FUpdateCount = 0 then\r\n            begin\r\n              ValidateCache;\r\n              Invalidate;\r\n            end;\r\n          end;\r\n\r\n          Invalidate;\r\n        end;\r\n      end;\r\n    end;\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TCustomVirtualTreeOptions.SetSelectionOptions(const Value: TVTSelectionOptions);\r\n\r\nvar\r\n  ToBeSet,\r\n  ToBeCleared: TVTSelectionOptions;\r\n\r\nbegin\r\n  if FSelectionOptions <> Value then\r\n  begin\r\n    ToBeSet := Value - FSelectionOptions;\r\n    ToBeCleared := FSelectionOptions - Value;\r\n    FSelectionOptions := Value;\r\n\r\n    with FOwner do\r\n    begin\r\n      if (toMultiSelect in (ToBeCleared + ToBeSet)) or\r\n        ([toLevelSelectConstraint, toSiblingSelectConstraint] * ToBeSet <> []) then\r\n        ClearSelection;\r\n\r\n      if (toExtendedFocus in ToBeCleared) and (FFocusedColumn > 0) and HandleAllocated then\r\n      begin\r\n        FFocusedColumn := FHeader.MainColumn;\r\n        Invalidate;\r\n      end;\r\n\r\n      if not (toExtendedFocus in FSelectionOptions) then\r\n        FFocusedColumn := FHeader.MainColumn;\r\n    end;\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TCustomVirtualTreeOptions.AssignTo(Dest: TPersistent);\r\n\r\nbegin\r\n  if Dest is TCustomVirtualTreeOptions then\r\n  begin\r\n    with Dest as TCustomVirtualTreeOptions do\r\n    begin\r\n      PaintOptions := Self.PaintOptions;\r\n      AnimationOptions := Self.AnimationOptions;\r\n      AutoOptions := Self.AutoOptions;\r\n      SelectionOptions := Self.SelectionOptions;\r\n      MiscOptions := Self.MiscOptions;\r\n    end;\r\n  end\r\n  else\r\n    inherited;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\n// OLE drag and drop support classes\r\n// This is quite heavy stuff (compared with the VCL implementation) but is much better suited to fit the needs\r\n// of DD'ing various kinds of virtual data and works also between applications.\r\n\r\n//----------------- TEnumFormatEtc -------------------------------------------------------------------------------------\r\n\r\nconstructor TEnumFormatEtc.Create(Tree: TBaseVirtualTree; const AFormatEtcArray: TFormatEtcArray);\r\n\r\nvar\r\n  I: Integer;\r\n\r\nbegin\r\n  inherited Create;\r\n\r\n  FTree := Tree;\r\n  // Make a local copy of the format data.\r\n  SetLength(FFormatEtcArray, Length(AFormatEtcArray));\r\n  for I := 0 to High(AFormatEtcArray) do\r\n    FFormatEtcArray[I] := AFormatEtcArray[I];\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TEnumFormatEtc.Clone(out Enum: IEnumFormatEtc): HResult;\r\n\r\nvar\r\n  AClone: TEnumFormatEtc;\r\n\r\nbegin\r\n  Result := S_OK;\r\n  try\r\n    AClone := TEnumFormatEtc.Create(nil, FFormatEtcArray);\r\n    AClone.FCurrentIndex := FCurrentIndex;\r\n    Enum := AClone as IEnumFormatEtc;\r\n  except\r\n    Result := E_FAIL;\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TEnumFormatEtc.Next(celt: Integer; out elt; pceltFetched: PLongint): HResult;\r\n\r\nvar\r\n  CopyCount: Integer;\r\n\r\nbegin\r\n  Result := S_FALSE;\r\n  CopyCount := Length(FFormatEtcArray) - FCurrentIndex;\r\n  if celt < CopyCount then\r\n    CopyCount := celt;\r\n  if CopyCount > 0 then\r\n  begin\r\n    Move(FFormatEtcArray[FCurrentIndex], elt, CopyCount * SizeOf(TFormatEtc));\r\n    Inc(FCurrentIndex, CopyCount);\r\n    Result := S_OK;\r\n  end;\r\n  if Assigned(pceltFetched) then\r\n    pceltFetched^ := CopyCount;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TEnumFormatEtc.Reset: HResult;\r\n\r\nbegin\r\n  FCurrentIndex := 0;\r\n  Result := S_OK;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TEnumFormatEtc.Skip(celt: Integer): HResult;\r\n\r\nbegin\r\n  if FCurrentIndex + celt < High(FFormatEtcArray) then\r\n  begin\r\n    Inc(FCurrentIndex, celt);\r\n    Result := S_Ok;\r\n  end\r\n  else\r\n    Result := S_FALSE;\r\nend;\r\n\r\n//----------------- TVTDataObject --------------------------------------------------------------------------------------\r\n\r\nconstructor TVTDataObject.Create(AOwner: TBaseVirtualTree; ForClipboard: Boolean);\r\n\r\nbegin\r\n  inherited Create;\r\n\r\n  FOwner := AOwner;\r\n  FForClipboard := ForClipboard;\r\n  FOwner.GetNativeClipboardFormats(FFormatEtcArray);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\ndestructor TVTDataObject.Destroy;\r\n\r\nvar\r\n  I: Integer;\r\n  StgMedium: PStgMedium;\r\n\r\nbegin\r\n  // Cancel a pending clipboard operation if this data object was created for the clipboard and\r\n  // is freed because something else is placed there.\r\n  if FForClipboard and not (tsClipboardFlushing in FOwner.FStates) then\r\n    FOwner.CancelCutOrCopy;\r\n\r\n  // Release any internal clipboard formats\r\n  for I := 0 to High(FormatEtcArray) do\r\n  begin\r\n    StgMedium := FindInternalStgMedium(FormatEtcArray[I].cfFormat);\r\n    if Assigned(StgMedium) then\r\n      ReleaseStgMedium(StgMedium^);\r\n  end;\r\n\r\n  FormatEtcArray := nil;\r\n  inherited;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TVTDataObject.CanonicalIUnknown(const TestUnknown: IUnknown): IUnknown;\r\n\r\n// Uses COM object identity: An explicit call to the IUnknown::QueryInterface method, requesting the IUnknown\r\n// interface, will always return the same pointer.\r\n\r\nbegin\r\n  if Assigned(TestUnknown) then\r\n  begin\r\n    if TestUnknown.QueryInterface(IUnknown, Result) = 0 then\r\n      Result._Release // Don't actually need it just need the pointer value\r\n    else\r\n      Result := TestUnknown;\r\n  end\r\n  else\r\n    Result := TestUnknown;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TVTDataObject.EqualFormatEtc(FormatEtc1, FormatEtc2: TFormatEtc): Boolean;\r\n\r\nbegin\r\n  Result := (FormatEtc1.cfFormat = FormatEtc2.cfFormat) and (FormatEtc1.ptd = FormatEtc2.ptd) and\r\n    (FormatEtc1.dwAspect = FormatEtc2.dwAspect) and (FormatEtc1.lindex = FormatEtc2.lindex) and\r\n    (FormatEtc1.tymed and FormatEtc2.tymed <> 0);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TVTDataObject.FindFormatEtc(TestFormatEtc: TFormatEtc; const FormatEtcArray: TFormatEtcArray): integer;\r\n\r\nvar\r\n  I: integer;\r\n\r\nbegin\r\n  Result := -1;\r\n  for I := 0 to High(FormatEtcArray) do\r\n  begin\r\n    if EqualFormatEtc(TestFormatEtc, FormatEtcArray[I]) then\r\n    begin\r\n      Result := I;\r\n      Break;\r\n    end;\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TVTDataObject.FindInternalStgMedium(Format: TClipFormat): PStgMedium;\r\n\r\nvar\r\n  I: integer;\r\nbegin\r\n  Result := nil;\r\n  for I := 0 to High(InternalStgMediumArray) do\r\n  begin\r\n    if Format = InternalStgMediumArray[I].Format then\r\n    begin\r\n      Result := @InternalStgMediumArray[I].Medium;\r\n      Break;\r\n    end;\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TVTDataObject.HGlobalClone(HGlobal: THandle): THandle;\r\n\r\n// Returns a global memory block that is a copy of the passed memory block.\r\n\r\nvar\r\n  Size: Cardinal;\r\n  Data,\r\n  NewData: PByte;\r\n\r\nbegin\r\n  Size := GlobalSize(HGlobal);\r\n  Result := GlobalAlloc(GPTR, Size);\r\n  Data := GlobalLock(hGlobal);\r\n  try\r\n    NewData := GlobalLock(Result);\r\n    try\r\n      Move(Data^, NewData^, Size);\r\n    finally\r\n      GlobalUnLock(Result);\r\n    end;\r\n  finally\r\n    GlobalUnLock(hGlobal);\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TVTDataObject.RenderInternalOLEData(const FormatEtcIn: TFormatEtc; var Medium: TStgMedium;\r\n  var OLEResult: HResult): Boolean;\r\n\r\n// Tries to render one of the formats which have been stored via the SetData method.\r\n// Since this data is already there it is just copied or its reference count is increased (depending on storage medium).\r\n\r\nvar\r\n  InternalMedium: PStgMedium;\r\n\r\nbegin\r\n  Result := True;\r\n  InternalMedium := FindInternalStgMedium(FormatEtcIn.cfFormat);\r\n  if Assigned(InternalMedium) then\r\n    OLEResult := StgMediumIncRef(InternalMedium^, Medium, False, Self as IDataObject)\r\n  else\r\n    Result := False;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TVTDataObject.StgMediumIncRef(const InStgMedium: TStgMedium; var OutStgMedium: TStgMedium;\r\n  CopyInMedium: Boolean; const DataObject: IDataObject): HRESULT;\r\n\r\n// InStgMedium is the data that is requested, OutStgMedium is the data that we are to return either a copy of or\r\n// increase the IDataObject's reference and send ourselves back as the data (unkForRelease). The InStgMedium is usually\r\n// the result of a call to find a particular FormatEtc that has been stored locally through a call to SetData.\r\n// If CopyInMedium is not true we already have a local copy of the data when the SetData function was called (during\r\n// that call the CopyInMedium must be true). Then as the caller asks for the data through GetData we do not have to make\r\n// copy of the data for the caller only to have them destroy it then need us to copy it again if necessary.\r\n// This way we increase the reference count to ourselves and pass the STGMEDIUM structure initially stored in SetData.\r\n// This way when the caller frees the structure it sees the unkForRelease is not nil and calls Release on the object\r\n// instead of destroying the actual data.\r\n\r\nvar\r\n  Len: Integer;\r\n\r\nbegin\r\n  Result := S_OK;\r\n\r\n  // Simply copy all fields to start with.\r\n  OutStgMedium := InStgMedium;\r\n  // The data handled here always results from a call of SetData we got. This ensures only one storage format\r\n  // is indicated and hence the case statement below is safe (IDataObject.GetData can optionally use several\r\n  // storage formats).\r\n  case InStgMedium.tymed of\r\n    TYMED_HGLOBAL:\r\n      begin\r\n        if CopyInMedium then\r\n        begin\r\n          // Generate a unique copy of the data passed\r\n          OutStgMedium.hGlobal := HGlobalClone(InStgMedium.hGlobal);\r\n          if OutStgMedium.hGlobal = 0 then\r\n            Result := E_OUTOFMEMORY;\r\n        end\r\n        else\r\n          // Don't generate a copy just use ourselves and the copy previously saved.\r\n          OutStgMedium.unkForRelease := Pointer(DataObject); // Does not increase RefCount.\r\n      end;\r\n    TYMED_FILE:\r\n      begin\r\n        Len := lstrLenW(InStgMedium.lpszFileName) + 1; // Don't forget the terminating null character.\r\n        OutStgMedium.lpszFileName := CoTaskMemAlloc(2 * Len);\r\n        Move(InStgMedium.lpszFileName^, OutStgMedium.lpszFileName^, 2 * Len);\r\n      end;\r\n    TYMED_ISTREAM:\r\n      IUnknown(OutStgMedium.stm)._AddRef;\r\n    TYMED_ISTORAGE:\r\n      IUnknown(OutStgMedium.stg)._AddRef;\r\n    TYMED_GDI:\r\n      if not CopyInMedium then\r\n        // Don't generate a copy just use ourselves and the previously saved data.\r\n        OutStgMedium.unkForRelease := Pointer(DataObject) // Does not increase RefCount.\r\n      else\r\n        Result := DV_E_TYMED; // Don't know how to copy GDI objects right now.\r\n    TYMED_MFPICT:\r\n      if not CopyInMedium then\r\n        // Don't generate a copy just use ourselves and the previously saved data.\r\n        OutStgMedium.unkForRelease := Pointer(DataObject) // Does not increase RefCount.\r\n      else\r\n        Result := DV_E_TYMED; // Don't know how to copy MetaFile objects right now.\r\n    TYMED_ENHMF:\r\n      if not CopyInMedium then\r\n        // Don't generate a copy just use ourselves and the previously saved data.\r\n        OutStgMedium.unkForRelease := Pointer(DataObject) // Does not increase RefCount.\r\n      else\r\n        Result := DV_E_TYMED; // Don't know how to copy enhanced metafiles objects right now.\r\n  else\r\n    Result := DV_E_TYMED;\r\n  end;\r\n\r\n  if (Result = S_OK) and Assigned(OutStgMedium.unkForRelease) then\r\n    IUnknown(OutStgMedium.unkForRelease)._AddRef;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TVTDataObject.DAdvise(const FormatEtc: TFormatEtc; advf: Integer; const advSink: IAdviseSink;\r\n  out dwConnection: Integer): HResult;\r\n\r\n// Advise sink management is greatly simplified by the IDataAdviseHolder interface.\r\n// We use this interface and forward all concerning calls to it.\r\n\r\nbegin\r\n  Result := S_OK;\r\n  if FAdviseHolder = nil then\r\n    Result := CreateDataAdviseHolder(FAdviseHolder);\r\n  if Result = S_OK then\r\n    Result := FAdviseHolder.Advise(Self as IDataObject, FormatEtc, advf, advSink, dwConnection);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TVTDataObject.DUnadvise(dwConnection: Integer): HResult;\r\n\r\nbegin\r\n  if FAdviseHolder = nil then\r\n    Result := E_NOTIMPL\r\n  else\r\n    Result := FAdviseHolder.Unadvise(dwConnection);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TVTDataObject.EnumDAdvise(out enumAdvise: IEnumStatData): HResult;\r\n\r\nbegin\r\n  if FAdviseHolder = nil then\r\n    Result := OLE_E_ADVISENOTSUPPORTED\r\n  else\r\n    Result := FAdviseHolder.EnumAdvise(enumAdvise);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TVTDataObject.EnumFormatEtc(Direction: Integer; out EnumFormatEtc: IEnumFormatEtc): HResult;\r\n\r\nvar\r\n  NewList: TEnumFormatEtc;\r\n\r\nbegin\r\n  Result := E_FAIL;\r\n  if Direction = DATADIR_GET then\r\n  begin\r\n    NewList := TEnumFormatEtc.Create(FOwner, FormatEtcArray);\r\n    EnumFormatEtc := NewList as IEnumFormatEtc;\r\n    Result := S_OK;\r\n  end\r\n  else\r\n    EnumFormatEtc := nil;\r\n  if EnumFormatEtc = nil then\r\n    Result := OLE_S_USEREG;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TVTDataObject.GetCanonicalFormatEtc(const FormatEtc: TFormatEtc; out FormatEtcOut: TFormatEtc): HResult;\r\n\r\nbegin\r\n  Result := DATA_S_SAMEFORMATETC;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TVTDataObject.GetData(const FormatEtcIn: TFormatEtc; out Medium: TStgMedium): HResult;\r\n\r\n// Data is requested by clipboard or drop target. This method dispatchs the call\r\n// depending on the data being requested.\r\n\r\nvar\r\n  I: Integer;\r\n  Data: PVTReference;\r\n\r\nbegin\r\n  // The tree reference format is always supported and returned from here.\r\n  if FormatEtcIn.cfFormat = CF_VTREFERENCE then\r\n  begin\r\n    // Note: this format is not used while flushing the clipboard to avoid a dangling reference\r\n    //       when the owner tree is destroyed before the clipboard data is replaced with something else.\r\n    if tsClipboardFlushing in FOwner.FStates then\r\n      Result := E_FAIL\r\n    else\r\n    begin\r\n      Medium.hGlobal := GlobalAlloc(GHND or GMEM_SHARE, SizeOf(TVTReference));\r\n      Data := GlobalLock(Medium.hGlobal);\r\n      Data.Process := GetCurrentProcessID;\r\n      Data.Tree := FOwner;\r\n      GlobalUnlock(Medium.hGlobal);\r\n      Medium.tymed := TYMED_HGLOBAL;\r\n      Medium.unkForRelease := nil;\r\n      Result := S_OK;\r\n    end;\r\n  end\r\n  else\r\n  begin\r\n    try\r\n      // See if we accept this type and if not get the correct return value.\r\n      Result := QueryGetData(FormatEtcIn);\r\n      if Result = S_OK then\r\n      begin\r\n        for I := 0 to High(FormatEtcArray) do\r\n        begin\r\n          if EqualFormatEtc(FormatEtcIn, FormatEtcArray[I]) then\r\n          begin\r\n            if not RenderInternalOLEData(FormatEtcIn, Medium, Result) then\r\n              Result := FOwner.RenderOLEData(FormatEtcIn, Medium, FForClipboard);\r\n            Break;\r\n          end;\r\n        end;\r\n      end;\r\n    except\r\n      ZeroMemory (@Medium, SizeOf(Medium));\r\n      Result := E_FAIL;\r\n    end;\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TVTDataObject.GetDataHere(const FormatEtc: TFormatEtc; out Medium: TStgMedium): HResult;\r\n\r\nbegin\r\n  Result := E_NOTIMPL;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TVTDataObject.QueryGetData(const FormatEtc: TFormatEtc): HResult;\r\n\r\nvar\r\n  I: Integer;\r\n\r\nbegin\r\n  Result := DV_E_CLIPFORMAT;\r\n  for I := 0 to High(FFormatEtcArray) do\r\n  begin\r\n    if FormatEtc.cfFormat = FFormatEtcArray[I].cfFormat then\r\n    begin\r\n      if (FormatEtc.tymed and FFormatEtcArray[I].tymed) <> 0 then\r\n      begin\r\n        if FormatEtc.dwAspect = FFormatEtcArray[I].dwAspect then\r\n        begin\r\n          if FormatEtc.lindex = FFormatEtcArray[I].lindex then\r\n          begin\r\n            Result := S_OK;\r\n            Break;\r\n          end\r\n          else\r\n            Result := DV_E_LINDEX;\r\n        end\r\n        else\r\n          Result := DV_E_DVASPECT;\r\n      end\r\n      else\r\n        Result := DV_E_TYMED;\r\n    end;\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TVTDataObject.SetData(const FormatEtc: TFormatEtc; var Medium: TStgMedium; DoRelease: BOOL): HResult;\r\n\r\n// Allows dynamic adding to the IDataObject during its existance. Most noteably it is used to implement\r\n// IDropSourceHelper and allows to set a special format for optimized moves during a shell transfer.\r\n\r\nvar\r\n  Index: Integer;\r\n  LocalStgMedium: PStgMedium;\r\n\r\nbegin\r\n  // See if we already have a format of that type available.\r\n  Index := FindFormatEtc(FormatEtc, FormatEtcArray);\r\n  if Index > - 1 then\r\n  begin\r\n    // Just use the TFormatEct in the array after releasing the data.\r\n    LocalStgMedium := FindInternalStgMedium(FormatEtcArray[Index].cfFormat);\r\n    if Assigned(LocalStgMedium) then\r\n    begin\r\n      ReleaseStgMedium(LocalStgMedium^);\r\n      ZeroMemory(LocalStgMedium, SizeOf(LocalStgMedium^));\r\n    end;\r\n  end\r\n  else\r\n  begin\r\n    // It is a new format so create a new TFormatCollectionItem, copy the\r\n    // FormatEtc parameter into the new object and and put it in the list.\r\n    SetLength(FFormatEtcArray, Length(FormatEtcArray) + 1);\r\n    FormatEtcArray[High(FormatEtcArray)] := FormatEtc;\r\n\r\n    // Create a new InternalStgMedium and initialize it and associate it with the format.\r\n    SetLength(FInternalStgMediumArray, Length(InternalStgMediumArray) + 1);\r\n    InternalStgMediumArray[High(InternalStgMediumArray)].Format := FormatEtc.cfFormat;\r\n    LocalStgMedium := @InternalStgMediumArray[High(InternalStgMediumArray)].Medium;\r\n    ZeroMemory(LocalStgMedium, SizeOf(LocalStgMedium^));\r\n  end;\r\n\r\n  if DoRelease then\r\n  begin\r\n    // We are simply being given the data and we take control of it.\r\n    LocalStgMedium^ := Medium;\r\n    Result := S_OK;\r\n  end\r\n  else\r\n  begin\r\n    // We need to reference count or copy the data and keep our own references to it.\r\n    Result := StgMediumIncRef(Medium, LocalStgMedium^, True, Self as IDataObject);\r\n\r\n    // Can get a circular reference if the client calls GetData then calls SetData with the same StgMedium.\r\n    // Because the unkForRelease for the IDataObject can be marshalled it is necessary to get pointers that\r\n    // can be correctly compared. See the IDragSourceHelper article by Raymond Chen at MSDN.\r\n    if Assigned(LocalStgMedium.unkForRelease) then\r\n    begin\r\n      if CanonicalIUnknown(Self) = CanonicalIUnknown(IUnknown(LocalStgMedium.unkForRelease)) then\r\n        IUnknown(LocalStgMedium.unkForRelease) := nil; // release the interface\r\n    end;\r\n  end;\r\n\r\n  // Tell all registered advice sinks about the data change.\r\n  if Assigned(FAdviseHolder) then\r\n    FAdviseHolder.SendOnDataChange(Self as IDataObject, 0, 0);\r\nend;\r\n\r\n//----------------- TVTDragManager -------------------------------------------------------------------------------------\r\n\r\nconstructor TVTDragManager.Create(AOwner: TBaseVirtualTree);\r\n\r\nbegin\r\n  inherited Create;\r\n  FOwner := AOwner;\r\n\r\n  // Create an instance  of the drop target helper interface. This will fail but not harm on systems which do\r\n  // not support this interface (everything below Windows 2000);\r\n  CoCreateInstance(CLSID_DragDropHelper, nil, CLSCTX_INPROC_SERVER, IID_IDropTargetHelper, FDropTargetHelper);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\ndestructor TVTDragManager.Destroy;\r\n\r\nbegin\r\n  // Set the owner's reference to us to nil otherwise it will access an invalid pointer\r\n  // after our desctruction is complete.\r\n  Pointer(FOwner.FDragManager) := nil;\r\n  inherited;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TVTDragManager.GetDataObject: IDataObject;\r\n\r\nbegin\r\n  // When the owner tree starts a drag operation then it gets a data object here to pass it to the OLE subsystem.\r\n  // In this case there is no local reference to a data object and one is created (but not stored).\r\n  // If there is a local reference then the owner tree is currently the drop target and the stored interface is\r\n  // that of the drag initiator.\r\n  if Assigned(FDataObject) then\r\n    Result := FDataObject\r\n  else\r\n  begin\r\n    Result := FOwner.DoCreateDataObject;\r\n    if Result = nil then\r\n      Result := TVTDataObject.Create(FOwner, False) as IDataObject;\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TVTDragManager.GetDragSource: TBaseVirtualTree;\r\n\r\nbegin\r\n  Result := FDragSource;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TVTDragManager.GetDropTargetHelperSupported: Boolean;\r\n\r\nbegin\r\n  Result := Assigned(FDropTargetHelper);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TVTDragManager.GetIsDropTarget: Boolean;\r\n\r\nbegin\r\n  Result := FIsDropTarget;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TVTDragManager.DragEnter(const DataObject: IDataObject; KeyState: Integer; Pt: TPoint;\r\n  var Effect: Integer): HResult;\r\n\r\nbegin\r\n  FDataObject := DataObject;\r\n  FIsDropTarget := True;\r\n\r\n  SystemParametersInfo(SPI_GETDRAGFULLWINDOWS, 0, @FFullDragging, 0);\r\n  // If full dragging of window contents is disabled in the system then our tree windows will be locked\r\n  // and cannot be updated during a drag operation. With the following call painting is again enabled.\r\n  if not FFullDragging then\r\n    LockWindowUpdate(0);\r\n  if Assigned(FDropTargetHelper) and FFullDragging then begin\r\n    if toAutoScroll in Self.FOwner.TreeOptions.AutoOptions then\r\n      FDropTargetHelper.DragEnter(FOwner.Handle, DataObject, Pt, Effect)\r\n    else\r\n      FDropTargetHelper.DragEnter(0, DataObject, Pt, Effect);// Do not pass handle, otherwise the IDropTargetHelper will perform autoscroll. Issue #486\r\n  end;\r\n  FDragSource := FOwner.GetTreeFromDataObject(DataObject);\r\n  Result := FOwner.DragEnter(KeyState, Pt, Effect);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TVTDragManager.DragLeave: HResult;\r\n\r\nbegin\r\n  if Assigned(FDropTargetHelper) and FFullDragging then\r\n    FDropTargetHelper.DragLeave;\r\n\r\n  FOwner.DragLeave;\r\n  FIsDropTarget := False;\r\n  FDragSource := nil;\r\n  FDataObject := nil;\r\n  Result := NOERROR;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TVTDragManager.DragOver(KeyState: Integer; Pt: TPoint; var Effect: Integer): HResult;\r\n\r\nbegin\r\n  if Assigned(FDropTargetHelper) and FFullDragging then\r\n    FDropTargetHelper.DragOver(Pt, Effect);\r\n\r\n  Result := FOwner.DragOver(FDragSource, KeyState, dsDragMove, Pt, Effect);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TVTDragManager.Drop(const DataObject: IDataObject; KeyState: Integer; Pt: TPoint;\r\n  var Effect: Integer): HResult;\r\n\r\nbegin\r\n  if Assigned(FDropTargetHelper) and FFullDragging then\r\n    FDropTargetHelper.Drop(DataObject, Pt, Effect);\r\n\r\n  Result := FOwner.DragDrop(DataObject, KeyState, Pt, Effect);\r\n  FIsDropTarget := False;\r\n  FDataObject := nil;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TVTDragManager.ForceDragLeave;\r\n\r\n// Some drop targets, e.g. Internet Explorer leave a drag image on screen instead removing it when they receive\r\n// a drop action. This method calls the drop target helper's DragLeave method to ensure it removes the drag image from\r\n// screen. Unfortunately, sometimes not even this does help (e.g. when dragging text from VT to a text field in IE).\r\n\r\nbegin\r\n  if Assigned(FDropTargetHelper) and FFullDragging then\r\n    FDropTargetHelper.DragLeave;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TVTDragManager.GiveFeedback(Effect: Integer): HResult;\r\n\r\nbegin\r\n  Result := DRAGDROP_S_USEDEFAULTCURSORS;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TVTDragManager.QueryContinueDrag(EscapePressed: BOOL; KeyState: Integer): HResult;\r\n\r\nvar\r\n  RButton,\r\n  LButton: Boolean;\r\n\r\nbegin\r\n  LButton := (KeyState and MK_LBUTTON) <> 0;\r\n  RButton := (KeyState and MK_RBUTTON) <> 0;\r\n\r\n  // Drag'n drop canceled by pressing both mouse buttons or Esc?\r\n  if (LButton and RButton) or EscapePressed then\r\n    Result := DRAGDROP_S_CANCEL\r\n  else\r\n    // Drag'n drop finished?\r\n    if not (LButton or RButton) then\r\n      Result := DRAGDROP_S_DROP\r\n    else\r\n      Result := S_OK;\r\nend;\r\n\r\n//----------------- TVirtualTreeHintWindow -----------------------------------------------------------------------------\r\n\r\nvar\r\n  // This variable is necessary to coordinate the complex interaction between different hints in the application\r\n  // and animated hints in our own class. Under certain conditions it can happen that our hint window is destroyed\r\n  // while it is still in the animation loop.\r\n  FHintWindowDestroyed: Boolean = True;\r\n\r\nconstructor TVirtualTreeHintWindow.Create(AOwner: TComponent);\r\n\r\nbegin\r\n  inherited;\r\n\r\n  FBackground := TBitmap.Create;\r\n  FBackground.PixelFormat := pf32Bit;\r\n  FDrawBuffer := TBitmap.Create;\r\n  FDrawBuffer.PixelFormat := pf32Bit;\r\n  FTarget := TBitmap.Create;\r\n  FTarget.PixelFormat := pf32Bit;\r\n\r\n  DoubleBuffered := False; // we do our own buffering\r\n  FHintWindowDestroyed := False;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\ndestructor TVirtualTreeHintWindow.Destroy;\r\n\r\nbegin\r\n  FHintWindowDestroyed := True;\r\n\r\n  FTarget.Free;\r\n  FDrawBuffer.Free;\r\n  FBackground.Free;\r\n  inherited;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TVirtualTreeHintWindow.AnimationCallback(Step, StepSize: Integer; Data: Pointer): Boolean;\r\n\r\nbegin\r\n  Result := not FHintWindowDestroyed and HandleAllocated and IsWindowVisible(Handle) and\r\n    Assigned(FHintData.Tree) and not (tsCancelHintAnimation in FHintData.Tree.FStates);\r\n  if Result then\r\n  begin\r\n    InternalPaint(Step, StepSize);\r\n    // We have to allow certain messages to be processed normally for various reasons.\r\n    // This introduces another problem however if this hint window is destroyed\r\n    // while it is still in the animation loop. A global variable keeps track of\r\n    // that case. This is reliable because we can only have one (internal) hint window.\r\n    Application.ProcessMessages;\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TVirtualTreeHintWindow.CMTextChanged(var Message: TMessage);\r\n\r\nbegin\r\n  // swallow this message to prevent the ancestor from resizing the window (we don't use the caption anyway)\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TVirtualTreeHintWindow.GetHintWindowDestroyed;\r\n\r\n// This function exists to inform descendants if the hint window has been destroyed.\r\n\r\nbegin\r\n  Result := FHintWindowDestroyed;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TVirtualTreeHintWindow.WMEraseBkgnd(var Message: TWMEraseBkgnd);\r\n\r\n// The control is fully painted by own code so don't erase its background as this causes flickering.\r\n\r\nbegin\r\n  Message.Result := 1;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TVirtualTreeHintWindow.WMNCPaint(var Message: TMessage);\r\n\r\n// The control is fully painted by own code so don't paint any borders.\r\n\r\nbegin\r\n  Message.Result := 0;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TVirtualTreeHintWindow.WMShowWindow(var Message: TWMShowWindow);\r\n\r\n// Clear hint data when the window becomes hidden.\r\n\r\nbegin\r\n  if not Message.Show then\r\n  begin\r\n    // Don't touch the last hint rectangle stored in the associated tree to avoid flickering in certain situations.\r\n    Finalize(FHintData);\r\n    ZeroMemory (@FHintData, SizeOf(FHintData));\r\n\r\n    // If the hint window destruction flag to stop any hint window animation was set by a tree\r\n    // during its destruction then reset it here to allow other tree instances to still use\r\n    // this hint window.\r\n    FHintWindowDestroyed := False;\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TVirtualTreeHintWindow.CreateParams(var Params: TCreateParams);\r\n\r\nbegin\r\n  inherited CreateParams(Params);\r\n\r\n  with Params do\r\n  begin\r\n    Style := WS_POPUP;\r\n    ExStyle := ExStyle and not WS_EX_CLIENTEDGE;\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TVirtualTreeHintWindow.InternalPaint(Step, StepSize: Integer);\r\n\r\n  //--------------- local functions -------------------------------------------\r\n\r\n  procedure DoShadowBlend(DC: HDC; R: TRect; Alpha: Integer);\r\n\r\n  // Helper routine for shadow blending to shorten the parameter list in frequent calls.\r\n\r\n  begin\r\n    AlphaBlend(0, DC, R, Point(0, 0), bmConstantAlphaAndColor,  Alpha, clBlack);\r\n  end;\r\n\r\n  //---------------------------------------------------------------------------\r\n\r\n  procedure DrawHintShadow(Canvas: TCanvas; ShadowSize: Integer);\r\n\r\n  var\r\n    R: TRect;\r\n\r\n  begin\r\n    // Bottom shadow.\r\n    R := Rect(ShadowSize, Height - ShadowSize, Width, Height);\r\n    DoShadowBlend(Canvas.Handle, R, 5);\r\n    Inc(R.Left);\r\n    Dec(R.Right);\r\n    Dec(R.Bottom);\r\n    DoShadowBlend(Canvas.Handle, R, 10);\r\n    Inc(R.Left);\r\n    Dec(R.Right);\r\n    Dec(R.Bottom);\r\n    DoShadowBlend(Canvas.Handle, R, 20);\r\n    Inc(R.Left);\r\n    Dec(R.Right);\r\n    Dec(R.Bottom);\r\n    DoShadowBlend(Canvas.Handle, R, 35);\r\n    Inc(R.Left);\r\n    Dec(R.Right);\r\n    Dec(R.Bottom);\r\n    DoShadowBlend(Canvas.Handle, R, 50);\r\n    // Right shadow.\r\n    R := Rect(Width - ShadowSize, ShadowSize, Width, Height - ShadowSize);\r\n    DoShadowBlend(Canvas.Handle, R, 5);\r\n    Inc(R.Top);\r\n    Dec(R.Right);\r\n    DoShadowBlend(Canvas.Handle, R, 10);\r\n    Inc(R.Top);\r\n    Dec(R.Right);\r\n    DoShadowBlend(Canvas.Handle, R, 20);\r\n    Inc(R.Top);\r\n    Dec(R.Right);\r\n    DoShadowBlend(Canvas.Handle, R, 35);\r\n    Inc(R.Top);\r\n    Dec(R.Right);\r\n    DoShadowBlend(Canvas.Handle, R, 50);\r\n  end;\r\n\r\n  //--------------- end local functions ---------------------------------------\r\n\r\nvar\r\n  R: TRect;\r\n  Y: Integer;\r\n  S: string;\r\n  DrawFormat: Cardinal;\r\n  Shadow: Integer;\r\n  HintKind: TVTHintKind;\r\n  LClipRect: TRect;\r\n\r\n  LColor: TColor;\r\n  LDetails: TThemedElementDetails;\r\n  LGradientStart: TColor;\r\n  LGradientEnd: TColor;\r\n\r\nbegin\r\n  Shadow := 0;\r\n\r\n  with FHintData, FDrawBuffer do\r\n  begin\r\n    // Do actual painting only in the very first run.\r\n    if Step = 0 then\r\n    begin\r\n      // If the given node is nil then we have to display a header hint.\r\n      if (Node = nil) or (Tree.FHintMode <> hmToolTip) then\r\n      begin\r\n        Canvas.Font := Screen.HintFont;\r\n        Y := 2;\r\n      end\r\n      else\r\n      begin\r\n        Tree.GetTextInfo(Node, Column, Canvas.Font, R, S);\r\n        if LineBreakStyle = hlbForceMultiLine then\r\n          Y := 1\r\n        else\r\n          Y := (R.Top - R.Bottom - Shadow + Self.Height) div 2;\r\n      end;\r\n\r\n      R := Rect(0, 0, Width - Shadow, Height - Shadow);\r\n\r\n      HintKind := vhkText;\r\n      if Assigned(Node) then\r\n        Tree.DoGetHintKind(Node, Column, HintKind);\r\n\r\n      if HintKind = vhkOwnerDraw then\r\n      begin\r\n        Tree.DoDrawHint(Canvas, Node, R, Column);\r\n      end\r\n      else\r\n        with Canvas do\r\n        begin\r\n          if Tree.VclStyleEnabled  then\r\n          begin\r\n            LDetails := StyleServices.GetElementDetails(thHintNormal);\r\n            if StyleServices.GetElementColor(LDetails, ecGradientColor1, LColor) and (LColor <> clNone) then\r\n              LGradientStart := LColor\r\n            else\r\n              LGradientStart := clInfoBk;\r\n            if StyleServices.GetElementColor(LDetails, ecGradientColor2, LColor) and (LColor <> clNone) then\r\n              LGradientEnd := LColor\r\n            else\r\n              LGradientEnd := clInfoBk;\r\n            if StyleServices.GetElementColor(LDetails, ecTextColor, LColor) and (LColor <> clNone) then\r\n              Font.Color := LColor\r\n            else\r\n              Font.Color := Screen.HintFont.Color;\r\n            GradientFillCanvas(Canvas, LGradientStart, LGradientEnd, R, gdVertical);\r\n          end\r\n          else\r\n          begin\r\n            // Still force tooltip back and text color.\r\n            Font.Color := clInfoText;\r\n            Pen.Color := clBlack;\r\n            Brush.Color := clInfoBk;\r\n            if IsWinVistaOrAbove and StyleServices.Enabled and ((toThemeAware in Tree.TreeOptions.PaintOptions) or\r\n               (toUseExplorerTheme in Tree.TreeOptions.PaintOptions)) then\r\n            begin\r\n              if toUseExplorerTheme in Tree.TreeOptions.PaintOptions then // ToolTip style\r\n                StyleServices.DrawElement(Canvas.Handle, StyleServices.GetElementDetails(tttStandardNormal), R)\r\n              else\r\n                begin // Hint style\r\n                  LClipRect := R;\r\n                  InflateRect(R, 4, 4);\r\n                  StyleServices.DrawElement(Handle, StyleServices.GetElementDetails(tttStandardNormal), R, @LClipRect);\r\n                  R := LClipRect;\r\n                  StyleServices.DrawEdge(Handle, StyleServices.GetElementDetails(twWindowRoot), R, [eeRaisedOuter], [efRect]);\r\n                end;\r\n            end\r\n            else\r\n              if Tree.VclStyleEnabled then\r\n                StyleServices.DrawElement(Canvas.Handle, StyleServices.GetElementDetails(tttStandardNormal), R)\r\n              else\r\n                Rectangle(R);\r\n          end;\r\n          // Determine text position and don't forget the border.\r\n          InflateRect(R, -1, -1);\r\n          DrawFormat := DT_TOP or DT_NOPREFIX;\r\n          SetBkMode(Handle, Winapi.Windows.TRANSPARENT);\r\n          R.Top := Y;\r\n          R.Left := R.Left + 3; // Make the text more centered\r\n          if Assigned(Node) and (LineBreakStyle = hlbForceMultiLine) then\r\n            DrawFormat := DrawFormat or DT_WORDBREAK;\r\n          Winapi.Windows.DrawTextW(Handle, PWideChar(HintText), Length(HintText), R, DrawFormat);\r\n        end;\r\n    end;\r\n  end;\r\n\r\n\r\n    if StepSize > 0 then\r\n      begin\r\n        if FHintData.Tree.DoGetAnimationType = hatFade then\r\n        begin\r\n          with FTarget do\r\n            BitBlt(Canvas.Handle, 0, 0, Width, Height, FBackground.Canvas.Handle, 0, 0, SRCCOPY);\r\n          // Main image.\r\n          AlphaBlend(FDrawBuffer.Canvas.Handle, FTarget.Canvas.Handle, Rect(0, 0, Width - Shadow, Height - Shadow),\r\n            Point(0, 0), bmConstantAlpha,  MulDiv(Step, 256, FadeAnimationStepCount), 0);\r\n\r\n          if Shadow > 0 then\r\n            DrawHintShadow(FTarget.Canvas, Shadow);\r\n          BitBlt(Canvas.Handle, 0, 0, Width, Height, FTarget.Canvas.Handle, 0, 0, SRCCOPY);\r\n        end\r\n        else\r\n        begin\r\n          // Slide is done by blitting \"step\" lines of the lower part of the hint window\r\n          // and fill the rest with the screen background.\r\n\r\n          // 1) blit hint bitmap to the hint canvas\r\n          BitBlt(Canvas.Handle, 0, 0, Width - Shadow, Step, FDrawBuffer.Canvas.Handle, 0, Height - Step, SRCCOPY);\r\n          // 2) blit background rest to hint canvas\r\n          if Step <= Shadow then\r\n            Step := 0\r\n          else\r\n            Dec(Step, Shadow);\r\n          BitBlt(Canvas.Handle, 0, Step, Width, Height - Step, FBackground.Canvas.Handle, 0, Step, SRCCOPY);\r\n        end;\r\n      end\r\n      else\r\n        // Last step during slide or the only step without animation.\r\n        if FHintData.Tree.DoGetAnimationType <> hatFade then\r\n        begin\r\n          if Shadow > 0 then\r\n          begin\r\n            with FBackground do\r\n              BitBlt(Canvas.Handle, 0, 0, Width - Shadow, Height - Shadow, FDrawBuffer.Canvas.Handle, 0, 0, SRCCOPY);\r\n\r\n            DrawHintShadow(FBackground.Canvas, Shadow);\r\n            BitBlt(Canvas.Handle, 0, 0, Width, Height, FBackground.Canvas.Handle, 0, 0, SRCCOPY);\r\n          end\r\n          else\r\n            BitBlt(Canvas.Handle, 0, 0, Width, Height, FDrawBuffer.Canvas.Handle, 0, 0, SRCCOPY);\r\n        end;\r\n\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TVirtualTreeHintWindow.Paint;\r\n\r\nbegin\r\n  InternalPaint(0, 0);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TVirtualTreeHintWindow.ActivateHint(Rect: TRect; const AHint: string);\r\n\r\nvar\r\n  DC: HDC;\r\n  StopLastAnimation: Boolean;\r\n  lCursorPos: TPoint;\r\nbegin\r\n  if IsRectEmpty(Rect) or not Assigned(FHintData.Tree) or\r\n     not GetCursorPos(lCursorPos) or not PtInRect(FHintData.Tree.FLastHintRect, FHintData.Tree.ScreenToClient(lCursorPos))\r\n  then\r\n    Application.CancelHint\r\n  else\r\n  begin\r\n    // There is already an animation. Start a new one but do not continue the old one once we are finished here.\r\n    StopLastAnimation := (tsInAnimation in FHintData.Tree.FStates);\r\n    if StopLastAnimation then\r\n      FHintData.Tree.DoStateChange([], [tsInAnimation]);\r\n\r\n    SetWindowPos(Handle, 0, Rect.Left, Rect.Top, Width, Height, SWP_HIDEWINDOW or SWP_NOACTIVATE or SWP_NOZORDER);\r\n    UpdateBoundsRect(Rect);\r\n\r\n    // Make sure the whole hint is visible on the monitor. Don't forget multi-monitor systems with the\r\n    // primary monitor not being at the top-left corner.\r\n    if Rect.Top - Screen.DesktopTop + Height > Screen.DesktopHeight then\r\n      Rect.Top := Screen.DesktopHeight - Height + Screen.DesktopTop;\r\n    if Rect.Left - Screen.DesktopLeft + Width > Screen.DesktopWidth then\r\n      Rect.Left := Screen.DesktopWidth - Width + Screen.DesktopLeft;\r\n    if Rect.Bottom - Screen.DesktopTop < Screen.DesktopTop then\r\n      Rect.Bottom := Screen.DesktopTop + Screen.DesktopTop;\r\n    if Rect.Left - Screen.DesktopLeft < Screen.DesktopLeft then\r\n      Rect.Left := Screen.DesktopLeft + Screen.DesktopLeft;\r\n\r\n    // adjust sizes of bitmaps\r\n    FDrawBuffer.Width := Width;\r\n    FDrawBuffer.Height := Height;\r\n    FBackground.Width := Width;\r\n    FBackground.Height := Height;\r\n    FTarget.Width := Width;\r\n    FTarget.Height := Height;\r\n\r\n    FHintData.Tree.Update;\r\n\r\n    // capture screen\r\n    DC := GetDC(0);\r\n    try\r\n      with TWithSafeRect(Rect) do\r\n        BitBlt(FBackground.Canvas.Handle, 0, 0, Width, Height, DC, Left, Top, SRCCOPY);\r\n    finally\r\n      ReleaseDC(0, DC);\r\n    end;\r\n\r\n    SetWindowPos(Handle, HWND_TOPMOST, Rect.Left, Rect.Top, Width, Height, SWP_SHOWWINDOW or SWP_NOACTIVATE);\r\n    with FHintData.Tree do\r\n      case DoGetAnimationType of\r\n        hatNone:\r\n          InvalidateRect(Self.Handle, nil, False);\r\n        hatFade:\r\n          begin\r\n            // Make sure the window is not drawn unanimated.\r\n            ValidateRect(Self.Handle, nil);\r\n            // Empirically determined animation duration shows that fading needs about twice as much time as\r\n            // sliding to show a comparable visual effect.\r\n            Animate(FadeAnimationStepCount, 2 * FAnimationDuration, AnimationCallback, nil);\r\n          end;\r\n        hatSlide:\r\n          begin\r\n            // Make sure the window is not drawn unanimated.\r\n            ValidateRect(Self.Handle, nil);\r\n            Animate(Self.Height, FAnimationDuration, AnimationCallback, nil);\r\n          end;\r\n      end;\r\n    if not FHintWindowDestroyed and StopLastAnimation and Assigned(FHintData.Tree) then\r\n      FHintData.Tree.DoStateChange([tsCancelHintAnimation]);\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TVirtualTreeHintWindow.CalcHintRect(MaxWidth: Integer; const AHint: string; AData: Pointer): TRect;\r\n\r\nvar\r\n  TM: TTextMetric;\r\n  R: TRect;\r\n\r\nbegin\r\n  if AData = nil then\r\n    // Defensive approach, it *can* happen that AData is nil. Maybe when several user defined hint classes are used.\r\n    Result := Rect(0, 0, 0, 0)\r\n  else\r\n  begin\r\n    // The hint window does not need any bidi mode setting but the caller of this method (TApplication.ActivateHint)\r\n    // does some unneccessary actions if the hint window is not left-to-right.\r\n    // The text alignment is based on the bidi mode passed in the hint data, hence we can\r\n    // simply set the window's mode to left-to-right (it might have been modified by the caller, if the\r\n    // tree window is right-to-left aligned).\r\n    BidiMode := bdLeftToRight;\r\n\r\n    FHintData := PVTHintData(AData)^;\r\n\r\n    with FHintData do\r\n    begin\r\n      // The draw tree gets its hint size by the application (but only if not a header hint is about to show).      // If the user will be drawing the hint, it gets its hint size by the application\r\n      // (but only if not a header hint is about to show).\r\n      // This size has already been determined in CMHintShow.\r\n      if Assigned(Node) and (not IsRectEmpty(HintRect)) then\r\n        Result := HintRect\r\n      else\r\n      begin\r\n        if Column <= NoColumn then\r\n        begin\r\n          BidiMode := Tree.BidiMode;\r\n          Alignment := Tree.Alignment;\r\n        end\r\n        else\r\n        begin\r\n          BidiMode := Tree.Header.Columns[Column].BidiMode;\r\n          Alignment := Tree.Header.Columns[Column].Alignment;\r\n        end;\r\n\r\n        if BidiMode <> bdLeftToRight then\r\n          ChangeBidiModeAlignment(Alignment);\r\n\r\n        if (Node = nil) or (Tree.FHintMode <> hmToolTip) then\r\n          Canvas.Font := Screen.HintFont\r\n        else\r\n        begin\r\n          Canvas.Font := Tree.Font;\r\n          if Tree is TCustomVirtualStringTree then\r\n            with TCustomVirtualStringTree(Tree) do\r\n              DoPaintText(Node, Self.Canvas, Column, ttNormal);\r\n        end;\r\n\r\n        GetTextMetrics(Canvas.Handle, TM);\r\n        FTextHeight := TM.tmHeight;\r\n        LineBreakStyle := hlbDefault;\r\n\r\n        if Length(DefaultHint) > 0 then\r\n          HintText := DefaultHint\r\n        else\r\n          if Tree.HintMode = hmToolTip then\r\n            HintText := Tree.DoGetNodeToolTip(Node, Column, LineBreakStyle)\r\n          else\r\n            HintText := Tree.DoGetNodeHint(Node, Column, LineBreakStyle);\r\n\r\n        if Length(HintText) = 0 then\r\n          Result := Rect(0, 0, 0, 0)\r\n        else\r\n        begin\r\n          if Assigned(Node) and (Tree.FHintMode = hmToolTip) then\r\n          begin\r\n            // Determine actual line break style depending on what was returned by the methods and what's in the node.\r\n            if LineBreakStyle = hlbDefault then\r\n              if vsMultiline in Node.States then\r\n                LineBreakStyle := hlbForceMultiLine\r\n              else\r\n                LineBreakStyle := hlbForceSingleLine;\r\n\r\n            // Hint for a node.\r\n            if LineBreakStyle = hlbForceMultiLine then\r\n            begin\r\n              // Multiline tooltips use the columns width but extend the bottom border to fit the whole caption.\r\n              Result := Tree.GetDisplayRect(Node, Column, True, False);\r\n              R := Result;\r\n\r\n              // On Windows NT/2K/XP the behavior of the tooltip is slightly different to that on Windows 9x/Me.\r\n              // We don't have Unicode word wrap on the latter so the tooltip gets as wide as the largest line\r\n              // in the caption (limited by carriage return), which results in unoptimal overlay of the tooltip.\r\n              Winapi.Windows.DrawTextW(Canvas.Handle, PWideChar(HintText), Length(HintText), R, DT_CALCRECT or DT_WORDBREAK);\r\n              if BidiMode = bdLeftToRight then\r\n                Result.Right := R.Right + Tree.FTextMargin\r\n              else\r\n                Result.Left := R.Left - Tree.FTextMargin + 1;\r\n              Result.Bottom := R.Bottom;\r\n\r\n              Inc(Result.Right);\r\n\r\n              // If the node height and the column width are both already large enough to cover the entire text,\r\n              // then we don't need the hint, though.\r\n              // However if the text is partially scrolled out of the client area then a hint is useful as well.\r\n              if (Tree.Header.Columns.Count > 0) and ((Integer(Tree.NodeHeight[Node]) + 2) >= (Result.Bottom - Result.Top)) and\r\n                 ((Tree.Header.Columns[Column].Width + 2) >= (Result.Right - Result.Left)) and not\r\n                 ((Result.Left < 0) or (Result.Right > Tree.ClientWidth + 3) or\r\n                  (Result.Top < 0) or (Result.Bottom > Tree.ClientHeight + 3)) then\r\n              begin\r\n                Result := Rect(0, 0, 0, 0);\r\n                Exit;\r\n              end;\r\n            end\r\n            else\r\n            begin\r\n              Result := Tree.FLastHintRect; // = Tree.GetDisplayRect(Node, Column, True, True, True); see TBaseVirtualTree.CMHintShow\r\n              if toShowHorzGridLines in Tree.TreeOptions.PaintOptions then\r\n                Dec(Result.Bottom);\r\n            end;\r\n\r\n            // Include a one pixel border.\r\n            InflateRect(Result, 1, 1);\r\n\r\n            // Make the coordinates relative. They will again be offset by the caller code.\r\n            OffsetRect(Result, -Result.Left - 1, -Result.Top - 1);\r\n          end\r\n          else\r\n          begin\r\n            // Hint for a header or non-tooltip hint.\r\n\r\n            // Start with the base size of the hint in client coordinates.\r\n            Result := Rect(0, 0, MaxWidth, FTextHeight);\r\n            // Calculate the true size of the text rectangle.\r\n            Winapi.Windows.DrawTextW(Canvas.Handle, PWideChar(HintText), Length(HintText), Result, DT_CALCRECT or DT_TOP or DT_NOPREFIX or DT_WORDBREAK);\r\n            // The height of the text plus 2 pixels vertical margin plus the border determine the hint window height.\r\n            Inc(Result.Bottom, 6);\r\n            // The text is centered horizontally with usual text margin for left and right borders (plus border).\r\n            if not Assigned(Tree) then\r\n              Exit; // Workaround, because we have seen several exceptions here caught by Eurekalog. Submitted as issue #114 to http://code.google.com/p/virtual-treeview/\r\n            Inc(Result.Right, Tree.FTextMargin + FTextHeight); // We are extending the width here, but the text height scales with the text width and has a similar value as AveCharWdith * 2.\r\n          end;\r\n        end;\r\n      end;\r\n    end;\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TVirtualTreeHintWindow.IsHintMsg(var Msg: TMsg): Boolean;\r\n\r\n// The VCL is a bit too generous when telling that an existing hint can be cancelled. Need to specify further here.\r\n\r\nbegin\r\n  Result := inherited IsHintMsg(Msg) and HandleAllocated and IsWindowVisible(Handle);\r\n  // Avoid that mouse moves over the non-client area or key presses cancel the current hint.\r\n  if Result and ((Msg.Message = WM_NCMOUSEMOVE) or ((Msg.Message >= WM_KEYFIRST) and (Msg.Message <= WM_KEYLAST))) then\r\n    Result := False\r\n  else\r\n    // Work around problems with keypresses while doing hint animation.\r\n    if HandleAllocated and IsWindowVisible(Handle) and (Msg.Message >= WM_KEYFIRST) and (Msg.Message <= WM_KEYLAST) and\r\n      (tsInAnimation in FHintData.Tree.FStates) and TranslateMessage(Msg) then\r\n      DispatchMessage(Msg);\r\nend;\r\n\r\n//----------------- TVTDragImage ---------------------------------------------------------------------------------------\r\n\r\nconstructor TVTDragImage.Create(AOwner: TBaseVirtualTree);\r\n\r\nbegin\r\n  FOwner := AOwner;\r\n  FTransparency := 128;\r\n  FPreBlendBias := 0;\r\n  FPostBlendBias := 0;\r\n  FFade := False;\r\n  FRestriction := dmrNone;\r\n  FColorKey := clNone;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\ndestructor TVTDragImage.Destroy;\r\n\r\nbegin\r\n  EndDrag;\r\n\r\n  inherited;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TVTDragImage.GetVisible: Boolean;\r\n\r\n// Returns True if the internal drag image is used (i.e. the system does not natively support drag images) and\r\n// the internal image is currently visible on screen.\r\n\r\nbegin\r\n  Result := FStates * [disHidden, disInDrag, disPrepared, disSystemSupport] = [disInDrag, disPrepared];\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TVTDragImage.InternalShowDragImage(ScreenDC: HDC);\r\n\r\n// Frequently called helper routine to actually do the blend and put it onto the screen.\r\n// Only used if the system does not support drag images.\r\n\r\nvar\r\n  BlendMode: TBlendMode;\r\n\r\nbegin\r\n  with FAlphaImage do\r\n    BitBlt(Canvas.Handle, 0, 0, Width, Height, FBackImage.Canvas.Handle, 0, 0, SRCCOPY);\r\n  if not FFade and (FColorKey = clNone) then\r\n    BlendMode := bmConstantAlpha\r\n  else\r\n    BlendMode := bmMasterAlpha;\r\n  with FDragImage do\r\n    AlphaBlend(Canvas.Handle, FAlphaImage.Canvas.Handle, Rect(0, 0, Width, Height), Point(0, 0), BlendMode,\r\n      FTransparency, FPostBlendBias);\r\n\r\n  with FAlphaImage do\r\n    BitBlt(ScreenDC, FImagePosition.X, FImagePosition.Y, Width, Height, Canvas.Handle, 0, 0, SRCCOPY);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TVTDragImage.MakeAlphaChannel(Source, Target: TBitmap);\r\n\r\n// Helper method to create a proper alpha channel in Target (which must be in 32 bit pixel format), depending\r\n// on the settings for the drag image and the color values in Source.\r\n// Only used if the system does not support drag images.\r\n\r\ntype\r\n  PBGRA = ^TBGRA;\r\n  TBGRA = packed record\r\n    case Boolean of\r\n      False:\r\n        (Color: Cardinal);\r\n      True:\r\n        (BGR: array[0..2] of Byte;\r\n         Alpha: Byte);\r\n  end;\r\n\r\nvar\r\n  Color,\r\n  ColorKeyRef: COLORREF;\r\n  UseColorKey: Boolean;\r\n  SourceRun,\r\n  TargetRun: PBGRA;\r\n  X, Y,\r\n  MaxDimension,\r\n  HalfWidth,\r\n  HalfHeight: Integer;\r\n  T: Extended;\r\n\r\nbegin\r\n  UseColorKey := ColorKey <> clNone;\r\n  ColorKeyRef := ColorToRGB(ColorKey) and $FFFFFF;\r\n  // Color values are in the form BGR (red on LSB) while bitmap colors are in the form ARGB (blue on LSB)\r\n  // hence we have to swap red and blue in the color key.\r\n  with TBGRA(ColorKeyRef) do\r\n  begin\r\n    X := BGR[0];\r\n    BGR[0] := BGR[2];\r\n    BGR[2] := X;\r\n  end;\r\n\r\n  with Target do\r\n  begin\r\n    MaxDimension := Max(Width, Height);\r\n\r\n    HalfWidth := Width div 2;\r\n    HalfHeight := Height div 2;\r\n    for Y := 0 to Height - 1 do\r\n    begin\r\n      TargetRun := Scanline[Y];\r\n      SourceRun := Source.Scanline[Y];\r\n      for X := 0 to Width - 1 do\r\n      begin\r\n        Color := SourceRun.Color and $FFFFFF;\r\n        if UseColorKey and (Color = ColorKeyRef) then\r\n          TargetRun.Alpha := 0\r\n        else\r\n        begin\r\n          // If the color is not the given color key (or none is used) then do full calculation of a bell curve.\r\n          T := Exp(-8 * Sqrt(Sqr((X - HalfWidth) / MaxDimension) + Sqr((Y - HalfHeight) / MaxDimension)));\r\n          TargetRun.Alpha := Round(255 * T);\r\n        end;\r\n        Inc(SourceRun);\r\n        Inc(TargetRun);\r\n      end;\r\n    end;\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TVTDragImage.DragTo(P: TPoint; ForceRepaint: Boolean): Boolean;\r\n\r\n// Moves the drag image to a new position, which is determined from the passed point P and the previous\r\n// mouse position.\r\n// ForceRepaint is True if something on the screen changed and the back image must be refreshed.\r\n\r\nvar\r\n  ScreenDC: HDC;\r\n  DeltaX,\r\n  DeltaY: Integer;\r\n\r\n  // optimized drag image move support\r\n  RSamp1,\r\n  RSamp2,       // newly added parts from screen which will be overwritten\r\n  RDraw1,\r\n  RDraw2,       // parts to be restored to screen\r\n  RScroll,\r\n  RClip: TRect; // ScrollDC of the existent background\r\n\r\nbegin\r\n  // Determine distances to move the drag image. Take care for restrictions.\r\n  case FRestriction of\r\n    dmrHorizontalOnly:\r\n      begin\r\n        DeltaX := FLastPosition.X - P.X;\r\n        DeltaY := 0;\r\n      end;\r\n    dmrVerticalOnly:\r\n      begin\r\n        DeltaX := 0;\r\n        DeltaY := FLastPosition.Y - P.Y;\r\n      end;\r\n  else // dmrNone\r\n    DeltaX := FLastPosition.X - P.X;\r\n    DeltaY := FLastPosition.Y - P.Y;\r\n  end;\r\n\r\n  Result := (DeltaX <> 0) or (DeltaY <> 0) or ForceRepaint;\r\n  if Result then\r\n  begin\r\n    if Visible then\r\n    begin\r\n      // All this stuff is only called if we have to handle the drag image ourselves. If the system supports\r\n      // drag image then this is all never executed.\r\n      ScreenDC := GetDC(0);\r\n      try\r\n        if (Abs(DeltaX) >= FDragImage.Width) or (Abs(DeltaY) >= FDragImage.Height) or ForceRepaint then\r\n        begin\r\n          // If moved more than image size then just restore old screen and blit image to new position.\r\n          BitBlt(ScreenDC, FImagePosition.X, FImagePosition.Y, FBackImage.Width, FBackImage.Height,\r\n            FBackImage.Canvas.Handle, 0, 0, SRCCOPY);\r\n\r\n          if ForceRepaint then\r\n            UpdateWindow(FOwner.Handle);\r\n\r\n          Inc(FImagePosition.X, -DeltaX);\r\n          Inc(FImagePosition.Y, -DeltaY);\r\n\r\n          BitBlt(FBackImage.Canvas.Handle, 0, 0, FBackImage.Width, FBackImage.Height, ScreenDC, FImagePosition.X,\r\n            FImagePosition.Y, SRCCOPY);\r\n        end\r\n        else\r\n        begin\r\n          // overlapping copy\r\n          FillDragRectangles(FDragImage.Width, FDragImage.Height, DeltaX, DeltaY, RClip, RScroll, RSamp1, RSamp2, RDraw1,\r\n            RDraw2);\r\n\r\n          with FBackImage.Canvas do\r\n          begin\r\n            // restore uncovered areas of the screen\r\n            if DeltaX = 0 then\r\n            begin\r\n              with TWithSafeRect(RDraw2) do\r\n                BitBlt(ScreenDC, FImagePosition.X + Left, FImagePosition.Y + Top, Right, Bottom, Handle, Left, Top,\r\n                  SRCCOPY);\r\n            end\r\n            else\r\n            begin\r\n              if DeltaY = 0 then\r\n              begin\r\n                with TWithSafeRect(RDraw1) do\r\n                  BitBlt(ScreenDC, FImagePosition.X + Left, FImagePosition.Y + Top, Right, Bottom, Handle, Left, Top,\r\n                    SRCCOPY);\r\n              end\r\n              else\r\n              begin\r\n                with TWithSafeRect(RDraw1) do\r\n                  BitBlt(ScreenDC, FImagePosition.X + Left, FImagePosition.Y + Top, Right, Bottom, Handle, Left, Top,\r\n                    SRCCOPY);\r\n                with TWithSafeRect(RDraw2) do\r\n                  BitBlt(ScreenDC, FImagePosition.X + Left, FImagePosition.Y + Top, Right, Bottom, Handle, Left, Top,\r\n                    SRCCOPY);\r\n              end;\r\n            end;\r\n\r\n            // move existent background\r\n            ScrollDC(Handle, DeltaX, DeltaY, RScroll, RClip, 0, nil);\r\n\r\n            Inc(FImagePosition.X, -DeltaX);\r\n            Inc(FImagePosition.Y, -DeltaY);\r\n\r\n            // Get first and second additional rectangle from screen.\r\n            if DeltaX = 0 then\r\n            begin\r\n              with TWithSafeRect(RSamp2) do\r\n                BitBlt(Handle, Left, Top, Right, Bottom, ScreenDC, FImagePosition.X + Left, FImagePosition.Y + Top,\r\n                  SRCCOPY);\r\n            end\r\n            else\r\n              if DeltaY = 0 then\r\n              begin\r\n                with TWithSafeRect(RSamp1) do\r\n                  BitBlt(Handle, Left, Top, Right, Bottom, ScreenDC, FImagePosition.X + Left, FImagePosition.Y + Top,\r\n                    SRCCOPY);\r\n              end\r\n              else\r\n              begin\r\n                with TWithSafeRect(RSamp1) do\r\n                  BitBlt(Handle, Left, Top, Right, Bottom, ScreenDC, FImagePosition.X + Left, FImagePosition.Y + Top,\r\n                    SRCCOPY);\r\n                with TWithSafeRect(RSamp2) do\r\n                  BitBlt(Handle, Left, Top, Right, Bottom, ScreenDC, FImagePosition.X + Left, FImagePosition.Y + Top,\r\n                    SRCCOPY);\r\n              end;\r\n          end;\r\n        end;\r\n        InternalShowDragImage(ScreenDC);\r\n      finally\r\n        ReleaseDC(0, ScreenDC);\r\n      end;\r\n    end;\r\n    FLastPosition.X := P.X;\r\n    FLastPosition.Y := P.Y;\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TVTDragImage.EndDrag;\r\n\r\nbegin\r\n  HideDragImage;\r\n  FStates := FStates - [disInDrag, disPrepared];\r\n\r\n  FBackImage.Free;\r\n  FBackImage := nil;\r\n  FDragImage.Free;\r\n  FDragImage := nil;\r\n  FAlphaImage.Free;\r\n  FAlphaImage := nil;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TVTDragImage.GetDragImageRect: TRect;\r\n\r\n// Returns the current size and position of the drag image (screen coordinates).\r\n\r\nbegin\r\n  if Visible then\r\n  begin\r\n    with FBackImage do\r\n      Result := Rect(FImagePosition.X, FImagePosition.Y, FImagePosition.X + Width, FImagePosition.Y + Height);\r\n  end\r\n  else\r\n    Result := Rect(0, 0, 0, 0);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TVTDragImage.HideDragImage;\r\n\r\nvar\r\n  ScreenDC: HDC;\r\n\r\nbegin\r\n  if Visible then\r\n  begin\r\n    Include(FStates, disHidden);\r\n    ScreenDC := GetDC(0);\r\n    try\r\n      // restore screen\r\n      with FBackImage do\r\n        BitBlt(ScreenDC, FImagePosition.X, FImagePosition.Y, Width, Height, Canvas.Handle, 0, 0, SRCCOPY);\r\n    finally\r\n      ReleaseDC(0, ScreenDC);\r\n    end;\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TVTDragImage.PrepareDrag(DragImage: TBitmap; ImagePosition, HotSpot: TPoint; const DataObject: IDataObject);\r\n\r\n// Creates all necessary structures to do alpha blended dragging using the given image.\r\n// ImagePostion and HotSpot are given in screen coordinates. The first determines where to place the drag image while\r\n// the second is the initial mouse position.\r\n// This method also determines whether the system supports drag images natively. If so then only minimal structures\r\n// are created.\r\n\r\nvar\r\n  Width,\r\n  Height: Integer;\r\n  DragSourceHelper: IDragSourceHelper;\r\n  DragInfo: TSHDragImage;\r\n  lDragSourceHelper2: IDragSourceHelper2;// Needed to get Windows Vista+ style drag hints.\r\n  lNullPoint: TPoint;\r\nbegin\r\n  Width := DragImage.Width;\r\n  Height := DragImage.Height;\r\n\r\n  // Determine whether the system supports the drag helper interfaces.\r\n  if Assigned(DataObject) and Succeeded(CoCreateInstance(CLSID_DragDropHelper, nil, CLSCTX_INPROC_SERVER,\r\n    IDragSourceHelper, DragSourceHelper)) then\r\n  begin\r\n    Include(FStates, disSystemSupport);\r\n    lNullPoint := Point(0,0);\r\n    if Supports(DragSourceHelper, IDragSourceHelper2, lDragSourceHelper2) then\r\n      lDragSourceHelper2.SetFlags(DSH_ALLOWDROPDESCRIPTIONTEXT);// Show description texts\r\n    // First let the system try to initialze the DragSourceHelper, this works fine for file system objects (CF_HDROP)\r\n    StandardOLEFormat.cfFormat := CF_HDROP;\r\n    if not Succeeded(DataObject.QueryGetData(StandardOLEFormat)) or not Succeeded(DragSourceHelper.InitializeFromWindow(0, lNullPoint, DataObject)) then\r\n    begin\r\n      // Supply the drag source helper with our drag image.\r\n      DragInfo.sizeDragImage.cx := Width;\r\n      DragInfo.sizeDragImage.cy := Height;\r\n      DragInfo.ptOffset.x := Width div 2;\r\n      DragInfo.ptOffset.y := Height div 2;\r\n      DragInfo.hbmpDragImage := CopyImage(DragImage.Handle, IMAGE_BITMAP, Width, Height, LR_COPYRETURNORG);\r\n      DragInfo.crColorKey := ColorToRGB(FColorKey);\r\n      if not Succeeded(DragSourceHelper.InitializeFromBitmap(@DragInfo, DataObject)) then\r\n      begin\r\n        DeleteObject(DragInfo.hbmpDragImage);\r\n        Exclude(FStates, disSystemSupport);\r\n      end;\r\n    end;\r\n  end\r\n  else\r\n    Exclude(FStates, disSystemSupport);\r\n\r\n  if MMXAvailable and not (disSystemSupport in FStates) then\r\n  begin\r\n    FLastPosition := HotSpot;\r\n\r\n    FDragImage := TBitmap.Create;\r\n    FDragImage.PixelFormat := pf32Bit;\r\n    FDragImage.Width := Width;\r\n    FDragImage.Height := Height;\r\n\r\n    FAlphaImage := TBitmap.Create;\r\n    FAlphaImage.PixelFormat := pf32Bit;\r\n    FAlphaImage.Width := Width;\r\n    FAlphaImage.Height := Height;\r\n\r\n    FBackImage := TBitmap.Create;\r\n    FBackImage.PixelFormat := pf32Bit;\r\n    FBackImage.Width := Width;\r\n    FBackImage.Height := Height;\r\n\r\n    // Copy the given drag image and apply pre blend bias if required.\r\n    if FPreBlendBias = 0 then\r\n      with FDragImage do\r\n        BitBlt(Canvas.Handle, 0, 0, Width, Height, DragImage.Canvas.Handle, 0, 0, SRCCOPY)\r\n    else\r\n      AlphaBlend(DragImage.Canvas.Handle, FDragImage.Canvas.Handle, Rect(0, 0, Width, Height), Point(0, 0),\r\n        bmConstantAlpha, 255, FPreBlendBias);\r\n\r\n    // Create a proper alpha channel also if no fading is required (transparent parts).\r\n    MakeAlphaChannel(DragImage, FDragImage);\r\n\r\n    FImagePosition := ImagePosition;\r\n\r\n    // Initially the drag image is hidden and will be shown during the immediately following DragEnter event.\r\n    FStates := FStates + [disInDrag, disHidden, disPrepared];\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TVTDragImage.RecaptureBackground(Tree: TBaseVirtualTree; R: TRect; VisibleRegion: HRGN;\r\n  CaptureNCArea, ReshowDragImage: Boolean);\r\n\r\n// Notification by the drop target tree to update the background image because something in the tree has changed.\r\n// Note: The passed rectangle is given in client coordinates of the current drop target tree (given in Tree).\r\n//       The caller does not check if the given rectangle is actually within the drag image. Hence this method must do\r\n//       all the checks.\r\n// This method does nothing if the system manages the drag image.\r\n\r\nvar\r\n  DragRect,\r\n  ClipRect: TRect;\r\n  PaintTarget: TPoint;\r\n  PaintOptions: TVTInternalPaintOptions;\r\n  ScreenDC: HDC;\r\n\r\nbegin\r\n  // Recapturing means we want the tree to paint the new part into our back bitmap instead to the screen.\r\n  if Visible then\r\n  begin\r\n    // Create the minimum rectangle to be recaptured.\r\n    MapWindowPoints(Tree.Handle, 0, R, 2);\r\n    DragRect := GetDragImageRect;\r\n    IntersectRect(R, R, DragRect);\r\n\r\n    OffsetRgn(VisibleRegion, -DragRect.Left, -DragRect.Top);\r\n\r\n    // The target position for painting in the drag image is relative and can be determined from screen coordinates too.\r\n    PaintTarget.X := R.Left - DragRect.Left;\r\n    PaintTarget.Y := R.Top - DragRect.Top;\r\n\r\n    // The source rectangle is determined by the offsets in the tree.\r\n    MapWindowPoints(0, Tree.Handle, R, 2);\r\n    OffsetRect(R, -Tree.FOffsetX, -Tree.FOffsetY);\r\n\r\n    // Finally let the tree paint the relevant part and upate the drag image on screen.\r\n    PaintOptions := [poBackground, poColumnColor, poDrawFocusRect, poDrawDropMark, poDrawSelection, poGridLines];\r\n    with FBackImage do\r\n    begin\r\n      ClipRect.TopLeft := PaintTarget;\r\n      ClipRect.Right := ClipRect.Left + R.Right - R.Left;\r\n      ClipRect.Bottom := ClipRect.Top + R.Bottom - R.Top;\r\n      ClipCanvas(Canvas, ClipRect, VisibleRegion);\r\n      Tree.PaintTree(Canvas, R, PaintTarget, PaintOptions);\r\n\r\n      if CaptureNCArea then\r\n      begin\r\n        // For the non-client area we only need the visible region of the window as limit for painting.\r\n        SelectClipRgn(Canvas.Handle, VisibleRegion);\r\n        // Since WM_PRINT cannot be given a position where to draw we simply move the window origin and\r\n        // get the same effect.\r\n        GetWindowRect(Tree.Handle, ClipRect);\r\n        SetCanvasOrigin(Canvas, DragRect.Left - ClipRect.Left, DragRect.Top - ClipRect.Top);\r\n        Tree.Perform(WM_PRINT, WPARAM(Canvas.Handle), PRF_NONCLIENT);\r\n        SetCanvasOrigin(Canvas, 0, 0);\r\n      end;\r\n      SelectClipRgn(Canvas.Handle, 0);\r\n\r\n      if ReshowDragImage then\r\n      begin\r\n        GDIFlush;\r\n        ScreenDC := GetDC(0);\r\n        try\r\n          InternalShowDragImage(ScreenDC);\r\n        finally\r\n          ReleaseDC(0, ScreenDC);\r\n        end;\r\n      end;\r\n    end;\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TVTDragImage.ShowDragImage;\r\n\r\n// Shows the drag image after it has been hidden by HideDragImage.\r\n// Note: there might be a new background now.\r\n// Also this method does nothing if the system manages the drag image.\r\n\r\nvar\r\n  ScreenDC: HDC;\r\n\r\nbegin\r\n  if FStates * [disInDrag, disHidden, disPrepared, disSystemSupport] = [disInDrag, disHidden, disPrepared] then\r\n  begin\r\n    Exclude(FStates, disHidden);\r\n\r\n    GDIFlush;\r\n    ScreenDC := GetDC(0);\r\n    try\r\n      BitBlt(FBackImage.Canvas.Handle, 0, 0, FBackImage.Width, FBackImage.Height, ScreenDC, FImagePosition.X,\r\n        FImagePosition.Y, SRCCOPY);\r\n\r\n      InternalShowDragImage(ScreenDC);\r\n    finally\r\n      ReleaseDC(0, ScreenDC);\r\n    end;\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TVTDragImage.WillMove(P: TPoint): Boolean;\r\n\r\n// This method determines whether the drag image would \"physically\" move when DragTo would be called with the same\r\n// target point.\r\n// Always returns False if the system drag image support is available.\r\n\r\nbegin\r\n  Result := Visible;\r\n  if Result then\r\n  begin\r\n    // Determine distances to move the drag image. Take care for restrictions.\r\n    case FRestriction of\r\n      dmrHorizontalOnly:\r\n        Result := FLastPosition.X <> P.X;\r\n      dmrVerticalOnly:\r\n        Result := FLastPosition.Y <> P.Y;\r\n    else // dmrNone\r\n      Result := (FLastPosition.X <> P.X) or (FLastPosition.Y <> P.Y);\r\n    end;\r\n  end;\r\nend;\r\n\r\n//----------------- TVTVirtualNodeEnumerator ---------------------------------------------------------------------------\r\n\r\nfunction TVTVirtualNodeEnumerator.GetCurrent: PVirtualNode;\r\n\r\nbegin\r\n  Result := FNode;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TVTVirtualNodeEnumerator.MoveNext: Boolean;\r\n\r\nbegin\r\n  Result := FCanModeNext;\r\n  if Result then\r\n  begin\r\n    FNode := FEnumeration.GetNext(FNode);\r\n    Result := FNode <> nil;\r\n    FCanModeNext := Result;\r\n  end;\r\nend;\r\n\r\n//----------------- TVTVirtualNodeEnumeration --------------------------------------------------------------------------\r\n\r\nfunction TVTVirtualNodeEnumeration.GetEnumerator: TVTVirtualNodeEnumerator;\r\n\r\nbegin\r\n  Result.FNode := nil;\r\n  Result.FCanModeNext := True;\r\n  Result.FEnumeration := @Self;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TVTVirtualNodeEnumeration.GetNext(Node: PVirtualNode): PVirtualNode;\r\nbegin\r\n  case FMode of\r\n    vneAll:\r\n      if Node = nil then\r\n        Result := FTree.GetFirst(FConsiderChildrenAbove)\r\n      else\r\n        Result := FTree.GetNext(Node, FConsiderChildrenAbove);\r\n\r\n    vneChecked:\r\n      if Node = nil then\r\n        Result := FTree.GetFirstChecked(FState, FConsiderChildrenAbove)\r\n      else\r\n        Result := FTree.GetNextChecked(Node, FState, FConsiderChildrenAbove);\r\n\r\n    vneChild:\r\n      if Node = nil then\r\n        Result := FTree.GetFirstChild(FNode)\r\n      else\r\n        Result := FTree.GetNextSibling(Node);\r\n\r\n    vneCutCopy:\r\n      if Node = nil then\r\n        Result := FTree.GetFirstCutCopy(FConsiderChildrenAbove)\r\n      else\r\n        Result := FTree.GetNextCutCopy(Node, FConsiderChildrenAbove);\r\n\r\n    vneInitialized:\r\n      if Node = nil then\r\n        Result := FTree.GetFirstInitialized(FConsiderChildrenAbove)\r\n      else\r\n        Result := FTree.GetNextInitialized(Node, FConsiderChildrenAbove);\r\n\r\n    vneLeaf:\r\n      if Node = nil then\r\n        Result := FTree.GetFirstLeaf\r\n      else\r\n        Result := FTree.GetNextLeaf(Node);\r\n\r\n    vneLevel:\r\n      if Node = nil then\r\n        Result := FTree.GetFirstLevel(FNodeLevel)\r\n      else\r\n        Result := FTree.GetNextLevel(Node, FNodeLevel);\r\n\r\n    vneNoInit:\r\n      if Node = nil then\r\n        Result := FTree.GetFirstNoInit(FConsiderChildrenAbove)\r\n      else\r\n        Result := FTree.GetNextNoInit(Node, FConsiderChildrenAbove);\r\n\r\n    vneSelected:\r\n      if Node = nil then\r\n        Result := FTree.GetFirstSelected(FConsiderChildrenAbove)\r\n      else\r\n        Result := FTree.GetNextSelected(Node, FConsiderChildrenAbove);\r\n\r\n    vneVisible:\r\n      begin\r\n        if Node = nil then\r\n        begin\r\n          Result := FTree.GetFirstVisible(FNode, FConsiderChildrenAbove, FIncludeFiltered);\r\n          if FIncludeFiltered or not FTree.IsEffectivelyFiltered[Result] then\r\n            Exit;\r\n        end;\r\n        repeat\r\n          Result := FTree.GetNextVisible(Node{, FConsiderChildrenAbove});\r\n        until not Assigned(Result) or FIncludeFiltered or not FTree.IsEffectivelyFiltered[Result];\r\n      end;\r\n\r\n    vneVisibleChild:\r\n      if Node = nil then\r\n        Result := FTree.GetFirstVisibleChild(FNode, FIncludeFiltered)\r\n      else\r\n        Result := FTree.GetNextVisibleSibling(Node, FIncludeFiltered);\r\n\r\n    vneVisibleNoInitChild:\r\n      if Node = nil then\r\n        Result := FTree.GetFirstVisibleChildNoInit(FNode, FIncludeFiltered)\r\n      else\r\n        Result := FTree.GetNextVisibleSiblingNoInit(Node, FIncludeFiltered);\r\n\r\n    vneVisibleNoInit:\r\n      begin\r\n        if Node = nil then\r\n        begin\r\n          Result := FTree.GetFirstVisibleNoInit(FNode, FConsiderChildrenAbove, FIncludeFiltered);\r\n          if FIncludeFiltered or not FTree.IsEffectivelyFiltered[Result] then\r\n            Exit;\r\n        end;\r\n        repeat\r\n          Result := FTree.GetNextVisibleNoInit(Node, FConsiderChildrenAbove);\r\n        until not Assigned(Result) or FIncludeFiltered or not FTree.IsEffectivelyFiltered[Result];\r\n      end;\r\n  else\r\n    Result := nil;\r\n  end;\r\nend;\r\n\r\n//----------------- TVirtualTreeColumn ---------------------------------------------------------------------------------\r\n\r\nconstructor TVirtualTreeColumn.Create(Collection: TCollection);\r\n\r\nbegin\r\n  FMinWidth := 10;\r\n  FMaxWidth := 10000;\r\n  FImageIndex := -1;\r\n  FMargin := 4;\r\n  FSpacing := 3;\r\n  FText := '';\r\n  FOptions := DefaultColumnOptions;\r\n  FAlignment := taLeftJustify;\r\n  FBiDiMode := bdLeftToRight;\r\n  FColor := clWindow;\r\n  FLayout := blGlyphLeft;\r\n  FBonusPixel := False;\r\n  FCaptionAlignment := taLeftJustify;\r\n  FCheckType := ctCheckBox;\r\n  FCheckState := csUncheckedNormal;\r\n  FCheckBox := False;\r\n  FHasImage := False;\r\n  FDefaultSortDirection := sdAscending;\r\n\r\n  inherited Create(Collection);\r\n\r\n  FWidth := Owner.FDefaultWidth;\r\n  FLastWidth := Owner.FDefaultWidth;\r\n  FPosition := Owner.Count - 1;\r\n  // Read parent bidi mode and color values as default values.\r\n  ParentBiDiModeChanged;\r\n  ParentColorChanged;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\ndestructor TVirtualTreeColumn.Destroy;\r\n\r\nvar\r\n  I: Integer;\r\n\r\n  //--------------- local function ---------------------------------------------\r\n\r\n  procedure AdjustColumnIndex(var ColumnIndex: TColumnIndex);\r\n\r\n  begin\r\n    if Index = ColumnIndex then\r\n      ColumnIndex := NoColumn\r\n    else\r\n      if Index < ColumnIndex then\r\n        Dec(ColumnIndex);\r\n  end;\r\n\r\n  //--------------- end local function -----------------------------------------\r\n\r\nbegin\r\n  // Check if this column is somehow referenced by its collection parent or the header.\r\n  with Owner do\r\n  begin\r\n    // If the columns collection object is currently deleting all columns\r\n    // then we don't need to check the various cached indices individually.\r\n    if not FClearing then\r\n    begin\r\n      Header.Treeview.CancelEditNode;\r\n      IndexChanged(Index, -1);\r\n\r\n      AdjustColumnIndex(FHoverIndex);\r\n      AdjustColumnIndex(FDownIndex);\r\n      AdjustColumnIndex(FTrackIndex);\r\n      AdjustColumnIndex(FClickIndex);\r\n\r\n      with Header do\r\n      begin\r\n        AdjustColumnIndex(FAutoSizeIndex);\r\n        if Index = FMainColumn then\r\n        begin\r\n          // If the current main column is about to be destroyed then we have to find a new main column.\r\n          FMainColumn := NoColumn;\r\n          for I := 0 to Count - 1 do\r\n            if I <> Index then\r\n            begin\r\n              FMainColumn := I;\r\n              Break;\r\n            end;\r\n        end;\r\n        AdjustColumnIndex(FSortColumn);\r\n      end;\r\n    end;\r\n  end;\r\n\r\n  inherited;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TVirtualTreeColumn.GetCaptionAlignment: TAlignment;\r\n\r\nbegin\r\n  if coUseCaptionAlignment in FOptions then\r\n    Result := FCaptionAlignment\r\n  else\r\n    Result := FAlignment;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TVirtualTreeColumn.GetLeft: Integer;\r\n\r\nbegin\r\n  Result := FLeft;\r\n  if [coVisible, coFixed] * FOptions <> [coVisible, coFixed] then\r\n    Dec(Result, Owner.Header.Treeview.FEffectiveOffsetX);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TVirtualTreeColumn.IsBiDiModeStored: Boolean;\r\n\r\nbegin\r\n  Result := not (coParentBiDiMode in FOptions);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TVirtualTreeColumn.IsCaptionAlignmentStored: Boolean;\r\n\r\nbegin\r\n  Result := coUseCaptionAlignment in FOptions;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TVirtualTreeColumn.IsColorStored: Boolean;\r\n\r\nbegin\r\n  Result := not (coParentColor in FOptions);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TVirtualTreeColumn.SetAlignment(const Value: TAlignment);\r\n\r\nbegin\r\n  if FAlignment <> Value then\r\n  begin\r\n    FAlignment := Value;\r\n    Changed(False);\r\n    // Setting the alignment affects also the tree, hence invalidate it too.\r\n    Owner.Header.TreeView.Invalidate;\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TVirtualTreeColumn.SetBiDiMode(Value: TBiDiMode);\r\n\r\nbegin\r\n  if Value <> FBiDiMode then\r\n  begin\r\n    FBiDiMode := Value;\r\n    Exclude(FOptions, coParentBiDiMode);\r\n    Changed(False);\r\n    // Setting the alignment affects also the tree, hence invalidate it too.\r\n    Owner.Header.TreeView.Invalidate;\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TVirtualTreeColumn.SetCaptionAlignment(const Value: TAlignment);\r\n\r\nbegin\r\n  if not (coUseCaptionAlignment in FOptions) or (FCaptionAlignment <> Value) then\r\n  begin\r\n    FCaptionAlignment := Value;\r\n    Include(FOptions, coUseCaptionAlignment);\r\n    // Setting the alignment affects also the tree, hence invalidate it too.\r\n    Owner.Header.Invalidate(Self);\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TVirtualTreeColumn.SetColor(const Value: TColor);\r\n\r\nbegin\r\n  if FColor <> Value then\r\n  begin\r\n    FColor := Value;\r\n    Exclude(FOptions, coParentColor);\r\n    Changed(False);\r\n    Owner.Header.TreeView.Invalidate;\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TVirtualTreeColumn.SetCheckBox(Value: Boolean);\r\n\r\nbegin\r\n  if Value <> FCheckBox then\r\n  begin\r\n    FCheckBox := Value;\r\n    if Value and (csDesigning in Owner.Header.Treeview.ComponentState) then\r\n      Owner.Header.Options := Owner.Header.Options + [hoShowImages];\r\n    Changed(False);\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TVirtualTreeColumn.SetCheckState(Value: TCheckState);\r\n\r\nbegin\r\n  if Value <> FCheckState then\r\n  begin\r\n    FCheckState := Value;\r\n    Changed(False);\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TVirtualTreeColumn.SetCheckType(Value: TCheckType);\r\n\r\nbegin\r\n  if Value <> FCheckType then\r\n  begin\r\n    FCheckType := Value;\r\n    Changed(False);\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TVirtualTreeColumn.SetImageIndex(Value: TImageIndex);\r\n\r\nbegin\r\n  if Value <> FImageIndex then\r\n  begin\r\n    FImageIndex := Value;\r\n    Changed(False);\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TVirtualTreeColumn.SetLayout(Value: TVTHeaderColumnLayout);\r\n\r\nbegin\r\n  if FLayout <> Value then\r\n  begin\r\n    FLayout := Value;\r\n    Changed(False);\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TVirtualTreeColumn.SetMargin(Value: Integer);\r\n\r\nbegin\r\n  // Compatibility setting for -1.\r\n  if Value < 0 then\r\n    Value := 4;\r\n  if FMargin <> Value then\r\n  begin\r\n    FMargin := Value;\r\n    Changed(False);\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TVirtualTreeColumn.SetMaxWidth(Value: Integer);\r\n\r\nbegin\r\n  if Value < FMinWidth then\r\n    Value := FMinWidth;\r\n  FMaxWidth := Value;\r\n  SetWidth(FWidth);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TVirtualTreeColumn.SetMinWidth(Value: Integer);\r\n\r\nbegin\r\n  if Value < 0 then\r\n    Value := 0;\r\n  if Value > FMaxWidth then\r\n    Value := FMaxWidth;\r\n  FMinWidth := Value;\r\n  SetWidth(FWidth);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TVirtualTreeColumn.SetOptions(Value: TVTColumnOptions);\r\n\r\nvar\r\n  ToBeSet,\r\n  ToBeCleared: TVTColumnOptions;\r\n  VisibleChanged,\r\n  ColorChanged: Boolean;\r\n\r\nbegin\r\n  if FOptions <> Value then\r\n  begin\r\n    ToBeCleared := FOptions - Value;\r\n    ToBeSet := Value - FOptions;\r\n\r\n    FOptions := Value;\r\n\r\n    VisibleChanged := coVisible in (ToBeSet + ToBeCleared);\r\n    ColorChanged := coParentColor in ToBeSet;\r\n\r\n    if coParentBidiMode in ToBeSet then\r\n      ParentBiDiModeChanged;\r\n    if ColorChanged then\r\n      ParentColorChanged;\r\n\r\n    if coAutoSpring in ToBeSet then\r\n      FSpringRest := 0;\r\n\r\n    if ((coFixed in ToBeSet) or (coFixed in ToBeCleared)) and (coVisible in FOptions) then\r\n      Owner.Header.RescaleHeader;\r\n\r\n    Changed(False);\r\n    // Need to repaint and adjust the owner tree too.\r\n    with Owner, Header.Treeview do\r\n      if not (csLoading in ComponentState) and (VisibleChanged or ColorChanged) and (UpdateCount = 0) and\r\n        HandleAllocated then\r\n      begin\r\n        Invalidate;\r\n        if VisibleChanged then\r\n          UpdateHorizontalScrollBar(False);\r\n      end;\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TVirtualTreeColumn.SetPosition(Value: TColumnPosition);\r\n\r\nvar\r\n  Temp: TColumnIndex;\r\n\r\nbegin\r\n  if csLoading in Owner.Header.Treeview.ComponentState then\r\n    // Only cache the position for final fixup when loading from DFM.\r\n    FPosition := Value\r\n  else\r\n  begin\r\n    if Value >= TColumnPosition(Collection.Count) then\r\n      Value := Collection.Count - 1;\r\n    if FPosition <> Value then\r\n    begin\r\n      with Owner do\r\n      begin\r\n        InitializePositionArray;\r\n        Header.Treeview.CancelEditNode;\r\n        AdjustPosition(Self, Value);\r\n        Self.Changed(False);\r\n\r\n        // Need to repaint.\r\n        with Header do\r\n        begin\r\n          if (UpdateCount = 0) and Treeview.HandleAllocated then\r\n          begin\r\n            Invalidate(Self);\r\n            Treeview.Invalidate;\r\n          end;\r\n        end;\r\n      end;\r\n\r\n      // If the moved column is now within the fixed columns then we make it fixed as well. If it's not\r\n      // we clear the fixed state (in case that fixed column is moved outside fixed area).\r\n      if (coFixed in FOptions) and (FPosition > 0) then\r\n        Temp := Owner.ColumnFromPosition(FPosition - 1)\r\n      else\r\n        Temp := Owner.ColumnFromPosition(FPosition + 1);\r\n\r\n      if Temp <> NoColumn then\r\n      begin\r\n        if coFixed in Owner[Temp].Options then\r\n          Options := Options + [coFixed]\r\n        else\r\n          Options := Options - [coFixed];\r\n      end;\r\n    end;\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TVirtualTreeColumn.SetSpacing(Value: Integer);\r\n\r\nbegin\r\n  if FSpacing <> Value then\r\n  begin\r\n    FSpacing := Value;\r\n    Changed(False);\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TVirtualTreeColumn.SetStyle(Value: TVirtualTreeColumnStyle);\r\n\r\nbegin\r\n  if FStyle <> Value then\r\n  begin\r\n    FStyle := Value;\r\n    Changed(False);\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TVirtualTreeColumn.SetText(const Value: string);\r\n\r\nbegin\r\n  if FText <> Value then\r\n  begin\r\n    FText := Value;\r\n    FCaptionText := '';\r\n    Changed(False);\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TVirtualTreeColumn.SetWidth(Value: Integer);\r\n\r\nvar\r\n  EffectiveMaxWidth,\r\n  EffectiveMinWidth,\r\n  TotalFixedMaxWidth,\r\n  TotalFixedMinWidth: Integer;\r\n  I: TColumnIndex;\r\n\r\nbegin\r\n  if not (hsScaling in Owner.FHeader.FStates) then\r\n    if ([coVisible, coFixed] * FOptions = [coVisible, coFixed]) then\r\n    begin\r\n      with Owner, FHeader, FFixedAreaConstraints, TreeView do\r\n      begin\r\n        TotalFixedMinWidth := 0;\r\n        TotalFixedMaxWidth := 0;\r\n        for I := 0 to FColumns.Count - 1 do\r\n          if ([coVisible, coFixed] * FColumns[I].FOptions = [coVisible, coFixed]) then\r\n          begin\r\n            Inc(TotalFixedMaxWidth, FColumns[I].FMaxWidth);\r\n            Inc(TotalFixedMinWidth, FColumns[I].FMinWidth);\r\n          end;\r\n\r\n        // The percentage values have precedence over the pixel values.\r\n        TotalFixedMinWidth := IfThen(FMaxWidthPercent > 0,\r\n                                     Min((ClientWidth * FMaxWidthPercent) div 100, TotalFixedMinWidth),\r\n                                     TotalFixedMinWidth);\r\n        TotalFixedMaxWidth := IfThen(FMinWidthPercent > 0,\r\n                                     Max((ClientWidth * FMinWidthPercent) div 100, TotalFixedMaxWidth),\r\n                                     TotalFixedMaxWidth);\r\n\r\n        EffectiveMaxWidth := Min(TotalFixedMaxWidth - (GetVisibleFixedWidth - Self.FWidth), FMaxWidth);\r\n        EffectiveMinWidth := Max(TotalFixedMinWidth - (GetVisibleFixedWidth - Self.FWidth), FMinWidth);\r\n        Value := Min(Max(Value, EffectiveMinWidth), EffectiveMaxWidth);\r\n\r\n        if FMinWidthPercent > 0 then\r\n          Value := Max((ClientWidth * FMinWidthPercent) div 100 - GetVisibleFixedWidth + Self.FWidth, Value);\r\n        if FMaxWidthPercent > 0 then\r\n          Value := Min((ClientWidth * FMaxWidthPercent) div 100 - GetVisibleFixedWidth + Self.FWidth, Value);\r\n      end;\r\n    end\r\n    else\r\n      Value := Min(Max(Value, FMinWidth), FMaxWidth);\r\n\r\n  if FWidth <> Value then\r\n  begin\r\n    FLastWidth := FWidth;\r\n    if not (hsResizing in Owner.Header.States) then\r\n      FBonusPixel := False;\r\n    if not (hoAutoResize in Owner.Header.Options) or (Index <> Owner.Header.AutoSizeIndex) then\r\n    begin\r\n      FWidth := Value;\r\n      Owner.UpdatePositions;\r\n    end;\r\n    if not (csLoading in Owner.Header.Treeview.ComponentState) and (Owner.UpdateCount = 0) then\r\n    begin\r\n      if hoAutoResize in Owner.Header.Options then\r\n        Owner.AdjustAutoSize(Index);\r\n      Owner.Header.Treeview.DoColumnResize(Index);\r\n    end;\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TVirtualTreeColumn.ComputeHeaderLayout(DC: HDC; Client: TRect; UseHeaderGlyph, UseSortGlyph: Boolean;\r\n  var HeaderGlyphPos, SortGlyphPos: TPoint; var SortGlyphSize: TSize; var TextBounds: TRect; DrawFormat: Cardinal;\r\n  CalculateTextRect: Boolean = False);\r\n\r\n// The layout of a column header is determined by a lot of factors. This method takes them all into account and\r\n// determines all necessary positions and bounds:\r\n// - for the header text\r\n// - the header glyph\r\n// - the sort glyph\r\n\r\nvar\r\n  TextSize: TSize;\r\n  TextPos,\r\n  ClientSize,\r\n  HeaderGlyphSize: TPoint;\r\n  CurrentAlignment: TAlignment;\r\n  MinLeft,\r\n  MaxRight,\r\n  TextSpacing: Integer;\r\n  UseText: Boolean;\r\n  R: TRect;\r\n  Theme: HTHEME;\r\n\r\nbegin\r\n  UseText := Length(FText) > 0;\r\n  // If nothing is to show then don't waste time with useless preparation.\r\n  if not (UseText or UseHeaderGlyph or UseSortGlyph) then\r\n    Exit;\r\n\r\n  CurrentAlignment := CaptionAlignment;\r\n  if FBiDiMode <> bdLeftToRight then\r\n    ChangeBiDiModeAlignment(CurrentAlignment);\r\n\r\n  // Calculate sizes of the involved items.\r\n  ClientSize := Point(Client.Right - Client.Left, Client.Bottom - Client.Top);\r\n  with Owner, Header do\r\n  begin\r\n    if UseHeaderGlyph then\r\n      if not FCheckBox then\r\n        HeaderGlyphSize := Point(FImages.Width, FImages.Height)\r\n      else\r\n        with Self.Owner.Header.Treeview do\r\n        begin\r\n          if Assigned(FCheckImages) then\r\n            HeaderGlyphSize := Point(FCheckImages.Width, FCheckImages.Height);\r\n        end\r\n    else\r\n      HeaderGlyphSize := Point(0, 0);\r\n    if UseSortGlyph then\r\n    begin\r\n      if tsUseExplorerTheme in FHeader.Treeview.FStates then\r\n      begin\r\n        R := Rect(0, 0, 100, 100);\r\n        Theme := OpenThemeData(FHeader.Treeview.Handle, 'HEADER');\r\n        GetThemePartSize(Theme, DC, HP_HEADERSORTARROW, HSAS_SORTEDUP, @R, TS_TRUE, SortGlyphSize);\r\n        CloseThemeData(Theme);\r\n      end\r\n      else\r\n      begin\r\n        SortGlyphSize.cx := UtilityImages.Width;\r\n        SortGlyphSize.cy := UtilityImages.Height;\r\n      end;\r\n\r\n      // In any case, the sort glyph is vertically centered.\r\n      SortGlyphPos.Y := (ClientSize.Y - SortGlyphSize.cy) div 2;\r\n    end\r\n    else\r\n    begin\r\n      SortGlyphSize.cx := 0;\r\n      SortGlyphSize.cy := 0;\r\n    end;\r\n  end;\r\n\r\n  if UseText then\r\n  begin\r\n    if not (coWrapCaption in FOptions) then\r\n    begin\r\n      FCaptionText := FText;\r\n      GetTextExtentPoint32W(DC, PWideChar(FText), Length(FText), TextSize);\r\n      Inc(TextSize.cx, 2);\r\n      TextBounds := Rect(0, 0, TextSize.cx, TextSize.cy);\r\n    end\r\n    else\r\n    begin\r\n      R := Client;\r\n      if FCaptionText = '' then\r\n        FCaptionText := WrapString(DC, FText, R, DT_RTLREADING and DrawFormat <> 0, DrawFormat);\r\n\r\n      GetStringDrawRect(DC, FCaptionText, R, DrawFormat);\r\n      TextSize.cx := Client.Right - Client.Left;\r\n      TextSize.cy := R.Bottom - R.Top;\r\n      TextBounds := Rect(0, 0, TextSize.cx, TextSize.cy);\r\n    end;\r\n    TextSpacing := FSpacing;\r\n  end\r\n  else\r\n  begin\r\n    TextSpacing := 0;\r\n    TextSize.cx := 0;\r\n    TextSize.cy := 0;\r\n  end;\r\n\r\n  // Check first for the special case where nothing is shown except the sort glyph.\r\n  if UseSortGlyph and not (UseText or UseHeaderGlyph) then\r\n  begin\r\n    // Center the sort glyph in the available area if nothing else is there.\r\n    SortGlyphPos := Point((ClientSize.X - SortGlyphSize.cx) div 2, (ClientSize.Y - SortGlyphSize.cy) div 2);\r\n  end\r\n  else\r\n  begin\r\n    // Determine extents of text and glyph and calculate positions which are clear from the layout.\r\n    if (Layout in [blGlyphLeft, blGlyphRight]) or not UseHeaderGlyph then\r\n    begin\r\n      HeaderGlyphPos.Y := (ClientSize.Y - HeaderGlyphSize.Y) div 2;\r\n      // If the text is taller than the given height, perform no vertical centration as this\r\n      // would make the text even less readable.\r\n      //Using Max() fixes badly positioned text if Extra Large fonts have been activated in the Windows display options\r\n      TextPos.Y := Max(-5, (ClientSize.Y - TextSize.cy) div 2);\r\n    end\r\n    else\r\n    begin\r\n      if Layout = blGlyphTop then\r\n      begin\r\n        HeaderGlyphPos.Y := (ClientSize.Y - HeaderGlyphSize.Y - TextSize.cy - TextSpacing) div 2;\r\n        TextPos.Y := HeaderGlyphPos.Y + HeaderGlyphSize.Y + TextSpacing;\r\n      end\r\n      else\r\n      begin\r\n        TextPos.Y := (ClientSize.Y - HeaderGlyphSize.Y - TextSize.cy - TextSpacing) div 2;\r\n        HeaderGlyphPos.Y := TextPos.Y + TextSize.cy + TextSpacing;\r\n      end;\r\n    end;\r\n\r\n    // Each alignment needs special consideration.\r\n    case CurrentAlignment of\r\n      taLeftJustify:\r\n        begin\r\n          MinLeft := FMargin;\r\n          if UseSortGlyph and (FBiDiMode <> bdLeftToRight) then\r\n          begin\r\n            // In RTL context is the sort glyph placed on the left hand side.\r\n            SortGlyphPos.X := MinLeft;\r\n            Inc(MinLeft, SortGlyphSize.cx + FSpacing);\r\n          end;\r\n          if Layout in [blGlyphTop, blGlyphBottom] then\r\n          begin\r\n            // Header glyph is above or below text, so both must be considered when calculating\r\n            // the left positition of the sort glyph (if it is on the right hand side).\r\n            TextPos.X := MinLeft;\r\n            if UseHeaderGlyph then\r\n            begin\r\n              HeaderGlyphPos.X := (ClientSize.X - HeaderGlyphSize.X) div 2;\r\n              if HeaderGlyphPos.X < MinLeft then\r\n                HeaderGlyphPos.X := MinLeft;\r\n              MinLeft := Max(TextPos.X + TextSize.cx + TextSpacing, HeaderGlyphPos.X + HeaderGlyphSize.X + FSpacing);\r\n            end\r\n            else\r\n              MinLeft := TextPos.X + TextSize.cx + TextSpacing;\r\n          end\r\n          else\r\n          begin\r\n            // Everything is lined up. TextSpacing might be 0 if there is no text.\r\n            // This simplifies the calculation because no extra tests are necessary.\r\n            if UseHeaderGlyph and (Layout = blGlyphLeft) then\r\n            begin\r\n              HeaderGlyphPos.X := MinLeft;\r\n              Inc(MinLeft, HeaderGlyphSize.X + FSpacing);\r\n            end;\r\n            TextPos.X := MinLeft;\r\n            Inc(MinLeft, TextSize.cx + TextSpacing);\r\n            if UseHeaderGlyph and (Layout = blGlyphRight) then\r\n            begin\r\n              HeaderGlyphPos.X := MinLeft;\r\n              Inc(MinLeft, HeaderGlyphSize.X + FSpacing);\r\n            end;\r\n          end;\r\n          if UseSortGlyph and (FBiDiMode = bdLeftToRight) then\r\n            SortGlyphPos.X := MinLeft;\r\n        end;\r\n      taCenter:\r\n        begin\r\n          if Layout in [blGlyphTop, blGlyphBottom] then\r\n          begin\r\n            HeaderGlyphPos.X := (ClientSize.X - HeaderGlyphSize.X) div 2;\r\n            TextPos.X := (ClientSize.X - TextSize.cx) div 2;\r\n            if UseSortGlyph then\r\n              Dec(TextPos.X, SortGlyphSize.cx div 2);\r\n          end\r\n          else\r\n          begin\r\n            MinLeft := (ClientSize.X - HeaderGlyphSize.X - TextSpacing - TextSize.cx) div 2;\r\n            if UseHeaderGlyph and (Layout = blGlyphLeft) then\r\n            begin\r\n              HeaderGlyphPos.X := MinLeft;\r\n              Inc(MinLeft, HeaderGlyphSize.X + TextSpacing);\r\n            end;\r\n            TextPos.X := MinLeft;\r\n            Inc(MinLeft, TextSize.cx + TextSpacing);\r\n            if UseHeaderGlyph and (Layout = blGlyphRight) then\r\n              HeaderGlyphPos.X := MinLeft;\r\n          end;\r\n          if UseHeaderGlyph then\r\n          begin\r\n            MinLeft := Min(HeaderGlyphPos.X, TextPos.X);\r\n            MaxRight := Max(HeaderGlyphPos.X + HeaderGlyphSize.X, TextPos.X + TextSize.cx);\r\n          end\r\n          else\r\n          begin\r\n            MinLeft := TextPos.X;\r\n            MaxRight := TextPos.X + TextSize.cx;\r\n          end;\r\n          // Place the sort glyph directly to the left or right of the larger item.\r\n          if UseSortGlyph then\r\n            if FBiDiMode = bdLeftToRight then\r\n            begin\r\n              // Sort glyph on the right hand side.\r\n              SortGlyphPos.X := MaxRight + FSpacing;\r\n            end\r\n            else\r\n            begin\r\n              // Sort glyph on the left hand side.\r\n              SortGlyphPos.X := MinLeft - FSpacing - SortGlyphSize.cx;\r\n            end;\r\n        end;\r\n    else\r\n      // taRightJustify\r\n      MaxRight := ClientSize.X - FMargin;\r\n      if UseSortGlyph and (FBiDiMode = bdLeftToRight) then\r\n      begin\r\n        // In LTR context is the sort glyph placed on the right hand side.\r\n        Dec(MaxRight, SortGlyphSize.cx);\r\n        SortGlyphPos.X := MaxRight;\r\n        Dec(MaxRight, FSpacing);\r\n      end;\r\n      if Layout in [blGlyphTop, blGlyphBottom] then\r\n      begin\r\n        TextPos.X := MaxRight - TextSize.cx;\r\n        if UseHeaderGlyph then\r\n        begin\r\n          HeaderGlyphPos.X := (ClientSize.X - HeaderGlyphSize.X) div 2;\r\n          if HeaderGlyphPos.X + HeaderGlyphSize.X + FSpacing > MaxRight then\r\n            HeaderGlyphPos.X := MaxRight - HeaderGlyphSize.X - FSpacing;\r\n          MaxRight := Min(TextPos.X - TextSpacing, HeaderGlyphPos.X - FSpacing);\r\n        end\r\n        else\r\n          MaxRight := TextPos.X - TextSpacing;\r\n      end\r\n      else\r\n      begin\r\n        // Everything is lined up. TextSpacing might be 0 if there is no text.\r\n        // This simplifies the calculation because no extra tests are necessary.\r\n        if UseHeaderGlyph and (Layout = blGlyphRight) then\r\n        begin\r\n          HeaderGlyphPos.X := MaxRight -  HeaderGlyphSize.X;\r\n          MaxRight := HeaderGlyphPos.X - FSpacing;\r\n        end;\r\n        TextPos.X := MaxRight - TextSize.cx;\r\n        MaxRight := TextPos.X - TextSpacing;\r\n        if UseHeaderGlyph and (Layout = blGlyphLeft) then\r\n        begin\r\n          HeaderGlyphPos.X := MaxRight - HeaderGlyphSize.X;\r\n          MaxRight := HeaderGlyphPos.X - FSpacing;\r\n        end;\r\n      end;\r\n      if UseSortGlyph and (FBiDiMode <> bdLeftToRight) then\r\n        SortGlyphPos.X := MaxRight - SortGlyphSize.cx;\r\n    end;\r\n  end;\r\n\r\n  // Once the position of each element is determined there remains only one but important step.\r\n  // The horizontal positions of every element must be adjusted so that it always fits into the\r\n  // given header area. This is accomplished by shorten the text appropriately.\r\n\r\n  // These are the maximum bounds. Nothing goes beyond them.\r\n  MinLeft := FMargin;\r\n  MaxRight := ClientSize.X - FMargin;\r\n  if UseSortGlyph then\r\n  begin\r\n    if FBiDiMode = bdLeftToRight then\r\n    begin\r\n      // Sort glyph on the right hand side.\r\n      if SortGlyphPos.X + SortGlyphSize.cx > MaxRight then\r\n        SortGlyphPos.X := MaxRight - SortGlyphSize.cx;\r\n      MaxRight := SortGlyphPos.X - FSpacing;\r\n    end;\r\n\r\n    // Consider also the left side of the sort glyph regardless of the bidi mode.\r\n    if SortGlyphPos.X < MinLeft then\r\n      SortGlyphPos.X := MinLeft;\r\n    // Left border needs only adjustment if the sort glyph marks the left border.\r\n    if FBiDiMode <> bdLeftToRight then\r\n      MinLeft := SortGlyphPos.X + SortGlyphSize.cx + FSpacing;\r\n\r\n    // Finally transform sort glyph to its actual position.\r\n    Inc(SortGlyphPos.X, Client.Left);\r\n    Inc(SortGlyphPos.Y, Client.Top);\r\n  end;\r\n  if UseHeaderGlyph then\r\n  begin\r\n    if HeaderGlyphPos.X + HeaderGlyphSize.X > MaxRight then\r\n      HeaderGlyphPos.X := MaxRight - HeaderGlyphSize.X;\r\n    if Layout = blGlyphRight then\r\n      MaxRight := HeaderGlyphPos.X - FSpacing;\r\n    if HeaderGlyphPos.X < MinLeft then\r\n      HeaderGlyphPos.X := MinLeft;\r\n    if Layout = blGlyphLeft then\r\n      MinLeft := HeaderGlyphPos.X + HeaderGlyphSize.X + FSpacing;\r\n    if FCheckBox and (Owner.Header.MainColumn = Self.Index) then\r\n      Dec(HeaderGlyphPos.X, 2)\r\n    else\r\n      if Owner.Header.MainColumn <> Self.Index then\r\n        Dec(HeaderGlyphPos.X, 2);\r\n\r\n    // Finally transform header glyph to its actual position.\r\n    Inc(HeaderGlyphPos.X, Client.Left);\r\n    Inc(HeaderGlyphPos.Y, Client.Top);\r\n  end;\r\n  if UseText then\r\n  begin\r\n    if TextPos.X < MinLeft then\r\n      TextPos.X := MinLeft;\r\n    OffsetRect(TextBounds, TextPos.X, TextPos.Y);\r\n    if TextBounds.Right > MaxRight then\r\n      TextBounds.Right := MaxRight;\r\n    OffsetRect(TextBounds, Client.Left, Client.Top);\r\n\r\n    if coWrapCaption in FOptions then\r\n    begin\r\n      // Wrap the column caption if necessary.\r\n      R := TextBounds;\r\n      FCaptionText := WrapString(DC, FText, R, DT_RTLREADING and DrawFormat <> 0, DrawFormat);\r\n      GetStringDrawRect(DC, FCaptionText, R, DrawFormat);\r\n    end;\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TVirtualTreeColumn.DefineProperties(Filer: TFiler);\r\n\r\nbegin\r\n  inherited;\r\n\r\n  // Must define a new name for the properties otherwise the VCL will try to load the wide string\r\n  // without asking us and screws it completely up.\r\n  Filer.DefineProperty('WideText', ReadText, WriteText, FText <> '');\r\n  Filer.DefineProperty('WideHint', ReadHint, WriteHint, FHint <> '');\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TVirtualTreeColumn.GetAbsoluteBounds(var Left, Right: Integer);\r\n\r\n// Returns the column's left and right bounds in header coordinates, that is, independant of the scrolling position.\r\n\r\nbegin\r\n  Left := FLeft;\r\n  Right := FLeft + FWidth;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TVirtualTreeColumn.GetDisplayName: string;\r\n\r\n// Returns the column text if it only contains ANSI characters, otherwise the column id is returned because the IDE\r\n// still cannot handle Unicode strings.\r\n\r\nvar\r\n  I: Integer;\r\n\r\nbegin\r\n  // Check if the text of the column contains characters > 255\r\n  I := 1;\r\n  while I <= Length(FText) do\r\n  begin\r\n    if Ord(FText[I]) > 255 then\r\n      Break;\r\n    Inc(I);\r\n  end;\r\n\r\n  if I > Length(FText) then\r\n    Result := FText // implicit conversion\r\n  else\r\n    Result := Format('Column %d', [Index]);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TVirtualTreeColumn.GetOwner: TVirtualTreeColumns;\r\n\r\nbegin\r\n  Result := Collection as TVirtualTreeColumns;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TVirtualTreeColumn.ReadText(Reader: TReader);\r\n\r\nbegin\r\n  case Reader.NextValue of\r\n    vaLString, vaString:\r\n      SetText(Reader.ReadString);\r\n  else\r\n    SetText(Reader.ReadString);\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TVirtualTreeColumn.ReadHint(Reader: TReader);\r\n\r\nbegin\r\n  case Reader.NextValue of\r\n    vaLString, vaString:\r\n      FHint := Reader.ReadString;\r\n  else\r\n    FHint := Reader.ReadString;\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TVirtualTreeColumn.WriteHint(Writer: TWriter);\r\n\r\nbegin\r\n  Writer.WriteString(FHint);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TVirtualTreeColumn.WriteText(Writer: TWriter);\r\n\r\nbegin\r\n  Writer.WriteString(FText);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TVirtualTreeColumn.Assign(Source: TPersistent);\r\n\r\nvar\r\n  OldOptions: TVTColumnOptions;\r\n\r\nbegin\r\n  if Source is TVirtualTreeColumn then\r\n  begin\r\n    OldOptions := FOptions;\r\n    FOptions := [];\r\n\r\n    BiDiMode := TVirtualTreeColumn(Source).BiDiMode;\r\n    ImageIndex := TVirtualTreeColumn(Source).ImageIndex;\r\n    Layout := TVirtualTreeColumn(Source).Layout;\r\n    Margin := TVirtualTreeColumn(Source).Margin;\r\n    MaxWidth := TVirtualTreeColumn(Source).MaxWidth;\r\n    MinWidth := TVirtualTreeColumn(Source).MinWidth;\r\n    Position := TVirtualTreeColumn(Source).Position;\r\n    Spacing := TVirtualTreeColumn(Source).Spacing;\r\n    Style := TVirtualTreeColumn(Source).Style;\r\n    Text := TVirtualTreeColumn(Source).Text;\r\n    Hint := TVirtualTreeColumn(Source).Hint;\r\n    Width := TVirtualTreeColumn(Source).Width;\r\n    Alignment := TVirtualTreeColumn(Source).Alignment;\r\n    CaptionAlignment := TVirtualTreeColumn(Source).CaptionAlignment;\r\n    Color := TVirtualTreeColumn(Source).Color;\r\n    Tag := TVirtualTreeColumn(Source).Tag;\r\n\r\n    // Order is important. Assign options last.\r\n    FOptions := OldOptions;\r\n    Options := TVirtualTreeColumn(Source).Options;\r\n\r\n    Changed(False);\r\n  end\r\n  else\r\n    inherited Assign(Source);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TVirtualTreeColumn.Equals(OtherColumnObj: TObject): Boolean;\r\nvar\r\n OtherColumn : TVirtualTreeColumn;\r\nbegin\r\n  if OtherColumnObj is TVirtualTreeColumn then\r\n  begin\r\n    OtherColumn := TVirtualTreeColumn (OtherColumnObj);\r\n    Result := (BiDiMode = OtherColumn.BiDiMode) and\r\n      (ImageIndex = OtherColumn.ImageIndex) and\r\n      (Layout = OtherColumn.Layout) and\r\n      (Margin = OtherColumn.Margin) and\r\n      (MaxWidth = OtherColumn.MaxWidth) and\r\n      (MinWidth = OtherColumn.MinWidth) and\r\n      (Position = OtherColumn.Position) and\r\n      (Spacing = OtherColumn.Spacing) and\r\n      (Style = OtherColumn.Style) and\r\n      (Text = OtherColumn.Text) and\r\n      (Hint = OtherColumn.Hint) and\r\n      (Width = OtherColumn.Width) and\r\n      (Alignment = OtherColumn.Alignment) and\r\n      (CaptionAlignment = OtherColumn.CaptionAlignment) and\r\n      (Color = OtherColumn.Color) and\r\n      (Tag = OtherColumn.Tag) and\r\n      (Options = OtherColumn.Options);\r\n  end\r\n  else\r\n    Result := False;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TVirtualTreeColumn.GetRect: TRect;\r\n\r\n// Returns the rectangle this column occupies in the header (relative to (0, 0) of the non-client area).\r\n\r\nbegin\r\n  with TVirtualTreeColumns(GetOwner).FHeader do\r\n    Result := Treeview.FHeaderRect;\r\n  Inc(Result.Left, FLeft);\r\n  Result.Right := Result.Left + FWidth;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\n// [IPK]\r\nfunction TVirtualTreeColumn.GetText: string;\r\n\r\nbegin\r\n  Result := FText;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TVirtualTreeColumn.LoadFromStream(const Stream: TStream; Version: Integer);\r\n\r\n  //--------------- local function --------------------------------------------\r\n\r\n  function ConvertOptions(Value: Cardinal): TVTColumnOptions;\r\n\r\n  // Converts the given raw value which represents column options for possibly older\r\n  // formats to the current format.\r\n\r\n  begin\r\n    if Version >= 3 then\r\n      Result := TVTColumnOptions(Word(Value and $FFFF))\r\n    else\r\n      if Version = 2 then\r\n        Result := TVTColumnOptions(Word(Value and $FF))\r\n      else\r\n      begin\r\n        // In version 2 coParentColor has been added. This needs an option shift for older stream formats.\r\n        // The first (lower) 4 options remain as they are.\r\n        Result := TVTColumnOptions(Word(Value) and $F);\r\n        Value := (Value and not $F) shl 1;\r\n        Result := Result + TVTColumnOptions(Word(Value and $FF));\r\n      end;\r\n  end;\r\n\r\n  //--------------- end local function ----------------------------------------\r\n\r\nvar\r\n  Dummy: Integer;\r\n  S: string;\r\n\r\nbegin\r\n  with Stream do\r\n  begin\r\n    ReadBuffer(Dummy, SizeOf(Dummy));\r\n    SetLength(S, Dummy);\r\n    ReadBuffer(PWideChar(S)^, 2 * Dummy);\r\n    Text := S;\r\n    ReadBuffer(Dummy, SizeOf(Dummy));\r\n    SetLength(FHint, Dummy);\r\n    ReadBuffer(PWideChar(FHint)^, 2 * Dummy);\r\n    ReadBuffer(Dummy, SizeOf(Dummy));\r\n    Width := Dummy;\r\n    ReadBuffer(Dummy, SizeOf(Dummy));\r\n    MinWidth := Dummy;\r\n    ReadBuffer(Dummy, SizeOf(Dummy));\r\n    MaxWidth := Dummy;\r\n    ReadBuffer(Dummy, SizeOf(Dummy));\r\n    Style := TVirtualTreeColumnStyle(Dummy);\r\n    ReadBuffer(Dummy, SizeOf(Dummy));\r\n    ImageIndex := Dummy;\r\n    ReadBuffer(Dummy, SizeOf(Dummy));\r\n    Layout := TVTHeaderColumnLayout(Dummy);\r\n    ReadBuffer(Dummy, SizeOf(Dummy));\r\n    Margin := Dummy;\r\n    ReadBuffer(Dummy, SizeOf(Dummy));\r\n    Spacing := Dummy;\r\n    ReadBuffer(Dummy, SizeOf(Dummy));\r\n    BiDiMode := TBiDiMode(Dummy);\r\n\r\n    ReadBuffer(Dummy, SizeOf(Dummy));\r\n    Options := ConvertOptions(Dummy);\r\n\r\n    if Version > 0 then\r\n    begin\r\n      // Parts which have been introduced/changed with header stream version 1+.\r\n      ReadBuffer(Dummy, SizeOf(Dummy));\r\n      Tag := Dummy;\r\n      ReadBuffer(Dummy, SizeOf(Dummy));\r\n      Alignment := TAlignment(Dummy);\r\n\r\n      if Version > 1 then\r\n      begin\r\n        ReadBuffer(Dummy, SizeOf(Dummy));\r\n        Color := TColor(Dummy);\r\n      end;\r\n\r\n      if Version > 5 then\r\n      begin\r\n        if coUseCaptionAlignment in FOptions then\r\n        begin\r\n          ReadBuffer(Dummy, SizeOf(Dummy));\r\n          CaptionAlignment := TAlignment(Dummy);\r\n        end;\r\n      end;\r\n    end;\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TVirtualTreeColumn.ParentBiDiModeChanged;\r\n\r\nvar\r\n  Columns: TVirtualTreeColumns;\r\n\r\nbegin\r\n  if coParentBiDiMode in FOptions then\r\n  begin\r\n    Columns := GetOwner as TVirtualTreeColumns;\r\n    if Assigned(Columns) and (FBiDiMode <> Columns.FHeader.Treeview.BiDiMode) then\r\n    begin\r\n      FBiDiMode := Columns.FHeader.Treeview.BiDiMode;\r\n      Changed(False);\r\n    end;\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TVirtualTreeColumn.ParentColorChanged;\r\n\r\nvar\r\n  Columns: TVirtualTreeColumns;\r\n\r\nbegin\r\n  if coParentColor in FOptions then\r\n  begin\r\n    Columns := GetOwner as TVirtualTreeColumns;\r\n    if Assigned(Columns) and (FColor <> Columns.FHeader.Treeview.Color) then\r\n    begin\r\n      FColor := Columns.FHeader.Treeview.Color;\r\n      Changed(False);\r\n    end;\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TVirtualTreeColumn.RestoreLastWidth;\r\n\r\nbegin\r\n  TVirtualTreeColumns(GetOwner).AnimatedResize(Index, FLastWidth);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TVirtualTreeColumn.SaveToStream(const Stream: TStream);\r\n\r\nvar\r\n  Dummy: Integer;\r\n\r\nbegin\r\n  with Stream do\r\n  begin\r\n    Dummy := Length(FText);\r\n    WriteBuffer(Dummy, SizeOf(Dummy));\r\n    WriteBuffer(PWideChar(FText)^, 2 * Dummy);\r\n    Dummy := Length(FHint);\r\n    WriteBuffer(Dummy, SizeOf(Dummy));\r\n    WriteBuffer(PWideChar(FHint)^, 2 * Dummy);\r\n    WriteBuffer(FWidth, SizeOf(FWidth));\r\n    WriteBuffer(FMinWidth, SizeOf(FMinWidth));\r\n    WriteBuffer(FMaxWidth, SizeOf(FMaxWidth));\r\n    Dummy := Ord(FStyle);\r\n    WriteBuffer(Dummy, SizeOf(Dummy));\r\n    Dummy := FImageIndex;\r\n    WriteBuffer(Dummy, SizeOf(Dummy));\r\n    Dummy := Ord(FLayout);\r\n    WriteBuffer(Dummy, SizeOf(Dummy));\r\n    WriteBuffer(FMargin, SizeOf(FMargin));\r\n    WriteBuffer(FSpacing, SizeOf(FSpacing));\r\n    Dummy := Ord(FBiDiMode);\r\n    WriteBuffer(Dummy, SizeOf(Dummy));\r\n    Dummy := Word(FOptions);\r\n    WriteBuffer(Dummy, SizeOf(Dummy));\r\n\r\n    // parts introduced with stream version 1\r\n    WriteBuffer(FTag, SizeOf(Dummy));\r\n    Dummy := Cardinal(FAlignment);\r\n    WriteBuffer(Dummy, SizeOf(Dummy));\r\n\r\n    // parts introduced with stream version 2\r\n    Dummy := Integer(FColor);\r\n    WriteBuffer(Dummy, SizeOf(Dummy));\r\n\r\n    // parts introduced with stream version 6\r\n    if coUseCaptionAlignment in FOptions then\r\n    begin\r\n      Dummy := Cardinal(FCaptionAlignment);\r\n      WriteBuffer(Dummy, SizeOf(Dummy));\r\n    end;\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TVirtualTreeColumn.UseRightToLeftReading: Boolean;\r\n\r\nbegin\r\n  Result := FBiDiMode <> bdLeftToRight;\r\nend;\r\n\r\n//----------------- TVirtualTreeColumns --------------------------------------------------------------------------------\r\n\r\nconstructor TVirtualTreeColumns.Create(AOwner: TVTHeader);\r\n\r\nvar\r\n  ColumnClass: TVirtualTreeColumnClass;\r\n\r\nbegin\r\n  FHeader := AOwner;\r\n\r\n  // Determine column class to be used in the header.\r\n  ColumnClass := AOwner.FOwner.GetColumnClass;\r\n  // The owner tree always returns the default tree column class if not changed by application/descendants.\r\n  inherited Create(ColumnClass);\r\n\r\n  FHeaderBitmap := TBitmap.Create;\r\n  FHeaderBitmap.PixelFormat := pf32Bit;\r\n\r\n  FHoverIndex := NoColumn;\r\n  FDownIndex := NoColumn;\r\n  FClickIndex := NoColumn;\r\n  FDropTarget := NoColumn;\r\n  FTrackIndex := NoColumn;\r\n  FDefaultWidth := 50;\r\n  Self.FColumnPopupMenu := nil;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\ndestructor TVirtualTreeColumns.Destroy;\r\n\r\nbegin\r\n  FreeAndNil(FColumnPopupMenu);\r\n  FreeAndNil(FHeaderBitmap);\r\n  inherited;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TVirtualTreeColumns.GetCount: Integer;\r\n\r\nbegin\r\n  Result := inherited Count;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TVirtualTreeColumns.GetItem(Index: TColumnIndex): TVirtualTreeColumn;\r\n\r\nbegin\r\n  Result := TVirtualTreeColumn(inherited GetItem(Index));\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TVirtualTreeColumns.GetNewIndex(P: TPoint; var OldIndex: TColumnIndex): Boolean;\r\n\r\nvar\r\n  NewIndex: Integer;\r\n\r\nbegin\r\n  Result := False;\r\n  // convert to local coordinates\r\n  Inc(P.Y, FHeader.FHeight);\r\n  NewIndex := ColumnFromPosition(P);\r\n  if NewIndex <> OldIndex then\r\n  begin\r\n    if OldIndex > NoColumn then\r\n      FHeader.Invalidate(Items[OldIndex]);\r\n    OldIndex := NewIndex;\r\n    if OldIndex > NoColumn then\r\n      FHeader.Invalidate(Items[OldIndex]);\r\n    Result := True;\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TVirtualTreeColumns.SetDefaultWidth(Value: Integer);\r\n\r\nbegin\r\n  FDefaultWidth := Value;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TVirtualTreeColumns.SetItem(Index: TColumnIndex; Value: TVirtualTreeColumn);\r\n\r\nbegin\r\n  inherited SetItem(Index, Value);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TVirtualTreeColumns.AdjustAutoSize(CurrentIndex: TColumnIndex; Force: Boolean = False);\r\n\r\n// Called only if the header is in auto-size mode which means a column needs to be so large\r\n// that it fills all the horizontal space not occupied by the other columns.\r\n// CurrentIndex (if not InvalidColumn) describes which column has just been resized.\r\n\r\nvar\r\n  NewValue,\r\n  AutoIndex,\r\n  Index,\r\n  RestWidth: Integer;\r\n  WasUpdating: Boolean;\r\nbegin\r\n  if Count > 0 then\r\n  begin\r\n    // Determine index to be used for auto resizing. This is usually given by the owner's AutoSizeIndex, but\r\n    // could be different if the column whose resize caused the invokation here is either the auto column itself\r\n    // or visually to the right of the auto size column.\r\n    AutoIndex := FHeader.FAutoSizeIndex;\r\n    if (AutoIndex < 0) or (AutoIndex >= Count) then\r\n      AutoIndex := Count - 1;\r\n\r\n    if AutoIndex >= 0 then\r\n    begin\r\n      with FHeader.Treeview do\r\n      begin\r\n        if HandleAllocated then\r\n          RestWidth := ClientWidth\r\n        else\r\n          RestWidth := Width;\r\n      end;\r\n\r\n      // Go through all columns and calculate the rest space remaining.\r\n      for Index := 0 to Count - 1 do\r\n        if (Index <> AutoIndex) and (coVisible in Items[Index].FOptions) then\r\n          Dec(RestWidth, Items[Index].Width);\r\n\r\n      with Items[AutoIndex] do\r\n      begin\r\n        NewValue := Max(MinWidth, Min(MaxWidth, RestWidth));\r\n        if Force or (FWidth <> NewValue) then\r\n        begin\r\n          FWidth := NewValue;\r\n          UpdatePositions;\r\n          WasUpdating := csUpdating in FHeader.Treeview.ComponentState;\r\n          if not WasUpdating then\r\n            FHeader.Treeview.Updating();// Fixes #398\r\n          try\r\n            FHeader.Treeview.DoColumnResize(AutoIndex);\r\n          finally\r\n            if not WasUpdating then\r\n              FHeader.Treeview.Updated();\r\n          end;\r\n        end;\r\n      end;\r\n    end;\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TVirtualTreeColumns.AdjustDownColumn(P: TPoint): TColumnIndex;\r\n\r\n// Determines the column from the given position and returns it. If this column is allowed to be clicked then\r\n// it is also kept for later use.\r\n\r\nbegin\r\n  // Convert to local coordinates.\r\n  Inc(P.Y, FHeader.FHeight);\r\n  Result := ColumnFromPosition(P);\r\n  if (Result > NoColumn) and (Result <> FDownIndex) and (coAllowClick in Items[Result].FOptions) and\r\n    (coEnabled in Items[Result].FOptions) then\r\n  begin\r\n    if FDownIndex > NoColumn then\r\n      FHeader.Invalidate(Items[FDownIndex]);\r\n    FDownIndex := Result;\r\n    FCheckBoxHit := Items[Result].FHasImage and PtInRect(Items[Result].FImageRect, P) and Items[Result].CheckBox;\r\n    FHeader.Invalidate(Items[FDownIndex]);\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TVirtualTreeColumns.AdjustHoverColumn(P: TPoint): Boolean;\r\n\r\n// Determines the new hover column index and returns True if the index actually changed else False.\r\n\r\nbegin\r\n  Result := GetNewIndex(P, FHoverIndex);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TVirtualTreeColumns.AdjustPosition(Column: TVirtualTreeColumn; Position: Cardinal);\r\n\r\n// Reorders the column position array so that the given column gets the given position.\r\n\r\nvar\r\n  OldPosition: Cardinal;\r\n\r\nbegin\r\n  OldPosition := Column.Position;\r\n  if OldPosition <> Position then\r\n  begin\r\n    if OldPosition < Position then\r\n    begin\r\n      // column will be moved up so move down other entries\r\n      Move(FPositionToIndex[OldPosition + 1], FPositionToIndex[OldPosition], (Position - OldPosition) * SizeOf(Cardinal));\r\n    end\r\n    else\r\n    begin\r\n      // column will be moved down so move up other entries\r\n      Move(FPositionToIndex[Position], FPositionToIndex[Position + 1], (OldPosition - Position) * SizeOf(Cardinal));\r\n    end;\r\n    FPositionToIndex[Position] := Column.Index;\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TVirtualTreeColumns.CanSplitterResize(P: TPoint; Column: TColumnIndex): Boolean;\r\n\r\nbegin\r\n  Result := (Column > NoColumn) and ([coResizable, coVisible] * Items[Column].FOptions = [coResizable, coVisible]);\r\n  DoCanSplitterResize(P, Column, Result);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TVirtualTreeColumns.DoCanSplitterResize(P: TPoint; Column: TColumnIndex; var Allowed: Boolean);\r\n\r\nbegin\r\n  if Assigned(FHeader.Treeview.FOnCanSplitterResizeColumn) then\r\n    FHeader.Treeview.FOnCanSplitterResizeColumn(FHeader, P, Column, Allowed);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TVirtualTreeColumns.DrawButtonText(DC: HDC; Caption: string; Bounds: TRect; Enabled, Hot: Boolean;\r\n    DrawFormat: Cardinal; WrapCaption: Boolean);\r\n\r\nvar\r\n  TextSpace: Integer;\r\n  Size: TSize;\r\n\r\nbegin\r\n  if not WrapCaption then\r\n  begin\r\n    // Do we need to shorten the caption due to limited space?\r\n    GetTextExtentPoint32W(DC, PWideChar(Caption), Length(Caption), Size);\r\n    TextSpace := Bounds.Right - Bounds.Left;\r\n    if TextSpace < Size.cx then\r\n      Caption := ShortenString(DC, Caption, TextSpace);\r\n  end;\r\n\r\n  SetBkMode(DC, TRANSPARENT);\r\n  if not Enabled then\r\n    if FHeader.Treeview.VclStyleEnabled then\r\n    begin\r\n      SetTextColor(DC, ColorToRGB(FHeader.Treeview.FColors.HeaderFontColor));\r\n      Winapi.Windows.DrawTextW(DC, PWideChar(Caption), Length(Caption), Bounds, DrawFormat);\r\n    end\r\n    else\r\n  begin\r\n    OffsetRect(Bounds, 1, 1);\r\n    SetTextColor(DC, ColorToRGB(clBtnHighlight));\r\n    Winapi.Windows.DrawTextW(DC, PWideChar(Caption), Length(Caption), Bounds, DrawFormat);\r\n    OffsetRect(Bounds, -1, -1);\r\n    SetTextColor(DC, ColorToRGB(clBtnShadow));\r\n    Winapi.Windows.DrawTextW(DC, PWideChar(Caption), Length(Caption), Bounds, DrawFormat);\r\n  end\r\n  else\r\n  begin\r\n    if Hot then\r\n      SetTextColor(DC, ColorToRGB(FHeader.Treeview.FColors.HeaderHotColor))\r\n    else\r\n      SetTextColor(DC, ColorToRGB(FHeader.Treeview.FColors.HeaderFontColor));\r\n    Winapi.Windows.DrawTextW(DC, PWideChar(Caption), Length(Caption), Bounds, DrawFormat);\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TVirtualTreeColumns.FixPositions;\r\n\r\n// Fixes column positions after loading from DFM or Bidi mode change.\r\n\r\nvar\r\n  I: Integer;\r\n\r\nbegin\r\n  for I := 0 to Count - 1 do\r\n    FPositionToIndex[Items[I].Position] := I;\r\n\r\n  FNeedPositionsFix := False;\r\n  UpdatePositions(True);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TVirtualTreeColumns.GetColumnAndBounds(P: TPoint; var ColumnLeft, ColumnRight: Integer;\r\n  Relative: Boolean = True): Integer;\r\n\r\n// Returns the column where the mouse is currently in as well as the left and right bound of\r\n// this column (Left and Right are undetermined if no column is involved).\r\n\r\nvar\r\n  I: Integer;\r\n\r\nbegin\r\n  Result := InvalidColumn;\r\n  if Relative and (P.X >= Header.Columns.GetVisibleFixedWidth) then\r\n    ColumnLeft := -FHeader.Treeview.FEffectiveOffsetX\r\n  else\r\n    ColumnLeft := 0;\r\n\r\n  if FHeader.Treeview.UseRightToLeftAlignment then\r\n    Inc(ColumnLeft, FHeader.Treeview.ComputeRTLOffset(True));\r\n\r\n  for I := 0 to Count - 1 do\r\n    with Items[FPositionToIndex[I]] do\r\n      if coVisible in FOptions then\r\n      begin\r\n        ColumnRight := ColumnLeft + FWidth;\r\n        if P.X < ColumnRight then\r\n        begin\r\n          Result := FPositionToIndex[I];\r\n          Exit;\r\n        end;\r\n        ColumnLeft := ColumnRight;\r\n      end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TVirtualTreeColumns.GetOwner: TPersistent;\r\n\r\nbegin\r\n  Result := FHeader;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TVirtualTreeColumns.HandleClick(P: TPoint; Button: TMouseButton; Force, DblClick: Boolean);\r\n\r\n// Generates a click event if the mouse button has been released over the same column it was pressed first.\r\n// Alternatively, Force might be set to True to indicate that the down index does not matter (right, middle and\r\n// double click).\r\n\r\nvar\r\n  HitInfo: TVTHeaderHitInfo;\r\n  NewClickIndex: Integer;\r\nbegin\r\n  if (csDesigning in Header.Treeview.ComponentState) then\r\n    exit;\r\n  // Convert vertical position to local coordinates.\r\n  Inc(P.Y, FHeader.FHeight);\r\n  NewClickIndex := ColumnFromPosition(P);\r\n  with HitInfo do\r\n  begin\r\n    X := P.X;\r\n    Y := P.Y;\r\n    Shift := FHeader.GetShiftState;\r\n    if DblClick then\r\n      Shift := Shift + [ssDouble];\r\n  end;\r\n  HitInfo.Button := Button;\r\n\r\n  if (NewClickIndex > NoColumn) and (coAllowClick in Items[NewClickIndex].FOptions) and\r\n    ((NewClickIndex = FDownIndex) or Force) then\r\n  begin\r\n    FClickIndex := NewClickIndex;\r\n    HitInfo.Column := NewClickIndex;\r\n    HitInfo.HitPosition := [hhiOnColumn];\r\n\r\n    if Items[NewClickIndex].FHasImage and PtInRect(Items[NewClickIndex].FImageRect, P) then\r\n    begin\r\n      Include(HitInfo.HitPosition, hhiOnIcon);\r\n      if Items[NewClickIndex].CheckBox then\r\n      begin\r\n        if Button = mbLeft then\r\n          FHeader.Treeview.UpdateColumnCheckState(Items[NewClickIndex]);\r\n        Include(HitInfo.HitPosition, hhiOnCheckbox);\r\n      end;\r\n    end;\r\n  end\r\n  else\r\n  begin\r\n    FClickIndex := NoColumn;\r\n    HitInfo.Column := NoColumn;\r\n    HitInfo.HitPosition := [hhiNoWhere];\r\n  end;\r\n\r\n  if DblClick then\r\n    FHeader.Treeview.DoHeaderDblClick(HitInfo)\r\n  else begin\r\n    if (hoHeaderClickAutoSort in Header.Options) and (HitInfo.Button = mbLeft) and not (hhiOnCheckbox in HitInfo.HitPosition) and (HitInfo.Column >= 0) then\r\n    begin\r\n      // handle automatic setting of SortColumn and toggling of the sort order\r\n      if HitInfo.Column <> Header.SortColumn then\r\n      begin\r\n        // set sort column\r\n        Header.SortColumn := HitInfo.Column;\r\n        Header.SortDirection := Self[Header.SortColumn].DefaultSortDirection;\r\n      end//if\r\n      else\r\n      begin\r\n        // toggle sort direction\r\n        if Header.SortDirection = sdDescending then\r\n          Header.SortDirection := sdAscending\r\n        else\r\n          Header.SortDirection := sdDescending;\r\n      end;//else\r\n    end;//if\r\n\r\n    if (Button = mbRight) and (hoAutoColumnPopupMenu in Header.Options) then begin\r\n      FreeAndNil(fColumnPopupMenu);// Attention: Do not free the TVTHeaderPopupMenu at the end of this method, otherwise the clikc events of the menu item will not be fired.\r\n      fColumnPopupMenu := TVTHeaderPopupMenu.Create(Header.TreeView);\r\n      TVTHeaderPopupMenu(fColumnPopupMenu).OnColumnChange := HeaderPopupMenuColumnChange;\r\n      fColumnPopupMenu.PopupComponent := Header.Treeview;\r\n      if (hoDblClickResize in Header.Options) and (Header.Treeview.ChildCount[nil] > 0) then\r\n        TVTHeaderPopupMenu(fColumnPopupMenu).Options := TVTHeaderPopupMenu(fColumnPopupMenu).Options + [poResizeToFitItem]\r\n      else\r\n        TVTHeaderPopupMenu(fColumnPopupMenu).Options := TVTHeaderPopupMenu(fColumnPopupMenu).Options - [poResizeToFitItem];\r\n      With Header.Treeview.ClientToScreen(P) do\r\n        fColumnPopupMenu.Popup(X, Y);\r\n    end;//if hoShowColumnPopupMenu\r\n    FHeader.Treeview.DoHeaderClick(HitInfo);\r\n  end;//else (not DblClick)\r\n\r\n  if not (hhiNoWhere in HitInfo.HitPosition) then\r\n    FHeader.Invalidate(Items[NewClickIndex]);\r\n  if (FClickIndex > NoColumn) and (FClickIndex <> NewClickIndex) then\r\n    FHeader.Invalidate(Items[FClickIndex]);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\n\r\nprocedure TVirtualTreeColumns.HeaderPopupMenuColumnChange(const Sender: TBaseVirtualTree; const Column: TColumnIndex; Visible: Boolean);\r\nbegin\r\n  Sender.DoColumnVisibilityChanged(Column, Visible);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TVirtualTreeColumns.IndexChanged(OldIndex, NewIndex: Integer);\r\n\r\n// Called by a column when its index in the collection changes. If NewIndex is -1 then the column is\r\n// about to be removed, otherwise it is moved to a new index.\r\n// The method will then update the position array to reflect the change.\r\n\r\nvar\r\n  I: Integer;\r\n  Increment: Integer;\r\n  Lower,\r\n  Upper: Integer;\r\n\r\nbegin\r\n  if NewIndex = -1 then\r\n  begin\r\n    // Find position in the array with the old index.\r\n    Upper := High(FPositionToIndex);\r\n    for I := 0 to Upper do\r\n    begin\r\n      if FPositionToIndex[I] = OldIndex then\r\n      begin\r\n        // Index found. Move all higher entries one step down and remove the last entry.\r\n        if I < Upper then\r\n          Move(FPositionToIndex[I + 1], FPositionToIndex[I], (Upper - I) * SizeOf(TColumnIndex));\r\n      end;\r\n      // Decrease all indices, which are greater than the index to be deleted.\r\n      if FPositionToIndex[I] > OldIndex then\r\n        Dec(FPositionToIndex[I]);\r\n    end;\r\n    SetLength(FPositionToIndex, High(FPositionToIndex));\r\n  end\r\n  else\r\n  begin\r\n    if OldIndex < NewIndex then\r\n      Increment := -1\r\n    else\r\n      Increment := 1;\r\n\r\n    Lower := Min(OldIndex, NewIndex);\r\n    Upper := Max(OldIndex, NewIndex);\r\n    for I := 0 to High(FPositionToIndex) do\r\n    begin\r\n      if (FPositionToIndex[I] >= Lower) and (FPositionToIndex[I] < Upper) then\r\n        Inc(FPositionToIndex[I], Increment)\r\n      else\r\n        if FPositionToIndex[I] = OldIndex then\r\n          FPositionToIndex[I] := NewIndex;\r\n    end;\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TVirtualTreeColumns.InitializePositionArray;\r\n\r\n// Ensures that the column position array contains as many entries as columns are defined.\r\n// The array is resized and initialized with default values if needed.\r\n\r\nvar\r\n  I, OldSize: Integer;\r\n  Changed: Boolean;\r\n\r\nbegin\r\n  if Count <> Length(FPositionToIndex) then\r\n  begin\r\n    OldSize := Length(FPositionToIndex);\r\n    SetLength(FPositionToIndex, Count);\r\n    if Count > OldSize then\r\n    begin\r\n      // New items have been added, just set their position to the same as their index.\r\n      for I := OldSize to Count - 1 do\r\n        FPositionToIndex[I] := I;\r\n    end\r\n    else\r\n    begin\r\n      // Items have been deleted, so reindex remaining entries by decrementing values larger than the highest\r\n      // possible index until no entry is higher than this limit.\r\n      repeat\r\n        Changed := False;\r\n        for I := 0 to Count - 1 do\r\n          if FPositionToIndex[I] >= Count then\r\n          begin\r\n            Dec(FPositionToIndex[I]);\r\n            Changed := True;\r\n          end;\r\n      until not Changed;\r\n    end;\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TVirtualTreeColumns.Notify(Item: TCollectionItem; Action: System.Classes.TCollectionNotification);\r\n\r\nbegin\r\n  if Action in [cnExtracting, cnDeleting] then\r\n    with Header.Treeview do\r\n      if not (csLoading in ComponentState) and (FFocusedColumn = Item.Index) then\r\n        FFocusedColumn := NoColumn;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TVirtualTreeColumns.ReorderColumns(RTL: Boolean);\r\n\r\nvar\r\n  I: Integer;\r\n\r\nbegin\r\n  if RTL then\r\n  begin\r\n    for I := 0 to Count - 1 do\r\n      FPositionToIndex[I] := Count - I - 1;\r\n  end\r\n  else\r\n  begin\r\n    for I := 0 to Count - 1 do\r\n      FPositionToIndex[I] := I;\r\n  end;\r\n\r\n  UpdatePositions(True);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TVirtualTreeColumns.Update(Item: TCollectionItem);\r\n\r\nbegin\r\n  // This is the only place which gets notified when a new column has been added or removed\r\n  // and we need this event to adjust the column position array.\r\n  InitializePositionArray;\r\n  if csLoading in Header.Treeview.ComponentState then\r\n    FNeedPositionsFix := True\r\n  else\r\n    UpdatePositions;\r\n\r\n  // The first column which is created is by definition also the main column.\r\n  if (Count > 0) and (Header.FMainColumn < 0) then\r\n    FHeader.FMainColumn := 0;\r\n\r\n  if not (csLoading in Header.Treeview.ComponentState) and not (hsLoading in FHeader.FStates) then\r\n  begin\r\n    with FHeader do\r\n    begin\r\n      if hoAutoResize in FOptions then\r\n        AdjustAutoSize(InvalidColumn);\r\n      if Assigned(Item) then\r\n        Invalidate(Item as TVirtualTreeColumn)\r\n      else\r\n        if Treeview.HandleAllocated then\r\n        begin\r\n          Treeview.UpdateHorizontalScrollBar(False);\r\n          Invalidate(nil);\r\n          Treeview.Invalidate;\r\n        end;\r\n\r\n      if not (tsUpdating in Treeview.FStates) then\r\n        // This is mainly to let the designer know when a change occurs at design time which\r\n        // doesn't involve the object inspector (like column resizing with the mouse).\r\n        // This does NOT include design time code as the communication is done via an interface.\r\n        Treeview.UpdateDesigner;\r\n    end;\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TVirtualTreeColumns.UpdatePositions(Force: Boolean = False);\r\n\r\n// Recalculates the left border of every column and updates their position property according to the\r\n// PostionToIndex array which primarily determines where each column is placed visually.\r\n\r\nvar\r\n  I, RunningPos: Integer;\r\n\r\nbegin\r\n  if not (csDestroying in FHeader.Treeview.ComponentState) and not FNeedPositionsFix and (Force or (UpdateCount = 0)) then\r\n  begin\r\n    RunningPos := 0;\r\n    for I := 0 to High(FPositionToIndex) do\r\n      with Items[FPositionToIndex[I]] do\r\n      begin\r\n        FPosition := I;\r\n        FLeft := RunningPos;\r\n        if coVisible in FOptions then\r\n          Inc(RunningPos, FWidth);\r\n      end;\r\n    FHeader.Treeview.UpdateHorizontalScrollBar(False);\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TVirtualTreeColumns.Add: TVirtualTreeColumn;\r\n\r\nbegin\r\n  Result := TVirtualTreeColumn(inherited Add);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TVirtualTreeColumns.AnimatedResize(Column: TColumnIndex; NewWidth: Integer);\r\n\r\n// Resizes the given column animated by scrolling the window DC.\r\n\r\nvar\r\n  OldWidth: Integer;\r\n  DC: HDC;\r\n  I,\r\n  Steps,\r\n  DX: Integer;\r\n  HeaderScrollRect,\r\n  ScrollRect,\r\n  R: TRect;\r\n\r\n  NewBrush,\r\n  LastBrush: HBRUSH;\r\n\r\nbegin\r\n  if not IsValidColumn(Column) then\r\n    Exit; // Just in case.\r\n\r\n  // Make sure the width constrains are considered.\r\n  if NewWidth < Items[Column].FMinWidth then\r\n     NewWidth := Items[Column].FMinWidth;\r\n  if NewWidth > Items[Column].FMaxWidth then\r\n     NewWidth := Items[Column].FMaxWidth;\r\n\r\n  OldWidth := Items[Column].Width;\r\n  // Nothing to do if the width is the same.\r\n  if OldWidth <> NewWidth then\r\n  begin\r\n    if not ( (hoDisableAnimatedResize in FHeader.Options) or\r\n             (coDisableAnimatedResize in Items[Column].Options) ) then\r\n    begin\r\n      DC := GetWindowDC(FHeader.Treeview.Handle);\r\n      with FHeader.Treeview do\r\n      try\r\n        Steps := 32;\r\n        DX := (NewWidth - OldWidth) div Steps;\r\n\r\n        // Determination of the scroll rectangle is a bit complicated since we neither want\r\n        // to scroll the scrollbars nor the border of the treeview window.\r\n        HeaderScrollRect := FHeaderRect;\r\n        ScrollRect := HeaderScrollRect;\r\n        // Exclude the header itself from scrolling.\r\n        ScrollRect.Top := ScrollRect.Bottom;\r\n        ScrollRect.Bottom := ScrollRect.Top + ClientHeight;\r\n        ScrollRect.Right := ScrollRect.Left + ClientWidth;\r\n        with Items[Column] do\r\n          Inc(ScrollRect.Left, FLeft + FWidth);\r\n        HeaderScrollRect.Left := ScrollRect.Left;\r\n        HeaderScrollRect.Right := ScrollRect.Right;\r\n\r\n        // When the new width is larger then avoid artefacts on the left hand side\r\n        // by deleting a small stripe\r\n        if NewWidth > OldWidth then\r\n        begin\r\n          R := ScrollRect;\r\n          NewBrush := CreateSolidBrush(ColorToRGB(Color));\r\n          LastBrush := SelectObject(DC, NewBrush);\r\n          R.Right := R.Left + DX;\r\n          FillRect(DC, R, NewBrush);\r\n          SelectObject(DC, LastBrush);\r\n          DeleteObject(NewBrush);\r\n        end\r\n        else\r\n        begin\r\n          Inc(HeaderScrollRect.Left, DX);\r\n          Inc(ScrollRect.Left, DX);\r\n        end;\r\n\r\n        for I := 0 to Steps - 1 do\r\n        begin\r\n          ScrollDC(DC, DX, 0, HeaderScrollRect, HeaderScrollRect, 0, nil);\r\n          Inc(HeaderScrollRect.Left, DX);\r\n          ScrollDC(DC, DX, 0, ScrollRect, ScrollRect, 0, nil);\r\n          Inc(ScrollRect.Left, DX);\r\n          Sleep(1);\r\n        end;\r\n      finally\r\n        ReleaseDC(Handle, DC);\r\n      end;\r\n    end;\r\n    Items[Column].Width := NewWidth;\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TVirtualTreeColumns.Assign(Source: TPersistent);\r\n\r\nbegin\r\n  // Let the collection class assign the items.\r\n  inherited;\r\n\r\n  if Source is TVirtualTreeColumns then\r\n  begin\r\n    // Copying the position array is the only needed task here.\r\n    FPositionToIndex := Copy(TVirtualTreeColumns(Source).FPositionToIndex, 0, MaxInt);\r\n\r\n    // Make sure the left edges are correct after assignment.\r\n    FNeedPositionsFix := False;\r\n    UpdatePositions(True);\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TVirtualTreeColumns.Clear;\r\n\r\nbegin\r\n  FClearing := True;\r\n  try\r\n    Header.Treeview.CancelEditNode;\r\n\r\n    // Since we're freeing all columns, the following have to be true when we're done.\r\n    FHoverIndex := NoColumn;\r\n    FDownIndex := NoColumn;\r\n    FTrackIndex := NoColumn;\r\n    FClickIndex := NoColumn;\r\n    FCheckBoxHit := False;\r\n\r\n    with Header do\r\n      if not (hsLoading in FStates) then\r\n      begin\r\n        FAutoSizeIndex := NoColumn;\r\n        FMainColumn := NoColumn;\r\n        FSortColumn := NoColumn;\r\n      end;\r\n\r\n    with Header.Treeview do\r\n      if not (csLoading in ComponentState) then\r\n        FFocusedColumn := NoColumn;\r\n\r\n    inherited Clear;\r\n  finally\r\n    FClearing := False;\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TVirtualTreeColumns.ColumnFromPosition(P: TPoint; Relative: Boolean = True): TColumnIndex;\r\n\r\n// Determines the current column based on the position passed in P.\r\n\r\nvar\r\n  I, Sum: Integer;\r\n\r\nbegin\r\n  Result := InvalidColumn;\r\n\r\n  // The position must be within the header area, but we extend the vertical bounds to the entire treeview area.\r\n  if (P.X >= 0) and (P.Y >= 0) and (P.Y <= FHeader.TreeView.Height) then\r\n    with FHeader, Treeview do\r\n    begin\r\n      if Relative and (P.X >= GetVisibleFixedWidth) then\r\n        Sum := -FEffectiveOffsetX\r\n      else\r\n        Sum := 0;\r\n\r\n      if UseRightToLeftAlignment then\r\n        Inc(Sum, ComputeRTLOffset(True));\r\n\r\n      for I := 0 to Count - 1 do\r\n        if coVisible in Items[FPositionToIndex[I]].FOptions then\r\n        begin\r\n          Inc(Sum, Items[FPositionToIndex[I]].Width);\r\n          if P.X < Sum then\r\n          begin\r\n            Result := FPositionToIndex[I];\r\n            Break;\r\n          end;\r\n        end;\r\n    end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TVirtualTreeColumns.ColumnFromPosition(PositionIndex: TColumnPosition): TColumnIndex;\r\n\r\n// Returns the index of the column at the given position.\r\n\r\nbegin\r\n  if Integer(PositionIndex) < Length(FPositionToIndex) then\r\n    Result := FPositionToIndex[PositionIndex]\r\n  else\r\n    Result := NoColumn;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TVirtualTreeColumns.Equals(OtherColumnsObj: TObject): Boolean;\r\n\r\n// Compares itself with the given set of columns and returns True if all published properties are the same\r\n// (including column order), otherwise False is returned.\r\n\r\nvar\r\n  I: Integer;\r\n  OtherColumns : TVirtualTreeColumns;\r\n\r\nbegin\r\n  if not (OtherColumnsObj is TVirtualTreeColumns) then\r\n  begin\r\n    Result := False;\r\n    Exit;\r\n  end;\r\n\r\n  OtherColumns := TVirtualTreeColumns (OtherColumnsObj);\r\n\r\n  // Same number of columns?\r\n  Result := OtherColumns.Count = Count;\r\n  if Result then\r\n  begin\r\n    // Same order of columns?\r\n    Result := CompareMem(Pointer(FPositionToIndex), Pointer(OtherColumns.FPositionToIndex),\r\n      Length(FPositionToIndex) * SizeOf(TColumnIndex));\r\n    if Result then\r\n    begin\r\n      for I := 0 to Count - 1 do\r\n        if not Items[I].Equals(OtherColumns[I]) then\r\n        begin\r\n          Result := False;\r\n          Break;\r\n        end;\r\n    end;\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TVirtualTreeColumns.GetColumnBounds(Column: TColumnIndex; var Left, Right: Integer);\r\n\r\n// Returns the left and right bound of the given column. If Column is NoColumn then the entire client width is returned.\r\n\r\nbegin\r\n  if Column <= NoColumn then\r\n  begin\r\n    Left := 0;\r\n    Right := FHeader.Treeview.ClientWidth;\r\n  end\r\n  else\r\n  begin\r\n    Left := Items[Column].Left;\r\n    Right := Left + Items[Column].Width;\r\n    if FHeader.Treeview.UseRightToLeftAlignment then\r\n    begin\r\n      Inc(Left, FHeader.Treeview.ComputeRTLOffset(True));\r\n      Inc(Right, FHeader.Treeview.ComputeRTLOffset(True));\r\n    end;\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TVirtualTreeColumns.GetScrollWidth: Integer;\r\n\r\n// Returns the average width of all visible, non-fixed columns. If there is no such column the indent is returned.\r\n\r\nvar\r\n  I: Integer;\r\n  ScrollColumnCount: Integer;\r\n\r\nbegin\r\n\r\n  Result := 0;\r\n\r\n  ScrollColumnCount := 0;\r\n  for I := 0 to FHeader.Columns.Count - 1 do\r\n  begin\r\n    if ([coVisible, coFixed] * FHeader.Columns[I].Options = [coVisible]) then\r\n    begin\r\n      Inc(Result, FHeader.Columns[I].Width);\r\n      Inc(ScrollColumnCount);\r\n    end;\r\n  end;\r\n\r\n  if ScrollColumnCount > 0 then // use average width\r\n    Result := Round(Result / ScrollColumnCount)\r\n  else // use indent\r\n    Result := Integer(FHeader.Treeview.FIndent);\r\n\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TVirtualTreeColumns.GetFirstVisibleColumn(ConsiderAllowFocus: Boolean = False): TColumnIndex;\r\n\r\n// Returns the index of the first visible column or \"InvalidColumn\" if either no columns are defined or\r\n// all columns are hidden.\r\n// If ConsiderAllowFocus is True then the column has not only to be visible but also focus has to be allowed.\r\n\r\nvar\r\n  I: Integer;\r\n\r\nbegin\r\n  Result := InvalidColumn;\r\n  for I := 0 to Count - 1 do\r\n    if (coVisible in Items[FPositionToIndex[I]].FOptions) and\r\n       ( (not ConsiderAllowFocus) or\r\n         (coAllowFocus in Items[FPositionToIndex[I]].FOptions)\r\n       ) then\r\n    begin\r\n      Result := FPositionToIndex[I];\r\n      Break;\r\n    end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TVirtualTreeColumns.GetLastVisibleColumn(ConsiderAllowFocus: Boolean = False): TColumnIndex;\r\n\r\n// Returns the index of the last visible column or \"InvalidColumn\" if either no columns are defined or\r\n// all columns are hidden.\r\n// If ConsiderAllowFocus is True then the column has not only to be visible but also focus has to be allowed.\r\n\r\nvar\r\n  I: Integer;\r\n\r\nbegin\r\n  Result := InvalidColumn;\r\n  for I := Count - 1 downto 0 do\r\n    if (coVisible in Items[FPositionToIndex[I]].FOptions) and\r\n       ( (not ConsiderAllowFocus) or\r\n         (coAllowFocus in Items[FPositionToIndex[I]].FOptions)\r\n       ) then\r\n    begin\r\n      Result := FPositionToIndex[I];\r\n      Break;\r\n    end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TVirtualTreeColumns.GetFirstColumn: TColumnIndex;\r\n\r\n// Returns the first column in display order.\r\n\r\nbegin\r\n  if Count = 0 then\r\n    Result := InvalidColumn\r\n  else\r\n    Result := FPositionToIndex[0];\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TVirtualTreeColumns.GetNextColumn(Column: TColumnIndex): TColumnIndex;\r\n\r\n// Returns the next column in display order. Column is the index of an item in the collection (a column).\r\n\r\nvar\r\n  Position: Integer;\r\n\r\nbegin\r\n  if Column < 0 then\r\n    Result := InvalidColumn\r\n  else\r\n  begin\r\n    Position := Items[Column].Position;\r\n    if Position < Count - 1 then\r\n      Result := FPositionToIndex[Position + 1]\r\n    else\r\n      Result := InvalidColumn;\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TVirtualTreeColumns.GetNextVisibleColumn(Column: TColumnIndex; ConsiderAllowFocus: Boolean = False): TColumnIndex;\r\n\r\n// Returns the next visible column in display order, Column is an index into the columns list.\r\n// If ConsiderAllowFocus is True then the column has not only to be visible but also focus has to be allowed.\r\n\r\nbegin\r\n  Result := Column;\r\n  repeat\r\n    Result := GetNextColumn(Result);\r\n  until (Result = InvalidColumn) or\r\n        ( (coVisible in Items[Result].FOptions) and\r\n          ( (not ConsiderAllowFocus) or\r\n            (coAllowFocus in Items[Result].FOptions)\r\n          )\r\n        );\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TVirtualTreeColumns.GetPreviousColumn(Column: TColumnIndex): TColumnIndex;\r\n\r\n// Returns the previous column in display order, Column is an index into the columns list.\r\n\r\nvar\r\n  Position: Integer;\r\n\r\nbegin\r\n  if Column < 0 then\r\n    Result := InvalidColumn\r\n  else\r\n  begin\r\n    Position := Items[Column].Position;\r\n    if Position > 0 then\r\n      Result := FPositionToIndex[Position - 1]\r\n    else\r\n      Result := InvalidColumn;\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TVirtualTreeColumns.GetPreviousVisibleColumn(Column: TColumnIndex; ConsiderAllowFocus: Boolean = False): TColumnIndex;\r\n\r\n// Returns the previous visible column in display order, Column is an index into the columns list.\r\n// If ConsiderAllowFocus is True then the column has not only to be visible but also focus has to be allowed.\r\n\r\nbegin\r\n  Result := Column;\r\n  repeat\r\n    Result := GetPreviousColumn(Result);\r\n  until (Result = InvalidColumn) or\r\n        ( (coVisible in Items[Result].FOptions) and\r\n          ( (not ConsiderAllowFocus) or\r\n            (coAllowFocus in Items[Result].FOptions)\r\n          )\r\n        );\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TVirtualTreeColumns.GetVisibleColumns: TColumnsArray;\r\n\r\n// Returns a list of all currently visible columns in actual order.\r\n\r\nvar\r\n  I, Counter: Integer;\r\n\r\nbegin\r\n  SetLength(Result, Count);\r\n  Counter := 0;\r\n\r\n  for I := 0 to Count - 1 do\r\n    if coVisible in Items[FPositionToIndex[I]].FOptions then\r\n    begin\r\n      Result[Counter] := Items[FPositionToIndex[I]];\r\n      Inc(Counter);\r\n    end;\r\n  // Set result length to actual visible count.\r\n  SetLength(Result, Counter);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TVirtualTreeColumns.GetVisibleFixedWidth: Integer;\r\n\r\n// Determines the horizontal space all visible and fixed columns occupy.\r\n\r\nvar\r\n  I: Integer;\r\n\r\nbegin\r\n  Result := 0;\r\n  for I := 0 to Count - 1 do\r\n  begin\r\n    if Items[I].Options * [coVisible, coFixed] = [coVisible, coFixed] then\r\n      Inc(Result, Items[I].Width);\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TVirtualTreeColumns.IsValidColumn(Column: TColumnIndex): Boolean;\r\n\r\n// Determines whether the given column is valid or not, that is, whether it is one of the current columns.\r\n\r\nbegin\r\n  Result := (Column > NoColumn) and (Column < Count);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TVirtualTreeColumns.LoadFromStream(const Stream: TStream; Version: Integer);\r\n\r\nvar\r\n  I,\r\n  ItemCount: Integer;\r\n\r\nbegin\r\n  Clear;\r\n  Stream.ReadBuffer(ItemCount, SizeOf(ItemCount));\r\n  // number of columns\r\n  if ItemCount > 0 then\r\n  begin\r\n    BeginUpdate;\r\n    try\r\n      for I := 0 to ItemCount - 1 do\r\n        Add.LoadFromStream(Stream, Version);\r\n      SetLength(FPositionToIndex, ItemCount);\r\n      Stream.ReadBuffer(FPositionToIndex[0], ItemCount * SizeOf(TColumnIndex));\r\n      UpdatePositions(True);\r\n    finally\r\n      EndUpdate;\r\n    end;\r\n  end;\r\n\r\n  // Data introduced with header stream version 5\r\n  if Version > 4 then\r\n    Stream.ReadBuffer(FDefaultWidth, SizeOf(FDefaultWidth));\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TVirtualTreeColumns.PaintHeader(DC: HDC; R: TRect; HOffset: Integer);\r\n\r\n// Backward compatible header paint method. This method takes care of visually moving floating columns\r\n\r\nvar\r\n  VisibleFixedWidth: Integer;\r\n  RTLOffset: Integer;\r\n\r\n  procedure PaintFixedArea;\r\n  \r\n  begin\r\n    if VisibleFixedWidth > 0 then\r\n      PaintHeader(FHeaderBitmap.Canvas,\r\n        Rect(0, 0, Min(R.Right, VisibleFixedWidth), R.Bottom - R.Top),\r\n        Point(R.Left, R.Top), RTLOffset);\r\n  end;\r\n\r\nbegin\r\n  // Adjust size of the header bitmap\r\n  with TWithSafeRect(FHeader.Treeview.FHeaderRect) do\r\n  begin\r\n    FHeaderBitmap.Width := Max(Right, R.Right - R.Left);\r\n    FHeaderBitmap.Height := Bottom;\r\n  end;\r\n\r\n  VisibleFixedWidth := GetVisibleFixedWidth;\r\n\r\n  // Consider right-to-left directionality.\r\n  if FHeader.TreeView.UseRightToLeftAlignment then\r\n    RTLOffset := FHeader.Treeview.ComputeRTLOffset\r\n  else\r\n    RTLOffset := 0;\r\n    \r\n  if RTLOffset = 0 then\r\n    PaintFixedArea;\r\n\r\n  // Paint the floating part of the header.\r\n  PaintHeader(FHeaderBitmap.Canvas,\r\n    Rect(VisibleFixedWidth - HOffset, 0, R.Right + VisibleFixedWidth - HOffset, R.Bottom - R.Top),\r\n    Point(R.Left + VisibleFixedWidth, R.Top), RTLOffset);\r\n\r\n  // In case of right-to-left directionality we paint the fixed part last.\r\n  if RTLOffset <> 0 then\r\n    PaintFixedArea;\r\n  \r\n  // Blit the result to target.\r\n  with TWithSafeRect(R) do\r\n    BitBlt(DC, Left, Top, Right - Left, Bottom - Top, FHeaderBitmap.Canvas.Handle, Left, Top, SRCCOPY);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TVirtualTreeColumns.PaintHeader(TargetCanvas: TCanvas; R: TRect; const Target: TPoint;\r\n  RTLOffset: Integer = 0);\r\n\r\n// Main paint method to draw the header.\r\n// This procedure will paint the a slice (given in R) out of HeaderRect into TargetCanvas starting at position Target.\r\n// This function does not offer the option to visually move floating columns due to scrolling. To accomplish this you\r\n// need to call this method twice.\r\n\r\nconst\r\n  SortGlyphs: array[TSortDirection, Boolean] of Integer = ( // ascending/descending, normal/XP style\r\n    (3, 5) {ascending}, (2, 4) {descending}\r\n  );\r\n\r\nvar\r\n  Run: TColumnIndex;\r\n  RightBorderFlag,\r\n  NormalButtonStyle,\r\n  NormalButtonFlags,\r\n  PressedButtonStyle,\r\n  PressedButtonFlags,\r\n  RaisedButtonStyle,\r\n  RaisedButtonFlags: Cardinal;\r\n  Images: TCustomImageList;\r\n  OwnerDraw,\r\n  AdvancedOwnerDraw: Boolean;\r\n  PaintInfo: THeaderPaintInfo;\r\n  RequestedElements,\r\n  ActualElements: THeaderPaintElements;\r\n\r\n  //--------------- local functions -------------------------------------------\r\n\r\n  procedure PrepareButtonStyles;\r\n\r\n  // Prepare the button styles and flags for later usage.\r\n\r\n  begin\r\n    RaisedButtonStyle := 0;\r\n    RaisedButtonFlags := 0;\r\n    case FHeader.Style of\r\n      hsThickButtons:\r\n        begin\r\n          NormalButtonStyle := BDR_RAISEDINNER or BDR_RAISEDOUTER;\r\n          NormalButtonFlags := BF_LEFT or BF_TOP or BF_BOTTOM or BF_MIDDLE or BF_SOFT or BF_ADJUST;\r\n          PressedButtonStyle := BDR_RAISEDINNER or BDR_RAISEDOUTER;\r\n          PressedButtonFlags := NormalButtonFlags or BF_RIGHT or BF_FLAT or BF_ADJUST;\r\n        end;\r\n      hsFlatButtons:\r\n        begin\r\n          NormalButtonStyle := BDR_RAISEDINNER;\r\n          NormalButtonFlags := BF_LEFT or BF_TOP or BF_BOTTOM or BF_MIDDLE or BF_ADJUST;\r\n          PressedButtonStyle := BDR_SUNKENOUTER;\r\n          PressedButtonFlags := BF_RECT or BF_MIDDLE or BF_ADJUST;\r\n        end;\r\n    else\r\n      // hsPlates or hsXPStyle, values are not used in the latter case\r\n      begin\r\n        NormalButtonStyle := BDR_RAISEDINNER;\r\n        NormalButtonFlags := BF_RECT or BF_MIDDLE or BF_SOFT or BF_ADJUST;\r\n        PressedButtonStyle := BDR_SUNKENOUTER;\r\n        PressedButtonFlags := BF_RECT or BF_MIDDLE or BF_ADJUST;\r\n        RaisedButtonStyle := BDR_RAISEDINNER;\r\n        RaisedButtonFlags := BF_LEFT or BF_TOP or BF_BOTTOM or BF_MIDDLE or BF_ADJUST;\r\n      end;\r\n    end;\r\n  end;\r\n\r\n  //---------------------------------------------------------------------------\r\n\r\n  procedure DrawBackground;\r\n\r\n  // Draw the header background.\r\n\r\n  var\r\n    BackgroundRect: TRect;\r\n    Details: TThemedElementDetails;\r\n    Theme: HTheme;\r\n  begin\r\n    BackgroundRect := Rect(Target.X, Target.Y, Target.X + R.Right - R.Left, Target.Y + FHeader.Height);\r\n\r\n    with TargetCanvas do\r\n      begin\r\n      if hpeBackground in RequestedElements then\r\n      begin\r\n        PaintInfo.PaintRectangle := BackgroundRect;\r\n        FHeader.Treeview.DoAdvancedHeaderDraw(PaintInfo, [hpeBackground]);\r\n      end  \r\n      else\r\n      begin\r\n        if (FHeader.Treeview.VclStyleEnabled and (seClient in FHeader.FOwner.StyleElements)) then\r\n        begin\r\n          Details := StyleServices.GetElementDetails(thHeaderItemRightNormal);\r\n          StyleServices.DrawElement(Handle, Details, BackgroundRect, @BackgroundRect);\r\n        end\r\n        else\r\n        if tsUseThemes in FHeader.Treeview.FStates then\r\n        begin\r\n          Theme := OpenThemeData(FHeader.Treeview.Handle, 'HEADER');\r\n          DrawThemeBackground(Theme, Handle, HP_HEADERITEM, HIS_NORMAL, BackgroundRect, nil);\r\n          CloseThemeData(THeme);\r\n        end\r\n        else\r\n        begin\r\n          Brush.Color := FHeader.FBackgroundColor;\r\n          FillRect(BackgroundRect);\r\n        end;\r\n      end;\r\n    end;\r\n  end;\r\n\r\n  //---------------------------------------------------------------------------\r\n\r\n  procedure PaintColumnHeader(AColumn: TColumnIndex; ATargetRect: TRect);\r\n\r\n  // Draw a single column to TargetRect. The clipping rect needs to be set before\r\n  // this procedure is called.\r\n\r\n  var\r\n    Y: Integer;\r\n    SavedDC: Integer;\r\n    ColCaptionText: string;\r\n    ColImageInfo: TVTImageInfo;\r\n    SortIndex: Integer;\r\n    SortGlyphSize: TSize;\r\n    Glyph: TThemedHeader;\r\n    Details: TThemedElementDetails;\r\n    WrapCaption: Boolean;\r\n    DrawFormat: Cardinal;\r\n    Pos: TRect;\r\n    DrawHot: Boolean;\r\n    ImageWidth: Integer;\r\n    Theme: HTheme;\r\n    IdState: Integer;\r\n  begin\r\n    ColImageInfo.Ghosted := False;\r\n    PaintInfo.Column := Items[AColumn];\r\n    with PaintInfo, Column do\r\n    begin\r\n      IsHoverIndex := (AColumn = FHoverIndex) and (hoHotTrack in FHeader.FOptions) and (coEnabled in FOptions);\r\n      IsDownIndex := (AColumn = FDownIndex) and not FCheckBoxHit;\r\n\r\n      if (coShowDropMark in FOptions) and (AColumn = FDropTarget) and (AColumn <> FDragIndex) then\r\n      begin\r\n        if FDropBefore then\r\n          DropMark := dmmLeft\r\n        else\r\n          DropMark := dmmRight;\r\n      end\r\n      else\r\n        DropMark := dmmNone;\r\n\r\n      IsEnabled := (coEnabled in FOptions) and (FHeader.Treeview.Enabled);\r\n      ShowHeaderGlyph := (hoShowImages in FHeader.FOptions) and ((Assigned(Images) and (FImageIndex > -1)) or FCheckBox);\r\n      ShowSortGlyph := (AColumn = FHeader.FSortColumn) and (hoShowSortGlyphs in FHeader.FOptions);\r\n      WrapCaption := coWrapCaption in FOptions;\r\n\r\n      PaintRectangle := ATargetRect;\r\n\r\n      // This path for text columns or advanced owner draw.\r\n      if (Style = vsText) or not OwnerDraw or AdvancedOwnerDraw then\r\n      begin\r\n        // See if the application wants to draw part of the header itself.\r\n        RequestedElements := [];\r\n        if AdvancedOwnerDraw then\r\n        begin\r\n          PaintInfo.Column := Items[AColumn];\r\n          FHeader.Treeview.DoHeaderDrawQueryElements(PaintInfo, RequestedElements);\r\n        end;\r\n\r\n        if ShowRightBorder or (AColumn < Count - 1) then\r\n          RightBorderFlag := BF_RIGHT\r\n        else\r\n          RightBorderFlag := 0;\r\n\r\n        if hpeBackground in RequestedElements then\r\n          FHeader.Treeview.DoAdvancedHeaderDraw(PaintInfo, [hpeBackground])\r\n        else\r\n        begin\r\n          if FHeader.Treeview.VclStyleEnabled and (seClient in FHeader.FOwner.StyleElements)  then\r\n          begin\r\n            if IsDownIndex then\r\n              Details := StyleServices.GetElementDetails(thHeaderItemPressed)\r\n            else\r\n              if IsHoverIndex then\r\n                Details := StyleServices.GetElementDetails(thHeaderItemHot)\r\n              else\r\n                Details := StyleServices.GetElementDetails(thHeaderItemNormal);\r\n            StyleServices.DrawElement(TargetCanvas.Handle, Details, PaintRectangle, @PaintRectangle);\r\n          end\r\n          else\r\n            begin\r\n              if tsUseThemes in FHeader.Treeview.FStates then\r\n              begin\r\n                Theme := OpenThemeData(FHeader.Treeview.Handle, 'HEADER');\r\n                if IsDownIndex then\r\n                  IdState := HIS_PRESSED\r\n                else\r\n                  if IsHoverIndex then\r\n                    IdState := HIS_HOT\r\n                  else\r\n                    IdState := HIS_NORMAL;\r\n                DrawThemeBackground(Theme, TargetCanvas.Handle, HP_HEADERITEM, IdState, PaintRectangle, nil);\r\n                CloseThemeData(Theme);\r\n              end\r\n              else\r\n                if IsDownIndex then\r\n                  DrawEdge(TargetCanvas.Handle, PaintRectangle, PressedButtonStyle, PressedButtonFlags)\r\n                else\r\n                  // Plates have the special case of raising on mouse over.\r\n                  if (FHeader.Style = hsPlates) and IsHoverIndex and\r\n                     (coAllowClick in FOptions) and (coEnabled in FOptions) then\r\n                    DrawEdge(TargetCanvas.Handle, PaintRectangle, RaisedButtonStyle,\r\n                             RaisedButtonFlags or RightBorderFlag)\r\n                  else\r\n                    DrawEdge(TargetCanvas.Handle, PaintRectangle, NormalButtonStyle,\r\n                             NormalButtonFlags or RightBorderFlag);\r\n          end;\r\n        end;\r\n\r\n        PaintRectangle := ATargetRect;\r\n\r\n        // calculate text and glyph position\r\n        InflateRect(PaintRectangle, -2, -2);\r\n        DrawFormat := DT_TOP or DT_NOPREFIX;\r\n        case CaptionAlignment of\r\n          taLeftJustify  : DrawFormat := DrawFormat or DT_LEFT;\r\n          taRightJustify : DrawFormat := DrawFormat or DT_RIGHT;\r\n          taCenter       : DrawFormat := DrawFormat or DT_CENTER;\r\n        end;\r\n        if UseRightToLeftReading then\r\n          DrawFormat := DrawFormat + DT_RTLREADING;\r\n        ComputeHeaderLayout(TargetCanvas.Handle, PaintRectangle, ShowHeaderGlyph, ShowSortGlyph, GlyphPos,\r\n          SortGlyphPos, SortGlyphSize, TextRectangle, DrawFormat);\r\n\r\n        // Move glyph and text one pixel to the right and down to simulate a pressed button.\r\n        if IsDownIndex then\r\n        begin\r\n          OffsetRect(TextRectangle, 1, 1);\r\n          Inc(GlyphPos.X);\r\n          Inc(GlyphPos.Y);\r\n          Inc(SortGlyphPos.X);\r\n          Inc(SortGlyphPos.Y);\r\n        end;\r\n\r\n        // Advanced owner draw allows to paint elements, which would normally not be painted (because of space\r\n        // limitations, empty captions etc.).\r\n        ActualElements := RequestedElements * [hpeHeaderGlyph, hpeSortGlyph, hpeDropMark, hpeText];\r\n\r\n        // main glyph\r\n        FHasImage := False;\r\n        if Assigned(Images) then\r\n          ImageWidth := Images.Width\r\n        else\r\n          ImageWidth := 0;\r\n\r\n        if not (hpeHeaderGlyph in ActualElements) and ShowHeaderGlyph and\r\n          (not ShowSortGlyph or (FBiDiMode <> bdLeftToRight) or (GlyphPos.X + ImageWidth <= SortGlyphPos.X) ) then\r\n        begin\r\n          if not FCheckBox then\r\n          begin\r\n            ColImageInfo.Images := Images;\r\n            Images.Draw(TargetCanvas, GlyphPos.X, GlyphPos.Y, FImageIndex, IsEnabled);\r\n          end\r\n          else\r\n          begin\r\n            with Header.Treeview do\r\n            begin\r\n              ColImageInfo.Images := GetCheckImageListFor(CheckImageKind);\r\n              if not Assigned(ColImageInfo.Images) then\r\n                ColImageInfo.Images := CustomCheckImages;\r\n              ColImageInfo.Index := GetCheckImage(nil, FCheckType, FCheckState, IsEnabled);\r\n              ColImageInfo.XPos := GlyphPos.X;\r\n              ColImageInfo.YPos := GlyphPos.Y;\r\n              PaintCheckImage(TargetCanvas, ColImageInfo, False);\r\n            end;\r\n          end;\r\n\r\n          FHasImage := True;\r\n          with TWithSafeRect(FImageRect) do\r\n          begin\r\n            Left := GlyphPos.X;\r\n            Top := GlyphPos.Y;\r\n            Right := Left + ColImageInfo.Images.Width;\r\n            Bottom := Top + ColImageInfo.Images.Height;\r\n          end;\r\n        end;\r\n\r\n        // caption\r\n        if WrapCaption then\r\n          ColCaptionText := FCaptionText\r\n        else\r\n          ColCaptionText := Text;\r\n          if IsHoverIndex and FHeader.Treeview.VclStyleEnabled then\r\n            DrawHot := True\r\n          else\r\n            DrawHot := (IsHoverIndex and (hoHotTrack in FHeader.FOptions) and not(tsUseThemes in FHeader.Treeview.FStates));\r\n          if not(hpeText in ActualElements) and (Length(Text) > 0) then\r\n            DrawButtonText(TargetCanvas.Handle, ColCaptionText, TextRectangle, IsEnabled, DrawHot, DrawFormat, WrapCaption);\r\n\r\n        // sort glyph\r\n        if not (hpeSortGlyph in ActualElements) and ShowSortGlyph then\r\n        begin\r\n          if tsUseExplorerTheme in FHeader.Treeview.FStates then\r\n          begin\r\n            Pos.TopLeft := SortGlyphPos;\r\n            Pos.Right := Pos.Left + SortGlyphSize.cx;\r\n            Pos.Bottom := Pos.Top + SortGlyphSize.cy;\r\n            if FHeader.FSortDirection = sdAscending then\r\n              Glyph := thHeaderSortArrowSortedUp\r\n            else\r\n              Glyph := thHeaderSortArrowSortedDown;\r\n            Details := StyleServices.GetElementDetails(Glyph);\r\n            StyleServices.DrawElement(TargetCanvas.Handle, Details, Pos, @Pos);\r\n          end\r\n          else\r\n          begin\r\n            SortIndex := SortGlyphs[FHeader.FSortDirection, tsUseThemes in FHeader.Treeview.FStates];\r\n            UtilityImages.Draw(TargetCanvas, SortGlyphPos.X, SortGlyphPos.Y, SortIndex);\r\n          end;\r\n        end;\r\n\r\n        // Show an indication if this column is the current drop target in a header drag operation.\r\n        if not (hpeDropMark in ActualElements) and (DropMark <> dmmNone) then\r\n        begin\r\n          Y := (PaintRectangle.Top + PaintRectangle.Bottom - UtilityImages.Height) div 2;\r\n          if DropMark = dmmLeft then\r\n            UtilityImages.Draw(TargetCanvas, PaintRectangle.Left, Y, 0)\r\n          else\r\n            UtilityImages.Draw(TargetCanvas, PaintRectangle.Right - 16 , Y,  1);\r\n        end;\r\n\r\n        if ActualElements <> [] then\r\n        begin\r\n          SavedDC := SaveDC(TargetCanvas.Handle);\r\n          FHeader.Treeview.DoAdvancedHeaderDraw(PaintInfo, ActualElements);\r\n          RestoreDC(TargetCanvas.Handle, SavedDC);\r\n        end;\r\n      end\r\n      else // Let application draw the header.\r\n        FHeader.Treeview.DoHeaderDraw(TargetCanvas, Items[AColumn], PaintRectangle, IsHoverIndex, IsDownIndex,\r\n          DropMark);\r\n    end;\r\n  end;\r\n\r\n  //--------------- end local functions ---------------------------------------\r\n\r\nvar\r\n  TargetRect: TRect;\r\n  MaxX: Integer;\r\n\r\nbegin\r\n  if IsRectEmpty(R) then\r\n    Exit;\r\n\r\n  // If both draw posibillities are specified then prefer the advanced way.\r\n  AdvancedOwnerDraw := (hoOwnerDraw in FHeader.FOptions) and Assigned(FHeader.Treeview.FOnAdvancedHeaderDraw) and\r\n    Assigned(FHeader.Treeview.FOnHeaderDrawQueryElements) and not (csDesigning in FHeader.Treeview.ComponentState);\r\n  OwnerDraw := (hoOwnerDraw in FHeader.FOptions) and Assigned(FHeader.Treeview.FOnHeaderDraw) and\r\n    not (csDesigning in FHeader.Treeview.ComponentState) and not AdvancedOwnerDraw;\r\n\r\n  ZeroMemory(@PaintInfo, SizeOf(PaintInfo));\r\n  PaintInfo.TargetCanvas := TargetCanvas;\r\n\r\n  with PaintInfo, TargetCanvas do\r\n  begin\r\n    // Use shortcuts for the images and the font.\r\n    Images := FHeader.FImages;\r\n    Font := FHeader.FFont;\r\n\r\n    PrepareButtonStyles;\r\n\r\n    // At first, query the application which parts of the header it wants to draw on its own.\r\n    RequestedElements := [];\r\n    if AdvancedOwnerDraw then\r\n    begin\r\n      PaintRectangle := R;\r\n      Column := nil;\r\n      FHeader.Treeview.DoHeaderDrawQueryElements(PaintInfo, RequestedElements);\r\n    end;\r\n\r\n    // Draw the background.\r\n    DrawBackground;\r\n\r\n    // Now that we have drawn the background, we apply the header's dimensions to R.\r\n    R := Rect(Max(R.Left, 0), Max(R.Top, 0), Min(R.Right, TotalWidth), Min(R.Bottom, Header.Height));\r\n\r\n    // Determine where to stop.\r\n    MaxX := Target.X + R.Right - R.Left;\r\n\r\n    // Determine the start column.\r\n    Run := ColumnFromPosition(Point(R.Left + RTLOffset, 0), False);\r\n    if Run <= NoColumn then\r\n      Exit;\r\n\r\n    TargetRect.Top := Target.Y;\r\n    TargetRect.Bottom := Target.Y + R.Bottom - R.Top;\r\n    TargetRect.Left := Target.X - R.Left + Items[Run].FLeft + RTLOffset;\r\n    // TargetRect.Right will be set in the loop\r\n\r\n    ShowRightBorder := (FHeader.Style = hsThickButtons) or not (hoAutoResize in FHeader.FOptions) or\r\n      (FHeader.Treeview.BevelKind = bkNone);\r\n\r\n    // Now go for each button.\r\n    while (Run > NoColumn) and (TargetRect.Left < MaxX) do\r\n    begin\r\n      TargetRect.Right := TargetRect.Left + Items[Run].FWidth;\r\n\r\n      // create a clipping rect to limit painting to button area\r\n      ClipCanvas(TargetCanvas, Rect(Max(TargetRect.Left, Target.X), Target.Y + R.Top,\r\n                                    Min(TargetRect.Right, MaxX), TargetRect.Bottom));\r\n\r\n      PaintColumnHeader(Run, TargetRect);\r\n\r\n      SelectClipRgn(Handle, 0);\r\n      \r\n      TargetRect.Left := TargetRect.Right;\r\n      Run := GetNextVisibleColumn(Run);\r\n    end;\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TVirtualTreeColumns.SaveToStream(const Stream: TStream);\r\n\r\nvar\r\n  I: Integer;\r\n\r\nbegin\r\n  I := Count;\r\n  Stream.WriteBuffer(I, SizeOf(I));\r\n  if I > 0 then\r\n  begin\r\n    for I := 0 to Count - 1 do\r\n      TVirtualTreeColumn(Items[I]).SaveToStream(Stream);\r\n\r\n    Stream.WriteBuffer(FPositionToIndex[0], Count * SizeOf(TColumnIndex));\r\n  end;\r\n\r\n  // Data introduced with header stream version 5.\r\n  Stream.WriteBuffer(DefaultWidth, SizeOf(DefaultWidth));\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TVirtualTreeColumns.TotalWidth: Integer;\r\n\r\nvar\r\n  LastColumn: TColumnIndex;\r\n\r\nbegin\r\n  Result := 0;\r\n  if (Count > 0) and (Length(FPositionToIndex) > 0) then\r\n  begin\r\n    LastColumn := FPositionToIndex[Count - 1];\r\n    if not (coVisible in Items[LastColumn].FOptions) then\r\n      LastColumn := GetPreviousVisibleColumn(LastColumn);\r\n    if LastColumn > NoColumn then\r\n      with Items[LastColumn] do\r\n        Result := FLeft + FWidth;\r\n  end;\r\nend;\r\n\r\n//----------------- TVTFixedAreaConstraints ----------------------------------------------------------------------------\r\n\r\nconstructor TVTFixedAreaConstraints.Create(AOwner: TVTHeader);\r\n\r\nbegin\r\n  inherited Create;\r\n\r\n  FHeader := AOwner;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TVTFixedAreaConstraints.SetConstraints(Index: Integer; Value: TVTConstraintPercent);\r\n\r\nbegin\r\n  case Index of\r\n    0:\r\n      if Value <> FMaxHeightPercent then\r\n      begin\r\n        FMaxHeightPercent := Value;\r\n        if (Value > 0) and (Value < FMinHeightPercent) then\r\n          FMinHeightPercent := Value;\r\n        Change;\r\n      end;\r\n    1:\r\n      if Value <> FMaxWidthPercent then\r\n      begin\r\n        FMaxWidthPercent := Value;\r\n        if (Value > 0) and (Value < FMinWidthPercent) then\r\n          FMinWidthPercent := Value;\r\n        Change;\r\n      end;\r\n    2:\r\n      if Value <> FMinHeightPercent then\r\n      begin\r\n        FMinHeightPercent := Value;\r\n        if (FMaxHeightPercent > 0) and (Value > FMaxHeightPercent) then\r\n          FMaxHeightPercent := Value;\r\n        Change;\r\n      end;\r\n    3:\r\n      if Value <> FMinWidthPercent then\r\n      begin\r\n        FMinWidthPercent := Value;\r\n        if (FMaxWidthPercent > 0) and (Value > FMaxWidthPercent) then\r\n          FMaxWidthPercent := Value;\r\n        Change;\r\n      end;\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TVTFixedAreaConstraints.Change;\r\n\r\nbegin\r\n  if Assigned(FOnChange) then\r\n    FOnChange(Self);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TVTFixedAreaConstraints.Assign(Source: TPersistent);\r\n\r\nbegin\r\n  if Source is TVTFixedAreaConstraints then\r\n  begin\r\n    FMaxHeightPercent := TVTFixedAreaConstraints(Source).FMaxHeightPercent;\r\n    FMaxWidthPercent := TVTFixedAreaConstraints(Source).FMaxWidthPercent;\r\n    FMinHeightPercent := TVTFixedAreaConstraints(Source).FMinHeightPercent;\r\n    FMinWidthPercent := TVTFixedAreaConstraints(Source).FMinWidthPercent;\r\n    Change;\r\n  end\r\n  else\r\n    inherited;\r\nend;\r\n\r\n//----------------- TVTHeader -----------------------------------------------------------------------------------------\r\n\r\nconstructor TVTHeader.Create(AOwner: TBaseVirtualTree);\r\n\r\nbegin\r\n  inherited Create;\r\n  FOwner := AOwner;\r\n  FColumns := GetColumnsClass.Create(Self);\r\n  FHeight := 19;\r\n  FDefaultHeight := FHeight;\r\n  FMinHeight := 10;\r\n  FMaxHeight := 10000;\r\n  FFont := TFont.Create;\r\n  FFont.OnChange := FontChanged;\r\n  FParentFont := False;\r\n  FBackgroundColor := clBtnFace;\r\n  FOptions := [hoColumnResize, hoDrag, hoShowSortGlyphs];\r\n\r\n  FImageChangeLink := TChangeLink.Create;\r\n  FImageChangeLink.OnChange := ImageListChange;\r\n\r\n  FSortColumn := NoColumn;\r\n  FSortDirection := sdAscending;\r\n  FMainColumn := NoColumn;\r\n\r\n  FDragImage := TVTDragImage.Create(AOwner);\r\n  with FDragImage do\r\n  begin\r\n    Fade := False;\r\n    PostBlendBias := 0;\r\n    PreBlendBias := -50;\r\n    Transparency := 140;\r\n  end;\r\n\r\n  fSplitterHitTolerance := 8;\r\n  FFixedAreaConstraints := TVTFixedAreaConstraints.Create(Self);\r\n  FFixedAreaConstraints.OnChange := FixedAreaConstraintsChanged;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\ndestructor TVTHeader.Destroy;\r\n\r\nbegin\r\n  FDragImage.Free;\r\n  FFixedAreaConstraints.Free;\r\n  FImageChangeLink.Free;\r\n  FFont.Free;\r\n  FColumns.Clear; // TCollection's Clear method is not virtual, so we have to call our own Clear method manually.\r\n  FColumns.Free;\r\n  inherited;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TVTHeader.FontChanged(Sender: TObject);\r\nvar\r\n  I: Integer;\r\n  lMaxHeight: Integer;\r\nbegin\r\n  if toAutoChangeScale in Treeview.TreeOptions.AutoOptions then\r\n  begin\r\n    // Find the largest Columns[].Spacing\r\n    lMaxHeight := 0;\r\n    for I := 0 to Self.Columns.Count - 1 do\r\n      lMaxHeight := Max(lMaxHeight, Columns[I].Spacing);\r\n    // Calculate the required size based on the font, this is important as the use migth just vave increased the size of the icon font\r\n    with TBitmap.Create do\r\n      try\r\n        Canvas.Font.Assign(FFont);\r\n        lMaxHeight := lMaxHeight {top spacing} + (lMaxHeight div 2) {minimum bottom spacing} + Canvas.TextHeight('Q');\r\n      finally\r\n        Free;\r\n      end;\r\n    // Get the maximum of the scaled original value an\r\n    lMaxHeight := Max(lMaxHeight, FHeight);\r\n    // Set the calculated size\r\n    Self.SetHeight(lMaxHeight);\r\n  end;\r\n  Invalidate(nil);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TVTHeader.GetMainColumn: TColumnIndex;\r\n\r\nbegin\r\n  if FColumns.Count > 0 then\r\n    Result := FMainColumn\r\n  else\r\n    Result := NoColumn;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TVTHeader.GetUseColumns: Boolean;\r\n\r\nbegin\r\n  Result := FColumns.Count > 0;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TVTHeader.IsFontStored: Boolean;\r\n\r\nbegin\r\n  Result := not ParentFont;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TVTHeader.SetAutoSizeIndex(Value: TColumnIndex);\r\n\r\nbegin\r\n  if FAutoSizeIndex <> Value then\r\n  begin\r\n    FAutoSizeIndex := Value;\r\n    if hoAutoResize in FOptions then\r\n      Columns.AdjustAutoSize(InvalidColumn);\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TVTHeader.SetBackground(Value: TColor);\r\n\r\nbegin\r\n  if FBackgroundColor <> Value then\r\n  begin\r\n    FBackgroundColor := Value;\r\n    Invalidate(nil);\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TVTHeader.SetColumns(Value: TVirtualTreeColumns);\r\n\r\nbegin\r\n  FColumns.Assign(Value);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TVTHeader.SetDefaultHeight(Value: Integer);\r\n\r\nbegin\r\n  if Value < FMinHeight then\r\n    Value := FMinHeight;\r\n  if Value > FMaxHeight then\r\n    Value := FMaxHeight;\r\n\r\n  if FHeight = FDefaultHeight then\r\n    SetHeight(Value);\r\n  FDefaultHeight := Value;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TVTHeader.SetFont(const Value: TFont);\r\n\r\nbegin\r\n  FFont.Assign(Value);\r\n  FParentFont := False;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TVTHeader.SetHeight(Value: Integer);\r\n\r\nvar\r\n  RelativeMaxHeight,\r\n  RelativeMinHeight,\r\n  EffectiveMaxHeight,\r\n  EffectiveMinHeight: Integer;\r\n\r\nbegin\r\n  if not TreeView.HandleAllocated then\r\n  begin\r\n    FHeight := Value;\r\n    Include(FStates, hsNeedScaling);\r\n  end\r\n  else\r\n  begin\r\n    with FFixedAreaConstraints do\r\n    begin\r\n      RelativeMaxHeight := ((Treeview.ClientHeight + FHeight) * FMaxHeightPercent) div 100;\r\n      RelativeMinHeight := ((Treeview.ClientHeight + FHeight) * FMinHeightPercent) div 100;\r\n\r\n      EffectiveMinHeight := IfThen(FMaxHeightPercent > 0, Min(RelativeMaxHeight, FMinHeight), FMinHeight);\r\n      EffectiveMaxHeight := IfThen(FMinHeightPercent > 0, Max(RelativeMinHeight, FMaxHeight), FMaxHeight);\r\n\r\n      Value := Min(Max(Value, EffectiveMinHeight), EffectiveMaxHeight);\r\n      if FMinHeightPercent > 0 then\r\n        Value := Max(RelativeMinHeight, Value);\r\n      if FMaxHeightPercent > 0 then\r\n        Value := Min(RelativeMaxHeight, Value);\r\n    end;\r\n\r\n    if FHeight <> Value then\r\n    begin\r\n      FHeight := Value;\r\n      if not (csLoading in Treeview.ComponentState) and not (hsScaling in FStates) then\r\n        RecalculateHeader;\r\n      Treeview.Invalidate;\r\n      UpdateWindow(Treeview.Handle);\r\n    end;\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TVTHeader.SetImages(const Value: TCustomImageList);\r\n\r\nbegin\r\n  if FImages <> Value then\r\n  begin\r\n    if Assigned(FImages) then\r\n    begin\r\n      FImages.UnRegisterChanges(FImageChangeLink);\r\n      FImages.RemoveFreeNotification(FOwner);\r\n    end;\r\n    FImages := Value;\r\n    if Assigned(FImages) then\r\n    begin\r\n      FImages.RegisterChanges(FImageChangeLink);\r\n      FImages.FreeNotification(FOwner);\r\n    end;\r\n    if not (csLoading in Treeview.ComponentState) then\r\n      Invalidate(nil);\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TVTHeader.SetMainColumn(Value: TColumnIndex);\r\n\r\nbegin\r\n  if csLoading in Treeview.ComponentState then\r\n    FMainColumn := Value\r\n  else\r\n  begin\r\n    if Value < 0 then\r\n      Value := 0;\r\n    if Value > FColumns.Count - 1 then\r\n      Value := FColumns.Count - 1;\r\n    if Value <> FMainColumn then\r\n    begin\r\n      FMainColumn := Value;\r\n      if not (csLoading in Treeview.ComponentState) then\r\n      begin\r\n        Treeview.MainColumnChanged;\r\n        if not (toExtendedFocus in Treeview.FOptions.FSelectionOptions) then\r\n          Treeview.FocusedColumn := FMainColumn;\r\n        Treeview.Invalidate;\r\n      end;\r\n    end;\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TVTHeader.SetMaxHeight(Value: Integer);\r\n\r\nbegin\r\n  if Value < FMinHeight then\r\n    Value := FMinHeight;\r\n  FMaxHeight := Value;\r\n  SetHeight(FHeight);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TVTHeader.SetMinHeight(Value: Integer);\r\n\r\nbegin\r\n  if Value < 0 then\r\n    Value := 0;\r\n  if Value > FMaxHeight then\r\n    Value := FMaxHeight;\r\n  FMinHeight := Value;\r\n  SetHeight(FHeight);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TVTHeader.SetOptions(Value: TVTHeaderOptions);\r\n\r\nvar\r\n  ToBeSet,\r\n  ToBeCleared: TVTHeaderOptions;\r\n\r\nbegin\r\n  ToBeSet := Value - FOptions;\r\n  ToBeCleared := FOptions - Value;\r\n  FOptions := Value;\r\n\r\n  if (hoAutoResize in (ToBeSet + ToBeCleared)) and (FColumns.Count > 0) then\r\n  begin\r\n    FColumns.AdjustAutoSize(InvalidColumn);\r\n    if Treeview.HandleAllocated then\r\n    begin\r\n      Treeview.UpdateHorizontalScrollBar(False);\r\n      if hoAutoResize in ToBeSet then\r\n        Treeview.Invalidate;\r\n    end;\r\n  end;\r\n\r\n  if not (csLoading in Treeview.ComponentState) and Treeview.HandleAllocated then\r\n  begin\r\n    if hoVisible in (ToBeSet + ToBeCleared) then\r\n      RecalculateHeader;\r\n    Invalidate(nil);\r\n    Treeview.Invalidate;\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TVTHeader.SetParentFont(Value: Boolean);\r\n\r\nbegin\r\n  if FParentFont <> Value then\r\n  begin\r\n    FParentFont := Value;\r\n    if FParentFont then\r\n      FFont.Assign(FOwner.Font);\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TVTHeader.SetSortColumn(Value: TColumnIndex);\r\n\r\nbegin\r\n  if csLoading in Treeview.ComponentState then\r\n    FSortColumn := Value\r\n  else\r\n    DoSetSortColumn(Value);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TVTHeader.SetSortDirection(const Value: TSortDirection);\r\n\r\nbegin\r\n  if Value <> FSortDirection then\r\n  begin\r\n    FSortDirection := Value;\r\n    Invalidate(nil);\r\n    if ((toAutoSort in Treeview.FOptions.FAutoOptions) or (hoHeaderClickAutoSort in Options)) and (Treeview.FUpdateCount = 0) then\r\n      Treeview.SortTree(FSortColumn, FSortDirection, True);\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TVTHeader.CanSplitterResize(P: TPoint): Boolean;\r\n\r\nbegin\r\n  Result := hoHeightResize in FOptions;\r\n  DoCanSplitterResize(P, Result);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TVTHeader.SetStyle(Value: TVTHeaderStyle);\r\n\r\nbegin\r\n  if FStyle <> Value then\r\n  begin\r\n    FStyle := Value;\r\n    if not (csLoading in Treeview.ComponentState) then\r\n      Invalidate(nil);\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TVTHeader.CanWriteColumns: Boolean;\r\n\r\n// descendants may override this to optionally prevent column writing (e.g. if they are build dynamically).\r\n\r\nbegin\r\n  Result := True;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TVTHeader.ChangeScale(M, D: Integer);\r\nvar\r\n  I: Integer;\r\nbegin\r\n  // This method is only executed if toAutoChangeScale is set\r\n  if not ParentFont then\r\n    FFont.Size := MulDiv(FFont.Size, M, D);\r\n  Self.Height := MulDiv(FHeight, M, D);\r\n  // Scale the columns widths too\r\n  for I := 0 to FColumns.Count - 1 do\r\n  begin\r\n    Self.FColumns[I].Width := MulDiv(Self.FColumns[I].Width, M, D);\r\n  end;//for I\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TVTHeader.DetermineSplitterIndex(P: TPoint): Boolean;\r\n\r\n// Tries to find the index of that column whose right border corresponds to P.\r\n// Result is True if column border was hit (with -3..+5 pixels tolerance).\r\n// For continuous resizing the current track index and the column's left/right border are set.\r\n// Note: The hit test is checking from right to left (or left to right in RTL mode) to make enlarging of zero-sized\r\n//       columns possible.\r\n\r\nvar\r\n  VisibleFixedWidth: Integer;\r\n  SplitPoint: Integer;\r\n\r\n  //--------------- local function --------------------------------------------\r\n\r\n  function IsNearBy(IsFixedCol: Boolean; LeftTolerance, RightTolerance: Integer): Boolean;\r\n\r\n  begin\r\n    if IsFixedCol then\r\n      Result := (P.X < SplitPoint + Treeview.FEffectiveOffsetX + RightTolerance) and (P.X > SplitPoint + Treeview.FEffectiveOffsetX - LeftTolerance)\r\n    else\r\n      Result := (P.X > VisibleFixedWidth) and (P.X < SplitPoint + RightTolerance) and (P.X > SplitPoint - LeftTolerance);\r\n  end;\r\n\r\n  //--------------- end local function ----------------------------------------\r\n\r\nvar\r\n  I: Integer;\r\n  LeftTolerance: Integer; // The area left of the column divider which allows column resizing\r\nbegin\r\n  Result := False;\r\n\r\n  if FColumns.Count > 0 then\r\n  begin\r\n    FColumns.FTrackIndex := NoColumn;\r\n    VisibleFixedWidth := FColumns.GetVisibleFixedWidth;\r\n    LeftTolerance := Round(SplitterHitTolerance * 0.6);\r\n    if Treeview.UseRightToLeftAlignment then\r\n    begin\r\n      SplitPoint := -Treeview.FEffectiveOffsetX;\r\n      if Integer(Treeview.FRangeX) < Treeview.ClientWidth then\r\n        Inc(SplitPoint, Treeview.ClientWidth - Integer(Treeview.FRangeX));\r\n\r\n      for I := 0 to FColumns.Count - 1 do\r\n        with FColumns, Items[FPositionToIndex[I]] do\r\n          if coVisible in FOptions then\r\n          begin\r\n            if IsNearBy(coFixed in FOptions, LeftTolerance, SplitterHitTolerance - LeftTolerance) then\r\n            begin\r\n              if CanSplitterResize(P, FPositionToIndex[I]) then\r\n              begin\r\n                Result := True;\r\n                FTrackIndex := FPositionToIndex[I];\r\n\r\n                // Keep the right border of this column. This and the current mouse position\r\n                // directly determine the current column width.\r\n                FTrackPoint.X := SplitPoint + IfThen(coFixed in FOptions, Treeview.FEffectiveOffsetX) + FWidth;\r\n                FTrackPoint.Y := P.Y;\r\n                Break;\r\n              end;\r\n            end;\r\n            Inc(SplitPoint, FWidth);\r\n          end;\r\n    end\r\n    else\r\n    begin\r\n      SplitPoint := -Treeview.FEffectiveOffsetX + Integer(Treeview.FRangeX);\r\n\r\n      for I := FColumns.Count - 1 downto 0 do\r\n        with FColumns, Items[FPositionToIndex[I]] do\r\n          if coVisible in FOptions then\r\n          begin\r\n            if IsNearBy(coFixed in FOptions, SplitterHitTolerance - LeftTolerance, LeftTolerance) then\r\n            begin\r\n              if CanSplitterResize(P, FPositionToIndex[I]) then\r\n              begin\r\n                Result := True;\r\n                FTrackIndex := FPositionToIndex[I];\r\n\r\n                // Keep the left border of this column. This and the current mouse position\r\n                // directly determine the current column width.\r\n                FTrackPoint.X := SplitPoint + IfThen(coFixed in FOptions, Treeview.FEffectiveOffsetX) - FWidth;\r\n                FTrackPoint.Y := P.Y;\r\n                Break;\r\n              end;\r\n            end;\r\n            Dec(SplitPoint, FWidth);\r\n          end;\r\n    end;\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TVTHeader.DoAfterAutoFitColumn(Column: TColumnIndex);\r\n\r\nbegin\r\n  if Assigned(TreeView.FOnAfterAutoFitColumn) then\r\n    TreeView.FOnAfterAutoFitColumn(Self, Column);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TVTHeader.DoAfterColumnWidthTracking(Column: TColumnIndex);\r\n\r\n// Tell the application that a column width tracking operation has been finished.\r\n\r\nbegin\r\n  if Assigned(TreeView.FOnAfterColumnWidthTracking) then\r\n    TreeView.FOnAfterColumnWidthTracking(Self, Column);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TVTHeader.DoAfterHeightTracking;\r\n\r\n// Tell the application that a height tracking operation has been finished.\r\n\r\nbegin\r\n  if Assigned(TreeView.FOnAfterHeaderHeightTracking) then\r\n    TreeView.FOnAfterHeaderHeightTracking(Self);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TVTHeader.DoBeforeAutoFitColumn(Column: TColumnIndex; SmartAutoFitType: TSmartAutoFitType): Boolean;\r\n\r\n// Query the application if we may autofit a column.\r\n\r\nbegin\r\n  Result := True;\r\n  if Assigned(TreeView.FOnBeforeAutoFitColumn) then\r\n    TreeView.FOnBeforeAutoFitColumn(Self, Column, SmartAutoFitType, Result);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TVTHeader.DoBeforeColumnWidthTracking(Column: TColumnIndex; Shift: TShiftState);\r\n\r\n// Tell the a application that a column width tracking operation may begin.\r\n\r\nbegin\r\n  if Assigned(TreeView.FOnBeforeColumnWidthTracking) then\r\n    TreeView.FOnBeforeColumnWidthTracking(Self, Column, Shift);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TVTHeader.DoBeforeHeightTracking(Shift: TShiftState);\r\n\r\n// Tell the application that a height tracking operation may begin.\r\n\r\nbegin\r\n  if Assigned(TreeView.FOnBeforeHeaderHeightTracking) then\r\n    TreeView.FOnBeforeHeaderHeightTracking(Self, Shift);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TVTHeader.DoCanSplitterResize(P: TPoint; var Allowed: Boolean);\r\nbegin\r\n  if Assigned(TreeView.FOnCanSplitterResizeHeader) then\r\n    TreeView.FOnCanSplitterResizeHeader(Self, P, Allowed);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TVTHeader.DoColumnWidthDblClickResize(Column: TColumnIndex; P: TPoint; Shift: TShiftState): Boolean;\r\n\r\n// Queries the application whether a double click on the column splitter should resize the column.\r\n\r\nbegin\r\n  Result := True;\r\n  if Assigned(TreeView.FOnColumnWidthDblClickResize) then\r\n    TreeView.FOnColumnWidthDblClickResize(Self, Column, Shift, P, Result);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TVTHeader.DoColumnWidthTracking(Column: TColumnIndex; Shift: TShiftState; var TrackPoint: TPoint; P: TPoint): Boolean;\r\n\r\nbegin\r\n  Result := True;\r\n  if Assigned(TreeView.FOnColumnWidthTracking) then\r\n    TreeView.FOnColumnWidthTracking(Self, Column, Shift, TrackPoint, P, Result);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TVTHeader.DoGetPopupMenu(Column: TColumnIndex; Position: TPoint): TPopupMenu;\r\n\r\n// Queries the application whether there is a column specific header popup menu.\r\n\r\nvar\r\n  AskParent: Boolean;\r\n\r\nbegin\r\n  Result := nil;\r\n  if Assigned(TreeView.FOnGetPopupMenu) then\r\n    TreeView.FOnGetPopupMenu(TreeView, nil, Column, Position, AskParent, Result);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TVTHeader.DoHeightTracking(var P: TPoint; Shift: TShiftState): Boolean;\r\n\r\nbegin\r\n  Result := True;\r\n  if Assigned(TreeView.FOnHeaderHeightTracking) then\r\n    TreeView.FOnHeaderHeightTracking(Self, P, Shift, Result);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TVTHeader.DoHeightDblClickResize(var P: TPoint; Shift: TShiftState): Boolean;\r\n\r\nbegin\r\n  Result := True;\r\n  if Assigned(TreeView.FOnHeaderHeightDblClickResize) then\r\n    TreeView.FOnHeaderHeightDblClickResize(Self, P, Shift, Result);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TVTHeader.DoSetSortColumn(Value: TColumnIndex);\r\n\r\nbegin\r\n  if Value < NoColumn then\r\n    Value := NoColumn;\r\n  if Value > Columns.Count - 1 then\r\n    Value := Columns.Count - 1;\r\n  if FSortColumn <> Value then\r\n  begin\r\n    if FSortColumn > NoColumn then\r\n      Invalidate(Columns[FSortColumn]);\r\n    FSortColumn := Value;\r\n    if FSortColumn > NoColumn then\r\n      Invalidate(Columns[FSortColumn]);\r\n    if ((toAutoSort in Treeview.FOptions.FAutoOptions) or (hoHeaderClickAutoSort in Options)) and (Treeview.FUpdateCount = 0) then\r\n      Treeview.SortTree(FSortColumn, FSortDirection, True);\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TVTHeader.DragTo(P: TPoint);\r\n\r\n// Moves the drag image to a new position, which is determined from the passed point P and the previous\r\n// mouse position.\r\n\r\nvar\r\n  I,\r\n  NewTarget: Integer;\r\n  // optimized drag image move support\r\n  ClientP: TPoint;\r\n  Left,\r\n  Right: Integer;\r\n  NeedRepaint: Boolean; // True if the screen needs an update (changed drop target or drop side)\r\n\r\nbegin\r\n  // Determine new drop target and which side of it is prefered.\r\n  ClientP := Treeview.ScreenToClient(P);\r\n  // Make coordinates relative to (0, 0) of the non-client area.\r\n  Inc(ClientP.Y, FHeight);\r\n  NewTarget := FColumns.ColumnFromPosition(ClientP);\r\n  NeedRepaint := (NewTarget <> InvalidColumn) and (NewTarget <> FColumns.FDropTarget);\r\n  if NewTarget >= 0 then\r\n  begin\r\n    FColumns.GetColumnBounds(NewTarget, Left, Right);\r\n    if (ClientP.X < ((Left + Right) div 2)) <> FColumns.FDropBefore then\r\n    begin\r\n      NeedRepaint := True;\r\n      FColumns.FDropBefore := not FColumns.FDropBefore;\r\n    end;\r\n  end;\r\n\r\n  if NeedRepaint then\r\n  begin\r\n    // Invalidate columns which need a repaint.\r\n    if FColumns.FDropTarget > NoColumn then\r\n    begin\r\n      I := FColumns.FDropTarget;\r\n      FColumns.FDropTarget := NoColumn;\r\n      Invalidate(FColumns.Items[I]);\r\n    end;\r\n    if (NewTarget > NoColumn) and (NewTarget <> FColumns.FDropTarget) then\r\n    begin\r\n      Invalidate(FColumns.Items[NewTarget]);\r\n      FColumns.FDropTarget := NewTarget;\r\n    end;\r\n  end;\r\n\r\n  FDragImage.DragTo(P, NeedRepaint);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TVTHeader.FixedAreaConstraintsChanged(Sender: TObject);\r\n\r\n// This method gets called when FFixedAreaConstraints is changed.\r\n\r\nbegin\r\n  if Treeview.HandleAllocated then\r\n    RescaleHeader\r\n  else\r\n    Include(FStates, hsNeedScaling);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TVTHeader.GetColumnsClass: TVirtualTreeColumnsClass;\r\n\r\n// Returns the class to be used for the actual column implementation. descendants may optionally override this and\r\n// return their own class.\r\n\r\nbegin\r\n  Result := TVirtualTreeColumns;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TVTHeader.GetOwner: TPersistent;\r\n\r\nbegin\r\n  Result := FOwner;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TVTHeader.GetShiftState: TShiftState;\r\n\r\nbegin\r\n  Result := [];\r\n  if GetKeyState(VK_SHIFT) < 0 then\r\n    Include(Result, ssShift);\r\n  if GetKeyState(VK_CONTROL) < 0 then\r\n    Include(Result, ssCtrl);\r\n  if GetKeyState(VK_MENU) < 0 then\r\n    Include(Result, ssAlt);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TVTHeader.HandleHeaderMouseMove(var Message: TWMMouseMove): Boolean;\r\n\r\nvar\r\n  P: TPoint;\r\n  NextColumn,\r\n  I: TColumnIndex;\r\n  NewWidth: Integer;\r\n\r\nbegin\r\n  Result := False;\r\n  with Message do\r\n  begin\r\n    P := Point(XPos, YPos);\r\n    if hsColumnWidthTrackPending in FStates then\r\n    begin\r\n      Treeview.StopTimer(HeaderTimer);\r\n      FStates := FStates - [hsColumnWidthTrackPending] + [hsColumnWidthTracking];\r\n      HandleHeaderMouseMove := True;\r\n      Result := 0;\r\n    end\r\n    else\r\n      if hsHeightTrackPending in FStates then\r\n      begin\r\n        Treeview.StopTimer(HeaderTimer);\r\n        FStates := FStates - [hsHeightTrackPending] + [hsHeightTracking];\r\n        HandleHeaderMouseMove := True;\r\n        Result := 0;\r\n      end\r\n      else\r\n        if hsColumnWidthTracking in FStates then\r\n        begin\r\n          if DoColumnWidthTracking(FColumns.FTrackIndex, GetShiftState, FTrackPoint, P) then\r\n          begin\r\n            if Treeview.UseRightToLeftAlignment then\r\n            begin\r\n              NewWidth := FTrackPoint.X - XPos;\r\n              NextColumn := FColumns.GetPreviousVisibleColumn(FColumns.FTrackIndex);\r\n          end\r\n            else\r\n            begin\r\n              NewWidth := XPos - FTrackPoint.X;\r\n              NextColumn := FColumns.GetNextVisibleColumn(FColumns.FTrackIndex);\r\n            end;\r\n\r\n            // The autosized column cannot be resized using the mouse normally. Instead we resize the next\r\n            // visible column, so it look as we directly resize the autosized column.\r\n            if (hoAutoResize in FOptions) and (FColumns.FTrackIndex = FAutoSizeIndex) and\r\n               (NextColumn > NoColumn) and (coResizable in FColumns[NextColumn].FOptions) and\r\n               (FColumns[FColumns.FTrackIndex].FMinWidth < NewWidth) and\r\n               (FColumns[FColumns.FTrackIndex].FMaxWidth > NewWidth) then\r\n              FColumns[NextColumn].Width := FColumns[NextColumn].Width - NewWidth\r\n                                            + FColumns[FColumns.FTrackIndex].Width\r\n            else\r\n              FColumns[FColumns.FTrackIndex].Width := NewWidth; // 1 EListError seen here (List index out of bounds (-1)) since 10/2013\r\n          end;\r\n          HandleHeaderMouseMove := True;\r\n          Result := 0;\r\n        end\r\n        else\r\n          if hsHeightTracking in FStates then\r\n          begin\r\n            if DoHeightTracking(P, GetShiftState) then\r\n              SetHeight(Integer(FHeight) + P.Y);\r\n            HandleHeaderMouseMove := True;\r\n            Result := 0;\r\n          end\r\n          else\r\n          begin\r\n            if hsDragPending in FStates then\r\n            begin\r\n              P := Treeview.ClientToScreen(P);\r\n              // start actual dragging if allowed\r\n              if (hoDrag in FOptions) and Treeview.DoHeaderDragging(FColumns.FDownIndex) then\r\n              begin\r\n                if ((Abs(FDragStart.X - P.X) > Mouse.DragThreshold) or\r\n                   (Abs(FDragStart.Y - P.Y) > Mouse.DragThreshold)) then\r\n                begin\r\n                  Treeview.StopTimer(HeaderTimer);\r\n                  I := FColumns.FDownIndex;\r\n                  FColumns.FDownIndex := NoColumn;\r\n                  FColumns.FHoverIndex := NoColumn;\r\n                  if I > NoColumn then\r\n                    Invalidate(FColumns[I]);\r\n                  PrepareDrag(P, FDragStart);\r\n                  FStates := FStates - [hsDragPending] + [hsDragging];\r\n                  HandleHeaderMouseMove := True;\r\n                  Result := 0;\r\n                end;\r\n              end;\r\n            end\r\n            else\r\n              if hsDragging in FStates then\r\n              begin\r\n                DragTo(Treeview.ClientToScreen(Point(XPos, YPos)));\r\n                HandleHeaderMouseMove := True;\r\n                Result := 0;\r\n              end;\r\n          end;\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TVTHeader.HandleMessage(var Message: TMessage): Boolean;\r\n\r\n// The header gets here the opportunity to handle certain messages before they reach the tree. This is important\r\n// because the tree needs to handle various non-client area messages for the header as well as some dragging/tracking\r\n// events.\r\n// By returning True the message will not be handled further, otherwise the message is then dispatched\r\n// to the proper message handlers.\r\n\r\nvar\r\n  P: TPoint;\r\n  R: TRect;\r\n  I: TColumnIndex;\r\n  OldPosition: Integer;\r\n  HitIndex: TColumnIndex;\r\n  NewCursor: HCURSOR;\r\n  Button: TMouseButton;\r\n  Menu: TPopupMenu;\r\n  IsInHeader,\r\n  IsHSplitterHit,\r\n  IsVSplitterHit: Boolean;\r\n\r\n  //--------------- local function --------------------------------------------\r\n\r\n  function HSplitterHit: Boolean;\r\n\r\n  var\r\n    NextCol: TColumnIndex;\r\n\r\n  begin\r\n    Result := (hoColumnResize in FOptions) and DetermineSplitterIndex(P);\r\n    if Result and not InHeader(P) then\r\n    begin\r\n      NextCol := FColumns.GetNextVisibleColumn(FColumns.FTrackIndex);\r\n      if not (coFixed in FColumns[FColumns.FTrackIndex].Options) or (NextCol <= NoColumn) or\r\n         (coFixed in FColumns[NextCol].Options) or (P.Y > Integer(Treeview.FRangeY)) then\r\n        Result := False;\r\n    end;\r\n  end;\r\n\r\n  //--------------- end local function ----------------------------------------\r\n\r\nbegin\r\n  Result := False;\r\n  case Message.Msg of\r\n    WM_SIZE:\r\n      begin\r\n        if not (tsWindowCreating in FOwner.FStates) then\r\n          if (hoAutoResize in FOptions) and not (hsAutoSizing in FStates) then\r\n          begin\r\n            FColumns.AdjustAutoSize(InvalidColumn);\r\n            Invalidate(nil);\r\n          end\r\n          else\r\n            if not (hsScaling in FStates) then\r\n            begin\r\n              RescaleHeader;\r\n              Invalidate(nil);\r\n            end;\r\n      end;\r\n    CM_PARENTFONTCHANGED:\r\n      if FParentFont then\r\n        FFont.Assign(FOwner.Font);\r\n    CM_BIDIMODECHANGED:\r\n      for I := 0 to FColumns.Count - 1 do\r\n        if coParentBiDiMode in FColumns[I].FOptions then\r\n          FColumns[I].ParentBiDiModeChanged;\r\n    WM_NCMBUTTONDOWN:\r\n      begin\r\n        with TWMNCMButtonDown(Message) do\r\n          P := Treeview.ScreenToClient(Point(XCursor, YCursor));\r\n        if InHeader(P) then\r\n          FOwner.DoHeaderMouseDown(mbMiddle, GetShiftState, P.X, P.Y + Integer(FHeight));\r\n      end;\r\n    WM_NCMBUTTONUP:\r\n      begin\r\n        with TWMNCMButtonUp(Message) do\r\n          P := FOwner.ScreenToClient(Point(XCursor, YCursor));\r\n        if InHeader(P) then\r\n        begin\r\n          FColumns.HandleClick(P, mbMiddle, True, False);\r\n          FOwner.DoHeaderMouseUp(mbMiddle, GetShiftState, P.X, P.Y + Integer(FHeight));\r\n          FColumns.FDownIndex := NoColumn;\r\n          FColumns.FCheckBoxHit := False;\r\n        end;\r\n      end;\r\n    WM_LBUTTONDBLCLK,\r\n    WM_NCLBUTTONDBLCLK,\r\n    WM_NCMBUTTONDBLCLK,\r\n    WM_NCRBUTTONDBLCLK:\r\n      begin\r\n        if Message.Msg <> WM_LBUTTONDBLCLK then\r\n          with TWMNCLButtonDblClk(Message) do\r\n            P := FOwner.ScreenToClient(Point(XCursor, YCursor))\r\n        else\r\n          with TWMLButtonDblClk(Message) do\r\n            P := Point(XPos, YPos);\r\n\r\n        if (hoHeightDblClickResize in FOptions) and InHeaderSplitterArea(P) and (FDefaultHeight > 0) then\r\n        begin\r\n          if DoHeightDblClickResize(P, GetShiftState) and (FDefaultHeight > 0) then\r\n            SetHeight(FMinHeight);\r\n          Result := True;\r\n        end\r\n        else\r\n          if HSplitterHit and ((Message.Msg = WM_NCLBUTTONDBLCLK) or (Message.Msg = WM_LBUTTONDBLCLK)) and\r\n             (hoDblClickResize in FOptions) and (FColumns.FTrackIndex > NoColumn) then\r\n          begin\r\n            // If the click was on a splitter then resize column to smallest width.\r\n            if DoColumnWidthDblClickResize(FColumns.FTrackIndex, P, GetShiftState) then\r\n              AutoFitColumns(True, smaUseColumnOption, FColumns[FColumns.FTrackIndex].FPosition,\r\n                             FColumns[FColumns.FTrackIndex].FPosition);\r\n            Message.Result := 0;\r\n            Result := True;\r\n          end\r\n          else\r\n            if InHeader(P) and (Message.Msg <> WM_LBUTTONDBLCLK) then\r\n            begin\r\n              case Message.Msg of\r\n                WM_NCMBUTTONDBLCLK:\r\n                  Button := mbMiddle;\r\n                WM_NCRBUTTONDBLCLK:\r\n                  Button := mbRight;\r\n                else\r\n                  // WM_NCLBUTTONDBLCLK\r\n                  Button := mbLeft;\r\n              end;\r\n              if Button = mbLeft then\r\n                Columns.AdjustDownColumn(P);\r\n              FColumns.HandleClick(P, Button, True, True);\r\n            end;\r\n      end;\r\n    // The \"hot\" area of the headers horizontal splitter is partly within the client area of the the tree, so we need\r\n    // to handle WM_LBUTTONDOWN here, too.\r\n    WM_LBUTTONDOWN,\r\n    WM_NCLBUTTONDOWN:\r\n      begin\r\n\r\n        Application.CancelHint;\r\n\r\n        if not (csDesigning in Treeview.ComponentState) then\r\n        begin\r\n          // make sure no auto scrolling is active...\r\n          Treeview.StopTimer(ScrollTimer);\r\n          Treeview.DoStateChange([], [tsScrollPending, tsScrolling]);\r\n          // ... pending editing is cancelled (actual editing remains active)\r\n          Treeview.StopTimer(EditTimer);\r\n          Treeview.DoStateChange([], [tsEditPending]);\r\n        end;\r\n\r\n        if Message.Msg = WM_LBUTTONDOWN then\r\n          // Coordinates are already client area based.\r\n          with TWMLButtonDown(Message) do\r\n            P := Point(XPos, YPos)\r\n        else\r\n          with TWMNCLButtonDown(Message) do\r\n          begin\r\n            // want the drag start point in screen coordinates\r\n            FDragStart := Point(XCursor, YCursor);\r\n            P := Treeview.ScreenToClient(FDragStart);\r\n          end;\r\n\r\n        IsInHeader := InHeader(P);\r\n        // in design-time header columns are always resizable\r\n        if (csDesigning in Treeview.ComponentState) then\r\n          IsVSplitterHit := InHeaderSplitterArea(P)\r\n        else\r\n          IsVSplitterHit := InHeaderSplitterArea(P) and CanSplitterResize(P);\r\n        IsHSplitterHit := HSplitterHit;\r\n\r\n        if IsVSplitterHit or IsHSplitterHit then\r\n        begin\r\n          FTrackStart := P;\r\n          FColumns.FHoverIndex := NoColumn;\r\n          if IsVSplitterHit then\r\n          begin\r\n            if not (csDesigning in Treeview.ComponentState) then\r\n              DoBeforeHeightTracking(GetShiftState);\r\n            Include(FStates, hsHeightTrackPending);\r\n          end\r\n          else\r\n          begin\r\n            if not (csDesigning in Treeview.ComponentState) then\r\n              DoBeforeColumnWidthTracking(FColumns.FTrackIndex, GetShiftState);\r\n            Include(FStates, hsColumnWidthTrackPending);\r\n          end;\r\n\r\n          SetCapture(Treeview.Handle);\r\n          Result := True;\r\n          Message.Result := 0;\r\n        end\r\n        else\r\n          if IsInHeader then\r\n          begin\r\n            HitIndex := Columns.AdjustDownColumn(P);\r\n            // in design-time header columns are always draggable\r\n            if ((csDesigning in Treeview.ComponentState) and (HitIndex > NoColumn)) or\r\n               ((hoDrag in FOptions) and (HitIndex > NoColumn) and (coDraggable in FColumns[HitIndex].FOptions)) then\r\n            begin\r\n              // Show potential drag operation.\r\n              // Disabled columns do not start a drag operation because they can't be clicked.\r\n              Include(FStates, hsDragPending);\r\n              SetCapture(Treeview.Handle);\r\n              Result := True;\r\n              Message.Result := 0;\r\n            end;\r\n          end;\r\n\r\n        // This is a good opportunity to notify the application.\r\n        if not (csDesigning in Treeview.ComponentState) and IsInHeader then\r\n          FOwner.DoHeaderMouseDown(mbLeft, GetShiftState, P.X, P.Y + Integer(FHeight));\r\n      end;\r\n    WM_NCRBUTTONDOWN:\r\n      begin\r\n        with TWMNCRButtonDown(Message) do\r\n          P := FOwner.ScreenToClient(Point(XCursor, YCursor));\r\n        if InHeader(P) then\r\n          FOwner.DoHeaderMouseDown(mbRight, GetShiftState, P.X, P.Y + Integer(FHeight));\r\n      end;\r\n    WM_NCRBUTTONUP:\r\n      if not (csDesigning in FOwner.ComponentState) then\r\n        with TWMNCRButtonUp(Message) do\r\n        begin\r\n          Application.CancelHint;\r\n\r\n          P := FOwner.ScreenToClient(Point(XCursor, YCursor));\r\n          if InHeader(P) then\r\n          begin\r\n            FColumns.HandleClick(P, mbRight, True, False);\r\n            FOwner.DoHeaderMouseUp(mbRight, GetShiftState, P.X, P.Y + Integer(FHeight));\r\n            FColumns.FDownIndex := NoColumn;\r\n            FColumns.FTrackIndex := NoColumn;\r\n            FColumns.FCheckBoxHit := False;\r\n\r\n            Menu := FPopupMenu;\r\n            if not Assigned(Menu) then\r\n              Menu := DoGetPopupMenu(FColumns.ColumnFromPosition(Point(P.X, P.Y + Integer(FHeight))), P);\r\n\r\n            // Trigger header popup if there's one.\r\n            if Assigned(Menu) then\r\n            begin\r\n              Treeview.StopTimer(ScrollTimer);\r\n              Treeview.StopTimer(HeaderTimer);\r\n              FColumns.FHoverIndex := NoColumn;\r\n              Treeview.DoStateChange([], [tsScrollPending, tsScrolling]);\r\n              Menu.PopupComponent := Treeview;\r\n              Menu.Popup(XCursor, YCursor);\r\n              HandleMessage := True;\r\n            end;\r\n          end;\r\n        end;\r\n    // When the tree window has an active mouse capture then we only get \"client-area\" messages.\r\n    WM_LBUTTONUP,\r\n    WM_NCLBUTTONUP:\r\n      begin\r\n        Application.CancelHint;\r\n\r\n        if FStates <> [] then\r\n        begin\r\n          ReleaseCapture;\r\n          if hsDragging in FStates then\r\n          begin\r\n            // successfull dragging moves columns\r\n            with TWMLButtonUp(Message) do\r\n              P := Treeview.ClientToScreen(Point(XPos, YPos));\r\n            GetWindowRect(Treeview.Handle, R);\r\n            with FColumns do\r\n            begin\r\n              FDragImage.EndDrag;\r\n              if (FDropTarget > -1) and (FDropTarget <> FDragIndex) and PtInRect(R, P) then\r\n              begin\r\n                OldPosition := FColumns[FDragIndex].Position;\r\n                if FColumns.FDropBefore then\r\n                begin\r\n                  if FColumns[FDragIndex].Position < FColumns[FDropTarget].Position then\r\n                    FColumns[FDragIndex].Position := Max(0, FColumns[FDropTarget].Position - 1)\r\n                  else\r\n                    FColumns[FDragIndex].Position := FColumns[FDropTarget].Position;\r\n                end\r\n                else\r\n                begin\r\n                  if FColumns[FDragIndex].Position < FColumns[FDropTarget].Position then\r\n                    FColumns[FDragIndex].Position := FColumns[FDropTarget].Position\r\n                  else\r\n                    FColumns[FDragIndex].Position := FColumns[FDropTarget].Position + 1;\r\n                end;\r\n                Treeview.DoHeaderDragged(FDragIndex, OldPosition);\r\n              end\r\n              else\r\n                Treeview.DoHeaderDraggedOut(FDragIndex, P);\r\n              FDropTarget := NoColumn;\r\n            end;\r\n            Invalidate(nil);\r\n          end;\r\n          Result := True;\r\n          Message.Result := 0;\r\n        end;\r\n\r\n        case Message.Msg of\r\n          WM_LBUTTONUP:\r\n            with TWMLButtonUp(Message) do\r\n            begin\r\n              if FColumns.FDownIndex > NoColumn then\r\n                FColumns.HandleClick(Point(XPos, YPos), mbLeft, False, False);\r\n              if FStates <> [] then\r\n                FOwner.DoHeaderMouseUp(mbLeft, KeysToShiftState(Keys), XPos, YPos);\r\n            end;\r\n          WM_NCLBUTTONUP:\r\n            with TWMNCLButtonUp(Message) do\r\n            begin\r\n              P := FOwner.ScreenToClient(Point(XCursor, YCursor));\r\n              FColumns.HandleClick(P, mbLeft, False, False);\r\n              FOwner.DoHeaderMouseUp(mbLeft, GetShiftState, P.X, P.Y + Integer(FHeight));\r\n            end;\r\n        end;\r\n\r\n        if FColumns.FTrackIndex > NoColumn then\r\n        begin\r\n          if hsColumnWidthTracking in FStates then\r\n            DoAfterColumnWidthTracking(FColumns.FTrackIndex);\r\n          Invalidate(Columns[FColumns.FTrackIndex]);\r\n          FColumns.FTrackIndex := NoColumn;\r\n        end;\r\n        if FColumns.FDownIndex > NoColumn then\r\n        begin\r\n          Invalidate(Columns[FColumns.FDownIndex]);\r\n          FColumns.FDownIndex := NoColumn;\r\n        end;\r\n        if hsHeightTracking in FStates then\r\n          DoAfterHeightTracking;\r\n\r\n        FStates := FStates - [hsDragging, hsDragPending,\r\n                              hsColumnWidthTracking, hsColumnWidthTrackPending,\r\n                              hsHeightTracking, hsHeightTrackPending];\r\n      end;\r\n    // hovering, mouse leave detection\r\n    WM_NCMOUSEMOVE:\r\n      with TWMNCMouseMove(Message), FColumns do\r\n      begin\r\n        P := Treeview.ScreenToClient(Point(XCursor, YCursor));\r\n        Treeview.DoHeaderMouseMove(GetShiftState, P.X, P.Y + Integer(FHeight));\r\n        if InHeader(P) and ((AdjustHoverColumn(P)) or ((FDownIndex >= 0) and (FHoverIndex <> FDownIndex))) then\r\n        begin\r\n          // We need a mouse leave detection from here for the non client area.\r\n          // TODO: The best solution available would be the TrackMouseEvent API.\r\n          // With the drop of the support of Win95 totally and WinNT4 we should replace the timer.\r\n          Treeview.StopTimer(HeaderTimer);\r\n          SetTimer(Treeview.Handle, HeaderTimer, 50, nil);\r\n          // use Delphi's internal hint handling for header hints too\r\n          if hoShowHint in FOptions then\r\n          begin\r\n            // client coordinates!\r\n            XCursor := P.X;\r\n            YCursor := P.Y + Integer(FHeight);\r\n            Application.HintMouseMessage(Treeview, Message);\r\n          end;\r\n        end;\r\n      end;\r\n    WM_TIMER:\r\n      if TWMTimer(Message).TimerID = HeaderTimer then\r\n      begin\r\n        // determine current mouse position to check if it left the window\r\n        GetCursorPos(P);\r\n        P := Treeview.ScreenToClient(P);\r\n        with FColumns do\r\n        begin\r\n          if not InHeader(P) or ((FDownIndex > NoColumn) and (FHoverIndex <> FDownIndex)) then\r\n          begin\r\n            Treeview.StopTimer(HeaderTimer);\r\n            FHoverIndex := NoColumn;\r\n            FClickIndex := NoColumn;\r\n            FDownIndex := NoColumn;\r\n            FCheckBoxHit := False;\r\n            Result := True;\r\n            Message.Result := 0;\r\n            Invalidate(nil);\r\n          end;\r\n        end;\r\n      end;\r\n    WM_MOUSEMOVE: // mouse capture and general message redirection\r\n      Result := HandleHeaderMouseMove(TWMMouseMove(Message));\r\n    WM_SETCURSOR:\r\n      // Feature: design-time header\r\n      if (FStates = []) then\r\n      begin\r\n        // Retrieve last cursor position (GetMessagePos does not work here, I don't know why).\r\n        GetCursorPos(P);\r\n\r\n        // Is the mouse in the header rectangle and near the splitters?\r\n        P := Treeview.ScreenToClient(P);\r\n        IsHSplitterHit := HSplitterHit;\r\n        // in design-time header columns are always resizable\r\n        if (csDesigning in Treeview.ComponentState) then\r\n          IsVSplitterHit := InHeaderSplitterArea(P)\r\n        else\r\n          IsVSplitterHit := InHeaderSplitterArea(P) and CanSplitterResize(P);\r\n\r\n        if IsVSplitterHit or IsHSplitterHit then\r\n        begin\r\n          NewCursor := Screen.Cursors[Treeview.Cursor];\r\n          if IsVSplitterHit and ((hoHeightResize in FOptions) or (csDesigning in Treeview.ComponentState)) then\r\n            NewCursor := Screen.Cursors[crVertSplit]\r\n          else\r\n            if IsHSplitterHit then\r\n              NewCursor := Screen.Cursors[crHeaderSplit];\r\n\r\n          if not (csDesigning in Treeview.ComponentState) then\r\n            Treeview.DoGetHeaderCursor(NewCursor);\r\n          Result := NewCursor <> Screen.Cursors[crDefault];\r\n          if Result then\r\n          begin\r\n            Winapi.Windows.SetCursor(NewCursor);\r\n            Message.Result := 1;\r\n          end;\r\n        end;\r\n      end\r\n      else\r\n      begin\r\n        Message.Result := 1;\r\n        Result := True;\r\n      end;\r\n    WM_KEYDOWN,\r\n    WM_KILLFOCUS:\r\n      if (Message.Msg = WM_KILLFOCUS) or\r\n         (TWMKeyDown(Message).CharCode = VK_ESCAPE) then\r\n      begin\r\n        if hsDragging in FStates then\r\n        begin\r\n          ReleaseCapture;\r\n          FDragImage.EndDrag;\r\n          Exclude(FStates, hsDragging);\r\n          FColumns.FDropTarget := NoColumn;\r\n          Invalidate(nil);\r\n          Result := True;\r\n          Message.Result := 0;\r\n        end\r\n        else\r\n        begin\r\n          if [hsColumnWidthTracking, hsHeightTracking] * FStates <> [] then\r\n          begin\r\n            ReleaseCapture;\r\n            if hsColumnWidthTracking in FStates then\r\n              DoAfterColumnWidthTracking(FColumns.FTrackIndex);\r\n            if hsHeightTracking in FStates then\r\n              DoAfterHeightTracking;\r\n            Result := True;\r\n            Message.Result := 0;\r\n          end;\r\n\r\n          FStates := FStates - [hsColumnWidthTracking, hsColumnWidthTrackPending,\r\n                                hsHeightTracking, hsHeightTrackPending];\r\n        end;\r\n      end;\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TVTHeader.ImageListChange(Sender: TObject);\r\n\r\nbegin\r\n  if not (csDestroying in Treeview.ComponentState) then\r\n    Invalidate(nil);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TVTHeader.PrepareDrag(P, Start: TPoint);\r\n\r\n// Initializes dragging of the header, P is the current mouse postion and Start the initial mouse position.\r\n\r\nvar\r\n  Image: TBitmap;\r\n  ImagePos: TPoint;\r\n  DragColumn: TVirtualTreeColumn;\r\n  RTLOffset: Integer;\r\n\r\nbegin\r\n  // Determine initial position of drag image (screen coordinates).\r\n  FColumns.FDropTarget := NoColumn;\r\n  Start := Treeview.ScreenToClient(Start);\r\n  Inc(Start.Y, FHeight);\r\n  FColumns.FDragIndex := FColumns.ColumnFromPosition(Start);\r\n  DragColumn := FColumns[FColumns.FDragIndex];\r\n\r\n  Image := TBitmap.Create;\r\n  with Image do\r\n  try\r\n    PixelFormat := pf32Bit;\r\n    Width := DragColumn.Width;\r\n    Height := FHeight;\r\n\r\n    // Erase the entire image with the color key value, for the case not everything\r\n    // in the image is covered by the header image.\r\n    Canvas.Brush.Color := clBtnFace;\r\n    Canvas.FillRect(Rect(0, 0, Width, Height));\r\n\r\n    if TreeView.UseRightToLeftAlignment then\r\n      RTLOffset := Treeview.ComputeRTLOffset\r\n    else\r\n      RTLOffset := 0;\r\n    with DragColumn do\r\n      FColumns.PaintHeader(Canvas, Rect(FLeft, 0, FLeft + Width, Height), Point(-RTLOffset, 0), RTLOffset);\r\n\r\n    if Treeview.UseRightToLeftAlignment then\r\n      ImagePos := Treeview.ClientToScreen(Point(DragColumn.Left + Treeview.ComputeRTLOffset(True), 0))\r\n    else\r\n      ImagePos := Treeview.ClientToScreen(Point(DragColumn.Left, 0));\r\n    // Column rectangles are given in local window coordinates not client coordinates.\r\n    Dec(ImagePos.Y, FHeight);\r\n\r\n    if hoRestrictDrag in FOptions then\r\n      FDragImage.MoveRestriction := dmrHorizontalOnly\r\n    else\r\n      FDragImage.MoveRestriction := dmrNone;\r\n    FDragImage.PrepareDrag(Image, ImagePos, P, nil);\r\n    FDragImage.ShowDragImage;\r\n  finally\r\n    Image.Free;\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TVTHeader.ReadColumns(Reader: TReader);\r\n\r\nbegin\r\n  Include(FStates, hsLoading);\r\n  Columns.Clear;\r\n  Reader.ReadValue;\r\n  Reader.ReadCollection(Columns);\r\n  Exclude(FStates, hsLoading);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TVTHeader.RecalculateHeader;\r\n\r\n// Initiate a recalculation of the non-client area of the owner tree.\r\n\r\nbegin\r\n  if Treeview.HandleAllocated then\r\n  begin\r\n    Treeview.UpdateHeaderRect;\r\n    SetWindowPos(Treeview.Handle, 0, 0, 0, 0, 0, SWP_FRAMECHANGED or SWP_NOMOVE or SWP_NOACTIVATE or SWP_NOOWNERZORDER or\r\n      SWP_NOSENDCHANGING or SWP_NOSIZE or SWP_NOZORDER);\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TVTHeader.RescaleHeader;\r\n\r\n// Rescale the fixed elements (fixed columns, header itself) to FixedAreaConstraints.\r\n\r\nvar\r\n  FixedWidth,\r\n  MaxFixedWidth,\r\n  MinFixedWidth: Integer;\r\n\r\n  //--------------- local function --------------------------------------------\r\n\r\n  procedure ComputeConstraints;\r\n\r\n  var\r\n    I: TColumnIndex;\r\n\r\n  begin\r\n    with FColumns do\r\n    begin\r\n      I := GetFirstVisibleColumn;\r\n      while I > NoColumn do\r\n      begin\r\n        if (coFixed in FColumns[I].Options) and (FColumns[I].Width < FColumns[I].MinWidth) then\r\n          FColumns[I].FWidth := FColumns[I].FMinWidth;\r\n        I := GetNextVisibleColumn(I);\r\n      end;\r\n      FixedWidth := GetVisibleFixedWidth;\r\n    end;\r\n\r\n    with FFixedAreaConstraints do\r\n    begin\r\n      MinFixedWidth := (TreeView.ClientWidth * FMinWidthPercent) div 100;\r\n      MaxFixedWidth := (TreeView.ClientWidth * FMaxWidthPercent) div 100;\r\n    end;\r\n  end;\r\n\r\n  //----------- end local function --------------------------------------------\r\n\r\nbegin\r\n  if ([csLoading, csReading, csWriting, csDestroying] * Treeview.ComponentState = []) and not\r\n     (hsLoading in FStates) and Treeview.HandleAllocated then\r\n  begin\r\n    Include(FStates, hsScaling);\r\n\r\n    SetHeight(FHeight);\r\n    RecalculateHeader;\r\n\r\n    with FFixedAreaConstraints do\r\n      if (FMinHeightPercent > 0) or (FMaxHeightPercent > 0) then\r\n      begin\r\n        ComputeConstraints;\r\n\r\n        with FColumns do\r\n          if (FMaxWidthPercent > 0) and (FixedWidth > MaxFixedWidth) then\r\n            ResizeColumns(MaxFixedWidth - FixedWidth, 0, Count - 1, [coVisible, coFixed])\r\n          else\r\n            if (FMinWidthPercent > 0) and (FixedWidth < MinFixedWidth) then\r\n              ResizeColumns(MinFixedWidth - FixedWidth, 0, Count - 1, [coVisible, coFixed]);\r\n\r\n        FColumns.UpdatePositions;\r\n      end;\r\n\r\n    Exclude(FStates, hsScaling);\r\n    Exclude(FStates, hsNeedScaling);\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TVTHeader.UpdateMainColumn;\r\n\r\n// Called once the load process of the owner tree is done.\r\n\r\nbegin\r\n  if FMainColumn < 0 then\r\n    FMainColumn := 0;\r\n  if FMainColumn > FColumns.Count - 1 then\r\n    FMainColumn := FColumns.Count - 1;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TVTHeader.UpdateSpringColumns;\r\n\r\nvar\r\n  I: TColumnIndex;\r\n  SpringCount: Integer;\r\n  Sign: Integer;\r\n  ChangeBy: Single;\r\n  Difference: Single;\r\n  NewAccumulator: Single;\r\n\r\nbegin\r\n  with TreeView do\r\n    ChangeBy := FHeaderRect.Right - FHeaderRect.Left - FLastWidth;\r\n  if (hoAutoSpring in FOptions) and (FLastWidth <> 0) and (ChangeBy <> 0) then\r\n  begin\r\n    // Stay positive if downsizing the control.\r\n    if ChangeBy < 0 then\r\n      Sign := -1\r\n    else\r\n      Sign := 1;\r\n    ChangeBy := Abs(ChangeBy);\r\n    // Count how many columns have spring enabled.\r\n    SpringCount := 0;\r\n    for I := 0 to FColumns.Count-1 do\r\n      if [coVisible, coAutoSpring] * FColumns[I].FOptions = [coVisible, coAutoSpring] then\r\n        Inc(SpringCount);\r\n    if SpringCount > 0 then\r\n    begin\r\n      // Calculate the size to add/sub to each columns.\r\n      Difference := ChangeBy / SpringCount;\r\n      // Adjust the column's size accumulators and resize if the result is >= 1.\r\n      for I := 0 to FColumns.Count - 1 do\r\n        if [coVisible, coAutoSpring] * FColumns[I].FOptions = [coVisible, coAutoSpring] then\r\n        begin\r\n          // Sum up rest changes from previous runs and the amount from this one and store it in the\r\n          // column. If there is at least one pixel difference then do a resize and reset the accumulator.\r\n          NewAccumulator := FColumns[I].FSpringRest + Difference;\r\n          // Set new width if at least one pixel size difference is reached.\r\n          if NewAccumulator >= 1 then\r\n            FColumns[I].SetWidth(FColumns[I].FWidth + (Trunc(NewAccumulator) * Sign));\r\n          FColumns[I].FSpringRest := Frac(NewAccumulator);\r\n\r\n          // Keep track of the size count.\r\n          ChangeBy := ChangeBy - Difference;\r\n          // Exit loop if resize count drops below freezing point.\r\n          if ChangeBy < 0 then\r\n            Break;\r\n        end;\r\n    end;\r\n  end;\r\n  with TreeView do\r\n    FLastWidth := FHeaderRect.Right - FHeaderRect.Left;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\ntype\r\n  // --- HACK WARNING!\r\n  // This type cast is a partial rewrite of the private section of TWriter. The purpose is to have access to\r\n  // the FPropPath member, which is otherwise not accessible. The reason why this access is needed is that\r\n  // with nested components this member contains unneeded property path information. These information prevent\r\n  // successful load of the stored properties later.\r\n  // In System.Classes.pas you can see that FPropPath is reset several times to '' to prevent this case for certain properies.\r\n  // Unfortunately, there is no clean way for us here to do the same.\r\n  {$hints off}\r\n  TWriterHack = class(TFiler)\r\n  private\r\n    FRootAncestor: TComponent;\r\n    FPropPath: string;\r\n  end;\r\n  {$hints on}\r\n\r\nprocedure TVTHeader.WriteColumns(Writer: TWriter);\r\n\r\n// Write out the columns but take care for the case VT is a nested component.\r\n\r\nvar\r\n  LastPropPath: string;\r\n\r\nbegin\r\n  // Save last property path for restoration.\r\n  LastPropPath := TWriterHack(Writer).FPropPath;\r\n  try\r\n    // If VT is a nested component then this path contains the name of the parent component at this time\r\n    // (otherwise it is already empty). This path is then combined with the property name under which the tree\r\n    // is defined in the parent component. Unfortunately, the load code in System.Classes.pas does not consider this case\r\n    // is then unable to load this property.\r\n    TWriterHack(Writer).FPropPath := '';\r\n    Writer.WriteCollection(Columns);\r\n  finally\r\n    TWriterHack(Writer).FPropPath := LastPropPath;\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TVTHeader.AllowFocus(ColumnIndex: TColumnIndex): Boolean;\r\nbegin\r\n  Result := False;\r\n  if not FColumns.IsValidColumn(ColumnIndex) then\r\n    Exit; // Just in case.\r\n\r\n  Result := (coAllowFocus in FColumns[ColumnIndex].Options);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TVTHeader.Assign(Source: TPersistent);\r\n\r\nbegin\r\n  if Source is TVTHeader then\r\n  begin\r\n    AutoSizeIndex := TVTHeader(Source).AutoSizeIndex;\r\n    Background := TVTHeader(Source).Background;\r\n    Columns := TVTHeader(Source).Columns;\r\n    Font := TVTHeader(Source).Font;\r\n    FixedAreaConstraints.Assign(TVTHeader(Source).FixedAreaConstraints);\r\n    Height := TVTHeader(Source).Height;\r\n    Images := TVTHeader(Source).Images;\r\n    MainColumn := TVTHeader(Source).MainColumn;\r\n    Options := TVTHeader(Source).Options;\r\n    ParentFont := TVTHeader(Source).ParentFont;\r\n    PopupMenu := TVTHeader(Source).PopupMenu;\r\n    SortColumn := TVTHeader(Source).SortColumn;\r\n    SortDirection := TVTHeader(Source).SortDirection;\r\n    Style := TVTHeader(Source).Style;\r\n\r\n    RescaleHeader;\r\n  end\r\n  else\r\n    inherited;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TVTHeader.AutoFitColumns(Animated: Boolean = True; SmartAutoFitType: TSmartAutoFitType = smaUseColumnOption;\r\n  RangeStartCol: Integer = NoColumn; RangeEndCol: Integer = NoColumn);\r\n\r\n  //--------------- local functions -------------------------------------------\r\n\r\n  function GetUseSmartColumnWidth(ColumnIndex: TColumnIndex): Boolean;\r\n\r\n  begin\r\n    Result := False;\r\n    case SmartAutoFitType of\r\n      smaAllColumns:\r\n        Result := True;\r\n      smaNoColumn:\r\n        Result := False;\r\n      smaUseColumnOption:\r\n        Result := coSmartResize in FColumns.Items[ColumnIndex].FOptions;\r\n    end;\r\n  end;\r\n\r\n  //----------------------------------------------------------------------------\r\n\r\n  procedure DoAutoFitColumn(Column: TColumnIndex);\r\n\r\n  begin\r\n    with FColumns do\r\n      if ([coResizable, coVisible] * Items[FPositionToIndex[Column]].FOptions = [coResizable, coVisible]) and\r\n            DoBeforeAutoFitColumn(FPositionToIndex[Column], SmartAutoFitType) and not TreeView.OperationCanceled then\r\n      begin\r\n        if Animated then\r\n          AnimatedResize(FPositionToIndex[Column], Treeview.GetMaxColumnWidth(FPositionToIndex[Column],\r\n            GetUseSmartColumnWidth(FPositionToIndex[Column])))\r\n        else\r\n          FColumns[FPositionToIndex[Column]].Width := Treeview.GetMaxColumnWidth(FPositionToIndex[Column],\r\n            GetUseSmartColumnWidth(FPositionToIndex[Column]));\r\n\r\n        DoAfterAutoFitColumn(FPositionToIndex[Column]);\r\n      end;\r\n  end;\r\n\r\n  //--------------- end local functions ----------------------------------------\r\n\r\nvar\r\n  I: Integer;\r\n  StartCol,\r\n  EndCol: Integer;\r\n\r\nbegin\r\n  StartCol := Max(NoColumn + 1, RangeStartCol);\r\n\r\n  if RangeEndCol <= NoColumn then\r\n    EndCol := FColumns.Count - 1\r\n  else\r\n    EndCol := Min(RangeEndCol, FColumns.Count - 1);\r\n\r\n  if StartCol > EndCol then\r\n    Exit; // nothing to do\r\n\r\n  TreeView.StartOperation(okAutoFitColumns);\r\n  try\r\n    if Assigned(TreeView.FOnBeforeAutoFitColumns) then\r\n      TreeView.FOnBeforeAutoFitColumns(Self, SmartAutoFitType);\r\n\r\n    for I := StartCol to EndCol do\r\n      DoAutoFitColumn(I);\r\n\r\n    if Assigned(TreeView.FOnAfterAutoFitColumns) then\r\n      TreeView.FOnAfterAutoFitColumns(Self);\r\n\r\n  finally\r\n    Treeview.EndOperation(okAutoFitColumns);\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TVTHeader.InHeader(P: TPoint): Boolean;\r\n\r\n// Determines whether the given point (client coordinates!) is within the header rectangle (non-client coordinates).\r\n\r\nvar\r\n  R, RW: TRect;\r\n\r\nbegin\r\n  R := Treeview.FHeaderRect;\r\n\r\n  // Current position of the owner in screen coordinates.\r\n  GetWindowRect(Treeview.Handle, RW);\r\n\r\n  // Convert to client coordinates.\r\n  MapWindowPoints(0, Treeview.Handle, RW, 2);\r\n\r\n  // Consider the header within this rectangle.\r\n  OffsetRect(R, RW.Left, RW.Top);\r\n  Result := PtInRect(R, P);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TVTHeader.InHeaderSplitterArea(P: TPoint): Boolean;\r\n\r\n// Determines whether the given point (client coordinates!) hits the horizontal splitter area of the header.\r\n\r\nvar\r\n  R, RW: TRect;\r\n\r\nbegin\r\n  if (P.Y > 2) or (P.Y < -2) or not (hoVisible in FOptions) then\r\n    Result := False\r\n  else\r\n  begin\r\n    R := Treeview.FHeaderRect;\r\n    Inc(R.Bottom, 2);\r\n\r\n    // Current position of the owner in screen coordinates.\r\n    GetWindowRect(Treeview.Handle, RW);\r\n\r\n    // Convert to client coordinates.\r\n    MapWindowPoints(0, Treeview.Handle, RW, 2);\r\n\r\n    // Consider the header within this rectangle.\r\n    OffsetRect(R, RW.Left, RW.Top);\r\n    Result := PtInRect(R, P);\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TVTHeader.Invalidate(Column: TVirtualTreeColumn; ExpandToBorder: Boolean = False);\r\n\r\n// Because the header is in the non-client area of the tree it needs some special handling in order to initiate its\r\n// repainting.\r\n// If ExpandToBorder is True then not only the given column but everything or (depending on hoFullRepaintOnResize) just\r\n// everything to its right (or left, in RTL mode) will be invalidated (useful for resizing). This makes only sense when\r\n// a column is given.\r\n\r\nvar\r\n  R, RW: TRect;\r\n\r\nbegin\r\n  if (hoVisible in FOptions) and Treeview.HandleAllocated then\r\n    with Treeview do\r\n    begin\r\n      if Column = nil then\r\n        R := FHeaderRect\r\n      else\r\n      begin\r\n        R := Column.GetRect;\r\n        if not (coFixed in Column.Options) then\r\n          OffsetRect(R, -FEffectiveOffsetX, 0);\r\n        if UseRightToLeftAlignment then\r\n          OffsetRect(R, ComputeRTLOffset, 0);\r\n        if ExpandToBorder then\r\n        begin\r\n          if (hoFullRepaintOnResize in FHeader.FOptions) then\r\n          begin\r\n            R.Left := FHeaderRect.Left;\r\n            R.Right := FHeaderRect.Right;\r\n          end\r\n          else\r\n          begin\r\n            if UseRightToLeftAlignment then\r\n              R.Left := FHeaderRect.Left\r\n            else\r\n              R.Right := FHeaderRect.Right;\r\n          end;\r\n        end;\r\n      end;\r\n\r\n      // Current position of the owner in screen coordinates.\r\n      GetWindowRect(Handle, RW);\r\n\r\n      // Consider the header within this rectangle.\r\n      OffsetRect(R, RW.Left, RW.Top);\r\n\r\n      // Expressed in client coordinates (because RedrawWindow wants them so, they will actually become negative).\r\n      MapWindowPoints(0, Handle, R, 2);\r\n      RedrawWindow(Handle, @R, 0, RDW_FRAME or RDW_INVALIDATE or RDW_VALIDATE or RDW_NOINTERNALPAINT or\r\n        RDW_NOERASE or RDW_NOCHILDREN);\r\n    end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TVTHeader.LoadFromStream(const Stream: TStream);\r\n\r\n// restore the state of the header from the given stream\r\n\r\nvar\r\n  Dummy,\r\n  Version: Integer;\r\n  S: AnsiString;\r\n  OldOptions: TVTHeaderOptions;\r\n\r\nbegin\r\n  Include(FStates, hsLoading);\r\n  with Stream do\r\n  try\r\n    // Switch off all options which could influence loading the columns (they will be later set again).\r\n    OldOptions := FOptions;\r\n    FOptions := [];\r\n\r\n    // Determine whether the stream contains data without a version number.\r\n    ReadBuffer(Dummy, SizeOf(Dummy));\r\n    if Dummy > -1 then\r\n    begin\r\n      // Seek back to undo the read operation if this is an old stream format.\r\n      Seek(-SizeOf(Dummy), soFromCurrent);\r\n      Version := -1;\r\n    end\r\n    else // Read version number if this is a \"versionized\" format.\r\n      ReadBuffer(Version, SizeOf(Version));\r\n    Columns.LoadFromStream(Stream, Version);\r\n\r\n    ReadBuffer(Dummy, SizeOf(Dummy));\r\n    AutoSizeIndex := Dummy;\r\n    ReadBuffer(Dummy, SizeOf(Dummy));\r\n    Background := Dummy;\r\n    ReadBuffer(Dummy, SizeOf(Dummy));\r\n    Height := Dummy;\r\n    ReadBuffer(Dummy, SizeOf(Dummy));\r\n    FOptions := OldOptions;\r\n    Options := TVTHeaderOptions(Dummy);\r\n    // PopupMenu is neither saved nor restored\r\n    ReadBuffer(Dummy, SizeOf(Dummy));\r\n    Style := TVTHeaderStyle(Dummy);\r\n    // TFont has no own save routine so we do it manually\r\n    with Font do\r\n    begin\r\n      ReadBuffer(Dummy, SizeOf(Dummy));\r\n      Color := Dummy;\r\n      ReadBuffer(Dummy, SizeOf(Dummy));\r\n      Height := Dummy;\r\n      ReadBuffer(Dummy, SizeOf(Dummy));\r\n      SetLength(S, Dummy);\r\n      ReadBuffer(PAnsiChar(S)^, Dummy);\r\n      Name := UTF8ToString(S);\r\n      ReadBuffer(Dummy, SizeOf(Dummy));\r\n      Pitch := TFontPitch(Dummy);\r\n      ReadBuffer(Dummy, SizeOf(Dummy));\r\n      Style := TFontStyles(Byte(Dummy));\r\n    end;\r\n\r\n    // Read data introduced by stream version 1+.\r\n    if Version > 0 then\r\n    begin\r\n      ReadBuffer(Dummy, SizeOf(Dummy));\r\n      MainColumn := Dummy;\r\n      ReadBuffer(Dummy, SizeOf(Dummy));\r\n      SortColumn := Dummy;\r\n      ReadBuffer(Dummy, SizeOf(Dummy));\r\n      SortDirection := TSortDirection(Byte(Dummy));\r\n    end;\r\n\r\n    // Read data introduced by stream version 5+.\r\n    if Version > 4 then\r\n    begin\r\n      ReadBuffer(Dummy, SizeOf(Dummy));\r\n      ParentFont := Boolean(Dummy);\r\n      ReadBuffer(Dummy, SizeOf(Dummy));\r\n      FMaxHeight := Integer(Dummy);\r\n      ReadBuffer(Dummy, SizeOf(Dummy));\r\n      FMinHeight := Integer(Dummy);\r\n      ReadBuffer(Dummy, SizeOf(Dummy));\r\n      FDefaultHeight := Integer(Dummy);\r\n      with FFixedAreaConstraints do\r\n      begin\r\n        ReadBuffer(Dummy, SizeOf(Dummy));\r\n        FMaxHeightPercent := TVTConstraintPercent(Dummy);\r\n        ReadBuffer(Dummy, SizeOf(Dummy));\r\n        FMaxWidthPercent := TVTConstraintPercent(Dummy);\r\n        ReadBuffer(Dummy, SizeOf(Dummy));\r\n        FMinHeightPercent := TVTConstraintPercent(Dummy);\r\n        ReadBuffer(Dummy, SizeOf(Dummy));\r\n        FMinWidthPercent := TVTConstraintPercent(Dummy);\r\n      end;\r\n    end;\r\n  finally\r\n    Exclude(FStates, hsLoading);\r\n    Treeview.DoColumnResize(NoColumn);\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TVTHeader.ResizeColumns(ChangeBy: Integer; RangeStartCol: TColumnIndex; RangeEndCol: TColumnIndex;\r\n  Options: TVTColumnOptions = [coVisible]): Integer;\r\n\r\n// Distribute the given width change to a range of columns. A 'fair' way is used to distribute ChangeBy to the columns,\r\n// while ensuring that everything that can be distributed will be distributed.\r\n\r\nvar\r\n  Start,\r\n  I: TColumnIndex;\r\n  ColCount,\r\n  ToGo,\r\n  Sign,\r\n  Rest,\r\n  MaxDelta,\r\n  Difference: Integer;\r\n  Constraints,\r\n  Widths: array of Integer;\r\n  BonusPixel: Boolean;\r\n\r\n  //--------------- local functions -------------------------------------------\r\n\r\n  function IsResizable (Column: TColumnIndex): Boolean;\r\n\r\n  begin\r\n    if BonusPixel then\r\n      Result := Widths[Column - RangeStartCol] < Constraints[Column - RangeStartCol]\r\n    else\r\n      Result := Widths[Column - RangeStartCol] > Constraints[Column - RangeStartCol];\r\n  end;\r\n\r\n  //---------------------------------------------------------------------------\r\n\r\n  procedure IncDelta(Column: TColumnIndex);\r\n\r\n  begin\r\n    if BonusPixel then\r\n      Inc(MaxDelta, FColumns[Column].MaxWidth - Widths[Column - RangeStartCol])\r\n    else\r\n      Inc(MaxDelta, Widths[Column - RangeStartCol] - Constraints[Column - RangeStartCol]);\r\n  end;\r\n\r\n  //---------------------------------------------------------------------------\r\n\r\n  function ChangeWidth(Column: TColumnIndex; Delta: Integer): Integer;\r\n\r\n  begin\r\n    if Delta > 0 then\r\n      Delta := Min(Delta, Constraints[Column - RangeStartCol] - Widths[Column - RangeStartCol])\r\n    else\r\n      Delta := Max(Delta, Constraints[Column - RangeStartCol] - Widths[Column - RangeStartCol]);\r\n\r\n    Inc(Widths[Column - RangeStartCol], Delta);\r\n    Dec(ToGo, Abs(Delta));\r\n    Result := Abs(Delta);\r\n  end;\r\n\r\n  //---------------------------------------------------------------------------\r\n\r\n  function ReduceConstraints: Boolean;\r\n\r\n  var\r\n    MaxWidth,\r\n    MaxReserveCol,\r\n    Column: TColumnIndex;\r\n\r\n  begin\r\n    Result := True;\r\n    if not (hsScaling in FStates) or BonusPixel then\r\n      Exit;\r\n\r\n    MaxWidth := 0;\r\n    MaxReserveCol := NoColumn;\r\n    for Column := RangeStartCol to RangeEndCol do\r\n      if (Options * FColumns[Column].FOptions = Options) and\r\n         (FColumns[Column].FWidth > MaxWidth) then\r\n      begin\r\n        MaxWidth := Widths[Column - RangeStartCol];\r\n        MaxReserveCol := Column;\r\n      end;\r\n\r\n    if (MaxReserveCol <= NoColumn) or (Constraints[MaxReserveCol - RangeStartCol] <= 10) then\r\n      Result := False\r\n    else\r\n      Dec(Constraints[MaxReserveCol - RangeStartCol],\r\n          Constraints[MaxReserveCol - RangeStartCol] div 10);\r\n  end;\r\n\r\n  //----------- end local functions -------------------------------------------\r\n\r\nbegin\r\n  Result := 0;\r\n  if ChangeBy <> 0 then\r\n  begin\r\n    // Do some initialization here\r\n    BonusPixel := ChangeBy > 0;\r\n    Sign := IfThen(BonusPixel, 1, -1);\r\n    Start := IfThen(BonusPixel, RangeStartCol, RangeEndCol);\r\n    ToGo := Abs(ChangeBy);\r\n    SetLength(Widths, RangeEndCol - RangeStartCol + 1);\r\n    SetLength(Constraints, RangeEndCol - RangeStartCol + 1);\r\n    for I := RangeStartCol to RangeEndCol do\r\n    begin\r\n      Widths[I - RangeStartCol] := FColumns[I].FWidth;\r\n      Constraints[I - RangeStartCol] := IfThen(BonusPixel, FColumns[I].MaxWidth, FColumns[I].MinWidth);\r\n    end;\r\n\r\n    repeat\r\n      repeat\r\n        MaxDelta := 0;\r\n        ColCount := 0;\r\n        for I := RangeStartCol to RangeEndCol do\r\n          if (Options * FColumns[I].FOptions = Options) and IsResizable(I) then\r\n          begin\r\n            Inc(ColCount);\r\n            IncDelta(I);\r\n          end;\r\n        if MaxDelta < Abs(ChangeBy) then\r\n          if not ReduceConstraints then\r\n            Break;\r\n      until (MaxDelta >= Abs(ChangeBy)) or not (hsScaling in FStates);\r\n\r\n      if ColCount = 0 then\r\n        Break;\r\n\r\n      ToGo := Min(ToGo, MaxDelta);\r\n      Difference := ToGo div ColCount;\r\n      Rest := ToGo mod ColCount;\r\n\r\n      if Difference > 0 then\r\n        for I := RangeStartCol to RangeEndCol do\r\n          if (Options * FColumns[I].FOptions = Options) and IsResizable(I) then\r\n            ChangeWidth(I, Difference * Sign);\r\n\r\n      // Now distribute Rest.\r\n      I := Start;\r\n      while Rest > 0 do\r\n      begin\r\n        if (Options * FColumns[I].FOptions = Options) and IsResizable(I) then\r\n          if FColumns[I].FBonusPixel <> BonusPixel then\r\n          begin\r\n            Dec(Rest, ChangeWidth(I, Sign));\r\n            FColumns[I].FBonusPixel := BonusPixel;\r\n          end;\r\n        Inc(I, Sign);\r\n        if (BonusPixel and (I > RangeEndCol)) or (not BonusPixel and (I < RangeStartCol)) then\r\n        begin\r\n          for I := RangeStartCol to RangeEndCol do\r\n            if Options * FColumns[I].FOptions = Options then\r\n              FColumns[I].FBonusPixel := not FColumns[I].FBonusPixel;\r\n          I := Start;\r\n        end;\r\n      end;\r\n    until ToGo <= 0;\r\n\r\n    // Now set the computed widths. We also compute the result here.\r\n    Include(FStates, hsResizing);\r\n    for I := RangeStartCol to RangeEndCol do\r\n      if (Options * FColumns[I].FOptions = Options) then\r\n      begin\r\n        Inc(Result, Widths[I - RangeStartCol] - FColumns[I].FWidth);\r\n        FColumns[I].SetWidth(Widths[I - RangeStartCol]);\r\n      end;\r\n    Exclude(FStates, hsResizing);\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TVTHeader.RestoreColumns;\r\n\r\n// Restores all columns to their width which they had before they have been auto fitted.\r\n\r\nvar\r\n  I: TColumnIndex;\r\n\r\nbegin\r\n  with FColumns do\r\n    for I := Count - 1 downto 0 do\r\n      if [coResizable, coVisible] * Items[FPositionToIndex[I]].FOptions = [coResizable, coVisible] then\r\n        Items[I].RestoreLastWidth;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TVTHeader.SaveToStream(const Stream: TStream);\r\n\r\n// Saves the complete state of the header into the provided stream.\r\n\r\nvar\r\n  Dummy: Integer;\r\n  Tmp: AnsiString;\r\n\r\nbegin\r\n  with Stream do\r\n  begin\r\n    // In previous version of VT was no header stream version defined.\r\n    // For feature enhancements it is necessary, however, to know which stream\r\n    // format we are trying to load.\r\n    // In order to distict from non-version streams an indicator is inserted.\r\n    Dummy := -1;\r\n    WriteBuffer(Dummy, SizeOf(Dummy));\r\n    // Write current stream version number, nothing more is required at the time being.\r\n    Dummy := VTHeaderStreamVersion;\r\n    WriteBuffer(Dummy, SizeOf(Dummy));\r\n\r\n    // Save columns in case they depend on certain options (like auto size).\r\n    Columns.SaveToStream(Stream);\r\n\r\n    Dummy := FAutoSizeIndex;\r\n    WriteBuffer(Dummy, SizeOf(Dummy));\r\n    Dummy := FBackgroundColor;\r\n    WriteBuffer(Dummy, SizeOf(Dummy));\r\n    Dummy := FHeight;\r\n    WriteBuffer(Dummy, SizeOf(Dummy));\r\n    Dummy := Integer(FOptions);\r\n    WriteBuffer(Dummy, SizeOf(Dummy));\r\n    // PopupMenu is neither saved nor restored\r\n    Dummy := Ord(FStyle);\r\n    WriteBuffer(Dummy, SizeOf(Dummy));\r\n    // TFont has no own save routine so we do it manually\r\n    with Font do\r\n    begin\r\n      Dummy := Color;\r\n      WriteBuffer(Dummy, SizeOf(Dummy));\r\n\r\n      // Need only to write one: size or height, I decided to write height.\r\n      Dummy := Height;\r\n      WriteBuffer(Dummy, SizeOf(Dummy));\r\n      Tmp := UTF8Encode(Name);\r\n      Dummy := Length(Tmp);\r\n      WriteBuffer(Dummy, SizeOf(Dummy));\r\n      WriteBuffer(PAnsiChar(Tmp)^, Dummy);\r\n      Dummy := Ord(Pitch);\r\n      WriteBuffer(Dummy, SizeOf(Dummy));\r\n      Dummy := Byte(Style);\r\n      WriteBuffer(Dummy, SizeOf(Dummy));\r\n    end;\r\n\r\n    // Data introduced by stream version 1.\r\n    Dummy := FMainColumn;\r\n    WriteBuffer(Dummy, SizeOf(Dummy));\r\n    Dummy := FSortColumn;\r\n    WriteBuffer(Dummy, SizeOf(Dummy));\r\n    Dummy := Byte(FSortDirection);\r\n    WriteBuffer(Dummy, SizeOf(Dummy));\r\n\r\n    // Data introduced by stream version 5.\r\n    Dummy := Integer(ParentFont);\r\n    WriteBuffer(Dummy, SizeOf(Dummy));\r\n    Dummy := Integer(FMaxHeight);\r\n    WriteBuffer(Dummy, SizeOf(Dummy));\r\n    Dummy := Integer(FMinHeight);\r\n    WriteBuffer(Dummy, SizeOf(Dummy));\r\n    Dummy := Integer(FDefaultHeight);\r\n    WriteBuffer(Dummy, SizeOf(Dummy));\r\n    with FFixedAreaConstraints do\r\n    begin\r\n      Dummy := Integer(FMaxHeightPercent);\r\n      WriteBuffer(Dummy, SizeOf(Dummy));\r\n      Dummy := Integer(FMaxWidthPercent);\r\n      WriteBuffer(Dummy, SizeOf(Dummy));\r\n      Dummy := Integer(FMinHeightPercent);\r\n      WriteBuffer(Dummy, SizeOf(Dummy));\r\n      Dummy := Integer(FMinWidthPercent);\r\n      WriteBuffer(Dummy, SizeOf(Dummy));\r\n    end;\r\n  end;\r\nend;\r\n\r\n//----------------- TScrollBarOptions ----------------------------------------------------------------------------------\r\n\r\nconstructor TScrollBarOptions.Create(AOwner: TBaseVirtualTree);\r\n\r\nbegin\r\n  inherited Create;\r\n\r\n  FOwner := AOwner;\r\n  FAlwaysVisible := False;\r\n  FScrollBarStyle := sbmRegular;\r\n  FScrollBars := ssBoth;\r\n  FIncrementX := 20;\r\n  FIncrementY := 20;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TScrollBarOptions.SetAlwaysVisible(Value: Boolean);\r\n\r\nbegin\r\n  if FAlwaysVisible <> Value then\r\n  begin\r\n    FAlwaysVisible := Value;\r\n    if not (csLoading in FOwner.ComponentState) and FOwner.HandleAllocated then\r\n      FOwner.RecreateWnd;\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TScrollBarOptions.SetScrollBars(Value: TScrollStyle);\r\n\r\nbegin\r\n  if FScrollBars <> Value then\r\n  begin\r\n    FScrollBars := Value;\r\n    if not (csLoading in FOwner.ComponentState) and FOwner.HandleAllocated then\r\n      FOwner.RecreateWnd;\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TScrollBarOptions.SetScrollBarStyle(Value: TScrollBarStyle);\r\n\r\nbegin\r\n  if FScrollBarStyle <> Value then\r\n  begin\r\n    FScrollBarStyle := Value;\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TScrollBarOptions.GetOwner: TPersistent;\r\n\r\nbegin\r\n  Result := FOwner;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TScrollBarOptions.Assign(Source: TPersistent);\r\n\r\nbegin\r\n  if Source is TScrollBarOptions then\r\n  begin\r\n    AlwaysVisible := TScrollBarOptions(Source).AlwaysVisible;\r\n    HorizontalIncrement := TScrollBarOptions(Source).HorizontalIncrement;\r\n    ScrollBars := TScrollBarOptions(Source).ScrollBars;\r\n    ScrollBarStyle := TScrollBarOptions(Source).ScrollBarStyle;\r\n    VerticalIncrement := TScrollBarOptions(Source).VerticalIncrement;\r\n  end\r\n  else\r\n    inherited;\r\nend;\r\n\r\n//----------------- TVTColors ------------------------------------------------------------------------------------------\r\n\r\nconstructor TVTColors.Create(AOwner: TBaseVirtualTree);\r\n\r\nbegin\r\n  FOwner := AOwner;\r\n  FColors[0] := clBtnShadow;      // DisabledColor\r\n  FColors[1] := clHighlight;      // DropMarkColor\r\n  FColors[2] := clHighLight;      // DropTargetColor\r\n  FColors[3] := clHighLight;      // FocusedSelectionColor\r\n  FColors[4] := clBtnFace;        // GridLineColor\r\n  FColors[5] := clBtnShadow;      // TreeLineColor\r\n  FColors[6] := clBtnFace;        // UnfocusedSelectionColor\r\n  FColors[7] := clBtnFace;        // BorderColor\r\n  FColors[8] := clWindowText;     // HotColor\r\n  FColors[9] := clHighLight;      // FocusedSelectionBorderColor\r\n  FColors[10] := clBtnFace;       // UnfocusedSelectionBorderColor\r\n  FColors[11] := clHighlight;     // DropTargetBorderColor\r\n  FColors[12] := clHighlight;     // SelectionRectangleBlendColor\r\n  FColors[13] := clHighlight;     // SelectionRectangleBorderColor\r\n  FColors[14] := clBtnShadow;     // HeaderHotColor\r\n  FColors[15] := clHighlightText; // SelectionTextColor\r\n  FColors[16] := clBtnFace;       // UnfocusedColor  [IPK]\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TVTColors.GetBackgroundColor: TColor;\r\nbegin\r\n// XE2 VCL Style\r\n  if FOwner.VclStyleEnabled and (seClient in FOwner.StyleElements) then\r\n    Result := StyleServices.GetStyleColor(scTreeView)\r\n  else\r\n    Result := FOwner.Color;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TVTColors.GetColor(const Index: Integer): TColor;\r\n\r\nbegin\r\n  if FOwner.VclStyleEnabled  then\r\n  begin\r\n    case Index of\r\n      0:\r\n        StyleServices.GetElementColor(StyleServices.GetElementDetails(ttItemDisabled), ecTextColor, Result); // DisabledColor\r\n      1, 2, 3, 6, 10, 12, 13:\r\n        Result := StyleServices.GetSystemColor(clHighlight); // 1:DropMarkColor 2:DropTargetColor 3: FocusedSelectionColor\r\n                                                             // 6:UnfocusedSelectionColor 10:UnfocusedSelectionBorderColor\r\n                                                             // 12:SelectionRectangleBlendColor 13:SelectionRectangleBorderColor\r\n      4:\r\n        Result := StyleServices.GetSystemColor(clBtnFace); // GridLineColor\r\n      5:\r\n        StyleServices.GetElementColor(StyleServices.GetElementDetails(ttBranch), ecBorderColor, Result); // TreeLineColor\r\n      7:\r\n        if not (seBorder in FOwner.StyleElements) then\r\n          Result := FColors[Index]\r\n        else\r\n         Result := StyleServices.GetSystemColor(clBtnFace); // BorderColor\r\n      8:\r\n        if not StyleServices.GetElementColor(StyleServices.GetElementDetails(ttItemHot), ecTextColor, Result) or\r\n          (Result <> clWindowText) then\r\n          Result := NodeFontColor; // HotColor\r\n      9:\r\n        StyleServices.GetElementColor(StyleServices.GetElementDetails(ttItemSelected), ecFillColor, Result);\r\n      // FocusedSelectionBorderColor\r\n      11:\r\n        Result := StyleServices.GetSystemColor(clBtnFace); // DropTargetBorderColor\r\n      14:\r\n        StyleServices.GetElementColor(StyleServices.GetElementDetails(thHeaderItemNormal), ecTextColor, Result); // HeaderHotColor\r\n      15:\r\n        if not StyleServices.GetElementColor(StyleServices.GetElementDetails(ttItemSelected), ecTextColor, Result) or\r\n          (Result <> clWindowText) then\r\n          Result := NodeFontColor; // SelectionTextColor\r\n    end;\r\n  end\r\n  else\r\n    Result := FColors[Index];\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TVTColors.GetHeaderFontColor: TColor;\r\nbegin\r\n// XE2+ VCL Style\r\n  if FOwner.VclStyleEnabled and (seFont in FOwner.StyleElements) then\r\n    StyleServices.GetElementColor(StyleServices.GetElementDetails(thHeaderItemNormal), ecTextColor, Result)\r\n  else\r\n    Result := FOwner.FHeader.Font.Color;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TVTColors.GetNodeFontColor: TColor;\r\nbegin\r\n  if FOwner.VclStyleEnabled and (seFont in FOwner.StyleElements) then\r\n    StyleServices.GetElementColor(StyleServices.GetElementDetails(ttItemNormal), ecTextColor, Result)\r\n  else\r\n    Result := FOwner.Font.Color;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TVTColors.SetColor(const Index: Integer; const Value: TColor);\r\n\r\nbegin\r\n  if FColors[Index] <> Value then\r\n  begin\r\n    FColors[Index] := Value;\r\n    if not (csLoading in FOwner.ComponentState) and FOwner.HandleAllocated then\r\n    begin\r\n      // Cause helper bitmap rebuild if the button color changed.\r\n      case Index of\r\n        5:\r\n          begin\r\n            FOwner.PrepareBitmaps(True, False);\r\n            FOwner.Invalidate;\r\n          end;\r\n        7:\r\n          RedrawWindow(FOwner.Handle, nil, 0, RDW_FRAME or RDW_INVALIDATE or RDW_NOERASE or RDW_NOCHILDREN)\r\n      else\r\n        FOwner.Invalidate;\r\n      end;\r\n    end;\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TVTColors.Assign(Source: TPersistent);\r\n\r\nbegin\r\n  if Source is TVTColors then\r\n  begin\r\n    FColors := TVTColors(Source).FColors;\r\n    if FOwner.FUpdateCount = 0 then\r\n      FOwner.Invalidate;\r\n  end\r\n  else\r\n    inherited;\r\nend;\r\n\r\n//----------------- TClipboardFormats ----------------------------------------------------------------------------------\r\n\r\nconstructor TClipboardFormats.Create(AOwner: TBaseVirtualTree);\r\n\r\nbegin\r\n  FOwner := AOwner;\r\n  Sorted := True;\r\n  Duplicates := dupIgnore;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TClipboardFormats.Add(const S: string): Integer;\r\n\r\n// Restrict additions to the clipbard formats to only those which are registered with the owner tree or one of its\r\n// ancestors.\r\n\r\nvar\r\n  Format: Word;\r\n  RegisteredClass: TVirtualTreeClass;\r\n\r\nbegin\r\n  RegisteredClass := TClipboardFormatList.FindFormat(S, Format);\r\n  if Assigned(RegisteredClass) and FOwner.ClassType.InheritsFrom(RegisteredClass) then\r\n    Result := inherited Add(S)\r\n  else\r\n    Result := -1;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TClipboardFormats.Insert(Index: Integer; const S: string);\r\n\r\n// Restrict additions to the clipbard formats to only those which are registered with the owner tree or one of its\r\n// ancestors.\r\n\r\nvar\r\n  Format: Word;\r\n  RegisteredClass: TVirtualTreeClass;\r\n\r\nbegin\r\n  RegisteredClass := TClipboardFormatList.FindFormat(S, Format);\r\n  if Assigned(RegisteredClass) and FOwner.ClassType.InheritsFrom(RegisteredClass) then\r\n    inherited Insert(Index, S);\r\nend;\r\n\r\n//----------------- TBaseVirtualTree -----------------------------------------------------------------------------------\r\n\r\nconstructor TBaseVirtualTree.Create(AOwner: TComponent);\r\n\r\nbegin\r\n  if not Initialized then\r\n    InitializeGlobalStructures;\r\n\r\n  inherited;\r\n\r\n  ControlStyle := ControlStyle - [csSetCaption] + [csCaptureMouse, csOpaque, csReplicatable, csDisplayDragImage,\r\n    csReflector];\r\n  FTotalInternalDataSize := 0;\r\n  FNodeDataSize := -1;\r\n  Width := 200;\r\n  Height := 100;\r\n  TabStop := True;\r\n  ParentColor := False;\r\n  FDefaultNodeHeight := 18;\r\n  FDragOperations := [doCopy, doMove];\r\n  FHotCursor := crDefault;\r\n  FScrollBarOptions := TScrollBarOptions.Create(Self);\r\n  FFocusedColumn := NoColumn;\r\n  FDragImageKind := diComplete;\r\n  FLastSelectionLevel := -1;\r\n  FAnimationType := hatSystemDefault;\r\n  FSelectionBlendFactor := 128;\r\n\r\n  FIndent := 18;\r\n\r\n  FPlusBM := TBitmap.Create;\r\n  FHotPlusBM := TBitmap.Create;\r\n  FMinusBM := TBitmap.Create;\r\n  FHotMinusBM := TBitmap.Create;\r\n  FSelectedHotPlusBM := TBitmap.Create;\r\n  FSelectedHotMinusBM := TBitmap.Create;\r\n\r\n  FBorderStyle := bsSingle;\r\n  FButtonStyle := bsRectangle;\r\n  FButtonFillMode := fmTreeColor;\r\n\r\n  FHeader := GetHeaderClass.Create(Self);\r\n\r\n  // we have an own double buffer handling\r\n  inherited DoubleBuffered := False;\r\n\r\n  FCheckImageKind := ckSystemDefault;\r\n  FCheckImages := SystemCheckImages;\r\n\r\n  FImageChangeLink := TChangeLink.Create;\r\n  FImageChangeLink.OnChange := ImageListChange;\r\n  FStateChangeLink := TChangeLink.Create;\r\n  FStateChangeLink.OnChange := ImageListChange;\r\n  FCustomCheckChangeLink := TChangeLink.Create;\r\n  FCustomCheckChangeLink.OnChange := ImageListChange;\r\n\r\n  FAutoExpandDelay := 1000;\r\n  FAutoScrollDelay := 1000;\r\n  FAutoScrollInterval := 1;\r\n\r\n  FBackground := TPicture.Create;\r\n\r\n  FDefaultPasteMode := amAddChildLast;\r\n  FMargin := 4;\r\n  FTextMargin := 4;\r\n  FLastDragEffect := DROPEFFECT_NONE;\r\n  FDragType := dtOLE;\r\n  FDragHeight := 350;\r\n  FDragWidth := 200;\r\n\r\n  FColors := TVTColors.Create(Self);\r\n  FEditDelay := 1000;\r\n\r\n  FDragImage := TVTDragImage.Create(Self);\r\n  with FDragImage do\r\n  begin\r\n    Fade := True;\r\n    PostBlendBias := 0;\r\n    PreBlendBias := 0;\r\n    Transparency := 200;\r\n  end;\r\n\r\n  SetLength(FSingletonNodeArray, 1);\r\n  FAnimationDuration := 200;\r\n  FSearchTimeout := 1000;\r\n  FSearchStart := ssFocusedNode;\r\n  FNodeAlignment := naProportional;\r\n  FLineStyle := lsDotted;\r\n  FIncrementalSearch := isNone;\r\n  FClipboardFormats := TClipboardFormats.Create(Self);\r\n  FOptions := GetOptionsClass.Create(Self);\r\n\r\n  if not (csDesigning in ComponentState) then //Don't cerate worker thread in IDE, there is no use for it\r\n    AddThreadReference;\r\n  VclStyleChanged();\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\ndestructor TBaseVirtualTree.Destroy;\r\n\r\nbegin\r\n  InterruptValidation();\r\n  Exclude(FOptions.FMiscOptions, toReadOnly);\r\n  ReleaseThreadReference(Self);\r\n  StopWheelPanning;\r\n  CancelEditNode;\r\n\r\n  // Just in case it didn't happen already release the edit link.\r\n  FEditLink := nil;\r\n  FClipboardFormats.Free;\r\n  // Clear will also free the drag manager if it is still alive.\r\n  Clear;\r\n  FDragImage.Free;\r\n  FColors.Free;\r\n  FBackground.Free;\r\n  FImageChangeLink.Free;\r\n  FStateChangeLink.Free;\r\n  FCustomCheckChangeLink.Free;\r\n  FScrollBarOptions.Free;\r\n\r\n  // The window handle must be destroyed before the header is freed because it is needed in WM_NCDESTROY.\r\n  if HandleAllocated then\r\n    DestroyWindowHandle;\r\n\r\n  // Release FDottedBrush in case WM_NCDESTROY hasn't been triggered.\r\n  if FDottedBrush <> 0 then\r\n    DeleteObject(FDottedBrush);\r\n  FDottedBrush := 0;\r\n\r\n  FHeader.Free;\r\n  FHeader := nil; // Do not use FreeAndNil() before checking issue #497\r\n  FreeAndNil(FOptions); // WM_NCDESTROY accesses FOptions\r\n\r\n  FreeMem(FRoot);\r\n\r\n  FPlusBM.Free;\r\n  FHotPlusBM.Free;\r\n  FMinusBM.Free;\r\n  FHotMinusBM.Free;\r\n  FSelectedHotPlusBM.Free;\r\n  FSelectedHotMinusBM.Free;\r\n\r\n  inherited;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.AdjustCoordinatesByIndent(var PaintInfo: TVTPaintInfo; Indent: Integer);\r\n\r\n// During painting of the main column some coordinates must be adjusted due to the tree lines.\r\n// The offset resulting from the tree lines and indentation level is given in Indent.\r\n\r\nvar\r\n  Offset: Integer;\r\n\r\nbegin\r\n  with PaintInfo do\r\n  begin\r\n    Offset := Indent * Integer(FIndent);\r\n    if BidiMode = bdLeftToRight then\r\n    begin\r\n      Inc(ContentRect.Left, Offset);\r\n      Inc(ImageInfo[iiNormal].XPos, Offset);\r\n      Inc(ImageInfo[iiState].XPos, Offset);\r\n      Inc(ImageInfo[iiCheck].XPos, Offset);\r\n    end\r\n    else\r\n    begin\r\n      Dec(ContentRect.Right, Offset);\r\n      Dec(ImageInfo[iiNormal].XPos, Offset);\r\n      Dec(ImageInfo[iiState].XPos, Offset);\r\n      Dec(ImageInfo[iiCheck].XPos, Offset);\r\n    end;\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.AdjustTotalCount(Node: PVirtualNode; Value: Integer; Relative: Boolean = False);\r\n\r\n// Sets a node's total count to the given value and recursively adjusts the parent's total count\r\n// (actually, the adjustment is done iteratively to avoid function call overheads).\r\n\r\nvar\r\n  Difference: Integer;\r\n  Run: PVirtualNode;\r\n\r\nbegin\r\n  if Relative then\r\n    Difference := Value\r\n  else\r\n    Difference := Value - Integer(Node.TotalCount);\r\n  if Difference <> 0 then\r\n  begin\r\n    Run := Node;\r\n    // Root node has as parent the tree view.\r\n    while Assigned(Run) and (Run <> Pointer(Self)) do\r\n    begin\r\n      Inc(Integer(Run.TotalCount), Difference);\r\n      Run := Run.Parent;\r\n    end;\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.AdjustTotalHeight(Node: PVirtualNode; Value: Integer; Relative: Boolean = False);\r\n\r\n// Sets a node's total height to the given value and recursively adjusts the parent's total height.\r\n\r\nvar\r\n  Difference: Integer;\r\n  Run: PVirtualNode;\r\n\r\nbegin\r\n  if Relative then\r\n    Difference := Value\r\n  else\r\n    Difference := Value - Integer(Node.TotalHeight);\r\n  if Difference <> 0 then\r\n  begin\r\n    Run := Node;\r\n    repeat\r\n      Inc(Integer(Run.TotalHeight), Difference);\r\n      // If the node is not visible or the parent node is not expanded or we are already at the top\r\n      // then nothing more remains to do.\r\n      if not (vsVisible in Run.States) or (Run = FRoot) or\r\n        (Run.Parent = nil) or not (vsExpanded in Run.Parent.States) then\r\n        Break;\r\n\r\n      Run := Run.Parent;\r\n    until False;\r\n  end;\r\n\r\n  UpdateVerticalRange;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TBaseVirtualTree.CalculateCacheEntryCount: Integer;\r\n\r\n// Calculates the size of the position cache.\r\n\r\nbegin\r\n  if FVisibleCount > 1 then\r\n    Result := Ceil(FVisibleCount / CacheThreshold)\r\n  else\r\n    Result := 0;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.CalculateVerticalAlignments(ShowImages, ShowStateImages: Boolean; Node: PVirtualNode;\r\n  var VAlign, VButtonAlign: Integer);\r\n\r\n// Calculates the vertical alignment of the given node and its associated expand/collapse button during\r\n// a node paint cycle depending on the required node alignment style.\r\n\r\nbegin\r\n  // For absolute alignment the calculation is trivial.\r\n  case FNodeAlignment of\r\n    naFromTop:\r\n      VAlign := Node.Align;\r\n    naFromBottom:\r\n      VAlign := Integer(NodeHeight[Node]) - Node.Align;\r\n  else // naProportional\r\n    // Consider button and line alignment, but make sure neither the image nor the button (whichever is taller)\r\n    // go out of the entire node height (100% means bottom alignment to the node's bounds).\r\n    if ShowImages or ShowStateImages then\r\n    begin\r\n      if ShowImages then\r\n        VAlign := GetNodeImageSize(Node).cy\r\n      else\r\n        VAlign := FStateImages.Height;\r\n      VAlign := MulDiv((Integer(NodeHeight[Node]) - VAlign), Node.Align, 100) + VAlign div 2;\r\n    end\r\n    else\r\n      if toShowButtons in FOptions.FPaintOptions then\r\n        VAlign := MulDiv((Integer(NodeHeight[Node]) - FPlusBM.Height), Node.Align, 100) + FPlusBM.Height div 2\r\n      else\r\n        VAlign := MulDiv(Integer(Node.NodeHeight), Node.Align, 100);\r\n  end;\r\n\r\n  VButtonAlign := VAlign - FPlusBM.Height div 2 - (FPlusBM.Height and 1);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TBaseVirtualTree.ChangeCheckState(Node: PVirtualNode; Value: TCheckState): Boolean;\r\n\r\n// Sets the check state of the node according to the given value and the node's check type.\r\n// If the check state must be propagated to the parent nodes and one of them refuses to change then\r\n// nothing happens and False is returned, otherwise True.\r\n\r\nvar\r\n  Run: PVirtualNode;\r\n  UncheckedCount,\r\n  MixedCheckCount,\r\n  CheckedCount: Cardinal;\r\n\r\nbegin\r\n  Result := not (vsChecking in Node.States);\r\n  with Node^ do\r\n  if Result then\r\n  begin\r\n    Include(States, vsChecking);\r\n    try\r\n      if not (vsInitialized in States) then\r\n        InitNode(Node)\r\n      else if CheckState = Value then\r\n      begin\r\n        // Value didn't change and node was initialized, so nothing to do\r\n        Result := False;\r\n        Exit;\r\n      end;//if\r\n\r\n      // Indicate that we are going to propagate check states up and down the hierarchy.\r\n      if FCheckPropagationCount = 0 then // WL, 05.02.2004: Do not enter tsCheckPropagation more than once\r\n        DoStateChange([tsCheckPropagation]);\r\n      Inc(FCheckPropagationCount); // WL, 05.02.2004\r\n      // Do actions which are associated with the given check state.\r\n      case CheckType of\r\n        // Check state change with additional consequences for check states of the children.\r\n        ctTriStateCheckBox:\r\n          begin\r\n            // Propagate state down to the children.\r\n            if toAutoTristateTracking in FOptions.FAutoOptions then\r\n              case Value of\r\n                csUncheckedNormal:\r\n                  if Node.ChildCount > 0 then\r\n                  begin\r\n                    Run := FirstChild;\r\n                    CheckedCount := 0;\r\n                    MixedCheckCount := 0;\r\n                    UncheckedCount := 0;\r\n                    while Assigned(Run) do\r\n                    begin\r\n                      if Run.CheckType in [ctCheckBox, ctTriStateCheckBox] then\r\n                      begin\r\n                        SetCheckState(Run, csUncheckedNormal);\r\n                        // Check if the new child state was set successfully, otherwise we have to adjust the\r\n                        // node's new check state accordingly.\r\n                        case Run.CheckState of\r\n                          csCheckedNormal:\r\n                            Inc(CheckedCount);\r\n                          csMixedNormal:\r\n                            Inc(MixedCheckCount);\r\n                          csUncheckedNormal:\r\n                            Inc(UncheckedCount);\r\n                        end;\r\n                      end;\r\n                      Run := Run.NextSibling;\r\n                    end;\r\n\r\n                    // If there is still a mixed state child node checkbox then this node must be mixed checked too.\r\n                    if MixedCheckCount > 0 then\r\n                      Value := csMixedNormal\r\n                    else\r\n                      // If nodes are normally checked child nodes then the unchecked count determines what\r\n                      // to set for the node itself.\r\n                      if CheckedCount > 0 then\r\n                        if UncheckedCount > 0 then\r\n                          Value := csMixedNormal\r\n                        else\r\n                          Value := csCheckedNormal;\r\n                  end;\r\n                csCheckedNormal:\r\n                  if Node.ChildCount > 0 then\r\n                  begin\r\n                    Run := FirstChild;\r\n                    CheckedCount := 0;\r\n                    MixedCheckCount := 0;\r\n                    UncheckedCount := 0;\r\n                    while Assigned(Run) do\r\n                    begin\r\n                      if Run.CheckType in [ctCheckBox, ctTriStateCheckBox] then\r\n                      begin\r\n                        SetCheckState(Run, csCheckedNormal);\r\n                        // Check if the new child state was set successfully, otherwise we have to adjust the\r\n                        // node's new check state accordingly.\r\n                        case Run.CheckState of\r\n                          csCheckedNormal:\r\n                            Inc(CheckedCount);\r\n                          csMixedNormal:\r\n                            Inc(MixedCheckCount);\r\n                          csUncheckedNormal:\r\n                            Inc(UncheckedCount);\r\n                        end;\r\n                      end;\r\n                      Run := Run.NextSibling;\r\n                    end;\r\n\r\n                    // If there is still a mixed state child node checkbox then this node must be mixed checked too.\r\n                    if MixedCheckCount > 0 then\r\n                      Value := csMixedNormal\r\n                    else\r\n                      // If nodes are normally checked child nodes then the unchecked count determines what\r\n                      // to set for the node itself.\r\n                      if CheckedCount > 0 then\r\n                        if UncheckedCount > 0 then\r\n                          Value := csMixedNormal\r\n                        else\r\n                          Value := csCheckedNormal;\r\n                  end;\r\n              end;\r\n          end;\r\n        // radio button check state change\r\n        ctRadioButton:\r\n          if Value = csCheckedNormal then\r\n          begin\r\n            Value := csCheckedNormal;\r\n            // Make sure only this node is checked.\r\n            Run := Parent.FirstChild;\r\n            while Assigned(Run) do\r\n            begin\r\n              if Run.CheckType = ctRadioButton then\r\n                Run.CheckState := csUncheckedNormal;\r\n              Run := Run.NextSibling;\r\n            end;\r\n            Invalidate;\r\n          end;\r\n      end;\r\n\r\n      if Result then\r\n        CheckState := Value // Set new check state\r\n      else\r\n        CheckState := UnpressedState[CheckState]; // Reset dynamic check state.\r\n\r\n      // Propagate state up to the parent.\r\n      if not (vsInitialized in Parent.States) then\r\n        InitNode(Parent);\r\n      if (toAutoTristateTracking in FOptions.FAutoOptions) and ([vsChecking, vsDisabled] * Parent.States = []) and\r\n        (CheckType in [ctCheckBox, ctTriStateCheckBox]) and (Parent <> FRoot) and\r\n        (Parent.CheckType = ctTriStateCheckBox) then\r\n        Result := CheckParentCheckState(Node, Value)\r\n      else\r\n        Result := True;\r\n\r\n      InvalidateNode(Node);\r\n\r\n      Dec(FCheckPropagationCount); // WL, 05.02.2004\r\n      if FCheckPropagationCount = 0 then // WL, 05.02.2004: Allow state change event after all check operations finished\r\n        DoStateChange([], [tsCheckPropagation]);\r\n    finally\r\n      Exclude(States, vsChecking);\r\n    end;\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TBaseVirtualTree.CollectSelectedNodesLTR(MainColumn, NodeLeft, NodeRight: Integer; Alignment: TAlignment;\r\n  OldRect, NewRect: TRect): Boolean;\r\n\r\n// Helper routine used when a draw selection takes place. This version handles left-to-right directionality.\r\n// In the process of adding or removing nodes the current selection is modified which requires to pack it after\r\n// the function returns. Another side effect of this method is that a temporary list of nodes will be created\r\n// (see also InternalCacheNode) which must be inserted into the current selection by the caller.\r\n\r\nvar\r\n  Run,\r\n  NextNode: PVirtualNode;\r\n  TextRight,\r\n  TextLeft,\r\n  CheckOffset,\r\n  CurrentTop,\r\n  CurrentRight,\r\n  NextTop,\r\n  NextColumn,\r\n  NodeWidth,\r\n  Dummy: Integer;\r\n  MinY, MaxY: Integer;\r\n  StateImageOffset: Integer;\r\n  IsInOldRect,\r\n  IsInNewRect: Boolean;\r\n\r\n  // quick check variables for various parameters\r\n  WithCheck,\r\n  WithImages,\r\n  WithStateImages,\r\n  DoSwitch,\r\n  AutoSpan: Boolean;\r\n  SimpleSelection: Boolean;\r\n\r\nbegin\r\n  // A priori nothing changes.\r\n  Result := False;\r\n\r\n  // Determine minimum and maximum vertical coordinates to limit iteration to.\r\n  MinY := Min(OldRect.Top, NewRect.Top);\r\n  MaxY := Max(OldRect.Bottom, NewRect.Bottom);\r\n\r\n  // Initialize short hand variables to speed up tests below.\r\n  DoSwitch := ssCtrl in FDrawSelShiftState;\r\n  WithCheck := (toCheckSupport in FOptions.FMiscOptions) and Assigned(FCheckImages);\r\n  // Don't check the events here as descendant trees might have overriden the DoGetImageIndex method.\r\n  WithImages := Assigned(FImages);\r\n  WithStateImages := Assigned(FStateImages);\r\n  if WithStateImages then\r\n    StateImageOffset := FStateImages.Width + 2\r\n  else\r\n    StateImageOffset := 0;\r\n  if WithCheck then\r\n    CheckOffset := FCheckImages.Width + 2\r\n  else\r\n    CheckOffset := 0;\r\n  AutoSpan := FHeader.UseColumns and (toAutoSpanColumns in FOptions.FAutoOptions);\r\n  SimpleSelection := toSimpleDrawSelection in FOptions.FSelectionOptions;\r\n  // This is the node to start with.\r\n  Run := GetNodeAt(0, MinY, False, CurrentTop);\r\n\r\n  if Assigned(Run) then\r\n  begin\r\n    // The initial minimal left border is determined by the identation level of the node and is dynamically adjusted.\r\n    if toShowRoot in FOptions.FPaintOptions then\r\n      Inc(NodeLeft, Integer((GetNodeLevel(Run) + 1) * FIndent) + FMargin)\r\n    else\r\n      Inc(NodeLeft, Integer(GetNodeLevel(Run) * FIndent) + FMargin);\r\n\r\n    // ----- main loop\r\n    // Change selection depending on the node's rectangle being in the selection rectangle or not, but\r\n    // touch only those nodes which overlap either the old selection rectangle or the new one but not both.\r\n    repeat\r\n      // Collect offsets for check, normal and state images.\r\n      TextLeft := NodeLeft;\r\n      if WithCheck and (Run.CheckType <> ctNone) then\r\n        Inc(TextLeft, CheckOffset);\r\n      if WithImages and HasImage(Run, ikNormal, MainColumn) then\r\n        Inc(TextLeft, GetNodeImageSize(Run).cx + 2);\r\n      if WithStateImages and HasImage(Run, ikState, MainColumn) then\r\n        Inc(TextLeft, StateImageOffset);\r\n      NextTop := CurrentTop + Integer(NodeHeight[Run]);\r\n\r\n      // Simple selection allows to draw the selection rectangle anywhere. No intersection with node captions is\r\n      // required. Only top and bottom bounds of the rectangle matter.\r\n      if SimpleSelection or (toFullRowSelect in FOptions.FSelectionOptions) then\r\n      begin\r\n        IsInOldRect := (NextTop > OldRect.Top) and (CurrentTop < OldRect.Bottom) and\r\n          ((FHeader.Columns.Count = 0) or (FHeader.Columns.TotalWidth > OldRect.Left)) and (NodeLeft < OldRect.Right);\r\n        IsInNewRect := (NextTop > NewRect.Top) and (CurrentTop < NewRect.Bottom) and\r\n          ((FHeader.Columns.Count = 0) or (FHeader.Columns.TotalWidth > NewRect.Left)) and (NodeLeft < NewRect.Right);\r\n      end\r\n      else\r\n      begin\r\n        // The right column border might be extended if column spanning is enabled.\r\n        if AutoSpan then\r\n        begin\r\n          with FHeader.FColumns do\r\n          begin\r\n            NextColumn := MainColumn;\r\n            repeat\r\n              Dummy := GetNextVisibleColumn(NextColumn);\r\n              if (Dummy = InvalidColumn) or not ColumnIsEmpty(Run, Dummy) or\r\n                 (Items[Dummy].BidiMode <> bdLeftToRight) then\r\n                Break;\r\n              NextColumn := Dummy;\r\n            until False;\r\n            if NextColumn = MainColumn then\r\n              CurrentRight := NodeRight\r\n            else\r\n              GetColumnBounds(NextColumn, Dummy, CurrentRight);\r\n          end;\r\n        end\r\n        else\r\n          CurrentRight := NodeRight;\r\n          // Check if we need the node's width. This is the case when the node is not left aligned or the\r\n          // left border of the selection rectangle is to the right of the left node border.\r\n          if (TextLeft < OldRect.Left) or (TextLeft < NewRect.Left) or (Alignment <> taLeftJustify) then\r\n          begin\r\n            NodeWidth := DoGetNodeWidth(Run, MainColumn);\r\n            if NodeWidth >= (CurrentRight - TextLeft) then\r\n              TextRight := CurrentRight\r\n            else\r\n              case Alignment of\r\n                taLeftJustify:\r\n                  TextRight := TextLeft + NodeWidth;\r\n                taCenter:\r\n                  begin\r\n                    TextLeft := (TextLeft + CurrentRight - NodeWidth) div 2;\r\n                    TextRight := TextLeft + NodeWidth;\r\n                  end;\r\n              else\r\n                // taRightJustify\r\n                TextRight := CurrentRight;\r\n                TextLeft := TextRight - NodeWidth;\r\n              end;\r\n          end\r\n          else\r\n            TextRight := CurrentRight;\r\n\r\n        // Now determine whether we need to change the state.\r\n        IsInOldRect := (OldRect.Left <= TextRight) and (OldRect.Right >= TextLeft) and\r\n          (NextTop > OldRect.Top) and (CurrentTop < OldRect.Bottom);\r\n        IsInNewRect := (NewRect.Left <= TextRight) and (NewRect.Right >= TextLeft) and\r\n          (NextTop > NewRect.Top) and (CurrentTop < NewRect.Bottom);\r\n      end;\r\n\r\n      if IsInOldRect xor IsInNewRect then\r\n      begin\r\n        Result := True;\r\n        if DoSwitch then\r\n        begin\r\n          if vsSelected in Run.States then\r\n            InternalRemoveFromSelection(Run)\r\n          else\r\n            InternalCacheNode(Run);\r\n        end\r\n        else\r\n        begin\r\n          if IsInNewRect then\r\n            InternalCacheNode(Run)\r\n          else\r\n            InternalRemoveFromSelection(Run);\r\n          end;\r\n      end;\r\n      CurrentTop := NextTop;\r\n      // Get next visible node and update left node position.\r\n      NextNode := GetNextVisibleNoInit(Run, True);\r\n      if NextNode = nil then\r\n        Break;\r\n      Inc(NodeLeft, CountLevelDifference(Run, NextNode) * Integer(FIndent));\r\n      Run := NextNode;\r\n    until CurrentTop > MaxY;\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TBaseVirtualTree.CollectSelectedNodesRTL(MainColumn, NodeLeft, NodeRight: Integer; Alignment: TAlignment;\r\n  OldRect, NewRect: TRect): Boolean;\r\n\r\n// Helper routine used when a draw selection takes place. This version handles right-to-left directionality.\r\n// See also comments in CollectSelectedNodesLTR.\r\n\r\nvar\r\n  Run,\r\n  NextNode: PVirtualNode;\r\n  TextRight,\r\n  TextLeft,\r\n  CheckOffset,\r\n  CurrentTop,\r\n  CurrentLeft,\r\n  NextTop,\r\n  NextColumn,\r\n  NodeWidth,\r\n  Dummy: Integer;\r\n  MinY, MaxY: Integer;\r\n  StateImageOffset: Integer;\r\n  IsInOldRect,\r\n  IsInNewRect: Boolean;\r\n\r\n  // quick check variables for various parameters\r\n  WithCheck,\r\n  WithImages,\r\n  WithStateImages,\r\n  DoSwitch,\r\n  AutoSpan: Boolean;\r\n  SimpleSelection: Boolean;\r\n\r\nbegin\r\n  // A priori nothing changes.\r\n  Result := False;\r\n  // Switch the alignment to the opposite value in RTL context.\r\n  ChangeBiDiModeAlignment(Alignment);\r\n\r\n  // Determine minimum and maximum vertical coordinates to limit iteration to.\r\n  MinY := Min(OldRect.Top, NewRect.Top);\r\n  MaxY := Max(OldRect.Bottom, NewRect.Bottom);\r\n\r\n  // Initialize short hand variables to speed up tests below.\r\n  DoSwitch := ssCtrl in FDrawSelShiftState;\r\n  WithCheck := (toCheckSupport in FOptions.FMiscOptions) and Assigned(FCheckImages);\r\n  // Don't check the events here as descendant trees might have overriden the DoGetImageIndex method.\r\n  WithImages := Assigned(FImages);\r\n  WithStateImages := Assigned(FStateImages);\r\n  if WithStateImages then\r\n    StateImageOffset := FStateImages.Width + 2\r\n  else\r\n    StateImageOffset := 0;\r\n  if WithCheck then\r\n    CheckOffset := FCheckImages.Width + 2\r\n  else\r\n    CheckOffset := 0;\r\n  AutoSpan := FHeader.UseColumns and (toAutoSpanColumns in FOptions.FAutoOptions);\r\n  SimpleSelection := toSimpleDrawSelection in FOptions.FSelectionOptions;\r\n  // This is the node to start with.\r\n  Run := GetNodeAt(0, MinY, False, CurrentTop);\r\n\r\n  if Assigned(Run) then\r\n  begin\r\n    // The initial minimal left border is determined by the identation level of the node and is dynamically adjusted.\r\n    if toShowRoot in FOptions.FPaintOptions then\r\n      Dec(NodeRight, Integer((GetNodeLevel(Run) + 1) * FIndent) + FMargin)\r\n    else\r\n      Dec(NodeRight, Integer(GetNodeLevel(Run) * FIndent) + FMargin);\r\n\r\n    // ----- main loop\r\n    // Change selection depending on the node's rectangle being in the selection rectangle or not, but\r\n    // touch only those nodes which overlap either the old selection rectangle or the new one but not both.\r\n    repeat\r\n      // Collect offsets for check, normal and state images.\r\n      TextRight := NodeRight;\r\n      if WithCheck and (Run.CheckType <> ctNone) then\r\n        Dec(TextRight, CheckOffset);\r\n      if WithImages and HasImage(Run, ikNormal, MainColumn) then\r\n        Dec(TextRight, GetNodeImageSize(Run).cx + 2);\r\n      if WithStateImages and HasImage(Run, ikState, MainColumn) then\r\n        Dec(TextRight, StateImageOffset);\r\n      NextTop := CurrentTop + Integer(NodeHeight[Run]);\r\n\r\n      // Simple selection allows to draw the selection rectangle anywhere. No intersection with node captions is\r\n      // required. Only top and bottom bounds of the rectangle matter.\r\n      if SimpleSelection then\r\n      begin\r\n        IsInOldRect := (NextTop > OldRect.Top) and (CurrentTop < OldRect.Bottom);\r\n        IsInNewRect := (NextTop > NewRect.Top) and (CurrentTop < NewRect.Bottom);\r\n      end\r\n      else\r\n      begin        // The left column border might be extended if column spanning is enabled.\r\n        if AutoSpan then\r\n        begin\r\n          NextColumn := MainColumn;\r\n          repeat\r\n            Dummy := FHeader.FColumns.GetPreviousVisibleColumn(NextColumn);\r\n            if (Dummy = InvalidColumn) or not ColumnIsEmpty(Run, Dummy) or\r\n               (FHeader.FColumns[Dummy].BiDiMode = bdLeftToRight) then\r\n              Break;\r\n            NextColumn := Dummy;\r\n          until False;\r\n          if NextColumn = MainColumn then\r\n            CurrentLeft := NodeLeft\r\n          else\r\n            FHeader.FColumns.GetColumnBounds(NextColumn, CurrentLeft, Dummy);\r\n        end\r\n        else\r\n          CurrentLeft := NodeLeft;\r\n          // Check if we need the node's width. This is the case when the node is not left aligned (in RTL context this        // means actually right aligned) or the right border of the selection rectangle is to the left\r\n          // of the right node border.\r\n          if (TextRight > OldRect.Right) or (TextRight > NewRect.Right) or (Alignment <> taRightJustify) then\r\n          begin\r\n          NodeWidth := DoGetNodeWidth(Run, MainColumn);\r\n          if NodeWidth >= (TextRight - CurrentLeft) then\r\n            TextLeft := CurrentLeft\r\n          else\r\n            case Alignment of\r\n              taLeftJustify:\r\n                begin\r\n                  TextLeft := CurrentLeft;\r\n                  TextRight := TextLeft + NodeWidth;\r\n                end;\r\n              taCenter:\r\n                begin\r\n                  TextLeft := (TextRight + CurrentLeft - NodeWidth) div 2;\r\n                  TextRight := TextLeft + NodeWidth;\r\n                end;\r\n              else\r\n                // taRightJustify\r\n                TextLeft := TextRight - NodeWidth;\r\n            end;\r\n        end\r\n        else\r\n          TextLeft := CurrentLeft;\r\n\r\n        // Now determine whether we need to change the state.\r\n        IsInOldRect := (OldRect.Right >= TextLeft) and (OldRect.Left <= TextRight) and\r\n          (NextTop > OldRect.Top) and (CurrentTop < OldRect.Bottom);\r\n        IsInNewRect := (NewRect.Right >= TextLeft) and (NewRect.Left <= TextRight) and\r\n          (NextTop > NewRect.Top) and (CurrentTop < NewRect.Bottom);\r\n      end;\r\n\r\n      if IsInOldRect xor IsInNewRect then\r\n      begin\r\n        Result := True;\r\n        if DoSwitch then\r\n        begin\r\n          if vsSelected in Run.States then\r\n            InternalRemoveFromSelection(Run)\r\n          else\r\n            InternalCacheNode(Run);\r\n        end\r\n        else\r\n        begin\r\n          if IsInNewRect then\r\n            InternalCacheNode(Run)\r\n          else\r\n            InternalRemoveFromSelection(Run);\r\n        end;\r\n      end;\r\n      CurrentTop := NextTop;\r\n      // Get next visible node and update left node position.\r\n      NextNode := GetNextVisibleNoInit(Run, True);\r\n      if NextNode = nil then\r\n        Break;\r\n      Dec(NodeRight, CountLevelDifference(Run, NextNode) * Integer(FIndent));\r\n      Run := NextNode;\r\n    until CurrentTop > MaxY;\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.ClearNodeBackground(const PaintInfo: TVTPaintInfo; UseBackground, Floating: Boolean;\r\n  R: TRect);\r\n\r\n// Erases a node's background depending on what the application decides to do.\r\n// UseBackground determines whether or not to use the background picture, while Floating indicates\r\n// that R is given in coordinates of the small node bitmap or the superordinated target bitmap used in PaintTree.\r\n\r\nvar\r\n  BackColor: TColor;\r\n  EraseAction: TItemEraseAction;\r\n  Offset: TPoint;\r\n\r\nbegin\r\n  BackColor := FColors.BackGroundColor;\r\n  with PaintInfo do\r\n  begin\r\n    EraseAction := eaDefault;\r\n\r\n    if Floating then\r\n    begin\r\n      Offset := Point(-FEffectiveOffsetX, R.Top);\r\n      OffsetRect(R, 0, -Offset.Y);\r\n    end\r\n    else\r\n      Offset := Point(0, 0);\r\n\r\n    DoBeforeItemErase(Canvas, Node, R, BackColor, EraseAction);\r\n\r\n    with Canvas do\r\n    begin\r\n      case EraseAction of\r\n        eaNone:\r\n          ;\r\n        eaColor:\r\n          begin\r\n            // User has given a new background color.\r\n            Brush.Color := BackColor;\r\n            FillRect(R);\r\n          end;\r\n      else // eaDefault\r\n        if UseBackground then\r\n        begin\r\n          if toStaticBackground in TreeOptions.PaintOptions then\r\n            StaticBackground(FBackground.Bitmap, Canvas, Offset, R)\r\n          else\r\n            TileBackground(FBackground.Bitmap, Canvas, Offset, R);\r\n        end\r\n        else\r\n        begin\r\n          if (poDrawSelection in PaintOptions) and (toFullRowSelect in FOptions.FSelectionOptions) and\r\n             (vsSelected in Node.States) and not (toUseBlendedSelection in FOptions.PaintOptions) and not\r\n             (tsUseExplorerTheme in FStates) then\r\n          begin\r\n            if toShowHorzGridLines in FOptions.PaintOptions then\r\n            begin\r\n              Brush.Color := BackColor;\r\n              FillRect(Rect(R.Left, R.Bottom - 1, R.Right, R.Bottom));\r\n              Dec(R.Bottom);\r\n            end;\r\n            if Focused or (toPopupMode in FOptions.FPaintOptions) then\r\n            begin\r\n              Brush.Color := FColors.FocusedSelectionColor;\r\n              Pen.Color := FColors.FocusedSelectionBorderColor;\r\n            end\r\n            else\r\n            begin\r\n              Brush.Color := FColors.UnfocusedSelectionColor;\r\n              Pen.Color := FColors.UnfocusedSelectionBorderColor;\r\n            end;\r\n\r\n            with TWithSafeRect(R) do\r\n              RoundRect(Left, Top, Right, Bottom, FSelectionCurveRadius, FSelectionCurveRadius);\r\n          end\r\n          else\r\n          begin\r\n            Brush.Color := BackColor;\r\n            FillRect(R);\r\n          end;\r\n        end;\r\n      end;\r\n      DoAfterItemErase(Canvas, Node, R);\r\n    end;\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TBaseVirtualTree.CompareNodePositions(Node1, Node2: PVirtualNode; ConsiderChildrenAbove: Boolean = False): Integer;\r\n\r\n// Tries hard and smart to quickly determine whether Node1's structural position is before Node2's position.\r\n// If ConsiderChildrenAbove is True, the nodes will be compared with their visual order in mind.\r\n// Returns 0 if Node1 = Node2, < 0 if Node1 is located before Node2 else > 0.\r\n\r\nvar\r\n  Run1,\r\n  Run2: PVirtualNode;\r\n  Level1,\r\n  Level2: Cardinal;\r\n\r\nbegin\r\n  Assert(Assigned(Node1) and Assigned(Node2), 'Nodes must never be nil.');\r\n\r\n  if Node1 = Node2 then\r\n    Result := 0\r\n  else\r\n  begin\r\n    if HasAsParent(Node1, Node2) then\r\n      Result := IfThen(ConsiderChildrenAbove and (toChildrenAbove in FOptions.FPaintOptions), -1, 1)\r\n    else\r\n      if HasAsParent(Node2, Node1) then\r\n        Result := IfThen(ConsiderChildrenAbove and (toChildrenAbove in FOptions.FPaintOptions), 1, -1)\r\n      else\r\n      begin\r\n        // the given nodes are neither equal nor are they parents of each other, so go up to FRoot\r\n        // for each node and compare the child indices of the top level parents\r\n        // Note: neither Node1 nor Node2 can be FRoot at this point as this (a bit strange) circumstance would\r\n        //       be caught by the previous code.\r\n\r\n        // start lookup at the same level\r\n        Level1 := GetNodeLevel(Node1);\r\n        Level2 := GetNodeLevel(Node2);\r\n        Run1 := Node1;\r\n        while Level1 > Level2 do\r\n        begin\r\n          Run1 := Run1.Parent;\r\n          Dec(Level1);\r\n        end;\r\n        Run2 := Node2;\r\n        while Level2 > Level1 do\r\n        begin\r\n          Run2 := Run2.Parent;\r\n          Dec(Level2);\r\n        end;\r\n\r\n        // now go up until we find a common parent node (loop will safely stop at FRoot if the nodes\r\n        // don't share a common parent)\r\n        while Run1.Parent <> Run2.Parent do\r\n        begin\r\n          Run1 := Run1.Parent;\r\n          Run2 := Run2.Parent;\r\n        end;\r\n        Result := Integer(Run1.Index) - Integer(Run2.Index);\r\n      end;\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.DrawLineImage(const PaintInfo: TVTPaintInfo; X, Y, H, VAlign: Integer; Style: TVTLineType;\r\n  Reverse: Boolean);\r\n\r\n// Draws (depending on Style) one of the 5 line types of the tree.\r\n// If Reverse is True then a right-to-left column is being drawn, hence horizontal lines must be mirrored.\r\n// X and Y describe the left upper corner of the line image rectangle, while H denotes its height (and width).\r\n\r\nvar\r\n  HalfWidth,\r\n  TargetX: Integer;\r\n\r\nbegin\r\n  HalfWidth := Round(FIndent / 2);\r\n  if Reverse then\r\n    TargetX := 0\r\n  else\r\n    TargetX := FIndent;\r\n\r\n  with PaintInfo.Canvas do\r\n  begin\r\n    case Style of\r\n      ltBottomRight:\r\n        begin\r\n          DrawDottedVLine(PaintInfo, Y + VAlign, Y + H, X + HalfWidth);\r\n          DrawDottedHLine(PaintInfo, X + HalfWidth, X + TargetX, Y + VAlign);\r\n        end;\r\n      ltTopDown:\r\n        DrawDottedVLine(PaintInfo, Y, Y + H, X + HalfWidth);\r\n      ltTopDownRight:\r\n        begin\r\n          DrawDottedVLine(PaintInfo, Y, Y + H, X + HalfWidth);\r\n          DrawDottedHLine(PaintInfo, X + HalfWidth, X + TargetX, Y + VAlign);\r\n        end;\r\n      ltRight:\r\n        DrawDottedHLine(PaintInfo, X + HalfWidth, X + TargetX, Y + VAlign);\r\n      ltTopRight:\r\n        begin\r\n          DrawDottedVLine(PaintInfo, Y, Y + VAlign, X + HalfWidth);\r\n          DrawDottedHLine(PaintInfo, X + HalfWidth, X + TargetX, Y + VAlign);\r\n        end;\r\n      ltLeft: // left can also mean right for RTL context\r\n        if Reverse then\r\n          DrawDottedVLine(PaintInfo, Y, Y + H, X + Integer(FIndent))\r\n        else\r\n          DrawDottedVLine(PaintInfo, Y, Y + H, X);\r\n      ltLeftBottom:\r\n        if Reverse then\r\n        begin\r\n          DrawDottedVLine(PaintInfo, Y, Y + H, X + Integer(FIndent));\r\n          DrawDottedHLine(PaintInfo, X, X + Integer(FIndent), Y + H);\r\n        end\r\n        else\r\n        begin\r\n          DrawDottedVLine(PaintInfo, Y, Y + H, X);\r\n          DrawDottedHLine(PaintInfo, X, X + Integer(FIndent), Y + H);\r\n        end;\r\n    end;\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TBaseVirtualTree.FindInPositionCache(Node: PVirtualNode; var CurrentPos: Cardinal): PVirtualNode;\r\n\r\n// Looks through the position cache and returns the node whose top position is the largest one which is smaller or equal\r\n// to the position of the given node.\r\n\r\nvar\r\n  L, H, I: Integer;\r\n\r\nbegin\r\n  L := 0;\r\n  H := High(FPositionCache);\r\n  while L <= H do\r\n  begin\r\n    I := (L + H) shr 1;\r\n    if CompareNodePositions(FPositionCache[I].Node, Node) <= 0 then\r\n      L := I + 1\r\n    else\r\n      H := I - 1;\r\n  end;\r\n  if L = 0 then // High(FPositionCache) = -1\r\n  begin\r\n    Result := nil;\r\n    CurrentPos := 0;\r\n  end\r\n  else\r\n  begin\r\n    Result := FPositionCache[L - 1].Node;\r\n    CurrentPos := FPositionCache[L - 1].AbsoluteTop;\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TBaseVirtualTree.FindInPositionCache(Position: Cardinal; var CurrentPos: Cardinal): PVirtualNode;\r\n\r\n// Looks through the position cache and returns the node whose top position is the largest one which is smaller or equal\r\n// to the given vertical position.\r\n// The returned node does not necessarily occupy the given position but is the nearest one to start\r\n// iterating from to approach the real node for a given position. CurrentPos receives the actual position of the found\r\n// node which is needed for further iteration.\r\n\r\nvar\r\n  L, H, I: Integer;\r\n\r\nbegin\r\n  L := 0;\r\n  H := High(FPositionCache);\r\n  while L <= H do\r\n  begin\r\n    I := (L + H) shr 1;\r\n    if FPositionCache[I].AbsoluteTop <= Position then\r\n      L := I + 1\r\n    else\r\n      H := I - 1;\r\n  end;\r\n  if L = 0 then // High(FPositionCache) = -1\r\n  begin\r\n    Result := nil;\r\n    CurrentPos := 0;\r\n  end\r\n  else\r\n  begin\r\n    Result := FPositionCache[L - 1].Node;\r\n    CurrentPos := FPositionCache[L - 1].AbsoluteTop;\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.FixupTotalCount(Node: PVirtualNode);\r\n\r\n// Called after loading a subtree from stream. The child count in each node is already set but not\r\n// their total count.\r\n\r\nvar\r\n  Child: PVirtualNode;\r\n\r\nbegin\r\n  // Initial total count is set to one on node creation.\r\n  Child := Node.FirstChild;\r\n  while Assigned(Child) do\r\n  begin\r\n    FixupTotalCount(Child);\r\n    Inc(Node.TotalCount, Child.TotalCount);\r\n    Child := Child.NextSibling;\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.FixupTotalHeight(Node: PVirtualNode);\r\n\r\n// Called after loading a subtree from stream. The individual height of each node is set already,\r\n// but their total height needs an adjustment depending on their visibility state.\r\n\r\nvar\r\n  Child: PVirtualNode;\r\n\r\nbegin\r\n  // Initial total height is set to the node height on load.\r\n  Child := Node.FirstChild;\r\n\r\n  if vsExpanded in Node.States then\r\n  begin\r\n    while Assigned(Child) do\r\n    begin\r\n      FixupTotalHeight(Child);\r\n      if vsVisible in Child.States then\r\n        Inc(Node.TotalHeight, Child.TotalHeight);\r\n      Child := Child.NextSibling;\r\n    end;\r\n  end\r\n  else\r\n  begin\r\n    // The node is collapsed, so just update the total height of its child nodes.\r\n    while Assigned(Child) do\r\n    begin\r\n      FixupTotalHeight(Child);\r\n      Child := Child.NextSibling;\r\n    end;\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TBaseVirtualTree.GetBottomNode: PVirtualNode;\r\n\r\nbegin\r\n  Result := GetNodeAt(0, ClientHeight - 1);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TBaseVirtualTree.GetCheckedCount: Integer;\r\n\r\nvar\r\n  Node: PVirtualNode;\r\n\r\nbegin\r\n  Result := 0;\r\n  Node := GetFirstChecked;\r\n  while Assigned(Node) do\r\n  begin\r\n     Inc(Result);\r\n     Node := GetNextChecked(Node);\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TBaseVirtualTree.GetCheckState(Node: PVirtualNode): TCheckState;\r\n\r\nbegin\r\n  Result := Node.CheckState;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TBaseVirtualTree.GetCheckType(Node: PVirtualNode): TCheckType;\r\n\r\nbegin\r\n  Result := Node.CheckType;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TBaseVirtualTree.GetChildCount(Node: PVirtualNode): Cardinal;\r\n\r\nbegin\r\n  if (Node = nil) or (Node = FRoot) then\r\n    Result := FRoot.ChildCount\r\n  else\r\n    Result := Node.ChildCount;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TBaseVirtualTree.GetChildrenInitialized(Node: PVirtualNode): Boolean;\r\n\r\nbegin\r\n  Result := not (vsHasChildren in Node.States) or (Node.ChildCount > 0);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TBaseVirtualTree.GetCutCopyCount: Integer;\r\n\r\nvar\r\n  Node: PVirtualNode;\r\n\r\nbegin\r\n  Result := 0;\r\n  Node := GetFirstCutCopy;\r\n  while Assigned(Node) do\r\n  begin\r\n     Inc(Result);\r\n     Node := GetNextCutCopy(Node);\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TBaseVirtualTree.GetDisabled(Node: PVirtualNode): Boolean;\r\n\r\nbegin\r\n  Result := Assigned(Node) and (vsDisabled in Node.States);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TBaseVirtualTree.GetDragManager: IVTDragManager;\r\n\r\n// Returns the internal drag manager interface. If this does not yet exist then it is created here.\r\n\r\nbegin\r\n  if FDragManager = nil then\r\n  begin\r\n    FDragManager := DoCreateDragManager;\r\n    if FDragManager = nil then\r\n      FDragManager := TVTDragManager.Create(Self);\r\n  end;\r\n\r\n  Result := FDragManager;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TBaseVirtualTree.GetExpanded(Node: PVirtualNode): Boolean;\r\n\r\nbegin\r\n  if Assigned(Node) then\r\n    Result := vsExpanded in Node.States\r\n  else\r\n    Result := False;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TBaseVirtualTree.GetFiltered(Node: PVirtualNode): Boolean;\r\n\r\nbegin\r\n  Result := vsFiltered in Node.States;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TBaseVirtualTree.GetFullyVisible(Node: PVirtualNode): Boolean;\r\n\r\n// Determines whether the given node has the visibility flag set as well as all its parents are expanded.\r\n\r\nbegin\r\n  Assert(Assigned(Node), 'Invalid parameter.');\r\n  Result := vsVisible in Node.States;\r\n  if Result and (Node <> FRoot) then\r\n    Result := VisiblePath[Node];\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TBaseVirtualTree.GetHasChildren(Node: PVirtualNode): Boolean;\r\n\r\nbegin\r\n  if Assigned(Node) then\r\n    Result := vsHasChildren in Node.States\r\n  else\r\n    Result := vsHasChildren in FRoot.States;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TBaseVirtualTree.GetMultiline(Node: PVirtualNode): Boolean;\r\n\r\nbegin\r\n  Result := Assigned(Node) and (Node <> FRoot) and (vsMultiline in Node.States);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TBaseVirtualTree.GetNodeHeight(Node: PVirtualNode): Cardinal;\r\n\r\nbegin\r\n  if Assigned(Node) and (Node <> FRoot) then\r\n  begin\r\n    if (toVariableNodeHeight in FOptions.FMiscOptions) and not (vsDeleting in Node.States) then\r\n    begin\r\n      if not (vsInitialized in Node.States) then\r\n        InitNode(Node);\r\n\r\n      // Ensure the node's height is determined.\r\n      MeasureItemHeight(Self.Canvas, Node);\r\n    end;\r\n    Result := Node.NodeHeight;\r\n  end\r\n  else\r\n    Result := 0;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TBaseVirtualTree.GetNodeParent(Node: PVirtualNode): PVirtualNode;\r\n\r\nbegin\r\n  if Assigned(Node) and (Node.Parent <> FRoot) then\r\n    Result := Node.Parent\r\n  else\r\n    Result := nil;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TBaseVirtualTree.GetOffsetXY: TPoint;\r\n\r\nbegin\r\n  Result := Point(FOffsetX, FOffsetY);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TBaseVirtualTree.GetRangeX: Cardinal;\r\nbegin\r\n  Result := Max(0, FRangeX);\r\nend;\r\n\r\nfunction TBaseVirtualTree.GetRootNodeCount: Cardinal;\r\n\r\nbegin\r\n  Result := FRoot.ChildCount;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TBaseVirtualTree.GetSelected(Node: PVirtualNode): Boolean;\r\n\r\nbegin\r\n  Result := Assigned(Node) and (vsSelected in Node.States);\r\nend;\r\n\r\nfunction TBaseVirtualTree.GetSelectedData: TArray;\r\nvar\r\n  lItem: PVirtualNode;\r\n  i: Integer;\r\nbegin\r\n  SetLEngth(Result, Self.SelectedCount);\r\n  lItem := Self.GetFirstSelected;\r\n  for i := 0 to SelectedCount - 1 do\r\n  begin\r\n    Result[i] := Self.GetNodeData(lItem);\r\n    lItem := Self.GetNextSelected(lItem);\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TBaseVirtualTree.GetTopNode: PVirtualNode;\r\n\r\nvar\r\n  Dummy: Integer;\r\n\r\nbegin\r\n  Result := GetNodeAt(0, 0, True, Dummy);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TBaseVirtualTree.GetTotalCount: Cardinal;\r\n\r\nbegin\r\n  Inc(FUpdateCount);\r\n  try\r\n    ValidateNode(FRoot, True);\r\n  finally\r\n    Dec(FUpdateCount);\r\n  end;\r\n  // The root node itself doesn't count as node.\r\n  Result := FRoot.TotalCount - 1;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TBaseVirtualTree.GetVerticalAlignment(Node: PVirtualNode): Byte;\r\n\r\nbegin\r\n  Result := Node.Align;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TBaseVirtualTree.GetVisible(Node: PVirtualNode): Boolean;\r\n\r\n// Determines if the given node is marked as being visible.\r\n\r\nbegin\r\n  if Node = nil then\r\n    Node := FRoot;\r\n\r\n  if not (vsInitialized in Node.States) then\r\n    InitNode(Node);\r\n\r\n  Result := vsVisible in Node.States;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TBaseVirtualTree.GetVisiblePath(Node: PVirtualNode): Boolean;\r\n\r\n// Determines if all parents of the given node are expanded and have the visibility flag set.\r\n\r\nbegin\r\n  Assert(Assigned(Node) and (Node <> FRoot), 'Invalid parameters.');\r\n\r\n  // FRoot is always expanded\r\n  repeat\r\n    Node := Node.Parent;\r\n  until (Node = FRoot) or not (vsExpanded in Node.States) or not (vsVisible in Node.States);\r\n\r\n  Result := Node = FRoot;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.HandleClickSelection(LastFocused, NewNode: PVirtualNode; Shift: TShiftState;\r\n  DragPending: Boolean);\r\n\r\n// Handles multi-selection with mouse click.\r\n\r\nbegin\r\n  // Ctrl key down\r\n  if ssCtrl in Shift then\r\n  begin\r\n    if ssShift in Shift then\r\n    begin\r\n      SelectNodes(FRangeAnchor, NewNode, True);\r\n    end\r\n    else\r\n    begin\r\n      if not (toSiblingSelectConstraint in FOptions.SelectionOptions) then\r\n        FRangeAnchor := NewNode;\r\n      // Delay selection change if a drag operation is pending.\r\n      // Otherwise switch selection state here.\r\n      if DragPending then\r\n        DoStateChange([tsToggleFocusedSelection])\r\n      else\r\n        if vsSelected in NewNode.States then\r\n          RemoveFromSelection(NewNode)\r\n        else\r\n          AddToSelection(NewNode);\r\n    end;\r\n    Invalidate();\r\n  end\r\n  else\r\n    // Shift key down\r\n    if ssShift in Shift then\r\n    begin\r\n      if FRangeAnchor = nil then\r\n        FRangeAnchor := FRoot.FirstChild;\r\n\r\n      // select node range\r\n      if Assigned(FRangeAnchor) then\r\n      begin\r\n        SelectNodes(FRangeAnchor, NewNode, False);\r\n        Invalidate;\r\n      end;\r\n    end\r\n    else\r\n    begin\r\n      // any other case\r\n      if not (vsSelected in NewNode.States) then\r\n      begin\r\n        AddToSelection(NewNode);\r\n        InvalidateNode(NewNode);\r\n      end;\r\n      // assign new reference item\r\n      FRangeAnchor := NewNode;\r\n    end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TBaseVirtualTree.HandleDrawSelection(X, Y: Integer): Boolean;\r\n\r\n// Handles multi-selection with a focus rectangle.\r\n// Result is True if something changed in selection.\r\n\r\nvar\r\n  OldRect,\r\n  NewRect: TRect;\r\n  MainColumn: TColumnIndex;\r\n  MaxValue: Integer;\r\n\r\n  // limits of a node and its text\r\n  NodeLeft,\r\n  NodeRight: Integer;\r\n\r\n  // alignment and directionality\r\n  CurrentBidiMode: TBidiMode;\r\n  CurrentAlignment: TAlignment;\r\n\r\nbegin\r\n  Result := False;\r\n\r\n  // Selection changes are only done if the user drew a selection rectangle large\r\n  // enough to exceed the threshold.\r\n  if (FRoot.TotalCount > 1) and (tsDrawSelecting in FStates) then\r\n  begin\r\n    // Effective handling of node selection is done by using two rectangles stored in FSelectRec.\r\n    OldRect := OrderRect(FLastSelRect);\r\n    NewRect := OrderRect(FNewSelRect);\r\n    ClearTempCache;\r\n\r\n    MainColumn := FHeader.MainColumn;\r\n\r\n    // Alignment and bidi mode determine where the node text is located within a node.\r\n    if MainColumn <= NoColumn then\r\n    begin\r\n      CurrentBidiMode := BidiMode;\r\n      CurrentAlignment := Alignment;\r\n    end\r\n    else\r\n    begin\r\n      CurrentBidiMode := FHeader.FColumns[MainColumn].BidiMode;\r\n      CurrentAlignment := FHeader.FColumns[MainColumn].Alignment;\r\n    end;\r\n\r\n    // Determine initial left border of first node (take column reordering into account).\r\n    if FHeader.UseColumns then\r\n    begin\r\n      // The mouse coordinates don't include any horizontal scrolling hence take this also\r\n      // out from the returned column position.\r\n      NodeLeft := FHeader.FColumns[MainColumn].Left - FEffectiveOffsetX;\r\n      NodeRight := NodeLeft + FHeader.FColumns[MainColumn].Width;\r\n    end\r\n    else\r\n    begin\r\n      NodeLeft := 0;\r\n      NodeRight := ClientWidth;\r\n    end;\r\n    if CurrentBidiMode = bdLeftToRight then\r\n      Result := CollectSelectedNodesLTR(MainColumn, NodeLeft, NodeRight, CurrentAlignment, OldRect, NewRect)\r\n    else\r\n      Result := CollectSelectedNodesRTL(MainColumn, NodeLeft, NodeRight, CurrentAlignment, OldRect, NewRect);\r\n  end;\r\n\r\n  if Result then\r\n  begin\r\n    // Do some housekeeping if there was a change.\r\n    MaxValue := PackArray(FSelection, FSelectionCount);\r\n    if MaxValue > -1 then\r\n    begin\r\n      FSelectionCount := MaxValue;\r\n      SetLength(FSelection, FSelectionCount);\r\n    end;\r\n    if FTempNodeCount > 0 then\r\n    begin\r\n      AddToSelection(FTempNodeCache, FTempNodeCount);\r\n      ClearTempCache;\r\n    end;\r\n\r\n    Change(nil);\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TBaseVirtualTree.HasVisibleNextSibling(Node: PVirtualNode): Boolean;\r\n\r\n// Helper method to determine if the given node has a visible next sibling. This is needed to\r\n// draw correct tree lines.\r\n\r\nbegin\r\n  // Check if there is a sibling at all.\r\n  Result := Assigned(Node.NextSibling);\r\n\r\n  if Result then\r\n  begin\r\n    repeat\r\n      Node := Node.NextSibling;\r\n      Result := IsEffectivelyVisible[Node];\r\n    until Result or (Node.NextSibling = nil);\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TBaseVirtualTree.HasVisiblePreviousSibling(Node: PVirtualNode): Boolean;\r\n\r\n// Helper method to determine if the given node has a visible previous sibling. This is needed to\r\n// draw correct tree lines.\r\n\r\nbegin\r\n  // Check if there is a sibling at all.\r\n  Result := Assigned(Node.PrevSibling);\r\n\r\n  if Result then\r\n  begin\r\n    repeat\r\n      Node := Node.PrevSibling;\r\n      Result := IsEffectivelyVisible[Node];\r\n    until Result or (Node.PrevSibling = nil);\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.ImageListChange(Sender: TObject);\r\n\r\nbegin\r\n  if not (csDestroying in ComponentState) then\r\n    Invalidate;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.InitializeFirstColumnValues(var PaintInfo: TVTPaintInfo);\r\n\r\n// Determines initial index, position and cell size of the first visible column.\r\n\r\nbegin\r\n  PaintInfo.Column := FHeader.FColumns.GetFirstVisibleColumn;\r\n  with FHeader.FColumns, PaintInfo do\r\n  begin\r\n    if Column > NoColumn then\r\n    begin\r\n      CellRect.Right := CellRect.Left + Items[Column].Width;\r\n      Position := Items[Column].Position;\r\n    end\r\n    else\r\n      Position := 0;\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.InitRootNode(OldSize: Cardinal = 0);\r\n\r\n// Reinitializes the root node.\r\n\r\nvar\r\n  NewSize: Cardinal;\r\n\r\nbegin\r\n  NewSize := TreeNodeSize + FTotalInternalDataSize;\r\n  if FRoot = nil then\r\n    FRoot := AllocMem(NewSize)\r\n  else\r\n  begin\r\n    ReallocMem(FRoot, NewSize);\r\n    ZeroMemory(PByte(FRoot) + OldSize, NewSize - OldSize);\r\n  end;\r\n\r\n  with FRoot^ do\r\n  begin\r\n    // Indication that this node is the root node.\r\n    PrevSibling := FRoot;\r\n    NextSibling := FRoot;\r\n    Parent := Pointer(Self);\r\n    States := [vsInitialized, vsExpanded, vsHasChildren, vsVisible];\r\n    TotalHeight := FDefaultNodeHeight;\r\n    TotalCount := 1;\r\n    NodeHeight := FDefaultNodeHeight;\r\n    Align := 50;\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.InterruptValidation;\r\n\r\nvar\r\n  WasValidating: Boolean;\r\n\r\nbegin\r\n  DoStateChange([tsStopValidation], [tsUseCache]);\r\n\r\n  // Check the worker thread existance. It might already be gone (usually on destruction of the last tree).\r\n  if Assigned(WorkerThread) then\r\n  begin\r\n    WasValidating := (tsValidating in FStates);\r\n    WorkerThread.RemoveTree(Self);\r\n    if WasValidating then\r\n      InvalidateCache();\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TBaseVirtualTree.IsFirstVisibleChild(Parent, Node: PVirtualNode): Boolean;\r\n\r\n// Helper method to check if Node is the same as the first visible child of Parent.\r\n\r\nvar\r\n  Run: PVirtualNode;\r\n\r\nbegin\r\n  // Find first visible child.\r\n  Run := Parent.FirstChild;\r\n  while Assigned(Run) and not IsEffectivelyVisible[Run] do\r\n    Run := Run.NextSibling;\r\n\r\n  Result := Assigned(Run) and (Run = Node);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TBaseVirtualTree.IsLastVisibleChild(Parent, Node: PVirtualNode): Boolean;\r\n\r\n// Helper method to check if Node is the same as the last visible child of Parent.\r\n\r\nvar\r\n  Run: PVirtualNode;\r\n\r\nbegin\r\n  // Find last visible child.\r\n  Run := Parent.LastChild;\r\n  while Assigned(Run) and not IsEffectivelyVisible[Run] do\r\n    Run := Run.PrevSibling;\r\n\r\n  Result := Assigned(Run) and (Run = Node);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TBaseVirtualTree.MakeNewNode: PVirtualNode;\r\n\r\nvar\r\n  Size: Cardinal;\r\n\r\nbegin\r\n  Size := TreeNodeSize;\r\n  if not (csDesigning in ComponentState) then\r\n  begin\r\n    // Make sure FNodeDataSize is valid.\r\n    if FNodeDataSize = -1 then\r\n      ValidateNodeDataSize(FNodeDataSize);\r\n\r\n    // Take record alignment into account.\r\n    Inc(Size, FNodeDataSize);\r\n  end;\r\n\r\n  Result := AllocMem(Size + FTotalInternalDataSize);\r\n\r\n  // Fill in some default values.\r\n  with Result^ do\r\n  begin\r\n    TotalCount := 1;\r\n    TotalHeight := FDefaultNodeHeight;\r\n    NodeHeight := FDefaultNodeHeight;\r\n    States := [vsVisible];\r\n    Align := 50;\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TBaseVirtualTree.PackArray({*}const TheArray: TNodeArray; Count: Integer): Integer; assembler;\r\n// *This is an optimization to get as near as possible with the PUREPASCAL code without the\r\n//  compiler generating a _DynArrayAddRef call. We still modify the array's content via pointers.\r\n\r\n// Removes all entries from the selection array which are no longer in use. The selection array must be sorted for this\r\n// algo to work. Values which must be removed are marked with bit 0 (LSB) set. This little trick works because memory\r\n// is always allocated DWORD aligned. Since the selection array must be sorted while determining the entries to be\r\n// removed it is much more efficient to increment the entry in question instead of setting it to nil (which would break\r\n// the ordered appearance of the list).\r\n//\r\n// On enter EAX contains self reference, EDX the address to TheArray and ECX Count\r\n// The returned value is the number of remaining entries in the array, so the caller can reallocate (shorten)\r\n// the selection array if needed or -1 if nothing needs to be changed.\r\n\r\n{$ifdef CPUX64}\r\nvar\r\n  Source, Dest: ^PVirtualNode;\r\n  ConstOne: NativeInt;\r\nbegin\r\n  Source := Pointer(TheArray);\r\n  ConstOne := 1;\r\n  Result := 0;\r\n  // Do the fastest scan possible to find the first entry\r\n  while (Count <> 0) and {not Odd(NativeInt(Source^))} (NativeInt(Source^) and ConstOne = 0) do\r\n  begin\r\n    Inc(Result);\r\n    Inc(Source);\r\n    Dec(Count);\r\n  end;\r\n\r\n  if Count <> 0 then\r\n  begin\r\n    Dest := Source;\r\n    repeat\r\n      // Skip odd entries\r\n      if {not Odd(NativeInt(Source^))} NativeInt(Source^) and ConstOne = 0 then\r\n      begin\r\n        Dest^ := Source^;\r\n        Inc(Result);\r\n        Inc(Dest);\r\n      end;\r\n      Inc(Source); // Point to the next entry\r\n      Dec(Count);\r\n    until Count = 0;\r\n  end;\r\nend;\r\n{$else}\r\nasm\r\n        PUSH    EBX\r\n        PUSH    EDI\r\n        PUSH    ESI\r\n        MOV     ESI, EDX\r\n        MOV     EDX, -1\r\n        JCXZ    @@Finish               // Empty list?\r\n        INC     EDX                    // init remaining entries counter\r\n        MOV     EDI, ESI               // source and destination point to the list memory\r\n        MOV     EBX, 1                 // use a register instead of immediate operant to check against\r\n@@PreScan:\r\n        TEST    [ESI], EBX             // do the fastest scan possible to find the first entry\r\n                                       // which must be removed\r\n        JNZ     @@DoMainLoop\r\n        INC     EDX\r\n        ADD     ESI, 4\r\n        DEC     ECX\r\n        JNZ     @@PreScan\r\n        JMP     @@Finish\r\n\r\n@@DoMainLoop:\r\n        MOV     EDI, ESI\r\n@@MainLoop:\r\n        TEST    [ESI], EBX             // odd entry?\r\n        JNE     @@Skip                 // yes, so skip this one\r\n        MOVSD                          // else move the entry to new location\r\n        INC     EDX                    // count the moved entries\r\n        DEC     ECX\r\n        JNZ     @@MainLoop             // do it until all entries are processed\r\n        JMP     @@Finish\r\n\r\n@@Skip:\r\n        ADD     ESI, 4                 // point to the next entry\r\n        DEC     ECX\r\n        JNZ     @@MainLoop             // do it until all entries are processed\r\n@@Finish:\r\n        MOV     EAX, EDX               // prepare return value\r\n        POP     ESI\r\n        POP     EDI\r\n        POP     EBX\r\nend;\r\n{$endif CPUX64}\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.PrepareBitmaps(NeedButtons, NeedLines: Boolean);\r\n\r\n// initializes the contents of the internal bitmaps\r\n\r\nconst\r\n  LineBitsDotted: array [0..8] of Word = ($55, $AA, $55, $AA, $55, $AA, $55, $AA, $55);\r\n  LineBitsSolid: array [0..7] of Word = (0, 0, 0, 0, 0, 0, 0, 0);\r\n\r\nvar\r\n  PatternBitmap: HBITMAP;\r\n  Bits: Pointer;\r\n  Size: TSize;\r\n  Theme: HTHEME;\r\n  R: TRect;\r\n\r\n  //--------------- local function --------------------------------------------\r\n\r\n  procedure FillBitmap (ABitmap: TBitmap);\r\n  begin\r\n    with ABitmap, Canvas do\r\n    begin\r\n      Width := Size.cx;\r\n      Height := Size.cy;\r\n\r\n      if IsWinVistaOrAbove and (tsUseThemes in FStates) and (toUseExplorerTheme in FOptions.FPaintOptions) or VclStyleEnabled then\r\n      begin\r\n        if (FHeader.MainColumn > NoColumn) and not (coParentColor in FHeader.FColumns[FHeader.MainColumn].Options) then\r\n          Brush.Color := FHeader.FColumns[FHeader.MainColumn].Color\r\n        else\r\n          Brush.Color := FColors.BackGroundColor;\r\n      end\r\n      else\r\n        Brush.Color := clFuchsia;\r\n\r\n      Transparent := True;\r\n      TransparentColor := Brush.Color;\r\n\r\n      FillRect(Rect(0, 0, Width, Height));\r\n    end;\r\n  end;\r\n\r\n  //--------------- end local function ----------------------------------------\r\n\r\nbegin\r\n  if VclStyleEnabled and (seClient in StyleElements) then\r\n  begin\r\n    Size.cx := 11;\r\n    Size.cy := 11;\r\n    FillBitmap(FPlusBM);\r\n    FillBitmap(FHotPlusBM);\r\n    FillBitmap(FSelectedHotPlusBM);\r\n    FillBitmap(FMinusBM);\r\n    FillBitmap(FHotMinusBM);\r\n    FillBitmap(FSelectedHotMinusBM);\r\n    R := Rect(0,0,Size. cx,Size.cy);\r\n    // tcbCategoryGlyphClosed, tcbCategoryGlyphOpened from CategoryButtons\r\n    StyleServices.DrawElement(FPlusBM.Canvas.Handle, StyleServices.GetElementDetails(tcbCategoryGlyphClosed), R);\r\n    StyleServices.DrawElement(FMinusBM.Canvas.Handle, StyleServices.GetElementDetails(tcbCategoryGlyphOpened), R);\r\n    FHotMinusBM.Canvas.Draw(0, 0, FMinusBM);\r\n    FSelectedHotMinusBM.Canvas.Draw(0, 0, FMinusBM);\r\n    FHotPlusBM.Canvas.Draw(0, 0, FPlusBM);\r\n    FSelectedHotPlusBM.Canvas.Draw(0, 0, FPlusBM);\r\n    if Assigned(FOnPrepareButtonImages) then\r\n      FOnPrepareButtonImages(Self, FPlusBM, FHotPlusBM, FSelectedHotPlusBM, FMinusBM, FHotMinusBM, FSelectedHotMinusBM, size);\r\n  end\r\n    else\r\n      begin\r\n        Size.cx := 9;\r\n        Size.cy := 9;\r\n        if tsUseThemes in FStates then\r\n        begin\r\n          R := Rect(0, 0, 100, 100);\r\n          Theme := OpenThemeData(Handle, 'TREEVIEW');\r\n          GetThemePartSize(Theme, FPlusBM.Canvas.Handle, TVP_GLYPH, GLPS_OPENED, @R, TS_TRUE, Size);\r\n        end\r\n          else\r\n            Theme := 0;\r\n\r\n        if NeedButtons then\r\n        begin\r\n          //VCL Themes do not really have ability to provide tree plus/minus images when not using the\r\n          //windows theme. The bitmap style designer doesn't have any elements for for them, and you\r\n          //cannot name any elements you add, which makes it useless.\r\n          //To mitigate this, Hook up the OnPrepareButtonImages and draw them yourself.\r\n          if Assigned(FOnPrepareButtonImages) then\r\n          begin\r\n            FillBitmap(FPlusBM);\r\n            FillBitmap(FHotPlusBM);\r\n            FillBitmap(FSelectedHotPlusBM);\r\n            FillBitmap(FMinusBM);\r\n            FillBitmap(FHotMinusBM);\r\n            FillBitmap(FSelectedHotMinusBM);\r\n            FOnPrepareButtonImages(Self, FPlusBM, FHotPlusBM, FSelectedHotPlusBM, FMinusBM, FHotMinusBM, FSelectedHotMinusBM, size);\r\n          end\r\n            else\r\n              begin\r\n                with FMinusBM, Canvas do\r\n                begin\r\n                  // box is always of odd size\r\n                  FillBitmap(FMinusBM);\r\n                  FillBitmap(FHotMinusBM);\r\n                  FillBitmap(FSelectedHotMinusBM);\r\n                  // Weil die selbstgezeichneten Bitmaps sehen im Vcl Style scheie aus\r\n                  // Because the self-drawn bitmaps view Vcl Style shit\r\n                  if Theme = 0 then\r\n                  begin\r\n                    if not(tsUseExplorerTheme in FStates) then\r\n                    begin\r\n                      if FButtonStyle = bsTriangle then\r\n                      begin\r\n                        Brush.Color := clBlack;\r\n                        Pen.Color := clBlack;\r\n                        Polygon([Point(0, 2), Point(8, 2), Point(4, 6)]);\r\n                      end\r\n                        else\r\n                          begin\r\n                            // Button style is rectangular. Now ButtonFillMode determines how to fill the interior.\r\n                            if FButtonFillMode in [fmTreeColor, fmWindowColor, fmTransparent] then\r\n                            begin\r\n                              case FButtonFillMode of\r\n                                fmTreeColor:\r\n                                  Brush.Color := FColors.BackGroundColor;\r\n                                fmWindowColor:\r\n                                  Brush.Color := clWindow;\r\n                              end;\r\n                              Pen.Color := FColors.TreeLineColor;\r\n                              Rectangle(0, 0, Width, Height);\r\n                              Pen.Color := FColors.NodeFontColor;\r\n                              MoveTo(2, Width div 2);\r\n                              LineTo(Width - 2, Width div 2);\r\n                            end\r\n                              else\r\n                                FMinusBM.Handle := LoadBitmap(HInstance, 'VT_XPBUTTONMINUS');\r\n                          end;\r\n                      FHotMinusBM.Canvas.Draw(0, 0, FMinusBM);\r\n                      FSelectedHotMinusBM.Canvas.Draw(0, 0, FMinusBM);\r\n                    end;\r\n                  end;\r\n                end;\r\n                with FPlusBM, Canvas do\r\n                begin\r\n                  FillBitmap(FPlusBM);\r\n                  FillBitmap(FHotPlusBM);\r\n                  FillBitmap(FSelectedHotPlusBM);\r\n                  if Theme = 0 then\r\n                  begin\r\n                    if not(tsUseExplorerTheme in FStates) then\r\n                    begin\r\n                      if FButtonStyle = bsTriangle then\r\n                      begin\r\n                        Brush.Color := clBlack;\r\n                        Pen.Color := clBlack;\r\n                        Polygon([Point(2, 0), Point(6, 4), Point(2, 8)]);\r\n                      end\r\n                        else\r\n                          begin\r\n                            // Button style is rectangular. Now ButtonFillMode determines how to fill the interior.\r\n                            if FButtonFillMode in [fmTreeColor, fmWindowColor, fmTransparent] then\r\n                            begin\r\n                              case FButtonFillMode of\r\n                                fmTreeColor:\r\n                                  Brush.Color := FColors.BackGroundColor;\r\n                                fmWindowColor:\r\n                                  Brush.Color := clWindow;\r\n                              end;\r\n                              Pen.Color := FColors.TreeLineColor;\r\n                              Rectangle(0, 0, Width, Height);\r\n                              Pen.Color := FColors.NodeFontColor;\r\n                              MoveTo(2, Width div 2);\r\n                              LineTo(Width - 2, Width div 2);\r\n                              MoveTo(Width div 2, 2);\r\n                              LineTo(Width div 2, Width - 2);\r\n                            end\r\n                              else\r\n                                FPlusBM.Handle := LoadBitmap(HInstance, 'VT_XPBUTTONPLUS');\r\n                          end;\r\n                       FHotPlusBM.Canvas.Draw(0, 0, FPlusBM);\r\n                       FSelectedHotPlusBM.Canvas.Draw(0, 0, FPlusBM);\r\n                     end;\r\n                  end;\r\n                end;\r\n\r\n\r\n          // Overwrite glyph images if theme is active.\r\n          if (tsUseThemes in FStates) and (Theme <> 0) then\r\n          begin\r\n            R := Rect(0, 0, Size.cx, Size.cy);\r\n            DrawThemeBackground(Theme, FPlusBM.Canvas.Handle, TVP_GLYPH, GLPS_CLOSED, R, nil);\r\n            DrawThemeBackground(Theme, FMinusBM.Canvas.Handle, TVP_GLYPH, GLPS_OPENED, R, nil);\r\n            if tsUseExplorerTheme in FStates then\r\n            begin\r\n              DrawThemeBackground(Theme, FHotPlusBM.Canvas.Handle, TVP_HOTGLYPH, GLPS_CLOSED, R, nil);\r\n              DrawThemeBackground(Theme, FSelectedHotPlusBM.Canvas.Handle, TVP_HOTGLYPH, GLPS_CLOSED, R, nil);\r\n              DrawThemeBackground(Theme, FHotMinusBM.Canvas.Handle, TVP_HOTGLYPH, GLPS_OPENED, R, nil);\r\n              DrawThemeBackground(Theme, FSelectedHotMinusBM.Canvas.Handle, TVP_HOTGLYPH, GLPS_OPENED, R, nil);\r\n             end\r\n               else\r\n                 begin\r\n                   FHotPlusBM.Canvas.Draw(0, 0, FPlusBM);\r\n                   FSelectedHotPlusBM.Canvas.Draw(0, 0, FPlusBM);\r\n                   FHotMinusBM.Canvas.Draw(0, 0, FMinusBM);\r\n                   FSelectedHotMinusBM.Canvas.Draw(0, 0, FMinusBM);\r\n                 end;\r\n          end;\r\n        end;\r\n        if tsUseThemes in FStates then\r\n          CloseThemeData(Theme);\r\n      end;\r\n  end;\r\n\r\n  if NeedLines then\r\n  begin\r\n    if FDottedBrush <> 0 then\r\n      DeleteObject(FDottedBrush);\r\n    case FLineStyle of\r\n      lsDotted:\r\n        Bits := @LineBitsDotted;\r\n      lsSolid:\r\n        Bits := @LineBitsSolid;\r\n    else // lsCustomStyle\r\n      Bits := @LineBitsDotted;\r\n      DoGetLineStyle(Bits);\r\n    end;\r\n    PatternBitmap := CreateBitmap(8, 8, 1, 1, Bits);\r\n    FDottedBrush := CreatePatternBrush(PatternBitmap);\r\n    DeleteObject(PatternBitmap);\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\ntype\r\n  TOldVTOption = (voAcceptOLEDrop, voAnimatedToggle, voAutoDropExpand, voAutoExpand, voAutoScroll,\r\n    voAutoSort, voAutoSpanColumns, voAutoTristateTracking, voCheckSupport, voDisableDrawSelection, voEditable,\r\n    voExtendedFocus, voFullRowSelect, voGridExtensions, voHideFocusRect, voHideSelection, voHotTrack, voInitOnSave,\r\n    voLevelSelectConstraint, voMiddleClickSelect, voMultiSelect, voRightClickSelect, voPopupMode, voShowBackground,\r\n    voShowButtons, voShowDropmark, voShowHorzGridLines, voShowRoot, voShowTreeLines, voShowVertGridLines,\r\n    voSiblingSelectConstraint, voToggleOnDblClick);\r\n\r\nconst\r\n  OptionMap: array[TOldVTOption] of Integer = (\r\n    Ord(toAcceptOLEDrop), Ord(toAnimatedToggle), Ord(toAutoDropExpand), Ord(toAutoExpand), Ord(toAutoScroll),\r\n    Ord(toAutoSort), Ord(toAutoSpanColumns), Ord(toAutoTristateTracking), Ord(toCheckSupport), Ord(toDisableDrawSelection),\r\n    Ord(toEditable), Ord(toExtendedFocus), Ord(toFullRowSelect), Ord(toGridExtensions), Ord(toHideFocusRect),\r\n    Ord(toHideSelection), Ord(toHotTrack), Ord(toInitOnSave), Ord(toLevelSelectConstraint), Ord(toMiddleClickSelect),\r\n    Ord(toMultiSelect), Ord(toRightClickSelect), Ord(toPopupMode), Ord(toShowBackground),\r\n    Ord(toShowButtons), Ord(toShowDropmark), Ord(toShowHorzGridLines), Ord(toShowRoot), Ord(toShowTreeLines),\r\n    Ord(toShowVertGridLines), Ord(toSiblingSelectConstraint), Ord(toToggleOnDblClick)\r\n  );\r\n\r\nprocedure TBaseVirtualTree.ReadOldOptions(Reader: TReader);\r\n\r\n// Migration helper routine to silently convert forms containing the old tree options member into the new\r\n// sub-options structure.\r\n\r\nvar\r\n  OldOption: TOldVTOption;\r\n  EnumName: string;\r\n\r\nbegin\r\n  // If we are at design time currently then let the designer know we changed something.\r\n  UpdateDesigner;\r\n\r\n  // It should never happen at this place that there is something different than the old set.\r\n  if Reader.ReadValue = vaSet then\r\n  begin\r\n    // Remove all default values set by the constructor.\r\n    FOptions.AnimationOptions := [];\r\n    FOptions.AutoOptions := [];\r\n    FOptions.MiscOptions := [];\r\n    FOptions.PaintOptions := [];\r\n    FOptions.SelectionOptions := [];\r\n\r\n    while True do\r\n    begin\r\n      // Sets are stored with their members as simple strings. Read them one by one and map them to the new option\r\n      // in the correct sub-option set.\r\n      EnumName := Reader.ReadStr;\r\n      if EnumName = '' then\r\n        Break;\r\n      OldOption := TOldVTOption(GetEnumValue(TypeInfo(TOldVTOption), EnumName));\r\n      case OldOption of\r\n        voAcceptOLEDrop, voCheckSupport, voEditable, voGridExtensions, voInitOnSave, voToggleOnDblClick:\r\n          FOptions.MiscOptions := FOptions.FMiscOptions + [TVTMiscOption(OptionMap[OldOption])];\r\n        voAnimatedToggle:\r\n          FOptions.AnimationOptions := FOptions.FAnimationOptions + [TVTAnimationOption(OptionMap[OldOption])];\r\n        voAutoDropExpand, voAutoExpand, voAutoScroll, voAutoSort, voAutoSpanColumns, voAutoTristateTracking:\r\n          FOptions.AutoOptions := FOptions.FAutoOptions + [TVTAutoOption(OptionMap[OldOption])];\r\n        voDisableDrawSelection, voExtendedFocus, voFullRowSelect, voLevelSelectConstraint,\r\n        voMiddleClickSelect, voMultiSelect, voRightClickSelect, voSiblingSelectConstraint:\r\n          FOptions.SelectionOptions := FOptions.FSelectionOptions + [TVTSelectionOption(OptionMap[OldOption])];\r\n        voHideFocusRect, voHideSelection, voHotTrack, voPopupMode, voShowBackground, voShowButtons,\r\n        voShowDropmark, voShowHorzGridLines, voShowRoot, voShowTreeLines, voShowVertGridLines:\r\n          FOptions.PaintOptions := FOptions.FPaintOptions + [TVTPaintOption(OptionMap[OldOption])];\r\n      end;\r\n    end;\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.SetAlignment(const Value: TAlignment);\r\n\r\nbegin\r\n  if FAlignment <> Value then\r\n  begin\r\n    FAlignment := Value;\r\n    if not (csLoading in ComponentState) then\r\n      Invalidate;\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.SetAnimationDuration(const Value: Cardinal);\r\n\r\nbegin\r\n  FAnimationDuration := Value;\r\n  if FAnimationDuration = 0 then\r\n    Exclude(FOptions.FAnimationOptions, toAnimatedToggle)\r\n  else\r\n    Include(FOptions.FAnimationOptions, toAnimatedToggle);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.SetBackground(const Value: TPicture);\r\n\r\nbegin\r\n  FBackground.Assign(Value);\r\n  Invalidate;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.SetBackgroundOffset(const Index, Value: Integer);\r\n\r\nbegin\r\n  case Index of\r\n    0:\r\n      if FBackgroundOffsetX <> Value then\r\n      begin\r\n        FBackgroundOffsetX := Value;\r\n        Invalidate;\r\n      end;\r\n    1:\r\n      if FBackgroundOffsetY <> Value then\r\n      begin\r\n        FBackgroundOffsetY := Value;\r\n        Invalidate;\r\n      end;\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.SetBorderStyle(Value: TBorderStyle);\r\n\r\nbegin\r\n  if FBorderStyle <> Value then\r\n  begin\r\n    FBorderStyle := Value;\r\n    RecreateWnd;\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.SetBottomNode(Node: PVirtualNode);\r\n\r\nvar\r\n  Run: PVirtualNode;\r\n  R: TRect;\r\n\r\nbegin\r\n  if Assigned(Node) then\r\n  begin\r\n    // make sure all parents of the node are expanded\r\n    Run := Node.Parent;\r\n    while Run <> FRoot do\r\n    begin\r\n      if not (vsExpanded in Run.States) then\r\n        ToggleNode(Run);\r\n      Run := Run.Parent;\r\n    end;\r\n    R := GetDisplayRect(Node, FHeader.MainColumn, True);\r\n    DoSetOffsetXY(Point(FOffsetX, FOffsetY + ClientHeight - R.Top - Integer(NodeHeight[Node])),\r\n      [suoRepaintScrollBars, suoUpdateNCArea]);\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.SetBottomSpace(const Value: Cardinal);\r\n\r\nbegin\r\n  if FBottomSpace <> Value then\r\n  begin\r\n    FBottomSpace := Value;\r\n    UpdateVerticalScrollBar(True);\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.SetButtonFillMode(const Value: TVTButtonFillMode);\r\n\r\nbegin\r\n  if FButtonFillMode <> Value then\r\n  begin\r\n    FButtonFillMode := Value;\r\n    if not (csLoading in ComponentState) then\r\n    begin\r\n      PrepareBitmaps(True, False);\r\n      if HandleAllocated then\r\n        Invalidate;\r\n    end;\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.SetButtonStyle(const Value: TVTButtonStyle);\r\n\r\nbegin\r\n  if FButtonStyle <> Value then\r\n  begin\r\n    FButtonStyle := Value;\r\n    if not (csLoading in ComponentState) then\r\n    begin\r\n      PrepareBitmaps(True, False);\r\n      if HandleAllocated then\r\n        Invalidate;\r\n    end;\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.SetCheckImageKind(Value: TCheckImageKind);\r\n\r\nbegin\r\n  if FCheckImageKind <> Value then\r\n  begin\r\n    FCheckImageKind := Value;\r\n    FCheckImages := GetCheckImageListFor(Value);\r\n    if not Assigned(FCheckImages) then\r\n      FCheckImages := FCustomCheckImages;\r\n    if HandleAllocated and (FUpdateCount = 0) and not (csLoading in ComponentState) then\r\n      InvalidateRect(Handle, nil, False);\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.SetCheckState(Node: PVirtualNode; Value: TCheckState);\r\n\r\nbegin\r\n  if (Node.CheckState <> Value) and not (vsDisabled in Node.States) and DoChecking(Node, Value) then\r\n    DoCheckClick(Node, Value);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.SetCheckStateForAll(aCheckState: TCheckState; pSelectedOnly: Boolean);\r\n\r\n// Changes the check state for all or for all seledcted nodes.\r\n// aCheckState: The new check state.\r\n// pSelectedOnly: If passed True, only the selected nodes will bechnaged, I f apssed Falsee all nodes in the control will be changed.\r\n\r\nvar\r\n  lItem : PVirtualNode;\r\nbegin\r\n  With Self do begin\r\n    Screen.Cursor := crHourGlass;\r\n    BeginUpdate;\r\n    try\r\n      if pSelectedOnly then\r\n        lItem := GetFirstSelected\r\n      else\r\n        lItem := GetFirst;\r\n      //for i:=0 to List.Items.Count-1 do begin\r\n      while Assigned(lItem) do begin\r\n        CheckState[lItem] := aCheckState;\r\n        if pSelectedOnly then\r\n          lItem := GetNextSelected(lItem)\r\n        else\r\n          lItem := GetNext(lItem);\r\n      end;//while\r\n    finally\r\n      Screen.Cursor := crDefault;\r\n      EndUpdate;\r\n    end;//try..finally\r\n  end;//With\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.SetCheckType(Node: PVirtualNode; Value: TCheckType);\r\n\r\nbegin\r\n  if (Node.CheckType <> Value) and not (toReadOnly in FOptions.FMiscOptions) then\r\n  begin\r\n    Node.CheckType := Value;\r\n    if (Value <> ctTriStateCheckBox) and (Node.CheckState in [csMixedNormal, csMixedPressed]) then\r\n      Node.CheckState := csUncheckedNormal;// reset check state if it doesn't fit the new check type\r\n    // For check boxes with tri-state check box parents we have to initialize differently.\r\n    if (toAutoTriStateTracking in FOptions.FAutoOptions) and (Value in [ctCheckBox, ctTriStateCheckBox]) and\r\n      (Node.Parent <> FRoot) then\r\n    begin\r\n      if not (vsInitialized in Node.Parent.States) then\r\n        InitNode(Node.Parent);\r\n      if (Node.Parent.CheckType = ctTriStateCheckBox) and\r\n        (Node.Parent.CheckState in [csUncheckedNormal, csCheckedNormal]) then\r\n        CheckState[Node] := Node.Parent.CheckState;\r\n    end;\r\n    InvalidateNode(Node);\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.SetChildCount(Node: PVirtualNode; NewChildCount: Cardinal);\r\n\r\n// Changes a node's child structure to accomodate the new child count. This is used to add or delete\r\n// child nodes to/from the end of the node's child list. To insert or delete a specific node a separate\r\n// routine is used.\r\n\r\nvar\r\n  Remaining: Cardinal;\r\n  Index: Cardinal;\r\n  Child: PVirtualNode;\r\n  Count: Integer;\r\n  NewHeight: Integer;\r\nbegin\r\n  if not (toReadOnly in FOptions.FMiscOptions) then\r\n  begin\r\n    if Node = nil then\r\n      Node := FRoot;\r\n\r\n    if NewChildCount = 0 then\r\n      DeleteChildren(Node)\r\n    else\r\n    begin\r\n      // If nothing changed then do nothing.\r\n      if NewChildCount <> Node.ChildCount then\r\n      begin\r\n        InterruptValidation;\r\n\r\n        if NewChildCount > Node.ChildCount then\r\n        begin\r\n          Remaining := NewChildCount - Node.ChildCount;\r\n          Count := Remaining;\r\n          NewHeight := Node.TotalHeight;\r\n\r\n          // New nodes to add.\r\n          if Assigned(Node.LastChild) then\r\n            Index := Node.LastChild.Index + 1\r\n          else\r\n          begin\r\n            Index := 0;\r\n            Include(Node.States, vsHasChildren);\r\n          end;\r\n          Node.States := Node.States - [vsAllChildrenHidden, vsHeightMeasured];\r\n          if (vsExpanded in Node.States) and FullyVisible[Node] then\r\n            Inc(FVisibleCount, Count); // Do this before a possible init of the sub-nodes in DoMeasureItem()\r\n\r\n          // New nodes are by default always visible, so we don't need to check the visibility.\r\n          while Remaining > 0 do\r\n          begin\r\n            Child := MakeNewNode;\r\n            Child.Index := Index;\r\n            Child.PrevSibling := Node.LastChild;\r\n            if Assigned(Node.LastChild) then\r\n              Node.LastChild.NextSibling := Child;\r\n            Child.Parent := Node;\r\n            Node.LastChild := Child;\r\n            if Node.FirstChild = nil then\r\n              Node.FirstChild := Child;\r\n            Dec(Remaining);\r\n            Inc(Index);\r\n\r\n            if (toVariableNodeHeight in FOptions.FMiscOptions) then\r\n              GetNodeHeight(Child);\r\n            Inc(NewHeight, Child.TotalHeight);\r\n          end;\r\n\r\n          if vsExpanded in Node.States then\r\n            AdjustTotalHeight(Node, NewHeight, False);\r\n\r\n          AdjustTotalCount(Node, Count, True);\r\n          Node.ChildCount := NewChildCount;\r\n          if (FUpdateCount = 0) and (toAutoSort in FOptions.FAutoOptions) and (FHeader.FSortColumn > InvalidColumn) then\r\n            Sort(Node, FHeader.FSortColumn, FHeader.FSortDirection, True);\r\n\r\n          InvalidateCache;\r\n        end//if NewChildCount > Node.ChildCount\r\n        else\r\n        begin\r\n          // Nodes have to be deleted.\r\n          Remaining := Node.ChildCount - NewChildCount;\r\n          while Remaining > 0 do\r\n          begin\r\n            DeleteNode(Node.LastChild);\r\n            Dec(Remaining);\r\n          end;\r\n        end;\r\n\r\n        if FUpdateCount = 0 then\r\n        begin\r\n          ValidateCache;\r\n          UpdateScrollBars(True);\r\n          Invalidate;\r\n        end;\r\n\r\n        if Node = FRoot then\r\n          StructureChange(nil, crChildAdded)\r\n        else\r\n          StructureChange(Node, crChildAdded);\r\n\r\n        // One may want to reinit the nodes here, especially to fix Issue #572 but that may trigger\r\n        // stack overflows in user code that calls AddChild inside the OnInitNode or OnInitChildren events.\r\n        //ReinitNode(Node, True);\r\n      end;\r\n    end;\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.SetClipboardFormats(const Value: TClipboardFormats);\r\n\r\nvar\r\n  I: Integer;\r\n\r\nbegin\r\n  // Add string by string instead doing an Assign or AddStrings because the list may return -1 for\r\n  // invalid entries which cause trouble for the standard implementation.\r\n  FClipboardFormats.Clear;\r\n  for I := 0 to Value.Count - 1 do\r\n    FClipboardFormats.Add(Value[I]);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.SetColors(const Value: TVTColors);\r\n\r\nbegin\r\n  FColors.Assign(Value);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.SetCustomCheckImages(const Value: TCustomImageList);\r\n\r\nbegin\r\n  if FCustomCheckImages <> Value then\r\n  begin\r\n    if Assigned(FCustomCheckImages) then\r\n    begin\r\n      FCustomCheckImages.UnRegisterChanges(FCustomCheckChangeLink);\r\n      FCustomCheckImages.RemoveFreeNotification(Self);\r\n      // Reset the internal check image list reference too, if necessary.\r\n      if FCheckImages = FCustomCheckImages then\r\n        FCheckImages := nil;\r\n    end;\r\n    FCustomCheckImages := Value;\r\n    if Assigned(FCustomCheckImages) then\r\n    begin\r\n      FCustomCheckImages.RegisterChanges(FCustomCheckChangeLink);\r\n      FCustomCheckImages.FreeNotification(Self);\r\n    end;\r\n    // Check if currently custom check images are active.\r\n    if FCheckImageKind = ckCustom then\r\n      FCheckImages := Value;\r\n    if not (csLoading in ComponentState) then\r\n      Invalidate;\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.SetDefaultNodeHeight(Value: Cardinal);\r\n\r\nbegin\r\n  if Value = 0 then\r\n    Value := 18;\r\n  if FDefaultNodeHeight <> Value then\r\n  begin\r\n    Inc(Integer(FRoot.TotalHeight), Integer(Value) - Integer(FDefaultNodeHeight));\r\n    Inc(SmallInt(FRoot.NodeHeight), Integer(Value) - Integer(FDefaultNodeHeight));\r\n    FDefaultNodeHeight := Value;\r\n    InvalidateCache;\r\n    if (FUpdateCount = 0) and HandleAllocated and not (csLoading in ComponentState) then\r\n    begin\r\n      ValidateCache;\r\n      UpdateScrollBars(True);\r\n      ScrollIntoView(FFocusedNode, toCenterScrollIntoView in FOptions.SelectionOptions, True);\r\n      Invalidate;\r\n    end;\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.SetDisabled(Node: PVirtualNode; Value: Boolean);\r\n\r\nbegin\r\n  if Assigned(Node) and (Value xor (vsDisabled in Node.States)) then\r\n  begin\r\n    if Value then\r\n      Include(Node.States, vsDisabled)\r\n    else\r\n      Exclude(Node.States, vsDisabled);\r\n\r\n    if FUpdateCount = 0 then\r\n      InvalidateNode(Node);\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.SetDoubleBuffered(const Value: Boolean);\r\nbegin\r\n  // empty by intention, we do our own buffering\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TBaseVirtualTree.GetDoubleBuffered: Boolean;\r\nbegin\r\n  Result := True; // we do our own buffering\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.SetEmptyListMessage(const Value: string);\r\n\r\nbegin\r\n  if Value <> EmptyListMessage then\r\n  begin\r\n    FEmptyListMessage := Value;\r\n    Invalidate;\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.SetExpanded(Node: PVirtualNode; Value: Boolean);\r\n\r\nbegin\r\n  if Assigned(Node) and (Node <> FRoot) and (Value xor (vsExpanded in Node.States)) then\r\n    ToggleNode(Node);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.SetFocusedColumn(Value: TColumnIndex);\r\n\r\nbegin\r\n  if (FFocusedColumn <> Value) and\r\n     DoFocusChanging(FFocusedNode, FFocusedNode, FFocusedColumn, Value) then\r\n  begin\r\n    CancelEditNode;\r\n    InvalidateColumn(FFocusedColumn);\r\n    InvalidateColumn(Value);\r\n    FFocusedColumn := Value;\r\n    if Assigned(FFocusedNode) and not (toDisableAutoscrollOnFocus in FOptions.FAutoOptions) then\r\n    begin\r\n      if ScrollIntoView(FFocusedNode, toCenterScrollIntoView in FOptions.SelectionOptions, True) then\r\n        InvalidateNode(FFocusedNode);\r\n    end;\r\n\r\n    if Assigned(FDropTargetNode) then\r\n      InvalidateNode(FDropTargetNode);\r\n\r\n    DoFocusChange(FFocusedNode, FFocusedColumn);\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.SetFocusedNode(Value: PVirtualNode);\r\n\r\nvar\r\n  WasDifferent: Boolean;\r\n\r\nbegin\r\n  WasDifferent := Value <> FFocusedNode;\r\n  DoFocusNode(Value, True);\r\n  // Do change event only if there was actually a change.\r\n  if WasDifferent and (FFocusedNode = Value) then\r\n    DoFocusChange(FFocusedNode, FFocusedColumn);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.SetFullyVisible(Node: PVirtualNode; Value: Boolean);\r\n\r\n// This method ensures that a node is visible and all its parent nodes are expanded and also visible\r\n// if Value is True. Otherwise the visibility flag of the node is reset but the expand state\r\n// of the parent nodes stays untouched.\r\n\r\nbegin\r\n  Assert(Assigned(Node) and (Node <> FRoot), 'Invalid parameter');\r\n\r\n  IsVisible[Node] := Value;\r\n  if Value then\r\n  begin\r\n    repeat\r\n      Node := Node.Parent;\r\n      if Node = FRoot then\r\n        Break;\r\n      if not (vsExpanded in Node.States) then\r\n        ToggleNode(Node);\r\n      if not (vsVisible in Node.States) then\r\n        IsVisible[Node] := True;\r\n    until False;\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.SetHasChildren(Node: PVirtualNode; Value: Boolean);\r\n\r\nbegin\r\n  if Assigned(Node) and not (toReadOnly in FOptions.FMiscOptions) then\r\n  begin\r\n    if Value then\r\n      Include(Node.States, vsHasChildren)\r\n    else\r\n    begin\r\n      Exclude(Node.States, vsHasChildren);\r\n      DeleteChildren(Node);\r\n    end;\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.SetHeader(const Value: TVTHeader);\r\n\r\nbegin\r\n  FHeader.Assign(Value);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.SetFiltered(Node: PVirtualNode; Value: Boolean);\r\n\r\n// Sets the 'filtered' flag of the given node according to Value and updates all dependent states.\r\n\r\nvar\r\n  NeedUpdate: Boolean;\r\n\r\nbegin\r\n  Assert(Assigned(Node) and (Node <> FRoot), 'Invalid parameter.');\r\n\r\n  // Initialize the node if necessary as this might change the filtered state.\r\n  if not (vsInitialized in Node.States) then\r\n    InitNode(Node);\r\n\r\n  if Value <> (vsFiltered in Node.States) then\r\n  begin\r\n    InterruptValidation;\r\n    NeedUpdate := False;\r\n    if Value then\r\n    begin\r\n      Include(Node.States, vsFiltered);\r\n      if not (toShowFilteredNodes in FOptions.FPaintOptions) then\r\n      begin\r\n        if vsInitializing in Node.States then\r\n          AdjustTotalHeight(Node, 0, False)\r\n        else\r\n          AdjustTotalHeight(Node, -Integer(NodeHeight[Node]), True);\r\n        if FullyVisible[Node] then\r\n        begin\r\n          Dec(FVisibleCount);\r\n          NeedUpdate := True;\r\n        end;\r\n      end;\r\n\r\n      if FUpdateCount = 0 then\r\n        DetermineHiddenChildrenFlag(Node.Parent)\r\n      else\r\n        Include(FStates, tsUpdateHiddenChildrenNeeded);\r\n    end\r\n    else\r\n    begin\r\n      Exclude(Node.States, vsFiltered);\r\n      if not (toShowFilteredNodes in FOptions.FPaintOptions) then\r\n      begin\r\n        AdjustTotalHeight(Node, Integer(NodeHeight[Node]), True);\r\n        if FullyVisible[Node] then\r\n        begin\r\n          Inc(FVisibleCount);\r\n          NeedUpdate := True;\r\n        end;\r\n      end;\r\n\r\n      if vsVisible in Node.States then\r\n        // Update the hidden children flag of the parent.\r\n        // Since this node is now visible we simply have to remove the flag.\r\n        Exclude(Node.Parent.States, vsAllChildrenHidden);\r\n    end;\r\n\r\n    InvalidateCache;\r\n    if NeedUpdate and (FUpdateCount = 0) then\r\n    begin\r\n      ValidateCache;\r\n      UpdateScrollBars(True);\r\n      Invalidate;\r\n    end;\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\nprocedure TBaseVirtualTree.SetImages(const Value: TCustomImageList);\r\n\r\nbegin\r\n  if FImages <> Value then\r\n  begin\r\n    if Assigned(FImages) then\r\n    begin\r\n      FImages.UnRegisterChanges(FImageChangeLink);\r\n      FImages.RemoveFreeNotification(Self);\r\n    end;\r\n    FImages := Value;\r\n    if Assigned(FImages) then\r\n    begin\r\n      FImages.RegisterChanges(FImageChangeLink);\r\n      FImages.FreeNotification(Self);\r\n    end;\r\n    if not (csLoading in ComponentState) then\r\n      Invalidate;\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.SetIndent(Value: Cardinal);\r\n\r\nbegin\r\n  if FIndent <> Value then\r\n  begin\r\n    FIndent := Value;\r\n    if not (csLoading in ComponentState) and (FUpdateCount = 0) and HandleAllocated then\r\n    begin\r\n      UpdateScrollBars(True);\r\n      Invalidate;\r\n    end;\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.SetLineMode(const Value: TVTLineMode);\r\n\r\nbegin\r\n  if FLineMode <> Value then\r\n  begin\r\n    FLineMode := Value;\r\n    if HandleAllocated and not (csLoading in ComponentState) then\r\n      Invalidate;\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.SetLineStyle(const Value: TVTLineStyle);\r\n\r\nbegin\r\n  if FLineStyle <> Value then\r\n  begin\r\n    FLineStyle := Value;\r\n    if not (csLoading in ComponentState) then\r\n    begin\r\n      PrepareBitmaps(False, True);\r\n      if HandleAllocated then\r\n        Invalidate;\r\n    end;\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.SetMargin(Value: Integer);\r\n\r\nbegin\r\n  if FMargin <> Value then\r\n  begin\r\n    FMargin := Value;\r\n    if HandleAllocated and not (csLoading in ComponentState) then\r\n      Invalidate;\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.SetMultiline(Node: PVirtualNode; const Value: Boolean);\r\n\r\nbegin\r\n  if Assigned(Node) and (Node <> FRoot) then\r\n    if Value <> (vsMultiline in Node.States) then\r\n    begin\r\n      if Value then\r\n        Include(Node.States, vsMultiline)\r\n      else\r\n        Exclude(Node.States, vsMultiline);\r\n\r\n      if FUpdateCount = 0 then\r\n        InvalidateNode(Node);\r\n    end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.SetNodeAlignment(const Value: TVTNodeAlignment);\r\n\r\nbegin\r\n  if FNodeAlignment <> Value then\r\n  begin\r\n    FNodeAlignment := Value;\r\n    if HandleAllocated and not (csReading in ComponentState) then\r\n      Invalidate;\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.SetNodeData(pNode: PVirtualNode; pUserData: Pointer);\r\n\r\n  // Can be used to set user data of a PVirtualNode with the size of a pointer, useful for setting\r\n  // A pointer to a record or a reference to a class instance.\r\n\r\nvar\r\n  NodeData: ^Pointer;\r\nbegin\r\n  // Check if there is initial user data and there is also enough user data space allocated.\r\n  Assert(FNodeDataSize >= SizeOf(Pointer), Self.Classname + ': Cannot set initial user data because there is not enough user data space allocated.');\r\n  NodeData := @pNode.Data;\r\n  NodeData^ := pUserData;\r\n  Include(pNode.States, vsOnFreeNodeCallRequired);\r\nend;\r\n\r\nprocedure TBaseVirtualTree.SetNodeData(pNode: PVirtualNode; pUserData: T);\r\n\r\n  // Can be used to set user data of a PVirtualNode to a class instance.\r\n\r\nbegin\r\n  SetNodeData(pNode, Pointer(pUserData));\r\nend;\r\n\r\nprocedure TBaseVirtualTree.SetNodeData(pNode: PVirtualNode; const pUserData: IInterface);\r\n\r\n  // Can be used to set user data of a PVirtualNode to a class instance,\r\n  // will take care about reference counting.\r\n\r\nbegin\r\n  pNode.SetData(pUserData);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.SetNodeDataSize(Value: Integer);\r\n\r\nvar\r\n  LastRootCount: Cardinal;\r\n\r\nbegin\r\n  if Value < -1 then\r\n    Value := -1;\r\n  if FNodeDataSize <> Value then\r\n  begin\r\n    FNodeDataSize := Value;\r\n    if not (csLoading in ComponentState) and not (csDesigning in ComponentState) then\r\n    begin\r\n      LastRootCount := FRoot.ChildCount;\r\n      Clear;\r\n      SetRootNodeCount(LastRootCount);\r\n    end;\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.SetNodeHeight(Node: PVirtualNode; Value: Cardinal);\r\n\r\nvar\r\n  Difference: Integer;\r\n\r\nbegin\r\n  if Assigned(Node) and (Node <> FRoot) and (Node.NodeHeight <> Value) and not (toReadOnly in FOptions.FMiscOptions) then\r\n  begin\r\n    Difference := Integer(Value) - Integer(Node.NodeHeight);\r\n    Node.NodeHeight := Value;\r\n\r\n    // If the node is effectively filtered out, nothing else has to be done, as it is not visible anyway.\r\n    if not IsEffectivelyFiltered[Node] then\r\n    begin\r\n      AdjustTotalHeight(Node, Difference, True);\r\n\r\n      // If an edit operation is currently active then update the editors boundaries as well.\r\n      UpdateEditBounds;\r\n\r\n      InvalidateCache;\r\n      // Stay away from touching the node cache while it is being validated.\r\n      if not (tsValidating in FStates) and FullyVisible[Node] and not IsEffectivelyFiltered[Node] then\r\n      begin\r\n        if (FUpdateCount = 0) and ([tsPainting, tsSizing] * FStates = []) then\r\n        begin\r\n          ValidateCache;\r\n          InvalidateToBottom(Node);\r\n          UpdateScrollBars(True);\r\n        end;\r\n      end;\r\n    end;\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.SetNodeParent(Node: PVirtualNode; const Value: PVirtualNode);\r\n\r\nbegin\r\n  if Assigned(Node) and Assigned(Value) and (Node.Parent <> Value) then\r\n    MoveTo(Node, Value, amAddChildLast, False);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.SetOffsetX(const Value: Integer);\r\n\r\nbegin\r\n  DoSetOffsetXY(Point(Value, FOffsetY), DefaultScrollUpdateFlags);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.SetOffsetXY(const Value: TPoint);\r\n\r\nbegin\r\n  DoSetOffsetXY(Value, DefaultScrollUpdateFlags);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.SetOffsetY(const Value: Integer);\r\n\r\nbegin\r\n  DoSetOffsetXY(Point(FOffsetX, Value), DefaultScrollUpdateFlags);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.SetOptions(const Value: TCustomVirtualTreeOptions);\r\n\r\nbegin\r\n  FOptions.Assign(Value);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.SetRootNodeCount(Value: Cardinal);\r\n\r\nbegin\r\n  // Don't set the root node count until all other properties (in particular the OnInitNode event) have been set.\r\n  if csLoading in ComponentState then\r\n  begin\r\n    FRoot.ChildCount := Value;\r\n    DoStateChange([tsNeedRootCountUpdate]);\r\n  end\r\n  else\r\n    if FRoot.ChildCount <> Value then\r\n    begin\r\n      BeginUpdate;\r\n      InterruptValidation;\r\n      SetChildCount(FRoot, Value);\r\n      EndUpdate;\r\n    end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.SetScrollBarOptions(Value: TScrollBarOptions);\r\n\r\nbegin\r\n  FScrollBarOptions.Assign(Value);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.SetSearchOption(const Value: TVTIncrementalSearch);\r\n\r\nbegin\r\n  if FIncrementalSearch <> Value then\r\n  begin\r\n    FIncrementalSearch := Value;\r\n    if FIncrementalSearch = isNone then\r\n    begin\r\n      StopTimer(SearchTimer);\r\n      FSearchBuffer := '';\r\n      FLastSearchNode := nil;\r\n    end;\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.SetSelected(Node: PVirtualNode; Value: Boolean);\r\n\r\nbegin\r\n  if not FSelectionLocked and Assigned(Node) and (Node <> FRoot) and (Value xor (vsSelected in Node.States)) then\r\n  begin\r\n    if Value then\r\n    begin\r\n      if FSelectionCount = 0 then\r\n        FRangeAnchor := Node\r\n      else\r\n        if not (toMultiSelect in FOptions.FSelectionOptions) then\r\n          ClearSelection;\r\n\r\n      AddToSelection(Node);\r\n\r\n      if not (toMultiSelect in FOptions.FSelectionOptions) then\r\n        FocusedNode := Node; // if only one node can be selected, make sure the focused node changes with the selected node\r\n      // Make sure there is a valid column selected (if there are columns at all).\r\n      if ((FFocusedColumn < 0) or not (coVisible in FHeader.Columns[FFocusedColumn].Options)) and\r\n        (FHeader.MainColumn > NoColumn) then\r\n        if ([coVisible, coAllowFocus] *  FHeader.Columns[FHeader.MainColumn].Options = [coVisible, coAllowFocus]) then\r\n          FFocusedColumn := FHeader.MainColumn\r\n        else\r\n          FFocusedColumn := FHeader.Columns.GetFirstVisibleColumn(True);\r\n      if FRangeAnchor = nil then\r\n        FRangeAnchor := Node;\r\n    end\r\n    else\r\n    begin\r\n      RemoveFromSelection(Node);\r\n      if FSelectionCount = 0 then\r\n        ResetRangeAnchor;\r\n    end;\r\n    if FullyVisible[Node] and not IsEffectivelyFiltered[Node] then\r\n      InvalidateNode(Node);\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.SetSelectionCurveRadius(const Value: Cardinal);\r\n\r\nbegin\r\n  if FSelectionCurveRadius <> Value then\r\n  begin\r\n    FSelectionCurveRadius := Value;\r\n    if HandleAllocated and not (csLoading in ComponentState) then\r\n      Invalidate;\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.SetStateImages(const Value: TCustomImageList);\r\n\r\nbegin\r\n  if FStateImages <> Value then\r\n  begin\r\n    if Assigned(FStateImages) then\r\n    begin\r\n      FStateImages.UnRegisterChanges(FStateChangeLink);\r\n      FStateImages.RemoveFreeNotification(Self);\r\n    end;\r\n    FStateImages := Value;\r\n    if Assigned(FStateImages) then\r\n    begin\r\n      FStateImages.RegisterChanges(FStateChangeLink);\r\n      FStateImages.FreeNotification(Self);\r\n    end;\r\n    if HandleAllocated and not (csLoading in ComponentState) then\r\n      Invalidate;\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.SetTextMargin(Value: Integer);\r\n\r\nbegin\r\n  if FTextMargin <> Value then\r\n  begin\r\n    FTextMargin := Value;\r\n    if not (csLoading in ComponentState) then\r\n      Invalidate;\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.SetTopNode(Node: PVirtualNode);\r\n\r\nvar\r\n  R: TRect;\r\n  Run: PVirtualNode;\r\n\r\nbegin\r\n  if Assigned(Node) then\r\n  begin\r\n    // make sure all parents of the node are expanded\r\n    Run := Node.Parent;\r\n    while Run <> FRoot do\r\n    begin\r\n      if not (vsExpanded in Run.States) then\r\n        ToggleNode(Run);\r\n      Run := Run.Parent;\r\n    end;\r\n    R := GetDisplayRect(Node, FHeader.MainColumn, True);\r\n    SetOffsetY(FOffsetY - R.Top);\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.SetUpdateState(Updating: Boolean);\r\n\r\nbegin\r\n  // The check for visibility is necessary otherwise the tree is automatically shown when\r\n  // updating is allowed. As this happens internally the VCL does not get notified and\r\n  // still assumes the control is hidden. This results in weird \"cannot focus invisible control\" errors.\r\n  if Visible and HandleAllocated and (FUpdateCount = 0) then\r\n    SendMessage(Handle, WM_SETREDRAW, Ord(not Updating), 0);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.SetVerticalAlignment(Node: PVirtualNode; Value: Byte);\r\n\r\nbegin\r\n  if Value > 100 then\r\n    Value := 100;\r\n  if Node.Align <> Value then\r\n  begin\r\n    Node.Align := Value;\r\n    if FullyVisible[Node] and not IsEffectivelyFiltered[Node] then\r\n      InvalidateNode(Node);\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.SetVisible(Node: PVirtualNode; Value: Boolean);\r\n\r\n// Sets the visibility style of the given node according to Value.\r\n\r\nvar\r\n  NeedUpdate: Boolean;\r\n\r\nbegin\r\n  Assert(Assigned(Node) and (Node <> FRoot), 'Invalid parameter.');\r\n\r\n  if Value <> (vsVisible in Node.States) then\r\n  begin\r\n    InterruptValidation;\r\n    NeedUpdate := False;\r\n    if Value then\r\n    begin\r\n      Include(Node.States, vsVisible);\r\n      if vsExpanded in Node.Parent.States then\r\n        AdjustTotalHeight(Node.Parent, Node.TotalHeight, True);\r\n      if VisiblePath[Node] then\r\n      begin\r\n        Inc(FVisibleCount, CountVisibleChildren(Node) + Cardinal(IfThen(IsEffectivelyVisible[Node], 1)));\r\n        NeedUpdate := True;\r\n      end;\r\n\r\n      // Update the hidden children flag of the parent.\r\n      // Since this node is now visible we simply have to remove the flag.\r\n      if not IsEffectivelyFiltered[Node] then\r\n        Exclude(Node.Parent.States, vsAllChildrenHidden);\r\n    end\r\n    else\r\n    begin\r\n      if vsExpanded in Node.Parent.States then\r\n        AdjustTotalHeight(Node.Parent, -Integer(Node.TotalHeight), True);\r\n      if VisiblePath[Node] then\r\n      begin\r\n        Dec(FVisibleCount, CountVisibleChildren(Node) + Cardinal(IfThen(IsEffectivelyVisible[Node], 1)));\r\n        NeedUpdate := True;\r\n      end;\r\n      Exclude(Node.States, vsVisible);\r\n\r\n      if FUpdateCount = 0 then\r\n        DetermineHiddenChildrenFlag(Node.Parent)\r\n      else\r\n        Include(FStates, tsUpdateHiddenChildrenNeeded);\r\n    end;\r\n\r\n    InvalidateCache;\r\n    if NeedUpdate and (FUpdateCount = 0) then\r\n    begin\r\n      ValidateCache;\r\n      UpdateScrollBars(True);\r\n      Invalidate;\r\n    end;\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.SetVisiblePath(Node: PVirtualNode; Value: Boolean);\r\n\r\n// If Value is True then all parent nodes of Node are expanded.\r\n\r\nbegin\r\n  Assert(Assigned(Node) and (Node <> FRoot), 'Invalid parameter.');\r\n\r\n  if Value then\r\n  begin\r\n    repeat\r\n      Node := Node.Parent;\r\n      if Node = FRoot then\r\n        Break;\r\n      if not (vsExpanded in Node.States) then\r\n        ToggleNode(Node);\r\n    until False;\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.StaticBackground(Source: TBitmap; Target: TCanvas; OffsetPosition: TPoint; R: TRect);\r\n\r\n// Draws the given source graphic so that it stays static in the given rectangle which is relative to the target bitmap.\r\n// The graphic is aligned so that it always starts at the upper left corner of the target canvas.\r\n// Offset gives the position of the target window as a possible superordinated surface.\r\n\r\nconst\r\n  DST = $00AA0029; // Ternary Raster Operation - Destination unchanged\r\n\r\nvar\r\n  PicRect: TRect;\r\n  AreaRect: TRect;\r\n  DrawRect: TRect;\r\n\r\nbegin\r\n  // clear background\r\n  Target.Brush.Color := Color;\r\n  Target.FillRect(R);\r\n\r\n  // Picture rect in relation to client viewscreen.\r\n  PicRect := Rect(FBackgroundOffsetX, FBackgroundOffsetY, FBackgroundOffsetX + Source.Width, FBackgroundOffsetY + Source.Height);\r\n\r\n  // Area to be draw in relation to client viewscreen.\r\n  AreaRect := Rect(OffsetPosition.X + R.Left, OffsetPosition.Y + R.Top, OffsetPosition.X + R.Right, OffsetPosition.Y + R.Bottom);\r\n\r\n  // If picture falls in AreaRect, return intersection (DrawRect).\r\n  if IntersectRect(DrawRect, PicRect, AreaRect) then\r\n  begin\r\n    // Draw portion of image which falls in canvas area.\r\n    if Source.Transparent then\r\n    begin\r\n      // Leave transparent area as destination unchanged (DST), copy non-transparent areas to canvas (SRCCOPY).\r\n      MaskBlt(Target.Handle, DrawRect.Left - OffsetPosition.X, DrawRect.Top - OffsetPosition.Y, (DrawRect.Right - OffsetPosition.X) - (DrawRect.Left - OffsetPosition.X),\r\n        (DrawRect.Bottom - OffsetPosition.Y) - (DrawRect.Top - OffsetPosition.Y), Source.Canvas.Handle, DrawRect.Left - PicRect.Left, DrawRect.Top - PicRect.Top,\r\n        Source.MaskHandle, DrawRect.Left - PicRect.Left, DrawRect.Top - PicRect.Top, MakeROP4(DST, SRCCOPY));\r\n    end\r\n    else\r\n    begin\r\n      // copy image to destination\r\n      BitBlt(Target.Handle, DrawRect.Left - OffsetPosition.X, DrawRect.Top - OffsetPosition.Y, (DrawRect.Right - OffsetPosition.X) - (DrawRect.Left - OffsetPosition.X),\r\n        (DrawRect.Bottom - OffsetPosition.Y) - (DrawRect.Top - OffsetPosition.Y) + R.Top, Source.Canvas.Handle, DrawRect.Left - PicRect.Left, DrawRect.Top - PicRect.Top,\r\n        SRCCOPY);\r\n    end;\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.StopTimer(ID: Integer);\r\n\r\nbegin\r\n  if HandleAllocated then\r\n    KillTimer(Handle, ID);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.SetWindowTheme(const Theme: string);\r\n\r\nbegin\r\n  FChangingTheme := True;\r\n  Winapi.UxTheme.SetWindowTheme(Handle, PWideChar(Theme), nil);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.TileBackground(Source: TBitmap; Target: TCanvas; Offset: TPoint; R: TRect);\r\n\r\n// Draws the given source graphic so that it tiles into the given rectangle which is relative to the target bitmap.\r\n// The graphic is aligned so that it always starts at the upper left corner of the target canvas.\r\n// Offset gives the position of the target window in an possible superordinated surface.\r\n\r\nvar\r\n  SourceX,\r\n  SourceY,\r\n  TargetX,\r\n  DeltaY: Integer;\r\n\r\nbegin\r\n  with Target do\r\n  begin\r\n    SourceY := (R.Top + Offset.Y + FBackgroundOffsetY) mod Source.Height;\r\n    // Always wrap the source coordinates into positive range.\r\n    if SourceY < 0 then\r\n      SourceY := Source.Height + SourceY;\r\n\r\n    // Tile image vertically until target rect is filled.\r\n    while R.Top < R.Bottom do\r\n    begin\r\n      SourceX := (R.Left + Offset.X + FBackgroundOffsetX) mod Source.Width;\r\n      // always wrap the source coordinates into positive range\r\n      if SourceX < 0 then\r\n        SourceX := Source.Width + SourceX;\r\n\r\n      TargetX := R.Left;\r\n      // height of strip to draw\r\n      DeltaY := Min(R.Bottom - R.Top, Source.Height - SourceY);\r\n\r\n      // tile the image horizontally\r\n      while TargetX < R.Right do\r\n      begin\r\n        BitBlt(Handle, TargetX, R.Top, Min(R.Right - TargetX, Source.Width - SourceX), DeltaY,\r\n          Source.Canvas.Handle, SourceX, SourceY, SRCCOPY);\r\n        Inc(TargetX, Source.Width - SourceX);\r\n        SourceX := 0;\r\n      end;\r\n      Inc(R.Top, Source.Height - SourceY);\r\n      SourceY := 0;\r\n    end;\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TBaseVirtualTree.ToggleCallback(Step, StepSize: Integer; Data: Pointer): Boolean;\r\n\r\nvar\r\n  Column: TColumnIndex;\r\n  Run: TRect;\r\n  SecondaryStepSize: Integer;\r\n\r\n  //--------------- local functions -------------------------------------------\r\n\r\n  procedure EraseLine;\r\n\r\n  var\r\n    LocalBrush: HBRUSH;\r\n\r\n  begin\r\n    with TToggleAnimationData(Data^), FHeader.FColumns do\r\n    begin\r\n      // Iterate through all columns and erase background in their local color.\r\n      // LocalBrush is a brush in the color of the particular column.\r\n      Column := GetFirstVisibleColumn;\r\n      while (Column > InvalidColumn) and (Run.Left < ClientWidth) do\r\n      begin\r\n        GetColumnBounds(Column, Run.Left, Run.Right);\r\n        if coParentColor in Items[Column].FOptions then\r\n          FillRect(DC, Run, Brush)\r\n        else\r\n        begin\r\n          if VclStyleEnabled then\r\n            LocalBrush := CreateSolidBrush(ColorToRGB(FColors.BackGroundColor))\r\n          else\r\n            LocalBrush := CreateSolidBrush(ColorToRGB(Items[Column].Color));\r\n          FillRect(DC, Run, LocalBrush);\r\n          DeleteObject(LocalBrush);\r\n        end;\r\n        Column := GetNextVisibleColumn(Column);\r\n      end;\r\n    end;\r\n  end;\r\n\r\n  //---------------------------------------------------------------------------\r\n\r\n  procedure DoScrollUp(DC: HDC; Brush: HBRUSH; Area: TRect; Steps: Integer);\r\n\r\n  begin\r\n    ScrollDC(DC, 0, -Steps, Area, Area, 0, nil);\r\n\r\n    if Step = 0 then\r\n      if not FHeader.UseColumns then\r\n        FillRect(DC, Rect(Area.Left, Area.Bottom - Steps - 1, Area.Right, Area.Bottom), Brush)\r\n      else\r\n      begin\r\n        Run := Rect(Area.Left, Area.Bottom - Steps - 1, Area.Right, Area.Bottom);\r\n        EraseLine;\r\n      end;\r\n  end;\r\n\r\n  //---------------------------------------------------------------------------\r\n\r\n  procedure DoScrollDown(DC: HDC; Brush: HBRUSH; Area: TRect; Steps: Integer);\r\n\r\n  begin\r\n    ScrollDC(DC, 0, Steps, Area, Area, 0, nil);\r\n\r\n    if Step = 0 then\r\n      if not FHeader.UseColumns then\r\n        FillRect(DC, Rect(Area.Left, Area.Top, Area.Right, Area.Top + Steps + 1), Brush)\r\n      else\r\n      begin\r\n        Run := Rect(Area.Left, Area.Top, Area.Right, Area.Top + Steps + 1);\r\n        EraseLine;\r\n      end;\r\n  end;\r\n\r\n  //--------------- end local functions ---------------------------------------\r\n\r\nbegin\r\n  Result := True;\r\n  if StepSize > 0 then\r\n  begin\r\n    SecondaryStepSize := 0;\r\n    with TToggleAnimationData(Data^) do\r\n    begin\r\n      if Mode1 <> tamNoScroll then\r\n      begin\r\n        if Mode1 = tamScrollUp then\r\n          DoScrollUp(DC, Brush, R1, StepSize)\r\n        else\r\n          DoScrollDown(DC, Brush, R1, StepSize);\r\n\r\n        if (Mode2 <> tamNoScroll) and (ScaleFactor > 0) then\r\n        begin\r\n          // As this routine is able to scroll two independent areas at once, the missing StepSize is\r\n          // computed in that case. To ensure the maximal accuracy the rounding error is accumulated.\r\n          SecondaryStepSize := Round((StepSize + MissedSteps) * ScaleFactor);\r\n          MissedSteps := MissedSteps + StepSize * ScaleFactor - SecondaryStepSize;\r\n        end;\r\n      end\r\n      else\r\n        SecondaryStepSize := StepSize;\r\n\r\n      if Mode2 <> tamNoScroll then\r\n        if Mode2 = tamScrollUp then\r\n          DoScrollUp(DC, Brush, R2, SecondaryStepSize)\r\n        else\r\n          DoScrollDown(DC, Brush, R2, SecondaryStepSize);\r\n    end;\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.CMColorChange(var Message: TMessage);\r\n\r\nbegin\r\n  if not (csLoading in ComponentState) then\r\n  begin\r\n    PrepareBitmaps(True, False);\r\n    if HandleAllocated then\r\n      Invalidate;\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.CMCtl3DChanged(var Message: TMessage);\r\n\r\nbegin\r\n  inherited;\r\n  if FBorderStyle = bsSingle then\r\n    RecreateWnd;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.CMBiDiModeChanged(var Message: TMessage);\r\n\r\nbegin\r\n  inherited;\r\n\r\n  if UseRightToLeftAlignment then\r\n    FEffectiveOffsetX := Integer(FRangeX) - ClientWidth + FOffsetX\r\n  else\r\n    FEffectiveOffsetX := -FOffsetX;\r\n  if FEffectiveOffsetX < 0 then\r\n    FEffectiveOffsetX := 0;\r\n\r\n  if toAutoBidiColumnOrdering in FOptions.FAutoOptions then\r\n    FHeader.FColumns.ReorderColumns(UseRightToLeftAlignment);\r\n  FHeader.Invalidate(nil);\r\nend;\r\n\r\nprocedure TBaseVirtualTree.CMBorderChanged(var Message: TMessage);\r\nbegin\r\n  inherited;\r\n  if VclStyleEnabled and (seBorder in StyleElements) then\r\n    RecreateWnd;\r\nend;\r\n\r\nprocedure TBaseVirtualTree.CMParentDoubleBufferedChange(var Message: TMessage);\r\nbegin\r\n  // empty by intention, we do our own buffering\r\nend;\r\n\r\nprocedure TBaseVirtualTree.CMStyleChanged(var Message: TMessage);\r\nbegin\r\n  VclStyleChanged;\r\n  RecreateWnd;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.CMDenySubclassing(var Message: TMessage);\r\n\r\n// If a Windows XP Theme Manager component is used in the application it will try to subclass all controls which do not\r\n// explicitly deny this. Virtual Treeview knows how to handle XP themes so it does not need subclassing.\r\n\r\nbegin\r\n  Message.Result := 1;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.CMDrag(var Message: TCMDrag);\r\n\r\nvar\r\n  S: TObject;\r\n  ShiftState: Integer;\r\n  P: TPoint;\r\n  Formats: TFormatArray;\r\n  Effect: Integer;\r\n\r\nbegin\r\n  with Message, DragRec^ do\r\n  begin\r\n    S := Source;\r\n    Formats := nil;\r\n\r\n    // Let the ancestor handle dock operations.\r\n    if S is TDragDockObject then\r\n      inherited\r\n    else\r\n    begin\r\n      // We need an extra check for the control drag object as there might be other objects not derived from\r\n      // this class (e.g. TActionDragObject).\r\n      if not (tsUserDragObject in FStates) and (S is TBaseDragControlObject) then\r\n        S := (S as TBaseDragControlObject).Control;\r\n      case DragMessage of\r\n        dmDragEnter, dmDragLeave, dmDragMove:\r\n          begin\r\n            if DragMessage = dmDragEnter then\r\n              DoStateChange([tsVCLDragging]);\r\n            if DragMessage = dmDragLeave then\r\n              DoStateChange([tsVCLDragFinished], [tsVCLDragging]);\r\n\r\n            if DragMessage = dmDragMove then\r\n              with ScreenToClient(Pos) do\r\n                DoAutoScroll(X, Y);\r\n\r\n            ShiftState := 0;\r\n            // Alt key will be queried by the KeysToShiftState function in DragOver.\r\n            if GetKeyState(VK_SHIFT) < 0 then\r\n              ShiftState := ShiftState or MK_SHIFT;\r\n            if GetKeyState(VK_CONTROL) < 0 then\r\n              ShiftState := ShiftState or MK_CONTROL;\r\n\r\n            // Allowed drop effects are simulated for VCL dd.\r\n            Effect := DROPEFFECT_MOVE or DROPEFFECT_COPY;\r\n            DragOver(S, ShiftState, TDragState(DragMessage), Pos, Effect);\r\n            FLastVCLDragTarget := FDropTargetNode;\r\n            FVCLDragEffect := Effect;\r\n            if (DragMessage = dmDragLeave) and Assigned(FDropTargetNode) then\r\n            begin\r\n              InvalidateNode(FDropTargetNode);\r\n              FDropTargetNode := nil;\r\n            end;\r\n            Result := LRESULT(Effect);\r\n          end;\r\n        dmDragDrop:\r\n          begin\r\n            ShiftState := 0;\r\n            // Alt key will be queried by the KeysToShiftState function in DragOver\r\n            if GetKeyState(VK_SHIFT) < 0 then\r\n              ShiftState := ShiftState or MK_SHIFT;\r\n            if GetKeyState(VK_CONTROL) < 0 then\r\n              ShiftState := ShiftState or MK_CONTROL;\r\n\r\n            // allowed drop effects are simulated for VCL dd,\r\n            // replace target node with cached node from other VCL dd messages\r\n            if Assigned(FDropTargetNode) then\r\n              InvalidateNode(FDropTargetNode);\r\n            FDropTargetNode := FLastVCLDragTarget;\r\n            P := Point(Pos.X, Pos.Y);\r\n            P := ScreenToClient(P);\r\n            try\r\n              DoDragDrop(S, nil, Formats, KeysToShiftState(ShiftState), P, FVCLDragEffect, FLastDropMode);\r\n            finally\r\n              if Assigned(FDropTargetNode) then\r\n              begin\r\n                InvalidateNode(FDropTargetNode);\r\n                FDropTargetNode := nil;\r\n              end;\r\n            end;\r\n          end;\r\n        dmFindTarget:\r\n          begin\r\n            Result := LRESULT(ControlAtPos(ScreenToClient(Pos), False));\r\n            if Result = 0 then\r\n              Result := LRESULT(Self);\r\n\r\n            // This is a reliable place to check whether VCL drag has\r\n            // really begun.\r\n            if tsVCLDragPending in FStates then\r\n              DoStateChange([tsVCLDragging], [tsVCLDragPending, tsEditPending, tsClearPending]);\r\n          end;\r\n      end;\r\n    end;\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.CMEnabledChanged(var Message: TMessage);\r\n\r\nbegin\r\n  inherited;\r\n\r\n  // Need to invalidate the non-client area as well, since the header must be redrawn too.\r\n  if csDesigning in ComponentState then\r\n    RedrawWindow(Handle, nil, 0, RDW_FRAME or RDW_INVALIDATE or RDW_NOERASE or RDW_NOCHILDREN);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.CMFontChanged(var Message: TMessage);\r\n\r\nvar\r\n  HeaderMessage: TMessage;\r\n\r\nbegin\r\n  inherited;\r\n\r\n  if not (csLoading in ComponentState) then\r\n  begin\r\n    AutoScale();\r\n    PrepareBitmaps(True, False);\r\n    if HandleAllocated then\r\n      Invalidate;\r\n  end;\r\n\r\n  HeaderMessage.Msg := CM_PARENTFONTCHANGED;\r\n  HeaderMessage.WParam := 0;\r\n  HeaderMessage.LParam := 0;\r\n  HeaderMessage.Result := 0;\r\n  FHeader.HandleMessage(HeaderMessage);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.CMHintShow(var Message: TCMHintShow);\r\n\r\n// Determines hint message (tooltip) and out-of-hint rect.\r\n// Note: A special handling is needed here because we cannot pass wide strings back to the caller.\r\n//       I had to introduce the hint data record anyway so we can use this to pass the hint string.\r\n//       We still need to set a dummy hint string in the message to make the VCL showing the hint window.\r\n\r\nvar\r\n  NodeRect: TRect;\r\n  SpanColumn,\r\n  Dummy,\r\n  ColLeft,\r\n  ColRight: Integer;\r\n  HitInfo: THitInfo;\r\n  ShowOwnHint: Boolean;\r\n  IsFocusedOrEditing: Boolean;\r\n  ParentForm: TCustomForm;\r\n  BottomRightCellContentMargin: TPoint;\r\n  DummyLineBreakStyle: TVTTooltipLineBreakStyle;\r\n  HintKind: TVTHintKind;\r\nbegin\r\n  with Message do\r\n  begin\r\n    Result := 1;\r\n\r\n    if PtInRect(FLastHintRect, HintInfo.CursorPos) then\r\n      Exit;\r\n\r\n    // Determine node for which to show hint/tooltip.\r\n    with HintInfo^ do\r\n      GetHitTestInfoAt(CursorPos.X, CursorPos.Y, True, HitInfo);\r\n\r\n    // Make sure a hint is only shown if the tree or at least its parent form is active.\r\n    // Active editing is ok too as long as we don't want the hint for the current edit node.\r\n    if IsEditing then\r\n      IsFocusedOrEditing := HitInfo.HitNode <> FFocusedNode\r\n    else\r\n    begin\r\n      IsFocusedOrEditing := Focused;\r\n      ParentForm := GetParentForm(Self);\r\n      if Assigned(ParentForm) then\r\n        IsFocusedOrEditing := ParentForm.Focused or Application.Active;\r\n    end;\r\n\r\n    if (GetCapture = 0) and ShowHint and not (Dragging or IsMouseSelecting) and ([tsScrolling] * FStates = []) and\r\n      (FHeader.States = []) and IsFocusedOrEditing then\r\n    begin\r\n      with HintInfo^ do\r\n      begin\r\n        Result := 0;\r\n        ShowOwnHint := False;\r\n        // Assign a dummy string otherwise the VCL will not show the hint window.\r\n        if GetHintWindowClass.InheritsFrom(TVirtualTreeHintWindow) then\r\n          HintStr := ' '\r\n        else\r\n        begin\r\n          //workaround for issue #291\r\n          //it duplicates parts of the following code and code in TVirtualTreeHintWindow\r\n          HintStr := '';\r\n          if FHeader.UseColumns and (hoShowHint in FHeader.FOptions) and FHeader.InHeader(CursorPos) then\r\n          begin\r\n            CursorRect := FHeaderRect;\r\n            // Convert the cursor rectangle into real client coordinates.\r\n            OffsetRect(CursorRect, 0, -Integer(FHeader.FHeight));\r\n            HitInfo.HitColumn := FHeader.FColumns.GetColumnAndBounds(CursorPos, CursorRect.Left, CursorRect.Right);\r\n            if (HitInfo.HitColumn > -1) and not (csLButtonDown in ControlState) and\r\n              (FHeader.FColumns[HitInfo.HitColumn].FHint <> '') then\r\n              HintStr := FHeader.FColumns[HitInfo.HitColumn].FHint;\r\n          end\r\n          else\r\n          if HintMode = hmDefault then\r\n            HintStr := GetShortHint(Hint)\r\n          else\r\n          if Assigned(HitInfo.HitNode) and (HitInfo.HitColumn > InvalidColumn) then\r\n          begin\r\n            if HintMode = hmToolTip then\r\n              HintStr := DoGetNodeToolTip(HitInfo.HitNode, HitInfo.HitColumn, DummyLineBreakStyle)\r\n            else\r\n              HintStr := DoGetNodeHint(HitInfo.HitNode, HitInfo.HitColumn, DummyLineBreakStyle);\r\n          end;\r\n        end;\r\n\r\n        // First check whether there is a header hint to show.\r\n        if FHeader.UseColumns and (hoShowHint in FHeader.FOptions) and FHeader.InHeader(CursorPos) then\r\n        begin\r\n          CursorRect := FHeaderRect;\r\n          // Convert the cursor rectangle into real client coordinates.\r\n          OffsetRect(CursorRect, 0, -Integer(FHeader.FHeight));\r\n          HitInfo.HitColumn := FHeader.FColumns.GetColumnAndBounds(CursorPos, CursorRect.Left, CursorRect.Right);\r\n          // align the vertical hint position on the bottom bound of the header, but\r\n          // avoid overlapping of mouse cursor and hint\r\n          HintPos.Y := Max(HintPos.Y, ClientToScreen(Point(0, CursorRect.Bottom)).Y);\r\n          // Note: the test for the left mouse button in ControlState might cause problems whenever the VCL does not\r\n          //       realize when the button is released. This, for instance, happens when doing OLE drag'n drop and\r\n          //       cancel this with ESC.\r\n          if (HitInfo.HitColumn > -1) and not (csLButtonDown in ControlState) then\r\n          begin\r\n            FHintData.DefaultHint := FHeader.FColumns[HitInfo.HitColumn].FHint;\r\n            if FHintData.DefaultHint <> '' then\r\n              ShowOwnHint := True\r\n            else\r\n              Result := 1;\r\n          end\r\n          else\r\n            Result := 1;\r\n        end\r\n        else\r\n        begin\r\n          // Default mode is handled as would the tree be a usual VCL control (no own hint window necessary).\r\n          if FHintMode = hmDefault then\r\n            HintStr := GetShortHint(Hint)\r\n          else\r\n          begin\r\n            if Assigned(HitInfo.HitNode) and (HitInfo.HitColumn > InvalidColumn) then\r\n            begin\r\n              // An owner-draw tree should only display a hint when at least\r\n              // its OnGetHintSize event handler is assigned.\r\n              DoGetHintKind(HitInfo.HitNode, HitInfo.HitColumn, HintKind);\r\n              FHintData.HintRect := Rect(0, 0, 0, 0);\r\n              if (HintKind = vhkOwnerDraw) then\r\n              begin\r\n                DoGetHintSize(HitInfo.HitNode, HitInfo.HitColumn, FHintData.HintRect);\r\n                ShowOwnHint := not IsRectEmpty(FHintData.HintRect);\r\n              end\r\n              else\r\n                // For trees displaying text hints, a decision about showing the hint or not is based\r\n                // on the hint string (if it is empty then no hint is shown).\r\n                ShowOwnHint := True;\r\n\r\n              if ShowOwnHint then\r\n              begin\r\n                if HitInfo.HitColumn > NoColumn then\r\n                begin\r\n                  FHeader.FColumns.GetColumnBounds(HitInfo.HitColumn, ColLeft, ColRight);\r\n                  // The right column border might be extended if column spanning is enabled.\r\n                  if toAutoSpanColumns in FOptions.FAutoOptions then\r\n                  begin\r\n                    SpanColumn := HitInfo.HitColumn;\r\n                    repeat\r\n                      Dummy := FHeader.FColumns.GetNextVisibleColumn(SpanColumn);\r\n                      if (Dummy = InvalidColumn) or not ColumnIsEmpty(HitInfo.HitNode, Dummy) then\r\n                        Break;\r\n                      SpanColumn := Dummy;\r\n                    until False;\r\n                    if SpanColumn <> HitInfo.HitColumn then\r\n                      FHeader.FColumns.GetColumnBounds(SpanColumn, Dummy, ColRight);\r\n                  end;\r\n                end\r\n                else\r\n                begin\r\n                  ColLeft := 0;\r\n                  ColRight := ClientWidth;\r\n                end;\r\n\r\n                FHintData.DefaultHint := '';\r\n                if FHintMode <> hmTooltip then\r\n                begin\r\n                  // Node specific hint text.\r\n                  CursorRect := GetDisplayRect(HitInfo.HitNode, HitInfo.HitColumn, False);\r\n                  CursorRect.Left := ColLeft;\r\n                  CursorRect.Right := ColRight;\r\n                  // Align the vertical hint position on the bottom bound of the node, but\r\n                  // avoid overlapping of mouse cursor and hint.\r\n                  HintPos.Y := Max(HintPos.Y, ClientToScreen(CursorRect.BottomRight).Y) + 2;\r\n                end\r\n                else\r\n                begin\r\n                  // Tool tip to show. This means the full caption of the node must be displayed.\r\n                  if vsMultiline in HitInfo.HitNode.States then\r\n                  begin\r\n                    if hiOnItemLabel in HitInfo.HitPositions then\r\n                    begin\r\n                      ShowOwnHint := True;\r\n                      NodeRect := GetDisplayRect(HitInfo.HitNode, HitInfo.HitColumn, True, False);\r\n                    end;\r\n                  end\r\n                  else\r\n                  begin\r\n                    NodeRect := GetDisplayRect(HitInfo.HitNode, HitInfo.HitColumn, True, True, True);\r\n                    BottomRightCellContentMargin := DoGetCellContentMargin(HitInfo.HitNode, HitInfo.HitColumn, ccmtBottomRightOnly);\r\n\r\n                    ShowOwnHint := (HitInfo.HitColumn > InvalidColumn) and PtInRect(NodeRect, CursorPos) and\r\n                      (CursorPos.X <= ColRight) and (CursorPos.X >= ColLeft) and\r\n                      (\r\n                        // Show hint also if the node text is partially out of the client area.\r\n                        // \"ColRight - 1\", since the right column border is not part of this cell.\r\n                        ( (NodeRect.Right + BottomRightCellContentMargin.X) > Min(ColRight - 1, ClientWidth) ) or\r\n                        (NodeRect.Left < Max(ColLeft, 0)) or\r\n                        ( (NodeRect.Bottom + BottomRightCellContentMargin.Y) > ClientHeight ) or\r\n                        (NodeRect.Top < 0)\r\n                      );\r\n                  end;\r\n\r\n                  if ShowOwnHint then\r\n                  begin\r\n                    // Node specific hint text given will be retrieved when needed.\r\n                    FHintData.DefaultHint := '';\r\n                    HintPos := ClientToScreen(Point(NodeRect.Left, NodeRect.Top));\r\n                    CursorRect := NodeRect;\r\n                  end\r\n                  else\r\n                    // nothing to show\r\n                    Result := 1;\r\n                end;\r\n              end\r\n              else\r\n                Result := 1; // Avoid hint if this is a draw tree returning an empty hint rectangle.\r\n            end\r\n            else\r\n            begin\r\n              // No node so fall back to control's hint (if indicated) or show nothing.\r\n              if FHintMode = hmHintAndDefault then\r\n              begin\r\n                FHintData.DefaultHint := GetShortHint(Hint);\r\n                if Length(FHintData.DefaultHint) = 0 then\r\n                  Result := 1\r\n                else\r\n                  ShowOwnHint := True;\r\n              end\r\n              else\r\n                Result := 1;\r\n            end;\r\n          end;\r\n        end;\r\n\r\n        // Set our own hint window class and prepare structure to be passed to the hint window.\r\n        if ShowOwnHint and (Result = 0) then\r\n        begin\r\n          HintWindowClass := GetHintWindowClass;\r\n\r\n          FHintData.Tree := Self;\r\n          FHintData.Column := HitInfo.HitColumn;\r\n          FHintData.Node := HitInfo.HitNode;\r\n          FLastHintRect := CursorRect;\r\n          HintData := @FHintData;\r\n        end\r\n        else\r\n          FLastHintRect := Rect(0, 0, 0, 0);\r\n      end;\r\n\r\n      // Remind that a hint is about to show.\r\n      if Result = 0 then\r\n        DoStateChange([tsHint])\r\n      else\r\n        DoStateChange([], [tsHint]);\r\n    end;\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.CMHintShowPause(var Message: TCMHintShowPause);\r\n\r\n// Tells the application that the tree (and only the tree) does not want a delayed tool tip.\r\n// Normal hints / header hints use the default delay (except for the first time).\r\n\r\nvar\r\n  P: TPoint;\r\n\r\nbegin\r\n  // A little workaround is needed here to make the application class using the correct hint window class.\r\n  // Once the application gets ShowHint set to true (which is the case when we want to show hints in the tree) then\r\n  // an internal hint window will be created which is not our own class (because we don't set an application wide\r\n  // hint window class but only one for the tree). Unfortunately, this default hint window class will prevent\r\n  // hints for the non-client area to show up (e.g. for the header) by calling CancelHint whenever certain messages\r\n  // arrive. By setting the hint show pause to 0 if our hint class was not used recently we make sure\r\n  // that the hint timer (in Forms.pas) is not used and our class is created immediately.\r\n  if FHintWindowDestroyed then\r\n  begin\r\n    GetCursorPos(P);\r\n    // Check if the mouse is in the header or tool tips are enabled, which must be shown without delay anyway.\r\n    if FHeader.UseColumns and (hoShowHint in FHeader.FOptions) and FHeader.InHeader(ScreenToClient(P)) or\r\n      (FHintMode = hmToolTip) then\r\n      Message.Pause^ := 0;\r\n  end\r\n  else\r\n    if FHintMode = hmToolTip then\r\n      Message.Pause^ := 0;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.CMMouseEnter(var Message: TMessage);\r\nbegin\r\n  DoMouseEnter();\r\n  inherited;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.CMMouseLeave(var Message: TMessage);\r\n\r\nvar\r\n  LeaveStates: TVirtualTreeStates;\r\n\r\nbegin\r\n  // Reset the last used hint rectangle in case the mouse enters the window within the bounds\r\n  if Assigned(FHintData.Tree) then\r\n    FHintData.Tree.FLastHintRect := Rect(0, 0, 0, 0);\r\n\r\n  LeaveStates := [tsHint];\r\n  if [tsWheelPanning, tsWheelScrolling] * FStates = [] then\r\n  begin\r\n    StopTimer(ScrollTimer);\r\n    LeaveStates := LeaveStates + [tsScrollPending, tsScrolling];\r\n  end;\r\n  DoStateChange([], LeaveStates);\r\n  if Assigned(FCurrentHotNode) then\r\n  begin\r\n    DoHotChange(FCurrentHotNode, nil);\r\n    if (toHotTrack in FOptions.PaintOptions) or (toCheckSupport in FOptions.FMiscOptions) then\r\n      InvalidateNode(FCurrentHotNode);\r\n    FCurrentHotNode := nil;\r\n  end;\r\n\r\n  if Assigned(Header) then\r\n  begin\r\n    Header.FColumns.FDownIndex := NoColumn;\r\n    Header.FColumns.FHoverIndex := NoColumn;\r\n    Header.FColumns.FCheckBoxHit := False;\r\n  end;\r\n  DoMouseLeave();\r\n  inherited;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.CMMouseWheel(var Message: TCMMouseWheel);\r\n\r\nvar\r\n  ScrollAmount: Integer;\r\n  ScrollLines: DWORD;\r\n  RTLFactor: Integer;\r\n  WheelFactor: Double;\r\n\r\nbegin\r\n  StopWheelPanning;\r\n\r\n  inherited;\r\n\r\n  if Message.Result = 0  then\r\n  begin\r\n    with Message do\r\n    begin\r\n      Result := 1;\r\n      WheelFactor := WheelDelta / WHEEL_DELTA;\r\n      if (FRangeY > Cardinal(ClientHeight)) and (not (ssShift in ShiftState)) then\r\n      begin\r\n        // Scroll vertically if there's something to scroll...\r\n        if ssCtrl in ShiftState then\r\n          ScrollAmount := Trunc(WheelFactor * ClientHeight)\r\n        else\r\n        begin\r\n          SystemParametersInfo(SPI_GETWHEELSCROLLLINES, 0, @ScrollLines, 0);\r\n          if ScrollLines = WHEEL_PAGESCROLL then\r\n            ScrollAmount := Trunc(WheelFactor * ClientHeight)\r\n          else\r\n            ScrollAmount := Integer(Trunc(WheelFactor * ScrollLines * FDefaultNodeHeight));\r\n        end;\r\n        SetOffsetY(FOffsetY + ScrollAmount);\r\n      end\r\n      else\r\n      begin\r\n        // ...else scroll horizontally if there's something to scroll.\r\n        if UseRightToLeftAlignment then\r\n          RTLFactor := -1\r\n        else\r\n          RTLFactor := 1;\r\n\r\n        if ssCtrl in ShiftState then\r\n          ScrollAmount := Trunc(WheelFactor * (ClientWidth - FHeader.Columns.GetVisibleFixedWidth))\r\n        else\r\n        begin\r\n          SystemParametersInfo(SPI_GETWHEELSCROLLLINES, 0, @ScrollLines, 0);\r\n          ScrollAmount := Trunc(WheelFactor * ScrollLines * FHeader.Columns.GetScrollWidth);\r\n        end;\r\n        SetOffsetX(FOffsetX + RTLFactor * ScrollAmount);\r\n      end;\r\n    end;\r\n\r\n  end;\r\n\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\nprocedure TBaseVirtualTree.CMSysColorChange(var Message: TMessage);\r\n\r\nbegin\r\n  inherited;\r\n\r\n  ConvertImageList(LightCheckImages, 'VT_CHECK_LIGHT');\r\n  ConvertImageList(DarkCheckImages, 'VT_CHECK_DARK');\r\n  ConvertImageList(LightTickImages, 'VT_TICK_LIGHT');\r\n  ConvertImageList(DarkTickImages, 'VT_TICK_DARK');\r\n  ConvertImageList(FlatImages, 'VT_FLAT');\r\n  ConvertImageList(UtilityImages, 'VT_UTILITIES');\r\n  // XP images do not need to be converted.\r\n  // System check images do not need to be converted.\r\n  Message.Msg := WM_SYSCOLORCHANGE;\r\n  DefaultHandler(Message);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.TVMGetItem(var Message: TMessage);\r\n\r\n// Screen reader support function. The method returns information about a particular node.\r\n\r\nconst\r\n  StateMask = TVIS_STATEIMAGEMASK or TVIS_OVERLAYMASK or TVIS_EXPANDED or TVIS_DROPHILITED or TVIS_CUT or\r\n    TVIS_SELECTED or TVIS_FOCUSED;\r\n\r\nvar\r\n  Item: PTVItemEx;\r\n  Node: PVirtualNode;\r\n  Ghosted: Boolean;\r\n  ImageIndex: TImageIndex;\r\n  R: TRect;\r\n  Text: string;\r\nbegin\r\n  // We can only return valid data if a nodes reference is given.\r\n  Item := Pointer(Message.LParam);\r\n  Message.Result := Ord(((Item.mask and TVIF_HANDLE) <> 0) and Assigned(Item.hItem));\r\n  if Message.Result = 1 then\r\n  begin\r\n    Node := Pointer(Item.hItem);\r\n    // Child count requested?\r\n    if (Item.mask and TVIF_CHILDREN) <> 0 then\r\n      Item.cChildren := Node.ChildCount;\r\n    // Index for normal image requested?\r\n    if (Item.mask and TVIF_IMAGE) <> 0 then\r\n    begin\r\n      ImageIndex := -1;\r\n      DoGetImageIndex(Node, ikNormal, -1, Ghosted, ImageIndex);\r\n      Item.iImage := ImageIndex;\r\n    end;\r\n    // Index for selected image requested?\r\n    if (Item.mask and TVIF_SELECTEDIMAGE) <> 0 then\r\n    begin\r\n      ImageIndex := -1;\r\n      DoGetImageIndex(Node, ikSelected, -1, Ghosted, ImageIndex);\r\n      Item.iSelectedImage := ImageIndex;\r\n    end;\r\n    // State info requested?\r\n    if (Item.mask and TVIF_STATE) <> 0 then\r\n    begin\r\n      // Everything, which is possible is returned.\r\n      Item.stateMask := StateMask;\r\n      Item.state := 0;\r\n      if Node = FFocusedNode then\r\n        Item.state := Item.state or TVIS_FOCUSED;\r\n      if vsSelected in Node.States then\r\n        Item.state := Item.state or TVIS_SELECTED;\r\n      if vsCutOrCopy in Node.States then\r\n        Item.state := Item.state or TVIS_CUT;\r\n      if Node = FDropTargetNode then\r\n        Item.state := Item.state or TVIS_DROPHILITED;\r\n      if vsExpanded in Node.States then\r\n        Item.state := Item.state or TVIS_EXPANDED;\r\n\r\n      // Construct state image and overlay image indices. They are one based, btw.\r\n      // and zero means there is no image.\r\n      ImageIndex := -1;\r\n      DoGetImageIndex(Node, ikState, -1, Ghosted, ImageIndex);\r\n      Item.state := Item.state or Byte(IndexToStateImageMask(ImageIndex + 1));\r\n      ImageIndex := -1;\r\n      DoGetImageIndex(Node, ikOverlay, -1, Ghosted, ImageIndex);\r\n      Item.state := Item.state or Byte(IndexToOverlayMask(ImageIndex + 1));\r\n    end;\r\n    // Node caption requested?\r\n    if (Item.mask and TVIF_TEXT) <> 0 then\r\n    begin\r\n      GetTextInfo(Node, -1, Font, R, Text);\r\n\r\n      StrLCopy(Item.pszText, PWideChar(Text), Item.cchTextMax - 1);\r\n      Item.pszText[Length(Text)] := #0;\r\n    end;\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.TVMGetItemRect(var Message: TMessage);\r\n\r\n// Screen read support function. This method returns a node's display rectangle.\r\n\r\nvar\r\n  TextOnly: Boolean;\r\n  Node: PVirtualNode;\r\n\r\nbegin\r\n  // The lparam member is used two-way. On enter it contains a pointer to the item (node).\r\n  // On exit it is to be considered as pointer to a rectangle structure.\r\n  Node := Pointer(Pointer(Message.LParam)^);\r\n  Message.Result := Ord(IsVisible[Node]);\r\n  if Message.Result <> 0 then\r\n  begin\r\n    TextOnly := Message.WParam <> 0;\r\n    PRect(Message.LParam)^ := GetDisplayRect(Node, -1, TextOnly);\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.TVMGetNextItem(var Message: TMessage);\r\n\r\n// Screen read support function. This method returns a node depending on the requested case.\r\n\r\nvar\r\n  Node: PVirtualNode;\r\n\r\nbegin\r\n  // Start with a nil result.\r\n  Message.Result := 0;\r\n  Node := Pointer(Message.LParam);\r\n  case Message.WParam of\r\n    TVGN_CARET:\r\n      Message.Result := LRESULT(FFocusedNode);\r\n    TVGN_CHILD:\r\n      if Assigned(Node) then\r\n        Message.Result := LRESULT(GetFirstChild(Node));\r\n    TVGN_DROPHILITE:\r\n      Message.Result := LRESULT(FDropTargetNode);\r\n    TVGN_FIRSTVISIBLE:\r\n      Message.Result := LRESULT(GetFirstVisible(nil, True));\r\n    TVGN_LASTVISIBLE:\r\n      Message.Result := LRESULT(GetLastVisible(nil, True));\r\n    TVGN_NEXT:\r\n      if Assigned(Node) then\r\n        Message.Result := LRESULT(GetNextSibling(Node));\r\n    TVGN_NEXTVISIBLE:\r\n      if Assigned(Node) then\r\n        Message.Result := LRESULT(GetNextVisible(Node, True));\r\n    TVGN_PARENT:\r\n      if Assigned(Node) and (Node <> FRoot) and (Node.Parent <> FRoot) then\r\n        Message.Result := LRESULT(Node.Parent);\r\n    TVGN_PREVIOUS:\r\n      if Assigned(Node) then\r\n        Message.Result := LRESULT(GetPreviousSibling(Node));\r\n    TVGN_PREVIOUSVISIBLE:\r\n      if Assigned(Node) then\r\n        Message.Result := LRESULT(GetPreviousVisible(Node, True));\r\n    TVGN_ROOT:\r\n      Message.Result := LRESULT(GetFirst);\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.WMCancelMode(var Message: TWMCancelMode);\r\n\r\nbegin\r\n  // Clear any transient state.\r\n  StopTimer(ExpandTimer);\r\n  StopTimer(EditTimer);\r\n  StopTimer(HeaderTimer);\r\n  StopTimer(ScrollTimer);\r\n  StopTimer(SearchTimer);\r\n  StopTimer(ThemeChangedTimer);\r\n  FSearchBuffer := '';\r\n  FLastSearchNode := nil;\r\n\r\n  DoStateChange([], [tsClearPending, tsEditPending, tsOLEDragPending, tsVCLDragPending, tsDrawSelecting,\r\n    tsDrawSelPending, tsIncrementalSearching]);\r\n\r\n  inherited;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.WMChangeState(var Message: TMessage);\r\n\r\nvar\r\n  EnterStates,\r\n  LeaveStates: TVirtualTreeStates;\r\n\r\nbegin\r\n  EnterStates := [];\r\n  if csStopValidation in TChangeStates(Byte(Message.WParam)) then\r\n    Include(EnterStates, tsStopValidation);\r\n  if csUseCache in TChangeStates(Byte(Message.WParam)) then\r\n    Include(EnterStates, tsUseCache);\r\n  if csValidating in TChangeStates(Byte(Message.WParam)) then\r\n    Include(EnterStates, tsValidating);\r\n  if csValidationNeeded in TChangeStates(Byte(Message.WParam)) then\r\n    Include(EnterStates, tsValidationNeeded);\r\n\r\n  LeaveStates := [];\r\n  if csStopValidation in TChangeStates(Byte(Message.LParam)) then\r\n    Include(LeaveStates, tsStopValidation);\r\n  if csUseCache in TChangeStates(Byte(Message.LParam)) then\r\n    Include(LeaveStates, tsUseCache);\r\n  if csValidating in TChangeStates(Byte(Message.LParam)) then\r\n    Include(LeaveStates, tsValidating);\r\n  if csValidationNeeded in TChangeStates(Byte(Message.LParam)) then\r\n    Include(LeaveStates, tsValidationNeeded);\r\n\r\n  DoStateChange(EnterStates, LeaveStates);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.WMChar(var Message: TWMChar);\r\n\r\nbegin\r\n  if tsIncrementalSearchPending in FStates then\r\n  begin\r\n    HandleIncrementalSearch(Message.CharCode);\r\n    DoStateChange([], [tsIncrementalSearchPending]);\r\n  end;\r\n\r\n  inherited;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.WMContextMenu(var Message: TWMContextMenu);\r\n\r\n// This method is called when a popup menu is about to be displayed.\r\n// We have to cancel some pending states here to avoid interferences.\r\n\r\nbegin\r\n  DoStateChange([], [tsClearPending, tsEditPending, tsOLEDragPending, tsVCLDragPending]);\r\n\r\n  if not (tsPopupMenuShown in FStates) then\r\n    inherited;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.WMCopy(var Message: TWMCopy);\r\n\r\nbegin\r\n  CopyToClipboard;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.WMCut(var Message: TWMCut);\r\n\r\nbegin\r\n  CutToClipboard;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.WMEnable(var Message: TWMEnable);\r\n\r\nbegin\r\n  inherited;\r\n  RedrawWindow(Handle, nil, 0, RDW_FRAME or RDW_INVALIDATE or RDW_NOERASE or RDW_NOCHILDREN);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.WMEraseBkgnd(var Message: TWMEraseBkgnd);\r\n\r\nbegin\r\n  Message.Result := 1;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.WMGetDlgCode(var Message: TWMGetDlgCode);\r\n\r\nbegin\r\n  Message.Result := DLGC_WANTCHARS or DLGC_WANTARROWS;\r\n  if FWantTabs then\r\n    Message.Result := Message.Result or DLGC_WANTTAB;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.WMGetObject(var Message: TMessage);\r\n\r\nbegin\r\n  if TVTAccessibilityFactory.GetAccessibilityFactory <> nil then\r\n  begin\r\n    // Create the IAccessibles for the tree view and tree view items, if necessary.\r\n    if FAccessible = nil then\r\n      FAccessible := TVTAccessibilityFactory.GetAccessibilityFactory.CreateIAccessible(Self);\r\n    if FAccessibleItem = nil then\r\n      FAccessibleItem := TVTAccessibilityFactory.GetAccessibilityFactory.CreateIAccessible(Self);\r\n    if Cardinal(Message.LParam) = OBJID_CLIENT then\r\n      if Assigned(Accessible) then\r\n        Message.Result := LresultFromObject(IID_IAccessible, Message.WParam, FAccessible)\r\n      else\r\n        Message.Result := 0;\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.WMHScroll(var Message: TWMHScroll);\r\n\r\n  //--------------- local functions -------------------------------------------\r\n\r\n  function GetRealScrollPosition: Integer;\r\n\r\n  var\r\n    SI: TScrollInfo;\r\n    Code: Integer;\r\n\r\n  begin\r\n    SI.cbSize := SizeOf(TScrollInfo);\r\n    SI.fMask := SIF_TRACKPOS;\r\n    Code := SB_HORZ;\r\n    GetScrollInfo(Handle, Code, SI);\r\n    Result := SI.nTrackPos;\r\n  end;\r\n\r\n  //--------------- end local functions ---------------------------------------\r\n\r\nvar\r\n  RTLFactor: Integer;\r\n\r\nbegin\r\n  if UseRightToLeftAlignment then\r\n    RTLFactor := -1\r\n  else\r\n    RTLFactor := 1;\r\n\r\n  case Message.ScrollCode of\r\n    SB_BOTTOM:\r\n      SetOffsetX(-Integer(FRangeX));\r\n    SB_ENDSCROLL:\r\n      begin\r\n        DoStateChange([], [tsThumbTracking]);\r\n        // avoiding to adjust the vertical scroll position while tracking makes it much smoother\r\n        // but we need to adjust the final position here then\r\n        UpdateHorizontalScrollBar(False);\r\n      end;\r\n    SB_LINELEFT:\r\n      SetOffsetX(FOffsetX + RTLFactor * FScrollBarOptions.FIncrementX);\r\n    SB_LINERIGHT:\r\n      SetOffsetX(FOffsetX - RTLFactor * FScrollBarOptions.FIncrementX);\r\n    SB_PAGELEFT:\r\n      SetOffsetX(FOffsetX + RTLFactor * (ClientWidth - FHeader.Columns.GetVisibleFixedWidth));\r\n    SB_PAGERIGHT:\r\n      SetOffsetX(FOffsetX - RTLFactor * (ClientWidth - FHeader.Columns.GetVisibleFixedWidth));\r\n    SB_THUMBPOSITION,\r\n    SB_THUMBTRACK:\r\n      begin\r\n        DoStateChange([tsThumbTracking]);\r\n        if UseRightToLeftAlignment then\r\n          SetOffsetX(-Integer(FRangeX) + ClientWidth + GetRealScrollPosition)\r\n        else\r\n          SetOffsetX(-GetRealScrollPosition);\r\n      end;\r\n    SB_TOP:\r\n      SetOffsetX(0);\r\n  end;\r\n\r\n  Message.Result := 0;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.WMKeyDown(var Message: TWMKeyDown);\r\n\r\n// Keyboard event handling for node focus, selection, node specific popup menus and help invokation.\r\n// For a detailed description of every action done here read the help.\r\n\r\nvar\r\n  Shift: TShiftState;\r\n  Node, Temp,\r\n  LastFocused: PVirtualNode;\r\n  Offset: Integer;\r\n  ClearPending,\r\n  NeedInvalidate,\r\n  DoRangeSelect,\r\n  PerformMultiSelect: Boolean;\r\n  Context: Integer;\r\n  ParentControl: TWinControl;\r\n  R: TRect;\r\n  NewCheckState: TCheckState;\r\n  TempColumn,\r\n  NewColumn: TColumnIndex;\r\n  ActAsGrid: Boolean;\r\n  ForceSelection: Boolean;\r\n  NewWidth,\r\n  NewHeight: Integer;\r\n  RTLFactor: Integer;\r\n\r\n  // for tabulator handling\r\n  GetStartColumn: function(ConsiderAllowFocus: Boolean = False): TColumnIndex of object;\r\n  GetNextColumn: function(Column: TColumnIndex; ConsiderAllowFocus: Boolean = False): TColumnIndex of object;\r\n  GetNextNode: TGetNextNodeProc;\r\n\r\n  KeyState: TKeyboardState;\r\n  Buffer: array[0..1] of AnsiChar;\r\n\r\nbegin\r\n  // Make form key preview work and let application modify the key if it wants this.\r\n  inherited;\r\n\r\n  with Message do\r\n  begin\r\n    Shift := KeyDataToShiftState(KeyData);\r\n    // Ask the application if the default key handling is desired.\r\n    if DoKeyAction(CharCode, Shift) then\r\n    begin\r\n      if (tsKeyCheckPending in FStates) and (CharCode <> VK_SPACE) then\r\n      begin\r\n        DoStateChange([], [tskeyCheckPending]);\r\n        FCheckNode.CheckState := UnpressedState[FCheckNode.CheckState];\r\n        RepaintNode(FCheckNode);\r\n        FCheckNode := nil;\r\n      end;\r\n\r\n      if (CharCode in [VK_HOME, VK_END, VK_PRIOR, VK_NEXT, VK_UP, VK_DOWN, VK_LEFT, VK_RIGHT, VK_BACK, VK_TAB]) and (RootNode.FirstChild <> nil) then\r\n      begin\r\n        PerformMultiSelect := (ssShift in Shift) and (toMultiSelect in FOptions.FSelectionOptions) and not IsEditing;\r\n\r\n        // Flag to avoid range selection in case of single node advance.\r\n        DoRangeSelect := (CharCode in [VK_HOME, VK_END, VK_PRIOR, VK_NEXT]) and PerformMultiSelect and not IsEditing;\r\n\r\n        NeedInvalidate := DoRangeSelect or (FSelectionCount > 1);\r\n        ActAsGrid := toGridExtensions in FOptions.FMiscOptions;\r\n        ClearPending := (Shift = []) or (ActAsGrid and not (ssShift in Shift)) or\r\n          not (toMultiSelect in FOptions.FSelectionOptions) or (CharCode in [VK_TAB, VK_BACK]);\r\n\r\n        // Keep old focused node for range selection. Use a default node if none was focused until now.\r\n        LastFocused := FFocusedNode;\r\n        if (LastFocused = nil) and (Shift <> []) then\r\n          LastFocused := GetFirstVisible(nil, True);\r\n\r\n        // Set an initial range anchor if there is not yet one.\r\n        if FRangeAnchor = nil then\r\n          FRangeAnchor := GetFirstSelected;\r\n        if FRangeAnchor = nil then\r\n          FRangeAnchor := GetFirst;\r\n\r\n        if UseRightToLeftAlignment then\r\n          RTLFactor := -1\r\n        else\r\n          RTLFactor := 1;\r\n\r\n        // Determine new focused node.\r\n        case CharCode of\r\n          VK_HOME, VK_END:\r\n            begin\r\n              if (CharCode = VK_END) xor UseRightToLeftAlignment then\r\n              begin\r\n                GetStartColumn := FHeader.FColumns.GetLastVisibleColumn;\r\n                GetNextColumn := FHeader.FColumns.GetPreviousVisibleColumn;\r\n                GetNextNode := GetPreviousVisible;\r\n                Node := GetLastVisible(nil, True);\r\n              end\r\n              else\r\n              begin\r\n                GetStartColumn := FHeader.FColumns.GetFirstVisibleColumn;\r\n                GetNextColumn := FHeader.FColumns.GetNextVisibleColumn;\r\n                GetNextNode := GetNextVisible;\r\n                Node := GetFirstVisible(nil, True);\r\n              end;\r\n\r\n              // Advance to next/previous visible column.\r\n              if FHeader.UseColumns then\r\n                NewColumn := GetStartColumn\r\n              else\r\n                NewColumn := NoColumn;\r\n              // Find a column for the new/current node which can be focused.\r\n              // Make the 'DoFocusChanging' for finding a valid column\r\n              // identifiable from the 'DoFocusChanging' raised later on by\r\n              // \"FocusedNode := Node;\"\r\n              while (NewColumn > NoColumn) and not DoFocusChanging(FFocusedNode, FFocusedNode, FFocusedColumn, NewColumn) do\r\n                NewColumn := GetNextColumn(NewColumn);\r\n              if NewColumn > InvalidColumn then\r\n              begin\r\n                if (Shift = [ssCtrl]) and not ActAsGrid then\r\n                begin\r\n                  ScrollIntoView(Node, toCenterScrollIntoView in FOptions.SelectionOptions,\r\n                    not (toDisableAutoscrollOnFocus in FOptions.FAutoOptions));\r\n                  if (CharCode = VK_HOME) and not UseRightToLeftAlignment then\r\n                    SetOffsetX(0)\r\n                  else\r\n                    SetOffsetX(-MaxInt);\r\n                end\r\n                else\r\n                begin\r\n                  if not ActAsGrid or (ssCtrl in Shift) then\r\n                    FocusedNode := Node;\r\n                  if ActAsGrid and not (toFullRowSelect in FOptions.FSelectionOptions) then\r\n                    FocusedColumn := NewColumn;\r\n                end;\r\n              end;\r\n            end;\r\n          VK_PRIOR:\r\n            if Shift = [ssCtrl, ssShift] then\r\n              SetOffsetX(FOffsetX + ClientWidth)\r\n            else\r\n              if [ssShift, ssAlt] = Shift then\r\n              begin\r\n                if FFocusedColumn <= NoColumn then\r\n                  NewColumn := FHeader.FColumns.GetFirstVisibleColumn\r\n                else\r\n                begin\r\n                  Offset := FHeader.FColumns.GetVisibleFixedWidth;\r\n                  NewColumn := FFocusedColumn;\r\n                  while True do\r\n                  begin\r\n                    TempColumn := FHeader.FColumns.GetPreviousVisibleColumn(NewColumn);\r\n                    NewWidth := FHeader.FColumns[NewColumn].Width;\r\n                    if (TempColumn <= NoColumn) or\r\n                       (Offset + NewWidth >= ClientWidth) or\r\n                       (coFixed in FHeader.FColumns[TempColumn].FOptions) then\r\n                      Break;\r\n                    NewColumn := TempColumn;\r\n                    Inc(Offset, NewWidth);\r\n                  end;\r\n                end;\r\n                SetFocusedColumn(NewColumn);\r\n              end\r\n              else\r\n                if ssCtrl in Shift then\r\n                  SetOffsetY(FOffsetY + ClientHeight)\r\n                else\r\n                begin\r\n                  Offset := 0;\r\n                  // If there's no focused node then just take the very first visible one.\r\n                  if FFocusedNode = nil then\r\n                    Node := GetFirstVisible(nil, True)\r\n                  else\r\n                  begin\r\n                    // Go up as many nodes as comprise together a size of ClientHeight.\r\n                    Node := FFocusedNode;\r\n                    while True do\r\n                    begin\r\n                      Temp := GetPreviousVisible(Node, True);\r\n                      NewHeight := NodeHeight[Node];\r\n                      if (Temp = nil) or (Offset + NewHeight >= ClientHeight) then\r\n                        Break;\r\n                      Node := Temp;\r\n                      Inc(Offset, NodeHeight[Node]);\r\n                    end;\r\n                  end;\r\n                  FocusedNode := Node;\r\n                end;\r\n          VK_NEXT:\r\n            if Shift = [ssCtrl, ssShift] then\r\n              SetOffsetX(FOffsetX - ClientWidth)\r\n            else\r\n              if [ssShift, ssAlt] = Shift then\r\n              begin\r\n                if FFocusedColumn <= NoColumn then\r\n                  NewColumn := FHeader.FColumns.GetFirstVisibleColumn\r\n                else\r\n                begin\r\n                  Offset := FHeader.FColumns.GetVisibleFixedWidth;\r\n                  NewColumn := FFocusedColumn;\r\n                  while True do\r\n                  begin\r\n                    TempColumn := FHeader.FColumns.GetNextVisibleColumn(NewColumn);\r\n                    NewWidth := FHeader.FColumns[NewColumn].Width;\r\n                    if (TempColumn <= NoColumn) or\r\n                       (Offset + NewWidth >= ClientWidth) or\r\n                       (coFixed in FHeader.FColumns[TempColumn].FOptions) then\r\n                      Break;\r\n                    NewColumn := TempColumn;\r\n                    Inc(Offset, NewWidth);\r\n                  end;\r\n                end;\r\n                SetFocusedColumn(NewColumn);\r\n              end\r\n              else\r\n                if ssCtrl in Shift then\r\n                  SetOffsetY(FOffsetY - ClientHeight)\r\n                else\r\n                begin\r\n                  Offset := 0;\r\n                  // If there's no focused node then just take the very last one.\r\n                  if FFocusedNode = nil then\r\n                    Node := GetLastVisible(nil, True)\r\n                  else\r\n                  begin\r\n                    // Go up as many nodes as comprise together a size of ClientHeight.\r\n                    Node := FFocusedNode;\r\n                    while True do\r\n                    begin\r\n                      Temp := GetNextVisible(Node, True);\r\n                      NewHeight := NodeHeight[Node];\r\n                      if (Temp = nil) or (Offset + NewHeight >= ClientHeight) then\r\n                        Break;\r\n                      Node := Temp;\r\n                      Inc(Offset, NewHeight);\r\n                    end;\r\n                  end;\r\n                  FocusedNode := Node;\r\n                end;\r\n          VK_UP:\r\n            begin\r\n              // scrolling without selection change\r\n              if ssCtrl in Shift then\r\n                SetOffsetY(FOffsetY + Integer(FDefaultNodeHeight))\r\n              else\r\n              begin\r\n                if FFocusedNode = nil then\r\n                  Node := GetLastVisible(nil, True)\r\n                else\r\n                  Node := GetPreviousVisible(FFocusedNode, True);\r\n\r\n                if Assigned(Node) then\r\n                begin\r\n                  if not EndEditNode then\r\n                    exit;\r\n                  if (not PerformMultiSelect or (CompareNodePositions(LastFocused, FRangeAnchor) > 0)) and\r\n                    Assigned(FFocusedNode) then\r\n                    RemoveFromSelection(FFocusedNode);\r\n                  if FFocusedColumn <= NoColumn then\r\n                    FFocusedColumn := FHeader.MainColumn;\r\n                  FocusedNode := Node;\r\n                end\r\n                else\r\n                  if Assigned(FFocusedNode) then\r\n                    InvalidateNode(FFocusedNode);\r\n              end;\r\n            end;\r\n          VK_DOWN:\r\n            begin\r\n              // scrolling without selection change\r\n              if ssCtrl in Shift then\r\n                SetOffsetY(FOffsetY - Integer(FDefaultNodeHeight))\r\n              else\r\n              begin\r\n                if FFocusedNode = nil then\r\n                  Node := GetFirstVisible(nil, True)\r\n                else\r\n                  Node := GetNextVisible(FFocusedNode, True);\r\n\r\n                if Assigned(Node) then\r\n                begin\r\n                  if not EndEditNode then\r\n                    exit;\r\n                  if (not PerformMultiSelect or (CompareNodePositions(LastFocused, FRangeAnchor) < 0)) and\r\n                    Assigned(FFocusedNode) then\r\n                    RemoveFromSelection(FFocusedNode);\r\n                  if FFocusedColumn <= NoColumn then\r\n                    FFocusedColumn := FHeader.MainColumn;\r\n                  FocusedNode := Node;\r\n                end\r\n                else\r\n                  if Assigned(FFocusedNode) then\r\n                    InvalidateNode(FFocusedNode);\r\n              end;\r\n            end;\r\n          VK_LEFT:\r\n            begin\r\n              // special handling\r\n              if ssCtrl in Shift then\r\n                SetOffsetX(FOffsetX + RTLFactor * FHeader.Columns.GetScrollWidth)\r\n              else\r\n              begin\r\n                // other special cases\r\n                Context := NoColumn;\r\n                if (toExtendedFocus in FOptions.FSelectionOptions) and (toGridExtensions in FOptions.FMiscOptions) then\r\n                begin\r\n                  Context := FHeader.Columns.GetPreviousVisibleColumn(FFocusedColumn, True);\r\n                  if Context > -1 then\r\n                    FocusedColumn := Context;\r\n                end\r\n                else\r\n                  if Assigned(FFocusedNode) and (vsExpanded in FFocusedNode.States) and\r\n                     (Shift = []) and (vsHasChildren in FFocusedNode.States) then\r\n                    ToggleNode(FFocusedNode)\r\n                  else\r\n                  begin\r\n                    if FFocusedNode = nil then\r\n                      FocusedNode := GetFirstVisible(nil, True)\r\n                    else\r\n                    begin\r\n                      if FFocusedNode.Parent <> FRoot then\r\n                        Node := FFocusedNode.Parent\r\n                      else\r\n                        Node := nil;\r\n                      if Assigned(Node) then\r\n                      begin\r\n                        if PerformMultiSelect then\r\n                        begin\r\n                          // and a third special case\r\n                          if FFocusedNode.Index > 0 then\r\n                            DoRangeSelect := True\r\n                          else\r\n                           if CompareNodePositions(Node, FRangeAnchor) > 0 then\r\n                             RemoveFromSelection(FFocusedNode);\r\n                        end;\r\n                        FocusedNode := Node;\r\n                      end;\r\n                    end;\r\n                  end;\r\n              end;\r\n            end;\r\n          VK_RIGHT:\r\n            begin\r\n              // special handling\r\n              if ssCtrl in Shift then\r\n                SetOffsetX(FOffsetX - RTLFactor * FHeader.Columns.GetScrollWidth)\r\n              else\r\n              begin\r\n                // other special cases\r\n                Context := NoColumn;\r\n                if (toExtendedFocus in FOptions.FSelectionOptions) and (toGridExtensions in FOptions.FMiscOptions) then\r\n                begin\r\n                  Context := FHeader.Columns.GetNextVisibleColumn(FFocusedColumn, True);\r\n                  if Context > -1 then\r\n                    FocusedColumn := Context;\r\n                end\r\n                else\r\n                  if Assigned(FFocusedNode) and not (vsExpanded in FFocusedNode.States) and\r\n                     (Shift = []) and (vsHasChildren in FFocusedNode.States) then\r\n                    ToggleNode(FFocusedNode)\r\n                  else\r\n                  begin\r\n                    if FFocusedNode = nil then\r\n                      FocusedNode := GetFirstVisible(nil, True)\r\n                    else\r\n                    begin\r\n                      Node := GetFirstVisibleChild(FFocusedNode);\r\n                      if Assigned(Node) then\r\n                      begin\r\n                        if PerformMultiSelect and (CompareNodePositions(Node, FRangeAnchor) < 0) then\r\n                          RemoveFromSelection(FFocusedNode);\r\n                        FocusedNode := Node;\r\n                      end;\r\n                    end;\r\n                  end;\r\n              end;\r\n            end;\r\n          VK_BACK:\r\n            if tsIncrementalSearching in FStates then\r\n              DoStateChange([tsIncrementalSearchPending])\r\n            else\r\n              if Assigned(FFocusedNode) and (FFocusedNode.Parent <> FRoot) then\r\n                FocusedNode := FocusedNode.Parent;\r\n          VK_TAB:\r\n            if (toExtendedFocus in FOptions.FSelectionOptions) and FHeader.UseColumns then\r\n            begin\r\n              // In order to avoid duplicating source code just to change the direction\r\n              // we use function variables.\r\n              if ssShift in Shift then\r\n              begin\r\n                GetStartColumn := FHeader.FColumns.GetLastVisibleColumn;\r\n                GetNextColumn := FHeader.FColumns.GetPreviousVisibleColumn;\r\n                GetNextNode := GetPreviousVisible;\r\n              end\r\n              else\r\n              begin\r\n                GetStartColumn := FHeader.FColumns.GetFirstVisibleColumn;\r\n                GetNextColumn := FHeader.FColumns.GetNextVisibleColumn;\r\n                GetNextNode := GetNextVisible;\r\n              end;\r\n\r\n              // Advance to next/previous visible column/node.\r\n              Node := FFocusedNode;\r\n              NewColumn := GetNextColumn(FFocusedColumn, True);\r\n              repeat\r\n                // Find a column for the current node which can be focused.\r\n                while (NewColumn > NoColumn) and not DoFocusChanging(FFocusedNode, Node, FFocusedColumn, NewColumn) do\r\n                  NewColumn := GetNextColumn(NewColumn, True);\r\n\r\n                if NewColumn > NoColumn then\r\n                begin\r\n                  // Set new node and column in one go.\r\n                  SetFocusedNodeAndColumn(Node, NewColumn);\r\n                  Break;\r\n                end;\r\n\r\n                // No next column was accepted for the current node. So advance to next node and try again.\r\n                Node := GetNextNode(Node);\r\n                NewColumn := GetStartColumn;\r\n              until Node = nil;\r\n            end;\r\n        end;\r\n\r\n        // Clear old selection if required but take care to select the new focused node if it was not selected before.\r\n        ForceSelection := False;\r\n        if ClearPending and ((LastFocused <> FFocusedNode) or (FSelectionCount <> 1)) then\r\n        begin\r\n          ClearSelection;\r\n          ForceSelection := True;\r\n        end;\r\n\r\n        // Determine new selection anchor.\r\n        if Shift = [] then\r\n        begin\r\n          FRangeAnchor := FFocusedNode;\r\n          FLastSelectionLevel := GetNodeLevel(FFocusedNode);\r\n        end;\r\n\r\n        if Assigned(FFocusedNode) then\r\n        begin\r\n          // Finally change the selection for a specific range of nodes.\r\n          if DoRangeSelect then\r\n            ToggleSelection(LastFocused, FFocusedNode);\r\n\r\n          // Make sure the new focused node is also selected.\r\n          if (LastFocused <> FFocusedNode) or ForceSelection then\r\n            AddToSelection(FFocusedNode);\r\n        end;\r\n\r\n        // If a repaint is needed then paint the entire tree because of the ClearSelection call,\r\n        if NeedInvalidate then\r\n          Invalidate;\r\n      end\r\n      else\r\n      begin\r\n        // Second chance for keys not directly concerned with selection changes.\r\n\r\n        // For +, -, /, * keys on the main keyboard (not numpad) there is no virtual key code defined.\r\n        // We have to do special processing to get them working too.\r\n        GetKeyboardState(KeyState);\r\n        // Avoid conversion to control characters. We have captured the control key state already in Shift.\r\n        KeyState[VK_CONTROL] := 0;\r\n        if ToASCII(Message.CharCode, (Message.KeyData shr 16) and 7, KeyState, PChar(@Buffer), 0) > 0 then\r\n        begin\r\n          case Buffer[0] of\r\n            '*':\r\n              CharCode := VK_MULTIPLY;\r\n            '+':\r\n              CharCode := VK_ADD;\r\n            '/':\r\n              CharCode := VK_DIVIDE;\r\n            '-':\r\n              CharCode := VK_SUBTRACT;\r\n          end;\r\n        end;\r\n\r\n        // According to https://web.archive.org/web/20041129085958/http://www.it-faq.pl/mskb/99/337.HTM\r\n        // there is a problem with ToASCII when used in conjunction with dead chars.\r\n        // The article recommends to call ToASCII twice to restore a deleted flag in the key message\r\n        // structure under certain circumstances. It turned out it is best to always call ToASCII twice.\r\n        ToASCII(Message.CharCode, (Message.KeyData shr 16) and 7, KeyState, PChar(@Buffer), 0);\r\n\r\n        case CharCode of\r\n          VK_F2:\r\n            if (Shift = []) and Assigned(FFocusedNode) and CanEdit(FFocusedNode, FFocusedColumn) then\r\n            begin\r\n              FEditColumn := FFocusedColumn;\r\n              DoEdit;\r\n            end;\r\n          VK_ADD:\r\n            if not (tsIncrementalSearching in FStates) then\r\n            begin\r\n              if ssCtrl in Shift then\r\n                if not (toReverseFullExpandHotKey in TreeOptions.MiscOptions) and (ssShift in Shift) then\r\n                  FullExpand\r\n                else\r\n                  FHeader.AutoFitColumns\r\n              else\r\n                if Assigned(FFocusedNode) and not (vsExpanded in FFocusedNode.States) then\r\n                  ToggleNode(FFocusedNode);\r\n            end\r\n            else\r\n              DoStateChange([tsIncrementalSearchPending]);\r\n          VK_SUBTRACT:\r\n            if not (tsIncrementalSearching in FStates) then\r\n            begin\r\n              if ssCtrl in Shift then\r\n                if not (toReverseFullExpandHotKey in TreeOptions.MiscOptions) and (ssShift in Shift) then\r\n                  FullCollapse\r\n                else\r\n                  FHeader.RestoreColumns\r\n              else\r\n                if Assigned(FFocusedNode) and (vsExpanded in FFocusedNode.States) then\r\n                  ToggleNode(FFocusedNode);\r\n            end\r\n            else\r\n              DoStateChange([tsIncrementalSearchPending]);\r\n          VK_MULTIPLY:\r\n            if not (tsIncrementalSearching in FStates) then\r\n            begin\r\n              if Assigned(FFocusedNode) then\r\n                FullExpand(FFocusedNode);\r\n            end\r\n            else\r\n              DoStateChange([tsIncrementalSearchPending]);\r\n          VK_DIVIDE:\r\n            if not (tsIncrementalSearching in FStates) then\r\n            begin\r\n              if Assigned(FFocusedNode) then\r\n                FullCollapse(FFocusedNode);\r\n            end\r\n            else\r\n              DoStateChange([tsIncrementalSearchPending]);\r\n          VK_ESCAPE: // cancel actions currently in progress\r\n            begin\r\n              if IsMouseSelecting then\r\n              begin\r\n                DoStateChange([], [tsDrawSelecting, tsDrawSelPending]);\r\n                Invalidate;\r\n              end\r\n              else\r\n                if IsEditing then\r\n                  CancelEditNode;\r\n            end;\r\n          VK_SPACE:\r\n            if (toCheckSupport in FOptions.FMiscOptions) and Assigned(FFocusedNode) and\r\n              (FFocusedNode.CheckType <> ctNone) then\r\n            begin\r\n              if (FStates * [tsKeyCheckPending, tsMouseCheckPending] = []) and\r\n                not (vsDisabled in FFocusedNode.States) then\r\n              begin\r\n                with FFocusedNode^ do\r\n                  NewCheckState := DetermineNextCheckState(CheckType, CheckState);\r\n                if DoChecking(FFocusedNode, NewCheckState) then\r\n                begin\r\n                  DoStateChange([tsKeyCheckPending]);\r\n                  FCheckNode := FFocusedNode;\r\n                  FPendingCheckState := NewCheckState;\r\n                  FCheckNode.CheckState := PressedState[FCheckNode.CheckState];\r\n                  RepaintNode(FCheckNode);\r\n                end;\r\n              end;\r\n            end\r\n            else\r\n              DoStateChange([tsIncrementalSearchPending]);\r\n          VK_F1:\r\n            if Assigned(FOnGetHelpContext) then\r\n            begin\r\n              Context := 0;\r\n              if Assigned(FFocusedNode) then\r\n              begin\r\n                Node := FFocusedNode;\r\n                // Traverse the tree structure up to the root.\r\n                repeat\r\n                  FOnGetHelpContext(Self, Node, IfThen(FFocusedColumn > NoColumn, FFocusedColumn, 0), Context);\r\n                  Node := Node.Parent;\r\n                until (Node = FRoot) or (Context <> 0);\r\n              end;\r\n\r\n              // If no help context could be found try the tree's one or its parent's contexts.\r\n              ParentControl := Self;\r\n              while Assigned(ParentControl) and (Context = 0) do\r\n              begin\r\n                Context := ParentControl.HelpContext;\r\n                ParentControl := ParentControl.Parent;\r\n              end;\r\n              if Context <> 0 then\r\n                Application.HelpContext(Context);\r\n            end;\r\n          VK_APPS:\r\n            if Assigned(FFocusedNode) then\r\n            begin\r\n              R := GetDisplayRect(FFocusedNode, FFocusedColumn, True);\r\n              Offset := DoGetNodeWidth(FFocusedNode, FFocusedColumn);\r\n              if FFocusedColumn >= 0 then\r\n              begin\r\n                if Offset > FHeader.Columns[FFocusedColumn].Width then\r\n                  Offset := FHeader.Columns[FFocusedColumn].Width;\r\n              end\r\n              else\r\n              begin\r\n                if Offset > ClientWidth then\r\n                  Offset := ClientWidth;\r\n              end;\r\n              DoPopupMenu(FFocusedNode, FFocusedColumn, Point(R.Left + Offset div 2, (R.Top + R.Bottom) div 2));\r\n            end\r\n            else\r\n              DoPopupMenu(nil, FFocusedColumn, Point(-1, -1));\r\n          Ord('a'), Ord('A'):\r\n            if ssCtrl in Shift then\r\n              SelectAll(True)\r\n            else\r\n              DoStateChange([tsIncrementalSearchPending]);\r\n        else\r\n        begin\r\n          // Use the key for incremental search.\r\n          // Since we are dealing with Unicode all the time there should be a more sophisticated way\r\n          // of checking for valid characters for incremental search.\r\n          // This is available but would require to include a significant amount of Unicode character\r\n          // properties, so we stick with the simple space check.\r\n          if ((Shift * [ssCtrl, ssAlt] = []) or ((Shift * [ssCtrl, ssAlt] = [ssCtrl, ssAlt]))) and (CharCode >= 32) then\r\n            DoStateChange([tsIncrementalSearchPending]);\r\n          end;\r\n        end;\r\n      end;\r\n    end;\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.WMKeyUp(var Message: TWMKeyUp);\r\n\r\nbegin\r\n  inherited;\r\n\r\n  case Message.CharCode of\r\n    VK_SPACE:\r\n      if tsKeyCheckPending in FStates then\r\n      begin\r\n        DoStateChange([], [tskeyCheckPending]);\r\n        if FCheckNode = FFocusedNode then\r\n          DoCheckClick(FCheckNode, FPendingCheckState);\r\n        InvalidateNode(FCheckNode);\r\n        FCheckNode := nil;\r\n      end;\r\n     VK_TAB:\r\n       EnsureNodeFocused(); // Always select a node if the control gets the focus via TAB key, #237\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.WMKillFocus(var Msg: TWMKillFocus);\r\n\r\nvar\r\n  Form: TCustomForm;\r\n  Control: TWinControl;\r\n  Pos: TSmallPoint;\r\n  Unknown: IUnknown;\r\n\r\nbegin\r\n  inherited;\r\n\r\n  // Remove hint if shown currently.\r\n  if tsHint in Self.FStates then\r\n    Application.CancelHint;\r\n\r\n  // Stop wheel panning if active.\r\n  StopWheelPanning;\r\n\r\n  // Don't let any timer continue if the tree is no longer the active control (except change timers).\r\n  StopTimer(ExpandTimer);\r\n  StopTimer(EditTimer);\r\n  StopTimer(HeaderTimer);\r\n  StopTimer(ScrollTimer);\r\n  StopTimer(SearchTimer);\r\n  FSearchBuffer := '';\r\n  FLastSearchNode := nil;\r\n\r\n  DoStateChange([], [tsScrollPending, tsScrolling, tsEditPending, tsLeftButtonDown, tsRightButtonDown,\r\n    tsMiddleButtonDown, tsOLEDragPending, tsVCLDragPending, tsIncrementalSearching, tsNodeHeightTrackPending,\r\n    tsNodeHeightTracking]);\r\n\r\n  if (FSelectionCount > 0) or not (toGhostedIfUnfocused in FOptions.FPaintOptions) then\r\n    Invalidate\r\n  else\r\n    if Assigned(FFocusedNode) then\r\n      InvalidateNode(FFocusedNode);\r\n\r\n  // Workaround for wrapped non-VCL controls (like TWebBrowser), which do not use VCL mechanisms and\r\n  // leave the ActiveControl property in the wrong state, which causes trouble when the control is refocused.\r\n  Form := GetParentForm(Self);\r\n  if Assigned(Form) and (Form.ActiveControl = Self) then\r\n  begin\r\n    Cardinal(Pos) := GetMessagePos;\r\n    Control := FindVCLWindow(SmallPointToPoint(Pos));\r\n    // Every control derived from TOleControl has potentially the focus problem. In order to avoid including\r\n    // the OleCtrls unit (which will, among others, include Variants), which would allow to test for the TOleControl\r\n    // class, the IOleClientSite interface is used for the test, which is supported by TOleControl and a good indicator.\r\n    if Assigned(Control) and Control.GetInterface(IOleClientSite, Unknown) then\r\n      Form.ActiveControl := nil;\r\n\r\n    // For other classes the active control should not be modified. Otherwise you need two clicks to select it.\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.WMLButtonDblClk(var Message: TWMLButtonDblClk);\r\n\r\nvar\r\n  HitInfo: THitInfo;\r\n\r\nbegin\r\n  DoStateChange([tsLeftDblClick]);\r\n  inherited;\r\n\r\n  // get information about the hit\r\n  GetHitTestInfoAt(Message.XPos, Message.YPos, True, HitInfo);\r\n  HandleMouseDblClick(Message, HitInfo);\r\n  DoStateChange([], [tsLeftDblClick]);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.WMLButtonDown(var Message: TWMLButtonDown);\r\n\r\nvar\r\n  HitInfo: THitInfo;\r\n\r\nbegin\r\n  DoStateChange([tsLeftButtonDown]);\r\n  inherited;\r\n\r\n  // get information about the hit\r\n  GetHitTestInfoAt(Message.XPos, Message.YPos, True, HitInfo);\r\n  HandleMouseDown(Message, HitInfo);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.WMLButtonUp(var Message: TWMLButtonUp);\r\n\r\nvar\r\n  HitInfo: THitInfo;\r\n\r\nbegin\r\n  DoStateChange([], [tsLeftButtonDown, tsNodeHeightTracking, tsNodeHeightTrackPending]);\r\n\r\n  // get information about the hit\r\n  GetHitTestInfoAt(Message.XPos, Message.YPos, True, HitInfo);\r\n  HandleMouseUp(Message, HitInfo);\r\n\r\n  inherited;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.WMMButtonDblClk(var Message: TWMMButtonDblClk);\r\n\r\nvar\r\n  HitInfo: THitInfo;\r\n\r\nbegin\r\n  DoStateChange([tsMiddleDblClick]);\r\n  inherited;\r\n\r\n  // get information about the hit\r\n  if toMiddleClickSelect in FOptions.FSelectionOptions then\r\n  begin\r\n    GetHitTestInfoAt(Message.XPos, Message.YPos, True, HitInfo);\r\n    HandleMouseDblClick(Message, HitInfo);\r\n  end;\r\n  DoStateChange([], [tsMiddleDblClick]);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.WMMButtonDown(var Message: TWMMButtonDown);\r\n\r\nvar\r\n  HitInfo: THitInfo;\r\n\r\nbegin\r\n  DoStateChange([tsMiddleButtonDown]);\r\n\r\n  if FHeader.FStates = [] then\r\n  begin\r\n    inherited;\r\n\r\n    // Start wheel panning or scrolling if not already active, allowed and scrolling is useful at all.\r\n    if (toWheelPanning in FOptions.FMiscOptions) and ([tsWheelScrolling, tsWheelPanning] * FStates = []) and\r\n      ((Integer(FRangeX) > ClientWidth) or (Integer(FRangeY) > ClientHeight)) then\r\n    begin\r\n      FLastClickPos := SmallPointToPoint(Message.Pos);\r\n      StartWheelPanning(FLastClickPos);\r\n    end\r\n    else\r\n    begin\r\n      StopWheelPanning;\r\n\r\n      // Get information about the hit.\r\n      if toMiddleClickSelect in FOptions.FSelectionOptions then\r\n      begin\r\n        GetHitTestInfoAt(Message.XPos, Message.YPos, True, HitInfo);\r\n        HandleMouseDown(Message, HitInfo);\r\n      end;\r\n    end;\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.WMMButtonUp(var Message: TWMMButtonUp);\r\n\r\nvar\r\n  HitInfo: THitInfo;\r\n\r\nbegin\r\n  DoStateChange([], [tsMiddleButtonDown]);\r\n\r\n  // If wheel panning/scrolling is active and the mouse has not yet been moved then the user starts wheel auto scrolling.\r\n  // Indicate this by removing the panning flag. Otherwise (the mouse has moved meanwhile) stop panning.\r\n  if [tsWheelPanning, tsWheelScrolling] * FStates <> [] then\r\n  begin\r\n    if tsWheelScrolling in FStates then\r\n      DoStateChange([], [tsWheelPanning])\r\n    else\r\n      StopWheelPanning;\r\n  end\r\n  else\r\n    if FHeader.FStates = [] then\r\n    begin\r\n      inherited;\r\n\r\n      // get information about the hit\r\n      if toMiddleClickSelect in FOptions.FSelectionOptions then\r\n      begin\r\n        GetHitTestInfoAt(Message.XPos, Message.YPos, True, HitInfo);\r\n        HandleMouseUp(Message, HitInfo);\r\n      end;\r\n    end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.WMNCCalcSize(var Message: TWMNCCalcSize);\r\n\r\nbegin\r\n  inherited;\r\n\r\n  with FHeader do\r\n    if hoVisible in FHeader.FOptions then\r\n      with Message.CalcSize_Params^ do\r\n        Inc(rgrc[0].Top, FHeight);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.WMNCDestroy(var Message: TWMNCDestroy);\r\n\r\n// Used to release a reference of the drag manager. This is the only reliable way we get notified about\r\n// window destruction, because of the automatic release of a window if its parent window is freed.\r\n\r\nbegin\r\n  InterruptValidation;\r\n\r\n  StopTimer(ChangeTimer);\r\n  StopTimer(StructureChangeTimer);\r\n\r\n  if not (csDesigning in ComponentState) and (toAcceptOLEDrop in FOptions.FMiscOptions) then\r\n    RevokeDragDrop(Handle);\r\n\r\n  // Clean up other stuff.\r\n  DeleteObject(FDottedBrush);\r\n  FDottedBrush := 0;\r\n  if tsInAnimation in FStates then\r\n    FHintWindowDestroyed := True; // Stop any pending animation.\r\n\r\n  inherited;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.WMNCHitTest(var Message: TWMNCHitTest);\r\n\r\nbegin\r\n  inherited;\r\n  if (hoVisible in FHeader.FOptions) and\r\n    FHeader.InHeader(ScreenToClient(SmallPointToPoint(Message.Pos))) then\r\n    Message.Result := HTBORDER;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\n\r\nprocedure TBaseVirtualTree.WMNCPaint(var Message: TWMNCPaint);\r\n\r\nvar\r\n  DC: HDC;\r\n  R: TRect;\r\n  Flags: DWORD;\r\n  ExStyle: Integer;\r\n  TempRgn: HRGN;\r\n  BorderWidth,\r\n  BorderHeight: Integer;\r\n \r\nbegin\r\n  if tsUseThemes in FStates then\r\n  begin\r\n    // If theming is enabled and the client edge border is set for the window then prevent the default window proc\r\n    // from painting the old border to avoid flickering.\r\n    ExStyle := GetWindowLong(Handle, GWL_EXSTYLE);\r\n    if (ExStyle and WS_EX_CLIENTEDGE) <> 0 then\r\n    begin\r\n      GetWindowRect(Handle, R);\r\n      // Determine width of the client edge.\r\n      BorderWidth := GetSystemMetrics(SM_CXEDGE);\r\n      BorderHeight := GetSystemMetrics(SM_CYEDGE);\r\n      InflateRect(R, -BorderWidth, -BorderHeight);\r\n      TempRgn := CreateRectRgnIndirect(R);\r\n      // Exclude the border from the message region if there is one. Otherwise just use the inflated\r\n      // window area region.\r\n      if Message.Rgn <> 1 then\r\n        CombineRgn(TempRgn, Message.Rgn, TempRgn, RGN_AND);\r\n      DefWindowProc(Handle, Message.Msg, WPARAM(TempRgn), 0);\r\n      DeleteObject(TempRgn);\r\n    end\r\n    else\r\n      DefaultHandler(Message);\r\n  end\r\n  else\r\n    DefaultHandler(Message);\r\n\r\n  Flags := DCX_CACHE or DCX_CLIPSIBLINGS or DCX_WINDOW or DCX_VALIDATE;\r\n\r\n  if (Message.Rgn = 1) then\r\n    DC := GetDCEx(Handle, 0, Flags)\r\n  else\r\n    DC := GetDCEx(Handle, Message.Rgn, Flags or DCX_INTERSECTRGN);\r\n\r\n  if DC <> 0 then\r\n  begin\r\n    if hoVisible in FHeader.FOptions then\r\n    begin\r\n      R := FHeaderRect;\r\n      FHeader.FColumns.PaintHeader(DC, R, -FEffectiveOffsetX);\r\n    end;\r\n    OriginalWMNCPaint(DC);\r\n    ReleaseDC(Handle, DC);\r\n  end;\r\n  if (((tsUseThemes in FStates) and not VclStyleEnabled) or (VclStyleEnabled and (seBorder in StyleElements))) then\r\n      StyleServices.PaintBorder(Self, False)\r\n  else\r\n    if (VclStyleEnabled and not (seBorder in StyleElements)) then\r\n      TStyleManager.SystemStyle.PaintBorder(Self, False)\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.WMPaint(var Message: TWMPaint);\r\n\r\nbegin\r\n  if tsVCLDragging in FStates then\r\n    ImageList_DragShowNolock(False);\r\n  if csPaintCopy in ControlState then\r\n    FUpdateRect := ClientRect\r\n  else\r\n    GetUpdateRect(Handle, FUpdateRect, True);\r\n  \r\n  inherited;\r\n \r\n  if tsVCLDragging in FStates then\r\n    ImageList_DragShowNolock(True);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.WMPaste(var Message: TWMPaste);\r\n\r\nbegin\r\n  PasteFromClipboard;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.WMPrint(var Message: TWMPrint);\r\n\r\n// This message is sent to request that the tree draws itself to a given device context. This includes not only\r\n// the client area but also the non-client area (header!).\r\n\r\nbegin\r\n  // Draw only if the window is visible or visibility is not required.\r\n  if ((Message.Flags and PRF_CHECKVISIBLE) = 0) or IsWindowVisible(Handle) then\r\n    Header.Columns.PaintHeader(Message.DC, FHeaderRect, -FEffectiveOffsetX);\r\n\r\n  inherited;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.WMPrintClient(var Message: TWMPrintClient);\r\n\r\nvar\r\n  Window: TRect;\r\n  Target: TPoint;\r\n  Canvas: TCanvas;\r\n\r\nbegin\r\n  // Draw only if the window is visible or visibility is not required.\r\n  if ((Message.Flags and PRF_CHECKVISIBLE) = 0) or IsWindowVisible(Handle) then\r\n  begin\r\n    // Determine area of the entire tree to be displayed in the control.\r\n    Window := ClientRect;\r\n    Target := Window.TopLeft;\r\n\r\n    // The Window rectangle is given in client coordinates. We have to convert it into\r\n    // a sliding window of the tree image.\r\n    OffsetRect(Window, FEffectiveOffsetX, -FOffsetY);\r\n\r\n    Canvas := TCanvas.Create;\r\n    try\r\n      Canvas.Handle := Message.DC;\r\n      PaintTree(Canvas, Window, Target, [poBackground, poDrawFocusRect, poDrawDropMark, poDrawSelection, poGridLines]);\r\n    finally\r\n      Canvas.Handle := 0;\r\n      Canvas.Free;\r\n    end;\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.WMRButtonDblClk(var Message: TWMRButtonDblClk);\r\n\r\nvar\r\n  HitInfo: THitInfo;\r\n\r\nbegin\r\n  DoStateChange([tsRightDblClick]);\r\n  inherited;\r\n\r\n  // get information about the hit\r\n  if toMiddleClickSelect in FOptions.FSelectionOptions then\r\n  begin\r\n    GetHitTestInfoAt(Message.XPos, Message.YPos, True, HitInfo);\r\n    HandleMouseDblClick(Message, HitInfo);\r\n  end;\r\n  DoStateChange([], [tsRightDblClick]);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.WMRButtonDown(var Message: TWMRButtonDown);\r\n\r\nvar\r\n  HitInfo: THitInfo;\r\n\r\nbegin\r\n  DoStateChange([tsRightButtonDown]);\r\n\r\n  if FHeader.FStates = [] then\r\n  begin\r\n    inherited;\r\n\r\n    // get information about the hit\r\n    if toRightClickSelect in FOptions.FSelectionOptions then\r\n    begin\r\n      GetHitTestInfoAt(Message.XPos, Message.YPos, True, HitInfo);\r\n      HandleMouseDown(Message, HitInfo);\r\n    end;\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.WMRButtonUp(var Message: TWMRButtonUp);\r\n\r\n// handle right click selection and node specific popup menu\r\n\r\nvar\r\n  HitInfo: THitInfo;\r\n\r\nbegin\r\n  DoStateChange([], [tsPopupMenuShown, tsRightButtonDown]);\r\n\r\n  if FHeader.FStates = [] then\r\n  begin\r\n    Application.CancelHint;\r\n\r\n    if IsMouseSelecting and Assigned(PopupMenu) then\r\n    begin\r\n      // Reset selection state already here, before the inherited handler opens the default menu.\r\n      DoStateChange([], [tsDrawSelecting, tsDrawSelPending]);\r\n      Invalidate;\r\n    end;\r\n\r\n    inherited;\r\n\r\n    // get information about the hit\r\n    GetHitTestInfoAt(Message.XPos, Message.YPos, True, HitInfo);\r\n\r\n    if toRightClickSelect in FOptions.FSelectionOptions then\r\n      HandleMouseUp(Message, HitInfo);\r\n\r\n    if not Assigned(PopupMenu) then\r\n      DoPopupMenu(HitInfo.HitNode, HitInfo.HitColumn, Point(Message.XPos, Message.YPos));\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.WMSetCursor(var Message: TWMSetCursor);\r\n\r\n// Sets the hot node mouse cursor for the tree. Cursor changes for the header are handled in Header.HandleMessage.\r\n\r\nvar\r\n  NewCursor: TCursor;\r\n  HitInfo: THitInfo;\r\n  P: TPoint;\r\n  Node: PVirtualNode;\r\n\r\nbegin\r\n  with Message do\r\n  begin\r\n    // Feature: design-time header #415\r\n    // Allow header to handle cursor and return control's default if it did nothing\r\n    if (CursorWnd = Handle) and\r\n      ([tsWheelPanning, tsWheelScrolling] * FStates = []) then\r\n    begin\r\n      if not FHeader.HandleMessage(TMessage(Message)) then\r\n      begin\r\n        // Apply own cursors only if there is no global cursor set.\r\n        if Screen.Cursor = crDefault then\r\n        begin\r\n          // node resizing and hot tracking - for run-time only\r\n          if not (csDesigning in ComponentState) then\r\n          begin\r\n            NewCursor := crDefault;\r\n            if (toNodeHeightResize in FOptions.FMiscOptions) then\r\n            begin\r\n              GetCursorPos(P);\r\n              P := ScreenToClient(P);\r\n              GetHitTestInfoAt(P.X, P.Y, True, HitInfo);\r\n              if (hiOnItem in HitInfo.HitPositions) and\r\n                 ([hiUpperSplitter, hiLowerSplitter] * HitInfo.HitPositions <> []) then\r\n              begin\r\n                if hiUpperSplitter in HitInfo.HitPositions then\r\n                  Node := GetPreviousVisible(HitInfo.HitNode, True)\r\n                else\r\n                  Node := HitInfo.HitNode;\r\n\r\n                if CanSplitterResizeNode(P, Node, HitInfo.HitColumn) then\r\n                  NewCursor := crVertSplit;\r\n              end;\r\n            end;\r\n\r\n            if (NewCursor = crDefault) then\r\n              if (toHotTrack in FOptions.PaintOptions) and Assigned(FCurrentHotNode) and (FHotCursor <> crDefault) then\r\n                NewCursor := FHotCursor\r\n              else\r\n                NewCursor := Cursor;\r\n\r\n            DoGetCursor(NewCursor);\r\n          end\r\n          else\r\n            NewCursor := Cursor;\r\n          Winapi.Windows.SetCursor(Screen.Cursors[NewCursor]);\r\n          Message.Result := 1;\r\n        end\r\n        else\r\n          inherited;\r\n      end;\r\n    end\r\n    else\r\n      inherited;\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.WMSetFocus(var Msg: TWMSetFocus);\r\n\r\nbegin\r\n  inherited;\r\n  if (FSelectionCount > 0) or not (toGhostedIfUnfocused in FOptions.FPaintOptions) then\r\n    Invalidate;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.WMSize(var Message: TWMSize);\r\n\r\nbegin\r\n  inherited;\r\n\r\n  // Need to update scroll bars here. This will cause a recursion because of the change of the client area\r\n  // when changing a scrollbar. Usually this is no problem since with the second level recursion no change of the\r\n  // window size happens (the same values for the scrollbars are set, which shouldn't cause a window size change).\r\n  // Appearently, this applies not to all systems, however.\r\n  if HandleAllocated and ([tsSizing, tsWindowCreating] * FStates = []) and (ClientHeight > 0) then\r\n  try\r\n    DoStateChange([tsSizing]);\r\n    // This call will invalidate the entire non-client area which needs recalculation on resize.\r\n    FHeader.RescaleHeader;\r\n    FHeader.UpdateSpringColumns;\r\n    UpdateScrollBars(True);\r\n\r\n    if (tsEditing in FStates) and not FHeader.UseColumns then\r\n      UpdateEditBounds;\r\n  finally\r\n    DoStateChange([], [tsSizing]);\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.WMThemeChanged(var Message: TMessage);\r\n\r\nbegin\r\n  inherited;\r\n\r\n  if StyleServices.Enabled and (toThemeAware in TreeOptions.PaintOptions) then\r\n    DoStateChange([tsUseThemes])\r\n  else\r\n    DoStateChange([], [tsUseThemes]);\r\n\r\n  // Updating the visuals here will not work correctly. Therefore we postpone\r\n  // the update by using a timer.\r\n  if not FChangingTheme then\r\n    SetTimer(Handle, ThemeChangedTimer, ThemeChangedTimerDelay, nil);\r\n  FChangingTheme := False;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.WMTimer(var Message: TWMTimer);\r\n\r\n// centralized timer handling happens here\r\n\r\nbegin\r\n  with Message do\r\n  begin\r\n    case TimerID of\r\n      ExpandTimer:\r\n        DoDragExpand;\r\n      EditTimer:\r\n        DoEdit;\r\n      ScrollTimer:\r\n        begin\r\n          if tsScrollPending in FStates then\r\n          begin\r\n            Application.CancelHint;\r\n            // Scroll delay has elapsed, set to normal scroll interval now.\r\n            SetTimer(Handle, ScrollTimer, FAutoScrollInterval, nil);\r\n            DoStateChange([tsScrolling], [tsScrollPending]);\r\n          end;\r\n          DoTimerScroll;\r\n        end;\r\n      ChangeTimer:\r\n        DoChange(FLastChangedNode);\r\n      StructureChangeTimer:\r\n        DoStructureChange(FLastStructureChangeNode, FLastStructureChangeReason);\r\n      SearchTimer:\r\n        begin\r\n          // When this event triggers then the user did not pressed any key for the specified timeout period.\r\n          // Hence incremental searching is stopped.\r\n          DoStateChange([], [tsIncrementalSearching]);\r\n          StopTimer(SearchTimer);\r\n          FSearchBuffer := '';\r\n          FLastSearchNode := nil;\r\n        end;\r\n      ThemeChangedTimer:\r\n        begin\r\n          StopTimer(ThemeChangedTimer);\r\n          RecreateWnd;\r\n        end;\r\n    end;\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.WMVScroll(var Message: TWMVScroll);\r\n\r\n  //--------------- local functions -------------------------------------------\r\n\r\n  function GetRealScrollPosition: Integer;\r\n\r\n  var\r\n    SI: TScrollInfo;\r\n    Code: Integer;\r\n\r\n  begin\r\n    SI.cbSize := SizeOf(TScrollInfo);\r\n    SI.fMask := SIF_TRACKPOS;\r\n    Code := SB_VERT;\r\n    GetScrollInfo(Handle, Code, SI);\r\n    Result := SI.nTrackPos;\r\n  end;\r\n\r\n  //--------------- end local functions ---------------------------------------\r\n\r\nbegin\r\n  case Message.ScrollCode of\r\n    SB_BOTTOM:\r\n      SetOffsetY(-Integer(FRoot.TotalHeight));\r\n    SB_ENDSCROLL:\r\n      begin\r\n        DoStateChange([], [tsThumbTracking]);\r\n        // Avoiding to adjust the horizontal scroll position while tracking makes scrolling much smoother\r\n        // but we need to adjust the final position here then.\r\n        UpdateScrollBars(True);\r\n        // Really weird invalidation needed here (and I do it only because it happens so rarely), because\r\n        // when showing the horizontal scrollbar while scrolling down using the down arrow button,\r\n        // the button will be repainted on mouse up (at the wrong place in the far right lower corner)...\r\n        RedrawWindow(Handle, nil, 0, RDW_FRAME or RDW_INVALIDATE or RDW_NOERASE or RDW_NOCHILDREN);\r\n      end;\r\n    SB_LINEUP:\r\n      SetOffsetY(FOffsetY + FScrollBarOptions.FIncrementY);\r\n    SB_LINEDOWN:\r\n      SetOffsetY(FOffsetY - FScrollBarOptions.FIncrementY);\r\n    SB_PAGEUP:\r\n      SetOffsetY(FOffsetY + ClientHeight);\r\n    SB_PAGEDOWN:\r\n      SetOffsetY(FOffsetY - ClientHeight);\r\n\r\n    SB_THUMBPOSITION,\r\n    SB_THUMBTRACK:\r\n      begin\r\n        DoStateChange([tsThumbTracking]);\r\n        SetOffsetY(-GetRealScrollPosition);\r\n      end;\r\n    SB_TOP:\r\n      SetOffsetY(0);\r\n  end;\r\n  Message.Result := 0;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.AddToSelection(Node: PVirtualNode);\r\n\r\nvar\r\n  Changed: Boolean;\r\n\r\nbegin\r\n  if not FSelectionLocked then\r\n  begin\r\n    Assert(Assigned(Node), 'Node must not be nil!');\r\n    FSingletonNodeArray[0] := Node;\r\n    Changed := InternalAddToSelection(FSingletonNodeArray, 1, False);\r\n    if Changed then\r\n    begin\r\n      InvalidateNode(Node);\r\n      Change(Node);\r\n    end;\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.AddToSelection(const NewItems: TNodeArray; NewLength: Integer; ForceInsert: Boolean = False);\r\n\r\n// Adds the given items all at once into the current selection array. NewLength is the amount of\r\n// nodes to add (necessary to allow NewItems to be larger than the actual used entries).\r\n// ForceInsert is True if nodes must be inserted without consideration of level select constraint or\r\n// already set selected flags (e.g. when loading from stream).\r\n// Note: In the case ForceInsert is True the caller is responsible for making sure the new nodes aren't already in the\r\n//       selection array!\r\n\r\nvar\r\n  Changed: Boolean;\r\n\r\nbegin\r\n  Changed := InternalAddToSelection(NewItems, NewLength, ForceInsert);\r\n  if Changed then\r\n  begin\r\n    if NewLength = 1 then\r\n    begin\r\n      InvalidateNode(NewItems[0]);\r\n      Change(NewItems[0]);\r\n    end\r\n    else\r\n    begin\r\n      Invalidate;\r\n      Change(nil);\r\n    end;\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.AdjustImageBorder(Images: TCustomImageList; BidiMode: TBidiMode; VAlign: Integer; var R: TRect;\r\n  var ImageInfo: TVTImageInfo);\r\n\r\n// Depending on the width of the image list as well as the given bidi mode R must be adjusted.\r\n\r\nbegin\r\n  if BidiMode = bdLeftToRight then\r\n  begin\r\n    ImageInfo.XPos := R.Left-1;\r\n    Inc(R.Left, Images.Width + 2);\r\n  end\r\n  else\r\n  begin\r\n    ImageInfo.XPos := R.Right - Images.Width;\r\n    Dec(R.Right, Images.Width + 2);\r\n  end;\r\n  ImageInfo.YPos := R.Top + VAlign - Images.Height div 2;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.AdjustPaintCellRect(var PaintInfo: TVTPaintInfo; var NextNonEmpty: TColumnIndex);\r\n\r\n// Used in descendants to modify the paint rectangle of the current column while painting a certain node.\r\n\r\nbegin\r\n  // Since cells are always drawn from left to right the next column index is independent of the\r\n  // bidi mode, but not the column borders, which might change depending on the cell's content.\r\n  NextNonEmpty := FHeader.FColumns.GetNextVisibleColumn(PaintInfo.Column);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.AdjustPanningCursor(X, Y: Integer);\r\n\r\n// Triggered by a mouse move when wheel panning/scrolling is active.\r\n// Loads the proper cursor which indicates into which direction scrolling is done.\r\n\r\nvar\r\n  Name: string;\r\n  NewCursor: HCURSOR;\r\n  ScrollHorizontal,\r\n  ScrollVertical: Boolean;\r\n\r\nbegin\r\n  ScrollHorizontal := Integer(FRangeX) > ClientWidth;\r\n  ScrollVertical := Integer(FRangeY) > ClientHeight;\r\n\r\n  if (Abs(X - FLastClickPos.X) < 8) and (Abs(Y - FLastClickPos.Y) < 8) then\r\n  begin\r\n    // Mouse is in the neutral zone.\r\n    if ScrollHorizontal then\r\n    begin\r\n      if ScrollVertical then\r\n        Name := 'VT_MOVEALL'\r\n      else\r\n        Name := 'VT_MOVEEW';\r\n    end\r\n    else\r\n      Name := 'VT_MOVENS';\r\n  end\r\n  else\r\n  begin\r\n    // One of 8 directions applies: north, north-east, east, south-east, south, south-west, west and north-west.\r\n    // Check also if scrolling in the particular direction is possible.\r\n    if ScrollVertical and ScrollHorizontal then\r\n    begin\r\n      // All directions allowed.\r\n      if X - FLastClickPos.X < -8 then\r\n      begin\r\n        // Left hand side.\r\n        if Y - FLastClickPos.Y < -8 then\r\n          Name := 'VT_MOVENW'\r\n        else\r\n          if Y - FLastClickPos.Y > 8 then\r\n            Name := 'VT_MOVESW'\r\n          else\r\n            Name := 'VT_MOVEW';\r\n      end\r\n      else\r\n        if X - FLastClickPos.X > 8 then\r\n        begin\r\n          // Right hand side.\r\n          if Y - FLastClickPos.Y < -8 then\r\n            Name := 'VT_MOVENE'\r\n          else\r\n            if Y - FLastClickPos.Y > 8 then\r\n              Name := 'VT_MOVESE'\r\n            else\r\n              Name := 'VT_MOVEE';\r\n        end\r\n        else\r\n        begin\r\n          // Up or down.\r\n          if Y < FLastClickPos.Y then\r\n            Name := 'VT_MOVEN'\r\n          else\r\n            Name := 'VT_MOVES';\r\n        end;\r\n    end\r\n    else\r\n      if ScrollHorizontal then\r\n      begin\r\n        // Only horizontal movement allowed.\r\n        if X < FLastClickPos.X then\r\n          Name := 'VT_MOVEW'\r\n        else\r\n          Name := 'VT_MOVEE';\r\n      end\r\n      else\r\n      begin\r\n        // Only vertical movement allowed.\r\n        if Y < FLastClickPos.Y then\r\n          Name := 'VT_MOVEN'\r\n        else\r\n          Name := 'VT_MOVES';\r\n      end;\r\n  end;\r\n\r\n  // Now load the cursor and apply it.\r\n  NewCursor := LoadCursor(HInstance, PChar(Name));\r\n  if FPanningCursor <> NewCursor then\r\n  begin\r\n    DeleteObject(FPanningCursor);\r\n    FPanningCursor := NewCursor;\r\n    Winapi.Windows.SetCursor(FPanningCursor);\r\n  end\r\n  else\r\n    DeleteObject(NewCursor);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.AdviseChangeEvent(StructureChange: Boolean; Node: PVirtualNode; Reason: TChangeReason);\r\n\r\n// Used to register a delayed change event. If StructureChange is False then we have a selection change event (without\r\n// a specific reason) otherwise it is a structure change.\r\n\r\nbegin\r\n  if StructureChange then\r\n  begin\r\n    if tsStructureChangePending in FStates then\r\n      StopTimer(StructureChangeTimer)\r\n    else\r\n      DoStateChange([tsStructureChangePending]);\r\n\r\n    FLastStructureChangeNode := Node;\r\n    if FLastStructureChangeReason = crIgnore then\r\n      FLastStructureChangeReason := Reason\r\n    else\r\n      if Reason <> crIgnore then\r\n        FLastStructureChangeReason := crAccumulated;\r\n  end\r\n  else\r\n  begin\r\n    if tsChangePending in FStates then\r\n      StopTimer(ChangeTimer)\r\n    else\r\n      DoStateChange([tsChangePending]);\r\n\r\n    FLastChangedNode := Node;\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TBaseVirtualTree.AllocateInternalDataArea(Size: Cardinal): Cardinal;\r\n\r\n// Simple registration method to be called by each descendant to claim their internal data area.\r\n// Result is the offset from the begin of the node to the internal data area of the calling tree class.\r\n\r\nbegin\r\n  Assert((FRoot = nil) or (FRoot.ChildCount = 0), 'Internal data allocation must be done before any node is created.');\r\n  Result := TreeNodeSize + FTotalInternalDataSize;\r\n  Inc(FTotalInternalDataSize, (Size + (SizeOf(Pointer) - 1)) and not (SizeOf(Pointer) - 1));\r\n  InitRootNode(Result);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.Animate(Steps, Duration: Cardinal; Callback: TVTAnimationCallback; Data: Pointer);\r\n\r\n// This method does the calculation part of an animation as used for node toggling and hint animations.\r\n// Steps is the maximum amount of animation steps to do and Duration determines the milliseconds the animation\r\n// has to run. Callback is a task specific method which is called in the loop for every step and Data is simply\r\n// something to pass on to the callback.\r\n// The callback is called with the current step, the current step size and the Data parameter. Since the step amount\r\n// as well as the step size are possibly adjusted during the animation, it is impossible to determine if the current\r\n// step is the last step, even if the original step amount is known. To solve this problem the callback will be\r\n// called after the loop has finished with a step size of 0 indicating so to execute any post processing.\r\n\r\nvar\r\n  StepSize,\r\n  RemainingTime,\r\n  RemainingSteps,\r\n  NextTimeStep,\r\n  CurrentStep,\r\n  StartTime,\r\n  CurrentTime: Cardinal;\r\n\r\nbegin\r\n  if not (tsInAnimation in FStates) and (Duration > 0) then\r\n  begin\r\n    DoStateChange([tsInAnimation]);\r\n    try\r\n      RemainingTime := Duration;\r\n      RemainingSteps := Steps;\r\n\r\n      // Determine the initial step size which is either 1 if the needed steps are less than the number of\r\n      // steps possible given by the duration or > 1 otherwise.\r\n      StepSize := Round(Max(1, RemainingSteps / Duration));\r\n      RemainingSteps := RemainingSteps div StepSize;\r\n      CurrentStep := 0;\r\n\r\n      while (RemainingSteps > 0) and (RemainingTime > 0) and not Application.Terminated do\r\n      begin\r\n        StartTime := timeGetTime;\r\n        NextTimeStep := StartTime + RemainingTime div RemainingSteps;\r\n        if not Callback(CurrentStep, StepSize, Data) then\r\n          Break;\r\n\r\n        // Keep duration for this step for rest calculation.\r\n        CurrentTime := timeGetTime;\r\n        // Wait until the calculated time has been reached.\r\n        while CurrentTime < NextTimeStep do\r\n          CurrentTime := timeGetTime;\r\n\r\n        // Subtract the time this step really needed.\r\n        if RemainingTime >= CurrentTime - StartTime then\r\n        begin\r\n          Dec(RemainingTime, CurrentTime - StartTime);\r\n          Dec(RemainingSteps);\r\n        end\r\n        else\r\n        begin\r\n          RemainingTime := 0;\r\n          RemainingSteps := 0;\r\n        end;\r\n        // If the remaining time per step is less than one time step then we have to decrease the\r\n        // step count and increase the step size.\r\n        if (RemainingSteps > 0) and ((RemainingTime div RemainingSteps) < 1) then\r\n        begin\r\n          repeat\r\n            Inc(StepSize);\r\n            RemainingSteps := RemainingTime div StepSize;\r\n          until (RemainingSteps <= 0) or ((RemainingTime div RemainingSteps) >= 1);\r\n        end;\r\n        CurrentStep := Cardinal(Steps) - RemainingSteps;\r\n      end;\r\n\r\n      if not Application.Terminated then\r\n        Callback(0, 0, Data);\r\n    finally\r\n      DoStateChange([], [tsCancelHintAnimation, tsInAnimation]);\r\n    end;\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.StartOperation(OperationKind: TVTOperationKind);\r\n\r\n// Called to indicate that a long-running operation has been started.\r\n\r\nbegin\r\n  Inc(FOperationCount);\r\n  DoStartOperation(OperationKind);\r\n  if FOperationCount = 1 then\r\n    FOperationCanceled := False;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TBaseVirtualTree.CalculateSelectionRect(X, Y: Integer): Boolean;\r\n\r\n// Recalculates old and new selection rectangle given that X, Y are new mouse coordinates.\r\n// Returns True if there was a change since the last call.\r\n\r\nvar\r\n  MaxValue: Integer;\r\n\r\nbegin\r\n  if tsDrawSelecting in FStates then\r\n    FLastSelRect := FNewSelRect;\r\n  FNewSelRect.BottomRight := Point(X + FEffectiveOffsetX, Y - FOffsetY);\r\n  if FNewSelRect.Right < 0 then\r\n    FNewSelRect.Right := 0;\r\n  if FNewSelRect.Bottom < 0 then\r\n    FNewSelRect.Bottom := 0;\r\n  MaxValue := ClientWidth;\r\n  if FRangeX > Cardinal(MaxValue) then\r\n    MaxValue := FRangeX;\r\n  if FNewSelRect.Right > MaxValue then\r\n    FNewSelRect.Right := MaxValue;\r\n  MaxValue := ClientHeight;\r\n  if FRangeY > Cardinal(MaxValue) then\r\n    MaxValue := FRangeY;\r\n  if FNewSelRect.Bottom > MaxValue then\r\n    FNewSelRect.Bottom := MaxValue;\r\n\r\n  Result := not CompareMem(@FLastSelRect, @FNewSelRect, SizeOf(FNewSelRect));\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TBaseVirtualTree.CanAutoScroll: Boolean;\r\n\r\n// Determines if auto scrolling is currently allowed.\r\n\r\nvar\r\n  IsDropTarget: Boolean;\r\n  IsDrawSelecting: Boolean;\r\n  IsWheelPanning: Boolean;\r\n\r\nbegin\r\n  // Don't scroll the client area if the header is currently doing tracking or dragging.\r\n  // Do auto scroll only if there is a draw selection in progress or the tree is the current drop target or\r\n  // wheel panning/scrolling is active.\r\n  IsDropTarget := Assigned(FDragManager) and DragManager.IsDropTarget;\r\n  IsDrawSelecting := [tsDrawSelPending, tsDrawSelecting] * FStates <> [];\r\n  IsWheelPanning := [tsWheelPanning, tsWheelScrolling] * FStates <> [];\r\n  Result := ((toAutoScroll in FOptions.FAutoOptions) or IsWheelPanning) and\r\n    (FHeader.FStates = []) and (IsDrawSelecting or IsDropTarget or (tsVCLDragging in FStates) or IsWheelPanning);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TBaseVirtualTree.CanShowDragImage: Boolean;\r\n\r\n// Determines whether a drag image should be shown.\r\n\r\nbegin\r\n  Result := FDragImageKind <> diNoImage;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TBaseVirtualTree.CanSplitterResizeNode(P: TPoint; Node: PVirtualNode; Column: TColumnIndex): Boolean;\r\n\r\nbegin\r\n  Result := (toNodeHeightResize in FOptions.FMiscOptions) and Assigned(Node) and (Node <> FRoot) and\r\n            (Column > NoColumn) and (coFixed in FHeader.FColumns[Column].FOptions);\r\n  DoCanSplitterResizeNode(P, Node, Column, Result);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.Change(Node: PVirtualNode);\r\n\r\nbegin\r\n  AdviseChangeEvent(False, Node, crIgnore);\r\n\r\n  if FUpdateCount = 0 then\r\n  begin\r\n    if (FChangeDelay > 0) and not (tsSynchMode in FStates) then\r\n      SetTimer(Handle, ChangeTimer, FChangeDelay, nil)\r\n    else\r\n      DoChange(Node);\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.ChangeScale(M, D: Integer);\r\n\r\nbegin\r\n  inherited;\r\n\r\n  if (M <> D) and (toAutoChangeScale in FOptions.FAutoOptions) then\r\n  begin\r\n    SetDefaultNodeHeight(MulDiv(FDefaultNodeHeight, M, D));\r\n    Indent := MulDiv(Indent, M, D);\r\n    FHeader.ChangeScale(M, D);\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.ChangeTreeStatesAsync(EnterStates, LeaveStates: TChangeStates);\r\n\r\nbegin\r\n  if (Self.HandleAllocated) then\r\n    SendMessage(Self.Handle, WM_CHANGESTATE, Byte(EnterStates), Byte(LeaveStates));\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TBaseVirtualTree.CheckParentCheckState(Node: PVirtualNode; NewCheckState: TCheckState): Boolean;\r\n\r\n// Checks all siblings of node to determine which check state Node's parent must get.\r\n\r\nvar\r\n  CheckCount,\r\n  BoxCount: Cardinal;\r\n  PartialCheck: Boolean;\r\n  Run: PVirtualNode;\r\n\r\nbegin\r\n  CheckCount := 0;\r\n  BoxCount := 0;\r\n  PartialCheck := False;\r\n  Run := Node.Parent.FirstChild;\r\n  while Assigned(Run) do\r\n  begin\r\n    if Run = Node then\r\n    begin\r\n      // The given node cannot be checked because it does not yet have its new check state (as this depends\r\n      // on the outcome of this method). Instead NewCheckState is used as this contains the new state the node\r\n      // will get if this method returns True.\r\n      if Run.CheckType in [ctCheckBox, ctTriStateCheckBox] then\r\n      begin\r\n        Inc(BoxCount);\r\n        if NewCheckState in [csCheckedNormal, csCheckedPressed] then\r\n          Inc(CheckCount);\r\n        PartialCheck := PartialCheck or (NewCheckState = csMixedNormal);\r\n      end;\r\n    end\r\n    else\r\n      if Run.CheckType in [ctCheckBox, ctTriStateCheckBox] then\r\n      begin\r\n        Inc(BoxCount);\r\n        if Run.CheckState in [csCheckedNormal, csCheckedPressed] then\r\n          Inc(CheckCount);\r\n        PartialCheck := PartialCheck or (Run.CheckState = csMixedNormal);\r\n      end;\r\n    Run := Run.NextSibling;\r\n  end;\r\n\r\n  if (CheckCount = 0) and not PartialCheck then\r\n    NewCheckState := csUncheckedNormal\r\n  else\r\n    if CheckCount < BoxCount then\r\n      NewCheckState := csMixedNormal\r\n    else\r\n      NewCheckState := csCheckedNormal;\r\n\r\n  Node := Node.Parent;\r\n  Result := DoChecking(Node, NewCheckState);\r\n  if Result then\r\n  begin\r\n    DoCheckClick(Node, NewCheckState);\r\n    // Recursively adjust parent of parent.\r\n    // This is already done in the function DoCheckClick() called in the above line\r\n    // We revent unnecessary upward recursion by commenting this code.\r\n    //    with Node^ do\r\n    //    begin\r\n    //      if not (vsInitialized in Parent.States) then\r\n    //        InitNode(Parent);\r\n    //      if ([vsChecking, vsDisabled] * Parent.States = []) and (Parent <> FRoot) and\r\n    //        (Parent.CheckType = ctTriStateCheckBox) then\r\n    //        Result := CheckParentCheckState(Node, NewCheckState);\r\n    //    end;\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.ClearTempCache;\r\n\r\n// make sure the temporary node cache is in a reliable state\r\n\r\nbegin\r\n  FTempNodeCache := nil;\r\n  FTempNodeCount := 0;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TBaseVirtualTree.ColumnIsEmpty(Node: PVirtualNode; Column: TColumnIndex): Boolean;\r\n\r\n// Returns True if the given column is to be considered as being empty. This will usually be determined by\r\n// descendants as the base tree implementation has not enough information to decide.\r\n\r\nbegin\r\n  Result := True;\r\n  if Assigned(FOnGetCellIsEmpty) then\r\n    FOnGetCellIsEmpty(Self, Node, Column, Result);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TBaseVirtualTree.ComputeRTLOffset(ExcludeScrollBar: Boolean): Integer;\r\n\r\n// Computes the horizontal offset needed when all columns are automatically right aligned (in RTL bidi mode).\r\n// ExcludeScrollBar determines if the left-hand vertical scrollbar is to be included (if visible) or not.\r\n\r\nvar\r\n  HeaderWidth: Integer;\r\n  ScrollBarVisible: Boolean;\r\nbegin\r\n  ScrollBarVisible := (Integer(FRangeY) > ClientHeight) and (ScrollBarOptions.ScrollBars in [ssVertical, ssBoth]);\r\n  if ScrollBarVisible then\r\n    Result := GetSystemMetrics(SM_CXVSCROLL)\r\n  else\r\n    Result := 0;\r\n\r\n  // Make everything right aligned.\r\n  HeaderWidth := FHeaderRect.Right - FHeaderRect.Left;\r\n  if Integer(FRangeX) + Result <= HeaderWidth then\r\n    Result := HeaderWidth - Integer(FRangeX);\r\n  // Otherwise take only left-hand vertical scrollbar into account.\r\n\r\n  if ScrollBarVisible and ExcludeScrollBar then\r\n    Dec(Result, GetSystemMetrics(SM_CXVSCROLL));\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TBaseVirtualTree.CountLevelDifference(Node1, Node2: PVirtualNode): Integer;\r\n\r\n// This method counts how many indentation levels the given nodes are apart. If both nodes have the same parent then the\r\n// difference is 0 otherwise the result is basically GetNodeLevel(Node2) - GetNodeLevel(Node1), but with sign.\r\n// If the result is negative then Node2 is less intended than Node1.\r\n\r\nvar\r\n  Level1, Level2: Integer;\r\n\r\nbegin\r\n  Assert(Assigned(Node1) and Assigned(Node2), 'Both nodes must be Assigned.');\r\n\r\n  Level1 := 0;\r\n  while Node1.Parent <> FRoot do\r\n  begin\r\n    Inc(Level1);\r\n    Node1 := Node1.Parent;\r\n  end;\r\n\r\n  Level2 := 0;\r\n  while Node2.Parent <> FRoot do\r\n  begin\r\n    Inc(Level2);\r\n    Node2 := Node2.Parent;\r\n  end;\r\n\r\n  Result := Level2 - Level1;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TBaseVirtualTree.CountVisibleChildren(Node: PVirtualNode): Cardinal;\r\n\r\n// Returns the number of visible child nodes of the given node.\r\n\r\nbegin\r\n  Result := 0;\r\n\r\n  // The node's direct children...\r\n  if vsExpanded in Node.States then\r\n  begin\r\n    // ...and their children.\r\n    Node := Node.FirstChild;\r\n    while Assigned(Node) do\r\n    begin\r\n      if vsVisible in Node.States then\r\n        Inc(Result, CountVisibleChildren(Node) + Cardinal(IfThen(IsEffectivelyVisible[Node], 1)));\r\n      Node := Node.NextSibling;\r\n    end;\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.CreateParams(var Params: TCreateParams);\r\n\r\nconst\r\n  ScrollBar: array[TScrollStyle] of Cardinal = (0, WS_HSCROLL, WS_VSCROLL, WS_HSCROLL or WS_VSCROLL);\r\n\r\nbegin\r\n  inherited CreateParams(Params);\r\n \r\n  with Params do\r\n  begin\r\n    Style := Style or WS_CLIPCHILDREN or WS_CLIPSIBLINGS or ScrollBar[ScrollBarOptions.FScrollBars];\r\n    if toFullRepaintOnResize in FOptions.FMiscOptions then\r\n      WindowClass.style := WindowClass.style or CS_HREDRAW or CS_VREDRAW\r\n    else\r\n      WindowClass.style := WindowClass.style and not (CS_HREDRAW or CS_VREDRAW);\r\n    if FBorderStyle = bsSingle then\r\n    begin\r\n      if Ctl3D then\r\n      begin\r\n        ExStyle := ExStyle or WS_EX_CLIENTEDGE;\r\n        Style := Style and not WS_BORDER;\r\n      end\r\n      else\r\n        Style := Style or WS_BORDER;\r\n    end\r\n    else\r\n      Style := Style and not WS_BORDER;\r\n\r\n    AddBiDiModeExStyle(ExStyle);\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.CreateWnd;\r\n\r\n// Initializes data which depends on a valid window handle.\r\n\r\nbegin\r\n  DoStateChange([tsWindowCreating]);\r\n  inherited;\r\n  DoStateChange([], [tsWindowCreating]);\r\n\r\n  if ((StyleServices.Enabled ) and (toThemeAware in TreeOptions.PaintOptions)  ) then\r\n  begin\r\n    DoStateChange([tsUseThemes]);\r\n    if (toUseExplorerTheme in FOptions.FPaintOptions) and IsWinVistaOrAbove then\r\n    begin\r\n      DoStateChange([tsUseExplorerTheme]);\r\n      SetWindowTheme('explorer');\r\n    end\r\n    else\r\n      DoStateChange([], [tsUseExplorerTheme]);\r\n  end\r\n  else\r\n    DoStateChange([], [tsUseThemes, tsUseExplorerTheme]);\r\n\r\n  AutoScale();\r\n  // Because of the special recursion and update stopper when creating the window (or resizing it)\r\n  // we have to manually trigger the auto size calculation here.\r\n  if hsNeedScaling in FHeader.FStates then\r\n    FHeader.RescaleHeader;\r\n  if hoAutoResize in FHeader.FOptions then\r\n    FHeader.FColumns.AdjustAutoSize(InvalidColumn);\r\n\r\n  PrepareBitmaps(True, True);\r\n\r\n  // Register tree as OLE drop target.\r\n  if not (csDesigning in ComponentState) and (toAcceptOLEDrop in FOptions.FMiscOptions) then\r\n    if not (csLoading in ComponentState) then // will be done in Loaded after all inherited settings are loaded from the DFMs\r\n      RegisterDragDrop(Handle, DragManager as IDropTarget);\r\n\r\n  UpdateScrollBars(True);\r\n  UpdateHeaderRect;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.DefineProperties(Filer: TFiler);\r\n\r\n// There were heavy changes in some properties during development of VT. This method helps to make migration easier\r\n// by reading old properties manually and put them into the new properties as appropriate.\r\n// Note: these old properties are never written again and silently disappear.\r\n// June 2002: Meanwhile another task is done here too: working around the problem that TCollection is not streamed\r\n//            correctly when using Visual Form Inheritance (VFI).\r\n\r\nvar\r\n  StoreIt: Boolean;\r\n\r\nbegin\r\n  inherited;\r\n\r\n  // The header can prevent writing columns altogether.\r\n  if FHeader.CanWriteColumns then\r\n  begin\r\n    // Check if we inherit from an ancestor form (Visual Form Inheritance).\r\n    StoreIt := Filer.Ancestor = nil;\r\n    // If there is an ancestor then save columns only if they are different to the base set.\r\n    if not StoreIt then\r\n      StoreIt := not FHeader.Columns.Equals(TBaseVirtualTree(Filer.Ancestor).FHeader.Columns);\r\n  end\r\n  else\r\n    StoreIt := False;\r\n\r\n  Filer.DefineProperty('Columns', FHeader.ReadColumns, FHeader.WriteColumns, StoreIt);\r\n  Filer.DefineProperty('Options', ReadOldOptions, nil, False);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TBaseVirtualTree.DetermineDropMode(const P: TPoint; var HitInfo: THitInfo; var NodeRect: TRect): TDropMode;\r\n\r\n// Determine the DropMode.\r\n\r\nvar\r\n  ImageHit: Boolean;\r\n  LabelHit: Boolean;\r\n  ItemHit: Boolean;\r\n\r\nbegin\r\n  ImageHit := HitInfo.HitPositions * [hiOnNormalIcon, hiOnStateIcon] <> [];\r\n  LabelHit := hiOnItemLabel in HitInfo.HitPositions;\r\n  ItemHit := ((hiOnItem in HitInfo.HitPositions) and\r\n             ((toFullRowDrag in FOptions.FMiscOptions) or (toFullRowSelect in FOptions.FSelectionOptions)));\r\n\r\n  // In report mode only direct hits of the node captions/images in the main column are accepted as hits.\r\n  if (toReportMode in FOptions.FMiscOptions) and not (ItemHit or ((LabelHit or ImageHit) and\r\n    (HitInfo.HitColumn = FHeader.MainColumn))) then\r\n    HitInfo.HitNode := nil;\r\n\r\n  if Assigned(HitInfo.HitNode) then\r\n  begin\r\n    if LabelHit or ImageHit or not (toShowDropmark in FOptions.FPaintOptions) then\r\n      Result := dmOnNode\r\n    else\r\n      if ((NodeRect.Top + NodeRect.Bottom) div 2) > P.Y then\r\n        Result := dmAbove\r\n      else\r\n        Result := dmBelow;\r\n  end\r\n  else\r\n    Result := dmNowhere;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.DetermineHiddenChildrenFlag(Node: PVirtualNode);\r\n\r\n// Update the hidden children flag of the given node.\r\n\r\nvar\r\n  Run: PVirtualNode;\r\n\r\nbegin\r\n  if Node.ChildCount = 0 then\r\n  begin\r\n    if vsHasChildren in Node.States then\r\n      Exclude(Node.States, vsAllChildrenHidden)\r\n    else\r\n      Include(Node.States, vsAllChildrenHidden);\r\n  end\r\n  else\r\n  begin\r\n    // Iterate through all siblings and stop when one visible is found.\r\n    Run := Node.FirstChild;\r\n    while Assigned(Run) and not IsEffectivelyVisible[Run] do\r\n      Run := Run.NextSibling;\r\n    if Assigned(Run) then\r\n      Exclude(Node.States, vsAllChildrenHidden)\r\n    else\r\n      Include(Node.States, vsAllChildrenHidden);\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.DetermineHiddenChildrenFlagAllNodes;\r\n\r\nvar\r\n  Run: PVirtualNode;\r\n\r\nbegin\r\n  Run := GetFirstNoInit(False);\r\n  while Assigned(Run) do\r\n  begin\r\n    DetermineHiddenChildrenFlag(Run);\r\n    Run := GetNextNoInit(Run);\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.DetermineHitPositionLTR(var HitInfo: THitInfo; Offset, Right: Integer;\r\n  Alignment: TAlignment);\r\n\r\n// This method determines the hit position within a node with left-to-right orientation.\r\n\r\nvar\r\n  MainColumnHit: Boolean;\r\n  Run: PVirtualNode;\r\n  Indent,\r\n  TextWidth,\r\n  ImageOffset: Integer;\r\n\r\nbegin\r\n  MainColumnHit := HitInfo.HitColumn = FHeader.MainColumn;\r\n  Indent := 0;\r\n\r\n  // If columns are not used or the main column is hit then the tree indentation must be considered too.\r\n  if MainColumnHit then\r\n  begin\r\n    if toFixedIndent in FOptions.FPaintOptions then\r\n      Indent := FIndent\r\n    else\r\n    begin\r\n      Run := HitInfo.HitNode;\r\n      while (Run.Parent <> FRoot) do\r\n      begin\r\n        Inc(Indent, FIndent);\r\n      Run := Run.Parent;\r\n      end;\r\n      if toShowRoot in FOptions.FPaintOptions then\r\n        Inc(Indent, FIndent);\r\n    end;\r\n  end;\r\n\r\n  if (MainColumnHit and (Offset < (Indent + Margin{See issue #259}))) then\r\n  begin\r\n    // Position is to the left of calculated indentation which can only happen for the main column.\r\n    // Check whether it corresponds to a button/checkbox.\r\n    if (toShowButtons in FOptions.FPaintOptions) and (vsHasChildren in HitInfo.HitNode.States) then\r\n    begin\r\n      // Position of button is interpreted very generously to avoid forcing the user\r\n      // to click exactly into the 9x9 pixels area. The entire node height and one full\r\n      // indentation level is accepted as button hit.\r\n      if Offset >= Indent - Integer(FIndent) then\r\n        Include(HitInfo.HitPositions, hiOnItemButton);\r\n      if Offset >= Indent - FPlusBM.Width then\r\n        Include(HitInfo.HitPositions, hiOnItemButtonExact);\r\n    end;\r\n    // no button hit so position is on indent\r\n    if HitInfo.HitPositions = [] then\r\n      Include(HitInfo.HitPositions, hiOnItemIndent);\r\n  end\r\n  else\r\n  begin\r\n    // The next hit positions can be:\r\n    //   - on the check box\r\n    //   - on the state image\r\n    //   - on the normal image\r\n    //   - to the left of the text area\r\n    //   - on the label or\r\n    //   - to the right of the text area\r\n    // (in this order).\r\n\r\n    // In report mode no hit other than in the main column is possible.\r\n    if MainColumnHit or not (toReportMode in FOptions.FMiscOptions) then\r\n    begin\r\n      ImageOffset := Indent +  FMargin;\r\n\r\n      // Check support is only available for the main column.\r\n      if MainColumnHit and (toCheckSupport in FOptions.FMiscOptions) and Assigned(FCheckImages) and\r\n        (HitInfo.HitNode.CheckType <> ctNone) then\r\n        Inc(ImageOffset, FCheckImages.Width + 2);\r\n\r\n      if MainColumnHit and (Offset < ImageOffset) then\r\n      begin\r\n        HitInfo.HitPositions := [hiOnItem];\r\n        if (HitInfo.HitNode.CheckType <> ctNone) then\r\n          Include(HitInfo.HitPositions, hiOnItemCheckBox);\r\n      end\r\n      else\r\n      begin\r\n        if Assigned(FStateImages) and HasImage(HitInfo.HitNode, ikState, HitInfo.HitColumn) then\r\n          Inc(ImageOffset, FStateImages.Width + 2);\r\n        if Offset < ImageOffset then\r\n          Include(HitInfo.HitPositions, hiOnStateIcon)\r\n        else\r\n        begin\r\n          if Assigned(FImages) and HasImage(HitInfo.HitNode, ikNormal, HitInfo.HitColumn) then\r\n            Inc(ImageOffset, GetNodeImageSize(HitInfo.HitNode).cx + 2);\r\n          if Offset < ImageOffset then\r\n            Include(HitInfo.HitPositions, hiOnNormalIcon)\r\n          else\r\n          begin\r\n            // ImageOffset contains now the left border of the node label area. This is used to calculate the\r\n            // correct alignment in the column.\r\n            TextWidth := DoGetNodeWidth(HitInfo.HitNode, HitInfo.HitColumn);\r\n\r\n            // Check if the text can be aligned at all. This is only possible if there is enough room\r\n            // in the remaining text rectangle.\r\n            if TextWidth > Right - ImageOffset then\r\n              Include(HitInfo.HitPositions, hiOnItemLabel)\r\n            else\r\n            begin\r\n              case Alignment of\r\n                taCenter:\r\n                  begin\r\n                    Indent := (ImageOffset + Right - TextWidth) div 2;\r\n                    if Offset < Indent then\r\n                      Include(HitInfo.HitPositions, hiOnItemLeft)\r\n                    else\r\n                      if Offset < Indent + TextWidth then\r\n                        Include(HitInfo.HitPositions, hiOnItemLabel)\r\n                      else\r\n                        Include(HitInfo.HitPositions, hiOnItemRight);\r\n                  end;\r\n                taRightJustify:\r\n                  begin\r\n                    Indent := Right - TextWidth;\r\n                    if Offset < Indent then\r\n                      Include(HitInfo.HitPositions, hiOnItemLeft)\r\n                    else\r\n                      Include(HitInfo.HitPositions, hiOnItemLabel);\r\n                  end;\r\n              else // taLeftJustify\r\n                if Offset < ImageOffset + TextWidth then\r\n                  Include(HitInfo.HitPositions, hiOnItemLabel)\r\n                else\r\n                  Include(HitInfo.HitPositions, hiOnItemRight);\r\n              end;\r\n            end;\r\n          end;\r\n        end;\r\n      end;\r\n    end;\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.DetermineHitPositionRTL(var HitInfo: THitInfo; Offset, Right: Integer; Alignment: TAlignment);\r\n\r\n// This method determines the hit position within a node with right-to-left orientation.\r\n\r\nvar\r\n  MainColumnHit: Boolean;\r\n  Run: PVirtualNode;\r\n  Indent,\r\n  TextWidth,\r\n  ImageOffset: Integer;\r\n\r\nbegin\r\n  MainColumnHit := HitInfo.HitColumn = FHeader.MainColumn;\r\n\r\n  // If columns are not used or the main column is hit then the tree indentation must be considered too.\r\n  if MainColumnHit then\r\n  begin\r\n    if toFixedIndent in FOptions.FPaintOptions then\r\n      Dec(Right, FIndent)\r\n    else\r\n    begin\r\n      Run := HitInfo.HitNode;\r\n      while (Run.Parent <> FRoot) do\r\n      begin\r\n        Dec(Right, FIndent);\r\n        Run := Run.Parent;\r\n      end;\r\n      if toShowRoot in FOptions.FPaintOptions then\r\n        Dec(Right, FIndent);\r\n    end;\r\n  end;\r\n\r\n  if Offset >= Right then\r\n  begin\r\n    // Position is to the right of calculated indentation which can only happen for the main column.\r\n    // Check whether it corresponds to a button/checkbox.\r\n    if (toShowButtons in FOptions.FPaintOptions) and (vsHasChildren in HitInfo.HitNode.States) then\r\n    begin\r\n      // Position of button is interpreted very generously to avoid forcing the user\r\n      // to click exactly into the 9x9 pixels area. The entire node height and one full\r\n      // indentation level is accepted as button hit.\r\n      if Offset <= Right + Integer(FIndent) then\r\n        Include(HitInfo.HitPositions, hiOnItemButton);\r\n      if Offset <= Right + FPlusBM.Width then\r\n        Include(HitInfo.HitPositions, hiOnItemButtonExact);\r\n    end;\r\n    // no button hit so position is on indent\r\n    if HitInfo.HitPositions = [] then\r\n      Include(HitInfo.HitPositions, hiOnItemIndent);\r\n  end\r\n  else\r\n  begin\r\n    // The next hit positions can be:\r\n    //   - on the check box\r\n    //   - on the state image\r\n    //   - on the normal image\r\n    //   - to the left of the text area\r\n    //   - on the label or\r\n    //   - to the right of the text area\r\n    // (in this order).\r\n\r\n    // In report mode no hit other than in the main column is possible.\r\n    if MainColumnHit or not (toReportMode in FOptions.FMiscOptions) then\r\n    begin\r\n      ImageOffset := Right - FMargin;\r\n\r\n      // Check support is only available for the main column.\r\n      if MainColumnHit and (toCheckSupport in FOptions.FMiscOptions) and Assigned(FCheckImages) and\r\n        (HitInfo.HitNode.CheckType <> ctNone) then\r\n        Dec(ImageOffset, FCheckImages.Width + 2);\r\n\r\n      if MainColumnHit and (Offset > ImageOffset) then\r\n      begin\r\n        HitInfo.HitPositions := [hiOnItem];\r\n        if (HitInfo.HitNode.CheckType <> ctNone) then\r\n          Include(HitInfo.HitPositions, hiOnItemCheckBox);\r\n      end\r\n      else\r\n      begin\r\n        if Assigned(FStateImages) and HasImage(HitInfo.HitNode, ikState, HitInfo.HitColumn) then\r\n          Dec(ImageOffset, FStateImages.Width + 2);\r\n        if Offset > ImageOffset then\r\n          Include(HitInfo.HitPositions, hiOnStateIcon)\r\n        else\r\n        begin\r\n          if Assigned(FImages) and HasImage(HitInfo.HitNode, ikNormal, HitInfo.HitColumn) then\r\n            Dec(ImageOffset, GetNodeImageSize(HitInfo.HitNode).cx + 2);\r\n          if Offset > ImageOffset then\r\n            Include(HitInfo.HitPositions, hiOnNormalIcon)\r\n          else\r\n          begin\r\n            // ImageOffset contains now the right border of the node label area. This is used to calculate the\r\n            // correct alignment in the column.\r\n            TextWidth := DoGetNodeWidth(HitInfo.HitNode, HitInfo.HitColumn);\r\n\r\n            // Check if the text can be aligned at all. This is only possible if there is enough room\r\n            // in the remaining text rectangle.\r\n            if TextWidth > ImageOffset then\r\n              Include(HitInfo.HitPositions, hiOnItemLabel)\r\n            else\r\n            begin\r\n              // Consider bidi mode here. In RTL context does left alignment actually mean right alignment\r\n              // and vice versa.\r\n              ChangeBiDiModeAlignment(Alignment);\r\n\r\n              case Alignment of\r\n                taCenter:\r\n                  begin\r\n                    Indent := (ImageOffset - TextWidth) div 2;\r\n                    if Offset < Indent then\r\n                      Include(HitInfo.HitPositions, hiOnItemLeft)\r\n                    else\r\n                      if Offset < Indent + TextWidth then\r\n                        Include(HitInfo.HitPositions, hiOnItemLabel)\r\n                      else\r\n                        Include(HitInfo.HitPositions, hiOnItemRight);\r\n                  end;\r\n                taRightJustify:\r\n                  begin\r\n                    Indent := ImageOffset - TextWidth;\r\n                    if Offset < Indent then\r\n                      Include(HitInfo.HitPositions, hiOnItemLeft)\r\n                    else\r\n                      Include(HitInfo.HitPositions, hiOnItemLabel);\r\n                  end;\r\n              else // taLeftJustify\r\n                if Offset > TextWidth then\r\n                  Include(HitInfo.HitPositions, hiOnItemRight)\r\n                else\r\n                  Include(HitInfo.HitPositions, hiOnItemLabel);\r\n              end;\r\n            end;\r\n          end;\r\n        end;\r\n      end;\r\n    end;\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TBaseVirtualTree.DetermineLineImageAndSelectLevel(Node: PVirtualNode; var LineImage: TLineImage): Integer;\r\n\r\n// This method is used during paint cycles and initializes an array of line type IDs. These IDs are used to paint\r\n// the tree lines in front of the given node.\r\n// Additionally an initial count of selected parents is determined and returned which is used for specific painting.\r\n\r\nvar\r\n  X: Integer;\r\n  Indent: Integer;\r\n  Run: PVirtualNode;\r\n\r\nbegin\r\n  Result := 0;\r\n  if toShowRoot in FOptions.FPaintOptions then\r\n    X := 1\r\n  else\r\n    X := 0;\r\n  Run := Node;\r\n  // Determine indentation level of top node.\r\n  while Run.Parent <> FRoot do\r\n  begin\r\n    Inc(X);\r\n    Run := Run.Parent;\r\n    // Count selected nodes (FRoot is never selected).\r\n    if vsSelected in Run.States then\r\n      Inc(Result);\r\n  end;\r\n\r\n  // Set initial size of line index array, this will automatically initialized all entries to ltNone.\r\n  SetLength(LineImage, X);\r\n  Indent := X - 1;\r\n\r\n  // Only use lines if requested.\r\n  if (toShowTreeLines in FOptions.FPaintOptions) and\r\n     (not (toHideTreeLinesIfThemed in FOptions.FPaintOptions) or not (tsUseThemes in FStates)) then\r\n  begin\r\n    if toChildrenAbove in FOptions.FPaintOptions then\r\n    begin\r\n      Dec(X);\r\n      if not HasVisiblePreviousSibling(Node) then\r\n      begin\r\n        if (Node.Parent <> FRoot) or HasVisibleNextSibling(Node) then\r\n          LineImage[X] := ltBottomRight\r\n        else\r\n          LineImage[X] := ltRight;\r\n      end\r\n      else\r\n        if (Node.Parent = FRoot) and (not HasVisibleNextSibling(Node)) then\r\n          LineImage[X] := ltTopRight\r\n        else\r\n          LineImage[X] := ltTopDownRight;\r\n\r\n      // Now go up to the root to determine the rest.\r\n      Run := Node.Parent;\r\n      while Run <> FRoot do\r\n      begin\r\n        Dec(X);\r\n        if HasVisiblePreviousSibling(Run) then\r\n          LineImage[X] := ltTopDown\r\n        else\r\n          LineImage[X] := ltNone;\r\n\r\n        Run := Run.Parent;\r\n      end;\r\n    end\r\n    else\r\n    begin\r\n      // Start over parent traversal if necessary.\r\n      Run := Node;\r\n\r\n      if Run.Parent <> FRoot then\r\n      begin\r\n        // The very last image (the one immediately before the item label) is different.\r\n        if HasVisibleNextSibling(Run) then\r\n          LineImage[X - 1] := ltTopDownRight\r\n        else\r\n          LineImage[X - 1] := ltTopRight;\r\n        Run := Run.Parent;\r\n\r\n        // Now go up all parents.\r\n        repeat\r\n          if Run.Parent = FRoot then\r\n            Break;\r\n          Dec(X);\r\n          if HasVisibleNextSibling(Run) then\r\n            LineImage[X - 1] := ltTopDown\r\n          else\r\n            LineImage[X - 1] := ltNone;\r\n          Run := Run.Parent;\r\n        until False;\r\n      end;\r\n\r\n      // Prepare root level. Run points at this stage to a top level node.\r\n      if (toShowRoot in FOptions.FPaintOptions) and ((toShowTreeLines in FOptions.FPaintOptions) and\r\n         (not (toHideTreeLinesIfThemed in FOptions.FPaintOptions) or not (tsUseThemes in FStates))) then\r\n      begin\r\n        // Is the top node a root node?\r\n        if Run = Node then\r\n        begin\r\n          // First child gets the bottom-right bitmap if it isn't also the only child.\r\n          if IsFirstVisibleChild(FRoot, Run) then\r\n            // Is it the only child?\r\n            if IsLastVisibleChild(FRoot, Run) then\r\n              LineImage[0] := ltRight\r\n            else\r\n              LineImage[0] := ltBottomRight\r\n          else\r\n            // real last child\r\n            if IsLastVisibleChild(FRoot, Run) then\r\n              LineImage[0] := ltTopRight\r\n            else\r\n              LineImage[0] := ltTopDownRight;\r\n        end\r\n        else\r\n        begin\r\n          // No, top node is not a top level node. So we need different painting.\r\n          if HasVisibleNextSibling(Run) then\r\n            LineImage[0] := ltTopDown\r\n          else\r\n            LineImage[0] := ltNone;\r\n        end;\r\n      end;\r\n    end;\r\n  end;\r\n\r\n  if (tsUseExplorerTheme in FStates) and HasChildren[Node] and (Indent >= 0) then\r\n    LineImage[Indent] := ltNone;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TBaseVirtualTree.DetermineNextCheckState(CheckType: TCheckType; CheckState: TCheckState): TCheckState;\r\n\r\n// Determines the next check state in case the user click the check image or pressed the space key.\r\n\r\nbegin\r\n  case CheckType of\r\n    ctTriStateCheckBox,\r\n    ctCheckBox:\r\n      if CheckState = csCheckedNormal then\r\n        Result := csUncheckedNormal\r\n      else\r\n        Result := csCheckedNormal;\r\n    ctRadioButton:\r\n      Result := csCheckedNormal;\r\n    ctButton:\r\n      Result := csUncheckedNormal;\r\n  else\r\n    Result := csMixedNormal;\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TBaseVirtualTree.DetermineScrollDirections(X, Y: Integer): TScrollDirections;\r\n\r\n// Determines which direction the client area must be scrolled depending on the given position.\r\n\r\nbegin\r\n  Result:= [];\r\n\r\n  if CanAutoScroll then\r\n  begin\r\n    // Calculation for wheel panning/scrolling is a bit different to normal auto scroll.\r\n    if [tsWheelPanning, tsWheelScrolling] * FStates <> [] then\r\n    begin\r\n      if (X - FLastClickPos.X) < -8 then\r\n        Include(Result, sdLeft);\r\n      if (X - FLastClickPos.X) > 8 then\r\n        Include(Result, sdRight);\r\n\r\n      if (Y - FLastClickPos.Y) < -8 then\r\n        Include(Result, sdUp);\r\n      if (Y - FLastClickPos.Y) > 8 then\r\n        Include(Result, sdDown);\r\n    end\r\n    else\r\n    begin\r\n      if (X < Integer(FDefaultNodeHeight)) and (FEffectiveOffsetX <> 0) then\r\n        Include(Result, sdLeft);\r\n      if (ClientWidth + FEffectiveOffsetX < Integer(FRangeX)) and (X > ClientWidth - Integer(FDefaultNodeHeight)) then\r\n        Include(Result, sdRight);\r\n\r\n      if (Y < Integer(FDefaultNodeHeight)) and (FOffsetY <> 0) then\r\n        Include(Result, sdUp);\r\n      if (ClientHeight - FOffsetY < Integer(FRangeY)) and (Y > ClientHeight - Integer(FDefaultNodeHeight)) then\r\n        Include(Result, sdDown);\r\n\r\n      // Since scrolling during dragging is not handled via the timer we do a check here whether the auto\r\n      // scroll timeout already has elapsed or not.\r\n      if (Result <> []) and\r\n        ((Assigned(FDragManager) and DragManager.IsDropTarget) or\r\n        (FindDragTarget(Point(X, Y), False) = Self)) then\r\n      begin\r\n        if FDragScrollStart = 0 then\r\n          FDragScrollStart := timeGetTime;\r\n        // Reset any scroll direction to avoid scroll in the case the user is dragging and the auto scroll time has not\r\n        // yet elapsed.\r\n        if ((timeGetTime - FDragScrollStart) < FAutoScrollDelay) then\r\n          Result := [];\r\n      end;\r\n    end;\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.DoAdvancedHeaderDraw(var PaintInfo: THeaderPaintInfo; const Elements: THeaderPaintElements);\r\n\r\nbegin\r\n  if Assigned(FOnAdvancedHeaderDraw) then\r\n    FOnAdvancedHeaderDraw(FHeader, PaintInfo, Elements);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.DoAfterCellPaint(Canvas: TCanvas; Node: PVirtualNode; Column: TColumnIndex; CellRect: TRect);\r\n\r\nbegin\r\n  if Assigned(FOnAfterCellPaint) then\r\n    FOnAfterCellPaint(Self, Canvas, Node, Column, CellRect);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.DoAfterItemErase(Canvas: TCanvas; Node: PVirtualNode; ItemRect: TRect);\r\n\r\nbegin\r\n  if Assigned(FOnAfterItemErase) then\r\n    FOnAfterItemErase(Self, Canvas, Node, ItemRect);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.DoAfterItemPaint(Canvas: TCanvas; Node: PVirtualNode; ItemRect: TRect);\r\n\r\nbegin\r\n  if Assigned(FOnAfterItemPaint) then\r\n    FOnAfterItemPaint(Self, Canvas, Node, ItemRect);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.DoAfterPaint(Canvas: TCanvas);\r\n\r\nbegin\r\n  if Assigned(FOnAfterPaint) then\r\n    FOnAfterPaint(Self, Canvas);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.DoAutoScroll(X, Y: Integer);\r\n\r\nbegin\r\n  FScrollDirections := DetermineScrollDirections(X, Y);\r\n\r\n  if FStates * [tsWheelPanning, tsWheelScrolling] = [] then\r\n  begin\r\n    if FScrollDirections = [] then\r\n    begin\r\n      if ((FStates * [tsScrollPending, tsScrolling]) <> []) then\r\n      begin\r\n        StopTimer(ScrollTimer);\r\n        DoStateChange([], [tsScrollPending, tsScrolling]);\r\n      end;\r\n    end\r\n    else\r\n    begin\r\n      // start auto scroll if not yet done\r\n      if (FStates * [tsScrollPending, tsScrolling]) = [] then\r\n      begin\r\n        DoStateChange([tsScrollPending]);\r\n        SetTimer(Handle, ScrollTimer, FAutoScrollDelay, nil);\r\n      end;\r\n    end;\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TBaseVirtualTree.DoBeforeDrag(Node: PVirtualNode; Column: TColumnIndex): Boolean;\r\n\r\nbegin\r\n  Result := False;\r\n  if Assigned(FOnDragAllowed) then\r\n    FOnDragAllowed(Self, Node, Column, Result);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.DoBeforeCellPaint(Canvas: TCanvas; Node: PVirtualNode; Column: TColumnIndex;\r\n  CellPaintMode: TVTCellPaintMode; CellRect: TRect; var ContentRect: TRect);\r\n\r\nvar\r\n  UpdateRect: TRect;\r\n\r\nbegin\r\n  if Assigned(FOnBeforeCellPaint) then\r\n  begin\r\n    if CellPaintMode = cpmGetContentMargin then\r\n    begin\r\n      // Prevent drawing if we are only about to get the margin. As this also clears the update rect we need to save it.\r\n      GetUpdateRect(Handle, UpdateRect, False);\r\n      SetUpdateState(True);\r\n    end;\r\n\r\n    Canvas.Font := Self.Font; // Fixes issue #298\r\n    FOnBeforeCellPaint(Self, Canvas, Node, Column, CellPaintMode, CellRect, ContentRect);\r\n\r\n    if CellPaintMode = cpmGetContentMargin then\r\n    begin\r\n      SetUpdateState(False);\r\n      InvalidateRect(Handle, @UpdateRect, False);\r\n    end;\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.DoBeforeItemErase(Canvas: TCanvas; Node: PVirtualNode; ItemRect: TRect; var Color: TColor;\r\n  var EraseAction: TItemEraseAction);\r\n\r\nbegin\r\n  if Assigned(FOnBeforeItemErase) then\r\n    FOnBeforeItemErase(Self, Canvas, Node, ItemRect, Color, EraseAction);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TBaseVirtualTree.DoBeforeItemPaint(Canvas: TCanvas; Node: PVirtualNode; ItemRect: TRect): Boolean;\r\n\r\nbegin\r\n  // By default custom draw will not be used, so the tree handles drawing the node.\r\n  Result := False;\r\n  if Assigned(FOnBeforeItemPaint) then\r\n    FOnBeforeItemPaint(Self, Canvas, Node, ItemRect, Result);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.DoBeforePaint(Canvas: TCanvas);\r\n\r\nbegin\r\n  if Assigned(FOnBeforePaint) then\r\n    FOnBeforePaint(Self, Canvas);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TBaseVirtualTree.DoCancelEdit: Boolean;\r\n\r\n// Called when the current edit action or a pending edit must be cancelled.\r\n\r\nbegin\r\n  StopTimer(EditTimer);\r\n  DoStateChange([], [tsEditPending]);\r\n  Result := (tsEditing in FStates) and FEditLink.CancelEdit;\r\n  if Result then\r\n  begin\r\n    DoStateChange([], [tsEditing]);\r\n    if Assigned(FOnEditCancelled) then\r\n      FOnEditCancelled(Self, FEditColumn);\r\n    if not (csDestroying in ComponentState) then\r\n      FEditLink := nil;\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.DoCanEdit(Node: PVirtualNode; Column: TColumnIndex; var Allowed: Boolean);\r\n\r\nbegin\r\n  if Assigned(FOnEditing) then\r\n    FOnEditing(Self, Node, Column, Allowed);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.DoCanSplitterResizeNode(P: TPoint; Node: PVirtualNode; Column: TColumnIndex;\r\n  var Allowed: Boolean);\r\n\r\nbegin\r\n  if Assigned(FOnCanSplitterResizeNode) then\r\n    FOnCanSplitterResizeNode(Self, P, Node, Column, Allowed);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.DoChange(Node: PVirtualNode);\r\n\r\nbegin\r\n  StopTimer(ChangeTimer);\r\n  if Assigned(FOnChange) then\r\n    FOnChange(Self, Node);\r\n\r\n  // This is a good place to reset the cached node. This is the same as the node passed in here.\r\n  // This is necessary to allow descendants to override this method and get the node then.\r\n  DoStateChange([], [tsChangePending]);\r\n  FLastChangedNode := nil;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.DoCheckClick(Node: PVirtualNode; NewCheckState: TCheckState);\r\n\r\nbegin\r\n  if ChangeCheckState(Node, NewCheckState) then\r\n    DoChecked(Node);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.DoChecked(Node: PVirtualNode);\r\n\r\nbegin\r\n  if Assigned(FOnChecked) then\r\n    FOnChecked(Self, Node);\r\n  if Assigned(FAccessibleItem) then\r\n    NotifyWinEvent(EVENT_OBJECT_STATECHANGE, Handle, OBJID_CLIENT, CHILDID_SELF);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TBaseVirtualTree.DoChecking(Node: PVirtualNode; var NewCheckState: TCheckState): Boolean;\r\n\r\n// Determines if a node is allowed to change its check state to NewCheckState.\r\n\r\nbegin\r\n  if toReadOnly in FOptions.FMiscOptions then\r\n    Result := False\r\n  else\r\n  begin\r\n    Result := True;\r\n    if Assigned(FOnChecking) then\r\n      FOnChecking(Self, Node, NewCheckState, Result);\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.DoCollapsed(Node: PVirtualNode);\r\nvar\r\n  lFirstSelected: PVirtualNode;\r\n  lParent: PVirtualNode;\r\nbegin\r\n  if Assigned(FOnCollapsed) then\r\n    FOnCollapsed(Self, Node);\r\n\r\n  if Assigned(FAccessibleItem) then\r\n    NotifyWinEvent(EVENT_OBJECT_STATECHANGE, Handle, OBJID_CLIENT, CHILDID_SELF);\r\n\r\n  if (toAlwaysSelectNode in TreeOptions.SelectionOptions) then\r\n  begin\r\n    // Select the next visible parent if the currently selected node gets invisible due to a collapse\r\n    // This makes the VT behave more like the Win32 custom TreeView control\r\n    // This makes only sense no no multi selection is allowed and if there is a selected node at all\r\n    lFirstSelected := GetFirstSelected();\r\n    if Assigned(lFirstSelected) and not FullyVisible[lFirstSelected] then\r\n    begin\r\n      lParent := GetVisibleParent(lFirstSelected);\r\n      Selected[lFirstSelected] := False;\r\n      Selected[lParent] := True;\r\n    end;//if\r\n    //if there is (still) no selected node, then use FNextNodeToSelect to select one\r\n    if SelectedCount = 0 then\r\n      EnsureNodeSelected();\r\n  end;//if\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TBaseVirtualTree.DoCollapsing(Node: PVirtualNode): Boolean;\r\n\r\nbegin\r\n  Result := True;\r\n  if Assigned(FOnCollapsing) then\r\n    FOnCollapsing(Self, Node, Result);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.DoColumnClick(Column: TColumnIndex; Shift: TShiftState);\r\n\r\nbegin\r\n  if Assigned(FOnColumnClick) then\r\n    FOnColumnClick(Self, Column, Shift);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.DoColumnDblClick(Column: TColumnIndex; Shift: TShiftState);\r\n\r\nbegin\r\n  if Assigned(FOnColumnDblClick) then\r\n    FOnColumnDblClick(Self, Column, Shift);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.DoColumnResize(Column: TColumnIndex);\r\n\r\nvar\r\n  R: TRect;\r\n  Run: PVirtualNode;\r\n\r\nbegin\r\n  if not (csLoading in ComponentState) and HandleAllocated then\r\n  begin\r\n    // Reset all vsHeightMeasured flags if we are in multiline mode.\r\n    Run := GetFirstInitialized;\r\n    while Assigned(Run) do\r\n    begin\r\n      if vsMultiline in Run.States then\r\n        Exclude(Run.States, vsHeightMeasured);\r\n      Run := GetNextInitialized(Run);\r\n    end;\r\n\r\n    UpdateHorizontalScrollBar(True);\r\n    if Column > NoColumn then\r\n    begin\r\n      // Invalidate client area from the current column all to the right (or left in RTL mode).\r\n      R := ClientRect;\r\n      if not (toAutoSpanColumns in FOptions.FAutoOptions) then\r\n        if UseRightToLeftAlignment then\r\n          R.Right := FHeader.Columns[Column].Left + FHeader.Columns[Column].Width + ComputeRTLOffset\r\n        else\r\n          R.Left := FHeader.Columns[Column].Left;\r\n      InvalidateRect(Handle, @R, False);\r\n      FHeader.Invalidate(FHeader.Columns[Column], True);\r\n    end;\r\n    if [hsColumnWidthTracking, hsResizing] * FHeader.States = [hsColumnWidthTracking] then\r\n      UpdateWindow(Handle);\r\n\r\n    if not (tsUpdating in FStates) then\r\n      UpdateDesigner; // design time only\r\n\r\n    if Assigned(FOnColumnResize) and not (hsResizing in FHeader.States) then\r\n      FOnColumnResize(FHeader, Column);\r\n\r\n    // If the tree is currently in edit state then notify edit link.\r\n    if tsEditing in FStates then\r\n      UpdateEditBounds;\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.DoColumnVisibilityChanged(const Column: TColumnIndex; Visible: Boolean);\r\n  // Triggers the OnColumnVisibilityChanged event.\r\nbegin\r\n  if Assigned(OnColumnVisibilityChanged) then\r\n    OnColumnVisibilityChanged(Self, Column, Visible);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TBaseVirtualTree.DoCompare(Node1, Node2: PVirtualNode; Column: TColumnIndex): Integer;\r\n\r\nbegin\r\n  Result := 0;\r\n  if Assigned(FOnCompareNodes) then\r\n    FOnCompareNodes(Self, Node1, Node2, Column, Result);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TBaseVirtualTree.DoCreateDataObject: IDataObject;\r\n\r\nbegin\r\n  Result := nil;\r\n  if Assigned(FOnCreateDataObject) then\r\n    FOnCreateDataObject(Self, Result);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TBaseVirtualTree.DoCreateDragManager: IVTDragManager;\r\n\r\nbegin\r\n  Result := nil;\r\n  if Assigned(FOnCreateDragManager) then\r\n    FOnCreateDragManager(Self, Result);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TBaseVirtualTree.DoCreateEditor(Node: PVirtualNode; Column: TColumnIndex): IVTEditLink;\r\n\r\nbegin\r\n  Result := nil;\r\n  if Assigned(FOnCreateEditor) then\r\n    FOnCreateEditor(Self, Node, Column, Result);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.DoDragging(P: TPoint);\r\n\r\n// Initiates finally the drag'n drop operation and returns after DD is finished.\r\n\r\n  //--------------- local function --------------------------------------------\r\n\r\n  function GetDragOperations: Integer;\r\n\r\n  begin\r\n    if FDragOperations = [] then\r\n      Result := DROPEFFECT_COPY or DROPEFFECT_MOVE or DROPEFFECT_LINK\r\n    else\r\n    begin\r\n      Result := 0;\r\n      if doCopy in FDragOperations then\r\n        Result := Result or DROPEFFECT_COPY;\r\n      if doLink in FDragOperations then\r\n        Result := Result or DROPEFFECT_LINK;\r\n      if doMove in FDragOperations then\r\n        Result := Result or DROPEFFECT_MOVE;\r\n    end;\r\n  end;\r\n\r\n  //--------------- end local function ----------------------------------------\r\n\r\nvar\r\n  AllowedEffects: Integer;\r\n  DragObject: TDragObject;\r\n\r\n  DataObject: IDataObject;\r\n\r\nbegin\r\n  DataObject := nil;\r\n  // Dragging is dragging, nothing else.\r\n  DoCancelEdit;\r\n\r\n  if Assigned(FCurrentHotNode) then\r\n  begin\r\n    InvalidateNode(FCurrentHotNode);\r\n    FCurrentHotNode := nil;\r\n  end;\r\n  // Select the focused node if not already done.\r\n  if Assigned(FFocusedNode) and not (vsSelected in FFocusedNode.States) then\r\n  begin\r\n    InternalAddToSelection(FFocusedNode, False);\r\n    InvalidateNode(FFocusedNode);\r\n  end;\r\n\r\n  UpdateWindow(Handle);\r\n\r\n  // Keep a list of all currently selected nodes as this list might change,\r\n  // but we have probably to delete currently selected nodes.\r\n  FDragSelection := GetSortedSelection(True);\r\n  try\r\n    DoStateChange([tsOLEDragging], [tsOLEDragPending, tsClearPending]);\r\n\r\n    // An application might create a drag object like used during VCL dd. This is not required for OLE dd but\r\n    // required as parameter.\r\n    DragObject := nil;\r\n    DoStartDrag(DragObject);\r\n    DragObject.Free;\r\n\r\n    DataObject := DragManager.DataObject;\r\n    PrepareDragImage(P, DataObject);\r\n\r\n    FLastDropMode := dmOnNode;\r\n    // Don't forget to initialize the result. It might never be touched.\r\n    FLastDragEffect := DROPEFFECT_NONE;\r\n    AllowedEffects := GetDragOperations;\r\n    try\r\n      DragAndDrop(AllowedEffects, DataObject, FLastDragEffect);\r\n      DragManager.ForceDragLeave;\r\n    finally\r\n      GetCursorPos(P);\r\n      P := ScreenToClient(P);\r\n      DoEndDrag(Self, P.X, P.Y);\r\n\r\n      FDragImage.EndDrag;\r\n\r\n      // Finish the operation.\r\n      if (FLastDragEffect = DROPEFFECT_MOVE) and (toAutoDeleteMovedNodes in TreeOptions.AutoOptions) then\r\n      begin\r\n        // The operation was a move so delete the previously selected nodes.\r\n        DeleteSelectedNodes;\r\n      end;\r\n\r\n      DoStateChange([], [tsOLEDragging]);\r\n    end;\r\n  finally\r\n    FDragSelection := nil;\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.DoDragExpand;\r\n\r\nvar\r\n  SourceTree: TBaseVirtualTree;\r\n\r\nbegin\r\n  StopTimer(ExpandTimer);\r\n  if Assigned(FDropTargetNode) and (vsHasChildren in FDropTargetNode.States) and\r\n    not (vsExpanded in FDropTargetNode.States) then\r\n  begin\r\n    if Assigned(FDragManager) then\r\n      SourceTree := DragManager.DragSource\r\n    else\r\n      SourceTree := nil;\r\n\r\n    if not DragManager.DropTargetHelperSupported and Assigned(SourceTree) then\r\n      SourceTree.FDragImage.HideDragImage;\r\n    ToggleNode(FDropTargetNode);\r\n    UpdateWindow(Handle);\r\n    if not DragManager.DropTargetHelperSupported and Assigned(SourceTree) then\r\n      SourceTree.FDragImage.ShowDragImage;\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TBaseVirtualTree.DoDragOver(Source: TObject; Shift: TShiftState; State: TDragState; Pt: TPoint; Mode: TDropMode;\r\n  var Effect: Integer): Boolean;\r\n\r\nbegin\r\n  Result := False;\r\n  if Assigned(FOnDragOver) then\r\n    FOnDragOver(Self, Source, Shift, State, Pt, Mode, Effect, Result);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.DoDragDrop(Source: TObject; const DataObject: IDataObject; const Formats: TFormatArray;\r\n  Shift: TShiftState; Pt: TPoint; var Effect: Integer; Mode: TDropMode);\r\n\r\nbegin\r\n  if Assigned(FOnDragDrop) then\r\n    FOnDragDrop(Self, Source, DataObject, Formats, Shift, Pt, Effect, Mode);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.DoBeforeDrawLineImage(Node: PVirtualNode; Level: Integer; var XPos: Integer);\r\n\r\nbegin\r\n  if Assigned(FOnBeforeDrawLineImage) then\r\n    FOnBeforeDrawLineImage(Self, Node, Level, XPos);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.DoEdit;\r\n\r\nbegin\r\n  Application.CancelHint;\r\n  StopTimer(ScrollTimer);\r\n  StopTimer(EditTimer);\r\n  DoStateChange([], [tsEditPending]);\r\n  if Assigned(FFocusedNode) and not (vsDisabled in FFocusedNode.States) and\r\n    not (toReadOnly in FOptions.FMiscOptions) and (FEditLink = nil) then\r\n  begin\r\n    FEditLink := DoCreateEditor(FFocusedNode, FEditColumn);\r\n    if Assigned(FEditLink) then\r\n    begin\r\n      DoStateChange([tsEditing], [tsDrawSelecting, tsDrawSelPending, tsToggleFocusedSelection, tsOLEDragPending,\r\n        tsOLEDragging, tsClearPending, tsDrawSelPending, tsScrollPending, tsScrolling, tsMouseCheckPending]);\r\n      ScrollIntoView(FFocusedNode, toCenterScrollIntoView in FOptions.SelectionOptions,\r\n        not (toDisableAutoscrollOnEdit in FOptions.AutoOptions));\r\n      if FEditLink.PrepareEdit(Self, FFocusedNode, FEditColumn) then\r\n      begin\r\n        UpdateEditBounds;\r\n        // Node needs repaint because the selection rectangle and static text must disappear.\r\n        InvalidateNode(FFocusedNode);\r\n        if not FEditLink.BeginEdit then\r\n          DoStateChange([], [tsEditing]);\r\n      end\r\n      else\r\n        DoStateChange([], [tsEditing]);\r\n      if not (tsEditing in FStates) then\r\n        FEditLink := nil;\r\n    end;\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.DoEndDrag(Target: TObject; X, Y: Integer);\r\n\r\n// Does some housekeeping for VCL drag'n drop;\r\n\r\nbegin\r\n  inherited;\r\n\r\n  DragFinished;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TBaseVirtualTree.DoEndEdit: Boolean;\r\n\r\n// Called to finish a current edit action or stop the edit timer if an edit operation is pending.\r\n// Returns True if editing was successfully ended or the control was not in edit mode\r\n// Returns False if the control could not leave the edit mode e.g. due to an invalid value that was entered.\r\n\r\nbegin\r\n  StopTimer(EditTimer);\r\n  Result := (tsEditing in FStates) and FEditLink.EndEdit;\r\n  if Result then\r\n  begin\r\n    DoStateChange([], [tsEditing]);\r\n    FEditLink := nil;\r\n    if Assigned(FOnEdited) then\r\n      FOnEdited(Self, FFocusedNode, FEditColumn);\r\n  end;\r\n  DoStateChange([], [tsEditPending]);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.DoEndOperation(OperationKind: TVTOperationKind);\r\n\r\nbegin\r\n  if Assigned(FOnEndOperation) then\r\n    FOnEndOperation(Self, OperationKind);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.DoEnter();\r\nbegin\r\n  inherited;\r\n  EnsureNodeSelected();\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.DoExpanded(Node: PVirtualNode);\r\n\r\nbegin\r\n  if Assigned(FOnExpanded) then\r\n    FOnExpanded(Self, Node);\r\n\r\n  if Assigned(FAccessibleItem) then\r\n    NotifyWinEvent(EVENT_OBJECT_STATECHANGE, Handle, OBJID_CLIENT, CHILDID_SELF);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TBaseVirtualTree.DoExpanding(Node: PVirtualNode): Boolean;\r\n\r\nbegin\r\n  Result := True;\r\n  if Assigned(FOnExpanding) then\r\n    FOnExpanding(Self, Node, Result);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.DoFocusChange(Node: PVirtualNode; Column: TColumnIndex);\r\n\r\nbegin\r\n  if Assigned(FOnFocusChanged) then\r\n    FOnFocusChanged(Self, Node, Column);\r\n\r\n  if Assigned(FAccessibleItem) then\r\n  begin\r\n    NotifyWinEvent(EVENT_OBJECT_LOCATIONCHANGE, Handle, OBJID_CLIENT, CHILDID_SELF);\r\n    NotifyWinEvent(EVENT_OBJECT_NAMECHANGE, Handle, OBJID_CLIENT, CHILDID_SELF);\r\n    NotifyWinEvent(EVENT_OBJECT_VALUECHANGE, Handle, OBJID_CLIENT, CHILDID_SELF);\r\n    NotifyWinEvent(EVENT_OBJECT_STATECHANGE, Handle, OBJID_CLIENT, CHILDID_SELF);\r\n    NotifyWinEvent(EVENT_OBJECT_SELECTION, Handle, OBJID_CLIENT, CHILDID_SELF);\r\n    NotifyWinEvent(EVENT_OBJECT_FOCUS, Handle, OBJID_CLIENT, CHILDID_SELF);\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TBaseVirtualTree.DoFocusChanging(OldNode, NewNode: PVirtualNode; OldColumn, NewColumn: TColumnIndex): Boolean;\r\n\r\nbegin\r\n  Result := (OldColumn = NewColumn) or FHeader.AllowFocus(NewColumn);\r\n  if Assigned(FOnFocusChanging) then\r\n    FOnFocusChanging(Self, OldNode, NewNode, OldColumn, NewColumn, Result);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.DoFocusNode(Node: PVirtualNode; Ask: Boolean);\r\n\r\nbegin\r\n  if not (tsEditing in FStates) or EndEditNode then\r\n  begin\r\n    if Node = FRoot then\r\n      Node := nil;\r\n    if (FFocusedNode <> Node) and (not Ask or DoFocusChanging(FFocusedNode, Node, FFocusedColumn, FFocusedColumn)) then\r\n    begin\r\n      if Assigned(FFocusedNode) then\r\n      begin\r\n        // Do automatic collapsing of last focused node if enabled. This is however only done if\r\n        // old and new focused node have a common parent node.\r\n        if (toAutoExpand in FOptions.FAutoOptions) and Assigned(Node) and (Node.Parent = FFocusedNode.Parent) and\r\n          (vsExpanded in FFocusedNode.States) then\r\n          ToggleNode(FFocusedNode)\r\n        else\r\n          InvalidateNode(FFocusedNode);\r\n      end;\r\n      FFocusedNode := Node;\r\n    end;\r\n\r\n    // Have to scroll the node into view, even it is the same node as before.\r\n    if Assigned(FFocusedNode) then\r\n    begin\r\n      // Make sure a valid column is set if columns are used and no column has currently the focus.\r\n      if FHeader.UseColumns and (not FHeader.FColumns.IsValidColumn(FFocusedColumn)) then\r\n        FFocusedColumn := FHeader.MainColumn;\r\n      // Do automatic expansion of the newly focused node if enabled.\r\n      if (toAutoExpand in FOptions.FAutoOptions) and not (vsExpanded in FFocusedNode.States) then\r\n        ToggleNode(FFocusedNode);\r\n      InvalidateNode(FFocusedNode);\r\n      if (FUpdateCount = 0) and not (toDisableAutoscrollOnFocus in FOptions.FAutoOptions) then\r\n        ScrollIntoView(FFocusedNode, (toCenterScrollIntoView in FOptions.SelectionOptions) and\r\n          (MouseButtonDown * FStates = []), not (toFullRowSelect in FOptions.SelectionOptions) );\r\n    end;\r\n\r\n    // Reset range anchor if necessary.\r\n    if FSelectionCount = 0 then\r\n      ResetRangeAnchor;\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.DoFreeNode(Node: PVirtualNode);\r\n\r\nbegin\r\n  // Prevent invalid references\r\n  if Node = FLastChangedNode then\r\n    FLastChangedNode := nil;\r\n  if Node = FCurrentHotNode then\r\n    FCurrentHotNode := nil;\r\n  if Node = FDropTargetNode then\r\n    FDropTargetNode := nil;\r\n  if Node = FLastStructureChangeNode then\r\n    FLastStructureChangeNode := nil;\r\n\r\n  if Node = FNextNodeToSelect then\r\n    FNextNodeToSelect := Node.Parent;\r\n\r\n  // fire event\r\n  if Assigned(FOnFreeNode) and ([vsInitialized, vsOnFreeNodeCallRequired] * Node.States <> []) then\r\n    FOnFreeNode(Self, Node);\r\n\r\n  if vsReleaseCallOnUserDataRequired in Node.States then\r\n    GetInterfaceFromNodeData(Node)._Release();\r\n\r\n  FreeMem(Node);\r\n  if Self.UpdateCount = 0 then\r\n    EnsureNodeSelected();\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\n// These constants are defined in the platform SDK for W2K/XP, but not yet in Delphi.\r\nconst\r\n  SPI_GETTOOLTIPANIMATION = $1016;\r\n  SPI_GETTOOLTIPFADE = $1018;\r\n\r\nfunction TBaseVirtualTree.DoGetAnimationType: THintAnimationType;\r\n\r\n// Determines (depending on the properties settings and the system) which hint\r\n// animation type is to be used.\r\n\r\nvar\r\n  Animation: BOOL;\r\n\r\nbegin\r\n  Result := FAnimationType;\r\n  if Result = hatSystemDefault then\r\n  begin\r\n    SystemParametersInfo(SPI_GETTOOLTIPANIMATION, 0, @Animation, 0);\r\n    if not Animation then\r\n      Result := hatNone\r\n    else\r\n    begin\r\n      SystemParametersInfo(SPI_GETTOOLTIPFADE, 0, @Animation, 0);\r\n      if Animation then\r\n        Result := hatFade\r\n      else\r\n        Result := hatSlide;\r\n    end;\r\n  end;\r\n\r\n  // Check availability of MMX if fading is requested.\r\n  if not MMXAvailable and (Result = hatFade) then\r\n    Result := hatSlide;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TBaseVirtualTree.DoGetCellContentMargin(Node: PVirtualNode; Column: TColumnIndex;\r\n  CellContentMarginType: TVTCellContentMarginType = ccmtAllSides; Canvas: TCanvas = nil): TPoint;\r\n\r\n// Determines the margins of the content rectangle caused by DoBeforeCellPaint.\r\n// Note that shrinking the content rectangle results in positive margins whereas enlarging the content rectangle results\r\n// in negative margins.\r\n\r\nvar\r\n  CellRect,\r\n  ContentRect: TRect;\r\n\r\nbegin\r\n  Result := Point(0, 0);\r\n\r\n  if Assigned(FOnBeforeCellPaint) then // Otherwise DoBeforeCellPaint has no effect.\r\n  begin\r\n    if Canvas = nil then\r\n      Canvas := Self.Canvas;\r\n\r\n    // Determine then node's cell rectangle and content rectangle before calling DoBeforeCellPaint.\r\n    CellRect := GetDisplayRect(Node, Column, True);\r\n    ContentRect := CellRect;\r\n    DoBeforeCellPaint(Canvas, Node, Column, cpmGetContentMargin, CellRect, ContentRect);\r\n\r\n    // Calculate the changes caused by DoBeforeCellPaint.\r\n    case CellContentMarginType of\r\n      ccmtAllSides:\r\n        // Calculate the width difference and high difference.\r\n        Result := Point((CellRect.Right - CellRect.Left) - (ContentRect.Right - ContentRect.Left),\r\n                        (CellRect.Bottom - CellRect.Top) - (ContentRect.Bottom - ContentRect.Top));\r\n      ccmtTopLeftOnly:\r\n        // Calculate the left margin and top margin only.\r\n        Result := Point(ContentRect.Left - CellRect.Left, ContentRect.Top - CellRect.Top);\r\n      ccmtBottomRightOnly:\r\n        // Calculate the right margin and bottom margin only.\r\n        Result := Point(CellRect.Right - ContentRect.Right, CellRect.Bottom - ContentRect.Bottom);\r\n    end;\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.DoGetCursor(var Cursor: TCursor);\r\n\r\nbegin\r\n  if Assigned(FOnGetCursor) then\r\n    FOnGetCursor(Self, Cursor);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.DoGetHeaderCursor(var Cursor: HCURSOR);\r\n\r\nbegin\r\n  if Assigned(FOnGetHeaderCursor) then\r\n    FOnGetHeaderCursor(FHeader, Cursor);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TBaseVirtualTree.DoGetImageIndex(Node: PVirtualNode; Kind: TVTImageKind; Column: TColumnIndex;\r\n  var Ghosted: Boolean; var Index: TImageIndex): TCustomImageList;\r\n\r\n// Queries the application/descendant about certain image properties for a node.\r\n// Returns a custom image list if given by the callee, otherwise nil.\r\n\r\nbegin\r\n  // First try the enhanced event to allow for custom image lists.\r\n  if Assigned(FOnGetImageEx) then begin\r\n    if Kind = ikState then //TODO -oMarder: Remove paramter DefaultImages() from GetImageIndex() and do this stuff only here. That way consumers of the OnGetImageEx can check the fefault imagelist.\r\n      Result := Self.StateImages\r\n    else\r\n      Result := Self.Images;\r\n    FOnGetImageEx(Self, Node, Kind, Column, Ghosted, Index, Result);\r\n  end\r\n  else begin\r\n    Result := nil;\r\n    if Assigned(FOnGetImage) then\r\n      FOnGetImage(Self, Node, Kind, Column, Ghosted, Index);\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.DoGetImageText(Node: PVirtualNode; Kind: TVTImageKind;\r\n  Column: TColumnIndex; var ImageText: string);\r\n\r\n// Queries the application/descendant about alternative image text for a node.\r\n\r\nbegin\r\n  if Assigned(FOnGetImageText) then\r\n     FOnGetImageText(Self, Node, Kind, Column, ImageText);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.DoGetLineStyle(var Bits: Pointer);\r\n\r\nbegin\r\n  if Assigned(FOnGetLineStyle) then\r\n    FOnGetLineStyle(Self, Bits);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TBaseVirtualTree.DoGetNodeHint(Node: PVirtualNode; Column: TColumnIndex;\r\n  var LineBreakStyle: TVTTooltipLineBreakStyle): string;\r\n\r\nbegin\r\n  Result := Hint;\r\n  LineBreakStyle := hlbDefault;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TBaseVirtualTree.DoGetNodeTooltip(Node: PVirtualNode; Column: TColumnIndex;\r\n  var LineBreakStyle: TVTTooltipLineBreakStyle): string;\r\n\r\nbegin\r\n  Result := Hint;\r\n  LineBreakStyle := hlbDefault;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TBaseVirtualTree.DoGetNodeExtraWidth(Node: PVirtualNode; Column: TColumnIndex; Canvas: TCanvas = nil): Integer;\r\n\r\n// Returns the pixel width of extra space occupied by node contents (for example, static text).\r\n\r\nbegin\r\n  Result := 0;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TBaseVirtualTree.DoGetNodeWidth(Node: PVirtualNode; Column: TColumnIndex; Canvas: TCanvas = nil): Integer;\r\n\r\n// Returns the pixel width of a node.\r\n\r\nbegin\r\n  Result := 0;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TBaseVirtualTree.DoGetPopupMenu(Node: PVirtualNode; Column: TColumnIndex; Position: TPoint): TPopupMenu;\r\n\r\n// Queries the application whether there is a node specific popup menu.\r\n\r\nvar\r\n  Run: PVirtualNode;\r\n  AskParent: Boolean;\r\n\r\nbegin\r\n  Result := nil;\r\n  if Assigned(FOnGetPopupMenu) then\r\n  begin\r\n    Run := Node;\r\n\r\n    if Assigned(Run) then\r\n    begin\r\n      AskParent := True;\r\n      repeat\r\n        FOnGetPopupMenu(Self, Run, Column, Position, AskParent, Result);\r\n        Run := Run.Parent;\r\n      until (Run = FRoot) or Assigned(Result) or not AskParent;\r\n    end\r\n    else\r\n      FOnGetPopupMenu(Self, nil, -1, Position, AskParent, Result);\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.DoGetUserClipboardFormats(var Formats: TFormatEtcArray);\r\n\r\nbegin\r\n  if Assigned(FOnGetUserClipboardFormats) then\r\n    FOnGetUserClipboardFormats(Self, Formats);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.DoHeaderClick(const HitInfo: TVTHeaderHitInfo);\r\n\r\nbegin\r\n  if Assigned(FOnHeaderClick) then\r\n    FOnHeaderClick(FHeader, HitInfo);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.DoHeaderDblClick(const HitInfo: TVTHeaderHitInfo);\r\n\r\nbegin\r\n  if Assigned(FOnHeaderDblClick) then\r\n    FOnHeaderDblClick(FHeader, HitInfo);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.DoHeaderDragged(Column: TColumnIndex; OldPosition: TColumnPosition);\r\n\r\nbegin\r\n  if Assigned(FOnHeaderDragged) then\r\n    FOnHeaderDragged(FHeader, Column, OldPosition);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.DoHeaderDraggedOut(Column: TColumnIndex; DropPosition: TPoint);\r\n\r\nbegin\r\n  if Assigned(FOnHeaderDraggedOut) then\r\n    FOnHeaderDraggedOut(FHeader, Column, DropPosition);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TBaseVirtualTree.DoHeaderDragging(Column: TColumnIndex): Boolean;\r\n\r\nbegin\r\n  Result := True;\r\n  if Assigned(FOnHeaderDragging) then\r\n    FOnHeaderDragging(FHeader, Column, Result);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.DoHeaderDraw(Canvas: TCanvas; Column: TVirtualTreeColumn; R: TRect; Hover, Pressed: Boolean;\r\n  DropMark: TVTDropMarkMode);\r\n\r\nbegin\r\n  if Assigned(FOnHeaderDraw) then\r\n    FOnHeaderDraw(FHeader, Canvas, Column, R, Hover, Pressed, DropMark);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.DoHeaderDrawQueryElements(var PaintInfo: THeaderPaintInfo; var Elements: THeaderPaintElements);\r\n\r\nbegin\r\n  if Assigned(FOnHeaderDrawQueryElements) then\r\n    FOnHeaderDrawQueryElements(FHeader, PaintInfo, Elements);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.DoHeaderMouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);\r\n\r\nbegin\r\n  if Assigned(FOnHeaderMouseDown) then\r\n    FOnHeaderMouseDown(FHeader, Button, Shift, X, Y);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.DoHeaderMouseMove(Shift: TShiftState; X, Y: Integer);\r\n\r\nbegin\r\n  if Assigned(FOnHeaderMouseMove) then\r\n    FOnHeaderMouseMove(FHeader, Shift, X, Y);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.DoHeaderMouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);\r\n\r\nbegin\r\n  if Assigned(FOnHeaderMouseUp) then\r\n    FOnHeaderMouseUp(FHeader, Button, Shift, X, Y);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.DoHotChange(Old, New: PVirtualNode);\r\n\r\nbegin\r\n  if Assigned(FOnHotChange) then\r\n    FOnHotChange(Self, Old, New);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TBaseVirtualTree.DoIncrementalSearch(Node: PVirtualNode; const Text: string): Integer;\r\n\r\nbegin\r\n  Result := 0;\r\n  if Assigned(FOnIncrementalSearch) then\r\n    FOnIncrementalSearch(Self, Node, Text, Result);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TBaseVirtualTree.DoInitChildren(Node: PVirtualNode; var ChildCount: Cardinal): Boolean;\r\n/// The function calls the OnInitChildren and returns True if the event was called; it returns False if the caller can expect that no changes have been made to ChildCount\r\nbegin\r\n  if Assigned(FOnInitChildren) then\r\n  begin\r\n    FOnInitChildren(Self, Node, ChildCount);\r\n    Result := True;\r\n  end\r\n  else\r\n    Result := False;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.DoInitNode(Parent, Node: PVirtualNode; var InitStates: TVirtualNodeInitStates);\r\n\r\nbegin\r\n  if Assigned(FOnInitNode) then\r\n    FOnInitNode(Self, Parent, Node, InitStates);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TBaseVirtualTree.DoKeyAction(var CharCode: Word; var Shift: TShiftState): Boolean;\r\n\r\nbegin\r\n  Result := True;\r\n  if Assigned(FOnKeyAction) then\r\n    FOnKeyAction(Self, CharCode, Shift, Result);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.DoLoadUserData(Node: PVirtualNode; Stream: TStream);\r\n\r\nbegin\r\n  if Assigned(FOnLoadNode) then\r\n    if Node = FRoot then\r\n      FOnLoadNode(Self, nil, Stream)\r\n    else\r\n      FOnLoadNode(Self, Node, Stream);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.DoMeasureItem(TargetCanvas: TCanvas; Node: PVirtualNode; var NodeHeight: Integer);\r\n\r\nbegin\r\n  if not (vsInitialized in Node.States) then\r\n    InitNode(Node);\r\n  if Assigned(FOnMeasureItem) then\r\n    FOnMeasureItem(Self, TargetCanvas, Node, NodeHeight);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.DoMouseEnter();\r\n\r\nbegin\r\n  if Assigned(FOnMouseEnter) then\r\n    FOnMouseEnter(Self);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.DoMouseLeave;\r\n\r\nbegin\r\n  if Assigned(FOnMouseLeave) then\r\n    FOnMouseLeave(Self);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.DoNodeCopied(Node: PVirtualNode);\r\n\r\nbegin\r\n  if Assigned(FOnNodeCopied) then\r\n    FOnNodeCopied(Self, Node);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TBaseVirtualTree.DoNodeCopying(Node, NewParent: PVirtualNode): Boolean;\r\n\r\nbegin\r\n  Result := True;\r\n  if Assigned(FOnNodeCopying) then\r\n    FOnNodeCopying(Self, Node, NewParent, Result);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.DoNodeClick(const HitInfo: THitInfo);\r\n\r\nbegin\r\n  if Assigned(FOnNodeClick) then\r\n    FOnNodeClick(Self, HitInfo);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.DoNodeDblClick(const HitInfo: THitInfo);\r\n\r\nbegin\r\n  if Assigned(FOnNodeDblClick) then\r\n    FOnNodeDblClick(Self, HitInfo);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TBaseVirtualTree.DoNodeHeightDblClickResize(Node: PVirtualNode; Column: TColumnIndex; Shift: TShiftState;\r\n  P: TPoint): Boolean;\r\n\r\nbegin\r\n  Result := True;\r\n  if Assigned(FOnNodeHeightDblClickResize) then\r\n    FOnNodeHeightDblClickResize(Self, Node, Column, Shift, P, Result);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TBaseVirtualTree.DoNodeHeightTracking(Node: PVirtualNode; Column: TColumnIndex; Shift: TShiftState;\r\n  var TrackPoint: TPoint; P: TPoint): Boolean;\r\n\r\nbegin\r\n  Result := True;\r\n  if Assigned(FOnNodeHeightTracking) then\r\n    FOnNodeHeightTracking(Self, Node, Column, Shift, TrackPoint, P, Result);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.DoNodeMoved(Node: PVirtualNode);\r\n\r\nbegin\r\n  if Assigned(FOnNodeMoved) then\r\n    FOnNodeMoved(Self, Node);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TBaseVirtualTree.DoNodeMoving(Node, NewParent: PVirtualNode): Boolean;\r\n\r\nbegin\r\n  Result := True;\r\n  if Assigned(FOnNodeMoving) then\r\n    FOnNodeMoving(Self, Node, NewParent, Result);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TBaseVirtualTree.DoPaintBackground(Canvas: TCanvas; R: TRect): Boolean;\r\n\r\nbegin\r\n  Result := False;\r\n  if Assigned(FOnPaintBackground) then\r\n    FOnPaintBackground(Self, Canvas, R, Result);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.DoPaintDropMark(Canvas: TCanvas; Node: PVirtualNode; R: TRect);\r\n\r\n// draws the drop mark into the given rectangle\r\n// Note: Changed properties of the given canvas should be reset to their previous values.\r\n\r\nvar\r\n  SaveBrushColor: TColor;\r\n  SavePenStyle: TPenStyle;\r\n\r\nbegin\r\n  if FLastDropMode in [dmAbove, dmBelow] then\r\n    with Canvas do\r\n    begin\r\n      SavePenStyle := Pen.Style;\r\n      Pen.Style := psClear;\r\n      SaveBrushColor := Brush.Color;\r\n      Brush.Color := FColors.DropMarkColor;\r\n\r\n      if FLastDropMode = dmAbove then\r\n      begin\r\n        Polygon([Point(R.Left + 2, R.Top),\r\n                 Point(R.Right - 2, R.Top),\r\n                 Point(R.Right - 2, R.Top + 6),\r\n                 Point(R.Right - 6, R.Top + 2),\r\n                 Point(R.Left + 6 , R.Top + 2),\r\n                 Point(R.Left + 2, R.Top + 6)\r\n        ]);\r\n      end\r\n      else\r\n        Polygon([Point(R.Left + 2, R.Bottom - 1),\r\n                 Point(R.Right - 2, R.Bottom - 1),\r\n                 Point(R.Right - 2, R.Bottom - 8),\r\n                 Point(R.Right - 7, R.Bottom - 3),\r\n                 Point(R.Left + 7 , R.Bottom - 3),\r\n                 Point(R.Left + 2, R.Bottom - 8)\r\n        ]);\r\n      Brush.Color := SaveBrushColor;\r\n      Pen.Style := SavePenStyle;\r\n    end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.DoPaintNode(var PaintInfo: TVTPaintInfo);\r\n\r\nbegin\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.DoPopupMenu(Node: PVirtualNode; Column: TColumnIndex; Position: TPoint);\r\n\r\n// Support for node dependent popup menus.\r\n\r\nvar\r\n  Menu: TPopupMenu;\r\n\r\nbegin\r\n  Menu := DoGetPopupMenu(Node, Column, Position);\r\n\r\n  if Assigned(Menu) then\r\n  begin\r\n    DoStateChange([tsPopupMenuShown]);\r\n    StopTimer(EditTimer);\r\n    Menu.PopupComponent := Self;\r\n    with ClientToScreen(Position) do\r\n      Menu.Popup(X, Y);\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.DoRemoveFromSelection(Node: PVirtualNode);\r\n\r\nbegin\r\n  if Assigned(FOnRemoveFromSelection) then\r\n    FOnRemoveFromSelection(Self, Node);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TBaseVirtualTree.DoRenderOLEData(const FormatEtcIn: TFormatEtc; out Medium: TStgMedium;\r\n  ForClipboard: Boolean): HRESULT;\r\n\r\nbegin\r\n  Result := E_FAIL;\r\n  if Assigned(FOnRenderOLEData) then\r\n    FOnRenderOLEData(Self, FormatEtcIn, Medium, ForClipboard, Result);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.DoReset(Node: PVirtualNode);\r\n\r\nbegin\r\n  if Assigned(FOnResetNode) then\r\n    FOnResetNode(Self, Node);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.DoSaveUserData(Node: PVirtualNode; Stream: TStream);\r\n\r\nbegin\r\n  if Assigned(FOnSaveNode) then\r\n    if Node = FRoot then\r\n      FOnSaveNode(Self, nil, Stream)\r\n    else\r\n      FOnSaveNode(Self, Node, Stream);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.DoScroll(DeltaX, DeltaY: Integer);\r\n\r\nbegin\r\n  if Assigned(FOnScroll) then\r\n    FOnScroll(Self, DeltaX, DeltaY);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TBaseVirtualTree.DoSetOffsetXY(Value: TPoint; Options: TScrollUpdateOptions; ClipRect: PRect = nil): Boolean;\r\n\r\n// Actual offset setter used to scroll the client area, update scroll bars and invalidating the header (all optional).\r\n// Returns True if the offset really changed otherwise False is returned.\r\n\r\nvar\r\n  DeltaX: Integer;\r\n  DeltaY: Integer;\r\n  DWPStructure: HDWP;\r\n  I: Integer;\r\n  P: TPoint;\r\n  R: TRect;\r\n\r\nbegin\r\n  // Range check, order is important here.\r\n  if Value.X < (ClientWidth - Integer(FRangeX)) then\r\n    Value.X := ClientWidth - Integer(FRangeX);\r\n  if Value.X > 0 then\r\n    Value.X := 0;\r\n  DeltaX := Value.X - FOffsetX;\r\n  if UseRightToLeftAlignment then\r\n    DeltaX := -DeltaX;\r\n  if Value.Y < (ClientHeight - Integer(FRangeY)) then\r\n    Value.Y := ClientHeight - Integer(FRangeY);\r\n  if Value.Y > 0 then\r\n    Value.Y := 0;\r\n  DeltaY := Value.Y - FOffsetY;\r\n\r\n  Result := (DeltaX <> 0) or (DeltaY <> 0);\r\n  if Result then\r\n  begin\r\n    FOffsetX := Value.X;\r\n    FOffsetY := Value.Y;\r\n    Result := True;\r\n\r\n    if tsHint in Self.FStates then\r\n      Application.CancelHint;\r\n    if FUpdateCount = 0 then\r\n    begin\r\n      // The drag image from VCL controls need special consideration.\r\n      if tsVCLDragging in FStates then\r\n        ImageList_DragShowNolock(False);\r\n\r\n      if (suoScrollClientArea in Options) and not (tsToggling in FStates) then\r\n      begin\r\n        // Have to invalidate the entire window if there's a background.\r\n        if (toShowBackground in FOptions.FPaintOptions) and (FBackground.Graphic is TBitmap) then\r\n        begin\r\n          // Since we don't use ScrollWindow here we have to move all client windows ourselves.\r\n          DWPStructure := BeginDeferWindowPos(ControlCount);\r\n          for I := 0 to ControlCount - 1 do\r\n            if Controls[I] is TWinControl then\r\n            begin\r\n              with Controls[I] as TWinControl do\r\n                DWPStructure := DeferWindowPos(DWPStructure, Handle, 0, Left + DeltaX, Top + DeltaY, 0, 0,\r\n                  SWP_NOZORDER or SWP_NOACTIVATE or SWP_NOSIZE);\r\n              if DWPStructure = 0 then\r\n                Break;\r\n            end;\r\n          if DWPStructure <> 0 then\r\n            EndDeferWindowPos(DWPStructure);\r\n          InvalidateRect(Handle, nil, False);\r\n        end\r\n        else\r\n        begin\r\n          if (DeltaX <> 0) and (Header.Columns.GetVisibleFixedWidth > 0) then\r\n          begin\r\n            // When fixed columns exists we have to scroll separately horizontally and vertically.\r\n            // Horizontally is scroll only the client area not occupied by fixed columns and\r\n            // vertically entire client area (or clipping area if one exists).\r\n            R := ClientRect;\r\n            R.Left := Header.Columns.GetVisibleFixedWidth;\r\n\r\n            ScrollWindow(Handle, DeltaX, 0, @R, @R);\r\n            if DeltaY <> 0 then\r\n              ScrollWindow(Handle, 0, DeltaY, ClipRect, ClipRect);\r\n          end\r\n          else\r\n            ScrollWindow(Handle, DeltaX, DeltaY, ClipRect, ClipRect);\r\n        end;\r\n      end;\r\n\r\n      if suoUpdateNCArea in Options then\r\n      begin\r\n        if DeltaX <> 0 then\r\n        begin\r\n          if (suoRepaintHeader in Options) and (hoVisible in FHeader.FOptions) then\r\n            FHeader.Invalidate(nil);\r\n          if not (tsSizing in FStates) and (FScrollBarOptions.ScrollBars in [System.UITypes.TScrollStyle.ssHorizontal, System.UITypes.TScrollStyle.ssBoth]) then\r\n            UpdateHorizontalScrollBar(suoRepaintScrollBars in Options);\r\n        end;\r\n\r\n        if (DeltaY <> 0) and ([tsThumbTracking, tsSizing] * FStates = []) then\r\n        begin\r\n          UpdateVerticalScrollBar(suoRepaintScrollBars in Options);\r\n          if not (FHeader.UseColumns or IsMouseSelecting) and\r\n            (FScrollBarOptions.ScrollBars in [System.UITypes.TScrollStyle.ssHorizontal, System.UITypes.TScrollStyle.ssBoth]) then\r\n            UpdateHorizontalScrollBar(suoRepaintScrollBars in Options);\r\n        end;\r\n      end;\r\n\r\n      if tsVCLDragging in FStates then\r\n        ImageList_DragShowNolock(True);\r\n    end;\r\n\r\n    // Finally update \"hot\" node if hot tracking is activated\r\n    GetCursorPos(P);\r\n    P := ScreenToClient(P);\r\n    if PtInRect(ClientRect, P) then\r\n      HandleHotTrack(P.X, P.Y);\r\n\r\n    DoScroll(DeltaX, DeltaY);\r\n    Perform(CM_UPDATE_VCLSTYLE_SCROLLBARS,0,0);\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.DoShowScrollBar(Bar: Integer; Show: Boolean);\r\n\r\nbegin\r\n  ShowScrollBar(Handle, Bar, Show);\r\n  if Assigned(FOnShowScrollBar) then\r\n    FOnShowScrollBar(Self, Bar, Show);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.DoStartDrag(var DragObject: TDragObject);\r\n\r\nbegin\r\n  inherited;\r\n\r\n  // Check if the application created an own drag object. This is needed to pass the correct source in\r\n  // OnDragOver and OnDragDrop.\r\n  if Assigned(DragObject) then\r\n    DoStateChange([tsUserDragObject]);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.DoStartOperation(OperationKind: TVTOperationKind);\r\n\r\nbegin\r\n  if Assigned(FOnStartOperation) then\r\n    FOnStartOperation(Self, OperationKind);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.DoStateChange(Enter: TVirtualTreeStates; Leave: TVirtualTreeStates = []);\r\n\r\nvar\r\n  ActualEnter,\r\n  ActualLeave: TVirtualTreeStates;\r\n\r\nbegin\r\n  if Assigned(FOnStateChange) then\r\n  begin\r\n    ActualEnter := Enter - FStates;\r\n    ActualLeave := FStates * Leave;\r\n    if (ActualEnter + ActualLeave) <> [] then\r\n      FOnStateChange(Self, Enter, Leave);\r\n  end;\r\n  FStates := FStates + Enter - Leave;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.DoStructureChange(Node: PVirtualNode; Reason: TChangeReason);\r\n\r\nbegin\r\n  StopTimer(StructureChangeTimer);\r\n  if Assigned(FOnStructureChange) then\r\n    FOnStructureChange(Self, Node, Reason);\r\n\r\n  // This is a good place to reset the cached node and reason. These are the same as the values passed in here.\r\n  // This is necessary to allow descendants to override this method and get them.\r\n  DoStateChange([], [tsStructureChangePending]);\r\n  FLastStructureChangeNode := nil;\r\n  FLastStructureChangeReason := crIgnore;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.DoTimerScroll;\r\n\r\nvar\r\n  P,\r\n  ClientP: TPoint;\r\n  InRect,\r\n  Panning: Boolean;\r\n  R,\r\n  ClipRect: TRect;\r\n  DeltaX,\r\n  DeltaY: Integer;\r\n\r\nbegin\r\n  GetCursorPos(P);\r\n  R := ClientRect;\r\n  ClipRect := R;\r\n  MapWindowPoints(Handle, 0, R, 2);\r\n  InRect := PtInRect(R, P);\r\n  ClientP := ScreenToClient(P);\r\n  Panning := [tsWheelPanning, tsWheelScrolling] * FStates <> [];\r\n\r\n  if IsMouseSelecting or InRect or Panning then\r\n  begin\r\n    DeltaX := 0;\r\n    DeltaY := 0;\r\n    if sdUp in FScrollDirections then\r\n    begin\r\n      if Panning then\r\n        DeltaY := FLastClickPos.Y - ClientP.Y - 8\r\n      else\r\n        if InRect then\r\n          DeltaY := Min(FScrollBarOptions.FIncrementY, ClientHeight)\r\n        else\r\n          DeltaY := Min(FScrollBarOptions.FIncrementY, ClientHeight) * Abs(R.Top - P.Y);\r\n      if FOffsetY = 0 then\r\n        Exclude(FScrollDirections, sdUp);\r\n    end;\r\n\r\n    if sdDown in FScrollDirections then\r\n    begin\r\n      if Panning then\r\n        DeltaY := FLastClickPos.Y - ClientP.Y + 8\r\n      else\r\n        if InRect then\r\n          DeltaY := -Min(FScrollBarOptions.FIncrementY, ClientHeight)\r\n        else\r\n          DeltaY := -Min(FScrollBarOptions.FIncrementY, ClientHeight) * Abs(P.Y - R.Bottom);\r\n      if (ClientHeight - FOffsetY) = Integer(FRangeY) then\r\n        Exclude(FScrollDirections, sdDown);\r\n    end;\r\n\r\n    if sdLeft in FScrollDirections then\r\n    begin\r\n      if Panning then\r\n        DeltaX := FLastClickPos.X - ClientP.X - 8\r\n      else\r\n        if InRect then\r\n          DeltaX := FScrollBarOptions.FIncrementX\r\n        else\r\n          DeltaX := FScrollBarOptions.FIncrementX * Abs(R.Left - P.X);\r\n      if FEffectiveOffsetX = 0 then\r\n        Exclude(FScrollDirections, sdleft);\r\n    end;\r\n\r\n    if sdRight in FScrollDirections then\r\n    begin\r\n      if Panning then\r\n        DeltaX := FLastClickPos.X - ClientP.X + 8\r\n      else\r\n        if InRect then\r\n          DeltaX := -FScrollBarOptions.FIncrementX\r\n        else\r\n          DeltaX := -FScrollBarOptions.FIncrementX * Abs(P.X - R.Right);\r\n\r\n      if (ClientWidth + FEffectiveOffsetX) = Integer(FRangeX) then\r\n        Exclude(FScrollDirections, sdRight);\r\n    end;\r\n\r\n    if UseRightToLeftAlignment then\r\n      DeltaX := - DeltaX;\r\n\r\n    if IsMouseSelecting then\r\n    begin\r\n      // In order to avoid scrolling the area which needs a repaint due to the changed selection rectangle\r\n      // we limit the scroll area explicitely.\r\n      OffsetRect(ClipRect, DeltaX, DeltaY);\r\n      DoSetOffsetXY(Point(FOffsetX + DeltaX, FOffsetY + DeltaY), DefaultScrollUpdateFlags, @ClipRect);\r\n      // When selecting with the mouse then either update only the parts of the window which have been uncovered\r\n      // by the scroll operation if no change in the selection happend or invalidate and redraw the entire\r\n      // client area otherwise (to avoid the time consuming task of determining the display rectangles of every\r\n      // changed node).\r\n      if CalculateSelectionRect(ClientP.X, ClientP.Y) and HandleDrawSelection(ClientP.X, ClientP.Y) then\r\n        InvalidateRect(Handle, nil, False)\r\n      else\r\n      begin\r\n        // The selection did not change so invalidate only the part of the window which really needs an update.\r\n        // 1) Invalidate the parts uncovered by the scroll operation. Add another offset range, we have to\r\n        //    scroll only one stripe but have to update two.\r\n        OffsetRect(ClipRect, DeltaX, DeltaY);\r\n        SubtractRect(ClipRect, ClientRect, ClipRect);\r\n        InvalidateRect(Handle, @ClipRect, False);\r\n\r\n        // 2) Invalidate the selection rectangles.\r\n        UnionRect(ClipRect, OrderRect(FNewSelRect), OrderRect(FLastSelRect));\r\n        OffsetRect(ClipRect, FOffsetX, FOffsetY);\r\n        InvalidateRect(Handle, @ClipRect, False);\r\n      end;\r\n    end\r\n    else\r\n    begin\r\n      // Scroll only if there is no drag'n drop in progress. Drag'n drop scrolling is handled in DragOver.\r\n      if ((FDragManager = nil) or not DragManager.IsDropTarget) and ((DeltaX <> 0) or (DeltaY <> 0)) then\r\n        DoSetOffsetXY(Point(FOffsetX + DeltaX, FOffsetY + DeltaY), DefaultScrollUpdateFlags, nil);\r\n    end;\r\n    UpdateWindow(Handle);\r\n\r\n    if (FScrollDirections = []) and ([tsWheelPanning, tsWheelScrolling] * FStates = []) then\r\n    begin\r\n      StopTimer(ScrollTimer);\r\n      DoStateChange([], [tsScrollPending, tsScrolling]);\r\n    end;\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.DoUpdating(State: TVTUpdateState);\r\n\r\nbegin\r\n  if Assigned(FOnUpdating) then\r\n    FOnUpdating(Self, State);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TBaseVirtualTree.DoValidateCache: Boolean;\r\n\r\n// This method fills the cache, which is used to speed up searching for nodes.\r\n// The strategy is simple: Take the current number of visible nodes and distribute evenly a number of marks\r\n// (which are stored in FPositionCache) so that iterating through the tree doesn't cost too much time.\r\n// If there are less than 'CacheThreshold' nodes in the tree then the cache remains empty.\r\n// Result is True if the cache was filled without interruption, otherwise False.\r\n// Note: You can adjust the maximum number of nodes between two cache entries by changing CacheThreshold.\r\n\r\nvar\r\n  EntryCount,\r\n  CurrentTop,\r\n  Index: Cardinal;\r\n  CurrentNode,\r\n  Temp: PVirtualNode;\r\n\r\nbegin\r\n  EntryCount := 0;\r\n  if not (tsStopValidation in FStates) then\r\n  begin\r\n    if FStartIndex = 0 then\r\n      FPositionCache := nil;\r\n\r\n    EntryCount := CalculateCacheEntryCount;\r\n    SetLength(FPositionCache, EntryCount);\r\n    if FStartIndex > EntryCount then\r\n      FStartIndex := EntryCount;\r\n\r\n    // Optimize validation by starting with FStartIndex if set.\r\n    if (FStartIndex > 0) and Assigned(FPositionCache[FStartIndex - 1].Node) then\r\n    begin\r\n      // Index is the current entry in FPositionCache.\r\n      Index := FStartIndex - 1;\r\n      // Running term for absolute top value.\r\n      CurrentTop := FPositionCache[Index].AbsoluteTop;\r\n      // Running node pointer.\r\n      CurrentNode := FPositionCache[Index].Node;\r\n    end\r\n    else\r\n    begin\r\n      // Index is the current entry in FPositionCache.\r\n      Index := 0;\r\n      // Running term for absolute top value.\r\n      CurrentTop := 0;\r\n      // Running node pointer.\r\n      CurrentNode := GetFirstVisibleNoInit(nil, True);\r\n    end;\r\n\r\n    // EntryCount serves as counter for processed nodes here. This value can always start at 0 as\r\n    // the validation either starts also at index 0 or an index which is always a multiple of CacheThreshold\r\n    // and EntryCount is only used with modulo CacheThreshold.\r\n    EntryCount := 0;\r\n    if Assigned(CurrentNode) then\r\n    begin\r\n      while not (tsStopValidation in FStates) do\r\n      begin\r\n        // If the cache is full then stop the loop.\r\n        if (Integer(Index) > Length(FPositionCache)) then    // ADDED: 17.09.2013 - Veit Zimmermann\r\n          Break;                                             // ADDED: 17.09.2013 - Veit Zimmermann\r\n        if (EntryCount mod CacheThreshold) = 0 then\r\n        begin\r\n          // New cache entry to set up.\r\n          with FPositionCache[Index] do\r\n          begin\r\n            Node := CurrentNode;\r\n            AbsoluteTop := CurrentTop;\r\n          end;\r\n          Inc(Index);\r\n        end;\r\n\r\n        Inc(CurrentTop, NodeHeight[CurrentNode]);\r\n        // Advance to next visible node.\r\n        Temp := GetNextVisibleNoInit(CurrentNode, True);\r\n        // If there is no further node then stop the loop.\r\n        if (Temp = nil) then       // CHANGED: 17.09.2013 - Veit Zimmermann\r\n          Break;                   // CHANGED: 17.09.2013 - Veit Zimmermann\r\n\r\n        CurrentNode := Temp;\r\n        Inc(EntryCount);\r\n      end;\r\n    end;\r\n    // Finalize the position cache so no nil entry remains there.\r\n    if not (tsStopValidation in FStates) and (Integer(Index) <= High(FPositionCache)) then\r\n    begin\r\n      SetLength(FPositionCache, Index + 1);\r\n      with FPositionCache[Index] do\r\n      begin\r\n        Node := CurrentNode;\r\n        AbsoluteTop := CurrentTop;\r\n      end;\r\n    end;\r\n  end;\r\n\r\n  Result := (EntryCount > 0) and not (tsStopValidation in FStates);\r\n\r\n  // In variable node height mode it might have happend that some or all of the nodes have been adjusted in their\r\n  // height. During validation updates of the scrollbars is disabled so let's do this here.\r\n  if Result and (toVariableNodeHeight in FOptions.FMiscOptions) then\r\n  begin\r\n    UpdateScrollBars(True);\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.DragAndDrop(AllowedEffects: Dword; const DataObject: IDataObject; var DragEffect: Integer);\r\nvar\r\n  lDragEffect: DWord; // required for type compatibility with SHDoDragDrop\r\nbegin\r\n  if IsWinVistaOrAbove then\r\n  begin\r\n    lDragEffect := DWord(DragEffect);\r\n    SHDoDragDrop(Self.Handle, DataObject, nil, AllowedEffects, lDragEffect); // supports drag hints on Windows Vista and later\r\n    DragEffect := lDragEffect;\r\n  end\r\n  else\r\n  Winapi.ActiveX.DoDragDrop(DataObject, DragManager as IDropSource, AllowedEffects, DragEffect);\r\n end;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.DragCanceled;\r\n\r\n// Does some housekeeping for VCL drag'n drop;\r\n\r\nbegin\r\n  inherited;\r\n\r\n  DragFinished;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TBaseVirtualTree.DragDrop(const DataObject: IDataObject; KeyState: Integer; Pt: TPoint;\r\n  var Effect: Integer): HResult;\r\n\r\nvar\r\n  Shift: TShiftState;\r\n  EnumFormat: IEnumFormatEtc;\r\n  Fetched: Integer;\r\n  OLEFormat: TFormatEtc;\r\n  Formats: TFormatArray;\r\n\r\nbegin\r\n  StopTimer(ExpandTimer);\r\n  StopTimer(ScrollTimer);\r\n  DoStateChange([], [tsScrollPending, tsScrolling]);\r\n  Formats := nil;\r\n\r\n  // Ask explicitly again whether the action is allowed. Otherwise we may accept a drop which is intentionally not\r\n  // allowed but cannot be prevented by the application because when the tree was scrolling while dropping\r\n  // no DragOver event is created by the OLE subsystem.\r\n  Result := DragOver(DragManager.DragSource, KeyState, dsDragMove, Pt, Effect);\r\n  try\r\n    if (Result <> NOERROR) or ((Effect and not DROPEFFECT_SCROLL) = DROPEFFECT_NONE) then\r\n      Result := E_FAIL\r\n    else\r\n    begin\r\n      try\r\n        Shift := KeysToShiftState(KeyState);\r\n        if tsRightButtonDown in FStates then\r\n          Include(Shift, ssRight)\r\n        else if tsMiddleButtonDown in FStates then\r\n          Include(Shift, ssMiddle)\r\n        else\r\n          Include(Shift, ssLeft);\r\n        Pt := ScreenToClient(Pt);\r\n        // Determine which formats we can get and pass them along with the data object to the drop handler.\r\n        Result := DataObject.EnumFormatEtc(DATADIR_GET, EnumFormat);\r\n        if Failed(Result) then\r\n          Abort;\r\n        Result := EnumFormat.Reset;\r\n        if Failed(Result) then\r\n          Abort;\r\n        // create a list of available formats\r\n        while EnumFormat.Next(1, OLEFormat, @Fetched) = S_OK do\r\n        begin\r\n          SetLength(Formats, Length(Formats) + 1);\r\n          Formats[High(Formats)] := OLEFormat.cfFormat;\r\n        end;\r\n        DoDragDrop(DragManager.DragSource, DataObject, Formats, Shift, Pt, Effect, FLastDropMode);\r\n      except\r\n        // An unhandled exception here leaks memory.\r\n        Application.HandleException(Self);\r\n        Result := E_UNEXPECTED;\r\n      end;\r\n    end;\r\n  finally\r\n    if Assigned(FDropTargetNode) then\r\n    begin\r\n      InvalidateNode(FDropTargetNode);\r\n      FDropTargetNode := nil;\r\n    end;\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TBaseVirtualTree.DragEnter(KeyState: Integer; Pt: TPoint; var Effect: Integer): HResult;\r\n\r\n// callback routine for the drop target interface\r\n\r\nvar\r\n  Shift: TShiftState;\r\n  Accept: Boolean;\r\n  R: TRect;\r\n  HitInfo: THitInfo;\r\n\r\nbegin\r\n  try\r\n    // Determine acceptance of drag operation and reset scroll start time.\r\n    FDragScrollStart := 0;\r\n\r\n    Shift := KeysToShiftState(KeyState);\r\n    if tsLeftButtonDown in FStates then\r\n      Include(Shift, ssLeft);\r\n    if tsMiddleButtonDown in FStates then\r\n      Include(Shift, ssMiddle);\r\n    if tsRightButtonDown in FStates then\r\n      Include(Shift, ssRight);\r\n    Pt := ScreenToClient(Pt);\r\n    Effect := SuggestDropEffect(DragManager.DragSource, Shift, Pt, Effect);\r\n    Accept := DoDragOver(DragManager.DragSource, Shift, dsDragEnter, Pt, FLastDropMode, Effect);\r\n    if not Accept then\r\n      Effect := DROPEFFECT_NONE\r\n    else\r\n    begin\r\n      // Set initial drop target node and drop mode.\r\n      GetHitTestInfoAt(Pt.X, Pt.Y, True, HitInfo);\r\n      if Assigned(HitInfo.HitNode) then\r\n      begin\r\n        FDropTargetNode := HitInfo.HitNode;\r\n        R := GetDisplayRect(HitInfo.HitNode, FHeader.MainColumn, False);\r\n        if (hiOnItemLabel in HitInfo.HitPositions) or ((hiOnItem in HitInfo.HitPositions) and\r\n          ((toFullRowDrag in FOptions.FMiscOptions) or (toFullRowSelect in FOptions.FSelectionOptions)))then\r\n          FLastDropMode := dmOnNode\r\n        else\r\n          if ((R.Top + R.Bottom) div 2) > Pt.Y then\r\n            FLastDropMode := dmAbove\r\n          else\r\n            FLastDropMode := dmBelow;\r\n      end\r\n      else\r\n        FLastDropMode := dmNowhere;\r\n    end;\r\n\r\n    // If the drag source is a virtual tree then we know how to control the drag image\r\n    // and can show it even if the source is not the target tree.\r\n    // This is only necessary if we cannot use the drag image helper interfaces.\r\n    if not DragManager.DropTargetHelperSupported and Assigned(DragManager.DragSource) then\r\n      DragManager.DragSource.FDragImage.ShowDragImage;\r\n    Result := NOERROR;\r\n  except\r\n    Result := E_UNEXPECTED;\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.DragFinished;\r\n\r\n// Called by DragCancelled or EndDrag to make up for the still missing mouse button up messages.\r\n// These are important for such important things like popup menus.\r\n\r\nvar\r\n  P: TPoint;\r\n\r\nbegin\r\n  if [tsOLEDragging, tsVCLDragPending, tsVCLDragging, tsVCLDragFinished] * FStates = [] then\r\n    Exit;\r\n\r\n  DoStateChange([], [tsVCLDragPending, tsVCLDragging, tsUserDragObject, tsVCLDragFinished]);\r\n\r\n  GetCursorPos(P);\r\n  P := ScreenToClient(P);\r\n  if tsRightButtonDown in FStates then\r\n    Perform(WM_RBUTTONUP, 0, LPARAM(Integer(PointToSmallPoint(P))))\r\n  else\r\n    if tsMiddleButtonDown in FStates then\r\n      Perform(WM_MBUTTONUP, 0, LPARAM(Integer(PointToSmallPoint(P))))\r\n    else\r\n      Perform(WM_LBUTTONUP, 0, LPARAM(Integer(PointToSmallPoint(P))));\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.DragLeave;\r\n\r\nvar\r\n  Effect: Integer;\r\n\r\nbegin\r\n  StopTimer(ExpandTimer);\r\n\r\n  if not DragManager.DropTargetHelperSupported and Assigned(DragManager.DragSource) then\r\n    DragManager.DragSource.FDragImage.HideDragImage;\r\n\r\n  if Assigned(FDropTargetNode) then\r\n  begin\r\n    InvalidateNode(FDropTargetNode);\r\n    FDropTargetNode := nil;\r\n  end;\r\n  UpdateWindow(Handle);\r\n\r\n  Effect := 0;\r\n  DoDragOver(nil, [], dsDragLeave, Point(0, 0), FLastDropMode, Effect);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TBaseVirtualTree.DragOver(Source: TObject; KeyState: Integer; DragState: TDragState; Pt: TPoint;\r\n  var Effect: Integer): HResult;\r\n\r\n// callback routine for the drop target interface\r\n\r\nvar\r\n  Shift: TShiftState;\r\n  Accept,\r\n  DragImageWillMove,\r\n  WindowScrolled: Boolean;\r\n  OldR, R: TRect;\r\n  NewDropMode: TDropMode;\r\n  HitInfo: THitInfo;\r\n  DragPos: TPoint;\r\n  Tree: TBaseVirtualTree;\r\n  LastNode: PVirtualNode;\r\n  DeltaX,\r\n  DeltaY: Integer;\r\n  ScrollOptions: TScrollUpdateOptions;\r\n\r\nbegin\r\n  if not DragManager.DropTargetHelperSupported and (Source is TBaseVirtualTree) then\r\n  begin\r\n    Tree := Source as TBaseVirtualTree;\r\n    ScrollOptions := [suoUpdateNCArea];\r\n  end\r\n  else\r\n  begin\r\n    Tree := nil;\r\n    ScrollOptions := DefaultScrollUpdateFlags;\r\n  end;\r\n\r\n  try\r\n    DragPos := Pt;\r\n    Pt := ScreenToClient(Pt);\r\n\r\n    // Check if we have to scroll the client area.\r\n    FScrollDirections := DetermineScrollDirections(Pt.X, Pt.Y);\r\n    DeltaX := 0;\r\n    DeltaY := 0;\r\n    if FScrollDirections <> [] then\r\n    begin\r\n      // Determine amount to scroll.\r\n      if sdUp in FScrollDirections then\r\n      begin\r\n        DeltaY := Min(FScrollBarOptions.FIncrementY, ClientHeight);\r\n        if FOffsetY = 0 then\r\n          Exclude(FScrollDirections, sdUp);\r\n      end;\r\n      if sdDown in FScrollDirections then\r\n      begin\r\n        DeltaY := -Min(FScrollBarOptions.FIncrementY, ClientHeight);\r\n        if (ClientHeight - FOffsetY) = Integer(FRangeY) then\r\n          Exclude(FScrollDirections, sdDown);\r\n      end;\r\n      if sdLeft in FScrollDirections then\r\n      begin\r\n        DeltaX := FScrollBarOptions.FIncrementX;\r\n        if FEffectiveOffsetX = 0 then\r\n          Exclude(FScrollDirections, sdleft);\r\n      end;\r\n      if sdRight in FScrollDirections then\r\n      begin\r\n        DeltaX := -FScrollBarOptions.FIncrementX;\r\n        if (ClientWidth + FEffectiveOffsetX) = Integer(FRangeX) then\r\n          Exclude(FScrollDirections, sdRight);\r\n      end;\r\n      WindowScrolled := DoSetOffsetXY(Point(FOffsetX + DeltaX, FOffsetY + DeltaY), ScrollOptions, nil);\r\n    end\r\n    else\r\n      WindowScrolled := False;\r\n\r\n    // Determine acceptance of drag operation as well as drag target.\r\n    Shift := KeysToShiftState(KeyState);\r\n    if tsLeftButtonDown in FStates then\r\n      Include(Shift, ssLeft);\r\n    if tsMiddleButtonDown in FStates then\r\n      Include(Shift, ssMiddle);\r\n    if tsRightButtonDown in FStates then\r\n      Include(Shift, ssRight);\r\n    GetHitTestInfoAt(Pt.X, Pt.Y, True, HitInfo);\r\n\r\n    if Assigned(HitInfo.HitNode) then\r\n      R := GetDisplayRect(HitInfo.HitNode, NoColumn, False)\r\n    else\r\n      R := Rect(0, 0, 0, 0);\r\n    NewDropMode := DetermineDropMode(Pt, HitInfo, R);\r\n\r\n    if Assigned(Tree) then\r\n      DragImageWillMove := Tree.FDragImage.WillMove(DragPos)\r\n    else\r\n      DragImageWillMove := False;\r\n\r\n    if (HitInfo.HitNode <> FDropTargetNode) or (FLastDropMode <> NewDropMode) then\r\n    begin\r\n      // Something in the tree will change. This requires to update the screen and/or the drag image.\r\n      FLastDropMode := NewDropMode;\r\n      if HitInfo.HitNode <> FDropTargetNode then\r\n      begin\r\n        StopTimer(ExpandTimer);\r\n        // The last target node is needed for the rectangle determination but must already be set for\r\n        // the recapture call, hence it must be stored somewhere.\r\n        LastNode := FDropTargetNode;\r\n        FDropTargetNode := HitInfo.HitNode;\r\n        // In order to show a selection rectangle a column must be focused.\r\n        if FFocusedColumn <= NoColumn then\r\n          FFocusedColumn := FHeader.MainColumn;\r\n\r\n        if Assigned(LastNode) and Assigned(FDropTargetNode) then\r\n        begin\r\n          // Optimize the case that the selection moved between two nodes.\r\n          OldR := GetDisplayRect(LastNode, NoColumn, False);\r\n          UnionRect(R, R, OldR);\r\n          if Assigned(Tree) then\r\n          begin\r\n            if WindowScrolled then\r\n              UpdateWindowAndDragImage(Tree, ClientRect, True, not DragImageWillMove)\r\n            else\r\n              UpdateWindowAndDragImage(Tree, R, False, not DragImageWillMove);\r\n          end\r\n          else\r\n            InvalidateRect(Handle, @R, False);\r\n        end\r\n        else\r\n        begin\r\n          if Assigned(LastNode) then\r\n          begin\r\n            // Repaint last target node.\r\n            OldR := GetDisplayRect(LastNode, NoColumn, False);\r\n            if Assigned(Tree) then\r\n            begin\r\n              if WindowScrolled then\r\n                UpdateWindowAndDragImage(Tree, ClientRect, WindowScrolled, not DragImageWillMove)\r\n              else\r\n                UpdateWindowAndDragImage(Tree, OldR, False, not DragImageWillMove);\r\n            end\r\n            else\r\n              InvalidateRect(Handle, @OldR, False);\r\n          end\r\n          else\r\n          begin\r\n            if Assigned(Tree) then\r\n            begin\r\n              if WindowScrolled then\r\n                UpdateWindowAndDragImage(Tree, ClientRect, WindowScrolled, not DragImageWillMove)\r\n              else\r\n                UpdateWindowAndDragImage(Tree, R, False, not DragImageWillMove);\r\n            end\r\n            else\r\n              InvalidateRect(Handle, @R, False);\r\n          end;\r\n        end;\r\n\r\n        // Start auto expand timer if necessary.\r\n        if (toAutoDropExpand in FOptions.FAutoOptions) and Assigned(FDropTargetNode) and\r\n          (vsHasChildren in FDropTargetNode.States) then\r\n          SetTimer(Handle, ExpandTimer, FAutoExpandDelay, nil);\r\n      end\r\n      else\r\n      begin\r\n        // Only the drop mark position changed so invalidate the current drop target node.\r\n        if Assigned(Tree) then\r\n        begin\r\n          if WindowScrolled then\r\n            UpdateWindowAndDragImage(Tree, ClientRect, WindowScrolled, not DragImageWillMove)\r\n          else\r\n            UpdateWindowAndDragImage(Tree, R, False, not DragImageWillMove);\r\n        end\r\n        else\r\n          InvalidateRect(Handle, @R, False);\r\n      end;\r\n    end\r\n    else\r\n    begin\r\n      // No change in the current drop target or drop mode. This might still mean horizontal or vertical scrolling.\r\n      if Assigned(Tree) and ((DeltaX <> 0) or (DeltaY <> 0)) then\r\n        UpdateWindowAndDragImage(Tree, ClientRect, WindowScrolled, not DragImageWillMove);\r\n    end;\r\n\r\n    Update;\r\n\r\n    if Assigned(Tree) and DragImageWillMove then\r\n      Tree.FDragImage.DragTo(DragPos, False);\r\n\r\n    Effect := SuggestDropEffect(Source, Shift, Pt, Effect);\r\n    Accept := DoDragOver(Source, Shift, DragState, Pt, FLastDropMode, Effect);\r\n    if not Accept then\r\n      Effect := DROPEFFECT_NONE;\r\n    if WindowScrolled then\r\n      Effect := Effect or Integer(DROPEFFECT_SCROLL);\r\n    Result := NOERROR;\r\n  except\r\n    Result := E_UNEXPECTED;\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.DrawDottedHLine(const PaintInfo: TVTPaintInfo; Left, Right, Top: Integer);\r\n\r\n// Draws a horizontal line with alternating pixels (this style is not supported for pens under Win9x).\r\n\r\nvar\r\n  R: TRect;\r\n\r\nbegin\r\n  with PaintInfo, Canvas do\r\n  begin\r\n    Brush.Color := FColors.BackGroundColor;\r\n    R := Rect(Min(Left, Right), Top, Max(Left, Right) + 1, Top + 1);\r\n    Winapi.Windows.FillRect(Handle, R, FDottedBrush);\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.DrawDottedVLine(const PaintInfo: TVTPaintInfo; Top, Bottom, Left: Integer; UseSelectedBkColor: Boolean = False);\r\n\r\n// Draws a horizontal line with alternating pixels (this style is not supported for pens under Win9x).\r\n\r\nvar\r\n  R: TRect;\r\n\r\nbegin\r\n  with PaintInfo, Canvas do\r\n  begin\r\n    if UseSelectedBkColor then\r\n    begin\r\n      if Focused or (toPopupMode in FOptions.FPaintOptions) then\r\n        Brush.Color := FColors.FocusedSelectionColor\r\n      else\r\n        Brush.Color := FColors.UnfocusedSelectionColor;\r\n    end\r\n    else\r\n    Brush.Color := FColors.BackGroundColor;\r\n    R := Rect(Left, Min(Top, Bottom), Left + 1, Max(Top, Bottom) + 1);\r\n    Winapi.Windows.FillRect(Handle, R, FDottedBrush);\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.EndOperation(OperationKind: TVTOperationKind);\r\n\r\n// Called to indicate that a long-running operation has finished.\r\n\r\nbegin\r\n  Assert(FOperationCount > 0, 'EndOperation must not be called when no operation in progress.');\r\n  Dec(FOperationCount);\r\n  DoEndOperation(OperationKind);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.EnsureNodeFocused();\r\nbegin\r\n  if FocusedNode = nil then\r\n    FocusedNode := Self.GetFirstSelected();\r\n  if FocusedNode = nil then\r\n    FocusedNode := Self.GetFirstVisible();\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.EnsureNodeSelected();\r\nbegin\r\n  if (toAlwaysSelectNode in TreeOptions.SelectionOptions) and (GetFirstSelected() = nil) and not SelectionLocked and not IsEmpty then\r\n  begin\r\n    if Assigned(FNextNodeToSelect) then\r\n      Selected[FNextNodeToSelect] := True\r\n    else if Self.Focused then\r\n      Selected[GetFirstVisible] := True;\r\n    EnsureNodeFocused();\r\n  end;//if\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TBaseVirtualTree.FindNodeInSelection(P: PVirtualNode; var Index: Integer; LowBound,\r\n  HighBound: Integer): Boolean;\r\n\r\n// Search routine to find a specific node in the selection array.\r\n// LowBound and HighBound determine the range in which to search the node.\r\n// Either value can be -1 to denote the maximum range otherwise LowBound must be less or equal HighBound.\r\n\r\nvar\r\n  L, H,\r\n  I: Integer;\r\n\r\nbegin\r\n  Result := False;\r\n  L := 0;\r\n  if LowBound >= 0 then\r\n    L := LowBound;\r\n  H := FSelectionCount - 1;\r\n  if HighBound >= 0 then\r\n    H := HighBound;\r\n  while L <= H do\r\n  begin\r\n    I := (L + H) shr 1;\r\n    if PAnsiChar(FSelection[I]) < PAnsiChar(P) then\r\n      L := I + 1\r\n    else\r\n    begin\r\n      H := I - 1;\r\n      if FSelection[I] = P then\r\n      begin\r\n        Result := True;\r\n        L := I;\r\n      end;\r\n    end;\r\n  end;\r\n  Index := L;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.FinishChunkHeader(Stream: TStream; StartPos, EndPos: Integer);\r\n\r\n// used while streaming out a node to finally write out the size of the chunk\r\n\r\nvar\r\n  Size: Integer;\r\n\r\nbegin\r\n  // seek back to the second entry in the chunk header\r\n  Stream.Position := StartPos + SizeOf(Size);\r\n  // determine size of chunk without the chunk header\r\n  Size := EndPos - StartPos - SizeOf(TChunkHeader);\r\n  // write the size...\r\n  Stream.Write(Size, SizeOf(Size));\r\n  // ... and seek to the last endposition\r\n  Stream.Position := EndPos;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.FontChanged(AFont: TObject);\r\n\r\n// Little helper function for font changes (as they are not tracked in TBitmap/TCanvas.OnChange).\r\n\r\nbegin\r\n  FFontChanged := True;\r\n  if Assigned(FOldFontChange) then\r\n    FOldFontChange(AFont);\r\n  //if not (tsPainting in TreeStates) then AutoScale();\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TBaseVirtualTree.GetBorderDimensions: TSize;\r\n\r\n// Returns the overall width of the current window border, depending on border styles.\r\n// Note: these numbers represent the system's standards not special properties, which can be set for TWinControl\r\n// (e.g. bevels, border width).\r\n\r\nvar\r\n  Styles: Integer;\r\n\r\nbegin\r\n  Result.cx := 0;\r\n  Result.cy := 0;\r\n\r\n  Styles := GetWindowLong(Handle, GWL_STYLE);\r\n  if (Styles and WS_BORDER) <> 0 then\r\n  begin\r\n    Dec(Result.cx);\r\n    Dec(Result.cy);\r\n  end;\r\n  if (Styles and WS_THICKFRAME) <> 0 then\r\n  begin\r\n    Dec(Result.cx, GetSystemMetrics(SM_CXFIXEDFRAME));\r\n    Dec(Result.cy, GetSystemMetrics(SM_CYFIXEDFRAME));\r\n  end;\r\n  Styles := GetWindowLong(Handle, GWL_EXSTYLE);\r\n  if (Styles and WS_EX_CLIENTEDGE) <> 0 then\r\n  begin\r\n    Dec(Result.cx, GetSystemMetrics(SM_CXEDGE));\r\n    Dec(Result.cy, GetSystemMetrics(SM_CYEDGE));\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TBaseVirtualTree.GetCheckImage(Node: PVirtualNode; ImgCheckType: TCheckType = ctNone; ImgCheckState:\r\n  TCheckState = csUncheckedNormal; ImgEnabled: Boolean = True): Integer;\r\n\r\n// Determines the index into the check image list for the given node depending on the check type\r\n// and enabled state.\r\n\r\nconst\r\n  // Four dimensional array consisting of image indices for the check type, the check state, the enabled state and the\r\n  // hot state.\r\n  CheckStateToCheckImage: array[ctCheckBox..ctButton, csUncheckedNormal..csMixedPressed, Boolean, Boolean] of Integer = (\r\n    // ctCheckBox, ctTriStateCheckBox\r\n    (\r\n      // csUncheckedNormal (disabled [not hot, hot], enabled [not hot, hot])\r\n      ((ckCheckUncheckedDisabled, ckCheckUncheckedDisabled), (ckCheckUncheckedNormal, ckCheckUncheckedHot)),\r\n      // csUncheckedPressed (disabled [not hot, hot], enabled [not hot, hot])\r\n      ((ckCheckUncheckedDisabled, ckCheckUncheckedDisabled), (ckCheckUncheckedPressed, ckCheckUncheckedPressed)),\r\n      // csCheckedNormal\r\n      ((ckCheckCheckedDisabled, ckCheckCheckedDisabled), (ckCheckCheckedNormal, ckCheckCheckedHot)),\r\n      // csCheckedPressed\r\n      ((ckCheckCheckedDisabled, ckCheckCheckedDisabled), (ckCheckCheckedPressed, ckCheckCheckedPressed)),\r\n      // csMixedNormal\r\n      ((ckCheckMixedDisabled, ckCheckMixedDisabled), (ckCheckMixedNormal, ckCheckMixedHot)),\r\n      // csMixedPressed\r\n      ((ckCheckMixedDisabled, ckCheckMixedDisabled), (ckCheckMixedPressed, ckCheckMixedPressed))\r\n    ),\r\n    // ctRadioButton\r\n    (\r\n      // csUncheckedNormal (disabled [not hot, hot], enabled [not hot, hot])\r\n      ((ckRadioUncheckedDisabled, ckRadioUncheckedDisabled), (ckRadioUncheckedNormal, ckRadioUncheckedHot)),\r\n      // csUncheckedPressed (disabled [not hot, hot], enabled [not hot, hot])\r\n      ((ckRadioUncheckedDisabled, ckRadioUncheckedDisabled), (ckRadioUncheckedPressed, ckRadioUncheckedPressed)),\r\n      // csCheckedNormal\r\n      ((ckRadioCheckedDisabled, ckRadioCheckedDisabled), (ckRadioCheckedNormal, ckRadioCheckedHot)),\r\n      // csCheckedPressed\r\n      ((ckRadioCheckedDisabled, ckRadioCheckedDisabled), (ckRadioCheckedPressed, ckRadioCheckedPressed)),\r\n      // csMixedNormal (should never appear with ctRadioButton)\r\n      ((ckCheckMixedDisabled, ckCheckMixedDisabled), (ckCheckMixedNormal, ckCheckMixedHot)),\r\n      // csMixedPressed (should never appear with ctRadioButton)\r\n      ((ckCheckMixedDisabled, ckCheckMixedDisabled), (ckCheckMixedPressed, ckCheckMixedPressed))\r\n    ),\r\n    // ctButton\r\n    (\r\n      // csUncheckedNormal (disabled [not hot, hot], enabled [not hot, hot])\r\n      ((ckButtonDisabled, ckButtonDisabled), (ckButtonNormal, ckButtonHot)),\r\n      // csUncheckedPressed (disabled [not hot, hot], enabled [not hot, hot])\r\n      ((ckButtonDisabled, ckButtonDisabled), (ckButtonPressed, ckButtonPressed)),\r\n      // csCheckedNormal\r\n      ((ckButtonDisabled, ckButtonDisabled), (ckButtonNormal, ckButtonHot)),\r\n      // csCheckedPressed\r\n      ((ckButtonDisabled, ckButtonDisabled), (ckButtonPressed, ckButtonPressed)),\r\n      // csMixedNormal (should never appear with ctButton)\r\n      ((ckCheckMixedDisabled, ckCheckMixedDisabled), (ckCheckMixedNormal, ckCheckMixedHot)),\r\n      // csMixedPressed (should never appear with ctButton)\r\n      ((ckCheckMixedDisabled, ckCheckMixedDisabled), (ckCheckMixedPressed, ckCheckMixedPressed))\r\n    )\r\n  );\r\n\r\nvar\r\n  IsHot: Boolean;\r\n\r\nbegin\r\n  if Assigned(Node) then\r\n  begin\r\n    ImgCheckType := Node.CheckType;\r\n    ImgCheckState := Node.CheckState;\r\n    ImgEnabled := not (vsDisabled in Node.States) and Enabled;\r\n    IsHot := Node = FCurrentHotNode;\r\n  end\r\n  else\r\n    IsHot := False;\r\n\r\n  if ImgCheckType = ctTriStateCheckBox then\r\n    ImgCheckType := ctCheckBox;\r\n\r\n  if ImgCheckType = ctNone then\r\n    Result := -1\r\n  else\r\n    Result := CheckStateToCheckImage[ImgCheckType, ImgCheckState, ImgEnabled, IsHot];\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nclass function TBaseVirtualTree.GetCheckImageListFor(Kind: TCheckImageKind): TCustomImageList;\r\n\r\nbegin\r\n  case Kind of\r\n    ckDarkCheck:\r\n      Result := DarkCheckImages;\r\n    ckLightTick:\r\n      Result := LightTickImages;\r\n    ckDarkTick:\r\n      Result := DarkTickImages;\r\n    ckLightCheck:\r\n      Result := LightCheckImages;\r\n    ckFlat:\r\n      Result := FlatImages;\r\n    ckXP:\r\n      Result := XPImages;\r\n    ckSystemDefault:\r\n      Result := SystemCheckImages;\r\n    ckSystemFlat:\r\n      Result := SystemFlatCheckImages;\r\n    else\r\n      Result := nil;\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TBaseVirtualTree.GetColumnClass: TVirtualTreeColumnClass;\r\n\r\nbegin\r\n  Result := TVirtualTreeColumn;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TBaseVirtualTree.GetHeaderClass: TVTHeaderClass;\r\n\r\nbegin\r\n  Result := TVTHeader;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TBaseVirtualTree.GetHintWindowClass: THintWindowClass;\r\n\r\n// Returns the default hint window class used for the tree. Descendants can override it to use their own System.Classes.\r\n\r\nbegin\r\n  Result := TVirtualTreeHintWindow;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.GetImageIndex(var Info: TVTPaintInfo; Kind: TVTImageKind; InfoIndex: TVTImageInfoIndex;\r\n  DefaultImages: TCustomImageList);\r\n\r\n// Retrieves the image index and an eventual customized image list for drawing.\r\n\r\nvar\r\n  CustomImages: TCustomImageList;\r\n\r\nbegin\r\n  with Info do\r\n  begin\r\n    ImageInfo[InfoIndex].Index := -1;\r\n    ImageInfo[InfoIndex].Ghosted := False;\r\n\r\n    CustomImages := DoGetImageIndex(Node, Kind, Column, ImageInfo[InfoIndex].Ghosted, ImageInfo[InfoIndex].Index);\r\n    if Assigned(CustomImages) then\r\n      ImageInfo[InfoIndex].Images := CustomImages\r\n    else\r\n      ImageInfo[InfoIndex].Images := DefaultImages;\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TBaseVirtualTree.IsEmpty: Boolean;\r\nbegin\r\n  Result := (Self.ChildCount[nil] = 0);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TBaseVirtualTree.GetNodeImageSize(Node: PVirtualNode): TSize;\r\n\r\n  // Returns the size of an image\r\n  // Override if you need different sized images for certain nodes.\r\nbegin\r\n  if Assigned(FImages) then\r\n  begin\r\n    Result.cx := FImages.Width;\r\n    Result.cy := FImages.Height;\r\n  end\r\n  else\r\n  begin\r\n    Result.cx := 0;\r\n    Result.cy := 0;\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TBaseVirtualTree.GetMaxRightExtend: Cardinal;\r\n\r\n// Determines the maximum with of the currently visible part of the tree, depending on the length\r\n// of the node texts. This method is used for determining the horizontal scroll range if no columns are used.\r\n\r\nvar\r\n  Node,\r\n  NextNode: PVirtualNode;\r\n  TopPosition: Integer;\r\n  NodeLeft,\r\n  CurrentWidth: Integer;\r\n  WithCheck: Boolean;\r\n  CheckOffset: Integer;\r\n\r\nbegin\r\n  Node := GetNodeAt(0, 0, True, TopPosition);\r\n  Result := 0;\r\n  if toShowRoot in FOptions.FPaintOptions then\r\n    NodeLeft := (GetNodeLevel(Node) + 1) * FIndent\r\n  else\r\n    NodeLeft := GetNodeLevel(Node) * FIndent;\r\n\r\n  if Assigned(FStateImages) then\r\n    Inc(NodeLeft, FStateImages.Width + 2);\r\n  if Assigned(FImages) then\r\n    Inc(NodeLeft, FImages.Width + 2);\r\n  WithCheck := (toCheckSupport in FOptions.FMiscOptions) and Assigned(FCheckImages);\r\n  if WithCheck then\r\n    CheckOffset := FCheckImages.Width + 2\r\n  else\r\n    CheckOffset := 0;\r\n\r\n  while Assigned(Node) do\r\n  begin\r\n    if not (vsInitialized in Node.States) then\r\n      InitNode(Node);\r\n\r\n    if WithCheck and (Node.CheckType <> ctNone) then\r\n      Inc(NodeLeft, CheckOffset);\r\n    CurrentWidth := DoGetNodeWidth(Node, NoColumn);\r\n    Inc(CurrentWidth, DoGetNodeExtraWidth(Node, NoColumn));\r\n    if Integer(Result) < (NodeLeft + CurrentWidth) then\r\n      Result := NodeLeft + CurrentWidth;\r\n    Inc(TopPosition, NodeHeight[Node]);\r\n    if TopPosition > Height then\r\n      Break;\r\n\r\n    if WithCheck and (Node.CheckType <> ctNone) then\r\n      Dec(NodeLeft, CheckOffset);\r\n\r\n    // Get next visible node and update left node position.\r\n    NextNode := GetNextVisible(Node, True);\r\n    if NextNode = nil then\r\n      Break;\r\n    Inc(NodeLeft, CountLevelDifference(Node, NextNode) * Integer(FIndent));\r\n    Node := NextNode;\r\n  end;\r\n\r\n  Inc(Result, FMargin);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.GetNativeClipboardFormats(var Formats: TFormatEtcArray);\r\n\r\n// Returns the supported clipboard formats of the tree.\r\n\r\nbegin\r\n  TClipboardFormatList.EnumerateFormats(TVirtualTreeClass(ClassType), Formats, FClipboardFormats);\r\n  // Ask application/descendants for self defined formats.\r\n  DoGetUserClipboardFormats(Formats);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TBaseVirtualTree.GetOperationCanceled;\r\n\r\nbegin\r\n  Result := FOperationCanceled and (FOperationCount > 0);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TBaseVirtualTree.GetOptionsClass: TTreeOptionsClass;\r\n\r\nbegin\r\n  Result := TCustomVirtualTreeOptions;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TBaseVirtualTree.GetTreeFromDataObject(const DataObject: IDataObject): TBaseVirtualTree;\r\n\r\n// Returns the owner/sender of the given data object by means of a special clipboard format\r\n// or nil if the sender is in another process or no virtual tree at all.\r\n\r\nvar\r\n  Medium: TStgMedium;\r\n  Data: PVTReference;\r\n\r\nbegin\r\n  Result := nil;\r\n  if Assigned(DataObject) then\r\n  begin\r\n    StandardOLEFormat.cfFormat := CF_VTREFERENCE;\r\n    if DataObject.GetData(StandardOLEFormat, Medium) = S_OK then\r\n    begin\r\n      Data := GlobalLock(Medium.hGlobal);\r\n      if Assigned(Data) then\r\n      begin\r\n        if Data.Process = GetCurrentProcessID then\r\n          Result := Data.Tree;\r\n        GlobalUnlock(Medium.hGlobal);\r\n      end;\r\n      ReleaseStgMedium(Medium);\r\n    end;\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.HandleHotTrack(X, Y: Integer);\r\n\r\n// Updates the current \"hot\" node.\r\n\r\nvar\r\n  HitInfo: THitInfo;\r\n  CheckPositions: THitPositions;\r\n  ButtonIsHit,\r\n  DoInvalidate: Boolean;\r\n  oldHotNode : PVirtualNode;\r\nbegin\r\n  DoInvalidate := False;\r\n  oldHotNode := FCurrentHotNode;\r\n  // Get information about the hit.\r\n  GetHitTestInfoAt(X, Y, True, HitInfo);\r\n\r\n  // Only make the new node being \"hot\" if its label is hit or full row selection is enabled.\r\n  CheckPositions := [hiOnItemLabel, hiOnItemCheckbox];\r\n\r\n  // If running under Windows Vista using the explorer theme hitting the buttons makes the node hot, too.\r\n  if tsUseExplorerTheme in FStates then\r\n    Include(CheckPositions, hiOnItemButtonExact);\r\n\r\n  if (CheckPositions * HitInfo.HitPositions = []) and\r\n    (not (toFullRowSelect in FOptions.FSelectionOptions) or (hiNowhere in HitInfo.HitPositions)) then\r\n    HitInfo.HitNode := nil;\r\n  if (HitInfo.HitNode <> FCurrentHotNode) or (HitInfo.HitColumn <> FCurrentHotColumn) then\r\n  begin\r\n    DoInvalidate := (toHotTrack in FOptions.PaintOptions) or (toCheckSupport in FOptions.FMiscOptions);\r\n    DoHotChange(FCurrentHotNode, HitInfo.HitNode);\r\n    if Assigned(FCurrentHotNode) and DoInvalidate then\r\n      InvalidateNode(FCurrentHotNode);\r\n    FCurrentHotNode := HitInfo.HitNode;\r\n    FCurrentHotColumn := HitInfo.HitColumn;\r\n  end;\r\n\r\n  ButtonIsHit := (hiOnItemButtonExact in HitInfo.HitPositions);\r\n  if Assigned(FCurrentHotNode) and ((FHotNodeButtonHit <> ButtonIsHit) or DoInvalidate) then\r\n  begin\r\n    FHotNodeButtonHit := ButtonIsHit;\r\n    InvalidateNode(FCurrentHotNode);\r\n  end\r\n  else\r\n    if not Assigned(FCurrentHotNode) then\r\n      FHotNodeButtonHit := False;\r\n\r\n  if (oldHotNode <> FCurrentHotNode) and (oldHotNode <> nil) then\r\n    InvalidateNode(oldHotNode);\r\n\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.HandleIncrementalSearch(CharCode: Word);\r\n\r\nvar\r\n  Run, Stop: PVirtualNode;\r\n  GetNextNode: TGetNextNodeProc;\r\n  NewSearchText: string;\r\n  SingleLetter,\r\n  PreviousSearch: Boolean; // True if VK_BACK was sent.\r\n  SearchDirection: TVTSearchDirection;\r\n\r\n  //--------------- local functions -------------------------------------------\r\n\r\n  procedure SetupNavigation;\r\n\r\n  // If the search buffer is empty then we start searching with the next node after the last one, otherwise\r\n  // we continue with the last one. Node navigation function is set up too here, to avoid frequent checks.\r\n\r\n  var\r\n    FindNextNode: Boolean;\r\n\r\n  begin\r\n    FindNextNode := (Length(FSearchBuffer) = 0) or (Run = nil) or SingleLetter or PreviousSearch;\r\n    case FIncrementalSearch of\r\n      isVisibleOnly:\r\n        if SearchDirection = sdForward then\r\n        begin\r\n          GetNextNode := GetNextVisible;\r\n          if FindNextNode then\r\n          begin\r\n            if Run = nil then\r\n              Run := GetFirstVisible(nil, True)\r\n            else\r\n            begin\r\n              Run := GetNextVisible(Run, True);\r\n              // Do wrap around.\r\n              if Run = nil then\r\n                Run := GetFirstVisible(nil, True);\r\n            end;\r\n          end;\r\n        end\r\n        else\r\n        begin\r\n          GetNextNode := GetPreviousVisible;\r\n          if FindNextNode then\r\n          begin\r\n            if Run = nil then\r\n              Run := GetLastVisible(nil, True)\r\n            else\r\n            begin\r\n              Run := GetPreviousVisible(Run, True);\r\n              // Do wrap around.\r\n              if Run = nil then\r\n                Run := GetLastVisible(nil, True);\r\n            end;\r\n          end;\r\n        end;\r\n      isInitializedOnly:\r\n        if SearchDirection = sdForward then\r\n        begin\r\n          GetNextNode := GetNextNoInit;\r\n          if FindNextNode then\r\n          begin\r\n            if Run = nil then\r\n              Run := GetFirstNoInit\r\n            else\r\n            begin\r\n              Run := GetNextNoInit(Run);\r\n              // Do wrap around.\r\n              if Run = nil then\r\n                Run := GetFirstNoInit;\r\n            end;\r\n          end;\r\n        end\r\n        else\r\n        begin\r\n          GetNextNode := GetPreviousNoInit;\r\n          if FindNextNode then\r\n          begin\r\n            if Run = nil then\r\n              Run := GetLastNoInit\r\n            else\r\n            begin\r\n              Run := GetPreviousNoInit(Run);\r\n              // Do wrap around.\r\n              if Run = nil then\r\n                Run := GetLastNoInit;\r\n            end;\r\n          end;\r\n        end;\r\n    else\r\n      // isAll\r\n      if SearchDirection = sdForward then\r\n      begin\r\n        GetNextNode := GetNext;\r\n        if FindNextNode then\r\n        begin\r\n          if Run = nil then\r\n            Run := GetFirst\r\n          else\r\n          begin\r\n            Run := GetNext(Run);\r\n            // Do wrap around.\r\n            if Run = nil then\r\n              Run := GetFirst;\r\n          end;\r\n        end;\r\n      end\r\n      else\r\n      begin\r\n        GetNextNode := GetPrevious;\r\n        if FindNextNode then\r\n        begin\r\n          if Run = nil then\r\n            Run := GetLast\r\n          else\r\n          begin\r\n            Run := GetPrevious(Run);\r\n            // Do wrap around.\r\n            if Run = nil then\r\n              Run := GetLast;\r\n          end;\r\n        end;\r\n      end;\r\n    end;\r\n  end;\r\n\r\n  //---------------------------------------------------------------------------\r\n\r\n  function CodePageFromLocale(Language: LCID): Integer;\r\n\r\n  // Determines the code page for a given locale.\r\n  // Unfortunately there is no easier way than this, currently.\r\n\r\n  var\r\n    Buf: array[0..6] of Char;\r\n\r\n  begin\r\n    GetLocaleInfo(Language, LOCALE_IDEFAULTANSICODEPAGE, Buf, 6);\r\n    Result := StrToIntDef(Buf, GetACP);\r\n  end;\r\n\r\n  //---------------------------------------------------------------------------\r\n\r\n  function KeyUnicode(C: Char): WideChar;\r\n  // Converts the given character into its corresponding Unicode character\r\n  // depending on the active keyboard layout.\r\n  begin\r\n    Result := C;      //!!!!!!\r\n  end;\r\n\r\n  //--------------- end local functions ---------------------------------------\r\n\r\nvar\r\n  FoundMatch: Boolean;\r\n  NewChar: WideChar;\r\n\r\nbegin\r\n  StopTimer(SearchTimer);\r\n\r\n  if FIncrementalSearch <> isNone then\r\n  begin\r\n    if CharCode <> 0 then\r\n    begin\r\n      DoStateChange([tsIncrementalSearching]);\r\n\r\n      // Convert the given virtual key code into a Unicode character based on the current locale.\r\n      NewChar := KeyUnicode(Char(CharCode));\r\n      PreviousSearch := NewChar = WideChar(VK_BACK);\r\n      // We cannot do a search with an empty search buffer.\r\n      if not PreviousSearch or (FSearchBuffer <> '') then\r\n      begin\r\n        // Determine which method to use to advance nodes and the start node to search from.\r\n        case FSearchStart of\r\n          ssAlwaysStartOver:\r\n            Run := nil;\r\n          ssFocusedNode:\r\n            Run := FFocusedNode;\r\n        else // ssLastHit\r\n          Run := FLastSearchNode;\r\n        end;\r\n\r\n        // Make sure the start node corresponds to the search criterion.\r\n        if Assigned(Run) then\r\n        begin\r\n          case FIncrementalSearch of\r\n            isInitializedOnly:\r\n              if not (vsInitialized in Run.States) then\r\n                Run := nil;\r\n            isVisibleOnly:\r\n              if not FullyVisible[Run] or IsEffectivelyFiltered[Run] then\r\n                Run := nil;\r\n          end;\r\n        end;\r\n        Stop := Run;\r\n\r\n        // VK_BACK temporarily changes search direction to opposite mode.\r\n        if PreviousSearch then\r\n        begin\r\n          if SearchDirection = sdBackward then\r\n            SearchDirection := sdForward\r\n          else\r\n            SearchDirection := sdBackward;\r\n        end\r\n        else\r\n          SearchDirection := FSearchDirection;\r\n        // The \"single letter mode\" is used to advance quickly from node to node when pressing the same key several times.\r\n        SingleLetter := (Length(FSearchBuffer) = 1) and not PreviousSearch and (FSearchBuffer[1] = NewChar);\r\n        // However if the current hit (if there is one) would fit also with a repeated character then\r\n        // don't use single letter mode.\r\n        if SingleLetter and (DoIncrementalSearch(Run, FSearchBuffer + NewChar) = 0) then\r\n          SingleLetter := False;\r\n        SetupNavigation;\r\n        FoundMatch := False;\r\n\r\n        if Assigned(Run) then\r\n        begin\r\n          if SingleLetter then\r\n            NewSearchText := FSearchBuffer\r\n          else\r\n            if PreviousSearch then\r\n            begin\r\n              SetLength(FSearchBuffer, Length(FSearchBuffer) - 1);\r\n              NewSearchText := FSearchBuffer;\r\n            end\r\n            else\r\n              NewSearchText := FSearchBuffer + NewChar;\r\n\r\n          repeat\r\n            if DoIncrementalSearch(Run, NewSearchText) = 0 then\r\n            begin\r\n              FoundMatch := True;\r\n              Break;\r\n            end;\r\n\r\n            // Advance to next node if we have not found a match.\r\n            Run := GetNextNode(Run);\r\n            // Do wrap around start or end of tree.\r\n            if (Run <> Stop) and (Run = nil) then\r\n              SetupNavigation;\r\n          until Run = Stop;\r\n        end;\r\n\r\n        if FoundMatch then\r\n        begin\r\n          ClearSelection;\r\n          FSearchBuffer := NewSearchText;\r\n          FLastSearchNode := Run;\r\n          FocusedNode := Run;\r\n          Selected[Run] := True;\r\n          FLastSearchNode := Run;\r\n        end\r\n        else\r\n          // Play an acoustic signal if nothing could be found but don't beep if only the currently\r\n          // focused node matches.\r\n          if Assigned(Run) and (DoIncrementalSearch(Run, NewSearchText) <> 0) then\r\n            Beep;\r\n      end;\r\n    end;\r\n\r\n    // Restart search timeout interval.\r\n    SetTimer(Handle, SearchTimer, FSearchTimeout, nil);\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.HandleMouseDblClick(var Message: TWMMouse; const HitInfo: THitInfo);\r\n\r\nvar\r\n  NewCheckState: TCheckState;\r\n  Node: PVirtualNode;\r\n  MayEdit: Boolean;\r\n\r\nbegin\r\n  MayEdit := not (tsEditing in FStates) and (toEditOnDblClick in FOptions.FMiscOptions);\r\n  if tsEditPending in FStates then\r\n  begin\r\n    StopTimer(EditTimer);\r\n    DoStateChange([], [tsEditPending]);\r\n  end;\r\n\r\n  if not (tsEditing in FStates) or DoEndEdit then\r\n  begin\r\n    if HitInfo.HitColumn = FHeader.FColumns.FClickIndex then\r\n      DoColumnDblClick(HitInfo.HitColumn, KeysToShiftState(Message.Keys));\r\n\r\n      if HitInfo.HitNode <> nil then\r\n      DoNodeDblClick(HitInfo);\r\n\r\n    Node := nil;\r\n    if (hiOnItem in HitInfo.HitPositions) and (HitInfo.HitColumn > NoColumn) and\r\n       (coFixed in FHeader.FColumns[HitInfo.HitColumn].FOptions) then\r\n    begin\r\n      if hiUpperSplitter in HitInfo.HitPositions then\r\n        Node := GetPreviousVisible(HitInfo.HitNode, True)\r\n      else\r\n        if  hiLowerSplitter in HitInfo.HitPositions then\r\n          Node := HitInfo.HitNode;\r\n    end;\r\n\r\n    if Assigned(Node) and (Node <> FRoot) and (toNodeHeightDblClickResize in FOptions.FMiscOptions) then\r\n    begin\r\n      if DoNodeHeightDblClickResize(Node, HitInfo.HitColumn, KeysToShiftState(Message.Keys), Point(Message.XPos, Message.YPos)) then\r\n      begin\r\n        SetNodeHeight(Node, FDefaultNodeHeight);\r\n        UpdateWindow(Handle);\r\n        MayEdit := False;\r\n      end;\r\n    end\r\n    else\r\n      if hiOnItemCheckBox in HitInfo.HitPositions then\r\n      begin\r\n        if (FStates * [tsMouseCheckPending, tsKeyCheckPending] = []) and not (vsDisabled in HitInfo.HitNode.States) then\r\n        begin\r\n          with HitInfo.HitNode^ do\r\n            NewCheckState := DetermineNextCheckState(CheckType, CheckState);\r\n          if (ssLeft in KeysToShiftState(Message.Keys)) and DoChecking(HitInfo.HitNode, NewCheckState) then\r\n          begin\r\n            DoStateChange([tsMouseCheckPending]);\r\n            FCheckNode := HitInfo.HitNode;\r\n            FPendingCheckState := NewCheckState;\r\n            FCheckNode.CheckState := PressedState[FCheckNode.CheckState];\r\n            InvalidateNode(HitInfo.HitNode);\r\n            MayEdit := False;\r\n          end;\r\n        end;\r\n      end\r\n      else\r\n      begin\r\n        if hiOnItemButton in HitInfo.HitPositions then\r\n        begin\r\n          ToggleNode(HitInfo.HitNode);\r\n          MayEdit := False;\r\n        end\r\n        else\r\n        begin\r\n          if toToggleOnDblClick in FOptions.FMiscOptions then\r\n          begin\r\n            if ((([hiOnItemButton, hiOnItemLabel, hiOnNormalIcon, hiOnStateIcon] * HitInfo.HitPositions) <> []) or\r\n              ((toFullRowSelect in FOptions.FSelectionOptions) and Assigned(HitInfo.HitNode))) then\r\n            begin\r\n              ToggleNode(HitInfo.HitNode);\r\n              MayEdit := False;\r\n            end;\r\n          end;\r\n        end;\r\n      end;\r\n  end;\r\n\r\n  if MayEdit and Assigned(FFocusedNode) and (FFocusedNode = HitInfo.HitNode) and\r\n    (FFocusedColumn = HitInfo.HitColumn) and CanEdit(FFocusedNode, HitInfo.HitColumn) then\r\n  begin\r\n    DoStateChange([tsEditPending]);\r\n    FEditColumn := FFocusedColumn;\r\n    SetTimer(Handle, EditTimer, 0, nil);\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.HandleMouseDown(var Message: TWMMouse; var HitInfo: THitInfo);\r\n\r\n// centralized mouse button down handling\r\n\r\nvar\r\n  LastFocused: PVirtualNode;\r\n  Column: TColumnIndex;\r\n  ShiftState: TShiftState;\r\n\r\n  // helper variables to shorten boolean equations/expressions\r\n  AutoDrag,              // automatic (or allowed) drag start\r\n  IsLabelHit,            // the node's caption or images are hit\r\n  IsCellHit,             // for grid extension or full row select (but not check box, button)\r\n  IsAnyHit,              // either IsHit or IsCellHit\r\n  IsHeightTracking,      // height tracking\r\n  MultiSelect,           // multiselection is enabled\r\n  ShiftEmpty,            // ShiftState = []\r\n  NodeSelected: Boolean; // the new node (if any) is selected\r\n  NewColumn: Boolean;    // column changed\r\n  NewNode: Boolean;      // Node changed.\r\n  NeedChange: Boolean;   // change event is required for selection change\r\n  CanClear: Boolean;\r\n  NewCheckState: TCheckState;\r\n  AltPressed: Boolean;   // Pressing the Alt key enables special processing for selection.\r\n  FullRowDrag: Boolean;  // Start dragging anywhere within a node's bound.\r\n  NodeRect: TRect;\r\n\r\nbegin\r\n  if [tsWheelPanning, tsWheelScrolling] * FStates <> [] then\r\n  begin\r\n    StopWheelPanning;\r\n    Exit;\r\n  end;\r\n\r\n  if tsEditPending in FStates then\r\n  begin\r\n    StopTimer(EditTimer);\r\n    DoStateChange([], [tsEditPending]);\r\n  end;\r\n\r\n  if (tsEditing in FStates) then begin\r\n    if not DoEndEdit then\r\n      exit;\r\n  end;//if tsEditing\r\n\r\n  // Focus change. Don't use the SetFocus method as this does not work for MDI Winapi.Windows.\r\n  if not Focused and CanFocus then\r\n  begin\r\n    Winapi.Windows.SetFocus(Handle);\r\n    // Repeat the hit test as an OnExit event might got triggered that could modify the tree.\r\n    GetHitTestInfoAt(Message.XPos, Message.YPos, True, HitInfo);\r\n  end;\r\n\r\n  // Keep clicked column in case the application needs it.\r\n  FHeader.FColumns.FClickIndex := HitInfo.HitColumn;\r\n\r\n  // Change column only if we have hit the node label.\r\n  if (hiOnItemLabel in HitInfo.HitPositions) or\r\n    (toFullRowSelect in FOptions.FSelectionOptions) or\r\n    (toGridExtensions in FOptions.FMiscOptions) then\r\n  begin\r\n    NewColumn := FFocusedColumn <> HitInfo.HitColumn;\r\n    if toExtendedFocus in FOptions.FSelectionOptions then\r\n      Column := HitInfo.HitColumn\r\n    else\r\n      Column := FHeader.MainColumn;\r\n  end\r\n  else\r\n  begin\r\n    NewColumn := False;\r\n    Column := FFocusedColumn;\r\n  end;\r\n\r\n  if NewColumn and not FHeader.AllowFocus(Column) then\r\n  begin\r\n    NewColumn := False;\r\n    Column := FFocusedColumn;\r\n  end;\r\n\r\n  NewNode := FFocusedNode <> HitInfo.HitNode;\r\n\r\n  // Translate keys and filter out shift and control key.\r\n  ShiftState := KeysToShiftState(Message.Keys) * [ssShift, ssCtrl, ssAlt];\r\n  if ssAlt in ShiftState then\r\n  begin\r\n    AltPressed := True;\r\n    // Remove the Alt key from the shift state. It is not meaningful there.\r\n    Exclude(ShiftState, ssAlt);\r\n  end\r\n  else\r\n    AltPressed := False;\r\n\r\n  // Various combinations determine what states the tree enters now.\r\n  // We initialize shorthand variables to avoid the following expressions getting too large\r\n  // and to avoid repeative expensive checks.\r\n  IsLabelHit := not AltPressed and not (toSimpleDrawSelection in FOptions.FSelectionOptions) and\r\n    ((hiOnItemLabel in HitInfo.HitPositions) or (hiOnNormalIcon in HitInfo.HitPositions));\r\n\r\n  IsCellHit := not AltPressed and not IsLabelHit and Assigned(HitInfo.HitNode) and\r\n    ([hiOnItemButton, hiOnItemCheckBox, hiNoWhere] * HitInfo.HitPositions = []) and\r\n    ((toFullRowSelect in FOptions.FSelectionOptions) or\r\n    ((toGridExtensions in FOptions.FMiscOptions) and (HitInfo.HitColumn > NoColumn)));\r\n\r\n  IsAnyHit := IsLabelHit or IsCellHit;\r\n  MultiSelect := toMultiSelect in FOptions.FSelectionOptions;\r\n  ShiftEmpty := ShiftState = [];\r\n  NodeSelected := IsAnyHit and (vsSelected in HitInfo.HitNode.States);\r\n\r\n  // Determine the Drag behavior.\r\n  if MultiSelect and not (toDisableDrawSelection in FOptions.FSelectionOptions) then\r\n  begin\r\n    // We have MultiSelect and want to draw a selection rectangle.\r\n    // We will start a full row drag only in case a label was hit,\r\n    // otherwise a multi selection will start.\r\n    FullRowDrag := (toFullRowDrag in FOptions.FMiscOptions) and IsCellHit and\r\n        not (hiNowhere in HitInfo.HitPositions) and\r\n        (NodeSelected or (hiOnItemLabel in HitInfo.HitPositions) or (hiOnNormalIcon in HitInfo.HitPositions));\r\n  end\r\n  else // No MultiSelect, hence we can start a drag anywhere in the row.\r\n    FullRowDrag := toFullRowDrag in FOptions.FMiscOptions;\r\n\r\n  IsHeightTracking := (Message.Msg = WM_LBUTTONDOWN) and\r\n                      (hiOnItem in HitInfo.HitPositions) and\r\n                      ([hiUpperSplitter, hiLowerSplitter] * HitInfo.HitPositions <> []);\r\n\r\n  // Dragging might be started in the inherited handler manually (which is discouraged for stability reasons)\r\n  // the test for manual mode is done below (after the focused node is set).\r\n  AutoDrag := ((DragMode = dmAutomatic) or Dragging) and (not IsCellHit or FullRowDrag);\r\n\r\n  // Query the application to learn if dragging may start now (if set to dmManual).\r\n  if Assigned(HitInfo.HitNode) and not AutoDrag and (DragMode = dmManual) then\r\n    AutoDrag := DoBeforeDrag(HitInfo.HitNode, Column) and (FullRowDrag or IsLabelHit);\r\n\r\n  // handle node height tracking\r\n  if IsHeightTracking then\r\n  begin\r\n    if hiUpperSplitter in HitInfo.HitPositions then\r\n      FHeightTrackNode := GetPreviousVisible(HitInfo.HitNode, True)\r\n    else\r\n      FHeightTrackNode := HitInfo.HitNode;\r\n\r\n    if CanSplitterResizeNode(Point(Message.XPos, Message.YPos), FHeightTrackNode, HitInfo.HitColumn) then\r\n    begin\r\n      FHeightTrackColumn := HitInfo.HitColumn;\r\n      NodeRect := GetDisplayRect(FHeightTrackNode, FHeightTrackColumn, False);\r\n      FHeightTrackPoint := Point(NodeRect.Left, NodeRect.Top);\r\n      DoStateChange([tsNodeHeightTrackPending]);\r\n      Exit;\r\n    end;\r\n  end;\r\n\r\n  // handle button clicks\r\n  if (hiOnItemButton in HitInfo.HitPositions) and (vsHasChildren in HitInfo.HitNode.States) then\r\n  begin\r\n    ToggleNode(HitInfo.HitNode);\r\n    Exit;\r\n  end;\r\n\r\n  // check event\r\n  if hiOnItemCheckBox in HitInfo.HitPositions then\r\n  begin\r\n    if (FStates * [tsMouseCheckPending, tsKeyCheckPending] = []) and not (vsDisabled in HitInfo.HitNode.States) then\r\n    begin\r\n      with HitInfo.HitNode^ do\r\n        NewCheckState := DetermineNextCheckState(CheckType, CheckState);\r\n      if (ssLeft in KeysToShiftState(Message.Keys)) and DoChecking(HitInfo.HitNode, NewCheckState) then\r\n      begin\r\n        DoStateChange([tsMouseCheckPending]);\r\n        FCheckNode := HitInfo.HitNode;\r\n        FPendingCheckState := NewCheckState;\r\n        FCheckNode.CheckState := PressedState[FCheckNode.CheckState];\r\n        InvalidateNode(HitInfo.HitNode);\r\n      end;\r\n    end;\r\n    Exit;\r\n  end;\r\n\r\n  // Keep this node's level in case we need it for constraint selection.\r\n  if (FRoot.ChildCount > 0) and ShiftEmpty or (FSelectionCount = 0) then\r\n    if Assigned(HitInfo.HitNode) then\r\n      FLastSelectionLevel := GetNodeLevel(HitInfo.HitNode)\r\n    else\r\n      FLastSelectionLevel := GetNodeLevel(GetLastVisibleNoInit(nil, True));\r\n\r\n  // pending clearance\r\n  if MultiSelect and ShiftEmpty and not (hiOnItemCheckbox in HitInfo.HitPositions) and IsAnyHit and AutoDrag and\r\n    NodeSelected and not FSelectionLocked then\r\n    DoStateChange([tsClearPending]);\r\n\r\n  // immediate clearance\r\n  // Determine for the right mouse button if there is a popup menu. In this case and if drag'n drop is pending\r\n  // the current selection has to stay as it is.\r\n  with HitInfo, Message do\r\n    CanClear := not AutoDrag and\r\n      (not (tsRightButtonDown in FStates) or not HasPopupMenu(HitNode, HitColumn, Point(XPos, YPos)));\r\n\r\n  // User starts a selection with a selection rectangle.\r\n  if not (toDisableDrawSelection in FOptions.FSelectionOptions) and not (IsLabelHit or FullRowDrag) and MultiSelect then\r\n  begin\r\n    SetCapture(Handle);\r\n    DoStateChange([tsDrawSelPending]);\r\n    FDrawSelShiftState := ShiftState;\r\n    FNewSelRect := Rect(Message.XPos + FEffectiveOffsetX, Message.YPos - FOffsetY, Message.XPos + FEffectiveOffsetX,\r\n      Message.YPos - FOffsetY);\r\n    FLastSelRect := Rect(0, 0, 0, 0);\r\n  end;\r\n\r\n  if not FSelectionLocked and ((not (IsAnyHit or FullRowDrag) and MultiSelect and ShiftEmpty) or\r\n    (IsAnyHit and (not NodeSelected or (NodeSelected and CanClear)) and (ShiftEmpty or not MultiSelect))) then\r\n  begin\r\n    Assert(not (tsClearPending in FStates), 'Pending and direct clearance are mutual exclusive!');\r\n\r\n    // If the currently hit node was already selected then we have to reselect it again after clearing the current\r\n    // selection, but without a change event if it is the only selected node.\r\n    // The same applies if the Alt key is pressed, which allows to start drawing the selection rectangle also\r\n    // on node captions and images. Here the previous selection state does not matter, though.\r\n    if NodeSelected or (AltPressed and Assigned(HitInfo.HitNode) and (HitInfo.HitColumn = FHeader.MainColumn)) and not (hiNowhere in HitInfo.HitPositions) then\r\n    begin\r\n      NeedChange := FSelectionCount > 1;\r\n      InternalClearSelection;\r\n      InternalAddToSelection(HitInfo.HitNode, True);\r\n      if NeedChange then\r\n      begin\r\n        Invalidate;\r\n        Change(nil);\r\n      end;\r\n    end\r\n    else if not ((hiNowhere in HitInfo.HitPositions) and (toAlwaysSelectNode in Self.TreeOptions.SelectionOptions)) then // When clicking in the free space we don't want the selection to be cleared in case toAlwaysSelectNode is set\r\n      ClearSelection;\r\n  end;\r\n\r\n  // pending node edit\r\n  if Focused and\r\n    ((hiOnItemLabel in HitInfo.HitPositions) or ((toGridExtensions in FOptions.FMiscOptions) and\r\n    (hiOnItem in HitInfo.HitPositions))) and NodeSelected and not NewColumn and ShiftEmpty then\r\n  begin\r\n    DoStateChange([tsEditPending]);\r\n  end;\r\n\r\n  if not (toDisableDrawSelection in FOptions.FSelectionOptions)\r\n    and not (IsLabelHit or FullRowDrag) and (MultiSelect or (hiNowhere in HitInfo.HitPositions)) then\r\n  begin\r\n    // The original code here was moved up to fix issue #187.\r\n    // In order not to break the semantics of this procedure, we are leaving these if statements here\r\n    if not IsCellHit then\r\n      Exit;\r\n  end;\r\n\r\n  // Keep current mouse position.\r\n  FLastClickPos := Point(Message.XPos, Message.YPos);\r\n\r\n  // Handle selection and node focus change.\r\n  if (IsLabelHit or IsCellHit) and\r\n     DoFocusChanging(FFocusedNode, HitInfo.HitNode, FFocusedColumn, Column) then\r\n  begin\r\n    if NewColumn then\r\n    begin\r\n      InvalidateColumn(FFocusedColumn);\r\n      InvalidateColumn(Column);\r\n      FFocusedColumn := Column;\r\n    end;\r\n    if DragKind = dkDock then\r\n    begin\r\n      StopTimer(ScrollTimer);\r\n      DoStateChange([], [tsScrollPending, tsScrolling]);\r\n    end;\r\n    // Get the currently focused node to make multiple multi-selection blocks possible.\r\n    LastFocused := FFocusedNode;\r\n    if NewNode then\r\n      DoFocusNode(HitInfo.HitNode, False);\r\n\r\n    if MultiSelect and not ShiftEmpty then\r\n      HandleClickSelection(LastFocused, HitInfo.HitNode, ShiftState, AutoDrag)\r\n    else\r\n    begin\r\n      if ShiftEmpty then\r\n        FRangeAnchor := HitInfo.HitNode;\r\n\r\n      // If the hit node is not yet selected then do it now.\r\n      if not NodeSelected then\r\n        AddToSelection(HitInfo.HitNode);\r\n    end;\r\n\r\n    if NewNode or NewColumn then\r\n    begin\r\n      ScrollIntoView(FFocusedNode, toCenterScrollIntoView in FOptions.SelectionOptions,\r\n        not (toDisableAutoscrollOnFocus in FOptions.FAutoOptions)\r\n        and not (toFullRowSelect in FOptions.SelectionOptions));\r\n\r\n      DoFocusChange(FFocusedNode, FFocusedColumn);\r\n    end;\r\n  end;\r\n\r\n  // Drag'n drop initiation\r\n  // If we lost focus in the interim the button states would be cleared in WM_KILLFOCUS.\r\n  if AutoDrag and IsAnyHit and (FStates * [tsLeftButtonDown, tsRightButtonDown, tsMiddleButtonDown] <> []) then\r\n    BeginDrag(False);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.HandleMouseUp(var Message: TWMMouse; const HitInfo: THitInfo);\r\n\r\n// Counterpart to the mouse down handler.\r\n\r\nvar\r\n  ReselectFocusedNode: Boolean;\r\n\r\nbegin\r\n  ReleaseCapture;\r\n\r\n  if not (tsVCLDragPending in FStates) then\r\n  begin\r\n    // reset pending or persistent states\r\n    if IsMouseSelecting then\r\n    begin\r\n      DoStateChange([], [tsDrawSelecting, tsDrawSelPending, tsToggleFocusedSelection]);\r\n      Invalidate;\r\n    end;\r\n\r\n    if tsClearPending in FStates then\r\n    begin\r\n      ReselectFocusedNode := Assigned(FFocusedNode) and (vsSelected in FFocusedNode.States);\r\n      ClearSelection;\r\n      if ReselectFocusedNode then\r\n        AddToSelection(FFocusedNode);\r\n    end;\r\n\r\n    if (tsToggleFocusedSelection in FStates) and (HitInfo.HitNode = FFocusedNode) and Assigned(HitInfo.HitNode) then //Prevent AV when dereferencing HitInfo.HitNode below, see bug #100\r\n    begin\r\n      if vsSelected in HitInfo.HitNode.States then\r\n      begin\r\n        if not (toAlwaysSelectNode in TreeOptions.SelectionOptions) or (Self.SelectedCount > 1) then\r\n          RemoveFromSelection(HitInfo.HitNode);\r\n      end\r\n      else\r\n        AddToSelection(HitInfo.HitNode);\r\n      InvalidateNode(HitInfo.HitNode);\r\n    end;\r\n\r\n    DoStateChange([], [tsOLEDragPending, tsOLEDragging, tsClearPending, tsDrawSelPending, tsToggleFocusedSelection,\r\n      tsScrollPending, tsScrolling]);\r\n    StopTimer(ScrollTimer);\r\n\r\n    if tsMouseCheckPending in FStates then\r\n    begin\r\n      DoStateChange([], [tsMouseCheckPending]);\r\n     //  Need check for nil, issue #285\r\n     //  because when mouse down on checkbox but not yet released\r\n     //  and in this time list starts to rebuild by timer\r\n     //  after this when mouse release  FCheckNode equal nil\r\n     if Assigned (FCheckNode) then\r\n     begin\r\n       // Is the mouse still over the same node?\r\n       if (HitInfo.HitNode = FCheckNode) and (hiOnItem in HitInfo.HitPositions) then\r\n          DoCheckClick(FCheckNode, FPendingCheckState)\r\n        else\r\n          FCheckNode.CheckState := UnpressedState[FCheckNode.CheckState];\r\n        InvalidateNode(FCheckNode);\r\n      end;\r\n      FCheckNode := nil;\r\n    end;\r\n\r\n    if (FHeader.FColumns.FClickIndex > NoColumn) and (FHeader.FColumns.FClickIndex = HitInfo.HitColumn) then\r\n      DoColumnClick(HitInfo.HitColumn, KeysToShiftState(Message.Keys));\r\n\r\n    if HitInfo.HitNode <> nil then\r\n     DoNodeClick(HitInfo);\r\n\r\n    // handle a pending edit event\r\n    if tsEditPending in FStates then\r\n    begin\r\n      // Is the mouse still over the same node?\r\n      if (HitInfo.HitNode = FFocusedNode) and (hiOnItem in HitInfo.HitPositions) and\r\n         (toEditOnClick in FOptions.FMiscOptions) and (FFocusedColumn = HitInfo.HitColumn) and\r\n         CanEdit(FFocusedNode, HitInfo.HitColumn) then\r\n      begin\r\n        FEditColumn := FFocusedColumn;\r\n        SetTimer(Handle, EditTimer, FEditDelay, nil);\r\n      end\r\n      else\r\n        DoStateChange([], [tsEditPending]);\r\n    end;\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TBaseVirtualTree.HasImage(Node: PVirtualNode; Kind: TVTImageKind; Column: TColumnIndex): Boolean;\r\n\r\n// Determines whether the given node has got an image of the given kind in the given column.\r\n// Returns True if so, otherwise False.\r\n// The given node will be implicitly initialized if needed.\r\n\r\nvar\r\n  Ghosted: Boolean;\r\n  Index: TImageIndex;\r\n\r\nbegin\r\n  if not (vsInitialized in Node.States) then\r\n    InitNode(Node);\r\n\r\n  Index := -1;\r\n  Ghosted := False;\r\n  DoGetImageIndex(Node, Kind, Column, Ghosted, Index);\r\n  Result := Index > -1;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TBaseVirtualTree.HasPopupMenu(Node: PVirtualNode; Column: TColumnIndex; Pos: TPoint): Boolean;\r\n\r\n// Determines whether the tree got a popup menu, either in its PopupMenu property, via the OnGetPopupMenu event or\r\n// through inheritance. The latter case must be checked by the descendant which must override this method.\r\n\r\nbegin\r\n  Result := Assigned(PopupMenu) or Assigned(DoGetPopupMenu(Node, Column, Pos));\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.InitChildren(Node: PVirtualNode);\r\n\r\n// Initiates the initialization of the child number of the given node.\r\n\r\nvar\r\n  Count: Cardinal;\r\n\r\nbegin\r\n  if Assigned(Node) and (Node <> FRoot) and (vsHasChildren in Node.States) then\r\n  begin\r\n    Count := Node.ChildCount;\r\n    if DoInitChildren(Node, Count) then\r\n    begin\r\n      SetChildCount(Node, Count);\r\n      if Count = 0 then\r\n        Exclude(Node.States, vsHasChildren);\r\n    end;\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.InitNode(Node: PVirtualNode);\r\n\r\n// Initiates the initialization of the given node to allow the application to load needed data for it.\r\n\r\nvar\r\n  InitStates: TVirtualNodeInitStates;\r\n  MustAdjustInternalVariables: Boolean;\r\n\r\nbegin\r\n  with Node^ do\r\n  begin\r\n    Include(States, vsInitializing);\r\n    try\r\n      InitStates := [];\r\n      if vsInitialized in States then\r\n        Include(InitStates, ivsReInit);\r\n      Include(States, vsInitialized);\r\n      if Parent = FRoot then\r\n        DoInitNode(nil, Node, InitStates)\r\n      else\r\n        DoInitNode(Parent, Node, InitStates);\r\n      if ivsDisabled in InitStates then\r\n        Include(States, vsDisabled);\r\n      if ivsHasChildren in InitStates then\r\n        Include(States, vsHasChildren);\r\n      if ivsSelected in InitStates then\r\n      begin\r\n        FSingletonNodeArray[0] := Node;\r\n        InternalAddToSelection(FSingletonNodeArray, 1, False);\r\n      end;\r\n      if ivsMultiline in InitStates then\r\n        Include(States, vsMultiline);\r\n      if ivsFiltered in InitStates then\r\n      begin\r\n        MustAdjustInternalVariables := not ((ivsReInit in InitStates) and (vsFiltered in States));\r\n\r\n        Include(States, vsFiltered);\r\n\r\n        if not (toShowFilteredNodes in FOptions.FPaintOptions) and MustAdjustInternalVariables then\r\n        begin\r\n          AdjustTotalHeight(Node, -NodeHeight, True);\r\n          if FullyVisible[Node] then\r\n            Dec(FVisibleCount);\r\n          if FUpdateCount = 0 then\r\n            UpdateScrollBars(True);\r\n        end;\r\n      end;\r\n\r\n      // Expanded may already be set (when called from ReinitNode) or be set in DoInitNode, allow both.\r\n      if (vsExpanded in Node.States) xor (ivsExpanded in InitStates) then\r\n      begin\r\n        // Expand node if not yet done (this will automatically initialize child nodes).\r\n        if ivsExpanded in InitStates then\r\n          ToggleNode(Node)\r\n        else\r\n          // If the node already was expanded then explicitly trigger child initialization.\r\n          if vsHasChildren in Node.States then\r\n            InitChildren(Node);\r\n      end;\r\n    finally\r\n      Exclude(States, vsInitializing);\r\n    end;\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.InternalAddFromStream(Stream: TStream; Version: Integer; Node: PVirtualNode);\r\n\r\n// Loads all details for Node (including its children) from the given stream.\r\n// Because the new nodes might be selected this method also fixes the selection array.\r\n\r\nvar\r\n  Stop: PVirtualNode;\r\n  Index: Integer;\r\n  LastTotalHeight: Cardinal;\r\n  WasFullyVisible: Boolean;\r\n\r\nbegin\r\n  Assert(Node <> FRoot, 'The root node cannot be loaded from stream.');\r\n\r\n  // Keep the current total height value of Node as it has already been applied\r\n  // but might change in the load and fixup code. We have to adjust that afterwards.\r\n  LastTotalHeight := Node.TotalHeight;\r\n  WasFullyVisible := FullyVisible[Node] and not IsEffectivelyFiltered[Node];\r\n\r\n  // Read in the new nodes.\r\n  ReadNode(Stream, Version, Node);\r\n\r\n  // One time update of node-internal states and the global visibility counter.\r\n  // This is located here to ease and speed up the loading process.\r\n  FixupTotalCount(Node);\r\n  AdjustTotalCount(Node.Parent, Node.TotalCount - 1, True); // -1 because Node itself was already set.\r\n  FixupTotalHeight(Node);\r\n  AdjustTotalHeight(Node.Parent, Node.TotalHeight - LastTotalHeight, True);\r\n\r\n  // New nodes are always visible, so the visible node count has been increased already.\r\n  // If Node is now invisible we have to take back this increment and don't need to add any visible child node.\r\n  if not FullyVisible[Node] or IsEffectivelyFiltered[Node] then\r\n  begin\r\n    if WasFullyVisible then\r\n      Dec(FVisibleCount);\r\n  end\r\n  else\r\n    // It can never happen that the node is now fully visible but was not before as this would require\r\n    // that the visibility state of one of its parents has changed, which cannot happen during loading.\r\n    Inc(FVisibleCount, CountVisibleChildren(Node));\r\n\r\n  // Fix selection array.\r\n  ClearTempCache;\r\n  if Node = FRoot then\r\n    Stop := nil\r\n  else\r\n    Stop := Node.NextSibling;\r\n\r\n  if toMultiSelect in FOptions.FSelectionOptions then\r\n  begin\r\n    // Add all nodes which were selected before to the current selection (unless they are already there).\r\n    while Node <> Stop do\r\n    begin\r\n      if (vsSelected in Node.States) and not FindNodeInSelection(Node, Index, 0, High(FSelection)) then\r\n        InternalCacheNode(Node);\r\n      Node := GetNextNoInit(Node);\r\n    end;\r\n    if FTempNodeCount > 0 then\r\n      AddToSelection(FTempNodeCache, FTempNodeCount, True);\r\n    ClearTempCache;\r\n  end\r\n  else // No further selected nodes allowed so delete the corresponding flag in all new nodes.\r\n    while Node <> Stop do\r\n    begin\r\n      Exclude(Node.States, vsSelected);\r\n      Node := GetNextNoInit(Node);\r\n    end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TBaseVirtualTree.InternalAddToSelection(Node: PVirtualNode; ForceInsert: Boolean): Boolean;\r\n\r\nbegin\r\n  Assert(Assigned(Node), 'Node must not be nil!');\r\n  FSingletonNodeArray[0] := Node;\r\n  Result := InternalAddToSelection(FSingletonNodeArray, 1, ForceInsert);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TBaseVirtualTree.InternalAddToSelection(const NewItems: TNodeArray; NewLength: Integer;\r\n  ForceInsert: Boolean): Boolean;\r\n\r\n// Internal version of method AddToSelection which does not trigger OnChange events\r\n\r\nvar\r\n  I, J: Integer;\r\n  CurrentEnd: Integer;\r\n  Constrained,\r\n  SiblingConstrained: Boolean;\r\n  lPreviousSelectedCount: Integer;\r\nbegin\r\n  lPreviousSelectedCount := FSelectionCount;\r\n  // The idea behind this code is to use a kind of reverse merge sort. QuickSort is quite fast\r\n  // and would do the job here too but has a serious problem with already sorted lists like FSelection.\r\n\r\n  // 1) Remove already selected items, mark all other as being selected.\r\n  if ForceInsert then\r\n  begin\r\n    for I := 0 to NewLength - 1 do\r\n    begin\r\n      Include(NewItems[I].States, vsSelected);\r\n      Inc(FSelectionCount);\r\n      if Assigned(FOnAddToSelection) then\r\n        FOnAddToSelection(Self, NewItems[I]);\r\n    end;\r\n  end\r\n  else\r\n  begin\r\n    Constrained := toLevelSelectConstraint in FOptions.FSelectionOptions;\r\n    if Constrained and (FLastSelectionLevel = -1) then\r\n      FLastSelectionLevel := GetNodeLevel(NewItems[0]);\r\n    SiblingConstrained := toSiblingSelectConstraint in FOptions.FSelectionOptions;\r\n    if SiblingConstrained and (FRangeAnchor = nil) then\r\n      FRangeAnchor := NewItems[0];\r\n\r\n    for I := 0 to NewLength - 1 do\r\n      if ([vsSelected, vsDisabled] * NewItems[I].States <> []) or\r\n         (Constrained and (Cardinal(FLastSelectionLevel) <> GetNodeLevel(NewItems[I]))) or\r\n         (SiblingConstrained and (FRangeAnchor.Parent <> NewItems[I].Parent)) then\r\n        Inc(PAnsiChar(NewItems[I]))\r\n      else\r\n      begin\r\n        Include(NewItems[I].States, vsSelected);\r\n      Inc(FSelectionCount);\r\n      if Assigned(FOnAddToSelection) then\r\n          FOnAddToSelection(Self, NewItems[I]);\r\n      end;\r\n  end;\r\n\r\n  I := PackArray(NewItems, NewLength);\r\n  if I > -1 then\r\n    NewLength := I;\r\n\r\n  Result := NewLength > 0;\r\n  if Result then\r\n  begin\r\n    // 2) Sort the new item list so we can easily traverse it.\r\n    if NewLength > 1 then\r\n      QuickSort(NewItems, 0, NewLength - 1);\r\n    // 3) Make room in FSelection for the new items.\r\n    if lPreviousSelectedCount + NewLength >= Length(FSelection) then\r\n      SetLength(FSelection, lPreviousSelectedCount + NewLength);\r\n\r\n    // 4) Merge in new items\r\n    J := NewLength - 1;\r\n    CurrentEnd := lPreviousSelectedCount - 1;\r\n\r\n    while J >= 0 do\r\n    begin\r\n      // First insert all new entries which are greater than the greatest entry in the old list.\r\n      // If the current end marker is < 0 then there's nothing more to move in the selection\r\n      // array and only the remaining new items must be inserted.\r\n      if CurrentEnd >= 0 then\r\n      begin\r\n        while (J >= 0) and (PAnsiChar(NewItems[J]) > PAnsiChar(FSelection[CurrentEnd])) do\r\n        begin\r\n          FSelection[CurrentEnd + J + 1] := NewItems[J];\r\n          Dec(J);\r\n        end;\r\n        // early out if nothing more needs to be copied\r\n        if J < 0 then\r\n          Break;\r\n      end\r\n      else\r\n      begin\r\n        // insert remaining new entries at position 0\r\n        Move(NewItems[0], FSelection[0], (J + 1) * SizeOf(Pointer));\r\n        // nothing more to do so exit main loop\r\n        Break;\r\n      end;\r\n\r\n      // find the last entry in the remaining selection list which is smaller then the largest\r\n      // entry in the remaining new items list\r\n      FindNodeInSelection(NewItems[J], I, 0, CurrentEnd);\r\n      Dec(I);\r\n      // move all entries which are greater than the greatest entry in the new items list up\r\n      // so the remaining gap travels down to where new items must be inserted\r\n      Move(FSelection[I + 1], FSelection[I + J + 2], (CurrentEnd - I) * SizeOf(Pointer));\r\n      CurrentEnd := I;\r\n    end;\r\n\r\n    Assert(FSelectionCount = (lPreviousSelectedCount + NewLength), 'Fixing issue #487 seems to ahve caused a problem here.')\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.InternalCacheNode(Node: PVirtualNode);\r\n\r\n// Adds the given node to the temporary node cache (used when collecting possibly large amounts of nodes).\r\n\r\nvar\r\n  Len: Cardinal;\r\n\r\nbegin\r\n  Len := Length(FTempNodeCache);\r\n  if FTempNodeCount = Len then\r\n  begin\r\n    if Len < 100 then\r\n      Len := 100\r\n    else\r\n      Len := Len + Len div 10;\r\n    SetLength(FTempNodeCache, Len);\r\n  end;\r\n  FTempNodeCache[FTempNodeCount] := Node;\r\n  Inc(FTempNodeCount);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.InternalClearSelection;\r\n\r\nvar\r\n  Count: Integer;\r\n\r\nbegin\r\n  // It is possible that there are invalid node references in the selection array\r\n  // if the tree update is locked and changes in the structure were made.\r\n  // Handle this potentially dangerous situation by packing the selection array explicitely.\r\n  if FUpdateCount > 0 then\r\n  begin\r\n    Count := PackArray(FSelection, FSelectionCount);\r\n    if Count > -1 then\r\n    begin\r\n      FSelectionCount := Count;\r\n      SetLength(FSelection, FSelectionCount);\r\n    end;\r\n  end;\r\n\r\n  while FSelectionCount > 0 do\r\n  begin\r\n    Dec(FSelectionCount);\r\n    Exclude(FSelection[FSelectionCount].States, vsSelected);\r\n    DoRemoveFromSelection(FSelection[FSelectionCount]);\r\n  end;\r\n  ResetRangeAnchor;\r\n  FSelection := nil;\r\n  DoStateChange([], [tsClearPending]);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.InternalConnectNode(Node, Destination: PVirtualNode; Target: TBaseVirtualTree;\r\n  Mode: TVTNodeAttachMode);\r\n\r\n// Connects Node with Destination depending on Mode.\r\n// No error checking takes place. Node as well as Destination must be valid. Node must never be a root node and\r\n// Destination must not be a root node if Mode is amInsertBefore or amInsertAfter.\r\n\r\nvar\r\n  Run: PVirtualNode;\r\n\r\nbegin\r\n  // Keep in mind that the destination node might belong to another tree.\r\n  with Target do\r\n  begin\r\n    case Mode of\r\n      amInsertBefore:\r\n        begin\r\n          Node.PrevSibling := Destination.PrevSibling;\r\n          Destination.PrevSibling := Node;\r\n          Node.NextSibling := Destination;\r\n          Node.Parent := Destination.Parent;\r\n          Node.Index := Destination.Index;\r\n          if Node.PrevSibling = nil then\r\n            Node.Parent.FirstChild := Node\r\n          else\r\n            Node.PrevSibling.NextSibling := Node;\r\n\r\n          // reindex all following nodes\r\n          Run := Destination;\r\n          while Assigned(Run) do\r\n          begin\r\n            Inc(Run.Index);\r\n            Run := Run.NextSibling;\r\n          end;\r\n        end;\r\n      amInsertAfter:\r\n        begin\r\n          Node.NextSibling := Destination.NextSibling;\r\n          Destination.NextSibling := Node;\r\n          Node.PrevSibling := Destination;\r\n          Node.Parent := Destination.Parent;\r\n          if Node.NextSibling = nil then\r\n            Node.Parent.LastChild := Node\r\n          else\r\n            Node.NextSibling.PrevSibling := Node;\r\n          Node.Index := Destination.Index;\r\n\r\n          // reindex all following nodes\r\n          Run := Node;\r\n          while Assigned(Run) do\r\n          begin\r\n            Inc(Run.Index);\r\n            Run := Run.NextSibling;\r\n          end;\r\n        end;\r\n      amAddChildFirst:\r\n        begin\r\n          if Assigned(Destination.FirstChild) then\r\n          begin\r\n            // If there's a first child then there must also be a last child.\r\n            Destination.FirstChild.PrevSibling := Node;\r\n            Node.NextSibling := Destination.FirstChild;\r\n            Destination.FirstChild := Node;\r\n          end\r\n          else\r\n          begin\r\n            // First child node at this location.\r\n            Destination.FirstChild := Node;\r\n            Destination.LastChild := Node;\r\n            Node.NextSibling := nil;\r\n          end;\r\n          Node.PrevSibling := nil;\r\n          Node.Parent := Destination;\r\n          Node.Index := 0;\r\n          // reindex all following nodes\r\n          Run := Node.NextSibling;\r\n          while Assigned(Run) do\r\n          begin\r\n            Inc(Run.Index);\r\n            Run := Run.NextSibling;\r\n          end;\r\n        end;\r\n      amAddChildLast:\r\n        begin\r\n          if Assigned(Destination.LastChild) then\r\n          begin\r\n            // If there's a last child then there must also be a first child.\r\n            Destination.LastChild.NextSibling := Node;\r\n            Node.PrevSibling := Destination.LastChild;\r\n            Destination.LastChild := Node;\r\n          end\r\n          else\r\n          begin\r\n            // first child node at this location\r\n            Destination.FirstChild := Node;\r\n            Destination.LastChild := Node;\r\n            Node.PrevSibling := nil;\r\n          end;\r\n          Node.NextSibling := nil;\r\n          Node.Parent := Destination;\r\n          if Assigned(Node.PrevSibling) then\r\n            Node.Index := Node.PrevSibling.Index + 1\r\n          else\r\n            Node.Index := 0;\r\n        end;\r\n    else\r\n      // amNoWhere: do nothing\r\n    end;\r\n    // Remove temporary states.\r\n    Node.States := Node.States - [vsChecking, vsCutOrCopy, vsDeleting, vsReleaseCallOnUserDataRequired];\r\n\r\n    if (Mode <> amNoWhere) then begin\r\n      Inc(Node.Parent.ChildCount);\r\n      Include(Node.Parent.States, vsHasChildren);\r\n      AdjustTotalCount(Node.Parent, Node.TotalCount, True);\r\n\r\n      // Add the new node's height only if its parent is expanded.\r\n      if (vsExpanded in Node.Parent.States) and (vsVisible in Node.States) then begin\r\n        AdjustTotalHeight(Node.Parent, Node.TotalHeight, True);\r\n        Inc(FVisibleCount, CountVisibleChildren(Node) + Cardinal(IfThen(IsEffectivelyVisible[Node], 1)));\r\n      end;//if\r\n\r\n      // Update the hidden children flag of the parent.\r\n      if (Node.Parent <> FRoot) then\r\n      begin\r\n        // If we have added a visible node then simply remove the all-children-hidden flag.\r\n        if IsEffectivelyVisible[Node] then\r\n          Exclude(Node.Parent.States, vsAllChildrenHidden)\r\n        else begin\r\n          // If we have added an invisible node and this is the only child node then\r\n          // make sure the all-children-hidden flag is in a determined state.\r\n          // If there were child nodes before then no action is needed.\r\n          if Node.Parent.ChildCount = 1 then\r\n            Include(Node.Parent.States, vsAllChildrenHidden);\r\n        end;//else\r\n      end; //if Node.Parent <> FRoot\r\n    end;//if Mode <> amNoWhere\r\n  end;//With\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TBaseVirtualTree.InternalData(Node: PVirtualNode): Pointer;\r\n\r\nbegin\r\n  Result := nil;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.InternalDisconnectNode(Node: PVirtualNode; KeepFocus: Boolean; Reindex: Boolean = True; ParentClearing: Boolean = False);\r\n\r\n// Disconnects the given node from its parent and siblings. The node's pointer are not reset so they can still be used\r\n// after return from this method (probably a very short time only!).\r\n// If KeepFocus is True then the focused node is not reset. This is useful if the given node is reconnected to the tree\r\n// immediately after return of this method and should stay being the focused node if it was it before.\r\n// Note: Node must not be nil or the root node.\r\n\r\nvar\r\n  Parent,\r\n  Run: PVirtualNode;\r\n  Index: Integer;\r\n  AdjustHeight: Boolean;\r\n\r\nbegin\r\n  Assert(Assigned(Node) and (Node <> FRoot), 'Node must neither be nil nor the root node.');\r\n\r\n  if (Node = FFocusedNode) and not KeepFocus then\r\n  begin\r\n    DoFocusNode(nil, False);\r\n    DoFocusChange(FFocusedNode, FFocusedColumn);\r\n  end;\r\n\r\n  if Node = FRangeAnchor then\r\n    ResetRangeAnchor;\r\n\r\n  // Update the hidden children flag of the parent.\r\n  if (Node.Parent <> FRoot) and not (ParentClearing) then\r\n    if FUpdateCount = 0 then\r\n      DetermineHiddenChildrenFlag(Node.Parent)\r\n    else\r\n      Include(FStates, tsUpdateHiddenChildrenNeeded);\r\n\r\n  if not (vsDeleting in Node.States) then\r\n  begin\r\n    // Some states are only temporary so take them out.\r\n    Node.States := Node.States - [vsChecking];\r\n    Parent := Node.Parent;\r\n    Dec(Parent.ChildCount);\r\n    AdjustHeight := (vsExpanded in Parent.States) and (vsVisible in Node.States);\r\n    if Parent.ChildCount = 0 then\r\n    begin\r\n      Parent.States := Parent.States - [vsAllChildrenHidden, vsHasChildren];\r\n      if (Parent <> FRoot) and (vsExpanded in Parent.States) then\r\n        Exclude(Parent.States, vsExpanded);\r\n    end;\r\n    AdjustTotalCount(Parent, -Integer(Node.TotalCount), True);\r\n    if AdjustHeight then\r\n      AdjustTotalHeight(Parent, -Integer(Node.TotalHeight), True);\r\n    if FullyVisible[Node] then\r\n      Dec(FVisibleCount, CountVisibleChildren(Node) + Cardinal(IfThen(IsEffectivelyVisible[Node], 1)));\r\n\r\n    if Assigned(Node.PrevSibling) then\r\n      Node.PrevSibling.NextSibling := Node.NextSibling\r\n    else\r\n      Parent.FirstChild := Node.NextSibling;\r\n\r\n    if Assigned(Node.NextSibling) then\r\n    begin\r\n      Node.NextSibling.PrevSibling := Node.PrevSibling;\r\n      // Reindex all following nodes.\r\n      if Reindex then\r\n      begin\r\n        Run := Node.NextSibling;\r\n        Index := Node.Index;\r\n        while Assigned(Run) do\r\n        begin\r\n          Run.Index := Index;\r\n          Inc(Index);\r\n          Run := Run.NextSibling;\r\n        end;\r\n      end;\r\n    end\r\n    else\r\n      Parent.LastChild := Node.PrevSibling;\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.InternalRemoveFromSelection(Node: PVirtualNode);\r\n\r\n// Special version to mark a node to be no longer in the current selection. PackArray must\r\n// be used to remove finally those entries.\r\n\r\nvar\r\n  Index: Integer;\r\n\r\nbegin\r\n  // Because pointers are always DWORD aligned we can simply increment all those\r\n  // which we want to have removed (see also PackArray) and still have the\r\n  // order in the list preserved.\r\n  if FindNodeInSelection(Node, Index, -1, -1) then\r\n  begin\r\n    Exclude(Node.States, vsSelected);\r\n    Inc(PAnsiChar(FSelection[Index]));\r\n    DoRemoveFromSelection(Node);\r\n    AdviseChangeEvent(False, Node, crIgnore);\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.InvalidateCache;\r\n\r\n// Marks the cache as invalid.\r\n\r\nbegin\r\n  DoStateChange([tsValidationNeeded], [tsUseCache]);\r\n  //ChangeTreeStatesAsync([csValidationNeeded], [csUseCache]);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.MarkCutCopyNodes;\r\n\r\n// Sets the vsCutOrCopy style in every currently selected but not disabled node to indicate it is\r\n// now part of a clipboard operation.\r\n\r\nvar\r\n  Nodes: TNodeArray;\r\n  I: Integer;\r\n\r\nbegin\r\n  Nodes := nil;\r\n  if FSelectionCount > 0 then\r\n  begin\r\n    // need the current selection sorted to exclude selected nodes which are children, grandchildren etc. of\r\n    // already selected nodes\r\n    Nodes := GetSortedSelection(False);\r\n    for I := 0 to High(Nodes) do\r\n      with Nodes[I]^ do\r\n        if not (vsDisabled in States) then\r\n          Include(States, vsCutOrCopy);\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.Loaded;\r\n\r\nvar\r\n  LastRootCount: Cardinal;\r\n  IsReadOnly: Boolean;\r\n\r\nbegin\r\n  inherited;\r\n\r\n  // Call RegisterDragDrop after all visual inheritance changes to MiscOptions have been applied.\r\n  if not (csDesigning in ComponentState) and (toAcceptOLEDrop in FOptions.FMiscOptions) then\r\n    if HandleAllocated then\r\n      RegisterDragDrop(Handle, DragManager as IDropTarget);\r\n\r\n  // If a root node count has been set during load of the tree then update its child structure now\r\n  // as this hasn't been done yet in this case.\r\n  if (tsNeedRootCountUpdate in FStates) and (FRoot.ChildCount > 0) then\r\n  begin\r\n    DoStateChange([], [tsNeedRootCountUpdate]);\r\n    IsReadOnly := toReadOnly in FOptions.FMiscOptions;\r\n    Exclude(FOptions.FMiscOptions, toReadOnly);\r\n    LastRootCount := FRoot.ChildCount;\r\n    FRoot.ChildCount := 0;\r\n    BeginUpdate;\r\n    SetChildCount(FRoot, LastRootCount);\r\n    EndUpdate;\r\n    if IsReadOnly then\r\n      Include(FOptions.FMiscOptions, toReadOnly);\r\n  end;\r\n\r\n  // Prevent the object inspector at design time from marking the header as being modified\r\n  // when auto resize is enabled.\r\n  Updating;\r\n  try\r\n    FHeader.UpdateMainColumn;\r\n    FHeader.FColumns.FixPositions;\r\n    if toAutoBidiColumnOrdering in FOptions.FAutoOptions then\r\n      FHeader.FColumns.ReorderColumns(UseRightToLeftAlignment);\r\n    // Because of the special recursion and update stopper when creating the window (or resizing it)\r\n    // we have to manually trigger the auto size calculation here.\r\n    if hsNeedScaling in FHeader.FStates then\r\n      FHeader.RescaleHeader\r\n    else\r\n      FHeader.RecalculateHeader;\r\n    if hoAutoResize in FHeader.FOptions then\r\n      FHeader.FColumns.AdjustAutoSize(InvalidColumn, True);\r\n  finally\r\n    Updated;\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.MainColumnChanged;\r\n\r\nbegin\r\n  DoCancelEdit;\r\n\r\n  if Assigned(FAccessibleItem) then\r\n    NotifyWinEvent(EVENT_OBJECT_NAMECHANGE, Handle, OBJID_CLIENT, CHILDID_SELF);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.MouseMove(Shift: TShiftState; X, Y: Integer);\r\n\r\nvar\r\n  R: TRect;\r\n\r\nbegin\r\n  if tsNodeHeightTrackPending in FStates then\r\n  begin\r\n    // Remove hint if shown currently.\r\n    Application.CancelHint;\r\n\r\n    // Stop wheel panning if active.\r\n    StopWheelPanning;\r\n\r\n    // Stop timers\r\n    StopTimer(ExpandTimer);\r\n    StopTimer(EditTimer);\r\n    StopTimer(HeaderTimer);\r\n    StopTimer(ScrollTimer);\r\n    StopTimer(SearchTimer);\r\n    FSearchBuffer := '';\r\n    FLastSearchNode := nil;\r\n\r\n    DoStateChange([tsNodeHeightTracking], [tsScrollPending, tsScrolling, tsEditPending, tsOLEDragPending, tsVCLDragPending,\r\n      tsIncrementalSearching, tsNodeHeightTrackPending]);\r\n  end;\r\n\r\n  if tsDrawSelPending in FStates then\r\n  begin\r\n    // Remove current selection in case the user clicked somewhere in the window (but not a node)\r\n    // and moved the mouse.\r\n    if CalculateSelectionRect(X, Y) then\r\n    begin\r\n      InvalidateRect(Handle, @FNewSelRect, False);\r\n      UpdateWindow(Handle);\r\n      if (Abs(FNewSelRect.Right - FNewSelRect.Left) > Mouse.DragThreshold) or\r\n         (Abs(FNewSelRect.Bottom - FNewSelRect.Top) > Mouse.DragThreshold) then\r\n      begin\r\n        if tsClearPending in FStates then\r\n        begin\r\n          DoStateChange([], [tsClearPending]);\r\n          ClearSelection;\r\n        end;\r\n        DoStateChange([tsDrawSelecting], [tsDrawSelPending]);\r\n\r\n        // Reset to main column for multiselection.\r\n        FocusedColumn := FHeader.MainColumn;\r\n\r\n        // The current rectangle may already include some node captions. Handle this.\r\n        if HandleDrawSelection(X, Y) then\r\n          InvalidateRect(Handle, nil, False);\r\n      end;\r\n    end;\r\n  end\r\n  else\r\n  begin\r\n    if tsNodeHeightTracking in FStates then\r\n    begin\r\n      // Handle height tracking.\r\n      if DoNodeHeightTracking(FHeightTrackNode, FHeightTrackColumn, FHeader.GetShiftState,\r\n        FHeightTrackPoint, Point(X, Y)) then\r\n      begin\r\n        // Avoid negative (or zero) node heights.\r\n        if FHeightTrackPoint.Y >= Y then\r\n          Y := FHeightTrackPoint.Y + 1;\r\n        SetNodeHeight(FHeightTrackNode, Y - FHeightTrackPoint.Y);\r\n        UpdateWindow(Handle);\r\n        Exit;\r\n      end;\r\n    end;\r\n\r\n    // If both wheel panning and auto scrolling are pending then the user moved the mouse while holding down the\r\n    // middle mouse button. This means panning is being used, hence remove the wheel scroll flag.\r\n    if [tsWheelPanning, tsWheelScrolling] * FStates = [tsWheelPanning, tsWheelScrolling] then\r\n    begin\r\n      if ((Abs(FLastClickPos.X - X) >= Mouse.DragThreshold) or (Abs(FLastClickPos.Y - Y) >= Mouse.DragThreshold)) then\r\n        DoStateChange([], [tsWheelScrolling]);\r\n    end;\r\n\r\n    // Really start dragging if the mouse has been moved more than the threshold.\r\n    if (tsOLEDragPending in FStates) and ((Abs(FLastClickPos.X - X) >= FDragThreshold) or\r\n       (Abs(FLastClickPos.Y - Y) >= FDragThreshold)) then\r\n      DoDragging(FLastClickPos)\r\n    else\r\n    begin\r\n      if CanAutoScroll then\r\n        DoAutoScroll(X, Y);\r\n      if [tsWheelPanning, tsWheelScrolling] * FStates <> [] then\r\n        AdjustPanningCursor(X, Y);\r\n      if not IsMouseSelecting then\r\n      begin\r\n        HandleHotTrack(X, Y);\r\n        inherited MouseMove(Shift, X, Y);\r\n      end\r\n      else\r\n      begin\r\n        // Handle draw selection if required, but don't do the work twice if the\r\n        // auto scrolling code already cares about the selection.\r\n        if not (tsScrolling in FStates) and CalculateSelectionRect(X, Y) then\r\n        begin\r\n          // If something in the selection changed then invalidate the entire\r\n          // tree instead trying to figure out the display rects of all changed nodes.\r\n          if HandleDrawSelection(X, Y) then\r\n            InvalidateRect(Handle, nil, False)\r\n          else\r\n          begin\r\n            UnionRect(R, OrderRect(FNewSelRect), OrderRect(FLastSelRect));\r\n            OffsetRect(R, -FEffectiveOffsetX, FOffsetY);\r\n            InvalidateRect(Handle, @R, False);\r\n          end;\r\n          UpdateWindow(Handle);\r\n        end;\r\n      end;\r\n    end;\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.Notification(AComponent: TComponent; Operation: TOperation);\r\n\r\nbegin\r\n  if (AComponent <> Self) and (Operation = opRemove) then\r\n  begin\r\n    // Check for components linked to the tree.\r\n    if AComponent = FImages then\r\n    begin\r\n      Images := nil;\r\n      if not (csDestroying in ComponentState) then\r\n        Invalidate;\r\n    end\r\n    else\r\n      if AComponent = FStateImages then\r\n      begin\r\n        StateImages := nil;\r\n        if not (csDestroying in ComponentState) then\r\n          Invalidate;\r\n      end\r\n      else\r\n        if AComponent = FCustomCheckImages then\r\n        begin\r\n          CustomCheckImages := nil;\r\n          FCheckImageKind := ckSystemDefault;\r\n          if not (csDestroying in ComponentState) then\r\n            Invalidate;\r\n        end\r\n        else\r\n          if AComponent = PopupMenu then\r\n            PopupMenu := nil\r\n          else\r\n            // Check for components linked to the header.\r\n            if Assigned(FHeader) then\r\n            begin\r\n              if AComponent = FHeader.FImages then\r\n                FHeader.Images := nil\r\n              else\r\n                if AComponent = FHeader.PopupMenu then\r\n                  FHeader.PopupMenu := nil;\r\n            end;\r\n  end;\r\n  inherited;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.OriginalWMNCPaint(DC: HDC);\r\n\r\n// Unfortunately, the painting for the non-client area in TControl is not always correct and does also not consider\r\n// existing clipping regions, so it has been modified here to take this into account.\r\n\r\nconst\r\n  InnerStyles: array[TBevelCut] of Integer = (0, BDR_SUNKENINNER, BDR_RAISEDINNER, 0);\r\n  OuterStyles: array[TBevelCut] of Integer = (0, BDR_SUNKENOUTER, BDR_RAISEDOUTER, 0);\r\n  EdgeStyles: array[TBevelKind] of Integer = (0, 0, BF_SOFT, BF_FLAT);\r\n  Ctl3DStyles: array[Boolean] of Integer = (BF_MONO, 0);\r\n\r\nvar\r\n  RC, RW: TRect;\r\n  EdgeSize: Integer;\r\n  Size: TSize;\r\n\r\nbegin\r\n  if (BevelKind <> bkNone) or (BorderWidth > 0) then\r\n  begin\r\n    RC := Rect(0, 0, Width, Height);\r\n    Size := GetBorderDimensions;\r\n    InflateRect(RC, Size.cx, Size.cy);\r\n\r\n    RW := RC;\r\n\r\n    if BevelKind <> bkNone then\r\n    begin\r\n      DrawEdge(DC, RC, InnerStyles[BevelInner] or OuterStyles[BevelOuter], Byte(BevelEdges) or EdgeStyles[BevelKind] or\r\n        Ctl3DStyles[Ctl3D]);\r\n\r\n      EdgeSize := 0;\r\n      if BevelInner <> bvNone then\r\n        Inc(EdgeSize, BevelWidth);\r\n      if BevelOuter <> bvNone then\r\n        Inc(EdgeSize, BevelWidth);\r\n      with TWithSafeRect(RC) do\r\n      begin\r\n        if beLeft in BevelEdges then\r\n          Inc(Left, EdgeSize);\r\n        if beTop in BevelEdges then\r\n          Inc(Top, EdgeSize);\r\n        if beRight in BevelEdges then\r\n          Dec(Right, EdgeSize);\r\n        if beBottom in BevelEdges then\r\n          Dec(Bottom, EdgeSize);\r\n      end;\r\n    end;\r\n\r\n    // Repaint only the part in the original clipping region and not yet drawn parts.\r\n    IntersectClipRect(DC, RC.Left, RC.Top, RC.Right, RC.Bottom);\r\n\r\n    // Determine inner rectangle to exclude (RC corresponds then to the client area).\r\n    InflateRect(RC, -Integer(BorderWidth), -Integer(BorderWidth));\r\n\r\n    // Remove the inner rectangle.\r\n    ExcludeClipRect(DC, RC.Left, RC.Top, RC.Right, RC.Bottom);\r\n\r\n    // Erase parts not drawn.\r\n    Brush.Color := FColors.BorderColor;\r\n    Winapi.Windows.FillRect(DC, RW, Brush.Handle);\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.Paint;\r\n\r\n// Window paint routine. Used when the tree window needs to be updated.\r\n\r\nvar\r\n  Window: TRect;\r\n  Target: TPoint;\r\n  Temp: Integer;\r\n  Options: TVTInternalPaintOptions;\r\n  RTLOffset: Integer;\r\n\r\nbegin\r\n\r\n  Options := [poBackground, poColumnColor, poDrawFocusRect, poDrawDropMark, poDrawSelection, poGridLines];\r\n  if UseRightToLeftAlignment and FHeader.UseColumns then\r\n    RTLOffset := ComputeRTLOffset(True)\r\n  else\r\n    RTLOffset := 0;\r\n\r\n  // The update rect has already been filled in WMPaint, as it is the window's update rect, which gets\r\n  // reset when BeginPaint is called (in the ancestor).\r\n  // The difference to the DC's clipbox is that it is also valid with internal paint operations used\r\n  // e.g. by the Explorer while dragging, but show window content while dragging is disabled.\r\n  if not IsRectEmpty(FUpdateRect) then\r\n  begin\r\n    Temp := Header.Columns.GetVisibleFixedWidth;\r\n    if Temp = 0 then\r\n    begin\r\n      Window := FUpdateRect;\r\n      Target := Window.TopLeft;\r\n\r\n      // The clipping rectangle is given in client coordinates of the window. We have to convert it into\r\n      // a sliding window of the tree image.\r\n      OffsetRect(Window, FEffectiveOffsetX - RTLOffset, -FOffsetY);\r\n      PaintTree(Canvas, Window, Target, Options);\r\n    end\r\n    else\r\n    begin\r\n      // First part, fixed columns\r\n      Window := ClientRect;\r\n      Window.Right := Temp;\r\n      Target := Window.TopLeft;\r\n\r\n      OffsetRect(Window,  -RTLOffset, -FOffsetY);\r\n      PaintTree(Canvas, Window, Target, Options);\r\n\r\n      // Second part, other columns\r\n      Window := GetClientRect;\r\n\r\n      if Temp > Window.Right then\r\n        Exit;\r\n\r\n      Window.Left := Temp;\r\n      Target := Window.TopLeft;\r\n\r\n      OffsetRect(Window, FEffectiveOffsetX - RTLOffset, -FOffsetY);\r\n      PaintTree(Canvas, Window, Target, Options);\r\n    end;\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.PaintCheckImage(Canvas: TCanvas; const ImageInfo: TVTImageInfo; Selected: Boolean);\r\n\r\nvar\r\n  ForegroundColor: COLORREF;\r\n  R: TRect;\r\n  Details: TThemedElementDetails;\r\n  lSize: TSize;\r\nbegin\r\n  with ImageInfo do\r\n  begin\r\n    if (tsUseThemes in FStates) and (FCheckImageKind = ckSystemDefault) then\r\n    begin\r\n      Details.Element := teButton;\r\n      case Index of\r\n        // ctRadioButton\r\n        1 : Details := StyleServices.GetElementDetails(tbRadioButtonUncheckedNormal);\r\n        2 : Details := StyleServices.GetElementDetails(tbRadioButtonUncheckedHot);\r\n        3 : Details := StyleServices.GetElementDetails(tbRadioButtonUncheckedPressed);\r\n        4 : Details := StyleServices.GetElementDetails(tbRadioButtonUncheckedDisabled);\r\n        5 : Details := StyleServices.GetElementDetails(tbRadioButtonCheckedNormal);\r\n        6 : Details := StyleServices.GetElementDetails(tbRadioButtonCheckedHot);\r\n        7 : Details := StyleServices.GetElementDetails(tbRadioButtonCheckedPressed);\r\n        8 : Details := StyleServices.GetElementDetails(tbRadioButtonCheckedDisabled);\r\n       // ct(TriState)CheckBox\r\n        9 : Details := StyleServices.GetElementDetails(tbCheckBoxUncheckedNormal);\r\n       10 : Details := StyleServices.GetElementDetails(tbCheckBoxUncheckedHot);\r\n       11 : Details := StyleServices.GetElementDetails(tbCheckBoxUncheckedPressed);\r\n       12 : Details := StyleServices.GetElementDetails(tbCheckBoxUncheckedDisabled);\r\n       13 : Details := StyleServices.GetElementDetails(tbCheckBoxCheckedNormal);\r\n       14 : Details := StyleServices.GetElementDetails(tbCheckBoxCheckedHot);\r\n       15 : Details := StyleServices.GetElementDetails(tbCheckBoxCheckedPressed);\r\n       16 : Details := StyleServices.GetElementDetails(tbCheckBoxCheckedDisabled);\r\n       17 : Details := StyleServices.GetElementDetails(tbCheckBoxMixedNormal);\r\n       18 : Details := StyleServices.GetElementDetails(tbCheckBoxMixedHot);\r\n       19 : Details := StyleServices.GetElementDetails(tbCheckBoxMixedPressed);\r\n       20 : Details := StyleServices.GetElementDetails(tbCheckBoxMixedDisabled);\r\n       // ctButton\r\n       21 : Details := StyleServices.GetElementDetails(tbPushButtonNormal);\r\n       22 : Details := StyleServices.GetElementDetails(tbPushButtonHot);\r\n       23 : Details := StyleServices.GetElementDetails(tbPushButtonPressed);\r\n       24 : Details := StyleServices.GetElementDetails(tbPushButtonDisabled);\r\n      else\r\n        Details := StyleServices.GetElementDetails(tbButtonRoot);\r\n      end;\r\n      StyleServices.GetElementSize(Canvas.Handle, Details, TElementSize.esActual, lSize);\r\n      R := Rect(XPos, YPos, XPos + lSize.cx, YPos + lSize.cy);\r\n      StyleServices.DrawElement(Canvas.Handle, Details, R);\r\n      if Index in [21..24] then\r\n        UtilityImages.Draw(Canvas, XPos, YPos, 4);\r\n    end\r\n    else\r\n      with FCheckImages do\r\n      begin\r\n        if Selected and not Ghosted then\r\n        begin\r\n          if Focused or (toPopupMode in FOptions.FPaintOptions) then\r\n            ForegroundColor := ColorToRGB(FColors.FocusedSelectionColor)\r\n          else\r\n            ForegroundColor := ColorToRGB(FColors.UnfocusedSelectionColor);\r\n        end\r\n        else\r\n          ForegroundColor := GetRGBColor(BlendColor);\r\n\r\n          ImageList_DrawEx(Handle, Index, Canvas.Handle, XPos, YPos, 0, 0, GetRGBColor(BkColor), ForegroundColor,\r\n            ILD_TRANSPARENT);\r\n      end;\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\n\r\nprocedure TBaseVirtualTree.PaintImage(var PaintInfo: TVTPaintInfo; ImageInfoIndex: TVTImageInfoIndex; DoOverlay: Boolean);\r\nconst\r\n  Style: array[TImageType] of Cardinal = (0, ILD_MASK);\r\nvar\r\n  ExtraStyle: Cardinal;\r\n  CutNode: Boolean;\r\n  PaintFocused: Boolean;\r\n  DrawEnabled: Boolean;\r\n\r\nbegin\r\n  with PaintInfo do\r\n  begin\r\n    CutNode := (vsCutOrCopy in Node.States) and (tsCutPending in FStates);\r\n    PaintFocused := Focused or (toGhostedIfUnfocused in FOptions.FPaintOptions);\r\n\r\n    // Since the overlay image must be specified together with the image to draw\r\n    // it is meaningfull to retrieve it in advance.\r\n    if DoOverlay then begin\r\n      GetImageIndex(PaintInfo, ikOverlay, iiOverlay, Images);\r\n      // If the overlay image is the same as the normal image, don't paint it.\r\n      // Users often forgot to respect the Kind parameter and ended up opening bugs.\r\n      if PaintInfo.ImageInfo[iiOverlay].Equals(PaintInfo.ImageInfo[iiNormal]) then\r\n        PaintInfo.ImageInfo[iiOverlay].Index := -1;\r\n    end\r\n    else\r\n      PaintInfo.ImageInfo[iiOverlay].Index := -1;\r\n\r\n    DrawEnabled := not (vsDisabled in Node.States) and Enabled;\r\n    with ImageInfo[ImageInfoIndex] do\r\n    begin\r\n       if (vsSelected in Node.States) and not(Ghosted or CutNode) then\r\n      begin\r\n        if PaintFocused or (toPopupMode in FOptions.FPaintOptions) then\r\n          Images.BlendColor := FColors.FocusedSelectionColor\r\n        else\r\n          Images.BlendColor := FColors.UnfocusedSelectionColor;\r\n      end\r\n      else\r\n        Images.BlendColor := Color;\r\n\r\n      // If the user returned an index >= 15 then we cannot use the built-in overlay image drawing.\r\n      // Instead we do it manually.\r\n      if (ImageInfo[iiOverlay].Index > -1) and (ImageInfo[iiOverlay].Index < 15) then\r\n        ExtraStyle := ILD_TRANSPARENT or ILD_OVERLAYMASK and IndexToOverlayMask(ImageInfo[iiOverlay].Index + 1)\r\n      else\r\n        ExtraStyle := ILD_TRANSPARENT;\r\n\r\n      // Blend image if enabled and the tree has the focus (or ghosted images must be drawn also if unfocused) ...\r\n      if (toUseBlendedImages in FOptions.FPaintOptions) and PaintFocused\r\n        // ... and the image is ghosted...\r\n        and (Ghosted or\r\n        // ... or it is not the check image and the node is selected (but selection is not for the entire row)...\r\n        ((vsSelected in Node.States) and\r\n        not (toFullRowSelect in FOptions.FSelectionOptions) and\r\n        not (toGridExtensions in FOptions.FMiscOptions)) or\r\n        // ... or the node must be shown in cut mode.\r\n        CutNode) then\r\n        ExtraStyle := ExtraStyle or ILD_BLEND50;\r\n\r\n      if (vsSelected in Node.States) and not Ghosted then\r\n        Images.BlendColor := clDefault;\r\n\r\n      DrawImage(Images, Index, Canvas, XPos, YPos, Style[Images.ImageType] or ExtraStyle, DrawEnabled);\r\n\r\n      // Now, draw the overlay. This circumnavigates limitations in the overlay mask index (it has to be 4 bits in size,\r\n      // anything larger will be truncated by the ILD_OVERLAYMASK).\r\n      // However this will only be done if the overlay image index is > 15, to avoid breaking code that relies\r\n      // on overlay image indices (e.g. when using system image lists).\r\n      if PaintInfo.ImageInfo[iiOverlay].Index >= 15 then begin\r\n        ExtraStyle := ExtraStyle and not ILD_BLEND50; // Fixes issue #551\r\n        // Note: XPos and YPos are those of the normal images.\r\n        DrawImage(ImageInfo[iiOverlay].Images, ImageInfo[iiOverlay].Index, Canvas, XPos, YPos,\r\n          Style[ImageInfo[iiOverlay].Images.ImageType] or ExtraStyle, DrawEnabled);\r\n      end;//if\r\n    end;\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.PaintNodeButton(Canvas: TCanvas; Node: PVirtualNode; Column: TColumnIndex; const R: TRect;\r\n  ButtonX, ButtonY: Integer; BidiMode: TBiDiMode);\r\n\r\nvar\r\n  Bitmap: TBitmap;\r\n  XPos: Integer;\r\n  IsHot: Boolean;\r\n  IsSelected : boolean;\r\n  Theme: HTHEME;\r\n  Glyph: Integer;\r\n  State: Integer;\r\n  Pos: TRect;\r\n\r\nbegin\r\n  IsHot := (FCurrentHotNode = Node) and FHotNodeButtonHit;\r\n  IsSelected := (vsSelected in Node.States);\r\n\r\n  // Draw the node's plus/minus button according to the directionality.\r\n  if BidiMode = bdLeftToRight then\r\n    XPos := R.Left + ButtonX\r\n  else\r\n    XPos := R.Right - ButtonX - FPlusBM.Width;\r\n\r\n  if (tsUseExplorerTheme in FStates) and not VclStyleEnabled then\r\n  begin\r\n    Glyph := IfThen(IsHot, TVP_HOTGLYPH, TVP_GLYPH);\r\n    State := IfThen(vsExpanded in Node.States, GLPS_OPENED, GLPS_CLOSED);\r\n    Pos := Rect(XPos, R.Top + ButtonY, XPos + FPlusBM.Width, R.Top + ButtonY + FPlusBM.Height);\r\n    Theme := OpenThemeData(Handle, 'TREEVIEW');\r\n    DrawThemeBackground(Theme, Canvas.Handle, Glyph, State, Pos, nil);\r\n    CloseThemeData(Theme);\r\n  end\r\n  else\r\n  begin\r\n    if vsExpanded in Node.States then\r\n    begin\r\n      if IsHot then\r\n      begin\r\n        if IsSelected then\r\n          BitMap := FSelectedHotMinusBM\r\n        else\r\n          Bitmap := FHotMinusBM;\r\n      end\r\n      else\r\n        Bitmap := FMinusBM;\r\n    end\r\n    else\r\n    begin\r\n      if IsHot then\r\n      begin\r\n        if IsSelected then\r\n          BitMap := FSelectedHotPlusBM\r\n        else\r\n          Bitmap := FHotPlusBM;\r\n      end\r\n      else\r\n        Bitmap := FPlusBM;\r\n    end;\r\n    // Need to draw this masked.\r\n    Canvas.Draw(XPos, R.Top + ButtonY, Bitmap);\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.PaintTreeLines(const PaintInfo: TVTPaintInfo; VAlignment, IndentSize: Integer; const LineImage: TLineImage);\r\n\r\nvar\r\n  I: Integer;\r\n  XPos,\r\n  Offset: Integer;\r\n  NewStyles: TLineImage;\r\n\r\nbegin\r\n  NewStyles := nil;\r\n\r\n  with PaintInfo do\r\n  begin\r\n    if BidiMode = bdLeftToRight then\r\n    begin\r\n      XPos := CellRect.Left;\r\n      Offset := FIndent;\r\n    end\r\n    else\r\n    begin\r\n      Offset := -Integer(FIndent);\r\n      XPos := CellRect.Right + Offset;\r\n    end;\r\n\r\n    case FLineMode of\r\n      lmBands:\r\n        if poGridLines in PaintInfo.PaintOptions then\r\n        begin\r\n          // Convert the line images in correct bands.\r\n          SetLength(NewStyles, Length(LineImage));\r\n          for I := IndentSize - 1 downto 0 do\r\n          begin\r\n            if (vsExpanded in Node.States) and not (vsAllChildrenHidden in Node.States) then\r\n              NewStyles[I] := ltLeft\r\n            else\r\n              case LineImage[I] of\r\n                ltRight,\r\n                ltBottomRight,\r\n                ltTopDownRight,\r\n                ltTopRight:\r\n                  NewStyles[I] := ltLeftBottom;\r\n                ltNone:\r\n                  // Have to take over the image to the right of this one. A no line entry can never appear as\r\n                  // last entry so I don't need an end check here.\r\n                  if LineImage[I + 1] in [ltNone, ltTopRight] then\r\n                    NewStyles[I] := NewStyles[I + 1]\r\n                  else\r\n                    NewStyles[I] := ltLeft;\r\n                ltTopDown:\r\n                  // Have to check the image to the right of this one. A top down line can never appear as\r\n                  // last entry so I don't need an end check here.\r\n                  if LineImage[I + 1] in [ltNone, ltTopRight] then\r\n                    NewStyles[I] := NewStyles[I + 1]\r\n                  else\r\n                    NewStyles[I] := ltLeft;\r\n              end;\r\n          end;\r\n\r\n          PaintInfo.Canvas.Font.Color := FColors.GridLineColor;\r\n          for I := 0 to IndentSize - 1 do\r\n          begin\r\n            DoBeforeDrawLineImage(PaintInfo.Node, I + Ord(not (toShowRoot in TreeOptions.PaintOptions)), XPos);\r\n            DrawLineImage(PaintInfo, XPos, CellRect.Top, NodeHeight[Node] - 1, VAlignment - 1, NewStyles[I],\r\n              BidiMode <> bdLeftToRight);\r\n            Inc(XPos, Offset);\r\n          end;\r\n        end;\r\n    else // lmNormal\r\n      PaintInfo.Canvas.Font.Color := FColors.TreeLineColor;\r\n      for I := 0 to IndentSize - 1 do\r\n      begin\r\n        DoBeforeDrawLineImage(PaintInfo.Node, I + Ord(not (toShowRoot in TreeOptions.PaintOptions)), XPos);\r\n        DrawLineImage(PaintInfo, XPos, CellRect.Top, NodeHeight[Node], VAlignment - 1, LineImage[I],\r\n          BidiMode <> bdLeftToRight);\r\n        Inc(XPos, Offset);\r\n      end;\r\n    end;\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.PaintSelectionRectangle(Target: TCanvas; WindowOrgX: Integer; const SelectionRect: TRect;\r\n  TargetRect: TRect);\r\n\r\n// Helper routine to draw a selection rectangle in the mode determined by DrawSelectionMode.\r\n\r\nvar\r\n  BlendRect: TRect;\r\n  TextColorBackup,\r\n  BackColorBackup: COLORREF;   // used to restore forground and background colors when drawing a selection rectangle\r\n\r\nbegin\r\n  if ((FDrawSelectionMode = smDottedRectangle) and not (tsUseThemes in FStates)) or\r\n    not MMXAvailable then\r\n  begin\r\n    // Classical selection rectangle using dotted borderlines.\r\n    TextColorBackup := GetTextColor(Target.Handle);\r\n    SetTextColor(Target.Handle, $FFFFFF);\r\n    BackColorBackup := GetBkColor(Target.Handle);\r\n    SetBkColor(Target.Handle, 0);\r\n    Target.DrawFocusRect(SelectionRect);\r\n    SetTextColor(Target.Handle, TextColorBackup);\r\n    SetBkColor(Target.Handle, BackColorBackup);\r\n  end\r\n  else\r\n  begin\r\n    // Modern alpha blended style.\r\n    OffsetRect(TargetRect, WindowOrgX, 0);\r\n    if IntersectRect(BlendRect, OrderRect(SelectionRect), TargetRect) then\r\n    begin\r\n      OffsetRect(BlendRect, -WindowOrgX, 0);\r\n      AlphaBlend(0, Target.Handle, BlendRect, Point(0, 0), bmConstantAlphaAndColor, FSelectionBlendFactor,\r\n        ColorToRGB(FColors.SelectionRectangleBlendColor));\r\n\r\n      Target.Brush.Color := FColors.SelectionRectangleBorderColor;\r\n      Target.FrameRect(SelectionRect);\r\n    end;\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.PanningWindowProc(var Message: TMessage);\r\n\r\nvar\r\n  PS: TPaintStruct;\r\n  Canvas: TCanvas;\r\n\r\nbegin\r\n  if Message.Msg = WM_PAINT then\r\n  begin\r\n    BeginPaint(FPanningWindow, PS);\r\n    Canvas := TCanvas.Create;\r\n    Canvas.Handle := PS.hdc;\r\n    try\r\n      Canvas.Draw(0, 0, FPanningImage);\r\n    finally\r\n      Canvas.Handle := 0;\r\n      Canvas.Free;\r\n      EndPaint(FPanningWindow, PS);\r\n    end;\r\n    Message.Result := 0;\r\n  end\r\n  else\r\n    with Message do\r\n      Result := DefWindowProc(FPanningWindow, Msg, wParam, lParam);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.PrepareCell(var PaintInfo: TVTPaintInfo; WindowOrgX, MaxWidth: Integer);\r\n\r\n// This method is called immediately before a cell's content is drawn und is responsible to paint selection colors etc.\r\n\r\nvar\r\n  TextColorBackup,\r\n  BackColorBackup: COLORREF;\r\n  FocusRect,\r\n  InnerRect: TRect;\r\n  RowRect: TRect;\r\n  Theme: HTHEME;\r\nconst\r\n  TREIS_HOTSELECTED = 6;\r\n\r\n  //--------------- local functions -------------------------------------------\r\n\r\n  procedure AlphaBlendSelection(Color: TColor);\r\n\r\n  var\r\n    R: TRect;\r\n\r\n  begin\r\n    // Take into account any window offset and size limitations in the target bitmap, as this is only as large\r\n    // as necessary and might not cover the whole node. For normal painting this does not matter (because of\r\n    // clipping) but for the MMX code there is no such check and it will crash badly when bitmap boundaries are\r\n    // crossed.\r\n    R := InnerRect;\r\n    OffsetRect(R, -WindowOrgX, 0);\r\n    if R.Left < 0 then\r\n      R.Left := 0;\r\n    if R.Right > MaxWidth then\r\n      R.Right := MaxWidth;\r\n    AlphaBlend(0, PaintInfo.Canvas.Handle, R, Point(0, 0), bmConstantAlphaAndColor,\r\n      FSelectionBlendFactor, ColorToRGB(Color));\r\n  end;\r\n\r\n  //---------------------------------------------------------------------------\r\n\r\n  procedure DrawBackground(State: Integer);\r\n  begin\r\n    // if the full row selection is disabled or toGridExtensions is in the MiscOptions, draw the selection\r\n    // into the InnerRect, otherwise into the RowRect\r\n    if not (toFullRowSelect in FOptions.FSelectionOptions) or (toGridExtensions in FOptions.FMiscOptions) then\r\n      DrawThemeBackground(Theme, PaintInfo.Canvas.Handle, TVP_TREEITEM, State, InnerRect, nil)\r\n    else\r\n      DrawThemeBackground(Theme, PaintInfo.Canvas.Handle, TVP_TREEITEM, State, RowRect, nil);\r\n  end;\r\n\r\n  procedure DrawThemedFocusRect(State: Integer);\r\n  var\r\n    Theme: HTHEME;\r\n  begin\r\n    Theme := OpenThemeData(Application.ActiveFormHandle, 'Explorer::ItemsView');\r\n    if not (toFullRowSelect in FOptions.FSelectionOptions) or (toGridExtensions in FOptions.FMiscOptions) then\r\n      DrawThemeBackground(Theme, PaintInfo.Canvas.Handle, LVP_LISTDETAIL, State, InnerRect, nil)\r\n    else\r\n      DrawThemeBackground(Theme, PaintInfo.Canvas.Handle, LVP_LISTDETAIL, State, RowRect, nil);\r\n    CloseThemeData(Theme);\r\n  end;\r\n\r\n  //--------------- end local functions ---------------------------------------\r\n\r\nbegin\r\n  if tsUseExplorerTheme in FStates then\r\n  begin\r\n    Theme := OpenThemeData(Application.ActiveFormHandle, 'Explorer::TreeView');\r\n    RowRect := Rect(0, PaintInfo.CellRect.Top, FRangeX, PaintInfo.CellRect.Bottom);\r\n    if (Header.Columns.Count = 0) and (toFullRowSelect in TreeOptions.SelectionOptions) then\r\n      RowRect.Right := Max(ClientWidth, RowRect.Right);\r\n    if toShowVertGridLines in FOptions.PaintOptions then\r\n      Dec(RowRect.Right);\r\n  end;\r\n\r\n  with PaintInfo, Canvas do\r\n  begin\r\n    // Fill cell background if its color differs from tree background.\r\n    with FHeader.FColumns do\r\n    if poColumnColor in PaintOptions then\r\n    begin\r\n      if (VclStyleEnabled and (coParentColor in FHeader.FColumns[Column].FOptions)) then\r\n        Brush.Color := FColors.BackGroundColor\r\n      else\r\n        Brush.Color := Items[Column].Color;\r\n      FillRect(CellRect);\r\n     end;\r\n\r\n    // Let the application customize the cell background and the content rectangle.\r\n    DoBeforeCellPaint(Canvas, Node, Column, cpmPaint, CellRect, ContentRect);\r\n\r\n    InnerRect := ContentRect;\r\n\r\n    // The selection rectangle depends on alignment.\r\n    if not (toGridExtensions in FOptions.FMiscOptions) then\r\n    begin\r\n      case Alignment of\r\n        taLeftJustify:\r\n          with TWithSafeRect(InnerRect) do\r\n            if Left + NodeWidth < Right then\r\n              Right := Left + NodeWidth;\r\n        taCenter:\r\n          with TWithSafeRect(InnerRect) do\r\n            if (Right - Left) > NodeWidth then\r\n            begin\r\n              Left := (Left + Right - NodeWidth) div 2;\r\n              Right := Left + NodeWidth;\r\n            end;\r\n        taRightJustify:\r\n          with TWithSafeRect(InnerRect) do\r\n            if (Right - Left) > NodeWidth then\r\n              Left := Right - NodeWidth;\r\n      end;\r\n    end;\r\n\r\n    if (Column = FFocusedColumn) or (toFullRowSelect in FOptions.FSelectionOptions) then\r\n    begin\r\n      // Fill the selection rectangle.\r\n      if poDrawSelection in PaintOptions then\r\n      begin\r\n        if Node = FDropTargetNode then\r\n        begin\r\n          if (FLastDropMode = dmOnNode) or (vsSelected in Node.States) then\r\n          begin\r\n            Brush.Color := FColors.DropTargetColor;\r\n            Pen.Color := FColors.DropTargetBorderColor;\r\n\r\n            if (toGridExtensions in FOptions.FMiscOptions) or\r\n              (toFullRowSelect in FOptions.FSelectionOptions) then\r\n              InnerRect := CellRect;\r\n            if not IsRectEmpty(InnerRect) then\r\n              if tsUseExplorerTheme in FStates then\r\n                DrawBackground(TREIS_SELECTED)\r\n              else\r\n                if MMXAvailable and (toUseBlendedSelection in FOptions.PaintOptions) then\r\n                  AlphaBlendSelection(Brush.Color)\r\n                else\r\n                  with TWithSafeRect(InnerRect) do\r\n                    RoundRect(Left, Top, Right, Bottom, FSelectionCurveRadius, FSelectionCurveRadius);\r\n          end\r\n          else\r\n          begin\r\n            Brush.Style := bsClear;\r\n          end;\r\n        end\r\n        else\r\n          if vsSelected in Node.States then\r\n          begin\r\n             if Focused or (toPopupMode in FOptions.FPaintOptions) then\r\n             begin\r\n              Brush.Color := FColors.FocusedSelectionColor;\r\n              Pen.Color := FColors.FocusedSelectionBorderColor;\r\n            end\r\n            else\r\n            begin\r\n              Brush.Color := FColors.UnfocusedSelectionColor;\r\n              Pen.Color := FColors.UnfocusedSelectionBorderColor;\r\n          end;\r\n\r\n            if (toGridExtensions in FOptions.FMiscOptions) or (toFullRowSelect in FOptions.FSelectionOptions) then\r\n              InnerRect := CellRect;\r\n            if not IsRectEmpty(InnerRect) then\r\n              if tsUseExplorerTheme in FStates then\r\n              begin\r\n                // If the node is also hot, its background will be drawn later.\r\n                if not (toHotTrack in FOptions.FPaintOptions) or (Node <> FCurrentHotNode) or\r\n                   ((Column <> FCurrentHotColumn) and not (toFullRowSelect in FOptions.FSelectionOptions)) then\r\n                  DrawBackground(IfThen(Self.Focused, TREIS_SELECTED, TREIS_SELECTEDNOTFOCUS));\r\n              end\r\n              else\r\n                if MMXAvailable and (toUseBlendedSelection in FOptions.PaintOptions) then\r\n                  AlphaBlendSelection(Brush.Color)\r\n                else\r\n                  with TWithSafeRect(InnerRect) do\r\n                    RoundRect(Left, Top, Right, Bottom, FSelectionCurveRadius, FSelectionCurveRadius);\r\n          end;\r\n      end;\r\n    end;\r\n\r\n    if (tsUseExplorerTheme in FStates) and (toHotTrack in FOptions.FPaintOptions) and (Node = FCurrentHotNode) and\r\n       ((Column = FCurrentHotColumn) or (toFullRowSelect in FOptions.FSelectionOptions)) then\r\n      DrawBackground(IfThen((vsSelected in Node.States) and not (toAlwaysHideSelection in FOptions.FPaintOptions),\r\n                            TREIS_HOTSELECTED, TREIS_HOT));\r\n\r\n    if (Column = FFocusedColumn) or (toFullRowSelect in FOptions.FSelectionOptions) then\r\n    begin\r\n      // draw focus rect\r\n      if (poDrawFocusRect in PaintOptions) and\r\n         (Focused or (toPopupMode in FOptions.FPaintOptions)) and (FFocusedNode = Node) and\r\n         ( (Column = FFocusedColumn) or\r\n             ((not (toExtendedFocus in FOptions.FSelectionOptions) or IsWinVistaOrAbove) and\r\n             (toFullRowSelect in FOptions.FSelectionOptions) and\r\n             (tsUseExplorerTheme in FStates) ) ) then\r\n      begin\r\n        TextColorBackup := GetTextColor(Handle);\r\n        SetTextColor(Handle, $FFFFFF);\r\n        BackColorBackup := GetBkColor(Handle);\r\n        SetBkColor(Handle, 0);\r\n\r\n        if not (toExtendedFocus in FOptions.FSelectionOptions) and (toFullRowSelect in FOptions.FSelectionOptions) and\r\n          (tsUseExplorerTheme in FStates) then\r\n          FocusRect := RowRect\r\n        else\r\n          if toGridExtensions in FOptions.FMiscOptions then\r\n            FocusRect := CellRect\r\n          else\r\n            FocusRect := InnerRect;\r\n\r\n        if tsUseExplorerTheme in FStates then\r\n          InflateRect(FocusRect, -1, -1);\r\n\r\n        if (tsUseExplorerTheme in FStates) and IsWinVistaOrAbove then\r\n        begin\r\n          //Draw focused unselected style like Windows 7 Explorer\r\n          if not (vsSelected in Node.States) then\r\n            DrawThemedFocusRect(LIS_NORMAL)\r\n          else\r\n            DrawBackground(TREIS_HOTSELECTED);\r\n        end\r\n        else\r\n          Winapi.Windows.DrawFocusRect(Handle, FocusRect);\r\n        SetTextColor(Handle, TextColorBackup);\r\n        SetBkColor(Handle, BackColorBackup);\r\n      end;\r\n    end;\r\n  end;\r\n\r\n  if tsUseExplorerTheme in FStates then\r\n    CloseThemeData(Theme);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TBaseVirtualTree.ReadChunk(Stream: TStream; Version: Integer; Node: PVirtualNode; ChunkType,\r\n  ChunkSize: Integer): Boolean;\r\n\r\n// Called while loading a tree structure, Node is already valid (allocated) at this point.\r\n// The function handles the base and user chunks, any other chunk is marked as being unknown (result becomes False)\r\n// and skipped. descendants may handle them by overriding this method.\r\n// Returns True if the chunk could be handled, otherwise False.\r\n\r\nvar\r\n  ChunkBody: TBaseChunkBody;\r\n  Run: PVirtualNode;\r\n  LastPosition: Integer;\r\n\r\nbegin\r\n  case ChunkType of\r\n    BaseChunk:\r\n      begin\r\n        // Load base chunk's body (chunk header has already been consumed).\r\n        if Version > 1 then\r\n          Stream.Read(ChunkBody, SizeOf(ChunkBody))\r\n        else\r\n        begin\r\n          with ChunkBody do\r\n          begin\r\n            // In version prior to 2 there was a smaller chunk body. Hence we have to read it entry by entry now.\r\n            Stream.Read(ChildCount, SizeOf(ChildCount));\r\n            Stream.Read(NodeHeight, SizeOf(NodeHeight));\r\n            // TVirtualNodeStates was a byte sized type in version 1.\r\n            States := [];\r\n            Stream.Read(States, SizeOf(Byte));\r\n            // vsVisible is now in the place where vsSelected was before, but every node was visible in the old version\r\n            // so we need to fix this too.\r\n            if vsVisible in States then\r\n              Include(States, vsSelected)\r\n            else\r\n              Include(States, vsVisible);\r\n            Stream.Read(Align, SizeOf(Align));\r\n            Stream.Read(CheckState, SizeOf(CheckState));\r\n            Stream.Read(CheckType, SizeOf(CheckType));\r\n          end;\r\n        end;\r\n\r\n        with Node^ do\r\n        begin\r\n          // Set states first, in case the node is invisible.\r\n          States := ChunkBody.States;\r\n          NodeHeight := ChunkBody.NodeHeight;\r\n          TotalHeight := NodeHeight;\r\n          Align := ChunkBody.Align;\r\n          CheckState := ChunkBody.CheckState;\r\n          CheckType := ChunkBody.CheckType;\r\n          ChildCount := ChunkBody.ChildCount;\r\n\r\n          // Create and read child nodes.\r\n          while ChunkBody.ChildCount > 0 do\r\n          begin\r\n            Run := MakeNewNode;\r\n\r\n            Run.PrevSibling := Node.LastChild;\r\n            if Assigned(Run.PrevSibling) then\r\n              Run.Index := Run.PrevSibling.Index + 1;\r\n            if Assigned(Node.LastChild) then\r\n              Node.LastChild.NextSibling := Run\r\n            else\r\n              Node.FirstChild := Run;\r\n            Node.LastChild := Run;\r\n            Run.Parent := Node;\r\n\r\n            ReadNode(Stream, Version, Run);\r\n            Dec(ChunkBody.ChildCount);\r\n          end;\r\n        end;\r\n        Result := True;\r\n      end;\r\n    UserChunk:\r\n      if ChunkSize > 0 then\r\n      begin\r\n        // need to know whether the data was read\r\n        LastPosition := Stream.Position;\r\n        DoLoadUserData(Node, Stream);\r\n        // compare stream position to learn whether the data was read\r\n        Result := Stream.Position > LastPosition;\r\n        // Improve stability by advancing the stream to the chunk's real end if\r\n        // the application did not read what has been written.\r\n        if not Result or (Stream.Position <> (LastPosition + ChunkSize)) then\r\n          Stream.Position := LastPosition + ChunkSize;\r\n      end\r\n      else\r\n        Result := True;\r\n  else\r\n    // unknown chunk, skip it\r\n    Stream.Position := Stream.Position + ChunkSize;\r\n    Result := False;\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.ReadNode(Stream: TStream; Version: Integer; Node: PVirtualNode);\r\n\r\n// Reads the anchor chunk of each node and initiates reading the sub chunks for this node\r\n\r\nvar\r\n  Header: TChunkHeader;\r\n  EndPosition: Integer;\r\n\r\nbegin\r\n  with Stream do\r\n  begin\r\n    // Read anchor chunk of the node.\r\n    Stream.Read(Header, SizeOf(Header));\r\n    if Header.ChunkType = NodeChunk then\r\n    begin\r\n      EndPosition := Stream.Position + Header.ChunkSize;\r\n      // Read all subchunks until the indicated chunk end position is reached in the stream.\r\n      while Position < EndPosition do\r\n      begin\r\n        // Read new chunk header.\r\n        Stream.Read(Header, SizeOf(Header));\r\n        ReadChunk(Stream, Version, Node, Header.ChunkType, Header.ChunkSize);\r\n      end;\r\n      // If the last chunk does not end at the given end position then there is something wrong.\r\n      if Position <> EndPosition then\r\n        ShowError(SCorruptStream2, hcTFCorruptStream2);\r\n    end\r\n    else\r\n      ShowError(SCorruptStream1, hcTFCorruptStream1);\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.RedirectFontChangeEvent(Canvas: TCanvas);\r\n\r\nbegin\r\n  if @Canvas.Font.OnChange <> @FOldFontChange then\r\n  begin\r\n    FOldFontChange := Canvas.Font.OnChange;\r\n    Canvas.Font.OnChange := FontChanged;\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.RemoveFromSelection(Node: PVirtualNode);\r\n\r\nvar\r\n  Index: Integer;\r\n\r\nbegin\r\n  if not FSelectionLocked then\r\n  begin\r\n    Assert(Assigned(Node), 'Node must not be nil!');\r\n    if vsSelected in Node.States then\r\n    begin\r\n      Exclude(Node.States, vsSelected);\r\n      if FindNodeInSelection(Node, Index, -1, -1) and (Index < FSelectionCount - 1) then\r\n        Move(FSelection[Index + 1], FSelection[Index], (FSelectionCount - Index - 1) * SizeOf(Pointer));\r\n      if FSelectionCount > 0 then\r\n        Dec(FSelectionCount);\r\n      SetLength(FSelection, FSelectionCount);\r\n\r\n      if FSelectionCount = 0 then\r\n        ResetRangeAnchor;\r\n\r\n      if FSelectionCount <= 1 then\r\n        UpdateNextNodeToSelect(Node);\r\n\r\n      DoRemoveFromSelection(Node);\r\n      Change(Node);\r\n    end;\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.UpdateNextNodeToSelect(Node: PVirtualNode);\r\n\r\n// save a potential node to select after the currently selected node will be deleted.\r\n// This will make the VT to behave more like the Win32 TreeView, which always selecta a new node if the currently\r\n// selected one gets deleted.\r\n\r\nbegin\r\n  if not (toAlwaysSelectNode in TreeOptions.SelectionOptions) then\r\n    Exit;\r\n  if GetNextSibling(Node) <> nil then\r\n    FNextNodeToSelect := GetNextSibling(Node)\r\n  else if GetPreviousSibling(Node) <> nil then\r\n    FNextNodeToSelect := GetPreviousSibling(Node)\r\n  else if GetNodeLevel(Node) > 0 then\r\n    FNextNodeToSelect := Node.Parent\r\n  else\r\n    FNextNodeToSelect := GetFirstChild(Node);\r\nend;//if Assigned(Node);\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TBaseVirtualTree.RenderOLEData(const FormatEtcIn: TFormatEtc; out Medium: TStgMedium;\r\n  ForClipboard: Boolean): HResult;\r\n\r\n// Returns a memory expression of all currently selected nodes in the Medium structure.\r\n// Note: The memory requirement of this method might be very high. This depends however on the requested storage format.\r\n//       For HGlobal (a global memory block) we need to render first all nodes to local memory and copy this then to\r\n//       the global memory in Medium. This is necessary because we have first to determine how much\r\n//       memory is needed before we can allocate it. Hence for a short moment we need twice the space as used by the\r\n//       nodes alone (plus the amount the nodes need in the tree anyway)!\r\n//       With IStream this does not happen. We directly stream out the nodes and pass the constructed stream along.\r\n\r\n  //--------------- local function --------------------------------------------\r\n\r\n  procedure WriteNodes(Stream: TStream);\r\n\r\n  var\r\n    Selection: TNodeArray;\r\n    I: Integer;\r\n\r\n  begin\r\n    if ForClipboard then\r\n      Selection := GetSortedCutCopySet(True)\r\n    else\r\n      Selection := GetSortedSelection(True);\r\n    for I := 0 to High(Selection) do\r\n      WriteNode(Stream, Selection[I]);\r\n  end;\r\n\r\n  //--------------- end local function ----------------------------------------\r\n\r\nvar\r\n  Data: PCardinal;\r\n  ResPointer: Pointer;\r\n  ResSize: Integer;\r\n  OLEStream: IStream;\r\n  VCLStream: TStream;\r\n\r\nbegin\r\n  ZeroMemory (@Medium, SizeOf(Medium));\r\n\r\n  // We can render the native clipboard format in two different storage media.\r\n  if (FormatEtcIn.cfFormat = CF_VIRTUALTREE) and (FormatEtcIn.tymed and (TYMED_HGLOBAL or TYMED_ISTREAM) <> 0) then\r\n  begin\r\n    VCLStream := nil;\r\n    try\r\n      Medium.unkForRelease := nil;\r\n      // Return data in one of the supported storage formats, prefer IStream.\r\n      if FormatEtcIn.tymed and TYMED_ISTREAM <> 0 then\r\n      begin\r\n        // Create an IStream on a memory handle (here it is 0 which indicates to implicitely allocated a handle).\r\n        // Do not use TStreamAdapter as it is not compatible with OLE (when flushing the clipboard OLE wants the HGlobal\r\n        // back which is not supported by TStreamAdapater).\r\n        CreateStreamOnHGlobal(0, True, OLEStream);\r\n        VCLStream := TOLEStream.Create(OLEStream);\r\n        WriteNodes(VCLStream);\r\n        // Rewind stream.\r\n        VCLStream.Position := 0;\r\n        Medium.tymed := TYMED_ISTREAM;\r\n        IUnknown(Medium.stm) := OLEStream;\r\n        Result := S_OK;\r\n      end\r\n      else\r\n      begin\r\n        VCLStream := TMemoryStream.Create;\r\n        WriteNodes(VCLStream);\r\n        ResPointer := TMemoryStream(VCLStream).Memory;\r\n        ResSize := VCLStream.Position;\r\n\r\n        // Allocate memory to hold the string.\r\n        if ResSize > 0 then\r\n        begin\r\n          Medium.hGlobal := GlobalAlloc(GHND or GMEM_SHARE, ResSize + SizeOf(Cardinal));\r\n          Data := GlobalLock(Medium.hGlobal);\r\n          // Store the size of the data too, for easy retrival.\r\n          Data^ := ResSize;\r\n          Inc(Data);\r\n          Move(ResPointer^, Data^, ResSize);\r\n          GlobalUnlock(Medium.hGlobal);\r\n          Medium.tymed := TYMED_HGLOBAL;\r\n\r\n          Result := S_OK;\r\n        end\r\n        else\r\n          Result := E_FAIL;\r\n      end;\r\n    finally\r\n      // We can free the VCL stream here since it was either a pure memory stream or only a wrapper around\r\n      // the OLEStream which exists independently.\r\n      VCLStream.Free;\r\n    end;\r\n  end\r\n  else // Ask application descendants to render self defined formats.\r\n    Result := DoRenderOLEData(FormatEtcIn, Medium, ForClipboard);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.ResetRangeAnchor;\r\n\r\n// Called when there is no selected node anymore and the selection range anchor needs a new value.\r\n\r\nbegin\r\n  FRangeAnchor := FFocusedNode;\r\n  FLastSelectionLevel := -1;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.RestoreFontChangeEvent(Canvas: TCanvas);\r\n\r\nbegin\r\n  Canvas.Font.OnChange := FOldFontChange;\r\n  FOldFontChange := nil;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.SelectNodes(StartNode, EndNode: PVirtualNode; AddOnly: Boolean);\r\n\r\n// Selects a range of nodes and unselects all other eventually selected nodes which are not in this range if\r\n// AddOnly is False.\r\n// EndNode must be visible while StartNode does not necessarily as in the case where the last focused node is the start\r\n// node but it is a child of a node which has been collapsed previously. In this case the first visible parent node\r\n// is used as start node. StartNode can be nil in which case the very first node in the tree is used.\r\n\r\nvar\r\n  NodeFrom,\r\n  NodeTo,\r\n  LastAnchor: PVirtualNode;\r\n  Index: Integer;\r\n\r\nbegin\r\n  Assert(Assigned(EndNode), 'EndNode must not be nil!');\r\n  if not FSelectionLocked then\r\n  begin\r\n    ClearTempCache;\r\n    if StartNode = nil then\r\n      StartNode := GetFirstVisibleNoInit(nil, True)\r\n    else\r\n      if not FullyVisible[StartNode] then\r\n      begin\r\n        StartNode := GetPreviousVisible(StartNode, True);\r\n        if StartNode = nil then\r\n          StartNode := GetFirstVisibleNoInit(nil, True);\r\n      end;\r\n\r\n    if CompareNodePositions(StartNode, EndNode, True) < 0 then\r\n    begin\r\n      NodeFrom := StartNode;\r\n      NodeTo := EndNode;\r\n    end\r\n    else\r\n    begin\r\n      NodeFrom := EndNode;\r\n      NodeTo := StartNode;\r\n    end;\r\n\r\n    // The range anchor will be reset by the following call.\r\n    LastAnchor := FRangeAnchor;\r\n    if not AddOnly then\r\n      InternalClearSelection;\r\n\r\n    while NodeFrom <> NodeTo do\r\n    begin\r\n      InternalCacheNode(NodeFrom);\r\n      NodeFrom := GetNextVisible(NodeFrom, True);\r\n    end;\r\n    // select last node too\r\n    InternalCacheNode(NodeFrom);\r\n    // now add them all in \"one\" step\r\n    AddToSelection(FTempNodeCache, FTempNodeCount);\r\n    ClearTempCache;\r\n    if Assigned(LastAnchor) and FindNodeInSelection(LastAnchor, Index, -1, -1) then\r\n     FRangeAnchor := LastAnchor;\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.SetFocusedNodeAndColumn(Node: PVirtualNode; Column: TColumnIndex);\r\n\r\nvar\r\n  OldColumn: TColumnIndex;\r\n  WasDifferent: Boolean;\r\n\r\nbegin\r\n  if not FHeader.AllowFocus(Column) then\r\n    Column := FFocusedColumn;\r\n\r\n  WasDifferent := (Node <> FFocusedNode) or (Column <> FFocusedColumn);\r\n\r\n  OldColumn := FFocusedColumn;\r\n  FFocusedColumn := Column;\r\n\r\n  DoFocusNode(Node, True);\r\n\r\n  // Check if the change was accepted.\r\n  if FFocusedNode = Node then\r\n  begin\r\n    CancelEditNode;\r\n    if WasDifferent then\r\n      DoFocusChange(FFocusedNode, FFocusedColumn);\r\n  end\r\n  else\r\n    // If the user did not accept the new cell to focus then set also the focused column back\r\n    // to its original state.\r\n    FFocusedColumn := OldColumn;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.SkipNode(Stream: TStream);\r\n\r\n// Skips the data for the next node in the given stream (including the child nodes).\r\n\r\nvar\r\n  Header: TChunkHeader;\r\n\r\nbegin\r\n  with Stream do\r\n  begin\r\n    // read achor chunk of the node\r\n    Stream.Read(Header, SizeOf(Header));\r\n    if Header.ChunkType = NodeChunk then\r\n      Stream.Position := Stream.Position + Header.ChunkSize\r\n    else\r\n      ShowError(SCorruptStream1, hcTFCorruptStream1);\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nvar\r\n  PanningWindowClass: TWndClass = (\r\n    style: 0;\r\n    lpfnWndProc: @DefWindowProc;\r\n    cbClsExtra: 0;\r\n    cbWndExtra: 0;\r\n    hInstance: 0;\r\n    hIcon: 0;\r\n    hCursor: 0;\r\n    hbrBackground: 0;\r\n    lpszMenuName: nil;\r\n    lpszClassName: 'VTPanningWindow'\r\n  );\r\n\r\nprocedure TBaseVirtualTree.StartWheelPanning(Position: TPoint);\r\n\r\n// Called when wheel panning should start. A little helper window is created to indicate the reference position,\r\n// which determines in which direction and how far wheel panning/scrolling will happen.\r\n\r\n  //--------------- local function --------------------------------------------\r\n\r\n  function CreateClipRegion: HRGN;\r\n\r\n  // In order to avoid doing all the transparent drawing ourselves we use a\r\n  // window region for the wheel window.\r\n  // Since we only work on a very small image (32x32 pixels) this is acceptable.\r\n\r\n  var\r\n    Start, X, Y: Integer;\r\n    Temp: HRGN;\r\n\r\n  begin\r\n    Assert(not FPanningImage.Empty, 'Invalid wheel panning image.');\r\n\r\n    // Create an initial region on which we operate.\r\n    Result := CreateRectRgn(0, 0, 0, 0);\r\n    with FPanningImage, Canvas do\r\n    begin\r\n      for Y := 0 to Height - 1 do\r\n      begin\r\n        Start := -1;\r\n        for X := 0 to Width - 1 do\r\n        begin\r\n          // Start a new span if we found a non-transparent pixel and no span is currently started.\r\n          if (Start = -1) and (Pixels[X, Y] <> clFuchsia) then\r\n            Start := X\r\n          else\r\n            if (Start > -1) and (Pixels[X, Y] = clFuchsia) then\r\n            begin\r\n              // A non-transparent span is finished. Add it to the result region.\r\n              Temp := CreateRectRgn(Start, Y, X, Y + 1);\r\n              CombineRgn(Result, Result, Temp, RGN_OR);\r\n              DeleteObject(Temp);\r\n              Start := -1;\r\n            end;\r\n        end;\r\n        // If there is an open span then add this also to the result region.\r\n        if Start > -1 then\r\n        begin\r\n          Temp := CreateRectRgn(Start, Y, Width, Y + 1);\r\n          CombineRgn(Result, Result, Temp, RGN_OR);\r\n          DeleteObject(Temp);\r\n        end;\r\n      end;\r\n    end;\r\n    // The resulting region is used as window region so we must not delete it.\r\n    // Windows will own it after the assignment below.\r\n  end;\r\n\r\n  //--------------- end local function ----------------------------------------\r\n\r\nvar\r\n  TempClass: TWndClass;\r\n  ClassRegistered: Boolean;\r\n  ImageName: string;\r\n  Pt: TPoint;\r\n\r\nbegin\r\n  // Set both panning and scrolling flag. One will be removed shortly depending on whether the middle mouse button is\r\n  // released before the mouse is moved or vice versa. The first case is referred to as wheel scrolling while the\r\n  // latter is called wheel panning.\r\n  StopTimer(ScrollTimer);\r\n  DoStateChange([tsWheelPanning, tsWheelScrolling]);\r\n\r\n  // Register the helper window class.\r\n  PanningWindowClass.hInstance := HInstance;\r\n  ClassRegistered := GetClassInfo(HInstance, PanningWindowClass.lpszClassName, TempClass);\r\n  if not ClassRegistered or (TempClass.lpfnWndProc <> @DefWindowProc) then\r\n  begin\r\n    if ClassRegistered then\r\n      Winapi.Windows.UnregisterClass(PanningWindowClass.lpszClassName, HInstance);\r\n    Winapi.Windows.RegisterClass(PanningWindowClass);\r\n  end;\r\n  // Create the helper window and show it at the given position without activating it.\r\n  Pt := ClientToScreen(Position);\r\n  FPanningWindow := CreateWindowEx(WS_EX_TOOLWINDOW, PanningWindowClass.lpszClassName, nil, WS_POPUP, Pt.X - 16, Pt.Y - 16,\r\n    32, 32, Handle, 0, HInstance, nil);\r\n\r\n  FPanningImage := TBitmap.Create;\r\n  if Integer(FRangeX) > ClientWidth then\r\n  begin\r\n    if Integer(FRangeY) > ClientHeight then\r\n      ImageName := 'VT_MOVEALL'\r\n    else\r\n      ImageName := 'VT_MOVEEW';\r\n  end\r\n  else\r\n    ImageName := 'VT_MOVENS';\r\n  FPanningImage.LoadFromResourceName(HInstance, ImageName);\r\n  SetWindowRgn(FPanningWindow, CreateClipRegion, False);\r\n\r\n  {$ifdef CPUX64}\r\n  SetWindowLongPtr(FPanningWindow, GWLP_WNDPROC, LONG_PTR(System.Classes.MakeObjectInstance(PanningWindowProc)));\r\n  {$else}\r\n  SetWindowLong(FPanningWindow, GWL_WNDPROC, NativeInt(System.Classes.MakeObjectInstance(PanningWindowProc)));\r\n  {$endif CPUX64}\r\n  ShowWindow(FPanningWindow, SW_SHOWNOACTIVATE);\r\n\r\n  // Setup the panscroll timer and capture all mouse input.\r\n  SetFocus;\r\n  SetCapture(Handle);\r\n  SetTimer(Handle, ScrollTimer, 20, nil);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.StopWheelPanning;\r\n\r\n// Stops panning if currently active and destroys the helper window.\r\n\r\nvar\r\n  Instance: Pointer;\r\n\r\nbegin\r\n  if [tsWheelPanning, tsWheelScrolling] * FStates <> [] then\r\n  begin\r\n    // Release the mouse capture and stop the panscroll timer.\r\n    StopTimer(ScrollTimer);\r\n    ReleaseCapture;\r\n    DoStateChange([], [tsWheelPanning, tsWheelScrolling]);\r\n\r\n    // Destroy the helper window.\r\n    {$ifdef CPUX64}\r\n    Instance := Pointer(GetWindowLongPtr(FPanningWindow, GWLP_WNDPROC));\r\n    {$else}\r\n    Instance := Pointer(GetWindowLong(FPanningWindow, GWL_WNDPROC));\r\n    {$endif CPUX64}\r\n    DestroyWindow(FPanningWindow);\r\n    if Instance <> @DefWindowProc then\r\n      System.Classes.FreeObjectInstance(Instance);\r\n    FPanningWindow := 0;\r\n    FPanningImage.Free;\r\n    FPanningImage := nil;\r\n    DeleteObject(FPanningCursor);\r\n    FPanningCursor := 0;\r\n    Winapi.Windows.SetCursor(Screen.Cursors[Cursor]);\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.StructureChange(Node: PVirtualNode; Reason: TChangeReason);\r\n\r\nbegin\r\n  AdviseChangeEvent(True, Node, Reason);\r\n\r\n  if FUpdateCount = 0 then\r\n  begin\r\n    if (FChangeDelay > 0) and not (tsSynchMode in FStates) then\r\n      SetTimer(Handle, StructureChangeTimer, FChangeDelay, nil)\r\n    else\r\n      DoStructureChange(Node, Reason);\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TBaseVirtualTree.SuggestDropEffect(Source: TObject; Shift: TShiftState; Pt: TPoint;\r\n  AllowedEffects: Integer): Integer;\r\n\r\n// determines the drop action to take if the drag'n drop operation ends on this tree\r\n// Note: Source can be any Delphi object not just a virtual tree\r\n\r\nbegin\r\n  Result := AllowedEffects;\r\n\r\n  // prefer MOVE if source and target are the same control, otherwise whatever is allowed as initial value\r\n  if Assigned(Source) and (Source = Self) then\r\n    if (AllowedEffects and DROPEFFECT_MOVE) <> 0 then\r\n      Result := DROPEFFECT_MOVE\r\n    else // no change\r\n  else\r\n    // drag between different applicatons\r\n    if (AllowedEffects and DROPEFFECT_COPY) <> 0 then\r\n      Result := DROPEFFECT_COPY;\r\n\r\n  // consider modifier keys and what is allowed at the moment, if none of the following conditions apply then\r\n  // the initial value just set is used\r\n  if ssCtrl in Shift then\r\n  begin\r\n    // copy or link\r\n    if ssShift in Shift then\r\n    begin\r\n      // link\r\n      if (AllowedEffects and DROPEFFECT_LINK) <> 0 then\r\n        Result := DROPEFFECT_LINK;\r\n    end\r\n    else\r\n    begin\r\n      // copy\r\n      if (AllowedEffects and DROPEFFECT_COPY) <> 0 then\r\n        Result := DROPEFFECT_COPY;\r\n    end;\r\n  end\r\n  else\r\n  begin\r\n    // move, link or default\r\n    if ssShift in Shift then\r\n    begin\r\n      // move\r\n      if (AllowedEffects and DROPEFFECT_MOVE) <> 0 then\r\n        Result := DROPEFFECT_MOVE;\r\n    end\r\n    else\r\n    begin\r\n      // link or default\r\n      if ssAlt in Shift then\r\n      begin\r\n        // link\r\n        if (AllowedEffects and DROPEFFECT_LINK) <> 0 then\r\n          Result := DROPEFFECT_LINK;\r\n      end;\r\n      // else default\r\n    end;\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.ToggleSelection(StartNode, EndNode: PVirtualNode);\r\n\r\n// Switchs the selection state of a range of nodes.\r\n// Note: This method is specifically designed to help selecting ranges with the keyboard and considers therefore\r\n//       the range anchor.\r\n\r\nvar\r\n  NodeFrom,\r\n  NodeTo: PVirtualNode;\r\n  NewSize: Integer;\r\n  Position: Integer;\r\n\r\nbegin\r\n  if not FSelectionLocked then\r\n  begin\r\n    Assert(Assigned(EndNode), 'EndNode must not be nil!');\r\n    if StartNode = nil then\r\n      StartNode := FRoot.FirstChild\r\n    else\r\n      if not FullyVisible[StartNode] then\r\n        StartNode := GetPreviousVisible(StartNode, True);\r\n\r\n    Position := CompareNodePositions(StartNode, EndNode);\r\n    // nothing to do if start and end node are the same\r\n    if Position <> 0 then\r\n    begin\r\n      if Position < 0 then\r\n      begin\r\n        NodeFrom := StartNode;\r\n        NodeTo := EndNode;\r\n      end\r\n      else\r\n      begin\r\n        NodeFrom := EndNode;\r\n        NodeTo := StartNode;\r\n      end;\r\n\r\n      ClearTempCache;\r\n\r\n      // 1) toggle the start node if it is before the range anchor\r\n      if CompareNodePositions(NodeFrom, FRangeAnchor) < 0 then\r\n        if not (vsSelected in NodeFrom.States) then\r\n          InternalCacheNode(NodeFrom)\r\n        else\r\n          InternalRemoveFromSelection(NodeFrom);\r\n\r\n      // 2) toggle all nodes within the range\r\n      NodeFrom := GetNextVisible(NodeFrom, True);\r\n      while NodeFrom <> NodeTo do\r\n      begin\r\n        if not (vsSelected in NodeFrom.States) then\r\n          InternalCacheNode(NodeFrom)\r\n        else\r\n          InternalRemoveFromSelection(NodeFrom);\r\n        NodeFrom := GetNextVisible(NodeFrom, True);\r\n      end;\r\n\r\n      // 3) toggle end node if it is after the range anchor\r\n      if CompareNodePositions(NodeFrom, FRangeAnchor) > 0 then\r\n        if not (vsSelected in NodeFrom.States) then\r\n          InternalCacheNode(NodeFrom)\r\n        else\r\n          InternalRemoveFromSelection(NodeFrom);\r\n\r\n      // Do some housekeeping if there was a change.\r\n      NewSize := PackArray(FSelection, FSelectionCount);\r\n      if NewSize > -1 then\r\n      begin\r\n        FSelectionCount := NewSize;\r\n        SetLength(FSelection, FSelectionCount);\r\n      end;\r\n      // If the range went over the anchor then we need to reselect it.\r\n      if not (vsSelected in FRangeAnchor.States) then\r\n        InternalCacheNode(FRangeAnchor);\r\n      if FTempNodeCount > 0 then\r\n        AddToSelection(FTempNodeCache, FTempNodeCount);\r\n      ClearTempCache;\r\n    end;\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.UnselectNodes(StartNode, EndNode: PVirtualNode);\r\n\r\n// Deselects a range of nodes.\r\n// EndNode must be visible while StartNode must not as in the case where the last focused node is the start node\r\n// but it is a child of a node which has been collapsed previously. In this case the first visible parent node\r\n// is used as start node. StartNode can be nil in which case the very first node in the tree is used.\r\n\r\nvar\r\n  NodeFrom,\r\n  NodeTo: PVirtualNode;\r\n  NewSize: Integer;\r\n\r\nbegin\r\n  if not FSelectionLocked then\r\n  begin\r\n    Assert(Assigned(EndNode), 'EndNode must not be nil!');\r\n\r\n    if StartNode = nil then\r\n      StartNode := FRoot.FirstChild\r\n    else\r\n      if not FullyVisible[StartNode] then\r\n      begin\r\n        StartNode := GetPreviousVisible(StartNode, True);\r\n        if StartNode = nil then\r\n          StartNode := FRoot.FirstChild;\r\n      end;\r\n\r\n    if CompareNodePositions(StartNode, EndNode) < 0 then\r\n    begin\r\n      NodeFrom := StartNode;\r\n      NodeTo := EndNode;\r\n    end\r\n    else\r\n    begin\r\n      NodeFrom := EndNode;\r\n      NodeTo := StartNode;\r\n    end;\r\n\r\n    while NodeFrom <> NodeTo do\r\n    begin\r\n      InternalRemoveFromSelection(NodeFrom);\r\n      NodeFrom := GetNextVisible(NodeFrom, True);\r\n    end;\r\n    // Deselect last node too.\r\n    InternalRemoveFromSelection(NodeFrom);\r\n\r\n    // Do some housekeeping.\r\n    NewSize := PackArray(FSelection, FSelectionCount);\r\n    if NewSize > -1 then\r\n    begin\r\n      FSelectionCount := NewSize;\r\n      SetLength(FSelection, FSelectionCount);\r\n    end;\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.UpdateColumnCheckState(Col: TVirtualTreeColumn);\r\n\r\nbegin\r\n  Col.CheckState := DetermineNextCheckState(Col.CheckType, Col.CheckState);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.UpdateDesigner;\r\n\r\nvar\r\n  ParentForm: TCustomForm;\r\n\r\nbegin\r\n  if (csDesigning in ComponentState) and not (csUpdating in ComponentState) then\r\n  begin\r\n    ParentForm := GetParentForm(Self);\r\n    if Assigned(ParentForm) and Assigned(ParentForm.Designer) then\r\n      ParentForm.Designer.Modified;\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.UpdateHeaderRect;\r\n\r\n// Calculates the rectangle the header occupies in non-client area.\r\n// These coordinates are in window rectangle.\r\n\r\nvar\r\n  OffsetX,\r\n  OffsetY: Integer;\r\n  EdgeSize: Integer;\r\n  Size: TSize;\r\n\r\nbegin\r\n  FHeaderRect := Rect(0, 0, Width, Height);\r\n\r\n  // Consider borders...\r\n  Size := GetBorderDimensions;\r\n  InflateRect(FHeaderRect, Size.cx, Size.cy);\r\n\r\n  // ... and bevels.\r\n  OffsetX := BorderWidth;\r\n  OffsetY := BorderWidth;\r\n  if BevelKind <> bkNone then\r\n  begin\r\n    EdgeSize := 0;\r\n    if BevelInner <> bvNone then\r\n      Inc(EdgeSize, BevelWidth);\r\n    if BevelOuter <> bvNone then\r\n      Inc(EdgeSize, BevelWidth);\r\n    if beLeft in BevelEdges then\r\n      Inc(OffsetX, EdgeSize);\r\n    if beTop in BevelEdges then\r\n      Inc(OffsetY, EdgeSize);\r\n  end;\r\n\r\n  InflateRect(FHeaderRect, -OffsetX, -OffsetY);\r\n\r\n  if hoVisible in FHeader.FOptions then\r\n  begin\r\n    if FHeaderRect.Left <= FHeaderRect.Right then\r\n      FHeaderRect.Bottom := FHeaderRect.Top + Integer(FHeader.FHeight)\r\n    else\r\n      FHeaderRect := Rect(0, 0, 0, 0);\r\n  end\r\n  else\r\n    FHeaderRect.Bottom := FHeaderRect.Top;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.UpdateEditBounds;\r\n\r\n// Used to update the bounds of the current node editor if editing is currently active.\r\n\r\nvar\r\n  R: TRect;\r\n  Dummy: Integer;\r\n  CurrentAlignment: TAlignment;\r\n  CurrentBidiMode: TBidiMode;\r\n\r\nbegin\r\n  if (tsEditing in FStates) and Assigned(FFocusedNode) and\r\n     (FEditColumn < FHeader.Columns.Count) then // prevent EArgumentOutOfRangeException\r\n  begin\r\n    if (GetCurrentThreadId <> MainThreadID) then\r\n    begin\r\n      // UpdateEditBounds() will be called at the end of the thread\r\n      Exit;\r\n    end;\r\n    if vsMultiline in FFocusedNode.States then\r\n      R := GetDisplayRect(FFocusedNode, FEditColumn, True, False)\r\n    else\r\n      R := GetDisplayRect(FFocusedNode, FEditColumn, True, True);\r\n    if (toGridExtensions in FOptions.FMiscOptions) then\r\n    begin\r\n      // Adjust edit bounds depending on alignment and bidi mode.\r\n      if FEditColumn <= NoColumn then\r\n      begin\r\n        CurrentAlignment := Alignment;\r\n        CurrentBidiMode := BiDiMode;\r\n      end\r\n      else\r\n      begin\r\n        CurrentAlignment := FHeader.Columns[FEditColumn].FAlignment;\r\n        CurrentBidiMode := FHeader.Columns[FEditColumn].FBiDiMode;\r\n      end;\r\n      // Consider bidi mode here. In RTL context does left alignment actually mean right alignment and vice versa.\r\n      if CurrentBidiMode <> bdLeftToRight then\r\n        ChangeBiDiModeAlignment(CurrentAlignment);\r\n      if CurrentAlignment = taLeftJustify then\r\n        FHeader.Columns.GetColumnBounds(FEditColumn, Dummy, R.Right)\r\n      else\r\n        FHeader.Columns.GetColumnBounds(FEditColumn, R.Left, Dummy);\r\n    end;\r\n    if toShowHorzGridLines in TreeOptions.PaintOptions then\r\n      Dec(R.Bottom);\r\n    R.Bottom := R.Top + Max(R.Bottom - R.Top, FEditLink.GetBounds.Bottom - FEditLink.GetBounds.Top); // Ensure to never decrease the size of the currently active edit control. Helps to prevent issue #159\r\n    FEditLink.SetBounds(R);\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nconst\r\n  ScrollMasks: array[Boolean] of Cardinal = (0, SIF_DISABLENOSCROLL);\r\n\r\nconst // Region identifiers for GetRandomRgn\r\n  CLIPRGN = 1;\r\n  METARGN = 2;\r\n  APIRGN = 3;\r\n  SYSRGN = 4;\r\n\r\nfunction GetRandomRgn(DC: HDC; Rgn: HRGN; iNum: Integer): Integer; stdcall; external 'GDI32.DLL';\r\n\r\nprocedure TBaseVirtualTree.UpdateWindowAndDragImage(const Tree: TBaseVirtualTree; TreeRect: TRect; UpdateNCArea,\r\n  ReshowDragImage: Boolean);\r\n\r\n// Method to repaint part of the window area which is not covered by the drag image and to initiate a recapture\r\n// of the drag image.\r\n// Note: This method must only be called during a drag operation and the tree passed in is the one managing the current\r\n// drag image (so it is the actual drag source).\r\n\r\nvar\r\n  DragRegion,          // the region representing the drag image\r\n  UpdateRegion,        // the unclipped region within the tree to be updated\r\n  NCRegion: HRGN;      // the region representing the non-client area of the tree\r\n  DragRect,\r\n  NCRect: TRect;\r\n  RedrawFlags: Cardinal;\r\n\r\n  VisibleTreeRegion: HRGN;\r\n\r\n  DC: HDC;\r\n\r\nbegin\r\n  if IntersectRect(TreeRect, TreeRect, ClientRect) then\r\n  begin\r\n    // Retrieve the visible region of the window. This is important to avoid overpainting parts of other windows\r\n    // which overlap this one.\r\n    VisibleTreeRegion := CreateRectRgn(0, 0, 1, 1);\r\n    DC := GetDCEx(Handle, 0, DCX_CACHE or DCX_WINDOW or DCX_CLIPSIBLINGS or DCX_CLIPCHILDREN);\r\n    GetRandomRgn(DC, VisibleTreeRegion, SYSRGN);\r\n    ReleaseDC(Handle, DC);\r\n\r\n    // The drag image will figure out itself what part of the rectangle can be recaptured.\r\n    // Recapturing is not done by taking a snapshot of the screen, but by letting the tree draw itself\r\n    // into the back bitmap of the drag image. So the order here is unimportant.\r\n    Tree.FDragImage.RecaptureBackground(Self, TreeRect, VisibleTreeRegion, UpdateNCArea, ReshowDragImage);\r\n\r\n    // Calculate the screen area not covered by the drag image and which needs an update.\r\n    DragRect := Tree.FDragImage.GetDragImageRect;\r\n    MapWindowPoints(0, Handle, DragRect, 2);\r\n    DragRegion := CreateRectRgnIndirect(DragRect);\r\n\r\n    // Start with non-client area if requested.\r\n    if UpdateNCArea then\r\n    begin\r\n      // Compute the part of the non-client area which must be updated.\r\n\r\n      // Determine the outer rectangle of the entire tree window.\r\n      GetWindowRect(Handle, NCRect);\r\n      // Express the tree window rectangle in client coordinates (because RedrawWindow wants them so).\r\n      MapWindowPoints(0, Handle, NCRect, 2);\r\n      NCRegion := CreateRectRgnIndirect(NCRect);\r\n      // Determine client rect in screen coordinates and create another region for it.\r\n      UpdateRegion := CreateRectRgnIndirect(ClientRect);\r\n      // Create a region which only contains the NC part by subtracting out the client area.\r\n      CombineRgn(NCRegion, NCRegion, UpdateRegion, RGN_DIFF);\r\n      // Subtract also out what is hidden by the drag image.\r\n      CombineRgn(NCRegion, NCRegion, DragRegion, RGN_DIFF);\r\n      RedrawWindow(Handle, nil, NCRegion, RDW_FRAME or RDW_NOERASE or RDW_NOCHILDREN or RDW_INVALIDATE or RDW_VALIDATE or\r\n        RDW_UPDATENOW);\r\n      DeleteObject(NCRegion);\r\n      DeleteObject(UpdateRegion);\r\n    end;\r\n\r\n    UpdateRegion := CreateRectRgnIndirect(TreeRect);\r\n    RedrawFlags := RDW_INVALIDATE or RDW_VALIDATE or RDW_UPDATENOW or RDW_NOERASE or RDW_NOCHILDREN;\r\n    // Remove the part of the update region which is covered by the drag image.\r\n    CombineRgn(UpdateRegion, UpdateRegion, DragRegion, RGN_DIFF);\r\n    RedrawWindow(Handle, nil, UpdateRegion, RedrawFlags);\r\n    DeleteObject(UpdateRegion);\r\n    DeleteObject(DragRegion);\r\n    DeleteObject(VisibleTreeRegion);\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.ValidateCache;\r\n\r\n// Starts cache validation if not already done by adding this instance to the worker thread's waiter list\r\n// (if not already there) and signalling the thread it can start validating.\r\n\r\nbegin\r\n  // Wait for thread to stop validation if it is currently validating this tree's cache.\r\n  InterruptValidation;\r\n\r\n  FStartIndex := 0;\r\n  if (tsValidationNeeded in FStates) and (FVisibleCount > CacheThreshold) and Assigned(WorkerThread) then\r\n  begin\r\n    // Tell the thread this tree needs actually something to do.\r\n    WorkerThread.AddTree(Self);\r\n    SetEvent(WorkEvent);\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.ValidateNodeDataSize(var Size: Integer);\r\n\r\nbegin\r\n  Size := SizeOf(Pointer);\r\n  if Assigned(FOnGetNodeDataSize) then\r\n    FOnGetNodeDataSize(Self, Size);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.VclStyleChanged;\r\n\r\n  // Updates the member FVclStyleEnabled, should be called initially and when the VCL style changes\r\n\r\nbegin\r\n  FVclStyleEnabled := StyleServices.Enabled and not StyleServices.IsSystemStyle;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\n//PROFILE-NO\r\nprocedure TBaseVirtualTree.WndProc(var Message: TMessage);\r\n\r\nvar\r\n  Handled: Boolean;\r\n\r\nbegin\r\n  Handled := False;\r\n\r\n  // Try the header whether it needs to take this message.\r\n  if Assigned(FHeader) and (FHeader.FStates <> []) then\r\n    Handled := FHeader.HandleMessage(Message);\r\n  if not Handled then\r\n  begin\r\n    // For auto drag mode, let tree handle itself, instead of TControl.\r\n    if not (csDesigning in ComponentState) and\r\n       ((Message.Msg = WM_LBUTTONDOWN) or (Message.Msg = WM_LBUTTONDBLCLK)) then\r\n    begin\r\n      if (DragMode = dmAutomatic) and (DragKind = dkDrag) then\r\n      begin\r\n        if IsControlMouseMsg(TWMMouse(Message)) then\r\n          Handled := True;\r\n        if not Handled then\r\n        begin\r\n          ControlState := ControlState + [csLButtonDown];\r\n          Dispatch(Message);  // overrides TControl's BeginDrag\r\n          Handled := True;\r\n        end;\r\n      end;\r\n    end;\r\n\r\n    if not Handled and Assigned(FHeader) then\r\n      Handled := FHeader.HandleMessage(Message);\r\n\r\n    if not Handled then\r\n    begin\r\n      if (Message.Msg in [WM_NCLBUTTONDOWN, WM_NCRBUTTONDOWN, WM_NCMBUTTONDOWN]) and not Focused and CanFocus then\r\n        SetFocus;\r\n      inherited;\r\n    end;\r\n  end;\r\nend;\r\n//PROFILE-YES\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.WriteChunks(Stream: TStream; Node: PVirtualNode);\r\n\r\n// Writes the core chunks for Node into the stream.\r\n// Note: descendants can optionally override this method to add other node specific chunks.\r\n//       Keep in mind that this method is also called for the root node. Using this fact in descendants you can\r\n//       create a kind of \"global\" chunks not directly bound to a specific node.\r\n\r\nvar\r\n  Header: TChunkHeader;\r\n  LastPosition,\r\n  ChunkSize: Integer;\r\n  Chunk: TBaseChunk;\r\n  Run: PVirtualNode;\r\n\r\nbegin\r\n  with Stream do\r\n  begin\r\n    // 1. The base chunk...\r\n    LastPosition := Position;\r\n    Chunk.Header.ChunkType := BaseChunk;\r\n    with Node^, Chunk do\r\n    begin\r\n      Body.ChildCount := ChildCount;\r\n      Body.NodeHeight := NodeHeight;\r\n      // Some states are only temporary so take them out as they make no sense at the new location.\r\n      Body.States := States - [vsChecking, vsCutOrCopy, vsDeleting, vsOnFreeNodeCallRequired, vsHeightMeasured];\r\n      Body.Align := Align;\r\n      Body.CheckState := CheckState;\r\n      Body.CheckType := CheckType;\r\n      Body.Reserved := 0;\r\n    end;\r\n    // write the base chunk\r\n    Write(Chunk, SizeOf(Chunk));\r\n\r\n    // 2. ... directly followed by the child node chunks (actually they are child chunks of\r\n    //   the base chunk)\r\n    if vsInitialized in Node.States then\r\n    begin\r\n      Run := Node.FirstChild;\r\n      while Assigned(Run) do\r\n      begin\r\n        WriteNode(Stream, Run);\r\n        Run := Run.NextSibling;\r\n      end;\r\n    end;\r\n\r\n    FinishChunkHeader(Stream, LastPosition, Position);\r\n\r\n    // 3. write user data\r\n    LastPosition := Position;\r\n    Header.ChunkType := UserChunk;\r\n    Write(Header, SizeOf(Header));\r\n    DoSaveUserData(Node, Stream);\r\n    // check if the application actually wrote data\r\n    ChunkSize := Position - LastPosition - SizeOf(TChunkHeader);\r\n    // seek back to start of chunk if nothing has been written\r\n    if ChunkSize = 0 then\r\n    begin\r\n      Position := LastPosition;\r\n      Size := Size - SizeOf(Header);\r\n    end\r\n    else\r\n      FinishChunkHeader(Stream, LastPosition, Position);\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.WriteNode(Stream: TStream; Node: PVirtualNode);\r\n\r\n// Writes the \"cover\" chunk for Node to Stream and initiates writing child nodes and chunks.\r\n\r\nvar\r\n  LastPosition: Integer;\r\n  Header: TChunkHeader;\r\n\r\nbegin\r\n  // Initialize the node first if necessary and wanted.\r\n  if toInitOnSave in FOptions.FMiscOptions then\r\n  begin\r\n    if not (vsInitialized in Node.States) then\r\n      InitNode(Node);\r\n    if (vsHasChildren in Node.States) and (Node.ChildCount = 0) then\r\n      InitChildren(Node);\r\n  end;\r\n\r\n  with Stream do\r\n  begin\r\n    LastPosition := Position;\r\n    // Emit the anchor chunk.\r\n    Header.ChunkType := NodeChunk;\r\n    Write(Header, SizeOf(Header));\r\n    // Write other chunks to stream taking their size into this chunk's size.\r\n    WriteChunks(Stream, Node);\r\n\r\n    // Update chunk size.\r\n    FinishChunkHeader(Stream, LastPosition, Position);\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TBaseVirtualTree.AbsoluteIndex(Node: PVirtualNode): Cardinal;\r\n\r\nbegin\r\n  Result := 0;\r\n  while Assigned(Node) and (Node <> FRoot) do\r\n  begin\r\n    if not (vsInitialized in Node.States) then\r\n      InitNode(Node);\r\n    if Assigned(Node.PrevSibling) then\r\n    begin\r\n      // if there's a previous sibling then add its total count to the result\r\n      Node := Node.PrevSibling;\r\n      Inc(Result, Node.TotalCount);\r\n    end\r\n    else\r\n    begin\r\n      Node := Node.Parent;\r\n      if Node <> FRoot then\r\n        Inc(Result);\r\n    end;\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TBaseVirtualTree.AddChild(Parent: PVirtualNode; UserData: Pointer = nil): PVirtualNode;\r\n\r\n// Adds a new node to the given parent node. This is simply done by increasing the child count of the\r\n// parent node. If Parent is nil then the new node is added as (last) top level node.\r\n// UserData can be used to set the first SizeOf(Pointer) bytes of the user data area to an initial value which can be used\r\n// in OnInitNode and will also cause to trigger the OnFreeNode event (if <> nil) even if the node is not yet\r\n// \"officially\" initialized.\r\n// AddChild is a compatibility method and will implicitly validate the parent node. This is however\r\n// against the virtual paradigm and hence I dissuade from its usage.\r\n\r\nbegin\r\n  if not (toReadOnly in FOptions.FMiscOptions) then\r\n  begin\r\n    CancelEditNode;\r\n\r\n    if Parent = nil then\r\n      Parent := FRoot;\r\n    if not (vsInitialized in Parent.States) then\r\n      InitNode(Parent);\r\n\r\n    // Locally stop updates of the tree in order to avoid usage of the new node before it is correctly set up.\r\n    // If the update count was 0 on enter then there will be a correct update at the end of this method.\r\n    Inc(FUpdateCount);\r\n    try\r\n      SetChildCount(Parent, Parent.ChildCount + 1);\r\n      // Update the hidden children flag of the parent. Nodes are added as being visible by default.\r\n      Exclude(Parent.States, vsAllChildrenHidden);\r\n    finally\r\n      Dec(FUpdateCount);\r\n    end;\r\n    Result := Parent.LastChild;\r\n    //TODO: The above code implicitely triggers OnMeasureItem, but the NodeData is not set then. Consider doing this similar to InsertNode() with a combination of MakeNewNode and InternalConnectNode()\r\n\r\n    if Assigned(UserData) then\r\n      SetNodeData(Result, UserData);\r\n\r\n    InvalidateCache;\r\n    if FUpdateCount = 0 then\r\n    begin\r\n      ValidateCache;\r\n      if tsStructureChangePending in FStates then\r\n      begin\r\n        if Parent = FRoot then\r\n          StructureChange(nil, crChildAdded)\r\n        else\r\n          StructureChange(Parent, crChildAdded);\r\n      end;\r\n\r\n      if (toAutoSort in FOptions.FAutoOptions) and (FHeader.FSortColumn > InvalidColumn) then\r\n        Sort(Parent, FHeader.FSortColumn, FHeader.FSortDirection, True);\r\n\r\n      InvalidateToBottom(Parent);\r\n      UpdateScrollBars(True);\r\n   end;\r\n  end\r\n  else\r\n    Result := nil;\r\nend;\r\n\r\nfunction TBaseVirtualTree.AddChild(Parent: PVirtualNode; const UserData: IInterface): PVirtualNode;\r\nbegin\r\n  UserData._AddRef();\r\n  Result := AddChild(Parent, Pointer(UserData));\r\n  Include(Result.States, vsReleaseCallOnUserDataRequired);\r\nend;\r\n\r\nfunction TBaseVirtualTree.AddChild(Parent: PVirtualNode; const UserData: TObject): PVirtualNode;\r\nbegin\r\n  Result := AddChild(Parent, Pointer(UserData));\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.AddFromStream(Stream: TStream; TargetNode: PVirtualNode);\r\n\r\n// loads nodes from the given stream and adds them to TargetNode\r\n// the current content is not cleared before the load process starts (see also LoadFromStream)\r\n\r\nvar\r\n  ThisID: TMagicID;\r\n  Version,\r\n  Count: Cardinal;\r\n  Node: PVirtualNode;\r\n\r\nbegin\r\n  if not (toReadOnly in FOptions.FMiscOptions) then\r\n  begin\r\n    // check first whether this is a stream we can read\r\n    Stream.ReadBuffer(ThisID, SizeOf(TMagicID));\r\n    if (ThisID[0] = MagicID[0]) and\r\n       (ThisID[1] = MagicID[1]) and\r\n       (ThisID[2] = MagicID[2]) and\r\n       (ThisID[5] = MagicID[5]) then\r\n    begin\r\n      Version := Word(ThisID[3]);\r\n      if Version <= VTTreeStreamVersion  then\r\n      begin\r\n        BeginUpdate;\r\n        try\r\n          if Version < 2 then\r\n            Count := MaxInt\r\n          else\r\n            Stream.ReadBuffer(Count, SizeOf(Count));\r\n\r\n          while (Stream.Position < Stream.Size) and (Count > 0) do\r\n          begin\r\n            Dec(Count);\r\n            Node := MakeNewNode;\r\n            InternalConnectNode(Node, TargetNode, Self, amAddChildLast);\r\n            InternalAddFromStream(Stream, Version, Node);\r\n          end;\r\n          if TargetNode = FRoot then\r\n            DoNodeCopied(nil)\r\n          else\r\n            DoNodeCopied(TargetNode);\r\n        finally\r\n          EndUpdate;\r\n        end;\r\n      end\r\n      else\r\n        ShowError(SWrongStreamVersion, hcTFWrongStreamVersion);\r\n    end\r\n    else\r\n      ShowError(SWrongStreamVersion, hcTFWrongStreamVersion);\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.AfterConstruction;\r\n\r\nbegin\r\n  inherited;\r\n\r\n  if FRoot = nil then\r\n    InitRootNode;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.Assign(Source: TPersistent);\r\n\r\nbegin\r\n  if (Source is TBaseVirtualTree) and not (toReadOnly in FOptions.FMiscOptions) then\r\n    with Source as TBaseVirtualTree do\r\n    begin\r\n      Self.Align := Align;\r\n      Self.Anchors := Anchors;\r\n      Self.AutoScrollDelay := AutoScrollDelay;\r\n      Self.AutoScrollInterval := AutoScrollInterval;\r\n      Self.AutoSize := AutoSize;\r\n      Self.Background := Background;\r\n      Self.BevelEdges := BevelEdges;\r\n      Self.BevelInner := BevelInner;\r\n      Self.BevelKind := BevelKind;\r\n      Self.BevelOuter := BevelOuter;\r\n      Self.BevelWidth := BevelWidth;\r\n      Self.BiDiMode := BiDiMode;\r\n      Self.BorderStyle := BorderStyle;\r\n      Self.BorderWidth := BorderWidth;\r\n      Self.ChangeDelay := ChangeDelay;\r\n      Self.CheckImageKind := CheckImageKind;\r\n      Self.Color := Color;\r\n      Self.Colors.Assign(Colors);\r\n      Self.Constraints.Assign(Constraints);\r\n      Self.Ctl3D := Ctl3D;\r\n      Self.DefaultNodeHeight := DefaultNodeHeight;\r\n      Self.DefaultPasteMode := DefaultPasteMode;\r\n      Self.DragCursor := DragCursor;\r\n      Self.DragImageKind := DragImageKind;\r\n      Self.DragKind := DragKind;\r\n      Self.DragMode := DragMode;\r\n      Self.Enabled := Enabled;\r\n      Self.Font := Font;\r\n      Self.Header := Header;\r\n      Self.HintAnimation := HintAnimation;\r\n      Self.HintMode := HintMode;\r\n      Self.HotCursor := HotCursor;\r\n      Self.Images := Images;\r\n      Self.ImeMode := ImeMode;\r\n      Self.ImeName := ImeName;\r\n      Self.Indent := Indent;\r\n      Self.Margin := Margin;\r\n      Self.NodeAlignment := NodeAlignment;\r\n      Self.NodeDataSize := NodeDataSize;\r\n      Self.TreeOptions := TreeOptions;\r\n      Self.ParentBiDiMode := ParentBiDiMode;\r\n      Self.ParentColor := ParentColor;\r\n      Self.ParentCtl3D := ParentCtl3D;\r\n      Self.ParentFont := ParentFont;\r\n      Self.ParentShowHint := ParentShowHint;\r\n      Self.PopupMenu := PopupMenu;\r\n      Self.RootNodeCount := RootNodeCount;\r\n      Self.ScrollBarOptions := ScrollBarOptions;\r\n      Self.ShowHint := ShowHint;\r\n      Self.StateImages := StateImages;\r\n      Self.StyleElements := StyleElements;\r\n      Self.TabOrder := TabOrder;\r\n      Self.TabStop := TabStop;\r\n      Self.Visible := Visible;\r\n      Self.SelectionCurveRadius := SelectionCurveRadius;\r\n      Self.SelectionBlendFactor := SelectionBlendFactor;\r\n      Self.EmptyListMessage := EmptyListMessage;\r\n    end\r\n    else\r\n      inherited;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.AutoScale();\r\n\r\n// If toAutoChangeScale is set, this method ensures that the defaulz node height is set corectly.\r\n\r\nvar\r\n  lTextHeight: Cardinal;\r\nbegin\r\n  if (toAutoChangeScale in TreeOptions.AutoOptions) then\r\n  begin\r\n    Canvas.Font.Assign(Self.Font);\r\n    lTextHeight := Canvas.TextHeight('Tg');\r\n    if (lTextHeight > Self.DefaultNodeHeight) then\r\n      Self.DefaultNodeHeight := lTextHeight;\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.BeginDrag(Immediate: Boolean; Threshold: Integer);\r\n\r\n// Reintroduced method to allow to start OLE drag'n drop as well as VCL drag'n drop.\r\n\r\nbegin\r\n  if FDragType = dtVCL then\r\n  begin\r\n    DoStateChange([tsVCLDragPending]);\r\n    inherited;\r\n  end\r\n  else\r\n    if (FStates * [tsOLEDragPending, tsOLEDragging]) = [] then\r\n    begin\r\n      // Drag start position has already been recorded in WMMouseDown.\r\n      if Threshold < 0 then\r\n        FDragThreshold := Mouse.DragThreshold\r\n      else\r\n        FDragThreshold := Threshold;\r\n      if Immediate then\r\n        DoDragging(FLastClickPos)\r\n      else\r\n        DoStateChange([tsOLEDragPending]);\r\n    end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.BeginSynch;\r\n\r\n// Starts the synchronous update mode (if not already active).\r\n\r\nbegin\r\n  if not (csDestroying in ComponentState) then\r\n  begin\r\n    if FSynchUpdateCount = 0 then\r\n    begin\r\n      DoUpdating(usBeginSynch);\r\n\r\n      // Stop all timers...\r\n      StopTimer(ChangeTimer);\r\n      StopTimer(StructureChangeTimer);\r\n      StopTimer(ExpandTimer);\r\n      StopTimer(EditTimer);\r\n      StopTimer(HeaderTimer);\r\n      StopTimer(ScrollTimer);\r\n      StopTimer(SearchTimer);\r\n      FSearchBuffer := '';\r\n      FLastSearchNode := nil;\r\n      DoStateChange([], [tsEditPending, tsScrollPending, tsScrolling, tsIncrementalSearching]);\r\n\r\n      // ...and trigger pending update states.\r\n      if tsStructureChangePending in FStates then\r\n        DoStructureChange(FLastStructureChangeNode, FLastStructureChangeReason);\r\n      if tsChangePending in FStates then\r\n        DoChange(FLastChangedNode);\r\n    end\r\n    else\r\n      DoUpdating(usSynch);\r\n  end;\r\n  Inc(FSynchUpdateCount);\r\n  DoStateChange([tsSynchMode]);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.BeginUpdate;\r\n\r\nbegin\r\n  if not (csDestroying in ComponentState) then\r\n  begin\r\n    if FUpdateCount = 0 then\r\n    begin\r\n      DoUpdating(usBegin);\r\n      SetUpdateState(True);\r\n    end\r\n    else\r\n      DoUpdating(usUpdate);\r\n  end;\r\n  Inc(FUpdateCount);\r\n  DoStateChange([tsUpdating]);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.CancelCutOrCopy;\r\n\r\n// Resets nodes which are marked as being cut.\r\n\r\nvar\r\n  Run: PVirtualNode;\r\n\r\nbegin\r\n  if ([tsCutPending, tsCopyPending] * FStates) <> [] then\r\n  begin\r\n    Run := FRoot.FirstChild;\r\n    while Assigned(Run) do\r\n    begin\r\n      if vsCutOrCopy in Run.States then\r\n        Exclude(Run.States, vsCutOrCopy);\r\n      Run := GetNextNoInit(Run);\r\n    end;\r\n  end;\r\n  DoStateChange([], [tsCutPending, tsCopyPending]);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TBaseVirtualTree.CancelEditNode: Boolean;\r\n\r\n// Called by the application or the current edit link to cancel the edit action.\r\n\r\nbegin\r\n  if HandleAllocated and ([tsEditing, tsEditPending] * FStates <> []) then\r\n    Result := DoCancelEdit\r\n  else\r\n    Result := True;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.CancelOperation;\r\n\r\n// Called by the application to cancel a long-running operation.\r\n\r\nbegin\r\n  if FOperationCount > 0 then\r\n    FOperationCanceled := True;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TBaseVirtualTree.CanEdit(Node: PVirtualNode; Column: TColumnIndex): Boolean;\r\n\r\n// Returns True if the given node can be edited.\r\n\r\nbegin\r\n  Result := (toEditable in FOptions.FMiscOptions) and Enabled and not (toReadOnly in FOptions.FMiscOptions)\r\n    and ((Column < 0) or (coEditable in FHeader.Columns[Column].Options));\r\n  DoCanEdit(Node, Column, Result);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TBaseVirtualTree.CanFocus: Boolean;\r\n\r\nvar\r\n  Form: TCustomForm;\r\n\r\nbegin\r\n  Result := inherited CanFocus;\r\n\r\n  if Result and not (csDesigning in ComponentState) then\r\n  begin\r\n    Form := GetParentForm(Self);\r\n    Result := (Form = nil) or (Form.Enabled and Form.Visible);\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.Clear;\r\n\r\nbegin\r\n  if not (toReadOnly in FOptions.FMiscOptions) or (csDestroying in ComponentState) then\r\n  begin\r\n    BeginUpdate;\r\n    try\r\n      InterruptValidation;\r\n      if IsEditing then\r\n        CancelEditNode;\r\n\r\n      if ClipboardStates * FStates <> [] then\r\n      begin\r\n        OleSetClipboard(nil);\r\n        DoStateChange([], ClipboardStates);\r\n      end;\r\n      ClearSelection;\r\n      FFocusedNode := nil;\r\n      FLastSelected := nil;\r\n      FCurrentHotNode := nil;\r\n      FDropTargetNode := nil;\r\n      FLastChangedNode := nil;\r\n      FRangeAnchor := nil;\r\n      FCheckNode := nil;\r\n      FLastVCLDragTarget := nil;\r\n      FLastSearchNode := nil;\r\n      DeleteChildren(FRoot, True);\r\n      FOffsetX := 0;\r\n      FOffsetY := 0;\r\n\r\n    finally\r\n      EndUpdate;\r\n    end;\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.ClearChecked;\r\n\r\nvar\r\n  Node: PVirtualNode;\r\n\r\nbegin\r\n  Node := RootNode.FirstChild;\r\n  while Assigned(Node) do\r\n  begin\r\n    if Node.CheckState <> csUncheckedNormal then\r\n      CheckState[Node] := csUncheckedNormal;\r\n    Node := GetNextNoInit(Node);\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.ClearSelection;\r\n\r\nvar\r\n  Node: PVirtualNode;\r\n  Dummy: Integer;\r\n  R: TRect;\r\n  Counter: Integer;\r\n\r\nbegin\r\n  if not FSelectionLocked and (FSelectionCount > 0) and not (csDestroying in ComponentState) then\r\n  begin\r\n    if (FUpdateCount = 0) and HandleAllocated and (FVisibleCount > 0) then\r\n    begin\r\n      // Iterate through nodes currently visible in the client area and invalidate them.\r\n      Node := GetNodeAt(0, 0, True, Dummy);\r\n      if Assigned(Node) then\r\n        R := GetDisplayRect(Node, NoColumn, False);\r\n      Counter := FSelectionCount;\r\n\r\n      while Assigned(Node) do\r\n      begin\r\n        R.Bottom := R.Top + Integer(NodeHeight[Node]);\r\n        if vsSelected in Node.States then\r\n        begin\r\n          InvalidateRect(Handle, @R, False);\r\n          Dec(Counter);\r\n          // Only try as many nodes as are selected.\r\n          if Counter = 0 then\r\n            Break;\r\n        end;\r\n        R.Top := R.Bottom;\r\n        if R.Top > ClientHeight then\r\n          Break;\r\n        Node := GetNextVisibleNoInit(Node, True);\r\n      end;\r\n    end;\r\n\r\n    InternalClearSelection;\r\n    Change(nil);\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TBaseVirtualTree.CopyTo(Source: PVirtualNode; Tree: TBaseVirtualTree; Mode: TVTNodeAttachMode;\r\n  ChildrenOnly: Boolean): PVirtualNode;\r\n\r\n// A simplified CopyTo method to allow to copy nodes to the root of another tree.\r\n\r\nbegin\r\n  Result := CopyTo(Source, Tree.FRoot, Mode, ChildrenOnly);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TBaseVirtualTree.CopyTo(Source, Target: PVirtualNode; Mode: TVTNodeAttachMode;\r\n  ChildrenOnly: Boolean): PVirtualNode;\r\n\r\n// Copies Source and all its child nodes to Target.\r\n// Mode is used to specify further where to add the new node actually (as sibling of Target or as child of Target).\r\n// Result is the newly created node to which source has been copied if ChildrenOnly is False or just contains Target\r\n// in the other case.\r\n// ChildrenOnly determines whether to copy also the source node or only its child nodes.\r\n\r\nvar\r\n  TargetTree: TBaseVirtualTree;\r\n  Stream: TMemoryStream;\r\n\r\nbegin\r\n  Assert(TreeFromNode(Source) = Self, 'The source tree must contain the source node.');\r\n\r\n  Result := nil;\r\n  if (Mode <> amNoWhere) and Assigned(Source) and (Source <> FRoot) then\r\n  begin\r\n    // Assume that an empty destination means the root in this (the source) tree.\r\n    if Target = nil then\r\n    begin\r\n      TargetTree := Self;\r\n      Target := FRoot;\r\n      Mode := amAddChildFirst;\r\n    end\r\n    else\r\n      TargetTree := TreeFromNode(Target);\r\n\r\n    if not (toReadOnly in TargetTree.FOptions.FMiscOptions) then\r\n    begin\r\n      if Target = TargetTree.FRoot then\r\n      begin\r\n        case Mode of\r\n          amInsertBefore:\r\n            Mode := amAddChildFirst;\r\n          amInsertAfter:\r\n            Mode := amAddChildLast;\r\n        end;\r\n      end;\r\n\r\n      Stream := TMemoryStream.Create;\r\n      try\r\n        // Write all nodes into a temprary stream depending on the ChildrenOnly flag.\r\n        if not ChildrenOnly then\r\n          WriteNode(Stream, Source)\r\n        else\r\n        begin\r\n          Source := Source.FirstChild;\r\n          while Assigned(Source) do\r\n          begin\r\n            WriteNode(Stream, Source);\r\n            Source := Source.NextSibling;\r\n          end;\r\n        end;\r\n        // Now load the serialized nodes into the target node (tree).\r\n        TargetTree.BeginUpdate;\r\n        try\r\n          Stream.Position := 0;\r\n          while Stream.Position < Stream.Size do\r\n          begin\r\n            Result := TargetTree.MakeNewNode;\r\n            InternalConnectNode(Result, Target, TargetTree, Mode);\r\n            TargetTree.InternalAddFromStream(Stream, VTTreeStreamVersion, Result);\r\n            if not DoNodeCopying(Result, Target) then\r\n            begin\r\n              TargetTree.DeleteNode(Result);\r\n              Result := nil;\r\n            end\r\n            else\r\n              DoNodeCopied(Result);\r\n          end;\r\n          if ChildrenOnly then\r\n            Result := Target;\r\n        finally\r\n          TargetTree.EndUpdate;\r\n        end;\r\n      finally\r\n        Stream.Free;\r\n      end;\r\n\r\n      with TargetTree do\r\n      begin\r\n        InvalidateCache;\r\n        if FUpdateCount = 0 then\r\n        begin\r\n          ValidateCache;\r\n          UpdateScrollBars(True);\r\n          Invalidate;\r\n        end;\r\n        StructureChange(Source, crNodeCopied);\r\n      end;\r\n    end;\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.CopyToClipboard;\r\n\r\nvar\r\n  DataObject: IDataObject;\r\n\r\nbegin\r\n  if FSelectionCount > 0 then\r\n  begin\r\n    DataObject := TVTDataObject.Create(Self, True) as IDataObject;\r\n    if OleSetClipboard(DataObject) = S_OK then\r\n    begin\r\n      MarkCutCopyNodes;\r\n      DoStateChange([tsCopyPending]);\r\n      Invalidate;\r\n    end;\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.CutToClipboard;\r\nbegin\r\n  if (FSelectionCount > 0) and not (toReadOnly in FOptions.FMiscOptions) then\r\n  begin\r\n    if OleSetClipboard(TVTDataObject.Create(Self, True)) = S_OK then\r\n    begin\r\n      MarkCutCopyNodes;\r\n      DoStateChange([tsCutPending], [tsCopyPending]);\r\n      Invalidate;\r\n    end;\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.DeleteChildren(Node: PVirtualNode; ResetHasChildren: Boolean = False);\r\n\r\n// Removes all children and their children from memory without changing the vsHasChildren style by default.\r\n\r\nvar\r\n  Run,\r\n  Mark: PVirtualNode;\r\n  LastTop,\r\n  LastLeft,\r\n  NewSize: Integer;\r\n  ParentVisible: Boolean;\r\n\r\nbegin\r\n  if Assigned(Node) and (Node.ChildCount > 0) and not (toReadOnly in FOptions.FMiscOptions) then\r\n  begin\r\n    Assert(not (tsIterating in FStates), 'Deleting nodes during tree iteration leads to invalid pointers.');\r\n\r\n    // The code below uses some flags for speed improvements which may cause invalid pointers if updates of\r\n    // the tree happen. Hence switch updates off until we have finished the operation.\r\n    Inc(FUpdateCount);\r\n    try\r\n      InterruptValidation;\r\n      LastLeft := -FEffectiveOffsetX;\r\n      LastTop := FOffsetY;\r\n\r\n      // Make a local copy of the visibility state of this node to speed up\r\n      // adjusting the visible nodes count.\r\n      ParentVisible := Node = FRoot;\r\n      if not ParentVisible then\r\n        ParentVisible := FullyVisible[Node] and (vsExpanded in Node.States);\r\n\r\n      // Show that we are clearing the child list, to avoid registering structure change events.\r\n      Run := Node.LastChild;\r\n      while Assigned(Run) do\r\n      begin\r\n        if ParentVisible and IsEffectivelyVisible[Run] then\r\n          Dec(FVisibleCount);\r\n\r\n        Include(Run.States, vsDeleting);\r\n        Mark := Run;\r\n        Run := Run.PrevSibling;\r\n        // Important, to avoid exchange of invalid pointers while disconnecting the node.\r\n        if Assigned(Run) then\r\n          Run.NextSibling := nil;\r\n        DeleteNode(Mark, False, True);\r\n      end;\r\n      if ResetHasChildren then\r\n        Exclude(Node.States, vsHasChildren);\r\n      if Node <> FRoot then\r\n        Exclude(Node.States, vsExpanded);\r\n      Node.ChildCount := 0;\r\n      if (Node = FRoot) or (vsDeleting in Node.States) then\r\n      begin\r\n        Node.TotalHeight := FDefaultNodeHeight + NodeHeight[Node];\r\n        Node.TotalCount := 1;\r\n      end\r\n      else\r\n      begin\r\n        AdjustTotalHeight(Node, NodeHeight[Node]);\r\n        AdjustTotalCount(Node, 1);\r\n      end;\r\n      Node.FirstChild := nil;\r\n      Node.LastChild := nil;\r\n    finally\r\n      Dec(FUpdateCount);\r\n    end;\r\n\r\n    InvalidateCache;\r\n    if FUpdateCount = 0 then\r\n    begin\r\n      NewSize := PackArray(FSelection, FSelectionCount);\r\n      if NewSize > -1 then\r\n      begin\r\n        FSelectionCount := NewSize;\r\n        SetLength(FSelection, FSelectionCount);\r\n      end;\r\n\r\n      ValidateCache;\r\n      UpdateScrollBars(True);\r\n      // Invalidate entire tree if it scrolled e.g. to make the last node also the\r\n      // bottom node in the treeview.\r\n      if (LastLeft <> FOffsetX) or (LastTop <> FOffsetY) then\r\n        Invalidate\r\n      else\r\n        InvalidateToBottom(Node);\r\n      if tsChangePending in FStates then begin\r\n        DoChange(FLastChangedNode);\r\n        EnsureNodeSelected();\r\n      end;\r\n    end;\r\n    StructureChange(Node, crChildDeleted);\r\n  end\r\n  else if ResetHasChildren then\r\n    Exclude(Node.States, vsHasChildren);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.DeleteNode(Node: PVirtualNode; Reindex: Boolean; ParentClearing: Boolean);\r\n\r\nvar\r\n  LastTop,\r\n  LastLeft: Integer;\r\n  LastParent: PVirtualNode;\r\n  WasInSynchMode: Boolean;\r\n\r\nbegin\r\n  if Assigned(Node) and (Node <> FRoot) and not (toReadOnly in FOptions.FMiscOptions) then\r\n  begin\r\n    Assert(not (tsIterating in FStates), 'Deleting nodes during tree iteration leads to invalid pointers.');\r\n\r\n    // Determine parent node for structure change notification.\r\n    LastParent := Node.Parent;\r\n\r\n    if not ParentClearing then\r\n    begin\r\n      if LastParent = FRoot then\r\n        StructureChange(nil, crChildDeleted)\r\n      else\r\n        StructureChange(LastParent, crChildDeleted);\r\n    end;\r\n\r\n    LastLeft := -FEffectiveOffsetX;\r\n    LastTop := FOffsetY;\r\n\r\n    if vsSelected in Node.States then\r\n    begin\r\n      if FUpdateCount = 0 then\r\n      begin\r\n        // Go temporarily into sync mode to avoid a delayed change event for the node\r\n        // when unselecting.\r\n        WasInSynchMode := tsSynchMode in FStates;\r\n        Include(FStates, tsSynchMode);\r\n        RemoveFromSelection(Node);\r\n        EnsureNodeSelected();\r\n        if not WasInSynchMode then\r\n          Exclude(FStates, tsSynchMode);\r\n        InvalidateToBottom(LastParent);\r\n      end\r\n      else\r\n        InternalRemoveFromSelection(Node);\r\n    end\r\n    else\r\n      InvalidateToBottom(LastParent);\r\n\r\n    if tsHint in FStates then\r\n    begin\r\n      Application.CancelHint;\r\n      DoStateChange([], [tsHint]);\r\n    end;\r\n\r\n    if not ParentClearing then\r\n      InterruptValidation;\r\n\r\n    DeleteChildren(Node);\r\n    InternalDisconnectNode(Node, False, Reindex);\r\n    DoFreeNode(Node);\r\n\r\n    if not ParentClearing then\r\n    begin\r\n      DetermineHiddenChildrenFlag(LastParent);\r\n      InvalidateCache;\r\n      if FUpdateCount = 0 then\r\n      begin\r\n        ValidateCache;\r\n        UpdateScrollBars(True);\r\n        // Invalidate entire tree if it scrolled e.g. to make the last node also the\r\n        // bottom node in the treeview.\r\n        if (LastLeft <> FOffsetX) or (LastTop <> FOffsetY) then\r\n          Invalidate;\r\n      end;\r\n    end;\r\n  end;\r\nend;\r\n\r\nprocedure TBaseVirtualTree.DeleteNode(Node: PVirtualNode);\r\nbegin\r\n  DeleteNode(Node, True, False);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.DeleteSelectedNodes;\r\n\r\n// Deletes all currently selected nodes (including their child nodes).\r\n\r\nvar\r\n  Nodes: TNodeArray;\r\n  I: Integer;\r\n  LevelChange: Boolean;\r\n\r\nbegin\r\n  Nodes := nil;\r\n  if (FSelectionCount > 0) and not (toReadOnly in FOptions.FMiscOptions) then\r\n  begin\r\n    BeginUpdate;\r\n    try\r\n      Nodes := GetSortedSelection(True);\r\n      for I := High(Nodes) downto 1 do\r\n      begin\r\n        LevelChange := Nodes[I].Parent <> Nodes[I - 1].Parent;\r\n        DeleteNode(Nodes[I], LevelChange, False);\r\n      end;\r\n      DeleteNode(Nodes[0]);\r\n    finally\r\n      EndUpdate;\r\n    end;\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TBaseVirtualTree.Dragging: Boolean;\r\n\r\nbegin\r\n  // Check for both OLE drag'n drop as well as VCL drag'n drop.\r\n  Result := ([tsOLEDragPending, tsOLEDragging] * FStates <> []) or inherited Dragging;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TBaseVirtualTree.EditNode(Node: PVirtualNode; Column: TColumnIndex): Boolean;\r\n\r\n// Application triggered edit event for the given node.\r\n// Returns True if the tree started editing otherwise False.\r\n\r\nbegin\r\n  Assert(Assigned(Node), 'Node must not be nil.');\r\n  Assert((Column > InvalidColumn) and (Column < FHeader.Columns.Count),\r\n    'Column must be a valid column index (-1 if no header is shown).');\r\n\r\n  Result := tsEditing in FStates;\r\n  // If the tree is already editing then we don't disrupt this.\r\n  if not Result and not (toReadOnly in FOptions.FMiscOptions) then\r\n  begin\r\n    FocusedNode := Node;\r\n    if Assigned(FFocusedNode) and (Node = FFocusedNode) and CanEdit(FFocusedNode, Column) then\r\n    begin\r\n      FEditColumn := Column;\r\n      if not (vsInitialized in Node.States) then\r\n        InitNode(Node);\r\n      DoEdit;\r\n      Result := tsEditing in FStates;\r\n    end\r\n    else\r\n      Result := False;\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TBaseVirtualTree.EndEditNode: Boolean;\r\n\r\n// Called to finish a current edit action or stop the edit timer if an edit operation is pending.\r\n// Returns True if editing was successfully ended or the control was not in edit mode\r\n// Returns False if the control could not leave the edit mode e.g. due to an invalid value that was entered.\r\n\r\nbegin\r\n  if [tsEditing, tsEditPending] * FStates <> [] then\r\n    Result := DoEndEdit\r\n  else\r\n    Result := True;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.EndSynch;\r\n\r\nbegin\r\n  if FSynchUpdateCount > 0 then\r\n    Dec(FSynchUpdateCount);\r\n\r\n  if not (csDestroying in ComponentState) then\r\n  begin\r\n    if FSynchUpdateCount = 0 then\r\n    begin\r\n      DoStateChange([], [tsSynchMode]);\r\n      DoUpdating(usEndSynch);\r\n    end\r\n    else\r\n      DoUpdating(usSynch);\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.EndUpdate;\r\n\r\nvar\r\n  NewSize: Integer;\r\n\r\nbegin\r\n  if FUpdateCount > 0 then\r\n    Dec(FUpdateCount);\r\n\r\n  if not (csDestroying in ComponentState) then\r\n  begin\r\n    if (FUpdateCount = 0) and (tsUpdating in FStates) then\r\n    begin\r\n      if tsUpdateHiddenChildrenNeeded in FStates then\r\n      begin\r\n        DetermineHiddenChildrenFlagAllNodes;\r\n        Exclude(FStates, tsUpdateHiddenChildrenNeeded);\r\n      end;\r\n\r\n      DoStateChange([], [tsUpdating]);\r\n\r\n      NewSize := PackArray(FSelection, FSelectionCount);\r\n      if NewSize > -1 then\r\n      begin\r\n        FSelectionCount := NewSize;\r\n        SetLength(FSelection, FSelectionCount);\r\n      end;\r\n\r\n      InvalidateCache;\r\n      ValidateCache;\r\n      if HandleAllocated then\r\n        UpdateScrollBars(False);\r\n\r\n      if tsStructureChangePending in FStates then\r\n        DoStructureChange(FLastStructureChangeNode, FLastStructureChangeReason);\r\n      try\r\n        if tsChangePending in FStates then\r\n          DoChange(FLastChangedNode);\r\n      finally\r\n        if toAutoSort in FOptions.FAutoOptions then\r\n          SortTree(FHeader.FSortColumn, FHeader.FSortDirection, True);\r\n\r\n        SetUpdateState(False);\r\n        if HandleAllocated then\r\n          Invalidate;\r\n        UpdateDesigner;\r\n      end;\r\n    end;\r\n\r\n    if FUpdateCount = 0 then begin\r\n      DoUpdating(usEnd);\r\n      EnsureNodeSelected();\r\n    end\r\n    else\r\n      DoUpdating(usUpdate);\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TBaseVirtualTree.ExecuteAction(Action: TBasicAction): Boolean;\r\n\r\n// Some support for standard actions.\r\n\r\nbegin\r\n  Result := inherited ExecuteAction(Action);\r\n\r\n  if not Result then\r\n  begin\r\n    Result := Action is TEditSelectAll;\r\n    if Result then\r\n      SelectAll(False)\r\n    else\r\n    begin\r\n      Result := Action is TEditCopy;\r\n      if Result then\r\n        CopyToClipboard\r\n      else\r\n        if not (toReadOnly in FOptions.FMiscOptions) then\r\n        begin\r\n          Result := Action is TEditCut;\r\n          if Result then\r\n            CutToClipboard\r\n          else\r\n          begin\r\n            Result := Action is TEditPaste;\r\n            if Result then\r\n              PasteFromClipboard\r\n              else\r\n              begin\r\n                Result := Action is TEditDelete;\r\n                if Result then\r\n                  DeleteSelectedNodes;\r\n              end;\r\n          end;\r\n      end;\r\n    end;\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.FinishCutOrCopy;\r\n\r\n// Deletes nodes which are marked as being cutted.\r\n\r\nvar\r\n  Run: PVirtualNode;\r\n\r\nbegin\r\n  if tsCutPending in FStates then\r\n  begin\r\n    Run := FRoot.FirstChild;\r\n    while Assigned(Run) do\r\n    begin\r\n      if vsCutOrCopy in Run.States then\r\n        DeleteNode(Run);\r\n      Run := GetNextNoInit(Run);\r\n    end;\r\n    DoStateChange([], [tsCutPending]);\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.FlushClipboard;\r\n\r\n// Used to render the data which is currently on the clipboard (finishes delayed rendering).\r\n\r\nbegin\r\n  if ClipboardStates * FStates <> [] then\r\n  begin\r\n    DoStateChange([tsClipboardFlushing]);\r\n    OleFlushClipboard;\r\n    CancelCutOrCopy;\r\n    DoStateChange([], [tsClipboardFlushing]);\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.FullCollapse(Node: PVirtualNode = nil);\r\n\r\n// This routine collapses all expanded nodes in the subtree given by Node or the whole tree if Node is FRoot or nil.\r\n// Only nodes which are expanded will be collapsed. This excludes uninitialized nodes but nodes marked as visible\r\n// will still be collapsed if they are expanded.\r\n\r\nvar\r\n  Stop: PVirtualNode;\r\n\r\nbegin\r\n  if FRoot.TotalCount > 1 then\r\n  begin\r\n    if Node = FRoot then\r\n      Node := nil;\r\n\r\n    DoStateChange([tsCollapsing]);\r\n    BeginUpdate;\r\n    try\r\n      Stop := Node;\r\n      Node := GetLastVisibleNoInit(Node, True);\r\n\r\n      if Assigned(Node) then\r\n      begin\r\n        repeat\r\n          if [vsHasChildren, vsExpanded] * Node.States = [vsHasChildren, vsExpanded] then\r\n            ToggleNode(Node);\r\n          Node := GetPreviousNoInit(Node, True);\r\n        until (Node = Stop) or not Assigned(Node);\r\n\r\n        // Collapse the start node too.\r\n        if Assigned(Stop) and ([vsHasChildren, vsExpanded] * Stop.States = [vsHasChildren, vsExpanded]) then\r\n          ToggleNode(Stop);\r\n      end;\r\n    finally\r\n      EndUpdate;\r\n      DoStateChange([], [tsCollapsing]);\r\n    end;\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.FullExpand(Node: PVirtualNode = nil);\r\n\r\n// This routine expands all collapsed nodes in the subtree given by Node or the whole tree if Node is FRoot or nil.\r\n// All nodes on the way down are initialized so this procedure might take a long time.\r\n// Since all nodes are validated, the tree cannot make use of optimatizations. Hence it is counter productive and you\r\n// should consider avoiding its use.\r\n\r\nvar\r\n  Stop: PVirtualNode;\r\n\r\nbegin\r\n  if FRoot.TotalCount > 1 then\r\n  begin\r\n    DoStateChange([tsExpanding]);\r\n    StartOperation(TVTOperationKind.okExpand);\r\n    BeginUpdate;\r\n    try\r\n      if Node = nil then\r\n      begin\r\n        Node := FRoot.FirstChild;\r\n        Stop := nil;\r\n      end\r\n      else\r\n      begin\r\n        Stop := Node.NextSibling;\r\n        if Stop = nil then\r\n        begin\r\n          Stop := Node;\r\n          repeat\r\n            Stop := Stop.Parent;\r\n          until (Stop = FRoot) or Assigned(Stop.NextSibling);\r\n          if Stop = FRoot then\r\n            Stop := nil\r\n          else\r\n            Stop := Stop.NextSibling;\r\n        end;\r\n      end;\r\n\r\n      // Initialize the start node. Others will be initialized in GetNext.\r\n      if not (vsInitialized in Node.States) then\r\n        InitNode(Node);\r\n\r\n      repeat\r\n        if not (vsExpanded in Node.States) then\r\n          ToggleNode(Node);\r\n        Node := GetNext(Node);\r\n      until (Node = Stop) or OperationCanceled;\r\n    finally\r\n      EndOperation(TVTOperationKind.okExpand);\r\n      EndUpdate;\r\n      DoStateChange([], [tsExpanding]);\r\n    end;\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TBaseVirtualTree.GetControlsAlignment: TAlignment;\r\n\r\nbegin\r\n  Result := FAlignment;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TBaseVirtualTree.GetDisplayRect(Node: PVirtualNode; Column: TColumnIndex; TextOnly: Boolean;\r\n  Unclipped: Boolean = False; ApplyCellContentMargin: Boolean = False): TRect;\r\n\r\n// Determines the client coordinates the given node covers, depending on scrolling, expand state etc.\r\n// If the given node cannot be found (because one of its parents is collapsed or it is invisible) then an empty\r\n// rectangle is returned.\r\n// If TextOnly is True then only the text bounds are returned, that is, the resulting rectangle's left and right border\r\n// are updated according to bidi mode, alignment and text width of the node.\r\n// If Unclipped is True (which only makes sense if also TextOnly is True) then the calculated text rectangle is\r\n// not clipped if the text does not entirely fit into the text space. This is special handling needed for hints.\r\n// If ApplyCellContentMargin is True (which only makes sense if also TextOnly is True) then the calculated text\r\n// rectangle respects the cell content margin.\r\n// If Column is -1 then the entire client width is used before determining the node's width otherwise the bounds of the\r\n// particular column are used.\r\n// Note: Column must be a valid column and is used independent of whether the header is visible or not.\r\n\r\nvar\r\n  Temp: PVirtualNode;\r\n  Offset: Cardinal;\r\n  CacheIsAvailable: Boolean;\r\n  Indent,\r\n  TextWidth: Integer;\r\n  MainColumnHit: Boolean;\r\n  CurrentBidiMode: TBidiMode;\r\n  CurrentAlignment: TAlignment;\r\n  MaxUnclippedHeight: Integer;\r\n  TM: TTextMetric;\r\n  ExtraVerticalMargin: Integer;\r\n\r\nbegin\r\n  Assert(Assigned(Node), 'Node must not be nil.');\r\n  Assert(Node <> FRoot, 'Node must not be the hidden root node.');\r\n\r\n  MainColumnHit := (Column + 1) in [0, FHeader.MainColumn + 1];\r\n  if not (vsInitialized in Node.States) then\r\n    InitNode(Node);\r\n\r\n  Result := Rect(0, 0, 0, 0);\r\n\r\n  // Check whether the node is visible (determine indentation level btw.).\r\n  if not IsEffectivelyVisible[Node] then\r\n    Exit;\r\n  Temp := Node;\r\n  Indent := 0;\r\n  if not (toFixedIndent in FOptions.FPaintOptions) then\r\n  begin\r\n    while Temp <> FRoot do\r\n    begin\r\n      if not (vsVisible in Temp.States) or not (vsExpanded in Temp.Parent.States) then\r\n        Exit;\r\n      Temp := Temp.Parent;\r\n      if MainColumnHit and (Temp <> FRoot) then\r\n        Inc(Indent, FIndent);\r\n    end;\r\n  end;//if not toFixedIndent\r\n\r\n  // Here we know the node is visible.\r\n  Offset := 0;\r\n  CacheIsAvailable := False;\r\n  if tsUseCache in FStates then\r\n  begin\r\n    // If we can use the position cache then do a binary search to find a cached node which is as close as possible\r\n    // to the current node. Iterate then through all following and visible nodes and sum up their heights.\r\n    Temp := FindInPositionCache(Node, Offset);\r\n    CacheIsAvailable := Assigned(Temp);\r\n    while Assigned(Temp) and (Temp <> Node) do\r\n    begin\r\n      Inc(Offset, NodeHeight[Temp]);\r\n      Temp := GetNextVisibleNoInit(Temp, True);\r\n    end;\r\n  end;\r\n  if not CacheIsAvailable then\r\n  begin\r\n    // If the cache is not available then go straight through all nodes up to the root and sum up their heights.\r\n    Temp := Node;\r\n    repeat\r\n      Temp := GetPreviousVisibleNoInit(Temp, True);\r\n      if Temp = nil then\r\n        Break;\r\n      Inc(Offset, NodeHeight[Temp]);\r\n    until False;\r\n  end;\r\n\r\n  Result := Rect(0, Offset, Max(FRangeX, ClientWidth), Offset + NodeHeight[Node]);\r\n\r\n  // Limit left and right bounds to the given column (if any) and move bounds according to current scroll state.\r\n  if Column > NoColumn then\r\n  begin\r\n    FHeader.FColumns.GetColumnBounds(Column, Result.Left, Result.Right);\r\n    // The right column border is not part of this cell.\r\n    Dec(Result.Right);\r\n    OffsetRect(Result, 0, FOffsetY);\r\n  end\r\n  else\r\n    OffsetRect(Result, -FEffectiveOffsetX, FOffsetY);\r\n\r\n  // Limit left and right bounds further if only the text area is required.\r\n  if TextOnly then\r\n  begin\r\n    // Start with the offset of the text in the column and consider the indentation level too.\r\n    Offset := FMargin + Indent;\r\n    // If the text of a node is involved then we have to consider directionality and alignment too.\r\n    if Column <= NoColumn then\r\n    begin\r\n      CurrentBidiMode := BidiMode;\r\n      CurrentAlignment := Alignment;\r\n    end\r\n    else\r\n    begin\r\n      CurrentBidiMode := FHeader.FColumns[Column].BidiMode;\r\n      CurrentAlignment := FHeader.FColumns[Column].Alignment;\r\n    end;\r\n\r\n    if MainColumnHit then\r\n    begin\r\n      if toShowRoot in FOptions.FPaintOptions then\r\n        Inc(Offset, FIndent);\r\n      if (toCheckSupport in FOptions.FMiscOptions) and Assigned(FCheckImages) and (Node.CheckType <> ctNone) then\r\n        Inc(Offset, FCheckImages.Width + 2);\r\n    end;\r\n    // Consider associated images.\r\n    if Assigned(FStateImages) and HasImage(Node, ikState, Column) then\r\n      Inc(Offset, FStateImages.Width + 2);\r\n    if Assigned(FImages) and HasImage(Node, ikNormal, Column) then\r\n      Inc(Offset, GetNodeImageSize(Node).cx + 2);\r\n\r\n    // Offset contains now the distance from the left or right border of the rectangle (depending on bidi mode).\r\n    // Now consider the alignment too and calculate the final result.\r\n    if CurrentBidiMode = bdLeftToRight then\r\n    begin\r\n      Inc(Result.Left, Offset);\r\n      // Left-to-right reading does not need any special adjustment of the alignment.\r\n    end\r\n    else\r\n    begin\r\n      Dec(Result.Right, Offset);\r\n\r\n      // Consider bidi mode here. In RTL context does left alignment actually mean right alignment and vice versa.\r\n      ChangeBiDiModeAlignment(CurrentAlignment);\r\n    end;\r\n\r\n    TextWidth := DoGetNodeWidth(Node, Column);\r\n\r\n    // Keep cell height before applying cell content margin in order to increase cell height if text does not fit\r\n    // and Unclipped it true (see below).\r\n    MaxUnclippedHeight := Result.Bottom - Result.Top;\r\n\r\n    if ApplyCellContentMargin then\r\n      DoBeforeCellPaint(Self.Canvas, Node, Column, cpmGetContentMargin, Result, Result);\r\n\r\n    if Unclipped then\r\n    begin\r\n      // The caller requested the text coordinates unclipped. This means they must be calculated so as would\r\n      // there be enough space, regardless of column bounds etc.\r\n      // The layout still depends on the available space too, because this determines the position\r\n      // of the unclipped text rectangle.\r\n      if Result.Right - Result.Left < TextWidth - 1 then\r\n        if CurrentBidiMode = bdLeftToRight then\r\n          CurrentAlignment := taLeftJustify\r\n        else\r\n          CurrentAlignment := taRightJustify;\r\n\r\n      // Increase cell height (up to MaxUnclippedHeight determined above) if text does not fit.\r\n      GetTextMetrics(Self.Canvas.Handle, TM);\r\n      ExtraVerticalMargin := System.Math.Min(TM.tmHeight, MaxUnclippedHeight) - (Result.Bottom - Result.Top);\r\n      if ExtraVerticalMargin > 0 then\r\n        InflateRect(Result, 0, (ExtraVerticalMargin + 1) div 2);\r\n\r\n      case CurrentAlignment of\r\n        taCenter:\r\n          begin\r\n            Result.Left := (Result.Left + Result.Right - TextWidth) div 2;\r\n            Result.Right := Result.Left + TextWidth;\r\n          end;\r\n        taRightJustify:\r\n          Result.Left := Result.Right - TextWidth;\r\n      else // taLeftJustify\r\n        Result.Right := Result.Left + TextWidth - 1;\r\n      end;\r\n    end\r\n    else\r\n      // Modify rectangle only if the text fits entirely into the given room.\r\n      if Result.Right - Result.Left > TextWidth then\r\n        case CurrentAlignment of\r\n          taCenter:\r\n            begin\r\n              Result.Left := (Result.Left + Result.Right - TextWidth) div 2;\r\n              Result.Right := Result.Left + TextWidth;\r\n            end;\r\n          taRightJustify:\r\n            Result.Left := Result.Right - TextWidth;\r\n        else // taLeftJustify\r\n          Result.Right := Result.Left + TextWidth;\r\n        end;\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TBaseVirtualTree.GetEffectivelyFiltered(Node: PVirtualNode): Boolean;\r\n\r\n// Checks if a node is effectively filtered out. This depends on the nodes state and the paint options.\r\n\r\nbegin\r\n  if Assigned(Node) then\r\n    Result := (vsFiltered in Node.States) and not (toShowFilteredNodes in FOptions.FPaintOptions)\r\n  else\r\n    Result := False;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TBaseVirtualTree.GetEffectivelyVisible(Node: PVirtualNode): Boolean;\r\n\r\nbegin\r\n  Result := (vsVisible in Node.States) and not IsEffectivelyFiltered[Node];\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TBaseVirtualTree.GetFirst(ConsiderChildrenAbove: Boolean = False): PVirtualNode;\r\n\r\n// Returns the first node in the tree while optionally considering toChildrenAbove.\r\n\r\nbegin\r\n  if ConsiderChildrenAbove and (toChildrenAbove in FOptions.FPaintOptions) then\r\n  begin\r\n    if vsHasChildren in FRoot.States then\r\n    begin\r\n      Result := FRoot;\r\n\r\n      // Child nodes are the first choice if possible.\r\n      if Assigned(Result.FirstChild) then\r\n      begin\r\n        while Assigned(Result.FirstChild) do\r\n        begin\r\n          Result := Result.FirstChild;\r\n          if not (vsInitialized in Result.States) then\r\n            InitNode(Result);\r\n\r\n          if (vsHasChildren in Result.States) and (Result.ChildCount = 0) then\r\n            InitChildren(Result);\r\n        end;\r\n      end\r\n      else\r\n        Result := nil;\r\n    end\r\n    else\r\n      Result := nil;\r\n  end\r\n  else\r\n    Result := FRoot.FirstChild;\r\n\r\n  if Assigned(Result) and not (vsInitialized in Result.States) then\r\n    InitNode(Result);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TBaseVirtualTree.GetFirstChecked(State: TCheckState = csCheckedNormal;\r\n  ConsiderChildrenAbove: Boolean = False): PVirtualNode;\r\n\r\n// Returns the first node in the tree with the given check state.\r\n\r\nbegin\r\n  Result := GetNextChecked(nil, State, ConsiderChildrenAbove);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TBaseVirtualTree.GetFirstChild(Node: PVirtualNode): PVirtualNode;\r\n\r\n// Returns the first child of the given node. The result node is initialized before exit.\r\n\r\nbegin\r\n  if (Node = nil) or (Node = FRoot) then\r\n    Result := FRoot.FirstChild\r\n  else\r\n  begin\r\n    if not (vsInitialized in Node.States) then\r\n      InitNode(Node);\r\n    if vsHasChildren in Node.States then\r\n    begin\r\n      if Node.ChildCount = 0 then\r\n        InitChildren(Node);\r\n      Result := Node.FirstChild;\r\n    end\r\n    else\r\n      Result := nil;\r\n  end;\r\n\r\n  if Assigned(Result) and not (vsInitialized in Result.States) then\r\n    InitNode(Result);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TBaseVirtualTree.GetFirstChildNoInit(Node: PVirtualNode): PVirtualNode;\r\n// Determines the first child of the given node but does not initialize it.\r\n\r\nbegin\r\n  if (Node = nil) or (Node = FRoot) then\r\n    Result := FRoot.FirstChild\r\n  else\r\n  begin\r\n    if vsHasChildren in Node.States then\r\n      Result := Node.FirstChild\r\n    else\r\n      Result := nil;\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TBaseVirtualTree.GetFirstCutCopy(ConsiderChildrenAbove: Boolean = False): PVirtualNode;\r\n\r\n// Returns the first node in the tree which is currently marked for a clipboard operation.\r\n// See also GetNextCutCopy for comments on initialization.\r\n\r\nbegin\r\n  Result := GetNextCutCopy(nil, ConsiderChildrenAbove);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TBaseVirtualTree.GetFirstInitialized(ConsiderChildrenAbove: Boolean = False): PVirtualNode;\r\n\r\n// Returns the first node which is already initialized.\r\n\r\nbegin\r\n  Result := GetFirstNoInit(ConsiderChildrenAbove);\r\n  if Assigned(Result) and not (vsInitialized in Result.States) then\r\n    Result := GetNextInitialized(Result, ConsiderChildrenAbove);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TBaseVirtualTree.GetFirstLeaf: PVirtualNode;\r\n\r\n// Returns the first node in the tree which has currently no children.\r\n// The result is initialized if necessary.\r\n\r\nbegin\r\n  Result := GetNextLeaf(nil);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TBaseVirtualTree.GetFirstLevel(NodeLevel: Cardinal): PVirtualNode;\r\n\r\n// Returns the first node in the tree on a specific level.\r\n// The result is initialized if necessary.\r\n\r\nbegin\r\n  Result := GetFirstNoInit(True);\r\n  while Assigned(Result) and (GetNodeLevel(Result) <> NodeLevel) do\r\n    Result := GetNextNoInit(Result, True);\r\n\r\n  if Assigned(Result) and (GetNodeLevel(Result) <> NodeLevel) then // i.e. there is no node with the desired level in the tree\r\n    Result := nil;\r\n\r\n  if Assigned(Result) and not (vsInitialized in Result.States) then\r\n    InitNode(Result);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TBaseVirtualTree.GetFirstNoInit(ConsiderChildrenAbove: Boolean = False): PVirtualNode;\r\n\r\n// Returns the first node in the tree while optionally considering toChildrenAbove.\r\n// No initialization is performed.\r\n\r\nbegin\r\n  if ConsiderChildrenAbove and (toChildrenAbove in FOptions.FPaintOptions) then\r\n  begin\r\n    if vsHasChildren in FRoot.States then\r\n    begin\r\n      Result := FRoot;\r\n\r\n      // Child nodes are the first choice if possible.\r\n      if Assigned(Result.FirstChild) then\r\n      begin\r\n        while Assigned(Result.FirstChild) do\r\n          Result := Result.FirstChild;\r\n      end\r\n      else\r\n        Result := nil;\r\n    end\r\n    else\r\n      Result := nil;\r\n  end\r\n  else\r\n    Result := FRoot.FirstChild;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TBaseVirtualTree.GetFirstSelected(ConsiderChildrenAbove: Boolean = False): PVirtualNode;\r\n\r\n// Returns the first node in the current selection while optionally considering toChildrenAbove.\r\n\r\nbegin\r\n  Result := GetNextSelected(nil, ConsiderChildrenAbove);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TBaseVirtualTree.GetFirstVisible(Node: PVirtualNode = nil; ConsiderChildrenAbove: Boolean = True;\r\n  IncludeFiltered: Boolean = False): PVirtualNode;\r\n\r\n// Returns the first visible node in the tree while optionally considering toChildrenAbove.\r\n// If necessary nodes are initialized on demand.\r\n\r\nbegin\r\n  Result := Node;\r\n  if not Assigned(Result) then\r\n    Result := FRoot;\r\n\r\n  if vsHasChildren in Result.States then\r\n  begin\r\n    if Result.ChildCount = 0 then\r\n      InitChildren(Result);\r\n\r\n    // Child nodes are the first choice if possible.\r\n    if Assigned(Result.FirstChild) then\r\n    begin\r\n      Result := GetFirstChild(Result);\r\n\r\n      if ConsiderChildrenAbove and (toChildrenAbove in FOptions.FPaintOptions) then\r\n      begin\r\n        repeat\r\n          // Search the first visible sibling.\r\n          while Assigned(Result.NextSibling) and not (vsVisible in Result.States) do\r\n          begin\r\n            Result := Result.NextSibling;\r\n            // Init node on demand as this might change the visibility.\r\n            if not (vsInitialized in Result.States) then\r\n              InitNode(Result);\r\n          end;\r\n\r\n          // If there are no visible siblings take the parent.\r\n          if not (vsVisible in Result.States) then\r\n          begin\r\n            Result := Result.Parent;\r\n            if Result = FRoot then\r\n              Result := nil;\r\n            Break;\r\n          end\r\n          else\r\n          begin\r\n            if (vsHasChildren in Result.States) and (Result.ChildCount = 0) then\r\n              InitChildren(Result);\r\n            if (not Assigned(Result.FirstChild)) or (not (vsExpanded in Result.States)) then\r\n              Break;\r\n          end;\r\n\r\n          Result := Result.FirstChild;\r\n          if not (vsInitialized in Result.States) then\r\n            InitNode(Result);\r\n        until False;\r\n      end\r\n      else\r\n      begin\r\n        // If there are no children or the first child is not visible then search the sibling nodes or traverse parents.\r\n        if not (vsVisible in Result.States) then\r\n        begin\r\n          repeat\r\n            // Is there a next sibling?\r\n            if Assigned(Result.NextSibling) then\r\n            begin\r\n              Result := Result.NextSibling;\r\n              // The visible state can be removed during initialization so init the node first.\r\n              if not (vsInitialized in Result.States) then\r\n                InitNode(Result);\r\n              if vsVisible in Result.States then\r\n                Break;\r\n            end\r\n            else\r\n            begin\r\n              // No sibling anymore, so use the parent's next sibling.\r\n              if Result.Parent <> FRoot then\r\n                Result := Result.Parent\r\n              else\r\n              begin\r\n                // There are no further nodes to examine, hence there is no further visible node.\r\n                Result := nil;\r\n                Break;\r\n              end;\r\n            end;\r\n          until False;\r\n        end;\r\n      end;\r\n    end\r\n    else\r\n      Result := nil;\r\n  end\r\n  else\r\n    Result := nil;\r\n\r\n  if Assigned(Result) and not IncludeFiltered and IsEffectivelyFiltered[Result] then\r\n    Result := GetNextVisible(Result);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TBaseVirtualTree.GetFirstVisibleChild(Node: PVirtualNode; IncludeFiltered: Boolean = False): PVirtualNode;\r\n\r\n// Returns the first visible child node of Node. If necessary nodes are initialized on demand.\r\n\r\nbegin\r\n  if Node = nil then\r\n    Node := FRoot;\r\n  Result := GetFirstChild(Node);\r\n\r\n  if Assigned(Result) and (not (vsVisible in Result.States) or\r\n     (not IncludeFiltered and IsEffectivelyFiltered[Node])) then\r\n    Result := GetNextVisibleSibling(Result, IncludeFiltered);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TBaseVirtualTree.GetFirstVisibleChildNoInit(Node: PVirtualNode; IncludeFiltered: Boolean = False): PVirtualNode;\r\n\r\n// Returns the first visible child node of Node.\r\n\r\nbegin\r\n  if Node = nil then\r\n    Node := FRoot;\r\n  Result := Node.FirstChild;\r\n  if Assigned(Result) and (not (vsVisible in Result.States) or\r\n     (not IncludeFiltered and IsEffectivelyFiltered[Node])) then\r\n    Result := GetNextVisibleSiblingNoInit(Result, IncludeFiltered);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TBaseVirtualTree.GetFirstVisibleNoInit(Node: PVirtualNode = nil;\r\n  ConsiderChildrenAbove: Boolean = True; IncludeFiltered: Boolean = False): PVirtualNode;\r\n\r\n// Returns the first visible node in the tree or given subtree while optionally considering toChildrenAbove.\r\n// No initialization is performed.\r\n\r\nbegin\r\n  Result := Node;\r\n  if not Assigned(Result) then\r\n    Result := FRoot;\r\n\r\n  if vsHasChildren in Result.States then\r\n  begin\r\n    // Child nodes are the first choice if possible.\r\n    if Assigned(Result.FirstChild) then\r\n    begin\r\n      Result := Result.FirstChild;\r\n\r\n      if ConsiderChildrenAbove and (toChildrenAbove in FOptions.FPaintOptions) then\r\n      begin\r\n        repeat\r\n          // Search the first visible sibling.\r\n          while Assigned(Result.NextSibling) and not (vsVisible in Result.States) do\r\n            Result := Result.NextSibling;\r\n\r\n          // If there a no visible siblings take the parent.\r\n          if not (vsVisible in Result.States) then\r\n          begin\r\n            Result := Result.Parent;\r\n            if Result = FRoot then\r\n              Result := nil;\r\n            Break;\r\n          end\r\n          else\r\n            if (not Assigned(Result.FirstChild)) or (not (vsExpanded in Result.States))then\r\n              Break;\r\n\r\n          Result := Result.FirstChild;\r\n        until False;\r\n      end\r\n      else\r\n      begin\r\n        // If there are no children or the first child is not visible then search the sibling nodes or traverse parents.\r\n        if not (vsVisible in Result.States) then\r\n        begin\r\n          repeat\r\n            // Is there a next sibling?\r\n            if Assigned(Result.NextSibling) then\r\n            begin\r\n              Result := Result.NextSibling;\r\n              if vsVisible in Result.States then\r\n                Break;\r\n            end\r\n            else\r\n            begin\r\n              // No sibling anymore, so use the parent's next sibling.\r\n              if Result.Parent <> FRoot then\r\n                Result := Result.Parent\r\n              else\r\n              begin\r\n                // There are no further nodes to examine, hence there is no further visible node.\r\n                Result := nil;\r\n                Break;\r\n              end;\r\n            end;\r\n          until False;\r\n        end;\r\n      end;\r\n    end\r\n    else\r\n      Result := nil;\r\n  end\r\n  else\r\n    Result := nil;\r\n\r\n  if Assigned(Result) and not IncludeFiltered and IsEffectivelyFiltered[Result] then\r\n    Result := GetNextVisibleNoInit(Result);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.GetHitTestInfoAt(X, Y: Integer; Relative: Boolean; var HitInfo: THitInfo);\r\n\r\n// Determines the node that occupies the specified point or nil if there's none. The parameter Relative determines\r\n// whether to consider X and Y as being client coordinates (if True) or as being absolute tree coordinates.\r\n// HitInfo is filled with flags describing the hit further.\r\n\r\nvar\r\n  ColLeft,\r\n  ColRight: Integer;\r\n  NodeTop: Integer;\r\n  InitialColumn,\r\n  NextColumn: TColumnIndex;\r\n  CurrentBidiMode: TBidiMode;\r\n  CurrentAlignment: TAlignment;\r\n  NodeRect: TRect;\r\n\r\nbegin\r\n  HitInfo.HitNode := nil;\r\n  HitInfo.HitPositions := [];\r\n  HitInfo.HitColumn := NoColumn;\r\n\r\n  // Determine if point lies in the tree's client area.\r\n  if X < 0 then\r\n    Include(HitInfo.HitPositions, hiToLeft)\r\n  else\r\n    if X > Max(FRangeX, ClientWidth) then\r\n      Include(HitInfo.HitPositions, hiToRight);\r\n\r\n  if Y < 0 then\r\n    Include(HitInfo.HitPositions, hiAbove)\r\n  else\r\n    if Y > Max(FRangeY, ClientHeight) then\r\n      Include(HitInfo.HitPositions, hiBelow);\r\n\r\n  // Convert position into absolute coordinate if necessary.\r\n  if Relative then\r\n  begin\r\n    if X >= Header.Columns.GetVisibleFixedWidth then\r\n      Inc(X, FEffectiveOffsetX);\r\n    Inc(Y, -FOffsetY);\r\n  end;\r\n  HitInfo.HitPoint.X := X;\r\n  HitInfo.HitPoint.Y := Y;\r\n\r\n  // If the point is in the tree area then check the nodes.\r\n  if HitInfo.HitPositions = [] then\r\n  begin\r\n    HitInfo.HitNode := GetNodeAt(X, Y, False, NodeTop);\r\n    if HitInfo.HitNode = nil then\r\n      Include(HitInfo.HitPositions, hiNowhere)\r\n    else\r\n    begin\r\n      // At this point we need some info about the node, so it must be initialized.\r\n      if not (vsInitialized in HitInfo.HitNode.States) then\r\n        InitNode(HitInfo.HitNode);\r\n\r\n      if FHeader.UseColumns then\r\n      begin\r\n        HitInfo.HitColumn := FHeader.Columns.GetColumnAndBounds(Point(X, Y), ColLeft, ColRight, False);\r\n        // If auto column spanning is enabled then look for the last non empty column.\r\n        if toAutoSpanColumns in FOptions.FAutoOptions then\r\n        begin\r\n          InitialColumn := HitInfo.HitColumn;\r\n          // Search to the left of the hit column for empty columns.\r\n          while (HitInfo.HitColumn > NoColumn) and ColumnIsEmpty(HitInfo.HitNode, HitInfo.HitColumn) do\r\n          begin\r\n            NextColumn := FHeader.FColumns.GetPreviousVisibleColumn(HitInfo.HitColumn);\r\n            if NextColumn = InvalidColumn then\r\n              Break;\r\n            HitInfo.HitColumn := NextColumn;\r\n            Dec(ColLeft, FHeader.FColumns[NextColumn].Width);\r\n          end;\r\n          // Search to the right of the hit column for empty columns.\r\n          repeat\r\n            InitialColumn := FHeader.FColumns.GetNextVisibleColumn(InitialColumn);\r\n            if (InitialColumn = InvalidColumn) or not ColumnIsEmpty(HitInfo.HitNode, InitialColumn) then\r\n              Break;\r\n            Inc(ColRight, FHeader.FColumns[InitialColumn].Width);\r\n          until False;\r\n        end;\r\n        // Make the X position and the right border relative to the start of the column.\r\n        Dec(X, ColLeft);\r\n        Dec(ColRight, ColLeft);\r\n      end\r\n      else\r\n      begin\r\n        HitInfo.HitColumn := NoColumn;\r\n        ColRight := Max(FRangeX, ClientWidth);\r\n      end;\r\n      ColLeft := 0;\r\n\r\n      if HitInfo.HitColumn = InvalidColumn then\r\n        Include(HitInfo.HitPositions, hiNowhere)\r\n      else\r\n      begin\r\n        // From now on X is in \"column\" coordinates (relative to the left column border).\r\n        HitInfo.HitPositions := [hiOnItem];\r\n\r\n        // Avoid getting the display rect if this is not necessary.\r\n        if toNodeHeightResize in FOptions.FMiscOptions then\r\n        begin\r\n          NodeRect := GetDisplayRect(HitInfo.HitNode, HitInfo.HitColumn, False);\r\n          if Y <= (NodeRect.Top - FOffsetY + 1) then\r\n            Include(HitInfo.HitPositions, hiUpperSplitter)\r\n          else\r\n          if Y >= (NodeRect.Bottom - FOffsetY - 3) then\r\n            Include(HitInfo.HitPositions, hiLowerSplitter);\r\n        end;\r\n\r\n        if HitInfo.HitColumn <= NoColumn then\r\n        begin\r\n          CurrentBidiMode := BidiMode;\r\n          CurrentAlignment := Alignment;\r\n        end\r\n        else\r\n        begin\r\n          CurrentBidiMode := FHeader.FColumns[HitInfo.HitColumn].BidiMode;\r\n          CurrentAlignment := FHeader.FColumns[HitInfo.HitColumn].Alignment;\r\n        end;\r\n\r\n        if CurrentBidiMode = bdLeftToRight then\r\n          DetermineHitPositionLTR(HitInfo, X, ColRight, CurrentAlignment)\r\n        else\r\n          DetermineHitPositionRTL(HitInfo, X, ColRight, CurrentAlignment);\r\n      end;\r\n    end;\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TBaseVirtualTree.GetLast(Node: PVirtualNode = nil; ConsiderChildrenAbove: Boolean = False): PVirtualNode;\r\n\r\n// Returns the very last node in the tree branch given by Node and initializes the nodes all the way down including the\r\n// result. toChildrenAbove is optionally considered. By using Node = nil the very last node in the tree is returned.\r\n\r\nvar\r\n  Next: PVirtualNode;\r\n\r\nbegin\r\n  Result := GetLastChild(Node);\r\n  if not ConsiderChildrenAbove or not (toChildrenAbove in FOptions.FPaintOptions) then\r\n    while Assigned(Result) do\r\n    begin\r\n      // Test if there is a next last child. If not keep the node from the last run.\r\n      // Otherwise use the next last child.\r\n      Next := GetLastChild(Result);\r\n      if Next = nil then\r\n        Break;\r\n      Result := Next;\r\n    end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TBaseVirtualTree.GetLastInitialized(Node: PVirtualNode = nil;\r\n  ConsiderChildrenAbove: Boolean = False): PVirtualNode;\r\n\r\n// Returns the very last initialized child node in the tree branch given by Node.\r\n\r\nbegin\r\n  Result := GetLastNoInit(Node, ConsiderChildrenAbove);\r\n  if Assigned(Result) and not (vsInitialized in Result.States) then\r\n    Result := GetPreviousInitialized(Result, ConsiderChildrenAbove);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TBaseVirtualTree.GetLastNoInit(Node: PVirtualNode = nil; ConsiderChildrenAbove: Boolean = False): PVirtualNode;\r\n\r\n// Returns the very last node in the tree branch given by Node without initialization.\r\n\r\nvar\r\n  Next: PVirtualNode;\r\n\r\nbegin\r\n  Result := GetLastChildNoInit(Node);\r\n  if not ConsiderChildrenAbove or not (toChildrenAbove in FOptions.FPaintOptions) then\r\n    while Assigned(Result) do\r\n    begin\r\n      // Test if there is a next last child. If not keep the node from the last run.\r\n      // Otherwise use the next last child.\r\n      Next := GetLastChildNoInit(Result);\r\n      if Next = nil then\r\n        Break;\r\n      Result := Next;\r\n    end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TBaseVirtualTree.GetLastChild(Node: PVirtualNode): PVirtualNode;\r\n\r\n// Determines the last child of the given node and initializes it if there is one.\r\n\r\nbegin\r\n  if (Node = nil) or (Node = FRoot) then\r\n    Result := FRoot.LastChild\r\n  else\r\n  begin\r\n    if not (vsInitialized in Node.States) then\r\n      InitNode(Node);\r\n    if vsHasChildren in Node.States then\r\n    begin\r\n      if Node.ChildCount = 0 then\r\n        InitChildren(Node);\r\n      Result := Node.LastChild;\r\n    end\r\n    else\r\n      Result := nil;\r\n  end;\r\n\r\n  if Assigned(Result) and not (vsInitialized in Result.States) then\r\n    InitNode(Result);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TBaseVirtualTree.GetLastChildNoInit(Node: PVirtualNode): PVirtualNode;\r\n\r\n// Determines the last child of the given node but does not initialize it.\r\n\r\nbegin\r\n  if (Node = nil) or (Node = FRoot) then\r\n    Result := FRoot.LastChild\r\n  else\r\n  begin\r\n    if vsHasChildren in Node.States then\r\n      Result := Node.LastChild\r\n    else\r\n      Result := nil;\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TBaseVirtualTree.GetLastVisible(Node: PVirtualNode = nil; ConsiderChildrenAbove: Boolean = True;\r\n  IncludeFiltered: Boolean = False): PVirtualNode;\r\n\r\n// Returns the very last visible node in the tree while optionally considering toChildrenAbove.\r\n// The nodes are intialized all the way up including the result node.\r\n\r\nvar\r\n  Run: PVirtualNode;\r\n\r\nbegin\r\n  Result := GetLastVisibleNoInit(Node, ConsiderChildrenAbove);\r\n\r\n  Run := Result;\r\n  while Assigned(Run) and (Run <> Node)  and (Run <> RootNode) do\r\n  begin\r\n    if not (vsInitialized in Run.States) then\r\n      InitNode(Run);\r\n    Run := Run.Parent;\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TBaseVirtualTree.GetLastVisibleChild(Node: PVirtualNode; IncludeFiltered: Boolean = False): PVirtualNode;\r\n\r\n// Determines the last visible child of the given node and initializes it if necessary.\r\n\r\nbegin\r\n  if (Node = nil) or (Node = FRoot) then\r\n    Result := GetLastChild(FRoot)\r\n  else\r\n    if FullyVisible[Node] and (vsExpanded in Node.States) then\r\n      Result := GetLastChild(Node)\r\n    else\r\n      Result := nil;\r\n\r\n  if Assigned(Result) and (not (vsVisible in Result.States) or\r\n     (not IncludeFiltered and IsEffectivelyFiltered[Node])) then\r\n    Result := GetPreviousVisibleSibling(Result, IncludeFiltered);\r\n\r\n  if Assigned(Result) and not (vsInitialized in Result.States) then\r\n    InitNode(Result);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TBaseVirtualTree.GetLastVisibleChildNoInit(Node: PVirtualNode; IncludeFiltered: Boolean = False): PVirtualNode;\r\n\r\n// Determines the last visible child of the given node without initialization.\r\n\r\nbegin\r\n  if (Node = nil) or (Node = FRoot) then\r\n    Result := GetLastChildNoInit(FRoot)\r\n  else\r\n    if FullyVisible[Node] and (vsExpanded in Node.States) then\r\n      Result := GetLastChildNoInit(Node)\r\n    else\r\n      Result := nil;\r\n\r\n  if Assigned(Result) and (not (vsVisible in Result.States) or\r\n     (not IncludeFiltered and IsEffectivelyFiltered[Node])) then\r\n    Result := GetPreviousVisibleSiblingNoInit(Result, IncludeFiltered);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TBaseVirtualTree.GetLastVisibleNoInit(Node: PVirtualNode = nil;\r\n  ConsiderChildrenAbove: Boolean = True; IncludeFiltered: Boolean = False): PVirtualNode;\r\n\r\n// Returns the very last visible node in the tree while optionally considering toChildrenAbove.\r\n// No initialization is performed.\r\n\r\nbegin\r\n  Result := GetLastNoInit(Node, ConsiderChildrenAbove);\r\n  while Assigned(Result) and (Result <> Node) do\r\n  begin\r\n    if FullyVisible[Result] and\r\n       (IncludeFiltered or not IsEffectivelyFiltered[Result]) then\r\n      Break;\r\n    Result := GetPreviousNoInit(Result, ConsiderChildrenAbove);\r\n  end;\r\n\r\n  if (Result = Node) then // i.e. there is no visible node\r\n    Result := nil;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TBaseVirtualTree.GetMaxColumnWidth(Column: TColumnIndex; UseSmartColumnWidth: Boolean = False): Integer;\r\n\r\n// This method determines the width of the largest node in the given column.\r\n// If UseSmartColumnWidth is True then only the visible nodes which are in view will be considered\r\n// Note: If UseSmartColumnWidth is False then every visible node in the tree will be initialized contradicting so\r\n//       the virtual paradigm.\r\n\r\nvar\r\n  Run,\r\n  LastNode,\r\n  NextNode: PVirtualNode;\r\n  NodeLeft,\r\n  TextLeft,\r\n  CurrentWidth: Integer;\r\n  AssumeImage: Boolean;\r\n  WithCheck,\r\n  WithStateImages: Boolean;\r\n  CheckOffset,\r\n  StateImageOffset: Integer;\r\n\r\nbegin\r\n  if OperationCanceled then\r\n  begin\r\n    // Behave non-destructive.\r\n    Result := FHeader.FColumns[Column].Width;\r\n    Exit;\r\n  end\r\n  else\r\n    Result := 0;\r\n\r\n  StartOperation(okGetMaxColumnWidth);\r\n  try\r\n    if Assigned(FOnBeforeGetMaxColumnWidth) then\r\n      FOnBeforeGetMaxColumnWidth(FHeader, Column, UseSmartColumnWidth);\r\n\r\n    WithStateImages := Assigned(FStateImages);\r\n    if WithStateImages then\r\n      StateImageOffset := FStateImages.Width + 2\r\n    else\r\n      StateImageOffset := 0;\r\n    if Assigned(FCheckImages) then\r\n      CheckOffset := FCheckImages.Width + 2\r\n    else\r\n      CheckOffset := 0;\r\n\r\n    if UseSmartColumnWidth then // Get first visible node which is in view.\r\n      Run := GetTopNode\r\n    else\r\n      Run := GetFirstVisible(nil, True);\r\n\r\n    if Column = FHeader.MainColumn then\r\n    begin\r\n      if toFixedIndent in FOptions.FPaintOptions then\r\n        NodeLeft := FIndent\r\n      else\r\n      begin\r\n        if toShowRoot in FOptions.FPaintOptions then\r\n          NodeLeft := Integer((GetNodeLevel(Run) + 1) * FIndent)\r\n        else\r\n          NodeLeft := Integer(GetNodeLevel(Run) * FIndent);\r\n      end;\r\n\r\n      WithCheck := (toCheckSupport in FOptions.FMiscOptions) and Assigned(FCheckImages);\r\n    end\r\n    else\r\n    begin\r\n      NodeLeft := 0;\r\n      WithCheck := False;\r\n    end;\r\n\r\n    // Consider node margin at the left of the nodes.\r\n    Inc(NodeLeft, FMargin);\r\n\r\n    // Decide where to stop.\r\n    if UseSmartColumnWidth then\r\n      LastNode := GetNextVisible(BottomNode)\r\n    else\r\n      LastNode := nil;\r\n\r\n    AssumeImage := False;\r\n    while Assigned(Run) and not OperationCanceled do\r\n    begin\r\n      TextLeft := NodeLeft;\r\n      if WithCheck and (Run.CheckType <> ctNone) then\r\n        Inc(TextLeft, CheckOffset);\r\n      if Assigned(FImages) and (AssumeImage or HasImage(Run, ikNormal, Column)) then\r\n      begin\r\n        TextLeft := TextLeft + GetNodeImageSize(Run).cx + 2;\r\n        AssumeImage := True;// From now on, assume that the nodes do ave an image\r\n      end;\r\n      if WithStateImages and HasImage(Run, ikState, Column) then\r\n        Inc(TextLeft, StateImageOffset);\r\n\r\n      CurrentWidth := DoGetNodeWidth(Run, Column);\r\n      Inc(CurrentWidth, DoGetNodeExtraWidth(Run, Column));\r\n      Inc(CurrentWidth, DoGetCellContentMargin(Run, Column).X);\r\n\r\n      if Result < (TextLeft + CurrentWidth) then\r\n        Result := TextLeft + CurrentWidth;\r\n\r\n      // Get next visible node and update left node position if needed.\r\n      NextNode := GetNextVisible(Run, True);\r\n      if NextNode = LastNode then\r\n        Break;\r\n      if (Column = Header.MainColumn) and not (toFixedIndent in FOptions.FPaintOptions) then\r\n        Inc(NodeLeft, CountLevelDifference(Run, NextNode) * Integer(FIndent));\r\n      Run := NextNode;\r\n    end;\r\n    if toShowVertGridLines in FOptions.FPaintOptions then\r\n      Inc(Result);\r\n\r\n    if Assigned(FOnAfterGetMaxColumnWidth) then\r\n      FOnAfterGetMaxColumnWidth(FHeader, Column, Result);\r\n\r\n  finally\r\n    EndOperation(okGetMaxColumnWidth);\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TBaseVirtualTree.GetNext(Node: PVirtualNode; ConsiderChildrenAbove: Boolean = False): PVirtualNode;\r\n\r\n// Returns next node in tree while optionally considering toChildrenAbove. The Result will be initialized if needed.\r\n\r\nbegin\r\n  Result := Node;\r\n  if Assigned(Result) then\r\n  begin\r\n    Assert(Result <> FRoot, 'Node must not be the hidden root node.');\r\n\r\n    if ConsiderChildrenAbove and (toChildrenAbove in FOptions.FPaintOptions) then\r\n    begin\r\n      // If this node has no siblings use the parent.\r\n      if not Assigned(Result.NextSibling) then\r\n      begin\r\n        Result := Result.Parent;\r\n        if Result = FRoot then\r\n        begin\r\n          Result := nil;\r\n        end;\r\n      end\r\n      else\r\n      begin\r\n        // There is at least one sibling so take it.\r\n        Result := Result.NextSibling;\r\n\r\n        // Has this node got children? Initialize them if necessary.\r\n        if (vsHasChildren in Result.States) and (Result.ChildCount = 0) then\r\n          InitChildren(Result);\r\n\r\n        // Now take a look at the children.\r\n        while Assigned(Result.FirstChild) do\r\n        begin\r\n          Result := Result.FirstChild;\r\n          if (vsHasChildren in Result.States) and (Result.ChildCount = 0) then\r\n            InitChildren(Result);\r\n        end;\r\n      end;\r\n    end\r\n    else\r\n    begin\r\n      // Has this node got children?\r\n      if vsHasChildren in Result.States then\r\n      begin\r\n        // Yes, there are child nodes. Initialize them if necessary.\r\n        if Result.ChildCount = 0 then\r\n          InitChildren(Result);\r\n      end;\r\n\r\n      // if there is no child node try siblings\r\n      if Assigned(Result.FirstChild) then\r\n        Result := Result.FirstChild\r\n      else\r\n      begin\r\n        repeat\r\n          // Is there a next sibling?\r\n          if Assigned(Result.NextSibling) then\r\n          begin\r\n            Result := Result.NextSibling;\r\n            Break;\r\n          end\r\n          else\r\n          begin\r\n            // No sibling anymore, so use the parent's next sibling.\r\n            if Result.Parent <> FRoot then\r\n              Result := Result.Parent\r\n            else\r\n            begin\r\n              // There are no further nodes to examine, hence there is no further visible node.\r\n              Result := nil;\r\n              Break;\r\n            end;\r\n          end;\r\n        until False;\r\n      end;\r\n    end;\r\n  end;\r\n\r\n  if Assigned(Result) and not (vsInitialized in Result.States) then\r\n    InitNode(Result);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TBaseVirtualTree.GetNextChecked(Node: PVirtualNode; State: TCheckState = csCheckedNormal;\r\n  ConsiderChildrenAbove: Boolean = False): PVirtualNode;\r\n\r\nbegin\r\n  if (Node = nil) or (Node = FRoot) then\r\n    Result := GetFirstNoInit(ConsiderChildrenAbove)\r\n  else\r\n    Result := GetNextNoInit(Node, ConsiderChildrenAbove);\r\n\r\n  while Assigned(Result) and (Result.CheckState <> State) do\r\n    Result := GetNextNoInit(Result, ConsiderChildrenAbove);\r\n\r\n  if Assigned(Result) and not (vsInitialized in Result.States) then\r\n    InitNode(Result);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TBaseVirtualTree.GetNextChecked(Node: PVirtualNode; ConsiderChildrenAbove: Boolean): PVirtualNode;\r\nbegin\r\n  Result := Self.GetNextChecked(Node, csCheckedNormal, ConsiderChildrenAbove);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TBaseVirtualTree.GetNextCutCopy(Node: PVirtualNode; ConsiderChildrenAbove: Boolean = False): PVirtualNode;\r\n\r\n// Returns the next node in the tree which is currently marked for a clipboard operation. Since only visible nodes can\r\n// be marked (or they are hidden after they have been marked) it is not necessary to initialize nodes to check for\r\n// child nodes. The result, however, is initialized if necessary.\r\n\r\nbegin\r\n  if ClipboardStates * FStates <> [] then\r\n  begin\r\n    if (Node = nil) or (Node = FRoot) then\r\n      Result := GetFirstNoInit(ConsiderChildrenAbove)\r\n    else\r\n      Result := GetNextNoInit(Node, ConsiderChildrenAbove);\r\n    while Assigned(Result) and not (vsCutOrCopy in Result.States) do\r\n      Result := GetNextNoInit(Result, ConsiderChildrenAbove);\r\n    if Assigned(Result) and not (vsInitialized in Result.States) then\r\n      InitNode(Result);\r\n  end\r\n  else\r\n    Result := nil;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TBaseVirtualTree.GetNextInitialized(Node: PVirtualNode; ConsiderChildrenAbove: Boolean = False): PVirtualNode;\r\n\r\n// Returns the next node in tree which is initialized.\r\n\r\nbegin\r\n  Result := Node;\r\n  repeat\r\n    Result := GetNextNoInit(Result, ConsiderChildrenAbove);\r\n  until (Result = nil) or (vsInitialized in Result.States);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TBaseVirtualTree.GetNextLeaf(Node: PVirtualNode): PVirtualNode;\r\n\r\n// Returns the next node in the tree which has currently no children.\r\n// The result is initialized if necessary.\r\n\r\nbegin\r\n  if (Node = nil) or (Node = FRoot) then\r\n    Result := FRoot.FirstChild\r\n  else\r\n    Result := GetNext(Node);\r\n  while Assigned(Result) and (vsHasChildren in Result.States) do\r\n    Result := GetNext(Result);\r\n  if Assigned(Result) and not (vsInitialized in Result.States) then\r\n    InitNode(Result);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TBaseVirtualTree.GetNextLevel(Node: PVirtualNode; NodeLevel: Cardinal): PVirtualNode;\r\n\r\n// Returns the next node in the tree on a specific level.\r\n// The result is initialized if necessary.\r\n\r\nvar\r\n  StartNodeLevel: Cardinal;\r\n\r\nbegin\r\n  Result := nil;\r\n\r\n  if Assigned(Node) and (Node <> FRoot) then\r\n  begin\r\n    StartNodeLevel := GetNodeLevel(Node);\r\n\r\n    if StartNodeLevel < NodeLevel then\r\n    begin\r\n      Result := GetNext(Node);\r\n      if Assigned(Result) and (GetNodeLevel(Result) <> NodeLevel) then\r\n        Result := GetNextLevel(Result, NodeLevel);\r\n    end\r\n    else\r\n      if StartNodeLevel = NodeLevel then\r\n      begin\r\n        Result := Node.NextSibling;\r\n        if not Assigned(Result) then // i.e. start node was a last sibling\r\n        begin\r\n          Result := Node.Parent;\r\n          if Assigned(Result) then\r\n          begin\r\n            // go to next anchestor of the start node which has a next sibling (if exists)\r\n            while Assigned(Result) and not Assigned(Result.NextSibling) do\r\n              Result := Result.Parent;\r\n            if Assigned(Result) then\r\n              Result := GetNextLevel(Result.NextSibling, NodeLevel);\r\n          end;\r\n        end;\r\n      end\r\n      else\r\n        // i.e. StartNodeLevel > NodeLevel\r\n        Result := GetNextLevel(Node.Parent, NodeLevel);\r\n  end;\r\n\r\n  if Assigned(Result) and not (vsInitialized in Result.States) then\r\n    InitNode(Result);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TBaseVirtualTree.GetNextNoInit(Node: PVirtualNode; ConsiderChildrenAbove: Boolean): PVirtualNode;\r\n\r\n// Optimized version of GetNext performing no initialization, but optionally considering toChildrenAbove.\r\n\r\nbegin\r\n  Result := Node;\r\n  if Assigned(Result) then\r\n  begin\r\n    Assert(Result <> FRoot, 'Node must not be the hidden root node.');\r\n\r\n    if ConsiderChildrenAbove and (toChildrenAbove in FOptions.FPaintOptions) then\r\n    begin\r\n      // If this node has no siblings use the parent.\r\n      if not Assigned(Result.NextSibling) then\r\n      begin\r\n        Result := Result.Parent;\r\n        if Result = FRoot then\r\n        begin\r\n          Result := nil;\r\n        end;\r\n      end\r\n      else\r\n      begin\r\n        // There is at least one sibling so take it.\r\n        Result := Result.NextSibling;\r\n\r\n        // Now take a look at the children.\r\n        while Assigned(Result.FirstChild) do\r\n        begin\r\n          Result := Result.FirstChild;\r\n        end;\r\n      end;\r\n    end\r\n    else\r\n    begin\r\n      // If there is no child node try siblings.\r\n      if Assigned(Result.FirstChild) then\r\n        Result := Result.FirstChild\r\n      else\r\n      begin\r\n        repeat\r\n          // Is there a next sibling?\r\n          if Assigned(Result.NextSibling) then\r\n          begin\r\n            Result := Result.NextSibling;\r\n            Break;\r\n          end\r\n          else\r\n          begin\r\n            // No sibling anymore, so use the parent's next sibling.\r\n            if Result.Parent <> FRoot then\r\n              Result := Result.Parent\r\n            else\r\n            begin\r\n              // There are no further nodes to examine, hence there is no further visible node.\r\n              Result := nil;\r\n              Break;\r\n            end;\r\n          end;\r\n        until False;\r\n      end;\r\n    end;\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TBaseVirtualTree.GetNextSelected(Node: PVirtualNode; ConsiderChildrenAbove: Boolean = False): PVirtualNode;\r\n\r\n// Returns the next node in the tree which is currently selected. Since children of unitialized nodes cannot be\r\n// in the current selection (because they simply do not exist yet) it is not necessary to initialize nodes here.\r\n// The result however is initialized if necessary.\r\n\r\nbegin\r\n  if FSelectionCount > 0 then\r\n  begin\r\n    if (Node = nil) or (Node = FRoot) then\r\n      Result := GetFirstNoInit(ConsiderChildrenAbove)\r\n    else\r\n      Result := GetNextNoInit(Node, ConsiderChildrenAbove);\r\n    while Assigned(Result) and not (vsSelected in Result.States) do\r\n      Result := GetNextNoInit(Result, ConsiderChildrenAbove);\r\n    if Assigned(Result) and not (vsInitialized in Result.States) then\r\n      InitNode(Result);\r\n  end\r\n  else\r\n    Result := nil;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TBaseVirtualTree.GetNextSibling(Node: PVirtualNode): PVirtualNode;\r\n\r\n// Returns the next sibling of Node and initializes it if necessary.\r\n\r\nbegin\r\n  Result := Node;\r\n  if Assigned(Result) then\r\n  begin\r\n    Assert(Result <> FRoot, 'Node must not be the hidden root node.');\r\n\r\n    Result := Result.NextSibling;\r\n    if Assigned(Result) and not (vsInitialized in Result.States) then\r\n      InitNode(Result);\r\n  end;\r\nend;\r\n\r\nfunction TBaseVirtualTree.GetNextSiblingNoInit(Node: PVirtualNode): PVirtualNode;\r\n\r\n// Returns the next sibling of Node.\r\n\r\nbegin\r\n  Result := Node;\r\n  if Assigned(Result) then\r\n  begin\r\n    Assert(Result <> FRoot, 'Node must not be the hidden root node.');\r\n\r\n    Result := Result.NextSibling;\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TBaseVirtualTree.GetNextVisible(Node: PVirtualNode; ConsiderChildrenAbove: Boolean = True): PVirtualNode;\r\n\r\n// Returns next node in tree, with regard to Node, which is visible.\r\n// Nodes which need an initialization (including the result) are initialized.\r\n// toChildrenAbove is optionally considered which is the default here.\r\n\r\nvar\r\n  ForceSearch: Boolean;\r\n\r\nbegin\r\n  Result := Node;\r\n  if Assigned(Result) then\r\n  begin\r\n    Assert(Result <> FRoot, 'Node must not be the hidden root node.');\r\n\r\n    repeat\r\n      // If the given node is not visible then look for a parent node which is visible, otherwise we will\r\n      // likely go unnecessarily through a whole bunch of invisible nodes.\r\n      if not FullyVisible[Result] then\r\n        Result := GetVisibleParent(Result, True);\r\n\r\n      if ConsiderChildrenAbove and (toChildrenAbove in FOptions.FPaintOptions) then\r\n      begin\r\n        repeat\r\n          // If there a no siblings anymore, go up one level.\r\n          if not Assigned(Result.NextSibling) then\r\n          begin\r\n            Result := Result.Parent;\r\n            if Result = FRoot then\r\n            begin\r\n              Result := nil;\r\n              Break;\r\n            end;\r\n\r\n            if not (vsInitialized in Result.States) then\r\n              InitNode(Result);\r\n            if vsVisible in Result.States then\r\n              Break;\r\n          end\r\n          else\r\n          begin\r\n            // There is at least one sibling so take it.\r\n            Result := Result.NextSibling;\r\n            if not (vsInitialized in Result.States) then\r\n              InitNode(Result);\r\n            if not (vsVisible in Result.States) then\r\n              Continue;\r\n\r\n            // Now take a look at the children.\r\n            // As the children are initialized while toggling, we don't need to do this here.\r\n            while (vsExpanded in Result.States) and Assigned(Result.FirstChild) do\r\n            begin\r\n              Result := Result.FirstChild;\r\n              if not (vsInitialized in Result.States) then\r\n                InitNode(Result);\r\n              if not (vsVisible in Result.States) then\r\n                Break;\r\n            end;\r\n\r\n            // If we found a visible node we don't need to search any longer.\r\n            if vsVisible in Result.States then\r\n              Break;\r\n          end;\r\n        until False;\r\n      end\r\n      else\r\n      begin\r\n        // Has this node got children?\r\n        if [vsHasChildren, vsExpanded] * Result.States = [vsHasChildren, vsExpanded] then\r\n        begin\r\n          // Yes, there are child nodes. Initialize them if necessary.\r\n          if Result.ChildCount = 0 then\r\n            InitChildren(Result);\r\n        end;\r\n\r\n        // Child nodes are the first choice if possible.\r\n        if (vsExpanded in Result.States) and Assigned(Result.FirstChild) then\r\n        begin\r\n          Result := GetFirstChild(Result);\r\n          ForceSearch := False;\r\n        end\r\n        else\r\n          ForceSearch := True;\r\n\r\n        // If there are no children or the first child is not visible then search the sibling nodes or traverse parents.\r\n        if Assigned(Result) and (ForceSearch or not (vsVisible in Result.States)) then\r\n        begin\r\n          repeat\r\n            // Is there a next sibling?\r\n            if Assigned(Result.NextSibling) then\r\n            begin\r\n              Result := Result.NextSibling;\r\n              if not (vsInitialized in Result.States) then\r\n                InitNode(Result);\r\n              if vsVisible in Result.States then\r\n                Break;\r\n            end\r\n            else\r\n            begin\r\n              // No sibling anymore, so use the parent's next sibling.\r\n              if Result.Parent <> FRoot then\r\n                Result := Result.Parent\r\n              else\r\n              begin\r\n                // There are no further nodes to examine, hence there is no further visible node.\r\n                Result := nil;\r\n                Break;\r\n              end;\r\n            end;\r\n          until False;\r\n        end;\r\n      end;\r\n    until not Assigned(Result) or IsEffectivelyVisible[Result];\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TBaseVirtualTree.GetNextVisibleNoInit(Node: PVirtualNode; ConsiderChildrenAbove: Boolean = True): PVirtualNode;\r\n\r\n// Returns the next node in tree, with regard to Node, which is visible.\r\n// toChildrenAbove is optionally considered (which is the default). No initialization is done.\r\n\r\nvar\r\n  ForceSearch: Boolean;\r\n\r\nbegin\r\n  Result := Node;\r\n  if Assigned(Result) then\r\n  begin\r\n    Assert(Result <> FRoot, 'Node must not be the hidden root node.');\r\n\r\n    repeat\r\n      if ConsiderChildrenAbove and (toChildrenAbove in FOptions.FPaintOptions) then\r\n      begin\r\n        repeat\r\n          // If there a no siblings anymore, go up one level.\r\n          if not Assigned(Result.NextSibling) then\r\n          begin\r\n            Result := Result.Parent;\r\n            if Result = FRoot then\r\n            begin\r\n              Result := nil;\r\n              Break;\r\n            end;\r\n            if vsVisible in Result.States then\r\n              Break;\r\n          end\r\n          else\r\n          begin\r\n            // There is at least one sibling so take it.\r\n            Result := Result.NextSibling;\r\n            if not (vsVisible in Result.States) then\r\n              Continue;\r\n\r\n            // Now take a look at the children.\r\n            while (vsExpanded in Result.States) and Assigned(Result.FirstChild) do\r\n            begin\r\n              Result := Result.FirstChild;\r\n              if not (vsVisible in Result.States) then\r\n                Break;\r\n            end;\r\n\r\n            // If we found a visible node we don't need to search any longer.\r\n            if vsVisible in Result.States then\r\n              Break;\r\n          end;\r\n        until False;\r\n      end\r\n      else\r\n      begin\r\n        // If the given node is not visible then look for a parent node which is visible, otherwise we will\r\n        // likely go unnecessarily through a whole bunch of invisible nodes.\r\n        if not FullyVisible[Result] then\r\n          Result := GetVisibleParent(Result, True);\r\n\r\n        // Child nodes are the first choice if possible.\r\n        if (vsExpanded in Result.States) and Assigned(Result.FirstChild) then\r\n        begin\r\n          Result := Result.FirstChild;\r\n          ForceSearch := False;\r\n        end\r\n        else\r\n          ForceSearch := True;\r\n\r\n        // If there are no children or the first child is not visible then search the sibling nodes or traverse parents.\r\n        if ForceSearch or not (vsVisible in Result.States) then\r\n        begin\r\n          repeat\r\n            // Is there a next sibling?\r\n            if Assigned(Result.NextSibling) then\r\n            begin\r\n              Result := Result.NextSibling;\r\n              if vsVisible in Result.States then\r\n                Break;\r\n            end\r\n            else\r\n            begin\r\n              // No sibling anymore, so use the parent's next sibling.\r\n              if Result.Parent <> FRoot then\r\n                Result := Result.Parent\r\n              else\r\n              begin\r\n                // There are no further nodes to examine, hence there is no further visible node.\r\n                Result := nil;\r\n                Break;\r\n              end;\r\n            end;\r\n          until False;\r\n        end;\r\n      end;\r\n    until not Assigned(Result) or IsEffectivelyVisible[Result];\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TBaseVirtualTree.GetNextVisibleSibling(Node: PVirtualNode; IncludeFiltered: Boolean = False): PVirtualNode;\r\n\r\n// Returns the next visible sibling after Node. Initialization is done implicitly.\r\n\r\nbegin\r\n  Assert(Assigned(Node) and (Node <> FRoot), 'Invalid parameter.');\r\n\r\n  Result := Node;\r\n  repeat\r\n    Result := GetNextSibling(Result);\r\n  until not Assigned(Result) or ((vsVisible in Result.States) and\r\n        (IncludeFiltered or not IsEffectivelyFiltered[Result]));\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TBaseVirtualTree.GetNextVisibleSiblingNoInit(Node: PVirtualNode; IncludeFiltered: Boolean = False): PVirtualNode;\r\n\r\n// Returns the next visible sibling after Node.\r\n\r\nbegin\r\n  Assert(Assigned(Node) and (Node <> FRoot), 'Invalid parameter.');\r\n\r\n  Result := Node;\r\n  repeat\r\n    Result := Result.NextSibling;\r\n  until not Assigned(Result) or ((vsVisible in Result.States) and\r\n       (IncludeFiltered or not IsEffectivelyFiltered[Result]));\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TBaseVirtualTree.GetNodeAt(X, Y: Integer): PVirtualNode;\r\n\r\n// Overloaded variant of GetNodeAt to easy life of application developers which do not need to have the exact\r\n// top position returned and always use client coordinates.\r\n\r\nvar\r\n  Dummy: Integer;\r\n\r\nbegin\r\n  Result := GetNodeAt(X, Y, True, Dummy);\r\nend;\r\n\r\nfunction TBaseVirtualTree.GetNodeAt(const P: TPoint): PVirtualNode;\r\nbegin\r\n  Result := GetNodeAt(P.X, P.Y);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TBaseVirtualTree.GetNodeAt(X, Y: Integer; Relative: Boolean; var NodeTop: Integer): PVirtualNode;\r\n\r\n// This method returns the node that occupies the specified point, or nil if there's none.\r\n// If Releative is True then X and Y are given in client coordinates otherwise they are considered as being\r\n// absolute values into the virtual tree image (regardless of the current offsets in the tree window).\r\n// NodeTop gets the absolute or relative top position of the node returned or is untouched if no node\r\n// could be found.\r\n\r\nvar\r\n  AbsolutePos,\r\n  CurrentPos: Cardinal;\r\n\r\nbegin\r\n  if Y < 0 then\r\n    Y := 0;\r\n\r\n  AbsolutePos := Y;\r\n  if Relative then\r\n    Inc(AbsolutePos, -FOffsetY);\r\n\r\n  // CurrentPos tracks a running term of the current position to test for.\r\n  // It corresponds always to the top position of the currently considered node.\r\n  CurrentPos := 0;\r\n\r\n  // If the cache is available then use it.\r\n  if tsUseCache in FStates then\r\n    Result := FindInPositionCache(AbsolutePos, CurrentPos)\r\n  else\r\n    Result := GetFirstVisibleNoInit(nil, True);\r\n\r\n  // Determine node, of which position and height corresponds to the scroll position most closely.\r\n  while Assigned(Result) and (Result <> FRoot) do\r\n  begin\r\n    if AbsolutePos < (CurrentPos + NodeHeight[Result]) then\r\n      Break;\r\n    Inc(CurrentPos, NodeHeight[Result]);\r\n    Result := GetNextVisibleNoInit(Result, True);\r\n  end;\r\n\r\n  if Result = FRoot then\r\n    Result := nil;\r\n\r\n  // Since the given vertical position is likely not the same as the top position\r\n  // of the found node this top position is returned.\r\n  if Assigned(Result) then\r\n  begin\r\n    NodeTop := CurrentPos;\r\n    if Relative then\r\n      Inc(NodeTop, FOffsetY);\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\n\r\nfunction TBaseVirtualTree.GetNodeData(Node: PVirtualNode): Pointer;\r\n\r\n// Returns the address of the user defined data area in the node.\r\n\r\nbegin\r\n  Assert(FNodeDataSize > 0, 'NodeDataSize not initialized.');\r\n  if (FNodeDataSize <= 0) or (Node = nil) or (Node = FRoot) then\r\n    Result := nil\r\n  else\r\n  begin\r\n    Result := @Node.Data;\r\n    Include(Node.States, vsOnFreeNodeCallRequired); // We now need to call OnFreeNode, see bug #323\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TBaseVirtualTree.GetNodeData(pNode: PVirtualNode): T;\r\n\r\n// Returns the associated data converted to the class given in the generic part of the function.\r\n\r\nbegin\r\n  if Assigned(pNode) then\r\n    Result := T(Self.GetNodeData(pNode)^)\r\n  else\r\n    Result := Default(T);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TBaseVirtualTree.GetInterfaceFromNodeData(pNode: PVirtualNode): T;\r\nbegin\r\n  if Assigned(pNode) then\r\n    Result := T(Self.GetNodeData(pNode)^)\r\n  else\r\n    Result := nil;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TBaseVirtualTree.GetNodeDataAt(pXCoord, pYCoord: Integer): T;\r\n\r\n// Returns the associated data at the specified coordinates converted to the type given in the generic part of the function.\r\n\r\nvar\r\n  lNode: PVirtualNode;\r\nbegin\r\n  lNode := GetNodeAt(pXCoord, pYCoord);\r\n  Result := Self.GetNodeData(lNode);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TBaseVirtualTree.GetFirstSelectedNodeData(): T;\r\n\r\n// Returns of the first selected node associated data converted to the type given in the generic part of the function.\r\n\r\nbegin\r\n  Result := Self.GetNodeData(GetFirstSelected());\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TBaseVirtualTree.GetNodeLevel(Node: PVirtualNode): Cardinal;\r\n\r\n// returns the level of the given node\r\n\r\nvar\r\n  Run: PVirtualNode;\r\n\r\nbegin\r\n  Result := 0;\r\n  if Assigned(Node) and (Node <> FRoot) then\r\n  begin\r\n    Run := Node.Parent;\r\n    while Run <> FRoot do\r\n    begin\r\n      Run := Run.Parent;\r\n      Inc(Result);\r\n    end;\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TBaseVirtualTree.GetPrevious(Node: PVirtualNode; ConsiderChildrenAbove: Boolean = False): PVirtualNode;\r\n\r\n// Returns previous node in tree. If ConsiderChildrenAbove is True the function considers\r\n// whether toChildrenAbove is currently set, otherwise the result will always be the previous\r\n// node in top-down order regardless of the current PaintOptions.\r\n// The Result will be initialized if needed.\r\n\r\nvar\r\n  Run: PVirtualNode;\r\n\r\nbegin\r\n  Result := Node;\r\n  if Assigned(Result) then\r\n  begin\r\n    Assert(Result <> FRoot, 'Node must not be the hidden root node.');\r\n\r\n    if ConsiderChildrenAbove and (toChildrenAbove in FOptions.FPaintOptions) then\r\n    begin\r\n      // Has this node got children? Initialize them if necessary.\r\n      if (vsHasChildren in Result.States) and (Result.ChildCount = 0) then\r\n        InitChildren(Result);\r\n\r\n      // If there is a last child, take it; if not try the previous sibling.\r\n      if Assigned(Result.LastChild) then\r\n        Result := Result.LastChild\r\n      else\r\n        if Assigned(Result.PrevSibling) then\r\n           Result := Result.PrevSibling\r\n      else\r\n      begin\r\n        // If neither a last child nor a previous sibling exist, go the tree upwards and\r\n        // look, wether one of the parent nodes have a previous sibling. If not the result\r\n        // will ne nil.\r\n        repeat\r\n          Result := Result.Parent;\r\n          Run := nil;\r\n          if Result <> FRoot then\r\n            Run := Result.PrevSibling\r\n          else\r\n            Result := nil;\r\n        until Assigned(Run) or (Result = nil);\r\n\r\n        if Assigned(Run) then\r\n          Result := Run;\r\n      end;\r\n    end\r\n    else\r\n    begin\r\n      // Is there a previous sibling?\r\n      if Assigned(Node.PrevSibling) then\r\n      begin\r\n        // Go down and find the last child node.\r\n        Result := GetLast(Node.PrevSibling);\r\n        if Result = nil then\r\n          Result := Node.PrevSibling;\r\n      end\r\n      else\r\n        // no previous sibling so the parent of the node is the previous visible node\r\n        if Node.Parent <> FRoot then\r\n          Result := Node.Parent\r\n        else\r\n          Result := nil;\r\n    end;\r\n  end;\r\n\r\n  if Assigned(Result) and not (vsInitialized in Result.States) then\r\n    InitNode(Result);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TBaseVirtualTree.GetPreviousChecked(Node: PVirtualNode; State: TCheckState = csCheckedNormal;\r\n  ConsiderChildrenAbove: Boolean = False): PVirtualNode;\r\n\r\nbegin\r\n  if (Node = nil) or (Node = FRoot) then\r\n    Result := GetLastNoInit(nil, ConsiderChildrenAbove)\r\n  else\r\n    Result := GetPreviousNoInit(Node, ConsiderChildrenAbove);\r\n\r\n  while Assigned(Result) and (Result.CheckState <> State) do\r\n    Result := GetPreviousNoInit(Result, ConsiderChildrenAbove);\r\n\r\n  if Assigned(Result) and not (vsInitialized in Result.States) then\r\n    InitNode(Result);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TBaseVirtualTree.GetPreviousCutCopy(Node: PVirtualNode; ConsiderChildrenAbove: Boolean = False): PVirtualNode;\r\n\r\n// Returns the previous node in the tree which is currently marked for a clipboard operation. Since only visible nodes can\r\n// be marked (or they are hidden after they have been marked) it is not necessary to initialize nodes to check for\r\n// child nodes. The result, however, is initialized if necessary.\r\n\r\nbegin\r\n  if ClipboardStates * FStates <> [] then\r\n  begin\r\n    if (Node = nil) or (Node = FRoot) then\r\n      Result := GetLastNoInit(nil, ConsiderChildrenAbove)\r\n    else\r\n      Result := GetPreviousNoInit(Node, ConsiderChildrenAbove);\r\n    while Assigned(Result) and not (vsCutOrCopy in Result.States) do\r\n      Result := GetPreviousNoInit(Result, ConsiderChildrenAbove);\r\n    if Assigned(Result) and not (vsInitialized in Result.States) then\r\n      InitNode(Result);\r\n  end\r\n  else\r\n    Result := nil;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TBaseVirtualTree.GetPreviousInitialized(Node: PVirtualNode; ConsiderChildrenAbove: Boolean = False): PVirtualNode;\r\n\r\n// Returns the previous node in tree which is initialized.\r\n\r\nbegin\r\n  Result := Node;\r\n  repeat\r\n    Result := GetPreviousNoInit(Result, ConsiderChildrenAbove);\r\n  until (Result = nil) or (vsInitialized in Result.States);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TBaseVirtualTree.GetPreviousLeaf(Node: PVirtualNode): PVirtualNode;\r\n\r\n// Returns the previous node in the tree which has currently no children.\r\n// The result is initialized if necessary.\r\n\r\nbegin\r\n  if (Node = nil) or (Node = FRoot) then\r\n    Result := FRoot.LastChild\r\n  else\r\n    Result := GetPrevious(Node);\r\n  while Assigned(Result) and (vsHasChildren in Result.States) do\r\n    Result := GetPrevious(Result);\r\n  if Assigned(Result) and not (vsInitialized in Result.States) then\r\n    InitNode(Result);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TBaseVirtualTree.GetPreviousLevel(Node: PVirtualNode; NodeLevel: Cardinal): PVirtualNode;\r\n\r\n// Returns the previous node in the tree on a specific level.\r\n// The result is initialized if necessary.\r\n\r\nvar\r\n  StartNodeLevel: Cardinal;\r\n  Run: PVirtualNode;\r\n\r\nbegin\r\n  Result := nil;\r\n\r\n  if Assigned(Node) and (Node <> FRoot) then\r\n  begin\r\n    StartNodeLevel := GetNodeLevel(Node);\r\n\r\n    if StartNodeLevel < NodeLevel then\r\n    begin\r\n      Result := Node.PrevSibling;\r\n      if Assigned(Result) then\r\n      begin\r\n        // go to last descendant of previous sibling with desired node level (if exists)\r\n        Run := Result;\r\n        while Assigned(Run) and (GetNodeLevel(Run) < NodeLevel) do\r\n        begin\r\n          Result := Run;\r\n          Run := GetLastChild(Run);\r\n        end;\r\n        if Assigned(Run) and (GetNodeLevel(Run) = NodeLevel) then\r\n          Result := Run\r\n        else\r\n        begin\r\n          if Assigned(Result.PrevSibling) then\r\n            Result := GetPreviousLevel(Result, NodeLevel)\r\n          else\r\n            if Assigned(Result) and (Result.Parent <> FRoot) then\r\n              Result := GetPreviousLevel(Result.Parent, NodeLevel)\r\n          else\r\n            Result := nil;\r\n        end;\r\n      end\r\n      else\r\n        Result := GetPreviousLevel(Node.Parent, NodeLevel);\r\n    end\r\n    else\r\n      if StartNodeLevel = NodeLevel then\r\n      begin\r\n        Result := Node.PrevSibling;\r\n        if not Assigned(Result) then // i.e. start node was a first sibling\r\n        begin\r\n          Result := Node.Parent;\r\n          if Assigned(Result) then\r\n            Result := GetPreviousLevel(Result, NodeLevel);\r\n        end;\r\n      end\r\n      else // i.e. StartNodeLevel > NodeLevel\r\n        Result := GetPreviousLevel(Node.Parent, NodeLevel);\r\n  end;\r\n\r\n  if Assigned(Result) and not (vsInitialized in Result.States) then\r\n    InitNode(Result);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TBaseVirtualTree.GetPreviousNoInit(Node: PVirtualNode; ConsiderChildrenAbove: Boolean = False): PVirtualNode;\r\n\r\n// Returns previous node in tree, optionally considering toChildrenAbove. No initialization is performed.\r\n\r\nvar\r\n  Run: PVirtualNode;\r\n\r\nbegin\r\n  Result := Node;\r\n  if Assigned(Result) then\r\n  begin\r\n    Assert(Result <> FRoot, 'Node must not be the hidden root node.');\r\n\r\n    if ConsiderChildrenAbove and (toChildrenAbove in FOptions.FPaintOptions) then\r\n    begin\r\n      // If there is a last child, take it; if not try the previous sibling.\r\n      if Assigned(Result.LastChild) then\r\n        Result := Result.LastChild\r\n      else\r\n        if Assigned(Result.PrevSibling) then\r\n          Result := Result.PrevSibling\r\n        else\r\n        begin\r\n          // If neither a last child nor a previous sibling exist, go the tree upwards and\r\n          // look, wether one of the parent nodes have a previous sibling. If not the result\r\n          // will ne nil.\r\n          repeat\r\n            Result := Result.Parent;\r\n            Run := nil;\r\n            if Result <> FRoot then\r\n              Run := Result.PrevSibling\r\n            else\r\n              Result := nil;\r\n          until Assigned(Run) or (Result = nil);\r\n\r\n          if Assigned(Run) then\r\n            Result := Run;\r\n        end;\r\n    end\r\n    else\r\n    begin\r\n      // Is there a previous sibling?\r\n      if Assigned(Node.PrevSibling) then\r\n      begin\r\n        // Go down and find the last child node.\r\n        Result := GetLastNoInit(Node.PrevSibling);\r\n        if Result = nil then\r\n          Result := Node.PrevSibling;\r\n      end\r\n      else\r\n        // No previous sibling so the parent of the node is the previous node.\r\n        if Node.Parent <> FRoot then\r\n          Result := Node.Parent\r\n        else\r\n          Result := nil;\r\n    end;\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TBaseVirtualTree.GetPreviousSelected(Node: PVirtualNode; ConsiderChildrenAbove: Boolean = False): PVirtualNode;\r\n\r\n// Returns the previous node in the tree which is currently selected. Since children of unitialized nodes cannot be\r\n// in the current selection (because they simply do not exist yet) it is not necessary to initialize nodes here.\r\n// The result however is initialized if necessary.\r\n\r\nbegin\r\n  if FSelectionCount > 0 then\r\n  begin\r\n    if (Node = nil) or (Node = FRoot) then\r\n      Result := FRoot.LastChild\r\n    else\r\n      Result := GetPreviousNoInit(Node, ConsiderChildrenAbove);\r\n    while Assigned(Result) and not (vsSelected in Result.States) do\r\n      Result := GetPreviousNoInit(Result, ConsiderChildrenAbove);\r\n    if Assigned(Result) and not (vsInitialized in Result.States) then\r\n      InitNode(Result);\r\n  end\r\n  else\r\n    Result := nil;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TBaseVirtualTree.GetPreviousSibling(Node: PVirtualNode): PVirtualNode;\r\n\r\n// Returns the previous sibling of Node and initializes it if necessary.\r\n\r\nbegin\r\n  Result := Node;\r\n  if Assigned(Result) then\r\n  begin\r\n    Assert(Result <> FRoot, 'Node must not be the hidden root node.');\r\n\r\n    Result := Result.PrevSibling;\r\n    if Assigned(Result) and not (vsInitialized in Result.States) then\r\n      InitNode(Result);\r\n  end;\r\nend;\r\n\r\nfunction TBaseVirtualTree.GetPreviousSiblingNoInit(Node: PVirtualNode): PVirtualNode;\r\n\r\n// Returns the previous sibling of Node\r\n\r\nbegin\r\n  Result := Node;\r\n  if Assigned(Result) then\r\n  begin\r\n    Assert(Result <> FRoot, 'Node must not be the hidden root node.');\r\n\r\n    Result := Result.PrevSibling;\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TBaseVirtualTree.GetPreviousVisible(Node: PVirtualNode; ConsiderChildrenAbove: Boolean = True): PVirtualNode;\r\n\r\n// Returns the previous node in tree, with regard to Node, which is visible.\r\n// Nodes which need an initialization (including the result) are initialized.\r\n// toChildrenAbove is optionally considered which is the default here.\r\n\r\nvar\r\n  Marker: PVirtualNode;\r\n\r\nbegin\r\n  Result := Node;\r\n  if Assigned(Result) then\r\n  begin\r\n    Assert(Result <> FRoot, 'Node must not be the hidden root node.');\r\n\r\n    repeat\r\n      // If the given node is not visible then look for a parent node which is visible and use its last visible\r\n      // child or the parent node (if there is no visible child) as result.\r\n      if not FullyVisible[Result] then\r\n      begin\r\n        Result := GetVisibleParent(Result, True);\r\n        if Result = FRoot then\r\n          Result := nil;\r\n        Marker := GetLastVisible(Result, True);\r\n        if Assigned(Marker) then\r\n          Result := Marker;\r\n      end\r\n      else\r\n      begin\r\n        if ConsiderChildrenAbove and (toChildrenAbove in FOptions.FPaintOptions) then\r\n        begin\r\n          repeat\r\n            if Assigned(Result.LastChild) and (vsExpanded in Result.States) then\r\n            begin\r\n              Result := Result.LastChild;\r\n              if not (vsInitialized in Result.States) then\r\n                InitNode(Result);\r\n\r\n              if vsVisible in Result.States then\r\n                Break;\r\n            end\r\n            else\r\n              if Assigned(Result.PrevSibling) then\r\n              begin\r\n                if not (vsInitialized in Result.PrevSibling.States) then\r\n                  InitNode(Result.PrevSibling);\r\n\r\n                if vsVisible in Result.PrevSibling.States then\r\n                begin\r\n                  Result := Result.PrevSibling;\r\n                  Break;\r\n                end;\r\n              end\r\n              else\r\n              begin\r\n                Marker := nil;\r\n                repeat\r\n                  Result := Result.Parent;\r\n                  if Result <> FRoot then\r\n                    Marker := GetPreviousVisibleSibling(Result, True)\r\n                  else\r\n                    Result := nil;\r\n                until Assigned(Marker) or (Result = nil);\r\n                if Assigned(Marker) then\r\n                  Result := Marker;\r\n\r\n                Break;\r\n              end;\r\n          until False;\r\n        end\r\n        else\r\n        begin\r\n          repeat\r\n            // Is there a previous sibling node?\r\n            if Assigned(Result.PrevSibling) then\r\n            begin\r\n              Result := Result.PrevSibling;\r\n              // Initialize the new node and check its visibility.\r\n              if not (vsInitialized in Result.States) then\r\n                InitNode(Result);\r\n              if vsVisible in Result.States then\r\n              begin\r\n                // If there are visible child nodes then use the last one.\r\n                Marker := GetLastVisible(Result, True, True);\r\n                if Assigned(Marker) then\r\n                  Result := Marker;\r\n                Break;\r\n              end;\r\n            end\r\n            else\r\n            begin\r\n              // No previous sibling there so the parent node is the nearest previous node.\r\n              Result := Result.Parent;\r\n              if Result = FRoot then\r\n                Result := nil;\r\n              Break;\r\n            end;\r\n          until False;\r\n        end;\r\n\r\n        if Assigned(Result) and not (vsInitialized in Result.States) then\r\n          InitNode(Result);\r\n      end;\r\n    until not Assigned(Result) or IsEffectivelyVisible[Result];\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TBaseVirtualTree.GetPreviousVisibleNoInit(Node: PVirtualNode;\r\n  ConsiderChildrenAbove: Boolean = True): PVirtualNode;\r\n\r\n// Returns the previous node in tree, with regard to Node, which is visible.\r\n// toChildrenAbove is optionally considered which is the default here.\r\n\r\nvar\r\n  Marker: PVirtualNode;\r\n\r\nbegin\r\n  Result := Node;\r\n  if Assigned(Result) then\r\n  begin\r\n    Assert(Result <> FRoot, 'Node must not be the hidden root node.');\r\n\r\n    repeat\r\n      // If the given node is not visible then look for a parent node which is visible and use its last visible\r\n      // child or the parent node (if there is no visible child) as result.\r\n      if not FullyVisible[Result] then\r\n      begin\r\n        Result := GetVisibleParent(Result, True);\r\n        if Result = FRoot then\r\n          Result := nil;\r\n        Marker := GetLastVisibleNoInit(Result, True);\r\n        if Assigned(Marker) then\r\n          Result := Marker;\r\n      end\r\n      else\r\n      begin\r\n        if ConsiderChildrenAbove and (toChildrenAbove in FOptions.FPaintOptions) then\r\n        begin\r\n          repeat\r\n            // Is the current node expanded and has children?\r\n            if (vsExpanded in Result.States) and Assigned(Result.LastChild) then\r\n            begin\r\n              Result := Result.LastChild;\r\n              if vsVisible in Result.States then\r\n                Break;\r\n            end\r\n            else\r\n              if Assigned(Result.PrevSibling) then\r\n              begin\r\n                // No children anymore, so take the previous sibling.\r\n                if vsVisible in Result.PrevSibling.States then\r\n                begin\r\n                  Result := Result.PrevSibling;\r\n                  Break;\r\n                end;\r\n              end\r\n              else\r\n              begin\r\n                // No children and no previous siblings, so walk up the tree and look wether\r\n                // a parent has a previous visible sibling. If that is the case take it,\r\n                // otherwise there is no previous visible node.\r\n                Marker := nil;\r\n                repeat\r\n                  Result := Result.Parent;\r\n                  if Result <> FRoot then\r\n                    Marker := GetPreviousVisibleSiblingNoInit(Result, True)\r\n                  else\r\n                    Result := nil;\r\n                until Assigned(Marker) or (Result = nil);\r\n                if Assigned(Marker) then\r\n                  Result := Marker;\r\n                Break;\r\n              end;\r\n          until False;\r\n        end\r\n        else\r\n        begin\r\n          repeat\r\n            // Is there a previous sibling node?\r\n            if Assigned(Result.PrevSibling) then\r\n            begin\r\n              Result := Result.PrevSibling;\r\n              if vsVisible in Result.States then\r\n              begin\r\n                // If there are visible child nodes then use the last one.\r\n                Marker := GetLastVisibleNoInit(Result, True, True);\r\n                if Assigned(Marker) then\r\n                  Result := Marker;\r\n                Break;\r\n              end;\r\n            end\r\n            else\r\n            begin\r\n              // No previous sibling there so the parent node is the nearest previous node.\r\n              Result := Result.Parent;\r\n              if Result = FRoot then\r\n                Result := nil;\r\n              Break;\r\n            end;\r\n          until False;\r\n        end;\r\n      end;\r\n    until not Assigned(Result) or IsEffectivelyVisible[Result];\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TBaseVirtualTree.GetPreviousVisibleSibling(Node: PVirtualNode; IncludeFiltered: Boolean = False): PVirtualNode;\r\n\r\n// Returns the previous visible sibling before Node. Initialization is done implicitly.\r\n\r\nbegin\r\n  Assert(Assigned(Node) and (Node <> FRoot), 'Invalid parameter.');\r\n\r\n  Result := Node;\r\n  repeat\r\n    Result := GetPreviousSibling(Result);\r\n  until not Assigned(Result) or ((vsVisible in Result.States) and\r\n        (IncludeFiltered or not IsEffectivelyFiltered[Result]));\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TBaseVirtualTree.GetPreviousVisibleSiblingNoInit(Node: PVirtualNode;\r\n  IncludeFiltered: Boolean = False): PVirtualNode;\r\n\r\n// Returns the previous visible sibling before Node.\r\n\r\nbegin\r\n  Assert(Assigned(Node) and (Node <> FRoot), 'Invalid parameter.');\r\n\r\n  Result := Node;\r\n  repeat\r\n    Result := Result.PrevSibling;\r\n  until not Assigned(Result) or ((vsVisible in Result.States) and\r\n        (IncludeFiltered or not IsEffectivelyFiltered[Result]));\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TBaseVirtualTree.Nodes(ConsiderChildrenAbove: Boolean): TVTVirtualNodeEnumeration;\r\n\r\n// Enumeration for all nodes\r\n\r\nbegin\r\n  Result.FMode := vneAll;\r\n  Result.FTree := Self;\r\n  Result.FConsiderChildrenAbove := ConsiderChildrenAbove;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TBaseVirtualTree.CheckedNodes(State: TCheckState; ConsiderChildrenAbove: Boolean): TVTVirtualNodeEnumeration;\r\n\r\n// Enumeration for all checked nodes\r\n\r\nbegin\r\n  Result.FMode := vneChecked;\r\n  Result.FTree := Self;\r\n  Result.FState := State;\r\n  Result.FConsiderChildrenAbove := ConsiderChildrenAbove;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TBaseVirtualTree.ChildNodes(Node: PVirtualNode): TVTVirtualNodeEnumeration;\r\n\r\n// Enumeration for child nodes\r\n\r\nbegin\r\n  Result.FMode := vneChild;\r\n  Result.FTree := Self;\r\n  Result.FNode := Node;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TBaseVirtualTree.CutCopyNodes(ConsiderChildrenAbove: Boolean): TVTVirtualNodeEnumeration;\r\n\r\n// Enumeration for cut copy node\r\n\r\nbegin\r\n  Result.FMode := vneCutCopy;\r\n  Result.FTree := Self;\r\n  Result.FConsiderChildrenAbove := ConsiderChildrenAbove;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TBaseVirtualTree.InitializedNodes(ConsiderChildrenAbove: Boolean): TVTVirtualNodeEnumeration;\r\n\r\n// Enumeration for initialized nodes\r\n\r\nbegin\r\n  Result.FMode := vneInitialized;\r\n  Result.FTree := Self;\r\n  Result.FConsiderChildrenAbove := ConsiderChildrenAbove;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TBaseVirtualTree.LeafNodes: TVTVirtualNodeEnumeration;\r\n\r\n// Enumeration for leaf nodes\r\n\r\nbegin\r\n  Result.FMode := vneLeaf;\r\n  Result.FTree := Self;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TBaseVirtualTree.LevelNodes(NodeLevel: Cardinal): TVTVirtualNodeEnumeration;\r\n\r\n// Enumeration for level nodes\r\n\r\nbegin\r\n  Result.FMode := vneLevel;\r\n  Result.FTree := Self;\r\n  Result.FNodeLevel := NodeLevel;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TBaseVirtualTree.NoInitNodes(ConsiderChildrenAbove: Boolean): TVTVirtualNodeEnumeration;\r\n\r\n// Enumeration for no init nodes\r\nbegin\r\n  Result.FMode := vneNoInit;\r\n  Result.FTree := Self;\r\n  Result.FConsiderChildrenAbove := ConsiderChildrenAbove;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TBaseVirtualTree.SelectedNodes(ConsiderChildrenAbove: Boolean): TVTVirtualNodeEnumeration;\r\n\r\n// Enumeration for selected nodes\r\n\r\nbegin\r\n  Result.FMode := vneSelected;\r\n  Result.FTree := Self;\r\n  Result.FConsiderChildrenAbove := ConsiderChildrenAbove;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TBaseVirtualTree.VisibleNodes(Node: PVirtualNode; ConsiderChildrenAbove: Boolean;\r\n  IncludeFiltered: Boolean): TVTVirtualNodeEnumeration;\r\n\r\n// Enumeration for visible nodes\r\n\r\nbegin\r\n  Result.FMode := vneVisible;\r\n  Result.FTree := Self;\r\n  Result.FNode := Node;\r\n  Result.FConsiderChildrenAbove := ConsiderChildrenAbove;\r\n  Result.FIncludeFiltered := IncludeFiltered;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TBaseVirtualTree.VisibleChildNodes(Node: PVirtualNode; IncludeFiltered: Boolean): TVTVirtualNodeEnumeration;\r\n\r\n// Enumeration for visible child nodes\r\n\r\nbegin\r\n  Result.FMode := vneVisibleChild;\r\n  Result.FTree := Self;\r\n  Result.FNode := Node;\r\n  Result.FIncludeFiltered := IncludeFiltered;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TBaseVirtualTree.VisibleChildNoInitNodes(Node: PVirtualNode; IncludeFiltered: Boolean): TVTVirtualNodeEnumeration;\r\n\r\n// Enumeration for visible child no init nodes\r\n\r\nbegin\r\n  Result.FMode := vneVisibleNoInitChild;\r\n  Result.FTree := Self;\r\n  Result.FNode := Node;\r\n  Result.FIncludeFiltered := IncludeFiltered;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TBaseVirtualTree.VisibleNoInitNodes(Node: PVirtualNode; ConsiderChildrenAbove: Boolean;\r\n  IncludeFiltered: Boolean): TVTVirtualNodeEnumeration;\r\n\r\n// Enumeration for visible no init nodes\r\n\r\nbegin\r\n  Result.FMode := vneVisibleNoInit;\r\n  Result.FTree := Self;\r\n  Result.FNode := Node;\r\n  Result.FConsiderChildrenAbove := ConsiderChildrenAbove;\r\n  Result.FIncludeFiltered := IncludeFiltered;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TBaseVirtualTree.GetSortedCutCopySet(Resolve: Boolean): TNodeArray;\r\n\r\n// Same as GetSortedSelection but with nodes marked as being part in the current cut/copy set (e.g. for clipboard).\r\n\r\nvar\r\n  Run: PVirtualNode;\r\n  Counter: Cardinal;\r\n\r\n  //--------------- local function --------------------------------------------\r\n\r\n  procedure IncludeThisNode(Node: PVirtualNode);\r\n\r\n  // adds the given node to the result\r\n\r\n  var\r\n    Len: Cardinal;\r\n\r\n  begin\r\n    Len := Length(Result);\r\n    if Counter = Len then\r\n    begin\r\n      if Len < 100 then\r\n        Len := 100\r\n      else\r\n        Len := Len + Len div 10;\r\n      SetLength(Result, Len);\r\n    end;\r\n    Result[Counter] := Node;\r\n    Inc(Counter);\r\n  end;\r\n\r\n  //--------------- end local function ----------------------------------------\r\n\r\nbegin\r\n  Run := FRoot.FirstChild;\r\n  Counter := 0;\r\n  if Resolve then\r\n  begin\r\n    // Resolving is actually easy: just find the first cutted node in logical order\r\n    // and then never go deeper in level than this node as long as there's a sibling node.\r\n    // Restart the search for a cutted node (at any level) if there are no further siblings.\r\n    while Assigned(Run) do\r\n    begin\r\n      if vsCutOrCopy in Run.States then\r\n      begin\r\n        IncludeThisNode(Run);\r\n        if Assigned(Run.NextSibling) then\r\n          Run := Run.NextSibling\r\n        else\r\n        begin\r\n          // If there are no further siblings then go up one or more levels until a node is\r\n          // found or all nodes have been processed. Although we consider here only initialized\r\n          // nodes we don't need to make any special checks as only initialized nodes can also be selected.\r\n          repeat\r\n            Run := Run.Parent;\r\n          until (Run = FRoot) or Assigned(Run.NextSibling);\r\n          if Run = FRoot then\r\n            Break\r\n          else\r\n            Run := Run.NextSibling;\r\n        end;\r\n      end\r\n      else\r\n        Run := GetNextNoInit(Run);\r\n    end;\r\n  end\r\n  else\r\n    while Assigned(Run) do\r\n    begin\r\n      if vsCutOrCopy in Run.States then\r\n        IncludeThisNode(Run);\r\n      Run := GetNextNoInit(Run);\r\n    end;\r\n\r\n  // set the resulting array to its real length\r\n  SetLength(Result, Counter);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TBaseVirtualTree.GetSortedSelection(Resolve: Boolean): TNodeArray;\r\n\r\n// Returns a list of selected nodes sorted in logical order, that is, as they appear in the tree.\r\n// If Resolve is True then nodes which are children of other selected nodes are not put into the new array.\r\n// This feature is in particuar important when doing drag'n drop as in this case all selected node plus their children\r\n// need to be considered. A selected node which is child (grand child etc.) of another selected node is then\r\n// automatically included and doesn't need to be explicitely mentioned in the returned selection array.\r\n//\r\n// Note: The caller is responsible for freeing the array. Allocation is done here. Usually, though, freeing the array\r\n//       doesn't need additional attention as it is automatically freed by Delphi when it gets out of scope.\r\n\r\nvar\r\n  Run: PVirtualNode;\r\n  Counter: Cardinal;\r\n\r\nbegin\r\n  SetLength(Result, FSelectionCount);\r\n  if FSelectionCount > 0 then\r\n  begin\r\n    Run := FRoot.FirstChild;\r\n    Counter := 0;\r\n    if Resolve then\r\n    begin\r\n      // Resolving is actually easy: just find the first selected node in logical order\r\n      // and then never go deeper in level than this node as long as there's a sibling node.\r\n      // Restart the search for a selected node (at any level) if there are no further siblings.\r\n      while Assigned(Run) do\r\n      begin\r\n        if vsSelected in Run.States then\r\n        begin\r\n          Result[Counter] := Run;\r\n          Inc(Counter);\r\n          if Assigned(Run.NextSibling) then\r\n            Run := Run.NextSibling\r\n          else\r\n          begin\r\n            // If there are no further siblings then go up one or more levels until a node is\r\n            // found or all nodes have been processed. Although we consider here only initialized\r\n            // nodes we don't need to make any special checks as only initialized nodes can also be selected.\r\n            repeat\r\n              Run := Run.Parent;\r\n            until (Run = FRoot) or Assigned(Run.NextSibling);\r\n            if Run = FRoot then\r\n              Break\r\n            else\r\n              Run := Run.NextSibling;\r\n          end;\r\n        end\r\n        else\r\n          Run := GetNextNoInit(Run);\r\n      end;\r\n    end\r\n    else\r\n      while Assigned(Run) do\r\n      begin\r\n        if vsSelected in Run.States then\r\n        begin\r\n          Result[Counter] := Run;\r\n          Inc(Counter);\r\n        end;\r\n        Run := GetNextNoInit(Run);\r\n      end;\r\n\r\n    // Since we may have skipped some nodes the result array is likely to be smaller than the\r\n    // selection array, hence shorten the result to true length.\r\n    if Integer(Counter) < Length(Result) then\r\n      SetLength(Result, Counter);\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.GetTextInfo(Node: PVirtualNode; Column: TColumnIndex; const AFont: TFont; var R: TRect;\r\n  var Text: string);\r\n\r\n// Generic base method for editors, hint windows etc. to get some info about a node.\r\n\r\nbegin\r\n  R := Rect(0, 0, 0, 0);\r\n  Text := '';\r\n  AFont.Assign(Font);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TBaseVirtualTree.GetTreeRect: TRect;\r\n\r\n// Returns the true size of the tree in pixels. This size is at least ClientHeight x ClientWidth and depends on\r\n// the expand state, header size etc.\r\n// Note: if no columns are used then the width of the tree is determined by the largest node which is currently in the\r\n//       client area. This might however not be the largest node in the entire tree.\r\n\r\nbegin\r\n  Result := Rect(0, 0, Max(FRangeX, ClientWidth), Max(FRangeY, ClientHeight));\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TBaseVirtualTree.GetVisibleParent(Node: PVirtualNode; IncludeFiltered: Boolean = False): PVirtualNode;\r\n\r\n// Returns the first (nearest) parent node of Node which is visible.\r\n// This method is one of the seldom cases where the hidden root node could be returned.\r\n\r\nbegin\r\n  Assert(Assigned(Node), 'Node must not be nil.');\r\n  Assert(Node <> FRoot, 'Node must not be the hidden root node.');\r\n\r\n  Result := Node.Parent;\r\n  while (Result <> FRoot) and (not FullyVisible[Result] or (not IncludeFiltered and IsEffectivelyFiltered[Result])) do\r\n    Result := Result.Parent;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TBaseVirtualTree.HasAsParent(Node, PotentialParent: PVirtualNode): Boolean;\r\n\r\n// Determines whether Node has got PotentialParent as one of its parents.\r\n\r\nvar\r\n  Run: PVirtualNode;\r\n\r\nbegin\r\n  Result := Assigned(Node) and Assigned(PotentialParent) and (Node <> PotentialParent);\r\n  if Result then\r\n  begin\r\n    Run := Node;\r\n    while (Run <> FRoot) and (Run <> PotentialParent) do\r\n      Run := Run.Parent;\r\n    Result := Run = PotentialParent;\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TBaseVirtualTree.InsertNode(Node: PVirtualNode; Mode: TVTNodeAttachMode; UserData: Pointer = nil): PVirtualNode;\r\n\r\n// Adds a new node relative to Node. The final position is determined by Mode.\r\n// UserData can be used to set the first SizeOf(Pointer) bytes of the user data area to an initial value which can be used\r\n// in OnInitNode and will also cause to trigger the OnFreeNode event (if <> nil) even if the node is not yet\r\n// \"officially\" initialized.\r\n// InsertNode is a compatibility method and will implicitly validate the given node if the new node\r\n// is to be added as child node. This is however against the virtual paradigm and hence I dissuade from its usage.\r\n\r\nbegin\r\n  if Mode <> amNoWhere then\r\n  begin\r\n    CancelEditNode;\r\n\r\n    if Node = nil then\r\n      Node := FRoot;\r\n    // we need a new node...\r\n    Result := MakeNewNode;\r\n    // avoid erronous attach modes\r\n    if Node = FRoot then\r\n    begin\r\n      case Mode of\r\n        amInsertBefore:\r\n          Mode := amAddChildFirst;\r\n        amInsertAfter:\r\n          Mode := amAddChildLast;\r\n      end;\r\n    end;\r\n\r\n    // Validate given node in case the new node becomes its child.\r\n    if (Mode in [amAddChildFirst, amAddChildLast]) and not (vsInitialized in Node.States) then\r\n      InitNode(Node);\r\n    InternalConnectNode(Result, Node, Self, Mode);\r\n\r\n    // Check if there is initial user data and there is also enough user data space allocated.\r\n    if Assigned(UserData) then\r\n      SetNodeData(Result, UserData);\r\n\r\n    if FUpdateCount = 0 then\r\n    begin\r\n      // If auto sort is enabled then sort the node or its parent (depending on the insert mode).\r\n      if (toAutoSort in FOptions.FAutoOptions) and (FHeader.FSortColumn > InvalidColumn) then\r\n        case Mode of\r\n          amInsertBefore,\r\n          amInsertAfter:\r\n            // Here no initialization is necessary because *if* a node has already got children then it\r\n            // must also be initialized.\r\n            // Note: Node can never be FRoot at this point.\r\n            Sort(Node.Parent, FHeader.FSortColumn, FHeader.FSortDirection, True);\r\n          amAddChildFirst,\r\n          amAddChildLast:\r\n            Sort(Node, FHeader.FSortColumn, FHeader.FSortDirection, True);\r\n        end;\r\n\r\n      UpdateScrollBars(True);\r\n      if Mode = amInsertBefore then\r\n        InvalidateToBottom(Result)\r\n      else\r\n        InvalidateToBottom(Node);\r\n    end;\r\n    StructureChange(Result, crNodeAdded);\r\n  end\r\n  else\r\n    Result := nil;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.InvalidateChildren(Node: PVirtualNode; Recursive: Boolean);\r\n\r\n// Invalidates Node and its immediate children.\r\n// If Recursive is True then all grandchildren are invalidated as well.\r\n// The node itself is initialized if necessary and its child nodes are created (and initialized too if\r\n// Recursive is True).\r\n\r\nvar\r\n  Run: PVirtualNode;\r\n\r\nbegin\r\n  if Assigned(Node) then\r\n  begin\r\n    if not (vsInitialized in Node.States) then\r\n      InitNode(Node);\r\n    InvalidateNode(Node);\r\n    if (vsHasChildren in Node.States) and (Node.ChildCount = 0) then\r\n      InitChildren(Node);\r\n    Run := Node.FirstChild;\r\n  end\r\n  else\r\n    Run := FRoot.FirstChild;\r\n\r\n  while Assigned(Run) do\r\n  begin\r\n    InvalidateNode(Run);\r\n    if Recursive then\r\n      InvalidateChildren(Run, True);\r\n    Run := Run.NextSibling;\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.InvalidateColumn(Column: TColumnIndex);\r\n\r\n// Invalidates the client area part of a column.\r\n\r\nvar\r\n  R: TRect;\r\n\r\nbegin\r\n  if (FUpdateCount = 0) and HandleAllocated and FHeader.FColumns.IsValidColumn(Column) then\r\n  begin\r\n    R := ClientRect;\r\n    FHeader.Columns.GetColumnBounds(Column, R.Left, R.Right);\r\n    InvalidateRect(Handle, @R, False);\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TBaseVirtualTree.InvalidateNode(Node: PVirtualNode): TRect;\r\n\r\n// Initiates repaint of the given node and returns the just invalidated rectangle.\r\n\r\nbegin\r\n  if (FUpdateCount = 0) and HandleAllocated then\r\n  begin\r\n    Result := GetDisplayRect(Node, NoColumn, False);\r\n    InvalidateRect(Handle, @Result, False);\r\n  end\r\n  else\r\n    result := Rect(-1,-1,-1,-1);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.InvalidateToBottom(Node: PVirtualNode);\r\n\r\n// Initiates repaint of client area starting at given node. If this node is not visible or not yet initialized\r\n// then nothing happens.\r\n\r\nvar\r\n  R: TRect;\r\n\r\nbegin\r\n  if (FUpdateCount = 0) and HandleAllocated then\r\n  begin\r\n    if (Node = nil) or (Node = FRoot) then\r\n      Invalidate\r\n    else\r\n      if (vsInitialized in Node.States) and IsEffectivelyVisible[Node] then\r\n      begin\r\n        R := GetDisplayRect(Node, -1, False);\r\n        if R.Top < ClientHeight then\r\n        begin\r\n          if (toChildrenAbove in FOptions.FPaintOptions) and (vsExpanded in Node.States) then\r\n            Dec(R.Top, Node.TotalHeight + NodeHeight[Node]);\r\n          R.Bottom := ClientHeight;\r\n          InvalidateRect(Handle, @R, False);\r\n        end;\r\n      end;\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.InvertSelection(VisibleOnly: Boolean);\r\n\r\n// Inverts the current selection (so nodes which are selected become unselected and vice versa).\r\n// If VisibleOnly is True then only visible nodes are considered.\r\n\r\nvar\r\n  Run: PVirtualNode;\r\n  NewSize: Integer;\r\n  NextFunction: TGetNextNodeProc;\r\n  TriggerChange: Boolean;\r\n\r\nbegin\r\n  if not FSelectionLocked and (toMultiSelect in FOptions.FSelectionOptions) then\r\n  begin\r\n    Run := FRoot.FirstChild;\r\n    ClearTempCache;\r\n    if VisibleOnly then\r\n      NextFunction := GetNextVisibleNoInit\r\n    else\r\n      NextFunction := GetNextNoInit;\r\n    while Assigned(Run) do\r\n    begin\r\n      if vsSelected in Run.States then\r\n        InternalRemoveFromSelection(Run)\r\n      else\r\n        InternalCacheNode(Run);\r\n      Run := NextFunction(Run);\r\n    end;\r\n\r\n    // do some housekeeping\r\n    // Need to trigger the OnChange event from here if nodes were only deleted but not added.\r\n    TriggerChange := False;\r\n    NewSize := PackArray(FSelection, FSelectionCount);\r\n    if NewSize > -1 then\r\n    begin\r\n      FSelectionCount := NewSize;\r\n      SetLength(FSelection, FSelectionCount);\r\n      TriggerChange := True;\r\n    end;\r\n    if FTempNodeCount > 0 then\r\n    begin\r\n      AddToSelection(FTempNodeCache, FTempNodeCount);\r\n      ClearTempCache;\r\n      TriggerChange := False;\r\n    end;\r\n    Invalidate;\r\n    if TriggerChange then\r\n      Change(nil);\r\n    if Self.SelectedCount = 0 then\r\n      FNextNodeToSelect := nil;//Ensure that no other node is selected now\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TBaseVirtualTree.IsEditing: Boolean;\r\n\r\nbegin\r\n  Result := tsEditing in FStates;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TBaseVirtualTree.IsMouseSelecting: Boolean;\r\n\r\nbegin\r\n  Result := (tsDrawSelPending in FStates) or (tsDrawSelecting in FStates);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TBaseVirtualTree.IterateSubtree(Node: PVirtualNode; Callback: TVTGetNodeProc; Data: Pointer;\r\n  Filter: TVirtualNodeStates = []; DoInit: Boolean = False; ChildNodesOnly: Boolean = False): PVirtualNode;\r\n\r\n// Iterates through the all children and grandchildren etc. of Node (or the entire tree if Node = nil)\r\n// and calls for each node the provided callback method (which must not be empty).\r\n// Filter determines which nodes to consider (an empty set denotes all nodes).\r\n// If DoInit is True then nodes which aren't initialized yet will be initialized.\r\n// Note: During execution of the callback the application can set Abort to True. In this case the iteration is stopped\r\n//       and the last accessed node (the one on which the callback set Abort to True) is returned to the caller.\r\n//       Otherwise (no abort) nil is returned.\r\n\r\nvar\r\n  Stop: PVirtualNode;\r\n  Abort: Boolean;\r\n  GetNextNode: TGetNextNodeProc;\r\n  WasIterating: Boolean;\r\n\r\nbegin\r\n  Assert(Node <> FRoot, 'Node must not be the hidden root node.');\r\n\r\n  WasIterating := tsIterating in FStates;\r\n  DoStateChange([tsIterating]);\r\n  try\r\n    // prepare function to be used when advancing\r\n    if DoInit then\r\n      GetNextNode := GetNext\r\n    else\r\n      GetNextNode := GetNextNoInit;\r\n\r\n    Abort := False;\r\n    if Node = nil then\r\n      Stop := nil\r\n    else\r\n    begin\r\n      if not (vsInitialized in Node.States) and DoInit then\r\n        InitNode(Node);\r\n\r\n      // The stopper does not need to be initialized since it is not taken into the enumeration.\r\n      Stop := Node.NextSibling;\r\n      if Stop = nil then\r\n      begin\r\n        Stop := Node;\r\n        repeat\r\n          Stop := Stop.Parent;\r\n        until (Stop = FRoot) or Assigned(Stop.NextSibling);\r\n        if Stop = FRoot then\r\n          Stop := nil\r\n        else\r\n          Stop := Stop.NextSibling;\r\n      end;\r\n    end;\r\n\r\n    // Use first node if we start with the root.\r\n    if Node = nil then\r\n      Node := GetFirstNoInit;\r\n\r\n    if Assigned(Node) then\r\n    begin\r\n      if not (vsInitialized in Node.States) and DoInit then\r\n        InitNode(Node);\r\n\r\n      // Skip given node if only the child nodes are requested.\r\n      if ChildNodesOnly then\r\n      begin\r\n        if Node.ChildCount = 0 then\r\n          Node := nil\r\n        else\r\n          Node := GetNextNode(Node);\r\n      end;\r\n\r\n      if Filter = [] then\r\n      begin\r\n        // unfiltered loop\r\n        while Assigned(Node) and (Node <> Stop) do\r\n        begin\r\n          Callback(Self, Node, Data, Abort);\r\n          if Abort then\r\n            Break;\r\n          Node := GetNextNode(Node);\r\n        end;\r\n      end\r\n      else\r\n      begin\r\n        // filtered loop\r\n        while Assigned(Node) and (Node <> Stop) do\r\n        begin\r\n          if Node.States * Filter = Filter then\r\n            Callback(Self, Node, Data, Abort);\r\n          if Abort then\r\n            Break;\r\n          Node := GetNextNode(Node);\r\n        end;\r\n      end;\r\n    end;\r\n\r\n    if Abort then\r\n      Result := Node\r\n    else\r\n      Result := nil;\r\n  finally\r\n    if not WasIterating then\r\n      DoStateChange([], [tsIterating]);\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.LoadFromFile(const FileName: TFileName);\r\n\r\nvar\r\n  FileStream: TFileStream;\r\n\r\nbegin\r\n  FileStream := TFileStream.Create(FileName, fmOpenRead or fmShareDenyWrite);\r\n  try\r\n    LoadFromStream(FileStream);\r\n  finally\r\n    FileStream.Free;\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.LoadFromStream(Stream: TStream);\r\n\r\n// Clears the current content of the tree and loads a new structure from the given stream.\r\n\r\nvar\r\n  ThisID: TMagicID;\r\n  Version,\r\n  Count: Cardinal;\r\n  Node: PVirtualNode;\r\n\r\nbegin\r\n  if not (toReadOnly in FOptions.FMiscOptions) then\r\n  begin\r\n    Clear;\r\n    // Check first whether this is a stream we can read.\r\n    if Stream.Read(ThisID, SizeOf(TMagicID)) < SizeOf(TMagicID) then\r\n      ShowError(SStreamTooSmall, hcTFStreamTooSmall);\r\n\r\n    if (ThisID[0] = MagicID[0]) and\r\n       (ThisID[1] = MagicID[1]) and\r\n       (ThisID[2] = MagicID[2]) and\r\n       (ThisID[5] = MagicID[5]) then\r\n    begin\r\n      Version := Word(ThisID[3]);\r\n      if Version <= VTTreeStreamVersion then\r\n      begin\r\n        BeginUpdate;\r\n        try\r\n          if Version < 2 then\r\n            Count := MaxInt\r\n          else\r\n            Stream.ReadBuffer(Count, SizeOf(Count));\r\n\r\n          while (Stream.Position < Stream.Size) and (Count > 0) do\r\n          begin\r\n            Dec(Count);\r\n            Node := MakeNewNode;\r\n            InternalConnectNode(Node, FRoot, Self, amAddChildLast);\r\n            InternalAddFromStream(Stream, Version, Node);\r\n          end;\r\n          DoNodeCopied(nil);\r\n          if Assigned(FOnLoadTree) then\r\n            FOnLoadTree(Self, Stream);\r\n        finally\r\n          EndUpdate;\r\n        end;\r\n      end\r\n      else\r\n        ShowError(SWrongStreamVersion, hcTFWrongStreamVersion);\r\n    end\r\n    else\r\n      ShowError(SWrongStreamFormat, hcTFWrongStreamFormat);\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.MeasureItemHeight(const Canvas: TCanvas; Node: PVirtualNode);\r\n\r\n// If the height of the given node has not yet been measured then do it now.\r\n\r\nvar\r\n  NewNodeHeight: Integer;\r\n\r\nbegin\r\n  if not (vsHeightMeasured in Node.States) then\r\n  begin\r\n    Include(Node.States, vsHeightMeasured);\r\n    if (toVariableNodeHeight in FOptions.FMiscOptions) then\r\n    begin\r\n      NewNodeHeight := Node.NodeHeight;\r\n      // Anonymous methods help to make this thread safe easily. \r\n      if (MainThreadId <> GetCurrentThreadId) then\r\n        TThread.Synchronize(nil,\r\n          procedure\r\n          begin\r\n            DoMeasureItem(Canvas, Node, NewNodeHeight);\r\n            SetNodeHeight(Node, NewNodeHeight);\r\n          end\r\n        )\r\n      else\r\n      begin\r\n        DoMeasureItem(Canvas, Node, NewNodeHeight);\r\n        SetNodeHeight(Node, NewNodeHeight);\r\n      end;\r\n    end;\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.MoveTo(Node: PVirtualNode; Tree: TBaseVirtualTree; Mode: TVTNodeAttachMode;\r\n  ChildrenOnly: Boolean);\r\n\r\n// A simplified method to allow to move nodes to the root of another tree.\r\n\r\nbegin\r\n  MoveTo(Node, Tree.FRoot, Mode, ChildrenOnly);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.MoveTo(Source, Target: PVirtualNode; Mode: TVTNodeAttachMode; ChildrenOnly: Boolean);\r\n\r\n// Moves the given node (and all its children) to Target. Source must belong to the tree instance which calls this\r\n// MoveTo method. Mode determines how to connect Source to Target.\r\n// This method might involve a change of the tree if Target belongs to a different tree than Source.\r\n\r\nvar\r\n  TargetTree: TBaseVirtualTree;\r\n  Allowed: Boolean;\r\n  NewNode: PVirtualNode;\r\n  Stream: TMemoryStream;\r\n\r\nbegin\r\n  Assert(TreeFromNode(Source) = Self, 'The source tree must contain the source node.');\r\n\r\n  // When moving nodes then source and target must not be the same node unless only the source's children are\r\n  // moved and they are inserted before or after the node itself.\r\n  Allowed := (Source <> Target) or ((Mode in [amInsertBefore, amInsertAfter]) and ChildrenOnly);\r\n\r\n  if Allowed and (Mode <> amNoWhere) and Assigned(Source) and (Source <> FRoot) and\r\n    not (toReadOnly in FOptions.FMiscOptions) then\r\n  begin\r\n    // Assume that an empty destination means the root in this (the source) tree.\r\n    if Target = nil then\r\n    begin\r\n      TargetTree := Self;\r\n      Target := FRoot;\r\n      Mode := amAddChildFirst;\r\n    end\r\n    else\r\n      TargetTree := TreeFromNode(Target);\r\n\r\n    if Target = TargetTree.FRoot then\r\n    begin\r\n      case Mode of\r\n        amInsertBefore:\r\n          Mode := amAddChildFirst;\r\n        amInsertAfter:\r\n          Mode := amAddChildLast;\r\n      end;\r\n    end;\r\n\r\n    // Make sure the target node is initialized.\r\n    if not (vsInitialized in Target.States) then\r\n      TargetTree.InitNode(Target)\r\n    else\r\n      if (vsHasChildren in Target.States) and (Target.ChildCount = 0) then\r\n        TargetTree.InitChildren(Target);\r\n\r\n    if TargetTree = Self then\r\n    begin\r\n      // Simple case: move node(s) within the same tree.\r\n      if Target = FRoot then\r\n        Allowed := DoNodeMoving(Source, nil)\r\n      else\r\n        Allowed := DoNodeMoving(Source, Target);\r\n      if Allowed then\r\n      begin\r\n        // Check first that Source is not added as new child to a target node which\r\n        // is already a child of Source.\r\n        // Consider the case Source and Target are the same node, but only child nodes are moved.\r\n        if (Source <> Target) and HasAsParent(Target, Source) then\r\n            ShowError(SWrongMoveError, hcTFWrongMoveError);\r\n\r\n        if not ChildrenOnly then\r\n        begin\r\n          // Disconnect from old location.\r\n          InternalDisconnectNode(Source, True);\r\n          // Connect to new location.\r\n          InternalConnectNode(Source, Target, Self, Mode);\r\n          DoNodeMoved(Source);\r\n        end\r\n        else\r\n        begin\r\n          // Only child nodes should be moved. Insertion order depends on move mode.\r\n          if Mode = amAddChildFirst then\r\n          begin\r\n            Source := Source.LastChild;\r\n            while Assigned(Source) do\r\n            begin\r\n              NewNode := Source.PrevSibling;\r\n              // Disconnect from old location.\r\n              InternalDisconnectNode(Source, True, False);\r\n              // Connect to new location.\r\n              InternalConnectNode(Source, Target, Self, Mode);\r\n              DoNodeMoved(Source);\r\n              Source := NewNode;\r\n            end;\r\n          end\r\n          else\r\n          begin\r\n            Source := Source.FirstChild;\r\n            while Assigned(Source) do\r\n            begin\r\n              NewNode := Source.NextSibling;\r\n              // Disconnect from old location.\r\n              InternalDisconnectNode(Source, True, False);\r\n              // Connect to new location.\r\n              InternalConnectNode(Source, Target, Self, Mode);\r\n              DoNodeMoved(Source);\r\n              Source := NewNode;\r\n            end;\r\n          end;\r\n        end;\r\n      end;\r\n    end\r\n    else\r\n    begin\r\n      // Difficult case: move node(s) to another tree.\r\n      // In opposition to node copying we ask only once if moving is allowed because\r\n      // we cannot take back a move once done.\r\n      if Target = TargetTree.FRoot then\r\n        Allowed := DoNodeMoving(Source, nil)\r\n      else\r\n        Allowed := DoNodeMoving(Source, Target);\r\n\r\n      if Allowed then\r\n      begin\r\n        Stream := TMemoryStream.Create;\r\n        try\r\n          // Write all nodes into a temporary stream depending on the ChildrenOnly flag.\r\n          if not ChildrenOnly then\r\n            WriteNode(Stream, Source)\r\n          else\r\n          begin\r\n            Source := Source.FirstChild;\r\n            while Assigned(Source) do\r\n            begin\r\n              WriteNode(Stream, Source);\r\n              Source := Source.NextSibling;\r\n            end;\r\n          end;\r\n          // Now load the serialized nodes into the target node (tree).\r\n          TargetTree.BeginUpdate;\r\n          try\r\n            Stream.Position := 0;\r\n            while Stream.Position < Stream.Size do\r\n            begin\r\n              NewNode := TargetTree.MakeNewNode;\r\n              InternalConnectNode(NewNode, Target, TargetTree, Mode);\r\n              TargetTree.InternalAddFromStream(Stream, VTTreeStreamVersion, NewNode);\r\n              DoNodeMoved(NewNode);\r\n            end;\r\n          finally\r\n            TargetTree.EndUpdate;\r\n          end;\r\n        finally\r\n          Stream.Free;\r\n        end;\r\n        // finally delete original nodes\r\n        BeginUpdate;\r\n        try\r\n          if ChildrenOnly then\r\n            DeleteChildren(Source)\r\n          else\r\n            DeleteNode(Source);\r\n        finally\r\n          EndUpdate;\r\n        end;\r\n      end;\r\n    end;\r\n\r\n    InvalidateCache;\r\n    if (FUpdateCount = 0) and Allowed then\r\n    begin\r\n      ValidateCache;\r\n      UpdateScrollBars(True);\r\n      Invalidate;\r\n      if TargetTree <> Self then\r\n        TargetTree.Invalidate;\r\n    end;\r\n    StructureChange(Source, crNodeMoved);\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.PaintTree(TargetCanvas: TCanvas; Window: TRect; Target: TPoint;\r\n  PaintOptions: TVTInternalPaintOptions; PixelFormat: TPixelFormat);\r\n\r\n// This is the core paint routine of the tree. It is responsible for maintaining the paint cycles per node as well\r\n// as coordinating drawing of the various parts of the tree image.\r\n// TargetCanvas is the canvas to which to draw the tree image. This is usually the tree window itself but could well\r\n// be a bitmap or printer canvas.\r\n// Window determines which part of the entire tree image to draw. The full size of the virtual image is determined\r\n// by GetTreeRect.\r\n// Target is the position in TargetCanvas where to draw the tree part specified by Window.\r\n// PaintOptions determines what of the tree to draw. For different tasks usually different parts need to be drawn, with\r\n// a full image in the window, selected only nodes for a drag image etc.\r\n\r\nconst\r\n  ImageKind: array[Boolean] of TVTImageKind = (ikNormal, ikSelected);\r\n\r\nvar\r\n  DrawSelectionRect,\r\n  UseBackground,\r\n  ShowImages,\r\n  ShowStateImages,\r\n  ShowCheckImages,\r\n  UseColumns,\r\n  IsMainColumn: Boolean;\r\n\r\n  VAlign,\r\n  IndentSize,\r\n  ButtonX,\r\n  ButtonY: Integer;\r\n  LineImage: TLineImage;\r\n  PaintInfo: TVTPaintInfo;     // all necessary information about a node to pass to the paint routines\r\n\r\n  R,                           // the area of an entire node in its local coordinate\r\n  TargetRect,                  // the area of a node (part) in the target canvas\r\n  SelectionRect,               // ordered rectangle used for drawing the selection focus rect\r\n  ClipRect: TRect;             // area to which the canvas will be clipped when painting a node's content\r\n  NextColumn: TColumnIndex;\r\n  BaseOffset: Integer;         // top position of the top node to draw given in absolute tree coordinates\r\n  NodeBitmap: TBitmap;         // small buffer to draw flicker free\r\n  MaximumRight,                // maximum horizontal target position\r\n  MaximumBottom: Integer;      // maximum vertical target position\r\n  SelectLevel: Integer;        // > 0 if current node is selected or child/grandchild etc. of a selected node\r\n  FirstColumn: TColumnIndex;   // index of first column which is at least partially visible in the given window\r\n\r\n  MaxRight,\r\n  ColLeft,\r\n  ColRight: Integer;\r\n\r\n  SavedTargetDC: Integer;\r\n  PaintWidth: Integer;\r\n  CurrentNodeHeight: Integer;\r\n  lUseSelectedBkColor: Boolean; // determines if the dotted grid lines need to be painted in selection color of background color\r\n\r\n  CellIsTouchingClientRight: Boolean;\r\n  CellIsInLastColumn: Boolean;\r\n  ColumnIsFixed: Boolean;\r\n\r\nbegin\r\n  if not (tsPainting in FStates) then\r\n  begin\r\n    DoStateChange([tsPainting]);\r\n    try\r\n      DoBeforePaint(TargetCanvas);\r\n\r\n      if poUnbuffered in PaintOptions then\r\n        SavedTargetDC := SaveDC(TargetCanvas.Handle)\r\n      else\r\n        SavedTargetDC := 0;\r\n\r\n      // Prepare paint info structure.\r\n      ZeroMemory(@PaintInfo, SizeOf(PaintInfo));\r\n\r\n      PaintWidth := Window.Right - Window.Left;\r\n\r\n      if not (poUnbuffered in PaintOptions) then\r\n      begin\r\n        // Create small bitmaps and initialize default values.\r\n        // The bitmaps are used to paint one node at a time and to draw the result to the target (e.g. screen) in one step,\r\n        // to prevent flickering.\r\n        NodeBitmap := TBitmap.Create;\r\n        // For alpha blending we need the 32 bit pixel format. For other targets there might be a need for a certain\r\n        // pixel format (e.g. printing).\r\n        if MMXAvailable and ((FDrawSelectionMode = smBlendedRectangle) or (tsUseThemes in FStates) or\r\n          (toUseBlendedSelection in FOptions.PaintOptions)) then\r\n          NodeBitmap.PixelFormat := pf32Bit\r\n        else\r\n          NodeBitmap.PixelFormat := PixelFormat;\r\n\r\n        NodeBitmap.Width := PaintWidth;\r\n\r\n        // Make sure the buffer bitmap and target bitmap use the same transformation mode.\r\n        SetMapMode(NodeBitmap.Canvas.Handle, GetMapMode(TargetCanvas.Handle));\r\n        PaintInfo.Canvas := NodeBitmap.Canvas;\r\n      end\r\n      else\r\n      begin\r\n        PaintInfo.Canvas := TargetCanvas;\r\n        NodeBitmap := nil;\r\n      end;\r\n\r\n      // Lock the canvas to avoid that it gets freed on the way.\r\n      PaintInfo.Canvas.Lock;\r\n      try\r\n        // Prepare the current selection rectangle once. The corner points are absolute tree coordinates.\r\n        SelectionRect := OrderRect(FNewSelRect);\r\n        DrawSelectionRect := IsMouseSelecting and not IsRectEmpty(SelectionRect) and (GetKeyState(VK_LBUTTON) < 0);\r\n\r\n        // R represents an entire node (all columns), but is a bit unprecise when it comes to\r\n        // trees without any column defined, because FRangeX only represents the maximum width of all\r\n        // nodes in the client area (not all defined nodes). There might be, however, wider nodes somewhere. Without full\r\n        // validation I cannot better determine the width, though. By using at least the control's width it is ensured\r\n        // that the tree is fully displayed on screen.\r\n        R := Rect(0, 0, Max(FRangeX, ClientWidth), 0);\r\n\r\n        // For quick checks some intermediate variables are used.\r\n        UseBackground := (toShowBackground in FOptions.FPaintOptions) and (FBackground.Graphic is TBitmap) and\r\n          (poBackground in PaintOptions);\r\n        ShowImages := Assigned(FImages);\r\n        ShowStateImages := Assigned(FStateImages);\r\n        ShowCheckImages := Assigned(FCheckImages) and (toCheckSupport in FOptions.FMiscOptions);\r\n        UseColumns := FHeader.UseColumns;\r\n\r\n        // Adjust paint options to tree settings. Hide selection if told so or the tree is unfocused.\r\n        if (toAlwaysHideSelection in FOptions.FPaintOptions) or\r\n          (not Focused and (toHideSelection in FOptions.FPaintOptions)) then\r\n          Exclude(PaintOptions, poDrawSelection);\r\n        if toHideFocusRect in FOptions.FPaintOptions then\r\n          Exclude(PaintOptions, poDrawFocusRect);\r\n\r\n        // Determine node to start drawing with.\r\n        BaseOffset := 0;\r\n        PaintInfo.Node := GetNodeAt(0, Window.Top, False, BaseOffset);\r\n        if PaintInfo.Node = nil then\r\n          BaseOffset := Window.Top;\r\n\r\n        // Transform selection rectangle into node bitmap coordinates.\r\n        if DrawSelectionRect then\r\n          OffsetRect(SelectionRect, 0, -BaseOffset);\r\n\r\n        // The target rectangle holds the coordinates of the exact area to blit in target canvas coordinates.\r\n        // It is usually smaller than an entire node and wanders while the paint loop advances.\r\n        MaximumRight := Target.X + (Window.Right - Window.Left);\r\n        MaximumBottom := Target.Y + (Window.Bottom - Window.Top);\r\n\r\n        TargetRect := Rect(Target.X, Target.Y - (Window.Top - BaseOffset), MaximumRight, 0);\r\n        TargetRect.Bottom := TargetRect.Top;\r\n        TargetCanvas.Font := Self.Font;\r\n\r\n        // This marker gets the index of the first column which is visible in the given window.\r\n        // This is needed for column based background colors.\r\n        FirstColumn := InvalidColumn;\r\n\r\n        if Assigned(PaintInfo.Node) then\r\n        begin\r\n          ButtonX := Round((Integer(FIndent) - FPlusBM.Width) / 2) + 1;\r\n\r\n          // ----- main node paint loop\r\n          while Assigned(PaintInfo.Node) do\r\n          begin\r\n            // Determine LineImage, SelectionLevel and IndentSize\r\n            SelectLevel := DetermineLineImageAndSelectLevel(PaintInfo.Node, LineImage);\r\n            IndentSize := Length(LineImage);\r\n            if not (toFixedIndent in FOptions.FPaintOptions) then\r\n              ButtonX := (IndentSize - 1) * Integer(FIndent) + Round((Integer(FIndent) - FPlusBM.Width) / 2) + 1;\r\n\r\n            // Initialize node if not already done.\r\n            if not (vsInitialized in PaintInfo.Node.States) then\r\n              InitNode(PaintInfo.Node);\r\n            if (vsSelected in PaintInfo.Node.States) and not (toChildrenAbove in FOptions.FPaintOptions) then\r\n              Inc(SelectLevel);\r\n\r\n            // Ensure the node's height is determined.\r\n            MeasureItemHeight(PaintInfo.Canvas, PaintInfo.Node);\r\n\r\n            // Adjust the brush origin for dotted lines depending on the current source position.\r\n            // It is applied some lines later, as the canvas might get reallocated, when changing the node bitmap.\r\n            PaintInfo.BrushOrigin := Point(Window.Left and 1, BaseOffset and 1);\r\n            Inc(BaseOffset, PaintInfo.Node.NodeHeight);\r\n\r\n            TargetRect.Bottom := TargetRect.Top + PaintInfo.Node.NodeHeight;\r\n\r\n            // If poSelectedOnly is active then do the following stuff only for selected nodes or nodes\r\n            // which are children of selected nodes.\r\n            if (SelectLevel > 0) or not (poSelectedOnly in PaintOptions) then\r\n            begin\r\n              if not (poUnbuffered in PaintOptions) then\r\n              begin\r\n                // Adjust height of temporary node bitmap.\r\n                with NodeBitmap do\r\n                begin\r\n                  if Height <> PaintInfo.Node.NodeHeight then\r\n                  begin\r\n                    // Avoid that the VCL copies the bitmap while changing its height.\r\n                    Height := 0;\r\n                    Height := PaintInfo.Node.NodeHeight;\r\n                    SetCanvasOrigin(Canvas, Window.Left, 0);\r\n                  end;\r\n                end;\r\n              end\r\n              else\r\n              begin\r\n                SetCanvasOrigin(PaintInfo.Canvas, -TargetRect.Left + Window.Left, -TargetRect.Top);\r\n                ClipCanvas(PaintInfo.Canvas, Rect(0, 0, TargetRect.Right - TargetRect.Left,\r\n                                                  Min(TargetRect.Bottom - TargetRect.Top, MaximumBottom - TargetRect.Top))); // See issue #579\r\n              end;\r\n\r\n              // Set the origin of the canvas' brush. This depends on the node heights.\r\n              with PaintInfo do\r\n                SetBrushOrigin(Canvas, BrushOrigin.X, BrushOrigin.Y);\r\n\r\n              CurrentNodeHeight := PaintInfo.Node.NodeHeight;\r\n              R.Bottom := CurrentNodeHeight;\r\n              \r\n              CalculateVerticalAlignments(ShowImages, ShowStateImages, PaintInfo.Node, VAlign, ButtonY);\r\n\r\n              // Let application decide whether the node should normally be drawn or by the application itself.\r\n              if not DoBeforeItemPaint(PaintInfo.Canvas, PaintInfo.Node, R) then\r\n              begin\r\n                // Init paint options for the background painting.\r\n                PaintInfo.PaintOptions := PaintOptions;\r\n\r\n                // The node background can contain a single color, a bitmap or can be drawn by the application.\r\n                ClearNodeBackground(PaintInfo, UseBackground, True, Rect(Window.Left, TargetRect.Top, Window.Right,\r\n                  TargetRect.Bottom));\r\n\r\n                // Prepare column, position and node clipping rectangle.\r\n                PaintInfo.CellRect := R;\r\n                if UseColumns then\r\n                  InitializeFirstColumnValues(PaintInfo);\r\n\r\n                // Now go through all visible columns (there's still one run if columns aren't used).\r\n                with FHeader.FColumns do\r\n                begin\r\n                  while ((PaintInfo.Column > InvalidColumn) or not UseColumns)\r\n                    and (PaintInfo.CellRect.Left < Window.Right) do\r\n                  begin\r\n                    if UseColumns then\r\n                    begin\r\n                      PaintInfo.Column := FPositionToIndex[PaintInfo.Position];\r\n                      if FirstColumn = InvalidColumn then\r\n                        FirstColumn := PaintInfo.Column;\r\n                      PaintInfo.BidiMode := Items[PaintInfo.Column].FBiDiMode;\r\n                      PaintInfo.Alignment := Items[PaintInfo.Column].FAlignment;\r\n                    end\r\n                    else\r\n                    begin\r\n                      PaintInfo.Column := NoColumn;\r\n                      PaintInfo.BidiMode := BidiMode;\r\n                      PaintInfo.Alignment := FAlignment;\r\n                    end;\r\n\r\n                    PaintInfo.PaintOptions := PaintOptions;\r\n                    with PaintInfo do\r\n                    begin\r\n                      if (tsEditing in FStates) and (Node = FFocusedNode) and\r\n                        ((Column = FEditColumn) or not UseColumns) then\r\n                        Exclude(PaintOptions, poDrawSelection);\r\n                      if not UseColumns or\r\n                        ((vsSelected in Node.States) and (toFullRowSelect in FOptions.FSelectionOptions) and\r\n                         (poDrawSelection in PaintOptions)) or\r\n                        (coParentColor in Items[PaintInfo.Column].Options) then\r\n                        Exclude(PaintOptions, poColumnColor);\r\n                    end;\r\n                    IsMainColumn := PaintInfo.Column = FHeader.MainColumn;\r\n\r\n                    // Consider bidi mode here. In RTL context means left alignment actually right alignment and vice versa.\r\n                    if PaintInfo.BidiMode <> bdLeftToRight then\r\n                      ChangeBiDiModeAlignment(PaintInfo.Alignment);\r\n\r\n                    // Paint the current cell if it is marked as being visible or columns aren't used and\r\n                    // if this cell belongs to the main column if only the main column should be drawn.\r\n                    if (not UseColumns or (coVisible in Items[PaintInfo.Column].FOptions)) and\r\n                      (not (poMainOnly in PaintOptions) or IsMainColumn) then\r\n                    begin\r\n                      AdjustPaintCellRect(PaintInfo, NextColumn);\r\n\r\n                      // Paint the cell only if it is in the current window.\r\n                      if PaintInfo.CellRect.Right > Window.Left then\r\n                      begin\r\n                        with PaintInfo do\r\n                        begin\r\n                          // Fill in remaining values in the paint info structure.\r\n                          NodeWidth := DoGetNodeWidth(Node, Column, Canvas);\r\n                          // Not the entire cell is covered by text. Hence we need a running rectangle to follow up.\r\n                          ContentRect := CellRect;\r\n                          // Set up the distance from column border (margin).\r\n                          if BidiMode <> bdLeftToRight then\r\n                            Dec(ContentRect.Right, FMargin)\r\n                          else\r\n                            Inc(ContentRect.Left, FMargin);\r\n\r\n                          if ShowCheckImages and IsMainColumn then\r\n                          begin\r\n                            ImageInfo[iiCheck].Index := GetCheckImage(Node);\r\n                            if ImageInfo[iiCheck].Index > -1 then\r\n                            begin\r\n                              AdjustImageBorder(FCheckImages, BidiMode, VAlign, ContentRect, ImageInfo[iiCheck]);\r\n                              ImageInfo[iiCheck].Ghosted := False;\r\n                            end;\r\n                          end\r\n                          else\r\n                            ImageInfo[iiCheck].Index := -1;\r\n                          if ShowStateImages then\r\n                          begin\r\n                            GetImageIndex(PaintInfo, ikState, iiState, FStateImages);\r\n                            if ImageInfo[iiState].Index > -1 then\r\n                              AdjustImageBorder(FStateImages, BidiMode, VAlign, ContentRect, ImageInfo[iiState]);\r\n                          end\r\n                          else\r\n                            ImageInfo[iiState].Index := -1;\r\n                          if ShowImages then\r\n                          begin\r\n                            GetImageIndex(PaintInfo, ImageKind[vsSelected in Node.States], iiNormal, FImages);\r\n                            if ImageInfo[iiNormal].Index > -1 then\r\n                              AdjustImageBorder(ImageInfo[iiNormal].Images, BidiMode, VAlign, ContentRect, ImageInfo[iiNormal]);\r\n                          end\r\n                          else\r\n                            ImageInfo[iiNormal].Index := -1;\r\n\r\n                          // Take the space for the tree lines into account.\r\n                          if IsMainColumn then\r\n                            AdjustCoordinatesByIndent(PaintInfo, IfThen(toFixedIndent in FOptions.FPaintOptions, 1, IndentSize));\r\n\r\n                          if UseColumns then\r\n                          begin\r\n                            ClipRect := CellRect;\r\n                            if poUnbuffered in PaintOptions then\r\n                            begin\r\n                              ClipRect.Left := Max(ClipRect.Left, Window.Left);\r\n                              ClipRect.Right := Min(ClipRect.Right, Window.Right);\r\n                              ClipRect.Top := Max(ClipRect.Top, Window.Top - (BaseOffset - CurrentNodeHeight));\r\n                              ClipRect.Bottom := ClipRect.Bottom - Max(TargetRect.Bottom - MaximumBottom, 0);\r\n                            end;\r\n                            ClipCanvas(Canvas, ClipRect);\r\n                          end;\r\n\r\n                          // Paint the horizontal grid line.\r\n                          if (poGridLines in PaintOptions) and (toShowHorzGridLines in FOptions.FPaintOptions) then\r\n                          begin\r\n                            Canvas.Font.Color := FColors.GridLineColor;\r\n                            if IsMainColumn and (FLineMode = lmBands) then\r\n                            begin\r\n                              if BidiMode = bdLeftToRight then\r\n                              begin\r\n                                DrawDottedHLine(PaintInfo, CellRect.Left + IfThen(toFixedIndent in FOptions.FPaintOptions, 1, IndentSize) * Integer(FIndent), CellRect.Right - 1,\r\n                                  CellRect.Bottom - 1);\r\n                              end\r\n                              else\r\n                              begin\r\n                                DrawDottedHLine(PaintInfo, CellRect.Left, CellRect.Right - IfThen(toFixedIndent in FOptions.FPaintOptions, 1, IndentSize) * Integer(FIndent) - 1,\r\n                                  CellRect.Bottom - 1);\r\n                              end;\r\n                            end\r\n                            else\r\n                              DrawDottedHLine(PaintInfo, CellRect.Left, CellRect.Right, CellRect.Bottom - 1);\r\n\r\n                            Dec(CellRect.Bottom);\r\n                            Dec(ContentRect.Bottom);\r\n                          end;\r\n\r\n                          if UseColumns then\r\n                          begin\r\n                            // Paint vertical grid line.\r\n                            if (poGridLines in PaintOptions) and (toShowVertGridLines in FOptions.FPaintOptions) then\r\n                            begin\r\n                              // These variables and the nested if conditions shall make the logic\r\n                              // easier to understand.\r\n                              CellIsTouchingClientRight := PaintInfo.CellRect.Right = ClientRect.Right;\r\n                              CellIsInLastColumn := Position = TColumnPosition(Count - 1);\r\n                              ColumnIsFixed := coFixed in FHeader.FColumns[Column].Options;\r\n\r\n                              // Don't draw if this is the last column and the header is in autosize mode.\r\n                              if not ((hoAutoResize in FHeader.FOptions) and CellIsInLastColumn) then\r\n                              begin\r\n                                // We have to take spanned cells into account which we determine\r\n                                // by checking if CellRect.Right equals the Window.Right.\r\n                                // But since the PaintTree procedure is called twice in\r\n                                // TBaseVirtualTree.Paint (i.e. for fixed columns and other columns.\r\n                                // CellIsTouchingClientRight does not work for fixed columns.)\r\n                                // we have to paint fixed column grid line anyway.\r\n                                if not CellIsTouchingClientRight or ColumnIsFixed then\r\n                                begin\r\n                                  if (BidiMode = bdLeftToRight) or not ColumnIsEmpty(Node, Column) then\r\n                                  begin\r\n                                    Canvas.Font.Color := FColors.GridLineColor;\r\n                                    lUseSelectedBkColor := (poDrawSelection in PaintOptions) and (toFullRowSelect in FOptions.FSelectionOptions) and\r\n                                                          (vsSelected in Node.States) and not (toUseBlendedSelection in FOptions.PaintOptions) and not\r\n                                                          (tsUseExplorerTheme in FStates);\r\n                                    DrawDottedVLine(PaintInfo, CellRect.Top, CellRect.Bottom, CellRect.Right - 1, lUseSelectedBkColor);\r\n                                  end;\r\n\r\n                                  Dec(CellRect.Right);\r\n                                  Dec(ContentRect.Right);\r\n                                end;\r\n                              end;\r\n                            end;\r\n                          end;\r\n\r\n                          // Prepare background and focus rect for the current cell.\r\n                          PrepareCell(PaintInfo, Window.Left, PaintWidth);\r\n\r\n                          // Some parts are only drawn for the main column.\r\n                          if IsMainColumn then\r\n                          begin\r\n                            if (toShowTreeLines in FOptions.FPaintOptions) and\r\n                               (not (toHideTreeLinesIfThemed in FOptions.FPaintOptions) or\r\n                                not (tsUseThemes in FStates)) then\r\n                              PaintTreeLines(PaintInfo, VAlign, IfThen(toFixedIndent in FOptions.FPaintOptions, 1,\r\n                                             IndentSize), LineImage);\r\n                            // Show node button if allowed, if there child nodes and at least one of the child\r\n                            // nodes is visible or auto button hiding is disabled.\r\n                            if (toShowButtons in FOptions.FPaintOptions) and (vsHasChildren in Node.States) and\r\n                              not ((vsAllChildrenHidden in Node.States) and\r\n                              (toAutoHideButtons in TreeOptions.FAutoOptions)) then\r\n                              PaintNodeButton(Canvas, Node, Column, CellRect, ButtonX, ButtonY, BidiMode);\r\n\r\n                            if ImageInfo[iiCheck].Index > -1 then\r\n                              PaintCheckImage(Canvas, PaintInfo.ImageInfo[iiCheck], vsSelected in PaintInfo.Node.States);\r\n                          end;\r\n\r\n                          if ImageInfo[iiState].Index > -1 then\r\n                            PaintImage(PaintInfo, iiState, False);\r\n                          if ImageInfo[iiNormal].Index > -1 then\r\n                            PaintImage(PaintInfo, iiNormal, True);\r\n\r\n                          // Now let descendants or applications draw whatever they want,\r\n                          // but don't draw the node if it is currently being edited.\r\n                          if not ((tsEditing in FStates) and (Node = FFocusedNode) and\r\n                            ((Column = FEditColumn) or not UseColumns)) then\r\n                            DoPaintNode(PaintInfo);\r\n\r\n                          DoAfterCellPaint(Canvas, Node, Column, CellRect);\r\n                        end;\r\n                      end;\r\n\r\n                      // leave after first run if columns aren't used\r\n                      if not UseColumns then\r\n                        Break;\r\n                    end\r\n                    else\r\n                      NextColumn := GetNextVisibleColumn(PaintInfo.Column);\r\n\r\n                    SelectClipRgn(PaintInfo.Canvas.Handle, 0);\r\n                    // Stop column loop if there are no further columns in the given window.\r\n                    if (PaintInfo.CellRect.Left >= Window.Right) or (NextColumn = InvalidColumn) then\r\n                      Break;\r\n\r\n                    // Move on to next column which might not be the one immediately following the current one\r\n                    // because of auto span feature.\r\n                    PaintInfo.Position := Items[NextColumn].Position;\r\n\r\n                    // Move clip rectangle and continue.\r\n                    if coVisible in Items[NextColumn].FOptions then\r\n                      with PaintInfo do\r\n                      begin\r\n                        Items[NextColumn].GetAbsoluteBounds(CellRect.Left, CellRect.Right);\r\n                        CellRect.Bottom := Node.NodeHeight;\r\n                        ContentRect.Bottom := Node.NodeHeight;\r\n                      end;\r\n                  end;\r\n                end;\r\n\r\n                // This node is finished, notify descendants/application.\r\n                with PaintInfo do\r\n                begin\r\n                  DoAfterItemPaint(Canvas, Node, R);\r\n\r\n                  // Final touch for this node: mark it if it is the current drop target node.\r\n                  if (Node = FDropTargetNode) and (toShowDropmark in FOptions.FPaintOptions) and\r\n                    (poDrawDropMark in PaintOptions) then\r\n                    DoPaintDropMark(Canvas, Node, R);\r\n                end;\r\n              end;\r\n\r\n              with PaintInfo.Canvas do\r\n              begin\r\n                if DrawSelectionRect then\r\n                begin\r\n                  PaintSelectionRectangle(PaintInfo.Canvas, Window.Left, SelectionRect, Rect(0, 0, PaintWidth,\r\n                    CurrentNodeHeight));\r\n                end;\r\n\r\n                // Put the constructed node image onto the target canvas.\r\n                if not (poUnbuffered in PaintOptions) then\r\n                  with TWithSafeRect(TargetRect), NodeBitmap do\r\n                    BitBlt(TargetCanvas.Handle, Left, Top, Width, Height, Canvas.Handle, Window.Left, 0, SRCCOPY);\r\n              end;\r\n            end;\r\n\r\n            Inc(TargetRect.Top, PaintInfo.Node.NodeHeight);\r\n            if TargetRect.Top >= MaximumBottom then\r\n              Break;\r\n\r\n            // Keep selection rectangle coordinates in sync.\r\n            if DrawSelectionRect then\r\n              OffsetRect(SelectionRect, 0, -PaintInfo.Node.NodeHeight);\r\n\r\n            // Advance to next visible node.\r\n            PaintInfo.Node := GetNextVisible(PaintInfo.Node, True);\r\n          end;\r\n        end;\r\n\r\n        // Erase rest of window not covered by a node.\r\n        if TargetRect.Top < MaximumBottom then\r\n        begin\r\n          // Keep the horizontal target position to determine the selection rectangle offset later (if necessary).\r\n          BaseOffset := Target.X;\r\n          Target := TargetRect.TopLeft;\r\n          R := Rect(TargetRect.Left, 0, TargetRect.Left, MaximumBottom - Target.Y);\r\n          TargetRect := Rect(0, 0, MaximumRight - Target.X, MaximumBottom - Target.Y);\r\n\r\n          if not (poUnbuffered in PaintOptions) then\r\n          begin\r\n            // Avoid unnecessary copying of bitmap content. This will destroy the DC handle too.\r\n            NodeBitmap.Height := 0;\r\n            NodeBitmap.PixelFormat := pf32Bit;\r\n            NodeBitmap.Width := TargetRect.Right - TargetRect.Left;\r\n            NodeBitmap.Height := TargetRect.Bottom - TargetRect.Top;\r\n          end;\r\n\r\n          // Call back application/descendants whether they want to erase this area.\r\n          if not DoPaintBackground(PaintInfo.Canvas, TargetRect) then\r\n          begin\r\n            if UseBackground then\r\n            begin\r\n              SetCanvasOrigin(PaintInfo.Canvas, 0, 0);\r\n              if toStaticBackground in TreeOptions.PaintOptions then\r\n                StaticBackground(FBackground.Bitmap, PaintInfo.Canvas, Target, TargetRect)\r\n              else\r\n                TileBackground(FBackground.Bitmap, PaintInfo.Canvas, Target, TargetRect);\r\n            end\r\n            else\r\n            begin\r\n              // Consider here also colors of the columns.\r\n              SetCanvasOrigin(PaintInfo.Canvas, Target.X, 0); // This line caused issue #313 when it was placed above the if-statement\r\n              if UseColumns then\r\n              begin\r\n                with FHeader.FColumns do\r\n                begin\r\n                  // If there is no content in the tree then the first column has not yet been determined.\r\n                  if FirstColumn = InvalidColumn then\r\n                  begin\r\n                    FirstColumn := GetFirstVisibleColumn;\r\n                    repeat\r\n                      if FirstColumn <> InvalidColumn then\r\n                      begin\r\n                        R.Left := Items[FirstColumn].Left;\r\n                        R.Right := R.Left +  Items[FirstColumn].FWidth;\r\n                        if R.Right > TargetRect.Left then\r\n                          Break;\r\n                        FirstColumn := GetNextVisibleColumn(FirstColumn);\r\n                      end;\r\n                    until FirstColumn = InvalidColumn;\r\n                  end\r\n                  else\r\n                  begin\r\n                    R.Left := Items[FirstColumn].Left;\r\n                    R.Right := R.Left +  Items[FirstColumn].FWidth;\r\n                  end;\r\n\r\n                  // Initialize MaxRight.\r\n                  MaxRight := Target.X - 1;\r\n\r\n                  PaintInfo.Canvas.Font.Color := FColors.GridLineColor;\r\n                  while (FirstColumn <> InvalidColumn) and (MaxRight < TargetRect.Right + Target.X) do\r\n                  begin\r\n                    // Determine left and right coordinate of the current column\r\n                    ColLeft := Items[FirstColumn].Left;\r\n                    ColRight := (ColLeft + Items[FirstColumn].FWidth);\r\n\r\n                    // Check wether this column needs to be painted at all.\r\n                    if (ColRight >= MaxRight) then\r\n                    begin\r\n                      R.Left := MaxRight;     // Continue where we left off\r\n                      R.Right := ColRight;    // Paint to the right of the column\r\n                      MaxRight := ColRight;   // And record were to start the next column.\r\n\r\n                      if (poGridLines in PaintOptions) and\r\n                         (toFullVertGridLines in FOptions.FPaintOptions) and\r\n                         (toShowVertGridLines in FOptions.FPaintOptions) and\r\n                         (not (hoAutoResize in FHeader.FOptions) or (Cardinal(FirstColumn) < TColumnPosition(Count - 1))) then\r\n                      begin\r\n                        DrawDottedVLine(PaintInfo, R.Top, R.Bottom, R.Right - 1);\r\n                        Dec(R.Right);\r\n                      end;\r\n\r\n                      if not (coParentColor in Items[FirstColumn].FOptions) then\r\n                        PaintInfo.Canvas.Brush.Color := Items[FirstColumn].FColor\r\n                      else\r\n                        PaintInfo.Canvas.Brush.Color := FColors.BackGroundColor;\r\n                      PaintInfo.Canvas.FillRect(R);\r\n                    end;\r\n                    FirstColumn := GetNextVisibleColumn(FirstColumn);\r\n                  end;\r\n\r\n                  // Erase also the part of the tree not covert by a column.\r\n                  if R.Right < TargetRect.Right + Target.X then\r\n                  begin\r\n                    R.Left := R.Right;\r\n                    R.Right := TargetRect.Right + Target.X;\r\n                    // Prevent erasing the last vertical grid line.\r\n                    if (poGridLines in PaintOptions) and\r\n                       (toFullVertGridLines in FOptions.FPaintOptions) and (toShowVertGridLines in FOptions.FPaintOptions) and\r\n                       (not (hoAutoResize in FHeader.FOptions)) then\r\n                      Inc(R.Left);\r\n                    PaintInfo.Canvas.Brush.Color := FColors.BackGroundColor;\r\n                    PaintInfo.Canvas.FillRect(R);\r\n                  end;\r\n                end;\r\n                SetCanvasOrigin(PaintInfo.Canvas, 0, 0);\r\n              end\r\n              else\r\n              begin\r\n                // No columns nor bitmap background. Simply erase it with the tree color.\r\n                SetCanvasOrigin(PaintInfo.Canvas, 0, 0);\r\n                PaintInfo.Canvas.Brush.Color := FColors.BackGroundColor;\r\n                PaintInfo.Canvas.FillRect(TargetRect);\r\n              end;\r\n            end;\r\n          end;\r\n          SetCanvasOrigin(PaintInfo.Canvas, 0, 0);\r\n\r\n          if DrawSelectionRect then\r\n          begin\r\n            R := OrderRect(FNewSelRect);\r\n            // Remap the selection rectangle to the current window of the tree.\r\n            // Since Target has been used for other tasks BaseOffset got the left extent of the target position here.\r\n            OffsetRect(R, -Target.X + BaseOffset - Window.Left, -Target.Y + FOffsetY);\r\n            SetBrushOrigin(PaintInfo.Canvas, 0, Target.X and 1);\r\n            PaintSelectionRectangle(PaintInfo.Canvas, 0, R, TargetRect);\r\n          end;\r\n\r\n          if not (poUnBuffered in PaintOptions) then\r\n            with Target, NodeBitmap do\r\n              BitBlt(TargetCanvas.Handle, X, Y, Width, Height, Canvas.Handle, 0, 0, SRCCOPY);\r\n        end;\r\n      finally\r\n        PaintInfo.Canvas.Unlock;\r\n        if poUnbuffered in PaintOptions then\r\n          RestoreDC(TargetCanvas.Handle, SavedTargetDC)\r\n        else\r\n          NodeBitmap.Free;\r\n      end;\r\n      \r\n      if (ChildCount[nil] = 0) and (FEmptyListMessage <> '') then\r\n      begin\r\n        // output a message if no items are to display\r\n        Canvas.Font := Self.Font;\r\n        SetBkMode(TargetCanvas.Handle, TRANSPARENT);\r\n        R.Left := OffSetX + 2;\r\n        R.Top := 2;\r\n        R.Right := R.Left + Width - 2;\r\n        R.Bottom := Height -2;\r\n        TargetCanvas.Font.Color := clGrayText;\r\n        TargetCanvas.TextRect(R, FEmptyListMessage, [tfNoClip, tfLeft, tfWordBreak]);\r\n      end;\r\n\r\n      DoAfterPaint(TargetCanvas);\r\n    finally\r\n      DoStateChange([], [tsPainting]);\r\n    end;\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TBaseVirtualTree.PasteFromClipboard: Boolean;\r\n\r\n// Reads what is currently on the clipboard into the tree (if the format is supported).\r\n// Note: If the application wants to have text or special formats to be inserted then it must implement\r\n//       its own code (OLE). Here only the native tree format is accepted.\r\n\r\nvar\r\n  Data: IDataObject;\r\n  Source: TBaseVirtualTree;\r\n\r\nbegin\r\n  Result := False;\r\n  if not (toReadOnly in FOptions.FMiscOptions) then\r\n  begin\r\n    if OleGetClipboard(Data) <> S_OK then\r\n      ShowError(SClipboardFailed, hcTFClipboardFailed)\r\n    else\r\n    begin\r\n      // Try to get the source tree of the operation to optimize the operation.\r\n      Source := GetTreeFromDataObject(Data);\r\n      Result := ProcessOLEData(Source, Data, FFocusedNode, FDefaultPasteMode, Assigned(Source) and\r\n        (tsCutPending in Source.FStates));\r\n      if Assigned(Source) then\r\n      begin\r\n        if Source <> Self then\r\n          Source.FinishCutOrCopy\r\n        else\r\n          DoStateChange([], [tsCutPending]);\r\n      end;    \r\n    end;\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.PrepareDragImage(HotSpot: TPoint; const DataObject: IDataObject);\r\n\r\n// Initiates an image drag operation. HotSpot is the position of the mouse in client coordinates.\r\n\r\nvar\r\n  PaintOptions: TVTInternalPaintOptions;\r\n  TreeRect,\r\n  PaintRect: TRect;\r\n  LocalSpot,\r\n  ImagePos,\r\n  PaintTarget: TPoint;\r\n  Image: TBitmap;\r\n\r\nbegin\r\n  if CanShowDragImage then\r\n  begin\r\n    // Determine the drag rectangle which is a square around the hot spot. Operate in virtual tree space.\r\n    LocalSpot := HotSpot;\r\n    Dec(LocalSpot.X, -FEffectiveOffsetX);\r\n    Dec(LocalSpot.Y, FOffsetY);\r\n    TreeRect := Rect(LocalSpot.X - FDragWidth div 2, LocalSpot.Y - FDragHeight div 2, LocalSpot.X + FDragWidth div 2,\r\n      LocalSpot.Y + FDragHeight div 2);\r\n\r\n    // Check that we have a valid rectangle.\r\n    PaintRect := TreeRect;\r\n    with TWithSafeRect(TreeRect) do\r\n    begin\r\n      if Left < 0 then\r\n      begin\r\n        PaintTarget.X := -Left;\r\n        PaintRect.Left := 0;\r\n      end\r\n      else\r\n        PaintTarget.X := 0;\r\n      if Top < 0 then\r\n      begin\r\n        PaintTarget.Y := -Top;\r\n        PaintRect.Top := 0;\r\n      end\r\n      else\r\n        PaintTarget.Y := 0;\r\n    end;\r\n\r\n    Image := TBitmap.Create;\r\n    with Image do\r\n    try\r\n      PixelFormat := pf32Bit;\r\n      Width := TreeRect.Right - TreeRect.Left;\r\n      Height := TreeRect.Bottom - TreeRect.Top;\r\n      // Erase the entire image with the color key value, for the case not everything\r\n      // in the image is covered by the tree image.\r\n      Canvas.Brush.Color := FColors.BackGroundColor;\r\n      Canvas.FillRect(Rect(0, 0, Width, Height));\r\n\r\n      PaintOptions := [poDrawSelection, poSelectedOnly];\r\n      if FDragImageKind = diMainColumnOnly then\r\n        Include(PaintOptions, poMainOnly);\r\n      PaintTree(Image.Canvas, PaintRect, PaintTarget, PaintOptions);\r\n\r\n      // Once we have got the drag image we can convert all necessary coordinates into screen space.\r\n      OffsetRect(TreeRect, -FEffectiveOffsetX, FOffsetY);\r\n      ImagePos := ClientToScreen(TreeRect.TopLeft);\r\n      HotSpot := ClientToScreen(HotSpot);\r\n\r\n      FDragImage.ColorKey := FColors.BackGroundColor;\r\n      FDragImage.PrepareDrag(Image, ImagePos, HotSpot, DataObject);\r\n    finally\r\n      Image.Free;\r\n    end;\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.Print(Printer: TPrinter; PrintHeader: Boolean);\r\n\r\nvar\r\n  SaveTreeFont: TFont;                 // Remembers the tree's current font.\r\n  SaveHeaderFont: TFont;               // Remembers the header's current font.\r\n  ImgRect,                             // Describes the dimensions of Image.\r\n  TreeRect,                            // The total VTree dimensions.\r\n  DestRect,                            // Dimensions of PrinterImage.\r\n  SrcRect: TRect;                      // Clip dimensions from Image -> PrinterImage\r\n  P: TPoint;                           // Used by PaintTree.\r\n  Options: TVTInternalPaintOptions;    // Used by PaintTree.\r\n  Image,                               // Complete Tree is drawn to this image.\r\n  PrinterImage: TBitmap;               // This is the image that gets printed.\r\n  SaveColor: TColor;                   // Remembers the VTree Color.\r\n  pTxtHeight,                          // Height of font in the TPrinter.Canvas\r\n  vTxtHeight,                          // Height of font in the VTree Canvas\r\n  vPageWidth,\r\n  vPageHeight,                         // Printer height in VTree resolution\r\n  xPageNum, yPageNum,                  // # of pages (except the occasional last one)\r\n  xPage, yPage: Integer;               // Loop counter\r\n  Scale: Extended;                     // Scale factor between Printer Canvas and VTree Canvas\r\n  LogFont: TLogFont;\r\n\r\nbegin\r\n  if Assigned(Printer) then\r\n  begin\r\n    BeginUpdate;\r\n\r\n    // Grid lines are the only parts which are desirable when printing.\r\n    Options := [poGridLines];\r\n\r\n    // Remember the tree font.\r\n    SaveTreeFont := TFont.Create;\r\n    SaveTreeFont.Assign(Font);\r\n    // Create a new font for printing which does not use clear type output (but is antialiased, if possible)\r\n    // and which has the highest possible quality.\r\n    GetObject(Font.Handle, SizeOf(TLogFont), @LogFont);\r\n    LogFont.lfQuality := ANTIALIASED_QUALITY;\r\n    Font.Handle := CreateFontIndirect(LogFont);\r\n\r\n    // Create an image that will hold the complete VTree\r\n    Image := TBitmap.Create;\r\n    Image.PixelFormat := pf32Bit;\r\n    PrinterImage := nil;\r\n    try\r\n      TreeRect := GetTreeRect;\r\n\r\n      Image.Width := TreeRect.Right - TreeRect.Left;\r\n      P := Point(0, 0);\r\n      if (hoVisible in FHeader.Options) and PrintHeader then\r\n      begin\r\n        Inc(TreeRect.Bottom, FHeader.Height);\r\n        Inc(P.Y, FHeader.Height);\r\n      end;\r\n      Image.Height := TreeRect.Bottom - TreeRect.Top;\r\n\r\n      ImgRect.Left := 0;\r\n      ImgRect.Top := 0;\r\n      ImgRect.Right := Image.Width;\r\n\r\n      // Force the background to white color during the rendering.\r\n      SaveColor := FColors.BackGroundColor;\r\n      Color := clWhite;\r\n      // Print header if it is visible.\r\n      if (hoVisible in FHeader.Options) and PrintHeader then\r\n      begin\r\n        SaveHeaderFont := TFont.Create;\r\n        try\r\n          SaveHeaderFont.Assign(FHeader.Font);\r\n          // Create a new font for printing which does not use clear type output (but is antialiased, if possible)\r\n          // and which has the highest possible quality.\r\n          GetObject(FHeader.Font.Handle, SizeOf(TLogFont), @LogFont);\r\n          LogFont.lfQuality := ANTIALIASED_QUALITY;\r\n          FHeader.Font.Handle := CreateFontIndirect(LogFont);\r\n          ImgRect.Bottom := FHeader.Height;\r\n          FHeader.FColumns.PaintHeader(Image.Canvas.Handle, ImgRect, 0);\r\n          FHeader.Font := SaveHeaderFont;\r\n        finally\r\n          SaveHeaderFont.Free;\r\n        end;\r\n      end;\r\n      // The image's height is already adjusted for the header if it is visible.\r\n      ImgRect.Bottom := Image.Height;\r\n\r\n      PaintTree(Image.Canvas, ImgRect, P, Options, pf32Bit);\r\n      Color := SaveColor;\r\n\r\n      // Activate the printer\r\n      Printer.BeginDoc;\r\n      Printer.Canvas.Font := Font;\r\n\r\n      // Now we can calculate the scaling :\r\n      pTxtHeight := Printer.Canvas.TextHeight('Tj');\r\n      vTxtHeight := Canvas.TextHeight('Tj');\r\n\r\n      Scale := pTxtHeight / vTxtHeight;\r\n\r\n      // Create an Image that has the same dimensions as the printer canvas but\r\n      // scaled to the VTree resolution:\r\n      PrinterImage := TBitmap.Create;\r\n\r\n      vPageHeight := Round(Printer.PageHeight / Scale);\r\n      vPageWidth := Round(Printer.PageWidth / Scale);\r\n\r\n      // We do a minumum of one page.\r\n      xPageNum := Trunc(Image.Width / vPageWidth);\r\n      yPageNum := Trunc(Image.Height / vPageHeight);\r\n\r\n      PrinterImage.Width := vPageWidth;\r\n      PrinterImage.Height := vPageHeight;\r\n\r\n      // Split vertically:\r\n      for yPage := 0 to yPageNum do\r\n      begin\r\n        DestRect.Left := 0;\r\n        DestRect.Top := 0;\r\n        DestRect.Right := PrinterImage.Width;\r\n        DestRect.Bottom := PrinterImage.Height;\r\n\r\n        // Split horizontally:\r\n        for xPage := 0 to xPageNum do\r\n          begin\r\n            SrcRect.Left := vPageWidth * xPage;\r\n            SrcRect.Top := vPageHeight * yPage;\r\n            SrcRect.Right := vPageWidth * xPage + PrinterImage.Width;\r\n            SrcRect.Bottom := SrcRect.Top + vPageHeight;\r\n\r\n            // Clear the image\r\n            PrinterImage.Canvas.Brush.Color := clWhite;\r\n            PrinterImage.Canvas.FillRect(Rect(0, 0, PrinterImage.Width, PrinterImage.Height));\r\n            PrinterImage.Canvas.CopyRect(DestRect, Image.Canvas, SrcRect);\r\n            PrtStretchDrawDIB(Printer.Canvas, Rect(0, 0, Printer.PageWidth, Printer.PageHeight - 1), PrinterImage);\r\n            if xPage <> xPageNum then\r\n              Printer.NewPage;\r\n          end;\r\n        if yPage <> yPageNum then\r\n          Printer.NewPage;\r\n      end;\r\n\r\n      // Restore tree font.\r\n      Font := SaveTreeFont;\r\n      SaveTreeFont.Free;\r\n      Printer.EndDoc;\r\n    finally\r\n      PrinterImage.Free;\r\n      Image.Free;\r\n      EndUpdate;\r\n    end;\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TBaseVirtualTree.ProcessDrop(const DataObject: IDataObject; TargetNode: PVirtualNode; var Effect: Integer;\r\n  Mode: TVTNodeAttachMode): Boolean;\r\n\r\n// Recreates the (sub) tree structure serialized into memory and provided by DataObject. The new nodes are attached to\r\n// the passed node or FRoot if TargetNode is nil.\r\n// Returns True on success, i.e. the CF_VIRTUALTREE format is supported by the data object and the structure could be\r\n// recreated, otherwise False.\r\n\r\nvar\r\n  Source: TBaseVirtualTree;\r\n\r\nbegin\r\n  Result := False;\r\n  if Mode = amNoWhere then\r\n    Effect := DROPEFFECT_NONE\r\n  else\r\n  begin\r\n    BeginUpdate;\r\n    // try to get the source tree of the operation\r\n    Source := GetTreeFromDataObject(DataObject);\r\n    if Assigned(Source) then\r\n      Source.BeginUpdate;\r\n    try\r\n      try\r\n        // Before adding the new nodes try to optimize the operation if source and target tree reside in\r\n        // the same application and operation is a move.\r\n        if ((Effect and DROPEFFECT_MOVE) <> 0) and Assigned(Source) then\r\n        begin\r\n          // If both copy and move are specified then prefer a copy because this is not destructing.\r\n          Result := ProcessOLEData(Source, DataObject, TargetNode, Mode, (Effect and DROPEFFECT_COPY) = 0);\r\n          // Since we made an optimized move or a copy there's no reason to act further after DoDragging returns.\r\n          Effect := DROPEFFECT_NONE;\r\n        end\r\n        else\r\n          // Act only if move or copy operation is requested.\r\n          if (Effect and (DROPEFFECT_MOVE or DROPEFFECT_COPY)) <> 0 then\r\n            Result := ProcessOLEData(Source, DataObject, TargetNode, Mode, False)\r\n          else\r\n            Result := False;\r\n      except\r\n        Effect := DROPEFFECT_NONE;\r\n      end;\r\n    finally\r\n      if Assigned(Source) then\r\n        Source.EndUpdate;\r\n      EndUpdate;\r\n    end;\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\ntype\r\n  // needed to handle OLE global memory objects\r\n  TOLEMemoryStream = class(TCustomMemoryStream)\r\n  public\r\n    function Write(const Buffer; Count: Integer): Integer; override;\r\n  end;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TOLEMemoryStream.Write(const Buffer; Count: Integer): Integer;\r\n\r\nbegin\r\n  raise EStreamError.CreateRes(PResStringRec(@SCantWriteResourceStreamError));\r\nend;\r\n\r\n//----------------- TBaseVirtualTree -----------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.DoDrawHint(Canvas: TCanvas; Node: PVirtualNode; R:\r\n    TRect; Column: TColumnIndex);\r\n\r\nbegin\r\n  if Assigned(FOnDrawHint) then\r\n    FOnDrawHint(Self, Canvas, Node, R, Column);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.DoGetHintSize(Node: PVirtualNode; Column:\r\n    TColumnIndex; var R: TRect);\r\n\r\nbegin\r\n  if Assigned(FOnGetHintSize) then\r\n    FOnGetHintSize(Self, Node, Column, R);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.DoGetHintKind(Node: PVirtualNode; Column:\r\n    TColumnIndex; var Kind: TVTHintKind);\r\n\r\nbegin\r\n  if Assigned(FOnGetHintKind) then\r\n    FOnGetHintKind(Self, Node, Column, Kind)\r\n  else\r\n    Kind := DefaultHintKind;\r\nend;\r\n\r\nfunction TBaseVirtualTree.GetDefaultHintKind: TVTHintKind;\r\n\r\nbegin\r\n  Result := vhkText;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TBaseVirtualTree.ProcessOLEData(Source: TBaseVirtualTree; const DataObject: IDataObject; TargetNode: PVirtualNode;\r\n  Mode: TVTNodeAttachMode; Optimized: Boolean): Boolean;\r\n\r\n// Recreates the (sub) tree structure serialized into memory and provided by DataObject. The new nodes are attached to\r\n// the passed node or FRoot if TargetNode is nil according to Mode. Optimized can be set to True if the entire operation\r\n// happens within the same process (i.e. sender and receiver of the OLE operation are located in the same process).\r\n// Optimize = True makes only sense if the operation to carry out is a move hence it is also the indication of the\r\n// operation to be done here. Source is the source of the OLE data and only of use (and usually assigned) when\r\n// an OLE operation takes place in the same application.\r\n// Returns True on success, i.e. the CF_VIRTUALTREE format is supported by the data object and the structure could be\r\n// recreated, otherwise False.\r\n\r\nvar\r\n  Medium: TStgMedium;\r\n  Stream: TStream;\r\n  Data: Pointer;\r\n  Node: PVirtualNode;\r\n  Nodes: TNodeArray;\r\n  I: Integer;\r\n  Res: HRESULT;\r\n  ChangeReason: TChangeReason;\r\n\r\nbegin\r\n  Nodes := nil;\r\n  // Check the data format available by the data object.\r\n  with StandardOLEFormat do\r\n  begin\r\n    // Read best format.\r\n    cfFormat := CF_VIRTUALTREE;\r\n  end;\r\n  Result := DataObject.QueryGetData(StandardOLEFormat) = S_OK;\r\n  if Result and not (toReadOnly in FOptions.FMiscOptions) then\r\n  begin\r\n    BeginUpdate;\r\n    Result := False;\r\n    try\r\n      if TargetNode = nil then\r\n        TargetNode := FRoot;\r\n      if TargetNode = FRoot then\r\n      begin\r\n        case Mode of\r\n          amInsertBefore:\r\n            Mode := amAddChildFirst;\r\n          amInsertAfter:\r\n            Mode := amAddChildLast;\r\n        end;\r\n      end;\r\n\r\n      // Optimized means source is known and in the same process so we can access its pointers, which avoids duplicating\r\n      // the data while doing a serialization. Can only be used with cut'n paste and drag'n drop with move effect.\r\n      if Optimized then\r\n      begin\r\n        if tsOLEDragging in Source.FStates then\r\n          Nodes := Source.FDragSelection\r\n        else\r\n          Nodes := Source.GetSortedCutCopySet(True);\r\n\r\n        if Mode in [amInsertBefore,amAddChildLast] then\r\n        begin\r\n          for I := 0 to High(Nodes) do\r\n            if not HasAsParent(TargetNode, Nodes[I]) then\r\n              Source.MoveTo(Nodes[I], TargetNode, Mode, False);\r\n        end\r\n        else\r\n        begin\r\n          for I := High(Nodes) downto 0 do\r\n            if not HasAsParent(TargetNode, Nodes[I]) then\r\n              Source.MoveTo(Nodes[I], TargetNode, Mode, False);\r\n        end;\r\n        Result := True;\r\n      end\r\n      else\r\n      begin\r\n        if Source = Self then\r\n          ChangeReason := crNodeCopied\r\n        else\r\n          ChangeReason := crNodeAdded;\r\n        Res := DataObject.GetData(StandardOLEFormat, Medium);\r\n        if Res = S_OK then\r\n        begin\r\n          case Medium.tymed of\r\n            TYMED_ISTREAM, // IStream interface\r\n            TYMED_HGLOBAL: // global memory block\r\n              begin\r\n                Stream := nil;\r\n                if Medium.tymed = TYMED_ISTREAM then\r\n                  Stream := TOLEStream.Create(IUnknown(Medium.stm) as IStream)\r\n                else\r\n                begin\r\n                  Data := GlobalLock(Medium.hGlobal);\r\n                  if Assigned(Data) then\r\n                  begin\r\n                    // Get the total size of data to retrieve.\r\n                    I := PCardinal(Data)^;\r\n                    Inc(PCardinal(Data));\r\n                    Stream := TOLEMemoryStream.Create;\r\n                    TOLEMemoryStream(Stream).SetPointer(Data, I);\r\n                  end;\r\n                end;\r\n\r\n                if Assigned(Stream) then\r\n                try\r\n                  while Stream.Position < Stream.Size do\r\n                  begin\r\n                    Node := MakeNewNode;\r\n                    InternalConnectNode(Node, TargetNode, Self, Mode);\r\n                    InternalAddFromStream(Stream, VTTreeStreamVersion, Node);\r\n                    // This seems a bit strange because of the callback for granting to add the node\r\n                    // which actually comes after the node has been added. The reason is that the node must\r\n                    // contain valid data otherwise I don't see how the application can make a funded decision.\r\n                    if not DoNodeCopying(Node, TargetNode) then\r\n                    begin\r\n                      DeleteNode(Node);\r\n                    end\r\n                    else\r\n                    begin\r\n                      DoNodeCopied(Node);\r\n                      StructureChange(Node, ChangeReason);\r\n                      // In order to maintain the same node order when restoring nodes in the case of amInsertAfter\r\n                      // we have to move the reference node continously. Othwise we would end up with reversed node order.\r\n                      if Mode = amInsertAfter then\r\n                        TargetNode := Node;\r\n                    end;\r\n                  end;\r\n                  Result := True;\r\n                finally\r\n                  Stream.Free;\r\n                  if Medium.tymed = TYMED_HGLOBAL then\r\n                    GlobalUnlock(Medium.hGlobal);\r\n                end;\r\n              end;\r\n          end;\r\n          ReleaseStgMedium(Medium);\r\n        end;\r\n      end;\r\n    finally\r\n      EndUpdate;\r\n    end;\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.ReinitChildren(Node: PVirtualNode; Recursive: Boolean);\r\n\r\n// Forces all child nodes of Node to be reinitialized.\r\n// If Recursive is True then also the grandchildren are reinitialized.\r\n\r\nvar\r\n  Run: PVirtualNode;\r\n\r\nbegin\r\n  if Assigned(Node) then\r\n  begin\r\n    InitChildren(Node);\r\n    Run := Node.FirstChild;\r\n  end\r\n  else\r\n  begin\r\n    InitChildren(FRoot);\r\n    Run := FRoot.FirstChild;\r\n  end;\r\n\r\n  while Assigned(Run) do\r\n  begin\r\n    ReinitNode(Run, Recursive);\r\n    Run := Run.NextSibling;\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.ReinitNode(Node: PVirtualNode; Recursive: Boolean);\r\n\r\n// Forces the given node and all its children (if recursive is True) to be initialized again without\r\n// modifying any data in the nodes nor deleting children (unless the application requests a different amount).\r\n\r\nbegin\r\n  if Assigned(Node) and (Node <> FRoot) then\r\n  begin\r\n    // Remove dynamic styles.\r\n    Node.States := Node.States - [vsChecking, vsCutOrCopy, vsDeleting, vsHeightMeasured];\r\n    if vsInitialized in Node.States then\r\n      InitNode(Node);\r\n  end;\r\n\r\n  if Recursive then\r\n    ReinitChildren(Node, True);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.RepaintNode(Node: PVirtualNode);\r\n\r\n// Causes an immediate repaint of the given node.\r\n\r\nvar\r\n  R: Trect;\r\n\r\nbegin\r\n  if Assigned(Node) and (Node <> FRoot) then\r\n  begin\r\n    R := GetDisplayRect(Node, -1, False);\r\n    RedrawWindow(Handle, @R, 0, RDW_INVALIDATE or RDW_UPDATENOW or RDW_NOERASE or RDW_VALIDATE or RDW_NOCHILDREN);\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.ResetNode(Node: PVirtualNode);\r\n\r\n// Deletes all children of the given node and marks it as being uninitialized.\r\n\r\nbegin\r\n  DoCancelEdit;\r\n  if (Node = nil) or (Node = FRoot) then\r\n    Clear\r\n  else\r\n  begin\r\n    DoReset(Node);\r\n    DeleteChildren(Node);\r\n    // Remove initialized and other dynamic styles, keep persistent styles.\r\n    Node.States := Node.States - [vsInitialized, vsChecking, vsCutOrCopy, vsDeleting, vsHasChildren, vsExpanded,\r\n      vsHeightMeasured];\r\n    InvalidateNode(Node);\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.SaveToFile(const FileName: TFileName);\r\n\r\n// Saves the entire content of the tree into a file (see further notes in SaveToStream).\r\n\r\nvar\r\n  FileStream: TFileStream;\r\n\r\nbegin\r\n  FileStream := TFileStream.Create(FileName, fmCreate);\r\n  try\r\n    SaveToStream(FileStream);\r\n  finally\r\n    FileStream.Free;\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.SaveToStream(Stream: TStream; Node: PVirtualNode = nil);\r\n\r\n// Saves Node and all its children to Stream. If Node is nil then all top level nodes will be stored.\r\n// Note: You should be careful about assuming what is actually saved. The problem here is that we are dealing with\r\n//       virtual data. The tree can so not know what it has to save. The only fact we reliably know is the tree's\r\n//       structure. To be flexible for future enhancements as well as unknown content (unknown to the tree class which\r\n//       is saving/loading the stream) a chunk based approach is used here. Every tree class handles only those\r\n//       chunks which are not handled by an anchestor class and are known by the class.\r\n//\r\n// The base tree class saves only the structure of the tree along with application provided data. descendants may\r\n// optionally add their own chunks to store additional information. See: WriteChunks.\r\n\r\nvar\r\n  Count: Cardinal;\r\n\r\nbegin\r\n  Stream.Write(MagicID, SizeOf(MagicID));\r\n  if Node = nil then\r\n  begin\r\n    // Keep number of top level nodes for easy restauration.\r\n    Count := FRoot.ChildCount;\r\n    Stream.WriteBuffer(Count, SizeOf(Count));\r\n\r\n    // Save entire tree here.\r\n    Node := FRoot.FirstChild;\r\n    while Assigned(Node) do\r\n    begin\r\n      WriteNode(Stream, Node);\r\n      Node := Node.NextSibling;\r\n    end;\r\n  end\r\n  else\r\n  begin\r\n    Count := 1;\r\n    Stream.WriteBuffer(Count, SizeOf(Count));\r\n    WriteNode(Stream, Node);\r\n  end;\r\n  if Assigned(FOnSaveTree) then\r\n    FOnSaveTree(Self, Stream);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TBaseVirtualTree.ScrollIntoView(Node: PVirtualNode; Center: Boolean; Horizontally: Boolean = False): Boolean;\r\n\r\n// Scrolls the tree so that the given node is in the client area and returns True if the tree really has been\r\n// scrolled (e.g. to avoid further updates) else returns False. If extened focus is enabled then the tree will also\r\n// be horizontally scrolled if needed.\r\n// Note: All collapsed parents of the node are expanded.\r\n\r\nvar\r\n  R: TRect;\r\n  Run: PVirtualNode;\r\n  UseColumns,\r\n  HScrollBarVisible: Boolean;\r\n  ScrolledVertically,\r\n  ScrolledHorizontally: Boolean;\r\n\r\nbegin\r\n  ScrolledVertically := False;\r\n  ScrolledHorizontally := False;\r\n\r\n  if Assigned(Node) and (Node <> FRoot) then\r\n  begin\r\n    // Make sure all parents of the node are expanded.\r\n    Run := Node.Parent;\r\n    while Run <> FRoot do\r\n    begin\r\n      if not (vsExpanded in Run.States) then\r\n        ToggleNode(Run);\r\n      Run := Run.Parent;\r\n    end;\r\n    UseColumns := FHeader.UseColumns;\r\n    if UseColumns and FHeader.FColumns.IsValidColumn(FFocusedColumn) then\r\n      R := GetDisplayRect(Node, FFocusedColumn, not (toGridExtensions in FOptions.FMiscOptions))\r\n    else\r\n      R := GetDisplayRect(Node, NoColumn, not (toGridExtensions in FOptions.FMiscOptions));\r\n\r\n    // The returned rectangle can never be empty after the expand code above.\r\n    // 1) scroll vertically\r\n    if R.Top < 0 then\r\n    begin\r\n      if Center then\r\n        SetOffsetY(FOffsetY - R.Top + ClientHeight div 2)\r\n      else\r\n        SetOffsetY(FOffsetY - R.Top);\r\n      ScrolledVertically := True;\r\n    end\r\n    else\r\n      if (R.Bottom > ClientHeight) or Center then\r\n      begin\r\n        HScrollBarVisible := (ScrollBarOptions.ScrollBars in [System.UITypes.TScrollStyle.ssBoth, System.UITypes.TScrollStyle.ssHorizontal]) and\r\n          (ScrollBarOptions.AlwaysVisible or (Integer(FRangeX) > ClientWidth));\r\n        if Center then\r\n          SetOffsetY(FOffsetY - R.Bottom + ClientHeight div 2)\r\n        else\r\n          SetOffsetY(FOffsetY - R.Bottom + ClientHeight);\r\n        // When scrolling up and the horizontal scroll appears because of the operation\r\n        // then we have to move up the node the horizontal scrollbar's height too\r\n        // in order to avoid that the scroll bar hides the node which we wanted to have in view.\r\n        if not UseColumns and not HScrollBarVisible and (Integer(FRangeX) > ClientWidth) then\r\n          SetOffsetY(FOffsetY - GetSystemMetrics(SM_CYHSCROLL));\r\n        ScrolledVertically := True;\r\n      end;\r\n\r\n    if Horizontally then\r\n      // 2) scroll horizontally\r\n      ScrolledHorizontally := ScrollIntoView(FFocusedColumn, Center);\r\n\r\n  end;\r\n\r\n  Result := ScrolledVertically or ScrolledHorizontally;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TBaseVirtualTree.ScrollIntoView(Column: TColumnIndex; Center: Boolean): Boolean;\r\n\r\n// Scrolls the columns so that the given column is in the client area and returns True if the columns really have been\r\n// scrolled (e.g. to avoid further updates) else returns False.\r\n\r\nvar\r\n  ColumnLeft,\r\n  ColumnRight: Integer;\r\n  NewOffset: Integer;\r\n\r\nbegin\r\n  Result := False;\r\n\r\n  if not FHeader.UseColumns then\r\n    Exit;\r\n  if not FHeader.Columns.IsValidColumn(Column) then\r\n    Exit; // Just in case.\r\n\r\n  ColumnLeft := Header.Columns.Items[Column].Left;\r\n  ColumnRight := ColumnLeft + Header.Columns.Items[Column].Width;\r\n\r\n  NewOffset := FEffectiveOffsetX;\r\n  if Center then\r\n  begin\r\n    NewOffset := FEffectiveOffsetX + ColumnLeft - (Header.Columns.GetVisibleFixedWidth div 2) - (ClientWidth div 2) + ((ColumnRight - ColumnLeft) div 2);\r\n    if NewOffset <> FEffectiveOffsetX then\r\n    begin\r\n      if UseRightToLeftAlignment then\r\n        SetOffsetX(-Integer(FRangeX) + ClientWidth + NewOffset)\r\n      else\r\n        SetOffsetX(-NewOffset);\r\n    end;\r\n    Result := True;\r\n  end\r\n  else if not (coFixed in Header.Columns[Column].Options) then\r\n  begin\r\n    if ColumnRight > ClientWidth then\r\n      NewOffset := FEffectiveOffsetX + (ColumnRight - ClientWidth)\r\n    else if (ColumnLeft < Header.Columns.GetVisibleFixedWidth) then\r\n      NewOffset := FEffectiveOffsetX - (Header.Columns.GetVisibleFixedWidth - ColumnLeft);\r\n    if NewOffset <> FEffectiveOffsetX then\r\n    begin\r\n      if UseRightToLeftAlignment then\r\n        SetOffsetX(-Integer(FRangeX) + ClientWidth + NewOffset)\r\n      else\r\n        SetOffsetX(-NewOffset);\r\n    end;\r\n    Result := True;\r\n  end\r\n  else\r\n    Result := True;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.SelectAll(VisibleOnly: Boolean);\r\n\r\n// Select all nodes in the tree.\r\n// If VisibleOnly is True then only visible nodes are selected.\r\n\r\nvar\r\n  Run: PVirtualNode;\r\n  NextFunction: TGetNextNodeProc;\r\n\r\nbegin\r\n  if not FSelectionLocked and (toMultiSelect in FOptions.FSelectionOptions) then\r\n  begin\r\n    ClearTempCache;\r\n    if VisibleOnly then\r\n    begin\r\n      Run := GetFirstVisible(nil, True);\r\n      NextFunction := GetNextVisible;\r\n    end\r\n    else\r\n    begin\r\n      Run := GetFirst;\r\n      NextFunction := GetNext;\r\n    end;\r\n\r\n    while Assigned(Run) do\r\n    begin\r\n      if not(vsSelected in Run.States) then\r\n        InternalCacheNode(Run);\r\n      Run := NextFunction(Run);\r\n    end;\r\n    if FTempNodeCount > 0 then\r\n      AddToSelection(FTempNodeCache, FTempNodeCount);\r\n    ClearTempCache;\r\n    Invalidate;\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.Sort(Node: PVirtualNode; Column: TColumnIndex; Direction: TSortDirection; DoInit: Boolean = True);\r\n\r\n// Sorts the given node. The application is queried about how to sort via the OnCompareNodes event.\r\n// Column is simply passed to the the compare function so the application can also sort in a particular column.\r\n// In order to free the application from taking care about the sort direction the parameter Direction is used.\r\n// This way the application can always sort in increasing order, while this method reorders nodes according to this flag.\r\n\r\n  //--------------- local functions -------------------------------------------\r\n\r\n  function MergeAscending(A, B: PVirtualNode): PVirtualNode;\r\n\r\n  // Merges A and B (which both must be sorted via Compare) into one list.\r\n\r\n  var\r\n    Dummy: TVirtualNode;\r\n    CompareResult: Integer;\r\n  begin\r\n    // This avoids checking for Result = nil in the loops.\r\n    Result := @Dummy;\r\n    while Assigned(A) and Assigned(B) do\r\n    begin\r\n      if OperationCanceled then\r\n        CompareResult := 0\r\n      else\r\n        CompareResult := DoCompare(A, B, Column);\r\n\r\n      if CompareResult <= 0 then\r\n      begin\r\n        Result.NextSibling := A;\r\n        Result := A;\r\n        A := A.NextSibling;\r\n      end\r\n      else\r\n      begin\r\n        Result.NextSibling := B;\r\n        Result := B;\r\n        B := B.NextSibling;\r\n      end;\r\n    end;\r\n\r\n    // Just append the list which is not nil (or set end of result list to nil if both lists are nil).\r\n    if Assigned(A) then\r\n      Result.NextSibling := A\r\n    else\r\n      Result.NextSibling := B;\r\n    // return start of the new merged list\r\n    Result := Dummy.NextSibling;\r\n  end;\r\n\r\n  //---------------------------------------------------------------------------\r\n\r\n  function MergeDescending(A, B: PVirtualNode): PVirtualNode;\r\n\r\n  // Merges A and B (which both must be sorted via Compare) into one list.\r\n\r\n  var\r\n    Dummy: TVirtualNode;\r\n    CompareResult: Integer;\r\n\r\n  begin\r\n    // this avoids checking for Result = nil in the loops\r\n    Result := @Dummy;\r\n    while Assigned(A) and Assigned(B) do\r\n    begin\r\n      if OperationCanceled then\r\n        CompareResult := 0\r\n      else\r\n        CompareResult := DoCompare(A, B, Column);\r\n\r\n      if CompareResult >= 0 then\r\n      begin\r\n        Result.NextSibling := A;\r\n        Result := A;\r\n        A := A.NextSibling;\r\n      end\r\n      else\r\n      begin\r\n        Result.NextSibling := B;\r\n        Result := B;\r\n        B := B.NextSibling;\r\n      end;\r\n    end;\r\n\r\n    // Just append the list which is not nil (or set end of result list to nil if both lists are nil).\r\n    if Assigned(A) then\r\n      Result.NextSibling := A\r\n    else\r\n      Result.NextSibling := B;\r\n    // Return start of the newly merged list.\r\n    Result := Dummy.NextSibling;\r\n  end;\r\n\r\n  //---------------------------------------------------------------------------\r\n\r\n  function MergeSortAscending(var Node: PVirtualNode; N: Cardinal): PVirtualNode;\r\n\r\n  // Sorts the list of nodes given by Node (which must not be nil).\r\n\r\n  var\r\n    A, B: PVirtualNode;\r\n\r\n  begin\r\n    if N > 1 then\r\n    begin\r\n      A := MergeSortAscending(Node, N div 2);\r\n      B := MergeSortAscending(Node, (N + 1) div 2);\r\n      Result := MergeAscending(A, B);\r\n    end\r\n    else\r\n    begin\r\n      Result := Node;\r\n      Node := Node.NextSibling;\r\n      Result.NextSibling := nil;\r\n    end;\r\n  end;\r\n\r\n  //---------------------------------------------------------------------------\r\n\r\n  function MergeSortDescending(var Node: PVirtualNode; N: Cardinal): PVirtualNode;\r\n\r\n  // Sorts the list of nodes given by Node (which must not be nil).\r\n\r\n  var\r\n    A, B: PVirtualNode;\r\n\r\n  begin\r\n    if N > 1 then\r\n    begin\r\n      A := MergeSortDescending(Node, N div 2);\r\n      B := MergeSortDescending(Node, (N + 1) div 2);\r\n      Result := MergeDescending(A, B);\r\n    end\r\n    else\r\n    begin\r\n      Result := Node;\r\n      Node := Node.NextSibling;\r\n      Result.NextSibling := nil;\r\n    end;\r\n  end;\r\n\r\n  //--------------- end local functions ---------------------------------------\r\n\r\nvar\r\n  Run: PVirtualNode;\r\n  Index: Cardinal;\r\n\r\nbegin\r\n  InterruptValidation;\r\n  if tsEditPending in FStates then\r\n  begin\r\n    StopTimer(EditTimer);\r\n    DoStateChange([], [tsEditPending]);\r\n  end;\r\n\r\n  if not (tsEditing in FStates) or DoEndEdit then\r\n  begin\r\n    if Node = nil then\r\n      Node := FRoot;\r\n    if vsHasChildren in Node.States then\r\n    begin\r\n      if (Node.ChildCount = 0) and DoInit then\r\n        InitChildren(Node);\r\n      // Make sure the children are valid, so they can be sorted at all.\r\n      if DoInit and (Node.ChildCount > 0) then\r\n        ValidateChildren(Node, False);\r\n      // Child count might have changed.\r\n      if Node.ChildCount > 1 then\r\n      begin\r\n        StartOperation(okSortNode);\r\n        try\r\n          // Sort the linked list, check direction flag only once.\r\n          if Direction = sdAscending then\r\n            Node.FirstChild := MergeSortAscending(Node.FirstChild, Node.ChildCount)\r\n          else\r\n            Node.FirstChild := MergeSortDescending(Node.FirstChild, Node.ChildCount);\r\n        finally\r\n          EndOperation(okSortNode);\r\n        end;\r\n        // Consolidate the child list finally.\r\n        Run := Node.FirstChild;\r\n        Run.PrevSibling := nil;\r\n        Index := 0;\r\n        repeat\r\n          Run.Index := Index;\r\n          Inc(Index);\r\n          if Run.NextSibling = nil then\r\n            Break;\r\n          Run.NextSibling.PrevSibling := Run;\r\n          Run := Run.NextSibling;\r\n        until False;\r\n        Node.LastChild := Run;\r\n\r\n        InvalidateCache;\r\n      end;\r\n      if FUpdateCount = 0 then\r\n      begin\r\n        ValidateCache;\r\n        Invalidate;\r\n      end;\r\n    end;\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.SortTree(Column: TColumnIndex; Direction: TSortDirection; DoInit: Boolean = True);\r\n\r\n  //--------------- local function --------------------------------------------\r\n\r\n  procedure DoSort(Node: PVirtualNode);\r\n\r\n  // Recursively sorts Node and its child nodes.\r\n\r\n  var\r\n    Run: PVirtualNode;\r\n\r\n  begin\r\n    Sort(Node, Column, Direction, DoInit);\r\n    // Recurse to next level\r\n    Run := Node.FirstChild;\r\n    while Assigned(Run) and not FOperationCanceled do\r\n    begin\r\n      if DoInit and not (vsInitialized in Run.States) then\r\n        InitNode(Run);\r\n      if (vsInitialized in Run.States) and (not (toAutoSort in TreeOptions.AutoOptions) or Expanded[Run]) then // There is no need to sort collapsed branches\r\n        DoSort(Run);\r\n      Run := Run.NextSibling;\r\n    end;\r\n  end;\r\n\r\n  //--------------- end local function ----------------------------------------\r\n\r\nbegin\r\n  if RootNode.TotalCount <= 2 then\r\n    Exit;//Nothing to do if there are one or zero nodes. RootNode.TotalCount is 1 if there are no nodes in the treee as the root node counts too here.\r\n  // Instead of wrapping the sort using BeginUpdate/EndUpdate simply the update counter\r\n  // is modified. Otherwise the EndUpdate call will recurse here.\r\n  Inc(FUpdateCount);\r\n  try\r\n    if Column > InvalidColumn then\r\n    begin\r\n      StartOperation(okSortTree);\r\n      try\r\n        DoSort(FRoot);\r\n      finally\r\n        EndOperation(okSortTree);\r\n      end; \r\n    end;\r\n    InvalidateCache;\r\n  finally\r\n    if FUpdateCount > 0 then\r\n      Dec(FUpdateCount);\r\n    if FUpdateCount = 0 then\r\n    begin\r\n      ValidateCache;\r\n      Invalidate;\r\n    end;\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.ToggleNode(Node: PVirtualNode);\r\n\r\n// Changes a node's expand state to the opposite state.\r\n\r\nvar\r\n  Child,\r\n  FirstVisible: PVirtualNode;\r\n  HeightDelta,\r\n  StepsR1,\r\n  StepsR2,\r\n  Steps: Integer;\r\n  TogglingTree,\r\n  ChildrenInView,\r\n  NeedFullInvalidate,\r\n  NeedUpdate,\r\n  NodeInView,\r\n  PosHoldable,\r\n  TotalFit: Boolean;\r\n  ToggleData: TToggleAnimationData;\r\n\r\n  //--------------- local function --------------------------------------------\r\n\r\n  procedure PrepareAnimation;\r\n\r\n  // Prepares ToggleData.\r\n\r\n  var\r\n    R: TRect;\r\n    S: Integer;\r\n    M: TToggleAnimationMode;\r\n\r\n  begin\r\n    with ToggleData do\r\n    begin\r\n      Window := Handle;\r\n      DC := GetDC(Handle);\r\n      Self.Brush.Color := FColors.BackGroundColor;\r\n      Brush := Self.Brush.Handle;\r\n\r\n      if (Mode1 <> tamNoScroll) and (Mode2 <> tamNoScroll) then\r\n      begin\r\n        if StepsR1 < StepsR2 then\r\n        begin\r\n          // As the primary rectangle is always R1 we will get a much smoother\r\n          // animation if R1 is the one that will be scrolled more.\r\n          R := R2;\r\n          R2 := R1;\r\n          R1 := R;\r\n\r\n          M := Mode2;\r\n          Mode2 := Mode1;\r\n          Mode1 := M;\r\n\r\n          S := StepsR2;\r\n          StepsR2 := StepsR1;\r\n          StepsR1 := S;\r\n        end;\r\n        ScaleFactor := StepsR2 / StepsR1;\r\n        MissedSteps := 0;\r\n      end;\r\n\r\n      if Mode1 <> tamNoScroll then\r\n        Steps := StepsR1\r\n      else\r\n        Steps := StepsR2;\r\n    end;\r\n  end;\r\n\r\n  //--------------- end local function ----------------------------------------\r\n\r\nbegin\r\n  Assert(Assigned(Node), 'Node must not be nil.');\r\n\r\n  TogglingTree := tsToggling in FStates;\r\n  ChildrenInView := False;\r\n  HeightDelta := 0;\r\n  NeedFullInvalidate := False;\r\n  NeedUpdate := False;\r\n  NodeInView := False;\r\n  PosHoldable := False;\r\n  TotalFit := False;\r\n\r\n  // We don't need to switch the expand state if the node is being deleted otherwise some\r\n  // updates (e.g. visible node count) are done twice with disasterous results).\r\n  if [vsDeleting, vsToggling] * Node.States = [] then\r\n  begin\r\n    try\r\n      DoStateChange([tsToggling]);\r\n      Include(Node.States, vsToggling);\r\n\r\n      if vsExpanded in Node.States then\r\n      begin\r\n        if DoCollapsing(Node) then\r\n        begin\r\n          NeedUpdate := True;\r\n\r\n          // Calculate the height delta right now as we need it for toChildrenAbove anyway.\r\n          HeightDelta := -Integer(Node.TotalHeight) + Integer(NodeHeight[Node]); \r\n          if (FUpdateCount = 0) and (toAnimatedToggle in FOptions.FAnimationOptions) and not\r\n             (tsCollapsing in FStates) then\r\n          begin\r\n            if tsHint in Self.FStates then\r\n              Application.CancelHint;\r\n            UpdateWindow(Handle);\r\n\r\n            // animated collapsing\r\n            with ToggleData do\r\n            begin\r\n              // Determine the animation behaviour and rectangle. If toChildrenAbove is set, the behaviour is depending\r\n              // on the position of the node to be collapsed.\r\n              R1 := GetDisplayRect(Node, NoColumn, False);\r\n              Mode2 := tamNoScroll;\r\n              if toChildrenAbove in FOptions.FPaintOptions then\r\n              begin\r\n                PosHoldable := (FOffsetY + (Integer(Node.TotalHeight) - Integer(NodeHeight[Node]))) <= 0;\r\n                NodeInView := R1.Top < ClientHeight;\r\n\r\n                StepsR1 := 0;\r\n                if NodeInView then\r\n                begin\r\n                  if PosHoldable or not (toAdvancedAnimatedToggle in FOptions.FAnimationOptions) then\r\n                  begin\r\n                    // Scroll the child nodes down.\r\n                    Mode1 := tamScrollDown;\r\n                    R1.Bottom := R1.Top;\r\n                    R1.Top := 0;\r\n                    StepsR1 := Min(R1.Bottom - R1.Top + 1, Integer(Node.TotalHeight) - Integer(NodeHeight[Node]));\r\n                  end\r\n                  else\r\n                  begin\r\n                    // The position cannot be kept. So scroll the node up to its future position.\r\n                    Mode1 := tamScrollUp;\r\n                    R1.Top := Max(0, R1.Top + HeightDelta);\r\n                    R1.Bottom := ClientHeight;\r\n                    StepsR1 := FOffsetY - HeightDelta;\r\n                  end;\r\n                end;\r\n              end\r\n              else\r\n              begin\r\n                if (Integer(FRangeY) + FOffsetY - R1.Bottom + HeightDelta >= ClientHeight - R1.Bottom) or\r\n                   (Integer(FRangeY) <= ClientHeight) or (FOffsetY = 0) or not\r\n                   (toAdvancedAnimatedToggle in FOptions.FAnimationOptions) then\r\n                begin\r\n                  // Do a simple scroll up over the child nodes.\r\n                  Mode1 := tamScrollUp;\r\n                  Inc(R1.Top, NodeHeight[Node]);\r\n                  R1.Bottom := ClientHeight;\r\n                  StepsR1 := Min(R1.Bottom - R1.Top + 1, -HeightDelta);\r\n                end\r\n                else\r\n                begin\r\n                  // Scroll the node down to its future position. As FOffsetY will change we need to invalidate the\r\n                  // whole tree.\r\n                  Mode1 := tamScrollDown;\r\n                  StepsR1 := Min(-FOffsetY, ClientHeight - Integer(FRangeY) -FOffsetY - HeightDelta);\r\n                  R1.Top := 0;\r\n                  R1.Bottom := Min(ClientHeight, R1.Bottom + Steps);\r\n                  NeedFullInvalidate := True;\r\n                end;\r\n              end;\r\n\r\n              // No animation necessary if the node is below the current client height.\r\n              if R1.Top < ClientHeight then\r\n              begin\r\n                PrepareAnimation;\r\n                try\r\n                  Animate(Steps, FAnimationDuration, ToggleCallback, @ToggleData);\r\n                finally\r\n                  ReleaseDC(Window, DC);\r\n                end;\r\n              end;\r\n            end;\r\n          end;\r\n\r\n          // collapse the node\r\n          AdjustTotalHeight(Node, IfThen(IsEffectivelyFiltered[Node], 0, NodeHeight[Node]));\r\n          if FullyVisible[Node] then\r\n            Dec(FVisibleCount, CountVisibleChildren(Node));\r\n          Exclude(Node.States, vsExpanded);\r\n          DoCollapsed(Node);\r\n\r\n          // Remove child nodes now, if enabled.\r\n          if (toAutoFreeOnCollapse in FOptions.FAutoOptions) and (Node.ChildCount > 0) then\r\n          begin\r\n            DeleteChildren(Node);\r\n            Include(Node.States, vsHasChildren);\r\n          end;\r\n        end;\r\n      end\r\n      else\r\n        if DoExpanding(Node) then\r\n        begin\r\n          NeedUpdate := True;\r\n          // expand the node, need to adjust the height\r\n          if not (vsInitialized in Node.States) then\r\n            InitNode(Node);\r\n          if (vsHasChildren in Node.States) and (Node.ChildCount = 0) then\r\n            InitChildren(Node);\r\n\r\n          // Avoid setting the vsExpanded style if there are no child nodes.\r\n          if Node.ChildCount > 0 then\r\n          begin\r\n            // Iterate through the child nodes without initializing them. We have to determine the entire height.\r\n            Child := Node.FirstChild;\r\n            repeat\r\n              if vsVisible in Child.States then\r\n              begin\r\n                // Ensure the item height is measured\r\n                MeasureItemHeight(Canvas, Child);\r\n\r\n                Inc(HeightDelta, Child.TotalHeight);\r\n              end;\r\n              Child := Child.NextSibling;\r\n            until Child = nil;\r\n\r\n            // Getting the display rectangle is already done here as it is needed for toChildrenAbove in any case.\r\n            if (toChildrenAbove in FOptions.FPaintOptions) or (FUpdateCount = 0) then\r\n            begin\r\n              with ToggleData do\r\n              begin\r\n                R1 := GetDisplayRect(Node, NoColumn, False);\r\n                Mode2 := tamNoScroll;\r\n                TotalFit := HeightDelta + Integer(NodeHeight[Node]) <= ClientHeight;\r\n\r\n                if toChildrenAbove in FOptions.FPaintOptions then\r\n                begin\r\n                  // The main goal with toChildrenAbove being set is to keep the nodes visual position so the user does\r\n                  // not get confused. Therefore we need to scroll the view when the expanding is done.\r\n                  PosHoldable := TotalFit and (Integer(FRangeY) - ClientHeight >= 0) ;\r\n                  ChildrenInView := (R1.Top - HeightDelta) >= 0;\r\n                  NodeInView := R1.Bottom <= ClientHeight;\r\n                end\r\n                else\r\n                begin\r\n                  PosHoldable := TotalFit;\r\n                  ChildrenInView := R1.Bottom + HeightDelta <= ClientHeight;\r\n                end;\r\n\r\n                R1.Bottom := ClientHeight;\r\n              end;\r\n            end;\r\n\r\n            if FUpdateCount = 0 then\r\n            begin\r\n              // Do animated expanding if enabled.\r\n              if (ToggleData.R1.Top < ClientHeight) and ([tsPainting, tsExpanding] * FStates = []) and\r\n                (toAnimatedToggle in FOptions.FAnimationOptions)then\r\n              begin\r\n                if tsHint in Self.FStates then\r\n                  Application.CancelHint;\r\n                UpdateWindow(Handle);\r\n                // animated expanding\r\n                with ToggleData do\r\n                begin\r\n                  if toChildrenAbove in FOptions.FPaintOptions then\r\n                  begin\r\n                    // At first check if we hold the position, which is the most common case.\r\n                    if not (toAdvancedAnimatedToggle in FOptions.FAnimationOptions) or\r\n                       (PosHoldable and ( (NodeInView and ChildrenInView) or not\r\n                                          (toAutoScrollOnExpand in FOptions.FAutoOptions) )) then\r\n                    begin\r\n                      Mode1 := tamScrollUp;\r\n                      R1 := Rect(R1.Left, 0, R1.Right, R1.Top);\r\n                      StepsR1 := Min(HeightDelta, R1.Bottom);\r\n                    end\r\n                    else\r\n                    begin\r\n                      // If we will not hold the node's visual position we mostly scroll in both directions.\r\n                      Mode1 := tamScrollDown;\r\n                      Mode2 := tamScrollUp;\r\n                      R2 := Rect(R1.Left, 0, R1.Right, R1.Top);\r\n                      if not (toAutoScrollOnExpand in FOptions.FAutoOptions) then\r\n                      begin\r\n                        // If we shall not or cannot scroll to the desired extent we calculate the new position (with\r\n                        // max FOffsetY applied) and animate it that way.\r\n                        StepsR1 := -FOffsetY - Max(Integer(FRangeY) + HeightDelta - ClientHeight, 0) + HeightDelta;\r\n                        if (Integer(FRangeY) + HeightDelta - ClientHeight) <= 0 then\r\n                          Mode2 := tamNoScroll\r\n                        else\r\n                          StepsR2 := Min(Integer(FRangeY) + HeightDelta - ClientHeight, R2.Bottom);\r\n                      end\r\n                      else\r\n                      begin\r\n                        if TotalFit and NodeInView and (Integer(FRangeY) + HeightDelta > ClientHeight) then\r\n                        begin\r\n                          // If the whole subtree will fit into the client area and the node is currently fully visible,\r\n                          // the first child will be made the top node if possible.\r\n                          if HeightDelta >= R1.Top then\r\n                            StepsR1 := Abs(R1.Top - HeightDelta)\r\n                          else\r\n                            StepsR1 := ClientHeight - Integer(FRangeY);\r\n                        end\r\n                        else\r\n                          if Integer(FRangeY) + HeightDelta <= ClientHeight then\r\n                          begin\r\n                            // We cannot make the first child the top node as we cannot scroll to that extent,\r\n                            // so we do a simple scroll down.\r\n                            Mode2 := tamNoScroll;\r\n                            StepsR1 := HeightDelta;\r\n                          end\r\n                          else\r\n                            // If the subtree does not fit into the client area at once, the expanded node will\r\n                            // be made the bottom node.\r\n                            StepsR1 := ClientHeight - R1.Top - Integer(NodeHeight[Node]);\r\n\r\n                        if Mode2 <> tamNoScroll then\r\n                        begin\r\n                          if StepsR1 > 0 then\r\n                            StepsR2 := Min(R1.Top, HeightDelta - StepsR1)\r\n                          else\r\n                          begin\r\n                            // If the node is already at the bottom scrolling is needed.\r\n                            Mode1 := tamNoScroll;\r\n                            StepsR2 := Min(HeightDelta, R1.Bottom);\r\n                          end;\r\n                        end;\r\n                      end;\r\n                    end;\r\n                  end\r\n                  else\r\n                  begin\r\n                    // toChildrenAbove is not set.\r\n                    if (PosHoldable and ChildrenInView) or not (toAutoScrollOnExpand in FOptions.FAutoOptions) or not\r\n                       (toAdvancedAnimatedToggle in FOptions.FAnimationOptions) or (R1.Top <= 0) then\r\n                    begin\r\n                      // If the node will stay at its visual position, do a simple down-scroll.\r\n                      Mode1 := tamScrollDown;\r\n                      Inc(R1.Top, NodeHeight[Node]);\r\n                      StepsR1 := Min(R1.Bottom - R1.Top, HeightDelta);\r\n                    end\r\n                    else\r\n                    begin\r\n                      // We will not hold the nodes visual position so perform a double scroll.\r\n                      Mode1 := tamScrollUp;\r\n                      Mode2 := tamScrollDown;\r\n\r\n                      R1.Bottom := R1.Top + Integer(NodeHeight[Node]) + 1;\r\n                      R1.Top := 0;\r\n                      R2 := Rect(R1.Left, R1.Bottom, R1.Right, ClientHeight);\r\n\r\n                      StepsR1 := Min(HeightDelta - (ClientHeight - R2.Top), R1.Bottom - Integer(NodeHeight[Node]));\r\n                      StepsR2 := ClientHeight - R2.Top;\r\n                    end;\r\n                  end;\r\n\r\n                  if ClientHeight >= R1.Top then\r\n                  begin\r\n                    PrepareAnimation;\r\n                    try\r\n                      Animate(Steps, FAnimationDuration, ToggleCallback, @ToggleData);\r\n                    finally\r\n                      ReleaseDC(Window, DC);\r\n                    end;\r\n                  end;\r\n                end;\r\n              end;\r\n              if toAutoSort in FOptions.FAutoOptions then\r\n                Sort(Node, FHeader.FSortColumn, FHeader.FSortDirection, False);\r\n            end;// if UpdateCount = 0\r\n\r\n            Include(Node.States, vsExpanded);\r\n            AdjustTotalHeight(Node, HeightDelta, True);\r\n            if FullyVisible[Node] then\r\n              Inc(FVisibleCount, CountVisibleChildren(Node));\r\n\r\n            DoExpanded(Node);\r\n          end;\r\n        end;\r\n\r\n      if NeedUpdate then\r\n      begin\r\n        InvalidateCache;\r\n        if FUpdateCount = 0 then\r\n        begin\r\n          ValidateCache;\r\n          if Node.ChildCount > 0 then\r\n          begin\r\n            UpdateRanges;\r\n            UpdateScrollBars(True);\r\n            if [tsPainting, tsExpanding] * FStates = [] then\r\n            begin\r\n              if (vsExpanded in Node.States) and ((toAutoScrollOnExpand in FOptions.FAutoOptions) or\r\n                 (toChildrenAbove in FOptions.FPaintOptions)) then\r\n              begin\r\n                if toChildrenAbove in FOptions.FPaintOptions then\r\n                begin\r\n                  NeedFullInvalidate := True;\r\n                  if (PosHoldable and ChildrenInView and NodeInView) or not\r\n                     (toAutoScrollOnExpand in FOptions.FAutoOptions) then\r\n                    SetOffsetY(FOffsetY - Integer(HeightDelta))\r\n                  else\r\n                    if TotalFit and NodeInView then\r\n                    begin\r\n                      FirstVisible := GetFirstVisible(Node, True);\r\n                      if Assigned(FirstVisible) then // otherwise there is no visible child at all\r\n                        SetOffsetY(FOffsetY - GetDisplayRect(FirstVisible, NoColumn, False).Top);\r\n                    end\r\n                    else\r\n                      BottomNode := Node;\r\n                end\r\n                else\r\n                begin\r\n                  // Scroll as much child nodes into view as possible if the node has been expanded.\r\n                  if PosHoldable then\r\n                    NeedFullInvalidate := ScrollIntoView(GetLastVisible(Node, True), False)\r\n                  else\r\n                  begin\r\n                    TopNode := Node;\r\n                    NeedFullInvalidate := True;\r\n                  end;\r\n                end;\r\n              end\r\n              else\r\n              begin\r\n                // If we have collapsed the node or toAutoScrollOnExpand is not set, we try to keep the nodes\r\n                // visual position.\r\n                if toChildrenAbove in FOptions.FPaintOptions then\r\n                  SetOffsetY(FOffsetY - Integer(HeightDelta));\r\n                NeedFullInvalidate := True;\r\n              end;\r\n            end;\r\n\r\n            //UpdateScrollBars(True); Moved up\r\n\r\n            // Check for automatically scrolled tree.\r\n            if NeedFullInvalidate then\r\n              Invalidate\r\n            else\r\n              InvalidateToBottom(Node);\r\n          end\r\n          else\r\n            InvalidateNode(Node);\r\n        end\r\n        else\r\n          UpdateRanges;\r\n      end;\r\n\r\n    finally\r\n      Exclude(Node.States, vsToggling);\r\n      if not TogglingTree then\r\n        DoStateChange([], [tsToggling]);\r\n    end;\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.UpdateHorizontalRange;\r\n\r\nbegin\r\n  if FHeader.UseColumns then\r\n    FRangeX := FHeader.FColumns.TotalWidth\r\n  else\r\n    FRangeX := GetMaxRightExtend;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.UpdateHorizontalScrollBar(DoRepaint: Boolean);\r\n\r\nvar\r\n  ScrollInfo: TScrollInfo;\r\n\r\nbegin\r\n  UpdateHorizontalRange;\r\n\r\n  if (tsUpdating in FStates) or not HandleAllocated then\r\n    Exit;\r\n\r\n  // Adjust effect scroll offset depending on bidi mode.\r\n  if UseRightToLeftAlignment then\r\n    FEffectiveOffsetX := Integer(FRangeX) - ClientWidth + FOffsetX\r\n  else\r\n    FEffectiveOffsetX := -FOffsetX;\r\n\r\n  if FScrollBarOptions.ScrollBars in [System.UITypes.TScrollStyle.ssHorizontal, System.UITypes.TScrollStyle.ssBoth] then\r\n  begin\r\n    ZeroMemory (@ScrollInfo, SizeOf(ScrollInfo));\r\n    ScrollInfo.cbSize := SizeOf(ScrollInfo);\r\n    ScrollInfo.fMask := SIF_ALL;\r\n    GetScrollInfo(Handle, SB_HORZ, ScrollInfo);\r\n\r\n    if (Integer(FRangeX) > ClientWidth) or FScrollBarOptions.AlwaysVisible then\r\n    begin\r\n      DoShowScrollBar(SB_HORZ, True);\r\n\r\n      ScrollInfo.nMin := 0;\r\n      ScrollInfo.nMax := FRangeX;\r\n      ScrollInfo.nPos := FEffectiveOffsetX;\r\n      ScrollInfo.nPage := Max(0, ClientWidth + 1);\r\n\r\n      ScrollInfo.fMask := SIF_ALL or ScrollMasks[FScrollBarOptions.AlwaysVisible];\r\n      SetScrollInfo(Handle, SB_HORZ, ScrollInfo, DoRepaint);\r\n    end\r\n    else\r\n    begin\r\n      ScrollInfo.nMin := 0;\r\n      ScrollInfo.nMax := 0;\r\n      ScrollInfo.nPos := 0;\r\n      ScrollInfo.nPage := 0;\r\n      DoShowScrollBar(SB_HORZ, False);\r\n      SetScrollInfo(Handle, SB_HORZ, ScrollInfo, False);\r\n    end;\r\n\r\n    // Since the position is automatically changed if it doesn't meet the range\r\n    // we better read the current position back to stay synchronized.\r\n    FEffectiveOffsetX := GetScrollPos(Handle, SB_HORZ);\r\n    if UseRightToLeftAlignment then\r\n      SetOffsetX(-Integer(FRangeX) + ClientWidth + FEffectiveOffsetX)\r\n    else\r\n      SetOffsetX(-FEffectiveOffsetX);\r\n  end\r\n  else\r\n  begin\r\n    DoShowScrollBar(SB_HORZ, False);\r\n\r\n    // Reset the current horizontal offset to account for window resize etc.\r\n    SetOffsetX(FOffsetX);\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.UpdateRanges;\r\n\r\nbegin\r\n  UpdateVerticalRange;\r\n  UpdateHorizontalRange;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.UpdateScrollBars(DoRepaint: Boolean);\r\n\r\n// adjusts scrollbars to reflect current size and paint offset of the tree\r\n\r\nbegin\r\n  if HandleAllocated then\r\n  begin\r\n    UpdateVerticalScrollBar(DoRepaint);\r\n    UpdateHorizontalScrollBar(DoRepaint);\r\n    Perform(CM_UPDATE_VCLSTYLE_SCROLLBARS,0,0);\r\n  end;\r\nend;\r\n\r\nprocedure TBaseVirtualTree.UpdateStyleElements;\r\nbegin\r\n  inherited;\r\n  UpdateHeaderRect;\r\n  FHeader.Columns.PaintHeader(Canvas, FHeaderRect, Point(0,0));\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.UpdateVerticalRange;\r\n\r\nbegin\r\n  // Total node height includes the height of the invisible root node.\r\n  FRangeY := Cardinal(Int64(FRoot.TotalHeight) - FRoot.NodeHeight + FBottomSpace);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.UpdateVerticalScrollBar(DoRepaint: Boolean);\r\n\r\nvar\r\n  ScrollInfo: TScrollInfo;\r\n\r\nbegin\r\n  UpdateVerticalRange;\r\n\r\n  if tsUpdating in FStates then\r\n    Exit;\r\n\r\n  if FScrollBarOptions.ScrollBars in [ssVertical, ssBoth] then\r\n  begin\r\n    ScrollInfo.cbSize := SizeOf(ScrollInfo);\r\n    ScrollInfo.fMask := SIF_ALL;\r\n    GetScrollInfo(Handle, SB_VERT, ScrollInfo);\r\n\r\n    if (Integer(FRangeY) > ClientHeight) or FScrollBarOptions.AlwaysVisible then\r\n    begin\r\n      DoShowScrollBar(SB_VERT, True);\r\n\r\n      ScrollInfo.nMin := 0;\r\n      ScrollInfo.nMax := FRangeY;\r\n      ScrollInfo.nPos := -FOffsetY;\r\n      ScrollInfo.nPage := Max(0, ClientHeight + 1);\r\n\r\n      ScrollInfo.fMask := SIF_ALL or ScrollMasks[FScrollBarOptions.AlwaysVisible];\r\n      SetScrollInfo(Handle, SB_VERT, ScrollInfo, DoRepaint);\r\n    end\r\n    else\r\n    begin\r\n      ScrollInfo.nMin := 0;\r\n      ScrollInfo.nMax := 0;\r\n      ScrollInfo.nPos := 0;\r\n      ScrollInfo.nPage := 0;\r\n      DoShowScrollBar(SB_VERT, False);\r\n      SetScrollInfo(Handle, SB_VERT, ScrollInfo, False);\r\n    end;\r\n\r\n    // Since the position is automatically changed if it doesn't meet the range\r\n    // we better read the current position back to stay synchronized.\r\n    SetOffsetY(-GetScrollPos(Handle, SB_VERT));\r\n  end\r\n  else\r\n  begin\r\n    DoShowScrollBar(SB_VERT, False);\r\n\r\n    // Reset the current vertical offset to account for window resize etc.\r\n    SetOffsetY(FOffsetY);\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TBaseVirtualTree.UseRightToLeftReading: Boolean;\r\n\r\n// The tree can handle right-to-left reading also on non-middle-east systems, so we cannot use the same function as\r\n// it is implemented in TControl.\r\n\r\nbegin\r\n  Result := BiDiMode <> bdLeftToRight;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.ValidateChildren(Node: PVirtualNode; Recursive: Boolean);\r\n\r\n// Ensures that the children of the given node (and all their children, if Recursive is True) are initialized.\r\n// Node must already be initialized\r\n\r\nvar\r\n  Child: PVirtualNode;\r\n\r\nbegin\r\n  if Node = nil then\r\n    Node := FRoot;\r\n\r\n  if (vsHasChildren in Node.States) and (Node.ChildCount = 0) then\r\n    InitChildren(Node);\r\n  Child := Node.FirstChild;\r\n  while Assigned(Child) do\r\n  begin\r\n    ValidateNode(Child, Recursive);\r\n    Child := Child.NextSibling;\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TBaseVirtualTree.ValidateNode(Node: PVirtualNode; Recursive: Boolean);\r\n\r\n// Ensures that the given node (and all its children, if Recursive is True) are initialized.\r\n\r\nvar\r\n  Child: PVirtualNode;\r\n\r\nbegin\r\n  if Node = nil then\r\n    Node := FRoot\r\n  else\r\n    if not (vsInitialized in Node.States) then\r\n      InitNode(Node);\r\n\r\n  if Recursive then\r\n  begin\r\n    if (vsHasChildren in Node.States) and (Node.ChildCount = 0) then\r\n      InitChildren(Node);\r\n    Child := Node.FirstChild;\r\n    while Assigned(Child) do\r\n    begin\r\n      ValidateNode(Child, Recursive);\r\n      Child := Child.NextSibling;\r\n    end;\r\n  end;\r\nend;\r\n\r\n//----------------- TCustomStringTreeOptions ---------------------------------------------------------------------------\r\n\r\nconstructor TCustomStringTreeOptions.Create(AOwner: TBaseVirtualTree);\r\n\r\nbegin\r\n  inherited;\r\n\r\n  FStringOptions := DefaultStringOptions;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TCustomStringTreeOptions.SetStringOptions(const Value: TVTStringOptions);\r\n\r\nvar\r\n  ChangedOptions: TVTStringOptions;\r\n\r\nbegin\r\n  if FStringOptions <> Value then\r\n  begin\r\n    // Exclusive ORing to get all entries wich are in either set but not in both.\r\n    ChangedOptions := FStringOptions + Value - (FStringOptions * Value);\r\n    FStringOptions := Value;\r\n    with FOwner do\r\n      if (toShowStaticText in ChangedOptions) and not (csLoading in ComponentState) and HandleAllocated then\r\n        Invalidate;\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TCustomStringTreeOptions.AssignTo(Dest: TPersistent);\r\n\r\nbegin\r\n  if Dest is TCustomStringTreeOptions then\r\n  begin\r\n    with Dest as TCustomStringTreeOptions do\r\n      StringOptions := Self.StringOptions;\r\n  end;\r\n\r\n  // Let ancestors assign their options to the destination class.\r\n  inherited;\r\nend;\r\n\r\n//----------------- TVTEdit --------------------------------------------------------------------------------------------\r\n\r\n// Implementation of a generic node caption editor.\r\n\r\nconstructor TVTEdit.Create(Link: TStringEditLink);\r\n\r\nbegin\r\n  inherited Create(nil);\r\n  ShowHint := False;\r\n  ParentShowHint := False;\r\n  // This assignment increases the reference count for the interface.\r\n  FRefLink := Link;\r\n  // This reference is used to access the link.\r\n  FLink := Link;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TVTEdit.CMAutoAdjust(var Message: TMessage);\r\n\r\nbegin\r\n  AutoAdjustSize;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TVTEdit.CMExit(var Message: TMessage);\r\n\r\nbegin\r\n  if Assigned(FLink) and not FLink.FStopping then\r\n    with FLink, FTree do\r\n    begin\r\n      if (toAutoAcceptEditChange in TreeOptions.StringOptions) then\r\n        DoEndEdit\r\n      else\r\n        DoCancelEdit;\r\n    end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TVTEdit.CMRelease(var Message: TMessage);\r\n\r\nbegin\r\n  Free;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TVTEdit.CNCommand(var Message: TWMCommand);\r\n\r\nbegin\r\n  if Assigned(FLink) and Assigned(FLink.FTree) and (Message.NotifyCode = EN_UPDATE) and\r\n    not (vsMultiline in FLink.FNode.States) then\r\n    // Instead directly calling AutoAdjustSize it is necessary on Win9x/Me to decouple this notification message\r\n    // and eventual resizing. Hence we use a message to accomplish that.\r\n    AutoAdjustSize()\r\n  else\r\n    inherited;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TVTEdit.WMChar(var Message: TWMChar);\r\n\r\nbegin\r\n  if not (Message.CharCode in [VK_ESCAPE, VK_TAB]) then\r\n    inherited;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TVTEdit.WMDestroy(var Message: TWMDestroy);\r\n\r\nbegin\r\n  // If editing stopped by other means than accept or cancel then we have to do default processing for\r\n  // pending changes.\r\n  if Assigned(FLink) and not FLink.FStopping then\r\n  begin\r\n    with FLink, FTree do\r\n    begin\r\n      if (toAutoAcceptEditChange in TreeOptions.StringOptions) and Modified then\r\n        Text[FNode, FColumn] := FEdit.Text;\r\n    end;\r\n    FLink := nil;\r\n    FRefLink := nil;\r\n  end;\r\n\r\n  inherited;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TVTEdit.WMGetDlgCode(var Message: TWMGetDlgCode);\r\n\r\nbegin\r\n  inherited;\r\n\r\n  Message.Result := Message.Result or DLGC_WANTALLKEYS or DLGC_WANTTAB or DLGC_WANTARROWS;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TVTEdit.WMKeyDown(var Message: TWMKeyDown);\r\n\r\n// Handles some control keys.\r\n\r\nvar\r\n  Shift: TShiftState;\r\n  EndEdit: Boolean;\r\n  Tree: TBaseVirtualTree;\r\n  NextNode: PVirtualNode;\r\nbegin\r\n  Tree := FLink.FTree;\r\n  case Message.CharCode of\r\n    VK_ESCAPE:\r\n      begin\r\n        Tree.DoCancelEdit;\r\n        Tree.SetFocus;\r\n      end;\r\n    VK_RETURN:\r\n      begin\r\n        EndEdit := not (vsMultiline in FLink.FNode.States);\r\n        if not EndEdit then\r\n        begin\r\n          // If a multiline node is being edited the finish editing only if Ctrl+Enter was pressed,\r\n          // otherwise allow to insert line breaks into the text.\r\n          Shift := KeyDataToShiftState(Message.KeyData);\r\n          EndEdit := ssCtrl in Shift;\r\n        end;\r\n        if EndEdit then\r\n        begin\r\n          Tree := FLink.FTree;\r\n          FLink.FTree.InvalidateNode(FLink.FNode);\r\n          FLink.FTree.DoEndEdit;\r\n          Tree.SetFocus;\r\n        end;\r\n      end;\r\n    VK_UP:\r\n      begin\r\n        if not (vsMultiline in FLink.FNode.States) then\r\n          Message.CharCode := VK_LEFT;\r\n        inherited;\r\n      end;\r\n    VK_DOWN:\r\n      begin\r\n        if not (vsMultiline in FLink.FNode.States) then\r\n          Message.CharCode := VK_RIGHT;\r\n        inherited;\r\n      end;\r\n    VK_TAB:\r\n      begin\r\n        if Tree.IsEditing then\r\n        begin\r\n          Tree.InvalidateNode(FLink.FNode);\r\n          NextNode := Tree.GetNextVisible(FLink.FNode, True);\r\n          Tree.EndEditNode;\r\n          Tree.FocusedNode := NextNode;\r\n          if Tree.CanEdit(Tree.FocusedNode, Tree.FocusedColumn) then\r\n            Tree.DoEdit;\r\n        end;\r\n      end;\r\n    Ord('A'):\r\n      begin\r\n        if Tree.IsEditing and ([ssCtrl] = KeyboardStateToShiftState) then\r\n        begin\r\n          Self.SelectAll();\r\n          Message.CharCode := 0;\r\n        end;\r\n      end;\r\n  else\r\n    inherited;\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TVTEdit.AutoAdjustSize;\r\n\r\n// Changes the size of the edit to accomodate as much as possible of its text within its container window.\r\n// NewChar describes the next character which will be added to the edit's text.\r\n\r\nvar\r\n  DC: HDC;\r\n  Size: TSize;\r\n  LastFont: THandle;\r\n\r\nbegin\r\n  if not (vsMultiline in FLink.FNode.States) and not (toGridExtensions in FLink.FTree.FOptions.FMiscOptions{see issue #252}) then\r\n  begin\r\n    // avoid flicker\r\n    SendMessage(Handle, WM_SETREDRAW, 0, 0);\r\n\r\n    DC := GetDC(Handle);\r\n    LastFont := SelectObject(DC, Font.Handle);\r\n    try\r\n      // Read needed space for the current text.\r\n      GetTextExtentPoint32(DC, PChar(Text+'yG'), Length(Text)+2, Size);\r\n      Inc(Size.cx, 2 * FLink.FTree.FTextMargin);\r\n      Inc(Size.cy, 2 * FLink.FTree.FTextMargin);\r\n      Height := Max(Size.cy, Height); // Ensure a minimum height so that the edit field's content and cursor are displayed correctly. See #159\r\n      // Repaint associated node if the edit becomes smaller.\r\n      if Size.cx < Width then\r\n        FLink.FTree.Invalidate();\r\n\r\n      if FLink.FAlignment = taRightJustify then\r\n        FLink.SetBounds(Rect(Left + Width - Size.cx, Top, Left + Width, Top + Height))\r\n      else\r\n        FLink.SetBounds(Rect(Left, Top, Left + Size.cx, Top + Height));\r\n    finally\r\n      SelectObject(DC, LastFont);\r\n      ReleaseDC(Handle, DC);\r\n      SendMessage(Handle, WM_SETREDRAW, 1, 0);\r\n    end;\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TVTEdit.CreateParams(var Params: TCreateParams);\r\n\r\nbegin\r\n  inherited;\r\n\r\n  // Only with multiline style we can use the text formatting rectangle.\r\n  // This does not harm formatting as single line control, if we don't use word wrapping.\r\n  with Params do\r\n  begin\r\n    Style := Style or ES_MULTILINE;\r\n    if vsMultiline in FLink.FNode.States then\r\n      Style := Style and not (ES_AUTOHSCROLL or WS_HSCROLL) or WS_VSCROLL or ES_AUTOVSCROLL;\r\n    if tsUseThemes in FLink.FTree.FStates then\r\n    begin\r\n      Style := Style and not WS_BORDER;\r\n      ExStyle := ExStyle or WS_EX_CLIENTEDGE;\r\n    end\r\n    else\r\n    begin\r\n      Style := Style or WS_BORDER;\r\n      ExStyle := ExStyle and not WS_EX_CLIENTEDGE;\r\n    end;\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TVTEdit.Release;\r\n\r\nbegin\r\n  if HandleAllocated then\r\n    PostMessage(Handle, CM_RELEASE, 0, 0);\r\nend;\r\n\r\n//----------------- TStringEditLink ------------------------------------------------------------------------------------\r\n\r\nconstructor TStringEditLink.Create;\r\n\r\nbegin\r\n  inherited;\r\n  FEdit := TVTEdit.Create(Self);\r\n  with FEdit do\r\n  begin\r\n    Visible := False;\r\n    BorderStyle := bsSingle;\r\n    AutoSize := False;\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\ndestructor TStringEditLink.Destroy;\r\n\r\nbegin\r\n  if Assigned(FEdit) then\r\n    FEdit.Release;\r\n  inherited;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TStringEditLink.BeginEdit: Boolean;\r\n\r\n// Notifies the edit link that editing can start now. descendants may cancel node edit\r\n// by returning False.\r\n\r\nbegin\r\n  Result := not FStopping;\r\n  if Result then\r\n  begin\r\n    FEdit.Show;\r\n    FEdit.SelectAll;\r\n    FEdit.SetFocus;\r\n    FEdit.AutoAdjustSize;\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TStringEditLink.SetEdit(const Value: TVTEdit);\r\n\r\nbegin\r\n  if Assigned(FEdit) then\r\n    FEdit.Free;\r\n  FEdit := Value;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TStringEditLink.CancelEdit: Boolean;\r\n\r\nbegin\r\n  Result := not FStopping;\r\n  if Result then\r\n  begin\r\n    FStopping := True;\r\n    FEdit.Hide;\r\n    FTree.CancelEditNode;\r\n    FEdit.FLink := nil;\r\n    FEdit.FRefLink := nil;\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TStringEditLink.EndEdit: Boolean;\r\n\r\nbegin\r\n  Result := not FStopping;\r\n  if Result then\r\n  try\r\n    FStopping := True;\r\n    if FEdit.Modified then\r\n      FTree.Text[FNode, FColumn] := FEdit.Text;\r\n    FEdit.Hide;\r\n    FEdit.FLink := nil;\r\n    FEdit.FRefLink := nil;\r\n  except\r\n    FStopping := False;\r\n    raise;\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TStringEditLink.GetBounds: TRect;\r\n\r\nbegin\r\n  Result := FEdit.BoundsRect;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TStringEditLink.PrepareEdit(Tree: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex): Boolean;\r\n\r\n// Retrieves the true text bounds from the owner tree.\r\n\r\nvar\r\n  Text: string;\r\n\r\nbegin\r\n  Result := Tree is TCustomVirtualStringTree;\r\n  if Result then\r\n  begin\r\n    if not Assigned(FEdit) then\r\n    begin\r\n      FEdit := TVTEdit.Create(Self);\r\n      FEdit.Visible := False;\r\n      FEdit.BorderStyle := bsSingle;\r\n      FEdit.AutoSize := False;\r\n    end;\r\n    FTree := Tree as TCustomVirtualStringTree;\r\n    FNode := Node;\r\n    FColumn := Column;\r\n    // Initial size, font and text of the node.\r\n    FTree.GetTextInfo(Node, Column, FEdit.Font, FTextBounds, Text);\r\n    FEdit.Font.Color := clWindowText;\r\n    FEdit.Parent := Tree;\r\n    FEdit.RecreateWnd;\r\n    FEdit.HandleNeeded;\r\n    FEdit.Text := Text;\r\n\r\n    if Column <= NoColumn then\r\n    begin\r\n      FEdit.BidiMode := FTree.BidiMode;\r\n      FAlignment := FTree.Alignment;\r\n    end\r\n    else\r\n    begin\r\n      FEdit.BidiMode := FTree.Header.Columns[Column].BidiMode;\r\n      FAlignment := FTree.Header.Columns[Column].Alignment;\r\n    end;\r\n\r\n    if FEdit.BidiMode <> bdLeftToRight then\r\n      ChangeBidiModeAlignment(FAlignment);\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TStringEditLink.ProcessMessage(var Message: TMessage);\r\n\r\nbegin\r\n  FEdit.WindowProc(Message);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TStringEditLink.SetBounds(R: TRect);\r\n\r\n// Sets the outer bounds of the edit control and the actual edit area in the control.\r\n\r\nvar\r\n  lOffset: Integer;\r\n\r\nbegin\r\n  if not FStopping then\r\n  begin\r\n    // Set the edit's bounds but make sure there's a minimum width and the right border does not\r\n    // extend beyond the parent's left/right border.\r\n    if R.Left < 0 then\r\n      R.Left := 0;\r\n    if R.Right - R.Left < 30 then\r\n    begin\r\n      if FAlignment = taRightJustify then\r\n        R.Left := R.Right - 30\r\n      else\r\n        R.Right := R.Left + 30;\r\n    end;\r\n    if R.Right > FTree.ClientWidth then\r\n      R.Right := FTree.ClientWidth;\r\n    FEdit.BoundsRect := R;\r\n\r\n    // The selected text shall exclude the text margins and be centered vertically.\r\n    // We have to take out the two pixel border of the edit control as well as a one pixel \"edit border\" the\r\n    // control leaves around the (selected) text.\r\n    R := FEdit.ClientRect;\r\n    lOffset := IfThen(vsMultiline in FNode.States, 0, 2);\r\n    if tsUseThemes in FTree.FStates then\r\n      Inc(lOffset);\r\n    InflateRect(R, -FTree.FTextMargin + lOffset, lOffset);\r\n    if not (vsMultiline in FNode.States) then\r\n      OffsetRect(R, 0, FTextBounds.Top - FEdit.Top);\r\n    R.Top := Max(-1, R.Top); // A value smaller than -1 will prevent the edit cursor from being shown by Windows, see issue #159\r\n    R.Left := Max(-1, R.Left);\r\n    SendMessage(FEdit.Handle, EM_SETRECTNP, 0, LPARAM(@R));\r\n  end;\r\nend;\r\n\r\n//----------------- TCustomVirtualString -------------------------------------------------------------------------------\r\n\r\nconstructor TCustomVirtualStringTree.Create(AOwner: TComponent);\r\n\r\nbegin\r\n  inherited;\r\n  FPreviouslySelected := nil;\r\n  FDefaultText := 'Node';\r\n  FInternalDataOffset := AllocateInternalDataArea(SizeOf(Cardinal));\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TCustomVirtualStringTree.GetRenderStartValues(Source: TVSTTextSourceType; var Node: PVirtualNode;\r\n  var NextNodeProc: TGetNextNodeProc);\r\n\r\nbegin\r\n  case Source of\r\n    tstInitialized:\r\n      begin\r\n        Node := GetFirstInitialized;\r\n        NextNodeProc := GetNextInitialized;\r\n      end;\r\n    tstSelected:\r\n      begin\r\n        Node := GetFirstSelected;\r\n        NextNodeProc := GetNextSelected;\r\n      end;\r\n    tstCutCopySet:\r\n      begin\r\n        Node := GetFirstCutCopy;\r\n        NextNodeProc := GetNextCutCopy;\r\n      end;\r\n    tstVisible:\r\n      begin\r\n        Node := GetFirstVisible(nil, True);\r\n        NextNodeProc := GetNextVisible;\r\n      end;\r\n    tstChecked:\r\n      begin\r\n        Node := GetFirstChecked;\r\n        NextNodeProc := GetNextChecked;\r\n      end;\r\n  else // tstAll\r\n    Node := GetFirst;\r\n    NextNodeProc := GetNext;\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TCustomVirtualStringTree.GetDataFromGrid(const AStrings: TStringList;\r\n  const IncludeHeading: Boolean);\r\nvar\r\n  LColIndex   : Integer;\r\n  LStartIndex : Integer;\r\n  LAddString  : string;\r\n  LCellText   : string;\r\n  LChildNode  : PVirtualNode;\r\nbegin\r\n  { Start from the First column. }\r\n  LStartIndex := 0;\r\n\r\n  { Do it for Header first }\r\n  if IncludeHeading then\r\n  begin\r\n    LAddString := EmptyStr;\r\n    for LColIndex := LStartIndex to Pred(Header.Columns.Count) do\r\n    begin\r\n      if (LColIndex > LStartIndex) then\r\n        LAddString := LAddString + ',';\r\n      LAddString := LAddString + AnsiQuotedStr(Header.Columns.Items[LColIndex].Text, '\"');\r\n    end;//for\r\n    AStrings.Add(LAddString);\r\n  end;//if\r\n\r\n  { Loop thru the virtual tree for Data }\r\n  LChildNode := GetFirst;\r\n  while Assigned(LChildNode) do\r\n  begin\r\n    LAddString := EmptyStr;\r\n\r\n    { Read for each column and then populate the text }\r\n    for LColIndex := LStartIndex to Pred(Header.Columns.Count) do\r\n    begin\r\n      LCellText := Text[LChildNode, LColIndex];\r\n      if (LCellText = EmptyStr) then\r\n        LCellText := ' ';\r\n      if (LColIndex > LStartIndex) then\r\n        LAddString := LAddString + ',';\r\n      LAddString := LAddString + AnsiQuotedStr(LCellText, '\"');\r\n    end;//for - Header.Columns.Count\r\n\r\n    AStrings.Add(LAddString);\r\n    LChildNode := LChildNode.NextSibling;\r\n  end;//while Assigned(LChildNode);\r\nend;\r\n\r\nfunction TCustomVirtualStringTree.GetImageText(Node: PVirtualNode;\r\n  Kind: TVTImageKind; Column: TColumnIndex): string;\r\nbegin\r\n  Assert(Assigned(Node), 'Node must not be nil.');\r\n\r\n  if not (vsInitialized in Node.States) then\r\n    InitNode(Node);\r\n  Result := '';\r\n\r\n  DoGetImageText(Node, Kind, Column, Result);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TCustomVirtualStringTree.GetOptions: TCustomStringTreeOptions;\r\n\r\nbegin\r\n  Result := FOptions as TCustomStringTreeOptions;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TCustomVirtualStringTree.GetStaticText(Node: PVirtualNode; Column: TColumnIndex): string;\r\n\r\nvar\r\n  lEventArgs: TVSTGetCellTextEventArgs;\r\n\r\nbegin\r\n  Assert(Assigned(Node), 'Node must not be nil.');\r\n  lEventArgs := TVSTGetCellTextEventArgs.Create(Node, Column);\r\n  DoGetText(lEventArgs);\r\n  Exit(lEventArgs.StaticText);\r\nend;\r\n\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TCustomVirtualStringTree.GetText(Node: PVirtualNode; Column: TColumnIndex): string;\r\n\r\nvar\r\n  lEventArgs: TVSTGetCellTextEventArgs;\r\n\r\nbegin\r\n  Assert(Assigned(Node), 'Node must not be nil.');\r\n  lEventArgs := TVSTGetCellTextEventArgs.Create(Node, Column);\r\n  lEventArgs.CellText := FDefaultText;\r\n  DoGetText(lEventArgs);\r\n  Exit(lEventArgs.CellText)\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TCustomVirtualStringTree.InitializeTextProperties(var PaintInfo: TVTPaintInfo);\r\n\r\n// Initializes default values for customization in PaintNormalText.\r\n\r\nbegin\r\n  with PaintInfo do\r\n  begin\r\n    // Set default font values first.\r\n    Canvas.Font := Font;\r\n    if Enabled then // Es werden sonst nur die Farben verwendet von Font die an  Canvas.Font bergeben wurden\r\n       Canvas.Font.Color := FColors.NodeFontColor\r\n    else\r\n      Canvas.Font.Color := FColors.DisabledColor;\r\n\r\n    if (toHotTrack in FOptions.FPaintOptions) and (Node = FCurrentHotNode) then\r\n    begin\r\n      if not (tsUseExplorerTheme in FStates) then\r\n      begin\r\n        Canvas.Font.Style := Canvas.Font.Style + [fsUnderline];\r\n        Canvas.Font.Color := FColors.HotColor;\r\n      end;\r\n    end;\r\n\r\n    // Change the font color only if the node also is drawn in selected style.\r\n    if poDrawSelection in PaintOptions then\r\n    begin\r\n      if (Column = FFocusedColumn) or (toFullRowSelect in FOptions.FSelectionOptions) then\r\n      begin\r\n        if Node = FDropTargetNode then\r\n        begin\r\n          if ((FLastDropMode = dmOnNode) or (vsSelected in Node.States)) and not\r\n             (tsUseExplorerTheme in FStates) then\r\n            Canvas.Font.Color := FColors.SelectionTextColor;\r\n        end\r\n        else\r\n          if vsSelected in Node.States then\r\n          begin\r\n            if (Focused or (toPopupMode in FOptions.FPaintOptions)) and not\r\n               (tsUseExplorerTheme in FStates) then\r\n            Canvas.Font.Color := FColors.SelectionTextColor;\r\n          end;\r\n      end;\r\n    end;\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TCustomVirtualStringTree.PaintNormalText(var PaintInfo: TVTPaintInfo; TextOutFlags: Integer;\r\n  Text: string);\r\n\r\n// This method is responsible for painting the given text to target canvas (under consideration of the given rectangles).\r\n// The text drawn here is considered as the normal text in a node.\r\n// Note: NodeWidth is the actual width of the text to be drawn. This does not necessarily correspond to the width of\r\n//       the node rectangle. The clipping rectangle comprises the entire node (including tree lines, buttons etc.).\r\n\r\nvar\r\n  TripleWidth: Integer;\r\n  R: TRect;\r\n  DrawFormat: Cardinal;\r\n  Size: TSize;\r\n  Height: Integer;\r\n\r\nbegin\r\n  InitializeTextProperties(PaintInfo);\r\n  with PaintInfo do\r\n  begin\r\n    R := ContentRect;\r\n    Canvas.TextFlags := 0;\r\n    InflateRect(R, -FTextMargin, 0);\r\n\r\n    // Multiline nodes don't need special font handling or text manipulation.\r\n    // Note: multiline support requires the Unicode version of DrawText, which is able to do word breaking.\r\n    //       The emulation in this unit does not support this so we have to use the OS version. However\r\n    //       DrawTextW is only available on NT/2000/XP and up. Hence there is only partial multiline support\r\n    //       for 9x/Me.\r\n    if vsMultiline in Node.States then\r\n    begin\r\n      DoPaintText(Node, Canvas, Column, ttNormal);\r\n      Height := ComputeNodeHeight(Canvas, Node, Column);\r\n      // Disabled node color overrides all other variants.\r\n      if (vsDisabled in Node.States) or not Enabled then\r\n        Canvas.Font.Color := FColors.DisabledColor;\r\n\r\n      // The edit control flag will ensure that no partial line is displayed, that is, only lines\r\n      // which are (vertically) fully visible are drawn.\r\n      DrawFormat := DT_NOPREFIX or DT_WORDBREAK or DT_END_ELLIPSIS or DT_EDITCONTROL or AlignmentToDrawFlag[Alignment];\r\n      if BidiMode <> bdLeftToRight then\r\n        DrawFormat := DrawFormat or DT_RTLREADING;\r\n\r\n      // Center the text vertically if it fits entirely into the content rect.\r\n      if R.Bottom - R.Top > Height then\r\n        InflateRect(R, 0, (Height - R.Bottom - R.Top) div 2);\r\n    end\r\n    else\r\n    begin\r\n      FFontChanged := False;\r\n      TripleWidth := FEllipsisWidth;\r\n      DoPaintText(Node, Canvas, Column, ttNormal);\r\n      if FFontChanged then\r\n      begin\r\n        // If the font has been changed then the ellipsis width must be recalculated.\r\n        TripleWidth := 0;\r\n        // Recalculate also the width of the normal text.\r\n        GetTextExtentPoint32W(Canvas.Handle, PWideChar(Text), Length(Text), Size);\r\n        NodeWidth := Size.cx + 2 * FTextMargin;\r\n      end;\r\n\r\n      // Disabled node color overrides all other variants.\r\n      if (vsDisabled in Node.States) or not Enabled then\r\n        Canvas.Font.Color := FColors.DisabledColor;\r\n\r\n      DrawFormat := DT_NOPREFIX or DT_VCENTER or DT_SINGLELINE;\r\n      if BidiMode <> bdLeftToRight then\r\n        DrawFormat := DrawFormat or DT_RTLREADING;\r\n      // Check if the text must be shortend.\r\n      if (Column > -1) and ((NodeWidth - 2 * FTextMargin) > R.Right - R.Left) then\r\n      begin\r\n        Text := DoShortenString(Canvas, Node, Column, Text, R.Right - R.Left, TripleWidth);\r\n        if Alignment = taRightJustify then\r\n          DrawFormat := DrawFormat or DT_RIGHT\r\n        else\r\n          DrawFormat := DrawFormat or DT_LEFT;\r\n      end\r\n      else\r\n        DrawFormat := DrawFormat or AlignmentToDrawFlag[Alignment];\r\n    end;\r\n\r\n    if Canvas.TextFlags and ETO_OPAQUE = 0 then\r\n      SetBkMode(Canvas.Handle, TRANSPARENT)\r\n    else\r\n      SetBkMode(Canvas.Handle, OPAQUE);\r\n\r\n    DoTextDrawing(PaintInfo, Text, R, DrawFormat);\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TCustomVirtualStringTree.PaintStaticText(const PaintInfo: TVTPaintInfo; TextOutFlags: Integer;\r\n  const Text: string);\r\n\r\n// This method retrives and draws the static text bound to a particular node.\r\n\r\nvar\r\n  R: TRect;\r\n  DrawFormat: Cardinal;\r\n\r\nbegin\r\n  with PaintInfo do\r\n  begin\r\n    Canvas.Font := Font;\r\n    if toFullRowSelect in FOptions.FSelectionOptions then\r\n    begin\r\n      if Node = FDropTargetNode then\r\n      begin\r\n        if (FLastDropMode = dmOnNode) or (vsSelected in Node.States) then\r\n          Canvas.Font.Color := FColors.SelectionTextColor\r\n        else\r\n          Canvas.Font.Color := FColors.NodeFontColor;\r\n      end\r\n      else\r\n        if vsSelected in Node.States then\r\n        begin\r\n          if Focused or (toPopupMode in FOptions.FPaintOptions) then\r\n          Canvas.Font.Color := FColors.SelectionTextColor\r\n          else\r\n            Canvas.Font.Color := FColors.NodeFontColor;\r\n        end;\r\n    end;\r\n\r\n    DrawFormat := DT_NOPREFIX or DT_VCENTER or DT_SINGLELINE;\r\n    Canvas.TextFlags := 0;\r\n    DoPaintText(Node, Canvas, Column, ttStatic);\r\n\r\n    // Disabled node color overrides all other variants.\r\n    if (vsDisabled in Node.States) or not Enabled then\r\n      Canvas.Font.Color := FColors.DisabledColor;\r\n\r\n    R := ContentRect;\r\n    if Alignment = taRightJustify then\r\n      Dec(R.Right, NodeWidth + FTextMargin)\r\n    else\r\n      Inc(R.Left, NodeWidth + FTextMargin);\r\n\r\n    if Canvas.TextFlags and ETO_OPAQUE = 0 then\r\n      SetBkMode(Canvas.Handle, TRANSPARENT)\r\n    else\r\n      SetBkMode(Canvas.Handle, OPAQUE);\r\n    Winapi.Windows.DrawTextW(Canvas.Handle, PWideChar(Text), Length(Text), R, DrawFormat);\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TCustomVirtualStringTree.ReadText(Reader: TReader);\r\n\r\nbegin\r\n  case Reader.NextValue of\r\n    vaLString, vaString:\r\n      SetDefaultText(Reader.ReadString);\r\n  else\r\n    SetDefaultText(Reader.ReadString);\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TCustomVirtualStringTree.SaveToCSVFile(\r\n  const FileNameWithPath: TFileName; const IncludeHeading: Boolean): Boolean;\r\nvar\r\n  LResultList : TStringList;\r\nbegin\r\n  Result := False;\r\n  if (FileNameWithPath = '') then\r\n    Exit;\r\n\r\n  LResultList := TStringList.Create;\r\n  try\r\n    { Get the data from grid. }\r\n    GetDataFromGrid(LResultList, IncludeHeading);\r\n    { Save File to Disk }\r\n    LResultList.SaveToFile(FileNameWithPath);\r\n    Result := True;\r\n  finally\r\n    FreeAndNil(LResultList);\r\n  end;//try-finally\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TCustomVirtualStringTree.SetDefaultText(const Value: string);\r\n\r\nbegin\r\n  if FDefaultText <> Value then\r\n  begin\r\n    FDefaultText := Value;\r\n    if not (csLoading in ComponentState) then\r\n      Invalidate;\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TCustomVirtualStringTree.SetOptions(const Value: TCustomStringTreeOptions);\r\n\r\nbegin\r\n  FOptions.Assign(Value);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TCustomVirtualStringTree.SetText(Node: PVirtualNode; Column: TColumnIndex; const Value: string);\r\n\r\nbegin\r\n  DoNewText(Node, Column, Value);\r\n  InvalidateNode(Node);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TCustomVirtualStringTree.WriteText(Writer: TWriter);\r\n\r\nbegin\r\n  Writer.WriteString(FDefaultText);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TCustomVirtualStringTree.WMSetFont(var Msg: TWMSetFont);\r\n\r\n// Whenever a new font is applied to the tree some default values are determined to avoid frequent\r\n// determination of the same value.\r\n\r\nvar\r\n  MemDC: HDC;\r\n  Run: PVirtualNode;\r\n  TM: TTextMetric;\r\n  Size: TSize;\r\n  Data: PInteger;\r\n\r\nbegin\r\n  inherited;\r\n\r\n  MemDC := CreateCompatibleDC(0);\r\n  try\r\n    SelectObject(MemDC, Msg.Font);\r\n    GetTextMetrics(MemDC, TM);\r\n    FTextHeight := TM.tmHeight;\r\n\r\n    GetTextExtentPoint32W(MemDC, '...', 3, Size);\r\n    FEllipsisWidth := Size.cx;\r\n  finally\r\n    DeleteDC(MemDC);\r\n  end;\r\n\r\n  // Have to reset all node widths.\r\n  Run := FRoot.FirstChild;\r\n  while Assigned(Run) do\r\n  begin\r\n    Data := InternalData(Run);\r\n    if Assigned(Data) then\r\n      Data^ := 0;\r\n    Run := GetNextNoInit(Run);\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TCustomVirtualStringTree.AddChild(Parent: PVirtualNode; UserData: Pointer): PVirtualNode;\r\nvar\r\n  NewNodeText: string;\r\nbegin\r\n  Result := inherited AddChild(Parent, UserData);\r\n  // Restore the prviously restored node if the caption of this node is knwon and no other node was selected\r\n  if (toRestoreSelection in TreeOptions.SelectionOptions) and Assigned(FPreviouslySelected) and Assigned(OnGetText) then\r\n  begin\r\n    // See if this was the previously selected node and restore it in this case\r\n    Self.OnGetText(Self, Result, 0, ttNormal, NewNodeText);\r\n    if FPreviouslySelected.IndexOf(NewNodeText) >= 0 then\r\n    begin\r\n      // Select this node and make sure that the parent node is expanded\r\n      Include(FStates, tsPreviouslySelectedLocked);\r\n      try\r\n        Self.Selected[Result] := True;\r\n      finally\r\n        Exclude(FStates, tsPreviouslySelectedLocked);\r\n      end;\r\n      // if a there is a selected node now, then make sure that it is visible\r\n      if (Self.GetFirstSelected <> nil) and (UpdateCount = 0) then\r\n        Self.ScrollIntoView(Self.GetFirstSelected, True);\r\n    end;\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TCustomVirtualStringTree.AdjustPaintCellRect(var PaintInfo: TVTPaintInfo; var NextNonEmpty: TColumnIndex);\r\n\r\n// In the case a node spans several columns (if enabled) we need to determine how many columns.\r\n// Note: the autospan feature can only be used with left-to-right layout.\r\n\r\nbegin\r\n  if (toAutoSpanColumns in FOptions.FAutoOptions) and FHeader.UseColumns and (PaintInfo.BidiMode = bdLeftToRight) then\r\n    with FHeader.FColumns, PaintInfo do\r\n    begin\r\n      // Start with the directly following column.\r\n      NextNonEmpty := GetNextVisibleColumn(Column);\r\n\r\n      // Auto spanning columns can only be used for left-to-right directionality because the tree is drawn\r\n      // from left to right. For RTL directionality it would be necessary to draw it from right to left.\r\n      // While this could be managed, it becomes impossible when directionality is mixed.\r\n      repeat\r\n        if (NextNonEmpty = InvalidColumn) or not ColumnIsEmpty(Node, NextNonEmpty) or\r\n          (Items[NextNonEmpty].BidiMode <> bdLeftToRight) then\r\n          Break;\r\n        Inc(CellRect.Right, Items[NextNonEmpty].Width);\r\n        NextNonEmpty := GetNextVisibleColumn(NextNonEmpty);\r\n      until False;\r\n    end\r\n    else\r\n      inherited;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TCustomVirtualStringTree.CalculateStaticTextWidth(Canvas: TCanvas; Node: PVirtualNode; Column: TColumnIndex; const Text: string): Integer;\r\n\r\nbegin\r\n  Result := 0;\r\n  if (Length(Text) > 0) and (Alignment <> taCenter) and not (vsMultiline in Node.States) then\r\n  begin\r\n    DoPaintText(Node, Canvas, Column, ttStatic);\r\n\r\n    Inc(Result, DoTextMeasuring(Canvas, Node, Column, Text).cx);\r\n    Inc(Result, FTextMargin);\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TCustomVirtualStringTree.CalculateTextWidth(Canvas: TCanvas; Node: PVirtualNode; Column: TColumnIndex;\r\n  const Text: string): Integer;\r\n\r\n// Determines the width of the given text.\r\n\r\nbegin\r\n  Result := 2 * FTextMargin;\r\n  if Length(Text) > 0 then\r\n  begin\r\n    Canvas.Font := Font;\r\n    DoPaintText(Node, Canvas, Column, ttNormal);\r\n\r\n    Inc(Result, DoTextMeasuring(Canvas, Node, Column, Text).cx);\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TCustomVirtualStringTree.ColumnIsEmpty(Node: PVirtualNode; Column: TColumnIndex): Boolean;\r\n\r\n// For hit tests it is necessary to consider cases where columns are empty and automatic column spanning is enabled.\r\n// This method simply checks the given column's text and if this is empty then the column is considered as being empty.\r\n\r\nbegin\r\n  Result := Length(Text[Node, Column]) = 0;\r\n  // If there is no text then let the ancestor decide if the column is to be considered as being empty\r\n  // (e.g. by asking the application). If there is text then the column is never be considered as being empty.\r\n  if Result then\r\n    Result := inherited ColumnIsEmpty(Node, Column);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TCustomVirtualStringTree.DefineProperties(Filer: TFiler);\r\n\r\nbegin\r\n  inherited;\r\n\r\n  // Delphi still cannot handle wide strings properly while streaming\r\n  Filer.DefineProperty('WideDefaultText', ReadText, WriteText, FDefaultText <> 'Node');\r\n  Filer.DefineProperty('StringOptions', ReadOldStringOptions, nil, False);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\ndestructor TCustomVirtualStringTree.Destroy;\r\nbegin\r\n  FreeAndNil(FPreviouslySelected);\r\n  inherited;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TCustomVirtualStringTree.DoCreateEditor(Node: PVirtualNode; Column: TColumnIndex): IVTEditLink;\r\n\r\nbegin\r\n  Result := inherited DoCreateEditor(Node, Column);\r\n  // Enable generic label editing support if the application does not have own editors.\r\n  if Result = nil then\r\n    Result := TStringEditLink.Create;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TCustomVirtualStringTree.DoGetNodeHint(Node: PVirtualNode; Column: TColumnIndex;\r\n  var LineBreakStyle: TVTTooltipLineBreakStyle): string;\r\n\r\nbegin\r\n  Result := inherited DoGetNodeHint(Node, Column, LineBreakStyle);\r\n  if Assigned(FOnGetHint) then\r\n    FOnGetHint(Self, Node, Column, LineBreakStyle, Result);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TCustomVirtualStringTree.DoGetNodeTooltip(Node: PVirtualNode; Column: TColumnIndex;\r\n  var LineBreakStyle: TVTTooltipLineBreakStyle): string;\r\n\r\nbegin\r\n  Result := inherited DoGetNodeToolTip(Node, Column, LineBreakStyle);\r\n  if Assigned(FOnGetHint) then\r\n    FOnGetHint(Self, Node, Column, LineBreakStyle, Result)\r\n  else\r\n    Result := Text[Node, Column];\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TCustomVirtualStringTree.DoGetNodeExtraWidth(Node: PVirtualNode; Column: TColumnIndex;\r\n  Canvas: TCanvas = nil): Integer;\r\n\r\nbegin\r\n  if not (toShowStaticText in TreeOptions.FStringOptions) then\r\n    Exit(0);\r\n  if Canvas = nil then\r\n    Canvas := Self.Canvas;\r\n  Result := CalculateStaticTextWidth(Canvas, Node, Column, StaticText[Node, Column]);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TCustomVirtualStringTree.DoGetNodeWidth(Node: PVirtualNode; Column: TColumnIndex; Canvas: TCanvas = nil): Integer;\r\n\r\n// Returns the text width of the given node in pixels.\r\n// This width is stored in the node's data member to increase access speed.\r\n\r\nvar\r\n  Data: PInteger;\r\n\r\nbegin\r\n  if (Column > NoColumn) and (vsMultiline in Node.States) then\r\n    Result := FHeader.Columns[Column].Width\r\n  else\r\n  begin\r\n    if Canvas = nil then\r\n      Canvas := Self.Canvas;\r\n\r\n    if Column = FHeader.MainColumn then\r\n    begin\r\n      // Primary column or no columns.\r\n      Data := InternalData(Node);\r\n      if Assigned(Data) then\r\n      begin\r\n        Result := Data^;\r\n        if Result = 0 then\r\n        begin\r\n          Data^ := CalculateTextWidth(Canvas, Node, Column, Text[Node, Column]);\r\n          Result := Data^;\r\n        end;\r\n      end\r\n      else\r\n        Result := 0;\r\n    end\r\n    else\r\n      // any other column\r\n      Result := CalculateTextWidth(Canvas, Node, Column, Text[Node, Column]);\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TCustomVirtualStringTree.DoGetText(var pEventArgs: TVSTGetCellTextEventArgs);\r\n\r\nbegin\r\n  if not (vsInitialized in pEventArgs.Node.States) then\r\n    InitNode(pEventArgs.Node);\r\n  if Assigned(OnGetCellText) then\r\n  begin\r\n    OnGetCellText(Self, pEventArgs);\r\n  end\r\n  else if Assigned(FOnGetText) then begin\r\n    FOnGetText(Self, pEventArgs.Node, pEventArgs.Column, TVSTTextType.ttNormal, pEventArgs.CellText);\r\n    FOnGetText(Self, pEventArgs.Node, pEventArgs.Column, TVSTTextType.ttStatic, pEventArgs.StaticText);\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TCustomVirtualStringTree.DoIncrementalSearch(Node: PVirtualNode; const Text: string): Integer;\r\n\r\n// Since the string tree has access to node text it can do incremental search on its own. Use the event to\r\n// override the default behavior.\r\n\r\nbegin\r\n  Result := 0;\r\n  if Assigned(FOnIncrementalSearch) then\r\n    FOnIncrementalSearch(Self, Node, Text, Result)\r\n  else\r\n    // Default behavior is to match the search string with the start of the node text.\r\n    if Pos(Text, GetText(Node, FocusedColumn)) <> 1 then\r\n      Result := 1;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TCustomVirtualStringTree.DoNewText(Node: PVirtualNode; Column: TColumnIndex; const Text: string);\r\n\r\nbegin\r\n  if Assigned(FOnNewText) then\r\n    FOnNewText(Self, Node, Column, Text);\r\n\r\n  // The width might have changed, so update the scrollbar.\r\n  if FUpdateCount = 0 then\r\n    UpdateHorizontalScrollBar(True);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TCustomVirtualStringTree.DoPaintNode(var PaintInfo: TVTPaintInfo);\r\n\r\n// Main output routine to print the text of the given node using the space provided in PaintInfo.ContentRect.\r\n\r\nvar\r\n  lEventArgs: TVSTGetCellTextEventArgs;\r\n  TextOutFlags: Integer;\r\n\r\nbegin\r\n  // Set a new OnChange event for the canvas' font so we know if the application changes it in the callbacks.\r\n  // This long winded procedure is necessary because font changes (as well as brush and pen changes) are\r\n  // unfortunately not announced via the Canvas.OnChange event.\r\n  RedirectFontChangeEvent(PaintInfo.Canvas);\r\n  try\r\n\r\n    // Determine main text direction as well as other text properties.\r\n    TextOutFlags := ETO_CLIPPED or RTLFlag[PaintInfo.BidiMode <> bdLeftToRight];\r\n    lEventArgs := TVSTGetCellTextEventArgs.Create(PaintInfo.Node, PaintInfo.Column);\r\n    DoGetText(lEventArgs);\r\n\r\n    // Paint the normal text first...\r\n    if not lEventArgs.CellText.IsEmpty then\r\n      PaintNormalText(PaintInfo, TextOutFlags, lEventArgs.CellText);\r\n\r\n    // ... and afterwards the static text if not centered and the node is not multiline enabled.\r\n    if (Alignment <> taCenter) and not (vsMultiline in PaintInfo.Node.States) and (toShowStaticText in TreeOptions.FStringOptions) and not lEventArgs.StaticText.IsEmpty then\r\n      PaintStaticText(PaintInfo, TextOutFlags, lEventArgs.StaticText);\r\n  finally\r\n    RestoreFontChangeEvent(PaintInfo.Canvas);\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\n\r\nprocedure TCustomVirtualStringTree.DoPaintText(Node: PVirtualNode; const Canvas: TCanvas; Column: TColumnIndex;\r\n  TextType: TVSTTextType);\r\n\r\nbegin\r\n  if Assigned(FOnPaintText) then\r\n    FOnPaintText(Self, Canvas, Node, Column, TextType);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TCustomVirtualStringTree.DoShortenString(Canvas: TCanvas; Node: PVirtualNode; Column: TColumnIndex;\r\n  const S: string; Width: Integer; EllipsisWidth: Integer = 0): string;\r\n\r\nvar\r\n  Done: Boolean;\r\n\r\nbegin\r\n  Done := False;\r\n  if Assigned(FOnShortenString) then\r\n    FOnShortenString(Self, Canvas, Node, Column, S, Width, Result, Done);\r\n  if not Done then\r\n    Result := ShortenString(Canvas.Handle, S, Width, EllipsisWidth);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TCustomVirtualStringTree.DoTextDrawing(var PaintInfo: TVTPaintInfo; const Text: string; CellRect: TRect;\r\n  DrawFormat: Cardinal);\r\n\r\nvar\r\n  DefaultDraw: Boolean;\r\n\r\nbegin\r\n  DefaultDraw := True;\r\n  if Assigned(FOnDrawText) then\r\n    FOnDrawText(Self, PaintInfo.Canvas, PaintInfo.Node, PaintInfo.Column, Text, CellRect, DefaultDraw);\r\n  if DefaultDraw then\r\n    Winapi.Windows.DrawTextW(PaintInfo.Canvas.Handle, PWideChar(Text), Length(Text), CellRect, DrawFormat);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TCustomVirtualStringTree.DoTextMeasuring(Canvas: TCanvas; Node: PVirtualNode; Column: TColumnIndex;\r\n  const Text: string): TSize;\r\n\r\nvar\r\n  R: TRect;\r\n  DrawFormat: Integer;\r\n\r\nbegin\r\n  GetTextExtentPoint32W(Canvas.Handle, PWideChar(Text), Length(Text), Result);\r\n  if vsMultiLine in Node.States then\r\n  begin\r\n    DrawFormat := DT_CALCRECT or DT_NOPREFIX or DT_WORDBREAK or DT_END_ELLIPSIS or DT_EDITCONTROL or AlignmentToDrawFlag[Alignment];\r\n    if BidiMode <> bdLeftToRight then\r\n      DrawFormat := DrawFormat or DT_RTLREADING;\r\n\r\n    R := Rect(0, 0, Result.cx, MaxInt);\r\n    Winapi.Windows.DrawTextW(Canvas.Handle, PWideChar(Text), Length(Text), R, DrawFormat);\r\n    Result.cx := R.Right - R.Left;\r\n  end;\r\n  if Assigned(FOnMeasureTextWidth) then\r\n    FOnMeasureTextWidth(Self, Canvas, Node, Column, Text, Result.cx);\r\n  if Assigned(FOnMeasureTextHeight) then\r\n    FOnMeasureTextHeight(Self, Canvas, Node, Column, Text, Result.cy);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TCustomVirtualStringTree.GetOptionsClass: TTreeOptionsClass;\r\n\r\nbegin\r\n  Result := TCustomStringTreeOptions;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TCustomVirtualStringTree.InternalData(Node: PVirtualNode): Pointer;\r\n\r\nbegin\r\n  if (Node = FRoot) or (Node = nil) or (FInternalDataOffset = 0) then\r\n    Result := nil\r\n  else\r\n    Result := PByte(Node) + Self.NodeDataSize + FInternalDataOffset;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TCustomVirtualStringTree.MainColumnChanged;\r\n\r\nvar\r\n  Run: PVirtualNode;\r\n  Data: PInteger;\r\n\r\nbegin\r\n  inherited;\r\n\r\n  // Have to reset all node widths.\r\n  Run := FRoot.FirstChild;\r\n  while Assigned(Run) do\r\n  begin\r\n    Data := InternalData(Run);\r\n    if Assigned(Data) then\r\n      Data^ := 0;\r\n    Run := GetNextNoInit(Run);\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TCustomVirtualStringTree.ReadChunk(Stream: TStream; Version: Integer; Node: PVirtualNode; ChunkType,\r\n  ChunkSize: Integer): Boolean;\r\n\r\n// read in the caption chunk if there is one\r\n\r\nvar\r\n  NewText: string;\r\n\r\nbegin\r\n  case ChunkType of\r\n    CaptionChunk:\r\n      begin\r\n        NewText := '';\r\n        if ChunkSize > 0 then\r\n        begin\r\n          SetLength(NewText, ChunkSize div 2);\r\n          Stream.Read(PWideChar(NewText)^, ChunkSize);\r\n        end;\r\n        // Do a new text event regardless of the caption content to allow removing the default string.\r\n        Text[Node, FHeader.MainColumn] := NewText;\r\n        Result := True;\r\n      end;\r\n  else\r\n    Result := inherited ReadChunk(Stream, Version, Node, ChunkType, ChunkSize);\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\ntype\r\n  TOldVTStringOption = (soSaveCaptions, soShowStaticText);\r\n\r\nprocedure TCustomVirtualStringTree.ReadOldStringOptions(Reader: TReader);\r\n\r\n// Migration helper routine to silently convert forms containing the old tree options member into the new\r\n// sub-options structure.\r\n\r\nvar\r\n  OldOption: TOldVTStringOption;\r\n  EnumName: string;\r\n\r\nbegin\r\n  // If we are at design time currently then let the designer know we changed something.\r\n  UpdateDesigner;\r\n\r\n  // It should never happen at this place that there is something different than the old set.\r\n  if Reader.ReadValue = vaSet then\r\n    with TreeOptions do\r\n    begin\r\n      // Remove all default values set by the constructor.\r\n      StringOptions := [];\r\n\r\n      while True do\r\n      begin\r\n        // Sets are stored with their members as simple strings. Read them one by one and map them to the new option\r\n        // in the correct sub-option set.\r\n        EnumName := Reader.ReadStr;\r\n        if EnumName = '' then\r\n          Break;\r\n        OldOption := TOldVTStringOption(GetEnumValue(TypeInfo(TOldVTStringOption), EnumName));\r\n        case OldOption of\r\n          soSaveCaptions:\r\n            StringOptions := FStringOptions + [toSaveCaptions];\r\n          soShowStaticText:\r\n            StringOptions := FStringOptions + [toShowStaticText];\r\n        end;\r\n      end;\r\n    end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TCustomVirtualStringTree.RenderOLEData(const FormatEtcIn: TFormatEtc; out Medium: TStgMedium;\r\n  ForClipboard: Boolean): HResult;\r\n\r\n// Returns string expressions of all currently selected nodes in the Medium structure.\r\n\r\nbegin\r\n  Result := inherited RenderOLEData(FormatEtcIn, Medium, ForClipboard);\r\n  if Failed(Result) then\r\n  try\r\n    if ForClipboard then\r\n      Medium.hGlobal := ContentToClipboard(FormatEtcIn.cfFormat, tstCutCopySet)\r\n    else\r\n      Medium.hGlobal := ContentToClipboard(FormatEtcIn.cfFormat, tstSelected);\r\n\r\n    // Fill rest of the Medium structure if rendering went fine.\r\n    if Medium.hGlobal <> 0 then\r\n    begin\r\n      Medium.tymed := TYMED_HGLOBAL;\r\n      Medium.unkForRelease := nil;\r\n\r\n      Result := S_OK;\r\n    end;\r\n  except\r\n    Result := E_FAIL;\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TCustomVirtualStringTree.WriteChunks(Stream: TStream; Node: PVirtualNode);\r\n\r\n// Adds another sibling chunk for Node storing the label if the node is initialized.\r\n// Note: If the application stores a node's caption in the node's data member (which will be quite common) and needs to\r\n//       store more node specific data then it should use the OnSaveNode event rather than the caption autosave function\r\n//       (take out soSaveCaption from StringOptions). Otherwise the caption is unnecessarily stored twice.\r\n\r\nvar\r\n  Header: TChunkHeader;\r\n  S: string;\r\n  Len: Integer;\r\n\r\nbegin\r\n  inherited;\r\n  if (toSaveCaptions in TreeOptions.FStringOptions) and (Node <> FRoot) and\r\n    (vsInitialized in Node.States) then\r\n    with Stream do\r\n    begin\r\n      // Read the node's caption (primary column only).\r\n      S := Text[Node, FHeader.MainColumn];\r\n      Len := 2 * Length(S);\r\n      if Len > 0 then\r\n      begin\r\n        // Write a new sub chunk.\r\n        Header.ChunkType := CaptionChunk;\r\n        Header.ChunkSize := Len;\r\n        Write(Header, SizeOf(Header));\r\n        Write(PWideChar(S)^, Len);\r\n      end;\r\n    end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TCustomVirtualStringTree.ComputeNodeHeight(Canvas: TCanvas; Node: PVirtualNode; Column: TColumnIndex;\r\n S: string): Integer;\r\n\r\n// Default node height calculation for multi line nodes. This method can be used by the application to delegate the\r\n// computation to the string tree.\r\n// Canvas is used to compute that value by using its current font settings.\r\n// Node and Column describe the cell to be used for the computation.\r\n// S is the string for which the height must be computed. If this string is empty the cell text is used instead.\r\n\r\nvar\r\n  DrawFormat: Cardinal;\r\n  BidiMode: TBidiMode;\r\n  Alignment: TAlignment;\r\n  PaintInfo: TVTPaintInfo;\r\n  Dummy: TColumnIndex;\r\n  LineImage: TLineImage;\r\nbegin\r\n  if Length(S) = 0 then\r\n    S := Text[Node, Column];\r\n\r\n  if Column <= NoColumn then\r\n  begin\r\n    BidiMode := Self.BidiMode;\r\n    Alignment := Self.Alignment;\r\n  end\r\n  else\r\n  begin\r\n    BidiMode := Header.Columns[Column].BidiMode;\r\n    Alignment := Header.Columns[Column].Alignment;\r\n  end;\r\n\r\n  if BidiMode <> bdLeftToRight then\r\n    ChangeBidiModeAlignment(Alignment);\r\n\r\n  if vsMultiline in Node.States then\r\n    DrawFormat := DT_NOPREFIX or DT_TOP or DT_WORDBREAK or DT_EDITCONTROL\r\n  else\r\n    DrawFormat := DT_NOPREFIX or DT_VCENTER or DT_SINGLELINE;\r\n  DrawFormat := DrawFormat or DT_CALCRECT;\r\n\r\n  // Allow for autospanning.\r\n  PaintInfo.Node := Node;\r\n  PaintInfo.BidiMode := BidiMode;\r\n  PaintInfo.Column := Column;\r\n  PaintInfo.CellRect := Rect(0, 0, 0, 0);\r\n  if Column > NoColumn then\r\n  begin\r\n    PaintInfo.CellRect.Right := FHeader.Columns[Column].Width - FTextMargin;\r\n    PaintInfo.CellRect.Left := FTextMargin + FMargin;\r\n    if Column = Header.MainColumn then\r\n    begin\r\n      if toFixedIndent in FOptions.FPaintOptions then\r\n        SetLength(LineImage, 1)\r\n      else\r\n        DetermineLineImageAndSelectLevel(Node, LineImage);\r\n    Inc(PaintInfo.CellRect.Left, Length(LineImage) * Integer(Indent));\r\n    end;\r\n  end\r\n  else\r\n    PaintInfo.CellRect.Right := ClientWidth;\r\n  AdjustPaintCellRect(PaintInfo, Dummy);\r\n\r\n  if BidiMode <> bdLeftToRight then\r\n    DrawFormat := DrawFormat or DT_RIGHT or DT_RTLREADING\r\n  else\r\n    DrawFormat := DrawFormat or DT_LEFT;\r\n  Winapi.Windows.DrawTextW(Canvas.Handle, PWideChar(S), Length(S), PaintInfo.CellRect, DrawFormat);\r\n  Result := PaintInfo.CellRect.Bottom - PaintInfo.CellRect.Top;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TCustomVirtualStringTree.ContentToClipboard(Format: Word; Source: TVSTTextSourceType): HGLOBAL;\r\n\r\n// This method constructs a shareable memory object filled with string data in the required format. Supported are:\r\n// CF_TEXT - plain ANSI text (Unicode text is converted using the user's current locale)\r\n// CF_UNICODETEXT - plain Unicode text\r\n// CF_CSV - comma separated plain ANSI text\r\n// CF_VRTF + CF_RTFNOOBS - rich text (plain ANSI)\r\n// CF_HTML - HTML text encoded using UTF-8\r\n//\r\n// Result is the handle to a globally allocated memory block which can directly be used for clipboard and drag'n drop\r\n// transfers. The caller is responsible for freeing the memory. If for some reason the content could not be rendered\r\n// the Result is 0.\r\n\r\nbegin\r\n  Result := VirtualTrees.Export.ContentToClipboard(Self, Format, Source);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TCustomVirtualStringTree.ContentToHTML(Source: TVSTTextSourceType; const Caption: string = ''): String;\r\n\r\n// Renders the current tree content (depending on Source) as HTML text encoded in UTF-8.\r\n// If Caption is not empty then it is used to create and fill the header for the table built here.\r\n// Based on ideas and code from Frank van den Bergh and Andreas Hrstemeier.\r\n\r\nbegin\r\n  Result := VirtualTrees.Export.ContentToHTML(Self, Source, Caption);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TCustomVirtualStringTree.CanExportNode(Node: PVirtualNode): Boolean;\r\n\r\nbegin\r\n  case FOptions.ExportMode of\r\n    emChecked:\r\n      Result := Node.CheckState = csCheckedNormal;\r\n    emUnchecked:\r\n      Result := Node.CheckState = csUncheckedNormal;\r\n    emVisibleDueToExpansion: //Do not export nodes that are not visible because their parent is not expanded\r\n      Result := not Assigned(Node.Parent) or Self.Expanded[Node.Parent];\r\n    emSelected: // export selected nodes only\r\n      Result := Selected[Node];\r\n    else\r\n      Result := True;\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TCustomVirtualStringTree.AddToSelection(Node: PVirtualNode);\r\nvar\r\n  lSelectedNodeCaption: string;\r\nbegin\r\n  inherited;\r\n  if (toRestoreSelection in TreeOptions.SelectionOptions) and Assigned(Self.OnGetText) and Self.Selected[Node] and not (tsPreviouslySelectedLocked in FStates) then\r\n  begin\r\n    if not Assigned(FPreviouslySelected) then\r\n    begin\r\n      FPreviouslySelected := TStringList.Create();\r\n      FPreviouslySelected.Duplicates := dupIgnore;\r\n      FPreviouslySelected.Sorted := True; //Improves performance, required to use Find()\r\n      FPreviouslySelected.CaseSensitive := False;\r\n    end;\r\n    if Self.SelectedCount = 1 then\r\n      FPreviouslySelected.Clear();\r\n    Self.OnGetText(Self, Node, 0, ttNormal, lSelectedNodeCaption);\r\n    FPreviouslySelected.Add(lSelectedNodeCaption);\r\n  end;//if\r\n  UpdateNextNodeToSelect(Node);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TCustomVirtualStringTree.RemoveFromSelection(Node: PVirtualNode);\r\nvar\r\n  lSelectedNodeCaption: string;\r\n  lIndex: Integer;\r\nbegin\r\n  inherited;\r\n  if (toRestoreSelection in TreeOptions.SelectionOptions) and Assigned(FPreviouslySelected) and not Self.Selected[Node] then\r\n  begin\r\n    if Self.SelectedCount = 0 then\r\n      FPreviouslySelected.Clear()\r\n    else\r\n    begin\r\n      Self.OnGetText(Self, Node, 0, ttNormal, lSelectedNodeCaption);\r\n      if FPreviouslySelected.Find(lSelectedNodeCaption, lIndex) then\r\n        FPreviouslySelected.Delete(lIndex);\r\n    end;//else\r\n  end;//if\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TCustomVirtualStringTree.ContentToRTF(Source: TVSTTextSourceType): RawByteString;\r\n\r\n// Renders the current tree content (depending on Source) as RTF (rich text).\r\n// Based on ideas and code from Frank van den Bergh and Andreas Hrstemeier.\r\n\r\nbegin\r\n  Result := VirtualTrees.Export.ContentToRTF(Self, Source);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TCustomVirtualStringTree.ContentToCustom(Source: TVSTTextSourceType);\r\n\r\n// Generic export procedure which polls the application at every stage of the export.\r\n\r\nbegin\r\n  VirtualTrees.Export.ContentToCustom(Self, Source);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TCustomVirtualStringTree.ContentToText(Source: TVSTTextSourceType; Separator: Char): String;\r\n\r\nbegin\r\n  Result := ContentToText(Source, string(Separator));\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\n\r\nfunction TCustomVirtualStringTree.ContentToUnicode(Source: TVSTTextSourceType; Separator: Char): string;\r\n\r\nbegin\r\n  Result := Self.ContentToText(Source, string(Separator));\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TCustomVirtualStringTree.ContentToText(Source: TVSTTextSourceType; const Separator: string): string;\r\n\r\n// Renders the current tree content (depending on Source) as Unicode text.\r\n// If an entry contains the separator char then it is wrapped with double quotation marks.\r\n\r\nbegin\r\n  Result := VirtualTrees.Export.ContentToUnicodeString(Self, Source, Separator);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TCustomVirtualStringTree.GetTextInfo(Node: PVirtualNode; Column: TColumnIndex; const AFont: TFont; var R: TRect;\r\n  var Text: string);\r\n\r\n// Returns the font, the text and its bounding rectangle to the caller. R is returned as the closest\r\n// bounding rectangle around Text.\r\n\r\nvar\r\n  NewHeight: Integer;\r\n  TM: TTextMetric;\r\n\r\nbegin\r\n  // Get default font and initialize the other parameters.\r\n  inherited GetTextInfo(Node, Column, AFont, R, Text);\r\n\r\n  Canvas.Font := AFont;\r\n\r\n  FFontChanged := False;\r\n  RedirectFontChangeEvent(Canvas);\r\n  DoPaintText(Node, Canvas, Column, ttNormal);\r\n  if FFontChanged then\r\n  begin\r\n    AFont.Assign(Canvas.Font);\r\n    GetTextMetrics(Canvas.Handle, TM);\r\n    NewHeight := TM.tmHeight;\r\n  end\r\n  else // Otherwise the correct font is already there and we only need to set the correct height.\r\n    NewHeight := FTextHeight;\r\n  RestoreFontChangeEvent(Canvas);\r\n\r\n  // Alignment to the actual text.\r\n  Text := Self.Text[Node, Column];\r\n  R := GetDisplayRect(Node, Column, True, not (vsMultiline in Node.States));\r\n  if toShowHorzGridLines in TreeOptions.PaintOptions then\r\n    Dec(R.Bottom);\r\n  InflateRect(R, 0, -(R.Bottom - R.Top - NewHeight) div 2);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TCustomVirtualStringTree.InvalidateNode(Node: PVirtualNode): TRect;\r\n\r\nvar\r\n  Data: PInteger;\r\n\r\nbegin\r\n  Result := inherited InvalidateNode(Node);\r\n  // Reset node width so changed text attributes are applied correctly.\r\n  if Assigned(Node) then\r\n  begin\r\n    Data := InternalData(Node);\r\n    if Assigned(Data) then\r\n      Data^ := 0;\r\n    // Reset height measured flag too to cause a re-issue of the OnMeasureItem event.\r\n    Exclude(Node.States, vsHeightMeasured);\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TCustomVirtualStringTree.Path(Node: PVirtualNode; Column: TColumnIndex; Delimiter: Char): string;\r\n\r\n// Constructs a string containing the node and all its parents. The last character in the returned path is always the\r\n// given delimiter.\r\n\r\nbegin\r\n  if (Node = nil) or (Node = FRoot) then\r\n    Result := Delimiter\r\n  else\r\n  begin\r\n    Result := '';\r\n    while Node <> FRoot do\r\n    begin\r\n      Result := Text[Node, Column] + Delimiter + Result;\r\n      Node := Node.Parent;\r\n    end;\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TCustomVirtualStringTree.ResetInternalData(Node: PVirtualNode; Recursive: Boolean);\r\n\r\nvar\r\n  Data: PInteger;\r\n  Run: PVirtualNode;\r\n\r\nbegin\r\n  // Reset node width so changed text attributes are applied correctly.\r\n  if Assigned(Node) and (Node <> FRoot) then\r\n  begin\r\n    Data := InternalData(Node);\r\n    if Assigned(Data) then\r\n      Data^ := 0;\r\n\r\n    Exclude(Node.States, vsHeightMeasured);\r\n  end;\r\n\r\n  if Assigned(Node) then\r\n    Run := Node.FirstChild\r\n  else\r\n    Run := FRoot.FirstChild;\r\n\r\n  while Assigned(Run) do\r\n  begin\r\n    ResetInternalData(Run, Recursive);\r\n    Run := Run.NextSibling;\r\n  end;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TCustomVirtualStringTree.ReinitNode(Node: PVirtualNode; Recursive: Boolean);\r\n\r\nbegin\r\n  inherited;\r\n\r\n  ResetInternalData(Node, False);  // False because there already is a loop inside ReinitNode\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TCustomVirtualStringTree.SetChildCount(Node: PVirtualNode; NewChildCount: Cardinal);\r\n\r\nbegin\r\n  inherited;\r\n\r\n  // See comment at the end of TBaseVirtualTree.SetChildCount\r\n  //ReinitChildren(Node, True);\r\n\r\n  ResetInternalData(Node, True);\r\nend;\r\n\r\n//----------------- TVirtualStringTree ---------------------------------------------------------------------------------\r\n\r\n\r\nfunction TVirtualStringTree.GetOptions: TStringTreeOptions;\r\n\r\nbegin\r\n  Result := FOptions as TStringTreeOptions;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TVirtualStringTree.SetOptions(const Value: TStringTreeOptions);\r\n\r\nbegin\r\n  FOptions.Assign(Value);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TVirtualStringTree.GetOptionsClass: TTreeOptionsClass;\r\n\r\nbegin\r\n  Result := TStringTreeOptions;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TCustomVirtualDrawTree.DoGetCellContentMargin(Node: PVirtualNode; Column: TColumnIndex;\r\n  CellContentMarginType: TVTCellContentMarginType = ccmtAllSides; Canvas: TCanvas = nil): TPoint;\r\n\r\nbegin\r\n  Result := Point(0, 0);\r\n  if Canvas = nil then\r\n    Canvas := Self.Canvas;\r\n\r\n  if Assigned(FOnGetCellContentMargin) then\r\n    FOnGetCellContentMargin(Self, Canvas, Node, Column, CellContentMarginType, Result);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TCustomVirtualDrawTree.DoGetNodeWidth(Node: PVirtualNode; Column: TColumnIndex; Canvas: TCanvas = nil): Integer;\r\n\r\nbegin\r\n  Result := 2 * FTextMargin;\r\n  if Canvas = nil then\r\n    Canvas := Self.Canvas;\r\n\r\n  if Assigned(FOnGetNodeWidth) then\r\n    FOnGetNodeWidth(Self, Canvas, Node, Column, Result);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TCustomVirtualDrawTree.DoPaintNode(var PaintInfo: TVTPaintInfo);\r\n\r\nbegin\r\n  if Assigned(FOnDrawNode) then\r\n    FOnDrawNode(Self, PaintInfo);\r\nend;\r\n\r\nfunction TCustomVirtualDrawTree.GetDefaultHintKind: TVTHintKind;\r\n\r\nbegin\r\n  Result := vhkOwnerDraw;\r\nend;\r\n\r\n//----------------- TVirtualDrawTree -----------------------------------------------------------------------------------\r\n\r\nfunction TVirtualDrawTree.GetOptions: TVirtualTreeOptions;\r\n\r\nbegin\r\n  Result := FOptions as TVirtualTreeOptions;\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nprocedure TVirtualDrawTree.SetOptions(const Value: TVirtualTreeOptions);\r\n\r\nbegin\r\n  FOptions.Assign(Value);\r\nend;\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\nfunction TVirtualDrawTree.GetOptionsClass: TTreeOptionsClass;\r\n\r\nbegin\r\n  Result := TVirtualTreeOptions;\r\nend;\r\n\r\n\r\n//----------------------------------------------------------------------------------------------------------------------\r\n\r\n{ PVirtualNodeHelper }\r\n\r\nfunction TVirtualNode.GetData(): Pointer;\r\n\r\n// Returns the associated data converted to the class given in the generic part of the function.\r\n\r\nbegin\r\n  Result := @Self.Data;\r\n  Include(States, vsOnFreeNodeCallRequired);\r\nend;\r\n\r\nfunction TVirtualNode.GetData: T;\r\n\r\n// Returns the associated data converted to the class given in the generic part of the function.\r\n\r\nbegin\r\n  Result := T(Pointer((PByte(@(Self.Data))))^);\r\n  Include(States, vsOnFreeNodeCallRequired);\r\nend;\r\n\r\nfunction TVirtualNode.IsAssigned: Boolean;\r\n\r\n// Returns False if this node is nil, True otherwise\r\n\r\nbegin\r\n  Exit(@Self <> nil);\r\nend;\r\n\r\nprocedure TVirtualNode.SetData(pUserData: Pointer);\r\n\r\n\r\n  // Can be used to set user data of a PVirtualNode with the size of a pointer, useful for setting\r\n  // A pointer to a record or a reference to a class instance.\r\n\r\nvar\r\n  NodeData: ^Pointer;\r\nbegin\r\n  NodeData := @Self.Data;\r\n  NodeData^ := pUserData;\r\n  Include(Self.States, vsOnFreeNodeCallRequired);\r\nend;\r\n\r\nprocedure TVirtualNode.SetData(const pUserData: IInterface);\r\n\r\n\r\n  // Can be used to set user data of a PVirtualNode to a class instance,\r\n  // will take care about reference counting.\r\n\r\nbegin\r\n  pUserData._AddRef();\r\n  SetData(Pointer(pUserData));\r\n  Include(Self.States, vsReleaseCallOnUserDataRequired);\r\nend;\r\n\r\nprocedure TVirtualNode.SetData(pUserData: T);\r\n\r\nbegin\r\n  SetData(Pointer(pUserData));\r\nend;\r\n\r\n{ TVTImageInfo }\r\n\r\nfunction TVTImageInfo.Equals(const pImageInfo2: TVTImageInfo): Boolean;\r\n\r\n  // Returns true if both images are the same, does not regard Ghosted and position.\r\n\r\nbegin\r\n  Result := (Self.Index = pImageInfo2.Index) and (Self.Images = pImageInfo2.Images);\r\nend;\r\n\r\n{ TVSTGetCellTextEventArgs }\r\n\r\nconstructor TVSTGetCellTextEventArgs.Create(pNode: PVirtualNode; pColumn: TColumnIndex; pExportType: TVTExportType);\r\nbegin\r\n  Self.Node := pNode;\r\n  Self.Column := pColumn;\r\n  Self.ExportType := pExportType;\r\nend;\r\n\r\ninitialization\r\n  // This watcher is used whenever a global structure could be modified by more than one thread.\r\n  Watcher := TCriticalSection.Create;\r\n\r\nfinalization\r\n  if Initialized then\r\n    FinalizeGlobalStructures;\r\n\r\n  Watcher.Free;\r\n  Watcher := nil;\r\n\r\nend.\r\n"
  },
  {
    "path": "GdiPlus/GdiPlus.pas",
    "content": "unit GdiPlus;\r\n\r\n{ Delphi GDI+ Library for use with Delphi 2009 or later.\r\n  Copyright (C) 2009 by Erik van Bilsen.\r\n  Email: erik@bilsen.com\r\n  Website: www.bilsen.com/gdiplus\r\n\r\nLicense in plain English:\r\n\r\n1. I don't promise that this software works. (But if you find any bugs,\r\n   please let me know!)\r\n2. You can use this software for whatever you want. You don't have to pay me.\r\n3. You may not pretend that you wrote this software. If you use it in a program,\r\n   you must acknowledge somewhere in your documentation that you've used this\r\n   code.\r\n\r\nIn legalese:\r\n\r\nThe author makes NO WARRANTY or representation, either express or implied,\r\nwith respect to this software, its quality, accuracy, merchantability, or\r\nfitness for a particular purpose.  This software is provided \"AS IS\", and you,\r\nits user, assume the entire risk as to its quality and accuracy.\r\n\r\nPermission is hereby granted to use, copy, modify, and distribute this\r\nsoftware (or portions thereof) for any purpose, without fee, subject to these\r\nconditions:\r\n(1) If any part of the source code for this software is distributed, then the\r\nLicense.txt file must be included, with this copyright and no-warranty notice\r\nunaltered; and any additions, deletions, or changes to the original files\r\nmust be clearly indicated in accompanying documentation.\r\n(2) If only executable code is distributed, then the accompanying\r\ndocumentation must state that \"this software is based in part on the Delphi\r\nGDI+ library by Erik van Bilsen\".\r\n(3) Permission for use of this software is granted only if the user accepts\r\nfull responsibility for any undesirable consequences; the author accepts\r\nNO LIABILITY for damages of any kind.\r\n\r\nVersion history\r\n===============\r\n\r\nVersion 1.2:\r\n-Minor bug fixes\r\n-The biggest complaint with version 1.0 was about name conflicts (for example\r\n between Graphics.TBitmap and GdiPlus.TBitmap). In this version, all GDI+ types\r\n start with a \"TGP\" or \"IGP\" prefix now to avoid these collisions (for example\r\n IGPBitmap and TGPBitmap). The previous type names are still available if you\r\n define the GDIP_ALIAS conditional define in your project, although usage of\r\n these names is discouraged now.\r\n\r\nVersion 1.1:\r\nNever existed (to avoid confusion with Microsofts GDI+ version 1.1)\r\n\r\nVersion 1.0:\r\nInitial version }\r\n\r\n{$ALIGN 8}\r\n{$MINENUMSIZE 4}\r\n\r\ninterface\r\n\r\nuses\r\n  Windows,\r\n  Math,\r\n  ActiveX,\r\n  SysUtils,\r\n  System.UITypes,\r\n  Generics.Collections;\r\n\r\n{$IFDEF GDIP_0110}\r\nconst\r\n  GDIPVER = $0110;\r\n\r\n{$R GdiPlus11.res}\r\n{$ELSE}\r\nconst\r\n  GDIPVER = $0100;\r\n{$ENDIF}\r\n\r\nconst\r\n  GdiPlusDll = 'gdiplus.dll';\r\n\r\ntype\r\n  PUInt16 = ^UInt16;\r\n  PLangID = ^LangID;\r\n  TColorRef = Integer;\r\n\r\n{$REGION 'Support classes'}\r\ntype\r\n  IGPArray = interface\r\n  ['{E80D8F50-F3E5-4E5F-8E07-FC4535EA90EA}']\r\n    { Property access methods }\r\n    function GetCount: Integer;\r\n    procedure SetCount(const Value: Integer);\r\n    function GetItem(const Index: Integer): T;\r\n    procedure SetItem(const Index: Integer; const Value: T);\r\n    function GetItemPtr: Pointer;\r\n\r\n    { Methods }\r\n    function GetEnumerator: TEnumerator;\r\n\r\n    { Properties }\r\n    property Count: Integer read GetCount write SetCount;\r\n    property Items[const Index: Integer]: T read GetItem write SetItem; default;\r\n    property ItemPtr: Pointer read GetItemPtr;\r\n  end;\r\n\r\ntype\r\n  TGPArray = class(TInterfacedObject, IGPArray)\r\n  public\r\n    type\r\n      TEnumerator = class(TEnumerator)\r\n      private\r\n        FArray: TGPArray;\r\n        FIndex: Integer;\r\n        function GetCurrent: T;\r\n      protected\r\n        function DoGetCurrent: T; override;\r\n        function DoMoveNext: Boolean; override;\r\n      public\r\n        constructor Create(const AArray: TGPArray);\r\n        property Current: T read GetCurrent;\r\n        function MoveNext: Boolean;\r\n      end;\r\n  private\r\n    FItems: array of T;\r\n  private\r\n    { IGPArray }\r\n    function GetCount: Integer;\r\n    procedure SetCount(const Value: Integer);\r\n    function GetItem(const Index: Integer): T;\r\n    procedure SetItem(const Index: Integer; const Value: T);\r\n    function GetItemPtr: Pointer;\r\n    function GetEnumerator: TEnumerator;\r\n  public\r\n    constructor Create(const Count: Integer);\r\n  end;\r\n\r\ntype\r\n  IGPBuffer = interface\r\n  ['{F252CE33-4F54-4B76-9261-2344D1BCD19C}']\r\n    { Property access methods }\r\n    function GetData: Pointer;\r\n    function GetSize: Cardinal;\r\n\r\n    { Properties }\r\n    property Data: Pointer read GetData;\r\n    property Size: Cardinal read GetSize;\r\n  end;\r\n\r\ntype\r\n  TGPBuffer = class(TInterfacedObject, IGPBuffer)\r\n  private\r\n    FData: Pointer;\r\n    FSize: Cardinal;\r\n  private\r\n    { IRegionData }\r\n    function GetData: Pointer;\r\n    function GetSize: Cardinal;\r\n  public\r\n    constructor Create(const Data: Pointer; const Size: Cardinal);\r\n    destructor Destroy; override;\r\n  end;\r\n{$ENDREGION 'Support classes'}\r\n\r\n{$REGION 'GdiplusMem.h'}\r\n(*****************************************************************************\r\n * GdiplusMem.h\r\n * GDI+ Private Memory Management APIs\r\n *****************************************************************************)\r\n\r\n//----------------------------------------------------------------------------\r\n// Memory Allocation APIs\r\n//----------------------------------------------------------------------------\r\n\r\nfunction GdipAlloc(Size: Integer): Pointer; stdcall; external GdiPlusDll;\r\nprocedure GdipFree(Ptr: Pointer); stdcall; external GdiPlusDll;\r\n{$ENDREGION 'GdiplusMem.h'}\r\n\r\n{$REGION 'GdiplusBase.h'}\r\n(*****************************************************************************\r\n * GdiplusBase.h\r\n * GDI+ base memory allocation class\r\n *****************************************************************************)\r\n\r\ntype\r\n  GpNativeHandle = Pointer;\r\n\r\ntype\r\n  IGdiplusBase = interface\r\n  ['{24A5D3F5-4A9B-42A2-9F60-20825E2740F5}']\r\n    { Property access methods }\r\n    function GetNativeHandle: GpNativeHandle;\r\n    procedure SetNativeHandle(const Value: GpNativeHandle);\r\n\r\n    { Properties }\r\n    property NativeHandle: GpNativeHandle read GetNativeHandle write SetNativeHandle;\r\n  end;\r\n\r\n  TGdiplusBase = class(TInterfacedObject, IGdiPlusBase)\r\n  protected\r\n    FNativeHandle: GpNativeHandle;\r\n  private\r\n    { IGdiPlusBase }\r\n    function GetNativeHandle: GpNativeHandle;\r\n    procedure SetNativeHandle(const Value: GpNativeHandle);\r\n  private\r\n    constructor Create;\r\n  public\r\n    class function NewInstance: TObject; override;\r\n    procedure FreeInstance; override;\r\n  end;\r\n{$ENDREGION 'GdiplusBase.h'}\r\n\r\n{$REGION 'GdiplusEnums.h'}\r\n(*****************************************************************************\r\n * GdiplusEnums.h\r\n * GDI+ Enumeration Types\r\n *****************************************************************************)\r\n\r\n//--------------------------------------------------------------------------\r\n// Default bezier flattening tolerance in device pixels.\r\n//--------------------------------------------------------------------------\r\n\r\nconst\r\n  FlatnessDefault = 1.0 / 4.0;\r\n\r\n//--------------------------------------------------------------------------\r\n// Graphics and Container State cookies\r\n//--------------------------------------------------------------------------\r\n\r\ntype\r\n  TGPGraphicsState = UINT;\r\n  PGPGraphicsState = ^TGPGraphicsState;\r\n  TGPGraphicsContainer = UINT;\r\n  PGPGraphicsContainer = ^TGPGraphicsContainer;\r\n\r\n//--------------------------------------------------------------------------\r\n// Fill mode constants\r\n//--------------------------------------------------------------------------\r\n\r\ntype\r\n  TGPFillMode = (\r\n    FillModeAlternate,        // 0\r\n    FillModeWinding);         // 1\r\n\r\n//--------------------------------------------------------------------------\r\n// Quality mode constants\r\n//--------------------------------------------------------------------------\r\n\r\ntype\r\n  TGPQualityMode = (\r\n    QualityModeInvalid   = -1,\r\n    QualityModeDefault   = 0,\r\n    QualityModeLow       = 1,  // Best performance\r\n    QualityModeHigh      = 2); // Best rendering quality\r\n\r\n//--------------------------------------------------------------------------\r\n// Alpha Compositing mode constants\r\n//--------------------------------------------------------------------------\r\n\r\ntype\r\n  TGPCompositingMode = (\r\n    CompositingModeSourceOver,    // 0\r\n    CompositingModeSourceCopy);   // 1\r\n\r\n//--------------------------------------------------------------------------\r\n// Alpha Compositing quality constants\r\n//--------------------------------------------------------------------------\r\n\r\ntype\r\n  TGPCompositingQuality = (\r\n    CompositingQualityInvalid          = Ord(QualityModeInvalid),\r\n    CompositingQualityDefault          = Ord(QualityModeDefault),\r\n    CompositingQualityHighSpeed        = Ord(QualityModeLow),\r\n    CompositingQualityHighQuality      = Ord(QualityModeHigh),\r\n    CompositingQualityGammaCorrected,\r\n    CompositingQualityAssumeLinear);\r\n\r\n//--------------------------------------------------------------------------\r\n// Unit constants\r\n//--------------------------------------------------------------------------\r\n\r\ntype\r\n  TGPUnit = (\r\n    UnitWorld,       // 0 -- World coordinate (non-physical unit)\r\n    UnitDisplay,     // 1 -- Variable -- for PageTransform only\r\n    UnitPixel,       // 2 -- Each unit is one device pixel.\r\n    UnitPoint,       // 3 -- Each unit is a printer's point, or 1/72 inch.\r\n    UnitInch,        // 4 -- Each unit is 1 inch.\r\n    UnitDocument,    // 5 -- Each unit is 1/300 inch.\r\n    UnitMillimeter); // 6 -- Each unit is 1 millimeter.\r\n\r\n//--------------------------------------------------------------------------\r\n// MetafileFrameUnit\r\n//\r\n// The frameRect for creating a metafile can be specified in any of these\r\n// units.  There is an extra frame unit value (MetafileFrameUnitGdi) so\r\n// that units can be supplied in the same units that GDI expects for\r\n// frame rects -- these units are in .01 (1/100ths) millimeter units\r\n// as defined by GDI.\r\n//--------------------------------------------------------------------------\r\n\r\ntype\r\n  TGPMetafileFrameUnit = (\r\n    MetafileFrameUnitPixel      = Ord(UnitPixel),\r\n    MetafileFrameUnitPoint      = Ord(UnitPoint),\r\n    MetafileFrameUnitInch       = Ord(UnitInch),\r\n    MetafileFrameUnitDocument   = Ord(UnitDocument),\r\n    MetafileFrameUnitMillimeter = Ord(UnitMillimeter),\r\n    MetafileFrameUnitGdi);  // GDI compatible .01 MM units\r\n\r\n//--------------------------------------------------------------------------\r\n// Coordinate space identifiers\r\n//--------------------------------------------------------------------------\r\n\r\ntype\r\n  TGPCoordinateSpace = (\r\n    CoordinateSpaceWorld,     // 0\r\n    CoordinateSpacePage,      // 1\r\n    CoordinateSpaceDevice);   // 2\r\n\r\n//--------------------------------------------------------------------------\r\n// Various wrap modes for brushes\r\n//--------------------------------------------------------------------------\r\n\r\ntype\r\n  TGPWrapMode = (\r\n    WrapModeTile,        // 0\r\n    WrapModeTileFlipX,   // 1\r\n    WrapModeTileFlipY,   // 2\r\n    WrapModeTileFlipXY,  // 3\r\n    WrapModeClamp);      // 4\r\n\r\n//--------------------------------------------------------------------------\r\n// Various hatch styles\r\n//--------------------------------------------------------------------------\r\n\r\ntype\r\n  TGPHatchStyle = (\r\n    HatchStyleHorizontal,                   // 0\r\n    HatchStyleVertical,                     // 1\r\n    HatchStyleForwardDiagonal,              // 2\r\n    HatchStyleBackwardDiagonal,             // 3\r\n    HatchStyleCross,                        // 4\r\n    HatchStyleDiagonalCross,                // 5\r\n    HatchStyle05Percent,                    // 6\r\n    HatchStyle10Percent,                    // 7\r\n    HatchStyle20Percent,                    // 8\r\n    HatchStyle25Percent,                    // 9\r\n    HatchStyle30Percent,                    // 10\r\n    HatchStyle40Percent,                    // 11\r\n    HatchStyle50Percent,                    // 12\r\n    HatchStyle60Percent,                    // 13\r\n    HatchStyle70Percent,                    // 14\r\n    HatchStyle75Percent,                    // 15\r\n    HatchStyle80Percent,                    // 16\r\n    HatchStyle90Percent,                    // 17\r\n    HatchStyleLightDownwardDiagonal,        // 18\r\n    HatchStyleLightUpwardDiagonal,          // 19\r\n    HatchStyleDarkDownwardDiagonal,         // 20\r\n    HatchStyleDarkUpwardDiagonal,           // 21\r\n    HatchStyleWideDownwardDiagonal,         // 22\r\n    HatchStyleWideUpwardDiagonal,           // 23\r\n    HatchStyleLightVertical,                // 24\r\n    HatchStyleLightHorizontal,              // 25\r\n    HatchStyleNarrowVertical,               // 26\r\n    HatchStyleNarrowHorizontal,             // 27\r\n    HatchStyleDarkVertical,                 // 28\r\n    HatchStyleDarkHorizontal,               // 29\r\n    HatchStyleDashedDownwardDiagonal,       // 30\r\n    HatchStyleDashedUpwardDiagonal,         // 31\r\n    HatchStyleDashedHorizontal,             // 32\r\n    HatchStyleDashedVertical,               // 33\r\n    HatchStyleSmallConfetti,                // 34\r\n    HatchStyleLargeConfetti,                // 35\r\n    HatchStyleZigZag,                       // 36\r\n    HatchStyleWave,                         // 37\r\n    HatchStyleDiagonalBrick,                // 38\r\n    HatchStyleHorizontalBrick,              // 39\r\n    HatchStyleWeave,                        // 40\r\n    HatchStylePlaid,                        // 41\r\n    HatchStyleDivot,                        // 42\r\n    HatchStyleDottedGrid,                   // 43\r\n    HatchStyleDottedDiamond,                // 44\r\n    HatchStyleShingle,                      // 45\r\n    HatchStyleTrellis,                      // 46\r\n    HatchStyleSphere,                       // 47\r\n    HatchStyleSmallGrid,                    // 48\r\n    HatchStyleSmallCheckerBoard,            // 49\r\n    HatchStyleLargeCheckerBoard,            // 50\r\n    HatchStyleOutlinedDiamond,              // 51\r\n    HatchStyleSolidDiamond,                 // 52\r\n\r\n    HatchStyleTotal,\r\n    HatchStyleLargeGrid = HatchStyleCross,  // 4\r\n\r\n    HatchStyleMin       = HatchStyleHorizontal,\r\n    HatchStyleMax       = HatchStyleTotal - 1);\r\n\r\n//--------------------------------------------------------------------------\r\n// Dash style constants\r\n//--------------------------------------------------------------------------\r\n\r\ntype\r\n  TGPDashStyle = (\r\n    DashStyleSolid,          // 0\r\n    DashStyleDash,           // 1\r\n    DashStyleDot,            // 2\r\n    DashStyleDashDot,        // 3\r\n    DashStyleDashDotDot,     // 4\r\n    DashStyleCustom);        // 5\r\n\r\n//--------------------------------------------------------------------------\r\n// Dash cap constants\r\n//--------------------------------------------------------------------------\r\n\r\ntype\r\n  TGPDashCap = (\r\n    DashCapFlat             = 0,\r\n    DashCapRound            = 2,\r\n    DashCapTriangle         = 3);\r\n\r\n//--------------------------------------------------------------------------\r\n// Line cap constants (only the lowest 8 bits are used).\r\n//--------------------------------------------------------------------------\r\n\r\ntype\r\n  TGPLineCap = (\r\n    LineCapFlat             = 0,\r\n    LineCapSquare           = 1,\r\n    LineCapRound            = 2,\r\n    LineCapTriangle         = 3,\r\n\r\n    LineCapNoAnchor         = $10,  // corresponds to flat cap\r\n    LineCapSquareAnchor     = $11,  // corresponds to square cap\r\n    LineCapRoundAnchor      = $12,  // corresponds to round cap\r\n    LineCapDiamondAnchor    = $13,  // corresponds to triangle cap\r\n    LineCapArrowAnchor      = $14,  // no correspondence\r\n\r\n    LineCapCustom           = $ff,  // custom cap\r\n\r\n    LineCapAnchorMask       = $f0); // mask to check for anchor or not.\r\n\r\n//--------------------------------------------------------------------------\r\n// Custom Line cap type constants\r\n//--------------------------------------------------------------------------\r\n\r\ntype\r\n  TGPCustomLineCapType = (\r\n    CustomLineCapTypeDefault         = 0,\r\n    CustomLineCapTypeAdjustableArrow = 1);\r\n\r\n//--------------------------------------------------------------------------\r\n// Line join constants\r\n//--------------------------------------------------------------------------\r\n\r\ntype\r\n  TGPLineJoin = (\r\n    LineJoinMiter        = 0,\r\n    LineJoinBevel        = 1,\r\n    LineJoinRound        = 2,\r\n    LineJoinMiterClipped = 3);\r\n\r\n//--------------------------------------------------------------------------\r\n// Path point types (only the lowest 8 bits are used.)\r\n//  The lowest 3 bits are interpreted as point type\r\n//  The higher 5 bits are reserved for flags.\r\n//--------------------------------------------------------------------------\r\n\r\ntype\r\n  TGPPathPointType = (\r\n    PathPointTypeStart           = 0,    // move\r\n    PathPointTypeLine            = 1,    // line\r\n    PathPointTypeBezier          = 3,    // default Bezier (= cubic Bezier)\r\n    PathPointTypePathTypeMask    = $07, // type mask (lowest 3 bits).\r\n    PathPointTypeDashMode        = $10, // currently in dash mode.\r\n    PathPointTypePathMarker      = $20, // a marker for the path.\r\n    PathPointTypeCloseSubpath    = $80, // closed flag\r\n\r\n    // Path types used for advanced path.\r\n\r\n    PathPointTypeBezier3         = 3);  // cubic Bezier\r\n\r\n//--------------------------------------------------------------------------\r\n// WarpMode constants\r\n//--------------------------------------------------------------------------\r\n\r\ntype\r\n  TGPWarpMode = (\r\n    WarpModePerspective,    // 0\r\n    WarpModeBilinear);      // 1\r\n\r\n//--------------------------------------------------------------------------\r\n// LineGradient Mode\r\n//--------------------------------------------------------------------------\r\n\r\ntype\r\n  TGPLinearGradientMode = (\r\n    LinearGradientModeHorizontal,         // 0\r\n    LinearGradientModeVertical,           // 1\r\n    LinearGradientModeForwardDiagonal,    // 2\r\n    LinearGradientModeBackwardDiagonal);  // 3\r\n\r\n//--------------------------------------------------------------------------\r\n// Region Comine Modes\r\n//--------------------------------------------------------------------------\r\n\r\ntype\r\n  TGPCombineMode = (\r\n    CombineModeReplace,     // 0\r\n    CombineModeIntersect,   // 1\r\n    CombineModeUnion,       // 2\r\n    CombineModeXor,         // 3\r\n    CombineModeExclude,     // 4\r\n    CombineModeComplement); // 5 (Exclude From)\r\n\r\n//--------------------------------------------------------------------------\r\n // Image types\r\n//--------------------------------------------------------------------------\r\n\r\ntype\r\n  TGPImageType = (\r\n    ImageTypeUnknown,   // 0\r\n    ImageTypeBitmap,    // 1\r\n    ImageTypeMetafile); // 2\r\n\r\n//--------------------------------------------------------------------------\r\n// Interpolation modes\r\n//--------------------------------------------------------------------------\r\n\r\ntype\r\n  TGPInterpolationMode = (\r\n    InterpolationModeInvalid          = Ord(QualityModeInvalid),\r\n    InterpolationModeDefault          = Ord(QualityModeDefault),\r\n    InterpolationModeLowQuality       = Ord(QualityModeLow),\r\n    InterpolationModeHighQuality      = Ord(QualityModeHigh),\r\n    InterpolationModeBilinear,\r\n    InterpolationModeBicubic,\r\n    InterpolationModeNearestNeighbor,\r\n    InterpolationModeHighQualityBilinear,\r\n    InterpolationModeHighQualityBicubic);\r\n\r\n//--------------------------------------------------------------------------\r\n// Pen types\r\n//--------------------------------------------------------------------------\r\n\r\ntype\r\n  TGPPenAlignment = (\r\n    PenAlignmentCenter       = 0,\r\n    PenAlignmentInset        = 1);\r\n\r\n//--------------------------------------------------------------------------\r\n// Brush types\r\n//--------------------------------------------------------------------------\r\n\r\ntype\r\n  TGPBrushType = (\r\n    BrushTypeSolidColor       = 0,\r\n    BrushTypeHatchFill        = 1,\r\n    BrushTypeTextureFill      = 2,\r\n    BrushTypePathGradient     = 3,\r\n    BrushTypeLinearGradient   = 4);\r\n\r\n//--------------------------------------------------------------------------\r\n// Pen's Fill types\r\n//--------------------------------------------------------------------------\r\n\r\ntype\r\n  TGPPenType = (\r\n    PenTypeSolidColor       = Ord(BrushTypeSolidColor),\r\n    PenTypeHatchFill        = Ord(BrushTypeHatchFill),\r\n    PenTypeTextureFill      = Ord(BrushTypeTextureFill),\r\n    PenTypePathGradient     = Ord(BrushTypePathGradient),\r\n    PenTypeLinearGradient   = Ord(BrushTypeLinearGradient),\r\n    PenTypeUnknown          = -1);\r\n\r\n//--------------------------------------------------------------------------\r\n// Matrix Order\r\n//--------------------------------------------------------------------------\r\n\r\ntype\r\n  TGPMatrixOrder = (\r\n    MatrixOrderPrepend    = 0,\r\n    MatrixOrderAppend     = 1);\r\n\r\n//--------------------------------------------------------------------------\r\n// Generic font families\r\n//--------------------------------------------------------------------------\r\n\r\ntype\r\n  TGPGenericFontFamily = (\r\n    GenericFontFamilySerif,\r\n    GenericFontFamilySansSerif,\r\n    GenericFontFamilyMonospace);\r\n\r\n//--------------------------------------------------------------------------\r\n// FontStyle: face types and common styles\r\n//--------------------------------------------------------------------------\r\n\r\ntype\r\n  TGPFontStyleEntry = (\r\n    FontStyleBold      = 0,\r\n    FontStyleItalic    = 1,\r\n    FontStyleUnderline = 2,\r\n    FontStyleStrikeout = 3,\r\n    FontStyleReserved  = 31);\r\n\r\n  TGPFontStyle = set of TGPFontStyleEntry;\r\n\r\nconst\r\n  FontStyleRegular = [];\r\n  FontStyleBoldItalic = [FontStyleBold, FontStyleItalic];\r\n\r\n//---------------------------------------------------------------------------\r\n// Smoothing Mode\r\n//---------------------------------------------------------------------------\r\n\r\ntype\r\n  TGPSmoothingMode = (\r\n    SmoothingModeInvalid     = Ord(QualityModeInvalid),\r\n    SmoothingModeDefault     = Ord(QualityModeDefault),\r\n    SmoothingModeHighSpeed   = Ord(QualityModeLow),\r\n    SmoothingModeHighQuality = Ord(QualityModeHigh),\r\n    SmoothingModeNone,\r\n    SmoothingModeAntiAlias\r\n    {$IF (GDIPVER >= $0110)}\r\n    ,\r\n    SmoothingModeAntiAlias8x4 = Ord(SmoothingModeAntiAlias),\r\n    SmoothingModeAntiAlias8x8\r\n    {$IFEND}\r\n    );\r\n\r\n//---------------------------------------------------------------------------\r\n// Pixel Format Mode\r\n//---------------------------------------------------------------------------\r\n\r\ntype\r\n  TGPPixelOffsetMode = (\r\n    PixelOffsetModeInvalid     = Ord(QualityModeInvalid),\r\n    PixelOffsetModeDefault     = Ord(QualityModeDefault),\r\n    PixelOffsetModeHighSpeed   = Ord(QualityModeLow),\r\n    PixelOffsetModeHighQuality = Ord(QualityModeHigh),\r\n    PixelOffsetModeNone,    // No pixel offset\r\n    PixelOffsetModeHalf);   // Offset by -0.5, -0.5 for fast anti-alias perf\r\n\r\n//---------------------------------------------------------------------------\r\n// Text Rendering Hint\r\n//---------------------------------------------------------------------------\r\n\r\ntype\r\n  TGPTextRenderingHint = (\r\n    TextRenderingHintSystemDefault = 0,            // Glyph with system default rendering hint\r\n    TextRenderingHintSingleBitPerPixelGridFit,     // Glyph bitmap with hinting\r\n    TextRenderingHintSingleBitPerPixel,            // Glyph bitmap without hinting\r\n    TextRenderingHintAntiAliasGridFit,             // Glyph anti-alias bitmap with hinting\r\n    TextRenderingHintAntiAlias,                    // Glyph anti-alias bitmap without hinting\r\n    TextRenderingHintClearTypeGridFit);            // Glyph CT bitmap with hinting\r\n\r\n//---------------------------------------------------------------------------\r\n// Metafile Types\r\n//---------------------------------------------------------------------------\r\n\r\ntype\r\n  TGPMetafileType = (\r\n    MetafileTypeInvalid,            // Invalid metafile\r\n    MetafileTypeWmf,                // Standard WMF\r\n    MetafileTypeWmfPlaceable,       // Placeable WMF\r\n    MetafileTypeEmf,                // EMF (not EMF+)\r\n    MetafileTypeEmfPlusOnly,        // EMF+ without dual, down-level records\r\n    MetafileTypeEmfPlusDual);       // EMF+ with dual, down-level records\r\n\r\n//---------------------------------------------------------------------------\r\n// Specifies the type of EMF to record\r\n//---------------------------------------------------------------------------\r\n\r\ntype\r\n  TGPEmfType = (\r\n    EmfTypeEmfOnly     = Ord(MetafileTypeEmf),          // no EMF+, only EMF\r\n    EmfTypeEmfPlusOnly = Ord(MetafileTypeEmfPlusOnly),  // no EMF, only EMF+\r\n    EmfTypeEmfPlusDual = Ord(MetafileTypeEmfPlusDual)); // both EMF+ and EMF\r\n\r\n//---------------------------------------------------------------------------\r\n// EMF+ Persistent object types\r\n//---------------------------------------------------------------------------\r\n\r\ntype\r\n  TGPObjectType = (\r\n    ObjectTypeInvalid,\r\n    ObjectTypeBrush,\r\n    ObjectTypePen,\r\n    ObjectTypePath,\r\n    ObjectTypeRegion,\r\n    ObjectTypeImage,\r\n    ObjectTypeFont,\r\n    ObjectTypeStringFormat,\r\n    ObjectTypeImageAttributes,\r\n    ObjectTypeCustomLineCap,\r\n    {$IF (GDIPVER >= $0110)}\r\n    ObjectTypeGraphics,\r\n\r\n    ObjectTypeMax = ObjectTypeGraphics,\r\n    {$ELSE}\r\n    ObjectTypeMax = ObjectTypeCustomLineCap,\r\n    {$IFEND}\r\n    ObjectTypeMin = ObjectTypeBrush);\r\n\r\nfunction ObjectTypeIsValid(const ObjectType: TGPObjectType): Boolean; inline;\r\n\r\n//---------------------------------------------------------------------------\r\n// EMF+ Records\r\n//---------------------------------------------------------------------------\r\n\r\n// We have to change the WMF record numbers so that they don't conflict with\r\n// the EMF and EMF+ record numbers.\r\n\r\nconst\r\n  GDIP_EMFPLUS_RECORD_BASE        = $00004000;\r\n  GDIP_WMF_RECORD_BASE            = $00010000;\r\n//  GDIP_WMF_RECORD_TO_EMFPLUS(n)   ((EmfPlusRecordType)((n) | GDIP_WMF_RECORD_BASE))\r\n//  GDIP_EMFPLUS_RECORD_TO_WMF(n)   ((n) & (~GDIP_WMF_RECORD_BASE))\r\n//  GDIP_IS_WMF_RECORDTYPE(n)       (((n) & GDIP_WMF_RECORD_BASE) != 0)\r\n\r\ntype\r\n  TEmfPlusRecordType = (\r\n    // Since we have to enumerate GDI records right along with GDI+ records,\r\n    // We list all the GDI records here so that they can be part of the\r\n    // same enumeration type which is used in the enumeration callback.\r\n\r\n    WmfRecordTypeSetBkColor              = GDIP_WMF_RECORD_BASE or META_SETBKCOLOR,\r\n    WmfRecordTypeSetBkMode               = GDIP_WMF_RECORD_BASE or META_SETBKMODE,\r\n    WmfRecordTypeSetMapMode              = GDIP_WMF_RECORD_BASE or META_SETMAPMODE,\r\n    WmfRecordTypeSetROP2                 = GDIP_WMF_RECORD_BASE or META_SETROP2,\r\n    WmfRecordTypeSetRelAbs               = GDIP_WMF_RECORD_BASE or META_SETRELABS,\r\n    WmfRecordTypeSetPolyFillMode         = GDIP_WMF_RECORD_BASE or META_SETPOLYFILLMODE,\r\n    WmfRecordTypeSetStretchBltMode       = GDIP_WMF_RECORD_BASE or META_SETSTRETCHBLTMODE,\r\n    WmfRecordTypeSetTextCharExtra        = GDIP_WMF_RECORD_BASE or META_SETTEXTCHAREXTRA,\r\n    WmfRecordTypeSetTextColor            = GDIP_WMF_RECORD_BASE or META_SETTEXTCOLOR,\r\n    WmfRecordTypeSetTextJustification    = GDIP_WMF_RECORD_BASE or META_SETTEXTJUSTIFICATION,\r\n    WmfRecordTypeSetWindowOrg            = GDIP_WMF_RECORD_BASE or META_SETWINDOWORG,\r\n    WmfRecordTypeSetWindowExt            = GDIP_WMF_RECORD_BASE or META_SETWINDOWEXT,\r\n    WmfRecordTypeSetViewportOrg          = GDIP_WMF_RECORD_BASE or META_SETVIEWPORTORG,\r\n    WmfRecordTypeSetViewportExt          = GDIP_WMF_RECORD_BASE or META_SETVIEWPORTEXT,\r\n    WmfRecordTypeOffsetWindowOrg         = GDIP_WMF_RECORD_BASE or META_OFFSETWINDOWORG,\r\n    WmfRecordTypeScaleWindowExt          = GDIP_WMF_RECORD_BASE or META_SCALEWINDOWEXT,\r\n    WmfRecordTypeOffsetViewportOrg       = GDIP_WMF_RECORD_BASE or META_OFFSETVIEWPORTORG,\r\n    WmfRecordTypeScaleViewportExt        = GDIP_WMF_RECORD_BASE or META_SCALEVIEWPORTEXT,\r\n    WmfRecordTypeLineTo                  = GDIP_WMF_RECORD_BASE or META_LINETO,\r\n    WmfRecordTypeMoveTo                  = GDIP_WMF_RECORD_BASE or META_MOVETO,\r\n    WmfRecordTypeExcludeClipRect         = GDIP_WMF_RECORD_BASE or META_EXCLUDECLIPRECT,\r\n    WmfRecordTypeIntersectClipRect       = GDIP_WMF_RECORD_BASE or META_INTERSECTCLIPRECT,\r\n    WmfRecordTypeArc                     = GDIP_WMF_RECORD_BASE or META_ARC,\r\n    WmfRecordTypeEllipse                 = GDIP_WMF_RECORD_BASE or META_ELLIPSE,\r\n    WmfRecordTypeFloodFill               = GDIP_WMF_RECORD_BASE or META_FLOODFILL,\r\n    WmfRecordTypePie                     = GDIP_WMF_RECORD_BASE or META_PIE,\r\n    WmfRecordTypeRectangle               = GDIP_WMF_RECORD_BASE or META_RECTANGLE,\r\n    WmfRecordTypeRoundRect               = GDIP_WMF_RECORD_BASE or META_ROUNDRECT,\r\n    WmfRecordTypePatBlt                  = GDIP_WMF_RECORD_BASE or META_PATBLT,\r\n    WmfRecordTypeSaveDC                  = GDIP_WMF_RECORD_BASE or META_SAVEDC,\r\n    WmfRecordTypeSetPixel                = GDIP_WMF_RECORD_BASE or META_SETPIXEL,\r\n    WmfRecordTypeOffsetClipRgn           = GDIP_WMF_RECORD_BASE or META_OFFSETCLIPRGN,\r\n    WmfRecordTypeTextOut                 = GDIP_WMF_RECORD_BASE or META_TEXTOUT,\r\n    WmfRecordTypeBitBlt                  = GDIP_WMF_RECORD_BASE or META_BITBLT,\r\n    WmfRecordTypeStretchBlt              = GDIP_WMF_RECORD_BASE or META_STRETCHBLT,\r\n    WmfRecordTypePolygon                 = GDIP_WMF_RECORD_BASE or META_POLYGON,\r\n    WmfRecordTypePolyline                = GDIP_WMF_RECORD_BASE or META_POLYLINE,\r\n    WmfRecordTypeEscape                  = GDIP_WMF_RECORD_BASE or META_ESCAPE,\r\n    WmfRecordTypeRestoreDC               = GDIP_WMF_RECORD_BASE or META_RESTOREDC,\r\n    WmfRecordTypeFillRegion              = GDIP_WMF_RECORD_BASE or META_FILLREGION,\r\n    WmfRecordTypeFrameRegion             = GDIP_WMF_RECORD_BASE or META_FRAMEREGION,\r\n    WmfRecordTypeInvertRegion            = GDIP_WMF_RECORD_BASE or META_INVERTREGION,\r\n    WmfRecordTypePaintRegion             = GDIP_WMF_RECORD_BASE or META_PAINTREGION,\r\n    WmfRecordTypeSelectClipRegion        = GDIP_WMF_RECORD_BASE or META_SELECTCLIPREGION,\r\n    WmfRecordTypeSelectObject            = GDIP_WMF_RECORD_BASE or META_SELECTOBJECT,\r\n    WmfRecordTypeSetTextAlign            = GDIP_WMF_RECORD_BASE or META_SETTEXTALIGN,\r\n    WmfRecordTypeDrawText                = GDIP_WMF_RECORD_BASE or $062F,  // META_DRAWTEXT\r\n    WmfRecordTypeChord                   = GDIP_WMF_RECORD_BASE or META_CHORD,\r\n    WmfRecordTypeSetMapperFlags          = GDIP_WMF_RECORD_BASE or META_SETMAPPERFLAGS,\r\n    WmfRecordTypeExtTextOut              = GDIP_WMF_RECORD_BASE or META_EXTTEXTOUT,\r\n    WmfRecordTypeSetDIBToDev             = GDIP_WMF_RECORD_BASE or META_SETDIBTODEV,\r\n    WmfRecordTypeSelectPalette           = GDIP_WMF_RECORD_BASE or META_SELECTPALETTE,\r\n    WmfRecordTypeRealizePalette          = GDIP_WMF_RECORD_BASE or META_REALIZEPALETTE,\r\n    WmfRecordTypeAnimatePalette          = GDIP_WMF_RECORD_BASE or META_ANIMATEPALETTE,\r\n    WmfRecordTypeSetPalEntries           = GDIP_WMF_RECORD_BASE or META_SETPALENTRIES,\r\n    WmfRecordTypePolyPolygon             = GDIP_WMF_RECORD_BASE or META_POLYPOLYGON,\r\n    WmfRecordTypeResizePalette           = GDIP_WMF_RECORD_BASE or META_RESIZEPALETTE,\r\n    WmfRecordTypeDIBBitBlt               = GDIP_WMF_RECORD_BASE or META_DIBBITBLT,\r\n    WmfRecordTypeDIBStretchBlt           = GDIP_WMF_RECORD_BASE or META_DIBSTRETCHBLT,\r\n    WmfRecordTypeDIBCreatePatternBrush   = GDIP_WMF_RECORD_BASE or META_DIBCREATEPATTERNBRUSH,\r\n    WmfRecordTypeStretchDIB              = GDIP_WMF_RECORD_BASE or META_STRETCHDIB,\r\n    WmfRecordTypeExtFloodFill            = GDIP_WMF_RECORD_BASE or META_EXTFLOODFILL,\r\n    WmfRecordTypeSetLayout               = GDIP_WMF_RECORD_BASE or $0149,  // META_SETLAYOUT\r\n    WmfRecordTypeResetDC                 = GDIP_WMF_RECORD_BASE or $014C,  // META_RESETDC\r\n    WmfRecordTypeStartDoc                = GDIP_WMF_RECORD_BASE or $014D,  // META_STARTDOC\r\n    WmfRecordTypeStartPage               = GDIP_WMF_RECORD_BASE or $004F,  // META_STARTPAGE\r\n    WmfRecordTypeEndPage                 = GDIP_WMF_RECORD_BASE or $0050,  // META_ENDPAGE\r\n    WmfRecordTypeAbortDoc                = GDIP_WMF_RECORD_BASE or $0052,  // META_ABORTDOC\r\n    WmfRecordTypeEndDoc                  = GDIP_WMF_RECORD_BASE or $005E,  // META_ENDDOC\r\n    WmfRecordTypeDeleteObject            = GDIP_WMF_RECORD_BASE or META_DELETEOBJECT,\r\n    WmfRecordTypeCreatePalette           = GDIP_WMF_RECORD_BASE or META_CREATEPALETTE,\r\n    WmfRecordTypeCreateBrush             = GDIP_WMF_RECORD_BASE or $00F8,  // META_CREATEBRUSH\r\n    WmfRecordTypeCreatePatternBrush      = GDIP_WMF_RECORD_BASE or META_CREATEPATTERNBRUSH,\r\n    WmfRecordTypeCreatePenIndirect       = GDIP_WMF_RECORD_BASE or META_CREATEPENINDIRECT,\r\n    WmfRecordTypeCreateFontIndirect      = GDIP_WMF_RECORD_BASE or META_CREATEFONTINDIRECT,\r\n    WmfRecordTypeCreateBrushIndirect     = GDIP_WMF_RECORD_BASE or META_CREATEBRUSHINDIRECT,\r\n    WmfRecordTypeCreateBitmapIndirect    = GDIP_WMF_RECORD_BASE or $02FD,  // META_CREATEBITMAPINDIRECT\r\n    WmfRecordTypeCreateBitmap            = GDIP_WMF_RECORD_BASE or $06FE,  // META_CREATEBITMAP\r\n    WmfRecordTypeCreateRegion            = GDIP_WMF_RECORD_BASE or META_CREATEREGION,\r\n\r\n    EmfRecordTypeHeader                  = EMR_HEADER,\r\n    EmfRecordTypePolyBezier              = EMR_POLYBEZIER,\r\n    EmfRecordTypePolygon                 = EMR_POLYGON,\r\n    EmfRecordTypePolyline                = EMR_POLYLINE,\r\n    EmfRecordTypePolyBezierTo            = EMR_POLYBEZIERTO,\r\n    EmfRecordTypePolyLineTo              = EMR_POLYLINETO,\r\n    EmfRecordTypePolyPolyline            = EMR_POLYPOLYLINE,\r\n    EmfRecordTypePolyPolygon             = EMR_POLYPOLYGON,\r\n    EmfRecordTypeSetWindowExtEx          = EMR_SETWINDOWEXTEX,\r\n    EmfRecordTypeSetWindowOrgEx          = EMR_SETWINDOWORGEX,\r\n    EmfRecordTypeSetViewportExtEx        = EMR_SETVIEWPORTEXTEX,\r\n    EmfRecordTypeSetViewportOrgEx        = EMR_SETVIEWPORTORGEX,\r\n    EmfRecordTypeSetBrushOrgEx           = EMR_SETBRUSHORGEX,\r\n    EmfRecordTypeEOF                     = EMR_EOF,\r\n    EmfRecordTypeSetPixelV               = EMR_SETPIXELV,\r\n    EmfRecordTypeSetMapperFlags          = EMR_SETMAPPERFLAGS,\r\n    EmfRecordTypeSetMapMode              = EMR_SETMAPMODE,\r\n    EmfRecordTypeSetBkMode               = EMR_SETBKMODE,\r\n    EmfRecordTypeSetPolyFillMode         = EMR_SETPOLYFILLMODE,\r\n    EmfRecordTypeSetROP2                 = EMR_SETROP2,\r\n    EmfRecordTypeSetStretchBltMode       = EMR_SETSTRETCHBLTMODE,\r\n    EmfRecordTypeSetTextAlign            = EMR_SETTEXTALIGN,\r\n    EmfRecordTypeSetColorAdjustment      = EMR_SETCOLORADJUSTMENT,\r\n    EmfRecordTypeSetTextColor            = EMR_SETTEXTCOLOR,\r\n    EmfRecordTypeSetBkColor              = EMR_SETBKCOLOR,\r\n    EmfRecordTypeOffsetClipRgn           = EMR_OFFSETCLIPRGN,\r\n    EmfRecordTypeMoveToEx                = EMR_MOVETOEX,\r\n    EmfRecordTypeSetMetaRgn              = EMR_SETMETARGN,\r\n    EmfRecordTypeExcludeClipRect         = EMR_EXCLUDECLIPRECT,\r\n    EmfRecordTypeIntersectClipRect       = EMR_INTERSECTCLIPRECT,\r\n    EmfRecordTypeScaleViewportExtEx      = EMR_SCALEVIEWPORTEXTEX,\r\n    EmfRecordTypeScaleWindowExtEx        = EMR_SCALEWINDOWEXTEX,\r\n    EmfRecordTypeSaveDC                  = EMR_SAVEDC,\r\n    EmfRecordTypeRestoreDC               = EMR_RESTOREDC,\r\n    EmfRecordTypeSetWorldTransform       = EMR_SETWORLDTRANSFORM,\r\n    EmfRecordTypeModifyWorldTransform    = EMR_MODIFYWORLDTRANSFORM,\r\n    EmfRecordTypeSelectObject            = EMR_SELECTOBJECT,\r\n    EmfRecordTypeCreatePen               = EMR_CREATEPEN,\r\n    EmfRecordTypeCreateBrushIndirect     = EMR_CREATEBRUSHINDIRECT,\r\n    EmfRecordTypeDeleteObject            = EMR_DELETEOBJECT,\r\n    EmfRecordTypeAngleArc                = EMR_ANGLEARC,\r\n    EmfRecordTypeEllipse                 = EMR_ELLIPSE,\r\n    EmfRecordTypeRectangle               = EMR_RECTANGLE,\r\n    EmfRecordTypeRoundRect               = EMR_ROUNDRECT,\r\n    EmfRecordTypeArc                     = EMR_ARC,\r\n    EmfRecordTypeChord                   = EMR_CHORD,\r\n    EmfRecordTypePie                     = EMR_PIE,\r\n    EmfRecordTypeSelectPalette           = EMR_SELECTPALETTE,\r\n    EmfRecordTypeCreatePalette           = EMR_CREATEPALETTE,\r\n    EmfRecordTypeSetPaletteEntries       = EMR_SETPALETTEENTRIES,\r\n    EmfRecordTypeResizePalette           = EMR_RESIZEPALETTE,\r\n    EmfRecordTypeRealizePalette          = EMR_REALIZEPALETTE,\r\n    EmfRecordTypeExtFloodFill            = EMR_EXTFLOODFILL,\r\n    EmfRecordTypeLineTo                  = EMR_LINETO,\r\n    EmfRecordTypeArcTo                   = EMR_ARCTO,\r\n    EmfRecordTypePolyDraw                = EMR_POLYDRAW,\r\n    EmfRecordTypeSetArcDirection         = EMR_SETARCDIRECTION,\r\n    EmfRecordTypeSetMiterLimit           = EMR_SETMITERLIMIT,\r\n    EmfRecordTypeBeginPath               = EMR_BEGINPATH,\r\n    EmfRecordTypeEndPath                 = EMR_ENDPATH,\r\n    EmfRecordTypeCloseFigure             = EMR_CLOSEFIGURE,\r\n    EmfRecordTypeFillPath                = EMR_FILLPATH,\r\n    EmfRecordTypeStrokeAndFillPath       = EMR_STROKEANDFILLPATH,\r\n    EmfRecordTypeStrokePath              = EMR_STROKEPATH,\r\n    EmfRecordTypeFlattenPath             = EMR_FLATTENPATH,\r\n    EmfRecordTypeWidenPath               = EMR_WIDENPATH,\r\n    EmfRecordTypeSelectClipPath          = EMR_SELECTCLIPPATH,\r\n    EmfRecordTypeAbortPath               = EMR_ABORTPATH,\r\n    EmfRecordTypeReserved_069            = 69,  // Not Used\r\n    EmfRecordTypeGdiComment              = EMR_GDICOMMENT,\r\n    EmfRecordTypeFillRgn                 = EMR_FILLRGN,\r\n    EmfRecordTypeFrameRgn                = EMR_FRAMERGN,\r\n    EmfRecordTypeInvertRgn               = EMR_INVERTRGN,\r\n    EmfRecordTypePaintRgn                = EMR_PAINTRGN,\r\n    EmfRecordTypeExtSelectClipRgn        = EMR_EXTSELECTCLIPRGN,\r\n    EmfRecordTypeBitBlt                  = EMR_BITBLT,\r\n    EmfRecordTypeStretchBlt              = EMR_STRETCHBLT,\r\n    EmfRecordTypeMaskBlt                 = EMR_MASKBLT,\r\n    EmfRecordTypePlgBlt                  = EMR_PLGBLT,\r\n    EmfRecordTypeSetDIBitsToDevice       = EMR_SETDIBITSTODEVICE,\r\n    EmfRecordTypeStretchDIBits           = EMR_STRETCHDIBITS,\r\n    EmfRecordTypeExtCreateFontIndirect   = EMR_EXTCREATEFONTINDIRECTW,\r\n    EmfRecordTypeExtTextOutA             = EMR_EXTTEXTOUTA,\r\n    EmfRecordTypeExtTextOutW             = EMR_EXTTEXTOUTW,\r\n    EmfRecordTypePolyBezier16            = EMR_POLYBEZIER16,\r\n    EmfRecordTypePolygon16               = EMR_POLYGON16,\r\n    EmfRecordTypePolyline16              = EMR_POLYLINE16,\r\n    EmfRecordTypePolyBezierTo16          = EMR_POLYBEZIERTO16,\r\n    EmfRecordTypePolylineTo16            = EMR_POLYLINETO16,\r\n    EmfRecordTypePolyPolyline16          = EMR_POLYPOLYLINE16,\r\n    EmfRecordTypePolyPolygon16           = EMR_POLYPOLYGON16,\r\n    EmfRecordTypePolyDraw16              = EMR_POLYDRAW16,\r\n    EmfRecordTypeCreateMonoBrush         = EMR_CREATEMONOBRUSH,\r\n    EmfRecordTypeCreateDIBPatternBrushPt = EMR_CREATEDIBPATTERNBRUSHPT,\r\n    EmfRecordTypeExtCreatePen            = EMR_EXTCREATEPEN,\r\n    EmfRecordTypePolyTextOutA            = EMR_POLYTEXTOUTA,\r\n    EmfRecordTypePolyTextOutW            = EMR_POLYTEXTOUTW,\r\n    EmfRecordTypeSetICMMode              = 98,  // EMR_SETICMMODE,\r\n    EmfRecordTypeCreateColorSpace        = 99,  // EMR_CREATECOLORSPACE,\r\n    EmfRecordTypeSetColorSpace           = 100, // EMR_SETCOLORSPACE,\r\n    EmfRecordTypeDeleteColorSpace        = 101, // EMR_DELETECOLORSPACE,\r\n    EmfRecordTypeGLSRecord               = 102, // EMR_GLSRECORD,\r\n    EmfRecordTypeGLSBoundedRecord        = 103, // EMR_GLSBOUNDEDRECORD,\r\n    EmfRecordTypePixelFormat             = 104, // EMR_PIXELFORMAT,\r\n    EmfRecordTypeDrawEscape              = 105, // EMR_RESERVED_105,\r\n    EmfRecordTypeExtEscape               = 106, // EMR_RESERVED_106,\r\n    EmfRecordTypeStartDoc                = 107, // EMR_RESERVED_107,\r\n    EmfRecordTypeSmallTextOut            = 108, // EMR_RESERVED_108,\r\n    EmfRecordTypeForceUFIMapping         = 109, // EMR_RESERVED_109,\r\n    EmfRecordTypeNamedEscape             = 110, // EMR_RESERVED_110,\r\n    EmfRecordTypeColorCorrectPalette     = 111, // EMR_COLORCORRECTPALETTE,\r\n    EmfRecordTypeSetICMProfileA          = 112, // EMR_SETICMPROFILEA,\r\n    EmfRecordTypeSetICMProfileW          = 113, // EMR_SETICMPROFILEW,\r\n    EmfRecordTypeAlphaBlend              = 114, // EMR_ALPHABLEND,\r\n    EmfRecordTypeSetLayout               = 115, // EMR_SETLAYOUT,\r\n    EmfRecordTypeTransparentBlt          = 116, // EMR_TRANSPARENTBLT,\r\n    EmfRecordTypeReserved_117            = 117, // Not Used\r\n    EmfRecordTypeGradientFill            = 118, // EMR_GRADIENTFILL,\r\n    EmfRecordTypeSetLinkedUFIs           = 119, // EMR_RESERVED_119,\r\n    EmfRecordTypeSetTextJustification    = 120, // EMR_RESERVED_120,\r\n    EmfRecordTypeColorMatchToTargetW     = 121, // EMR_COLORMATCHTOTARGETW,\r\n    EmfRecordTypeCreateColorSpaceW       = 122, // EMR_CREATECOLORSPACEW,\r\n    EmfRecordTypeMax                     = 122,\r\n    EmfRecordTypeMin                     = 1,\r\n\r\n    // That is the END of the GDI EMF records.\r\n\r\n    // Now we start the list of EMF+ records.  We leave quite\r\n    // a bit of room here for the addition of any new GDI\r\n    // records that may be added later.\r\n\r\n    EmfPlusRecordTypeInvalid = GDIP_EMFPLUS_RECORD_BASE,\r\n    EmfPlusRecordTypeHeader,\r\n    EmfPlusRecordTypeEndOfFile,\r\n\r\n    EmfPlusRecordTypeComment,\r\n\r\n    EmfPlusRecordTypeGetDC,\r\n\r\n    EmfPlusRecordTypeMultiFormatStart,\r\n    EmfPlusRecordTypeMultiFormatSection,\r\n    EmfPlusRecordTypeMultiFormatEnd,\r\n\r\n    // For all persistent objects\r\n\r\n    EmfPlusRecordTypeObject,\r\n\r\n    // Drawing Records\r\n\r\n    EmfPlusRecordTypeClear,\r\n    EmfPlusRecordTypeFillRects,\r\n    EmfPlusRecordTypeDrawRects,\r\n    EmfPlusRecordTypeFillPolygon,\r\n    EmfPlusRecordTypeDrawLines,\r\n    EmfPlusRecordTypeFillEllipse,\r\n    EmfPlusRecordTypeDrawEllipse,\r\n    EmfPlusRecordTypeFillPie,\r\n    EmfPlusRecordTypeDrawPie,\r\n    EmfPlusRecordTypeDrawArc,\r\n    EmfPlusRecordTypeFillRegion,\r\n    EmfPlusRecordTypeFillPath,\r\n    EmfPlusRecordTypeDrawPath,\r\n    EmfPlusRecordTypeFillClosedCurve,\r\n    EmfPlusRecordTypeDrawClosedCurve,\r\n    EmfPlusRecordTypeDrawCurve,\r\n    EmfPlusRecordTypeDrawBeziers,\r\n    EmfPlusRecordTypeDrawImage,\r\n    EmfPlusRecordTypeDrawImagePoints,\r\n    EmfPlusRecordTypeDrawString,\r\n\r\n    // Graphics State Records\r\n\r\n    EmfPlusRecordTypeSetRenderingOrigin,\r\n    EmfPlusRecordTypeSetAntiAliasMode,\r\n    EmfPlusRecordTypeSetTextRenderingHint,\r\n    EmfPlusRecordTypeSetTextContrast,\r\n    EmfPlusRecordTypeSetInterpolationMode,\r\n    EmfPlusRecordTypeSetPixelOffsetMode,\r\n    EmfPlusRecordTypeSetCompositingMode,\r\n    EmfPlusRecordTypeSetCompositingQuality,\r\n    EmfPlusRecordTypeSave,\r\n    EmfPlusRecordTypeRestore,\r\n    EmfPlusRecordTypeBeginContainer,\r\n    EmfPlusRecordTypeBeginContainerNoParams,\r\n    EmfPlusRecordTypeEndContainer,\r\n    EmfPlusRecordTypeSetWorldTransform,\r\n    EmfPlusRecordTypeResetWorldTransform,\r\n    EmfPlusRecordTypeMultiplyWorldTransform,\r\n    EmfPlusRecordTypeTranslateWorldTransform,\r\n    EmfPlusRecordTypeScaleWorldTransform,\r\n    EmfPlusRecordTypeRotateWorldTransform,\r\n    EmfPlusRecordTypeSetPageTransform,\r\n    EmfPlusRecordTypeResetClip,\r\n    EmfPlusRecordTypeSetClipRect,\r\n    EmfPlusRecordTypeSetClipPath,\r\n    EmfPlusRecordTypeSetClipRegion,\r\n    EmfPlusRecordTypeOffsetClip,\r\n\r\n    EmfPlusRecordTypeDrawDriverString,\r\n    {$IF (GDIPVER >= $0110)}\r\n    EmfPlusRecordTypeStrokeFillPath,\r\n    EmfPlusRecordTypeSerializableObject,\r\n\r\n    EmfPlusRecordTypeSetTSGraphics,\r\n    EmfPlusRecordTypeSetTSClip,\r\n    {$IFEND}\r\n    // NOTE: New records *must* be added immediately before this line.\r\n\r\n    EmfPlusRecordTotal,\r\n\r\n    EmfPlusRecordTypeMax = EmfPlusRecordTotal-1,\r\n    EmfPlusRecordTypeMin = EmfPlusRecordTypeHeader);\r\n\r\n//---------------------------------------------------------------------------\r\n// StringFormatFlags\r\n//---------------------------------------------------------------------------\r\n\r\n//---------------------------------------------------------------------------\r\n// String format flags\r\n//\r\n//  DirectionRightToLeft          - For horizontal text, the reading order is\r\n//                                  right to left. This value is called\r\n//                                  the base embedding level by the Unicode\r\n//                                  bidirectional engine.\r\n//                                  For vertical text, columns are read from\r\n//                                  right to left.\r\n//                                  By default, horizontal or vertical text is\r\n//                                  read from left to right.\r\n//\r\n//  DirectionVertical             - Individual lines of text are vertical. In\r\n//                                  each line, characters progress from top to\r\n//                                  bottom.\r\n//                                  By default, lines of text are horizontal,\r\n//                                  each new line below the previous line.\r\n//\r\n//  NoFitBlackBox                 - Allows parts of glyphs to overhang the\r\n//                                  bounding rectangle.\r\n//                                  By default glyphs are first aligned\r\n//                                  inside the margines, then any glyphs which\r\n//                                  still overhang the bounding box are\r\n//                                  repositioned to avoid any overhang.\r\n//                                  For example when an italic\r\n//                                  lower case letter f in a font such as\r\n//                                  Garamond is aligned at the far left of a\r\n//                                  rectangle, the lower part of the f will\r\n//                                  reach slightly further left than the left\r\n//                                  edge of the rectangle. Setting this flag\r\n//                                  will ensure the character aligns visually\r\n//                                  with the lines above and below, but may\r\n//                                  cause some pixels outside the formatting\r\n//                                  rectangle to be clipped or painted.\r\n//\r\n//  DisplayFormatControl          - Causes control characters such as the\r\n//                                  left-to-right mark to be shown in the\r\n//                                  output with a representative glyph.\r\n//\r\n//  NoFontFallback                - Disables fallback to alternate fonts for\r\n//                                  characters not supported in the requested\r\n//                                  font. Any missing characters will be\r\n//                                  be displayed with the fonts missing glyph,\r\n//                                  usually an open square.\r\n//\r\n//  NoWrap                        - Disables wrapping of text between lines\r\n//                                  when formatting within a rectangle.\r\n//                                  NoWrap is implied when a point is passed\r\n//                                  instead of a rectangle, or when the\r\n//                                  specified rectangle has a zero line length.\r\n//\r\n//  NoClip                        - By default text is clipped to the\r\n//                                  formatting rectangle. Setting NoClip\r\n//                                  allows overhanging pixels to affect the\r\n//                                  device outside the formatting rectangle.\r\n//                                  Pixels at the end of the line may be\r\n//                                  affected if the glyphs overhang their\r\n//                                  cells, and either the NoFitBlackBox flag\r\n//                                  has been set, or the glyph extends to far\r\n//                                  to be fitted.\r\n//                                  Pixels above/before the first line or\r\n//                                  below/after the last line may be affected\r\n//                                  if the glyphs extend beyond their cell\r\n//                                  ascent / descent. This can occur rarely\r\n//                                  with unusual diacritic mark combinations.\r\n\r\n//---------------------------------------------------------------------------\r\n\r\ntype\r\n  TGPStringFormatFlag = (\r\n    StringFormatFlagsDirectionRightToLeft  = 0,\r\n    StringFormatFlagsDirectionVertical     = 1,\r\n    StringFormatFlagsNoFitBlackBox         = 2,\r\n    StringFormatFlagsDisplayFormatControl  = 5,\r\n    StringFormatFlagsNoFontFallback        = 10,\r\n    StringFormatFlagsMeasureTrailingSpaces = 11,\r\n    StringFormatFlagsNoWrap                = 12,\r\n    StringFormatFlagsLineLimit             = 13,\r\n\r\n    StringFormatFlagsNoClip                = 14,\r\n    StringFormatFlagsBypassGDI             = 31);\r\n  TGPStringFormatFlags = set of TGPStringFormatFlag;\r\n\r\n//---------------------------------------------------------------------------\r\n// StringTrimming\r\n//---------------------------------------------------------------------------\r\n\r\ntype\r\n  TGPStringTrimming = (\r\n    StringTrimmingNone              = 0,\r\n    StringTrimmingCharacter         = 1,\r\n    StringTrimmingWord              = 2,\r\n    StringTrimmingEllipsisCharacter = 3,\r\n    StringTrimmingEllipsisWord      = 4,\r\n    StringTrimmingEllipsisPath      = 5);\r\n\r\n//---------------------------------------------------------------------------\r\n// National language digit substitution\r\n//---------------------------------------------------------------------------\r\n\r\ntype\r\n  TGPStringDigitSubstitute = (\r\n    StringDigitSubstituteUser        = 0,  // As NLS setting\r\n    StringDigitSubstituteNone        = 1,\r\n    StringDigitSubstituteNational    = 2,\r\n    StringDigitSubstituteTraditional = 3);\r\n  PGPStringDigitSubstitute = ^TGPStringDigitSubstitute;\r\n\r\n//---------------------------------------------------------------------------\r\n// Hotkey prefix interpretation\r\n//---------------------------------------------------------------------------\r\n\r\ntype\r\n  TGPHotkeyPrefix = (\r\n    HotkeyPrefixNone        = 0,\r\n    HotkeyPrefixShow        = 1,\r\n    HotkeyPrefixHide        = 2);\r\n\r\n//---------------------------------------------------------------------------\r\n// String alignment flags\r\n//---------------------------------------------------------------------------\r\n\r\ntype\r\n  TGPStringAlignment = (\r\n    // Left edge for left-to-right text,\r\n    // right for right-to-left text,\r\n    // and top for vertical\r\n    StringAlignmentNear   = 0,\r\n    StringAlignmentCenter = 1,\r\n    StringAlignmentFar    = 2);\r\n\r\n//---------------------------------------------------------------------------\r\n// DriverStringOptions\r\n//---------------------------------------------------------------------------\r\n\r\ntype\r\n  TGPDriverStringOption = (\r\n    DriverStringOptionsCmapLookup             = 0,\r\n    DriverStringOptionsVertical               = 1,\r\n    DriverStringOptionsRealizedAdvance        = 2,\r\n    DriverStringOptionsLimitSubpixel          = 3,\r\n    DriverStringOptionsReserved               = 31);\r\n  TGPDriverStringOptions = set of TGPDriverStringOption;\r\n\r\n//---------------------------------------------------------------------------\r\n// Flush Intention flags\r\n//---------------------------------------------------------------------------\r\n\r\ntype\r\n  TGPFlushIntention = (\r\n    FlushIntentionFlush = 0,        // Flush all batched rendering operations\r\n    FlushIntentionSync = 1);        // Flush all batched rendering operations\r\n                                    // and wait for them to complete\r\n\r\n//---------------------------------------------------------------------------\r\n// Image encoder parameter related types\r\n//---------------------------------------------------------------------------\r\n\r\ntype\r\n  TGPEncoderParameterValueType = (\r\n    EncoderParameterValueTypeByte           = 1,    // 8-bit unsigned int\r\n    EncoderParameterValueTypeASCII          = 2,    // 8-bit byte containing one 7-bit ASCII\r\n                                                    // code. NULL terminated.\r\n    EncoderParameterValueTypeShort          = 3,    // 16-bit unsigned int\r\n    EncoderParameterValueTypeLong           = 4,    // 32-bit unsigned int\r\n    EncoderParameterValueTypeRational       = 5,    // Two Longs. The first Long is the\r\n                                                    // numerator, the second Long expresses the\r\n                                                    // denomintor.\r\n    EncoderParameterValueTypeLongRange      = 6,    // Two longs which specify a range of\r\n                                                    // integer values. The first Long specifies\r\n                                                    // the lower end and the second one\r\n                                                    // specifies the higher end. All values\r\n                                                    // are inclusive at both ends\r\n    EncoderParameterValueTypeUndefined      = 7,    // 8-bit byte that can take any value\r\n                                                    // depending on field definition\r\n    EncoderParameterValueTypeRationalRange  = 8     // Two Rationals. The first Rational\r\n                                                    // specifies the lower end and the second\r\n                                                    // specifies the higher end. All values\r\n                                                    // are inclusive at both ends\r\n    {$IF (GDIPVER >= $0110)}\r\n    ,\r\n    EncoderParameterValueTypePointer        = 9     // a pointer to a parameter defined data.\r\n    {$IFEND}\r\n    );\r\n\r\n//---------------------------------------------------------------------------\r\n// Image encoder value types\r\n//---------------------------------------------------------------------------\r\n\r\ntype\r\n  TGPEncoderValue = (\r\n    EncoderValueColorTypeCMYK,\r\n    EncoderValueColorTypeYCCK,\r\n    EncoderValueCompressionLZW,\r\n    EncoderValueCompressionCCITT3,\r\n    EncoderValueCompressionCCITT4,\r\n    EncoderValueCompressionRle,\r\n    EncoderValueCompressionNone,\r\n    EncoderValueScanMethodInterlaced,\r\n    EncoderValueScanMethodNonInterlaced,\r\n    EncoderValueVersionGif87,\r\n    EncoderValueVersionGif89,\r\n    EncoderValueRenderProgressive,\r\n    EncoderValueRenderNonProgressive,\r\n    EncoderValueTransformRotate90,\r\n    EncoderValueTransformRotate180,\r\n    EncoderValueTransformRotate270,\r\n    EncoderValueTransformFlipHorizontal,\r\n    EncoderValueTransformFlipVertical,\r\n    EncoderValueMultiFrame,\r\n    EncoderValueLastFrame,\r\n    EncoderValueFlush,\r\n    EncoderValueFrameDimensionTime,\r\n    EncoderValueFrameDimensionResolution,\r\n    EncoderValueFrameDimensionPage\r\n    {$IF (GDIPVER >= $0110)}\r\n    ,\r\n    EncoderValueColorTypeGray,\r\n    EncoderValueColorTypeRGB\r\n    {$IFEND}\r\n    );\r\n\r\n//---------------------------------------------------------------------------\r\n// Conversion of Emf To WMF Bits flags\r\n//---------------------------------------------------------------------------\r\n\r\ntype\r\n  TGPEmfToWmfBitsFlag = (\r\n    EmfToWmfBitsFlagsEmbedEmf         = 0,\r\n    EmfToWmfBitsFlagsIncludePlaceable = 1,\r\n    EmfToWmfBitsFlagsNoXORClip        = 2,\r\n    EmfToWmfBitsFlagsReserved         = 31);\r\n  TGPEmfToWmfBitsFlags = set of TGPEmfToWmfBitsFlag;\r\n\r\nconst\r\n  EmfToWmfBitsFlagsDefault = [];\r\n\r\n{$IF (GDIPVER >= $0110)}\r\n//---------------------------------------------------------------------------\r\n// Conversion of Emf To Emf+ Bits flags\r\n//---------------------------------------------------------------------------\r\n\r\ntype\r\n  TGPConvertToEmfPlusFlags = (\r\n    ConvertToEmfPlusFlagsRopUsed       = 0,\r\n    ConvertToEmfPlusFlagsText          = 1,\r\n    ConvertToEmfPlusFlagsInvalidRecord = 2);\r\n\r\nconst\r\n  ConvertToEmfPlusFlagsDefault = [];\r\n{$IFEND}\r\n\r\n//---------------------------------------------------------------------------\r\n// Test Control flags\r\n//---------------------------------------------------------------------------\r\n\r\ntype\r\n  TGPTestControlEnum = (\r\n    TestControlForceBilinear = 0,\r\n    TestControlNoICM = 1,\r\n    TestControlGetBuildNumber = 2);\r\n\r\n{$ENDREGION 'GdiplusEnums.h' }\r\n\r\n{$REGION 'GdiplusTypes.h'}\r\n(*****************************************************************************\r\n * GdiplusTypes.h\r\n * GDI+ Types\r\n *****************************************************************************)\r\n\r\n//--------------------------------------------------------------------------\r\n// Callback functions\r\n//--------------------------------------------------------------------------\r\n\r\ntype\r\n  TGPImageAbort = function(CallbackData: Pointer): BOOL; stdcall;\r\n  TGPDrawImageAbort = TGPImageAbort;\r\n  TGPGetThumbnailImageAbort = TGPImageAbort;\r\n\r\n// Callback for EnumerateMetafile methods.  The parameters are:\r\n\r\n//      recordType      WMF, EMF, or EMF+ record type\r\n//      flags           (always 0 for WMF/EMF records)\r\n//      dataSize        size of the record data (in bytes), or 0 if no data\r\n//      data            pointer to the record data, or NULL if no data\r\n//      callbackData    pointer to callbackData, if any\r\n\r\n// This method can then call Metafile::PlayRecord to play the\r\n// record that was just enumerated.  If this method  returns\r\n// FALSE, the enumeration process is aborted.  Otherwise, it continues.\r\n\r\ntype\r\n  TGPEnumerateMetafileProc= function (RecordType: TEmfPlusRecordType;\r\n    Flags, DataSize: UINT; Data: PByte; CallbackData: Pointer): BOOL; stdcall;\r\n\r\n{$IF (GDIPVER >= $0110)}\r\n// This is the main GDI+ Abort interface\r\n\r\ntype\r\n  TGdiplusAbort = record\r\n    Abort: function: HRESULT of object;\r\n  end;\r\n  PGdiplusAbort = ^TGdiplusAbort;\r\n{$IFEND}\r\n\r\n//--------------------------------------------------------------------------\r\n// Primitive data types\r\n//\r\n// NOTE:\r\n//  Types already defined in standard header files:\r\n//      INT8\r\n//      UINT8\r\n//      INT16\r\n//      UINT16\r\n//      INT32\r\n//      UINT32\r\n//      INT64\r\n//      UINT64\r\n//\r\n//  Avoid using the following types:\r\n//      LONG - use INT\r\n//      ULONG - use UINT\r\n//      DWORD - use UINT32\r\n//--------------------------------------------------------------------------\r\n\r\nconst\r\n  REAL_MAX       = MaxSingle;\r\n  REAL_MIN       = MinSingle;\r\n  REAL_TOLERANCE = (MinSingle * 100);\r\n  REAL_EPSILON   = 1.192092896e-07; // FLT_EPSILON\r\n\r\n//--------------------------------------------------------------------------\r\n// Status return values from GDI+ methods\r\n//--------------------------------------------------------------------------\r\n\r\ntype\r\n  TGPStatus = (\r\n    Ok = 0,\r\n    GenericError = 1,\r\n    InvalidParameter = 2,\r\n    OutOfMemory = 3,\r\n    ObjectBusy = 4,\r\n    InsufficientBuffer = 5,\r\n    NotImplemented = 6,\r\n    Win32Error = 7,\r\n    WrongState = 8,\r\n    Aborted = 9,\r\n    FileNotFound = 10,\r\n    ValueOverflow = 11,\r\n    AccessDenied = 12,\r\n    UnknownImageFormat = 13,\r\n    FontFamilyNotFound = 14,\r\n    FontStyleNotFound = 15,\r\n    NotTrueTypeFont = 16,\r\n    UnsupportedGdiplusVersion = 17,\r\n    GdiplusNotInitialized = 18,\r\n    PropertyNotFound = 19,\r\n    PropertyNotSupported = 20\r\n    {$IF (GDIPVER >= $0110)}\r\n    ,\r\n    ProfileNotFound = 21\r\n    {$IFEND}\r\n    );\r\n\r\n//--------------------------------------------------------------------------\r\n// Represents a dimension in a 2D coordinate system (floating-point coordinates)\r\n//--------------------------------------------------------------------------\r\n\r\ntype\r\n  TGPSizeF = record\r\n  public\r\n    Width: Single;\r\n    Height: Single;\r\n  public\r\n    procedure Initialize; overload;\r\n    procedure Initialize(const Size: TGPSizeF); overload;\r\n    procedure Initialize(const AWidth, AHeight: Single); overload;\r\n    class function Create(const Size: TGPSizeF): TGPSizeF; overload; static;\r\n    class function Create(const AWidth, AHeight: Single): TGPSizeF; overload; static;\r\n    class operator Add(const A, B: TGPSizeF): TGPSizeF;\r\n    class operator Subtract(const A, B: TGPSizeF): TGPSizeF;\r\n    function Empty: Boolean;\r\n    function Equals(const Size: TGPSizeF): Boolean;\r\n  end;\r\n  PGPSizeF = ^TGPSizeF;\r\n\r\n//--------------------------------------------------------------------------\r\n// Represents a dimension in a 2D coordinate system (integer coordinates)\r\n//--------------------------------------------------------------------------\r\n\r\ntype\r\n  TGPSize = record\r\n  public\r\n    Width: Integer;\r\n    Height: Integer;\r\n  public\r\n    procedure Initialize; overload;\r\n    procedure Initialize(const Size: TGPSize); overload;\r\n    procedure Initialize(const AWidth, AHeight: Integer); overload;\r\n    class function Create(const Size: TGPSize): TGPSize; overload; static;\r\n    class function Create(const AWidth, AHeight: Integer): TGPSize; overload; static;\r\n    class operator Add(const A, B: TGPSize): TGPSize;\r\n    class operator Subtract(const A, B: TGPSize): TGPSize;\r\n    function Empty: Boolean;\r\n    function Equals(const Size: TGPSize): Boolean;\r\n  end;\r\n  PGPSize = ^TGPSize;\r\n\r\n//--------------------------------------------------------------------------\r\n// Represents a location in a 2D coordinate system (floating-point coordinates)\r\n//--------------------------------------------------------------------------\r\n\r\ntype\r\n  TGPPointF = record\r\n  public\r\n    X: Single;\r\n    Y: Single;\r\n  public\r\n    procedure Initialize; overload;\r\n    procedure Initialize(const Point: TGPPointF); overload;\r\n    procedure Initialize(const Size: TGPSizeF); overload;\r\n    procedure Initialize(const AX, AY: Single); overload;\r\n    class function Create(const Point: TGPPointF): TGPPointF; overload; static;\r\n    class function Create(const Size: TGPSizeF): TGPPointF; overload; static;\r\n    class function Create(const AX, AY: Single): TGPPointF; overload; static;\r\n    class operator Add(const A, B: TGPPointF): TGPPointF;\r\n    class operator Subtract(const A, B: TGPPointF): TGPPointF;\r\n    function Equals(const Point: TGPPointF): Boolean;\r\n  end;\r\n  PGPPointF = ^TGPPointF;\r\n\r\n//--------------------------------------------------------------------------\r\n// Represents a location in a 2D coordinate system (integer coordinates)\r\n//--------------------------------------------------------------------------\r\n\r\ntype\r\n  TGPPoint = record\r\n  public\r\n    X: Integer;\r\n    Y: Integer;\r\n  public\r\n    procedure Initialize; overload;\r\n    procedure Initialize(const Point: TGPPoint); overload;\r\n    procedure Initialize(const Size: TGPSize); overload;\r\n    procedure Initialize(const AX, AY: Integer); overload;\r\n    class function Create(const Point: TGPPoint): TGPPoint; overload; static;\r\n    class function Create(const Size: TGPSize): TGPPoint; overload; static;\r\n    class function Create(const AX, AY: Integer): TGPPoint; overload; static;\r\n    class operator Add(const A, B: TGPPoint): TGPPoint;\r\n    class operator Subtract(const A, B: TGPPoint): TGPPoint;\r\n    function Equals(const Point: TGPPoint): Boolean;\r\n  end;\r\n  PGPPoint = ^TGPPoint;\r\n\r\n//--------------------------------------------------------------------------\r\n// Represents a rectangle in a 2D coordinate system (floating-point coordinates)\r\n//--------------------------------------------------------------------------\r\n\r\ntype\r\n  PGPRectF = ^TGPRectF;\r\n  TGPRectF = record\r\n  public\r\n    X: Single;\r\n    Y: Single;\r\n    Width: Single;\r\n    Height: Single;\r\n  private\r\n    function GetLocation: TGPPointF;\r\n    function GetSize: TGPSizeF;\r\n    function GetBounds: TGPRectF;\r\n    function GetRight: Single;\r\n    function GetBottom: Single;\r\n  public\r\n    procedure Initialize; overload;\r\n    procedure Initialize(const AX, AY, AWidth, AHeight: Single); overload;\r\n    procedure Initialize(const Location: TGPPointF; const Size: TGPSizeF); overload;\r\n    procedure InitializeFromLTRB(const Left, Top, Right, Bottom: Single);\r\n    class function Create(const AX, AY, AWidth, AHeight: Single): TGPRectF; overload; static;\r\n    class function Create(const Location: TGPPointF; const Size: TGPSizeF): TGPRectF; overload; static;\r\n    function Clone: TGPRectF;\r\n    function IsEmptyArea: Boolean;\r\n    function Equals(const Rect: TGPRectF): Boolean;\r\n    function Contains(const AX, AY: Single): Boolean; overload;\r\n    function Contains(const Point: TGPPointF): Boolean; overload;\r\n    function Contains(const Rect: TGPRectF): Boolean; overload;\r\n    procedure Inflate(const DX, DY: Single); overload;\r\n    procedure Inflate(const DXY: Single); overload;\r\n    procedure Inflate(const Point: TGPPointF); overload;\r\n    function Intersect(const Rect: TGPRectF): Boolean; overload;\r\n    class function Intersect(out C: TGPRectF; const A, B: TGPRectF): Boolean; overload; static;\r\n    function IntersectsWith(const Rect: TGPRectF): Boolean;\r\n    function Union(const Rect: TGPRectF): Boolean; overload;\r\n    class function Union(out C: TGPRectF; const A, B: TGPRectF): Boolean; overload; static;\r\n    procedure Offset(const Point: TGPPointF); overload;\r\n    procedure Offset(const DX, DY: Single); overload;\r\n\r\n    property Location: TGPPointF read GetLocation;\r\n    property Size: TGPSizeF read GetSize;\r\n    property Bounds: TGPRectF read GetBounds;\r\n    property Left: Single read X;\r\n    property Top: Single read Y;\r\n    property Right: Single read GetRight;\r\n    property Bottom: Single read GetBottom;\r\n  end;\r\n\r\n//--------------------------------------------------------------------------\r\n// Represents a rectangle in a 2D coordinate system (integer coordinates)\r\n//--------------------------------------------------------------------------\r\n\r\ntype\r\n  PGPRect = ^TGPRect;\r\n  TGPRect = record\r\n  public\r\n    X: Integer;\r\n    Y: Integer;\r\n    Width: Integer;\r\n    Height: Integer;\r\n  private\r\n    function GetLocation: TGPPoint; inline;\r\n    function GetSize: TGPSize; inline;\r\n    function GetBounds: TGPRect; inline;\r\n    function GetRight: Integer; inline;\r\n    function GetBottom: Integer; inline;\r\n  public\r\n    procedure Initialize; overload;\r\n    procedure Initialize(const AX, AY, AWidth, AHeight: Integer); overload;\r\n    procedure Initialize(const Location: TGPPoint; const Size: TGPSize); overload;\r\n    procedure Initialize(const Rect: Windows.TRect); overload;\r\n    procedure InitializeFromLTRB(const Left, Top, Right, Bottom: Integer);\r\n    class function Create(const AX, AY, AWidth, AHeight: Integer): TGPRect; overload; static;\r\n    class function Create(const Location: TGPPoint; const Size: TGPSize): TGPRect; overload; static;\r\n    class function Create(const Rect: Windows.TRect): TGPRect; overload; static;\r\n    function Clone: TGPRect;\r\n    function IsEmptyArea: Boolean;\r\n    function Equals(const Rect: TGPRect): Boolean;\r\n    function Contains(const AX, AY: Integer): Boolean; overload;\r\n    function Contains(const Point: TGPPoint): Boolean; overload;\r\n    function Contains(const Rect: TGPRect): Boolean; overload;\r\n    procedure Inflate(const DX, DY: Integer); overload;\r\n    procedure Inflate(const Point: TGPPoint); overload;\r\n    function Intersect(const Rect: TGPRect): Boolean; overload;\r\n    class function Intersect(out C: TGPRect; const A, B: TGPRect): Boolean; overload; static;\r\n    function IntersectsWith(const Rect: TGPRect): Boolean;\r\n    function Union(const Rect: TGPRect): Boolean; overload;\r\n    class function Union(out C: TGPRect; const A, B: TGPRect): Boolean; overload; static;\r\n    procedure Offset(const Point: TGPPoint); overload;\r\n    procedure Offset(const DX, DY: Integer); overload;\r\n\r\n    property Location: TGPPoint read GetLocation;\r\n    property Size: TGPSize read GetSize;\r\n    property Bounds: TGPRect read GetBounds;\r\n    property Left: Integer read X;\r\n    property Top: Integer read Y;\r\n    property Right: Integer read GetRight;\r\n    property Bottom: Integer read GetBottom;\r\n  end;\r\n\r\ntype\r\n  TGPNativePathData = record\r\n    Count: Integer;\r\n    Points: PGPPointF;\r\n    Types: PByte;\r\n  end;\r\n  PGPNativePathData = ^TGPNativePathData;\r\n\r\ntype\r\n  TGPCharacterRange = record\r\n  public\r\n    First: Integer;\r\n    Length: Integer;\r\n  public\r\n    procedure Initialize; overload;\r\n    procedure Initialize(const AFirst, ALength: Integer); overload;\r\n  end;\r\n  PGPCharacterRange = ^TGPCharacterRange;\r\n\r\n{$ENDREGION 'GdiplusTypes.h'}\r\n\r\n{$REGION 'GdiplusInit.h'}\r\n(*****************************************************************************\r\n * GdiplusInit.h\r\n * GDI+ Startup and Shutdown APIs\r\n *****************************************************************************)\r\n\r\ntype\r\n  TGPDebugEventLevel = (\r\n    DebugEventLevelFatal,\r\n    DebugEventLevelWarning);\r\n\r\n// Callback function that GDI+ can call, on debug builds, for assertions\r\n// and warnings.\r\n\r\ntype\r\n  TGPDebugEventProc = procedure(Level: TGPDebugEventLevel; Message: PAnsiChar); stdcall;\r\n\r\n// Notification functions which the user must call appropriately if\r\n// \"SuppressBackgroundThread\" (below) is set.\r\n\r\ntype\r\n  TGPNofificationHookProc = function(out Token: ULONG): TGPStatus; stdcall;\r\n  TGPNofificationUnhookProc = procedure(Token: ULONG); stdcall;\r\n\r\n// Input structure for GdiplusStartup()\r\n\r\ntype\r\n  TGdiplusStartupInput = record\r\n  public\r\n    GdiplusVersion: UInt32; // Must be 1  (or 2 for the Ex version)\r\n    DebugEventCallback: TGPDebugEventProc; // Ignored on free builds\r\n    SuppressBackgroundThread: BOOL; // FALSE unless you're prepared to call the hook/unhook functions properly\r\n    SuppressExternalCodecs: BOOL; // FALSE unless you want GDI+ only to use its internal image codecs.\r\n  public\r\n    procedure Intialize(const ADebugEventCallback: TGPDebugEventProc = nil;\r\n      const ASuppressBackgroundThread: Boolean = False;\r\n      const ASuppressExternalCodecs: Boolean = False);\r\n  end;\r\n  PGdiplusStartupInput = ^TGdiplusStartupInput;\r\n\r\n{$IF (GDIPVER >= $0110)}\r\ntype\r\n  TGdiplusStartupInputEx = record\r\n  public\r\n    { From TGdiplusStartupInput }\r\n    GdiplusVersion: UInt32;\r\n    DebugEventCallback: TGPDebugEventProc;\r\n    SuppressBackgroundThread: BOOL;\r\n    SuppressExternalCodecs: BOOL;\r\n    { New }\r\n    StartupParameters: Integer; // Do we not set the FPU rounding mode\r\n  public\r\n    procedure Intialize(const AStartupParameters: Integer = 0;\r\n      const ADebugEventCallback: TGPDebugEventProc = nil;\r\n      const ASuppressBackgroundThread: Boolean = False;\r\n      const ASuppressExternalCodecs: Boolean = False);\r\n  end;\r\n  PGdiplusStartupInputEx = ^TGdiplusStartupInputEx;\r\n\r\nconst\r\n  GdiplusStartupDefault = 0;\r\n  GdiplusStartupNoSetRound = 1;\r\n  GdiplusStartupSetPSValue = 2;\r\n  GdiplusStartupTransparencyMask = $FF000000;\r\n{$IFEND}\r\n\r\n// Output structure for GdiplusStartup()\r\n\r\ntype\r\n  TGdiplusStartupOutput = record\r\n    // The following 2 fields are NULL if SuppressBackgroundThread is FALSE.\r\n    // Otherwise, they are functions which must be called appropriately to\r\n    // replace the background thread.\r\n    //\r\n    // These should be called on the application's main message loop - i.e.\r\n    // a message loop which is active for the lifetime of GDI+.\r\n    // \"NotificationHook\" should be called before starting the loop,\r\n    // and \"NotificationUnhook\" should be called after the loop ends.\r\n    NotificationHook: TGPNofificationHookProc;\r\n    NotificationUnhook: TGPNofificationUnhookProc;\r\n  end;\r\n  PGdiplusStartupOutput = ^TGdiplusStartupOutput;\r\n\r\n// GDI+ initialization. Must not be called from DllMain - can cause deadlock.\r\n//\r\n// Must be called before GDI+ API's or constructors are used.\r\n//\r\n// token  - may not be NULL - accepts a token to be passed in the corresponding\r\n//          GdiplusShutdown call.\r\n// input  - may not be NULL\r\n// output - may be NULL only if input->SuppressBackgroundThread is FALSE.\r\n\r\nfunction GdiplusStartup(out Token: ULONG; const Input: PGdiplusStartupInput;\r\n  Output: PGdiplusStartupOutput): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n// GDI+ termination. Must be called before GDI+ is unloaded.\r\n// Must not be called from DllMain - can cause deadlock.\r\n//\r\n// GDI+ API's may not be called after GdiplusShutdown. Pay careful attention\r\n// to GDI+ object destructors.\r\n\r\nprocedure GdiplusShutdown(Token: ULONG); stdcall; external GdiPlusDll;\r\n{$ENDREGION 'GdiplusInit.h'}\r\n\r\n{$REGION 'GdiplusPixelFormats.h'}\r\n(*****************************************************************************\r\n * GdiplusPixelFormats.h\r\n * GDI+ Pixel Formats\r\n *****************************************************************************)\r\n\r\ntype\r\n  ARGB = UInt32;\r\n  ARGB64 = UInt64;\r\n  PARGB = ^ARGB;\r\n  PARGB64 = ^ARGB64;\r\n\r\nconst\r\n  ALPHA_SHIFT = 24;\r\n  RED_SHIFT   = 16;\r\n  GREEN_SHIFT = 8;\r\n  BLUE_SHIFT  = 0;\r\n  ALPHA_MASK  = ARGB($FF) shl ALPHA_SHIFT;\r\n\r\n// In-memory pixel data formats:\r\n// bits 0-7 = format index\r\n// bits 8-15 = pixel size (in bits)\r\n// bits 16-23 = flags\r\n// bits 24-31 = reserved\r\n\r\ntype\r\n  TGPPixelFormat = Integer;\r\n\r\nconst\r\n  PixelFormatIndexed         = $00010000; // Indexes into a palette\r\n  PixelFormatGDI             = $00020000; // Is a GDI-supported format\r\n  PixelFormatAlpha           = $00040000; // Has an alpha component\r\n  PixelFormatPAlpha          = $00080000; // Pre-multiplied alpha\r\n  PixelFormatExtended        = $00100000; // Extended color 16 bits/channel\r\n  PixelFormatCanonical       = $00200000;\r\n\r\n  PixelFormatUndefined       = 0;\r\n  PixelFormatDontCare        = 0;\r\n\r\n  PixelFormat1bppIndexed     = ( 1 or ( 1 shl 8) or PixelFormatIndexed or PixelFormatGDI);\r\n  PixelFormat4bppIndexed     = ( 2 or ( 4 shl 8) or PixelFormatIndexed or PixelFormatGDI);\r\n  PixelFormat8bppIndexed     = ( 3 or ( 8 shl 8) or PixelFormatIndexed or PixelFormatGDI);\r\n  PixelFormat16bppGrayScale  = ( 4 or (16 shl 8) or PixelFormatExtended);\r\n  PixelFormat16bppRGB555     = ( 5 or (16 shl 8) or PixelFormatGDI);\r\n  PixelFormat16bppRGB565     = ( 6 or (16 shl 8) or PixelFormatGDI);\r\n  PixelFormat16bppARGB1555   = ( 7 or (16 shl 8) or PixelFormatAlpha or PixelFormatGDI);\r\n  PixelFormat24bppRGB        = ( 8 or (24 shl 8) or PixelFormatGDI);\r\n  PixelFormat32bppRGB        = ( 9 or (32 shl 8) or PixelFormatGDI);\r\n  PixelFormat32bppARGB       = (10 or (32 shl 8) or PixelFormatAlpha or PixelFormatGDI or PixelFormatCanonical);\r\n  PixelFormat32bppPARGB      = (11 or (32 shl 8) or PixelFormatAlpha or PixelFormatPAlpha or PixelFormatGDI);\r\n  PixelFormat48bppRGB        = (12 or (48 shl 8) or PixelFormatExtended);\r\n  PixelFormat64bppARGB       = (13 or (64 shl 8) or PixelFormatAlpha  or PixelFormatCanonical or PixelFormatExtended);\r\n  PixelFormat64bppPARGB      = (14 or (64 shl 8) or PixelFormatAlpha  or PixelFormatPAlpha or PixelFormatExtended);\r\n  PixelFormat32bppCMYK       = (15 or (32 shl 8));\r\n  PixelFormatMax             = 16;\r\n\r\nfunction GetPixelFormatSize(const PixFmt: TGPPixelFormat): Integer; inline;\r\nfunction IsIndexedPixelFormat(const PixFmt: TGPPixelFormat): Boolean; inline;\r\nfunction IsAlphaPixelFormat(const PixFmt: TGPPixelFormat): Boolean; inline;\r\nfunction IsExtendedPixelFormat(const PixFmt: TGPPixelFormat): Boolean; inline;\r\n\r\n//--------------------------------------------------------------------------\r\n// Determine if the Pixel Format is Canonical format:\r\n//   PixelFormat32bppARGB\r\n//   PixelFormat32bppPARGB\r\n//   PixelFormat64bppARGB\r\n//   PixelFormat64bppPARGB\r\n//--------------------------------------------------------------------------\r\n\r\nfunction IsCanonicalPixelFormat(const PixFmt: TGPPixelFormat): Boolean; inline;\r\n\r\n{$IF (GDIPVER >= $0110)}\r\n//----------------------------------------------------------------------------\r\n// Color format conversion parameters\r\n//----------------------------------------------------------------------------\r\n\r\ntype\r\n  TGPPaletteType = (\r\n    // Arbitrary custom palette provided by caller.\r\n\r\n    PaletteTypeCustom           = 0,\r\n\r\n    // Optimal palette generated using a median-cut algorithm.\r\n\r\n    PaletteTypeOptimal        = 1,\r\n\r\n    // Black and white palette.\r\n\r\n    PaletteTypeFixedBW          = 2,\r\n\r\n    // Symmetric halftone palettes.\r\n    // Each of these halftone palettes will be a superset of the system palette.\r\n    // E.g. Halftone8 will have it's 8-color on-off primaries and the 16 system\r\n    // colors added. With duplicates removed, that leaves 16 colors.\r\n\r\n    PaletteTypeFixedHalftone8   = 3, // 8-color, on-off primaries\r\n    PaletteTypeFixedHalftone27  = 4, // 3 intensity levels of each color\r\n    PaletteTypeFixedHalftone64  = 5, // 4 intensity levels of each color\r\n    PaletteTypeFixedHalftone125 = 6, // 5 intensity levels of each color\r\n    PaletteTypeFixedHalftone216 = 7, // 6 intensity levels of each color\r\n\r\n    // Assymetric halftone palettes.\r\n    // These are somewhat less useful than the symmetric ones, but are\r\n    // included for completeness. These do not include all of the system\r\n    // colors.\r\n\r\n    PaletteTypeFixedHalftone252 = 8,  // 6-red, 7-green, 6-blue intensities\r\n    PaletteTypeFixedHalftone256 = 9); // 8-red, 8-green, 4-blue intensities\r\n\r\ntype\r\n  TGPDitherType = (\r\n    DitherTypeNone          = 0,\r\n\r\n    // Solid color - picks the nearest matching color with no attempt to\r\n    // halftone or dither. May be used on an arbitrary palette.\r\n\r\n    DitherTypeSolid         = 1,\r\n\r\n    // Ordered dithers and spiral dithers must be used with a fixed palette.\r\n\r\n    // NOTE: DitherOrdered4x4 is unique in that it may apply to 16bpp\r\n    // conversions also.\r\n\r\n    DitherTypeOrdered4x4    = 2,\r\n\r\n    DitherTypeOrdered8x8    = 3,\r\n    DitherTypeOrdered16x16  = 4,\r\n    DitherTypeSpiral4x4     = 5,\r\n    DitherTypeSpiral8x8     = 6,\r\n    DitherTypeDualSpiral4x4 = 7,\r\n    DitherTypeDualSpiral8x8 = 8,\r\n\r\n    // Error diffusion. May be used with any palette.\r\n\r\n    DitherTypeErrorDiffusion   = 9,\r\n\r\n    DitherTypeMax              = 10);\r\n{$IFEND}\r\n\r\ntype\r\n  TGPPaletteFlag = (\r\n    PaletteFlagsHasAlpha    = 0,\r\n    PaletteFlagsGrayScale   = 1,\r\n    PaletteFlagsHalftone    = 2,\r\n    PaletteFlagsReserved    = 31);\r\n  TGPPaletteFlags = set of TGPPaletteFlag;\r\n\r\ntype\r\n  TGPNativeColorPalette = record\r\n  public\r\n    Flags: TGPPaletteFlags;\r\n    Count: Integer;\r\n    // Entries: array [0..0] of ARGB;\r\n  end;\r\n  PGPNativeColorPalette = ^TGPNativeColorPalette;\r\n{$ENDREGION 'GdiplusPixelFormats.h'}\r\n\r\n{$REGION 'GdiplusColor.h'}\r\n(*****************************************************************************\r\n * GdiplusColor.h\r\n * GDI+ Color Object\r\n *****************************************************************************)\r\n\r\n//----------------------------------------------------------------------------\r\n// Color mode\r\n//----------------------------------------------------------------------------\r\n\r\ntype\r\n  TGPColorMode = (\r\n    ColorModeARGB32 = 0,\r\n    ColorModeARGB64 = 1);\r\n\r\n//----------------------------------------------------------------------------\r\n// Color Channel flags\r\n//----------------------------------------------------------------------------\r\n\r\ntype\r\n  TGPColorChannelFlags = (\r\n    ColorChannelFlagsC = 0,\r\n    ColorChannelFlagsM,\r\n    ColorChannelFlagsY,\r\n    ColorChannelFlagsK,\r\n    ColorChannelFlagsLast);\r\n\r\n//----------------------------------------------------------------------------\r\n// Color\r\n//----------------------------------------------------------------------------\r\n\r\ntype\r\n  TGPColor = record\r\n  private\r\n    FArgb: ARGB;\r\n  private\r\n    function GetAlpha: Byte;\r\n    procedure SetAlpha(const Value: Byte);\r\n    function GetRed: Byte;\r\n    procedure SetRed(const Value: Byte);\r\n    function GetGreen: Byte;\r\n    procedure SetGreen(const Value: Byte);\r\n    function GetBlue: Byte;\r\n    procedure SetBlue(const Value: Byte);\r\n    function GetColorRef: TColorRef;\r\n    procedure SetColorRef(const Value: TColorRef);\r\n  public\r\n    // Common color constants\r\n    const AliceBlue            = $FFF0F8FF;\r\n    const AntiqueWhite         = $FFFAEBD7;\r\n    const Aqua                 = $FF00FFFF;\r\n    const Aquamarine           = $FF7FFFD4;\r\n    const Azure                = $FFF0FFFF;\r\n    const Beige                = $FFF5F5DC;\r\n    const Bisque               = $FFFFE4C4;\r\n    const Black                = $FF000000;\r\n    const BlanchedAlmond       = $FFFFEBCD;\r\n    const Blue                 = $FF0000FF;\r\n    const BlueViolet           = $FF8A2BE2;\r\n    const Brown                = $FFA52A2A;\r\n    const BurlyWood            = $FFDEB887;\r\n    const CadetBlue            = $FF5F9EA0;\r\n    const Chartreuse           = $FF7FFF00;\r\n    const Chocolate            = $FFD2691E;\r\n    const Coral                = $FFFF7F50;\r\n    const CornflowerBlue       = $FF6495ED;\r\n    const Cornsilk             = $FFFFF8DC;\r\n    const Crimson              = $FFDC143C;\r\n    const Cyan                 = $FF00FFFF;\r\n    const DarkBlue             = $FF00008B;\r\n    const DarkCyan             = $FF008B8B;\r\n    const DarkGoldenrod        = $FFB8860B;\r\n    const DarkGray             = $FFA9A9A9;\r\n    const DarkGreen            = $FF006400;\r\n    const DarkKhaki            = $FFBDB76B;\r\n    const DarkMagenta          = $FF8B008B;\r\n    const DarkOliveGreen       = $FF556B2F;\r\n    const DarkOrange           = $FFFF8C00;\r\n    const DarkOrchid           = $FF9932CC;\r\n    const DarkRed              = $FF8B0000;\r\n    const DarkSalmon           = $FFE9967A;\r\n    const DarkSeaGreen         = $FF8FBC8B;\r\n    const DarkSlateBlue        = $FF483D8B;\r\n    const DarkSlateGray        = $FF2F4F4F;\r\n    const DarkTurquoise        = $FF00CED1;\r\n    const DarkViolet           = $FF9400D3;\r\n    const DeepPink             = $FFFF1493;\r\n    const DeepSkyBlue          = $FF00BFFF;\r\n    const DimGray              = $FF696969;\r\n    const DodgerBlue           = $FF1E90FF;\r\n    const Firebrick            = $FFB22222;\r\n    const FloralWhite          = $FFFFFAF0;\r\n    const ForestGreen          = $FF228B22;\r\n    const Fuchsia              = $FFFF00FF;\r\n    const Gainsboro            = $FFDCDCDC;\r\n    const GhostWhite           = $FFF8F8FF;\r\n    const Gold                 = $FFFFD700;\r\n    const Goldenrod            = $FFDAA520;\r\n    const Gray                 = $FF808080;\r\n    const Green                = $FF008000;\r\n    const GreenYellow          = $FFADFF2F;\r\n    const Honeydew             = $FFF0FFF0;\r\n    const HotPink              = $FFFF69B4;\r\n    const IndianRed            = $FFCD5C5C;\r\n    const Indigo               = $FF4B0082;\r\n    const Ivory                = $FFFFFFF0;\r\n    const Khaki                = $FFF0E68C;\r\n    const Lavender             = $FFE6E6FA;\r\n    const LavenderBlush        = $FFFFF0F5;\r\n    const LawnGreen            = $FF7CFC00;\r\n    const LemonChiffon         = $FFFFFACD;\r\n    const LightBlue            = $FFADD8E6;\r\n    const LightCoral           = $FFF08080;\r\n    const LightCyan            = $FFE0FFFF;\r\n    const LightGoldenrodYellow = $FFFAFAD2;\r\n    const LightGray            = $FFD3D3D3;\r\n    const LightGreen           = $FF90EE90;\r\n    const LightPink            = $FFFFB6C1;\r\n    const LightSalmon          = $FFFFA07A;\r\n    const LightSeaGreen        = $FF20B2AA;\r\n    const LightSkyBlue         = $FF87CEFA;\r\n    const LightSlateGray       = $FF778899;\r\n    const LightSteelBlue       = $FFB0C4DE;\r\n    const LightYellow          = $FFFFFFE0;\r\n    const Lime                 = $FF00FF00;\r\n    const LimeGreen            = $FF32CD32;\r\n    const Linen                = $FFFAF0E6;\r\n    const Magenta              = $FFFF00FF;\r\n    const Maroon               = $FF800000;\r\n    const MediumAquamarine     = $FF66CDAA;\r\n    const MediumBlue           = $FF0000CD;\r\n    const MediumOrchid         = $FFBA55D3;\r\n    const MediumPurple         = $FF9370DB;\r\n    const MediumSeaGreen       = $FF3CB371;\r\n    const MediumSlateBlue      = $FF7B68EE;\r\n    const MediumSpringGreen    = $FF00FA9A;\r\n    const MediumTurquoise      = $FF48D1CC;\r\n    const MediumVioletRed      = $FFC71585;\r\n    const MidnightBlue         = $FF191970;\r\n    const MintCream            = $FFF5FFFA;\r\n    const MistyRose            = $FFFFE4E1;\r\n    const Moccasin             = $FFFFE4B5;\r\n    const NavajoWhite          = $FFFFDEAD;\r\n    const Navy                 = $FF000080;\r\n    const OldLace              = $FFFDF5E6;\r\n    const Olive                = $FF808000;\r\n    const OliveDrab            = $FF6B8E23;\r\n    const Orange               = $FFFFA500;\r\n    const OrangeRed            = $FFFF4500;\r\n    const Orchid               = $FFDA70D6;\r\n    const PaleGoldenrod        = $FFEEE8AA;\r\n    const PaleGreen            = $FF98FB98;\r\n    const PaleTurquoise        = $FFAFEEEE;\r\n    const PaleVioletRed        = $FFDB7093;\r\n    const PapayaWhip           = $FFFFEFD5;\r\n    const PeachPuff            = $FFFFDAB9;\r\n    const Peru                 = $FFCD853F;\r\n    const Pink                 = $FFFFC0CB;\r\n    const Plum                 = $FFDDA0DD;\r\n    const PowderBlue           = $FFB0E0E6;\r\n    const Purple               = $FF800080;\r\n    const Red                  = $FFFF0000;\r\n    const RosyBrown            = $FFBC8F8F;\r\n    const RoyalBlue            = $FF4169E1;\r\n    const SaddleBrown          = $FF8B4513;\r\n    const Salmon               = $FFFA8072;\r\n    const SandyBrown           = $FFF4A460;\r\n    const SeaGreen             = $FF2E8B57;\r\n    const SeaShell             = $FFFFF5EE;\r\n    const Sienna               = $FFA0522D;\r\n    const Silver               = $FFC0C0C0;\r\n    const SkyBlue              = $FF87CEEB;\r\n    const SlateBlue            = $FF6A5ACD;\r\n    const SlateGray            = $FF708090;\r\n    const Snow                 = $FFFFFAFA;\r\n    const SpringGreen          = $FF00FF7F;\r\n    const SteelBlue            = $FF4682B4;\r\n    const Tan                  = $FFD2B48C;\r\n    const Teal                 = $FF008080;\r\n    const Thistle              = $FFD8BFD8;\r\n    const Tomato               = $FFFF6347;\r\n    const Transparent          = $00FFFFFF;\r\n    const Turquoise            = $FF40E0D0;\r\n    const Violet               = $FFEE82EE;\r\n    const Wheat                = $FFF5DEB3;\r\n    const White                = $FFFFFFFF;\r\n    const WhiteSmoke           = $FFF5F5F5;\r\n    const Yellow               = $FFFFFF00;\r\n    const YellowGreen          = $FF9ACD32;\r\n\r\n    // Shift count and bit mask for A, R, G, B components\r\n    const AlphaShift = 24;\r\n    const RedShift   = 16;\r\n    const GreenShift = 8;\r\n    const BlueShift  = 0;\r\n\r\n    const AlphaMask  = $FF000000;\r\n    const RedMask    = $00FF0000;\r\n    const GreenMask  = $0000FF00;\r\n    const BlueMask   = $000000FF;\r\n  public\r\n    procedure Initialize; overload;\r\n\r\n    // Construct an opaque Color object with\r\n    // the specified Red, Green, Blue values.\r\n    //\r\n    // Color values are not premultiplied.\r\n    procedure Initialize(const R, G, B: Byte); overload;\r\n    procedure Initialize(const A, R, G, B: Byte); overload;\r\n    procedure Initialize(const AArgb: ARGB); overload;\r\n    procedure InitializeFromColorRef(const ColorRef: TColorRef);\r\n\r\n    class operator Implicit(const AArgb: ARGB): TGPColor;\r\n    class operator Implicit(const Color: TGPColor): ARGB;\r\n    class function MakeARGB(const A, R, G, B: Byte): ARGB; static;\r\n    class function Create(const R, G, B: Byte): TGPColor; overload; static;\r\n    class function Create(const A, R, G, B: Byte): TGPColor; overload; static;\r\n    class function Create(const AArgb: ARGB): TGPColor; overload; static;\r\n    class function Create(const Color: TColor): TGPColor; overload; static;\r\n    class function CreateFromColorRef(const ColorRef: TColorRef): TGPColor; overload; static;\r\n\r\n    property Alpha: Byte read GetAlpha write SetAlpha;\r\n    property A: Byte read GetAlpha write SetAlpha;\r\n    property R: Byte read GetRed write SetRed;\r\n    property G: Byte read GetGreen write SetGreen;\r\n    property B: Byte read GetBlue write SetBlue;\r\n    property Value: ARGB read FArgb write FArgb;\r\n    property ColorRef: TColorRef read GetColorRef write SetColorRef;\r\n  end;\r\n  PGPColor = ^TGPColor;\r\n{$ENDREGION 'GdiplusColor.h'}\r\n\r\n{$REGION 'GdiplusMetaHeader.h'}\r\n(*****************************************************************************\r\n * GdiplusMetaHeader.h\r\n * GDI+ Metafile Related Structures\r\n *****************************************************************************)\r\n\r\ntype\r\n  TEnhMetaHeader3 = record\r\n    iType: DWORD;               // Record type EMR_HEADER\r\n    nSize: DWORD;               // Record size in bytes.  This may be greater\r\n                                // than the sizeof(ENHMETAHEADER).\r\n    rclBounds: Windows.TRect;   // Inclusive-inclusive bounds in device units\r\n    rclFrame: Windows.TRect;    // Inclusive-inclusive Picture Frame .01mm unit\r\n    dSignature: DWORD;          // Signature.  Must be ENHMETA_SIGNATURE.\r\n    nVersion: DWORD;            // Version number\r\n    nBytes: DWORD;              // Size of the metafile in bytes\r\n    nRecords: DWORD;            // Number of records in the metafile\r\n    nHandles: WORD;             // Number of handles in the handle table\r\n                                // Handle index zero is reserved.\r\n    sReserved: WORD;            // Reserved.  Must be zero.\r\n    nDescription: DWORD;        // Number of chars in the unicode desc string\r\n                                // This is 0 if there is no description string\r\n    offDescription: DWORD;      // Offset to the metafile description record.\r\n                                // This is 0 if there is no description string\r\n    nPalEntries: DWORD;         // Number of entries in the metafile palette.\r\n    szlDevice: Windows.TSize;   // Size of the reference device in pels\r\n    szlMillimeters: Windows.TSize; // Size of the reference device in millimeters\r\n  end;\r\n  PEnhMetaHeader3 = ^TEnhMetaHeader3;\r\n\r\n// Placeable WMFs\r\n\r\n// Placeable Metafiles were created as a non-standard way of specifying how\r\n// a metafile is mapped and scaled on an output device.\r\n// Placeable metafiles are quite wide-spread, but not directly supported by\r\n// the Windows API. To playback a placeable metafile using the Windows API,\r\n// you will first need to strip the placeable metafile header from the file.\r\n// This is typically performed by copying the metafile to a temporary file\r\n// starting at file offset 22 (0x16). The contents of the temporary file may\r\n// then be used as input to the Windows GetMetaFile(), PlayMetaFile(),\r\n// CopyMetaFile(), etc. GDI functions.\r\n\r\n// Each placeable metafile begins with a 22-byte header,\r\n//  followed by a standard metafile:\r\n\r\ntype\r\n  TPWMFRect16 = packed record\r\n    Left: Int16;\r\n    Top: Int16;\r\n    Right: Int16;\r\n    Bottom: Int16;\r\n  end;\r\n  PPWMFRect16 = ^TPWMFRect16;\r\n\r\ntype\r\n  TWmfPlaceableFileHeader = packed record\r\n    Key: UInt32;                 // GDIP_WMF_PLACEABLEKEY\r\n    Hmf: Int16;                  // Metafile HANDLE number (always 0)\r\n    BoundingBox: TPWMFRect16;    // Coordinates in metafile units\r\n    Inch: Int16;                 // Number of metafile units per inch\r\n    Reserved: UInt32;            // Reserved (always 0)\r\n    Checksum: Int16;             // Checksum value for previous 10 WORDs\r\n  end;\r\n  PWmfPlaceableFileHeader = ^TWmfPlaceableFileHeader;\r\n\r\n// Key contains a special identification value that indicates the presence\r\n// of a placeable metafile header and is always 0x9AC6CDD7.\r\n\r\n// Handle is used to stored the handle of the metafile in memory. When written\r\n// to disk, this field is not used and will always contains the value 0.\r\n\r\n// Left, Top, Right, and Bottom contain the coordinates of the upper-left\r\n// and lower-right corners of the image on the output device. These are\r\n// measured in twips.\r\n\r\n// A twip (meaning \"twentieth of a point\") is the logical unit of measurement\r\n// used in Windows Metafiles. A twip is equal to 1/1440 of an inch. Thus 720\r\n// twips equal 1/2 inch, while 32,768 twips is 22.75 inches.\r\n\r\n// Inch contains the number of twips per inch used to represent the image.\r\n// Normally, there are 1440 twips per inch; however, this number may be\r\n// changed to scale the image. A value of 720 indicates that the image is\r\n// double its normal size, or scaled to a factor of 2:1. A value of 360\r\n// indicates a scale of 4:1, while a value of 2880 indicates that the image\r\n// is scaled down in size by a factor of two. A value of 1440 indicates\r\n// a 1:1 scale ratio.\r\n\r\n// Reserved is not used and is always set to 0.\r\n\r\n// Checksum contains a checksum value for the previous 10 WORDs in the header.\r\n// This value can be used in an attempt to detect if the metafile has become\r\n// corrupted. The checksum is calculated by XORing each WORD value to an\r\n// initial value of 0.\r\n\r\n// If the metafile was recorded with a reference Hdc that was a display.\r\n\r\nconst\r\n  GDIP_EMFPLUSFLAGS_DISPLAY = $00000001;\r\n\r\ntype\r\n  TGPMetafileHeader = record\r\n  private\r\n    type\r\n      THeader = record\r\n        case Integer of\r\n          0: (WmfHeader: TMetaHeader);\r\n          1: (EmfHeader: TEnhMetaHeader3);\r\n      end;\r\n  private\r\n    FMetafileType: TGPMetafileType;\r\n    FSize: Cardinal;    // Size of the metafile (in bytes)\r\n    FVersion: Cardinal; // EMF+, EMF, or WMF version\r\n    FEmfPlusFlags: Cardinal;\r\n    FDpiX: Single;\r\n    FDpiY: Single;\r\n    FX: Integer;        // Bounds in device units\r\n    FY: Integer;\r\n    FWidth: Integer;\r\n    FHeight: Integer;\r\n    FHeader: THeader;\r\n    FEmfPlusHeaderSize: Integer; // size of the EMF+ header in file\r\n    FLogicalDpiX: Integer;       // Logical Dpi of reference Hdc\r\n    FLogicalDpiY: Integer;       // usually valid only for EMF+\r\n  private\r\n    function GetBounds: TGPRect;\r\n    function GetWmfHeader: PMetaHeader;\r\n    function GetEmfHeader: PEnhMetaHeader3;\r\n  public\r\n    // Is it any type of WMF (standard or Placeable Metafile)?\r\n    function IsWmf: Boolean;\r\n\r\n    // Is this an Placeable Metafile?\r\n    function IsWmfPlaceable: Boolean;\r\n\r\n    // Is this an EMF (not an EMF+)?\r\n    function IsEmf: Boolean;\r\n\r\n    // Is this an EMF or EMF+ file?\r\n    function IsEmfOrEmfPlus: Boolean;\r\n\r\n    // Is this an EMF+ file?\r\n    function IsEmfPlus: Boolean;\r\n\r\n    // Is this an EMF+ dual (has dual, down-level records) file?\r\n    function IsEmfPlusDual: Boolean;\r\n\r\n    // Is this an EMF+ only (no dual records) file?\r\n    function IsEmfPlusOnly: Boolean;\r\n\r\n    // If it's an EMF+ file, was it recorded against a display Hdc?\r\n    function IsDisplay: Boolean;\r\n\r\n    property MetafileType: TGPMetafileType read FMetafileType;\r\n    property MetafileSize: Cardinal read FSize;\r\n\r\n    // If IsEmfPlus, this is the EMF+ version; else it is the WMF or EMF ver\r\n    property Version: Cardinal read FVersion;\r\n\r\n    // Get the EMF+ flags associated with the metafile\r\n    property EmfPlusFlags: Cardinal read FEmfPlusFlags;\r\n\r\n    property DpiX: Single read FDpiX;\r\n    property DpiY: Single read FDpiY;\r\n    property Bounds: TGPRect read GetBounds;\r\n\r\n    // Get the WMF header of the metafile (if it is a WMF)\r\n    property WmfHeader: PMetaHeader read GetWmfHeader;\r\n\r\n    // Get the EMF header of the metafile (if it is an EMF)\r\n    property EmfHeader: PEnhMetaHeader3 read GetEmfHeader;\r\n\r\n    property EmfPlusHeaderSize: Integer read FEmfPlusHeaderSize;\r\n    property LogicalDpiX: Integer read FLogicalDpiX;\r\n    property LogicalDpiY: Integer read FLogicalDpiY;\r\n  end;\r\n  PGPMetafileHeader = ^TGPMetafileHeader;\r\n{$ENDREGION 'GdiplusMetaHeader.h'}\r\n\r\n{$REGION 'GdiplusImaging.h'}\r\n(*****************************************************************************\r\n * GdiplusImaging.h\r\n * GDI+ Imaging GUIDs\r\n *****************************************************************************)\r\n\r\n//---------------------------------------------------------------------------\r\n// Image file format identifiers\r\n//---------------------------------------------------------------------------\r\nconst\r\n  ImageFormatUndefined : TGUID = '{b96b3ca9-0728-11d3-9d7b-0000f81ef32e}';\r\n  ImageFormatMemoryBMP : TGUID = '{b96b3caa-0728-11d3-9d7b-0000f81ef32e}';\r\n  ImageFormatBMP       : TGUID = '{b96b3cab-0728-11d3-9d7b-0000f81ef32e}';\r\n  ImageFormatEMF       : TGUID = '{b96b3cac-0728-11d3-9d7b-0000f81ef32e}';\r\n  ImageFormatWMF       : TGUID = '{b96b3cad-0728-11d3-9d7b-0000f81ef32e}';\r\n  ImageFormatJPEG      : TGUID = '{b96b3cae-0728-11d3-9d7b-0000f81ef32e}';\r\n  ImageFormatPNG       : TGUID = '{b96b3caf-0728-11d3-9d7b-0000f81ef32e}';\r\n  ImageFormatGIF       : TGUID = '{b96b3cb0-0728-11d3-9d7b-0000f81ef32e}';\r\n  ImageFormatTIFF      : TGUID = '{b96b3cb1-0728-11d3-9d7b-0000f81ef32e}';\r\n  ImageFormatEXIF      : TGUID = '{b96b3cb2-0728-11d3-9d7b-0000f81ef32e}';\r\n  ImageFormatIcon      : TGUID = '{b96b3cb5-0728-11d3-9d7b-0000f81ef32e}';\r\n\r\n//---------------------------------------------------------------------------\r\n// Predefined multi-frame dimension IDs\r\n//---------------------------------------------------------------------------\r\n\r\nconst\r\n  FrameDimensionTime       : TGUID = '{6aedbd6d-3fb5-418a-83a6-7f45229dc872}';\r\n  FrameDimensionResolution : TGUID = '{84236f7b-3bd3-428f-8dab-4ea1439ca315}';\r\n  FrameDimensionPage       : TGUID = '{7462dc86-6180-4c7e-8e3f-ee7333a7a483}';\r\n\r\n//---------------------------------------------------------------------------\r\n// Property sets\r\n//---------------------------------------------------------------------------\r\n\r\nconst\r\n  FormatIDImageInformation : TGUID = '{e5836cbe-5eef-4f1d-acde-ae4c43b608ce}';\r\n  FormatIDJpegAppHeaders   : TGUID = '{1c4afdcd-6177-43cf-abc7-5f51af39ee85}';\r\n\r\n//---------------------------------------------------------------------------\r\n// Encoder parameter sets\r\n//---------------------------------------------------------------------------\r\n\r\nconst\r\n  EncoderCompression      : TGUID = '{e09d739d-ccd4-44ee-8eba-3fbf8be4fc58}';\r\n  EncoderColorDepth       : TGUID = '{66087055-ad66-4c7c-9a18-38a2310b8337}';\r\n  EncoderScanMethod       : TGUID = '{3a4e2661-3109-4e56-8536-42c156e7dcfa}';\r\n  EncoderVersion          : TGUID = '{24d18c76-814a-41a4-bf53-1c219cccf797}';\r\n  EncoderRenderMethod     : TGUID = '{6d42c53a-229a-4825-8bb7-5c99e2b9a8b8}';\r\n  EncoderQuality          : TGUID = '{1d5be4b5-fa4a-452d-9cdd-5db35105e7eb}';\r\n  EncoderTransformation   : TGUID = '{8d0eb2d1-a58e-4ea8-aa14-108074b7b6f9}';\r\n  EncoderLuminanceTable   : TGUID = '{edb33bce-0266-4a77-b904-27216099e717}';\r\n  EncoderChrominanceTable : TGUID = '{f2e455dc-09b3-4316-8260-676ada32481c}';\r\n  EncoderSaveFlag         : TGUID = '{292266fc-ac40-47bf-8cfc-a85b89a655de}';\r\n\r\n  {$IF (GDIPVER >= $0110)}\r\n  EncoderColorSpace       : TGUID = '{ae7a62a0-ee2c-49d8-9d07-1ba8a927596e}';\r\n  EncoderImageItems       : TGUID = '{63875e13-1f1d-45ab-9195-a29b6066a650}';\r\n  EncoderSaveAsCMYK       : TGUID = '{a219bbc9-0a9d-4005-a3ee-3a421b8bb06c}';\r\n  {$IFEND}\r\n\r\n  CodecIImageBytes        : TGUID = '{025d1823-6c7d-447b-bbdb-a3cbc3dfa2fc}';\r\n\r\ntype\r\n  IGPImageBytes = interface(IUnknown)\r\n  ['{025D1823-6C7D-447B-BBDB-A3CBC3DFA2FC}']\r\n    // Return total number of bytes in the IStream\r\n    function CountBytes(out Count: UINT): HRESULT; stdcall;\r\n\r\n    // Locks \"cb\" bytes, starting from \"ulOffset\" in the stream, and returns the\r\n    // pointer to the beginning of the locked memory chunk in \"ppvBytes\"\r\n    function LockBytes(Count: UINT; Offset: ULONG; out Bytes: Pointer): HResult; stdcall;\r\n\r\n    // Unlocks \"cb\" bytes, pointed by \"pvBytes\", starting from \"ulOffset\" in the\r\n    // stream\r\n    function UnlockBytes(const Bytes: Pointer; Count: UINT; Offset: ULONG): HResult; stdcall;\r\n  end;\r\n\r\n//--------------------------------------------------------------------------\r\n// Information flags about image codecs\r\n//--------------------------------------------------------------------------\r\n\r\ntype\r\n  TGPImageCodecFlag = (\r\n    ImageCodecFlagsEncoder            = 0,\r\n    ImageCodecFlagsDecoder            = 1,\r\n    ImageCodecFlagsSupportBitmap      = 2,\r\n    ImageCodecFlagsSupportVector      = 3,\r\n    ImageCodecFlagsSeekableEncode     = 4,\r\n    ImageCodecFlagsBlockingDecode     = 5,\r\n\r\n    ImageCodecFlagsBuiltin            = 16,\r\n    ImageCodecFlagsSystem             = 17,\r\n    ImageCodecFlagsUser               = 18);\r\n  TGPImageCodecFlags = set of TGPImageCodecFlag;\r\n\r\n//--------------------------------------------------------------------------\r\n// ImageCodecInfo structure\r\n//--------------------------------------------------------------------------\r\n\r\ntype\r\n  TGPNativeImageCodecInfo = record\r\n  public\r\n    ClsId: TGUID;\r\n    FormatId: TGUID;\r\n    CodecName: PWideChar;\r\n    DllName: PWideChar;\r\n    FormatDescription: PWideChar;\r\n    FilenameExtension: PWideChar;\r\n    MimeType: PWideChar;\r\n    Flags: TGPImageCodecFlags;\r\n    Version: DWORD;\r\n    SigCount: DWORD;\r\n    SigSize: DWORD;\r\n    SigPattern: PByte;\r\n    SigMask: PByte;\r\n  end;\r\n  PGPNativeImageCodecInfo = ^TGPNativeImageCodecInfo;\r\n\r\n//---------------------------------------------------------------------------\r\n// Access modes used when calling Image::LockBits\r\n//---------------------------------------------------------------------------\r\n\r\ntype\r\n  TGPImageLockModeOption = (\r\n    ImageLockModeRead         = 0,\r\n    ImageLockModeWrite        = 1,\r\n    ImageLockModeUserInputBuf = 2,\r\n    ImageLockModeReserved     = 31);\r\n\r\n  TGPImageLockMode = set of TGPImageLockModeOption;\r\n\r\n//---------------------------------------------------------------------------\r\n// Information about image pixel data\r\n//---------------------------------------------------------------------------\r\n\r\ntype\r\n  TGPBitmapData = record\r\n  public\r\n    Width: Cardinal;\r\n    Height: Cardinal;\r\n    Stride: Integer;\r\n    PixelFormat: TGPPixelFormat;\r\n    Scan0: Pointer;\r\n    Reserved: Cardinal;\r\n  end;\r\n  PGPBitmapData = ^TGPBitmapData;\r\n\r\n//---------------------------------------------------------------------------\r\n// Image flags\r\n//---------------------------------------------------------------------------\r\n\r\ntype\r\n  TGPImageFlag = (\r\n    // Low-word: shared with SINKFLAG_x\r\n\r\n    ImageFlagsScalable            = 0,\r\n    ImageFlagsHasAlpha            = 1,\r\n    ImageFlagsHasTranslucent      = 2,\r\n    ImageFlagsPartiallyScalable   = 3,\r\n\r\n    // Low-word: color space definition\r\n\r\n    ImageFlagsColorSpaceRGB       = 4,\r\n    ImageFlagsColorSpaceCMYK      = 5,\r\n    ImageFlagsColorSpaceGRAY      = 6,\r\n    ImageFlagsColorSpaceYCBCR     = 7,\r\n    ImageFlagsColorSpaceYCCK      = 8,\r\n\r\n    // Low-word: image size info\r\n\r\n    ImageFlagsHasRealDPI          = 12,\r\n    ImageFlagsHasRealPixelSize    = 13,\r\n\r\n    // High-word\r\n\r\n    ImageFlagsReadOnly            = 16,\r\n    ImageFlagsCaching             = 17);\r\n\r\n  TGPImageFlags = set of TGPImageFlag;\r\n\r\nconst\r\n  ImageFlagsNone = [];\r\n\r\ntype\r\n  TGPRotateFlipType = (\r\n    RotateNoneFlipNone = 0,\r\n    Rotate90FlipNone   = 1,\r\n    Rotate180FlipNone  = 2,\r\n    Rotate270FlipNone  = 3,\r\n\r\n    RotateNoneFlipX    = 4,\r\n    Rotate90FlipX      = 5,\r\n    Rotate180FlipX     = 6,\r\n    Rotate270FlipX     = 7,\r\n\r\n    RotateNoneFlipY    = Rotate180FlipX,\r\n    Rotate90FlipY      = Rotate270FlipX,\r\n    Rotate180FlipY     = RotateNoneFlipX,\r\n    Rotate270FlipY     = Rotate90FlipX,\r\n\r\n    RotateNoneFlipXY   = Rotate180FlipNone,\r\n    Rotate90FlipXY     = Rotate270FlipNone,\r\n    Rotate180FlipXY    = RotateNoneFlipNone,\r\n    Rotate270FlipXY    = Rotate90FlipNone);\r\n\r\n//---------------------------------------------------------------------------\r\n// Encoder Parameter structure\r\n//---------------------------------------------------------------------------\r\n\r\ntype\r\n  TGPNativeEncoderParameter = record\r\n  public\r\n    Guid: TGUID;               // GUID of the parameter\r\n    NumberOfValues: ULONG;     // Number of the parameter values\r\n    ValueType: TGPEncoderParameterValueType;  // Value type, like ValueTypeLONG  etc.\r\n    Value: Pointer;            // A pointer to the parameter values\r\n  end;\r\n  PGPNativeEncoderParameter = ^TGPNativeEncoderParameter;\r\n\r\n//---------------------------------------------------------------------------\r\n// Encoder Parameters structure\r\n//---------------------------------------------------------------------------\r\n\r\ntype\r\n  TGPNativeEncoderParameters = record\r\n  public\r\n    Count: Cardinal;  // Number of parameters in this structure\r\n    Parameter: array [0..0] of TGPNativeEncoderParameter; // Parameter values\r\n  end;\r\n  PGPNativeEncoderParameters = ^TGPNativeEncoderParameters;\r\n\r\n{$IF (GDIPVER >= $0110)}\r\ntype\r\n  TGPItemDataPosition = (\r\n    ItemDataPositionAfterHeader    = 0,\r\n    ItemDataPositionAfterPalette   = 1,\r\n    ItemDataPositionAfterBits      = 2);\r\n\r\n//---------------------------------------------------------------------------\r\n// External Data Item\r\n//---------------------------------------------------------------------------\r\n\r\ntype\r\n  TGPImageItemData = record\r\n  public\r\n    Size: Cardinal;       // size of the structure\r\n    Position: Cardinal;   // flags describing how the data is to be used.\r\n    Desc: Pointer;        // description on how the data is to be saved.\r\n                          // it is different for every codec type.\r\n    DescSize: Cardinal;   // size memory pointed by Desc\r\n    Data: Pointer;        // pointer to the data that is to be saved in the\r\n                          // file, could be anything saved directly.\r\n    DataSize: Cardinal;   // size memory pointed by Data\r\n    Cookie: Cardinal;     // opaque for the apps data member used during\r\n                          // enumeration of image data items.\r\n  end;\r\n  PGPImageItemData = ^TGPImageItemData;\r\n{$IFEND}\r\n\r\n//---------------------------------------------------------------------------\r\n// Property Item\r\n//---------------------------------------------------------------------------\r\n\r\ntype\r\n  TGPNativePropertyItem = record\r\n  public\r\n    Id: TPropID;                // ID of this property\r\n    Length: ULONG;              // Length of the property value, in bytes\r\n    ValueType: Word;            // Type of the value, as one of TAG_TYPE_XXX\r\n                                // defined above\r\n    Value: Pointer;             // property value\r\n  end;\r\n  PGPNativePropertyItem = ^TGPNativePropertyItem;\r\n\r\n//---------------------------------------------------------------------------\r\n// Image property types\r\n//---------------------------------------------------------------------------\r\n\r\nconst\r\n  PropertyTagTypeByte        = 1;\r\n  PropertyTagTypeASCII       = 2;\r\n  PropertyTagTypeShort       = 3;\r\n  PropertyTagTypeLong        = 4;\r\n  PropertyTagTypeRational    = 5;\r\n  PropertyTagTypeUndefined   = 7;\r\n  PropertyTagTypeSLONG       = 9;\r\n  PropertyTagTypeSRational  = 10;\r\n\r\n//---------------------------------------------------------------------------\r\n// Image property ID tags\r\n//---------------------------------------------------------------------------\r\n\r\n  PropertyTagExifIFD             = $8769;\r\n  PropertyTagGpsIFD              = $8825;\r\n\r\n  PropertyTagNewSubfileType      = $00FE;\r\n  PropertyTagSubfileType         = $00FF;\r\n  PropertyTagImageWidth          = $0100;\r\n  PropertyTagImageHeight         = $0101;\r\n  PropertyTagBitsPerSample       = $0102;\r\n  PropertyTagCompression         = $0103;\r\n  PropertyTagPhotometricInterp   = $0106;\r\n  PropertyTagThreshHolding       = $0107;\r\n  PropertyTagCellWidth           = $0108;\r\n  PropertyTagCellHeight          = $0109;\r\n  PropertyTagFillOrder           = $010A;\r\n  PropertyTagDocumentName        = $010D;\r\n  PropertyTagImageDescription    = $010E;\r\n  PropertyTagEquipMake           = $010F;\r\n  PropertyTagEquipModel          = $0110;\r\n  PropertyTagStripOffsets        = $0111;\r\n  PropertyTagOrientation         = $0112;\r\n  PropertyTagSamplesPerPixel     = $0115;\r\n  PropertyTagRowsPerStrip        = $0116;\r\n  PropertyTagStripBytesCount     = $0117;\r\n  PropertyTagMinSampleValue      = $0118;\r\n  PropertyTagMaxSampleValue      = $0119;\r\n  PropertyTagXResolution         = $011A;   // Image resolution in width direction\r\n  PropertyTagYResolution         = $011B;   // Image resolution in height direction\r\n  PropertyTagPlanarConfig        = $011C;   // Image data arrangement\r\n  PropertyTagPageName            = $011D;\r\n  PropertyTagXPosition           = $011E;\r\n  PropertyTagYPosition           = $011F;\r\n  PropertyTagFreeOffset          = $0120;\r\n  PropertyTagFreeByteCounts      = $0121;\r\n  PropertyTagGrayResponseUnit    = $0122;\r\n  PropertyTagGrayResponseCurve   = $0123;\r\n  PropertyTagT4Option            = $0124;\r\n  PropertyTagT6Option            = $0125;\r\n  PropertyTagResolutionUnit      = $0128;   // Unit of X and Y resolution\r\n  PropertyTagPageNumber          = $0129;\r\n  PropertyTagTransferFuncition   = $012D;\r\n  PropertyTagSoftwareUsed        = $0131;\r\n  PropertyTagDateTime            = $0132;\r\n  PropertyTagArtist              = $013B;\r\n  PropertyTagHostComputer        = $013C;\r\n  PropertyTagPredictor           = $013D;\r\n  PropertyTagWhitePoint          = $013E;\r\n  PropertyTagPrimaryChromaticities = $013F;\r\n  PropertyTagColorMap            = $0140;\r\n  PropertyTagHalftoneHints       = $0141;\r\n  PropertyTagTileWidth           = $0142;\r\n  PropertyTagTileLength          = $0143;\r\n  PropertyTagTileOffset          = $0144;\r\n  PropertyTagTileByteCounts      = $0145;\r\n  PropertyTagInkSet              = $014C;\r\n  PropertyTagInkNames            = $014D;\r\n  PropertyTagNumberOfInks        = $014E;\r\n  PropertyTagDotRange            = $0150;\r\n  PropertyTagTargetPrinter       = $0151;\r\n  PropertyTagExtraSamples        = $0152;\r\n  PropertyTagSampleFormat        = $0153;\r\n  PropertyTagSMinSampleValue     = $0154;\r\n  PropertyTagSMaxSampleValue     = $0155;\r\n  PropertyTagTransferRange       = $0156;\r\n\r\n  PropertyTagJPEGProc            = $0200;\r\n  PropertyTagJPEGInterFormat     = $0201;\r\n  PropertyTagJPEGInterLength     = $0202;\r\n  PropertyTagJPEGRestartInterval = $0203;\r\n  PropertyTagJPEGLosslessPredictors  = $0205;\r\n  PropertyTagJPEGPointTransforms     = $0206;\r\n  PropertyTagJPEGQTables         = $0207;\r\n  PropertyTagJPEGDCTables        = $0208;\r\n  PropertyTagJPEGACTables        = $0209;\r\n\r\n  PropertyTagYCbCrCoefficients   = $0211;\r\n  PropertyTagYCbCrSubsampling    = $0212;\r\n  PropertyTagYCbCrPositioning    = $0213;\r\n  PropertyTagREFBlackWhite       = $0214;\r\n\r\n  PropertyTagICCProfile          = $8773;   // This TAG is defined by ICC\r\n                                            // for embedded ICC in TIFF\r\n  PropertyTagGamma               = $0301;\r\n  PropertyTagICCProfileDescriptor = $0302;\r\n  PropertyTagSRGBRenderingIntent = $0303;\r\n\r\n  PropertyTagImageTitle          = $0320;\r\n  PropertyTagCopyright           = $8298;\r\n\r\n// Extra TAGs (Like Adobe Image Information tags etc.)\r\n\r\n  PropertyTagResolutionXUnit           = $5001;\r\n  PropertyTagResolutionYUnit           = $5002;\r\n  PropertyTagResolutionXLengthUnit     = $5003;\r\n  PropertyTagResolutionYLengthUnit     = $5004;\r\n  PropertyTagPrintFlags                = $5005;\r\n  PropertyTagPrintFlagsVersion         = $5006;\r\n  PropertyTagPrintFlagsCrop            = $5007;\r\n  PropertyTagPrintFlagsBleedWidth      = $5008;\r\n  PropertyTagPrintFlagsBleedWidthScale = $5009;\r\n  PropertyTagHalftoneLPI               = $500A;\r\n  PropertyTagHalftoneLPIUnit           = $500B;\r\n  PropertyTagHalftoneDegree            = $500C;\r\n  PropertyTagHalftoneShape             = $500D;\r\n  PropertyTagHalftoneMisc              = $500E;\r\n  PropertyTagHalftoneScreen            = $500F;\r\n  PropertyTagJPEGQuality               = $5010;\r\n  PropertyTagGridSize                  = $5011;\r\n  PropertyTagThumbnailFormat           = $5012; // 1 = JPEG, 0 = RAW RGB\r\n  PropertyTagThumbnailWidth            = $5013;\r\n  PropertyTagThumbnailHeight           = $5014;\r\n  PropertyTagThumbnailColorDepth       = $5015;\r\n  PropertyTagThumbnailPlanes           = $5016;\r\n  PropertyTagThumbnailRawBytes         = $5017;\r\n  PropertyTagThumbnailSize             = $5018;\r\n  PropertyTagThumbnailCompressedSize   = $5019;\r\n  PropertyTagColorTransferFunction     = $501A;\r\n  PropertyTagThumbnailData             = $501B; // RAW thumbnail bits in\r\n                                                // JPEG format or RGB format\r\n                                                // depends on\r\n                                                // PropertyTagThumbnailFormat\r\n\r\n// Thumbnail related TAGs\r\n\r\n  PropertyTagThumbnailImageWidth       = $5020;  // Thumbnail width\r\n  PropertyTagThumbnailImageHeight      = $5021;  // Thumbnail height\r\n  PropertyTagThumbnailBitsPerSample    = $5022;  // Number of bits per\r\n                                                 // component\r\n  PropertyTagThumbnailCompression      = $5023;  // Compression Scheme\r\n  PropertyTagThumbnailPhotometricInterp = $5024; // Pixel composition\r\n  PropertyTagThumbnailImageDescription = $5025;  // Image Tile\r\n  PropertyTagThumbnailEquipMake        = $5026;  // Manufacturer of Image\r\n                                                 // Input equipment\r\n  PropertyTagThumbnailEquipModel       = $5027;  // Model of Image input\r\n                                                 // equipment\r\n  PropertyTagThumbnailStripOffsets     = $5028;  // Image data location\r\n  PropertyTagThumbnailOrientation      = $5029;  // Orientation of image\r\n  PropertyTagThumbnailSamplesPerPixel  = $502A;  // Number of components\r\n  PropertyTagThumbnailRowsPerStrip     = $502B;  // Number of rows per strip\r\n  PropertyTagThumbnailStripBytesCount  = $502C;  // Bytes per compressed\r\n                                                 // strip\r\n  PropertyTagThumbnailResolutionX      = $502D;  // Resolution in width\r\n                                                 // direction\r\n  PropertyTagThumbnailResolutionY      = $502E;  // Resolution in height\r\n                                                 // direction\r\n  PropertyTagThumbnailPlanarConfig     = $502F;  // Image data arrangement\r\n  PropertyTagThumbnailResolutionUnit   = $5030;  // Unit of X and Y\r\n                                                 // Resolution\r\n  PropertyTagThumbnailTransferFunction = $5031;  // Transfer function\r\n  PropertyTagThumbnailSoftwareUsed     = $5032;  // Software used\r\n  PropertyTagThumbnailDateTime         = $5033;  // File change date and\r\n                                                 // time\r\n  PropertyTagThumbnailArtist           = $5034;  // Person who created the\r\n                                                 // image\r\n  PropertyTagThumbnailWhitePoint       = $5035;  // White point chromaticity\r\n  PropertyTagThumbnailPrimaryChromaticities = $5036; // Chromaticities of\r\n                                                     // primaries\r\n  PropertyTagThumbnailYCbCrCoefficients = $5037; // Color space transforma-\r\n                                                 // tion coefficients\r\n  PropertyTagThumbnailYCbCrSubsampling = $5038;  // Subsampling ratio of Y\r\n                                                 // to C\r\n  PropertyTagThumbnailYCbCrPositioning = $5039;  // Y and C position\r\n  PropertyTagThumbnailRefBlackWhite    = $503A;  // Pair of black and white\r\n                                                 // reference values\r\n  PropertyTagThumbnailCopyRight        = $503B;  // CopyRight holder\r\n\r\n  PropertyTagLuminanceTable            = $5090;\r\n  PropertyTagChrominanceTable          = $5091;\r\n\r\n  PropertyTagFrameDelay                = $5100;\r\n  PropertyTagLoopCount                 = $5101;\r\n\r\n  {$IF (GDIPVER >= $0110)}\r\n  PropertyTagGlobalPalette             = $5102;\r\n  PropertyTagIndexBackground           = $5103;\r\n  PropertyTagIndexTransparent          = $5104;\r\n  {$IFEND}\r\n\r\n  PropertyTagPixelUnit         = $5110;  // Unit specifier for pixel/unit\r\n  PropertyTagPixelPerUnitX     = $5111;  // Pixels per unit in X\r\n  PropertyTagPixelPerUnitY     = $5112;  // Pixels per unit in Y\r\n  PropertyTagPaletteHistogram  = $5113;  // Palette histogram\r\n\r\n// EXIF specific tag\r\n\r\n  PropertyTagExifExposureTime  = $829A;\r\n  PropertyTagExifFNumber       = $829D;\r\n\r\n  PropertyTagExifExposureProg  = $8822;\r\n  PropertyTagExifSpectralSense = $8824;\r\n  PropertyTagExifISOSpeed      = $8827;\r\n  PropertyTagExifOECF          = $8828;\r\n\r\n  PropertyTagExifVer            = $9000;\r\n  PropertyTagExifDTOrig         = $9003; // Date & time of original\r\n  PropertyTagExifDTDigitized    = $9004; // Date & time of digital data generation\r\n\r\n  PropertyTagExifCompConfig     = $9101;\r\n  PropertyTagExifCompBPP        = $9102;\r\n\r\n  PropertyTagExifShutterSpeed   = $9201;\r\n  PropertyTagExifAperture       = $9202;\r\n  PropertyTagExifBrightness     = $9203;\r\n  PropertyTagExifExposureBias   = $9204;\r\n  PropertyTagExifMaxAperture    = $9205;\r\n  PropertyTagExifSubjectDist    = $9206;\r\n  PropertyTagExifMeteringMode   = $9207;\r\n  PropertyTagExifLightSource    = $9208;\r\n  PropertyTagExifFlash          = $9209;\r\n  PropertyTagExifFocalLength    = $920A;\r\n  PropertyTagExifSubjectArea    = $9214;  // exif 2.2 Subject Area\r\n  PropertyTagExifMakerNote      = $927C;\r\n  PropertyTagExifUserComment    = $9286;\r\n  PropertyTagExifDTSubsec       = $9290;  // Date & Time subseconds\r\n  PropertyTagExifDTOrigSS       = $9291;  // Date & Time original subseconds\r\n  PropertyTagExifDTDigSS        = $9292;  // Date & TIme digitized subseconds\r\n\r\n  PropertyTagExifFPXVer         = $A000;\r\n  PropertyTagExifColorSpace     = $A001;\r\n  PropertyTagExifPixXDim        = $A002;\r\n  PropertyTagExifPixYDim        = $A003;\r\n  PropertyTagExifRelatedWav     = $A004;  // related sound file\r\n  PropertyTagExifInterop        = $A005;\r\n  PropertyTagExifFlashEnergy    = $A20B;\r\n  PropertyTagExifSpatialFR      = $A20C;  // Spatial Frequency Response\r\n  PropertyTagExifFocalXRes      = $A20E;  // Focal Plane X Resolution\r\n  PropertyTagExifFocalYRes      = $A20F;  // Focal Plane Y Resolution\r\n  PropertyTagExifFocalResUnit   = $A210;  // Focal Plane Resolution Unit\r\n  PropertyTagExifSubjectLoc     = $A214;\r\n  PropertyTagExifExposureIndex  = $A215;\r\n  PropertyTagExifSensingMethod  = $A217;\r\n  PropertyTagExifFileSource     = $A300;\r\n  PropertyTagExifSceneType      = $A301;\r\n  PropertyTagExifCfaPattern     = $A302;\r\n\r\n// New EXIF 2.2 properties\r\n\r\n  PropertyTagExifCustomRendered           = $A401;\r\n  PropertyTagExifExposureMode             = $A402;\r\n  PropertyTagExifWhiteBalance             = $A403;\r\n  PropertyTagExifDigitalZoomRatio         = $A404;\r\n  PropertyTagExifFocalLengthIn35mmFilm    = $A405;\r\n  PropertyTagExifSceneCaptureType         = $A406;\r\n  PropertyTagExifGainControl              = $A407;\r\n  PropertyTagExifContrast                 = $A408;\r\n  PropertyTagExifSaturation               = $A409;\r\n  PropertyTagExifSharpness                = $A40A;\r\n  PropertyTagExifDeviceSettingDesc        = $A40B;\r\n  PropertyTagExifSubjectDistanceRange     = $A40C;\r\n  PropertyTagExifUniqueImageID            = $A420;\r\n\r\n\r\n  PropertyTagGpsVer             = $0000;\r\n  PropertyTagGpsLatitudeRef     = $0001;\r\n  PropertyTagGpsLatitude        = $0002;\r\n  PropertyTagGpsLongitudeRef    = $0003;\r\n  PropertyTagGpsLongitude       = $0004;\r\n  PropertyTagGpsAltitudeRef     = $0005;\r\n  PropertyTagGpsAltitude        = $0006;\r\n  PropertyTagGpsGpsTime         = $0007;\r\n  PropertyTagGpsGpsSatellites   = $0008;\r\n  PropertyTagGpsGpsStatus       = $0009;\r\n  PropertyTagGpsGpsMeasureMode  = $000A ;\r\n  PropertyTagGpsGpsDop          = $000B;  // Measurement precision\r\n  PropertyTagGpsSpeedRef        = $000C;\r\n  PropertyTagGpsSpeed           = $000D;\r\n  PropertyTagGpsTrackRef        = $000E;\r\n  PropertyTagGpsTrack           = $000F;\r\n  PropertyTagGpsImgDirRef       = $0010;\r\n  PropertyTagGpsImgDir          = $0011;\r\n  PropertyTagGpsMapDatum        = $0012;\r\n  PropertyTagGpsDestLatRef      = $0013;\r\n  PropertyTagGpsDestLat         = $0014;\r\n  PropertyTagGpsDestLongRef     = $0015;\r\n  PropertyTagGpsDestLong        = $0016;\r\n  PropertyTagGpsDestBearRef     = $0017;\r\n  PropertyTagGpsDestBear        = $0018;\r\n  PropertyTagGpsDestDistRef     = $0019;\r\n  PropertyTagGpsDestDist        = $001A;\r\n  PropertyTagGpsProcessingMethod = $001B;\r\n  PropertyTagGpsAreaInformation = $001C;\r\n  PropertyTagGpsDate            = $001D;\r\n  PropertyTagGpsDifferential    = $001E;\r\n{$ENDREGION 'GdiplusImaging.h'}\r\n\r\n{$REGION 'GdiplusColorMatrix.h'}\r\n(*****************************************************************************\r\n * GdiplusColorMatrix.h\r\n * GDI+ Color Matrix object, used with Graphics.DrawImage\r\n *****************************************************************************)\r\n\r\n{$IF (GDIPVER >= $0110)}\r\n//----------------------------------------------------------------------------\r\n// Color channel look up table (LUT)\r\n//----------------------------------------------------------------------------\r\n\r\ntype\r\n  TGPColorChannelLUT = array [0..255] of Byte;\r\n\r\n//----------------------------------------------------------------------------\r\n// Per-channel Histogram for 8bpp images.\r\n//----------------------------------------------------------------------------\r\n\r\ntype\r\n  TGPHistogramFormat = (\r\n    HistogramFormatARGB,\r\n    HistogramFormatPARGB,\r\n    HistogramFormatRGB,\r\n    HistogramFormatGray,\r\n    HistogramFormatB,\r\n    HistogramFormatG,\r\n    HistogramFormatR,\r\n    HistogramFormatA);\r\n{$IFEND}\r\n\r\n//----------------------------------------------------------------------------\r\n// Color matrix\r\n//----------------------------------------------------------------------------\r\n\r\ntype\r\n  TGPColorMatrix = record\r\n  public\r\n    M: array [0..4, 0..4] of Single;\r\n  public\r\n    procedure SetToIdentity;\r\n  end;\r\n  PGPColorMatrix = ^TGPColorMatrix;\r\n\r\n//----------------------------------------------------------------------------\r\n// Color Matrix flags\r\n//----------------------------------------------------------------------------\r\n\r\ntype\r\n  TGPColorMatrixFlags = (\r\n    ColorMatrixFlagsDefault   = 0,\r\n    ColorMatrixFlagsSkipGrays = 1,\r\n    ColorMatrixFlagsAltGray   = 2);\r\n\r\n//----------------------------------------------------------------------------\r\n// Color Adjust Type\r\n//----------------------------------------------------------------------------\r\n\r\ntype\r\n  TGPColorAdjustType = (\r\n    ColorAdjustTypeDefault,\r\n    ColorAdjustTypeBitmap,\r\n    ColorAdjustTypeBrush,\r\n    ColorAdjustTypePen,\r\n    ColorAdjustTypeText,\r\n    ColorAdjustTypeCount,\r\n    ColorAdjustTypeAny);  // Reserved\r\n\r\n//----------------------------------------------------------------------------\r\n// Color Map\r\n//----------------------------------------------------------------------------\r\n\r\ntype\r\n  TGPColorMap = record\r\n    OldColor: TGPColor;\r\n    NewColor: TGPColor;\r\n  end;\r\n  PGPColorMap = ^TGPColorMap;\r\n\r\n{$ENDREGION 'GdiplusColorMatrix.h'}\r\n\r\n{$REGION 'GdiplusEffects.h'}\r\n{$IF (GDIPVER >= $0110)}\r\n(*****************************************************************************\r\n * GdiplusEffects.h\r\n * Gdiplus effect objects\r\n *****************************************************************************)\r\n//-----------------------------------------------------------------------------\r\n// GDI+ effect GUIDs\r\n//-----------------------------------------------------------------------------\r\n\r\nconst\r\n  BlurEffectGuid                  : TGUID = '{633C80A4-1843-482b-9EF2-BE2834C5FDD4}';\r\n  SharpenEffectGuid               : TGUID = '{63CBF3EE-C526-402c-8F71-62C540BF5142}';\r\n  ColorMatrixEffectGuid           : TGUID = '{718F2615-7933-40e3-A511-5F68FE14DD74}';\r\n  ColorLUTEffectGuid              : TGUID = '{A7CE72A9-0F7F-40d7-B3CC-D0C02D5C3212}';\r\n  BrightnessContrastEffectGuid    : TGUID = '{D3A1DBE1-8EC4-4c17-9F4C-EA97AD1C343D}';\r\n  HueSaturationLightnessEffectGuid: TGUID = '{8B2DD6C3-EB07-4d87-A5F0-7108E26A9C5F}';\r\n  LevelsEffectGuid                : TGUID = '{99C354EC-2A31-4f3a-8C34-17A803B33A25}';\r\n  TintEffectGuid                  : TGUID = '{1077AF00-2848-4441-9489-44AD4C2D7A2C}';\r\n  ColorBalanceEffectGuid          : TGUID = '{537E597D-251E-48da-9664-29CA496B70F8}';\r\n  RedEyeCorrectionEffectGuid      : TGUID = '{74D29D05-69A4-4266-9549-3CC52836B632}';\r\n  ColorCurveEffectGuid            : TGUID = '{DD6A0022-58E4-4a67-9D9B-D48EB881A53D}';\r\n\r\n//-----------------------------------------------------------------------------\r\n\r\ntype\r\n  TGPSharpenParams = record\r\n  public\r\n    Radius: Single;\r\n    Amount: Single;\r\n  end;\r\n  PGPSharpenParams = ^TGPSharpenParams;\r\n\r\ntype\r\n  TGPBlurParams = record\r\n  public\r\n    Radius: Single;\r\n    ExpandEdge: BOOL;\r\n  end;\r\n  PGPBlurParams = ^TGPBlurParams;\r\n\r\ntype\r\n  TGPBrightnessContrastParams = record\r\n  public\r\n    BrightnessLevel: Integer;\r\n    ContrastLevel: Integer;\r\n  end;\r\n  PGPBrightnessContrastParams = ^TGPBrightnessContrastParams;\r\n\r\ntype\r\n  TGPRedEyeCorrectionParams = record\r\n  public\r\n    NumberOfAreas: Cardinal;\r\n    Areas: Windows.PRect;\r\n  end;\r\n  PGPRedEyeCorrectionParams = ^TGPRedEyeCorrectionParams;\r\n\r\ntype\r\n  TGPHueSaturationLightnessParams = record\r\n  public\r\n    HueLevel: Integer;\r\n    SaturationLevel: Integer;\r\n    LightnessLevel: Integer;\r\n  end;\r\n  PGPHueSaturationLightnessParams = ^TGPHueSaturationLightnessParams;\r\n\r\ntype\r\n  TGPTintParams = record\r\n  public\r\n    Hue: Integer;\r\n    Amount: Integer;\r\n  end;\r\n  PGPTintParams = ^TGPTintParams;\r\n\r\ntype\r\n  TGPLevelsParams = record\r\n  public\r\n    Highlight: Integer;\r\n    Midtone: Integer;\r\n    Shadow: Integer;\r\n  end;\r\n  PGPLevelsParams = ^TGPLevelsParams;\r\n\r\ntype\r\n  TGPColorBalanceParams = record\r\n  public\r\n    CyanRed: Integer;\r\n    MagentaGreen: Integer;\r\n    YellowBlue: Integer;\r\n  end;\r\n  PGPColorBalanceParams = ^TGPColorBalanceParams;\r\n\r\ntype\r\n  TGPColorLUTParams = record\r\n    // look up tables for each color channel.\r\n\r\n    LutB: TGPColorChannelLUT;\r\n    LutG: TGPColorChannelLUT;\r\n    LutR: TGPColorChannelLUT;\r\n    LutA: TGPColorChannelLUT;\r\n  end;\r\n  PGPColorLUTParams = ^TGPColorLUTParams;\r\n\r\ntype\r\n  TGPCurveAdjustments = (\r\n    AdjustExposure,\r\n    AdjustDensity,\r\n    AdjustContrast,\r\n    AdjustHighlight,\r\n    AdjustShadow,\r\n    AdjustMidtone,\r\n    AdjustWhiteSaturation,\r\n    AdjustBlackSaturation);\r\n\r\ntype\r\n  TGPCurveChannel = (\r\n    CurveChannelAll,\r\n    CurveChannelRed,\r\n    CurveChannelGreen,\r\n    CurveChannelBlue);\r\n\r\ntype\r\n  TGPColorCurveParams = record\r\n  public\r\n    Adjustment: TGPCurveAdjustments;\r\n    Channel: TGPCurveChannel;\r\n    AdjustValue: Integer;\r\n  end;\r\n  PGPColorCurveParams = ^TGPColorCurveParams;\r\n\r\ntype\r\n  CGpEffect = Pointer;\r\n\r\nfunction GdipCreateEffect(Guid: TGUID;\r\n  out Effect: CGpEffect): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\nfunction GdipDeleteEffect(Effect: CGpEffect): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\nfunction GdipGetEffectParameterSize(Effect: CGpEffect;\r\n  out Size: UINT): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\nfunction GdipSetEffectParameters(Effect: CGpEffect; const Params: Pointer;\r\n  const Size: UINT): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\nfunction GdipGetEffectParameters(Effect: CGpEffect; var Size: UINT;\r\n  Params: Pointer): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\ntype\r\n  IGPEffect = interface(IGdiPlusBase)\r\n  ['{446CEE9F-25A0-400F-8599-3905CBE4828A}']\r\n    { Property access methods }\r\n    function GetAuxDataSize: Integer;\r\n    function GetAuxData: Pointer;\r\n    function GetUseAuxData: Boolean;\r\n    procedure SetUseAuxData(const Value: Boolean);\r\n    function GetParameterSize: Cardinal;\r\n\r\n    { Methods }\r\n    procedure ReleaseAuxData;\r\n    procedure SetAuxData(const Data: Pointer; const Size: Integer);\r\n\r\n    { Properties }\r\n    property AuxDataSize: Integer read GetAuxDataSize;\r\n    property AuxData: Pointer read GetAuxData;\r\n    property UseAuxData: Boolean read GetUseAuxData write SetUseAuxData;\r\n    property ParameterSize: Cardinal read GetParameterSize;\r\n  end;\r\n\r\n  TGPEffect = class(TGdiplusBase, IGPEffect)\r\n  private\r\n    FAuxDataSize: Integer;\r\n    FAuxData: Pointer;\r\n    FUseAuxData: Boolean;\r\n  private\r\n    { IGPEffect }\r\n    function GetAuxDataSize: Integer;\r\n    function GetAuxData: Pointer;\r\n    function GetUseAuxData: Boolean;\r\n    procedure SetUseAuxData(const Value: Boolean);\r\n    function GetParameterSize: Cardinal;\r\n    procedure ReleaseAuxData;\r\n    procedure SetAuxData(const Data: Pointer; const Size: Integer);\r\n  protected\r\n    procedure SetParameters(const Params: Pointer; const Size: Cardinal);\r\n    procedure GetParameters(var Size: Cardinal; Params: Pointer);\r\n  public\r\n    destructor Destroy; override;\r\n  end;\r\n\r\ntype\r\n  // Blur\r\n  IGPBlur = interface(IGPEffect)\r\n  ['{8F6EFDE6-E905-4886-8386-8BE9E92545E5}']\r\n    { Property access methods }\r\n    function GetParameters: TGPBlurParams;\r\n    procedure SetParameters(const Value: TGPBlurParams);\r\n\r\n    { Properties }\r\n    property Parameters: TGPBlurParams read GetParameters write SetParameters;\r\n  end;\r\n\r\n  TGPBlur = class(TGPEffect, IGPBlur)\r\n  private\r\n    { IGPBlur }\r\n    function GetParameters: TGPBlurParams;\r\n    procedure SetParameters(const Value: TGPBlurParams);\r\n  public\r\n    constructor Create;\r\n  end;\r\n\r\ntype\r\n  // Sharpen\r\n  IGPSharpen = interface(IGPEffect)\r\n  ['{D5276FFC-FB19-4DCC-9FBB-DC5142DDE65E}']\r\n    { Property access methods }\r\n    function GetParameters: TGPSharpenParams;\r\n    procedure SetParameters(const Value: TGPSharpenParams);\r\n\r\n    { Properties }\r\n    property Parameters: TGPSharpenParams read GetParameters write SetParameters;\r\n  end;\r\n\r\n  TGPSharpen = class(TGPEffect, IGPSharpen)\r\n  private\r\n    { IGPSharpen }\r\n    function GetParameters: TGPSharpenParams;\r\n    procedure SetParameters(const Value: TGPSharpenParams);\r\n  public\r\n    constructor Create;\r\n  end;\r\n\r\ntype\r\n  // RedEye Correction\r\n  IGPRedEyeCorrection = interface(IGPEffect)\r\n  ['{055F978A-DB24-48C9-B87E-BA5616809566}']\r\n    { Property access methods }\r\n    function GetParameters: TGPRedEyeCorrectionParams;\r\n    procedure SetParameters(const Value: TGPRedEyeCorrectionParams);\r\n\r\n    { Properties }\r\n    property Parameters: TGPRedEyeCorrectionParams read GetParameters write SetParameters;\r\n  end;\r\n\r\n  TGPRedEyeCorrection = class(TGPEffect, IGPRedEyeCorrection)\r\n  private\r\n    { IGPRedEyeCorrection }\r\n    function GetParameters: TGPRedEyeCorrectionParams;\r\n    procedure SetParameters(const Value: TGPRedEyeCorrectionParams);\r\n  public\r\n    constructor Create;\r\n  end;\r\n\r\ntype\r\n  // Brightness/Contrast\r\n  IGPBrightnessContrast = interface(IGPEffect)\r\n  ['{3216DA55-5C78-4376-B693-E538E757118E}']\r\n    { Property access methods }\r\n    function GetParameters: TGPBrightnessContrastParams;\r\n    procedure SetParameters(const Value: TGPBrightnessContrastParams);\r\n\r\n    { Properties }\r\n    property Parameters: TGPBrightnessContrastParams read GetParameters write SetParameters;\r\n  end;\r\n\r\n  TGPBrightnessContrast = class(TGPEffect, IGPBrightnessContrast)\r\n  private\r\n    { IGPBrightnessContrast }\r\n    function GetParameters: TGPBrightnessContrastParams;\r\n    procedure SetParameters(const Value: TGPBrightnessContrastParams);\r\n  public\r\n    constructor Create;\r\n  end;\r\n\r\ntype\r\n  // Hue/Saturation/Lightness\r\n  IGPHueSaturationLightness = interface(IGPEffect)\r\n  ['{7DFF5E66-E1FB-4441-B78A-03423A1AB3CC}']\r\n    { Property access methods }\r\n    function GetParameters: TGPHueSaturationLightnessParams;\r\n    procedure SetParameters(const Value: TGPHueSaturationLightnessParams);\r\n\r\n    { Properties }\r\n    property Parameters: TGPHueSaturationLightnessParams read GetParameters write SetParameters;\r\n  end;\r\n\r\n  TGPHueSaturationLightness = class(TGPEffect, IGPHueSaturationLightness)\r\n  private\r\n    { IGPHueSaturationLightness }\r\n    function GetParameters: TGPHueSaturationLightnessParams;\r\n    procedure SetParameters(const Value: TGPHueSaturationLightnessParams);\r\n  public\r\n    constructor Create;\r\n  end;\r\n\r\ntype\r\n  // Highlight/Midtone/Shadow curves\r\n  IGPLevels = interface(IGPEffect)\r\n  ['{A4770860-C2CA-47EB-AF07-91F85B2FD0FC}']\r\n    { Property access methods }\r\n    function GetParameters: TGPLevelsParams;\r\n    procedure SetParameters(const Value: TGPLevelsParams);\r\n\r\n    { Properties }\r\n    property Parameters: TGPLevelsParams read GetParameters write SetParameters;\r\n  end;\r\n\r\n  TGPLevels = class(TGPEffect, IGPLevels)\r\n  private\r\n    { IGPLevels }\r\n    function GetParameters: TGPLevelsParams;\r\n    procedure SetParameters(const Value: TGPLevelsParams);\r\n  public\r\n    constructor Create;\r\n  end;\r\n\r\ntype\r\n  // Tint\r\n  IGPTint = interface(IGPEffect)\r\n  ['{EEBFC517-2FC5-4164-860A-C133C1D15541}']\r\n    { Property access methods }\r\n    function GetParameters: TGPTintParams;\r\n    procedure SetParameters(const Value: TGPTintParams);\r\n\r\n    { Properties }\r\n    property Parameters: TGPTintParams read GetParameters write SetParameters;\r\n  end;\r\n\r\n  TGPTint = class(TGPEffect, IGPTint)\r\n  private\r\n    { IGPTint }\r\n    function GetParameters: TGPTintParams;\r\n    procedure SetParameters(const Value: TGPTintParams);\r\n  public\r\n    constructor Create;\r\n  end;\r\n\r\ntype\r\n  // ColorBalance\r\n  IGPColorBalance = interface(IGPEffect)\r\n  ['{951B7FA7-239E-402E-B20F-DC1058A93B38}']\r\n    { Property access methods }\r\n    function GetParameters: TGPColorBalanceParams;\r\n    procedure SetParameters(const Value: TGPColorBalanceParams);\r\n\r\n    { Properties }\r\n    property Parameters: TGPColorBalanceParams read GetParameters write SetParameters;\r\n  end;\r\n\r\n  TGPColorBalance = class(TGPEffect, IGPColorBalance)\r\n  private\r\n    { IGPColorBalance }\r\n    function GetParameters: TGPColorBalanceParams;\r\n    procedure SetParameters(const Value: TGPColorBalanceParams);\r\n  public\r\n    constructor Create;\r\n  end;\r\n\r\ntype\r\n  // ColorMatrix\r\n  IGPColorMatrixEffect = interface(IGPEffect)\r\n  ['{492E9124-97C2-45AD-BC4E-699F75C62AF4}']\r\n    { Property access methods }\r\n    function GetParameters: TGPColorMatrix;\r\n    procedure SetParameters(const Value: TGPColorMatrix);\r\n\r\n    { Properties }\r\n    property Parameters: TGPColorMatrix read GetParameters write SetParameters;\r\n  end;\r\n\r\n  TGPColorMatrixEffect = class(TGPEffect, IGPColorMatrixEffect)\r\n  private\r\n    { IGPColorMatrixEffect }\r\n    function GetParameters: TGPColorMatrix;\r\n    procedure SetParameters(const Value: TGPColorMatrix);\r\n  public\r\n    constructor Create;\r\n  end;\r\n\r\ntype\r\n  // ColorLUT\r\n  IGPColorLUT = interface(IGPEffect)\r\n  ['{4846B6A9-7A08-4A09-B599-963588A77C14}']\r\n    { Property access methods }\r\n    function GetParameters: TGPColorLUTParams;\r\n    procedure SetParameters(const Value: TGPColorLUTParams);\r\n\r\n    { Properties }\r\n    property Parameters: TGPColorLUTParams read GetParameters write SetParameters;\r\n  end;\r\n\r\n  TGPColorLUT = class(TGPEffect, IGPColorLUT)\r\n  private\r\n    { IGPColorLUT }\r\n    function GetParameters: TGPColorLUTParams;\r\n    procedure SetParameters(const Value: TGPColorLUTParams);\r\n  public\r\n    constructor Create;\r\n  end;\r\n\r\ntype\r\n  // Color Curve\r\n  IGPColorCurve = interface(IGPEffect)\r\n  ['{710EE23F-A7A0-43E4-9551-51EA66E12773}']\r\n    { Property access methods }\r\n    function GetParameters: TGPColorCurveParams;\r\n    procedure SetParameters(const Value: TGPColorCurveParams);\r\n\r\n    { Properties }\r\n    property Parameters: TGPColorCurveParams read GetParameters write SetParameters;\r\n  end;\r\n\r\n  TGPColorCurve = class(TGPEffect, IGPColorCurve)\r\n  private\r\n    { IGPColorCurve }\r\n    function GetParameters: TGPColorCurveParams;\r\n    procedure SetParameters(const Value: TGPColorCurveParams);\r\n  public\r\n    constructor Create;\r\n  end;\r\n{$IFEND}\r\n{$ENDREGION 'GdiplusEffects.h'}\r\n\r\n{$REGION 'GdiplusGpStubs.h (1)'}\r\n(*****************************************************************************\r\n * GdiplusGpStubs.h\r\n * Private GDI+ header file.\r\n *****************************************************************************)\r\n\r\n//---------------------------------------------------------------------------\r\n// Private GDI+ classes for internal type checking\r\n//---------------------------------------------------------------------------\r\n\r\n  GpGraphics = Pointer;\r\n\r\n  GpBrush = Pointer;\r\n  GpTexture = Pointer;\r\n  GpSolidFill = Pointer;\r\n  GpLineGradient = Pointer;\r\n  GpPathGradient = Pointer;\r\n  GpHatch = Pointer;\r\n\r\n  GpPen = Pointer;\r\n  GpCustomLineCap = Pointer;\r\n  GpAdjustableArrowCap = Pointer;\r\n\r\n  GpImage = Pointer;\r\n  GpBitmap = Pointer;\r\n  PGpBitmap = ^GpBitmap;\r\n  GpMetafile = Pointer;\r\n  GpImageAttributes = Pointer;\r\n\r\n  GpPath = Pointer;\r\n  GpRegion = Pointer;\r\n  PGpRegion = ^GpRegion;\r\n  GpPathIterator = Pointer;\r\n\r\n  GpFontFamily = Pointer;\r\n  PGpFontFamily = ^GpFontFamily;\r\n  GpFont = Pointer;\r\n  GpStringFormat = Pointer;\r\n  GpFontCollection = Pointer;\r\n  GpInstalledFontCollection = Pointer;\r\n  GpPrivateFontCollection = Pointer;\r\n\r\n  GpCachedBitmap = Pointer;\r\n\r\n  GpMatrix = Pointer;\r\n\r\n{$ENDREGION 'GdiplusGpStubs.h (1)'}\r\n\r\n{$REGION 'GdiplusFlat.h'}\r\n(*****************************************************************************\r\n * GdiplusFlat.h\r\n * Private GDI+ header file.\r\n *****************************************************************************)\r\n\r\n//----------------------------------------------------------------------------\r\n// GraphicsPath APIs\r\n//----------------------------------------------------------------------------\r\n\r\n{ GdipCreatePath(GpFillMode brushMode, GpPath **path); }\r\nfunction GdipCreatePath(BrushMode: TGPFillMode; out Path: GpPath): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipCreatePath2(GDIPCONST GpPointF*, GDIPCONST BYTE*, INT, GpFillMode, GpPath **path); }\r\nfunction GdipCreatePath2(const Param1: PGPPointF; const Param2: PByte;\r\n  Param3: Integer; Param4: TGPFillMode; out Path: GpPath): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipCreatePath2I(GDIPCONST GpPoint*, GDIPCONST BYTE*, INT, GpFillMode, GpPath **path); }\r\nfunction GdipCreatePath2I(const Param1: PGPPoint; const Param2: PByte;\r\n  Param3: Integer; Param4: TGPFillMode; out Path: GpPath): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipClonePath(GpPath* path, GpPath **clonePath); }\r\nfunction GdipClonePath(Path: GpPath; out ClonePath: GpPath): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipDeletePath(GpPath* path); }\r\nfunction GdipDeletePath(Path: GpPath): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipResetPath(GpPath* path); }\r\nfunction GdipResetPath(Path: GpPath): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipGetPointCount(GpPath* path, INT* count); }\r\nfunction GdipGetPointCount(Path: GpPath; out Count: Integer): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipGetPathTypes(GpPath* path, BYTE* types, INT count); }\r\nfunction GdipGetPathTypes(Path: GpPath; Types: PByte; Count: Integer): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipGetPathPoints(GpPath*, GpPointF* points, INT count); }\r\nfunction GdipGetPathPoints(Path: GpPath; Points: PGPPointF; Count: Integer): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipGetPathPointsI(GpPath*, GpPoint* points, INT count); }\r\nfunction GdipGetPathPointsI(Path: GpPath; Points: PGPPoint; Count: Integer): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipGetPathFillMode(GpPath *path, GpFillMode *fillmode); }\r\nfunction GdipGetPathFillMode(Path: GpPath; out Fillmode: TGPFillMode): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipSetPathFillMode(GpPath *path, GpFillMode fillmode); }\r\nfunction GdipSetPathFillMode(Path: GpPath; Fillmode: TGPFillMode): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipGetPathData(GpPath *path, GpPathData* pathData); }\r\nfunction GdipGetPathData(Path: GpPath; PathData: PGPNativePathData): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipStartPathFigure(GpPath *path); }\r\nfunction GdipStartPathFigure(Path: GpPath): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipClosePathFigure(GpPath *path); }\r\nfunction GdipClosePathFigure(Path: GpPath): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipClosePathFigures(GpPath *path); }\r\nfunction GdipClosePathFigures(Path: GpPath): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipSetPathMarker(GpPath* path); }\r\nfunction GdipSetPathMarker(Path: GpPath): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipClearPathMarkers(GpPath* path); }\r\nfunction GdipClearPathMarkers(Path: GpPath): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipReversePath(GpPath* path); }\r\nfunction GdipReversePath(Path: GpPath): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipGetPathLastPoint(GpPath* path, GpPointF* lastPoint); }\r\nfunction GdipGetPathLastPoint(Path: GpPath; out LastPoint: TGPPointF): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipAddPathLine(GpPath *path, REAL x1, REAL y1, REAL x2, REAL y2); }\r\nfunction GdipAddPathLine(Path: GpPath; X1: Single; Y1: Single; X2: Single;\r\n  Y2: Single): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipAddPathLine2(GpPath *path, GDIPCONST GpPointF *points, INT count); }\r\nfunction GdipAddPathLine2(Path: GpPath; const Points: PGPPointF; Count: Integer): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipAddPathArc(GpPath *path, REAL x, REAL y, REAL width, REAL height, REAL startAngle, REAL sweepAngle); }\r\nfunction GdipAddPathArc(Path: GpPath; X: Single; Y: Single; Width: Single;\r\n  Height: Single; StartAngle: Single; SweepAngle: Single): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipAddPathBezier(GpPath *path, REAL x1, REAL y1, REAL x2, REAL y2, REAL x3, REAL y3, REAL x4, REAL y4); }\r\nfunction GdipAddPathBezier(Path: GpPath; X1: Single; Y1: Single; X2: Single;\r\n  Y2: Single; X3: Single; Y3: Single; X4: Single; Y4: Single): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipAddPathBeziers(GpPath *path, GDIPCONST GpPointF *points, INT count); }\r\nfunction GdipAddPathBeziers(Path: GpPath; const Points: PGPPointF; Count: Integer): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipAddPathCurve(GpPath *path, GDIPCONST GpPointF *points, INT count); }\r\nfunction GdipAddPathCurve(Path: GpPath; const Points: PGPPointF; Count: Integer): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipAddPathCurve2(GpPath *path, GDIPCONST GpPointF *points, INT count, REAL tension); }\r\nfunction GdipAddPathCurve2(Path: GpPath; const Points: PGPPointF; Count: Integer;\r\n  Tension: Single): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipAddPathCurve3(GpPath *path, GDIPCONST GpPointF *points, INT count, INT offset, INT numberOfSegments, REAL tension); }\r\nfunction GdipAddPathCurve3(Path: GpPath; const Points: PGPPointF; Count: Integer;\r\n  Offset: Integer; NumberOfSegments: Integer; Tension: Single): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipAddPathClosedCurve(GpPath *path, GDIPCONST GpPointF *points, INT count); }\r\nfunction GdipAddPathClosedCurve(Path: GpPath; const Points: PGPPointF;\r\n  Count: Integer): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipAddPathClosedCurve2(GpPath *path, GDIPCONST GpPointF *points, INT count, REAL tension); }\r\nfunction GdipAddPathClosedCurve2(Path: GpPath; const Points: PGPPointF;\r\n  Count: Integer; Tension: Single): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipAddPathRectangle(GpPath *path, REAL x, REAL y, REAL width, REAL height); }\r\nfunction GdipAddPathRectangle(Path: GpPath; X: Single; Y: Single; Width: Single;\r\n  Height: Single): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipAddPathRectangles(GpPath *path, GDIPCONST GpRectF *rects, INT count); }\r\nfunction GdipAddPathRectangles(Path: GpPath; const Rects: PGPRectF;\r\n  Count: Integer): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipAddPathEllipse(GpPath *path, REAL x, REAL y, REAL width, REAL height); }\r\nfunction GdipAddPathEllipse(Path: GpPath; X: Single; Y: Single; Width: Single;\r\n  Height: Single): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipAddPathPie(GpPath *path, REAL x, REAL y, REAL width, REAL height, REAL startAngle, REAL sweepAngle); }\r\nfunction GdipAddPathPie(Path: GpPath; X: Single; Y: Single; Width: Single;\r\n  Height: Single; StartAngle: Single; SweepAngle: Single): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipAddPathPolygon(GpPath *path, GDIPCONST GpPointF *points, INT count); }\r\nfunction GdipAddPathPolygon(Path: GpPath; const Points: PGPPointF; Count: Integer): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipAddPathPath(GpPath *path, GDIPCONST GpPath* addingPath, BOOL connect); }\r\nfunction GdipAddPathPath(Path: GpPath; const AddingPath: GpPath; Connect: Bool): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipAddPathString(GpPath *path, GDIPCONST WCHAR *string, INT length, GDIPCONST GpFontFamily *family, INT style, REAL emSize, GDIPCONST RectF *layoutRect, GDIPCONST GpStringFormat *format); }\r\nfunction GdipAddPathString(Path: GpPath; const Str: PWideChar; Length: Integer;\r\n  const Family: GpFontFamily; Style: TGPFontStyle; EmSize: Single;\r\n  const LayoutRect: PGPRectF; const Format: GpStringFormat): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipAddPathStringI(GpPath *path, GDIPCONST WCHAR *string, INT length, GDIPCONST GpFontFamily *family, INT style, REAL emSize, GDIPCONST Rect *layoutRect, GDIPCONST GpStringFormat *format); }\r\nfunction GdipAddPathStringI(Path: GpPath; const Str: PWideChar; Length: Integer;\r\n  const Family: GpFontFamily; Style: TGPFontStyle; EmSize: Single;\r\n  const LayoutRect: PGPRect; const Format: GpStringFormat): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipAddPathLineI(GpPath *path, INT x1, INT y1, INT x2, INT y2); }\r\nfunction GdipAddPathLineI(Path: GpPath; X1: Integer; Y1: Integer; X2: Integer;\r\n  Y2: Integer): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipAddPathLine2I(GpPath *path, GDIPCONST GpPoint *points, INT count); }\r\nfunction GdipAddPathLine2I(Path: GpPath; const Points: PGPPoint; Count: Integer): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipAddPathArcI(GpPath *path, INT x, INT y, INT width, INT height, REAL startAngle, REAL sweepAngle); }\r\nfunction GdipAddPathArcI(Path: GpPath; X: Integer; Y: Integer; Width: Integer;\r\n  Height: Integer; StartAngle: Single; SweepAngle: Single): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipAddPathBezierI(GpPath *path, INT x1, INT y1, INT x2, INT y2, INT x3, INT y3, INT x4, INT y4); }\r\nfunction GdipAddPathBezierI(Path: GpPath; X1: Integer; Y1: Integer; X2: Integer;\r\n  Y2: Integer; X3: Integer; Y3: Integer; X4: Integer; Y4: Integer): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipAddPathBeziersI(GpPath *path, GDIPCONST GpPoint *points, INT count); }\r\nfunction GdipAddPathBeziersI(Path: GpPath; const Points: PGPPoint; Count: Integer): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipAddPathCurveI(GpPath *path, GDIPCONST GpPoint *points, INT count); }\r\nfunction GdipAddPathCurveI(Path: GpPath; const Points: PGPPoint; Count: Integer): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipAddPathCurve2I(GpPath *path, GDIPCONST GpPoint *points, INT count, REAL tension); }\r\nfunction GdipAddPathCurve2I(Path: GpPath; const Points: PGPPoint; Count: Integer;\r\n  Tension: Single): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipAddPathCurve3I(GpPath *path, GDIPCONST GpPoint *points, INT count, INT offset, INT numberOfSegments, REAL tension); }\r\nfunction GdipAddPathCurve3I(Path: GpPath; const Points: PGPPoint; Count: Integer;\r\n  Offset: Integer; NumberOfSegments: Integer; Tension: Single): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipAddPathClosedCurveI(GpPath *path, GDIPCONST GpPoint *points, INT count); }\r\nfunction GdipAddPathClosedCurveI(Path: GpPath; const Points: PGPPoint;\r\n  Count: Integer): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipAddPathClosedCurve2I(GpPath *path, GDIPCONST GpPoint *points, INT count, REAL tension); }\r\nfunction GdipAddPathClosedCurve2I(Path: GpPath; const Points: PGPPoint;\r\n  Count: Integer; Tension: Single): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipAddPathRectangleI(GpPath *path, INT x, INT y, INT width, INT height); }\r\nfunction GdipAddPathRectangleI(Path: GpPath; X: Integer; Y: Integer;\r\n  Width: Integer; Height: Integer): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipAddPathRectanglesI(GpPath *path, GDIPCONST GpRect *rects, INT count); }\r\nfunction GdipAddPathRectanglesI(Path: GpPath; const Rects: PGPRect;\r\n  Count: Integer): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipAddPathEllipseI(GpPath *path, INT x, INT y, INT width, INT height); }\r\nfunction GdipAddPathEllipseI(Path: GpPath; X: Integer; Y: Integer;\r\n  Width: Integer; Height: Integer): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipAddPathPieI(GpPath *path, INT x, INT y, INT width, INT height, REAL startAngle, REAL sweepAngle); }\r\nfunction GdipAddPathPieI(Path: GpPath; X: Integer; Y: Integer; Width: Integer;\r\n  Height: Integer; StartAngle: Single; SweepAngle: Single): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipAddPathPolygonI(GpPath *path, GDIPCONST GpPoint *points, INT count); }\r\nfunction GdipAddPathPolygonI(Path: GpPath; const Points: PGPPoint; Count: Integer): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipFlattenPath(GpPath *path, GpMatrix* matrix, REAL flatness); }\r\nfunction GdipFlattenPath(Path: GpPath; Matrix: GpMatrix; Flatness: Single): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipWindingModeOutline( GpPath *path, GpMatrix *matrix, REAL flatness ); }\r\nfunction GdipWindingModeOutline(Path: GpPath; Matrix: GpMatrix;\r\n  Flatness: Single): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipWidenPath( GpPath *nativePath, GpPen *pen, GpMatrix *matrix, REAL flatness ); }\r\nfunction GdipWidenPath(NativePath: GpPath; Pen: GpPen; Matrix: GpMatrix;\r\n  Flatness: Single): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipWarpPath(GpPath *path, GpMatrix* matrix, GDIPCONST GpPointF *points, INT count, REAL srcx, REAL srcy, REAL srcwidth, REAL srcheight, WarpMode warpMode, REAL flatness); }\r\nfunction GdipWarpPath(Path: GpPath; Matrix: GpMatrix; const Points: PGPPointF;\r\n  Count: Integer; Srcx: Single; Srcy: Single; Srcwidth: Single;\r\n  Srcheight: Single; WarpMode: TGPWarpMode; Flatness: Single): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipTransformPath(GpPath* path, GpMatrix* matrix); }\r\nfunction GdipTransformPath(Path: GpPath; Matrix: GpMatrix): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipGetPathWorldBounds(GpPath* path, GpRectF* bounds, GDIPCONST GpMatrix *matrix, GDIPCONST GpPen *pen); }\r\nfunction GdipGetPathWorldBounds(Path: GpPath; Bounds: PGPRectF;\r\n  const Matrix: GpMatrix; const Pen: GpPen): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipGetPathWorldBoundsI(GpPath* path, GpRect* bounds, GDIPCONST GpMatrix *matrix, GDIPCONST GpPen *pen); }\r\nfunction GdipGetPathWorldBoundsI(Path: GpPath; Bounds: PGPRect;\r\n  const Matrix: GpMatrix; const Pen: GpPen): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipIsVisiblePathPoint(GpPath* path, REAL x, REAL y, GpGraphics *graphics, BOOL *result); }\r\nfunction GdipIsVisiblePathPoint(Path: GpPath; X: Single; Y: Single;\r\n  Graphics: GpGraphics; out Result: Bool): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipIsVisiblePathPointI(GpPath* path, INT x, INT y, GpGraphics *graphics, BOOL *result); }\r\nfunction GdipIsVisiblePathPointI(Path: GpPath; X: Integer; Y: Integer;\r\n  Graphics: GpGraphics; out Result: Bool): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipIsOutlineVisiblePathPoint(GpPath* path, REAL x, REAL y, GpPen *pen, GpGraphics *graphics, BOOL *result); }\r\nfunction GdipIsOutlineVisiblePathPoint(Path: GpPath; X: Single; Y: Single;\r\n  Pen: GpPen; Graphics: GpGraphics; out Result: Bool): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipIsOutlineVisiblePathPointI(GpPath* path, INT x, INT y, GpPen *pen, GpGraphics *graphics, BOOL *result); }\r\nfunction GdipIsOutlineVisiblePathPointI(Path: GpPath; X: Integer; Y: Integer;\r\n  Pen: GpPen; Graphics: GpGraphics; out Result: Bool): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n\r\n//----------------------------------------------------------------------------\r\n// PathIterator APIs\r\n//----------------------------------------------------------------------------\r\n\r\n{ GdipCreatePathIter(GpPathIterator **iterator, GpPath* path); }\r\nfunction GdipCreatePathIter(out Iterator: GpPathIterator; Path: GpPath): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipDeletePathIter(GpPathIterator *iterator); }\r\nfunction GdipDeletePathIter(Iterator: GpPathIterator): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipPathIterNextSubpath(GpPathIterator* iterator, INT *resultCount, INT* startIndex, INT* endIndex, BOOL* isClosed); }\r\nfunction GdipPathIterNextSubpath(Iterator: GpPathIterator;\r\n  out ResultCount: Integer; out StartIndex: Integer; out EndIndex: Integer;\r\n  out IsClosed: Bool): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipPathIterNextSubpathPath(GpPathIterator* iterator, INT* resultCount, GpPath* path, BOOL* isClosed); }\r\nfunction GdipPathIterNextSubpathPath(Iterator: GpPathIterator;\r\n  out ResultCount: Integer; Path: GpPath; out IsClosed: Bool): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipPathIterNextPathType(GpPathIterator* iterator, INT* resultCount, BYTE* pathType, INT* startIndex, INT* endIndex); }\r\nfunction GdipPathIterNextPathType(Iterator: GpPathIterator;\r\n  out ResultCount: Integer; out PathType: Byte; out StartIndex: Integer;\r\n  out EndIndex: Integer): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipPathIterNextMarker(GpPathIterator* iterator, INT *resultCount, INT* startIndex, INT* endIndex); }\r\nfunction GdipPathIterNextMarker(Iterator: GpPathIterator; out ResultCount: Integer;\r\n  out StartIndex: Integer; out EndIndex: Integer): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipPathIterNextMarkerPath(GpPathIterator* iterator, INT* resultCount, GpPath* path); }\r\nfunction GdipPathIterNextMarkerPath(Iterator: GpPathIterator;\r\n  out ResultCount: Integer; Path: GpPath): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipPathIterGetCount(GpPathIterator* iterator, INT* count); }\r\nfunction GdipPathIterGetCount(Iterator: GpPathIterator; out Count: Integer): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipPathIterGetSubpathCount(GpPathIterator* iterator, INT* count); }\r\nfunction GdipPathIterGetSubpathCount(Iterator: GpPathIterator; out Count: Integer): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipPathIterIsValid(GpPathIterator* iterator, BOOL* valid); }\r\nfunction GdipPathIterIsValid(Iterator: GpPathIterator; Valid: PBool): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipPathIterHasCurve(GpPathIterator* iterator, BOOL* hasCurve); }\r\nfunction GdipPathIterHasCurve(Iterator: GpPathIterator; out HasCurve: Bool): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipPathIterRewind(GpPathIterator* iterator); }\r\nfunction GdipPathIterRewind(Iterator: GpPathIterator): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipPathIterEnumerate(GpPathIterator* iterator, INT* resultCount, GpPointF *points, BYTE *types, INT count); }\r\nfunction GdipPathIterEnumerate(Iterator: GpPathIterator; out ResultCount: Integer;\r\n  Points: PGPPointF; Types: PByte; Count: Integer): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipPathIterCopyData(GpPathIterator* iterator, INT* resultCount, GpPointF* points, BYTE* types, INT startIndex, INT endIndex); }\r\nfunction GdipPathIterCopyData(Iterator: GpPathIterator; out ResultCount: Integer;\r\n  Points: PGPPointF; Types: PByte; StartIndex: Integer; EndIndex: Integer): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n//----------------------------------------------------------------------------\r\n// Matrix APIs\r\n//----------------------------------------------------------------------------\r\n\r\n{ GdipCreateMatrix(GpMatrix **matrix); }\r\nfunction GdipCreateMatrix(out Matrix: GpMatrix): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipCreateMatrix2(REAL m11, REAL m12, REAL m21, REAL m22, REAL dx, REAL dy, GpMatrix **matrix); }\r\nfunction GdipCreateMatrix2(M11: Single; M12: Single; M21: Single; M22: Single;\r\n  Dx: Single; Dy: Single; out Matrix: GpMatrix): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipCreateMatrix3(GDIPCONST GpRectF *rect, GDIPCONST GpPointF *dstplg, GpMatrix **matrix); }\r\nfunction GdipCreateMatrix3(const Rect: PGPRectF; const Dstplg: PGPPointF;\r\n  out Matrix: GpMatrix): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipCreateMatrix3I(GDIPCONST GpRect *rect, GDIPCONST GpPoint *dstplg, GpMatrix **matrix); }\r\nfunction GdipCreateMatrix3I(const Rect: PGPRect; const Dstplg: PGPPoint;\r\n  out Matrix: GpMatrix): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipCloneMatrix(GpMatrix *matrix, GpMatrix **cloneMatrix); }\r\nfunction GdipCloneMatrix(Matrix: GpMatrix; out CloneMatrix: GpMatrix): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipDeleteMatrix(GpMatrix *matrix); }\r\nfunction GdipDeleteMatrix(Matrix: GpMatrix): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipSetMatrixElements(GpMatrix *matrix, REAL m11, REAL m12, REAL m21, REAL m22, REAL dx, REAL dy); }\r\nfunction GdipSetMatrixElements(Matrix: GpMatrix; M11: Single; M12: Single;\r\n  M21: Single; M22: Single; Dx: Single; Dy: Single): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipMultiplyMatrix(GpMatrix *matrix, GpMatrix* matrix2, GpMatrixOrder order); }\r\nfunction GdipMultiplyMatrix(Matrix: GpMatrix; Matrix2: GpMatrix;\r\n  Order: TGPMatrixOrder): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipTranslateMatrix(GpMatrix *matrix, REAL offsetX, REAL offsetY, GpMatrixOrder order); }\r\nfunction GdipTranslateMatrix(Matrix: GpMatrix; OffsetX: Single; OffsetY: Single;\r\n  Order: TGPMatrixOrder): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipScaleMatrix(GpMatrix *matrix, REAL scaleX, REAL scaleY, GpMatrixOrder order); }\r\nfunction GdipScaleMatrix(Matrix: GpMatrix; ScaleX: Single; ScaleY: Single;\r\n  Order: TGPMatrixOrder): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipRotateMatrix(GpMatrix *matrix, REAL angle, GpMatrixOrder order); }\r\nfunction GdipRotateMatrix(Matrix: GpMatrix; Angle: Single; Order: TGPMatrixOrder): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipShearMatrix(GpMatrix *matrix, REAL shearX, REAL shearY, GpMatrixOrder order); }\r\nfunction GdipShearMatrix(Matrix: GpMatrix; ShearX: Single; ShearY: Single;\r\n  Order: TGPMatrixOrder): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipInvertMatrix(GpMatrix *matrix); }\r\nfunction GdipInvertMatrix(Matrix: GpMatrix): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipTransformMatrixPoints(GpMatrix *matrix, GpPointF *pts, INT count); }\r\nfunction GdipTransformMatrixPoints(Matrix: GpMatrix; Pts: PGPPointF;\r\n  Count: Integer): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipTransformMatrixPointsI(GpMatrix *matrix, GpPoint *pts, INT count); }\r\nfunction GdipTransformMatrixPointsI(Matrix: GpMatrix; Pts: PGPPoint;\r\n  Count: Integer): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipVectorTransformMatrixPoints(GpMatrix *matrix, GpPointF *pts, INT count); }\r\nfunction GdipVectorTransformMatrixPoints(Matrix: GpMatrix; Pts: PGPPointF;\r\n  Count: Integer): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipVectorTransformMatrixPointsI(GpMatrix *matrix, GpPoint *pts, INT count); }\r\nfunction GdipVectorTransformMatrixPointsI(Matrix: GpMatrix; Pts: PGPPoint;\r\n  Count: Integer): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipGetMatrixElements(GDIPCONST GpMatrix *matrix, REAL *matrixOut); }\r\nfunction GdipGetMatrixElements(const Matrix: GpMatrix; MatrixOut: PSingle): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipIsMatrixInvertible(GDIPCONST GpMatrix *matrix, BOOL *result); }\r\nfunction GdipIsMatrixInvertible(const Matrix: GpMatrix; out Result: Bool): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipIsMatrixIdentity(GDIPCONST GpMatrix *matrix, BOOL *result); }\r\nfunction GdipIsMatrixIdentity(const Matrix: GpMatrix; out Result: Bool): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipIsMatrixEqual(GDIPCONST GpMatrix *matrix, GDIPCONST GpMatrix *matrix2, BOOL *result); }\r\nfunction GdipIsMatrixEqual(const Matrix: GpMatrix; const Matrix2: GpMatrix;\r\n  out Result: Bool): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n//----------------------------------------------------------------------------\r\n// Region APIs\r\n//----------------------------------------------------------------------------\r\n\r\n{ GdipCreateRegion(GpRegion **region); }\r\nfunction GdipCreateRegion(out Region: GpRegion): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipCreateRegionRect(GDIPCONST GpRectF *rect, GpRegion **region); }\r\nfunction GdipCreateRegionRect(const Rect: PGPRectF; out Region: GpRegion): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipCreateRegionRectI(GDIPCONST GpRect *rect, GpRegion **region); }\r\nfunction GdipCreateRegionRectI(const Rect: PGPRect; out Region: GpRegion): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipCreateRegionPath(GpPath *path, GpRegion **region); }\r\nfunction GdipCreateRegionPath(Path: GpPath; out Region: GpRegion): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipCreateRegionRgnData(GDIPCONST BYTE *regionData, INT size, GpRegion **region); }\r\nfunction GdipCreateRegionRgnData(const RegionData: PByte; Size: Integer;\r\n  out Region: GpRegion): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipCreateRegionHrgn(HRGN hRgn, GpRegion **region); }\r\nfunction GdipCreateRegionHrgn(HRgn: HRGN; out Region: GpRegion): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipCloneRegion(GpRegion *region, GpRegion **cloneRegion); }\r\nfunction GdipCloneRegion(Region: GpRegion; out CloneRegion: GpRegion): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipDeleteRegion(GpRegion *region); }\r\nfunction GdipDeleteRegion(Region: GpRegion): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipSetInfinite(GpRegion *region); }\r\nfunction GdipSetInfinite(Region: GpRegion): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipSetEmpty(GpRegion *region); }\r\nfunction GdipSetEmpty(Region: GpRegion): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipCombineRegionRect(GpRegion *region, GDIPCONST GpRectF *rect, CombineMode combineMode); }\r\nfunction GdipCombineRegionRect(Region: GpRegion; const Rect: PGPRectF;\r\n  CombineMode: TGPCombineMode): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipCombineRegionRectI(GpRegion *region, GDIPCONST GpRect *rect, CombineMode combineMode); }\r\nfunction GdipCombineRegionRectI(Region: GpRegion; const Rect: PGPRect;\r\n  CombineMode: TGPCombineMode): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipCombineRegionPath(GpRegion *region, GpPath *path, CombineMode combineMode); }\r\nfunction GdipCombineRegionPath(Region: GpRegion; Path: GpPath;\r\n  CombineMode: TGPCombineMode): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipCombineRegionRegion(GpRegion *region, GpRegion *region2, CombineMode combineMode); }\r\nfunction GdipCombineRegionRegion(Region: GpRegion; Region2: GpRegion;\r\n  CombineMode: TGPCombineMode): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipTranslateRegion(GpRegion *region, REAL dx, REAL dy); }\r\nfunction GdipTranslateRegion(Region: GpRegion; Dx: Single; Dy: Single): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipTranslateRegionI(GpRegion *region, INT dx, INT dy); }\r\nfunction GdipTranslateRegionI(Region: GpRegion; Dx: Integer; Dy: Integer): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipTransformRegion(GpRegion *region, GpMatrix *matrix); }\r\nfunction GdipTransformRegion(Region: GpRegion; Matrix: GpMatrix): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipGetRegionBounds(GpRegion *region, GpGraphics *graphics, GpRectF *rect); }\r\nfunction GdipGetRegionBounds(Region: GpRegion; Graphics: GpGraphics;\r\n  out Rect: TGPRectF): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipGetRegionBoundsI(GpRegion *region, GpGraphics *graphics, GpRect *rect); }\r\nfunction GdipGetRegionBoundsI(Region: GpRegion; Graphics: GpGraphics;\r\n  out Rect: TGPRect): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipGetRegionHRgn(GpRegion *region, GpGraphics *graphics, HRGN *hRgn); }\r\nfunction GdipGetRegionHRgn(Region: GpRegion; Graphics: GpGraphics;\r\n  out HRgn: HRgn): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipIsEmptyRegion(GpRegion *region, GpGraphics *graphics, BOOL *result); }\r\nfunction GdipIsEmptyRegion(Region: GpRegion; Graphics: GpGraphics;\r\n  out Result: Bool): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipIsInfiniteRegion(GpRegion *region, GpGraphics *graphics, BOOL *result); }\r\nfunction GdipIsInfiniteRegion(Region: GpRegion; Graphics: GpGraphics;\r\n  out Result: Bool): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipIsEqualRegion(GpRegion *region, GpRegion *region2, GpGraphics *graphics, BOOL *result); }\r\nfunction GdipIsEqualRegion(Region: GpRegion; Region2: GpRegion;\r\n  Graphics: GpGraphics; out Result: Bool): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipGetRegionDataSize(GpRegion *region, UINT * bufferSize); }\r\nfunction GdipGetRegionDataSize(Region: GpRegion; out BufferSize: Cardinal): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipGetRegionData(GpRegion *region, BYTE * buffer, UINT bufferSize, UINT * sizeFilled); }\r\nfunction GdipGetRegionData(Region: GpRegion; Buffer: Pointer;\r\n  BufferSize: Cardinal; SizeFilled: PCardinal): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipIsVisibleRegionPoint(GpRegion *region, REAL x, REAL y, GpGraphics *graphics, BOOL *result); }\r\nfunction GdipIsVisibleRegionPoint(Region: GpRegion; X: Single; Y: Single;\r\n  Graphics: GpGraphics; out Result: Bool): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipIsVisibleRegionPointI(GpRegion *region, INT x, INT y, GpGraphics *graphics, BOOL *result); }\r\nfunction GdipIsVisibleRegionPointI(Region: GpRegion; X: Integer; Y: Integer;\r\n  Graphics: GpGraphics; out Result: Bool): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipIsVisibleRegionRect(GpRegion *region, REAL x, REAL y, REAL width, REAL height, GpGraphics *graphics, BOOL *result); }\r\nfunction GdipIsVisibleRegionRect(Region: GpRegion; X: Single; Y: Single;\r\n  Width: Single; Height: Single; Graphics: GpGraphics; out Result: Bool): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipIsVisibleRegionRectI(GpRegion *region, INT x, INT y, INT width, INT height, GpGraphics *graphics, BOOL *result); }\r\nfunction GdipIsVisibleRegionRectI(Region: GpRegion; X: Integer; Y: Integer;\r\n  Width: Integer; Height: Integer; Graphics: GpGraphics; out Result: Bool): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipGetRegionScansCount(GpRegion *region, UINT* count, GpMatrix* matrix); }\r\nfunction GdipGetRegionScansCount(Region: GpRegion; out Count: Integer;\r\n  Matrix: GpMatrix): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipGetRegionScans(GpRegion *region, GpRectF* rects, INT* count, GpMatrix* matrix); }\r\nfunction GdipGetRegionScans(Region: GpRegion; Rects: PGPRectF; var Count: Integer;\r\n  Matrix: GpMatrix): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipGetRegionScansI(GpRegion *region, GpRect* rects, INT* count, GpMatrix* matrix); }\r\nfunction GdipGetRegionScansI(Region: GpRegion; Rects: PGPRect; var Count: Integer;\r\n  Matrix: GpMatrix): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n//----------------------------------------------------------------------------\r\n// Brush APIs\r\n//----------------------------------------------------------------------------\r\n\r\n{ GdipCloneBrush(GpBrush *brush, GpBrush **cloneBrush); }\r\nfunction GdipCloneBrush(Brush: GpBrush; out CloneBrush: GpBrush): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipDeleteBrush(GpBrush *brush); }\r\nfunction GdipDeleteBrush(Brush: GpBrush): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipGetBrushType(GpBrush *brush, GpBrushType *type); }\r\nfunction GdipGetBrushType(Brush: GpBrush; out AType: TGPBrushType): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n//----------------------------------------------------------------------------\r\n// HatchBrush APIs\r\n//----------------------------------------------------------------------------\r\n\r\n{ GdipCreateHatchBrush(GpHatchStyle hatchstyle, ARGB forecol, ARGB backcol, GpHatch **brush); }\r\nfunction GdipCreateHatchBrush(Hatchstyle: TGPHatchStyle; Forecol: ARGB;\r\n  Backcol: ARGB; out Brush: GpHatch): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipGetHatchStyle(GpHatch *brush, GpHatchStyle *hatchstyle); }\r\nfunction GdipGetHatchStyle(Brush: GpHatch; out Hatchstyle: TGPHatchStyle): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipGetHatchForegroundColor(GpHatch *brush, ARGB* forecol); }\r\nfunction GdipGetHatchForegroundColor(Brush: GpHatch; out Forecol: ARGB): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipGetHatchBackgroundColor(GpHatch *brush, ARGB* backcol); }\r\nfunction GdipGetHatchBackgroundColor(Brush: GpHatch; out Backcol: ARGB): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n//----------------------------------------------------------------------------\r\n// TextureBrush APIs\r\n//----------------------------------------------------------------------------\r\n\r\n{ GdipCreateTexture(GpImage *image, GpWrapMode wrapmode, GpTexture **texture); }\r\nfunction GdipCreateTexture(Image: GpImage; Wrapmode: TGPWrapMode;\r\n  out Texture: GpTexture): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipCreateTexture2(GpImage *image, GpWrapMode wrapmode, REAL x, REAL y, REAL width, REAL height, GpTexture **texture); }\r\nfunction GdipCreateTexture2(Image: GpImage; Wrapmode: TGPWrapMode; X: Single;\r\n  Y: Single; Width: Single; Height: Single; out Texture: GpTexture): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipCreateTextureIA(GpImage *image, GDIPCONST GpImageAttributes *imageAttributes, REAL x, REAL y, REAL width, REAL height, GpTexture **texture); }\r\nfunction GdipCreateTextureIA(Image: GpImage;\r\n  const ImageAttributes: GpImageAttributes; X: Single; Y: Single; Width: Single;\r\n  Height: Single; out Texture: GpTexture): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipCreateTexture2I(GpImage *image, GpWrapMode wrapmode, INT x, INT y, INT width, INT height, GpTexture **texture); }\r\nfunction GdipCreateTexture2I(Image: GpImage; Wrapmode: TGPWrapMode; X: Integer;\r\n  Y: Integer; Width: Integer; Height: Integer; out Texture: GpTexture): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipCreateTextureIAI(GpImage *image, GDIPCONST GpImageAttributes *imageAttributes, INT x, INT y, INT width, INT height, GpTexture **texture); }\r\nfunction GdipCreateTextureIAI(Image: GpImage;\r\n  const ImageAttributes: GpImageAttributes; X: Integer; Y: Integer;\r\n  Width: Integer; Height: Integer; out Texture: GpTexture): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n\r\n{ GdipGetTextureTransform(GpTexture *brush, GpMatrix *matrix); }\r\nfunction GdipGetTextureTransform(Brush: GpTexture; Matrix: GpMatrix): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipSetTextureTransform(GpTexture *brush, GDIPCONST GpMatrix *matrix); }\r\nfunction GdipSetTextureTransform(Brush: GpTexture; const Matrix: GpMatrix): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipResetTextureTransform(GpTexture* brush); }\r\nfunction GdipResetTextureTransform(Brush: GpTexture): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipMultiplyTextureTransform(GpTexture* brush, GDIPCONST GpMatrix *matrix, GpMatrixOrder order); }\r\nfunction GdipMultiplyTextureTransform(Brush: GpTexture; const Matrix: GpMatrix;\r\n  Order: TGPMatrixOrder): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipTranslateTextureTransform(GpTexture* brush, REAL dx, REAL dy, GpMatrixOrder order); }\r\nfunction GdipTranslateTextureTransform(Brush: GpTexture; Dx: Single; Dy: Single;\r\n  Order: TGPMatrixOrder): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipScaleTextureTransform(GpTexture* brush, REAL sx, REAL sy, GpMatrixOrder order); }\r\nfunction GdipScaleTextureTransform(Brush: GpTexture; Sx: Single; Sy: Single;\r\n  Order: TGPMatrixOrder): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipRotateTextureTransform(GpTexture* brush, REAL angle, GpMatrixOrder order); }\r\nfunction GdipRotateTextureTransform(Brush: GpTexture; Angle: Single;\r\n  Order: TGPMatrixOrder): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipSetTextureWrapMode(GpTexture *brush, GpWrapMode wrapmode); }\r\nfunction GdipSetTextureWrapMode(Brush: GpTexture; Wrapmode: TGPWrapMode): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipGetTextureWrapMode(GpTexture *brush, GpWrapMode *wrapmode); }\r\nfunction GdipGetTextureWrapMode(Brush: GpTexture; out Wrapmode: TGPWrapMode): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipGetTextureImage(GpTexture *brush, GpImage **image); }\r\nfunction GdipGetTextureImage(Brush: GpTexture; out Image: GpImage): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n//----------------------------------------------------------------------------\r\n// SolidBrush APIs\r\n//----------------------------------------------------------------------------\r\n\r\n{ GdipCreateSolidFill(ARGB color, GpSolidFill **brush); }\r\nfunction GdipCreateSolidFill(Color: ARGB; out Brush: GpSolidFill): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipSetSolidFillColor(GpSolidFill *brush, ARGB color); }\r\nfunction GdipSetSolidFillColor(Brush: GpSolidFill; Color: ARGB): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipGetSolidFillColor(GpSolidFill *brush, ARGB *color); }\r\nfunction GdipGetSolidFillColor(Brush: GpSolidFill; out Color: ARGB): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n//----------------------------------------------------------------------------\r\n// LineBrush APIs\r\n//----------------------------------------------------------------------------\r\n\r\n{ GdipCreateLineBrush(GDIPCONST GpPointF* point1, GDIPCONST GpPointF* point2, ARGB color1, ARGB color2, GpWrapMode wrapMode, GpLineGradient **lineGradient); }\r\nfunction GdipCreateLineBrush(const Point1: PGPPointF; const Point2: PGPPointF;\r\n  Color1: ARGB; Color2: ARGB; WrapMode: TGPWrapMode;\r\n  out LineGradient: GpLineGradient): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipCreateLineBrushI(GDIPCONST GpPoint* point1, GDIPCONST GpPoint* point2, ARGB color1, ARGB color2, GpWrapMode wrapMode, GpLineGradient **lineGradient); }\r\nfunction GdipCreateLineBrushI(const Point1: PGPPoint; const Point2: PGPPoint;\r\n  Color1: ARGB; Color2: ARGB; WrapMode: TGPWrapMode;\r\n  out LineGradient: GpLineGradient): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipCreateLineBrushFromRect(GDIPCONST GpRectF* rect, ARGB color1, ARGB color2, LinearGradientMode mode, GpWrapMode wrapMode, GpLineGradient **lineGradient); }\r\nfunction GdipCreateLineBrushFromRect(const Rect: PGPRectF; Color1: ARGB;\r\n  Color2: ARGB; Mode: TGPLinearGradientMode; WrapMode: TGPWrapMode;\r\n  out LineGradient: GpLineGradient): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipCreateLineBrushFromRectI(GDIPCONST GpRect* rect, ARGB color1, ARGB color2, LinearGradientMode mode, GpWrapMode wrapMode, GpLineGradient **lineGradient); }\r\nfunction GdipCreateLineBrushFromRectI(const Rect: PGPRect; Color1: ARGB;\r\n  Color2: ARGB; Mode: TGPLinearGradientMode; WrapMode: TGPWrapMode;\r\n  out LineGradient: GpLineGradient): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipCreateLineBrushFromRectWithAngle(GDIPCONST GpRectF* rect, ARGB color1, ARGB color2, REAL angle, BOOL isAngleScalable, GpWrapMode wrapMode, GpLineGradient **lineGradient); }\r\nfunction GdipCreateLineBrushFromRectWithAngle(const Rect: PGPRectF; Color1: ARGB;\r\n  Color2: ARGB; Angle: Single; IsAngleScalable: Bool; WrapMode: TGPWrapMode;\r\n  out LineGradient: GpLineGradient): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipCreateLineBrushFromRectWithAngleI(GDIPCONST GpRect* rect, ARGB color1, ARGB color2, REAL angle, BOOL isAngleScalable, GpWrapMode wrapMode, GpLineGradient **lineGradient); }\r\nfunction GdipCreateLineBrushFromRectWithAngleI(const Rect: PGPRect; Color1: ARGB;\r\n  Color2: ARGB; Angle: Single; IsAngleScalable: Bool; WrapMode: TGPWrapMode;\r\n  out LineGradient: GpLineGradient): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipSetLineColors(GpLineGradient *brush, ARGB color1, ARGB color2); }\r\nfunction GdipSetLineColors(Brush: GpLineGradient; Color1: ARGB; Color2: ARGB): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipGetLineColors(GpLineGradient *brush, ARGB* colors); }\r\nfunction GdipGetLineColors(Brush: GpLineGradient; Colors: PARGB): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipGetLineRect(GpLineGradient *brush, GpRectF *rect); }\r\nfunction GdipGetLineRect(Brush: GpLineGradient; out Rect: TGPRectF): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipGetLineRectI(GpLineGradient *brush, GpRect *rect); }\r\nfunction GdipGetLineRectI(Brush: GpLineGradient; out Rect: TGPRect): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipSetLineGammaCorrection(GpLineGradient *brush, BOOL useGammaCorrection); }\r\nfunction GdipSetLineGammaCorrection(Brush: GpLineGradient;\r\n  UseGammaCorrection: Bool): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipGetLineGammaCorrection(GpLineGradient *brush, BOOL *useGammaCorrection); }\r\nfunction GdipGetLineGammaCorrection(Brush: GpLineGradient;\r\n  out UseGammaCorrection: Bool): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipGetLineBlendCount(GpLineGradient *brush, INT *count); }\r\nfunction GdipGetLineBlendCount(Brush: GpLineGradient; out Count: Integer): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipGetLineBlend(GpLineGradient *brush, REAL *blend, REAL* positions, INT count); }\r\nfunction GdipGetLineBlend(Brush: GpLineGradient; Blend: PSingle;\r\n  Positions: PSingle; Count: Integer): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipSetLineBlend(GpLineGradient *brush, GDIPCONST REAL *blend, GDIPCONST REAL* positions, INT count); }\r\nfunction GdipSetLineBlend(Brush: GpLineGradient; const Blend: PSingle;\r\n  const Positions: PSingle; Count: Integer): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipGetLinePresetBlendCount(GpLineGradient *brush, INT *count); }\r\nfunction GdipGetLinePresetBlendCount(Brush: GpLineGradient; out Count: Integer): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipGetLinePresetBlend(GpLineGradient *brush, ARGB *blend, REAL* positions, INT count); }\r\nfunction GdipGetLinePresetBlend(Brush: GpLineGradient; Blend: PARGB;\r\n  Positions: PSingle; Count: Integer): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipSetLinePresetBlend(GpLineGradient *brush, GDIPCONST ARGB *blend, GDIPCONST REAL* positions, INT count); }\r\nfunction GdipSetLinePresetBlend(Brush: GpLineGradient; const Blend: PARGB;\r\n  const Positions: PSingle; Count: Integer): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipSetLineSigmaBlend(GpLineGradient *brush, REAL focus, REAL scale); }\r\nfunction GdipSetLineSigmaBlend(Brush: GpLineGradient; Focus: Single;\r\n  Scale: Single): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipSetLineLinearBlend(GpLineGradient *brush, REAL focus, REAL scale); }\r\nfunction GdipSetLineLinearBlend(Brush: GpLineGradient; Focus: Single;\r\n  Scale: Single): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipSetLineWrapMode(GpLineGradient *brush, GpWrapMode wrapmode); }\r\nfunction GdipSetLineWrapMode(Brush: GpLineGradient; Wrapmode: TGPWrapMode): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipGetLineWrapMode(GpLineGradient *brush, GpWrapMode *wrapmode); }\r\nfunction GdipGetLineWrapMode(Brush: GpLineGradient; out Wrapmode: TGPWrapMode): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipGetLineTransform(GpLineGradient *brush, GpMatrix *matrix); }\r\nfunction GdipGetLineTransform(Brush: GpLineGradient; Matrix: GpMatrix): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipSetLineTransform(GpLineGradient *brush, GDIPCONST GpMatrix *matrix); }\r\nfunction GdipSetLineTransform(Brush: GpLineGradient; const Matrix: GpMatrix): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipResetLineTransform(GpLineGradient* brush); }\r\nfunction GdipResetLineTransform(Brush: GpLineGradient): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipMultiplyLineTransform(GpLineGradient* brush, GDIPCONST GpMatrix *matrix, GpMatrixOrder order); }\r\nfunction GdipMultiplyLineTransform(Brush: GpLineGradient;\r\n  const Matrix: GpMatrix; Order: TGPMatrixOrder): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipTranslateLineTransform(GpLineGradient* brush, REAL dx, REAL dy, GpMatrixOrder order); }\r\nfunction GdipTranslateLineTransform(Brush: GpLineGradient; Dx: Single;\r\n  Dy: Single; Order: TGPMatrixOrder): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipScaleLineTransform(GpLineGradient* brush, REAL sx, REAL sy, GpMatrixOrder order); }\r\nfunction GdipScaleLineTransform(Brush: GpLineGradient; Sx: Single; Sy: Single;\r\n  Order: TGPMatrixOrder): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipRotateLineTransform(GpLineGradient* brush, REAL angle, GpMatrixOrder order); }\r\nfunction GdipRotateLineTransform(Brush: GpLineGradient; Angle: Single;\r\n  Order: TGPMatrixOrder): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n//----------------------------------------------------------------------------\r\n// PathGradientBrush APIs\r\n//----------------------------------------------------------------------------\r\n\r\n{ GdipCreatePathGradient(GDIPCONST GpPointF* points, INT count, GpWrapMode wrapMode, GpPathGradient **polyGradient); }\r\nfunction GdipCreatePathGradient(const Points: PGPPointF; Count: Integer;\r\n  WrapMode: TGPWrapMode; out PolyGradient: GpPathGradient): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipCreatePathGradientI(GDIPCONST GpPoint* points, INT count, GpWrapMode wrapMode, GpPathGradient **polyGradient); }\r\nfunction GdipCreatePathGradientI(const Points: PGPPoint; Count: Integer;\r\n  WrapMode: TGPWrapMode; out PolyGradient: GpPathGradient): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipCreatePathGradientFromPath(GDIPCONST GpPath* path, GpPathGradient **polyGradient); }\r\nfunction GdipCreatePathGradientFromPath(const Path: GpPath;\r\n  out PolyGradient: GpPathGradient): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipGetPathGradientCenterColor( GpPathGradient *brush, ARGB* colors); }\r\nfunction GdipGetPathGradientCenterColor(Brush: GpPathGradient; out Color: ARGB): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipSetPathGradientCenterColor( GpPathGradient *brush, ARGB colors); }\r\nfunction GdipSetPathGradientCenterColor(Brush: GpPathGradient; Color: ARGB): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipGetPathGradientSurroundColorsWithCount( GpPathGradient *brush, ARGB* color, INT* count); }\r\nfunction GdipGetPathGradientSurroundColorsWithCount(Brush: GpPathGradient;\r\n  Color: PARGB; out Count: Integer): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipSetPathGradientSurroundColorsWithCount( GpPathGradient *brush, GDIPCONST ARGB* color, INT* count); }\r\nfunction GdipSetPathGradientSurroundColorsWithCount(Brush: GpPathGradient;\r\n  const Color: PARGB; out Count: Integer): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipGetPathGradientPath(GpPathGradient *brush, GpPath *path); }\r\nfunction GdipGetPathGradientPath(Brush: GpPathGradient; Path: GpPath): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipSetPathGradientPath(GpPathGradient *brush, GDIPCONST GpPath *path); }\r\nfunction GdipSetPathGradientPath(Brush: GpPathGradient; const Path: GpPath): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipGetPathGradientCenterPoint( GpPathGradient *brush, GpPointF* points); }\r\nfunction GdipGetPathGradientCenterPoint(Brush: GpPathGradient; out Point: TGPPointF): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipGetPathGradientCenterPointI( GpPathGradient *brush, GpPoint* points); }\r\nfunction GdipGetPathGradientCenterPointI(Brush: GpPathGradient; out Point: TGPPoint): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipSetPathGradientCenterPoint( GpPathGradient *brush, GDIPCONST GpPointF* points); }\r\nfunction GdipSetPathGradientCenterPoint(Brush: GpPathGradient;\r\n  const Point: PGPPointF): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipSetPathGradientCenterPointI( GpPathGradient *brush, GDIPCONST GpPoint* points); }\r\nfunction GdipSetPathGradientCenterPointI(Brush: GpPathGradient;\r\n  const Point: PGPPoint): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipGetPathGradientRect(GpPathGradient *brush, GpRectF *rect); }\r\nfunction GdipGetPathGradientRect(Brush: GpPathGradient; out Rect: TGPRectF): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipGetPathGradientRectI(GpPathGradient *brush, GpRect *rect); }\r\nfunction GdipGetPathGradientRectI(Brush: GpPathGradient; out Rect: TGPRect): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipGetPathGradientPointCount(GpPathGradient *brush, INT* count); }\r\nfunction GdipGetPathGradientPointCount(Brush: GpPathGradient; out Count: Integer): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipGetPathGradientSurroundColorCount(GpPathGradient *brush, INT* count); }\r\nfunction GdipGetPathGradientSurroundColorCount(Brush: GpPathGradient;\r\n  out Count: Integer): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipSetPathGradientGammaCorrection(GpPathGradient *brush, BOOL useGammaCorrection); }\r\nfunction GdipSetPathGradientGammaCorrection(Brush: GpPathGradient;\r\n  UseGammaCorrection: Bool): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipGetPathGradientGammaCorrection(GpPathGradient *brush, BOOL *useGammaCorrection); }\r\nfunction GdipGetPathGradientGammaCorrection(Brush: GpPathGradient;\r\n  out UseGammaCorrection: Bool): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipGetPathGradientBlendCount(GpPathGradient *brush, INT *count); }\r\nfunction GdipGetPathGradientBlendCount(Brush: GpPathGradient; out Count: Integer): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipGetPathGradientBlend(GpPathGradient *brush, REAL *blend, REAL *positions, INT count); }\r\nfunction GdipGetPathGradientBlend(Brush: GpPathGradient; Blend: PSingle;\r\n  Positions: PSingle; Count: Integer): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipSetPathGradientBlend(GpPathGradient *brush, GDIPCONST REAL *blend, GDIPCONST REAL *positions, INT count); }\r\nfunction GdipSetPathGradientBlend(Brush: GpPathGradient; const Blend: PSingle;\r\n  const Positions: PSingle; Count: Integer): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipGetPathGradientPresetBlendCount(GpPathGradient *brush, INT *count); }\r\nfunction GdipGetPathGradientPresetBlendCount(Brush: GpPathGradient;\r\n  out Count: Integer): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipGetPathGradientPresetBlend(GpPathGradient *brush, ARGB *blend, REAL* positions, INT count); }\r\nfunction GdipGetPathGradientPresetBlend(Brush: GpPathGradient; Blend: PARGB;\r\n  Positions: PSingle; Count: Integer): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipSetPathGradientPresetBlend(GpPathGradient *brush, GDIPCONST ARGB *blend, GDIPCONST REAL* positions, INT count); }\r\nfunction GdipSetPathGradientPresetBlend(Brush: GpPathGradient;\r\n  const Blend: PARGB; const Positions: PSingle; Count: Integer): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipSetPathGradientSigmaBlend(GpPathGradient *brush, REAL focus, REAL scale); }\r\nfunction GdipSetPathGradientSigmaBlend(Brush: GpPathGradient; Focus: Single;\r\n  Scale: Single): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipSetPathGradientLinearBlend(GpPathGradient *brush, REAL focus, REAL scale); }\r\nfunction GdipSetPathGradientLinearBlend(Brush: GpPathGradient; Focus: Single;\r\n  Scale: Single): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipGetPathGradientWrapMode(GpPathGradient *brush, GpWrapMode *wrapmode); }\r\nfunction GdipGetPathGradientWrapMode(Brush: GpPathGradient;\r\n  out Wrapmode: TGPWrapMode): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipSetPathGradientWrapMode(GpPathGradient *brush, GpWrapMode wrapmode); }\r\nfunction GdipSetPathGradientWrapMode(Brush: GpPathGradient; Wrapmode: TGPWrapMode): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipGetPathGradientTransform(GpPathGradient *brush, GpMatrix *matrix); }\r\nfunction GdipGetPathGradientTransform(Brush: GpPathGradient; Matrix: GpMatrix): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipSetPathGradientTransform(GpPathGradient *brush, GpMatrix *matrix); }\r\nfunction GdipSetPathGradientTransform(Brush: GpPathGradient; Matrix: GpMatrix): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipResetPathGradientTransform(GpPathGradient* brush); }\r\nfunction GdipResetPathGradientTransform(Brush: GpPathGradient): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipMultiplyPathGradientTransform(GpPathGradient* brush, GDIPCONST GpMatrix *matrix, GpMatrixOrder order); }\r\nfunction GdipMultiplyPathGradientTransform(Brush: GpPathGradient;\r\n  const Matrix: GpMatrix; Order: TGPMatrixOrder): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipTranslatePathGradientTransform(GpPathGradient* brush, REAL dx, REAL dy, GpMatrixOrder order); }\r\nfunction GdipTranslatePathGradientTransform(Brush: GpPathGradient; Dx: Single;\r\n  Dy: Single; Order: TGPMatrixOrder): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipScalePathGradientTransform(GpPathGradient* brush, REAL sx, REAL sy, GpMatrixOrder order); }\r\nfunction GdipScalePathGradientTransform(Brush: GpPathGradient; Sx: Single;\r\n  Sy: Single; Order: TGPMatrixOrder): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipRotatePathGradientTransform(GpPathGradient* brush, REAL angle, GpMatrixOrder order); }\r\nfunction GdipRotatePathGradientTransform(Brush: GpPathGradient; Angle: Single;\r\n  Order: TGPMatrixOrder): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipGetPathGradientFocusScales(GpPathGradient *brush, REAL* xScale, REAL* yScale); }\r\nfunction GdipGetPathGradientFocusScales(Brush: GpPathGradient; out XScale: Single;\r\n  out YScale: Single): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipSetPathGradientFocusScales(GpPathGradient *brush, REAL xScale, REAL yScale); }\r\nfunction GdipSetPathGradientFocusScales(Brush: GpPathGradient; XScale: Single;\r\n  YScale: Single): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n//----------------------------------------------------------------------------\r\n// Pen APIs\r\n//----------------------------------------------------------------------------\r\n\r\n{ GdipCreatePen1(ARGB color, REAL width, GpUnit unit, GpPen **pen); }\r\nfunction GdipCreatePen1(Color: ARGB; Width: Single; AUnit: TGPUnit;\r\n  out Pen: GpPen): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipCreatePen2(GpBrush *brush, REAL width, GpUnit unit, GpPen **pen); }\r\nfunction GdipCreatePen2(Brush: GpBrush; Width: Single; AUnit: TGPUnit;\r\n  out Pen: GpPen): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipClonePen(GpPen *pen, GpPen **clonepen); }\r\nfunction GdipClonePen(Pen: GpPen; out Clonepen: GpPen): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipDeletePen(GpPen *pen); }\r\nfunction GdipDeletePen(Pen: GpPen): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipSetPenWidth(GpPen *pen, REAL width); }\r\nfunction GdipSetPenWidth(Pen: GpPen; Width: Single): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipGetPenWidth(GpPen *pen, REAL *width); }\r\nfunction GdipGetPenWidth(Pen: GpPen; out Width: Single): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipSetPenUnit(GpPen *pen, GpUnit unit); }\r\nfunction GdipSetPenUnit(Pen: GpPen; AUnit: TGPUnit): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipGetPenUnit(GpPen *pen, GpUnit *unit); }\r\nfunction GdipGetPenUnit(Pen: GpPen; out AUnit: TGPUnit): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipSetPenLineCap197819(GpPen *pen, GpLineCap startCap, GpLineCap endCap, GpDashCap dashCap); }\r\nfunction GdipSetPenLineCap197819(Pen: GpPen; StartCap: TGPLineCap;\r\n  EndCap: TGPLineCap; DashCap: TGPDashCap): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipSetPenStartCap(GpPen *pen, GpLineCap startCap); }\r\nfunction GdipSetPenStartCap(Pen: GpPen; StartCap: TGPLineCap): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipSetPenEndCap(GpPen *pen, GpLineCap endCap); }\r\nfunction GdipSetPenEndCap(Pen: GpPen; EndCap: TGPLineCap): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipSetPenDashCap197819(GpPen *pen, GpDashCap dashCap); }\r\nfunction GdipSetPenDashCap197819(Pen: GpPen; DashCap: TGPDashCap): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipGetPenStartCap(GpPen *pen, GpLineCap *startCap); }\r\nfunction GdipGetPenStartCap(Pen: GpPen; out StartCap: TGPLineCap): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipGetPenEndCap(GpPen *pen, GpLineCap *endCap); }\r\nfunction GdipGetPenEndCap(Pen: GpPen; out EndCap: TGPLineCap): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipGetPenDashCap197819(GpPen *pen, GpDashCap *dashCap); }\r\nfunction GdipGetPenDashCap197819(Pen: GpPen; out DashCap: TGPDashCap): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipSetPenLineJoin(GpPen *pen, GpLineJoin lineJoin); }\r\nfunction GdipSetPenLineJoin(Pen: GpPen; LineJoin: TGPLineJoin): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipGetPenLineJoin(GpPen *pen, GpLineJoin *lineJoin); }\r\nfunction GdipGetPenLineJoin(Pen: GpPen; out LineJoin: TGPLineJoin): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipSetPenCustomStartCap(GpPen *pen, GpCustomLineCap* customCap); }\r\nfunction GdipSetPenCustomStartCap(Pen: GpPen; CustomCap: GpCustomLineCap): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipGetPenCustomStartCap(GpPen *pen, GpCustomLineCap** customCap); }\r\nfunction GdipGetPenCustomStartCap(Pen: GpPen; out CustomCap: GpCustomLineCap): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipSetPenCustomEndCap(GpPen *pen, GpCustomLineCap* customCap); }\r\nfunction GdipSetPenCustomEndCap(Pen: GpPen; CustomCap: GpCustomLineCap): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipGetPenCustomEndCap(GpPen *pen, GpCustomLineCap** customCap); }\r\nfunction GdipGetPenCustomEndCap(Pen: GpPen; out CustomCap: GpCustomLineCap): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipSetPenMiterLimit(GpPen *pen, REAL miterLimit); }\r\nfunction GdipSetPenMiterLimit(Pen: GpPen; MiterLimit: Single): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipGetPenMiterLimit(GpPen *pen, REAL *miterLimit); }\r\nfunction GdipGetPenMiterLimit(Pen: GpPen; out MiterLimit: Single): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipSetPenMode(GpPen *pen, GpPenAlignment penMode); }\r\nfunction GdipSetPenMode(Pen: GpPen; PenMode: TGPPenAlignment): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipGetPenMode(GpPen *pen, GpPenAlignment *penMode); }\r\nfunction GdipGetPenMode(Pen: GpPen; out PenMode: TGPPenAlignment): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipSetPenTransform(GpPen *pen, GpMatrix *matrix); }\r\nfunction GdipSetPenTransform(Pen: GpPen; Matrix: GpMatrix): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipGetPenTransform(GpPen *pen, GpMatrix *matrix); }\r\nfunction GdipGetPenTransform(Pen: GpPen; Matrix: GpMatrix): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipResetPenTransform(GpPen *pen); }\r\nfunction GdipResetPenTransform(Pen: GpPen): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipMultiplyPenTransform(GpPen *pen, GDIPCONST GpMatrix *matrix, GpMatrixOrder order); }\r\nfunction GdipMultiplyPenTransform(Pen: GpPen; const Matrix: GpMatrix;\r\n  Order: TGPMatrixOrder): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipTranslatePenTransform(GpPen *pen, REAL dx, REAL dy, GpMatrixOrder order); }\r\nfunction GdipTranslatePenTransform(Pen: GpPen; Dx: Single; Dy: Single;\r\n  Order: TGPMatrixOrder): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipScalePenTransform(GpPen *pen, REAL sx, REAL sy, GpMatrixOrder order); }\r\nfunction GdipScalePenTransform(Pen: GpPen; Sx: Single; Sy: Single;\r\n  Order: TGPMatrixOrder): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipRotatePenTransform(GpPen *pen, REAL angle, GpMatrixOrder order); }\r\nfunction GdipRotatePenTransform(Pen: GpPen; Angle: Single; Order: TGPMatrixOrder): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipSetPenColor(GpPen *pen, ARGB argb); }\r\nfunction GdipSetPenColor(Pen: GpPen; Argb: ARGB): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipGetPenColor(GpPen *pen, ARGB *argb); }\r\nfunction GdipGetPenColor(Pen: GpPen; out Argb: ARGB): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipSetPenBrushFill(GpPen *pen, GpBrush *brush); }\r\nfunction GdipSetPenBrushFill(Pen: GpPen; Brush: GpBrush): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipGetPenBrushFill(GpPen *pen, GpBrush **brush); }\r\nfunction GdipGetPenBrushFill(Pen: GpPen; out Brush: GpBrush): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipGetPenFillType(GpPen *pen, GpPenType* type); }\r\nfunction GdipGetPenFillType(Pen: GpPen; out AType: TGPPenType): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipGetPenDashStyle(GpPen *pen, GpDashStyle *dashstyle); }\r\nfunction GdipGetPenDashStyle(Pen: GpPen; out Dashstyle: TGPDashStyle): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipSetPenDashStyle(GpPen *pen, GpDashStyle dashstyle); }\r\nfunction GdipSetPenDashStyle(Pen: GpPen; Dashstyle: TGPDashStyle): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipGetPenDashOffset(GpPen *pen, REAL *offset); }\r\nfunction GdipGetPenDashOffset(Pen: GpPen; out Offset: Single): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipSetPenDashOffset(GpPen *pen, REAL offset); }\r\nfunction GdipSetPenDashOffset(Pen: GpPen; Offset: Single): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipGetPenDashCount(GpPen *pen, INT *count); }\r\nfunction GdipGetPenDashCount(Pen: GpPen; out Count: Integer): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipSetPenDashArray(GpPen *pen, GDIPCONST REAL *dash, INT count); }\r\nfunction GdipSetPenDashArray(Pen: GpPen; const Dash: PSingle; Count: Integer): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipGetPenDashArray(GpPen *pen, REAL *dash, INT count); }\r\nfunction GdipGetPenDashArray(Pen: GpPen; Dash: PSingle; Count: Integer): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipGetPenCompoundCount(GpPen *pen, INT *count); }\r\nfunction GdipGetPenCompoundCount(Pen: GpPen; out Count: Integer): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipSetPenCompoundArray(GpPen *pen, GDIPCONST REAL *dash, INT count); }\r\nfunction GdipSetPenCompoundArray(Pen: GpPen; const Dash: PSingle;\r\n  Count: Integer): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipGetPenCompoundArray(GpPen *pen, REAL *dash, INT count); }\r\nfunction GdipGetPenCompoundArray(Pen: GpPen; Dash: PSingle; Count: Integer): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n//----------------------------------------------------------------------------\r\n// CustomLineCap APIs\r\n//----------------------------------------------------------------------------\r\n\r\n{ GdipCreateCustomLineCap(GpPath* fillPath, GpPath* strokePath, GpLineCap baseCap, REAL baseInset, GpCustomLineCap **customCap); }\r\nfunction GdipCreateCustomLineCap(FillPath: GpPath; StrokePath: GpPath;\r\n  BaseCap: TGPLineCap; BaseInset: Single; out CustomCap: GpCustomLineCap): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipDeleteCustomLineCap(GpCustomLineCap* customCap); }\r\nfunction GdipDeleteCustomLineCap(CustomCap: GpCustomLineCap): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipCloneCustomLineCap(GpCustomLineCap* customCap, GpCustomLineCap** clonedCap); }\r\nfunction GdipCloneCustomLineCap(CustomCap: GpCustomLineCap;\r\n  out ClonedCap: GpCustomLineCap): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipGetCustomLineCapType(GpCustomLineCap* customCap, CustomLineCapType* capType); }\r\nfunction GdipGetCustomLineCapType(CustomCap: GpCustomLineCap;\r\n  out CapType: TGPCustomLineCapType): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipSetCustomLineCapStrokeCaps(GpCustomLineCap* customCap, GpLineCap startCap, GpLineCap endCap); }\r\nfunction GdipSetCustomLineCapStrokeCaps(CustomCap: GpCustomLineCap;\r\n  StartCap: TGPLineCap; EndCap: TGPLineCap): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipGetCustomLineCapStrokeCaps(GpCustomLineCap* customCap, GpLineCap* startCap, GpLineCap* endCap); }\r\nfunction GdipGetCustomLineCapStrokeCaps(CustomCap: GpCustomLineCap;\r\n  out StartCap: TGPLineCap; out EndCap: TGPLineCap): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipSetCustomLineCapStrokeJoin(GpCustomLineCap* customCap, GpLineJoin lineJoin); }\r\nfunction GdipSetCustomLineCapStrokeJoin(CustomCap: GpCustomLineCap;\r\n  LineJoin: TGPLineJoin): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipGetCustomLineCapStrokeJoin(GpCustomLineCap* customCap, GpLineJoin* lineJoin); }\r\nfunction GdipGetCustomLineCapStrokeJoin(CustomCap: GpCustomLineCap;\r\n  out LineJoin: TGPLineJoin): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipSetCustomLineCapBaseCap(GpCustomLineCap* customCap, GpLineCap baseCap); }\r\nfunction GdipSetCustomLineCapBaseCap(CustomCap: GpCustomLineCap;\r\n  BaseCap: TGPLineCap): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipGetCustomLineCapBaseCap(GpCustomLineCap* customCap, GpLineCap* baseCap); }\r\nfunction GdipGetCustomLineCapBaseCap(CustomCap: GpCustomLineCap;\r\n  out BaseCap: TGPLineCap): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipSetCustomLineCapBaseInset(GpCustomLineCap* customCap, REAL inset); }\r\nfunction GdipSetCustomLineCapBaseInset(CustomCap: GpCustomLineCap;\r\n  Inset: Single): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipGetCustomLineCapBaseInset(GpCustomLineCap* customCap, REAL* inset); }\r\nfunction GdipGetCustomLineCapBaseInset(CustomCap: GpCustomLineCap;\r\n  out Inset: Single): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipSetCustomLineCapWidthScale(GpCustomLineCap* customCap, REAL widthScale); }\r\nfunction GdipSetCustomLineCapWidthScale(CustomCap: GpCustomLineCap;\r\n  WidthScale: Single): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipGetCustomLineCapWidthScale(GpCustomLineCap* customCap, REAL* widthScale); }\r\nfunction GdipGetCustomLineCapWidthScale(CustomCap: GpCustomLineCap;\r\n  out WidthScale: Single): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n//----------------------------------------------------------------------------\r\n// AdjustableArrowCap APIs\r\n//----------------------------------------------------------------------------\r\n\r\n{ GdipCreateAdjustableArrowCap(REAL height, REAL width, BOOL isFilled, GpAdjustableArrowCap **cap); }\r\nfunction GdipCreateAdjustableArrowCap(Height: Single; Width: Single;\r\n  IsFilled: Bool; out Cap: GpAdjustableArrowCap): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipSetAdjustableArrowCapHeight(GpAdjustableArrowCap* cap, REAL height); }\r\nfunction GdipSetAdjustableArrowCapHeight(Cap: GpAdjustableArrowCap;\r\n  Height: Single): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipGetAdjustableArrowCapHeight(GpAdjustableArrowCap* cap, REAL* height); }\r\nfunction GdipGetAdjustableArrowCapHeight(Cap: GpAdjustableArrowCap;\r\n  out Height: Single): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipSetAdjustableArrowCapWidth(GpAdjustableArrowCap* cap, REAL width); }\r\nfunction GdipSetAdjustableArrowCapWidth(Cap: GpAdjustableArrowCap;\r\n  Width: Single): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipGetAdjustableArrowCapWidth(GpAdjustableArrowCap* cap, REAL* width); }\r\nfunction GdipGetAdjustableArrowCapWidth(Cap: GpAdjustableArrowCap;\r\n  out Width: Single): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipSetAdjustableArrowCapMiddleInset(GpAdjustableArrowCap* cap, REAL middleInset); }\r\nfunction GdipSetAdjustableArrowCapMiddleInset(Cap: GpAdjustableArrowCap;\r\n  MiddleInset: Single): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipGetAdjustableArrowCapMiddleInset(GpAdjustableArrowCap* cap, REAL* middleInset); }\r\nfunction GdipGetAdjustableArrowCapMiddleInset(Cap: GpAdjustableArrowCap;\r\n  out MiddleInset: Single): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipSetAdjustableArrowCapFillState(GpAdjustableArrowCap* cap, BOOL fillState); }\r\nfunction GdipSetAdjustableArrowCapFillState(Cap: GpAdjustableArrowCap;\r\n  FillState: Bool): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipGetAdjustableArrowCapFillState(GpAdjustableArrowCap* cap, BOOL* fillState); }\r\nfunction GdipGetAdjustableArrowCapFillState(Cap: GpAdjustableArrowCap;\r\n  out FillState: Bool): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n//----------------------------------------------------------------------------\r\n// Image APIs\r\n//----------------------------------------------------------------------------\r\n\r\n{ GdipLoadImageFromStream(IStream* stream, GpImage **image); }\r\nfunction GdipLoadImageFromStream(const Stream: IStream; out Image: GpImage): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipLoadImageFromFile(GDIPCONST WCHAR* filename, GpImage **image); }\r\nfunction GdipLoadImageFromFile(const Filename: PWideChar; out Image: GpImage): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipLoadImageFromStreamICM(IStream* stream, GpImage **image); }\r\nfunction GdipLoadImageFromStreamICM(const Stream: IStream; out Image: GpImage): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipLoadImageFromFileICM(GDIPCONST WCHAR* filename, GpImage **image); }\r\nfunction GdipLoadImageFromFileICM(const Filename: PWideChar; out Image: GpImage): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipCloneImage(GpImage *image, GpImage **cloneImage); }\r\nfunction GdipCloneImage(Image: GpImage; out CloneImage: GpImage): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipDisposeImage(GpImage *image); }\r\nfunction GdipDisposeImage(Image: GpImage): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipSaveImageToFile(GpImage *image, GDIPCONST WCHAR* filename, GDIPCONST CLSID* clsidEncoder, GDIPCONST EncoderParameters* encoderParams); }\r\nfunction GdipSaveImageToFile(Image: GpImage; const Filename: PWideChar;\r\n  const ClsidEncoder: TGUID; const EncoderParams: PGPNativeEncoderParameters): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipSaveImageToStream(GpImage *image, IStream* stream, GDIPCONST CLSID* clsidEncoder, GDIPCONST EncoderParameters* encoderParams); }\r\nfunction GdipSaveImageToStream(Image: GpImage; const Stream: IStream;\r\n  const ClsidEncoder: TGUID; const EncoderParams: PGPNativeEncoderParameters): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipSaveAdd(GpImage *image, GDIPCONST EncoderParameters* encoderParams); }\r\nfunction GdipSaveAdd(Image: GpImage; const EncoderParams: PGPNativeEncoderParameters): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipSaveAddImage(GpImage *image, GpImage* newImage, GDIPCONST EncoderParameters* encoderParams); }\r\nfunction GdipSaveAddImage(Image: GpImage; NewImage: GpImage;\r\n  const EncoderParams: PGPNativeEncoderParameters): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipGetImageGraphicsContext(GpImage *image, GpGraphics **graphics); }\r\nfunction GdipGetImageGraphicsContext(Image: GpImage; out Graphics: GpGraphics): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipGetImageBounds(GpImage *image, GpRectF *srcRect, GpUnit *srcUnit); }\r\nfunction GdipGetImageBounds(Image: GpImage; out SrcRect: TGPRectF;\r\n  out SrcUnit: TGPUnit): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipGetImageDimension(GpImage *image, REAL *width, REAL *height); }\r\nfunction GdipGetImageDimension(Image: GpImage; out Width: Single;\r\n  out Height: Single): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipGetImageType(GpImage *image, ImageType *type); }\r\nfunction GdipGetImageType(Image: GpImage; out AType: TGPImageType): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipGetImageWidth(GpImage *image, UINT *width); }\r\nfunction GdipGetImageWidth(Image: GpImage; out Width: Cardinal): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipGetImageHeight(GpImage *image, UINT *height); }\r\nfunction GdipGetImageHeight(Image: GpImage; out Height: Cardinal): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipGetImageHorizontalResolution(GpImage *image, REAL *resolution); }\r\nfunction GdipGetImageHorizontalResolution(Image: GpImage; out Resolution: Single): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipGetImageVerticalResolution(GpImage *image, REAL *resolution); }\r\nfunction GdipGetImageVerticalResolution(Image: GpImage; out Resolution: Single): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipGetImageFlags(GpImage *image, UINT *flags); }\r\nfunction GdipGetImageFlags(Image: GpImage; out Flags: TGPImageFlags): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipGetImageRawFormat(GpImage *image, GUID *format); }\r\nfunction GdipGetImageRawFormat(Image: GpImage; out Format: TGUID): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipGetImagePixelFormat(GpImage *image, PixelFormat *format); }\r\nfunction GdipGetImagePixelFormat(Image: GpImage; out Format: TGPPixelFormat): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipGetImageThumbnail(GpImage *image, UINT thumbWidth, UINT thumbHeight, GpImage **thumbImage, GetThumbnailImageAbort callback, VOID * callbackData); }\r\nfunction GdipGetImageThumbnail(Image: GpImage; ThumbWidth: Cardinal;\r\n  ThumbHeight: Cardinal; out ThumbImage: GpImage;\r\n  Callback: TGPGetThumbnailImageAbort; CallbackData: Pointer): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipGetEncoderParameterListSize(GpImage *image, GDIPCONST CLSID* clsidEncoder, UINT* size); }\r\nfunction GdipGetEncoderParameterListSize(Image: GpImage;\r\n  const ClsidEncoder: PGUID; out Size: Cardinal): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipGetEncoderParameterList(GpImage *image, GDIPCONST CLSID* clsidEncoder, UINT size, EncoderParameters* buffer); }\r\nfunction GdipGetEncoderParameterList(Image: GpImage; const ClsidEncoder: PGUID;\r\n  Size: Cardinal; Buffer: PGPNativeEncoderParameters): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipImageGetFrameDimensionsCount(GpImage* image, UINT* count); }\r\nfunction GdipImageGetFrameDimensionsCount(Image: GpImage; out Count: Cardinal): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipImageGetFrameDimensionsList(GpImage* image, GUID* dimensionIDs, UINT count); }\r\nfunction GdipImageGetFrameDimensionsList(Image: GpImage; DimensionIDs: PGUID;\r\n  Count: Cardinal): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipImageGetFrameCount(GpImage *image, GDIPCONST GUID* dimensionID, UINT* count); }\r\nfunction GdipImageGetFrameCount(Image: GpImage; const DimensionID: TGUID;\r\n  out Count: Cardinal): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipImageSelectActiveFrame(GpImage *image, GDIPCONST GUID* dimensionID, UINT frameIndex); }\r\nfunction GdipImageSelectActiveFrame(Image: GpImage; const DimensionID: TGUID;\r\n  FrameIndex: Cardinal): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipImageRotateFlip(GpImage *image, RotateFlipType rfType); }\r\nfunction GdipImageRotateFlip(Image: GpImage; RfType: TGPRotateFlipType): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipGetImagePalette(GpImage *image, ColorPalette *palette, INT size); }\r\nfunction GdipGetImagePalette(Image: GpImage; Palette: PGPNativeColorPalette;\r\n  Size: Integer): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipSetImagePalette(GpImage *image, GDIPCONST ColorPalette *palette); }\r\nfunction GdipSetImagePalette(Image: GpImage; const Palette: PGPNativeColorPalette): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipGetImagePaletteSize(GpImage *image, INT *size); }\r\nfunction GdipGetImagePaletteSize(Image: GpImage; out Size: Integer): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipGetPropertyCount(GpImage *image, UINT* numOfProperty); }\r\nfunction GdipGetPropertyCount(Image: GpImage; out NumOfProperty: Cardinal): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipGetPropertyIdList(GpImage *image, UINT numOfProperty, PROPID* list); }\r\nfunction GdipGetPropertyIdList(Image: GpImage; NumOfProperty: Cardinal;\r\n  List: PPropID): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipGetPropertyItemSize(GpImage *image, PROPID propId, UINT* size); }\r\nfunction GdipGetPropertyItemSize(Image: GpImage; PropId: TPropID;\r\n  out Size: Cardinal): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipGetPropertyItem(GpImage *image, PROPID propId,UINT propSize, PropertyItem* buffer); }\r\nfunction GdipGetPropertyItem(Image: GpImage; PropId: TPropID;\r\n  PropSize: Cardinal; Buffer: PGPNativePropertyItem): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipGetPropertySize(GpImage *image, UINT* totalBufferSize, UINT* numProperties); }\r\nfunction GdipGetPropertySize(Image: GpImage; out TotalBufferSize: Cardinal;\r\n  out NumProperties: Cardinal): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipGetAllPropertyItems(GpImage *image, UINT totalBufferSize, UINT numProperties, PropertyItem* allItems); }\r\nfunction GdipGetAllPropertyItems(Image: GpImage; TotalBufferSize: Cardinal;\r\n  NumProperties: Cardinal; AllItems: PGPNativePropertyItem): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipRemovePropertyItem(GpImage *image, PROPID propId); }\r\nfunction GdipRemovePropertyItem(Image: GpImage; PropId: TPropID): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipSetPropertyItem(GpImage *image, GDIPCONST PropertyItem* item); }\r\nfunction GdipSetPropertyItem(Image: GpImage; const Item: PGPNativePropertyItem): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{$IF (GDIPVER >= $0110)}\r\n{ GdipFindFirstImageItem(GpImage *image, ImageItemData* item); }\r\nfunction GdipFindFirstImageItem(Image: GpImage; Item: PGPImageItemData): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipFindNextImageItem(GpImage *image, ImageItemData* item); }\r\nfunction GdipFindNextImageItem(Image: GpImage; Item: PGPImageItemData): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipGetImageItemData(GpImage *image, ImageItemData* item); }\r\nfunction GdipGetImageItemData(Image: GpImage; Item: PGPImageItemData): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n{$IFEND}\r\n\r\n{ GdipImageForceValidation(GpImage *image); }\r\nfunction GdipImageForceValidation(Image: GpImage): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n//----------------------------------------------------------------------------\r\n// Bitmap APIs\r\n//----------------------------------------------------------------------------\r\n\r\n{ GdipCreateBitmapFromStream(IStream* stream, GpBitmap **bitmap); }\r\nfunction GdipCreateBitmapFromStream(const Stream: IStream; out Bitmap: GpBitmap): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipCreateBitmapFromFile(GDIPCONST WCHAR* filename, GpBitmap **bitmap); }\r\nfunction GdipCreateBitmapFromFile(const Filename: PWideChar;\r\n  out Bitmap: GpBitmap): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipCreateBitmapFromStreamICM(IStream* stream, GpBitmap **bitmap); }\r\nfunction GdipCreateBitmapFromStreamICM(const Stream: IStream;\r\n  out Bitmap: GpBitmap): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipCreateBitmapFromFileICM(GDIPCONST WCHAR* filename, GpBitmap **bitmap); }\r\nfunction GdipCreateBitmapFromFileICM(const Filename: PWideChar;\r\n  out Bitmap: GpBitmap): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipCreateBitmapFromScan0(INT width, INT height, INT stride, PixelFormat format, BYTE* scan0, GpBitmap** bitmap); }\r\nfunction GdipCreateBitmapFromScan0(Width: Integer; Height: Integer;\r\n  Stride: Integer; Format: TGPPixelFormat; Scan0: PByte; out Bitmap: GpBitmap): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipCreateBitmapFromGraphics(INT width, INT height, GpGraphics* target, GpBitmap** bitmap); }\r\nfunction GdipCreateBitmapFromGraphics(Width: Integer; Height: Integer;\r\n  Target: GpGraphics; out Bitmap: GpBitmap): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipCreateBitmapFromDirectDrawSurface(IDirectDrawSurface7* surface, GpBitmap** bitmap); }\r\nfunction GdipCreateBitmapFromDirectDrawSurface(const Surface: IUnknown;\r\n  out Bitmap: GpBitmap): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipCreateBitmapFromGdiDib(GDIPCONST BITMAPINFO* gdiBitmapInfo, VOID* gdiBitmapData, GpBitmap** bitmap); }\r\nfunction GdipCreateBitmapFromGdiDib(const GdiBitmapInfo: PBitmapInfo;\r\n  GdiBitmapData: Pointer; out Bitmap: GpBitmap): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipCreateBitmapFromHBITMAP(HBITMAP hbm, HPALETTE hpal, GpBitmap** bitmap); }\r\nfunction GdipCreateBitmapFromHBITMAP(Hbm: HBitmap; Hpal: HPalette;\r\n  out Bitmap: GpBitmap): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipCreateHBITMAPFromBitmap(GpBitmap* bitmap, HBITMAP* hbmReturn, ARGB background); }\r\nfunction GdipCreateHBITMAPFromBitmap(Bitmap: GpBitmap; out HbmReturn: HBitmap;\r\n  Background: ARGB): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipCreateBitmapFromHICON(HICON hicon, GpBitmap** bitmap); }\r\nfunction GdipCreateBitmapFromHICON(Hicon: HIcon; out Bitmap: GpBitmap): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipCreateHICONFromBitmap(GpBitmap* bitmap, HICON* hbmReturn); }\r\nfunction GdipCreateHICONFromBitmap(Bitmap: GpBitmap; out HbmReturn: HIcon): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipCreateBitmapFromResource(HINSTANCE hInstance, GDIPCONST WCHAR* lpBitmapName, GpBitmap** bitmap); }\r\nfunction GdipCreateBitmapFromResource(HInstance: HInst;\r\n  const LpBitmapName: PWideChar; out Bitmap: GpBitmap): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipCloneBitmapArea(REAL x, REAL y, REAL width, REAL height, PixelFormat format, GpBitmap *srcBitmap, GpBitmap **dstBitmap); }\r\nfunction GdipCloneBitmapArea(X: Single; Y: Single; Width: Single;\r\n  Height: Single; Format: TGPPixelFormat; SrcBitmap: GpBitmap;\r\n  out DstBitmap: GpBitmap): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipCloneBitmapAreaI(INT x, INT y, INT width, INT height, PixelFormat format, GpBitmap *srcBitmap, GpBitmap **dstBitmap); }\r\nfunction GdipCloneBitmapAreaI(X: Integer; Y: Integer; Width: Integer;\r\n  Height: Integer; Format: TGPPixelFormat; SrcBitmap: GpBitmap;\r\n  out DstBitmap: GpBitmap): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipBitmapLockBits(GpBitmap* bitmap, GDIPCONST GpRect* rect, UINT flags, PixelFormat format, BitmapData* lockedBitmapData); }\r\nfunction GdipBitmapLockBits(Bitmap: GpBitmap; const Rect: PGPRect;\r\n  Flags: TGPImageLockMode; Format: TGPPixelFormat; out LockedBitmapData: TGPBitmapData): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipBitmapUnlockBits(GpBitmap* bitmap, BitmapData* lockedBitmapData); }\r\nfunction GdipBitmapUnlockBits(Bitmap: GpBitmap; const LockedBitmapData: TGPBitmapData): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipBitmapGetPixel(GpBitmap* bitmap, INT x, INT y, ARGB *color); }\r\nfunction GdipBitmapGetPixel(Bitmap: GpBitmap; X: Integer; Y: Integer;\r\n  out Color: ARGB): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipBitmapSetPixel(GpBitmap* bitmap, INT x, INT y, ARGB color); }\r\nfunction GdipBitmapSetPixel(Bitmap: GpBitmap; X: Integer; Y: Integer;\r\n  Color: ARGB): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{$IF (GDIPVER >= $0110)}\r\n{ GdipImageSetAbort( GpImage *pImage, GdiplusAbort *pIAbort ); }\r\nfunction GdipImageSetAbort(PImage: GpImage; PIAbort: PGdiplusAbort): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipGraphicsSetAbort( GpGraphics *pGraphics, GdiplusAbort *pIAbort ); }\r\nfunction GdipGraphicsSetAbort(PGraphics: GpGraphics; PIAbort: PGdiplusAbort): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipBitmapConvertFormat( IN GpBitmap *pInputBitmap, PixelFormat format, DitherType dithertype, PaletteType palettetype, ColorPalette *palette, REAL alphaThresholdPercent ); }\r\nfunction GdipBitmapConvertFormat(const InputBitmap: GpBitmap;\r\n  Format: TGPPixelFormat; Dithertype: TGPDitherType; Palettetype: TGPPaletteType;\r\n  Palette: PGPNativeColorPalette; AlphaThresholdPercent: Single): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipInitializePalette( OUT ColorPalette *palette, PaletteType palettetype, INT optimalColors, BOOL useTransparentColor, GpBitmap *bitmap ); }\r\nfunction GdipInitializePalette(const Palette: PGPNativeColorPalette;\r\n  Palettetype: TGPPaletteType; OptimalColors: Integer; UseTransparentColor: Bool;\r\n  Bitmap: GpBitmap): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipBitmapApplyEffect( GpBitmap* bitmap, CGpEffect *effect, RECT *roi, BOOL useAuxData, VOID **auxData, INT *auxDataSize ); }\r\nfunction GdipBitmapApplyEffect(Bitmap: GpBitmap; Effect: CGpEffect; Roi: Windows.PRect;\r\n  UseAuxData: Bool; out AuxData: Pointer; out AuxDataSize: Integer): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipBitmapCreateApplyEffect( GpBitmap **inputBitmaps, INT numInputs, CGpEffect *effect, RECT *roi, RECT *outputRect, GpBitmap **outputBitmap, BOOL useAuxData, VOID **auxData, INT *auxDataSize ); }\r\nfunction GdipBitmapCreateApplyEffect(const InputBitmaps: PGpBitmap;\r\n  NumInputs: Integer; Effect: CGpEffect; Roi: Windows.PRect; OutputRect: Windows.PRect;\r\n  out OutputBitmap: GpBitmap; UseAuxData: Bool; out AuxData: Pointer;\r\n  out AuxDataSize: Integer): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipBitmapGetHistogram( GpBitmap* bitmap, IN HistogramFormat format, IN UINT NumberOfEntries, __out_bcount(sizeof(UINT)*256) UINT *channel0, __out_bcount(sizeof(UINT)*256) UINT *channel1, __out_bcount(sizeof(UINT)*256) UINT *channel2, __out_bcount(sizeof(UINT)*256) UINT *channel3 ); }\r\nfunction GdipBitmapGetHistogram(Bitmap: GpBitmap;\r\n  const Format: TGPHistogramFormat; const NumberOfEntries: Cardinal;\r\n  Channel0: PCardinal; Channel1: PCardinal; Channel2: PCardinal;\r\n  Channel3: PCardinal): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipBitmapGetHistogramSize( IN HistogramFormat format, OUT UINT *NumberOfEntries ); }\r\nfunction GdipBitmapGetHistogramSize(const Format: TGPHistogramFormat;\r\n  out NumberOfEntries: Cardinal): TGPStatus; stdcall; external GdiPlusDll;\r\n{$IFEND}\r\n\r\n{ GdipBitmapSetResolution(GpBitmap* bitmap, REAL xdpi, REAL ydpi); }\r\nfunction GdipBitmapSetResolution(Bitmap: GpBitmap; Xdpi: Single; Ydpi: Single): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n//----------------------------------------------------------------------------\r\n// ImageAttributes APIs\r\n//----------------------------------------------------------------------------\r\n\r\n{ GdipCreateImageAttributes(GpImageAttributes **imageattr); }\r\nfunction GdipCreateImageAttributes(out Imageattr: GpImageAttributes): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipCloneImageAttributes(GDIPCONST GpImageAttributes *imageattr, GpImageAttributes **cloneImageattr); }\r\nfunction GdipCloneImageAttributes(const Imageattr: GpImageAttributes;\r\n  out CloneImageattr: GpImageAttributes): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipDisposeImageAttributes(GpImageAttributes *imageattr); }\r\nfunction GdipDisposeImageAttributes(Imageattr: GpImageAttributes): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipSetImageAttributesToIdentity(GpImageAttributes *imageattr, ColorAdjustType type); }\r\nfunction GdipSetImageAttributesToIdentity(Imageattr: GpImageAttributes;\r\n  AType: TGPColorAdjustType): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipResetImageAttributes(GpImageAttributes *imageattr, ColorAdjustType type); }\r\nfunction GdipResetImageAttributes(Imageattr: GpImageAttributes;\r\n  AType: TGPColorAdjustType): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipSetImageAttributesColorMatrix(GpImageAttributes *imageattr, ColorAdjustType type, BOOL enableFlag, GDIPCONST ColorMatrix* colorMatrix, GDIPCONST ColorMatrix* grayMatrix, ColorMatrixFlags flags); }\r\nfunction GdipSetImageAttributesColorMatrix(Imageattr: GpImageAttributes;\r\n  AType: TGPColorAdjustType; EnableFlag: Bool; const ColorMatrix: PGPColorMatrix;\r\n  const GrayMatrix: PGPColorMatrix; Flags: TGPColorMatrixFlags): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipSetImageAttributesThreshold(GpImageAttributes *imageattr, ColorAdjustType type, BOOL enableFlag, REAL threshold); }\r\nfunction GdipSetImageAttributesThreshold(Imageattr: GpImageAttributes;\r\n  AType: TGPColorAdjustType; EnableFlag: Bool; Threshold: Single): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipSetImageAttributesGamma(GpImageAttributes *imageattr, ColorAdjustType type, BOOL enableFlag, REAL gamma); }\r\nfunction GdipSetImageAttributesGamma(Imageattr: GpImageAttributes;\r\n  AType: TGPColorAdjustType; EnableFlag: Bool; Gamma: Single): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipSetImageAttributesNoOp(GpImageAttributes *imageattr, ColorAdjustType type, BOOL enableFlag); }\r\nfunction GdipSetImageAttributesNoOp(Imageattr: GpImageAttributes;\r\n  AType: TGPColorAdjustType; EnableFlag: Bool): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipSetImageAttributesColorKeys(GpImageAttributes *imageattr, ColorAdjustType type, BOOL enableFlag, ARGB colorLow, ARGB colorHigh); }\r\nfunction GdipSetImageAttributesColorKeys(Imageattr: GpImageAttributes;\r\n  AType: TGPColorAdjustType; EnableFlag: Bool; ColorLow: ARGB; ColorHigh: ARGB): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipSetImageAttributesOutputChannel(GpImageAttributes *imageattr, ColorAdjustType type, BOOL enableFlag, ColorChannelFlags channelFlags); }\r\nfunction GdipSetImageAttributesOutputChannel(Imageattr: GpImageAttributes;\r\n  AType: TGPColorAdjustType; EnableFlag: Bool; ChannelFlags: TGPColorChannelFlags): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipSetImageAttributesOutputChannelColorProfile(GpImageAttributes *imageattr, ColorAdjustType type, BOOL enableFlag, GDIPCONST WCHAR *colorProfileFilename); }\r\nfunction GdipSetImageAttributesOutputChannelColorProfile(\r\n  Imageattr: GpImageAttributes; AType: TGPColorAdjustType; EnableFlag: Bool;\r\n  const ColorProfileFilename: PWideChar): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipSetImageAttributesRemapTable(GpImageAttributes *imageattr, ColorAdjustType type, BOOL enableFlag, UINT mapSize, GDIPCONST ColorMap *map); }\r\nfunction GdipSetImageAttributesRemapTable(Imageattr: GpImageAttributes;\r\n  AType: TGPColorAdjustType; EnableFlag: Bool; MapSize: Cardinal;\r\n  const Map: PGPColorMap): TGPStatus; stdcall; external GdiPlusDll;\r\n{ GdipSetImageAttributesWrapMode( GpImageAttributes *imageAttr, WrapMode wrap, ARGB argb, BOOL clamp ); }\r\nfunction GdipSetImageAttributesWrapMode(ImageAttr: GpImageAttributes;\r\n  Wrap: TGPWrapMode; Argb: ARGB; Clamp: Bool): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipSetImageAttributesICMMode( GpImageAttributes *imageAttr, BOOL on ); }\r\nfunction GdipSetImageAttributesICMMode(ImageAttr: GpImageAttributes; Enable: Bool): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipGetImageAttributesAdjustedPalette( GpImageAttributes *imageAttr, ColorPalette * colorPalette, ColorAdjustType colorAdjustType ); }\r\nfunction GdipGetImageAttributesAdjustedPalette(ImageAttr: GpImageAttributes;\r\n  ColorPalette: PGPNativeColorPalette; ColorAdjustType: TGPColorAdjustType): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n//----------------------------------------------------------------------------\r\n// Graphics APIs\r\n//----------------------------------------------------------------------------\r\n\r\n{ GdipFlush(GpGraphics *graphics, GpFlushIntention intention); }\r\nfunction GdipFlush(Graphics: GpGraphics; Intention: TGPFlushIntention): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipCreateFromHDC(HDC hdc, GpGraphics **graphics); }\r\nfunction GdipCreateFromHDC(Hdc: HDC; out Graphics: GpGraphics): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipCreateFromHDC2(HDC hdc, HANDLE hDevice, GpGraphics **graphics); }\r\nfunction GdipCreateFromHDC2(Hdc: HDC; HDevice: THandle;\r\n  out Graphics: GpGraphics): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipCreateFromHWND(HWND hwnd, GpGraphics **graphics); }\r\nfunction GdipCreateFromHWND(Hwnd: HWnd; out Graphics: GpGraphics): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipCreateFromHWNDICM(HWND hwnd, GpGraphics **graphics); }\r\nfunction GdipCreateFromHWNDICM(Hwnd: HWnd; out Graphics: GpGraphics): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipDeleteGraphics(GpGraphics *graphics); }\r\nfunction GdipDeleteGraphics(Graphics: GpGraphics): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipGetDC(GpGraphics* graphics, HDC * hdc); }\r\nfunction GdipGetDC(Graphics: GpGraphics; out Hdc: HDC): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipReleaseDC(GpGraphics* graphics, HDC hdc); }\r\nfunction GdipReleaseDC(Graphics: GpGraphics; Hdc: HDC): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipSetCompositingMode(GpGraphics *graphics, CompositingMode compositingMode); }\r\nfunction GdipSetCompositingMode(Graphics: GpGraphics;\r\n  CompositingMode: TGPCompositingMode): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipGetCompositingMode(GpGraphics *graphics, CompositingMode *compositingMode); }\r\nfunction GdipGetCompositingMode(Graphics: GpGraphics;\r\n  out CompositingMode: TGPCompositingMode): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipSetRenderingOrigin(GpGraphics *graphics, INT x, INT y); }\r\nfunction GdipSetRenderingOrigin(Graphics: GpGraphics; X: Integer; Y: Integer): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipGetRenderingOrigin(GpGraphics *graphics, INT *x, INT *y); }\r\nfunction GdipGetRenderingOrigin(Graphics: GpGraphics; out X: Integer; out Y: Integer): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipSetCompositingQuality(GpGraphics *graphics, CompositingQuality compositingQuality); }\r\nfunction GdipSetCompositingQuality(Graphics: GpGraphics;\r\n  CompositingQuality: TGPCompositingQuality): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipGetCompositingQuality(GpGraphics *graphics, CompositingQuality *compositingQuality); }\r\nfunction GdipGetCompositingQuality(Graphics: GpGraphics;\r\n  out CompositingQuality: TGPCompositingQuality): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipSetSmoothingMode(GpGraphics *graphics, SmoothingMode smoothingMode); }\r\nfunction GdipSetSmoothingMode(Graphics: GpGraphics;\r\n  SmoothingMode: TGPSmoothingMode): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipGetSmoothingMode(GpGraphics *graphics, SmoothingMode *smoothingMode); }\r\nfunction GdipGetSmoothingMode(Graphics: GpGraphics;\r\n  out SmoothingMode: TGPSmoothingMode): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipSetPixelOffsetMode(GpGraphics* graphics, PixelOffsetMode pixelOffsetMode); }\r\nfunction GdipSetPixelOffsetMode(Graphics: GpGraphics;\r\n  PixelOffsetMode: TGPPixelOffsetMode): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipGetPixelOffsetMode(GpGraphics *graphics, PixelOffsetMode *pixelOffsetMode); }\r\nfunction GdipGetPixelOffsetMode(Graphics: GpGraphics;\r\n  out PixelOffsetMode: TGPPixelOffsetMode): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipSetTextRenderingHint(GpGraphics *graphics, TextRenderingHint mode); }\r\nfunction GdipSetTextRenderingHint(Graphics: GpGraphics;\r\n  Mode: TGPTextRenderingHint): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipGetTextRenderingHint(GpGraphics *graphics, TextRenderingHint *mode); }\r\nfunction GdipGetTextRenderingHint(Graphics: GpGraphics;\r\n  out Mode: TGPTextRenderingHint): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipSetTextContrast(GpGraphics *graphics, UINT contrast); }\r\nfunction GdipSetTextContrast(Graphics: GpGraphics; Contrast: Integer): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipGetTextContrast(GpGraphics *graphics, UINT * contrast); }\r\nfunction GdipGetTextContrast(Graphics: GpGraphics; out Contrast: Integer): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipSetInterpolationMode(GpGraphics *graphics, InterpolationMode interpolationMode); }\r\nfunction GdipSetInterpolationMode(Graphics: GpGraphics;\r\n  InterpolationMode: TGPInterpolationMode): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipGetInterpolationMode(GpGraphics *graphics, InterpolationMode *interpolationMode); }\r\nfunction GdipGetInterpolationMode(Graphics: GpGraphics;\r\n  out InterpolationMode: TGPInterpolationMode): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipSetWorldTransform(GpGraphics *graphics, GpMatrix *matrix); }\r\nfunction GdipSetWorldTransform(Graphics: GpGraphics; Matrix: GpMatrix): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipResetWorldTransform(GpGraphics *graphics); }\r\nfunction GdipResetWorldTransform(Graphics: GpGraphics): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipMultiplyWorldTransform(GpGraphics *graphics, GDIPCONST GpMatrix *matrix, GpMatrixOrder order); }\r\nfunction GdipMultiplyWorldTransform(Graphics: GpGraphics;\r\n  const Matrix: GpMatrix; Order: TGPMatrixOrder): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipTranslateWorldTransform(GpGraphics *graphics, REAL dx, REAL dy, GpMatrixOrder order); }\r\nfunction GdipTranslateWorldTransform(Graphics: GpGraphics; Dx: Single;\r\n  Dy: Single; Order: TGPMatrixOrder): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipScaleWorldTransform(GpGraphics *graphics, REAL sx, REAL sy, GpMatrixOrder order); }\r\nfunction GdipScaleWorldTransform(Graphics: GpGraphics; Sx: Single; Sy: Single;\r\n  Order: TGPMatrixOrder): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipRotateWorldTransform(GpGraphics *graphics, REAL angle, GpMatrixOrder order); }\r\nfunction GdipRotateWorldTransform(Graphics: GpGraphics; Angle: Single;\r\n  Order: TGPMatrixOrder): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipGetWorldTransform(GpGraphics *graphics, GpMatrix *matrix); }\r\nfunction GdipGetWorldTransform(Graphics: GpGraphics; Matrix: GpMatrix): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipResetPageTransform(GpGraphics *graphics); }\r\nfunction GdipResetPageTransform(Graphics: GpGraphics): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipGetPageUnit(GpGraphics *graphics, GpUnit *unit); }\r\nfunction GdipGetPageUnit(Graphics: GpGraphics; out AUnit: TGPUnit): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipGetPageScale(GpGraphics *graphics, REAL *scale); }\r\nfunction GdipGetPageScale(Graphics: GpGraphics; out Scale: Single): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipSetPageUnit(GpGraphics *graphics, GpUnit unit); }\r\nfunction GdipSetPageUnit(Graphics: GpGraphics; AUnit: TGPUnit): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipSetPageScale(GpGraphics *graphics, REAL scale); }\r\nfunction GdipSetPageScale(Graphics: GpGraphics; Scale: Single): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipGetDpiX(GpGraphics *graphics, REAL* dpi); }\r\nfunction GdipGetDpiX(Graphics: GpGraphics; out Dpi: Single): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipGetDpiY(GpGraphics *graphics, REAL* dpi); }\r\nfunction GdipGetDpiY(Graphics: GpGraphics; out Dpi: Single): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipTransformPoints(GpGraphics *graphics, GpCoordinateSpace destSpace, GpCoordinateSpace srcSpace, GpPointF *points, INT count); }\r\nfunction GdipTransformPoints(Graphics: GpGraphics; DestSpace: TGPCoordinateSpace;\r\n  SrcSpace: TGPCoordinateSpace; Points: PGPPointF; Count: Integer): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipTransformPointsI(GpGraphics *graphics, GpCoordinateSpace destSpace, GpCoordinateSpace srcSpace, GpPoint *points, INT count); }\r\nfunction GdipTransformPointsI(Graphics: GpGraphics; DestSpace: TGPCoordinateSpace;\r\n  SrcSpace: TGPCoordinateSpace; Points: PGPPoint; Count: Integer): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipGetNearestColor(GpGraphics *graphics, ARGB* argb); }\r\nfunction GdipGetNearestColor(Graphics: GpGraphics; Argb: PARGB): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n// Creates the Win9x Halftone Palette (even on NT) with correct Desktop colors\r\nfunction GdipCreateHalftonePalette: HPalette; external GdiPlusDll;\r\n\r\n{ GdipDrawLine(GpGraphics *graphics, GpPen *pen, REAL x1, REAL y1, REAL x2, REAL y2); }\r\nfunction GdipDrawLine(Graphics: GpGraphics; Pen: GpPen; X1: Single; Y1: Single;\r\n  X2: Single; Y2: Single): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipDrawLineI(GpGraphics *graphics, GpPen *pen, INT x1, INT y1, INT x2, INT y2); }\r\nfunction GdipDrawLineI(Graphics: GpGraphics; Pen: GpPen; X1: Integer;\r\n  Y1: Integer; X2: Integer; Y2: Integer): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipDrawLines(GpGraphics *graphics, GpPen *pen, GDIPCONST GpPointF *points, INT count); }\r\nfunction GdipDrawLines(Graphics: GpGraphics; Pen: GpPen; const Points: PGPPointF;\r\n  Count: Integer): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipDrawLinesI(GpGraphics *graphics, GpPen *pen, GDIPCONST GpPoint *points, INT count); }\r\nfunction GdipDrawLinesI(Graphics: GpGraphics; Pen: GpPen; const Points: PGPPoint;\r\n  Count: Integer): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipDrawArc(GpGraphics *graphics, GpPen *pen, REAL x, REAL y, REAL width, REAL height, REAL startAngle, REAL sweepAngle); }\r\nfunction GdipDrawArc(Graphics: GpGraphics; Pen: GpPen; X: Single; Y: Single;\r\n  Width: Single; Height: Single; StartAngle: Single; SweepAngle: Single): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipDrawArcI(GpGraphics *graphics, GpPen *pen, INT x, INT y, INT width, INT height, REAL startAngle, REAL sweepAngle); }\r\nfunction GdipDrawArcI(Graphics: GpGraphics; Pen: GpPen; X: Integer; Y: Integer;\r\n  Width: Integer; Height: Integer; StartAngle: Single; SweepAngle: Single): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipDrawBezier(GpGraphics *graphics, GpPen *pen, REAL x1, REAL y1, REAL x2, REAL y2, REAL x3, REAL y3, REAL x4, REAL y4); }\r\nfunction GdipDrawBezier(Graphics: GpGraphics; Pen: GpPen; X1: Single;\r\n  Y1: Single; X2: Single; Y2: Single; X3: Single; Y3: Single; X4: Single;\r\n  Y4: Single): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipDrawBezierI(GpGraphics *graphics, GpPen *pen, INT x1, INT y1, INT x2, INT y2, INT x3, INT y3, INT x4, INT y4); }\r\nfunction GdipDrawBezierI(Graphics: GpGraphics; Pen: GpPen; X1: Integer;\r\n  Y1: Integer; X2: Integer; Y2: Integer; X3: Integer; Y3: Integer; X4: Integer;\r\n  Y4: Integer): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipDrawBeziers(GpGraphics *graphics, GpPen *pen, GDIPCONST GpPointF *points, INT count); }\r\nfunction GdipDrawBeziers(Graphics: GpGraphics; Pen: GpPen;\r\n  const Points: PGPPointF; Count: Integer): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipDrawBeziersI(GpGraphics *graphics, GpPen *pen, GDIPCONST GpPoint *points, INT count); }\r\nfunction GdipDrawBeziersI(Graphics: GpGraphics; Pen: GpPen;\r\n  const Points: PGPPoint; Count: Integer): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipDrawRectangle(GpGraphics *graphics, GpPen *pen, REAL x, REAL y, REAL width, REAL height); }\r\nfunction GdipDrawRectangle(Graphics: GpGraphics; Pen: GpPen; X: Single;\r\n  Y: Single; Width: Single; Height: Single): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipDrawRectangleI(GpGraphics *graphics, GpPen *pen, INT x, INT y, INT width, INT height); }\r\nfunction GdipDrawRectangleI(Graphics: GpGraphics; Pen: GpPen; X: Integer;\r\n  Y: Integer; Width: Integer; Height: Integer): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipDrawRectangles(GpGraphics *graphics, GpPen *pen, GDIPCONST GpRectF *rects, INT count); }\r\nfunction GdipDrawRectangles(Graphics: GpGraphics; Pen: GpPen;\r\n  const Rects: PGPRectF; Count: Integer): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipDrawRectanglesI(GpGraphics *graphics, GpPen *pen, GDIPCONST GpRect *rects, INT count); }\r\nfunction GdipDrawRectanglesI(Graphics: GpGraphics; Pen: GpPen;\r\n  const Rects: PGPRect; Count: Integer): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipDrawEllipse(GpGraphics *graphics, GpPen *pen, REAL x, REAL y, REAL width, REAL height); }\r\nfunction GdipDrawEllipse(Graphics: GpGraphics; Pen: GpPen; X: Single; Y: Single;\r\n  Width: Single; Height: Single): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipDrawEllipseI(GpGraphics *graphics, GpPen *pen, INT x, INT y, INT width, INT height); }\r\nfunction GdipDrawEllipseI(Graphics: GpGraphics; Pen: GpPen; X: Integer;\r\n  Y: Integer; Width: Integer; Height: Integer): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipDrawPie(GpGraphics *graphics, GpPen *pen, REAL x, REAL y, REAL width, REAL height, REAL startAngle, REAL sweepAngle); }\r\nfunction GdipDrawPie(Graphics: GpGraphics; Pen: GpPen; X: Single; Y: Single;\r\n  Width: Single; Height: Single; StartAngle: Single; SweepAngle: Single): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipDrawPieI(GpGraphics *graphics, GpPen *pen, INT x, INT y, INT width, INT height, REAL startAngle, REAL sweepAngle); }\r\nfunction GdipDrawPieI(Graphics: GpGraphics; Pen: GpPen; X: Integer; Y: Integer;\r\n  Width: Integer; Height: Integer; StartAngle: Single; SweepAngle: Single): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipDrawPolygon(GpGraphics *graphics, GpPen *pen, GDIPCONST GpPointF *points, INT count); }\r\nfunction GdipDrawPolygon(Graphics: GpGraphics; Pen: GpPen;\r\n  const Points: PGPPointF; Count: Integer): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipDrawPolygonI(GpGraphics *graphics, GpPen *pen, GDIPCONST GpPoint *points, INT count); }\r\nfunction GdipDrawPolygonI(Graphics: GpGraphics; Pen: GpPen;\r\n  const Points: PGPPoint; Count: Integer): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipDrawPath(GpGraphics *graphics, GpPen *pen, GpPath *path); }\r\nfunction GdipDrawPath(Graphics: GpGraphics; Pen: GpPen; Path: GpPath): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipDrawCurve(GpGraphics *graphics, GpPen *pen, GDIPCONST GpPointF *points, INT count); }\r\nfunction GdipDrawCurve(Graphics: GpGraphics; Pen: GpPen; const Points: PGPPointF;\r\n  Count: Integer): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipDrawCurveI(GpGraphics *graphics, GpPen *pen, GDIPCONST GpPoint *points, INT count); }\r\nfunction GdipDrawCurveI(Graphics: GpGraphics; Pen: GpPen; const Points: PGPPoint;\r\n  Count: Integer): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipDrawCurve2(GpGraphics *graphics, GpPen *pen, GDIPCONST GpPointF *points, INT count, REAL tension); }\r\nfunction GdipDrawCurve2(Graphics: GpGraphics; Pen: GpPen; const Points: PGPPointF;\r\n  Count: Integer; Tension: Single): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipDrawCurve2I(GpGraphics *graphics, GpPen *pen, GDIPCONST GpPoint *points, INT count, REAL tension); }\r\nfunction GdipDrawCurve2I(Graphics: GpGraphics; Pen: GpPen; const Points: PGPPoint;\r\n  Count: Integer; Tension: Single): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipDrawCurve3(GpGraphics *graphics, GpPen *pen, GDIPCONST GpPointF *points, INT count, INT offset, INT numberOfSegments, REAL tension); }\r\nfunction GdipDrawCurve3(Graphics: GpGraphics; Pen: GpPen; const Points: PGPPointF;\r\n  Count: Integer; Offset: Integer; NumberOfSegments: Integer; Tension: Single): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipDrawCurve3I(GpGraphics *graphics, GpPen *pen, GDIPCONST GpPoint *points, INT count, INT offset, INT numberOfSegments, REAL tension); }\r\nfunction GdipDrawCurve3I(Graphics: GpGraphics; Pen: GpPen; const Points: PGPPoint;\r\n  Count: Integer; Offset: Integer; NumberOfSegments: Integer; Tension: Single): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipDrawClosedCurve(GpGraphics *graphics, GpPen *pen, GDIPCONST GpPointF *points, INT count); }\r\nfunction GdipDrawClosedCurve(Graphics: GpGraphics; Pen: GpPen;\r\n  const Points: PGPPointF; Count: Integer): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipDrawClosedCurveI(GpGraphics *graphics, GpPen *pen, GDIPCONST GpPoint *points, INT count); }\r\nfunction GdipDrawClosedCurveI(Graphics: GpGraphics; Pen: GpPen;\r\n  const Points: PGPPoint; Count: Integer): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipDrawClosedCurve2(GpGraphics *graphics, GpPen *pen, GDIPCONST GpPointF *points, INT count, REAL tension); }\r\nfunction GdipDrawClosedCurve2(Graphics: GpGraphics; Pen: GpPen;\r\n  const Points: PGPPointF; Count: Integer; Tension: Single): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipDrawClosedCurve2I(GpGraphics *graphics, GpPen *pen, GDIPCONST GpPoint *points, INT count, REAL tension); }\r\nfunction GdipDrawClosedCurve2I(Graphics: GpGraphics; Pen: GpPen;\r\n  const Points: PGPPoint; Count: Integer; Tension: Single): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipGraphicsClear(GpGraphics *graphics, ARGB color); }\r\nfunction GdipGraphicsClear(Graphics: GpGraphics; Color: ARGB): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipFillRectangle(GpGraphics *graphics, GpBrush *brush, REAL x, REAL y, REAL width, REAL height); }\r\nfunction GdipFillRectangle(Graphics: GpGraphics; Brush: GpBrush; X: Single;\r\n  Y: Single; Width: Single; Height: Single): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipFillRectangleI(GpGraphics *graphics, GpBrush *brush, INT x, INT y, INT width, INT height); }\r\nfunction GdipFillRectangleI(Graphics: GpGraphics; Brush: GpBrush; X: Integer;\r\n  Y: Integer; Width: Integer; Height: Integer): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipFillRectangles(GpGraphics *graphics, GpBrush *brush, GDIPCONST GpRectF *rects, INT count); }\r\nfunction GdipFillRectangles(Graphics: GpGraphics; Brush: GpBrush;\r\n  const Rects: PGPRectF; Count: Integer): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipFillRectanglesI(GpGraphics *graphics, GpBrush *brush, GDIPCONST GpRect *rects, INT count); }\r\nfunction GdipFillRectanglesI(Graphics: GpGraphics; Brush: GpBrush;\r\n  const Rects: PGPRect; Count: Integer): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipFillPolygon(GpGraphics *graphics, GpBrush *brush, GDIPCONST GpPointF *points, INT count, GpFillMode fillMode); }\r\nfunction GdipFillPolygon(Graphics: GpGraphics; Brush: GpBrush;\r\n  const Points: PGPPointF; Count: Integer; FillMode: TGPFillMode): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipFillPolygonI(GpGraphics *graphics, GpBrush *brush, GDIPCONST GpPoint *points, INT count, GpFillMode fillMode); }\r\nfunction GdipFillPolygonI(Graphics: GpGraphics; Brush: GpBrush;\r\n  const Points: PGPPoint; Count: Integer; FillMode: TGPFillMode): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipFillPolygon2(GpGraphics *graphics, GpBrush *brush, GDIPCONST GpPointF *points, INT count); }\r\nfunction GdipFillPolygon2(Graphics: GpGraphics; Brush: GpBrush;\r\n  const Points: PGPPointF; Count: Integer): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipFillPolygon2I(GpGraphics *graphics, GpBrush *brush, GDIPCONST GpPoint *points, INT count); }\r\nfunction GdipFillPolygon2I(Graphics: GpGraphics; Brush: GpBrush;\r\n  const Points: PGPPoint; Count: Integer): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipFillEllipse(GpGraphics *graphics, GpBrush *brush, REAL x, REAL y, REAL width, REAL height); }\r\nfunction GdipFillEllipse(Graphics: GpGraphics; Brush: GpBrush; X: Single;\r\n  Y: Single; Width: Single; Height: Single): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipFillEllipseI(GpGraphics *graphics, GpBrush *brush, INT x, INT y, INT width, INT height); }\r\nfunction GdipFillEllipseI(Graphics: GpGraphics; Brush: GpBrush; X: Integer;\r\n  Y: Integer; Width: Integer; Height: Integer): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipFillPie(GpGraphics *graphics, GpBrush *brush, REAL x, REAL y, REAL width, REAL height, REAL startAngle, REAL sweepAngle); }\r\nfunction GdipFillPie(Graphics: GpGraphics; Brush: GpBrush; X: Single; Y: Single;\r\n  Width: Single; Height: Single; StartAngle: Single; SweepAngle: Single): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipFillPieI(GpGraphics *graphics, GpBrush *brush, INT x, INT y, INT width, INT height, REAL startAngle, REAL sweepAngle); }\r\nfunction GdipFillPieI(Graphics: GpGraphics; Brush: GpBrush; X: Integer;\r\n  Y: Integer; Width: Integer; Height: Integer; StartAngle: Single;\r\n  SweepAngle: Single): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipFillPath(GpGraphics *graphics, GpBrush *brush, GpPath *path); }\r\nfunction GdipFillPath(Graphics: GpGraphics; Brush: GpBrush; Path: GpPath): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipFillClosedCurve(GpGraphics *graphics, GpBrush *brush, GDIPCONST GpPointF *points, INT count); }\r\nfunction GdipFillClosedCurve(Graphics: GpGraphics; Brush: GpBrush;\r\n  const Points: PGPPointF; Count: Integer): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipFillClosedCurveI(GpGraphics *graphics, GpBrush *brush, GDIPCONST GpPoint *points, INT count); }\r\nfunction GdipFillClosedCurveI(Graphics: GpGraphics; Brush: GpBrush;\r\n  const Points: PGPPoint; Count: Integer): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipFillClosedCurve2(GpGraphics *graphics, GpBrush *brush, GDIPCONST GpPointF *points, INT count, REAL tension, GpFillMode fillMode); }\r\nfunction GdipFillClosedCurve2(Graphics: GpGraphics; Brush: GpBrush;\r\n  const Points: PGPPointF; Count: Integer; Tension: Single; FillMode: TGPFillMode): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipFillClosedCurve2I(GpGraphics *graphics, GpBrush *brush, GDIPCONST GpPoint *points, INT count, REAL tension, GpFillMode fillMode); }\r\nfunction GdipFillClosedCurve2I(Graphics: GpGraphics; Brush: GpBrush;\r\n  const Points: PGPPoint; Count: Integer; Tension: Single; FillMode: TGPFillMode): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipFillRegion(GpGraphics *graphics, GpBrush *brush, GpRegion *region); }\r\nfunction GdipFillRegion(Graphics: GpGraphics; Brush: GpBrush; Region: GpRegion): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{$IF (GDIPVER >= $0110)}\r\n{ GdipDrawImageFX( GpGraphics *graphics, GpImage *image, GpRectF *source, GpMatrix *xForm, CGpEffect *effect, GpImageAttributes *imageAttributes, GpUnit srcUnit ); }\r\nfunction GdipDrawImageFX(Graphics: GpGraphics; Image: GpImage; Source: PGPRectF;\r\n  XForm: GpMatrix; Effect: CGpEffect; ImageAttributes: GpImageAttributes;\r\n  SrcUnit: TGPUnit): TGPStatus; stdcall; external GdiPlusDll;\r\n{$IFEND}\r\n\r\n{ GdipDrawImage(GpGraphics *graphics, GpImage *image, REAL x, REAL y); }\r\nfunction GdipDrawImage(Graphics: GpGraphics; Image: GpImage; X: Single;\r\n  Y: Single): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipDrawImageI(GpGraphics *graphics, GpImage *image, INT x, INT y); }\r\nfunction GdipDrawImageI(Graphics: GpGraphics; Image: GpImage; X: Integer;\r\n  Y: Integer): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipDrawImageRect(GpGraphics *graphics, GpImage *image, REAL x, REAL y, REAL width, REAL height); }\r\nfunction GdipDrawImageRect(Graphics: GpGraphics; Image: GpImage; X: Single;\r\n  Y: Single; Width: Single; Height: Single): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipDrawImageRectI(GpGraphics *graphics, GpImage *image, INT x, INT y, INT width, INT height); }\r\nfunction GdipDrawImageRectI(Graphics: GpGraphics; Image: GpImage; X: Integer;\r\n  Y: Integer; Width: Integer; Height: Integer): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipDrawImagePoints(GpGraphics *graphics, GpImage *image, GDIPCONST GpPointF *dstpoints, INT count); }\r\nfunction GdipDrawImagePoints(Graphics: GpGraphics; Image: GpImage;\r\n  const Dstpoints: PGPPointF; Count: Integer): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipDrawImagePointsI(GpGraphics *graphics, GpImage *image, GDIPCONST GpPoint *dstpoints, INT count); }\r\nfunction GdipDrawImagePointsI(Graphics: GpGraphics; Image: GpImage;\r\n  const Dstpoints: PGPPoint; Count: Integer): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipDrawImagePointRect(GpGraphics *graphics, GpImage *image, REAL x, REAL y, REAL srcx, REAL srcy, REAL srcwidth, REAL srcheight, GpUnit srcUnit); }\r\nfunction GdipDrawImagePointRect(Graphics: GpGraphics; Image: GpImage; X: Single;\r\n  Y: Single; Srcx: Single; Srcy: Single; Srcwidth: Single; Srcheight: Single;\r\n  SrcUnit: TGPUnit): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipDrawImagePointRectI(GpGraphics *graphics, GpImage *image, INT x, INT y, INT srcx, INT srcy, INT srcwidth, INT srcheight, GpUnit srcUnit); }\r\nfunction GdipDrawImagePointRectI(Graphics: GpGraphics; Image: GpImage;\r\n  X: Integer; Y: Integer; Srcx: Integer; Srcy: Integer; Srcwidth: Integer;\r\n  Srcheight: Integer; SrcUnit: TGPUnit): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipDrawImageRectRect(GpGraphics *graphics, GpImage *image, REAL dstx, REAL dsty, REAL dstwidth, REAL dstheight, REAL srcx, REAL srcy, REAL srcwidth, REAL srcheight, GpUnit srcUnit, GDIPCONST GpImageAttributes* imageAttributes, DrawImageAbort callback, VOID * callbackData); }\r\nfunction GdipDrawImageRectRect(Graphics: GpGraphics; Image: GpImage;\r\n  Dstx: Single; Dsty: Single; Dstwidth: Single; Dstheight: Single; Srcx: Single;\r\n  Srcy: Single; Srcwidth: Single; Srcheight: Single; SrcUnit: TGPUnit;\r\n  const ImageAttributes: GpImageAttributes; Callback: TGPDrawImageAbort;\r\n  CallbackData: Pointer): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipDrawImageRectRectI(GpGraphics *graphics, GpImage *image, INT dstx, INT dsty, INT dstwidth, INT dstheight, INT srcx, INT srcy, INT srcwidth, INT srcheight, GpUnit srcUnit, GDIPCONST GpImageAttributes* imageAttributes, DrawImageAbort callback, VOID * callbackData); }\r\nfunction GdipDrawImageRectRectI(Graphics: GpGraphics; Image: GpImage;\r\n  Dstx: Integer; Dsty: Integer; Dstwidth: Integer; Dstheight: Integer;\r\n  Srcx: Integer; Srcy: Integer; Srcwidth: Integer; Srcheight: Integer;\r\n  SrcUnit: TGPUnit; const ImageAttributes: GpImageAttributes;\r\n  Callback: TGPDrawImageAbort; CallbackData: Pointer): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipDrawImagePointsRect(GpGraphics *graphics, GpImage *image, GDIPCONST GpPointF *points, INT count, REAL srcx, REAL srcy, REAL srcwidth, REAL srcheight, GpUnit srcUnit, GDIPCONST GpImageAttributes* imageAttributes, DrawImageAbort callback, VOID * callbackData); }\r\nfunction GdipDrawImagePointsRect(Graphics: GpGraphics; Image: GpImage;\r\n  const Points: PGPPointF; Count: Integer; Srcx: Single; Srcy: Single;\r\n  Srcwidth: Single; Srcheight: Single; SrcUnit: TGPUnit;\r\n  const ImageAttributes: GpImageAttributes; Callback: TGPDrawImageAbort;\r\n  CallbackData: Pointer): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipDrawImagePointsRectI(GpGraphics *graphics, GpImage *image, GDIPCONST GpPoint *points, INT count, INT srcx, INT srcy, INT srcwidth, INT srcheight, GpUnit srcUnit, GDIPCONST GpImageAttributes* imageAttributes, DrawImageAbort callback, VOID * callbackData); }\r\nfunction GdipDrawImagePointsRectI(Graphics: GpGraphics; Image: GpImage;\r\n  const Points: PGPPoint; Count: Integer; Srcx: Integer; Srcy: Integer;\r\n  Srcwidth: Integer; Srcheight: Integer; SrcUnit: TGPUnit;\r\n  const ImageAttributes: GpImageAttributes; Callback: TGPDrawImageAbort;\r\n  CallbackData: Pointer): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipEnumerateMetafileDestPoint( GpGraphics * graphics, GDIPCONST GpMetafile * metafile, GDIPCONST PointF & destPoint, EnumerateMetafileProc callback, VOID * callbackData, GDIPCONST GpImageAttributes * imageAttributes ); }\r\nfunction GdipEnumerateMetafileDestPoint(Graphics: GpGraphics;\r\n  const Metafile: GpMetafile; const DestPoint: PGPPointF;\r\n  Callback: TGPEnumerateMetafileProc; CallbackData: Pointer;\r\n  const ImageAttributes: GpImageAttributes): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipEnumerateMetafileDestPointI( GpGraphics * graphics, GDIPCONST GpMetafile * metafile, GDIPCONST Point & destPoint, EnumerateMetafileProc callback, VOID * callbackData, GDIPCONST GpImageAttributes * imageAttributes ); }\r\nfunction GdipEnumerateMetafileDestPointI(Graphics: GpGraphics;\r\n  const Metafile: GpMetafile; const DestPoint: PGPPoint;\r\n  Callback: TGPEnumerateMetafileProc; CallbackData: Pointer;\r\n  const ImageAttributes: GpImageAttributes): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipEnumerateMetafileDestRect( GpGraphics * graphics, GDIPCONST GpMetafile * metafile, GDIPCONST RectF & destRect, EnumerateMetafileProc callback, VOID * callbackData, GDIPCONST GpImageAttributes * imageAttributes ); }\r\nfunction GdipEnumerateMetafileDestRect(Graphics: GpGraphics;\r\n  const Metafile: GpMetafile; const DestRect: PGPRectF;\r\n  Callback: TGPEnumerateMetafileProc; CallbackData: Pointer;\r\n  const ImageAttributes: GpImageAttributes): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipEnumerateMetafileDestRectI( GpGraphics * graphics, GDIPCONST GpMetafile * metafile, GDIPCONST Rect & destRect, EnumerateMetafileProc callback, VOID * callbackData, GDIPCONST GpImageAttributes * imageAttributes ); }\r\nfunction GdipEnumerateMetafileDestRectI(Graphics: GpGraphics;\r\n  const Metafile: GpMetafile; const DestRect: PGPRect;\r\n  Callback: TGPEnumerateMetafileProc; CallbackData: Pointer;\r\n  const ImageAttributes: GpImageAttributes): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipEnumerateMetafileDestPoints( GpGraphics * graphics, GDIPCONST GpMetafile * metafile, GDIPCONST PointF * destPoints, INT count, EnumerateMetafileProc callback, VOID * callbackData, GDIPCONST GpImageAttributes * imageAttributes ); }\r\nfunction GdipEnumerateMetafileDestPoints(Graphics: GpGraphics;\r\n  const Metafile: GpMetafile; const DestPoints: PGPPointF; Count: Integer;\r\n  Callback: TGPEnumerateMetafileProc; CallbackData: Pointer;\r\n  const ImageAttributes: GpImageAttributes): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipEnumerateMetafileDestPointsI( GpGraphics * graphics, GDIPCONST GpMetafile * metafile, GDIPCONST Point * destPoints, INT count, EnumerateMetafileProc callback, VOID * callbackData, GDIPCONST GpImageAttributes * imageAttributes ); }\r\nfunction GdipEnumerateMetafileDestPointsI(Graphics: GpGraphics;\r\n  const Metafile: GpMetafile; const DestPoints: PGPPoint; Count: Integer;\r\n  Callback: TGPEnumerateMetafileProc; CallbackData: Pointer;\r\n  const ImageAttributes: GpImageAttributes): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipEnumerateMetafileSrcRectDestPoint( GpGraphics * graphics, GDIPCONST GpMetafile * metafile, GDIPCONST PointF & destPoint, GDIPCONST RectF & srcRect, Unit srcUnit, EnumerateMetafileProc callback, VOID * callbackData, GDIPCONST GpImageAttributes * imageAttributes ); }\r\nfunction GdipEnumerateMetafileSrcRectDestPoint(Graphics: GpGraphics;\r\n  const Metafile: GpMetafile; const DestPoint: PGPPointF; const SrcRect: PGPRectF;\r\n  SrcUnit: TGPUnit; Callback: TGPEnumerateMetafileProc; CallbackData: Pointer;\r\n  const ImageAttributes: GpImageAttributes): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipEnumerateMetafileSrcRectDestPointI( GpGraphics * graphics, GDIPCONST GpMetafile * metafile, GDIPCONST Point & destPoint, GDIPCONST Rect & srcRect, Unit srcUnit, EnumerateMetafileProc callback, VOID * callbackData, GDIPCONST GpImageAttributes * imageAttributes ); }\r\nfunction GdipEnumerateMetafileSrcRectDestPointI(Graphics: GpGraphics;\r\n  const Metafile: GpMetafile; const DestPoint: PGPPoint; const SrcRect: PGPRect;\r\n  SrcUnit: TGPUnit; Callback: TGPEnumerateMetafileProc; CallbackData: Pointer;\r\n  const ImageAttributes: GpImageAttributes): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipEnumerateMetafileSrcRectDestRect( GpGraphics * graphics, GDIPCONST GpMetafile * metafile, GDIPCONST RectF & destRect, GDIPCONST RectF & srcRect, Unit srcUnit, EnumerateMetafileProc callback, VOID * callbackData, GDIPCONST GpImageAttributes * imageAttributes ); }\r\nfunction GdipEnumerateMetafileSrcRectDestRect(Graphics: GpGraphics;\r\n  const Metafile: GpMetafile; const DestRect: PGPRectF; const SrcRect: PGPRectF;\r\n  SrcUnit: TGPUnit; Callback: TGPEnumerateMetafileProc; CallbackData: Pointer;\r\n  const ImageAttributes: GpImageAttributes): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipEnumerateMetafileSrcRectDestRectI( GpGraphics * graphics, GDIPCONST GpMetafile * metafile, GDIPCONST Rect & destRect, GDIPCONST Rect & srcRect, Unit srcUnit, EnumerateMetafileProc callback, VOID * callbackData, GDIPCONST GpImageAttributes * imageAttributes ); }\r\nfunction GdipEnumerateMetafileSrcRectDestRectI(Graphics: GpGraphics;\r\n  const Metafile: GpMetafile; const DestRect: PGPRect; const SrcRect: PGPRect;\r\n  SrcUnit: TGPUnit; Callback: TGPEnumerateMetafileProc; CallbackData: Pointer;\r\n  const ImageAttributes: GpImageAttributes): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipEnumerateMetafileSrcRectDestPoints( GpGraphics * graphics, GDIPCONST GpMetafile * metafile, GDIPCONST PointF * destPoints, INT count, GDIPCONST RectF & srcRect, Unit srcUnit, EnumerateMetafileProc callback, VOID * callbackData, GDIPCONST GpImageAttributes * imageAttributes ); }\r\nfunction GdipEnumerateMetafileSrcRectDestPoints(Graphics: GpGraphics;\r\n  const Metafile: GpMetafile; const DestPoints: PGPPointF; Count: Integer;\r\n  const SrcRect: PGPRectF; SrcUnit: TGPUnit; Callback: TGPEnumerateMetafileProc;\r\n  CallbackData: Pointer; const ImageAttributes: GpImageAttributes): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipEnumerateMetafileSrcRectDestPointsI( GpGraphics * graphics, GDIPCONST GpMetafile * metafile, GDIPCONST Point * destPoints, INT count, GDIPCONST Rect & srcRect, Unit srcUnit, EnumerateMetafileProc callback, VOID * callbackData, GDIPCONST GpImageAttributes * imageAttributes ); }\r\nfunction GdipEnumerateMetafileSrcRectDestPointsI(Graphics: GpGraphics;\r\n  const Metafile: GpMetafile; const DestPoints: PGPPoint; Count: Integer;\r\n  const SrcRect: PGPRect; SrcUnit: TGPUnit; Callback: TGPEnumerateMetafileProc;\r\n  CallbackData: Pointer; const ImageAttributes: GpImageAttributes): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipPlayMetafileRecord( GDIPCONST GpMetafile * metafile, EmfPlusRecordType recordType, UINT flags, UINT dataSize, GDIPCONST BYTE * data ); }\r\nfunction GdipPlayMetafileRecord(const Metafile: GpMetafile;\r\n  RecordType: TEmfPlusRecordType; Flags: Cardinal; DataSize: Cardinal;\r\n  const Data: PByte): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipSetClipGraphics(GpGraphics *graphics, GpGraphics *srcgraphics, CombineMode combineMode); }\r\nfunction GdipSetClipGraphics(Graphics: GpGraphics; Srcgraphics: GpGraphics;\r\n  CombineMode: TGPCombineMode): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipSetClipRect(GpGraphics *graphics, REAL x, REAL y, REAL width, REAL height, CombineMode combineMode); }\r\nfunction GdipSetClipRect(Graphics: GpGraphics; X: Single; Y: Single;\r\n  Width: Single; Height: Single; CombineMode: TGPCombineMode): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipSetClipRectI(GpGraphics *graphics, INT x, INT y, INT width, INT height, CombineMode combineMode); }\r\nfunction GdipSetClipRectI(Graphics: GpGraphics; X: Integer; Y: Integer;\r\n  Width: Integer; Height: Integer; CombineMode: TGPCombineMode): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipSetClipPath(GpGraphics *graphics, GpPath *path, CombineMode combineMode); }\r\nfunction GdipSetClipPath(Graphics: GpGraphics; Path: GpPath;\r\n  CombineMode: TGPCombineMode): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipSetClipRegion(GpGraphics *graphics, GpRegion *region, CombineMode combineMode); }\r\nfunction GdipSetClipRegion(Graphics: GpGraphics; Region: GpRegion;\r\n  CombineMode: TGPCombineMode): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipSetClipHrgn(GpGraphics *graphics, HRGN hRgn, CombineMode combineMode); }\r\nfunction GdipSetClipHrgn(Graphics: GpGraphics; HRgn: HRGN;\r\n  CombineMode: TGPCombineMode): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipResetClip(GpGraphics *graphics); }\r\nfunction GdipResetClip(Graphics: GpGraphics): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipTranslateClip(GpGraphics *graphics, REAL dx, REAL dy); }\r\nfunction GdipTranslateClip(Graphics: GpGraphics; Dx: Single; Dy: Single): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipTranslateClipI(GpGraphics *graphics, INT dx, INT dy); }\r\nfunction GdipTranslateClipI(Graphics: GpGraphics; Dx: Integer; Dy: Integer): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipGetClip(GpGraphics *graphics, GpRegion *region); }\r\nfunction GdipGetClip(Graphics: GpGraphics; Region: GpRegion): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipGetClipBounds(GpGraphics *graphics, GpRectF *rect); }\r\nfunction GdipGetClipBounds(Graphics: GpGraphics; out Rect: TGPRectF): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipGetClipBoundsI(GpGraphics *graphics, GpRect *rect); }\r\nfunction GdipGetClipBoundsI(Graphics: GpGraphics; out Rect: TGPRect): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipIsClipEmpty(GpGraphics *graphics, BOOL *result); }\r\nfunction GdipIsClipEmpty(Graphics: GpGraphics; out Result: Bool): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipGetVisibleClipBounds(GpGraphics *graphics, GpRectF *rect); }\r\nfunction GdipGetVisibleClipBounds(Graphics: GpGraphics; out Rect: TGPRectF): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipGetVisibleClipBoundsI(GpGraphics *graphics, GpRect *rect); }\r\nfunction GdipGetVisibleClipBoundsI(Graphics: GpGraphics; out Rect: TGPRect): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipIsVisibleClipEmpty(GpGraphics *graphics, BOOL *result); }\r\nfunction GdipIsVisibleClipEmpty(Graphics: GpGraphics; out Result: Bool): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipIsVisiblePoint(GpGraphics *graphics, REAL x, REAL y, BOOL *result); }\r\nfunction GdipIsVisiblePoint(Graphics: GpGraphics; X: Single; Y: Single;\r\n  out Result: Bool): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipIsVisiblePointI(GpGraphics *graphics, INT x, INT y, BOOL *result); }\r\nfunction GdipIsVisiblePointI(Graphics: GpGraphics; X: Integer; Y: Integer;\r\n  out Result: Bool): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipIsVisibleRect(GpGraphics *graphics, REAL x, REAL y, REAL width, REAL height, BOOL *result); }\r\nfunction GdipIsVisibleRect(Graphics: GpGraphics; X: Single; Y: Single;\r\n  Width: Single; Height: Single; out Result: Bool): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipIsVisibleRectI(GpGraphics *graphics, INT x, INT y, INT width, INT height, BOOL *result); }\r\nfunction GdipIsVisibleRectI(Graphics: GpGraphics; X: Integer; Y: Integer;\r\n  Width: Integer; Height: Integer; out Result: Bool): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipSaveGraphics(GpGraphics *graphics, GraphicsState *state); }\r\nfunction GdipSaveGraphics(Graphics: GpGraphics; out State: TGPGraphicsState): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipRestoreGraphics(GpGraphics *graphics, GraphicsState state); }\r\nfunction GdipRestoreGraphics(Graphics: GpGraphics; State: TGPGraphicsState): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipBeginContainer(GpGraphics *graphics, GDIPCONST GpRectF* dstrect, GDIPCONST GpRectF *srcrect, GpUnit unit, GraphicsContainer *state); }\r\nfunction GdipBeginContainer(Graphics: GpGraphics; const Dstrect: PGPRectF;\r\n  const Srcrect: PGPRectF; AUnit: TGPUnit; out State: TGPGraphicsContainer): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipBeginContainerI(GpGraphics *graphics, GDIPCONST GpRect* dstrect, GDIPCONST GpRect *srcrect, GpUnit unit, GraphicsContainer *state); }\r\nfunction GdipBeginContainerI(Graphics: GpGraphics; const Dstrect: PGPRect;\r\n  const Srcrect: PGPRect; AUnit: TGPUnit; out State: TGPGraphicsContainer): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipBeginContainer2(GpGraphics *graphics, GraphicsContainer* state); }\r\nfunction GdipBeginContainer2(Graphics: GpGraphics; out State: TGPGraphicsContainer): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipEndContainer(GpGraphics *graphics, GraphicsContainer state); }\r\nfunction GdipEndContainer(Graphics: GpGraphics; State: TGPGraphicsContainer): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipGetMetafileHeaderFromWmf( HMETAFILE hWmf, GDIPCONST WmfPlaceableFileHeader * wmfPlaceableFileHeader, MetafileHeader * header ); }\r\nfunction GdipGetMetafileHeaderFromWmf(HWmf: HMetaFile;\r\n  const WmfPlaceableFileHeader: TWmfPlaceableFileHeader;\r\n  out Header: TGPMetafileHeader): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipGetMetafileHeaderFromEmf( HENHMETAFILE hEmf, MetafileHeader * header ); }\r\nfunction GdipGetMetafileHeaderFromEmf(HEmf: HEnhMetaFile;\r\n  out Header: TGPMetafileHeader): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipGetMetafileHeaderFromFile( GDIPCONST WCHAR* filename, MetafileHeader * header ); }\r\nfunction GdipGetMetafileHeaderFromFile(const Filename: PWideChar;\r\n  out Header: TGPMetafileHeader): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipGetMetafileHeaderFromStream( IStream * stream, MetafileHeader * header ); }\r\nfunction GdipGetMetafileHeaderFromStream(const Stream: IStream;\r\n  out Header: TGPMetafileHeader): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipGetMetafileHeaderFromMetafile( GpMetafile * metafile, MetafileHeader * header ); }\r\nfunction GdipGetMetafileHeaderFromMetafile(Metafile: GpMetafile;\r\n  out Header: TGPMetafileHeader): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipGetHemfFromMetafile( GpMetafile * metafile, HENHMETAFILE * hEmf ); }\r\nfunction GdipGetHemfFromMetafile(Metafile: GpMetafile;\r\n  out HEmf: HEnhMetaFile): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipCreateStreamOnFile(GDIPCONST WCHAR * filename, UINT access, IStream **stream); }\r\nfunction GdipCreateStreamOnFile(const Filename: PWideChar; Access: Cardinal;\r\n  const Stream: IStream): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipCreateMetafileFromWmf(HMETAFILE hWmf, BOOL deleteWmf, GDIPCONST WmfPlaceableFileHeader * wmfPlaceableFileHeader, GpMetafile **metafile); }\r\nfunction GdipCreateMetafileFromWmf(HWmf: HMetaFile; DeleteWmf: Bool;\r\n  const WmfPlaceableFileHeader: TWmfPlaceableFileHeader;\r\n  out Metafile: GpMetafile): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipCreateMetafileFromEmf(HENHMETAFILE hEmf, BOOL deleteEmf, GpMetafile **metafile); }\r\nfunction GdipCreateMetafileFromEmf(HEmf: HEnhMetaFile; DeleteEmf: Bool;\r\n  out Metafile: GpMetafile): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipCreateMetafileFromFile(GDIPCONST WCHAR* file, GpMetafile **metafile); }\r\nfunction GdipCreateMetafileFromFile(const Filename: PWideChar;\r\n  out Metafile: GpMetafile): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipCreateMetafileFromWmfFile(GDIPCONST WCHAR* file, GDIPCONST WmfPlaceableFileHeader * wmfPlaceableFileHeader, GpMetafile **metafile); }\r\nfunction GdipCreateMetafileFromWmfFile(const Filename: PWideChar;\r\n  const WmfPlaceableFileHeader: TWmfPlaceableFileHeader;\r\n  out Metafile: GpMetafile): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipCreateMetafileFromStream(IStream * stream, GpMetafile **metafile); }\r\nfunction GdipCreateMetafileFromStream(const Stream: IStream;\r\n  out Metafile: GpMetafile): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n\r\n{ GdipRecordMetafile( HDC referenceHdc, EmfType type, GDIPCONST GpRectF * frameRect, MetafileFrameUnit frameUnit, GDIPCONST WCHAR * description, GpMetafile ** metafile ); }\r\nfunction GdipRecordMetafile(ReferenceHdc: HDC; AType: TGPEmfType;\r\n  const FrameRect: PGPRectF; FrameUnit: TGPMetafileFrameUnit;\r\n  const Description: PWideChar; out Metafile: GpMetafile): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipRecordMetafileI( HDC referenceHdc, EmfType type, GDIPCONST GpRect * frameRect, MetafileFrameUnit frameUnit, GDIPCONST WCHAR * description, GpMetafile ** metafile ); }\r\nfunction GdipRecordMetafileI(ReferenceHdc: HDC; AType: TGPEmfType;\r\n  const FrameRect: PGPRect; FrameUnit: TGPMetafileFrameUnit;\r\n  const Description: PWideChar; out Metafile: GpMetafile): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipRecordMetafileFileName( GDIPCONST WCHAR* fileName, HDC referenceHdc, EmfType type, GDIPCONST GpRectF * frameRect, MetafileFrameUnit frameUnit, GDIPCONST WCHAR * description, GpMetafile ** metafile ); }\r\nfunction GdipRecordMetafileFileName(const FileName: PWideChar;\r\n  ReferenceHdc: HDC; AType: TGPEmfType; const FrameRect: PGPRectF;\r\n  FrameUnit: TGPMetafileFrameUnit; const Description: PWideChar;\r\n  out Metafile: GpMetafile): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipRecordMetafileFileNameI( GDIPCONST WCHAR* fileName, HDC referenceHdc, EmfType type, GDIPCONST GpRect * frameRect, MetafileFrameUnit frameUnit, GDIPCONST WCHAR * description, GpMetafile ** metafile ); }\r\nfunction GdipRecordMetafileFileNameI(const FileName: PWideChar;\r\n  ReferenceHdc: HDC; AType: TGPEmfType; const FrameRect: PGPRect;\r\n  FrameUnit: TGPMetafileFrameUnit; const Description: PWideChar;\r\n  out Metafile: GpMetafile): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipRecordMetafileStream( IStream * stream, HDC referenceHdc, EmfType type, GDIPCONST GpRectF * frameRect, MetafileFrameUnit frameUnit, GDIPCONST WCHAR * description, GpMetafile ** metafile ); }\r\nfunction GdipRecordMetafileStream(const Stream: IStream; ReferenceHdc: HDC;\r\n  AType: TGPEmfType; const FrameRect: PGPRectF; FrameUnit: TGPMetafileFrameUnit;\r\n  const Description: PWideChar; out Metafile: GpMetafile): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipRecordMetafileStreamI( IStream * stream, HDC referenceHdc, EmfType type, GDIPCONST GpRect * frameRect, MetafileFrameUnit frameUnit, GDIPCONST WCHAR * description, GpMetafile ** metafile ); }\r\nfunction GdipRecordMetafileStreamI(const Stream: IStream; ReferenceHdc: HDC;\r\n  AType: TGPEmfType; const FrameRect: PGPRect; FrameUnit: TGPMetafileFrameUnit;\r\n  const Description: PWideChar; out Metafile: GpMetafile): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipSetMetafileDownLevelRasterizationLimit( GpMetafile * metafile, UINT metafileRasterizationLimitDpi ); }\r\nfunction GdipSetMetafileDownLevelRasterizationLimit(Metafile: GpMetafile;\r\n  MetafileRasterizationLimitDpi: Cardinal): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipGetMetafileDownLevelRasterizationLimit( GDIPCONST GpMetafile * metafile, UINT * metafileRasterizationLimitDpi ); }\r\nfunction GdipGetMetafileDownLevelRasterizationLimit(const Metafile: GpMetafile;\r\n  out MetafileRasterizationLimitDpi: Cardinal): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipGetImageDecodersSize(UINT *numDecoders, UINT *size); }\r\nfunction GdipGetImageDecodersSize(out NumDecoders: Cardinal; out Size: Cardinal): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipGetImageDecoders(UINT numDecoders, UINT size, __out_bcount(size) ImageCodecInfo *decoders); }\r\nfunction GdipGetImageDecoders(NumDecoders: Cardinal; Size: Cardinal;\r\n  Decoders: PGPNativeImageCodecInfo): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipGetImageEncodersSize(UINT *numEncoders, UINT *size); }\r\nfunction GdipGetImageEncodersSize(out NumEncoders: Cardinal; out Size: Cardinal): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipGetImageEncoders(UINT numEncoders, UINT size, __out_bcount(size) ImageCodecInfo *encoders); }\r\nfunction GdipGetImageEncoders(NumEncoders: Cardinal; Size: Cardinal;\r\n  Encoders: PGPNativeImageCodecInfo): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipComment(GpGraphics* graphics, UINT sizeData, GDIPCONST BYTE * data); }\r\nfunction GdipComment(Graphics: GpGraphics; SizeData: Cardinal;\r\n  const Data: PByte): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n//----------------------------------------------------------------------------\r\n// FontFamily APIs\r\n//----------------------------------------------------------------------------\r\n\r\n{ GdipCreateFontFamilyFromName(GDIPCONST WCHAR *name, GpFontCollection *fontCollection, GpFontFamily **fontFamily); }\r\nfunction GdipCreateFontFamilyFromName(const Name: PWideChar;\r\n  FontCollection: GpFontCollection; out FontFamily: GpFontFamily): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipDeleteFontFamily(GpFontFamily *fontFamily); }\r\nfunction GdipDeleteFontFamily(FontFamily: GpFontFamily): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipCloneFontFamily(GpFontFamily *fontFamily, GpFontFamily **clonedFontFamily); }\r\nfunction GdipCloneFontFamily(FontFamily: GpFontFamily;\r\n  out ClonedFontFamily: GpFontFamily): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipGetGenericFontFamilySansSerif(GpFontFamily **nativeFamily); }\r\nfunction GdipGetGenericFontFamilySansSerif(out NativeFamily: GpFontFamily): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipGetGenericFontFamilySerif(GpFontFamily **nativeFamily); }\r\nfunction GdipGetGenericFontFamilySerif(out NativeFamily: GpFontFamily): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipGetGenericFontFamilyMonospace(GpFontFamily **nativeFamily); }\r\nfunction GdipGetGenericFontFamilyMonospace(out NativeFamily: GpFontFamily): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n\r\n{ GdipGetFamilyName( GDIPCONST GpFontFamily *family, __out_ecount(LF_FACESIZE) LPWSTR name, LANGID language ); }\r\nfunction GdipGetFamilyName(const Family: GpFontFamily; Name: PWideChar;\r\n  Language: LangID): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipIsStyleAvailable(GDIPCONST GpFontFamily *family, INT style, BOOL * IsStyleAvailable); }\r\nfunction GdipIsStyleAvailable(const Family: GpFontFamily; Style: TGPFontStyle;\r\n  out IsStyleAvailable: Bool): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipFontCollectionEnumerable( GpFontCollection* fontCollection, GpGraphics* graphics, INT * numFound ); }\r\nfunction GdipFontCollectionEnumerable(FontCollection: GpFontCollection;\r\n  Graphics: GpGraphics; NumFound: PInteger): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipFontCollectionEnumerate( GpFontCollection* fontCollection, INT numSought, GpFontFamily* gpfamilies[], INT* numFound, GpGraphics* graphics ); }\r\nfunction GdipFontCollectionEnumerate(FontCollection: GpFontCollection;\r\n  NumSought: Integer; Gpfamilies: PGpFontFamily; NumFound: PInteger;\r\n  Graphics: GpGraphics): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipGetEmHeight(GDIPCONST GpFontFamily *family, INT style, UINT16 * EmHeight); }\r\nfunction GdipGetEmHeight(const Family: GpFontFamily; Style: TGPFontStyle;\r\n  out EmHeight: UInt16): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipGetCellAscent(GDIPCONST GpFontFamily *family, INT style, UINT16 * CellAscent); }\r\nfunction GdipGetCellAscent(const Family: GpFontFamily; Style: TGPFontStyle;\r\n  out CellAscent: UInt16): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipGetCellDescent(GDIPCONST GpFontFamily *family, INT style, UINT16 * CellDescent); }\r\nfunction GdipGetCellDescent(const Family: GpFontFamily; Style: TGPFontStyle;\r\n  out CellDescent: UInt16): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipGetLineSpacing(GDIPCONST GpFontFamily *family, INT style, UINT16 * LineSpacing); }\r\nfunction GdipGetLineSpacing(const Family: GpFontFamily; Style: TGPFontStyle;\r\n  out LineSpacing: UInt16): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n//----------------------------------------------------------------------------\r\n// Font APIs\r\n//----------------------------------------------------------------------------\r\n\r\n{ GdipCreateFontFromDC( HDC hdc, GpFont **font ); }\r\nfunction GdipCreateFontFromDC(Hdc: HDC; out Font: GpFont): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipCreateFontFromLogfontA( HDC hdc, GDIPCONST LOGFONTA *logfont, GpFont **font ); }\r\nfunction GdipCreateFontFromLogfontA(Hdc: HDC; const Logfont: PLogFontA;\r\n  out Font: GpFont): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipCreateFontFromLogfontW( HDC hdc, GDIPCONST LOGFONTW *logfont, GpFont **font ); }\r\nfunction GdipCreateFontFromLogfontW(Hdc: HDC; const Logfont: PLogFontW;\r\n  out Font: GpFont): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipCreateFont( GDIPCONST GpFontFamily *fontFamily, REAL emSize, INT style, Unit unit, GpFont **font ); }\r\nfunction GdipCreateFont(const FontFamily: GpFontFamily; EmSize: Single;\r\n  Style: TGPFontStyle; MeasureUnit: TGPUnit; out Font: GpFont): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipCloneFont(GpFont* font, GpFont** cloneFont); }\r\nfunction GdipCloneFont(Font: GpFont; out CloneFont: GpFont): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipDeleteFont(GpFont* font); }\r\nfunction GdipDeleteFont(Font: GpFont): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipGetFamily(GpFont *font, GpFontFamily **family); }\r\nfunction GdipGetFamily(Font: GpFont; out Family: GpFontFamily): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipGetFontStyle(GpFont *font, INT *style); }\r\nfunction GdipGetFontStyle(Font: GpFont; out Style: TGPFontStyle): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipGetFontSize(GpFont *font, REAL *size); }\r\nfunction GdipGetFontSize(Font: GpFont; out Size: Single): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipGetFontUnit(GpFont *font, Unit *unit); }\r\nfunction GdipGetFontUnit(Font: GpFont; out MeasureUnit: TGPUnit): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipGetFontHeight(GDIPCONST GpFont *font, GDIPCONST GpGraphics *graphics, REAL *height); }\r\nfunction GdipGetFontHeight(const Font: GpFont; const Graphics: GpGraphics;\r\n  out Height: Single): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipGetFontHeightGivenDPI(GDIPCONST GpFont *font, REAL dpi, REAL *height); }\r\nfunction GdipGetFontHeightGivenDPI(const Font: GpFont; Dpi: Single;\r\n  out Height: Single): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipGetLogFontA(GpFont * font, GpGraphics *graphics, LOGFONTA * logfontA); }\r\nfunction GdipGetLogFontA(Font: GpFont; Graphics: GpGraphics;\r\n  out LogfontA: TLogFontA): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipGetLogFontW(GpFont * font, GpGraphics *graphics, LOGFONTW * logfontW); }\r\nfunction GdipGetLogFontW(Font: GpFont; Graphics: GpGraphics;\r\n  out LogfontW: TLogFontW): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipNewInstalledFontCollection(GpFontCollection** fontCollection); }\r\nfunction GdipNewInstalledFontCollection(out FontCollection: GpFontCollection): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipNewPrivateFontCollection(GpFontCollection** fontCollection); }\r\nfunction GdipNewPrivateFontCollection(out FontCollection: GpFontCollection): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipDeletePrivateFontCollection(GpFontCollection** fontCollection); }\r\nfunction GdipDeletePrivateFontCollection(out FontCollection: GpFontCollection): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipGetFontCollectionFamilyCount( GpFontCollection* fontCollection, INT * numFound ); }\r\nfunction GdipGetFontCollectionFamilyCount(FontCollection: GpFontCollection;\r\n  out NumFound: Integer): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipGetFontCollectionFamilyList( GpFontCollection* fontCollection, INT numSought, GpFontFamily* gpfamilies[], INT* numFound ); }\r\nfunction GdipGetFontCollectionFamilyList(FontCollection: GpFontCollection;\r\n  NumSought: Integer; Gpfamilies: PGpFontFamily; out NumFound: Integer): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipPrivateAddFontFile( GpFontCollection* fontCollection, GDIPCONST WCHAR* filename ); }\r\nfunction GdipPrivateAddFontFile(FontCollection: GpFontCollection;\r\n  const Filename: PWideChar): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipPrivateAddMemoryFont( GpFontCollection* fontCollection, GDIPCONST void* memory, INT length ); }\r\nfunction GdipPrivateAddMemoryFont(FontCollection: GpFontCollection;\r\n  const Memory: Pointer; Length: Integer): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n//----------------------------------------------------------------------------\r\n// Text APIs\r\n//----------------------------------------------------------------------------\r\n\r\n{ GdipDrawString( GpGraphics *graphics, GDIPCONST WCHAR *string, INT length, GDIPCONST GpFont *font, GDIPCONST RectF *layoutRect, GDIPCONST GpStringFormat *stringFormat, GDIPCONST GpBrush *brush ); }\r\nfunction GdipDrawString(Graphics: GpGraphics; const Str: PWideChar;\r\n  Length: Integer; const Font: GpFont; const LayoutRect: PGPRectF;\r\n  const StringFormat: GpStringFormat; const Brush: GpBrush): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipMeasureString( GpGraphics *graphics, GDIPCONST WCHAR *string, INT length, GDIPCONST GpFont *font, GDIPCONST RectF *layoutRect, GDIPCONST GpStringFormat *stringFormat, RectF *boundingBox, INT *codepointsFitted, INT *linesFilled ); }\r\nfunction GdipMeasureString(Graphics: GpGraphics; const Str: PWideChar;\r\n  Length: Integer; const Font: GpFont; const LayoutRect: PGPRectF;\r\n  const StringFormat: GpStringFormat; out BoundingBox: TGPRectF;\r\n  CodepointsFitted: PInteger; LinesFilled: PInteger): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipMeasureCharacterRanges( GpGraphics *graphics, GDIPCONST WCHAR *string, INT length, GDIPCONST GpFont *font, GDIPCONST RectF &layoutRect, GDIPCONST GpStringFormat *stringFormat, INT regionCount, GpRegion **regions ); }\r\nfunction GdipMeasureCharacterRanges(Graphics: GpGraphics; const Str: PWideChar;\r\n  Length: Integer; const Font: GpFont; const LayoutRect: PGPRectF;\r\n  const StringFormat: GpStringFormat; RegionCount: Integer;\r\n  Regions: PGpRegion): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipDrawDriverString( GpGraphics *graphics, GDIPCONST UINT16 *text, INT length, GDIPCONST GpFont *font, GDIPCONST GpBrush *brush, GDIPCONST PointF *positions, INT flags, GDIPCONST GpMatrix *matrix ); }\r\nfunction GdipDrawDriverString(Graphics: GpGraphics; const Text: PUInt16;\r\n  Length: Integer; const Font: GpFont; const Brush: GpBrush;\r\n  const Positions: PGPPointF; Flags: TGPDriverStringOptions; const Matrix: GpMatrix): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipMeasureDriverString( GpGraphics *graphics, GDIPCONST UINT16 *text, INT length, GDIPCONST GpFont *font, GDIPCONST PointF *positions, INT flags, GDIPCONST GpMatrix *matrix, RectF *boundingBox ); }\r\nfunction GdipMeasureDriverString(Graphics: GpGraphics; const Text: PUInt16;\r\n  Length: Integer; const Font: GpFont; const Positions: PGPPointF; Flags: TGPDriverStringOptions;\r\n  const Matrix: GpMatrix; out BoundingBox: TGPRectF): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n//----------------------------------------------------------------------------\r\n// String format APIs\r\n//----------------------------------------------------------------------------\r\n\r\n{ GdipCreateStringFormat( INT formatAttributes, LANGID language, GpStringFormat **format ); }\r\nfunction GdipCreateStringFormat(FormatAttributes: TGPStringFormatFlags; Language: LANGID;\r\n  out Format: GpStringFormat): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipStringFormatGetGenericDefault(GpStringFormat **format); }\r\nfunction GdipStringFormatGetGenericDefault(out Format: GpStringFormat): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipStringFormatGetGenericTypographic(GpStringFormat **format); }\r\nfunction GdipStringFormatGetGenericTypographic(out Format: GpStringFormat): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipDeleteStringFormat(GpStringFormat *format); }\r\nfunction GdipDeleteStringFormat(Format: GpStringFormat): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipCloneStringFormat(GDIPCONST GpStringFormat *format, GpStringFormat **newFormat); }\r\nfunction GdipCloneStringFormat(const Format: GpStringFormat;\r\n  out NewFormat: GpStringFormat): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipSetStringFormatFlags(GpStringFormat *format, INT flags); }\r\nfunction GdipSetStringFormatFlags(Format: GpStringFormat; Flags: TGPStringFormatFlags): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipGetStringFormatFlags(GDIPCONST GpStringFormat *format, INT *flags); }\r\nfunction GdipGetStringFormatFlags(const Format: GpStringFormat;\r\n  out Flags: TGPStringFormatFlags): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipSetStringFormatAlign(GpStringFormat *format, StringAlignment align); }\r\nfunction GdipSetStringFormatAlign(Format: GpStringFormat;\r\n  Align: TGPStringAlignment): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipGetStringFormatAlign(GDIPCONST GpStringFormat *format, StringAlignment *align); }\r\nfunction GdipGetStringFormatAlign(const Format: GpStringFormat;\r\n  out Align: TGPStringAlignment): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipSetStringFormatLineAlign(GpStringFormat *format, StringAlignment align); }\r\nfunction GdipSetStringFormatLineAlign(Format: GpStringFormat;\r\n  Align: TGPStringAlignment): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipGetStringFormatLineAlign(GDIPCONST GpStringFormat *format, StringAlignment *align); }\r\nfunction GdipGetStringFormatLineAlign(const Format: GpStringFormat;\r\n  out Align: TGPStringAlignment): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipSetStringFormatTrimming( GpStringFormat *format, StringTrimming trimming ); }\r\nfunction GdipSetStringFormatTrimming(Format: GpStringFormat;\r\n  Trimming: TGPStringTrimming): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipGetStringFormatTrimming( GDIPCONST GpStringFormat *format, StringTrimming *trimming ); }\r\nfunction GdipGetStringFormatTrimming(const Format: GpStringFormat;\r\n  out Trimming: TGPStringTrimming): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipSetStringFormatHotkeyPrefix(GpStringFormat *format, INT hotkeyPrefix); }\r\nfunction GdipSetStringFormatHotkeyPrefix(Format: GpStringFormat;\r\n  HotkeyPrefix: TGPHotkeyPrefix): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipGetStringFormatHotkeyPrefix(GDIPCONST GpStringFormat *format, INT *hotkeyPrefix); }\r\nfunction GdipGetStringFormatHotkeyPrefix(const Format: GpStringFormat;\r\n  out HotkeyPrefix: TGPHotkeyPrefix): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipSetStringFormatTabStops(GpStringFormat *format, REAL firstTabOffset, INT count, GDIPCONST REAL *tabStops); }\r\nfunction GdipSetStringFormatTabStops(Format: GpStringFormat;\r\n  FirstTabOffset: Single; Count: Integer; const TabStops: PSingle): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipGetStringFormatTabStops(GDIPCONST GpStringFormat *format, INT count, REAL *firstTabOffset, REAL *tabStops); }\r\nfunction GdipGetStringFormatTabStops(const Format: GpStringFormat;\r\n  Count: Integer; out FirstTabOffset: Single; TabStops: PSingle): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipGetStringFormatTabStopCount(GDIPCONST GpStringFormat *format, INT * count); }\r\nfunction GdipGetStringFormatTabStopCount(const Format: GpStringFormat;\r\n  out Count: Integer): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipSetStringFormatDigitSubstitution(GpStringFormat *format, LANGID language, StringDigitSubstitute substitute); }\r\nfunction GdipSetStringFormatDigitSubstitution(Format: GpStringFormat;\r\n  Language: LangID; Substitute: TGPStringDigitSubstitute): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipGetStringFormatDigitSubstitution(GDIPCONST GpStringFormat *format, LANGID *language, StringDigitSubstitute *substitute); }\r\nfunction GdipGetStringFormatDigitSubstitution(const Format: GpStringFormat;\r\n  Language: PLangID; Substitute: PGPStringDigitSubstitute): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipGetStringFormatMeasurableCharacterRangeCount( GDIPCONST GpStringFormat *format, INT *count ); }\r\nfunction GdipGetStringFormatMeasurableCharacterRangeCount(\r\n  const Format: GpStringFormat; out Count: Integer): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipSetStringFormatMeasurableCharacterRanges( GpStringFormat *format, INT rangeCount, GDIPCONST CharacterRange *ranges ); }\r\nfunction GdipSetStringFormatMeasurableCharacterRanges(Format: GpStringFormat;\r\n  RangeCount: Integer; const Ranges: PGPCharacterRange): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n//----------------------------------------------------------------------------\r\n// Cached Bitmap APIs\r\n//----------------------------------------------------------------------------\r\n\r\n{ GdipCreateCachedBitmap( GpBitmap *bitmap, GpGraphics *graphics, GpCachedBitmap **cachedBitmap ); }\r\nfunction GdipCreateCachedBitmap(Bitmap: GpBitmap; Graphics: GpGraphics;\r\n  out CachedBitmap: GpCachedBitmap): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipDeleteCachedBitmap(GpCachedBitmap *cachedBitmap); }\r\nfunction GdipDeleteCachedBitmap(CachedBitmap: GpCachedBitmap): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipDrawCachedBitmap( GpGraphics *graphics, GpCachedBitmap *cachedBitmap, INT x, INT y ); }\r\nfunction GdipDrawCachedBitmap(Graphics: GpGraphics;\r\n  CachedBitmap: GpCachedBitmap; X: Integer; Y: Integer): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\nfunction GdipEmfToWmfBits(HEmf: HEnhMetaFile; cbData16: UINT; pData16: PByte;\r\n  MapMode: Integer; Flags: TGPEmfToWmfBitsFlags): UINT; stdcall; external GdiPlusDll;\r\n\r\n{ GdipSetImageAttributesCachedBackground( GpImageAttributes *imageattr, BOOL enableFlag ); }\r\nfunction GdipSetImageAttributesCachedBackground(Imageattr: GpImageAttributes;\r\n  EnableFlag: Bool): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipTestControl( GpTestControlEnum control, void * param ); }\r\nfunction GdipTestControl(Control: TGPTestControlEnum; Param: Pointer): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\nfunction GdiplusNotificationHook(out Token: ULONG): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\nprocedure GdiplusNotificationUnhook(Token: ULONG); stdcall; external GdiPlusDll;\r\n\r\n{$IF (GDIPVER >= $0110)}\r\n{ GdipConvertToEmfPlus( const GpGraphics* refGraphics, GpMetafile* metafile, INT* conversionFailureFlag, EmfType emfType, const WCHAR* description, GpMetafile** out_metafile ); }\r\nfunction GdipConvertToEmfPlus(const RefGraphics: GpGraphics;\r\n  Metafile: GpMetafile; ConversionFailureFlag: PInteger; EmfType: TGPEmfType;\r\n  const Description: PWideChar; out Out_metafile: GpMetafile): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n\r\n{ GdipConvertToEmfPlusToFile( const GpGraphics* refGraphics, GpMetafile* metafile, INT* conversionFailureFlag, const WCHAR* filename, EmfType emfType, const WCHAR* description, GpMetafile** out_metafile ); }\r\nfunction GdipConvertToEmfPlusToFile(const RefGraphics: GpGraphics;\r\n  Metafile: GpMetafile; ConversionFailureFlag: PInteger;\r\n  const Filename: PWideChar; EmfType: TGPEmfType; const Description: PWideChar;\r\n  out Out_metafile: GpMetafile): TGPStatus; stdcall; external GdiPlusDll;\r\n\r\n{ GdipConvertToEmfPlusToStream( const GpGraphics* refGraphics, GpMetafile* metafile, INT* conversionFailureFlag, IStream* stream, EmfType emfType, const WCHAR* description, GpMetafile** out_metafile ); }\r\nfunction GdipConvertToEmfPlusToStream(const RefGraphics: GpGraphics;\r\n  Metafile: GpMetafile; ConversionFailureFlag: PInteger; const Stream: IStream;\r\n  EmfType: TGPEmfType; const Description: PWideChar; out Out_metafile: GpMetafile): TGPStatus; stdcall;\r\n  external GdiPlusDll;\r\n{$IFEND}\r\n{$ENDREGION 'GdiplusFlat.h'}\r\n\r\n{$REGION 'GdiplusGpStubs.h (2)'}\r\n(*****************************************************************************\r\n * GdiplusGpStubs.h\r\n * Private GDI+ header file.\r\n *****************************************************************************)\r\n\r\n\r\n//---------------------------------------------------------------------------\r\n// GDI+ classes for forward reference\r\n//---------------------------------------------------------------------------\r\n\r\ntype\r\n  IGPGraphics = interface;\r\n  IGPPen = interface;\r\n  IGPBrush = interface;\r\n  IGPMatrix = interface;\r\n  IGPBitmap = interface;\r\n  IGPMetafile = interface;\r\n  IGPGraphicsPath = interface;\r\n  IGPGraphicsPathIterator = interface;\r\n  IGPRegion = interface;\r\n  IGPImage = interface;\r\n  IGPTextureBrush = interface;\r\n  IGPHatchBrush = interface;\r\n  IGPSolidBrush = interface;\r\n  IGPLinearGradientBrush = interface;\r\n  IGPPathGradientBrush = interface;\r\n  IGPFont = interface;\r\n  IGPFontFamily = interface;\r\n  IGPFontCollection = interface;\r\n  IGPInstalledFontCollection = interface;\r\n  IGPPrivateFontCollection = interface;\r\n  IGPImageAttributes = interface;\r\n  IGPCachedBitmap = interface;\r\n{$ENDREGION 'GdiplusGpStubs.h (2)'}\r\n\r\n{$REGION 'GdiplusRegion.h'}\r\n(*****************************************************************************\r\n * GdiplusRegion.h\r\n * GDI+ Region class implementation\r\n *****************************************************************************)\r\n\r\n  IGPRegionData = IGPBuffer;\r\n  IGPRegionScansF = IGPArray;\r\n  IGPRegionScans = IGPArray;\r\n\r\n  IGPRegion = interface(IGdiPlusBase)\r\n  ['{BA76B8F7-FEF0-41AA-9E96-59946D279F4D}']\r\n    { Methods }\r\n    function Clone: IGPRegion;\r\n    procedure MakeInfinite;\r\n    procedure MakeEmpty;\r\n    function GetData: IGPRegionData;\r\n    procedure Intersect(const Rect: TGPRect); overload;\r\n    procedure Intersect(const Rect: TGPRectF); overload;\r\n    procedure Intersect(const Path: IGPGraphicsPath); overload;\r\n    procedure Intersect(const Region: IGPRegion); overload;\r\n    procedure Union(const Rect: TGPRect); overload;\r\n    procedure Union(const Rect: TGPRectF); overload;\r\n    procedure Union(const Path: IGPGraphicsPath); overload;\r\n    procedure Union(const Region: IGPRegion); overload;\r\n    procedure ExclusiveOr(const Rect: TGPRect); overload;\r\n    procedure ExclusiveOr(const Rect: TGPRectF); overload;\r\n    procedure ExclusiveOr(const Path: IGPGraphicsPath); overload;\r\n    procedure ExclusiveOr(const Region: IGPRegion); overload;\r\n    procedure Exclude(const Rect: TGPRect); overload;\r\n    procedure Exclude(const Rect: TGPRectF); overload;\r\n    procedure Exclude(const Path: IGPGraphicsPath); overload;\r\n    procedure Exclude(const Region: IGPRegion); overload;\r\n    procedure Complement(const Rect: TGPRect); overload;\r\n    procedure Complement(const Rect: TGPRectF); overload;\r\n    procedure Complement(const Path: IGPGraphicsPath); overload;\r\n    procedure Complement(const Region: IGPRegion); overload;\r\n    procedure Translate(const DX, DY: Single); overload;\r\n    procedure Translate(const DX, DY: Integer); overload;\r\n    procedure Transform(const Matrix: IGPMatrix);\r\n    procedure GetBounds(out Rect: TGPRect; const G: IGPGraphics); overload;\r\n    procedure GetBounds(out Rect: TGPRectF; const G: IGPGraphics); overload;\r\n    function GetHRGN(const G: IGPGraphics): HRGN;\r\n    function IsEmpty(const G: IGPGraphics): Boolean;\r\n    function IsInfinite(const G: IGPGraphics): Boolean;\r\n    function IsVisible(const X, Y: Integer; const G: IGPGraphics = nil): Boolean; overload;\r\n    function IsVisible(const Point: TGPPoint; const G: IGPGraphics = nil): Boolean; overload;\r\n    function IsVisible(const X, Y: Single; const G: IGPGraphics = nil): Boolean; overload;\r\n    function IsVisible(const Point: TGPPointF; const G: IGPGraphics = nil): Boolean; overload;\r\n    function IsVisible(const X, Y, Width, Height: Integer; const G: IGPGraphics = nil): Boolean; overload;\r\n    function IsVisible(const Rect: TGPRect; const G: IGPGraphics = nil): Boolean; overload;\r\n    function IsVisible(const X, Y, Width, Height: Single; const G: IGPGraphics = nil): Boolean; overload;\r\n    function IsVisible(const Rect: TGPRectF; const G: IGPGraphics = nil): Boolean; overload;\r\n    function Equals(const Region: IGPRegion; const G: IGPGraphics): Boolean;\r\n    function GetRegionScans(const Matrix: IGPMatrix): IGPRegionScansF;\r\n    function GetRegionScansI(const Matrix: IGPMatrix): IGPRegionScans;\r\n  end;\r\n\r\n  TGPRegion = class(TGdiplusBase, IGPRegion)\r\n  private\r\n    { IGPRegion }\r\n    function Clone: IGPRegion;\r\n    procedure MakeInfinite;\r\n    procedure MakeEmpty;\r\n    function GetData: IGPRegionData;\r\n    procedure Intersect(const Rect: TGPRect); overload;\r\n    procedure Intersect(const Rect: TGPRectF); overload;\r\n    procedure Intersect(const Path: IGPGraphicsPath); overload;\r\n    procedure Intersect(const Region: IGPRegion); overload;\r\n    procedure Union(const Rect: TGPRect); overload;\r\n    procedure Union(const Rect: TGPRectF); overload;\r\n    procedure Union(const Path: IGPGraphicsPath); overload;\r\n    procedure Union(const Region: IGPRegion); overload;\r\n    procedure ExclusiveOr(const Rect: TGPRect); overload;\r\n    procedure ExclusiveOr(const Rect: TGPRectF); overload;\r\n    procedure ExclusiveOr(const Path: IGPGraphicsPath); overload;\r\n    procedure ExclusiveOr(const Region: IGPRegion); overload;\r\n    procedure Exclude(const Rect: TGPRect); overload;\r\n    procedure Exclude(const Rect: TGPRectF); overload;\r\n    procedure Exclude(const Path: IGPGraphicsPath); overload;\r\n    procedure Exclude(const Region: IGPRegion); overload;\r\n    procedure Complement(const Rect: TGPRect); overload;\r\n    procedure Complement(const Rect: TGPRectF); overload;\r\n    procedure Complement(const Path: IGPGraphicsPath); overload;\r\n    procedure Complement(const Region: IGPRegion); overload;\r\n    procedure Translate(const DX, DY: Single); overload;\r\n    procedure Translate(const DX, DY: Integer); overload;\r\n    procedure Transform(const Matrix: IGPMatrix);\r\n    procedure GetBounds(out Rect: TGPRect; const G: IGPGraphics); overload;\r\n    procedure GetBounds(out Rect: TGPRectF; const G: IGPGraphics); overload;\r\n    function GetHRGN(const G: IGPGraphics): HRGN;\r\n    function IsEmpty(const G: IGPGraphics): Boolean;\r\n    function IsInfinite(const G: IGPGraphics): Boolean;\r\n    function IsVisible(const X, Y: Integer; const G: IGPGraphics = nil): Boolean; overload;\r\n    function IsVisible(const Point: TGPPoint; const G: IGPGraphics = nil): Boolean; overload;\r\n    function IsVisible(const X, Y: Single; const G: IGPGraphics = nil): Boolean; overload;\r\n    function IsVisible(const Point: TGPPointF; const G: IGPGraphics = nil): Boolean; overload;\r\n    function IsVisible(const X, Y, Width, Height: Integer; const G: IGPGraphics = nil): Boolean; overload;\r\n    function IsVisible(const Rect: TGPRect; const G: IGPGraphics = nil): Boolean; overload;\r\n    function IsVisible(const X, Y, Width, Height: Single; const G: IGPGraphics = nil): Boolean; overload;\r\n    function IsVisible(const Rect: TGPRectF; const G: IGPGraphics = nil): Boolean; overload;\r\n    function Equals(const Region: IGPRegion; const G: IGPGraphics): Boolean; reintroduce;\r\n    function GetRegionScans(const Matrix: IGPMatrix): IGPRegionScansF;\r\n    function GetRegionScansI(const Matrix: IGPMatrix): IGPRegionScans;\r\n  private\r\n    constructor Create(const NativeRegion: GpRegion); overload;\r\n  public\r\n    constructor Create; overload;\r\n    constructor Create(const Rect: TGPRectF); overload;\r\n    constructor Create(const Rect: TGPRect); overload;\r\n    constructor Create(const Path: IGPGraphicsPath); overload;\r\n    constructor Create(const RegionData: PByte; const Size: Integer); overload;\r\n    constructor Create(const HRgn: HRGN); overload;\r\n    destructor Destroy; override;\r\n\r\n    class function FromHRGN(const HRgn: HRGN): IGPRegion; static;\r\n  end;\r\n{$ENDREGION 'GdiplusRegion.h'}\r\n\r\n{$REGION 'GdiplusFontFamily.h'}\r\n(*****************************************************************************\r\n * GdiplusFontFamily.h\r\n * GDI+ Font Family class\r\n *****************************************************************************)\r\n\r\n  IGPFontFamily = interface(IGdiPlusBase)\r\n  ['{FC545EB0-E826-476E-9435-8ADAE2D191B4}']\r\n    { Property access method }\r\n    function GetFamilyNameInternal: String;\r\n\r\n    { Methods }\r\n    function GetFamilyName(const Language: LangID = 0): String;\r\n    function Clone: IGPFontFamily;\r\n    function IsAvailable: Boolean;\r\n    function IsStyleAvailable(const Style: TGPFontStyle): Boolean;\r\n    function GetEmHeight(const Style: TGPFontStyle): Word;\r\n    function GetCellAscent(const Style: TGPFontStyle): Word;\r\n    function GetCellDescent(const Style: TGPFontStyle): Word;\r\n    function GetLineSpacing(const Style: TGPFontStyle): Word;\r\n\r\n    { Properties }\r\n    property FamilyName: String read GetFamilyNameInternal;\r\n  end;\r\n\r\n  TGPFontFamily = class(TGdiplusBase, IGPFontFamily)\r\n  private\r\n    class var FGenericSansSerifFontFamily: IGPFontFamily;\r\n    class var FGenericSerifFontFamily: IGPFontFamily;\r\n    class var FGenericMonoSpaceFontFamily: IGPFontFamily;\r\n  private\r\n    { IGPFontFamily }\r\n    function GetFamilyNameInternal: String;\r\n    function GetFamilyName(const Language: LangID = 0): String;\r\n    function Clone: IGPFontFamily;\r\n    function IsAvailable: Boolean;\r\n    function IsStyleAvailable(const Style: TGPFontStyle): Boolean;\r\n    function GetEmHeight(const Style: TGPFontStyle): Word;\r\n    function GetCellAscent(const Style: TGPFontStyle): Word;\r\n    function GetCellDescent(const Style: TGPFontStyle): Word;\r\n    function GetLineSpacing(const Style: TGPFontStyle): Word;\r\n  private\r\n    constructor Create(const NativeFamily: GpFontFamily); overload;\r\n  public\r\n    constructor Create; overload;\r\n    constructor Create(const Name: String;\r\n      const FontCollection: IGPFontCollection = nil); overload;\r\n    destructor Destroy; override;\r\n\r\n    class function GenericSansSerif: IGPFontFamily; static;\r\n    class function GenericSerif: IGPFontFamily; static;\r\n    class function GenericMonospace: IGPFontFamily; static;\r\n  end;\r\n\r\n{$ENDREGION 'GdiplusFontFamily.h'}\r\n\r\n{$REGION 'GdiplusFont.h'}\r\n(*****************************************************************************\r\n * GdiplusFont.h\r\n * GDI+ Font class\r\n *****************************************************************************)\r\n\r\n  IGPFont = interface(IGdiPlusBase)\r\n  ['{63A81FE2-D0BC-4031-9DD8-0254A1CC732D}']\r\n    { Property access methods }\r\n    function GetStyle: TGPFontStyle;\r\n    function GetSize: Single;\r\n    function GetUnit: TGPUnit;\r\n    function GetFamily: IGPFontFamily;\r\n\r\n    { Methods }\r\n    function Clone: IGPFont;\r\n    function GetLogFontA(const G: IGPGraphics): TLogFontA;\r\n    function GetLogFontW(const G: IGPGraphics): TLogFontW;\r\n    function IsAvailable: Boolean;\r\n    function GetHeight(const Graphics: IGPGraphics): Single; overload;\r\n    function GetHeight(const Dpi: Single): Single; overload;\r\n\r\n    { Properties }\r\n    property Style: TGPFontStyle read GetStyle;\r\n    property Size: Single read GetSize;\r\n    property MeasureUnit: TGPUnit read GetUnit;\r\n    property Family: IGPFontFamily read GetFamily;\r\n  end;\r\n\r\n  TGPFont = class(TGdiPlusBase, IGPFont)\r\n  private\r\n    { IGPFont }\r\n    function GetStyle: TGPFontStyle;\r\n    function GetSize: Single;\r\n    function GetUnit: TGPUnit;\r\n    function Clone: IGPFont;\r\n    function GetLogFontA(const G: IGPGraphics): TLogFontA;\r\n    function GetLogFontW(const G: IGPGraphics): TLogFontW;\r\n    function IsAvailable: Boolean;\r\n    function GetHeight(const Graphics: IGPGraphics): Single; overload;\r\n    function GetHeight(const Dpi: Single): Single; overload;\r\n    function GetFamily: IGPFontFamily;\r\n  private\r\n    constructor Create(const NativeFont: GpFont); overload;\r\n  public\r\n    constructor Create(const DC: HDC); overload;\r\n    constructor Create(const DC: HDC; const LogFont: TLogFontA); overload;\r\n    constructor Create(const DC: HDC; const LogFont: TLogFontW); overload;\r\n    constructor Create(const DC: HDC; const FontHandle: HFont); overload;\r\n    constructor Create(const Family: IGPFontFamily; const EmSize: Single;\r\n      const Style: TGPFontStyle = FontStyleRegular;\r\n      const MeasureUnit: TGPUnit = UnitPoint); overload;\r\n    constructor Create(const FamilyName: String; const EmSize: Single;\r\n      const Style: TGPFontStyle = FontStyleRegular;\r\n      const MeasureUnit: TGPUnit = UnitPoint;\r\n      const FontCollection: IGPFontCollection = nil); overload;\r\n    destructor Destroy; override;\r\n  end;\r\n\r\n{$ENDREGION 'GdiplusFont.h'}\r\n\r\n{$REGION 'GdiplusFontCollection.h'}\r\n(*****************************************************************************\r\n * GdiplusFontCollection.h\r\n * Font collections (Installed and Private)\r\n *****************************************************************************)\r\n\r\n  IGPFontFamilies = IGPArray;\r\n\r\n  IGPFontCollection = interface(IGdiPlusBase)\r\n  ['{5040653F-C5E1-4CA1-9623-6CD258F6DD6C}']\r\n    { Property access methods }\r\n    function GetFamilies: IGPFontFamilies;\r\n\r\n    { Properties }\r\n    property Families: IGPFontFamilies read GetFamilies;\r\n  end;\r\n\r\n  TGPFontCollection = class(TGdiPlusBase, IGPFontCollection)\r\n  private\r\n    { IGPFontCollection }\r\n    function GetFamilies: IGPFontFamilies;\r\n  public\r\n    constructor Create;\r\n  end;\r\n\r\n  IGPInstalledFontCollection = interface(IGPFontCollection)\r\n  ['{168514BC-DC7E-40BC-808D-B2E949AE9F4F}']\r\n  end;\r\n\r\n  TGPInstalledFontCollection = class(TGPFontCollection, IGPInstalledFontCollection)\r\n  public\r\n    constructor Create;\r\n  end;\r\n\r\n  IGPPrivateFontCollection = interface(IGPFontCollection)\r\n  ['{75E3CC1B-16E4-4203-9796-05B47EB5F076}']\r\n    { Methods }\r\n    procedure AddFontFile(const Filename: String);\r\n    procedure AddMemoryFont(const Memory: Pointer; const Length: Integer);\r\n  end;\r\n\r\n  TGPPrivateFontCollection = class(TGPFontCollection, IGPPrivateFontCollection)\r\n  private\r\n    { IGPPrivateFontCollection }\r\n    procedure AddFontFile(const Filename: String);\r\n    procedure AddMemoryFont(const Memory: Pointer; const Length: Integer);\r\n  public\r\n    constructor Create;\r\n    destructor Destroy; override;\r\n  end;\r\n\r\n{$ENDREGION 'GdiplusFontCollection.h'}\r\n\r\n{$REGION 'GdiplusBitmap.h'}\r\n(*****************************************************************************\r\n * GdiplusBitmap.h\r\n * GDI+ Bitmap class\r\n *****************************************************************************)\r\n\r\n  IGPImageFormat = interface\r\n  ['{EDAB4D5F-527C-47D6-B53E-38DB9496725D}']\r\n    { Property access method }\r\n    function GetGuid: TGUID;\r\n    function GetCodecId: TGUID;\r\n\r\n    { Properties }\r\n    property Guid: TGUID read GetGUID;\r\n    property CodecId: TGUID read GetCodecId;\r\n  end;\r\n\r\n  TGPImageFormat = class(TInterfacedObject, IGPImageFormat)\r\n  private\r\n    FGuid: TGUID;\r\n    FCodecId: TGUID;\r\n    class var FInitialized: Boolean;\r\n    class var FBmp: IGPImageFormat;\r\n    class var FJpeg: IGPImageFormat;\r\n    class var FGif: IGPImageFormat;\r\n    class var FTiff: IGPImageFormat;\r\n    class var FPng: IGPImageFormat;\r\n    class function GetBmp: IGPImageFormat; static;\r\n    class function GetJpeg: IGPImageFormat; static;\r\n    class function GetGif: IGPImageFormat; static;\r\n    class function GetTiff: IGPImageFormat; static;\r\n    class function GetPng: IGPImageFormat; static;\r\n    class procedure InitializeCodecs; static;\r\n  private\r\n    { IGPImageFormat }\r\n    function GetGuid: TGuid;\r\n    function GetCodecId: TGUID;\r\n  public\r\n    constructor Create(const Guid: TGUID); overload;\r\n    constructor Create(const Guid, CodecId: TGUID); overload;\r\n    class function FindByFormatId(const lFormatId: TGUID): IGPImageFormat; static;\r\n\r\n    class property Bmp: IGPImageFormat read GetBmp;\r\n    class property Jpeg: IGPImageFormat read GetJpeg;\r\n    class property Gif: IGPImageFormat read GetGif;\r\n    class property Tiff: IGPImageFormat read GetTiff;\r\n    class property Png: IGPImageFormat read GetPng;\r\n  end;\r\n\r\n  IGPImageCodecInfo = interface\r\n  ['{4AAE3ECA-3AEA-4C20-8D17-865F07393536}']\r\n    { Property access methods }\r\n    function GetClsId: TGUID;\r\n    function GetCodecName: String;\r\n    function GetDllName: String;\r\n    function GetFilenameExtension: String;\r\n    function GetFlags: TGPImageCodecFlags;\r\n    function GetFormatDescription: String;\r\n    function GetFormatId: TGUID;\r\n    function GetMimeType: String;\r\n    function GetVersion: Integer;\r\n\r\n    { Properties }\r\n    property ClsId: TGUID read GetClsId;\r\n    property CodecName: String read GetCodecName;\r\n    property DllName: String read GetDllName;\r\n    property FilenameExtension: String read GetFilenameExtension;\r\n    property Flags: TGPImageCodecFlags read GetFlags;\r\n    property FormatDescription: String read GetFormatDescription;\r\n    property FormatId: TGUID read GetFormatId;\r\n    property MimeType: String read GetMimeType;\r\n    property Version: Integer read GetVersion;\r\n  end;\r\n\r\n  IGPImageCodecInfoArray = IGPArray;\r\n\r\n  TGPImageCodecInfo = class(TInterfacedObject, IGPImageCodecInfo)\r\n  private\r\n    FInfo: TGPNativeImageCodecInfo;\r\n  private\r\n    { IGPImageCodecInfo }\r\n    function GetClsId: TGUID;\r\n    function GetCodecName: String;\r\n    function GetDllName: String;\r\n    function GetFilenameExtension: String;\r\n    function GetFlags: TGPImageCodecFlags;\r\n    function GetFormatDescription: String;\r\n    function GetFormatId: TGUID;\r\n    function GetMimeType: String;\r\n    function GetVersion: Integer;\r\n  public\r\n    constructor Create(const Info: TGPNativeImageCodecInfo);\r\n    class function GetImageDecoders: IGPImageCodecInfoArray; static;\r\n    class function GetImageEncoders: IGPImageCodecInfoArray; static;\r\n  end;\r\n\r\n  IGPEncoderParameters = interface;\r\n\r\n  TGPEncoderParameterEnumerator = class\r\n  private\r\n    FIndex: Integer;\r\n    FParams: IGPEncoderParameters;\r\n  public\r\n    constructor Create(const AParams: IGPEncoderParameters);\r\n    function GetCurrent: PGPNativeEncoderParameter;\r\n    function MoveNext: Boolean;\r\n    property Current: PGPNativeEncoderParameter read GetCurrent;\r\n  end;\r\n\r\n  IGPEncoderParameters = interface\r\n  ['{284A0A77-1831-483A-AF75-903FCFB50A56}']\r\n    { Property access methods }\r\n    function GetCount: Integer;\r\n    function GetParam(const Index: Integer): PGPNativeEncoderParameter;\r\n    function GetNativeParams: PGPNativeEncoderParameters;\r\n\r\n    { Methods }\r\n    function GetEnumerator: TGPEncoderParameterEnumerator;\r\n    procedure Clear;\r\n    procedure Add(const ParamType: TGUID; const Value: TGPEncoderValue); overload;\r\n    procedure Add(const ParamType: TGUID; const Value: array of TGPEncoderValue); overload;\r\n    procedure Add(const ParamType: TGUID; var Value: Byte); overload;\r\n    procedure Add(const ParamType: TGUID; const Value: array of Byte); overload;\r\n    procedure Add(const ParamType: TGUID; var Value: Int16); overload;\r\n    procedure Add(const ParamType: TGUID; const Value: array of Int16); overload;\r\n    procedure Add(const ParamType: TGUID; var Value: Int32); overload;\r\n    procedure Add(const ParamType: TGUID; const Value: array of Int32); overload;\r\n    procedure Add(const ParamType: TGUID; var Value: Int64); overload;\r\n    procedure Add(const ParamType: TGUID; const Value: array of Int64); overload;\r\n    procedure Add(const ParamType: TGUID; const Value: String); overload;\r\n    procedure Add(const ParamType: TGUID; const Value: Byte;\r\n      const Undefined: Boolean); overload;\r\n    procedure Add(const ParamType: TGUID; const Value: array of Byte;\r\n      const Undefined: Boolean); overload;\r\n    procedure Add(const ParamType: TGUID; var Numerator, Denominator: Int32); overload;\r\n    procedure Add(const ParamType: TGUID; const Numerators,\r\n      Denominators: array of Int32); overload;\r\n    procedure Add(const ParamType: TGUID; var RangeBegin, RangeEnd: Int64); overload;\r\n    procedure Add(const ParamType: TGUID; const RangesBegin,\r\n      RangesEnd: array of Int64); overload;\r\n    procedure Add(const ParamType: TGUID; const NumberOfValues: Integer;\r\n      const ValueType: TGPEncoderParameterValueType; const Value: Pointer); overload;\r\n    procedure Add(const ParamType: TGUID; const Numerator1, Denominator1,\r\n      Numerator2, Denominator2: Int32); overload;\r\n    procedure Add(const ParamType: TGUID; const Numerator1, Denominator1,\r\n      Numerator2, Denominator2: array of Int32); overload;\r\n\r\n    { Properties }\r\n    property Count: Integer read GetCount;\r\n    property Param[const Index: Integer]: PGPNativeEncoderParameter read GetParam; default;\r\n    property NativeParams: PGPNativeEncoderParameters read GetNativeParams;\r\n  end;\r\n\r\n  TGPEncoderParameters = class(TInterfacedObject, IGPEncoderParameters)\r\n  private\r\n    FParams: array of TGPNativeEncoderParameter;\r\n    FParamCount: Integer;\r\n    FValues: Pointer;\r\n    FValueSize: Integer;\r\n    FValueAllocated: Integer;\r\n    FNativeParams: PGPNativeEncoderParameters;\r\n    FModified: Boolean;\r\n  private\r\n    { IGPEncoderParameters }\r\n    function GetNativeParams: PGPNativeEncoderParameters;\r\n    function GetEnumerator: TGPEncoderParameterEnumerator;\r\n    function GetCount: Integer;\r\n    function GetParam(const Index: Integer): PGPNativeEncoderParameter;\r\n    procedure Clear;\r\n    procedure Add(const ParamType: TGUID; const Value: TGPEncoderValue); overload;\r\n    procedure Add(const ParamType: TGUID; const Value: array of TGPEncoderValue); overload;\r\n    procedure Add(const ParamType: TGUID; var Value: Byte); overload;\r\n    procedure Add(const ParamType: TGUID; const Value: array of Byte); overload;\r\n    procedure Add(const ParamType: TGUID; var Value: Int16); overload;\r\n    procedure Add(const ParamType: TGUID; const Value: array of Int16); overload;\r\n    procedure Add(const ParamType: TGUID; var Value: Int32); overload;\r\n    procedure Add(const ParamType: TGUID; const Value: array of Int32); overload;\r\n    procedure Add(const ParamType: TGUID; var Value: Int64); overload;\r\n    procedure Add(const ParamType: TGUID; const Value: array of Int64); overload;\r\n    procedure Add(const ParamType: TGUID; const Value: String); overload;\r\n    procedure Add(const ParamType: TGUID; const Value: Byte;\r\n      const Undefined: Boolean); overload;\r\n    procedure Add(const ParamType: TGUID; const Value: array of Byte;\r\n      const Undefined: Boolean); overload;\r\n    procedure Add(const ParamType: TGUID; var Numerator, Denominator: Int32); overload;\r\n    procedure Add(const ParamType: TGUID; const Numerators,\r\n      Denominators: array of Int32); overload;\r\n    procedure Add(const ParamType: TGUID; var RangeBegin, RangeEnd: Int64); overload;\r\n    procedure Add(const ParamType: TGUID; const RangesBegin,\r\n      RangesEnd: array of Int64); overload;\r\n    procedure Add(const ParamType: TGUID; const NumberOfValues: Integer;\r\n      const ValueType: TGPEncoderParameterValueType; const Value: Pointer); overload;\r\n    procedure Add(const ParamType: TGUID; const Numerator1, Denominator1,\r\n      Numerator2, Denominator2: Int32); overload;\r\n    procedure Add(const ParamType: TGUID; const Numerator1, Denominator1,\r\n      Numerator2, Denominator2: array of Int32); overload;\r\n  private\r\n    constructor Create(const Params: PGPNativeEncoderParameters); overload;\r\n  public\r\n    constructor Create; overload;\r\n    destructor Destroy; override;\r\n  end;\r\n\r\n  IGPColorPalette = interface\r\n  ['{17D63D7E-20F6-445F-AEFC-3D53FC8D01CE}']\r\n    { Property access methods }\r\n    function GetFlags: TGPPaletteFlags;\r\n    procedure SetFlags(const Value: TGPPaletteFlags);\r\n    function GetCount: Integer;\r\n    function GetEntry(const Index: Integer): ARGB;\r\n    procedure SetEntry(const Index: Integer; const Value: ARGB);\r\n    function GetEntryPtr: PARGB;\r\n    function GetNativePalette: PGPNativeColorPalette;\r\n\r\n    { Properties }\r\n    property Flags: TGPPaletteFlags read GetFlags write SetFlags;\r\n    property Count: Integer read GetCount;\r\n    property Entries[const Index: Integer]: ARGB read GetEntry write SetEntry; default;\r\n    property EntryPtr: PARGB read GetEntryPtr;\r\n    property NativePalette: PGPNativeColorPalette read GetNativePalette;\r\n  end;\r\n\r\n  TGPColorPalette = class(TInterfacedObject, IGPColorPalette)\r\n  private\r\n    FData: PGPNativeColorPalette;\r\n    FEntries: PARGB;\r\n  private\r\n    { IGPColorPalette }\r\n    function GetFlags: TGPPaletteFlags;\r\n    procedure SetFlags(const Value: TGPPaletteFlags);\r\n    function GetCount: Integer;\r\n    function GetEntry(const Index: Integer): ARGB;\r\n    procedure SetEntry(const Index: Integer; const Value: ARGB);\r\n    function GetEntryPtr: PARGB;\r\n    function GetNativePalette: PGPNativeColorPalette;\r\n  private\r\n    constructor Create(const NativePalette: PGPNativeColorPalette); overload;\r\n  public\r\n    constructor Create(const Count: Integer); overload;\r\n    destructor Destroy; override;\r\n  end;\r\n\r\n  IGPPropertyItem = interface\r\n  ['{8886FE82-91E0-4069-B7BA-EA4A99E28AB4}']\r\n    { Property access methods }\r\n    function GetId: TPropID;\r\n    procedure SetId(const Value: TPropID);\r\n    function GetLength: Cardinal;\r\n    procedure SetLength(const Value: Cardinal);\r\n    function GetValueType: Word;\r\n    procedure SetValueType(const Value: Word);\r\n    function GetValue: Pointer;\r\n    procedure SetValue(const Value: Pointer);\r\n    function GetNativeItem: PGPNativePropertyItem;\r\n\r\n    { Properties }\r\n    property Id: TPropID read GetId write SetId;\r\n    property Length: Cardinal read GetLength write SetLength;\r\n    property ValueType: Word read GetValueType write SetValueType;\r\n    property Value: Pointer read GetValue write SetValue;\r\n    property NativeItem: PGPNativePropertyItem read GetNativeItem;\r\n  end;\r\n\r\n  TGPPropertyItem = class(TInterfacedObject, IGPPropertyItem)\r\n  private\r\n    FData: PGPNativePropertyItem;\r\n  private\r\n    { IGPPropertyItem }\r\n    function GetId: TPropID;\r\n    procedure SetId(const Value: TPropID);\r\n    function GetLength: Cardinal;\r\n    procedure SetLength(const Value: Cardinal);\r\n    function GetValueType: Word;\r\n    procedure SetValueType(const Value: Word);\r\n    function GetValue: Pointer;\r\n    procedure SetValue(const Value: Pointer);\r\n    function GetNativeItem: PGPNativePropertyItem;\r\n  private\r\n    constructor Create(const Data: PGPNativePropertyItem); overload;\r\n  public\r\n    constructor Create; overload;\r\n    destructor Destroy; override;\r\n  end;\r\n\r\n  IGPFrameDimensions = IGPArray;\r\n  IGPPropertyIdList = IGPArray;\r\n  IGPPropertyItems = IGPArray;\r\n\r\n  IGPImage = interface(IGdiPlusBase)\r\n  ['{9E494AC2-7002-41CD-9776-CA6B5A4E8426}']\r\n    { Property access methods }\r\n    function GetType: TGPImageType;\r\n    function GetWidth: Cardinal;\r\n    function GetHeight: Cardinal;\r\n    function GetHorizontalResolution: Single;\r\n    function GetVerticalResolution: Single;\r\n    function GetFlags: TGPImageFlags;\r\n    function GetRawFormat: TGUID;\r\n    function GetPixelFormat: TGPPixelFormat;\r\n    function GetPalette: IGPColorPalette;\r\n    procedure SetPalette(const Value: IGPColorPalette);\r\n    function GetPropertyIdList: IGPPropertyIdList;\r\n    function GetPropertyItems: IGPPropertyItems;\r\n\r\n    { Methods }\r\n    function Clone: IGPImage;\r\n    procedure Save(const Filename: String; const Format: IGPImageFormat;\r\n      const Params: IGPEncoderParameters = nil); overload;\r\n    procedure Save(const Filename: String; const Encoder: IGPImageCodecInfo;\r\n      const Params: IGPEncoderParameters = nil); overload;\r\n    procedure Save(const Stream: IStream; const Format: IGPImageFormat;\r\n      const Params: IGPEncoderParameters = nil); overload;\r\n    procedure Save(const Stream: IStream; const Encoder: IGPImageCodecInfo;\r\n      const Params: IGPEncoderParameters = nil); overload;\r\n    procedure SaveAdd(const Params: IGPEncoderParameters); overload;\r\n    procedure SaveAdd(const NewImage: IGPImage;\r\n      const Params: IGPEncoderParameters); overload;\r\n    procedure GetPhysicalDimension(out Size: TGPSizeF);\r\n    procedure GetBounds(out SrcRect: TGPRectF; out SrcUnit: TGPUnit);\r\n    function GetThumbnailImage(const ThumbWidth, ThumbHeight: Cardinal;\r\n      const Callback: TGPGetThumbnailImageAbort = nil;\r\n      const CallbackData: Pointer = nil): IGPImage;\r\n    function GetFrameDimensions: IGPFrameDimensions;\r\n    function GetFrameCount(const DimensionID: TGUID): Cardinal;\r\n    procedure SelectActiveFrame(const DimensionID: TGUID;\r\n      const FrameIndex: Cardinal);\r\n    procedure RotateFlip(const RotateFlipType: TGPRotateFlipType);\r\n    function GetPropertyItem(const PropId: TPropID): IGPPropertyItem;\r\n    procedure SetPropertyItem(const PropItem: IGPPropertyItem);\r\n    procedure RemovePropertyItem(const PropId: TPropID);\r\n    function GetEncoderParameterList(const lEncoder: TGUID): IGPEncoderParameters;\r\n    {$IF (GDIPVER >= $0110)}\r\n    procedure FindFirstItem(const Item: PGPImageItemData);\r\n    procedure FindNextItem(const Item: PGPImageItemData);\r\n    procedure GetItemData(const Item: PGPImageItemData);\r\n    procedure SetAbort(const Abort: TGdiplusAbort);\r\n    {$IFEND}\r\n\r\n    { Properties }\r\n    property ImageType: TGPImageType read GetType;\r\n    property Width: Cardinal read GetWidth;\r\n    property Height: Cardinal read GetHeight;\r\n    property HorizontalResolution: Single read GetHorizontalResolution;\r\n    property VerticalResolution: Single read GetVerticalResolution;\r\n    property Flags: TGPImageFlags read GetFlags;\r\n    property RawFormat: TGUID read GetRawFormat;\r\n    property PixelFormat: TGPPixelFormat read GetPixelFormat;\r\n    property Palette: IGPColorPalette read GetPalette write SetPalette;\r\n    property PropertyIdList: IGPPropertyIdList read GetPropertyIdList;\r\n    property PropertyItems: IGPPropertyItems read GetPropertyItems;\r\n  end;\r\n\r\n  TGPImage = class(TGdiplusBase, IGPImage)\r\n  private\r\n    { IGPImage }\r\n    function GetType: TGPImageType;\r\n    function GetWidth: Cardinal;\r\n    function GetHeight: Cardinal;\r\n    function GetHorizontalResolution: Single;\r\n    function GetVerticalResolution: Single;\r\n    function GetFlags: TGPImageFlags;\r\n    function GetRawFormat: TGUID;\r\n    function GetPixelFormat: TGPPixelFormat;\r\n    function GetPalette: IGPColorPalette;\r\n    procedure SetPalette(const Value: IGPColorPalette);\r\n    function GetPropertyIdList: IGPPropertyIdList;\r\n    function GetPropertyItems: IGPPropertyItems;\r\n\r\n    function Clone: IGPImage;\r\n    procedure Save(const Filename: String; const Format: IGPImageFormat;\r\n      const Params: IGPEncoderParameters = nil); overload;\r\n    procedure Save(const Filename: String; const Encoder: IGPImageCodecInfo;\r\n      const Params: IGPEncoderParameters = nil); overload;\r\n    procedure Save(const Stream: IStream; const Format: IGPImageFormat;\r\n      const Params: IGPEncoderParameters = nil); overload;\r\n    procedure Save(const Stream: IStream; const Encoder: IGPImageCodecInfo;\r\n      const Params: IGPEncoderParameters = nil); overload;\r\n    procedure SaveAdd(const Params: IGPEncoderParameters); overload;\r\n    procedure SaveAdd(const NewImage: IGPImage;\r\n      const Params: IGPEncoderParameters); overload;\r\n    procedure GetPhysicalDimension(out Size: TGPSizeF);\r\n    procedure GetBounds(out SrcRect: TGPRectF; out SrcUnit: TGPUnit);\r\n    function GetThumbnailImage(const ThumbWidth, ThumbHeight: Cardinal;\r\n      const Callback: TGPGetThumbnailImageAbort = nil;\r\n      const CallbackData: Pointer = nil): IGPImage;\r\n    function GetFrameDimensions: IGPFrameDimensions;\r\n    function GetFrameCount(const DimensionID: TGUID): Cardinal;\r\n    procedure SelectActiveFrame(const DimensionID: TGUID;\r\n      const FrameIndex: Cardinal);\r\n    procedure RotateFlip(const RotateFlipType: TGPRotateFlipType);\r\n    function GetPropertyItem(const PropId: TPropID): IGPPropertyItem;\r\n    procedure SetPropertyItem(const PropItem: IGPPropertyItem);\r\n    procedure RemovePropertyItem(const PropId: TPropID);\r\n    function GetEncoderParameterList(const lEncoder: TGUID): IGPEncoderParameters;\r\n    {$IF (GDIPVER >= $0110)}\r\n    procedure FindFirstItem(const Item: PGPImageItemData);\r\n    procedure FindNextItem(const Item: PGPImageItemData);\r\n    procedure GetItemData(const Item: PGPImageItemData);\r\n    procedure SetAbort(const Abort: TGdiplusAbort);\r\n    {$IFEND}\r\n  private\r\n    constructor Create(const NativeImage: GpImage); overload;\r\n  public\r\n    constructor Create(const Filename: String;\r\n      const UseEmbeddedColorManagement: Boolean = False); overload;\r\n    constructor Create(const Stream: IStream;\r\n      const UseEmbeddedColorManagement: Boolean = False); overload;\r\n    destructor Destroy; override;\r\n\r\n    class function FromFile(const Filename: String;\r\n      const UseEmbeddedColorManagement: Boolean = False): IGPImage; static;\r\n    class function FromStream(const Stream: IStream;\r\n      const UseEmbeddedColorManagement: Boolean = False): IGPImage; static;\r\n  end;\r\n\r\n  {$IF (GDIPVER >= $0110)}\r\n  IGPHistogram = interface\r\n  ['{4449210B-46EF-46B0-9458-CE3277CBBA67}']\r\n    { Property access methods }\r\n    function GetChannelCount: Integer;\r\n    function GetEntryCount: Integer;\r\n    function GetValue(const ChannelIndex, EntryIndex: Integer): Cardinal;\r\n    function GetChannel0(const Index: Integer): Cardinal;\r\n    function GetChannel1(const Index: Integer): Cardinal;\r\n    function GetChannel2(const Index: Integer): Cardinal;\r\n    function GetChannel3(const Index: Integer): Cardinal;\r\n    function GetValuePtr(const ChannelIndex: Integer): PCardinal;\r\n    function GetChannel0Ptr: PCardinal;\r\n    function GetChannel1Ptr: PCardinal;\r\n    function GetChannel2Ptr: PCardinal;\r\n    function GetChannel3Ptr: PCardinal;\r\n\r\n    { Properties }\r\n    property ChannelCount: Integer read GetChannelCount;\r\n    property EntryCount: Integer read GetEntryCount;\r\n    property Values[const ChannelIndex, EntryIndex: Integer]: Cardinal read GetValue; default;\r\n    property Channel0[const Index: Integer]: Cardinal read GetChannel0;\r\n    property Channel1[const Index: Integer]: Cardinal read GetChannel1;\r\n    property Channel2[const Index: Integer]: Cardinal read GetChannel2;\r\n    property Channel3[const Index: Integer]: Cardinal read GetChannel3;\r\n    property ValuePtr[const ChannelIndex: Integer]: PCardinal read GetValuePtr;\r\n    property Channel0Ptr: PCardinal read GetChannel0Ptr;\r\n    property Channel1Ptr: PCardinal read GetChannel1Ptr;\r\n    property Channel2Ptr: PCardinal read GetChannel2Ptr;\r\n    property Channel3Ptr: PCardinal read GetChannel3Ptr;\r\n  end;\r\n\r\n  TGPHistogram = class(TInterfacedObject, IGPHistogram)\r\n  private\r\n    FChannelCount: Integer;\r\n    FEntryCount: Integer;\r\n    FChannels: array [0..3] of PCardinal;\r\n  private\r\n    { IGPHistogram }\r\n    function GetChannelCount: Integer;\r\n    function GetEntryCount: Integer;\r\n    function GetValue(const ChannelIndex, EntryIndex: Integer): Cardinal;\r\n    function GetChannel0(const Index: Integer): Cardinal;\r\n    function GetChannel1(const Index: Integer): Cardinal;\r\n    function GetChannel2(const Index: Integer): Cardinal;\r\n    function GetChannel3(const Index: Integer): Cardinal;\r\n    function GetValuePtr(const ChannelIndex: Integer): PCardinal;\r\n    function GetChannel0Ptr: PCardinal;\r\n    function GetChannel1Ptr: PCardinal;\r\n    function GetChannel2Ptr: PCardinal;\r\n    function GetChannel3Ptr: PCardinal;\r\n  private\r\n    constructor Create(const AChannelCount, AEntryCount: Integer;\r\n      const AChannel0, AChannel1, AChannel2, AChannel3: PCardinal);\r\n  public\r\n    destructor Destroy; override;\r\n  end;\r\n  {$IFEND}\r\n\r\n  IGPBitmap = interface(IGPImage)\r\n  ['{704FC1E3-DAFC-4775-9BCB-D7D70741BB54}']\r\n    { Property access methods }\r\n    function GetPixel(const X, Y: Integer): TGPColor;\r\n    procedure SetPixel(const X, Y: Integer; const Value: TGPColor);\r\n\r\n    { Methods }\r\n    function Clone: IGPBitmap; overload;\r\n    function Clone(const Rect: TGPRect; const Format: TGPPixelFormat): IGPBitmap; overload;\r\n    function Clone(const X, Y, Width, Height: Integer; const Format: TGPPixelFormat): IGPBitmap; overload;\r\n    function Clone(const Rect: TGPRectF; const Format: TGPPixelFormat): IGPBitmap; overload;\r\n    function Clone(const X, Y, Width, Height: Single; const Format: TGPPixelFormat): IGPBitmap; overload;\r\n    function LockBits(const Rect: TGPRect; const Mode: TGPImageLockMode;\r\n      const Format: TGPPixelFormat): TGPBitmapData;\r\n    procedure UnlockBits(const LockedBitmapData: TGPBitmapData);\r\n    {$IF (GDIPVER >= $0110)}\r\n    procedure ConvertFormat(const Format: TGPPixelFormat;\r\n      const DitherType: TGPDitherType; const PaletteType: TGPPaletteType;\r\n      const Palette: IGPColorPalette = nil; const AlphaThresholdPercent: Single = 0);\r\n    procedure ApplyEffect(const Effect: IGPEffect; const ROI: Windows.PRect = nil);\r\n    function GetHistogram(const Format: TGPHistogramFormat): IGPHistogram;\r\n    {$IFEND}\r\n    procedure SetResolution(const XDpi, YDpi: Single);\r\n    function GetHBitmap(const ColorBackground: TGPColor): HBitmap;\r\n    function GetHIcon: HIcon;\r\n\r\n    { Properties }\r\n    property Pixels[const X, Y: Integer]: TGPColor read GetPixel write SetPixel; default;\r\n  end;\r\n\r\n  TGPBitmap = class(TGPImage, IGPBitmap)\r\n  private\r\n    { IGPBitmap }\r\n    function GetPixel(const X, Y: Integer): TGPColor;\r\n    procedure SetPixel(const X, Y: Integer; const Value: TGPColor);\r\n\r\n    function Clone: IGPBitmap; overload;\r\n    function Clone(const Rect: TGPRect; const Format: TGPPixelFormat): IGPBitmap; overload;\r\n    function Clone(const X, Y, Width, Height: Integer; const Format: TGPPixelFormat): IGPBitmap; overload;\r\n    function Clone(const Rect: TGPRectF; const Format: TGPPixelFormat): IGPBitmap; overload;\r\n    function Clone(const X, Y, Width, Height: Single; const Format: TGPPixelFormat): IGPBitmap; overload;\r\n    function LockBits(const Rect: TGPRect; const Mode: TGPImageLockMode;\r\n      const Format: TGPPixelFormat): TGPBitmapData;\r\n    procedure UnlockBits(const LockedBitmapData: TGPBitmapData);\r\n    {$IF (GDIPVER >= $0110)}\r\n    procedure ConvertFormat(const Format: TGPPixelFormat;\r\n      const DitherType: TGPDitherType; const PaletteType: TGPPaletteType;\r\n      const Palette: IGPColorPalette; const AlphaThresholdPercent: Single);\r\n    procedure ApplyEffect(const Effect: IGPEffect; const ROI: Windows.PRect); overload;\r\n    function GetHistogram(const Format: TGPHistogramFormat): IGPHistogram;\r\n    {$IFEND}\r\n    procedure SetResolution(const XDpi, YDpi: Single);\r\n    function GetHBitmap(const ColorBackground: TGPColor): HBitmap;\r\n    function GetHIcon: HIcon;\r\n  private\r\n    constructor Create(const NativeBitmap: GpBitmap); overload;\r\n  public\r\n    constructor Create(const Filename: String;\r\n      const UseEmbeddedColorManagement: Boolean = False); overload;\r\n    constructor Create(const Stream: IStream;\r\n      const UseEmbeddedColorManagement: Boolean = False); overload;\r\n    constructor Create(const Width, Height, Stride: Integer;\r\n      const Format: TGPPixelFormat; const Scan0: Pointer); overload;\r\n    constructor Create(const Width, Height: Integer;\r\n      const Format: TGPPixelFormat = PixelFormat32bppARGB); overload;\r\n    constructor Create(const Width, Height: Integer;\r\n      const Target: IGPGraphics); overload;\r\n    constructor Create(const DirectDrawSurface7: IUnknown); overload;\r\n    constructor Create(const BitmapInfo: TBitmapInfo;\r\n      const BitmapData: Pointer); overload;\r\n    constructor Create(const BitmapHandle: HBitmap;\r\n      const Palette: HPalette); overload;\r\n    constructor Create(const IconHandle: HIcon); overload;\r\n    constructor Create(const Instance: HInst; const BitmapName: String); overload;\r\n\r\n    class function FromFile(const Filename: String;\r\n      const UseEmbeddedColorManagement: Boolean = False): IGPBitmap; static;\r\n    class function FromStream(const Stream: IStream;\r\n      const UseEmbeddedColorManagement: Boolean = False): IGPBitmap; static;\r\n    class function FromDirectDrawSurface7(const Surface: IUnknown): IGPBitmap;\r\n    class function FromBitmapInfo(const BitmapInfo: TBitmapInfo;\r\n      const BitmapData: Pointer): IGPBitmap;\r\n    class function FromHBitmap(const BitmapHandle: HBitmap;\r\n      const Palette: HPalette): IGPBitmap;\r\n    class function FromHIcon(const IconHandle: HIcon): IGPBitmap;\r\n    class function FromResource(const Instance: HInst;\r\n      const BitmapName: String): IGPBitmap;\r\n\r\n    {$IF (GDIPVER >= $0110)}\r\n    class function InitializePalette(const ColorCount: Integer;\r\n      const PaletteType: TGPPaletteType; const OptimalColors: Integer;\r\n      const UseTransparentColor: Boolean; const Bitmap: IGPBitmap): IGPColorPalette; static;\r\n    class function ApplyEffect(const Inputs: array of IGPBitmap;\r\n      const Effect: IGPEffect; const ROI, OutputRect: Windows.PRect): IGPBitmap; overload;\r\n    {$IFEND}\r\n  end;\r\n\r\n{$ENDREGION 'GdiplusBitmap.h'}\r\n\r\n{$REGION 'GdiplusLineCaps.h'}\r\n(*****************************************************************************\r\n * GdiplusLineCaps.h\r\n * GDI+ CustomLineCap APIs\r\n *****************************************************************************)\r\n\r\n  IGPCustomLineCap = interface(IGdiPlusBase)\r\n  ['{6BF10928-312C-42F6-83DE-76D98FFFCD7B}']\r\n    { Property access methods }\r\n    function GetStrokeJoin: TGPLineJoin;\r\n    procedure SetStrokeJoin(const Value: TGPLineJoin);\r\n    function GetBaseCap: TGPLineCap;\r\n    procedure SetBaseCap(const Value: TGPLineCap);\r\n    function GetBaseInset: Single;\r\n    procedure SetBaseInset(const Value: Single);\r\n    function GetWidthScale: Single;\r\n    procedure SetWidthScale(const Value: Single);\r\n\r\n    { Methods }\r\n    function Clone: IGPCustomLineCap;\r\n    procedure SetStrokeCap(const StrokeCap: TGPLineCap);\r\n    procedure SetStrokeCaps(const StartCap, EndCap: TGPLineCap);\r\n    procedure GetStrokeCaps(out StartCap, EndCap: TGPLineCap);\r\n\r\n    { Properties }\r\n    property StrokeJoin: TGPLineJoin read GetStrokeJoin write SetStrokeJoin;\r\n    property BaseCap: TGPLineCap read GetBaseCap write SetBaseCap;\r\n    property BaseInset: Single read GetBaseInset write SetBaseInset;\r\n    property WidthScale: Single read GetWidthScale write SetWidthScale;\r\n  end;\r\n\r\n  TGPCustomLineCap = class(TGdiplusBase, IGPCustomLineCap)\r\n  private\r\n    { IGPCustomLineCap }\r\n    function GetStrokeJoin: TGPLineJoin;\r\n    procedure SetStrokeJoin(const Value: TGPLineJoin);\r\n    function GetBaseCap: TGPLineCap;\r\n    procedure SetBaseCap(const Value: TGPLineCap);\r\n    function GetBaseInset: Single;\r\n    procedure SetBaseInset(const Value: Single);\r\n    function GetWidthScale: Single;\r\n    procedure SetWidthScale(const Value: Single);\r\n\r\n    function Clone: IGPCustomLineCap;\r\n    procedure SetStrokeCap(const StrokeCap: TGPLineCap);\r\n    procedure SetStrokeCaps(const StartCap, EndCap: TGPLineCap);\r\n    procedure GetStrokeCaps(out StartCap, EndCap: TGPLineCap);\r\n  private\r\n    constructor Create(const NativeLineCap: GpCustomLineCap); overload;\r\n  public\r\n    constructor Create(const FillPath, StrokePath: IGPGraphicsPath;\r\n      const BaseCap: TGPLineCap = LineCapFlat; const BaseInset: Single = 0); overload;\r\n    destructor Destroy; override;\r\n  end;\r\n\r\n  IGPAdjustableArrowCap = interface(IGPCustomLineCap)\r\n  ['{25BE82E3-DF7F-4143-B5EA-3E535BDD3A86}']\r\n    { Property access methods }\r\n    function GetHeight: Single;\r\n    procedure SetHeight(const Value: Single);\r\n    function GetWidth: Single;\r\n    procedure SetWidth(const Value: Single);\r\n    function GetMiddleInset: Single;\r\n    procedure SetMiddleInset(const Value: Single);\r\n    function GetFilled: Boolean;\r\n    procedure SetFilled(const Value: Boolean);\r\n\r\n    { Properties }\r\n    property Height: Single read GetHeight write SetHeight;\r\n    property Width: Single read GetWidth write SetWidth;\r\n    property MiddleInset: Single read GetMiddleInset write SetMiddleInset;\r\n    property Filled: Boolean read GetFilled write SetFilled;\r\n  end;\r\n\r\n  TGPAdjustableArrowCap = class(TGPCustomLineCap, IGPAdjustableArrowCap)\r\n  private\r\n    { IGPAdjustableArrowCap }\r\n    function GetHeight: Single;\r\n    procedure SetHeight(const Value: Single);\r\n    function GetWidth: Single;\r\n    procedure SetWidth(const Value: Single);\r\n    function GetMiddleInset: Single;\r\n    procedure SetMiddleInset(const Value: Single);\r\n    function GetFilled: Boolean;\r\n    procedure SetFilled(const Value: Boolean);\r\n  public\r\n    constructor Create(const Height, Width: Single;\r\n      const IsFilled: Boolean = True); overload;\r\n  end;\r\n{$ENDREGION 'GdiplusLineCaps.h'}\r\n\r\n{$REGION 'GdiplusCachedBitmap.h'}\r\n(*****************************************************************************\r\n * GdiplusCachedBitmap.h\r\n * GDI+ CachedBitmap is a representation of an accelerated drawing\r\n * that has restrictions on what operations are allowed in order\r\n * to accelerate the drawing to the destination.\r\n *****************************************************************************)\r\n\r\n  IGPCachedBitmap = interface(IGdiPlusBase)\r\n  ['{1F77CA35-C917-4167-87CF-BF9DBB23FCAB}']\r\n  end;\r\n\r\n  TGPCachedBitmap = class(TGdiplusBase, IGPCachedBitmap)\r\n  public\r\n    constructor Create(const Bitmap: IGPBitmap; const Graphics: IGPGraphics); overload;\r\n    destructor Destroy; override;\r\n  end;\r\n\r\n{$ENDREGION 'GdiplusCachedBitmap.h'}\r\n\r\n{$REGION 'GdiplusMetafile.h'}\r\n(*****************************************************************************\r\n * GdiplusMetafile.h\r\n * GDI+ Metafile class\r\n *****************************************************************************)\r\n\r\n  IGPMetafile = interface(IGPImage)\r\n  ['{BBA510DD-1D60-4067-839C-C77733BCC2AB}']\r\n    { Property access methods }\r\n    function GetDownLevelRasterizationLimit: Cardinal;\r\n    procedure SetDownLevelRasterizationLimit(const Value: Cardinal);\r\n\r\n    { Methods }\r\n    function GetMetafileHeader: TGPMetafileHeader;\r\n    function GetHEnhMetafile: HEnhMetafile;\r\n    procedure PlayRecord(const RecordType: TEmfPlusRecordType;\r\n      const Flags, DataSize: Integer; const Data: Pointer);\r\n    {$IF (GDIPVER >= $0110)}\r\n    procedure ConvertToEmfPlus(const RefGraphics: IGPGraphics;\r\n      const ConversionFailureFlag: PInteger = nil;\r\n      const EmfType: TGPEmfType = EmfTypeEmfPlusOnly;\r\n      const Description: String = ''); overload;\r\n    procedure ConvertToEmfPlus(const RefGraphics: IGPGraphics;\r\n      const Filename: String; const ConversionFailureFlag: PInteger = nil;\r\n      const EmfType: TGPEmfType = EmfTypeEmfPlusOnly;\r\n      const Description: String = ''); overload;\r\n    procedure ConvertToEmfPlus(const RefGraphics: IGPGraphics;\r\n      const Stream: IStream; const ConversionFailureFlag: PInteger = nil;\r\n      const EmfType: TGPEmfType = EmfTypeEmfPlusOnly;\r\n      const Description: String = ''); overload;\r\n    {$IFEND}\r\n\r\n    { Properties }\r\n    property DownLevelRasterizationLimit: Cardinal read GetDownLevelRasterizationLimit write SetDownLevelRasterizationLimit;\r\n  end;\r\n\r\n  TGPMetafile = class(TGPImage, IGPMetafile)\r\n  private\r\n    { IGPMetafile }\r\n    function GetDownLevelRasterizationLimit: Cardinal;\r\n    procedure SetDownLevelRasterizationLimit(const Value: Cardinal);\r\n\r\n    function GetMetafileHeader: TGPMetafileHeader; overload;\r\n    function GetHEnhMetafile: HEnhMetafile;\r\n    procedure PlayRecord(const RecordType: TEmfPlusRecordType;\r\n      const Flags, DataSize: Integer; const Data: Pointer);\r\n    {$IF (GDIPVER >= $0110)}\r\n    procedure ConvertToEmfPlus(const RefGraphics: IGPGraphics;\r\n      const ConversionFailureFlag: PInteger = nil;\r\n      const EmfType: TGPEmfType = EmfTypeEmfPlusOnly;\r\n      const Description: String = ''); overload;\r\n    procedure ConvertToEmfPlus(const RefGraphics: IGPGraphics;\r\n      const Filename: String; const ConversionFailureFlag: PInteger = nil;\r\n      const EmfType: TGPEmfType = EmfTypeEmfPlusOnly;\r\n      const Description: String = ''); overload;\r\n    procedure ConvertToEmfPlus(const RefGraphics: IGPGraphics;\r\n      const Stream: IStream; const ConversionFailureFlag: PInteger = nil;\r\n      const EmfType: TGPEmfType = EmfTypeEmfPlusOnly;\r\n      const Description: String = ''); overload;\r\n    {$IFEND}\r\n  public\r\n    constructor Create(const Wmf: HMetafile;\r\n      const WmfPlaceableFileHeader: TWmfPlaceableFileHeader;\r\n      const DeleteWmf: Boolean = False); overload;\r\n    constructor Create(const Emf: HEnhMetafile; const DeleteEmf: Boolean = False); overload;\r\n    constructor Create(const Filename: String); overload;\r\n    constructor Create(const Filename: String;\r\n      const WmfPlaceableFileHeader: TWmfPlaceableFileHeader); overload;\r\n    constructor Create(const Stream: IStream); overload;\r\n    constructor Create(const ReferenceDC: HDC;\r\n      const EmfType: TGPEmfType = EmfTypeEmfPlusDual;\r\n      const Description: String = ''); overload;\r\n    constructor Create(const ReferenceDC: HDC; const FrameRect: TGPRectF;\r\n      const FrameUnit: TGPMetafileFrameUnit = MetafileFrameUnitGdi;\r\n      const EmfType: TGPEmfType = EmfTypeEmfPlusDual;\r\n      const Description: String = ''); overload;\r\n    constructor Create(const ReferenceDC: HDC; const FrameRect: TGPRect;\r\n      const FrameUnit: TGPMetafileFrameUnit = MetafileFrameUnitGdi;\r\n      const EmfType: TGPEmfType = EmfTypeEmfPlusDual;\r\n      const Description: String = ''); overload;\r\n    constructor Create(const Filename: String; const ReferenceDC: HDC;\r\n      const EmfType: TGPEmfType = EmfTypeEmfPlusDual;\r\n      const Description: String = ''); overload;\r\n    constructor Create(const Filename: String; const ReferenceDC: HDC;\r\n      const FrameRect: TGPRectF;\r\n      const FrameUnit: TGPMetafileFrameUnit = MetafileFrameUnitGdi;\r\n      const EmfType: TGPEmfType = EmfTypeEmfPlusDual;\r\n      const Description: String = ''); overload;\r\n    constructor Create(const Filename: String; const ReferenceDC: HDC;\r\n      const FrameRect: TGPRect;\r\n      const FrameUnit: TGPMetafileFrameUnit = MetafileFrameUnitGdi;\r\n      const EmfType: TGPEmfType = EmfTypeEmfPlusDual;\r\n      const Description: String = ''); overload;\r\n    constructor Create(const Stream: IStream; const ReferenceDC: HDC;\r\n      const EmfType: TGPEmfType = EmfTypeEmfPlusDual;\r\n      const Description: String = ''); overload;\r\n    constructor Create(const Stream: IStream; const ReferenceDC: HDC;\r\n      const FrameRect: TGPRectF;\r\n      const FrameUnit: TGPMetafileFrameUnit = MetafileFrameUnitGdi;\r\n      const EmfType: TGPEmfType = EmfTypeEmfPlusDual;\r\n      const Description: String = ''); overload;\r\n    constructor Create(const Stream: IStream; const ReferenceDC: HDC;\r\n      const FrameRect: TGPRect;\r\n      const FrameUnit: TGPMetafileFrameUnit = MetafileFrameUnitGdi;\r\n      const EmfType: TGPEmfType = EmfTypeEmfPlusDual;\r\n      const Description: String = ''); overload;\r\n\r\n    class function GetMetafileHeader(const Wmf: HMetafile;\r\n      const WmfPlaceableFileHeader: TWmfPlaceableFileHeader): TGPMetafileHeader; overload; static;\r\n    class function GetMetafileHeader(const Emf: HEnhMetafile): TGPMetafileHeader; overload; static;\r\n    class function GetMetafileHeader(const Filename: String): TGPMetafileHeader; overload; static;\r\n    class function GetMetafileHeader(const Stream: IStream): TGPMetafileHeader; overload; static;\r\n\r\n    class function EmfToWmfBits(const Emf: HEnhMetafile;\r\n      const MapMode: Integer = MM_ANISOTROPIC;\r\n      const Flags: TGPEmfToWmfBitsFlags = EmfToWmfBitsFlagsDefault): IGPBuffer;\r\n  end;\r\n\r\n{$ENDREGION 'GdiplusMetafile.h'}\r\n\r\n{$REGION 'GdiplusImageAttributes.h'}\r\n\r\n(*****************************************************************************\r\n * GdiplusImageAttributes.h\r\n * GDI+ Image Attributes used with Graphics.DrawImage\r\n *****************************************************************************)\r\n\r\n  IGPImageAttributes = interface(IGdiPlusBase)\r\n  ['{840C6292-E52C-4A2D-8444-CCE2A91DB701}']\r\n    { Methods }\r\n    function Clone: IGPImageAttributes;\r\n    procedure SetToIdentity(const AdjustType: TGPColorAdjustType = ColorAdjustTypeDefault);\r\n    procedure Reset(const AdjustType: TGPColorAdjustType = ColorAdjustTypeDefault);\r\n    procedure SetColorMatrix(const ColorMatrix: TGPColorMatrix;\r\n      const Mode: TGPColorMatrixFlags = ColorMatrixFlagsDefault;\r\n      const AdjustType: TGPColorAdjustType = ColorAdjustTypeDefault);\r\n    procedure ClearColorMatrix(const AdjustType: TGPColorAdjustType = ColorAdjustTypeDefault);\r\n    procedure SetColorMatrices(const ColorMatrix, GrayMatrix: TGPColorMatrix;\r\n      const Mode: TGPColorMatrixFlags = ColorMatrixFlagsDefault;\r\n      const AdjustType: TGPColorAdjustType = ColorAdjustTypeDefault);\r\n    procedure ClearColorMatrices(const AdjustType: TGPColorAdjustType = ColorAdjustTypeDefault);\r\n    procedure SetThreshold(const Threshold: Single;\r\n      const AdjustType: TGPColorAdjustType = ColorAdjustTypeDefault);\r\n    procedure ClearThreshold(const AdjustType: TGPColorAdjustType = ColorAdjustTypeDefault);\r\n    procedure SetGamma(const Gamma: Single;\r\n      const AdjustType: TGPColorAdjustType = ColorAdjustTypeDefault);\r\n    procedure ClearGamma(const AdjustType: TGPColorAdjustType = ColorAdjustTypeDefault);\r\n    procedure SetNoOp(const AdjustType: TGPColorAdjustType = ColorAdjustTypeDefault);\r\n    procedure ClearNoOp(const AdjustType: TGPColorAdjustType = ColorAdjustTypeDefault);\r\n    procedure SetColorKey(const ColorLow, ColorHigh: TGPColor;\r\n      const AdjustType: TGPColorAdjustType = ColorAdjustTypeDefault);\r\n    procedure ClearColorKey(const AdjustType: TGPColorAdjustType = ColorAdjustTypeDefault);\r\n    procedure SetOutputChannel(const ChannelFlags: TGPColorChannelFlags;\r\n      const AdjustType: TGPColorAdjustType = ColorAdjustTypeDefault);\r\n    procedure ClearOutputChannel(const AdjustType: TGPColorAdjustType = ColorAdjustTypeDefault);\r\n    procedure SetOutputChannelColorProfile(const ColorProfileFilename: String;\r\n      const AdjustType: TGPColorAdjustType = ColorAdjustTypeDefault);\r\n    procedure ClearOutputChannelColorProfile(\r\n      const AdjustType: TGPColorAdjustType = ColorAdjustTypeDefault);\r\n    procedure SetRemapTable(const Map: array of TGPColorMap;\r\n      const AdjustType: TGPColorAdjustType = ColorAdjustTypeDefault);\r\n    procedure ClearRemapTable(const AdjustType: TGPColorAdjustType = ColorAdjustTypeDefault);\r\n    procedure SetBrushRemapTable(const Map: array of TGPColorMap);\r\n    procedure ClearBrushRemapTable;\r\n    procedure SetWrapMode(const Wrap: TGPWrapMode;\r\n      const Color: TGPColor; const Clamp: Boolean = False); overload;\r\n    procedure SetWrapMode(const Wrap: TGPWrapMode); overload;\r\n    procedure GetAdjustedPalette(const ColorPalette: IGPColorPalette;\r\n      const ColorAdjustType: TGPColorAdjustType);\r\n  end;\r\n\r\n  TGPImageAttributes = class(TGdiplusBase, IGPImageAttributes)\r\n  private\r\n    { IGPImageAttributes }\r\n    function Clone: IGPImageAttributes;\r\n    procedure SetToIdentity(const AdjustType: TGPColorAdjustType = ColorAdjustTypeDefault);\r\n    procedure Reset(const AdjustType: TGPColorAdjustType = ColorAdjustTypeDefault);\r\n    procedure SetColorMatrix(const ColorMatrix: TGPColorMatrix;\r\n      const Mode: TGPColorMatrixFlags = ColorMatrixFlagsDefault;\r\n      const AdjustType: TGPColorAdjustType = ColorAdjustTypeDefault);\r\n    procedure ClearColorMatrix(const AdjustType: TGPColorAdjustType = ColorAdjustTypeDefault);\r\n    procedure SetColorMatrices(const ColorMatrix, GrayMatrix: TGPColorMatrix;\r\n      const Mode: TGPColorMatrixFlags = ColorMatrixFlagsDefault;\r\n      const AdjustType: TGPColorAdjustType = ColorAdjustTypeDefault);\r\n    procedure ClearColorMatrices(const AdjustType: TGPColorAdjustType = ColorAdjustTypeDefault);\r\n    procedure SetThreshold(const Threshold: Single;\r\n      const AdjustType: TGPColorAdjustType = ColorAdjustTypeDefault);\r\n    procedure ClearThreshold(const AdjustType: TGPColorAdjustType = ColorAdjustTypeDefault);\r\n    procedure SetGamma(const Gamma: Single;\r\n      const AdjustType: TGPColorAdjustType = ColorAdjustTypeDefault);\r\n    procedure ClearGamma(const AdjustType: TGPColorAdjustType = ColorAdjustTypeDefault);\r\n    procedure SetNoOp(const AdjustType: TGPColorAdjustType = ColorAdjustTypeDefault);\r\n    procedure ClearNoOp(const AdjustType: TGPColorAdjustType = ColorAdjustTypeDefault);\r\n    procedure SetColorKey(const ColorLow, ColorHigh: TGPColor;\r\n      const AdjustType: TGPColorAdjustType = ColorAdjustTypeDefault);\r\n    procedure ClearColorKey(const AdjustType: TGPColorAdjustType = ColorAdjustTypeDefault);\r\n    procedure SetOutputChannel(const ChannelFlags: TGPColorChannelFlags;\r\n      const AdjustType: TGPColorAdjustType = ColorAdjustTypeDefault);\r\n    procedure ClearOutputChannel(const AdjustType: TGPColorAdjustType = ColorAdjustTypeDefault);\r\n    procedure SetOutputChannelColorProfile(const ColorProfileFilename: String;\r\n      const AdjustType: TGPColorAdjustType = ColorAdjustTypeDefault);\r\n    procedure ClearOutputChannelColorProfile(\r\n      const AdjustType: TGPColorAdjustType = ColorAdjustTypeDefault);\r\n    procedure SetRemapTable(const Map: array of TGPColorMap;\r\n      const AdjustType: TGPColorAdjustType = ColorAdjustTypeDefault);\r\n    procedure ClearRemapTable(const AdjustType: TGPColorAdjustType = ColorAdjustTypeDefault);\r\n    procedure SetBrushRemapTable(const Map: array of TGPColorMap);\r\n    procedure ClearBrushRemapTable;\r\n    procedure SetWrapMode(const Wrap: TGPWrapMode;\r\n      const Color: TGPColor; const Clamp: Boolean = False); overload;\r\n    procedure SetWrapMode(const Wrap: TGPWrapMode); overload;\r\n    procedure GetAdjustedPalette(const ColorPalette: IGPColorPalette;\r\n      const ColorAdjustType: TGPColorAdjustType);\r\n  private\r\n    constructor Create(const NativeAttributes: GpImageAttributes); overload;\r\n  public\r\n    constructor Create; overload;\r\n    destructor Destroy; override;\r\n  end;\r\n\r\n{$ENDREGION 'GdiplusImageAttributes.h'}\r\n\r\n{$REGION 'GdiplusMatrix.h'}\r\n\r\n(*****************************************************************************\r\n * GdiplusMatrix.h\r\n * GDI+ Matrix class\r\n *****************************************************************************)\r\n\r\n  TGPMatrixElements = record\r\n    case Integer of\r\n      0: (M: array [0..5] of Single);\r\n      1: (M11: Single;\r\n          M12: Single;\r\n          M21: Single;\r\n          M22: Single;\r\n          DX : Single;\r\n          DY : Single);\r\n  end;\r\n\r\n  TGPPlgPointsF = array [0..2] of TGPPointF;\r\n  TGPPlgPoints = array [0..2] of TGPPoint;\r\n\r\n  IGPMatrix = interface(IGdiPlusBase)\r\n  ['{2B5AA3D4-F4AA-436D-AB48-18321613FF99}']\r\n    { Property access methods }\r\n    function GetElements: TGPMatrixElements;\r\n    procedure SetElements(const Value: TGPMatrixElements); overload;\r\n    function GetOffsetX: Single;\r\n    function GetOffsetY: Single;\r\n    function GetIsInvertible: Boolean;\r\n    function GetIsIdentity: Boolean;\r\n\r\n    { Methods }\r\n    function Clone: IGPMatrix;\r\n    procedure Reset;\r\n    procedure SetElements(const M11, M12, M21, M22, DX, DY: Single); overload;\r\n    procedure Multiply(const Matrix: IGPMatrix;\r\n      const Order: TGPMatrixOrder = MatrixOrderPrepend);\r\n    procedure Translate(const OffsetX, OffsetY: Single;\r\n      const Order: TGPMatrixOrder = MatrixOrderPrepend);\r\n    procedure Scale(const ScaleX, ScaleY: Single;\r\n      const Order: TGPMatrixOrder = MatrixOrderPrepend);\r\n    procedure Rotate(const Angle: Single;\r\n      const Order: TGPMatrixOrder = MatrixOrderPrepend);\r\n    procedure RotateAt(const Angle: Single; const Center: TGPPointF;\r\n      const Order: TGPMatrixOrder = MatrixOrderPrepend);\r\n    procedure Shear(const ShearX, ShearY: Single;\r\n      const Order: TGPMatrixOrder = MatrixOrderPrepend);\r\n    procedure Invert;\r\n    procedure TransformPoint(var Point: TGPPointF); overload;\r\n    procedure TransformPoint(var Point: TGPPoint); overload;\r\n    procedure TransformPoints(const Points: array of TGPPointF); overload;\r\n    procedure TransformPoints(const Points: array of TGPPoint); overload;\r\n    procedure TransformVector(var Point: TGPPointF); overload;\r\n    procedure TransformVector(var Point: TGPPoint); overload;\r\n    procedure TransformVectors(const Points: array of TGPPointF); overload;\r\n    procedure TransformVectors(const Points: array of TGPPoint); overload;\r\n    function Equals(const Matrix: IGPMatrix): Boolean;\r\n\r\n    { Properties }\r\n    property Elements: TGPMatrixElements read GetElements write SetElements;\r\n    property OffsetX: Single read GetOffsetX;\r\n    property OffsetY: Single read GetOffsetY;\r\n    property IsInvertible: Boolean read GetIsInvertible;\r\n    property IsIdentity: Boolean read GetIsIdentity;\r\n  end;\r\n\r\n  TGPMatrix = class(TGdiplusBase, IGPMatrix)\r\n  private\r\n    { IGPMatrix }\r\n    function GetElements: TGPMatrixElements;\r\n    procedure SetElements(const Value: TGPMatrixElements); overload;\r\n    function GetOffsetX: Single;\r\n    function GetOffsetY: Single;\r\n    function GetIsInvertible: Boolean;\r\n    function GetIsIdentity: Boolean;\r\n\r\n    function Clone: IGPMatrix;\r\n    procedure Reset;\r\n    procedure SetElements(const M11, M12, M21, M22, DX, DY: Single); overload;\r\n    procedure Multiply(const Matrix: IGPMatrix;\r\n      const Order: TGPMatrixOrder = MatrixOrderPrepend);\r\n    procedure Translate(const OffsetX, OffsetY: Single;\r\n      const Order: TGPMatrixOrder = MatrixOrderPrepend);\r\n    procedure Scale(const ScaleX, ScaleY: Single;\r\n      const Order: TGPMatrixOrder = MatrixOrderPrepend);\r\n    procedure Rotate(const Angle: Single;\r\n      const Order: TGPMatrixOrder = MatrixOrderPrepend);\r\n    procedure RotateAt(const Angle: Single; const Center: TGPPointF;\r\n      const Order: TGPMatrixOrder = MatrixOrderPrepend);\r\n    procedure Shear(const ShearX, ShearY: Single;\r\n      const Order: TGPMatrixOrder = MatrixOrderPrepend);\r\n    procedure Invert;\r\n    procedure TransformPoint(var Point: TGPPointF); overload;\r\n    procedure TransformPoint(var Point: TGPPoint); overload;\r\n    procedure TransformPoints(const Points: array of TGPPointF); overload;\r\n    procedure TransformPoints(const Points: array of TGPPoint); overload;\r\n    procedure TransformVector(var Point: TGPPointF); overload;\r\n    procedure TransformVector(var Point: TGPPoint); overload;\r\n    procedure TransformVectors(const Points: array of TGPPointF); overload;\r\n    procedure TransformVectors(const Points: array of TGPPoint); overload;\r\n    function Equals(const Matrix: IGPMatrix): Boolean; reintroduce;\r\n  private\r\n    constructor Create(const NativeMatrix: GpMatrix); overload;\r\n  public\r\n    constructor Create; overload;\r\n    constructor Create(const M11, M12, M21, M22, DX, DY: Single); overload;\r\n    constructor Create(const Rect: TGPRectF; const DstPlg: TGPPlgPointsF); overload;\r\n    constructor Create(const Rect: TGPRect; const DstPlg: TGPPlgPoints); overload;\r\n    destructor Destroy; override;\r\n  end;\r\n{$ENDREGION 'GdiplusMatrix.h'}\r\n\r\n{$REGION 'GdiplusBrush.h'}\r\n\r\n(*****************************************************************************\r\n * GdiplusBrush.h\r\n * GDI+ Brush class\r\n *****************************************************************************)\r\n  IGPBrush = interface(IGdiPlusBase)\r\n  ['{E0A8536C-D389-43E9-984F-B6DB6B1AFBF2}']\r\n    { Property access methods }\r\n    function GetType: TGPBrushType;\r\n\r\n    { Methods }\r\n    function Clone: IGPBrush;\r\n\r\n    { Properties }\r\n    property BrushType: TGPBrushType read GetType;\r\n  end;\r\n\r\n  TGPBrush = class abstract(TGdiplusBase, IGPBrush)\r\n  private\r\n    { IGPBrush }\r\n    function GetType: TGPBrushType;\r\n    function Clone: IGPBrush;\r\n  private\r\n    constructor Create; overload;\r\n    constructor Create(const NativeBrush: GpBrush); overload;\r\n  public\r\n    destructor Destroy; override;\r\n  end;\r\n\r\n  IGPSolidBrush = interface(IGPBrush)\r\n  ['{5DC6D20E-74C1-48B8-83A1-00D213827298}']\r\n    { Property access methods }\r\n    function GetColor: TGPColor;\r\n    procedure SetColor(const Value: TGPColor);\r\n\r\n    { Properties }\r\n    property Color: TGPColor read GetColor write SetColor;\r\n  end;\r\n\r\n  TGPSolidBrush = class(TGPBrush, IGPSolidBrush)\r\n  private\r\n    { IGPSolidBrush }\r\n    function GetColor: TGPColor;\r\n    procedure SetColor(const Value: TGPColor);\r\n  private\r\n    constructor Create; overload;\r\n  public\r\n    constructor Create(const Color: TGPColor); overload;\r\n  end;\r\n\r\n  IGPTextureBrush = interface(IGPBrush)\r\n  ['{37076023-1AE9-4F95-BB6C-D09C4E647AC2}']\r\n    { Property access methods }\r\n    function GetTransform: IGPMatrix;\r\n    procedure SetTransform(const Value: IGPMatrix);\r\n    function GetWrapMode: TGPWrapMode;\r\n    procedure SetWrapMode(const Value: TGPWrapMode);\r\n    function GetImage: IGPImage;\r\n\r\n    { Methods }\r\n    procedure ResetTransform;\r\n    procedure MultiplyTransform(const Matrix: IGPMatrix;\r\n      const Order: TGPMatrixOrder = MatrixOrderPrepend);\r\n    procedure TranslateTransform(const DX, DY: Single;\r\n      const Order: TGPMatrixOrder = MatrixOrderPrepend);\r\n    procedure ScaleTransform(const SX, SY: Single;\r\n      const Order: TGPMatrixOrder = MatrixOrderPrepend);\r\n    procedure RotateTransform(const Angle: Single;\r\n      const Order: TGPMatrixOrder = MatrixOrderPrepend);\r\n\r\n    { Properties }\r\n    property Transform: IGPMatrix read GetTransform write SetTransform;\r\n    property WrapMode: TGPWrapMode read GetWrapMode write SetWrapMode;\r\n    property Image: IGPImage read GetImage;\r\n  end;\r\n\r\n  TGPTextureBrush = class(TGPBrush, IGPTextureBrush)\r\n  private\r\n    { IGPTextureBrush }\r\n    function GetTransform: IGPMatrix;\r\n    procedure SetTransform(const Value: IGPMatrix);\r\n    function GetWrapMode: TGPWrapMode;\r\n    procedure SetWrapMode(const Value: TGPWrapMode);\r\n    function GetImage: IGPImage;\r\n\r\n    procedure ResetTransform;\r\n    procedure MultiplyTransform(const Matrix: IGPMatrix;\r\n      const Order: TGPMatrixOrder = MatrixOrderPrepend);\r\n    procedure TranslateTransform(const DX, DY: Single;\r\n      const Order: TGPMatrixOrder = MatrixOrderPrepend);\r\n    procedure ScaleTransform(const SX, SY: Single;\r\n      const Order: TGPMatrixOrder = MatrixOrderPrepend);\r\n    procedure RotateTransform(const Angle: Single;\r\n      const Order: TGPMatrixOrder = MatrixOrderPrepend);\r\n  private\r\n    constructor Create; overload;\r\n  public\r\n    constructor Create(const Image: IGPImage;\r\n      const WrapMode: TGPWrapMode = WrapModeTile); overload;\r\n    constructor Create(const Image: IGPImage;\r\n      const WrapMode: TGPWrapMode; const DstRect: TGPRectF); overload;\r\n    constructor Create(const Image: IGPImage;\r\n      const WrapMode: TGPWrapMode; const DstRect: TGPRect); overload;\r\n    constructor Create(const Image: IGPImage; const DstRect: TGPRectF;\r\n      const ImageAttributes: IGPImageAttributes = nil); overload;\r\n    constructor Create(const Image: IGPImage; const DstRect: TGPRect;\r\n      const ImageAttributes: IGPImageAttributes = nil); overload;\r\n    constructor Create(const Image: IGPImage;\r\n      const WrapMode: TGPWrapMode; const DstX, DstY, DstWidth, DstHeight: Single); overload;\r\n    constructor Create(const Image: IGPImage;\r\n      const WrapMode: TGPWrapMode; const DstX, DstY, DstWidth, DstHeight: Integer); overload;\r\n  end;\r\n\r\n  TGPLinearColors = array [0..1] of TGPColor;\r\n\r\n  IGPBlend = interface\r\n  ['{497DDA96-3962-4037-B5D4-089D0C463378}']\r\n    { Property access methods }\r\n    function GetCount: Integer;\r\n    function GetFactor(const Index: Integer): Single;\r\n    procedure SetFactor(const Index: Integer; const Value: Single);\r\n    function GetPosition(const Index: Integer): Single;\r\n    procedure SetPosition(const Index: Integer; const Value: Single);\r\n    function GetFactorPtr: PSingle;\r\n    function GetPositionPtr: PSingle;\r\n\r\n    { Properties }\r\n    property Count: Integer read GetCount;\r\n    property Factors[const Index: Integer]: Single read GetFactor write SetFactor;\r\n    property Positions[const Index: Integer]: Single read GetPosition write SetPosition;\r\n    property FactorPtr: PSingle read GetFactorPtr;\r\n    property PositionPtr: PSingle read GetPositionPtr;\r\n  end;\r\n\r\n  TGPBlend = class(TInterfacedObject, IGPBlend)\r\n  private\r\n    FFactors: array of Single;\r\n    FPositions: array of Single;\r\n  private\r\n    { IGPBlend }\r\n    function GetCount: Integer;\r\n    function GetFactor(const Index: Integer): Single;\r\n    procedure SetFactor(const Index: Integer; const Value: Single);\r\n    function GetPosition(const Index: Integer): Single;\r\n    procedure SetPosition(const Index: Integer; const Value: Single);\r\n    function GetFactorPtr: PSingle;\r\n    function GetPositionPtr: PSingle;\r\n  private\r\n    constructor Create(const ACount: Integer); overload;\r\n  public\r\n    constructor Create(const AFactors, APositions: array of Single); overload;\r\n  end;\r\n\r\n  IGPColorBlend = interface\r\n  ['{5F3C0BE0-BFED-4275-A21B-7FF97687F271}']\r\n    { Property access methods }\r\n    function GetCount: Integer;\r\n    function GetColor(const Index: Integer): TGPColor;\r\n    procedure SetColor(const Index: Integer; const Value: TGPColor);\r\n    function GetPosition(const Index: Integer): Single;\r\n    procedure SetPosition(const Index: Integer; const Value: Single);\r\n    function GetColorPtr: PGPColor;\r\n    function GetPositionPtr: PSingle;\r\n\r\n    { Properties }\r\n    property Count: Integer read GetCount;\r\n    property Colors[const Index: Integer]: TGPColor read GetColor write SetColor;\r\n    property Positions[const Index: Integer]: Single read GetPosition write SetPosition;\r\n    property ColorPtr: PGPColor read GetColorPtr;\r\n    property PositionPtr: PSingle read GetPositionPtr;\r\n  end;\r\n\r\n  TGPColorBlend = class(TInterfacedObject, IGPColorBlend)\r\n  private\r\n    FColors: array of TGPColor;\r\n    FPositions: array of Single;\r\n  private\r\n    { IGPColorBlend }\r\n    function GetCount: Integer;\r\n    function GetColor(const Index: Integer): TGPColor;\r\n    procedure SetColor(const Index: Integer; const Value: TGPColor);\r\n    function GetPosition(const Index: Integer): Single;\r\n    procedure SetPosition(const Index: Integer; const Value: Single);\r\n    function GetColorPtr: PGPColor;\r\n    function GetPositionPtr: PSingle;\r\n  private\r\n    constructor Create(const ACount: Integer); overload;\r\n  public\r\n    constructor Create(const AColors: array of TGPColor;\r\n      const APositions: array of Single); overload;\r\n  end;\r\n\r\n  IGPLinearGradientBrush = interface(IGPBrush)\r\n  ['{85ECE5BB-FE0F-4CD9-9094-6608696C8475}']\r\n    { Property access methods }\r\n    function GetLinearColors: TGPLinearColors;\r\n    procedure SetLinearColors(const Value: TGPLinearColors);\r\n    function GetRectangle: TGPRectF; overload;\r\n    function GetGammaCorrection: Boolean;\r\n    procedure SetGammaCorrection(const Value: Boolean);\r\n    function GetBlend: IGPBlend;\r\n    procedure SetBlend(const Value: IGPBlend);\r\n    function GetInterpolationColors: IGPColorBlend;\r\n    procedure SetInterpolationColors(const Value: IGPColorBlend);\r\n    function GetTransform: IGPMatrix;\r\n    procedure SetTransform(const Value: IGPMatrix);\r\n    function GetWrapMode: TGPWrapMode;\r\n    procedure SetWrapMode(const Value: TGPWrapMode);\r\n\r\n    { Methods }\r\n    procedure GetRectangle(out Rect: TGPRectF); overload;\r\n    procedure GetRectangle(out Rect: TGPRect); overload;\r\n    procedure SetBlendBellShape(const Focus: Single; const Scale: Single = 1);\r\n    procedure SetBlendTriangularShape(const Focus: Single; const Scale: Single = 1);\r\n    procedure ResetTransform;\r\n    procedure MultiplyTransform(const Matrix: IGPMatrix;\r\n      const Order: TGPMatrixOrder = MatrixOrderPrepend);\r\n    procedure TranslateTransform(const DX, DY: Single;\r\n      const Order: TGPMatrixOrder = MatrixOrderPrepend);\r\n    procedure ScaleTransform(const SX, SY: Single;\r\n      const Order: TGPMatrixOrder = MatrixOrderPrepend);\r\n    procedure RotateTransform(const Angle: Single;\r\n      const Order: TGPMatrixOrder = MatrixOrderPrepend);\r\n\r\n    { Properties }\r\n    property LinearColors: TGPLinearColors read GetLinearColors write SetLinearColors;\r\n    property Rectangle: TGPRectF read GetRectangle;\r\n    property GammaCorrection: Boolean read GetGammaCorrection write SetGammaCorrection;\r\n    property Blend: IGPBlend read GetBlend write SetBlend;\r\n    property InterpolationColors: IGPColorBlend read GetInterpolationColors write SetInterpolationColors;\r\n    property Transform: IGPMatrix read GetTransform write SetTransform;\r\n    property WrapMode: TGPWrapMode read GetWrapMode write SetWrapMode;\r\n  end;\r\n\r\n  TGPLinearGradientBrush = class(TGPBrush, IGPLinearGradientBrush)\r\n  private\r\n    { IGPLinearGradientBrush }\r\n    function GetLinearColors: TGPLinearColors;\r\n    procedure SetLinearColors(const Value: TGPLinearColors);\r\n    function GetRectangle: TGPRectF; overload;\r\n    function GetGammaCorrection: Boolean;\r\n    procedure SetGammaCorrection(const Value: Boolean);\r\n    function GetBlend: IGPBlend;\r\n    procedure SetBlend(const Value: IGPBlend);\r\n    function GetInterpolationColors: IGPColorBlend;\r\n    procedure SetInterpolationColors(const Value: IGPColorBlend);\r\n    function GetTransform: IGPMatrix;\r\n    procedure SetTransform(const Value: IGPMatrix);\r\n    function GetWrapMode: TGPWrapMode;\r\n    procedure SetWrapMode(const Value: TGPWrapMode);\r\n\r\n    procedure GetRectangle(out Rect: TGPRectF); overload;\r\n    procedure GetRectangle(out Rect: TGPRect); overload;\r\n    procedure SetBlendBellShape(const Focus: Single; const Scale: Single = 1);\r\n    procedure SetBlendTriangularShape(const Focus: Single; const Scale: Single = 1);\r\n    procedure ResetTransform;\r\n    procedure MultiplyTransform(const Matrix: IGPMatrix;\r\n      const Order: TGPMatrixOrder = MatrixOrderPrepend);\r\n    procedure TranslateTransform(const DX, DY: Single;\r\n      const Order: TGPMatrixOrder = MatrixOrderPrepend);\r\n    procedure ScaleTransform(const SX, SY: Single;\r\n      const Order: TGPMatrixOrder = MatrixOrderPrepend);\r\n    procedure RotateTransform(const Angle: Single;\r\n      const Order: TGPMatrixOrder = MatrixOrderPrepend);\r\n  private\r\n    constructor Create; overload;\r\n  public\r\n    constructor Create(const Point1, Point2: TGPPointF;\r\n      const Color1, Color2: TGPColor); overload;\r\n    constructor Create(const Point1, Point2: TGPPoint;\r\n      const Color1, Color2: TGPColor); overload;\r\n    constructor Create(const Rect: TGPRectF; const Color1, Color2: TGPColor;\r\n      const Mode: TGPLinearGradientMode); overload;\r\n    constructor Create(const Rect: TGPRect; const Color1, Color2: TGPColor;\r\n      const Mode: TGPLinearGradientMode); overload;\r\n    constructor Create(const Rect: TGPRectF; const Color1, Color2: TGPColor;\r\n      const Angle: Single; const IsAngleScalable: Boolean = False); overload;\r\n    constructor Create(const Rect: TGPRect; const Color1, Color2: TGPColor;\r\n      const Angle: Single; const IsAngleScalable: Boolean = False); overload;\r\n  end;\r\n\r\n  IGPHatchBrush = interface(IGPBrush)\r\n  ['{5EED3025-99F4-435D-A854-FDF2B0A08FBD}']\r\n    { Property access methods }\r\n    function GetHatchStyle: TGPHatchStyle;\r\n    function GetForegroundColor: TGPColor;\r\n    function GetBackgroundColor: TGPColor;\r\n\r\n    { Properties }\r\n    property HatchStyle: TGPHatchStyle read GetHatchStyle;\r\n    property ForegroundColor: TGPColor read GetForegroundColor;\r\n    property BackgroundColor: TGPColor read GetBackgroundColor;\r\n  end;\r\n\r\n  TGPHatchBrush = class(TGPBrush, IGPHatchBrush)\r\n  private\r\n    { IGPHatchBrush }\r\n    function GetHatchStyle: TGPHatchStyle;\r\n    function GetForegroundColor: TGPColor;\r\n    function GetBackgroundColor: TGPColor;\r\n  private\r\n    constructor Create; overload;\r\n  public\r\n    constructor Create(const HatchStyle: TGPHatchStyle; const ForeColor,\r\n      BackColor: TGPColor); overload;\r\n    constructor Create(const HatchStyle: TGPHatchStyle; const ForeColor: TGPColor); overload;\r\n  end;\r\n\r\n{$ENDREGION 'GdiplusBrush.h'}\r\n\r\n{$REGION 'GdiplusPen.h'}\r\n\r\n(*****************************************************************************\r\n * GdiplusPen.h\r\n * GDI+ Pen class\r\n *****************************************************************************)\r\n\r\n  IGPDashPattern = IGPArray;\r\n  IGPCompoundArray = IGPArray;\r\n\r\n  IGPPen = interface(IGdiPlusBase)\r\n  ['{5F88EBBC-6104-44AC-BDCE-691DBEF21607}']\r\n    { Property access methods }\r\n    function GetWidth: Single;\r\n    procedure SetWidth(const Value: Single);\r\n    function GetStartCap: TGPLineCap;\r\n    procedure SetStartCap(const Value: TGPLineCap);\r\n    function GetEndCap: TGPLineCap;\r\n    procedure SetEndCap(const Value: TGPLineCap);\r\n    function GetDashCap: TGPDashCap;\r\n    procedure SetDashCap(const Value: TGPDashCap);\r\n    function GetLineJoin: TGPLineJoin;\r\n    procedure SetLineJoin(const Value: TGPLineJoin);\r\n    function GetCustomStartCap: IGPCustomLineCap;\r\n    procedure SetCustomStartCap(const Value: IGPCustomLineCap);\r\n    function GetCustomEndCap: IGPCustomLineCap;\r\n    procedure SetCustomEndCap(const Value: IGPCustomLineCap);\r\n    function GetMiterLimit: Single;\r\n    procedure SetMiterLimit(const Value: Single);\r\n    function GetAlignment: TGPPenAlignment;\r\n    procedure SetAlignment(const Value: TGPPenAlignment);\r\n    function GetTransform: IGPMatrix;\r\n    procedure SetTransform(const Value: IGPMatrix);\r\n    function GetPenType: TGPPenType;\r\n    function GetColor: TGPColor;\r\n    procedure SetColor(const Value: TGPColor);\r\n    function GetBrush: IGPBrush;\r\n    procedure SetBrush(const Value: IGPBrush);\r\n    function GetDashStyle: TGPDashStyle;\r\n    procedure SetDashStyle(const Value: TGPDashStyle);\r\n    function GetDashOffset: Single;\r\n    procedure SetDashOffset(const Value: Single);\r\n    function GetDashPattern: IGPDashPattern;\r\n    procedure SetDashPatternInternal(const Value: IGPDashPattern);\r\n    function GetCompoundArray: IGPCompoundArray;\r\n    procedure SetCompoundArray(const Value: IGPCompoundArray);\r\n\r\n    { Methods }\r\n    function Clone: IGPPen;\r\n    procedure SetLineCap(const StartCap, EndCap: TGPLineCap;\r\n      const DashCap: TGPDashCap);\r\n    procedure ResetTransform;\r\n    procedure MultiplyTransform(const Matrix: IGPMatrix;\r\n      const Order: TGPMatrixOrder = MatrixOrderPrepend);\r\n    procedure TranslateTransform(const DX, DY: Single;\r\n      const Order: TGPMatrixOrder = MatrixOrderPrepend);\r\n    procedure ScaleTransform(const SX, SY: Single;\r\n      const Order: TGPMatrixOrder = MatrixOrderPrepend);\r\n    procedure RotateTransform(const Angle: Single;\r\n      const Order: TGPMatrixOrder = MatrixOrderPrepend);\r\n    procedure SetDashPattern(const Pattern: array of Single);\r\n\r\n    { Properties }\r\n    property Width: Single read GetWidth write SetWidth;\r\n    property StartCap: TGPLineCap read GetStartCap write SetStartCap;\r\n    property EndCap: TGPLineCap read GetEndCap write SetEndCap;\r\n    property DashCap: TGPDashCap read GetDashCap write SetDashCap;\r\n    property LineJoin: TGPLineJoin read GetLineJoin write SetLineJoin;\r\n    property CustomStartCap: IGPCustomLineCap read GetCustomStartCap write SetCustomStartCap;\r\n    property CustomEndCap: IGPCustomLineCap read GetCustomEndCap write SetCustomEndCap;\r\n    property MiterLimit: Single read GetMiterLimit write SetMiterLimit;\r\n    property Alignment: TGPPenAlignment read GetAlignment write SetAlignment;\r\n    property Transform: IGPMatrix read GetTransform write SetTransform;\r\n    property PenType: TGPPenType read GetPenType;\r\n    property Color: TGPColor read GetColor write SetColor;\r\n    property Brush: IGPBrush read GetBrush write SetBrush;\r\n    property DashStyle: TGPDashStyle read GetDashStyle write SetDashStyle;\r\n    property DashOffset: Single read GetDashOffset write SetDashOffset;\r\n    property DashPattern: IGPDashPattern read GetDashPattern write SetDashPatternInternal;\r\n    property CompoundArray: IGPCompoundArray read GetCompoundArray write SetCompoundArray;\r\n  end;\r\n\r\n  TGPPen = class(TGdiplusBase, IGPPen)\r\n  private\r\n    { IGPPen }\r\n    function GetWidth: Single;\r\n    procedure SetWidth(const Value: Single);\r\n    function GetStartCap: TGPLineCap;\r\n    procedure SetStartCap(const Value: TGPLineCap);\r\n    function GetEndCap: TGPLineCap;\r\n    procedure SetEndCap(const Value: TGPLineCap);\r\n    function GetDashCap: TGPDashCap;\r\n    procedure SetDashCap(const Value: TGPDashCap);\r\n    function GetLineJoin: TGPLineJoin;\r\n    procedure SetLineJoin(const Value: TGPLineJoin);\r\n    function GetCustomStartCap: IGPCustomLineCap;\r\n    procedure SetCustomStartCap(const Value: IGPCustomLineCap);\r\n    function GetCustomEndCap: IGPCustomLineCap;\r\n    procedure SetCustomEndCap(const Value: IGPCustomLineCap);\r\n    function GetMiterLimit: Single;\r\n    procedure SetMiterLimit(const Value: Single);\r\n    function GetAlignment: TGPPenAlignment;\r\n    procedure SetAlignment(const Value: TGPPenAlignment);\r\n    function GetTransform: IGPMatrix;\r\n    procedure SetTransform(const Value: IGPMatrix);\r\n    function GetPenType: TGPPenType;\r\n    function GetColor: TGPColor;\r\n    procedure SetColor(const Value: TGPColor);\r\n    function GetBrush: IGPBrush;\r\n    procedure SetBrush(const Value: IGPBrush);\r\n    function GetDashStyle: TGPDashStyle;\r\n    procedure SetDashStyle(const Value: TGPDashStyle);\r\n    function GetDashOffset: Single;\r\n    procedure SetDashOffset(const Value: Single);\r\n    function GetDashPattern: IGPDashPattern;\r\n    procedure SetDashPatternInternal(const Value: IGPDashPattern);\r\n    function GetCompoundArray: IGPCompoundArray;\r\n    procedure SetCompoundArray(const Value: IGPCompoundArray);\r\n\r\n    function Clone: IGPPen;\r\n    procedure SetLineCap(const StartCap, EndCap: TGPLineCap;\r\n      const DashCap: TGPDashCap);\r\n    procedure ResetTransform;\r\n    procedure MultiplyTransform(const Matrix: IGPMatrix;\r\n      const Order: TGPMatrixOrder = MatrixOrderPrepend);\r\n    procedure TranslateTransform(const DX, DY: Single;\r\n      const Order: TGPMatrixOrder = MatrixOrderPrepend);\r\n    procedure ScaleTransform(const SX, SY: Single;\r\n      const Order: TGPMatrixOrder = MatrixOrderPrepend);\r\n    procedure RotateTransform(const Angle: Single;\r\n      const Order: TGPMatrixOrder = MatrixOrderPrepend);\r\n    procedure SetDashPattern(const Pattern: array of Single);\r\n  private\r\n    constructor Create(const NativePen: GpPen); overload;\r\n  public\r\n    constructor Create(const Color: TGPColor; const Width: Single = 1); overload;\r\n    constructor Create(const Brush: IGPBrush; const Width: Single = 1); overload;\r\n    destructor Destroy; override;\r\n  end;\r\n\r\n{$ENDREGION 'GdiplusPen.h'}\r\n\r\n{$REGION 'GdiplusStringFormat.h'}\r\n\r\n(*****************************************************************************\r\n * GdiplusStringFormat.h\r\n * GDI+ StringFormat class\r\n *****************************************************************************)\r\n\r\n  IGPTabStops = IGPArray;\r\n  IGPCharacterRanges = IGPArray;\r\n\r\n  IGPStringFormat = interface(IGdiPlusBase)\r\n  ['{15875A7E-A799-4460-AC3B-4C5A966319E8}']\r\n    { Property access methods }\r\n    function GetFormatFlags: TGPStringFormatFlags;\r\n    procedure SetFormatFlags(const Value: TGPStringFormatFlags);\r\n    function GetAlignment: TGPStringAlignment;\r\n    procedure SetAlignment(const Value: TGPStringAlignment);\r\n    function GetLineAlignment: TGPStringAlignment;\r\n    procedure SetLineAlignment(const Value: TGPStringAlignment);\r\n    function GetHotkeyPrefix: TGPHotkeyPrefix;\r\n    procedure SetHotkeyPrefix(const Value: TGPHotkeyPrefix);\r\n    function GetDigitSubstitutionLanguage: LangID;\r\n    function GetDigitSubstitutionMethod: TGPStringDigitSubstitute;\r\n    function GetTrimming: TGPStringTrimming;\r\n    procedure SetTrimming(const Value: TGPStringTrimming);\r\n    function GetMeasurableCharacterRangeCount: Integer;\r\n\r\n    { Methods }\r\n    function Clone: IGPStringFormat;\r\n    function GetTabStops(out FirstTabOffset: Single): IGPTabStops;\r\n    procedure SetTabStops(const FirstTabOffset: Single;\r\n      const TabStops: array of Single);\r\n    procedure SetDigitSubstitution(const Language: LangID;\r\n      const Substitute: TGPStringDigitSubstitute);\r\n    procedure SetMeasurableCharacterRanges(const Ranges: IGPCharacterRanges);\r\n\r\n    { Properties }\r\n    property FormatFlags: TGPStringFormatFlags read GetFormatFlags write SetFormatFlags;\r\n    property Alignment: TGPStringAlignment read GetAlignment write SetAlignment;\r\n    property LineAlignment: TGPStringAlignment read GetLineAlignment write SetLineAlignment;\r\n    property HotkeyPrefix: TGPHotkeyPrefix read GetHotkeyPrefix write SetHotkeyPrefix;\r\n    property DigitSubstitutionLanguage: LangID read GetDigitSubstitutionLanguage;\r\n    property DigitSubstitutionMethod: TGPStringDigitSubstitute read GetDigitSubstitutionMethod;\r\n    property Trimming: TGPStringTrimming read GetTrimming write SetTrimming;\r\n    property MeasurableCharacterRangeCount: Integer read GetMeasurableCharacterRangeCount;\r\n  end;\r\n\r\n  TGPStringFormat = class(TGdiplusBase, IGPStringFormat)\r\n  private\r\n    class var FGenericDefault: IGPStringFormat;\r\n    class var FGenericTypographic: IGPStringFormat;\r\n  private\r\n    { IGPStringFormat }\r\n    function GetFormatFlags: TGPStringFormatFlags;\r\n    procedure SetFormatFlags(const Value: TGPStringFormatFlags);\r\n    function GetAlignment: TGPStringAlignment;\r\n    procedure SetAlignment(const Value: TGPStringAlignment);\r\n    function GetLineAlignment: TGPStringAlignment;\r\n    procedure SetLineAlignment(const Value: TGPStringAlignment);\r\n    function GetHotkeyPrefix: TGPHotkeyPrefix;\r\n    procedure SetHotkeyPrefix(const Value: TGPHotkeyPrefix);\r\n    function GetDigitSubstitutionLanguage: LangID;\r\n    function GetDigitSubstitutionMethod: TGPStringDigitSubstitute;\r\n    function GetTrimming: TGPStringTrimming;\r\n    procedure SetTrimming(const Value: TGPStringTrimming);\r\n    function GetMeasurableCharacterRangeCount: Integer;\r\n\r\n    function Clone: IGPStringFormat;\r\n    function GetTabStops(out FirstTabOffset: Single): IGPTabStops;\r\n    procedure SetTabStops(const FirstTabOffset: Single;\r\n      const TabStops: array of Single);\r\n    procedure SetDigitSubstitution(const Language: LangID;\r\n      const Substitute: TGPStringDigitSubstitute);\r\n    procedure SetMeasurableCharacterRanges(const Ranges: IGPCharacterRanges);\r\n  private\r\n    constructor Create(const NativeFormat: GpStringFormat); overload;\r\n  public\r\n    constructor Create(const FormatFlags: TGPStringFormatFlags = [];\r\n      const Language: LangID = LANG_NEUTRAL); overload;\r\n    constructor Create(const Format: IGPStringFormat); overload;\r\n    destructor Destroy; override;\r\n\r\n    class function GenericDefault: IGPStringFormat; static;\r\n    class function GenericTypographic: IGPStringFormat; static;\r\n  end;\r\n{$ENDREGION 'GdiplusStringFormat.h'}\r\n\r\n{$REGION 'GdiplusPath.h'}\r\n\r\n(*****************************************************************************\r\n * GdiplusPath.h\r\n * GDI+ Graphics Path class\r\n *****************************************************************************)\r\n\r\n  IGPPathTypes = IGPArray;\r\n  IGPPathPoints = IGPArray;\r\n  IGPPathPointsI = IGPArray;\r\n\r\n  IGPPathData = interface\r\n  ['{2FC67BFC-7013-4279-839A-1FCD71BD0909}']\r\n    { Property access methods }\r\n    function GetCount: Integer;\r\n    procedure SetCount(const Value: Integer);\r\n    function GetPoint(const Index: Integer): TGPPointF;\r\n    function GetType(const Index: Integer): Byte;\r\n    function GetPointPtr: PGPPointF;\r\n    function GetTypePtr: PByte;\r\n    function GetNativePathData: TGPNativePathData;\r\n\r\n    { Properties }\r\n    property Count: Integer read GetCount write SetCount;\r\n    property Points[const Index: Integer]: TGPPointF read GetPoint;\r\n    property Types[const Index: Integer]: Byte read GetType;\r\n    property PointPtr: PGPPointF read GetPointPtr;\r\n    property TypePtr: PByte read GetTypePtr;\r\n    property NativePathData: TGPNativePathData read GetNativePathData;\r\n  end;\r\n\r\n  TGPPathData = class(TInterfacedObject, IGPPathData)\r\n  private\r\n    FPoints: array of TGPPointF;\r\n    FTypes: array of Byte;\r\n  private\r\n    { IGPPathData }\r\n    function GetCount: Integer;\r\n    procedure SetCount(const Value: Integer);\r\n    function GetPoint(const Index: Integer): TGPPointF;\r\n    function GetType(const Index: Integer): Byte;\r\n    function GetPointPtr: PGPPointF;\r\n    function GetTypePtr: PByte;\r\n    function GetNativePathData: TGPNativePathData;\r\n  private\r\n    constructor Create(const ACount: Integer);\r\n  end;\r\n\r\n  IGPGraphicsPath = interface(IGdiPlusBase)\r\n  ['{9F117627-F765-41C0-96BD-44AA9165BF07}']\r\n    { Property access methods }\r\n    function GetFillMode: TGPFillMode;\r\n    procedure SetFillMode(const Value: TGPFillMode);\r\n    function GetPathData: IGPPathData;\r\n    function GetPointCount: Integer;\r\n    function GetPathTypes: IGPPathTypes;\r\n    function GetPathPoints: IGPPathPoints;\r\n    function GetPathPointsI: IGPPathPointsI;\r\n\r\n    { Methods }\r\n    function Clone: IGPGraphicsPath;\r\n    procedure Reset;\r\n    procedure StartFigure;\r\n    procedure CloseFigure;\r\n    procedure CloseAllFigures;\r\n    procedure SetMarker;\r\n    procedure ClearMarkers;\r\n    procedure Reverse;\r\n    function GetLastPoint: TGPPointF;\r\n\r\n    procedure AddLine(const Pt1, Pt2: TGPPointF); overload;\r\n    procedure AddLine(const X1, Y1, X2, Y2: Single); overload;\r\n    procedure AddLine(const Pt1, Pt2: TGPPoint); overload;\r\n    procedure AddLine(const X1, Y1, X2, Y2: Integer); overload;\r\n\r\n    procedure AddLines(const Points: array of TGPPointF); overload;\r\n    procedure AddLines(const Points: array of TGPPoint); overload;\r\n\r\n    procedure AddArc(const Rect: TGPRectF; const StartAngle, SweepAngle: Single); overload;\r\n    procedure AddArc(const X, Y, Width, Height, StartAngle, SweepAngle: Single); overload;\r\n    procedure AddArc(const Rect: TGPRect; const StartAngle, SweepAngle: Single); overload;\r\n    procedure AddArc(const X, Y, Width, Height: Integer;\r\n      const StartAngle, SweepAngle: Single); overload;\r\n\r\n    procedure AddBezier(const Pt1, Pt2, Pt3, Pt4: TGPPointF); overload;\r\n    procedure AddBezier(const X1, Y1, X2, Y2, X3, Y3, X4, Y4: Single); overload;\r\n    procedure AddBezier(const Pt1, Pt2, Pt3, Pt4: TGPPoint); overload;\r\n    procedure AddBezier(const X1, Y1, X2, Y2, X3, Y3, X4, Y4: Integer); overload;\r\n\r\n    procedure AddBeziers(const Points: array of TGPPointF); overload;\r\n    procedure AddBeziers(const Points: array of TGPPoint); overload;\r\n\r\n    procedure AddCurve(const Points: array of TGPPointF); overload;\r\n    procedure AddCurve(const Points: array of TGPPointF;\r\n      const Tension: Single); overload;\r\n    procedure AddCurve(const Points: array of TGPPointF;\r\n      const Offset, NumberOfSegments: Integer; const Tension: Single); overload;\r\n    procedure AddCurve(const Points: array of TGPPoint); overload;\r\n    procedure AddCurve(const Points: array of TGPPoint;\r\n      const Tension: Single); overload;\r\n    procedure AddCurve(const Points: array of TGPPoint;\r\n      const Offset, NumberOfSegments: Integer; const Tension: Single); overload;\r\n\r\n    procedure AddClosedCurve(const Points: array of TGPPointF); overload;\r\n    procedure AddClosedCurve(const Points: array of TGPPointF;\r\n      const Tension: Single); overload;\r\n    procedure AddClosedCurve(const Points: array of TGPPoint); overload;\r\n    procedure AddClosedCurve(const Points: array of TGPPoint;\r\n      const Tension: Single); overload;\r\n\r\n    procedure AddRectangle(const Rect: TGPRectF); overload;\r\n    procedure AddRectangle(const Rect: TGPRect); overload;\r\n\r\n    procedure AddRectangles(const Rects: array of TGPRectF); overload;\r\n    procedure AddRectangles(const Rects: array of TGPRect); overload;\r\n\r\n    procedure AddEllipse(const Rect: TGPRectF); overload;\r\n    procedure AddEllipse(const X, Y, Width, Height: Single); overload;\r\n    procedure AddEllipse(const Rect: TGPRect); overload;\r\n    procedure AddEllipse(const X, Y, Width, Height: Integer); overload;\r\n\r\n    procedure AddPie(const Rect: TGPRectF; const StartAngle, SweepAngle: Single); overload;\r\n    procedure AddPie(const X, Y, Width, Height, StartAngle, SweepAngle: Single); overload;\r\n    procedure AddPie(const Rect: TGPRect; const StartAngle, SweepAngle: Single); overload;\r\n    procedure AddPie(const X, Y, Width, Height: Integer;\r\n      const StartAngle, SweepAngle: Single); overload;\r\n\r\n    procedure AddPolygon(const Points: array of TGPPointF); overload;\r\n    procedure AddPolygon(const Points: array of TGPPoint); overload;\r\n\r\n    procedure AddPath(const AddingPath: IGPGraphicsPath; const Connect: Boolean);\r\n\r\n    procedure AddString(const Str: String; const Family: IGPFontFamily;\r\n      const Style: TGPFontStyle; const EmSize: Single; const Origin: TGPPointF;\r\n      const Format: IGPStringFormat); overload;\r\n    procedure AddString(const Str: String; const Family: IGPFontFamily;\r\n      const Style: TGPFontStyle; const EmSize: Single; const LayoutRect: TGPRectF;\r\n      const Format: IGPStringFormat); overload;\r\n    procedure AddString(const Str: String; const Family: IGPFontFamily;\r\n      const Style: TGPFontStyle; const EmSize: Single; const Origin: TGPPoint;\r\n      const Format: IGPStringFormat); overload;\r\n    procedure AddString(const Str: String; const Family: IGPFontFamily;\r\n      const Style: TGPFontStyle; const EmSize: Single; const LayoutRect: TGPRect;\r\n      const Format: IGPStringFormat); overload;\r\n\r\n    procedure Transform(const Matrix: IGPMatrix);\r\n    procedure GetBounds(out Bounds: TGPRectF; const Matrix: IGPMatrix = nil;\r\n      const Pen: IGPPen = nil); overload;\r\n    procedure GetBounds(out Bounds: TGPRect; const Matrix: IGPMatrix = nil;\r\n      const Pen: IGPPen = nil); overload;\r\n    procedure Flatten(const Matrix: IGPMatrix = nil;\r\n      const Flatness: Single = FlatnessDefault);\r\n    procedure Widen(const Pen: IGPPen; const Matrix: IGPMatrix = nil;\r\n      const Flatness: Single = FlatnessDefault);\r\n    procedure Outline(const Matrix: IGPMatrix = nil;\r\n      const Flatness: Single = FlatnessDefault);\r\n    procedure Warp(const DestPoints: array of TGPPointF; const SrcRect: TGPRectF;\r\n      const Matrix: IGPMatrix = nil; const WarpMode: TGPWarpMode = WarpModePerspective;\r\n      const Flatness: Single = FlatnessDefault);\r\n\r\n    function IsVisible(const Point: TGPPointF; const G: IGPGraphics = nil): Boolean; overload;\r\n    function IsVisible(const X, Y: Single; const G: IGPGraphics = nil): Boolean; overload;\r\n    function IsVisible(const Point: TGPPoint; const G: IGPGraphics = nil): Boolean; overload;\r\n    function IsVisible(const X, Y: Integer; const G: IGPGraphics = nil): Boolean; overload;\r\n\r\n    function IsOutlineVisible(const Point: TGPPointF; const Pen: IGPPen;\r\n      const G: IGPGraphics = nil): Boolean; overload;\r\n    function IsOutlineVisible(const X, Y: Single; const Pen: IGPPen;\r\n      const G: IGPGraphics = nil): Boolean; overload;\r\n    function IsOutlineVisible(const Point: TGPPoint; const Pen: IGPPen;\r\n      const G: IGPGraphics = nil): Boolean; overload;\r\n    function IsOutlineVisible(const X, Y: Integer; const Pen: IGPPen;\r\n      const G: IGPGraphics = nil): Boolean; overload;\r\n\r\n    { Properties }\r\n    property FillMode: TGPFillMode read GetFillMode write SetFillMode;\r\n    property PathData: IGPPathData read GetPathData;\r\n    property PointCount: Integer read GetPointCount;\r\n    property PathTypes: IGPPathTypes read GetPathTypes;\r\n    property PathPoints: IGPPathPoints read GetPathPoints;\r\n    property PathPointsI: IGPPathPointsI read GetPathPointsI;\r\n  end;\r\n\r\n  TGPGraphicsPath = class(TGdiplusBase, IGPGraphicsPath)\r\n  private\r\n    { IGPGraphicsPath }\r\n    function GetFillMode: TGPFillMode;\r\n    procedure SetFillMode(const Value: TGPFillMode);\r\n    function GetPathData: IGPPathData;\r\n    function GetPointCount: Integer;\r\n    function GetPathTypes: IGPPathTypes;\r\n    function GetPathPoints: IGPPathPoints;\r\n    function GetPathPointsI: IGPPathPointsI;\r\n\r\n    function Clone: IGPGraphicsPath;\r\n    procedure Reset;\r\n    procedure StartFigure;\r\n    procedure CloseFigure;\r\n    procedure CloseAllFigures;\r\n    procedure SetMarker;\r\n    procedure ClearMarkers;\r\n    procedure Reverse;\r\n    function GetLastPoint: TGPPointF;\r\n    procedure AddLine(const Pt1, Pt2: TGPPointF); overload;\r\n    procedure AddLine(const X1, Y1, X2, Y2: Single); overload;\r\n    procedure AddLine(const Pt1, Pt2: TGPPoint); overload;\r\n    procedure AddLine(const X1, Y1, X2, Y2: Integer); overload;\r\n    procedure AddLines(const Points: array of TGPPointF); overload;\r\n    procedure AddLines(const Points: array of TGPPoint); overload;\r\n    procedure AddArc(const Rect: TGPRectF; const StartAngle, SweepAngle: Single); overload;\r\n    procedure AddArc(const X, Y, Width, Height, StartAngle, SweepAngle: Single); overload;\r\n    procedure AddArc(const Rect: TGPRect; const StartAngle, SweepAngle: Single); overload;\r\n    procedure AddArc(const X, Y, Width, Height: Integer;\r\n      const StartAngle, SweepAngle: Single); overload;\r\n    procedure AddBezier(const Pt1, Pt2, Pt3, Pt4: TGPPointF); overload;\r\n    procedure AddBezier(const X1, Y1, X2, Y2, X3, Y3, X4, Y4: Single); overload;\r\n    procedure AddBezier(const Pt1, Pt2, Pt3, Pt4: TGPPoint); overload;\r\n    procedure AddBezier(const X1, Y1, X2, Y2, X3, Y3, X4, Y4: Integer); overload;\r\n    procedure AddBeziers(const Points: array of TGPPointF); overload;\r\n    procedure AddBeziers(const Points: array of TGPPoint); overload;\r\n    procedure AddCurve(const Points: array of TGPPointF); overload;\r\n    procedure AddCurve(const Points: array of TGPPointF;\r\n      const Tension: Single); overload;\r\n    procedure AddCurve(const Points: array of TGPPointF;\r\n      const Offset, NumberOfSegments: Integer; const Tension: Single); overload;\r\n    procedure AddCurve(const Points: array of TGPPoint); overload;\r\n    procedure AddCurve(const Points: array of TGPPoint;\r\n      const Tension: Single); overload;\r\n    procedure AddCurve(const Points: array of TGPPoint;\r\n      const Offset, NumberOfSegments: Integer; const Tension: Single); overload;\r\n    procedure AddClosedCurve(const Points: array of TGPPointF); overload;\r\n    procedure AddClosedCurve(const Points: array of TGPPointF;\r\n      const Tension: Single); overload;\r\n    procedure AddClosedCurve(const Points: array of TGPPoint); overload;\r\n    procedure AddClosedCurve(const Points: array of TGPPoint;\r\n      const Tension: Single); overload;\r\n    procedure AddRectangle(const Rect: TGPRectF); overload;\r\n    procedure AddRectangle(const Rect: TGPRect); overload;\r\n    procedure AddRectangles(const Rects: array of TGPRectF); overload;\r\n    procedure AddRectangles(const Rects: array of TGPRect); overload;\r\n    procedure AddEllipse(const Rect: TGPRectF); overload;\r\n    procedure AddEllipse(const X, Y, Width, Height: Single); overload;\r\n    procedure AddEllipse(const Rect: TGPRect); overload;\r\n    procedure AddEllipse(const X, Y, Width, Height: Integer); overload;\r\n    procedure AddPie(const Rect: TGPRectF; const StartAngle, SweepAngle: Single); overload;\r\n    procedure AddPie(const X, Y, Width, Height, StartAngle, SweepAngle: Single); overload;\r\n    procedure AddPie(const Rect: TGPRect; const StartAngle, SweepAngle: Single); overload;\r\n    procedure AddPie(const X, Y, Width, Height: Integer;\r\n      const StartAngle, SweepAngle: Single); overload;\r\n    procedure AddPolygon(const Points: array of TGPPointF); overload;\r\n    procedure AddPolygon(const Points: array of TGPPoint); overload;\r\n    procedure AddPath(const AddingPath: IGPGraphicsPath; const Connect: Boolean);\r\n    procedure AddString(const Str: String; const Family: IGPFontFamily;\r\n      const Style: TGPFontStyle; const EmSize: Single; const Origin: TGPPointF;\r\n      const Format: IGPStringFormat); overload;\r\n    procedure AddString(const Str: String; const Family: IGPFontFamily;\r\n      const Style: TGPFontStyle; const EmSize: Single; const LayoutRect: TGPRectF;\r\n      const Format: IGPStringFormat); overload;\r\n    procedure AddString(const Str: String; const Family: IGPFontFamily;\r\n      const Style: TGPFontStyle; const EmSize: Single; const Origin: TGPPoint;\r\n      const Format: IGPStringFormat); overload;\r\n    procedure AddString(const Str: String; const Family: IGPFontFamily;\r\n      const Style: TGPFontStyle; const EmSize: Single; const LayoutRect: TGPRect;\r\n      const Format: IGPStringFormat); overload;\r\n    procedure Transform(const Matrix: IGPMatrix);\r\n    procedure GetBounds(out Bounds: TGPRectF; const Matrix: IGPMatrix = nil;\r\n      const Pen: IGPPen = nil); overload;\r\n    procedure GetBounds(out Bounds: TGPRect; const Matrix: IGPMatrix = nil;\r\n      const Pen: IGPPen = nil); overload;\r\n    procedure Flatten(const Matrix: IGPMatrix = nil;\r\n      const Flatness: Single = FlatnessDefault);\r\n    procedure Widen(const Pen: IGPPen; const Matrix: IGPMatrix = nil;\r\n      const Flatness: Single = FlatnessDefault);\r\n    procedure Outline(const Matrix: IGPMatrix = nil;\r\n      const Flatness: Single = FlatnessDefault);\r\n    procedure Warp(const DestPoints: array of TGPPointF; const SrcRect: TGPRectF;\r\n      const Matrix: IGPMatrix = nil; const WarpMode: TGPWarpMode = WarpModePerspective;\r\n      const Flatness: Single = FlatnessDefault);\r\n    function IsVisible(const Point: TGPPointF; const G: IGPGraphics = nil): Boolean; overload;\r\n    function IsVisible(const X, Y: Single; const G: IGPGraphics = nil): Boolean; overload;\r\n    function IsVisible(const Point: TGPPoint; const G: IGPGraphics = nil): Boolean; overload;\r\n    function IsVisible(const X, Y: Integer; const G: IGPGraphics = nil): Boolean; overload;\r\n    function IsOutlineVisible(const Point: TGPPointF; const Pen: IGPPen;\r\n      const G: IGPGraphics = nil): Boolean; overload;\r\n    function IsOutlineVisible(const X, Y: Single; const Pen: IGPPen;\r\n      const G: IGPGraphics = nil): Boolean; overload;\r\n    function IsOutlineVisible(const Point: TGPPoint; const Pen: IGPPen;\r\n      const G: IGPGraphics = nil): Boolean; overload;\r\n    function IsOutlineVisible(const X, Y: Integer; const Pen: IGPPen;\r\n      const G: IGPGraphics = nil): Boolean; overload;\r\n  private\r\n    constructor Create(const NativePath: GpPath); overload;\r\n  public\r\n    constructor Create(const FillMode: TGPFillMode = FillModeAlternate); overload;\r\n    constructor Create(const Points: array of TGPPointF; const Types: array of Byte;\r\n      const FillMode: TGPFillMode = FillModeAlternate); overload;\r\n    constructor Create(const Points: array of TGPPoint; const Types: array of Byte;\r\n      const FillMode: TGPFillMode = FillModeAlternate); overload;\r\n    destructor Destroy; override;\r\n  end;\r\n\r\n  IGPGraphicsPathIterator = interface(IGdiPlusBase)\r\n  ['{4A37267A-F6EE-46C1-8D1D-08256ED3FCB8}']\r\n    { Property access methods }\r\n    function GetCount: Integer;\r\n    function GetSubpathCount: Integer;\r\n\r\n    { Methods }\r\n    function NextSubPath(out StartIndex, EndIndex: Integer;\r\n      out IsClosed: Boolean): Integer; overload;\r\n    function NextSubPath(const Path: IGPGraphicsPath;\r\n      out IsClosed: Boolean): Integer; overload;\r\n    function NextPathType(out PathType: Byte; out StartIndex,\r\n      EndIndex: Integer): Integer;\r\n    function NextMarker(out StartIndex, EndIndex: Integer): Integer; overload;\r\n    function NextMarker(const Path: IGPGraphicsPath): Integer; overload;\r\n    function HasCurve: Boolean;\r\n    procedure Rewind;\r\n    function Enumerate: IGPPathData;\r\n    function CopyData(const StartIndex, EndIndex: Integer): IGPPathData;\r\n\r\n    { Properties }\r\n    property Count: Integer read GetCount;\r\n    property SubpathCount: Integer read GetSubpathCount;\r\n  end;\r\n\r\n  TGPGraphicsPathIterator = class(TGdiplusBase, IGPGraphicsPathIterator)\r\n  private\r\n    { IGPGraphicsPathIterator }\r\n    function GetCount: Integer;\r\n    function GetSubpathCount: Integer;\r\n\r\n    function NextSubPath(out StartIndex, EndIndex: Integer;\r\n      out IsClosed: Boolean): Integer; overload;\r\n    function NextSubPath(const Path: IGPGraphicsPath;\r\n      out IsClosed: Boolean): Integer; overload;\r\n    function NextPathType(out PathType: Byte; out StartIndex,\r\n      EndIndex: Integer): Integer;\r\n    function NextMarker(out StartIndex, EndIndex: Integer): Integer; overload;\r\n    function NextMarker(const Path: IGPGraphicsPath): Integer; overload;\r\n    function HasCurve: Boolean;\r\n    procedure Rewind;\r\n    function Enumerate: IGPPathData;\r\n    function CopyData(const StartIndex, EndIndex: Integer): IGPPathData;\r\n  public\r\n    constructor Create(const Path: IGPGraphicsPath);\r\n    destructor Destroy; override;\r\n  end;\r\n\r\n  IGPColors = IGPArray;\r\n\r\n  IGPPathGradientBrush = interface(IGPBrush)\r\n  ['{66013840-6B90-4179-B72A-031548138EBF}']\r\n    { Property access methods }\r\n    function GetCenterColor: TGPColor;\r\n    procedure SetCenterColor(const Value: TGPColor);\r\n    function GetPointCount: Integer;\r\n    function GetSurroundColors: IGPColors;\r\n    procedure SetSurroundColorsInternal(const Value: IGPColors);\r\n    function GetGraphicsPath: IGPGraphicsPath;\r\n    procedure SetGraphicsPath(const Value: IGPGraphicsPath);\r\n    function GetCenterPoint: TGPPointF;\r\n    procedure SetCenterPoint(const Value: TGPPointF);\r\n    function GetCenterPointI: TGPPoint;\r\n    procedure SetCenterPointI(const Value: TGPPoint);\r\n    function GetRectangle: TGPRectF;\r\n    function GetRectangleI: TGPRect;\r\n    function GetGammaCorrection: Boolean;\r\n    procedure SetGammaCorrection(const Value: Boolean);\r\n    function GetBlend: IGPBlend;\r\n    procedure SetBlend(const Value: IGPBlend);\r\n    function GetInterpolationColors: IGPColorBlend;\r\n    procedure SetInterpolationColors(const Value: IGPColorBlend);\r\n    function GetTransform: IGPMatrix;\r\n    procedure SetTransform(const Value: IGPMatrix);\r\n    function GetWrapMode: TGPWrapMode;\r\n    procedure SetWrapMode(const Value: TGPWrapMode);\r\n\r\n    { Methods }\r\n    procedure SetBlendBellShape(const Focus: Single; const Scale: Single = 1);\r\n    procedure SetBlendTriangularShape(const Focus: Single; const Scale: Single = 1);\r\n    procedure ResetTransform;\r\n    procedure MultiplyTransform(const Matrix: IGPMatrix;\r\n      const Order: TGPMatrixOrder = MatrixOrderPrepend);\r\n    procedure TranslateTransform(const DX, DY: Single;\r\n      const Order: TGPMatrixOrder = MatrixOrderPrepend);\r\n    procedure ScaleTransform(const SX, SY: Single;\r\n      const Order: TGPMatrixOrder = MatrixOrderPrepend);\r\n    procedure RotateTransform(const Angle: Single;\r\n      const Order: TGPMatrixOrder = MatrixOrderPrepend);\r\n    procedure GetFocusScales(out XScale, YScale: Single);\r\n    procedure SetFocusScales(const XScale, YScale: Single);\r\n    procedure SetSurroundColors(const Colors: array of TGPColor);\r\n\r\n    { Properties }\r\n    property CenterColor: TGPColor read GetCenterColor write SetCenterColor;\r\n    property PointCount: Integer read GetPointCount;\r\n    property SurroundColors: IGPColors read GetSurroundColors write SetSurroundColorsInternal;\r\n    property GraphicsPath: IGPGraphicsPath read GetGraphicsPath write SetGraphicsPath;\r\n    property CenterPoint: TGPPointF read GetCenterPoint write SetCenterPoint;\r\n    property CenterPointI: TGPPoint read GetCenterPointI write SetCenterPointI;\r\n    property Rectangle: TGPRectF read GetRectangle;\r\n    property RectangleI: TGPRect read GetRectangleI;\r\n    property GammaCorrection: Boolean read GetGammaCorrection write SetGammaCorrection;\r\n    property Blend: IGPBlend read GetBlend write SetBlend;\r\n    property InterpolationColors: IGPColorBlend read GetInterpolationColors write SetInterpolationColors;\r\n    property Transform: IGPMatrix read GetTransform write SetTransform;\r\n    property WrapMode: TGPWrapMode read GetWrapMode write SetWrapMode;\r\n  end;\r\n\r\n  TGPPathGradientBrush = class(TGPBrush, IGPPathGradientBrush)\r\n  private\r\n    { IGPPathGradientBrush }\r\n    function GetCenterColor: TGPColor;\r\n    procedure SetCenterColor(const Value: TGPColor);\r\n    function GetPointCount: Integer;\r\n    function GetSurroundColors: IGPColors;\r\n    procedure SetSurroundColorsInternal(const Value: IGPColors);\r\n    function GetGraphicsPath: IGPGraphicsPath;\r\n    procedure SetGraphicsPath(const Value: IGPGraphicsPath);\r\n    function GetCenterPoint: TGPPointF;\r\n    procedure SetCenterPoint(const Value: TGPPointF);\r\n    function GetCenterPointI: TGPPoint;\r\n    procedure SetCenterPointI(const Value: TGPPoint);\r\n    function GetRectangle: TGPRectF;\r\n    function GetRectangleI: TGPRect;\r\n    function GetGammaCorrection: Boolean;\r\n    procedure SetGammaCorrection(const Value: Boolean);\r\n    function GetBlend: IGPBlend;\r\n    procedure SetBlend(const Value: IGPBlend);\r\n    function GetInterpolationColors: IGPColorBlend;\r\n    procedure SetInterpolationColors(const Value: IGPColorBlend);\r\n    function GetTransform: IGPMatrix;\r\n    procedure SetTransform(const Value: IGPMatrix);\r\n    function GetWrapMode: TGPWrapMode;\r\n    procedure SetWrapMode(const Value: TGPWrapMode);\r\n\r\n    procedure SetBlendBellShape(const Focus: Single; const Scale: Single = 1);\r\n    procedure SetBlendTriangularShape(const Focus: Single; const Scale: Single = 1);\r\n    procedure ResetTransform;\r\n    procedure MultiplyTransform(const Matrix: IGPMatrix;\r\n      const Order: TGPMatrixOrder = MatrixOrderPrepend);\r\n    procedure TranslateTransform(const DX, DY: Single;\r\n      const Order: TGPMatrixOrder = MatrixOrderPrepend);\r\n    procedure ScaleTransform(const SX, SY: Single;\r\n      const Order: TGPMatrixOrder = MatrixOrderPrepend);\r\n    procedure RotateTransform(const Angle: Single;\r\n      const Order: TGPMatrixOrder = MatrixOrderPrepend);\r\n    procedure GetFocusScales(out XScale, YScale: Single);\r\n    procedure SetFocusScales(const XScale, YScale: Single);\r\n    procedure SetSurroundColors(const Colors: array of TGPColor);\r\n  public\r\n    constructor Create(const Points: array of TGPPointF;\r\n      const WrapMode: TGPWrapMode = WrapModeClamp); overload;\r\n    constructor Create(const Points: array of TGPPoint;\r\n      const WrapMode: TGPWrapMode = WrapModeClamp); overload;\r\n    constructor Create(const Path: IGPGraphicsPath); overload;\r\n  end;\r\n{$ENDREGION 'GdiplusPath.h'}\r\n\r\n{$REGION 'GdiplusGraphics.h'}\r\n\r\n(*****************************************************************************\r\n * GdiplusGraphics.h\r\n * GDI+ Graphics class\r\n *****************************************************************************)\r\n\r\n  IGPRegions = IGPArray;\r\n\r\n  IGPGraphics = interface(IGdiPlusBase)\r\n  ['{57F85BA4-CB01-4466-8441-948D03588F54}']\r\n    { Property access methods }\r\n    function GetRenderingOrigin: TGPPoint; overload;\r\n    procedure SetRenderingOrigin(const Value: TGPPoint); overload;\r\n    function GetCompositingMode: TGPCompositingMode;\r\n    procedure SetCompositingMode(const Value: TGPCompositingMode);\r\n    function GetCompositingQuality: TGPCompositingQuality;\r\n    procedure SetCompositingQuality(const Value: TGPCompositingQuality);\r\n    function GetTextRenderingHint: TGPTextRenderingHint;\r\n    procedure SetTextRenderingHint(const Value: TGPTextRenderingHint);\r\n    function GetTextContrast: Integer;\r\n    procedure SetTextContrast(const Value: Integer);\r\n    function GetInterpolationMode: TGPInterpolationMode;\r\n    procedure SetInterpolationMode(const Value: TGPInterpolationMode);\r\n    function GetSmoothingMode: TGPSmoothingMode;\r\n    procedure SetSmoothingMode(const Value: TGPSmoothingMode);\r\n    function GetPixelOffsetMode: TGPPixelOffsetMode;\r\n    procedure SetPixelOffsetMode(const Value: TGPPixelOffsetMode);\r\n    function GetTransform: IGPMatrix;\r\n    procedure SetTransform(const Value: IGPMatrix);\r\n    function GetPageUnit: TGPUnit;\r\n    procedure SetPageUnit(const Value: TGPUnit);\r\n    function GetPageScale: Single;\r\n    procedure SetPageScale(const Value: Single);\r\n    function GetDpiX: Single;\r\n    function GetDpiY: Single;\r\n    function GetClip: IGPRegion;\r\n    procedure SetClipReplace(const Value: IGPRegion);\r\n    function GetClipBounds: TGPRectF;\r\n    function GetClipBoundsI: TGPRect;\r\n    function GetIsClipEmpty: Boolean;\r\n    function GetVisibleClipBounds: TGPRectF;\r\n    function GetVisibleClipBoundsI: TGPRect;\r\n    function GetIsVisibleClipEmpty: Boolean;\r\n\r\n    { Methods }\r\n    procedure Flush(const Intention: TGPFlushIntention = FlushIntentionFlush);\r\n    function GetHDC: HDC;\r\n    procedure ReleaseHDC(const DC: HDC);\r\n    procedure GetRenderingOrigin(out X, Y: Integer); overload;\r\n    procedure SetRenderingOrigin(const X, Y: Integer); overload;\r\n    {$IF (GDIPVER >= $0110)}\r\n    procedure SetAbort(const IAbort: TGdiplusAbort);\r\n    {$IFEND}\r\n    procedure ResetTransform;\r\n    procedure MultiplyTransform(const Matrix: IGPMatrix;\r\n      const Order: TGPMatrixOrder = MatrixOrderPrepend);\r\n    procedure TranslateTransform(const DX, DY: Single;\r\n      const Order: TGPMatrixOrder = MatrixOrderPrepend);\r\n    procedure ScaleTransform(const SX, SY: Single;\r\n      const Order: TGPMatrixOrder = MatrixOrderPrepend);\r\n    procedure RotateTransform(const Angle: Single;\r\n      const Order: TGPMatrixOrder = MatrixOrderPrepend);\r\n    procedure TransformPoints(const DestSpace, SrcSpace: TGPCoordinateSpace;\r\n      const Points: array of TGPPointF); overload;\r\n    procedure TransformPoints(const DestSpace, SrcSpace: TGPCoordinateSpace;\r\n      const Points: array of TGPPoint); overload;\r\n    function GetNearestColor(const Color: TGPColor): TGPColor;\r\n\r\n    procedure DrawLine(const Pen: IGPPen; const Pt1, Pt2: TGPPointF); overload;\r\n    procedure DrawLine(const Pen: IGPPen; const X1, Y1, X2, Y2: Single); overload;\r\n    procedure DrawLine(const Pen: IGPPen; const Pt1, Pt2: TGPPoint); overload;\r\n    procedure DrawLine(const Pen: IGPPen; const X1, Y1, X2, Y2: Integer); overload;\r\n\r\n    procedure DrawLines(const Pen: IGPPen; const Points: array of TGPPointF); overload;\r\n    procedure DrawLines(const Pen: IGPPen; const Points: array of TGPPoint); overload;\r\n\r\n    procedure DrawArc(const Pen: IGPPen; const Rect: TGPRectF; const StartAngle,\r\n      SweepAngle: Single); overload;\r\n    procedure DrawArc(const Pen: IGPPen; const X, Y, Width, Height, StartAngle,\r\n      SweepAngle: Single); overload;\r\n    procedure DrawArc(const Pen: IGPPen; const Rect: TGPRect; const StartAngle,\r\n      SweepAngle: Single); overload;\r\n    procedure DrawArc(const Pen: IGPPen; const X, Y, Width, Height: Integer;\r\n      const StartAngle, SweepAngle: Single); overload;\r\n\r\n    procedure DrawBezier(const Pen: IGPPen; const Pt1, Pt2, Pt3, Pt4: TGPPointF); overload;\r\n    procedure DrawBezier(const Pen: IGPPen; const X1, Y1, X2, Y2, X3, Y3, X4, Y4: Single); overload;\r\n    procedure DrawBezier(const Pen: IGPPen; const Pt1, Pt2, Pt3, Pt4: TGPPoint); overload;\r\n    procedure DrawBezier(const Pen: IGPPen; const X1, Y1, X2, Y2, X3, Y3, X4, Y4: Integer); overload;\r\n\r\n    procedure DrawBeziers(const Pen: IGPPen; const Points: array of TGPPointF); overload;\r\n    procedure DrawBeziers(const Pen: IGPPen; const Points: array of TGPPoint); overload;\r\n\r\n    procedure DrawRectangle(const Pen: IGPPen; const Rect: TGPRectF); overload;\r\n    procedure DrawRectangle(const Pen: IGPPen; const Rect: TGPRect); overload;\r\n    procedure DrawRectangle(const Pen: IGPPen; const X, Y, Width, Height: Single); overload;\r\n    procedure DrawRectangle(const Pen: IGPPen; const X, Y, Width, Height: Integer); overload;\r\n\r\n    procedure DrawRectangles(const Pen: IGPPen; const Rects: array of TGPRectF); overload;\r\n    procedure DrawRectangles(const Pen: IGPPen; const Rects: array of TGPRect); overload;\r\n\r\n    procedure DrawEllipse(const Pen: IGPPen; const Rect: TGPRectF); overload;\r\n    procedure DrawEllipse(const Pen: IGPPen; const X, Y, Width, Height: Single); overload;\r\n    procedure DrawEllipse(const Pen: IGPPen; const Rect: TGPRect); overload;\r\n    procedure DrawEllipse(const Pen: IGPPen; const X, Y, Width, Height: Integer); overload;\r\n\r\n    procedure DrawPie(const Pen: IGPPen; const Rect: TGPRectF;\r\n      const StartAngle, SweepAngle: Single); overload;\r\n    procedure DrawPie(const Pen: IGPPen; const X, Y, Width, Height,\r\n      StartAngle, SweepAngle: Single); overload;\r\n    procedure DrawPie(const Pen: IGPPen; const Rect: TGPRect;\r\n      const StartAngle, SweepAngle: Single); overload;\r\n    procedure DrawPie(const Pen: IGPPen; const X, Y, Width, Height: Integer;\r\n      const StartAngle, SweepAngle: Single); overload;\r\n\r\n    procedure DrawPolygon(const Pen: IGPPen; const Points: array of TGPPointF); overload;\r\n    procedure DrawPolygon(const Pen: IGPPen; const Points: array of TGPPoint); overload;\r\n\r\n    procedure DrawPath(const Pen: IGPPen; const Path: IGPGraphicsPath);\r\n\r\n    procedure DrawCurve(const Pen: IGPPen; const Points: array of TGPPointF); overload;\r\n    procedure DrawCurve(const Pen: IGPPen; const Points: array of TGPPointF;\r\n      const Tension: Single); overload;\r\n    procedure DrawCurve(const Pen: IGPPen; const Points: array of TGPPointF;\r\n      const Offset, NumberOfSegments: Integer; const Tension: Single); overload;\r\n    procedure DrawCurve(const Pen: IGPPen; const Points: array of TGPPoint); overload;\r\n    procedure DrawCurve(const Pen: IGPPen; const Points: array of TGPPoint;\r\n      const Tension: Single); overload;\r\n    procedure DrawCurve(const Pen: IGPPen; const Points: array of TGPPoint;\r\n      const Offset, NumberOfSegments: Integer; const Tension: Single); overload;\r\n\r\n    procedure DrawClosedCurve(const Pen: IGPPen; const Points: array of TGPPointF); overload;\r\n    procedure DrawClosedCurve(const Pen: IGPPen; const Points: array of TGPPointF;\r\n      const Tension: Single); overload;\r\n    procedure DrawClosedCurve(const Pen: IGPPen; const Points: array of TGPPoint); overload;\r\n    procedure DrawClosedCurve(const Pen: IGPPen; const Points: array of TGPPoint;\r\n      const Tension: Single); overload;\r\n\r\n    procedure Clear(const Color: TGPColor);\r\n\r\n    procedure FillRectangle(const Brush: IGPBrush; const Rect: TGPRectF); overload;\r\n    procedure FillRectangle(const Brush: IGPBrush; const Rect: TGPRect); overload;\r\n    procedure FillRectangle(const Brush: IGPBrush; const X, Y, Width, Height: Single); overload;\r\n    procedure FillRectangle(const Brush: IGPBrush; const X, Y, Width, Height: Integer); overload;\r\n\r\n    procedure FillRectangles(const Brush: IGPBrush; const Rects: array of TGPRectF); overload;\r\n    procedure FillRectangles(const Brush: IGPBrush; const Rects: array of TGPRect); overload;\r\n\r\n    procedure FillPolygon(const Brush: IGPBrush; const Points: array of TGPPointF); overload;\r\n    procedure FillPolygon(const Brush: IGPBrush; const Points: array of TGPPoint); overload;\r\n    procedure FillPolygon(const Brush: IGPBrush; const Points: array of TGPPointF;\r\n      const FillMode: TGPFillMode); overload;\r\n    procedure FillPolygon(const Brush: IGPBrush; const Points: array of TGPPoint;\r\n      const FillMode: TGPFillMode); overload;\r\n\r\n    procedure FillEllipse(const Brush: IGPBrush; const Rect: TGPRectF); overload;\r\n    procedure FillEllipse(const Brush: IGPBrush; const X, Y, Width, Height: Single); overload;\r\n    procedure FillEllipse(const Brush: IGPBrush; const Rect: TGPRect); overload;\r\n    procedure FillEllipse(const Brush: IGPBrush; const X, Y, Width, Height: Integer); overload;\r\n\r\n    procedure FillPie(const Brush: IGPBrush; const Rect: TGPRectF;\r\n      const StartAngle, SweepAngle: Single); overload;\r\n    procedure FillPie(const Brush: IGPBrush; const X, Y, Width, Height,\r\n      StartAngle, SweepAngle: Single); overload;\r\n    procedure FillPie(const Brush: IGPBrush; const Rect: TGPRect;\r\n      const StartAngle, SweepAngle: Single); overload;\r\n    procedure FillPie(const Brush: IGPBrush; const X, Y, Width, Height: Integer;\r\n      const StartAngle, SweepAngle: Single); overload;\r\n\r\n    procedure FillPath(const Brush: IGPBrush; const Path: IGPGraphicsPath);\r\n\r\n    procedure FillClosedCurve(const Brush: IGPBrush; const Points: array of TGPPointF); overload;\r\n    procedure FillClosedCurve(const Brush: IGPBrush; const Points: array of TGPPointF;\r\n      const FillMode: TGPFillMode; const Tension: Single); overload;\r\n    procedure FillClosedCurve(const Brush: IGPBrush; const Points: array of TGPPoint); overload;\r\n    procedure FillClosedCurve(const Brush: IGPBrush; const Points: array of TGPPoint;\r\n      const FillMode: TGPFillMode; const Tension: Single); overload;\r\n\r\n    procedure FillRegion(const Brush: IGPBrush; const Region: IGPRegion);\r\n\r\n    procedure DrawString(const Str: String; const Font: IGPFont;\r\n      const Origin: TGPPointF; const Brush: IGPBrush); overload;\r\n    procedure DrawString(const Str: String; const Font: IGPFont;\r\n      const LayoutRect: TGPRectF; const Format: IGPStringFormat;\r\n      const Brush: IGPBrush); overload;\r\n    procedure DrawString(const Str: String; const Font: IGPFont;\r\n      const Origin: TGPPointF; const Format: IGPStringFormat;\r\n      const Brush: IGPBrush); overload;\r\n\r\n    function MeasureString(const Str: String; const Font: IGPFont;\r\n      const LayoutRect: TGPRectF; const Format: IGPStringFormat): TGPRectF; overload;\r\n    function MeasureString(const Str: String; const Font: IGPFont;\r\n      const LayoutRect: TGPRectF; const Format: IGPStringFormat;\r\n      out CodepointsFitted, LinesFilled: Integer): TGPRectF; overload;\r\n    function MeasureString(const Str: String; const Font: IGPFont;\r\n      const LayoutRectSize: TGPSizeF; const Format: IGPStringFormat): TGPSizeF; overload;\r\n    function MeasureString(const Str: String; const Font: IGPFont;\r\n      const LayoutRectSize: TGPSizeF; const Format: IGPStringFormat;\r\n      out CodepointsFitted, LinesFilled: Integer): TGPSizeF; overload;\r\n    function MeasureString(const Str: String; const Font: IGPFont;\r\n      const Origin: TGPPointF; const Format: IGPStringFormat): TGPRectF; overload;\r\n    function MeasureString(const Str: String; const Font: IGPFont;\r\n      const LayoutRect: TGPRectF): TGPRectF; overload;\r\n    function MeasureString(const Str: String; const Font: IGPFont;\r\n      const Origin: TGPPointF): TGPRectF; overload;\r\n\r\n    function MeasureCharacterRanges(const Str: String; const Font: IGPFont;\r\n      const LayoutRect: TGPRectF; const Format: IGPStringFormat): IGPRegions;\r\n    procedure DrawDriverString(const Text: PUInt16; const Length: Integer;\r\n      const Font: IGPFont; const Brush: IGPBrush; const Positions: PGPPointF;\r\n      const Flags: TGPDriverStringOptions; const Matrix: IGPMatrix);\r\n    function MeasureDriverString(const Text: PUInt16; const Length: Integer;\r\n      const Font: IGPFont; const Positions: PGPPointF;\r\n      const Flags: TGPDriverStringOptions; const Matrix: IGPMatrix): TGPRectF;\r\n\r\n    procedure DrawCachedBitmap(const CachedBitmap: IGPCachedBitmap;\r\n      const X, Y: Integer);\r\n\r\n    procedure DrawImage(const Image: IGPImage; const Point: TGPPointF); overload;\r\n    procedure DrawImage(const Image: IGPImage; const X, Y: Single); overload;\r\n    procedure DrawImage(const Image: IGPImage; const Rect: TGPRectF); overload;\r\n    procedure DrawImage(const Image: IGPImage; const X, Y, Width, Height: Single); overload;\r\n    procedure DrawImage(const Image: IGPImage; const Point: TGPPoint); overload;\r\n    procedure DrawImage(const Image: IGPImage; const X, Y: Integer); overload;\r\n    procedure DrawImage(const Image: IGPImage; const Rect: TGPRect); overload;\r\n    procedure DrawImage(const Image: IGPImage; const X, Y, Width, Height: Integer); overload;\r\n    procedure DrawImage(const Image: IGPImage; const DestPoints: TGPPlgPointsF); overload;\r\n    procedure DrawImage(const Image: IGPImage; const DestPoints: TGPPlgPoints); overload;\r\n    procedure DrawImage(const Image: IGPImage; const X, Y, SrcX, SrcY, SrcWidth,\r\n      SrcHeight: Single; const SrcUnit: TGPUnit); overload;\r\n    procedure DrawImage(const Image: IGPImage; const DestRect: TGPRectF;\r\n      const SrcX, SrcY, SrcWidth, SrcHeight: Single; const SrcUnit: TGPUnit;\r\n      const ImageAttributes: IGPImageAttributes = nil;\r\n      const Callback: TGPDrawImageAbort = nil; const CallbackData: Pointer = nil); overload;\r\n    procedure DrawImage(const Image: IGPImage; const DstX, DstY, DstWidth,\r\n      DstHeight, SrcX, SrcY, SrcWidth, SrcHeight: Single; const SrcUnit: TGPUnit;\r\n      const ImageAttributes: IGPImageAttributes = nil;\r\n      const Callback: TGPDrawImageAbort = nil; const CallbackData: Pointer = nil); overload;\r\n    procedure DrawImage(const Image: IGPImage; const DestPoints: TGPPlgPointsF;\r\n      const SrcX, SrcY, SrcWidth, SrcHeight: Single; const SrcUnit: TGPUnit;\r\n      const ImageAttributes: IGPImageAttributes = nil;\r\n      const Callback: TGPDrawImageAbort = nil; const CallbackData: Pointer = nil); overload;\r\n    procedure DrawImage(const Image: IGPImage; const X, Y, SrcX, SrcY, SrcWidth,\r\n      SrcHeight: Integer; const SrcUnit: TGPUnit); overload;\r\n    procedure DrawImage(const Image: IGPImage; const DestRect: TGPRect;\r\n      const SrcX, SrcY, SrcWidth, SrcHeight: Integer; const SrcUnit: TGPUnit;\r\n      const ImageAttributes: IGPImageAttributes = nil;\r\n      const Callback: TGPDrawImageAbort = nil; const CallbackData: Pointer = nil); overload;\r\n    procedure DrawImage(const Image: IGPImage; const DstX, DstY, DstWidth,\r\n      DstHeight, SrcX, SrcY, SrcWidth, SrcHeight: Integer; const SrcUnit: TGPUnit;\r\n      const ImageAttributes: IGPImageAttributes = nil;\r\n      const Callback: TGPDrawImageAbort = nil; const CallbackData: Pointer = nil); overload;\r\n    procedure DrawImage(const Image: IGPImage; const DestPoints: TGPPlgPoints;\r\n      const SrcX, SrcY, SrcWidth, SrcHeight: Integer; const SrcUnit: TGPUnit;\r\n      const ImageAttributes: IGPImageAttributes = nil;\r\n      const Callback: TGPDrawImageAbort = nil; const CallbackData: Pointer = nil); overload;\r\n    {$IF (GDIPVER >= $0110)}\r\n    procedure DrawImage(const Image: IGPImage; const DestRect, SourceRect: TGPRectF;\r\n      const SrcUnit: TGPUnit; const ImageAttributes: IGPImageAttributes = nil); overload;\r\n    procedure DrawImage(const Image: IGPImage; const SourceRect: TGPRectF;\r\n      const XForm: IGPMatrix; const Effect: IGPEffect;\r\n      const ImageAttributes: IGPImageAttributes; const SrcUnit: TGPUnit); overload;\r\n    {$IFEND}\r\n\r\n    procedure EnumerateMetafile(const Metafile: IGPMetafile;\r\n      const DestPoint: TGPPointF; const Callback: TGPEnumerateMetafileProc;\r\n      const CallbackData: Pointer = nil;\r\n      const ImageAttributes: IGPImageAttributes = nil); overload;\r\n    procedure EnumerateMetafile(const Metafile: IGPMetafile;\r\n      const DestPoint: TGPPoint; const Callback: TGPEnumerateMetafileProc;\r\n      const CallbackData: Pointer = nil;\r\n      const ImageAttributes: IGPImageAttributes = nil); overload;\r\n    procedure EnumerateMetafile(const Metafile: IGPMetafile;\r\n      const DestRect: TGPRectF; const Callback: TGPEnumerateMetafileProc;\r\n      const CallbackData: Pointer = nil;\r\n      const ImageAttributes: IGPImageAttributes = nil); overload;\r\n    procedure EnumerateMetafile(const Metafile: IGPMetafile;\r\n      const DestRect: TGPRect; const Callback: TGPEnumerateMetafileProc;\r\n      const CallbackData: Pointer = nil;\r\n      const ImageAttributes: IGPImageAttributes = nil); overload;\r\n    procedure EnumerateMetafile(const Metafile: IGPMetafile;\r\n      const DestPoints: TGPPlgPointsF; const Callback: TGPEnumerateMetafileProc;\r\n      const CallbackData: Pointer = nil;\r\n      const ImageAttributes: IGPImageAttributes = nil); overload;\r\n    procedure EnumerateMetafile(const Metafile: IGPMetafile;\r\n      const DestPoints: TGPPlgPoints; const Callback: TGPEnumerateMetafileProc;\r\n      const CallbackData: Pointer = nil;\r\n      const ImageAttributes: IGPImageAttributes = nil); overload;\r\n    procedure EnumerateMetafile(const Metafile: IGPMetafile;\r\n      const DestPoint: TGPPointF; const SrcRect: TGPRectF; const SrcUnit: TGPUnit;\r\n      const Callback: TGPEnumerateMetafileProc; const CallbackData: Pointer = nil;\r\n      const ImageAttributes: IGPImageAttributes = nil); overload;\r\n    procedure EnumerateMetafile(const Metafile: IGPMetafile;\r\n      const DestPoint: TGPPoint; const SrcRect: TGPRect; const SrcUnit: TGPUnit;\r\n      const Callback: TGPEnumerateMetafileProc; const CallbackData: Pointer = nil;\r\n      const ImageAttributes: IGPImageAttributes = nil); overload;\r\n    procedure EnumerateMetafile(const Metafile: IGPMetafile;\r\n      const DestRect, SrcRect: TGPRectF; const SrcUnit: TGPUnit;\r\n      const Callback: TGPEnumerateMetafileProc; const CallbackData: Pointer = nil;\r\n      const ImageAttributes: IGPImageAttributes = nil); overload;\r\n    procedure EnumerateMetafile(const Metafile: IGPMetafile;\r\n      const DestRect, SrcRect: TGPRect; const SrcUnit: TGPUnit;\r\n      const Callback: TGPEnumerateMetafileProc; const CallbackData: Pointer = nil;\r\n      const ImageAttributes: IGPImageAttributes = nil); overload;\r\n    procedure EnumerateMetafile(const Metafile: IGPMetafile;\r\n      const DestPoints: TGPPlgPointsF; const SrcRect: TGPRectF; const SrcUnit: TGPUnit;\r\n      const Callback: TGPEnumerateMetafileProc; const CallbackData: Pointer = nil;\r\n      const ImageAttributes: IGPImageAttributes = nil); overload;\r\n    procedure EnumerateMetafile(const Metafile: IGPMetafile;\r\n      const DestPoints: TGPPlgPoints; const SrcRect: TGPRect; const SrcUnit: TGPUnit;\r\n      const Callback: TGPEnumerateMetafileProc; const CallbackData: Pointer = nil;\r\n      const ImageAttributes: IGPImageAttributes = nil); overload;\r\n\r\n    procedure SetClip(const G: IGPGraphics;\r\n      const CombineMode: TGPCombineMode = CombineModeReplace); overload;\r\n    procedure SetClip(const Rect: TGPRectF;\r\n      const CombineMode: TGPCombineMode = CombineModeReplace); overload;\r\n    procedure SetClip(const Rect: TGPRect;\r\n      const CombineMode: TGPCombineMode = CombineModeReplace); overload;\r\n    procedure SetClip(const Path: IGPGraphicsPath;\r\n      const CombineMode: TGPCombineMode = CombineModeReplace); overload;\r\n    procedure SetClip(const Region: IGPRegion;\r\n      const CombineMode: TGPCombineMode = CombineModeReplace); overload;\r\n    procedure SetClip(const Region: HRgn;\r\n      const CombineMode: TGPCombineMode = CombineModeReplace); overload;\r\n\r\n    procedure IntersectClip(const Rect: TGPRectF); overload;\r\n    procedure IntersectClip(const Rect: TGPRect); overload;\r\n    procedure IntersectClip(const Region: IGPRegion); overload;\r\n    procedure ExcludeClip(const Rect: TGPRectF); overload;\r\n    procedure ExcludeClip(const Rect: TGPRect); overload;\r\n    procedure ExcludeClip(const Region: IGPRegion); overload;\r\n    procedure ResetClip;\r\n    procedure TranslateClip(const DX, DY: Single); overload;\r\n    procedure TranslateClip(const DX, DY: Integer); overload;\r\n\r\n    function IsVisible(const X, Y: Integer): Boolean; overload;\r\n    function IsVisible(const Point: TGPPoint): Boolean; overload;\r\n    function IsVisible(const X, Y, Width, Height: Integer): Boolean; overload;\r\n    function IsVisible(const Rect: TGPRect): Boolean; overload;\r\n    function IsVisible(const X, Y: Single): Boolean; overload;\r\n    function IsVisible(const Point: TGPPointF): Boolean; overload;\r\n    function IsVisible(const X, Y, Width, Height: Single): Boolean; overload;\r\n    function IsVisible(const Rect: TGPRectF): Boolean; overload;\r\n\r\n    function Save: TGPGraphicsState;\r\n    procedure Restore(const State: TGPGraphicsState);\r\n    function BeginContainer(const DstRect, SrcRect: TGPRectF;\r\n      const MeasureUnit: TGPUnit): TGPGraphicsContainer; overload;\r\n    function BeginContainer(const DstRect, SrcRect: TGPRect;\r\n      const MeasureUnit: TGPUnit): TGPGraphicsContainer; overload;\r\n    function BeginContainer: TGPGraphicsContainer; overload;\r\n    procedure EndContainer(const State: TGPGraphicsContainer);\r\n\r\n    procedure AddMetafileComment(const Data: array of Byte);\r\n\r\n    { Properties }\r\n    property RenderingOrigin: TGPPoint read GetRenderingOrigin write SetRenderingOrigin;\r\n    property CompositingMode: TGPCompositingMode read GetCompositingMode write SetCompositingMode;\r\n    property CompositingQuality: TGPCompositingQuality read GetCompositingQuality write SetCompositingQuality;\r\n    property TextRenderingHint: TGPTextRenderingHint read GetTextRenderingHint write SetTextRenderingHint;\r\n    property TextContrast: Integer read GetTextContrast write SetTextContrast;\r\n    property InterpolationMode: TGPInterpolationMode read GetInterpolationMode write SetInterpolationMode;\r\n    property SmoothingMode: TGPSmoothingMode read GetSmoothingMode write SetSmoothingMode;\r\n    property PixelOffsetMode: TGPPixelOffsetMode read GetPixelOffsetMode write SetPixelOffsetMode;\r\n    property Transform: IGPMatrix read GetTransform write SetTransform;\r\n    property PageUnit: TGPUnit read GetPageUnit write SetPageUnit;\r\n    property PageScale: Single read GetPageScale write SetPageScale;\r\n    property DpiX: Single read GetDpiX;\r\n    property DpiY: Single read GetDpiY;\r\n    property Clip: IGPRegion read GetClip write SetClipReplace;\r\n    property ClipBounds: TGPRectF read GetClipBounds;\r\n    property ClipBoundsI: TGPRect read GetClipBoundsI;\r\n    property IsClipEmpty: Boolean read GetIsClipEmpty;\r\n    property VisibleClipBounds: TGPRectF read GetVisibleClipBounds;\r\n    property VisibleClipBoundsI: TGPRect read GetVisibleClipBoundsI;\r\n    property IsVisibleClipEmpty: Boolean read GetIsVisibleClipEmpty;\r\n  end;\r\n\r\n  TGPGraphics = class(TGdiplusBase, IGPGraphics)\r\n  private\r\n    { IGPGraphics }\r\n    function GetRenderingOrigin: TGPPoint; overload;\r\n    procedure SetRenderingOrigin(const Value: TGPPoint); overload;\r\n    function GetCompositingMode: TGPCompositingMode;\r\n    procedure SetCompositingMode(const Value: TGPCompositingMode);\r\n    function GetCompositingQuality: TGPCompositingQuality;\r\n    procedure SetCompositingQuality(const Value: TGPCompositingQuality);\r\n    function GetTextRenderingHint: TGPTextRenderingHint;\r\n    procedure SetTextRenderingHint(const Value: TGPTextRenderingHint);\r\n    function GetTextContrast: Integer;\r\n    procedure SetTextContrast(const Value: Integer);\r\n    function GetInterpolationMode: TGPInterpolationMode;\r\n    procedure SetInterpolationMode(const Value: TGPInterpolationMode);\r\n    function GetSmoothingMode: TGPSmoothingMode;\r\n    procedure SetSmoothingMode(const Value: TGPSmoothingMode);\r\n    function GetPixelOffsetMode: TGPPixelOffsetMode;\r\n    procedure SetPixelOffsetMode(const Value: TGPPixelOffsetMode);\r\n    function GetTransform: IGPMatrix;\r\n    procedure SetTransform(const Value: IGPMatrix);\r\n    function GetPageUnit: TGPUnit;\r\n    procedure SetPageUnit(const Value: TGPUnit);\r\n    function GetPageScale: Single;\r\n    procedure SetPageScale(const Value: Single);\r\n    function GetDpiX: Single;\r\n    function GetDpiY: Single;\r\n    function GetClip: IGPRegion;\r\n    procedure SetClipReplace(const Value: IGPRegion);\r\n    function GetClipBounds: TGPRectF;\r\n    function GetClipBoundsI: TGPRect;\r\n    function GetIsClipEmpty: Boolean;\r\n    function GetVisibleClipBounds: TGPRectF;\r\n    function GetVisibleClipBoundsI: TGPRect;\r\n    function GetIsVisibleClipEmpty: Boolean;\r\n\r\n    procedure Flush(const Intention: TGPFlushIntention = FlushIntentionFlush);\r\n    function GetHDC: HDC;\r\n    procedure ReleaseHDC(const DC: HDC);\r\n    procedure GetRenderingOrigin(out X, Y: Integer); overload;\r\n    procedure SetRenderingOrigin(const X, Y: Integer); overload;\r\n    {$IF (GDIPVER >= $0110)}\r\n    procedure SetAbort(const IAbort: TGdiplusAbort);\r\n    {$IFEND}\r\n    procedure ResetTransform;\r\n    procedure MultiplyTransform(const Matrix: IGPMatrix;\r\n      const Order: TGPMatrixOrder = MatrixOrderPrepend);\r\n    procedure TranslateTransform(const DX, DY: Single;\r\n      const Order: TGPMatrixOrder = MatrixOrderPrepend);\r\n    procedure ScaleTransform(const SX, SY: Single;\r\n      const Order: TGPMatrixOrder = MatrixOrderPrepend);\r\n    procedure RotateTransform(const Angle: Single;\r\n      const Order: TGPMatrixOrder = MatrixOrderPrepend);\r\n    procedure TransformPoints(const DestSpace, SrcSpace: TGPCoordinateSpace;\r\n      const Points: array of TGPPointF); overload;\r\n    procedure TransformPoints(const DestSpace, SrcSpace: TGPCoordinateSpace;\r\n      const Points: array of TGPPoint); overload;\r\n    function GetNearestColor(const Color: TGPColor): TGPColor;\r\n\r\n    procedure DrawLine(const Pen: IGPPen; const Pt1, Pt2: TGPPointF); overload;\r\n    procedure DrawLine(const Pen: IGPPen; const X1, Y1, X2, Y2: Single); overload;\r\n    procedure DrawLine(const Pen: IGPPen; const Pt1, Pt2: TGPPoint); overload;\r\n    procedure DrawLine(const Pen: IGPPen; const X1, Y1, X2, Y2: Integer); overload;\r\n\r\n    procedure DrawLines(const Pen: IGPPen; const Points: array of TGPPointF); overload;\r\n    procedure DrawLines(const Pen: IGPPen; const Points: array of TGPPoint); overload;\r\n\r\n    procedure DrawArc(const Pen: IGPPen; const Rect: TGPRectF; const StartAngle,\r\n      SweepAngle: Single); overload;\r\n    procedure DrawArc(const Pen: IGPPen; const X, Y, Width, Height, StartAngle,\r\n      SweepAngle: Single); overload;\r\n    procedure DrawArc(const Pen: IGPPen; const Rect: TGPRect; const StartAngle,\r\n      SweepAngle: Single); overload;\r\n    procedure DrawArc(const Pen: IGPPen; const X, Y, Width, Height: Integer;\r\n      const StartAngle, SweepAngle: Single); overload;\r\n\r\n    procedure DrawBezier(const Pen: IGPPen; const Pt1, Pt2, Pt3, Pt4: TGPPointF); overload;\r\n    procedure DrawBezier(const Pen: IGPPen; const X1, Y1, X2, Y2, X3, Y3, X4, Y4: Single); overload;\r\n    procedure DrawBezier(const Pen: IGPPen; const Pt1, Pt2, Pt3, Pt4: TGPPoint); overload;\r\n    procedure DrawBezier(const Pen: IGPPen; const X1, Y1, X2, Y2, X3, Y3, X4, Y4: Integer); overload;\r\n\r\n    procedure DrawBeziers(const Pen: IGPPen; const Points: array of TGPPointF); overload;\r\n    procedure DrawBeziers(const Pen: IGPPen; const Points: array of TGPPoint); overload;\r\n\r\n    procedure DrawRectangle(const Pen: IGPPen; const Rect: TGPRectF); overload;\r\n    procedure DrawRectangle(const Pen: IGPPen; const Rect: TGPRect); overload;\r\n    procedure DrawRectangle(const Pen: IGPPen; const X, Y, Width, Height: Single); overload;\r\n    procedure DrawRectangle(const Pen: IGPPen; const X, Y, Width, Height: Integer); overload;\r\n\r\n    procedure DrawRectangles(const Pen: IGPPen; const Rects: array of TGPRectF); overload;\r\n    procedure DrawRectangles(const Pen: IGPPen; const Rects: array of TGPRect); overload;\r\n\r\n    procedure DrawEllipse(const Pen: IGPPen; const Rect: TGPRectF); overload;\r\n    procedure DrawEllipse(const Pen: IGPPen; const X, Y, Width, Height: Single); overload;\r\n    procedure DrawEllipse(const Pen: IGPPen; const Rect: TGPRect); overload;\r\n    procedure DrawEllipse(const Pen: IGPPen; const X, Y, Width, Height: Integer); overload;\r\n\r\n    procedure DrawPie(const Pen: IGPPen; const Rect: TGPRectF;\r\n      const StartAngle, SweepAngle: Single); overload;\r\n    procedure DrawPie(const Pen: IGPPen; const X, Y, Width, Height,\r\n      StartAngle, SweepAngle: Single); overload;\r\n    procedure DrawPie(const Pen: IGPPen; const Rect: TGPRect;\r\n      const StartAngle, SweepAngle: Single); overload;\r\n    procedure DrawPie(const Pen: IGPPen; const X, Y, Width, Height: Integer;\r\n      const StartAngle, SweepAngle: Single); overload;\r\n\r\n    procedure DrawPolygon(const Pen: IGPPen; const Points: array of TGPPointF); overload;\r\n    procedure DrawPolygon(const Pen: IGPPen; const Points: array of TGPPoint); overload;\r\n\r\n    procedure DrawPath(const Pen: IGPPen; const Path: IGPGraphicsPath);\r\n\r\n    procedure DrawCurve(const Pen: IGPPen; const Points: array of TGPPointF); overload;\r\n    procedure DrawCurve(const Pen: IGPPen; const Points: array of TGPPointF;\r\n      const Tension: Single); overload;\r\n    procedure DrawCurve(const Pen: IGPPen; const Points: array of TGPPointF;\r\n      const Offset, NumberOfSegments: Integer; const Tension: Single); overload;\r\n    procedure DrawCurve(const Pen: IGPPen; const Points: array of TGPPoint); overload;\r\n    procedure DrawCurve(const Pen: IGPPen; const Points: array of TGPPoint;\r\n      const Tension: Single); overload;\r\n    procedure DrawCurve(const Pen: IGPPen; const Points: array of TGPPoint;\r\n      const Offset, NumberOfSegments: Integer; const Tension: Single); overload;\r\n\r\n    procedure DrawClosedCurve(const Pen: IGPPen; const Points: array of TGPPointF); overload;\r\n    procedure DrawClosedCurve(const Pen: IGPPen; const Points: array of TGPPointF;\r\n      const Tension: Single); overload;\r\n    procedure DrawClosedCurve(const Pen: IGPPen; const Points: array of TGPPoint); overload;\r\n    procedure DrawClosedCurve(const Pen: IGPPen; const Points: array of TGPPoint;\r\n      const Tension: Single); overload;\r\n\r\n    procedure Clear(const Color: TGPColor);\r\n\r\n    procedure FillRectangle(const Brush: IGPBrush; const Rect: TGPRectF); overload;\r\n    procedure FillRectangle(const Brush: IGPBrush; const Rect: TGPRect); overload;\r\n    procedure FillRectangle(const Brush: IGPBrush; const X, Y, Width, Height: Single); overload;\r\n    procedure FillRectangle(const Brush: IGPBrush; const X, Y, Width, Height: Integer); overload;\r\n\r\n    procedure FillRectangles(const Brush: IGPBrush; const Rects: array of TGPRectF); overload;\r\n    procedure FillRectangles(const Brush: IGPBrush; const Rects: array of TGPRect); overload;\r\n\r\n    procedure FillPolygon(const Brush: IGPBrush; const Points: array of TGPPointF); overload;\r\n    procedure FillPolygon(const Brush: IGPBrush; const Points: array of TGPPoint); overload;\r\n    procedure FillPolygon(const Brush: IGPBrush; const Points: array of TGPPointF;\r\n      const FillMode: TGPFillMode); overload;\r\n    procedure FillPolygon(const Brush: IGPBrush; const Points: array of TGPPoint;\r\n      const FillMode: TGPFillMode); overload;\r\n\r\n    procedure FillEllipse(const Brush: IGPBrush; const Rect: TGPRectF); overload;\r\n    procedure FillEllipse(const Brush: IGPBrush; const X, Y, Width, Height: Single); overload;\r\n    procedure FillEllipse(const Brush: IGPBrush; const Rect: TGPRect); overload;\r\n    procedure FillEllipse(const Brush: IGPBrush; const X, Y, Width, Height: Integer); overload;\r\n\r\n    procedure FillPie(const Brush: IGPBrush; const Rect: TGPRectF;\r\n      const StartAngle, SweepAngle: Single); overload;\r\n    procedure FillPie(const Brush: IGPBrush; const X, Y, Width, Height,\r\n      StartAngle, SweepAngle: Single); overload;\r\n    procedure FillPie(const Brush: IGPBrush; const Rect: TGPRect;\r\n      const StartAngle, SweepAngle: Single); overload;\r\n    procedure FillPie(const Brush: IGPBrush; const X, Y, Width, Height: Integer;\r\n      const StartAngle, SweepAngle: Single); overload;\r\n\r\n    procedure FillPath(const Brush: IGPBrush; const Path: IGPGraphicsPath);\r\n\r\n    procedure FillClosedCurve(const Brush: IGPBrush; const Points: array of TGPPointF); overload;\r\n    procedure FillClosedCurve(const Brush: IGPBrush; const Points: array of TGPPointF;\r\n      const FillMode: TGPFillMode; const Tension: Single); overload;\r\n    procedure FillClosedCurve(const Brush: IGPBrush; const Points: array of TGPPoint); overload;\r\n    procedure FillClosedCurve(const Brush: IGPBrush; const Points: array of TGPPoint;\r\n      const FillMode: TGPFillMode; const Tension: Single); overload;\r\n\r\n    procedure FillRegion(const Brush: IGPBrush; const Region: IGPRegion);\r\n\r\n    procedure DrawString(const Str: String; const Font: IGPFont;\r\n      const LayoutRect: TGPRectF; const Format: IGPStringFormat;\r\n      const Brush: IGPBrush); overload;\r\n    procedure DrawString(const Str: String; const Font: IGPFont;\r\n      const Origin: TGPPointF; const Format: IGPStringFormat;\r\n      const Brush: IGPBrush); overload;\r\n    procedure DrawString(const Str: String; const Font: IGPFont;\r\n      const Origin: TGPPointF; const Brush: IGPBrush); overload;\r\n\r\n    function MeasureString(const Str: String; const Font: IGPFont;\r\n      const LayoutRect: TGPRectF; const Format: IGPStringFormat): TGPRectF; overload;\r\n    function MeasureString(const Str: String; const Font: IGPFont;\r\n      const LayoutRect: TGPRectF; const Format: IGPStringFormat;\r\n      out CodepointsFitted, LinesFilled: Integer): TGPRectF; overload;\r\n    function MeasureString(const Str: String; const Font: IGPFont;\r\n      const LayoutRectSize: TGPSizeF; const Format: IGPStringFormat): TGPSizeF; overload;\r\n    function MeasureString(const Str: String; const Font: IGPFont;\r\n      const LayoutRectSize: TGPSizeF; const Format: IGPStringFormat;\r\n      out CodepointsFitted, LinesFilled: Integer): TGPSizeF; overload;\r\n    function MeasureString(const Str: String; const Font: IGPFont;\r\n      const Origin: TGPPointF; const Format: IGPStringFormat): TGPRectF; overload;\r\n    function MeasureString(const Str: String; const Font: IGPFont;\r\n      const LayoutRect: TGPRectF): TGPRectF; overload;\r\n    function MeasureString(const Str: String; const Font: IGPFont;\r\n      const Origin: TGPPointF): TGPRectF; overload;\r\n\r\n    function MeasureCharacterRanges(const Str: String; const Font: IGPFont;\r\n      const LayoutRect: TGPRectF; const Format: IGPStringFormat): IGPRegions;\r\n    procedure DrawDriverString(const Text: PUInt16; const Length: Integer;\r\n      const Font: IGPFont; const Brush: IGPBrush; const Positions: PGPPointF;\r\n      const Flags: TGPDriverStringOptions; const Matrix: IGPMatrix);\r\n    function MeasureDriverString(const Text: PUInt16; const Length: Integer;\r\n      const Font: IGPFont; const Positions: PGPPointF;\r\n      const Flags: TGPDriverStringOptions; const Matrix: IGPMatrix): TGPRectF;\r\n\r\n    procedure DrawCachedBitmap(const CachedBitmap: IGPCachedBitmap;\r\n      const X, Y: Integer);\r\n\r\n    procedure DrawImage(const Image: IGPImage; const Point: TGPPointF); overload;\r\n    procedure DrawImage(const Image: IGPImage; const X, Y: Single); overload;\r\n    procedure DrawImage(const Image: IGPImage; const Rect: TGPRectF); overload;\r\n    procedure DrawImage(const Image: IGPImage; const X, Y, Width, Height: Single); overload;\r\n    procedure DrawImage(const Image: IGPImage; const Point: TGPPoint); overload;\r\n    procedure DrawImage(const Image: IGPImage; const X, Y: Integer); overload;\r\n    procedure DrawImage(const Image: IGPImage; const Rect: TGPRect); overload;\r\n    procedure DrawImage(const Image: IGPImage; const X, Y, Width, Height: Integer); overload;\r\n    procedure DrawImage(const Image: IGPImage; const DestPoints: TGPPlgPointsF); overload;\r\n    procedure DrawImage(const Image: IGPImage; const DestPoints: TGPPlgPoints); overload;\r\n    procedure DrawImage(const Image: IGPImage; const X, Y, SrcX, SrcY, SrcWidth,\r\n      SrcHeight: Single; const SrcUnit: TGPUnit); overload;\r\n    procedure DrawImage(const Image: IGPImage; const DestRect: TGPRectF;\r\n      const SrcX, SrcY, SrcWidth, SrcHeight: Single; const SrcUnit: TGPUnit;\r\n      const ImageAttributes: IGPImageAttributes = nil;\r\n      const Callback: TGPDrawImageAbort = nil; const CallbackData: Pointer = nil); overload;\r\n    procedure DrawImage(const Image: IGPImage; const DstX, DstY, DstWidth,\r\n      DstHeight, SrcX, SrcY, SrcWidth, SrcHeight: Single; const SrcUnit: TGPUnit;\r\n      const ImageAttributes: IGPImageAttributes = nil;\r\n      const Callback: TGPDrawImageAbort = nil; const CallbackData: Pointer = nil); overload;\r\n    procedure DrawImage(const Image: IGPImage; const DestPoints: TGPPlgPointsF;\r\n      const SrcX, SrcY, SrcWidth, SrcHeight: Single; const SrcUnit: TGPUnit;\r\n      const ImageAttributes: IGPImageAttributes = nil;\r\n      const Callback: TGPDrawImageAbort = nil; const CallbackData: Pointer = nil); overload;\r\n    procedure DrawImage(const Image: IGPImage; const X, Y, SrcX, SrcY, SrcWidth,\r\n      SrcHeight: Integer; const SrcUnit: TGPUnit); overload;\r\n    procedure DrawImage(const Image: IGPImage; const DestRect: TGPRect;\r\n      const SrcX, SrcY, SrcWidth, SrcHeight: Integer; const SrcUnit: TGPUnit;\r\n      const ImageAttributes: IGPImageAttributes = nil;\r\n      const Callback: TGPDrawImageAbort = nil; const CallbackData: Pointer = nil); overload;\r\n    procedure DrawImage(const Image: IGPImage; const DstX, DstY, DstWidth,\r\n      DstHeight, SrcX, SrcY, SrcWidth, SrcHeight: Integer; const SrcUnit: TGPUnit;\r\n      const ImageAttributes: IGPImageAttributes = nil;\r\n      const Callback: TGPDrawImageAbort = nil; const CallbackData: Pointer = nil); overload;\r\n    procedure DrawImage(const Image: IGPImage; const DestPoints: TGPPlgPoints;\r\n      const SrcX, SrcY, SrcWidth, SrcHeight: Integer; const SrcUnit: TGPUnit;\r\n      const ImageAttributes: IGPImageAttributes = nil;\r\n      const Callback: TGPDrawImageAbort = nil; const CallbackData: Pointer = nil); overload;\r\n    {$IF (GDIPVER >= $0110)}\r\n    procedure DrawImage(const Image: IGPImage; const DestRect, SourceRect: TGPRectF;\r\n      const SrcUnit: TGPUnit; const ImageAttributes: IGPImageAttributes = nil); overload;\r\n    procedure DrawImage(const Image: IGPImage; const SourceRect: TGPRectF;\r\n      const XForm: IGPMatrix; const Effect: IGPEffect;\r\n      const ImageAttributes: IGPImageAttributes; const SrcUnit: TGPUnit); overload;\r\n    {$IFEND}\r\n\r\n    procedure EnumerateMetafile(const Metafile: IGPMetafile;\r\n      const DestPoint: TGPPointF; const Callback: TGPEnumerateMetafileProc;\r\n      const CallbackData: Pointer = nil;\r\n      const ImageAttributes: IGPImageAttributes = nil); overload;\r\n    procedure EnumerateMetafile(const Metafile: IGPMetafile;\r\n      const DestPoint: TGPPoint; const Callback: TGPEnumerateMetafileProc;\r\n      const CallbackData: Pointer = nil;\r\n      const ImageAttributes: IGPImageAttributes = nil); overload;\r\n    procedure EnumerateMetafile(const Metafile: IGPMetafile;\r\n      const DestRect: TGPRectF; const Callback: TGPEnumerateMetafileProc;\r\n      const CallbackData: Pointer = nil;\r\n      const ImageAttributes: IGPImageAttributes = nil); overload;\r\n    procedure EnumerateMetafile(const Metafile: IGPMetafile;\r\n      const DestRect: TGPRect; const Callback: TGPEnumerateMetafileProc;\r\n      const CallbackData: Pointer = nil;\r\n      const ImageAttributes: IGPImageAttributes = nil); overload;\r\n    procedure EnumerateMetafile(const Metafile: IGPMetafile;\r\n      const DestPoints: TGPPlgPointsF; const Callback: TGPEnumerateMetafileProc;\r\n      const CallbackData: Pointer = nil;\r\n      const ImageAttributes: IGPImageAttributes = nil); overload;\r\n    procedure EnumerateMetafile(const Metafile: IGPMetafile;\r\n      const DestPoints: TGPPlgPoints; const Callback: TGPEnumerateMetafileProc;\r\n      const CallbackData: Pointer = nil;\r\n      const ImageAttributes: IGPImageAttributes = nil); overload;\r\n    procedure EnumerateMetafile(const Metafile: IGPMetafile;\r\n      const DestPoint: TGPPointF; const SrcRect: TGPRectF; const SrcUnit: TGPUnit;\r\n      const Callback: TGPEnumerateMetafileProc; const CallbackData: Pointer = nil;\r\n      const ImageAttributes: IGPImageAttributes = nil); overload;\r\n    procedure EnumerateMetafile(const Metafile: IGPMetafile;\r\n      const DestPoint: TGPPoint; const SrcRect: TGPRect; const SrcUnit: TGPUnit;\r\n      const Callback: TGPEnumerateMetafileProc; const CallbackData: Pointer = nil;\r\n      const ImageAttributes: IGPImageAttributes = nil); overload;\r\n    procedure EnumerateMetafile(const Metafile: IGPMetafile;\r\n      const DestRect, SrcRect: TGPRectF; const SrcUnit: TGPUnit;\r\n      const Callback: TGPEnumerateMetafileProc; const CallbackData: Pointer = nil;\r\n      const ImageAttributes: IGPImageAttributes = nil); overload;\r\n    procedure EnumerateMetafile(const Metafile: IGPMetafile;\r\n      const DestRect, SrcRect: TGPRect; const SrcUnit: TGPUnit;\r\n      const Callback: TGPEnumerateMetafileProc; const CallbackData: Pointer = nil;\r\n      const ImageAttributes: IGPImageAttributes = nil); overload;\r\n    procedure EnumerateMetafile(const Metafile: IGPMetafile;\r\n      const DestPoints: TGPPlgPointsF; const SrcRect: TGPRectF; const SrcUnit: TGPUnit;\r\n      const Callback: TGPEnumerateMetafileProc; const CallbackData: Pointer = nil;\r\n      const ImageAttributes: IGPImageAttributes = nil); overload;\r\n    procedure EnumerateMetafile(const Metafile: IGPMetafile;\r\n      const DestPoints: TGPPlgPoints; const SrcRect: TGPRect; const SrcUnit: TGPUnit;\r\n      const Callback: TGPEnumerateMetafileProc; const CallbackData: Pointer = nil;\r\n      const ImageAttributes: IGPImageAttributes = nil); overload;\r\n\r\n    procedure SetClip(const G: IGPGraphics;\r\n      const CombineMode: TGPCombineMode = CombineModeReplace); overload;\r\n    procedure SetClip(const Rect: TGPRectF;\r\n      const CombineMode: TGPCombineMode = CombineModeReplace); overload;\r\n    procedure SetClip(const Rect: TGPRect;\r\n      const CombineMode: TGPCombineMode = CombineModeReplace); overload;\r\n    procedure SetClip(const Path: IGPGraphicsPath;\r\n      const CombineMode: TGPCombineMode = CombineModeReplace); overload;\r\n    procedure SetClip(const Region: IGPRegion;\r\n      const CombineMode: TGPCombineMode = CombineModeReplace); overload;\r\n    procedure SetClip(const Region: HRgn;\r\n      const CombineMode: TGPCombineMode = CombineModeReplace); overload;\r\n\r\n    procedure IntersectClip(const Rect: TGPRectF); overload;\r\n    procedure IntersectClip(const Rect: TGPRect); overload;\r\n    procedure IntersectClip(const Region: IGPRegion); overload;\r\n    procedure ExcludeClip(const Rect: TGPRectF); overload;\r\n    procedure ExcludeClip(const Rect: TGPRect); overload;\r\n    procedure ExcludeClip(const Region: IGPRegion); overload;\r\n    procedure ResetClip;\r\n    procedure TranslateClip(const DX, DY: Single); overload;\r\n    procedure TranslateClip(const DX, DY: Integer); overload;\r\n\r\n    function IsVisible(const X, Y: Integer): Boolean; overload;\r\n    function IsVisible(const Point: TGPPoint): Boolean; overload;\r\n    function IsVisible(const X, Y, Width, Height: Integer): Boolean; overload;\r\n    function IsVisible(const Rect: TGPRect): Boolean; overload;\r\n    function IsVisible(const X, Y: Single): Boolean; overload;\r\n    function IsVisible(const Point: TGPPointF): Boolean; overload;\r\n    function IsVisible(const X, Y, Width, Height: Single): Boolean; overload;\r\n    function IsVisible(const Rect: TGPRectF): Boolean; overload;\r\n\r\n    function Save: TGPGraphicsState;\r\n    procedure Restore(const State: TGPGraphicsState);\r\n    function BeginContainer(const DstRect, SrcRect: TGPRectF;\r\n      const MeasureUnit: TGPUnit): TGPGraphicsContainer; overload;\r\n    function BeginContainer(const DstRect, SrcRect: TGPRect;\r\n      const MeasureUnit: TGPUnit): TGPGraphicsContainer; overload;\r\n    function BeginContainer: TGPGraphicsContainer; overload;\r\n    procedure EndContainer(const State: TGPGraphicsContainer);\r\n\r\n    procedure AddMetafileComment(const Data: array of Byte);\r\n  public\r\n    constructor Create(const DC: HDC); overload;\r\n    constructor Create(const DC: HDC; const Device: THandle); overload;\r\n    constructor Create(const Window: HWnd; const ICM: Boolean = False); overload;\r\n    constructor Create(const Image: IGPImage); overload;\r\n    destructor Destroy; override;\r\n\r\n    class function FromHDC(const DC: HDC): IGPGraphics; overload; static;\r\n    class function FromHDC(const DC: HDC; const Device: THandle): IGPGraphics; overload; static;\r\n    class function FromHWnd(const Window: HWnd;\r\n      const ICM: Boolean = False): IGPGraphics; static;\r\n    class function FromImage(const Image: IGPImage): IGPGraphics; static;\r\n  end;\r\n{$ENDREGION 'GdiplusGraphics.h'}\r\n\r\n{$REGION 'Utilities'}\r\ntype\r\n  EGdipError = class(Exception)\r\n  private\r\n    FStatus: TGPStatus;\r\n  public\r\n    constructor Create(const Status: TGPStatus);\r\n\r\n    property Status: TGPStatus read FStatus;\r\n  end;\r\n{$ENDREGION 'Utilities'}\r\n\r\n{$REGION 'Aliases'}\r\n{$IFDEF GDIP_ALIAS}\r\ntype\r\n  TGraphicsState = TGPGraphicsState;\r\n  PGraphicsState = PGPGraphicsState;\r\n  TGraphicsContainer = TGPGraphicsContainer;\r\n  PGraphicsContainer = PGPGraphicsContainer;\r\n  TFillMode = TGPFillMode;\r\n  TQualityMode = TGPQualityMode;\r\n  TCompositingMode = TGPCompositingMode;\r\n  TCompositingQuality = TGPCompositingQuality;\r\n  TUnit = TGPUnit;\r\n  TMetafileFrameUnit = TGPMetafileFrameUnit;\r\n  TCoordinateSpace = TGPCoordinateSpace;\r\n  TWrapMode = TGPWrapMode;\r\n  THatchStyle = TGPHatchStyle;\r\n  TDashStyle = TGPDashStyle;\r\n  TDashCap = TGPDashCap;\r\n  TLineCap = TGPLineCap;\r\n  TCustomLineCapType = TGPCustomLineCapType;\r\n  TLineJoin = TGPLineJoin;\r\n  TPathPointType = TGPPathPointType;\r\n  TWarpMode = TGPWarpMode;\r\n  TLinearGradientMode = TGPLinearGradientMode;\r\n  TCombineMode = TGPCombineMode;\r\n  TImageType = TGPImageType;\r\n  TInterpolationMode = TGPInterpolationMode;\r\n  TPenAlignment = TGPPenAlignment;\r\n  TBrushType = TGPBrushType;\r\n  TPenType = TGPPenType;\r\n  TMatrixOrder = TGPMatrixOrder;\r\n  TGenericFontFamily = TGPGenericFontFamily;\r\n  TFontStyleEntry = TGPFontStyleEntry;\r\n  TFontStyle = TGPFontStyle;\r\n  TSmoothingMode = TGPSmoothingMode;\r\n  TPixelOffsetMode = TGPPixelOffsetMode;\r\n  TTextRenderingHint = TGPTextRenderingHint;\r\n  TMetafileType = TGPMetafileType;\r\n  TEmfType = TGPEmfType;\r\n  TObjectType = TGPObjectType;\r\n  TStringFormatFlag = TGPStringFormatFlag;\r\n  TStringFormatFlags = TGPStringFormatFlags;\r\n  TStringTrimming = TGPStringTrimming;\r\n  TStringDigitSubstitute = TGPStringDigitSubstitute;\r\n  PStringDigitSubstitute = PGPStringDigitSubstitute;\r\n  THotkeyPrefix = TGPHotkeyPrefix;\r\n  TStringAlignment = TGPStringAlignment;\r\n  TDriverStringOption = TGPDriverStringOption;\r\n  TDriverStringOptions = TGPDriverStringOptions;\r\n  TFlushIntention = TGPFlushIntention;\r\n  TEncoderParameterValueType = TGPEncoderParameterValueType;\r\n  TEncoderValue = TGPEncoderValue;\r\n  TEmfToWmfBitsFlag = TGPEmfToWmfBitsFlag;\r\n  TEmfToWmfBitsFlags = TGPEmfToWmfBitsFlags;\r\n  TTestControlEnum = TGPTestControlEnum;\r\n  TImageAbort = TGPImageAbort;\r\n  TDrawImageAbort = TGPDrawImageAbort;\r\n  TGetThumbnailImageAbort = TGPGetThumbnailImageAbort;\r\n  TEnumerateMetafileProc = TGPEnumerateMetafileProc;\r\n  TStatus = TGPStatus;\r\n  TSizeF = TGPSizeF;\r\n  PSizeF = PGPSizeF;\r\n  TSize = TGPSize;\r\n  PSize = PGPSize;\r\n  TPointF = TGPPointF;\r\n  PPointF = PGPPointF;\r\n  TPoint = TGPPoint;\r\n  PPoint = PGPPoint;\r\n  PRectF = PGPRectF;\r\n  TRectF = TGPRectF;\r\n  PRect = PGPRect;\r\n  TRect = TGPRect;\r\n  TNativePathData = TGPNativePathData;\r\n  PNativePathData = PGPNativePathData;\r\n  TCharacterRange = TGPCharacterRange;\r\n  PCharacterRange = PGPCharacterRange;\r\n  TDebugEventLevel = TGPDebugEventLevel;\r\n  TDebugEventProc = TGPDebugEventProc;\r\n  TNofificationHookProc = TGPNofificationHookProc;\r\n  TNofificationUnhookProc = TGPNofificationUnhookProc;\r\n  TPixelFormat = TGPPixelFormat;\r\n  TPaletteFlag = TGPPaletteFlag;\r\n  TPaletteFlags = TGPPaletteFlags;\r\n  TNativeColorPalette = TGPNativeColorPalette;\r\n  PNativeColorPalette = PGPNativeColorPalette;\r\n  TColorMode = TGPColorMode;\r\n  TColorChannelFlags = TGPColorChannelFlags;\r\n  TColor = TGPColor;\r\n  PColor = PGPColor;\r\n  TMetafileHeader = TGPMetafileHeader;\r\n  PMetafileHeader = PGPMetafileHeader;\r\n  IImageBytes = IGPImageBytes;\r\n  TImageCodecFlag = TGPImageCodecFlag;\r\n  TNativeImageCodecInfo = TGPNativeImageCodecInfo;\r\n  PNativeImageCodecInfo = PGPNativeImageCodecInfo;\r\n  TImageLockModeOption = TGPImageLockModeOption;\r\n  TImageLockMode = TGPImageLockMode;\r\n  TBitmapData = TGPBitmapData;\r\n  PBitmapData = PGPBitmapData;\r\n  TImageFlag = TGPImageFlag;\r\n  TImageFlags = TGPImageFlags;\r\n  TRotateFlipType = TGPRotateFlipType;\r\n  TNativeEncoderParameter = TGPNativeEncoderParameter;\r\n  PNativeEncoderParameter = PGPNativeEncoderParameter;\r\n  TNativeEncoderParameters = TGPNativeEncoderParameters;\r\n  PNativeEncoderParameters = PGPNativeEncoderParameters;\r\n  TNativePropertyItem = TGPNativePropertyItem;\r\n  PNativePropertyItem = PGPNativePropertyItem;\r\n  TColorMatrix = TGPColorMatrix;\r\n  PColorMatrix = PGPColorMatrix;\r\n  TColorMatrixFlags = TGPColorMatrixFlags;\r\n  TColorAdjustType = TGPColorAdjustType;\r\n  TColorMap = TGPColorMap;\r\n  PColorMap = PGPColorMap;\r\n  IRegionData = IGPRegionData;\r\n  IRegionScansF = IGPRegionScansF;\r\n  IRegionScans = IGPRegionScans;\r\n  IRegion = IGPRegion;\r\n  TRegion = TGPRegion;\r\n  IFontFamily = IGPFontFamily;\r\n  TFontFamily = TGPFontFamily;\r\n  IFont = IGPFont;\r\n  TFont = TGPFont;\r\n  IFontFamilies = IGPFontFamilies;\r\n  IFontCollection = IGPFontCollection;\r\n  TFontCollection = TGPFontCollection;\r\n  IInstalledFontCollection = IGPInstalledFontCollection;\r\n  TInstalledFontCollection = TGPInstalledFontCollection;\r\n  IPrivateFontCollection = IGPPrivateFontCollection;\r\n  TPrivateFontCollection = TGPPrivateFontCollection;\r\n  IImageFormat = IGPImageFormat;\r\n  TImageFormat = TGPImageFormat;\r\n  IImageCodecInfo = IGPImageCodecInfo;\r\n  IImageCodecInfoArray = IGPImageCodecInfoArray;\r\n  TImageCodecInfo = TGPImageCodecInfo;\r\n  IEncoderParameters = IGPEncoderParameters;\r\n  TEncoderParameterEnumerator = TGPEncoderParameterEnumerator;\r\n  TEncoderParameters = TGPEncoderParameters;\r\n  IColorPalette = IGPColorPalette;\r\n  TColorPalette = TGPColorPalette;\r\n  IPropertyItem = IGPPropertyItem;\r\n  TPropertyItem = TGPPropertyItem;\r\n  IFrameDimensions = IGPFrameDimensions;\r\n  IPropertyIdList = IGPPropertyIdList;\r\n  IPropertyItems = IGPPropertyItems;\r\n  IImage = IGPImage;\r\n  TImage = TGPImage;\r\n  IBitmap = IGPBitmap;\r\n  TBitmap = TGPBitmap;\r\n  ICustomLineCap = IGPCustomLineCap;\r\n  TCustomLineCap = TGPCustomLineCap;\r\n  IAdjustableArrowCap = IGPAdjustableArrowCap;\r\n  TAdjustableArrowCap = TGPAdjustableArrowCap;\r\n  ICachedBitmap = IGPCachedBitmap;\r\n  TCachedBitmap = TGPCachedBitmap;\r\n  IMetafile = IGPMetafile;\r\n  TMetafile = TGPMetafile;\r\n  IImageAttributes = IGPImageAttributes;\r\n  TImageAttributes = TGPImageAttributes;\r\n  TMatrixElements = TGPMatrixElements;\r\n  TPlgPointsF = TGPPlgPointsF;\r\n  TPlgPoints = TGPPlgPoints;\r\n  IMatrix = IGPMatrix;\r\n  TMatrix = TGPMatrix;\r\n  IBrush = IGPBrush;\r\n  TBrush = TGPBrush;\r\n  ISolidBrush = IGPSolidBrush;\r\n  TSolidBrush = TGPSolidBrush;\r\n  ITextureBrush = IGPTextureBrush;\r\n  TTextureBrush = TGPTextureBrush;\r\n  TLinearColors = TGPLinearColors;\r\n  IBlend = IGPBlend;\r\n  TBlend = TGPBlend;\r\n  IColorBlend = IGPColorBlend;\r\n  TColorBlend = TGPColorBlend;\r\n  ILinearGradientBrush = IGPLinearGradientBrush;\r\n  TLinearGradientBrush = TGPLinearGradientBrush;\r\n  IHatchBrush = IGPHatchBrush;\r\n  THatchBrush = TGPHatchBrush;\r\n  IDashPattern = IGPDashPattern;\r\n  ICompoundArray = IGPCompoundArray;\r\n  IPen = IGPPen;\r\n  TPen = TGPPen;\r\n  ITabStops = IGPTabStops;\r\n  ICharacterRanges = IGPCharacterRanges;\r\n  IStringFormat = IGPStringFormat;\r\n  TStringFormat = TGPStringFormat;\r\n  IPathTypes = IGPPathTypes;\r\n  IPathPoints = IGPPathPoints;\r\n  IPathPointsI = IGPPathPointsI;\r\n  IPathData = IGPPathData;\r\n  TPathData = TGPPathData;\r\n  IGraphicsPath = IGPGraphicsPath;\r\n  TGraphicsPath = TGPGraphicsPath;\r\n  IGraphicsPathIterator = IGPGraphicsPathIterator;\r\n  TGraphicsPathIterator = TGPGraphicsPathIterator;\r\n  IColors = IGPColors;\r\n  IPathGradientBrush = IGPPathGradientBrush;\r\n  TPathGradientBrush = TGPPathGradientBrush;\r\n  IRegions = IGPRegions;\r\n  IGraphics = IGPGraphics;\r\n  TGraphics = TGPGraphics;\r\n{$IF (GDIPVER >= $0110)}\r\n  TConvertToEmfPlusFlags = TGPConvertToEmfPlusFlags;\r\n  TPaletteType = TGPPaletteType;\r\n  TDitherType = TGPDitherType;\r\n  TItemDataPosition = TGPItemDataPosition;\r\n  TImageItemData = TGPImageItemData;\r\n  PImageItemData = PGPImageItemData;\r\n  TColorChannelLUT = TGPColorChannelLUT;\r\n  THistogramFormat = TGPHistogramFormat;\r\n  IHistogram = IGPHistogram;\r\n  THistogram = TGPHistogram;\r\n  TSharpenParams = TGPSharpenParams;\r\n  PSharpenParams = PGPSharpenParams;\r\n  TBlurParams = TGPBlurParams;\r\n  PBlurParams = PGPBlurParams;\r\n  TBrightnessContrastParams = TGPBrightnessContrastParams;\r\n  PBrightnessContrastParams = PGPBrightnessContrastParams;\r\n  TRedEyeCorrectionParams = TGPRedEyeCorrectionParams;\r\n  PRedEyeCorrectionParams = PGPRedEyeCorrectionParams;\r\n  THueSaturationLightnessParams = TGPHueSaturationLightnessParams;\r\n  PHueSaturationLightnessParams = PGPHueSaturationLightnessParams;\r\n  TTintParams = TGPTintParams;\r\n  PTintParams = PGPTintParams;\r\n  TLevelsParams = TGPLevelsParams;\r\n  PLevelsParams = PGPLevelsParams;\r\n  TColorBalanceParams = TGPColorBalanceParams;\r\n  PColorBalanceParams = PGPColorBalanceParams;\r\n  TColorLUTParams = TGPColorLUTParams;\r\n  PColorLUTParams = PGPColorLUTParams;\r\n  TCurveAdjustments = TGPCurveAdjustments;\r\n  TCurveChannel = TGPCurveChannel;\r\n  TColorCurveParams = TGPColorCurveParams;\r\n  PColorCurveParams = PGPColorCurveParams;\r\n  IEffect = IGPEffect;\r\n  TEffect = TGPEffect;\r\n  IBlur = IGPBlur;\r\n  TBlur = TGPBlur;\r\n  ISharpen = IGPSharpen;\r\n  TSharpen = TGPSharpen;\r\n  IRedEyeCorrection = IGPRedEyeCorrection;\r\n  TRedEyeCorrection = TGPRedEyeCorrection;\r\n  IBrightnessContrast = IGPBrightnessContrast;\r\n  TBrightnessContrast = TGPBrightnessContrast;\r\n  IHueSaturationLightness = IGPHueSaturationLightness;\r\n  THueSaturationLightness = TGPHueSaturationLightness;\r\n  ILevels = IGPLevels;\r\n  TLevels = TGPLevels;\r\n  ITint = IGPTint;\r\n  TTint = TGPTint;\r\n  IColorBalance = IGPColorBalance;\r\n  TColorBalance = TGPColorBalance;\r\n  IColorMatrixEffect = IGPColorMatrixEffect;\r\n  TColorMatrixEffect = TGPColorMatrixEffect;\r\n  IColorLUT = IGPColorLUT;\r\n  TColorLUT = TGPColorLUT;\r\n  IColorCurve = IGPColorCurve;\r\n  TColorCurve = TGPColorCurve;\r\n{$IFEND} // (GDIPVER >= $0110)\r\n{$ENDIF} // GDIP_ALIAS\r\n{$ENDREGION 'Aliases'}\r\n\r\nimplementation\r\n\r\n{$POINTERMATH ON}\r\n\r\n{$REGION 'Support classes'}\r\n\r\n{ TGPArray.TEnumerator }\r\n\r\nconstructor TGPArray.TEnumerator.Create(const AArray: TGPArray);\r\nbegin\r\n  inherited Create;\r\n  FArray := AArray;\r\n  FIndex := -1;\r\nend;\r\n\r\nfunction TGPArray.TEnumerator.DoGetCurrent: T;\r\nbegin\r\n  Result := GetCurrent;\r\nend;\r\n\r\nfunction TGPArray.TEnumerator.DoMoveNext: Boolean;\r\nbegin\r\n  Result := MoveNext;\r\nend;\r\n\r\nfunction TGPArray.TEnumerator.GetCurrent: T;\r\nbegin\r\n  Result := FArray.GetItem(FIndex);\r\nend;\r\n\r\nfunction TGPArray.TEnumerator.MoveNext: Boolean;\r\nbegin\r\n  if (FIndex >= FArray.GetCount) then\r\n    Exit(False);\r\n  Inc(FIndex);\r\n  Result := (FIndex < FArray.GetCount);\r\nend;\r\n\r\n{ TGPArray }\r\n\r\nconstructor TGPArray.Create(const Count: Integer);\r\nbegin\r\n  inherited Create;\r\n  SetLength(FItems, Count);\r\nend;\r\n\r\nfunction TGPArray.GetCount: Integer;\r\nbegin\r\n  Result := Length(FItems);\r\nend;\r\n\r\nfunction TGPArray.GetEnumerator: TEnumerator;\r\nbegin\r\n  Result := TEnumerator.Create(Self);\r\nend;\r\n\r\nfunction TGPArray.GetItem(const Index: Integer): T;\r\nbegin\r\n  Result := FItems[Index];\r\nend;\r\n\r\nfunction TGPArray.GetItemPtr: Pointer;\r\nbegin\r\n  Result := @FItems[0];\r\nend;\r\n\r\nprocedure TGPArray.SetCount(const Value: Integer);\r\nbegin\r\n  if (Value <> Length(FItems)) then\r\n    SetLength(FItems, Value);\r\nend;\r\n\r\nprocedure TGPArray.SetItem(const Index: Integer; const Value: T);\r\nbegin\r\n  FItems[Index] := Value;\r\nend;\r\n\r\n{ TGPBuffer }\r\n\r\nconstructor TGPBuffer.Create(const Data: Pointer; const Size: Cardinal);\r\nbegin\r\n  inherited Create;\r\n  FData := Data;\r\n  FSize := Size;\r\nend;\r\n\r\ndestructor TGPBuffer.Destroy;\r\nbegin\r\n  FreeMem(FData);\r\n  inherited;\r\nend;\r\n\r\nfunction TGPBuffer.GetData: Pointer;\r\nbegin\r\n  Result := FData;\r\nend;\r\n\r\nfunction TGPBuffer.GetSize: Cardinal;\r\nbegin\r\n  Result := FSize;\r\nend;\r\n\r\n{$ENDREGION 'Support classes'}\r\n\r\n{$REGION 'Utilities'}\r\n\r\nprocedure RaiseGdipError(const Status: TGPStatus);\r\nbegin\r\n  raise EGdipError.Create(Status);\r\nend;\r\n\r\nprocedure GdipCheck(const Status: TGPStatus); inline;\r\nbegin\r\n  if (Status <> Ok) then\r\n    RaiseGdipError(Status);\r\nend;\r\n\r\nfunction GdipHandle(const GpObject: IGdiplusBase): GpNativeHandle;\r\nbegin\r\n  if Assigned(GpObject) then\r\n    Result := GpObject.NativeHandle\r\n  else\r\n    Result := nil;\r\nend;\r\n{ EGdipError }\r\n\r\nconstructor EGdipError.Create(const Status: TGPStatus);\r\nvar\r\n  S: String;\r\nbegin\r\n  case Status of\r\n    GenericError:\r\n      S := 'Generic Error';\r\n    InvalidParameter:\r\n      S := 'One of the arguments passed to the method was not valid';\r\n    OutOfMemory:\r\n      S := 'Out of Memory';\r\n    ObjectBusy:\r\n      S := 'One of the arguments is already in use in another thread';\r\n    InsufficientBuffer:\r\n      S := 'The specified buffer is not large enough to hold the data to be received';\r\n    NotImplemented:\r\n      S := 'Method is not implemented';\r\n    Win32Error:\r\n      S := 'Win32 Error: ' + SysErrorMessage(GetLastError);\r\n    WrongState:\r\n      S := 'The object is in an invalid state';\r\n    Aborted:\r\n      S := 'The method was aborted';\r\n    FileNotFound:\r\n      S := 'The specified image file or metafile cannot be found';\r\n    ValueOverflow:\r\n      S := 'The method performed an arithmetic operation that produces a numeric overflow';\r\n    AccessDenied:\r\n      S := 'A write operation is not allowed on the specified file';\r\n    UnknownImageFormat:\r\n      S := 'The specified image file format is not known';\r\n    FontFamilyNotFound:\r\n      S := 'The specified font family cannot be found';\r\n    FontStyleNotFound:\r\n      S := 'The specified style is not available for the specified font family';\r\n    NotTrueTypeFont:\r\n      S := 'The specified font is not a TrueType font';\r\n    UnsupportedGdiplusVersion:\r\n      S := 'The version of GDI+ installed on the system is incompatible with the requested version';\r\n    GdiplusNotInitialized:\r\n      S := 'GDI+ is not initialized';\r\n    PropertyNotFound:\r\n      S := 'The specified property does not exist in the image';\r\n    PropertyNotSupported:\r\n      S := 'The specified property is not supported by the format of the image';\r\n    {$IF (GDIPVER >= $0110)}\r\n    ProfileNotFound:\r\n      S := 'The color profile required to save an image in CMYK format was not found';\r\n    {$IFEND}\r\n  else\r\n    S := 'Unknown error: ' + IntToStr(Ord(Status));\r\n  end;\r\n  inherited Create('(GDI+ Error) ' + S);\r\nend;\r\n{$ENDREGION 'Utilities'}\r\n\r\n{$REGION 'GdiplusBase.h'}\r\n(*****************************************************************************\r\n * GdiplusBase.h\r\n * GDI+ base memory allocation class\r\n *****************************************************************************)\r\n\r\n{ TGdiplusBase }\r\n\r\nconstructor TGdiplusBase.Create;\r\nbegin\r\n  inherited Create;\r\nend;\r\n\r\nprocedure TGdiplusBase.FreeInstance;\r\nbegin\r\n  CleanupInstance;\r\n  GdipFree(Self);\r\nend;\r\n\r\nfunction TGdiplusBase.GetNativeHandle: GpNativeHandle;\r\nbegin\r\n  Result := FNativeHandle;\r\nend;\r\n\r\nclass function TGdiplusBase.NewInstance: TObject;\r\nbegin\r\n  Result := InitInstance(GdipAlloc(InstanceSize));\r\n\r\n  { Set an implicit refcount so that refcounting during construction won't\r\n    destroy the object (see TInterfacedObject.NewInstance) }\r\n  TGdiplusBase(Result).FRefCount := 1;\r\nend;\r\n\r\nprocedure TGdiplusBase.SetNativeHandle(const Value: GpNativeHandle);\r\nbegin\r\n  FNativeHandle := Value;\r\nend;\r\n\r\n{$ENDREGION 'GdiplusBase.h'}\r\n\r\n{$REGION 'GdiplusEnums.h'}\r\n(*****************************************************************************\r\n * GdiplusEnums.h\r\n * GDI+ Enumeration Types\r\n *****************************************************************************)\r\n\r\nfunction ObjectTypeIsValid(const ObjectType: TGPObjectType): Boolean; inline;\r\nbegin\r\n  Result := (ObjectType >= ObjectTypeMin) and (ObjectType <= ObjectTypeMax);\r\nend;\r\n{$ENDREGION 'GdiplusEnums.h' }\r\n\r\n{$REGION 'GdiplusTypes.h'}\r\n\r\n{ TGPSizeF }\r\n\r\nclass operator TGPSizeF.Add(const A, B: TGPSizeF): TGPSizeF;\r\nbegin\r\n  Result.Initialize(A.Width + B.Width, A.Height + B.Height);\r\nend;\r\n\r\nclass function TGPSizeF.Create(const Size: TGPSizeF): TGPSizeF;\r\nbegin\r\n  Result.Initialize(Size);\r\nend;\r\n\r\nclass function TGPSizeF.Create(const AWidth, AHeight: Single): TGPSizeF;\r\nbegin\r\n  Result.Initialize(AWidth, AHeight);\r\nend;\r\n\r\nfunction TGPSizeF.Empty: Boolean;\r\nbegin\r\n  Result := (Width = 0) and (Height = 0);\r\nend;\r\n\r\nfunction TGPSizeF.Equals(const Size: TGPSizeF): Boolean;\r\nbegin\r\n  Result := (Width = Size.Width) and (Height = Size.Height);\r\nend;\r\n\r\nprocedure TGPSizeF.Initialize;\r\nbegin\r\n  Width := 0;\r\n  Height := 0;\r\nend;\r\n\r\nprocedure TGPSizeF.Initialize(const AWidth, AHeight: Single);\r\nbegin\r\n  Width := AWidth;\r\n  Height := AHeight;\r\nend;\r\n\r\nprocedure TGPSizeF.Initialize(const Size: TGPSizeF);\r\nbegin\r\n  Width := Size.Width;\r\n  Height := Size.Height;\r\nend;\r\n\r\nclass operator TGPSizeF.Subtract(const A, B: TGPSizeF): TGPSizeF;\r\nbegin\r\n  Result.Initialize(A.Width - B.Width, A.Height - B.Height);\r\nend;\r\n\r\n{ TGPSize }\r\n\r\nclass operator TGPSize.Add(const A, B: TGPSize): TGPSize;\r\nbegin\r\n  Result.Initialize(A.Width + B.Width, A.Height + B.Height);\r\nend;\r\n\r\nclass function TGPSize.Create(const Size: TGPSize): TGPSize;\r\nbegin\r\n  Result.Initialize(Size);\r\nend;\r\n\r\nclass function TGPSize.Create(const AWidth, AHeight: Integer): TGPSize;\r\nbegin\r\n  Result.Initialize(AWidth, AHeight);\r\nend;\r\n\r\nfunction TGPSize.Empty: Boolean;\r\nbegin\r\n  Result := (Width = 0) and (Height = 0);\r\nend;\r\n\r\nfunction TGPSize.Equals(const Size: TGPSize): Boolean;\r\nbegin\r\n  Result := (Width = Size.Width) and (Height = Size.Height);\r\nend;\r\n\r\nprocedure TGPSize.Initialize;\r\nbegin\r\n  Width := 0;\r\n  Height := 0;\r\nend;\r\n\r\nprocedure TGPSize.Initialize(const AWidth, AHeight: Integer);\r\nbegin\r\n  Width := AWidth;\r\n  Height := AHeight;\r\nend;\r\n\r\nprocedure TGPSize.Initialize(const Size: TGPSize);\r\nbegin\r\n  Width := Size.Width;\r\n  Height := Size.Height;\r\nend;\r\n\r\nclass operator TGPSize.Subtract(const A, B: TGPSize): TGPSize;\r\nbegin\r\n  Result.Initialize(A.Width - B.Width, A.Height - B.Height);\r\nend;\r\n\r\n{ TGPPointF }\r\n\r\nclass operator TGPPointF.Add(const A, B: TGPPointF): TGPPointF;\r\nbegin\r\n  Result.Initialize(A.X + B.X, A.Y + B.Y);\r\nend;\r\n\r\nclass function TGPPointF.Create(const Point: TGPPointF): TGPPointF;\r\nbegin\r\n  Result.Initialize(Point);\r\nend;\r\n\r\nclass function TGPPointF.Create(const Size: TGPSizeF): TGPPointF;\r\nbegin\r\n  Result.Initialize(Size);\r\nend;\r\n\r\nclass function TGPPointF.Create(const AX, AY: Single): TGPPointF;\r\nbegin\r\n  Result.Initialize(AX, AY);\r\nend;\r\n\r\nfunction TGPPointF.Equals(const Point: TGPPointF): Boolean;\r\nbegin\r\n  Result := (X = Point.X) and (Y = Point.Y);\r\nend;\r\n\r\nprocedure TGPPointF.Initialize;\r\nbegin\r\n  X := 0;\r\n  Y := 0;\r\nend;\r\n\r\nprocedure TGPPointF.Initialize(const Point: TGPPointF);\r\nbegin\r\n  X := Point.X;\r\n  Y := Point.Y;\r\nend;\r\n\r\nprocedure TGPPointF.Initialize(const AX, AY: Single);\r\nbegin\r\n  X := AX;\r\n  Y := AY;\r\nend;\r\n\r\nprocedure TGPPointF.Initialize(const Size: TGPSizeF);\r\nbegin\r\n  X := Size.Width;\r\n  Y := Size.Height;\r\nend;\r\n\r\nclass operator TGPPointF.Subtract(const A, B: TGPPointF): TGPPointF;\r\nbegin\r\n  Result.Initialize(A.X - B.X, A.Y - B.Y);\r\nend;\r\n\r\n{ TGPPoint }\r\n\r\nclass operator TGPPoint.Add(const A, B: TGPPoint): TGPPoint;\r\nbegin\r\n  Result.Initialize(A.X + B.X, A.Y + B.Y);\r\nend;\r\n\r\nclass function TGPPoint.Create(const Point: TGPPoint): TGPPoint;\r\nbegin\r\n  Result.Initialize(Point);\r\nend;\r\n\r\nclass function TGPPoint.Create(const Size: TGPSize): TGPPoint;\r\nbegin\r\n  Result.Initialize(Size);\r\nend;\r\n\r\nclass function TGPPoint.Create(const AX, AY: Integer): TGPPoint;\r\nbegin\r\n  Result.Initialize(AX, AY);\r\nend;\r\n\r\nfunction TGPPoint.Equals(const Point: TGPPoint): Boolean;\r\nbegin\r\n  Result := (X = Point.X) and (Y = Point.Y);\r\nend;\r\n\r\nprocedure TGPPoint.Initialize;\r\nbegin\r\n  X := 0;\r\n  Y := 0;\r\nend;\r\n\r\nprocedure TGPPoint.Initialize(const Point: TGPPoint);\r\nbegin\r\n  X := Point.X;\r\n  Y := Point.Y;\r\nend;\r\n\r\nprocedure TGPPoint.Initialize(const AX, AY: Integer);\r\nbegin\r\n  X := AX;\r\n  Y := AY;\r\nend;\r\n\r\nprocedure TGPPoint.Initialize(const Size: TGPSize);\r\nbegin\r\n  X := Size.Width;\r\n  Y := Size.Height;\r\nend;\r\n\r\nclass operator TGPPoint.Subtract(const A, B: TGPPoint): TGPPoint;\r\nbegin\r\n  Result.Initialize(A.X - B.X, A.Y - B.Y);\r\nend;\r\n\r\n{ TGPRectF }\r\n\r\nfunction TGPRectF.Clone: TGPRectF;\r\nbegin\r\n  Result := Self;\r\nend;\r\n\r\nfunction TGPRectF.Contains(const Rect: TGPRectF): Boolean;\r\nbegin\r\n  Result := (X <= Rect.X) and (Rect.Right <= Right)\r\n        and (Y <= Rect.Y) and (Rect.Bottom <= Bottom);\r\nend;\r\n\r\nclass function TGPRectF.Create(const AX, AY, AWidth, AHeight: Single): TGPRectF;\r\nbegin\r\n  Result.Initialize(AX, AY, AWidth, AHeight);\r\nend;\r\n\r\nclass function TGPRectF.Create(const Location: TGPPointF;\r\n  const Size: TGPSizeF): TGPRectF;\r\nbegin\r\n  Result.Initialize(Location, Size);\r\nend;\r\n\r\nfunction TGPRectF.Contains(const Point: TGPPointF): Boolean;\r\nbegin\r\n  Result := Contains(Point.X, Point.Y);\r\nend;\r\n\r\nfunction TGPRectF.Contains(const AX, AY: Single): Boolean;\r\nbegin\r\n  Result := (AX >= X) and (AX < (X + Width)) and (AY >= Y) and (AY < (Y + Height));\r\nend;\r\n\r\nfunction TGPRectF.Equals(const Rect: TGPRectF): Boolean;\r\nbegin\r\n  Result := (X = Rect.X) and (Y = Rect.Y) and (Width = Rect.Width) and (Height = Rect.Height);\r\nend;\r\n\r\nfunction TGPRectF.GetBottom: Single;\r\nbegin\r\n  Result := Y + Height;\r\nend;\r\n\r\nfunction TGPRectF.GetBounds: TGPRectF;\r\nbegin\r\n  Result := Self;\r\nend;\r\n\r\nfunction TGPRectF.GetLocation: TGPPointF;\r\nbegin\r\n  Result.X := X;\r\n  Result.Y := Y;\r\nend;\r\n\r\nfunction TGPRectF.GetRight: Single;\r\nbegin\r\n  Result := X + Width;\r\nend;\r\n\r\nfunction TGPRectF.GetSize: TGPSizeF;\r\nbegin\r\n  Result.Width := Width;\r\n  Result.Height := Height;\r\nend;\r\n\r\nprocedure TGPRectF.Inflate(const Point: TGPPointF);\r\nbegin\r\n  Inflate(Point.X, Point.Y);\r\nend;\r\n\r\nprocedure TGPRectF.Inflate(const DX, DY: Single);\r\nbegin\r\n  X := X - DX;\r\n  Y := Y - DY;\r\n  Width := Width + (2 * DX);\r\n  Height := Height + (2 * DY);\r\nend;\r\n\r\nprocedure TGPRectF.Initialize;\r\nbegin\r\n  X := 0;\r\n  Y := 0;\r\n  Width := 0;\r\n  Height := 0;\r\nend;\r\n\r\nprocedure TGPRectF.Initialize(const AX, AY, AWidth, AHeight: Single);\r\nbegin\r\n  X := AX;\r\n  Y := AY;\r\n  Width := AWidth;\r\n  Height := AHeight;\r\nend;\r\n\r\nprocedure TGPRectF.Inflate(const DXY: Single);\r\nbegin\r\n  Inflate(DXY, DXY);\r\nend;\r\n\r\nprocedure TGPRectF.Initialize(const Location: TGPPointF; const Size: TGPSizeF);\r\nbegin\r\n  X := Location.X;\r\n  Y := Location.Y;\r\n  Width := Size.Width;\r\n  Height := Size.Height;\r\nend;\r\n\r\nprocedure TGPRectF.InitializeFromLTRB(const Left, Top, Right, Bottom: Single);\r\nbegin\r\n  X := Left;\r\n  Y := Top;\r\n  Width := Right - Left;\r\n  Height := Bottom - Top;\r\nend;\r\n\r\nclass function TGPRectF.Intersect(out C: TGPRectF; const A, B: TGPRectF): Boolean;\r\nvar\r\n  Right, Bottom, Left, Top: Single;\r\nbegin\r\n  Right := Min(A.Right, B.Right);\r\n  Bottom := Min(A.Bottom, B.Bottom);\r\n  Left := Max(A.Left, B.Left);\r\n  Top := Max(A.Top, B.Top);\r\n\r\n  C.X := Left;\r\n  C.Y := Top;\r\n  C.Width := Right - Left;\r\n  C.Height := Bottom - Top;\r\n  Result := (not C.IsEmptyArea);\r\nend;\r\n\r\nfunction TGPRectF.Intersect(const Rect: TGPRectF): Boolean;\r\nbegin\r\n  Result := Intersect(Self, Self, Rect);\r\nend;\r\n\r\nfunction TGPRectF.IntersectsWith(const Rect: TGPRectF): Boolean;\r\nbegin\r\n  Result := (Left < Rect.Right) and (Top < Rect.Bottom)\r\n        and (Right > Rect.Left) and (Bottom > Rect.Top);\r\nend;\r\n\r\nfunction TGPRectF.IsEmptyArea: Boolean;\r\nbegin\r\n  Result := (Width <= REAL_EPSILON) or (Height <= REAL_EPSILON);\r\nend;\r\n\r\nprocedure TGPRectF.Offset(const DX, DY: Single);\r\nbegin\r\n  X := X + DX;\r\n  Y := Y + DY;\r\nend;\r\n\r\nfunction TGPRectF.Union(const Rect: TGPRectF): Boolean;\r\nbegin\r\n  Result := Union(Self, Self, Rect);\r\nend;\r\n\r\nprocedure TGPRectF.Offset(const Point: TGPPointF);\r\nbegin\r\n  Offset(Point.X, Point.Y);\r\nend;\r\n\r\nclass function TGPRectF.Union(out C: TGPRectF; const A, B: TGPRectF): Boolean;\r\nvar\r\n  Right, Bottom, Left, Top: Single;\r\nbegin\r\n  Right := Max(A.Right, B.Right);\r\n  Bottom := Max(A.Bottom, B.Bottom);\r\n  Left := Min(A.Left, B.Left);\r\n  Top := Min(A.Top, B.Top);\r\n\r\n  C.X := Left;\r\n  C.Y := Top;\r\n  C.Width := Right - Left;\r\n  C.Height := Bottom - Top;\r\n  Result := (not C.IsEmptyArea);\r\nend;\r\n\r\n{ TGPRect }\r\n\r\nfunction TGPRect.Clone: TGPRect;\r\nbegin\r\n  Result := Self;\r\nend;\r\n\r\nfunction TGPRect.Contains(const Rect: TGPRect): Boolean;\r\nbegin\r\n  Result := (X <= Rect.X) and (Rect.Right <= Right)\r\n        and (Y <= Rect.Y) and (Rect.Bottom <= Bottom);\r\nend;\r\n\r\nclass function TGPRect.Create(const AX, AY, AWidth, AHeight: Integer): TGPRect;\r\nbegin\r\n  Result.Initialize(AX, AY, AWidth, AHeight);\r\nend;\r\n\r\nclass function TGPRect.Create(const Location: TGPPoint; const Size: TGPSize): TGPRect;\r\nbegin\r\n  Result.Initialize(Location, Size);\r\nend;\r\n\r\nclass function TGPRect.Create(const Rect: Windows.TRect): TGPRect;\r\nbegin\r\n  Result.Initialize(Rect);\r\nend;\r\n\r\nfunction TGPRect.Contains(const Point: TGPPoint): Boolean;\r\nbegin\r\n  Result := Contains(Point.X, Point.Y);\r\nend;\r\n\r\nfunction TGPRect.Contains(const AX, AY: Integer): Boolean;\r\nbegin\r\n  Result := (AX >= X) and (AX < (X + Width)) and (AY >= Y) and (AY < (Y + Height));\r\nend;\r\n\r\nfunction TGPRect.Equals(const Rect: TGPRect): Boolean;\r\nbegin\r\n  Result := (X = Rect.X) and (Y = Rect.Y) and (Width = Rect.Width) and (Height = Rect.Height);\r\nend;\r\n\r\nfunction TGPRect.GetBottom: Integer;\r\nbegin\r\n  Result := Y + Height;\r\nend;\r\n\r\nfunction TGPRect.GetBounds: TGPRect;\r\nbegin\r\n  Result := Self;\r\nend;\r\n\r\nfunction TGPRect.GetLocation: TGPPoint;\r\nbegin\r\n  Result.X := X;\r\n  Result.Y := Y;\r\nend;\r\n\r\nfunction TGPRect.GetRight: Integer;\r\nbegin\r\n  Result := X + Width;\r\nend;\r\n\r\nfunction TGPRect.GetSize: TGPSize;\r\nbegin\r\n  Result.Width := Width;\r\n  Result.Height := Height;\r\nend;\r\n\r\nprocedure TGPRect.Inflate(const Point: TGPPoint);\r\nbegin\r\n  Inflate(Point.X, Point.Y);\r\nend;\r\n\r\nprocedure TGPRect.Inflate(const DX, DY: Integer);\r\nbegin\r\n  X := X - DX;\r\n  Y := Y - DY;\r\n  Width := Width + (2 * DX);\r\n  Height := Height + (2 * DY);\r\nend;\r\n\r\nprocedure TGPRect.Initialize;\r\nbegin\r\n  X := 0;\r\n  Y := 0;\r\n  Width := 0;\r\n  Height := 0;\r\nend;\r\n\r\nprocedure TGPRect.Initialize(const AX, AY, AWidth, AHeight: Integer);\r\nbegin\r\n  X := AX;\r\n  Y := AY;\r\n  Width := AWidth;\r\n  Height := AHeight;\r\nend;\r\n\r\nprocedure TGPRect.Initialize(const Location: TGPPoint; const Size: TGPSize);\r\nbegin\r\n  X := Location.X;\r\n  Y := Location.Y;\r\n  Width := Size.Width;\r\n  Height := Size.Height;\r\nend;\r\n\r\nprocedure TGPRect.Initialize(const Rect: Windows.TRect);\r\nbegin\r\n  X := Rect.Left;\r\n  Y := Rect.Top;\r\n  Width := Rect.Right - Rect.Left;\r\n  Height := Rect.Bottom - Rect.Top;\r\nend;\r\n\r\nprocedure TGPRect.InitializeFromLTRB(const Left, Top, Right, Bottom: Integer);\r\nbegin\r\n  X := Left;\r\n  Y := Top;\r\n  Width := Right - Left;\r\n  Height := Bottom - Top;\r\nend;\r\n\r\nclass function TGPRect.Intersect(out C: TGPRect; const A, B: TGPRect): Boolean;\r\nvar\r\n  Right, Bottom, Left, Top: Integer;\r\nbegin\r\n  Right := Min(A.Right, B.Right);\r\n  Bottom := Min(A.Bottom, B.Bottom);\r\n  Left := Max(A.Left, B.Left);\r\n  Top := Max(A.Top, B.Top);\r\n\r\n  C.X := Left;\r\n  C.Y := Top;\r\n  C.Width := Right - Left;\r\n  C.Height := Bottom - Top;\r\n  Result := (not C.IsEmptyArea);\r\nend;\r\n\r\nfunction TGPRect.Intersect(const Rect: TGPRect): Boolean;\r\nbegin\r\n  Result := Intersect(Self, Self, Rect);\r\nend;\r\n\r\nfunction TGPRect.IntersectsWith(const Rect: TGPRect): Boolean;\r\nbegin\r\n  Result := (Left < Rect.Right) and (Top < Rect.Bottom)\r\n        and (Right > Rect.Left) and (Bottom > Rect.Top);\r\nend;\r\n\r\nfunction TGPRect.IsEmptyArea: Boolean;\r\nbegin\r\n  Result := (Width <= REAL_EPSILON) or (Height <= REAL_EPSILON);\r\nend;\r\n\r\nprocedure TGPRect.Offset(const DX, DY: Integer);\r\nbegin\r\n  X := X + DX;\r\n  Y := Y + DY;\r\nend;\r\n\r\nfunction TGPRect.Union(const Rect: TGPRect): Boolean;\r\nbegin\r\n  Result := Union(Self, Self, Rect);\r\nend;\r\n\r\nprocedure TGPRect.Offset(const Point: TGPPoint);\r\nbegin\r\n  Offset(Point.X, Point.Y);\r\nend;\r\n\r\nclass function TGPRect.Union(out C: TGPRect; const A, B: TGPRect): Boolean;\r\nvar\r\n  Right, Bottom, Left, Top: Integer;\r\nbegin\r\n  Right := Max(A.Right, B.Right);\r\n  Bottom := Max(A.Bottom, B.Bottom);\r\n  Left := Min(A.Left, B.Left);\r\n  Top := Min(A.Top, B.Top);\r\n\r\n  C.X := Left;\r\n  C.Y := Top;\r\n  C.Width := Right - Left;\r\n  C.Height := Bottom - Top;\r\n  Result := (not C.IsEmptyArea);\r\nend;\r\n\r\n{ TGPCharacterRange }\r\n\r\nprocedure TGPCharacterRange.Initialize;\r\nbegin\r\n  First := 0;\r\n  Length := 0;\r\nend;\r\n\r\nprocedure TGPCharacterRange.Initialize(const AFirst, ALength: Integer);\r\nbegin\r\n  First := AFirst;\r\n  Length := ALength;\r\nend;\r\n{$ENDREGION 'GdiplusTypes.h'}\r\n\r\n{$REGION 'GdiplusInit.h'}\r\n\r\n{ TGdiplusStartupInput }\r\n\r\nprocedure TGdiplusStartupInput.Intialize(\r\n  const ADebugEventCallback: TGPDebugEventProc; const ASuppressBackgroundThread,\r\n  ASuppressExternalCodecs: Boolean);\r\nbegin\r\n  GdiplusVersion := 1;\r\n  DebugEventCallback := ADebugEventCallback;\r\n  SuppressBackgroundThread := ASuppressBackgroundThread;\r\n  SuppressExternalCodecs := ASuppressExternalCodecs;\r\nend;\r\n\r\n{$IF (GDIPVER >= $0110)}\r\n\r\n{ TGdiplusStartupInputEx }\r\n\r\nprocedure TGdiplusStartupInputEx.Intialize(const AStartupParameters: Integer;\r\n  const ADebugEventCallback: TGPDebugEventProc; const ASuppressBackgroundThread,\r\n  ASuppressExternalCodecs: Boolean);\r\nbegin\r\n  GdiplusVersion := 2;\r\n  DebugEventCallback := ADebugEventCallback;\r\n  SuppressBackgroundThread := ASuppressBackgroundThread;\r\n  SuppressExternalCodecs := ASuppressExternalCodecs;\r\n  StartupParameters := AStartupParameters;\r\nend;\r\n{$IFEND}\r\n\r\n{$ENDREGION 'GdiplusInit.h'}\r\n\r\n{$REGION 'GdiplusPixelFormats.h'}\r\nfunction GetPixelFormatSize(const PixFmt: TGPPixelFormat): Integer; inline;\r\nbegin\r\n  Result := (PixFmt shr 8) and $FF;\r\nend;\r\n\r\nfunction IsIndexedPixelFormat(const PixFmt: TGPPixelFormat): Boolean; inline;\r\nbegin\r\n  Result := ((PixFmt and PixelFormatIndexed) <> 0);\r\nend;\r\n\r\nfunction IsAlphaPixelFormat(const PixFmt: TGPPixelFormat): Boolean; inline;\r\nbegin\r\n  Result := ((PixFmt and PixelFormatAlpha) <> 0);\r\nend;\r\n\r\nfunction IsExtendedPixelFormat(const PixFmt: TGPPixelFormat): Boolean; inline;\r\nbegin\r\n  Result := ((PixFmt and PixelFormatExtended) <> 0);\r\nend;\r\n\r\nfunction IsCanonicalPixelFormat(const PixFmt: TGPPixelFormat): Boolean; inline;\r\nbegin\r\n  Result := ((PixFmt and PixelFormatCanonical) <> 0);\r\nend;\r\n\r\n{$ENDREGION 'GdiplusPixelFormats.h'}\r\n\r\n{$REGION 'GdiplusColor.h'}\r\n\r\n{ TGPColor }\r\n\r\nclass function TGPColor.Create(const AArgb: ARGB): TGPColor;\r\nbegin\r\n  Result.FArgb := AArgb;\r\nend;\r\n\r\nclass function TGPColor.Create(const Color: TColor): TGPColor;\r\nbegin\r\n  Result.SetColorRef(TColorRef(Color));\r\nend;\r\n\r\nclass function TGPColor.CreateFromColorRef(const ColorRef: TColorRef): TGPColor;\r\nbegin\r\n  Result.SetColorRef(ColorRef);\r\nend;\r\n\r\nclass function TGPColor.Create(const R, G, B: Byte): TGPColor;\r\nbegin\r\n  Result.FArgb := MakeARGB(255, R, G, B);\r\nend;\r\n\r\nclass function TGPColor.Create(const A, R, G, B: Byte): TGPColor;\r\nbegin\r\n  Result.FArgb := MakeARGB(A, R, G, B);\r\nend;\r\n\r\nfunction TGPColor.GetAlpha: Byte;\r\nbegin\r\n  Result := Byte(FArgb shr AlphaShift);\r\nend;\r\n\r\nfunction TGPColor.GetBlue: Byte;\r\nbegin\r\n  Result := Byte(FArgb shr BlueShift);\r\nend;\r\n\r\nfunction TGPColor.GetColorRef: TColorRef;\r\nbegin\r\n  Result := GetRed or (GetGreen shl 8) or (GetBlue shl 16);\r\nend;\r\n\r\nfunction TGPColor.GetGreen: Byte;\r\nbegin\r\n  Result := Byte(FArgb shr GreenShift);\r\nend;\r\n\r\nfunction TGPColor.GetRed: Byte;\r\nbegin\r\n  Result := Byte(FArgb shr RedShift);\r\nend;\r\n\r\nprocedure TGPColor.Initialize(const R, G, B: Byte);\r\nbegin\r\n  FArgb := MakeARGB(255, R, G, B);\r\nend;\r\n\r\nprocedure TGPColor.Initialize;\r\nbegin\r\n  FArgb := Black;\r\nend;\r\n\r\nclass operator TGPColor.Implicit(const AArgb: ARGB): TGPColor;\r\nbegin\r\n  Result.FArgb := AArgb;\r\nend;\r\n\r\nclass operator TGPColor.Implicit(const Color: TGPColor): ARGB;\r\nbegin\r\n  Result := Color.FArgb;\r\nend;\r\n\r\nprocedure TGPColor.Initialize(const AArgb: ARGB);\r\nbegin\r\n  FArgb := AArgb;\r\nend;\r\n\r\nprocedure TGPColor.InitializeFromColorRef(const ColorRef: TColorRef);\r\nbegin\r\n  SetColorRef(ColorRef);\r\nend;\r\n\r\nprocedure TGPColor.Initialize(const A, R, G, B: Byte);\r\nbegin\r\n  FArgb := MakeARGB(A, R, G, B)\r\nend;\r\n\r\nclass function TGPColor.MakeARGB(const A, R, G, B: Byte): ARGB;\r\nbegin\r\n  Result := (ARGB(B) shl BlueShift) or\r\n            (ARGB(G) shl GreenShift) or\r\n            (ARGB(R) shl RedShift) or\r\n            (ARGB(A) shl AlphaShift);\r\nend;\r\n\r\nprocedure TGPColor.SetAlpha(const Value: Byte);\r\nbegin\r\n  FArgb := (FArgb and (not AlphaMask)) or (Value shl AlphaShift);\r\nend;\r\n\r\nprocedure TGPColor.SetBlue(const Value: Byte);\r\nbegin\r\n  FArgb := (FArgb and (not BlueMask)) or (Value shl BlueShift);\r\nend;\r\n\r\nprocedure TGPColor.SetColorRef(const Value: TColorRef);\r\nbegin\r\n  if (Value < 0) then\r\n    FArgb := GetSysColor(Value and $000000FF)\r\n  else\r\n    FArgb := Value;\r\n  FArgb := MakeARGB(255, Byte(FArgb), Byte(FArgb shr 8), Byte(FArgb shr 16));\r\nend;\r\n\r\nprocedure TGPColor.SetGreen(const Value: Byte);\r\nbegin\r\n  FArgb := (FArgb and (not GreenMask)) or (Value shl GreenShift);\r\nend;\r\n\r\nprocedure TGPColor.SetRed(const Value: Byte);\r\nbegin\r\n  FArgb := (FArgb and (not RedMask)) or (Value shl RedShift);\r\nend;\r\n\r\n{$ENDREGION 'GdiplusColor.h'}\r\n\r\n{$REGION 'GdiplusMetaHeader.h'}\r\n\r\n{ TGPMetafileHeader }\r\n\r\nfunction TGPMetafileHeader.GetBounds: TGPRect;\r\nbegin\r\n  Result.Initialize(FX, FY, FWidth, FHeight);\r\nend;\r\n\r\nfunction TGPMetafileHeader.GetEmfHeader: PEnhMetaHeader3;\r\nbegin\r\n  if (IsEmfOrEmfPlus) then\r\n    Result := @FHeader.EmfHeader\r\n  else\r\n    Result := nil;\r\nend;\r\n\r\nfunction TGPMetafileHeader.GetWmfHeader: PMetaHeader;\r\nbegin\r\n  if (IsWmf) then\r\n    Result := @FHeader.WmfHeader\r\n  else\r\n    Result := nil;\r\nend;\r\n\r\nfunction TGPMetafileHeader.IsDisplay: Boolean;\r\nbegin\r\n  Result := IsEmfPlus and ((FEmfPlusFlags and GDIP_EMFPLUSFLAGS_DISPLAY) <> 0);\r\nend;\r\n\r\nfunction TGPMetafileHeader.IsEmf: Boolean;\r\nbegin\r\n  Result := (FMetafileType = MetafileTypeEmf);\r\nend;\r\n\r\nfunction TGPMetafileHeader.IsEmfOrEmfPlus: Boolean;\r\nbegin\r\n  Result := (FMetafileType >= MetafileTypeEmf);\r\nend;\r\n\r\nfunction TGPMetafileHeader.IsEmfPlus: Boolean;\r\nbegin\r\n  Result := (FMetafileType >= MetafileTypeEmfPlusOnly);\r\nend;\r\n\r\nfunction TGPMetafileHeader.IsEmfPlusDual: Boolean;\r\nbegin\r\n  Result := (FMetafileType = MetafileTypeEmfPlusDual);\r\nend;\r\n\r\nfunction TGPMetafileHeader.IsEmfPlusOnly: Boolean;\r\nbegin\r\n  Result := (FMetafileType = MetafileTypeEmfPlusOnly);\r\nend;\r\n\r\nfunction TGPMetafileHeader.IsWmf: Boolean;\r\nbegin\r\n  Result := (FMetafileType in [MetafileTypeWmf, MetafileTypeWmfPlaceable]);\r\nend;\r\n\r\nfunction TGPMetafileHeader.IsWmfPlaceable: Boolean;\r\nbegin\r\n  Result := (FMetafileType = MetafileTypeWmfPlaceable);\r\nend;\r\n{$ENDREGION 'GdiplusMetaHeader.h'}\r\n\r\n{$REGION 'GdiplusColorMatrix.h'}\r\nprocedure TGPColorMatrix.SetToIdentity;\r\nbegin\r\n  FillChar(M, SizeOf(M), 0);\r\n  M[0,0] := 1;\r\n  M[1,1] := 1;\r\n  M[2,2] := 1;\r\n  M[3,3] := 1;\r\n  M[4,4] := 1;\r\nend;\r\n{$ENDREGION 'GdiplusColorMatrix.h'}\r\n\r\n{$REGION 'GdiplusEffects.h'}\r\n{$IF (GDIPVER >= $0110)}\r\n\r\n{ TGPEffect }\r\n\r\ndestructor TGPEffect.Destroy;\r\nbegin\r\n  ReleaseAuxData;\r\n\r\n  // Release the native Effect.\r\n  GdipCheck(GdipDeleteEffect(FNativeHandle));\r\n  inherited;\r\nend;\r\n\r\nfunction TGPEffect.GetAuxData: Pointer;\r\nbegin\r\n  Result := FAuxData;\r\nend;\r\n\r\nfunction TGPEffect.GetAuxDataSize: Integer;\r\nbegin\r\n  Result := FAuxDataSize;\r\nend;\r\n\r\nprocedure TGPEffect.GetParameters(var Size: Cardinal; Params: Pointer);\r\nbegin\r\n  GdipCheck(GdipGetEffectParameters(FNativeHandle, Size, Params));\r\nend;\r\n\r\nfunction TGPEffect.GetParameterSize: Cardinal;\r\nbegin\r\n  GdipCheck(GdipGetEffectParameterSize(FNativeHandle, Result));\r\nend;\r\n\r\nfunction TGPEffect.GetUseAuxData: Boolean;\r\nbegin\r\n  Result := FUseAuxData;\r\nend;\r\n\r\nprocedure TGPEffect.ReleaseAuxData;\r\nbegin\r\n  // pvData is allocated by ApplyEffect. Return the pointer so that\r\n  // it can be freed by the appropriate memory manager.\r\n  GdipFree(FAuxData);\r\n  FAuxData := nil;\r\n  FAuxDataSize := 0;\r\nend;\r\n\r\nprocedure TGPEffect.SetAuxData(const Data: Pointer; const Size: Integer);\r\nbegin\r\n  ReleaseAuxData;\r\n  FAuxData := Data;\r\n  FAuxDataSize := Size;\r\nend;\r\n\r\nprocedure TGPEffect.SetParameters(const Params: Pointer; const Size: Cardinal);\r\nbegin\r\n  GdipCheck(GdipSetEffectParameters(FNativeHandle, Params, Size));\r\nend;\r\n\r\nprocedure TGPEffect.SetUseAuxData(const Value: Boolean);\r\nbegin\r\n  FUseAuxData := Value;\r\nend;\r\n\r\n{ TGPBlur }\r\n\r\nconstructor TGPBlur.Create;\r\nbegin\r\n  inherited Create;\r\n  GdipCheck(GdipCreateEffect(BlurEffectGuid, FNativeHandle));\r\nend;\r\n\r\nfunction TGPBlur.GetParameters: TGPBlurParams;\r\nvar\r\n  Size: Cardinal;\r\nbegin\r\n  Size := SizeOf(Result);\r\n  inherited GetParameters(Size, @Result);\r\nend;\r\n\r\nprocedure TGPBlur.SetParameters(const Value: TGPBlurParams);\r\nbegin\r\n  inherited SetParameters(@Value, SizeOf(Value));\r\nend;\r\n\r\n{ TGPSharpen }\r\n\r\nconstructor TGPSharpen.Create;\r\nbegin\r\n  inherited Create;\r\n  GdipCheck(GdipCreateEffect(SharpenEffectGuid, FNativeHandle));\r\nend;\r\n\r\nfunction TGPSharpen.GetParameters: TGPSharpenParams;\r\nvar\r\n  Size: Cardinal;\r\nbegin\r\n  Size := SizeOf(Result);\r\n  inherited GetParameters(Size, @Result);\r\nend;\r\n\r\nprocedure TGPSharpen.SetParameters(const Value: TGPSharpenParams);\r\nbegin\r\n  inherited SetParameters(@Value, SizeOf(Value));\r\nend;\r\n\r\n{ TGPRedEyeCorrection }\r\n\r\nconstructor TGPRedEyeCorrection.Create;\r\nbegin\r\n  inherited Create;\r\n  GdipCheck(GdipCreateEffect(RedEyeCorrectionEffectGuid, FNativeHandle));\r\nend;\r\n\r\nfunction TGPRedEyeCorrection.GetParameters: TGPRedEyeCorrectionParams;\r\nvar\r\n  Size: Cardinal;\r\nbegin\r\n  Size := SizeOf(Result);\r\n  inherited GetParameters(Size, @Result);\r\nend;\r\n\r\nprocedure TGPRedEyeCorrection.SetParameters(const Value: TGPRedEyeCorrectionParams);\r\nbegin\r\n  inherited SetParameters(@Value, SizeOf(Value)\r\n    + (Value.NumberOfAreas * SizeOf(Windows.TRect)));\r\nend;\r\n\r\n{ TGPBrightnessContrast }\r\n\r\nconstructor TGPBrightnessContrast.Create;\r\nbegin\r\n  inherited Create;\r\n  GdipCheck(GdipCreateEffect(BrightnessContrastEffectGuid, FNativeHandle));\r\nend;\r\n\r\nfunction TGPBrightnessContrast.GetParameters: TGPBrightnessContrastParams;\r\nvar\r\n  Size: Cardinal;\r\nbegin\r\n  Size := SizeOf(Result);\r\n  inherited GetParameters(Size, @Result);\r\nend;\r\n\r\nprocedure TGPBrightnessContrast.SetParameters(\r\n  const Value: TGPBrightnessContrastParams);\r\nbegin\r\n  inherited SetParameters(@Value, SizeOf(Value));\r\nend;\r\n\r\n{ TGPHueSaturationLightness }\r\n\r\nconstructor TGPHueSaturationLightness.Create;\r\nbegin\r\n  inherited Create;\r\n  GdipCheck(GdipCreateEffect(HueSaturationLightnessEffectGuid, FNativeHandle));\r\nend;\r\n\r\nfunction TGPHueSaturationLightness.GetParameters: TGPHueSaturationLightnessParams;\r\nvar\r\n  Size: Cardinal;\r\nbegin\r\n  Size := SizeOf(Result);\r\n  inherited GetParameters(Size, @Result);\r\nend;\r\n\r\nprocedure TGPHueSaturationLightness.SetParameters(\r\n  const Value: TGPHueSaturationLightnessParams);\r\nbegin\r\n  inherited SetParameters(@Value, SizeOf(Value));\r\nend;\r\n\r\n{ TGPLevels }\r\n\r\nconstructor TGPLevels.Create;\r\nbegin\r\n  inherited Create;\r\n  GdipCheck(GdipCreateEffect(LevelsEffectGuid, FNativeHandle));\r\nend;\r\n\r\nfunction TGPLevels.GetParameters: TGPLevelsParams;\r\nvar\r\n  Size: Cardinal;\r\nbegin\r\n  Size := SizeOf(Result);\r\n  inherited GetParameters(Size, @Result);\r\nend;\r\n\r\nprocedure TGPLevels.SetParameters(const Value: TGPLevelsParams);\r\nbegin\r\n  inherited SetParameters(@Value, SizeOf(Value));\r\nend;\r\n\r\n{ TGPTint }\r\n\r\nconstructor TGPTint.Create;\r\nbegin\r\n  inherited Create;\r\n  GdipCheck(GdipCreateEffect(TintEffectGuid, FNativeHandle));\r\nend;\r\n\r\nfunction TGPTint.GetParameters: TGPTintParams;\r\nvar\r\n  Size: Cardinal;\r\nbegin\r\n  Size := SizeOf(Result);\r\n  inherited GetParameters(Size, @Result);\r\nend;\r\n\r\nprocedure TGPTint.SetParameters(const Value: TGPTintParams);\r\nbegin\r\n  inherited SetParameters(@Value, SizeOf(Value));\r\nend;\r\n\r\n{ TGPColorBalance }\r\n\r\nconstructor TGPColorBalance.Create;\r\nbegin\r\n  inherited Create;\r\n  GdipCheck(GdipCreateEffect(ColorBalanceEffectGuid, FNativeHandle));\r\nend;\r\n\r\nfunction TGPColorBalance.GetParameters: TGPColorBalanceParams;\r\nvar\r\n  Size: Cardinal;\r\nbegin\r\n  Size := SizeOf(Result);\r\n  inherited GetParameters(Size, @Result);\r\nend;\r\n\r\nprocedure TGPColorBalance.SetParameters(const Value: TGPColorBalanceParams);\r\nbegin\r\n  inherited SetParameters(@Value, SizeOf(Value));\r\nend;\r\n\r\n{ TGPColorMatrixEffect }\r\n\r\nconstructor TGPColorMatrixEffect.Create;\r\nbegin\r\n  inherited Create;\r\n  GdipCheck(GdipCreateEffect(ColorMatrixEffectGuid, FNativeHandle));\r\nend;\r\n\r\nfunction TGPColorMatrixEffect.GetParameters: TGPColorMatrix;\r\nvar\r\n  Size: Cardinal;\r\nbegin\r\n  Size := SizeOf(Result);\r\n  inherited GetParameters(Size, @Result);\r\nend;\r\n\r\nprocedure TGPColorMatrixEffect.SetParameters(const Value: TGPColorMatrix);\r\nbegin\r\n  inherited SetParameters(@Value, SizeOf(Value));\r\nend;\r\n\r\n{ TGPColorLUT }\r\n\r\nconstructor TGPColorLUT.Create;\r\nbegin\r\n  inherited Create;\r\n  GdipCheck(GdipCreateEffect(ColorLUTEffectGuid, FNativeHandle));\r\nend;\r\n\r\nfunction TGPColorLUT.GetParameters: TGPColorLUTParams;\r\nvar\r\n  Size: Cardinal;\r\nbegin\r\n  Size := SizeOf(Result);\r\n  inherited GetParameters(Size, @Result);\r\nend;\r\n\r\nprocedure TGPColorLUT.SetParameters(const Value: TGPColorLUTParams);\r\nbegin\r\n  inherited SetParameters(@Value, SizeOf(Value));\r\nend;\r\n\r\n{ TGPColorCurve }\r\n\r\nconstructor TGPColorCurve.Create;\r\nbegin\r\n  inherited Create;\r\n  GdipCheck(GdipCreateEffect(ColorCurveEffectGuid, FNativeHandle));\r\nend;\r\n\r\nfunction TGPColorCurve.GetParameters: TGPColorCurveParams;\r\nvar\r\n  Size: Cardinal;\r\nbegin\r\n  Size := SizeOf(Result);\r\n  inherited GetParameters(Size, @Result);\r\nend;\r\n\r\nprocedure TGPColorCurve.SetParameters(const Value: TGPColorCurveParams);\r\nbegin\r\n  inherited SetParameters(@Value, SizeOf(Value));\r\nend;\r\n\r\n{$IFEND}\r\n{$ENDREGION 'GdiplusEffects.h'}\r\n\r\n{$REGION 'GdiplusRegion.h'}\r\n\r\n{ TGPRegion }\r\n\r\nfunction TGPRegion.Clone: IGPRegion;\r\nvar\r\n  NativeClone: GpRegion;\r\nbegin\r\n  NativeClone := nil;\r\n  GdipCheck(GdipCloneRegion(FNativeHandle, NativeClone));\r\n  Result := TGPRegion.Create(NativeClone);\r\nend;\r\n\r\nconstructor TGPRegion.Create(const NativeRegion: GpRegion);\r\nbegin\r\n  inherited Create;\r\n  FNativeHandle := NativeRegion;\r\nend;\r\n\r\nconstructor TGPRegion.Create(const Path: IGPGraphicsPath);\r\nbegin\r\n  inherited Create;\r\n  GdipCheck(GdipCreateRegionPath(Path.NativeHandle, FNativeHandle));\r\nend;\r\n\r\nconstructor TGPRegion.Create(const Rect: TGPRect);\r\nbegin\r\n  inherited Create;\r\n  GdipCheck(GdipCreateRegionRectI(@Rect, FNativeHandle));\r\nend;\r\n\r\nconstructor TGPRegion.Create(const HRgn: HRGN);\r\nbegin\r\n  inherited Create;\r\n  GdipCheck(GdipCreateRegionHrgn(HRgn, FNativeHandle));\r\nend;\r\n\r\nconstructor TGPRegion.Create(const RegionData: PByte; const Size: Integer);\r\nbegin\r\n  inherited Create;\r\n  GdipCheck(GdipCreateRegionRgnData(RegionData, Size, FNativeHandle));\r\nend;\r\n\r\nconstructor TGPRegion.Create;\r\nbegin\r\n  inherited Create;\r\n  GdipCheck(GdipCreateRegion(FNativeHandle));\r\nend;\r\n\r\nconstructor TGPRegion.Create(const Rect: TGPRectF);\r\nbegin\r\n  inherited Create;\r\n  GdipCheck(GdipCreateRegionRect(@Rect, FNativeHandle));\r\nend;\r\n\r\nprocedure TGPRegion.Complement(const Rect: TGPRectF);\r\nbegin\r\n  GdipCheck(GdipCombineRegionRect(FNativeHandle, @Rect, CombineModeComplement));\r\nend;\r\n\r\nprocedure TGPRegion.Complement(const Rect: TGPRect);\r\nbegin\r\n  GdipCheck(GdipCombineRegionRectI(FNativeHandle, @Rect, CombineModeComplement));\r\nend;\r\n\r\nprocedure TGPRegion.Complement(const Path: IGPGraphicsPath);\r\nbegin\r\n  GdipCheck(GdipCombineRegionRect(FNativeHandle, Path.NativeHandle, CombineModeComplement));\r\nend;\r\n\r\nprocedure TGPRegion.Complement(const Region: IGPRegion);\r\nbegin\r\n  GdipCheck(GdipCombineRegionRect(FNativeHandle, Region.NativeHandle, CombineModeComplement));\r\nend;\r\n\r\ndestructor TGPRegion.Destroy;\r\nbegin\r\n  GdipDeleteRegion(FNativeHandle);\r\n  inherited;\r\nend;\r\n\r\nfunction TGPRegion.Equals(const Region: IGPRegion; const G: IGPGraphics): Boolean;\r\nvar\r\n  B: Bool;\r\nbegin\r\n  B := False;\r\n  GdipCheck(GdipIsEqualRegion(FNativeHandle, Region.NativeHandle, G.NativeHandle, B));\r\n  Result := B;\r\nend;\r\n\r\nprocedure TGPRegion.ExclusiveOr(const Rect: TGPRectF);\r\nbegin\r\n  GdipCheck(GdipCombineRegionRect(FNativeHandle, @Rect, CombineModeXor));\r\nend;\r\n\r\nprocedure TGPRegion.ExclusiveOr(const Rect: TGPRect);\r\nbegin\r\n  GdipCheck(GdipCombineRegionRectI(FNativeHandle, @Rect, CombineModeXor));\r\nend;\r\n\r\nprocedure TGPRegion.Exclude(const Rect: TGPRectF);\r\nbegin\r\n  GdipCheck(GdipCombineRegionRect(FNativeHandle, @Rect, CombineModeExclude));\r\nend;\r\n\r\nprocedure TGPRegion.Exclude(const Rect: TGPRect);\r\nbegin\r\n  GdipCheck(GdipCombineRegionRectI(FNativeHandle, @Rect, CombineModeExclude));\r\nend;\r\n\r\nprocedure TGPRegion.Exclude(const Region: IGPRegion);\r\nbegin\r\n  GdipCheck(GdipCombineRegionRegion(FNativeHandle, Region.NativeHandle, CombineModeExclude));\r\nend;\r\n\r\nprocedure TGPRegion.Exclude(const Path: IGPGraphicsPath);\r\nbegin\r\n  GdipCheck(GdipCombineRegionPath(FNativeHandle, Path.NativeHandle, CombineModeExclude));\r\nend;\r\n\r\nprocedure TGPRegion.ExclusiveOr(const Region: IGPRegion);\r\nbegin\r\n  GdipCheck(GdipCombineRegionRegion(FNativeHandle, Region.NativeHandle, CombineModeXor));\r\nend;\r\n\r\nprocedure TGPRegion.ExclusiveOr(const Path: IGPGraphicsPath);\r\nbegin\r\n  GdipCheck(GdipCombineRegionPath(FNativeHandle, Path.NativeHandle, CombineModeXor));\r\nend;\r\n\r\nclass function TGPRegion.FromHRGN(const HRgn: HRGN): IGPRegion;\r\nvar\r\n  NativeRegion: GpRegion;\r\nbegin\r\n  NativeRegion := nil;\r\n  if (GdipCreateRegionHrgn(HRgn, NativeRegion) = Ok) then\r\n    Result := TGPRegion.Create(NativeRegion)\r\n  else\r\n    Result := nil;\r\nend;\r\n\r\nprocedure TGPRegion.GetBounds(out Rect: TGPRectF; const G: IGPGraphics);\r\nbegin\r\n  GdipCheck(GdipGetRegionBounds(FNativeHandle, G.NativeHandle, Rect));\r\nend;\r\n\r\nprocedure TGPRegion.GetBounds(out Rect: TGPRect; const G: IGPGraphics);\r\nbegin\r\n  GdipCheck(GdipGetRegionBoundsI(FNativeHandle, G.NativeHandle, Rect));\r\nend;\r\n\r\nfunction TGPRegion.GetData: IGPRegionData;\r\nvar\r\n  Data: Pointer;\r\n  Size: Cardinal;\r\nbegin\r\n  Data := nil;\r\n  Size := 0;\r\n  GdipCheck(GdipGetRegionDataSize(FNativeHandle, Size));\r\n  if (Size > 0) then\r\n  begin\r\n    GetMem(Data, Size);\r\n    GdipCheck(GdipGetRegionData(FNativeHandle, Data, Size, nil));\r\n  end;\r\n  Result := TGPBuffer.Create(Data, Size);\r\nend;\r\n\r\nfunction TGPRegion.GetHRGN(const G: IGPGraphics): HRGN;\r\nbegin\r\n  GdipCheck(GdipGetRegionHRgn(FNativeHandle, G.NativeHandle, Result));\r\nend;\r\n\r\nfunction TGPRegion.GetRegionScans(const Matrix: IGPMatrix): IGPRegionScansF;\r\nvar\r\n  Count: Integer;\r\nbegin\r\n  Count := 0;\r\n  GdipCheck(GdipGetRegionScansCount(FNativeHandle, Count, Matrix.NativeHandle));\r\n  Result := TGPArray.Create(Count);\r\n  if (Count > 0) then\r\n    GdipCheck(GdipGetRegionScans(FNativeHandle, Result.ItemPtr, Count, Matrix.NativeHandle));\r\nend;\r\n\r\nfunction TGPRegion.GetRegionScansI(const Matrix: IGPMatrix): IGPRegionScans;\r\nvar\r\n  Count: Integer;\r\nbegin\r\n  Count := 0;\r\n  GdipCheck(GdipGetRegionScansCount(FNativeHandle, Count, Matrix.NativeHandle));\r\n  Result := TGPArray.Create(Count);\r\n  if (Count > 0) then\r\n    GdipCheck(GdipGetRegionScansI(FNativeHandle, Result.ItemPtr, Count, Matrix.NativeHandle));\r\nend;\r\n\r\nprocedure TGPRegion.Intersect(const Rect: TGPRectF);\r\nbegin\r\n  GdipCheck(GdipCombineRegionRect(FNativeHandle, @Rect, CombineModeIntersect));\r\nend;\r\n\r\nprocedure TGPRegion.Intersect(const Path: IGPGraphicsPath);\r\nbegin\r\n  GdipCheck(GdipCombineRegionPath(FNativeHandle, Path.NativeHandle, CombineModeIntersect));\r\nend;\r\n\r\nprocedure TGPRegion.Intersect(const Region: IGPRegion);\r\nbegin\r\n  GdipCheck(GdipCombineRegionRegion(FNativeHandle, Region.NativeHandle, CombineModeIntersect));\r\nend;\r\n\r\nprocedure TGPRegion.Intersect(const Rect: TGPRect);\r\nbegin\r\n  GdipCheck(GdipCombineRegionRectI(FNativeHandle, @Rect, CombineModeIntersect));\r\nend;\r\n\r\nfunction TGPRegion.IsEmpty(const G: IGPGraphics): Boolean;\r\nvar\r\n  B: Bool;\r\nbegin\r\n  B := False;\r\n  GdipCheck(GdipIsEmptyRegion(FNativeHandle, G.NativeHandle, B));\r\n  Result := B;\r\nend;\r\n\r\nfunction TGPRegion.IsInfinite(const G: IGPGraphics): Boolean;\r\nvar\r\n  B: Bool;\r\nbegin\r\n  B := False;\r\n  GdipCheck(GdipIsInfiniteRegion(FNativeHandle, G.NativeHandle, B));\r\n  Result := B;\r\nend;\r\n\r\nfunction TGPRegion.IsVisible(const Rect: TGPRect; const G: IGPGraphics): Boolean;\r\nvar\r\n  B: Bool;\r\nbegin\r\n  B := False;\r\n  GdipCheck(GdipIsVisibleRegionRectI(FNativeHandle, Rect.X, Rect.Y,\r\n    Rect.Width, Rect.Height, GdipHandle(G), B));\r\n  Result := B;\r\nend;\r\n\r\nfunction TGPRegion.IsVisible(const X, Y, Width, Height: Integer;\r\n  const G: IGPGraphics): Boolean;\r\nbegin\r\n  Result := IsVisible(TGPRect.Create(X, Y, Width, Height), G);\r\nend;\r\n\r\nfunction TGPRegion.IsVisible(const Rect: TGPRectF; const G: IGPGraphics): Boolean;\r\nvar\r\n  B: Bool;\r\nbegin\r\n  B := False;\r\n  GdipCheck(GdipIsVisibleRegionRect(FNativeHandle, Rect.X, Rect.Y,\r\n    Rect.Width, Rect.Height, GdipHandle(G), B));\r\n  Result := B;\r\nend;\r\n\r\nfunction TGPRegion.IsVisible(const X, Y, Width, Height: Single;\r\n  const G: IGPGraphics): Boolean;\r\nbegin\r\n  Result := IsVisible(TGPRectF.Create(X, Y, Width, Height), G);\r\nend;\r\n\r\nfunction TGPRegion.IsVisible(const Point: TGPPoint; const G: IGPGraphics): Boolean;\r\nvar\r\n  B: Bool;\r\nbegin\r\n  B := False;\r\n  GdipCheck(GdipIsVisibleRegionPointI(FNativeHandle, Point.X, Point.Y, GdipHandle(G), B));\r\n  Result := B;\r\nend;\r\n\r\nfunction TGPRegion.IsVisible(const X, Y: Integer; const G: IGPGraphics): Boolean;\r\nbegin\r\n  Result := IsVisible(TGPPoint.Create(X, Y), G);\r\nend;\r\n\r\nfunction TGPRegion.IsVisible(const Point: TGPPointF; const G: IGPGraphics): Boolean;\r\nvar\r\n  B: Bool;\r\nbegin\r\n  B := False;\r\n  GdipCheck(GdipIsVisibleRegionPoint(FNativeHandle, Point.X, Point.Y, GdipHandle(G), B));\r\n  Result := B;\r\nend;\r\n\r\nfunction TGPRegion.IsVisible(const X, Y: Single; const G: IGPGraphics): Boolean;\r\nbegin\r\n  Result := IsVisible(TGPPointF.Create(X, Y), G);\r\nend;\r\n\r\nprocedure TGPRegion.MakeEmpty;\r\nbegin\r\n  GdipCheck(GdipSetEmpty(FNativeHandle));\r\nend;\r\n\r\nprocedure TGPRegion.MakeInfinite;\r\nbegin\r\n  GdipCheck(GdipSetInfinite(FNativeHandle));\r\nend;\r\n\r\nprocedure TGPRegion.Transform(const Matrix: IGPMatrix);\r\nbegin\r\n  GdipCheck(GdipTransformRegion(FNativeHandle, Matrix.NativeHandle));\r\nend;\r\n\r\nprocedure TGPRegion.Translate(const DX, DY: Single);\r\nbegin\r\n  GdipCheck(GdipTranslateRegion(FNativeHandle, DX, DY));\r\nend;\r\n\r\nprocedure TGPRegion.Translate(const DX, DY: Integer);\r\nbegin\r\n  GdipCheck(GdipTranslateRegionI(FNativeHandle, DX, DY));\r\nend;\r\n\r\nprocedure TGPRegion.Union(const Rect: TGPRect);\r\nbegin\r\n  GdipCheck(GdipCombineRegionRectI(FNativeHandle, @Rect, CombineModeUnion));\r\nend;\r\n\r\nprocedure TGPRegion.Union(const Rect: TGPRectF);\r\nbegin\r\n  GdipCheck(GdipCombineRegionRect(FNativeHandle, @Rect, CombineModeUnion));\r\nend;\r\n\r\nprocedure TGPRegion.Union(const Path: IGPGraphicsPath);\r\nbegin\r\n  GdipCheck(GdipCombineRegionPath(FNativeHandle, Path.NativeHandle, CombineModeUnion));\r\nend;\r\n\r\nprocedure TGPRegion.Union(const Region: IGPRegion);\r\nbegin\r\n  GdipCheck(GdipCombineRegionRegion(FNativeHandle, Region.NativeHandle, CombineModeUnion));\r\nend;\r\n{$ENDREGION 'GdiplusRegion.h'}\r\n\r\n{$REGION 'GdiplusFontFamily.h'}\r\n{ TGPFontFamily }\r\n\r\nfunction TGPFontFamily.Clone: IGPFontFamily;\r\nvar\r\n  ClonedFamily: GpFontFamily;\r\nbegin\r\n  ClonedFamily := nil;\r\n  GdipCheck(GdipCloneFontFamily(FNativeHandle, ClonedFamily));\r\n  Result := TGPFontFamily.Create(ClonedFamily);\r\nend;\r\n\r\nconstructor TGPFontFamily.Create(const NativeFamily: GpFontFamily);\r\nbegin\r\n  inherited Create;\r\n  FNativeHandle := NativeFamily;\r\nend;\r\n\r\nconstructor TGPFontFamily.Create;\r\nbegin\r\n  inherited Create;\r\nend;\r\n\r\nconstructor TGPFontFamily.Create(const Name: String;\r\n  const FontCollection: IGPFontCollection);\r\nbegin\r\n  inherited Create;\r\n  GdipCheck(GdipCreateFontFamilyFromName(PWideChar(Name), GdipHandle(FontCollection), FNativeHandle));\r\nend;\r\n\r\ndestructor TGPFontFamily.Destroy;\r\nbegin\r\n  GdipDeleteFontFamily(FNativeHandle);\r\n  inherited;\r\nend;\r\n\r\nclass function TGPFontFamily.GenericMonospace: IGPFontFamily;\r\nvar\r\n  NativeFamily: GpFontFamily;\r\nbegin\r\n  if (FGenericMonospaceFontFamily = nil) then\r\n  begin\r\n    GdipCheck(GdipGetGenericFontFamilyMonospace(NativeFamily));\r\n    FGenericMonospaceFontFamily := TGPFontFamily.Create(NativeFamily);\r\n  end;\r\n  Result := FGenericMonospaceFontFamily;\r\nend;\r\n\r\nclass function TGPFontFamily.GenericSansSerif: IGPFontFamily;\r\nvar\r\n  NativeFamily: GpFontFamily;\r\nbegin\r\n  if (FGenericSansSerifFontFamily = nil) then\r\n  begin\r\n    GdipCheck(GdipGetGenericFontFamilySansSerif(NativeFamily));\r\n    FGenericSansSerifFontFamily := TGPFontFamily.Create(NativeFamily);\r\n  end;\r\n  Result := FGenericSansSerifFontFamily;\r\nend;\r\n\r\nclass function TGPFontFamily.GenericSerif: IGPFontFamily;\r\nvar\r\n  NativeFamily: GpFontFamily;\r\nbegin\r\n  if (FGenericSerifFontFamily = nil) then\r\n  begin\r\n    GdipCheck(GdipGetGenericFontFamilySerif(NativeFamily));\r\n    FGenericSerifFontFamily := TGPFontFamily.Create(NativeFamily);\r\n  end;\r\n  Result := FGenericSerifFontFamily;\r\nend;\r\n\r\nfunction TGPFontFamily.GetCellAscent(const Style: TGPFontStyle): Word;\r\nbegin\r\n  GdipCheck(GdipGetCellAscent(FNativeHandle, Style, Result));\r\nend;\r\n\r\nfunction TGPFontFamily.GetCellDescent(const Style: TGPFontStyle): Word;\r\nbegin\r\n  GdipCheck(GdipGetCellDescent(FNativeHandle, Style, Result));\r\nend;\r\n\r\nfunction TGPFontFamily.GetEmHeight(const Style: TGPFontStyle): Word;\r\nbegin\r\n  GdipCheck(GdipGetEmHeight(FNativeHandle, Style, Result));\r\nend;\r\n\r\nfunction TGPFontFamily.GetFamilyName(const Language: LangID = 0): String;\r\nvar\r\n  Name: array [0..LF_FACESIZE - 1] of WideChar;\r\nbegin\r\n  GdipCheck(GdipGetFamilyName(FNativeHandle, Name, Language));\r\n  Result := Name;\r\nend;\r\n\r\nfunction TGPFontFamily.GetFamilyNameInternal: String;\r\nbegin\r\n  Result := GetFamilyName(0);\r\nend;\r\n\r\nfunction TGPFontFamily.GetLineSpacing(const Style: TGPFontStyle): Word;\r\nbegin\r\n  GdipCheck(GdipGetLineSpacing(FNativeHandle, Style, Result));\r\nend;\r\n\r\nfunction TGPFontFamily.IsAvailable: Boolean;\r\nbegin\r\n  Result := Assigned(FNativeHandle);\r\nend;\r\n\r\nfunction TGPFontFamily.IsStyleAvailable(const Style: TGPFontStyle): Boolean;\r\nvar\r\n  B: Bool;\r\nbegin\r\n  if (GdipIsStyleAvailable(FNativeHandle, Style, B) <> Ok) then\r\n    Result := False\r\n  else\r\n    Result := B;\r\nend;\r\n{$ENDREGION 'GdiplusFontFamily.h'}\r\n\r\n{$REGION 'GdiplusFont.h'}\r\n\r\n{ TGPFont }\r\n\r\nfunction TGPFont.Clone: IGPFont;\r\nvar\r\n  NativeClone: GpFont;\r\nbegin\r\n  NativeClone := nil;\r\n  GdipCheck(GdipCloneFont(FNativeHandle, NativeClone));\r\n  Result := TGPFont.Create(NativeClone);\r\nend;\r\n\r\nconstructor TGPFont.Create(const DC: HDC; const LogFont: TLogFontA);\r\nbegin\r\n  GdipCheck(GdipCreateFontFromLogfontA(DC, @LogFont, FNativeHandle))\r\nend;\r\n\r\nconstructor TGPFont.Create(const DC: HDC);\r\nbegin\r\n  inherited Create;\r\n  GdipCheck(GdipCreateFontFromDC(DC, FNativeHandle));\r\nend;\r\n\r\nconstructor TGPFont.Create(const NativeFont: GpFont);\r\nbegin\r\n  inherited Create;\r\n  FNativeHandle := NativeFont;\r\nend;\r\n\r\nconstructor TGPFont.Create(const Family: IGPFontFamily; const EmSize: Single;\r\n  const Style: TGPFontStyle; const MeasureUnit: TGPUnit);\r\nbegin\r\n  inherited Create;\r\n  GdipCheck(GdipCreateFont(GdipHandle(Family), EmSize, Style, MeasureUnit, FNativeHandle))\r\nend;\r\n\r\nconstructor TGPFont.Create(const FamilyName: String; const EmSize: Single;\r\n  const Style: TGPFontStyle; const MeasureUnit: TGPUnit;\r\n  const FontCollection: IGPFontCollection);\r\nvar\r\n  Family: IGPFontFamily;\r\n  NativeFamily: GpFontFamily;\r\nbegin\r\n  inherited Create;\r\n  try\r\n    Family := TGPFontFamily.Create(FamilyName, FontCollection);\r\n    NativeFamily := Family.NativeHandle;\r\n  except\r\n    NativeFamily := TGPFontFamily.GenericSansSerif.NativeHandle;\r\n  end;\r\n  GdipCheck(GdipCreateFont(NativeFamily, EmSize, Style, MeasureUnit, FNativeHandle))\r\nend;\r\n\r\nconstructor TGPFont.Create(const DC: HDC; const LogFont: TLogFontW);\r\nbegin\r\n  inherited Create;\r\n  GdipCheck(GdipCreateFontFromLogfontW(DC, @LogFont, FNativeHandle))\r\nend;\r\n\r\nconstructor TGPFont.Create(const DC: HDC; const FontHandle: HFont);\r\nvar\r\n  LogFont: TLogFontA;\r\nbegin\r\n  inherited Create;\r\n  if (FontHandle <> 0) then\r\n  begin\r\n    if (GetObjectA(FontHandle, SizeOf(LogFont), @LogFont) <> 0) then\r\n      GdipCheck(GdipCreateFontFromLogfontA(DC, @LogFont, FNativeHandle))\r\n    else\r\n      GdipCheck(GdipCreateFontFromDC(DC, FNativeHandle));\r\n  end\r\n  else\r\n    GdipCheck(GdipCreateFontFromDC(DC, FNativeHandle));\r\nend;\r\n\r\ndestructor TGPFont.Destroy;\r\nbegin\r\n  GdipDeleteFont(FNativeHandle);\r\n  inherited;\r\nend;\r\n\r\nfunction TGPFont.GetFamily: IGPFontFamily;\r\nvar\r\n  NativeFamily: GpFontFamily;\r\nbegin\r\n  GdipCheck(GdipGetFamily(FNativeHandle, NativeFamily));\r\n  Result := TGPFontFamily.Create(NativeFamily);\r\nend;\r\n\r\nfunction TGPFont.GetHeight(const Dpi: Single): Single;\r\nbegin\r\n  GdipCheck(GdipGetFontHeightGivenDPI(FNativeHandle, Dpi, Result));\r\nend;\r\n\r\nfunction TGPFont.GetHeight(const Graphics: IGPGraphics): Single;\r\nbegin\r\n  GdipCheck(GdipGetFontHeight(FNativeHandle, GdipHandle(Graphics), Result));\r\nend;\r\n\r\nfunction TGPFont.GetLogFontA(const G: IGPGraphics): TLogFontA;\r\nbegin\r\n  GdipCheck(GdipGetLogFontA(FNativeHandle, GdipHandle(G), Result));\r\nend;\r\n\r\nfunction TGPFont.GetLogFontW(const G: IGPGraphics): TLogFontW;\r\nbegin\r\n  GdipCheck(GdipGetLogFontW(FNativeHandle, GdipHandle(G), Result));\r\nend;\r\n\r\nfunction TGPFont.GetSize: Single;\r\nbegin\r\n  GdipCheck(GdipGetFontSize(FNativeHandle, Result));\r\nend;\r\n\r\nfunction TGPFont.GetStyle: TGPFontStyle;\r\nbegin\r\n  GdipCheck(GdipGetFontStyle(FNativeHandle, Result));\r\nend;\r\n\r\nfunction TGPFont.GetUnit: TGPUnit;\r\nbegin\r\n  GdipCheck(GdipGetFontUnit(FNativeHandle, Result));\r\nend;\r\n\r\nfunction TGPFont.IsAvailable: Boolean;\r\nbegin\r\n  Result := Assigned(FNativeHandle);\r\nend;\r\n{$ENDREGION 'GdiplusFont.h'}\r\n\r\n{$REGION 'GdiplusFontCollection.h'}\r\n\r\n{ TGPFontCollection }\r\n\r\nconstructor TGPFontCollection.Create;\r\nbegin\r\n  inherited Create;\r\n  FNativeHandle := nil;\r\nend;\r\n\r\nfunction TGPFontCollection.GetFamilies: IGPFontFamilies;\r\nvar\r\n  NativeFamilyList: array of GpFontFamily;\r\n  NativeClone: GpFontFamily;\r\n  Count, ActualCount, I: Integer;\r\nbegin\r\n  Count := 0;\r\n  GdipCheck(GdipGetFontCollectionFamilyCount(FNativeHandle, Count));\r\n\r\n  SetLength(NativeFamilyList, Count);\r\n  GdipCheck(GdipGetFontCollectionFamilyList(FNativeHandle, Count,\r\n    @NativeFamilyList[0], ActualCount));\r\n\r\n  Result := TGPArray.Create(ActualCount);\r\n  for I := 0 to ActualCount - 1 do\r\n  begin\r\n    GdipCheck(GdipCloneFontFamily(NativeFamilyList[I], NativeClone));\r\n    Result[I] := TGPFontFamily.Create(NativeClone);\r\n  end;\r\nend;\r\n\r\n{ TGPInstalledFontCollection }\r\n\r\nconstructor TGPInstalledFontCollection.Create;\r\nbegin\r\n  inherited Create;\r\n  GdipCheck(GdipNewInstalledFontCollection(FNativeHandle));\r\nend;\r\n\r\n{ TGPPrivateFontCollection }\r\n\r\nprocedure TGPPrivateFontCollection.AddFontFile(const Filename: String);\r\nbegin\r\n  GdipCheck(GdipPrivateAddFontFile(FNativeHandle, PWideChar(Filename)));\r\nend;\r\n\r\nprocedure TGPPrivateFontCollection.AddMemoryFont(const Memory: Pointer;\r\n  const Length: Integer);\r\nbegin\r\n  GdipCheck(GdipPrivateAddMemoryFont(FNativeHandle, Memory, Length));\r\nend;\r\n\r\nconstructor TGPPrivateFontCollection.Create;\r\nbegin\r\n  inherited Create;\r\n  GdipCheck(GdipNewPrivateFontCollection(FNativeHandle));\r\nend;\r\n\r\ndestructor TGPPrivateFontCollection.Destroy;\r\nbegin\r\n  GdipDeletePrivateFontCollection(FNativeHandle);\r\n  inherited;\r\nend;\r\n{$ENDREGION 'GdiplusFontCollection.h'}\r\n\r\n{$REGION 'GdiplusBitmap.h'}\r\n{ TGPImageFormat }\r\n\r\nconstructor TGPImageFormat.Create(const Guid: TGUID);\r\nbegin\r\n  inherited Create;\r\n  FGuid := Guid;\r\nend;\r\n\r\nconstructor TGPImageFormat.Create(const Guid, CodecId: TGUID);\r\nbegin\r\n  inherited Create;\r\n  FGuid := Guid;\r\n  FCodecId := CodecId;\r\nend;\r\n\r\nclass function TGPImageFormat.FindByFormatId(\r\n  const lFormatId: TGUID): IGPImageFormat;\r\nbegin\r\n  InitializeCodecs;\r\n  if IsEqualGUID(lFormatId, FBmp.Guid) then\r\n    Result := FBmp\r\n  else if IsEqualGUID(lFormatId, FGif.Guid) then\r\n    Result := FGif\r\n  else if IsEqualGUID(lFormatId, FJpeg.Guid) then\r\n    Result := FJpeg\r\n  else if IsEqualGUID(lFormatId, FPng.Guid) then\r\n    Result := FPng\r\n  else if IsEqualGUID(lFormatId, FTiff.Guid) then\r\n    Result := FTiff\r\n  else\r\n    Result := nil;\r\nend;\r\n\r\nclass function TGPImageFormat.GetBmp: IGPImageFormat;\r\nbegin\r\n  InitializeCodecs;\r\n  Result := FBmp;\r\nend;\r\n\r\nfunction TGPImageFormat.GetCodecId: TGUID;\r\nbegin\r\n  Result := FCodecId;\r\nend;\r\n\r\nclass function TGPImageFormat.GetGif: IGPImageFormat;\r\nbegin\r\n  InitializeCodecs;\r\n  Result := FGif;\r\nend;\r\n\r\nfunction TGPImageFormat.GetGuid: TGuid;\r\nbegin\r\n  Result := FGuid;\r\nend;\r\n\r\nclass function TGPImageFormat.GetJpeg: IGPImageFormat;\r\nbegin\r\n  InitializeCodecs;\r\n  Result := FJpeg;\r\nend;\r\n\r\nclass function TGPImageFormat.GetPng: IGPImageFormat;\r\nbegin\r\n  InitializeCodecs;\r\n  Result := FPng;\r\nend;\r\n\r\nclass function TGPImageFormat.GetTiff: IGPImageFormat;\r\nbegin\r\n  InitializeCodecs;\r\n  Result := FTiff;\r\nend;\r\n\r\nclass procedure TGPImageFormat.InitializeCodecs;\r\nvar\r\n  I, Count, Size: Cardinal;\r\n  List, Info: PGPNativeImageCodecInfo;\r\nbegin\r\n  if (not FInitialized) then\r\n  begin\r\n    FInitialized := True;\r\n    GdipCheck(GdipGetImageEncodersSize(Count, Size));\r\n    if (Size > 0) then\r\n    begin\r\n      GetMem(List, Size);\r\n      try\r\n        GdipCheck(GdipGetImageEncoders(Count, Size, List));\r\n        Info := List;\r\n        for I := 0 to Count - 1 do\r\n        begin\r\n          if IsEqualGUID(Info.FormatId, ImageFormatBMP) then\r\n            FBmp := TGPImageFormat.Create(Info.FormatId, Info.ClsId)\r\n          else\r\n          if IsEqualGUID(Info.FormatId, ImageFormatJPEG) then\r\n            FJpeg := TGPImageFormat.Create(Info.FormatId, Info.ClsId)\r\n          else\r\n          if IsEqualGUID(Info.FormatId, ImageFormatGIF) then\r\n            FGif := TGPImageFormat.Create(Info.FormatId, Info.ClsId)\r\n          else\r\n          if IsEqualGUID(Info.FormatId, ImageFormatTIFF) then\r\n            FTiff := TGPImageFormat.Create(Info.FormatId, Info.ClsId)\r\n          else\r\n          if IsEqualGUID(Info.FormatId, ImageFormatPNG) then\r\n            FPng := TGPImageFormat.Create(Info.FormatId, Info.ClsId);\r\n          Inc(Info);\r\n        end;\r\n      finally\r\n        FreeMem(List);\r\n      end;\r\n    end;\r\n    Assert(Assigned(FBmp));\r\n    Assert(Assigned(FJpeg));\r\n    Assert(Assigned(FGif));\r\n    Assert(Assigned(FTiff));\r\n    Assert(Assigned(FPng));\r\n  end;\r\nend;\r\n\r\n{ TGPImageCodecInfo }\r\n\r\nconstructor TGPImageCodecInfo.Create(const Info: TGPNativeImageCodecInfo);\r\nbegin\r\n  inherited Create;\r\n  FInfo := Info;\r\nend;\r\n\r\nfunction TGPImageCodecInfo.GetClsId: TGUID;\r\nbegin\r\n  Result := FInfo.ClsId;\r\nend;\r\n\r\nfunction TGPImageCodecInfo.GetCodecName: String;\r\nbegin\r\n  Result := FInfo.CodecName;\r\nend;\r\n\r\nfunction TGPImageCodecInfo.GetDllName: String;\r\nbegin\r\n  Result := FInfo.DllName;\r\nend;\r\n\r\nfunction TGPImageCodecInfo.GetFilenameExtension: String;\r\nbegin\r\n  Result := FInfo.FilenameExtension;\r\nend;\r\n\r\nfunction TGPImageCodecInfo.GetFlags: TGPImageCodecFlags;\r\nbegin\r\n  Result := FInfo.Flags;\r\nend;\r\n\r\nfunction TGPImageCodecInfo.GetFormatDescription: String;\r\nbegin\r\n  Result := FInfo.FormatDescription;\r\nend;\r\n\r\nfunction TGPImageCodecInfo.GetFormatId: TGUID;\r\nbegin\r\n  Result := FInfo.FormatId;\r\nend;\r\n\r\nclass function TGPImageCodecInfo.GetImageDecoders: IGPImageCodecInfoArray;\r\nvar\r\n  I, Count, Size: Cardinal;\r\n  List, Info: PGPNativeImageCodecInfo;\r\nbegin\r\n  GdipCheck(GdipGetImageDecodersSize(Count, Size));\r\n  if (Count > 0) then\r\n  begin\r\n    Result := TGPArray.Create(Count);\r\n    GetMem(List, Size);\r\n    try\r\n      GdipCheck(GdipGetImageDecoders(Count, Size, List));\r\n      Info := List;\r\n      for I := 0 to Count - 1 do\r\n      begin\r\n        Result[I] := TGPImageCodecInfo.Create(Info^);\r\n        Inc(Info);\r\n      end;\r\n    finally\r\n      FreeMem(List);\r\n    end;\r\n  end\r\n  else\r\n    Result := nil;\r\nend;\r\n\r\nclass function TGPImageCodecInfo.GetImageEncoders: IGPImageCodecInfoArray;\r\nvar\r\n  I, Count, Size: Cardinal;\r\n  List, Info: PGPNativeImageCodecInfo;\r\nbegin\r\n  GdipCheck(GdipGetImageEncodersSize(Count, Size));\r\n  if (Count > 0) then\r\n  begin\r\n    Result := TGPArray.Create(Count);\r\n    GetMem(List, Size);\r\n    try\r\n      GdipCheck(GdipGetImageEncoders(Count, Size, List));\r\n      Info := List;\r\n      for I := 0 to Count - 1 do\r\n      begin\r\n        Result[I] := TGPImageCodecInfo.Create(Info^);\r\n        Inc(Info);\r\n      end;\r\n    finally\r\n      FreeMem(List);\r\n    end;\r\n  end\r\n  else\r\n    Result := nil;\r\nend;\r\n\r\nfunction TGPImageCodecInfo.GetMimeType: String;\r\nbegin\r\n  Result := FInfo.MimeType;\r\nend;\r\n\r\nfunction TGPImageCodecInfo.GetVersion: Integer;\r\nbegin\r\n  Result := FInfo.Version;\r\nend;\r\n\r\n{ TGPEncoderParameterEnumerator }\r\n\r\nconstructor TGPEncoderParameterEnumerator.Create(\r\n  const AParams: IGPEncoderParameters);\r\nbegin\r\n  inherited Create;\r\n  FParams := AParams;\r\n  FIndex := -1;\r\nend;\r\n\r\nfunction TGPEncoderParameterEnumerator.GetCurrent: PGPNativeEncoderParameter;\r\nbegin\r\n  Result := FParams.Param[FIndex];\r\nend;\r\n\r\nfunction TGPEncoderParameterEnumerator.MoveNext: Boolean;\r\nbegin\r\n  Result := (FIndex < FParams.Count - 1);\r\n  if Result then\r\n    Inc(FIndex);\r\nend;\r\n\r\n{ TGPEncoderParameters }\r\n\r\nprocedure TGPEncoderParameters.Add(const ParamType: TGUID; var Value: Int64);\r\nvar\r\n  Value32: Int32;\r\nbegin\r\n  Value32 := Value;\r\n  Add(ParamType, 1, EncoderParameterValueTypeLong, @Value32);\r\nend;\r\n\r\nprocedure TGPEncoderParameters.Add(const ParamType: TGUID;\r\n  const Value: array of Int32);\r\nbegin\r\n  Assert(Length(Value) > 0);\r\n  Add(ParamType, Length(Value), EncoderParameterValueTypeLong, @Value[0]);\r\nend;\r\n\r\nprocedure TGPEncoderParameters.Add(const ParamType: TGUID; const Value: String);\r\nvar\r\n  AnsiValue: AnsiString;\r\nbegin\r\n  {$WARNINGS OFF}\r\n  AnsiValue := AnsiString(Value);\r\n  {$WARNINGS ON}\r\n  Assert(Length(AnsiValue) > 0);\r\n  Add(ParamType, Length(AnsiValue) + 1, EncoderParameterValueTypeASCII, @AnsiValue[1]);\r\nend;\r\n\r\nprocedure TGPEncoderParameters.Add(const ParamType: TGUID;\r\n  const Value: array of Int64);\r\nvar\r\n  Value32: array of Int32;\r\n  I: Integer;\r\nbegin\r\n  Assert(Length(Value) > 0);\r\n  SetLength(Value32, Length(Value));\r\n  for I := 0 to Length(Value) - 1 do\r\n    Value32[I] := Value[I];\r\n  Add(ParamType, Length(Value), EncoderParameterValueTypeLong, @Value32[0]);\r\nend;\r\n\r\nprocedure TGPEncoderParameters.Add(const ParamType: TGUID; var Value: Int32);\r\nbegin\r\n  Add(ParamType, 1, EncoderParameterValueTypeLong, @Value);\r\nend;\r\n\r\nprocedure TGPEncoderParameters.Add(const ParamType: TGUID;\r\n  const Value: array of Byte);\r\nbegin\r\n  Assert(Length(Value) > 0);\r\n  Add(ParamType, Length(Value), EncoderParameterValueTypeByte, @Value[0]);\r\nend;\r\n\r\nprocedure TGPEncoderParameters.Add(const ParamType: TGUID; var Value: Byte);\r\nbegin\r\n  Add(ParamType, 1, EncoderParameterValueTypeByte, @Value);\r\nend;\r\n\r\nprocedure TGPEncoderParameters.Add(const ParamType: TGUID;\r\n  const Value: array of Int16);\r\nbegin\r\n  Assert(Length(Value) > 0);\r\n  Add(ParamType, Length(Value), EncoderParameterValueTypeShort, @Value[0]);\r\nend;\r\n\r\nprocedure TGPEncoderParameters.Add(const ParamType: TGUID; var Value: Int16);\r\nbegin\r\n  Add(ParamType, 1, EncoderParameterValueTypeShort, @Value);\r\nend;\r\n\r\nprocedure TGPEncoderParameters.Add(const ParamType: TGUID;\r\n  const NumberOfValues: Integer; const ValueType: TGPEncoderParameterValueType;\r\n  const Value: Pointer);\r\nvar\r\n  ValueSize: Integer;\r\n  ValuePtr: PByte;\r\nbegin\r\n  FModified := True;\r\n  if (FParamCount >= Length(FParams)) then\r\n    SetLength(FParams, FParamCount + 4);\r\n\r\n  case ValueType of\r\n    EncoderParameterValueTypeByte,\r\n    EncoderParameterValueTypeASCII,\r\n    EncoderParameterValueTypeUndefined:\r\n      ValueSize := 1;\r\n    EncoderParameterValueTypeShort:\r\n      ValueSize := 2;\r\n    EncoderParameterValueTypeLong:\r\n      ValueSize := 4;\r\n    EncoderParameterValueTypeRational,\r\n    EncoderParameterValueTypeLongRange:\r\n      ValueSize := 8;\r\n    EncoderParameterValueTypeRationalRange:\r\n      ValueSize := 16;\r\n\r\n    {$IF (GDIPVER >= $0110)}\r\n    EncoderParameterValueTypePointer:\r\n      ValueSize := 1;\r\n    {$IFEND}\r\n  else\r\n    begin\r\n      ValueSize := 1;\r\n      Assert(False);\r\n    end;\r\n  end;\r\n  ValueSize := ValueSize * NumberOfValues;\r\n  if ((FValueSize + ValueSize) > FValueAllocated) then\r\n  begin\r\n    FValueAllocated := FValueSize + ValueSize + 64;\r\n    ReallocMem(FValues, FValueAllocated);\r\n  end;\r\n  ValuePtr := FValues;\r\n  Inc(ValuePtr, FValueSize);\r\n  Inc(FValueSize, ValueSize);\r\n  Move(Value^, ValuePtr^, ValueSize);\r\n\r\n  FParams[FParamCount].Guid := ParamType;\r\n  FParams[FParamCount].NumberOfValues := NumberOfValues;\r\n  FParams[FParamCount].ValueType := ValueType;\r\n  FParams[FParamCount].Value := ValuePtr;\r\n\r\n  Inc(FParamCount);\r\nend;\r\n\r\nprocedure TGPEncoderParameters.Add(const ParamType: TGUID; const RangesBegin,\r\n  RangesEnd: array of Int64);\r\nvar\r\n  Ranges: array of Int32;\r\n  I: Integer;\r\nbegin\r\n  Assert(Length(RangesBegin) > 0);\r\n  Assert(Length(RangesBegin) = Length(RangesEnd));\r\n  SetLength(Ranges, Length(RangesBegin) * 2);\r\n  for I := 0 to Length(RangesBegin) - 1 do\r\n  begin\r\n    Ranges[I * 2 + 0] := RangesBegin[I];\r\n    Ranges[I * 2 + 1] := RangesEnd[I];\r\n  end;\r\n  Add(ParamType, Length(RangesBegin), EncoderParameterValueTypeLongRange, @Ranges[0]);\r\nend;\r\n\r\nprocedure TGPEncoderParameters.Add(const ParamType: TGUID; const Numerator1,\r\n  Denominator1, Numerator2, Denominator2: array of Int32);\r\nvar\r\n  Values: array of Int32;\r\n  I: Integer;\r\nbegin\r\n  Assert(Length(Numerator1) > 0);\r\n  Assert(Length(Numerator1) = Length(Numerator2));\r\n  Assert(Length(Numerator1) = Length(Denominator1));\r\n  Assert(Length(Numerator1) = Length(Denominator2));\r\n  SetLength(Values, Length(Numerator1) * 4);\r\n  for I := 0 to Length(Numerator1) - 1 do\r\n  begin\r\n    Values[I * 4 + 0] := Numerator1[I];\r\n    Values[I * 4 + 1] := Denominator1[I];\r\n    Values[I * 4 + 2] := Numerator2[I];\r\n    Values[I * 4 + 3] := Denominator2[I];\r\n  end;\r\n  Add(ParamType, Length(Numerator1), EncoderParameterValueTypeRationalRange, @Values[0]);\r\nend;\r\n\r\nprocedure TGPEncoderParameters.Add(const ParamType: TGUID;\r\n  const Value: array of TGPEncoderValue);\r\nbegin\r\n  Assert(Length(Value) > 0);\r\n  Add(ParamType, Length(Value), EncoderParameterValueTypeLong, @Value[0]);\r\nend;\r\n\r\nprocedure TGPEncoderParameters.Add(const ParamType: TGUID;\r\n  const Value: TGPEncoderValue);\r\nbegin\r\n  Add(ParamType, 1, EncoderParameterValueTypeLong, @Value);\r\nend;\r\n\r\nprocedure TGPEncoderParameters.Clear;\r\nbegin\r\n  FParamCount := 0;\r\n  FValueSize := 0;\r\n  FModified := True;\r\nend;\r\n\r\nconstructor TGPEncoderParameters.Create;\r\nbegin\r\n  inherited Create;\r\nend;\r\n\r\nconstructor TGPEncoderParameters.Create(const Params: PGPNativeEncoderParameters);\r\nvar\r\n  Param: PGPNativeEncoderParameter;\r\n  I: Integer;\r\nbegin\r\n  inherited Create;\r\n  if Assigned(Params) then\r\n  begin\r\n    SetLength(FParams, Params.Count);\r\n    if (Params.Count > 0) then\r\n    begin\r\n      Param := @Params.Parameter[0];\r\n      for I := 0 to Params.Count - 1 do\r\n      begin\r\n        Add(Param.Guid, Param.NumberOfValues, Param.ValueType, Param.Value);\r\n        Inc(Param);\r\n      end;\r\n    end;\r\n  end;\r\nend;\r\n\r\nprocedure TGPEncoderParameters.Add(const ParamType: TGUID; const Numerator1,\r\n  Denominator1, Numerator2, Denominator2: Int32);\r\nvar\r\n  Values: array [0..3] of Int32;\r\nbegin\r\n  Values[0] := Numerator1;\r\n  Values[1] := Denominator1;\r\n  Values[2] := Numerator2;\r\n  Values[3] := Denominator2;\r\n  Add(ParamType, 1, EncoderParameterValueTypeRationalRange, @Values[0]);\r\nend;\r\n\r\nprocedure TGPEncoderParameters.Add(const ParamType: TGUID; var RangeBegin,\r\n  RangeEnd: Int64);\r\nvar\r\n  Values: array [0..1] of Int32;\r\nbegin\r\n  Values[0] := RangeBegin;\r\n  Values[1] := RangeEnd;\r\n  Add(ParamType, 1, EncoderParameterValueTypeLongRange, @Values[0]);\r\nend;\r\n\r\nprocedure TGPEncoderParameters.Add(const ParamType: TGUID;\r\n  const Value: array of Byte; const Undefined: Boolean);\r\nbegin\r\n  Assert(Length(Value) > 0);\r\n  if (Undefined) then\r\n    Add(ParamType, Length(Value), EncoderParameterValueTypeUndefined, @Value[0])\r\n  else\r\n    Add(ParamType, Length(Value), EncoderParameterValueTypeByte, @Value[0]);\r\nend;\r\n\r\nprocedure TGPEncoderParameters.Add(const ParamType: TGUID; const Value: Byte;\r\n  const Undefined: Boolean);\r\nbegin\r\n  if (Undefined) then\r\n    Add(ParamType, 1, EncoderParameterValueTypeUndefined, @Value)\r\n  else\r\n    Add(ParamType, 1, EncoderParameterValueTypeByte, @Value);\r\nend;\r\n\r\nprocedure TGPEncoderParameters.Add(const ParamType: TGUID; const Numerators,\r\n  Denominators: array of Int32);\r\nvar\r\n  Values: array of Int32;\r\n  I: Integer;\r\nbegin\r\n  Assert(Length(Numerators) > 0);\r\n  Assert(Length(Numerators) = Length(Denominators));\r\n  SetLength(Values, Length(Numerators) * 2);\r\n  for I := 0 to Length(Numerators) - 1 do\r\n  begin\r\n    Values[I * 2 + 0] := Numerators[I];\r\n    Values[I * 2 + 1] := Denominators[I];\r\n  end;\r\n  Add(ParamType, Length(Numerators), EncoderParameterValueTypeRational, @Values[0]);\r\nend;\r\n\r\nprocedure TGPEncoderParameters.Add(const ParamType: TGUID; var Numerator,\r\n  Denominator: Int32);\r\nvar\r\n  Values: array [0..1] of Int32;\r\nbegin\r\n  Values[0] := Numerator;\r\n  Values[1] := Denominator;\r\n  Add(ParamType, 1, EncoderParameterValueTypeRational, @Values[0]);\r\nend;\r\n\r\ndestructor TGPEncoderParameters.Destroy;\r\nbegin\r\n  FreeMem(FNativeParams);\r\n  FreeMem(FValues);\r\n  inherited;\r\nend;\r\n\r\nfunction TGPEncoderParameters.GetCount: Integer;\r\nbegin\r\n  Result := FParamCount;\r\nend;\r\n\r\nfunction TGPEncoderParameters.GetEnumerator: TGPEncoderParameterEnumerator;\r\nbegin\r\n  Result := TGPEncoderParameterEnumerator.Create(Self);\r\nend;\r\n\r\nfunction TGPEncoderParameters.GetNativeParams: PGPNativeEncoderParameters;\r\nbegin\r\n  if (FNativeParams = nil) or (FModified) then\r\n  begin\r\n    ReallocMem(FNativeParams, 4 + FParamCount * SizeOf(TGPNativeEncoderParameter));\r\n    FNativeParams.Count := FParamCount;\r\n    if (FParamCount > 0) then\r\n      Move(FParams[0], FNativeParams.Parameter[0], FParamCount * SizeOf(TGPNativeEncoderParameter));\r\n    FModified := False;\r\n  end;\r\n  Result := FNativeParams;\r\nend;\r\n\r\nfunction TGPEncoderParameters.GetParam(const Index: Integer): PGPNativeEncoderParameter;\r\nbegin\r\n  Result := @FParams[Index];\r\nend;\r\n\r\n{ TGPColorPalette }\r\n\r\nconstructor TGPColorPalette.Create(const Count: Integer);\r\nbegin\r\n  inherited Create;\r\n  GetMem(FData, SizeOf(TGPNativeColorPalette) + Count * SizeOf(ARGB));\r\n  FData.Count := Count;\r\n  FData.Flags := [];\r\n  FEntries := Pointer(FData);\r\n  Inc(PByte(FEntries), SizeOf(TGPNativeColorPalette));\r\nend;\r\n\r\nconstructor TGPColorPalette.Create(const NativePalette: PGPNativeColorPalette);\r\nbegin\r\n  if (NativePalette = nil) then\r\n  begin\r\n    Create(1);\r\n    FData.Count := 0;\r\n  end\r\n  else\r\n  begin\r\n    inherited Create;\r\n    FData := NativePalette;\r\n    FEntries := Pointer(FData);\r\n    Inc(PByte(FEntries), SizeOf(TGPNativeColorPalette));\r\n  end;\r\nend;\r\n\r\ndestructor TGPColorPalette.Destroy;\r\nbegin\r\n  FreeMem(FData);\r\n  inherited;\r\nend;\r\n\r\nfunction TGPColorPalette.GetCount: Integer;\r\nbegin\r\n  Result := FData.Count;\r\nend;\r\n\r\nfunction TGPColorPalette.GetEntry(const Index: Integer): ARGB;\r\nbegin\r\n  Result := FEntries[Index];\r\nend;\r\n\r\nfunction TGPColorPalette.GetEntryPtr: PARGB;\r\nbegin\r\n  Result := FEntries;\r\nend;\r\n\r\nfunction TGPColorPalette.GetFlags: TGPPaletteFlags;\r\nbegin\r\n  Result := FData.Flags;\r\nend;\r\n\r\nfunction TGPColorPalette.GetNativePalette: PGPNativeColorPalette;\r\nbegin\r\n  Result := FData;\r\nend;\r\n\r\nprocedure TGPColorPalette.SetEntry(const Index: Integer; const Value: ARGB);\r\nbegin\r\n  FEntries[Index] := Value;\r\nend;\r\n\r\nprocedure TGPColorPalette.SetFlags(const Value: TGPPaletteFlags);\r\nbegin\r\n  FData.Flags := Value;\r\nend;\r\n\r\n{ TGPPropertyItem }\r\n\r\nconstructor TGPPropertyItem.Create(const Data: PGPNativePropertyItem);\r\nbegin\r\n  inherited Create;\r\n  FData := Data;\r\nend;\r\n\r\nconstructor TGPPropertyItem.Create;\r\nbegin\r\n  inherited Create;\r\n  GetMem(FData, SizeOf(TGPNativePropertyItem));\r\nend;\r\n\r\ndestructor TGPPropertyItem.Destroy;\r\nbegin\r\n  FreeMem(FData);\r\n  inherited;\r\nend;\r\n\r\nfunction TGPPropertyItem.GetId: TPropID;\r\nbegin\r\n  Result := FData.Id;\r\nend;\r\n\r\nfunction TGPPropertyItem.GetLength: Cardinal;\r\nbegin\r\n  Result := FData.Length;\r\nend;\r\n\r\nfunction TGPPropertyItem.GetNativeItem: PGPNativePropertyItem;\r\nbegin\r\n  Result := FData;\r\nend;\r\n\r\nfunction TGPPropertyItem.GetValue: Pointer;\r\nbegin\r\n  Result := FData.Value;\r\nend;\r\n\r\nfunction TGPPropertyItem.GetValueType: Word;\r\nbegin\r\n  Result := FData.ValueType;\r\nend;\r\n\r\nprocedure TGPPropertyItem.SetId(const Value: TPropID);\r\nbegin\r\n  FData.Id := Value;\r\nend;\r\n\r\nprocedure TGPPropertyItem.SetLength(const Value: Cardinal);\r\nbegin\r\n  FData.Length := Value;\r\nend;\r\n\r\nprocedure TGPPropertyItem.SetValue(const Value: Pointer);\r\nbegin\r\n  FData.Value := Value;\r\nend;\r\n\r\nprocedure TGPPropertyItem.SetValueType(const Value: Word);\r\nbegin\r\n  FData.ValueType := Value;\r\nend;\r\n\r\n{ TGPImage }\r\n\r\nfunction TGPImage.Clone: IGPImage;\r\nvar\r\n  NativeClone: GpImage;\r\nbegin\r\n  NativeClone := nil;\r\n  GdipCheck(GdipCloneImage(FNativeHandle, NativeClone));\r\n  Result := TGPImage.Create(NativeClone);\r\nend;\r\n\r\nconstructor TGPImage.Create(const Stream: IStream;\r\n  const UseEmbeddedColorManagement: Boolean);\r\nbegin\r\n  inherited Create;\r\n  if (UseEmbeddedColorManagement) then\r\n    GdipCheck(GdipLoadImageFromStreamICM(Stream, FNativeHandle))\r\n  else\r\n    GdipCheck(GdipLoadImageFromStream(Stream, FNativeHandle))\r\nend;\r\n\r\nconstructor TGPImage.Create(const Filename: String;\r\n  const UseEmbeddedColorManagement: Boolean);\r\nbegin\r\n  inherited Create;\r\n  if (UseEmbeddedColorManagement) then\r\n    GdipCheck(GdipLoadImageFromFileICM(PWideChar(Filename), FNativeHandle))\r\n  else\r\n    GdipCheck(GdipLoadImageFromFile(PWideChar(Filename), FNativeHandle))\r\nend;\r\n\r\nconstructor TGPImage.Create(const NativeImage: GpImage);\r\nbegin\r\n  inherited Create;\r\n  FNativeHandle := NativeImage;\r\nend;\r\n\r\ndestructor TGPImage.Destroy;\r\nbegin\r\n  GdipDisposeImage(FNativeHandle);\r\n  inherited;\r\nend;\r\n\r\n{$IF (GDIPVER >= $0110)}\r\nprocedure TGPImage.FindFirstItem(const Item: PGPImageItemData);\r\nbegin\r\n  GdipCheck(GdipFindFirstImageItem(FNativeHandle, Item));\r\nend;\r\n\r\nprocedure TGPImage.FindNextItem(const Item: PGPImageItemData);\r\nbegin\r\n  GdipCheck(GdipFindNextImageItem(FNativeHandle, Item));\r\nend;\r\n\r\nprocedure TGPImage.GetItemData(const Item: PGPImageItemData);\r\nbegin\r\n  GdipCheck(GdipGetImageItemData(FNativeHandle, Item));\r\nend;\r\n\r\nprocedure TGPImage.SetAbort(const Abort: TGdiplusAbort);\r\nbegin\r\n  GdipCheck(GdipImageSetAbort(FNativeHandle, @Abort));\r\nend;\r\n{$IFEND}\r\n\r\nclass function TGPImage.FromFile(const Filename: String;\r\n  const UseEmbeddedColorManagement: Boolean): IGPImage;\r\nbegin\r\n  Result := TGPImage.Create(Filename, UseEmbeddedColorManagement);\r\nend;\r\n\r\nclass function TGPImage.FromStream(const Stream: IStream;\r\n  const UseEmbeddedColorManagement: Boolean): IGPImage;\r\nbegin\r\n  Result := TGPImage.Create(Stream, UseEmbeddedColorManagement);\r\nend;\r\n\r\nprocedure TGPImage.GetBounds(out SrcRect: TGPRectF; out SrcUnit: TGPUnit);\r\nbegin\r\n  GdipCheck(GdipGetImageBounds(FNativeHandle, SrcRect, SrcUnit));\r\nend;\r\n\r\nfunction TGPImage.GetEncoderParameterList(const lEncoder: TGUID): IGPEncoderParameters;\r\nvar\r\n  Size: Cardinal;\r\n  Params: PGPNativeEncoderParameters;\r\nbegin\r\n  Size := 0;\r\n  Params := nil;\r\n  try\r\n    if (GdipGetEncoderParameterListSize(FNativeHandle, @lEncoder, Size) = Ok) and (Size > 0) then\r\n    begin\r\n      GetMem(Params, Size);\r\n      GdipCheck(GdipGetEncoderParameterList(FNativeHandle, @lEncoder, Size, Params));\r\n    end;\r\n    Result := TGPEncoderParameters.Create(Params);\r\n  finally\r\n    FreeMem(Params);\r\n  end;\r\nend;\r\n\r\nfunction TGPImage.GetFlags: TGPImageFlags;\r\nbegin\r\n  Result := [];\r\n  GdipCheck(GdipGetImageFlags(FNativeHandle, Result));\r\nend;\r\n\r\nfunction TGPImage.GetFrameCount(const DimensionID: TGUID): Cardinal;\r\nbegin\r\n  Result := 0;\r\n  GdipCheck(GdipImageGetFrameCount(FNativeHandle, DimensionID, Result));\r\nend;\r\n\r\nfunction TGPImage.GetFrameDimensions: IGPFrameDimensions;\r\nvar\r\n  Count: Cardinal;\r\nbegin\r\n  Count := 0;\r\n  GdipCheck(GdipImageGetFrameDimensionsCount(FNativeHandle, Count));\r\n  Result := TGPArray.Create(Count);\r\n  if (Count > 0) then\r\n    GdipCheck(GdipImageGetFrameDimensionsList(FNativeHandle, Result.ItemPtr, Count));\r\nend;\r\n\r\nfunction TGPImage.GetHeight: Cardinal;\r\nbegin\r\n  Result := 0;\r\n  GdipCheck(GdipGetImageHeight(FNativeHandle, Result));\r\nend;\r\n\r\nfunction TGPImage.GetHorizontalResolution: Single;\r\nbegin\r\n  Result := 0;\r\n  GdipCheck(GdipGetImageHorizontalResolution(FNativeHandle, Result));\r\nend;\r\n\r\nfunction TGPImage.GetPalette: IGPColorPalette;\r\nvar\r\n  Size: Integer;\r\n  Palette: PGPNativeColorPalette;\r\nbegin\r\n  Palette := nil;\r\n  Size := 0;\r\n  GdipCheck(GdipGetImagePaletteSize(FNativeHandle, Size));\r\n  if (Size > 0) then\r\n  begin\r\n    GetMem(Palette, Size);\r\n    GdipCheck(GdipGetImagePalette(FNativeHandle, Palette, Size));\r\n  end;\r\n  Result := TGPColorPalette.Create(Palette);\r\nend;\r\n\r\nprocedure TGPImage.GetPhysicalDimension(out Size: TGPSizeF);\r\nbegin\r\n  GdipCheck(GdipGetImageDimension(FNativeHandle, Size.Width, Size.Height));\r\nend;\r\n\r\nfunction TGPImage.GetPixelFormat: TGPPixelFormat;\r\nbegin\r\n  GdipCheck(GdipGetImagePixelFormat(FNativeHandle, Result));\r\nend;\r\n\r\nfunction TGPImage.GetPropertyIdList: IGPPropertyIdList;\r\nvar\r\n  Count: Cardinal;\r\nbegin\r\n  Count := 0;\r\n  GdipCheck(GdipGetPropertyCount(FNativeHandle, Count));\r\n  Result := TGPArray.Create(Count);\r\n  if (Count > 0) then\r\n    GdipCheck(GdipGetPropertyIdList(FNativeHandle, Count, Result.ItemPtr));\r\nend;\r\n\r\nfunction TGPImage.GetPropertyItem(const PropId: TPropID): IGPPropertyItem;\r\nvar\r\n  Size: Cardinal;\r\n  Data: PGPNativePropertyItem;\r\nbegin\r\n  Size := 0;\r\n  Data := nil;\r\n  GdipCheck(GdipGetPropertyItemSize(FNativeHandle, PropId, Size));\r\n  if (Size > 0) then\r\n  begin\r\n    GetMem(Data, Size);\r\n    GdipCheck(GdipGetPropertyItem(FNativeHandle, PropId, Size, Data));\r\n  end;\r\n  Result := TGPPropertyItem.Create(Data);\r\nend;\r\n\r\nfunction TGPImage.GetPropertyItems: IGPPropertyItems;\r\nvar\r\n  I, TotalBufferSize, NumProperties, PropSize: Cardinal;\r\n  AllProperties, CurProp, Data: PGPNativePropertyItem;\r\nbegin\r\n  GdipCheck(GdipGetPropertySize(FNativeHandle, TotalBufferSize, NumProperties));\r\n  Result := TGPArray.Create(NumProperties);\r\n  if (TotalBufferSize > 0) then\r\n  begin\r\n    GetMem(AllProperties, TotalBufferSize);\r\n    try\r\n      GdipCheck(GdipGetAllPropertyItems(FNativeHandle, TotalBufferSize,\r\n        NumProperties, AllProperties));\r\n      CurProp := AllProperties;\r\n      PropSize := TotalBufferSize div SizeOf(TGPNativePropertyItem);\r\n      for I := 0 to NumProperties - 1 do\r\n      begin\r\n        GetMem(Data, PropSize);\r\n        Move(CurProp^, Data^, PropSize);\r\n        Result[I] := TGPPropertyItem.Create(Data);\r\n        Inc(CurProp);\r\n      end;\r\n    finally\r\n      FreeMem(AllProperties);\r\n    end;\r\n  end;\r\nend;\r\n\r\nfunction TGPImage.GetRawFormat: TGUID;\r\nbegin\r\n  GdipCheck(GdipGetImageRawFormat(FNativeHandle, Result));\r\nend;\r\n\r\nfunction TGPImage.GetThumbnailImage(const ThumbWidth, ThumbHeight: Cardinal;\r\n  const Callback: TGPGetThumbnailImageAbort; const CallbackData: Pointer): IGPImage;\r\nvar\r\n  NativeThumbnail: GpImage;\r\nbegin\r\n  NativeThumbnail := nil;\r\n  GdipCheck(GdipGetImageThumbnail(FNativeHandle, ThumbWidth, ThumbHeight,\r\n    NativeThumbnail, Callback, CallbackData));\r\n  Result := TGPImage.Create(NativeThumbnail);\r\nend;\r\n\r\nfunction TGPImage.GetType: TGPImageType;\r\nbegin\r\n  Result := ImageTypeUnknown;\r\n  GdipCheck(GdipGetImageType(FNativeHandle, Result));\r\nend;\r\n\r\nfunction TGPImage.GetVerticalResolution: Single;\r\nbegin\r\n  Result := 0;\r\n  GdipCheck(GdipGetImageVerticalResolution(FNativeHandle, Result));\r\nend;\r\n\r\nfunction TGPImage.GetWidth: Cardinal;\r\nbegin\r\n  Result := 0;\r\n  GdipCheck(GdipGetImageWidth(FNativeHandle, Result));\r\nend;\r\n\r\nprocedure TGPImage.RemovePropertyItem(const PropId: TPropID);\r\nbegin\r\n  GdipCheck(GdipRemovePropertyItem(FNativeHandle, PropId));\r\nend;\r\n\r\nprocedure TGPImage.RotateFlip(const RotateFlipType: TGPRotateFlipType);\r\nbegin\r\n  GdipCheck(GdipImageRotateFlip(FNativeHandle, RotateFlipType));\r\nend;\r\n\r\nprocedure TGPImage.Save(const Filename: String; const Encoder: IGPImageCodecInfo;\r\n  const Params: IGPEncoderParameters);\r\nvar\r\n  NativeParams: PGPNativeEncoderParameters;\r\nbegin\r\n  Assert(Assigned(Encoder));\r\n  if Assigned(Params) then\r\n    NativeParams := Params.NativeParams\r\n  else\r\n    NativeParams := nil;\r\n  GdipCheck(GdipSaveImageToFile(FNativeHandle, PWideChar(Filename),\r\n    Encoder.ClsId, NativeParams));\r\nend;\r\n\r\nprocedure TGPImage.Save(const Stream: IStream; const Format: IGPImageFormat;\r\n  const Params: IGPEncoderParameters);\r\nvar\r\n  NativeParams: PGPNativeEncoderParameters;\r\nbegin\r\n  Assert(Assigned(Format));\r\n  if Assigned(Params) then\r\n    NativeParams := Params.NativeParams\r\n  else\r\n    NativeParams := nil;\r\n  GdipCheck(GdipSaveImageToStream(FNativeHandle, Stream, Format.CodecId, NativeParams));\r\nend;\r\n\r\nprocedure TGPImage.Save(const Stream: IStream; const Encoder: IGPImageCodecInfo;\r\n  const Params: IGPEncoderParameters);\r\nvar\r\n  NativeParams: PGPNativeEncoderParameters;\r\nbegin\r\n  Assert(Assigned(Encoder));\r\n  if Assigned(Params) then\r\n    NativeParams := Params.NativeParams\r\n  else\r\n    NativeParams := nil;\r\n  GdipCheck(GdipSaveImageToStream(FNativeHandle, Stream, Encoder.ClsId, NativeParams));\r\nend;\r\n\r\nprocedure TGPImage.Save(const Filename: String; const Format: IGPImageFormat;\r\n  const Params: IGPEncoderParameters);\r\nvar\r\n  NativeParams: PGPNativeEncoderParameters;\r\nbegin\r\n  Assert(Assigned(Format));\r\n  if Assigned(Params) then\r\n    NativeParams := Params.NativeParams\r\n  else\r\n    NativeParams := nil;\r\n  GdipCheck(GdipSaveImageToFile(FNativeHandle, PWideChar(Filename),\r\n    Format.CodecId, NativeParams));\r\nend;\r\n\r\nprocedure TGPImage.SaveAdd(const NewImage: IGPImage;\r\n  const Params: IGPEncoderParameters);\r\nbegin\r\n  Assert(Assigned(Params));\r\n  if (NewImage = nil) then\r\n    GdipCheck(InvalidParameter);\r\n  GdipCheck(GdipSaveAddImage(FNativeHandle, NewImage.NativeHandle, Params.NativeParams));\r\nend;\r\n\r\nprocedure TGPImage.SaveAdd(const Params: IGPEncoderParameters);\r\nbegin\r\n  Assert(Assigned(Params));\r\n  GdipCheck(GdipSaveAdd(FNativeHandle, Params.NativeParams));\r\nend;\r\n\r\nprocedure TGPImage.SelectActiveFrame(const DimensionID: TGUID;\r\n  const FrameIndex: Cardinal);\r\nbegin\r\n  GdipCheck(GdipImageSelectActiveFrame(FNativeHandle, DimensionID, FrameIndex));\r\nend;\r\n\r\nprocedure TGPImage.SetPalette(const Value: IGPColorPalette);\r\nbegin\r\n  Assert(Assigned(Value));\r\n  GdipCheck(GdipSetImagePalette(FNativeHandle, Value.NativePalette));\r\nend;\r\n\r\nprocedure TGPImage.SetPropertyItem(const PropItem: IGPPropertyItem);\r\nbegin\r\n  Assert(Assigned(PropItem));\r\n  GdipCheck(GdipSetPropertyItem(FNativeHandle, PropItem.NativeItem));\r\nend;\r\n\r\n{$IF (GDIPVER >= $0110)}\r\n\r\n{ TGPHistogram }\r\n\r\nconstructor TGPHistogram.Create(const AChannelCount, AEntryCount: Integer; const AChannel0, AChannel1,\r\n  AChannel2, AChannel3: PCardinal);\r\nbegin\r\n  inherited Create;\r\n  FChannelCount := AChannelCount;\r\n  FEntryCount := AEntryCount;\r\n  FChannels[0] := AChannel0;\r\n  FChannels[1] := AChannel1;\r\n  FChannels[2] := AChannel2;\r\n  FChannels[3] := AChannel3;\r\nend;\r\n\r\ndestructor TGPHistogram.Destroy;\r\nbegin\r\n  FreeMem(FChannels[3]);\r\n  FreeMem(FChannels[2]);\r\n  FreeMem(FChannels[1]);\r\n  FreeMem(FChannels[0]);\r\n  inherited;\r\nend;\r\n\r\nfunction TGPHistogram.GetChannel0(const Index: Integer): Cardinal;\r\nbegin\r\n  Result := FChannels[0, Index];\r\nend;\r\n\r\nfunction TGPHistogram.GetChannel0Ptr: PCardinal;\r\nbegin\r\n  Result := FChannels[0];\r\nend;\r\n\r\nfunction TGPHistogram.GetChannel1(const Index: Integer): Cardinal;\r\nbegin\r\n  Result := FChannels[1,Index];\r\nend;\r\n\r\nfunction TGPHistogram.GetChannel1Ptr: PCardinal;\r\nbegin\r\n  Result := FChannels[1];\r\nend;\r\n\r\nfunction TGPHistogram.GetChannel2(const Index: Integer): Cardinal;\r\nbegin\r\n  Result := FChannels[2,Index];\r\nend;\r\n\r\nfunction TGPHistogram.GetChannel2Ptr: PCardinal;\r\nbegin\r\n  Result := FChannels[2];\r\nend;\r\n\r\nfunction TGPHistogram.GetChannel3(const Index: Integer): Cardinal;\r\nbegin\r\n  Result := FChannels[3,Index];\r\nend;\r\n\r\nfunction TGPHistogram.GetChannel3Ptr: PCardinal;\r\nbegin\r\n  Result := FChannels[3];\r\nend;\r\n\r\nfunction TGPHistogram.GetChannelCount: Integer;\r\nbegin\r\n  Result := FChannelCount;\r\nend;\r\n\r\nfunction TGPHistogram.GetEntryCount: Integer;\r\nbegin\r\n  Result := FEntryCount;\r\nend;\r\n\r\nfunction TGPHistogram.GetValue(const ChannelIndex, EntryIndex: Integer): Cardinal;\r\nbegin\r\n  Result := FChannels[ChannelIndex, EntryIndex];\r\nend;\r\n\r\nfunction TGPHistogram.GetValuePtr(const ChannelIndex: Integer): PCardinal;\r\nbegin\r\n  Result := FChannels[ChannelIndex];\r\nend;\r\n{$IFEND}\r\n\r\n{ TGPBitmap }\r\n\r\n{$IF (GDIPVER >= $0110)}\r\nprocedure TGPBitmap.ApplyEffect(const Effect: IGPEffect; const ROI: Windows.PRect);\r\nvar\r\n  AuxData: Pointer;\r\n  AuxDataSize: Integer;\r\nbegin\r\n  Effect.ReleaseAuxData;\r\n  AuxData := nil;\r\n  AuxDataSize := 0;\r\n  GdipCheck(GdipBitmapApplyEffect(FNativeHandle, Effect.NativeHandle, ROI,\r\n    Effect.UseAuxData, AuxData, AuxDataSize));\r\n  Effect.SetAuxData(AuxData, AuxDataSize);\r\nend;\r\n\r\nclass function TGPBitmap.ApplyEffect(const Inputs: array of IGPBitmap;\r\n  const Effect: IGPEffect; const ROI, OutputRect: Windows.PRect): IGPBitmap;\r\nvar\r\n  NativeInputs: array of GpBitmap;\r\n  NativeOutput: GpBitmap;\r\n  I, AuxDataSize: Integer;\r\n  AuxData: Pointer;\r\nbegin\r\n  SetLength(NativeInputs, Length(Inputs));\r\n  for I := 0 to Length(Inputs) - 1 do\r\n    NativeInputs[I] := Inputs[I].NativeHandle;\r\n\r\n  Effect.ReleaseAuxData;\r\n  AuxData := nil;\r\n  AuxDataSize := 0;\r\n\r\n  GdipCheck(GdipBitmapCreateApplyEffect(@NativeInputs[0], Length(Inputs),\r\n    Effect.NativeHandle, ROI, OutputRect, NativeOutput, Effect.UseAuxData,\r\n    AuxData, AuxDataSize));\r\n\r\n  Effect.SetAuxData(AuxData, AuxDataSize);\r\n  Result := TGPBitmap.Create(NativeOutput);\r\nend;\r\n{$IFEND}\r\n\r\nfunction TGPBitmap.Clone(const Rect: TGPRectF; const Format: TGPPixelFormat): IGPBitmap;\r\nbegin\r\n  Result := Clone(Rect.X, Rect.Y, Rect.Width, Rect.Height, Format);\r\nend;\r\n\r\nfunction TGPBitmap.Clone(const X, Y, Width, Height: Single;\r\n  const Format: TGPPixelFormat): IGPBitmap;\r\nvar\r\n  NativeClone: GpBitmap;\r\nbegin\r\n  GdipCheck(GdipCloneBitmapArea(X, Y, Width, Height, Format, FNativeHandle, NativeClone));\r\n  Result := TGPBitmap.Create(NativeClone);\r\nend;\r\n\r\nfunction TGPBitmap.Clone: IGPBitmap;\r\nbegin\r\n  Result := Clone(0, 0, GetWidth, GetHeight, GetPixelFormat);\r\nend;\r\n\r\nfunction TGPBitmap.Clone(const X, Y, Width, Height: Integer;\r\n  const Format: TGPPixelFormat): IGPBitmap;\r\nvar\r\n  NativeClone: GpBitmap;\r\nbegin\r\n  GdipCheck(GdipCloneBitmapAreaI(X, Y, Width, Height, Format, FNativeHandle, NativeClone));\r\n  Result := TGPBitmap.Create(NativeClone);\r\nend;\r\n\r\nfunction TGPBitmap.Clone(const Rect: TGPRect; const Format: TGPPixelFormat): IGPBitmap;\r\nbegin\r\n  Result := Clone(Rect.X, Rect.Y, Rect.Width, Rect.Height, Format);\r\nend;\r\n\r\n{$IF (GDIPVER >= $0110)}\r\nprocedure TGPBitmap.ConvertFormat(const Format: TGPPixelFormat;\r\n  const DitherType: TGPDitherType; const PaletteType: TGPPaletteType;\r\n  const Palette: IGPColorPalette; const AlphaThresholdPercent: Single);\r\nvar\r\n  NativePalette: PGPNativeColorPalette;\r\nbegin\r\n  if Assigned(Palette) then\r\n    NativePalette := Palette.NativePalette\r\n  else\r\n    NativePalette := nil;\r\n  GdipCheck(GdipBitmapConvertFormat(FNativeHandle, Format, DitherType,\r\n    PaletteType, NativePalette, AlphaThresholdPercent));\r\nend;\r\n{$IFEND}\r\n\r\nconstructor TGPBitmap.Create(const Filename: String;\r\n  const UseEmbeddedColorManagement: Boolean);\r\nbegin\r\n  inherited Create;\r\n  if (UseEmbeddedColorManagement) then\r\n    GdipCheck(GdipCreateBitmapFromFileICM(PWideChar(Filename), FNativeHandle))\r\n  else\r\n    GdipCheck(GdipCreateBitmapFromFile(PWideChar(Filename), FNativeHandle))\r\nend;\r\n\r\nconstructor TGPBitmap.Create(const NativeBitmap: GpBitmap);\r\nbegin\r\n  inherited Create(NativeBitmap);\r\nend;\r\n\r\nconstructor TGPBitmap.Create(const BitmapHandle: HBitmap;\r\n  const Palette: HPalette);\r\nbegin\r\n  inherited Create;\r\n  GdipCheck(GdipCreateBitmapFromHBITMAP(BitmapHandle, Palette, FNativeHandle))\r\nend;\r\n\r\nconstructor TGPBitmap.Create(const BitmapInfo: TBitmapInfo;\r\n  const BitmapData: Pointer);\r\nbegin\r\n  inherited Create;\r\n  GdipCheck(GdipCreateBitmapFromGdiDib(@BitmapInfo, BitmapData, FNativeHandle))\r\nend;\r\n\r\nconstructor TGPBitmap.Create(const Instance: HInst; const BitmapName: String);\r\nbegin\r\n  inherited Create;\r\n  GdipCheck(GdipCreateBitmapFromResource(Instance, PWideChar(BitmapName), FNativeHandle))\r\nend;\r\n\r\nconstructor TGPBitmap.Create(const IconHandle: HIcon);\r\nbegin\r\n  inherited Create;\r\n  GdipCheck(GdipCreateBitmapFromHICON(IconHandle, FNativeHandle))\r\nend;\r\n\r\nconstructor TGPBitmap.Create(const DirectDrawSurface7: IInterface);\r\n{$IFOPT C+}\r\nconst\r\n  IID_IDirectDrawSurface7: TGUID = '{15e65ec0-3b9c-11d2-b92f-00609797ea5b}';\r\n{$ENDIF}\r\nbegin\r\n  {$IFOPT C+}\r\n  Assert(Supports(DirectDrawSurface7, IID_IDirectDrawSurface7));\r\n  {$ENDIF}\r\n  inherited Create;\r\n  GdipCheck(GdipCreateBitmapFromDirectDrawSurface(DirectDrawSurface7, FNativeHandle))\r\nend;\r\n\r\nconstructor TGPBitmap.Create(const Stream: IStream;\r\n  const UseEmbeddedColorManagement: Boolean);\r\nbegin\r\n  inherited Create;\r\n  if (UseEmbeddedColorManagement) then\r\n    GdipCheck(GdipCreateBitmapFromStreamICM(Stream, FNativeHandle))\r\n  else\r\n    GdipCheck(GdipCreateBitmapFromStream(Stream, FNativeHandle))\r\nend;\r\n\r\nconstructor TGPBitmap.Create(const Width, Height, Stride: Integer;\r\n  const Format: TGPPixelFormat; const Scan0: Pointer);\r\nbegin\r\n  inherited Create;\r\n  GdipCheck(GdipCreateBitmapFromScan0(Width, Height, Stride, Format, Scan0, FNativeHandle));\r\nend;\r\n\r\nconstructor TGPBitmap.Create(const Width, Height: Integer;\r\n  const Target: IGPGraphics);\r\nbegin\r\n  inherited Create;\r\n  GdipCheck(GdipCreateBitmapFromGraphics(Width, Height, Target.NativeHandle, FNativeHandle));\r\nend;\r\n\r\nconstructor TGPBitmap.Create(const Width, Height: Integer;\r\n  const Format: TGPPixelFormat);\r\nbegin\r\n  inherited Create;\r\n  GdipCheck(GdipCreateBitmapFromScan0(Width, Height, 0, Format, nil, FNativeHandle));\r\nend;\r\n\r\nclass function TGPBitmap.FromBitmapInfo(const BitmapInfo: TBitmapInfo;\r\n  const BitmapData: Pointer): IGPBitmap;\r\nbegin\r\n  Result := TGPBitmap.Create(BitmapInfo, BitmapData);\r\nend;\r\n\r\nclass function TGPBitmap.FromDirectDrawSurface7(\r\n  const Surface: IInterface): IGPBitmap;\r\nbegin\r\n  Result := TGPBitmap.Create(Surface);\r\nend;\r\n\r\nclass function TGPBitmap.FromFile(const Filename: String;\r\n  const UseEmbeddedColorManagement: Boolean): IGPBitmap;\r\nbegin\r\n  Result := TGPBitmap.Create(Filename, UseEmbeddedColorManagement);\r\nend;\r\n\r\nclass function TGPBitmap.FromHBitmap(const BitmapHandle: HBitmap;\r\n  const Palette: HPalette): IGPBitmap;\r\nbegin\r\n  Result := TGPBitmap.Create(BitmapHandle, Palette);\r\nend;\r\n\r\nclass function TGPBitmap.FromHIcon(const IconHandle: HIcon): IGPBitmap;\r\nbegin\r\n  Result := TGPBitmap.Create(IconHandle);\r\nend;\r\n\r\nclass function TGPBitmap.FromResource(const Instance: HInst;\r\n  const BitmapName: String): IGPBitmap;\r\nbegin\r\n  Result := TGPBitmap.Create(Instance, BitmapName);\r\nend;\r\n\r\nclass function TGPBitmap.FromStream(const Stream: IStream;\r\n  const UseEmbeddedColorManagement: Boolean): IGPBitmap;\r\nbegin\r\n  Result := TGPBitmap.Create(Stream, UseEmbeddedColorManagement);\r\nend;\r\n\r\nfunction TGPBitmap.GetHBitmap(const ColorBackground: TGPColor): HBitmap;\r\nbegin\r\n  GdipCheck(GdipCreateHBITMAPFromBitmap(FNativeHandle, Result, ColorBackground.Value));\r\nend;\r\n\r\nfunction TGPBitmap.GetHIcon: HIcon;\r\nbegin\r\n  GdipCheck(GdipCreateHICONFromBitmap(FNativeHandle, Result));\r\nend;\r\n\r\n{$IF (GDIPVER >= $0110)}\r\nfunction TGPBitmap.GetHistogram(const Format: TGPHistogramFormat): IGPHistogram;\r\nvar\r\n  ChannelCount, EntryCount: Cardinal;\r\n  Channel0, Channel1, Channel2, Channel3: PCardinal;\r\nbegin\r\n  case Format of\r\n    HistogramFormatARGB,\r\n    HistogramFormatPARGB:\r\n      ChannelCount := 4;\r\n    HistogramFormatRGB:\r\n      ChannelCount := 3;\r\n  else\r\n    ChannelCount := 1;\r\n  end;\r\n  EntryCount := 0;\r\n  Channel0 := nil;\r\n  Channel1 := nil;\r\n  Channel2 := nil;\r\n  Channel3 := nil;\r\n  GdipCheck(GdipBitmapGetHistogramSize(Format, EntryCount));\r\n  if (EntryCount > 0) then\r\n  begin\r\n    GetMem(Channel0, EntryCount * SizeOf(Cardinal));\r\n    if (ChannelCount > 1) then\r\n    begin\r\n      GetMem(Channel1, EntryCount * SizeOf(Cardinal));\r\n      GetMem(Channel2, EntryCount * SizeOf(Cardinal));\r\n      if (ChannelCount > 3) then\r\n        GetMem(Channel3, EntryCount * SizeOf(Cardinal));\r\n    end;\r\n\r\n    try\r\n      GdipCheck(GdipBitmapGetHistogram(FNativeHandle, Format, EntryCount,\r\n        Channel0, Channel1, Channel2, Channel3));\r\n    except\r\n      FreeMem(Channel3);\r\n      FreeMem(Channel2);\r\n      FreeMem(Channel2);\r\n      FreeMem(Channel0);\r\n      Channel0 := nil;\r\n      Channel1 := nil;\r\n      Channel2 := nil;\r\n      Channel3 := nil;\r\n    end;\r\n  end;\r\n  Result := TGPHistogram.Create(ChannelCount, EntryCount, Channel0, Channel1, Channel2, Channel3);\r\nend;\r\n{$IFEND}\r\n\r\nfunction TGPBitmap.GetPixel(const X, Y: Integer): TGPColor;\r\nbegin\r\n  GdipCheck(GdipBitmapGetPixel(FNativeHandle, X, Y, Result.FArgb));\r\nend;\r\n\r\n{$IF (GDIPVER >= $0110)}\r\nclass function TGPBitmap.InitializePalette(const ColorCount: Integer;\r\n  const PaletteType: TGPPaletteType; const OptimalColors: Integer;\r\n  const UseTransparentColor: Boolean; const Bitmap: IGPBitmap): IGPColorPalette;\r\nvar\r\n  NativePalette: PGPNativeColorPalette;\r\nbegin\r\n  GetMem(NativePalette, SizeOf(TGPNativeColorPalette) + ColorCount * SizeOf(ARGB));\r\n  NativePalette.Flags := [];\r\n  NativePalette.Count := ColorCount;\r\n  try\r\n    GdipCheck(GdipInitializePalette(NativePalette, PaletteType, OptimalColors,\r\n      UseTransparentColor, GdipHandle(Bitmap)));\r\n  except\r\n    FreeMem(NativePalette);\r\n    raise;\r\n  end;\r\n  Result := TGPColorPalette.Create(NativePalette);\r\nend;\r\n{$IFEND}\r\n\r\nfunction TGPBitmap.LockBits(const Rect: TGPRect; const Mode: TGPImageLockMode;\r\n  const Format: TGPPixelFormat): TGPBitmapData;\r\nbegin\r\n  GdipCheck(GdipBitmapLockBits(FNativeHandle, @Rect, Mode, Format, Result));\r\nend;\r\n\r\nprocedure TGPBitmap.SetPixel(const X, Y: Integer; const Value: TGPColor);\r\nbegin\r\n  GdipCheck(GdipBitmapSetPixel(FNativeHandle, X, Y, Value.Value));\r\nend;\r\n\r\nprocedure TGPBitmap.SetResolution(const XDpi, YDpi: Single);\r\nbegin\r\n  GdipCheck(GdipBitmapSetResolution(FNativeHandle, XDpi, YDpi));\r\nend;\r\n\r\nprocedure TGPBitmap.UnlockBits(const LockedBitmapData: TGPBitmapData);\r\nbegin\r\n  GdipCheck(GdipBitmapUnlockBits(FNativeHandle, LockedBitmapData));\r\nend;\r\n{$ENDREGION 'GdiplusBitmap.h'}\r\n\r\n{$REGION 'GdiplusLineCaps.h'}\r\n\r\n{ TGPCustomLineCap }\r\n\r\nfunction TGPCustomLineCap.Clone: IGPCustomLineCap;\r\nvar\r\n  NativeClone: GpCustomLineCap;\r\nbegin\r\n  NativeClone := nil;\r\n  GdipCheck(GdipCloneCustomLineCap(FNativeHandle, NativeClone));\r\n  Result := TGPCustomLineCap.Create(NativeClone);\r\nend;\r\n\r\nconstructor TGPCustomLineCap.Create(const NativeLineCap: GpCustomLineCap);\r\nbegin\r\n  inherited Create;\r\n  FNativeHandle := NativeLineCap;\r\nend;\r\n\r\nconstructor TGPCustomLineCap.Create(const FillPath, StrokePath: IGPGraphicsPath;\r\n  const BaseCap: TGPLineCap; const BaseInset: Single);\r\nbegin\r\n  inherited Create;\r\n  GdipCheck(GdipCreateCustomLineCap(GdipHandle(FillPath), GdipHandle(StrokePath),\r\n    BaseCap, BaseInset, FNativeHandle));\r\nend;\r\n\r\ndestructor TGPCustomLineCap.Destroy;\r\nbegin\r\n  GdipDeleteCustomLineCap(FNativeHandle);\r\n  inherited;\r\nend;\r\n\r\nfunction TGPCustomLineCap.GetBaseCap: TGPLineCap;\r\nbegin\r\n  GdipCheck(GdipGetCustomLineCapBaseCap(FNativeHandle, Result));\r\nend;\r\n\r\nfunction TGPCustomLineCap.GetBaseInset: Single;\r\nbegin\r\n  GdipCheck(GdipGetCustomLineCapBaseInset(FNativeHandle, Result));\r\nend;\r\n\r\nprocedure TGPCustomLineCap.GetStrokeCaps(out StartCap, EndCap: TGPLineCap);\r\nbegin\r\n  GdipCheck(GdipGetCustomLineCapStrokeCaps(FNativeHandle, StartCap, EndCap));\r\nend;\r\n\r\nfunction TGPCustomLineCap.GetStrokeJoin: TGPLineJoin;\r\nbegin\r\n  GdipCheck(GdipGetCustomLineCapStrokeJoin(FNativeHandle, Result));\r\nend;\r\n\r\nfunction TGPCustomLineCap.GetWidthScale: Single;\r\nbegin\r\n  GdipCheck(GdipGetCustomLineCapWidthScale(FNativeHandle, Result));\r\nend;\r\n\r\nprocedure TGPCustomLineCap.SetBaseCap(const Value: TGPLineCap);\r\nbegin\r\n  GdipCheck(GdipSetCustomLineCapBaseCap(FNativeHandle, Value));\r\nend;\r\n\r\nprocedure TGPCustomLineCap.SetBaseInset(const Value: Single);\r\nbegin\r\n  GdipCheck(GdipSetCustomLineCapBaseInset(FNativeHandle, Value));\r\nend;\r\n\r\nprocedure TGPCustomLineCap.SetStrokeCap(const StrokeCap: TGPLineCap);\r\nbegin\r\n  SetStrokeCaps(StrokeCap, StrokeCap);\r\nend;\r\n\r\nprocedure TGPCustomLineCap.SetStrokeCaps(const StartCap, EndCap: TGPLineCap);\r\nbegin\r\n  GdipCheck(GdipSetCustomLineCapStrokeCaps(FNativeHandle, StartCap, EndCap));\r\nend;\r\n\r\nprocedure TGPCustomLineCap.SetStrokeJoin(const Value: TGPLineJoin);\r\nbegin\r\n  GdipCheck(GdipSetCustomLineCapStrokeJoin(FNativeHandle, Value));\r\nend;\r\n\r\nprocedure TGPCustomLineCap.SetWidthScale(const Value: Single);\r\nbegin\r\n  GdipCheck(GdipSetCustomLineCapWidthScale(FNativeHandle, Value));\r\nend;\r\n\r\n{ TGPAdjustableArrowCap }\r\n\r\nconstructor TGPAdjustableArrowCap.Create(const Height, Width: Single;\r\n  const IsFilled: Boolean);\r\nbegin\r\n  GdipCheck(GdipCreateAdjustableArrowCap(Height, Width, IsFilled, FNativeHandle));\r\nend;\r\n\r\nfunction TGPAdjustableArrowCap.GetFilled: Boolean;\r\nvar\r\n  B: Bool;\r\nbegin\r\n  GdipCheck(GdipGetAdjustableArrowCapFillState(FNativeHandle, B));\r\n  Result := B;\r\nend;\r\n\r\nfunction TGPAdjustableArrowCap.GetHeight: Single;\r\nbegin\r\n  GdipCheck(GdipGetAdjustableArrowCapHeight(FNativeHandle, Result));\r\nend;\r\n\r\nfunction TGPAdjustableArrowCap.GetMiddleInset: Single;\r\nbegin\r\n  GdipCheck(GdipGetAdjustableArrowCapMiddleInset(FNativeHandle, Result));\r\nend;\r\n\r\nfunction TGPAdjustableArrowCap.GetWidth: Single;\r\nbegin\r\n  GdipCheck(GdipGetAdjustableArrowCapWidth(FNativeHandle, Result));\r\nend;\r\n\r\nprocedure TGPAdjustableArrowCap.SetFilled(const Value: Boolean);\r\nbegin\r\n  GdipCheck(GdipSetAdjustableArrowCapFillState(FNativeHandle, Value));\r\nend;\r\n\r\nprocedure TGPAdjustableArrowCap.SetHeight(const Value: Single);\r\nbegin\r\n  GdipCheck(GdipSetAdjustableArrowCapHeight(FNativeHandle, Value));\r\nend;\r\n\r\nprocedure TGPAdjustableArrowCap.SetMiddleInset(const Value: Single);\r\nbegin\r\n  GdipCheck(GdipSetAdjustableArrowCapMiddleInset(FNativeHandle, Value));\r\nend;\r\n\r\nprocedure TGPAdjustableArrowCap.SetWidth(const Value: Single);\r\nbegin\r\n  GdipCheck(GdipSetAdjustableArrowCapWidth(FNativeHandle, Value));\r\nend;\r\n{$ENDREGION 'GdiplusLineCaps.h'}\r\n\r\n{$REGION 'GdiplusCachedBitmap.h'}\r\n\r\n{ TGPCachedBitmap }\r\n\r\nconstructor TGPCachedBitmap.Create(const Bitmap: IGPBitmap;\r\n  const Graphics: IGPGraphics);\r\nbegin\r\n  inherited Create;\r\n  GdipCheck(GdipCreateCachedBitmap(Bitmap.NativeHandle, Graphics.NativeHandle, FNativeHandle));\r\nend;\r\n\r\ndestructor TGPCachedBitmap.Destroy;\r\nbegin\r\n  GdipDeleteCachedBitmap(FNativeHandle);\r\n  inherited;\r\nend;\r\n{$ENDREGION 'GdiplusCachedBitmap.h'}\r\n\r\n{$REGION 'GdiplusMetafile.h'}\r\n\r\n{ TGPMetafile }\r\n\r\n{$IF (GDIPVER >= $0110)}\r\nprocedure TGPMetafile.ConvertToEmfPlus(const RefGraphics: IGPGraphics;\r\n  const ConversionFailureFlag: PInteger; const EmfType: TGPEmfType;\r\n  const Description: String);\r\nvar\r\n  Metafile: GpMetafile;\r\nbegin\r\n  Metafile := nil;\r\n  GdipCheck(GdipConvertToEmfPlus(RefGraphics.NativeHandle, FNativeHandle,\r\n    ConversionFailureFlag, EmfType, PWideChar(Description), Metafile));\r\n  GdipDisposeImage(FNativeHandle);\r\n  FNativeHandle := Metafile;\r\nend;\r\n\r\nprocedure TGPMetafile.ConvertToEmfPlus(const RefGraphics: IGPGraphics;\r\n  const Filename: String; const ConversionFailureFlag: PInteger;\r\n  const EmfType: TGPEmfType; const Description: String);\r\nvar\r\n  Metafile: GpMetafile;\r\nbegin\r\n  Metafile := nil;\r\n  GdipCheck(GdipConvertToEmfPlusToFile(RefGraphics.NativeHandle, FNativeHandle,\r\n    ConversionFailureFlag, PWideChar(Filename), EmfType, PWideChar(Description), Metafile));\r\n  GdipDisposeImage(FNativeHandle);\r\n  FNativeHandle := Metafile;\r\nend;\r\n\r\nprocedure TGPMetafile.ConvertToEmfPlus(const RefGraphics: IGPGraphics;\r\n  const Stream: IStream; const ConversionFailureFlag: PInteger;\r\n  const EmfType: TGPEmfType; const Description: String);\r\nvar\r\n  Metafile: GpMetafile;\r\nbegin\r\n  Metafile := nil;\r\n  GdipCheck(GdipConvertToEmfPlusToStream(RefGraphics.NativeHandle, FNativeHandle,\r\n    ConversionFailureFlag, Stream, EmfType, PWideChar(Description), Metafile));\r\n  GdipDisposeImage(FNativeHandle);\r\n  FNativeHandle := Metafile;\r\nend;\r\n{$IFEND}\r\n\r\nconstructor TGPMetafile.Create(const Filename: String;\r\n  const WmfPlaceableFileHeader: TWmfPlaceableFileHeader);\r\nbegin\r\n  inherited Create;\r\n  GdipCheck(GdipCreateMetafileFromWmfFile(PWideChar(Filename), WmfPlaceableFileHeader, FNativeHandle));\r\nend;\r\n\r\nconstructor TGPMetafile.Create(const Stream: IStream);\r\nbegin\r\n  inherited Create;\r\n  GdipCheck(GdipCreateMetafileFromStream(Stream, FNativeHandle));\r\nend;\r\n\r\nconstructor TGPMetafile.Create(const ReferenceDC: HDC; const EmfType: TGPEmfType;\r\n  const Description: String);\r\nbegin\r\n  inherited Create;\r\n  GdipCheck(GdipRecordMetafile(ReferenceDC, EmfType, nil, MetafileFrameUnitGdi,\r\n    PWideChar(Description), FNativeHandle));\r\nend;\r\n\r\nconstructor TGPMetafile.Create(const Filename: String);\r\nbegin\r\n  inherited Create;\r\n  GdipCheck(GdipCreateMetafileFromFile(PWideChar(Filename), FNativeHandle));\r\nend;\r\n\r\nconstructor TGPMetafile.Create(const Wmf: HMetafile;\r\n  const WmfPlaceableFileHeader: TWmfPlaceableFileHeader;\r\n  const DeleteWmf: Boolean);\r\nbegin\r\n  inherited Create;\r\n  GdipCheck(GdipCreateMetafileFromWmf(Wmf, DeleteWmf, WmfPlaceableFileHeader, FNativeHandle));\r\nend;\r\n\r\nconstructor TGPMetafile.Create(const Emf: HEnhMetafile; const DeleteEmf: Boolean);\r\nbegin\r\n  inherited Create;\r\n  GdipCheck(GdipCreateMetafileFromEmf(Emf, DeleteEmf, FNativeHandle));\r\nend;\r\n\r\nconstructor TGPMetafile.Create(const ReferenceDC: HDC; const FrameRect: TGPRectF;\r\n  const FrameUnit: TGPMetafileFrameUnit; const EmfType: TGPEmfType;\r\n  const Description: String);\r\nbegin\r\n  inherited Create;\r\n  GdipCheck(GdipRecordMetafile(ReferenceDC, EmfType, @FrameRect, FrameUnit,\r\n    PWideChar(Description), FNativeHandle));\r\nend;\r\n\r\nconstructor TGPMetafile.Create(const Stream: IStream; const ReferenceDC: HDC;\r\n  const EmfType: TGPEmfType; const Description: String);\r\nbegin\r\n  inherited Create;\r\n  GdipCheck(GdipRecordMetafileStream(Stream, ReferenceDC, EmfType, nil,\r\n    MetafileFrameUnitGdi, PWideChar(Description), FNativeHandle));\r\nend;\r\n\r\nconstructor TGPMetafile.Create(const Stream: IStream; const ReferenceDC: HDC;\r\n  const FrameRect: TGPRectF; const FrameUnit: TGPMetafileFrameUnit;\r\n  const EmfType: TGPEmfType; const Description: String);\r\nbegin\r\n  inherited Create;\r\n  GdipCheck(GdipRecordMetafileStream(Stream, ReferenceDC, EmfType, @FrameRect,\r\n    FrameUnit, PWideChar(Description), FNativeHandle));\r\nend;\r\n\r\nconstructor TGPMetafile.Create(const Stream: IStream; const ReferenceDC: HDC;\r\n  const FrameRect: TGPRect; const FrameUnit: TGPMetafileFrameUnit;\r\n  const EmfType: TGPEmfType; const Description: String);\r\nbegin\r\n  inherited Create;\r\n  GdipCheck(GdipRecordMetafileStreamI(Stream, ReferenceDC, EmfType, @FrameRect,\r\n    FrameUnit, PWideChar(Description), FNativeHandle));\r\nend;\r\n\r\nconstructor TGPMetafile.Create(const Filename: String; const ReferenceDC: HDC;\r\n  const FrameRect: TGPRect; const FrameUnit: TGPMetafileFrameUnit;\r\n  const EmfType: TGPEmfType; const Description: String);\r\nbegin\r\n  inherited Create;\r\n  GdipCheck(GdipRecordMetafileFileNameI(PWideChar(Filename), ReferenceDC,\r\n    EmfType, @FrameRect, FrameUnit, PWideChar(Description), FNativeHandle));\r\nend;\r\n\r\nconstructor TGPMetafile.Create(const ReferenceDC: HDC; const FrameRect: TGPRect;\r\n  const FrameUnit: TGPMetafileFrameUnit; const EmfType: TGPEmfType;\r\n  const Description: String);\r\nbegin\r\n  inherited Create;\r\n  GdipCheck(GdipRecordMetafileI(ReferenceDC, EmfType, @FrameRect, FrameUnit,\r\n    PWideChar(Description), FNativeHandle));\r\nend;\r\n\r\nconstructor TGPMetafile.Create(const Filename: String; const ReferenceDC: HDC;\r\n  const EmfType: TGPEmfType; const Description: String);\r\nbegin\r\n  inherited Create;\r\n  GdipCheck(GdipRecordMetafileFileName(PWideChar(Filename), ReferenceDC,\r\n    EmfType, nil, MetafileFrameUnitGdi, PWideChar(Description), FNativeHandle));\r\nend;\r\n\r\nconstructor TGPMetafile.Create(const Filename: String; const ReferenceDC: HDC;\r\n  const FrameRect: TGPRectF; const FrameUnit: TGPMetafileFrameUnit;\r\n  const EmfType: TGPEmfType; const Description: String);\r\nbegin\r\n  inherited Create;\r\n  GdipCheck(GdipRecordMetafileFileName(PWideChar(Filename), ReferenceDC,\r\n    EmfType, @FrameRect, FrameUnit, PWideChar(Description), FNativeHandle));\r\nend;\r\n\r\nclass function TGPMetafile.EmfToWmfBits(const Emf: HEnhMetafile;\r\n  const MapMode: Integer; const Flags: TGPEmfToWmfBitsFlags): IGPBuffer;\r\nvar\r\n  Data: Pointer;\r\n  Size: Integer;\r\nbegin\r\n  Data := nil;\r\n  Size := GdipEmfToWmfBits(Emf, 0, nil, MapMode, Flags);\r\n  if (Size > 0) then\r\n  begin\r\n    GetMem(Data, Size);\r\n    GdipEmfToWmfBits(Emf, Size, Data, MapMode, Flags);\r\n  end;\r\n  Result := TGPBuffer.Create(Data, Size);\r\nend;\r\n\r\nfunction TGPMetafile.GetDownLevelRasterizationLimit: Cardinal;\r\nbegin\r\n  GdipCheck(GdipGetMetafileDownLevelRasterizationLimit(FNativeHandle, Result));\r\nend;\r\n\r\nfunction TGPMetafile.GetHEnhMetafile: HEnhMetafile;\r\nbegin\r\n  GdipCheck(GdipGetHemfFromMetafile(FNativeHandle, Result));\r\nend;\r\n\r\nclass function TGPMetafile.GetMetafileHeader(\r\n  const Emf: HEnhMetafile): TGPMetafileHeader;\r\nbegin\r\n  GdipCheck(GdipGetMetafileHeaderFromEmf(Emf, Result));\r\nend;\r\n\r\nclass function TGPMetafile.GetMetafileHeader(const Wmf: HMetafile;\r\n  const WmfPlaceableFileHeader: TWmfPlaceableFileHeader): TGPMetafileHeader;\r\nbegin\r\n  GdipCheck(GdipGetMetafileHeaderFromWmf(Wmf, WmfPlaceableFileHeader, Result));\r\nend;\r\n\r\nfunction TGPMetafile.GetMetafileHeader: TGPMetafileHeader;\r\nbegin\r\n  GdipCheck(GdipGetMetafileHeaderFromMetafile(FNativeHandle, Result));\r\nend;\r\n\r\nclass function TGPMetafile.GetMetafileHeader(\r\n  const Filename: String): TGPMetafileHeader;\r\nbegin\r\n  GdipCheck(GdipGetMetafileHeaderFromFile(PWideChar(Filename), Result));\r\nend;\r\n\r\nclass function TGPMetafile.GetMetafileHeader(\r\n  const Stream: IStream): TGPMetafileHeader;\r\nbegin\r\n  GdipCheck(GdipGetMetafileHeaderFromStream(Stream, Result));\r\nend;\r\n\r\nprocedure TGPMetafile.PlayRecord(const RecordType: TEmfPlusRecordType;\r\n  const Flags, DataSize: Integer; const Data: Pointer);\r\nbegin\r\n  GdipCheck(GdipPlayMetafileRecord(FNativeHandle, RecordType, Flags, DataSize, Data));\r\nend;\r\n\r\nprocedure TGPMetafile.SetDownLevelRasterizationLimit(const Value: Cardinal);\r\nbegin\r\n  GdipCheck(GdipSetMetafileDownLevelRasterizationLimit(FNativeHandle, Value));\r\nend;\r\n{$ENDREGION 'GdiplusMetafile.h'}\r\n\r\n{$REGION 'GdiplusImageAttributes.h'}\r\n\r\n{ TGPImageAttributes }\r\n\r\nprocedure TGPImageAttributes.ClearBrushRemapTable;\r\nbegin\r\n  ClearRemapTable(ColorAdjustTypeBrush);\r\nend;\r\n\r\nprocedure TGPImageAttributes.ClearColorKey(const AdjustType: TGPColorAdjustType);\r\nbegin\r\n  GdipCheck(GdipSetImageAttributesColorKeys(FNativeHandle, AdjustType, False,\r\n    0, 0));\r\nend;\r\n\r\nprocedure TGPImageAttributes.ClearColorMatrices(\r\n  const AdjustType: TGPColorAdjustType);\r\nbegin\r\n  GdipCheck(GdipSetImageAttributesColorMatrix(FNativeHandle, AdjustType,\r\n    False, nil, nil, ColorMatrixFlagsDefault));\r\nend;\r\n\r\nprocedure TGPImageAttributes.ClearColorMatrix(const AdjustType: TGPColorAdjustType);\r\nbegin\r\n  GdipCheck(GdipSetImageAttributesColorMatrix(FNativeHandle, AdjustType,\r\n    False, nil, nil, ColorMatrixFlagsDefault));\r\nend;\r\n\r\nprocedure TGPImageAttributes.ClearGamma(const AdjustType: TGPColorAdjustType);\r\nbegin\r\n  GdipCheck(GdipSetImageAttributesGamma(FNativeHandle, AdjustType,\r\n    False, 0));\r\nend;\r\n\r\nprocedure TGPImageAttributes.ClearNoOp(const AdjustType: TGPColorAdjustType);\r\nbegin\r\n  GdipCheck(GdipSetImageAttributesNoOp(FNativeHandle, AdjustType, False));\r\nend;\r\n\r\nprocedure TGPImageAttributes.ClearOutputChannel(\r\n  const AdjustType: TGPColorAdjustType);\r\nbegin\r\n  GdipCheck(GdipSetImageAttributesOutputChannel(FNativeHandle, AdjustType, False,\r\n    ColorChannelFlagsLast));\r\nend;\r\n\r\nprocedure TGPImageAttributes.ClearOutputChannelColorProfile(\r\n  const AdjustType: TGPColorAdjustType);\r\nbegin\r\n  GdipCheck(GdipSetImageAttributesOutputChannelColorProfile(FNativeHandle,\r\n    AdjustType, False, nil));\r\nend;\r\n\r\nprocedure TGPImageAttributes.ClearRemapTable(const AdjustType: TGPColorAdjustType);\r\nbegin\r\n  GdipCheck(GdipSetImageAttributesRemapTable(FNativeHandle, AdjustType, False,\r\n    0, nil));\r\nend;\r\n\r\nprocedure TGPImageAttributes.ClearThreshold(const AdjustType: TGPColorAdjustType);\r\nbegin\r\n  GdipCheck(GdipSetImageAttributesThreshold(FNativeHandle, AdjustType,\r\n    False, 0));\r\nend;\r\n\r\nfunction TGPImageAttributes.Clone: IGPImageAttributes;\r\nvar\r\n  NativeClone: GpImageAttributes;\r\nbegin\r\n  GdipCheck(GdipCloneImageAttributes(FNativeHandle, NativeClone));\r\n  Result := TGPImageAttributes.Create(NativeClone);\r\nend;\r\n\r\nconstructor TGPImageAttributes.Create(const NativeAttributes: GpImageAttributes);\r\nbegin\r\n  inherited Create;\r\n  FNativeHandle := NativeAttributes;\r\nend;\r\n\r\nconstructor TGPImageAttributes.Create;\r\nbegin\r\n  inherited Create;\r\n  GdipCheck(GdipCreateImageAttributes(FNativeHandle));\r\nend;\r\n\r\ndestructor TGPImageAttributes.Destroy;\r\nbegin\r\n  GdipDisposeImageAttributes(FNativeHandle);\r\n  inherited;\r\nend;\r\n\r\nprocedure TGPImageAttributes.GetAdjustedPalette(const ColorPalette: IGPColorPalette;\r\n  const ColorAdjustType: TGPColorAdjustType);\r\nbegin\r\n  Assert(Assigned(ColorPalette));\r\n  GdipCheck(GdipGetImageAttributesAdjustedPalette(FNativeHandle,\r\n    ColorPalette.NativePalette, ColorAdjustType));\r\nend;\r\n\r\nprocedure TGPImageAttributes.Reset(const AdjustType: TGPColorAdjustType);\r\nbegin\r\n  GdipCheck(GdipResetImageAttributes(FNativeHandle, AdjustType));\r\nend;\r\n\r\nprocedure TGPImageAttributes.SetBrushRemapTable(const Map: array of TGPColorMap);\r\nbegin\r\n  SetRemapTable(Map, ColorAdjustTypeBrush);\r\nend;\r\n\r\nprocedure TGPImageAttributes.SetColorKey(const ColorLow, ColorHigh: TGPColor;\r\n  const AdjustType: TGPColorAdjustType);\r\nbegin\r\n  GdipCheck(GdipSetImageAttributesColorKeys(FNativeHandle, AdjustType, True,\r\n    ColorLow.Value, ColorHigh.Value));\r\nend;\r\n\r\nprocedure TGPImageAttributes.SetColorMatrices(const ColorMatrix,\r\n  GrayMatrix: TGPColorMatrix; const Mode: TGPColorMatrixFlags;\r\n  const AdjustType: TGPColorAdjustType);\r\nbegin\r\n  GdipCheck(GdipSetImageAttributesColorMatrix(FNativeHandle, AdjustType,\r\n    True, @ColorMatrix, @GrayMatrix, Mode));\r\nend;\r\n\r\nprocedure TGPImageAttributes.SetColorMatrix(const ColorMatrix: TGPColorMatrix;\r\n  const Mode: TGPColorMatrixFlags; const AdjustType: TGPColorAdjustType);\r\nbegin\r\n  GdipCheck(GdipSetImageAttributesColorMatrix(FNativeHandle, AdjustType,\r\n    True, @ColorMatrix, nil, Mode));\r\nend;\r\n\r\nprocedure TGPImageAttributes.SetGamma(const Gamma: Single;\r\n  const AdjustType: TGPColorAdjustType);\r\nbegin\r\n  GdipCheck(GdipSetImageAttributesGamma(FNativeHandle, AdjustType,\r\n    True, Gamma));\r\nend;\r\n\r\nprocedure TGPImageAttributes.SetNoOp(const AdjustType: TGPColorAdjustType);\r\nbegin\r\n  GdipCheck(GdipSetImageAttributesNoOp(FNativeHandle, AdjustType, True));\r\nend;\r\n\r\nprocedure TGPImageAttributes.SetOutputChannel(\r\n  const ChannelFlags: TGPColorChannelFlags; const AdjustType: TGPColorAdjustType);\r\nbegin\r\n  GdipCheck(GdipSetImageAttributesOutputChannel(FNativeHandle, AdjustType, True,\r\n    ChannelFlags));\r\nend;\r\n\r\nprocedure TGPImageAttributes.SetOutputChannelColorProfile(\r\n  const ColorProfileFilename: String; const AdjustType: TGPColorAdjustType);\r\nbegin\r\n  GdipCheck(GdipSetImageAttributesOutputChannelColorProfile(FNativeHandle,\r\n    AdjustType, True, PWideChar(ColorProfileFilename)));\r\nend;\r\n\r\nprocedure TGPImageAttributes.SetRemapTable(const Map: array of TGPColorMap;\r\n  const AdjustType: TGPColorAdjustType);\r\nbegin\r\n  Assert(Length(Map) > 0);\r\n  GdipCheck(GdipSetImageAttributesRemapTable(FNativeHandle, AdjustType, True,\r\n    Length(Map), @Map[0]));\r\nend;\r\n\r\nprocedure TGPImageAttributes.SetThreshold(const Threshold: Single;\r\n  const AdjustType: TGPColorAdjustType);\r\nbegin\r\n  GdipCheck(GdipSetImageAttributesThreshold(FNativeHandle, AdjustType,\r\n    True, Threshold));\r\nend;\r\n\r\nprocedure TGPImageAttributes.SetToIdentity(const AdjustType: TGPColorAdjustType);\r\nbegin\r\n  GdipCheck(GdipSetImageAttributesToIdentity(FNativeHandle, AdjustType));\r\nend;\r\n\r\nprocedure TGPImageAttributes.SetWrapMode(const Wrap: TGPWrapMode;\r\n  const Color: TGPColor; const Clamp: Boolean);\r\nbegin\r\n  GdipCheck(GdipSetImageAttributesWrapMode(FNativeHandle, Wrap, Color.Value,\r\n    Clamp));\r\nend;\r\n\r\nprocedure TGPImageAttributes.SetWrapMode(const Wrap: TGPWrapMode);\r\nvar\r\n  Color: TGPColor;\r\nbegin\r\n  Color := TGPColor.Black;\r\n  SetWrapMode(Wrap, Color);\r\nend;\r\n\r\n{$ENDREGION 'GdiplusImageAttributes.h'}\r\n\r\n{$REGION 'GdiplusMatrix.h'}\r\n\r\n{ TGPMatrix }\r\n\r\nfunction TGPMatrix.Clone: IGPMatrix;\r\nvar\r\n  NativeClone: GpMatrix;\r\nbegin\r\n  NativeClone := nil;\r\n  GdipCheck(GdipCloneMatrix(FNativeHandle, NativeClone));\r\n  Result := TGPMatrix.Create(NativeClone);\r\nend;\r\n\r\nconstructor TGPMatrix.Create;\r\nbegin\r\n  inherited Create;\r\n  GdipCheck(GdipCreateMatrix(FNativeHandle));\r\nend;\r\n\r\nconstructor TGPMatrix.Create(const NativeMatrix: GpMatrix);\r\nbegin\r\n  inherited Create;\r\n  FNativeHandle := NativeMatrix;\r\nend;\r\n\r\nconstructor TGPMatrix.Create(const Rect: TGPRect; const DstPlg: TGPPlgPoints);\r\nbegin\r\n  inherited Create;\r\n  GdipCheck(GdipCreateMatrix3I(@Rect, @DstPlg, FNativeHandle));\r\nend;\r\n\r\nconstructor TGPMatrix.Create(const Rect: TGPRectF; const DstPlg: TGPPlgPointsF);\r\nbegin\r\n  inherited Create;\r\n  GdipCheck(GdipCreateMatrix3(@Rect, @DstPlg, FNativeHandle));\r\nend;\r\n\r\nconstructor TGPMatrix.Create(const M11, M12, M21, M22, DX, DY: Single);\r\nbegin\r\n  inherited Create;\r\n  GdipCheck(GdipCreateMatrix2(M11, M12, M21, M22, DX, DY, FNativeHandle));\r\nend;\r\n\r\ndestructor TGPMatrix.Destroy;\r\nbegin\r\n  GdipDeleteMatrix(FNativeHandle);\r\n  inherited;\r\nend;\r\n\r\nfunction TGPMatrix.Equals(const Matrix: IGPMatrix): Boolean;\r\nvar\r\n  B: Bool;\r\nbegin\r\n  B := False;\r\n  GdipCheck(GdipIsMatrixEqual(FNativeHandle, Matrix.NativeHandle, B));\r\n  Result := B;\r\nend;\r\n\r\nfunction TGPMatrix.GetElements: TGPMatrixElements;\r\nbegin\r\n  GdipCheck(GdipGetMatrixElements(FNativeHandle, @Result.M[0]));\r\nend;\r\n\r\nfunction TGPMatrix.GetIsIdentity: Boolean;\r\nvar\r\n  B: Bool;\r\nbegin\r\n  B := False;\r\n  GdipCheck(GdipIsMatrixIdentity(FNativeHandle, B));\r\n  Result := B;\r\nend;\r\n\r\nfunction TGPMatrix.GetIsInvertible: Boolean;\r\nvar\r\n  B: Bool;\r\nbegin\r\n  B := False;\r\n  GdipCheck(GdipIsMatrixInvertible(FNativeHandle, B));\r\n  Result := B;\r\nend;\r\n\r\nfunction TGPMatrix.GetOffsetX: Single;\r\nvar\r\n  Elements: TGPMatrixElements;\r\nbegin\r\n  Elements := GetElements;\r\n  Result := Elements.DX;\r\nend;\r\n\r\nfunction TGPMatrix.GetOffsetY: Single;\r\nvar\r\n  Elements: TGPMatrixElements;\r\nbegin\r\n  Elements := GetElements;\r\n  Result := Elements.DY;\r\nend;\r\n\r\nprocedure TGPMatrix.Invert;\r\nbegin\r\n  GdipCheck(GdipInvertMatrix(FNativeHandle));\r\nend;\r\n\r\nprocedure TGPMatrix.Multiply(const Matrix: IGPMatrix; const Order: TGPMatrixOrder);\r\nbegin\r\n  GdipCheck(GdipMultiplyMatrix(FNativeHandle, Matrix.NativeHandle, Order));\r\nend;\r\n\r\nprocedure TGPMatrix.Reset;\r\nbegin\r\n  GdipCheck(GdipSetMatrixElements(FNativeHandle, 1, 0, 0, 1, 0, 0));\r\nend;\r\n\r\nprocedure TGPMatrix.Rotate(const Angle: Single; const Order: TGPMatrixOrder);\r\nbegin\r\n  GdipCheck(GdipRotateMatrix(FNativeHandle, Angle, Order));\r\nend;\r\n\r\nprocedure TGPMatrix.RotateAt(const Angle: Single; const Center: TGPPointF;\r\n  const Order: TGPMatrixOrder);\r\nbegin\r\n  if (Order = MatrixOrderPrepend) then\r\n  begin\r\n    GdipCheck(GdipTranslateMatrix(FNativeHandle, Center.X, Center.Y, Order));\r\n    GdipCheck(GdipRotateMatrix(FNativeHandle, Angle, Order));\r\n    GdipCheck(GdipTranslateMatrix(FNativeHandle, -Center.X, -Center.Y, Order));\r\n  end\r\n  else\r\n  begin\r\n    GdipCheck(GdipTranslateMatrix(FNativeHandle, -Center.X, -Center.Y, Order));\r\n    GdipCheck(GdipRotateMatrix(FNativeHandle, Angle, Order));\r\n    GdipCheck(GdipTranslateMatrix(FNativeHandle, Center.X, Center.Y, Order));\r\n  end;\r\nend;\r\n\r\nprocedure TGPMatrix.Scale(const ScaleX, ScaleY: Single;\r\n  const Order: TGPMatrixOrder);\r\nbegin\r\n  GdipCheck(GdipScaleMatrix(FNativeHandle, ScaleX, ScaleY, Order));\r\nend;\r\n\r\nprocedure TGPMatrix.SetElements(const M11, M12, M21, M22, DX, DY: Single);\r\nbegin\r\n  GdipCheck(GdipSetMatrixElements(FNativeHandle, M11, M12, M21, M22, DX, DY));\r\nend;\r\n\r\nprocedure TGPMatrix.SetElements(const Value: TGPMatrixElements);\r\nbegin\r\n  GdipCheck(GdipSetMatrixElements(FNativeHandle, Value.M11, Value.M12,\r\n    Value.M21, Value.M22, Value.DX, Value.DY));\r\nend;\r\n\r\nprocedure TGPMatrix.Shear(const ShearX, ShearY: Single;\r\n  const Order: TGPMatrixOrder);\r\nbegin\r\n  GdipCheck(GdipShearMatrix(FNativeHandle, ShearX, ShearY, Order));\r\nend;\r\n\r\nprocedure TGPMatrix.TransformPoint(var Point: TGPPointF);\r\nbegin\r\n  GdipCheck(GdipTransformMatrixPoints(FNativeHandle, @Point, 1));\r\nend;\r\n\r\nprocedure TGPMatrix.TransformPoint(var Point: TGPPoint);\r\nbegin\r\n  GdipCheck(GdipTransformMatrixPointsI(FNativeHandle, @Point, 1));\r\nend;\r\n\r\nprocedure TGPMatrix.TransformPoints(const Points: array of TGPPointF);\r\nbegin\r\n  Assert(Length(Points) > 0);\r\n  GdipCheck(GdipTransformMatrixPoints(FNativeHandle, @Points[0], Length(Points)));\r\nend;\r\n\r\nprocedure TGPMatrix.TransformPoints(const Points: array of TGPPoint);\r\nbegin\r\n  Assert(Length(Points) > 0);\r\n  GdipCheck(GdipTransformMatrixPointsI(FNativeHandle, @Points[0], Length(Points)));\r\nend;\r\n\r\nprocedure TGPMatrix.TransformVector(var Point: TGPPoint);\r\nbegin\r\n  GdipCheck(GdipVectorTransformMatrixPointsI(FNativeHandle, @Point, 1));\r\nend;\r\n\r\nprocedure TGPMatrix.TransformVector(var Point: TGPPointF);\r\nbegin\r\n  GdipCheck(GdipVectorTransformMatrixPoints(FNativeHandle, @Point, 1));\r\nend;\r\n\r\nprocedure TGPMatrix.TransformVectors(const Points: array of TGPPoint);\r\nbegin\r\n  Assert(Length(Points) > 0);\r\n  GdipCheck(GdipVectorTransformMatrixPointsI(FNativeHandle, @Points[0], Length(Points)));\r\nend;\r\n\r\nprocedure TGPMatrix.TransformVectors(const Points: array of TGPPointF);\r\nbegin\r\n  Assert(Length(Points) > 0);\r\n  GdipCheck(GdipVectorTransformMatrixPoints(FNativeHandle, @Points[0], Length(Points)));\r\nend;\r\n\r\nprocedure TGPMatrix.Translate(const OffsetX, OffsetY: Single;\r\n  const Order: TGPMatrixOrder);\r\nbegin\r\n  GdipCheck(GdipTranslateMatrix(FNativeHandle, OffsetX, OffsetY, Order));\r\nend;\r\n{$ENDREGION 'GdiplusMatrix.h'}\r\n\r\n{$REGION 'GdiplusBrush.h'}\r\n\r\n{ TGPBrush }\r\n\r\nfunction TGPBrush.Clone: IGPBrush;\r\nvar\r\n  NativeClone: GpBrush;\r\nbegin\r\n  GdipCheck(GdipCloneBrush(FNativeHandle, NativeClone));\r\n  Result := TGPBrush.Create(NativeClone);\r\nend;\r\n\r\nconstructor TGPBrush.Create(const NativeBrush: GpBrush);\r\nbegin\r\n  inherited Create;\r\n  FNativeHandle := NativeBrush;\r\nend;\r\n\r\nconstructor TGPBrush.Create;\r\nbegin\r\n  inherited Create;\r\nend;\r\n\r\ndestructor TGPBrush.Destroy;\r\nbegin\r\n  GdipDeleteBrush(FNativeHandle);\r\n  inherited;\r\nend;\r\n\r\nfunction TGPBrush.GetType: TGPBrushType;\r\nbegin\r\n  Result := TGPBrushType(-1);\r\n  GdipCheck(GdipGetBrushType(FNativeHandle, Result));\r\nend;\r\n\r\n{ TGPSolidBrush }\r\n\r\nconstructor TGPSolidBrush.Create(const Color: TGPColor);\r\nbegin\r\n  inherited Create;\r\n  GdipCheck(GdipCreateSolidFill(Color.Value, FNativeHandle));\r\nend;\r\n\r\nconstructor TGPSolidBrush.Create;\r\nbegin\r\n  inherited Create;\r\nend;\r\n\r\nfunction TGPSolidBrush.GetColor: TGPColor;\r\nbegin\r\n  GdipCheck(GdipGetSolidFillColor(FNativeHandle, Result.FArgb));\r\nend;\r\n\r\nprocedure TGPSolidBrush.SetColor(const Value: TGPColor);\r\nbegin\r\n  GdipCheck(GdipSetSolidFillColor(FNativeHandle, Value.FArgb));\r\nend;\r\n\r\n{ TGPTextureBrush }\r\n\r\nconstructor TGPTextureBrush.Create(const Image: IGPImage; const WrapMode: TGPWrapMode;\r\n  const DstRect: TGPRect);\r\nbegin\r\n  inherited Create;\r\n  GdipCheck(GdipCreateTexture2I(Image.NativeHandle, WrapMode, DstRect.X,\r\n    DstRect.Y, DstRect.Width, DstRect.Height, FNativeHandle));\r\nend;\r\n\r\nconstructor TGPTextureBrush.Create(const Image: IGPImage; const WrapMode: TGPWrapMode;\r\n  const DstRect: TGPRectF);\r\nbegin\r\n  inherited Create;\r\n  GdipCheck(GdipCreateTexture2(Image.NativeHandle, WrapMode, DstRect.X,\r\n    DstRect.Y, DstRect.Width, DstRect.Height, FNativeHandle));\r\nend;\r\n\r\nconstructor TGPTextureBrush.Create(const Image: IGPImage;\r\n  const WrapMode: TGPWrapMode);\r\nbegin\r\n  inherited Create;\r\n  GdipCheck(GdipCreateTexture(Image.NativeHandle, WrapMode, FNativeHandle));\r\nend;\r\n\r\nconstructor TGPTextureBrush.Create(const Image: IGPImage; const DstRect: TGPRectF;\r\n  const ImageAttributes: IGPImageAttributes);\r\nbegin\r\n  inherited Create;\r\n  GdipCheck(GdipCreateTextureIA(Image.NativeHandle, GdipHandle(ImageAttributes),\r\n    DstRect.X, DstRect.Y, DstRect.Width, DstRect.Height, FNativeHandle));\r\nend;\r\n\r\nconstructor TGPTextureBrush.Create(const Image: IGPImage; const WrapMode: TGPWrapMode;\r\n  const DstX, DstY, DstWidth, DstHeight: Integer);\r\nbegin\r\n  inherited Create;\r\n  GdipCheck(GdipCreateTexture2I(Image.NativeHandle, WrapMode, DstX, DstY,\r\n    DstWidth, DstHeight, FNativeHandle));\r\nend;\r\n\r\nconstructor TGPTextureBrush.Create;\r\nbegin\r\n  inherited Create;\r\nend;\r\n\r\nconstructor TGPTextureBrush.Create(const Image: IGPImage; const WrapMode: TGPWrapMode;\r\n  const DstX, DstY, DstWidth, DstHeight: Single);\r\nbegin\r\n  inherited Create;\r\n  GdipCheck(GdipCreateTexture2(Image.NativeHandle, WrapMode, DstX, DstY,\r\n    DstWidth, DstHeight, FNativeHandle));\r\nend;\r\n\r\nconstructor TGPTextureBrush.Create(const Image: IGPImage; const DstRect: TGPRect;\r\n  const ImageAttributes: IGPImageAttributes);\r\nbegin\r\n  inherited Create;\r\n  GdipCheck(GdipCreateTextureIAI(Image.NativeHandle, GdipHandle(ImageAttributes),\r\n    DstRect.X, DstRect.Y, DstRect.Width, DstRect.Height, FNativeHandle));\r\nend;\r\n\r\nfunction TGPTextureBrush.GetImage: IGPImage;\r\nvar\r\n  NativeImage: GpImage;\r\nbegin\r\n  GdipCheck(GdipGetTextureImage(FNativeHandle, NativeImage));\r\n  Result := TGPImage.Create(NativeImage);\r\nend;\r\n\r\nfunction TGPTextureBrush.GetTransform: IGPMatrix;\r\nbegin\r\n  Result := TGPMatrix.Create;\r\n  GdipCheck(GdipGetTextureTransform(FNativeHandle, Result.NativeHandle));\r\nend;\r\n\r\nfunction TGPTextureBrush.GetWrapMode: TGPWrapMode;\r\nbegin\r\n  GdipCheck(GdipGetTextureWrapMode(FNativeHandle, Result));\r\nend;\r\n\r\nprocedure TGPTextureBrush.MultiplyTransform(const Matrix: IGPMatrix;\r\n  const Order: TGPMatrixOrder);\r\nbegin\r\n  GdipCheck(GdipMultiplyTextureTransform(FNativeHandle, Matrix.NativeHandle,\r\n    Order));\r\nend;\r\n\r\nprocedure TGPTextureBrush.ResetTransform;\r\nbegin\r\n  GdipCheck(GdipResetTextureTransform(FNativeHandle));\r\nend;\r\n\r\nprocedure TGPTextureBrush.RotateTransform(const Angle: Single;\r\n  const Order: TGPMatrixOrder);\r\nbegin\r\n  GdipCheck(GdipRotateTextureTransform(FNativeHandle, Angle, Order));\r\nend;\r\n\r\nprocedure TGPTextureBrush.ScaleTransform(const SX, SY: Single;\r\n  const Order: TGPMatrixOrder);\r\nbegin\r\n  GdipCheck(GdipScaleTextureTransform(FNativeHandle, SX, SY, Order));\r\nend;\r\n\r\nprocedure TGPTextureBrush.SetTransform(const Value: IGPMatrix);\r\nbegin\r\n  GdipCheck(GdipSetTextureTransform(FNativeHandle, Value.NativeHandle));\r\nend;\r\n\r\nprocedure TGPTextureBrush.SetWrapMode(const Value: TGPWrapMode);\r\nbegin\r\n  GdipCheck(GdipSetTextureWrapMode(FNativeHandle, Value));\r\nend;\r\n\r\nprocedure TGPTextureBrush.TranslateTransform(const DX, DY: Single;\r\n  const Order: TGPMatrixOrder);\r\nbegin\r\n  GdipCheck(GdipTranslateTextureTransform(FNativeHandle, DX, DY, Order));\r\nend;\r\n\r\n{ TGPBlend }\r\n\r\nconstructor TGPBlend.Create(const ACount: Integer);\r\nbegin\r\n  inherited Create;\r\n  SetLength(FFactors, ACount);\r\n  SetLength(FPositions, ACount);\r\nend;\r\n\r\nconstructor TGPBlend.Create(const AFactors, APositions: array of Single);\r\nbegin\r\n  Assert(Length(AFactors) > 0);\r\n  Assert(Length(APositions) = Length(AFactors));\r\n  Create(Length(AFactors));\r\n  Move(AFactors[0], FFactors[0], Length(AFactors) * SizeOf(Single));\r\n  Move(APositions[0], FPositions[0], Length(APositions) * SizeOf(Single));\r\nend;\r\n\r\nfunction TGPBlend.GetCount: Integer;\r\nbegin\r\n  Result := Length(FFactors);\r\nend;\r\n\r\nfunction TGPBlend.GetFactor(const Index: Integer): Single;\r\nbegin\r\n  Result := FFactors[Index];\r\nend;\r\n\r\nfunction TGPBlend.GetFactorPtr: PSingle;\r\nbegin\r\n  Result := @FFactors[0];\r\nend;\r\n\r\nfunction TGPBlend.GetPosition(const Index: Integer): Single;\r\nbegin\r\n  Result := FPositions[Index];\r\nend;\r\n\r\nfunction TGPBlend.GetPositionPtr: PSingle;\r\nbegin\r\n  Result := @FPositions[0];\r\nend;\r\n\r\nprocedure TGPBlend.SetFactor(const Index: Integer; const Value: Single);\r\nbegin\r\n  FFactors[Index] := Value;\r\nend;\r\n\r\nprocedure TGPBlend.SetPosition(const Index: Integer; const Value: Single);\r\nbegin\r\n  FPositions[Index] := Value;\r\nend;\r\n\r\n{ TGPColorBlend }\r\n\r\nconstructor TGPColorBlend.Create(const ACount: Integer);\r\nbegin\r\n  inherited Create;\r\n  SetLength(FColors, ACount);\r\n  SetLength(FPositions, ACount);\r\nend;\r\n\r\nconstructor TGPColorBlend.Create(const AColors: array of TGPColor;\r\n  const APositions: array of Single);\r\nbegin\r\n  Assert(Length(AColors) > 0);\r\n  Assert(Length(AColors) = Length(APositions));\r\n  Create(Length(AColors));\r\n  Move(AColors[0], FColors[0], Length(AColors) * SizeOf(TGPColor));\r\n  Move(APositions[0], FPositions[0], Length(APositions) * SizeOf(Single));\r\nend;\r\n\r\nfunction TGPColorBlend.GetColor(const Index: Integer): TGPColor;\r\nbegin\r\n  Result := FColors[Index];\r\nend;\r\n\r\nfunction TGPColorBlend.GetColorPtr: PGPColor;\r\nbegin\r\n  Result := @FColors[0];\r\nend;\r\n\r\nfunction TGPColorBlend.GetCount: Integer;\r\nbegin\r\n  Result := Length(FColors);\r\nend;\r\n\r\nfunction TGPColorBlend.GetPosition(const Index: Integer): Single;\r\nbegin\r\n  Result := FPositions[Index];\r\nend;\r\n\r\nfunction TGPColorBlend.GetPositionPtr: PSingle;\r\nbegin\r\n  Result := @FPositions[0];\r\nend;\r\n\r\nprocedure TGPColorBlend.SetColor(const Index: Integer; const Value: TGPColor);\r\nbegin\r\n  FColors[Index] := Value;\r\nend;\r\n\r\nprocedure TGPColorBlend.SetPosition(const Index: Integer; const Value: Single);\r\nbegin\r\n  FPositions[Index] := Value;\r\nend;\r\n\r\n{ TGPLinearGradientBrush }\r\n\r\nconstructor TGPLinearGradientBrush.Create(const Rect: TGPRectF; const Color1,\r\n  Color2: TGPColor; const Mode: TGPLinearGradientMode);\r\nbegin\r\n  inherited Create;\r\n  GdipCheck(GdipCreateLineBrushFromRect(@Rect, Color1.Value, Color2.Value,\r\n    Mode, WrapModeTile, FNativeHandle));\r\nend;\r\n\r\nconstructor TGPLinearGradientBrush.Create(const Rect: TGPRect; const Color1,\r\n  Color2: TGPColor; const Mode: TGPLinearGradientMode);\r\nbegin\r\n  inherited Create;\r\n  GdipCheck(GdipCreateLineBrushFromRectI(@Rect, Color1.Value, Color2.Value,\r\n    Mode, WrapModeTile, FNativeHandle));\r\nend;\r\n\r\nconstructor TGPLinearGradientBrush.Create(const Point1, Point2: TGPPointF;\r\n  const Color1, Color2: TGPColor);\r\nbegin\r\n  inherited Create;\r\n  GdipCheck(GdipCreateLineBrush(@Point1, @Point2, Color1.Value, Color2.Value,\r\n    WrapModeTile, FNativeHandle));\r\nend;\r\n\r\nconstructor TGPLinearGradientBrush.Create(const Point1, Point2: TGPPoint;\r\n  const Color1, Color2: TGPColor);\r\nbegin\r\n  inherited Create;\r\n  GdipCheck(GdipCreateLineBrushI(@Point1, @Point2, Color1.Value, Color2.Value,\r\n    WrapModeTile, FNativeHandle));\r\nend;\r\n\r\nconstructor TGPLinearGradientBrush.Create(const Rect: TGPRectF; const Color1,\r\n  Color2: TGPColor; const Angle: Single; const IsAngleScalable: Boolean);\r\nbegin\r\n  inherited Create;\r\n  GdipCheck(GdipCreateLineBrushFromRectWithAngle(@Rect, Color1.Value, Color2.Value,\r\n    Angle, IsAngleScalable, WrapModeTile, FNativeHandle));\r\nend;\r\n\r\nconstructor TGPLinearGradientBrush.Create(const Rect: TGPRect; const Color1,\r\n  Color2: TGPColor; const Angle: Single; const IsAngleScalable: Boolean);\r\nbegin\r\n  inherited Create;\r\n  GdipCheck(GdipCreateLineBrushFromRectWithAngleI(@Rect, Color1.Value, Color2.Value,\r\n    Angle, IsAngleScalable, WrapModeTile, FNativeHandle));\r\nend;\r\n\r\nconstructor TGPLinearGradientBrush.Create;\r\nbegin\r\n  inherited Create;\r\nend;\r\n\r\nfunction TGPLinearGradientBrush.GetBlend: IGPBlend;\r\nvar\r\n  Count: Integer;\r\nbegin\r\n  Count := 0;\r\n  GdipCheck(GdipGetLineBlendCount(FNativeHandle, Count));\r\n  Result := TGPBlend.Create(Count);\r\n  if (Count > 0) then\r\n    GdipCheck(GdipGetLineBlend(FNativeHandle, Result.FactorPtr,\r\n      Result.PositionPtr, Count));\r\nend;\r\n\r\nfunction TGPLinearGradientBrush.GetGammaCorrection: Boolean;\r\nvar\r\n  B: Bool;\r\nbegin\r\n  GdipCheck(GdipGetLineGammaCorrection(FNativeHandle, B));\r\n  Result := B;\r\nend;\r\n\r\nfunction TGPLinearGradientBrush.GetInterpolationColors: IGPColorBlend;\r\nvar\r\n  Count: Integer;\r\nbegin\r\n  Count := 0;\r\n  GdipCheck(GdipGetLinePresetBlendCount(FNativeHandle, Count));\r\n  Result := TGPColorBlend.Create(Count);\r\n  if (Count > 0) then\r\n    GdipCheck(GdipGetLinePresetBlend(FNativeHandle, PARGB(Result.ColorPtr),\r\n      Result.PositionPtr, Count));\r\nend;\r\n\r\nfunction TGPLinearGradientBrush.GetLinearColors: TGPLinearColors;\r\nbegin\r\n  GdipCheck(GdipGetLineColors(FNativeHandle, @Result[0]));\r\nend;\r\n\r\nprocedure TGPLinearGradientBrush.GetRectangle(out Rect: TGPRectF);\r\nbegin\r\n  GdipCheck(GdipGetLineRect(FNativeHandle, Rect));\r\nend;\r\n\r\nfunction TGPLinearGradientBrush.GetRectangle: TGPRectF;\r\nbegin\r\n  GdipCheck(GdipGetLineRect(FNativeHandle, Result));\r\nend;\r\n\r\nprocedure TGPLinearGradientBrush.GetRectangle(out Rect: TGPRect);\r\nbegin\r\n  GdipCheck(GdipGetLineRectI(FNativeHandle, Rect));\r\nend;\r\n\r\nfunction TGPLinearGradientBrush.GetTransform: IGPMatrix;\r\nbegin\r\n  Result := TGPMatrix.Create;\r\n  GdipCheck(GdipGetLineTransform(FNativeHandle, Result.NativeHandle));\r\nend;\r\n\r\nfunction TGPLinearGradientBrush.GetWrapMode: TGPWrapMode;\r\nbegin\r\n  GdipCheck(GdipGetLineWrapMode(FNativeHandle, Result));\r\nend;\r\n\r\nprocedure TGPLinearGradientBrush.MultiplyTransform(const Matrix: IGPMatrix;\r\n  const Order: TGPMatrixOrder);\r\nbegin\r\n  GdipCheck(GdipMultiplyLineTransform(FNativeHandle, Matrix.NativeHandle, Order));\r\nend;\r\n\r\nprocedure TGPLinearGradientBrush.ResetTransform;\r\nbegin\r\n  GdipCheck(GdipResetLineTransform(FNativeHandle));\r\nend;\r\n\r\nprocedure TGPLinearGradientBrush.RotateTransform(const Angle: Single;\r\n  const Order: TGPMatrixOrder);\r\nbegin\r\n  GdipCheck(GdipRotateLineTransform(FNativeHandle, Angle, Order));\r\nend;\r\n\r\nprocedure TGPLinearGradientBrush.ScaleTransform(const SX, SY: Single;\r\n  const Order: TGPMatrixOrder);\r\nbegin\r\n  GdipCheck(GdipScaleLineTransform(FNativeHandle, SX, SY, Order));\r\nend;\r\n\r\nprocedure TGPLinearGradientBrush.SetBlend(const Value: IGPBlend);\r\nbegin\r\n  Assert(Assigned(Value));\r\n  GdipCheck(GdipSetLineBlend(FNativeHandle, Value.FactorPtr,\r\n    Value.PositionPtr, Value.Count));\r\nend;\r\n\r\nprocedure TGPLinearGradientBrush.SetBlendBellShape(const Focus, Scale: Single);\r\nbegin\r\n  GdipCheck(GdipSetLineSigmaBlend(FNativeHandle, Focus, Scale));\r\nend;\r\n\r\nprocedure TGPLinearGradientBrush.SetBlendTriangularShape(const Focus,\r\n  Scale: Single);\r\nbegin\r\n  GdipCheck(GdipSetLineLinearBlend(FNativeHandle, Focus, Scale));\r\nend;\r\n\r\nprocedure TGPLinearGradientBrush.SetGammaCorrection(const Value: Boolean);\r\nbegin\r\n  GdipCheck(GdipSetLineGammaCorrection(FNativeHandle, Value));\r\nend;\r\n\r\nprocedure TGPLinearGradientBrush.SetInterpolationColors(const Value: IGPColorBlend);\r\nbegin\r\n  Assert(Assigned(Value));\r\n  GdipCheck(GdipSetLinePresetBlend(FNativeHandle, PARGB(Value.ColorPtr),\r\n    Value.PositionPtr, Value.Count));\r\nend;\r\n\r\nprocedure TGPLinearGradientBrush.SetLinearColors(const Value: TGPLinearColors);\r\nbegin\r\n  GdipCheck(GdipSetLineColors(FNativeHandle, Value[0].Value, Value[1].Value));\r\nend;\r\n\r\nprocedure TGPLinearGradientBrush.SetTransform(const Value: IGPMatrix);\r\nbegin\r\n  GdipCheck(GdipSetLineTransform(FNativeHandle, Value.NativeHandle));\r\nend;\r\n\r\nprocedure TGPLinearGradientBrush.SetWrapMode(const Value: TGPWrapMode);\r\nbegin\r\n  GdipCheck(GdipSetLineWrapMode(FNativeHandle, Value));\r\nend;\r\n\r\nprocedure TGPLinearGradientBrush.TranslateTransform(const DX, DY: Single;\r\n  const Order: TGPMatrixOrder);\r\nbegin\r\n  GdipCheck(GdipTranslateLineTransform(FNativeHandle, DX, DY, Order));\r\nend;\r\n\r\n{ TGPHatchBrush }\r\n\r\nconstructor TGPHatchBrush.Create(const HatchStyle: TGPHatchStyle; const ForeColor,\r\n  BackColor: TGPColor);\r\nbegin\r\n  inherited Create;\r\n  GdipCheck(GdipCreateHatchBrush(HatchStyle, ForeColor.Value, BackColor.Value,\r\n    FNativeHandle));\r\nend;\r\n\r\nconstructor TGPHatchBrush.Create(const HatchStyle: TGPHatchStyle;\r\n  const ForeColor: TGPColor);\r\nbegin\r\n  inherited Create;\r\n  GdipCheck(GdipCreateHatchBrush(HatchStyle, ForeColor.Value, TGPColor.Black,\r\n    FNativeHandle));\r\nend;\r\n\r\nconstructor TGPHatchBrush.Create;\r\nbegin\r\n  inherited Create;\r\nend;\r\n\r\nfunction TGPHatchBrush.GetBackgroundColor: TGPColor;\r\nbegin\r\n  GdipCheck(GdipGetHatchBackgroundColor(FNativeHandle, Result.FArgb));\r\nend;\r\n\r\nfunction TGPHatchBrush.GetForegroundColor: TGPColor;\r\nbegin\r\n  GdipCheck(GdipGetHatchForegroundColor(FNativeHandle, Result.FArgb));\r\nend;\r\n\r\nfunction TGPHatchBrush.GetHatchStyle: TGPHatchStyle;\r\nbegin\r\n  GdipCheck(GdipGetHatchStyle(FNativeHandle, Result));\r\nend;\r\n{$ENDREGION 'GdiplusBrush.h'}\r\n\r\n{$REGION 'GdiplusPen.h'}\r\n\r\n{ TGPPen }\r\n\r\nfunction TGPPen.Clone: IGPPen;\r\nvar\r\n  NativeClone: GpPen;\r\nbegin\r\n  GdipCheck(GdipClonePen(FNativeHandle, NativeClone));\r\n  Result := TGPPen.Create(FNativeHandle);\r\nend;\r\n\r\nconstructor TGPPen.Create(const Brush: IGPBrush; const Width: Single);\r\nbegin\r\n  inherited Create;\r\n  GdipCheck(GdipCreatePen2(Brush.NativeHandle, Width, UnitWorld, FNativeHandle));\r\nend;\r\n\r\nconstructor TGPPen.Create(const Color: TGPColor; const Width: Single);\r\nbegin\r\n  inherited Create;\r\n  GdipCheck(GdipCreatePen1(Color.Value, Width, UnitWorld, FNativeHandle));\r\nend;\r\n\r\nconstructor TGPPen.Create(const NativePen: GpPen);\r\nbegin\r\n  inherited Create;\r\n  FNativeHandle := NativePen;\r\nend;\r\n\r\ndestructor TGPPen.Destroy;\r\nbegin\r\n  GdipDeletePen(FNativeHandle);\r\n  inherited;\r\nend;\r\n\r\nfunction TGPPen.GetAlignment: TGPPenAlignment;\r\nbegin\r\n  GdipCheck(GdipGetPenMode(FNativeHandle, Result));\r\nend;\r\n\r\nfunction TGPPen.GetBrush: IGPBrush;\r\nvar\r\n  PenType: TGPPenType;\r\n  NativeBrush: GpBrush;\r\nbegin\r\n  Result := nil;\r\n  GdipCheck(GdipGetPenFillType(FNativeHandle, PenType));\r\n  case PenType of\r\n    PenTypeSolidColor:\r\n      Result := TGPSolidBrush.Create;\r\n\r\n    PenTypeHatchFill:\r\n      Result := TGPHatchBrush.Create;\r\n\r\n    PenTypeTextureFill:\r\n      Result := TGPTextureBrush.Create;\r\n\r\n    PenTypePathGradient:\r\n      Result := TGPBrush.Create;\r\n\r\n    PenTypeLinearGradient:\r\n      Result := TGPLinearGradientBrush.Create;\r\n  end;\r\n\r\n  if Assigned(Result) then\r\n  begin\r\n    NativeBrush := nil;\r\n    GdipCheck(GdipGetPenBrushFill(FNativeHandle, NativeBrush));\r\n    Result.NativeHandle := NativeBrush;\r\n  end;\r\nend;\r\n\r\nfunction TGPPen.GetColor: TGPColor;\r\nvar\r\n  PenType: TGPPenType;\r\nbegin\r\n  GdipCheck(GdipGetPenFillType(FNativeHandle, PenType));\r\n  if (PenType <> PenTypeSolidColor) then\r\n    GdipCheck(WrongState);\r\n  GdipCheck(GdipGetPenColor(FNativeHandle, Result.FArgb));\r\nend;\r\n\r\nfunction TGPPen.GetCompoundArray: IGPCompoundArray;\r\nvar\r\n  Count: Integer;\r\nbegin\r\n  Count := 0;\r\n  GdipCheck(GdipGetPenCompoundCount(FNativeHandle, Count));\r\n  Result := TGPArray.Create(Count);\r\n  if (Count > 0) then\r\n    GdipCheck(GdipGetPenCompoundArray(FNativeHandle, Result.ItemPtr, Count));\r\nend;\r\n\r\nfunction TGPPen.GetCustomEndCap: IGPCustomLineCap;\r\nvar\r\n  NativeCap: GpCustomLineCap;\r\nbegin\r\n  NativeCap := nil;\r\n  GdipCheck(GdipGetPenCustomEndCap(FNativeHandle, NativeCap));\r\n  Result := TGPCustomLineCap.Create(NativeCap);\r\nend;\r\n\r\nfunction TGPPen.GetCustomStartCap: IGPCustomLineCap;\r\nvar\r\n  NativeCap: GpCustomLineCap;\r\nbegin\r\n  NativeCap := nil;\r\n  GdipCheck(GdipGetPenCustomStartCap(FNativeHandle, NativeCap));\r\n  Result := TGPCustomLineCap.Create(NativeCap);\r\nend;\r\n\r\nfunction TGPPen.GetDashCap: TGPDashCap;\r\nbegin\r\n  GdipCheck(GdipGetPenDashCap197819(FNativeHandle, Result));\r\nend;\r\n\r\nfunction TGPPen.GetDashOffset: Single;\r\nbegin\r\n  GdipCheck(GdipGetPenDashOffset(FNativeHandle, Result));\r\nend;\r\n\r\nfunction TGPPen.GetDashPattern: IGPDashPattern;\r\nvar\r\n  Count: Integer;\r\nbegin\r\n  Count := 0;\r\n  GdipCheck(GdipGetPenDashCount(FNativeHandle, Count));\r\n  Result := TGPArray.Create(Count);\r\n  if (Count > 0) then\r\n    GdipCheck(GdipGetPenDashArray(FNativeHandle, Result.ItemPtr, Count));\r\nend;\r\n\r\nfunction TGPPen.GetDashStyle: TGPDashStyle;\r\nbegin\r\n  GdipCheck(GdipGetPenDashStyle(FNativeHandle, Result));\r\nend;\r\n\r\nfunction TGPPen.GetEndCap: TGPLineCap;\r\nbegin\r\n  GdipCheck(GdipGetPenEndCap(FNativeHandle, Result));\r\nend;\r\n\r\nfunction TGPPen.GetLineJoin: TGPLineJoin;\r\nbegin\r\n  GdipCheck(GdipGetPenLineJoin(FNativeHandle, Result));\r\nend;\r\n\r\nfunction TGPPen.GetMiterLimit: Single;\r\nbegin\r\n  GdipCheck(GdipGetPenMiterLimit(FNativeHandle, Result));\r\nend;\r\n\r\nfunction TGPPen.GetPenType: TGPPenType;\r\nbegin\r\n  GdipCheck(GdipGetPenFillType(FNativeHandle, Result));\r\nend;\r\n\r\nfunction TGPPen.GetStartCap: TGPLineCap;\r\nbegin\r\n  GdipCheck(GdipGetPenStartCap(FNativeHandle, Result));\r\nend;\r\n\r\nfunction TGPPen.GetTransform: IGPMatrix;\r\nbegin\r\n  Result := TGPMatrix.Create;\r\n  GdipCheck(GdipGetPenTransform(FNativeHandle, Result.NativeHandle));\r\nend;\r\n\r\nfunction TGPPen.GetWidth: Single;\r\nbegin\r\n  GdipCheck(GdipGetPenWidth(FNativeHandle, Result));\r\nend;\r\n\r\nprocedure TGPPen.MultiplyTransform(const Matrix: IGPMatrix;\r\n  const Order: TGPMatrixOrder);\r\nbegin\r\n  GdipCheck(GdipMultiplyPenTransform(FNativeHandle, Matrix.NativeHandle, Order));\r\nend;\r\n\r\nprocedure TGPPen.ResetTransform;\r\nbegin\r\n  GdipCheck(GdipResetPenTransform(FNativeHandle));\r\nend;\r\n\r\nprocedure TGPPen.RotateTransform(const Angle: Single; const Order: TGPMatrixOrder);\r\nbegin\r\n  GdipCheck(GdipRotatePenTransform(FNativeHandle, Angle, Order));\r\nend;\r\n\r\nprocedure TGPPen.ScaleTransform(const SX, SY: Single; const Order: TGPMatrixOrder);\r\nbegin\r\n  GdipCheck(GdipScalePenTransform(FNativeHandle, SX, SY, Order));\r\nend;\r\n\r\nprocedure TGPPen.SetAlignment(const Value: TGPPenAlignment);\r\nbegin\r\n  GdipCheck(GdipSetPenMode(FNativeHandle, Value));\r\nend;\r\n\r\nprocedure TGPPen.SetBrush(const Value: IGPBrush);\r\nbegin\r\n  GdipCheck(GdipSetPenBrushFill(FNativeHandle, Value.NativeHandle));\r\nend;\r\n\r\nprocedure TGPPen.SetColor(const Value: TGPColor);\r\nbegin\r\n  GdipCheck(GdipSetPenColor(FNativeHandle, Value.FArgb));\r\nend;\r\n\r\nprocedure TGPPen.SetCompoundArray(const Value: IGPCompoundArray);\r\nbegin\r\n  Assert(Assigned(Value));\r\n  GdipCheck(GdipSetPenCompoundArray(FNativeHandle, Value.ItemPtr, Value.Count));\r\nend;\r\n\r\nprocedure TGPPen.SetCustomEndCap(const Value: IGPCustomLineCap);\r\nbegin\r\n  GdipCheck(GdipSetPenCustomEndCap(FNativeHandle, GdipHandle(Value)));\r\nend;\r\n\r\nprocedure TGPPen.SetCustomStartCap(const Value: IGPCustomLineCap);\r\nbegin\r\n  GdipCheck(GdipSetPenCustomStartCap(FNativeHandle, GdipHandle(Value)));\r\nend;\r\n\r\nprocedure TGPPen.SetDashCap(const Value: TGPDashCap);\r\nbegin\r\n  GdipCheck(GdipSetPenDashCap197819(FNativeHandle, Value));\r\nend;\r\n\r\nprocedure TGPPen.SetDashOffset(const Value: Single);\r\nbegin\r\n  GdipCheck(GdipSetPenDashOffset(FNativeHandle, Value));\r\nend;\r\n\r\nprocedure TGPPen.SetDashPattern(const Pattern: array of Single);\r\nbegin\r\n  Assert(Length(Pattern) > 0);\r\n  GdipCheck(GdipSetPenDashArray(FNativeHandle, @Pattern[0], Length(Pattern)));\r\nend;\r\n\r\nprocedure TGPPen.SetDashPatternInternal(const Value: IGPDashPattern);\r\nbegin\r\n  Assert(Assigned(Value));\r\n  GdipCheck(GdipSetPenDashArray(FNativeHandle, Value.ItemPtr, Value.Count));\r\nend;\r\n\r\nprocedure TGPPen.SetDashStyle(const Value: TGPDashStyle);\r\nbegin\r\n  GdipCheck(GdipSetPenDashStyle(FNativeHandle, Value));\r\nend;\r\n\r\nprocedure TGPPen.SetEndCap(const Value: TGPLineCap);\r\nbegin\r\n  GdipCheck(GdipSetPenEndCap(FNativeHandle, Value));\r\nend;\r\n\r\nprocedure TGPPen.SetLineCap(const StartCap, EndCap: TGPLineCap;\r\n  const DashCap: TGPDashCap);\r\nbegin\r\n  GdipCheck(GdipSetPenLineCap197819(FNativeHandle, StartCap, EndCap, DashCap));\r\nend;\r\n\r\nprocedure TGPPen.SetLineJoin(const Value: TGPLineJoin);\r\nbegin\r\n  GdipCheck(GdipSetPenLineJoin(FNativeHandle, Value));\r\nend;\r\n\r\nprocedure TGPPen.SetMiterLimit(const Value: Single);\r\nbegin\r\n  GdipCheck(GdipSetPenMiterLimit(FNativeHandle, Value));\r\nend;\r\n\r\nprocedure TGPPen.SetStartCap(const Value: TGPLineCap);\r\nbegin\r\n  GdipCheck(GdipSetPenStartCap(FNativeHandle, Value));\r\nend;\r\n\r\nprocedure TGPPen.SetTransform(const Value: IGPMatrix);\r\nbegin\r\n  GdipCheck(GdipSetPenTransform(FNativeHandle, Value.NativeHandle));\r\nend;\r\n\r\nprocedure TGPPen.SetWidth(const Value: Single);\r\nbegin\r\n  GdipCheck(GdipSetPenWidth(FNativeHandle, Value));\r\nend;\r\n\r\nprocedure TGPPen.TranslateTransform(const DX, DY: Single;\r\n  const Order: TGPMatrixOrder);\r\nbegin\r\n  GdipCheck(GdipTranslatePenTransform(FNativeHandle, DX, DY, Order));\r\nend;\r\n{$ENDREGION 'GdiplusPen.h'}\r\n\r\n{$REGION 'GdiplusStringFormat.h'}\r\n\r\n{ TGPStringFormat }\r\n\r\nfunction TGPStringFormat.Clone: IGPStringFormat;\r\nvar\r\n  NativeClone: GpStringFormat;\r\nbegin\r\n  NativeClone := nil;\r\n  GdipCheck(GdipCloneStringFormat(FNativeHandle, NativeClone));\r\n  Result := TGPStringFormat.Create(NativeClone);\r\nend;\r\n\r\nconstructor TGPStringFormat.Create(const NativeFormat: GpStringFormat);\r\nbegin\r\n  inherited Create;\r\n  FNativeHandle := NativeFormat;\r\nend;\r\n\r\nconstructor TGPStringFormat.Create(const FormatFlags: TGPStringFormatFlags;\r\n  const Language: LangID);\r\nbegin\r\n  inherited Create;\r\n  GdipCheck(GdipCreateStringFormat(FormatFlags, Language, FNativeHandle));\r\nend;\r\n\r\nconstructor TGPStringFormat.Create(const Format: IGPStringFormat);\r\nbegin\r\n  inherited Create;\r\n  GdipCheck(GdipCloneStringFormat(GdipHandle(Format), FNativeHandle));\r\nend;\r\n\r\ndestructor TGPStringFormat.Destroy;\r\nbegin\r\n  GdipDeleteStringFormat(FNativeHandle);\r\n  inherited;\r\nend;\r\n\r\nclass function TGPStringFormat.GenericDefault: IGPStringFormat;\r\nvar\r\n  NativeDefault: GpStringFormat;\r\nbegin\r\n  if (FGenericDefault = nil) then\r\n  begin\r\n    NativeDefault := nil;\r\n    GdipCheck(GdipStringFormatGetGenericDefault(NativeDefault));\r\n    FGenericDefault := TGPStringFormat.Create(NativeDefault);\r\n  end;\r\n  Result := FGenericDefault;\r\nend;\r\n\r\nclass function TGPStringFormat.GenericTypographic: IGPStringFormat;\r\nvar\r\n  NativeDefault: GpStringFormat;\r\nbegin\r\n  if (FGenericTypographic = nil) then\r\n  begin\r\n    NativeDefault := nil;\r\n    GdipCheck(GdipStringFormatGetGenericTypographic(NativeDefault));\r\n    FGenericTypographic := TGPStringFormat.Create(NativeDefault);\r\n  end;\r\n  Result := FGenericTypographic;\r\nend;\r\n\r\nfunction TGPStringFormat.GetAlignment: TGPStringAlignment;\r\nbegin\r\n  GdipCheck(GdipGetStringFormatAlign(FNativeHandle, Result));\r\nend;\r\n\r\nfunction TGPStringFormat.GetDigitSubstitutionLanguage: LangID;\r\nbegin\r\n  GdipCheck(GdipGetStringFormatDigitSubstitution(FNativeHandle, @Result, nil));\r\nend;\r\n\r\nfunction TGPStringFormat.GetDigitSubstitutionMethod: TGPStringDigitSubstitute;\r\nbegin\r\n  GdipCheck(GdipGetStringFormatDigitSubstitution(FNativeHandle, nil, @Result));\r\nend;\r\n\r\nfunction TGPStringFormat.GetFormatFlags: TGPStringFormatFlags;\r\nbegin\r\n  GdipCheck(GdipGetStringFormatFlags(FNativeHandle, Result));\r\nend;\r\n\r\nfunction TGPStringFormat.GetHotkeyPrefix: TGPHotkeyPrefix;\r\nbegin\r\n  GdipCheck(GdipGetStringFormatHotkeyPrefix(FNativeHandle, Result));\r\nend;\r\n\r\nfunction TGPStringFormat.GetLineAlignment: TGPStringAlignment;\r\nbegin\r\n  GdipCheck(GdipGetStringFormatLineAlign(FNativeHandle, Result));\r\nend;\r\n\r\nfunction TGPStringFormat.GetMeasurableCharacterRangeCount: Integer;\r\nbegin\r\n  GdipCheck(GdipGetStringFormatMeasurableCharacterRangeCount(FNativeHandle,\r\n    Result));\r\nend;\r\n\r\nfunction TGPStringFormat.GetTabStops(out FirstTabOffset: Single): IGPTabStops;\r\nvar\r\n  Count: Integer;\r\nbegin\r\n  GdipCheck(GdipGetStringFormatTabStopCount(FNativeHandle, Count));\r\n  Result := TGPArray.Create(Count);\r\n  if (Count > 0) then\r\n    GdipCheck(GdipGetStringFormatTabStops(FNativeHandle, Count, FirstTabOffset,\r\n      Result.ItemPtr));\r\nend;\r\n\r\nfunction TGPStringFormat.GetTrimming: TGPStringTrimming;\r\nbegin\r\n  GdipCheck(GdipGetStringFormatTrimming(FNativeHandle, Result));\r\nend;\r\n\r\nprocedure TGPStringFormat.SetAlignment(const Value: TGPStringAlignment);\r\nbegin\r\n  GdipCheck(GdipSetStringFormatAlign(FNativeHandle, Value));\r\nend;\r\n\r\nprocedure TGPStringFormat.SetDigitSubstitution(const Language: LangID;\r\n  const Substitute: TGPStringDigitSubstitute);\r\nbegin\r\n  GdipCheck(GdipSetStringFormatDigitSubstitution(FNativeHandle, Language, Substitute));\r\nend;\r\n\r\nprocedure TGPStringFormat.SetFormatFlags(const Value: TGPStringFormatFlags);\r\nbegin\r\n  GdipCheck(GdipSetStringFormatFlags(FNativeHandle, Value));\r\nend;\r\n\r\nprocedure TGPStringFormat.SetHotkeyPrefix(const Value: TGPHotkeyPrefix);\r\nbegin\r\n  GdipCheck(GdipSetStringFormatHotkeyPrefix(FNativeHandle, Value));\r\nend;\r\n\r\nprocedure TGPStringFormat.SetLineAlignment(const Value: TGPStringAlignment);\r\nbegin\r\n  GdipCheck(GdipSetStringFormatLineAlign(FNativeHandle, Value));\r\nend;\r\n\r\nprocedure TGPStringFormat.SetMeasurableCharacterRanges(\r\n  const Ranges: IGPCharacterRanges);\r\nbegin\r\n  Assert(Assigned(Ranges));\r\n  GdipCheck(GdipSetStringFormatMeasurableCharacterRanges(FNativeHandle,\r\n    Ranges.Count, Ranges.ItemPtr));\r\nend;\r\n\r\nprocedure TGPStringFormat.SetTabStops(const FirstTabOffset: Single;\r\n  const TabStops: array of Single);\r\nbegin\r\n  Assert(Length(TabStops) > 0);\r\n  GdipCheck(GdipSetStringFormatTabStops(FNativeHandle, FirstTabOffset,\r\n    Length(TabStops), @TabStops[0]));\r\nend;\r\n\r\nprocedure TGPStringFormat.SetTrimming(const Value: TGPStringTrimming);\r\nbegin\r\n  GdipCheck(GdipSetStringFormatTrimming(FNativeHandle, Value));\r\nend;\r\n{$ENDREGION 'GdiplusStringFormat.h'}\r\n\r\n{$REGION 'GdiplusPath.h'}\r\n\r\n{ TGPPathData }\r\n\r\nconstructor TGPPathData.Create(const ACount: Integer);\r\nbegin\r\n  inherited Create;\r\n  SetLength(FPoints, ACount);\r\n  SetLength(FTypes, ACount);\r\nend;\r\n\r\nfunction TGPPathData.GetCount: Integer;\r\nbegin\r\n  Result := Length(FPoints);\r\nend;\r\n\r\nfunction TGPPathData.GetNativePathData: TGPNativePathData;\r\nbegin\r\n  Result.Count := Length(FPoints);\r\n  Result.Points := @FPoints[0];\r\n  Result.Types := @FTypes[0];\r\nend;\r\n\r\nfunction TGPPathData.GetPoint(const Index: Integer): TGPPointF;\r\nbegin\r\n  Result := FPoints[Index];\r\nend;\r\n\r\nfunction TGPPathData.GetPointPtr: PGPPointF;\r\nbegin\r\n  Result := @FPoints[0];\r\nend;\r\n\r\nfunction TGPPathData.GetType(const Index: Integer): Byte;\r\nbegin\r\n  Result := FTypes[Index];\r\nend;\r\n\r\nfunction TGPPathData.GetTypePtr: PByte;\r\nbegin\r\n  Result := @FTypes[0];\r\nend;\r\n\r\nprocedure TGPPathData.SetCount(const Value: Integer);\r\nbegin\r\n  if (Value <> Length(FPoints)) then\r\n  begin\r\n    SetLength(FPoints, Value);\r\n    SetLength(FTypes, Value);\r\n  end;\r\nend;\r\n\r\n{ TGPGraphicsPath }\r\n\r\nprocedure TGPGraphicsPath.AddArc(const Rect: TGPRectF; const StartAngle,\r\n  SweepAngle: Single);\r\nbegin\r\n  AddArc(Rect.X, Rect.Y, Rect.Width, Rect.Height, StartAngle, SweepAngle);\r\nend;\r\n\r\nprocedure TGPGraphicsPath.AddArc(const X, Y, Width, Height: Integer;\r\n  const StartAngle, SweepAngle: Single);\r\nbegin\r\n  GdipCheck(GdipAddPathArcI(FNativeHandle, X, Y, Width, Height, StartAngle, SweepAngle));\r\nend;\r\n\r\nprocedure TGPGraphicsPath.AddArc(const Rect: TGPRect; const StartAngle,\r\n  SweepAngle: Single);\r\nbegin\r\n  AddArc(Rect.X, Rect.Y, Rect.Width, Rect.Height, StartAngle, SweepAngle);\r\nend;\r\n\r\nprocedure TGPGraphicsPath.AddArc(const X, Y, Width, Height, StartAngle,\r\n  SweepAngle: Single);\r\nbegin\r\n  GdipCheck(GdipAddPathArc(FNativeHandle, X, Y, Width, Height, StartAngle, SweepAngle));\r\nend;\r\n\r\nprocedure TGPGraphicsPath.AddBezier(const Pt1, Pt2, Pt3, Pt4: TGPPoint);\r\nbegin\r\n  AddBezier(Pt1.X, Pt1.Y, Pt2.X, Pt2.Y, Pt3.X, Pt3.Y, Pt4.X, Pt4.Y);\r\nend;\r\n\r\nprocedure TGPGraphicsPath.AddBezier(const Pt1, Pt2, Pt3, Pt4: TGPPointF);\r\nbegin\r\n  AddBezier(Pt1.X, Pt1.Y, Pt2.X, Pt2.Y, Pt3.X, Pt3.Y, Pt4.X, Pt4.Y);\r\nend;\r\n\r\nprocedure TGPGraphicsPath.AddBezier(const X1, Y1, X2, Y2, X3, Y3, X4, Y4: Single);\r\nbegin\r\n  GdipCheck(GdipAddPathBezier(FNativeHandle, X1, Y1, X2, Y2, X3, Y3, X4, Y4));\r\nend;\r\n\r\nprocedure TGPGraphicsPath.AddBezier(const X1, Y1, X2, Y2, X3, Y3, X4,\r\n  Y4: Integer);\r\nbegin\r\n  GdipCheck(GdipAddPathBezierI(FNativeHandle, X1, Y1, X2, Y2, X3, Y3, X4, Y4));\r\nend;\r\n\r\nprocedure TGPGraphicsPath.AddBeziers(const Points: array of TGPPointF);\r\nbegin\r\n  Assert(Length(Points) > 0);\r\n  GdipCheck(GdipAddPathBeziers(FNativeHandle, @Points[0], Length(Points)));\r\nend;\r\n\r\nprocedure TGPGraphicsPath.AddBeziers(const Points: array of TGPPoint);\r\nbegin\r\n  Assert(Length(Points) > 0);\r\n  GdipCheck(GdipAddPathBeziersI(FNativeHandle, @Points[0], Length(Points)));\r\nend;\r\n\r\nprocedure TGPGraphicsPath.AddClosedCurve(const Points: array of TGPPoint);\r\nbegin\r\n  Assert(Length(Points) > 0);\r\n  GdipCheck(GdipAddPathClosedCurveI(FNativeHandle, @Points[0], Length(Points)));\r\nend;\r\n\r\nprocedure TGPGraphicsPath.AddClosedCurve(const Points: array of TGPPoint;\r\n  const Tension: Single);\r\nbegin\r\n  Assert(Length(Points) > 0);\r\n  GdipCheck(GdipAddPathClosedCurve2I(FNativeHandle, @Points[0], Length(Points), Tension));\r\nend;\r\n\r\nprocedure TGPGraphicsPath.AddClosedCurve(const Points: array of TGPPointF);\r\nbegin\r\n  Assert(Length(Points) > 0);\r\n  GdipCheck(GdipAddPathClosedCurve(FNativeHandle, @Points[0], Length(Points)));\r\nend;\r\n\r\nprocedure TGPGraphicsPath.AddClosedCurve(const Points: array of TGPPointF;\r\n  const Tension: Single);\r\nbegin\r\n  Assert(Length(Points) > 0);\r\n  GdipCheck(GdipAddPathClosedCurve2(FNativeHandle, @Points[0], Length(Points), Tension));\r\nend;\r\n\r\nprocedure TGPGraphicsPath.AddCurve(const Points: array of TGPPoint);\r\nbegin\r\n  Assert(Length(Points) > 0);\r\n  GdipCheck(GdipAddPathCurveI(FNativeHandle, @Points[0], Length(Points)));\r\nend;\r\n\r\nprocedure TGPGraphicsPath.AddCurve(const Points: array of TGPPoint;\r\n  const Tension: Single);\r\nbegin\r\n  Assert(Length(Points) > 0);\r\n  GdipCheck(GdipAddPathCurve2I(FNativeHandle, @Points[0], Length(Points), Tension));\r\nend;\r\n\r\nprocedure TGPGraphicsPath.AddCurve(const Points: array of TGPPoint; const Offset,\r\n  NumberOfSegments: Integer; const Tension: Single);\r\nbegin\r\n  Assert(Length(Points) > 0);\r\n  GdipCheck(GdipAddPathCurve3I(FNativeHandle, @Points[0], Length(Points),\r\n    Offset, NumberOfSegments, Tension));\r\nend;\r\n\r\nprocedure TGPGraphicsPath.AddCurve(const Points: array of TGPPointF);\r\nbegin\r\n  Assert(Length(Points) > 0);\r\n  GdipCheck(GdipAddPathCurve(FNativeHandle, @Points[0], Length(Points)));\r\nend;\r\n\r\nprocedure TGPGraphicsPath.AddCurve(const Points: array of TGPPointF;\r\n  const Tension: Single);\r\nbegin\r\n  Assert(Length(Points) > 0);\r\n  GdipCheck(GdipAddPathCurve2(FNativeHandle, @Points[0], Length(Points), Tension));\r\nend;\r\n\r\nprocedure TGPGraphicsPath.AddCurve(const Points: array of TGPPointF; const Offset,\r\n  NumberOfSegments: Integer; const Tension: Single);\r\nbegin\r\n  Assert(Length(Points) > 0);\r\n  GdipCheck(GdipAddPathCurve3(FNativeHandle, @Points[0], Length(Points),\r\n    Offset, NumberOfSegments, Tension));\r\nend;\r\n\r\nprocedure TGPGraphicsPath.AddEllipse(const X, Y, Width, Height: Single);\r\nbegin\r\n  GdipCheck(GdipAddPathEllipse(FNativeHandle, X, Y, Width, Height));\r\nend;\r\n\r\nprocedure TGPGraphicsPath.AddEllipse(const Rect: TGPRectF);\r\nbegin\r\n  AddEllipse(Rect.X, Rect.Y, Rect.Width, Rect.Height);\r\nend;\r\n\r\nprocedure TGPGraphicsPath.AddEllipse(const X, Y, Width, Height: Integer);\r\nbegin\r\n  GdipCheck(GdipAddPathEllipseI(FNativeHandle, X, Y, Width, Height));\r\nend;\r\n\r\nprocedure TGPGraphicsPath.AddEllipse(const Rect: TGPRect);\r\nbegin\r\n  AddEllipse(Rect.X, Rect.Y, Rect.Width, Rect.Height);\r\nend;\r\n\r\nprocedure TGPGraphicsPath.AddLine(const Pt1, Pt2: TGPPoint);\r\nbegin\r\n  AddLine(Pt1.X, Pt1.Y, Pt2.X, Pt2.Y);\r\nend;\r\n\r\nprocedure TGPGraphicsPath.AddLine(const X1, Y1, X2, Y2: Integer);\r\nbegin\r\n  GdipCheck(GdipAddPathLineI(FNativeHandle, X1, Y1, X2, Y2));\r\nend;\r\n\r\nprocedure TGPGraphicsPath.AddLine(const Pt1, Pt2: TGPPointF);\r\nbegin\r\n  AddLine(Pt1.X, Pt1.Y, Pt2.X, Pt2.Y);\r\nend;\r\n\r\nprocedure TGPGraphicsPath.AddLine(const X1, Y1, X2, Y2: Single);\r\nbegin\r\n  GdipCheck(GdipAddPathLine(FNativeHandle, X1, Y1, X2, Y2));\r\nend;\r\n\r\nprocedure TGPGraphicsPath.AddLines(const Points: array of TGPPoint);\r\nbegin\r\n  Assert(Length(Points) > 0);\r\n  GdipCheck(GdipAddPathLine2I(FNativeHandle, @Points[0], Length(Points)));\r\nend;\r\n\r\nprocedure TGPGraphicsPath.AddLines(const Points: array of TGPPointF);\r\nbegin\r\n  Assert(Length(Points) > 0);\r\n  GdipCheck(GdipAddPathLine2(FNativeHandle, @Points[0], Length(Points)));\r\nend;\r\n\r\nprocedure TGPGraphicsPath.AddPath(const AddingPath: IGPGraphicsPath;\r\n  const Connect: Boolean);\r\nbegin\r\n  GdipCheck(GdipAddPathPath(FNativeHandle, GdipHandle(AddingPath), Connect));\r\nend;\r\n\r\nprocedure TGPGraphicsPath.AddPie(const Rect: TGPRect; const StartAngle,\r\n  SweepAngle: Single);\r\nbegin\r\n  AddPie(Rect.X, Rect.Y, Rect.Width, Rect.Height, StartAngle, SweepAngle);\r\nend;\r\n\r\nprocedure TGPGraphicsPath.AddPie(const X, Y, Width, Height: Integer;\r\n  const StartAngle, SweepAngle: Single);\r\nbegin\r\n  GdipCheck(GdipAddPathPieI(FNativeHandle, X, Y, Width, Height, StartAngle, SweepAngle));\r\nend;\r\n\r\nprocedure TGPGraphicsPath.AddPie(const Rect: TGPRectF; const StartAngle,\r\n  SweepAngle: Single);\r\nbegin\r\n  AddPie(Rect.X, Rect.Y, Rect.Width, Rect.Height, StartAngle, SweepAngle);\r\nend;\r\n\r\nprocedure TGPGraphicsPath.AddPie(const X, Y, Width, Height, StartAngle,\r\n  SweepAngle: Single);\r\nbegin\r\n  GdipCheck(GdipAddPathPie(FNativeHandle, X, Y, Width, Height, StartAngle, SweepAngle));\r\nend;\r\n\r\nprocedure TGPGraphicsPath.AddPolygon(const Points: array of TGPPoint);\r\nbegin\r\n  Assert(Length(Points) > 0);\r\n  GdipCheck(GdipAddPathPolygonI(FNativeHandle, @Points[0], Length(Points)));\r\nend;\r\n\r\nprocedure TGPGraphicsPath.AddPolygon(const Points: array of TGPPointF);\r\nbegin\r\n  Assert(Length(Points) > 0);\r\n  GdipCheck(GdipAddPathPolygon(FNativeHandle, @Points[0], Length(Points)));\r\nend;\r\n\r\nprocedure TGPGraphicsPath.AddRectangle(const Rect: TGPRect);\r\nbegin\r\n  GdipCheck(GdipAddPathRectangleI(FNativeHandle, Rect.X, Rect.Y,\r\n    Rect.Width, Rect.Height));\r\nend;\r\n\r\nprocedure TGPGraphicsPath.AddRectangle(const Rect: TGPRectF);\r\nbegin\r\n  GdipCheck(GdipAddPathRectangle(FNativeHandle, Rect.X, Rect.Y,\r\n    Rect.Width, Rect.Height));\r\nend;\r\n\r\nprocedure TGPGraphicsPath.AddRectangles(const Rects: array of TGPRect);\r\nbegin\r\n  Assert(Length(Rects) > 0);\r\n  GdipCheck(GdipAddPathRectanglesI(FNativeHandle, @Rects[0], Length(Rects)));\r\nend;\r\n\r\nprocedure TGPGraphicsPath.AddRectangles(const Rects: array of TGPRectF);\r\nbegin\r\n  Assert(Length(Rects) > 0);\r\n  GdipCheck(GdipAddPathRectangles(FNativeHandle, @Rects[0], Length(Rects)));\r\nend;\r\n\r\nprocedure TGPGraphicsPath.AddString(const Str: String; const Family: IGPFontFamily;\r\n  const Style: TGPFontStyle; const EmSize: Single; const Origin: TGPPoint;\r\n  const Format: IGPStringFormat);\r\nvar\r\n  Rect: TGPRect;\r\nbegin\r\n  Rect.Initialize(Origin.X, Origin.Y, 0, 0);\r\n  GdipCheck(GdipAddPathStringI(FNativeHandle, PWideChar(Str), Length(Str),\r\n    GdipHandle(Family), Style, EmSize, @Rect, GdipHandle(Format)));\r\nend;\r\n\r\nprocedure TGPGraphicsPath.AddString(const Str: String; const Family: IGPFontFamily;\r\n  const Style: TGPFontStyle; const EmSize: Single; const LayoutRect: TGPRect;\r\n  const Format: IGPStringFormat);\r\nbegin\r\n  GdipCheck(GdipAddPathStringI(FNativeHandle, PWideChar(Str), Length(Str),\r\n    GdipHandle(Family), Style, EmSize, @LayoutRect, GdipHandle(Format)));\r\nend;\r\n\r\nprocedure TGPGraphicsPath.AddString(const Str: String; const Family: IGPFontFamily;\r\n  const Style: TGPFontStyle; const EmSize: Single; const Origin: TGPPointF;\r\n  const Format: IGPStringFormat);\r\nvar\r\n  Rect: TGPRectF;\r\nbegin\r\n  Rect.Initialize(Origin.X, Origin.Y, 0, 0);\r\n  GdipCheck(GdipAddPathString(FNativeHandle, PWideChar(Str), Length(Str),\r\n    GdipHandle(Family), Style, EmSize, @Rect, GdipHandle(Format)));\r\nend;\r\n\r\nprocedure TGPGraphicsPath.AddString(const Str: String; const Family: IGPFontFamily;\r\n  const Style: TGPFontStyle; const EmSize: Single; const LayoutRect: TGPRectF;\r\n  const Format: IGPStringFormat);\r\nbegin\r\n  GdipCheck(GdipAddPathString(FNativeHandle, PWideChar(Str), Length(Str),\r\n    GdipHandle(Family), Style, EmSize, @LayoutRect, GdipHandle(Format)));\r\nend;\r\n\r\nprocedure TGPGraphicsPath.ClearMarkers;\r\nbegin\r\n  GdipCheck(GdipClearPathMarkers(FNativeHandle));\r\nend;\r\n\r\nfunction TGPGraphicsPath.Clone: IGPGraphicsPath;\r\nvar\r\n  NativeClone: GpPath;\r\nbegin\r\n  NativeClone := nil;\r\n  GdipCheck(GdipClonePath(FNativeHandle, NativeClone));\r\n  Result := TGPGraphicsPath.Create(NativeClone);\r\nend;\r\n\r\nprocedure TGPGraphicsPath.CloseAllFigures;\r\nbegin\r\n  GdipCheck(GdipClosePathFigures(FNativeHandle));\r\nend;\r\n\r\nprocedure TGPGraphicsPath.CloseFigure;\r\nbegin\r\n  GdipCheck(GdipClosePathFigure(FNativeHandle));\r\nend;\r\n\r\nconstructor TGPGraphicsPath.Create(const Points: array of TGPPoint;\r\n  const Types: array of Byte; const FillMode: TGPFillMode);\r\nbegin\r\n  Assert(Length(Points) > 0);\r\n  Assert(Length(Points) = Length(Types));\r\n  inherited Create;\r\n  GdipCheck(GdipCreatePath2I(@Points[0], @Types[0], Length(Points), FillMode,\r\n    FNativeHandle));\r\nend;\r\n\r\nconstructor TGPGraphicsPath.Create(const NativePath: GpPath);\r\nbegin\r\n  inherited Create;\r\n  FNativeHandle := NativePath;\r\nend;\r\n\r\nconstructor TGPGraphicsPath.Create(const FillMode: TGPFillMode);\r\nbegin\r\n  inherited Create;\r\n  GdipCheck(GdipCreatePath(FillMode, FNativeHandle));\r\nend;\r\n\r\nconstructor TGPGraphicsPath.Create(const Points: array of TGPPointF;\r\n  const Types: array of Byte; const FillMode: TGPFillMode);\r\nbegin\r\n  Assert(Length(Points) > 0);\r\n  Assert(Length(Points) = Length(Types));\r\n  inherited Create;\r\n  GdipCheck(GdipCreatePath2(@Points[0], @Types[0], Length(Points), FillMode,\r\n    FNativeHandle));\r\nend;\r\n\r\ndestructor TGPGraphicsPath.Destroy;\r\nbegin\r\n  GdipDeletePath(FNativeHandle);\r\n  inherited;\r\nend;\r\n\r\nprocedure TGPGraphicsPath.Flatten(const Matrix: IGPMatrix; const Flatness: Single);\r\nbegin\r\n  GdipCheck(GdipFlattenPath(FNativeHandle, GdipHandle(Matrix), Flatness));\r\nend;\r\n\r\nprocedure TGPGraphicsPath.GetBounds(out Bounds: TGPRectF; const Matrix: IGPMatrix;\r\n  const Pen: IGPPen);\r\nbegin\r\n  GdipCheck(GdipGetPathWorldBounds(FNativeHandle, @Bounds,\r\n    GdipHandle(Matrix), GdipHandle(Pen)));\r\nend;\r\n\r\nprocedure TGPGraphicsPath.GetBounds(out Bounds: TGPRect; const Matrix: IGPMatrix;\r\n  const Pen: IGPPen);\r\nbegin\r\n  GdipCheck(GdipGetPathWorldBoundsI(FNativeHandle, @Bounds,\r\n    GdipHandle(Matrix), GdipHandle(Pen)));\r\nend;\r\n\r\nfunction TGPGraphicsPath.GetFillMode: TGPFillMode;\r\nbegin\r\n  Result := FillModeAlternate;\r\n  GdipCheck(GdipGetPathFillMode(FNativeHandle, Result));\r\nend;\r\n\r\nfunction TGPGraphicsPath.GetLastPoint: TGPPointF;\r\nbegin\r\n  GdipCheck(GdipGetPathLastPoint(FNativeHandle, Result));\r\nend;\r\n\r\nfunction TGPGraphicsPath.GetPathData: IGPPathData;\r\nvar\r\n  Count: Integer;\r\n  NativeData: TGPNativePathData;\r\nbegin\r\n  Count := GetPointCount;\r\n  Result := TGPPathData.Create(Count);\r\n  NativeData := Result.NativePathData;\r\n  GdipCheck(GdipGetPathData(FNativeHandle, @NativeData));\r\nend;\r\n\r\nfunction TGPGraphicsPath.GetPathPoints: IGPPathPoints;\r\nvar\r\n  Count: Integer;\r\nbegin\r\n  Count := GetPointCount;\r\n  Result := TGPArray.Create(Count);\r\n  GdipCheck(GdipGetPathPoints(FNativeHandle, Result.ItemPtr, Count));\r\nend;\r\n\r\nfunction TGPGraphicsPath.GetPathPointsI: IGPPathPointsI;\r\nvar\r\n  Count: Integer;\r\nbegin\r\n  Count := GetPointCount;\r\n  Result := TGPArray.Create(Count);\r\n  GdipCheck(GdipGetPathPointsI(FNativeHandle, Result.ItemPtr, Count));\r\nend;\r\n\r\nfunction TGPGraphicsPath.GetPathTypes: IGPPathTypes;\r\nvar\r\n  Count: Integer;\r\nbegin\r\n  Count := GetPointCount;\r\n  Result := TGPArray.Create(Count);\r\n  GdipCheck(GdipGetPathTypes(FNativeHandle, Result.ItemPtr, Count));\r\nend;\r\n\r\nfunction TGPGraphicsPath.GetPointCount: Integer;\r\nbegin\r\n  Result := 0;\r\n  GdipCheck(GdipGetPointCount(FNativeHandle, Result));\r\nend;\r\n\r\nfunction TGPGraphicsPath.IsOutlineVisible(const X, Y: Integer; const Pen: IGPPen;\r\n  const G: IGPGraphics): Boolean;\r\nvar\r\n  B: Bool;\r\nbegin\r\n  B := False;\r\n  GdipCheck(GdipIsOutlineVisiblePathPointI(FNativeHandle, X, Y, GdipHandle(Pen),\r\n    GdipHandle(G), B));\r\n  Result := B;\r\nend;\r\n\r\nfunction TGPGraphicsPath.IsOutlineVisible(const Point: TGPPointF; const Pen: IGPPen;\r\n  const G: IGPGraphics): Boolean;\r\nbegin\r\n  Result := IsOutlineVisible(Point.X, Point.Y, Pen, G);\r\nend;\r\n\r\nfunction TGPGraphicsPath.IsOutlineVisible(const X, Y: Single; const Pen: IGPPen;\r\n  const G: IGPGraphics): Boolean;\r\nvar\r\n  B: Bool;\r\nbegin\r\n  B := False;\r\n  GdipCheck(GdipIsOutlineVisiblePathPoint(FNativeHandle, X, Y, GdipHandle(Pen),\r\n    GdipHandle(G), B));\r\n  Result := B;\r\nend;\r\n\r\nfunction TGPGraphicsPath.IsOutlineVisible(const Point: TGPPoint; const Pen: IGPPen;\r\n  const G: IGPGraphics): Boolean;\r\nbegin\r\n  Result := IsOutlineVisible(Point.X, Point.Y, Pen, G);\r\nend;\r\n\r\nfunction TGPGraphicsPath.IsVisible(const X, Y: Single;\r\n  const G: IGPGraphics): Boolean;\r\nvar\r\n  B: Bool;\r\nbegin\r\n  B := False;\r\n  GdipCheck(GdipIsVisiblePathPoint(FNativeHandle, X, Y, GdipHandle(G), B));\r\n  Result := B;\r\nend;\r\n\r\nfunction TGPGraphicsPath.IsVisible(const X, Y: Integer;\r\n  const G: IGPGraphics): Boolean;\r\nvar\r\n  B: Bool;\r\nbegin\r\n  B := False;\r\n  GdipCheck(GdipIsVisiblePathPointI(FNativeHandle, X, Y, GdipHandle(G), B));\r\n  Result := B;\r\nend;\r\n\r\nfunction TGPGraphicsPath.IsVisible(const Point: TGPPointF;\r\n  const G: IGPGraphics): Boolean;\r\nbegin\r\n  Result := IsVisible(Point.X, Point.Y, G);\r\nend;\r\n\r\nfunction TGPGraphicsPath.IsVisible(const Point: TGPPoint;\r\n  const G: IGPGraphics): Boolean;\r\nbegin\r\n  Result := IsVisible(Point.X, Point.Y, G);\r\nend;\r\n\r\nprocedure TGPGraphicsPath.Outline(const Matrix: IGPMatrix; const Flatness: Single);\r\nbegin\r\n  GdipCheck(GdipWindingModeOutline(FNativeHandle, GdipHandle(Matrix), Flatness));\r\nend;\r\n\r\nprocedure TGPGraphicsPath.Reset;\r\nbegin\r\n  GdipCheck(GdipResetPath(FNativeHandle));\r\nend;\r\n\r\nprocedure TGPGraphicsPath.Reverse;\r\nbegin\r\n  GdipCheck(GdipReversePath(FNativeHandle));\r\nend;\r\n\r\nprocedure TGPGraphicsPath.SetFillMode(const Value: TGPFillMode);\r\nbegin\r\n  GdipCheck(GdipSetPathFillMode(FNativeHandle, Value));\r\nend;\r\n\r\nprocedure TGPGraphicsPath.SetMarker;\r\nbegin\r\n  GdipCheck(GdipSetPathMarker(FNativeHandle));\r\nend;\r\n\r\nprocedure TGPGraphicsPath.StartFigure;\r\nbegin\r\n  GdipCheck(GdipStartPathFigure(FNativeHandle));\r\nend;\r\n\r\nprocedure TGPGraphicsPath.Transform(const Matrix: IGPMatrix);\r\nbegin\r\n  if Assigned(Matrix) then\r\n    GdipCheck(GdipTransformPath(FNativeHandle, Matrix.NativeHandle));\r\nend;\r\n\r\nprocedure TGPGraphicsPath.Warp(const DestPoints: array of TGPPointF;\r\n  const SrcRect: TGPRectF; const Matrix: IGPMatrix; const WarpMode: TGPWarpMode;\r\n  const Flatness: Single);\r\nbegin\r\n  Assert(Length(DestPoints) > 0);\r\n  GdipCheck(GdipWarpPath(FNativeHandle, GdipHandle(Matrix), @DestPoints[0],\r\n    Length(DestPoints), SrcRect.X, SrcRect.Y, SrcRect.Width, SrcRect.Height,\r\n    WarpMode, Flatness));\r\nend;\r\n\r\nprocedure TGPGraphicsPath.Widen(const Pen: IGPPen; const Matrix: IGPMatrix;\r\n  const Flatness: Single);\r\nbegin\r\n  GdipCheck(GdipWidenPath(FNativeHandle, Pen.NativeHandle, GdipHandle(Matrix), Flatness));\r\nend;\r\n\r\n{ TGPGraphicsPathIterator }\r\n\r\nfunction TGPGraphicsPathIterator.CopyData(const StartIndex,\r\n  EndIndex: Integer): IGPPathData;\r\nvar\r\n  Count: Integer;\r\nbegin\r\n  Count := EndIndex - StartIndex + 1;\r\n  Result := TGPPathData.Create(Count);\r\n  GdipCheck(GdipPathIterCopyData(FNativeHandle, Count, Result.PointPtr,\r\n    Result.TypePtr, StartIndex, EndIndex));\r\n  Result.Count := Count;\r\nend;\r\n\r\nconstructor TGPGraphicsPathIterator.Create(const Path: IGPGraphicsPath);\r\nbegin\r\n  inherited Create;\r\n  GdipCheck(GdipCreatePathIter(FNativeHandle, GdipHandle(Path)));\r\nend;\r\n\r\ndestructor TGPGraphicsPathIterator.Destroy;\r\nbegin\r\n  GdipDeletePathIter(FNativeHandle);\r\n  inherited;\r\nend;\r\n\r\nfunction TGPGraphicsPathIterator.Enumerate: IGPPathData;\r\nvar\r\n  Count: Integer;\r\nbegin\r\n  Count := GetCount;\r\n  Result := TGPPathData.Create(Count);\r\n  GdipCheck(GdipPathIterEnumerate(FNativeHandle, Count, Result.PointPtr,\r\n    Result.TypePtr, Count));\r\n  Result.Count := Count;\r\nend;\r\n\r\nfunction TGPGraphicsPathIterator.GetCount: Integer;\r\nbegin\r\n  GdipCheck(GdipPathIterGetCount(FNativeHandle, Result));\r\nend;\r\n\r\nfunction TGPGraphicsPathIterator.GetSubpathCount: Integer;\r\nbegin\r\n  GdipCheck(GdipPathIterGetSubpathCount(FNativeHandle, Result));\r\nend;\r\n\r\nfunction TGPGraphicsPathIterator.HasCurve: Boolean;\r\nvar\r\n  B: Bool;\r\nbegin\r\n  GdipCheck(GdipPathIterHasCurve(FNativeHandle, B));\r\n  Result := B;\r\nend;\r\n\r\nfunction TGPGraphicsPathIterator.NextMarker(out StartIndex,\r\n  EndIndex: Integer): Integer;\r\nbegin\r\n  GdipCheck(GdipPathIterNextMarker(FNativeHandle, Result, StartIndex, EndIndex));\r\nend;\r\n\r\nfunction TGPGraphicsPathIterator.NextMarker(const Path: IGPGraphicsPath): Integer;\r\nbegin\r\n  GdipCheck(GdipPathIterNextMarkerPath(FNativeHandle, Result, GdipHandle(Path)));\r\nend;\r\n\r\nfunction TGPGraphicsPathIterator.NextPathType(out PathType: Byte; out StartIndex,\r\n  EndIndex: Integer): Integer;\r\nbegin\r\n  GdipCheck(GdipPathIterNextPathType(FNativeHandle, Result, PathType,\r\n    StartIndex, EndIndex));\r\nend;\r\n\r\nfunction TGPGraphicsPathIterator.NextSubPath(out StartIndex, EndIndex: Integer;\r\n  out IsClosed: Boolean): Integer;\r\nvar\r\n  B: Bool;\r\nbegin\r\n  GdipCheck(GdipPathIterNextSubpath(FNativeHandle, Result, StartIndex,\r\n    EndIndex, B));\r\n  IsClosed := B;\r\nend;\r\n\r\nfunction TGPGraphicsPathIterator.NextSubPath(const Path: IGPGraphicsPath;\r\n  out IsClosed: Boolean): Integer;\r\nvar\r\n  B: Bool;\r\nbegin\r\n  GdipCheck(GdipPathIterNextSubpathPath(FNativeHandle, Result,\r\n    GdipHandle(Path), B));\r\n  IsClosed := B;\r\nend;\r\n\r\nprocedure TGPGraphicsPathIterator.Rewind;\r\nbegin\r\n  GdipCheck(GdipPathIterRewind(FNativeHandle));\r\nend;\r\n\r\n{ TGPPathGradientBrush }\r\n\r\nconstructor TGPPathGradientBrush.Create(const Path: IGPGraphicsPath);\r\nbegin\r\n  inherited Create;\r\n  GdipCheck(GdipCreatePathGradientFromPath(Path.NativeHandle, FNativeHandle));\r\nend;\r\n\r\nconstructor TGPPathGradientBrush.Create(const Points: array of TGPPoint;\r\n  const WrapMode: TGPWrapMode);\r\nbegin\r\n  inherited Create;\r\n  Assert(Length(Points) > 0);\r\n  GdipCheck(GdipCreatePathGradientI(@Points[0], Length(Points), WrapMode, FNativeHandle));\r\nend;\r\n\r\nconstructor TGPPathGradientBrush.Create(const Points: array of TGPPointF;\r\n  const WrapMode: TGPWrapMode);\r\nbegin\r\n  inherited Create;\r\n  Assert(Length(Points) > 0);\r\n  GdipCheck(GdipCreatePathGradient(@Points[0], Length(Points), WrapMode, FNativeHandle));\r\nend;\r\n\r\nfunction TGPPathGradientBrush.GetBlend: IGPBlend;\r\nvar\r\n  Count: Integer;\r\nbegin\r\n  Count := 0;\r\n  GdipCheck(GdipGetPathGradientBlendCount(FNativeHandle, Count));\r\n  Result := TGPBlend.Create(Count);\r\n  if (Count > 0) then\r\n    GdipCheck(GdipGetPathGradientBlend(FNativeHandle, Result.FactorPtr,\r\n      Result.PositionPtr, Count));\r\nend;\r\n\r\nfunction TGPPathGradientBrush.GetCenterColor: TGPColor;\r\nbegin\r\n  GdipCheck(GdipGetPathGradientCenterColor(FNativeHandle, Result.FArgb));\r\nend;\r\n\r\nfunction TGPPathGradientBrush.GetCenterPoint: TGPPointF;\r\nbegin\r\n  GdipCheck(GdipGetPathGradientCenterPoint(FNativeHandle, Result));\r\nend;\r\n\r\nfunction TGPPathGradientBrush.GetCenterPointI: TGPPoint;\r\nbegin\r\n  GdipCheck(GdipGetPathGradientCenterPointI(FNativeHandle, Result));\r\nend;\r\n\r\nprocedure TGPPathGradientBrush.GetFocusScales(out XScale, YScale: Single);\r\nbegin\r\n  GdipCheck(GdipGetPathGradientFocusScales(FNativeHandle, XScale, YScale));\r\nend;\r\n\r\nfunction TGPPathGradientBrush.GetGammaCorrection: Boolean;\r\nvar\r\n  B: Bool;\r\nbegin\r\n  GdipCheck(GdipGetPathGradientGammaCorrection(FNativeHandle, B));\r\n  Result := B;\r\nend;\r\n\r\nfunction TGPPathGradientBrush.GetGraphicsPath: IGPGraphicsPath;\r\nvar\r\n  NativePath: GpPath;\r\nbegin\r\n  NativePath := nil;\r\n  GdipCheck(GdipGetPathGradientPath(FNativeHandle, NativePath));\r\n  Result := TGPGraphicsPath.Create(NativePath);\r\nend;\r\n\r\nfunction TGPPathGradientBrush.GetInterpolationColors: IGPColorBlend;\r\nvar\r\n  Count: Integer;\r\nbegin\r\n  Count := 0;\r\n  GdipCheck(GdipGetPathGradientPresetBlendCount(FNativeHandle, Count));\r\n  Result := TGPColorBlend.Create(Count);\r\n  if (Count > 0) then\r\n    GdipCheck(GdipGetPathGradientPresetBlend(FNativeHandle, PARGB(Result.ColorPtr),\r\n      Result.PositionPtr, Count));\r\nend;\r\n\r\nfunction TGPPathGradientBrush.GetPointCount: Integer;\r\nbegin\r\n  GdipCheck(GdipGetPathGradientPointCount(FNativeHandle, Result));\r\nend;\r\n\r\nfunction TGPPathGradientBrush.GetRectangle: TGPRectF;\r\nbegin\r\n  GdipCheck(GdipGetPathGradientRect(FNativeHandle, Result));\r\nend;\r\n\r\nfunction TGPPathGradientBrush.GetRectangleI: TGPRect;\r\nbegin\r\n  GdipCheck(GdipGetPathGradientRectI(FNativeHandle, Result));\r\nend;\r\n\r\nfunction TGPPathGradientBrush.GetSurroundColors: IGPColors;\r\nvar\r\n  Count: Integer;\r\nbegin\r\n  GdipCheck(GdipGetPathGradientSurroundColorCount(FNativeHandle, Count));\r\n  Result := TGPArray.Create(Count);\r\n  if (Count > 0) then\r\n  begin\r\n    GdipCheck(GdipGetPathGradientSurroundColorsWithCount(FNativeHandle,\r\n      Result.ItemPtr, Count));\r\n    Result.Count := Count;\r\n  end;\r\nend;\r\n\r\nfunction TGPPathGradientBrush.GetTransform: IGPMatrix;\r\nbegin\r\n  Result := TGPMatrix.Create;\r\n  GdipCheck(GdipGetPathGradientTransform(FNativeHandle, Result.NativeHandle));\r\nend;\r\n\r\nfunction TGPPathGradientBrush.GetWrapMode: TGPWrapMode;\r\nbegin\r\n  GdipCheck(GdipGetPathGradientWrapMode(FNativeHandle, Result));\r\nend;\r\n\r\nprocedure TGPPathGradientBrush.MultiplyTransform(const Matrix: IGPMatrix;\r\n  const Order: TGPMatrixOrder);\r\nbegin\r\n  GdipCheck(GdipMultiplyPathGradientTransform(FNativeHandle,\r\n    Matrix.NativeHandle, Order));\r\nend;\r\n\r\nprocedure TGPPathGradientBrush.ResetTransform;\r\nbegin\r\n  GdipCheck(GdipResetPathGradientTransform(FNativeHandle));\r\nend;\r\n\r\nprocedure TGPPathGradientBrush.RotateTransform(const Angle: Single;\r\n  const Order: TGPMatrixOrder);\r\nbegin\r\n  GdipCheck(GdipRotatePathGradientTransform(FNativeHandle, Angle, Order));\r\nend;\r\n\r\nprocedure TGPPathGradientBrush.ScaleTransform(const SX, SY: Single;\r\n  const Order: TGPMatrixOrder);\r\nbegin\r\n  GdipCheck(GdipScalePathGradientTransform(FNativeHandle, SX, SY, Order));\r\nend;\r\n\r\nprocedure TGPPathGradientBrush.SetBlend(const Value: IGPBlend);\r\nbegin\r\n  Assert(Assigned(Value));\r\n  GdipCheck(GdipSetPathGradientBlend(FNativeHandle, Value.FactorPtr,\r\n    Value.PositionPtr, Value.Count));\r\nend;\r\n\r\nprocedure TGPPathGradientBrush.SetBlendBellShape(const Focus, Scale: Single);\r\nbegin\r\n  GdipCheck(GdipSetPathGradientSigmaBlend(FNativeHandle, Focus, Scale));\r\nend;\r\n\r\nprocedure TGPPathGradientBrush.SetBlendTriangularShape(const Focus,\r\n  Scale: Single);\r\nbegin\r\n  GdipCheck(GdipSetPathGradientLinearBlend(FNativeHandle, Focus, Scale));\r\nend;\r\n\r\nprocedure TGPPathGradientBrush.SetCenterColor(const Value: TGPColor);\r\nbegin\r\n  GdipCheck(GdipSetPathGradientCenterColor(FNativeHandle, Value.FArgb));\r\nend;\r\n\r\nprocedure TGPPathGradientBrush.SetCenterPoint(const Value: TGPPointF);\r\nbegin\r\n  GdipCheck(GdipSetPathGradientCenterPoint(FNativeHandle, @Value));\r\nend;\r\n\r\nprocedure TGPPathGradientBrush.SetCenterPointI(const Value: TGPPoint);\r\nbegin\r\n  GdipCheck(GdipSetPathGradientCenterPointI(FNativeHandle, @Value));\r\nend;\r\n\r\nprocedure TGPPathGradientBrush.SetFocusScales(const XScale, YScale: Single);\r\nbegin\r\n  GdipCheck(GdipSetPathGradientFocusScales(FNativeHandle, XScale, YScale));\r\nend;\r\n\r\nprocedure TGPPathGradientBrush.SetGammaCorrection(const Value: Boolean);\r\nbegin\r\n  GdipCheck(GdipSetPathGradientGammaCorrection(FNativeHandle, Value));\r\nend;\r\n\r\nprocedure TGPPathGradientBrush.SetGraphicsPath(const Value: IGPGraphicsPath);\r\nbegin\r\n  if Assigned(Value) then\r\n    GdipCheck(GdipSetPathGradientPath(FNativeHandle, Value.NativeHandle))\r\n  else\r\n    GdipCheck(InvalidParameter);\r\nend;\r\n\r\nprocedure TGPPathGradientBrush.SetInterpolationColors(const Value: IGPColorBlend);\r\nbegin\r\n  GdipCheck(GdipSetPathGradientPresetBlend(FNativeHandle, PARGB(Value.ColorPtr),\r\n    Value.PositionPtr, Value.Count));\r\nend;\r\n\r\nprocedure TGPPathGradientBrush.SetSurroundColors(const Colors: array of TGPColor);\r\nvar\r\n  Count: Integer;\r\nbegin\r\n  Assert(Length(Colors) > 0);\r\n  Count := Length(Colors);\r\n  GdipCheck(GdipSetPathGradientSurroundColorsWithCount(FNativeHandle,\r\n    @Colors[0], Count));\r\nend;\r\n\r\nprocedure TGPPathGradientBrush.SetSurroundColorsInternal(const Value: IGPColors);\r\nvar\r\n  Count: Integer;\r\nbegin\r\n  Assert(Assigned(Value));\r\n  Count := Value.Count;\r\n  GdipCheck(GdipSetPathGradientSurroundColorsWithCount(FNativeHandle,\r\n    Value.ItemPtr, Count));\r\n  Value.Count := Count;\r\nend;\r\n\r\nprocedure TGPPathGradientBrush.SetTransform(const Value: IGPMatrix);\r\nbegin\r\n  GdipCheck(GdipSetPathGradientTransform(FNativeHandle, Value.NativeHandle));\r\nend;\r\n\r\nprocedure TGPPathGradientBrush.SetWrapMode(const Value: TGPWrapMode);\r\nbegin\r\n  GdipCheck(GdipSetPathGradientWrapMode(FNativeHandle, Value));\r\nend;\r\n\r\nprocedure TGPPathGradientBrush.TranslateTransform(const DX, DY: Single;\r\n  const Order: TGPMatrixOrder);\r\nbegin\r\n  GdipCheck(GdipTranslatePathGradientTransform(FNativeHandle, DX, DY, Order));\r\nend;\r\n{$ENDREGION 'GdiplusPath.h'}\r\n\r\n{$REGION 'GdiplusGraphics.h'}\r\n\r\n{ TGPGraphics }\r\n\r\nprocedure TGPGraphics.AddMetafileComment(const Data: array of Byte);\r\nbegin\r\n  Assert(Length(Data) > 0);\r\n  GdipCheck(GdipComment(FNativeHandle, Length(Data), @Data[0]));\r\nend;\r\n\r\nfunction TGPGraphics.BeginContainer: TGPGraphicsContainer;\r\nbegin\r\n  GdipCheck(GdipBeginContainer2(FNativeHandle, Result));\r\nend;\r\n\r\nfunction TGPGraphics.BeginContainer(const DstRect, SrcRect: TGPRect;\r\n  const MeasureUnit: TGPUnit): TGPGraphicsContainer;\r\nbegin\r\n  GdipCheck(GdipBeginContainerI(FNativeHandle, @DstRect, @SrcRect, MeasureUnit, Result));\r\nend;\r\n\r\nfunction TGPGraphics.BeginContainer(const DstRect, SrcRect: TGPRectF;\r\n  const MeasureUnit: TGPUnit): TGPGraphicsContainer;\r\nbegin\r\n  GdipCheck(GdipBeginContainer(FNativeHandle, @DstRect, @SrcRect, MeasureUnit, Result));\r\nend;\r\n\r\nprocedure TGPGraphics.Clear(const Color: TGPColor);\r\nbegin\r\n  GdipCheck(GdipGraphicsClear(FNativeHandle, Color.Value));\r\nend;\r\n\r\nconstructor TGPGraphics.Create(const Image: IGPImage);\r\nbegin\r\n  inherited Create;\r\n  Assert(Assigned(Image));\r\n  GdipCheck(GdipGetImageGraphicsContext(Image.NativeHandle, FNativeHandle));\r\nend;\r\n\r\nconstructor TGPGraphics.Create(const DC: HDC);\r\nbegin\r\n  inherited Create;\r\n  GdipCheck(GdipCreateFromHDC(DC, FNativeHandle));\r\nend;\r\n\r\nconstructor TGPGraphics.Create(const DC: HDC; const Device: THandle);\r\nbegin\r\n  inherited Create;\r\n  GdipCheck(GdipCreateFromHDC2(DC, Device, FNativeHandle));\r\nend;\r\n\r\nconstructor TGPGraphics.Create(const Window: HWnd; const ICM: Boolean);\r\nbegin\r\n  inherited Create;\r\n  if (ICM) then\r\n    GdipCheck(GdipCreateFromHWNDICM(Window, FNativeHandle))\r\n  else\r\n    GdipCheck(GdipCreateFromHWND(Window, FNativeHandle));\r\nend;\r\n\r\ndestructor TGPGraphics.Destroy;\r\nbegin\r\n  GdipDeleteGraphics(FNativeHandle);\r\n  inherited;\r\nend;\r\n\r\nprocedure TGPGraphics.DrawArc(const Pen: IGPPen; const Rect: TGPRect;\r\n  const StartAngle, SweepAngle: Single);\r\nbegin\r\n  DrawArc(Pen, Rect.X, Rect.Y, Rect.Width, Rect.Height, StartAngle, SweepAngle);\r\nend;\r\n\r\nprocedure TGPGraphics.DrawArc(const Pen: IGPPen; const X, Y, Width, Height: Integer;\r\n  const StartAngle, SweepAngle: Single);\r\nbegin\r\n  GdipCheck(GdipDrawArcI(FNativeHandle, Pen.NativeHandle, X, Y, Width, Height,\r\n    StartAngle, SweepAngle));\r\nend;\r\n\r\nprocedure TGPGraphics.DrawArc(const Pen: IGPPen; const Rect: TGPRectF;\r\n  const StartAngle, SweepAngle: Single);\r\nbegin\r\n  DrawArc(Pen, Rect.X, Rect.Y, Rect.Width, Rect.Height, StartAngle, SweepAngle);\r\nend;\r\n\r\nprocedure TGPGraphics.DrawArc(const Pen: IGPPen; const X, Y, Width, Height,\r\n  StartAngle, SweepAngle: Single);\r\nbegin\r\n  GdipCheck(GdipDrawArc(FNativeHandle, Pen.NativeHandle, X, Y, Width, Height,\r\n    StartAngle, SweepAngle));\r\nend;\r\n\r\nprocedure TGPGraphics.DrawBezier(const Pen: IGPPen; const Pt1, Pt2, Pt3,\r\n  Pt4: TGPPoint);\r\nbegin\r\n  DrawBezier(Pen, Pt1.X, Pt1.Y, Pt2.X, Pt2.Y, Pt3.X, Pt3.Y, Pt4.X, Pt4.Y);\r\nend;\r\n\r\nprocedure TGPGraphics.DrawBezier(const Pen: IGPPen; const X1, Y1, X2, Y2, X3, Y3,\r\n  X4, Y4: Integer);\r\nbegin\r\n  GdipCheck(GdipDrawBezierI(FNativeHandle, Pen.NativeHandle, X1, Y1, X2, Y2,\r\n    X3, Y3, X4, Y4));\r\nend;\r\n\r\nprocedure TGPGraphics.DrawBezier(const Pen: IGPPen; const Pt1, Pt2, Pt3,\r\n  Pt4: TGPPointF);\r\nbegin\r\n  DrawBezier(Pen, Pt1.X, Pt1.Y, Pt2.X, Pt2.Y, Pt3.X, Pt3.Y, Pt4.X, Pt4.Y);\r\nend;\r\n\r\nprocedure TGPGraphics.DrawBezier(const Pen: IGPPen; const X1, Y1, X2, Y2, X3, Y3,\r\n  X4, Y4: Single);\r\nbegin\r\n  GdipCheck(GdipDrawBezier(FNativeHandle, Pen.NativeHandle, X1, Y1, X2, Y2,\r\n    X3, Y3, X4, Y4));\r\nend;\r\n\r\nprocedure TGPGraphics.DrawBeziers(const Pen: IGPPen; const Points: array of TGPPoint);\r\nbegin\r\n  Assert(Length(Points) > 0);\r\n  GdipCheck(GdipDrawBeziersI(FNativeHandle, Pen.NativeHandle, @Points[0], Length(Points)));\r\nend;\r\n\r\nprocedure TGPGraphics.DrawBeziers(const Pen: IGPPen;\r\n  const Points: array of TGPPointF);\r\nbegin\r\n  Assert(Length(Points) > 0);\r\n  GdipCheck(GdipDrawBeziers(FNativeHandle, Pen.NativeHandle, @Points[0], Length(Points)));\r\nend;\r\n\r\nprocedure TGPGraphics.DrawCachedBitmap(const CachedBitmap: IGPCachedBitmap; const X,\r\n  Y: Integer);\r\nbegin\r\n  GdipCheck(GdipDrawCachedBitmap(FNativeHandle, CachedBitmap.NativeHandle, X, Y));\r\nend;\r\n\r\nprocedure TGPGraphics.DrawClosedCurve(const Pen: IGPPen;\r\n  const Points: array of TGPPoint; const Tension: Single);\r\nbegin\r\n  Assert(Length(Points) > 0);\r\n  GdipCheck(GdipDrawClosedCurve2I(FNativeHandle, Pen.NativeHandle, @Points[0],\r\n    Length(Points), Tension));\r\nend;\r\n\r\nprocedure TGPGraphics.DrawClosedCurve(const Pen: IGPPen;\r\n  const Points: array of TGPPointF);\r\nbegin\r\n  Assert(Length(Points) > 0);\r\n  GdipCheck(GdipDrawClosedCurve(FNativeHandle, Pen.NativeHandle, @Points[0],\r\n    Length(Points)));\r\nend;\r\n\r\nprocedure TGPGraphics.DrawClosedCurve(const Pen: IGPPen;\r\n  const Points: array of TGPPointF; const Tension: Single);\r\nbegin\r\n  Assert(Length(Points) > 0);\r\n  GdipCheck(GdipDrawClosedCurve2(FNativeHandle, Pen.NativeHandle, @Points[0],\r\n    Length(Points), Tension));\r\nend;\r\n\r\nprocedure TGPGraphics.DrawClosedCurve(const Pen: IGPPen;\r\n  const Points: array of TGPPoint);\r\nbegin\r\n  Assert(Length(Points) > 0);\r\n  GdipCheck(GdipDrawClosedCurveI(FNativeHandle, Pen.NativeHandle, @Points[0],\r\n    Length(Points)));\r\nend;\r\n\r\nprocedure TGPGraphics.DrawCurve(const Pen: IGPPen; const Points: array of TGPPointF;\r\n  const Offset, NumberOfSegments: Integer; const Tension: Single);\r\nbegin\r\n  Assert(Length(Points) > 0);\r\n  GdipCheck(GdipDrawCurve3(FNativeHandle, Pen.NativeHandle, @Points[0],\r\n    Length(Points), Offset, NumberOfSegments, Tension));\r\nend;\r\n\r\nprocedure TGPGraphics.DrawCurve(const Pen: IGPPen; const Points: array of TGPPointF;\r\n  const Tension: Single);\r\nbegin\r\n  Assert(Length(Points) > 0);\r\n  GdipCheck(GdipDrawCurve2(FNativeHandle, Pen.NativeHandle, @Points[0],\r\n    Length(Points), Tension));\r\nend;\r\n\r\nprocedure TGPGraphics.DrawCurve(const Pen: IGPPen; const Points: array of TGPPointF);\r\nbegin\r\n  Assert(Length(Points) > 0);\r\n  GdipCheck(GdipDrawCurve(FNativeHandle, Pen.NativeHandle, @Points[0], Length(Points)));\r\nend;\r\n\r\nprocedure TGPGraphics.DrawCurve(const Pen: IGPPen; const Points: array of TGPPoint;\r\n  const Offset, NumberOfSegments: Integer; const Tension: Single);\r\nbegin\r\n  Assert(Length(Points) > 0);\r\n  GdipCheck(GdipDrawCurve3I(FNativeHandle, Pen.NativeHandle, @Points[0],\r\n    Length(Points), Offset, NumberOfSegments, Tension));\r\nend;\r\n\r\nprocedure TGPGraphics.DrawCurve(const Pen: IGPPen; const Points: array of TGPPoint;\r\n  const Tension: Single);\r\nbegin\r\n  Assert(Length(Points) > 0);\r\n  GdipCheck(GdipDrawCurve2I(FNativeHandle, Pen.NativeHandle, @Points[0],\r\n    Length(Points), Tension));\r\nend;\r\n\r\nprocedure TGPGraphics.DrawCurve(const Pen: IGPPen; const Points: array of TGPPoint);\r\nbegin\r\n  Assert(Length(Points) > 0);\r\n  GdipCheck(GdipDrawCurveI(FNativeHandle, Pen.NativeHandle, @Points[0], Length(Points)));\r\nend;\r\n\r\nprocedure TGPGraphics.DrawDriverString(const Text: PUInt16; const Length: Integer;\r\n  const Font: IGPFont; const Brush: IGPBrush; const Positions: PGPPointF;\r\n  const Flags: TGPDriverStringOptions; const Matrix: IGPMatrix);\r\nbegin\r\n  GdipCheck(GdipDrawDriverString(FNativeHandle, Text, Length, GdipHandle(Font),\r\n    GdipHandle(Brush), Positions, Flags, GdipHandle(Matrix)));\r\nend;\r\n\r\nprocedure TGPGraphics.DrawEllipse(const Pen: IGPPen; const X, Y, Width,\r\n  Height: Single);\r\nbegin\r\n  GdipCheck(GdipDrawEllipse(FNativeHandle, Pen.NativeHandle, X, Y, Width, Height));\r\nend;\r\n\r\nprocedure TGPGraphics.DrawEllipse(const Pen: IGPPen; const Rect: TGPRect);\r\nbegin\r\n  DrawEllipse(Pen, Rect.X, Rect.Y, Rect.Width, Rect.Height);\r\nend;\r\n\r\nprocedure TGPGraphics.DrawEllipse(const Pen: IGPPen; const X, Y, Width,\r\n  Height: Integer);\r\nbegin\r\n  GdipCheck(GdipDrawEllipseI(FNativeHandle, Pen.NativeHandle, X, Y, Width, Height));\r\nend;\r\n\r\nprocedure TGPGraphics.DrawEllipse(const Pen: IGPPen; const Rect: TGPRectF);\r\nbegin\r\n  DrawEllipse(Pen, Rect.X, Rect.Y, Rect.Width, Rect.Height);\r\nend;\r\n\r\nprocedure TGPGraphics.DrawImage(const Image: IGPImage; const X, Y, SrcX, SrcY,\r\n  SrcWidth, SrcHeight: Single; const SrcUnit: TGPUnit);\r\nbegin\r\n  GdipCheck(GdipDrawImagePointRect(FNativeHandle, GdipHandle(Image),\r\n    X, Y, SrcX, SrcY, SrcWidth, SrcHeight, SrcUnit));\r\nend;\r\n\r\nprocedure TGPGraphics.DrawImage(const Image: IGPImage; const DestRect: TGPRect;\r\n  const SrcX, SrcY, SrcWidth, SrcHeight: Integer; const SrcUnit: TGPUnit;\r\n  const ImageAttributes: IGPImageAttributes; const Callback: TGPDrawImageAbort;\r\n  const CallbackData: Pointer);\r\nbegin\r\n  GdipCheck(GdipDrawImageRectRectI(FNativeHandle, GdipHandle(Image),\r\n    DestRect.X, DestRect.Y, DestRect.Width, DestRect.Height,\r\n    SrcX, SrcY, SrcWidth, SrcHeight, SrcUnit, GdipHandle(ImageAttributes),\r\n    Callback, CallbackData));\r\nend;\r\n\r\nprocedure TGPGraphics.DrawImage(const Image: IGPImage; const DestPoints: TGPPlgPoints;\r\n  const SrcX, SrcY, SrcWidth, SrcHeight: Integer; const SrcUnit: TGPUnit;\r\n  const ImageAttributes: IGPImageAttributes; const Callback: TGPDrawImageAbort;\r\n  const CallbackData: Pointer);\r\nbegin\r\n  GdipCheck(GdipDrawImagePointsRectI(FNativeHandle, GdipHandle(Image),\r\n    @DestPoints, 3, SrcX, SrcY, SrcWidth, SrcHeight, SrcUnit,\r\n    GdipHandle(ImageAttributes), Callback, CallbackData));\r\nend;\r\n\r\nprocedure TGPGraphics.DrawImage(const Image: IGPImage; const DstX, DstY, DstWidth,\r\n  DstHeight, SrcX, SrcY, SrcWidth, SrcHeight: Single; const SrcUnit: TGPUnit;\r\n  const ImageAttributes: IGPImageAttributes; const Callback: TGPDrawImageAbort;\r\n  const CallbackData: Pointer);\r\nbegin\r\n  GdipCheck(GdipDrawImageRectRect(FNativeHandle, GdipHandle(Image),\r\n    DstX, DstY, DstWidth, DstHeight, SrcX, SrcY, SrcWidth, SrcHeight,\r\n    SrcUnit, GdipHandle(ImageAttributes), Callback, CallbackData));\r\nend;\r\n\r\nprocedure TGPGraphics.DrawImage(const Image: IGPImage; const DstX, DstY, DstWidth,\r\n  DstHeight, SrcX, SrcY, SrcWidth, SrcHeight: Integer; const SrcUnit: TGPUnit;\r\n  const ImageAttributes: IGPImageAttributes; const Callback: TGPDrawImageAbort;\r\n  const CallbackData: Pointer);\r\nbegin\r\n  GdipCheck(GdipDrawImageRectRectI(FNativeHandle, GdipHandle(Image),\r\n    DstX, DstY, DstWidth, DstHeight, SrcX, SrcY, SrcWidth, SrcHeight,\r\n    SrcUnit, GdipHandle(ImageAttributes), Callback, CallbackData));\r\nend;\r\n\r\nprocedure TGPGraphics.DrawImage(const Image: IGPImage; const Rect: TGPRect);\r\nbegin\r\n  DrawImage(Image, Rect.X, Rect.Y, Rect.Width, Rect.Height);\r\nend;\r\n\r\nprocedure TGPGraphics.DrawImage(const Image: IGPImage;\r\n  const DestPoints: TGPPlgPointsF; const SrcX, SrcY, SrcWidth,\r\n  SrcHeight: Single; const SrcUnit: TGPUnit;\r\n  const ImageAttributes: IGPImageAttributes; const Callback: TGPDrawImageAbort;\r\n  const CallbackData: Pointer);\r\nbegin\r\n  GdipCheck(GdipDrawImagePointsRect(FNativeHandle, GdipHandle(Image),\r\n    @DestPoints, 3, SrcX, SrcY, SrcWidth, SrcHeight, SrcUnit,\r\n    GdipHandle(ImageAttributes), Callback, CallbackData));\r\nend;\r\n\r\nprocedure TGPGraphics.DrawImage(const Image: IGPImage; const DestRect: TGPRectF;\r\n  const SrcX, SrcY, SrcWidth, SrcHeight: Single; const SrcUnit: TGPUnit;\r\n  const ImageAttributes: IGPImageAttributes; const Callback: TGPDrawImageAbort;\r\n  const CallbackData: Pointer);\r\nbegin\r\n  GdipCheck(GdipDrawImageRectRect(FNativeHandle, GdipHandle(Image),\r\n    DestRect.X, DestRect.Y, DestRect.Width, DestRect.Height,\r\n    SrcX, SrcY, SrcWidth, SrcHeight, SrcUnit, GdipHandle(ImageAttributes),\r\n    Callback, CallbackData));\r\nend;\r\n\r\nprocedure TGPGraphics.DrawImage(const Image: IGPImage; const X, Y, Width,\r\n  Height: Single);\r\nbegin\r\n  GdipCheck(GdipDrawImageRect(FNativeHandle, GdipHandle(Image), X, Y, Width, Height));\r\nend;\r\n\r\nprocedure TGPGraphics.DrawImage(const Image: IGPImage; const Point: TGPPoint);\r\nbegin\r\n  DrawImage(Image, Point.X, Point.Y);\r\nend;\r\n\r\nprocedure TGPGraphics.DrawImage(const Image: IGPImage; const X, Y: Integer);\r\nbegin\r\n  GdipCheck(GdipDrawImageI(FNativeHandle, GdipHandle(Image), X, Y));\r\nend;\r\n\r\nprocedure TGPGraphics.DrawImage(const Image: IGPImage; const Rect: TGPRectF);\r\nbegin\r\n  DrawImage(Image, Rect.X, Rect.Y, Rect.Width, Rect.Height);\r\nend;\r\n\r\nprocedure TGPGraphics.DrawImage(const Image: IGPImage; const X, Y, SrcX, SrcY,\r\n  SrcWidth, SrcHeight: Integer; const SrcUnit: TGPUnit);\r\nbegin\r\n  GdipCheck(GdipDrawImagePointRectI(FNativeHandle, GdipHandle(Image),\r\n    X, Y, SrcX, SrcY, SrcWidth, SrcHeight, SrcUnit));\r\nend;\r\n\r\nprocedure TGPGraphics.DrawImage(const Image: IGPImage; const Point: TGPPointF);\r\nbegin\r\n  DrawImage(Image, Point.X, Point.Y);\r\nend;\r\n\r\nprocedure TGPGraphics.DrawImage(const Image: IGPImage; const X, Y: Single);\r\nbegin\r\n  GdipCheck(GdipDrawImage(FNativeHandle, GdipHandle(Image), X, Y));\r\nend;\r\n\r\nprocedure TGPGraphics.DrawImage(const Image: IGPImage;\r\n  const DestPoints: TGPPlgPoints);\r\nbegin\r\n  GdipCheck(GdipDrawImagePointsI(FNativeHandle, GdipHandle(Image), @DestPoints[0], 3));\r\nend;\r\n\r\nprocedure TGPGraphics.DrawImage(const Image: IGPImage;\r\n  const DestPoints: TGPPlgPointsF);\r\nbegin\r\n  GdipCheck(GdipDrawImagePoints(FNativeHandle, GdipHandle(Image), @DestPoints[0], 3));\r\nend;\r\n\r\nprocedure TGPGraphics.DrawImage(const Image: IGPImage; const X, Y, Width,\r\n  Height: Integer);\r\nbegin\r\n  GdipCheck(GdipDrawImageRectI(FNativeHandle, GdipHandle(Image), X, Y, Width, Height));\r\nend;\r\n\r\n{$IF (GDIPVER >= $0110)}\r\nprocedure TGPGraphics.DrawImage(const Image: IGPImage; const DestRect,\r\n  SourceRect: TGPRectF; const SrcUnit: TGPUnit;\r\n  const ImageAttributes: IGPImageAttributes);\r\nbegin\r\n  GdipCheck(GdipDrawImageRectRect(FNativeHandle, Image.NativeHandle,\r\n    DestRect.X, DestRect.Y, DestRect.Width, DestRect.Height,\r\n    SourceRect.X, SourceRect.Y, SourceRect.Width, SourceRect.Height,\r\n    SrcUnit, GdipHandle(ImageAttributes), nil, nil));\r\nend;\r\n\r\nprocedure TGPGraphics.DrawImage(const Image: IGPImage; const SourceRect: TGPRectF;\r\n  const XForm: IGPMatrix; const Effect: IGPEffect;\r\n  const ImageAttributes: IGPImageAttributes; const SrcUnit: TGPUnit);\r\nbegin\r\n  GdipCheck(GdipDrawImageFX(FNativeHandle, Image.NativeHandle, @SourceRect,\r\n    GdipHandle(XForm), GdipHandle(Effect), GdipHandle(ImageAttributes), SrcUnit));\r\nend;\r\n{$IFEND}\r\n\r\nprocedure TGPGraphics.DrawLine(const Pen: IGPPen; const Pt1, Pt2: TGPPoint);\r\nbegin\r\n  DrawLine(Pen, Pt1.X, Pt1.Y, Pt2.X, Pt2.Y);\r\nend;\r\n\r\nprocedure TGPGraphics.DrawLine(const Pen: IGPPen; const X1, Y1, X2, Y2: Single);\r\nbegin\r\n  GdipCheck(GdipDrawLine(FNativeHandle, Pen.NativeHandle, X1, Y1, X2, Y2));\r\nend;\r\n\r\nprocedure TGPGraphics.DrawLine(const Pen: IGPPen; const Pt1, Pt2: TGPPointF);\r\nbegin\r\n  DrawLine(Pen, Pt1.X, Pt1.Y, Pt2.X, Pt2.Y);\r\nend;\r\n\r\nprocedure TGPGraphics.DrawLine(const Pen: IGPPen; const X1, Y1, X2, Y2: Integer);\r\nbegin\r\n  GdipCheck(GdipDrawLineI(FNativeHandle, Pen.NativeHandle, X1, Y1, X2, Y2));\r\nend;\r\n\r\nprocedure TGPGraphics.DrawLines(const Pen: IGPPen; const Points: array of TGPPoint);\r\nbegin\r\n  Assert(Length(Points) > 0);\r\n  GdipCheck(GdipDrawLinesI(FNativeHandle, Pen.NativeHandle, @Points[0], Length(Points)));\r\nend;\r\n\r\nprocedure TGPGraphics.DrawLines(const Pen: IGPPen; const Points: array of TGPPointF);\r\nbegin\r\n  Assert(Length(Points) > 0);\r\n  GdipCheck(GdipDrawLines(FNativeHandle, Pen.NativeHandle, @Points[0], Length(Points)));\r\nend;\r\n\r\nprocedure TGPGraphics.DrawPath(const Pen: IGPPen; const Path: IGPGraphicsPath);\r\nbegin\r\n  GdipCheck(GdipDrawPath(FNativeHandle, GdipHandle(Pen), GdipHandle(Path)));\r\nend;\r\n\r\nprocedure TGPGraphics.DrawPie(const Pen: IGPPen; const X, Y, Width, Height,\r\n  StartAngle, SweepAngle: Single);\r\nbegin\r\n  GdipCheck(GdipDrawPie(FNativeHandle, Pen.NativeHandle, X, Y, Width, Height,\r\n    StartAngle, SweepAngle));\r\nend;\r\n\r\nprocedure TGPGraphics.DrawPie(const Pen: IGPPen; const Rect: TGPRectF;\r\n  const StartAngle, SweepAngle: Single);\r\nbegin\r\n  DrawPie(Pen, Rect.X, Rect.Y, Rect.Width, Rect.Height, StartAngle, SweepAngle);\r\nend;\r\n\r\nprocedure TGPGraphics.DrawPie(const Pen: IGPPen; const X, Y, Width, Height: Integer;\r\n  const StartAngle, SweepAngle: Single);\r\nbegin\r\n  GdipCheck(GdipDrawPieI(FNativeHandle, Pen.NativeHandle, X, Y, Width, Height,\r\n    StartAngle, SweepAngle));\r\nend;\r\n\r\nprocedure TGPGraphics.DrawPie(const Pen: IGPPen; const Rect: TGPRect;\r\n  const StartAngle, SweepAngle: Single);\r\nbegin\r\n  DrawPie(Pen, Rect.X, Rect.Y, Rect.Width, Rect.Height, StartAngle, SweepAngle);\r\nend;\r\n\r\nprocedure TGPGraphics.DrawPolygon(const Pen: IGPPen; const Points: array of TGPPoint);\r\nbegin\r\n  Assert(Length(Points) > 0);\r\n  GdipCheck(GdipDrawPolygonI(FNativeHandle, Pen.NativeHandle, @Points[0], Length(Points)));\r\nend;\r\n\r\nprocedure TGPGraphics.DrawPolygon(const Pen: IGPPen;\r\n  const Points: array of TGPPointF);\r\nbegin\r\n  Assert(Length(Points) > 0);\r\n  GdipCheck(GdipDrawPolygon(FNativeHandle, Pen.NativeHandle, @Points[0], Length(Points)));\r\nend;\r\n\r\nprocedure TGPGraphics.DrawRectangle(const Pen: IGPPen; const Rect: TGPRectF);\r\nbegin\r\n  DrawRectangle(Pen, Rect.X, Rect.Y, Rect.Width, Rect.Height);\r\nend;\r\n\r\nprocedure TGPGraphics.DrawRectangle(const Pen: IGPPen; const Rect: TGPRect);\r\nbegin\r\n  DrawRectangle(Pen, Rect.X, Rect.Y, Rect.Width, Rect.Height);\r\nend;\r\n\r\nprocedure TGPGraphics.DrawRectangle(const Pen: IGPPen; const X, Y, Width,\r\n  Height: Single);\r\nbegin\r\n  GdipCheck(GdipDrawRectangle(FNativeHandle, Pen.NativeHandle, X, Y, Width, Height));\r\nend;\r\n\r\nprocedure TGPGraphics.DrawRectangle(const Pen: IGPPen; const X, Y, Width,\r\n  Height: Integer);\r\nbegin\r\n  GdipCheck(GdipDrawRectangleI(FNativeHandle, Pen.NativeHandle, X, Y, Width, Height));\r\nend;\r\n\r\nprocedure TGPGraphics.DrawRectangles(const Pen: IGPPen;\r\n  const Rects: array of TGPRect);\r\nbegin\r\n  Assert(Length(Rects) > 0);\r\n  GdipCheck(GdipDrawRectanglesI(FNativeHandle, Pen.NativeHandle, @Rects[0], Length(Rects)));\r\nend;\r\n\r\nprocedure TGPGraphics.DrawRectangles(const Pen: IGPPen;\r\n  const Rects: array of TGPRectF);\r\nbegin\r\n  Assert(Length(Rects) > 0);\r\n  GdipCheck(GdipDrawRectangles(FNativeHandle, Pen.NativeHandle, @Rects[0], Length(Rects)));\r\nend;\r\n\r\nprocedure TGPGraphics.DrawString(const Str: String; const Font: IGPFont;\r\n  const Origin: TGPPointF; const Brush: IGPBrush);\r\nvar\r\n  Rect: TGPRectF;\r\nbegin\r\n  Rect.Initialize(Origin.X, Origin.Y, 0, 0);\r\n  GdipCheck(GdipDrawString(FNativeHandle, PWideChar(Str), Length(Str),\r\n    GdipHandle(Font), @Rect, nil, GdipHandle(Brush)));\r\nend;\r\n\r\nprocedure TGPGraphics.DrawString(const Str: String; const Font: IGPFont;\r\n  const Origin: TGPPointF; const Format: IGPStringFormat; const Brush: IGPBrush);\r\nvar\r\n  Rect: TGPRectF;\r\nbegin\r\n  Rect.Initialize(Origin.X, Origin.Y, 0, 0);\r\n  GdipCheck(GdipDrawString(FNativeHandle, PWideChar(Str), Length(Str),\r\n    GdipHandle(Font), @Rect, GdipHandle(Format), GdipHandle(Brush)));\r\nend;\r\n\r\nprocedure TGPGraphics.DrawString(const Str: String; const Font: IGPFont;\r\n  const LayoutRect: TGPRectF; const Format: IGPStringFormat; const Brush: IGPBrush);\r\nbegin\r\n  GdipCheck(GdipDrawString(FNativeHandle, PWideChar(Str), Length(Str),\r\n    GdipHandle(Font), @LayoutRect, GdipHandle(Format), GdipHandle(Brush)));\r\nend;\r\n\r\nprocedure TGPGraphics.EndContainer(const State: TGPGraphicsContainer);\r\nbegin\r\n  GdipCheck(GdipEndContainer(FNativeHandle, State));\r\nend;\r\n\r\nprocedure TGPGraphics.EnumerateMetafile(const Metafile: IGPMetafile; const DestRect,\r\n  SrcRect: TGPRectF; const SrcUnit: TGPUnit; const Callback: TGPEnumerateMetafileProc;\r\n  const CallbackData: Pointer; const ImageAttributes: IGPImageAttributes);\r\nbegin\r\n  GdipCheck(GdipEnumerateMetafileSrcRectDestRect(FNativeHandle,\r\n    GdipHandle(Metafile), @DestRect, @SrcRect, SrcUnit, Callback,\r\n    CallbackData, GdipHandle(ImageAttributes)));\r\nend;\r\n\r\nprocedure TGPGraphics.EnumerateMetafile(const Metafile: IGPMetafile;\r\n  const DestPoint: TGPPoint; const SrcRect: TGPRect; const SrcUnit: TGPUnit;\r\n  const Callback: TGPEnumerateMetafileProc; const CallbackData: Pointer;\r\n  const ImageAttributes: IGPImageAttributes);\r\nbegin\r\n  GdipCheck(GdipEnumerateMetafileSrcRectDestPointI(FNativeHandle,\r\n    GdipHandle(Metafile), @DestPoint, @SrcRect, SrcUnit, Callback,\r\n    CallbackData, GdipHandle(ImageAttributes)));\r\nend;\r\n\r\nprocedure TGPGraphics.EnumerateMetafile(const Metafile: IGPMetafile;\r\n  const DestPoint: TGPPointF; const SrcRect: TGPRectF; const SrcUnit: TGPUnit;\r\n  const Callback: TGPEnumerateMetafileProc; const CallbackData: Pointer;\r\n  const ImageAttributes: IGPImageAttributes);\r\nbegin\r\n  GdipCheck(GdipEnumerateMetafileSrcRectDestPoint(FNativeHandle,\r\n    GdipHandle(Metafile), @DestPoint, @SrcRect, SrcUnit, Callback,\r\n    CallbackData, GdipHandle(ImageAttributes)));\r\nend;\r\n\r\nprocedure TGPGraphics.EnumerateMetafile(const Metafile: IGPMetafile;\r\n  const DestPoints: TGPPlgPoints; const SrcRect: TGPRect; const SrcUnit: TGPUnit;\r\n  const Callback: TGPEnumerateMetafileProc; const CallbackData: Pointer;\r\n  const ImageAttributes: IGPImageAttributes);\r\nbegin\r\n  GdipCheck(GdipEnumerateMetafileSrcRectDestPointsI(FNativeHandle,\r\n    GdipHandle(Metafile), @DestPoints[0], 3, @SrcRect, SrcUnit, Callback,\r\n    CallbackData, GdipHandle(ImageAttributes)));\r\nend;\r\n\r\nprocedure TGPGraphics.EnumerateMetafile(const Metafile: IGPMetafile;\r\n  const DestPoints: TGPPlgPointsF; const SrcRect: TGPRectF; const SrcUnit: TGPUnit;\r\n  const Callback: TGPEnumerateMetafileProc; const CallbackData: Pointer;\r\n  const ImageAttributes: IGPImageAttributes);\r\nbegin\r\n  GdipCheck(GdipEnumerateMetafileSrcRectDestPoints(FNativeHandle,\r\n    GdipHandle(Metafile), @DestPoints[0], 3, @SrcRect, SrcUnit, Callback,\r\n    CallbackData, GdipHandle(ImageAttributes)));\r\nend;\r\n\r\nprocedure TGPGraphics.EnumerateMetafile(const Metafile: IGPMetafile; const DestRect,\r\n  SrcRect: TGPRect; const SrcUnit: TGPUnit; const Callback: TGPEnumerateMetafileProc;\r\n  const CallbackData: Pointer; const ImageAttributes: IGPImageAttributes);\r\nbegin\r\n  GdipCheck(GdipEnumerateMetafileSrcRectDestRectI(FNativeHandle,\r\n    GdipHandle(Metafile), @DestRect, @SrcRect, SrcUnit, Callback,\r\n    CallbackData, GdipHandle(ImageAttributes)));\r\nend;\r\n\r\nprocedure TGPGraphics.EnumerateMetafile(const Metafile: IGPMetafile;\r\n  const DestRect: TGPRectF; const Callback: TGPEnumerateMetafileProc;\r\n  const CallbackData: Pointer; const ImageAttributes: IGPImageAttributes);\r\nbegin\r\n  GdipCheck(GdipEnumerateMetafileDestRect(FNativeHandle, GdipHandle(Metafile),\r\n    @DestRect, Callback, CallbackData, GdipHandle(ImageAttributes)));\r\nend;\r\n\r\nprocedure TGPGraphics.EnumerateMetafile(const Metafile: IGPMetafile;\r\n  const DestPoint: TGPPoint; const Callback: TGPEnumerateMetafileProc;\r\n  const CallbackData: Pointer; const ImageAttributes: IGPImageAttributes);\r\nbegin\r\n  GdipCheck(GdipEnumerateMetafileDestPointI(FNativeHandle, GdipHandle(Metafile),\r\n    @DestPoint, Callback, CallbackData, GdipHandle(ImageAttributes)));\r\nend;\r\n\r\nprocedure TGPGraphics.EnumerateMetafile(const Metafile: IGPMetafile;\r\n  const DestPoint: TGPPointF; const Callback: TGPEnumerateMetafileProc;\r\n  const CallbackData: Pointer; const ImageAttributes: IGPImageAttributes);\r\nbegin\r\n  GdipCheck(GdipEnumerateMetafileDestPoint(FNativeHandle, GdipHandle(Metafile),\r\n    @DestPoint, Callback, CallbackData, GdipHandle(ImageAttributes)));\r\nend;\r\n\r\nprocedure TGPGraphics.EnumerateMetafile(const Metafile: IGPMetafile;\r\n  const DestPoints: TGPPlgPoints; const Callback: TGPEnumerateMetafileProc;\r\n  const CallbackData: Pointer; const ImageAttributes: IGPImageAttributes);\r\nbegin\r\n  GdipCheck(GdipEnumerateMetafileDestPointsI(FNativeHandle, GdipHandle(Metafile),\r\n    @DestPoints[0], 3, Callback, CallbackData, GdipHandle(ImageAttributes)));\r\nend;\r\n\r\nprocedure TGPGraphics.EnumerateMetafile(const Metafile: IGPMetafile;\r\n  const DestPoints: TGPPlgPointsF; const Callback: TGPEnumerateMetafileProc;\r\n  const CallbackData: Pointer; const ImageAttributes: IGPImageAttributes);\r\nbegin\r\n  GdipCheck(GdipEnumerateMetafileDestPoints(FNativeHandle, GdipHandle(Metafile),\r\n    @DestPoints[0], 3, Callback, CallbackData, GdipHandle(ImageAttributes)));\r\nend;\r\n\r\nprocedure TGPGraphics.EnumerateMetafile(const Metafile: IGPMetafile;\r\n  const DestRect: TGPRect; const Callback: TGPEnumerateMetafileProc;\r\n  const CallbackData: Pointer; const ImageAttributes: IGPImageAttributes);\r\nbegin\r\n  GdipCheck(GdipEnumerateMetafileDestRectI(FNativeHandle, GdipHandle(Metafile),\r\n    @DestRect, Callback, CallbackData, GdipHandle(ImageAttributes)));\r\nend;\r\n\r\nprocedure TGPGraphics.ExcludeClip(const Region: IGPRegion);\r\nbegin\r\n  GdipCheck(GdipSetClipRegion(FNativeHandle, Region.NativeHandle, CombineModeExclude));\r\nend;\r\n\r\nprocedure TGPGraphics.ExcludeClip(const Rect: TGPRect);\r\nbegin\r\n  GdipCheck(GdipSetClipRectI(FNativeHandle, Rect.X, Rect.Y, Rect.Width,\r\n    Rect.Height, CombineModeExclude));\r\nend;\r\n\r\nprocedure TGPGraphics.ExcludeClip(const Rect: TGPRectF);\r\nbegin\r\n  GdipCheck(GdipSetClipRect(FNativeHandle, Rect.X, Rect.Y, Rect.Width,\r\n    Rect.Height, CombineModeExclude));\r\nend;\r\n\r\nprocedure TGPGraphics.FillClosedCurve(const Brush: IGPBrush;\r\n  const Points: array of TGPPointF);\r\nbegin\r\n  Assert(Length(Points) > 0);\r\n  GdipCheck(GdipFillClosedCurve(FNativeHandle, Brush.NativeHandle, @Points[0],\r\n    Length(Points)));\r\nend;\r\n\r\nprocedure TGPGraphics.FillClosedCurve(const Brush: IGPBrush;\r\n  const Points: array of TGPPoint);\r\nbegin\r\n  Assert(Length(Points) > 0);\r\n  GdipCheck(GdipFillClosedCurveI(FNativeHandle, Brush.NativeHandle, @Points[0],\r\n    Length(Points)));\r\nend;\r\n\r\nprocedure TGPGraphics.FillClosedCurve(const Brush: IGPBrush;\r\n  const Points: array of TGPPoint; const FillMode: TGPFillMode;\r\n  const Tension: Single);\r\nbegin\r\n  Assert(Length(Points) > 0);\r\n  GdipCheck(GdipFillClosedCurve2I(FNativeHandle, Brush.NativeHandle, @Points[0],\r\n    Length(Points), Tension, FillMode));\r\nend;\r\n\r\nprocedure TGPGraphics.FillClosedCurve(const Brush: IGPBrush;\r\n  const Points: array of TGPPointF; const FillMode: TGPFillMode;\r\n  const Tension: Single);\r\nbegin\r\n  Assert(Length(Points) > 0);\r\n  GdipCheck(GdipFillClosedCurve2(FNativeHandle, Brush.NativeHandle, @Points[0],\r\n    Length(Points), Tension, FillMode));\r\nend;\r\n\r\nprocedure TGPGraphics.FillEllipse(const Brush: IGPBrush; const Rect: TGPRect);\r\nbegin\r\n  FillEllipse(Brush, Rect.X, Rect.Y, Rect.Width, Rect.Height);\r\nend;\r\n\r\nprocedure TGPGraphics.FillEllipse(const Brush: IGPBrush; const X, Y, Width,\r\n  Height: Integer);\r\nbegin\r\n  GdipCheck(GdipFillEllipseI(FNativeHandle, Brush.NativeHandle, X, Y, Width, Height));\r\nend;\r\n\r\nprocedure TGPGraphics.FillEllipse(const Brush: IGPBrush; const Rect: TGPRectF);\r\nbegin\r\n  FillEllipse(Brush, Rect.X, Rect.Y, Rect.Width, Rect.Height);\r\nend;\r\n\r\nprocedure TGPGraphics.FillEllipse(const Brush: IGPBrush; const X, Y, Width,\r\n  Height: Single);\r\nbegin\r\n  GdipCheck(GdipFillEllipse(FNativeHandle, Brush.NativeHandle, X, Y, Width, Height));\r\nend;\r\n\r\nprocedure TGPGraphics.FillPath(const Brush: IGPBrush;\r\n  const Path: IGPGraphicsPath);\r\nbegin\r\n  GdipCheck(GdipFillPath(FNativeHandle, Brush.NativeHandle, Path.NativeHandle));\r\nend;\r\n\r\nprocedure TGPGraphics.FillPie(const Brush: IGPBrush; const Rect: TGPRectF;\r\n  const StartAngle, SweepAngle: Single);\r\nbegin\r\n  FillPie(Brush, Rect.X, Rect.Y, Rect.Width, Rect.Height, StartAngle, SweepAngle);\r\nend;\r\n\r\nprocedure TGPGraphics.FillPie(const Brush: IGPBrush; const X, Y, Width,\r\n  Height: Integer; const StartAngle, SweepAngle: Single);\r\nbegin\r\n  GdipCheck(GdipFillPieI(FNativeHandle, Brush.NativeHandle, X, Y, Width, Height,\r\n    StartAngle, SweepAngle));\r\nend;\r\n\r\nprocedure TGPGraphics.FillPie(const Brush: IGPBrush; const Rect: TGPRect;\r\n  const StartAngle, SweepAngle: Single);\r\nbegin\r\n  FillPie(Brush, Rect.X, Rect.Y, Rect.Width, Rect.Height, StartAngle, SweepAngle);\r\nend;\r\n\r\nprocedure TGPGraphics.FillPie(const Brush: IGPBrush; const X, Y, Width, Height,\r\n  StartAngle, SweepAngle: Single);\r\nbegin\r\n  GdipCheck(GdipFillPie(FNativeHandle, Brush.NativeHandle, X, Y, Width, Height,\r\n    StartAngle, SweepAngle));\r\nend;\r\n\r\nprocedure TGPGraphics.FillPolygon(const Brush: IGPBrush;\r\n  const Points: array of TGPPoint);\r\nbegin\r\n  FillPolygon(Brush, Points, FillModeAlternate);\r\nend;\r\n\r\nprocedure TGPGraphics.FillPolygon(const Brush: IGPBrush;\r\n  const Points: array of TGPPointF; const FillMode: TGPFillMode);\r\nbegin\r\n  Assert(Length(Points) > 0);\r\n  GdipCheck(GdipFillPolygon(FNativeHandle, Brush.NativeHandle, @Points[0],\r\n    Length(Points), FillMode));\r\nend;\r\n\r\nprocedure TGPGraphics.FillPolygon(const Brush: IGPBrush;\r\n  const Points: array of TGPPoint; const FillMode: TGPFillMode);\r\nbegin\r\n  Assert(Length(Points) > 0);\r\n  GdipCheck(GdipFillPolygonI(FNativeHandle, Brush.NativeHandle, @Points[0],\r\n    Length(Points), FillMode));\r\nend;\r\n\r\nprocedure TGPGraphics.FillPolygon(const Brush: IGPBrush;\r\n  const Points: array of TGPPointF);\r\nbegin\r\n  FillPolygon(Brush, Points, FillModeAlternate);\r\nend;\r\n\r\nprocedure TGPGraphics.FillRectangle(const Brush: IGPBrush; const X, Y, Width,\r\n  Height: Integer);\r\nbegin\r\n  GdipCheck(GdipFillRectangleI(FNativeHandle, Brush.NativeHandle, X, Y, Width, Height));\r\nend;\r\n\r\nprocedure TGPGraphics.FillRectangle(const Brush: IGPBrush; const Rect: TGPRect);\r\nbegin\r\n  FillRectangle(Brush, Rect.X, Rect.Y, Rect.Width, Rect.Height);\r\nend;\r\n\r\nprocedure TGPGraphics.FillRectangle(const Brush: IGPBrush; const Rect: TGPRectF);\r\nbegin\r\n  FillRectangle(Brush, Rect.X, Rect.Y, Rect.Width, Rect.Height);\r\nend;\r\n\r\nprocedure TGPGraphics.FillRectangle(const Brush: IGPBrush; const X, Y, Width,\r\n  Height: Single);\r\nbegin\r\n  GdipCheck(GdipFillRectangle(FNativeHandle, Brush.NativeHandle, X, Y, Width, Height));\r\nend;\r\n\r\nprocedure TGPGraphics.FillRectangles(const Brush: IGPBrush;\r\n  const Rects: array of TGPRect);\r\nbegin\r\n  Assert(Length(Rects) > 0);\r\n  GdipCheck(GdipFillRectanglesI(FNativeHandle, Brush.NativeHandle, @Rects[0], Length(Rects)));\r\nend;\r\n\r\nprocedure TGPGraphics.FillRectangles(const Brush: IGPBrush;\r\n  const Rects: array of TGPRectF);\r\nbegin\r\n  Assert(Length(Rects) > 0);\r\n  GdipCheck(GdipFillRectangles(FNativeHandle, Brush.NativeHandle, @Rects[0], Length(Rects)));\r\nend;\r\n\r\nprocedure TGPGraphics.FillRegion(const Brush: IGPBrush; const Region: IGPRegion);\r\nbegin\r\n  GdipCheck(GdipFillRegion(FNativeHandle, Brush.NativeHandle, Region.NativeHandle));\r\nend;\r\n\r\nprocedure TGPGraphics.Flush(const Intention: TGPFlushIntention);\r\nbegin\r\n  GdipFlush(FNativeHandle, Intention);\r\nend;\r\n\r\nclass function TGPGraphics.FromHDC(const DC: HDC): IGPGraphics;\r\nbegin\r\n  Result := TGPGraphics.Create(DC);\r\nend;\r\n\r\nclass function TGPGraphics.FromHDC(const DC: HDC;\r\n  const Device: THandle): IGPGraphics;\r\nbegin\r\n  Result := TGPGraphics.Create(DC, Device);\r\nend;\r\n\r\nclass function TGPGraphics.FromHWnd(const Window: HWnd;\r\n  const ICM: Boolean): IGPGraphics;\r\nbegin\r\n  Result := TGPGraphics.Create(Window, ICM);\r\nend;\r\n\r\nclass function TGPGraphics.FromImage(const Image: IGPImage): IGPGraphics;\r\nbegin\r\n  Result := TGPGraphics.Create(Image);\r\nend;\r\n\r\nfunction TGPGraphics.GetClip: IGPRegion;\r\nbegin\r\n  Result := TGPRegion.Create;\r\n  GdipCheck(GdipGetClip(FNativeHandle, Result.NativeHandle));\r\nend;\r\n\r\nfunction TGPGraphics.GetClipBounds: TGPRectF;\r\nbegin\r\n  GdipCheck(GdipGetClipBounds(FNativeHandle, Result));\r\nend;\r\n\r\nfunction TGPGraphics.GetClipBoundsI: TGPRect;\r\nbegin\r\n  GdipCheck(GdipGetClipBoundsI(FNativeHandle, Result));\r\nend;\r\n\r\nfunction TGPGraphics.GetCompositingMode: TGPCompositingMode;\r\nbegin\r\n  GdipCheck(GdipGetCompositingMode(FNativeHandle, Result));\r\nend;\r\n\r\nfunction TGPGraphics.GetCompositingQuality: TGPCompositingQuality;\r\nbegin\r\n  GdipCheck(GdipGetCompositingQuality(FNativeHandle, Result));\r\nend;\r\n\r\nfunction TGPGraphics.GetDpiX: Single;\r\nbegin\r\n  GdipCheck(GdipGetDpiX(FNativeHandle, Result));\r\nend;\r\n\r\nfunction TGPGraphics.GetDpiY: Single;\r\nbegin\r\n  GdipCheck(GdipGetDpiY(FNativeHandle, Result));\r\nend;\r\n\r\nfunction TGPGraphics.GetHDC: HDC;\r\nbegin\r\n  Result := 0;\r\n  GdipCheck(GdipGetDC(FNativeHandle, Result));\r\nend;\r\n\r\nfunction TGPGraphics.GetInterpolationMode: TGPInterpolationMode;\r\nbegin\r\n  GdipCheck(GdipGetInterpolationMode(FNativeHandle, Result));\r\nend;\r\n\r\nfunction TGPGraphics.GetIsClipEmpty: Boolean;\r\nvar\r\n  B: Bool;\r\nbegin\r\n  B := False;\r\n  GdipCheck(GdipIsClipEmpty(FNativeHandle, B));\r\n  Result := B;\r\nend;\r\n\r\nfunction TGPGraphics.GetIsVisibleClipEmpty: Boolean;\r\nvar\r\n  B: Bool;\r\nbegin\r\n  B := False;\r\n  GdipCheck(GdipIsVisibleClipEmpty(FNativeHandle, B));\r\n  Result := B;\r\nend;\r\n\r\nfunction TGPGraphics.GetNearestColor(const Color: TGPColor): TGPColor;\r\nvar\r\n  C: ARGB;\r\nbegin\r\n  C := Color.Value;\r\n  GdipCheck(GdipGetNearestColor(FNativeHandle, @C));\r\n  Result.Value := C;\r\nend;\r\n\r\nfunction TGPGraphics.GetPageScale: Single;\r\nbegin\r\n  GdipCheck(GdipGetPageScale(FNativeHandle, Result));\r\nend;\r\n\r\nfunction TGPGraphics.GetPageUnit: TGPUnit;\r\nbegin\r\n  GdipCheck(GdipGetPageUnit(FNativeHandle, Result));\r\nend;\r\n\r\nfunction TGPGraphics.GetPixelOffsetMode: TGPPixelOffsetMode;\r\nbegin\r\n  GdipCheck(GdipGetPixelOffsetMode(FNativeHandle, Result));\r\nend;\r\n\r\nprocedure TGPGraphics.GetRenderingOrigin(out X, Y: Integer);\r\nbegin\r\n  GdipCheck(GdipGetRenderingOrigin(FNativeHandle, X, Y));\r\nend;\r\n\r\nfunction TGPGraphics.GetRenderingOrigin: TGPPoint;\r\nbegin\r\n  GdipCheck(GdipGetRenderingOrigin(FNativeHandle, Result.X, Result.Y));\r\nend;\r\n\r\nfunction TGPGraphics.GetSmoothingMode: TGPSmoothingMode;\r\nbegin\r\n  GdipCheck(GdipGetSmoothingMode(FNativeHandle, Result));\r\nend;\r\n\r\nfunction TGPGraphics.GetTextContrast: Integer;\r\nbegin\r\n  GdipCheck(GdipGetTextContrast(FNativeHandle, Result));\r\nend;\r\n\r\nfunction TGPGraphics.GetTextRenderingHint: TGPTextRenderingHint;\r\nbegin\r\n  GdipCheck(GdipGetTextRenderingHint(FNativeHandle, Result));\r\nend;\r\n\r\nfunction TGPGraphics.GetTransform: IGPMatrix;\r\nbegin\r\n  Result := TGPMatrix.Create;\r\n  GdipCheck(GdipGetWorldTransform(FNativeHandle, Result.NativeHandle));\r\nend;\r\n\r\nfunction TGPGraphics.GetVisibleClipBounds: TGPRectF;\r\nbegin\r\n GdipCheck(GdipGetVisibleClipBounds(FNativeHandle, Result));\r\nend;\r\n\r\nfunction TGPGraphics.GetVisibleClipBoundsI: TGPRect;\r\nbegin\r\n GdipCheck(GdipGetVisibleClipBoundsI(FNativeHandle, Result));\r\nend;\r\n\r\nprocedure TGPGraphics.IntersectClip(const Rect: TGPRectF);\r\nbegin\r\n  GdipCheck(GdipSetClipRect(FNativeHandle, Rect.X, Rect.Y, Rect.Width,\r\n    Rect.Height, CombineModeIntersect));\r\nend;\r\n\r\nprocedure TGPGraphics.IntersectClip(const Rect: TGPRect);\r\nbegin\r\n  GdipCheck(GdipSetClipRectI(FNativeHandle, Rect.X, Rect.Y, Rect.Width,\r\n    Rect.Height, CombineModeIntersect));\r\nend;\r\n\r\nprocedure TGPGraphics.IntersectClip(const Region: IGPRegion);\r\nbegin\r\n  GdipCheck(GdipSetClipRegion(FNativeHandle, Region.NativeHandle, CombineModeIntersect));\r\nend;\r\n\r\nfunction TGPGraphics.IsVisible(const Rect: TGPRect): Boolean;\r\nbegin\r\n  Result := IsVisible(Rect.X, Rect.Y, Rect.Width, Rect.Height);\r\nend;\r\n\r\nfunction TGPGraphics.IsVisible(const Rect: TGPRectF): Boolean;\r\nbegin\r\n  Result := IsVisible(Rect.X, Rect.Y, Rect.Width, Rect.Height);\r\nend;\r\n\r\nfunction TGPGraphics.IsVisible(const X, Y, Width, Height: Integer): Boolean;\r\nvar\r\n  B: Bool;\r\nbegin\r\n  B := False;\r\n  GdipCheck(GdipIsVisibleRectI(FNativeHandle, X, Y, Width, Height, B));\r\n  Result := B;\r\nend;\r\n\r\nfunction TGPGraphics.IsVisible(const X, Y: Integer): Boolean;\r\nvar\r\n  B: Bool;\r\nbegin\r\n  B := False;\r\n  GdipCheck(GdipIsVisiblePointI(FNativeHandle, X, Y, B));\r\n  Result := B;\r\nend;\r\n\r\nfunction TGPGraphics.IsVisible(const Point: TGPPoint): Boolean;\r\nbegin\r\n  Result := IsVisible(Point.X, Point.Y);\r\nend;\r\n\r\nfunction TGPGraphics.IsVisible(const X, Y, Width, Height: Single): Boolean;\r\nvar\r\n  B: Bool;\r\nbegin\r\n  B := False;\r\n  GdipCheck(GdipIsVisibleRect(FNativeHandle, X, Y, Width, Height, B));\r\n  Result := B;\r\nend;\r\n\r\nfunction TGPGraphics.IsVisible(const Point: TGPPointF): Boolean;\r\nbegin\r\n  Result := IsVisible(Point.X, Point.Y);\r\nend;\r\n\r\nfunction TGPGraphics.IsVisible(const X, Y: Single): Boolean;\r\nvar\r\n  B: Bool;\r\nbegin\r\n  B := False;\r\n  GdipCheck(GdipIsVisiblePoint(FNativeHandle, X, Y, B));\r\n  Result := B;\r\nend;\r\n\r\nfunction TGPGraphics.MeasureCharacterRanges(const Str: String; const Font: IGPFont;\r\n  const LayoutRect: TGPRectF; const Format: IGPStringFormat): IGPRegions;\r\nvar\r\n  I, Count: Integer;\r\n  NativeRegions: array of GpRegion;\r\nbegin\r\n  if (Format = nil) then\r\n    GdipCheck(InvalidParameter);\r\n  Count := Format.MeasurableCharacterRangeCount;\r\n  SetLength(NativeRegions, Count);\r\n  Result := TGPArray.Create(Count);\r\n  for I := 0 to Count - 1 do\r\n  begin\r\n    Result[I] := TGPRegion.Create;\r\n    NativeRegions[I] := Result[I].NativeHandle;\r\n  end;\r\n  GdipCheck(GdipMeasureCharacterRanges(FNativeHandle, PWideChar(Str),\r\n    Length(Str), GdipHandle(Font), @LayoutRect, Format.NativeHandle,\r\n    Count, @NativeRegions[0]));\r\nend;\r\n\r\nfunction TGPGraphics.MeasureDriverString(const Text: PUInt16;\r\n  const Length: Integer; const Font: IGPFont; const Positions: PGPPointF;\r\n  const Flags: TGPDriverStringOptions; const Matrix: IGPMatrix): TGPRectF;\r\nbegin\r\n  GdipCheck(GdipMeasureDriverString(FNativeHandle, Text, Length,\r\n    GdipHandle(Font), Positions, Flags, GdipHandle(Matrix),\r\n    Result));\r\nend;\r\n\r\nfunction TGPGraphics.MeasureString(const Str: String; const Font: IGPFont;\r\n  const LayoutRect: TGPRectF; const Format: IGPStringFormat): TGPRectF;\r\nvar\r\n  CodepointsFitted, LinesFilled: Integer;\r\nbegin\r\n  Result :=  MeasureString(Str, Font, LayoutRect, Format, CodepointsFitted, LinesFilled);\r\nend;\r\n\r\nfunction TGPGraphics.MeasureString(const Str: String; const Font: IGPFont;\r\n  const LayoutRect: TGPRectF; const Format: IGPStringFormat; out CodepointsFitted,\r\n  LinesFilled: Integer): TGPRectF;\r\nbegin\r\n  GdipCheck(GdipMeasureString(FNativeHandle, PWideChar(Str), Length(Str),\r\n    GdipHandle(Font), @LayoutRect, GdipHandle(Format), Result,\r\n    @CodepointsFitted, @LinesFilled));\r\nend;\r\n\r\nfunction TGPGraphics.MeasureString(const Str: String; const Font: IGPFont;\r\n  const LayoutRect: TGPRectF): TGPRectF;\r\nbegin\r\n  GdipCheck(GdipMeasureString(FNativeHandle, PWideChar(Str), Length(Str),\r\n    GdipHandle(Font), @LayoutRect, nil, Result, nil, nil));\r\nend;\r\n\r\nfunction TGPGraphics.MeasureString(const Str: String; const Font: IGPFont;\r\n  const Origin: TGPPointF): TGPRectF;\r\nvar\r\n  Rect: TGPRectF;\r\nbegin\r\n  Rect.Initialize(Origin.X, Origin.Y, 0, 0);\r\n  GdipCheck(GdipMeasureString(FNativeHandle, PWideChar(Str), Length(Str),\r\n    GdipHandle(Font), @Rect, nil, Result, nil, nil));\r\nend;\r\n\r\nfunction TGPGraphics.MeasureString(const Str: String; const Font: IGPFont;\r\n  const Origin: TGPPointF; const Format: IGPStringFormat): TGPRectF;\r\nvar\r\n  Rect: TGPRectF;\r\nbegin\r\n  Rect.Initialize(Origin.X, Origin.Y, 0, 0);\r\n  GdipCheck(GdipMeasureString(FNativeHandle, PWideChar(Str), Length(Str),\r\n    GdipHandle(Font), @Rect, GdipHandle(Format), Result, nil, nil));\r\nend;\r\n\r\nfunction TGPGraphics.MeasureString(const Str: String; const Font: IGPFont;\r\n  const LayoutRectSize: TGPSizeF; const Format: IGPStringFormat): TGPSizeF;\r\nvar\r\n  CodepointsFitted, LinesFilled: Integer;\r\nbegin\r\n  Result := MeasureString(Str, Font, LayoutRectSize, Format, CodepointsFitted, LinesFilled);\r\nend;\r\n\r\nfunction TGPGraphics.MeasureString(const Str: String; const Font: IGPFont;\r\n  const LayoutRectSize: TGPSizeF; const Format: IGPStringFormat;\r\n  out CodepointsFitted, LinesFilled: Integer): TGPSizeF;\r\nvar\r\n  LayoutRect, BoundingBox: TGPRectF;\r\nbegin\r\n  LayoutRect.Initialize(0, 0, LayoutRectSize.Width, LayoutRectSize.Height);\r\n  GdipCheck(GdipMeasureString(FNativeHandle, PWideChar(Str), Length(Str),\r\n    GdipHandle(Font), @LayoutRect, GdipHandle(Format), BoundingBox,\r\n    @CodepointsFitted, @LinesFilled));\r\n  Result.Width := BoundingBox.Width;\r\n  Result.Height := BoundingBox.Height;\r\nend;\r\n\r\nprocedure TGPGraphics.MultiplyTransform(const Matrix: IGPMatrix;\r\n  const Order: TGPMatrixOrder);\r\nbegin\r\n  GdipCheck(GdipMultiplyWorldTransform(FNativeHandle, Matrix.NativeHandle, Order));\r\nend;\r\n\r\nprocedure TGPGraphics.ReleaseHDC(const DC: HDC);\r\nbegin\r\n  GdipCheck(GdipReleaseDC(FNativeHandle, DC));\r\nend;\r\n\r\nprocedure TGPGraphics.ResetClip;\r\nbegin\r\n  GdipCheck(GdipResetClip(FNativeHandle));\r\nend;\r\n\r\nprocedure TGPGraphics.ResetTransform;\r\nbegin\r\n  GdipCheck(GdipResetWorldTransform(FNativeHandle));\r\nend;\r\n\r\nprocedure TGPGraphics.Restore(const State: TGPGraphicsState);\r\nbegin\r\n  GdipCheck(GdipRestoreGraphics(FNativeHandle, State));\r\nend;\r\n\r\nprocedure TGPGraphics.RotateTransform(const Angle: Single;\r\n  const Order: TGPMatrixOrder);\r\nbegin\r\n  GdipCheck(GdipRotateWorldTransform(FNativeHandle, Angle, Order));\r\nend;\r\n\r\nfunction TGPGraphics.Save: TGPGraphicsState;\r\nbegin\r\n  GdipCheck(GdipSaveGraphics(FNativeHandle, Result));\r\nend;\r\n\r\nprocedure TGPGraphics.ScaleTransform(const SX, SY: Single;\r\n  const Order: TGPMatrixOrder);\r\nbegin\r\n  GdipCheck(GdipScaleWorldTransform(FNativeHandle, SX, SY, Order));\r\nend;\r\n\r\n{$IF (GDIPVER >= $0110)}\r\nprocedure TGPGraphics.SetAbort(const IAbort: TGdiplusAbort);\r\nbegin\r\n  GdipCheck(GdipGraphicsSetAbort(FNativeHandle, @IAbort));\r\nend;\r\n{$IFEND}\r\n\r\nprocedure TGPGraphics.SetClip(const Rect: TGPRect; const CombineMode: TGPCombineMode);\r\nbegin\r\n  GdipCheck(GdipSetClipRectI(FNativeHandle, Rect.X, Rect.Y, Rect.Width,\r\n    Rect.Height, CombineMode));\r\nend;\r\n\r\nprocedure TGPGraphics.SetClip(const Path: IGPGraphicsPath;\r\n  const CombineMode: TGPCombineMode);\r\nbegin\r\n  GdipCheck(GdipSetClipPath(FNativeHandle, Path.NativeHandle, CombineMode));\r\nend;\r\n\r\nprocedure TGPGraphics.SetClip(const Region: HRgn;\r\n  const CombineMode: TGPCombineMode);\r\nbegin\r\n  GdipCheck(GdipSetClipHrgn(FNativeHandle, Region, CombineMode));\r\nend;\r\n\r\nprocedure TGPGraphics.SetClip(const G: IGPGraphics;\r\n  const CombineMode: TGPCombineMode);\r\nbegin\r\n  GdipCheck(GdipSetClipGraphics(FNativeHandle, G.NativeHandle, CombineMode));\r\nend;\r\n\r\nprocedure TGPGraphics.SetClip(const Region: IGPRegion;\r\n  const CombineMode: TGPCombineMode);\r\nbegin\r\n  GdipCheck(GdipSetClipRegion(FNativeHandle, Region.NativeHandle, CombineMode));\r\nend;\r\n\r\nprocedure TGPGraphics.SetClip(const Rect: TGPRectF;\r\n  const CombineMode: TGPCombineMode);\r\nbegin\r\n  GdipCheck(GdipSetClipRect(FNativeHandle, Rect.X, Rect.Y, Rect.Width,\r\n    Rect.Height, CombineMode));\r\nend;\r\n\r\nprocedure TGPGraphics.SetClipReplace(const Value: IGPRegion);\r\nbegin\r\n  GdipCheck(GdipSetClipRegion(FNativeHandle, Value.NativeHandle, CombineModeReplace));\r\nend;\r\n\r\nprocedure TGPGraphics.SetCompositingMode(const Value: TGPCompositingMode);\r\nbegin\r\n  GdipCheck(GdipSetCompositingMode(FNativeHandle, Value));\r\nend;\r\n\r\nprocedure TGPGraphics.SetCompositingQuality(const Value: TGPCompositingQuality);\r\nbegin\r\n  GdipCheck(GdipSetCompositingQuality(FNativeHandle, Value));\r\nend;\r\n\r\nprocedure TGPGraphics.SetInterpolationMode(const Value: TGPInterpolationMode);\r\nbegin\r\n  GdipCheck(GdipSetInterpolationMode(FNativeHandle, Value));\r\nend;\r\n\r\nprocedure TGPGraphics.SetPageScale(const Value: Single);\r\nbegin\r\n  GdipCheck(GdipSetPageScale(FNativeHandle, Value));\r\nend;\r\n\r\nprocedure TGPGraphics.SetPageUnit(const Value: TGPUnit);\r\nbegin\r\n  GdipCheck(GdipSetPageUnit(FNativeHandle, Value));\r\nend;\r\n\r\nprocedure TGPGraphics.SetPixelOffsetMode(const Value: TGPPixelOffsetMode);\r\nbegin\r\n  GdipCheck(GdipSetPixelOffsetMode(FNativeHandle, Value));\r\nend;\r\n\r\nprocedure TGPGraphics.SetRenderingOrigin(const Value: TGPPoint);\r\nbegin\r\n  GdipCheck(GdipSetRenderingOrigin(FNativeHandle, Value.X, Value.Y));\r\nend;\r\n\r\nprocedure TGPGraphics.SetRenderingOrigin(const X, Y: Integer);\r\nbegin\r\n  GdipCheck(GdipSetRenderingOrigin(FNativeHandle, X, Y));\r\nend;\r\n\r\nprocedure TGPGraphics.SetSmoothingMode(const Value: TGPSmoothingMode);\r\nbegin\r\n  GdipCheck(GdipSetSmoothingMode(FNativeHandle, Value));\r\nend;\r\n\r\nprocedure TGPGraphics.SetTextContrast(const Value: Integer);\r\nbegin\r\n  GdipCheck(GdipSetTextContrast(FNativeHandle, Value));\r\nend;\r\n\r\nprocedure TGPGraphics.SetTextRenderingHint(const Value: TGPTextRenderingHint);\r\nbegin\r\n  GdipCheck(GdipSetTextRenderingHint(FNativeHandle, Value));\r\nend;\r\n\r\nprocedure TGPGraphics.SetTransform(const Value: IGPMatrix);\r\nbegin\r\n  GdipCheck(GdipSetWorldTransform(FNativeHandle, Value.NativeHandle));\r\nend;\r\n\r\nprocedure TGPGraphics.TransformPoints(const DestSpace, SrcSpace: TGPCoordinateSpace;\r\n  const Points: array of TGPPoint);\r\nbegin\r\n  Assert(Length(Points) > 0);\r\n  GdipCheck(GdipTransformPointsI(FNativeHandle, DestSpace, SrcSpace,\r\n    @Points[0], Length(Points)));\r\nend;\r\n\r\nprocedure TGPGraphics.TransformPoints(const DestSpace, SrcSpace: TGPCoordinateSpace;\r\n  const Points: array of TGPPointF);\r\nbegin\r\n  Assert(Length(Points) > 0);\r\n  GdipCheck(GdipTransformPoints(FNativeHandle, DestSpace, SrcSpace,\r\n    @Points[0], Length(Points)));\r\nend;\r\n\r\nprocedure TGPGraphics.TranslateClip(const DX, DY: Integer);\r\nbegin\r\n  GdipCheck(GdipTranslateClipI(FNativeHandle, DX, DY));\r\nend;\r\n\r\nprocedure TGPGraphics.TranslateClip(const DX, DY: Single);\r\nbegin\r\n  GdipCheck(GdipTranslateClip(FNativeHandle, DX, DY));\r\nend;\r\n\r\nprocedure TGPGraphics.TranslateTransform(const DX, DY: Single;\r\n  const Order: TGPMatrixOrder);\r\nbegin\r\n  GdipCheck(GdipTranslateWorldTransform(FNativeHandle, DX, DY, Order));\r\nend;\r\n{$ENDREGION 'GdiplusGraphics.h'}\r\n\r\n{$REGION 'Initialization and Finalization'}\r\n\r\nvar\r\n  {$IF (GDIPVER >= $0110)}\r\n  StartupInput: TGdiplusStartupInputEx;\r\n  {$ELSE}\r\n  StartupInput: TGdiplusStartupInput;\r\n  {$IFEND}\r\n  GdiplusToken: ULONG;\r\n\r\nprocedure Initialize;\r\nbegin\r\n  TGPImageFormat.FInitialized := False;\r\n  StartupInput.Intialize;\r\n  GdiplusStartup(GdiplusToken, @StartupInput, nil);\r\nend;\r\n\r\nprocedure Finalize;\r\nbegin\r\n  GdiplusShutdown(GdiplusToken);\r\nend;\r\n\r\ninitialization\r\n  Initialize;\r\n\r\nfinalization\r\n  Finalize;\r\n{$ENDREGION 'Initialization and Finalization'}\r\n\r\nend.\r\n"
  },
  {
    "path": "GdiPlus/GdiPlusHelpers.pas",
    "content": "unit GdiPlusHelpers;\r\n\r\n{ Delphi GDI+ Library for use with Delphi 2009 or later.\r\n  Copyright (C) 2009 by Erik van Bilsen.\r\n  Email: erik@bilsen.com\r\n  Website: www.bilsen.com/gdiplus\r\n\r\nLicense in plain English:\r\n\r\n1. I don't promise that this software works. (But if you find any bugs,\r\n   please let me know!)\r\n2. You can use this software for whatever you want. You don't have to pay me.\r\n3. You may not pretend that you wrote this software. If you use it in a program,\r\n   you must acknowledge somewhere in your documentation that you've used this\r\n   code.\r\n\r\nIn legalese:\r\n\r\nThe author makes NO WARRANTY or representation, either express or implied,\r\nwith respect to this software, its quality, accuracy, merchantability, or\r\nfitness for a particular purpose.  This software is provided \"AS IS\", and you,\r\nits user, assume the entire risk as to its quality and accuracy.\r\n\r\nPermission is hereby granted to use, copy, modify, and distribute this\r\nsoftware (or portions thereof) for any purpose, without fee, subject to these\r\nconditions:\r\n(1) If any part of the source code for this software is distributed, then the\r\nLicense.txt file must be included, with this copyright and no-warranty notice\r\nunaltered; and any additions, deletions, or changes to the original files\r\nmust be clearly indicated in accompanying documentation.\r\n(2) If only executable code is distributed, then the accompanying\r\ndocumentation must state that \"this software is based in part on the Delphi\r\nGDI+ library by Erik van Bilsen\".\r\n(3) Permission for use of this software is granted only if the user accepts\r\nfull responsibility for any undesirable consequences; the author accepts\r\nNO LIABILITY for damages of any kind. }\r\n\r\ninterface\r\n\r\nuses\r\n  Windows,\r\n  Graphics,\r\n  Controls,\r\n  GdiPlus;\r\n\r\ntype\r\n  TGPCanvasHelper = class helper for TCanvas\r\n  public\r\n    function ToGPGraphics: IGPGraphics;\r\n  end;\r\n\r\ntype\r\n  TGPGraphicControlHelper = class helper for TGraphicControl\r\n  public\r\n    function ToGPGraphics: IGPGraphics;\r\n  end;\r\n\r\ntype\r\n  TGPCustomControlHelper = class helper for TCustomControl\r\n  public\r\n    function ToGPGraphics: IGPGraphics;\r\n  end;\r\n\r\ntype\r\n  TGPBitmapHelper = class helper for Graphics.TBitmap\r\n  public\r\n    function ToGPBitmap: IGPBitmap;\r\n    procedure FromGPBitmap(const GPBitmap: IGPBitmap);\r\n  end;\r\n\r\nimplementation\r\n\r\n{ TGPCanvasHelper }\r\n\r\nfunction TGPCanvasHelper.ToGPGraphics: IGPGraphics;\r\nbegin\r\n  Result := TGPGraphics.Create(Handle);\r\nend;\r\n\r\n{ TGPGraphicControlHelper }\r\n\r\nfunction TGPGraphicControlHelper.ToGPGraphics: IGPGraphics;\r\nbegin\r\n  Result := TGPGraphics.Create(Canvas.Handle);\r\nend;\r\n\r\n{ TGPCustomControlHelper }\r\n\r\nfunction TGPCustomControlHelper.ToGPGraphics: IGPGraphics;\r\nbegin\r\n  Result := TGPGraphics.Create(Canvas.Handle);\r\nend;\r\n\r\n{ TGPBitmapHelper }\r\n\r\nprocedure TGPBitmapHelper.FromGPBitmap(const GPBitmap: IGPBitmap);\r\nbegin\r\n  Handle := GPBitmap.GetHBitmap(0);\r\nend;\r\n\r\nfunction TGPBitmapHelper.ToGPBitmap: IGPBitmap;\r\nbegin\r\n  if (PixelFormat in [pf1Bit, pf4Bit, pf8Bit]) then\r\n    Result := TGPBitmap.Create(Handle, Palette)\r\n  else\r\n    Result := TGPBitmap.Create(Handle, 0);\r\nend;\r\n\r\nend.\r\n"
  },
  {
    "path": "JclPeImage.pas",
    "content": "{**************************************************************************************************}\r\n{                                                                                                  }\r\n{ Project JEDI Code Library (JCL)                                                                  }\r\n{                                                                                                  }\r\n{ The contents of this file are subject to the Mozilla Public License Version 1.1 (the \"License\"); }\r\n{ you may not use this file except in compliance with the License. You may obtain a copy of the    }\r\n{ License at http://www.mozilla.org/MPL/                                                           }\r\n{                                                                                                  }\r\n{ Software distributed under the License is distributed on an \"AS IS\" basis, WITHOUT WARRANTY OF   }\r\n{ ANY KIND, either express or implied. See the License for the specific language governing rights  }\r\n{ and limitations under the License.                                                               }\r\n{                                                                                                  }\r\n{ The Original Code is JclPeImage.pas.                                                             }\r\n{                                                                                                  }\r\n{ The Initial Developer of the Original Code is Petr Vones. Portions created by Petr Vones are     }\r\n{ Copyright (C) Petr Vones. All Rights Reserved.                                                   }\r\n{                                                                                                  }\r\n{ Contributor(s):                                                                                  }\r\n{   Marcel van Brakel                                                                              }\r\n{   Robert Marquardt (marquardt)                                                                   }\r\n{   Uwe Schuster (uschuster)                                                                       }\r\n{   Matthias Thoma (mthoma)                                                                        }\r\n{   Petr Vones (pvones)                                                                            }\r\n{   Hallvard Vassbotn                                                                              }\r\n{   Jean-Fabien Connault (cycocrew)                                                                }\r\n{                                                                                                  }\r\n{**************************************************************************************************}\r\n{                                                                                                  }\r\n{ This unit contains various classes and support routines to read the contents of portable         }\r\n{ executable (PE) files. You can use these classes to, for example examine the contents of the     }\r\n{ imports section of an executable. In addition the unit contains support for Borland specific     }\r\n{ structures and name unmangling.                                                                  }\r\n{                                                                                                  }\r\n{**************************************************************************************************}\r\n{                                                                                                  }\r\n{ Last modified: $Date:: 2013-05-13 21:15:06 +0200                                               $ }\r\n{ Revision:      $Rev:: 5a26dc1cafb60f4dcaf1e677a6fb03cc30db43b3                                 $ }\r\n{ Author:        $Author:: Andreas Hausladen                                                     $ }\r\n{                                                                                                  }\r\n{**************************************************************************************************}\r\n\r\nunit JclPeImage;\r\n\r\n{$I jcl.inc}\r\n{$I windowsonly.inc}\r\n\r\ninterface\r\n\r\nuses\r\n  {$IFDEF UNITVERSIONING}\r\n  JclUnitVersioning,\r\n  {$ENDIF UNITVERSIONING}\r\n  {$IFDEF HAS_UNITSCOPE}\r\n  Winapi.Windows, System.Classes, System.SysUtils, System.TypInfo, System.Contnrs,\r\n  {$ELSE ~HAS_UNITSCOPE}\r\n  Windows, Classes, SysUtils, TypInfo, Contnrs,\r\n  {$ENDIF ~HAS_UNITSCOPE}\r\n  JclBase, JclDateTime, JclFileUtils, JclWin32;\r\n\r\ntype\r\n  // Smart name compare function\r\n  TJclSmartCompOption = (scSimpleCompare, scIgnoreCase);\r\n  TJclSmartCompOptions = set of TJclSmartCompOption;\r\n\r\nfunction PeStripFunctionAW(const FunctionName: string): string;\r\n\r\nfunction PeSmartFunctionNameSame(const ComparedName, FunctionName: string;\r\n  Options: TJclSmartCompOptions = []): Boolean;\r\n\r\ntype\r\n  // Base list\r\n  EJclPeImageError = class(EJclError);\r\n\r\n  TJclPeImage = class;\r\n\r\n  TJclPeImageClass = class of TJclPeImage;\r\n\r\n  TJclPeImageBaseList = class(TObjectList)\r\n  private\r\n    FImage: TJclPeImage;\r\n  public\r\n    constructor Create(AImage: TJclPeImage);\r\n    property Image: TJclPeImage read FImage;\r\n  end;\r\n\r\n  // Images cache\r\n  TJclPeImagesCache = class(TObject)\r\n  private\r\n    FList: TStringList;\r\n    function GetCount: Integer;\r\n    function GetImages(const FileName: TFileName): TJclPeImage;\r\n  protected\r\n    function GetPeImageClass: TJclPeImageClass; virtual;\r\n  public\r\n    constructor Create;\r\n    destructor Destroy; override;\r\n    procedure Clear;\r\n    property Images[const FileName: TFileName]: TJclPeImage read GetImages; default;\r\n    property Count: Integer read GetCount;\r\n  end;\r\n\r\n  // Import section related classes\r\n  TJclPeImportSort = (isName, isOrdinal, isHint, isLibImport);\r\n  TJclPeImportLibSort = (ilName, ilIndex);\r\n  TJclPeImportKind = (ikImport, ikDelayImport, ikBoundImport);\r\n  TJclPeResolveCheck = (icNotChecked, icResolved, icUnresolved);\r\n  TJclPeLinkerProducer = (lrBorland, lrMicrosoft);\r\n  // lrBorland   -> Delphi PE files\r\n  // lrMicrosoft -> MSVC and BCB PE files\r\n\r\n  TJclPeImportLibItem = class;\r\n\r\n  // Created from a IMAGE_THUNK_DATA64 or IMAGE_THUNK_DATA32 record\r\n  TJclPeImportFuncItem = class(TObject)\r\n  private\r\n    FOrdinal: Word;  // word in 32/64\r\n    FHint: Word;\r\n    FImportLib: TJclPeImportLibItem;\r\n    FIndirectImportName: Boolean;\r\n    FName: string;\r\n    FResolveCheck: TJclPeResolveCheck;\r\n    function GetIsByOrdinal: Boolean;\r\n  protected\r\n    procedure SetName(const Value: string);\r\n    procedure SetIndirectImportName(const Value: string);\r\n    procedure SetResolveCheck(Value: TJclPeResolveCheck);\r\n  public\r\n    constructor Create(AImportLib: TJclPeImportLibItem; AOrdinal: Word;\r\n      AHint: Word; const AName: string);\r\n    property Ordinal: Word read FOrdinal;\r\n    property Hint: Word read FHint;\r\n    property ImportLib: TJclPeImportLibItem read FImportLib;\r\n    property IndirectImportName: Boolean read FIndirectImportName;\r\n    property IsByOrdinal: Boolean read GetIsByOrdinal;\r\n    property Name: string read FName;\r\n    property ResolveCheck: TJclPeResolveCheck read FResolveCheck;\r\n  end;\r\n\r\n  // Created from a IMAGE_IMPORT_DESCRIPTOR\r\n  TJclPeImportLibItem = class(TJclPeImageBaseList)\r\n  private\r\n    FImportDescriptor: Pointer;\r\n    FImportDirectoryIndex: Integer;\r\n    FImportKind: TJclPeImportKind;\r\n    FLastSortType: TJclPeImportSort;\r\n    FLastSortDescending: Boolean;\r\n    FName: string;\r\n    FSorted: Boolean;\r\n    FTotalResolveCheck: TJclPeResolveCheck;\r\n    FThunk: Pointer;\r\n    FThunkData: Pointer;\r\n    function GetCount: Integer;\r\n    function GetFileName: TFileName;\r\n    function GetItems(Index: Integer): TJclPeImportFuncItem;\r\n    function GetName: string;\r\n    function GetThunkData32: PImageThunkData32;\r\n    function GetThunkData64: PImageThunkData64;\r\n  protected\r\n    procedure CheckImports(ExportImage: TJclPeImage);\r\n    procedure CreateList;\r\n    procedure SetImportDirectoryIndex(Value: Integer);\r\n    procedure SetImportKind(Value: TJclPeImportKind);\r\n    procedure SetSorted(Value: Boolean);\r\n    procedure SetThunk(Value: Pointer);\r\n  public\r\n    constructor Create(AImage: TJclPeImage; AImportDescriptor: Pointer;\r\n      AImportKind: TJclPeImportKind; const AName: string; AThunk: Pointer);\r\n    procedure SortList(SortType: TJclPeImportSort; Descending: Boolean = False);\r\n    property Count: Integer read GetCount;\r\n    property FileName: TFileName read GetFileName;\r\n    property ImportDescriptor: Pointer read FImportDescriptor;\r\n    property ImportDirectoryIndex: Integer read FImportDirectoryIndex;\r\n    property ImportKind: TJclPeImportKind read FImportKind;\r\n    property Items[Index: Integer]: TJclPeImportFuncItem read GetItems; default;\r\n    property Name: string read GetName;\r\n    property OriginalName: string read FName;\r\n    // use the following properties\r\n    // property ThunkData: PImageThunkData\r\n    property ThunkData32: PImageThunkData32 read GetThunkData32;\r\n    property ThunkData64: PImageThunkData64 read GetThunkData64;\r\n    property TotalResolveCheck: TJclPeResolveCheck read FTotalResolveCheck;\r\n  end;\r\n\r\n  TJclPeImportList = class(TJclPeImageBaseList)\r\n  private\r\n    FAllItemsList: TList;\r\n    FFilterModuleName: string;\r\n    FLastAllSortType: TJclPeImportSort;\r\n    FLastAllSortDescending: Boolean;\r\n    FLinkerProducer: TJclPeLinkerProducer;\r\n    FParallelImportTable: array of Pointer;\r\n    FUniqueNamesList: TStringList;\r\n    function GetAllItemCount: Integer;\r\n    function GetAllItems(Index: Integer): TJclPeImportFuncItem;\r\n    function GetItems(Index: Integer): TJclPeImportLibItem;\r\n    function GetUniqueLibItemCount: Integer;\r\n    function GetUniqueLibItems(Index: Integer): TJclPeImportLibItem;\r\n    function GetUniqueLibNames(Index: Integer): string;\r\n    function GetUniqueLibItemFromName(const Name: string): TJclPeImportLibItem;\r\n    procedure SetFilterModuleName(const Value: string);\r\n  protected\r\n    procedure CreateList;\r\n    procedure RefreshAllItems;\r\n  public\r\n    constructor Create(AImage: TJclPeImage);\r\n    destructor Destroy; override;\r\n    procedure CheckImports(PeImageCache: TJclPeImagesCache = nil);\r\n    function MakeBorlandImportTableForMappedImage: Boolean;\r\n    function SmartFindName(const CompareName, LibName: string; Options: TJclSmartCompOptions = []): TJclPeImportFuncItem;\r\n    procedure SortAllItemsList(SortType: TJclPeImportSort; Descending: Boolean = False);\r\n    procedure SortList(SortType: TJclPeImportLibSort);\r\n    procedure TryGetNamesForOrdinalImports;\r\n    property AllItems[Index: Integer]: TJclPeImportFuncItem read GetAllItems;\r\n    property AllItemCount: Integer read GetAllItemCount;\r\n    property FilterModuleName: string read FFilterModuleName write SetFilterModuleName;\r\n    property Items[Index: Integer]: TJclPeImportLibItem read GetItems; default;\r\n    property LinkerProducer: TJclPeLinkerProducer read FLinkerProducer;\r\n    property UniqueLibItemCount: Integer read GetUniqueLibItemCount;\r\n    property UniqueLibItemFromName[const Name: string]: TJclPeImportLibItem read GetUniqueLibItemFromName;\r\n    property UniqueLibItems[Index: Integer]: TJclPeImportLibItem read GetUniqueLibItems;\r\n    property UniqueLibNames[Index: Integer]: string read GetUniqueLibNames;\r\n  end;\r\n\r\n  // Export section related classes\r\n  TJclPeExportSort = (esName, esOrdinal, esHint, esAddress, esForwarded,  esAddrOrFwd, esSection);\r\n\r\n  TJclPeExportFuncList = class;\r\n\r\n  // Created from a IMAGE_EXPORT_DIRECTORY\r\n  TJclPeExportFuncItem = class(TObject)\r\n  private\r\n    FAddress: DWORD;\r\n    FExportList: TJclPeExportFuncList;\r\n    FForwardedName: string;\r\n    FForwardedDotPos: string;\r\n    FHint: Word;\r\n    FName: string;\r\n    FOrdinal: Word;\r\n    FResolveCheck: TJclPeResolveCheck;\r\n    function GetAddressOrForwardStr: string;\r\n    function GetForwardedFuncName: string;\r\n    function GetForwardedLibName: string;\r\n    function GetForwardedFuncOrdinal: DWORD;\r\n    function GetIsExportedVariable: Boolean;\r\n    function GetIsForwarded: Boolean;\r\n    function GetSectionName: string;\r\n    function GetMappedAddress: Pointer;\r\n  protected\r\n    procedure SetResolveCheck(Value: TJclPeResolveCheck);\r\n  public\r\n    constructor Create(AExportList: TJclPeExportFuncList; const AName, AForwardedName: string;\r\n      AAddress: DWORD; AHint: Word; AOrdinal: Word; AResolveCheck: TJclPeResolveCheck);\r\n    property Address: DWORD read FAddress;\r\n    property AddressOrForwardStr: string read GetAddressOrForwardStr;\r\n    property IsExportedVariable: Boolean read GetIsExportedVariable;\r\n    property IsForwarded: Boolean read GetIsForwarded;\r\n    property ForwardedName: string read FForwardedName;\r\n    property ForwardedLibName: string read GetForwardedLibName;\r\n    property ForwardedFuncOrdinal: DWORD read GetForwardedFuncOrdinal;\r\n    property ForwardedFuncName: string read GetForwardedFuncName;\r\n    property Hint: Word read FHint;\r\n    property MappedAddress: Pointer read GetMappedAddress;\r\n    property Name: string read FName;\r\n    property Ordinal: Word read FOrdinal;\r\n    property ResolveCheck: TJclPeResolveCheck read FResolveCheck;\r\n    property SectionName: string read GetSectionName;\r\n  end;\r\n\r\n  TJclPeExportFuncList = class(TJclPeImageBaseList)\r\n  private\r\n    FAnyForwards: Boolean;\r\n    FBase: DWORD;\r\n    FExportDir: PImageExportDirectory;\r\n    FForwardedLibsList: TStringList;\r\n    FFunctionCount: DWORD;\r\n    FLastSortType: TJclPeExportSort;\r\n    FLastSortDescending: Boolean;\r\n    FSorted: Boolean;\r\n    FTotalResolveCheck: TJclPeResolveCheck;\r\n    function GetForwardedLibsList: TStrings;\r\n    function GetItems(Index: Integer): TJclPeExportFuncItem;\r\n    function GetItemFromAddress(Address: DWORD): TJclPeExportFuncItem;\r\n    function GetItemFromOrdinal(Ordinal: DWORD): TJclPeExportFuncItem;\r\n    function GetItemFromName(const Name: string): TJclPeExportFuncItem;\r\n    function GetName: string;\r\n  protected\r\n    function CanPerformFastNameSearch: Boolean;\r\n    procedure CreateList;\r\n    property LastSortType: TJclPeExportSort read FLastSortType;\r\n    property LastSortDescending: Boolean read FLastSortDescending;\r\n    property Sorted: Boolean read FSorted;\r\n  public\r\n    constructor Create(AImage: TJclPeImage);\r\n    destructor Destroy; override;\r\n    procedure CheckForwards(PeImageCache: TJclPeImagesCache = nil);\r\n    class function ItemName(Item: TJclPeExportFuncItem): string;\r\n    function OrdinalValid(Ordinal: DWORD): Boolean;\r\n    procedure PrepareForFastNameSearch;\r\n    function SmartFindName(const CompareName: string; Options: TJclSmartCompOptions = []): TJclPeExportFuncItem;\r\n    procedure SortList(SortType: TJclPeExportSort; Descending: Boolean = False);\r\n    property AnyForwards: Boolean read FAnyForwards;\r\n    property Base: DWORD read FBase;\r\n    property ExportDir: PImageExportDirectory read FExportDir;\r\n    property ForwardedLibsList: TStrings read GetForwardedLibsList;\r\n    property FunctionCount: DWORD read FFunctionCount;\r\n    property Items[Index: Integer]: TJclPeExportFuncItem read GetItems; default;\r\n    property ItemFromAddress[Address: DWORD]: TJclPeExportFuncItem read GetItemFromAddress;\r\n    property ItemFromName[const Name: string]: TJclPeExportFuncItem read GetItemFromName;\r\n    property ItemFromOrdinal[Ordinal: DWORD]: TJclPeExportFuncItem read GetItemFromOrdinal;\r\n    property Name: string read GetName;\r\n    property TotalResolveCheck: TJclPeResolveCheck read FTotalResolveCheck;\r\n  end;\r\n\r\n  // Resource section related classes\r\n  TJclPeResourceKind = (\r\n    rtUnknown0,\r\n    rtCursorEntry,\r\n    rtBitmap,\r\n    rtIconEntry,\r\n    rtMenu,\r\n    rtDialog,\r\n    rtString,\r\n    rtFontDir,\r\n    rtFont,\r\n    rtAccelerators,\r\n    rtRCData,\r\n    rtMessageTable,\r\n    rtCursor,\r\n    rtUnknown13,\r\n    rtIcon,\r\n    rtUnknown15,\r\n    rtVersion,\r\n    rtDlgInclude,\r\n    rtUnknown18,\r\n    rtPlugPlay,\r\n    rtVxd,\r\n    rtAniCursor,\r\n    rtAniIcon,\r\n    rtHmtl,\r\n    rtManifest,\r\n    rtUserDefined);\r\n\r\n  TJclPeResourceList = class;\r\n  TJclPeResourceItem = class;\r\n\r\n  TJclPeResourceRawStream = class(TCustomMemoryStream)\r\n  public\r\n    constructor Create(AResourceItem: TJclPeResourceItem);\r\n    function Write(const Buffer; Count: Longint): Longint; override;\r\n  end;\r\n\r\n  TJclPeResourceItem = class(TObject)\r\n  private\r\n    FEntry: PImageResourceDirectoryEntry;\r\n    FImage: TJclPeImage;\r\n    FList: TJclPeResourceList;\r\n    FLevel: Byte;\r\n    FParentItem: TJclPeResourceItem;\r\n    FNameCache: string;\r\n    function GetDataEntry: PImageResourceDataEntry;\r\n    function GetIsDirectory: Boolean;\r\n    function GetIsName: Boolean;\r\n    function GetLangID: LANGID;\r\n    function GetList: TJclPeResourceList;\r\n    function GetName: string;\r\n    function GetParameterName: string;\r\n    function GetRawEntryData: Pointer;\r\n    function GetRawEntryDataSize: Integer;\r\n    function GetResourceType: TJclPeResourceKind;\r\n    function GetResourceTypeStr: string;\r\n  protected\r\n    function OffsetToRawData(Ofs: DWORD): TJclAddr;\r\n    function Level1Item: TJclPeResourceItem;\r\n    function SubDirData: PImageResourceDirectory;\r\n  public\r\n    constructor Create(AImage: TJclPeImage; AParentItem: TJclPeResourceItem;\r\n      AEntry: PImageResourceDirectoryEntry);\r\n    destructor Destroy; override;\r\n    function CompareName(AName: PChar): Boolean;\r\n    property DataEntry: PImageResourceDataEntry read GetDataEntry;\r\n    property Entry: PImageResourceDirectoryEntry read FEntry;\r\n    property Image: TJclPeImage read FImage;\r\n    property IsDirectory: Boolean read GetIsDirectory;\r\n    property IsName: Boolean read GetIsName;\r\n    property LangID: LANGID read GetLangID;\r\n    property List: TJclPeResourceList read GetList;\r\n    property Level: Byte read FLevel;\r\n    property Name: string read GetName;\r\n    property ParameterName: string read GetParameterName;\r\n    property ParentItem: TJclPeResourceItem read FParentItem;\r\n    property RawEntryData: Pointer read GetRawEntryData;\r\n    property RawEntryDataSize: Integer read GetRawEntryDataSize;\r\n    property ResourceType: TJclPeResourceKind read GetResourceType;\r\n    property ResourceTypeStr: string read GetResourceTypeStr;\r\n  end;\r\n\r\n  TJclPeResourceList = class(TJclPeImageBaseList)\r\n  private\r\n    FDirectory: PImageResourceDirectory;\r\n    FParentItem: TJclPeResourceItem;\r\n    function GetItems(Index: Integer): TJclPeResourceItem;\r\n  protected\r\n    procedure CreateList(AParentItem: TJclPeResourceItem);\r\n  public\r\n    constructor Create(AImage: TJclPeImage; AParentItem: TJclPeResourceItem;\r\n      ADirectory: PImageResourceDirectory);\r\n    function FindName(const Name: string): TJclPeResourceItem;\r\n    property Directory: PImageResourceDirectory read FDirectory;\r\n    property Items[Index: Integer]: TJclPeResourceItem read GetItems; default;\r\n    property ParentItem: TJclPeResourceItem read FParentItem;\r\n  end;\r\n\r\n  TJclPeRootResourceList = class(TJclPeResourceList)\r\n  private\r\n    FManifestContent: TStringList;\r\n    function GetManifestContent: TStrings;\r\n  public\r\n    destructor Destroy; override;\r\n    function FindResource(ResourceType: TJclPeResourceKind;\r\n      const ResourceName: string = ''): TJclPeResourceItem; overload;\r\n    function FindResource(const ResourceType: PChar;\r\n      const ResourceName: PChar = nil): TJclPeResourceItem; overload;\r\n    function ListResourceNames(ResourceType: TJclPeResourceKind; const Strings: TStrings): Boolean;\r\n    property ManifestContent: TStrings read GetManifestContent;\r\n  end;\r\n\r\n  // Relocation section related classes\r\n  TJclPeRelocation = record\r\n    Address: Word;\r\n    RelocType: Byte;\r\n    VirtualAddress: DWORD;\r\n  end;\r\n\r\n  TJclPeRelocEntry = class(TObject)\r\n  private\r\n    FChunk: PImageBaseRelocation;\r\n    FCount: Integer;\r\n    function GetRelocations(Index: Integer): TJclPeRelocation;\r\n    function GetSize: DWORD;\r\n    function GetVirtualAddress: DWORD;\r\n  public\r\n    constructor Create(AChunk: PImageBaseRelocation; ACount: Integer);\r\n    property Count: Integer read FCount;\r\n    property Relocations[Index: Integer]: TJclPeRelocation read GetRelocations; default;\r\n    property Size: DWORD read GetSize;\r\n    property VirtualAddress: DWORD read GetVirtualAddress;\r\n  end;\r\n\r\n  TJclPeRelocList = class(TJclPeImageBaseList)\r\n  private\r\n    FAllItemCount: Integer;\r\n    function GetItems(Index: Integer): TJclPeRelocEntry;\r\n    function GetAllItems(Index: Integer): TJclPeRelocation;\r\n  protected\r\n    procedure CreateList;\r\n  public\r\n    constructor Create(AImage: TJclPeImage);\r\n    property AllItems[Index: Integer]: TJclPeRelocation read GetAllItems;\r\n    property AllItemCount: Integer read FAllItemCount;\r\n    property Items[Index: Integer]: TJclPeRelocEntry read GetItems; default;\r\n  end;\r\n\r\n  // Debug section related classes\r\n  TJclPeDebugList = class(TJclPeImageBaseList)\r\n  private\r\n    function GetItems(Index: Integer): TImageDebugDirectory;\r\n  protected\r\n    procedure CreateList;\r\n  public\r\n    constructor Create(AImage: TJclPeImage);\r\n    property Items[Index: Integer]: TImageDebugDirectory read GetItems; default;\r\n  end;\r\n\r\n  // Certificates section related classes\r\n  TJclPeCertificate = class(TObject)\r\n  private\r\n    FData: Pointer;\r\n    FHeader: TWinCertificate;\r\n  public\r\n    constructor Create(AHeader: TWinCertificate; AData: Pointer);\r\n    property Data: Pointer read FData;\r\n    property Header: TWinCertificate read FHeader;\r\n  end;\r\n\r\n  TJclPeCertificateList = class(TJclPeImageBaseList)\r\n  private\r\n    function GetItems(Index: Integer): TJclPeCertificate;\r\n  protected\r\n    procedure CreateList;\r\n  public\r\n    constructor Create(AImage: TJclPeImage);\r\n    property Items[Index: Integer]: TJclPeCertificate read GetItems; default;\r\n  end;\r\n\r\n  // Common Language Runtime section related classes\r\n  TJclPeCLRHeader = class(TObject)\r\n  private\r\n    FHeader: TImageCor20Header;\r\n    FImage: TJclPeImage;\r\n    function GetVersionString: string;\r\n    function GetHasMetadata: Boolean;\r\n  protected\r\n    procedure ReadHeader;\r\n  public\r\n    constructor Create(AImage: TJclPeImage);\r\n    property HasMetadata: Boolean read GetHasMetadata;\r\n    property Header: TImageCor20Header read FHeader;\r\n    property VersionString: string read GetVersionString;\r\n    property Image: TJclPeImage read FImage;\r\n  end;\r\n\r\n  // PE Image\r\n  TJclPeHeader = (\r\n    JclPeHeader_Signature,\r\n    JclPeHeader_Machine,\r\n    JclPeHeader_NumberOfSections,\r\n    JclPeHeader_TimeDateStamp,\r\n    JclPeHeader_PointerToSymbolTable,\r\n    JclPeHeader_NumberOfSymbols,\r\n    JclPeHeader_SizeOfOptionalHeader,\r\n    JclPeHeader_Characteristics,\r\n    JclPeHeader_Magic,\r\n    JclPeHeader_LinkerVersion,\r\n    JclPeHeader_SizeOfCode,\r\n    JclPeHeader_SizeOfInitializedData,\r\n    JclPeHeader_SizeOfUninitializedData,\r\n    JclPeHeader_AddressOfEntryPoint,\r\n    JclPeHeader_BaseOfCode,\r\n    JclPeHeader_BaseOfData,\r\n    JclPeHeader_ImageBase,\r\n    JclPeHeader_SectionAlignment,\r\n    JclPeHeader_FileAlignment,\r\n    JclPeHeader_OperatingSystemVersion,\r\n    JclPeHeader_ImageVersion,\r\n    JclPeHeader_SubsystemVersion,\r\n    JclPeHeader_Win32VersionValue,\r\n    JclPeHeader_SizeOfImage,\r\n    JclPeHeader_SizeOfHeaders,\r\n    JclPeHeader_CheckSum,\r\n    JclPeHeader_Subsystem,\r\n    JclPeHeader_DllCharacteristics,\r\n    JclPeHeader_SizeOfStackReserve,\r\n    JclPeHeader_SizeOfStackCommit,\r\n    JclPeHeader_SizeOfHeapReserve,\r\n    JclPeHeader_SizeOfHeapCommit,\r\n    JclPeHeader_LoaderFlags,\r\n    JclPeHeader_NumberOfRvaAndSizes);\r\n\r\n  TJclLoadConfig = (\r\n    JclLoadConfig_Characteristics,   { TODO : rename to Size? }\r\n    JclLoadConfig_TimeDateStamp,\r\n    JclLoadConfig_Version,\r\n    JclLoadConfig_GlobalFlagsClear,\r\n    JclLoadConfig_GlobalFlagsSet,\r\n    JclLoadConfig_CriticalSectionDefaultTimeout,\r\n    JclLoadConfig_DeCommitFreeBlockThreshold,\r\n    JclLoadConfig_DeCommitTotalFreeThreshold,\r\n    JclLoadConfig_LockPrefixTable,\r\n    JclLoadConfig_MaximumAllocationSize,\r\n    JclLoadConfig_VirtualMemoryThreshold,\r\n    JclLoadConfig_ProcessHeapFlags,\r\n    JclLoadConfig_ProcessAffinityMask,\r\n    JclLoadConfig_CSDVersion,\r\n    JclLoadConfig_Reserved1,\r\n    JclLoadConfig_EditList,\r\n    JclLoadConfig_Reserved           { TODO : extend to the new fields? }\r\n  );\r\n\r\n  TJclPeFileProperties = record\r\n    Size: DWORD;\r\n    CreationTime: TDateTime;\r\n    LastAccessTime: TDateTime;\r\n    LastWriteTime: TDateTime;\r\n    Attributes: Integer;\r\n  end;\r\n\r\n  TJclPeImageStatus = (stNotLoaded, stOk, stNotPE, stNotSupported, stNotFound, stError);\r\n  TJclPeTarget = (taUnknown, taWin32, taWin64);\r\n\r\n  TJclPeImage = class(TObject)\r\n  private\r\n    FAttachedImage: Boolean;\r\n    FCertificateList: TJclPeCertificateList;\r\n    FCLRHeader: TJclPeCLRHeader;\r\n    FDebugList: TJclPeDebugList;\r\n    FFileName: TFileName;\r\n    FImageSections: TStringList;\r\n    FLoadedImage: TLoadedImage;\r\n    FExportList: TJclPeExportFuncList;\r\n    FImportList: TJclPeImportList;\r\n    FNoExceptions: Boolean;\r\n    FReadOnlyAccess: Boolean;\r\n    FRelocationList: TJclPeRelocList;\r\n    FResourceList: TJclPeRootResourceList;\r\n    FResourceVA: TJclAddr;\r\n    FStatus: TJclPeImageStatus;\r\n    FTarget: TJclPeTarget;\r\n    FVersionInfo: TJclFileVersionInfo;\r\n    FStringTable: TStringList;\r\n    function GetCertificateList: TJclPeCertificateList;\r\n    function GetCLRHeader: TJclPeCLRHeader;\r\n    function GetDebugList: TJclPeDebugList;\r\n    function GetDescription: string;\r\n    function GetDirectories(Directory: Word): TImageDataDirectory;\r\n    function GetDirectoryExists(Directory: Word): Boolean;\r\n    function GetExportList: TJclPeExportFuncList;\r\n    function GetFileProperties: TJclPeFileProperties;\r\n    function GetImageSectionCount: Integer;\r\n    function GetImageSectionHeaders(Index: Integer): TImageSectionHeader;\r\n    function GetImageSectionNames(Index: Integer): string;\r\n    function GetImageSectionNameFromRva(const Rva: DWORD): string;\r\n    function GetImportList: TJclPeImportList;\r\n    function GetHeaderValues(Index: TJclPeHeader): string;\r\n    function GetLoadConfigValues(Index: TJclLoadConfig): string;\r\n    function GetMappedAddress: TJclAddr;\r\n    function GetOptionalHeader32: TImageOptionalHeader32;\r\n    function GetOptionalHeader64: TImageOptionalHeader64;\r\n    function GetRelocationList: TJclPeRelocList;\r\n    function GetResourceList: TJclPeRootResourceList;\r\n    function GetUnusedHeaderBytes: TImageDataDirectory;\r\n    function GetVersionInfo: TJclFileVersionInfo;\r\n    function GetVersionInfoAvailable: Boolean;\r\n    procedure ReadImageSections;\r\n    procedure ReadStringTable;\r\n    procedure SetFileName(const Value: TFileName);\r\n    function GetStringTableCount: Integer;\r\n    function GetStringTableItem(Index: Integer): string;\r\n    function GetImageSectionFullNames(Index: Integer): string;\r\n  protected\r\n    procedure AfterOpen; dynamic;\r\n    procedure CheckNotAttached;\r\n    procedure Clear; dynamic;\r\n    function ExpandModuleName(const ModuleName: string): TFileName;\r\n    procedure RaiseStatusException;\r\n    function ResourceItemCreate(AEntry: PImageResourceDirectoryEntry;\r\n      AParentItem: TJclPeResourceItem): TJclPeResourceItem; virtual;\r\n    function ResourceListCreate(ADirectory: PImageResourceDirectory;\r\n      AParentItem: TJclPeResourceItem): TJclPeResourceList; virtual;\r\n    property NoExceptions: Boolean read FNoExceptions;\r\n  public\r\n    constructor Create(ANoExceptions: Boolean = False); virtual;\r\n    destructor Destroy; override;\r\n    procedure AttachLoadedModule(const Handle: HMODULE);\r\n    function CalculateCheckSum: DWORD;\r\n    function DirectoryEntryToData(Directory: Word): Pointer;\r\n    function GetSectionHeader(const SectionName: string; out Header: PImageSectionHeader): Boolean;\r\n    function GetSectionName(Header: PImageSectionHeader): string;\r\n    function GetNameInStringTable(Offset: ULONG): string;\r\n    function IsBrokenFormat: Boolean;\r\n    function IsCLR: Boolean;\r\n    function IsSystemImage: Boolean;\r\n    // RVA are always DWORD\r\n    function RawToVa(Raw: DWORD): Pointer; overload;\r\n    function RvaToSection(Rva: DWORD): PImageSectionHeader; overload;\r\n    function RvaToVa(Rva: DWORD): Pointer; overload;\r\n    function RvaToVaEx(Rva: DWORD): Pointer; overload;\r\n    function StatusOK: Boolean;\r\n    procedure TryGetNamesForOrdinalImports;\r\n    function VerifyCheckSum: Boolean;\r\n    class function DebugTypeNames(DebugType: DWORD): string;\r\n    class function DirectoryNames(Directory: Word): string;\r\n    class function ExpandBySearchPath(const ModuleName, BasePath: string): TFileName;\r\n    class function HeaderNames(Index: TJclPeHeader): string;\r\n    class function LoadConfigNames(Index: TJclLoadConfig): string;\r\n    class function ShortSectionInfo(Characteristics: DWORD): string;\r\n    class function DateTimeToStamp(const DateTime: TDateTime): DWORD;\r\n    class function StampToDateTime(TimeDateStamp: DWORD): TDateTime;\r\n    property AttachedImage: Boolean read FAttachedImage;\r\n    property CertificateList: TJclPeCertificateList read GetCertificateList;\r\n    property CLRHeader: TJclPeCLRHeader read GetCLRHeader;\r\n    property DebugList: TJclPeDebugList read GetDebugList;\r\n    property Description: string read GetDescription;\r\n    property Directories[Directory: Word]: TImageDataDirectory read GetDirectories;\r\n    property DirectoryExists[Directory: Word]: Boolean read GetDirectoryExists;\r\n    property ExportList: TJclPeExportFuncList read GetExportList;\r\n    property FileName: TFileName read FFileName write SetFileName;\r\n    property FileProperties: TJclPeFileProperties read GetFileProperties;\r\n    property HeaderValues[Index: TJclPeHeader]: string read GetHeaderValues;\r\n    property ImageSectionCount: Integer read GetImageSectionCount;\r\n    property ImageSectionHeaders[Index: Integer]: TImageSectionHeader read GetImageSectionHeaders;\r\n    property ImageSectionNames[Index: Integer]: string read GetImageSectionNames;\r\n    property ImageSectionFullNames[Index: Integer]: string read GetImageSectionFullNames;\r\n    property ImageSectionNameFromRva[const Rva: DWORD]: string read GetImageSectionNameFromRva;\r\n    property ImportList: TJclPeImportList read GetImportList;\r\n    property LoadConfigValues[Index: TJclLoadConfig]: string read GetLoadConfigValues;\r\n    property LoadedImage: TLoadedImage read FLoadedImage;\r\n    property MappedAddress: TJclAddr read GetMappedAddress;\r\n    property StringTableCount: Integer read GetStringTableCount;\r\n    property StringTable[Index: Integer]: string read GetStringTableItem;\r\n    // use the following properties\r\n    // property OptionalHeader: TImageOptionalHeader\r\n    property OptionalHeader32: TImageOptionalHeader32 read GetOptionalHeader32;\r\n    property OptionalHeader64: TImageOptionalHeader64 read GetOptionalHeader64;\r\n    property ReadOnlyAccess: Boolean read FReadOnlyAccess write FReadOnlyAccess;\r\n    property RelocationList: TJclPeRelocList read GetRelocationList;\r\n    property ResourceVA: TJclAddr read FResourceVA;\r\n    property ResourceList: TJclPeRootResourceList read GetResourceList;\r\n    property Status: TJclPeImageStatus read FStatus;\r\n    property Target: TJclPeTarget read FTarget;\r\n    property UnusedHeaderBytes: TImageDataDirectory read GetUnusedHeaderBytes;\r\n    property VersionInfo: TJclFileVersionInfo read GetVersionInfo;\r\n    property VersionInfoAvailable: Boolean read GetVersionInfoAvailable;\r\n  end;\r\n\r\n  {$IFDEF BORLAND}\r\n  TJclPeBorImage = class;\r\n\r\n  TJclPeBorImagesCache = class(TJclPeImagesCache)\r\n  private\r\n    function GetImages(const FileName: TFileName): TJclPeBorImage;\r\n  protected\r\n    function GetPeImageClass: TJclPeImageClass; override;\r\n  public\r\n    property Images[const FileName: TFileName]: TJclPeBorImage read GetImages; default;\r\n  end;\r\n\r\n  // Borland Delphi PE Image specific information\r\n  TJclPePackageInfo = class(TObject)\r\n  private\r\n    FAvailable: Boolean;\r\n    FContains: TStringList;\r\n    FDcpName: string;\r\n    FRequires: TStringList;\r\n    FFlags: Integer;\r\n    FDescription: string;\r\n    FEnsureExtension: Boolean;\r\n    FSorted: Boolean;\r\n    function GetContains: TStrings;\r\n    function GetContainsCount: Integer;\r\n    function GetContainsFlags(Index: Integer): Byte;\r\n    function GetContainsNames(Index: Integer): string;\r\n    function GetRequires: TStrings;\r\n    function GetRequiresCount: Integer;\r\n    function GetRequiresNames(Index: Integer): string;\r\n  protected\r\n    procedure ReadPackageInfo(ALibHandle: THandle);\r\n    procedure SetDcpName(const Value: string);\r\n  public\r\n    constructor Create(ALibHandle: THandle);\r\n    destructor Destroy; override;\r\n    class function PackageModuleTypeToString(Flags: Cardinal): string;\r\n    class function PackageOptionsToString(Flags: Cardinal): string;\r\n    class function ProducerToString(Flags: Cardinal): string;\r\n    class function UnitInfoFlagsToString(UnitFlags: Byte): string;\r\n    property Available: Boolean read FAvailable;\r\n    property Contains: TStrings read GetContains;\r\n    property ContainsCount: Integer read GetContainsCount;\r\n    property ContainsNames[Index: Integer]: string read GetContainsNames;\r\n    property ContainsFlags[Index: Integer]: Byte read GetContainsFlags;\r\n    property Description: string read FDescription;\r\n    property DcpName: string read FDcpName;\r\n    property EnsureExtension: Boolean read FEnsureExtension write FEnsureExtension;\r\n    property Flags: Integer read FFlags;\r\n    property Requires: TStrings read GetRequires;\r\n    property RequiresCount: Integer read GetRequiresCount;\r\n    property RequiresNames[Index: Integer]: string read GetRequiresNames;\r\n    property Sorted: Boolean read FSorted write FSorted;\r\n  end;\r\n\r\n  TJclPeBorForm = class(TObject)\r\n  private\r\n    FFormFlags: TFilerFlags;\r\n    FFormClassName: string;\r\n    FFormObjectName: string;\r\n    FFormPosition: Integer;\r\n    FResItem: TJclPeResourceItem;\r\n    function GetDisplayName: string;\r\n  public\r\n    constructor Create(AResItem: TJclPeResourceItem; AFormFlags: TFilerFlags;\r\n      AFormPosition: Integer; const AFormClassName, AFormObjectName: string);\r\n    procedure ConvertFormToText(const Stream: TStream); overload;\r\n    procedure ConvertFormToText(const Strings: TStrings); overload;\r\n    property FormClassName: string read FFormClassName;\r\n    property FormFlags: TFilerFlags read FFormFlags;\r\n    property FormObjectName: string read FFormObjectName;\r\n    property FormPosition: Integer read FFormPosition;\r\n    property DisplayName: string read GetDisplayName;\r\n    property ResItem: TJclPeResourceItem read FResItem;\r\n  end;\r\n\r\n  TJclPeBorImage = class(TJclPeImage)\r\n  private\r\n    FForms: TObjectList;\r\n    FIsPackage: Boolean;\r\n    FIsBorlandImage: Boolean;\r\n    FLibHandle: THandle;\r\n    FPackageInfo: TJclPePackageInfo;\r\n    FPackageInfoSorted: Boolean;\r\n    FPackageCompilerVersion: Integer;\r\n    function GetFormCount: Integer;\r\n    function GetForms(Index: Integer): TJclPeBorForm;\r\n    function GetFormFromName(const FormClassName: string): TJclPeBorForm;\r\n    function GetLibHandle: THandle;\r\n    function GetPackageCompilerVersion: Integer;\r\n    function GetPackageInfo: TJclPePackageInfo;\r\n  protected\r\n    procedure AfterOpen; override;\r\n    procedure Clear; override;\r\n    procedure CreateFormsList;\r\n  public\r\n    constructor Create(ANoExceptions: Boolean = False); override;\r\n    destructor Destroy; override;\r\n    function DependedPackages(List: TStrings; FullPathName, Descriptions: Boolean): Boolean;\r\n    function FreeLibHandle: Boolean;\r\n    property Forms[Index: Integer]: TJclPeBorForm read GetForms;\r\n    property FormCount: Integer read GetFormCount;\r\n    property FormFromName[const FormClassName: string]: TJclPeBorForm read GetFormFromName;\r\n    property IsBorlandImage: Boolean read FIsBorlandImage;\r\n    property IsPackage: Boolean read FIsPackage;\r\n    property LibHandle: THandle read GetLibHandle;\r\n    property PackageCompilerVersion: Integer read GetPackageCompilerVersion;\r\n    property PackageInfo: TJclPePackageInfo read GetPackageInfo;\r\n    property PackageInfoSorted: Boolean read FPackageInfoSorted write FPackageInfoSorted;\r\n  end;\r\n  {$ENDIF BORLAND}\r\n\r\n  // Threaded function search\r\n  TJclPeNameSearchOption = (seImports, seDelayImports, seBoundImports, seExports);\r\n  TJclPeNameSearchOptions = set of TJclPeNameSearchOption;\r\n\r\n  TJclPeNameSearchNotifyEvent = procedure (Sender: TObject; PeImage: TJclPeImage;\r\n    var Process: Boolean) of object;\r\n  TJclPeNameSearchFoundEvent = procedure (Sender: TObject; const FileName: TFileName;\r\n    const FunctionName: string; Option: TJclPeNameSearchOption) of object;\r\n\r\n  TJclPeNameSearch = class(TThread)\r\n  private\r\n    F_FileName: TFileName;\r\n    F_FunctionName: string;\r\n    F_Option: TJclPeNameSearchOption;\r\n    F_Process: Boolean;\r\n    FFunctionName: string;\r\n    FOptions: TJclPeNameSearchOptions;\r\n    FPath: string;\r\n    FPeImage: TJclPeImage;\r\n    FOnFound: TJclPeNameSearchFoundEvent;\r\n    FOnProcessFile: TJclPeNameSearchNotifyEvent;\r\n  protected\r\n    function CompareName(const FunctionName, ComparedName: string): Boolean; virtual;\r\n    procedure DoFound;\r\n    procedure DoProcessFile;\r\n    procedure Execute; override;\r\n  public\r\n    constructor Create(const FunctionName, Path: string; Options: TJclPeNameSearchOptions = [seImports, seExports]);\r\n    procedure Start;\r\n    property OnFound: TJclPeNameSearchFoundEvent read FOnFound write FOnFound;\r\n    property OnProcessFile: TJclPeNameSearchNotifyEvent read FOnProcessFile write FOnProcessFile;\r\n  end;\r\n\r\n// PE Image miscellaneous functions\r\ntype\r\n  TJclRebaseImageInfo32 = record\r\n    OldImageSize: DWORD;\r\n    OldImageBase: TJclAddr32;\r\n    NewImageSize: DWORD;\r\n    NewImageBase: TJclAddr32;\r\n  end;\r\n  TJclRebaseImageInfo64 = record\r\n    OldImageSize: DWORD;\r\n    OldImageBase: TJclAddr64;\r\n    NewImageSize: DWORD;\r\n    NewImageBase: TJclAddr64;\r\n  end;\r\n\r\n  // renamed\r\n  // TJclRebaseImageInfo = TJclRebaseImageInfo32;\r\n\r\n{ Image validity }\r\n\r\nfunction IsValidPeFile(const FileName: TFileName): Boolean;\r\n\r\n// use PeGetNtHeaders32 for backward compatibility\r\n// function PeGetNtHeaders(const FileName: TFileName; out NtHeaders: TImageNtHeaders): Boolean;\r\nfunction PeGetNtHeaders32(const FileName: TFileName; out NtHeaders: TImageNtHeaders32): Boolean;\r\nfunction PeGetNtHeaders64(const FileName: TFileName; out NtHeaders: TImageNtHeaders64): Boolean;\r\n\r\n{ Image modifications }\r\n\r\nfunction PeCreateNameHintTable(const FileName: TFileName): Boolean;\r\n\r\n// use PeRebaseImage32\r\n//function PeRebaseImage(const ImageName: TFileName; NewBase: DWORD = 0; TimeStamp: DWORD = 0;\r\n//  MaxNewSize: DWORD = 0): TJclRebaseImageInfo;\r\nfunction PeRebaseImage32(const ImageName: TFileName; NewBase: TJclAddr32 = 0; TimeStamp: DWORD = 0;\r\n  MaxNewSize: DWORD = 0): TJclRebaseImageInfo32;\r\nfunction PeRebaseImage64(const ImageName: TFileName; NewBase: TJclAddr64 = 0; TimeStamp: DWORD = 0;\r\n  MaxNewSize: DWORD = 0): TJclRebaseImageInfo64;\r\n\r\nfunction PeUpdateLinkerTimeStamp(const FileName: TFileName; const Time: TDateTime): Boolean;\r\nfunction PeReadLinkerTimeStamp(const FileName: TFileName): TDateTime;\r\n\r\nfunction PeInsertSection(const FileName: TFileName; SectionStream: TStream; SectionName: string): Boolean;\r\n\r\n{ Image Checksum }\r\n\r\nfunction PeVerifyCheckSum(const FileName: TFileName): Boolean;\r\nfunction PeClearCheckSum(const FileName: TFileName): Boolean;\r\nfunction PeUpdateCheckSum(const FileName: TFileName): Boolean;\r\n\r\n// Various simple PE Image searching and listing routines\r\n{ Exports searching }\r\n\r\nfunction PeDoesExportFunction(const FileName: TFileName; const FunctionName: string;\r\n  Options: TJclSmartCompOptions = []): Boolean;\r\n\r\nfunction PeIsExportFunctionForwardedEx(const FileName: TFileName; const FunctionName: string;\r\n  out ForwardedName: string; Options: TJclSmartCompOptions = []): Boolean;\r\nfunction PeIsExportFunctionForwarded(const FileName: TFileName; const FunctionName: string;\r\n  Options: TJclSmartCompOptions = []): Boolean;\r\n\r\n{ Imports searching }\r\n\r\nfunction PeDoesImportFunction(const FileName: TFileName; const FunctionName: string;\r\n  const LibraryName: string = ''; Options: TJclSmartCompOptions = []): Boolean;\r\n\r\nfunction PeDoesImportLibrary(const FileName: TFileName; const LibraryName: string;\r\n  Recursive: Boolean = False): Boolean;\r\n\r\n{ Imports listing }\r\n\r\nfunction PeImportedLibraries(const FileName: TFileName; const LibrariesList: TStrings;\r\n  Recursive: Boolean = False; FullPathName: Boolean = False): Boolean;\r\n\r\nfunction PeImportedFunctions(const FileName: TFileName; const FunctionsList: TStrings;\r\n  const LibraryName: string = ''; IncludeLibNames: Boolean = False): Boolean;\r\n\r\n{ Exports listing }\r\n\r\nfunction PeExportedFunctions(const FileName: TFileName; const FunctionsList: TStrings): Boolean;\r\nfunction PeExportedNames(const FileName: TFileName; const FunctionsList: TStrings): Boolean;\r\nfunction PeExportedVariables(const FileName: TFileName; const FunctionsList: TStrings): Boolean;\r\n\r\n{ Resources listing }\r\n\r\nfunction PeResourceKindNames(const FileName: TFileName; ResourceType: TJclPeResourceKind;\r\n  const NamesList: TStrings): Boolean;\r\n\r\n{ Borland packages specific }\r\n\r\n{$IFDEF BORLAND}\r\nfunction PeBorFormNames(const FileName: TFileName; const NamesList: TStrings): Boolean;\r\n\r\nfunction PeBorDependedPackages(const FileName: TFileName; PackagesList: TStrings;\r\n  FullPathName, Descriptions: Boolean): Boolean;\r\n{$ENDIF BORLAND}\r\n\r\n// Missing imports checking routines\r\nfunction PeFindMissingImports(const FileName: TFileName; MissingImportsList: TStrings): Boolean; overload;\r\nfunction PeFindMissingImports(RequiredImportsList, MissingImportsList: TStrings): Boolean; overload;\r\n\r\nfunction PeCreateRequiredImportList(const FileName: TFileName; RequiredImportsList: TStrings): Boolean;\r\n\r\n// Mapped or loaded image related routines\r\n// use PeMapImgNtHeaders32\r\n// function PeMapImgNtHeaders(const BaseAddress: Pointer): PImageNtHeaders;\r\nfunction PeMapImgNtHeaders32(const BaseAddress: Pointer): PImageNtHeaders32; overload;\r\nfunction PeMapImgNtHeaders32(Stream: TStream; const BasePosition: Int64; out NtHeaders32: TImageNtHeaders32): Int64; overload;\r\nfunction PeMapImgNtHeaders64(const BaseAddress: Pointer): PImageNtHeaders64; overload;\r\nfunction PeMapImgNtHeaders64(Stream: TStream; const BasePosition: Int64; out NtHeaders64: TImageNtHeaders64): Int64; overload;\r\n\r\nfunction PeMapImgLibraryName(const BaseAddress: Pointer): string;\r\nfunction PeMapImgLibraryName32(const BaseAddress: Pointer): string;\r\nfunction PeMapImgLibraryName64(const BaseAddress: Pointer): string;\r\n\r\nfunction PeMapImgSize(const BaseAddress: Pointer): DWORD; overload;\r\nfunction PeMapImgSize(Stream: TStream; const BasePosition: Int64): DWORD; overload;\r\nfunction PeMapImgSize32(const BaseAddress: Pointer): DWORD; overload;\r\nfunction PeMapImgSize32(Stream: TStream; const BasePosition: Int64): DWORD; overload;\r\nfunction PeMapImgSize64(const BaseAddress: Pointer): DWORD; overload;\r\nfunction PeMapImgSize64(Stream: TStream; const BasePosition: Int64): DWORD; overload;\r\n\r\nfunction PeMapImgTarget(const BaseAddress: Pointer): TJclPeTarget; overload;\r\nfunction PeMapImgTarget(Stream: TStream; const BasePosition: Int64): TJclPeTarget; overload;\r\n\r\ntype\r\n  TImageSectionHeaderArray = array of TImageSectionHeader;\r\n\r\n// use PeMapImgSections32\r\n// function PeMapImgSections(NtHeaders: PImageNtHeaders): PImageSectionHeader;\r\nfunction PeMapImgSections32(NtHeaders: PImageNtHeaders32): PImageSectionHeader; overload;\r\nfunction PeMapImgSections32(Stream: TStream; const NtHeaders32Position: Int64; const NtHeaders32: TImageNtHeaders32;\r\n  out ImageSectionHeaders: TImageSectionHeaderArray): Int64; overload;\r\nfunction PeMapImgSections64(NtHeaders: PImageNtHeaders64): PImageSectionHeader; overload;\r\nfunction PeMapImgSections64(Stream: TStream; const NtHeaders64Position: Int64; const NtHeaders64: TImageNtHeaders64;\r\n  out ImageSectionHeaders: TImageSectionHeaderArray): Int64; overload;\r\n\r\n// use PeMapImgFindSection32\r\n// function PeMapImgFindSection(NtHeaders: PImageNtHeaders;\r\n//   const SectionName: string): PImageSectionHeader;\r\nfunction PeMapImgFindSection32(NtHeaders: PImageNtHeaders32;\r\n  const SectionName: string): PImageSectionHeader;\r\nfunction PeMapImgFindSection64(NtHeaders: PImageNtHeaders64;\r\n  const SectionName: string): PImageSectionHeader;\r\nfunction PeMapImgFindSection(const ImageSectionHeaders: TImageSectionHeaderArray;\r\n  const SectionName: string): SizeInt;\r\n\r\nfunction PeMapImgFindSectionFromModule(const BaseAddress: Pointer;\r\n  const SectionName: string): PImageSectionHeader;\r\n\r\nfunction PeMapImgExportedVariables(const Module: HMODULE; const VariablesList: TStrings): Boolean;\r\n\r\nfunction PeMapImgResolvePackageThunk(Address: Pointer): Pointer;\r\n\r\nfunction PeMapFindResource(const Module: HMODULE; const ResourceType: PChar;\r\n  const ResourceName: string): Pointer;\r\n\r\ntype\r\n  TJclPeSectionStream = class(TCustomMemoryStream)\r\n  private\r\n    FInstance: HMODULE;\r\n    FSectionHeader: TImageSectionHeader;\r\n    procedure Initialize(Instance: HMODULE; const ASectionName: string);\r\n  public\r\n    constructor Create(Instance: HMODULE; const ASectionName: string);\r\n    function Write(const Buffer; Count: Longint): Longint; override;\r\n    property Instance: HMODULE read FInstance;\r\n    property SectionHeader: TImageSectionHeader read FSectionHeader;\r\n  end;\r\n\r\n// API hooking classes\r\ntype\r\n  TJclPeMapImgHookItem = class(TObject)\r\n  private\r\n    FBaseAddress: Pointer;\r\n    FFunctionName: string;\r\n    FModuleName: string;\r\n    FNewAddress: Pointer;\r\n    FOriginalAddress: Pointer;\r\n    FList: TObjectList;\r\n  protected\r\n    function InternalUnhook: Boolean;\r\n  public\r\n    constructor Create(AList: TObjectList; const AFunctionName: string;\r\n      const AModuleName: string; ABaseAddress, ANewAddress, AOriginalAddress: Pointer);\r\n    destructor Destroy; override;\r\n    function Unhook: Boolean;\r\n    property BaseAddress: Pointer read FBaseAddress;\r\n    property FunctionName: string read FFunctionName;\r\n    property ModuleName: string read FModuleName;\r\n    property NewAddress: Pointer read FNewAddress;\r\n    property OriginalAddress: Pointer read FOriginalAddress;\r\n  end;\r\n\r\n  TJclPeMapImgHooks = class(TObjectList)\r\n  private\r\n    function GetItems(Index: Integer): TJclPeMapImgHookItem;\r\n    function GetItemFromOriginalAddress(OriginalAddress: Pointer): TJclPeMapImgHookItem;\r\n    function GetItemFromNewAddress(NewAddress: Pointer): TJclPeMapImgHookItem;\r\n  public\r\n    function HookImport(Base: Pointer; const ModuleName: string;\r\n      const FunctionName: string; NewAddress: Pointer; var OriginalAddress: Pointer): Boolean;\r\n    class function IsWin9xDebugThunk(P: Pointer): Boolean;\r\n    class function ReplaceImport(Base: Pointer; const ModuleName: string; FromProc, ToProc: Pointer): Boolean;\r\n    class function SystemBase: Pointer;\r\n    procedure UnhookAll;\r\n    function UnhookByNewAddress(NewAddress: Pointer): Boolean;\r\n    procedure UnhookByBaseAddress(BaseAddress: Pointer);\r\n    property Items[Index: Integer]: TJclPeMapImgHookItem read GetItems; default;\r\n    property ItemFromOriginalAddress[OriginalAddress: Pointer]: TJclPeMapImgHookItem read GetItemFromOriginalAddress;\r\n    property ItemFromNewAddress[NewAddress: Pointer]: TJclPeMapImgHookItem read GetItemFromNewAddress;\r\n  end;\r\n\r\n// Image access under a debbuger\r\nfunction PeDbgImgNtHeaders32(ProcessHandle: THandle; BaseAddress: TJclAddr32;\r\n  var NtHeaders: TImageNtHeaders32): Boolean;\r\n// TODO 64 bit version\r\n//function PeDbgImgNtHeaders64(ProcessHandle: THandle; BaseAddress: TJclAddr64;\r\n//  var NtHeaders: TImageNtHeaders64): Boolean;\r\n\r\nfunction PeDbgImgLibraryName32(ProcessHandle: THandle; BaseAddress: TJclAddr32;\r\n  var Name: string): Boolean;\r\n//function PeDbgImgLibraryName64(ProcessHandle: THandle; BaseAddress: TJclAddr64;\r\n//  var Name: string): Boolean;\r\n\r\n// Borland BPL packages name unmangling\r\ntype\r\n  TJclBorUmSymbolKind = (skData, skFunction, skConstructor, skDestructor, skRTTI, skVTable);\r\n  TJclBorUmSymbolModifier = (smQualified, smLinkProc);\r\n  TJclBorUmSymbolModifiers = set of TJclBorUmSymbolModifier;\r\n  TJclBorUmDescription = record\r\n    Kind: TJclBorUmSymbolKind;\r\n    Modifiers: TJclBorUmSymbolModifiers;\r\n  end;\r\n  TJclBorUmResult = (urOk, urNotMangled, urMicrosoft, urError);\r\n  TJclPeUmResult = (umNotMangled, umBorland, umMicrosoft);\r\n\r\nfunction PeBorUnmangleName(const Name: string; out Unmangled: string;\r\n  out Description: TJclBorUmDescription; out BasePos: Integer): TJclBorUmResult; overload;\r\nfunction PeBorUnmangleName(const Name: string; out Unmangled: string;\r\n  out Description: TJclBorUmDescription): TJclBorUmResult; overload;\r\nfunction PeBorUnmangleName(const Name: string; out Unmangled: string): TJclBorUmResult; overload;\r\nfunction PeBorUnmangleName(const Name: string): string; overload;\r\n\r\nfunction PeIsNameMangled(const Name: string): TJclPeUmResult;\r\n\r\nfunction UndecorateSymbolName(const DecoratedName: string; out UnMangled: string; Flags: DWORD): Boolean;\r\nfunction PeUnmangleName(const Name: string; out Unmangled: string): TJclPeUmResult;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n  UnitVersioning: TUnitVersionInfo = (\r\n    RCSfile: '$URL: jcl/source/windows/JclPeImage.pas $';\r\n    Revision: '$Revision: 5a26dc1cafb60f4dcaf1e677a6fb03cc30db43b3 $';\r\n    Date: '$Date: 2013-05-13 21:15:06 +0200 $';\r\n    LogPath: 'JCL\\source\\windows';\r\n    Extra: '';\r\n    Data: nil\r\n    );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n  {$IFDEF HAS_UNITSCOPE}\r\n  System.RTLConsts,\r\n  System.Types, // for inlining TList.Remove\r\n  {$IFDEF HAS_UNIT_CHARACTER}\r\n  System.Character,\r\n  {$ENDIF HAS_UNIT_CHARACTER}\r\n  {$ELSE ~HAS_UNITSCOPE}\r\n  RTLConsts,\r\n  {$IFDEF HAS_UNIT_CHARACTER}\r\n  Character,\r\n  {$ENDIF HAS_UNIT_CHARACTER}\r\n  {$ENDIF ~HAS_UNITSCOPE}\r\n  JclLogic, JclResources, JclSysUtils, JclAnsiStrings, JclStrings, JclStringConversions;\r\n\r\nconst\r\n  MANIFESTExtension = '.manifest';\r\n\r\n  DebugSectionName    = '.debug';\r\n  ReadOnlySectionName = '.rdata';\r\n\r\n  BinaryExtensionLibrary = '.dll';\r\n\r\n  {$IFDEF BORLAND}\r\n  CompilerExtensionDCP   = '.dcp';\r\n  BinaryExtensionPackage = '.bpl';\r\n\r\n  PackageInfoResName    = 'PACKAGEINFO';\r\n  DescriptionResName    = 'DESCRIPTION';\r\n  PackageOptionsResName = 'PACKAGEOPTIONS';\r\n  DVclAlResName         = 'DVCLAL';\r\n  {$ENDIF BORLAND}\r\n\r\n// Helper routines\r\nfunction AddFlagTextRes(var Text: string; const FlagText: PResStringRec; const Value, Mask: Cardinal): Boolean;\r\nbegin\r\n  Result := (Value and Mask <> 0);\r\n  if Result then\r\n  begin\r\n    if Length(Text) > 0 then\r\n      Text := Text + ', ';\r\n    Text := Text + LoadResString(FlagText);\r\n  end;\r\nend;\r\n\r\nfunction CompareResourceName(T1, T2: PChar): Boolean;\r\nvar\r\n  Long1, Long2: LongRec;\r\nbegin\r\n  {$IFDEF CPU64}\r\n  Long1 := LongRec(Int64Rec(T1).Lo);\r\n  Long2 := LongRec(Int64Rec(T2).Lo);\r\n  if (Int64Rec(T1).Hi = 0) and (Int64Rec(T2).Hi = 0) and (Long1.Hi = 0) and (Long2.Hi = 0) then\r\n  {$ENDIF CPU64}\r\n  {$IFDEF CPU32}\r\n  Long1 := LongRec(T1);\r\n  Long2 := LongRec(T2);\r\n  if (Long1.Hi = 0) or (Long2.Hi = 0) then\r\n  {$ENDIF CPU32}\r\n    Result := Long1.Lo = Long2.Lo\r\n  else\r\n    Result := (StrIComp(T1, T2) = 0);\r\nend;\r\n\r\nfunction CreatePeImage(const FileName: TFileName): TJclPeImage;\r\nbegin\r\n  Result := TJclPeImage.Create(True);\r\n  Result.FileName := FileName;\r\nend;\r\n\r\nfunction InternalImportedLibraries(const FileName: TFileName;\r\n  Recursive, FullPathName: Boolean; ExternalCache: TJclPeImagesCache): TStringList;\r\nvar\r\n  Cache: TJclPeImagesCache;\r\n\r\n  procedure ProcessLibraries(const AFileName: TFileName);\r\n  var\r\n    I: Integer;\r\n    S: TFileName;\r\n    ImportLib: TJclPeImportLibItem;\r\n  begin\r\n    with Cache[AFileName].ImportList do\r\n      for I := 0 to Count - 1 do\r\n      begin\r\n        ImportLib := Items[I];\r\n        if FullPathName then\r\n          S := ImportLib.FileName\r\n        else\r\n          S := TFileName(ImportLib.Name);\r\n        if Result.IndexOf(S) = -1 then\r\n        begin\r\n          Result.Add(S);\r\n          if Recursive then\r\n            ProcessLibraries(ImportLib.FileName);\r\n        end;\r\n      end;\r\n  end;\r\n\r\nbegin\r\n  if ExternalCache = nil then\r\n    Cache := TJclPeImagesCache.Create\r\n  else\r\n    Cache := ExternalCache;\r\n  try\r\n    Result := TStringList.Create;\r\n    try\r\n      Result.Sorted := True;\r\n      Result.Duplicates := dupIgnore;\r\n      ProcessLibraries(FileName);\r\n    except\r\n      FreeAndNil(Result);\r\n      raise;\r\n    end;\r\n  finally\r\n    if ExternalCache = nil then\r\n      Cache.Free;\r\n  end;\r\nend;\r\n\r\n// Smart name compare function\r\nfunction PeStripFunctionAW(const FunctionName: string): string;\r\nvar\r\n  L: Integer;\r\nbegin\r\n  Result := FunctionName;\r\n  L := Length(Result);\r\n  if (L > 1) then\r\n    case Result[L] of\r\n      'A', 'W':\r\n        if CharIsValidIdentifierLetter(Result[L - 1]) then\r\n          Delete(Result, L, 1);\r\n    end;\r\nend;\r\n\r\nfunction PeSmartFunctionNameSame(const ComparedName, FunctionName: string;\r\n  Options: TJclSmartCompOptions): Boolean;\r\nvar\r\n  S: string;\r\nbegin\r\n  if scIgnoreCase in Options then\r\n    Result := CompareText(FunctionName, ComparedName) = 0\r\n  else\r\n    Result := (FunctionName = ComparedName);\r\n  if (not Result) and not (scSimpleCompare in Options) then\r\n  begin\r\n    if Length(FunctionName) > 0 then\r\n    begin\r\n      S := PeStripFunctionAW(FunctionName);\r\n      if scIgnoreCase in Options then\r\n        Result := CompareText(S, ComparedName) = 0\r\n      else\r\n        Result := (S = ComparedName);\r\n    end\r\n    else\r\n      Result := False;\r\n  end;\r\nend;\r\n\r\n//=== { TJclPeImagesCache } ==================================================\r\n\r\nconstructor TJclPeImagesCache.Create;\r\nbegin\r\n  inherited Create;\r\n  FList := TStringList.Create;\r\n  FList.Sorted := True;\r\n  FList.Duplicates := dupIgnore;\r\nend;\r\n\r\ndestructor TJclPeImagesCache.Destroy;\r\nbegin\r\n  Clear;\r\n  FreeAndNil(FList);\r\n  inherited Destroy;\r\nend;\r\n\r\nprocedure TJclPeImagesCache.Clear;\r\nvar\r\n  I: Integer;\r\nbegin\r\n  with FList do\r\n    for I := 0 to Count - 1 do\r\n      Objects[I].Free;\r\n  FList.Clear;\r\nend;\r\n\r\nfunction TJclPeImagesCache.GetCount: Integer;\r\nbegin\r\n  Result := FList.Count;\r\nend;\r\n\r\nfunction TJclPeImagesCache.GetImages(const FileName: TFileName): TJclPeImage;\r\nvar\r\n  I: Integer;\r\nbegin\r\n  I := FList.IndexOf(FileName);\r\n  if I = -1 then\r\n  begin\r\n    Result := GetPeImageClass.Create(True);\r\n    Result.FileName := FileName;\r\n    FList.AddObject(FileName, Result);\r\n  end\r\n  else\r\n    Result := TJclPeImage(FList.Objects[I]);\r\nend;\r\n\r\nfunction TJclPeImagesCache.GetPeImageClass: TJclPeImageClass;\r\nbegin\r\n  Result := TJclPeImage;\r\nend;\r\n\r\n//=== { TJclPeImageBaseList } ================================================\r\n\r\nconstructor TJclPeImageBaseList.Create(AImage: TJclPeImage);\r\nbegin\r\n  inherited Create(True);\r\n  FImage := AImage;\r\nend;\r\n\r\n// Import sort functions\r\n\r\nfunction ImportSortByName(Item1, Item2: Pointer): Integer;\r\nbegin\r\n  Result := CompareStr(TJclPeImportFuncItem(Item1).Name, TJclPeImportFuncItem(Item2).Name);\r\n  if Result = 0 then\r\n    Result := CompareStr(TJclPeImportFuncItem(Item1).ImportLib.Name, TJclPeImportFuncItem(Item2).ImportLib.Name);\r\n  if Result = 0 then\r\n    Result := TJclPeImportFuncItem(Item1).Ordinal - TJclPeImportFuncItem(Item2).Ordinal;\r\nend;\r\n\r\nfunction ImportSortByNameDESC(Item1, Item2: Pointer): Integer;\r\nbegin\r\n  Result := ImportSortByName(Item2, Item1);\r\nend;\r\n\r\nfunction ImportSortByHint(Item1, Item2: Pointer): Integer;\r\nbegin\r\n  Result := TJclPeImportFuncItem(Item1).Hint - TJclPeImportFuncItem(Item2).Hint;\r\nend;\r\n\r\nfunction ImportSortByHintDESC(Item1, Item2: Pointer): Integer;\r\nbegin\r\n  Result := ImportSortByHint(Item2, Item1);\r\nend;\r\n\r\nfunction ImportSortByDll(Item1, Item2: Pointer): Integer;\r\nbegin\r\n  Result := CompareStr(TJclPeImportFuncItem(Item1).ImportLib.Name,\r\n    TJclPeImportFuncItem(Item2).ImportLib.Name);\r\n  if Result = 0 then\r\n    Result := ImportSortByName(Item1, Item2);\r\nend;\r\n\r\nfunction ImportSortByDllDESC(Item1, Item2: Pointer): Integer;\r\nbegin\r\n  Result := ImportSortByDll(Item2, Item1);\r\nend;\r\n\r\nfunction ImportSortByOrdinal(Item1, Item2: Pointer): Integer;\r\nbegin\r\n  Result := CompareStr(TJclPeImportFuncItem(Item1).ImportLib.Name,\r\n    TJclPeImportFuncItem(Item2).ImportLib.Name);\r\n  if Result = 0 then\r\n    Result := TJclPeImportFuncItem(Item1).Ordinal -  TJclPeImportFuncItem(Item2).Ordinal;\r\nend;\r\n\r\nfunction ImportSortByOrdinalDESC(Item1, Item2: Pointer): Integer;\r\nbegin\r\n  Result := ImportSortByOrdinal(Item2, Item1);\r\nend;\r\n\r\nfunction GetImportSortFunction(SortType: TJclPeImportSort; Descending: Boolean): TListSortCompare;\r\nconst\r\n  SortFunctions: array [TJclPeImportSort, Boolean] of TListSortCompare =\r\n    ((ImportSortByName, ImportSortByNameDESC),\r\n     (ImportSortByOrdinal, ImportSortByOrdinalDESC),\r\n     (ImportSortByHint, ImportSortByHintDESC),\r\n     (ImportSortByDll, ImportSortByDllDESC)\r\n    );\r\nbegin\r\n  Result := SortFunctions[SortType, Descending];\r\nend;\r\n\r\nfunction ImportLibSortByIndex(Item1, Item2: Pointer): Integer;\r\nbegin\r\n  Result := TJclPeImportLibItem(Item1).ImportDirectoryIndex -\r\n    TJclPeImportLibItem(Item2).ImportDirectoryIndex;\r\nend;\r\n\r\nfunction ImportLibSortByName(Item1, Item2: Pointer): Integer;\r\nbegin\r\n  Result := AnsiCompareStr(TJclPeImportLibItem(Item1).Name, TJclPeImportLibItem(Item2).Name);\r\n  if Result = 0 then\r\n    Result := ImportLibSortByIndex(Item1, Item2);\r\nend;\r\n\r\nfunction GetImportLibSortFunction(SortType: TJclPeImportLibSort): TListSortCompare;\r\nconst\r\n  SortFunctions: array [TJclPeImportLibSort] of TListSortCompare =\r\n    (ImportLibSortByName, ImportLibSortByIndex);\r\nbegin\r\n  Result := SortFunctions[SortType];\r\nend;\r\n\r\n//=== { TJclPeImportFuncItem } ===============================================\r\n\r\nconstructor TJclPeImportFuncItem.Create(AImportLib: TJclPeImportLibItem;\r\n  AOrdinal: Word; AHint: Word; const AName: string);\r\nbegin\r\n  inherited Create;\r\n  FImportLib := AImportLib;\r\n  FOrdinal := AOrdinal;\r\n  FHint := AHint;\r\n  FName := AName;\r\n  FResolveCheck := icNotChecked;\r\n  FIndirectImportName := False;\r\nend;\r\n\r\nfunction TJclPeImportFuncItem.GetIsByOrdinal: Boolean;\r\nbegin\r\n  Result := FOrdinal <> 0;\r\nend;\r\n\r\nprocedure TJclPeImportFuncItem.SetIndirectImportName(const Value: string);\r\nbegin\r\n  FName := Value;\r\n  FIndirectImportName := True;\r\nend;\r\n\r\nprocedure TJclPeImportFuncItem.SetName(const Value: string);\r\nbegin\r\n  FName := Value;\r\n  FIndirectImportName := False;\r\nend;\r\n\r\nprocedure TJclPeImportFuncItem.SetResolveCheck(Value: TJclPeResolveCheck);\r\nbegin\r\n  FResolveCheck := Value;\r\nend;\r\n\r\n//=== { TJclPeImportLibItem } ================================================\r\n\r\nconstructor TJclPeImportLibItem.Create(AImage: TJclPeImage;\r\n  AImportDescriptor: Pointer; AImportKind: TJclPeImportKind; const AName: string;\r\n  AThunk: Pointer);\r\nbegin\r\n  inherited Create(AImage);\r\n  FTotalResolveCheck := icNotChecked;\r\n  FImportDescriptor := AImportDescriptor;\r\n  FImportKind := AImportKind;\r\n  FName := AName;\r\n  FThunk := AThunk;\r\n  FThunkData := AThunk;\r\nend;\r\n\r\nprocedure TJclPeImportLibItem.CheckImports(ExportImage: TJclPeImage);\r\nvar\r\n  I: Integer;\r\n  ExportList: TJclPeExportFuncList;\r\nbegin\r\n  if ExportImage.StatusOK then\r\n  begin\r\n    FTotalResolveCheck := icResolved;\r\n    ExportList := ExportImage.ExportList;\r\n    for I := 0 to Count - 1 do\r\n    begin\r\n      with Items[I] do\r\n        if IsByOrdinal then\r\n        begin\r\n          if ExportList.OrdinalValid(Ordinal) then\r\n            SetResolveCheck(icResolved)\r\n          else\r\n          begin\r\n            SetResolveCheck(icUnresolved);\r\n            Self.FTotalResolveCheck := icUnresolved;\r\n          end;\r\n        end\r\n        else\r\n        begin\r\n          if ExportList.ItemFromName[Items[I].Name] <> nil then\r\n            SetResolveCheck(icResolved)\r\n          else\r\n          begin\r\n            SetResolveCheck(icUnresolved);\r\n            Self.FTotalResolveCheck := icUnresolved;\r\n          end;\r\n        end;\r\n    end;\r\n  end\r\n  else\r\n  begin\r\n    FTotalResolveCheck := icUnresolved;\r\n    for I := 0 to Count - 1 do\r\n      Items[I].SetResolveCheck(icUnresolved);\r\n  end;\r\nend;\r\n\r\nprocedure TJclPeImportLibItem.CreateList;\r\n  procedure CreateList32;\r\n  var\r\n    Thunk32: PImageThunkData32;\r\n    OrdinalName: PImageImportByName;\r\n    Ordinal, Hint: Word;\r\n    Name: PAnsiChar;\r\n    ImportName: string;\r\n  begin\r\n    Thunk32 := PImageThunkData32(FThunk);\r\n    while Thunk32^.Function_ <> 0 do\r\n    begin\r\n      Ordinal := 0;\r\n      Hint := 0;\r\n      Name := nil;\r\n      if Thunk32^.Ordinal and IMAGE_ORDINAL_FLAG32 = 0 then\r\n      begin\r\n        case ImportKind of\r\n          ikImport, ikBoundImport:\r\n            begin\r\n              OrdinalName := PImageImportByName(Image.RvaToVa(Thunk32^.AddressOfData));\r\n              Hint := OrdinalName.Hint;\r\n              Name := OrdinalName.Name;\r\n            end;\r\n          ikDelayImport:\r\n            begin\r\n              OrdinalName := PImageImportByName(Image.RvaToVaEx(Thunk32^.AddressOfData));\r\n              Hint := OrdinalName.Hint;\r\n              Name := OrdinalName.Name;\r\n            end;\r\n        end;\r\n      end\r\n      else\r\n        Ordinal := IMAGE_ORDINAL32(Thunk32^.Ordinal);\r\n      if not TryUTF8ToString(Name, ImportName) then\r\n        ImportName := string(Name);\r\n      Add(TJclPeImportFuncItem.Create(Self, Ordinal, Hint, ImportName));\r\n      Inc(Thunk32);\r\n    end;\r\n  end;\r\n\r\n  procedure CreateList64;\r\n  var\r\n    Thunk64: PImageThunkData64;\r\n    OrdinalName: PImageImportByName;\r\n    Ordinal, Hint: Word;\r\n    Name: PAnsiChar;\r\n    ImportName: string;\r\n  begin\r\n    Thunk64 := PImageThunkData64(FThunk);\r\n    while Thunk64^.Function_ <> 0 do\r\n    begin\r\n      Ordinal := 0;\r\n      Hint := 0;\r\n      Name := nil;\r\n      if Thunk64^.Ordinal and IMAGE_ORDINAL_FLAG64 = 0 then\r\n      begin\r\n        case ImportKind of\r\n          ikImport, ikBoundImport:\r\n            begin\r\n              OrdinalName := PImageImportByName(Image.RvaToVa(Thunk64^.AddressOfData));\r\n              Hint := OrdinalName.Hint;\r\n              Name := OrdinalName.Name;\r\n            end;\r\n          ikDelayImport:\r\n            begin\r\n              OrdinalName := PImageImportByName(Image.RvaToVaEx(Thunk64^.AddressOfData));\r\n              Hint := OrdinalName.Hint;\r\n              Name := OrdinalName.Name;\r\n            end;\r\n        end;\r\n      end\r\n      else\r\n        Ordinal := IMAGE_ORDINAL64(Thunk64^.Ordinal);\r\n      if not TryUTF8ToString(Name, ImportName) then\r\n        ImportName := string(Name);\r\n      Add(TJclPeImportFuncItem.Create(Self, Ordinal, Hint, ImportName));\r\n      Inc(Thunk64);\r\n    end;\r\n  end;\r\nbegin\r\n  if FThunk = nil then\r\n    Exit;\r\n\r\n  case Image.Target of\r\n    taWin32:\r\n      CreateList32;\r\n    taWin64:\r\n      CreateList64;\r\n  end;\r\n\r\n  FThunk := nil;\r\nend;\r\n\r\nfunction TJclPeImportLibItem.GetCount: Integer;\r\nbegin\r\n  if FThunk <> nil then\r\n    CreateList;\r\n  Result := inherited Count;\r\nend;\r\n\r\nfunction TJclPeImportLibItem.GetFileName: TFileName;\r\nbegin\r\n  Result := Image.ExpandModuleName(Name);\r\nend;\r\n\r\nfunction TJclPeImportLibItem.GetItems(Index: Integer): TJclPeImportFuncItem;\r\nbegin\r\n  Result := TJclPeImportFuncItem(Get(Index));\r\nend;\r\n\r\nfunction TJclPeImportLibItem.GetName: string;\r\nbegin\r\n  Result := AnsiLowerCase(OriginalName);\r\nend;\r\n\r\nfunction TJclPeImportLibItem.GetThunkData32: PImageThunkData32;\r\nbegin\r\n  if Image.Target = taWin32 then\r\n    Result := FThunkData\r\n  else\r\n    Result := nil;\r\nend;\r\n\r\nfunction TJclPeImportLibItem.GetThunkData64: PImageThunkData64;\r\nbegin\r\n  if Image.Target = taWin64 then\r\n    Result := FThunkData\r\n  else\r\n    Result := nil;\r\nend;\r\n\r\nprocedure TJclPeImportLibItem.SetImportDirectoryIndex(Value: Integer);\r\nbegin\r\n  FImportDirectoryIndex := Value;\r\nend;\r\n\r\nprocedure TJclPeImportLibItem.SetImportKind(Value: TJclPeImportKind);\r\nbegin\r\n  FImportKind := Value;\r\nend;\r\n\r\nprocedure TJclPeImportLibItem.SetSorted(Value: Boolean);\r\nbegin\r\n  FSorted := Value;\r\nend;\r\n\r\nprocedure TJclPeImportLibItem.SetThunk(Value: Pointer);\r\nbegin\r\n  FThunk := Value;\r\n  FThunkData := Value;\r\nend;\r\n\r\nprocedure TJclPeImportLibItem.SortList(SortType: TJclPeImportSort; Descending: Boolean);\r\nbegin\r\n  if not FSorted or (SortType <> FLastSortType) or (Descending <> FLastSortDescending) then\r\n  begin\r\n    GetCount; // create list if it wasn't created\r\n    Sort(GetImportSortFunction(SortType, Descending));\r\n    FLastSortType := SortType;\r\n    FLastSortDescending := Descending;\r\n    FSorted := True;\r\n  end;\r\nend;\r\n\r\n//=== { TJclPeImportList } ===================================================\r\n\r\nconstructor TJclPeImportList.Create(AImage: TJclPeImage);\r\nbegin\r\n  inherited Create(AImage);\r\n  FAllItemsList := TList.Create;\r\n  FAllItemsList.Capacity := 256;\r\n  FUniqueNamesList := TStringList.Create;\r\n  FUniqueNamesList.Sorted := True;\r\n  FUniqueNamesList.Duplicates := dupIgnore;\r\n  FLastAllSortType := isName;\r\n  FLastAllSortDescending := False;\r\n  CreateList;\r\nend;\r\n\r\ndestructor TJclPeImportList.Destroy;\r\nvar\r\n  I: Integer;\r\nbegin\r\n  FreeAndNil(FAllItemsList);\r\n  FreeAndNil(FUniqueNamesList);\r\n  for I := 0 to Length(FparallelImportTable) - 1 do\r\n    FreeMem(FparallelImportTable[I]);\r\n  inherited Destroy;\r\nend;\r\n\r\nprocedure TJclPeImportList.CheckImports(PeImageCache: TJclPeImagesCache);\r\nvar\r\n  I: Integer;\r\n  ExportPeImage: TJclPeImage;\r\nbegin\r\n  Image.CheckNotAttached;\r\n  if PeImageCache <> nil then\r\n    ExportPeImage := nil // to make the compiler happy\r\n  else\r\n    ExportPeImage := TJclPeImage.Create(True);\r\n  try\r\n    for I := 0 to Count - 1 do\r\n      if Items[I].TotalResolveCheck = icNotChecked then\r\n      begin\r\n        if PeImageCache <> nil then\r\n          ExportPeImage := PeImageCache[Items[I].FileName]\r\n        else\r\n          ExportPeImage.FileName := Items[I].FileName;\r\n        ExportPeImage.ExportList.PrepareForFastNameSearch;\r\n        Items[I].CheckImports(ExportPeImage);\r\n      end;\r\n  finally\r\n    if PeImageCache = nil then\r\n      ExportPeImage.Free;\r\n  end;\r\nend;\r\n\r\nprocedure TJclPeImportList.CreateList;\r\n  procedure CreateDelayImportList32(DelayImportDesc: PImgDelayDescrV1);\r\n  var\r\n    LibItem: TJclPeImportLibItem;\r\n    UTF8Name: TUTF8String;\r\n    LibName: string;\r\n  begin\r\n    while DelayImportDesc^.szName <> nil do\r\n    begin\r\n      UTF8Name := PAnsiChar(Image.RvaToVaEx(DWORD(DelayImportDesc^.szName)));\r\n      if not TryUTF8ToString(UTF8Name, LibName) then\r\n        LibName := string(UTF8Name);\r\n      LibItem := TJclPeImportLibItem.Create(Image, DelayImportDesc, ikDelayImport,\r\n        LibName, Image.RvaToVaEx(DWORD(DelayImportDesc^.pINT)));\r\n      Add(LibItem);\r\n      FUniqueNamesList.AddObject(AnsiLowerCase(LibItem.Name), LibItem);\r\n      Inc(DelayImportDesc);\r\n    end;\r\n  end;\r\n\r\n  procedure CreateDelayImportList64(DelayImportDesc: PImgDelayDescrV2);\r\n  var\r\n    LibItem: TJclPeImportLibItem;\r\n    UTF8Name: TUTF8String;\r\n    LibName: string;\r\n  begin\r\n    while DelayImportDesc^.rvaDLLName <> 0 do\r\n    begin\r\n      UTF8Name := PAnsiChar(Image.RvaToVa(DelayImportDesc^.rvaDLLName));\r\n      if not TryUTF8ToString(UTF8Name, LibName) then\r\n        LibName := string(UTF8Name);\r\n      LibItem := TJclPeImportLibItem.Create(Image, DelayImportDesc, ikDelayImport,\r\n        LibName, Image.RvaToVa(DelayImportDesc^.rvaINT));\r\n      Add(LibItem);\r\n      FUniqueNamesList.AddObject(AnsiLowerCase(LibItem.Name), LibItem);\r\n      Inc(DelayImportDesc);\r\n    end;\r\n  end;\r\nvar\r\n  ImportDesc: PImageImportDescriptor;\r\n  LibItem: TJclPeImportLibItem;\r\n  UTF8Name: TUTF8String;\r\n  LibName, ModuleName: string;\r\n  DelayImportDesc: Pointer;\r\n  BoundImports, BoundImport: PImageBoundImportDescriptor;\r\n  S: string;\r\n  I: Integer;\r\n  Thunk: Pointer;\r\nbegin\r\n  SetCapacity(100);\r\n  with Image do\r\n  begin\r\n    if not StatusOK then\r\n      Exit;\r\n    ImportDesc := DirectoryEntryToData(IMAGE_DIRECTORY_ENTRY_IMPORT);\r\n    if ImportDesc <> nil then\r\n      while ImportDesc^.Name <> 0 do\r\n      begin\r\n        if ImportDesc^.Union.Characteristics = 0 then\r\n        begin\r\n          if AttachedImage then  // Borland images doesn't have two parallel arrays\r\n            Thunk := nil // see MakeBorlandImportTableForMappedImage method\r\n          else\r\n            Thunk := RvaToVa(ImportDesc^.FirstThunk);\r\n          FLinkerProducer := lrBorland;\r\n        end\r\n        else\r\n        begin\r\n          Thunk := RvaToVa(ImportDesc^.Union.Characteristics);\r\n          FLinkerProducer := lrMicrosoft;\r\n        end;\r\n        UTF8Name := PAnsiChar(RvaToVa(ImportDesc^.Name));\r\n        if not TryUTF8ToString(UTF8Name, LibName) then\r\n          LibName := string(UTF8Name);\r\n        LibItem := TJclPeImportLibItem.Create(Image, ImportDesc, ikImport, LibName, Thunk);\r\n        Add(LibItem);\r\n        FUniqueNamesList.AddObject(AnsiLowerCase(LibItem.Name), LibItem);\r\n        Inc(ImportDesc);\r\n      end;\r\n    DelayImportDesc := DirectoryEntryToData(IMAGE_DIRECTORY_ENTRY_DELAY_IMPORT);\r\n    if DelayImportDesc <> nil then\r\n    begin\r\n      case Target of\r\n        taWin32:\r\n          CreateDelayImportList32(DelayImportDesc);\r\n        taWin64:\r\n          CreateDelayImportList64(DelayImportDesc);\r\n      end;\r\n    end;\r\n    BoundImports := DirectoryEntryToData(IMAGE_DIRECTORY_ENTRY_BOUND_IMPORT);\r\n    if BoundImports <> nil then\r\n    begin\r\n      BoundImport := BoundImports;\r\n      while BoundImport^.OffsetModuleName <> 0 do\r\n      begin\r\n        UTF8Name := PAnsiChar(TJclAddr(BoundImports) + BoundImport^.OffsetModuleName);\r\n        if not TryUTF8ToString(UTF8Name, ModuleName) then\r\n          ModuleName := string(UTF8Name);\r\n        S := AnsiLowerCase(ModuleName);\r\n        I := FUniqueNamesList.IndexOf(S);\r\n        if I >= 0 then\r\n          TJclPeImportLibItem(FUniqueNamesList.Objects[I]).SetImportKind(ikBoundImport);\r\n        for I := 1 to BoundImport^.NumberOfModuleForwarderRefs do\r\n          Inc(PImageBoundForwarderRef(BoundImport)); // skip forward information\r\n        Inc(BoundImport);\r\n      end;\r\n    end;\r\n  end;\r\n  for I := 0 to Count - 1 do\r\n    Items[I].SetImportDirectoryIndex(I);\r\nend;\r\n\r\nfunction TJclPeImportList.GetAllItemCount: Integer;\r\nbegin\r\n  Result := FAllItemsList.Count;\r\n  if Result = 0 then // we haven't created the list yet -> create unsorted list\r\n  begin\r\n    RefreshAllItems;\r\n    Result := FAllItemsList.Count;\r\n  end;\r\nend;\r\n\r\nfunction TJclPeImportList.GetAllItems(Index: Integer): TJclPeImportFuncItem;\r\nbegin\r\n  Result := TJclPeImportFuncItem(FAllItemsList[Index]);\r\nend;\r\n\r\nfunction TJclPeImportList.GetItems(Index: Integer): TJclPeImportLibItem;\r\nbegin\r\n  Result := TJclPeImportLibItem(Get(Index));\r\nend;\r\n\r\nfunction TJclPeImportList.GetUniqueLibItemCount: Integer;\r\nbegin\r\n  Result := FUniqueNamesList.Count;\r\nend;\r\n\r\nfunction TJclPeImportList.GetUniqueLibItemFromName(const Name: string): TJclPeImportLibItem;\r\nvar\r\n  I: Integer;\r\nbegin\r\n  I := FUniqueNamesList.IndexOf(Name);\r\n  if I = -1 then\r\n    Result := nil\r\n  else\r\n    Result := TJclPeImportLibItem(FUniqueNamesList.Objects[I]);\r\nend;\r\n\r\nfunction TJclPeImportList.GetUniqueLibItems(Index: Integer): TJclPeImportLibItem;\r\nbegin\r\n  Result := TJclPeImportLibItem(FUniqueNamesList.Objects[Index]);\r\nend;\r\n\r\nfunction TJclPeImportList.GetUniqueLibNames(Index: Integer): string;\r\nbegin\r\n  Result := FUniqueNamesList[Index];\r\nend;\r\n\r\nfunction TJclPeImportList.MakeBorlandImportTableForMappedImage: Boolean;\r\nvar\r\n  FileImage: TJclPeImage;\r\n  I, TableSize: Integer;\r\nbegin\r\n  if Image.AttachedImage and (LinkerProducer = lrBorland) and\r\n    (Length(FParallelImportTable) = 0) then\r\n  begin\r\n    FileImage := TJclPeImage.Create(True);\r\n    try\r\n      FileImage.FileName := Image.FileName;\r\n      Result := FileImage.StatusOK;\r\n      if Result then\r\n      begin\r\n        SetLength(FParallelImportTable, FileImage.ImportList.Count);\r\n        for I := 0 to FileImage.ImportList.Count - 1 do\r\n        begin\r\n          Assert(Items[I].ImportKind = ikImport); // Borland doesn't have Delay load or Bound imports\r\n          TableSize := (FileImage.ImportList[I].Count + 1);\r\n          case Image.Target of\r\n            taWin32:\r\n              begin\r\n                TableSize := TableSize * SizeOf(TImageThunkData32);\r\n                GetMem(FParallelImportTable[I], TableSize);\r\n                System.Move(FileImage.ImportList[I].ThunkData32^, FParallelImportTable[I]^, TableSize);\r\n                Items[I].SetThunk(FParallelImportTable[I]);\r\n              end;\r\n            taWin64:\r\n              begin\r\n                TableSize := TableSize * SizeOf(TImageThunkData64);\r\n                GetMem(FParallelImportTable[I], TableSize);\r\n                System.Move(FileImage.ImportList[I].ThunkData64^, FParallelImportTable[I]^, TableSize);\r\n                Items[I].SetThunk(FParallelImportTable[I]);\r\n              end;\r\n          end;\r\n        end;\r\n      end;\r\n    finally\r\n      FileImage.Free;\r\n    end;\r\n  end\r\n  else\r\n    Result := True;\r\nend;\r\n\r\nprocedure TJclPeImportList.RefreshAllItems;\r\nvar\r\n  L, I: Integer;\r\n  LibItem: TJclPeImportLibItem;\r\nbegin\r\n  FAllItemsList.Clear;\r\n  for L := 0 to Count - 1 do\r\n  begin\r\n    LibItem := Items[L];\r\n    if (Length(FFilterModuleName) = 0) or (AnsiCompareText(LibItem.Name, FFilterModuleName) = 0) then\r\n      for I := 0 to LibItem.Count - 1 do\r\n        FAllItemsList.Add(LibItem[I]);\r\n  end;\r\nend;\r\n\r\nprocedure TJclPeImportList.SetFilterModuleName(const Value: string);\r\nbegin\r\n  if (FFilterModuleName <> Value) or (FAllItemsList.Count = 0) then\r\n  begin\r\n    FFilterModuleName := Value;\r\n    RefreshAllItems;\r\n    FAllItemsList.Sort(GetImportSortFunction(FLastAllSortType, FLastAllSortDescending));\r\n  end;\r\nend;\r\n\r\nfunction TJclPeImportList.SmartFindName(const CompareName, LibName: string;\r\n  Options: TJclSmartCompOptions): TJclPeImportFuncItem;\r\nvar\r\n  L, I: Integer;\r\n  LibItem: TJclPeImportLibItem;\r\nbegin\r\n  Result := nil;\r\n  for L := 0 to Count - 1 do\r\n  begin\r\n    LibItem := Items[L];\r\n    if (Length(LibName) = 0) or (AnsiCompareText(LibItem.Name, LibName) = 0) then\r\n      for I := 0 to LibItem.Count - 1 do\r\n        if PeSmartFunctionNameSame(CompareName, LibItem[I].Name, Options) then\r\n        begin\r\n          Result := LibItem[I];\r\n          Break;\r\n        end;\r\n  end;\r\nend;\r\n\r\nprocedure TJclPeImportList.SortAllItemsList(SortType: TJclPeImportSort; Descending: Boolean);\r\nbegin\r\n  GetAllItemCount; // create list if it wasn't created\r\n  FAllItemsList.Sort(GetImportSortFunction(SortType, Descending));\r\n  FLastAllSortType := SortType;\r\n  FLastAllSortDescending := Descending;\r\nend;\r\n\r\nprocedure TJclPeImportList.SortList(SortType: TJclPeImportLibSort);\r\nbegin\r\n  Sort(GetImportLibSortFunction(SortType));\r\nend;\r\n\r\nprocedure TJclPeImportList.TryGetNamesForOrdinalImports;\r\nvar\r\n  LibNamesList: TStringList;\r\n  L, I: Integer;\r\n  LibPeDump: TJclPeImage;\r\n\r\n  procedure TryGetNames(const ModuleName: string);\r\n  var\r\n    Item: TJclPeImportFuncItem;\r\n    I, L: Integer;\r\n    ImportLibItem: TJclPeImportLibItem;\r\n    ExportItem: TJclPeExportFuncItem;\r\n    ExportList: TJclPeExportFuncList;\r\n  begin\r\n    if Image.AttachedImage then\r\n      LibPeDump.AttachLoadedModule(GetModuleHandle(PChar(ModuleName)))\r\n    else\r\n      LibPeDump.FileName := Image.ExpandModuleName(ModuleName);\r\n    if not LibPeDump.StatusOK then\r\n      Exit;\r\n    ExportList := LibPeDump.ExportList;\r\n    for L := 0 to Count - 1 do\r\n    begin\r\n      ImportLibItem := Items[L];\r\n      if AnsiCompareText(ImportLibItem.Name, ModuleName) = 0 then\r\n      begin\r\n        for I := 0 to ImportLibItem.Count - 1 do\r\n        begin\r\n          Item := ImportLibItem[I];\r\n          if Item.IsByOrdinal then\r\n          begin\r\n            ExportItem := ExportList.ItemFromOrdinal[Item.Ordinal];\r\n            if (ExportItem <> nil) and (ExportItem.Name <> '') then\r\n              Item.SetIndirectImportName(ExportItem.Name);\r\n          end;\r\n        end;\r\n        ImportLibItem.SetSorted(False);\r\n      end;\r\n    end;\r\n  end;\r\n\r\nbegin\r\n  LibNamesList := TStringList.Create;\r\n  try\r\n    LibNamesList.Sorted := True;\r\n    LibNamesList.Duplicates := dupIgnore;\r\n    for L := 0 to Count - 1 do\r\n      with Items[L] do\r\n        for I := 0 to Count - 1 do\r\n          if Items[I].IsByOrdinal then\r\n            LibNamesList.Add(AnsiUpperCase(Name));\r\n    LibPeDump := TJclPeImage.Create(True);\r\n    try\r\n      for I := 0 to LibNamesList.Count - 1 do\r\n        TryGetNames(LibNamesList[I]);\r\n    finally\r\n      LibPeDump.Free;\r\n    end;\r\n    SortAllItemsList(FLastAllSortType, FLastAllSortDescending);\r\n  finally\r\n    LibNamesList.Free;\r\n  end;\r\nend;\r\n\r\n//=== { TJclPeExportFuncItem } ===============================================\r\n\r\nconstructor TJclPeExportFuncItem.Create(AExportList: TJclPeExportFuncList;\r\n  const AName, AForwardedName: string; AAddress: DWORD; AHint: Word;\r\n  AOrdinal: Word; AResolveCheck: TJclPeResolveCheck);\r\nvar\r\n  DotPos: Integer;\r\nbegin\r\n  inherited Create;\r\n  FExportList := AExportList;\r\n  FName := AName;\r\n  FForwardedName := AForwardedName;\r\n  FAddress := AAddress;\r\n  FHint := AHint;\r\n  FOrdinal := AOrdinal;\r\n  FResolveCheck := AResolveCheck;\r\n\r\n  DotPos := AnsiPos('.', ForwardedName);\r\n  if DotPos > 0 then\r\n    FForwardedDotPos := Copy(ForwardedName, DotPos + 1, Length(ForwardedName) - DotPos)\r\n  else\r\n    FForwardedDotPos := '';\r\nend;\r\n\r\nfunction TJclPeExportFuncItem.GetAddressOrForwardStr: string;\r\nbegin\r\n  if IsForwarded then\r\n    Result := ForwardedName\r\n  else\r\n    FmtStr(Result, '%.8x', [Address]);\r\nend;\r\n\r\nfunction TJclPeExportFuncItem.GetForwardedFuncName: string;\r\nbegin\r\n  if (Length(FForwardedDotPos) > 0) and (FForwardedDotPos[1] <> '#') then\r\n    Result := FForwardedDotPos\r\n  else\r\n    Result := '';\r\nend;\r\n\r\nfunction TJclPeExportFuncItem.GetForwardedFuncOrdinal: DWORD;\r\nbegin\r\n  if (Length(FForwardedDotPos) > 0) and (FForwardedDotPos[1] = '#') then\r\n    Result := StrToIntDef(FForwardedDotPos, 0)\r\n  else\r\n    Result := 0;\r\nend;\r\n\r\nfunction TJclPeExportFuncItem.GetForwardedLibName: string;\r\nbegin\r\n  if Length(FForwardedDotPos) = 0 then\r\n    Result := ''\r\n  else\r\n    Result := AnsiLowerCase(Copy(FForwardedName, 1, Length(FForwardedName) - Length(FForwardedDotPos) - 1)) + BinaryExtensionLibrary;\r\nend;\r\n\r\nfunction TJclPeExportFuncItem.GetIsExportedVariable: Boolean;\r\nbegin\r\n  case FExportList.Image.Target of\r\n    taWin32:\r\n    begin\r\n      {$IFDEF DELPHI64_TEMPORARY}\r\n      System.Error(rePlatformNotImplemented);//there is no BaseOfData in the 32-bit header for Win64\r\n      Result := False;\r\n      {$ELSE ~DELPHI64_TEMPORARY}\r\n      Result := (Address >= FExportList.Image.OptionalHeader32.BaseOfData);\r\n      {$ENDIF ~DELPHI64_TEMPORARY}\r\n    end;\r\n    taWin64:\r\n      Result := False;\r\n      // TODO equivalent for 64-bit modules\r\n      //Result := (Address >= FExportList.Image.OptionalHeader64.BaseOfData);\r\n  else\r\n    Result := False;\r\n  end;\r\nend;\r\n\r\nfunction TJclPeExportFuncItem.GetIsForwarded: Boolean;\r\nbegin\r\n  Result := Length(FForwardedName) <> 0;\r\nend;\r\n\r\nfunction TJclPeExportFuncItem.GetMappedAddress: Pointer;\r\nbegin\r\n  Result := FExportList.Image.RvaToVa(FAddress);\r\nend;\r\n\r\nfunction TJclPeExportFuncItem.GetSectionName: string;\r\nbegin\r\n  if IsForwarded then\r\n    Result := ''\r\n  else\r\n    with FExportList.Image do\r\n      Result := ImageSectionNameFromRva[Address];\r\nend;\r\n\r\nprocedure TJclPeExportFuncItem.SetResolveCheck(Value: TJclPeResolveCheck);\r\nbegin\r\n  FResolveCheck := Value;\r\nend;\r\n\r\n// Export sort functions\r\nfunction ExportSortByName(Item1, Item2: Pointer): Integer;\r\nbegin\r\n  Result := CompareStr(TJclPeExportFuncItem(Item1).Name, TJclPeExportFuncItem(Item2).Name);\r\nend;\r\n\r\nfunction ExportSortByNameDESC(Item1, Item2: Pointer): Integer;\r\nbegin\r\n  Result := ExportSortByName(Item2, Item1);\r\nend;\r\n\r\nfunction ExportSortByOrdinal(Item1, Item2: Pointer): Integer;\r\nbegin\r\n  Result := TJclPeExportFuncItem(Item1).Ordinal - TJclPeExportFuncItem(Item2).Ordinal;\r\nend;\r\n\r\nfunction ExportSortByOrdinalDESC(Item1, Item2: Pointer): Integer;\r\nbegin\r\n  Result := ExportSortByOrdinal(Item2, Item1);\r\nend;\r\n\r\nfunction ExportSortByHint(Item1, Item2: Pointer): Integer;\r\nbegin\r\n  Result := TJclPeExportFuncItem(Item1).Hint - TJclPeExportFuncItem(Item2).Hint;\r\nend;\r\n\r\nfunction ExportSortByHintDESC(Item1, Item2: Pointer): Integer;\r\nbegin\r\n  Result := ExportSortByHint(Item2, Item1);\r\nend;\r\n\r\nfunction ExportSortByAddress(Item1, Item2: Pointer): Integer;\r\nbegin\r\n  Result := INT_PTR(TJclPeExportFuncItem(Item1).Address) - INT_PTR(TJclPeExportFuncItem(Item2).Address);\r\n  if Result = 0 then\r\n    Result := ExportSortByName(Item1, Item2);\r\nend;\r\n\r\nfunction ExportSortByAddressDESC(Item1, Item2: Pointer): Integer;\r\nbegin\r\n  Result := ExportSortByAddress(Item2, Item1);\r\nend;\r\n\r\nfunction ExportSortByForwarded(Item1, Item2: Pointer): Integer;\r\nbegin\r\n  Result := CompareStr(TJclPeExportFuncItem(Item1).ForwardedName, TJclPeExportFuncItem(Item2).ForwardedName);\r\n  if Result = 0 then\r\n    Result := ExportSortByName(Item1, Item2);\r\nend;\r\n\r\nfunction ExportSortByForwardedDESC(Item1, Item2: Pointer): Integer;\r\nbegin\r\n  Result := ExportSortByForwarded(Item2, Item1);\r\nend;\r\n\r\nfunction ExportSortByAddrOrFwd(Item1, Item2: Pointer): Integer;\r\nbegin\r\n  Result := CompareStr(TJclPeExportFuncItem(Item1).AddressOrForwardStr, TJclPeExportFuncItem(Item2).AddressOrForwardStr);\r\nend;\r\n\r\nfunction ExportSortByAddrOrFwdDESC(Item1, Item2: Pointer): Integer;\r\nbegin\r\n  Result := ExportSortByAddrOrFwd(Item2, Item1);\r\nend;\r\n\r\nfunction ExportSortBySection(Item1, Item2: Pointer): Integer;\r\nbegin\r\n  Result := CompareStr(TJclPeExportFuncItem(Item1).SectionName, TJclPeExportFuncItem(Item2).SectionName);\r\n  if Result = 0 then\r\n    Result := ExportSortByName(Item1, Item2);\r\nend;\r\n\r\nfunction ExportSortBySectionDESC(Item1, Item2: Pointer): Integer;\r\nbegin\r\n  Result := ExportSortBySection(Item2, Item1);\r\nend;\r\n\r\n//=== { TJclPeExportFuncList } ===============================================\r\n\r\nconstructor TJclPeExportFuncList.Create(AImage: TJclPeImage);\r\nbegin\r\n  inherited Create(AImage);\r\n  FTotalResolveCheck := icNotChecked;\r\n  CreateList;\r\nend;\r\n\r\ndestructor TJclPeExportFuncList.Destroy;\r\nbegin\r\n  FreeAndNil(FForwardedLibsList);\r\n  inherited Destroy;\r\nend;\r\n\r\nfunction TJclPeExportFuncList.CanPerformFastNameSearch: Boolean;\r\nbegin\r\n  Result := FSorted and (FLastSortType = esName) and not FLastSortDescending;\r\nend;\r\n\r\nprocedure TJclPeExportFuncList.CheckForwards(PeImageCache: TJclPeImagesCache);\r\nvar\r\n  I: Integer;\r\n  FullFileName: TFileName;\r\n  ForwardPeImage: TJclPeImage;\r\n  ModuleResolveCheck: TJclPeResolveCheck;\r\n\r\n  procedure PerformCheck(const ModuleName: string);\r\n  var\r\n    I: Integer;\r\n    Item: TJclPeExportFuncItem;\r\n    EL: TJclPeExportFuncList;\r\n  begin\r\n    EL := ForwardPeImage.ExportList;\r\n    EL.PrepareForFastNameSearch;\r\n    ModuleResolveCheck := icResolved;\r\n    for I := 0 to Count - 1 do\r\n    begin\r\n      Item := Items[I];\r\n      if (not Item.IsForwarded) or (Item.ResolveCheck <> icNotChecked) or\r\n        (Item.ForwardedLibName <> ModuleName) then\r\n        Continue;\r\n      if EL.ItemFromName[Item.ForwardedFuncName] = nil then\r\n      begin\r\n        Item.SetResolveCheck(icUnresolved);\r\n        ModuleResolveCheck := icUnresolved;\r\n      end\r\n      else\r\n        Item.SetResolveCheck(icResolved);\r\n    end;\r\n  end;\r\n\r\nbegin\r\n  if not AnyForwards then\r\n    Exit;\r\n  FTotalResolveCheck := icResolved;\r\n  if PeImageCache <> nil then\r\n    ForwardPeImage := nil // to make the compiler happy\r\n  else\r\n    ForwardPeImage := TJclPeImage.Create(True);\r\n  try\r\n    for I := 0 to ForwardedLibsList.Count - 1 do\r\n    begin\r\n      FullFileName := Image.ExpandModuleName(ForwardedLibsList[I]);\r\n      if PeImageCache <> nil then\r\n        ForwardPeImage := PeImageCache[FullFileName]\r\n      else\r\n        ForwardPeImage.FileName := FullFileName;\r\n      if ForwardPeImage.StatusOK then\r\n        PerformCheck(ForwardedLibsList[I])\r\n      else\r\n        ModuleResolveCheck := icUnresolved;\r\n      FForwardedLibsList.Objects[I] := Pointer(ModuleResolveCheck);\r\n      if ModuleResolveCheck = icUnresolved then\r\n        FTotalResolveCheck := icUnresolved;\r\n    end;\r\n  finally\r\n    if PeImageCache = nil then\r\n      ForwardPeImage.Free;\r\n  end;\r\nend;\r\n\r\nprocedure TJclPeExportFuncList.CreateList;\r\nvar\r\n  Functions: Pointer;\r\n  Address, NameCount: DWORD;\r\n  NameOrdinals: PWORD;\r\n  Names: PDWORD;\r\n  I: Integer;\r\n  ExportItem: TJclPeExportFuncItem;\r\n  ExportVABegin, ExportVAEnd: DWORD;\r\n  UTF8Name: TUTF8String;\r\n  ForwardedName, ExportName: string;\r\nbegin\r\n  with Image do\r\n  begin\r\n    if not StatusOK then\r\n      Exit;\r\n    with Directories[IMAGE_DIRECTORY_ENTRY_EXPORT] do\r\n    begin\r\n      ExportVABegin := VirtualAddress;\r\n      ExportVAEnd := VirtualAddress + TJclAddr(Size);\r\n    end;\r\n    FExportDir := DirectoryEntryToData(IMAGE_DIRECTORY_ENTRY_EXPORT);\r\n    if FExportDir <> nil then\r\n    begin\r\n      FBase := FExportDir^.Base;\r\n      FFunctionCount := FExportDir^.NumberOfFunctions;\r\n      Functions := RvaToVa(FExportDir^.AddressOfFunctions);\r\n      NameOrdinals := RvaToVa(FExportDir^.AddressOfNameOrdinals);\r\n      Names := RvaToVa(FExportDir^.AddressOfNames);\r\n      NameCount := FExportDir^.NumberOfNames;\r\n      Count := FExportDir^.NumberOfFunctions;\r\n\r\n      for I := 0 to Count - 1 do\r\n      begin\r\n        Address := PDWORD(TJclAddr(Functions) + TJclAddr(I) * SizeOf(DWORD))^;\r\n        if (Address >= ExportVABegin) and (Address <= ExportVAEnd) then\r\n        begin\r\n          FAnyForwards := True;\r\n          UTF8Name := PAnsiChar(RvaToVa(Address));\r\n          if not TryUTF8ToString(UTF8Name, ForwardedName) then\r\n            ForwardedName := string(UTF8Name);\r\n        end\r\n        else\r\n          ForwardedName := '';\r\n\r\n        ExportItem := TJclPeExportFuncItem.Create(Self, '',\r\n          ForwardedName, Address, $FFFF, TJclAddr(I) + FBase, icNotChecked);\r\n\r\n        List{$IFNDEF RTL230_UP}^{$ENDIF !RTL230_UP}[I] := ExportItem;\r\n      end;\r\n\r\n      for I := 0 to NameCount - 1 do\r\n      begin\r\n          // named function\r\n        UTF8Name := PAnsiChar(RvaToVa(Names^));\r\n        if not TryUTF8ToString(UTF8Name, ExportName) then\r\n          ExportName := string(UTF8Name);\r\n\r\n        ExportItem := TJclPeExportFuncItem(List{$IFNDEF RTL230_UP}^{$ENDIF !RTL230_UP}[NameOrdinals^]);\r\n        ExportItem.FName := ExportName;\r\n        ExportItem.FHint := I;\r\n\r\n        Inc(NameOrdinals);\r\n        Inc(Names);\r\n      end;\r\n    end;\r\n  end;\r\nend;\r\n\r\nfunction TJclPeExportFuncList.GetForwardedLibsList: TStrings;\r\nvar\r\n  I: Integer;\r\nbegin\r\n  if FForwardedLibsList = nil then\r\n  begin\r\n    FForwardedLibsList := TStringList.Create;\r\n    FForwardedLibsList.Sorted := True;\r\n    FForwardedLibsList.Duplicates := dupIgnore;\r\n    if FAnyForwards then\r\n      for I := 0 to Count - 1 do\r\n        with Items[I] do\r\n          if IsForwarded then\r\n            FForwardedLibsList.AddObject(ForwardedLibName, Pointer(icNotChecked));\r\n  end;\r\n  Result := FForwardedLibsList;\r\nend;\r\n\r\nfunction TJclPeExportFuncList.GetItemFromAddress(Address: DWORD): TJclPeExportFuncItem;\r\nvar\r\n  I: Integer;\r\nbegin\r\n  Result := nil;\r\n  for I := 0 to Count - 1 do\r\n    if Items[I].Address = Address then\r\n    begin\r\n      Result := Items[I];\r\n      Break;\r\n    end;\r\nend;\r\n\r\nfunction TJclPeExportFuncList.GetItemFromName(const Name: string): TJclPeExportFuncItem;\r\nvar\r\n  L, H, I, C: Integer;\r\n  B: Boolean;\r\nbegin\r\n  Result := nil;\r\n  if CanPerformFastNameSearch then\r\n  begin\r\n    L := 0;\r\n    H := Count - 1;\r\n    B := False;\r\n    while L <= H do\r\n    begin\r\n      I := (L + H) shr 1;\r\n      C := CompareStr(Items[I].Name, Name);\r\n      if C < 0 then\r\n        L := I + 1\r\n      else\r\n      begin\r\n        H := I - 1;\r\n        if C = 0 then\r\n        begin\r\n          B := True;\r\n          L := I;\r\n        end;\r\n      end;\r\n    end;\r\n    if B then\r\n      Result := Items[L];\r\n  end\r\n  else\r\n    for I := 0 to Count - 1 do\r\n      if Items[I].Name = Name then\r\n      begin\r\n        Result := Items[I];\r\n        Break;\r\n      end;\r\nend;\r\n\r\nfunction TJclPeExportFuncList.GetItemFromOrdinal(Ordinal: DWORD): TJclPeExportFuncItem;\r\nvar\r\n  I: Integer;\r\nbegin\r\n  Result := nil;\r\n  for I := 0 to Count - 1 do\r\n    if Items[I].Ordinal = Ordinal then\r\n    begin\r\n      Result := Items[I];\r\n      Break;\r\n    end;\r\nend;\r\n\r\nfunction TJclPeExportFuncList.GetItems(Index: Integer): TJclPeExportFuncItem;\r\nbegin\r\n  Result := TJclPeExportFuncItem(Get(Index));\r\nend;\r\n\r\nfunction TJclPeExportFuncList.GetName: string;\r\nvar\r\n  UTF8ExportName: TUTF8String;\r\nbegin\r\n  if (FExportDir = nil) or (FExportDir^.Name = 0) then\r\n    Result := ''\r\n  else\r\n  begin\r\n    UTF8ExportName := PAnsiChar(Image.RvaToVa(FExportDir^.Name));\r\n    if not TryUTF8ToString(UTF8ExportName, Result) then\r\n      Result := string(UTF8ExportName);\r\n  end;\r\nend;\r\n\r\nclass function TJclPeExportFuncList.ItemName(Item: TJclPeExportFuncItem): string;\r\nbegin\r\n  if Item = nil then\r\n    Result := ''\r\n  else\r\n    Result := Item.Name;\r\nend;\r\n\r\nfunction TJclPeExportFuncList.OrdinalValid(Ordinal: DWORD): Boolean;\r\nbegin\r\n  Result := (FExportDir <> nil) and (Ordinal >= Base) and\r\n    (Ordinal < FunctionCount + Base);\r\nend;\r\n\r\nprocedure TJclPeExportFuncList.PrepareForFastNameSearch;\r\nbegin\r\n  if not CanPerformFastNameSearch then\r\n    SortList(esName, False);\r\nend;\r\n\r\nfunction TJclPeExportFuncList.SmartFindName(const CompareName: string;\r\n  Options: TJclSmartCompOptions): TJclPeExportFuncItem;\r\nvar\r\n  I: Integer;\r\nbegin\r\n  Result := nil;\r\n  for I := 0 to Count - 1 do\r\n  begin\r\n    if PeSmartFunctionNameSame(CompareName, Items[I].Name, Options) then\r\n    begin\r\n      Result := Items[I];\r\n      Break;\r\n    end;\r\n  end;\r\nend;\r\n\r\nprocedure TJclPeExportFuncList.SortList(SortType: TJclPeExportSort; Descending: Boolean);\r\nconst\r\n  SortFunctions: array [TJclPeExportSort, Boolean] of TListSortCompare =\r\n    ((ExportSortByName, ExportSortByNameDESC),\r\n     (ExportSortByOrdinal, ExportSortByOrdinalDESC),\r\n     (ExportSortByHint, ExportSortByHintDESC),\r\n     (ExportSortByAddress, ExportSortByAddressDESC),\r\n     (ExportSortByForwarded, ExportSortByForwardedDESC),\r\n     (ExportSortByAddrOrFwd, ExportSortByAddrOrFwdDESC),\r\n     (ExportSortBySection, ExportSortBySectionDESC)\r\n    );\r\nbegin\r\n  if not FSorted or (SortType <> FLastSortType) or (Descending <> FLastSortDescending) then\r\n  begin\r\n    Sort(SortFunctions[SortType, Descending]);\r\n    FLastSortType := SortType;\r\n    FLastSortDescending := Descending;\r\n    FSorted := True;\r\n  end;\r\nend;\r\n\r\n//=== { TJclPeResourceRawStream } ============================================\r\n\r\nconstructor TJclPeResourceRawStream.Create(AResourceItem: TJclPeResourceItem);\r\nbegin\r\n  Assert(not AResourceItem.IsDirectory);\r\n  inherited Create;\r\n  SetPointer(AResourceItem.RawEntryData, AResourceItem.RawEntryDataSize);\r\nend;\r\n\r\nfunction TJclPeResourceRawStream.Write(const Buffer; Count: Integer): Longint;\r\nbegin\r\n  raise EJclPeImageError.CreateRes(@RsPeReadOnlyStream);\r\nend;\r\n\r\n//=== { TJclPeResourceItem } =================================================\r\n\r\nconstructor TJclPeResourceItem.Create(AImage: TJclPeImage;\r\n  AParentItem: TJclPeResourceItem; AEntry: PImageResourceDirectoryEntry);\r\nbegin\r\n  inherited Create;\r\n  FImage := AImage;\r\n  FEntry := AEntry;\r\n  FParentItem := AParentItem;\r\n  if AParentItem = nil then\r\n    FLevel := 1\r\n  else\r\n    FLevel := AParentItem.Level + 1;\r\nend;\r\n\r\ndestructor TJclPeResourceItem.Destroy;\r\nbegin\r\n  FreeAndNil(FList);\r\n  inherited Destroy;\r\nend;\r\n\r\nfunction TJclPeResourceItem.CompareName(AName: PChar): Boolean;\r\nvar\r\n  P: PChar;\r\nbegin\r\n  if IsName then\r\n    P := PChar(Name)\r\n  else\r\n    P := PChar(FEntry^.Name and $FFFF); // Integer encoded in a PChar\r\n  Result := CompareResourceName(AName, P);\r\nend;\r\n\r\nfunction TJclPeResourceItem.GetDataEntry: PImageResourceDataEntry;\r\nbegin\r\n  if GetIsDirectory then\r\n    Result := nil\r\n  else\r\n    Result := PImageResourceDataEntry(OffsetToRawData(FEntry^.OffsetToData));\r\nend;\r\n\r\nfunction TJclPeResourceItem.GetIsDirectory: Boolean;\r\nbegin\r\n  Result := FEntry^.OffsetToData and IMAGE_RESOURCE_DATA_IS_DIRECTORY <> 0;\r\nend;\r\n\r\nfunction TJclPeResourceItem.GetIsName: Boolean;\r\nbegin\r\n  Result := FEntry^.Name and IMAGE_RESOURCE_NAME_IS_STRING <> 0;\r\nend;\r\n\r\nfunction TJclPeResourceItem.GetLangID: LANGID;\r\nbegin\r\n  if IsDirectory then\r\n  begin\r\n    GetList;\r\n    if FList.Count = 1 then\r\n      Result := StrToIntDef(FList[0].Name, 0)\r\n    else\r\n      Result := 0;\r\n  end\r\n  else\r\n    Result := StrToIntDef(Name, 0);\r\nend;\r\n\r\nfunction TJclPeResourceItem.GetList: TJclPeResourceList;\r\nbegin\r\n  if not IsDirectory then\r\n  begin\r\n    if Image.NoExceptions then\r\n    begin\r\n      Result := nil;\r\n      Exit;\r\n    end\r\n    else\r\n      raise EJclPeImageError.CreateRes(@RsPeNotResDir);\r\n  end;\r\n  if FList = nil then\r\n    FList := FImage.ResourceListCreate(SubDirData, Self);\r\n  Result := FList;\r\nend;\r\n\r\nfunction TJclPeResourceItem.GetName: string;\r\nbegin\r\n  if IsName then\r\n  begin\r\n    if FNameCache = '' then\r\n    begin\r\n      with PImageResourceDirStringU(OffsetToRawData(FEntry^.Name))^ do\r\n        FNameCache := WideCharLenToString(NameString, Length);\r\n      StrResetLength(FNameCache);\r\n    end;\r\n    Result := FNameCache;\r\n  end\r\n  else\r\n    Result := IntToStr(FEntry^.Name and $FFFF);\r\nend;\r\n\r\nfunction TJclPeResourceItem.GetParameterName: string;\r\nbegin\r\n  if IsName then\r\n    Result := Name\r\n  else\r\n    Result := Format('#%d', [FEntry^.Name and $FFFF]);\r\nend;\r\n\r\nfunction TJclPeResourceItem.GetRawEntryData: Pointer;\r\nbegin\r\n  if GetIsDirectory then\r\n    Result := nil\r\n  else\r\n    Result := FImage.RvaToVa(GetDataEntry^.OffsetToData);\r\nend;\r\n\r\nfunction TJclPeResourceItem.GetRawEntryDataSize: Integer;\r\nbegin\r\n  if GetIsDirectory then\r\n    Result := -1\r\n  else\r\n    Result := PImageResourceDataEntry(OffsetToRawData(FEntry^.OffsetToData))^.Size;\r\nend;\r\n\r\nfunction TJclPeResourceItem.GetResourceType: TJclPeResourceKind;\r\nbegin\r\n  with Level1Item do\r\n  begin\r\n    if FEntry^.Name < Cardinal(High(TJclPeResourceKind)) then\r\n      Result := TJclPeResourceKind(FEntry^.Name)\r\n    else\r\n      Result := rtUserDefined\r\n  end;\r\nend;\r\n\r\nfunction TJclPeResourceItem.GetResourceTypeStr: string;\r\nbegin\r\n  with Level1Item do\r\n  begin\r\n    if FEntry^.Name < Cardinal(High(TJclPeResourceKind)) then\r\n      Result := Copy(GetEnumName(TypeInfo(TJclPeResourceKind), Ord(FEntry^.Name)), 3, 30)\r\n    else\r\n      Result := Name;\r\n  end;\r\nend;\r\n\r\nfunction TJclPeResourceItem.Level1Item: TJclPeResourceItem;\r\nbegin\r\n  Result := Self;\r\n  while Result.FParentItem <> nil do\r\n    Result := Result.FParentItem;\r\nend;\r\n\r\nfunction TJclPeResourceItem.OffsetToRawData(Ofs: DWORD): TJclAddr;\r\nbegin\r\n  Result := (Ofs and $7FFFFFFF) + Image.ResourceVA;\r\nend;\r\n\r\nfunction TJclPeResourceItem.SubDirData: PImageResourceDirectory;\r\nbegin\r\n  Result := Pointer(OffsetToRawData(FEntry^.OffsetToData));\r\nend;\r\n\r\n//=== { TJclPeResourceList } =================================================\r\n\r\nconstructor TJclPeResourceList.Create(AImage: TJclPeImage;\r\n  AParentItem: TJclPeResourceItem; ADirectory: PImageResourceDirectory);\r\nbegin\r\n  inherited Create(AImage);\r\n  FDirectory := ADirectory;\r\n  FParentItem := AParentItem;\r\n  CreateList(AParentItem);\r\nend;\r\n\r\nprocedure TJclPeResourceList.CreateList(AParentItem: TJclPeResourceItem);\r\nvar\r\n  Entry: PImageResourceDirectoryEntry;\r\n  DirItem: TJclPeResourceItem;\r\n  I: Integer;\r\nbegin\r\n  if FDirectory = nil then\r\n    Exit;\r\n  Entry := Pointer(TJclAddr(FDirectory) + SizeOf(TImageResourceDirectory));\r\n  for I := 1 to DWORD(FDirectory^.NumberOfNamedEntries) + DWORD(FDirectory^.NumberOfIdEntries) do\r\n  begin\r\n    DirItem := Image.ResourceItemCreate(Entry, AParentItem);\r\n    Add(DirItem);\r\n    Inc(Entry);\r\n  end;\r\nend;\r\n\r\nfunction TJclPeResourceList.FindName(const Name: string): TJclPeResourceItem;\r\nvar\r\n  I: Integer;\r\nbegin\r\n  Result := nil;\r\n  for I := 0 to Count - 1 do\r\n    if StrSame(Items[I].Name, Name) then\r\n    begin\r\n      Result := Items[I];\r\n      Break;\r\n    end;\r\nend;\r\n\r\nfunction TJclPeResourceList.GetItems(Index: Integer): TJclPeResourceItem;\r\nbegin\r\n  Result := TJclPeResourceItem(Get(Index));\r\nend;\r\n\r\n//=== { TJclPeRootResourceList } =============================================\r\n\r\ndestructor TJclPeRootResourceList.Destroy;\r\nbegin\r\n  FreeAndNil(FManifestContent);\r\n  inherited Destroy;\r\nend;\r\n\r\nfunction TJclPeRootResourceList.FindResource(ResourceType: TJclPeResourceKind;\r\n  const ResourceName: string): TJclPeResourceItem;\r\nvar\r\n  I: Integer;\r\n  TypeItem: TJclPeResourceItem;\r\nbegin\r\n  Result := nil;\r\n  TypeItem := nil;\r\n  for I := 0 to Count - 1 do\r\n  begin\r\n    if Items[I].ResourceType = ResourceType then\r\n    begin\r\n      TypeItem := Items[I];\r\n      Break;\r\n    end;\r\n  end;\r\n  if TypeItem <> nil then\r\n    if ResourceName = '' then\r\n      Result := TypeItem\r\n    else\r\n      with TypeItem.List do\r\n        for I := 0 to Count - 1 do\r\n          if Items[I].Name = ResourceName then\r\n          begin\r\n            Result := Items[I];\r\n            Break;\r\n          end;\r\nend;\r\n\r\nfunction TJclPeRootResourceList.FindResource(const ResourceType: PChar;\r\n  const ResourceName: PChar): TJclPeResourceItem;\r\nvar\r\n  I: Integer;\r\n  TypeItem: TJclPeResourceItem;\r\nbegin\r\n  Result := nil;\r\n  TypeItem := nil;\r\n  for I := 0 to Count - 1 do\r\n    if Items[I].CompareName(ResourceType) then\r\n    begin\r\n      TypeItem := Items[I];\r\n      Break;\r\n    end;\r\n  if TypeItem <> nil then\r\n    if ResourceName = nil then\r\n      Result := TypeItem\r\n    else\r\n      with TypeItem.List do\r\n        for I := 0 to Count - 1 do\r\n          if Items[I].CompareName(ResourceName) then\r\n          begin\r\n            Result := Items[I];\r\n            Break;\r\n          end;\r\nend;\r\n\r\nfunction TJclPeRootResourceList.GetManifestContent: TStrings;\r\nvar\r\n  ManifestFileName: string;\r\n  ResItem: TJclPeResourceItem;\r\n  ResStream: TJclPeResourceRawStream;\r\nbegin\r\n  if FManifestContent = nil then\r\n  begin\r\n    FManifestContent := TStringList.Create;\r\n    ResItem := FindResource(RT_MANIFEST, CREATEPROCESS_MANIFEST_RESOURCE_ID);\r\n    if ResItem = nil then\r\n    begin\r\n      ManifestFileName := Image.FileName + MANIFESTExtension;\r\n      if FileExists(ManifestFileName) then\r\n        FManifestContent.LoadFromFile(ManifestFileName);\r\n    end\r\n    else\r\n    begin\r\n      ResStream := TJclPeResourceRawStream.Create(ResItem.List[0]);\r\n      try\r\n        FManifestContent.LoadFromStream(ResStream);\r\n      finally\r\n        ResStream.Free;\r\n      end;\r\n    end;\r\n  end;\r\n  Result := FManifestContent;\r\nend;\r\n\r\nfunction TJclPeRootResourceList.ListResourceNames(ResourceType: TJclPeResourceKind;\r\n  const Strings: TStrings): Boolean;\r\nvar\r\n  ResTypeItem, TempItem: TJclPeResourceItem;\r\n  I: Integer;\r\nbegin\r\n  ResTypeItem := FindResource(ResourceType, '');\r\n  Result := (ResTypeItem <> nil);\r\n  if Result then\r\n  begin\r\n    Strings.BeginUpdate;\r\n    try\r\n      with ResTypeItem.List do\r\n        for I := 0 to Count - 1 do\r\n        begin\r\n          TempItem := Items[I];\r\n          Strings.AddObject(TempItem.Name, Pointer(TempItem.IsName));\r\n        end;\r\n    finally\r\n      Strings.EndUpdate;\r\n    end;\r\n  end;\r\nend;\r\n\r\n//=== { TJclPeRelocEntry } ===================================================\r\n\r\nconstructor TJclPeRelocEntry.Create(AChunk: PImageBaseRelocation; ACount: Integer);\r\nbegin\r\n  inherited Create;\r\n  FChunk := AChunk;\r\n  FCount := ACount;\r\nend;\r\n\r\nfunction TJclPeRelocEntry.GetRelocations(Index: Integer): TJclPeRelocation;\r\nvar\r\n  Temp: Word;\r\nbegin\r\n  Temp := PWord(TJclAddr(FChunk) + SizeOf(TImageBaseRelocation) + DWORD(Index) * SizeOf(Word))^;\r\n  Result.Address := Temp and $0FFF;\r\n  Result.RelocType := (Temp and $F000) shr 12;\r\n  Result.VirtualAddress := TJclAddr(Result.Address) + VirtualAddress;\r\nend;\r\n\r\nfunction TJclPeRelocEntry.GetSize: DWORD;\r\nbegin\r\n  Result := FChunk^.SizeOfBlock;\r\nend;\r\n\r\nfunction TJclPeRelocEntry.GetVirtualAddress: DWORD;\r\nbegin\r\n  Result := FChunk^.VirtualAddress;\r\nend;\r\n\r\n//=== { TJclPeRelocList } ====================================================\r\n\r\nconstructor TJclPeRelocList.Create(AImage: TJclPeImage);\r\nbegin\r\n  inherited Create(AImage);\r\n  CreateList;\r\nend;\r\n\r\nprocedure TJclPeRelocList.CreateList;\r\nvar\r\n  Chunk: PImageBaseRelocation;\r\n  Item: TJclPeRelocEntry;\r\n  RelocCount: Integer;\r\nbegin\r\n  with Image do\r\n  begin\r\n    if not StatusOK then\r\n      Exit;\r\n    Chunk := DirectoryEntryToData(IMAGE_DIRECTORY_ENTRY_BASERELOC);\r\n    if Chunk = nil then\r\n      Exit;\r\n    FAllItemCount := 0;\r\n    while Chunk^.SizeOfBlock <> 0 do\r\n    begin\r\n      RelocCount := (Chunk^.SizeOfBlock - SizeOf(TImageBaseRelocation)) div SizeOf(Word);\r\n      Item := TJclPeRelocEntry.Create(Chunk, RelocCount);\r\n      Inc(FAllItemCount, RelocCount);\r\n      Add(Item);\r\n      Chunk := Pointer(TJclAddr(Chunk) + Chunk^.SizeOfBlock);\r\n    end;\r\n  end;\r\nend;\r\n\r\nfunction TJclPeRelocList.GetAllItems(Index: Integer): TJclPeRelocation;\r\nvar\r\n  I, N, C: Integer;\r\nbegin\r\n  N := Index;\r\n  for I := 0 to Count - 1 do\r\n  begin\r\n    C := Items[I].Count;\r\n    Dec(N, C);\r\n    if N < 0 then\r\n    begin\r\n      Result := Items[I][N + C];\r\n      Break;\r\n    end;\r\n  end;\r\nend;\r\n\r\nfunction TJclPeRelocList.GetItems(Index: Integer): TJclPeRelocEntry;\r\nbegin\r\n  Result := TJclPeRelocEntry(Get(Index));\r\nend;\r\n\r\n//=== { TJclPeDebugList } ====================================================\r\n\r\nconstructor TJclPeDebugList.Create(AImage: TJclPeImage);\r\nbegin\r\n  inherited Create(AImage);\r\n  OwnsObjects := False;\r\n  CreateList;\r\nend;\r\n\r\nprocedure TJclPeDebugList.CreateList;\r\nvar\r\n  DebugImageDir: TImageDataDirectory;\r\n  DebugDir: PImageDebugDirectory;\r\n  Header: PImageSectionHeader;\r\n  FormatCount, I: Integer;\r\nbegin\r\n  with Image do\r\n  begin\r\n    if not StatusOK then\r\n      Exit;\r\n    DebugImageDir := Directories[IMAGE_DIRECTORY_ENTRY_DEBUG];\r\n    if DebugImageDir.VirtualAddress = 0 then\r\n      Exit;\r\n    if GetSectionHeader(DebugSectionName, Header) and\r\n      (Header^.VirtualAddress = DebugImageDir.VirtualAddress) then\r\n    begin\r\n      FormatCount := DebugImageDir.Size;\r\n      DebugDir := RvaToVa(Header^.VirtualAddress);\r\n    end\r\n    else\r\n    begin\r\n      if not GetSectionHeader(ReadOnlySectionName, Header) then\r\n        Exit;\r\n      FormatCount := DebugImageDir.Size div SizeOf(TImageDebugDirectory);\r\n      DebugDir := Pointer(MappedAddress + DebugImageDir.VirtualAddress -\r\n        Header^.VirtualAddress + Header^.PointerToRawData);\r\n    end;\r\n    for I := 1 to FormatCount do\r\n    begin\r\n      Add(TObject(DebugDir));\r\n      Inc(DebugDir);\r\n    end;\r\n  end;\r\nend;\r\n\r\nfunction TJclPeDebugList.GetItems(Index: Integer): TImageDebugDirectory;\r\nbegin\r\n  Result := PImageDebugDirectory(Get(Index))^;\r\nend;\r\n\r\n//=== { TJclPeCertificate } ==================================================\r\n\r\nconstructor TJclPeCertificate.Create(AHeader: TWinCertificate; AData: Pointer);\r\nbegin\r\n  inherited Create;\r\n  FHeader := AHeader;\r\n  FData := AData;\r\nend;\r\n\r\n//=== { TJclPeCertificateList } ==============================================\r\n\r\nconstructor TJclPeCertificateList.Create(AImage: TJclPeImage);\r\nbegin\r\n  inherited Create(AImage);\r\n  CreateList;\r\nend;\r\n\r\nprocedure TJclPeCertificateList.CreateList;\r\nvar\r\n  Directory: TImageDataDirectory;\r\n  CertPtr: PChar;\r\n  TotalSize: Integer;\r\n  Item: TJclPeCertificate;\r\nbegin\r\n  Directory := Image.Directories[IMAGE_DIRECTORY_ENTRY_SECURITY];\r\n  if Directory.VirtualAddress = 0 then\r\n    Exit;\r\n  CertPtr := Image.RawToVa(Directory.VirtualAddress); // Security directory is a raw offset\r\n  TotalSize := Directory.Size;\r\n  while TotalSize >= SizeOf(TWinCertificate) do\r\n  begin\r\n    Item := TJclPeCertificate.Create(PWinCertificate(CertPtr)^, CertPtr + SizeOf(TWinCertificate));\r\n    Dec(TotalSize, Item.Header.dwLength);\r\n    Add(Item);\r\n  end;\r\nend;\r\n\r\nfunction TJclPeCertificateList.GetItems(Index: Integer): TJclPeCertificate;\r\nbegin\r\n  Result := TJclPeCertificate(Get(Index));\r\nend;\r\n\r\n//=== { TJclPeCLRHeader } ====================================================\r\n\r\nconstructor TJclPeCLRHeader.Create(AImage: TJclPeImage);\r\nbegin\r\n  FImage := AImage;\r\n  ReadHeader;\r\nend;\r\n\r\nfunction TJclPeCLRHeader.GetHasMetadata: Boolean;\r\nconst\r\n  METADATA_SIGNATURE = $424A5342; // Reference: Partition II Metadata.doc - 23.2.1 Metadata root\r\nbegin\r\n  with Header.MetaData do\r\n    Result := (VirtualAddress <> 0) and (PDWORD(FImage.RvaToVa(VirtualAddress))^ = METADATA_SIGNATURE);\r\nend;\r\n{ TODO -cDOC : \"Flier Lu\"  }\r\n\r\nfunction TJclPeCLRHeader.GetVersionString: string;\r\nbegin\r\n  Result := FormatVersionString(Header.MajorRuntimeVersion, Header.MinorRuntimeVersion);\r\nend;\r\n\r\nprocedure TJclPeCLRHeader.ReadHeader;\r\nvar\r\n  HeaderPtr: PImageCor20Header;\r\nbegin\r\n  HeaderPtr := Image.DirectoryEntryToData(IMAGE_DIRECTORY_ENTRY_COM_DESCRIPTOR);\r\n  if (HeaderPtr <> nil) and (HeaderPtr^.cb >= SizeOf(TImageCor20Header)) then\r\n    FHeader := HeaderPtr^;\r\nend;\r\n\r\n//=== { TJclPeImage } ========================================================\r\n\r\nconstructor TJclPeImage.Create(ANoExceptions: Boolean);\r\nbegin\r\n  FNoExceptions := ANoExceptions;\r\n  FReadOnlyAccess := True;\r\n  FImageSections := TStringList.Create;\r\n  FStringTable := TStringList.Create;\r\nend;\r\n\r\ndestructor TJclPeImage.Destroy;\r\nbegin\r\n  Clear;\r\n  FreeAndNil(FImageSections);\r\n  FStringTable.Free;\r\n\r\n  inherited Destroy;\r\nend;\r\n\r\nprocedure TJclPeImage.AfterOpen;\r\nbegin\r\nend;\r\n\r\nprocedure TJclPeImage.AttachLoadedModule(const Handle: HMODULE);\r\n  procedure AttachLoadedModule32;\r\n  var\r\n    NtHeaders: PImageNtHeaders32;\r\n  begin\r\n    NtHeaders := PeMapImgNtHeaders32(Pointer(Handle));\r\n    if NtHeaders = nil then\r\n      FStatus := stNotPE\r\n    else\r\n    begin\r\n      FStatus := stOk;\r\n      FAttachedImage := True;\r\n      FFileName := GetModulePath(Handle);\r\n      // OF: possible loss of data\r\n      FLoadedImage.ModuleName := PAnsiChar(AnsiString(FFileName));\r\n      FLoadedImage.hFile := INVALID_HANDLE_VALUE;\r\n      FLoadedImage.MappedAddress := Pointer(Handle);\r\n      FLoadedImage.FileHeader := PImageNtHeaders(NtHeaders);\r\n      FLoadedImage.NumberOfSections := NtHeaders^.FileHeader.NumberOfSections;\r\n      FLoadedImage.Sections := PeMapImgSections32(NtHeaders);\r\n      FLoadedImage.LastRvaSection := FLoadedImage.Sections;\r\n      FLoadedImage.Characteristics := NtHeaders^.FileHeader.Characteristics;\r\n      FLoadedImage.fSystemImage := (FLoadedImage.Characteristics and IMAGE_FILE_SYSTEM <> 0);\r\n      FLoadedImage.fDOSImage := False;\r\n      FLoadedImage.SizeOfImage := NtHeaders^.OptionalHeader.SizeOfImage;\r\n      ReadImageSections;\r\n      ReadStringTable;\r\n      AfterOpen;\r\n    end;\r\n    RaiseStatusException;\r\n  end;\r\n\r\n  procedure AttachLoadedModule64;\r\n   var\r\n    NtHeaders: PImageNtHeaders64;\r\n  begin\r\n    NtHeaders := PeMapImgNtHeaders64(Pointer(Handle));\r\n    if NtHeaders = nil then\r\n      FStatus := stNotPE\r\n    else\r\n    begin\r\n      FStatus := stOk;\r\n      FAttachedImage := True;\r\n      FFileName := GetModulePath(Handle);\r\n      // OF: possible loss of data\r\n      FLoadedImage.ModuleName := PAnsiChar(AnsiString(FFileName));\r\n      FLoadedImage.hFile := INVALID_HANDLE_VALUE;\r\n      FLoadedImage.MappedAddress := Pointer(Handle);\r\n      FLoadedImage.FileHeader := PImageNtHeaders(NtHeaders);\r\n      FLoadedImage.NumberOfSections := NtHeaders^.FileHeader.NumberOfSections;\r\n      FLoadedImage.Sections := PeMapImgSections64(NtHeaders);\r\n      FLoadedImage.LastRvaSection := FLoadedImage.Sections;\r\n      FLoadedImage.Characteristics := NtHeaders^.FileHeader.Characteristics;\r\n      FLoadedImage.fSystemImage := (FLoadedImage.Characteristics and IMAGE_FILE_SYSTEM <> 0);\r\n      FLoadedImage.fDOSImage := False;\r\n      FLoadedImage.SizeOfImage := NtHeaders^.OptionalHeader.SizeOfImage;\r\n      ReadImageSections;\r\n      ReadStringTable;\r\n      AfterOpen;\r\n    end;\r\n    RaiseStatusException;\r\n  end;\r\nbegin\r\n  Clear;\r\n  if Handle = 0 then\r\n    Exit;\r\n  FTarget := PeMapImgTarget(Pointer(Handle));\r\n  case Target of\r\n    taWin32:\r\n      AttachLoadedModule32;\r\n    taWin64:\r\n      AttachLoadedModule64;\r\n    taUnknown:\r\n      FStatus := stNotSupported;\r\n  end;\r\nend;\r\n\r\nfunction TJclPeImage.CalculateCheckSum: DWORD;\r\nvar\r\n  C: DWORD;\r\nbegin\r\n  if StatusOK then\r\n  begin\r\n    CheckNotAttached;\r\n    if CheckSumMappedFile(FLoadedImage.MappedAddress, FLoadedImage.SizeOfImage,\r\n      C, Result) = nil then\r\n        RaiseLastOSError;\r\n  end\r\n  else\r\n    Result := 0;\r\nend;\r\n\r\nprocedure TJclPeImage.CheckNotAttached;\r\nbegin\r\n  if FAttachedImage then\r\n    raise EJclPeImageError.CreateRes(@RsPeNotAvailableForAttached);\r\nend;\r\n\r\nprocedure TJclPeImage.Clear;\r\nbegin\r\n  FImageSections.Clear;\r\n  FStringTable.Clear;\r\n  FreeAndNil(FCertificateList);\r\n  FreeAndNil(FCLRHeader);\r\n  FreeAndNil(FDebugList);\r\n  FreeAndNil(FImportList);\r\n  FreeAndNil(FExportList);\r\n  FreeAndNil(FRelocationList);\r\n  FreeAndNil(FResourceList);\r\n  FreeAndNil(FVersionInfo);\r\n  if not FAttachedImage and StatusOK then\r\n    UnMapAndLoad(FLoadedImage);\r\n  ResetMemory(FLoadedImage, SizeOf(FLoadedImage));\r\n  FStatus := stNotLoaded;\r\n  FAttachedImage := False;\r\nend;\r\n\r\nclass function TJclPeImage.DateTimeToStamp(const DateTime: TDateTime): DWORD;\r\nbegin\r\n  Result := Round((DateTime - UnixTimeStart) * SecsPerDay);\r\nend;\r\n\r\nclass function TJclPeImage.DebugTypeNames(DebugType: DWORD): string;\r\nbegin\r\n  case DebugType of\r\n    IMAGE_DEBUG_TYPE_UNKNOWN:\r\n      Result := LoadResString(@RsPeDEBUG_UNKNOWN);\r\n    IMAGE_DEBUG_TYPE_COFF:\r\n      Result := LoadResString(@RsPeDEBUG_COFF);\r\n    IMAGE_DEBUG_TYPE_CODEVIEW:\r\n      Result := LoadResString(@RsPeDEBUG_CODEVIEW);\r\n    IMAGE_DEBUG_TYPE_FPO:\r\n      Result := LoadResString(@RsPeDEBUG_FPO);\r\n    IMAGE_DEBUG_TYPE_MISC:\r\n      Result := LoadResString(@RsPeDEBUG_MISC);\r\n    IMAGE_DEBUG_TYPE_EXCEPTION:\r\n      Result := LoadResString(@RsPeDEBUG_EXCEPTION);\r\n    IMAGE_DEBUG_TYPE_FIXUP:\r\n      Result := LoadResString(@RsPeDEBUG_FIXUP);\r\n    IMAGE_DEBUG_TYPE_OMAP_TO_SRC:\r\n      Result := LoadResString(@RsPeDEBUG_OMAP_TO_SRC);\r\n    IMAGE_DEBUG_TYPE_OMAP_FROM_SRC:\r\n      Result := LoadResString(@RsPeDEBUG_OMAP_FROM_SRC);\r\n  else\r\n    Result := LoadResString(@RsPeDEBUG_UNKNOWN);\r\n  end;\r\nend;\r\n\r\nfunction TJclPeImage.DirectoryEntryToData(Directory: Word): Pointer;\r\nvar\r\n  Size: DWORD;\r\nbegin\r\n  Size := 0;\r\n  Result := ImageDirectoryEntryToData(FLoadedImage.MappedAddress, FAttachedImage, Directory, Size);\r\nend;\r\n\r\nclass function TJclPeImage.DirectoryNames(Directory: Word): string;\r\nbegin\r\n  case Directory of\r\n    IMAGE_DIRECTORY_ENTRY_EXPORT:\r\n      Result := LoadResString(@RsPeImg_00);\r\n    IMAGE_DIRECTORY_ENTRY_IMPORT:\r\n      Result := LoadResString(@RsPeImg_01);\r\n    IMAGE_DIRECTORY_ENTRY_RESOURCE:\r\n      Result := LoadResString(@RsPeImg_02);\r\n    IMAGE_DIRECTORY_ENTRY_EXCEPTION:\r\n      Result := LoadResString(@RsPeImg_03);\r\n    IMAGE_DIRECTORY_ENTRY_SECURITY:\r\n      Result := LoadResString(@RsPeImg_04);\r\n    IMAGE_DIRECTORY_ENTRY_BASERELOC:\r\n      Result := LoadResString(@RsPeImg_05);\r\n    IMAGE_DIRECTORY_ENTRY_DEBUG:\r\n      Result := LoadResString(@RsPeImg_06);\r\n    IMAGE_DIRECTORY_ENTRY_COPYRIGHT:\r\n      Result := LoadResString(@RsPeImg_07);\r\n    IMAGE_DIRECTORY_ENTRY_GLOBALPTR:\r\n      Result := LoadResString(@RsPeImg_08);\r\n    IMAGE_DIRECTORY_ENTRY_TLS:\r\n      Result := LoadResString(@RsPeImg_09);\r\n    IMAGE_DIRECTORY_ENTRY_LOAD_CONFIG:\r\n      Result := LoadResString(@RsPeImg_10);\r\n    IMAGE_DIRECTORY_ENTRY_BOUND_IMPORT:\r\n      Result := LoadResString(@RsPeImg_11);\r\n    IMAGE_DIRECTORY_ENTRY_IAT:\r\n      Result := LoadResString(@RsPeImg_12);\r\n    IMAGE_DIRECTORY_ENTRY_DELAY_IMPORT:\r\n      Result := LoadResString(@RsPeImg_13);\r\n    IMAGE_DIRECTORY_ENTRY_COM_DESCRIPTOR:\r\n      Result := LoadResString(@RsPeImg_14);\r\n  else\r\n    Result := Format(LoadResString(@RsPeImg_Reserved), [Directory]);\r\n  end;\r\nend;\r\n\r\nclass function TJclPeImage.ExpandBySearchPath(const ModuleName, BasePath: string): TFileName;\r\nvar\r\n  FullName: array [0..MAX_PATH] of Char;\r\n  FilePart: PChar;\r\nbegin\r\n  Result := PathAddSeparator(ExtractFilePath(BasePath)) + ModuleName;\r\n  if FileExists(Result) then\r\n    Exit;\r\n  FilePart := nil;\r\n  if SearchPath(nil, PChar(ModuleName), nil, Length(FullName), FullName, FilePart) = 0 then\r\n    Result := ModuleName\r\n  else\r\n    Result := FullName;\r\nend;\r\n\r\nfunction TJclPeImage.ExpandModuleName(const ModuleName: string): TFileName;\r\nbegin\r\n  Result := ExpandBySearchPath(ModuleName, ExtractFilePath(FFileName));\r\nend;\r\n\r\nfunction TJclPeImage.GetCertificateList: TJclPeCertificateList;\r\nbegin\r\n  if FCertificateList = nil then\r\n    FCertificateList := TJclPeCertificateList.Create(Self);\r\n  Result := FCertificateList;\r\nend;\r\n\r\nfunction TJclPeImage.GetCLRHeader: TJclPeCLRHeader;\r\nbegin\r\n  if FCLRHeader = nil then\r\n    FCLRHeader := TJclPeCLRHeader.Create(Self);\r\n  Result := FCLRHeader;\r\nend;\r\n\r\nfunction TJclPeImage.GetDebugList: TJclPeDebugList;\r\nbegin\r\n  if FDebugList = nil then\r\n    FDebugList := TJclPeDebugList.Create(Self);\r\n  Result := FDebugList;\r\nend;\r\n\r\nfunction TJclPeImage.GetDescription: string;\r\nvar\r\n  UTF8DescriptionName: TUTF8String;\r\nbegin\r\n  if DirectoryExists[IMAGE_DIRECTORY_ENTRY_COPYRIGHT] then\r\n  begin\r\n    UTF8DescriptionName := PAnsiChar(DirectoryEntryToData(IMAGE_DIRECTORY_ENTRY_COPYRIGHT));\r\n    if not TryUTF8ToString(UTF8DescriptionName, Result) then\r\n      Result := string(UTF8DescriptionName);\r\n  end\r\n  else\r\n    Result := '';\r\nend;\r\n\r\nfunction TJclPeImage.GetDirectories(Directory: Word): TImageDataDirectory;\r\nbegin\r\n  if StatusOK then\r\n  begin\r\n    case Target of\r\n      taWin32:\r\n        Result := PImageNtHeaders32(FLoadedImage.FileHeader)^.OptionalHeader.DataDirectory[Directory];\r\n      taWin64:\r\n        Result := PImageNtHeaders64(FLoadedImage.FileHeader)^.OptionalHeader.DataDirectory[Directory];\r\n    else\r\n      Result.VirtualAddress := 0;\r\n      Result.Size := 0;\r\n    end\r\n  end\r\n  else\r\n  begin\r\n    Result.VirtualAddress := 0;\r\n    Result.Size := 0;\r\n  end;\r\nend;\r\n\r\nfunction TJclPeImage.GetDirectoryExists(Directory: Word): Boolean;\r\nbegin\r\n  Result := (Directories[Directory].VirtualAddress <> 0);\r\nend;\r\n\r\nfunction TJclPeImage.GetExportList: TJclPeExportFuncList;\r\nbegin\r\n  if FExportList = nil then\r\n    FExportList := TJclPeExportFuncList.Create(Self);\r\n  Result := FExportList;\r\nend;\r\n\r\nfunction TJclPeImage.GetFileProperties: TJclPeFileProperties;\r\nvar\r\n  FileAttributesEx: WIN32_FILE_ATTRIBUTE_DATA;\r\n  Size: TJclULargeInteger;\r\nbegin\r\n  ResetMemory(Result, SizeOf(Result));\r\n  if GetFileAttributesEx(PChar(FileName), GetFileExInfoStandard, @FileAttributesEx) then\r\n  begin\r\n    Size.LowPart := FileAttributesEx.nFileSizeLow;\r\n    Size.HighPart := FileAttributesEx.nFileSizeHigh;\r\n    Result.Size := Size.QuadPart;\r\n    Result.CreationTime := FileTimeToLocalDateTime(FileAttributesEx.ftCreationTime);\r\n    Result.LastAccessTime := FileTimeToLocalDateTime(FileAttributesEx.ftLastAccessTime);\r\n    Result.LastWriteTime := FileTimeToLocalDateTime(FileAttributesEx.ftLastWriteTime);\r\n    Result.Attributes := FileAttributesEx.dwFileAttributes;\r\n  end;\r\nend;\r\n\r\nfunction TJclPeImage.GetHeaderValues(Index: TJclPeHeader): string;\r\n\r\n  function GetMachineString(Value: DWORD): string;\r\n  begin\r\n    case Value of\r\n      IMAGE_FILE_MACHINE_UNKNOWN:\r\n        Result := LoadResString(@RsPeMACHINE_UNKNOWN);\r\n      IMAGE_FILE_MACHINE_I386:\r\n        Result := LoadResString(@RsPeMACHINE_I386);\r\n      IMAGE_FILE_MACHINE_R3000:\r\n        Result := LoadResString(@RsPeMACHINE_R3000);\r\n      IMAGE_FILE_MACHINE_R4000:\r\n        Result := LoadResString(@RsPeMACHINE_R4000);\r\n      IMAGE_FILE_MACHINE_R10000:\r\n        Result := LoadResString(@RsPeMACHINE_R10000);\r\n      IMAGE_FILE_MACHINE_WCEMIPSV2:\r\n        Result := LoadResString(@RsPeMACHINE_WCEMIPSV2);\r\n      IMAGE_FILE_MACHINE_ALPHA:\r\n        Result := LoadResString(@RsPeMACHINE_ALPHA);\r\n      IMAGE_FILE_MACHINE_SH3:\r\n        Result := LoadResString(@RsPeMACHINE_SH3);        // SH3 little-endian\r\n      IMAGE_FILE_MACHINE_SH3DSP:\r\n        Result := LoadResString(@RsPeMACHINE_SH3DSP);\r\n      IMAGE_FILE_MACHINE_SH3E:\r\n        Result := LoadResString(@RsPeMACHINE_SH3E);       // SH3E little-endian\r\n      IMAGE_FILE_MACHINE_SH4:\r\n        Result := LoadResString(@RsPeMACHINE_SH4);        // SH4 little-endian\r\n      IMAGE_FILE_MACHINE_SH5:\r\n        Result := LoadResString(@RsPeMACHINE_SH5);        // SH5\r\n      IMAGE_FILE_MACHINE_ARM:\r\n        Result := LoadResString(@RsPeMACHINE_ARM);        // ARM Little-Endian\r\n      IMAGE_FILE_MACHINE_THUMB:\r\n        Result := LoadResString(@RsPeMACHINE_THUMB);\r\n      IMAGE_FILE_MACHINE_AM33:\r\n        Result := LoadResString(@RsPeMACHINE_AM33);\r\n      IMAGE_FILE_MACHINE_POWERPC:\r\n        Result := LoadResString(@RsPeMACHINE_POWERPC);\r\n      IMAGE_FILE_MACHINE_POWERPCFP:\r\n        Result := LoadResString(@RsPeMACHINE_POWERPCFP);\r\n      IMAGE_FILE_MACHINE_IA64:\r\n        Result := LoadResString(@RsPeMACHINE_IA64);       // Intel 64\r\n      IMAGE_FILE_MACHINE_MIPS16:\r\n        Result := LoadResString(@RsPeMACHINE_MIPS16);     // MIPS\r\n      IMAGE_FILE_MACHINE_ALPHA64:\r\n        Result := LoadResString(@RsPeMACHINE_AMPHA64);    // ALPHA64\r\n      //IMAGE_FILE_MACHINE_AXP64\r\n      IMAGE_FILE_MACHINE_MIPSFPU:\r\n        Result := LoadResString(@RsPeMACHINE_MIPSFPU);    // MIPS\r\n      IMAGE_FILE_MACHINE_MIPSFPU16:\r\n        Result := LoadResString(@RsPeMACHINE_MIPSFPU16);  // MIPS\r\n      IMAGE_FILE_MACHINE_TRICORE:\r\n        Result := LoadResString(@RsPeMACHINE_TRICORE);    // Infineon\r\n      IMAGE_FILE_MACHINE_CEF:\r\n        Result := LoadResString(@RsPeMACHINE_CEF);\r\n      IMAGE_FILE_MACHINE_EBC:\r\n        Result := LoadResString(@RsPeMACHINE_EBC);        // EFI Byte Code\r\n      IMAGE_FILE_MACHINE_AMD64:\r\n        Result := LoadResString(@RsPeMACHINE_AMD64);      // AMD64 (K8)\r\n      IMAGE_FILE_MACHINE_M32R:\r\n        Result := LoadResString(@RsPeMACHINE_M32R);       // M32R little-endian\r\n      IMAGE_FILE_MACHINE_CEE:\r\n        Result := LoadResString(@RsPeMACHINE_CEE);\r\n    else\r\n      Result := Format('[%.8x]', [Value]);\r\n    end;\r\n  end;\r\n\r\n  function GetSubsystemString(Value: DWORD): string;\r\n  begin\r\n    case Value of\r\n      IMAGE_SUBSYSTEM_UNKNOWN:\r\n        Result := LoadResString(@RsPeSUBSYSTEM_UNKNOWN);\r\n      IMAGE_SUBSYSTEM_NATIVE:\r\n        Result := LoadResString(@RsPeSUBSYSTEM_NATIVE);\r\n      IMAGE_SUBSYSTEM_WINDOWS_GUI:\r\n        Result := LoadResString(@RsPeSUBSYSTEM_WINDOWS_GUI);\r\n      IMAGE_SUBSYSTEM_WINDOWS_CUI:\r\n        Result := LoadResString(@RsPeSUBSYSTEM_WINDOWS_CUI);\r\n      IMAGE_SUBSYSTEM_OS2_CUI:\r\n        Result := LoadResString(@RsPeSUBSYSTEM_OS2_CUI);\r\n      IMAGE_SUBSYSTEM_POSIX_CUI:\r\n        Result := LoadResString(@RsPeSUBSYSTEM_POSIX_CUI);\r\n      IMAGE_SUBSYSTEM_RESERVED8:\r\n        Result := LoadResString(@RsPeSUBSYSTEM_RESERVED8);\r\n    else\r\n      Result := Format('[%.8x]', [Value]);\r\n    end;\r\n  end;\r\n\r\n  function GetHeaderValues32(Index: TJclPeHeader): string;\r\n  var\r\n    OptionalHeader: TImageOptionalHeader32;\r\n  begin\r\n    OptionalHeader := OptionalHeader32;\r\n    case Index of\r\n      JclPeHeader_Magic:\r\n        Result := IntToHex(OptionalHeader.Magic, 4);\r\n      JclPeHeader_LinkerVersion:\r\n        Result := FormatVersionString(OptionalHeader.MajorLinkerVersion, OptionalHeader.MinorLinkerVersion);\r\n      JclPeHeader_SizeOfCode:\r\n        Result := IntToHex(OptionalHeader.SizeOfCode, 8);\r\n      JclPeHeader_SizeOfInitializedData:\r\n        Result := IntToHex(OptionalHeader.SizeOfInitializedData, 8);\r\n      JclPeHeader_SizeOfUninitializedData:\r\n        Result := IntToHex(OptionalHeader.SizeOfUninitializedData, 8);\r\n      JclPeHeader_AddressOfEntryPoint:\r\n        Result := IntToHex(OptionalHeader.AddressOfEntryPoint, 8);\r\n      JclPeHeader_BaseOfCode:\r\n        Result := IntToHex(OptionalHeader.BaseOfCode, 8);\r\n      JclPeHeader_BaseOfData:\r\n        {$IFDEF DELPHI64_TEMPORARY}\r\n        System.Error(rePlatformNotImplemented);\r\n        {$ELSE ~DELPHI64_TEMPORARY}\r\n        Result := IntToHex(OptionalHeader.BaseOfData, 8);\r\n        {$ENDIF ~DELPHI64_TEMPORARY}\r\n      JclPeHeader_ImageBase:\r\n        Result := IntToHex(OptionalHeader.ImageBase, 8);\r\n      JclPeHeader_SectionAlignment:\r\n        Result := IntToHex(OptionalHeader.SectionAlignment, 8);\r\n      JclPeHeader_FileAlignment:\r\n        Result := IntToHex(OptionalHeader.FileAlignment, 8);\r\n      JclPeHeader_OperatingSystemVersion:\r\n        Result := FormatVersionString(OptionalHeader.MajorOperatingSystemVersion, OptionalHeader.MinorOperatingSystemVersion);\r\n      JclPeHeader_ImageVersion:\r\n        Result := FormatVersionString(OptionalHeader.MajorImageVersion, OptionalHeader.MinorImageVersion);\r\n      JclPeHeader_SubsystemVersion:\r\n        Result := FormatVersionString(OptionalHeader.MajorSubsystemVersion, OptionalHeader.MinorSubsystemVersion);\r\n      JclPeHeader_Win32VersionValue:\r\n        Result := IntToHex(OptionalHeader.Win32VersionValue, 8);\r\n      JclPeHeader_SizeOfImage:\r\n        Result := IntToHex(OptionalHeader.SizeOfImage, 8);\r\n      JclPeHeader_SizeOfHeaders:\r\n        Result := IntToHex(OptionalHeader.SizeOfHeaders, 8);\r\n      JclPeHeader_CheckSum:\r\n        Result := IntToHex(OptionalHeader.CheckSum, 8);\r\n      JclPeHeader_Subsystem:\r\n        Result := GetSubsystemString(OptionalHeader.Subsystem);\r\n      JclPeHeader_DllCharacteristics:\r\n        Result := IntToHex(OptionalHeader.DllCharacteristics, 4);\r\n      JclPeHeader_SizeOfStackReserve:\r\n        Result := IntToHex(OptionalHeader.SizeOfStackReserve, 8);\r\n      JclPeHeader_SizeOfStackCommit:\r\n        Result := IntToHex(OptionalHeader.SizeOfStackCommit, 8);\r\n      JclPeHeader_SizeOfHeapReserve:\r\n        Result := IntToHex(OptionalHeader.SizeOfHeapReserve, 8);\r\n      JclPeHeader_SizeOfHeapCommit:\r\n        Result := IntToHex(OptionalHeader.SizeOfHeapCommit, 8);\r\n      JclPeHeader_LoaderFlags:\r\n        Result := IntToHex(OptionalHeader.LoaderFlags, 8);\r\n      JclPeHeader_NumberOfRvaAndSizes:\r\n        Result := IntToHex(OptionalHeader.NumberOfRvaAndSizes, 8);\r\n    end;\r\n  end;\r\n\r\n  function GetHeaderValues64(Index: TJclPeHeader): string;\r\n  var\r\n    OptionalHeader: TImageOptionalHeader64;\r\n  begin\r\n    OptionalHeader := OptionalHeader64;\r\n    case Index of\r\n      JclPeHeader_Magic:\r\n        Result := IntToHex(OptionalHeader.Magic, 4);\r\n      JclPeHeader_LinkerVersion:\r\n        Result := FormatVersionString(OptionalHeader.MajorLinkerVersion, OptionalHeader.MinorLinkerVersion);\r\n      JclPeHeader_SizeOfCode:\r\n        Result := IntToHex(OptionalHeader.SizeOfCode, 8);\r\n      JclPeHeader_SizeOfInitializedData:\r\n        Result := IntToHex(OptionalHeader.SizeOfInitializedData, 8);\r\n      JclPeHeader_SizeOfUninitializedData:\r\n        Result := IntToHex(OptionalHeader.SizeOfUninitializedData, 8);\r\n      JclPeHeader_AddressOfEntryPoint:\r\n        Result := IntToHex(OptionalHeader.AddressOfEntryPoint, 8);\r\n      JclPeHeader_BaseOfCode:\r\n        Result := IntToHex(OptionalHeader.BaseOfCode, 8);\r\n      JclPeHeader_BaseOfData:\r\n        Result := ''; // IntToHex(OptionalHeader.BaseOfData, 8);\r\n      JclPeHeader_ImageBase:\r\n        Result := IntToHex(OptionalHeader.ImageBase, 16);\r\n      JclPeHeader_SectionAlignment:\r\n        Result := IntToHex(OptionalHeader.SectionAlignment, 8);\r\n      JclPeHeader_FileAlignment:\r\n        Result := IntToHex(OptionalHeader.FileAlignment, 8);\r\n      JclPeHeader_OperatingSystemVersion:\r\n        Result := FormatVersionString(OptionalHeader.MajorOperatingSystemVersion, OptionalHeader.MinorOperatingSystemVersion);\r\n      JclPeHeader_ImageVersion:\r\n        Result := FormatVersionString(OptionalHeader.MajorImageVersion, OptionalHeader.MinorImageVersion);\r\n      JclPeHeader_SubsystemVersion:\r\n        Result := FormatVersionString(OptionalHeader.MajorSubsystemVersion, OptionalHeader.MinorSubsystemVersion);\r\n      JclPeHeader_Win32VersionValue:\r\n        Result := IntToHex(OptionalHeader.Win32VersionValue, 8);\r\n      JclPeHeader_SizeOfImage:\r\n        Result := IntToHex(OptionalHeader.SizeOfImage, 8);\r\n      JclPeHeader_SizeOfHeaders:\r\n        Result := IntToHex(OptionalHeader.SizeOfHeaders, 8);\r\n      JclPeHeader_CheckSum:\r\n        Result := IntToHex(OptionalHeader.CheckSum, 8);\r\n      JclPeHeader_Subsystem:\r\n        Result := GetSubsystemString(OptionalHeader.Subsystem);\r\n      JclPeHeader_DllCharacteristics:\r\n        Result := IntToHex(OptionalHeader.DllCharacteristics, 4);\r\n      JclPeHeader_SizeOfStackReserve:\r\n        Result := IntToHex(OptionalHeader.SizeOfStackReserve, 16);\r\n      JclPeHeader_SizeOfStackCommit:\r\n        Result := IntToHex(OptionalHeader.SizeOfStackCommit, 16);\r\n      JclPeHeader_SizeOfHeapReserve:\r\n        Result := IntToHex(OptionalHeader.SizeOfHeapReserve, 16);\r\n      JclPeHeader_SizeOfHeapCommit:\r\n        Result := IntToHex(OptionalHeader.SizeOfHeapCommit, 16);\r\n      JclPeHeader_LoaderFlags:\r\n        Result := IntToHex(OptionalHeader.LoaderFlags, 8);\r\n      JclPeHeader_NumberOfRvaAndSizes:\r\n        Result := IntToHex(OptionalHeader.NumberOfRvaAndSizes, 8);\r\n    end;\r\n  end;\r\n\r\nbegin\r\n  if StatusOK then\r\n    with FLoadedImage.FileHeader^ do\r\n      case Index of\r\n        JclPeHeader_Signature:\r\n          Result := IntToHex(Signature, 8);\r\n        JclPeHeader_Machine:\r\n          Result := GetMachineString(FileHeader.Machine);\r\n        JclPeHeader_NumberOfSections:\r\n          Result := IntToHex(FileHeader.NumberOfSections, 4);\r\n        JclPeHeader_TimeDateStamp:\r\n          Result := IntToHex(FileHeader.TimeDateStamp, 8);\r\n        JclPeHeader_PointerToSymbolTable:\r\n          Result := IntToHex(FileHeader.PointerToSymbolTable, 8);\r\n        JclPeHeader_NumberOfSymbols:\r\n          Result := IntToHex(FileHeader.NumberOfSymbols, 8);\r\n        JclPeHeader_SizeOfOptionalHeader:\r\n          Result := IntToHex(FileHeader.SizeOfOptionalHeader, 4);\r\n        JclPeHeader_Characteristics:\r\n          Result := IntToHex(FileHeader.Characteristics, 4);\r\n        JclPeHeader_Magic..JclPeHeader_NumberOfRvaAndSizes:\r\n          case Target of\r\n            taWin32:\r\n              Result := GetHeaderValues32(Index);\r\n            taWin64:\r\n              Result := GetHeaderValues64(Index);\r\n            //taUnknown:\r\n          else\r\n            Result := '';\r\n          end;\r\n      else\r\n        Result := '';\r\n      end\r\n  else\r\n    Result := '';\r\nend;\r\n\r\nfunction TJclPeImage.GetImageSectionCount: Integer;\r\nbegin\r\n  Result := FImageSections.Count;\r\nend;\r\n\r\nfunction TJclPeImage.GetImageSectionFullNames(Index: Integer): string;\r\nvar\r\n  Offset: Integer;\r\nbegin\r\n  Result := ImageSectionNames[Index];\r\n  if (Length(Result) > 0) and (Result[1] = '/') and TryStrToInt(Copy(Result, 2, MaxInt), Offset) then\r\n    Result := GetNameInStringTable(Offset);\r\nend;\r\n\r\nfunction TJclPeImage.GetImageSectionHeaders(Index: Integer): TImageSectionHeader;\r\nbegin\r\n  Result := PImageSectionHeader(FImageSections.Objects[Index])^;\r\nend;\r\n\r\nfunction TJclPeImage.GetImageSectionNameFromRva(const Rva: DWORD): string;\r\nbegin\r\n  Result := GetSectionName(RvaToSection(Rva));\r\nend;\r\n\r\nfunction TJclPeImage.GetImageSectionNames(Index: Integer): string;\r\nbegin\r\n  Result := FImageSections[Index];\r\nend;\r\n\r\nfunction TJclPeImage.GetImportList: TJclPeImportList;\r\nbegin\r\n  if FImportList = nil then\r\n    FImportList := TJclPeImportList.Create(Self);\r\n  Result := FImportList;\r\nend;\r\n\r\nfunction TJclPeImage.GetLoadConfigValues(Index: TJclLoadConfig): string;\r\n  function GetLoadConfigValues32(Index: TJclLoadConfig): string;\r\n  var\r\n    LoadConfig: PIMAGE_LOAD_CONFIG_DIRECTORY32;\r\n  begin\r\n    LoadConfig := DirectoryEntryToData(IMAGE_DIRECTORY_ENTRY_LOAD_CONFIG);\r\n    if LoadConfig <> nil then\r\n      with LoadConfig^ do\r\n        case Index of\r\n          JclLoadConfig_Characteristics:\r\n            Result := IntToHex(Size, 8);\r\n          JclLoadConfig_TimeDateStamp:\r\n            Result := IntToHex(TimeDateStamp, 8);\r\n          JclLoadConfig_Version:\r\n            Result := FormatVersionString(MajorVersion, MinorVersion);\r\n          JclLoadConfig_GlobalFlagsClear:\r\n            Result := IntToHex(GlobalFlagsClear, 8);\r\n          JclLoadConfig_GlobalFlagsSet:\r\n            Result := IntToHex(GlobalFlagsSet, 8);\r\n          JclLoadConfig_CriticalSectionDefaultTimeout:\r\n            Result := IntToHex(CriticalSectionDefaultTimeout, 8);\r\n          JclLoadConfig_DeCommitFreeBlockThreshold:\r\n            Result := IntToHex(DeCommitFreeBlockThreshold, 8);\r\n          JclLoadConfig_DeCommitTotalFreeThreshold:\r\n            Result := IntToHex(DeCommitTotalFreeThreshold, 8);\r\n          JclLoadConfig_LockPrefixTable:\r\n            Result := IntToHex(LockPrefixTable, 8);\r\n          JclLoadConfig_MaximumAllocationSize:\r\n            Result := IntToHex(MaximumAllocationSize, 8);\r\n          JclLoadConfig_VirtualMemoryThreshold:\r\n            Result := IntToHex(VirtualMemoryThreshold, 8);\r\n          JclLoadConfig_ProcessHeapFlags:\r\n            Result := IntToHex(ProcessHeapFlags, 8);\r\n          JclLoadConfig_ProcessAffinityMask:\r\n            Result := IntToHex(ProcessAffinityMask, 8);\r\n          JclLoadConfig_CSDVersion:\r\n            Result := IntToHex(CSDVersion, 4);\r\n          JclLoadConfig_Reserved1:\r\n            Result := IntToHex(Reserved1, 4);\r\n          JclLoadConfig_EditList:\r\n            Result := IntToHex(EditList, 8);\r\n          JclLoadConfig_Reserved:\r\n            Result := LoadResString(@RsPeReserved);\r\n        end;\r\n  end;\r\n  function GetLoadConfigValues64(Index: TJclLoadConfig): string;\r\n  var\r\n    LoadConfig: PIMAGE_LOAD_CONFIG_DIRECTORY64;\r\n  begin\r\n    LoadConfig := DirectoryEntryToData(IMAGE_DIRECTORY_ENTRY_LOAD_CONFIG);\r\n    if LoadConfig <> nil then\r\n      with LoadConfig^ do\r\n        case Index of\r\n          JclLoadConfig_Characteristics:\r\n            Result := IntToHex(Size, 8);\r\n          JclLoadConfig_TimeDateStamp:\r\n            Result := IntToHex(TimeDateStamp, 8);\r\n          JclLoadConfig_Version:\r\n            Result := FormatVersionString(MajorVersion, MinorVersion);\r\n          JclLoadConfig_GlobalFlagsClear:\r\n            Result := IntToHex(GlobalFlagsClear, 8);\r\n          JclLoadConfig_GlobalFlagsSet:\r\n            Result := IntToHex(GlobalFlagsSet, 8);\r\n          JclLoadConfig_CriticalSectionDefaultTimeout:\r\n            Result := IntToHex(CriticalSectionDefaultTimeout, 8);\r\n          JclLoadConfig_DeCommitFreeBlockThreshold:\r\n            Result := IntToHex(DeCommitFreeBlockThreshold, 16);\r\n          JclLoadConfig_DeCommitTotalFreeThreshold:\r\n            Result := IntToHex(DeCommitTotalFreeThreshold, 16);\r\n          JclLoadConfig_LockPrefixTable:\r\n            Result := IntToHex(LockPrefixTable, 16);\r\n          JclLoadConfig_MaximumAllocationSize:\r\n            Result := IntToHex(MaximumAllocationSize, 16);\r\n          JclLoadConfig_VirtualMemoryThreshold:\r\n            Result := IntToHex(VirtualMemoryThreshold, 16);\r\n          JclLoadConfig_ProcessHeapFlags:\r\n            Result := IntToHex(ProcessHeapFlags, 8);\r\n          JclLoadConfig_ProcessAffinityMask:\r\n            Result := IntToHex(ProcessAffinityMask, 16);\r\n          JclLoadConfig_CSDVersion:\r\n            Result := IntToHex(CSDVersion, 4);\r\n          JclLoadConfig_Reserved1:\r\n            Result := IntToHex(Reserved1, 4);\r\n          JclLoadConfig_EditList:\r\n            Result := IntToHex(EditList, 16);\r\n          JclLoadConfig_Reserved:\r\n            Result := LoadResString(@RsPeReserved);\r\n        end;\r\n  end;\r\nbegin\r\n  Result := '';\r\n  case Target of\r\n    taWin32:\r\n      Result := GetLoadConfigValues32(Index);\r\n    taWin64:\r\n      Result := GetLoadConfigValues64(Index);\r\n  end;\r\nend;\r\n\r\nfunction TJclPeImage.GetMappedAddress: TJclAddr;\r\nbegin\r\n  if StatusOK then\r\n    Result := TJclAddr(LoadedImage.MappedAddress)\r\n  else\r\n    Result := 0;\r\nend;\r\n\r\nfunction TJclPeImage.GetNameInStringTable(Offset: ULONG): string;\r\nvar\r\n  Index: Integer;\r\nbegin\r\n  Dec(Offset, SizeOf(ULONG));\r\n  Index := 0;\r\n  while (Offset > 0) and (Index < FStringTable.Count) do\r\n  begin\r\n    Dec(Offset, Length(FStringTable[Index]) + 1);\r\n    if Offset > 0 then\r\n      Inc(Index);\r\n  end;\r\n\r\n  if Offset = 0 then\r\n    Result := FStringTable[Index]\r\n  else\r\n    Result := '';\r\nend;\r\n\r\nfunction TJclPeImage.GetOptionalHeader32: TImageOptionalHeader32;\r\nbegin\r\n  if Target = taWin32 then\r\n    Result := PImageNtHeaders32(FLoadedImage.FileHeader)^.OptionalHeader\r\n  else\r\n    ZeroMemory(@Result, SizeOf(Result));\r\nend;\r\n\r\nfunction TJclPeImage.GetOptionalHeader64: TImageOptionalHeader64;\r\nbegin\r\n  if Target = taWin64 then\r\n    Result := PImageNtHeaders64(FLoadedImage.FileHeader)^.OptionalHeader\r\n  else\r\n    ZeroMemory(@Result, SizeOf(Result));\r\nend;\r\n\r\nfunction TJclPeImage.GetRelocationList: TJclPeRelocList;\r\nbegin\r\n  if FRelocationList = nil then\r\n    FRelocationList := TJclPeRelocList.Create(Self);\r\n  Result := FRelocationList;\r\nend;\r\n\r\nfunction TJclPeImage.GetResourceList: TJclPeRootResourceList;\r\nbegin\r\n  if FResourceList = nil then\r\n  begin\r\n    FResourceVA := Directories[IMAGE_DIRECTORY_ENTRY_RESOURCE].VirtualAddress;\r\n    if FResourceVA <> 0 then\r\n      FResourceVA := TJclAddr(RvaToVa(FResourceVA));\r\n    FResourceList := TJclPeRootResourceList.Create(Self, nil, PImageResourceDirectory(FResourceVA));\r\n  end;\r\n  Result := FResourceList;\r\nend;\r\n\r\nfunction TJclPeImage.GetSectionHeader(const SectionName: string;\r\n  out Header: PImageSectionHeader): Boolean;\r\nvar\r\n  I: Integer;\r\nbegin\r\n  I := FImageSections.IndexOf(SectionName);\r\n  if I = -1 then\r\n  begin\r\n    Header := nil;\r\n    Result := False;\r\n  end\r\n  else\r\n  begin\r\n    Header := PImageSectionHeader(FImageSections.Objects[I]);\r\n    Result := True;\r\n  end;\r\nend;\r\n\r\nfunction TJclPeImage.GetSectionName(Header: PImageSectionHeader): string;\r\nvar\r\n  I: Integer;\r\nbegin\r\n  I := FImageSections.IndexOfObject(TObject(Header));\r\n  if I = -1 then\r\n    Result := ''\r\n  else\r\n    Result := FImageSections[I];\r\nend;\r\n\r\nfunction TJclPeImage.GetStringTableCount: Integer;\r\nbegin\r\n  Result := FStringTable.Count;\r\nend;\r\n\r\nfunction TJclPeImage.GetStringTableItem(Index: Integer): string;\r\nbegin\r\n  Result := FStringTable[Index];\r\nend;\r\n\r\nfunction TJclPeImage.GetUnusedHeaderBytes: TImageDataDirectory;\r\nbegin\r\n  CheckNotAttached;\r\n  Result.Size := 0;\r\n  Result.VirtualAddress := GetImageUnusedHeaderBytes(FLoadedImage, Result.Size);\r\n  if Result.VirtualAddress = 0 then\r\n    RaiseLastOSError;\r\nend;\r\n\r\nfunction TJclPeImage.GetVersionInfo: TJclFileVersionInfo;\r\nvar\r\n  VersionInfoResource: TJclPeResourceItem;\r\nbegin\r\n  if (FVersionInfo = nil) and VersionInfoAvailable then\r\n  begin\r\n    VersionInfoResource := ResourceList.FindResource(rtVersion, '1').List[0];\r\n    with VersionInfoResource do\r\n      try\r\n        FVersionInfo := TJclFileVersionInfo.Attach(RawEntryData, RawEntryDataSize);\r\n      except\r\n        FreeAndNil(FVersionInfo);\r\n      end;\r\n  end;\r\n  Result := FVersionInfo;\r\nend;\r\n\r\nfunction TJclPeImage.GetVersionInfoAvailable: Boolean;\r\nbegin\r\n  Result := StatusOK and (ResourceList.FindResource(rtVersion, '1') <> nil);\r\nend;\r\n\r\nclass function TJclPeImage.HeaderNames(Index: TJclPeHeader): string;\r\nbegin\r\n  case Index of\r\n    JclPeHeader_Signature:\r\n      Result := LoadResString(@RsPeSignature);\r\n    JclPeHeader_Machine:\r\n      Result := LoadResString(@RsPeMachine);\r\n    JclPeHeader_NumberOfSections:\r\n      Result := LoadResString(@RsPeNumberOfSections);\r\n    JclPeHeader_TimeDateStamp:\r\n      Result := LoadResString(@RsPeTimeDateStamp);\r\n    JclPeHeader_PointerToSymbolTable:\r\n      Result := LoadResString(@RsPePointerToSymbolTable);\r\n    JclPeHeader_NumberOfSymbols:\r\n      Result := LoadResString(@RsPeNumberOfSymbols);\r\n    JclPeHeader_SizeOfOptionalHeader:\r\n      Result := LoadResString(@RsPeSizeOfOptionalHeader);\r\n    JclPeHeader_Characteristics:\r\n      Result := LoadResString(@RsPeCharacteristics);\r\n    JclPeHeader_Magic:\r\n      Result := LoadResString(@RsPeMagic);\r\n    JclPeHeader_LinkerVersion:\r\n      Result := LoadResString(@RsPeLinkerVersion);\r\n    JclPeHeader_SizeOfCode:\r\n      Result := LoadResString(@RsPeSizeOfCode);\r\n    JclPeHeader_SizeOfInitializedData:\r\n      Result := LoadResString(@RsPeSizeOfInitializedData);\r\n    JclPeHeader_SizeOfUninitializedData:\r\n      Result := LoadResString(@RsPeSizeOfUninitializedData);\r\n    JclPeHeader_AddressOfEntryPoint:\r\n      Result := LoadResString(@RsPeAddressOfEntryPoint);\r\n    JclPeHeader_BaseOfCode:\r\n      Result := LoadResString(@RsPeBaseOfCode);\r\n    JclPeHeader_BaseOfData:\r\n      Result := LoadResString(@RsPeBaseOfData);\r\n    JclPeHeader_ImageBase:\r\n      Result := LoadResString(@RsPeImageBase);\r\n    JclPeHeader_SectionAlignment:\r\n      Result := LoadResString(@RsPeSectionAlignment);\r\n    JclPeHeader_FileAlignment:\r\n      Result := LoadResString(@RsPeFileAlignment);\r\n    JclPeHeader_OperatingSystemVersion:\r\n      Result := LoadResString(@RsPeOperatingSystemVersion);\r\n    JclPeHeader_ImageVersion:\r\n      Result := LoadResString(@RsPeImageVersion);\r\n    JclPeHeader_SubsystemVersion:\r\n      Result := LoadResString(@RsPeSubsystemVersion);\r\n    JclPeHeader_Win32VersionValue:\r\n      Result := LoadResString(@RsPeWin32VersionValue);\r\n    JclPeHeader_SizeOfImage:\r\n      Result := LoadResString(@RsPeSizeOfImage);\r\n    JclPeHeader_SizeOfHeaders:\r\n      Result := LoadResString(@RsPeSizeOfHeaders);\r\n    JclPeHeader_CheckSum:\r\n      Result := LoadResString(@RsPeCheckSum);\r\n    JclPeHeader_Subsystem:\r\n      Result := LoadResString(@RsPeSubsystem);\r\n    JclPeHeader_DllCharacteristics:\r\n      Result := LoadResString(@RsPeDllCharacteristics);\r\n    JclPeHeader_SizeOfStackReserve:\r\n      Result := LoadResString(@RsPeSizeOfStackReserve);\r\n    JclPeHeader_SizeOfStackCommit:\r\n      Result := LoadResString(@RsPeSizeOfStackCommit);\r\n    JclPeHeader_SizeOfHeapReserve:\r\n      Result := LoadResString(@RsPeSizeOfHeapReserve);\r\n    JclPeHeader_SizeOfHeapCommit:\r\n      Result := LoadResString(@RsPeSizeOfHeapCommit);\r\n    JclPeHeader_LoaderFlags:\r\n      Result := LoadResString(@RsPeLoaderFlags);\r\n    JclPeHeader_NumberOfRvaAndSizes:\r\n      Result := LoadResString(@RsPeNumberOfRvaAndSizes);\r\n  else\r\n    Result := '';\r\n  end;\r\nend;\r\n\r\nfunction TJclPeImage.IsBrokenFormat: Boolean;\r\n  function IsBrokenFormat32: Boolean;\r\n  var\r\n    OptionalHeader: TImageOptionalHeader32;\r\n  begin\r\n    OptionalHeader := OptionalHeader32;\r\n    Result := not ((OptionalHeader.AddressOfEntryPoint = 0) or IsCLR);\r\n    if Result then\r\n    begin\r\n      Result := (ImageSectionCount = 0);\r\n      if not Result then\r\n        with ImageSectionHeaders[0] do\r\n          Result := (VirtualAddress <> OptionalHeader.BaseOfCode) or (SizeOfRawData = 0) or\r\n            (OptionalHeader.AddressOfEntryPoint > VirtualAddress + Misc.VirtualSize) or\r\n            (Characteristics and (IMAGE_SCN_CNT_CODE or IMAGE_SCN_MEM_WRITE) <> IMAGE_SCN_CNT_CODE);\r\n    end;\r\n  end;\r\n  function IsBrokenFormat64: Boolean;\r\n  var\r\n    OptionalHeader: TImageOptionalHeader64;\r\n  begin\r\n    OptionalHeader := OptionalHeader64;\r\n    Result := not ((OptionalHeader.AddressOfEntryPoint = 0) or IsCLR);\r\n    if Result then\r\n    begin\r\n      Result := (ImageSectionCount = 0);\r\n      if not Result then\r\n        with ImageSectionHeaders[0] do\r\n          Result := (VirtualAddress <> OptionalHeader.BaseOfCode) or (SizeOfRawData = 0) or\r\n            (OptionalHeader.AddressOfEntryPoint > VirtualAddress + Misc.VirtualSize) or\r\n            (Characteristics and (IMAGE_SCN_CNT_CODE or IMAGE_SCN_MEM_WRITE) <> IMAGE_SCN_CNT_CODE);\r\n    end;\r\n  end;\r\nbegin\r\n  case Target of\r\n    taWin32:\r\n      Result := IsBrokenFormat32;\r\n    taWin64:\r\n      Result := IsBrokenFormat64;\r\n    //taUnknown:\r\n  else\r\n    Result := False; // don't know how to check it\r\n  end;\r\nend;\r\n\r\nfunction TJclPeImage.IsCLR: Boolean;\r\nbegin\r\n  Result := DirectoryExists[IMAGE_DIRECTORY_ENTRY_COM_DESCRIPTOR] and CLRHeader.HasMetadata;\r\nend;\r\n\r\nfunction TJclPeImage.IsSystemImage: Boolean;\r\nbegin\r\n  Result := StatusOK and FLoadedImage.fSystemImage;\r\nend;\r\n\r\nclass function TJclPeImage.LoadConfigNames(Index: TJclLoadConfig): string;\r\nbegin\r\n  case Index of\r\n    JclLoadConfig_Characteristics:\r\n      Result := LoadResString(@RsPeCharacteristics);\r\n    JclLoadConfig_TimeDateStamp:\r\n      Result := LoadResString(@RsPeTimeDateStamp);\r\n    JclLoadConfig_Version:\r\n      Result := LoadResString(@RsPeVersion);\r\n    JclLoadConfig_GlobalFlagsClear:\r\n      Result := LoadResString(@RsPeGlobalFlagsClear);\r\n    JclLoadConfig_GlobalFlagsSet:\r\n      Result := LoadResString(@RsPeGlobalFlagsSet);\r\n    JclLoadConfig_CriticalSectionDefaultTimeout:\r\n      Result := LoadResString(@RsPeCriticalSectionDefaultTimeout);\r\n    JclLoadConfig_DeCommitFreeBlockThreshold:\r\n      Result := LoadResString(@RsPeDeCommitFreeBlockThreshold);\r\n    JclLoadConfig_DeCommitTotalFreeThreshold:\r\n      Result := LoadResString(@RsPeDeCommitTotalFreeThreshold);\r\n    JclLoadConfig_LockPrefixTable:\r\n      Result := LoadResString(@RsPeLockPrefixTable);\r\n    JclLoadConfig_MaximumAllocationSize:\r\n      Result := LoadResString(@RsPeMaximumAllocationSize);\r\n    JclLoadConfig_VirtualMemoryThreshold:\r\n      Result := LoadResString(@RsPeVirtualMemoryThreshold);\r\n    JclLoadConfig_ProcessHeapFlags:\r\n      Result := LoadResString(@RsPeProcessHeapFlags);\r\n    JclLoadConfig_ProcessAffinityMask:\r\n      Result := LoadResString(@RsPeProcessAffinityMask);\r\n    JclLoadConfig_CSDVersion:\r\n      Result := LoadResString(@RsPeCSDVersion);\r\n    JclLoadConfig_Reserved1:\r\n      Result := LoadResString(@RsPeReserved);\r\n    JclLoadConfig_EditList:\r\n      Result := LoadResString(@RsPeEditList);\r\n    JclLoadConfig_Reserved:\r\n      Result := LoadResString(@RsPeReserved);\r\n  else\r\n    Result := '';\r\n  end;\r\nend;\r\n\r\nprocedure TJclPeImage.RaiseStatusException;\r\nbegin\r\n  if not FNoExceptions then\r\n    case FStatus of\r\n      stNotPE:\r\n        raise EJclPeImageError.CreateRes(@RsPeNotPE);\r\n      stNotFound:\r\n        raise EJclPeImageError.CreateResFmt(@RsPeCantOpen, [FFileName]);\r\n      stNotSupported:\r\n        raise EJclPeImageError.CreateRes(@RsPeUnknownTarget);\r\n      stError:\r\n        RaiseLastOSError;\r\n    end;\r\nend;\r\n\r\nfunction TJclPeImage.RawToVa(Raw: DWORD): Pointer;\r\nbegin\r\n  Result := Pointer(TJclAddr(FLoadedImage.MappedAddress) + Raw);\r\nend;\r\n\r\nprocedure TJclPeImage.ReadImageSections;\r\nvar\r\n  I: Integer;\r\n  Header: PImageSectionHeader;\r\n  UTF8Name: TUTF8String;\r\n  SectionName: string;\r\nbegin\r\n  if not StatusOK then\r\n    Exit;\r\n  Header := FLoadedImage.Sections;\r\n  for I := 0 to FLoadedImage.NumberOfSections - 1 do\r\n  begin\r\n    SetLength(UTF8Name, IMAGE_SIZEOF_SHORT_NAME);\r\n    Move(Header.Name[0], UTF8Name[1], IMAGE_SIZEOF_SHORT_NAME * SizeOf(AnsiChar));\r\n    StrResetLength(UTF8Name);\r\n    if not TryUTF8ToString(UTF8Name, SectionName) then\r\n      SectionName := string(UTF8Name);\r\n    FImageSections.AddObject(SectionName, Pointer(Header));\r\n    Inc(Header);\r\n  end;\r\nend;\r\n\r\nprocedure TJclPeImage.ReadStringTable;\r\nvar\r\n  SymbolTable: DWORD;\r\n  StringTablePtr: PAnsiChar;\r\n  Ptr: PAnsiChar;\r\n  ByteSize: ULONG;\r\n  Start: PAnsiChar;\r\n  StringEntry: AnsiString;\r\nbegin\r\n  SymbolTable := LoadedImage.FileHeader.FileHeader.PointerToSymbolTable;\r\n  if SymbolTable = 0 then\r\n    Exit;\r\n\r\n  StringTablePtr := PAnsiChar(LoadedImage.MappedAddress) +\r\n                    SymbolTable +\r\n                    (LoadedImage.FileHeader.FileHeader.NumberOfSymbols * SizeOf(IMAGE_SYMBOL));\r\n\r\n  ByteSize := PULONG(StringTablePtr)^;\r\n  Ptr := StringTablePtr + SizeOf(ByteSize);\r\n\r\n  while Ptr < StringTablePtr + ByteSize do\r\n  begin\r\n    Start := Ptr;\r\n    while (Ptr^ <> #0) and (Ptr < StringTablePtr + ByteSize) do\r\n      Inc(Ptr);\r\n    if Start <> Ptr then\r\n    begin\r\n      SetLength(StringEntry, Ptr - Start);\r\n      Move(Start^, StringEntry[1], Ptr - Start);\r\n      FStringTable.Add(string(StringEntry));\r\n    end;\r\n    Inc(Ptr); // to skip the #0 character\r\n  end;\r\nend;\r\n\r\nfunction TJclPeImage.ResourceItemCreate(AEntry: PImageResourceDirectoryEntry;\r\n  AParentItem: TJclPeResourceItem): TJclPeResourceItem;\r\nbegin\r\n  Result := TJclPeResourceItem.Create(Self, AParentItem, AEntry);\r\nend;\r\n\r\nfunction TJclPeImage.ResourceListCreate(ADirectory: PImageResourceDirectory;\r\n  AParentItem: TJclPeResourceItem): TJclPeResourceList;\r\nbegin\r\n  Result := TJclPeResourceList.Create(Self, AParentItem, ADirectory);\r\nend;\r\n\r\nfunction TJclPeImage.RvaToSection(Rva: DWORD): PImageSectionHeader;\r\nvar\r\n  I: Integer;\r\n  SectionHeader: PImageSectionHeader;\r\n  EndRVA: DWORD;\r\nbegin\r\n  Result := ImageRvaToSection(FLoadedImage.FileHeader, FLoadedImage.MappedAddress, Rva);\r\n  if Result = nil then\r\n    for I := 0 to FImageSections.Count - 1 do\r\n    begin\r\n      SectionHeader := PImageSectionHeader(FImageSections.Objects[I]);\r\n      if SectionHeader^.SizeOfRawData = 0 then\r\n        EndRVA := SectionHeader^.Misc.VirtualSize\r\n      else\r\n        EndRVA := SectionHeader^.SizeOfRawData;\r\n      Inc(EndRVA, SectionHeader^.VirtualAddress);\r\n      if (SectionHeader^.VirtualAddress <= Rva) and (EndRVA >= Rva) then\r\n      begin\r\n        Result := SectionHeader;\r\n        Break;\r\n      end;\r\n    end;\r\nend;\r\n\r\nfunction TJclPeImage.RvaToVa(Rva: DWORD): Pointer;\r\nbegin\r\n  if FAttachedImage then\r\n    Result := Pointer(TJclAddr(FLoadedImage.MappedAddress) + Rva)\r\n  else\r\n    Result := ImageRvaToVa(FLoadedImage.FileHeader, FLoadedImage.MappedAddress, Rva, nil);\r\nend;\r\n\r\nfunction TJclPeImage.RvaToVaEx(Rva: DWORD): Pointer;\r\n  function RvaToVaEx32(Rva: DWORD): Pointer;\r\n  var\r\n    OptionalHeader: TImageOptionalHeader32;\r\n  begin\r\n    OptionalHeader := OptionalHeader32;\r\n    if (Rva >= OptionalHeader.ImageBase) and (Rva < (OptionalHeader.ImageBase + FLoadedImage.SizeOfImage)) then\r\n      Dec(Rva, OptionalHeader.ImageBase);\r\n    Result := RvaToVa(Rva);\r\n  end;\r\n  function RvaToVaEx64(Rva: DWORD): Pointer;\r\n  var\r\n    OptionalHeader: TImageOptionalHeader64;\r\n  begin\r\n    OptionalHeader := OptionalHeader64;\r\n    if (Rva >= OptionalHeader.ImageBase) and (Rva < (OptionalHeader.ImageBase + FLoadedImage.SizeOfImage)) then\r\n      Dec(Rva, OptionalHeader.ImageBase);\r\n    Result := RvaToVa(Rva);\r\n  end;\r\nbegin\r\n  case Target of\r\n    taWin32:\r\n      Result := RvaToVaEx32(Rva);\r\n    taWin64:\r\n      Result := RvaToVaEx64(Rva);\r\n    //taUnknown:\r\n  else\r\n    Result := nil;\r\n  end;\r\nend;\r\n\r\nprocedure TJclPeImage.SetFileName(const Value: TFileName);\r\nbegin\r\n  if FFileName <> Value then\r\n  begin\r\n    Clear;\r\n    FFileName := Value;\r\n    if FFileName = '' then\r\n      Exit;\r\n    // OF: possible loss of data\r\n    if MapAndLoad(PAnsiChar(AnsiString(FFileName)), nil, FLoadedImage, True, FReadOnlyAccess) then\r\n    begin\r\n      FTarget := PeMapImgTarget(FLoadedImage.MappedAddress);\r\n      if FTarget <> taUnknown then\r\n      begin\r\n        FStatus := stOk;\r\n        ReadImageSections;\r\n        ReadStringTable;\r\n        AfterOpen;\r\n      end\r\n      else\r\n        FStatus := stNotSupported;\r\n    end\r\n    else\r\n      case GetLastError of\r\n        ERROR_SUCCESS:\r\n          FStatus := stNotPE;\r\n        ERROR_FILE_NOT_FOUND:\r\n          FStatus := stNotFound;\r\n      else\r\n        FStatus := stError;\r\n      end;\r\n    RaiseStatusException;\r\n  end;\r\nend;\r\n\r\nclass function TJclPeImage.ShortSectionInfo(Characteristics: DWORD): string;\r\ntype\r\n  TSectionCharacteristics = packed record\r\n    Mask: DWORD;\r\n    InfoChar: Char;\r\n  end;\r\nconst\r\n  Info: array [1..8] of TSectionCharacteristics = (\r\n    (Mask: IMAGE_SCN_CNT_CODE; InfoChar: 'C'),\r\n    (Mask: IMAGE_SCN_MEM_EXECUTE; InfoChar: 'E'),\r\n    (Mask: IMAGE_SCN_MEM_READ; InfoChar: 'R'),\r\n    (Mask: IMAGE_SCN_MEM_WRITE; InfoChar: 'W'),\r\n    (Mask: IMAGE_SCN_CNT_INITIALIZED_DATA; InfoChar: 'I'),\r\n    (Mask: IMAGE_SCN_CNT_UNINITIALIZED_DATA; InfoChar: 'U'),\r\n    (Mask: IMAGE_SCN_MEM_SHARED; InfoChar: 'S'),\r\n    (Mask: IMAGE_SCN_MEM_DISCARDABLE; InfoChar: 'D')\r\n  );\r\nvar\r\n  I: Integer;\r\nbegin\r\n  SetLength(Result, High(Info));\r\n  Result := '';\r\n  for I := Low(Info) to High(Info) do\r\n    with Info[I] do\r\n      if (Characteristics and Mask) = Mask then\r\n        Result := Result + InfoChar;\r\nend;\r\n\r\nfunction TJclPeImage.StatusOK: Boolean;\r\nbegin\r\n  Result := (FStatus = stOk);\r\nend;\r\n\r\nclass function TJclPeImage.StampToDateTime(TimeDateStamp: DWORD): TDateTime;\r\nbegin\r\n  Result := TimeDateStamp / SecsPerDay + UnixTimeStart\r\nend;\r\n\r\nprocedure TJclPeImage.TryGetNamesForOrdinalImports;\r\nbegin\r\n  if StatusOK then\r\n  begin\r\n    GetImportList;\r\n    FImportList.TryGetNamesForOrdinalImports;\r\n  end;\r\nend;\r\n\r\nfunction TJclPeImage.VerifyCheckSum: Boolean;\r\n  function VerifyCheckSum32: Boolean;\r\n  var\r\n    OptionalHeader: TImageOptionalHeader32;\r\n  begin\r\n    OptionalHeader := OptionalHeader32;\r\n    Result := StatusOK and ((OptionalHeader.CheckSum = 0) or (CalculateCheckSum = OptionalHeader.CheckSum));\r\n  end;\r\n  function VerifyCheckSum64: Boolean;\r\n  var\r\n    OptionalHeader: TImageOptionalHeader64;\r\n  begin\r\n    OptionalHeader := OptionalHeader64;\r\n    Result := StatusOK and ((OptionalHeader.CheckSum = 0) or (CalculateCheckSum = OptionalHeader.CheckSum));\r\n  end;\r\nbegin\r\n  CheckNotAttached;\r\n  case Target of\r\n    taWin32:\r\n      Result := VerifyCheckSum32;\r\n    taWin64:\r\n      Result := VerifyCheckSum64;\r\n    //taUnknown: ;\r\n  else\r\n    Result := True;\r\n  end;\r\nend;\r\n\r\n{$IFDEF BORLAND}\r\n\r\n//=== { TJclPeBorImagesCache } ===============================================\r\n\r\nfunction TJclPeBorImagesCache.GetImages(const FileName: TFileName): TJclPeBorImage;\r\nbegin\r\n  Result := TJclPeBorImage(inherited Images[FileName]);\r\nend;\r\n\r\nfunction TJclPeBorImagesCache.GetPeImageClass: TJclPeImageClass;\r\nbegin\r\n  Result := TJclPeBorImage;\r\nend;\r\n\r\n//=== { TJclPePackageInfo } ==================================================\r\n\r\nconstructor TJclPePackageInfo.Create(ALibHandle: THandle);\r\nbegin\r\n  FContains := TStringList.Create;\r\n  FRequires := TStringList.Create;\r\n  FEnsureExtension := True;\r\n  FSorted := True;\r\n  ReadPackageInfo(ALibHandle);\r\nend;\r\n\r\ndestructor TJclPePackageInfo.Destroy;\r\nbegin\r\n  FreeAndNil(FContains);\r\n  FreeAndNil(FRequires);\r\n  inherited Destroy;\r\nend;\r\n\r\nfunction TJclPePackageInfo.GetContains: TStrings;\r\nbegin\r\n  Result := FContains;\r\nend;\r\n\r\nfunction TJclPePackageInfo.GetContainsCount: Integer;\r\nbegin\r\n  Result := Contains.Count;\r\nend;\r\n\r\nfunction TJclPePackageInfo.GetContainsFlags(Index: Integer): Byte;\r\nbegin\r\n  Result := Byte(Contains.Objects[Index]);\r\nend;\r\n\r\nfunction TJclPePackageInfo.GetContainsNames(Index: Integer): string;\r\nbegin\r\n  Result := Contains[Index];\r\nend;\r\n\r\nfunction TJclPePackageInfo.GetRequires: TStrings;\r\nbegin\r\n  Result := FRequires;\r\nend;\r\n\r\nfunction TJclPePackageInfo.GetRequiresCount: Integer;\r\nbegin\r\n  Result := Requires.Count;\r\nend;\r\n\r\nfunction TJclPePackageInfo.GetRequiresNames(Index: Integer): string;\r\nbegin\r\n  Result := Requires[Index];\r\n  if FEnsureExtension then\r\n    StrEnsureSuffix(BinaryExtensionPackage, Result);\r\nend;\r\n\r\nclass function TJclPePackageInfo.PackageModuleTypeToString(Flags: Cardinal): string;\r\nbegin\r\n  case Flags and pfModuleTypeMask of\r\n    pfExeModule, pfModuleTypeMask:\r\n      Result := LoadResString(@RsPePkgExecutable);\r\n    pfPackageModule:\r\n      Result := LoadResString(@RsPePkgPackage);\r\n    pfLibraryModule:\r\n      Result := LoadResString(@PsPePkgLibrary);\r\n  else\r\n    Result := '';\r\n  end;\r\nend;\r\n\r\nclass function TJclPePackageInfo.PackageOptionsToString(Flags: Cardinal): string;\r\nbegin\r\n  Result := '';\r\n  AddFlagTextRes(Result, @RsPePkgNeverBuild, Flags, pfNeverBuild);\r\n  AddFlagTextRes(Result, @RsPePkgDesignOnly, Flags, pfDesignOnly);\r\n  AddFlagTextRes(Result, @RsPePkgRunOnly, Flags, pfRunOnly);\r\n  AddFlagTextRes(Result, @RsPePkgIgnoreDupUnits, Flags, pfIgnoreDupUnits);\r\nend;\r\n\r\nclass function TJclPePackageInfo.ProducerToString(Flags: Cardinal): string;\r\nbegin\r\n  case Flags and pfProducerMask of\r\n    pfV3Produced:\r\n      Result := LoadResString(@RsPePkgV3Produced);\r\n    pfProducerUndefined:\r\n      Result := LoadResString(@RsPePkgProducerUndefined);\r\n    pfBCB4Produced:\r\n      Result := LoadResString(@RsPePkgBCB4Produced);\r\n    pfDelphi4Produced:\r\n      Result := LoadResString(@RsPePkgDelphi4Produced);\r\n  else\r\n    Result := '';\r\n  end;\r\nend;\r\n\r\nprocedure PackageInfoProc(const Name: string; NameType: TNameType; AFlags: Byte; Param: Pointer);\r\nbegin\r\n  with TJclPePackageInfo(Param) do\r\n    case NameType of\r\n      ntContainsUnit:\r\n        Contains.AddObject(Name, Pointer(AFlags));\r\n      ntRequiresPackage:\r\n        Requires.Add(Name);\r\n      ntDcpBpiName:\r\n        SetDcpName(Name);\r\n    end;\r\nend;\r\n\r\nprocedure TJclPePackageInfo.ReadPackageInfo(ALibHandle: THandle);\r\nvar\r\n  DescrResInfo: HRSRC;\r\n  DescrResData: HGLOBAL;\r\nbegin\r\n  FAvailable := FindResource(ALibHandle, PackageInfoResName, RT_RCDATA) <> 0;\r\n  if FAvailable then\r\n  begin\r\n    GetPackageInfo(ALibHandle, Self, FFlags, PackageInfoProc);\r\n    if FDcpName = '' then\r\n      FDcpName := PathExtractFileNameNoExt(GetModulePath(ALibHandle)) + CompilerExtensionDCP;\r\n    if FSorted then\r\n    begin\r\n      FContains.Sort;\r\n      FRequires.Sort;\r\n    end;\r\n  end;\r\n  DescrResInfo := FindResource(ALibHandle, DescriptionResName, RT_RCDATA);\r\n  if DescrResInfo <> 0 then\r\n  begin\r\n    DescrResData := LoadResource(ALibHandle, DescrResInfo);\r\n    if DescrResData <> 0 then\r\n    begin\r\n      FDescription := WideCharLenToString(LockResource(DescrResData),\r\n        SizeofResource(ALibHandle, DescrResInfo));\r\n      StrResetLength(FDescription);\r\n    end;\r\n  end;\r\nend;\r\n\r\nprocedure TJclPePackageInfo.SetDcpName(const Value: string);\r\nbegin\r\n  FDcpName := Value;\r\nend;\r\n\r\nclass function TJclPePackageInfo.UnitInfoFlagsToString(UnitFlags: Byte): string;\r\nbegin\r\n  Result := '';\r\n  AddFlagTextRes(Result, @RsPePkgMain, UnitFlags, ufMainUnit);\r\n  AddFlagTextRes(Result, @RsPePkgPackage, UnitFlags, ufPackageUnit);\r\n  AddFlagTextRes(Result, @RsPePkgWeak, UnitFlags, ufWeakUnit);\r\n  AddFlagTextRes(Result, @RsPePkgOrgWeak, UnitFlags, ufOrgWeakUnit);\r\n  AddFlagTextRes(Result, @RsPePkgImplicit, UnitFlags, ufImplicitUnit);\r\nend;\r\n\r\n//=== { TJclPeBorForm } ======================================================\r\n\r\nconstructor TJclPeBorForm.Create(AResItem: TJclPeResourceItem;\r\n  AFormFlags: TFilerFlags; AFormPosition: Integer;\r\n  const AFormClassName, AFormObjectName: string);\r\nbegin\r\n  inherited Create;\r\n  FResItem := AResItem;\r\n  FFormFlags := AFormFlags;\r\n  FFormPosition := AFormPosition;\r\n  FFormClassName := AFormClassName;\r\n  FFormObjectName := AFormObjectName;\r\nend;\r\n\r\nprocedure TJclPeBorForm.ConvertFormToText(const Stream: TStream);\r\nvar\r\n  SourceStream: TJclPeResourceRawStream;\r\nbegin\r\n  SourceStream := TJclPeResourceRawStream.Create(ResItem);\r\n  try\r\n    ObjectBinaryToText(SourceStream, Stream);\r\n  finally\r\n    SourceStream.Free;\r\n  end;\r\nend;\r\n\r\nprocedure TJclPeBorForm.ConvertFormToText(const Strings: TStrings);\r\nvar\r\n  TempStream: TMemoryStream;\r\nbegin\r\n  TempStream := TMemoryStream.Create;\r\n  try\r\n    ConvertFormToText(TempStream);\r\n    TempStream.Seek(0, soFromBeginning);\r\n    Strings.LoadFromStream(TempStream);\r\n  finally\r\n    TempStream.Free;\r\n  end;\r\nend;\r\n\r\nfunction TJclPeBorForm.GetDisplayName: string;\r\nbegin\r\n  if FFormObjectName <> '' then\r\n    Result := FFormObjectName + ': '\r\n  else\r\n    Result := '';\r\n  Result := Result + FFormClassName;\r\nend;\r\n\r\n//=== { TJclPeBorImage } =====================================================\r\n\r\nconstructor TJclPeBorImage.Create(ANoExceptions: Boolean);\r\nbegin\r\n  FForms := TObjectList.Create(True);\r\n  FPackageInfoSorted := True;\r\n  inherited Create(ANoExceptions);\r\nend;\r\n\r\ndestructor TJclPeBorImage.Destroy;\r\nbegin\r\n  inherited Destroy;\r\n  FreeAndNil(FForms);\r\nend;\r\n\r\nprocedure TJclPeBorImage.AfterOpen;\r\nvar\r\n  HasDVCLAL, HasPACKAGEINFO, HasPACKAGEOPTIONS: Boolean;\r\nbegin\r\n  inherited AfterOpen;\r\n  if StatusOK then\r\n    with ResourceList do\r\n    begin\r\n      HasDVCLAL := (FindResource(rtRCData, DVclAlResName) <> nil);\r\n      HasPACKAGEINFO := (FindResource(rtRCData, PackageInfoResName) <> nil);\r\n      HasPACKAGEOPTIONS := (FindResource(rtRCData, PackageOptionsResName) <> nil);\r\n      FIsPackage := HasPACKAGEINFO and HasPACKAGEOPTIONS;\r\n      FIsBorlandImage := HasDVCLAL or FIsPackage;\r\n    end;\r\nend;\r\n\r\nprocedure TJclPeBorImage.Clear;\r\nbegin\r\n  FForms.Clear;\r\n  FreeAndNil(FPackageInfo);\r\n  FreeLibHandle;\r\n  inherited Clear;\r\n  FIsBorlandImage := False;\r\n  FIsPackage := False;\r\n  FPackageCompilerVersion := 0;\r\nend;\r\n\r\nprocedure TJclPeBorImage.CreateFormsList;\r\nvar\r\n  ResTypeItem: TJclPeResourceItem;\r\n  I: Integer;\r\n\r\n  procedure ProcessListItem(DfmResItem: TJclPeResourceItem);\r\n  const\r\n    FilerSignature: array [1..4] of AnsiChar = string('TPF0');\r\n  var\r\n    SourceStream: TJclPeResourceRawStream;\r\n    Reader: TReader;\r\n    FormFlags: TFilerFlags;\r\n    FormPosition: Integer;\r\n    ClassName, FormName: string;\r\n  begin\r\n    SourceStream := TJclPeResourceRawStream.Create(DfmResItem);\r\n    try\r\n      if (SourceStream.Size > SizeOf(FilerSignature)) and\r\n        (PInteger(SourceStream.Memory)^ = Integer(FilerSignature)) then\r\n      begin\r\n        Reader := TReader.Create(SourceStream, 4096);\r\n        try\r\n          Reader.ReadSignature;\r\n          Reader.ReadPrefix(FormFlags, FormPosition);\r\n          ClassName := Reader.ReadStr;\r\n          FormName := Reader.ReadStr;\r\n          FForms.Add(TJclPeBorForm.Create(DfmResItem, FormFlags, FormPosition,\r\n            ClassName, FormName));\r\n        finally\r\n          Reader.Free;\r\n        end;\r\n      end;\r\n    finally\r\n      SourceStream.Free;\r\n    end;\r\n  end;\r\n\r\nbegin\r\n  if StatusOK then\r\n    with ResourceList do\r\n    begin\r\n      ResTypeItem := FindResource(rtRCData, '');\r\n      if ResTypeItem <> nil then\r\n        with ResTypeItem.List do\r\n          for I := 0 to Count - 1 do\r\n            ProcessListItem(Items[I].List[0]);\r\n    end;\r\nend;\r\n\r\nfunction TJclPeBorImage.DependedPackages(List: TStrings; FullPathName, Descriptions: Boolean): Boolean;\r\nvar\r\n  ImportList: TStringList;\r\n  I: Integer;\r\n  Name: string;\r\nbegin\r\n  Result := IsBorlandImage;\r\n  if not Result then\r\n    Exit;\r\n  ImportList := InternalImportedLibraries(FileName, True, FullPathName, nil);\r\n  List.BeginUpdate;\r\n  try\r\n    for I := 0 to ImportList.Count - 1 do\r\n    begin\r\n      Name := ImportList[I];\r\n      if StrSame(ExtractFileExt(Name), BinaryExtensionPackage) then\r\n      begin\r\n        if Descriptions then\r\n          List.Add(Name + '=' + GetPackageDescription(PChar(Name)))\r\n        else\r\n          List.Add(Name);\r\n      end;\r\n    end;\r\n  finally\r\n    ImportList.Free;\r\n    List.EndUpdate;\r\n  end;\r\nend;\r\n\r\nfunction TJclPeBorImage.FreeLibHandle: Boolean;\r\nbegin\r\n  if FLibHandle <> 0 then\r\n  begin\r\n    Result := FreeLibrary(FLibHandle);\r\n    FLibHandle := 0;\r\n  end\r\n  else\r\n    Result := True;\r\nend;\r\n\r\nfunction TJclPeBorImage.GetFormCount: Integer;\r\nbegin\r\n  if FForms.Count = 0 then\r\n    CreateFormsList;\r\n  Result := FForms.Count;\r\nend;\r\n\r\nfunction TJclPeBorImage.GetFormFromName(const FormClassName: string): TJclPeBorForm;\r\nvar\r\n  I: Integer;\r\nbegin\r\n  Result := nil;\r\n  for I := 0 to FormCount - 1 do\r\n    if StrSame(FormClassName, Forms[I].FormClassName) then\r\n    begin\r\n      Result := Forms[I];\r\n      Break;\r\n    end;\r\nend;\r\n\r\nfunction TJclPeBorImage.GetForms(Index: Integer): TJclPeBorForm;\r\nbegin\r\n  Result := TJclPeBorForm(FForms[Index]);\r\nend;\r\n\r\nfunction TJclPeBorImage.GetLibHandle: THandle;\r\nbegin\r\n  if StatusOK and (FLibHandle = 0) then\r\n  begin\r\n    FLibHandle := LoadLibraryEx(PChar(FileName), 0, LOAD_LIBRARY_AS_DATAFILE);\r\n    if FLibHandle = 0 then\r\n      RaiseLastOSError;\r\n  end;\r\n  Result := FLibHandle;\r\nend;\r\n\r\nfunction TJclPeBorImage.GetPackageCompilerVersion: Integer;\r\nvar\r\n  I: Integer;\r\n  ImportName: string;\r\n\r\n  function CheckName: Boolean;\r\n  begin\r\n    Result := False;\r\n    ImportName := AnsiUpperCase(ImportName);\r\n    if StrSame(ExtractFileExt(ImportName), BinaryExtensionPackage) then\r\n    begin\r\n      ImportName := PathExtractFileNameNoExt(ImportName);\r\n      if (Length(ImportName) = 5) and\r\n        CharIsDigit(ImportName[4]) and CharIsDigit(ImportName[5]) and\r\n        ((Pos('RTL', ImportName) = 1) or (Pos('VCL', ImportName) = 1)) then\r\n      begin\r\n        FPackageCompilerVersion := StrToIntDef(Copy(ImportName, 4, 2), 0);\r\n        Result := True;\r\n      end;\r\n    end;\r\n  end;\r\n\r\nbegin\r\n  if (FPackageCompilerVersion = 0) and IsPackage then\r\n  begin\r\n    with ImportList do\r\n      for I := 0 to UniqueLibItemCount - 1 do\r\n      begin\r\n        ImportName := UniqueLibNames[I];\r\n        if CheckName then\r\n          Break;\r\n      end;\r\n    if FPackageCompilerVersion = 0 then\r\n    begin\r\n      ImportName := ExtractFileName(FileName);\r\n      CheckName;\r\n    end;\r\n  end;\r\n  Result := FPackageCompilerVersion;\r\nend;\r\n\r\nfunction TJclPeBorImage.GetPackageInfo: TJclPePackageInfo;\r\nbegin\r\n  if StatusOK and (FPackageInfo = nil) then\r\n  begin\r\n    GetLibHandle;\r\n    FPackageInfo := TJclPePackageInfo.Create(FLibHandle);\r\n    FPackageInfo.Sorted := FPackageInfoSorted;\r\n    FreeLibHandle;\r\n  end;\r\n  Result := FPackageInfo;\r\nend;\r\n{$ENDIF BORLAND}\r\n\r\n//=== { TJclPeNameSearch } ===================================================\r\n\r\nconstructor TJclPeNameSearch.Create(const FunctionName, Path: string; Options: TJclPeNameSearchOptions);\r\nbegin\r\n  inherited Create(True);\r\n  FFunctionName := FunctionName;\r\n  FOptions := Options;\r\n  FPath := Path;\r\n  FreeOnTerminate := True;\r\nend;\r\n\r\nfunction TJclPeNameSearch.CompareName(const FunctionName, ComparedName: string): Boolean;\r\nbegin\r\n  Result := PeSmartFunctionNameSame(ComparedName, FunctionName, [scIgnoreCase]);\r\nend;\r\n\r\nprocedure TJclPeNameSearch.DoFound;\r\nbegin\r\n  if Assigned(FOnFound) then\r\n    FOnFound(Self, F_FileName, F_FunctionName, F_Option);\r\nend;\r\n\r\nprocedure TJclPeNameSearch.DoProcessFile;\r\nbegin\r\n  if Assigned(FOnProcessFile) then\r\n    FOnProcessFile(Self, FPeImage, F_Process);\r\nend;\r\n\r\nprocedure TJclPeNameSearch.Execute;\r\nvar\r\n  PathList: TStringList;\r\n  I: Integer;\r\n\r\n  function CompareNameAndNotify(const S: string): Boolean;\r\n  begin\r\n    Result := CompareName(S, FFunctionName);\r\n    if Result and not Terminated then\r\n    begin\r\n      F_FunctionName := S;\r\n      Synchronize(DoFound);\r\n    end;\r\n  end;\r\n\r\n  procedure ProcessDirectorySearch(const DirName: string);\r\n  var\r\n    Se: TSearchRec;\r\n    SearchResult: Integer;\r\n    ImportList: TJclPeImportList;\r\n    ExportList: TJclPeExportFuncList;\r\n    I: Integer;\r\n  begin\r\n    SearchResult := FindFirst(DirName, faArchive + faReadOnly, Se);\r\n    try\r\n      while not Terminated and (SearchResult = 0) do\r\n      begin\r\n        F_FileName := PathAddSeparator(ExtractFilePath(DirName)) + Se.Name;\r\n        F_Process := True;\r\n        FPeImage.FileName := F_FileName;\r\n        if Assigned(FOnProcessFile) then\r\n          Synchronize(DoProcessFile);\r\n        if F_Process and FPeImage.StatusOK then\r\n        begin\r\n          if seExports in FOptions then\r\n          begin\r\n            ExportList := FPeImage.ExportList;\r\n            F_Option := seExports;\r\n            for I := 0 to ExportList.Count - 1 do\r\n            begin\r\n              if Terminated then\r\n                Break;\r\n              CompareNameAndNotify(ExportList[I].Name);\r\n            end;\r\n          end;\r\n          if FOptions * [seImports, seDelayImports, seBoundImports] <> [] then\r\n          begin\r\n            ImportList := FPeImage.ImportList;\r\n            FPeImage.TryGetNamesForOrdinalImports;\r\n            for I := 0 to ImportList.AllItemCount - 1 do\r\n              with ImportList.AllItems[I] do\r\n              begin\r\n                if Terminated then\r\n                  Break;\r\n                case ImportLib.ImportKind of\r\n                  ikImport:\r\n                    if seImports in FOptions then\r\n                    begin\r\n                      F_Option := seImports;\r\n                      CompareNameAndNotify(Name);\r\n                    end;\r\n                  ikDelayImport:\r\n                    if seDelayImports in FOptions then\r\n                    begin\r\n                      F_Option := seDelayImports;\r\n                      CompareNameAndNotify(Name);\r\n                    end;\r\n                  ikBoundImport:\r\n                    if seDelayImports in FOptions then\r\n                    begin\r\n                      F_Option := seBoundImports;\r\n                      CompareNameAndNotify(Name);\r\n                    end;\r\n                end;\r\n              end;\r\n          end;\r\n        end;\r\n        SearchResult := FindNext(Se);\r\n      end;\r\n    finally\r\n      FindClose(Se);\r\n    end;\r\n  end;\r\n\r\nbegin\r\n  FPeImage := TJclPeImage.Create(True);\r\n  PathList := TStringList.Create;\r\n  try\r\n    PathList.Sorted := True;\r\n    PathList.Duplicates := dupIgnore;\r\n    StrToStrings(FPath, ';', PathList);\r\n    for I := 0 to PathList.Count - 1 do\r\n      ProcessDirectorySearch(PathAddSeparator(Trim(PathList[I])) + '*.*');\r\n  finally\r\n    PathList.Free;\r\n    FPeImage.Free;\r\n  end;\r\nend;\r\n\r\nprocedure TJclPeNameSearch.Start;\r\nbegin\r\n  {$IFDEF RTL210_UP}\r\n  Suspended := False;\r\n  {$ELSE ~RTL210_UP}\r\n  Resume;\r\n  {$ENDIF ~RTL210_UP}\r\nend;\r\n\r\n//=== PE Image miscellaneous functions =======================================\r\n\r\nfunction IsValidPeFile(const FileName: TFileName): Boolean;\r\nvar\r\n  NtHeaders: TImageNtHeaders32;\r\nbegin\r\n  Result := PeGetNtHeaders32(FileName, NtHeaders);\r\nend;\r\n\r\nfunction InternalGetNtHeaders32(const FileName: TFileName; out NtHeaders): Boolean;\r\nvar\r\n  FileHandle: THandle;\r\n  Mapping: TJclFileMapping;\r\n  View: TJclFileMappingView;\r\n  HeadersPtr: PImageNtHeaders32;\r\nbegin\r\n  Result := False;\r\n  ResetMemory(NtHeaders, SizeOf(TImageNtHeaders32));\r\n  FileHandle := FileOpen(FileName, fmOpenRead or fmShareDenyWrite);\r\n  if FileHandle = INVALID_HANDLE_VALUE then\r\n    Exit;\r\n  try\r\n    if GetSizeOfFile(FileHandle) >= SizeOf(TImageDosHeader) then\r\n    begin\r\n      Mapping := TJclFileMapping.Create(FileHandle, '', PAGE_READONLY, 0, nil);\r\n      try\r\n        View := TJclFileMappingView.Create(Mapping, FILE_MAP_READ, 0, 0);\r\n        HeadersPtr := PeMapImgNtHeaders32(View.Memory);\r\n        if HeadersPtr <> nil then\r\n        begin\r\n          Result := True;\r\n          TImageNtHeaders32(NtHeaders) := HeadersPtr^;\r\n        end;\r\n      finally\r\n        Mapping.Free;\r\n      end;\r\n    end;\r\n  finally\r\n    FileClose(FileHandle);\r\n  end;\r\nend;\r\n\r\nfunction PeGetNtHeaders32(const FileName: TFileName; out NtHeaders: TImageNtHeaders32): Boolean;\r\nbegin\r\n  Result := InternalGetNtHeaders32(FileName, NtHeaders);\r\nend;\r\n\r\nfunction PeGetNtHeaders64(const FileName: TFileName; out NtHeaders: TImageNtHeaders64): Boolean;\r\nvar\r\n  FileHandle: THandle;\r\n  Mapping: TJclFileMapping;\r\n  View: TJclFileMappingView;\r\n  HeadersPtr: PImageNtHeaders64;\r\nbegin\r\n  Result := False;\r\n  ResetMemory(NtHeaders, SizeOf(NtHeaders));\r\n  FileHandle := FileOpen(FileName, fmOpenRead or fmShareDenyWrite);\r\n  if FileHandle = INVALID_HANDLE_VALUE then\r\n    Exit;\r\n  try\r\n    if GetSizeOfFile(FileHandle) >= SizeOf(TImageDosHeader) then\r\n    begin\r\n      Mapping := TJclFileMapping.Create(FileHandle, '', PAGE_READONLY, 0, nil);\r\n      try\r\n        View := TJclFileMappingView.Create(Mapping, FILE_MAP_READ, 0, 0);\r\n        HeadersPtr := PeMapImgNtHeaders64(View.Memory);\r\n        if HeadersPtr <> nil then\r\n        begin\r\n          Result := True;\r\n          NtHeaders := HeadersPtr^;\r\n        end;\r\n      finally\r\n        Mapping.Free;\r\n      end;\r\n    end;\r\n  finally\r\n    FileClose(FileHandle);\r\n  end;\r\nend;\r\n\r\nfunction PeCreateNameHintTable(const FileName: TFileName): Boolean;\r\nvar\r\n  PeImage, ExportsImage: TJclPeImage;\r\n  I: Integer;\r\n  ImportItem: TJclPeImportLibItem;\r\n  Thunk32: PImageThunkData32;\r\n  Thunk64: PImageThunkData64;\r\n  OrdinalName: PImageImportByName;\r\n  ExportItem: TJclPeExportFuncItem;\r\n  Cache: TJclPeImagesCache;\r\n  ImageBase32: TJclAddr32;\r\n  ImageBase64: TJclAddr64;\r\n  UTF8Name: TUTF8String;\r\n  ExportName: string;\r\nbegin\r\n  Cache := TJclPeImagesCache.Create;\r\n  try\r\n    PeImage := TJclPeImage.Create(False);\r\n    try\r\n      PeImage.ReadOnlyAccess := False;\r\n      PeImage.FileName := FileName;\r\n      Result := PeImage.ImportList.Count > 0;\r\n      for I := 0 to PeImage.ImportList.Count - 1 do\r\n      begin\r\n        ImportItem := PeImage.ImportList[I];\r\n        if ImportItem.ImportKind = ikBoundImport then\r\n          Continue;\r\n        ExportsImage := Cache[ImportItem.FileName];\r\n        ExportsImage.ExportList.PrepareForFastNameSearch;\r\n        case PEImage.Target of\r\n          taWin32:\r\n            begin\r\n              Thunk32 := ImportItem.ThunkData32;\r\n              ImageBase32 := PeImage.OptionalHeader32.ImageBase;\r\n              while Thunk32^.Function_ <> 0 do\r\n              begin\r\n                if Thunk32^.Ordinal and IMAGE_ORDINAL_FLAG32 = 0 then\r\n                begin\r\n                  case ImportItem.ImportKind of\r\n                    ikImport:\r\n                      OrdinalName := PImageImportByName(PeImage.RvaToVa(Thunk32^.AddressOfData));\r\n                    ikDelayImport:\r\n                      OrdinalName := PImageImportByName(PeImage.RvaToVa(Thunk32^.AddressOfData - ImageBase32));\r\n                  else\r\n                    OrdinalName := nil;\r\n                  end;\r\n                  UTF8Name := PAnsiChar(@OrdinalName.Name);\r\n                  if not TryUTF8ToString(UTF8Name, ExportName) then\r\n                    ExportName := string(UTF8Name);\r\n                  ExportItem := ExportsImage.ExportList.ItemFromName[ExportName];\r\n                  if ExportItem <> nil then\r\n                    OrdinalName.Hint := ExportItem.Hint\r\n                  else\r\n                    OrdinalName.Hint := 0;\r\n                end;\r\n                Inc(Thunk32);\r\n              end;\r\n            end;\r\n          taWin64:\r\n            begin\r\n              Thunk64 := ImportItem.ThunkData64;\r\n              ImageBase64 := PeImage.OptionalHeader64.ImageBase;\r\n              while Thunk64^.Function_ <> 0 do\r\n              begin\r\n                if Thunk64^.Ordinal and IMAGE_ORDINAL_FLAG64 = 0 then\r\n                begin\r\n                  case ImportItem.ImportKind of\r\n                    ikImport:\r\n                      OrdinalName := PImageImportByName(PeImage.RvaToVa(Thunk64^.AddressOfData));\r\n                    ikDelayImport:\r\n                      OrdinalName := PImageImportByName(PeImage.RvaToVa(Thunk64^.AddressOfData - ImageBase64));\r\n                  else\r\n                    OrdinalName := nil;\r\n                  end;\r\n                  UTF8Name := PAnsiChar(@OrdinalName.Name);\r\n                  if not TryUTF8ToString(UTF8Name, ExportName) then\r\n                    ExportName := string(UTF8Name);\r\n                  ExportItem := ExportsImage.ExportList.ItemFromName[ExportName];\r\n                  if ExportItem <> nil then\r\n                    OrdinalName.Hint := ExportItem.Hint\r\n                  else\r\n                    OrdinalName.Hint := 0;\r\n                end;\r\n                Inc(Thunk64);\r\n              end;\r\n            end;\r\n        end;\r\n      end;\r\n    finally\r\n      PeImage.Free;\r\n    end;\r\n  finally\r\n    Cache.Free;\r\n  end;\r\nend;\r\n\r\nfunction PeRebaseImage32(const ImageName: TFileName; NewBase: TJclAddr32;\r\n  TimeStamp, MaxNewSize: DWORD): TJclRebaseImageInfo32;\r\n\r\n  function CalculateBaseAddress: TJclAddr32;\r\n  var\r\n    FirstChar: Char;\r\n    ModuleName: string;\r\n  begin\r\n    ModuleName := ExtractFileName(ImageName);\r\n    if Length(ModuleName) > 0 then\r\n      FirstChar := UpCase(ModuleName[1])\r\n    else\r\n      FirstChar := NativeNull;\r\n    if not CharIsUpper(FirstChar) then\r\n      FirstChar := 'A';\r\n    Result := $60000000 + (((Ord(FirstChar) - Ord('A')) div 3) * $1000000);\r\n  end;\r\n\r\n{$IFDEF CPU64}\r\n{$IFNDEF DELPHI64_TEMPORARY}\r\nvar\r\n  NewIB, OldIB: QWord;\r\n{$ENDIF CPU64}\r\n{$ENDIF ~DELPHI64_TEMPORARY}\r\nbegin\r\n  if NewBase = 0 then\r\n    NewBase := CalculateBaseAddress;\r\n  with Result do\r\n  begin\r\n    NewImageBase := NewBase;\r\n    // OF: possible loss of data\r\n    {$IFDEF CPU32}\r\n    Win32Check(ReBaseImage(PAnsiChar(AnsiString(ImageName)), nil, True, False, False, MaxNewSize,\r\n      OldImageSize, OldImageBase, NewImageSize, NewImageBase, TimeStamp));\r\n    {$ENDIF CPU32}\r\n    {$IFDEF CPU64}\r\n    {$IFDEF DELPHI64_TEMPORARY}\r\n    System.Error(rePlatformNotImplemented);\r\n    {$ELSE ~DELPHI64_TEMPORARY}\r\n    NewIB := NewImageBase;\r\n    OldIB := OldImageBase;\r\n    Win32Check(ReBaseImage(PAnsiChar(AnsiString(ImageName)), nil, True, False, False, MaxNewSize,\r\n      OldImageSize, OldIB, NewImageSize, NewIB, TimeStamp));\r\n    NewImageBase := NewIB;\r\n    OldImageBase := OldIB;\r\n    {$ENDIF ~DELPHI64_TEMPORARY}\r\n    {$ENDIF CPU64}\r\n  end;\r\nend;\r\n\r\nfunction PeRebaseImage64(const ImageName: TFileName; NewBase: TJclAddr64;\r\n  TimeStamp, MaxNewSize: DWORD): TJclRebaseImageInfo64;\r\n\r\n  function CalculateBaseAddress: TJclAddr64;\r\n  var\r\n    FirstChar: Char;\r\n    ModuleName: string;\r\n  begin\r\n    ModuleName := ExtractFileName(ImageName);\r\n    if Length(ModuleName) > 0 then\r\n      FirstChar := UpCase(ModuleName[1])\r\n    else\r\n      FirstChar := NativeNull;\r\n    if not CharIsUpper(FirstChar) then\r\n      FirstChar := 'A';\r\n    Result := $60000000 + (((Ord(FirstChar) - Ord('A')) div 3) * $1000000);\r\n    Result := Result shl 32;\r\n  end;\r\n\r\nbegin\r\n  if NewBase = 0 then\r\n    NewBase := CalculateBaseAddress;\r\n  with Result do\r\n  begin\r\n    NewImageBase := NewBase;\r\n    // OF: possible loss of data\r\n    Win32Check(ReBaseImage64(PAnsiChar(AnsiString(ImageName)), nil, True, False, False, MaxNewSize,\r\n      OldImageSize, OldImageBase, NewImageSize, NewImageBase, TimeStamp));\r\n  end;\r\nend;\r\n\r\nfunction PeUpdateLinkerTimeStamp(const FileName: TFileName; const Time: TDateTime): Boolean;\r\nvar\r\n  Mapping: TJclFileMapping;\r\n  View: TJclFileMappingView;\r\n  Headers: PImageNtHeaders32; // works with 64-bit binaries too\r\n                              // only the optional field differs\r\nbegin\r\n  Mapping := TJclFileMapping.Create(FileName, fmOpenReadWrite, '', PAGE_READWRITE, 0, nil);\r\n  try\r\n    View := TJclFileMappingView.Create(Mapping, FILE_MAP_WRITE, 0, 0);\r\n    Headers := PeMapImgNtHeaders32(View.Memory);\r\n    Result := (Headers <> nil);\r\n    if Result then\r\n      Headers^.FileHeader.TimeDateStamp := TJclPeImage.DateTimeToStamp(Time);\r\n  finally\r\n    Mapping.Free;\r\n  end;\r\nend;\r\n\r\nfunction PeReadLinkerTimeStamp(const FileName: TFileName): TDateTime;\r\nvar\r\n  Mapping: TJclFileMappingStream;\r\n  Headers: PImageNtHeaders32; // works with 64-bit binaries too\r\n                              // only the optional field differs\r\nbegin\r\n  Mapping := TJclFileMappingStream.Create(FileName, fmOpenRead or fmShareDenyWrite);\r\n  try\r\n    Headers := PeMapImgNtHeaders32(Mapping.Memory);\r\n    if Headers <> nil then\r\n      Result := TJclPeImage.StampToDateTime(Headers^.FileHeader.TimeDateStamp)\r\n    else\r\n      Result := -1;\r\n  finally\r\n    Mapping.Free;\r\n  end;\r\nend;\r\n\r\n{ TODO -cHelp : Author: Uwe Schuster(just a generic version of JclDebug.InsertDebugDataIntoExecutableFile) }\r\nfunction PeInsertSection(const FileName: TFileName; SectionStream: TStream; SectionName: string): Boolean;\r\n  procedure RoundUpToAlignment(var Value: DWORD; Alignment: DWORD);\r\n  begin\r\n    if (Value mod Alignment) <> 0 then\r\n      Value := ((Value div Alignment) + 1) * Alignment;\r\n  end;\r\n  function PeInsertSection32(ImageStream: TMemoryStream): Boolean;\r\n  var\r\n    NtHeaders: PImageNtHeaders32;\r\n    Sections, LastSection, NewSection: PImageSectionHeader;\r\n    VirtualAlignedSize: DWORD;\r\n    I, X, NeedFill: Integer;\r\n    SectionDataSize: Integer;\r\n    UTF8Name: TUTF8String;\r\n  begin\r\n    Result := True;\r\n    try\r\n      SectionDataSize := SectionStream.Size;\r\n      NtHeaders := PeMapImgNtHeaders32(ImageStream.Memory);\r\n      Assert(NtHeaders <> nil);\r\n      Sections := PeMapImgSections32(NtHeaders);\r\n      Assert(Sections <> nil);\r\n      // Check whether there is not a section with the name already. If so, return True (#0000069)\r\n      if PeMapImgFindSection32(NtHeaders, SectionName) <> nil then\r\n      begin\r\n        Result := True;\r\n        Exit;\r\n      end;\r\n\r\n      LastSection := Sections;\r\n      Inc(LastSection, NtHeaders^.FileHeader.NumberOfSections - 1);\r\n      NewSection := LastSection;\r\n      Inc(NewSection);\r\n\r\n      // Increase the number of sections\r\n      Inc(NtHeaders^.FileHeader.NumberOfSections);\r\n      ResetMemory(NewSection^, SizeOf(TImageSectionHeader));\r\n      // JCLDEBUG Virtual Address\r\n      NewSection^.VirtualAddress := LastSection^.VirtualAddress + LastSection^.Misc.VirtualSize;\r\n      RoundUpToAlignment(NewSection^.VirtualAddress, NtHeaders^.OptionalHeader.SectionAlignment);\r\n      // JCLDEBUG Physical Offset\r\n      NewSection^.PointerToRawData := LastSection^.PointerToRawData + LastSection^.SizeOfRawData;\r\n      RoundUpToAlignment(NewSection^.PointerToRawData, NtHeaders^.OptionalHeader.FileAlignment);\r\n      // JCLDEBUG Section name\r\n      if not TryStringToUTF8(SectionName, UTF8Name) then\r\n        UTF8Name := TUTF8String(SectionName);\r\n      StrPLCopy(PAnsiChar(@NewSection^.Name), UTF8Name, IMAGE_SIZEOF_SHORT_NAME);\r\n      // JCLDEBUG Characteristics flags\r\n      NewSection^.Characteristics := IMAGE_SCN_MEM_READ or IMAGE_SCN_CNT_INITIALIZED_DATA;\r\n\r\n      // Size of virtual data area\r\n      NewSection^.Misc.VirtualSize := SectionDataSize;\r\n      VirtualAlignedSize := SectionDataSize;\r\n      RoundUpToAlignment(VirtualAlignedSize, NtHeaders^.OptionalHeader.SectionAlignment);\r\n      // Update Size of Image\r\n      Inc(NtHeaders^.OptionalHeader.SizeOfImage, VirtualAlignedSize);\r\n      // Raw data size\r\n      NewSection^.SizeOfRawData := SectionDataSize;\r\n      RoundUpToAlignment(NewSection^.SizeOfRawData, NtHeaders^.OptionalHeader.FileAlignment);\r\n      // Update Initialized data size\r\n      Inc(NtHeaders^.OptionalHeader.SizeOfInitializedData, NewSection^.SizeOfRawData);\r\n\r\n      // Fill data to alignment\r\n      NeedFill := INT_PTR(NewSection^.SizeOfRawData) - SectionDataSize;\r\n\r\n      // Note: Delphi linker seems to generate incorrect (unaligned) size of\r\n      // the executable when adding TD32 debug data so the position could be\r\n      // behind the size of the file then.\r\n      ImageStream.Seek(NewSection^.PointerToRawData, soBeginning);\r\n      ImageStream.CopyFrom(SectionStream, 0);\r\n      X := 0;\r\n      for I := 1 to NeedFill do\r\n        ImageStream.WriteBuffer(X, 1);\r\n    except\r\n      Result := False;\r\n    end;\r\n  end;\r\n  function PeInsertSection64(ImageStream: TMemoryStream): Boolean;\r\n  var\r\n    NtHeaders: PImageNtHeaders64;\r\n    Sections, LastSection, NewSection: PImageSectionHeader;\r\n    VirtualAlignedSize: DWORD;\r\n    I, X, NeedFill: Integer;\r\n    SectionDataSize: Integer;\r\n    UTF8Name: TUTF8String;\r\n  begin\r\n    Result := True;\r\n    try\r\n      SectionDataSize := SectionStream.Size;\r\n      NtHeaders := PeMapImgNtHeaders64(ImageStream.Memory);\r\n      Assert(NtHeaders <> nil);\r\n      Sections := PeMapImgSections64(NtHeaders);\r\n      Assert(Sections <> nil);\r\n      // Check whether there is not a section with the name already. If so, return True (#0000069)\r\n      if PeMapImgFindSection64(NtHeaders, SectionName) <> nil then\r\n      begin\r\n        Result := True;\r\n        Exit;\r\n      end;\r\n\r\n      LastSection := Sections;\r\n      Inc(LastSection, NtHeaders^.FileHeader.NumberOfSections - 1);\r\n      NewSection := LastSection;\r\n      Inc(NewSection);\r\n\r\n      // Increase the number of sections\r\n      Inc(NtHeaders^.FileHeader.NumberOfSections);\r\n      ResetMemory(NewSection^, SizeOf(TImageSectionHeader));\r\n      // JCLDEBUG Virtual Address\r\n      NewSection^.VirtualAddress := LastSection^.VirtualAddress + LastSection^.Misc.VirtualSize;\r\n      RoundUpToAlignment(NewSection^.VirtualAddress, NtHeaders^.OptionalHeader.SectionAlignment);\r\n      // JCLDEBUG Physical Offset\r\n      NewSection^.PointerToRawData := LastSection^.PointerToRawData + LastSection^.SizeOfRawData;\r\n      RoundUpToAlignment(NewSection^.PointerToRawData, NtHeaders^.OptionalHeader.FileAlignment);\r\n      // JCLDEBUG Section name\r\n      if not TryStringToUTF8(SectionName, UTF8Name) then\r\n        UTF8Name := TUTF8String(SectionName);\r\n      StrPLCopy(PAnsiChar(@NewSection^.Name), UTF8Name, IMAGE_SIZEOF_SHORT_NAME);\r\n      // JCLDEBUG Characteristics flags\r\n      NewSection^.Characteristics := IMAGE_SCN_MEM_READ or IMAGE_SCN_CNT_INITIALIZED_DATA;\r\n\r\n      // Size of virtual data area\r\n      NewSection^.Misc.VirtualSize := SectionDataSize;\r\n      VirtualAlignedSize := SectionDataSize;\r\n      RoundUpToAlignment(VirtualAlignedSize, NtHeaders^.OptionalHeader.SectionAlignment);\r\n      // Update Size of Image\r\n      Inc(NtHeaders^.OptionalHeader.SizeOfImage, VirtualAlignedSize);\r\n      // Raw data size\r\n      NewSection^.SizeOfRawData := SectionDataSize;\r\n      RoundUpToAlignment(NewSection^.SizeOfRawData, NtHeaders^.OptionalHeader.FileAlignment);\r\n      // Update Initialized data size\r\n      Inc(NtHeaders^.OptionalHeader.SizeOfInitializedData, NewSection^.SizeOfRawData);\r\n\r\n      // Fill data to alignment\r\n      NeedFill := INT_PTR(NewSection^.SizeOfRawData) - SectionDataSize;\r\n\r\n      // Note: Delphi linker seems to generate incorrect (unaligned) size of\r\n      // the executable when adding TD32 debug data so the position could be\r\n      // behind the size of the file then.\r\n      ImageStream.Seek(NewSection^.PointerToRawData, soBeginning);\r\n      ImageStream.CopyFrom(SectionStream, 0);\r\n      X := 0;\r\n      for I := 1 to NeedFill do\r\n        ImageStream.WriteBuffer(X, 1);\r\n    except\r\n      Result := False;\r\n    end;\r\n  end;\r\n\r\nvar\r\n  ImageStream: TMemoryStream;\r\nbegin\r\n  Result := Assigned(SectionStream) and (SectionName <> '');\r\n  if not Result then\r\n    Exit;\r\n  ImageStream := TMemoryStream.Create;\r\n  try\r\n    ImageStream.LoadFromFile(FileName);\r\n    case PeMapImgTarget(ImageStream.Memory) of\r\n      taWin32:\r\n        Result := PeInsertSection32(ImageStream);\r\n      taWin64:\r\n        Result := PeInsertSection64(ImageStream);\r\n      //taUnknown:\r\n    else\r\n      Result := False;\r\n    end;\r\n\r\n    if Result then\r\n      ImageStream.SaveToFile(FileName);\r\n  finally\r\n    ImageStream.Free;\r\n  end;\r\nend;\r\n\r\nfunction PeVerifyCheckSum(const FileName: TFileName): Boolean;\r\nbegin\r\n  with CreatePeImage(FileName) do\r\n  try\r\n    Result := VerifyCheckSum;\r\n  finally\r\n    Free;\r\n  end;\r\nend;\r\n\r\nfunction PeClearCheckSum(const FileName: TFileName): Boolean;\r\n  function PeClearCheckSum32(ModuleAddress: Pointer): Boolean;\r\n  var\r\n    Headers: PImageNtHeaders32;\r\n  begin\r\n    Headers := PeMapImgNtHeaders32(ModuleAddress);\r\n    Result := (Headers <> nil);\r\n    if Result then\r\n      Headers^.OptionalHeader.CheckSum := 0;\r\n  end;\r\n  function PeClearCheckSum64(ModuleAddress: Pointer): Boolean;\r\n  var\r\n    Headers: PImageNtHeaders64;\r\n  begin\r\n    Headers := PeMapImgNtHeaders64(ModuleAddress);\r\n    Result := (Headers <> nil);\r\n    if Result then\r\n      Headers^.OptionalHeader.CheckSum := 0;\r\n  end;\r\nvar\r\n  Mapping: TJclFileMapping;\r\n  View: TJclFileMappingView;\r\nbegin\r\n  Mapping := TJclFileMapping.Create(FileName, fmOpenReadWrite, '', PAGE_READWRITE, 0, nil);\r\n  try\r\n    View := TJclFileMappingView.Create(Mapping, FILE_MAP_WRITE, 0, 0);\r\n    case PeMapImgTarget(View.Memory) of\r\n      taWin32:\r\n        Result := PeClearCheckSum32(View.Memory);\r\n      taWin64:\r\n        Result := PeClearCheckSum64(View.Memory);\r\n      //taUnknown:\r\n    else\r\n      Result := False;\r\n    end;\r\n  finally\r\n    Mapping.Free;\r\n  end;\r\nend;\r\n\r\nfunction PeUpdateCheckSum(const FileName: TFileName): Boolean;\r\nvar\r\n  LI: TLoadedImage;\r\nbegin\r\n  LI.ModuleName := nil;\r\n  // OF: possible loss of data\r\n  Result := MapAndLoad(PAnsiChar(AnsiString(FileName)), nil, LI, True, False);\r\n  if Result then\r\n    Result := UnMapAndLoad(LI);\r\nend;\r\n\r\n// Various simple PE Image searching and listing routines\r\n\r\nfunction PeDoesExportFunction(const FileName: TFileName; const FunctionName: string;\r\n  Options: TJclSmartCompOptions): Boolean;\r\nbegin\r\n  with CreatePeImage(FileName) do\r\n  try\r\n    Result := StatusOK and Assigned(ExportList.SmartFindName(FunctionName, Options));\r\n  finally\r\n    Free;\r\n  end;\r\nend;\r\n\r\nfunction PeIsExportFunctionForwardedEx(const FileName: TFileName; const FunctionName: string;\r\n  out ForwardedName: string; Options: TJclSmartCompOptions): Boolean;\r\nvar\r\n  ExportItem: TJclPeExportFuncItem;\r\nbegin\r\n  with CreatePeImage(FileName) do\r\n  try\r\n    Result := StatusOK;\r\n    if Result then\r\n    begin\r\n      ExportItem := ExportList.SmartFindName(FunctionName, Options);\r\n      if ExportItem <> nil then\r\n      begin\r\n        Result := ExportItem.IsForwarded;\r\n        ForwardedName := ExportItem.ForwardedName;\r\n      end\r\n      else\r\n      begin\r\n        Result := False;\r\n        ForwardedName := '';\r\n      end;\r\n    end;\r\n  finally\r\n    Free;\r\n  end;\r\nend;\r\n\r\nfunction PeIsExportFunctionForwarded(const FileName: TFileName; const FunctionName: string;\r\n  Options: TJclSmartCompOptions): Boolean;\r\nvar\r\n  Dummy: string;\r\nbegin\r\n  Result := PeIsExportFunctionForwardedEx(FileName, FunctionName, Dummy, Options);\r\nend;\r\n\r\nfunction PeDoesImportFunction(const FileName: TFileName; const FunctionName: string;\r\n  const LibraryName: string; Options: TJclSmartCompOptions): Boolean;\r\nbegin\r\n  with CreatePeImage(FileName) do\r\n  try\r\n    Result := StatusOK;\r\n    if Result then\r\n      with ImportList do\r\n      begin\r\n        TryGetNamesForOrdinalImports;\r\n        Result := SmartFindName(FunctionName, LibraryName, Options) <> nil;\r\n      end;\r\n  finally\r\n    Free;\r\n  end;\r\nend;\r\n\r\nfunction PeDoesImportLibrary(const FileName: TFileName; const LibraryName: string;\r\n  Recursive: Boolean): Boolean;\r\nvar\r\n  SL: TStringList;\r\nbegin\r\n  with CreatePeImage(FileName) do\r\n  try\r\n    Result := StatusOK;\r\n    if Result then\r\n    begin\r\n      SL := InternalImportedLibraries(FileName, Recursive, False, nil);\r\n      try\r\n        Result := SL.IndexOf(LibraryName) > -1;\r\n      finally\r\n        SL.Free;\r\n      end;\r\n    end;\r\n  finally\r\n    Free;\r\n  end;\r\nend;\r\n\r\nfunction PeImportedLibraries(const FileName: TFileName; const LibrariesList: TStrings;\r\n  Recursive, FullPathName: Boolean): Boolean;\r\nvar\r\n  SL: TStringList;\r\nbegin\r\n  with CreatePeImage(FileName) do\r\n  try\r\n    Result := StatusOK;\r\n    if Result then\r\n    begin\r\n      SL := InternalImportedLibraries(FileName, Recursive, FullPathName, nil);\r\n      try\r\n        LibrariesList.Assign(SL);\r\n      finally\r\n        SL.Free;\r\n      end;\r\n    end;\r\n  finally\r\n    Free;\r\n  end;\r\nend;\r\n\r\nfunction PeImportedFunctions(const FileName: TFileName; const FunctionsList: TStrings;\r\n  const LibraryName: string; IncludeLibNames: Boolean): Boolean;\r\nvar\r\n  I: Integer;\r\nbegin\r\n  with CreatePeImage(FileName) do\r\n    try\r\n      Result := StatusOK;\r\n      if Result then\r\n        with ImportList do\r\n        begin\r\n          TryGetNamesForOrdinalImports;\r\n          FunctionsList.BeginUpdate;\r\n          try\r\n            for I := 0 to AllItemCount - 1 do\r\n              with AllItems[I] do\r\n                if ((Length(LibraryName) = 0) or StrSame(ImportLib.Name, LibraryName)) and\r\n                  (Name <> '') then\r\n                begin\r\n                  if IncludeLibNames then\r\n                    FunctionsList.Add(ImportLib.Name + '=' + Name)\r\n                  else\r\n                    FunctionsList.Add(Name);\r\n                end;\r\n          finally\r\n            FunctionsList.EndUpdate;\r\n          end;\r\n        end;\r\n    finally\r\n      Free;\r\n    end;\r\nend;\r\n\r\nfunction PeExportedFunctions(const FileName: TFileName; const FunctionsList: TStrings): Boolean;\r\nvar\r\n  I: Integer;\r\nbegin\r\n  with CreatePeImage(FileName) do\r\n    try\r\n      Result := StatusOK;\r\n      if Result then\r\n      begin\r\n        FunctionsList.BeginUpdate;\r\n        try\r\n          with ExportList do\r\n            for I := 0 to Count - 1 do\r\n              with Items[I] do\r\n                if not IsExportedVariable then\r\n                  FunctionsList.Add(Name);\r\n        finally\r\n          FunctionsList.EndUpdate;\r\n        end;\r\n      end;\r\n    finally\r\n      Free;\r\n    end;\r\nend;\r\n\r\nfunction PeExportedNames(const FileName: TFileName; const FunctionsList: TStrings): Boolean;\r\nvar\r\n  I: Integer;\r\nbegin\r\n  with CreatePeImage(FileName) do\r\n  try\r\n    Result := StatusOK;\r\n    if Result then\r\n    begin\r\n      FunctionsList.BeginUpdate;\r\n      try\r\n        with ExportList do\r\n          for I := 0 to Count - 1 do\r\n            FunctionsList.Add(Items[I].Name);\r\n      finally\r\n        FunctionsList.EndUpdate;\r\n      end;\r\n    end;\r\n  finally\r\n    Free;\r\n  end;\r\nend;\r\n\r\nfunction PeExportedVariables(const FileName: TFileName; const FunctionsList: TStrings): Boolean;\r\nvar\r\n  I: Integer;\r\nbegin\r\n  with CreatePeImage(FileName) do\r\n  try\r\n    Result := StatusOK;\r\n    if Result then\r\n    begin\r\n      FunctionsList.BeginUpdate;\r\n      try\r\n        with ExportList do\r\n          for I := 0 to Count - 1 do\r\n            with Items[I] do\r\n              if IsExportedVariable then\r\n                FunctionsList.AddObject(Name, Pointer(Address));\r\n      finally\r\n        FunctionsList.EndUpdate;\r\n      end;\r\n    end;\r\n  finally\r\n    Free;\r\n  end;\r\nend;\r\n\r\nfunction PeResourceKindNames(const FileName: TFileName; ResourceType: TJclPeResourceKind;\r\n  const NamesList: TStrings): Boolean;\r\nbegin\r\n  with CreatePeImage(FileName) do\r\n  try\r\n    Result := StatusOK and ResourceList.ListResourceNames(ResourceType, NamesList);\r\n  finally\r\n    Free;\r\n  end;\r\nend;\r\n\r\n{$IFDEF BORLAND}\r\n\r\nfunction PeBorFormNames(const FileName: TFileName; const NamesList: TStrings): Boolean;\r\nvar\r\n  I: Integer;\r\n  BorImage: TJclPeBorImage;\r\n  BorForm: TJclPeBorForm;\r\nbegin\r\n  BorImage := TJclPeBorImage.Create(True);\r\n  try\r\n    BorImage.FileName := FileName;\r\n    Result := BorImage.IsBorlandImage;\r\n    if Result then\r\n    begin\r\n      NamesList.BeginUpdate;\r\n      try\r\n        for I := 0 to BorImage.FormCount - 1 do\r\n        begin\r\n          BorForm := BorImage.Forms[I];\r\n          NamesList.AddObject(BorForm.DisplayName, Pointer(BorForm.ResItem.RawEntryDataSize));\r\n        end;\r\n      finally\r\n        NamesList.EndUpdate;\r\n      end;\r\n    end;\r\n  finally\r\n    BorImage.Free;\r\n  end;\r\nend;\r\n\r\nfunction PeBorDependedPackages(const FileName: TFileName; PackagesList: TStrings;\r\n  FullPathName, Descriptions: Boolean): Boolean;\r\nvar\r\n  BorImage: TJclPeBorImage;\r\nbegin\r\n  BorImage := TJclPeBorImage.Create(True);\r\n  try\r\n    BorImage.FileName := FileName;\r\n    Result := BorImage.DependedPackages(PackagesList, FullPathName, Descriptions);\r\n  finally\r\n    BorImage.Free;\r\n  end;\r\nend;\r\n\r\n{$ENDIF BORLAND}\r\n\r\n// Missing imports checking routines\r\n\r\nfunction PeFindMissingImports(const FileName: TFileName; MissingImportsList: TStrings): Boolean;\r\nvar\r\n  Cache: TJclPeImagesCache;\r\n  FileImage, LibImage: TJclPeImage;\r\n  L, I: Integer;\r\n  LibItem: TJclPeImportLibItem;\r\n  List: TStringList;\r\nbegin\r\n  Result := False;\r\n  List := nil;\r\n  Cache := TJclPeImagesCache.Create;\r\n  try\r\n    List := TStringList.Create;\r\n    List.Duplicates := dupIgnore;\r\n    List.Sorted := True;\r\n    FileImage := Cache[FileName];\r\n    if FileImage.StatusOK then\r\n    begin\r\n      for L := 0 to FileImage.ImportList.Count - 1 do\r\n      begin\r\n        LibItem := FileImage.ImportList[L];\r\n        LibImage := Cache[LibItem.FileName];\r\n        if LibImage.StatusOK then\r\n        begin\r\n          LibImage.ExportList.PrepareForFastNameSearch;\r\n          for I := 0 to LibItem.Count - 1 do\r\n            if LibImage.ExportList.ItemFromName[LibItem[I].Name] = nil then\r\n              List.Add(LibItem.Name + '=' + LibItem[I].Name);\r\n        end\r\n        else\r\n          List.Add(LibItem.Name + '=');\r\n      end;\r\n      MissingImportsList.Assign(List);\r\n      Result := List.Count > 0;\r\n    end;\r\n  finally\r\n    List.Free;\r\n    Cache.Free;\r\n  end;\r\nend;\r\n\r\nfunction PeFindMissingImports(RequiredImportsList, MissingImportsList: TStrings): Boolean;\r\nvar\r\n  Cache: TJclPeImagesCache;\r\n  LibImage: TJclPeImage;\r\n  I, SepPos: Integer;\r\n  List: TStringList;\r\n  S, LibName, ImportName: string;\r\nbegin\r\n  List := nil;\r\n  Cache := TJclPeImagesCache.Create;\r\n  try\r\n    List := TStringList.Create;\r\n    List.Duplicates := dupIgnore;\r\n    List.Sorted := True;\r\n    for I := 0 to RequiredImportsList.Count - 1 do\r\n    begin\r\n      S := RequiredImportsList[I];\r\n      SepPos := Pos('=', S);\r\n      if SepPos = 0 then\r\n        Continue;\r\n      LibName := StrLeft(S, SepPos - 1);\r\n      LibImage := Cache[LibName];\r\n      if LibImage.StatusOK then\r\n      begin\r\n        LibImage.ExportList.PrepareForFastNameSearch;\r\n        ImportName := StrRestOf(S, SepPos + 1);\r\n        if LibImage.ExportList.ItemFromName[ImportName] = nil then\r\n          List.Add(LibName + '=' + ImportName);\r\n      end\r\n      else\r\n        List.Add(LibName + '=');\r\n    end;\r\n    MissingImportsList.Assign(List);\r\n    Result := List.Count > 0;\r\n  finally\r\n    List.Free;\r\n    Cache.Free;\r\n  end;\r\nend;\r\n\r\nfunction PeCreateRequiredImportList(const FileName: TFileName; RequiredImportsList: TStrings): Boolean;\r\nbegin\r\n  Result := PeImportedFunctions(FileName, RequiredImportsList, '', True);\r\nend;\r\n\r\n// Mapped or loaded image related functions\r\n\r\nfunction PeMapImgNtHeaders32(const BaseAddress: Pointer): PImageNtHeaders32;\r\nbegin\r\n  Result := nil;\r\n  if IsBadReadPtr(BaseAddress, SizeOf(TImageDosHeader)) then\r\n    Exit;\r\n  if (PImageDosHeader(BaseAddress)^.e_magic <> IMAGE_DOS_SIGNATURE) or\r\n    (PImageDosHeader(BaseAddress)^._lfanew = 0) then\r\n    Exit;\r\n  Result := PImageNtHeaders32(TJclAddr(BaseAddress) + DWORD(PImageDosHeader(BaseAddress)^._lfanew));\r\n  if IsBadReadPtr(Result, SizeOf(TImageNtHeaders32)) or\r\n    (Result^.Signature <> IMAGE_NT_SIGNATURE) then\r\n      Result := nil\r\nend;\r\n\r\nfunction PeMapImgNtHeaders32(Stream: TStream; const BasePosition: Int64; out NtHeaders32: TImageNtHeaders32): Int64;\r\nvar\r\n  ImageDosHeader: TImageDosHeader;\r\nbegin\r\n  ResetMemory(NtHeaders32, SizeOf(NtHeaders32));\r\n  Result := -1;\r\n\r\n  if (Stream.Seek(BasePosition, soBeginning) <> BasePosition) or\r\n    (Stream.Read(ImageDosHeader, SizeOf(ImageDosHeader)) <> SizeOf(ImageDosHeader)) then\r\n    raise EJclPeImageError.CreateRes(@SReadError);\r\n\r\n  if (ImageDosHeader.e_magic <> IMAGE_DOS_SIGNATURE) or\r\n    (ImageDosHeader._lfanew = 0) then\r\n    Exit;\r\n\r\n  Result := BasePosition + DWORD(ImageDosHeader._lfanew);\r\n\r\n  if (Stream.Seek(Result, soBeginning) <> Result) or\r\n    (Stream.Read(NtHeaders32, SizeOf(NtHeaders32)) <> SizeOf(NtHeaders32)) then\r\n    raise EJclPeImageError.CreateRes(@SReadError);\r\n\r\n  if NtHeaders32.Signature <> IMAGE_NT_SIGNATURE then\r\n    Result := -1;\r\nend;\r\n\r\nfunction PeMapImgNtHeaders64(const BaseAddress: Pointer): PImageNtHeaders64;\r\nbegin\r\n  Result := nil;\r\n  if IsBadReadPtr(BaseAddress, SizeOf(TImageDosHeader)) then\r\n    Exit;\r\n  if (PImageDosHeader(BaseAddress)^.e_magic <> IMAGE_DOS_SIGNATURE) or\r\n    (PImageDosHeader(BaseAddress)^._lfanew = 0) then\r\n    Exit;\r\n  Result := PImageNtHeaders64(TJclAddr(BaseAddress) + DWORD(PImageDosHeader(BaseAddress)^._lfanew));\r\n  if IsBadReadPtr(Result, SizeOf(TImageNtHeaders64)) or\r\n    (Result^.Signature <> IMAGE_NT_SIGNATURE) then\r\n      Result := nil\r\nend;\r\n\r\nfunction PeMapImgNtHeaders64(Stream: TStream; const BasePosition: Int64; out NtHeaders64: TImageNtHeaders64): Int64;\r\nvar\r\n  ImageDosHeader: TImageDosHeader;\r\nbegin\r\n  ResetMemory(NtHeaders64, SizeOf(NtHeaders64));\r\n  Result := -1;\r\n\r\n  if (Stream.Seek(BasePosition, soBeginning) <> BasePosition) or\r\n    (Stream.Read(ImageDosHeader, SizeOf(ImageDosHeader)) <> SizeOf(ImageDosHeader)) then\r\n    raise EJclPeImageError.CreateRes(@SReadError);\r\n\r\n  if (ImageDosHeader.e_magic <> IMAGE_DOS_SIGNATURE) or\r\n    (ImageDosHeader._lfanew = 0) then\r\n    Exit;\r\n\r\n  Result := BasePosition + DWORD(ImageDosHeader._lfanew);\r\n\r\n  if (Stream.Seek(Result, soBeginning) <> Result) or\r\n    (Stream.Read(NtHeaders64, SizeOf(NtHeaders64)) <> SizeOf(NtHeaders64)) then\r\n    raise EJclPeImageError.CreateRes(@SReadError);\r\n\r\n  if NtHeaders64.Signature <> IMAGE_NT_SIGNATURE then\r\n    Result := -1;\r\nend;\r\n\r\nfunction PeMapImgSize(const BaseAddress: Pointer): DWORD;\r\nbegin\r\n  case PeMapImgTarget(BaseAddress) of\r\n    taWin32:\r\n      Result := PeMapImgSize32(BaseAddress);\r\n    taWin64:\r\n      Result := PeMapImgSize64(BaseAddress);\r\n    //taUnknown:\r\n  else\r\n    Result := 0;\r\n  end;\r\nend;\r\n\r\nfunction PeMapImgSize(Stream: TStream; const BasePosition: Int64): DWORD;\r\nbegin\r\n  case PeMapImgTarget(Stream, BasePosition) of\r\n    taWin32:\r\n      Result := PeMapImgSize32(Stream, BasePosition);\r\n    taWin64:\r\n      Result := PeMapImgSize64(Stream, BasePosition);\r\n    //taUnknown:\r\n  else\r\n    Result := 0;\r\n  end;\r\nend;\r\n\r\nfunction PeMapImgSize32(const BaseAddress: Pointer): DWORD;\r\nvar\r\n  NtHeaders32: PImageNtHeaders32;\r\nbegin\r\n  Result := 0;\r\n  NtHeaders32 := PeMapImgNtHeaders32(BaseAddress);\r\n  if Assigned(NtHeaders32) then\r\n    Result := NtHeaders32^.OptionalHeader.SizeOfImage;\r\nend;\r\n\r\nfunction PeMapImgSize32(Stream: TStream; const BasePosition: Int64): DWORD;\r\nvar\r\n  NtHeaders32: TImageNtHeaders32;\r\nbegin\r\n  Result := 0;\r\n  if PeMapImgNtHeaders32(Stream, BasePosition, NtHeaders32) <> -1 then\r\n    Result := NtHeaders32.OptionalHeader.SizeOfImage;\r\nend;\r\n\r\nfunction PeMapImgSize64(const BaseAddress: Pointer): DWORD;\r\nvar\r\n  NtHeaders64: PImageNtHeaders64;\r\nbegin\r\n  Result := 0;\r\n  NtHeaders64 := PeMapImgNtHeaders64(BaseAddress);\r\n  if Assigned(NtHeaders64) then\r\n    Result := NtHeaders64^.OptionalHeader.SizeOfImage;\r\nend;\r\n\r\nfunction PeMapImgSize64(Stream: TStream; const BasePosition: Int64): DWORD;\r\nvar\r\n  NtHeaders64: TImageNtHeaders64;\r\nbegin\r\n  Result := 0;\r\n  if PeMapImgNtHeaders64(Stream, BasePosition, NtHeaders64) <> -1 then\r\n    Result := NtHeaders64.OptionalHeader.SizeOfImage;\r\nend;\r\n\r\nfunction PeMapImgLibraryName(const BaseAddress: Pointer): string;\r\nbegin\r\n  case PeMapImgTarget(BaseAddress) of\r\n    taWin32:\r\n      Result := PeMapImgLibraryName32(BaseAddress);\r\n    taWin64:\r\n      Result := PeMapImgLibraryName64(BaseAddress);\r\n    //taUnknown:\r\n  else\r\n    Result := '';\r\n  end;\r\nend;\r\n\r\nfunction PeMapImgLibraryName32(const BaseAddress: Pointer): string;\r\nvar\r\n  NtHeaders: PImageNtHeaders32;\r\n  DataDir: TImageDataDirectory;\r\n  ExportDir: PImageExportDirectory;\r\n  UTF8Name: TUTF8String;\r\nbegin\r\n  Result := '';\r\n  NtHeaders := PeMapImgNtHeaders32(BaseAddress);\r\n  if NtHeaders = nil then\r\n    Exit;\r\n  DataDir := NtHeaders^.OptionalHeader.DataDirectory[IMAGE_DIRECTORY_ENTRY_EXPORT];\r\n  if DataDir.Size = 0 then\r\n    Exit;\r\n  ExportDir := PImageExportDirectory(TJclAddr(BaseAddress) + DataDir.VirtualAddress);\r\n  if IsBadReadPtr(ExportDir, SizeOf(TImageExportDirectory)) or (ExportDir^.Name = 0) then\r\n    Exit;\r\n  UTF8Name := PAnsiChar(TJclAddr(BaseAddress) + ExportDir^.Name);\r\n  if not TryUTF8ToString(UTF8Name, Result) then\r\n    Result := string(UTF8Name);\r\nend;\r\n\r\nfunction PeMapImgLibraryName64(const BaseAddress: Pointer): string;\r\nvar\r\n  NtHeaders: PImageNtHeaders64;\r\n  DataDir: TImageDataDirectory;\r\n  ExportDir: PImageExportDirectory;\r\n  UTF8Name: TUTF8String;\r\nbegin\r\n  Result := '';\r\n  NtHeaders := PeMapImgNtHeaders64(BaseAddress);\r\n  if NtHeaders = nil then\r\n    Exit;\r\n  DataDir := NtHeaders^.OptionalHeader.DataDirectory[IMAGE_DIRECTORY_ENTRY_EXPORT];\r\n  if DataDir.Size = 0 then\r\n    Exit;\r\n  ExportDir := PImageExportDirectory(TJclAddr(BaseAddress) + DataDir.VirtualAddress);\r\n  if IsBadReadPtr(ExportDir, SizeOf(TImageExportDirectory)) or (ExportDir^.Name = 0) then\r\n    Exit;\r\n  UTF8Name := PAnsiChar(TJclAddr(BaseAddress) + ExportDir^.Name);\r\n  if not TryUTF8ToString(UTF8Name, Result) then\r\n    Result := string(UTF8Name);\r\nend;\r\n\r\nfunction PeMapImgTarget(const BaseAddress: Pointer): TJclPeTarget;\r\nvar\r\n  ImageNtHeaders: PImageNtHeaders32;\r\nbegin\r\n  Result := taUnknown;\r\n\r\n  ImageNtHeaders := PeMapImgNtHeaders32(BaseAddress);\r\n  if Assigned(ImageNtHeaders) then\r\n    case ImageNtHeaders.FileHeader.Machine of\r\n      IMAGE_FILE_MACHINE_I386:\r\n        Result := taWin32;\r\n      IMAGE_FILE_MACHINE_AMD64:\r\n        Result := taWin64;\r\n    end;\r\nend;\r\n\r\nfunction PeMapImgTarget(Stream: TStream; const BasePosition: Int64): TJclPeTarget;\r\nvar\r\n  ImageNtHeaders: TImageNtHeaders32;\r\nbegin\r\n  Result := taUnknown;\r\n\r\n  if PeMapImgNtHeaders32(Stream, BasePosition, ImageNtHeaders) <> -1 then\r\n  begin\r\n    case ImageNtHeaders.FileHeader.Machine of\r\n      IMAGE_FILE_MACHINE_I386:\r\n        Result := taWin32;\r\n      IMAGE_FILE_MACHINE_AMD64:\r\n        Result := taWin64;\r\n    end;\r\n  end;\r\nend;\r\n\r\nfunction PeMapImgSections32(NtHeaders: PImageNtHeaders32): PImageSectionHeader;\r\nbegin\r\n  if NtHeaders = nil then\r\n    Result := nil\r\n  else\r\n    Result := PImageSectionHeader(TJclAddr(@NtHeaders^.OptionalHeader) +\r\n      NtHeaders^.FileHeader.SizeOfOptionalHeader);\r\nend;\r\n\r\nfunction PeMapImgSections32(Stream: TStream; const NtHeaders32Position: Int64; const NtHeaders32: TImageNtHeaders32;\r\n  out ImageSectionHeaders: TImageSectionHeaderArray): Int64;\r\nvar\r\n  SectionSize: Integer;\r\nbegin\r\n  if NtHeaders32Position = -1 then\r\n  begin\r\n    SetLength(ImageSectionHeaders, 0);\r\n    Result := -1;\r\n  end\r\n  else\r\n  begin\r\n    SetLength(ImageSectionHeaders, NtHeaders32.FileHeader.NumberOfSections);\r\n    Result := NtHeaders32Position + SizeOf(NtHeaders32.Signature) + SizeOf(NtHeaders32.FileHeader) + NtHeaders32.FileHeader.SizeOfOptionalHeader;\r\n\r\n    SectionSize := SizeOf(ImageSectionHeaders[0]) * Length(ImageSectionHeaders);\r\n    if (Stream.Seek(Result, soBeginning) <> Result) or\r\n      (Stream.Read(ImageSectionHeaders[0], SectionSize) <> SectionSize) then\r\n      raise EJclPeImageError.CreateRes(@SReadError);\r\n  end;\r\nend;\r\n\r\nfunction PeMapImgSections64(NtHeaders: PImageNtHeaders64): PImageSectionHeader;\r\nbegin\r\n  if NtHeaders = nil then\r\n    Result := nil\r\n  else\r\n    Result := PImageSectionHeader(TJclAddr(@NtHeaders^.OptionalHeader) +\r\n      NtHeaders^.FileHeader.SizeOfOptionalHeader);\r\nend;\r\n\r\nfunction PeMapImgSections64(Stream: TStream; const NtHeaders64Position: Int64; const NtHeaders64: TImageNtHeaders64;\r\n  out ImageSectionHeaders: TImageSectionHeaderArray): Int64;\r\nvar\r\n  SectionSize: Integer;\r\nbegin\r\n  if NtHeaders64Position = -1 then\r\n  begin\r\n    SetLength(ImageSectionHeaders, 0);\r\n    Result := -1;\r\n  end\r\n  else\r\n  begin\r\n    SetLength(ImageSectionHeaders, NtHeaders64.FileHeader.NumberOfSections);\r\n    Result := NtHeaders64Position + SizeOf(NtHeaders64.Signature) + SizeOf(NtHeaders64.FileHeader) + NtHeaders64.FileHeader.SizeOfOptionalHeader;\r\n\r\n    SectionSize := SizeOf(ImageSectionHeaders[0]) * Length(ImageSectionHeaders);\r\n    if (Stream.Seek(Result, soBeginning) <> Result) or\r\n      (Stream.Read(ImageSectionHeaders[0], SectionSize) <> SectionSize) then\r\n      raise EJclPeImageError.CreateRes(@SReadError);\r\n  end;\r\nend;\r\n\r\nfunction PeMapImgFindSection32(NtHeaders: PImageNtHeaders32;\r\n  const SectionName: string): PImageSectionHeader;\r\nvar\r\n  Header: PImageSectionHeader;\r\n  I: Integer;\r\n  P: PAnsiChar;\r\n  UTF8Name: TUTF8String;\r\nbegin\r\n  Result := nil;\r\n  if NtHeaders <> nil then\r\n  begin\r\n    if not TryStringToUTF8(SectionName, UTF8Name) then\r\n      UTF8Name := TUTF8String(SectionName);\r\n    P := PAnsiChar(UTF8Name);\r\n    Header := PeMapImgSections32(NtHeaders);\r\n    for I := 1 to NtHeaders^.FileHeader.NumberOfSections do\r\n      if StrLComp(PAnsiChar(@Header^.Name), P, IMAGE_SIZEOF_SHORT_NAME) = 0 then\r\n      begin\r\n        Result := Header;\r\n        Break;\r\n      end\r\n      else\r\n        Inc(Header);\r\n  end;\r\nend;\r\n\r\nfunction PeMapImgFindSection64(NtHeaders: PImageNtHeaders64;\r\n  const SectionName: string): PImageSectionHeader;\r\nvar\r\n  Header: PImageSectionHeader;\r\n  I: Integer;\r\n  P: PAnsiChar;\r\n  UTF8Name: TUTF8String;\r\nbegin\r\n  Result := nil;\r\n  if NtHeaders <> nil then\r\n  begin\r\n    if not TryStringToUTF8(SectionName, UTF8Name) then\r\n      UTF8Name := TUTF8String(SectionName);\r\n    P := PAnsiChar(UTF8Name);\r\n    Header := PeMapImgSections64(NtHeaders);\r\n    for I := 1 to NtHeaders^.FileHeader.NumberOfSections do\r\n      if StrLComp(PAnsiChar(@Header^.Name), P, IMAGE_SIZEOF_SHORT_NAME) = 0 then\r\n      begin\r\n        Result := Header;\r\n        Break;\r\n      end\r\n      else\r\n        Inc(Header);\r\n  end;\r\nend;\r\n\r\nfunction PeMapImgFindSection(const ImageSectionHeaders: TImageSectionHeaderArray;\r\n  const SectionName: string): SizeInt;\r\nvar\r\n  P: PAnsiChar;\r\n  UTF8Name: TUTF8String;\r\nbegin\r\n  if Length(ImageSectionHeaders) > 0 then\r\n  begin\r\n    if not TryStringToUTF8(SectionName, UTF8Name) then\r\n      UTF8Name := TUTF8String(SectionName);\r\n    P := PAnsiChar(UTF8Name);\r\n    for Result := Low(ImageSectionHeaders) to High(ImageSectionHeaders) do\r\n      if StrLComp(PAnsiChar(@ImageSectionHeaders[Result].Name), P, IMAGE_SIZEOF_SHORT_NAME) = 0 then\r\n        Exit;\r\n  end;\r\n  Result := -1;\r\nend;\r\n\r\nfunction PeMapImgFindSectionFromModule(const BaseAddress: Pointer;\r\n  const SectionName: string): PImageSectionHeader;\r\n  function PeMapImgFindSectionFromModule32(const BaseAddress: Pointer;\r\n    const SectionName: string): PImageSectionHeader;\r\n  var\r\n    NtHeaders32: PImageNtHeaders32;\r\n  begin\r\n    Result := nil;\r\n    NtHeaders32 := PeMapImgNtHeaders32(BaseAddress);\r\n    if Assigned(NtHeaders32) then\r\n      Result := PeMapImgFindSection32(NtHeaders32, SectionName);\r\n  end;\r\n  function PeMapImgFindSectionFromModule64(const BaseAddress: Pointer;\r\n    const SectionName: string): PImageSectionHeader;\r\n  var\r\n    NtHeaders64: PImageNtHeaders64;\r\n  begin\r\n    Result := nil;\r\n    NtHeaders64 := PeMapImgNtHeaders64(BaseAddress);\r\n    if Assigned(NtHeaders64) then\r\n      Result := PeMapImgFindSection64(NtHeaders64, SectionName);\r\n  end;\r\nbegin\r\n  case PeMapImgTarget(BaseAddress) of\r\n    taWin32:\r\n      Result := PeMapImgFindSectionFromModule32(BaseAddress, SectionName);\r\n    taWin64:\r\n      Result := PeMapImgFindSectionFromModule64(BaseAddress, SectionName);\r\n    //taUnknown:\r\n  else\r\n    Result := nil;\r\n  end;\r\nend;\r\n\r\nfunction PeMapImgExportedVariables(const Module: HMODULE; const VariablesList: TStrings): Boolean;\r\nvar\r\n  I: Integer;\r\nbegin\r\n  with TJclPeImage.Create(True) do\r\n  try\r\n    AttachLoadedModule(Module);\r\n    Result := StatusOK;\r\n    if Result then\r\n    begin\r\n      VariablesList.BeginUpdate;\r\n      try\r\n        with ExportList do\r\n          for I := 0 to Count - 1 do\r\n            with Items[I] do\r\n              if IsExportedVariable then\r\n                VariablesList.AddObject(Name, MappedAddress);\r\n      finally\r\n        VariablesList.EndUpdate;\r\n      end;\r\n    end;\r\n  finally\r\n    Free;\r\n  end;\r\nend;\r\n\r\nfunction PeMapImgResolvePackageThunk(Address: Pointer): Pointer;\r\n{$IFDEF BORLAND}\r\nconst\r\n  JmpInstructionCode = $25FF;\r\ntype\r\n  PPackageThunk = ^TPackageThunk;\r\n  TPackageThunk = packed record\r\n    JmpInstruction: Word;\r\n    JmpAddress: PPointer;\r\n  end;\r\nbegin\r\n  if not IsCompiledWithPackages then\r\n    Result := Address\r\n  else\r\n  if not IsBadReadPtr(Address, SizeOf(TPackageThunk)) and\r\n    (PPackageThunk(Address)^.JmpInstruction = JmpInstructionCode) then\r\n    Result := PPackageThunk(Address)^.JmpAddress^\r\n  else\r\n    Result := nil;\r\nend;\r\n{$ENDIF BORLAND}\r\n{$IFDEF FPC}\r\nbegin\r\n  Result := Address;\r\nend;\r\n{$ENDIF FPC}\r\n\r\nfunction PeMapFindResource(const Module: HMODULE; const ResourceType: PChar;\r\n  const ResourceName: string): Pointer;\r\nvar\r\n  ResItem: TJclPeResourceItem;\r\nbegin\r\n  Result := nil;\r\n  with TJclPeImage.Create(True) do\r\n  try\r\n    AttachLoadedModule(Module);\r\n    if StatusOK then\r\n    begin\r\n      ResItem := ResourceList.FindResource(ResourceType, PChar(ResourceName));\r\n      if (ResItem <> nil) and ResItem.IsDirectory then\r\n        Result := ResItem.List[0].RawEntryData;\r\n    end;\r\n  finally\r\n    Free;\r\n  end;\r\nend;\r\n\r\n//=== { TJclPeSectionStream } ================================================\r\n\r\nconstructor TJclPeSectionStream.Create(Instance: HMODULE; const ASectionName: string);\r\nbegin\r\n  inherited Create;\r\n  Initialize(Instance, ASectionName);\r\nend;\r\n\r\nprocedure TJclPeSectionStream.Initialize(Instance: HMODULE; const ASectionName: string);\r\nvar\r\n  Header: PImageSectionHeader;\r\n  NtHeaders32: PImageNtHeaders32;\r\n  NtHeaders64: PImageNtHeaders64;\r\n  DataSize: Integer;\r\nbegin\r\n  FInstance := Instance;\r\n  case PeMapImgTarget(Pointer(Instance)) of\r\n    taWin32:\r\n      begin\r\n        NtHeaders32 := PeMapImgNtHeaders32(Pointer(Instance));\r\n        if NtHeaders32 = nil then\r\n          raise EJclPeImageError.CreateRes(@RsPeNotPE);\r\n        Header := PeMapImgFindSection32(NtHeaders32, ASectionName);\r\n      end;\r\n    taWin64:\r\n      begin\r\n        NtHeaders64 := PeMapImgNtHeaders64(Pointer(Instance));\r\n        if NtHeaders64 = nil then\r\n          raise EJclPeImageError.CreateRes(@RsPeNotPE);\r\n        Header := PeMapImgFindSection64(NtHeaders64, ASectionName);\r\n      end;\r\n    //toUnknown:\r\n  else\r\n    raise EJclPeImageError.CreateRes(@RsPeUnknownTarget);\r\n  end;\r\n  if Header = nil then\r\n    raise EJclPeImageError.CreateResFmt(@RsPeSectionNotFound, [ASectionName]);\r\n  // Borland and Microsoft seems to have swapped the meaning of this items.\r\n  DataSize := Min(Header^.SizeOfRawData, Header^.Misc.VirtualSize);\r\n  SetPointer(Pointer(FInstance + Header^.VirtualAddress), DataSize);\r\n  FSectionHeader := Header^;\r\nend;\r\n\r\nfunction TJclPeSectionStream.Write(const Buffer; Count: Integer): Longint;\r\nbegin\r\n  raise EJclPeImageError.CreateRes(@RsPeReadOnlyStream);\r\nend;\r\n\r\n//=== { TJclPeMapImgHookItem } ===============================================\r\n\r\nconstructor TJclPeMapImgHookItem.Create(AList: TObjectList;\r\n  const AFunctionName: string; const AModuleName: string;\r\n  ABaseAddress, ANewAddress, AOriginalAddress: Pointer);\r\nbegin\r\n  inherited Create;\r\n  FList := AList;\r\n  FFunctionName := AFunctionName;\r\n  FModuleName := AModuleName;\r\n  FBaseAddress := ABaseAddress;\r\n  FNewAddress := ANewAddress;\r\n  FOriginalAddress := AOriginalAddress;\r\nend;\r\n\r\ndestructor TJclPeMapImgHookItem.Destroy;\r\nbegin\r\n  if FBaseAddress <> nil then\r\n    InternalUnhook;\r\n  inherited Destroy;\r\nend;\r\n\r\nfunction TJclPeMapImgHookItem.InternalUnhook: Boolean;\r\nvar\r\n  Buf: TMemoryBasicInformation;\r\nbegin\r\n  Buf.AllocationBase := nil;\r\n  if (VirtualQuery(FBaseAddress, Buf, SizeOf(Buf)) = SizeOf(Buf)) and (Buf.State and MEM_FREE = 0) then\r\n    Result := TJclPeMapImgHooks.ReplaceImport(FBaseAddress, ModuleName, NewAddress, OriginalAddress)\r\n  else\r\n    Result := True; // PE image is not available anymore (DLL got unloaded)\r\n  if Result then\r\n    FBaseAddress := nil;\r\nend;\r\n\r\nfunction TJclPeMapImgHookItem.Unhook: Boolean;\r\nbegin\r\n  Result := InternalUnhook;\r\n  if Result then\r\n    FList.Remove(Self);\r\nend;\r\n\r\n//=== { TJclPeMapImgHooks } ==================================================\r\n\r\ntype\r\n  PWin9xDebugThunk32 = ^TWin9xDebugThunk32;\r\n  TWin9xDebugThunk32 = packed record\r\n    PUSH: Byte;    // PUSH instruction opcode ($68)\r\n    Addr: DWORD; // The actual address of the DLL routine\r\n    JMP: Byte;     // JMP instruction opcode ($E9)\r\n    Rel: DWORD;  // Relative displacement (a Kernel32 address)\r\n  end;\r\n\r\nfunction TJclPeMapImgHooks.GetItemFromNewAddress(NewAddress: Pointer): TJclPeMapImgHookItem;\r\nvar\r\n  I: Integer;\r\nbegin\r\n  Result := nil;\r\n  for I := 0 to Count - 1 do\r\n    if Items[I].NewAddress = NewAddress then\r\n    begin\r\n      Result := Items[I];\r\n      Break;\r\n    end;\r\nend;\r\n\r\nfunction TJclPeMapImgHooks.GetItemFromOriginalAddress(OriginalAddress: Pointer): TJclPeMapImgHookItem;\r\nvar\r\n  I: Integer;\r\nbegin\r\n  Result := nil;\r\n  for I := 0 to Count - 1 do\r\n    if Items[I].OriginalAddress = OriginalAddress then\r\n    begin\r\n      Result := Items[I];\r\n      Break;\r\n    end;\r\nend;\r\n\r\nfunction TJclPeMapImgHooks.GetItems(Index: Integer): TJclPeMapImgHookItem;\r\nbegin\r\n  Result := TJclPeMapImgHookItem(Get(Index));\r\nend;\r\n\r\nfunction TJclPeMapImgHooks.HookImport(Base: Pointer; const ModuleName: string;\r\n  const FunctionName: string; NewAddress: Pointer; var OriginalAddress: Pointer): Boolean;\r\nvar\r\n  ModuleHandle: THandle;\r\n  OriginalItem: TJclPeMapImgHookItem;\r\n  UTF8Name: TUTF8String;\r\nbegin\r\n  ModuleHandle := GetModuleHandle(PChar(ModuleName));\r\n  Result := (ModuleHandle <> 0);\r\n  if not Result then\r\n  begin\r\n    SetLastError(ERROR_MOD_NOT_FOUND);\r\n    Exit;\r\n  end;\r\n  if not TryStringToUTF8(FunctionName, UTF8Name) then\r\n    UTF8Name := TUTF8String(FunctionName);\r\n  OriginalAddress := GetProcAddress(ModuleHandle, PAnsiChar(UTF8Name));\r\n  Result := (OriginalAddress <> nil);\r\n  if not Result then\r\n  begin\r\n    SetLastError(ERROR_PROC_NOT_FOUND);\r\n    Exit;\r\n  end;\r\n  OriginalItem := ItemFromOriginalAddress[OriginalAddress];\r\n  Result := ((OriginalItem = nil) or (OriginalItem.ModuleName = ModuleName)) and\r\n    (NewAddress <> nil) and (OriginalAddress <> NewAddress);\r\n  if not Result then\r\n  begin\r\n    SetLastError(ERROR_ALREADY_EXISTS);\r\n    Exit;\r\n  end;\r\n  if Result then\r\n    Result := ReplaceImport(Base, ModuleName, OriginalAddress, NewAddress);\r\n  if Result then\r\n  begin\r\n    Add(TJclPeMapImgHookItem.Create(Self, FunctionName, ModuleName, Base,\r\n      NewAddress, OriginalAddress));\r\n  end\r\n  else\r\n    SetLastError(ERROR_INVALID_PARAMETER);\r\nend;\r\n\r\nclass function TJclPeMapImgHooks.IsWin9xDebugThunk(P: Pointer): Boolean;\r\nbegin\r\n  with PWin9xDebugThunk32(P)^ do\r\n    Result := (PUSH = $68) and (JMP = $E9);\r\nend;\r\n\r\nclass function TJclPeMapImgHooks.ReplaceImport(Base: Pointer; const ModuleName: string;\r\n  FromProc, ToProc: Pointer): Boolean;\r\nvar\r\n  {$IFDEF CPU32}\r\n  FromProcDebugThunk32, ImportThunk32: PWin9xDebugThunk32;\r\n  IsThunked: Boolean;\r\n  {$ENDIF CPU32}\r\n  NtHeader32: PImageNtHeaders32;\r\n  ImportDir: TImageDataDirectory;\r\n  ImportDesc: PImageImportDescriptor;\r\n  CurrName, RefName: PAnsiChar;\r\n  {$IFDEF CPU32}\r\n  ImportEntry32: PImageThunkData32;\r\n  {$ENDIF CPU32}\r\n  {$IFDEF CPU64}\r\n  ImportEntry64: PImageThunkData64;\r\n  {$ENDIF CPU64}\r\n  FoundProc: Boolean;\r\n  WrittenBytes: Cardinal;\r\n  UTF8Name: TUTF8String;\r\nbegin\r\n  Result := False;\r\n  {$IFDEF CPU32}\r\n  FromProcDebugThunk32 := PWin9xDebugThunk32(FromProc);\r\n  IsThunked := (Win32Platform <> VER_PLATFORM_WIN32_NT) and IsWin9xDebugThunk(FromProcDebugThunk32);\r\n  {$ENDIF CPU32}\r\n  NtHeader32 := PeMapImgNtHeaders32(Base);\r\n  if NtHeader32 = nil then\r\n    Exit;\r\n  ImportDir := NtHeader32.OptionalHeader.DataDirectory[IMAGE_DIRECTORY_ENTRY_IMPORT];\r\n  if ImportDir.VirtualAddress = 0 then\r\n    Exit;\r\n  ImportDesc := PImageImportDescriptor(TJclAddr(Base) + ImportDir.VirtualAddress);\r\n  if not TryStringToUTF8(ModuleName, UTF8Name) then\r\n    UTF8Name := TUTF8String(ModuleName);\r\n  RefName := PAnsiChar(UTF8Name);\r\n  while ImportDesc^.Name <> 0 do\r\n  begin\r\n    CurrName := PAnsiChar(Base) + ImportDesc^.Name;\r\n    if StrIComp(CurrName, RefName) = 0 then\r\n    begin\r\n      {$IFDEF CPU32}\r\n      ImportEntry32 := PImageThunkData32(TJclAddr(Base) + ImportDesc^.FirstThunk);\r\n      while ImportEntry32^.Function_ <> 0 do\r\n      begin\r\n        if IsThunked then\r\n        begin\r\n          ImportThunk32 := PWin9xDebugThunk32(ImportEntry32^.Function_);\r\n          FoundProc := IsWin9xDebugThunk(ImportThunk32) and (ImportThunk32^.Addr = FromProcDebugThunk32^.Addr);\r\n        end\r\n        else\r\n          FoundProc := Pointer(ImportEntry32^.Function_) = FromProc;\r\n        if FoundProc then\r\n          Result := WriteProtectedMemory(@ImportEntry32^.Function_, @ToProc, SizeOf(ToProc), WrittenBytes);\r\n        Inc(ImportEntry32);\r\n      end;\r\n      {$ENDIF CPU32}\r\n      {$IFDEF CPU64}\r\n      ImportEntry64 := PImageThunkData64(TJclAddr(Base) + ImportDesc^.FirstThunk);\r\n      while ImportEntry64^.Function_ <> 0 do\r\n      begin\r\n        FoundProc := Pointer(ImportEntry64^.Function_) = FromProc;\r\n        if FoundProc then\r\n          Result := WriteProtectedMemory(@ImportEntry64^.Function_, @ToProc, SizeOf(ToProc), WrittenBytes);\r\n        Inc(ImportEntry64);\r\n      end;\r\n      {$ENDIF CPU64}\r\n    end;\r\n    Inc(ImportDesc);\r\n  end;\r\nend;\r\n\r\nclass function TJclPeMapImgHooks.SystemBase: Pointer;\r\nbegin\r\n  Result := Pointer(SystemTObjectInstance);\r\nend;\r\n\r\nprocedure TJclPeMapImgHooks.UnhookAll;\r\nvar\r\n  I: Integer;\r\nbegin\r\n  I := 0;\r\n  while I < Count do\r\n    if not Items[I].Unhook then\r\n      Inc(I);\r\nend;\r\n\r\nfunction TJclPeMapImgHooks.UnhookByNewAddress(NewAddress: Pointer): Boolean;\r\nvar\r\n  Item: TJclPeMapImgHookItem;\r\nbegin\r\n  Item := ItemFromNewAddress[NewAddress];\r\n  Result := (Item <> nil) and Item.Unhook;\r\nend;\r\n\r\nprocedure TJclPeMapImgHooks.UnhookByBaseAddress(BaseAddress: Pointer);\r\nvar\r\n  I: Integer;\r\nbegin\r\n  for I := Count - 1 downto 0 do\r\n    if Items[I].BaseAddress = BaseAddress then\r\n      Items[I].Unhook;\r\nend;\r\n\r\n// Image access under a debbuger\r\n{$IFDEF USE_64BIT_TYPES}\r\nfunction InternalReadProcMem(ProcessHandle: THandle; Address: DWORD;\r\n  Buffer: Pointer; Size: SIZE_T): Boolean;\r\nvar\r\n  BR: SIZE_T;\r\n{$ELSE}\r\nfunction InternalReadProcMem(ProcessHandle: THandle; Address: DWORD;\r\n  Buffer: Pointer; Size: Integer): Boolean;\r\nvar\r\n  BR: DWORD;\r\n{$ENDIF}\r\nbegin\r\n  BR := 0;\r\n  Result := ReadProcessMemory(ProcessHandle, Pointer(Address), Buffer, Size, BR);\r\nend;\r\n\r\n// TODO: 64 bit version\r\nfunction PeDbgImgNtHeaders32(ProcessHandle: THandle; BaseAddress: TJclAddr32;\r\n  var NtHeaders: TImageNtHeaders32): Boolean;\r\nvar\r\n  DosHeader: TImageDosHeader;\r\nbegin\r\n  Result := False;\r\n  ResetMemory(NtHeaders, SizeOf(NtHeaders));\r\n  ResetMemory(DosHeader, SizeOf(DosHeader));\r\n  if not InternalReadProcMem(ProcessHandle, TJclAddr32(BaseAddress), @DosHeader, SizeOf(DosHeader)) then\r\n    Exit;\r\n  if DosHeader.e_magic <> IMAGE_DOS_SIGNATURE then\r\n    Exit;\r\n  Result := InternalReadProcMem(ProcessHandle, TJclAddr32(BaseAddress) + TJclAddr32(DosHeader._lfanew),\r\n    @NtHeaders, SizeOf(TImageNtHeaders32));\r\nend;\r\n\r\n// TODO: 64 bit version\r\nfunction PeDbgImgLibraryName32(ProcessHandle: THandle; BaseAddress: TJclAddr32;\r\n  var Name: string): Boolean;\r\nvar\r\n  NtHeaders32: TImageNtHeaders32;\r\n  DataDir: TImageDataDirectory;\r\n  ExportDir: TImageExportDirectory;\r\n  UTF8Name: TUTF8String;\r\nbegin\r\n  Name := '';\r\n\r\n  NtHeaders32.Signature := 0;\r\n  Result := PeDbgImgNtHeaders32(ProcessHandle, BaseAddress, NtHeaders32);\r\n  if not Result then\r\n    Exit;\r\n  DataDir := NtHeaders32.OptionalHeader.DataDirectory[IMAGE_DIRECTORY_ENTRY_EXPORT];\r\n  if DataDir.Size = 0 then\r\n    Exit;\r\n  if not InternalReadProcMem(ProcessHandle, TJclAddr(BaseAddress) + DataDir.VirtualAddress,\r\n    @ExportDir, SizeOf(ExportDir)) then\r\n    Exit;\r\n  if ExportDir.Name = 0 then\r\n    Exit;\r\n  SetLength(UTF8Name, MAX_PATH);\r\n  if InternalReadProcMem(ProcessHandle, TJclAddr(BaseAddress) + ExportDir.Name, PAnsiChar(UTF8Name), MAX_PATH) then\r\n  begin\r\n    StrResetLength(UTF8Name);\r\n    if not TryUTF8ToString(UTF8Name, Name) then\r\n      Name := string(UTF8Name);\r\n  end\r\n  else\r\n    Name := '';\r\nend;\r\n\r\n// Borland BPL packages name unmangling\r\n\r\nfunction PeBorUnmangleName(const Name: string; out Unmangled: string;\r\n  out Description: TJclBorUmDescription; out BasePos: Integer): TJclBorUmResult;\r\nvar\r\n  NameP, NameU, NameUFirst: PAnsiChar;\r\n  QualifierFound, LinkProcFound: Boolean;\r\n  UTF8Unmangled, UTF8Name: TUTF8String;\r\n\r\n  procedure MarkQualifier;\r\n  begin\r\n    if not QualifierFound then\r\n    begin\r\n      QualifierFound := True;\r\n      BasePos := NameU - NameUFirst + 2;\r\n    end;\r\n  end;\r\n\r\n  procedure ReadSpecialSymbol;\r\n  var\r\n    SymbolLength: Integer;\r\n  begin\r\n    SymbolLength := 0;\r\n    while CharIsDigit(Char(NameP^)) do\r\n    begin\r\n      SymbolLength := SymbolLength * 10 + Ord(NameP^) - 48;\r\n      Inc(NameP);\r\n    end;\r\n    while (SymbolLength > 0) and (NameP^ <> #0) do\r\n    begin\r\n      if NameP^ = '@' then\r\n      begin\r\n        MarkQualifier;\r\n        NameU^ := '.';\r\n      end\r\n      else\r\n        NameU^ := NameP^;\r\n      Inc(NameP);\r\n      Inc(NameU);\r\n      Dec(SymbolLength);\r\n    end;\r\n  end;\r\n\r\n  procedure ReadRTTI;\r\n  begin\r\n    if StrLComp(NameP, '$xp$', 4) = 0 then\r\n    begin\r\n      Inc(NameP, 4);\r\n      Description.Kind := skRTTI;\r\n      QualifierFound := False;\r\n      ReadSpecialSymbol;\r\n      if QualifierFound then\r\n        Include(Description.Modifiers, smQualified);\r\n    end\r\n    else\r\n      Result := urError;\r\n  end;\r\n\r\n  procedure ReadNameSymbol;\r\n  begin\r\n    if NameP^ = '@' then\r\n    begin\r\n      LinkProcFound := True;\r\n      Inc(NameP);\r\n    end;\r\n    while CharIsValidIdentifierLetter(Char(NameP^)) do\r\n    begin\r\n      NameU^ := NameP^;\r\n      Inc(NameP);\r\n      Inc(NameU);\r\n    end;\r\n  end;\r\n\r\n  procedure ReadName;\r\n  begin\r\n    Description.Kind := skData;\r\n    QualifierFound := False;\r\n    LinkProcFound := False;\r\n    repeat\r\n      ReadNameSymbol;\r\n      if LinkProcFound and not QualifierFound then\r\n        LinkProcFound := False;\r\n      case NameP^ of\r\n        '@':\r\n          case (NameP + 1)^ of\r\n            #0:\r\n              begin\r\n                Description.Kind := skVTable;\r\n                Break;\r\n              end;\r\n            '$':\r\n              begin\r\n                if (NameP + 2)^ = 'b' then\r\n                begin\r\n                  case (NameP + 3)^ of\r\n                    'c':\r\n                      Description.Kind := skConstructor;\r\n                    'd':\r\n                      Description.Kind := skDestructor;\r\n                  end;\r\n                  Inc(NameP, 6);\r\n                end\r\n                else\r\n                  Description.Kind := skFunction;\r\n                Break; // no parameters unmangling yet\r\n              end;\r\n          else\r\n            MarkQualifier;\r\n            NameU^ := '.';\r\n            Inc(NameU);\r\n            Inc(NameP);\r\n          end;\r\n        '$':\r\n          begin\r\n            Description.Kind := skFunction;\r\n            Break; // no parameters unmangling yet\r\n          end;\r\n      else\r\n        Break;\r\n      end;\r\n    until False;\r\n    if QualifierFound then\r\n      Include(Description.Modifiers, smQualified);\r\n    if LinkProcFound then\r\n      Include(Description.Modifiers, smLinkProc);\r\n  end;\r\n\r\nbegin\r\n  if not TryStringToUTF8(Name, UTF8Name) then\r\n    UTF8Name := TUTF8String(Name);\r\n  NameP := PAnsiChar(UTF8Name);\r\n  Result := urError;\r\n  case NameP^ of\r\n    '@':\r\n      Result := urOk;\r\n    '?':\r\n      Result := urMicrosoft;\r\n    '_', 'A'..'Z', 'a'..'z':\r\n      Result := urNotMangled;\r\n  end;\r\n  if Result <> urOk then\r\n    Exit;\r\n  Inc(NameP);\r\n  SetLength(UTF8UnMangled, 1024);\r\n  NameU := PAnsiChar(UTF8UnMangled);\r\n  NameUFirst := NameU;\r\n  Description.Modifiers := [];\r\n  BasePos := 1;\r\n  case NameP^ of\r\n    '$':\r\n      ReadRTTI;\r\n    '_', 'A'..'Z', 'a'..'z':\r\n      ReadName;\r\n  else\r\n    Result := urError;\r\n  end;\r\n  NameU^ := #0;\r\n  SetLength(UTF8Unmangled, StrLen(PAnsiChar(UTF8Unmangled))); // SysUtils prefix due to compiler bug\r\n  if not TryUTF8ToString(UTF8Unmangled, Unmangled) then\r\n    Unmangled := string(UTF8Unmangled);\r\nend;\r\n\r\nfunction PeBorUnmangleName(const Name: string; out Unmangled: string;\r\n  out Description: TJclBorUmDescription): TJclBorUmResult;\r\nvar\r\n  BasePos: Integer;\r\nbegin\r\n  Result := PeBorUnmangleName(Name, Unmangled, Description, BasePos);\r\nend;\r\n\r\nfunction PeBorUnmangleName(const Name: string; out Unmangled: string): TJclBorUmResult;\r\nvar\r\n  Description: TJclBorUmDescription;\r\n  BasePos: Integer;\r\nbegin\r\n  Result := PeBorUnmangleName(Name, Unmangled, Description, BasePos);\r\nend;\r\n\r\nfunction PeBorUnmangleName(const Name: string): string;\r\nvar\r\n  Unmangled: string;\r\n  Description: TJclBorUmDescription;\r\n  BasePos: Integer;\r\nbegin\r\n  if PeBorUnmangleName(Name, Unmangled, Description, BasePos) = urOk then\r\n    Result := Unmangled\r\n  else\r\n    Result := '';\r\nend;\r\n\r\nfunction PeIsNameMangled(const Name: string): TJclPeUmResult;\r\nbegin\r\n  Result := umNotMangled;\r\n  if Length(Name) > 0 then\r\n    case Name[1] of\r\n      '@':\r\n        Result := umBorland;\r\n      '?':\r\n        Result := umMicrosoft;\r\n    end;\r\nend;\r\n\r\ntype\r\n  TUndecorateSymbolNameA = function (DecoratedName: PAnsiChar;\r\n    UnDecoratedName: PAnsiChar; UndecoratedLength: DWORD; Flags: DWORD): DWORD; stdcall;\r\n// 'imagehlp.dll' 'UnDecorateSymbolName'\r\n\r\n  TUndecorateSymbolNameW = function (DecoratedName: PWideChar;\r\n    UnDecoratedName: PWideChar; UndecoratedLength: DWORD; Flags: DWORD): DWORD; stdcall;\r\n// 'imagehlp.dll' 'UnDecorateSymbolNameW'\r\n\r\nvar\r\n  UndecorateSymbolNameA: TUndecorateSymbolNameA = nil;\r\n  UndecorateSymbolNameAFailed: Boolean = False;\r\n  UndecorateSymbolNameW: TUndecorateSymbolNameW = nil;\r\n  UndecorateSymbolNameWFailed: Boolean = False;\r\n\r\nfunction UndecorateSymbolName(const DecoratedName: string; out UnMangled: string; Flags: DWORD): Boolean;\r\nconst\r\n  ModuleName = 'imagehlp.dll';\r\n  BufferSize = 512;\r\nvar\r\n  ModuleHandle: HMODULE;\r\n  WideBuffer: WideString;\r\n  AnsiBuffer: AnsiString;\r\n  Res: DWORD;\r\nbegin\r\n  Result := False;\r\n  if ((not Assigned(UndecorateSymbolNameA)) and (not UndecorateSymbolNameAFailed)) or\r\n     ((not Assigned(UndecorateSymbolNameW)) and (not UndecorateSymbolNameWFailed)) then\r\n  begin\r\n    ModuleHandle := GetModuleHandle(ModuleName);\r\n    if ModuleHandle = 0 then\r\n    begin\r\n      ModuleHandle := SafeLoadLibrary(ModuleName);\r\n      if ModuleHandle = 0 then\r\n        Exit;\r\n    end;\r\n    UndecorateSymbolNameA := GetProcAddress(ModuleHandle, 'UnDecorateSymbolName');\r\n    UndecorateSymbolNameAFailed := not Assigned(UndecorateSymbolNameA);\r\n    UndecorateSymbolNameW := GetProcAddress(ModuleHandle, 'UnDecorateSymbolNameW');\r\n    UndecorateSymbolNameWFailed := not Assigned(UndecorateSymbolNameW);\r\n  end;\r\n  if Assigned(UndecorateSymbolNameW) then\r\n  begin\r\n    SetLength(WideBuffer, BufferSize);\r\n    Res := UnDecorateSymbolNameW(PWideChar(WideString(DecoratedName)), PWideChar(WideBuffer), BufferSize, Flags);\r\n    if Res > 0 then\r\n    begin\r\n      StrResetLength(WideBuffer);\r\n      UnMangled := string(WideBuffer);\r\n      Result := True;\r\n    end;\r\n  end\r\n  else\r\n  if Assigned(UndecorateSymbolNameA) then\r\n  begin\r\n    SetLength(AnsiBuffer, BufferSize);\r\n    Res := UnDecorateSymbolNameA(PAnsiChar(AnsiString(DecoratedName)), PAnsiChar(AnsiBuffer), BufferSize, Flags);\r\n    if Res > 0 then\r\n    begin\r\n      StrResetLength(AnsiBuffer);\r\n      UnMangled := string(AnsiBuffer);\r\n      Result := True;\r\n    end;\r\n  end;\r\nend;\r\n\r\nfunction PeUnmangleName(const Name: string; out Unmangled: string): TJclPeUmResult;\r\nbegin\r\n  Result := umNotMangled;\r\n  case PeBorUnmangleName(Name, Unmangled) of\r\n    urOk:\r\n      Result := umBorland;\r\n    urMicrosoft:\r\n      if UndecorateSymbolName(Name, Unmangled, UNDNAME_NAME_ONLY) then\r\n        Result := umMicrosoft;\r\n  end;\r\n  if Result = umNotMangled then\r\n    Unmangled := Name;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n  RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n  UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n"
  },
  {
    "path": "JclTD32Ex.pas",
    "content": "{**************************************************************************************************}\r\n{                                                                                                  }\r\n{ Project JEDI Code Library (JCL)                                                                  }\r\n{                                                                                                  }\r\n{ The contents of this file are subject to the Mozilla Public License Version 1.1 (the \"License\"); }\r\n{ you may not use this file except in compliance with the License. You may obtain a copy of the    }\r\n{ License at http://www.mozilla.org/MPL/                                                           }\r\n{                                                                                                  }\r\n{ Software distributed under the License is distributed on an \"AS IS\" basis, WITHOUT WARRANTY OF   }\r\n{ ANY KIND, either express or implied. See the License for the specific language governing rights  }\r\n{ and limitations under the License.                                                               }\r\n{                                                                                                  }\r\n{ The Original Code is JclTD32.pas.                                                                }\r\n{                                                                                                  }\r\n{ The Initial Developer of the Original Code is Flier Lu ().  }\r\n{ Portions created by Flier Lu are Copyright (C) Flier Lu.  All Rights Reserved.                   }\r\n{                                                                                                  }\r\n{ Contributors:                                                                                    }\r\n{   Flier Lu (flier)                                                                               }\r\n{   Olivier Sannier (obones)                                                                       }\r\n{   Petr Vones (pvones)                                                                            }\r\n{   Heinz Zastrau (heinzz)                                                                         }\r\n{   Andreas Hausladen (ahuser)                                                                     }\r\n{                                                                                                  }\r\n{**************************************************************************************************}\r\n{                                                                                                  }\r\n{ Borland TD32 symbolic debugging information support routines and classes.                        }\r\n{                                                                                                  }\r\n{**************************************************************************************************}\r\n{                                                                                                  }\r\n{ Last modified: $Date:: 2011-09-03 00:07:50 +0200 (sam. 03 sept. 2011)                          $ }\r\n{ Revision:      $Rev:: 3599                                                                     $ }\r\n{ Author:        $Author:: outchy                                                                $ }\r\n{                                                                                                  }\r\n{**************************************************************************************************}\r\n\r\nunit JclTD32Ex;\r\n\r\ninterface\r\n\r\n{$I jcl.inc}\r\n{$I windowsonly.inc}\r\n\r\nuses\r\n  {$IFDEF UNITVERSIONING}\r\n  JclUnitVersioning,\r\n  {$ENDIF UNITVERSIONING}\r\n  {$IFDEF HAS_UNITSCOPE}\r\n  {$IFDEF MSWINDOWS}\r\n  Winapi.Windows,\r\n  {$ENDIF MSWINDOWS}\r\n  System.Classes, System.SysUtils, System.Contnrs,\r\n  {$ELSE ~HAS_UNITSCOPE}\r\n  {$IFDEF MSWINDOWS}\r\n  Windows,\r\n  {$ENDIF MSWINDOWS}\r\n  Classes, SysUtils, Contnrs,\r\n  {$ENDIF ~HAS_UNITSCOPE}\r\n  JclBase,\r\n  {$IFDEF BORLAND}\r\n  JclPeImage,\r\n  {$ENDIF BORLAND}\r\n  JclFileUtils;\r\n\r\n{ TODO -cDOC : Original code: \"Flier Lu\"  }\r\n\r\n// TD32 constants and structures\r\n{*******************************************************************************\r\n\r\n  [-----------------------------------------------------------------------]\r\n  [         Symbol and Type OMF Format Borland Executable Files           ]\r\n  [-----------------------------------------------------------------------]\r\n\r\n  Introduction\r\n\r\n  This section describes the format used to embed debugging information  into\r\n  the executable file.\r\n\r\n  Debug Information Format\r\n\r\n  The format encompasses a block of  data which goes at  the end of the  .EXE\r\n  file,  i.e.,  after   the   header   plus   load   image,   overlays,   and\r\n  Windows/Presentation Manager  resource  compiler  information.   The  lower\r\n  portion of the file is unaffected by the additional data.\r\n\r\n  The last eight bytes of the file contain a signature and a long file offset\r\n  from the end of the file (lfoBase).  The signature is FBxx, where xx is the\r\n  version number.  The  long  offset  indicates  the  position  in  the  file\r\n  (relative to the end of the file)  of the base address.  For the LX  format\r\n  executables, the base address  is determined by  looking at the  executable\r\n  header.\r\n\r\n  The signatures have the following meanings:\r\n\r\n    FB09        The signature for a Borland 32 bit symbol file.\r\n\r\n  The value\r\n\r\n          lfaBase=length of the file - lfoBase\r\n\r\n  gives the base address of the start of the Symbol and Type OMF  information\r\n  relative to  the beginning  of the  file.  All  other file  offsets in  the\r\n  Symbol and Type OMF are relative to  the lfaBase.  At the base address  the\r\n  signature is repeated, followed by the long displacement to the  subsection\r\n  directory (lfoDir).  All subsections start on a long word boundary and  are\r\n  designed to maintain  natural alignment internally  in each subsection  and\r\n  within the subsection directory.\r\n\r\n  Subsection Directory\r\n\r\n  The subsection directory has the format\r\n\r\n       Directory header\r\n\r\n       Directory entry 0\r\n\r\n       Directory entry 1\r\n\r\n        .\r\n        .\r\n        .\r\n\r\n       Directory entry n\r\n\r\n  There is no requirement for a particular subsection of a particular module to exist.\r\n\r\n  The following is the layout of the FB09 debug information in the image:\r\n\r\n  FB09 Header\r\n\r\n    sstModule [1]\r\n    .\r\n    .\r\n    .\r\n    sstModule [n]\r\n\r\n    sstAlignSym [1]\r\n    sstSrcModule [1]\r\n    .\r\n    .\r\n    .\r\n    sstAlignSym [n]\r\n    sstSrcModule [n]\r\n\r\n    sstGlobalSym\r\n    sstGlobalTypes\r\n    sstNames\r\n\r\n    SubSection Directory\r\n\r\n  FB09 Trailer\r\n\r\n*******************************************************************************}\r\n\r\nconst\r\n  Borland32BitSymbolFileSignatureForDelphi = $39304246; // 'FB09'\r\n  Borland32BitSymbolFileSignatureForBCB    = $41304246; // 'FB0A'\r\n\r\ntype\r\n  { Signature structure }\r\n  PJclTD32FileSignature = ^TJclTD32FileSignature;\r\n  TJclTD32FileSignature = packed record\r\n    Signature: DWORD;\r\n    Offset: DWORD;\r\n  end;\r\n\r\nconst\r\n  { Subsection Types }\r\n  SUBSECTION_TYPE_MODULE         = $120;\r\n  SUBSECTION_TYPE_TYPES          = $121;\r\n  SUBSECTION_TYPE_SYMBOLS        = $124;\r\n  SUBSECTION_TYPE_ALIGN_SYMBOLS  = $125;\r\n  SUBSECTION_TYPE_SOURCE_MODULE  = $127;\r\n  SUBSECTION_TYPE_GLOBAL_SYMBOLS = $129;\r\n  SUBSECTION_TYPE_GLOBAL_TYPES   = $12B;\r\n  SUBSECTION_TYPE_NAMES          = $130;\r\n\r\ntype\r\n  { Subsection directory header structure }\r\n  { The directory header structure is followed by the directory entries\r\n    which specify the subsection type, module index, file offset, and size.\r\n    The subsection directory gives the location (LFO) and size of each subsection,\r\n    as well as its type and module number if applicable. }\r\n  PDirectoryEntry = ^TDirectoryEntry;\r\n  TDirectoryEntry = packed record\r\n    SubsectionType: Word; // Subdirectory type\r\n    ModuleIndex: Word;    // Module index\r\n    Offset: DWORD;        // Offset from the base offset lfoBase\r\n    Size: DWORD;          // Number of bytes in subsection\r\n  end;\r\n\r\n  { The subsection directory is prefixed with a directory header structure\r\n    indicating size and number of subsection directory entries that follow. }\r\n  PDirectoryHeader = ^TDirectoryHeader;\r\n  TDirectoryHeader = packed record\r\n    Size: Word;           // Length of this structure\r\n    DirEntrySize: Word;   // Length of each directory entry\r\n    DirEntryCount: DWORD; // Number of directory entries\r\n    lfoNextDir: DWORD;    // Offset from lfoBase of next directory.\r\n    Flags: DWORD;         // Flags describing directory and subsection tables.\r\n    DirEntries: array [0..0] of TDirectoryEntry;\r\n  end;\r\n\r\n\r\n{*******************************************************************************\r\n\r\n  SUBSECTION_TYPE_MODULE $120\r\n\r\n  This describes the basic information about an object module including  code\r\n  segments, module name,  and the  number of  segments for  the modules  that\r\n  follow.  Directory entries for  sstModules  precede  all  other  subsection\r\n  directory entries.\r\n\r\n*******************************************************************************}\r\n\r\ntype\r\n  PSegmentInfo = ^TSegmentInfo;\r\n  TSegmentInfo = packed record\r\n    Segment: Word; // Segment that this structure describes\r\n    Flags: Word;   // Attributes for the logical segment.\r\n                   // The following attributes are defined:\r\n                   //   $0000  Data segment\r\n                   //   $0001  Code segment\r\n    Offset: DWORD; // Offset in segment where the code starts\r\n    Size: DWORD;   // Count of the number of bytes of code in the segment\r\n  end;\r\n\r\n  PSegmentInfoArray = ^TSegmentInfoArray;\r\n  TSegmentInfoArray = array [0..32767] of TSegmentInfo;\r\n\r\n  PModuleInfo = ^TModuleInfo;\r\n  TModuleInfo = packed record\r\n    OverlayNumber: Word;  // Overlay number\r\n    LibraryIndex: Word;   // Index into sstLibraries subsection\r\n                          // if this module was linked from a library\r\n    SegmentCount: Word;   // Count of the number of code segments\r\n                          // this module contributes to\r\n    DebuggingStyle: Word; // Debugging style  for this  module.\r\n    NameIndex: DWORD;     // Name index of module.\r\n    TimeStamp: DWORD;     // Time stamp from the OBJ file.\r\n    Reserved: array [0..2] of DWORD; // Set to 0.\r\n    Segments: array [0..0] of TSegmentInfo;\r\n                          // Detailed information about each segment\r\n                          // that code is contributed to.\r\n                          // This is an array of cSeg count segment\r\n                          // information descriptor structures.\r\n  end;\r\n\r\n{*******************************************************************************\r\n\r\n  SUBSECTION_TYPE_SOURCE_MODULE $0127\r\n\r\n  This table describes the source line number to addressing mapping\r\n  information for a module. The table permits the description of a module\r\n  containing multiple source files with each source file contributing code to\r\n  one or more code segments. The base addresses of the tables described\r\n  below are all relative to the beginning of the sstSrcModule table.\r\n\r\n\r\n  Module header\r\n\r\n  Information for source file 1\r\n\r\n    Information for segment 1\r\n         .\r\n         .\r\n         .\r\n    Information for segment n\r\n\r\n         .\r\n         .\r\n         .\r\n\r\n  Information for source file n\r\n\r\n    Information for segment 1\r\n         .\r\n         .\r\n         .\r\n    Information for segment n\r\n\r\n*******************************************************************************}\r\ntype\r\n  { The line number to address mapping information is contained in a table with\r\n    the following format: }\r\n  PLineMappingEntry = ^TLineMappingEntry;\r\n  TLineMappingEntry = packed record\r\n    SegmentIndex: Word;  // Segment index for this table\r\n    PairCount: Word;     // Count of the number of source line pairs to follow\r\n    Offsets: array [0..0] of DWORD;\r\n                     // An array of 32-bit offsets for the offset\r\n                     // within the code segment ofthe start of ine contained\r\n                     // in the parallel array linenumber.\r\n    (*\r\n    { This is an array of 16-bit line numbers of the lines in the source file\r\n      that cause code to be emitted to the code segment.\r\n      This array is parallel to the offset array.\r\n      If cPair is not even, then a zero word is emitted to\r\n      maintain natural alignment in the sstSrcModule table. }\r\n    LineNumbers: array [0..PairCount - 1] of Word;\r\n    *)\r\n  end;\r\n\r\n  TOffsetPair = packed record\r\n    StartOffset: DWORD;\r\n    EndOffset: DWORD;\r\n  end;\r\n  POffsetPairArray = ^TOffsetPairArray;\r\n  TOffsetPairArray = array [0..32767] of TOffsetPair;\r\n\r\n  { The file table describes the code segments that receive code from this\r\n    source file. Source file entries have the following format: }\r\n  PSourceFileEntry = ^TSourceFileEntry;\r\n  TSourceFileEntry = packed record\r\n    SegmentCount: Word; // Number of segments that receive code from this source file.\r\n    NameIndex: DWORD;   // Name index of Source file name.\r\n\r\n    BaseSrcLines: array [0..0] of DWORD;\r\n                        // An array of offsets for the line/address mapping\r\n                        // tables for each of the segments that receive code\r\n                        // from this source file.\r\n    (*\r\n    { An array  of two  32-bit offsets  per segment  that\r\n      receives code from this  module.  The first  offset\r\n      is the offset within the segment of the first  byte\r\n      of code from this module.  The second offset is the\r\n      ending address of the  code from this module.   The\r\n      order of these pairs corresponds to the ordering of\r\n      the segments in the  seg  array.   Zeros  in  these\r\n      entries means that the information is not known and\r\n      the file and line tables described below need to be\r\n      examined to determine if an address of interest  is\r\n      contained within the code from this module. }\r\n    SegmentAddress: array [0..SegmentCount - 1] of TOffsetPair;\r\n\r\n    Name: ShortString; // Count of the number of bytes in source file name\r\n    *)\r\n  end;\r\n\r\n  { The module header structure describes the source file and code segment\r\n    organization of the module. Each module header has the following format: }\r\n  PSourceModuleInfo = ^TSourceModuleInfo;\r\n  TSourceModuleInfo = packed record\r\n    FileCount: Word;    // The number of source file scontributing code to segments\r\n    SegmentCount: Word; // The number of code segments receiving code from this module\r\n\r\n    BaseSrcFiles: array [0..0] of DWORD;\r\n    (*\r\n    // This is an array of base offsets from the beginning of the sstSrcModule table\r\n    BaseSrcFiles: array [0..FileCount - 1] of DWORD;\r\n\r\n    { An array  of two  32-bit offsets  per segment  that\r\n      receives code from this  module.  The first  offset\r\n      is the offset within the segment of the first  byte\r\n      of code from this module.  The second offset is the\r\n      ending address of the  code from this module.   The\r\n      order of these pairs corresponds to the ordering of\r\n      the segments in the  seg  array.   Zeros  in  these\r\n      entries means that the information is not known and\r\n      the file and line tables described below need to be\r\n      examined to determine if an address of interest  is\r\n      contained within the code from this module. }\r\n    SegmentAddress: array [0..SegmentCount - 1] of TOffsetPair;\r\n\r\n    { An array of segment indices that receive code  from\r\n      this module.  If the  number  of  segments  is  not\r\n      even, a pad word  is inserted  to maintain  natural\r\n      alignment. }\r\n    SegmentIndexes: array [0..SegmentCount - 1] of Word;\r\n    *)\r\n  end;\r\n\r\n{*******************************************************************************\r\n\r\n  SUBSECTION_TYPE_GLOBAL_TYPES $12b\r\n\r\n  This subsection contains the packed type records for the executable file.\r\n  The first long word of the subsection contains the number of types in the\r\n  table. This count is followed by a count-sized array of long offsets to the\r\n  corresponding type record. As the sstGlobalTypes subsection is written, each\r\n  type record is forced to start on a long word boundary. However, the length\r\n  of the type string is not adjusted by the pad count. The remainder of the\r\n  subsection contains the type records. This table is invalid for NB05\r\n  signatures.\r\n\r\n  Note that for NB07 and NB08 executables, the type string offset is from the\r\n  beginning of the subsection table. For NB09 executables, the type string\r\n  offset is from the first type record of the sstGlobalTypes subsection. Using\r\n  the offset from the first type record simplifies demand loading of the\r\n  sstGlobalTypes table.\r\n\r\n*******************************************************************************}\r\n\r\ntype\r\n  PGlobalTypeInfo = ^TGlobalTypeInfo;\r\n  TGlobalTypeInfo = packed record\r\n    Unused: array[0..2] of Byte;    // Reserved for future use. Must be emitted as zeroes\r\n    Signature: Byte;                // Global types table signature\r\n    Count: DWORD;                   // Count or number of types\r\n    Offsets: array [0..0] of DWORD; // Offset of each type. See note above\r\n  end;\r\n\r\nconst\r\n  { Symbol type defines }\r\n  SYMBOL_TYPE_COMPILE        = $0001; // Compile flags symbol\r\n  SYMBOL_TYPE_REGISTER       = $0002; // Register variable\r\n  SYMBOL_TYPE_CONST          = $0003; // Constant symbol\r\n  SYMBOL_TYPE_UDT            = $0004; // User-defined Type\r\n  SYMBOL_TYPE_SSEARCH        = $0005; // Start search\r\n  SYMBOL_TYPE_END            = $0006; // End block, procedure, with, or thunk\r\n  SYMBOL_TYPE_SKIP           = $0007; // Skip - Reserve symbol space\r\n  SYMBOL_TYPE_CVRESERVE      = $0008; // Reserved for Code View internal use\r\n  SYMBOL_TYPE_OBJNAME        = $0009; // Specify name of object file\r\n\r\n  SYMBOL_TYPE_GPROCREF       = $0020;\r\n  SYMBOL_TYPE_GDATAREF       = $0021;\r\n  SYMBOL_TYPE_EDATA          = $0022;\r\n  SYMBOL_TYPE_EPROC          = $0023;\r\n  SYMBOL_TYPE_USES           = $0024;\r\n  SYMBOL_TYPE_NAMESPACE      = $0025;\r\n  SYMBOL_TYPE_USING          = $0026;\r\n  SYMBOL_TYPE_PCONSTANT      = $0027;\r\n\r\n  SYMBOL_TYPE_BPREL16        = $0100; // BP relative 16:16\r\n  SYMBOL_TYPE_LDATA16        = $0101; // Local data 16:16\r\n  SYMBOL_TYPE_GDATA16        = $0102; // Global data 16:16\r\n  SYMBOL_TYPE_PUB16          = $0103; // Public symbol 16:16\r\n  SYMBOL_TYPE_LPROC16        = $0104; // Local procedure start 16:16\r\n  SYMBOL_TYPE_GPROC16        = $0105; // Global procedure start 16:16\r\n  SYMBOL_TYPE_THUNK16        = $0106; // Thunk start 16:16\r\n  SYMBOL_TYPE_BLOCK16        = $0107; // Block start 16:16\r\n  SYMBOL_TYPE_WITH16         = $0108; // With start 16:16\r\n  SYMBOL_TYPE_LABEL16        = $0109; // Code label 16:16\r\n  SYMBOL_TYPE_CEXMODEL16     = $010A; // Change execution model 16:16\r\n  SYMBOL_TYPE_VFTPATH16      = $010B; // Virtual function table path descriptor 16:16\r\n\r\n  SYMBOL_TYPE_BPREL32        = $0200; // BP relative 16:32\r\n  SYMBOL_TYPE_LDATA32        = $0201; // Local data 16:32\r\n  SYMBOL_TYPE_GDATA32        = $0202; // Global data 16:32\r\n  SYMBOL_TYPE_PUB32          = $0203; // Public symbol 16:32\r\n  SYMBOL_TYPE_LPROC32        = $0204; // Local procedure start 16:32\r\n  SYMBOL_TYPE_GPROC32        = $0205; // Global procedure start 16:32\r\n  SYMBOL_TYPE_THUNK32        = $0206; // Thunk start 16:32\r\n  SYMBOL_TYPE_BLOCK32        = $0207; // Block start 16:32\r\n  SYMBOL_TYPE_WITH32         = $0208; // With start 16:32\r\n  SYMBOL_TYPE_LABEL32        = $0209; // Label 16:32\r\n  SYMBOL_TYPE_CEXMODEL32     = $020A; // Change execution model 16:32\r\n  SYMBOL_TYPE_VFTPATH32      = $020B; // Virtual function table path descriptor 16:32\r\n\r\n  SYMBOL_TYPE_ENTRY32        = $0210;\r\n  SYMBOL_TYPE_OPTVAR32       = $0211;\r\n  SYMBOL_TYPE_PROCRET32      = $0212;\r\n  SYMBOL_TYPE_SAVREGS32      = $0213;\r\n  SYMBOL_TYPE_SLINK32        = $0230;\r\n\r\n{*******************************************************************************\r\n\r\n  Global and Local Procedure Start 16:32\r\n\r\n  SYMBOL_TYPE_LPROC32 $0204\r\n  SYMBOL_TYPE_GPROC32 $0205\r\n\r\n    The symbol records define local (file static) and global procedure\r\n  definition. For C/C++, functions that are declared static to a module are\r\n  emitted as Local Procedure symbols. Functions not specifically declared\r\n  static are emitted as Global Procedures.\r\n    For each SYMBOL_TYPE_GPROC32 emitted, an SYMBOL_TYPE_GPROCREF symbol\r\n  must be fabricated and emitted to the SUBSECTION_TYPE_GLOBAL_SYMBOLS section.\r\n\r\n*******************************************************************************}\r\n\r\ntype\r\n  TSymbolProcInfo = packed record\r\n    pParent: DWORD;\r\n    pEnd: DWORD;\r\n    pNext: DWORD;\r\n    Size: DWORD;        // Length in bytes of this procedure\r\n    DebugStart: DWORD;  // Offset in bytes from the start of the procedure to\r\n                        // the point where the stack frame has been set up.\r\n    DebugEnd: DWORD;    // Offset in bytes from the start of the procedure to\r\n                        // the point where the  procedure is  ready to  return\r\n                        // and has calculated its return value, if any.\r\n                        // Frame and register variables an still be viewed.\r\n    Offset: DWORD;      // Offset portion of  the segmented address of\r\n                        // the start of the procedure in the code segment\r\n    Segment: Word;      // Segment portion of the segmented address of\r\n                        // the start of the procedure in the code segment\r\n    Reserved1: Word;\r\n    TypeIndex: DWORD;   // Type of the procedure type record\r\n    NameIndex: DWORD;   // Name index of procedure\r\n    Reserved2: DWORD;\r\n  end;\r\n\r\n  TSymbolObjNameInfo = packed record\r\n    Signature: DWORD;   // Signature for the CodeView information contained in\r\n                        // this module\r\n    NameIndex: DWORD;   // Name index of the object file\r\n  end;\r\n\r\n  TSymbolDataInfo = packed record\r\n    Offset: DWORD;      // Offset portion of  the segmented address of\r\n                        // the start of the data in the code segment\r\n    Segment: Word;      // Segment portion of the segmented address of\r\n                        // the start of the data in the code segment\r\n    Reserved1: Word;\r\n    TypeIndex: DWORD;   // Type index of the symbol\r\n    NameIndex: DWORD;   // Name index of the symbol\r\n    Reserved2: DWORD;\r\n  end;\r\n\r\n  TSymbolWithInfo = packed record\r\n    pParent: DWORD;\r\n    Size: DWORD;        // Length in bytes of this \"with\"\r\n    Offset: DWORD;      // Offset portion of the segmented address of\r\n                        // the start of the \"with\" in the code segment\r\n    Segment: Word;      // Segment portion of the segmented address of\r\n                        // the start of the \"with\" in the code segment\r\n    Reserved1: Word;\r\n    TypeIndex: DWORD;\r\n    NameIndex: DWORD;   // Name index of the \"with\"\r\n    Reserved2: DWORD;\r\n  end;\r\n\r\n  TSymbolLabelInfo = packed record\r\n    Offset: DWORD;      // Offset portion of  the segmented address of\r\n                        // the start of the label in the code segment\r\n    Segment: Word;      // Segment portion of the segmented address of\r\n                        // the start of the label in the code segment\r\n    NearFar: Byte;      // Address mode of the label:\r\n                        //   0       near\r\n                        //   4       far\r\n    Reserved: Byte;\r\n    NameIndex: DWORD;   // Name index of the label\r\n  end;\r\n\r\n  TSymbolConstantInfo = packed record\r\n    TypeIndex: DWORD;\r\n    Flags: Word;\r\n    NameIndex: DWORD;\r\n    Reserved: DWORD;\r\n    Value: array[0..0] of Byte;\r\n  end;\r\n\r\n  TSymbolUdtInfo = packed record\r\n    TypeIndex: DWORD;   // Type index of the type\r\n    Properties: Word;   // isTag:1 True if this is a tag (not a typedef)\r\n                        // isNest:1 True if the type is a nested type (its name\r\n                        // will be 'class_name::type_name' in that case)\r\n    NameIndex: DWORD;   // Name index of the type\r\n    Reserved: DWORD;\r\n  end;\r\n\r\n  TSymbolVftPathInfo = packed record\r\n    Offset: DWORD;      // Offset portion of start of the virtual function table\r\n    Segment: Word;      // Segment portion of the virtual function table\r\n    Reserved: Word;\r\n    RootIndex: DWORD;   // The type index of the class at the root of the path\r\n    PathIndex: DWORD;   // Type index of the record describing the base class\r\n                        // path from the root to the leaf class for the virtual\r\n                        // function table\r\n  end;\r\n\r\n  TSymbolBPRelInfo = packed record\r\n    Offset: Integer;\r\n    TypeIndex: DWORD;\r\n    NameIndex: DWORD;\r\n    Reserved: DWORD;\r\n  end;\r\n\r\n  TSymbolStartInfo = packed record\r\n    Offset: DWORD;\r\n    Segment: Word;\r\n    CodeCount: Word;\r\n    DataCount: Word;\r\n    FirstData: DWORD;\r\n    Reserved: Word;\r\n  end;\r\n\r\n  TSymbolLinkInfo = packed record\r\n    Offset: DWORD;\r\n  end;\r\n\r\n  TSymbolUsesInfo = packed record\r\n    Names: array[0..0] of DWORD;\r\n  end;\r\n\r\n  TRegisterInfo = packed record\r\n    TypeIndex: DWORD;\r\n    Registers: Word;\r\n    NameIndex: DWORD;\r\n    Reserved: DWORD;\r\n  end;\r\n\r\n  PRegisterRange = ^TRegisterRange;\r\n  TRegisterRange = packed record\r\n    Start: DWORD;\r\n    Len: DWORD;\r\n    Registers: Word;\r\n  end;\r\n\r\n  TOptVarInfo = packed record\r\n    Count: Word;\r\n    Ranges: array[0..0] of TRegisterRange;\r\n  end;\r\n\r\ntype\r\n  { Symbol Information Records }\r\n  PSymbolInfo = ^TSymbolInfo;\r\n  TSymbolInfo = packed record\r\n    Size: Word;\r\n    SymbolType: Word;\r\n    case Word of\r\n      SYMBOL_TYPE_LPROC32, SYMBOL_TYPE_GPROC32:\r\n        (Proc: TSymbolProcInfo);\r\n      SYMBOL_TYPE_OBJNAME:\r\n        (ObjName: TSymbolObjNameInfo);\r\n      SYMBOL_TYPE_LDATA32, SYMBOL_TYPE_GDATA32, SYMBOL_TYPE_PUB32:\r\n        (Data: TSymbolDataInfo);\r\n      SYMBOL_TYPE_WITH32:\r\n        (With32: TSymbolWithInfo);\r\n      SYMBOL_TYPE_LABEL32:\r\n        (Label32: TSymbolLabelInfo);\r\n      SYMBOL_TYPE_CONST, SYMBOL_TYPE_PCONSTANT:\r\n        (Constant: TSymbolConstantInfo);\r\n      SYMBOL_TYPE_UDT:\r\n        (Udt: TSymbolUdtInfo);\r\n      SYMBOL_TYPE_VFTPATH32:\r\n        (VftPath: TSymbolVftPathInfo);\r\n      SYMBOL_TYPE_REGISTER:\r\n        (Registers: TRegisterInfo);\r\n      SYMBOL_TYPE_SSEARCH:\r\n        (Start: TSymbolStartInfo);\r\n      SYMBOL_TYPE_USES:\r\n        (Use: TSymbolUsesInfo);\r\n      SYMBOL_TYPE_BPREL32:\r\n        (BPRel: TSymbolBPRelInfo);\r\n      SYMBOL_TYPE_SLINK32:\r\n        (Link: TSymbolLinkInfo);\r\n      SYMBOL_TYPE_OPTVAR32:\r\n        (OptVar: TOptVarInfo);\r\n  end;\r\n\r\n  PSymbolInfos = ^TSymbolInfos;\r\n  TSymbolInfos = packed record\r\n    Signature: DWORD;\r\n    Symbols: array [0..0] of TSymbolInfo;\r\n  end;\r\n\r\n{$IFDEF SUPPORTS_EXTSYM}\r\n\r\n{$EXTERNALSYM Borland32BitSymbolFileSignatureForDelphi}\r\n{$EXTERNALSYM Borland32BitSymbolFileSignatureForBCB}\r\n\r\n{$EXTERNALSYM SUBSECTION_TYPE_MODULE}\r\n{$EXTERNALSYM SUBSECTION_TYPE_TYPES}\r\n{$EXTERNALSYM SUBSECTION_TYPE_SYMBOLS}\r\n{$EXTERNALSYM SUBSECTION_TYPE_ALIGN_SYMBOLS}\r\n{$EXTERNALSYM SUBSECTION_TYPE_SOURCE_MODULE}\r\n{$EXTERNALSYM SUBSECTION_TYPE_GLOBAL_SYMBOLS}\r\n{$EXTERNALSYM SUBSECTION_TYPE_GLOBAL_TYPES}\r\n{$EXTERNALSYM SUBSECTION_TYPE_NAMES}\r\n\r\n{$EXTERNALSYM SYMBOL_TYPE_COMPILE}\r\n{$EXTERNALSYM SYMBOL_TYPE_REGISTER}\r\n{$EXTERNALSYM SYMBOL_TYPE_CONST}\r\n{$EXTERNALSYM SYMBOL_TYPE_UDT}\r\n{$EXTERNALSYM SYMBOL_TYPE_SSEARCH}\r\n{$EXTERNALSYM SYMBOL_TYPE_END}\r\n{$EXTERNALSYM SYMBOL_TYPE_SKIP}\r\n{$EXTERNALSYM SYMBOL_TYPE_CVRESERVE}\r\n{$EXTERNALSYM SYMBOL_TYPE_OBJNAME}\r\n\r\n{$EXTERNALSYM SYMBOL_TYPE_BPREL16}\r\n{$EXTERNALSYM SYMBOL_TYPE_LDATA16}\r\n{$EXTERNALSYM SYMBOL_TYPE_GDATA16}\r\n{$EXTERNALSYM SYMBOL_TYPE_PUB16}\r\n{$EXTERNALSYM SYMBOL_TYPE_LPROC16}\r\n{$EXTERNALSYM SYMBOL_TYPE_GPROC16}\r\n{$EXTERNALSYM SYMBOL_TYPE_THUNK16}\r\n{$EXTERNALSYM SYMBOL_TYPE_BLOCK16}\r\n{$EXTERNALSYM SYMBOL_TYPE_WITH16}\r\n{$EXTERNALSYM SYMBOL_TYPE_LABEL16}\r\n{$EXTERNALSYM SYMBOL_TYPE_CEXMODEL16}\r\n{$EXTERNALSYM SYMBOL_TYPE_VFTPATH16}\r\n\r\n{$EXTERNALSYM SYMBOL_TYPE_BPREL32}\r\n{$EXTERNALSYM SYMBOL_TYPE_LDATA32}\r\n{$EXTERNALSYM SYMBOL_TYPE_GDATA32}\r\n{$EXTERNALSYM SYMBOL_TYPE_PUB32}\r\n{$EXTERNALSYM SYMBOL_TYPE_LPROC32}\r\n{$EXTERNALSYM SYMBOL_TYPE_GPROC32}\r\n{$EXTERNALSYM SYMBOL_TYPE_THUNK32}\r\n{$EXTERNALSYM SYMBOL_TYPE_BLOCK32}\r\n{$EXTERNALSYM SYMBOL_TYPE_WITH32}\r\n{$EXTERNALSYM SYMBOL_TYPE_LABEL32}\r\n{$EXTERNALSYM SYMBOL_TYPE_CEXMODEL32}\r\n{$EXTERNALSYM SYMBOL_TYPE_VFTPATH32}\r\n\r\n{$ENDIF SUPPORTS_EXTSYM}\r\n\r\n// TD32 information related classes\r\ntype\r\n  TJclTD32SourceModuleInfo = class;\r\n  TJclTD32SymbolInfo = class;\r\n  TJclTD32ProcSymbolInfo = class;\r\n\r\n  TJclTD32ModuleInfo = class(TObject)\r\n  private\r\n    FNameIndex: DWORD;\r\n    FSegments: PSegmentInfoArray;\r\n    FSegmentCount: Integer;\r\n    FSourceModules: TList;\r\n    FSymbols: TList;\r\n    FProcSymbols: TList;\r\n    FUsedModuleNameIndices: TList;\r\n    function GetSegment(const Idx: Integer): TSegmentInfo;\r\n    function GetSourceModule(const Idx: Integer): TJclTD32SourceModuleInfo;\r\n    function GetSourceModuleCount: Integer;\r\n    function GetSymbol(const Idx: Integer): TJclTD32SymbolInfo;\r\n    function GetSymbolCount: Integer;\r\n    function GetProcSymbol(const Idx: Integer): TJclTD32ProcSymbolInfo;\r\n    function GetProcSymbolCount: Integer;\r\n    function GetUsedModuleNameIndex(const Idx: Integer): Integer;\r\n    function GetUsedModuleNameIndexCount: Integer;\r\n  protected\r\n    constructor Create(pModInfo: PModuleInfo);\r\n  public\r\n    destructor Destroy; override;\r\n    function FindProc(Offset: DWORD): TJclTD32ProcSymbolInfo;\r\n    property NameIndex: DWORD read FNameIndex;\r\n    property SegmentCount: Integer read FSegmentCount; //GetSegmentCount;\r\n    property Segment[const Idx: Integer]: TSegmentInfo read GetSegment; default;\r\n    property SourceModules[const Idx: Integer]: TJclTD32SourceModuleInfo read GetSourceModule;\r\n    property SourceModuleCount: Integer read GetSourceModuleCount;\r\n    property Symbols[const Idx: Integer]: TJclTD32SymbolInfo read GetSymbol;\r\n    property SymbolCount: Integer read GetSymbolCount;\r\n    property ProcSymbols[const Idx: Integer]: TJclTD32ProcSymbolInfo read GetProcSymbol;\r\n    property ProcSymbolCount: Integer read GetProcSymbolCount;\r\n    property UsedModuleNameIndices[const Idx: Integer]: Integer read GetUsedModuleNameIndex;\r\n    property UsedModuleNameIndexCount: Integer read GetUsedModuleNameIndexCount;\r\n  end;\r\n\r\n  TJclTD32LineInfo = class(TObject)\r\n  private\r\n    FLineNo: DWORD;\r\n    FOffset: DWORD;\r\n    FSegment: Word;\r\n  public\r\n    constructor Create(const ALineNo, AOffset: DWORD; const ASegment: Word);\r\n\r\n    property LineNo: DWORD read FLineNo;\r\n    property Offset: DWORD read FOffset;\r\n    property Segment: Word read FSegment;\r\n  end;\r\n\r\n  TJclTD32SourceModuleInfo = class(TObject)\r\n  private\r\n    FLines: TObjectList;\r\n    FSegments: POffsetPairArray;\r\n    FSegmentCount: Integer;\r\n    FNameIndex: DWORD;\r\n    function GetLine(const Idx: Integer): TJclTD32LineInfo;\r\n    function GetLineCount: Integer;\r\n    function GetSegment(const Idx: Integer): TOffsetPair;\r\n  protected\r\n    constructor Create(pSrcFile: PSourceFileEntry; const Base: DWORD);\r\n  public\r\n    destructor Destroy; override;\r\n    function FindLine(const AAddr: DWORD; var ALine: TJclTD32LineInfo): LongBool;\r\n    property NameIndex: DWORD read FNameIndex;\r\n    property LineCount: Integer read GetLineCount;\r\n    property Line[const Idx: Integer]: TJclTD32LineInfo read GetLine; default;\r\n    property SegmentCount: Integer read FSegmentCount; //GetSegmentCount;\r\n    property Segment[const Idx: Integer]: TOffsetPair read GetSegment;\r\n  end;\r\n\r\n  TJclTD32SymbolInfo = class(TObject)\r\n  private\r\n    FID: DWORD;\r\n    FParentID: DWORD;\r\n    FParent: TJclTD32SymbolInfo;\r\n    FSymbolType: Word;\r\n  public\r\n    constructor Create(pSymInfo: PSymbolInfo; const aID: DWORD); virtual;\r\n    property ID: DWORD read FID;\r\n    property ParentID: DWORD read FParentID;\r\n    property Parent: TJclTD32SymbolInfo read FParent;\r\n    property SymbolType: Word read FSymbolType;\r\n  end;\r\n\r\n  TJclTD32NamedSymbol = class(TJclTD32SymbolInfo)\r\n  private\r\n    FNameIndex: DWORD;\r\n    FTypeIndex: DWORD;\r\n  public\r\n    property NameIndex: DWORD read FNameIndex;\r\n    property TypeIndex: DWORD read FTypeIndex;\r\n  end;\r\n\r\n  TJclTD32Scope = class(TJclTD32NamedSymbol)\r\n  private\r\n    FSegment: Word;\r\n    FOffset: DWORD;\r\n    FSize: DWORD;\r\n  public\r\n    property Segment: Word read FSegment;\r\n    property Offset: DWORD read FOffset;\r\n    property Size: DWORD read FSize;\r\n  end;\r\n\r\n  TJclTD32ProcSymbolInfo = class(TJclTD32Scope)\r\n  private\r\n    FDebugStart: DWORD;\r\n    FDebugEnd: DWORD;\r\n    FSymbols: TList;\r\n    function GetSymbol(const Idx: Integer): TJclTD32SymbolInfo;\r\n    function GetSymbolCount: Integer;\r\n  public\r\n    constructor Create(pSymInfo: PSymbolInfo; const aID: DWORD); override;\r\n    destructor Destroy; override;\r\n    property DebugStart: DWORD read FDebugStart;\r\n    property DebugEnd: DWORD read FDebugEnd;\r\n    property Symbols[const Idx: Integer]: TJclTD32SymbolInfo read GetSymbol;\r\n    property SymbolCount: Integer read GetSymbolCount;\r\n  end;\r\n\r\n  TJclTD32LocalProcSymbolInfo = class(TJclTD32ProcSymbolInfo);\r\n  TJclTD32GlobalProcSymbolInfo = class(TJclTD32ProcSymbolInfo);\r\n\r\n  TJclTD32WithSymbolInfo = class(TJclTD32Scope)\r\n  public\r\n    constructor Create(pSymInfo: PSymbolInfo; const aID: DWORD); override;\r\n  end;\r\n\r\n  TJclTD32BPRel32SymbolInfo = class(TJclTD32NamedSymbol)\r\n  private\r\n    FOffset: Integer;\r\n  public\r\n    constructor Create(pSymInfo: PSymbolInfo; const aID: DWORD); override;\r\n    property Offset: Integer read FOffset;\r\n  end;\r\n\r\n  TJclTD32RegisterSymbolInfo = class(TJclTD32NamedSymbol)\r\n  private\r\n    FRegisters: Word;\r\n    FRanges: array of PRegisterRange;\r\n    function GetRange(const Index: Integer): PRegisterRange;\r\n    function GetRangeCount: Integer;\r\n  protected\r\n    procedure AnalizeRanges(pSymInfo: PSymbolInfo);\r\n  public\r\n    constructor Create(pSymInfo: PSymbolInfo; const aID: DWORD); override;\r\n    property Registers: Word read FRegisters;\r\n    property Range[const Index: Integer]: PRegisterRange read GetRange;\r\n    property RangeCount: Integer read GetRangeCount;\r\n  end;\r\n\r\n  { not used by Delphi }\r\n  TJclTD32ObjNameSymbolInfo = class(TJclTD32SymbolInfo)\r\n  private\r\n    FSignature: DWORD;\r\n    FNameIndex: DWORD;\r\n  public\r\n    constructor Create(pSymInfo: PSymbolInfo; const aID: DWORD); override;\r\n    property NameIndex: DWORD read FNameIndex;\r\n    property Signature: DWORD read FSignature;\r\n  end;\r\n\r\n  TJclTD32DataSymbolInfo = class(TJclTD32NamedSymbol)\r\n  private\r\n    FSegment: Word;\r\n    FOffset: DWORD;\r\n  public\r\n    constructor Create(pSymInfo: PSymbolInfo; const aID: DWORD); override;\r\n    property Segment: Word read FSegment;\r\n    property Offset: DWORD read FOffset;\r\n  end;\r\n\r\n  TJclTD32LDataSymbolInfo = class(TJclTD32DataSymbolInfo);\r\n  TJclTD32GDataSymbolInfo = class(TJclTD32DataSymbolInfo);\r\n\r\n  TJclTD32UdtSymbolInfo = class(TJclTD32NamedSymbol)\r\n  private\r\n    FProperties: Word;\r\n  public\r\n    constructor Create(pSymInfo: PSymbolInfo; const aID: DWORD); override;\r\n    property Properties: Word read FProperties;\r\n  end;\r\n\r\n  TJclTD32StartSymbolInfo = class(TJclTD32SymbolInfo)\r\n  private\r\n    FSegment: Word;\r\n    FOffset: DWORD;\r\n    FCodeCount: Word;\r\n    FDataCount: Word;\r\n    FFirstData: DWORD;\r\n  public\r\n    constructor Create(pSymInfo: PSymbolInfo; const aID: DWORD); override;\r\n    property Segment: Word read FSegment;\r\n    property Offset: DWORD read FOffset;\r\n    property CodeCount: Word read FCodeCount;\r\n    property DataCount: Word read FDataCount;\r\n    property FirstData: DWORD read FFirstData;\r\n  end;\r\n\r\n  TJclTD32EndSymbolInfo = class(TJclTD32SymbolInfo);\r\n\r\n  TJclTD32LinkSymbolInfo = class(TJclTD32SymbolInfo)\r\n  private\r\n    FOffset: DWORD;\r\n  public\r\n    constructor Create(pSymInfo: PSymbolInfo; const aID: DWORD); override;\r\n    property Offset: DWORD read FOffset;\r\n  end;\r\n\r\n  TJclTD32ConstantSymbolInfo = class(TJclTD32NamedSymbol)\r\n    FFlags: Word;\r\n    FSize: Word;\r\n    FValue: Pointer;\r\n  public\r\n    constructor Create(pSymInfo: PSymbolInfo; const aID: DWORD); override;\r\n    destructor Destroy; override;\r\n    property Flags: Word read FFlags;\r\n    property Size: Word read FSize;\r\n    property Value: Pointer read FValue;\r\n  end;\r\n\r\nconst\r\n  { Leaf indices for type records that can be referenced from symbols }\r\n  LF_MODIFIER   = $1;\r\n  LF_POINTER    = $2;\r\n  LF_ARRAY      = $3;\r\n  LF_CLASS      = $4;\r\n  LF_STRUCTURE  = $5;\r\n  LF_UNION      = $6;\r\n  LF_ENUM       = $7;\r\n  LF_PROCEDURE  = $8;\r\n  LF_MFUNCTION  = $9;\r\n  LF_VTSHAPE    = $A;\r\n  LF_COBOL0     = $B;\r\n  LF_COBOL1     = $C;\r\n  LF_BARRAY     = $D;\r\n  LF_LABEL      = $E;\r\n  LF_NULL       = $F;\r\n  LF_NOTTRAN    = $10;\r\n  LF_DIMARRAY   = $11;\r\n  LF_VFTPATH    = $12;\r\n  LF_PRECOMP    = $13;\r\n  LF_ENDPRECOMP = $14;\r\n  LF_OEM        = $15;\r\n\r\n  { Delphi leafs }\r\n  LF_SET        = $30;\r\n  LF_SUBRANGE   = $31;\r\n  LF_PARRAY     = $32;\r\n  LF_PSTRING    = $33;\r\n  LF_CLOSURE    = $34;\r\n  LF_PROPERTY   = $35;\r\n  LF_LSTRING    = $36;\r\n  LF_VARIANT    = $37;\r\n  LF_CLASSREF   = $38;\r\n  LF_WSTRING    = $39;\r\n\r\n  { Leaf indices for type records that can be referenced from other type records }\r\n  LF_SKIP       = $200;\r\n  LF_ARGLIST    = $201;\r\n  LF_DEFARG     = $202;\r\n  LF_LIST       = $203;\r\n  LF_FIELDLIST  = $204;\r\n  LF_DERIVED    = $205;\r\n  LF_BITFIELD   = $206;\r\n  LF_METHODLIST = $207;\r\n  LF_DIMCONU    = $208;\r\n  LF_DIMCONLU   = $209;\r\n  LF_DIMVARU    = $20A;\r\n  LF_DIMVARLU   = $20B;\r\n  LF_REFSYM     = $20C;\r\n\r\n  { Leaf indices for fields of complex lists }\r\n  LF_BCLASS     = $400;\r\n  LF_VBCLASS    = $401;\r\n  LF_IVBCLASS   = $402;\r\n  LF_ENUMERATE  = $403;\r\n  LF_FRIENDFCN  = $404;\r\n  LF_INDEX      = $405;\r\n  LF_MEMBER     = $406;\r\n  LF_STMEMBER   = $407;\r\n  LF_METHOD     = $408;\r\n  LF_NESTTYPE   = $409;\r\n  LF_VFUNCTAB   = $40A;\r\n  LF_FRIENDCLS  = $40B;\r\n  LF_ONEMETHOD  = $40C;\r\n  LF_VFUNCOFF   = $40D;\r\n\r\n  { Leaf indices for numeric fields of symbols and type records }\r\n  LF_CHAR       = $8000;\r\n  LF_SHORT      = $8001;\r\n  LF_USHORT     = $8002;\r\n  LF_LONG       = $8003;\r\n  LF_ULONG      = $8004;\r\n  LF_REAL32     = $8005;\r\n  LF_REAL64     = $8006;\r\n  LF_REAL80     = $8007;\r\n  LF_REAL128    = $8008;\r\n  LF_QUADWORD   = $8009;\r\n  LF_UQUADWORD  = $800A;\r\n  LF_REAL48     = $800B;\r\n  LF_COMPLEX32  = $800C;\r\n  LF_COMPLEX64  = $800D;\r\n  LF_COMPLEX80  = $800E;\r\n  LF_COMPLEX128 = $800F;\r\n  LF_VARSTRING  = $8010;\r\n\r\n  LF_RAWBITS    = $9000;\r\n\r\n  LF_PAD0       = $F0;\r\n  LF_PAD1       = $F1;\r\n  LF_PAD2       = $F2;\r\n  LF_PAD3       = $F3;\r\n  LF_PAD4       = $F4;\r\n  LF_PAD5       = $F5;\r\n  LF_PAD6       = $F6;\r\n  LF_PAD7       = $F7;\r\n  LF_PAD8       = $F8;\r\n  LF_PAD9       = $F9;\r\n  LF_PAD10      = $FA;\r\n  LF_PAD11      = $FB;\r\n  LF_PAD12      = $FC;\r\n  LF_PAD13      = $FD;\r\n  LF_PAD14      = $FE;\r\n  LF_PAD15      = $FF;\r\n\r\ntype\r\n  TCharTypeInfo = packed record\r\n    Value: ShortInt;\r\n  end;\r\n\r\n  TShortTypeInfo = packed record\r\n    Value: SmallInt;\r\n  end;\r\n\r\n  TUShortTypeInfo = packed record\r\n    Value: Word;\r\n  end;\r\n\r\n  TLongTypeInfo = packed record\r\n    Value: Integer;\r\n  end;\r\n\r\n  TULongTypeInfo = packed record\r\n    Value: LongWord;\r\n  end;\r\n\r\n  TReal32TypeInfo = packed record\r\n    Value: Single;\r\n  end;\r\n\r\n  TReal64TypeInfo = packed record\r\n    Value: Real;\r\n  end;\r\n\r\n  TReal80TypeInfo = packed record\r\n    Value: Extended;\r\n  end;\r\n\r\n  TQuadWordTypeInfo = packed record\r\n    Value: Int64;\r\n  end;\r\n\r\n  TUQuadWordTypeInfo = packed record\r\n    Value: UInt64;\r\n  end;\r\n\r\n  TReal48TypeInfo = packed record\r\n    Value: Real48;\r\n  end;\r\n\r\n  TCurrencyTypeInfo = packed record\r\n    Value: Currency;\r\n  end;\r\n\r\n  TComplex64TypeInfo = packed record\r\n    Re: Real;\r\n    Im: Real;\r\n  end;\r\n\r\n  TWideCharTypeInfo = packed record\r\n    Value: WideChar;\r\n  end;\r\n\r\n  TNumericLeaf = packed record\r\n    Leaf: Word;\r\n    case Word of\r\n      LF_CHAR      : (LeafChar      : TCharTypeInfo);\r\n      LF_SHORT     : (LeafShort     : TShortTypeInfo);\r\n      LF_USHORT    : (LeafUShort    : TUShortTypeInfo);\r\n      LF_LONG      : (LeafLong      : TLongTypeInfo);\r\n      LF_ULONG     : (LeafULong     : TULongTypeInfo);\r\n      LF_QUADWORD  : (LeafQuadWord  : TQuadWordTypeInfo);\r\n      LF_UQUADWORD : (LeafUQuadWord : TUQuadWordTypeInfo);\r\n      LF_REAL32    : (LeafReal32    : TReal32TypeInfo);\r\n      LF_REAL48    : (LeafReal48    : TReal48TypeInfo);\r\n      LF_REAL64    : (LeafReal64    : TReal64TypeInfo);\r\n      LF_REAL80    : (LeafReal80    : TReal80TypeInfo);\r\n      LF_COMPLEX64 : (LeafComplex64 : TComplex64TypeInfo);\r\n  end;\r\n\r\n  TClassTypeInfo = packed record\r\n    Fields: Word;\r\n    FieldIdx: DWORD;\r\n    Flags: Word;\r\n    cClass: DWORD;\r\n    dList: DWORD;\r\n    VTable: DWORD;\r\n    Name: DWORD;\r\n    Length: Word;\r\n  end;\r\n\r\n  TStructureTypeInfo = TClassTypeInfo;\r\n\r\n  TPStringTypeInfo = packed record\r\n    BaseType: DWORD;\r\n    IndexType: DWORD;\r\n    Name: DWORD;\r\n    Flags: DWORD;\r\n  end;\r\n\r\n  TLStringTypeInfo = packed record\r\n    NameIndex: DWORD;\r\n  end;\r\n\r\n  TWStringTypeInfo = TLStringTypeInfo;\r\n\r\n  TSubrangeData = packed record\r\n    case Byte of\r\n      0: (L0, H0: Word; S0: DWORD);\r\n      1: (L1: TNumericLeaf; H1: Word; S1: DWORD);\r\n      2: (L2: Word; H2: TNumericLeaf; S2: DWORD);\r\n      3: (L3, H3: TNumericLeaf; S3: DWORD);\r\n  end;\r\n\r\n  TSubrangeTypeInfo = packed record\r\n    BaseType: DWORD;\r\n    Name: DWORD;\r\n    Data: TSubrangeData;\r\n  end;\r\n\r\n  TPointerTypeInfo = packed record\r\n    Flags: Word;\r\n    ElementType: DWORD;\r\n  end;\r\n\r\n  TEnumTypeInfo = packed record\r\n    Count: Word;\r\n    ElementType: DWORD;\r\n    FieldsType: DWORD;\r\n    ClassType: DWORD;\r\n    Name: DWORD;\r\n  end;\r\n\r\n  TProcTypeInfo = packed record\r\n    ResultType: DWORD;\r\n    CallType: Word;\r\n    ParamCount: Word;\r\n    ArgList: DWORD;\r\n  end;\r\n\r\n  TMFuncTypeInfo = packed record\r\n    TypeIndex: DWORD;\r\n    ClassType: DWORD;\r\n    SelfType: DWORD;\r\n    Falgs: Word;\r\n    ParamCount: Word;\r\n    ArgList: DWORD;\r\n    Adjust: DWORD;\r\n  end;\r\n\r\n  TSetTypeInfo = packed record\r\n    BaseType: DWORD;\r\n    Name: DWORD;\r\n    LowByte: Word;\r\n    Length: Word;\r\n  end;\r\n\r\n  TArrayTypeInfo = packed record\r\n    BaseType: DWORD;\r\n    IndexType: DWORD;\r\n    Name: DWORD;\r\n    case Byte of\r\n      0: (S0: Word; E0: TNumericLeaf);\r\n      1: (S1, E1: TNumericLeaf);\r\n  end;\r\n\r\n  TPropertyFlag = (pfDefault, pfReadIsName, pfWriteIsName);\r\n  TPropertyFlags = set of TPropertyFlag;\r\n\r\n  TPropertySlot = packed record\r\n    case Byte of\r\n      0: (FieldOffset: DWORD); // When pfReadIsName or pfWriteIsName is _not_ in TPropertyFlags:\r\n      1: (NameIndex: DWORD);   // When pfReadIsName or pfWriteIsName is in TPropertyFlags:\r\n  end;\r\n\r\n  TPropertyTypeInfo = packed record\r\n    BaseType: DWORD;\r\n    Flags: Word;\r\n    IndexType: DWORD;\r\n    PropIndex: DWORD;\r\n    Read: TPropertySlot;\r\n    Write: TPropertySlot;\r\n  end;\r\n\r\n  TVariantTypeInfo = packed record\r\n    NameIndex: DWORD;\r\n  end;\r\n\r\n  TBClassTypeInfo = packed record\r\n    TypeIndex: DWORD;\r\n    Flags: Word;\r\n    Offset: Word;\r\n  end;\r\n\r\n  TEnumerateTypeInfo = packed record\r\n    Flags: Word;\r\n    NameIndex: DWORD;\r\n    Reserved: DWORD;\r\n    Value: Word;\r\n  end;\r\n\r\n  TMemberTypeInfo = packed record\r\n    BaseType: DWORD;\r\n    Flags: Word;\r\n    NameIndex: DWORD;\r\n    Reserved: DWORD;\r\n    Offset: Word;\r\n  end;\r\n\r\n  PFieldListElement = ^TFieldListElement;\r\n  TFieldListElement = packed record\r\n    Leaf: Word;\r\n    case Word of\r\n      LF_BCLASS: (LeafBClass: TBClassTypeInfo);\r\n      LF_ENUMERATE: (LeafEnumerate: TEnumerateTypeInfo);\r\n      LF_MEMBER: (LeafMember: TMemberTypeInfo);\r\n  end;\r\n\r\n  TClassRefTypeInfo = packed record\r\n    ElementType : DWORD;\r\n    VTable: DWORD;\r\n  end;\r\n\r\n  TJclEnumerateSymbolInfo = class(TJclTD32NamedSymbol)\r\n  private\r\n    FFlags: Word;\r\n    FValue: Word;\r\n  public\r\n    constructor Create(pSymInfo: PFieldListElement); reintroduce; virtual;\r\n    property Flags: Word read FFlags;\r\n    property Value: Word read FValue;\r\n  end;\r\n\r\n  TJclTD32MemberSymbolInfo = class(TJclTD32NamedSymbol)\r\n  private\r\n    FFlags: Word;\r\n    FOffset: Word;\r\n  public\r\n    constructor Create(pSymInfo: PFieldListElement); reintroduce; virtual;\r\n    property Flags: Word read FFlags;\r\n    property Offset: Word read FOffset;\r\n  end;\r\n\r\n  TArgListTypeInfo = packed record\r\n    Count: Word;\r\n    Args: array[0..0] Of DWORD;\r\n  end;\r\n\r\n  TFieldListTypeInfo = packed record\r\n    Length: Word;\r\n    Leaf: Word;\r\n    Data: array[0..0] of Byte;\r\n  end;\r\n\r\n  PSymbolTypeInfo = ^TSymbolTypeInfo;\r\n  TSymbolTypeInfo = packed record\r\n    Length: Word;\r\n    Leaf: Word;\r\n    case Word of\r\n      LF_POINTER: (LeafPointer: TPointerTypeInfo);\r\n      LF_CLASS: (LeafClass: TClassTypeInfo);\r\n      LF_STRUCTURE: (LeafStructure: TStructureTypeInfo);\r\n      LF_ENUM: (LeafEnum: TEnumTypeInfo);\r\n      LF_PROCEDURE: (LeafProc: TProcTypeInfo);\r\n      LF_MFUNCTION: (LeafMFunc: TMFuncTypeInfo);\r\n      LF_SET: (LeafSet: TSetTypeInfo);\r\n      LF_SUBRANGE: (LeafSubrange: TSubrangeTypeInfo);\r\n      LF_PARRAY: (LeafArray: TArrayTypeInfo);\r\n      LF_PSTRING: (LeafPString: TPStringTypeInfo);\r\n      LF_PROPERTY: (LeafProperty: TPropertyTypeInfo);\r\n      LF_LSTRING: (LeafLString: TLStringTypeInfo);\r\n      LF_VARIANT: (LeafVariant: TVariantTypeInfo);\r\n      LF_CLASSREF: (LeafClassRef: TClassRefTypeInfo);\r\n      LF_WSTRING: (LeafWString: TWStringTypeInfo);\r\n      LF_ARGLIST: (LeafArgList: TArgListTypeInfo);\r\n      LF_FIELDLIST: (LeafFieldList: TFieldListTypeInfo);\r\n      LF_CHAR: (LeafChar: TCharTypeInfo);\r\n      LF_SHORT: (LeafShort: TShortTypeInfo);\r\n      LF_USHORT: (LeafUShort: TUShortTypeInfo);\r\n      LF_LONG: (LeafLong: TLongTypeInfo);\r\n      LF_ULONG: (LeafULong: TULongTypeInfo);\r\n      LF_QUADWORD: (LeafQuadWord: TQuadWordTypeInfo);\r\n      LF_UQUADWORD: (LeafUQuadWord: TUQuadWordTypeInfo);\r\n      LF_REAL32: (LeafReal32: TReal32TypeInfo);\r\n      LF_REAL48: (LeafReal48: TReal48TypeInfo);\r\n      LF_REAL64: (LeafReal64: TReal64TypeInfo);\r\n      LF_REAL80: (LeafReal80: TReal80TypeInfo);\r\n      LF_COMPLEX64: (LeafComplex64: TComplex64TypeInfo);\r\n  end;\r\n\r\n  TJclSymbolTypeKind = (stkBoolean, stkWordBool, stkLongBool, stkShortInt,\r\n    stkSmallInt, stkInteger, stkInt64, stkByte, stkWord, stkCardinal, stkUInt64,\r\n    stkSingle, stkReal48, stkReal, stkExtended, stkCurrency, stkComplex, stkPString,\r\n    stkLString, stkWString, stkChar, stkPointer, stkSubRange, stkArray, stkEnum,\r\n    stkStructure, stkClass, stkSet, stkVariant, stkProperty, stkFieldList, stkClosure,\r\n    stkClassRef, stkWideChar, stkProcedure, stkArgList, stkMFunction, stkVoid);\r\n\r\n  TJclSymbolTypeInfo = class\r\n  private\r\n    FMembers: TObjectList;\r\n    FArgs: TList;\r\n\r\n    function GetArgs: TList;\r\n    function GetMembers: TObjectList;\r\n  public\r\n    NameIndex: Integer;\r\n    DataSize: UInt64;\r\n    Kind: TJclSymbolTypeKind;\r\n\r\n    ElementType: Integer;\r\n    Elements: Integer;\r\n\r\n    IndexType: Integer;\r\n\r\n    MinValue: Integer;\r\n    MaxValue: Integer;\r\n\r\n    Flags: Word;\r\n\r\n    ClassType: Integer;\r\n    SelfType: Integer;\r\n\r\n    UnitInfo: Pointer;\r\n    UnitInfoIndex: Integer;\r\n\r\n    constructor Create;\r\n    destructor Destroy; override;\r\n\r\n    property Members: TObjectList read GetMembers;\r\n    property Args: TList read GetArgs;\r\n  end;\r\n\r\n  // TD32 parser\r\n  TJclTD32InfoParser = class(TObject)\r\n  private\r\n    FBase: Pointer;\r\n    FData: TCustomMemoryStream;\r\n    FNames: TList;\r\n    FModules: TObjectList;\r\n    FSourceModules: TObjectList;\r\n    FSymbols: TObjectList;\r\n    FProcSymbols: TList;\r\n    FSymbolTypes: TList;\r\n    FValidData: LongBool;\r\n    FIsVarTypesExist: LongBool;\r\n    function GetName(const Idx: Integer): AnsiString;\r\n    function GetNameCount: Integer;\r\n    function GetSymbol(const Idx: Integer): TJclTD32SymbolInfo;\r\n    function GetSymbolCount: Integer;\r\n    function GetSymbolType(const Idx: Integer): TJclSymbolTypeInfo;\r\n    function GetSymbolTypeCount: Integer;\r\n    function GetProcSymbol(const Idx: Integer): TJclTD32ProcSymbolInfo;\r\n    function GetProcSymbolCount: Integer;\r\n    function GetModule(const Idx: Integer): TJclTD32ModuleInfo;\r\n    function GetModuleCount: Integer;\r\n    function GetSourceModule(const Idx: Integer): TJclTD32SourceModuleInfo;\r\n    function GetSourceModuleCount: Integer;\r\n    function GetIndexOfName(Const Name: AnsiString): Integer;\r\n  protected\r\n    procedure Analyse;\r\n    procedure AnalyseNames(const pSubsection: Pointer; const Size: DWORD); //virtual;\r\n    procedure AnalyseGlobalTypes(const pTypes: Pointer; const Size: DWORD); //virtual;\r\n    procedure AnalyseAlignSymbols(pSymbols: PSymbolInfos; const Size: DWORD; const ModuleIndex: Integer); //virtual;\r\n    procedure AnalyseModules(pModInfo: PModuleInfo; const Size: DWORD); //virtual;\r\n    procedure AnalyseSourceModules(pSrcModInfo: PSourceModuleInfo; const Size: DWORD; const ModuleIndex: Integer); //virtual;\r\n    procedure AnalyseUnknownSubSection(const pSubsection: Pointer; const Size: DWORD); //virtual;\r\n    procedure AnalyzeUses(pSymbols: PSymbolInfo; Module: TJclTD32ModuleInfo); //virtual;\r\n    function LfaToVa(const Lfa: DWORD): Pointer;\r\n    function CreateTypeInfo(const Kind: TJclSymbolTypeKind; const Size: DWORD = 0; const NameIndex: DWORD = 0): TJclSymbolTypeInfo; //virtual;\r\n    function CreatePrimitiveTypeInfo(const Idx: DWORD): TJclSymbolTypeInfo; //virtual;\r\n    function CreateArgListTypeInfo(pInfo: PSymbolTypeInfo): TJclSymbolTypeInfo; //virtual;\r\n    function CreateFieldListTypeInfo(pInfo: PSymbolTypeInfo): TJclSymbolTypeInfo; //virtual;\r\n    procedure FixVariantTypes; //virtual;\r\n  public\r\n    constructor Create(const ATD32Data: TCustomMemoryStream); // Data mustn't be freed before the class is destroyed\r\n    destructor Destroy; override;\r\n    function FindModule(const AAddr: DWORD; var AMod: TJclTD32ModuleInfo): LongBool; overload;\r\n    function FindModule(const Section: Word; const Offset: DWORD): TJclTD32ModuleInfo; overload;\r\n    function ModuleByNameIndex(const NameIndex: Cardinal): TJclTD32ModuleInfo; //virtual;\r\n    function FindSourceModule(const AAddr: DWORD; var ASrcMod: TJclTD32SourceModuleInfo): LongBool;\r\n    function FindProc(const AAddr: DWORD; var AProc: TJclTD32ProcSymbolInfo): LongBool;\r\n    class function IsTD32Sign(const Sign: TJclTD32FileSignature): LongBool;\r\n    class function IsTD32DebugInfoValid(const DebugData: Pointer; const DebugDataSize: LongWord): LongBool;\r\n    property Data: TCustomMemoryStream read FData;\r\n    property Names[const Idx: Integer]: AnsiString read GetName;\r\n    property NameCount: Integer read GetNameCount;\r\n    property IndexOfName[Const Name: AnsiString]: Integer read GetIndexOfName;\r\n    property Symbols[const Idx: Integer]: TJclTD32SymbolInfo read GetSymbol;\r\n    property SymbolCount: Integer read GetSymbolCount;\r\n    property SymbolTypes[const Idx: Integer]: TJclSymbolTypeInfo read GetSymbolType;\r\n    property SymbolTypeCount: Integer read GetSymbolTypeCount;\r\n    property ProcSymbols[const Idx: Integer]: TJclTD32ProcSymbolInfo read GetProcSymbol;\r\n    property ProcSymbolCount: Integer read GetProcSymbolCount;\r\n    property Modules[const Idx: Integer]: TJclTD32ModuleInfo read GetModule;\r\n    property ModuleCount: Integer read GetModuleCount;\r\n    property SourceModules[const Idx: Integer]: TJclTD32SourceModuleInfo read GetSourceModule;\r\n    property SourceModuleCount: Integer read GetSourceModuleCount;\r\n    property ValidData: LongBool read FValidData;\r\n  end;\r\n\r\n  // TD32 scanner with source location methods\r\n  TJclTD32InfoScanner = class(TJclTD32InfoParser)\r\n  public\r\n    function LineNumberFromAddr(const AAddr: DWORD; var Offset: Integer): Integer; overload;\r\n    function LineNumberFromAddr(const AAddr: DWORD): Integer; overload;\r\n    function ProcNameFromAddr(const AAddr: DWORD): AnsiString; overload;\r\n    function ProcNameFromAddr(const AAddr: DWORD; var Offset: Integer): AnsiString; overload;\r\n    function ModuleNameFromAddr(const AAddr: DWORD): AnsiString;\r\n    function SourceNameFromAddr(const AAddr: DWORD): AnsiString;\r\n  end;\r\n\r\n  TTD32DebugDataType = (ddtNone, ddtInImage, ddtTDS);\r\n\r\n  // PE Image with TD32 information and source location support\r\n  TJclPeBorTD32Image = class(TJclPeBorImage)\r\n  private\r\n    FIsTD32DebugPresent: LongBool;\r\n    FTD32DebugDataType: TTD32DebugDataType;\r\n    FTD32DebugData: TCustomMemoryStream;\r\n    FTD32Scanner: TJclTD32InfoScanner;\r\n  protected\r\n    procedure AfterOpen; override;\r\n    procedure Clear; override;\r\n    procedure ClearDebugData;\r\n    procedure CheckDebugData;\r\n    function IsDebugInfoInImage(var DataStream: TCustomMemoryStream): LongBool;\r\n    function IsDebugInfoInTds(var DataStream: TCustomMemoryStream): LongBool;\r\n  public\r\n    property IsTD32DebugPresent: LongBool read FIsTD32DebugPresent;\r\n    property TD32DebugDataType: TTD32DebugDataType read FTD32DebugDataType;\r\n    property TD32DebugData: TCustomMemoryStream read FTD32DebugData;\r\n    property TD32Scanner: TJclTD32InfoScanner read FTD32Scanner;\r\n  end;\r\n\r\n{$IFDEF UNITVERSIONING}\r\nconst\r\n  UnitVersioning: TUnitVersionInfo = (\r\n    RCSfile: '$URL: https://jcl.svn.sourceforge.net/svnroot/jcl/tags/JCL-2.4-Build4571/jcl/source/windows/JclTD32.pas $';\r\n    Revision: '$Revision: 3599 $';\r\n    Date: '$Date: 2011-09-03 00:07:50 +0200 (sam. 03 sept. 2011) $';\r\n    LogPath: 'JCL\\source\\windows';\r\n    Extra: '';\r\n    Data: nil\r\n    );\r\n{$ENDIF UNITVERSIONING}\r\n\r\nimplementation\r\n\r\nuses\r\n  JclResources,\r\n  JclSysUtils, System.AnsiStrings;\r\n\r\nconst\r\n  TurboDebuggerSymbolExt = '.tds';\r\n\r\n//=== { TJclModuleInfo } =====================================================\r\n\r\nconstructor TJclTD32ModuleInfo.Create(pModInfo: PModuleInfo);\r\nbegin\r\n  Assert(Assigned(pModInfo));\r\n  inherited Create;\r\n  FSourceModules := TList.Create;\r\n  FUsedModuleNameIndices := TList.Create;\r\n  FSymbols := TList.Create;\r\n  FProcSymbols := TList.Create;\r\n  FNameIndex := pModInfo.NameIndex;\r\n  FSegments := @pModInfo.Segments[0];\r\n  FSegmentCount := pModInfo.SegmentCount;\r\nend;\r\n\r\ndestructor TJclTD32ModuleInfo.Destroy;\r\nbegin\r\n  FreeAndNil(FProcSymbols);\r\n  FreeAndNil(FSymbols);\r\n  FreeAndNil(FSourceModules);\r\n  FreeAndNil(FUsedModuleNameIndices);\r\n  inherited;\r\nend;\r\n\r\nfunction TJclTD32ModuleInfo.GetSegment(const Idx: Integer): TSegmentInfo;\r\nbegin\r\n  Assert((0 <= Idx) and (Idx < FSegmentCount));\r\n  Result := FSegments[Idx];\r\nend;\r\n\r\nfunction TJclTD32ModuleInfo.GetSourceModule(const Idx: Integer): TJclTD32SourceModuleInfo;\r\nbegin\r\n  Result := TJclTD32SourceModuleInfo(FSourceModules.Items[Idx]);\r\nend;\r\n\r\nfunction TJclTD32ModuleInfo.GetSourceModuleCount: Integer;\r\nbegin\r\n  Result := FSourceModules.Count;\r\nend;\r\n\r\nfunction TJclTD32ModuleInfo.GetSymbol(const Idx: Integer): TJclTD32SymbolInfo;\r\nbegin\r\n  Result := TJclTD32SymbolInfo(FSymbols.Items[Idx]);\r\nend;\r\n\r\nfunction TJclTD32ModuleInfo.GetSymbolCount: Integer;\r\nbegin\r\n  Result := FSymbols.Count;\r\nend;\r\n\r\nfunction TJclTD32ModuleInfo.GetProcSymbol(const Idx: Integer): TJclTD32ProcSymbolInfo;\r\nbegin\r\n  Result := TJclTD32ProcSymbolInfo(FProcSymbols.Items[Idx]);\r\nend;\r\n\r\nfunction TJclTD32ModuleInfo.GetProcSymbolCount: Integer;\r\nbegin\r\n  Result := FProcSymbols.Count;\r\nend;\r\n\r\nfunction TJclTD32ModuleInfo.FindProc(Offset: DWORD): TJclTD32ProcSymbolInfo;\r\nvar\r\n  P: Integer;\r\nbegin\r\n  for P := 0 to ProcSymbolCount - 1 do\r\n  begin\r\n    Result := ProcSymbols[P];\r\n    if (Result.Offset <= Offset) and (Result.Offset + Result.Size >= Offset) then\r\n      Exit;\r\n  end;\r\n\r\n  Result := nil;\r\nend;\r\n\r\nfunction TJclTD32ModuleInfo.GetUsedModuleNameIndex(const Idx: Integer): Integer;\r\nbegin\r\n  Result := Integer(FUsedModuleNameIndices.Items[Idx]);\r\nend;\r\n\r\nfunction TJclTD32ModuleInfo.GetUsedModuleNameIndexCount: Integer;\r\nbegin\r\n  Result := FUsedModuleNameIndices.Count;\r\nend;\r\n\r\n//=== { TJclLineInfo } =======================================================\r\n\r\nconstructor TJclTD32LineInfo.Create(const ALineNo, AOffset: DWORD; const ASegment: Word);\r\nbegin\r\n  inherited Create;\r\n  FLineNo := ALineNo;\r\n  FOffset := AOffset;\r\n  FSegment := ASegment;\r\nend;\r\n\r\n//=== { TJclSourceModuleInfo } ===============================================\r\n\r\nconstructor TJclTD32SourceModuleInfo.Create(pSrcFile: PSourceFileEntry; const Base: DWORD);\r\ntype\r\n  PArrayOfOffsets = ^TArrayOfOffsets;\r\n  TArrayOfOffsets = array[0..0] of Word;\r\nvar\r\n  I, J: Integer;\r\n  pLineEntry: PLineMappingEntry;\r\n  LineInfo: TJclTD32LineInfo;\r\n  Offsets: PArrayOfOffsets;\r\nbegin\r\n  Assert(Assigned(pSrcFile));\r\n  inherited Create;\r\n\r\n  FNameIndex := pSrcFile.NameIndex;\r\n  FLines := TObjectList.Create;\r\n\r\n  for I := 0 to pSrcFile.SegmentCount - 1 do\r\n  begin\r\n    pLineEntry := PLineMappingEntry(Base + pSrcFile.BaseSrcLines[I]);\r\n\r\n    Offsets := @pLineEntry.Offsets[pLineEntry.PairCount];\r\n\r\n    FLines.Capacity := FLines.Capacity + pLineEntry.PairCount;\r\n    for J := 0 to pLineEntry.PairCount - 1 do\r\n    begin\r\n      LineInfo := TJclTD32LineInfo.Create(Offsets^[J], pLineEntry.Offsets[J], pLineEntry.SegmentIndex);\r\n      FLines.Add(LineInfo);\r\n    end;\r\n  end;\r\n\r\n  FSegments := @pSrcFile.BaseSrcLines[pSrcFile.SegmentCount];\r\n  FSegmentCount := pSrcFile.SegmentCount;\r\nend;\r\n\r\ndestructor TJclTD32SourceModuleInfo.Destroy;\r\nbegin\r\n  FreeAndNil(FLines);\r\n  inherited Destroy;\r\nend;\r\n\r\nfunction TJclTD32SourceModuleInfo.GetLine(const Idx: Integer): TJclTD32LineInfo;\r\nbegin\r\n  Result := TJclTD32LineInfo(FLines.Items[Idx]);\r\nend;\r\n\r\nfunction TJclTD32SourceModuleInfo.GetLineCount: Integer;\r\nbegin\r\n  Result := FLines.Count;\r\nend;\r\n\r\nfunction TJclTD32SourceModuleInfo.GetSegment(const Idx: Integer): TOffsetPair;\r\nbegin\r\n  Assert((0 <= Idx) and (Idx < FSegmentCount));\r\n  Result := FSegments[Idx];\r\nend;\r\n\r\nfunction TJclTD32SourceModuleInfo.FindLine(const AAddr: DWORD; var ALine: TJclTD32LineInfo): LongBool;\r\nvar\r\n  I: Integer;\r\nbegin\r\n  for I := 0 to LineCount - 1 do\r\n    with Line[I] do\r\n    begin\r\n      if AAddr = Offset then\r\n      begin\r\n        Result := True;\r\n        ALine := Line[I];\r\n        Exit;\r\n      end\r\n      else\r\n      if (I > 1) and (Line[I - 1].Offset < AAddr) and (AAddr < Offset) then\r\n      begin\r\n        Result := True;\r\n        ALine := Line[I-1];\r\n        Exit;\r\n      end;\r\n    end;\r\n  Result := False;\r\n  ALine := nil;\r\nend;\r\n\r\n//=== { TJclSymbolInfo } =====================================================\r\n\r\nconstructor TJclTD32SymbolInfo.Create(pSymInfo: PSymbolInfo; const aID: DWORD);\r\nbegin\r\n  Assert(Assigned(pSymInfo));\r\n  inherited Create;\r\n  FID := aID;\r\n  FSymbolType := pSymInfo.SymbolType;\r\nend;\r\n\r\n//=== { TJclProcSymbolInfo } =================================================\r\n\r\nconstructor TJclTD32ProcSymbolInfo.Create(pSymInfo: PSymbolInfo; const aID: DWORD);\r\nbegin\r\n  inherited;\r\n  FSymbols := TList.Create;\r\n  with pSymInfo^ do\r\n  begin\r\n    FParentID := Proc.pParent;\r\n    FSegment := Proc.Segment;\r\n    FOffset := Proc.Offset;\r\n    FSize := Proc.Size;\r\n    FNameIndex := Proc.NameIndex;\r\n\r\n    FDebugStart := Proc.DebugStart;\r\n    FDebugEnd := Proc.DebugEnd;\r\n    FTypeIndex := Proc.TypeIndex;\r\n  end;\r\nend;\r\n\r\ndestructor TJclTD32ProcSymbolInfo.Destroy;\r\nbegin\r\n  FreeAndNil(FSymbols);\r\n  inherited;\r\nend;\r\n\r\nfunction TJclTD32ProcSymbolInfo.GetSymbol(const Idx: Integer): TJclTD32SymbolInfo;\r\nbegin\r\n  Result := TJclTD32SymbolInfo(FSymbols.Items[Idx]);\r\nend;\r\n\r\nfunction TJclTD32ProcSymbolInfo.GetSymbolCount: Integer;\r\nbegin\r\n  Result := FSymbols.Count;\r\nend;\r\n\r\n//=== { TJclDataSymbolInfo } =================================================\r\n\r\nconstructor TJclTD32DataSymbolInfo.Create(pSymInfo: PSymbolInfo; const aID: DWORD);\r\nbegin\r\n  inherited;\r\n  with pSymInfo^ do\r\n  begin\r\n    FTypeIndex := Data.TypeIndex;\r\n    FNameIndex := Data.NameIndex;\r\n    FSegment := Data.Segment;\r\n    FOffset := Data.Offset;\r\n  end;\r\nend;\r\n\r\n//=== { TJclWithSymbolInfo } =================================================\r\n\r\nconstructor TJclTD32WithSymbolInfo.Create(pSymInfo: PSymbolInfo; const aID: DWORD);\r\nbegin\r\n  inherited;\r\n  with pSymInfo^ do\r\n  begin\r\n    FParentID := With32.pParent;\r\n    FSegment := With32.Segment;\r\n    FOffset := With32.Offset;\r\n    FSize := With32.Size;\r\n    FNameIndex := With32.NameIndex;\r\n\r\n    FTypeIndex := With32.TypeIndex;\r\n  end;\r\nend;\r\n\r\n//=== { TJclUdtSymbolInfo } ==================================================\r\n\r\nconstructor TJclTD32UdtSymbolInfo.Create(pSymInfo: PSymbolInfo; const aID: DWORD);\r\nbegin\r\n  inherited;\r\n  with pSymInfo^ do\r\n  begin\r\n    FProperties := Udt.Properties;\r\n    FNameIndex := Udt.NameIndex;\r\n    FTypeIndex := Udt.TypeIndex;\r\n  end;\r\nend;\r\n\r\nconstructor TJclTD32StartSymbolInfo.Create(pSymInfo: PSymbolInfo; const aID: DWORD);\r\nbegin\r\n  inherited;\r\n  with pSymInfo^ do\r\n  begin\r\n    FSegment := Start.Segment;\r\n    FOffset := Start.Offset;\r\n    FCodeCount := Start.CodeCount;\r\n    FDataCount := Start.DataCount;\r\n    FFirstData := Start.FirstData;\r\n  end;\r\nend;\r\n\r\nconstructor TJclTD32BPRel32SymbolInfo.Create(pSymInfo: PSymbolInfo; const aID: DWORD);\r\nbegin\r\n  inherited;\r\n  with pSymInfo^ do\r\n  begin\r\n    FOffset := BPRel.Offset;\r\n    FNameIndex := BPRel.NameIndex;\r\n    FTypeIndex := BPRel.TypeIndex;\r\n  end;\r\nend;\r\n\r\nconstructor TJclTD32RegisterSymbolInfo.Create(pSymInfo: PSymbolInfo; const aID: DWORD);\r\nbegin\r\n  inherited;\r\n  with pSymInfo^ do\r\n  begin\r\n    FRegisters := Registers.Registers;\r\n    FNameIndex := Registers.NameIndex;\r\n    FTypeIndex := Registers.TypeIndex;\r\n  end;\r\nend;\r\n\r\nprocedure TJclTD32RegisterSymbolInfo.AnalizeRanges(pSymInfo: PSymbolInfo);\r\nvar\r\n  I: Integer;\r\nbegin\r\n  with pSymInfo^ do\r\n  begin\r\n    SetLength(FRanges, OptVar.Count);\r\n    for I := 0 to OptVar.Count - 1 do\r\n      FRanges[I] := @OptVar.Ranges[I];\r\n  end;\r\nend;\r\n\r\nfunction TJclTD32RegisterSymbolInfo.GetRange(const Index: Integer): PRegisterRange;\r\nbegin\r\n  Result := FRanges[Index];\r\nend;\r\n\r\nfunction TJclTD32RegisterSymbolInfo.GetRangeCount: Integer;\r\nbegin\r\n  Result := Length(FRanges);\r\nend;\r\n\r\nconstructor TJclTD32LinkSymbolInfo.Create(pSymInfo: PSymbolInfo; const aID: DWORD);\r\nbegin\r\n  inherited;\r\n  with pSymInfo^ do\r\n    FOffset := Link.Offset;\r\nend;\r\n\r\nconstructor TJclTD32ConstantSymbolInfo.Create(pSymInfo: PSymbolInfo; const aID: DWORD);\r\nbegin\r\n  inherited;\r\n  with pSymInfo^ do\r\n  begin\r\n    FTypeIndex := Constant.TypeIndex;\r\n    FFlags := Constant.Flags;\r\n    FNameIndex := Constant.NameIndex;\r\n    FSize := Size - 16;\r\n    GetMem(FValue, FSize);\r\n    Move(Constant.Value, FValue^, FSize);\r\n  end;\r\nend;\r\n\r\ndestructor TJclTD32ConstantSymbolInfo.Destroy;\r\nbegin\r\n  FreeMem(FValue);\r\n  inherited;\r\nend;\r\n\r\nconstructor TJclEnumerateSymbolInfo.Create(pSymInfo: PFieldListElement);\r\nbegin\r\n  // Adjust PFieldListElement to PSymbolInfo for TJclSymbolInfo.Create\r\n  inherited Create(PSymbolInfo(DWORD(pSymInfo) - 2), 0);\r\n  with pSymInfo^ do\r\n  begin\r\n    FFlags := LeafEnumerate.Flags;\r\n    FNameIndex := LeafEnumerate.NameIndex;\r\n    FValue := LeafEnumerate.Value;\r\n  end;\r\nend;\r\n\r\nconstructor TJclTD32MemberSymbolInfo.Create(pSymInfo: PFieldListElement);\r\nbegin\r\n  // Adjust PFieldListElement to PSymbolInfo for TJclSymbolInfo.Create\r\n  inherited Create(PSymbolInfo(DWORD(pSymInfo) - 2), 0);\r\n  with pSymInfo^ do\r\n  begin\r\n    FFlags := LeafMember.Flags;\r\n    FNameIndex := LeafMember.NameIndex;\r\n    FTypeIndex := LeafMember.BaseType;\r\n    FOffset := LeafMember.Offset;\r\n  end;\r\nend;\r\n\r\n//=== { TJclTD32InfoParser } =================================================\r\n\r\nconstructor TJclTD32InfoParser.Create(const ATD32Data: TCustomMemoryStream);\r\nbegin\r\n  Assert(Assigned(ATD32Data));\r\n  inherited Create;\r\n  FNames := TList.Create;\r\n  FModules := TObjectList.Create;\r\n  FSourceModules := TObjectList.Create;\r\n  FSymbols := TObjectList.Create;\r\n  FSymbolTypes := TObjectList.Create;\r\n  FProcSymbols := TList.Create;\r\n  FNames.Add(nil);\r\n  FData := ATD32Data;\r\n  FBase := FData.Memory;\r\n  FValidData := IsTD32DebugInfoValid(FBase, FData.Size);\r\n  if FValidData then\r\n    Analyse;\r\nend;\r\n\r\ndestructor TJclTD32InfoParser.Destroy;\r\nbegin\r\n  FreeAndNil(FProcSymbols);\r\n  FreeAndNil(FSymbols);\r\n  FreeAndNil(FSymbolTypes);\r\n  FreeAndNil(FSourceModules);\r\n  FreeAndNil(FModules);\r\n  FreeAndNil(FNames);\r\n  inherited Destroy;\r\nend;\r\n\r\nprocedure TJclTD32InfoParser.Analyse;\r\nvar\r\n  I, M: Integer;\r\n  pDirHeader: PDirectoryHeader;\r\n  DirEntry: TDirectoryEntry;\r\n  pSubsection: Pointer;\r\nbegin\r\n  pDirHeader := PDirectoryHeader(LfaToVa(PJclTD32FileSignature(LfaToVa(0)).Offset));\r\n  while True do\r\n  begin\r\n    Assert(pDirHeader.DirEntrySize = SizeOf(TDirectoryEntry));\r\n    M := 0;\r\n    {$RANGECHECKS OFF}\r\n    for I := 0 to pDirHeader.DirEntryCount - 1 do\r\n    begin\r\n      DirEntry := pDirHeader.DirEntries[I];\r\n      pSubsection := LfaToVa(DirEntry.Offset);\r\n      case DirEntry.SubsectionType of\r\n        SUBSECTION_TYPE_MODULE:\r\n          AnalyseModules(pSubsection, DirEntry.Size);\r\n        SUBSECTION_TYPE_ALIGN_SYMBOLS:\r\n        begin\r\n          AnalyseAlignSymbols(pSubsection, DirEntry.Size, M);\r\n          Inc(M);\r\n        end;\r\n        SUBSECTION_TYPE_SOURCE_MODULE:\r\n          AnalyseSourceModules(pSubsection, DirEntry.Size, M);\r\n        SUBSECTION_TYPE_NAMES:\r\n          AnalyseNames(pSubsection, DirEntry.Size);\r\n        SUBSECTION_TYPE_GLOBAL_TYPES:\r\n        begin\r\n          FSymbolTypes.Count := $1000; // Reserve space for primitive types that will be created dinamically\r\n          AnalyseGlobalTypes(pSubsection, DirEntry.Size);\r\n        end\r\n      else\r\n        AnalyseUnknownSubSection(pSubsection, DirEntry.Size);\r\n      end;\r\n    end;\r\n    {$IFDEF RANGECHECKS_ON}\r\n    {$RANGECHECKS ON}\r\n    {$ENDIF RANGECHECKS_ON}\r\n    if pDirHeader.lfoNextDir <> 0 then\r\n      pDirHeader := PDirectoryHeader(LfaToVa(pDirHeader.lfoNextDir))\r\n    else\r\n      Break;\r\n  end;\r\n  // Add predefined Variant type info and update all references to it\r\n  FixVariantTypes;\r\nend;\r\n\r\nprocedure TJclTD32InfoParser.AnalyseNames(const pSubsection: Pointer; const Size: DWORD);\r\nvar\r\n  I, Count, Len: Integer;\r\n  pszName: PAnsiChar;\r\nbegin\r\n  Count := PDWORD(pSubsection)^;\r\n  pszName := PAnsiChar(TJclAddr(pSubsection) + SizeOf(DWORD));\r\n  if Count > 0 then\r\n  begin\r\n    FNames.Capacity := FNames.Capacity + Count;\r\n    for I := 0 to Count - 1 do\r\n    begin\r\n      // Get the length of the name\r\n      Len := Byte(pszName^);\r\n      Inc(pszName);\r\n      // Get the name\r\n      FNames.Add(pszName);\r\n      // first, skip the length of name\r\n      Inc(pszName, Len);\r\n      // the length is only correct modulo 256 because it is stored on a single byte,\r\n      // so we have to iterate until we find the real end of the string\r\n      while PszName^ <> #0 do\r\n        Inc(pszName, 256);\r\n      // then, skip a NULL at the end\r\n      Inc(pszName, 1);\r\n    end;\r\n  end;\r\nend;\r\n\r\nprocedure TJclTD32InfoParser.AnalyseGlobalTypes(const pTypes: Pointer; const Size: DWORD);\r\n\r\n  function GetBoundFromNumeric(var Data: Pointer): Integer;\r\n  var\r\n    Size, Offset: Integer;\r\n  begin\r\n    Result := 0;\r\n\r\n    if PWord(Data)^ >= $8000 then\r\n    begin\r\n      case PWord(Data)^ of\r\n        LF_LONG, LF_ULONG:\r\n          Size := 4;\r\n        LF_QUADWORD, LF_UQUADWORD:\r\n          Size := 8;\r\n      else\r\n        Exit;\r\n      end;\r\n      Offset := 2;\r\n    end\r\n    else\r\n    begin\r\n      Size := 2;\r\n      Offset := 0;\r\n    end;\r\n\r\n    Inc(Cardinal(Data), Offset);\r\n    Move(Data^, Result, Size);\r\n    Inc(Cardinal(Data), Size);\r\n  end;\r\n\r\nvar\r\n  I: Integer;\r\n  Info: PSymbolTypeInfo;\r\n  TypeInfo: TJclSymbolTypeInfo;\r\n\r\n  procedure _LoadSubRangeType;\r\n  var\r\n    Data: Pointer;\r\n  begin\r\n    TypeInfo := CreateTypeInfo(stkSubrange, 0, Info.LeafSubrange.Name);\r\n    TypeInfo.IndexType := Info.LeafSubrange.BaseType;\r\n    Data := @Info.LeafSubrange.Data;\r\n    TypeInfo.MinValue := GetBoundFromNumeric(Data);\r\n    TypeInfo.MaxValue := GetBoundFromNumeric(Data);\r\n    TypeInfo.DataSize := PWord(Data)^;\r\n  end;\r\n\r\n  procedure _LoadArrayType;\r\n  var\r\n    Data: Pointer;\r\n  begin\r\n    TypeInfo := CreateTypeInfo(stkArray, 0, Info.LeafArray.Name);\r\n    TypeInfo.ElementType := Info.LeafArray.BaseType;\r\n    TypeInfo.IndexType := Info.LeafArray.IndexType;\r\n\r\n    // TODO: Size for dynamic array\r\n    Data := @Info.LeafArray.S1;\r\n    TypeInfo.DataSize := GetBoundFromNumeric(Data);\r\n    TypeInfo.MaxValue := GetBoundFromNumeric(Data);\r\n  end;\r\n\r\nbegin\r\n  FSymbolTypes.Capacity := FSymbolTypes.Capacity + Integer(PGlobalTypeInfo(pTypes).Count);\r\n  for I := 0 To PGlobalTypeInfo(pTypes).Count - 1 do\r\n  begin\r\n    TypeInfo := Nil;\r\n    Info := PSymbolTypeInfo(LongWord(pTypes) + PGlobalTypeInfo(pTypes).Offsets[I]);\r\n    case Info.Leaf of\r\n      LF_POINTER:\r\n      begin\r\n        TypeInfo := CreateTypeInfo(stkPointer, SizeOf(Pointer));\r\n        TypeInfo.ElementType := Info.LeafPointer.ElementType;\r\n      end;\r\n      LF_CLASS:\r\n      begin\r\n        TypeInfo := CreateTypeInfo(stkClass, Info.LeafClass.Length, Info.LeafClass.Name);\r\n        TypeInfo.Elements := Info.LeafClass.FieldIdx;\r\n      end;\r\n      LF_STRUCTURE:\r\n      begin\r\n        TypeInfo := CreateTypeInfo(stkStructure, Info.LeafStructure.Length, Info.LeafStructure.Name);\r\n        TypeInfo.Elements := Info.LeafStructure.FieldIdx;\r\n      end;\r\n      LF_ENUM:\r\n      begin\r\n        TypeInfo := CreateTypeInfo(stkEnum, 0, Info.LeafEnum.Name);\r\n        TypeInfo.ElementType := Info.LeafEnum.ElementType;\r\n        TypeInfo.Elements := Info.LeafEnum.FieldsType;\r\n      end;\r\n      LF_PROCEDURE:\r\n      begin\r\n        TypeInfo := CreateTypeInfo(stkProcedure, 0);\r\n        TypeInfo.IndexType := Info.LeafProc.ResultType;\r\n        TypeInfo.Flags := Info.LeafProc.CallType;\r\n        TypeInfo.ElementType := Info.LeafProc.ArgList;\r\n        TypeInfo.Elements := Info.LeafProc.ParamCount;\r\n      end;\r\n      LF_MFUNCTION:\r\n      begin\r\n        TypeInfo := CreateTypeInfo(stkMFunction, 0);\r\n        TypeInfo.IndexType := Info.LeafMFunc.TypeIndex;\r\n        TypeInfo.ClassType := Info.LeafMFunc.ClassType;\r\n        TypeInfo.SelfType := Info.LeafMFunc.SelfType;\r\n        TypeInfo.Flags := Info.LeafMFunc.Falgs;\r\n        TypeInfo.ElementType := Info.LeafMFunc.ArgList;\r\n        TypeInfo.Elements := Info.LeafMFunc.ParamCount;\r\n        TypeInfo.MinValue := Info.LeafMFunc.Adjust;\r\n      end;\r\n      LF_SET:\r\n      begin\r\n        TypeInfo := CreateTypeInfo(stkSet, 0, Info.LeafSet.Name);\r\n        TypeInfo.ElementType := Info.LeafSet.BaseType;\r\n        TypeInfo.MinValue := Info.LeafSet.LowByte;\r\n        TypeInfo.DataSize := 32;\r\n      end;\r\n      LF_SUBRANGE:\r\n        _LoadSubRangeType;\r\n      LF_PARRAY:\r\n        _LoadArrayType;\r\n      LF_PSTRING:\r\n      begin\r\n        TypeInfo := CreateTypeInfo(stkPString, 0, Info.LeafPString.Name);\r\n        TypeInfo.ElementType := Info.LeafPString.BaseType;\r\n        TypeInfo.IndexType := Info.LeafPString.IndexType;\r\n      end;\r\n      LF_CLOSURE:\r\n        TypeInfo := CreateTypeInfo(stkClosure, SizeOf(Pointer));\r\n      LF_PROPERTY:\r\n      begin\r\n        TypeInfo := CreateTypeInfo(stkProperty, 0, Info.LeafProperty.PropIndex);\r\n        TypeInfo.Flags := Info.LeafProperty.Flags;\r\n        TypeInfo.ElementType := Info.LeafProperty.BaseType;\r\n        TypeInfo.IndexType := Info.LeafProperty.IndexType;\r\n        TypeInfo.MinValue := Info.LeafProperty.Read.FieldOffset;\r\n        TypeInfo.MaxValue := Info.LeafProperty.Write.FieldOffset;\r\n      end;\r\n      LF_LSTRING:\r\n      begin\r\n        TypeInfo := CreateTypeInfo(stkLString, SizeOf(Pointer), Info.LeafWString.NameIndex);\r\n        TypeInfo.ElementType := 97; // Predefined Char type\r\n      end;\r\n      LF_VARIANT:\r\n      begin\r\n        TypeInfo := CreateTypeInfo(stkVariant, 16, Info.LeafVariant.NameIndex);\r\n        FIsVarTypesExist := True;\r\n      end;\r\n      LF_CLASSREF:\r\n      begin\r\n        TypeInfo := CreateTypeInfo(stkClassRef, SizeOf(Pointer));\r\n        TypeInfo.ElementType := Info.LeafClassRef.ElementType;\r\n        TypeInfo.Elements := Info.LeafClassRef.VTable;\r\n      end;\r\n      LF_WSTRING:\r\n      begin\r\n        TypeInfo := CreateTypeInfo(stkWString, SizeOf(Pointer), Info.LeafLString.NameIndex);\r\n        TypeInfo.ElementType := 113; // Predefined WideChar type\r\n      end;\r\n      LF_ARGLIST:\r\n        TypeInfo := CreateArgListTypeInfo(Info);\r\n      LF_FIELDLIST:\r\n        TypeInfo := CreateFieldListTypeInfo(Info);\r\n      LF_CHAR:\r\n        TypeInfo := CreateTypeInfo(stkInteger, SizeOf(Info.LeafChar));\r\n      LF_SHORT:\r\n        TypeInfo := CreateTypeInfo(stkInteger, SizeOf(Info.LeafShort));\r\n      LF_USHORT:\r\n        TypeInfo := CreateTypeInfo(stkInteger, SizeOf(Info.LeafUShort));\r\n      LF_LONG:\r\n        TypeInfo := CreateTypeInfo(stkInteger, SizeOf(Info.LeafLong));\r\n      LF_ULONG:\r\n        TypeInfo := CreateTypeInfo(stkInteger, SizeOf(Info.LeafULong));\r\n      LF_QUADWORD:\r\n        TypeInfo := CreateTypeInfo(stkInteger, SizeOf(Info.LeafQuadWord));\r\n      LF_UQUADWORD:\r\n        TypeInfo := CreateTypeInfo(stkInteger, SizeOf(Info.LeafUQuadWord));\r\n      LF_REAL32:\r\n        TypeInfo := CreateTypeInfo(stkReal, SizeOf(Info.LeafReal32));\r\n      LF_REAL48:\r\n        TypeInfo := CreateTypeInfo(stkReal, SizeOf(Info.LeafReal48));\r\n      LF_REAL64:\r\n        TypeInfo := CreateTypeInfo(stkReal, SizeOf(Info.LeafReal64));\r\n      LF_REAL80:\r\n        TypeInfo := CreateTypeInfo(stkReal, SizeOf(Info.LeafReal80));\r\n      LF_COMPLEX64:\r\n        TypeInfo := CreateTypeInfo(stkComplex, SizeOf(Info.LeafComplex64));\r\n\r\n      LF_VTSHAPE, LF_METHODLIST: ;// TODO:\r\n    end;\r\n\r\n    FSymbolTypes.Add(TypeInfo);\r\n  end;\r\nend;\r\n\r\nprocedure TJclTD32InfoParser.AnalyseAlignSymbols(pSymbols: PSymbolInfos; const Size: DWORD; const ModuleIndex: Integer);\r\nvar\r\n  I: Integer;\r\n  Offset, ID: DWORD;\r\n  pInfo: PSymbolInfo;\r\n  Symbol: TJclTD32SymbolInfo;\r\n  Module: TJclTD32ModuleInfo;\r\n  ProcSymbol: TJclTD32ProcSymbolInfo;\r\n  ModuleProcSymbol: TJclTD32ProcSymbolInfo;\r\nbegin\r\n  Module := Modules[ModuleIndex];\r\n  ProcSymbol := nil;\r\n  Offset := DWORD(@pSymbols.Symbols[0]) - DWORD(pSymbols);\r\n\r\n  if FSymbols.Capacity = 0 then\r\n    FSymbols.Capacity := 4096;\r\n\r\n  if FProcSymbols.Capacity = 0 then\r\n    FProcSymbols.Capacity := 4096;\r\n\r\n  if Module.FSymbols.Capacity = 0 then\r\n    Module.FSymbols.Capacity := 256;\r\n\r\n  while Offset < Size do\r\n  begin\r\n    pInfo := PSymbolInfo(DWORD(pSymbols) + Offset);\r\n    ID := DWORD(pInfo) - DWORD(pSymbols);\r\n    Symbol := nil;\r\n    case pInfo.SymbolType of\r\n{ Temporary disabled symbols\r\n      SYMBOL_TYPE_WITH32:\r\n        Symbol := TJclWithSymbolInfo.Create(pInfo, ID);\r\n      SYMBOL_TYPE_UDT:\r\n        Symbol := TJclUdtSymbolInfo.Create(pInfo, ID);\r\n      SYMBOL_TYPE_SSEARCH:\r\n        Symbol := TJclStartSymbolInfo.Create(pInfo, ID);\r\n}\r\n      SYMBOL_TYPE_END:\r\n        Symbol := TJclTD32EndSymbolInfo.Create(pInfo, ID);\r\n      SYMBOL_TYPE_USES:\r\n        AnalyzeUses(pInfo, Module);\r\n      SYMBOL_TYPE_REGISTER:\r\n        Symbol := TJclTD32RegisterSymbolInfo.Create(pInfo, ID);\r\n      SYMBOL_TYPE_OPTVAR32:\r\n        if FSymbols.Last is TJclTD32RegisterSymbolInfo then\r\n          TJclTD32RegisterSymbolInfo(FSymbols.Last).AnalizeRanges(pInfo);\r\n      SYMBOL_TYPE_PCONSTANT:\r\n        Symbol := TJclTD32ConstantSymbolInfo.Create(pInfo, ID);\r\n      SYMBOL_TYPE_BPREL32:\r\n        Symbol := TJclTD32BPRel32SymbolInfo.Create(pInfo, ID);\r\n      SYMBOL_TYPE_LDATA32:\r\n        Symbol := TJclTD32LDataSymbolInfo.Create(pInfo, ID);\r\n      SYMBOL_TYPE_GDATA32:\r\n        Symbol := TJclTD32GDataSymbolInfo.Create(pInfo, ID);\r\n      SYMBOL_TYPE_LPROC32:\r\n        Symbol := TJclTD32LocalProcSymbolInfo.Create(pInfo, ID);\r\n      SYMBOL_TYPE_GPROC32:\r\n        Symbol := TJclTD32GlobalProcSymbolInfo.Create(pInfo, ID);\r\n      SYMBOL_TYPE_SLINK32:\r\n        Symbol := TJclTD32LinkSymbolInfo.Create(pInfo, ID);\r\n    end;\r\n\r\n    if Assigned(Symbol) then\r\n    begin\r\n      FSymbols.Add(Symbol);\r\n      if Symbol.FSymbolType = SYMBOL_TYPE_END then\r\n        ProcSymbol := nil\r\n      else\r\n      begin\r\n        if ProcSymbol = nil then\r\n          Module.FSymbols.Add(Symbol)\r\n        else\r\n          ProcSymbol.FSymbols.Add(Symbol);\r\n\r\n        if Symbol is TJclTD32ProcSymbolInfo then\r\n        begin\r\n          FProcSymbols.Add(Symbol);\r\n          Module.FProcSymbols.Add(Symbol);\r\n          ProcSymbol := TJclTD32ProcSymbolInfo(Symbol);\r\n\r\n          if Symbol.ParentID <> 0 then\r\n            for I := Module.ProcSymbolCount - 1 downto 0 do\r\n            begin\r\n              ModuleProcSymbol := Module.ProcSymbols[I];\r\n              if ModuleProcSymbol.ID = Symbol.ParentID then\r\n              begin\r\n                Symbol.FParent := ModuleProcSymbol;\r\n                ModuleProcSymbol.FSymbols.Add(Symbol);\r\n                Break;\r\n              end;\r\n            end;\r\n        end;\r\n      end;\r\n    end;\r\n    Inc(Offset, pInfo.Size + SizeOf(pInfo.Size));\r\n  end;\r\nend;\r\n\r\nprocedure TJclTD32InfoParser.AnalyseModules(pModInfo: PModuleInfo; const Size: DWORD);\r\nvar\r\n  ModuleInfo: TJclTD32ModuleInfo;\r\nbegin\r\n  ModuleInfo := TJclTD32ModuleInfo.Create(pModInfo);\r\n  FModules.Add(ModuleInfo);\r\nend;\r\n\r\nprocedure TJclTD32InfoParser.AnalyseSourceModules(pSrcModInfo: PSourceModuleInfo; const Size: DWORD; const ModuleIndex: Integer);\r\nvar\r\n  I: Integer;\r\n  pSrcFile: PSourceFileEntry;\r\n  SrcModule: TJclTD32SourceModuleInfo;\r\n  ModuleInfo: TJclTD32ModuleInfo;\r\nbegin\r\n  ModuleInfo := Modules[ModuleIndex];\r\n\r\n  FSourceModules.Capacity := FSourceModules.Capacity + pSrcModInfo.FileCount;\r\n  ModuleInfo.FSourceModules.Capacity := ModuleInfo.FSourceModules.Capacity + pSrcModInfo.FileCount;\r\n  for I := 0 to pSrcModInfo.FileCount - 1 do\r\n  begin\r\n    pSrcFile := PSourceFileEntry(DWORD(pSrcModInfo) + pSrcModInfo.BaseSrcFiles[I]);\r\n    if pSrcFile.NameIndex > 0 then\r\n    begin\r\n      SrcModule := TJclTD32SourceModuleInfo.Create(pSrcFile, DWORD(pSrcModInfo));\r\n      FSourceModules.Add(SrcModule);\r\n      ModuleInfo.FSourceModules.Add(SrcModule);\r\n    end;\r\n  end;\r\nend;\r\n\r\nprocedure TJclTD32InfoParser.AnalyseUnknownSubSection(const pSubsection: Pointer; const Size: DWORD);\r\nbegin\r\n  // do nothing\r\nend;\r\n\r\nprocedure TJclTD32InfoParser.AnalyzeUses(pSymbols: PSymbolInfo; Module: TJclTD32ModuleInfo);\r\nvar\r\n  I: Integer;\r\n  Count: Integer;\r\nbegin\r\n  Count := (pSymbols.Size - SizeOf(pSymbols.SymbolType)) div SizeOf(DWORD);\r\n  Module.FUsedModuleNameIndices.Capacity := Module.FUsedModuleNameIndices.Capacity + Count;\r\n  for I := 0 to Count - 1 do\r\n    Module.FUsedModuleNameIndices.Add(Pointer(pSymbols.Use.Names[I]));\r\nend;\r\n\r\nfunction TJclTD32InfoParser.GetModule(const Idx: Integer): TJclTD32ModuleInfo;\r\nbegin\r\n  Result := TJclTD32ModuleInfo(FModules.Items[Idx]);\r\nend;\r\n\r\nfunction TJclTD32InfoParser.GetModuleCount: Integer;\r\nbegin\r\n  Result := FModules.Count;\r\nend;\r\n\r\nfunction TJclTD32InfoParser.GetName(const Idx: Integer): AnsiString;\r\nbegin\r\n  Result := PAnsiChar(FNames.Items[Idx]);\r\nend;\r\n\r\nfunction TJclTD32InfoParser.GetNameCount: Integer;\r\nbegin\r\n  Result := FNames.Count;\r\nend;\r\n\r\nfunction TJclTD32InfoParser.GetSourceModule(const Idx: Integer): TJclTD32SourceModuleInfo;\r\nbegin\r\n  Result := TJclTD32SourceModuleInfo(FSourceModules.Items[Idx]);\r\nend;\r\n\r\nfunction TJclTD32InfoParser.GetSourceModuleCount: Integer;\r\nbegin\r\n  Result := FSourceModules.Count;\r\nend;\r\n\r\nfunction TJclTD32InfoParser.GetIndexOfName(Const Name: AnsiString): Integer;\r\nvar\r\n  I: Integer;\r\n  L: Integer;\r\n  N: PAnsiChar;\r\n  S: PAnsiChar;\r\nbegin\r\n  N := PAnsiChar(Name);\r\n  L := Length(Name);\r\n  for I := 0 to FNames.Count - 1 do\r\n  begin\r\n    S := PAnsiChar(FNames[I]);\r\n    if (S <> Nil) And (L = Integer(System.AnsiStrings.StrLen(S))) And (System.AnsiStrings.StrLIComp(S, N, L) = 0) then\r\n    begin\r\n      Result := I;\r\n      Exit;\r\n    end;\r\n  end;\r\n  Result := -1;\r\nend;\r\n\r\nfunction TJclTD32InfoParser.GetSymbol(const Idx: Integer): TJclTD32SymbolInfo;\r\nbegin\r\n  Result := TJclTD32SymbolInfo(FSymbols.Items[Idx]);\r\nend;\r\n\r\nfunction TJclTD32InfoParser.GetSymbolCount: Integer;\r\nbegin\r\n  Result := FSymbols.Count;\r\nend;\r\n\r\nfunction TJclTD32InfoParser.GetSymbolType(const Idx: Integer): TJclSymbolTypeInfo;\r\nbegin\r\n  if (Idx > -1) and (Idx < $1000) and (FSymbolTypes[Idx] = nil) then\r\n    FSymbolTypes[Idx] := CreatePrimitiveTypeInfo(Idx);\r\n  Result := FSymbolTypes[Idx];\r\nend;\r\n\r\nfunction TJclTD32InfoParser.GetSymbolTypeCount: Integer;\r\nbegin\r\n  Result := FSymbolTypes.Count;\r\nend;\r\n\r\nfunction TJclTD32InfoParser.GetProcSymbol(const Idx: Integer): TJclTD32ProcSymbolInfo;\r\nbegin\r\n  Result := TJclTD32ProcSymbolInfo(FProcSymbols.Items[Idx]);\r\nend;\r\n\r\nfunction TJclTD32InfoParser.GetProcSymbolCount: Integer;\r\nbegin\r\n  Result := FProcSymbols.Count;\r\nend;\r\n\r\nfunction TJclTD32InfoParser.FindModule(const AAddr: DWORD; var AMod: TJclTD32ModuleInfo): LongBool;\r\nvar\r\n  I, J: Integer;\r\n  ModuleInfo: TJclTD32ModuleInfo;\r\n  SegmentInfo: PSegmentInfo;\r\nbegin\r\n  if ValidData then\r\n    for I := 0 to ModuleCount - 1 do\r\n    begin\r\n      ModuleInfo := Modules[I];\r\n      for J := 0 to ModuleInfo.SegmentCount - 1 do\r\n      begin\r\n        SegmentInfo := @ModuleInfo.FSegments[J];\r\n        if (SegmentInfo^.Flags = 1) and (AAddr >= SegmentInfo^.Offset) and\r\n          (AAddr - SegmentInfo^.Offset <= SegmentInfo^.Size) then\r\n        begin\r\n          Result := True;\r\n          AMod := ModuleInfo;\r\n          Exit;\r\n        end;\r\n      end;\r\n    end;\r\n  Result := False;\r\n  AMod := nil;\r\nend;\r\n\r\nfunction TJclTD32InfoParser.FindModule(const Section: Word; const Offset: DWORD): TJclTD32ModuleInfo;\r\nvar\r\n  M, S: Integer;\r\nbegin\r\n  //TODO:\r\n  if ValidData then\r\n    for M := 0 to ModuleCount - 1 do\r\n    with Modules[M] do\r\n      for S := 0 to SegmentCount - 1 do\r\n        if (Segment[S].Segment = Section) and (Segment[S].Offset <= Offset) and (Segment[S].Offset + Segment[S].Size >= Offset) then\r\n        begin\r\n          Result := Modules[M];\r\n          Exit;\r\n        end;\r\n  Result := nil;\r\nend;\r\n\r\nfunction TJclTD32InfoParser.ModuleByNameIndex(const NameIndex: Cardinal): TJclTD32ModuleInfo;\r\nvar\r\n  I: Integer;\r\nbegin\r\n  if ValidData then\r\n    for I := 0 to ModuleCount - 1 do\r\n      if Modules[I].NameIndex = NameIndex then\r\n      begin\r\n        Result := Modules[I];\r\n        Exit;\r\n      end;\r\n  Result := nil;\r\nend;\r\n\r\nfunction TJclTD32InfoParser.FindSourceModule(const AAddr: DWORD; var ASrcMod: TJclTD32SourceModuleInfo): LongBool;\r\nvar\r\n  I, J: Integer;\r\nbegin\r\n  if ValidData then\r\n    for I := 0 to SourceModuleCount - 1 do\r\n    with SourceModules[I] do\r\n      for J := 0 to SegmentCount - 1 do\r\n        with Segment[J] do\r\n          if (StartOffset <= AAddr) and (AAddr < EndOffset) then\r\n          begin\r\n            Result := True;\r\n            ASrcMod := SourceModules[I];\r\n            Exit;\r\n          end;\r\n  ASrcMod := nil;\r\n  Result := False;\r\nend;\r\n\r\nfunction TJclTD32InfoParser.FindProc(const AAddr: DWORD; var AProc: TJclTD32ProcSymbolInfo): LongBool;\r\nvar\r\n  I: Integer;\r\nbegin\r\n  if ValidData then\r\n    for I := 0 to ProcSymbolCount - 1 do\r\n    begin\r\n      AProc := ProcSymbols[I];\r\n      with AProc do\r\n        if (Offset <= AAddr) and (AAddr < Offset + Size) then\r\n        begin\r\n          Result := True;\r\n          Exit;\r\n        end;\r\n    end;\r\n  AProc := nil;\r\n  Result := False;\r\nend;\r\n\r\nclass function TJclTD32InfoParser.IsTD32DebugInfoValid(\r\n  const DebugData: Pointer; const DebugDataSize: LongWord): LongBool;\r\nvar\r\n  Sign: PJclTD32FileSignature;\r\n  EndOfDebugData: LongWord;\r\nbegin\r\n  Assert(not IsBadReadPtr(DebugData, DebugDataSize));\r\n  Result := False;\r\n  EndOfDebugData := LongWord(DebugData) + DebugDataSize;\r\n  if DebugDataSize > SizeOf(TJclTD32FileSignature) then\r\n  begin\r\n    Sign := PJclTD32FileSignature(EndOfDebugData - SizeOf(TJclTD32FileSignature));\r\n    if IsTD32Sign(Sign^) and (Sign^.Offset <= DebugDataSize) then\r\n    begin\r\n      Sign := PJclTD32FileSignature(EndOfDebugData - Sign^.Offset);\r\n      Result := IsTD32Sign(Sign^);\r\n    end;\r\n  end;\r\nend;\r\n\r\nclass function TJclTD32InfoParser.IsTD32Sign(const Sign: TJclTD32FileSignature): LongBool;\r\nbegin\r\n  Result := (Sign.Signature = Borland32BitSymbolFileSignatureForDelphi) or\r\n    (Sign.Signature = Borland32BitSymbolFileSignatureForBCB);\r\nend;\r\n\r\nfunction TJclTD32InfoParser.LfaToVa(const Lfa: DWORD): Pointer;\r\nbegin\r\n  Result := Pointer(DWORD(FBase) + Lfa)\r\nend;\r\n\r\nfunction TJclTD32InfoParser.CreateTypeInfo(const Kind: TJclSymbolTypeKind; const Size: DWORD = 0; const NameIndex: DWORD = 0): TJclSymbolTypeInfo;\r\nbegin\r\n  Result := TJclSymbolTypeInfo.Create;\r\n  Result.Kind := Kind;\r\n  Result.DataSize := Size;\r\n  Result.NameIndex := NameIndex;\r\nend;\r\n\r\nfunction TJclTD32InfoParser.CreatePrimitiveTypeInfo(const Idx: DWORD): TJclSymbolTypeInfo;\r\nvar\r\n  Kind: Byte;\r\n  Size: Byte;\r\nbegin\r\n  Result := nil;\r\n  Size := Idx And $7;\r\n  Kind := (Idx And $F0) Shr 4;\r\n  case Kind of\r\n    0: // Special\r\n      case Size Of\r\n        3: Result := CreateTypeInfo(stkVoid, SizeOf(Pointer));\r\n        4: Result := CreateTypeInfo(stkCurrency, SizeOf(TCurrencyTypeInfo));\r\n      end;\r\n    1: // Signed integral value\r\n      case Size Of\r\n        0: Result := CreateTypeInfo(stkShortInt, SizeOf(TCharTypeInfo));\r\n        1: Result := CreateTypeInfo(stkSmallInt, SizeOf(TShortTypeInfo));\r\n        2: Result := CreateTypeInfo(stkInteger, SizeOf(TLongTypeInfo));\r\n        3: Result := CreateTypeInfo(stkInt64, SizeOf(TQuadWordTypeInfo));\r\n      end;\r\n    2: // Unsigned integral value\r\n      case Size Of\r\n        0: Result := CreateTypeInfo(stkByte, SizeOf(TCharTypeInfo));\r\n        1: Result := CreateTypeInfo(stkWord, SizeOf(TUShortTypeInfo));\r\n        2: Result := CreateTypeInfo(stkCardinal, SizeOf(TULongTypeInfo));\r\n        3: Result := CreateTypeInfo(stkUInt64, SizeOf(TUQuadWordTypeInfo));\r\n      end;\r\n    3: // Boolean\r\n      case Size Of\r\n        0: Result := CreateTypeInfo(stkBoolean, SizeOf(TCharTypeInfo));\r\n        1: Result := CreateTypeInfo(stkWordBool, SizeOf(TUShortTypeInfo));\r\n        2: Result := CreateTypeInfo(stkLongBool, SizeOf(TULongTypeInfo));\r\n      end;\r\n    4: // Real\r\n      case Size Of\r\n        0: Result := CreateTypeInfo(stkSingle, SizeOf(TReal32TypeInfo));\r\n        1: Result := CreateTypeInfo(stkReal, SizeOf(TReal64TypeInfo));\r\n        2: Result := CreateTypeInfo(stkExtended, SizeOf(TReal80TypeInfo));\r\n        4: Result := CreateTypeInfo(stkReal48, SizeOf(TReal48TypeInfo));\r\n      end;\r\n    5: // Complex\r\n      case Size Of\r\n        2: Result := CreateTypeInfo(stkComplex, SizeOf(TComplex64TypeInfo));\r\n      end;\r\n    6: // Special2\r\n      case Size Of\r\n        1: Result := CreateTypeInfo(stkChar, SizeOf(TCharTypeInfo));\r\n      end;\r\n    7: // Real int value\r\n      case Size Of\r\n        0: Result := CreateTypeInfo(stkChar, SizeOf(TCharTypeInfo));\r\n        1: Result := CreateTypeInfo(stkWideChar, SizeOf(TWideCharTypeInfo));\r\n        2: Result := CreateTypeInfo(stkSmallInt, SizeOf(TShortTypeInfo));\r\n        3: Result := CreateTypeInfo(stkWord, SizeOf(TUShortTypeInfo));\r\n        4: Result := CreateTypeInfo(stkInteger, SizeOf(TLongTypeInfo));\r\n        5: Result := CreateTypeInfo(stkCardinal, SizeOf(TULongTypeInfo));\r\n        6: Result := CreateTypeInfo(stkInt64, SizeOf(TQuadWordTypeInfo));\r\n        7: Result := CreateTypeInfo(stkUInt64, SizeOf(TUQuadWordTypeInfo));\r\n      end;\r\n  end;\r\nend;\r\n\r\nfunction TJclTD32InfoParser.CreateArgListTypeInfo(pInfo: PSymbolTypeInfo): TJclSymbolTypeInfo;\r\nvar\r\n  I: Integer;\r\nbegin\r\n  Result := CreateTypeInfo(stkArgList, 0);\r\n  Result.Args.Capacity := pInfo.LeafArgList.Count;\r\n  for I := 0 to pInfo.LeafArgList.Count - 1 do\r\n    Result.Args.Add(Pointer(pInfo.LeafArgList.Args[I]));\r\nend;\r\n\r\nfunction TJclTD32InfoParser.CreateFieldListTypeInfo(pInfo: PSymbolTypeInfo): TJclSymbolTypeInfo;\r\nvar\r\n  Offset, Size: Integer;\r\n\r\n  procedure IncOffset;\r\n  begin\r\n    Inc(Offset, Size);\r\n    if PByte(Offset)^ > $F0 then\r\n      Inc(Offset, PByte(Offset)^ And $0F);\r\n  end;\r\n\r\nbegin\r\n  Result := CreateTypeInfo(stkFieldList, 0);\r\n  Offset := Integer(pInfo);\r\n  Size := Integer(@PSymbolTypeInfo(0).LeafFieldList);\r\n  IncOffset;\r\n\r\n  Result.Members.Capacity := 16;\r\n  while Integer(@pInfo.Leaf) + pInfo.Length > Offset do\r\n  begin\r\n    case pFieldListElement(Offset).Leaf of\r\n      LF_BCLASS:\r\n      begin\r\n        Result.ElementType := pFieldListElement(Offset).LeafBClass.TypeIndex;\r\n        Size := SizeOf(TBClassTypeInfo);\r\n      end;\r\n      LF_ENUMERATE:\r\n      begin\r\n        Result.Members.Add(TJclEnumerateSymbolInfo.Create(pFieldListElement(Offset)));\r\n        Size := SizeOf(TEnumerateTypeInfo);\r\n      end;\r\n      LF_MEMBER:\r\n      begin\r\n        Result.Members.Add(TJclTD32MemberSymbolInfo.Create(pFieldListElement(Offset)));\r\n        Size := SizeOf(TMemberTypeInfo);\r\n      end;\r\n      LF_STMEMBER: Size := 14;           // Static member - skip\r\n      LF_METHOD:   Size := 10;           // Class method - skip\r\n      LF_VFUNCTAB: Size := 6             // VMT - skip\r\n      else         Size := pInfo.Length; // Unknown element - cancel parsing\r\n    end;\r\n    Inc(Size, SizeOf(Word));\r\n    IncOffset;\r\n  end;\r\nend;\r\n\r\nprocedure TJclTD32InfoParser.FixVariantTypes;\r\n\r\n  function CheckNameIndex(const Value: AnsiString): Integer;\r\n  begin\r\n    if Value <> '' then\r\n    begin\r\n      Result := IndexOfName[Value];\r\n      if Result = -1 then\r\n        Result := FNames.Add(PAnsiChar(Value));\r\n    end\r\n    else\r\n      Result := 0;\r\n  end;\r\n\r\n  function CreateMember(const MemberName: AnsiString; const Offset: Word; const BaseType: DWORD): TJclTD32MemberSymbolInfo;\r\n  var\r\n    Member: TFieldListElement;\r\n  begin\r\n    Member.Leaf := LF_MEMBER;\r\n    Member.LeafMember.BaseType := BaseType;\r\n    Member.LeafMember.Flags := 3;\r\n    Member.LeafMember.NameIndex := CheckNameIndex(MemberName);\r\n    Member.LeafMember.Reserved := 0;\r\n    Member.LeafMember.Offset := Offset;\r\n    Result := TJclTD32MemberSymbolInfo.Create(pFieldListElement(@Member));\r\n  end;\r\n\r\n  function CreatePointer(const ElementType: Integer): Integer;\r\n  var\r\n    TypeInfo: TJclSymbolTypeInfo;\r\n  begin\r\n    TypeInfo := CreateTypeInfo(stkPointer, SizeOf(Pointer));\r\n    TypeInfo.ElementType := ElementType;\r\n    Result := FSymbolTypes.Add(TypeInfo);\r\n  end;\r\n\r\n  function CreateSubRange(const SubRangeName: AnsiString; const IndexType, MinValue, MaxValue: Integer; const DataSize: UInt64): Integer;\r\n  var\r\n    TypeInfo: TJclSymbolTypeInfo;\r\n  begin\r\n    TypeInfo := CreateTypeInfo(stkSubrange, 0, CheckNameIndex(SubRangeName));\r\n    TypeInfo.IndexType := IndexType;\r\n    TypeInfo.MinValue := MinValue;\r\n    TypeInfo.MaxValue := MaxValue;\r\n    TypeInfo.DataSize := DataSize;\r\n    Result := FSymbolTypes.Add(TypeInfo);\r\n  end;\r\n\r\n  function CreateArray(const ArrayName: AnsiString; const ElementType, IndexType, DataSize, ElementCount: Integer): Integer;\r\n  var\r\n    TypeInfo: TJclSymbolTypeInfo;\r\n  begin\r\n    TypeInfo := CreateTypeInfo(stkArray, 0, CheckNameIndex(ArrayName));\r\n    TypeInfo.ElementType := ElementType;\r\n    TypeInfo.IndexType := IndexType;\r\n    TypeInfo.DataSize := DataSize;\r\n    TypeInfo.MaxValue := ElementCount;\r\n    Result := FSymbolTypes.Add(TypeInfo);\r\n  end;\r\n\r\n  function CreateStruct(const StructName: AnsiString; const Length, Members: Integer): Integer;\r\n  var\r\n    TypeInfo: TJclSymbolTypeInfo;\r\n  begin\r\n    TypeInfo := CreateTypeInfo(stkStructure, Length, CheckNameIndex(StructName));\r\n    TypeInfo.Elements := Members;\r\n    Result := FSymbolTypes.Add(TypeInfo);\r\n  end;\r\n\r\ntype\r\n  TMemberSymbolTypeInfo = packed record\r\n    Leaf: Word;\r\n    Member: TMemberTypeInfo;\r\n  end;\r\n\r\nvar\r\n  I, NameIndex, FieldListIndex, VoidIndex: Integer;\r\n  FieldList : TJclSymbolTypeInfo;\r\n  SymbolType: TJclSymbolTypeInfo;\r\nbegin\r\n  // Create debug info for TVarData type\r\n  if FIsVarTypesExist then\r\n  begin\r\n    NameIndex := CheckNameIndex('TVarData');\r\n    VoidIndex := CreatePointer(0);\r\n\r\n    FieldList := CreateTypeInfo(stkFieldList, 0);\r\n    FieldList.Members.Add(CreateMember('ElementCount', 0, $74));\r\n    FieldList.Members.Add(CreateMember('LowBound', 4, $74));\r\n    FieldListIndex := FSymbolTypes.Add(FieldList);\r\n\r\n    FieldList := CreateTypeInfo(stkFieldList, 0);\r\n    FieldList.Members.Add(CreateMember('DimCount', 0, $73));\r\n    FieldList.Members.Add(CreateMember('Flags', 2, $73));\r\n    FieldList.Members.Add(CreateMember('ElementSize', 4, $74));\r\n    FieldList.Members.Add(CreateMember('LockCount', 8, $74));\r\n    FieldList.Members.Add(CreateMember('Data', 12, VoidIndex));\r\n    FieldList.Members.Add(CreateMember('Bounds', 16, CreateArray('TVarArrayBoundArray', CreateStruct('TVarArrayBound', 8, FieldListIndex), CreateSubRange('', $74, 0, 0, 1), 8, 1)));\r\n    FieldListIndex := FSymbolTypes.Add(FieldList);\r\n\r\n    FieldList := CreateTypeInfo(stkFieldList, 0);\r\n    FieldList.Members.Add(CreateMember('VType', 0, $73));\r\n    FieldList.Members.Add(CreateMember('Reserved1', 2, $73));\r\n    FieldList.Members.Add(CreateMember('Reserved2', 4, $73));\r\n    FieldList.Members.Add(CreateMember('Reserved3', 6, $73));\r\n    FieldList.Members.Add(CreateMember('VSmallInt', 8, $72));\r\n    FieldList.Members.Add(CreateMember('VInteger', 8, $74));\r\n    FieldList.Members.Add(CreateMember('VSingle', 8, $40));\r\n    FieldList.Members.Add(CreateMember('VDouble', 8, $41));\r\n    FieldList.Members.Add(CreateMember('VCurrency', 8, $04));\r\n    FieldList.Members.Add(CreateMember('VDate', 8, $41));\r\n    FieldList.Members.Add(CreateMember('VOleStr', 8, CreatePointer($71)));\r\n    FieldList.Members.Add(CreateMember('VDispatch', 8, VoidIndex));\r\n    FieldList.Members.Add(CreateMember('VError', 8, $74));\r\n    FieldList.Members.Add(CreateMember('VBoolean', 8, CreateSubRange('WordBool', $72, Low(Integer), High(Integer), 2)));\r\n    FieldList.Members.Add(CreateMember('VUnknown', 8, VoidIndex));\r\n    FieldList.Members.Add(CreateMember('VShortInt', 8, $10));\r\n    FieldList.Members.Add(CreateMember('VByte', 8, $20));\r\n    FieldList.Members.Add(CreateMember('VWord', 8, $73));\r\n    FieldList.Members.Add(CreateMember('VLongWord', 8, $75));\r\n    FieldList.Members.Add(CreateMember('VInt64', 8, $76));\r\n    FieldList.Members.Add(CreateMember('VString', 8, VoidIndex));\r\n    FieldList.Members.Add(CreateMember('VAny', 8, VoidIndex));\r\n    FieldList.Members.Add(CreateMember('VArray', 8, CreatePointer(CreateStruct('TVarArray', 24, FieldListIndex))));\r\n    FieldList.Members.Add(CreateMember('VPointer', 8, VoidIndex));\r\n    FieldList.Members.Add(CreateMember('VLongs', 4, CreateArray('', $74, CreateSubRange('', $74, 0, 2, 1), 12, 3)));\r\n    FieldList.Members.Add(CreateMember('VWords', 2, CreateArray('', $73, CreateSubRange('', $74, 0, 6, 1), 14, 7)));\r\n    FieldList.Members.Add(CreateMember('VBytes', 2, CreateArray('', $20, CreateSubRange('', $74, 0, 13, 1), 14, 14)));\r\n    FieldList.Members.Add(CreateMember('RawData', 0, CreateArray('', $74, CreateSubRange('', $74, 0, 3, 1), 16, 4)));\r\n    FieldListIndex := FSymbolTypes.Add(FieldList);\r\n\r\n    for I := 0 to SymbolTypeCount - 1 do\r\n    begin\r\n      SymbolType := SymbolTypes[I];\r\n      if (SymbolType <> nil) and (SymbolType.Kind = stkVariant) then\r\n      begin\r\n        SymbolType.Kind := stkStructure;\r\n        SymbolType.NameIndex := NameIndex;\r\n        SymbolType.Elements := FieldListIndex;\r\n      end;\r\n    end;\r\n  end;\r\nend;\r\n\r\n//=== { TJclTD32InfoScanner } ================================================\r\n\r\nfunction TJclTD32InfoScanner.LineNumberFromAddr(const AAddr: DWORD): Integer;\r\nvar\r\n  Dummy: Integer;\r\nbegin\r\n  Result := LineNumberFromAddr(AAddr, Dummy);\r\nend;\r\n\r\nfunction TJclTD32InfoScanner.LineNumberFromAddr(const AAddr: DWORD; var Offset: Integer): Integer;\r\nvar\r\n  ASrcMod: TJclTD32SourceModuleInfo;\r\n  ALine: TJclTD32LineInfo;\r\nbegin\r\n  if FindSourceModule(AAddr, ASrcMod) and ASrcMod.FindLine(AAddr, ALine) then\r\n  begin\r\n    Result := ALine.LineNo;\r\n    Offset := AAddr - ALine.Offset;\r\n  end\r\n  else\r\n  begin\r\n    Result := 0;\r\n    Offset := 0;\r\n  end;\r\nend;\r\n\r\nfunction TJclTD32InfoScanner.ModuleNameFromAddr(const AAddr: DWORD): AnsiString;\r\nvar\r\n  AMod: TJclTD32ModuleInfo;\r\nbegin\r\n  if FindModule(AAddr, AMod) then\r\n    Result := Names[AMod.NameIndex]\r\n  else\r\n    Result := '';\r\nend;\r\n\r\nfunction TJclTD32InfoScanner.ProcNameFromAddr(const AAddr: DWORD): AnsiString;\r\nvar\r\n  Dummy: Integer;\r\nbegin\r\n  Result := ProcNameFromAddr(AAddr, Dummy);\r\nend;\r\n\r\nfunction TJclTD32InfoScanner.ProcNameFromAddr(const AAddr: DWORD; var Offset: Integer): AnsiString;\r\nvar\r\n  AProc: TJclTD32ProcSymbolInfo;\r\n\r\n  function FormatProcName(const ProcName: AnsiString): AnsiString;\r\n  var\r\n    pchSecondAt, P: PAnsiChar;\r\n  begin\r\n    Result := ProcName;\r\n    if (Length(ProcName) > 0) and (ProcName[1] = '@') then\r\n    begin\r\n      pchSecondAt := System.AnsiStrings.StrScan(PAnsiChar(Copy(ProcName, 2, Length(ProcName) - 1)), '@');\r\n      if pchSecondAt <> nil then\r\n      begin\r\n        Inc(pchSecondAt);\r\n        Result := pchSecondAt;\r\n        P := PAnsiChar(Result);\r\n        while P^ <> #0 do\r\n        begin\r\n          if (pchSecondAt^ = '@') and ((pchSecondAt - 1)^ <> '@') then\r\n            P^ := '.';\r\n          Inc(P);\r\n          Inc(pchSecondAt);\r\n        end;\r\n      end;\r\n    end;\r\n  end;\r\n\r\nbegin\r\n  if FindProc(AAddr, AProc) then\r\n  begin\r\n    Result := FormatProcName(Names[AProc.NameIndex]);\r\n    Offset := AAddr - AProc.Offset;\r\n  end\r\n  else\r\n  begin\r\n    Result := '';\r\n    Offset := 0;\r\n  end;\r\nend;\r\n\r\nfunction TJclTD32InfoScanner.SourceNameFromAddr(const AAddr: DWORD): AnsiString;\r\nvar\r\n  ASrcMod: TJclTD32SourceModuleInfo;\r\nbegin\r\n  if FindSourceModule(AAddr, ASrcMod) then\r\n    Result := Names[ASrcMod.NameIndex];\r\nend;\r\n\r\n//=== { TJclPeBorTD32Image } =================================================\r\n\r\nprocedure TJclPeBorTD32Image.AfterOpen;\r\nbegin\r\n  inherited AfterOpen;\r\n  CheckDebugData;\r\nend;\r\n\r\nprocedure TJclPeBorTD32Image.CheckDebugData;\r\nbegin\r\n  FTD32DebugDataType := ddtNone;\r\n  FIsTD32DebugPresent := IsDebugInfoInImage(FTD32DebugData);\r\n  if FIsTD32DebugPresent then\r\n    FTD32DebugDataType := ddtInImage\r\n  else\r\n  begin\r\n    FIsTD32DebugPresent := IsDebugInfoInTds(FTD32DebugData);\r\n    if FIsTD32DebugPresent then\r\n      FTD32DebugDataType := ddtTDS;\r\n  end;\r\n\r\n  if FIsTD32DebugPresent then\r\n  begin\r\n    FTD32Scanner := TJclTD32InfoScanner.Create(FTD32DebugData);\r\n    if not FTD32Scanner.ValidData then\r\n    begin\r\n      ClearDebugData;\r\n      if not NoExceptions then\r\n        raise EJclError.CreateResFmt(@RsHasNotTD32Info, [FileName]);\r\n    end;\r\n  end;\r\nend;\r\n\r\nprocedure TJclPeBorTD32Image.Clear;\r\nbegin\r\n  ClearDebugData;\r\n  inherited Clear;\r\nend;\r\n\r\nprocedure TJclPeBorTD32Image.ClearDebugData;\r\nbegin\r\n  FIsTD32DebugPresent := False;\r\n  FreeAndNil(FTD32Scanner);\r\n  FreeAndNil(FTD32DebugData);\r\nend;\r\n\r\nfunction TJclPeBorTD32Image.IsDebugInfoInImage(var DataStream: TCustomMemoryStream): LongBool;\r\nvar\r\n  DebugDir: TImageDebugDirectory;\r\n  BugDataStart: Pointer;\r\n  DebugDataSize: Integer;\r\nbegin\r\n  Result := False;\r\n  DataStream := nil;\r\n  if IsBorlandImage and (DebugList.Count = 1) then\r\n  begin\r\n    DebugDir := DebugList[0];\r\n    if DebugDir._Type = IMAGE_DEBUG_TYPE_UNKNOWN then\r\n    begin\r\n      BugDataStart := RvaToVa(DebugDir.AddressOfRawData);\r\n      DebugDataSize := DebugDir.SizeOfData;\r\n      Result := TJclTD32InfoParser.IsTD32DebugInfoValid(BugDataStart, DebugDataSize);\r\n      if Result then\r\n        DataStream := TJclReferenceMemoryStream.Create(BugDataStart, DebugDataSize);\r\n    end;\r\n  end;\r\nend;\r\n\r\nfunction TJclPeBorTD32Image.IsDebugInfoInTds(var DataStream: TCustomMemoryStream): LongBool;\r\nvar\r\n  TdsFileName: TFileName;\r\n  TempStream: TCustomMemoryStream;\r\nbegin\r\n  Result := False;\r\n  DataStream := nil;\r\n  TdsFileName := ChangeFileExt(FileName, TurboDebuggerSymbolExt);\r\n  if FileExists(TdsFileName) then\r\n  begin\r\n    TempStream := TJclFileMappingStream.Create(TdsFileName);\r\n    try\r\n      Result := TJclTD32InfoParser.IsTD32DebugInfoValid(TempStream.Memory, TempStream.Size);\r\n      if Result then\r\n        DataStream := TempStream\r\n      else\r\n        TempStream.Free;\r\n    except\r\n      TempStream.Free;\r\n      raise;\r\n    end;\r\n  end;\r\nend;\r\n\r\n{ TJclSymbolTypeInfo }\r\n\r\nconstructor TJclSymbolTypeInfo.Create;\r\nbegin\r\n  inherited;\r\n\r\n  FMembers := Nil;\r\n  FArgs := Nil;\r\nend;\r\n\r\ndestructor TJclSymbolTypeInfo.Destroy;\r\nbegin\r\n  FreeAndNil(FMembers);\r\n  FreeAndNil(FArgs);\r\n\r\n  inherited;\r\nend;\r\n\r\nfunction TJclSymbolTypeInfo.GetArgs: TList;\r\nbegin\r\n  if FArgs = Nil then\r\n    FArgs := TList.Create;\r\n\r\n  Result := FArgs;\r\nend;\r\n\r\nfunction TJclSymbolTypeInfo.GetMembers: TObjectList;\r\nbegin\r\n  if FMembers = Nil then\r\n    FMembers := TObjectList.Create;\r\n\r\n  Result := FMembers;\r\nend;\r\n\r\n{ TJclTD32ObjNameSymbolInfo }\r\n\r\nconstructor TJclTD32ObjNameSymbolInfo.Create(pSymInfo: PSymbolInfo; const aID: DWORD);\r\nbegin\r\n  Assert(Assigned(pSymInfo));\r\n  inherited Create(pSymInfo, aID);\r\n  with pSymInfo^ do\r\n  begin\r\n    FNameIndex := ObjName.NameIndex;\r\n    FSignature := ObjName.Signature;\r\n  end;\r\nend;\r\n\r\n{$IFDEF UNITVERSIONING}\r\ninitialization\r\n  RegisterUnitVersion(HInstance, UnitVersioning);\r\n\r\nfinalization\r\n  UnregisterUnitVersion(HInstance);\r\n{$ENDIF UNITVERSIONING}\r\n\r\nend.\r\n"
  },
  {
    "path": "MapDebugInfo.pas",
    "content": "unit MapDebugInfo;\r\n\r\ninterface\r\n\r\nuses System.Classes, System.SysUtils, DebugInfo, JclDebug, Windows, DelphiDebugInfo,\r\n  uFastList;\r\n\r\ntype\r\n  TMapScanner = class;\r\n\r\n  TUnitSegmentInfoList = class;\r\n\r\n  TMapDebugInfo = class(TDelphiDebugInfo)\r\n  private\r\n    FMapScanner: TMapScanner;\r\n    FUnitSegmentInfoList: TUnitSegmentInfoList;\r\n\r\n    procedure LoadSegmentClasses;\r\n\r\n    procedure LoadSegment(Segment: PJclMapSegment);\r\n    procedure LoadSource(Source: PJclMapProcName);\r\n    procedure LoadSegments;\r\n\r\n    procedure LoadProc(Proc: PJclMapProcName);\r\n    procedure LoadProcs;\r\n\r\n    procedure CalcFuncsSize;\r\n    procedure CalcLastFuncSize(FuncInfo: TFuncInfo);\r\n\r\n    function LoadLine(Line: PJclMapLineNumber): TLineInfo;\r\n    procedure LoadLines;\r\n\r\n    function FindSegmentByAddr(const Addr: Pointer; const SegmentID: Word = 0): TUnitSegmentInfo;\r\n    function FindFuncByAddr(const Addr: Pointer; const SegmentID: Word = 0): TFuncInfo; overload;\r\n    Function FindFuncByAddr(const UnitInfo: TUnitInfo; const Addr: Pointer): TFuncInfo; overload;\r\n    Function FindLineByAddr(const FuncInfo: TFuncInfo; const Addr: Pointer; const GetPrevLine: LongBool = False): TLineInfo;\r\n  Protected\r\n    Function DoReadDebugInfo(Const FileName: String; ALoadDebugInfo: LongBool): LongBool; Override;\r\n  public\r\n    Constructor Create;\r\n    Destructor Destroy; Override;\r\n\r\n    Procedure ClearDebugInfo; Override;\r\n\r\n    Function GetNameById(const Idx: TNameId): AnsiString; override;\r\n\r\n    Function HasDebugInfo(Const FileName: String): LongBool; override;\r\n\r\n    Function GetLineInfo(const Addr: Pointer; Var UnitInfo: TUnitInfo; Var FuncInfo: TFuncInfo; Var LineInfo: TLineInfo;\r\n      GetPrevLine: LongBool): TFindResult; override;\r\n\r\n    Function MakeFuncDbgFullName(Const ClassName, MethodName: AnsiString): AnsiString; override;\r\n    Function MakeFuncShortName(Const MethodName: AnsiString): AnsiString; override;\r\n    Function MakeFuncNativeName(Const MethodName: AnsiString): AnsiString; override;\r\n\r\n    function GetMemoryManager: TVarInfo; override;\r\n  end;\r\n\r\n  TJclMapSegmentClassHelper = record helper for TJclMapSegmentClass\r\n  public\r\n    function Name: String;\r\n    function SegmentType: TSegmentType;\r\n  end;\r\n\r\n  TJclMapSegmentHelper = record helper for TJclMapSegment\r\n  public\r\n    function ModuleName: String;\r\n    function Address: Pointer;\r\n    function Size: Cardinal;\r\n  end;\r\n\r\n  TJclMapProcNameHelper = record helper for TJclMapProcName\r\n  public\r\n    function Name: String;\r\n    function Address: Pointer;\r\n  end;\r\n\r\n  PJclMapStringCache = ^TJclMapStringCache;\r\n\r\n  TMapScanner = class(TJclAbstractMapParser)\r\n  strict private\r\n    FSegmentClasses: array of TJclMapSegmentClass;\r\n    FSegments: array of TJclMapSegment;\r\n    FSourceNames: array of TJclMapProcName;\r\n    FProcNames: array of TJclMapProcName;\r\n    FLineNumbers: array of TJclMapLineNumber;\r\n\r\n    FSegmentCnt: Integer;\r\n    FProcNamesCnt: Integer;\r\n    FLineNumbersCnt: Integer;\r\n\r\n    FLineNumberErrors: Integer; // ???\r\n\r\n    FNewUnitFileName: PJclMapString;\r\n\r\n    FTLSSegmentID: Word;\r\n\r\n    function GetSegment(const Index: Integer): PJclMapSegment; inline;\r\n    function GetProc(const Index: Integer): PJclMapProcName; inline;\r\n    function GetSegmentClassByID(const ID: Word): PJclMapSegmentClass;\r\n    function GetSegmentClass(const Index: Integer): PJclMapSegmentClass; inline;\r\n    function GetLineNumber(const Index: Integer): PJclMapLineNumber; inline;\r\n    function GetSource(const Index: Integer): PJclMapProcName; inline;\r\n  protected\r\n    //function MAPAddrToVA(const Addr: DWORD): DWORD;\r\n\r\n    procedure ClassTableItem(const Address: TJclMapAddress; Len: Integer; SectionName, GroupName: PJclMapString); override;\r\n    procedure SegmentItem(const Address: TJclMapAddress; Len: Integer; GroupName, UnitName: PJclMapString); override;\r\n    procedure PublicsByNameItem(const Address: TJclMapAddress; Name: PJclMapString); override;\r\n    procedure PublicsByValueItem(const Address: TJclMapAddress; Name: PJclMapString); override;\r\n    procedure LineNumbersItem(LineNumber: Integer; const Address: TJclMapAddress); override;\r\n    procedure LineNumberUnitItem(UnitName, UnitFileName: PJclMapString); override;\r\n\r\n    procedure Scan;\r\n  public\r\n    constructor Create(const MapFileName: TFileName; Module: HMODULE); override;\r\n\r\n    class function MapStringCacheToFileName(var MapString: TJclMapStringCache): string;\r\n    class function MapStringCacheToModuleName(var MapString: TJclMapStringCache): string;\r\n    class function MapStringCacheToStr(var MapString: TJclMapStringCache; IgnoreSpaces: LongBool = False): string;\r\n\r\n    function SegmentClassesCount: Integer; inline;\r\n    function SegmentsCount: Integer; inline;\r\n    function SourcesCount: Integer; inline;\r\n    function ProcsCount: Integer; inline;\r\n    function LineNumbersCount: Integer; inline;\r\n\r\n    property SegmentClassesByID[const ID: Word]: PJclMapSegmentClass read GetSegmentClassByID;\r\n    property SegmentClasses[const Index: Integer]: PJclMapSegmentClass read GetSegmentClass;\r\n    property Segments[const Index: Integer]: PJclMapSegment read GetSegment;\r\n    property Sources[const Index: Integer]: PJclMapProcName read GetSource;\r\n    property Procs[const Index: Integer]: PJclMapProcName read GetProc;\r\n    property LineNumbers[const Index: Integer]: PJclMapLineNumber read GetLineNumber;\r\n  end;\r\n\r\n  TUnitSegmentInfoList = class(TListSorted)\r\n  public\r\n    function Compare(Item1, Item2: Pointer; const aFindMode: LongBool): Integer; override;\r\n  end;\r\n\r\nimplementation\r\n\r\nuses\r\n  System.StrUtils, JclBase, JclPeImage, System.AnsiStrings, JclSysUtils,\r\n  JclTD32Ex;\r\n\r\n{ TMapDebugInfo }\r\n\r\nprocedure TMapDebugInfo.CalcFuncsSize;\r\nvar\r\n  I, J: Integer;\r\n  UnitInfo: TUnitInfo;\r\n  FuncInfo: TFuncInfo;\r\n  PrevFuncInfo: TFuncInfo;\r\nbegin\r\n  for I := 0 to Units.Count - 1 do\r\n  begin\r\n    UnitInfo := TUnitInfo(Units.Objects[I]);\r\n\r\n    PrevFuncInfo := Nil;\r\n    for J := 0 to UnitInfo.Funcs.Count - 1 do\r\n    begin\r\n      FuncInfo := TFuncInfo(UnitInfo.Funcs[J]);\r\n\r\n      if Assigned(PrevFuncInfo) then\r\n      begin\r\n        if (PrevFuncInfo.UnitSegment = FuncInfo.UnitSegment) then\r\n        begin\r\n          //    \r\n          PrevFuncInfo.Size := Cardinal(FuncInfo.Address) - Cardinal(PrevFuncInfo.Address)\r\n        end\r\n        else\r\n          CalcLastFuncSize(PrevFuncInfo);\r\n      end;\r\n\r\n      PrevFuncInfo := FuncInfo;\r\n    end;\r\n\r\n    if Assigned(PrevFuncInfo) then\r\n      CalcLastFuncSize(PrevFuncInfo);\r\n  end;\r\nend;\r\n\r\nprocedure TMapDebugInfo.CalcLastFuncSize(FuncInfo: TFuncInfo);\r\nbegin\r\n  FuncInfo.Size := FuncInfo.UnitSegment.Size - (Cardinal(FuncInfo.Address) - Cardinal(FuncInfo.UnitSegment.Address));\r\nend;\r\n\r\nprocedure TMapDebugInfo.ClearDebugInfo;\r\nbegin\r\n  inherited;\r\n  FUnitSegmentInfoList.Clear;\r\nend;\r\n\r\nconstructor TMapDebugInfo.Create;\r\nbegin\r\n  inherited;\r\n\r\n  FMapScanner := Nil;\r\n  FUnitSegmentInfoList := TUnitSegmentInfoList.Create;\r\nend;\r\n\r\ndestructor TMapDebugInfo.Destroy;\r\nbegin\r\n  FreeAndNil(FMapScanner);\r\n  FUnitSegmentInfoList.Free;\r\n\r\n  inherited;\r\nend;\r\n\r\nfunction TMapDebugInfo.DoReadDebugInfo(const FileName: String; ALoadDebugInfo: LongBool): LongBool;\r\nvar\r\n  MapFileName: String;\r\nbegin\r\n  Result := False;\r\n\r\n  if FileExists(FileName) then\r\n  begin\r\n    DoProgress('Prepare', 4);\r\n    if Assigned(FImage) then\r\n      FreeAndNil(FImage);\r\n\r\n    DoProgress('Init image', 5);\r\n    FImage := TJclPeBorTD32Image.Create(True);\r\n    DoProgress('Load image', 5);\r\n\r\n    FImage.FileName := GetDBGFileName(FileName);\r\n\r\n    DoProgress('Load debug info', 10);\r\n  end;\r\n\r\n  try\r\n    if ALoadDebugInfo then\r\n    begin\r\n      MapFileName := ChangeFileExt(FileName, '.map');\r\n\r\n      Result := FileExists(MapFileName);\r\n      if Result then\r\n      begin\r\n        FMapScanner := TMapScanner.Create(MapFileName);\r\n\r\n        FDebugInfoType := 'External(MAP)';\r\n\r\n        LoadSegmentClasses;\r\n\r\n        DoProgress('Load units info', 20);\r\n        LoadSegments;\r\n\r\n        DoProgress('Load methods info', 40);\r\n        LoadProcs;\r\n\r\n        DoProgress('Load lines info', 70);\r\n        LoadLines;\r\n\r\n        DoProgress('Debug info loaded', 99);\r\n      end;\r\n    end;\r\n  except\r\n    on E: Exception do\r\n    begin\r\n      FreeAndNil(FMapScanner);\r\n\r\n      raise;\r\n    end;\r\n  end;\r\nend;\r\n\r\nfunction TMapDebugInfo.FindFuncByAddr(const Addr: Pointer; const SegmentID: Word = 0): TFuncInfo;\r\nvar\r\n  Segment: TUnitSegmentInfo;\r\nbegin\r\n  Result := Nil;\r\n\r\n  Segment := FindSegmentByAddr(Addr, SegmentID);\r\n  if Assigned(Segment) then\r\n    Result := TFuncInfo(Segment.UnitInfo.FuncsByAddr.FindByAddress(Addr));\r\nend;\r\n\r\nfunction TMapDebugInfo.FindFuncByAddr(const UnitInfo: TUnitInfo; const Addr: Pointer): TFuncInfo;\r\nBegin\r\n  Result := TFuncInfo(UnitInfo.FuncsByAddr.FindByAddress(Addr));\r\nend;\r\n\r\nfunction TMapDebugInfo.FindLineByAddr(const FuncInfo: TFuncInfo; const Addr: Pointer; const GetPrevLine: LongBool): TLineInfo;\r\nVar\r\n  LineIdx: Integer;\r\nBegin\r\n  LineIdx := FuncInfo.Lines.Count - 1;\r\n\r\n  While (LineIdx >= 0) Do\r\n  Begin\r\n    Result := TLineInfo(FuncInfo.Lines[LineIdx]);\r\n    If Cardinal(Addr) >= Cardinal(Result.Address) Then\r\n    Begin\r\n      If GetPrevLine And (LineIdx > 0) Then\r\n        Result := TLineInfo(FuncInfo.Lines[LineIdx - 1]);\r\n\r\n      Exit;\r\n    End;\r\n    Dec(LineIdx);\r\n  End;\r\n\r\n  Result := Nil;\r\nend;\r\n\r\nfunction TMapDebugInfo.FindSegmentByAddr(const Addr: Pointer; const SegmentID: Word = 0): TUnitSegmentInfo;\r\nvar\r\n  I, j: Integer;\r\n  UnitInfo: TUnitInfo;\r\n  seg: TUnitSegmentInfo;\r\nBegin\r\n  //need to fill the fast sorted list the first time?\r\n  if FUnitSegmentInfoList.Count = 0 then\r\n  begin\r\n    for i := 0 to Units.Count - 1 do\r\n    begin\r\n      UnitInfo := TUnitInfo(Units.Objects[i]);\r\n      for j := 0 to UnitInfo.Segments.Count - 1 do\r\n      begin\r\n        seg := UnitInfo.Segments[j];\r\n        FUnitSegmentInfoList.Add(seg);\r\n      end;\r\n    end;\r\n  end;\r\n\r\n  //fast binary search\r\n  j := FUnitSegmentInfoList.FindObject(Addr);\r\n  if j >= 0 then\r\n  for i := j to FUnitSegmentInfoList.Count - 1 do\r\n  begin\r\n    if i > j + 5 then Break; //only search a limit number of items\r\n    seg := FUnitSegmentInfoList.Items[i];\r\n\r\n    if (SegmentID <> 0) and Assigned(seg.SegmentClassInfo) and (seg.SegmentClassInfo.ID <> SegmentID) then\r\n      Continue;\r\n    if (Cardinal(Addr) >= Cardinal(seg.Address)) and (Cardinal(Addr) < (Cardinal(seg.Address) + seg.Size)) then\r\n    begin\r\n      Result := seg;\r\n      Exit;\r\n    end;\r\n  end;\r\n\r\n  ///old slow linear search\r\n  for I := 0 to Units.Count - 1 do\r\n  begin\r\n    UnitInfo := TUnitInfo(Units.Objects[I]);\r\n\r\n    Result := UnitInfo.FindSegmentByAddr(Addr, SegmentID);\r\n    if Assigned(Result) then\r\n      Exit;\r\n  end;\r\n\r\n  Result := Nil;\r\nend;\r\n\r\nfunction TMapDebugInfo.GetLineInfo(const Addr: Pointer; var UnitInfo: TUnitInfo; var FuncInfo: TFuncInfo;\r\n  var LineInfo: TLineInfo; GetPrevLine: LongBool): TFindResult;\r\nvar\r\n  UnitSegmentInfo: TUnitSegmentInfo;\r\nbegin\r\n  Result := slNotFound;\r\n\r\n  UnitSegmentInfo := FindSegmentByAddr(Addr);\r\n  if Assigned(UnitSegmentInfo) and Assigned(UnitSegmentInfo.SegmentClassInfo) and (UnitSegmentInfo.SegmentClassInfo.SegType = ustCode) then\r\n  begin\r\n    UnitInfo := UnitSegmentInfo.UnitInfo;\r\n    FuncInfo := FindFuncByAddr(UnitInfo, Addr);\r\n    if Assigned(FuncInfo) then\r\n    begin\r\n      LineInfo := FindLineByAddr(FuncInfo, Addr, GetPrevLine);\r\n      if LineInfo = Nil then\r\n        Result := slFoundWithoutLine\r\n      else\r\n      begin\r\n        if LineInfo.Address = Addr then\r\n          Result := slFoundExact\r\n        else\r\n          Result := slFoundNotExact;\r\n      end;\r\n    end;\r\n  end;\r\nend;\r\n\r\nfunction TMapDebugInfo.GetMemoryManager: TVarInfo;\r\nconst\r\n  _MemoryManager = 'System.MemoryManager';\r\nVar\r\n  USystem: TUnitInfo;\r\nbegin\r\n  Result := Nil;\r\n\r\n  USystem := GetSystemUnit;\r\n  if Assigned(USystem) then\r\n  begin\r\n    Result := USystem.FindVarByName(_MemoryManager);\r\n  end;\r\nend;\r\n\r\nfunction TMapDebugInfo.GetNameById(const Idx: TNameId): AnsiString;\r\nvar\r\n  MapStringCache: PJclMapStringCache;\r\nbegin\r\n  MapStringCache := PJclMapStringCache(Pointer(Idx));\r\n\r\n  Result := AnsiString(TMapScanner.MapStringCacheToStr(MapStringCache^));\r\nend;\r\n\r\nfunction TMapDebugInfo.HasDebugInfo(const FileName: String): LongBool;\r\nbegin\r\n  Result := inherited HasDebugInfo(FileName) or\r\n    FileExists(ChangeFileExt(FileName, '.map'));\r\nend;\r\n\r\nfunction TMapDebugInfo.LoadLine(Line: PJclMapLineNumber): TLineInfo;\r\nvar\r\n  FuncInfo: TFuncInfo;\r\n  SegmentClassInfo: TSegmentClassInfo;\r\n  UnitSourceModuleInfo: TUnitSourceModuleInfo;\r\nbegin\r\n  Result := TLineInfo.Create;\r\n\r\n  SegmentClassInfo := GetSegmentByID(Line^.Segment);\r\n  Result.Address := Pointer(Cardinal(SegmentClassInfo.Address) + Line^.VA);\r\n\r\n  Result.LineNo := Line^.LineNumber;\r\n\r\n  FuncInfo := FindFuncByAddr(Result.Address, Line^.Segment);\r\n  if Assigned(FuncInfo) then\r\n  begin\r\n    FuncInfo.Lines.Add(Result);\r\n\r\n    UnitSourceModuleInfo := FuncInfo.UnitInfo.FindSourceSegmentByAddr(Result.Address);\r\n    if Assigned(UnitSourceModuleInfo) then\r\n    begin\r\n      Result.SrcSegment := UnitSourceModuleInfo;\r\n      UnitSourceModuleInfo.Lines.Add(Result);\r\n    end;\r\n\r\n    FuncInfo.UnitInfo.Lines.Add(Result);\r\n  end\r\n  else\r\n    FreeAndNil(Result); // TODO:\r\nend;\r\n\r\nprocedure TMapDebugInfo.LoadLines;\r\nvar\r\n  Idx: Integer;\r\nbegin\r\n  for Idx := 0 to FMapScanner.LineNumbersCount - 1 do\r\n    LoadLine(FMapScanner.LineNumbers[Idx]);\r\nend;\r\n\r\nprocedure TMapDebugInfo.LoadProc(Proc: PJclMapProcName);\r\nvar\r\n  UnitSegmentInfo: TUnitSegmentInfo;\r\n  SegmentClassInfo: TSegmentClassInfo;\r\n  ProcAddress: Pointer;\r\n\r\n  procedure LoadFuncInfo;\r\n  var\r\n    FuncInfo: TFuncInfo;\r\n  begin\r\n    FuncInfo := TFuncInfo.Create;\r\n\r\n    FuncInfo.NameId := Integer(@Proc^.ProcName);\r\n    FuncInfo.SymbolInfo := Nil;\r\n    FuncInfo.Address := ProcAddress;\r\n    FuncInfo.Size := 0;\r\n    FuncInfo.UnitInfo := UnitSegmentInfo.UnitInfo;\r\n    FuncInfo.UnitSegment := UnitSegmentInfo;\r\n    FuncInfo.ID := Nil;\r\n    FuncInfo.ParentID := Nil;\r\n\r\n    UnitSegmentInfo.UnitInfo.Funcs.Add(FuncInfo);\r\n    UnitSegmentInfo.UnitInfo.FuncsByAddr.Add(FuncInfo);\r\n  end;\r\n\r\n  procedure LoadVarInfo;\r\n  var\r\n    VarInfo: TVarInfo;\r\n  begin\r\n    VarInfo := TVarInfo.Create;\r\n\r\n    VarInfo.NameId := Integer(@Proc^.ProcName);\r\n    VarInfo.SymbolInfo := Nil;\r\n\r\n    if SegmentClassInfo.SegType = ustTLS then\r\n      VarInfo.VarKind := vkTLS\r\n    else\r\n      VarInfo.VarKind := vkGlobal;\r\n\r\n    VarInfo.Offset := Cardinal(ProcAddress);\r\n\r\n    UnitSegmentInfo.UnitInfo.Vars.Add(VarInfo);\r\n  end;\r\n\r\n  procedure LoadTypeInfo;\r\n  begin\r\n    // TODO:\r\n  end;\r\n\r\nbegin\r\n  SegmentClassInfo := GetSegmentByID(Proc^.Segment);\r\n\r\n  ProcAddress := Pointer(Cardinal(SegmentClassInfo.Address) + Cardinal(Proc^.Address));\r\n\r\n  UnitSegmentInfo := FindSegmentByAddr(ProcAddress, Proc^.Segment);\r\n\r\n  if Assigned(UnitSegmentInfo) then\r\n  begin\r\n    (*\r\n    UnitSourceModuleInfo := UnitSegmentInfo.UnitInfo.FindSourceSegmentByNameId(TNameId(@Proc^.ProcName));\r\n    if UnitSourceModuleInfo = Nil then\r\n    begin\r\n      UnitSourceModuleInfo := TUnitSourceModuleInfo.Create;\r\n\r\n      UnitSourceModuleInfo.NameId := TNameId(@Proc^.ProcName);\r\n      UnitSourceModuleInfo.SymbolInfo := Nil;\r\n      UnitSourceModuleInfo.UnitInfo := UnitSegmentInfo.UnitInfo;\r\n\r\n      UnitSegmentInfo.UnitInfo.SourceSegments.Add(UnitSourceModuleInfo);\r\n    end;\r\n    *)\r\n\r\n    case SegmentClassInfo.SegType of\r\n      ustCode:\r\n        LoadFuncInfo;\r\n      ustICode:\r\n        LoadTypeInfo;\r\n      ustData, ustBSS, ustTLS:\r\n        LoadVarInfo;\r\n    end;\r\n  end;\r\nend;\r\n\r\nprocedure TMapDebugInfo.LoadProcs;\r\nvar\r\n  Idx: Integer;\r\nbegin\r\n  for Idx := 0 to FMapScanner.ProcsCount - 1 do\r\n    LoadProc(FMapScanner.Procs[Idx]);\r\n\r\n  CalcFuncsSize;\r\nend;\r\n\r\nprocedure TMapDebugInfo.LoadSegments;\r\nvar\r\n  Idx: Integer;\r\nbegin\r\n  for Idx := 0 to FMapScanner.SegmentsCount - 1 do\r\n    LoadSegment(FMapScanner.Segments[Idx]);\r\n\r\n  for Idx := 0 to FMapScanner.SourcesCount - 1 do\r\n    LoadSource(FMapScanner.Sources[Idx]);\r\nend;\r\n\r\nprocedure TMapDebugInfo.LoadSource(Source: PJclMapProcName);\r\nvar\r\n  UnitSegmentInfo: TUnitSegmentInfo;\r\n  UnitSourceModuleInfo: TUnitSourceModuleInfo;\r\n  SegmentClassInfo: TSegmentClassInfo;\r\n  StartAddress: Pointer;\r\nbegin\r\n  SegmentClassInfo := GetSegmentByID(Source^.Segment);\r\n\r\n  StartAddress := Pointer(Cardinal(SegmentClassInfo.Address) + Source^.VA);\r\n\r\n  UnitSegmentInfo := FindSegmentByAddr(StartAddress, Source^.Segment);\r\n\r\n  if Assigned(UnitSegmentInfo) then\r\n  begin\r\n    UnitSourceModuleInfo := TUnitSourceModuleInfo.Create;\r\n\r\n    UnitSourceModuleInfo.NameId := TNameId(@Source^.ProcName);\r\n    UnitSourceModuleInfo.SymbolInfo := Nil;\r\n    UnitSourceModuleInfo.UnitInfo := UnitSegmentInfo.UnitInfo;\r\n    UnitSourceModuleInfo.Address := StartAddress;\r\n\r\n    UnitSourceModuleInfo.UnitInfo.SourceSegments.Add(UnitSourceModuleInfo);\r\n  end;\r\nend;\r\n\r\nfunction TMapDebugInfo.MakeFuncDbgFullName(const ClassName, MethodName: AnsiString): AnsiString;\r\nbegin\r\n  Result := ClassName + '.' + MethodName;\r\nend;\r\n\r\nfunction TMapDebugInfo.MakeFuncNativeName(const MethodName: AnsiString): AnsiString;\r\nbegin\r\n  Result := MethodName;\r\nend;\r\n\r\nfunction TMapDebugInfo.MakeFuncShortName(const MethodName: AnsiString): AnsiString;\r\nbegin\r\n  Result := MethodName;\r\nend;\r\n\r\nprocedure TMapDebugInfo.LoadSegment(Segment: PJclMapSegment);\r\nvar\r\n  Idx: Integer;\r\n  UnitInfo: TUnitInfo;\r\n  UnitSegmentInfo: TUnitSegmentInfo;\r\nbegin\r\n  UnitInfo := TUnitInfo.Create;\r\n  UnitInfo.NameId := Integer(@Segment^.UnitName);\r\n\r\n  Idx := Units.IndexOf(UnitInfo.ShortName);\r\n  if Idx < 0 then\r\n  begin\r\n    UnitInfo.SymbolInfo := Nil;\r\n    Units.AddObject(UnitInfo.ShortName, UnitInfo);\r\n  end\r\n  else\r\n  begin\r\n    FreeAndNil(UnitInfo);\r\n    UnitInfo := TUnitInfo(Units.Objects[Idx]);\r\n  end;\r\n\r\n  Inc(UnitInfo.Size, Segment^.Size);\r\n\r\n  UnitSegmentInfo := TUnitSegmentInfo.Create;\r\n  UnitSegmentInfo.UnitInfo := UnitInfo;\r\n\r\n  UnitSegmentInfo.SegmentClassInfo := GetSegmentByID(Segment^.Segment);\r\n  if Assigned(UnitSegmentInfo.SegmentClassInfo) then\r\n    UnitSegmentInfo.Address := Pointer(Cardinal(UnitSegmentInfo.SegmentClassInfo.Address) + Segment^.StartVA)\r\n  else\r\n    UnitSegmentInfo.Address := Pointer(Segment^.StartVA);\r\n\r\n  UnitSegmentInfo.Size := Segment^.Size;\r\n\r\n  if (UnitInfo.Address = Nil) and Assigned(UnitSegmentInfo.SegmentClassInfo) and\r\n    (UnitSegmentInfo.SegmentClassInfo.SegType in [ustCode, ustICode])\r\n  then\r\n    UnitInfo.Address := Pointer(UnitSegmentInfo.Address);\r\n\r\n  UnitInfo.Segments.Add(UnitSegmentInfo);\r\nend;\r\n\r\nprocedure TMapDebugInfo.LoadSegmentClasses;\r\nvar\r\n  Idx: Integer;\r\n  SegmentClass: PJclMapSegmentClass;\r\n  DbgSegmentClass: TSegmentClassInfo;\r\nbegin\r\n  for Idx := 0 to FMapScanner.SegmentClassesCount - 1 do\r\n  begin\r\n    SegmentClass := FMapScanner.SegmentClasses[Idx];\r\n\r\n    DbgSegmentClass := TSegmentClassInfo.Create;\r\n    DbgSegmentClass.Address := Pointer(SegmentClass^.Start);\r\n    DbgSegmentClass.Size := SegmentClass^.Len;\r\n    DbgSegmentClass.SegType := SegmentClass^.SegmentType;\r\n    DbgSegmentClass.ID := SegmentClass^.Segment;\r\n\r\n    Segments.AddObject(DbgSegmentClass.SegTypeName, DbgSegmentClass);\r\n  end;\r\nend;\r\n\r\n{ TMapScanner }\r\n\r\nprocedure TMapScanner.ClassTableItem(const Address: TJclMapAddress; Len: Integer; SectionName, GroupName: PJclMapString);\r\nvar\r\n  SegmentClass: PJclMapSegmentClass;\r\n  SectionHeader: PImageSectionHeader;\r\nbegin\r\n  SetLength(FSegmentClasses, Length(FSegmentClasses) + 1);\r\n\r\n  SegmentClass := @FSegmentClasses[High(FSegmentClasses)];\r\n\r\n  SegmentClass.Segment := Address.Segment;\r\n  SegmentClass.Start := Address.Offset;\r\n  SegmentClass.Addr := Address.Offset; // will be fixed below while considering module mapped address\r\n\r\n  // test GroupName because SectionName = '.tls' in Delphi and '_tls' in BCB\r\n  (*\r\n  if System.AnsiStrings.StrLIComp(GroupName, 'TLS', 3) = 0 then\r\n  begin\r\n    SegmentClass.VA := SegmentClass.Start;\r\n    FTLSSegmentID := SegmentClass.Segment;\r\n  end\r\n  else\r\n    SegmentClass.VA := MAPAddrToVA(SegmentClass.Start);\r\n  *)\r\n  SegmentClass.VA := SegmentClass.Start;\r\n\r\n  SegmentClass.Len := Len;\r\n  SegmentClass.SectionName.RawValue := SectionName;\r\n  SegmentClass.GroupName.RawValue := GroupName;\r\n\r\n  if FModule <> 0 then\r\n  begin\r\n    { Fix the section addresses }\r\n    SectionHeader := PeMapImgFindSectionFromModule(Pointer(FModule), MapStringToStr(SectionName));\r\n    if SectionHeader = nil then\r\n      { before Delphi 2005 the class names where used for the section names }\r\n      SectionHeader := PeMapImgFindSectionFromModule(Pointer(FModule), MapStringToStr(GroupName));\r\n\r\n    if SectionHeader <> nil then\r\n    begin\r\n      SegmentClass.Addr := TJclAddr(FModule) + SectionHeader.VirtualAddress;\r\n      SegmentClass.VA := SectionHeader.VirtualAddress;\r\n    end;\r\n  end;\r\nend;\r\n\r\nconstructor TMapScanner.Create(const MapFileName: TFileName;  Module: HMODULE);\r\nbegin\r\n  inherited;\r\n  FTLSSegmentID := 0;\r\n\r\n  Scan;\r\nend;\r\n\r\nfunction TMapScanner.GetLineNumber(const Index: Integer): PJclMapLineNumber;\r\nbegin\r\n  Result := @FLineNumbers[Index];\r\nend;\r\n\r\nfunction TMapScanner.GetProc(const Index: Integer): PJclMapProcName;\r\nbegin\r\n  Result := @FProcNames[Index];\r\nend;\r\n\r\nfunction TMapScanner.GetSegment(const Index: Integer): PJclMapSegment;\r\nbegin\r\n  Result := @FSegments[Index];\r\nend;\r\n\r\nfunction TMapScanner.GetSegmentClass(const Index: Integer): PJclMapSegmentClass;\r\nbegin\r\n  Result := @FSegmentClasses[Index];\r\nend;\r\n\r\nfunction TMapScanner.GetSegmentClassByID(const ID: Word): PJclMapSegmentClass;\r\nvar\r\n  Idx: Integer;\r\nbegin\r\n  for Idx := Low(FSegmentClasses) to High(FSegmentClasses) do\r\n  begin\r\n    Result := @FSegmentClasses[Idx];\r\n    if Result.Segment = ID then\r\n      Exit;\r\n  end;\r\n\r\n  Result := Nil;\r\nend;\r\n\r\nfunction TMapScanner.GetSource(const Index: Integer): PJclMapProcName;\r\nbegin\r\n  Result := @FSourceNames[Index];\r\nend;\r\n\r\nfunction TMapScanner.LineNumbersCount: Integer;\r\nbegin\r\n  Result := Length(FLineNumbers);\r\nend;\r\n\r\nprocedure TMapScanner.LineNumbersItem(LineNumber: Integer; const Address: TJclMapAddress);\r\nvar\r\n  SegmentClass: PJclMapSegmentClass;\r\n  MapLineNumber: PJclMapLineNumber;\r\n  MapSourceName: PJclMapProcName;\r\n  VA: DWORD;\r\n  Added: LongBool;\r\nbegin\r\n  Added := False;\r\n\r\n  SegmentClass := SegmentClassesByID[Address.Segment];\r\n\r\n  if Assigned(SegmentClass) {and (Address.Offset < SegmentClass.Len)} then\r\n  begin\r\n    (*\r\n    if SegmentClass.Segment = FTLSSegmentID then\r\n      VA := Address.Offset\r\n    else\r\n      VA := MAPAddrToVA(Address.Offset + SegmentClass.Start);\r\n    *)\r\n    VA := Address.Offset;\r\n\r\n    { Starting with Delphi 2005, \"empty\" units are listes with the last line and\r\n      the VA 0001:00000000. When we would accept 0 VAs here, System.pas functions\r\n      could be mapped to other units and line numbers. Discaring such items should\r\n      have no impact on the correct information, because there can't be a function\r\n      that starts at VA 0. }\r\n    if VA = 0 then\r\n      Exit;\r\n\r\n    if FLineNumbersCnt = Length(FLineNumbers)  then\r\n    begin\r\n      if FLineNumbersCnt < 512 then\r\n        SetLength(FLineNumbers, FLineNumbersCnt + 512)\r\n      else\r\n        SetLength(FLineNumbers, FLineNumbersCnt * 2);\r\n    end;\r\n\r\n    MapLineNumber := @FLineNumbers[FLineNumbersCnt];\r\n    MapLineNumber.Segment := SegmentClass.Segment;\r\n    MapLineNumber.VA := VA;\r\n    MapLineNumber.LineNumber := LineNumber;\r\n\r\n    Inc(FLineNumbersCnt);\r\n\r\n    Added := True;\r\n\r\n    if FNewUnitFileName <> nil then\r\n    begin\r\n      SetLength(FSourceNames, Length(FSourceNames) + 1);\r\n      MapSourceName := @FSourceNames[High(FSourceNames)];\r\n\r\n      MapSourceName.Segment := SegmentClass.Segment;\r\n      MapSourceName.VA := VA;\r\n      MapSourceName.ProcName.RawValue := FNewUnitFileName;\r\n\r\n      FNewUnitFileName := nil;\r\n    end;\r\n  end;\r\n\r\n  if not Added then\r\n    Inc(FLineNumberErrors);\r\nend;\r\n\r\nprocedure TMapScanner.LineNumberUnitItem(UnitName, UnitFileName: PJclMapString);\r\nbegin\r\n  FNewUnitFileName := UnitFileName;\r\nend;\r\n\r\n(*\r\nfunction TMapScanner.MAPAddrToVA(const Addr: DWORD): DWORD;\r\nbegin\r\n  // MAP file format was changed in Delphi 2005\r\n  // before Delphi 2005: segments started at offset 0\r\n  //                     only one segment of code\r\n  // after Delphi 2005: segments started at code base address (module base address + $10000)\r\n  //                    2 segments of code\r\n  if (Length(FSegmentClasses) > 0) and (FSegmentClasses[0].Start > 0) and (Addr >= FSegmentClasses[0].Start) then\r\n    // Delphi 2005 and later\r\n    // The first segment should be code starting at module base address + $10000\r\n    Result := Addr - FSegmentClasses[0].Start\r\n  else\r\n    // before Delphi 2005\r\n    Result := Addr;\r\nend;\r\n*)\r\n\r\nclass function TMapScanner.MapStringCacheToFileName(var MapString: TJclMapStringCache): string;\r\nbegin\r\n  Result := MapString.CachedValue;\r\n  if Result = '' then\r\n  begin\r\n    Result := MapStringToFileName(MapString.RawValue);\r\n    MapString.CachedValue := Result;\r\n  end;\r\nend;\r\n\r\nclass function TMapScanner.MapStringCacheToModuleName(var MapString: TJclMapStringCache): string;\r\nbegin\r\n  Result := MapString.CachedValue;\r\n  if Result = '' then\r\n  begin\r\n    Result := MapStringToModuleName(MapString.RawValue);\r\n    MapString.CachedValue := Result;\r\n  end;\r\nend;\r\n\r\nclass function TMapScanner.MapStringCacheToStr(var MapString: TJclMapStringCache; IgnoreSpaces: LongBool): string;\r\nbegin\r\n  Result := MapString.CachedValue;\r\n  if Result = '' then\r\n  begin\r\n    Result := MapStringToStr(MapString.RawValue, IgnoreSpaces);\r\n    MapString.CachedValue := Result;\r\n  end;\r\nend;\r\n\r\nfunction TMapScanner.ProcsCount: Integer;\r\nbegin\r\n  Result := Length(FProcNames);\r\nend;\r\n\r\nprocedure TMapScanner.PublicsByNameItem(const Address: TJclMapAddress; Name: PJclMapString);\r\nbegin\r\n  { TODO : What to do? }\r\nend;\r\n\r\nprocedure TMapScanner.PublicsByValueItem(const Address: TJclMapAddress; Name: PJclMapString);\r\nvar\r\n  SegmentClass: PJclMapSegmentClass;\r\n  ProcName: PJclMapProcName;\r\nbegin\r\n  SegmentClass := SegmentClassesByID[Address.Segment];\r\n\r\n  if Assigned(SegmentClass) and (Address.Offset < SegmentClass.Len) then\r\n  begin\r\n    if FProcNamesCnt = Length(FProcNames)  then\r\n    begin\r\n      if FProcNamesCnt < 512 then\r\n        SetLength(FProcNames, FProcNamesCnt + 512)\r\n      else\r\n        SetLength(FProcNames, FProcNamesCnt * 2);\r\n    end;\r\n\r\n    ProcName := @FProcNames[FProcNamesCnt];\r\n\r\n    ProcName.Segment := SegmentClass.Segment;\r\n\r\n    (*\r\n    if SegmentClass.Segment = FTLSSegmentID then\r\n      ProcName.VA := Address.Offset\r\n    else\r\n      ProcName.VA := MAPAddrToVA(Address.Offset + SegmentClass.Start);\r\n    *)\r\n    ProcName.VA := Address.Offset;\r\n\r\n    ProcName.ProcName.RawValue := Name;\r\n\r\n    Inc(FProcNamesCnt);\r\n  end;\r\nend;\r\n\r\nfunction Sort_MapLineNumber(Item1, Item2: Pointer): Integer;\r\nbegin\r\n  Result := Integer(PJclMapLineNumber(Item1)^.Segment) - Integer(PJclMapLineNumber(Item2)^.Segment);\r\n\r\n  if Result = 0 then\r\n    Result := Integer(PJclMapLineNumber(Item1)^.VA) - Integer(PJclMapLineNumber(Item2)^.VA);\r\nend;\r\n\r\nfunction Sort_MapProcName(Item1, Item2: Pointer): Integer;\r\nbegin\r\n  Result := Integer(PJclMapProcName(Item1)^.Segment) - Integer(PJclMapProcName(Item2)^.Segment);\r\n\r\n  if Result = 0 then\r\n    Result := Integer(PJclMapProcName(Item1)^.VA) - Integer(PJclMapProcName(Item2)^.VA);\r\nend;\r\n\r\nfunction Sort_MapSegment(Item1, Item2: Pointer): Integer;\r\nbegin\r\n  Result := Integer(PJclMapSegment(Item1)^.Segment) - Integer(PJclMapSegment(Item2)^.Segment);\r\n\r\n  if Result = 0 then\r\n    Result := Integer(PJclMapSegment(Item1)^.StartVA) - Integer(PJclMapSegment(Item2)^.StartVA);\r\nend;\r\n\r\nprocedure TMapScanner.Scan;\r\nbegin\r\n  FLineNumberErrors := 0;\r\n  FSegmentCnt := 0;\r\n  FProcNamesCnt := 0;\r\n\r\n  Parse;\r\n\r\n  SetLength(FLineNumbers, FLineNumbersCnt);\r\n  SetLength(FProcNames, FProcNamesCnt);\r\n  SetLength(FSegments, FSegmentCnt);\r\n\r\n  SortDynArray(FLineNumbers, SizeOf(FLineNumbers[0]), Sort_MapLineNumber);\r\n  SortDynArray(FProcNames, SizeOf(FProcNames[0]), Sort_MapProcName);\r\n  SortDynArray(FSegments, SizeOf(FSegments[0]), Sort_MapSegment);\r\n  SortDynArray(FSourceNames, SizeOf(FSourceNames[0]), Sort_MapProcName);\r\nend;\r\n\r\nfunction TMapScanner.SegmentClassesCount: Integer;\r\nbegin\r\n  Result := Length(FSegmentClasses);\r\nend;\r\n\r\nprocedure TMapScanner.SegmentItem(const Address: TJclMapAddress; Len: Integer; GroupName, UnitName: PJclMapString);\r\nvar\r\n  SegmentClass: PJclMapSegmentClass;\r\n  Segment: PJclMapSegment;\r\n  VA: DWORD;\r\nbegin\r\n  SegmentClass := SegmentClassesByID[Address.Segment];\r\n\r\n  if Assigned(SegmentClass) and (Address.Offset < SegmentClass.Len) then\r\n  begin\r\n    (*\r\n    if SegmentClass.Segment = FTLSSegmentID then\r\n      VA := Address.Offset\r\n    else\r\n      VA := MAPAddrToVA(Address.Offset + SegmentClass.Start);\r\n    *)\r\n    VA := Address.Offset;\r\n\r\n    if FSegmentCnt mod 16 = 0 then\r\n      SetLength(FSegments, FSegmentCnt + 16);\r\n\r\n    Segment := @FSegments[FSegmentCnt];\r\n    Segment.Segment := SegmentClass.Segment;\r\n    Segment.StartVA := VA;\r\n    Segment.EndVA := VA + DWORD(Len);\r\n    Segment.UnitName.RawValue := UnitName;\r\n\r\n    Inc(FSegmentCnt);\r\n  end;\r\nend;\r\n\r\nfunction TMapScanner.SegmentsCount: Integer;\r\nbegin\r\n  Result := Length(FSegments);\r\nend;\r\n\r\nfunction TMapScanner.SourcesCount: Integer;\r\nbegin\r\n  Result := Length(FSourceNames);\r\nend;\r\n\r\n{ TJclMapSegmentHelper }\r\n\r\nfunction TJclMapSegmentHelper.Address: Pointer;\r\nbegin\r\n  Result := Pointer(StartVA);\r\nend;\r\n\r\nfunction TJclMapSegmentHelper.ModuleName: String;\r\nbegin\r\n  Result := TMapScanner.MapStringCacheToModuleName(UnitName);\r\nend;\r\n\r\nfunction TJclMapSegmentHelper.Size: Cardinal;\r\nbegin\r\n  Result := EndVA - StartVA; // +1 ???\r\nend;\r\n\r\n{ TJclMapProcNameHelper }\r\n\r\nfunction TJclMapProcNameHelper.Address: Pointer;\r\nbegin\r\n  Result := Pointer(VA);\r\nend;\r\n\r\nfunction TJclMapProcNameHelper.Name: String;\r\nbegin\r\n  Result := TMapScanner.MapStringCacheToStr(ProcName);\r\nend;\r\n\r\n{ TJclMapSegmentClassHelper }\r\n\r\nfunction TJclMapSegmentClassHelper.Name: String;\r\nbegin\r\n  Result := TMapScanner.MapStringCacheToStr(SectionName);\r\nend;\r\n\r\nfunction TJclMapSegmentClassHelper.SegmentType: TSegmentType;\r\nbegin\r\n  Result := TSegmentClassInfo.StrToSegmentType(Name);\r\nend;\r\n\r\n{ TUnitSegmentInfoList }\r\n\r\nfunction TUnitSegmentInfoList.Compare(Item1, Item2: Pointer; const aFindMode: LongBool): Integer;\r\nvar\r\n  v1, v2: TUnitSegmentInfo;\r\nbegin\r\n  v1 := TUnitSegmentInfo(Item1);\r\n  v2 := TUnitSegmentInfo(Item2);\r\n  if aFindMode then //first item is a value, not an object!\r\n    Result := NativeUInt(Item1) - NativeUInt(v2.Address)\r\n  else\r\n    Result := NativeUInt(v1.Address) - NativeUInt(v2.Address);\r\nend;\r\n\r\nend.\r\n"
  },
  {
    "path": "Other/uMacroParser.pas",
    "content": "unit uMacroParser;\r\n\r\ninterface\r\n\r\nuses\r\n  Classes, SysUtils, StrUtils;\r\n\r\ntype\r\n  TMacroParser = class;\r\n  TMacroItem = class;\r\n\r\n  TMacroParams = class(TList)\r\n  private\r\n    function GetParam(const Index: Integer): TMacroItem;\r\n  public\r\n    constructor Create;\r\n    destructor Destroy; override;\r\n\r\n    procedure Clear; override;\r\n\r\n    property Params[const Index: Integer]: TMacroItem read GetParam; default;\r\n  end;\r\n\r\n  TMacroParserEvent = procedure(const FunName: String; Params: TMacroParams; var FunResult: String; var Done: Boolean) of object;\r\n\r\n  //      \r\n  TMacroItem = class\r\n  private\r\n    FMacroParser: TMacroParser;\r\n    FMacroStr: String;\r\n\r\n    FFunName: String; //  \r\n    FConst: String;\r\n    FParams: TMacroParams;\r\n\r\n    FErrPos: Integer;\r\n    FErrText: String;\r\n\r\n    procedure ClearParams;\r\n    function GetFunName(const Str: String): String;\r\n    function GetParamsStr(const Str: String): String;\r\n    function GetConst(const Str: String): String;\r\n  protected\r\n    procedure Execute(const FunName: String; Params: TMacroParams; var FunResult: String);\r\n\r\n    function BaseFun(const FunName: String; Params: TMacroParams; var FunResult: String): Boolean; virtual;\r\n\r\n    procedure RaiseException(const Msg: String); overload;\r\n    procedure RaiseException(const Msg: String; const Args: array of const); overload;\r\n  public\r\n    constructor Create(AOwner: TMacroParser);\r\n    destructor Destroy; override;\r\n\r\n    //  \r\n    function Parse(const Str: String): Boolean;\r\n\r\n    //   \r\n    function Calc: String;\r\n\r\n    property ErrPos: Integer read FErrPos;\r\n    property ErrText: String read FErrText;\r\n  end;\r\n\r\n  //     \r\n  TMacroParser = class\r\n  private\r\n    FMacroStr: String;\r\n    FRootItem: TMacroItem;\r\n    FOnCalcFun: TMacroParserEvent;\r\n\r\n    procedure SetMacroStr(const Value: String);\r\n    function GetErrText: String;\r\n  protected\r\n    function Parse(const Str: String = ''): Boolean; virtual;\r\n  public\r\n    constructor Create;\r\n    destructor Destroy; override;\r\n\r\n    //  \r\n    function Check(const Macro: String = ''): Boolean;\r\n\r\n    //   \r\n    function Calc(const Macro: String = ''): String;\r\n\r\n    property ErrText: String read GetErrText;\r\n  published\r\n    property MacroStr: String read FMacroStr write SetMacroStr;\r\n    property OnCalcFun: TMacroParserEvent read FOnCalcFun write FOnCalcFun;\r\n  end;\r\n\r\n  EMacroParser = class(Exception);\r\n\r\nimplementation\r\n\r\nconst\r\n  ERR_PARAM_COUNT = '  ';\r\n  RES_EMPTY = '{!EMPTY!}';\r\n  ERR_CALC_FUN = 'Unknown function: %s';\r\n  ERR_FUN_NAME = '  ';\r\n  ERR_PARAM_STR = '  ';\r\n  ERR_BRACKET = '     ';\r\n\r\nfunction _StrToBool(const Str: String): Boolean;\r\nbegin\r\n  Result := (Str = '1') or ((Str <> '') and (Str[1] = 'T'));\r\nend;\r\n\r\nfunction _IF(Params: TMacroParams; var FunResult: String): Boolean;\r\nvar\r\n  Condition: String;\r\nbegin\r\n  Result := False;\r\n\r\n  if Params.Count in [2, 3] then\r\n  begin\r\n    Condition := Params[0].Calc;\r\n\r\n    if _StrToBool(Condition) then\r\n      FunResult := Params[1].Calc\r\n    else\r\n      if Params.Count = 3 then\r\n        FunResult := Params[2].Calc;\r\n\r\n    Result := True;\r\n  end;\r\nend;\r\n\r\n{ TMacroItem }\r\n\r\nprocedure TMacroItem.Execute(const FunName: String; Params: TMacroParams; var FunResult: String);\r\nvar\r\n  Done: Boolean;\r\nbegin\r\n  FunResult := '';\r\n\r\n  if not BaseFun(FunName, Params, FunResult) then\r\n  begin\r\n    Done := False;\r\n\r\n    if Assigned(FMacroParser.OnCalcFun) then\r\n      FMacroParser.OnCalcFun(FunName, Params, FunResult, Done);\r\n\r\n    if not Done then\r\n      RaiseException(ERR_CALC_FUN, [FunName]);\r\n  end;\r\nend;\r\n\r\nfunction TMacroItem.BaseFun(const FunName: String; Params: TMacroParams; var FunResult: String): Boolean;\r\nbegin\r\n  Result := False;\r\n\r\n  // @(Fun1; Fun2; ...)\r\n  if FunName = '@' then\r\n    Result := True\r\n  else\r\n  if FunName = 'IF' then\r\n    Result := _IF(Params, FunResult)\r\nend;\r\n\r\nfunction TMacroItem.Calc: String;\r\nbegin\r\n  Result := '';\r\n\r\n  if FMacroStr <> '' then\r\n    if not Parse(FMacroStr) then\r\n      Exit;\r\n\r\n  if FFunName = '' then\r\n    Result := FConst\r\n  else\r\n    Execute(FFunName, FParams, Result);\r\nend;\r\n\r\nprocedure TMacroItem.ClearParams;\r\nbegin\r\n  FFunName := '';\r\n  FConst := '';\r\n\r\n  FParams.Clear;\r\nend;\r\n\r\nconstructor TMacroItem.Create(AOwner: TMacroParser);\r\nbegin\r\n  inherited Create;\r\n\r\n  FMacroParser := AOwner;\r\n\r\n  FFunName := '';\r\n  FConst := '';\r\n\r\n  FParams := TMacroParams.Create;\r\n\r\n  FErrPos := 0;\r\n  FErrText := '';\r\nend;\r\n\r\ndestructor TMacroItem.Destroy;\r\nbegin\r\n  ClearParams;\r\n  FreeAndNil(FParams);\r\n\r\n  inherited;\r\nend;\r\n\r\nfunction TMacroItem.GetConst(const Str: String): String;\r\nbegin\r\n  if (Str[1] in ['\"', '''']) and (Str[Length(Str)] in ['\"', '''']) then\r\n    Result := Copy(Str, 2, Length(Str) - 2)\r\n  else\r\n    Result := Str;\r\nend;\r\n\r\nfunction TMacroItem.GetFunName(const Str: String): String;\r\nvar\r\n  i: Integer;\r\nbegin\r\n  Result := '';\r\n\r\n  if (Str <> '') and not(Str[1] in ['\"', '''']) then\r\n  begin\r\n    i := Pos('(', Str);\r\n    if i > 0 then\r\n    begin\r\n      if i > 1 then\r\n      begin\r\n        //    \r\n        if Str[1] in ['0' .. '9'] then\r\n          RaiseException(ERR_FUN_NAME);\r\n\r\n        //     \r\n        i := 1;\r\n        while (Str[i] <> '(') do\r\n        begin\r\n          if not(Str[i] in ['a'..'z', 'A' .. 'Z', '0' .. '9', '_', '@']) then\r\n            RaiseException(ERR_FUN_NAME);\r\n\r\n          Inc(i);\r\n        end;\r\n\r\n        //   \r\n        if Str[i] = '(' then\r\n          Result := AnsiUpperCase(Copy(Str, 1, i - 1));\r\n      end\r\n      else\r\n        RaiseException(ERR_FUN_NAME);\r\n    end;\r\n  end;\r\nend;\r\n\r\nfunction TMacroItem.GetParamsStr(const Str: String): String;\r\nvar\r\n  i, j: Integer;\r\nbegin\r\n  Result := '';\r\n\r\n  //   \r\n  i := Pos('(', Str);\r\n\r\n  //    \r\n  j := Length(Str);\r\n  if Str[j] <> ')' then\r\n    raise Exception.Create(ERR_PARAM_STR);\r\n\r\n  //   \r\n  Result := Copy(Str, i + 1, j - i - 1);\r\nend;\r\n\r\nfunction TMacroItem.Parse(const Str: String): Boolean;\r\nvar\r\n  ParamsStr: String;\r\n  _Cur: Integer;\r\n\r\n  //   \r\n  function GetParam(var ResParam: String): Boolean;\r\n  var\r\n    _OldCur: Integer;\r\n    Level: Integer;\r\n  begin\r\n    Result := True;\r\n    ResParam := '';\r\n\r\n    _OldCur := _Cur;\r\n    Level := 0;\r\n\r\n    while (_Cur <= Length(ParamsStr)) and ((ParamsStr[_Cur] <> ';') or (Level > 0)) do\r\n    begin\r\n      case ParamsStr[_Cur] of\r\n        '\"':\r\n          _Cur := PosEx('\"', ParamsStr, _Cur + 1);\r\n        '''':\r\n          _Cur := PosEx('''', ParamsStr, _Cur + 1);\r\n        '(':\r\n          Inc(Level);\r\n        ')':\r\n          Dec(Level);\r\n      end;\r\n\r\n      Inc(_Cur);\r\n    end;\r\n\r\n    if Level = 0 then\r\n    begin\r\n      if _OldCur <> _Cur then\r\n      begin\r\n        ResParam := Copy(ParamsStr, _OldCur, _Cur - _OldCur);\r\n        Inc(_Cur);\r\n      end\r\n      else\r\n        Result := False;\r\n    end\r\n    else\r\n    begin\r\n      //  \r\n      RaiseException(ERR_BRACKET);\r\n    end;\r\n  end;\r\n\r\nvar\r\n  _CurParam: String;\r\n  _ChildItem: TMacroItem;\r\nbegin\r\n  Result := False;\r\n\r\n  ClearParams;\r\n\r\n  //     \r\n  FMacroStr := Trim(Str);\r\n\r\n  //  \r\n  FFunName := GetFunName(FMacroStr);\r\n  if FFunName <> '' then\r\n  begin\r\n    //   \r\n    ParamsStr := GetParamsStr(FMacroStr);\r\n\r\n    _Cur := 1;\r\n    try\r\n      while Result and GetParam(_CurParam) do\r\n      begin\r\n        _ChildItem := TMacroItem.Create(FMacroParser);\r\n        FParams.Add(_ChildItem);\r\n\r\n        Result := _ChildItem.Parse(_CurParam);\r\n        if not Result then\r\n        begin\r\n          //  \r\n          FErrPos := Pos('(', FMacroStr) + _ChildItem.ErrPos;\r\n          FErrText := _ChildItem.ErrText;\r\n        end;\r\n      end;\r\n    except\r\n      on E: Exception do\r\n      begin\r\n        //  \r\n        FErrPos := Pos('(', FMacroStr) + _Cur;\r\n        FErrText := E.Message;\r\n      end;\r\n    end;\r\n\r\n    if not Result then\r\n      ClearParams;\r\n  end\r\n  else\r\n  begin\r\n    // \r\n    FConst := GetConst(FMacroStr);\r\n    Result := True;\r\n  end;\r\nend;\r\n\r\nprocedure TMacroItem.RaiseException(const Msg: String; const Args: array of const);\r\nbegin\r\n  raise EMacroParser.CreateFmt(Msg, Args);\r\nend;\r\n\r\nprocedure TMacroItem.RaiseException(const Msg: String);\r\nbegin\r\n  raise EMacroParser.Create(Msg);\r\nend;\r\n\r\n{ TMacroParser }\r\n\r\nfunction TMacroParser.Calc(const Macro: String): String;\r\nbegin\r\n  Result := '';\r\n\r\n  if Parse(Trim(Macro)) then\r\n    Result := FRootItem.Calc;\r\nend;\r\n\r\nfunction TMacroParser.Check(const Macro: String): Boolean;\r\nbegin\r\n  Result := Parse(Macro);\r\nend;\r\n\r\nconstructor TMacroParser.Create;\r\nbegin\r\n  inherited Create;\r\n\r\n  FRootItem := TMacroItem.Create(Self);\r\nend;\r\n\r\ndestructor TMacroParser.Destroy;\r\nbegin\r\n  FreeAndNil(FRootItem);\r\n\r\n  inherited;\r\nend;\r\n\r\nfunction TMacroParser.GetErrText: String;\r\nbegin\r\n  Result := '';\r\n\r\n  if Assigned(FRootItem) and (FRootItem.ErrPos > 0) then\r\n  begin\r\n    Result := Format('Syntax error [%d]: %s', [FRootItem.ErrPos, FRootItem.ErrText]);\r\n  end;\r\nend;\r\n\r\nfunction TMacroParser.Parse(const Str: String): Boolean;\r\nbegin\r\n  Result := FRootItem.Parse(Str);\r\nend;\r\n\r\nprocedure TMacroParser.SetMacroStr(const Value: String);\r\nbegin\r\n  FMacroStr := Value;\r\n  Parse(FMacroStr);\r\nend;\r\n\r\n{ TMacroParams }\r\n\r\nprocedure TMacroParams.Clear;\r\nvar\r\n  i: Integer;\r\n  Obj: TObject;\r\nbegin\r\n  for i := 0 to Count - 1 do\r\n  begin\r\n    Obj := Items[i];\r\n    Items[i] := Nil;\r\n    FreeAndNil(Obj);\r\n  end;\r\n\r\n  inherited Clear;\r\nend;\r\n\r\nconstructor TMacroParams.Create;\r\nbegin\r\n  inherited Create;\r\nend;\r\n\r\ndestructor TMacroParams.Destroy;\r\nbegin\r\n\r\n  inherited;\r\nend;\r\n\r\nfunction TMacroParams.GetParam(const Index: Integer): TMacroItem;\r\nbegin\r\n  Result := TMacroItem(Items[Index]);\r\nend;\r\n\r\nend.\r\n"
  },
  {
    "path": "Readme.md",
    "content": "# Spider - Delphi profiler \n\nReal time profiler for Delphi applications:\n* Detailed debug information (internal, TDS, MAP)\n* Display information for multi-threaded applications\n* Timeline diagram for process execute\n* Analysis of exceptions\n* Analysis of the realtime use of memory\n* Analysis of memory leaks\n* Analysis of the call stack\n* Analysis of run-time functions (code tracking)\n* Analysis of the \"deadlocks\" (Sleep, CriticalSection, SendMessage, etc.)\n* The ability to view the source code in the analysis of events\n\nMore information can be found on the project's website: http://dbg-spider.net\n\n## Fork Notes\n\nThis fork contains portions of (hash) code from the DWScript repository (https://bitbucket.org/egrange/dwscript) which is copyright by Eric Grange.\n\nSince the license for the this project has not been specified by the original author, it might not be compatible when specified."
  },
  {
    "path": "Spider.dpr",
    "content": "program Spider;\r\n\r\nuses\r\n  Vcl.Themes,\r\n  Vcl.Styles,\r\n  Forms,\r\n  uMain in 'uMain.pas' {MainForm},\r\n  Debuger in 'Debuger.pas',\r\n  DebugInfo in 'DebugInfo.pas',\r\n  ClassUtils in 'ClassUtils.pas',\r\n  DelphiDebugInfo in 'DelphiDebugInfo.pas',\r\n  uProcessList in 'uProcessList.pas' {frmProcessList},\r\n  JclTD32Ex in 'JclTD32Ex.pas',\r\n  DebugHook in 'DebugHook.pas',\r\n  DbgHookTypes in 'DbgHookTypes.pas',\r\n  DebugerTypes in 'DebugerTypes.pas',\r\n  uActionController in 'uActionController.pas',\r\n  uDebugerThread in 'uDebugerThread.pas',\r\n  uProjectOptions in 'uProjectOptions.pas' {fmProjectOptions},\r\n  uSpiderOptions in 'uSpiderOptions.pas',\r\n  uShareData in 'uShareData.pas' {dmShareData: TDataModule},\r\n  uSelectSource in 'uSelectSource.pas' {fmSelectSource},\r\n  WinAPIUtils in 'WinAPIUtils.pas',\r\n  Collections.Bags in 'Collections\\Collections.Bags.pas',\r\n  Collections.Base in 'Collections\\Collections.Base.pas',\r\n  Collections.BidiDictionaries in 'Collections\\Collections.BidiDictionaries.pas',\r\n  Collections.BidiMaps in 'Collections\\Collections.BidiMaps.pas',\r\n  Collections.Dictionaries in 'Collections\\Collections.Dictionaries.pas',\r\n  Collections.Dynamic in 'Collections\\Collections.Dynamic.pas',\r\n  Collections.Lists in 'Collections\\Collections.Lists.pas',\r\n  Collections.MultiMaps in 'Collections\\Collections.MultiMaps.pas',\r\n  Collections.Queues in 'Collections\\Collections.Queues.pas',\r\n  Collections.Serialization in 'Collections\\Collections.Serialization.pas',\r\n  Collections.Sets in 'Collections\\Collections.Sets.pas',\r\n  Collections.Stacks in 'Collections\\Collections.Stacks.pas',\r\n  uGA in 'uGA.pas',\r\n  uUpdateInfo in 'uUpdateInfo.pas',\r\n  uFeedback in 'uFeedback.pas' {frmFeedback},\r\n  GdiPlus in 'GdiPlus\\GdiPlus.pas',\r\n  GdiPlusHelpers in 'GdiPlus\\GdiPlusHelpers.pas',\r\n  uExceptionHook in 'uExceptionHook.pas',\r\n  uRWLock in 'uRWLock.pas',\r\n  uSourceViewFrame in 'uSourceViewFrame.pas' {SourceViewFrame: TFrame},\r\n  CollectList in 'CollectList.pas',\r\n  MapDebugInfo in 'MapDebugInfo.pas',\r\n  JclPeImage in 'JclPeImage.pas',\r\n  uSharedObject in 'uSharedObject.pas',\r\n  uSQLiteDB in 'uSQLiteDB.pas',\r\n  DbgMemoryProfiler in 'DbgMemoryProfiler.pas',\r\n  DbgWorkerThread in 'DbgWorkerThread.pas',\r\n  DbgSyncObjsProfiler in 'DbgSyncObjsProfiler.pas',\r\n  DbgSamplingProfiler in 'DbgSamplingProfiler.pas',\r\n  DbgCodeProfiler in 'DbgCodeProfiler.pas';\r\n\r\n{$R *.res}\r\n\r\nbegin\r\n  Application.Initialize;\r\n  TStyleManager.TrySetStyle('Silver');\r\n  Application.MainFormOnTaskbar := True;\r\n  Application.Title := 'Spider';\r\n  Application.CreateForm(TdmShareData, dmShareData);\r\n  Application.CreateForm(TMainForm, MainForm);\r\n  Application.Run;\r\nend.\r\n"
  },
  {
    "path": "Spider.dproj",
    "content": "\r\n    \r\n        {99256B98-0F1D-4707-BC25-85850B6A52B7}\r\n        14.6\r\n        Spider.dpr\r\n        Release\r\n        DCC32\r\n        VCL\r\n        True\r\n        Win32\r\n        1\r\n        Application\r\n    \r\n    \r\n        true\r\n    \r\n    \r\n        true\r\n        Base\r\n        true\r\n    \r\n    \r\n        true\r\n        Base\r\n        true\r\n    \r\n    \r\n        true\r\n        Cfg_2\r\n        true\r\n        true\r\n    \r\n    \r\n        3\r\n        SUPPORTS_INLINE;$(DCC_Define)\r\n        true\r\n        9\r\n        false\r\n        false\r\n        Spider_Icon.ico\r\n        "Silver|VCLSTYLE|$(PUBLIC)\\Documents\\RAD Studio\\11.0\\Styles\\Silver.vsf"\r\n        $(BDS)\\bin\\default_app.manifest\r\n        vclx;vcl;vclimg;dbrtl;Rave77VCL;bdertl;rtl;vclactnband;vcldb;vcldbx;vcltouch;xmlrtl;dsnap;dsnapcon;TeeUI;Tee;TeeDB;vclib;ibxpress;adortl;IndyCore;IndySystem;IndyProtocols;inet;intrawebdb_100_140;Intraweb_100_140;VclSmp;vclie;websnap;webdsnap;inetdb;inetdbbde;inetdbxpress;soaprtl;vclribbon;dbexpress;DbxCommonDriver;DataSnapIndy10ServerTransport;DataSnapProviderClient;DataSnapServer;DbxClientDriver;DBXInterBaseDriver;DBXMySQLDriver;dbxcds;DBXFirebirdDriver;DBXSybaseASEDriver;DBXSybaseASADriver;DBXOracleDriver;DBXMSSQLDriver;DBXInformixDriver;DBXDb2Driver;GanttPackage;VirtualTreesR;JclDeveloperTools;Jcl;JclVcl;JclContainers;JvCore;JvSystem;JvStdCtrls;JvAppFrm;JvBands;JvDB;JvDlgs;JvBDE;JvControls;JvCmp;JvCrypt;JvCustom;JvDocking;JvDotNetCtrls;JvGlobus;JvHMI;JvJans;JvManagedThreads;JvMM;JvNet;JvPageComps;JvPascalInterpreter;JvPluginSystem;JvPrintPreview;JvRuntimeDesign;JvTimeFramework;JvWizards;JvXPCtrls;acnt2010_R;$(DCC_UsePackage)\r\n        CompanyName=;FileDescription=;FileVersion=1.3.9.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=Spider;ProductVersion=1.3;Comments=\r\n        Vcl;Vcl.Imaging;Vcl.Touch;Vcl.Samples;Vcl.Shell;System;Xml;Data;Datasnap;Web;Soap;Winapi;System.Bindings;$(DCC_Namespace)\r\n        1033\r\n        C:\\Projects\\Spider\\JCL\\source\\common;C:\\Projects\\Spider\\JCL\\source\\include;C:\\Projects\\Spider\\JCL\\source\\include\\jedi;C:\\Projects\\Spider\\JCL\\source\\windows;C:\\Projects\\Spider\\JCL\\source;$(BRCC_IncludePath)\r\n        dcu\r\n        Spider.exe\r\n        false\r\n        false\r\n        00400000\r\n        x86\r\n        false\r\n        false\r\n        false\r\n    \r\n    \r\n        3\r\n        true\r\n        true\r\n        RELEASE;$(DCC_Define)\r\n    \r\n    \r\n        3\r\n        true\r\n        true\r\n        DEBUG;$(DCC_Define)\r\n    \r\n    \r\n        true\r\n        true\r\n        ..\\dbg-spider_\\Spider_Icon.ico\r\n    \r\n    \r\n        \r\n            MainSource\r\n        \r\n        \r\n            
    MainForm
    \r\n        \r\n        \r\n        \r\n        \r\n        \r\n        \r\n            
    frmProcessList
    \r\n            \r\n        \r\n        \r\n        \r\n        \r\n        \r\n        \r\n        \r\n            
    fmProjectOptions
    \r\n            \r\n        \r\n        \r\n            
    dmShareData
    \r\n            TDataModule\r\n            \r\n        \r\n            
    fmSelectSource
    \r\n            \r\n        \r\n        \r\n        \r\n        \r\n        \r\n        \r\n        \r\n        \r\n        \r\n        \r\n        \r\n        \r\n        \r\n        \r\n        \r\n        \r\n            
    frmFeedback
    \r\n            dfm\r\n            \r\n        \r\n        \r\n        \r\n        \r\n        \r\n            
    SourceViewFrame
    \r\n            dfm\r\n            TFrame\r\n            \r\n        \r\n        \r\n        \r\n        \r\n        \r\n        \r\n        \r\n        \r\n        \r\n        \r\n        \r\n            Cfg_2\r\n            Base\r\n        \r\n        \r\n            Base\r\n        \r\n        \r\n            Cfg_1\r\n            Base\r\n        \r\n    \r\n    \r\n    \r\n        Delphi.Personality.12\r\n        \r\n        \r\n            \r\n                \r\n                    Spider.dpr\r\n                \r\n                \r\n                    False\r\n                    True\r\n                    False\r\n                \r\n                \r\n                    True\r\n                    True\r\n                    0\r\n                    1\r\n                    1\r\n                    346\r\n                    False\r\n                    False\r\n                    False\r\n                    False\r\n                    False\r\n                    1033\r\n                    1252\r\n                \r\n                \r\n                    \r\n                    \r\n                    0.1.1.346\r\n                    \r\n                    \r\n                    \r\n                    \r\n                    \r\n                    1.0.0.0\r\n                    \r\n                \r\n                \r\n                    Microsoft Office 2000 Sample Automation Server Wrapper Components\r\n                    Microsoft Office XP Sample Automation Server Wrapper Components\r\n                \r\n            \r\n            \r\n                True\r\n                False\r\n            \r\n        \r\n        12\r\n    \r\n    \r\n\r\n"
  },
  {
    "path": "SpiderXE6.dpr",
    "content": "program SpiderXE6;\r\n\r\nuses\r\n  Vcl.Themes,\r\n  Vcl.Styles,\r\n  Forms,\r\n  uMain in 'uMain.pas' {MainForm},\r\n  Debuger in 'Debuger.pas',\r\n  DebugInfo in 'DebugInfo.pas',\r\n  ClassUtils in 'ClassUtils.pas',\r\n  DelphiDebugInfo in 'DelphiDebugInfo.pas',\r\n  uProcessList in 'uProcessList.pas' {frmProcessList},\r\n  JclTD32Ex in 'JclTD32Ex.pas',\r\n  DebugHook in 'DebugHook.pas',\r\n  DbgHookTypes in 'DbgHookTypes.pas',\r\n  DebugerTypes in 'DebugerTypes.pas',\r\n  uActionController in 'uActionController.pas',\r\n  uDebugerThread in 'uDebugerThread.pas',\r\n  uProjectOptions in 'uProjectOptions.pas' {fmProjectOptions},\r\n  uSpiderOptions in 'uSpiderOptions.pas',\r\n  uShareData in 'uShareData.pas' {dmShareData: TDataModule},\r\n  uSelectSource in 'uSelectSource.pas' {fmSelectSource},\r\n  WinAPIUtils in 'WinAPIUtils.pas',\r\n  Collections.Bags in 'Collections\\Collections.Bags.pas',\r\n  Collections.Base in 'Collections\\Collections.Base.pas',\r\n  Collections.BidiDictionaries in 'Collections\\Collections.BidiDictionaries.pas',\r\n  Collections.BidiMaps in 'Collections\\Collections.BidiMaps.pas',\r\n  Collections.Dictionaries in 'Collections\\Collections.Dictionaries.pas',\r\n  Collections.Dynamic in 'Collections\\Collections.Dynamic.pas',\r\n  Collections.Lists in 'Collections\\Collections.Lists.pas',\r\n  Collections.MultiMaps in 'Collections\\Collections.MultiMaps.pas',\r\n  Collections.Queues in 'Collections\\Collections.Queues.pas',\r\n  Collections.Serialization in 'Collections\\Collections.Serialization.pas',\r\n  Collections.Sets in 'Collections\\Collections.Sets.pas',\r\n  Collections.Stacks in 'Collections\\Collections.Stacks.pas',\r\n  uGA in 'uGA.pas',\r\n  uUpdateInfo in 'uUpdateInfo.pas',\r\n  uFeedback in 'uFeedback.pas' {frmFeedback},\r\n  GdiPlus in 'GdiPlus\\GdiPlus.pas',\r\n  GdiPlusHelpers in 'GdiPlus\\GdiPlusHelpers.pas',\r\n  uExceptionHook in 'uExceptionHook.pas',\r\n  uRWLock in 'uRWLock.pas',\r\n  uSourceViewFrame in 'uSourceViewFrame.pas' {SourceViewFrame: TFrame},\r\n  CollectList in 'CollectList.pas',\r\n  MapDebugInfo in 'MapDebugInfo.pas',\r\n  JclPeImage in 'JclPeImage.pas',\r\n  uSharedObject in 'uSharedObject.pas',\r\n  uSQLiteDB in 'uSQLiteDB.pas',\r\n  DbgMemoryProfiler in 'DbgMemoryProfiler.pas',\r\n  DbgWorkerThread in 'DbgWorkerThread.pas',\r\n  DbgSyncObjsProfiler in 'DbgSyncObjsProfiler.pas',\r\n  DbgSamplingProfiler in 'DbgSamplingProfiler.pas',\r\n  DbgCodeProfiler in 'DbgCodeProfiler.pas',\r\n  KOLDetours in 'External\\KOLDetours.pas',\r\n  uFastList in 'uFastList.pas';\r\n\r\n{$R *.res}\r\n\r\nbegin\r\n  Application.Initialize;\r\n  TStyleManager.TrySetStyle('Silver');\r\n  Application.MainFormOnTaskbar := True;\r\n  Application.Title := 'Spider';\r\n  Application.CreateForm(TdmShareData, dmShareData);\r\n  Application.CreateForm(TMainForm, MainForm);\r\n  Application.Run;\r\nend.\r\n"
  },
  {
    "path": "SpiderXE6.dproj",
    "content": "\r\n    \r\n        {99256B98-0F1D-4707-BC25-85850B6A52B7}\r\n        15.4\r\n        SpiderXE6.dpr\r\n        Release\r\n        DCC32\r\n        VCL\r\n        True\r\n        Win32\r\n        1\r\n        Application\r\n    \r\n    \r\n        true\r\n    \r\n    \r\n        true\r\n        Base\r\n        true\r\n    \r\n    \r\n        true\r\n        Base\r\n        true\r\n    \r\n    \r\n        true\r\n        Cfg_2\r\n        true\r\n        true\r\n    \r\n    \r\n        SpiderXE6\r\n        .\\External\\SynEdit\\Source\\;.\\External\\VirtualTreeView\\Source\\;.\\External\\Jedi\\jvcl\\run\\;.\\External\\Jedi\\jvcl\\common\\;.\\External\\Jedi\\jvcl\\resources\\;.\\External\\Jedi\\Jvcl\\common\\jedi;.\\External\\Jedi\\Jvcl\\run;.\\External\\Jedi\\Jcl\\source\\include\\;.\\External\\Jedi\\Jcl\\source\\common\\;.\\External\\Jedi\\Jcl\\source\\windows\\;$(DCC_UnitSearchPath)\r\n        .\\bin\r\n        3\r\n        3\r\n        SUPPORTS_INLINE;$(DCC_Define)\r\n        true\r\n        9\r\n        false\r\n        false\r\n        Silver|VCLSTYLE|$(PUBLIC)\\Documents\\Embarcadero\\Studio\\14.0\\Styles\\Silver.vsf\r\n        $(BDS)\\bin\\default_app.manifest\r\n        vclx;vcl;vclimg;dbrtl;Rave77VCL;bdertl;rtl;vclactnband;vcldb;vcldbx;vcltouch;xmlrtl;dsnap;dsnapcon;TeeUI;Tee;TeeDB;vclib;ibxpress;adortl;IndyCore;IndySystem;IndyProtocols;inet;intrawebdb_100_140;Intraweb_100_140;VclSmp;vclie;websnap;webdsnap;inetdb;inetdbbde;inetdbxpress;soaprtl;vclribbon;dbexpress;DbxCommonDriver;DataSnapIndy10ServerTransport;DataSnapProviderClient;DataSnapServer;DbxClientDriver;DBXInterBaseDriver;DBXMySQLDriver;dbxcds;DBXFirebirdDriver;DBXSybaseASEDriver;DBXSybaseASADriver;DBXOracleDriver;DBXMSSQLDriver;DBXInformixDriver;DBXDb2Driver;GanttPackage;VirtualTreesR;JclDeveloperTools;Jcl;JclVcl;JclContainers;JvCore;JvSystem;JvStdCtrls;JvAppFrm;JvBands;JvDB;JvDlgs;JvBDE;JvControls;JvCmp;JvCrypt;JvCustom;JvDocking;JvDotNetCtrls;JvGlobus;JvHMI;JvJans;JvManagedThreads;JvMM;JvNet;JvPageComps;JvPascalInterpreter;JvPluginSystem;JvPrintPreview;JvRuntimeDesign;JvTimeFramework;JvWizards;JvXPCtrls;acnt2010_R;$(DCC_UsePackage)\r\n        CompanyName=;FileDescription=;FileVersion=1.3.9.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=Spider;ProductVersion=1.3;Comments=\r\n        Vcl;Vcl.Imaging;Vcl.Touch;Vcl.Samples;Vcl.Shell;System;Xml;Data;Datasnap;Web;Soap;Winapi;System.Bindings;system.win;$(DCC_Namespace)\r\n        1033\r\n        C:\\Projects\\Spider\\JCL\\source\\common;C:\\Projects\\Spider\\JCL\\source\\include;C:\\Projects\\Spider\\JCL\\source\\include\\jedi;C:\\Projects\\Spider\\JCL\\source\\windows;C:\\Projects\\Spider\\JCL\\source;$(BRCC_IncludePath)\r\n        .\\dcu\r\n        Spider.exe\r\n        false\r\n        false\r\n        00400000\r\n        x86\r\n        false\r\n        false\r\n        false\r\n    \r\n    \r\n        3\r\n        true\r\n        true\r\n        RELEASE;$(DCC_Define)\r\n    \r\n    \r\n        true\r\n        3\r\n        true\r\n        true\r\n        DEBUG;$(DCC_Define)\r\n    \r\n    \r\n        true\r\n        true\r\n        false\r\n        true\r\n    \r\n    \r\n        \r\n            MainSource\r\n        \r\n        \r\n            
    MainForm
    \r\n            \r\n        \r\n        \r\n        \r\n        \r\n        \r\n            
    frmProcessList
    \r\n            \r\n        \r\n        \r\n        \r\n        \r\n        \r\n        \r\n        \r\n            
    fmProjectOptions
    \r\n            \r\n        \r\n        \r\n            
    dmShareData
    \r\n            TDataModule\r\n            \r\n        \r\n            
    fmSelectSource
    \r\n            \r\n        \r\n        \r\n        \r\n        \r\n        \r\n        \r\n        \r\n        \r\n        \r\n        \r\n        \r\n        \r\n        \r\n        \r\n        \r\n        \r\n            
    frmFeedback
    \r\n            dfm\r\n            \r\n        \r\n        \r\n        \r\n        \r\n        \r\n            
    SourceViewFrame
    \r\n            dfm\r\n            TFrame\r\n            \r\n        \r\n        \r\n        \r\n        \r\n        \r\n        \r\n        \r\n        \r\n        \r\n        \r\n        \r\n        \r\n        \r\n            Cfg_2\r\n            Base\r\n        \r\n        \r\n            Base\r\n        \r\n        \r\n            Cfg_1\r\n            Base\r\n        \r\n        \r\n    \r\n    \r\n        Delphi.Personality.12\r\n        \r\n        \r\n            \r\n                \r\n                    SpiderXE6.dpr\r\n                \r\n                \r\n                    False\r\n                    True\r\n                    False\r\n                \r\n                \r\n                    True\r\n                    True\r\n                    0\r\n                    1\r\n                    1\r\n                    346\r\n                    False\r\n                    False\r\n                    False\r\n                    False\r\n                    False\r\n                    1033\r\n                    1252\r\n                \r\n                \r\n                    \r\n                    \r\n                    0.1.1.346\r\n                    \r\n                    \r\n                    \r\n                    \r\n                    \r\n                    1.0.0.0\r\n                    \r\n                \r\n                \r\n                    DBExpress Data Explorer Integration\r\n                    Microsoft Office 2000 Sample Automation Server Wrapper Components\r\n                    Microsoft Office XP Sample Automation Server Wrapper Components\r\n                    Devart Data Access Components\r\n                    Devart Controls\r\n                    Devart SQL Server Data Access Components\r\n                    Devart SQL Server Data Access FMX Components\r\n                    Devart DataSet Manager\r\n                \r\n            \r\n            \r\n                True\r\n                False\r\n            \r\n        \r\n        12\r\n    \r\n    \r\n    \r\n"
  },
  {
    "path": "Spider_Project.groupproj",
    "content": "\t\r\n\t\t\r\n\t\t\t{C7751C4D-EDB7-4931-A6C1-A2320117E406}\r\n\t\t\r\n\t\t\r\n\t\t\t\r\n\t\t\t\t\r\n\t\t\t\r\n\t\t\t\r\n\t\t\t\t\r\n\t\t\t\r\n\t\t\r\n\t\t\r\n\t\t\tDefault.Personality.12\r\n\t\t\t\r\n\t\t\t\r\n\t\t\t\t\r\n\t\t\t\r\n\t\t\r\n\t\t\r\n\t\t\t\r\n\t\t\r\n\t\t\r\n\t\t\t\r\n\t\t\r\n\t\t\r\n\t\t\t\r\n\t\t\r\n\t\t\r\n\t\t\t\r\n\t\t\r\n\t\t\r\n\t\t\t\r\n\t\t\r\n\t\t\r\n\t\t\t\r\n\t\t\r\n\t\t\r\n\t\t\t\r\n\t\t\r\n\t\t\r\n\t\t\t\r\n\t\t\r\n\t\t\r\n\t\t\t\r\n\t\t\r\n\t\t\r\n\t\r\n"
  },
  {
    "path": "WinAPIUtils.pas",
    "content": "unit WinAPIUtils;\r\n\r\ninterface\r\n\r\nuses Windows, SysUtils;\r\n\r\nfunction _QueryPerformanceCounter: Int64;\r\nfunction _QueryPerformanceFrequency: Int64;\r\n\r\nfunction _QueryThreadCycleTime(const ThreadHandle: THandle): UInt64;\r\nfunction _QueryProcessCycleTime(const ProcessHandle: THandle): UInt64;\r\n\r\nfunction _GetThreadId(ThreadHandle: THandle): DWORD;\r\n\r\nfunction GetProcessCPUTime(const hProcess: THandle): UInt64;\r\nfunction GetThreadCPUTime(const hThread: THandle): UInt64;\r\n\r\nfunction FileTimeToDateTime(const FileTime: TFileTime): TDateTime;\r\nfunction FileTimeToInt64(const FileTime: TFileTime): UInt64; inline;\r\nfunction Int64ToFileTime(const Value: UInt64): TFileTime; inline;\r\nfunction Int64ToDateTime(const Value: UInt64): TDateTime; inline;\r\n\r\nfunction DebugBreakProcess(Process: THandle): BOOL; stdcall;\r\nfunction DebugSetProcessKillOnExit(KillOnExit: BOOL): BOOL; stdcall;\r\nfunction DebugActiveProcessStop(dwProcessId: DWORD): BOOL; stdcall;\r\n\r\nfunction SuspendProcess(const PID: DWORD): LongBool;\r\nfunction ResumeProcess(const PID: DWORD): LongBool;\r\n\r\nfunction GetFileVersion(const AFileName: string): string;\r\n\r\nfunction GetGUID: String;\r\n\r\nprocedure Check(const Value: LongBool); inline;\r\n\r\nimplementation\r\n\r\ntype\r\n  NTSTATUS = LongInt;\r\n  TProcFunction = function(ProcHandle: THandle): NTSTATUS; stdcall;\r\n\r\nconst\r\n  STATUS_SUCCESS = $00000000;\r\n  PROCESS_SUSPEND_RESUME = $0800;\r\n\r\nfunction QueryThreadCycleTime(ThreadHandle: THandle; CycleTime: PUInt64): BOOL; stdcall; external kernel32 name 'QueryThreadCycleTime';\r\nfunction QueryProcessCycleTime(ProcessHandle: THandle; CycleTime: PUInt64): BOOL; stdcall; external kernel32 name 'QueryProcessCycleTime';\r\n//function SuspendProcess(ProcessHandle: THandle): NTSTATUS; stdcall; external kernel32 name 'NtSuspendProcess';\r\n//function ResumeProcess(ProcessHandle: THandle): NTSTATUS; stdcall; external kernel32 name 'NtResumeProcess';\r\nfunction DebugBreakProcess(Process: THandle): BOOL; stdcall; external kernel32 name 'DebugBreakProcess';\r\nfunction DebugSetProcessKillOnExit(KillOnExit: BOOL): BOOL; stdcall; external kernel32;\r\nfunction DebugActiveProcessStop(dwProcessId: DWORD): BOOL; stdcall; external kernel32;\r\nfunction GetThreadId(ThreadHandle: THandle): DWORD; stdcall; external kernel32 name 'GetThreadId';\r\nfunction CoCreateGuid(out guid: TGUID): HResult; stdcall; external 'ole32.dll' name 'CoCreateGuid';\r\n\r\nfunction NtQueryVirtualMemory(ProcessHandle: THandle; BaseAddress: Pointer; MemoryInformationClass: DWORD; MemoryInformation: Pointer;\r\n  MemoryInformationLength :ULONG; ReturnLength :PULONG): LongInt; stdcall; external 'ntdll.dll';\r\n\r\nvar\r\n  _KernelLibHandle: THandle = 0;\r\n  NtSuspendProcess: TProcFunction = Nil;\r\n  NtResumeProcess: TProcFunction = Nil;\r\n\r\nprocedure Check(const Value: LongBool);\r\nbegin\r\n  if not Value then\r\n    RaiseLastOSError;\r\nend;\r\n\r\nprocedure _LoadKernelProcs;\r\nbegin\r\n  _KernelLibHandle := SafeLoadLibrary('ntdll.dll');\r\n  if _KernelLibHandle <> 0 then\r\n  begin\r\n    @NtSuspendProcess := GetProcAddress(_KernelLibHandle, 'NtSuspendProcess');\r\n    @NtResumeProcess := GetProcAddress(_KernelLibHandle, 'NtResumeProcess');\r\n  end;\r\nend;\r\n\r\nfunction SuspendProcess(const PID: DWORD): LongBool;\r\nvar\r\n  ProcHandle: THandle;\r\nbegin\r\n  Result := False;\r\n\r\n  if @NtSuspendProcess <> nil then\r\n  begin\r\n    ProcHandle := OpenProcess(PROCESS_SUSPEND_RESUME, False, PID);\r\n    if ProcHandle <> 0 then\r\n    begin\r\n      Result := NtSuspendProcess(ProcHandle) = STATUS_SUCCESS;\r\n      CloseHandle(ProcHandle);\r\n    end;\r\n  end;\r\nend;\r\n\r\nfunction ResumeProcess(const PID: DWORD): LongBool;\r\nvar\r\n  ProcHandle: THandle;\r\nbegin\r\n  Result := False;\r\n\r\n  if @NtResumeProcess <> nil then\r\n  begin\r\n    ProcHandle := OpenProcess(PROCESS_SUSPEND_RESUME, False, PID);\r\n    if ProcHandle <> 0 then\r\n    begin\r\n      Result := NtResumeProcess(ProcHandle) = STATUS_SUCCESS;\r\n      CloseHandle(ProcHandle);\r\n    end;\r\n  end;\r\nend;\r\n\r\nfunction GetGUID: String;\r\nvar\r\n  G: TGUID;\r\nbegin\r\n  CoCreateGuid(G);\r\n  Result := GUIDToString(G);\r\n  Result := Copy(Result, 2, Length(Result) - 2);\r\nend;\r\n\r\nvar\r\n  _AppVersion: String = '';\r\n\r\nfunction GetFileVersion(const AFileName: string): String;\r\nvar\r\n  FileName: string;\r\n  InfoSize, Wnd: DWORD;\r\n  VerBuf: Pointer;\r\n  FI: PVSFixedFileInfo;\r\n  VerSize: DWORD;\r\n  Major1, Major2, Minor1, Minor2: Cardinal;\r\nbegin\r\n  Result := _AppVersion;\r\n\r\n  if Result <> '' then Exit;\r\n  \r\n  FileName := AFileName;\r\n  UniqueString(FileName);\r\n  InfoSize := GetFileVersionInfoSize(PChar(FileName), Wnd);\r\n  if InfoSize <> 0 then\r\n  begin\r\n    GetMem(VerBuf, InfoSize);\r\n    try\r\n      if GetFileVersionInfo(PChar(FileName), Wnd, InfoSize, VerBuf) then\r\n        if VerQueryValue(VerBuf, '\\', Pointer(FI), VerSize) then\r\n        begin\r\n          Major1 := FI.dwFileVersionMS shr 16;\r\n          Major2 := FI.dwFileVersionMS and $FFFF;\r\n          Minor1 := FI.dwFileVersionLS shr 16;\r\n          Minor2 := FI.dwFileVersionLS and $FFFF;\r\n\r\n          _AppVersion := Format('%d.%d.%d.%d', [Major1, Major2, Minor1, Minor2]);\r\n          Result := _AppVersion;\r\n        end;\r\n    finally\r\n      FreeMem(VerBuf);\r\n    end;\r\n  end;\r\nend;\r\n\r\ntype\r\n  EWinAPIException = class(Exception);\r\n\r\nprocedure RaiseWinAPIException;\r\nbegin\r\n  raise EWinAPIException.Create('');\r\nend;\r\n\r\nfunction _QueryThreadCycleTime(const ThreadHandle: THandle): UInt64;\r\nbegin\r\n  Result := 0;\r\n\r\n  if not QueryThreadCycleTime(ThreadHandle, @Result) then\r\n    RaiseWinAPIException;\r\nend;\r\n\r\nfunction _QueryProcessCycleTime(const ProcessHandle: THandle): UInt64;\r\nbegin\r\n  Result := 0;\r\n\r\n  if not QueryProcessCycleTime(ProcessHandle, @Result) then\r\n    RaiseWinAPIException;\r\nend;\r\n\r\nfunction FileTimeToDateTime(const FileTime: TFileTime): TDateTime;\r\nvar\r\n  SystemTime: TSystemTime;\r\nbegin\r\n  Result := 0;\r\n\r\n  if FileTimeToSystemTime(@FileTime, SystemTime) then\r\n  begin\r\n    Result := SystemTimeToDateTime(SystemTime);\r\n    Exit;\r\n  end;\r\n\r\n  RaiseWinAPIException;\r\nend;\r\n\r\nfunction FileTimeToInt64(const FileTime: TFileTime): UInt64;\r\nbegin\r\n  Result := UInt64(UInt64(FileTime.dwHighDateTime) shl 32) or FileTime.dwLowDateTime;\r\nend;\r\n\r\nfunction Int64ToFileTime(const Value: UInt64): TFileTime;\r\nbegin\r\n  Result.dwLowDateTime := DWORD(Value);\r\n  Result.dwHighDateTime := DWORD(Value shr 32);\r\nend;\r\n\r\nfunction Int64ToDateTime(const Value: UInt64): TDateTime;\r\nbegin\r\n  Result := FileTimeToDateTime(Int64ToFileTime(Value));\r\nend;\r\n\r\ntype\r\n  PCPUTime = ^RCPUTime;\r\n  RCPUTime = record\r\n    CT, ET, KT, UT: TFileTime;\r\n  end;\r\n\r\nthreadvar\r\n  _CPUTimeRes: RCPUTime;\r\n\r\nfunction GetProcessCPUTime(const hProcess: THandle): UInt64;\r\nbegin\r\n  Result := 0;\r\n\r\n  with _CPUTimeRes do\r\n    if GetProcessTimes(hProcess, CT, ET, KT, UT) then\r\n      Result := FileTimeToInt64(KT) + FileTimeToInt64(UT)\r\n    else\r\n      RaiseWinAPIException;\r\nend;\r\n\r\nfunction GetThreadCPUTime(const hThread: THandle): UInt64;\r\nbegin\r\n  Result := 0;\r\n\r\n  with _CPUTimeRes do\r\n    if GetThreadTimes(hThread, CT, ET, KT, UT) then\r\n      Result := FileTimeToInt64(KT) + FileTimeToInt64(UT)\r\n    else\r\n      RaiseWinAPIException;\r\nend;\r\n\r\nfunction _QueryPerformanceCounter: Int64;\r\nbegin\r\n  Result := 0;\r\n\r\n  if not QueryPerformanceCounter(Result) then\r\n    RaiseWinAPIException;\r\nend;\r\n\r\nfunction _QueryPerformanceFrequency: Int64;\r\nbegin\r\n  Result := 0;\r\n\r\n  if not QueryPerformanceFrequency(Result) then\r\n    RaiseWinAPIException;\r\nend;\r\n\r\nfunction _GetThreadId(ThreadHandle: THandle): DWORD;\r\nbegin\r\n  Result := GetThreadId(ThreadHandle);\r\nend;\r\n\r\ninitialization\r\n  _LoadKernelProcs;\r\n\r\nend.\r\n"
  },
  {
    "path": "uActionController.pas",
    "content": "unit uActionController;\r\n\r\ninterface\r\n\r\nuses Classes, DebugInfo, DebugerTypes, XMLDoc, XMLIntf, Collections.Queues,\r\n  System.SyncObjs;\r\n\r\ntype\r\n  TacAction = (acCreateProcess, acAddThread, acUpdateInfo, acProgress, acSetProjectName, acChangeProjectSettings, acChangeDbgState);\r\n\r\n  TDbgOption = (\r\n    doDebugInfo,\r\n    doRun,\r\n    doProfiler,\r\n    doMemProfiler, doMemCallStack, doMemCheckDoubleFree,\r\n    doExceptions, doExceptionCallStack,\r\n    doCodeTracking, doTrackSystemUnits, doSamplingMethod,\r\n    doSyncObjsTracking\r\n  );\r\n\r\n  TDbgOptions = set of TDbgOption;\r\n\r\n  TArgsList = array of Variant;\r\n\r\n  TActionItem = class\r\n  private\r\n    FAction: TacAction;\r\n    FArgs: TArgsList;\r\n  public\r\n    constructor Create(const AAction: TacAction; const AArgs: TArgsList);\r\n\r\n    property Action: TacAction read FAction;\r\n    property Args: TArgsList read FArgs;\r\n  end;\r\n\r\n  TActionQueue = class(TQueue)\r\n  public\r\n    constructor Create;\r\n\r\n    procedure Clear; override;\r\n\r\n    function GetAction: TActionItem;\r\n    procedure AddAction(const Action: TacAction; const Args: TArgsList);\r\n  end;\r\n\r\n  TActionThread = class(TThread)\r\n  protected\r\n    procedure Execute; override;\r\n  public\r\n    constructor Create;\r\n    destructor Destroy; override;\r\n  end;\r\n\r\n  TActionController = class\r\n  public\r\n    class procedure RunDebug(const ADbgOptions: TDbgOptions; const AProcessID: TProcessId = 0); static;\r\n    class procedure StopDebug; static;\r\n    class procedure PauseDebug; static;\r\n    class procedure TraceDebug(const TraceType: TDbgTraceState); static;\r\n\r\n    class procedure Log(const LogType: TDbgLogType; const Msg: String); overload; static;\r\n    class procedure Log(const LogType: TDbgLogType; const Msg: String; const Args: array of const); overload; static;\r\n\r\n    class procedure DoAction(const Action: TacAction; const Args: array of Variant); overload; static;\r\n    class procedure DoAction(const Action: TacAction; const Args: TArgsList); overload; static;\r\n    class procedure DoSyncAction(const Action: TacAction; const Args: array of Variant); overload; static;\r\n    class procedure DoSyncAction(const Action: TacAction; const Args: TArgsList); overload; static;\r\n    class procedure ViewDebugInfo(DebugInfo: TDebugInfo); static;\r\n\r\n    class procedure ClearDebug(const DbgFree: LongBool); static;\r\n\r\n    class procedure AppClose; static;\r\n  end;\r\n\r\n  TProjectOptions = class\r\n  private\r\n    FProjectName: String;\r\n    FProjectXML: IXMLDocument;\r\n    FUpdateCount: Integer;\r\n\r\n    function GetXMLValue(const NodeName: String): String;\r\n    procedure SetXMLValue(const NodeName, NodeValue: String);\r\n\r\n    function GetApplicationName: String;\r\n    function GetProjectName: String;\r\n    function GetProjectStorage: String;\r\n    function GetDelphiSource: String;\r\n    function GetProjectSource: String;\r\n    function GetRunParams: String;\r\n    function GetWorkingDirectory: String;\r\n\r\n    procedure SetApplicationName(const Value: String);\r\n    procedure SetProjectStorage(const Value: String);\r\n    procedure SetDelphiSource(const Value: String);\r\n    procedure SetProjectSource(const Value: String);\r\n    procedure SetRunParams(const Value: String);\r\n    procedure SetWorkingDirectory(const Value: String);\r\n  public\r\n    constructor Create;\r\n    destructor Destroy; override;\r\n\r\n    procedure Clear;\r\n\r\n    procedure BeginUpdate;\r\n    procedure EndUpdate;\r\n\r\n    procedure Open(const AProjectName: String);\r\n    procedure NewConfig;\r\n    procedure Save;\r\n\r\n    class function GetDefProjectSource(const ProjectName: String): String; static;\r\n    class function GetDefDelphiSource: String; static;\r\n\r\n    property ProjectName: String read GetProjectName;\r\n    property ApplicationName: String read GetApplicationName write SetApplicationName;\r\n    property ProjectStorage: String read GetProjectStorage write SetProjectStorage;\r\n    property ProjectSource: String read GetProjectSource write SetProjectSource;\r\n    property DelphiSource: String read GetDelphiSource write SetDelphiSource;\r\n    property RunParams: String read GetRunParams write SetRunParams;\r\n    property WorkingDirectory: String read GetWorkingDirectory write SetWorkingDirectory;\r\n  end;\r\n\r\nconst\r\n  _DEFAULT_PROJECT = '_default.spider';\r\n\r\nvar\r\n  _AC: TActionController = nil;\r\n  gvProjectOptions: TProjectOptions = nil;\r\n\r\nimplementation\r\n\r\nuses SysUtils, uMain, Debuger, uDebugerThread, ClassUtils, JclIDEUtils,\r\n  System.IOUtils, System.Types, Vcl.Dialogs;\r\n\r\nvar\r\n  gvActionThread: TActionThread = nil;\r\n  gvActionQueue: TActionQueue = nil;\r\n\r\n{ TActionController }\r\n\r\nclass procedure TActionController.Log(const LogType: TDbgLogType; const Msg: String);\r\nbegin\r\n  if Assigned(gvDebugInfo) then\r\n    gvDebugInfo.DbgLog.Add(LogType, Msg);\r\n\r\n  DoAction(acUpdateInfo, []);\r\nend;\r\n\r\nclass procedure TActionController.AppClose;\r\nbegin\r\n  gvActionThread.Terminate;\r\n\r\n  Sleep(500);\r\nend;\r\n\r\nclass procedure TActionController.ClearDebug(const DbgFree: LongBool);\r\nbegin\r\n  gvActionQueue.Clear;\r\n\r\n  if Assigned(gvDebugInfo) then\r\n  begin\r\n    gvDebugInfo.ClearDebugInfo;\r\n    if DbgFree then\r\n      FreeAndNil(gvDebugInfo);\r\n  end;\r\n\r\n  if Assigned(gvDebuger) then\r\n  begin\r\n    gvDebuger.ClearDbgInfo;\r\n    if DbgFree then\r\n      FreeAndNil(gvDebuger);\r\n  end;\r\nend;\r\n\r\nclass procedure TActionController.DoAction(const Action: TacAction; const Args: TArgsList);\r\nbegin\r\n  gvActionQueue.AddAction(Action, Args);\r\nend;\r\n\r\nclass procedure TActionController.DoSyncAction(const Action: TacAction; const Args: array of Variant);\r\nvar\r\n  _Args: TArgsList;\r\n  i: Integer;\r\nbegin\r\n  SetLength(_Args, Length(Args));\r\n  for i := 0 to High(Args) do\r\n    _Args[i] := Args[i];\r\n\r\n  TActionController.DoSyncAction(Action, _Args);\r\nend;\r\n\r\nclass procedure TActionController.DoAction(const Action: TacAction; const Args: array of Variant);\r\nvar\r\n  _Args: TArgsList;\r\n  i: Integer;\r\nbegin\r\n  SetLength(_Args, Length(Args));\r\n  for i := 0 to High(Args) do\r\n    _Args[i] := Args[i];\r\n\r\n  TActionController.DoAction(Action, _Args);\r\nend;\r\n\r\nclass procedure TActionController.DoSyncAction(const Action: TacAction; const Args: TArgsList);\r\nbegin\r\n  TThread.Synchronize(nil,\r\n    procedure\r\n    begin\r\n      if Assigned(MainForm) then\r\n        MainForm.DoAction(Action, Args);\r\n    end\r\n  );\r\nend;\r\n\r\nclass procedure TActionController.Log(const LogType: TDbgLogType; const Msg: String; const Args: array of const);\r\nbegin\r\n  Log(LogType, Format(Msg, Args));\r\nend;\r\n\r\nclass procedure TActionController.PauseDebug;\r\nbegin\r\n  TActionController.TraceDebug(dtsPause);\r\nend;\r\n\r\nclass procedure TActionController.RunDebug(const ADbgOptions: TDbgOptions; const AProcessID: TProcessId = 0);\r\nbegin\r\n  if not Assigned(_DbgThread) then\r\n    _DbgThread := TDebugerThread.Create(ADbgOptions, AProcessID);\r\nend;\r\n\r\nclass procedure TActionController.StopDebug;\r\nbegin\r\n  if Assigned(gvDebuger) then\r\n    gvDebuger.StopDebug;\r\nend;\r\n\r\nclass procedure TActionController.TraceDebug(const TraceType: TDbgTraceState);\r\nbegin\r\n  if Assigned(gvDebuger) then\r\n  begin\r\n    gvDebuger.TraceDebug(TraceType);\r\n    TActionController.DoAction(acChangeDbgState, []);\r\n  end;\r\nend;\r\n\r\nclass procedure TActionController.ViewDebugInfo(DebugInfo: TDebugInfo);\r\nvar\r\n  DI: TDebugInfo;\r\nbegin\r\n  DI := DebugInfo;\r\n  TThread.Synchronize(nil,\r\n    procedure\r\n    begin\r\n      MainForm.ViewDebugInfo(DI);\r\n    end\r\n  );\r\nend;\r\n\r\n\r\n{ TProjectOptions }\r\n\r\nprocedure TProjectOptions.BeginUpdate;\r\nbegin\r\n  Inc(FUpdateCount);\r\nend;\r\n\r\nprocedure TProjectOptions.Clear;\r\nbegin\r\n  FProjectName := '';\r\n  FProjectXML := nil;\r\n  FUpdateCount := 0;\r\nend;\r\n\r\nconstructor TProjectOptions.Create;\r\nbegin\r\n  inherited Create;\r\n\r\n  FProjectXML := nil;\r\n  FUpdateCount := 0;\r\nend;\r\n\r\ndestructor TProjectOptions.Destroy;\r\nbegin\r\n\r\n  inherited;\r\nend;\r\n\r\nprocedure TProjectOptions.EndUpdate;\r\nbegin\r\n  Dec(FUpdateCount);\r\n  if FUpdateCount = 0 then\r\n    Save;\r\nend;\r\n\r\nfunction TProjectOptions.GetProjectName: String;\r\nbegin\r\n  Result := FProjectName;\r\nend;\r\n\r\nprocedure TProjectOptions.NewConfig;\r\nvar\r\n  DocNode: IXMLNode;\r\nbegin\r\n  FProjectXML := TXMLDocument.Create(nil);\r\n  FProjectXML.NodeIndentStr := '  ';\r\n  FProjectXML.Options := FProjectXML.Options + [doNodeAutoIndent, doNodeAutoCreate];\r\n  FProjectXML.Active := True;\r\n  FProjectXML.Encoding := 'utf-8';\r\n\r\n  DocNode := FProjectXML.AddChild('spider');\r\n  DocNode.Attributes['version'] := '1.0';\r\nend;\r\n\r\nprocedure TProjectOptions.Open(const AProjectName: String);\r\nbegin\r\n  if AProjectName <> FProjectName then\r\n    Clear;\r\n\r\n  FProjectName := AProjectName;\r\n  if FileExists(FProjectName) then\r\n    FProjectXML := TXMLDocument.Create(FProjectName)\r\n  else\r\n    NewConfig;\r\nend;\r\n\r\nprocedure TProjectOptions.Save;\r\nbegin\r\n  if Assigned(FProjectXML) and (ExtractFileName(FProjectName) <> _DEFAULT_PROJECT) then\r\n  try\r\n    FProjectXML.SaveToFile(FProjectName);\r\n  except\r\n    on E: Exception do\r\n      ShowMessageFmt('Save to \"%s\" fail: %s', [FProjectName, E.Message]);\r\n  end;\r\nend;\r\n\r\nfunction TProjectOptions.GetApplicationName: String;\r\nbegin\r\n  Result := GetXMLValue('application_name');\r\nend;\r\n\r\nprocedure TProjectOptions.SetApplicationName(const Value: String);\r\nbegin\r\n  SetXMLValue('application_name', Value);\r\nend;\r\n\r\nclass function TProjectOptions.GetDefDelphiSource: String;\r\nvar\r\n  Installations: TJclBorRADToolInstallations;\r\n  DelphiRoot: String;\r\nbegin\r\n  Result := '';\r\n\r\n  Installations := TJclBorRADToolInstallations.Create;\r\n  try\r\n    if Installations.Count > 0 then\r\n    begin\r\n      DelphiRoot := Installations.Installations[Installations.Count - 1].RootDir;\r\n      Result := IncludeTrailingPathDelimiter(DelphiRoot) + 'source';\r\n    end;\r\n  finally\r\n    FreeAndNil(Installations);\r\n  end;\r\nend;\r\n\r\nclass function TProjectOptions.GetDefProjectSource(const ProjectName: String): String;\r\nvar\r\n  DprName: String;\r\n  DprPathName: String;\r\n  Find: TStringDynArray;\r\nbegin\r\n  Result := '';\r\n\r\n  if ProjectName <> '' then\r\n  begin\r\n    DprName := ExtractFileName(ProjectName);\r\n    DprName := ChangeFileExt(DprName, '.dpr');\r\n\r\n    Result := ExtractFileDir(ProjectName);\r\n\r\n    while (Result <> '') and TDirectory.Exists(Result) do\r\n    begin\r\n      DprPathName := Result + PathDelim + DprName;\r\n      if TFile.Exists(DprPathName) then\r\n        Break;\r\n\r\n      Find := TDirectory.GetFiles(Result, '*.dpr');\r\n      if Length(Find) > 0 then\r\n        Break;\r\n\r\n      Result := ExtractFileDir(Result);\r\n\r\n      //    ,  \r\n      if Result = IncludeTrailingPathDelimiter(ExtractFileDrive(Result)) then\r\n      begin\r\n        Result := '';\r\n        Break;\r\n      end;\r\n    end;\r\n\r\n    if Result <> '' then\r\n    begin\r\n      // TODO: Source dirs from DPR\r\n    end;\r\n  end;\r\nend;\r\n\r\nfunction TProjectOptions.GetDelphiSource: String;\r\nbegin\r\n  Result := GetXMLValue('delphi_source');\r\nend;\r\n\r\nprocedure TProjectOptions.SetDelphiSource(const Value: String);\r\nbegin\r\n  SetXMLValue('delphi_source', Value);\r\nend;\r\n\r\nfunction TProjectOptions.GetProjectSource: String;\r\nbegin\r\n  Result := GetXMLValue('project_source');\r\nend;\r\n\r\nprocedure TProjectOptions.SetProjectSource(const Value: String);\r\nbegin\r\n  SetXMLValue('project_source', Value);\r\nend;\r\n\r\nfunction TProjectOptions.GetProjectStorage: String;\r\nbegin\r\n  Result := GetXMLValue('project_storage');\r\nend;\r\n\r\nfunction TProjectOptions.GetRunParams: String;\r\nbegin\r\n  Result := GetXMLValue('run_parameters');\r\nend;\r\n\r\nfunction TProjectOptions.GetWorkingDirectory: String;\r\nbegin\r\n  Result := GetXMLValue('working_directory');\r\nend;\r\n\r\nprocedure TProjectOptions.SetProjectStorage(const Value: String);\r\nbegin\r\n  SetXMLValue('project_storage', Value);\r\nend;\r\n\r\nprocedure TProjectOptions.SetRunParams(const Value: String);\r\nbegin\r\n  SetXMLValue('run_parameters', Value);\r\nend;\r\n\r\nprocedure TProjectOptions.SetWorkingDirectory(const Value: String);\r\nbegin\r\n  SetXMLValue('working_directory', Value);\r\nend;\r\n\r\nfunction TProjectOptions.GetXMLValue(const NodeName: String): String;\r\nbegin\r\n  Result := '';\r\n  if Assigned(FProjectXML) then\r\n    Result := ClassUtils.GetXMLValue(FProjectXML.DocumentElement, NodeName);\r\nend;\r\n\r\nprocedure TProjectOptions.SetXMLValue(const NodeName, NodeValue: String);\r\nbegin\r\n  if Assigned(FProjectXML) then\r\n  begin\r\n    BeginUpdate;\r\n    ClassUtils.SetXMLValue(FProjectXML.DocumentElement, NodeName, NodeValue);\r\n    EndUpdate;\r\n  end;\r\nend;\r\n\r\n{ TActionQueue }\r\n\r\nprocedure TActionQueue.AddAction(const Action: TacAction; const Args: TArgsList);\r\nvar\r\n  ActionItem: TActionItem;\r\nbegin\r\n  ActionItem := TActionItem.Create(Action, Args);\r\n  Enqueue(ActionItem);\r\nend;\r\n\r\nprocedure TActionQueue.Clear;\r\nvar\r\n  Action: TActionItem;\r\nbegin\r\n  while Count > 0 do\r\n  begin\r\n    Action := GetAction;\r\n    FreeAndNil(Action);\r\n  end;\r\n\r\n  inherited Clear;\r\nend;\r\n\r\nconstructor TActionQueue.Create;\r\nbegin\r\n  inherited Create(1024, True);\r\nend;\r\n\r\nfunction TActionQueue.GetAction: TActionItem;\r\nbegin\r\n  Result := Dequeue;\r\nend;\r\n\r\n{ TActionThread }\r\n\r\nconstructor TActionThread.Create;\r\nbegin\r\n  inherited Create(False);\r\n\r\n  FreeOnTerminate := True;\r\nend;\r\n\r\ndestructor TActionThread.Destroy;\r\nbegin\r\n  FreeAndNil(gvActionQueue);\r\n  gvActionThread := nil;\r\n\r\n  inherited;\r\nend;\r\n\r\nprocedure TActionThread.Execute;\r\nvar\r\n  ActionItem: TActionItem;\r\nbegin\r\n  NameThreadForDebugging(ClassName);\r\n\r\n  while not Terminated do\r\n  begin\r\n    while not Terminated and (gvActionQueue.Count > 0) do\r\n    begin\r\n      ActionItem := gvActionQueue.GetAction;\r\n      if Assigned(ActionItem) then\r\n        try\r\n          _AC.DoSyncAction(ActionItem.Action, ActionItem.Args);\r\n        finally\r\n          FreeAndNil(ActionItem);\r\n        end;\r\n    end;\r\n\r\n    if not Terminated then\r\n      Sleep(500);\r\n  end;\r\nend;\r\n\r\n{ TActionItem }\r\n\r\nconstructor TActionItem.Create(const AAction: TacAction; const AArgs: TArgsList);\r\nbegin\r\n  inherited Create;\r\n\r\n  FAction := AAction;\r\n  FArgs := Copy(AArgs, 0, Length(AArgs));\r\nend;\r\n\r\ninitialization\r\n  gvProjectOptions := TProjectOptions.Create;\r\n  gvActionQueue := TActionQueue.Create;\r\n  gvActionThread := TActionThread.Create;\r\n\r\nfinalization\r\n  // Destroys in gvActionThread\r\n  //FreeAndNil(gvActionThread);\r\n  //FreeAndNil(gvActionQueue);\r\n\r\n  FreeAndNil(gvProjectOptions);\r\n\r\nend.\r\n"
  },
  {
    "path": "uDebugerThread.pas",
    "content": "unit uDebugerThread;\r\n\r\ninterface\r\n\r\nuses SysUtils, Windows, Classes, DebugerTypes, uActionController;\r\n\r\ntype\r\n  TDebugerThread = class(TThread)\r\n  private\r\n    FProcessID: TProcessId;\r\n    FDbgOptions: TDbgOptions;\r\n\r\n    FDbgInfoLoaded: LongBool;\r\n    FDbgStarted: LongBool;\r\n\r\n    procedure OnChangeDebugState(Sender: TObject);\r\n    procedure OnEndDebug(Sender: TObject);\r\n    procedure OnRip(Sender: TObject; ThreadId: TThreadId; Data: PRIPInfo);\r\n    procedure OnCreateThread(Sender: TObject; ThreadId: TThreadId; Data: PCreateThreadDebugInfo);\r\n    procedure OnExitThread(Sender: TObject; ThreadId: TThreadId; Data: PExitThreadDebugInfo);\r\n    procedure OnCreateProcess(Sender: TObject; ProcessId: TProcessId; Data: PCreateProcessDebugInfo);\r\n    procedure OnExitProcess(Sender: TObject; ProcessId: TProcessId; Data: PExitProcessDebugInfo);\r\n    procedure OnLoadDll(Sender: TObject; ThreadId: TThreadId; Data: PLoadDLLDebugInfo);\r\n    procedure OnUnLoadDll(Sender: TObject; ThreadId: TThreadId; Data: PUnloadDLLDebugInfo);\r\n    procedure OnDebugString(Sender: TObject; ThreadId: TThreadId; Data: POutputDebugStringInfo);\r\n    procedure OnUnknownException(Sender: TObject; ThreadId: TThreadId; ExceptionRecord: PExceptionRecord);\r\n    procedure OnUnknownBreakPoint(Sender: TObject; ThreadId: TThreadId; ExceptionRecord: PExceptionRecord);\r\n    procedure OnBreakPoint(Sender: TObject; ThreadId: TThreadId; ExceptionRecord: PExceptionRecord; BreakPointIndex: Integer; var ReleaseBreakpoint: LongBool);\r\n    procedure OnDbgLog(Sender: TObject; ThreadId: TThreadId; const Data: String);\r\n    procedure OnProgress(const Action: String; const Progress: Integer);\r\n\r\n    procedure InitDebuger;\r\n    procedure InitDebugInfo(const DbgExt: String = '');\r\n    procedure LoadDebugInfo;\r\n    function GetAppName: String;\r\n    function GetProjectSourceDirs: String;\r\n    function GetDelphiSourceDirs: String;\r\n    function GetRunParams: String;\r\n    function GetWorkingDirectory: String;\r\n  protected\r\n    procedure Execute; override;\r\n    procedure DoTerminate; override;\r\n\r\n    property AppName: String read GetAppName;\r\n    property ProjectSourceDirs: String read GetProjectSourceDirs;\r\n    property DelphiSourceDirs: String read GetDelphiSourceDirs;\r\n    property RunParams: String read GetRunParams;\r\n    property WorkingDirectory: String read GetWorkingDirectory;\r\n  public\r\n    constructor Create(const ADbgOptions: TDbgOptions; const AProcessID: TProcessId = 0);\r\n    destructor Destroy; override;\r\n  end;\r\n\r\nvar\r\n  _DbgThread: TDebugerThread = nil;\r\n\r\nimplementation\r\n\r\nuses Debuger, DebugInfo, DelphiDebugInfo, MapDebugInfo;\r\n\r\n{ TDebugerThread }\r\n\r\nconstructor TDebugerThread.Create(const ADbgOptions: TDbgOptions; const AProcessID: TProcessId = 0);\r\nbegin\r\n  inherited Create(False);\r\n  FreeOnTerminate := True;\r\n\r\n  FDbgOptions := ADbgOptions;\r\n  FProcessID := AProcessID;\r\n\r\n  FDbgInfoLoaded := False;\r\n  FDbgStarted := False;\r\n\r\n  Priority := tpHighest;\r\nend;\r\n\r\ndestructor TDebugerThread.Destroy;\r\nbegin\r\n  _DbgThread := nil;\r\n  inherited;\r\nend;\r\n\r\nprocedure TDebugerThread.DoTerminate;\r\nbegin\r\n  inherited;\r\n\r\n  _DbgThread := Nil;\r\nend;\r\n\r\nprocedure TDebugerThread.Execute;\r\nvar\r\n  FRun: LongBool;\r\n  FError: String;\r\nbegin\r\n  NameThreadForDebugging(AnsiString(ClassName), ThreadId);\r\n\r\n  InitDebuger;\r\n  gvDebuger.ClearDbgInfo;\r\n\r\n  InitDebugInfo;\r\n  if doDebugInfo in FDbgOptions then\r\n    LoadDebugInfo;\r\n\r\n  if doRun in FDbgOptions then\r\n  begin\r\n    FError := '';\r\n\r\n    if FProcessID = 0 then\r\n    begin\r\n      _AC.Log(dltInfo, 'Run application \"%s\"', [AppName]);\r\n\r\n      if RunParams <> '' then\r\n        _AC.Log(dltInfo, 'Run parameters: \"%s\"', [RunParams]);\r\n\r\n      if WorkingDirectory <> '' then\r\n        _AC.Log(dltInfo, 'Working directory: \"%s\"', [WorkingDirectory]);\r\n\r\n      FRun := gvDebuger.DebugNewProcess(AppName, FError, RunParams, WorkingDirectory);\r\n    end\r\n    else\r\n    begin\r\n      _AC.Log(dltInfo, 'Attach to process [%d]', [FProcessID]);\r\n      FRun := gvDebuger.AttachToProcess(FProcessID, False);\r\n    end;\r\n\r\n    if FRun then\r\n    begin\r\n      gvDebuger.PerfomanceMode := (doProfiler in FDbgOptions);\r\n\r\n      gvDebuger.DbgMemoryProfiler.MemoryCheckMode := (doMemProfiler in FDbgOptions);\r\n      gvDebuger.DbgMemoryProfiler.MemoryCallStack := gvDebuger.DbgMemoryProfiler.MemoryCheckMode and (doMemCallStack in FDbgOptions);\r\n      gvDebuger.DbgMemoryProfiler.MemoryCheckDoubleFree := gvDebuger.DbgMemoryProfiler.MemoryCheckMode and (doMemCheckDoubleFree in FDbgOptions);\r\n\r\n      gvDebuger.ExceptionCheckMode := (doExceptions in FDbgOptions);\r\n      gvDebuger.ExceptionCallStack := gvDebuger.ExceptionCheckMode and (doExceptionCallStack in FDbgOptions);\r\n\r\n      gvDebuger.CodeTracking := (doCodeTracking in FDbgOptions);\r\n      gvDebuger.TrackSystemUnits := gvDebuger.CodeTracking and (doTrackSystemUnits in FDbgOptions);\r\n      gvDebuger.SamplingMethod := gvDebuger.CodeTracking and (doSamplingMethod in FDbgOptions);\r\n\r\n      gvDebuger.DbgSysncObjsProfiler.SyncObjsTracking := (doSyncObjsTracking in FDbgOptions);\r\n\r\n      _AC.Log(dltInfo, 'Start debug process');\r\n      try\r\n        gvDebuger.ProcessDebugEvents;\r\n      except\r\n        on E: Exception do\r\n          _AC.Log(dltError, 'Fail debug process: \"%s\"', [E.Message]);\r\n      end;\r\n    end\r\n    else\r\n      _AC.Log(dltError, 'Fail start application: %s', [FError]);\r\n  end\r\n  else\r\n    _AC.DoAction(acChangeDbgState, []);\r\nend;\r\n\r\nfunction TDebugerThread.GetAppName: String;\r\nbegin\r\n  Result := gvProjectOptions.ApplicationName;\r\nend;\r\n\r\nfunction TDebugerThread.GetDelphiSourceDirs: String;\r\nbegin\r\n  Result := gvProjectOptions.DelphiSource;\r\nend;\r\n\r\nfunction TDebugerThread.GetProjectSourceDirs: String;\r\nbegin\r\n  Result := gvProjectOptions.ProjectSource;\r\nend;\r\n\r\nfunction TDebugerThread.GetRunParams: String;\r\nbegin\r\n  Result := gvProjectOptions.RunParams;\r\nend;\r\n\r\nfunction TDebugerThread.GetWorkingDirectory: String;\r\nbegin\r\n  Result := gvProjectOptions.WorkingDirectory;\r\nend;\r\n\r\nprocedure TDebugerThread.InitDebuger;\r\nbegin\r\n  if gvDebuger = nil then\r\n    gvDebuger := TDebuger.Create();\r\n\r\n  gvDebuger.OnChangeDebugState := OnChangeDebugState;\r\n  gvDebuger.OnEndDebug := OnEndDebug;\r\n  gvDebuger.OnRip := OnRip;\r\n  gvDebuger.OnCreateProcess := OnCreateProcess;\r\n  gvDebuger.OnExitProcess := OnExitProcess;\r\n  gvDebuger.OnCreateThread := OnCreateThread;\r\n  gvDebuger.OnExitThread := OnExitThread;\r\n  gvDebuger.OnLoadDll := OnLoadDll;\r\n  gvDebuger.OnUnloadDll := OnUnLoadDll;\r\n  gvDebuger.OnDebugString := OnDebugString;\r\n  gvDebuger.OnUnknownException := OnUnknownException;\r\n  gvDebuger.OnUnknownBreakPoint := OnUnknownBreakPoint;\r\n  gvDebuger.OnBreakPoint := OnBreakPoint;\r\n  gvDebuger.OnDbgLog := OnDbgLog;\r\nend;\r\n\r\nprocedure TDebugerThread.InitDebugInfo(const DbgExt: String = '');\r\nbegin\r\n  FreeAndNil(gvDebugInfo);\r\n\r\n  if DbgExt = '' then\r\n    gvDebugInfo := TDelphiDebugInfo.Create\r\n  else\r\n  if SameText(DbgExt, '.map') then\r\n    gvDebugInfo := TMapDebugInfo.Create;\r\n\r\n  gvDebugInfo.DebugInfoProgressCallback := OnProgress;\r\nend;\r\n\r\nprocedure TDebugerThread.LoadDebugInfo;\r\nbegin\r\n  _AC.ClearDebug(False);\r\n\r\n  _AC.DoAction(acUpdateInfo, []);\r\n\r\n  _AC.DoAction(acProgress, ['Load debug info...', 1]);\r\n  try\r\n    _AC.Log(dltInfo, 'Scan delphi source dirs');\r\n    gvDebugInfo.UpdateSourceDirs(utSystem, DelphiSourceDirs);\r\n\r\n    _AC.Log(dltInfo, 'Scan project source dirs');\r\n    gvDebugInfo.UpdateSourceDirs(utProject, ProjectSourceDirs);\r\n\r\n    _AC.Log(dltInfo, 'Load debug info for \"%s\"', [AppName]);\r\n    FDbgInfoLoaded := gvDebugInfo.ReadDebugInfo(AppName);\r\n\r\n    if not FDbgInfoLoaded then\r\n    begin\r\n      InitDebugInfo('.map');\r\n\r\n      _AC.Log(dltInfo, 'Scan source dirs');\r\n      gvDebugInfo.UpdateSourceDirs(utSystem, DelphiSourceDirs);\r\n      gvDebugInfo.UpdateSourceDirs(utProject, ProjectSourceDirs);\r\n\r\n      FDbgInfoLoaded := gvDebugInfo.ReadDebugInfo(AppName);\r\n    end;\r\n\r\n    if FDbgInfoLoaded then\r\n    begin\r\n      _AC.Log(dltInfo, 'Loaded %s debug info for \"%s\"', [gvDebugInfo.DebugInfoType, AppName]);\r\n      _AC.ViewDebugInfo(gvDebugInfo);\r\n\r\n      _AC.Log(dltWarning, 'Hint: Set \"Stack frames\" to \"True\" in project options, for view full call stack');\r\n\r\n      if gvDebugInfo.Units.IndexOf('system.pas') = -1 then\r\n        _AC.Log(dltError, 'Debug info for unit \"system.pas\" not found. Please, set \"Use debug .dcus\" to \"False\" in project options.');\r\n    end\r\n    else\r\n    begin\r\n      _AC.Log(dltWarning, 'No debug info for \"%s\"', [AppName]);\r\n      // FreeAndNil(gvDebugInfo);    \r\n    end;\r\n\r\n    _AC.DoAction(acUpdateInfo, []);\r\n  finally\r\n    _AC.DoAction(acProgress, ['', 0]);\r\n  end;\r\nend;\r\n\r\nprocedure TDebugerThread.OnBreakPoint(Sender: TObject; ThreadId: TThreadId; ExceptionRecord: PExceptionRecord;\r\n      BreakPointIndex: Integer; var ReleaseBreakpoint: LongBool);\r\nbegin\r\n  if BreakPointIndex = -1 then\r\n    _AC.Log(dltThreadEvent, 'Perfomance ThreadID: %d', [ThreadId]);\r\nend;\r\n\r\nprocedure TDebugerThread.OnChangeDebugState(Sender: TObject);\r\nbegin\r\n  _AC.DoAction(acChangeDbgState, []);\r\nend;\r\n\r\nprocedure TDebugerThread.OnCreateProcess(Sender: TObject; ProcessId: TProcessId; Data: PCreateProcessDebugInfo);\r\nbegin\r\n  _AC.Log(dltProcessEvent, 'Process Start ID: %d', [ProcessId]);\r\n\r\n  _AC.DoSyncAction(acChangeDbgState, []);\r\n  _AC.DoSyncAction(acCreateProcess, [ProcessId]);\r\nend;\r\n\r\nprocedure TDebugerThread.OnCreateThread(Sender: TObject; ThreadId: TThreadId; Data: PCreateThreadDebugInfo);\r\nbegin\r\n  _AC.Log(dltThreadEvent, 'Thread Create ID: %d', [ThreadID]);\r\n  _AC.DoSyncAction(acAddThread, [ThreadID]);\r\nend;\r\n\r\nprocedure TDebugerThread.OnDbgLog(Sender: TObject; ThreadId: TThreadId; const Data: String);\r\nbegin\r\n  _AC.Log(dltDebugOutput, Format('Debug log: [%d] %s', [ThreadId, Data]));\r\nend;\r\n\r\nprocedure TDebugerThread.OnDebugString(Sender: TObject; ThreadId: TThreadId; Data: POutputDebugStringInfo);\r\nvar\r\n  Msg: String;\r\nbegin\r\n  if Data^.fUnicode = 1 then\r\n    Msg := String(gvDebuger.ReadStringW(Data^.lpDebugStringData, Data^.nDebugStringLength))\r\n  else\r\n    Msg := String(gvDebuger.ReadStringA(Data^.lpDebugStringData, Data^.nDebugStringLength));\r\n\r\n  _AC.Log(dltDebugOutput, 'Debug String: ' + Msg);\r\n\r\n  if Msg = '### DBG_MODE_ON ###' then\r\n    gvDebuger.DbgLogMode := True;\r\n\r\n  if Msg = '### DBG_MODE_OFF ###' then\r\n    gvDebuger.DbgLogMode := False;\r\nend;\r\n\r\nprocedure TDebugerThread.OnExitProcess(Sender: TObject; ProcessId: TProcessId; Data: PExitProcessDebugInfo);\r\nbegin\r\n  _AC.Log(dltProcessEvent, 'Process Exit ID: %d', [ProcessID]);\r\nend;\r\n\r\nprocedure TDebugerThread.OnExitThread(Sender: TObject; ThreadId: TThreadId; Data: PExitThreadDebugInfo);\r\nbegin\r\n  if Data <> Nil then\r\n    _AC.Log(dltThreadEvent, 'Thread Exit ID: %d (%d)', [ThreadID, Data^.dwExitCode])\r\n  else\r\n    _AC.Log(dltThreadEvent, 'Thread Exit ID: %d', [ThreadID]);\r\nend;\r\n\r\nprocedure TDebugerThread.OnEndDebug(Sender: TObject);\r\nbegin\r\n  _AC.Log(dltInfo, 'Finish debug');\r\n\r\n  _AC.DoAction(acChangeDbgState, []);\r\nend;\r\n\r\nprocedure TDebugerThread.OnLoadDll(Sender: TObject; ThreadId: TThreadId; Data: PLoadDLLDebugInfo);\r\nconst\r\n  FormatStrKnownDLL = 'Load Dll at instance $%p handle %d \"%s\"';\r\n  FormatStrUnknownDLL = 'Load unknown Dll at instance $%p handle %d';\r\nvar\r\n  DllName: AnsiString;\r\n  IsUnicodeData: LongBool;\r\nbegin\r\n  //FDebuger.ContinueStatus := DBG_EXCEPTION_NOT_HANDLED;\r\n  IsUnicodeData := Data^.fUnicode = 1;\r\n  DllName := gvDebuger.GetDllName(Data^.lpImageName, Data^.lpBaseOfDll, IsUnicodeData);\r\n  if DllName <> '' then\r\n  begin\r\n    if IsUnicodeData then\r\n      _AC.Log(dltDLLEvent, FormatStrKnownDLL, [Data^.lpBaseOfDll, Data^.hFile, PWideChar(@DllName[1])])\r\n    else\r\n      _AC.Log(dltDLLEvent, Format(FormatStrKnownDLL, [Data^.lpBaseOfDll, Data^.hFile, PAnsiChar(@DllName[1])]));\r\n  end\r\n  else\r\n    _AC.Log(dltDLLEvent, Format(FormatStrUnknownDLL, [Data^.lpBaseOfDll, Data^.hFile]));\r\nend;\r\n\r\nprocedure TDebugerThread.OnProgress(const Action: String; const Progress: Integer);\r\nbegin\r\n  _AC.DoAction(acProgress, [Action, Progress]);\r\nend;\r\n\r\nprocedure TDebugerThread.OnRip(Sender: TObject; ThreadId: TThreadId; Data: PRIPInfo);\r\nbegin\r\n  _AC.Log(dltError, 'Debug fail [error: %d; type: %d]', [Data^.dwError, Data^.dwType]);\r\nend;\r\n\r\nprocedure TDebugerThread.OnUnknownBreakPoint(Sender: TObject; ThreadId: TThreadId; ExceptionRecord: PExceptionRecord);\r\nbegin\r\n  _AC.Log(dltBreakPointEvent, 'OnUnknownBreakPoint ThreadID: %d', [ThreadId]);\r\nend;\r\n\r\nprocedure TDebugerThread.OnUnknownException(Sender: TObject; ThreadId: TThreadId; ExceptionRecord: PExceptionRecord);\r\nbegin\r\n  //_AC.Log(gvDebugInfo.GetExceptionMessage(ExceptionRecord, ThreadId));\r\nend;\r\n\r\nprocedure TDebugerThread.OnUnLoadDll(Sender: TObject; ThreadId: TThreadId; Data: PUnloadDLLDebugInfo);\r\nconst\r\n  FormatStrDLL = 'UnLoad Dll at instance $%p';\r\nbegin\r\n  _AC.Log(dltDLLEvent, FormatStrDLL, [Data^.lpBaseOfDll]);\r\nend;\r\n\r\nend.\r\n"
  },
  {
    "path": "uExceptionHook.pas",
    "content": "unit uExceptionHook;\r\n\r\ninterface\r\n\r\nuses Classes, SysUtils, Windows;\r\n\r\nimplementation\r\n\r\nconst\r\n  MAX_STACK_LENGTH = 16;\r\n\r\ntype\r\n  PStackFrame = ^TStackFrame;\r\n  TStackFrame = record\r\n    CallerFrame: Pointer;\r\n    CallerAddr: Pointer;\r\n  end;\r\n\r\n  NT_TIB32 = packed record\r\n    ExceptionList: DWORD;\r\n    StackBase: DWORD;\r\n    StackLimit: DWORD;\r\n    SubSystemTib: DWORD;\r\n    case Integer of\r\n      0 : (\r\n        FiberData: DWORD;\r\n        ArbitraryUserPointer: DWORD;\r\n        Self: DWORD;\r\n      );\r\n      1 : (\r\n        Version: DWORD;\r\n      );\r\n  end;\r\n\r\nthreadvar\r\n  _Buf: TMemoryBasicInformation;\r\n\r\nvar\r\n  OldDebugHook: Byte = 0;\r\n  InDebugMode: LongBool = False;\r\n\r\nfunction IsValidCodeAddr(const Addr: Pointer): LongBool;\r\nconst\r\n  _PAGE_CODE: Cardinal = (PAGE_EXECUTE Or PAGE_EXECUTE_READ or PAGE_EXECUTE_READWRITE Or PAGE_EXECUTE_WRITECOPY);\r\nBegin\r\n  Result := (VirtualQuery(Addr, _Buf, SizeOf(TMemoryBasicInformation)) <> 0) And ((_Buf.Protect And _PAGE_CODE) <> 0);\r\nend;\r\n\r\nfunction IsValidAddr(const Addr: Pointer): LongBool;\r\nBegin\r\n  Result := (VirtualQuery(Addr, _Buf, SizeOf(TMemoryBasicInformation)) <> 0);\r\nend;\r\n\r\nfunction GetStackTop: Pointer; assembler;\r\nasm\r\n  MOV     EAX, FS:[0].NT_TIB32.StackBase\r\nend;\r\n\r\nfunction GetCallStack(const EIP, EBP: Pointer): TList; overload;\r\nvar\r\n  TopOfStack: Pointer;\r\n  BaseOfStack: Pointer;\r\n  StackFrame: PStackFrame;\r\n  Level: Integer;\r\nbegin\r\n  Result := TList.Create;\r\n  try\r\n    Level := 0; //   \r\n\r\n    Result.Add(EIP);\r\n\r\n    StackFrame := EBP;\r\n    BaseOfStack := Pointer(Cardinal(StackFrame) - 1);\r\n\r\n    TopOfStack := GetStackTop;\r\n    while (Level < MAX_STACK_LENGTH) and (\r\n        (Cardinal(BaseOfStack) < Cardinal(StackFrame)) and\r\n        (Cardinal(StackFrame) < Cardinal(TopOfStack)) and\r\n        IsValidAddr(StackFrame) and\r\n        (StackFrame <> StackFrame^.CallerFrame) and\r\n        IsValidCodeAddr(StackFrame^.CallerAddr)\r\n      )\r\n    do begin\r\n      if Level >= 0 then\r\n        Result.Add(Pointer(Cardinal(StackFrame^.CallerAddr) - 1));\r\n\r\n      StackFrame := PStackFrame(StackFrame^.CallerFrame);\r\n\r\n      Inc(Level);\r\n    end;\r\n  except\r\n    // Skip\r\n  end;\r\nend;\r\n\r\nfunction GetCallStack(Context: PContext): TList; overload;\r\nbegin\r\n  Result := GetCallStack(Pointer(Context^.Eip), Pointer(Context^.Ebp));\r\nend;\r\n\r\nprocedure _CleanUpStackInfoProc(Info: Pointer);\r\nbegin\r\n  FreeAndNil(Info);\r\nend;\r\n\r\nfunction _GetStackInfoStringProc(Info: Pointer): String;\r\nvar\r\n  StackList: TList;\r\n  I: Integer;\r\nbegin\r\n  Result := '';\r\n  if Assigned(Info) then\r\n  begin\r\n    StackList := TList(Info);\r\n\r\n    for I := 0 to StackList.Count - 1 do\r\n    begin\r\n      if Result <> '' then\r\n        Result := Result + ' ';\r\n\r\n      Result := Result + Format('%p', [StackList[I]]);\r\n    end;\r\n  end;\r\nend;\r\n\r\nvar\r\n  _BaseRaiseExceptionProc: TRaiseExceptionProc = nil;\r\n\r\ntype\r\n  TParamArray = array[0..14] of Pointer;\r\n  HookException = class(Exception);\r\n\r\nconst\r\n  cNonDelphiException = $0EEDFAE4;\r\n  cDelphiException    = $0EEDFADE;\r\n  cContinuable        = 0;\r\n\r\nprocedure _RaiseExceptionProc(ExceptionCode, ExceptionFlags: LongWord; NumberOfArguments: LongWord; Args: Pointer); stdcall;\r\nvar\r\n  ContextRecord: PContext;\r\n  ExceptionObj: HookException;\r\nbegin\r\n  if InDebugMode then\r\n  begin\r\n    //      \r\n    _BaseRaiseExceptionProc(ExceptionCode, ExceptionFlags, NumberOfArguments, Args);\r\n  end\r\n  else\r\n  begin\r\n    if (ExceptionCode = cNonDelphiException) then\r\n    begin\r\n      ContextRecord := TParamArray(Args^)[0];\r\n      ExceptionObj := TParamArray(Args^)[1];\r\n      ExceptionObj.SetStackInfo(GetCallStack(ContextRecord));\r\n    end\r\n    else\r\n    if (ExceptionCode = cDelphiException) and (ExceptionFlags <> cContinuable) then\r\n    begin\r\n      ExceptionObj := TParamArray(Args^)[1]; // Except object\r\n      ExceptionObj.SetStackInfo(GetCallStack(TParamArray(Args^)[0]{Address}, TParamArray(Args^)[5]{Stack frame}));\r\n    end;\r\n\r\n    if ExceptionFlags <> cContinuable then\r\n    begin\r\n      if not InDebugMode then\r\n        DebugHook := OldDebugHook;\r\n      try\r\n        _BaseRaiseExceptionProc(ExceptionCode, ExceptionFlags, NumberOfArguments, Args)\r\n      finally\r\n        if not InDebugMode then\r\n          DebugHook := 1;\r\n      end;\r\n    end;\r\n  end;\r\nend;\r\n\r\nprocedure _InitExceptionHook;\r\nbegin\r\n  //      \r\n  {$IFNDEF DEBUG}\r\n  SetErrorMode(SEM_FAILCRITICALERRORS or SEM_NOGPFAULTERRORBOX or SEM_NOALIGNMENTFAULTEXCEPT or SEM_NOOPENFILEERRORBOX);\r\n  {$ENDIF}\r\n\r\n  //    \r\n  InDebugMode := (DebugHook <> 0);\r\n\r\n  OldDebugHook := DebugHook;\r\n\r\n  if not InDebugMode then\r\n    DebugHook := 1; //   RaiseExceptionProc\r\n\r\n  //if not InDebugMode then\r\n  begin\r\n    _BaseRaiseExceptionProc := RaiseExceptionProc;\r\n    RaiseExceptionProc := @_RaiseExceptionProc;\r\n\r\n    Exception.CleanUpStackInfoProc := @_CleanUpStackInfoProc;\r\n    Exception.GetStackInfoStringProc := @_GetStackInfoStringProc;\r\n  end;\r\nend;\r\n\r\nprocedure _ReleaseExceptionHook;\r\nbegin\r\n  if not InDebugMode then\r\n    DebugHook := OldDebugHook;\r\n\r\n  //if not InDebugMode then\r\n  begin\r\n    RaiseExceptionProc := @_BaseRaiseExceptionProc;\r\n\r\n    Exception.CleanUpStackInfoProc := nil;\r\n    Exception.GetStackInfoStringProc := nil;\r\n  end;\r\nend;\r\n\r\ninitialization\r\n  _InitExceptionHook;\r\n\r\nfinalization\r\n  _ReleaseExceptionHook;\r\n\r\nend.\r\n"
  },
  {
    "path": "uFastList.pas",
    "content": "unit uFastList;\r\n\r\ninterface\r\n\r\nuses\r\n  Classes, Sysutils;\r\n\r\ntype\r\n  TListSorted = class(TList)\r\n  private\r\n    //FValues: TList;\r\n\r\n    // Allow duplicate objects in the\r\n    // list of objects based on\r\n    // compare(item1,item2) = 0\r\n    // Default to dupIgnore (dupes ok)\r\n    Duplicates : TDuplicates;\r\n  public\r\n    procedure AfterConstruction; override;\r\n    destructor Destroy; override;\r\n    constructor Create;\r\n\r\n    // an abstract compare function\r\n    // this should be overridden by an inheriting class\r\n    // it should return   -1 if item1 < item2\r\n    //                    0 if item1 = item2\r\n    //                    1 if item1 > item2\r\n    function Compare(Item1, Item2: Pointer; const aFindMode: LongBool): Integer; virtual; abstract;\r\n\r\n    //function AddKeyValue(Key, Value: Pointer): Integer;\r\n    function Add(Item: Pointer): Integer;\r\n\r\n    // returns the index of Item using the compare method to find\r\n    // the object\r\n    // note: if more than one object matches using the compare method,\r\n    //       this does not look for the same memory address by\r\n    //       matching the pointers, it looks for the same value\r\n    //       ie compare method returns 0\r\n    // then any one of those matching could be returned\r\n    // The index returned, ranges from 0 to Count-1\r\n    // A value of -1 indicates that no Item was found\r\n    function FindObject(Item : Pointer) : Integer;\r\n  end;\r\n\r\nimplementation\r\n\r\nprocedure TListSorted.AfterConstruction;\r\nbegin\r\n  inherited;\r\n  //FValues := TList.Create;\r\nend;\r\n\r\nconstructor TListSorted.Create;\r\nbegin\r\n   Duplicates := dupIgnore;\r\n   inherited Create;\r\nend;\r\n\r\ndestructor TListSorted.Destroy;\r\nbegin\r\n  //FValues.Free;\r\n  inherited;\r\nend;\r\n\r\n//function TListSorted.AddKeyValue(Key, Value: Pointer): Integer;\r\nfunction TListSorted.Add(Item: Pointer): Integer;\r\nvar\r\n   nCount  : Integer;\r\n   bFound  : LongBool;\r\n   nResult : Integer;\r\nbegin\r\n   nCount := 0;\r\n   bFound := False;\r\n   // search the list of objects until we find the\r\n   // correct position for the new object we are adding\r\n   while (not bFound) and (nCount < Count) do\r\n   begin\r\n      if (Compare(Items[nCount], Item, False) >= 0) then\r\n         bFound := True\r\n      else\r\n         inc(nCount);\r\n   end;\r\n   if (bFound) then\r\n   begin\r\n      if (Duplicates = dupIgnore) or (Compare(Items[nCount], Item, False) <> 0) then\r\n      begin\r\n         Insert(nCount,Item);\r\n         nResult := nCount;\r\n      end\r\n      else\r\n         nResult := -1;\r\n   end\r\n   else\r\n      nResult := inherited Add(Item);\r\n   Add := nResult;\r\nend;\r\n\r\nfunction TListSorted.FindObject(Item : Pointer) : Integer;\r\n// Find the object using the compare method and\r\n// a binary chop search\r\nvar\r\n   nResult   : Integer;\r\n   nLow      : Integer;\r\n   nHigh     : Integer;\r\n   nCompare  : Integer;\r\n   nCheckPos : Integer;\r\nbegin\r\n   nLow := 0;\r\n   nHigh := Count-1;\r\n   nResult := -1;\r\n   Result := -1;\r\n   // keep searching until found or\r\n   // no more items to search\r\n   while (nResult = -1) and (nLow <= nHigh) do\r\n   begin\r\n      nCheckPos := (nLow + nHigh) div 2;\r\n      nCompare := Compare(Item, Items[nCheckPos], True);\r\n      if (nCompare <= -1) then                // less than\r\n        nHigh := nCheckPos - 1\r\n      else if (nCompare >= 1) then            // greater than\r\n      begin\r\n        FindObject := nCheckPos; //best c.q. last c.q. lowest result\r\n        nLow := nCheckPos + 1\r\n      end\r\n      else                                  // equal to\r\n      begin\r\n        nResult := nCheckPos;\r\n        Exit;\r\n      end;\r\n   end;\r\n   //FindObject := nCheckPos; //nResult;   best c.q. last result\r\nend;\r\n\r\nend.\r\n"
  },
  {
    "path": "uFeedback.dfm",
    "content": "object frmFeedback: TfrmFeedback\r\n  Left = 0\r\n  Top = 0\r\n  ActiveControl = mMessage\r\n  BorderIcons = [biSystemMenu]\r\n  BorderStyle = bsSingle\r\n  Caption = 'Add comment'\r\n  ClientHeight = 334\r\n  ClientWidth = 537\r\n  Color = clBtnFace\r\n  Font.Charset = DEFAULT_CHARSET\r\n  Font.Color = clWindowText\r\n  Font.Height = -11\r\n  Font.Name = 'Tahoma'\r\n  Font.Style = []\r\n  OldCreateOrder = False\r\n  Position = poScreenCenter\r\n  OnCreate = FormCreate\r\n  PixelsPerInch = 96\r\n  TextHeight = 13\r\n  object lbFeedbackType: TLabel\r\n    Left = 8\r\n    Top = 8\r\n    Width = 70\r\n    Height = 13\r\n    Caption = 'Comment type'\r\n  end\r\n  object lbMessage: TLabel\r\n    Left = 8\r\n    Top = 64\r\n    Width = 42\r\n    Height = 13\r\n    Caption = 'Message'\r\n  end\r\n  object lbEmail: TLabel\r\n    Left = 232\r\n    Top = 8\r\n    Width = 77\r\n    Height = 13\r\n    Caption = 'E-mail (optional)'\r\n  end\r\n  object cbbType: TComboBoxEx\r\n    Left = 8\r\n    Top = 24\r\n    Width = 193\r\n    Height = 22\r\n    ItemsEx = <\r\n      item\r\n        Caption = 'Have question'\r\n      end\r\n      item\r\n        Caption = 'Error found'\r\n      end\r\n      item\r\n        Caption = 'New idea'\r\n      end\r\n      item\r\n        Caption = 'Other'\r\n      end>\r\n    Style = csExDropDownList\r\n    TabOrder = 0\r\n  end\r\n  object mMessage: TMemo\r\n    Left = 8\r\n    Top = 80\r\n    Width = 513\r\n    Height = 201\r\n    Lines.Strings = (\r\n      'mMessage')\r\n    ScrollBars = ssVertical\r\n    TabOrder = 2\r\n  end\r\n  object btnSend: TBitBtn\r\n    Left = 440\r\n    Top = 295\r\n    Width = 81\r\n    Height = 28\r\n    Action = acSend\r\n    Caption = 'Send'\r\n    TabOrder = 3\r\n  end\r\n  object eEMail: TEdit\r\n    Left = 232\r\n    Top = 24\r\n    Width = 289\r\n    Height = 21\r\n    TabOrder = 1\r\n  end\r\n  object AL: TActionList\r\n    Images = dmShareData.ilActionsSmall\r\n    Left = 320\r\n    Top = 136\r\n    object acSend: TAction\r\n      Caption = 'Send'\r\n      ImageIndex = 1\r\n      OnExecute = acSendExecute\r\n    end\r\n  end\r\nend\r\n"
  },
  {
    "path": "uFeedback.pas",
    "content": "unit uFeedback;\r\n\r\ninterface\r\n\r\nuses\r\n  Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,\r\n  Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls, Vcl.ComCtrls,\r\n  Vcl.Buttons, System.Actions, Vcl.ActnList;\r\n\r\ntype\r\n  TfrmFeedback = class(TForm)\r\n    cbbType: TComboBoxEx;\r\n    lbFeedbackType: TLabel;\r\n    lbMessage: TLabel;\r\n    mMessage: TMemo;\r\n    btnSend: TBitBtn;\r\n    AL: TActionList;\r\n    acSend: TAction;\r\n    lbEmail: TLabel;\r\n    eEMail: TEdit;\r\n    procedure acSendExecute(Sender: TObject);\r\n    procedure FormCreate(Sender: TObject);\r\n  private\r\n    function GetFeedbackText: String;\r\n    function GetFeedbackType: String;\r\n    { Private declarations }\r\n  public\r\n    property FeedbackType: String read GetFeedbackType;\r\n    property FeedbackText: String read GetFeedbackText;\r\n  end;\r\n\r\nvar\r\n  frmFeedback: TfrmFeedback;\r\n\r\nimplementation\r\n\r\nuses\r\n  uShareData;\r\n\r\n{$R *.dfm}\r\n\r\nprocedure TfrmFeedback.acSendExecute(Sender: TObject);\r\nbegin\r\n  ModalResult := mrOk;\r\nend;\r\n\r\nprocedure TfrmFeedback.FormCreate(Sender: TObject);\r\nbegin\r\n  cbbType.ItemIndex := 0;\r\n  mMessage.Text := '';\r\nend;\r\n\r\nfunction TfrmFeedback.GetFeedbackText: String;\r\nbegin\r\n  Result := Format('[%s] %s', [eEMail.Text, mMessage.Text]);\r\nend;\r\n\r\nfunction TfrmFeedback.GetFeedbackType: String;\r\nbegin\r\n  Result := cbbType.ItemsEx.ComboItems[cbbType.ItemIndex].Caption;\r\nend;\r\n\r\nend.\r\n"
  },
  {
    "path": "uGA.pas",
    "content": "unit uGA;\r\n\r\ninterface\r\n\r\nuses System.Classes, System.SysUtils, System.Generics.Collections, IdHTTP;\r\n\r\ntype\r\n  TGAType = (gatPageview, gatAppview, gatEvent, gatTransaction, gatItem, gatSocial, gatException, gatTiming);\r\n\r\n  TGAParamType = (\r\n    // General\r\n    gapVersion, gapTrackingID, gapAnonymizeIP, gapQueueTime, gapCacheBuster,\r\n    // Visitor\r\n    gapClientID,\r\n    // Session\r\n    gapSessionControl,\r\n    // Traffic Sources\r\n    gapDocumentReferrer, gapCampaignName, gapCampaignSource, gapCampaignMedium, gapCampaignKeyword, gapCampaignContent,\r\n    gapCampaignID, gapGoogleAdWordsID, gapGoogleDisplayAdsID,\r\n    // System Info\r\n    gapScreenResolution, gapViewportSize, gapDocumentEncoding, gapScreenColors, gapUserLanguage, gapJavaEnabled, gapFlashVersion,\r\n    // Hit\r\n    gapHitType, gapNonInteractionHit,\r\n    // Content Information\r\n    gapDocumentLocationURL, gapDocumentHostName, gapDocumentPath, gapDocumentTitle, gapContentDescription,\r\n    // App Tracking\r\n    gapApplicationName, gapApplicationVersion,\r\n    // Event Tracking\r\n    gapEventCategory, gapEventAction, gapEventLabel, gapEventValue,\r\n    // E-Commerce\r\n    gapTransactionID, gapTransactionAffiliation, gapTransactionRevenue, gapTransactionShipping, gapTransactionTax,\r\n    gapItemName, gapItemPrice, gapItemQuantity, gapItemCode, gapItemCategory, gapCurrencyCode,\r\n    // Social Interactions\r\n    gapSocialNetwork, gapSocialAction, gapSocialActionTarget,\r\n    // Timing\r\n    gapUserTimingCategory, gapUserTimingVariableName, gapUserTimingTime, gapUserTimingLabel, gapPageLoadTime,\r\n    gapDNSTime, gapPageDownloadTime, gapRedirectResponseTime, gapTCPConnectTime, gapServerResponseTime,\r\n    // Exceptions\r\n    gapExceptionDescription, gapIsExceptionFatal,\r\n    // Custom Dimensions / Metrics\r\n    gapCustomDimension1, gapCustomMetric1\r\n  );\r\n\r\n  TGAParam = TPair;\r\n  TGAParams = TDictionary;\r\n\r\n  TGA = class\r\n  private\r\n    FBaseParams: TGAParams;\r\n    FParams: TGAParams;\r\n    FSendFilterList: TStringList;\r\n\r\n    function GetTrackingID: string;\r\n    procedure SetTrackingID(const Value: string);\r\n    function GetAppName: string;\r\n    procedure SetAppName(const Value: string);\r\n    function GetAppVersion: string;\r\n    procedure SetAppVersion(const Value: string);\r\n    function GetClientID: string;\r\n    procedure SetClientID(const Value: string);\r\n    function GetUserLanguage: string;\r\n    procedure SetUserLanguage(const Value: string);\r\n    function GetHTTP: TIdHTTP;\r\n    function GetSendFilter: string;\r\n    procedure SetSendFilter(const Value: string);\r\n  protected\r\n    function GetParamStr: string;\r\n    procedure DoSend; virtual;\r\n\r\n    function CheckFilter(const Str: String): Boolean; virtual;\r\n\r\n    property Params: TGAParams read FParams;\r\n    property BaseParams: TGAParams read FBaseParams;\r\n  public\r\n    constructor Create;\r\n    destructor Destroy; override;\r\n\r\n    procedure SendEvent(const Category, Action: string; const ELabel: string = ''; const Value: Integer = 0;\r\n      const ExtParam1: String = '');\r\n    procedure SendException(const Description: string; const IsFatal: Boolean = False);\r\n\r\n    procedure SendFeedback(const SocialNetwork, SocialAction, SocialActionTarget: String);\r\n\r\n    procedure SessionStart;\r\n    procedure SessionEnd;\r\n\r\n    property HTTP: TIdHTTP read GetHTTP;\r\n\r\n    property TrackingID: string read GetTrackingID write SetTrackingID;\r\n    property ClientID: string read GetClientID write SetClientID;\r\n    property AppName: string read GetAppName write SetAppName;\r\n    property AppVersion: string read GetAppVersion write SetAppVersion;\r\n    property UserLanguage: string read GetUserLanguage write SetUserLanguage;\r\n    property SendFilter: string read GetSendFilter write SetSendFilter;\r\n  end;\r\n\r\nimplementation\r\n\r\nuses IdGlobal, IdUriUtils, System.SyncObjs, Winapi.Windows;\r\n\r\nconst\r\n  GA_URL = 'http://www.google-analytics.com/collect';\r\n  GA_VERSION = '1';\r\n\r\n  GA_HIT_TYPES: array[Low(TGAType)..High(TGAType)] of string =\r\n    ('pageview', 'appview', 'event', 'transaction', 'item', 'social', 'exception', 'timing');\r\n\r\n  GA_PARAMS: array[Low(TGAParamType)..High(TGAParamType)] of string = (\r\n    'v', 'tid', 'aip', 'qt', 'z', 'cid', 'sc', 'dr', 'cn', 'cs', 'cm', 'ck', 'cc', 'ci', 'gclid', 'dclid', 'sr',\r\n    'vp', 'de', 'sd', 'ul', 'je', 'fl', 't', 'ni', 'dl', 'dh', 'dp', 'dt', 'cd', 'an', 'av', 'ec', 'ea', 'el', 'ev',\r\n    'ti', 'ta', 'tr', 'ts', 'tt', 'in', 'ip', 'iq', 'ic', 'iv', 'cu', 'sn', 'sa', 'st', 'utc', 'utv', 'utt', 'utl',\r\n    'plt', 'dns', 'pdt', 'rrt', 'tcp', 'srt', 'exd', 'exf', 'cd1', 'cm1'\r\n  );\r\n\r\n  GA_TIMEOUT = 1000;\r\n\r\ntype\r\n  TGAQueue = TQueue;\r\n\r\n  TGASender = class(TThread)\r\n  private\r\n    FQueue: TGAQueue;\r\n    FQueueEvent: TEvent;\r\n    FQueueCS: TCriticalSection;\r\n    FHTTP: TIdHTTP;\r\n    procedure ThSleep(const MSec: Integer);\r\n  protected\r\n    function DoSend(const Data: string): Boolean;\r\n    procedure Execute; override;\r\n  public\r\n    constructor Create;\r\n    destructor Destroy; override;\r\n\r\n    procedure Send(const Data: string);\r\n\r\n    property HTTP: TIdHTTP read FHTTP;\r\n  end;\r\n\r\nvar\r\n  gvGASender: TGASender = nil;\r\n\r\nfunction ParamEncode(const ASrc: string): string;\r\nconst\r\n  _VALID_CHARS = 'abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789.-_~';\r\nvar\r\n  I, J, CharLen, ByteLen: Integer;\r\n  Buf: TIdBytes;\r\n  LChar: WideChar;\r\n  AByteEncoding: IIdTextEncoding;\r\nbegin\r\n  Result := '';\r\n\r\n  if ASrc = '' then\r\n    Exit;\r\n\r\n  AByteEncoding := nil;\r\n  EnsureEncoding(AByteEncoding, encUTF8);\r\n\r\n  SetLength(Buf, AByteEncoding.GetMaxByteCount(2));\r\n\r\n  I := 1;\r\n  while I <= Length(ASrc) do\r\n  begin\r\n    LChar := ASrc[I];\r\n\r\n    if Pos(LChar, _VALID_CHARS) = 0 then\r\n    begin\r\n      CharLen := CalcUTF16CharLength(ASrc, I);\r\n\r\n      ByteLen := AByteEncoding.GetBytes(ASrc, I, CharLen, Buf, 0);\r\n      for J := 0 to ByteLen - 1 do\r\n        Result := Result + '%' + IntToHex(Ord(Buf[J]), 2);\r\n\r\n      Inc(I, CharLen);\r\n    end\r\n    else\r\n    begin\r\n      Result := Result + Char(LChar);\r\n      Inc(I);\r\n    end;\r\n  end;\r\nend;\r\n\r\n\r\n{ TGA }\r\n\r\nfunction TGA.CheckFilter(const Str: String): Boolean;\r\nbegin\r\n  Result := (FSendFilterList.IndexOf(Str) = -1);\r\nend;\r\n\r\nconstructor TGA.Create;\r\nbegin\r\n  inherited Create;\r\n\r\n  FBaseParams := TGAParams.Create;\r\n  FParams := TGAParams.Create;\r\n\r\n  FSendFilterList := TStringList.Create;\r\n  FSendFilterList.Delimiter := ',';\r\n  FSendFilterList.StrictDelimiter := True;\r\n  FSendFilterList.CaseSensitive := False;\r\n\r\n  FBaseParams.Add(gapVersion, GA_VERSION);\r\nend;\r\n\r\ndestructor TGA.Destroy;\r\nbegin\r\n  FreeAndNil(FBaseParams);\r\n  FreeAndNil(FParams);\r\n  FreeAndNil(FSendFilterList);\r\n\r\n  inherited;\r\nend;\r\n\r\nprocedure TGA.DoSend;\r\nbegin\r\n  gvGASender.Send(GetParamStr);\r\nend;\r\n\r\nfunction TGA.GetAppName: string;\r\nbegin\r\n  Result := FBaseParams[gapApplicationName];\r\nend;\r\n\r\nfunction TGA.GetAppVersion: string;\r\nbegin\r\n  Result := FBaseParams[gapApplicationVersion];\r\nend;\r\n\r\nfunction TGA.GetClientID: string;\r\nbegin\r\n  Result := FBaseParams[gapClientID];\r\nend;\r\n\r\nfunction TGA.GetHTTP: TIdHTTP;\r\nbegin\r\n  Result := gvGASender.HTTP;\r\nend;\r\n\r\nfunction TGA.GetParamStr: string;\r\nvar\r\n  P: TGAParam;\r\nbegin\r\n  Result := '';\r\n\r\n  for P in FBaseParams Do\r\n  begin\r\n    if Result <> '' then\r\n      Result := Result + '&';\r\n\r\n    Result := Result + GA_PARAMS[P.Key] + '=' + ParamEncode(P.Value);\r\n  end;\r\n\r\n  for P in FParams Do\r\n  begin\r\n    if Result <> '' then\r\n      Result := Result + '&';\r\n\r\n    Result := Result + GA_PARAMS[P.Key] + '=' + ParamEncode(P.Value);\r\n  end;\r\nend;\r\n\r\nfunction TGA.GetSendFilter: string;\r\nbegin\r\n  Result := FSendFilterList.DelimitedText;\r\nend;\r\n\r\nfunction TGA.GetTrackingID: string;\r\nbegin\r\n  Result := FBaseParams[gapTrackingID];\r\nend;\r\n\r\nfunction TGA.GetUserLanguage: string;\r\nbegin\r\n  Result := FBaseParams[gapUserLanguage];\r\nend;\r\n\r\nprocedure TGA.SendEvent(const Category, Action: string; const ELabel: string = ''; const Value: Integer = 0;\r\n  const ExtParam1: String = '');\r\nbegin\r\n  if not CheckFilter(Category) or not CheckFilter(Action) or not CheckFilter(ELabel) then Exit;\r\n\r\n  Params.Clear;\r\n  Params.Add(gapHitType, GA_HIT_TYPES[gatEvent]);\r\n\r\n  Params.Add(gapEventCategory, Category);\r\n  Params.Add(gapEventAction, Action);\r\n  Params.Add(gapEventLabel, ELabel);\r\n  Params.Add(gapEventValue, IntToStr(Value));\r\n\r\n  if ExtParam1 <> '' then\r\n  begin\r\n    Params.Add(gapCustomDimension1, ExtParam1);\r\n  end;\r\n\r\n  DoSend;\r\nend;\r\n\r\nprocedure TGA.SendException(const Description: string; const IsFatal: Boolean);\r\nbegin\r\n  Params.Clear;\r\n  Params.Add(gapHitType, GA_HIT_TYPES[gatException]);\r\n\r\n  Params.Add(gapExceptionDescription, Description);\r\n  if IsFatal then\r\n    Params.Add(gapIsExceptionFatal, '1')\r\n  else\r\n    Params.Add(gapIsExceptionFatal, '0');\r\n\r\n  DoSend;\r\nend;\r\n\r\nprocedure TGA.SendFeedback(const SocialNetwork, SocialAction, SocialActionTarget: String);\r\nbegin\r\n  Params.Clear;\r\n  Params.Add(gapHitType, GA_HIT_TYPES[gatSocial]);\r\n\r\n  Params.Add(gapSocialNetwork, SocialNetwork);\r\n  Params.Add(gapSocialAction, SocialAction);\r\n  Params.Add(gapSocialActionTarget, SocialActionTarget);\r\n\r\n  DoSend;\r\nend;\r\n\r\nprocedure TGA.SessionEnd;\r\nbegin\r\n  Params.Clear;\r\n  Params.Add(gapHitType, GA_HIT_TYPES[gatEvent]); //???\r\n  Params.Add(gapSessionControl, 'end');\r\n\r\n  DoSend;\r\nend;\r\n\r\nprocedure TGA.SessionStart;\r\nbegin\r\n  Params.Clear;\r\n  Params.Add(gapHitType, GA_HIT_TYPES[gatEvent]); //???\r\n  Params.Add(gapSessionControl, 'start');\r\n\r\n  DoSend;\r\nend;\r\n\r\nprocedure TGA.SetAppName(const Value: string);\r\nbegin\r\n  FBaseParams.AddOrSetValue(gapApplicationName, Value);\r\nend;\r\n\r\nprocedure TGA.SetAppVersion(const Value: string);\r\nbegin\r\n  FBaseParams.AddOrSetValue(gapApplicationVersion, Value);\r\nend;\r\n\r\nprocedure TGA.SetClientID(const Value: string);\r\nbegin\r\n  FBaseParams.AddOrSetValue(gapClientID, Value);\r\nend;\r\n\r\nprocedure TGA.SetSendFilter(const Value: string);\r\nvar\r\n  S: String;\r\nbegin\r\n  FSendFilterList.Clear;\r\n\r\n  if Value <> '' then\r\n  begin\r\n    S := StringReplace(Value, ' ', '', [rfReplaceAll]);\r\n    if S <> '' then\r\n    begin\r\n      if (S[1] = '(') and (S[Length(S)] = ')') then\r\n        S := Copy(S, 2, Length(S) - 2);\r\n\r\n      if S <> '' then\r\n        FSendFilterList.DelimitedText := S;\r\n    end;\r\n  end;\r\nend;\r\n\r\nprocedure TGA.SetTrackingID(const Value: string);\r\nbegin\r\n  FBaseParams.AddOrSetValue(gapTrackingID, Value);\r\nend;\r\n\r\nprocedure TGA.SetUserLanguage(const Value: string);\r\nbegin\r\n  FBaseParams.AddOrSetValue(gapUserLanguage, Value);\r\nend;\r\n\r\n{ TGASender }\r\n\r\nconstructor TGASender.Create;\r\nbegin\r\n  inherited Create(False);\r\n\r\n  FreeOnTerminate := False; // free on finalization\r\n\r\n  //FHTTP := TIdHTTP.Create(nil);\r\n  FQueue := TGAQueue.Create;\r\n  FQueueEvent := TEvent.Create;\r\n  FQueueCS := TCriticalSection.Create;\r\nend;\r\n\r\ndestructor TGASender.Destroy;\r\nbegin\r\n  try\r\n    FQueueCS.Enter;\r\n    try\r\n      FQueue.Clear;\r\n      FreeAndNil(FQueue);\r\n    finally\r\n      FQueueCS.Leave;\r\n    end;\r\n\r\n    FreeAndNil(FQueueCS);\r\n    FreeAndNil(FQueueEvent);\r\n\r\n    //FreeAndNil(FHTTP);\r\n  except\r\n    //  Log  \r\n  end;\r\n\r\n  inherited;\r\nend;\r\n\r\nfunction TGASender.DoSend(const Data: string): Boolean;\r\nvar\r\n  S: TStringStream;\r\n\r\nbegin\r\n  {$IFDEF DEBUG}\r\n  Result := True;\r\n  Exit;\r\n  {$ENDIF}\r\n\r\n  if (Self = Nil) or Terminated then\r\n  begin\r\n    Result := True;\r\n    Exit;\r\n  end;\r\n\r\n  Result := False;\r\n\r\n  S := TStringStream.Create(Data);\r\n  try\r\n    try\r\n      FHTTP.Post(GA_URL, S);\r\n\r\n      if (Self <> Nil) and not Terminated then\r\n        Result := (FHTTP.ResponseCode = 200);\r\n    except\r\n      //   \r\n    end;\r\n  finally\r\n    FreeAndNil(S);\r\n  end;\r\nend;\r\n\r\nprocedure TGASender.Execute;\r\nvar\r\n  Data: string;\r\nbegin\r\n  NameThreadForDebugging('TGASender');\r\n  try\r\n    FHTTP := TIdHTTP.Create(nil);\r\n    try\r\n      FHTTP.HandleRedirects := True;\r\n\r\n      while (Self <> nil) and not Terminated do\r\n      begin\r\n        if FQueueEvent.WaitFor(100) = wrSignaled then\r\n          while not Terminated and (FQueue.Count > 0) do\r\n          begin\r\n            FQueueCS.Enter;\r\n            try\r\n              Data := FQueue.Dequeue;\r\n              FQueueEvent.ResetEvent;\r\n            finally\r\n              FQueueCS.Leave;\r\n            end;\r\n\r\n            while not DoSend(Data) do\r\n            begin\r\n              if (Self = Nil) or Terminated then Exit;\r\n              ThSleep(GA_TIMEOUT * 60);\r\n            end;\r\n\r\n            ThSleep(GA_TIMEOUT);\r\n          end;\r\n      end;\r\n    finally\r\n      FreeAndNil(FHTTP);\r\n    end;\r\n  except\r\n    //   \r\n  end;\r\nend;\r\n\r\nprocedure TGASender.Send(const Data: string);\r\nbegin\r\n  FQueueCS.Enter;\r\n  try\r\n    FQueue.Enqueue(Data);\r\n    FQueueEvent.SetEvent;\r\n  finally\r\n    FQueueCS.Leave;\r\n  end;\r\nend;\r\n\r\nprocedure TGASender.ThSleep(const MSec: Integer);\r\nvar\r\n  StartTime: Cardinal;\r\nbegin\r\n  StartTime := GetTickCount;\r\n  while (Self <> Nil) and not Terminated and (Abs(GetTickCount - StartTime) < MSec) do\r\n    Sleep(50);\r\nend;\r\n\r\ninitialization\r\n  gvGASender := TGASender.Create;\r\n\r\nfinalization\r\n  try\r\n    gvGASender.Terminate;\r\n    FreeAndNil(gvGASender);\r\n  except end;\r\n\r\nend.\r\n"
  },
  {
    "path": "uMain.dfm",
    "content": "object MainForm: TMainForm\r\n  Left = 0\r\n  Top = 0\r\n  Caption = 'Spider'\r\n  ClientHeight = 885\r\n  ClientWidth = 1395\r\n  Color = clWindow\r\n  Constraints.MinHeight = 600\r\n  Constraints.MinWidth = 800\r\n  Font.Charset = DEFAULT_CHARSET\r\n  Font.Color = clWindowText\r\n  Font.Height = -11\r\n  Font.Name = 'Tahoma'\r\n  Font.Style = []\r\n  OldCreateOrder = False\r\n  Position = poScreenCenter\r\n  WindowState = wsMaximized\r\n  OnCloseQuery = FormCloseQuery\r\n  OnCreate = FormCreate\r\n  OnDestroy = FormDestroy\r\n  OnShow = FormShow\r\n  PixelsPerInch = 96\r\n  TextHeight = 13\r\n  object pcMain: TPageControl\r\n    Left = 0\r\n    Top = 167\r\n    Width = 1395\r\n    Height = 693\r\n    ActivePage = tsMemInfo\r\n    Align = alClient\r\n    TabOrder = 0\r\n    OnChange = pcMainChange\r\n    object tsLog: TTabSheet\r\n      Caption = 'Log'\r\n      object vstLog: TVirtualStringTree\r\n        Left = 0\r\n        Top = 0\r\n        Width = 1387\r\n        Height = 665\r\n        Align = alClient\r\n        BevelEdges = []\r\n        BevelInner = bvNone\r\n        BevelOuter = bvNone\r\n        BorderStyle = bsNone\r\n        ClipboardFormats.Strings = (\r\n          'CSV'\r\n          'HTML Format'\r\n          'Plain text'\r\n          'Rich Text Format'\r\n          'Rich Text Format Without Objects'\r\n          'Unicode text')\r\n        Header.AutoSizeIndex = 0\r\n        Header.Font.Charset = DEFAULT_CHARSET\r\n        Header.Font.Color = clWindowText\r\n        Header.Font.Height = -11\r\n        Header.Font.Name = 'Tahoma'\r\n        Header.Font.Style = []\r\n        Header.Options = [hoColumnResize, hoShowSortGlyphs, hoVisible]\r\n        Indent = 0\r\n        ScrollBarOptions.AlwaysVisible = True\r\n        TabOrder = 0\r\n        TreeOptions.MiscOptions = [toAcceptOLEDrop, toFullRepaintOnResize, toGridExtensions, toInitOnSave, toReportMode, toToggleOnDblClick, toWheelPanning, toEditOnClick]\r\n        TreeOptions.PaintOptions = [toShowDropmark, toShowHorzGridLines, toShowVertGridLines, toThemeAware, toUseBlendedImages, toFullVertGridLines]\r\n        TreeOptions.SelectionOptions = [toExtendedFocus, toFullRowSelect, toMultiSelect]\r\n        TreeOptions.StringOptions = [toAutoAcceptEditChange]\r\n        OnColumnResize = vstLogColumnResize\r\n        OnDrawText = vstLogDrawText\r\n        OnGetText = vstLogGetText\r\n        OnGetNodeDataSize = vstThreadsGetNodeDataSize\r\n        OnResize = vstLogResize\r\n        Columns = <\r\n          item\r\n            Alignment = taRightJustify\r\n            CaptionAlignment = taCenter\r\n            Options = [coAllowClick, coDraggable, coEnabled, coParentBidiMode, coParentColor, coResizable, coShowDropMark, coVisible, coFixed, coAllowFocus, coUseCaptionAlignment]\r\n            Position = 0\r\n            Width = 150\r\n            WideText = 'Event time'\r\n          end\r\n          item\r\n            Options = [coAllowClick, coDraggable, coEnabled, coParentBidiMode, coParentColor, coResizable, coShowDropMark, coVisible, coAllowFocus, coUseCaptionAlignment]\r\n            Position = 1\r\n            Width = 800\r\n            WideText = 'Message'\r\n          end>\r\n      end\r\n    end\r\n    object tsDebugInfo: TTabSheet\r\n      Caption = 'Debug info'\r\n      Highlighted = True\r\n      ImageIndex = 5\r\n      object splDebugInfo: TSplitter\r\n        Left = 362\r\n        Top = 0\r\n        Height = 665\r\n      end\r\n      object vstDbgInfoUnits: TVirtualStringTree\r\n        Left = 0\r\n        Top = 0\r\n        Width = 362\r\n        Height = 665\r\n        Align = alLeft\r\n        BevelEdges = []\r\n        BevelInner = bvNone\r\n        BevelOuter = bvNone\r\n        BorderStyle = bsNone\r\n        ClipboardFormats.Strings = (\r\n          'CSV'\r\n          'HTML Format'\r\n          'Plain text'\r\n          'Rich Text Format'\r\n          'Rich Text Format Without Objects'\r\n          'Unicode text')\r\n        Constraints.MinWidth = 200\r\n        Header.AutoSizeIndex = 0\r\n        Header.Font.Charset = DEFAULT_CHARSET\r\n        Header.Font.Color = clWindowText\r\n        Header.Font.Height = -11\r\n        Header.Font.Name = 'Tahoma'\r\n        Header.Font.Style = []\r\n        Header.Options = [hoColumnResize, hoShowImages, hoVisible, hoHeaderClickAutoSort]\r\n        Header.SortColumn = 0\r\n        IncrementalSearch = isVisibleOnly\r\n        ScrollBarOptions.AlwaysVisible = True\r\n        TabOrder = 0\r\n        TreeOptions.MiscOptions = [toAcceptOLEDrop, toCheckSupport, toFullRepaintOnResize, toGridExtensions, toInitOnSave, toToggleOnDblClick, toWheelPanning, toEditOnClick]\r\n        TreeOptions.PaintOptions = [toShowButtons, toShowDropmark, toShowHorzGridLines, toShowTreeLines, toShowVertGridLines, toThemeAware, toUseBlendedImages, toFullVertGridLines]\r\n        TreeOptions.SelectionOptions = [toExtendedFocus, toFullRowSelect, toMultiSelect]\r\n        OnColumnResize = vstColumnResize\r\n        OnCompareNodes = vstDbgInfoUnitsCompareNodes\r\n        OnDrawText = vstDbgInfoUnitsDrawText\r\n        OnFocusChanged = vstDbgInfoUnitsFocusChanged\r\n        OnGetText = vstDbgInfoUnitsGetText\r\n        OnGetNodeDataSize = vstThreadsGetNodeDataSize\r\n        OnIncrementalSearch = vstDbgInfoUnitsIncrementalSearch\r\n        OnResize = vstTreeResize\r\n        Columns = <\r\n          item\r\n            CaptionAlignment = taCenter\r\n            Options = [coAllowClick, coDraggable, coEnabled, coParentBidiMode, coParentColor, coResizable, coShowDropMark, coVisible, coFixed, coAllowFocus, coUseCaptionAlignment]\r\n            Position = 0\r\n            Width = 210\r\n            WideText = 'Unit name'\r\n          end\r\n          item\r\n            Alignment = taRightJustify\r\n            CaptionAlignment = taCenter\r\n            Options = [coAllowClick, coDraggable, coEnabled, coParentBidiMode, coParentColor, coResizable, coShowDropMark, coVisible, coAllowFocus, coUseCaptionAlignment]\r\n            Position = 1\r\n            Width = 75\r\n            WideText = 'Offset'\r\n          end\r\n          item\r\n            Alignment = taRightJustify\r\n            CaptionAlignment = taCenter\r\n            DefaultSortDirection = sdDescending\r\n            Options = [coAllowClick, coDraggable, coEnabled, coParentBidiMode, coParentColor, coResizable, coShowDropMark, coVisible, coAllowFocus, coUseCaptionAlignment]\r\n            Position = 2\r\n            Width = 60\r\n            WideText = 'Size'\r\n          end>\r\n      end\r\n      object pDbgInfoDetail: TPanel\r\n        Left = 365\r\n        Top = 0\r\n        Width = 1022\r\n        Height = 665\r\n        Align = alClient\r\n        BevelEdges = []\r\n        BevelOuter = bvNone\r\n        Constraints.MinWidth = 400\r\n        TabOrder = 1\r\n        object pcDbgInfoDetail: TPageControl\r\n          Left = 0\r\n          Top = 0\r\n          Width = 1022\r\n          Height = 665\r\n          ActivePage = tsDbgUnitTypes\r\n          Align = alClient\r\n          TabOrder = 0\r\n          object tsDbgUnitConsts: TTabSheet\r\n            Caption = 'Consts'\r\n            object vstDbgInfoConsts: TVirtualStringTree\r\n              Left = 0\r\n              Top = 0\r\n              Width = 1014\r\n              Height = 637\r\n              Align = alClient\r\n              BevelEdges = []\r\n              BevelInner = bvNone\r\n              BevelOuter = bvNone\r\n              BorderStyle = bsNone\r\n              ClipboardFormats.Strings = (\r\n                'CSV'\r\n                'HTML Format'\r\n                'Plain text'\r\n                'Rich Text Format'\r\n                'Rich Text Format Without Objects'\r\n                'Unicode text')\r\n              Header.AutoSizeIndex = 0\r\n              Header.Font.Charset = DEFAULT_CHARSET\r\n              Header.Font.Color = clWindowText\r\n              Header.Font.Height = -11\r\n              Header.Font.Name = 'Tahoma'\r\n              Header.Font.Style = []\r\n              Header.Options = [hoColumnResize, hoShowSortGlyphs, hoVisible]\r\n              IncrementalSearch = isVisibleOnly\r\n              ScrollBarOptions.AlwaysVisible = True\r\n              TabOrder = 0\r\n              TreeOptions.MiscOptions = [toAcceptOLEDrop, toFullRepaintOnResize, toGridExtensions, toInitOnSave, toToggleOnDblClick, toWheelPanning, toEditOnClick]\r\n              TreeOptions.PaintOptions = [toShowButtons, toShowDropmark, toShowHorzGridLines, toShowTreeLines, toShowVertGridLines, toThemeAware, toUseBlendedImages, toFullVertGridLines]\r\n              TreeOptions.SelectionOptions = [toExtendedFocus, toFullRowSelect, toMultiSelect]\r\n              OnCompareNodes = vstDbgInfoConstsCompareNodes\r\n              OnGetText = vstDbgInfoConstsGetText\r\n              OnGetNodeDataSize = vstThreadsGetNodeDataSize\r\n              OnIncrementalSearch = vstDbgInfoConstsIncrementalSearch\r\n              Columns = <\r\n                item\r\n                  CaptionAlignment = taCenter\r\n                  Options = [coAllowClick, coDraggable, coEnabled, coParentBidiMode, coParentColor, coResizable, coShowDropMark, coVisible, coFixed, coAllowFocus, coUseCaptionAlignment]\r\n                  Position = 0\r\n                  Width = 250\r\n                  WideText = 'Const name'\r\n                end\r\n                item\r\n                  Alignment = taRightJustify\r\n                  CaptionAlignment = taCenter\r\n                  Options = [coAllowClick, coDraggable, coEnabled, coParentBidiMode, coParentColor, coResizable, coShowDropMark, coVisible, coAllowFocus, coUseCaptionAlignment]\r\n                  Position = 1\r\n                  Width = 200\r\n                  WideText = 'Const value'\r\n                end\r\n                item\r\n                  CaptionAlignment = taCenter\r\n                  Options = [coAllowClick, coDraggable, coEnabled, coParentBidiMode, coParentColor, coResizable, coShowDropMark, coVisible, coAllowFocus, coUseCaptionAlignment]\r\n                  Position = 2\r\n                  Width = 150\r\n                  WideText = 'Const type'\r\n                end>\r\n            end\r\n          end\r\n          object tsDbgUnitTypes: TTabSheet\r\n            Caption = 'Types'\r\n            ImageIndex = 1\r\n            object vstDbgInfoTypes: TVirtualStringTree\r\n              Left = 0\r\n              Top = 0\r\n              Width = 1014\r\n              Height = 637\r\n              Align = alClient\r\n              BevelEdges = []\r\n              BevelInner = bvNone\r\n              BevelOuter = bvNone\r\n              BorderStyle = bsNone\r\n              ClipboardFormats.Strings = (\r\n                'CSV'\r\n                'HTML Format'\r\n                'Plain text'\r\n                'Rich Text Format'\r\n                'Rich Text Format Without Objects'\r\n                'Unicode text')\r\n              Header.AutoSizeIndex = 0\r\n              Header.Font.Charset = DEFAULT_CHARSET\r\n              Header.Font.Color = clWindowText\r\n              Header.Font.Height = -11\r\n              Header.Font.Name = 'Tahoma'\r\n              Header.Font.Style = []\r\n              Header.Options = [hoColumnResize, hoShowSortGlyphs, hoVisible]\r\n              IncrementalSearch = isVisibleOnly\r\n              ScrollBarOptions.AlwaysVisible = True\r\n              TabOrder = 0\r\n              TreeOptions.MiscOptions = [toAcceptOLEDrop, toFullRepaintOnResize, toGridExtensions, toInitOnSave, toToggleOnDblClick, toWheelPanning, toEditOnClick]\r\n              TreeOptions.PaintOptions = [toShowButtons, toShowDropmark, toShowHorzGridLines, toShowTreeLines, toShowVertGridLines, toThemeAware, toUseBlendedImages, toFullVertGridLines]\r\n              TreeOptions.SelectionOptions = [toExtendedFocus, toFullRowSelect, toMultiSelect]\r\n              OnCompareNodes = vstDbgInfoTypesCompareNodes\r\n              OnGetText = vstDbgInfoTypesGetText\r\n              OnGetNodeDataSize = vstThreadsGetNodeDataSize\r\n              OnIncrementalSearch = vstDbgInfoTypesIncrementalSearch\r\n              Columns = <\r\n                item\r\n                  CaptionAlignment = taCenter\r\n                  Options = [coAllowClick, coDraggable, coEnabled, coParentBidiMode, coParentColor, coResizable, coShowDropMark, coVisible, coFixed, coAllowFocus, coUseCaptionAlignment]\r\n                  Position = 0\r\n                  Width = 210\r\n                  WideText = 'Type name'\r\n                end\r\n                item\r\n                  CaptionAlignment = taCenter\r\n                  Options = [coAllowClick, coDraggable, coEnabled, coParentBidiMode, coParentColor, coResizable, coShowDropMark, coVisible, coAllowFocus, coUseCaptionAlignment]\r\n                  Position = 1\r\n                  Width = 400\r\n                  WideText = 'Base type'\r\n                end\r\n                item\r\n                  Alignment = taRightJustify\r\n                  CaptionAlignment = taCenter\r\n                  Options = [coAllowClick, coDraggable, coEnabled, coParentBidiMode, coParentColor, coResizable, coShowDropMark, coVisible, coAllowFocus, coUseCaptionAlignment]\r\n                  Position = 2\r\n                  Width = 60\r\n                  WideText = 'Data size'\r\n                end\r\n                item\r\n                  Alignment = taRightJustify\r\n                  CaptionAlignment = taCenter\r\n                  Options = [coAllowClick, coDraggable, coEnabled, coParentBidiMode, coParentColor, coResizable, coShowDropMark, coVisible, coAllowFocus, coUseCaptionAlignment]\r\n                  Position = 3\r\n                  Width = 80\r\n                  WideText = 'Offset'\r\n                end>\r\n            end\r\n          end\r\n          object tsDbgUnitVars: TTabSheet\r\n            Caption = 'Vars'\r\n            ImageIndex = 2\r\n            object vstDbgInfoVars: TVirtualStringTree\r\n              Left = 0\r\n              Top = 0\r\n              Width = 1014\r\n              Height = 637\r\n              Align = alClient\r\n              BevelEdges = []\r\n              BevelInner = bvNone\r\n              BevelOuter = bvNone\r\n              BorderStyle = bsNone\r\n              ClipboardFormats.Strings = (\r\n                'CSV'\r\n                'HTML Format'\r\n                'Plain text'\r\n                'Rich Text Format'\r\n                'Rich Text Format Without Objects'\r\n                'Unicode text')\r\n              Header.AutoSizeIndex = 0\r\n              Header.Font.Charset = DEFAULT_CHARSET\r\n              Header.Font.Color = clWindowText\r\n              Header.Font.Height = -11\r\n              Header.Font.Name = 'Tahoma'\r\n              Header.Font.Style = []\r\n              Header.Options = [hoColumnResize, hoShowSortGlyphs, hoVisible]\r\n              IncrementalSearch = isVisibleOnly\r\n              ScrollBarOptions.AlwaysVisible = True\r\n              TabOrder = 0\r\n              TreeOptions.MiscOptions = [toAcceptOLEDrop, toFullRepaintOnResize, toGridExtensions, toInitOnSave, toToggleOnDblClick, toWheelPanning, toEditOnClick]\r\n              TreeOptions.PaintOptions = [toShowButtons, toShowDropmark, toShowHorzGridLines, toShowTreeLines, toShowVertGridLines, toThemeAware, toUseBlendedImages, toFullVertGridLines]\r\n              TreeOptions.SelectionOptions = [toExtendedFocus, toFullRowSelect, toMultiSelect]\r\n              OnCompareNodes = vstDbgInfoVarsCompareNodes\r\n              OnGetText = vstDbgInfoVarsGetText\r\n              OnGetNodeDataSize = vstThreadsGetNodeDataSize\r\n              OnIncrementalSearch = vstDbgInfoVarsIncrementalSearch\r\n              Columns = <\r\n                item\r\n                  CaptionAlignment = taCenter\r\n                  Options = [coAllowClick, coDraggable, coEnabled, coParentBidiMode, coParentColor, coResizable, coShowDropMark, coVisible, coFixed, coAllowFocus, coUseCaptionAlignment]\r\n                  Position = 0\r\n                  Width = 250\r\n                  WideText = 'Var name'\r\n                end\r\n                item\r\n                  CaptionAlignment = taCenter\r\n                  Options = [coAllowClick, coDraggable, coEnabled, coParentBidiMode, coParentColor, coResizable, coShowDropMark, coVisible, coAllowFocus, coUseCaptionAlignment]\r\n                  Position = 1\r\n                  Width = 200\r\n                  WideText = 'Var type'\r\n                end\r\n                item\r\n                  Alignment = taRightJustify\r\n                  CaptionAlignment = taCenter\r\n                  Options = [coAllowClick, coDraggable, coEnabled, coParentBidiMode, coParentColor, coResizable, coShowDropMark, coVisible, coAllowFocus, coUseCaptionAlignment]\r\n                  Position = 2\r\n                  Width = 70\r\n                  WideText = 'Var address'\r\n                end>\r\n            end\r\n          end\r\n          object tsDbgUnitFunctions: TTabSheet\r\n            Caption = 'Functions'\r\n            ImageIndex = 3\r\n            object splDbgInfoFuncs: TSplitter\r\n              Left = 447\r\n              Top = 0\r\n              Height = 637\r\n            end\r\n            object vstDbgInfoFunctions: TVirtualStringTree\r\n              Left = 0\r\n              Top = 0\r\n              Width = 447\r\n              Height = 637\r\n              Align = alLeft\r\n              BevelEdges = []\r\n              BevelInner = bvNone\r\n              BevelOuter = bvNone\r\n              BorderStyle = bsNone\r\n              ClipboardFormats.Strings = (\r\n                'CSV'\r\n                'HTML Format'\r\n                'Plain text'\r\n                'Rich Text Format'\r\n                'Rich Text Format Without Objects'\r\n                'Unicode text')\r\n              Constraints.MinWidth = 200\r\n              Header.AutoSizeIndex = 0\r\n              Header.Font.Charset = DEFAULT_CHARSET\r\n              Header.Font.Color = clWindowText\r\n              Header.Font.Height = -11\r\n              Header.Font.Name = 'Tahoma'\r\n              Header.Font.Style = []\r\n              Header.Options = [hoColumnResize, hoShowSortGlyphs, hoVisible]\r\n              IncrementalSearch = isVisibleOnly\r\n              ScrollBarOptions.AlwaysVisible = True\r\n              TabOrder = 0\r\n              TreeOptions.MiscOptions = [toAcceptOLEDrop, toFullRepaintOnResize, toGridExtensions, toInitOnSave, toToggleOnDblClick, toWheelPanning, toEditOnClick]\r\n              TreeOptions.PaintOptions = [toShowButtons, toShowDropmark, toShowHorzGridLines, toShowTreeLines, toShowVertGridLines, toThemeAware, toUseBlendedImages, toFullVertGridLines]\r\n              TreeOptions.SelectionOptions = [toExtendedFocus, toFullRowSelect, toMultiSelect]\r\n              OnColumnResize = vstColumnResize\r\n              OnCompareNodes = vstDbgInfoFunctionsCompareNodes\r\n              OnFocusChanged = vstDbgInfoFunctionsFocusChanged\r\n              OnGetText = vstDbgInfoFunctionsGetText\r\n              OnGetNodeDataSize = vstThreadsGetNodeDataSize\r\n              OnIncrementalSearch = vstDbgInfoFunctionsIncrementalSearch\r\n              OnResize = vstTreeResize\r\n              Columns = <\r\n                item\r\n                  CaptionAlignment = taCenter\r\n                  Options = [coAllowClick, coDraggable, coEnabled, coParentBidiMode, coParentColor, coResizable, coShowDropMark, coVisible, coFixed, coAllowFocus, coUseCaptionAlignment]\r\n                  Position = 0\r\n                  Width = 300\r\n                  WideText = 'Function name'\r\n                end\r\n                item\r\n                  Alignment = taRightJustify\r\n                  CaptionAlignment = taCenter\r\n                  Options = [coAllowClick, coDraggable, coEnabled, coParentBidiMode, coParentColor, coResizable, coShowDropMark, coVisible, coAllowFocus, coUseCaptionAlignment]\r\n                  Position = 1\r\n                  Width = 70\r\n                  WideText = 'Address'\r\n                end\r\n                item\r\n                  Alignment = taRightJustify\r\n                  CaptionAlignment = taCenter\r\n                  Options = [coAllowClick, coDraggable, coEnabled, coParentBidiMode, coParentColor, coResizable, coShowDropMark, coVisible, coAllowFocus, coUseCaptionAlignment]\r\n                  Position = 2\r\n                  Width = 60\r\n                  WideText = 'Code size'\r\n                end>\r\n            end\r\n            object pDbgInfoFuncAdv: TPanel\r\n              Left = 450\r\n              Top = 0\r\n              Width = 564\r\n              Height = 637\r\n              Align = alClient\r\n              BevelEdges = []\r\n              BevelOuter = bvNone\r\n              Caption = 'pDbgInfoFuncAdv'\r\n              ShowCaption = False\r\n              TabOrder = 1\r\n              object splDbgInfoFuncAdv: TSplitter\r\n                Left = 0\r\n                Top = 193\r\n                Width = 564\r\n                Height = 3\r\n                Cursor = crVSplit\r\n                Align = alTop\r\n              end\r\n              object vstDbgInfoFuncVars: TVirtualStringTree\r\n                Left = 0\r\n                Top = 0\r\n                Width = 564\r\n                Height = 193\r\n                Align = alTop\r\n                BevelEdges = []\r\n                BevelInner = bvNone\r\n                BevelOuter = bvNone\r\n                BorderStyle = bsNone\r\n                ClipboardFormats.Strings = (\r\n                  'CSV'\r\n                  'HTML Format'\r\n                  'Plain text'\r\n                  'Rich Text Format'\r\n                  'Rich Text Format Without Objects'\r\n                  'Unicode text')\r\n                Constraints.MinHeight = 100\r\n                Header.AutoSizeIndex = 0\r\n                Header.Font.Charset = DEFAULT_CHARSET\r\n                Header.Font.Color = clWindowText\r\n                Header.Font.Height = -11\r\n                Header.Font.Name = 'Tahoma'\r\n                Header.Font.Style = []\r\n                Header.Options = [hoColumnResize, hoShowSortGlyphs, hoVisible]\r\n                ScrollBarOptions.AlwaysVisible = True\r\n                TabOrder = 0\r\n                TreeOptions.MiscOptions = [toAcceptOLEDrop, toFullRepaintOnResize, toGridExtensions, toInitOnSave, toToggleOnDblClick, toWheelPanning, toEditOnClick]\r\n                TreeOptions.PaintOptions = [toShowButtons, toShowDropmark, toShowHorzGridLines, toShowTreeLines, toShowVertGridLines, toThemeAware, toUseBlendedImages, toFullVertGridLines]\r\n                TreeOptions.SelectionOptions = [toExtendedFocus, toFullRowSelect, toMultiSelect]\r\n                OnGetText = vstDbgInfoFuncVarsGetText\r\n                OnGetNodeDataSize = vstThreadsGetNodeDataSize\r\n                Columns = <\r\n                  item\r\n                    CaptionAlignment = taCenter\r\n                    Options = [coAllowClick, coDraggable, coEnabled, coParentBidiMode, coParentColor, coResizable, coShowDropMark, coVisible, coFixed, coAllowFocus, coUseCaptionAlignment]\r\n                    Position = 0\r\n                    Width = 200\r\n                    WideText = 'Param name'\r\n                  end\r\n                  item\r\n                    CaptionAlignment = taCenter\r\n                    Options = [coAllowClick, coDraggable, coEnabled, coParentBidiMode, coParentColor, coResizable, coShowDropMark, coVisible, coAllowFocus, coUseCaptionAlignment]\r\n                    Position = 1\r\n                    Width = 150\r\n                    WideText = 'Param type'\r\n                  end\r\n                  item\r\n                    Position = 2\r\n                    Width = 70\r\n                    WideText = 'Param kind'\r\n                  end>\r\n              end\r\n              inline svfDbgInfoFuncAdv: TSourceViewFrame\r\n                Left = 0\r\n                Top = 196\r\n                Width = 564\r\n                Height = 441\r\n                Align = alClient\r\n                Constraints.MinHeight = 100\r\n                TabOrder = 1\r\n                inherited synmSourceView: TSynMemo\r\n                  Width = 564\r\n                  Height = 420\r\n                end\r\n                inherited eSrcFileName: TEdit\r\n                  Width = 564\r\n                end\r\n              end\r\n            end\r\n          end\r\n          object tsDbgUnitSource: TTabSheet\r\n            Caption = 'Source'\r\n            ImageIndex = 4\r\n            inline svfDbgInfoUnitSource: TSourceViewFrame\r\n              Left = 0\r\n              Top = 0\r\n              Width = 1014\r\n              Height = 637\r\n              Align = alClient\r\n              TabOrder = 0\r\n              inherited synmSourceView: TSynMemo\r\n                Width = 1014\r\n                Height = 616\r\n              end\r\n              inherited eSrcFileName: TEdit\r\n                Width = 1014\r\n              end\r\n            end\r\n          end\r\n        end\r\n      end\r\n    end\r\n    object tsThreads1: TTabSheet\r\n      Caption = 'Threads timeline'\r\n      ImageIndex = 3\r\n      object vstThreads: TVirtualStringTree\r\n        Left = 0\r\n        Top = 0\r\n        Width = 460\r\n        Height = 665\r\n        Align = alLeft\r\n        BorderStyle = bsNone\r\n        ClipboardFormats.Strings = (\r\n          'CSV'\r\n          'HTML Format'\r\n          'Plain text'\r\n          'Rich Text Format'\r\n          'Rich Text Format Without Objects'\r\n          'Unicode text')\r\n        Colors.FocusedSelectionColor = clBtnFace\r\n        Colors.FocusedSelectionBorderColor = clBtnFace\r\n        Colors.SelectionRectangleBlendColor = clBtnFace\r\n        Colors.SelectionRectangleBorderColor = clBtnFace\r\n        Colors.SelectionTextColor = clWindowText\r\n        Constraints.MinWidth = 200\r\n        DrawSelectionMode = smBlendedRectangle\r\n        Header.AutoSizeIndex = -1\r\n        Header.Font.Charset = DEFAULT_CHARSET\r\n        Header.Font.Color = clWindowText\r\n        Header.Font.Height = -11\r\n        Header.Font.Name = 'Tahoma'\r\n        Header.Font.Style = []\r\n        Header.Options = [hoColumnResize, hoVisible]\r\n        Header.Style = hsPlates\r\n        IncrementalSearch = isVisibleOnly\r\n        ScrollBarOptions.AlwaysVisible = True\r\n        ScrollBarOptions.ScrollBars = ssHorizontal\r\n        TabOrder = 0\r\n        TreeOptions.AutoOptions = [toAutoDeleteMovedNodes, toDisableAutoscrollOnFocus]\r\n        TreeOptions.MiscOptions = [toAcceptOLEDrop, toInitOnSave, toToggleOnDblClick, toWheelPanning]\r\n        TreeOptions.PaintOptions = [toHideFocusRect, toShowButtons, toShowDropmark, toShowHorzGridLines, toShowTreeLines, toShowVertGridLines, toThemeAware, toUseBlendedImages, toFullVertGridLines]\r\n        TreeOptions.SelectionOptions = [toDisableDrawSelection, toExtendedFocus, toFullRowSelect]\r\n        OnChange = vdtTimeLineChange\r\n        OnCollapsed = vstThreadsCollapsed\r\n        OnColumnResize = vstColumnResize\r\n        OnCompareNodes = vstThreadsCompareNodes\r\n        OnDrawText = vstThreadsDrawText\r\n        OnExpanded = vstThreadsExpanded\r\n        OnGetText = vstThreadsGetText\r\n        OnGetNodeDataSize = vstThreadsGetNodeDataSize\r\n        OnIncrementalSearch = vstThreadsIncrementalSearch\r\n        OnScroll = vstThreadsScroll\r\n        Columns = <\r\n          item\r\n            CaptionAlignment = taCenter\r\n            Options = [coEnabled, coParentBidiMode, coParentColor, coResizable, coShowDropMark, coVisible, coFixed, coUseCaptionAlignment]\r\n            Position = 0\r\n            Width = 300\r\n            WideText = 'Thread name'\r\n          end\r\n          item\r\n            Alignment = taRightJustify\r\n            CaptionAlignment = taCenter\r\n            Options = [coEnabled, coParentBidiMode, coParentColor, coResizable, coShowDropMark, coVisible, coUseCaptionAlignment]\r\n            Position = 1\r\n            Width = 90\r\n            WideText = 'ID'\r\n          end\r\n          item\r\n            Alignment = taRightJustify\r\n            CaptionAlignment = taCenter\r\n            Options = [coEnabled, coParentBidiMode, coParentColor, coResizable, coShowDropMark, coVisible, coUseCaptionAlignment]\r\n            Position = 2\r\n            Width = 70\r\n            WideText = 'CPU time'\r\n          end>\r\n      end\r\n      object vdtTimeLine: TVirtualDrawTree\r\n        Left = 460\r\n        Top = 0\r\n        Width = 927\r\n        Height = 665\r\n        Align = alClient\r\n        BorderStyle = bsNone\r\n        Colors.FocusedSelectionColor = clBtnFace\r\n        Colors.FocusedSelectionBorderColor = clBtnFace\r\n        Colors.SelectionRectangleBlendColor = clBtnFace\r\n        Colors.SelectionRectangleBorderColor = clBtnFace\r\n        Constraints.MinWidth = 200\r\n        DrawSelectionMode = smBlendedRectangle\r\n        Header.AutoSizeIndex = 0\r\n        Header.Font.Charset = DEFAULT_CHARSET\r\n        Header.Font.Color = clWindowText\r\n        Header.Font.Height = -11\r\n        Header.Font.Name = 'Tahoma'\r\n        Header.Font.Style = []\r\n        Header.Options = [hoOwnerDraw, hoVisible, hoFullRepaintOnResize, hoDisableAnimatedResize]\r\n        Header.Style = hsPlates\r\n        ScrollBarOptions.AlwaysVisible = True\r\n        TabOrder = 1\r\n        TreeOptions.AutoOptions = [toAutoDeleteMovedNodes, toDisableAutoscrollOnFocus]\r\n        TreeOptions.MiscOptions = [toFullRepaintOnResize, toGridExtensions, toInitOnSave, toToggleOnDblClick, toWheelPanning]\r\n        TreeOptions.PaintOptions = [toShowBackground, toThemeAware, toStaticBackground]\r\n        TreeOptions.SelectionOptions = [toDisableDrawSelection, toExtendedFocus, toFullRowSelect]\r\n        OnAdvancedHeaderDraw = vdtTimeLineAdvancedHeaderDraw\r\n        OnChange = vdtTimeLineChange\r\n        OnCollapsed = vstThreadsCollapsed\r\n        OnDrawNode = vdtTimeLineDrawNode\r\n        OnExpanded = vstThreadsExpanded\r\n        OnGetNodeDataSize = vstThreadsGetNodeDataSize\r\n        OnHeaderDrawQueryElements = vdtTimeLineHeaderDrawQueryElements\r\n        OnPaintBackground = vdtTimeLinePaintBackground\r\n        OnScroll = vdtTimeLineScroll\r\n        Columns = <\r\n          item\r\n            BiDiMode = bdLeftToRight\r\n            Options = [coEnabled, coParentColor, coResizable, coVisible, coFixed, coAllowFocus]\r\n            Position = 0\r\n            Style = vsOwnerDraw\r\n            Width = 10000\r\n          end>\r\n      end\r\n    end\r\n    object tsMemInfo: TTabSheet\r\n      Caption = 'Memory Info'\r\n      ImageIndex = 3\r\n      object splMemInfo: TSplitter\r\n        Left = 486\r\n        Top = 0\r\n        Height = 665\r\n      end\r\n      object vstMemInfoThreads: TVirtualStringTree\r\n        Left = 0\r\n        Top = 0\r\n        Width = 486\r\n        Height = 665\r\n        Align = alLeft\r\n        ClipboardFormats.Strings = (\r\n          'CSV'\r\n          'HTML Format'\r\n          'Plain text'\r\n          'Rich Text Format'\r\n          'Rich Text Format Without Objects'\r\n          'Unicode text')\r\n        Constraints.MinWidth = 200\r\n        Header.AutoSizeIndex = 0\r\n        Header.Font.Charset = DEFAULT_CHARSET\r\n        Header.Font.Color = clWindowText\r\n        Header.Font.Height = -11\r\n        Header.Font.Name = 'Tahoma'\r\n        Header.Font.Style = []\r\n        Header.Options = [hoColumnResize, hoShowSortGlyphs, hoVisible]\r\n        Header.Style = hsFlatButtons\r\n        ScrollBarOptions.AlwaysVisible = True\r\n        TabOrder = 0\r\n        TreeOptions.AutoOptions = [toAutoDropExpand, toAutoTristateTracking, toAutoDeleteMovedNodes]\r\n        TreeOptions.MiscOptions = [toAcceptOLEDrop, toFullRepaintOnResize, toInitOnSave, toToggleOnDblClick, toWheelPanning]\r\n        TreeOptions.PaintOptions = [toShowButtons, toShowDropmark, toShowHorzGridLines, toShowRoot, toShowTreeLines, toShowVertGridLines, toThemeAware, toUseBlendedImages, toFullVertGridLines]\r\n        TreeOptions.SelectionOptions = [toExtendedFocus, toFullRowSelect]\r\n        OnColumnResize = vstColumnResize\r\n        OnDrawText = vstThreadsDrawText\r\n        OnFocusChanged = vstMemInfoThreadsFocusChanged\r\n        OnGetText = vstMemInfoThreadsGetText\r\n        OnGetNodeDataSize = vstThreadsGetNodeDataSize\r\n        OnResize = vstTreeResize\r\n        Columns = <\r\n          item\r\n            CaptionAlignment = taCenter\r\n            Options = [coAllowClick, coDraggable, coEnabled, coParentBidiMode, coParentColor, coResizable, coShowDropMark, coVisible, coFixed, coAllowFocus, coUseCaptionAlignment]\r\n            Position = 0\r\n            Width = 250\r\n            WideText = 'Thread name'\r\n          end\r\n          item\r\n            Alignment = taRightJustify\r\n            CaptionAlignment = taCenter\r\n            Options = [coAllowClick, coDraggable, coEnabled, coParentBidiMode, coParentColor, coResizable, coShowDropMark, coVisible, coAllowFocus, coUseCaptionAlignment]\r\n            Position = 1\r\n            Width = 90\r\n            WideText = 'ID'\r\n          end\r\n          item\r\n            Alignment = taRightJustify\r\n            CaptionAlignment = taCenter\r\n            Options = [coAllowClick, coDraggable, coEnabled, coParentBidiMode, coParentColor, coResizable, coShowDropMark, coVisible, coAllowFocus, coUseCaptionAlignment]\r\n            Position = 2\r\n            WideText = 'Count'\r\n          end\r\n          item\r\n            Alignment = taRightJustify\r\n            CaptionAlignment = taCenter\r\n            Options = [coAllowClick, coDraggable, coEnabled, coParentBidiMode, coParentColor, coResizable, coShowDropMark, coVisible, coAllowFocus, coUseCaptionAlignment]\r\n            Position = 3\r\n            Width = 75\r\n            WideText = 'Size'\r\n          end>\r\n      end\r\n      object pMemInfoClient: TPanel\r\n        Left = 489\r\n        Top = 0\r\n        Width = 898\r\n        Height = 665\r\n        Align = alClient\r\n        BevelEdges = []\r\n        BevelOuter = bvNone\r\n        Caption = 'pMemInfoClient'\r\n        Constraints.MinWidth = 400\r\n        ShowCaption = False\r\n        TabOrder = 1\r\n        object cbMemInfo: TCoolBar\r\n          Left = 0\r\n          Top = 0\r\n          Width = 898\r\n          Height = 24\r\n          AutoSize = True\r\n          BandBorderStyle = bsNone\r\n          Bands = <\r\n            item\r\n              Control = actbMemInfo\r\n              ImageIndex = -1\r\n              MinHeight = 24\r\n              Width = 898\r\n            end>\r\n          EdgeBorders = []\r\n          EdgeInner = esNone\r\n          EdgeOuter = esNone\r\n          FixedOrder = True\r\n          object actbMemInfo: TActionToolBar\r\n            Left = 0\r\n            Top = 0\r\n            Width = 898\r\n            Height = 24\r\n            ActionManager = amMain\r\n            Caption = 'actbMemInfo'\r\n            ColorMap.MenuColor = clMenu\r\n            ColorMap.BtnSelectedColor = clBtnFace\r\n            ColorMap.UnusedColor = 14410210\r\n            EdgeInner = esNone\r\n            Font.Charset = DEFAULT_CHARSET\r\n            Font.Color = clBlack\r\n            Font.Height = -11\r\n            Font.Name = 'Tahoma'\r\n            Font.Style = []\r\n            ParentFont = False\r\n            Spacing = 0\r\n          end\r\n        end\r\n        object pcMemInfo: TPageControl\r\n          Left = 0\r\n          Top = 24\r\n          Width = 898\r\n          Height = 641\r\n          ActivePage = tsMemInfoViewStack\r\n          Align = alClient\r\n          TabOrder = 1\r\n          OnChange = pcMemInfoChange\r\n          object tsMemInfoViewStack: TTabSheet\r\n            Caption = 'Simple view'\r\n            object pnl1: TPanel\r\n              Left = 0\r\n              Top = 0\r\n              Width = 890\r\n              Height = 613\r\n              Align = alClient\r\n              BevelOuter = bvNone\r\n              TabOrder = 0\r\n              object splMemInfoSmpView: TSplitter\r\n                Left = 305\r\n                Top = 0\r\n                Height = 613\r\n              end\r\n              object pMemoryInfoAdv: TPanel\r\n                Left = 308\r\n                Top = 0\r\n                Width = 582\r\n                Height = 613\r\n                Align = alClient\r\n                BevelOuter = bvNone\r\n                Caption = 'pMemoryInfoAdv'\r\n                Constraints.MinWidth = 200\r\n                ShowCaption = False\r\n                TabOrder = 0\r\n                object splMemInfoAdv: TSplitter\r\n                  Left = 0\r\n                  Top = 225\r\n                  Width = 582\r\n                  Height = 3\r\n                  Cursor = crVSplit\r\n                  Align = alTop\r\n                end\r\n                object vstMemStack: TVirtualStringTree\r\n                  Left = 0\r\n                  Top = 0\r\n                  Width = 582\r\n                  Height = 225\r\n                  Align = alTop\r\n                  ClipboardFormats.Strings = (\r\n                    'CSV'\r\n                    'HTML Format'\r\n                    'Plain text'\r\n                    'Rich Text Format'\r\n                    'Rich Text Format Without Objects'\r\n                    'Unicode text')\r\n                  Constraints.MinHeight = 100\r\n                  Header.AutoSizeIndex = 0\r\n                  Header.Font.Charset = DEFAULT_CHARSET\r\n                  Header.Font.Color = clWindowText\r\n                  Header.Font.Height = -11\r\n                  Header.Font.Name = 'Tahoma'\r\n                  Header.Font.Style = []\r\n                  Header.Options = [hoColumnResize, hoShowSortGlyphs, hoVisible]\r\n                  Header.Style = hsFlatButtons\r\n                  ScrollBarOptions.AlwaysVisible = True\r\n                  TabOrder = 0\r\n                  TreeOptions.MiscOptions = [toAcceptOLEDrop, toFullRepaintOnResize, toGridExtensions, toInitOnSave, toToggleOnDblClick, toWheelPanning, toEditOnClick]\r\n                  TreeOptions.PaintOptions = [toShowButtons, toShowDropmark, toShowHorzGridLines, toShowTreeLines, toShowVertGridLines, toThemeAware, toUseBlendedImages, toFullVertGridLines]\r\n                  TreeOptions.SelectionOptions = [toExtendedFocus, toFullRowSelect, toMultiSelect]\r\n                  OnFocusChanged = vstMemStackFocusChanged\r\n                  OnGetText = vstMemStackGetText\r\n                  OnGetNodeDataSize = vstThreadsGetNodeDataSize\r\n                  Columns = <\r\n                    item\r\n                      Alignment = taRightJustify\r\n                      CaptionAlignment = taCenter\r\n                      Options = [coAllowClick, coDraggable, coEnabled, coParentBidiMode, coParentColor, coResizable, coShowDropMark, coVisible, coFixed, coSmartResize, coAllowFocus, coUseCaptionAlignment]\r\n                      Position = 0\r\n                      Width = 70\r\n                      WideText = 'Address'\r\n                    end\r\n                    item\r\n                      CaptionAlignment = taCenter\r\n                      Options = [coAllowClick, coDraggable, coEnabled, coParentBidiMode, coParentColor, coResizable, coShowDropMark, coVisible, coAllowFocus, coUseCaptionAlignment]\r\n                      Position = 1\r\n                      Width = 120\r\n                      WideText = 'Unit'\r\n                    end\r\n                    item\r\n                      Alignment = taRightJustify\r\n                      CaptionAlignment = taCenter\r\n                      Options = [coAllowClick, coDraggable, coEnabled, coParentBidiMode, coParentColor, coResizable, coShowDropMark, coVisible, coAllowFocus, coUseCaptionAlignment]\r\n                      Position = 2\r\n                      WideText = 'Line'\r\n                    end\r\n                    item\r\n                      Position = 3\r\n                      Width = 500\r\n                      WideText = 'Call stack function'\r\n                    end>\r\n                end\r\n                inline svfMemInfoSource: TSourceViewFrame\r\n                  Left = 0\r\n                  Top = 228\r\n                  Width = 582\r\n                  Height = 385\r\n                  Align = alClient\r\n                  Constraints.MinHeight = 100\r\n                  TabOrder = 1\r\n                  inherited synmSourceView: TSynMemo\r\n                    Width = 582\r\n                    Height = 364\r\n                    SearchEngine = dmShareData.synEditSearch1\r\n                  end\r\n                  inherited eSrcFileName: TEdit\r\n                    Width = 582\r\n                  end\r\n                end\r\n              end\r\n              object vstMemList: TVirtualStringTree\r\n                Left = 0\r\n                Top = 0\r\n                Width = 305\r\n                Height = 613\r\n                Align = alLeft\r\n                ClipboardFormats.Strings = (\r\n                  'CSV'\r\n                  'HTML Format'\r\n                  'Plain text'\r\n                  'Rich Text Format'\r\n                  'Rich Text Format Without Objects'\r\n                  'Unicode text')\r\n                Constraints.MinWidth = 200\r\n                Header.AutoSizeIndex = 0\r\n                Header.Font.Charset = DEFAULT_CHARSET\r\n                Header.Font.Color = clWindowText\r\n                Header.Font.Height = -11\r\n                Header.Font.Name = 'Tahoma'\r\n                Header.Font.Style = []\r\n                Header.Options = [hoColumnResize, hoVisible, hoHeaderClickAutoSort]\r\n                Header.SortColumn = 2\r\n                Header.SortDirection = sdDescending\r\n                Header.Style = hsFlatButtons\r\n                ScrollBarOptions.AlwaysVisible = True\r\n                TabOrder = 1\r\n                TreeOptions.AutoOptions = [toAutoDropExpand, toAutoScrollOnExpand, toAutoSort, toAutoTristateTracking, toAutoDeleteMovedNodes]\r\n                TreeOptions.MiscOptions = [toAcceptOLEDrop, toFullRepaintOnResize, toGridExtensions, toInitOnSave, toToggleOnDblClick, toWheelPanning, toEditOnClick]\r\n                TreeOptions.PaintOptions = [toHideFocusRect, toShowButtons, toShowDropmark, toShowHorzGridLines, toShowTreeLines, toShowVertGridLines, toThemeAware, toUseBlendedImages, toFullVertGridLines]\r\n                TreeOptions.SelectionOptions = [toFullRowSelect, toMultiSelect]\r\n                OnColumnResize = vstColumnResize\r\n                OnCompareNodes = vstMemInfoObjectsCompareNodes\r\n                OnFocusChanged = vstMemListFocusChanged\r\n                OnGetText = vstMemListGetText\r\n                OnGetNodeDataSize = vstThreadsGetNodeDataSize\r\n                OnResize = vstTreeResize\r\n                Columns = <\r\n                  item\r\n                    CaptionAlignment = taCenter\r\n                    Options = [coAllowClick, coDraggable, coEnabled, coParentBidiMode, coParentColor, coResizable, coShowDropMark, coVisible, coFixed, coAllowFocus, coUseCaptionAlignment]\r\n                    Position = 0\r\n                    Width = 150\r\n                    WideText = 'Object type'\r\n                  end\r\n                  item\r\n                    Alignment = taRightJustify\r\n                    CaptionAlignment = taCenter\r\n                    Options = [coAllowClick, coDraggable, coEnabled, coParentBidiMode, coParentColor, coResizable, coShowDropMark, coVisible, coAllowFocus, coUseCaptionAlignment]\r\n                    Position = 1\r\n                    Width = 70\r\n                    WideText = 'Pointer'\r\n                  end\r\n                  item\r\n                    Alignment = taRightJustify\r\n                    CaptionAlignment = taCenter\r\n                    DefaultSortDirection = sdDescending\r\n                    Options = [coAllowClick, coDraggable, coEnabled, coParentBidiMode, coParentColor, coResizable, coShowDropMark, coVisible, coAllowFocus, coUseCaptionAlignment]\r\n                    Position = 2\r\n                    Width = 65\r\n                    WideText = 'Size'\r\n                  end>\r\n              end\r\n            end\r\n          end\r\n          object tsMemInfoTreeView: TTabSheet\r\n            Caption = 'Tree view'\r\n            ImageIndex = 1\r\n            object spl2: TSplitter\r\n              Left = 0\r\n              Top = 361\r\n              Width = 890\r\n              Height = 3\r\n              Cursor = crVSplit\r\n              Align = alBottom\r\n            end\r\n            object pMemInfoTreeLeft: TPanel\r\n              Left = 0\r\n              Top = 0\r\n              Width = 890\r\n              Height = 361\r\n              Align = alClient\r\n              BevelEdges = []\r\n              BevelOuter = bvNone\r\n              Caption = 'pMemInfoTreeLeft'\r\n              Constraints.MinHeight = 200\r\n              ShowCaption = False\r\n              TabOrder = 0\r\n              object splMemInfoTreeView1: TSplitter\r\n                Left = 456\r\n                Top = 0\r\n                Height = 361\r\n              end\r\n              object vstMemInfoFuncTree: TVirtualStringTree\r\n                Left = 0\r\n                Top = 0\r\n                Width = 456\r\n                Height = 361\r\n                Align = alLeft\r\n                BevelEdges = []\r\n                BevelInner = bvNone\r\n                BevelOuter = bvNone\r\n                BorderStyle = bsNone\r\n                ClipboardFormats.Strings = (\r\n                  'CSV'\r\n                  'HTML Format'\r\n                  'Plain text'\r\n                  'Rich Text Format'\r\n                  'Rich Text Format Without Objects'\r\n                  'Unicode text')\r\n                Constraints.MinWidth = 200\r\n                Header.AutoSizeIndex = 0\r\n                Header.Font.Charset = DEFAULT_CHARSET\r\n                Header.Font.Color = clWindowText\r\n                Header.Font.Height = -11\r\n                Header.Font.Name = 'Tahoma'\r\n                Header.Font.Style = []\r\n                Header.Options = [hoColumnResize, hoVisible, hoHeaderClickAutoSort]\r\n                Header.SortColumn = 2\r\n                Header.SortDirection = sdDescending\r\n                ScrollBarOptions.AlwaysVisible = True\r\n                TabOrder = 0\r\n                TreeOptions.AutoOptions = [toAutoDropExpand, toAutoScrollOnExpand, toAutoSort, toAutoTristateTracking, toAutoDeleteMovedNodes]\r\n                TreeOptions.MiscOptions = [toAcceptOLEDrop, toFullRepaintOnResize, toGridExtensions, toInitOnSave, toToggleOnDblClick, toWheelPanning, toEditOnClick]\r\n                TreeOptions.PaintOptions = [toShowButtons, toShowDropmark, toShowHorzGridLines, toShowTreeLines, toShowVertGridLines, toThemeAware, toUseBlendedImages, toFullVertGridLines]\r\n                TreeOptions.SelectionOptions = [toExtendedFocus, toFullRowSelect, toMultiSelect]\r\n                OnColumnResize = vstColumnResize\r\n                OnCompareNodes = vstMemInfoFuncTreeCompareNodes\r\n                OnDrawText = vstTrackFuncsDrawText\r\n                OnFocusChanged = vstMemInfoFuncTreeFocusChanged\r\n                OnGetText = vstMemInfoFuncTreeGetText\r\n                OnGetNodeDataSize = vstThreadsGetNodeDataSize\r\n                OnResize = vstTreeResize\r\n                Columns = <\r\n                  item\r\n                    CaptionAlignment = taCenter\r\n                    Options = [coAllowClick, coDraggable, coEnabled, coParentBidiMode, coParentColor, coResizable, coShowDropMark, coVisible, coFixed, coAllowFocus, coUseCaptionAlignment]\r\n                    Position = 0\r\n                    Width = 300\r\n                    WideText = 'Function name'\r\n                  end\r\n                  item\r\n                    Alignment = taRightJustify\r\n                    CaptionAlignment = taCenter\r\n                    DefaultSortDirection = sdDescending\r\n                    Options = [coAllowClick, coDraggable, coEnabled, coParentBidiMode, coParentColor, coResizable, coShowDropMark, coVisible, coAllowFocus, coUseCaptionAlignment]\r\n                    Position = 1\r\n                    Width = 70\r\n                    WideText = 'Count'\r\n                  end\r\n                  item\r\n                    Alignment = taRightJustify\r\n                    CaptionAlignment = taCenter\r\n                    DefaultSortDirection = sdDescending\r\n                    Options = [coAllowClick, coDraggable, coEnabled, coParentBidiMode, coParentColor, coResizable, coShowDropMark, coVisible, coAllowFocus, coUseCaptionAlignment]\r\n                    Position = 2\r\n                    Width = 70\r\n                    WideText = 'Size'\r\n                  end>\r\n              end\r\n              object pcMemInfoFuncInfo: TPageControl\r\n                Left = 459\r\n                Top = 0\r\n                Width = 431\r\n                Height = 361\r\n                ActivePage = tsMemInfoFuncLinks\r\n                Align = alClient\r\n                Constraints.MinWidth = 200\r\n                TabOrder = 1\r\n                object tsMemInfoFuncLinks: TTabSheet\r\n                  Caption = 'Links'\r\n                  object pMemInfoFuncLinks: TPanel\r\n                    Left = 0\r\n                    Top = 0\r\n                    Width = 423\r\n                    Height = 333\r\n                    Align = alClient\r\n                    BevelOuter = bvNone\r\n                    ShowCaption = False\r\n                    TabOrder = 0\r\n                    OnResize = pMemInfoFuncLinksResize\r\n                    object spl1: TSplitter\r\n                      Left = 0\r\n                      Top = 100\r\n                      Width = 423\r\n                      Height = 3\r\n                      Cursor = crVSplit\r\n                      Align = alTop\r\n                    end\r\n                    object vstMemInfoFuncParents: TVirtualStringTree\r\n                      Left = 0\r\n                      Top = 0\r\n                      Width = 423\r\n                      Height = 100\r\n                      Align = alTop\r\n                      BevelEdges = []\r\n                      BevelInner = bvNone\r\n                      BevelOuter = bvNone\r\n                      BorderStyle = bsNone\r\n                      ClipboardFormats.Strings = (\r\n                        'CSV'\r\n                        'HTML Format'\r\n                        'Plain text'\r\n                        'Rich Text Format'\r\n                        'Rich Text Format Without Objects'\r\n                        'Unicode text')\r\n                      Constraints.MinHeight = 50\r\n                      Header.AutoSizeIndex = 0\r\n                      Header.Font.Charset = DEFAULT_CHARSET\r\n                      Header.Font.Color = clWindowText\r\n                      Header.Font.Height = -11\r\n                      Header.Font.Name = 'Tahoma'\r\n                      Header.Font.Style = []\r\n                      Header.Options = [hoColumnResize, hoShowSortGlyphs, hoVisible]\r\n                      ScrollBarOptions.AlwaysVisible = True\r\n                      TabOrder = 0\r\n                      TreeOptions.MiscOptions = [toAcceptOLEDrop, toFullRepaintOnResize, toGridExtensions, toInitOnSave, toToggleOnDblClick, toWheelPanning, toEditOnClick]\r\n                      TreeOptions.PaintOptions = [toShowButtons, toShowDropmark, toShowHorzGridLines, toShowTreeLines, toShowVertGridLines, toThemeAware, toUseBlendedImages, toFullVertGridLines]\r\n                      TreeOptions.SelectionOptions = [toExtendedFocus, toFullRowSelect, toMultiSelect]\r\n                      OnDblClick = vstMemInfoFuncParentsDblClick\r\n                      OnDrawText = vstTrackFuncLinksDrawText\r\n                      OnGetText = vstMemInfoFuncLinksGetText\r\n                      OnGetNodeDataSize = vstThreadsGetNodeDataSize\r\n                      Columns = <\r\n                        item\r\n                          CaptionAlignment = taCenter\r\n                          Options = [coAllowClick, coDraggable, coEnabled, coParentBidiMode, coParentColor, coResizable, coShowDropMark, coVisible, coFixed, coAllowFocus, coUseCaptionAlignment]\r\n                          Position = 0\r\n                          Width = 300\r\n                          WideText = 'Parent function name'\r\n                        end\r\n                        item\r\n                          Alignment = taRightJustify\r\n                          CaptionAlignment = taCenter\r\n                          Options = [coAllowClick, coDraggable, coEnabled, coParentBidiMode, coParentColor, coResizable, coShowDropMark, coVisible, coAllowFocus, coUseCaptionAlignment]\r\n                          Position = 1\r\n                          WideText = 'LineNo'\r\n                        end\r\n                        item\r\n                          Alignment = taRightJustify\r\n                          CaptionAlignment = taCenter\r\n                          Options = [coAllowClick, coDraggable, coEnabled, coParentBidiMode, coParentColor, coResizable, coShowDropMark, coVisible, coAllowFocus, coUseCaptionAlignment]\r\n                          Position = 2\r\n                          Width = 70\r\n                          WideText = 'Count'\r\n                        end\r\n                        item\r\n                          Alignment = taRightJustify\r\n                          CaptionAlignment = taCenter\r\n                          Options = [coAllowClick, coDraggable, coEnabled, coParentBidiMode, coParentColor, coResizable, coShowDropMark, coVisible, coAllowFocus, coUseCaptionAlignment]\r\n                          Position = 3\r\n                          Width = 70\r\n                          WideText = 'Size'\r\n                        end>\r\n                    end\r\n                    object vstMemInfoFuncChilds: TVirtualStringTree\r\n                      Left = 0\r\n                      Top = 103\r\n                      Width = 423\r\n                      Height = 230\r\n                      Align = alClient\r\n                      BevelEdges = []\r\n                      BevelInner = bvNone\r\n                      BevelOuter = bvNone\r\n                      BorderStyle = bsNone\r\n                      ClipboardFormats.Strings = (\r\n                        'CSV'\r\n                        'HTML Format'\r\n                        'Plain text'\r\n                        'Rich Text Format'\r\n                        'Rich Text Format Without Objects'\r\n                        'Unicode text')\r\n                      Constraints.MinHeight = 50\r\n                      Header.AutoSizeIndex = 0\r\n                      Header.Font.Charset = DEFAULT_CHARSET\r\n                      Header.Font.Color = clWindowText\r\n                      Header.Font.Height = -11\r\n                      Header.Font.Name = 'Tahoma'\r\n                      Header.Font.Style = []\r\n                      Header.Options = [hoColumnResize, hoShowSortGlyphs, hoVisible]\r\n                      ScrollBarOptions.AlwaysVisible = True\r\n                      TabOrder = 1\r\n                      TreeOptions.MiscOptions = [toAcceptOLEDrop, toFullRepaintOnResize, toGridExtensions, toInitOnSave, toToggleOnDblClick, toWheelPanning, toEditOnClick]\r\n                      TreeOptions.PaintOptions = [toShowButtons, toShowDropmark, toShowHorzGridLines, toShowTreeLines, toShowVertGridLines, toThemeAware, toUseBlendedImages, toFullVertGridLines]\r\n                      TreeOptions.SelectionOptions = [toExtendedFocus, toFullRowSelect, toMultiSelect]\r\n                      OnDblClick = vstMemInfoFuncChildsDblClick\r\n                      OnDrawText = vstTrackFuncLinksDrawText\r\n                      OnGetText = vstMemInfoFuncLinksGetText\r\n                      OnGetNodeDataSize = vstThreadsGetNodeDataSize\r\n                      Columns = <\r\n                        item\r\n                          CaptionAlignment = taCenter\r\n                          Options = [coAllowClick, coDraggable, coEnabled, coParentBidiMode, coParentColor, coResizable, coShowDropMark, coVisible, coFixed, coAllowFocus, coUseCaptionAlignment]\r\n                          Position = 0\r\n                          Width = 300\r\n                          WideText = 'Child function name'\r\n                        end\r\n                        item\r\n                          Alignment = taRightJustify\r\n                          CaptionAlignment = taCenter\r\n                          Options = [coAllowClick, coDraggable, coEnabled, coParentBidiMode, coParentColor, coResizable, coShowDropMark, coVisible, coAllowFocus, coUseCaptionAlignment]\r\n                          Position = 1\r\n                          WideText = 'LineNo'\r\n                        end\r\n                        item\r\n                          Alignment = taRightJustify\r\n                          CaptionAlignment = taCenter\r\n                          Options = [coAllowClick, coDraggable, coEnabled, coParentBidiMode, coParentColor, coResizable, coShowDropMark, coVisible, coAllowFocus, coUseCaptionAlignment]\r\n                          Position = 2\r\n                          Width = 70\r\n                          WideText = 'Count'\r\n                        end\r\n                        item\r\n                          Alignment = taRightJustify\r\n                          CaptionAlignment = taCenter\r\n                          Options = [coAllowClick, coDraggable, coEnabled, coParentBidiMode, coParentColor, coResizable, coShowDropMark, coVisible, coAllowFocus, coUseCaptionAlignment]\r\n                          Position = 3\r\n                          Width = 70\r\n                          WideText = 'Size'\r\n                        end>\r\n                    end\r\n                  end\r\n                end\r\n                object tsMemInfoFuncSrc: TTabSheet\r\n                  Caption = 'Source'\r\n                  ImageIndex = 1\r\n                  inline svfMemInfoFuncSrc: TSourceViewFrame\r\n                    Left = 0\r\n                    Top = 0\r\n                    Width = 423\r\n                    Height = 333\r\n                    Align = alClient\r\n                    TabOrder = 0\r\n                    inherited synmSourceView: TSynMemo\r\n                      Width = 423\r\n                      Height = 312\r\n                    end\r\n                    inherited eSrcFileName: TEdit\r\n                      Width = 423\r\n                    end\r\n                  end\r\n                end\r\n              end\r\n            end\r\n            object pMemInfoButtom: TPanel\r\n              Left = 0\r\n              Top = 364\r\n              Width = 890\r\n              Height = 249\r\n              Align = alBottom\r\n              BevelEdges = []\r\n              BevelOuter = bvNone\r\n              Caption = 'pMemInfoButtom'\r\n              Constraints.MinHeight = 200\r\n              ShowCaption = False\r\n              TabOrder = 1\r\n              object splMemInfoTreeView2: TSplitter\r\n                Left = 356\r\n                Top = 0\r\n                Height = 249\r\n              end\r\n              object vstMemInfoObjects: TVirtualStringTree\r\n                Left = 0\r\n                Top = 0\r\n                Width = 356\r\n                Height = 249\r\n                Align = alLeft\r\n                ClipboardFormats.Strings = (\r\n                  'CSV'\r\n                  'HTML Format'\r\n                  'Plain text'\r\n                  'Rich Text Format'\r\n                  'Rich Text Format Without Objects'\r\n                  'Unicode text')\r\n                Constraints.MinWidth = 200\r\n                Header.AutoSizeIndex = 0\r\n                Header.Font.Charset = DEFAULT_CHARSET\r\n                Header.Font.Color = clWindowText\r\n                Header.Font.Height = -11\r\n                Header.Font.Name = 'Tahoma'\r\n                Header.Font.Style = []\r\n                Header.Options = [hoColumnResize, hoVisible, hoHeaderClickAutoSort]\r\n                Header.SortColumn = 2\r\n                Header.SortDirection = sdDescending\r\n                Header.Style = hsFlatButtons\r\n                ScrollBarOptions.AlwaysVisible = True\r\n                TabOrder = 0\r\n                TreeOptions.AutoOptions = [toAutoDropExpand, toAutoScrollOnExpand, toAutoSort, toAutoTristateTracking, toAutoDeleteMovedNodes]\r\n                TreeOptions.MiscOptions = [toAcceptOLEDrop, toFullRepaintOnResize, toGridExtensions, toInitOnSave, toToggleOnDblClick, toWheelPanning, toEditOnClick]\r\n                TreeOptions.PaintOptions = [toHideFocusRect, toShowButtons, toShowDropmark, toShowHorzGridLines, toShowTreeLines, toShowVertGridLines, toThemeAware, toUseBlendedImages, toFullVertGridLines]\r\n                TreeOptions.SelectionOptions = [toFullRowSelect, toMultiSelect]\r\n                OnColumnResize = vstColumnResize\r\n                OnCompareNodes = vstMemInfoObjectsCompareNodes\r\n                OnFocusChanged = vstMemInfoObjectsFocusChanged\r\n                OnGetText = vstMemInfoObjectsGetText\r\n                OnGetNodeDataSize = vstThreadsGetNodeDataSize\r\n                OnResize = vstTreeResize\r\n                Columns = <\r\n                  item\r\n                    CaptionAlignment = taCenter\r\n                    Options = [coAllowClick, coDraggable, coEnabled, coParentBidiMode, coParentColor, coResizable, coShowDropMark, coVisible, coFixed, coAllowFocus, coUseCaptionAlignment]\r\n                    Position = 0\r\n                    Width = 200\r\n                    WideText = 'Object type'\r\n                  end\r\n                  item\r\n                    Alignment = taRightJustify\r\n                    CaptionAlignment = taCenter\r\n                    Options = [coAllowClick, coDraggable, coEnabled, coParentBidiMode, coParentColor, coResizable, coShowDropMark, coVisible, coAllowFocus, coUseCaptionAlignment]\r\n                    Position = 1\r\n                    Width = 70\r\n                    WideText = 'Pointer'\r\n                  end\r\n                  item\r\n                    Alignment = taRightJustify\r\n                    CaptionAlignment = taCenter\r\n                    DefaultSortDirection = sdDescending\r\n                    Options = [coAllowClick, coDraggable, coEnabled, coParentBidiMode, coParentColor, coResizable, coShowDropMark, coVisible, coAllowFocus, coUseCaptionAlignment]\r\n                    Position = 2\r\n                    Width = 65\r\n                    WideText = 'Size'\r\n                  end>\r\n              end\r\n              object vstMemInfoObjStack: TVirtualStringTree\r\n                Left = 359\r\n                Top = 0\r\n                Width = 531\r\n                Height = 249\r\n                Align = alClient\r\n                ClipboardFormats.Strings = (\r\n                  'CSV'\r\n                  'HTML Format'\r\n                  'Plain text'\r\n                  'Rich Text Format'\r\n                  'Rich Text Format Without Objects'\r\n                  'Unicode text')\r\n                Constraints.MinWidth = 200\r\n                Header.AutoSizeIndex = 0\r\n                Header.Font.Charset = DEFAULT_CHARSET\r\n                Header.Font.Color = clWindowText\r\n                Header.Font.Height = -11\r\n                Header.Font.Name = 'Tahoma'\r\n                Header.Font.Style = []\r\n                Header.Options = [hoColumnResize, hoShowSortGlyphs, hoVisible]\r\n                Header.Style = hsFlatButtons\r\n                ScrollBarOptions.AlwaysVisible = True\r\n                TabOrder = 1\r\n                TreeOptions.MiscOptions = [toAcceptOLEDrop, toFullRepaintOnResize, toGridExtensions, toInitOnSave, toToggleOnDblClick, toWheelPanning, toEditOnClick]\r\n                TreeOptions.PaintOptions = [toShowButtons, toShowDropmark, toShowHorzGridLines, toShowTreeLines, toShowVertGridLines, toThemeAware, toUseBlendedImages, toFullVertGridLines]\r\n                TreeOptions.SelectionOptions = [toExtendedFocus, toFullRowSelect, toMultiSelect]\r\n                OnDblClick = vstMemInfoObjStackDblClick\r\n                OnGetText = vstMemStackGetText\r\n                OnGetNodeDataSize = vstThreadsGetNodeDataSize\r\n                Columns = <\r\n                  item\r\n                    Alignment = taRightJustify\r\n                    CaptionAlignment = taCenter\r\n                    Options = [coAllowClick, coDraggable, coEnabled, coParentBidiMode, coParentColor, coResizable, coShowDropMark, coVisible, coFixed, coSmartResize, coAllowFocus, coUseCaptionAlignment]\r\n                    Position = 0\r\n                    Width = 70\r\n                    WideText = 'Address'\r\n                  end\r\n                  item\r\n                    CaptionAlignment = taCenter\r\n                    Options = [coAllowClick, coDraggable, coEnabled, coParentBidiMode, coParentColor, coResizable, coShowDropMark, coVisible, coAllowFocus, coUseCaptionAlignment]\r\n                    Position = 1\r\n                    Width = 150\r\n                    WideText = 'Unit'\r\n                  end\r\n                  item\r\n                    Alignment = taRightJustify\r\n                    CaptionAlignment = taCenter\r\n                    Options = [coAllowClick, coDraggable, coEnabled, coParentBidiMode, coParentColor, coResizable, coShowDropMark, coVisible, coAllowFocus, coUseCaptionAlignment]\r\n                    Position = 2\r\n                    WideText = 'Line'\r\n                  end\r\n                  item\r\n                    Position = 3\r\n                    Width = 500\r\n                    WideText = 'Call stack function'\r\n                  end>\r\n              end\r\n            end\r\n          end\r\n        end\r\n      end\r\n    end\r\n    object tsExceptions: TTabSheet\r\n      Caption = 'Exceptions'\r\n      ImageIndex = 4\r\n      object splExceptInfo: TSplitter\r\n        Left = 411\r\n        Top = 0\r\n        Height = 665\r\n      end\r\n      object vstExceptionThreads: TVirtualStringTree\r\n        Left = 0\r\n        Top = 0\r\n        Width = 411\r\n        Height = 665\r\n        Align = alLeft\r\n        ClipboardFormats.Strings = (\r\n          'CSV'\r\n          'HTML Format'\r\n          'Plain text'\r\n          'Rich Text Format'\r\n          'Rich Text Format Without Objects'\r\n          'Unicode text')\r\n        Constraints.MinWidth = 200\r\n        Header.AutoSizeIndex = 0\r\n        Header.Font.Charset = DEFAULT_CHARSET\r\n        Header.Font.Color = clWindowText\r\n        Header.Font.Height = -11\r\n        Header.Font.Name = 'Tahoma'\r\n        Header.Font.Style = []\r\n        Header.Options = [hoColumnResize, hoShowSortGlyphs, hoVisible]\r\n        Header.Style = hsFlatButtons\r\n        ScrollBarOptions.AlwaysVisible = True\r\n        TabOrder = 0\r\n        TreeOptions.AutoOptions = [toAutoDropExpand, toAutoTristateTracking, toAutoDeleteMovedNodes]\r\n        TreeOptions.MiscOptions = [toAcceptOLEDrop, toFullRepaintOnResize, toInitOnSave, toToggleOnDblClick, toWheelPanning]\r\n        TreeOptions.PaintOptions = [toShowButtons, toShowDropmark, toShowHorzGridLines, toShowRoot, toShowTreeLines, toShowVertGridLines, toThemeAware, toUseBlendedImages, toFullVertGridLines]\r\n        TreeOptions.SelectionOptions = [toExtendedFocus, toFullRowSelect]\r\n        OnColumnResize = vstColumnResize\r\n        OnDrawText = vstThreadsDrawText\r\n        OnFocusChanged = vstExceptionThreadsFocusChanged\r\n        OnGetText = vstExceptionThreadsGetText\r\n        OnGetNodeDataSize = vstThreadsGetNodeDataSize\r\n        OnResize = vstTreeResize\r\n        Columns = <\r\n          item\r\n            CaptionAlignment = taCenter\r\n            Options = [coAllowClick, coDraggable, coEnabled, coParentBidiMode, coParentColor, coResizable, coShowDropMark, coVisible, coFixed, coAllowFocus, coUseCaptionAlignment]\r\n            Position = 0\r\n            Width = 250\r\n            WideText = 'Thread name'\r\n          end\r\n          item\r\n            Alignment = taRightJustify\r\n            CaptionAlignment = taCenter\r\n            Options = [coAllowClick, coDraggable, coEnabled, coParentBidiMode, coParentColor, coResizable, coShowDropMark, coVisible, coAllowFocus, coUseCaptionAlignment]\r\n            Position = 1\r\n            Width = 90\r\n            WideText = 'ID'\r\n          end\r\n          item\r\n            Alignment = taRightJustify\r\n            CaptionAlignment = taCenter\r\n            Options = [coAllowClick, coDraggable, coEnabled, coParentBidiMode, coParentColor, coResizable, coShowDropMark, coVisible, coAllowFocus, coUseCaptionAlignment]\r\n            Position = 2\r\n            WideText = 'Count'\r\n          end>\r\n      end\r\n      object pExceptionInfo: TPanel\r\n        Left = 414\r\n        Top = 0\r\n        Width = 973\r\n        Height = 665\r\n        Align = alClient\r\n        BevelEdges = []\r\n        BevelOuter = bvNone\r\n        Caption = 'pExceptionInfo'\r\n        Constraints.MinWidth = 400\r\n        ShowCaption = False\r\n        TabOrder = 1\r\n        object pnl2: TPanel\r\n          Left = 0\r\n          Top = 24\r\n          Width = 973\r\n          Height = 641\r\n          Align = alClient\r\n          BevelOuter = bvNone\r\n          TabOrder = 0\r\n          object splExceptInfo2: TSplitter\r\n            Left = 511\r\n            Top = 0\r\n            Height = 641\r\n          end\r\n          object vstExceptionList: TVirtualStringTree\r\n            Left = 0\r\n            Top = 0\r\n            Width = 511\r\n            Height = 641\r\n            Align = alLeft\r\n            ClipboardFormats.Strings = (\r\n              'CSV'\r\n              'HTML Format'\r\n              'Plain text'\r\n              'Rich Text Format'\r\n              'Rich Text Format Without Objects'\r\n              'Unicode text')\r\n            Constraints.MinWidth = 200\r\n            Header.AutoSizeIndex = 0\r\n            Header.Font.Charset = DEFAULT_CHARSET\r\n            Header.Font.Color = clWindowText\r\n            Header.Font.Height = -11\r\n            Header.Font.Name = 'Tahoma'\r\n            Header.Font.Style = []\r\n            Header.Options = [hoColumnResize, hoVisible]\r\n            Header.SortDirection = sdDescending\r\n            Header.Style = hsFlatButtons\r\n            ScrollBarOptions.AlwaysVisible = True\r\n            TabOrder = 0\r\n            TreeOptions.AutoOptions = [toAutoDropExpand, toAutoScrollOnExpand, toAutoSort, toAutoTristateTracking, toAutoDeleteMovedNodes]\r\n            TreeOptions.MiscOptions = [toAcceptOLEDrop, toFullRepaintOnResize, toGridExtensions, toInitOnSave, toToggleOnDblClick, toWheelPanning, toEditOnClick]\r\n            TreeOptions.PaintOptions = [toHideFocusRect, toShowButtons, toShowDropmark, toShowHorzGridLines, toShowTreeLines, toShowVertGridLines, toThemeAware, toUseBlendedImages, toFullVertGridLines]\r\n            TreeOptions.SelectionOptions = [toFullRowSelect, toMultiSelect]\r\n            OnColumnResize = vstColumnResize\r\n            OnFocusChanged = vstExceptionListFocusChanged\r\n            OnGetText = vstExceptionListGetText\r\n            OnGetNodeDataSize = vstThreadsGetNodeDataSize\r\n            OnResize = vstTreeResize\r\n            Columns = <\r\n              item\r\n                Alignment = taRightJustify\r\n                CaptionAlignment = taCenter\r\n                Options = [coAllowClick, coDraggable, coEnabled, coParentBidiMode, coParentColor, coResizable, coShowDropMark, coVisible, coFixed, coAllowFocus, coUseCaptionAlignment]\r\n                Position = 0\r\n                Width = 70\r\n                WideText = 'Pointer'\r\n              end\r\n              item\r\n                CaptionAlignment = taCenter\r\n                Options = [coAllowClick, coDraggable, coEnabled, coParentBidiMode, coParentColor, coResizable, coShowDropMark, coVisible, coFixed, coAllowFocus, coUseCaptionAlignment]\r\n                Position = 1\r\n                Width = 120\r\n                WideText = 'Exception type'\r\n              end\r\n              item\r\n                CaptionAlignment = taCenter\r\n                DefaultSortDirection = sdDescending\r\n                Options = [coAllowClick, coDraggable, coEnabled, coParentBidiMode, coParentColor, coResizable, coShowDropMark, coVisible, coSmartResize, coAllowFocus, coUseCaptionAlignment]\r\n                Position = 2\r\n                Width = 300\r\n                WideText = 'Message'\r\n              end>\r\n          end\r\n          object pExceptInfoAdv: TPanel\r\n            Left = 514\r\n            Top = 0\r\n            Width = 459\r\n            Height = 641\r\n            Align = alClient\r\n            BevelEdges = []\r\n            BevelOuter = bvNone\r\n            Caption = 'pExceptInfoAdv'\r\n            Constraints.MinWidth = 200\r\n            ShowCaption = False\r\n            TabOrder = 1\r\n            object splExceptInfoAdv: TSplitter\r\n              Left = 0\r\n              Top = 217\r\n              Width = 459\r\n              Height = 3\r\n              Cursor = crVSplit\r\n              Align = alTop\r\n            end\r\n            object vstExceptionCallStack: TVirtualStringTree\r\n              Left = 0\r\n              Top = 0\r\n              Width = 459\r\n              Height = 217\r\n              Align = alTop\r\n              ClipboardFormats.Strings = (\r\n                'CSV'\r\n                'HTML Format'\r\n                'Plain text'\r\n                'Rich Text Format'\r\n                'Rich Text Format Without Objects'\r\n                'Unicode text')\r\n              Constraints.MinHeight = 100\r\n              Header.AutoSizeIndex = 0\r\n              Header.Font.Charset = DEFAULT_CHARSET\r\n              Header.Font.Color = clWindowText\r\n              Header.Font.Height = -11\r\n              Header.Font.Name = 'Tahoma'\r\n              Header.Font.Style = []\r\n              Header.Options = [hoColumnResize, hoShowSortGlyphs, hoVisible]\r\n              Header.Style = hsFlatButtons\r\n              ScrollBarOptions.AlwaysVisible = True\r\n              TabOrder = 0\r\n              TreeOptions.MiscOptions = [toAcceptOLEDrop, toFullRepaintOnResize, toGridExtensions, toInitOnSave, toToggleOnDblClick, toWheelPanning, toEditOnClick]\r\n              TreeOptions.PaintOptions = [toShowButtons, toShowDropmark, toShowHorzGridLines, toShowTreeLines, toShowVertGridLines, toThemeAware, toUseBlendedImages, toFullVertGridLines]\r\n              TreeOptions.SelectionOptions = [toExtendedFocus, toFullRowSelect, toMultiSelect]\r\n              OnFocusChanged = vstExceptionCallStackFocusChanged\r\n              OnGetText = vstExceptionCallStackGetText\r\n              OnGetNodeDataSize = vstThreadsGetNodeDataSize\r\n              Columns = <\r\n                item\r\n                  Alignment = taRightJustify\r\n                  CaptionAlignment = taCenter\r\n                  Options = [coAllowClick, coDraggable, coEnabled, coParentBidiMode, coParentColor, coResizable, coShowDropMark, coVisible, coFixed, coSmartResize, coAllowFocus, coUseCaptionAlignment]\r\n                  Position = 0\r\n                  Width = 70\r\n                  WideText = 'Address'\r\n                end\r\n                item\r\n                  CaptionAlignment = taCenter\r\n                  Options = [coAllowClick, coDraggable, coEnabled, coParentBidiMode, coParentColor, coResizable, coShowDropMark, coVisible, coAllowFocus, coUseCaptionAlignment]\r\n                  Position = 1\r\n                  Width = 120\r\n                  WideText = 'Unit'\r\n                end\r\n                item\r\n                  Alignment = taRightJustify\r\n                  CaptionAlignment = taCenter\r\n                  Options = [coAllowClick, coDraggable, coEnabled, coParentBidiMode, coParentColor, coResizable, coShowDropMark, coVisible, coAllowFocus, coUseCaptionAlignment]\r\n                  Position = 2\r\n                  WideText = 'Line'\r\n                end\r\n                item\r\n                  Position = 3\r\n                  Width = 500\r\n                  WideText = 'Call stack function'\r\n                end>\r\n            end\r\n            inline svfExceptInfoSource: TSourceViewFrame\r\n              Left = 0\r\n              Top = 220\r\n              Width = 459\r\n              Height = 421\r\n              Align = alClient\r\n              Constraints.MinHeight = 100\r\n              TabOrder = 1\r\n              inherited synmSourceView: TSynMemo\r\n                Width = 459\r\n                Height = 400\r\n                SearchEngine = dmShareData.synEditSearch1\r\n              end\r\n              inherited eSrcFileName: TEdit\r\n                Width = 459\r\n              end\r\n            end\r\n          end\r\n        end\r\n        object cbExceptionInfo: TCoolBar\r\n          Left = 0\r\n          Top = 0\r\n          Width = 973\r\n          Height = 24\r\n          AutoSize = True\r\n          BandBorderStyle = bsNone\r\n          Bands = <\r\n            item\r\n              Control = actbExceptionInfo\r\n              ImageIndex = -1\r\n              MinHeight = 24\r\n              Width = 973\r\n            end>\r\n          EdgeBorders = [ebTop]\r\n          EdgeInner = esNone\r\n          EdgeOuter = esNone\r\n          FixedOrder = True\r\n          object actbExceptionInfo: TActionToolBar\r\n            Left = 0\r\n            Top = 0\r\n            Width = 973\r\n            Height = 24\r\n            ActionManager = amMain\r\n            Caption = 'actbExceptionInfo'\r\n            ColorMap.MenuColor = clMenu\r\n            ColorMap.BtnSelectedColor = clBtnFace\r\n            ColorMap.UnusedColor = 14410210\r\n            Font.Charset = DEFAULT_CHARSET\r\n            Font.Color = clBlack\r\n            Font.Height = -11\r\n            Font.Name = 'Tahoma'\r\n            Font.Style = []\r\n            ParentFont = False\r\n            Spacing = 0\r\n          end\r\n        end\r\n      end\r\n    end\r\n    object tsCodeTracking: TTabSheet\r\n      Caption = 'Code tracking'\r\n      ImageIndex = 5\r\n      object splCodeTrack1: TSplitter\r\n        Left = 542\r\n        Top = 0\r\n        Height = 665\r\n      end\r\n      object vstTrackThreads: TVirtualStringTree\r\n        Left = 0\r\n        Top = 0\r\n        Width = 542\r\n        Height = 665\r\n        Align = alLeft\r\n        BorderStyle = bsNone\r\n        ClipboardFormats.Strings = (\r\n          'CSV'\r\n          'HTML Format'\r\n          'Plain text'\r\n          'Rich Text Format'\r\n          'Rich Text Format Without Objects'\r\n          'Unicode text')\r\n        Colors.FocusedSelectionColor = clBtnFace\r\n        Colors.FocusedSelectionBorderColor = clBtnFace\r\n        Colors.SelectionRectangleBlendColor = clBtnFace\r\n        Colors.SelectionRectangleBorderColor = clBtnFace\r\n        Colors.SelectionTextColor = clWindowText\r\n        Constraints.MinWidth = 200\r\n        DrawSelectionMode = smBlendedRectangle\r\n        Header.AutoSizeIndex = -1\r\n        Header.Font.Charset = DEFAULT_CHARSET\r\n        Header.Font.Color = clWindowText\r\n        Header.Font.Height = -11\r\n        Header.Font.Name = 'Tahoma'\r\n        Header.Font.Style = []\r\n        Header.Options = [hoColumnResize, hoVisible]\r\n        Header.Style = hsPlates\r\n        ScrollBarOptions.AlwaysVisible = True\r\n        TabOrder = 0\r\n        TreeOptions.AutoOptions = [toAutoTristateTracking, toAutoDeleteMovedNodes]\r\n        TreeOptions.MiscOptions = [toAcceptOLEDrop, toInitOnSave, toToggleOnDblClick, toWheelPanning]\r\n        TreeOptions.PaintOptions = [toHideFocusRect, toShowButtons, toShowDropmark, toShowHorzGridLines, toShowTreeLines, toShowVertGridLines, toThemeAware, toUseBlendedImages, toFullVertGridLines]\r\n        TreeOptions.SelectionOptions = [toDisableDrawSelection, toExtendedFocus, toFullRowSelect]\r\n        OnColumnResize = vstColumnResize\r\n        OnDrawText = vstThreadsDrawText\r\n        OnFocusChanged = vstTrackThreadsFocusChanged\r\n        OnFocusChanging = vstTrackThreadsFocusChanging\r\n        OnGetText = vstTrackThreadsGetText\r\n        OnGetNodeDataSize = vstThreadsGetNodeDataSize\r\n        OnResize = vstTreeResize\r\n        Columns = <\r\n          item\r\n            CaptionAlignment = taCenter\r\n            Options = [coEnabled, coParentBidiMode, coParentColor, coResizable, coShowDropMark, coVisible, coFixed, coUseCaptionAlignment]\r\n            Position = 0\r\n            Width = 275\r\n            WideText = 'Thread name'\r\n          end\r\n          item\r\n            Alignment = taRightJustify\r\n            CaptionAlignment = taCenter\r\n            Options = [coEnabled, coParentBidiMode, coParentColor, coResizable, coShowDropMark, coVisible, coUseCaptionAlignment]\r\n            Position = 1\r\n            Width = 90\r\n            WideText = 'ID'\r\n          end\r\n          item\r\n            Alignment = taRightJustify\r\n            CaptionAlignment = taCenter\r\n            Options = [coAllowClick, coDraggable, coEnabled, coParentBidiMode, coParentColor, coResizable, coShowDropMark, coVisible, coAllowFocus, coUseCaptionAlignment]\r\n            Position = 2\r\n            Width = 90\r\n            WideText = 'Call Count'\r\n          end\r\n          item\r\n            Alignment = taRightJustify\r\n            CaptionAlignment = taCenter\r\n            Options = [coEnabled, coParentBidiMode, coParentColor, coResizable, coShowDropMark, coVisible, coUseCaptionAlignment]\r\n            Position = 3\r\n            Width = 70\r\n            WideText = 'CPU time'\r\n          end>\r\n      end\r\n      object pCodeTrackingInfo: TPanel\r\n        Left = 545\r\n        Top = 0\r\n        Width = 842\r\n        Height = 665\r\n        Align = alClient\r\n        BevelOuter = bvNone\r\n        Caption = 'pCodeTrackingInfo'\r\n        Constraints.MinWidth = 400\r\n        ShowCaption = False\r\n        TabOrder = 1\r\n        object pTrackAdv: TPanel\r\n          Left = 0\r\n          Top = 26\r\n          Width = 842\r\n          Height = 639\r\n          Align = alClient\r\n          BevelOuter = bvNone\r\n          Caption = 'pTrackAdv'\r\n          ShowCaption = False\r\n          TabOrder = 0\r\n          object splCodeTrack2: TSplitter\r\n            Left = 457\r\n            Top = 0\r\n            Height = 639\r\n          end\r\n          object vstTrackFuncs: TVirtualStringTree\r\n            Left = 0\r\n            Top = 0\r\n            Width = 457\r\n            Height = 639\r\n            Align = alLeft\r\n            BevelEdges = []\r\n            BevelInner = bvNone\r\n            BevelOuter = bvNone\r\n            BorderStyle = bsNone\r\n            ClipboardFormats.Strings = (\r\n              'CSV'\r\n              'HTML Format'\r\n              'Plain text'\r\n              'Rich Text Format'\r\n              'Rich Text Format Without Objects'\r\n              'Unicode text')\r\n            Constraints.MinWidth = 200\r\n            Header.AutoSizeIndex = 0\r\n            Header.Font.Charset = DEFAULT_CHARSET\r\n            Header.Font.Color = clWindowText\r\n            Header.Font.Height = -11\r\n            Header.Font.Name = 'Tahoma'\r\n            Header.Font.Style = []\r\n            Header.Options = [hoColumnResize, hoVisible, hoHeaderClickAutoSort]\r\n            Header.SortColumn = 2\r\n            Header.SortDirection = sdDescending\r\n            PopupMenu = pmVirtualTreeView\r\n            ScrollBarOptions.AlwaysVisible = True\r\n            TabOrder = 0\r\n            TreeOptions.AutoOptions = [toAutoDropExpand, toAutoScrollOnExpand, toAutoSort, toAutoTristateTracking, toAutoDeleteMovedNodes]\r\n            TreeOptions.MiscOptions = [toAcceptOLEDrop, toFullRepaintOnResize, toGridExtensions, toInitOnSave, toToggleOnDblClick, toWheelPanning, toEditOnClick]\r\n            TreeOptions.PaintOptions = [toShowButtons, toShowDropmark, toShowHorzGridLines, toShowTreeLines, toShowVertGridLines, toThemeAware, toUseBlendedImages, toFullVertGridLines]\r\n            TreeOptions.SelectionOptions = [toExtendedFocus, toFullRowSelect, toMultiSelect]\r\n            OnColumnResize = vstColumnResize\r\n            OnCompareNodes = vstTrackFuncsCompareNodes\r\n            OnDrawText = vstTrackFuncsDrawText\r\n            OnFocusChanged = vstTrackFuncsFocusChanged\r\n            OnFocusChanging = vstTrackFuncsFocusChanging\r\n            OnGetText = vstTrackFuncsGetText\r\n            OnGetNodeDataSize = vstThreadsGetNodeDataSize\r\n            OnIncrementalSearch = vstTrackFuncsIncrementalSearch\r\n            OnResize = vstTreeResize\r\n            Columns = <\r\n              item\r\n                CaptionAlignment = taCenter\r\n                Options = [coAllowClick, coDraggable, coEnabled, coParentBidiMode, coParentColor, coResizable, coShowDropMark, coVisible, coFixed, coAllowFocus, coUseCaptionAlignment]\r\n                Position = 0\r\n                Width = 280\r\n                WideText = 'Function name'\r\n              end\r\n              item\r\n                Alignment = taRightJustify\r\n                CaptionAlignment = taCenter\r\n                DefaultSortDirection = sdDescending\r\n                Options = [coAllowClick, coDraggable, coEnabled, coParentBidiMode, coParentColor, coResizable, coShowDropMark, coVisible, coAllowFocus, coUseCaptionAlignment]\r\n                Position = 1\r\n                Width = 90\r\n                WideText = 'Call count'\r\n              end\r\n              item\r\n                Alignment = taRightJustify\r\n                CaptionAlignment = taCenter\r\n                DefaultSortDirection = sdDescending\r\n                Options = [coAllowClick, coDraggable, coEnabled, coParentBidiMode, coParentColor, coResizable, coShowDropMark, coVisible, coAllowFocus, coUseCaptionAlignment]\r\n                Position = 2\r\n                Width = 70\r\n                WideText = 'CPU time'\r\n              end>\r\n          end\r\n          object pcTrackFuncAdv: TPageControl\r\n            Left = 460\r\n            Top = 0\r\n            Width = 382\r\n            Height = 639\r\n            ActivePage = tsTrackFuncAdvSrc\r\n            Align = alClient\r\n            Constraints.MinWidth = 200\r\n            TabOrder = 1\r\n            object tsTrackFuncAdvLinks: TTabSheet\r\n              Caption = 'Links'\r\n              object pTrackFuncAdv: TPanel\r\n                Left = 0\r\n                Top = 0\r\n                Width = 374\r\n                Height = 611\r\n                Align = alClient\r\n                BevelOuter = bvNone\r\n                Caption = 'pTrackFuncAdv'\r\n                ShowCaption = False\r\n                TabOrder = 0\r\n                OnResize = pTrackFuncAdvResize\r\n                object splTrackFuncAdv: TSplitter\r\n                  Left = 0\r\n                  Top = 329\r\n                  Width = 374\r\n                  Height = 3\r\n                  Cursor = crVSplit\r\n                  Align = alTop\r\n                end\r\n                object vstTrackFuncParent: TVirtualStringTree\r\n                  Left = 0\r\n                  Top = 0\r\n                  Width = 374\r\n                  Height = 329\r\n                  Align = alTop\r\n                  BevelEdges = []\r\n                  BevelInner = bvNone\r\n                  BevelOuter = bvNone\r\n                  BorderStyle = bsNone\r\n                  ClipboardFormats.Strings = (\r\n                    'CSV'\r\n                    'HTML Format'\r\n                    'Plain text'\r\n                    'Rich Text Format'\r\n                    'Rich Text Format Without Objects'\r\n                    'Unicode text')\r\n                  Constraints.MinHeight = 100\r\n                  Header.AutoSizeIndex = 0\r\n                  Header.Font.Charset = DEFAULT_CHARSET\r\n                  Header.Font.Color = clWindowText\r\n                  Header.Font.Height = -11\r\n                  Header.Font.Name = 'Tahoma'\r\n                  Header.Font.Style = []\r\n                  Header.Options = [hoColumnResize, hoShowSortGlyphs, hoVisible]\r\n                  PopupMenu = pmTrackFuncAdvParents\r\n                  ScrollBarOptions.AlwaysVisible = True\r\n                  TabOrder = 0\r\n                  TreeOptions.MiscOptions = [toAcceptOLEDrop, toFullRepaintOnResize, toGridExtensions, toInitOnSave, toToggleOnDblClick, toWheelPanning, toEditOnClick]\r\n                  TreeOptions.PaintOptions = [toShowButtons, toShowDropmark, toShowHorzGridLines, toShowTreeLines, toShowVertGridLines, toThemeAware, toUseBlendedImages, toFullVertGridLines]\r\n                  TreeOptions.SelectionOptions = [toExtendedFocus, toFullRowSelect, toMultiSelect]\r\n                  OnDblClick = vstTrackFuncParentDblClick\r\n                  OnDrawText = vstTrackFuncLinksDrawText\r\n                  OnGetText = vstTrackFuncParentGetText\r\n                  OnGetNodeDataSize = vstThreadsGetNodeDataSize\r\n                  Columns = <\r\n                    item\r\n                      CaptionAlignment = taCenter\r\n                      Options = [coAllowClick, coDraggable, coEnabled, coParentBidiMode, coParentColor, coResizable, coShowDropMark, coVisible, coFixed, coAllowFocus, coUseCaptionAlignment]\r\n                      Position = 0\r\n                      Width = 280\r\n                      WideText = 'Parent function name'\r\n                    end\r\n                    item\r\n                      Alignment = taRightJustify\r\n                      CaptionAlignment = taCenter\r\n                      Options = [coAllowClick, coDraggable, coEnabled, coParentBidiMode, coParentColor, coResizable, coShowDropMark, coVisible, coAllowFocus, coUseCaptionAlignment]\r\n                      Position = 1\r\n                      WideText = 'LineNo'\r\n                    end\r\n                    item\r\n                      Alignment = taRightJustify\r\n                      CaptionAlignment = taCenter\r\n                      Options = [coAllowClick, coDraggable, coEnabled, coParentBidiMode, coParentColor, coResizable, coShowDropMark, coVisible, coAllowFocus, coUseCaptionAlignment]\r\n                      Position = 2\r\n                      Width = 90\r\n                      WideText = 'Call count'\r\n                    end\r\n                    item\r\n                      Alignment = taRightJustify\r\n                      CaptionAlignment = taCenter\r\n                      Options = [coAllowClick, coDraggable, coEnabled, coParentBidiMode, coParentColor, coResizable, coShowDropMark, coVisible, coAllowFocus, coUseCaptionAlignment]\r\n                      Position = 3\r\n                      Width = 70\r\n                      WideText = 'CPU time'\r\n                    end>\r\n                end\r\n                object vstTrackFuncChilds: TVirtualStringTree\r\n                  Left = 0\r\n                  Top = 332\r\n                  Width = 374\r\n                  Height = 279\r\n                  Align = alClient\r\n                  BevelEdges = []\r\n                  BevelInner = bvNone\r\n                  BevelOuter = bvNone\r\n                  BorderStyle = bsNone\r\n                  ClipboardFormats.Strings = (\r\n                    'CSV'\r\n                    'HTML Format'\r\n                    'Plain text'\r\n                    'Rich Text Format'\r\n                    'Rich Text Format Without Objects'\r\n                    'Unicode text')\r\n                  Constraints.MinHeight = 100\r\n                  Header.AutoSizeIndex = 0\r\n                  Header.Font.Charset = DEFAULT_CHARSET\r\n                  Header.Font.Color = clWindowText\r\n                  Header.Font.Height = -11\r\n                  Header.Font.Name = 'Tahoma'\r\n                  Header.Font.Style = []\r\n                  Header.Options = [hoColumnResize, hoShowSortGlyphs, hoVisible]\r\n                  PopupMenu = pmVirtualTreeView\r\n                  ScrollBarOptions.AlwaysVisible = True\r\n                  TabOrder = 1\r\n                  TreeOptions.MiscOptions = [toAcceptOLEDrop, toFullRepaintOnResize, toGridExtensions, toInitOnSave, toToggleOnDblClick, toWheelPanning, toEditOnClick]\r\n                  TreeOptions.PaintOptions = [toShowButtons, toShowDropmark, toShowHorzGridLines, toShowTreeLines, toShowVertGridLines, toThemeAware, toUseBlendedImages, toFullVertGridLines]\r\n                  TreeOptions.SelectionOptions = [toExtendedFocus, toFullRowSelect, toMultiSelect]\r\n                  OnCompareNodes = vstTrackFuncChildsCompareNodes\r\n                  OnDblClick = vstTrackFuncChildsDblClick\r\n                  OnDrawText = vstTrackFuncLinksDrawText\r\n                  OnGetText = vstTrackFuncChildsGetText\r\n                  OnGetNodeDataSize = vstThreadsGetNodeDataSize\r\n                  OnIncrementalSearch = vstTrackFuncChildsIncrementalSearch\r\n                  Columns = <\r\n                    item\r\n                      CaptionAlignment = taCenter\r\n                      Options = [coAllowClick, coDraggable, coEnabled, coParentBidiMode, coParentColor, coResizable, coShowDropMark, coVisible, coFixed, coAllowFocus, coUseCaptionAlignment]\r\n                      Position = 0\r\n                      Width = 280\r\n                      WideText = 'Child function name'\r\n                    end\r\n                    item\r\n                      Alignment = taRightJustify\r\n                      CaptionAlignment = taCenter\r\n                      Options = [coAllowClick, coDraggable, coEnabled, coParentBidiMode, coParentColor, coResizable, coShowDropMark, coVisible, coAllowFocus, coUseCaptionAlignment]\r\n                      Position = 1\r\n                      WideText = 'LineNo'\r\n                    end\r\n                    item\r\n                      Alignment = taRightJustify\r\n                      CaptionAlignment = taCenter\r\n                      Options = [coAllowClick, coDraggable, coEnabled, coParentBidiMode, coParentColor, coResizable, coShowDropMark, coVisible, coAllowFocus, coUseCaptionAlignment]\r\n                      Position = 2\r\n                      Width = 90\r\n                      WideText = 'Call count'\r\n                    end\r\n                    item\r\n                      Alignment = taRightJustify\r\n                      CaptionAlignment = taCenter\r\n                      Options = [coAllowClick, coDraggable, coEnabled, coParentBidiMode, coParentColor, coResizable, coShowDropMark, coVisible, coAllowFocus, coUseCaptionAlignment]\r\n                      Position = 3\r\n                      Width = 70\r\n                      WideText = 'CPU time'\r\n                    end>\r\n                end\r\n              end\r\n            end\r\n            object tsTrackFuncAdvSrc: TTabSheet\r\n              Caption = 'Source'\r\n              ImageIndex = 1\r\n              inline svfTrackFuncAdvSource: TSourceViewFrame\r\n                Left = 0\r\n                Top = 0\r\n                Width = 374\r\n                Height = 611\r\n                Align = alClient\r\n                TabOrder = 0\r\n                inherited synmSourceView: TSynMemo\r\n                  Width = 374\r\n                  Height = 590\r\n                  SearchEngine = dmShareData.synEditSearch1\r\n                end\r\n                inherited eSrcFileName: TEdit\r\n                  Width = 374\r\n                end\r\n              end\r\n            end\r\n          end\r\n        end\r\n        object cbCodeTrackingInfo: TCoolBar\r\n          Left = 0\r\n          Top = 0\r\n          Width = 842\r\n          Height = 26\r\n          AutoSize = True\r\n          BandBorderStyle = bsNone\r\n          Bands = <\r\n            item\r\n              Control = actbCodeTrackingInfo\r\n              ImageIndex = -1\r\n              MinHeight = 26\r\n              Width = 842\r\n            end>\r\n          EdgeBorders = []\r\n          FixedSize = True\r\n          FixedOrder = True\r\n          object actbCodeTrackingInfo: TActionToolBar\r\n            Left = 0\r\n            Top = 0\r\n            Width = 842\r\n            Height = 26\r\n            ActionManager = amMain\r\n            Caption = 'actbCodeTrackingInfo'\r\n            ColorMap.MenuColor = clMenu\r\n            ColorMap.BtnSelectedColor = clBtnFace\r\n            ColorMap.UnusedColor = 14410210\r\n            Font.Charset = DEFAULT_CHARSET\r\n            Font.Color = clBlack\r\n            Font.Height = -11\r\n            Font.Name = 'Tahoma'\r\n            Font.Style = []\r\n            ParentFont = False\r\n            Spacing = 0\r\n          end\r\n        end\r\n      end\r\n    end\r\n    object tsLockTracking: TTabSheet\r\n      Caption = 'Lock tracking'\r\n      ImageIndex = 7\r\n      object splLockTrack1: TSplitter\r\n        Left = 477\r\n        Top = 0\r\n        Height = 665\r\n      end\r\n      object vstLockThreads: TVirtualStringTree\r\n        Left = 0\r\n        Top = 0\r\n        Width = 477\r\n        Height = 665\r\n        Align = alLeft\r\n        BorderStyle = bsNone\r\n        Colors.FocusedSelectionColor = clBtnFace\r\n        Colors.FocusedSelectionBorderColor = clBtnFace\r\n        Colors.SelectionRectangleBlendColor = clBtnFace\r\n        Colors.SelectionRectangleBorderColor = clBtnFace\r\n        Colors.SelectionTextColor = clWindowText\r\n        Constraints.MinWidth = 200\r\n        DrawSelectionMode = smBlendedRectangle\r\n        Header.AutoSizeIndex = -1\r\n        Header.Font.Charset = DEFAULT_CHARSET\r\n        Header.Font.Color = clWindowText\r\n        Header.Font.Height = -11\r\n        Header.Font.Name = 'Tahoma'\r\n        Header.Font.Style = []\r\n        Header.Options = [hoColumnResize, hoVisible]\r\n        Header.Style = hsPlates\r\n        IncrementalSearch = isVisibleOnly\r\n        ScrollBarOptions.AlwaysVisible = True\r\n        TabOrder = 0\r\n        TreeOptions.AutoOptions = [toAutoTristateTracking, toAutoDeleteMovedNodes]\r\n        TreeOptions.MiscOptions = [toAcceptOLEDrop, toInitOnSave, toToggleOnDblClick, toWheelPanning]\r\n        TreeOptions.PaintOptions = [toHideFocusRect, toShowButtons, toShowDropmark, toShowHorzGridLines, toShowTreeLines, toShowVertGridLines, toThemeAware, toUseBlendedImages, toFullVertGridLines]\r\n        TreeOptions.SelectionOptions = [toDisableDrawSelection, toExtendedFocus, toFullRowSelect]\r\n        OnColumnResize = vstColumnResize\r\n        OnCompareNodes = vstLockThreadsCompareNodes\r\n        OnDrawText = vstThreadsDrawText\r\n        OnFocusChanged = vstLockThreadsFocusChanged\r\n        OnGetText = vstLockThreadsGetText\r\n        OnGetNodeDataSize = vstThreadsGetNodeDataSize\r\n        OnIncrementalSearch = vstLockThreadsIncrementalSearch\r\n        OnResize = vstTreeResize\r\n        Columns = <\r\n          item\r\n            CaptionAlignment = taCenter\r\n            Options = [coEnabled, coParentBidiMode, coParentColor, coResizable, coShowDropMark, coVisible, coFixed, coUseCaptionAlignment]\r\n            Position = 0\r\n            Width = 300\r\n            WideText = 'Thread name'\r\n          end\r\n          item\r\n            Alignment = taRightJustify\r\n            CaptionAlignment = taCenter\r\n            Options = [coEnabled, coParentBidiMode, coParentColor, coResizable, coShowDropMark, coVisible, coUseCaptionAlignment]\r\n            Position = 1\r\n            Width = 90\r\n            WideText = 'ID'\r\n          end\r\n          item\r\n            Alignment = taRightJustify\r\n            CaptionAlignment = taCenter\r\n            Options = [coEnabled, coParentBidiMode, coParentColor, coResizable, coShowDropMark, coVisible, coUseCaptionAlignment]\r\n            Position = 2\r\n            Width = 70\r\n            WideText = 'Wait time'\r\n          end>\r\n      end\r\n      object pLockTrackingInfo: TPanel\r\n        Left = 480\r\n        Top = 0\r\n        Width = 907\r\n        Height = 665\r\n        Align = alClient\r\n        BevelEdges = []\r\n        BevelOuter = bvNone\r\n        Caption = 'pLockTrackingInfo'\r\n        Constraints.MinWidth = 400\r\n        ShowCaption = False\r\n        TabOrder = 1\r\n        object spl4: TSplitter\r\n          Left = 0\r\n          Top = 393\r\n          Width = 907\r\n          Height = 3\r\n          Cursor = crVSplit\r\n          Align = alBottom\r\n        end\r\n        object cbLockTracking: TCoolBar\r\n          Left = 0\r\n          Top = 0\r\n          Width = 907\r\n          Height = 24\r\n          AutoSize = True\r\n          BandBorderStyle = bsNone\r\n          Bands = <\r\n            item\r\n              Control = actbLockTracking\r\n              ImageIndex = -1\r\n              MinHeight = 24\r\n              Width = 907\r\n            end>\r\n          EdgeInner = esNone\r\n          EdgeOuter = esNone\r\n          FixedOrder = True\r\n          object actbLockTracking: TActionToolBar\r\n            Left = 0\r\n            Top = 0\r\n            Width = 907\r\n            Height = 24\r\n            ActionManager = amMain\r\n            Caption = 'actbLockTracking'\r\n            ColorMap.MenuColor = clMenu\r\n            ColorMap.BtnSelectedColor = clBtnFace\r\n            ColorMap.UnusedColor = 14410210\r\n            Font.Charset = DEFAULT_CHARSET\r\n            Font.Color = clBlack\r\n            Font.Height = -11\r\n            Font.Name = 'Tahoma'\r\n            Font.Style = []\r\n            ParentFont = False\r\n            Spacing = 0\r\n          end\r\n        end\r\n        object pLockTrackingAdv: TPanel\r\n          Left = 0\r\n          Top = 24\r\n          Width = 907\r\n          Height = 369\r\n          Align = alClient\r\n          BevelOuter = bvNone\r\n          Caption = 'pLockTrackingAdv'\r\n          Constraints.MinHeight = 250\r\n          ShowCaption = False\r\n          TabOrder = 1\r\n          object splLockTrack3: TSplitter\r\n            Left = 457\r\n            Top = 0\r\n            Height = 369\r\n          end\r\n          object vstLockTrackingList: TVirtualStringTree\r\n            Left = 0\r\n            Top = 0\r\n            Width = 457\r\n            Height = 369\r\n            Align = alLeft\r\n            BevelEdges = []\r\n            BevelInner = bvNone\r\n            BevelOuter = bvNone\r\n            BorderStyle = bsNone\r\n            Constraints.MinWidth = 200\r\n            Header.AutoSizeIndex = 0\r\n            Header.Font.Charset = DEFAULT_CHARSET\r\n            Header.Font.Color = clWindowText\r\n            Header.Font.Height = -11\r\n            Header.Font.Name = 'Tahoma'\r\n            Header.Font.Style = []\r\n            Header.Options = [hoColumnResize, hoVisible, hoHeaderClickAutoSort]\r\n            Header.SortColumn = 2\r\n            Header.SortDirection = sdDescending\r\n            IncrementalSearch = isVisibleOnly\r\n            ScrollBarOptions.AlwaysVisible = True\r\n            TabOrder = 0\r\n            TreeOptions.AutoOptions = [toAutoDropExpand, toAutoScrollOnExpand, toAutoSort, toAutoTristateTracking, toAutoDeleteMovedNodes]\r\n            TreeOptions.MiscOptions = [toAcceptOLEDrop, toFullRepaintOnResize, toGridExtensions, toInitOnSave, toToggleOnDblClick, toWheelPanning, toEditOnClick]\r\n            TreeOptions.PaintOptions = [toShowButtons, toShowDropmark, toShowHorzGridLines, toShowTreeLines, toShowVertGridLines, toThemeAware, toUseBlendedImages, toFullVertGridLines]\r\n            TreeOptions.SelectionOptions = [toExtendedFocus, toFullRowSelect]\r\n            OnColumnResize = vstColumnResize\r\n            OnCompareNodes = vstLockTrackingListCompareNodes\r\n            OnDrawText = vstTrackFuncsDrawText\r\n            OnFocusChanged = vstLockTrackingListFocusChanged\r\n            OnGetText = vstLockTrackingListGetText\r\n            OnGetNodeDataSize = vstThreadsGetNodeDataSize\r\n            OnIncrementalSearch = vstLockTrackingListIncrementalSearch\r\n            OnResize = vstTreeResize\r\n            Columns = <\r\n              item\r\n                CaptionAlignment = taCenter\r\n                Options = [coAllowClick, coDraggable, coEnabled, coParentBidiMode, coParentColor, coResizable, coShowDropMark, coVisible, coFixed, coAllowFocus, coUseCaptionAlignment]\r\n                Position = 0\r\n                Width = 300\r\n                WideText = 'Function name'\r\n              end\r\n              item\r\n                Alignment = taRightJustify\r\n                CaptionAlignment = taCenter\r\n                DefaultSortDirection = sdDescending\r\n                Options = [coAllowClick, coDraggable, coEnabled, coParentBidiMode, coParentColor, coResizable, coShowDropMark, coVisible, coAllowFocus, coUseCaptionAlignment]\r\n                Position = 1\r\n                Width = 70\r\n                WideText = 'Call count'\r\n              end\r\n              item\r\n                Alignment = taRightJustify\r\n                CaptionAlignment = taCenter\r\n                DefaultSortDirection = sdDescending\r\n                Options = [coAllowClick, coDraggable, coEnabled, coParentBidiMode, coParentColor, coResizable, coShowDropMark, coVisible, coAllowFocus, coUseCaptionAlignment]\r\n                Position = 2\r\n                Width = 70\r\n                WideText = 'Wait time'\r\n              end>\r\n          end\r\n          object pcLockTrackingLinks: TPageControl\r\n            Left = 460\r\n            Top = 0\r\n            Width = 447\r\n            Height = 369\r\n            ActivePage = ts1\r\n            Align = alClient\r\n            Constraints.MinWidth = 200\r\n            TabOrder = 1\r\n            object ts1: TTabSheet\r\n              Caption = 'Links'\r\n              object pLockTrackingLinks: TPanel\r\n                Left = 0\r\n                Top = 0\r\n                Width = 439\r\n                Height = 341\r\n                Align = alClient\r\n                BevelOuter = bvNone\r\n                ShowCaption = False\r\n                TabOrder = 0\r\n                OnResize = pLockTrackingLinksResize\r\n                object spl3: TSplitter\r\n                  Left = 0\r\n                  Top = 100\r\n                  Width = 439\r\n                  Height = 3\r\n                  Cursor = crVSplit\r\n                  Align = alTop\r\n                end\r\n                object vstLockTrackingParents: TVirtualStringTree\r\n                  Left = 0\r\n                  Top = 0\r\n                  Width = 439\r\n                  Height = 100\r\n                  Align = alTop\r\n                  BevelEdges = []\r\n                  BevelInner = bvNone\r\n                  BevelOuter = bvNone\r\n                  BorderStyle = bsNone\r\n                  ClipboardFormats.Strings = (\r\n                    'CSV'\r\n                    'HTML Format'\r\n                    'Plain text'\r\n                    'Rich Text Format'\r\n                    'Rich Text Format Without Objects'\r\n                    'Unicode text')\r\n                  Constraints.MinHeight = 100\r\n                  Header.AutoSizeIndex = 0\r\n                  Header.Font.Charset = DEFAULT_CHARSET\r\n                  Header.Font.Color = clWindowText\r\n                  Header.Font.Height = -11\r\n                  Header.Font.Name = 'Tahoma'\r\n                  Header.Font.Style = []\r\n                  Header.Options = [hoColumnResize, hoShowSortGlyphs, hoVisible]\r\n                  IncrementalSearch = isVisibleOnly\r\n                  ScrollBarOptions.AlwaysVisible = True\r\n                  TabOrder = 0\r\n                  TreeOptions.MiscOptions = [toAcceptOLEDrop, toFullRepaintOnResize, toGridExtensions, toInitOnSave, toToggleOnDblClick, toWheelPanning, toEditOnClick]\r\n                  TreeOptions.PaintOptions = [toShowButtons, toShowDropmark, toShowHorzGridLines, toShowTreeLines, toShowVertGridLines, toThemeAware, toUseBlendedImages, toFullVertGridLines]\r\n                  TreeOptions.SelectionOptions = [toExtendedFocus, toFullRowSelect, toMultiSelect]\r\n                  OnCompareNodes = vstLockTrackingParentsCompareNodes\r\n                  OnDblClick = vstLockTrackingParentsDblClick\r\n                  OnDrawText = vstTrackFuncLinksDrawText\r\n                  OnGetText = vstLockTrackingLinksGetText\r\n                  OnGetNodeDataSize = vstThreadsGetNodeDataSize\r\n                  OnIncrementalSearch = vstLockTrackingParentsIncrementalSearch\r\n                  Columns = <\r\n                    item\r\n                      CaptionAlignment = taCenter\r\n                      Options = [coAllowClick, coDraggable, coEnabled, coParentBidiMode, coParentColor, coResizable, coShowDropMark, coVisible, coFixed, coAllowFocus, coUseCaptionAlignment]\r\n                      Position = 0\r\n                      Width = 300\r\n                      WideText = 'Parent function name'\r\n                    end\r\n                    item\r\n                      Alignment = taRightJustify\r\n                      CaptionAlignment = taCenter\r\n                      Options = [coAllowClick, coDraggable, coEnabled, coParentBidiMode, coParentColor, coResizable, coShowDropMark, coVisible, coAllowFocus, coUseCaptionAlignment]\r\n                      Position = 1\r\n                      WideText = 'LineNo'\r\n                    end\r\n                    item\r\n                      Alignment = taRightJustify\r\n                      CaptionAlignment = taCenter\r\n                      Options = [coAllowClick, coDraggable, coEnabled, coParentBidiMode, coParentColor, coResizable, coShowDropMark, coVisible, coAllowFocus, coUseCaptionAlignment]\r\n                      Position = 2\r\n                      Width = 70\r\n                      WideText = 'Call count'\r\n                    end\r\n                    item\r\n                      Alignment = taRightJustify\r\n                      CaptionAlignment = taCenter\r\n                      Options = [coAllowClick, coDraggable, coEnabled, coParentBidiMode, coParentColor, coResizable, coShowDropMark, coVisible, coAllowFocus, coUseCaptionAlignment]\r\n                      Position = 3\r\n                      Width = 70\r\n                      WideText = 'Wait time'\r\n                    end>\r\n                end\r\n                object vstLockTrackingChilds: TVirtualStringTree\r\n                  Left = 0\r\n                  Top = 103\r\n                  Width = 439\r\n                  Height = 238\r\n                  Align = alClient\r\n                  BevelEdges = []\r\n                  BevelInner = bvNone\r\n                  BevelOuter = bvNone\r\n                  BorderStyle = bsNone\r\n                  ClipboardFormats.Strings = (\r\n                    'CSV'\r\n                    'HTML Format'\r\n                    'Plain text'\r\n                    'Rich Text Format'\r\n                    'Rich Text Format Without Objects'\r\n                    'Unicode text')\r\n                  Constraints.MinHeight = 100\r\n                  Header.AutoSizeIndex = 0\r\n                  Header.Font.Charset = DEFAULT_CHARSET\r\n                  Header.Font.Color = clWindowText\r\n                  Header.Font.Height = -11\r\n                  Header.Font.Name = 'Tahoma'\r\n                  Header.Font.Style = []\r\n                  Header.Options = [hoColumnResize, hoShowSortGlyphs, hoVisible]\r\n                  IncrementalSearch = isVisibleOnly\r\n                  ScrollBarOptions.AlwaysVisible = True\r\n                  TabOrder = 1\r\n                  TreeOptions.MiscOptions = [toAcceptOLEDrop, toFullRepaintOnResize, toGridExtensions, toInitOnSave, toToggleOnDblClick, toWheelPanning, toEditOnClick]\r\n                  TreeOptions.PaintOptions = [toShowButtons, toShowDropmark, toShowHorzGridLines, toShowTreeLines, toShowVertGridLines, toThemeAware, toUseBlendedImages, toFullVertGridLines]\r\n                  TreeOptions.SelectionOptions = [toExtendedFocus, toFullRowSelect, toMultiSelect]\r\n                  OnCompareNodes = vstLockTrackingChildsCompareNodes\r\n                  OnDblClick = vstLockTrackingChildsDblClick\r\n                  OnDrawText = vstTrackFuncLinksDrawText\r\n                  OnGetText = vstLockTrackingLinksGetText\r\n                  OnGetNodeDataSize = vstThreadsGetNodeDataSize\r\n                  OnIncrementalSearch = vstLockTrackingChildsIncrementalSearch\r\n                  Columns = <\r\n                    item\r\n                      CaptionAlignment = taCenter\r\n                      Options = [coAllowClick, coDraggable, coEnabled, coParentBidiMode, coParentColor, coResizable, coShowDropMark, coVisible, coFixed, coAllowFocus, coUseCaptionAlignment]\r\n                      Position = 0\r\n                      Width = 300\r\n                      WideText = 'Child function name'\r\n                    end\r\n                    item\r\n                      Alignment = taRightJustify\r\n                      CaptionAlignment = taCenter\r\n                      Options = [coAllowClick, coDraggable, coEnabled, coParentBidiMode, coParentColor, coResizable, coShowDropMark, coVisible, coAllowFocus, coUseCaptionAlignment]\r\n                      Position = 1\r\n                      WideText = 'LineNo'\r\n                    end\r\n                    item\r\n                      Alignment = taRightJustify\r\n                      CaptionAlignment = taCenter\r\n                      Options = [coAllowClick, coDraggable, coEnabled, coParentBidiMode, coParentColor, coResizable, coShowDropMark, coVisible, coAllowFocus, coUseCaptionAlignment]\r\n                      Position = 2\r\n                      Width = 70\r\n                      WideText = 'Call count'\r\n                    end\r\n                    item\r\n                      Alignment = taRightJustify\r\n                      CaptionAlignment = taCenter\r\n                      Options = [coAllowClick, coDraggable, coEnabled, coParentBidiMode, coParentColor, coResizable, coShowDropMark, coVisible, coAllowFocus, coUseCaptionAlignment]\r\n                      Position = 3\r\n                      Width = 70\r\n                      WideText = 'Wait time'\r\n                    end>\r\n                end\r\n              end\r\n            end\r\n            object ts2: TTabSheet\r\n              Caption = 'Source'\r\n              ImageIndex = 1\r\n              inline svfLockTrackingSource: TSourceViewFrame\r\n                Left = 0\r\n                Top = 0\r\n                Width = 439\r\n                Height = 341\r\n                Align = alClient\r\n                TabOrder = 0\r\n                inherited synmSourceView: TSynMemo\r\n                  Width = 439\r\n                  Height = 320\r\n                  SearchEngine = dmShareData.synEditSearch1\r\n                end\r\n                inherited eSrcFileName: TEdit\r\n                  Width = 439\r\n                end\r\n              end\r\n            end\r\n          end\r\n        end\r\n        object p2: TPanel\r\n          Left = 0\r\n          Top = 396\r\n          Width = 907\r\n          Height = 269\r\n          Align = alBottom\r\n          BevelEdges = []\r\n          BevelOuter = bvNone\r\n          Caption = 'pMemInfoButtom'\r\n          Constraints.MinHeight = 100\r\n          ShowCaption = False\r\n          TabOrder = 2\r\n          object splLockTrack2: TSplitter\r\n            Left = 331\r\n            Top = 0\r\n            Height = 269\r\n          end\r\n          object vstLockTrackingSyncObjs: TVirtualStringTree\r\n            Left = 0\r\n            Top = 0\r\n            Width = 331\r\n            Height = 269\r\n            Align = alLeft\r\n            ClipboardFormats.Strings = (\r\n              'CSV'\r\n              'HTML Format'\r\n              'Plain text'\r\n              'Rich Text Format'\r\n              'Rich Text Format Without Objects'\r\n              'Unicode text')\r\n            Constraints.MinWidth = 200\r\n            Header.AutoSizeIndex = 0\r\n            Header.Font.Charset = DEFAULT_CHARSET\r\n            Header.Font.Color = clWindowText\r\n            Header.Font.Height = -11\r\n            Header.Font.Name = 'Tahoma'\r\n            Header.Font.Style = []\r\n            Header.Options = [hoColumnResize, hoVisible, hoHeaderClickAutoSort]\r\n            Header.SortColumn = 2\r\n            Header.SortDirection = sdDescending\r\n            Header.Style = hsFlatButtons\r\n            IncrementalSearch = isVisibleOnly\r\n            ScrollBarOptions.AlwaysVisible = True\r\n            TabOrder = 0\r\n            TreeOptions.AutoOptions = [toAutoDropExpand, toAutoScrollOnExpand, toAutoSort, toAutoTristateTracking, toAutoDeleteMovedNodes]\r\n            TreeOptions.MiscOptions = [toAcceptOLEDrop, toFullRepaintOnResize, toGridExtensions, toInitOnSave, toToggleOnDblClick, toWheelPanning, toEditOnClick]\r\n            TreeOptions.PaintOptions = [toHideFocusRect, toShowButtons, toShowDropmark, toShowHorzGridLines, toShowTreeLines, toShowVertGridLines, toThemeAware, toUseBlendedImages, toFullVertGridLines]\r\n            TreeOptions.SelectionOptions = [toFullRowSelect, toMultiSelect]\r\n            OnColumnResize = vstColumnResize\r\n            OnCompareNodes = vstLockTrackingSyncObjsCompareNodes\r\n            OnFocusChanged = vstLockTrackingSyncObjsFocusChanged\r\n            OnGetText = vstLockTrackingSyncObjsGetText\r\n            OnGetNodeDataSize = vstThreadsGetNodeDataSize\r\n            OnIncrementalSearch = vstLockTrackingSyncObjsIncrementalSearch\r\n            OnResize = vstTreeResize\r\n            Columns = <\r\n              item\r\n                CaptionAlignment = taCenter\r\n                Options = [coAllowClick, coDraggable, coEnabled, coParentBidiMode, coParentColor, coResizable, coShowDropMark, coVisible, coFixed, coAllowFocus, coUseCaptionAlignment]\r\n                Position = 0\r\n                Width = 150\r\n                WideText = 'Sync object type'\r\n              end\r\n              item\r\n                Alignment = taRightJustify\r\n                CaptionAlignment = taCenter\r\n                Options = [coAllowClick, coDraggable, coEnabled, coParentBidiMode, coParentColor, coResizable, coShowDropMark, coVisible, coAllowFocus, coUseCaptionAlignment]\r\n                Position = 1\r\n                Width = 90\r\n                WideText = 'Owning Thread'\r\n              end\r\n              item\r\n                Alignment = taRightJustify\r\n                CaptionAlignment = taCenter\r\n                Options = [coAllowClick, coDraggable, coEnabled, coParentBidiMode, coParentColor, coResizable, coShowDropMark, coVisible, coAllowFocus, coUseCaptionAlignment]\r\n                Position = 2\r\n                Width = 70\r\n                WideText = 'Wait time'\r\n              end>\r\n          end\r\n          object vstLockTrackingSyncObjStack: TVirtualStringTree\r\n            Left = 334\r\n            Top = 0\r\n            Width = 573\r\n            Height = 269\r\n            Align = alClient\r\n            ClipboardFormats.Strings = (\r\n              'CSV'\r\n              'HTML Format'\r\n              'Plain text'\r\n              'Rich Text Format'\r\n              'Rich Text Format Without Objects'\r\n              'Unicode text')\r\n            Constraints.MinWidth = 200\r\n            Header.AutoSizeIndex = 0\r\n            Header.Font.Charset = DEFAULT_CHARSET\r\n            Header.Font.Color = clWindowText\r\n            Header.Font.Height = -11\r\n            Header.Font.Name = 'Tahoma'\r\n            Header.Font.Style = []\r\n            Header.Options = [hoColumnResize, hoShowSortGlyphs, hoVisible]\r\n            Header.Style = hsFlatButtons\r\n            IncrementalSearch = isVisibleOnly\r\n            ScrollBarOptions.AlwaysVisible = True\r\n            TabOrder = 1\r\n            TreeOptions.MiscOptions = [toAcceptOLEDrop, toFullRepaintOnResize, toGridExtensions, toInitOnSave, toToggleOnDblClick, toWheelPanning, toEditOnClick]\r\n            TreeOptions.PaintOptions = [toShowButtons, toShowDropmark, toShowHorzGridLines, toShowTreeLines, toShowVertGridLines, toThemeAware, toUseBlendedImages, toFullVertGridLines]\r\n            TreeOptions.SelectionOptions = [toExtendedFocus, toFullRowSelect, toMultiSelect]\r\n            OnCompareNodes = vstLockTrackingSyncObjStackCompareNodes\r\n            OnDblClick = vstLockTrackingSyncObjStackDblClick\r\n            OnGetText = vstLockTrackingSyncObjStackGetText\r\n            OnGetNodeDataSize = vstThreadsGetNodeDataSize\r\n            OnIncrementalSearch = vstLockTrackingSyncObjStackIncrementalSearch\r\n            Columns = <\r\n              item\r\n                Alignment = taRightJustify\r\n                CaptionAlignment = taCenter\r\n                Options = [coAllowClick, coDraggable, coEnabled, coParentBidiMode, coParentColor, coResizable, coShowDropMark, coVisible, coFixed, coSmartResize, coAllowFocus, coUseCaptionAlignment]\r\n                Position = 0\r\n                Width = 70\r\n                WideText = 'Address'\r\n              end\r\n              item\r\n                CaptionAlignment = taCenter\r\n                Options = [coAllowClick, coDraggable, coEnabled, coParentBidiMode, coParentColor, coResizable, coShowDropMark, coVisible, coAllowFocus, coUseCaptionAlignment]\r\n                Position = 1\r\n                Width = 150\r\n                WideText = 'Unit'\r\n              end\r\n              item\r\n                Alignment = taRightJustify\r\n                CaptionAlignment = taCenter\r\n                Options = [coAllowClick, coDraggable, coEnabled, coParentBidiMode, coParentColor, coResizable, coShowDropMark, coVisible, coAllowFocus, coUseCaptionAlignment]\r\n                Position = 2\r\n                WideText = 'Line'\r\n              end\r\n              item\r\n                Position = 3\r\n                Width = 500\r\n                WideText = 'Call stack function'\r\n              end>\r\n          end\r\n        end\r\n      end\r\n    end\r\n    object tsUpdateInfo: TTabSheet\r\n      Caption = 'Update info'\r\n      ImageIndex = 6\r\n      object vstUpdateInfo: TVirtualStringTree\r\n        Left = 0\r\n        Top = 24\r\n        Width = 1387\r\n        Height = 641\r\n        Align = alClient\r\n        ClipboardFormats.Strings = (\r\n          'CSV'\r\n          'HTML Format'\r\n          'Plain text'\r\n          'Rich Text Format'\r\n          'Rich Text Format Without Objects'\r\n          'Unicode text')\r\n        Header.AutoSizeIndex = 0\r\n        Header.Font.Charset = DEFAULT_CHARSET\r\n        Header.Font.Color = clWindowText\r\n        Header.Font.Height = -11\r\n        Header.Font.Name = 'Tahoma'\r\n        Header.Font.Style = []\r\n        Header.Options = [hoAutoResize, hoColumnResize, hoDrag, hoShowSortGlyphs, hoVisible]\r\n        TabOrder = 0\r\n        TreeOptions.PaintOptions = [toShowButtons, toShowDropmark, toShowRoot, toShowTreeLines, toShowVertGridLines, toThemeAware, toUseBlendedImages]\r\n        TreeOptions.SelectionOptions = [toExtendedFocus, toFullRowSelect, toMultiSelect]\r\n        OnDrawText = vstUpdateInfoDrawText\r\n        OnGetText = vstUpdateInfoGetText\r\n        OnGetNodeDataSize = vstThreadsGetNodeDataSize\r\n        Columns = <\r\n          item\r\n            Position = 0\r\n            Width = 1383\r\n            WideText = 'Info'\r\n          end>\r\n      end\r\n      object cbUpdateInfo: TCoolBar\r\n        Left = 0\r\n        Top = 0\r\n        Width = 1387\r\n        Height = 24\r\n        AutoSize = True\r\n        BandBorderStyle = bsNone\r\n        Bands = <\r\n          item\r\n            Control = actbUpdateInfo\r\n            ImageIndex = -1\r\n            MinHeight = 24\r\n            Width = 1387\r\n          end>\r\n        EdgeInner = esNone\r\n        EdgeOuter = esNone\r\n        FixedOrder = True\r\n        object actbUpdateInfo: TActionToolBar\r\n          Left = 0\r\n          Top = 0\r\n          Width = 1387\r\n          Height = 24\r\n          ActionManager = amMain\r\n          Caption = 'actbUpdateInfo'\r\n          ColorMap.MenuColor = clMenu\r\n          ColorMap.BtnSelectedColor = clBtnFace\r\n          ColorMap.UnusedColor = 14410210\r\n          Font.Charset = DEFAULT_CHARSET\r\n          Font.Color = clBlack\r\n          Font.Height = -11\r\n          Font.Name = 'Tahoma'\r\n          Font.Style = []\r\n          ParentFont = False\r\n          Spacing = 0\r\n        end\r\n      end\r\n    end\r\n  end\r\n  object rbnMain: TRibbon\r\n    Left = 0\r\n    Top = 0\r\n    Width = 1395\r\n    Height = 143\r\n    ActionManager = amMain\r\n    ApplicationMenu.Caption = 'Recent projects'\r\n    ApplicationMenu.CommandType = ctCommands\r\n    ApplicationMenu.Icon.Data = {\r\n      0000010001002020000001002000A81000001600000028000000200000004000\r\n      0000010020000000000080100000000000000000000000000000000000007E7E\r\n      7E007E7E7E007E7E7E007E7E7E007E7E7E007E7E7E007E7E7E007E7E7E007E7E\r\n      7E007E7E7E007E7E7E007E7E7E007E7E7E007E7E7E007E7E7E007E7E7E007E7E\r\n      7E007E7E7E007E7E7E007E7E7E007E7E7E007E7E7E007E7E7E007E7E7E007E7E\r\n      7E007E7E7E007E7E7E007E7E7E007E7E7E007E7E7E007E7E7E007E7E7E007E7E\r\n      7E007E7E7EFF7E7E7E707E7E7E007E7E7E007E7E7E007E7E7E007E7E7E007E7E\r\n      7E007E7E7E007E7E7E007E7E7E007E7E7E007E7E7E007E7E7E007E7E7E007E7E\r\n      7E007E7E7E007E7E7E007E7E7E007E7E7E007E7E7E007E7E7E007E7E7E007E7E\r\n      7E007E7E7E007E7E7E007E7E7E007E7E7E007E7E7E007E7E7E007E7E7E007E7E\r\n      7E007E7E7EFF7E7E7EAF7E7E7E307E7E7E007E7E7E007E7E7E007E7E7E007E7E\r\n      7E007E7E7E007E7E7E007E7E7E007E7E7E007E7E7E007E7E7E007E7E7E007E7E\r\n      7E107E7E7EBF7E7E7E107E7E7E007E7E7E007E7E7E007E7E7E007E7E7E007E7E\r\n      7E007E7E7E007E7E7E007E7E7E007E7E7E007E7E7E007E7E7E007E7E7E007E7E\r\n      7E007E7E7EFF7E7E7E007E7E7EBF7E7E7E407E7E7E007E7E7E007E7E7E007E7E\r\n      7E007E7E7E007E7E7E007E7E7E007E7E7E007E7E7E007E7E7E007E7E7E007E7E\r\n      7E9F7E7E7EDF7E7E7E107E7E7E007E7E7E007E7E7E007E7E7E007E7E7E007E7E\r\n      7E007E7E7E007E7E7E007E7E7E007E7E7E007E7E7E007E7E7E007E7E7E007E7E\r\n      7E007E7E7EFF7E7E7E007E7E7E107E7E7ECF7E7E7E8F7E7E7E107E7E7E007E7E\r\n      7E007E7E7E007E7E7E007E7E7E007E7E7E007E7E7E007E7E7E007E7E7E507E7E\r\n      7EFF7E7E7E607E7E7E007E7E7E007E7E7E007E7E7E007E7E7E007E7E7E007E7E\r\n      7E007E7E7E007E7E7E007E7E7E007E7E7E007E7E7E007E7E7E007E7E7E007E7E\r\n      7E007E7E7EFF7E7E7E007E7E7E007E7E7E107E7E7EAF7E7E7EEF7E7E7E9F7E7E\r\n      7E507E7E7E207E7E7E007E7E7E007E7E7E407E7E7E707E7E7EDF7E7E7EFF7E7E\r\n      7EBF7E7E7E007E7E7E007E7E7E007E7E7E007E7E7E007E7E7E007E7E7E007E7E\r\n      7E007E7E7E007E7E7E007E7E7E007E7E7E007E7E7E007E7E7E007E7E7E007E7E\r\n      7E007E7E7EFF7E7E7E007E7E7E007E7E7E007E7E7E007E7E7E407E7E7EBF7E7E\r\n      7EFF7E7E7EFF7E7E7EFF7E7E7EFF7E7E7EFF7E7E7EFF7E7E7EFF7E7E7EFF7E7E\r\n      7E307E7E7E007E7E7E007E7E7E007E7E7E007E7E7E007E7E7E007E7E7E007E7E\r\n      7E007E7E7E007E7E7E007E7E7E007E7E7E007E7E7E007E7E7E007E7E7E007E7E\r\n      7E007E7E7EFF7E7E7E007E7E7E007E7E7E007E7E7E007E7E7E007E7E7E007E7E\r\n      7E207E7E7E707E7E7E8F7E7E7EBF7E7E7EBF7E7E7EAF7E7E7EFF7E7E7EBF7E7E\r\n      7E007E7E7E007E7E7E007E7E7E007E7E7E007E7E7E007E7E7E007E7E7E007E7E\r\n      7E007E7E7E007E7E7E007E7E7E007E7E7E007E7E7E007E7E7E007E7E7E007E7E\r\n      7E007E7E7EFF7E7E7E007E7E7E007E7E7E007E7E7E007E7E7E007E7E7E007E7E\r\n      7E007E7E7E007E7E7E007E7E7E007E7E7E007E7E7E807E7E7EEF7E7E7E8F7E7E\r\n      7E007E7E7E007E7E7E007E7E7E007E7E7E007E7E7E007E7E7E007E7E7E007E7E\r\n      7E007E7E7E007E7E7E007E7E7E007E7E7E007E7E7E007E7E7E007E7E7E007E7E\r\n      7E007E7E7EFF7E7E7E007E7E7E007E7E7E007E7E7E007E7E7E007E7E7E007E7E\r\n      7E007E7E7E007E7E7E007E7E7E007E7E7E207E7E7EEF7E7E7E807E7E7E707E7E\r\n      7E507E7E7E007E7E7E007E7E7E007E7E7E007E7E7E007E7E7E007E7E7E007E7E\r\n      7E007E7E7E007E7E7E007E7E7E007E7E7E007E7E7E007E7E7E007E7E7E007E7E\r\n      7E007E7E7EFF7E7E7E507E7E7E007E7E7E007E7E7E007E7E7E007E7E7E007E7E\r\n      7E007E7E7E007E7E7E007E7E7E007E7E7E9F7E7E7EDF7E7E7E007E7E7E307E7E\r\n      7EAF7E7E7E007E7E7E007E7E7E007E7E7E007E7E7E007E7E7E007E7E7E007E7E\r\n      7E007E7E7E007E7E7E007E7E7E007E7E7E007E7E7E007E7E7E007E7E7E007E7E\r\n      7E007E7E7EFF7E7E7EDF7E7E7E507E7E7E007E7E7E007E7E7E007E7E7E007E7E\r\n      7E007E7E7E007E7E7E007E7E7E407E7E7EFF7E7E7E507E7E7E007E7E7E007E7E\r\n      7EDF7E7E7E407E7E7E007E7E7E007E7E7E007E7E7E007E7E7E007E7E7E007E7E\r\n      7E007E7E7E007E7E7E007E7E7E007E7E7E007E7E7E007E7E7E007E7E7E007E7E\r\n      7E007E7E7EFF7E7E7E507E7E7ECF7E7E7EBF7E7E7E507E7E7E007E7E7E007E7E\r\n      7E007E7E7E307E7E7E9F7E7E7EFF7E7E7EBF7E7E7E007E7E7E007E7E7E007E7E\r\n      7E607E7E7EDF7E7E7E107E7E7E007E7E7E007E7E7E007E7E7E007E7E7E007E7E\r\n      7E007E7E7E007E7E7E007E7E7E007E7E7E007E7E7E007E7E7E007E7E7E007E7E\r\n      7E007E7E7EFF7E7E7E007E7E7E107E7E7E8F7E7E7EFF7E7E7EFF7E7E7EFF7E7E\r\n      7EFF7E7E7EFF7E7E7EFF7E7E7EFF7E7E7E207E7E7E007E7E7E007E7E7E007E7E\r\n      7E007E7E7ECF7E7E7ECF7E7E7E107E7E7E007E7E7E007E7E7E007E7E7E007E7E\r\n      7E007E7E7E007E7E7E007E7E7E007E7E7E007E7E7E007E7E7E007E7E7E007E7E\r\n      7E007E7E7EFF7E7E7E007E7E7E007E7E7E007E7E7E207E7E7E707E7E7EBF7E7E\r\n      7EBF7E7E7ECF7E7E7EFF7E7E7E9F7E7E7E007E7E7E007E7E7E007E7E7E007E7E\r\n      7E007E7E7E207E7E7EEF7E7E7EEF7E7E7E507E7E7E007E7E7E007E7E7E007E7E\r\n      7E007E7E7E007E7E7E007E7E7E407E7E7ECF7E7E7ECF7E7E7E007E7E7E007E7E\r\n      7E007E7E7EFF7E7E7E007E7E7E007E7E7E007E7E7E007E7E7E007E7E7E007E7E\r\n      7E007E7E7E807E7E7EEF7E7E7E9F7E7E7E007E7E7E007E7E7E007E7E7E007E7E\r\n      7E007E7E7E007E7E7E307E7E7EEF7E7E7EFF7E7E7ECF7E7E7E707E7E7E307E7E\r\n      7E007E7E7E207E7E7EAF7E7E7EFF7E7E7EBF7E7E7E207E7E7E007E7E7E007E7E\r\n      7E007E7E7EFF7E7E7E007E7E7E007E7E7E007E7E7E007E7E7E007E7E7E007E7E\r\n      7E207E7E7EFF7E7E7E707E7E7E9F7E7E7E407E7E7E007E7E7E007E7E7E007E7E\r\n      7E007E7E7E007E7E7E007E7E7E107E7E7EAF7E7E7EFF7E7E7EFF7E7E7EFF7E7E\r\n      7EFF7E7E7EFF7E7E7EDF7E7E7E407E7E7E007E7E7E007E7E7E007E7E7E007E7E\r\n      7E007E7E7EFF7E7E7E007E7E7E007E7E7E007E7E7E007E7E7E007E7E7E007E7E\r\n      7EAF7E7E7EDF7E7E7E007E7E7E507E7E7EDF7E7E7E107E7E7E007E7E7E007E7E\r\n      7E007E7E7E007E7E7E007E7E7E007E7E7E007E7E7E407E7E7EDF7E7E7EFF7E7E\r\n      7EFF7E7E7E707E7E7E007E7E7E007E7E7E007E7E7E007E7E7E007E7E7E007E7E\r\n      7E007E7E7EFF7E7E7E007E7E7E007E7E7E007E7E7E007E7E7E007E7E7E407E7E\r\n      7EFF7E7E7E407E7E7E007E7E7E007E7E7ECF7E7E7ECF7E7E7E207E7E7E007E7E\r\n      7E007E7E7E007E7E7E007E7E7E007E7E7E407E7E7EBF7E7E7EFF7E7E7E8F7E7E\r\n      7EBF7E7E7E007E7E7E007E7E7E007E7E7E007E7E7E007E7E7E007E7E7E007E7E\r\n      7E007E7E7EFF7E7E7E007E7E7E007E7E7E007E7E7E007E7E7E007E7E7EDF7E7E\r\n      7EAF7E7E7E007E7E7E007E7E7E007E7E7E307E7E7EEF7E7E7EEF7E7E7E8F7E7E\r\n      7E307E7E7E007E7E7E207E7E7E9F7E7E7EFF7E7E7EBF7E7E7E307E7E7E307E7E\r\n      7E807E7E7E007E7E7E007E7E7E007E7E7E007E7E7E007E7E7E007E7E7E007E7E\r\n      7E007E7E7EFF7E7E7E007E7E7E007E7E7E007E7E7E007E7E7E707E7E7EFF7E7E\r\n      7E207E7E7E007E7E7E007E7E7E007E7E7E007E7E7E307E7E7EDF7E7E7EFF7E7E\r\n      7EFF7E7E7EFF7E7E7EFF7E7E7EDF7E7E7E507E7E7E007E7E7E007E7E7E807E7E\r\n      7E407E7E7E007E7E7E007E7E7E007E7E7E007E7E7E007E7E7E007E7E7E007E7E\r\n      7E007E7E7EFF7E7E7E007E7E7E007E7E7E007E7E7E107E7E7EEF7E7E7E807E7E\r\n      7E007E7E7E007E7E7E007E7E7E007E7E7E007E7E7E007E7E7E107E7E7EBF7E7E\r\n      7EFF7E7E7EEF7E7E7E807E7E7E007E7E7E007E7E7E007E7E7E007E7E7E9F7E7E\r\n      7E407E7E7E007E7E7E007E7E7E007E7E7E007E7E7E007E7E7E007E7E7E007E7E\r\n      7E007E7E7EFF7E7E7E007E7E7E007E7E7E007E7E7E8F7E7E7EEF7E7E7E107E7E\r\n      7E007E7E7E007E7E7E007E7E7E007E7E7E007E7E7E307E7E7EBF7E7E7EFF7E7E\r\n      7EBF7E7E7E8F7E7E7E007E7E7E007E7E7E007E7E7E007E7E7E007E7E7EBF7E7E\r\n      7E407E7E7E007E7E7E007E7E7E007E7E7E007E7E7E007E7E7E007E7E7E007E7E\r\n      7E007E7E7EFF7E7E7E007E7E7E007E7E7E207E7E7EFF7E7E7E607E7E7E007E7E\r\n      7E007E7E7E007E7E7E007E7E7E107E7E7E9F7E7E7EFF7E7E7EBF7E7E7E407E7E\r\n      7E707E7E7E507E7E7E007E7E7E007E7E7E007E7E7E007E7E7E007E7E7EBF7E7E\r\n      7E807E7E7E007E7E7E007E7E7E007E7E7E007E7E7E007E7E7E007E7E7E007E7E\r\n      7E007E7E7EFF7E7E7E007E7E7E007E7E7EBF7E7E7ECF7E7E7E007E7E7E007E7E\r\n      7E007E7E7E007E7E7E707E7E7EEF7E7E7EDF7E7E7E607E7E7E007E7E7E007E7E\r\n      7E807E7E7E507E7E7E007E7E7E007E7E7E007E7E7E007E7E7E007E7E7E8F7E7E\r\n      7EAF7E7E7E007E7E7E007E7E7E007E7E7E007E7E7E007E7E7E007E7E7E007E7E\r\n      7E007E7E7EFF7E7E7E007E7E7E507E7E7EFF7E7E7E407E7E7E007E7E7E007E7E\r\n      7E407E7E7EDF7E7E7EFF7E7E7E807E7E7E107E7E7E007E7E7E007E7E7E007E7E\r\n      7E807E7E7E807E7E7E007E7E7E007E7E7E007E7E7E007E7E7E007E7E7E707E7E\r\n      7EFF7E7E7E207E7E7E007E7E7E007E7E7E007E7E7E007E7E7E007E7E7E007E7E\r\n      7E007E7E7EFF7E7E7E007E7E7EDF7E7E7E9F7E7E7E007E7E7E207E7E7EBF7E7E\r\n      7EFF7E7E7EAF7E7E7E207E7E7E007E7E7E007E7E7E007E7E7E007E7E7E007E7E\r\n      7E807E7E7ECF7E7E7E007E7E7E007E7E7E007E7E7E007E7E7E007E7E7E207E7E\r\n      7EFF7E7E7EAF7E7E7E007E7E7E007E7E7E007E7E7E007E7E7E007E7E7E007E7E\r\n      7E007E7E7EFF7E7E7EBF7E7E7EEF7E7E7E307E7E7E807E7E7EFF7E7E7ECF7E7E\r\n      7E407E7E7E007E7E7E007E7E7E007E7E7E007E7E7E007E7E7E007E7E7E007E7E\r\n      7E607E7E7EFF7E7E7E407E7E7E007E7E7E007E7E7E007E7E7E007E7E7E007E7E\r\n      7EBF7E7E7EFF7E7E7E607E7E7E007E7E7E007E7E7E007E7E7E007E7E7E007E7E\r\n      7E007E7E7EFF7E7E7EFF7E7E7ECF7E7E7EEF7E7E7EEF7E7E7E607E7E7E007E7E\r\n      7E007E7E7E007E7E7E007E7E7E007E7E7E007E7E7E007E7E7E007E7E7E007E7E\r\n      7E107E7E7EFF7E7E7EEF7E7E7E107E7E7E007E7E7E007E7E7E007E7E7E007E7E\r\n      7E407E7E7EFF7E7E7EEF7E7E7E507E7E7E007E7E7E007E7E7E007E7E7E007E7E\r\n      7E007E7E7EFF7E7E7EFF7E7E7EFF7E7E7ECF7E7E7E507E7E7E007E7E7E007E7E\r\n      7E007E7E7E007E7E7E007E7E7E007E7E7E007E7E7E007E7E7E007E7E7E007E7E\r\n      7E007E7E7EBF7E7E7EFF7E7E7EEF7E7E7E507E7E7E007E7E7E007E7E7E007E7E\r\n      7E007E7E7EBF7E7E7EFF7E7E7EFF7E7E7E807E7E7E007E7E7E007E7E7E007E7E\r\n      7E007E7E7EFF7E7E7EFF7E7E7EFF7E7E7EFF7E7E7EFF7E7E7EFF7E7E7EFF7E7E\r\n      7EFF7E7E7EFF7E7E7EFF7E7E7EFF7E7E7EFF7E7E7EFF7E7E7EFF7E7E7EFF7E7E\r\n      7EFF7E7E7EFF7E7E7EFF7E7E7EFF7E7E7EFF7E7E7EFF7E7E7EFF7E7E7EFF7E7E\r\n      7EFF7E7E7EFF7E7E7EFF7E7E7EFF7E7E7EFF7E7E7EFF7E7E7EFF7E7E7E007E7E\r\n      7E007E7E7E007E7E7E007E7E7E007E7E7E007E7E7E007E7E7E007E7E7E007E7E\r\n      7E007E7E7E007E7E7E007E7E7E007E7E7E007E7E7E007E7E7E007E7E7E007E7E\r\n      7E007E7E7E007E7E7E007E7E7E007E7E7E007E7E7E007E7E7E007E7E7E007E7E\r\n      7E007E7E7E007E7E7E007E7E7E007E7E7E007E7E7E007E7E7E007E7E7E00FFFF\r\n      FFFF9FFFFFFF8FFF1FFFA7FF1FFFA1FE3FFFB0307FFFBC007FFFBF00FFFFBFF8\r\n      FFFFBFF07FFF9FF27FFF8FE33FFF83871FFFA0078FFFB80F87E3BF8FC083BF07\r\n      E00FBF23F83FBE31F07FBE70407FBC78067FB8FC1E7FB8F83E7FB1E03E7FB3C3\r\n      3E7FA3073E3FA41F3E3F807F1F1F81FF0F0F83FF878780000001FFFFFFFF}\r\n    ApplicationMenu.IconSize = isLarge\r\n    ApplicationMenu.Menu = rbambMain\r\n    Caption = 'Empty'\r\n    QuickAccessToolbar.ActionBar = rbqtbMain\r\n    ShowHelpButton = False\r\n    Tabs = <\r\n      item\r\n        Caption = 'Menu'\r\n        Page = rbpMain\r\n      end\r\n      item\r\n        Caption = 'Options'\r\n        Page = rbnpgOptions\r\n      end>\r\n    TabIndex = 1\r\n    UseCustomFrame = False\r\n    DesignSize = (\r\n      1395\r\n      143)\r\n    StyleName = 'Ribbon - Silver'\r\n    object rbambMain: TRibbonApplicationMenuBar\r\n      Margins.Left = 32\r\n      Margins.Right = 32\r\n      ActionManager = amMain\r\n      OptionItems = <>\r\n      RecentItems = <\r\n        item\r\n          Action = acRecent0\r\n          Caption = 'acRecent0'\r\n          Tag = 0\r\n        end\r\n        item\r\n          Action = acRecent1\r\n          Caption = 'acRecent1'\r\n          Tag = 0\r\n        end\r\n        item\r\n          Action = acRecent2\r\n          Caption = 'acRecent2'\r\n          Tag = 0\r\n        end\r\n        item\r\n          Action = acRecent3\r\n          Caption = 'acRecent3'\r\n          Tag = 0\r\n        end\r\n        item\r\n          Action = acRecent4\r\n          Caption = 'acRecent4'\r\n          Tag = 0\r\n        end\r\n        item\r\n          Action = acRecent5\r\n          Caption = 'acRecent5'\r\n          Tag = 0\r\n        end\r\n        item\r\n          Action = acRecent6\r\n          Caption = 'acRecent6'\r\n          Tag = 0\r\n        end\r\n        item\r\n          Action = acRecent7\r\n          Caption = 'acRecent7'\r\n          Tag = 0\r\n        end\r\n        item\r\n          Action = acRecent8\r\n          Caption = 'acRecent8'\r\n          Tag = 0\r\n        end\r\n        item\r\n          Action = acRecent9\r\n          Caption = 'acRecent9'\r\n          Tag = 0\r\n        end>\r\n    end\r\n    object rbqtbMain: TRibbonQuickAccessToolbar\r\n      Left = 49\r\n      Top = 1\r\n      Width = 48\r\n      Height = 24\r\n      ActionManager = amMain\r\n    end\r\n    object rbpMain: TRibbonPage\r\n      Left = 0\r\n      Top = 50\r\n      Width = 1394\r\n      Height = 93\r\n      Caption = 'Menu'\r\n      Index = 0\r\n      object rbgProject: TRibbonGroup\r\n        Left = 4\r\n        Top = 3\r\n        Width = 197\r\n        Height = 86\r\n        ActionManager = amMain\r\n        Caption = 'Project'\r\n        GroupIndex = 0\r\n      end\r\n      object rbgApplication: TRibbonGroup\r\n        Left = 203\r\n        Top = 3\r\n        Width = 122\r\n        Height = 86\r\n        ActionManager = amMain\r\n        Caption = 'Application'\r\n        GroupIndex = 1\r\n        Rows = 2\r\n      end\r\n      object rbngrpDebug: TRibbonGroup\r\n        Left = 327\r\n        Top = 3\r\n        Width = 121\r\n        Height = 86\r\n        ActionManager = amMain\r\n        Caption = 'Debug'\r\n        GroupIndex = 2\r\n      end\r\n      object rbngrpFeedback: TRibbonGroup\r\n        AlignWithMargins = True\r\n        Left = 616\r\n        Top = 3\r\n        Width = 61\r\n        Height = 86\r\n        ActionManager = amMain\r\n        Caption = 'Feedback'\r\n        GroupIndex = 9\r\n        Rows = 1\r\n      end\r\n      object rbngrpProfilers: TRibbonGroup\r\n        Left = 450\r\n        Top = 3\r\n        Width = 164\r\n        Height = 86\r\n        ActionManager = amMain\r\n        Caption = 'Active profilers'\r\n        GroupIndex = 4\r\n      end\r\n    end\r\n    object rbnpgOptions: TRibbonPage\r\n      Left = 0\r\n      Top = 50\r\n      Width = 1394\r\n      Height = 93\r\n      Caption = 'Options'\r\n      Index = 1\r\n      object rbngrpTimeLineSettings: TRibbonGroup\r\n        Tag = 2\r\n        AlignWithMargins = True\r\n        Left = 124\r\n        Top = 3\r\n        Width = 114\r\n        Height = 86\r\n        ActionManager = amMain\r\n        Caption = 'Timeline options'\r\n        GroupIndex = 1\r\n      end\r\n      object rbngrpDbgInfoOptions: TRibbonGroup\r\n        Left = 4\r\n        Top = 3\r\n        Width = 118\r\n        Height = 86\r\n        ActionManager = amMain\r\n        Caption = 'View options'\r\n        GroupIndex = 0\r\n      end\r\n      object rbngrpMemInfoOptions: TRibbonGroup\r\n        Tag = 3\r\n        AlignWithMargins = True\r\n        Left = 240\r\n        Top = 3\r\n        Width = 123\r\n        Height = 86\r\n        ActionManager = amMain\r\n        Caption = 'Memory info options'\r\n        GroupIndex = 2\r\n      end\r\n      object rbngrpExceptionOptions: TRibbonGroup\r\n        Tag = 4\r\n        AlignWithMargins = True\r\n        Left = 481\r\n        Top = 3\r\n        Width = 131\r\n        Height = 86\r\n        ActionManager = amMain\r\n        Caption = 'Exception options'\r\n        GroupIndex = 4\r\n      end\r\n      object rbngrpCodeTracking: TRibbonGroup\r\n        Tag = 5\r\n        AlignWithMargins = True\r\n        Left = 614\r\n        Top = 3\r\n        Width = 250\r\n        Height = 86\r\n        ActionManager = amMain\r\n        Caption = 'Code tracking options'\r\n        GroupIndex = 5\r\n      end\r\n      object rbngrpLockTracking: TRibbonGroup\r\n        Tag = 6\r\n        AlignWithMargins = True\r\n        Left = 365\r\n        Top = 3\r\n        Width = 114\r\n        Height = 86\r\n        ActionManager = amMain\r\n        Caption = 'Lock tracking options'\r\n        GroupIndex = 3\r\n      end\r\n    end\r\n  end\r\n  object cbMainTabs: TCoolBar\r\n    Left = 0\r\n    Top = 143\r\n    Width = 1395\r\n    Height = 24\r\n    AutoSize = True\r\n    Bands = <\r\n      item\r\n        Control = actbMainTabs\r\n        ImageIndex = -1\r\n        MinHeight = 24\r\n        Width = 1395\r\n      end>\r\n    EdgeBorders = []\r\n    FixedSize = True\r\n    FixedOrder = True\r\n    object actbMainTabs: TActionToolBar\r\n      Left = 0\r\n      Top = 0\r\n      Width = 1395\r\n      Height = 24\r\n      ActionManager = amMain\r\n      AllowHiding = False\r\n      Caption = 'actbMainTabs'\r\n      ColorMap.MenuColor = clMenu\r\n      ColorMap.BtnSelectedColor = clBtnFace\r\n      ColorMap.UnusedColor = 14410210\r\n      Font.Charset = DEFAULT_CHARSET\r\n      Font.Color = clBlack\r\n      Font.Height = -11\r\n      Font.Name = 'Tahoma'\r\n      Font.Style = []\r\n      ParentFont = False\r\n      Spacing = 0\r\n    end\r\n  end\r\n  object cbStatusInfo: TCoolBar\r\n    Left = 0\r\n    Top = 860\r\n    Width = 1395\r\n    Height = 25\r\n    Align = alBottom\r\n    AutoSize = True\r\n    Bands = <\r\n      item\r\n        Break = False\r\n        Control = pStatusBar\r\n        HorizontalOnly = True\r\n        ImageIndex = -1\r\n        Width = 1395\r\n      end>\r\n    EdgeBorders = []\r\n    EdgeInner = esNone\r\n    EdgeOuter = esNone\r\n    FixedSize = True\r\n    FixedOrder = True\r\n    object pStatusBar: TPanel\r\n      Left = 0\r\n      Top = 0\r\n      Width = 1395\r\n      Height = 25\r\n      BevelEdges = []\r\n      BevelOuter = bvNone\r\n      Caption = 'pStatusBar'\r\n      DoubleBuffered = True\r\n      ParentDoubleBuffered = False\r\n      ShowCaption = False\r\n      TabOrder = 0\r\n      object lbStatusAction: TLabel\r\n        Left = 208\r\n        Top = 6\r\n        Width = 69\r\n        Height = 13\r\n        Caption = 'lbStatusAction'\r\n      end\r\n      object pbProgress: TProgressBar\r\n        Left = 2\r\n        Top = 3\r\n        Width = 200\r\n        Height = 17\r\n        Position = 20\r\n        Smooth = True\r\n        TabOrder = 0\r\n      end\r\n      object pStatusDbgInfo: TPanel\r\n        Left = 1259\r\n        Top = 0\r\n        Width = 136\r\n        Height = 25\r\n        Align = alRight\r\n        Caption = 'pStatusDbgInfo'\r\n        ShowCaption = False\r\n        TabOrder = 1\r\n        object lbStatusDbgInfoValue: TLabel\r\n          AlignWithMargins = True\r\n          Left = 56\r\n          Top = 3\r\n          Width = 70\r\n          Height = 19\r\n          Margins.Left = 1\r\n          Margins.Top = 2\r\n          Margins.Right = 5\r\n          Margins.Bottom = 2\r\n          Align = alLeft\r\n          AutoSize = False\r\n          Caption = 'External (TDS)'\r\n          Layout = tlCenter\r\n        end\r\n        object lbStatusDbgInfoLabel: TLabel\r\n          AlignWithMargins = True\r\n          Left = 6\r\n          Top = 3\r\n          Width = 44\r\n          Height = 19\r\n          Margins.Left = 5\r\n          Margins.Top = 2\r\n          Margins.Right = 5\r\n          Margins.Bottom = 2\r\n          Align = alLeft\r\n          Caption = 'Dbg info:'\r\n          Layout = tlCenter\r\n        end\r\n      end\r\n      object pStatusDbgState: TPanel\r\n        Left = 1139\r\n        Top = 0\r\n        Width = 120\r\n        Height = 25\r\n        Align = alRight\r\n        Caption = 'pStatusDbgState'\r\n        ShowCaption = False\r\n        TabOrder = 2\r\n        object lbStatusDbgStateLabel: TLabel\r\n          AlignWithMargins = True\r\n          Left = 6\r\n          Top = 3\r\n          Width = 51\r\n          Height = 19\r\n          Margins.Left = 5\r\n          Margins.Top = 2\r\n          Margins.Right = 5\r\n          Margins.Bottom = 2\r\n          Align = alLeft\r\n          Caption = 'Dbg state:'\r\n          Layout = tlCenter\r\n        end\r\n        object lbStatusDbgStateValue: TLabel\r\n          AlignWithMargins = True\r\n          Left = 63\r\n          Top = 3\r\n          Width = 50\r\n          Height = 19\r\n          Margins.Left = 1\r\n          Margins.Top = 2\r\n          Margins.Right = 5\r\n          Margins.Bottom = 2\r\n          Align = alLeft\r\n          AutoSize = False\r\n          Caption = 'Debug Fail'\r\n          Layout = tlCenter\r\n        end\r\n      end\r\n      object pStatusEventCnt: TPanel\r\n        Left = 1019\r\n        Top = 0\r\n        Width = 120\r\n        Height = 25\r\n        Align = alRight\r\n        Caption = 'pStatusEventCnt'\r\n        ShowCaption = False\r\n        TabOrder = 3\r\n        object lbStateEventCntLabel: TLabel\r\n          AlignWithMargins = True\r\n          Left = 6\r\n          Top = 3\r\n          Width = 59\r\n          Height = 19\r\n          Margins.Left = 5\r\n          Margins.Top = 2\r\n          Margins.Right = 5\r\n          Margins.Bottom = 2\r\n          Align = alLeft\r\n          Caption = 'Dbg events:'\r\n          Layout = tlCenter\r\n        end\r\n        object lbStatusEventsCntValue: TLabel\r\n          AlignWithMargins = True\r\n          Left = 71\r\n          Top = 3\r\n          Width = 42\r\n          Height = 19\r\n          Margins.Left = 1\r\n          Margins.Top = 2\r\n          Margins.Right = 5\r\n          Margins.Bottom = 2\r\n          Align = alLeft\r\n          Alignment = taRightJustify\r\n          AutoSize = False\r\n          Caption = '0000000'\r\n          Layout = tlCenter\r\n        end\r\n      end\r\n      object pStatusTrackEventCnt: TPanel\r\n        Left = 888\r\n        Top = 0\r\n        Width = 131\r\n        Height = 25\r\n        Align = alRight\r\n        Caption = 'pStatusEventCnt'\r\n        ShowCaption = False\r\n        TabOrder = 4\r\n        object lbStatusTrackEventCntLabel: TLabel\r\n          AlignWithMargins = True\r\n          Left = 6\r\n          Top = 3\r\n          Width = 66\r\n          Height = 19\r\n          Margins.Left = 5\r\n          Margins.Top = 2\r\n          Margins.Right = 5\r\n          Margins.Bottom = 2\r\n          Align = alLeft\r\n          Caption = 'Track events:'\r\n          Layout = tlCenter\r\n        end\r\n        object lbStatusTrackEventCntValue: TLabel\r\n          AlignWithMargins = True\r\n          Left = 78\r\n          Top = 3\r\n          Width = 48\r\n          Height = 19\r\n          Margins.Left = 1\r\n          Margins.Top = 2\r\n          Margins.Right = 5\r\n          Margins.Bottom = 2\r\n          Align = alLeft\r\n          Alignment = taRightJustify\r\n          AutoSize = False\r\n          Caption = '00000000'\r\n          Layout = tlCenter\r\n        end\r\n      end\r\n    end\r\n  end\r\n  object AL: TActionList\r\n    Images = dmShareData.imlMainSmall\r\n    Left = 32\r\n    Top = 288\r\n    object acAppOpen: TAction\r\n      Category = 'Project'\r\n      Caption = 'Open application'\r\n      ImageIndex = 2\r\n      OnExecute = acAppOpenExecute\r\n    end\r\n    object acAttachProcess: TAction\r\n      Category = 'Project'\r\n      Caption = 'Attach to process'\r\n      ImageIndex = 3\r\n      OnExecute = acAttachProcessExecute\r\n    end\r\n    object acDebugInfo: TAction\r\n      Category = 'Debug'\r\n      Caption = 'Debug Info'\r\n      ImageIndex = 5\r\n    end\r\n    object acRunStop: TAction\r\n      Category = 'Debug'\r\n      Caption = 'Run'\r\n      Enabled = False\r\n      ImageIndex = 4\r\n    end\r\n    object acRun: TAction\r\n      Category = 'Debug'\r\n      Caption = 'Run'\r\n      Enabled = False\r\n      ImageIndex = 4\r\n      OnExecute = acRunExecute\r\n    end\r\n    object acStop: TAction\r\n      Category = 'Debug'\r\n      Caption = 'Stop'\r\n      Enabled = False\r\n      ImageIndex = 11\r\n      OnExecute = acStopExecute\r\n    end\r\n    object acNewProject: TAction\r\n      Category = 'Project'\r\n      Caption = 'New'\r\n      ImageIndex = 0\r\n      OnExecute = acNewProjectExecute\r\n    end\r\n    object acOpenProject: TAction\r\n      Category = 'Project'\r\n      Caption = 'Open'\r\n      ImageIndex = 1\r\n      OnExecute = acOpenProjectExecute\r\n    end\r\n    object acCloseProject: TAction\r\n      Category = 'Project'\r\n      Caption = 'Close'\r\n      ImageIndex = 8\r\n      OnExecute = acCloseProjectExecute\r\n    end\r\n    object acPause: TAction\r\n      Category = 'Debug'\r\n      Caption = 'Pause'\r\n      ImageIndex = 6\r\n      OnExecute = acPauseExecute\r\n    end\r\n    object acOptions: TAction\r\n      Category = 'Spider'\r\n      Caption = 'Options'\r\n      OnExecute = acOptionsExecute\r\n    end\r\n    object acExit: TAction\r\n      Category = 'Spider'\r\n      Caption = 'Exit'\r\n      ImageIndex = 7\r\n      OnExecute = acExitExecute\r\n    end\r\n    object acAbout: TAction\r\n      Category = 'Spider'\r\n      Caption = 'About'\r\n    end\r\n    object acSave: TAction\r\n      Category = 'Project'\r\n      Caption = 'Save'\r\n      ImageIndex = 9\r\n    end\r\n    object acSaveCopy: TAction\r\n      Category = 'Project'\r\n      Caption = 'Save copy'\r\n      ImageIndex = 10\r\n      OnExecute = acSaveCopyExecute\r\n    end\r\n    object acCPUTimeLine: TAction\r\n      Category = 'Options'\r\n      AutoCheck = True\r\n      Caption = 'CPU timeline'\r\n      Checked = True\r\n      GroupIndex = 1\r\n      OnExecute = acRealTimeLineExecute\r\n    end\r\n    object acRealTimeLine: TAction\r\n      Category = 'Options'\r\n      AutoCheck = True\r\n      Caption = 'Real timeline'\r\n      GroupIndex = 1\r\n      OnExecute = acRealTimeLineExecute\r\n    end\r\n    object acTabLog: TAction\r\n      Category = 'MainTabs'\r\n      Caption = 'Log'\r\n      Checked = True\r\n      OnExecute = acMainTabExecute\r\n    end\r\n    object acTabDebugInfo: TAction\r\n      Tag = 1\r\n      Category = 'MainTabs'\r\n      Caption = 'Debug info'\r\n      OnExecute = acMainTabExecute\r\n    end\r\n    object acTabTimeline: TAction\r\n      Tag = 2\r\n      Category = 'MainTabs'\r\n      Caption = 'Process timeline'\r\n      OnExecute = acMainTabExecute\r\n    end\r\n    object acTabMemoryInfo: TAction\r\n      Tag = 3\r\n      Category = 'MainTabs'\r\n      Caption = 'Memory info'\r\n      OnExecute = acMainTabExecute\r\n    end\r\n    object acTabExceptions: TAction\r\n      Tag = 4\r\n      Category = 'MainTabs'\r\n      Caption = 'Exceptions'\r\n      OnExecute = acMainTabExecute\r\n    end\r\n    object acStatusDebuger: TAction\r\n      Category = 'StatusInfo'\r\n      Caption = 'NONE'\r\n    end\r\n    object acStatusDbgInfo: TAction\r\n      Category = 'StatusInfo'\r\n      Caption = 'NONE'\r\n    end\r\n    object acStausEventCount: TAction\r\n      Category = 'StatusInfo'\r\n      Caption = 'NONE'\r\n    end\r\n    object acEditProject: TAction\r\n      Category = 'Project'\r\n      Caption = 'Settings'\r\n      ImageIndex = 14\r\n    end\r\n    object acUseShortNames: TAction\r\n      Category = 'Options'\r\n      AutoCheck = True\r\n      Caption = 'Use short names'\r\n      Checked = True\r\n      OnExecute = acUseShortNamesExecute\r\n    end\r\n    object acTabCodeTracking: TAction\r\n      Tag = 5\r\n      Category = 'MainTabs'\r\n      Caption = 'Code tracking'\r\n      OnExecute = acMainTabExecute\r\n    end\r\n    object acCodeTracking: TAction\r\n      Category = 'Options'\r\n      AutoCheck = True\r\n      Caption = 'Code tracking'\r\n      Checked = True\r\n      OnExecute = acCodeTrackingExecute\r\n    end\r\n    object acTrackSystemUnits: TAction\r\n      Category = 'Options'\r\n      AutoCheck = True\r\n      Caption = 'Track system units'\r\n      OnExecute = acTrackSystemUnitsExecute\r\n    end\r\n    object acParentViewSource: TAction\r\n      Category = 'PopupMenu'\r\n      Caption = 'View source'\r\n      OnExecute = acParentViewSourceExecute\r\n    end\r\n    object acRecentProjects: TAction\r\n      Category = 'Project'\r\n      Caption = 'Recent projects'\r\n      ImageIndex = 1\r\n    end\r\n    object acSamplingMethod: TAction\r\n      Category = 'Options'\r\n      AutoCheck = True\r\n      Caption = 'Sampling method'\r\n      Checked = True\r\n      GroupIndex = 2\r\n      OnExecute = acSamplingMethodExecute\r\n    end\r\n    object acCALLMethod: TAction\r\n      Category = 'Options'\r\n      AutoCheck = True\r\n      Caption = 'CALL method'\r\n      GroupIndex = 2\r\n      OnExecute = acSamplingMethodExecute\r\n    end\r\n    object acMemoryInfo: TAction\r\n      Category = 'Options'\r\n      AutoCheck = True\r\n      Caption = 'Memory info'\r\n      Checked = True\r\n      OnExecute = acMemoryInfoExecute\r\n    end\r\n    object acMemInfoCallStack: TAction\r\n      Category = 'Options'\r\n      AutoCheck = True\r\n      Caption = 'GetMem call stack'\r\n      Checked = True\r\n      OnExecute = acMemInfoCallStackExecute\r\n    end\r\n    object acMemInfoDblFree: TAction\r\n      Category = 'Options'\r\n      AutoCheck = True\r\n      Caption = 'Double FreeMem control'\r\n      Enabled = False\r\n      OnExecute = acMemInfoDblFreeExecute\r\n    end\r\n    object acProcessTimeline: TAction\r\n      Category = 'Options'\r\n      AutoCheck = True\r\n      Caption = 'Process timeline'\r\n      Checked = True\r\n      OnExecute = acProcessTimelineExecute\r\n    end\r\n    object acExceptions: TAction\r\n      Category = 'Options'\r\n      AutoCheck = True\r\n      Caption = 'Exceptions'\r\n      Checked = True\r\n      OnExecute = acExceptionsExecute\r\n    end\r\n    object acExceptionCallStack: TAction\r\n      Category = 'Options'\r\n      AutoCheck = True\r\n      Caption = 'Exception call stack'\r\n      Checked = True\r\n      OnExecute = acExceptionCallStackExecute\r\n    end\r\n    object acCodeTrackRefresh: TAction\r\n      Category = 'CodeTrack'\r\n      Caption = 'Refresh'\r\n      ImageIndex = 17\r\n      OnExecute = acCodeTrackRefreshExecute\r\n    end\r\n    object acCodeTrackHistoryBack: TAction\r\n      Category = 'CodeTrack'\r\n      Caption = 'History'\r\n      ImageIndex = 15\r\n      OnExecute = acCodeTrackHistoryBackExecute\r\n    end\r\n    object acMemInfoRefresh: TAction\r\n      Category = 'MemInfo'\r\n      Caption = 'Refresh'\r\n      ImageIndex = 17\r\n      OnExecute = acMemInfoRefreshExecute\r\n    end\r\n    object acMemInfoHistory: TAction\r\n      Category = 'MemInfo'\r\n      Caption = 'History'\r\n      Enabled = False\r\n      ImageIndex = 15\r\n      OnExecute = acMemInfoHistoryExecute\r\n    end\r\n    object acAddressInfo: TAction\r\n      Category = 'ExceptInfo'\r\n      Caption = 'Custom stack info'\r\n      ImageIndex = 5\r\n      OnExecute = acAddressInfoExecute\r\n    end\r\n    object acOpenSite: TAction\r\n      Category = 'Spider'\r\n      Caption = 'http://dbg-spider.net'\r\n      ImageIndex = 18\r\n      OnExecute = acOpenSiteExecute\r\n    end\r\n    object acFeedback: TAction\r\n      Category = 'Spider'\r\n      Caption = 'Add comment'\r\n      ImageIndex = 19\r\n      OnExecute = acFeedbackExecute\r\n    end\r\n    object acContinue: TAction\r\n      Category = 'Debug'\r\n      Caption = 'Continue'\r\n      ImageIndex = 4\r\n      OnExecute = acContinueExecute\r\n    end\r\n    object acPauseContinue: TAction\r\n      Category = 'Debug'\r\n      Caption = 'Pause'\r\n      Enabled = False\r\n      ImageIndex = 6\r\n      OnExecute = acPauseExecute\r\n    end\r\n    object acStepInto: TAction\r\n      Category = 'Debug'\r\n      Caption = 'Step into'\r\n      Enabled = False\r\n      ImageIndex = 21\r\n      Visible = False\r\n      OnExecute = acStepIntoExecute\r\n    end\r\n    object acStepOver: TAction\r\n      Category = 'Debug'\r\n      Caption = 'Step over'\r\n      Enabled = False\r\n      ImageIndex = 22\r\n      Visible = False\r\n      OnExecute = acStepOverExecute\r\n    end\r\n    object acStepOut: TAction\r\n      Category = 'Debug'\r\n      Caption = 'Step out'\r\n      Enabled = False\r\n      ImageIndex = 20\r\n      Visible = False\r\n      OnExecute = acStepOutExecute\r\n    end\r\n    object acExcepInfoRefresh: TAction\r\n      Category = 'ExceptInfo'\r\n      Caption = 'Refresh'\r\n      ImageIndex = 17\r\n      OnExecute = acExcepInfoRefreshExecute\r\n    end\r\n    object acTabLockTracking: TAction\r\n      Tag = 6\r\n      Category = 'MainTabs'\r\n      Caption = 'Lock tracking'\r\n      OnExecute = acMainTabExecute\r\n    end\r\n    object acTabUpdateInfo: TAction\r\n      Tag = 7\r\n      Category = 'MainTabs'\r\n      Caption = 'Update Info'\r\n      Visible = False\r\n      OnExecute = acMainTabExecute\r\n    end\r\n    object acCopy: TAction\r\n      Caption = 'acCopy'\r\n      SecondaryShortCuts.Strings = (\r\n        'Ctrl+Ins')\r\n      ShortCut = 16451\r\n      OnExecute = acCopyExecute\r\n    end\r\n    object acLockTrackingRefresh: TAction\r\n      Category = 'LockTrack'\r\n      Caption = 'Refresh'\r\n      ImageIndex = 17\r\n      OnExecute = acLockTrackingRefreshExecute\r\n    end\r\n    object acLockTracking: TAction\r\n      Category = 'Options'\r\n      AutoCheck = True\r\n      Caption = 'Lock tracking'\r\n      Checked = True\r\n      OnExecute = acLockTrackingExecute\r\n    end\r\n    object acViewSyncObjsOnTimeLine: TAction\r\n      Category = 'Options'\r\n      AutoCheck = True\r\n      Caption = 'View on timeline'\r\n      Checked = True\r\n      OnExecute = acViewSyncObjsOnTimeLineExecute\r\n    end\r\n    object acDebugOptions: TAction\r\n      Category = 'Options'\r\n      Caption = 'Options'\r\n      ImageIndex = 23\r\n      OnExecute = acDebugOptionsExecute\r\n    end\r\n    object acCollapseAll: TAction\r\n      Category = 'PopupMenu'\r\n      Caption = 'Collapse All'\r\n      OnExecute = acCollapseAllExecute\r\n    end\r\n  end\r\n  object OD: TFileOpenDialog\r\n    FavoriteLinks = <>\r\n    FileTypes = <\r\n      item\r\n        DisplayName = 'All supported'\r\n        FileMask = '*.spider;*.exe;*.tds;*.map'\r\n      end\r\n      item\r\n        DisplayName = 'Spider project (*.spider)'\r\n        FileMask = '*.spider'\r\n      end\r\n      item\r\n        DisplayName = 'Application (*.exe)'\r\n        FileMask = '*.exe'\r\n      end\r\n      item\r\n        DisplayName = 'External debug info (*.tds)'\r\n        FileMask = '*.tds'\r\n      end\r\n      item\r\n        DisplayName = 'External debug info (*.map)'\r\n        FileMask = '*.map'\r\n      end>\r\n    Options = [fdoFileMustExist]\r\n    Left = 112\r\n    Top = 288\r\n  end\r\n  object tmrThreadsUpdate: TTimer\r\n    Enabled = False\r\n    Interval = 500\r\n    OnTimer = tmrThreadsUpdateTimer\r\n    Left = 112\r\n    Top = 232\r\n  end\r\n  object amMain: TActionManager\r\n    ActionBars = <\r\n      item\r\n        Items = <\r\n          item\r\n            ChangesAllowed = [caModify]\r\n            BackgroundLayout = blRightBanner\r\n            Items = <\r\n              item\r\n                Action = acOpenSite\r\n                Caption = '&http://dbg-spider.net'\r\n                ImageIndex = 18\r\n              end\r\n              item\r\n                Caption = '-'\r\n                CommandStyle = csSeparator\r\n                CommandProperties.Width = -1\r\n                CommandProperties.Font.Charset = DEFAULT_CHARSET\r\n                CommandProperties.Font.Color = clWindowText\r\n                CommandProperties.Font.Height = -11\r\n                CommandProperties.Font.Name = 'Tahoma'\r\n                CommandProperties.Font.Style = []\r\n                CommandProperties.ParentFont = False\r\n              end\r\n              item\r\n                Action = acNewProject\r\n                Caption = '&New'\r\n                ImageIndex = 0\r\n              end\r\n              item\r\n                Action = acOpenProject\r\n                Caption = '&Open'\r\n                ImageIndex = 1\r\n              end\r\n              item\r\n                Action = acEditProject\r\n                Caption = '&Settings'\r\n                ImageIndex = 14\r\n              end\r\n              item\r\n                Action = acSaveCopy\r\n                Caption = 'Sa&ve copy'\r\n                ImageIndex = 10\r\n              end\r\n              item\r\n                Action = acCloseProject\r\n                Caption = '&Close'\r\n                ImageIndex = 8\r\n              end\r\n              item\r\n                Caption = '-'\r\n                CommandStyle = csSeparator\r\n                CommandProperties.Width = -1\r\n                CommandProperties.Font.Charset = DEFAULT_CHARSET\r\n                CommandProperties.Font.Color = clWindowText\r\n                CommandProperties.Font.Height = -11\r\n                CommandProperties.Font.Name = 'Tahoma'\r\n                CommandProperties.Font.Style = []\r\n                CommandProperties.ParentFont = False\r\n              end\r\n              item\r\n                Action = acAppOpen\r\n                Caption = 'O&pen application'\r\n                ImageIndex = 2\r\n              end\r\n              item\r\n                Action = acAttachProcess\r\n                Caption = '&Attach to process'\r\n                ImageIndex = 3\r\n              end\r\n              item\r\n                Caption = '-'\r\n              end\r\n              item\r\n                Action = acExit\r\n                Caption = '&Exit'\r\n                ImageIndex = 7\r\n              end>\r\n            Caption = '&MainMenu'\r\n            ImageIndex = 0\r\n            KeyTip = 'F'\r\n            CommandProperties.ButtonSize = bsLarge\r\n          end>\r\n        ActionBar = rbambMain\r\n        AutoSize = False\r\n      end\r\n      item\r\n        ActionBar = rbqtbMain\r\n        AutoSize = False\r\n      end\r\n      item\r\n        Items = <\r\n          item\r\n            Action = acNewProject\r\n            Caption = '&New'\r\n            ImageIndex = 0\r\n            CommandProperties.ButtonSize = bsLarge\r\n          end\r\n          item\r\n            Caption = '-'\r\n          end\r\n          item\r\n            Items = <\r\n              item\r\n                Action = acRecent0\r\n                Caption = '&acRecent0'\r\n              end\r\n              item\r\n                Action = acRecent1\r\n                Caption = 'a&cRecent1'\r\n              end\r\n              item\r\n                Action = acRecent2\r\n                Caption = 'ac&Recent2'\r\n              end\r\n              item\r\n                Action = acRecent3\r\n                Caption = 'acR&ecent3'\r\n              end\r\n              item\r\n                Action = acRecent4\r\n                Caption = 'acRece&nt4'\r\n              end\r\n              item\r\n                Action = acRecent5\r\n                Caption = 'acRecen&t5'\r\n              end\r\n              item\r\n                Action = acRecent6\r\n                Caption = 'acRecent&6'\r\n              end\r\n              item\r\n                Action = acRecent7\r\n                Caption = 'acRecent&7'\r\n              end\r\n              item\r\n                Action = acRecent8\r\n                Caption = 'acRecent&8'\r\n              end\r\n              item\r\n                Action = acRecent9\r\n                Caption = 'acRecent&9'\r\n              end>\r\n            Action = acOpenProject\r\n            Caption = '&Open'\r\n            ImageIndex = 1\r\n            CommandProperties.ButtonSize = bsLarge\r\n            CommandProperties.ButtonType = btSplit\r\n          end\r\n          item\r\n            Caption = '-'\r\n          end\r\n          item\r\n            Action = acCloseProject\r\n            Caption = '&Close'\r\n            ImageIndex = 8\r\n          end\r\n          item\r\n            Action = acEditProject\r\n            Caption = '&Settings'\r\n            ImageIndex = 14\r\n          end\r\n          item\r\n            Action = acSaveCopy\r\n            Caption = 'S&ave copy'\r\n            ImageIndex = 10\r\n          end>\r\n        ActionBar = rbgProject\r\n      end\r\n      item\r\n        Items = <\r\n          item\r\n            Action = acRun\r\n            Caption = '&Run'\r\n            CommandProperties.ButtonSize = bsLarge\r\n          end\r\n          item\r\n            Action = acDebugInfo\r\n            Caption = '&DebugInfo'\r\n          end\r\n          item\r\n            Action = acPause\r\n            Caption = '&Pause'\r\n          end>\r\n      end\r\n      item\r\n        Items = <\r\n          item\r\n            Action = acAppOpen\r\n            Caption = '&Open application'\r\n            ImageIndex = 2\r\n          end\r\n          item\r\n            Action = acAttachProcess\r\n            Caption = '&Attach to process'\r\n            ImageIndex = 3\r\n          end>\r\n        ActionBar = rbgApplication\r\n      end\r\n      item\r\n        Items = <\r\n          item\r\n            Action = acRunStop\r\n            Caption = '&Run'\r\n            ImageIndex = 4\r\n            CommandProperties.ButtonSize = bsLarge\r\n          end\r\n          item\r\n            Caption = '-'\r\n          end\r\n          item\r\n            Action = acPauseContinue\r\n            Caption = '&Pause'\r\n            ImageIndex = 6\r\n          end>\r\n        ActionBar = rbngrpDebug\r\n      end\r\n      item\r\n        Items = <\r\n          item\r\n            Action = acProcessTimeline\r\n            Caption = '&Process timeline'\r\n            CommandStyle = csCheckBox\r\n            CommandProperties.Width = -1\r\n          end\r\n          item\r\n            Action = acCPUTimeLine\r\n            Caption = '&CPU timeline'\r\n            CommandStyle = csRadioButton\r\n            CommandProperties.Width = -1\r\n          end\r\n          item\r\n            Action = acRealTimeLine\r\n            Caption = '&Real timeline'\r\n            CommandStyle = csRadioButton\r\n            CommandProperties.Width = -1\r\n          end>\r\n        ActionBar = rbngrpTimeLineSettings\r\n      end\r\n      item\r\n        Items = <\r\n          item\r\n            Action = acTabLog\r\n            Caption = '&Log'\r\n          end\r\n          item\r\n            Caption = '-'\r\n          end\r\n          item\r\n            Action = acTabDebugInfo\r\n            Caption = '&Debug info'\r\n          end\r\n          item\r\n            Caption = '-'\r\n          end\r\n          item\r\n            Action = acTabTimeline\r\n            Caption = '&Process timeline'\r\n          end\r\n          item\r\n            Caption = '-'\r\n          end\r\n          item\r\n            Action = acTabMemoryInfo\r\n            Caption = '&Memory info'\r\n          end\r\n          item\r\n            Caption = '-'\r\n          end\r\n          item\r\n            Action = acTabExceptions\r\n            Caption = '&Exceptions'\r\n          end\r\n          item\r\n            Caption = '-'\r\n          end\r\n          item\r\n            Action = acTabCodeTracking\r\n            Caption = '&Code tracking'\r\n          end\r\n          item\r\n            Caption = '-'\r\n          end\r\n          item\r\n            Action = acTabLockTracking\r\n            Caption = 'L&ock tracking'\r\n          end\r\n          item\r\n            Caption = '-'\r\n          end\r\n          item\r\n            Visible = False\r\n            Action = acTabUpdateInfo\r\n          end>\r\n        ActionBar = actbMainTabs\r\n      end\r\n      item\r\n        Items.AutoHotKeys = False\r\n        Items = <\r\n          item\r\n            Caption = 'none'\r\n            CommandStyle = csText\r\n            CommandProperties.Width = -1\r\n            CommandProperties.Font.Charset = DEFAULT_CHARSET\r\n            CommandProperties.Font.Color = clWindowText\r\n            CommandProperties.Font.Height = -11\r\n            CommandProperties.Font.Name = 'Tahoma'\r\n            CommandProperties.Font.Style = [fsBold]\r\n            CommandProperties.ParentFont = False\r\n          end\r\n          item\r\n            Caption = 'DbgInfo:'\r\n            CommandStyle = csText\r\n            CommandProperties.Width = -1\r\n            CommandProperties.Font.Charset = DEFAULT_CHARSET\r\n            CommandProperties.Font.Color = clWindowText\r\n            CommandProperties.Font.Height = -11\r\n            CommandProperties.Font.Name = 'Tahoma'\r\n            CommandProperties.Font.Style = []\r\n            CommandProperties.ParentFont = False\r\n          end\r\n          item\r\n            Caption = '-'\r\n          end\r\n          item\r\n            Caption = 'none'\r\n            CommandStyle = csText\r\n            CommandProperties.Width = -1\r\n            CommandProperties.Font.Charset = DEFAULT_CHARSET\r\n            CommandProperties.Font.Color = clWindowText\r\n            CommandProperties.Font.Height = -11\r\n            CommandProperties.Font.Name = 'Tahoma'\r\n            CommandProperties.Font.Style = []\r\n            CommandProperties.ParentFont = False\r\n          end\r\n          item\r\n            Caption = 'DbgStatus:'\r\n            CommandStyle = csText\r\n            CommandProperties.Width = -1\r\n            CommandProperties.Font.Charset = DEFAULT_CHARSET\r\n            CommandProperties.Font.Color = clWindowText\r\n            CommandProperties.Font.Height = -11\r\n            CommandProperties.Font.Name = 'Tahoma'\r\n            CommandProperties.Font.Style = []\r\n            CommandProperties.ParentFont = False\r\n          end\r\n          item\r\n            Caption = '-'\r\n          end\r\n          item\r\n            Caption = '0'\r\n            CommandStyle = csText\r\n            CommandProperties.Width = -1\r\n            CommandProperties.Font.Charset = DEFAULT_CHARSET\r\n            CommandProperties.Font.Color = clWindowText\r\n            CommandProperties.Font.Height = -11\r\n            CommandProperties.Font.Name = 'Tahoma'\r\n            CommandProperties.Font.Style = []\r\n            CommandProperties.ParentFont = False\r\n          end\r\n          item\r\n            Caption = 'Events:'\r\n            CommandStyle = csText\r\n            CommandProperties.Width = -1\r\n            CommandProperties.Font.Charset = DEFAULT_CHARSET\r\n            CommandProperties.Font.Color = clWindowText\r\n            CommandProperties.Font.Height = -11\r\n            CommandProperties.Font.Name = 'Tahoma'\r\n            CommandProperties.Font.Style = []\r\n            CommandProperties.ParentFont = False\r\n          end\r\n          item\r\n            Caption = '-'\r\n          end>\r\n      end\r\n      item\r\n      end\r\n      item\r\n        ChangesAllowed = []\r\n        Items.AutoHotKeys = False\r\n        Items.Customizable = False\r\n        Items.HideUnused = False\r\n        Items.CaptionOptions = coNone\r\n        Items = <\r\n          item\r\n            Items.HideUnused = False\r\n            Items = <>\r\n            Caption = ' '\r\n            ShowGlyph = False\r\n            ShowShortCut = False\r\n          end\r\n          item\r\n            Items.HideUnused = False\r\n            Items = <>\r\n            Caption = ' '\r\n          end>\r\n      end\r\n      item\r\n        Items = <\r\n          item\r\n            Action = acUseShortNames\r\n            Caption = '&Use short names'\r\n            CommandStyle = csCheckBox\r\n            CommandProperties.Width = -1\r\n          end>\r\n        ActionBar = rbngrpDbgInfoOptions\r\n      end\r\n      item\r\n        Items = <\r\n          item\r\n            Action = acCodeTracking\r\n            Caption = '&Code tracking'\r\n            CommandStyle = csCheckBox\r\n            CommandProperties.Width = -1\r\n          end\r\n          item\r\n            Action = acSamplingMethod\r\n            Caption = '&Sampling method'\r\n            CommandStyle = csRadioButton\r\n            CommandProperties.Width = -1\r\n          end\r\n          item\r\n            Action = acCALLMethod\r\n            Caption = 'C&ALL method'\r\n            CommandStyle = csRadioButton\r\n            CommandProperties.Width = -1\r\n          end\r\n          item\r\n            Caption = '-'\r\n          end\r\n          item\r\n            Action = acTrackSystemUnits\r\n            Caption = '&Track system units'\r\n            CommandStyle = csCheckBox\r\n            CommandProperties.Width = -1\r\n          end>\r\n        ActionBar = rbngrpCodeTracking\r\n      end\r\n      item\r\n        Items = <\r\n          item\r\n            Action = acMemoryInfo\r\n            Caption = '&Memory info'\r\n            CommandStyle = csCheckBox\r\n            CommandProperties.Width = -1\r\n          end\r\n          item\r\n            Action = acMemInfoCallStack\r\n            Caption = '&GetMem call stack'\r\n            CommandStyle = csCheckBox\r\n            CommandProperties.Width = -1\r\n          end>\r\n        ActionBar = rbngrpMemInfoOptions\r\n      end\r\n      item\r\n        Items = <\r\n          item\r\n            Action = acExceptions\r\n            Caption = '&Exceptions'\r\n            CommandStyle = csCheckBox\r\n            CommandProperties.Width = -1\r\n          end\r\n          item\r\n            Action = acExceptionCallStack\r\n            Caption = 'E&xception call stack'\r\n            CommandStyle = csCheckBox\r\n            CommandProperties.Width = -1\r\n          end>\r\n        ActionBar = rbngrpExceptionOptions\r\n      end\r\n      item\r\n        Items = <\r\n          item\r\n            Items = <\r\n              item\r\n                Action = acFunc0\r\n                Caption = '&acFunc0'\r\n              end\r\n              item\r\n                Action = acFunc1\r\n                Caption = 'a&cFunc1'\r\n              end\r\n              item\r\n                Action = acFunc2\r\n                Caption = 'ac&Func2'\r\n              end\r\n              item\r\n                Action = acFunc3\r\n                Caption = 'acF&unc3'\r\n              end\r\n              item\r\n                Action = acFunc4\r\n                Caption = 'acFu&nc4'\r\n              end\r\n              item\r\n                Action = acFunc5\r\n                Caption = 'acFunc&5'\r\n              end\r\n              item\r\n                Action = acFunc6\r\n                Caption = 'acFunc&6'\r\n              end\r\n              item\r\n                Action = acFunc7\r\n                Caption = 'acFunc&7'\r\n              end\r\n              item\r\n                Action = acFunc8\r\n                Caption = 'acFunc&8'\r\n              end\r\n              item\r\n                Action = acFunc9\r\n                Caption = 'acFunc&9'\r\n              end>\r\n            Action = acCodeTrackHistoryBack\r\n            Caption = '&History'\r\n            ImageIndex = 15\r\n            CommandProperties.ButtonType = btSplit\r\n          end\r\n          item\r\n            Action = acCodeTrackRefresh\r\n            Caption = '&Refresh'\r\n            ImageIndex = 17\r\n          end>\r\n        ActionBar = actbCodeTrackingInfo\r\n      end\r\n      item\r\n        Items = <\r\n          item\r\n            Action = acMemInfoHistory\r\n            Caption = '&History'\r\n            ImageIndex = 15\r\n            CommandProperties.ButtonType = btSplit\r\n          end\r\n          item\r\n            Action = acMemInfoRefresh\r\n            Caption = '&Refresh'\r\n            ImageIndex = 17\r\n          end>\r\n        ActionBar = actbMemInfo\r\n      end\r\n      item\r\n        Items = <\r\n          item\r\n            Action = acExcepInfoRefresh\r\n            Caption = '&Refresh'\r\n            ImageIndex = 17\r\n          end\r\n          item\r\n            Action = acAddressInfo\r\n            Caption = '&Custom stack info'\r\n            ImageIndex = 5\r\n          end>\r\n        ActionBar = actbExceptionInfo\r\n      end\r\n      item\r\n        Items = <\r\n          item\r\n            Action = acOpenSite\r\n            Caption = '&http://dbg-spider.net'\r\n            ImageIndex = 18\r\n          end>\r\n        ActionBar = actbUpdateInfo\r\n      end\r\n      item\r\n        Items = <\r\n          item\r\n            Action = acFeedback\r\n            Caption = '&Add comment'\r\n            ImageIndex = 19\r\n            CommandProperties.ButtonSize = bsLarge\r\n          end>\r\n        ActionBar = rbngrpFeedback\r\n      end\r\n      item\r\n        Items = <\r\n          item\r\n            Action = acLockTrackingRefresh\r\n            Caption = '&Refresh'\r\n            ImageIndex = 17\r\n          end>\r\n        ActionBar = actbLockTracking\r\n      end\r\n      item\r\n        Items = <\r\n          item\r\n            Action = acLockTracking\r\n            Caption = '&Lock tracking'\r\n            CommandStyle = csCheckBox\r\n            CommandProperties.Width = -1\r\n          end\r\n          item\r\n            Action = acViewSyncObjsOnTimeLine\r\n            Caption = '&View on timeline'\r\n            CommandStyle = csCheckBox\r\n            CommandProperties.Width = -1\r\n          end>\r\n        ActionBar = rbngrpLockTracking\r\n      end\r\n      item\r\n        Items = <\r\n          item\r\n            Action = acDebugOptions\r\n            Caption = '&Options'\r\n            ImageIndex = 23\r\n            CommandProperties.ButtonSize = bsLarge\r\n          end>\r\n      end\r\n      item\r\n        Items = <\r\n          item\r\n            Action = acMemoryInfo\r\n            Caption = '&Memory info'\r\n            CommandStyle = csCheckBox\r\n            CommandProperties.Width = -1\r\n          end\r\n          item\r\n            Action = acLockTracking\r\n            Caption = '&Lock tracking'\r\n            CommandStyle = csCheckBox\r\n            CommandProperties.Width = -1\r\n          end\r\n          item\r\n            Action = acCodeTracking\r\n            Caption = '&Code tracking'\r\n            CommandStyle = csCheckBox\r\n            CommandProperties.Width = -1\r\n          end\r\n          item\r\n            Caption = '-'\r\n          end\r\n          item\r\n            Action = acDebugOptions\r\n            Caption = '&Options'\r\n            ImageIndex = 23\r\n            CommandProperties.ButtonSize = bsLarge\r\n          end>\r\n        ActionBar = rbngrpProfilers\r\n      end>\r\n    DisabledImages = dmShareData.imlMainSmall\r\n    LargeDisabledImages = dmShareData.imlMain\r\n    LargeImages = dmShareData.imlMain\r\n    LinkedActionLists = <\r\n      item\r\n        ActionList = AL\r\n        Caption = 'AL'\r\n      end\r\n      item\r\n        ActionList = alRecent\r\n        Caption = 'ALRecent'\r\n      end\r\n      item\r\n        ActionList = alCodeTrackHistory\r\n        Caption = 'alCodeTrackHistory'\r\n      end>\r\n    Images = dmShareData.imlMainSmall\r\n    Left = 32\r\n    Top = 232\r\n    StyleName = 'Ribbon - Silver'\r\n  end\r\n  object alRecent: TActionList\r\n    Left = 112\r\n    Top = 352\r\n    object acRecent0: TAction\r\n      Caption = 'acRecent0'\r\n      OnExecute = acRecentExecute\r\n    end\r\n    object acRecent1: TAction\r\n      Caption = 'acRecent1'\r\n      OnExecute = acRecentExecute\r\n    end\r\n    object acRecent2: TAction\r\n      Caption = 'acRecent2'\r\n      OnExecute = acRecentExecute\r\n    end\r\n    object acRecent3: TAction\r\n      Caption = 'acRecent3'\r\n      OnExecute = acRecentExecute\r\n    end\r\n    object acRecent4: TAction\r\n      Caption = 'acRecent4'\r\n      OnExecute = acRecentExecute\r\n    end\r\n    object acRecent5: TAction\r\n      Caption = 'acRecent5'\r\n      OnExecute = acRecentExecute\r\n    end\r\n    object acRecent6: TAction\r\n      Caption = 'acRecent6'\r\n      OnExecute = acRecentExecute\r\n    end\r\n    object acRecent7: TAction\r\n      Caption = 'acRecent7'\r\n      OnExecute = acRecentExecute\r\n    end\r\n    object acRecent8: TAction\r\n      Caption = 'acRecent8'\r\n      OnExecute = acRecentExecute\r\n    end\r\n    object acRecent9: TAction\r\n      Caption = 'acRecent9'\r\n      OnExecute = acRecentExecute\r\n    end\r\n  end\r\n  object pmTrackFuncAdvParents: TPopupMenu\r\n    Left = 112\r\n    Top = 408\r\n    object mnViewSource: TMenuItem\r\n      Action = acParentViewSource\r\n    end\r\n  end\r\n  object alCodeTrackHistory: TActionList\r\n    Left = 200\r\n    Top = 352\r\n    object acFunc0: TAction\r\n      Caption = 'acFunc0'\r\n      OnExecute = acFuncExecute\r\n    end\r\n    object acFunc1: TAction\r\n      Caption = 'acFunc1'\r\n      OnExecute = acFuncExecute\r\n    end\r\n    object acFunc2: TAction\r\n      Caption = 'acFunc2'\r\n      OnExecute = acFuncExecute\r\n    end\r\n    object acFunc3: TAction\r\n      Caption = 'acFunc3'\r\n      OnExecute = acFuncExecute\r\n    end\r\n    object acFunc4: TAction\r\n      Caption = 'acFunc4'\r\n      OnExecute = acFuncExecute\r\n    end\r\n    object acFunc5: TAction\r\n      Caption = 'acFunc5'\r\n      OnExecute = acFuncExecute\r\n    end\r\n    object acFunc6: TAction\r\n      Caption = 'acFunc6'\r\n      OnExecute = acFuncExecute\r\n    end\r\n    object acFunc7: TAction\r\n      Caption = 'acFunc7'\r\n      OnExecute = acFuncExecute\r\n    end\r\n    object acFunc8: TAction\r\n      Caption = 'acFunc8'\r\n      OnExecute = acFuncExecute\r\n    end\r\n    object acFunc9: TAction\r\n      Caption = 'acFunc9'\r\n      OnExecute = acFuncExecute\r\n    end\r\n  end\r\n  object pmVirtualTreeView: TPopupMenu\r\n    Left = 112\r\n    Top = 464\r\n    object mnuCollapseAll: TMenuItem\r\n      Action = acCollapseAll\r\n    end\r\n  end\r\nend\r\n"
  },
  {
    "path": "uMain.pas",
    "content": "unit uMain;\r\n\r\ninterface\r\n\r\nuses\r\n  Windows, uShareData, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,\r\n  Dialogs, StdCtrls, Buttons, Mask, ExtCtrls, ComCtrls, ActnList, DebugInfo,\r\n  Grids, VirtualTrees, GdiPlus, GdiPlusHelpers,\r\n  Debuger, DebugerTypes, DelphiDebugInfo,\r\n  PlatformDefaultStyleActnCtrls, ActnMan, Ribbon, RibbonLunaStyleActnCtrls,\r\n  RibbonSilverStyleActnCtrls, ToolWin, ActnCtrls, ActnMenus,\r\n  RibbonActnMenus, ImgList, ActnColorMaps, XPMan,\r\n  uActionController, uSpiderOptions, System.Actions,\r\n  Vcl.Menus, uUpdateInfo, uSourceViewFrame;\r\n\r\ntype\r\n  TProgectType = (ptEmpty, ptSpider, ptApplication, ptDebugInfo);\r\n\r\n  TLinkType = (ltNone = 0, ltProject, ltProcess, ltThread, ltMemInfo, ltMemStack, ltExceptInfo, ltExceptStack,\r\n    ltDbgUnitGroup, ltDbgUnitInfo, ltDbgConstInfo, ltDbgTypeInfo, ltDbgVarInfo, ltDbgFuncInfo, ltDbgStructMemberInfo,\r\n    ltDbgFuncParamInfo, ltDbgLogItem, ltTrackFuncInfo, ltTrackUnitInfo, ltTrackCallFuncInfo,\r\n    ltSpiderInfo, ltVersionInfo, ltChangeLogItemInfo, ltSyncObjInfo, ltSyncObjChildInfo, ltSyncObjStack);\r\n\r\n  PLinkData = ^TLinkData;\r\n  TLinkData = record\r\n    SyncNode: PVirtualNode;\r\n    case LinkType: TLinkType of\r\n      ltNone:\r\n        ();\r\n      ltProject:\r\n        ();\r\n      ltProcess:\r\n        (ProcessData: TProcessData);\r\n      ltThread:\r\n        (ThreadData: PThreadData);\r\n      ltMemInfo:\r\n        (MemPtr: Pointer);\r\n      ltMemStack:\r\n        (MemStackPtr: Pointer);\r\n      ltExceptInfo:\r\n        (ExceptInfo: TExceptInfo);\r\n      ltExceptStack:\r\n        (ExceptStackEntry: TStackEntry);\r\n      ltDbgUnitGroup:\r\n        (DbgUnitGroupType: TUnitType);\r\n      ltDbgUnitInfo:\r\n        (DbgUnitInfo: TUnitInfo);\r\n      ltDbgConstInfo:\r\n        (DbgConstInfo: TConstInfo);\r\n      ltDbgTypeInfo:\r\n        (DbgTypeInfo: TTypeInfo);\r\n      ltDbgVarInfo:\r\n        (DbgVarInfo: TVarInfo);\r\n      ltDbgFuncInfo:\r\n        (DbgFuncInfo: TFuncInfo);\r\n      ltDbgStructMemberInfo:\r\n        (DbgStructMemberInfo: TStructMember);\r\n      ltDbgFuncParamInfo:\r\n        (DbgFuncParamInfo: TVarInfo);\r\n      ltDbgLogItem:\r\n        (DbgLogItemIdx: Integer);\r\n      ltTrackFuncInfo:\r\n        (TrackFuncInfo: TTrackFuncInfo);\r\n      ltTrackUnitInfo:\r\n        (TrackUnitInfo: TTrackUnitInfo);\r\n      ltTrackCallFuncInfo:\r\n        (TrackCallFuncInfo: TCallFuncInfo);\r\n      ltSpiderInfo:\r\n        ();\r\n      ltVersionInfo:\r\n        (VersionInfo: TChangeLogVersionInfo);\r\n      ltChangeLogItemInfo:\r\n        (ChangeLogItem: TChangeLogItem);\r\n      ltSyncObjInfo, ltSyncObjChildInfo:\r\n        (SyncObjItem: PSyncObjsInfo);\r\n      ltSyncObjStack:\r\n        (SyncObjStackPtr: Pointer);\r\n  end;\r\n\r\n  TCheckFunc = function(LinkData: PLinkData; CmpData: Pointer): LongBool;\r\n\r\n  TMainForm = class(TForm)\r\n    acAbout: TAction;\r\n    acAddressInfo: TAction;\r\n    acAppOpen: TAction;\r\n    acAttachProcess: TAction;\r\n    acCALLMethod: TAction;\r\n    acCloseProject: TAction;\r\n    acCodeTrackHistoryBack: TAction;\r\n    acCodeTracking: TAction;\r\n    acCodeTrackRefresh: TAction;\r\n    acContinue: TAction;\r\n    acCopy: TAction;\r\n    acCPUTimeLine: TAction;\r\n    acDebugInfo: TAction;\r\n    acDebugOptions: TAction;\r\n    acEditProject: TAction;\r\n    acExcepInfoRefresh: TAction;\r\n    acExceptionCallStack: TAction;\r\n    acExceptions: TAction;\r\n    acExit: TAction;\r\n    acFeedback: TAction;\r\n    acFunc0: TAction;\r\n    acFunc1: TAction;\r\n    acFunc2: TAction;\r\n    acFunc3: TAction;\r\n    acFunc4: TAction;\r\n    acFunc5: TAction;\r\n    acFunc6: TAction;\r\n    acFunc7: TAction;\r\n    acFunc8: TAction;\r\n    acFunc9: TAction;\r\n    acLockTracking: TAction;\r\n    acLockTrackingRefresh: TAction;\r\n    acMemInfoCallStack: TAction;\r\n    acMemInfoDblFree: TAction;\r\n    acMemInfoHistory: TAction;\r\n    acMemInfoRefresh: TAction;\r\n    acMemoryInfo: TAction;\r\n    acNewProject: TAction;\r\n    acOpenProject: TAction;\r\n    acOpenSite: TAction;\r\n    acOptions: TAction;\r\n    acParentViewSource: TAction;\r\n    acPause: TAction;\r\n    acPauseContinue: TAction;\r\n    acProcessTimeline: TAction;\r\n    acRealTimeLine: TAction;\r\n    acRecent0: TAction;\r\n    acRecent1: TAction;\r\n    acRecent2: TAction;\r\n    acRecent3: TAction;\r\n    acRecent4: TAction;\r\n    acRecent5: TAction;\r\n    acRecent6: TAction;\r\n    acRecent7: TAction;\r\n    acRecent8: TAction;\r\n    acRecent9: TAction;\r\n    acRecentProjects: TAction;\r\n    acRun: TAction;\r\n    acRunStop: TAction;\r\n    acSamplingMethod: TAction;\r\n    acSave: TAction;\r\n    acSaveCopy: TAction;\r\n    acStatusDbgInfo: TAction;\r\n    acStatusDebuger: TAction;\r\n    acStausEventCount: TAction;\r\n    acStepInto: TAction;\r\n    acStepOut: TAction;\r\n    acStepOver: TAction;\r\n    acStop: TAction;\r\n    acTabCodeTracking: TAction;\r\n    acTabDebugInfo: TAction;\r\n    acTabExceptions: TAction;\r\n    acTabLockTracking: TAction;\r\n    acTabLog: TAction;\r\n    acTabMemoryInfo: TAction;\r\n    acTabTimeline: TAction;\r\n    acTabUpdateInfo: TAction;\r\n    actbCodeTrackingInfo: TActionToolBar;\r\n    actbExceptionInfo: TActionToolBar;\r\n    actbLockTracking: TActionToolBar;\r\n    actbMainTabs: TActionToolBar;\r\n    actbMemInfo: TActionToolBar;\r\n    actbUpdateInfo: TActionToolBar;\r\n    acTrackSystemUnits: TAction;\r\n    acUseShortNames: TAction;\r\n    acViewSyncObjsOnTimeLine: TAction;\r\n    AL: TActionList;\r\n    alCodeTrackHistory: TActionList;\r\n    alRecent: TActionList;\r\n    amMain: TActionManager;\r\n    cbCodeTrackingInfo: TCoolBar;\r\n    cbExceptionInfo: TCoolBar;\r\n    cbLockTracking: TCoolBar;\r\n    cbMainTabs: TCoolBar;\r\n    cbMemInfo: TCoolBar;\r\n    cbStatusInfo: TCoolBar;\r\n    cbUpdateInfo: TCoolBar;\r\n    lbStateEventCntLabel: TLabel;\r\n    lbStatusAction: TLabel;\r\n    lbStatusDbgInfoLabel: TLabel;\r\n    lbStatusDbgInfoValue: TLabel;\r\n    lbStatusDbgStateLabel: TLabel;\r\n    lbStatusDbgStateValue: TLabel;\r\n    lbStatusEventsCntValue: TLabel;\r\n    lbStatusTrackEventCntLabel: TLabel;\r\n    lbStatusTrackEventCntValue: TLabel;\r\n    mnViewSource: TMenuItem;\r\n    OD: TFileOpenDialog;\r\n    p2: TPanel;\r\n    pbProgress: TProgressBar;\r\n    pcDbgInfoDetail: TPageControl;\r\n    pcLockTrackingLinks: TPageControl;\r\n    pcMain: TPageControl;\r\n    pcMemInfo: TPageControl;\r\n    pcMemInfoFuncInfo: TPageControl;\r\n    pCodeTrackingInfo: TPanel;\r\n    pcTrackFuncAdv: TPageControl;\r\n    pDbgInfoDetail: TPanel;\r\n    pDbgInfoFuncAdv: TPanel;\r\n    pExceptInfoAdv: TPanel;\r\n    pExceptionInfo: TPanel;\r\n    pLockTrackingAdv: TPanel;\r\n    pLockTrackingInfo: TPanel;\r\n    pLockTrackingLinks: TPanel;\r\n    pMemInfoButtom: TPanel;\r\n    pMemInfoClient: TPanel;\r\n    pMemInfoFuncLinks: TPanel;\r\n    pMemInfoTreeLeft: TPanel;\r\n    pMemoryInfoAdv: TPanel;\r\n    pmTrackFuncAdvParents: TPopupMenu;\r\n    pnl1: TPanel;\r\n    pnl2: TPanel;\r\n    pStatusBar: TPanel;\r\n    pStatusDbgInfo: TPanel;\r\n    pStatusDbgState: TPanel;\r\n    pStatusEventCnt: TPanel;\r\n    pStatusTrackEventCnt: TPanel;\r\n    pTrackAdv: TPanel;\r\n    pTrackFuncAdv: TPanel;\r\n    rbambMain: TRibbonApplicationMenuBar;\r\n    rbgApplication: TRibbonGroup;\r\n    rbgProject: TRibbonGroup;\r\n    rbngrpCodeTracking: TRibbonGroup;\r\n    rbngrpDbgInfoOptions: TRibbonGroup;\r\n    rbngrpDebug: TRibbonGroup;\r\n    rbngrpExceptionOptions: TRibbonGroup;\r\n    rbngrpFeedback: TRibbonGroup;\r\n    rbngrpLockTracking: TRibbonGroup;\r\n    rbngrpMemInfoOptions: TRibbonGroup;\r\n    rbngrpProfilers: TRibbonGroup;\r\n    rbngrpTimeLineSettings: TRibbonGroup;\r\n    rbnMain: TRibbon;\r\n    rbnpgOptions: TRibbonPage;\r\n    rbpMain: TRibbonPage;\r\n    rbqtbMain: TRibbonQuickAccessToolbar;\r\n    spl1: TSplitter;\r\n    spl2: TSplitter;\r\n    spl3: TSplitter;\r\n    spl4: TSplitter;\r\n    splCodeTrack1: TSplitter;\r\n    splCodeTrack2: TSplitter;\r\n    splDbgInfoFuncAdv: TSplitter;\r\n    splDbgInfoFuncs: TSplitter;\r\n    splDebugInfo: TSplitter;\r\n    splExceptInfo: TSplitter;\r\n    splExceptInfo2: TSplitter;\r\n    splExceptInfoAdv: TSplitter;\r\n    splLockTrack1: TSplitter;\r\n    splLockTrack2: TSplitter;\r\n    splLockTrack3: TSplitter;\r\n    splMemInfo: TSplitter;\r\n    splMemInfoAdv: TSplitter;\r\n    splMemInfoSmpView: TSplitter;\r\n    splMemInfoTreeView1: TSplitter;\r\n    splMemInfoTreeView2: TSplitter;\r\n    splTrackFuncAdv: TSplitter;\r\n    svfDbgInfoFuncAdv: TSourceViewFrame;\r\n    svfDbgInfoUnitSource: TSourceViewFrame;\r\n    svfExceptInfoSource: TSourceViewFrame;\r\n    svfLockTrackingSource: TSourceViewFrame;\r\n    svfMemInfoFuncSrc: TSourceViewFrame;\r\n    svfMemInfoSource: TSourceViewFrame;\r\n    svfTrackFuncAdvSource: TSourceViewFrame;\r\n    tmrThreadsUpdate: TTimer;\r\n    ts1: TTabSheet;\r\n    ts2: TTabSheet;\r\n    tsCodeTracking: TTabSheet;\r\n    tsDbgUnitConsts: TTabSheet;\r\n    tsDbgUnitFunctions: TTabSheet;\r\n    tsDbgUnitSource: TTabSheet;\r\n    tsDbgUnitTypes: TTabSheet;\r\n    tsDbgUnitVars: TTabSheet;\r\n    tsDebugInfo: TTabSheet;\r\n    tsExceptions: TTabSheet;\r\n    tsLockTracking: TTabSheet;\r\n    tsLog: TTabSheet;\r\n    tsMemInfo: TTabSheet;\r\n    tsMemInfoFuncLinks: TTabSheet;\r\n    tsMemInfoFuncSrc: TTabSheet;\r\n    tsMemInfoTreeView: TTabSheet;\r\n    tsMemInfoViewStack: TTabSheet;\r\n    tsThreads1: TTabSheet;\r\n    tsTrackFuncAdvLinks: TTabSheet;\r\n    tsTrackFuncAdvSrc: TTabSheet;\r\n    tsUpdateInfo: TTabSheet;\r\n    vdtTimeLine: TVirtualDrawTree;\r\n    vstDbgInfoConsts: TVirtualStringTree;\r\n    vstDbgInfoFunctions: TVirtualStringTree;\r\n    vstDbgInfoFuncVars: TVirtualStringTree;\r\n    vstDbgInfoTypes: TVirtualStringTree;\r\n    vstDbgInfoUnits: TVirtualStringTree;\r\n    vstDbgInfoVars: TVirtualStringTree;\r\n    vstExceptionCallStack: TVirtualStringTree;\r\n    vstExceptionList: TVirtualStringTree;\r\n    vstExceptionThreads: TVirtualStringTree;\r\n    vstLockThreads: TVirtualStringTree;\r\n    vstLockTrackingChilds: TVirtualStringTree;\r\n    vstLockTrackingList: TVirtualStringTree;\r\n    vstLockTrackingParents: TVirtualStringTree;\r\n    vstLockTrackingSyncObjs: TVirtualStringTree;\r\n    vstLockTrackingSyncObjStack: TVirtualStringTree;\r\n    vstLog: TVirtualStringTree;\r\n    vstMemInfoFuncChilds: TVirtualStringTree;\r\n    vstMemInfoFuncParents: TVirtualStringTree;\r\n    vstMemInfoFuncTree: TVirtualStringTree;\r\n    vstMemInfoObjects: TVirtualStringTree;\r\n    vstMemInfoObjStack: TVirtualStringTree;\r\n    vstMemInfoThreads: TVirtualStringTree;\r\n    vstMemList: TVirtualStringTree;\r\n    vstMemStack: TVirtualStringTree;\r\n    vstThreads: TVirtualStringTree;\r\n    vstTrackFuncChilds: TVirtualStringTree;\r\n    vstTrackFuncParent: TVirtualStringTree;\r\n    vstTrackFuncs: TVirtualStringTree;\r\n    vstTrackThreads: TVirtualStringTree;\r\n    vstUpdateInfo: TVirtualStringTree;\r\n    pmVirtualTreeView: TPopupMenu;\r\n    mnuCollapseAll: TMenuItem;\r\n    acCollapseAll: TAction;\r\n\r\n    procedure FormCreate(Sender: TObject);\r\n    procedure FormDestroy(Sender: TObject);\r\n    procedure FormShow(Sender: TObject);\r\n    procedure FormCloseQuery(Sender: TObject; var CanClose: Boolean);\r\n\r\n    procedure vstThreadsGetText(Sender: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex; TextType: TVSTTextType; var CellText: string);\r\n    procedure vstThreadsDrawText(Sender: TBaseVirtualTree; TargetCanvas: TCanvas; Node: PVirtualNode; Column: TColumnIndex;\r\n      const Text: string; const CellRect: TRect; var DefaultDraw: Boolean);\r\n    procedure vstThreadsGetNodeDataSize(Sender: TBaseVirtualTree; var NodeDataSize: Integer);\r\n    procedure vstThreadsCompareNodes(Sender: TBaseVirtualTree; Node1, Node2: PVirtualNode; Column: TColumnIndex; var Result: Integer);\r\n    procedure vstThreadsIncrementalSearch(Sender: TBaseVirtualTree; Node: PVirtualNode; const SearchText: string; var Result: Integer);\r\n    procedure vstThreadsScroll(Sender: TBaseVirtualTree; DeltaX, DeltaY: Integer);\r\n    procedure vstThreadsCollapsed(Sender: TBaseVirtualTree; Node: PVirtualNode);\r\n    procedure vstThreadsExpanded(Sender: TBaseVirtualTree; Node: PVirtualNode);\r\n    procedure vstColumnResize(Sender: TVTHeader; Column: TColumnIndex);\r\n\r\n    procedure vdtTimeLineDrawNode(Sender: TBaseVirtualTree; const PaintInfo: TVTPaintInfo);\r\n    procedure vdtTimeLineAdvancedHeaderDraw(Sender: TVTHeader; var PaintInfo: THeaderPaintInfo; const Elements: THeaderPaintElements);\r\n    procedure vdtTimeLineHeaderDrawQueryElements(Sender: TVTHeader; var PaintInfo: THeaderPaintInfo; var Elements: THeaderPaintElements);\r\n    procedure vdtTimeLineScroll(Sender: TBaseVirtualTree; DeltaX, DeltaY: Integer);\r\n    procedure vdtTimeLineChange(Sender: TBaseVirtualTree; Node: PVirtualNode);\r\n    procedure vdtTimeLinePaintBackground(Sender: TBaseVirtualTree; TargetCanvas: TCanvas; R: TRect; var Handled: Boolean);\r\n\r\n    procedure vstMemInfoThreadsGetText(Sender: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex; TextType: TVSTTextType; var CellText: string);\r\n    procedure vstMemInfoThreadsFocusChanged(Sender: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex);\r\n\r\n    procedure vstMemListGetText(Sender: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex; TextType: TVSTTextType; var CellText: string);\r\n    procedure vstMemListFocusChanged(Sender: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex);\r\n\r\n    procedure vstMemInfoFuncTreeGetText(Sender: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex; TextType: TVSTTextType; var CellText: string);\r\n    procedure vstMemInfoFuncTreeFocusChanged(Sender: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex);\r\n    procedure vstMemInfoFuncTreeCompareNodes(Sender: TBaseVirtualTree; Node1, Node2: PVirtualNode; Column: TColumnIndex; var Result: Integer);\r\n\r\n    procedure vstMemInfoFuncLinksGetText(Sender: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex; TextType: TVSTTextType; var CellText: string);\r\n\r\n    procedure vstMemInfoFuncParentsDblClick(Sender: TObject);\r\n\r\n    procedure vstMemInfoObjectsGetText(Sender: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex; TextType: TVSTTextType; var CellText: string);\r\n    procedure vstMemInfoObjectsFocusChanged(Sender: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex);\r\n    procedure vstMemInfoObjectsCompareNodes(Sender: TBaseVirtualTree; Node1, Node2: PVirtualNode; Column: TColumnIndex; var Result: Integer);\r\n\r\n    procedure vstMemStackGetText(Sender: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex; TextType: TVSTTextType; var CellText: string);\r\n    procedure vstMemStackFocusChanged(Sender: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex);\r\n\r\n    procedure vstExceptionThreadsGetText(Sender: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex; TextType: TVSTTextType; var CellText: string);\r\n    procedure vstExceptionThreadsFocusChanged(Sender: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex);\r\n\r\n    procedure vstExceptionListGetText(Sender: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex; TextType: TVSTTextType; var CellText: string);\r\n    procedure vstExceptionListFocusChanged(Sender: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex);\r\n\r\n    procedure vstExceptionCallStackGetText(Sender: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex; TextType: TVSTTextType; var CellText: string);\r\n    procedure vstExceptionCallStackFocusChanged(Sender: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex);\r\n\r\n    procedure vstDbgInfoUnitsGetText(Sender: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex; TextType: TVSTTextType; var CellText: string);\r\n    procedure vstDbgInfoUnitsDrawText(Sender: TBaseVirtualTree; TargetCanvas: TCanvas; Node: PVirtualNode; Column: TColumnIndex;\r\n      const Text: string; const CellRect: TRect; var DefaultDraw: Boolean);\r\n    procedure vstDbgInfoUnitsFocusChanged(Sender: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex);\r\n    procedure vstDbgInfoUnitsCompareNodes(Sender: TBaseVirtualTree; Node1, Node2: PVirtualNode; Column: TColumnIndex; var Result: Integer);\r\n    procedure vstDbgInfoUnitsIncrementalSearch(Sender: TBaseVirtualTree; Node: PVirtualNode; const SearchText: string; var Result: Integer);\r\n\r\n    procedure vstDbgInfoConstsGetText(Sender: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex; TextType: TVSTTextType; var CellText: string);\r\n    procedure vstDbgInfoConstsCompareNodes(Sender: TBaseVirtualTree; Node1, Node2: PVirtualNode; Column: TColumnIndex; var Result: Integer);\r\n    procedure vstDbgInfoConstsIncrementalSearch(Sender: TBaseVirtualTree; Node: PVirtualNode; const SearchText: string; var Result: Integer);\r\n\r\n    procedure vstDbgInfoTypesGetText(Sender: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex; TextType: TVSTTextType; var CellText: string);\r\n    procedure vstDbgInfoTypesCompareNodes(Sender: TBaseVirtualTree; Node1, Node2: PVirtualNode; Column: TColumnIndex; var Result: Integer);\r\n    procedure vstDbgInfoTypesIncrementalSearch(Sender: TBaseVirtualTree; Node: PVirtualNode; const SearchText: string; var Result: Integer);\r\n\r\n    procedure vstDbgInfoVarsGetText(Sender: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex; TextType: TVSTTextType; var CellText: string);\r\n    procedure vstDbgInfoVarsCompareNodes(Sender: TBaseVirtualTree; Node1, Node2: PVirtualNode; Column: TColumnIndex; var Result: Integer);\r\n    procedure vstDbgInfoVarsIncrementalSearch(Sender: TBaseVirtualTree; Node: PVirtualNode; const SearchText: string; var Result: Integer);\r\n\r\n    procedure vstDbgInfoFunctionsGetText(Sender: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex; TextType: TVSTTextType; var CellText: string);\r\n    procedure vstDbgInfoFunctionsFocusChanged(Sender: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex);\r\n    procedure vstDbgInfoFunctionsCompareNodes(Sender: TBaseVirtualTree; Node1, Node2: PVirtualNode; Column: TColumnIndex; var Result: Integer);\r\n    procedure vstDbgInfoFunctionsIncrementalSearch(Sender: TBaseVirtualTree; Node: PVirtualNode; const SearchText: string; var Result: Integer);\r\n\r\n    procedure vstDbgInfoFuncVarsGetText(Sender: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex; TextType: TVSTTextType; var CellText: string);\r\n\r\n    procedure vstLogGetText(Sender: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex; TextType: TVSTTextType; var CellText: string);\r\n    procedure vstLogDrawText(Sender: TBaseVirtualTree; TargetCanvas: TCanvas; Node: PVirtualNode; Column: TColumnIndex;\r\n      const Text: string; const CellRect: TRect; var DefaultDraw: Boolean);\r\n\r\n    procedure vstLogResize(Sender: TObject);\r\n    procedure vstLogColumnResize(Sender: TVTHeader; Column: TColumnIndex);\r\n\r\n    procedure vstTrackThreadsGetText(Sender: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex; TextType: TVSTTextType; var CellText: string);\r\n    procedure vstTrackThreadsFocusChanged(Sender: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex);\r\n    procedure vstTrackThreadsFocusChanging(Sender: TBaseVirtualTree; OldNode, NewNode: PVirtualNode; OldColumn, NewColumn: TColumnIndex;\r\n      var Allowed: Boolean);\r\n\r\n    procedure vstTrackFuncsGetText(Sender: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex; TextType: TVSTTextType; var CellText: string);\r\n    procedure vstTrackFuncsDrawText(Sender: TBaseVirtualTree; TargetCanvas: TCanvas; Node: PVirtualNode; Column: TColumnIndex;\r\n      const Text: string; const CellRect: TRect; var DefaultDraw: Boolean);\r\n\r\n    procedure vstTrackFuncsFocusChanged(Sender: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex);\r\n    procedure vstTrackFuncsCompareNodes(Sender: TBaseVirtualTree; Node1, Node2: PVirtualNode; Column: TColumnIndex; var Result: Integer);\r\n    procedure vstTrackFuncsIncrementalSearch(Sender: TBaseVirtualTree; Node: PVirtualNode; const SearchText: string; var Result: Integer);\r\n    procedure vstTrackFuncsFocusChanging(Sender: TBaseVirtualTree; OldNode, NewNode: PVirtualNode; OldColumn, NewColumn: TColumnIndex;\r\n      var Allowed: Boolean);\r\n\r\n    procedure vstTrackFuncParentGetText(Sender: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex; TextType: TVSTTextType; var CellText: string);\r\n    procedure vstTrackFuncParentDblClick(Sender: TObject);\r\n\r\n    procedure vstTrackFuncChildsGetText(Sender: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex; TextType: TVSTTextType; var CellText: string);\r\n    procedure vstTrackFuncChildsDblClick(Sender: TObject);\r\n    procedure vstTrackFuncChildsCompareNodes(Sender: TBaseVirtualTree; Node1, Node2: PVirtualNode; Column: TColumnIndex; var Result: Integer);\r\n    procedure vstTrackFuncChildsIncrementalSearch(Sender: TBaseVirtualTree; Node: PVirtualNode; const SearchText: string; var Result: Integer);\r\n\r\n    procedure vstTrackFuncLinksDrawText(Sender: TBaseVirtualTree; TargetCanvas: TCanvas; Node: PVirtualNode; Column: TColumnIndex;\r\n      const Text: string; const CellRect: TRect; var DefaultDraw: Boolean);\r\n\r\n    procedure vstUpdateInfoGetText(Sender: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex; TextType: TVSTTextType; var CellText: string);\r\n    procedure vstUpdateInfoDrawText(Sender: TBaseVirtualTree; TargetCanvas: TCanvas; Node: PVirtualNode; Column: TColumnIndex;\r\n      const Text: string; const CellRect: TRect; var DefaultDraw: Boolean);\r\n\r\n    procedure vstLockThreadsGetText(Sender: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex; TextType: TVSTTextType; var CellText: string);\r\n    procedure vstLockThreadsFocusChanged(Sender: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex);\r\n    procedure vstLockThreadsCompareNodes(Sender: TBaseVirtualTree; Node1, Node2: PVirtualNode; Column: TColumnIndex; var Result: Integer);\r\n    procedure vstLockThreadsIncrementalSearch(Sender: TBaseVirtualTree; Node: PVirtualNode; const SearchText: string; var Result: Integer);\r\n\r\n    procedure vstLockTrackingChildsCompareNodes(Sender: TBaseVirtualTree; Node1, Node2: PVirtualNode; Column: TColumnIndex; var Result: Integer);\r\n    procedure vstLockTrackingChildsDblClick(Sender: TObject);\r\n    procedure vstLockTrackingChildsIncrementalSearch(Sender: TBaseVirtualTree; Node: PVirtualNode; const SearchText: string; var Result: Integer);\r\n\r\n    procedure vstLockTrackingLinksGetText(Sender: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex; TextType: TVSTTextType; var CellText: string);\r\n\r\n    procedure vstLockTrackingListCompareNodes(Sender: TBaseVirtualTree; Node1, Node2: PVirtualNode; Column: TColumnIndex; var Result: Integer);\r\n    procedure vstLockTrackingListFocusChanged(Sender: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex);\r\n    procedure vstLockTrackingListGetText(Sender: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex; TextType: TVSTTextType; var CellText: string);\r\n    procedure vstLockTrackingListIncrementalSearch(Sender: TBaseVirtualTree; Node: PVirtualNode; const SearchText: string; var Result: Integer);\r\n\r\n    procedure vstLockTrackingParentsCompareNodes(Sender: TBaseVirtualTree; Node1, Node2: PVirtualNode; Column: TColumnIndex; var Result: Integer);\r\n    procedure vstLockTrackingParentsDblClick(Sender: TObject);\r\n    procedure vstLockTrackingParentsIncrementalSearch(Sender: TBaseVirtualTree; Node: PVirtualNode; const SearchText: string; var Result: Integer);\r\n\r\n    procedure vstLockTrackingSyncObjsCompareNodes(Sender: TBaseVirtualTree; Node1, Node2: PVirtualNode; Column: TColumnIndex; var Result: Integer);\r\n    procedure vstLockTrackingSyncObjsFocusChanged(Sender: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex);\r\n    procedure vstLockTrackingSyncObjsGetText(Sender: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex; TextType: TVSTTextType; var CellText: string);\r\n    procedure vstLockTrackingSyncObjsIncrementalSearch(Sender: TBaseVirtualTree; Node: PVirtualNode; const SearchText: string; var Result: Integer);\r\n\r\n    procedure vstLockTrackingSyncObjStackCompareNodes(Sender: TBaseVirtualTree; Node1, Node2: PVirtualNode; Column: TColumnIndex; var Result: Integer);\r\n    procedure vstLockTrackingSyncObjStackDblClick(Sender: TObject);\r\n    procedure vstLockTrackingSyncObjStackGetText(Sender: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex; TextType: TVSTTextType; var CellText: string);\r\n    procedure vstLockTrackingSyncObjStackIncrementalSearch(Sender: TBaseVirtualTree; Node: PVirtualNode; const SearchText: string; var Result: Integer);\r\n\r\n    procedure vstTreeResize(Sender: TObject);\r\n\r\n    procedure tmrThreadsUpdateTimer(Sender: TObject);\r\n    procedure cbCPUTimeLineClick(Sender: TObject);\r\n\r\n    procedure acAppOpenExecute(Sender: TObject);\r\n    procedure acAttachProcessExecute(Sender: TObject);\r\n\r\n    procedure acRunExecute(Sender: TObject);\r\n    procedure acStopExecute(Sender: TObject);\r\n    procedure acPauseExecute(Sender: TObject);\r\n    procedure acContinueExecute(Sender: TObject);\r\n    procedure acStepIntoExecute(Sender: TObject);\r\n    procedure acStepOverExecute(Sender: TObject);\r\n    procedure acStepOutExecute(Sender: TObject);\r\n\r\n    procedure acOptionsExecute(Sender: TObject);\r\n    procedure acExitExecute(Sender: TObject);\r\n    procedure acCPUTimeLineExecute(Sender: TObject);\r\n    procedure acRealTimeLineExecute(Sender: TObject);\r\n    procedure acMainTabExecute(Sender: TObject);\r\n    procedure acOpenProjectExecute(Sender: TObject);\r\n    procedure acCloseProjectExecute(Sender: TObject);\r\n    procedure acNewProjectExecute(Sender: TObject);\r\n    procedure acRecentExecute(Sender: TObject);\r\n    procedure acEditProjectExecute(Sender: TObject);\r\n    procedure acSaveCopyExecute(Sender: TObject);\r\n    procedure acUseShortNamesExecute(Sender: TObject);\r\n    procedure acCodeTrackingExecute(Sender: TObject);\r\n    procedure acTrackSystemUnitsExecute(Sender: TObject);\r\n    procedure acParentViewSourceExecute(Sender: TObject);\r\n    procedure acMemoryInfoExecute(Sender: TObject);\r\n    procedure acProcessTimelineExecute(Sender: TObject);\r\n    procedure acMemInfoDblFreeExecute(Sender: TObject);\r\n    procedure acMemInfoCallStackExecute(Sender: TObject);\r\n    procedure acExceptionsExecute(Sender: TObject);\r\n    procedure acExceptionCallStackExecute(Sender: TObject);\r\n    procedure acCodeTrackHistoryBackExecute(Sender: TObject);\r\n    procedure acCodeTrackRefreshExecute(Sender: TObject);\r\n    procedure acFuncExecute(Sender: TObject);\r\n    procedure acMemInfoRefreshExecute(Sender: TObject);\r\n    procedure acMemInfoHistoryExecute(Sender: TObject);\r\n    procedure acAddressInfoExecute(Sender: TObject);\r\n    procedure acOpenSiteExecute(Sender: TObject);\r\n    procedure acFeedbackExecute(Sender: TObject);\r\n    procedure acExcepInfoRefreshExecute(Sender: TObject);\r\n    procedure acCopyExecute(Sender: TObject);\r\n    procedure acLockTrackingRefreshExecute(Sender: TObject);\r\n    procedure acLockTrackingExecute(Sender: TObject);\r\n    procedure acViewSyncObjsOnTimeLineExecute(Sender: TObject);\r\n    procedure acCollapseAllExecute(Sender: TObject);\r\n    procedure acDebugOptionsExecute(Sender: TObject);\r\n    procedure acSamplingMethodExecute(Sender: TObject);\r\n\r\n    procedure pcMainChange(Sender: TObject);\r\n    procedure pcMemInfoChange(Sender: TObject);\r\n\r\n    procedure pTrackFuncAdvResize(Sender: TObject);\r\n    procedure pMemInfoFuncLinksResize(Sender: TObject);\r\n    procedure pLockTrackingLinksResize(Sender: TObject);\r\n\r\n    procedure vstMemInfoFuncChildsDblClick(Sender: TObject);\r\n    procedure vstMemInfoObjStackDblClick(Sender: TObject);\r\n\r\n  private\r\n    FSpiderOptions: TSpiderOptions;\r\n    FProjectType: TProgectType;\r\n    FTrackHistory: TList;\r\n\r\n    FPID: DWORD;\r\n\r\n    FCloseApp: LongBool;\r\n    procedure WMClose(var Message: TWMClose); message WM_CLOSE;\r\n\r\n    procedure SetProjectName(const ProjectName: String);\r\n    procedure UpdateProjectOptions;\r\n\r\n    procedure ProgressAction(const Action: String; const Progress: Integer);\r\n\r\n    function GetLineTimeOffset: Cardinal;\r\n\r\n    procedure HidePCTabs(PC: TPageControl);\r\n\r\n    procedure SendGAEvent(const Category, Action: String; const ELabel: String = '');\r\n    procedure SendGAException(E: Exception);\r\n    procedure SendGAFeedback(const FeedbackType, FeedbackText: String);\r\n    procedure StartGASession;\r\n    procedure FinishGASession;\r\n\r\n    procedure LoadUpdateInfo;\r\n\r\n    procedure ClearProject;\r\n    procedure ClearTrees;\r\n    procedure ClearDbgTrees;\r\n    procedure ClearDbgInfoTrees;\r\n    procedure ClearTrackTrees;\r\n    procedure ClearMemInfoTrees;\r\n    procedure ClearLockInfoTrees;\r\n\r\n    procedure UpdateTrees;\r\n    procedure UpdateStatusInfo;\r\n    procedure UpdateDebugActions;\r\n    procedure UpdateLog;\r\n    procedure InitLog(const RootMsg: String);\r\n\r\n    procedure UpdateMainActions;\r\n\r\n    procedure LoadUnits;\r\n    procedure LoadConsts(UnitInfo: TUnitInfo; UnitNode: PVirtualNode);\r\n    procedure LoadTypes(UnitInfo: TUnitInfo; UnitNode: PVirtualNode);\r\n    procedure LoadVars(UnitInfo: TUnitInfo; UnitNode: PVirtualNode);\r\n    procedure LoadFunctions(UnitInfo: TUnitInfo; UnitNode: PVirtualNode);\r\n    procedure LoadFunctionParams(FuncInfo: TFuncInfo; FuncNode: PVirtualNode);\r\n    function LoadFunctionSource(SrcView: TSourceViewFrame; FuncInfo: TFuncInfo; LineNo: Integer = 0): LongBool; overload;\r\n    procedure LoadUnitSource(UnitInfo: TUnitInfo; UnitNode: PVirtualNode);\r\n\r\n    procedure LoadTrackProcessFunctions(ProcData: TProcessData; ThreadNode: PVirtualNode);\r\n    procedure LoadTrackThreadFunctions(ThData: PThreadData; ThreadNode: PVirtualNode);\r\n    procedure LoadTrackParentFunctions(TrackFuncInfo: TTrackFuncInfo; TrackFuncNode: PVirtualNode);\r\n    procedure LoadTrackChildFunctions(TrackFuncInfo: TTrackFuncInfo; TrackFuncNode: PVirtualNode);\r\n\r\n    procedure LoadLockTrackThreadFunctions(ThData: PThreadData; ThreadNode: PVirtualNode);\r\n\r\n    procedure LoadMemInfoThreadFunctions(ThData: PThreadData; ThreadNode: PVirtualNode);\r\n    procedure LoadMemInfoParentFunctions(Tree: TBaseVirtualTree; TrackFuncInfo: TTrackFuncInfo; TrackFuncNode: PVirtualNode);\r\n    procedure LoadMemInfoChildFunctions(Tree: TBaseVirtualTree; TrackFuncInfo: TTrackFuncInfo; TrackFuncNode: PVirtualNode);\r\n    procedure LoadMemInfoObjects(Tree: TBaseVirtualTree; MemInfo: TGetMemInfoList; SyncNode: PVirtualNode);\r\n    procedure LoadMemInfoObjectStack(Tree: TBaseVirtualTree; MemInfo: TGetMemInfo; SyncNode: PVirtualNode);\r\n\r\n    procedure LoadSyncObjsInfoObjects(Tree: TBaseVirtualTree; SyncObjsInfo: TFuncSyncObjsInfoList; SyncNode: PVirtualNode);\r\n    procedure LoadSyncObjsInfoStack(Tree: TBaseVirtualTree; SyncObjInfo: PSyncObjsInfo; SyncNode: PVirtualNode);\r\n\r\n    procedure AddTrackHistory(TrackFuncInfo: TTrackFuncInfo);\r\n    procedure UpdateTrackHistoryList;\r\n    procedure ClearTrackHistoryList;\r\n\r\n    procedure DrawTimeLineHeaderEx(const GP: IGPGraphics; const R: TRect; const Offset: Integer);\r\n\r\n    procedure DrawThreadTimeLine(const GP: IGPGraphics; const R: TRect; ThData: PThreadData; const CurOffset: Cardinal);\r\n    procedure DrawThreadCPUTimeLine(const GP: IGPGraphics; const R: TRect; ThData: PThreadData; const CurOffset: Cardinal);\r\n\r\n    procedure DrawProcessTimeLine(const GP: IGPGraphics; const R: TRect; ProcData: TProcessData; const CurOffset: Cardinal);\r\n    procedure DrawProcessCPUTimeLine(const GP: IGPGraphics; const R: TRect; ProcData: TProcessData; const CurOffset: Cardinal);\r\n\r\n    procedure DrawBackgroundEx(const GP: IGPGraphics; const R: TRect; const BkColor: TColor);\r\n\r\n    procedure AddProcess(const ProcessID: Cardinal);\r\n    function AddProcessToTree(Tree: TBaseVirtualTree): PVirtualNode;\r\n    procedure AddThread(const ThreadID: Cardinal);\r\n    function AddThreadToTree(Tree: TBaseVirtualTree; ThData: PThreadData): PVirtualNode;\r\n    procedure SyncNodes(Tree: TBaseVirtualTree; Node: PVirtualNode);\r\n\r\n    function ElapsedToTime(const Elapsed: UInt64): String;\r\n    function FuncElapsedToTime(const FullCPUTime, FullElapsed, Elapsed: UInt64): String; overload;\r\n\r\n    function ElapsedTimeToStr(Tree: TBaseVirtualTree; Data: PLinkData; const Elapsed: UInt64): String;\r\n\r\n    function ThreadIDToStr(const ThreadID: TThreadId): String;\r\n    function ProcessIDToStr(const ProcessID: TProcessId): String;\r\n\r\n    function FindThreadNode(vTree: TBaseVirtualTree; ThData: PThreadData): PVirtualNode;\r\n    //function FindThreadNodeById(vTree: TBaseVirtualTree; const ThreadId: TThreadId): PVirtualNode;\r\n    function FindTrackUnitNode(vTree: TBaseVirtualTree; const UnitInfo: TUnitInfo): PVirtualNode;\r\n    function FindTrackFuncNode(vTree: TBaseVirtualTree; const FuncInfo: TFuncInfo): PVirtualNode;\r\n\r\n\r\n    function FindNode(vTree: TBaseVirtualTree; Node: PVirtualNode; CheckFunc: TCheckFunc; CmpData: Pointer): PVirtualNode;\r\n\r\n    procedure LoadGUIOptions;\r\n    procedure LoadRecentProjects;\r\n    function GetDebugOptions: TDbgOptions;\r\n    function GetAppID: String;\r\n    procedure FillUpdateInfo(Sender: TObject);\r\n\r\n  public\r\n    procedure OnException(Sender: TObject; E: Exception);\r\n    procedure DoAction(Action: TacAction; const Args: array of Variant);\r\n    procedure ViewDebugInfo(DebugInfo: TDebugInfo);\r\n  end;\r\n\r\nvar\r\n  MainForm: TMainForm = nil;\r\n\r\nimplementation\r\n\r\n{$R *.dfm}\r\n\r\nuses Math, ClassUtils, uProcessList, uDebugerThread,\r\n  uProjectOptions, WinAPIUtils, System.UITypes, System.Types,\r\n  uGA, System.Win.Registry, Winapi.ActiveX, Winapi.ShellAPI, uFeedback,\r\n  DbgHookTypes, Collections.Dictionaries, Collections.Base;\r\n\r\nconst\r\n  _TrackingID_web = 'UA-44820931-1';\r\n  _TrackingID_app = 'UA-44820931-2';\r\n  _AppName = 'Spider';\r\n\r\ntype\r\n  THookBaseVirtualTree = class(TBaseVirtualTree);\r\n\r\nconst\r\n  CUnitTypeStrings: array [TUnitType] of string =\r\n    ('Project units', 'System units', 'Components', 'External', 'Other');\r\n  CDbgSyncObjsType: array [TDbgSyncObjsType] of String = ('Unknown', 'Sleep',\r\n    'WaitForSingleObject', 'WaitForMultipleObjects', 'EnterCriticalSection',\r\n    'LeaveCriticalSection', 'InCriticalSection', 'SendMessage');\r\n\r\nprocedure TMainForm.acAddressInfoExecute(Sender: TObject);\r\nvar\r\n  AddressListStr: String;\r\n  AddressList: TStringList;\r\n  ExceptInfo: TExceptInfo;\r\n  I: Integer;\r\n  StackEntry: TStackEntry;\r\n  AddressStr: String;\r\n  Address: Integer;\r\nbegin\r\n  AddressListStr := '';\r\n  if InputQuery('Get stack info', 'Stack', AddressListStr) then\r\n  begin\r\n    AddressList := TStringList.Create;\r\n    try\r\n      AddressList.DelimitedText := AddressListStr;\r\n      if AddressList.Count > 0 then\r\n      begin\r\n        ExceptInfo := TExceptInfo.Create();\r\n        ExceptInfo.ExceptionName := '### DBG_STACK_INFO';\r\n        ExceptInfo.Message := AddressListStr;\r\n\r\n        ExceptInfo.Stack.Capacity := AddressList.Count;\r\n        for I := 0 to AddressList.Count - 1 do\r\n        begin\r\n          AddressStr := AddressList[I];\r\n          if AddressStr <> '' then\r\n          begin\r\n            // Mac address style\r\n            if AddressStr.StartsWith('0x', True) then\r\n              AddressStr := Copy(AddressStr, Length('0x') + 1, MaxInt);\r\n\r\n            if AddressStr[1] <> '$' then\r\n              AddressStr := '$' + AddressStr;\r\n\r\n            if TryStrToInt(AddressStr, Address) then\r\n            begin\r\n              StackEntry := TStackEntry.Create;\r\n              StackEntry.UpdateInfo(Pointer(Address));\r\n\r\n              ExceptInfo.Stack.Add(StackEntry);\r\n            end;\r\n          end;\r\n        end;\r\n\r\n        gvDebuger.ProcessData.DbgExceptions.Add(ExceptInfo);\r\n\r\n        vstExceptionThreadsFocusChanged(nil, nil, 0);\r\n      end;\r\n    finally\r\n      FreeAndNil(AddressList);\r\n    end;\r\n  end;\r\nend;\r\n\r\nprocedure TMainForm.acAppOpenExecute(Sender: TObject);\r\nbegin\r\n  if OD.Execute then\r\n    SetProjectName(OD.FileName);\r\nend;\r\n\r\nprocedure TMainForm.acAttachProcessExecute(Sender: TObject);\r\nvar\r\n  F: TfrmProcessList;\r\nbegin\r\n  Application.CreateForm(TfrmProcessList, F);\r\n  try\r\n    if F.ShowModal = mrOk then\r\n    begin\r\n      FPID := TProcessId(F.GetSelProcessID);\r\n      SetProjectName(F.GetSelProcessName);\r\n    end;\r\n  finally\r\n    F.Release;\r\n  end;\r\nend;\r\n\r\nprocedure TMainForm.acCloseProjectExecute(Sender: TObject);\r\nbegin\r\n  ClearProject;\r\nend;\r\n\r\nprocedure TMainForm.acCodeTrackHistoryBackExecute(Sender: TObject);\r\nbegin\r\n  vstTrackFuncs.OnFocusChanging := nil;\r\n  try\r\n    acFunc0.Execute;\r\n  finally\r\n    vstTrackFuncs.OnFocusChanging := vstTrackFuncsFocusChanging;\r\n  end;\r\nend;\r\n\r\nprocedure TMainForm.acCodeTrackingExecute(Sender: TObject);\r\nbegin\r\n  if Assigned(gvDebuger) then\r\n  begin\r\n    gvDebuger.CodeTracking := acCodeTracking.Checked;\r\n\r\n    acSamplingMethod.Enabled := gvDebuger.CodeTracking;\r\n    acCALLMethod.Enabled := gvDebuger.CodeTracking;\r\n    acTrackSystemUnits.Enabled := gvDebuger.CodeTracking;\r\n  end;\r\nend;\r\n\r\nprocedure TMainForm.acCodeTrackRefreshExecute(Sender: TObject);\r\nbegin\r\n  vstTrackThreadsFocusChanged(vstTrackThreads, vstTrackThreads.FocusedNode, 0);\r\nend;\r\n\r\nprocedure TMainForm.acCollapseAllExecute(Sender: TObject);\r\nvar\r\n  VirtualTreeView: TBaseVirtualTree;\r\n  Node: PVirtualNode;\r\nbegin\r\n  if vstTrackFuncs.Focused then\r\n    VirtualTreeView := vstTrackFuncs\r\n  else\r\n  if vstTrackFuncChilds.Focused then\r\n    VirtualTreeView := vstTrackFuncChilds\r\n  else\r\n    Exit;\r\n\r\n  if VirtualTreeView is TBaseVirtualTree then\r\n    for Node in VirtualTreeView.Nodes do\r\n      VirtualTreeView.Expanded[Node] := False;\r\nend;\r\n\r\nprocedure TMainForm.acContinueExecute(Sender: TObject);\r\nbegin\r\n  _AC.TraceDebug(dtsContinue);\r\nend;\r\n\r\nprocedure TMainForm.acCopyExecute(Sender: TObject);\r\nbegin\r\n  if Assigned(ActiveControl) then\r\n    ActiveControl.Perform(WM_COPY, 0, 0);\r\nend;\r\n\r\nprocedure TMainForm.acCPUTimeLineExecute(Sender: TObject);\r\nbegin\r\n  UpdateTrees;\r\nend;\r\n\r\nprocedure TMainForm.acDebugOptionsExecute(Sender: TObject);\r\nbegin\r\n  rbnMain.TabIndex := rbnpgOptions.Index;\r\nend;\r\n\r\nprocedure TMainForm.acEditProjectExecute(Sender: TObject);\r\nbegin\r\n  OpenProjectOptions(otEdit);\r\nend;\r\n\r\nprocedure TMainForm.acExcepInfoRefreshExecute(Sender: TObject);\r\nbegin\r\n  vstExceptionThreadsFocusChanged(vstExceptionThreads, vstExceptionThreads.FocusedNode, 0);\r\nend;\r\n\r\nprocedure TMainForm.acExceptionCallStackExecute(Sender: TObject);\r\nbegin\r\n  //\r\nend;\r\n\r\nprocedure TMainForm.acExceptionsExecute(Sender: TObject);\r\nbegin\r\n  //\r\nend;\r\n\r\nprocedure TMainForm.acExitExecute(Sender: TObject);\r\nbegin\r\n  FCloseApp := True;\r\n  Close;\r\nend;\r\n\r\nprocedure TMainForm.acFeedbackExecute(Sender: TObject);\r\nvar\r\n  F: TfrmFeedback;\r\nbegin\r\n  Application.CreateForm(TfrmFeedback, F);\r\n  try\r\n    if F.ShowModal = mrOk then\r\n    begin\r\n      //SendGAEvent('Feedback', F.FeedbackType, F.FeedbackText);\r\n      SendGAFeedback(F.FeedbackType, F.FeedbackText);\r\n    end;\r\n  finally\r\n    FreeAndNil(F);\r\n  end;\r\nend;\r\n\r\nprocedure TMainForm.acFuncExecute(Sender: TObject);\r\nvar\r\n  Action: TAction;\r\n  TrackFuncInfo: TTrackFuncInfo;\r\n  FuncNode: PVirtualNode;\r\nbegin\r\n  if Sender is TAction then\r\n  begin\r\n    Action := TAction(Sender);\r\n    if Action.Tag <> 0 then\r\n    begin\r\n      TrackFuncInfo := TTrackFuncInfo(Action.Tag);\r\n\r\n      FTrackHistory.Remove(TrackFuncInfo);\r\n      UpdateTrackHistoryList;\r\n\r\n      FuncNode := FindTrackFuncNode(vstTrackFuncs, TFuncInfo(TrackFuncInfo.FuncInfo));\r\n      if Assigned(FuncNode) then\r\n      begin\r\n        vstTrackFuncs.ClearSelection;\r\n        vstTrackFuncs.FocusedNode := FuncNode;\r\n        vstTrackFuncs.Selected[FuncNode] := True;\r\n      end;\r\n    end;\r\n  end;\r\nend;\r\n\r\nprocedure TMainForm.acLockTrackingExecute(Sender: TObject);\r\nbegin\r\n  //\r\nend;\r\n\r\nprocedure TMainForm.acLockTrackingRefreshExecute(Sender: TObject);\r\nbegin\r\n  vstLockThreadsFocusChanged(vstLockThreads, vstLockThreads.FocusedNode, 0);\r\nend;\r\n\r\nprocedure TMainForm.acOpenProjectExecute(Sender: TObject);\r\nbegin\r\n  if OD.Execute then\r\n    SetProjectName(OD.FileName);\r\nend;\r\n\r\nprocedure TMainForm.acOpenSiteExecute(Sender: TObject);\r\nconst\r\n  _SPIDER_URL = 'http://dbg-spider.net';\r\nbegin\r\n  ShellExecute(WindowHandle, 'open', _SPIDER_URL, nil, nil, SW_SHOWNORMAL);\r\nend;\r\n\r\nprocedure TMainForm.acOptionsExecute(Sender: TObject);\r\nbegin\r\n  //\r\nend;\r\n\r\nprocedure TMainForm.acRealTimeLineExecute(Sender: TObject);\r\nbegin\r\n  UpdateTrees;\r\nend;\r\n\r\nprocedure TMainForm.acRecentExecute(Sender: TObject);\r\nvar\r\n  PName: String;\r\nbegin\r\n  if Sender is TAction then\r\n  begin\r\n    PName := TAction(Sender).Caption;\r\n    UniqueString(PName);\r\n    SetProjectName(PName);\r\n  end;\r\nend;\r\n\r\nfunction TMainForm.GetDebugOptions: TDbgOptions;\r\nbegin\r\n  Result := [];\r\n\r\n  if acProcessTimeline.Checked then\r\n    Include(Result, doProfiler);\r\n\r\n  if acMemoryInfo.Checked then\r\n  begin\r\n    Include(Result, doMemProfiler);\r\n\r\n    if acMemInfoCallStack.Checked then\r\n      Include(Result, doMemCallStack);\r\n\r\n    if acMemInfoDblFree.Checked then\r\n      Include(Result, doMemCheckDoubleFree);\r\n  end;\r\n\r\n  if acExceptions.Checked then\r\n  begin\r\n    Include(Result, doExceptions);\r\n\r\n    if acExceptionCallStack.Checked then\r\n      Include(Result, doExceptionCallStack);\r\n  end;\r\n\r\n  if acCodeTracking.Checked then\r\n  begin\r\n    Include(Result, doCodeTracking);\r\n\r\n    if acTrackSystemUnits.Checked then\r\n      Include(Result, doTrackSystemUnits);\r\n\r\n    if acSamplingMethod.Checked then\r\n      Include(Result, doSamplingMethod);\r\n  end;\r\n\r\n  if acLockTracking.Checked then\r\n  begin\r\n    Include(Result, doSyncObjsTracking);\r\n  end;\r\nend;\r\n\r\nprocedure TMainForm.acRunExecute(Sender: TObject);\r\nbegin\r\n  SendGAEvent('Run Spider project', GetAppID, 'Run');\r\n\r\n  acRun.Enabled := False;\r\n\r\n  ClearTrees;\r\n\r\n  tmrThreadsUpdate.Enabled := True;\r\n\r\n  if Assigned(gvDebuger) then\r\n    gvDebuger.ClearDbgInfo;\r\n\r\n  UpdateStatusInfo;\r\n  UpdateMainActions;\r\n\r\n  _AC.RunDebug([doRun, doDebugInfo] + GetDebugOptions, FPID);\r\nend;\r\n\r\nprocedure TMainForm.acSamplingMethodExecute(Sender: TObject);\r\nbegin\r\n  if Assigned(gvDebuger) then\r\n  begin\r\n    gvDebuger.SamplingMethod := acSamplingMethod.Checked;\r\n  end;\r\nend;\r\n\r\nprocedure TMainForm.acSaveCopyExecute(Sender: TObject);\r\nbegin\r\n  OpenProjectOptions(otSaveAs);\r\nend;\r\n\r\nprocedure TMainForm.acStepIntoExecute(Sender: TObject);\r\nbegin\r\n  _AC.TraceDebug(dtsStepIn);\r\nend;\r\n\r\nprocedure TMainForm.acStepOutExecute(Sender: TObject);\r\nbegin\r\n  _AC.TraceDebug(dtsStepOut);\r\nend;\r\n\r\nprocedure TMainForm.acStepOverExecute(Sender: TObject);\r\nbegin\r\n  _AC.TraceDebug(dtsStepOver);\r\nend;\r\n\r\nprocedure TMainForm.acStopExecute(Sender: TObject);\r\nbegin\r\n  acStop.Enabled := False;\r\n\r\n  _AC.StopDebug;\r\nend;\r\n\r\nprocedure TMainForm.acProcessTimelineExecute(Sender: TObject);\r\nbegin\r\n  //\r\nend;\r\n\r\nprocedure TMainForm.acTrackSystemUnitsExecute(Sender: TObject);\r\nbegin\r\n  if Assigned(gvDebuger) then\r\n  begin\r\n    gvDebuger.TrackSystemUnits := acTrackSystemUnits.Checked;\r\n  end;\r\nend;\r\n\r\nprocedure TMainForm.acUseShortNamesExecute(Sender: TObject);\r\nbegin\r\n  if Assigned(gvDebugInfo) then\r\n  begin\r\n    gvDebugInfo.UseShortNames := acUseShortNames.Checked;\r\n    UpdateTrees;\r\n  end;\r\nend;\r\n\r\nprocedure TMainForm.acViewSyncObjsOnTimeLineExecute(Sender: TObject);\r\nbegin\r\n  UpdateTrees;\r\nend;\r\n\r\nprocedure TMainForm.acParentViewSourceExecute(Sender: TObject);\r\nvar\r\n  Node: PVirtualNode;\r\n  Data: PLinkData;\r\nbegin\r\n  Node := vstTrackFuncParent.FocusedNode;\r\n  if Assigned(Node) then\r\n  begin\r\n    Data := vstTrackFuncParent.GetNodeData(Node);\r\n    if Data^.LinkType = ltTrackCallFuncInfo then\r\n      if LoadFunctionSource(svfTrackFuncAdvSource, TFuncInfo(Data^.TrackCallFuncInfo.FuncInfo), Data^.TrackCallFuncInfo.LineNo) then\r\n        pcTrackFuncAdv.ActivePage := tsTrackFuncAdvSrc;\r\n  end;\r\nend;\r\n\r\nprocedure TMainForm.acPauseExecute(Sender: TObject);\r\nbegin\r\n  _AC.PauseDebug;\r\nend;\r\n\r\nprocedure TMainForm.HidePCTabs(PC: TPageControl);\r\nvar\r\n  I: Integer;\r\nbegin\r\n  for I := 0 to PC.PageCount - 1 do\r\n    PC.Pages[I].TabVisible := False;\r\nend;\r\n\r\nprocedure TMainForm.InitLog(const RootMsg: String);\r\nvar\r\n  Node: PVirtualNode;\r\n  Data: PLinkData;\r\nbegin\r\n  vstLog.Clear;\r\n\r\n  Node := vstLog.AddChild(nil);\r\n  Data := vstLog.GetNodeData(Node);\r\n\r\n  Data^.LinkType := ltProject;\r\nend;\r\n\r\nprocedure TMainForm.acMainTabExecute(Sender: TObject);\r\nvar\r\n  CurTag: Integer;\r\nbegin\r\n  CurTag := TAction(Sender).Tag;\r\n\r\n  acTabLog.Checked := (CurTag = acTabLog.Tag);\r\n  acTabDebugInfo.Checked := (CurTag = acTabDebugInfo.Tag);\r\n  acTabTimeline.Checked := (CurTag = acTabTimeline.Tag);\r\n  acTabMemoryInfo.Checked := (CurTag = acTabMemoryInfo.Tag);\r\n  acTabExceptions.Checked := (CurTag = acTabExceptions.Tag);\r\n  acTabCodeTracking.Checked := (CurTag = acTabCodeTracking.Tag);\r\n  acTabLockTracking.Checked := (CurTag = acTabLockTracking.Tag);\r\n  acTabUpdateInfo.Checked := (CurTag = acTabUpdateInfo.Tag);\r\n\r\n  pcMain.ActivePageIndex := CurTag;\r\n\r\n  UpdateTrees;\r\nend;\r\n\r\nprocedure TMainForm.acMemInfoCallStackExecute(Sender: TObject);\r\nbegin\r\n  //\r\nend;\r\n\r\nprocedure TMainForm.acMemInfoDblFreeExecute(Sender: TObject);\r\nbegin\r\n  //\r\nend;\r\n\r\nprocedure TMainForm.acMemInfoHistoryExecute(Sender: TObject);\r\nbegin\r\n  //\r\nend;\r\n\r\nprocedure TMainForm.acMemInfoRefreshExecute(Sender: TObject);\r\nbegin\r\n  vstMemInfoThreadsFocusChanged(vstMemInfoThreads, vstMemInfoThreads.FocusedNode, 0);\r\nend;\r\n\r\nprocedure TMainForm.acMemoryInfoExecute(Sender: TObject);\r\nbegin\r\n  //\r\nend;\r\n\r\nprocedure TMainForm.acNewProjectExecute(Sender: TObject);\r\nbegin\r\n  OpenProjectOptions(otNew);\r\nend;\r\n\r\nprocedure TMainForm.AddProcess(const ProcessID: Cardinal);\r\nvar\r\n  LinkData: PLinkData;\r\n  NameNode: PVirtualNode;\r\n  TimeLineNode: PVirtualNode;\r\nbegin\r\n  // Threads timeline\r\n  vstThreads.BeginUpdate;\r\n  vdtTimeLine.BeginUpdate;\r\n  try\r\n    NameNode := AddProcessToTree(vstThreads);\r\n    TimeLineNode := AddProcessToTree(vdtTimeLine);\r\n\r\n    LinkData := vstThreads.GetNodeData(NameNode);\r\n    LinkData^.SyncNode := TimeLineNode;\r\n\r\n    LinkData := vdtTimeLine.GetNodeData(TimeLineNode);\r\n    LinkData^.SyncNode := NameNode;\r\n  finally\r\n    vstThreads.EndUpdate;\r\n    vdtTimeLine.EndUpdate;\r\n  end;\r\n\r\n  // Memory Info\r\n  AddProcessToTree(vstMemInfoThreads);\r\n\r\n  // Exceptions\r\n  AddProcessToTree(vstExceptionThreads);\r\n\r\n  // Code Tracking\r\n  AddProcessToTree(vstTrackThreads);\r\n\r\n  // Lock Tracking\r\n  AddProcessToTree(vstLockThreads);\r\nend;\r\n\r\nfunction TMainForm.AddProcessToTree(Tree: TBaseVirtualTree): PVirtualNode;\r\nvar\r\n  LinkData: PLinkData;\r\nbegin\r\n  Result := Tree.AddChild(Nil);\r\n  LinkData := Tree.GetNodeData(Result);\r\n  LinkData^.SyncNode := nil;\r\n  LinkData^.ProcessData := gvDebuger.ProcessData;\r\n  LinkData^.LinkType := ltProcess;\r\nend;\r\n\r\nfunction TMainForm.FindNode(vTree: TBaseVirtualTree; Node: PVirtualNode; CheckFunc: TCheckFunc; CmpData: Pointer): PVirtualNode;\r\nvar\r\n  CurNode: PVirtualNode;\r\n  LinkData: PLinkData;\r\nbegin\r\n  Result := Nil;\r\n  CurNode := Node^.FirstChild;\r\n  if CurNode <> Nil then\r\n  repeat\r\n    LinkData := vTree.GetNodeData(CurNode);\r\n    if CheckFunc(LinkData, CmpData) then\r\n    begin\r\n      Result := CurNode;\r\n      Break;\r\n    end;\r\n\r\n    Result := FindNode(vTree, CurNode, CheckFunc, CmpData);\r\n    CurNode := CurNode^.NextSibling;\r\n  until (CurNode = nil) or (Result <> Nil);\r\nend;\r\n\r\nfunction TMainForm.FindThreadNode(vTree: TBaseVirtualTree; ThData: PThreadData): PVirtualNode;\r\n\r\n  function _Cmp(LinkData: PLinkData; CmpData: Pointer): LongBool;\r\n  begin\r\n    Result := (LinkData^.LinkType = ltThread) and (LinkData^.ThreadData = CmpData);\r\n  end;\r\n\r\nbegin\r\n  Result := FindNode(vTree, vTree.RootNode, @_Cmp, ThData);\r\nend;\r\n\r\n(*\r\nfunction TMainForm.FindThreadNodeById(vTree: TBaseVirtualTree; const ThreadId: TThreadId): PVirtualNode;\r\n\r\n  function _Cmp(LinkData: PLinkData; CmpData: Pointer): Boolean;\r\n  begin\r\n    Result := (LinkData^.LinkType = ltThread) and (LinkData^.ThreadData^.ThreadID = TThreadId(CmpData));\r\n  end;\r\n\r\nbegin\r\n  Result := FindNode(vTree, vTree.RootNode, @_Cmp, Pointer(ThreadId));\r\nend;\r\n*)\r\n\r\nfunction TMainForm.FindTrackFuncNode(vTree: TBaseVirtualTree; const FuncInfo: TFuncInfo): PVirtualNode;\r\n\r\n  function _Cmp(LinkData: PLinkData; CmpData: Pointer): LongBool;\r\n  begin\r\n    Result := (LinkData^.LinkType = ltTrackFuncInfo) and (LinkData^.TrackFuncInfo.FuncInfo = CmpData);\r\n  end;\r\n\r\nbegin\r\n  Result := FindNode(vTree, vTree.RootNode, @_Cmp, FuncInfo);\r\nend;\r\n\r\nfunction TMainForm.FindTrackUnitNode(vTree: TBaseVirtualTree; const UnitInfo: TUnitInfo): PVirtualNode;\r\n\r\n  function _Cmp(LinkData: PLinkData; CmpData: Pointer): LongBool;\r\n  begin\r\n    case LinkData^.LinkType of\r\n      ltTrackUnitInfo:\r\n        Result := (LinkData^.TrackUnitInfo = CmpData);\r\n      ltDbgUnitInfo:\r\n        Result := (LinkData^.DbgUnitInfo = CmpData);\r\n    else\r\n      Result := False;\r\n    end;\r\n  end;\r\n\r\nbegin\r\n  Result := FindNode(vTree, vTree.RootNode, @_Cmp, UnitInfo);\r\nend;\r\n\r\nprocedure TMainForm.FinishGASession;\r\nvar\r\n  GA: TGA;\r\nbegin\r\n  GA := TGA.Create;\r\n  try\r\n    GA.TrackingID := _TrackingID_app;\r\n    GA.AppName := _AppName;\r\n    GA.ClientID := GetAppID;\r\n    GA.AppVersion := GetFileVersion(Application.ExeName);\r\n\r\n    GA.SessionEnd;\r\n  finally\r\n    FreeAndNil(GA);\r\n  end;\r\nend;\r\n\r\nprocedure TMainForm.AddThread(const ThreadID: Cardinal);\r\nvar\r\n  ThData: PThreadData;\r\n  NameNode: PVirtualNode;\r\n  TimeLineNode: PVirtualNode;\r\n  LinkData: PLinkData;\r\nbegin\r\n  if gvDebuger = nil then Exit;\r\n\r\n  ThData := gvDebuger.GetThreadData(ThreadID);\r\n  if ThData = nil then Exit;\r\n\r\n  // Timeline\r\n  vstThreads.BeginUpdate;\r\n  vdtTimeLine.BeginUpdate;\r\n  try\r\n    NameNode := AddThreadToTree(vstThreads, ThData);\r\n    TimeLineNode := AddThreadToTree(vdtTimeLine, ThData);\r\n\r\n    LinkData := vstThreads.GetNodeData(NameNode);\r\n    LinkData^.SyncNode := TimeLineNode;\r\n\r\n    LinkData := vdtTimeLine.GetNodeData(TimeLineNode);\r\n    LinkData^.SyncNode := NameNode;\r\n  finally\r\n    vstThreads.EndUpdate;\r\n    vdtTimeLine.EndUpdate;\r\n  end;\r\n\r\n  // Memory Info\r\n  AddThreadToTree(vstMemInfoThreads, ThData);\r\n\r\n  // Exceptions\r\n  AddThreadToTree(vstExceptionThreads, ThData);\r\n\r\n  // Code Tracking\r\n  AddThreadToTree(vstTrackThreads, ThData);\r\n\r\n  // Lock Tracking\r\n  AddThreadToTree(vstLockThreads, ThData);\r\nend;\r\n\r\nfunction TMainForm.AddThreadToTree(Tree: TBaseVirtualTree; ThData: PThreadData): PVirtualNode;\r\nvar\r\n  LinkData: PLinkData;\r\n  ParentThData: PThreadData;\r\n  ParentId: Cardinal;\r\n  ParentNode: PVirtualNode;\r\n  CurNode: PVirtualNode;\r\nbegin\r\n  Tree.BeginUpdate;\r\n  CurNode := Tree.FocusedNode;\r\n  try\r\n    ParentNode := Nil;\r\n\r\n    ParentId := ThData^.ThreadAdvInfo^.ThreadParentId;\r\n\r\n    if ParentId <> 0 then\r\n    begin\r\n      ParentThData := gvDebuger.GetThreadData(ParentId, True);\r\n\r\n      if ParentThData <> nil then\r\n        ParentNode := FindThreadNode(Tree, ParentThData);\r\n\r\n      (*\r\n      if ParentThData = nil then\r\n        //       \r\n        ParentNode := FindThreadNodeById(Tree, ParentId)\r\n      else\r\n        ParentNode := FindThreadNode(Tree, ParentThData);\r\n      *)\r\n    end;\r\n\r\n    if ParentNode = Nil then\r\n      ParentNode := Tree.RootNode^.FirstChild;\r\n\r\n    Result := Tree.AddChild(ParentNode);\r\n    Tree.Expanded[ParentNode] := True;\r\n\r\n    LinkData := Tree.GetNodeData(Result);\r\n    LinkData^.SyncNode := nil;\r\n    LinkData^.ThreadData := ThData;\r\n    LinkData^.LinkType := ltThread;\r\n  finally\r\n    Tree.FocusedNode := CurNode;\r\n    Tree.EndUpdate;\r\n  end;\r\nend;\r\n\r\nprocedure TMainForm.AddTrackHistory(TrackFuncInfo: TTrackFuncInfo);\r\nbegin\r\n  FTrackHistory.Remove(TrackFuncInfo);\r\n  FTrackHistory.Insert(0, TrackFuncInfo);\r\n\r\n  UpdateTrackHistoryList;\r\nend;\r\n\r\nprocedure TMainForm.cbCPUTimeLineClick(Sender: TObject);\r\nbegin\r\n  UpdateTrees;\r\nend;\r\n\r\nprocedure TMainForm.ClearDbgInfoTrees;\r\nbegin\r\n  vstDbgInfoUnits.Clear;\r\n  vstDbgInfoConsts.Clear;\r\n  vstDbgInfoTypes.Clear;\r\n  vstDbgInfoVars.Clear;\r\n  vstDbgInfoFunctions.Clear;\r\n  vstDbgInfoFuncVars.Clear;\r\n  svfDbgInfoUnitSource.Clear;\r\n  svfDbgInfoFuncAdv.Clear;\r\nend;\r\n\r\nprocedure TMainForm.ClearDbgTrees;\r\nbegin\r\n  vstThreads.Clear;\r\n  vdtTimeLine.Clear;\r\n\r\n  ClearMemInfoTrees;\r\n\r\n  vstExceptionThreads.Clear;\r\n  vstExceptionList.Clear;\r\n  vstExceptionCallStack.Clear;\r\n  svfExceptInfoSource.Clear;\r\nend;\r\n\r\nprocedure TMainForm.ClearMemInfoTrees;\r\nbegin\r\n  vstMemInfoThreads.Clear;\r\n\r\n  vstMemList.Clear;\r\n  vstMemStack.Clear;\r\n  svfMemInfoSource.Clear;\r\n\r\n  vstMemInfoFuncTree.Clear;\r\n  vstMemInfoObjects.Clear;\r\n  vstMemInfoObjStack.Clear;\r\n  vstMemInfoFuncParents.Clear;\r\n  vstMemInfoFuncChilds.Clear;\r\n  svfMemInfoFuncSrc.Clear;\r\nend;\r\n\r\nprocedure TMainForm.ClearProject;\r\nbegin\r\n  if Assigned(gvDebuger) and gvDebuger.Active then\r\n  begin\r\n    acStop.Execute;\r\n\r\n    while gvDebuger.Active do\r\n      Application.ProcessMessages;\r\n  end;\r\n\r\n  //  \r\n  tmrThreadsUpdate.Enabled := False;\r\n\r\n  ClearTrees;\r\n\r\n  _AC.ClearDebug(True);\r\n\r\n  if gvProjectOptions.ProjectName <> '' then\r\n    FSpiderOptions.AddRecentProject(gvProjectOptions.ProjectName);\r\n\r\n  LoadRecentProjects;\r\n\r\n  FProjectType := ptEmpty;\r\n  rbnMain.Caption := 'Empty';\r\n  gvProjectOptions.Clear;\r\n\r\n  UpdateStatusInfo;\r\n  UpdateMainActions;\r\nend;\r\n\r\nprocedure TMainForm.ClearTrackHistoryList;\r\nbegin\r\n  FTrackHistory.Clear;\r\n\r\n  UpdateTrackHistoryList;\r\nend;\r\n\r\nprocedure TMainForm.ClearTrackTrees;\r\nbegin\r\n  vstTrackThreads.Clear;\r\n  vstTrackFuncs.Clear;\r\n  vstTrackFuncParent.Clear;\r\n  vstTrackFuncChilds.Clear;\r\nend;\r\n\r\nprocedure TMainForm.ClearLockInfoTrees;\r\nbegin\r\n  vstLockThreads.Clear;\r\n  vstLockTrackingList.Clear;\r\n  vstLockTrackingParents.Clear;\r\n  vstLockTrackingChilds.Clear;\r\n  vstLockTrackingSyncObjs.Clear;\r\n  vstLockTrackingSyncObjStack.Clear;\r\n  svfLockTrackingSource.Clear;\r\nend;\r\n\r\nprocedure TMainForm.ClearTrees;\r\nbegin\r\n  vstLog.Clear;\r\n\r\n  ClearDbgTrees;\r\n  ClearDbgInfoTrees;\r\n  ClearTrackTrees;\r\n  ClearLockInfoTrees;\r\nend;\r\n\r\nprocedure TMainForm.DoAction(Action: TacAction; const Args: array of Variant);\r\nbegin\r\n  if not Visible then Exit;\r\n\r\n  case Action of\r\n    acAddThread:\r\n      AddThread(Args[0]);\r\n    acCreateProcess:\r\n      AddProcess(Args[0]);\r\n    acProgress:\r\n      ProgressAction(Args[0], Args[1]);\r\n    acSetProjectName:\r\n      SetProjectName(Args[0]);\r\n    acChangeProjectSettings:\r\n      UpdateProjectOptions;\r\n    acChangeDbgState:\r\n      UpdateDebugActions;\r\n  end;\r\n\r\n  //  ,       \r\n  tmrThreadsUpdate.Enabled := True;\r\n\r\n  (*\r\n  UpdateStatusInfo;\r\n\r\n  tmrThreadsUpdate.Enabled := Assigned(gvDebugInfo) and Assigned(gvDebuger) and gvDebuger.Active;\r\n\r\n  if not tmrThreadsUpdate.Enabled then\r\n    UpdateTrees;\r\n  *)\r\nend;\r\n\r\nfunction OffsetToTime(const Offset: Cardinal): String;\r\nvar\r\n  Sec: Cardinal;\r\n  Min: Cardinal;\r\n  Hour: Cardinal;\r\n  Day: Cardinal;\r\nbegin\r\n  Sec := Offset;\r\n  Min := Sec div 60; Sec := Sec mod 60;\r\n  Result := IntToStr(Sec) + 's ';\r\n  if Min > 0 then\r\n  begin\r\n    Hour := Min div 60; Min := Min mod 60;\r\n    Result := IntToStr(Min) + 'm ' + Result;\r\n    if Hour > 0 then\r\n    begin\r\n      Day := Hour div 24; Hour := Hour mod 24;\r\n      Result := IntToStr(Hour) + 'h ' + Result;\r\n      if Day > 0 then\r\n        Result := IntToStr(Day) + 'd ' + Result;\r\n    end;\r\n  end;\r\nend;\r\n\r\nconst\r\n  _TicksPerSec = 100;\r\n\r\nprocedure TMainForm.DrawBackgroundEx(const GP: IGPGraphics; const R: TRect; const BkColor: TColor);\r\nconst\r\n  DashValues: array [0..1] of Single = (4, 2);\r\nvar\r\n  Brush: IGPBrush;\r\n  Pen: IGPPen;\r\n\r\n  Cnt: Integer;\r\n  X: Integer;\r\nbegin\r\n  Brush := TGPSolidBrush.Create(TGPColor.Create(ColorToRGB(BkColor)));\r\n  Pen := TGPPen.Create(TGPColor.Silver);\r\n  Pen.SetDashPattern(DashValues);\r\n\r\n  GP.FillRectangle(Brush, TGPRect.Create(R));\r\n\r\n  For Cnt := 0 to ((R.Right - R.Left + 1) div 100) + 1 do\r\n  begin\r\n    X := R.Left + Cnt * 100 + 1;\r\n\r\n    GP.DrawLine(Pen, X, R.Top, X, R.Bottom);\r\n  end;\r\nend;\r\n\r\nprocedure TMainForm.DrawProcessCPUTimeLine(const GP: IGPGraphics; const R: TRect; ProcData: TProcessData; const CurOffset: Cardinal);\r\nvar\r\n  X1, X2, Y1, Y2: Integer;\r\n  T1, T2: Int64;\r\n  I: Cardinal;\r\n  ProcPoint: PProcessPoint;\r\nbegin\r\n  if (ProcData = nil) or (ProcData.DbgPointsCount = 0) then Exit;\r\n\r\n  T1 := 0;\r\n  T2 := ProcData.DbgPointsCount - 1;\r\n\r\n  X1 := R.Left + Integer(T1 - CurOffset);\r\n  X2 := R.Left + Integer(T2 - CurOffset);\r\n\r\n  if (X1 < R.Left) and (X2 < R.Left) then Exit;\r\n  if (X1 > R.Right) and (X2 > R.Right) then Exit;\r\n\r\n  if X1 < R.Left then X1 := R.Left;\r\n  if X1 > R.Right then X1 := R.Right;\r\n\r\n  if X2 < R.Left then X2 := R.Left;\r\n  if X2 > R.Right then X2 := R.Right;\r\n\r\n  Y1 := R.Top + 3;\r\n  Y2 := R.Bottom - 3;\r\n\r\n  DrawVGradientRect(GP, GPRect(X1, Y1, X2, Y2), FSpiderOptions.TimelineColors[ptWait]);\r\n\r\n  if ProcData.DbgPointsCount > 0 then\r\n  begin\r\n    for I := CurOffset to ProcData.DbgPointsCount - 1 do\r\n    begin\r\n      ProcPoint := ProcData.DbgPointByIdx(I);\r\n      if ((ProcPoint^.PointType = ptPerfomance) and (ProcPoint^.DeltaTime > 0)) or\r\n        (ProcPoint^.PointType in [ptException, ptThreadInfo, ptTraceInfo])\r\n      then begin\r\n        X1 := R.Left + Integer(I - CurOffset) - 1;\r\n        if (X1 < R.Left) then Continue;\r\n        if (X1 > R.Right) then Break;\r\n\r\n        DrawVGradientRect(GP, GPRect(X1, Y1, X1, Y2), FSpiderOptions.TimelineColors[ProcPoint^.PointType]);\r\n      end;\r\n    end;\r\n  end;\r\nend;\r\n\r\nprocedure TMainForm.DrawProcessTimeLine(const GP: IGPGraphics; const R: TRect; ProcData: TProcessData; const CurOffset: Cardinal);\r\nvar\r\n  X1, X2, Y1, Y2: Integer;\r\n  T1, T2, F: Int64;\r\n  OffsetT1, OffsetT2, Offset: Cardinal;\r\n  IdxL, IdxR, Idx: Cardinal;\r\n  I: Cardinal;\r\n  ProcPoint: PProcessPoint;\r\nbegin\r\n  if ProcData = nil then Exit;\r\n\r\n  T1 := 0;\r\n  if ProcData.State <> psActive then\r\n    T2 := ProcData.Elapsed\r\n  else\r\n    T2 := _QueryPerformanceCounter;\r\n\r\n  T2 := T2 - ProcData.Started;\r\n\r\n  Offset := CurOffset * _TicksPerSec;\r\n\r\n  F := _QueryPerformanceFrequency; // in 1 sec\r\n\r\n  F := F div _TicksPerSec;\r\n\r\n  OffsetT1 := T1 div F;\r\n  OffsetT2 := T2 div F;\r\n\r\n  X1 := R.Left + Integer(OffsetT1 - Offset);\r\n  X2 := R.Left + Integer(OffsetT2 - Offset);\r\n\r\n  if (X1 < R.Left) and (X2 < R.Left) then Exit;\r\n  if (X1 > R.Right) and (X2 > R.Right) then Exit;\r\n\r\n  if X1 < R.Left then X1 := R.Left;\r\n  if X1 > R.Right then X1 := R.Right;\r\n\r\n  if X2 < R.Left then X2 := R.Left;\r\n  if X2 > R.Right then X2 := R.Right;\r\n\r\n  Y1 := R.Top + 3;\r\n  Y2 := R.Bottom - 3;\r\n\r\n  DrawVGradientRect(GP, GPRect(X1, Y1, X2, Y2), FSpiderOptions.TimelineColors[ptWait]);\r\n\r\n  if ProcData.DbgPointsCount > 0 then\r\n  begin\r\n    IdxL := 0;\r\n\r\n    //       \r\n    if Offset > 0 then\r\n    begin\r\n      IdxR := ProcData.DbgPointsCount - 1;\r\n\r\n      repeat\r\n        Idx := (IdxL + IdxR) div 2;\r\n        ProcPoint := ProcData.DbgPointByIdx(Idx);\r\n\r\n        if (ProcPoint^.FromStart div F) > Offset then\r\n          IdxR := Idx\r\n        else\r\n          IdxL := Idx;\r\n      until IdxR - IdxL <= 1;\r\n    end;\r\n\r\n    for I := IdxL to ProcData.DbgPointsCount - 1 do\r\n    begin\r\n      ProcPoint := ProcData.DbgPointByIdx(I);\r\n      if ((ProcPoint^.PointType = ptPerfomance) and (ProcPoint^.DeltaTime > 0)) or\r\n        (ProcPoint^.PointType in [ptException, ptThreadInfo, ptTraceInfo])\r\n      then begin\r\n        OffsetT1 := ProcPoint^.FromStart div F;\r\n        X1 := R.Left + Integer(OffsetT1 - Offset) - 1;\r\n\r\n        if (X1 < R.Left) then\r\n          Continue;\r\n        if (X1 > R.Right) then\r\n          Break;\r\n\r\n        DrawVGradientRect(GP, GPRect(X1, Y1, X1, Y2), FSpiderOptions.TimelineColors[ProcPoint^.PointType]);\r\n      end;\r\n    end;\r\n  end;\r\nend;\r\n\r\nprocedure TMainForm.DrawThreadCPUTimeLine(const GP: IGPGraphics; const R: TRect; ThData: PThreadData; const CurOffset: Cardinal);\r\nvar\r\n  X1, X2, X3, Y1, Y2: Integer;\r\n  T1, T2, T3: Int64;\r\n  I: Integer;\r\n\r\n  IdxL, IdxR, Idx: Integer;\r\n  ThPoint: PThreadPoint;\r\n\r\n  IdxL1, IdxR1: Integer;\r\n  SyncObjsInfo: PSyncObjsInfo;\r\n\r\n  procedure _DrawSyncObjs(SyncObjsInfo: PSyncObjsInfo);\r\n  var\r\n    XL, XR: Integer;\r\n    TL, TR: Int64;\r\n\r\n    DR: TGPRect;\r\n\r\n    SyncObjsInfoL: PSyncObjsInfo;\r\n    SyncObjsInfoR: PSyncObjsInfo;\r\n\r\n    SyncObjsColor: TColor;\r\n  begin\r\n    SyncObjsInfoL := nil;\r\n    SyncObjsInfoR := nil;\r\n\r\n    case SyncObjsInfo.SyncObjsInfo.SyncObjsStateType of\r\n      sosEnter:\r\n        begin\r\n          SyncObjsInfoL := SyncObjsInfo;\r\n          SyncObjsInfoR := SyncObjsInfo.Link;\r\n        end;\r\n      sosLeave:\r\n        begin\r\n          SyncObjsInfoL := SyncObjsInfo.Link;\r\n          SyncObjsInfoR := SyncObjsInfo;\r\n        end;\r\n    end;\r\n\r\n    if Assigned(SyncObjsInfoL) then\r\n    begin\r\n      TL := SyncObjsInfoL.PerfIdx;\r\n      XL := R.Left + Integer(TL - CurOffset) - 1;\r\n    end\r\n    else\r\n      XL := X1;\r\n\r\n    if Assigned(SyncObjsInfoR) then\r\n    begin\r\n      TR := SyncObjsInfoR.PerfIdx;\r\n      XR := R.Left + Integer(TR - CurOffset) - 1;\r\n    end\r\n    else\r\n      XR := X2;\r\n\r\n    if XL <> XR then\r\n    begin\r\n      SyncObjsColor := FSpiderOptions.SyncObjsColors[SyncObjsInfo^.SyncObjsInfo.SyncObjsType];\r\n\r\n      case SyncObjsInfo^.SyncObjsInfo.SyncObjsType of\r\n        soInCriticalSection:\r\n          begin\r\n            DR := GPRect(XL, Y1 - 2, XR, Y1);\r\n            DrawHInterval(GP, DR, SyncObjsColor);\r\n\r\n            (*\r\n            DR := Rect(XL, Y1, XL, Y2);\r\n            DrawVGradientRect(GP, DR, SyncObjsColor);\r\n\r\n            DR := Rect(XR, Y1, XR, Y2);\r\n            DrawVGradientRect(GP, DR, SyncObjsColor);\r\n            *)\r\n          end;\r\n      else\r\n        begin\r\n          DR := GPRect(XL, Y1, XR, Y2);\r\n          DrawVGradientRect(GP, DR, SyncObjsColor);\r\n        end;\r\n      end;\r\n    end;\r\n  end;\r\n\r\nbegin\r\n  if (ThData = nil) or (ThData^.DbgPointsCount = 0) then Exit;\r\n\r\n  T1 := ThData^.DbgPointByIdx(0)^.PerfIdx;\r\n  if ThData^.State = tsFinished then\r\n    T2 := ThData^.DbgPointByIdx(ThData^.DbgPointsCount - 1)^.PerfIdx\r\n  else\r\n    T2 := gvDebuger.ProcessData.CurDbgPointIdx;\r\n\r\n  X1 := R.Left + Integer(T1 - CurOffset);\r\n  X2 := R.Left + Integer(T2 - CurOffset);\r\n\r\n  if (X1 < R.Left) and (X2 < R.Left) then Exit;\r\n  if (X1 > R.Right) and (X2 > R.Right) then Exit;\r\n\r\n  if X1 < R.Left then X1 := R.Left;\r\n  if X1 > R.Right then X1 := R.Right;\r\n\r\n  if X2 < R.Left then X2 := R.Left;\r\n  if X2 > R.Right then X2 := R.Right;\r\n\r\n  Y1 := R.Top + 3;\r\n  Y2 := R.Bottom - 3;\r\n\r\n  DrawVGradientRect(GP, GPRect(X1, Y1, X2, Y2), FSpiderOptions.TimelineColors[ptWait]);\r\n\r\n  if ThData^.DbgPointsCount > 0 then\r\n  begin\r\n    IdxL := 0;\r\n\r\n    //  SyncObjs\r\n    if acLockTracking.Checked and acViewSyncObjsOnTimeLine.Checked then\r\n    begin\r\n      if ThData^.DbgSyncObjsInfo.Count > 0 then\r\n      begin\r\n        IdxL1 := 0;\r\n\r\n        //    \r\n        if IdxL > 0 then\r\n        begin\r\n          IdxR1 := ThData^.DbgSyncObjsInfo.Count - 1;\r\n\r\n          repeat\r\n            Idx := (IdxL1 + IdxR1) div 2;\r\n            SyncObjsInfo := ThData^.DbgSyncObjsByIdx(Idx);\r\n\r\n            if SyncObjsInfo^.PerfIdx > IdxL then\r\n              IdxR1 := Idx\r\n            else\r\n            begin\r\n              IdxL1 := Idx;\r\n\r\n              if IdxL1 = IdxL then\r\n              begin\r\n                while (IdxL1 > 0) do\r\n                begin\r\n                  SyncObjsInfo := ThData^.DbgSyncObjsByIdx(IdxL1);\r\n\r\n                  if SyncObjsInfo^.PerfIdx <> IdxL then\r\n                    Break;\r\n\r\n                  Dec(IdxL1);\r\n                end;\r\n\r\n                Break;\r\n              end;\r\n            end;\r\n          until (IdxR1 - IdxL1 <= 1);\r\n        end;\r\n\r\n        for I := IdxL1 to ThData^.DbgSyncObjsInfo.Count - 1 do\r\n        begin\r\n          SyncObjsInfo := ThData^.DbgSyncObjsByIdx(I);\r\n\r\n          T3 := SyncObjsInfo^.PerfIdx;\r\n          X3 := R.Left + Integer(T3 - CurOffset) - 1;\r\n\r\n          if (X3 > R.Right) then\r\n            Break;\r\n\r\n          _DrawSyncObjs(SyncObjsInfo);\r\n        end;\r\n      end;\r\n    end;\r\n\r\n    //       \r\n    if CurOffset > 0 then\r\n    begin\r\n      IdxR := ThData^.DbgPointsCount - 1;\r\n\r\n      repeat\r\n        Idx := (IdxL + IdxR) div 2;\r\n        ThPoint := ThData^.DbgPointByIdx(Idx);\r\n\r\n        if ThPoint^.PerfIdx > CurOffset then\r\n          IdxR := Idx\r\n        else\r\n          IdxL := Idx;\r\n      until IdxR - IdxL <= 1;\r\n    end;\r\n\r\n    //  \r\n    for I := IdxL to ThData^.DbgPointsCount - 1 do\r\n    begin\r\n      ThPoint := ThData^.DbgPointByIdx(I);\r\n\r\n      if ThPoint = nil then\r\n        Continue;\r\n\r\n      T3 := ThPoint^.PerfIdx;\r\n      X3 := R.Left + Integer(T3 - CurOffset) - 1;\r\n\r\n      if (X3 < R.Left) then\r\n        Continue;\r\n      if (X3 > R.Right) then\r\n        Break;\r\n\r\n      DrawVGradientRect(GP, GPRect(X3, Y1, X3, Y2), FSpiderOptions.TimelineColors[ThPoint^.PointType]);\r\n    end;\r\n  end;\r\nend;\r\n\r\nprocedure TMainForm.DrawThreadTimeLine(const GP: IGPGraphics; const R: TRect; ThData: PThreadData; const CurOffset: Cardinal);\r\nvar\r\n  X1, X2, X3, Y1, Y2: Integer;\r\n  T1, T2, T3, F: Int64;\r\n  OffsetT1, OffsetT2, Offset: Cardinal;\r\n  IdxL, IdxR, Idx: Cardinal;\r\n  I: Cardinal;\r\n  ThPoint: PThreadPoint;\r\n  ProcPoint: PProcessPoint;\r\n\r\n  procedure _DrawSyncObjs(SyncObjsInfo: PSyncObjsInfo);\r\n  var\r\n    XL, XR: Integer;\r\n    TL, TR: Int64;\r\n\r\n    DR: TGPRect;\r\n\r\n    SyncObjsInfoL: PSyncObjsInfo;\r\n    SyncObjsInfoR: PSyncObjsInfo;\r\n\r\n    SyncObjsColor: TColor;\r\n  begin\r\n    SyncObjsInfoL := nil;\r\n    SyncObjsInfoR := nil;\r\n\r\n    case SyncObjsInfo.SyncObjsInfo.SyncObjsStateType of\r\n      sosEnter:\r\n        begin\r\n          SyncObjsInfoL := SyncObjsInfo;\r\n          SyncObjsInfoR := SyncObjsInfo.Link;\r\n        end;\r\n      sosLeave:\r\n        begin\r\n          SyncObjsInfoL := SyncObjsInfo.Link;\r\n          SyncObjsInfoR := SyncObjsInfo;\r\n        end;\r\n    end;\r\n\r\n    if Assigned(SyncObjsInfoL) then\r\n    begin\r\n      TL := (SyncObjsInfoL^.SyncObjsInfo.CurTime - ThData^.Started) div F;\r\n      XL := R.Left + Integer(OffsetT1 + TL - Offset);\r\n    end\r\n    else\r\n      XL := X1;\r\n\r\n    if Assigned(SyncObjsInfoR) then\r\n    begin\r\n      TR := (SyncObjsInfoR^.SyncObjsInfo.CurTime - ThData^.Started) div F;\r\n      XR := R.Left + Integer(OffsetT1 + TR - Offset);\r\n    end\r\n    else\r\n      XR := X2;\r\n\r\n    if XL <> XR then\r\n    begin\r\n      SyncObjsColor := FSpiderOptions.SyncObjsColors[SyncObjsInfo^.SyncObjsInfo.SyncObjsType];\r\n\r\n      case SyncObjsInfo^.SyncObjsInfo.SyncObjsType of\r\n        soInCriticalSection:\r\n          begin\r\n            DR := GPRect(XL, Y1 - 2, XR, Y1);\r\n            DrawHInterval(GP, DR, SyncObjsColor);\r\n\r\n            DR := GPRect(XL, Y1, XL, Y2);\r\n            DrawVGradientRect(GP, DR, FSpiderOptions.SyncObjsColors[soEnterCriticalSection]);\r\n\r\n            DR := GPRect(XR, Y1, XR, Y2);\r\n            DrawVGradientRect(GP, DR, FSpiderOptions.SyncObjsColors[soLeaveCriticalSection]);\r\n          end;\r\n      else\r\n        begin\r\n          DR := GPRect(XL, Y1, XR, Y2);\r\n          DrawVGradientRect(GP, DR, SyncObjsColor);\r\n        end;\r\n      end;\r\n    end;\r\n  end;\r\n\r\nvar\r\n  IdxL1, IdxR1: Cardinal;\r\n  SyncObjsInfo: PSyncObjsInfo;\r\nbegin\r\n  if ThData = nil then Exit;\r\n\r\n  T1 := ThData^.Started;\r\n  if ThData^.State = tsFinished then\r\n    T2 := T1 + ThData^.Elapsed\r\n  else\r\n    T2 := _QueryPerformanceCounter;\r\n\r\n  T1 := T1 - gvDebuger.ProcessData.Started;\r\n  T2 := T2 - gvDebuger.ProcessData.Started;\r\n\r\n  Offset := CurOffset * _TicksPerSec;\r\n\r\n  F := _QueryPerformanceFrequency; // in 1 sec\r\n\r\n  F := F div _TicksPerSec;\r\n\r\n  OffsetT1 := T1 div F;\r\n  OffsetT2 := T2 div F;\r\n\r\n  X1 := R.Left + Integer(OffsetT1 - Offset);\r\n  X2 := R.Left + Integer(OffsetT2 - Offset);\r\n\r\n  if (X1 < R.Left) and (X2 < R.Left) then Exit;\r\n  if (X1 > R.Right) and (X2 > R.Right) then Exit;\r\n\r\n  if X1 < R.Left then X1 := R.Left;\r\n  if X1 > R.Right then X1 := R.Right;\r\n\r\n  if X2 < R.Left then X2 := R.Left;\r\n  if X2 > R.Right then X2 := R.Right;\r\n\r\n  Y1 := R.Top + 3;\r\n  Y2 := R.Bottom - 3;\r\n\r\n  DrawVGradientRect(GP, GPRect(X1, Y1, X2, Y2), FSpiderOptions.TimelineColors[ptWait]);\r\n\r\n  if ThData^.DbgPointsCount > 0 then\r\n  begin\r\n    IdxL := 0;\r\n\r\n    //  SyncObjs\r\n    if acLockTracking.Checked and acViewSyncObjsOnTimeLine.Checked then\r\n    begin\r\n      if ThData^.DbgSyncObjsInfo.Count > 0 then\r\n      begin\r\n        IdxL1 := 0;\r\n\r\n        //    \r\n        if IdxL > 0 then\r\n        begin\r\n          IdxR1 := ThData^.DbgSyncObjsInfo.Count - 1;\r\n\r\n          repeat\r\n            Idx := (IdxL1 + IdxR1) div 2;\r\n            SyncObjsInfo := ThData^.DbgSyncObjsByIdx(Idx);\r\n            ProcPoint := gvDebuger.ProcessData.DbgPointByIdx(SyncObjsInfo^.PerfIdx);\r\n\r\n            if (ProcPoint^.FromStart div F) > IdxL then\r\n              IdxR1 := Idx\r\n            else\r\n            begin\r\n              IdxL1 := Idx;\r\n\r\n              if IdxL1 = IdxL then\r\n              begin\r\n                while (IdxL1 > 0) do\r\n                begin\r\n                  SyncObjsInfo := ThData^.DbgSyncObjsByIdx(IdxL1);\r\n                  ProcPoint := gvDebuger.ProcessData.DbgPointByIdx(SyncObjsInfo^.PerfIdx);\r\n\r\n                  // TODO: optimize\r\n                  if (ProcPoint^.FromStart div F) <> IdxL then\r\n                    Break;\r\n\r\n                  Dec(IdxL1);\r\n                end;\r\n\r\n                Break;\r\n              end;\r\n            end;\r\n          until (IdxR1 - IdxL1 <= 1);\r\n        end;\r\n\r\n        for I := IdxL1 to ThData^.DbgSyncObjsInfo.Count - 1 do\r\n        begin\r\n          SyncObjsInfo := ThData^.DbgSyncObjsByIdx(I);\r\n          ProcPoint := gvDebuger.ProcessData.DbgPointByIdx(SyncObjsInfo^.PerfIdx);\r\n\r\n          T3 := ProcPoint^.FromStart div F;\r\n          X3 := R.Left + Integer(T3 - Offset) - 1;\r\n\r\n          if (X3 > R.Right) then\r\n            Break;\r\n\r\n          _DrawSyncObjs(SyncObjsInfo);\r\n        end;\r\n      end;\r\n    end;\r\n\r\n    //       \r\n    if Offset > 0 then\r\n    begin\r\n      IdxR := ThData^.DbgPointsCount - 1;\r\n\r\n      repeat\r\n        Idx := (IdxL + IdxR) div 2;\r\n        ThPoint := ThData^.DbgPointByIdx(Idx);\r\n        ProcPoint := gvDebuger.ProcessData.DbgPointByIdx(ThPoint^.PerfIdx);\r\n\r\n        if (ProcPoint^.FromStart div F) > Offset then\r\n          IdxR := Idx\r\n        else\r\n          IdxL := Idx;\r\n      until IdxR - IdxL <= 1;\r\n    end;\r\n\r\n    for I := IdxL to ThData^.DbgPointsCount - 1 do\r\n    begin\r\n      ThPoint := ThData^.DbgPointByIdx(I);\r\n\r\n      if ThPoint = nil then\r\n        Continue;\r\n\r\n      ProcPoint := gvDebuger.ProcessData.DbgPointByIdx(ThPoint^.PerfIdx);\r\n\r\n      T3 := ProcPoint^.FromStart div F;\r\n      X3 := R.Left + Integer(T3 - Offset) - 1;\r\n\r\n      if (X3 < R.Left) then\r\n        Continue;\r\n      if (X3 > R.Right) then\r\n        Break;\r\n\r\n      DrawVGradientRect(GP, GPRect(X3, Y1, X3, Y2), FSpiderOptions.TimelineColors[ThPoint^.PointType]);\r\n    end;\r\n  end;\r\nend;\r\n\r\nprocedure TMainForm.DrawTimeLineHeaderEx(const GP: IGPGraphics; const R: TRect; const Offset: Integer);\r\nvar\r\n  Font: IGPFont;\r\n  Pen: IGPPen;\r\n  Brush: IGPBrush;\r\n\r\n  Cnt: Cardinal;\r\n  X, Y: Integer;\r\n  T: String;\r\n  Idx: Cardinal;\r\n  ProcPoint: PProcessPoint;\r\nbegin\r\n  Font := TGPFont.Create('Tahoma', 10, FontStyleRegular, UnitPixel);\r\n  Pen := TGPPen.Create(TGPColor.Black);\r\n  Brush := TGPSolidBrush.Create(TGPColor.Black);\r\n\r\n  For Cnt := 0 to ((R.Right - R.Left + 1) div 100) + 1 do\r\n  begin\r\n    X := R.Left + Integer(Cnt) * 100;\r\n    Y := R.Bottom;\r\n\r\n    T := '';\r\n\r\n    if acCPUTimeLine.Checked then\r\n    begin\r\n      if Assigned(gvDebuger) then\r\n      begin\r\n        Idx := Offset + Integer(Cnt) * 100;\r\n\r\n        if Idx < gvDebuger.ProcessData.DbgPointsCount then\r\n        begin\r\n          ProcPoint := gvDebuger.ProcessData.DbgPointByIdx(Idx);\r\n          T := ElapsedToTime(ProcPoint^.CPUTime);\r\n        end;\r\n      end;\r\n    end\r\n    else\r\n      T := OffsetToTime(Cardinal(Offset + Integer(Cnt)));\r\n\r\n    if T <> '' then\r\n      GP.DrawString(T, Font, TGPPointF.Create(X + 2, R.Top - 3), Brush);\r\n\r\n    GP.DrawLine(Pen, X - 1, Y - 1, X - 1, Y - 8);\r\n    GP.DrawLine(Pen, X + 50, Y - 1, X + 50, Y - 4);\r\n  end;\r\nend;\r\n\r\nprocedure TMainForm.FormCloseQuery(Sender: TObject; var CanClose: Boolean);\r\nbegin\r\n  CanClose := FCloseApp;\r\n\r\n  if CanClose then\r\n  begin\r\n    FinishGASession;\r\n\r\n    if acStop.Enabled then\r\n    begin\r\n      acStop.Execute;\r\n      while Assigned(gvDebuger) and gvDebuger.Active do\r\n      begin\r\n        Sleep(10);\r\n        Application.ProcessMessages;\r\n      end;\r\n    end;\r\n\r\n    acCloseProject.Execute;\r\n  end;\r\nend;\r\n\r\nprocedure TMainForm.OnException(Sender: TObject; E: Exception);\r\nbegin\r\n  SendGAException(E);\r\nend;\r\n\r\nprocedure TMainForm.pcMainChange(Sender: TObject);\r\nbegin\r\n  UpdateTrees;\r\nend;\r\n\r\nprocedure TMainForm.pcMemInfoChange(Sender: TObject);\r\nbegin\r\n  acMemInfoRefresh.Execute;\r\nend;\r\n\r\nprocedure TMainForm.pLockTrackingLinksResize(Sender: TObject);\r\nbegin\r\n  vstLockTrackingParents.Height := pLockTrackingLinks.ClientHeight div 2;\r\nend;\r\n\r\nprocedure TMainForm.pMemInfoFuncLinksResize(Sender: TObject);\r\nbegin\r\n  vstMemInfoFuncParents.Height := pMemInfoFuncLinks.ClientHeight div 2;\r\nend;\r\n\r\nprocedure TMainForm.LoadRecentProjects;\r\nvar\r\n  RL: TStringList;\r\n  I: Integer;\r\n  Item: TOptionItem;\r\n  Action: TContainedAction;\r\nbegin\r\n  RL := TStringList.Create;\r\n  try\r\n    FSpiderOptions.GetRecentProjects(RL);\r\n\r\n    for I := 0 to ALRecent.ActionCount - 1 do\r\n    begin\r\n      Action := ALRecent.Actions[I];\r\n      if I < RL.Count then\r\n      begin\r\n        TAction(Action).Enabled := True;\r\n        TAction(Action).Visible := True;\r\n        TAction(Action).Caption := RL[I];\r\n\r\n        Item := rbambMain.RecentItems[I];\r\n        Item.Caption := Format('&%d: %s', [I, RL[I]]);\r\n      end\r\n      else\r\n      begin\r\n        TAction(Action).Enabled := False;\r\n        TAction(Action).Visible := False;\r\n      end;\r\n    end;\r\n  finally\r\n    FreeAndNil(RL);\r\n  end;\r\nend;\r\n\r\nprocedure TMainForm.LoadSyncObjsInfoObjects(Tree: TBaseVirtualTree; SyncObjsInfo: TFuncSyncObjsInfoList; SyncNode: PVirtualNode);\r\nvar\r\n  SyncObjsItem: PSyncObjsInfo;\r\n  SyncObjsNode: PVirtualNode;\r\n  SyncObjsChildNode: PVirtualNode;\r\n  Data: PLinkData;\r\n  ChildData: PLinkData;\r\n  I: Integer;\r\nbegin\r\n  if SyncObjsInfo = Nil then Exit;\r\n\r\n  Tree.BeginUpdate;\r\n  try\r\n    Tree.Clear;\r\n\r\n    //SyncObjsInfo.Lock.BeginRead;\r\n    try\r\n      for I := 0 to SyncObjsInfo.Count - 1 do\r\n      begin\r\n        SyncObjsItem := PRPSyncObjsInfo(SyncObjsInfo[I])^.SyncObjsInfo;\r\n\r\n        if SyncObjsItem^.SyncObjsInfo.SyncObjsType = soInCriticalSection then\r\n          Continue;\r\n\r\n        if SyncObjsItem.IsShortLock then\r\n          Continue;\r\n\r\n        SyncObjsNode := Tree.AddChild(nil);\r\n\r\n        Data := Tree.GetNodeData(SyncObjsNode);\r\n        Data^.SyncNode := SyncNode;\r\n        Data^.SyncObjItem := SyncObjsItem.Enter; //   \r\n        Data^.LinkType := ltSyncObjInfo;\r\n\r\n        if SyncObjsItem^.SyncObjsInfo.SyncObjsType = soEnterCriticalSection then\r\n        begin\r\n          if Assigned(SyncObjsItem.LinkExt) then\r\n          begin\r\n            // Leave\r\n            if SyncObjsItem.Leave <> Nil then\r\n            begin\r\n              SyncObjsChildNode := Tree.AddChild(SyncObjsNode);\r\n              ChildData := Tree.GetNodeData(SyncObjsChildNode);\r\n              ChildData^.SyncNode := SyncNode;\r\n              ChildData^.SyncObjItem := SyncObjsItem.LinkExt.Leave;\r\n              ChildData^.LinkType := ltSyncObjChildInfo;\r\n\r\n              Tree.Expanded[SyncObjsNode] := True;\r\n            end;\r\n          end;\r\n        end;\r\n      end;\r\n    finally\r\n      //SyncObjsInfo.Lock.EndRead;\r\n    end;\r\n  finally\r\n    Tree.EndUpdate;\r\n  end;\r\nend;\r\n\r\nprocedure TMainForm.LoadSyncObjsInfoStack(Tree: TBaseVirtualTree; SyncObjInfo: PSyncObjsInfo; SyncNode: PVirtualNode);\r\nvar\r\n  Idx: Integer;\r\n  StackNode: PVirtualNode;\r\n  StackData: PLinkData;\r\n  Ptr: Pointer;\r\nbegin\r\n  Tree.BeginUpdate;\r\n  try\r\n    Tree.Clear;\r\n\r\n    if Assigned(SyncObjInfo) then\r\n    begin\r\n      for Idx := 0 to High(SyncObjInfo^.SyncObjsInfo.Stack) do\r\n      begin\r\n        Ptr := SyncObjInfo^.SyncObjsInfo.Stack[Idx];\r\n        if Ptr = nil then Break;\r\n\r\n        StackNode := Tree.AddChild(nil);\r\n        StackData := Tree.GetNodeData(StackNode);\r\n\r\n        StackData^.SyncObjStackPtr := Ptr;\r\n        StackData^.SyncNode := SyncNode;\r\n        StackData^.LinkType := ltSyncObjStack;\r\n      end;\r\n    end;\r\n  finally\r\n    Tree.EndUpdate;\r\n  end;\r\nend;\r\n\r\nprocedure TMainForm.LoadGUIOptions;\r\nbegin\r\n  LoadRecentProjects;\r\nend;\r\n\r\nprocedure TMainForm.LoadLockTrackThreadFunctions(ThData: PThreadData; ThreadNode: PVirtualNode);\r\nvar\r\n  Data: PLinkData;\r\n\r\n  TrackFuncInfoPair: TTrackFuncInfoPair;\r\n  TrackUnitInfoPair: TTrackUnitInfoPair;\r\n\r\n  UnitInfo: TUnitInfo;\r\n\r\n  BaseNode: PVirtualNode;\r\n  UnitNode: PVirtualNode;\r\n  Node: PVirtualNode;\r\nbegin\r\n  vstLockTrackingList.Clear;\r\n\r\n  vstLockTrackingList.BeginUpdate;\r\n  try\r\n    BaseNode := vstLockTrackingList.AddChild(nil);\r\n    Data := vstLockTrackingList.GetNodeData(BaseNode);\r\n    Data^.ThreadData := ThData;\r\n    Data^.SyncNode := ThreadNode;\r\n    Data^.LinkType := ltThread;\r\n\r\n    ThData^.DbgSyncObjsUnitList.LockForRead;\r\n    try\r\n      for TrackUnitInfoPair in ThData^.DbgSyncObjsUnitList do\r\n      begin\r\n        UnitInfo := TUnitInfo(TrackUnitInfoPair.Value.UnitInfo);\r\n        if UnitInfo = nil then Continue;\r\n\r\n        UnitNode := vstLockTrackingList.AddChild(BaseNode);\r\n        Data := vstLockTrackingList.GetNodeData(UnitNode);\r\n\r\n        Data^.SyncNode := ThreadNode;\r\n        Data^.TrackUnitInfo := TrackUnitInfoPair.Value;\r\n        Data^.LinkType := ltTrackUnitInfo;\r\n\r\n        TrackUnitInfoPair.Value.FuncInfoList.LockForRead;\r\n        try\r\n          for TrackFuncInfoPair in TrackUnitInfoPair.Value.FuncInfoList do\r\n          begin\r\n            Node := vstLockTrackingList.AddChild(UnitNode);\r\n            Data := vstLockTrackingList.GetNodeData(Node);\r\n\r\n            Data^.SyncNode := ThreadNode;\r\n            Data^.TrackFuncInfo := TrackFuncInfoPair.Value;\r\n            Data^.LinkType := ltTrackFuncInfo;\r\n          end;\r\n        finally\r\n          TrackUnitInfoPair.Value.FuncInfoList.UnLockForRead;\r\n        end;\r\n\r\n        vstLockTrackingList.Expanded[UnitNode] := True;\r\n      end;\r\n    finally\r\n      ThData^.DbgSyncObjsUnitList.UnLockForRead;\r\n    end;\r\n\r\n    vstLockTrackingList.Expanded[BaseNode] := True;\r\n  finally\r\n    vstLockTrackingList.EndUpdate;\r\n  end;\r\nend;\r\n\r\nprocedure TMainForm.LoadMemInfoChildFunctions(Tree: TBaseVirtualTree; TrackFuncInfo: TTrackFuncInfo; TrackFuncNode: PVirtualNode);\r\nvar\r\n  Data: PLinkData;\r\n  FuncInfo: TFuncInfo;\r\n  BaseNode: PVirtualNode;\r\n  UnitNode: PVirtualNode;\r\n  UnitData: PLinkData;\r\n  Node: PVirtualNode;\r\n  CallFuncCounterPair: TCallFuncCounterPair;\r\nbegin\r\n  Tree.Clear;\r\n\r\n  if TrackFuncInfo.ChildFuncs.Count = 0 then Exit;\r\n\r\n  Tree.BeginUpdate;\r\n  try\r\n    BaseNode := Tree.AddChild(nil);\r\n    Data := Tree.GetNodeData(BaseNode);\r\n    Data^.TrackFuncInfo := TrackFuncInfo;\r\n    Data^.SyncNode := TrackFuncNode;\r\n    Data^.LinkType := ltTrackFuncInfo;\r\n\r\n    TrackFuncInfo.ChildFuncs.LockForRead;\r\n    try\r\n      for CallFuncCounterPair in TrackFuncInfo.ChildFuncs do\r\n      begin\r\n        FuncInfo := TFuncInfo(CallFuncCounterPair.Value.FuncInfo);\r\n        if FuncInfo = nil then Continue;\r\n\r\n        UnitNode := FindTrackUnitNode(Tree, FuncInfo.UnitInfo);\r\n\r\n        if UnitNode = nil then\r\n        begin\r\n          UnitNode := Tree.AddChild(BaseNode);\r\n          UnitData := Tree.GetNodeData(UnitNode);\r\n\r\n          UnitData^.DbgUnitInfo := FuncInfo.UnitInfo;\r\n          UnitData^.SyncNode := TrackFuncNode;\r\n          UnitData^.LinkType := ltDbgUnitInfo;\r\n        end;\r\n\r\n        Node := Tree.AddChild(UnitNode);\r\n        Data := Tree.GetNodeData(Node);\r\n\r\n        Data^.TrackCallFuncInfo := CallFuncCounterPair.Value;\r\n        Data^.SyncNode := TrackFuncNode;\r\n        Data^.LinkType := ltTrackCallFuncInfo;\r\n\r\n        Tree.Expanded[UnitNode] := True;\r\n      end;\r\n    finally\r\n      TrackFuncInfo.ChildFuncs.UnLockForRead;\r\n    end;\r\n\r\n    Tree.Expanded[BaseNode] := True;\r\n  finally\r\n    Tree.EndUpdate;\r\n  end;\r\nend;\r\n\r\nprocedure TMainForm.LoadMemInfoObjects(Tree: TBaseVirtualTree; MemInfo: TGetMemInfoList; SyncNode: PVirtualNode);\r\nvar\r\n  MItem: TGetMemInfoItem;\r\n  node,\r\n  MemNode: PVirtualNode;\r\n  Data: PLinkData;\r\nbegin\r\n  if MemInfo = Nil then Exit;\r\n\r\n  Tree.BeginUpdate;\r\n  try\r\n    Tree.Clear;\r\n\r\n    MemInfo.Lock.BeginRead;\r\n    try\r\n      //init all nodes at once: much and much faster!\r\n      Tree.ChildCount[nil] := MemInfo.Count;\r\n      node := Tree.RootNode.FirstChild;\r\n      MemNode := node;\r\n\r\n      for MItem in MemInfo do\r\n      begin\r\n        //MemNode := Tree.AddChild(nil);       slooooooow\r\n        Data := Tree.GetNodeData(MemNode);\r\n        Data^.SyncNode := SyncNode;\r\n        Data^.MemPtr := MItem.Key;\r\n        Data^.LinkType := ltMemInfo;\r\n\r\n        MemNode := MemNode.NextSibling;\r\n      end;\r\n    finally\r\n      MemInfo.Lock.EndRead;\r\n    end;\r\n  finally\r\n    Tree.EndUpdate;\r\n  end;\r\nend;\r\n\r\nprocedure TMainForm.LoadMemInfoObjectStack(Tree: TBaseVirtualTree; MemInfo: TGetMemInfo; SyncNode: PVirtualNode);\r\nvar\r\n  Idx: Integer;\r\n  StackNode: PVirtualNode;\r\n  StackData: PLinkData;\r\n  Ptr: Pointer;\r\nbegin\r\n  Tree.BeginUpdate;\r\n  try\r\n    Tree.Clear;\r\n\r\n    for Idx := 0 to High(MemInfo.Stack) do\r\n    begin\r\n      Ptr := MemInfo.Stack[Idx];\r\n      if Ptr = nil then Break;\r\n\r\n      StackNode := Tree.AddChild(nil);\r\n      StackData := Tree.GetNodeData(StackNode);\r\n\r\n      StackData^.MemStackPtr := Ptr;\r\n      StackData^.SyncNode := SyncNode;\r\n      StackData^.LinkType := ltMemStack;\r\n    end;\r\n  finally\r\n    Tree.EndUpdate;\r\n  end;\r\nend;\r\n\r\nprocedure TMainForm.LoadMemInfoParentFunctions(Tree: TBaseVirtualTree; TrackFuncInfo: TTrackFuncInfo; TrackFuncNode: PVirtualNode);\r\nvar\r\n  Data: PLinkData;\r\n  FuncInfo: TFuncInfo;\r\n  BaseNode: PVirtualNode;\r\n  UnitNode: PVirtualNode;\r\n  Node: PVirtualNode;\r\n  CallFuncCounterPair: TCallFuncCounterPair;\r\nbegin\r\n  Tree.Clear;\r\n\r\n  if TrackFuncInfo.ParentFuncs.Count = 0 then Exit;\r\n\r\n  Tree.BeginUpdate;\r\n  try\r\n    BaseNode := Tree.AddChild(nil);\r\n    Data := Tree.GetNodeData(BaseNode);\r\n    Data^.TrackFuncInfo := TrackFuncInfo;\r\n    Data^.SyncNode := TrackFuncNode;\r\n    Data^.LinkType := ltTrackFuncInfo;\r\n\r\n    TrackFuncInfo.ParentFuncs.LockForRead;\r\n    try\r\n      for CallFuncCounterPair in TrackFuncInfo.ParentFuncs do\r\n      begin\r\n        FuncInfo := TFuncInfo(CallFuncCounterPair.Value.FuncInfo);\r\n        if FuncInfo = nil then Continue;\r\n\r\n        UnitNode := FindTrackUnitNode(Tree, FuncInfo.UnitInfo);\r\n\r\n        if UnitNode = nil then\r\n        begin\r\n          UnitNode := Tree.AddChild(BaseNode);\r\n          Data := Tree.GetNodeData(UnitNode);\r\n\r\n          Data^.DbgUnitInfo := FuncInfo.UnitInfo;\r\n          Data^.LinkType := ltDbgUnitInfo;\r\n        end;\r\n\r\n        Node := Tree.AddChild(UnitNode);\r\n        Data := Tree.GetNodeData(Node);\r\n\r\n        Data^.TrackCallFuncInfo := CallFuncCounterPair.Value;\r\n        Data^.SyncNode := TrackFuncNode;\r\n        Data^.LinkType := ltTrackCallFuncInfo;\r\n\r\n        Tree.Expanded[UnitNode] := True;\r\n      end;\r\n    finally\r\n      TrackFuncInfo.ParentFuncs.UnLockForRead;\r\n    end;\r\n\r\n    Tree.Expanded[BaseNode] := True;\r\n  finally\r\n    Tree.EndUpdate;\r\n  end;\r\nend;\r\n\r\nprocedure TMainForm.LoadMemInfoThreadFunctions(ThData: PThreadData; ThreadNode: PVirtualNode);\r\nvar\r\n  Th: TThread;\r\nbegin\r\n  vstMemInfoFuncTree.Clear;\r\n  vstMemInfoFuncParents.Clear;\r\n  vstMemInfoFuncChilds.Clear;\r\n\r\n  Th := TThread.CreateAnonymousThread(\r\n    procedure\r\n    begin\r\n      TThread.NameThreadForDebugging('TMainForm.LoadMemInfoThreadFunctions');\r\n\r\n      ThData^.UpdateGetMemUnitList;\r\n\r\n      // ,      \r\n      ThData^.DbgGetMemUnitList.LockForRead;\r\n      try\r\n        TThread.Synchronize(nil,\r\n          procedure\r\n          var\r\n            Data: PLinkData;\r\n\r\n            TrackFuncInfoPair: TTrackFuncInfoPair;\r\n            TrackUnitInfoPair: TTrackUnitInfoPair;\r\n\r\n            UnitInfo: TUnitInfo;\r\n\r\n            BaseNode: PVirtualNode;\r\n            UnitNode: PVirtualNode;\r\n            Node: PVirtualNode;\r\n          begin\r\n            vstMemInfoFuncTree.Clear;\r\n            vstMemInfoFuncParents.Clear;\r\n            vstMemInfoFuncChilds.Clear;\r\n\r\n            vstMemInfoFuncTree.BeginUpdate;\r\n            try\r\n              BaseNode := vstMemInfoFuncTree.AddChild(nil);\r\n              Data := vstMemInfoFuncTree.GetNodeData(BaseNode);\r\n              Data^.ThreadData := ThData;\r\n              Data^.SyncNode := ThreadNode;\r\n              Data^.LinkType := ltThread;\r\n\r\n              ThData^.DbgGetMemUnitList.LockForRead;\r\n              try\r\n                for TrackUnitInfoPair in ThData^.DbgGetMemUnitList do\r\n                begin\r\n                  UnitInfo := TUnitInfo(TrackUnitInfoPair.Value.UnitInfo);\r\n                  if UnitInfo = nil then Continue;\r\n\r\n                  UnitNode := vstMemInfoFuncTree.AddChild(BaseNode);\r\n                  Data := vstMemInfoFuncTree.GetNodeData(UnitNode);\r\n\r\n                  Data^.SyncNode := ThreadNode;\r\n                  Data^.TrackUnitInfo := TrackUnitInfoPair.Value;\r\n                  Data^.LinkType := ltTrackUnitInfo;\r\n\r\n                  for TrackFuncInfoPair in TrackUnitInfoPair.Value.FuncInfoList do\r\n                  begin\r\n                    Node := vstMemInfoFuncTree.AddChild(UnitNode);\r\n                    Data := vstMemInfoFuncTree.GetNodeData(Node);\r\n\r\n                    Data^.SyncNode := ThreadNode;\r\n                    Data^.TrackFuncInfo := TrackFuncInfoPair.Value;\r\n                    Data^.LinkType := ltTrackFuncInfo;\r\n                  end;\r\n\r\n                  vstMemInfoFuncTree.Expanded[UnitNode] := True;\r\n                end;\r\n              finally\r\n                ThData^.DbgGetMemUnitList.UnLockForRead;\r\n              end;\r\n\r\n              vstMemInfoFuncTree.Expanded[BaseNode] := True;\r\n            finally\r\n              vstMemInfoFuncTree.EndUpdate;\r\n            end;\r\n          end\r\n        );\r\n      finally\r\n        ThData^.DbgGetMemUnitList.UnLockForRead;\r\n      end;\r\n    end\r\n  );\r\n  Th.Suspended := False;\r\nend;\r\n\r\nprocedure TMainForm.FormCreate(Sender: TObject);\r\nbegin\r\n  Application.OnException := OnException;\r\n\r\n  FSpiderOptions := TSpiderOptions.Create(ChangeFileExt(Application.ExeName, '.xcfg'));\r\n  LoadGUIOptions;\r\n\r\n  FCloseApp := False;\r\n  FProjectType := ptEmpty;\r\n\r\n  FTrackHistory := TList.Create;\r\n\r\n  TThread.NameThreadForDebugging(AnsiString(ClassName), MainThreadID);\r\n\r\n  actbMainTabs.ParentBackground := True;\r\n\r\n  HidePCTabs(pcMain);\r\n  acTabLog.Execute;\r\n\r\n  ProgressAction('', 0);\r\n\r\n  //LoadLibrary('DbgHook32.dll'); //     DLL\r\nend;\r\n\r\nprocedure TMainForm.FormDestroy(Sender: TObject);\r\nbegin\r\n  tmrThreadsUpdate.Enabled := False;\r\n\r\n  FreeAndNil(FSpiderOptions);\r\n  FreeAndNil(FTrackHistory);\r\n\r\n  _AC.AppClose;\r\nend;\r\n\r\nprocedure TMainForm.FormShow(Sender: TObject);\r\nbegin\r\n  StartGASession;\r\n  SendGAEvent('Run Spider', GetAppID, 'Start');\r\n\r\n  acRunStop.Assign(acRun);\r\n  UpdateMainActions;\r\n  UpdateStatusInfo;\r\n\r\n  vstColumnResize(vstThreads.Header, 0);\r\n  vstColumnResize(vstMemInfoThreads.Header, 0);\r\n\r\n  LoadUpdateInfo;\r\nend;\r\n\r\nfunction TMainForm.FuncElapsedToTime(const FullCPUTime, FullElapsed, Elapsed: UInt64): String;\r\nvar\r\n  FTime: UInt64;\r\nbegin\r\n  Result := ' ';\r\n\r\n  if (Elapsed = 0) or (FullElapsed = 0) then\r\n    Exit;\r\n\r\n  FTime := Trunc(FullCPUTime * (Elapsed / FullElapsed));\r\n\r\n  if FTime > 0 then\r\n    Result := ElapsedToTime(FTime)\r\n  else\r\n    Result := '00:00.000';\r\nend;\r\n\r\nfunction TMainForm.GetLineTimeOffset: Cardinal;\r\nvar\r\n  F: Double;\r\n  PW: Integer;\r\nbegin\r\n  Result := 0;\r\n  if Assigned(gvDebugInfo) and Assigned(gvDebuger) and\r\n    (gvDebuger.ProcessData.DbgPointsCount > 0)\r\n  then\r\n  begin\r\n    PW := vdtTimeLine.Header.Columns[0].Width - vdtTimeLine.ClientWidth;\r\n    F := (-vdtTimeLine.OffsetX) / PW;\r\n    if acCPUTimeLine.Checked then\r\n      Result := (Trunc(gvDebuger.ProcessData.CurDbgPointIdx * F) div 100) * 100\r\n    else\r\n      Result := Trunc((gvDebuger.ProcessData.Elapsed_MSec div 1000) * F);\r\n  end;\r\nend;\r\n\r\nprocedure TMainForm.LoadConsts(UnitInfo: TUnitInfo; UnitNode: PVirtualNode);\r\nvar\r\n  I: Integer;\r\n  C: TConstInfo;\r\n  BaseNode: PVirtualNode;\r\n  Node: PVirtualNode;\r\n  Data: PLinkData;\r\nbegin\r\n  vstDbgInfoConsts.Clear;\r\n\r\n  if UnitInfo.Consts.Count = 0 then Exit;\r\n\r\n  vstDbgInfoConsts.BeginUpdate;\r\n  try\r\n    BaseNode := vstDbgInfoConsts.AddChild(nil);\r\n    Data := vstDbgInfoConsts.GetNodeData(BaseNode);\r\n\r\n    Data^.SyncNode := UnitNode;\r\n    Data^.DbgUnitInfo := UnitInfo;\r\n    Data^.LinkType := ltDbgUnitInfo;\r\n\r\n    for I := 0 to UnitInfo.Consts.Count - 1 do\r\n    begin\r\n      C := TConstInfo(UnitInfo.Consts[I]);\r\n\r\n      Node := vstDbgInfoConsts.AddChild(BaseNode);\r\n      Data := vstDbgInfoConsts.GetNodeData(Node);\r\n\r\n      Data^.SyncNode := UnitNode;\r\n      Data^.DbgConstInfo := C;\r\n      Data^.LinkType := ltDbgConstInfo;\r\n    end;\r\n\r\n    vstDbgInfoConsts.Expanded[BaseNode] := True;\r\n  finally\r\n    vstDbgInfoConsts.EndUpdate;\r\n  end;\r\nend;\r\n\r\nprocedure TMainForm.LoadFunctionParams(FuncInfo: TFuncInfo; FuncNode: PVirtualNode);\r\nvar\r\n  I: Integer;\r\n  V: TVarInfo;\r\n  BaseNode: PVirtualNode;\r\n  Node: PVirtualNode;\r\n  Data: PLinkData;\r\nbegin\r\n  vstDbgInfoFuncVars.Clear;\r\n\r\n  if FuncInfo.Params.Count = 0 then Exit;\r\n\r\n  vstDbgInfoFuncVars.BeginUpdate;\r\n  try\r\n    BaseNode := vstDbgInfoFuncVars.AddChild(nil);\r\n    Data := vstDbgInfoFuncVars.GetNodeData(BaseNode);\r\n\r\n    Data^.SyncNode := FuncNode;\r\n    Data^.DbgFuncInfo := FuncInfo;\r\n    Data^.LinkType := ltDbgFuncInfo;\r\n\r\n    for I := 0 to FuncInfo.Params.Count - 1 do\r\n    begin\r\n      V := TVarInfo(FuncInfo.Params[I]);\r\n\r\n      Node := vstDbgInfoFuncVars.AddChild(BaseNode);\r\n      Data := vstDbgInfoFuncVars.GetNodeData(Node);\r\n\r\n      Data^.SyncNode := FuncNode;\r\n      Data^.DbgFuncParamInfo := V;\r\n      Data^.LinkType := ltDbgFuncParamInfo;\r\n    end;\r\n\r\n    vstDbgInfoFuncVars.Expanded[BaseNode] := True;\r\n  finally\r\n    vstDbgInfoFuncVars.EndUpdate;\r\n  end;\r\nend;\r\n\r\nprocedure TMainForm.LoadFunctions(UnitInfo: TUnitInfo; UnitNode: PVirtualNode);\r\nvar\r\n  I: Integer;\r\n  F: TFuncInfo;\r\n  BaseNode: PVirtualNode;\r\n  Node: PVirtualNode;\r\n  Data: PLinkData;\r\nbegin\r\n  vstDbgInfoFuncVars.Clear;\r\n  vstDbgInfoFunctions.Clear;\r\n  svfDbgInfoFuncAdv.Clear;\r\n\r\n  if UnitInfo.Funcs.Count = 0 then Exit;\r\n\r\n  vstDbgInfoFunctions.BeginUpdate;\r\n  try\r\n    BaseNode := vstDbgInfoFunctions.AddChild(nil);\r\n    Data := vstDbgInfoFunctions.GetNodeData(BaseNode);\r\n\r\n    Data^.SyncNode := UnitNode;\r\n    Data^.DbgUnitInfo := UnitInfo;\r\n    Data^.LinkType := ltDbgUnitInfo;\r\n\r\n    for I := 0 to UnitInfo.Funcs.Count - 1 do\r\n    begin\r\n      F := TFuncInfo(UnitInfo.Funcs[I]);\r\n\r\n      Node := vstDbgInfoFunctions.AddChild(BaseNode);\r\n      Data := vstDbgInfoFunctions.GetNodeData(Node);\r\n\r\n      Data^.SyncNode := UnitNode;\r\n      Data^.DbgFuncInfo := F;\r\n      Data^.LinkType := ltDbgFuncInfo;\r\n    end;\r\n\r\n    vstDbgInfoFunctions.Expanded[BaseNode] := True;\r\n  finally\r\n    vstDbgInfoFunctions.EndUpdate;\r\n  end;\r\nend;\r\n\r\nfunction TMainForm.LoadFunctionSource(SrcView: TSourceViewFrame; FuncInfo: TFuncInfo; LineNo: Integer): LongBool;\r\nvar\r\n  UnitInfo: TUnitInfo;\r\n  StartLine: TLineInfo;\r\n  LineIdx: Integer;\r\n  PrevLine: TLineInfo;\r\nbegin\r\n  Result := False;\r\n\r\n  if not Assigned(FuncInfo) then\r\n  begin\r\n    SrcView.Clear;\r\n    Exit;\r\n  end;\r\n\r\n  UnitInfo := FuncInfo.UnitInfo;\r\n\r\n  SrcView.BeginUpdate;\r\n  try\r\n    SrcView.SourceFileName := UnitInfo.FullUnitName;\r\n\r\n    if LineNo = 0 then\r\n    begin\r\n      if FuncInfo.Lines.Count > 0 then\r\n      begin\r\n        StartLine := FuncInfo.Lines[0];\r\n\r\n        if Assigned(StartLine.SrcSegment) then\r\n          SrcView.SourceFileName := StartLine.SrcSegment.FullUnitName;\r\n\r\n        LineIdx := UnitInfo.Lines.IndexOf(StartLine) - 1;\r\n        if LineIdx >= 0 then\r\n        begin\r\n          PrevLine := UnitInfo.Lines[LineIdx];\r\n          LineNo := PrevLine.LineNo + 1;\r\n        end\r\n        else\r\n          LineNo := StartLine.LineNo - 2;\r\n\r\n        if Abs(StartLine.LineNo - LineNo) < 10 then\r\n          SrcView.GotoLine(LineNo, taAlignTop)\r\n        else\r\n          SrcView.GotoLine(LineNo, taVerticalCenter);\r\n\r\n        SrcView.SelectLine(StartLine.LineNo);\r\n      end;\r\n    end\r\n    else\r\n    begin\r\n      SrcView.GotoLine(LineNo, taVerticalCenter);\r\n\r\n      SrcView.SelectLine(LineNo);\r\n    end;\r\n\r\n    Result := True;\r\n  finally\r\n    SrcView.EndUpdate;\r\n  end;\r\nend;\r\n\r\nprocedure TMainForm.LoadTrackChildFunctions(TrackFuncInfo: TTrackFuncInfo; TrackFuncNode: PVirtualNode);\r\nvar\r\n  Data: PLinkData;\r\n  FuncInfo: TFuncInfo;\r\n  BaseNode: PVirtualNode;\r\n  UnitNode: PVirtualNode;\r\n  UnitData: PLinkData;\r\n  Node: PVirtualNode;\r\n  CallFuncCounterPair: TCallFuncCounterPair;\r\nbegin\r\n  vstTrackFuncChilds.Clear;\r\n\r\n  if TrackFuncInfo.ChildFuncs.Count = 0 then Exit;\r\n\r\n  vstTrackFuncChilds.BeginUpdate;\r\n  try\r\n    BaseNode := vstTrackFuncChilds.AddChild(nil);\r\n    Data := vstTrackFuncChilds.GetNodeData(BaseNode);\r\n    Data^.TrackFuncInfo := TrackFuncInfo;\r\n    Data^.SyncNode := TrackFuncNode;\r\n    Data^.LinkType := ltTrackFuncInfo;\r\n\r\n    for CallFuncCounterPair in TrackFuncInfo.ChildFuncs do\r\n    begin\r\n      FuncInfo := TFuncInfo(CallFuncCounterPair.Value.FuncInfo);\r\n      if FuncInfo = nil then Continue;\r\n\r\n      UnitNode := FindTrackUnitNode(vstTrackFuncChilds, FuncInfo.UnitInfo);\r\n\r\n      if UnitNode = nil then\r\n      begin\r\n        UnitNode := vstTrackFuncChilds.AddChild(BaseNode);\r\n        UnitData := vstTrackFuncChilds.GetNodeData(UnitNode);\r\n\r\n        UnitData^.DbgUnitInfo := FuncInfo.UnitInfo;\r\n        UnitData^.SyncNode := TrackFuncNode;\r\n        UnitData^.LinkType := ltDbgUnitInfo;\r\n      end;\r\n\r\n      Node := vstTrackFuncChilds.AddChild(UnitNode);\r\n      Data := vstTrackFuncChilds.GetNodeData(Node);\r\n\r\n      Data^.TrackCallFuncInfo := CallFuncCounterPair.Value;\r\n      Data^.SyncNode := TrackFuncNode;\r\n      Data^.LinkType := ltTrackCallFuncInfo;\r\n\r\n      vstTrackFuncChilds.Expanded[UnitNode] := True;\r\n    end;\r\n\r\n    vstTrackFuncChilds.Expanded[BaseNode] := True;\r\n  finally\r\n    vstTrackFuncChilds.EndUpdate;\r\n  end;\r\nend;\r\n\r\nprocedure TMainForm.LoadTrackParentFunctions(TrackFuncInfo: TTrackFuncInfo; TrackFuncNode: PVirtualNode);\r\nvar\r\n  Data: PLinkData;\r\n  FuncInfo: TFuncInfo;\r\n  BaseNode: PVirtualNode;\r\n  UnitNode: PVirtualNode;\r\n  Node: PVirtualNode;\r\n  CallFuncCounterPair: TCallFuncCounterPair;\r\nbegin\r\n  vstTrackFuncParent.Clear;\r\n\r\n  if TrackFuncInfo.ParentFuncs.Count = 0 then Exit;\r\n\r\n  vstTrackFuncParent.BeginUpdate;\r\n  try\r\n    BaseNode := vstTrackFuncParent.AddChild(nil);\r\n    Data := vstTrackFuncParent.GetNodeData(BaseNode);\r\n    Data^.TrackFuncInfo := TrackFuncInfo;\r\n    Data^.SyncNode := TrackFuncNode;\r\n    Data^.LinkType := ltTrackFuncInfo;\r\n\r\n    for CallFuncCounterPair in TrackFuncInfo.ParentFuncs do\r\n    begin\r\n      FuncInfo := TFuncInfo(CallFuncCounterPair.Value.FuncInfo);\r\n      if FuncInfo = nil then Continue;\r\n\r\n      UnitNode := FindTrackUnitNode(vstTrackFuncParent, FuncInfo.UnitInfo);\r\n\r\n      if UnitNode = nil then\r\n      begin\r\n        UnitNode := vstTrackFuncParent.AddChild(BaseNode);\r\n        Data := vstTrackFuncParent.GetNodeData(UnitNode);\r\n\r\n        Data^.DbgUnitInfo := FuncInfo.UnitInfo;\r\n        Data^.LinkType := ltDbgUnitInfo;\r\n      end;\r\n\r\n      Node := vstTrackFuncParent.AddChild(UnitNode);\r\n      Data := vstTrackFuncParent.GetNodeData(Node);\r\n\r\n      Data^.TrackCallFuncInfo := CallFuncCounterPair.Value;\r\n      Data^.SyncNode := TrackFuncNode;\r\n      Data^.LinkType := ltTrackCallFuncInfo;\r\n\r\n      vstTrackFuncParent.Expanded[UnitNode] := True;\r\n    end;\r\n\r\n    vstTrackFuncParent.Expanded[BaseNode] := True;\r\n  finally\r\n    vstTrackFuncParent.EndUpdate;\r\n  end;\r\nend;\r\n\r\nprocedure TMainForm.LoadTrackProcessFunctions(ProcData: TProcessData; ThreadNode: PVirtualNode);\r\nvar\r\n  Data: PLinkData;\r\n\r\n  TrackFuncInfoPair: TTrackFuncInfoPair;\r\n  TrackUnitInfoPair: TTrackUnitInfoPair;\r\n\r\n  UnitInfo: TUnitInfo;\r\n\r\n  BaseNode: PVirtualNode;\r\n  UnitNode: PVirtualNode;\r\n  Node: PVirtualNode;\r\nbegin\r\n  vstTrackFuncs.Clear;\r\n  vstTrackFuncParent.Clear;\r\n  vstTrackFuncChilds.Clear;\r\n\r\n  vstTrackFuncs.BeginUpdate;\r\n  try\r\n    BaseNode := vstTrackFuncs.AddChild(nil);\r\n    Data := vstTrackFuncs.GetNodeData(BaseNode);\r\n    Data^.ProcessData := ProcData;\r\n    Data^.SyncNode := ThreadNode;\r\n    Data^.LinkType := ltProcess;\r\n\r\n    for TrackUnitInfoPair in ProcData.DbgTrackUnitList do\r\n    begin\r\n      UnitInfo := TUnitInfo(TrackUnitInfoPair.Value.UnitInfo);\r\n      if UnitInfo = nil then Continue;\r\n\r\n      UnitNode := vstTrackFuncs.AddChild(BaseNode);\r\n      Data := vstTrackFuncs.GetNodeData(UnitNode);\r\n\r\n      Data^.SyncNode := ThreadNode;\r\n      Data^.TrackUnitInfo := TrackUnitInfoPair.Value;\r\n      Data^.LinkType := ltTrackUnitInfo;\r\n\r\n      for TrackFuncInfoPair in TrackUnitInfoPair.Value.FuncInfoList do\r\n      begin\r\n        Node := vstTrackFuncs.AddChild(UnitNode);\r\n        Data := vstTrackFuncs.GetNodeData(Node);\r\n\r\n        Data^.SyncNode := ThreadNode;\r\n        Data^.TrackFuncInfo := TrackFuncInfoPair.Value;\r\n        Data^.LinkType := ltTrackFuncInfo;\r\n      end;\r\n\r\n      vstTrackFuncs.Expanded[UnitNode] := True;\r\n    end;\r\n\r\n    vstTrackFuncs.Expanded[BaseNode] := True;\r\n  finally\r\n    vstTrackFuncs.EndUpdate;\r\n  end;\r\nend;\r\n\r\nprocedure TMainForm.LoadTrackThreadFunctions(ThData: PThreadData; ThreadNode: PVirtualNode);\r\nvar\r\n  Data: PLinkData;\r\n\r\n  TrackFuncInfoPair: TTrackFuncInfoPair;\r\n  TrackUnitInfoPair: TTrackUnitInfoPair;\r\n\r\n  UnitInfo: TUnitInfo;\r\n\r\n  BaseNode: PVirtualNode;\r\n  UnitNode: PVirtualNode;\r\n  Node: PVirtualNode;\r\nbegin\r\n  vstTrackFuncs.Clear;\r\n  vstTrackFuncParent.Clear;\r\n  vstTrackFuncChilds.Clear;\r\n\r\n  vstTrackFuncs.BeginUpdate;\r\n  try\r\n    BaseNode := vstTrackFuncs.AddChild(nil);\r\n    Data := vstTrackFuncs.GetNodeData(BaseNode);\r\n    Data^.ThreadData := ThData;\r\n    Data^.SyncNode := ThreadNode;\r\n    Data^.LinkType := ltThread;\r\n\r\n    ThData^.DbgTrackUnitList.LockForRead;\r\n    for TrackUnitInfoPair in ThData^.DbgTrackUnitList do\r\n    begin\r\n      UnitInfo := TUnitInfo(TrackUnitInfoPair.Value.UnitInfo);\r\n      if UnitInfo = nil then Continue;\r\n\r\n      UnitNode := vstTrackFuncs.AddChild(BaseNode);\r\n      Data := vstTrackFuncs.GetNodeData(UnitNode);\r\n\r\n      Data^.SyncNode := ThreadNode;\r\n      Data^.TrackUnitInfo := TrackUnitInfoPair.Value;\r\n      Data^.LinkType := ltTrackUnitInfo;\r\n\r\n      TrackUnitInfoPair.Value.FuncInfoList.LockForRead;\r\n      for TrackFuncInfoPair in TrackUnitInfoPair.Value.FuncInfoList do\r\n      begin\r\n        Node := vstTrackFuncs.AddChild(UnitNode);\r\n        Data := vstTrackFuncs.GetNodeData(Node);\r\n\r\n        Data^.SyncNode := ThreadNode;\r\n        Data^.TrackFuncInfo := TrackFuncInfoPair.Value;\r\n        Data^.LinkType := ltTrackFuncInfo;\r\n      end;\r\n      TrackUnitInfoPair.Value.FuncInfoList.UnLockForRead;\r\n\r\n      vstTrackFuncs.Expanded[UnitNode] := True;\r\n    end;\r\n    ThData^.DbgTrackUnitList.UnLockForRead;\r\n\r\n    vstTrackFuncs.Expanded[BaseNode] := True;\r\n  finally\r\n    vstTrackFuncs.EndUpdate;\r\n  end;\r\nend;\r\n\r\nprocedure TMainForm.LoadTypes(UnitInfo: TUnitInfo; UnitNode: PVirtualNode);\r\nvar\r\n  I, J: Integer;\r\n  BaseNode: PVirtualNode;\r\n\r\n  T: TTypeInfo;\r\n  Node: PVirtualNode;\r\n  Data: PLinkData;\r\n\r\n  ChildNode: PVirtualNode;\r\n  ChildData: PLinkData;\r\n  Member: TStructMember;\r\nbegin\r\n  vstDbgInfoTypes.Clear;\r\n\r\n  if UnitInfo.Types.Count = 0 then Exit;\r\n\r\n  vstDbgInfoTypes.BeginUpdate;\r\n  try\r\n    BaseNode := vstDbgInfoTypes.AddChild(nil);\r\n    Data := vstDbgInfoTypes.GetNodeData(BaseNode);\r\n\r\n    Data^.SyncNode := UnitNode;\r\n    Data^.DbgUnitInfo := UnitInfo;\r\n    Data^.LinkType := ltDbgUnitInfo;\r\n\r\n    for I := 0 to UnitInfo.Types.Count - 1 do\r\n    begin\r\n      T := TTypeInfo(UnitInfo.Types[I]);\r\n\r\n      Node := vstDbgInfoTypes.AddChild(BaseNode);\r\n      Data := vstDbgInfoTypes.GetNodeData(Node);\r\n\r\n      Data^.SyncNode := UnitNode;\r\n      Data^.DbgTypeInfo := T;\r\n      Data^.LinkType := ltDbgTypeInfo;\r\n\r\n      if Assigned(T.Members) then\r\n      begin\r\n        for J := 0 to T.Members.Count - 1 do\r\n        begin\r\n          Member := TStructMember(T.Members[J]);\r\n\r\n          ChildNode := vstDbgInfoTypes.AddChild(Node);\r\n          ChildData := vstDbgInfoTypes.GetNodeData(ChildNode);\r\n\r\n          ChildData^.SyncNode := UnitNode;\r\n          ChildData^.DbgStructMemberInfo := Member;\r\n          ChildData^.LinkType := ltDbgStructMemberInfo;\r\n        end;\r\n      end;\r\n    end;\r\n\r\n    vstDbgInfoTypes.Expanded[BaseNode] := True;\r\n  finally\r\n    vstDbgInfoTypes.EndUpdate;\r\n  end;\r\nend;\r\n\r\nprocedure TMainForm.LoadUnits;\r\nvar\r\n  I: Integer;\r\n  UnitGroupType: TUnitType;\r\n  UnitGroupNodes: array[Low(TUnitType)..High(TUnitType)] of PVirtualNode;\r\n  UnitNode: PVirtualNode;\r\n  UnitGroupNode: PVirtualNode;\r\n  LinkData: PLinkData;\r\n  UnitInfo: TUnitInfo;\r\nbegin\r\n  vstDbgInfoUnits.Clear;\r\n\r\n  vstDbgInfoUnits.BeginUpdate;\r\n  try\r\n    for UnitGroupType := Low(TUnitType) to High(TUnitType) do\r\n    begin\r\n      UnitGroupNode := vstDbgInfoUnits.AddChild(nil);\r\n      UnitGroupNode.CheckType := ctTriStateCheckBox;\r\n\r\n      LinkData := vstDbgInfoUnits.GetNodeData(UnitGroupNode);\r\n      LinkData^.DbgUnitGroupType := UnitGroupType;\r\n      LinkData^.LinkType := ltDbgUnitGroup;\r\n\r\n      UnitGroupNodes[UnitGroupType] := UnitGroupNode;\r\n    end;\r\n\r\n    for I := 0 to gvDebugInfo.Units.Count - 1 do\r\n    begin\r\n      UnitInfo := TUnitInfo(gvDebugInfo.Units.Objects[I]);\r\n\r\n      UnitGroupNode := UnitGroupNodes[UnitInfo.UnitType];\r\n\r\n      UnitNode := vstDbgInfoUnits.AddChild(UnitGroupNode);\r\n      UnitNode.CheckType := ctTriStateCheckBox;\r\n\r\n      LinkData := vstDbgInfoUnits.GetNodeData(UnitNode);\r\n\r\n      LinkData^.DbgUnitInfo := UnitInfo;\r\n      LinkData^.LinkType := ltDbgUnitInfo;\r\n    end;\r\n\r\n    for UnitGroupType := Low(TUnitType) to High(TUnitType) do\r\n    begin\r\n      vstDbgInfoUnits.Expanded[UnitGroupNodes[UnitGroupType]] := True;\r\n    end;\r\n  finally\r\n    vstDbgInfoUnits.EndUpdate;\r\n  end;\r\nend;\r\n\r\nprocedure TMainForm.LoadUnitSource(UnitInfo: TUnitInfo; UnitNode: PVirtualNode);\r\nbegin\r\n  svfDbgInfoUnitSource.SourceFileName := UnitInfo.FullUnitName;\r\nend;\r\n\r\nprocedure TMainForm.FillUpdateInfo(Sender: TObject);\r\nvar\r\n  AllVersions: TStringList;\r\n  I, J: Integer;\r\n  Ver: String;\r\n  Info: TChangeLogVersionInfo;\r\n  Data: PLinkData;\r\n  RootNode: PVirtualNode;\r\n  VerNode: PVirtualNode;\r\n  ItemNode: PVirtualNode;\r\nbegin\r\n  vstUpdateInfo.Clear;\r\n\r\n  if gvUpdateInfo.LastVersion = gvUpdateInfo.CurrentVersion then Exit;\r\n\r\n  AllVersions := TStringList.Create;\r\n  try\r\n    if gvUpdateInfo.GetAllVersions(AllVersions) then\r\n    begin\r\n      vstUpdateInfo.BeginUpdate;\r\n      try\r\n        RootNode := vstUpdateInfo.AddChild(nil);\r\n        Data := vstUpdateInfo.GetNodeData(RootNode);\r\n\r\n        Data^.LinkType := ltSpiderInfo;\r\n\r\n        for I := 0 to AllVersions.Count - 1 do\r\n        begin\r\n          Ver := AllVersions[I];\r\n\r\n          Info := TChangeLogVersionInfo.Create(False);\r\n          if gvUpdateInfo.GetVersionInfo(Ver, Info) then\r\n          begin\r\n            VerNode := vstUpdateInfo.AddChild(RootNode);\r\n            Data := vstUpdateInfo.GetNodeData(VerNode);\r\n\r\n            Data^.LinkType := ltVersionInfo;\r\n            Data^.VersionInfo := Info;\r\n\r\n            for J := 0 to Info.Count - 1 do\r\n            begin\r\n              ItemNode := vstUpdateInfo.AddChild(VerNode);\r\n              Data := vstUpdateInfo.GetNodeData(ItemNode);\r\n\r\n              Data^.LinkType := ltChangeLogItemInfo;\r\n              Data^.ChangeLogItem := Info[J];\r\n            end;\r\n\r\n            vstUpdateInfo.Expanded[VerNode] := True;\r\n          end;\r\n        end;\r\n\r\n        vstUpdateInfo.Expanded[RootNode] := True;\r\n      finally\r\n        vstUpdateInfo.EndUpdate;\r\n      end;\r\n\r\n      acTabUpdateInfo.Caption := Format('New version: %s', [gvUpdateInfo.LastVersion]);\r\n      acTabUpdateInfo.Visible := True;\r\n    end;\r\n  finally\r\n    FreeAndNil(AllVersions);\r\n  end;\r\nend;\r\n\r\nprocedure TMainForm.LoadUpdateInfo;\r\n\r\nvar\r\n  Th: TThread;\r\nbegin\r\n  Th := TThread.CreateAnonymousThread(\r\n    procedure\r\n    begin\r\n      TThread.NameThreadForDebugging('TMainForm.LoadUpdateInfo');\r\n\r\n      CoInitializeEx(nil, COINIT_MULTITHREADED);\r\n      try\r\n        gvUpdateInfo.Load;\r\n      finally\r\n        CoUninitialize;\r\n      end;\r\n    end\r\n  );\r\n  Th.OnTerminate := FillUpdateInfo;\r\n  Th.Start;\r\nend;\r\n\r\nprocedure TMainForm.LoadVars(UnitInfo: TUnitInfo; UnitNode: PVirtualNode);\r\nvar\r\n  I: Integer;\r\n  V: TVarInfo;\r\n  BaseNode: PVirtualNode;\r\n  Node: PVirtualNode;\r\n  Data: PLinkData;\r\nbegin\r\n  vstDbgInfoVars.Clear;\r\n\r\n  if UnitInfo.Vars.Count = 0 then Exit;\r\n\r\n  vstDbgInfoVars.BeginUpdate;\r\n  try\r\n    BaseNode := vstDbgInfoVars.AddChild(nil);\r\n    Data := vstDbgInfoVars.GetNodeData(BaseNode);\r\n\r\n    Data^.SyncNode := UnitNode;\r\n    Data^.DbgUnitInfo := UnitInfo;\r\n    Data^.LinkType := ltDbgUnitInfo;\r\n\r\n    for I := 0 to UnitInfo.Vars.Count - 1 do\r\n    begin\r\n      V := TVarInfo(UnitInfo.Vars[I]);\r\n\r\n      Node := vstDbgInfoVars.AddChild(BaseNode);\r\n      Data := vstDbgInfoVars.GetNodeData(Node);\r\n\r\n      Data^.SyncNode := UnitNode;\r\n      Data^.DbgVarInfo := V;\r\n      Data^.LinkType := ltDbgVarInfo;\r\n    end;\r\n\r\n    vstDbgInfoVars.Expanded[BaseNode] := True;\r\n  finally\r\n    vstDbgInfoVars.EndUpdate;\r\n  end;\r\nend;\r\n\r\nfunction TMainForm.ProcessIDToStr(const ProcessID: TProcessId): String;\r\nbegin\r\n  Result := Format('%d(%x)', [ProcessID, ProcessID]);\r\nend;\r\n\r\nprocedure TMainForm.ProgressAction(const Action: String; const Progress: Integer);\r\nbegin\r\n  pbProgress.Visible := (Progress > 0);\r\n\r\n  if pbProgress.Position <> Progress then\r\n    pbProgress.Position := Progress;\r\n\r\n  if Action <> '' then\r\n    lbStatusAction.Caption := Action\r\n  else\r\n    lbStatusAction.Caption := '';\r\nend;\r\n\r\nprocedure TMainForm.pTrackFuncAdvResize(Sender: TObject);\r\nbegin\r\n  vstTrackFuncParent.Height := pTrackFuncAdv.ClientHeight div 2;\r\nend;\r\n\r\nvar\r\n  _AppID: String = '';\r\n\r\nfunction TMainForm.GetAppID: String;\r\nconst\r\n  _RegKey = 'Software\\Spider\\';\r\n  _RegAppID = 'AppID';\r\nvar\r\n  Reg: TRegistry;\r\nbegin\r\n  Result := _AppID;\r\n\r\n  if Result <> '' then Exit;\r\n\r\n  Reg := TRegistry.Create;\r\n  try\r\n    Reg.RootKey := HKEY_CURRENT_USER;\r\n    if Reg.OpenKey(_RegKey, not Reg.KeyExists(_RegKey)) then\r\n    try\r\n      _AppID := Reg.GetDataAsString(_RegAppID);\r\n      if _AppID = '' then\r\n      begin\r\n        _AppID := GetGUID;\r\n        Reg.WriteString(_RegAppID, _AppID);\r\n      end;\r\n    finally\r\n      Reg.CloseKey;\r\n    end\r\n    else\r\n      _AppID := GetGUID;\r\n  finally\r\n    FreeAndNil(Reg);\r\n  end;\r\n\r\n  Result := _AppID;\r\nend;\r\n\r\nprocedure TMainForm.SendGAEvent(const Category, Action, ELabel: String);\r\nvar\r\n  GA: TGA;\r\nbegin\r\n  GA := TGA.Create;\r\n  try\r\n    GA.TrackingID := _TrackingID_app;\r\n    GA.AppName := _AppName;\r\n    GA.ClientID := GetAppID;\r\n    GA.AppVersion := GetFileVersion(Application.ExeName);\r\n\r\n    GA.SendEvent(Category, Action, ELabel);\r\n  finally\r\n    FreeAndNil(GA);\r\n  end;\r\nend;\r\n\r\nprocedure TMainForm.SendGAException(E: Exception);\r\nvar\r\n  StackTrace: String;\r\n  Msg: String;\r\nbegin\r\n  if Assigned(E) then\r\n  begin\r\n    Msg := E.Message;\r\n\r\n    StackTrace := E.StackTrace;\r\n    if StackTrace <> '' then\r\n      Msg := Msg + Format(' [%s]', [StackTrace]);\r\n\r\n    _AC.Log(dltError, '%s: %s', [E.ClassName, Msg]);\r\n\r\n    SendGAEvent('Exception', E.ClassName, Msg);\r\n  end;\r\nend;\r\n\r\nprocedure TMainForm.SendGAFeedback(const FeedbackType, FeedbackText: String);\r\nvar\r\n  GA: TGA;\r\nbegin\r\n  GA := TGA.Create;\r\n  try\r\n    GA.TrackingID := _TrackingID_app;\r\n    GA.AppName := _AppName;\r\n    GA.ClientID := GetAppID;\r\n    GA.AppVersion := GetFileVersion(Application.ExeName);\r\n\r\n    GA.SendEvent(FeedbackType, FeedbackText, GetAppID);\r\n  finally\r\n    FreeAndNil(GA);\r\n  end;\r\nend;\r\n\r\nprocedure TMainForm.SetProjectName(const ProjectName: String);\r\nvar\r\n  Ext: String;\r\nbegin\r\n  if AnsiSameText(gvProjectOptions.ProjectName, ProjectName) then\r\n    Exit;\r\n\r\n  ClearProject;\r\n\r\n  Ext := ExtractFileExt(ProjectName);\r\n  if AnsiSameText(Ext, '.spider') then\r\n    FProjectType := ptSpider\r\n  else\r\n  if AnsiSameText(Ext, '.exe') then\r\n    FProjectType := ptApplication\r\n  else\r\n  if AnsiSameText(Ext, '.map') then\r\n    FProjectType := ptDebugInfo\r\n  else\r\n    Exit;\r\n\r\n  rbnMain.Caption := ProjectName;\r\n  InitLog(ProjectName);\r\n\r\n  case FProjectType of\r\n    ptSpider:\r\n        gvProjectOptions.Open(ProjectName);\r\n    ptApplication:\r\n      begin\r\n        gvProjectOptions.Open(ChangeFileExt(ProjectName, '.spider'));\r\n        gvProjectOptions.ApplicationName := ProjectName;\r\n        gvProjectOptions.ProjectSource := TProjectOptions.GetDefProjectSource(ProjectName);\r\n        gvProjectOptions.DelphiSource := TProjectOptions.GetDefDelphiSource;\r\n      end;\r\n    ptDebugInfo:\r\n      begin\r\n        gvProjectOptions.Open(ChangeFileExt(ProjectName, '.spider'));\r\n        gvProjectOptions.ApplicationName := ChangeFileExt(ProjectName, '.exe');\r\n        if not FileExists(gvProjectOptions.ApplicationName) then\r\n          gvProjectOptions.ApplicationName := ProjectName;\r\n        gvProjectOptions.ProjectSource := TProjectOptions.GetDefProjectSource(ProjectName);\r\n        gvProjectOptions.DelphiSource := TProjectOptions.GetDefDelphiSource;\r\n      end;\r\n  end;\r\n\r\n  _AC.RunDebug([doDebugInfo]);\r\n\r\n  UpdateMainActions;\r\nend;\r\n\r\nprocedure TMainForm.StartGASession;\r\nvar\r\n  GA: TGA;\r\nbegin\r\n  GA := TGA.Create;\r\n  try\r\n    GA.TrackingID := _TrackingID_app;\r\n    GA.AppName := _AppName;\r\n    GA.ClientID := GetAppID;\r\n    GA.AppVersion := GetFileVersion(Application.ExeName);\r\n\r\n    GA.SessionStart;\r\n  finally\r\n    FreeAndNil(GA);\r\n  end;\r\nend;\r\n\r\nprocedure TMainForm.SyncNodes(Tree: TBaseVirtualTree; Node: PVirtualNode);\r\nvar\r\n  Data: PLinkData;\r\n  OtherTree: TBaseVirtualTree;\r\nbegin\r\n  if (Tree = Nil) or (Node = Nil) then\r\n    Exit;\r\n\r\n  Data := Tree.GetNodeData(Node);\r\n  if Tree = vstThreads then\r\n    OtherTree := vdtTimeLine\r\n  else\r\n    OtherTree := vstThreads;\r\n\r\n  OtherTree.Expanded[Data.SyncNode] := Tree.Expanded[Node];\r\n  OtherTree.Selected[Data.SyncNode] := Tree.Selected[Node];\r\n\r\n  if Tree.FocusedNode = Node then\r\n    OtherTree.FocusedNode := Data.SyncNode;\r\nend;\r\n\r\nfunction TMainForm.ThreadIDToStr(const ThreadID: TThreadId): String;\r\nbegin\r\n  Result := Format('%d(%x)', [ThreadID, ThreadID]);\r\nend;\r\n\r\nprocedure TMainForm.tmrThreadsUpdateTimer(Sender: TObject);\r\nbegin\r\n  UpdateDebugActions;\r\n  UpdateStatusInfo;\r\n  UpdateTrees;\r\n\r\n  tmrThreadsUpdate.Enabled := (gvDebugInfo <> nil) and (gvDebuger <> nil) and gvDebuger.Active;\r\nend;\r\n\r\nprocedure TMainForm.UpdateMainActions;\r\nbegin\r\n  if FProjectType = ptEmpty then\r\n  begin\r\n    acRun.Enabled := False;\r\n    acStop.Enabled := False;\r\n    acRunStop.Enabled := False;\r\n    acPause.Enabled := False;\r\n\r\n    acCloseProject.Enabled := False;\r\n    acEditProject.Enabled := False;\r\n    acSave.Enabled := False;\r\n    acSaveCopy.Enabled := False;\r\n  end\r\n  else\r\n  begin\r\n    acCloseProject.Enabled := True;\r\n    acSave.Enabled := True;\r\n    acSaveCopy.Enabled := True;\r\n    acEditProject.Enabled := True;\r\n  end;\r\nend;\r\n\r\nprocedure TMainForm.UpdateProjectOptions;\r\nbegin\r\n  if Assigned(gvDebugInfo) then\r\n  begin\r\n    gvDebugInfo.UpdateSourceDirs(utSystem, gvProjectOptions.DelphiSource);\r\n    gvDebugInfo.UpdateSourceDirs(utProject, gvProjectOptions.ProjectSource);\r\n  end;\r\nend;\r\n\r\nprocedure TMainForm.UpdateDebugActions;\r\nvar\r\n  DebugInfoLoaded: LongBool;\r\n  DebugerStoped: LongBool;\r\n  DebugePaused: LongBool;\r\nbegin\r\n  DebugInfoLoaded := Assigned(gvDebugInfo) and gvDebugInfo.DebugInfoLoaded;\r\n  DebugerStoped := (gvDebuger = Nil) or not gvDebuger.Active;\r\n\r\n  acRun.Enabled := DebugInfoLoaded and DebugerStoped;\r\n  acStop.Enabled := not DebugerStoped;\r\n\r\n  if acRun.Enabled then\r\n    acRunStop.Assign(acRun)\r\n  else\r\n  if acStop.Enabled then\r\n    acRunStop.Assign(acStop)\r\n  else\r\n  begin\r\n    acRunStop.Assign(acPause);\r\n    acRunStop.Enabled := False;\r\n  end;\r\n\r\n  DebugePaused := Assigned(gvDebuger) and (gvDebuger.DbgTraceState = dtsPause);\r\n  acPause.Enabled := acStop.Enabled and not(DebugePaused);\r\n  acContinue.Enabled := DebugePaused;\r\n\r\n  if acPause.Enabled then\r\n    acPauseContinue.Assign(acPause)\r\n  else\r\n  if acContinue.Enabled then\r\n    acPauseContinue.Assign(acContinue)\r\n  else\r\n  begin\r\n    acPauseContinue.Assign(acPause);\r\n    acPauseContinue.Enabled := False;\r\n  end;\r\n\r\n  acStepInto.Enabled := acContinue.Enabled;\r\n  acStepOver.Enabled := acContinue.Enabled;\r\n  acStepOut.Enabled := acContinue.Enabled;\r\nend;\r\n\r\nprocedure TMainForm.UpdateLog;\r\nvar\r\n  CurCount: Integer;\r\n  LogCount: Integer;\r\n  I: Integer;\r\n  Node: PVirtualNode;\r\n  Data: PLinkData;\r\nbegin\r\n  if gvDebugInfo = nil then Exit;\r\n\r\n  if vstLog.RootNode.FirstChild = nil then\r\n    InitLog(gvProjectOptions.ApplicationName);\r\n\r\n  CurCount := vstLog.RootNode.FirstChild.ChildCount;\r\n\r\n  gvDebugInfo.DbgLog.Lock.BeginRead;\r\n  try\r\n    LogCount := gvDebugInfo.DbgLog.Count;\r\n    if CurCount <> LogCount then\r\n    begin\r\n      vstLog.BeginUpdate;\r\n      try\r\n        for I := CurCount to LogCount - 1 do\r\n        begin\r\n          Node := vstLog.AddChild(vstLog.RootNode.FirstChild);\r\n          Data := vstLog.GetNodeData(Node);\r\n\r\n          Data^.DbgLogItemIdx := I;\r\n          Data^.LinkType := ltDbgLogItem;\r\n        end;\r\n\r\n        vstLog.Expanded[vstLog.RootNode.FirstChild] := True;\r\n      finally\r\n        vstLog.EndUpdate;\r\n      end;\r\n    end;\r\n  finally\r\n    gvDebugInfo.DbgLog.Lock.EndRead;\r\n  end;\r\nend;\r\n\r\nprocedure TMainForm.UpdateStatusInfo;\r\nvar\r\n  Msg: String;\r\nbegin\r\n  if Assigned(gvDebuger) then\r\n  begin\r\n    if Assigned(gvDebugInfo) and (gvDebugInfo.DebugInfoLoaded) then\r\n      lbStatusDbgInfoValue.Caption := gvDebugInfo.DebugInfoType\r\n    else\r\n      lbStatusDbgInfoValue.Caption := 'Not found';\r\n\r\n    case gvDebuger.DbgState of\r\n      dsNone: Msg := 'none';\r\n      dsStarted: Msg := 'Started';\r\n      dsWait: Msg := 'Active';\r\n      dsPerfomance: Msg := 'Active';\r\n      dsTrace: Msg := 'Trace';\r\n      dsEvent: Msg := 'Active';\r\n      dsPause: Msg := 'Pause';\r\n      dsStoping: Msg := 'Stoping';\r\n      dsStoped: Msg := 'Stoped';\r\n      dsDbgFail: Msg := 'Debug Fail';\r\n    else\r\n      Msg := '';\r\n    end;\r\n    lbStatusDbgStateValue.Caption := Msg;\r\n\r\n    if gvDebuger.PerfomanceMode and not(gvDebuger.DbgState in [dsNone]) and Assigned(gvDebuger.ProcessData.DbgPoints) then\r\n      lbStatusEventsCntValue.Caption := IntToStr(gvDebuger.ProcessData.DbgPoints.Count)\r\n    else\r\n      lbStatusEventsCntValue.Caption := '0';\r\n\r\n    if gvDebuger.SamplingMethod then\r\n      lbStatusTrackEventCntValue.Caption := IntToStr(gvDebuger.ProcessData.SamplingCount)\r\n    else\r\n      lbStatusTrackEventCntValue.Caption := IntToStr(gvDebuger.ProcessData.DbgTrackEventCount);\r\n  end\r\n  else\r\n  begin\r\n    lbStatusDbgInfoValue.Caption := 'None';\r\n    lbStatusDbgStateValue.Caption := 'None';\r\n    lbStatusEventsCntValue.Caption := '0';\r\n    lbStatusTrackEventCntValue.Caption := '0';\r\n  end;\r\nend;\r\n\r\nprocedure TMainForm.UpdateTrackHistoryList;\r\nvar\r\n  I: Integer;\r\n  Action: TContainedAction;\r\n  TrackFuncInfo: TTrackFuncInfo;\r\n  F: LongBool;\r\nbegin\r\n  F := False;\r\n  for I := 0 to alCodeTrackHistory.ActionCount - 1 do\r\n  begin\r\n    Action := alCodeTrackHistory.Actions[I];\r\n    if I < FTrackHistory.Count then\r\n    begin\r\n      TrackFuncInfo := TTrackFuncInfo(FTrackHistory[I]);\r\n\r\n      TAction(Action).Caption := TFuncInfo(TrackFuncInfo.FuncInfo).ShortName;\r\n      TAction(Action).Tag := NativeInt(TrackFuncInfo);\r\n\r\n      TAction(Action).Enabled := True;\r\n      TAction(Action).Visible := True;\r\n\r\n      F := True;\r\n    end\r\n    else\r\n    begin\r\n      TAction(Action).Enabled := False;\r\n      TAction(Action).Visible := False;\r\n    end;\r\n  end;\r\n\r\n  acCodeTrackHistoryBack.Enabled := F;\r\nend;\r\n\r\nprocedure TMainForm.UpdateTrees;\r\nbegin\r\n  case pcMain.ActivePageIndex of\r\n    0: begin\r\n      UpdateLog;\r\n    end;\r\n    1: begin\r\n      vstDbgInfoUnits.Invalidate;\r\n      vstDbgInfoConsts.Invalidate;\r\n      vstDbgInfoTypes.Invalidate;\r\n      vstDbgInfoVars.Invalidate;\r\n      vstDbgInfoFunctions.Invalidate;\r\n      vstDbgInfoFuncVars.Invalidate;\r\n    end;\r\n    2: begin\r\n      vstThreads.Invalidate;\r\n      vdtTimeLine.Invalidate;\r\n      vdtTimeLine.Header.Invalidate(nil);\r\n    end;\r\n    3: begin\r\n      vstMemInfoThreads.Invalidate;\r\n      vstMemList.Invalidate;\r\n      vstMemStack.Invalidate;\r\n\r\n      vstMemInfoFuncTree.Invalidate;\r\n      vstMemInfoObjects.Invalidate;\r\n      vstMemInfoFuncParents.Invalidate;\r\n      vstMemInfoFuncChilds.Invalidate;\r\n    end;\r\n    4: begin\r\n      vstExceptionThreads.Invalidate;\r\n      vstExceptionList.Invalidate;\r\n      vstExceptionCallStack.Invalidate;\r\n    end;\r\n    5: begin\r\n      vstTrackThreads.Invalidate;\r\n      vstTrackFuncs.Invalidate;\r\n      vstTrackFuncParent.Invalidate;\r\n      vstTrackFuncChilds.Invalidate;\r\n\r\n      // UpdateTrackHistoryList; ???\r\n    end;\r\n    6: begin\r\n      vstLockThreads.Invalidate;\r\n      vstLockTrackingList.Invalidate;\r\n      vstLockTrackingParents.Invalidate;\r\n      vstLockTrackingChilds.Invalidate;\r\n      vstLockTrackingSyncObjs.Invalidate;\r\n    end;\r\n  end;\r\nend;\r\n\r\nprocedure TMainForm.vdtTimeLineAdvancedHeaderDraw(Sender: TVTHeader;\r\n  var PaintInfo: THeaderPaintInfo; const Elements: THeaderPaintElements);\r\nbegin\r\n  if (PaintInfo.Column <> Nil) and (PaintInfo.Column.Index = 0)then\r\n    DrawTimeLineHeaderEx(PaintInfo.TargetCanvas.ToGPGraphics, PaintInfo.PaintRectangle, GetLineTimeOffset);\r\nend;\r\n\r\nprocedure TMainForm.vdtTimeLineChange(Sender: TBaseVirtualTree; Node: PVirtualNode);\r\nbegin\r\n  SyncNodes(Sender, Node);\r\nend;\r\n\r\nprocedure TMainForm.vdtTimeLineDrawNode(Sender: TBaseVirtualTree; const PaintInfo: TVTPaintInfo);\r\nvar\r\n  GP: IGPGraphics;\r\n  LinkData: PLinkData;\r\n  R: TRect;\r\nbegin\r\n  GP := PaintInfo.Canvas.ToGPGraphics;\r\n\r\n  R := PaintInfo.CellRect;\r\n  R.Width := vdtTimeLine.ClientWidth;\r\n\r\n  DrawBackgroundEx(GP, R, PaintInfo.Canvas.Brush.Color);\r\n\r\n  LinkData := Sender.GetNodeData(PaintInfo.Node);\r\n  case LinkData^.LinkType of\r\n    ltProcess:\r\n    begin\r\n      if acCPUTimeLine.Checked then\r\n        DrawProcessCPUTimeLine(GP, R, LinkData^.ProcessData, GetLineTimeOffset)\r\n      else\r\n        DrawProcessTimeLine(GP, R, LinkData^.ProcessData, GetLineTimeOffset);\r\n    end;\r\n    ltThread:\r\n    begin\r\n      if acCPUTimeLine.Checked then\r\n        DrawThreadCPUTimeLine(GP, R, LinkData^.ThreadData, GetLineTimeOffset)\r\n      else\r\n        DrawThreadTimeLine(GP, R, LinkData^.ThreadData, GetLineTimeOffset);\r\n    end;\r\n  end;\r\nend;\r\n\r\nprocedure TMainForm.vdtTimeLineHeaderDrawQueryElements(Sender: TVTHeader;\r\n  var PaintInfo: THeaderPaintInfo; var Elements: THeaderPaintElements);\r\nbegin\r\n  Include(Elements, hpeText);\r\nend;\r\n\r\nprocedure TMainForm.vdtTimeLinePaintBackground(Sender: TBaseVirtualTree; TargetCanvas: TCanvas; R: TRect; var Handled: Boolean);\r\nbegin\r\n  R.Width := vdtTimeLine.ClientWidth;\r\n\r\n  DrawBackgroundEx(TargetCanvas.ToGPGraphics, R, vdtTimeLine.Canvas.Brush.Color);\r\n\r\n  Handled := True;\r\nend;\r\n\r\nprocedure TMainForm.vdtTimeLineScroll(Sender: TBaseVirtualTree; DeltaX, DeltaY: Integer);\r\nbegin\r\n  if DeltaY <> 0 then\r\n    vstThreads.OffsetY := vdtTimeLine.OffsetY;\r\n\r\n  if DeltaX <> 0 then\r\n    vdtTimeLine.Invalidate;\r\nend;\r\n\r\nprocedure TMainForm.ViewDebugInfo(DebugInfo: TDebugInfo);\r\nbegin\r\n  gvDebugInfo := DebugInfo;\r\n\r\n  LoadUnits;\r\nend;\r\n\r\nprocedure TMainForm.vstLockTrackingSyncObjStackCompareNodes(\r\n  Sender: TBaseVirtualTree; Node1, Node2: PVirtualNode; Column: TColumnIndex;\r\n  var Result: Integer);\r\nvar\r\n  Data1, Data2: PLinkData;\r\n  Name1, Name2: String;\r\n  ValueU1, ValueU2: UInt64;\r\nbegin\r\n  Data1 := vstLockTrackingSyncObjStack.GetNodeData(Node1);\r\n  Data2 := vstLockTrackingSyncObjStack.GetNodeData(Node2);\r\n\r\n  case Column of\r\n    0:\r\n      begin\r\n        Name1 := '';\r\n        Name2 := '';\r\n\r\n        if (Data1^.LinkType = ltSyncObjInfo) and (Data2^.LinkType = ltSyncObjInfo) then\r\n        begin\r\n          Name1 := CDbgSyncObjsType[Data1^.SyncObjItem^.SyncObjsInfo.SyncObjsType];\r\n          Name2 := CDbgSyncObjsType[Data2^.SyncObjItem^.SyncObjsInfo.SyncObjsType];\r\n        end\r\n        else\r\n        if (Data1^.LinkType = ltSyncObjChildInfo) and (Data2^.LinkType = ltSyncObjChildInfo) then\r\n        begin\r\n          if (Data1^.SyncObjItem^.SyncObjsInfo.SyncObjsType = soInCriticalSection)\r\n            and (Data1^.SyncObjItem^.SyncObjsInfo.SyncObjsStateType = sosLeave) then\r\n            Name1 := 'Leave';\r\n          if (Data2^.SyncObjItem^.SyncObjsInfo.SyncObjsType = soInCriticalSection)\r\n            and (Data2^.SyncObjItem^.SyncObjsInfo.SyncObjsStateType = sosLeave) then\r\n            Name2 := 'Leave';\r\n        end;\r\n\r\n        Result := CompareText(Name1, Name2);\r\n      end;\r\n    1:\r\n      begin\r\n        ValueU1 := 0;\r\n        ValueU2 := 0;\r\n\r\n        if (Data1^.LinkType = ltSyncObjInfo) and (Data2^.LinkType = ltSyncObjInfo) then\r\n        begin\r\n          if Data1^.SyncObjItem^.SyncObjsInfo.SyncObjsType = soEnterCriticalSection then\r\n            ValueU1 := Data1^.SyncObjItem^.SyncObjsInfo.OwningThreadId;\r\n          if Data2^.SyncObjItem^.SyncObjsInfo.SyncObjsType = soEnterCriticalSection then\r\n            ValueU2 := Data2^.SyncObjItem^.SyncObjsInfo.OwningThreadId;\r\n        end;\r\n\r\n        Result := Compare(ValueU1, ValueU2);\r\n      end;\r\n    2:\r\n      begin\r\n        ValueU1 := 0;\r\n        ValueU2 := 0;\r\n\r\n        if (Data1^.LinkType = ltSyncObjInfo) and (Data2^.LinkType = ltSyncObjInfo) then\r\n        begin\r\n          if Data1^.SyncObjItem^.SyncObjsInfo.SyncObjsType in [soWaitForSingleObject,\r\n            soWaitForMultipleObjects, soEnterCriticalSection, soSendMessage] then\r\n              ValueU1 := Data1^.SyncObjItem^.WaitTime;\r\n          if Data2^.SyncObjItem^.SyncObjsInfo.SyncObjsType in [soWaitForSingleObject,\r\n            soWaitForMultipleObjects, soEnterCriticalSection, soSendMessage] then\r\n              ValueU2 := Data2^.SyncObjItem^.WaitTime;\r\n        end\r\n        else\r\n        if (Data1^.LinkType = ltSyncObjChildInfo) and (Data2^.LinkType = ltSyncObjChildInfo) then\r\n        begin\r\n          if Data1^.SyncObjItem^.SyncObjsInfo.SyncObjsType = soInCriticalSection then\r\n            ValueU1 := Data1^.SyncObjItem^.WaitTime;\r\n          if Data2^.SyncObjItem^.SyncObjsInfo.SyncObjsType = soInCriticalSection then\r\n            ValueU2 := Data2^.SyncObjItem^.WaitTime;\r\n        end;\r\n\r\n        Result := Compare(ValueU1, ValueU2);\r\n      end;\r\n  end;\r\nend;\r\n\r\nprocedure TMainForm.vstLockTrackingSyncObjStackDblClick(Sender: TObject);\r\nvar\r\n  Data: PLinkData;\r\n  StackEntry: TStackEntry;\r\nbegin\r\n  svfLockTrackingSource.Clear;\r\n\r\n  if vstLockTrackingSyncObjStack.FocusedNode = Nil then\r\n    Exit;\r\n\r\n  Data := vstLockTrackingSyncObjStack.GetNodeData(vstLockTrackingSyncObjStack.FocusedNode);\r\n  if Data^.LinkType = ltSyncObjStack then\r\n  begin\r\n    StackEntry := TStackEntry.Create;\r\n    try\r\n      if StackEntry.UpdateInfo(Data^.SyncObjStackPtr) <> slNotFound then\r\n      begin\r\n        if Assigned(StackEntry.FuncInfo) then\r\n        begin\r\n          if Assigned(StackEntry.LineInfo) then\r\n            LoadFunctionSource(svfLockTrackingSource, StackEntry.FuncInfo, StackEntry.LineInfo.LineNo)\r\n          else\r\n            LoadFunctionSource(svfLockTrackingSource, StackEntry.FuncInfo);\r\n\r\n          pcLockTrackingLinks.ActivePageIndex := 1;\r\n        end;\r\n      end;\r\n    finally\r\n      FreeAndNil(StackEntry);\r\n    end;\r\n  end;\r\nend;\r\n\r\nprocedure TMainForm.vstLockTrackingSyncObjStackGetText(Sender: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex; TextType: TVSTTextType;\r\n  var CellText: string);\r\nvar\r\n  Data: PLinkData;\r\n  StackEntry: TStackEntry;\r\n  FindResult: TFindResult;\r\nbegin\r\n  CellText := ' ';\r\n\r\n  Data := Sender.GetNodeData(Node);\r\n  if Data^.LinkType = ltSyncObjStack then\r\n  begin\r\n      case Column of\r\n        0: CellText := Format('%p', [Data^.SyncObjStackPtr]);\r\n      else\r\n        begin\r\n          StackEntry := TStackEntry.Create;\r\n          try\r\n            FindResult := StackEntry.UpdateInfo(Data^.SyncObjStackPtr);\r\n            case Column of\r\n              1: if (FindResult <> slNotFound) and Assigned(StackEntry.UnitInfo) then\r\n                   CellText := StackEntry.UnitInfo.ShortName\r\n                 else\r\n                   CellText := 'unknown';\r\n              2: if (FindResult in [slFoundExact, slFoundNotExact]) and Assigned(StackEntry.LineInfo) then\r\n                   CellText := IntToStr(StackEntry.LineInfo.LineNo);\r\n              3: if (FindResult <> slNotFound) and Assigned(StackEntry.FuncInfo) then\r\n                   CellText := StackEntry.FuncInfo.ShortName\r\n                 else\r\n                   CellText := 'unknown';\r\n            end;\r\n          finally\r\n            FreeAndNil(StackEntry);\r\n          end;\r\n        end;\r\n      end;\r\n  end;\r\nend;\r\n\r\nprocedure TMainForm.vstLockTrackingSyncObjStackIncrementalSearch(\r\n  Sender: TBaseVirtualTree; Node: PVirtualNode; const SearchText: string;\r\n  var Result: Integer);\r\nvar\r\n  Data: PLinkData;\r\n  Name: String;\r\nbegin\r\n  Data := vstLockTrackingSyncObjStack.GetNodeData(Node);\r\n\r\n  Name := '';\r\n\r\n  if (Data^.LinkType = ltSyncObjInfo) then\r\n    Name := CDbgSyncObjsType[Data^.SyncObjItem^.SyncObjsInfo.SyncObjsType]\r\n  else\r\n  if (Data^.LinkType = ltSyncObjChildInfo) then\r\n    if (Data^.SyncObjItem^.SyncObjsInfo.SyncObjsType = soInCriticalSection)\r\n      and (Data^.SyncObjItem^.SyncObjsInfo.SyncObjsStateType = sosLeave) then\r\n      Name := 'Leave';\r\n\r\n  Result := AnsiStrLIComp(PChar(SearchText), PChar(Name), Min(Length(SearchText), Length(Name)));\r\nend;\r\n\r\nprocedure TMainForm.vstDbgInfoConstsCompareNodes(Sender: TBaseVirtualTree;\r\n  Node1, Node2: PVirtualNode; Column: TColumnIndex; var Result: Integer);\r\nvar\r\n  Data1, Data2: PLinkData;\r\n  Name1, Name2: String;\r\nbegin\r\n  Data1 := vstDbgInfoConsts.GetNodeData(Node1);\r\n  Data2 := vstDbgInfoConsts.GetNodeData(Node2);\r\n\r\n  Name1 := '';\r\n  Name2 := '';\r\n  case Column of\r\n    0:\r\n      begin\r\n        if (Data1^.LinkType = ltDbgConstInfo) and (Data2^.LinkType = ltDbgConstInfo) then\r\n        begin\r\n          Name1 := Data1^.DbgConstInfo.ShortName;\r\n          Name2 := Data2^.DbgConstInfo.ShortName;\r\n        end;\r\n\r\n        Result := CompareText(Name1, Name2);\r\n      end;\r\n    1:\r\n      begin\r\n        if (Data1^.LinkType = ltDbgConstInfo) and (Data2^.LinkType = ltDbgConstInfo) then\r\n        begin\r\n          Name1 := Data1^.DbgConstInfo.ValueAsString;\r\n          Name2 := Data2^.DbgConstInfo.ValueAsString;\r\n        end;\r\n\r\n        Result := CompareText(Name1, Name2);\r\n      end;\r\n    2:\r\n      begin\r\n        if (Data1^.LinkType = ltDbgConstInfo) and (Data2^.LinkType = ltDbgConstInfo) then\r\n        begin\r\n          Name1 := Data1^.DbgConstInfo.TypeInfo.ShortName;\r\n          Name2 := Data2^.DbgConstInfo.TypeInfo.ShortName;\r\n        end;\r\n\r\n        Result := CompareText(Name1, Name2);\r\n      end;\r\n  end;\r\nend;\r\n\r\nprocedure TMainForm.vstDbgInfoConstsGetText(Sender: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex; TextType: TVSTTextType; var CellText: string);\r\nvar\r\n  Data: PLinkData;\r\n  ConstInfo: TConstInfo;\r\n  UnitInfo: TUnitInfo;\r\nbegin\r\n  Data := vstDbgInfoConsts.GetNodeData(Node);\r\n  case Data^.LinkType of\r\n    ltDbgUnitInfo:\r\n      begin\r\n        UnitInfo := Data^.DbgUnitInfo;\r\n        case Column of\r\n          0: CellText := UnitInfo.ShortName;\r\n        else\r\n          CellText := ' ';\r\n        end;\r\n      end;\r\n    ltDbgConstInfo:\r\n      begin\r\n        ConstInfo := Data^.DbgConstInfo;\r\n\r\n        case Column of\r\n          0: CellText := ConstInfo.ShortName;\r\n          1: CellText := ConstInfo.ValueAsString;\r\n          2: CellText := String(ConstInfo.TypeInfo.ShortName);\r\n        end;\r\n      end;\r\n  end;\r\nend;\r\n\r\nprocedure TMainForm.vstDbgInfoConstsIncrementalSearch(Sender: TBaseVirtualTree;\r\n  Node: PVirtualNode; const SearchText: string; var Result: Integer);\r\nvar\r\n  Data: PLinkData;\r\n  Name: String;\r\nbegin\r\n  Data := vstDbgInfoConsts.GetNodeData(Node);\r\n\r\n  Name := '';\r\n  if (Data^.LinkType = ltDbgConstInfo) then\r\n    Name := Data^.DbgConstInfo.ShortName;\r\n\r\n  Result := AnsiStrLIComp(PChar(SearchText), PChar(Name), Min(Length(SearchText), Length(Name)));\r\nend;\r\n\r\nprocedure TMainForm.vstDbgInfoFunctionsCompareNodes(Sender: TBaseVirtualTree;\r\n  Node1, Node2: PVirtualNode; Column: TColumnIndex; var Result: Integer);\r\nvar\r\n  Data1, Data2: PLinkData;\r\n  Name1, Name2: String;\r\n  ValueU1, ValueU2: NativeUInt;\r\n  ValueS1, ValueS2: Int64;\r\nbegin\r\n  Data1 := vstDbgInfoFunctions.GetNodeData(Node1);\r\n  Data2 := vstDbgInfoFunctions.GetNodeData(Node2);\r\n\r\n  case Column of\r\n    0:\r\n      begin\r\n        Name1 := '';\r\n        Name2 := '';\r\n\r\n        if (Data1^.LinkType = ltDbgFuncInfo) and (Data2^.LinkType = ltDbgFuncInfo) then\r\n        begin\r\n          Name1 := Data1^.DbgFuncInfo.ShortName;\r\n          Name2 := Data2^.DbgFuncInfo.ShortName;\r\n        end;\r\n\r\n        Result := CompareText(Name1, Name2);\r\n      end;\r\n    1:\r\n      begin\r\n        ValueU1 := 0;\r\n        ValueU2 := 0;\r\n\r\n        if (Data1^.LinkType = ltDbgFuncInfo) and (Data2^.LinkType = ltDbgFuncInfo) then\r\n        begin\r\n          ValueU1 := NativeUInt(Data1^.DbgFuncInfo.Address);\r\n          ValueU2 := NativeUInt(Data2^.DbgFuncInfo.Address);\r\n        end;\r\n\r\n        Result := Compare(ValueU1, ValueU2);\r\n      end;\r\n    2:\r\n      begin\r\n        ValueS1 := 0;\r\n        ValueS2 := 0;\r\n\r\n        if (Data1^.LinkType = ltDbgFuncInfo) and (Data2^.LinkType = ltDbgFuncInfo) then\r\n        begin\r\n          ValueS1 := Data1^.DbgFuncInfo.Size;\r\n          ValueS2 := Data2^.DbgFuncInfo.Size;\r\n        end;\r\n\r\n        Result := Compare(ValueS1, ValueS2);\r\n      end;\r\n  end;\r\nend;\r\n\r\nprocedure TMainForm.vstDbgInfoFunctionsFocusChanged(Sender: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex);\r\nvar\r\n  Data: PLinkData;\r\n  FuncInfo: TFuncInfo;\r\nbegin\r\n  Data := vstDbgInfoFunctions.GetNodeData(Node);\r\n  if Data^.LinkType = ltDbgFuncInfo then\r\n  begin\r\n    FuncInfo := Data^.DbgFuncInfo;\r\n\r\n    LoadFunctionParams(FuncInfo, Node);\r\n    LoadFunctionSource(svfDbgInfoFuncAdv, FuncInfo);\r\n  end;\r\nend;\r\n\r\nprocedure TMainForm.vstDbgInfoFunctionsGetText(Sender: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex; TextType: TVSTTextType; var CellText: string);\r\nvar\r\n  Data: PLinkData;\r\n  FuncInfo: TFuncInfo;\r\n  UnitInfo: TUnitInfo;\r\nbegin\r\n  Data := vstDbgInfoFunctions.GetNodeData(Node);\r\n  case Data^.LinkType of\r\n    ltDbgUnitInfo:\r\n      begin\r\n        UnitInfo := Data^.DbgUnitInfo;\r\n        case Column of\r\n          0: CellText := UnitInfo.ShortName;\r\n        else\r\n          CellText := ' ';\r\n        end;\r\n      end;\r\n    ltDbgFuncInfo:\r\n      begin\r\n        FuncInfo := Data^.DbgFuncInfo;\r\n\r\n        case Column of\r\n          0: CellText := FuncInfo.ShortName;\r\n          1: CellText := Format('%p', [FuncInfo.Address]);\r\n          2: CellText := Format('%d', [FuncInfo.Size]);\r\n        end;\r\n      end;\r\n  end;\r\nend;\r\n\r\nprocedure TMainForm.vstDbgInfoFunctionsIncrementalSearch(\r\n  Sender: TBaseVirtualTree; Node: PVirtualNode; const SearchText: string;\r\n  var Result: Integer);\r\nvar\r\n  Data: PLinkData;\r\n  Name: String;\r\nbegin\r\n  Data := vstDbgInfoFunctions.GetNodeData(Node);\r\n\r\n  Name := '';\r\n  if (Data^.LinkType = ltDbgFuncInfo) then\r\n    Name := Data^.DbgFuncInfo.ShortName;\r\n\r\n  Result := AnsiStrLIComp(PChar(SearchText), PChar(Name), Min(Length(SearchText), Length(Name)));\r\nend;\r\n\r\nprocedure TMainForm.vstDbgInfoFuncVarsGetText(Sender: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex; TextType: TVSTTextType; var CellText: string);\r\nvar\r\n  Data: PLinkData;\r\n  FuncInfo: TFuncInfo;\r\n  VarInfo: TVarInfo;\r\nbegin\r\n  Data := vstDbgInfoTypes.GetNodeData(Node);\r\n  case Data^.LinkType of\r\n    ltDbgFuncInfo:\r\n      begin\r\n        FuncInfo := Data^.DbgFuncInfo;\r\n        case Column of\r\n          0: CellText := FuncInfo.ShortName;\r\n        else\r\n          CellText := ' ';\r\n        end;\r\n      end;\r\n    ltDbgFuncParamInfo:\r\n      begin\r\n        VarInfo := Data^.DbgFuncParamInfo;\r\n        case Column of\r\n          0: CellText := VarInfo.ShortName;\r\n          1: CellText := VarInfo.DataTypeName;\r\n          2:\r\n            begin\r\n              case VarInfo.VarKind of\r\n                vkGlobal:\r\n                  CellText := 'Global';\r\n                vkStack:\r\n                  CellText := 'Stack';\r\n                vkRegister:\r\n                  CellText := 'Reg';\r\n                vkLink:\r\n                  CellText := 'Link';\r\n              end;\r\n            end;\r\n        end;\r\n      end;\r\n  end;\r\nend;\r\n\r\nprocedure TMainForm.vstDbgInfoTypesCompareNodes(Sender: TBaseVirtualTree; Node1,\r\n  Node2: PVirtualNode; Column: TColumnIndex; var Result: Integer);\r\nvar\r\n  Data1, Data2: PLinkData;\r\n  Name1, Name2: String;\r\n  ValueS1, ValueS2: Int64;\r\nbegin\r\n  Data1 := vstDbgInfoTypes.GetNodeData(Node1);\r\n  Data2 := vstDbgInfoTypes.GetNodeData(Node2);\r\n\r\n  case Column of\r\n    0:\r\n      begin\r\n        Name1 := '';\r\n        Name2 := '';\r\n\r\n        if (Data1^.LinkType = ltDbgTypeInfo) and (Data2^.LinkType = ltDbgTypeInfo) then\r\n        begin\r\n          Name1 := Data1^.DbgTypeInfo.ShortName;\r\n          Name2 := Data2^.DbgTypeInfo.ShortName;\r\n        end\r\n        else if (Data1^.LinkType = ltDbgStructMemberInfo) and (Data2^.LinkType = ltDbgStructMemberInfo) then\r\n        begin\r\n          Name1 := Data1^.DbgStructMemberInfo.ShortName;\r\n          Name2 := Data2^.DbgStructMemberInfo.ShortName;\r\n        end;\r\n\r\n        Result := CompareText(Name1, Name2);\r\n      end;\r\n    1:\r\n      begin\r\n        Name1 := '';\r\n        Name2 := '';\r\n\r\n        if (Data1^.LinkType = ltDbgTypeInfo) and (Data2^.LinkType = ltDbgTypeInfo) then\r\n        begin\r\n          Name1 := Data1^.DbgTypeInfo.TypeOf;\r\n          Name2 := Data2^.DbgTypeInfo.TypeOf;\r\n        end\r\n        else if (Data1^.LinkType = ltDbgStructMemberInfo) and (Data2^.LinkType = ltDbgStructMemberInfo) then\r\n        begin\r\n          Name1 := Data1^.DbgStructMemberInfo.DataType.ShortName;\r\n          Name2 := Data2^.DbgStructMemberInfo.DataType.ShortName;\r\n        end;\r\n\r\n        Result := CompareText(Name1, Name2);\r\n      end;\r\n    2:\r\n      begin\r\n        ValueS1 := 0;\r\n        ValueS2 := 0;\r\n\r\n        if (Data1^.LinkType = ltDbgTypeInfo) and (Data2^.LinkType = ltDbgTypeInfo) then\r\n        begin\r\n          ValueS1 := Data1^.DbgTypeInfo.DataSize;\r\n          ValueS2 := Data2^.DbgTypeInfo.DataSize;\r\n        end\r\n        else if (Data1^.LinkType = ltDbgStructMemberInfo) and (Data2^.LinkType = ltDbgStructMemberInfo) then\r\n        begin\r\n          ValueS1 := Data1^.DbgStructMemberInfo.DataSize;\r\n          ValueS2 := Data2^.DbgStructMemberInfo.DataSize;\r\n        end;\r\n\r\n        Result := Compare(ValueS1, ValueS2);\r\n      end;\r\n    3:\r\n      begin\r\n        ValueS1 := 0;\r\n        ValueS2 := 0;\r\n\r\n        if (Data1^.LinkType = ltDbgStructMemberInfo) and (Data2^.LinkType = ltDbgStructMemberInfo) then\r\n        begin\r\n          ValueS1 := Data1^.DbgStructMemberInfo.Offset;\r\n          ValueS2 := Data2^.DbgStructMemberInfo.Offset;\r\n        end;\r\n\r\n        Result := Compare(ValueS1, ValueS2);\r\n      end;\r\n  end;\r\nend;\r\n\r\nprocedure TMainForm.vstDbgInfoTypesGetText(Sender: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex; TextType: TVSTTextType; var CellText: string);\r\nvar\r\n  Data: PLinkData;\r\n  UnitInfo: TUnitInfo;\r\n  TypeInfo: TTypeInfo;\r\n  MemberInfo: TStructMember;\r\nbegin\r\n  CellText := ' ';\r\n\r\n  Data := vstDbgInfoTypes.GetNodeData(Node);\r\n  case Data^.LinkType of\r\n    ltDbgUnitInfo:\r\n      begin\r\n        UnitInfo := Data^.DbgUnitInfo;\r\n        case Column of\r\n          0: CellText := UnitInfo.ShortName;\r\n        end;\r\n      end;\r\n    ltDbgTypeInfo:\r\n      begin\r\n        TypeInfo := Data^.DbgTypeInfo;\r\n\r\n        case Column of\r\n          0: CellText := TypeInfo.ShortName;\r\n          1: CellText := TypeInfo.TypeOf;\r\n          2: CellText := IntToStr(TypeInfo.DataSize);\r\n        end;\r\n      end;\r\n    ltDbgStructMemberInfo:\r\n      begin\r\n        MemberInfo := Data^.DbgStructMemberInfo;\r\n\r\n        case Column of\r\n          0: CellText := MemberInfo.ShortName;\r\n          1: CellText := MemberInfo.DataType.ShortName;\r\n          2: CellText := IntToStr(MemberInfo.DataSize);\r\n          3: CellText := IntToStr(MemberInfo.Offset);\r\n        end;\r\n      end;\r\n  end;\r\nend;\r\n\r\nprocedure TMainForm.vstDbgInfoTypesIncrementalSearch(Sender: TBaseVirtualTree;\r\n  Node: PVirtualNode; const SearchText: string; var Result: Integer);\r\nvar\r\n  Data: PLinkData;\r\n  Name: String;\r\nbegin\r\n  Data := vstDbgInfoTypes.GetNodeData(Node);\r\n  Name := '';\r\n\r\n  if (Data^.LinkType = ltDbgTypeInfo) then\r\n    Name := Data^.DbgTypeInfo.ShortName\r\n  else if (Data^.LinkType = ltDbgStructMemberInfo) then\r\n    Name := Data^.DbgStructMemberInfo.ShortName;\r\n\r\n  Result := AnsiStrLIComp(PChar(SearchText), PChar(Name), Min(Length(SearchText), Length(Name)));\r\nend;\r\n\r\nprocedure TMainForm.vstDbgInfoUnitsCompareNodes(Sender: TBaseVirtualTree; Node1, Node2: PVirtualNode; Column: TColumnIndex; var Result: Integer);\r\nvar\r\n  Data1, Data2: PLinkData;\r\n  Name1, Name2: String;\r\n  ValueU1, ValueU2: NativeUInt;\r\n  ValueS1, ValueS2: Int64;\r\nbegin\r\n  Data1 := vstDbgInfoUnits.GetNodeData(Node1);\r\n  Data2 := vstDbgInfoUnits.GetNodeData(Node2);\r\n\r\n  case Column of\r\n    0:\r\n      begin\r\n        Name1 := '';\r\n        Name2 := '';\r\n\r\n        if (Data1^.LinkType = ltDbgUnitInfo) and (Data2^.LinkType = ltDbgUnitInfo) then\r\n        begin\r\n          Name1 := Data1^.DbgUnitInfo.ShortName;\r\n          Name2 := Data2^.DbgUnitInfo.ShortName;\r\n        end;\r\n\r\n        Result := CompareText(Name1, Name2);\r\n      end;\r\n    1:\r\n      begin\r\n        ValueU1 := 0;\r\n        ValueU2 := 0;\r\n\r\n        if (Data1^.LinkType = ltDbgUnitInfo) and (Data2^.LinkType = ltDbgUnitInfo) then\r\n        begin\r\n          ValueU1 := NativeUInt(Data1^.DbgUnitInfo.Address);\r\n          ValueU2 := NativeUInt(Data2^.DbgUnitInfo.Address);\r\n        end;\r\n\r\n        Result := Compare(ValueU1, ValueU2);\r\n      end;\r\n    2:\r\n      begin\r\n        ValueS1 := 0;\r\n        ValueS2 := 0;\r\n\r\n        if (Data1^.LinkType = ltDbgUnitInfo) and (Data2^.LinkType = ltDbgUnitInfo) then\r\n        begin\r\n          ValueS1 := Data1^.DbgUnitInfo.Size;\r\n          ValueS2 := Data2^.DbgUnitInfo.Size;\r\n        end;\r\n\r\n        Result := Compare(ValueS1, ValueS2);\r\n      end;\r\n  end;\r\nend;\r\n\r\nprocedure TMainForm.vstDbgInfoUnitsDrawText(Sender: TBaseVirtualTree; TargetCanvas: TCanvas; Node: PVirtualNode; Column: TColumnIndex;\r\n  const Text: string; const CellRect: TRect; var DefaultDraw: Boolean);\r\nvar\r\n  Data: PLinkData;\r\nbegin\r\n  Data := vstDbgInfoUnits.GetNodeData(Node);\r\n  case Data^.LinkType of\r\n    ltDbgUnitGroup:\r\n      begin\r\n        TargetCanvas.Font.Style := [fsBold];\r\n      end;\r\n  end;\r\nend;\r\n\r\nprocedure TMainForm.vstDbgInfoUnitsFocusChanged(Sender: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex);\r\nvar\r\n  Data: PLinkData;\r\n  UnitInfo: TUnitInfo;\r\nbegin\r\n  Data := vstDbgInfoUnits.GetNodeData(Node);\r\n  case Data^.LinkType of\r\n    ltDbgUnitInfo:\r\n      begin\r\n        UnitInfo := Data^.DbgUnitInfo;\r\n\r\n        LoadConsts(UnitInfo, Node);\r\n        LoadTypes(UnitInfo, Node);\r\n        LoadVars(UnitInfo, Node);\r\n        LoadFunctions(UnitInfo, Node);\r\n        LoadUnitSource(UnitInfo, Node);\r\n      end;\r\n  end;\r\nend;\r\n\r\nprocedure TMainForm.vstDbgInfoUnitsGetText(Sender: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex; TextType: TVSTTextType; var CellText: string);\r\nvar\r\n  Data: PLinkData;\r\n  UnitInfo: TUnitInfo;\r\nbegin\r\n  CellText := ' ';\r\n  Data := vstDbgInfoUnits.GetNodeData(Node);\r\n  case Data^.LinkType of\r\n    ltDbgUnitGroup:\r\n      begin\r\n        if Column = 0 then\r\n          CellText := CUnitTypeStrings[Data^.DbgUnitGroupType];\r\n      end;\r\n    ltDbgUnitInfo:\r\n      begin\r\n        UnitInfo := Data^.DbgUnitInfo;\r\n        case Column of\r\n          0: CellText := UnitInfo.ShortName;\r\n          1: CellText := Format('%p ', [UnitInfo.Address]);\r\n          2: CellText := Format('%d ', [UnitInfo.Size]);\r\n        end;\r\n      end;\r\n  end;\r\nend;\r\n\r\nprocedure TMainForm.vstDbgInfoUnitsIncrementalSearch(Sender: TBaseVirtualTree;\r\n  Node: PVirtualNode; const SearchText: string; var Result: Integer);\r\nvar\r\n  Data : PLinkData;\r\n  Name: String;\r\nbegin\r\n  Data := vstDbgInfoUnits.GetNodeData(Node);\r\n\r\n  Name := '';\r\n\r\n  if (Data^.LinkType = ltDbgUnitInfo) then\r\n    Name := Data^.DbgUnitInfo.ShortName\r\n  else\r\n  if (Data^.LinkType = ltDbgUnitGroup) then\r\n    Name := CUnitTypeStrings[Data^.DbgUnitGroupType];\r\n\r\n  Result := AnsiStrLIComp(PChar(SearchText), PChar(Name), Min(Length(SearchText), Length(Name)));\r\nend;\r\n\r\nprocedure TMainForm.vstTreeResize(Sender: TObject);\r\nvar\r\n  Idx: Integer;\r\n  C: TVirtualTreeColumn;\r\n  OldWidth: Integer;\r\n  NewWidth: Integer;\r\n  Factor: Double;\r\n  CCnt: Integer;\r\n  SaveOnColumnResize: TVTHeaderNotifyEvent;\r\n  vTree: TVirtualStringTree;\r\nbegin\r\n  vTree := TVirtualStringTree(Sender);\r\n\r\n  SaveOnColumnResize := vTree.OnColumnResize;\r\n  vTree.OnColumnResize := Nil;\r\n  try\r\n    CCnt := vTree.Header.Columns.Count;\r\n\r\n    OldWidth := 0;\r\n    for Idx := 0 to CCnt - 1 do\r\n    begin\r\n      C := vTree.Header.Columns[Idx];\r\n      if coVisible in C.Options then\r\n        Inc(OldWidth, C.Width);\r\n    end;\r\n\r\n    NewWidth := vTree.ClientWidth;\r\n\r\n    if (OldWidth = 0) or (NewWidth = 0)  then Exit;\r\n\r\n    Factor := NewWidth / OldWidth;\r\n\r\n    for Idx := 0 to CCnt - 1 do\r\n    begin\r\n      C := vTree.Header.Columns[Idx];\r\n\r\n      if coVisible in C.Options then\r\n      begin\r\n        if Idx < CCnt - 1 then\r\n        begin\r\n            C.Width := Round(C.Width * Factor);\r\n            Dec(NewWidth, C.Width);\r\n        end\r\n        else\r\n          C.Width := NewWidth;\r\n      end;\r\n    end;\r\n  finally\r\n    vTree.OnColumnResize := SaveOnColumnResize;\r\n  end;\r\nend;\r\n\r\nprocedure TMainForm.vstDbgInfoVarsCompareNodes(Sender: TBaseVirtualTree; Node1,\r\n  Node2: PVirtualNode; Column: TColumnIndex; var Result: Integer);\r\nvar\r\n  Data1, Data2: PLinkData;\r\n  Name1, Name2: String;\r\n  ValueS1, ValueS2: Int64;\r\nbegin\r\n  Data1 := vstDbgInfoVars.GetNodeData(Node1);\r\n  Data2 := vstDbgInfoVars.GetNodeData(Node2);\r\n\r\n  case Column of\r\n    0:\r\n      begin\r\n        Name1 := '';\r\n        Name2 := '';\r\n\r\n        if (Data1^.LinkType = ltDbgVarInfo) and (Data2^.LinkType = ltDbgVarInfo) then\r\n        begin\r\n          Name1 := Data1^.DbgVarInfo.ShortName;\r\n          Name2 := Data2^.DbgVarInfo.ShortName;\r\n        end;\r\n\r\n        Result := CompareText(Name1, Name2);\r\n      end;\r\n    1:\r\n      begin\r\n        Name1 := '';\r\n        Name2 := '';\r\n\r\n        if (Data1^.LinkType = ltDbgVarInfo) and (Data2^.LinkType = ltDbgVarInfo) then\r\n        begin\r\n          Name1 := Data1^.DbgVarInfo.DataTypeName;\r\n          Name2 := Data2^.DbgVarInfo.DataTypeName;\r\n        end;\r\n\r\n        Result := CompareText(Name1, Name2);\r\n      end;\r\n    2:\r\n      begin\r\n        ValueS1 := 0;\r\n        ValueS2 := 0;\r\n\r\n        if (Data1^.LinkType = ltDbgVarInfo) and (Data2^.LinkType = ltDbgVarInfo) then\r\n        begin\r\n          ValueS1 := Data1^.DbgVarInfo.Offset;\r\n          ValueS2 := Data2^.DbgVarInfo.Offset;\r\n        end;\r\n\r\n        Result := Compare(ValueS1, ValueS2);\r\n      end;\r\n  end;\r\nend;\r\n\r\nprocedure TMainForm.vstDbgInfoVarsGetText(Sender: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex; TextType: TVSTTextType; var CellText: string);\r\nvar\r\n  Data: PLinkData;\r\n  VarInfo: TVarInfo;\r\n  UnitInfo: TUnitInfo;\r\nbegin\r\n  Data := vstDbgInfoVars.GetNodeData(Node);\r\n  case Data^.LinkType of\r\n    ltDbgUnitInfo:\r\n      begin\r\n        UnitInfo := Data^.DbgUnitInfo;\r\n        case Column of\r\n          0: CellText := UnitInfo.ShortName;\r\n        else\r\n          CellText := ' ';\r\n        end;\r\n      end;\r\n    ltDbgVarInfo:\r\n      begin\r\n        VarInfo := Data^.DbgVarInfo;\r\n\r\n        case Column of\r\n          0: CellText := VarInfo.ShortName;\r\n          1: CellText := VarInfo.DataTypeName;\r\n          2: CellText := Format('%p', [Pointer(VarInfo.Offset)]);\r\n        end;\r\n      end;\r\n  end;\r\nend;\r\n\r\nprocedure TMainForm.vstDbgInfoVarsIncrementalSearch(Sender: TBaseVirtualTree;\r\n  Node: PVirtualNode; const SearchText: string; var Result: Integer);\r\nvar\r\n  Data: PLinkData;\r\n  Name: String;\r\nbegin\r\n  Data := vstDbgInfoVars.GetNodeData(Node);\r\n\r\n  Name := '';\r\n  if Data^.LinkType = ltDbgVarInfo then\r\n    Name := Data^.DbgVarInfo.ShortName;\r\n\r\n  Result := AnsiStrLIComp(PChar(SearchText), PChar(Name), Min(Length(SearchText), Length(Name)));\r\nend;\r\n\r\nprocedure TMainForm.vstExceptionCallStackFocusChanged(Sender: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex);\r\nvar\r\n  Data: PLinkData;\r\n  StackEntry: TStackEntry;\r\nbegin\r\n  svfExceptInfoSource.Clear;\r\n\r\n  Data := vstExceptionCallStack.GetNodeData(Node);\r\n  if Data^.LinkType = ltExceptStack then\r\n  begin\r\n    StackEntry := Data^.ExceptStackEntry;\r\n\r\n    if Assigned(StackEntry) and Assigned(StackEntry.FuncInfo) then\r\n    begin\r\n      if Assigned(StackEntry.LineInfo) then\r\n        LoadFunctionSource(svfExceptInfoSource, StackEntry.FuncInfo, StackEntry.LineInfo.LineNo)\r\n      else\r\n        LoadFunctionSource(svfExceptInfoSource, StackEntry.FuncInfo);\r\n    end;\r\n  end;\r\nend;\r\n\r\nprocedure TMainForm.vstExceptionCallStackGetText(Sender: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex; TextType: TVSTTextType; var CellText: string);\r\nvar\r\n  Data: PLinkData;\r\n  StackEntry: TStackEntry;\r\nbegin\r\n  CellText := ' ';\r\n\r\n  Data := vstExceptionCallStack.GetNodeData(Node);\r\n  if Data^.LinkType = ltExceptStack then\r\n  begin\r\n    StackEntry := Data^.ExceptStackEntry;\r\n    if StackEntry <> nil then\r\n    begin\r\n      case Column of\r\n        0: CellText := Format('%p', [StackEntry.EIP]);\r\n        1: if Assigned(StackEntry.UnitInfo) then\r\n             CellText := StackEntry.UnitInfo.ShortName\r\n           else\r\n             CellText := 'unknown';\r\n        2: if Assigned(StackEntry.LineInfo) then\r\n             CellText := IntToStr(StackEntry.LineInfo.LineNo);\r\n        3: if Assigned(StackEntry.FuncInfo) then\r\n             CellText := StackEntry.FuncInfo.ShortName\r\n           else\r\n             CellText := 'unknown';\r\n      end;\r\n    end;\r\n  end;\r\nend;\r\n\r\nprocedure TMainForm.vstExceptionListFocusChanged(Sender: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex);\r\nvar\r\n  Data: PLinkData;\r\n  Stack: TList;\r\n  I: Integer;\r\n  StackNode: PVirtualNode;\r\n  StackData: PLinkData;\r\nbegin\r\n  vstExceptionCallStack.Clear;\r\n  svfExceptInfoSource.Clear;\r\n\r\n  Data := vstExceptionList.GetNodeData(Node);\r\n  if Data^.LinkType = ltExceptInfo then\r\n  begin\r\n    vstExceptionCallStack.BeginUpdate;\r\n    try\r\n      Stack := Data^.ExceptInfo.Stack;\r\n      for I := 0 to Stack.Count - 1 do\r\n      begin\r\n        StackNode := vstExceptionCallStack.AddChild(nil);\r\n        StackData := vstExceptionCallStack.GetNodeData(StackNode);\r\n        StackData^.ExceptStackEntry := TStackEntry(Stack[I]);\r\n        StackData^.LinkType := ltExceptStack;\r\n      end;\r\n    finally\r\n      vstExceptionCallStack.EndUpdate;\r\n    end;\r\n  end;\r\nend;\r\n\r\nprocedure TMainForm.vstExceptionListGetText(Sender: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex; TextType: TVSTTextType; var CellText: string);\r\nvar\r\n  Data: PLinkData;\r\nbegin\r\n  Data := vstExceptionList.GetNodeData(Node);\r\n  case Column of\r\n    0: CellText := Format('%p', [Data^.ExceptInfo.Address]);\r\n    1: CellText := Data^.ExceptInfo.ExceptionName;\r\n    2: CellText := Data^.ExceptInfo.Message;\r\n  end;\r\nend;\r\n\r\nprocedure TMainForm.vstExceptionThreadsFocusChanged(Sender: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex);\r\nvar\r\n  Data: PLinkData;\r\n  ThData: PThreadData;\r\n  ProcData: TProcessData;\r\n  ExceptList: TThreadList;\r\n  ExceptNode: PVirtualNode;\r\n  I: Integer;\r\n  L: TList;\r\nbegin\r\n  vstExceptionList.Clear;\r\n  vstExceptionCallStack.Clear;\r\n  svfExceptInfoSource.Clear;\r\n\r\n  if gvDebuger = Nil then Exit;\r\n\r\n  ExceptList := Nil;\r\n  if Assigned(Node) then\r\n  begin\r\n    Data := Sender.GetNodeData(Node);\r\n    case Data^.LinkType of\r\n      ltProcess:\r\n      begin\r\n        ProcData := Data^.ProcessData;\r\n        ExceptList := ProcData.DbgExceptions;\r\n      end;\r\n      ltThread:\r\n      begin\r\n        ThData := Data^.ThreadData;\r\n        ExceptList := ThData^.DbgExceptions;\r\n      end;\r\n    end;\r\n  end\r\n  else\r\n  begin\r\n    //    Address info\r\n    ProcData := gvDebuger.ProcessData;\r\n    ExceptList := ProcData.DbgExceptions;\r\n  end;\r\n\r\n  vstExceptionList.BeginUpdate;\r\n  try\r\n    if ExceptList <> Nil then\r\n    begin\r\n      L := ExceptList.LockList;\r\n      try\r\n        for I := 0 to L.Count - 1 do\r\n        begin\r\n          ExceptNode := vstExceptionList.AddChild(nil);\r\n          Data := vstExceptionList.GetNodeData(ExceptNode);\r\n          Data^.SyncNode := Node;\r\n          Data^.ExceptInfo := TExceptInfo(L[I]);\r\n          Data^.LinkType := ltExceptInfo;\r\n        end;\r\n      finally\r\n        ExceptList.UnlockList;\r\n      end;\r\n    end;\r\n  finally\r\n    vstExceptionList.EndUpdate;\r\n  end;\r\nend;\r\n\r\nprocedure TMainForm.vstExceptionThreadsGetText(Sender: TBaseVirtualTree;\r\n  Node: PVirtualNode; Column: TColumnIndex; TextType: TVSTTextType;\r\n  var CellText: string);\r\nvar\r\n  Data: PLinkData;\r\n  ThData: PThreadData;\r\n  ProcData: TProcessData;\r\nbegin\r\n  CellText := ' ';\r\n  Data := Sender.GetNodeData(Node);\r\n  case Data^.LinkType of\r\n    ltProcess:\r\n      begin\r\n        ProcData := Data^.ProcessData;\r\n        if ProcData <> nil then\r\n          case Column of\r\n            0: CellText := ExtractFileName(gvProjectOptions.ApplicationName);\r\n            1: CellText := ProcessIDToStr(ProcData.ProcessID);\r\n            2: if ProcData.DbgExceptionsCount > 0 then\r\n                 CellText := Format('%d', [ProcData.DbgExceptionsCount]);\r\n          end;\r\n      end;\r\n    ltThread:\r\n      begin\r\n        ThData := Data^.ThreadData;\r\n        if ThData <> nil then\r\n          case Column of\r\n            0: CellText := ThData^.ThreadAdvInfo^.AsString;\r\n            1: CellText := ThreadIDToStr(ThData^.ThreadID);\r\n            2: if ThData^.DbgExceptionsCount > 0 then\r\n                 CellText := Format('%d', [ThData^.DbgExceptionsCount]);\r\n          end;\r\n      end;\r\n  end;\r\nend;\r\n\r\nprocedure TMainForm.vstLockThreadsCompareNodes(Sender: TBaseVirtualTree; Node1,\r\n  Node2: PVirtualNode; Column: TColumnIndex; var Result: Integer);\r\nvar\r\n  Data1, Data2: PLinkData;\r\n  Name1, Name2: String;\r\n  ValueU1, ValueU2: UInt64;\r\nbegin\r\n  Data1 := vstLockThreads.GetNodeData(Node1);\r\n  Data2 := vstLockThreads.GetNodeData(Node2);\r\n\r\n  case Column of\r\n    0:\r\n      begin\r\n        Name1 := '';\r\n        Name2 := '';\r\n\r\n        if (Data1^.LinkType = ltProcess) and (Data2^.LinkType = ltProcess) then\r\n        begin\r\n          Name1 := ExtractFileName(gvProjectOptions.ApplicationName);\r\n          Name2 := ExtractFileName(gvProjectOptions.ApplicationName);\r\n        end\r\n        else\r\n        if (Data1^.LinkType = ltThread) and (Data2^.LinkType = ltThread) then\r\n        begin\r\n          Name1 := Data1^.ThreadData^.ThreadAdvInfo^.AsString;\r\n          Name2 := Data2^.ThreadData^.ThreadAdvInfo^.AsString;\r\n        end;\r\n\r\n        Result := CompareText(Name1, Name2);\r\n      end;\r\n    1:\r\n      begin\r\n        ValueU1 := 0;\r\n        ValueU2 := 0;\r\n\r\n        if (Data1^.LinkType = ltProcess) and (Data2^.LinkType = ltProcess) then\r\n        begin\r\n          ValueU1 := Data1^.ProcessData.ProcessID;\r\n          ValueU2 := Data2^.ProcessData.ProcessID;\r\n        end\r\n        else\r\n        if (Data1^.LinkType = ltThread) and (Data2^.LinkType = ltThread) then\r\n        begin\r\n          ValueU1 := Data1^.ThreadData^.ThreadID;\r\n          ValueU2 := Data2^.ThreadData^.ThreadID;\r\n        end;\r\n\r\n        Result := Compare(ValueU1, ValueU2);\r\n      end;\r\n    2:\r\n      begin\r\n        ValueU1 := 0;\r\n        ValueU2 := 0;\r\n\r\n        if (Data1^.LinkType = ltThread) and (Data2^.LinkType = ltThread) then\r\n        begin\r\n          if Data1^.ThreadData^.WaitTime <> 0 then\r\n            ValueU1 := Data1^.ThreadData^.WaitTime;\r\n          if Data2^.ThreadData^.WaitTime <> 0 then\r\n            ValueU2 := Data2^.ThreadData^.WaitTime;\r\n        end;\r\n        Result := Compare(ValueU1, ValueU2);\r\n      end;\r\n  end;\r\nend;\r\n\r\nprocedure TMainForm.vstLockThreadsFocusChanged(Sender: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex);\r\nvar\r\n  Data: PLinkData;\r\nbegin\r\n  if Node = nil then Exit;\r\n\r\n  vstLockTrackingList.Clear;\r\n  vstLockTrackingParents.Clear;\r\n  vstLockTrackingChilds.Clear;\r\n  vstLockTrackingSyncObjs.Clear;\r\n  vstLockTrackingSyncObjStack.Clear;\r\n  svfLockTrackingSource.Clear;\r\n\r\n  Data := vstLockThreads.GetNodeData(Node);\r\n  case Data^.LinkType of\r\n    //ltProcess:\r\n    //  LoadTrackProcessFunctions(Data^.ProcessData, Node);\r\n    ltThread:\r\n      LoadLockTrackThreadFunctions(Data^.ThreadData, Node);\r\n  end;\r\nend;\r\n\r\nprocedure TMainForm.vstLockThreadsGetText(Sender: TBaseVirtualTree;\r\n  Node: PVirtualNode; Column: TColumnIndex; TextType: TVSTTextType;\r\n  var CellText: string);\r\nvar\r\n  Data: PLinkData;\r\n  ThData: PThreadData;\r\n  ProcData: TProcessData;\r\nbegin\r\n  CellText := ' ';\r\n\r\n  Data := Sender.GetNodeData(Node);\r\n  case Data^.LinkType of\r\n    ltProcess:\r\n      begin\r\n        ProcData := Data^.ProcessData;\r\n        if ProcData <> nil then\r\n          case Column of\r\n            0: CellText := ExtractFileName(gvProjectOptions.ApplicationName);\r\n            1: CellText := ProcessIDToStr(ProcData.ProcessID);\r\n          end;\r\n      end;\r\n    ltThread:\r\n      begin\r\n        ThData := Data^.ThreadData;\r\n        if ThData <> nil then\r\n          case Column of\r\n            0: CellText := ThData^.ThreadAdvInfo^.AsString;\r\n            1: CellText := ThreadIDToStr(ThData^.ThreadID);\r\n            2: if ThData^.WaitTime <> 0 then\r\n              CellText := ElapsedToTime(ThData^.WaitTime);\r\n          end;\r\n      end;\r\n  end;\r\nend;\r\n\r\nprocedure TMainForm.vstLockThreadsIncrementalSearch(Sender: TBaseVirtualTree;\r\n  Node: PVirtualNode; const SearchText: string; var Result: Integer);\r\nvar\r\n  Data: PLinkData;\r\n  Name: String;\r\nbegin\r\n  Data := vstLockThreads.GetNodeData(Node);\r\n\r\n  Name := '';\r\n  if (Data^.LinkType = ltProcess) then\r\n    Name := ExtractFileName(gvProjectOptions.ApplicationName)\r\n  else\r\n  if (Data^.LinkType = ltThread) then\r\n    Name := Data^.ThreadData^.ThreadAdvInfo^.AsString;\r\n\r\n  Result := AnsiStrLIComp(PChar(SearchText), PChar(Name), Min(Length(SearchText), Length(Name)));\r\nend;\r\n\r\nprocedure TMainForm.vstLockTrackingListCompareNodes(Sender: TBaseVirtualTree; Node1, Node2: PVirtualNode; Column: TColumnIndex; var Result: Integer);\r\nvar\r\n  Data1, Data2: PLinkData;\r\n  Name1, Name2: String;\r\n  ValueU1, ValueU2: UInt64;\r\n  ValueS1, ValueS2: Int64;\r\nbegin\r\n  Data1 := Sender.GetNodeData(Node1);\r\n  Data2 := Sender.GetNodeData(Node2);\r\n\r\n  case Column of\r\n    0:\r\n      begin\r\n        Name1 := '';\r\n        Name2 := '';\r\n\r\n        if (Data1^.LinkType = ltTrackFuncInfo) and (Data2^.LinkType = ltTrackFuncInfo) then\r\n        begin\r\n          Name1 := TFuncInfo(Data1^.TrackFuncInfo.FuncInfo).ShortName;\r\n          Name2 := TFuncInfo(Data2^.TrackFuncInfo.FuncInfo).ShortName;\r\n        end\r\n        else\r\n        if (Data1^.LinkType = ltTrackUnitInfo) and (Data2^.LinkType = ltTrackUnitInfo) then\r\n        begin\r\n          Name1 := TUnitInfo(Data1^.TrackUnitInfo.UnitInfo).ShortName;\r\n          Name2 := TUnitInfo(Data2^.TrackUnitInfo.UnitInfo).ShortName;\r\n        end;\r\n\r\n        Result := CompareText(Name1, Name2);\r\n      end;\r\n    1:\r\n      begin\r\n        ValueU1 := 0;\r\n        ValueU2 := 0;\r\n\r\n        if (Data1^.LinkType = ltTrackFuncInfo) and (Data2^.LinkType = ltTrackFuncInfo) then\r\n        begin\r\n          ValueU1 := Data1^.TrackFuncInfo.CallCount;\r\n          ValueU2 := Data2^.TrackFuncInfo.CallCount;\r\n        end\r\n        else\r\n        if (Data1^.LinkType = ltTrackUnitInfo) and (Data2^.LinkType = ltTrackUnitInfo) then\r\n        begin\r\n          ValueU1 := Data1^.TrackUnitInfo.CallCount;\r\n          ValueU2 := Data2^.TrackUnitInfo.CallCount;\r\n        end;\r\n\r\n        Result := Compare(ValueU1, ValueU2);\r\n      end;\r\n    2:\r\n      begin\r\n        ValueS1 := 0;\r\n        ValueS2 := 0;\r\n\r\n        if (Data1^.LinkType = ltTrackFuncInfo) and (Data2^.LinkType = ltTrackFuncInfo) then\r\n        begin\r\n          ValueS1 := TSyncObjsTrackFuncInfo(Data1^.TrackFuncInfo).WaitTime;\r\n          ValueS2 := TSyncObjsTrackFuncInfo(Data2^.TrackFuncInfo).WaitTime;\r\n        end;\r\n\r\n        Result := Compare(ValueS1, ValueS2);\r\n      end;\r\n  end;\r\nend;\r\n\r\nprocedure TMainForm.vstLockTrackingListFocusChanged(Sender: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex);\r\nvar\r\n  Data: PLinkData;\r\n  TrackFuncInfo: TSyncObjsTrackFuncInfo;\r\nbegin\r\n  Data := vstLockTrackingList.GetNodeData(Node);\r\n  case Data^.LinkType of\r\n    ltTrackFuncInfo:\r\n      begin\r\n        vstLockTrackingSyncObjStack.Clear;\r\n\r\n        TrackFuncInfo := TSyncObjsTrackFuncInfo(Data^.TrackFuncInfo);\r\n\r\n        LoadSyncObjsInfoObjects(vstLockTrackingSyncObjs, TrackFuncInfo.SyncObjsList, Node);\r\n        LoadMemInfoParentFunctions(vstLockTrackingParents, TrackFuncInfo, Node);\r\n        LoadMemInfoChildFunctions(vstLockTrackingChilds, TrackFuncInfo, Node);\r\n\r\n        LoadFunctionSource(svfLockTrackingSource, TFuncInfo(TrackFuncInfo.FuncInfo));\r\n      end;\r\n  else\r\n    begin\r\n      vstLockTrackingParents.Clear;\r\n      vstLockTrackingChilds.Clear;\r\n      vstLockTrackingSyncObjStack.Clear;\r\n      vstLockTrackingSyncObjs.Clear;\r\n      svfLockTrackingSource.Clear;\r\n    end;\r\n  end;\r\nend;\r\n\r\nprocedure TMainForm.vstLockTrackingListGetText(Sender: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex; TextType: TVSTTextType;\r\n  var CellText: string);\r\nvar\r\n  Data: PLinkData;\r\n  ThData: PThreadData;\r\n  TrackFuncInfo: TSyncObjsTrackFuncInfo;\r\n  TrackUnitInfo: TSyncObjsTrackUnitInfo;\r\nbegin\r\n  CellText := ' ';\r\n  Data := vstLockTrackingList.GetNodeData(Node);\r\n  case Data^.LinkType of\r\n    ltProcess:\r\n      begin\r\n        case Column of\r\n          0: CellText := ExtractFileName(gvProjectOptions.ApplicationName);\r\n        end;\r\n      end;\r\n    ltThread:\r\n      begin\r\n        ThData := Data^.ThreadData;\r\n        case Column of\r\n          0: CellText := ThData^.ThreadAdvInfo^.AsString;\r\n          1: ;\r\n          2: CellText := ElapsedToTime(ThData^.WaitTime);\r\n        end;\r\n      end;\r\n    ltTrackFuncInfo:\r\n      begin\r\n        TrackFuncInfo := TSyncObjsTrackFuncInfo(Data^.TrackFuncInfo);\r\n        case Column of\r\n          0: CellText := TFuncInfo(TrackFuncInfo.FuncInfo).ShortName;\r\n          1: CellText := IntToStr(TrackFuncInfo.CallCount);\r\n          2: CellText := ElapsedToTime(TrackFuncInfo.WaitTime);\r\n        end;\r\n      end;\r\n    ltTrackUnitInfo:\r\n      begin\r\n        TrackUnitInfo := TSyncObjsTrackUnitInfo(Data^.TrackUnitInfo);\r\n        case Column of\r\n          0: CellText := TUnitInfo(TrackUnitInfo.UnitInfo).ShortName;\r\n        end;\r\n      end;\r\n  end;\r\nend;\r\n\r\nprocedure TMainForm.vstLockTrackingListIncrementalSearch(\r\n  Sender: TBaseVirtualTree; Node: PVirtualNode; const SearchText: string;\r\n  var Result: Integer);\r\nvar\r\n  Data: PLinkData;\r\n  Name: String;\r\nbegin\r\n  Data := Sender.GetNodeData(Node);\r\n\r\n  Name := '';\r\n  if (Data^.LinkType = ltProcess) then\r\n    Name := ExtractFileName(gvProjectOptions.ApplicationName)\r\n  else\r\n  if (Data^.LinkType = ltThread) then\r\n    Name := Data^.ThreadData^.ThreadAdvInfo^.AsString\r\n  else\r\n  if (Data^.LinkType = ltTrackFuncInfo) then\r\n    Name := TFuncInfo(Data^.TrackFuncInfo.FuncInfo).ShortName\r\n  else\r\n  if (Data^.LinkType = ltTrackUnitInfo) then\r\n    Name := TUnitInfo(Data^.TrackUnitInfo.UnitInfo).ShortName;\r\n\r\n  Result := AnsiStrLIComp(PChar(SearchText), PChar(Name), Min(Length(SearchText), Length(Name)));\r\nend;\r\n\r\nprocedure TMainForm.vstLockTrackingParentsCompareNodes(Sender: TBaseVirtualTree;\r\n  Node1, Node2: PVirtualNode; Column: TColumnIndex; var Result: Integer);\r\nvar\r\n  Data: array [0..1] of PLinkData;\r\n  Name: array [0..1] of String;\r\n  ValueU: array [0..1] of UInt64;\r\nbegin\r\n  Data[0] := vstLockTrackingParents.GetNodeData(Node1);\r\n  Data[1] := vstLockTrackingParents.GetNodeData(Node2);\r\n\r\n  case Column of\r\n    0:\r\n      begin\r\n        Name[0] := '';\r\n        Name[1] := '';\r\n\r\n        if (Data[0]^.LinkType = ltDbgUnitInfo) and (Data[1]^.LinkType = ltDbgUnitInfo) then\r\n        begin\r\n          Name[0] := Data[0]^.DbgUnitInfo.ShortName;\r\n          Name[1] := Data[1]^.DbgUnitInfo.ShortName;\r\n        end\r\n        else\r\n        if (Data[0]^.LinkType = ltTrackFuncInfo) and (Data[1]^.LinkType = ltTrackFuncInfo) then\r\n        begin\r\n          Name[0] := TFuncInfo(TSyncObjsTrackFuncInfo(Data[0]^.TrackFuncInfo).FuncInfo).ShortName;\r\n          Name[1] := TFuncInfo(TSyncObjsTrackFuncInfo(Data[1]^.TrackFuncInfo).FuncInfo).ShortName;\r\n        end\r\n        else\r\n        if (Data[0]^.LinkType = ltTrackCallFuncInfo) and (Data[1]^.LinkType = ltTrackCallFuncInfo) then\r\n        begin\r\n          Name[0] := TFuncInfo(Data[0]^.TrackCallFuncInfo.FuncInfo).ShortName;\r\n          Name[1] := TFuncInfo(Data[1]^.TrackCallFuncInfo.FuncInfo).ShortName;\r\n        end;\r\n\r\n        Result := CompareText(Name[0], Name[1]);\r\n      end;\r\n    1:\r\n      begin\r\n        ValueU[0] := 0;\r\n        ValueU[1] := 0;\r\n\r\n        if (Data[0]^.LinkType = ltTrackCallFuncInfo) and (Data[1]^.LinkType = ltTrackCallFuncInfo) then\r\n        begin\r\n          if Data[0]^.TrackCallFuncInfo.LineNo > 0 then\r\n            ValueU[0] := Data[0]^.TrackCallFuncInfo.LineNo;\r\n          if Data[1]^.TrackCallFuncInfo.LineNo > 0 then\r\n            ValueU[1] := Data[1]^.TrackCallFuncInfo.LineNo;\r\n        end;\r\n\r\n        Result := Compare(ValueU[0], ValueU[1]);\r\n      end;\r\n    2:\r\n      begin\r\n        ValueU[0] := 0;\r\n        ValueU[1] := 0;\r\n        if (Data[0]^.LinkType = ltTrackFuncInfo) and (Data[1]^.LinkType = ltTrackFuncInfo) then\r\n        begin\r\n          ValueU[0] := TSyncObjsTrackFuncInfo(Data[0]^.TrackFuncInfo).CallCount;\r\n          ValueU[1] := TSyncObjsTrackFuncInfo(Data[1]^.TrackFuncInfo).CallCount;\r\n        end;\r\n        if (Data[0]^.LinkType = ltTrackCallFuncInfo) and (Data[1]^.LinkType = ltTrackCallFuncInfo) then\r\n        begin\r\n          ValueU[0] := Data[0]^.TrackCallFuncInfo.CallCount;\r\n          ValueU[1] := Data[1]^.TrackCallFuncInfo.CallCount;\r\n        end;\r\n\r\n        Result := Compare(ValueU[0], ValueU[1]);\r\n      end;\r\n    3:\r\n      begin\r\n        ValueU[0] := 0;\r\n        ValueU[1] := 0;\r\n        if (Data[0]^.LinkType = ltTrackFuncInfo) and (Data[1]^.LinkType = ltTrackFuncInfo) then\r\n        begin\r\n          ValueU[0] := TSyncObjsTrackFuncInfo(Data[0]^.TrackFuncInfo).WaitTime;\r\n          ValueU[1] := TSyncObjsTrackFuncInfo(Data[1]^.TrackFuncInfo).WaitTime;\r\n        end;\r\n        if (Data[0]^.LinkType = ltTrackCallFuncInfo) and (Data[1]^.LinkType = ltTrackCallFuncInfo) then\r\n        begin\r\n          ValueU[0] := Data[0]^.TrackCallFuncInfo.Data;\r\n          ValueU[1] := Data[1]^.TrackCallFuncInfo.Data;\r\n        end;\r\n\r\n        Result := Compare(ValueU[0], ValueU[1]);\r\n      end;\r\n  end;\r\nend;\r\n\r\nprocedure TMainForm.vstLockTrackingParentsDblClick(Sender: TObject);\r\nvar\r\n  Node: PVirtualNode;\r\n  Data: PLinkData;\r\n  FuncInfo: TFuncInfo;\r\n  FuncNode: PVirtualNode;\r\n  LineNo: Cardinal;\r\nbegin\r\n  Node := vstLockTrackingParents.FocusedNode;\r\n  if Assigned(Node) then\r\n  begin\r\n    Data := vstLockTrackingParents.GetNodeData(Node);\r\n    if Data^.LinkType = ltTrackCallFuncInfo then\r\n    begin\r\n      FuncInfo := TFuncInfo(Data^.TrackCallFuncInfo.FuncInfo);\r\n      if Assigned(FuncInfo) then\r\n      begin\r\n        LineNo := Data^.TrackCallFuncInfo.LineNo;\r\n\r\n        FuncNode := FindTrackFuncNode(vstLockTrackingList, FuncInfo);\r\n        if Assigned(FuncNode) then\r\n        begin\r\n          vstLockTrackingList.ClearSelection;\r\n          vstLockTrackingList.FocusedNode := FuncNode;\r\n          vstLockTrackingList.Selected[FuncNode] := True;\r\n\r\n          if LineNo <> 0 then\r\n            LoadFunctionSource(svfLockTrackingSource, FuncInfo, LineNo);\r\n        end;\r\n      end;\r\n    end;\r\n  end;\r\nend;\r\n\r\nprocedure TMainForm.vstLockTrackingParentsIncrementalSearch(\r\n  Sender: TBaseVirtualTree; Node: PVirtualNode; const SearchText: string;\r\n  var Result: Integer);\r\nvar\r\n  Data: PLinkData;\r\n  Name: String;\r\nbegin\r\n  Data := vstLockTrackingParents.GetNodeData(Node);\r\n\r\n  Name := '';\r\n  if (Data^.LinkType = ltDbgUnitInfo) then\r\n    Name := Data^.DbgUnitInfo.ShortName\r\n  else\r\n  if (Data^.LinkType = ltTrackFuncInfo) then\r\n    Name := TFuncInfo(TSyncObjsTrackFuncInfo(Data^.TrackFuncInfo).FuncInfo).ShortName\r\n  else\r\n  if (Data^.LinkType = ltTrackCallFuncInfo) then\r\n    Name := TFuncInfo(Data^.TrackCallFuncInfo.FuncInfo).ShortName;\r\n\r\n  Result := AnsiStrLIComp(PChar(SearchText), PChar(Name), Min(Length(SearchText), Length(Name)));\r\nend;\r\n\r\nprocedure TMainForm.vstLockTrackingSyncObjsCompareNodes(Sender: TBaseVirtualTree; Node1, Node2: PVirtualNode; Column: TColumnIndex; var Result: Integer);\r\nvar\r\n  Data1, Data2: PLinkData;\r\n  Name1, Name2: String;\r\n  Th1, Th2: NativeUInt;\r\n  WaitTime1, WaitTime2: Int64;\r\nbegin\r\n  Data1 := Sender.GetNodeData(Node1);\r\n  Data2 := Sender.GetNodeData(Node2);\r\n\r\n  case Column of\r\n    0:\r\n      begin\r\n        Name1 := '';\r\n        Name2 := '';\r\n\r\n        if (Data1^.LinkType = ltSyncObjInfo) and (Data1^.LinkType = ltSyncObjInfo) then\r\n        begin\r\n          vstLockTrackingSyncObjsGetText(Sender, Node1, Column, ttNormal, Name1);\r\n          vstLockTrackingSyncObjsGetText(Sender, Node2, Column, ttNormal, Name2);\r\n        end;\r\n\r\n        if TVirtualStringTree(Sender).Header.SortDirection = sdAscending then\r\n          Result := Compare(Name1, Name2, 1)\r\n        else\r\n          Result := Compare(Name1, Name2, -1);\r\n      end;\r\n    1:\r\n      begin\r\n        Th1 := 0;\r\n        Th2 := 0;\r\n\r\n        if (Data1^.LinkType = ltSyncObjInfo) and (Data1^.LinkType = ltSyncObjInfo) then\r\n        begin\r\n          Th1 := NativeUInt(Data1^.SyncObjItem^.SyncObjsInfo.ThreadId);\r\n          Th2 := NativeUInt(Data2^.SyncObjItem^.SyncObjsInfo.ThreadId);\r\n        end;\r\n\r\n        Result := Compare(Th1, Th2);\r\n      end;\r\n    2:\r\n      begin\r\n        WaitTime1 := 0;\r\n        WaitTime2 := 0;\r\n\r\n        if (Data1^.LinkType = ltSyncObjInfo) and (Data1^.LinkType = ltSyncObjInfo) then\r\n        begin\r\n          WaitTime1 := NativeUInt(Data1^.SyncObjItem^.WaitTime);\r\n          WaitTime2 := NativeUInt(Data2^.SyncObjItem^.WaitTime);\r\n        end;\r\n\r\n        Result := Compare(WaitTime1, WaitTime2);\r\n      end;\r\n  end;\r\nend;\r\n\r\nprocedure TMainForm.vstLockTrackingSyncObjsFocusChanged(Sender: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex);\r\nvar\r\n  Data: PLinkData;\r\nbegin\r\n  Data := Sender.GetNodeData(Node);\r\n  case Data^.LinkType of\r\n    ltSyncObjInfo, ltSyncObjChildInfo:\r\n      LoadSyncObjsInfoStack(vstLockTrackingSyncObjStack, Data^.SyncObjItem, Node);\r\n  end;\r\nend;\r\n\r\nprocedure TMainForm.vstLockTrackingSyncObjsGetText(Sender: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex;\r\n  TextType: TVSTTextType; var CellText: string);\r\nvar\r\n  Data: PLinkData;\r\nbegin\r\n  CellText := ' ';\r\n\r\n  Data := Sender.GetNodeData(Node);\r\n  case Data^.LinkType of\r\n    ltSyncObjInfo:\r\n      case Column of\r\n        0:\r\n          CellText := CDbgSyncObjsType[Data^.SyncObjItem^.SyncObjsInfo.SyncObjsType];\r\n        1:\r\n          begin\r\n            case Data^.SyncObjItem^.SyncObjsInfo.SyncObjsType of\r\n              soEnterCriticalSection:\r\n                if Data^.SyncObjItem^.SyncObjsInfo.OwningThreadId <> 0 then\r\n                  CellText := ThreadIDToStr(Data^.SyncObjItem^.SyncObjsInfo.OwningThreadId);\r\n            end;\r\n          end;\r\n        2:\r\n          begin\r\n            case Data^.SyncObjItem^.SyncObjsInfo.SyncObjsType of\r\n              soWaitForSingleObject, soWaitForMultipleObjects, soEnterCriticalSection, soSendMessage:\r\n                CellText := ElapsedToTime(Data^.SyncObjItem^.WaitTime);\r\n            end;\r\n          end;\r\n      end;\r\n    ltSyncObjChildInfo:\r\n      case Column of\r\n        0: begin\r\n          case Data^.SyncObjItem^.SyncObjsInfo.SyncObjsType of\r\n            soInCriticalSection:\r\n              case Data^.SyncObjItem^.SyncObjsInfo.SyncObjsStateType of\r\n                sosLeave:\r\n                  CellText := 'Leave';\r\n              end;\r\n          end;\r\n        end;\r\n        2: begin\r\n          case Data^.SyncObjItem^.SyncObjsInfo.SyncObjsType of\r\n            soInCriticalSection:\r\n              CellText := ElapsedToTime(Data^.SyncObjItem^.WaitTime);\r\n          end;\r\n        end;\r\n      end;\r\n  end;\r\nend;\r\n\r\nprocedure TMainForm.vstLockTrackingSyncObjsIncrementalSearch(\r\n  Sender: TBaseVirtualTree; Node: PVirtualNode; const SearchText: string;\r\n  var Result: Integer);\r\nvar\r\n  Data: PLinkData;\r\n  Name: String;\r\nbegin\r\n  Data := Sender.GetNodeData(Node);\r\n\r\n  Name := '';\r\n\r\n  if (Data^.LinkType = ltSyncObjInfo) then\r\n    vstLockTrackingSyncObjsGetText(Sender, Node, 0, ttNormal, Name);\r\n\r\n  Result := AnsiStrLIComp(PChar(SearchText), PChar(Name), Min(Length(SearchText), Length(Name)));\r\nend;\r\n\r\nprocedure TMainForm.vstLockTrackingChildsCompareNodes(Sender: TBaseVirtualTree;\r\n  Node1, Node2: PVirtualNode; Column: TColumnIndex; var Result: Integer);\r\nvar\r\n  Data: array [0..1] of PLinkData;\r\n  Name: array [0..1] of String;\r\n  ValueU: array [0..1] of UInt64;\r\nbegin\r\n  Data[0] := vstLockTrackingChilds.GetNodeData(Node1);\r\n  Data[1] := vstLockTrackingChilds.GetNodeData(Node2);\r\n\r\n  case Column of\r\n    0:\r\n      begin\r\n        Name[0] := '';\r\n        Name[1] := '';\r\n\r\n        if (Data[0]^.LinkType = ltDbgUnitInfo) and (Data[1]^.LinkType = ltDbgUnitInfo) then\r\n        begin\r\n          Name[0] := Data[0]^.DbgUnitInfo.ShortName;\r\n          Name[1] := Data[1]^.DbgUnitInfo.ShortName;\r\n        end\r\n        else\r\n        if (Data[0]^.LinkType = ltTrackFuncInfo) and (Data[1]^.LinkType = ltTrackFuncInfo) then\r\n        begin\r\n          Name[0] := TFuncInfo(TSyncObjsTrackFuncInfo(Data[0]^.TrackFuncInfo).FuncInfo).ShortName;\r\n          Name[1] := TFuncInfo(TSyncObjsTrackFuncInfo(Data[1]^.TrackFuncInfo).FuncInfo).ShortName;\r\n        end\r\n        else\r\n        if (Data[0]^.LinkType = ltTrackCallFuncInfo) and (Data[1]^.LinkType = ltTrackCallFuncInfo) then\r\n        begin\r\n          Name[0] := TFuncInfo(Data[0]^.TrackCallFuncInfo.FuncInfo).ShortName;\r\n          Name[1] := TFuncInfo(Data[1]^.TrackCallFuncInfo.FuncInfo).ShortName;\r\n        end;\r\n\r\n        Result := CompareText(Name[0], Name[1]);\r\n      end;\r\n    1:\r\n      begin\r\n        ValueU[0] := 0;\r\n        ValueU[1] := 0;\r\n\r\n        if (Data[0]^.LinkType = ltTrackCallFuncInfo) and (Data[1]^.LinkType = ltTrackCallFuncInfo) then\r\n        begin\r\n          if Data[0]^.TrackCallFuncInfo.LineNo > 0 then\r\n            ValueU[0] := Data[0]^.TrackCallFuncInfo.LineNo;\r\n          if Data[1]^.TrackCallFuncInfo.LineNo > 0 then\r\n            ValueU[1] := Data[1]^.TrackCallFuncInfo.LineNo;\r\n        end;\r\n\r\n        Result := Compare(ValueU[0], ValueU[1]);\r\n      end;\r\n    2:\r\n      begin\r\n        ValueU[0] := 0;\r\n        ValueU[1] := 0;\r\n        if (Data[0]^.LinkType = ltTrackFuncInfo) and (Data[1]^.LinkType = ltTrackFuncInfo) then\r\n        begin\r\n          ValueU[0] := TSyncObjsTrackFuncInfo(Data[0]^.TrackFuncInfo).CallCount;\r\n          ValueU[1] := TSyncObjsTrackFuncInfo(Data[1]^.TrackFuncInfo).CallCount;\r\n        end;\r\n        if (Data[0]^.LinkType = ltTrackCallFuncInfo) and (Data[1]^.LinkType = ltTrackCallFuncInfo) then\r\n        begin\r\n          ValueU[0] := Data[0]^.TrackCallFuncInfo.CallCount;\r\n          ValueU[1] := Data[1]^.TrackCallFuncInfo.CallCount;\r\n        end;\r\n\r\n        Result := Compare(ValueU[0], ValueU[1]);\r\n      end;\r\n    3:\r\n      begin\r\n        ValueU[0] := 0;\r\n        ValueU[1] := 0;\r\n        if (Data[0]^.LinkType = ltTrackFuncInfo) and (Data[1]^.LinkType = ltTrackFuncInfo) then\r\n        begin\r\n          ValueU[0] := TSyncObjsTrackFuncInfo(Data[0]^.TrackFuncInfo).WaitTime;\r\n          ValueU[1] := TSyncObjsTrackFuncInfo(Data[1]^.TrackFuncInfo).WaitTime;\r\n        end;\r\n        if (Data[0]^.LinkType = ltTrackCallFuncInfo) and (Data[1]^.LinkType = ltTrackCallFuncInfo) then\r\n        begin\r\n          ValueU[0] := Data[0]^.TrackCallFuncInfo.Data;\r\n          ValueU[1] := Data[1]^.TrackCallFuncInfo.Data;\r\n        end;\r\n\r\n        Result := Compare(ValueU[0], ValueU[1]);\r\n      end;\r\n  end;\r\nend;\r\n\r\nprocedure TMainForm.vstLockTrackingChildsDblClick(Sender: TObject);\r\nvar\r\n  Node: PVirtualNode;\r\n  Data: PLinkData;\r\n  FuncInfo: TFuncInfo;\r\n  FuncNode: PVirtualNode;\r\n  LineNo: Cardinal;\r\nbegin\r\n  Node := vstLockTrackingChilds.FocusedNode;\r\n  if Assigned(Node) then\r\n  begin\r\n    Data := vstLockTrackingChilds.GetNodeData(Node);\r\n    if Data^.LinkType = ltTrackCallFuncInfo then\r\n    begin\r\n      FuncInfo := TFuncInfo(Data^.TrackCallFuncInfo.FuncInfo);\r\n      if Assigned(FuncInfo) then\r\n      begin\r\n        LineNo := Data^.TrackCallFuncInfo.LineNo;\r\n\r\n        FuncNode := FindTrackFuncNode(vstLockTrackingList, FuncInfo);\r\n        if Assigned(FuncNode) then\r\n        begin\r\n          vstLockTrackingList.ClearSelection;\r\n          vstLockTrackingList.FocusedNode := FuncNode;\r\n          vstLockTrackingList.Selected[FuncNode] := True;\r\n\r\n          if LineNo <> 0 then\r\n            LoadFunctionSource(svfLockTrackingSource, FuncInfo, LineNo);\r\n        end;\r\n      end;\r\n    end;\r\n  end;\r\nend;\r\n\r\nprocedure TMainForm.vstLockTrackingChildsIncrementalSearch(\r\n  Sender: TBaseVirtualTree; Node: PVirtualNode; const SearchText: string;\r\n  var Result: Integer);\r\nvar\r\n  Data: PLinkData;\r\n  Name: String;\r\nbegin\r\n  Data := vstLockTrackingChilds.GetNodeData(Node);\r\n\r\n  Name := '';\r\n  if (Data^.LinkType = ltDbgUnitInfo) then\r\n    Name := Data^.DbgUnitInfo.ShortName\r\n  else\r\n  if (Data^.LinkType = ltTrackFuncInfo) then\r\n    Name := TFuncInfo(TSyncObjsTrackFuncInfo(Data^.TrackFuncInfo).FuncInfo).ShortName\r\n  else\r\n  if (Data^.LinkType = ltTrackCallFuncInfo) then\r\n    Name := TFuncInfo(Data^.TrackCallFuncInfo.FuncInfo).ShortName;\r\n\r\n  Result := AnsiStrLIComp(PChar(SearchText), PChar(Name), Min(Length(SearchText), Length(Name)));\r\nend;\r\n\r\nprocedure TMainForm.vstLockTrackingLinksGetText(Sender: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex; TextType: TVSTTextType;\r\n  var CellText: string);\r\nvar\r\n  Data: PLinkData;\r\n  TrackCallFuncInfo: TCallFuncInfo;\r\n  TrackFuncInfo: TSyncObjsTrackFuncInfo;\r\nbegin\r\n  CellText := ' ';\r\n\r\n  Data := Sender.GetNodeData(Node);\r\n  case Data^.LinkType of\r\n    ltDbgUnitInfo:\r\n      begin\r\n        case Column of\r\n          0: CellText := Data^.DbgUnitInfo.ShortName;\r\n        end;\r\n      end;\r\n    ltTrackFuncInfo:\r\n      begin\r\n        TrackFuncInfo := TSyncObjsTrackFuncInfo(Data^.TrackFuncInfo);\r\n        case Column of\r\n          0: CellText := TFuncInfo(TrackFuncInfo.FuncInfo).ShortName;\r\n          2: CellText := IntToStr(TrackFuncInfo.CallCount);\r\n          3: CellText := ElapsedToTime(TrackFuncInfo.WaitTime);\r\n        end;\r\n      end;\r\n    ltTrackCallFuncInfo:\r\n      begin\r\n        TrackCallFuncInfo := Data^.TrackCallFuncInfo;\r\n        case Column of\r\n          0: CellText := TFuncInfo(TrackCallFuncInfo.FuncInfo).ShortName;\r\n          1: if TrackCallFuncInfo.LineNo > 0 then\r\n            CellText := IntToStr(TrackCallFuncInfo.LineNo);\r\n          2: CellText := IntToStr(TrackCallFuncInfo.CallCount);\r\n          3: CellText := ElapsedToTime(TrackCallFuncInfo.Data);\r\n        end;\r\n      end;\r\n  end;\r\nend;\r\n\r\nprocedure TMainForm.vstLogColumnResize(Sender: TVTHeader; Column: TColumnIndex);\r\nbegin\r\n  vstLogResize(Sender);\r\nend;\r\n\r\nprocedure TMainForm.vstLogDrawText(Sender: TBaseVirtualTree; TargetCanvas: TCanvas; Node: PVirtualNode; Column: TColumnIndex;\r\n  const Text: string; const CellRect: TRect; var DefaultDraw: Boolean);\r\nvar\r\n  Data: PLinkData;\r\n  Item: TDbgLogItem;\r\nbegin\r\n  Data := vstLog.GetNodeData(Node);\r\n  case Data^.LinkType of\r\n    ltDbgLogItem:\r\n      begin\r\n        Item := gvDebugInfo.DbgLog[Data^.DbgLogItemIdx];\r\n        if Assigned(Item) then\r\n          TargetCanvas.Font.Color := FSpiderOptions.LogColors[Item.LogType];\r\n      end;\r\n  end;\r\nend;\r\n\r\nprocedure TMainForm.vstLogGetText(Sender: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex; TextType: TVSTTextType; var CellText: string);\r\nvar\r\n  Data: PLinkData;\r\n  Item: TDbgLogItem;\r\nbegin\r\n  Data := vstLog.GetNodeData(Node);\r\n  case Data^.LinkType of\r\n    ltProject:\r\n      begin\r\n        case Column of\r\n          1: CellText := gvProjectOptions.ApplicationName;\r\n        else\r\n          CellText := 'Application:';\r\n        end;\r\n      end;\r\n    ltDbgLogItem:\r\n      begin\r\n        Item := gvDebugInfo.DbgLog[Data^.DbgLogItemIdx];\r\n        if Assigned(Item) then\r\n        begin\r\n          case Column of\r\n            0: CellText := FormatDateTime('yyyy.dd.mm hh:nn:ss.zzz', Item.DateTime);\r\n            1: CellText := Item.LogMessage;\r\n          end;\r\n        end;\r\n      end;\r\n  end;\r\nend;\r\n\r\nprocedure TMainForm.vstLogResize(Sender: TObject);\r\nbegin\r\n  vstLog.Header.Columns[1].Width := vstLog.ClientWidth - vstLog.Header.Columns[0].Width - 1;\r\nend;\r\n\r\nprocedure TMainForm.vstMemInfoFuncChildsDblClick(Sender: TObject);\r\nvar\r\n  Node: PVirtualNode;\r\n  Data: PLinkData;\r\n  FuncInfo: TFuncInfo;\r\n  FuncNode: PVirtualNode;\r\n  LineNo: Cardinal;\r\nbegin\r\n  Node := vstMemInfoFuncChilds.FocusedNode;\r\n  if Assigned(Node) then\r\n  begin\r\n    Data := vstMemInfoFuncChilds.GetNodeData(Node);\r\n    if Data^.LinkType = ltTrackCallFuncInfo then\r\n    begin\r\n      FuncInfo := TFuncInfo(Data^.TrackCallFuncInfo.FuncInfo);\r\n      if Assigned(FuncInfo) then\r\n      begin\r\n        LineNo := Data^.TrackCallFuncInfo.LineNo;\r\n\r\n        FuncNode := FindTrackFuncNode(vstMemInfoFuncTree, FuncInfo);\r\n        if Assigned(FuncNode) then\r\n        begin\r\n          vstMemInfoFuncTree.ClearSelection;\r\n          vstMemInfoFuncTree.FocusedNode := FuncNode;\r\n          vstMemInfoFuncTree.Selected[FuncNode] := True;\r\n\r\n          if LineNo <> 0 then\r\n            LoadFunctionSource(svfMemInfoFuncSrc, FuncInfo, LineNo);\r\n        end;\r\n      end;\r\n    end;\r\n  end;\r\nend;\r\n\r\nprocedure TMainForm.vstMemInfoFuncParentsDblClick(Sender: TObject);\r\nvar\r\n  Node: PVirtualNode;\r\n  Data: PLinkData;\r\n  FuncInfo: TFuncInfo;\r\n  FuncNode: PVirtualNode;\r\n  LineNo: Cardinal;\r\nbegin\r\n  Node := vstMemInfoFuncParents.FocusedNode;\r\n  if Assigned(Node) then\r\n  begin\r\n    Data := vstMemInfoFuncParents.GetNodeData(Node);\r\n    if Data^.LinkType = ltTrackCallFuncInfo then\r\n    begin\r\n      FuncInfo := TFuncInfo(Data^.TrackCallFuncInfo.FuncInfo);\r\n      if Assigned(FuncInfo) then\r\n      begin\r\n        LineNo := Data^.TrackCallFuncInfo.LineNo;\r\n\r\n        FuncNode := FindTrackFuncNode(vstMemInfoFuncTree, FuncInfo);\r\n        if Assigned(FuncNode) then\r\n        begin\r\n          vstMemInfoFuncTree.ClearSelection;\r\n          vstMemInfoFuncTree.FocusedNode := FuncNode;\r\n          vstMemInfoFuncTree.Selected[FuncNode] := True;\r\n\r\n          if LineNo <> 0 then\r\n            LoadFunctionSource(svfMemInfoFuncSrc, FuncInfo, LineNo);\r\n        end;\r\n      end;\r\n    end;\r\n  end;\r\nend;\r\n\r\nprocedure TMainForm.vstMemInfoFuncLinksGetText(Sender: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex; TextType: TVSTTextType;\r\n  var CellText: string);\r\nvar\r\n  Data: PLinkData;\r\n  TrackCallFuncInfo: TCallFuncInfo;\r\n  TrackFuncInfo: TMemInfoTrackFuncInfo;\r\nbegin\r\n  CellText := ' ';\r\n\r\n  Data := Sender.GetNodeData(Node);\r\n  case Data^.LinkType of\r\n    ltDbgUnitInfo:\r\n      begin\r\n        case Column of\r\n          0: CellText := Data^.DbgUnitInfo.ShortName;\r\n        end;\r\n      end;\r\n    ltTrackFuncInfo:\r\n      begin\r\n        TrackFuncInfo := TMemInfoTrackFuncInfo(Data^.TrackFuncInfo);\r\n        case Column of\r\n          0: CellText := TFuncInfo(TrackFuncInfo.FuncInfo).ShortName;\r\n          2: CellText := IntToStr(TrackFuncInfo.CurCount);\r\n          3: CellText := IntToStr(TrackFuncInfo.Size);\r\n        end;\r\n      end;\r\n    ltTrackCallFuncInfo:\r\n      begin\r\n        TrackCallFuncInfo := Data^.TrackCallFuncInfo;\r\n        case Column of\r\n          0: CellText := TFuncInfo(TrackCallFuncInfo.FuncInfo).ShortName;\r\n          1: if TrackCallFuncInfo.LineNo > 0 then\r\n            CellText := IntToStr(TrackCallFuncInfo.LineNo);\r\n          2: CellText := IntToStr(TrackCallFuncInfo.CallCount);\r\n          3: CellText := IntToStr(TrackCallFuncInfo.Size);\r\n        end;\r\n      end;\r\n  end;\r\nend;\r\n\r\nprocedure TMainForm.vstMemInfoFuncTreeCompareNodes(Sender: TBaseVirtualTree; Node1, Node2: PVirtualNode; Column: TColumnIndex; var Result: Integer);\r\nvar\r\n  Data1, Data2: PLinkData;\r\n  Name1, Name2: String;\r\n  ValueU1, ValueU2: UInt64;\r\n  ValueS1, ValueS2: Int64;\r\nbegin\r\n  Data1 := vstMemInfoFuncTree.GetNodeData(Node1);\r\n  Data2 := vstMemInfoFuncTree.GetNodeData(Node2);\r\n\r\n  case Column of\r\n    0:\r\n      begin\r\n        Name1 := '';\r\n        Name2 := '';\r\n\r\n        if (Data1^.LinkType = ltTrackFuncInfo) and (Data2^.LinkType = ltTrackFuncInfo) then\r\n        begin\r\n          Name1 := TFuncInfo(Data1^.TrackFuncInfo.FuncInfo).ShortName;\r\n          Name2 := TFuncInfo(Data2^.TrackFuncInfo.FuncInfo).ShortName;\r\n        end\r\n        else\r\n        if (Data1^.LinkType = ltTrackUnitInfo) and (Data2^.LinkType = ltTrackUnitInfo) then\r\n        begin\r\n          Name1 := TUnitInfo(Data1^.TrackUnitInfo.UnitInfo).ShortName;\r\n          Name2 := TUnitInfo(Data2^.TrackUnitInfo.UnitInfo).ShortName;\r\n        end;\r\n\r\n        Result := CompareText(Name1, Name2);\r\n      end;\r\n    1:\r\n      begin\r\n        ValueU1 := 0;\r\n        ValueU2 := 0;\r\n\r\n        if (Data1^.LinkType = ltTrackFuncInfo) and (Data2^.LinkType = ltTrackFuncInfo) then\r\n        begin\r\n          ValueU1 := Data1^.TrackFuncInfo.CallCount;\r\n          ValueU2 := Data2^.TrackFuncInfo.CallCount;\r\n        end\r\n        else\r\n        if (Data1^.LinkType = ltTrackUnitInfo) and (Data2^.LinkType = ltTrackUnitInfo) then\r\n        begin\r\n          ValueU1 := Data1^.TrackUnitInfo.CallCount;\r\n          ValueU2 := Data2^.TrackUnitInfo.CallCount;\r\n        end;\r\n\r\n        Result := Compare(ValueU1, ValueU2);\r\n      end;\r\n    2:\r\n      begin\r\n        ValueS1 := 0;\r\n        ValueS2 := 0;\r\n\r\n        if (Data1^.LinkType = ltTrackFuncInfo) and (Data2^.LinkType = ltTrackFuncInfo) then\r\n        begin\r\n          ValueS1 := TMemInfoTrackFuncInfo(Data1^.TrackFuncInfo).Size;\r\n          ValueS2 := TMemInfoTrackFuncInfo(Data2^.TrackFuncInfo).Size;\r\n        end;\r\n\r\n        Result := Compare(ValueS1, ValueS2);\r\n      end;\r\n  end;\r\nend;\r\n\r\nprocedure TMainForm.vstMemInfoFuncTreeFocusChanged(Sender: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex);\r\nvar\r\n  Data: PLinkData;\r\n  TrackFuncInfo: TMemInfoTrackFuncInfo;\r\nbegin\r\n  Data := vstMemInfoFuncTree.GetNodeData(Node);\r\n  case Data^.LinkType of\r\n    ltTrackFuncInfo:\r\n      begin\r\n        vstMemInfoObjStack.Clear;\r\n\r\n        TrackFuncInfo := TMemInfoTrackFuncInfo(Data^.TrackFuncInfo);\r\n\r\n        LoadMemInfoObjects(vstMemInfoObjects, TrackFuncInfo.GetMemList, Node);\r\n        LoadMemInfoParentFunctions(vstMemInfoFuncParents, TrackFuncInfo, Node);\r\n        LoadMemInfoChildFunctions(vstMemInfoFuncChilds, TrackFuncInfo, Node);\r\n\r\n        LoadFunctionSource(svfMemInfoFuncSrc, TFuncInfo(TrackFuncInfo.FuncInfo));\r\n      end;\r\n  else\r\n    begin\r\n      vstMemInfoObjects.Clear;\r\n      vstMemInfoObjStack.Clear;\r\n      vstMemInfoFuncParents.Clear;\r\n      vstMemInfoFuncChilds.Clear;\r\n      svfMemInfoFuncSrc.Clear;\r\n    end;\r\n  end;\r\nend;\r\n\r\nprocedure TMainForm.vstMemInfoFuncTreeGetText(Sender: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex; TextType: TVSTTextType;\r\n  var CellText: string);\r\nvar\r\n  Data: PLinkData;\r\n  ThData: PThreadData;\r\n  ProcData: TProcessData;\r\n  TrackFuncInfo: TMemInfoTrackFuncInfo;\r\n  TrackUnitInfo: TTrackUnitInfo;\r\nbegin\r\n  CellText := ' ';\r\n  Data := vstMemInfoFuncTree.GetNodeData(Node);\r\n  case Data^.LinkType of\r\n    ltProcess:\r\n      begin\r\n        ProcData := Data^.ProcessData;\r\n        case Column of\r\n          0: CellText := ExtractFileName(gvProjectOptions.ApplicationName);\r\n          1: CellText := IntToStr(ProcData.DbgGetMemInfo.Count);\r\n          2: CellText := IntToStr(ProcData.DbgGetMemInfoSize);\r\n        end;\r\n      end;\r\n    ltThread:\r\n      begin\r\n        ThData := Data^.ThreadData;\r\n        case Column of\r\n          0: CellText := ThData^.ThreadAdvInfo^.AsString;\r\n          1: CellText := IntToStr(ThData^.DbgGetMemInfo.Count);\r\n          2: CellText := IntToStr(ThData^.DbgGetMemInfoSize);\r\n        end;\r\n      end;\r\n    ltTrackFuncInfo:\r\n      begin\r\n        TrackFuncInfo := TMemInfoTrackFuncInfo(Data^.TrackFuncInfo);\r\n        case Column of\r\n          0: CellText := TFuncInfo(TrackFuncInfo.FuncInfo).ShortName;\r\n          1: CellText := IntToStr(TrackFuncInfo.CurCount);\r\n          2: CellText := IntToStr(TrackFuncInfo.Size);\r\n        end;\r\n      end;\r\n    ltTrackUnitInfo:\r\n      begin\r\n        TrackUnitInfo := Data^.TrackUnitInfo;\r\n        case Column of\r\n          0: CellText := TUnitInfo(TrackUnitInfo.UnitInfo).ShortName;\r\n          //1: CellText := IntToStr(TrackUnitInfo.CurCount);\r\n        end;\r\n      end;\r\n  end;\r\nend;\r\n\r\nprocedure TMainForm.vstMemInfoObjectsCompareNodes(Sender: TBaseVirtualTree; Node1, Node2: PVirtualNode; Column: TColumnIndex; var Result: Integer);\r\nvar\r\n  Data1, Data2: PLinkData;\r\n  Name1, Name2: String;\r\n  Ptr1, Ptr2: NativeUInt;\r\nbegin\r\n  Data1 := Sender.GetNodeData(Node1);\r\n  Data2 := Sender.GetNodeData(Node2);\r\n\r\n  case Column of\r\n    0:\r\n      begin\r\n        Name1 := '';\r\n        Name2 := '';\r\n\r\n        if (Data1^.LinkType = ltMemInfo) and (Data1^.LinkType = ltMemInfo) then\r\n        begin\r\n          if Sender = vstMemInfoObjects then\r\n          begin\r\n            vstMemInfoObjectsGetText(Sender, Node1, Column, ttNormal, Name1);\r\n            vstMemInfoObjectsGetText(Sender, Node2, Column, ttNormal, Name2);\r\n          end\r\n          else\r\n          if Sender = vstMemList then\r\n          begin\r\n            vstMemListGetText(Sender, Node1, Column, ttNormal, Name1);\r\n            vstMemListGetText(Sender, Node2, Column, ttNormal, Name2);\r\n          end;\r\n        end;\r\n\r\n        if TVirtualStringTree(Sender).Header.SortDirection = sdAscending then\r\n          Result := Compare(Name1, Name2, 1)\r\n        else\r\n          Result := Compare(Name1, Name2, -1);\r\n      end;\r\n    1:\r\n      begin\r\n        Ptr1 := 0;\r\n        Ptr2 := 0;\r\n\r\n        if (Data1^.LinkType = ltMemInfo) and (Data1^.LinkType = ltMemInfo) then\r\n        begin\r\n          Ptr1 := NativeUInt(Data1^.MemPtr);\r\n          Ptr2 := NativeUInt(Data2^.MemPtr);\r\n        end;\r\n\r\n        Result := Compare(Ptr1, Ptr2);\r\n      end;\r\n    2:\r\n      begin\r\n        Name1 := '';\r\n        Name2 := '';\r\n\r\n        if (Data1^.LinkType = ltMemInfo) and (Data1^.LinkType = ltMemInfo) then\r\n        begin\r\n          if Sender = vstMemInfoObjects then\r\n          begin\r\n            vstMemInfoObjectsGetText(Sender, Node1, Column, ttNormal, Name1);\r\n            vstMemInfoObjectsGetText(Sender, Node2, Column, ttNormal, Name2);\r\n          end\r\n          else\r\n          if Sender = vstMemList then\r\n          begin\r\n            vstMemListGetText(Sender, Node1, Column, ttNormal, Name1);\r\n            vstMemListGetText(Sender, Node2, Column, ttNormal, Name2);\r\n          end;\r\n        end;\r\n\r\n        Result := CompareNumberStr(Name1, Name2);\r\n      end;\r\n  end;\r\nend;\r\n\r\nprocedure TMainForm.vstMemInfoObjectsFocusChanged(Sender: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex);\r\nvar\r\n  Data: PLinkData;\r\n\r\n  FuncNode: PVirtualNode;\r\n  FuncLinkData: PLinkData;\r\n\r\n  ThNode: PVirtualNode;\r\n  ThLinkData: PLinkData;\r\n\r\n  ThData: PThreadData;\r\n  ProcData: TProcessData;\r\n  MemInfo: TGetMemInfoList;\r\n  GetMemInfo: TGetMemInfo;\r\nbegin\r\n  vstMemInfoObjStack.Clear;\r\n\r\n  Data := vstMemInfoObjects.GetNodeData(Node);\r\n\r\n  FuncNode := Data^.SyncNode;\r\n  if FuncNode = Nil then Exit;\r\n\r\n  FuncLinkData := vstMemInfoFuncTree.GetNodeData(FuncNode);\r\n\r\n  ThNode := FuncLinkData^.SyncNode;\r\n  if ThNode = Nil then Exit;\r\n\r\n  ThLinkData := vstMemInfoThreads.GetNodeData(ThNode);\r\n  if ThLinkData = Nil then Exit;\r\n\r\n  MemInfo := Nil;\r\n  case ThLinkData^.LinkType of\r\n    ltProcess:\r\n    begin\r\n      ProcData := ThLinkData^.ProcessData;\r\n      MemInfo := ProcData.DbgGetMemInfo;\r\n    end;\r\n    ltThread:\r\n    begin\r\n      ThData := ThLinkData^.ThreadData;\r\n      MemInfo := ThData^.DbgGetMemInfo;\r\n    end;\r\n  end;\r\n\r\n  if (MemInfo <> Nil) then\r\n  begin\r\n    MemInfo.Lock.BeginRead;\r\n    try\r\n      if MemInfo.TryGetValue(Data^.MemPtr, GetMemInfo) then\r\n        LoadMemInfoObjectStack(vstMemInfoObjStack, GetMemInfo, Node);\r\n    finally\r\n      MemInfo.Lock.EndRead;\r\n    end;\r\n  end;\r\nend;\r\n\r\nprocedure TMainForm.vstMemInfoObjectsGetText(Sender: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex; TextType: TVSTTextType; var CellText: string);\r\nvar\r\n  Data: PLinkData;\r\n\r\n  FuncNode: PVirtualNode;\r\n  FuncLinkData: PLinkData;\r\n\r\n  ThNode: PVirtualNode;\r\n  ThLinkData: PLinkData;\r\n  ThData: PThreadData;\r\n  ProcData: TProcessData;\r\n\r\n  MemInfo: TGetMemInfoList;\r\n  GetMemInfo: TGetMemInfo;\r\nbegin\r\n  MemInfo := Nil;\r\n  CellText := '';\r\n\r\n  Data := vstMemInfoObjects.GetNodeData(Node);\r\n\r\n  FuncNode := Data^.SyncNode;\r\n  if FuncNode = Nil then Exit;\r\n\r\n  FuncLinkData := vstMemInfoFuncTree.GetNodeData(FuncNode);\r\n\r\n  //if FuncLinkData^.LinkType <> ltTrackFuncInfo then Exit;\r\n\r\n  ThNode := FuncLinkData^.SyncNode;\r\n  if ThNode = Nil then Exit;\r\n\r\n  ThLinkData := vstMemInfoThreads.GetNodeData(ThNode);\r\n  if ThLinkData = Nil then Exit;\r\n\r\n  case ThLinkData^.LinkType of\r\n    ltProcess:\r\n    begin\r\n      ProcData := ThLinkData^.ProcessData;\r\n      MemInfo := ProcData.DbgGetMemInfo;\r\n    end;\r\n    ltThread:\r\n    begin\r\n      ThData := ThLinkData^.ThreadData;\r\n      MemInfo := ThData^.DbgGetMemInfo;\r\n    end;\r\n  end;\r\n\r\n  case Column of\r\n    0:\r\n      begin\r\n        if (MemInfo <> Nil) then\r\n        begin\r\n          MemInfo.Lock.BeginRead;\r\n          if MemInfo.TryGetValue(Data^.MemPtr, GetMemInfo) then\r\n            CellText := GetMemInfo.GetObjectType;\r\n          MemInfo.Lock.EndRead;\r\n        end;\r\n      end;\r\n    1: CellText := Format('%p', [Data^.MemPtr]);\r\n    2:\r\n      begin\r\n        if (MemInfo <> Nil) then\r\n        begin\r\n          MemInfo.Lock.BeginRead;\r\n          if MemInfo.TryGetValue(Data^.MemPtr, GetMemInfo) then\r\n            CellText := IntToStr(GetMemInfo.Size);\r\n          MemInfo.Lock.EndRead;\r\n        end;\r\n      end;\r\n  end;\r\nend;\r\n\r\nprocedure TMainForm.vstMemInfoObjStackDblClick(Sender: TObject);\r\nvar\r\n  Data: PLinkData;\r\n  StackEntry: TStackEntry;\r\nbegin\r\n  svfMemInfoFuncSrc.Clear;\r\n\r\n  if vstMemInfoObjStack.FocusedNode = Nil then\r\n    Exit;\r\n\r\n  Data := vstMemInfoObjStack.GetNodeData(vstMemInfoObjStack.FocusedNode);\r\n  if Data^.LinkType = ltMemStack then\r\n  begin\r\n    StackEntry := TStackEntry.Create;\r\n    try\r\n      if StackEntry.UpdateInfo(Data^.MemStackPtr) <> slNotFound then\r\n      begin\r\n        if Assigned(StackEntry.FuncInfo) then\r\n        begin\r\n          if Assigned(StackEntry.LineInfo) then\r\n            LoadFunctionSource(svfMemInfoFuncSrc, StackEntry.FuncInfo, StackEntry.LineInfo.LineNo)\r\n          else\r\n            LoadFunctionSource(svfMemInfoFuncSrc, StackEntry.FuncInfo);\r\n\r\n          pcMemInfoFuncInfo.ActivePageIndex := 1;\r\n        end;\r\n      end;\r\n    finally\r\n      FreeAndNil(StackEntry);\r\n    end;\r\n  end;\r\nend;\r\n\r\nprocedure TMainForm.vstMemInfoThreadsFocusChanged(Sender: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex);\r\nvar\r\n  Data: PLinkData;\r\n  ThData: PThreadData;\r\n  ProcData: TProcessData;\r\n  MemInfo: TGetMemInfoList;\r\nbegin\r\n  vstMemList.Clear;\r\n  vstMemStack.Clear;\r\n  svfMemInfoSource.Clear;\r\n\r\n  vstMemInfoFuncTree.Clear;\r\n  vstMemInfoObjects.Clear;\r\n  vstMemInfoObjStack.Clear;\r\n  vstMemInfoFuncParents.Clear;\r\n  vstMemInfoFuncChilds.Clear;\r\n  svfMemInfoFuncSrc.Clear;\r\n\r\n  if Node = nil then Exit;\r\n\r\n  Data := vstMemInfoThreads.GetNodeData(Node);\r\n  case Data^.LinkType of\r\n    ltProcess:\r\n    begin\r\n      ProcData := Data^.ProcessData;\r\n      MemInfo := ProcData.DbgGetMemInfo;\r\n\r\n      case pcMemInfo.ActivePageIndex of\r\n        0: LoadMemInfoObjects(vstMemList, MemInfo, Node);\r\n        //1: LoadMemInfoThreadFunctions(ThData, Node);\r\n      end;\r\n    end;\r\n    ltThread:\r\n    begin\r\n      ThData := Data^.ThreadData;\r\n      MemInfo := ThData^.DbgGetMemInfo;\r\n\r\n      case pcMemInfo.ActivePageIndex of\r\n        0: LoadMemInfoObjects(vstMemList, MemInfo, Node);\r\n        1: LoadMemInfoThreadFunctions(ThData, Node);\r\n      end;\r\n    end;\r\n  end;\r\nend;\r\n\r\nprocedure TMainForm.vstMemInfoThreadsGetText(Sender: TBaseVirtualTree;\r\n  Node: PVirtualNode; Column: TColumnIndex; TextType: TVSTTextType;\r\n  var CellText: string);\r\nvar\r\n  Data: PLinkData;\r\n  ThData: PThreadData;\r\n  ProcData: TProcessData;\r\nbegin\r\n  CellText := ' ';\r\n\r\n  Data := Sender.GetNodeData(Node);\r\n  case Data^.LinkType of\r\n    ltProcess:\r\n      begin\r\n        ProcData := Data^.ProcessData;\r\n        if ProcData <> nil then\r\n          case Column of\r\n            0: CellText := ExtractFileName(gvProjectOptions.ApplicationName);\r\n            1: CellText := ProcessIDToStr(ProcData.ProcessID);\r\n            2: if ProcData.ProcessGetMemCount > 0 then\r\n                 CellText := Format('%d', [ProcData.ProcessGetMemCount]);\r\n            3: if ProcData.ProcessGetMemCount > 0 then\r\n                 CellText := Format('%d', [ProcData.ProcessGetMemSize]);\r\n          end;\r\n      end;\r\n    ltThread:\r\n      begin\r\n        ThData := Data^.ThreadData;\r\n        if ThData <> nil then\r\n          case Column of\r\n            0: CellText := ThData^.ThreadAdvInfo^.AsString;\r\n            1: CellText := ThreadIDToStr(ThData^.ThreadID);\r\n            2: if ThData^.DbgGetMemInfo.Count > 0 then\r\n                 CellText := Format('%d', [ThData^.DbgGetMemInfo.Count]);\r\n            3: if ThData^.DbgGetMemInfo.Count > 0 then\r\n                 CellText := Format('%d', [ThData^.DbgGetMemInfoSize]);\r\n          end;\r\n      end;\r\n  end;\r\nend;\r\n\r\nprocedure TMainForm.vstMemListFocusChanged(Sender: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex);\r\nvar\r\n  Data: PLinkData;\r\n  ThNode: PVirtualNode;\r\n  ThLinkData: PLinkData;\r\n\r\n  ThData: PThreadData;\r\n  ProcData: TProcessData;\r\n  MemInfo: TGetMemInfoList;\r\n  GetMemInfo: TGetMemInfo;\r\nbegin\r\n  vstMemStack.Clear;\r\n  svfMemInfoSource.Clear;\r\n\r\n  Data := vstMemList.GetNodeData(Node);\r\n\r\n  MemInfo := Nil;\r\n  ThNode := Data^.SyncNode;\r\n  if ThNode = Nil then Exit;\r\n\r\n  ThLinkData := vstMemInfoThreads.GetNodeData(ThNode);\r\n  if ThLinkData = Nil then Exit;\r\n\r\n  case ThLinkData^.LinkType of\r\n    ltProcess:\r\n    begin\r\n      ProcData := ThLinkData^.ProcessData;\r\n      MemInfo := ProcData.DbgGetMemInfo;\r\n    end;\r\n    ltThread:\r\n    begin\r\n      ThData := ThLinkData^.ThreadData;\r\n      MemInfo := ThData^.DbgGetMemInfo;\r\n    end;\r\n  end;\r\n\r\n  if (MemInfo <> Nil) then\r\n  begin\r\n    MemInfo.Lock.BeginRead;\r\n    try\r\n      if MemInfo.TryGetValue(Data^.MemPtr, GetMemInfo) then\r\n        LoadMemInfoObjectStack(vstMemStack, GetMemInfo, Node);\r\n    finally\r\n      MemInfo.Lock.EndRead;\r\n    end;\r\n  end;\r\nend;\r\n\r\nprocedure TMainForm.vstMemListGetText(Sender: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex; TextType: TVSTTextType; var CellText: string);\r\nvar\r\n  Data: PLinkData;\r\n  ThNode: PVirtualNode;\r\n  ThLinkData: PLinkData;\r\n\r\n  ThData: PThreadData;\r\n  ProcData: TProcessData;\r\n  MemInfo: TGetMemInfoList;\r\n  GetMemInfo: TGetMemInfo;\r\nbegin\r\n  MemInfo := Nil;\r\n  CellText := '';\r\n\r\n  Data := vstMemList.GetNodeData(Node);\r\n  ThNode := Data^.SyncNode;\r\n  if ThNode = Nil then Exit;\r\n\r\n  ThLinkData := vstMemInfoThreads.GetNodeData(ThNode);\r\n  if ThLinkData = Nil then Exit;\r\n\r\n  case ThLinkData^.LinkType of\r\n    ltProcess:\r\n    begin\r\n      ProcData := ThLinkData^.ProcessData;\r\n      MemInfo := ProcData.DbgGetMemInfo;\r\n    end;\r\n    ltThread:\r\n    begin\r\n      ThData := ThLinkData^.ThreadData;\r\n      MemInfo := ThData^.DbgGetMemInfo;\r\n    end;\r\n  end;\r\n\r\n  case Column of\r\n    0:\r\n      begin\r\n        if (MemInfo <> Nil) then\r\n        begin\r\n          MemInfo.Lock.BeginRead;\r\n          if MemInfo.TryGetValue(Data^.MemPtr, GetMemInfo) then\r\n            CellText := GetMemInfo.GetObjectType;\r\n          MemInfo.Lock.EndRead;\r\n        end;\r\n      end;\r\n    1: CellText := Format('%p', [Data^.MemPtr]);\r\n    2:\r\n      begin\r\n        if (MemInfo <> Nil) then\r\n        begin\r\n          MemInfo.Lock.BeginRead;\r\n          if MemInfo.TryGetValue(Data^.MemPtr, GetMemInfo) then\r\n            CellText := IntToStr(GetMemInfo.Size);\r\n          MemInfo.Lock.EndRead;\r\n        end;\r\n      end;\r\n  end;\r\nend;\r\n\r\nprocedure TMainForm.vstMemStackFocusChanged(Sender: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex);\r\nvar\r\n  Data: PLinkData;\r\n  StackEntry: TStackEntry;\r\nbegin\r\n  svfMemInfoSource.Clear;\r\n\r\n  Data := vstMemStack.GetNodeData(Node);\r\n  if Data^.LinkType = ltMemStack then\r\n  begin\r\n    StackEntry := TStackEntry.Create;\r\n    try\r\n      if StackEntry.UpdateInfo(Data^.MemStackPtr) <> slNotFound then\r\n      begin\r\n        if Assigned(StackEntry.FuncInfo) then\r\n        begin\r\n          if Assigned(StackEntry.LineInfo) then\r\n            LoadFunctionSource(svfMemInfoSource, StackEntry.FuncInfo, StackEntry.LineInfo.LineNo)\r\n          else\r\n            LoadFunctionSource(svfMemInfoSource, StackEntry.FuncInfo);\r\n        end;\r\n      end;\r\n    finally\r\n      FreeAndNil(StackEntry);\r\n    end;\r\n  end;\r\nend;\r\n\r\nprocedure TMainForm.vstMemStackGetText(Sender: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex; TextType: TVSTTextType; var CellText: string);\r\nvar\r\n  Data: PLinkData;\r\n  StackEntry: TStackEntry;\r\n  FindResult: TFindResult;\r\nbegin\r\n  CellText := ' ';\r\n\r\n  Data := Sender.GetNodeData(Node);\r\n  if Data^.LinkType = ltMemStack then\r\n  begin\r\n      case Column of\r\n        0: CellText := Format('%p', [Data^.MemStackPtr]);\r\n      else\r\n        begin\r\n          StackEntry := TStackEntry.Create;\r\n          try\r\n            FindResult := StackEntry.UpdateInfo(Data^.MemStackPtr);\r\n\r\n            case Column of\r\n              1: if (FindResult <> slNotFound) and Assigned(StackEntry.UnitInfo) then\r\n                   CellText := StackEntry.UnitInfo.ShortName\r\n                 else\r\n                   CellText := 'unknown';\r\n              2: if (FindResult in [slFoundExact, slFoundNotExact]) and Assigned(StackEntry.LineInfo) then\r\n                   CellText := IntToStr(StackEntry.LineInfo.LineNo);\r\n              3: if (FindResult <> slNotFound) and Assigned(StackEntry.FuncInfo) then\r\n                   CellText := StackEntry.FuncInfo.ShortName\r\n                 else\r\n                   CellText := 'unknown';\r\n            end;\r\n          finally\r\n            FreeAndNil(StackEntry);\r\n          end;\r\n        end;\r\n      end;\r\n  end;\r\nend;\r\n\r\nprocedure TMainForm.vstThreadsCollapsed(Sender: TBaseVirtualTree; Node: PVirtualNode);\r\nbegin\r\n  SyncNodes(Sender, Node);\r\nend;\r\n\r\nprocedure TMainForm.vstThreadsCompareNodes(Sender: TBaseVirtualTree; Node1,\r\n  Node2: PVirtualNode; Column: TColumnIndex; var Result: Integer);\r\nvar\r\n  Data1, Data2: PLinkData;\r\n  Name1, Name2: String;\r\n  ValueU1, ValueU2: UInt64;\r\nbegin\r\n  Data1 := vstThreads.GetNodeData(Node1);\r\n  Data2 := vstThreads.GetNodeData(Node2);\r\n\r\n  case Column of\r\n    0:\r\n      begin\r\n        Name1 := '';\r\n        Name2 := '';\r\n\r\n        if (Data1^.LinkType = ltProcess) and (Data2^.LinkType = ltProcess) then\r\n        begin\r\n          Name1 := ExtractFileName(gvProjectOptions.ApplicationName);\r\n          Name2 := ExtractFileName(gvProjectOptions.ApplicationName);\r\n        end\r\n        else\r\n        if (Data1^.LinkType = ltThread) and (Data2^.LinkType = ltThread) then\r\n        begin\r\n          Name1 := Data1^.ThreadData^.ThreadAdvInfo^.AsString;\r\n          Name2 := Data2^.ThreadData^.ThreadAdvInfo^.AsString;\r\n        end;\r\n\r\n        Result := CompareText(Name1, Name2);\r\n      end;\r\n    1:\r\n      begin\r\n        ValueU1 := 0;\r\n        ValueU2 := 0;\r\n\r\n        if (Data1^.LinkType = ltProcess) and (Data2^.LinkType = ltProcess) then\r\n        begin\r\n          ValueU1 := Data1^.ProcessData.ProcessID;\r\n          ValueU2 := Data2^.ProcessData.ProcessID;\r\n        end\r\n        else\r\n        if (Data1^.LinkType = ltThread) and (Data2^.LinkType = ltThread) then\r\n        begin\r\n          ValueU1 := Data1^.ThreadData^.ThreadID;\r\n          ValueU2 := Data2^.ThreadData^.ThreadID;\r\n        end;\r\n\r\n        Result := Compare(ValueU1, ValueU2);\r\n      end;\r\n    2:\r\n      begin\r\n        ValueU1 := 0;\r\n        ValueU2 := 0;\r\n\r\n        if (Data1^.LinkType = ltProcess) and (Data2^.LinkType = ltProcess) then\r\n        begin\r\n          ValueU1 := Data1^.ProcessData.CPUTime;\r\n          ValueU2 := Data2^.ProcessData.CPUTime;\r\n        end\r\n        else\r\n        if (Data1^.LinkType = ltThread) and (Data2^.LinkType = ltThread) then\r\n        begin\r\n          ValueU1 := Data1^.ThreadData^.CPUTime;\r\n          ValueU2 := Data2^.ThreadData^.CPUTime;\r\n        end;\r\n        Result := Compare(ValueU1, ValueU2);\r\n      end;\r\n  end;\r\nend;\r\n\r\nprocedure TMainForm.vstColumnResize(Sender: TVTHeader; Column: TColumnIndex);\r\nvar\r\n  W: Integer;\r\n  I: Integer;\r\n  C: TVirtualTreeColumn;\r\n  vTree: TVirtualStringTree;\r\n  SaveOnResize: TNotifyEvent;\r\nbegin\r\n  vTree := TVirtualStringTree(Sender.Treeview);\r\n\r\n  SaveOnResize := vTree.OnResize;\r\n  vTree.OnResize := nil;\r\n  try\r\n    W := 0;\r\n    for I := 0 to Sender.Columns.Count - 1 do\r\n    begin\r\n      C := Sender.Columns[I];\r\n      if coVisible in C.Options then\r\n        Inc(W, C.Width);\r\n    end;\r\n\r\n    vTree.ClientWidth := W;\r\n  finally\r\n    vTree.OnResize := SaveOnResize;\r\n  end;\r\nend;\r\n\r\nprocedure TMainForm.vstThreadsDrawText(Sender: TBaseVirtualTree;\r\n  TargetCanvas: TCanvas; Node: PVirtualNode; Column: TColumnIndex;\r\n  const Text: string; const CellRect: TRect; var DefaultDraw: Boolean);\r\nvar\r\n  Data: PLinkData;\r\n  ThData: PThreadData;\r\n  ProcData: TProcessData;\r\nbegin\r\n  Data := Sender.GetNodeData(Node);\r\n  case Data^.LinkType of\r\n    ltProcess:\r\n      begin\r\n        ProcData := Data^.ProcessData;\r\n        if (ProcData <> nil) and (ProcData.State = psActive) then\r\n          TargetCanvas.Font.Style := [fsBold];\r\n      end;\r\n    ltThread:\r\n      begin\r\n        ThData := Data^.ThreadData;\r\n        if (ThData <> nil) and (ThData^.State = tsActive) then\r\n          TargetCanvas.Font.Style := [fsBold];\r\n      end;\r\n  end;\r\nend;\r\n\r\nprocedure TMainForm.vstThreadsExpanded(Sender: TBaseVirtualTree; Node: PVirtualNode);\r\nbegin\r\n  SyncNodes(Sender, Node);\r\nend;\r\n\r\nprocedure TMainForm.vstThreadsGetNodeDataSize(Sender: TBaseVirtualTree; var NodeDataSize: Integer);\r\nbegin\r\n  NodeDataSize := SizeOf(TLinkData);\r\nend;\r\n\r\nfunction TMainForm.ElapsedToTime(const Elapsed: UInt64): String;\r\nbegin\r\n  Result := FormatDateTime('nn:ss.zzz', Int64ToDateTime(Elapsed));\r\nend;\r\n\r\nprocedure TMainForm.vstThreadsGetText(Sender: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex; TextType: TVSTTextType;\r\n  var CellText: string);\r\nvar\r\n  Data: PLinkData;\r\n  ThData: PThreadData;\r\n  ProcData: TProcessData;\r\nbegin\r\n  Data := Sender.GetNodeData(Node);\r\n  case Data^.LinkType of\r\n    ltProcess:\r\n      begin\r\n        ProcData := Data^.ProcessData;\r\n        if ProcData <> nil then\r\n          case Column of\r\n            0: CellText := ExtractFileName(gvProjectOptions.ApplicationName);\r\n            1: CellText := ProcessIDToStr(ProcData.ProcessID);\r\n            2: CellText := ElapsedToTime(ProcData.CPUTime);\r\n          end;\r\n      end;\r\n    ltThread:\r\n      begin\r\n        ThData := Data^.ThreadData;\r\n        if ThData <> nil then\r\n          case Column of\r\n            0: CellText := ThData^.ThreadAdvInfo^.AsString;\r\n            1: CellText := ThreadIDToStr(ThData^.ThreadID);\r\n            2: CellText := ElapsedToTime(ThData^.CPUTime);\r\n          end;\r\n      end;\r\n  end;\r\nend;\r\n\r\nprocedure TMainForm.vstThreadsIncrementalSearch(Sender: TBaseVirtualTree;\r\n  Node: PVirtualNode; const SearchText: string; var Result: Integer);\r\nvar\r\n  Data: PLinkData;\r\n  Name: String;\r\nbegin\r\n  Data := vstThreads.GetNodeData(Node);\r\n\r\n  Name := '';\r\n  if (Data^.LinkType = ltProcess) then\r\n    Name := ExtractFileName(gvProjectOptions.ApplicationName)\r\n  else\r\n  if (Data^.LinkType = ltThread) then\r\n    Name := Data^.ThreadData^.ThreadAdvInfo^.AsString;\r\n\r\n  Result := AnsiStrLIComp(PChar(SearchText), PChar(Name), Min(Length(SearchText), Length(Name)));\r\nend;\r\n\r\nprocedure TMainForm.vstThreadsScroll(Sender: TBaseVirtualTree; DeltaX, DeltaY: Integer);\r\nbegin\r\n  if DeltaY <> 0 then\r\n    vdtTimeLine.OffsetY := vstThreads.OffsetY;\r\nend;\r\n\r\nprocedure TMainForm.vstTrackFuncChildsGetText(Sender: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex; TextType: TVSTTextType;\r\n  var CellText: string);\r\nvar\r\n  Data: PLinkData;\r\n  TrackCallFuncInfo: TCallFuncInfo;\r\n  TrackFuncInfo: TCodeTrackFuncInfo;\r\nbegin\r\n  CellText := ' ';\r\n\r\n  Data := vstTrackFuncChilds.GetNodeData(Node);\r\n  case Data^.LinkType of\r\n    ltDbgUnitInfo:\r\n      begin\r\n        case Column of\r\n          0: CellText := Data^.DbgUnitInfo.ShortName;\r\n        end;\r\n      end;\r\n    ltTrackFuncInfo:\r\n      begin\r\n        TrackFuncInfo := TCodeTrackFuncInfo(Data^.TrackFuncInfo);\r\n        case Column of\r\n          0: CellText := TFuncInfo(TrackFuncInfo.FuncInfo).ShortName;\r\n          2: CellText := IntToStr(TrackFuncInfo.CallCount);\r\n          3: CellText := ElapsedTimeToStr(vstTrackFuncChilds, Data, TrackFuncInfo.CPUElapsed);\r\n        end;\r\n      end;\r\n    ltTrackCallFuncInfo:\r\n      begin\r\n        TrackCallFuncInfo := Data^.TrackCallFuncInfo;\r\n        case Column of\r\n          0: CellText := TFuncInfo(TrackCallFuncInfo.FuncInfo).ShortName;\r\n          1: CellText := IntToStr(TrackCallFuncInfo.LineNo);\r\n          2:\r\n            begin\r\n              CellText := IntToStr(TrackCallFuncInfo.CallCount);\r\n              if gvDebuger.SamplingMethod then\r\n              begin\r\n                Data := vstTrackFuncs.GetNodeData(Data^.SyncNode);\r\n                if Data^.LinkType = ltTrackFuncInfo then\r\n                begin\r\n                  TrackFuncInfo := TCodeTrackFuncInfo(Data^.TrackFuncInfo);\r\n                  CellText := CellText + PercentStr(TrackCallFuncInfo.CallCount, TrackFuncInfo.CallCount);\r\n                end;\r\n              end;\r\n            end;\r\n          3: CellText := ElapsedTimeToStr(vstTrackFuncChilds, Data, TrackCallFuncInfo.Elapsed);\r\n        end;\r\n      end;\r\n  end;\r\nend;\r\n\r\nprocedure TMainForm.vstTrackFuncChildsIncrementalSearch(\r\n  Sender: TBaseVirtualTree; Node: PVirtualNode; const SearchText: string;\r\n  var Result: Integer);\r\nvar\r\n  Data: PLinkData;\r\n  Name: String;\r\nbegin\r\n  Data := vstTrackFuncChilds.GetNodeData(Node);\r\n\r\n  Name := '';\r\n  if (Data^.LinkType = ltTrackCallFuncInfo) then\r\n    Name := TFuncInfo(Data^.TrackCallFuncInfo.FuncInfo).ShortName\r\n  else\r\n  if (Data^.LinkType = ltTrackFuncInfo) then\r\n    Name := TFuncInfo(Data^.TrackFuncInfo.FuncInfo).ShortName\r\n  else\r\n  if (Data^.LinkType = ltTrackUnitInfo) then\r\n    Name := TUnitInfo(Data^.TrackUnitInfo.UnitInfo).ShortName;\r\n\r\n  Result := AnsiStrLIComp(PChar(SearchText), PChar(Name), Min(Length(SearchText), Length(Name)));\r\nend;\r\n\r\nprocedure TMainForm.vstTrackFuncParentDblClick(Sender: TObject);\r\nvar\r\n  Node: PVirtualNode;\r\n  Data: PLinkData;\r\n  FuncInfo: TFuncInfo;\r\n  FuncNode: PVirtualNode;\r\n  LineNo: Cardinal;\r\nbegin\r\n  Node := vstTrackFuncParent.FocusedNode;\r\n  if Assigned(Node) then\r\n  begin\r\n    Data := vstTrackFuncParent.GetNodeData(Node);\r\n    if Data^.LinkType = ltTrackCallFuncInfo then\r\n    begin\r\n      FuncInfo := TFuncInfo(Data^.TrackCallFuncInfo.FuncInfo);\r\n      if Assigned(FuncInfo) then\r\n      begin\r\n        LineNo := Data^.TrackCallFuncInfo.LineNo;\r\n\r\n        FuncNode := FindTrackFuncNode(vstTrackFuncs, FuncInfo);\r\n        if Assigned(FuncNode) then\r\n        begin\r\n          vstTrackFuncs.ClearSelection;\r\n          vstTrackFuncs.FocusedNode := FuncNode;\r\n          vstTrackFuncs.Selected[FuncNode] := True;\r\n\r\n          if LineNo <> 0 then\r\n            LoadFunctionSource(svfTrackFuncAdvSource, FuncInfo, LineNo);\r\n        end;\r\n      end;\r\n    end;\r\n  end;\r\nend;\r\n\r\nprocedure TMainForm.vstTrackFuncLinksDrawText(Sender: TBaseVirtualTree; TargetCanvas: TCanvas; Node: PVirtualNode; Column: TColumnIndex;\r\n  const Text: string; const CellRect: TRect; var DefaultDraw: Boolean);\r\nvar\r\n  Data: PLinkData;\r\nbegin\r\n  Data := Sender.GetNodeData(Node);\r\n  case Data^.LinkType of\r\n    ltTrackFuncInfo, ltDbgUnitInfo, ltTrackUnitInfo:\r\n      TargetCanvas.Font.Style := [fsBold];\r\n  end;\r\nend;\r\n\r\nprocedure TMainForm.vstTrackFuncChildsCompareNodes(Sender: TBaseVirtualTree;\r\n  Node1, Node2: PVirtualNode; Column: TColumnIndex; var Result: Integer);\r\nvar\r\n  Data1, Data2: PLinkData;\r\n  Value1, Value2: UInt64;\r\n  Name1, Name2: String;\r\nbegin\r\n  Data1 := vstTrackFuncChilds.GetNodeData(Node1);\r\n  Data2 := vstTrackFuncChilds.GetNodeData(Node2);\r\n\r\n  case Column of\r\n    0:\r\n      begin\r\n        Name1 := '';\r\n        Name2 := '';\r\n\r\n        if (Data1^.LinkType = ltTrackCallFuncInfo) and (Data2^.LinkType = ltTrackCallFuncInfo) then\r\n        begin\r\n          Name1 := TFuncInfo(Data1^.TrackCallFuncInfo.FuncInfo).ShortName;\r\n          Name2 := TFuncInfo(Data2^.TrackCallFuncInfo.FuncInfo).ShortName;\r\n        end\r\n        else\r\n        if (Data1^.LinkType = ltTrackFuncInfo) and (Data2^.LinkType = ltTrackFuncInfo) then\r\n        begin\r\n          Name1 := TFuncInfo(Data1^.TrackFuncInfo.FuncInfo).ShortName;\r\n          Name2 := TFuncInfo(Data2^.TrackFuncInfo.FuncInfo).ShortName;\r\n        end\r\n        else\r\n        if (Data1^.LinkType = ltTrackUnitInfo) and (Data2^.LinkType = ltTrackUnitInfo) then\r\n        begin\r\n          Name1 := TUnitInfo(Data1^.TrackUnitInfo.UnitInfo).ShortName;\r\n          Name2 := TUnitInfo(Data2^.TrackUnitInfo.UnitInfo).ShortName;\r\n        end;\r\n\r\n        Result := CompareText(Name1, Name2);\r\n      end;\r\n    1:\r\n      begin\r\n        Value1 := 0;\r\n        Value2 := 0;\r\n\r\n\r\n        if (Data1^.LinkType = ltTrackCallFuncInfo) and (Data2^.LinkType = ltTrackCallFuncInfo) then\r\n        begin\r\n          Value1 := Data1^.TrackCallFuncInfo.LineNo;\r\n          Value2 := Data2^.TrackCallFuncInfo.LineNo;\r\n        end\r\n        else\r\n        if (Data1^.LinkType = ltTrackFuncInfo) and (Data2^.LinkType = ltTrackFuncInfo) then\r\n        begin\r\n          Value1 := Data1^.TrackFuncInfo.CallCount;\r\n          Value2 := Data2^.TrackFuncInfo.CallCount;\r\n        end\r\n        else\r\n        if (Data1^.LinkType = ltTrackUnitInfo) and (Data2^.LinkType = ltTrackUnitInfo) then\r\n        begin\r\n          //     -  \r\n          Value1 := Data1^.TrackUnitInfo.CallCount;\r\n          Value2 := Data2^.TrackUnitInfo.CallCount;\r\n        end;\r\n\r\n        Result := Compare(Value1, Value2);\r\n      end;\r\n    2:\r\n      begin\r\n        Value1 := 0;\r\n        Value2 := 0;\r\n\r\n        if (Data1^.LinkType = ltTrackCallFuncInfo) and (Data2^.LinkType = ltTrackCallFuncInfo) then\r\n        begin\r\n          Value1 := Data1^.TrackCallFuncInfo.CallCount;\r\n          Value2 := Data2^.TrackCallFuncInfo.CallCount;\r\n        end\r\n        else\r\n        if (Data1^.LinkType = ltTrackFuncInfo) and (Data2^.LinkType = ltTrackFuncInfo) then\r\n        begin\r\n          Value1 := TCodeTrackFuncInfo(Data1^.TrackFuncInfo).CPUElapsed;\r\n          Value2 := TCodeTrackFuncInfo(Data2^.TrackFuncInfo).CPUElapsed;\r\n        end\r\n        else\r\n        if (Data1^.LinkType = ltTrackUnitInfo) and (Data2^.LinkType = ltTrackUnitInfo) then\r\n        begin\r\n          //     -  \r\n          Value1 := Data1^.TrackUnitInfo.CallCount;\r\n          Value2 := Data2^.TrackUnitInfo.CallCount;\r\n        end;\r\n\r\n        Result := Compare(Value1, Value2);\r\n      end;\r\n    3:\r\n      begin\r\n        Value1 := 0;\r\n        Value2 := 0;\r\n\r\n        if (Data1^.LinkType = ltTrackCallFuncInfo) and (Data2^.LinkType = ltTrackCallFuncInfo) then\r\n        begin\r\n          Value1 := Data1^.TrackCallFuncInfo.Elapsed;\r\n          Value2 := Data2^.TrackCallFuncInfo.Elapsed;\r\n        end;\r\n\r\n        Result := Compare(Value1, Value2);\r\n      end;\r\n  end;\r\nend;\r\n\r\nprocedure TMainForm.vstTrackFuncChildsDblClick(Sender: TObject);\r\nvar\r\n  Node: PVirtualNode;\r\n  Data: PLinkData;\r\n  FuncInfo: TFuncInfo;\r\n  FuncNode: PVirtualNode;\r\nbegin\r\n  Node := vstTrackFuncChilds.FocusedNode;\r\n  if Assigned(Node) then\r\n  begin\r\n    Data := vstTrackFuncChilds.GetNodeData(Node);\r\n    if Data^.LinkType = ltTrackCallFuncInfo then\r\n    begin\r\n      FuncInfo := TFuncInfo(Data^.TrackCallFuncInfo.FuncInfo);\r\n      if Assigned(FuncInfo) then\r\n      begin\r\n        FuncNode := FindTrackFuncNode(vstTrackFuncs, FuncInfo);\r\n        if Assigned(FuncNode) then\r\n        begin\r\n          vstTrackFuncs.ClearSelection;\r\n          vstTrackFuncs.FocusedNode := FuncNode;\r\n          vstTrackFuncs.Selected[FuncNode] := True;\r\n        end;\r\n      end;\r\n    end;\r\n  end;\r\nend;\r\n\r\nFunction TMainForm.ElapsedTimeToStr(Tree: TBaseVirtualTree; Data: PLinkData; const Elapsed: UInt64): String;\r\nvar\r\n  SyncNode: PVirtualNode;\r\n  SyncData: PLinkData;\r\n\r\n  ThData: PThreadData;\r\n  ProcData: TProcessData;\r\nbegin\r\n  Result := ' ';\r\n\r\n  SyncNode := Data^.SyncNode;\r\n  SyncData := Tree.GetNodeData(SyncNode);\r\n\r\n  if SyncData^.LinkType = ltTrackFuncInfo then\r\n  begin\r\n    SyncNode := SyncData^.SyncNode;\r\n    SyncData := Tree.GetNodeData(SyncNode);\r\n\r\n    case SyncData^.LinkType of\r\n      ltThread:\r\n        begin\r\n          ThData := SyncData^.ThreadData;\r\n          Result := FuncElapsedToTime(ThData^.CPUTime, ThData^.CPUElapsed, Elapsed);\r\n        end;\r\n      ltProcess:\r\n        begin\r\n          ProcData := SyncData^.ProcessData;\r\n          Result := FuncElapsedToTime(ProcData.CPUTime, ProcData.CPUElapsed, Elapsed);\r\n        end;\r\n    end;\r\n  end;\r\nend;\r\n\r\nprocedure TMainForm.vstTrackFuncParentGetText(Sender: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex; TextType: TVSTTextType;\r\n  var CellText: string);\r\nvar\r\n  Data: PLinkData;\r\n  TrackCallFuncInfo: TCallFuncInfo;\r\n  TrackFuncInfo: TCodeTrackFuncInfo;\r\nbegin\r\n  CellText := ' ';\r\n\r\n  Data := vstTrackFuncParent.GetNodeData(Node);\r\n  case Data^.LinkType of\r\n    ltDbgUnitInfo:\r\n      begin\r\n        case Column of\r\n          0: CellText := Data^.DbgUnitInfo.ShortName;\r\n        end;\r\n      end;\r\n    ltTrackFuncInfo:\r\n      begin\r\n        TrackFuncInfo := TCodeTrackFuncInfo(Data^.TrackFuncInfo);\r\n        case Column of\r\n          0: CellText := TFuncInfo(TrackFuncInfo.FuncInfo).ShortName;\r\n          2: CellText := IntToStr(TrackFuncInfo.CallCount);\r\n          3: CellText := ElapsedTimeToStr(vstTrackFuncParent, Data, TrackFuncInfo.CPUElapsed);\r\n        end;\r\n      end;\r\n    ltTrackCallFuncInfo:\r\n      begin\r\n        TrackCallFuncInfo := Data^.TrackCallFuncInfo;\r\n        case Column of\r\n          0: CellText := TFuncInfo(TrackCallFuncInfo.FuncInfo).ShortName;\r\n          1: CellText := IntToStr(TrackCallFuncInfo.LineNo);\r\n          2: CellText := IntToStr(TrackCallFuncInfo.CallCount);\r\n          3: CellText := ElapsedTimeToStr(vstTrackFuncParent, Data, TrackCallFuncInfo.Elapsed);\r\n        end;\r\n      end;\r\n  end;\r\nend;\r\n\r\nprocedure TMainForm.vstTrackFuncsCompareNodes(Sender: TBaseVirtualTree; Node1, Node2: PVirtualNode; Column: TColumnIndex; var Result: Integer);\r\nvar\r\n  Data1, Data2: PLinkData;\r\n  Value1, Value2: UInt64;\r\n  Name1, Name2: String;\r\nbegin\r\n  Data1 := vstTrackFuncs.GetNodeData(Node1);\r\n  Data2 := vstTrackFuncs.GetNodeData(Node2);\r\n\r\n  case Column of\r\n    0:\r\n      begin\r\n        Name1 := '';\r\n        Name2 := '';\r\n\r\n        if (Data1^.LinkType = ltTrackFuncInfo) and (Data2^.LinkType = ltTrackFuncInfo) then\r\n        begin\r\n          Name1 := TFuncInfo(Data1^.TrackFuncInfo.FuncInfo).ShortName;\r\n          Name2 := TFuncInfo(Data2^.TrackFuncInfo.FuncInfo).ShortName;\r\n        end\r\n        else\r\n        if (Data1^.LinkType = ltTrackUnitInfo) and (Data2^.LinkType = ltTrackUnitInfo) then\r\n        begin\r\n          Name1 := TUnitInfo(Data1^.TrackUnitInfo.UnitInfo).ShortName;\r\n          Name2 := TUnitInfo(Data2^.TrackUnitInfo.UnitInfo).ShortName;\r\n        end;\r\n\r\n        Result := CompareText(Name1, Name2);\r\n      end;\r\n    1:\r\n      begin\r\n        Value1 := 0;\r\n        Value2 := 0;\r\n\r\n        if (Data1^.LinkType = ltTrackFuncInfo) and (Data2^.LinkType = ltTrackFuncInfo) then\r\n        begin\r\n          Value1 := Data1^.TrackFuncInfo.CallCount;\r\n          Value2 := Data2^.TrackFuncInfo.CallCount;\r\n        end\r\n        else\r\n        if (Data1^.LinkType = ltTrackUnitInfo) and (Data2^.LinkType = ltTrackUnitInfo) then\r\n        begin\r\n          //     -  \r\n          Value1 := Data1^.TrackUnitInfo.CallCount;\r\n          Value2 := Data2^.TrackUnitInfo.CallCount;\r\n        end;\r\n\r\n        Result := Compare(Value1, Value2);\r\n      end;\r\n    2:\r\n      begin\r\n        Value1 := 0;\r\n        Value2 := 0;\r\n\r\n        if (Data1^.LinkType = ltTrackFuncInfo) and (Data2^.LinkType = ltTrackFuncInfo) then\r\n        begin\r\n          Value1 := TCodeTrackFuncInfo(Data1^.TrackFuncInfo).CPUElapsed;\r\n          Value2 := TCodeTrackFuncInfo(Data2^.TrackFuncInfo).CPUElapsed;\r\n        end\r\n        else\r\n        if (Data1^.LinkType = ltTrackUnitInfo) and (Data2^.LinkType = ltTrackUnitInfo) then\r\n        begin\r\n          //     -  \r\n          Value1 := Data1^.TrackUnitInfo.CallCount;\r\n          Value2 := Data2^.TrackUnitInfo.CallCount;\r\n        end;\r\n\r\n        Result := Compare(Value1, Value2);\r\n      end;\r\n  end;\r\nend;\r\n\r\nprocedure TMainForm.vstTrackFuncsDrawText(Sender: TBaseVirtualTree; TargetCanvas: TCanvas; Node: PVirtualNode; Column: TColumnIndex;\r\n  const Text: string; const CellRect: TRect; var DefaultDraw: Boolean);\r\nvar\r\n  Data: PLinkData;\r\nbegin\r\n  Data := Sender.GetNodeData(Node);\r\n  case Data^.LinkType of\r\n    ltProcess, ltThread, ltTrackUnitInfo:\r\n      TargetCanvas.Font.Style := [fsBold];\r\n  end;\r\nend;\r\n\r\nprocedure TMainForm.vstTrackFuncsFocusChanged(Sender: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex);\r\nvar\r\n  Data: PLinkData;\r\nbegin\r\n  Data := vstTrackFuncs.GetNodeData(Node);\r\n  case Data^.LinkType of\r\n    ltTrackFuncInfo:\r\n      begin\r\n        LoadTrackParentFunctions(Data^.TrackFuncInfo, Node);\r\n        LoadTrackChildFunctions(Data^.TrackFuncInfo, Node);\r\n\r\n        LoadFunctionSource(svfTrackFuncAdvSource, TFuncInfo(Data^.TrackFuncInfo.FuncInfo));\r\n      end;\r\n  else\r\n    begin\r\n      vstTrackFuncParent.Clear;\r\n      vstTrackFuncChilds.Clear;\r\n      svfTrackFuncAdvSource.Clear;\r\n    end;\r\n  end;\r\nend;\r\n\r\nprocedure TMainForm.vstTrackFuncsFocusChanging(Sender: TBaseVirtualTree; OldNode, NewNode: PVirtualNode; OldColumn, NewColumn: TColumnIndex;\r\n  var Allowed: Boolean);\r\nvar\r\n  Data: PLinkData;\r\nbegin\r\n  if Assigned(OldNode) then\r\n  begin\r\n    Data := vstTrackFuncs.GetNodeData(OldNode);\r\n    case Data^.LinkType of\r\n      ltTrackFuncInfo:\r\n        AddTrackHistory(Data^.TrackFuncInfo);\r\n    end;\r\n  end;\r\nend;\r\n\r\nprocedure TMainForm.vstTrackFuncsGetText(Sender: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex; TextType: TVSTTextType;\r\n  var CellText: string);\r\nvar\r\n  Data: PLinkData;\r\n  SyncData: PLinkData;\r\n  ThData: PThreadData;\r\n  ProcData: TProcessData;\r\n  TrackFuncInfo: TCodeTrackFuncInfo;\r\n  TrackUnitInfo: TTrackUnitInfo;\r\nbegin\r\n  CellText := ' ';\r\n  Data := vstTrackFuncs.GetNodeData(Node);\r\n  case Data^.LinkType of\r\n    ltProcess:\r\n      begin\r\n        ProcData := Data^.ProcessData;\r\n        case Column of\r\n          0: CellText := ExtractFileName(gvProjectOptions.ApplicationName);\r\n          1: CellText := IntToStr(ProcData.DbgTrackEventCount);\r\n          2: CellText := ElapsedToTime(ProcData.CPUTime);\r\n        end;\r\n      end;\r\n    ltThread:\r\n      begin\r\n        ThData := Data^.ThreadData;\r\n        case Column of\r\n          0: CellText := ThData^.ThreadAdvInfo^.AsString;\r\n          1:\r\n            begin\r\n              CellText := IntToStr(ThData^.DbgTrackEventCount);\r\n              if gvDebuger.SamplingMethod then\r\n                CellText := CellText + PercentStr(ThData^.DbgTrackEventCount, gvDebuger.ProcessData.DbgTrackEventCount);\r\n            end;\r\n          2: CellText := ElapsedToTime(ThData^.CPUTime);\r\n        end;\r\n      end;\r\n    ltTrackFuncInfo:\r\n      begin\r\n        TrackFuncInfo := TCodeTrackFuncInfo(Data^.TrackFuncInfo);\r\n        case Column of\r\n          0: CellText := TFuncInfo(TrackFuncInfo.FuncInfo).ShortName;\r\n          1:\r\n            begin\r\n              CellText := IntToStr(TrackFuncInfo.CallCount);\r\n\r\n              if gvDebuger.SamplingMethod then\r\n              begin\r\n                SyncData := vstTrackFuncs.GetNodeData(Data^.SyncNode);\r\n                case SyncData^.LinkType of\r\n                  ltThread:\r\n                    begin\r\n                      ThData := SyncData^.ThreadData;\r\n                      CellText := CellText + PercentStr(TrackFuncInfo.CallCount, ThData^.DbgTrackEventCount);\r\n                    end;\r\n                  ltProcess:\r\n                    begin\r\n                      ProcData := SyncData^.ProcessData;\r\n                      CellText := CellText + PercentStr(TrackFuncInfo.CallCount, ProcData.DbgTrackEventCount);\r\n                    end;\r\n                end;\r\n              end;\r\n            end;\r\n          2:\r\n            begin\r\n              SyncData := vstTrackFuncs.GetNodeData(Data^.SyncNode);\r\n              case SyncData^.LinkType of\r\n                ltThread:\r\n                  begin\r\n                    ThData := SyncData^.ThreadData;\r\n                    CellText := FuncElapsedToTime(ThData^.CPUTime, ThData^.CPUElapsed, TrackFuncInfo.CPUElapsed);\r\n                  end;\r\n                ltProcess:\r\n                  begin\r\n                    ProcData := SyncData^.ProcessData;\r\n                    CellText := FuncElapsedToTime(ProcData.CPUTime, ProcData.CPUElapsed, TrackFuncInfo.CPUElapsed);\r\n                  end;\r\n              end;\r\n            end;\r\n        end;\r\n      end;\r\n    ltTrackUnitInfo:\r\n      begin\r\n        TrackUnitInfo := Data^.TrackUnitInfo;\r\n        case Column of\r\n          0: CellText := TUnitInfo(TrackUnitInfo.UnitInfo).ShortName;\r\n          1: CellText := IntToStr(TrackUnitInfo.CallCount);\r\n          (*\r\n          2:\r\n            begin\r\n              SyncData := vstTrackFuncs.GetNodeData(Data^.SyncNode);\r\n              case SyncData^.LinkType of\r\n                ltThread:\r\n                  begin\r\n                    ThData := SyncData^.ThreadData;\r\n                    CellText := FuncElapsedToTime(ThData^.CPUTime, ThData^.Elapsed, TrackUnitInfo.Elapsed);\r\n                  end;\r\n                ltProcess:\r\n                  begin\r\n                    ProcData := SyncData^.ProcessData;\r\n                    CellText := FuncElapsedToTime(ProcData^.CPUTime, ProcData^.Elapsed, TrackUnitInfo.Elapsed);\r\n                  end;\r\n              end;\r\n            end;\r\n          *)\r\n        end;\r\n      end;\r\n  end;\r\nend;\r\n\r\nprocedure TMainForm.vstTrackFuncsIncrementalSearch(Sender: TBaseVirtualTree;\r\n  Node: PVirtualNode; const SearchText: string; var Result: Integer);\r\nvar\r\n  Data: PLinkData;\r\n  Name: String;\r\nbegin\r\n  Data := vstTrackFuncs.GetNodeData(Node);\r\n\r\n  Name := '';\r\n\r\n  if (Data^.LinkType = ltTrackFuncInfo) then\r\n    Name := TFuncInfo(Data^.TrackFuncInfo.FuncInfo).ShortName\r\n  else\r\n  if (Data^.LinkType = ltTrackUnitInfo) then\r\n    Name := TUnitInfo(Data^.TrackUnitInfo.UnitInfo).ShortName;\r\n\r\n  Result := AnsiStrLIComp(PChar(SearchText), PChar(Name), Min(Length(SearchText), Length(Name)));\r\nend;\r\n\r\nprocedure TMainForm.vstTrackThreadsFocusChanged(Sender: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex);\r\nvar\r\n  Data: PLinkData;\r\nbegin\r\n  if Node = nil then Exit;\r\n\r\n  Data := vstTrackThreads.GetNodeData(Node);\r\n  case Data^.LinkType of\r\n    ltProcess:\r\n      LoadTrackProcessFunctions(Data^.ProcessData, Node);\r\n    ltThread:\r\n      LoadTrackThreadFunctions(Data^.ThreadData, Node);\r\n  end;\r\nend;\r\n\r\nprocedure TMainForm.vstTrackThreadsFocusChanging(Sender: TBaseVirtualTree; OldNode, NewNode: PVirtualNode; OldColumn, NewColumn: TColumnIndex;\r\n  var Allowed: Boolean);\r\nbegin\r\n  ClearTrackHistoryList;\r\nend;\r\n\r\nprocedure TMainForm.vstTrackThreadsGetText(Sender: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex; TextType: TVSTTextType; var CellText: string);\r\nvar\r\n  Data: PLinkData;\r\n  ThData: PThreadData;\r\n  ProcData: TProcessData;\r\nbegin\r\n  Data := Sender.GetNodeData(Node);\r\n  case Data^.LinkType of\r\n    ltProcess:\r\n      begin\r\n        ProcData := Data^.ProcessData;\r\n        if ProcData <> nil then\r\n          case Column of\r\n            0: CellText := ExtractFileName(gvProjectOptions.ApplicationName);\r\n            1: CellText := ProcessIDToStr(ProcData.ProcessID);\r\n            2: CellText := IntToStr(ProcData.DbgTrackEventCount);\r\n            3: CellText := ElapsedToTime(ProcData.CPUTime);\r\n          end;\r\n      end;\r\n    ltThread:\r\n      begin\r\n        ThData := Data^.ThreadData;\r\n        if ThData <> nil then\r\n          case Column of\r\n            0: CellText := ThData^.ThreadAdvInfo^.AsString;\r\n            1: CellText := ThreadIDToStr(ThData^.ThreadID);\r\n            2:\r\n              begin\r\n                CellText := IntToStr(ThData^.DbgTrackEventCount);\r\n                if gvDebuger.SamplingMethod then\r\n                  CellText := CellText + PercentStr(ThData^.DbgTrackEventCount, gvDebuger.ProcessData.DbgTrackEventCount);\r\n              end;\r\n            3: CellText := ElapsedToTime(ThData^.CPUTime);\r\n          end;\r\n      end;\r\n  end;\r\nend;\r\n\r\nprocedure TMainForm.vstUpdateInfoDrawText(Sender: TBaseVirtualTree; TargetCanvas: TCanvas; Node: PVirtualNode; Column: TColumnIndex;\r\n  const Text: string; const CellRect: TRect; var DefaultDraw: Boolean);\r\nvar\r\n  Data: PLinkData;\r\nbegin\r\n  Data := vstUpdateInfo.GetNodeData(Node);\r\n  case Data^.LinkType of\r\n    ltSpiderInfo:\r\n      TargetCanvas.Font.Style := [fsBold];\r\n    ltVersionInfo:\r\n      TargetCanvas.Font.Style := [fsBold];\r\n  end;\r\nend;\r\n\r\nprocedure TMainForm.vstUpdateInfoGetText(Sender: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex; TextType: TVSTTextType;\r\n  var CellText: string);\r\nvar\r\n  Data: PLinkData;\r\nbegin\r\n  CellText := ' ';\r\n\r\n  Data := vstUpdateInfo.GetNodeData(Node);\r\n  case Data^.LinkType of\r\n    ltSpiderInfo:\r\n      CellText := Format('Current version: %s; Last version: %s', [gvUpdateInfo.CurrentVersion, gvUpdateInfo.LastVersion]);\r\n    ltVersionInfo:\r\n      CellText := Format('Changes for version: %s (%s)', [Data^.VersionInfo.Version, Data^.VersionInfo.Date]);\r\n    ltChangeLogItemInfo:\r\n      CellText := Format('%s: %s', [TChangeLogItem.ItemTypeAsStr(Data^.ChangeLogItem.ItemType), Data^.ChangeLogItem.ItemText]);\r\n  end;\r\nend;\r\n\r\nprocedure TMainForm.WMClose(var Message: TWMClose);\r\nbegin\r\n  FCloseApp := True;\r\n  inherited;\r\nend;\r\n\r\nend.\r\n"
  },
  {
    "path": "uProcessList.dfm",
    "content": "object frmProcessList: TfrmProcessList\r\n  Left = 0\r\n  Top = 0\r\n  BorderIcons = [biSystemMenu]\r\n  BorderStyle = bsSingle\r\n  Caption = 'Process list'\r\n  ClientHeight = 413\r\n  ClientWidth = 569\r\n  Color = clBtnFace\r\n  Font.Charset = DEFAULT_CHARSET\r\n  Font.Color = clWindowText\r\n  Font.Height = -11\r\n  Font.Name = 'Tahoma'\r\n  Font.Style = []\r\n  OldCreateOrder = False\r\n  Position = poScreenCenter\r\n  OnCreate = FormCreate\r\n  OnShow = FormShow\r\n  PixelsPerInch = 96\r\n  TextHeight = 13\r\n  object sgProcessList: TStringGrid\r\n    Left = 0\r\n    Top = 26\r\n    Width = 569\r\n    Height = 342\r\n    Align = alClient\r\n    BorderStyle = bsNone\r\n    ColCount = 1\r\n    DefaultRowHeight = 18\r\n    FixedCols = 0\r\n    TabOrder = 0\r\n    ExplicitHeight = 331\r\n    ColWidths = (\r\n      519)\r\n  end\r\n  object cbTop: TCoolBar\r\n    Left = 0\r\n    Top = 0\r\n    Width = 569\r\n    Height = 26\r\n    AutoSize = True\r\n    Bands = <\r\n      item\r\n        Control = actbTop\r\n        ImageIndex = -1\r\n        MinHeight = 26\r\n        Width = 567\r\n      end>\r\n    EdgeBorders = []\r\n    EdgeInner = esNone\r\n    EdgeOuter = esNone\r\n    FixedOrder = True\r\n    object actbTop: TActionToolBar\r\n      Left = 2\r\n      Top = 0\r\n      Width = 567\r\n      Height = 26\r\n      ActionManager = acmgr1\r\n      Caption = 'actbTop'\r\n      ColorMap.MenuColor = clMenu\r\n      ColorMap.BtnSelectedColor = clBtnFace\r\n      ColorMap.UnusedColor = 13684944\r\n      Font.Charset = DEFAULT_CHARSET\r\n      Font.Color = clBlack\r\n      Font.Height = -11\r\n      Font.Name = 'Tahoma'\r\n      Font.Style = []\r\n      ParentFont = False\r\n      Spacing = 0\r\n    end\r\n  end\r\n  object pActions: TPanel\r\n    Left = 0\r\n    Top = 368\r\n    Width = 569\r\n    Height = 45\r\n    Align = alBottom\r\n    BevelOuter = bvNone\r\n    Caption = 'pActions'\r\n    ShowCaption = False\r\n    TabOrder = 2\r\n    DesignSize = (\r\n      569\r\n      45)\r\n    object btnAttach: TBitBtn\r\n      Left = 387\r\n      Top = 11\r\n      Width = 75\r\n      Height = 25\r\n      Action = acOk\r\n      Anchors = [akRight, akBottom]\r\n      Caption = 'Attach'\r\n      TabOrder = 0\r\n    end\r\n    object btnCancel: TBitBtn\r\n      Left = 475\r\n      Top = 11\r\n      Width = 75\r\n      Height = 25\r\n      Action = acCancel\r\n      Anchors = [akRight, akBottom]\r\n      Caption = 'Cancel'\r\n      TabOrder = 1\r\n    end\r\n  end\r\n  object AL: TActionList\r\n    Images = dmShareData.ilActionsSmall\r\n    Left = 432\r\n    Top = 72\r\n    object acOk: TAction\r\n      Caption = 'Attach'\r\n      ImageIndex = 1\r\n      ShortCut = 13\r\n      OnExecute = acOkExecute\r\n    end\r\n    object acCancel: TAction\r\n      Caption = 'Cancel'\r\n      ImageIndex = 2\r\n      ShortCut = 27\r\n      OnExecute = acCancelExecute\r\n    end\r\n    object acRefresh: TAction\r\n      Caption = 'Refresh'\r\n      ImageIndex = 3\r\n      ShortCut = 116\r\n      OnExecute = acRefreshExecute\r\n    end\r\n  end\r\n  object acmgr1: TActionManager\r\n    ActionBars = <\r\n      item\r\n        Items = <\r\n          item\r\n            Action = acRefresh\r\n            Caption = '&Refresh'\r\n            ImageIndex = 3\r\n            ShortCut = 116\r\n          end>\r\n        ActionBar = actbTop\r\n      end>\r\n    LargeImages = dmShareData.imlMain\r\n    LinkedActionLists = <\r\n      item\r\n        ActionList = AL\r\n        Caption = 'AL'\r\n      end>\r\n    Images = dmShareData.imlMainSmall\r\n    Left = 432\r\n    Top = 152\r\n    StyleName = 'Platform Default'\r\n  end\r\nend\r\n"
  },
  {
    "path": "uProcessList.pas",
    "content": "unit uProcessList;\r\n\r\ninterface\r\n\r\nuses\r\n  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,\r\n  Dialogs, Grids, ExtCtrls, ActnList, StdCtrls, Buttons,\r\n  PlatformDefaultStyleActnCtrls, ActnMan, ActnCtrls, ToolWin, ComCtrls,\r\n  RibbonSilverStyleActnCtrls, System.Actions;\r\n\r\ntype\r\n  TfrmProcessList = class(TForm)\r\n    sgProcessList: TStringGrid;\r\n    AL: TActionList;\r\n    acOk: TAction;\r\n    acCancel: TAction;\r\n    acRefresh: TAction;\r\n    cbTop: TCoolBar;\r\n    actbTop: TActionToolBar;\r\n    pActions: TPanel;\r\n    btnAttach: TBitBtn;\r\n    btnCancel: TBitBtn;\r\n    acmgr1: TActionManager;\r\n    procedure acRefreshExecute(Sender: TObject);\r\n    procedure acOkExecute(Sender: TObject);\r\n    procedure acCancelExecute(Sender: TObject);\r\n    procedure FormShow(Sender: TObject);\r\n    procedure FormCreate(Sender: TObject);\r\n  private\r\n    { Private declarations }\r\n  public\r\n    function GetSelProcessID: DWORD;\r\n    function GetSelProcessName: String;\r\n  end;\r\n\r\nvar\r\n  frmProcessList: TfrmProcessList;\r\n\r\nimplementation\r\n\r\nuses PsAPI, uShareData;\r\n\r\nprocedure GetProcessList(List: TStringList);\r\nvar\r\n  PIDArray: array [0..1023] of DWORD;\r\n  cb: DWORD;\r\n  I: Integer;\r\n  ProcCount: Integer;\r\n  hMod: HMODULE;\r\n  hProcess: THandle;\r\n  ProcessID: DWORD;\r\n  ModuleName: array [0..300] of Char;\r\nbegin\r\n  if List = nil then Exit;\r\n\r\n  if EnumProcesses(@PIDArray, SizeOf(PIDArray), cb) then\r\n  begin\r\n    ProcCount := cb div SizeOf(DWORD);\r\n    for I := 0 to ProcCount - 1 do\r\n    begin\r\n      ProcessID := PIDArray[I];\r\n      hProcess := OpenProcess(PROCESS_QUERY_INFORMATION or PROCESS_VM_READ, False, ProcessID);\r\n      if (hProcess <> 0) then\r\n      begin\r\n        EnumProcessModules(hProcess, @hMod, SizeOf(hMod), cb);\r\n        GetModuleFilenameEx(hProcess, hMod, ModuleName, SizeOf(ModuleName));\r\n        List.AddObject(ModuleName, TObject(ProcessID));\r\n        CloseHandle(hProcess);\r\n      end;\r\n    end;\r\n  end;\r\nend;\r\n\r\n{$R *.dfm}\r\n\r\nprocedure TfrmProcessList.acCancelExecute(Sender: TObject);\r\nbegin\r\n  ModalResult := mrCancel;\r\nend;\r\n\r\nprocedure TfrmProcessList.acOkExecute(Sender: TObject);\r\nbegin\r\n  ModalResult := mrOk;\r\nend;\r\n\r\nprocedure TfrmProcessList.acRefreshExecute(Sender: TObject);\r\nvar\r\n  PL: TStringList;\r\n  I: Integer;\r\nbegin\r\n  PL := TStringList.Create;\r\n  try\r\n    GetProcessList(PL);\r\n\r\n    sgProcessList.RowCount := PL.Count + 1;\r\n    sgProcessList.Cells[0, 0] := 'Process name';\r\n\r\n    for I := 0 to PL.Count - 1 do\r\n    begin\r\n      sgProcessList.Cells[0, I + 1] := PL.Strings[I];\r\n      sgProcessList.Objects[0, I + 1] := PL.Objects[I];\r\n    end;\r\n  finally\r\n    FreeAndNil(PL);\r\n  end;\r\nend;\r\n\r\nprocedure TfrmProcessList.FormCreate(Sender: TObject);\r\nbegin\r\n  actbTop.ParentBackground := True;\r\nend;\r\n\r\nprocedure TfrmProcessList.FormShow(Sender: TObject);\r\nbegin\r\n  acRefresh.Execute;\r\nend;\r\n\r\nfunction TfrmProcessList.GetSelProcessID: DWORD;\r\nbegin\r\n  Result := DWORD(sgProcessList.Objects[sgProcessList.Col, sgProcessList.Row]);\r\nend;\r\n\r\nfunction TfrmProcessList.GetSelProcessName: String;\r\nbegin\r\n  Result := sgProcessList.Cells[sgProcessList.Col, sgProcessList.Row];\r\nend;\r\n\r\nend.\r\n"
  },
  {
    "path": "uProjectOptions.dfm",
    "content": "object fmProjectOptions: TfmProjectOptions\r\n  Left = 0\r\n  Top = 0\r\n  BorderIcons = [biSystemMenu]\r\n  BorderStyle = bsSingle\r\n  Caption = 'Project options'\r\n  ClientHeight = 225\r\n  ClientWidth = 454\r\n  Color = clBtnFace\r\n  Constraints.MaxHeight = 253\r\n  Constraints.MaxWidth = 460\r\n  Constraints.MinHeight = 250\r\n  Constraints.MinWidth = 460\r\n  DoubleBuffered = True\r\n  Font.Charset = DEFAULT_CHARSET\r\n  Font.Color = clWindowText\r\n  Font.Height = -11\r\n  Font.Name = 'Tahoma'\r\n  Font.Style = []\r\n  OldCreateOrder = False\r\n  Position = poScreenCenter\r\n  OnCreate = FormCreate\r\n  OnShow = FormShow\r\n  PixelsPerInch = 96\r\n  TextHeight = 13\r\n  object pcProjectOpt: TPageControl\r\n    Left = 0\r\n    Top = 0\r\n    Width = 454\r\n    Height = 185\r\n    ActivePage = tsProject\r\n    Align = alClient\r\n    Font.Charset = DEFAULT_CHARSET\r\n    Font.Color = clWindowText\r\n    Font.Height = -11\r\n    Font.Name = 'Tahoma'\r\n    Font.Style = [fsBold]\r\n    ParentFont = False\r\n    TabOrder = 0\r\n    object tsProject: TTabSheet\r\n      Caption = 'Project settings'\r\n      Font.Charset = DEFAULT_CHARSET\r\n      Font.Color = clWindowText\r\n      Font.Height = -11\r\n      Font.Name = 'Tahoma'\r\n      Font.Style = []\r\n      ParentFont = False\r\n      object lbeApplication: TLabeledEdit\r\n        Left = 7\r\n        Top = 24\r\n        Width = 378\r\n        Height = 21\r\n        EditLabel.Width = 52\r\n        EditLabel.Height = 13\r\n        EditLabel.Caption = 'Application'\r\n        TabOrder = 0\r\n      end\r\n      object lbeProjectName: TLabeledEdit\r\n        Left = 7\r\n        Top = 72\r\n        Width = 378\r\n        Height = 21\r\n        EditLabel.Width = 63\r\n        EditLabel.Height = 13\r\n        EditLabel.Caption = 'Project name'\r\n        TabOrder = 2\r\n      end\r\n      object lbeProjectStorage: TLabeledEdit\r\n        Left = 7\r\n        Top = 120\r\n        Width = 378\r\n        Height = 21\r\n        EditLabel.Width = 112\r\n        EditLabel.Height = 13\r\n        EditLabel.Caption = 'Project session storage'\r\n        ReadOnly = True\r\n        TabOrder = 4\r\n      end\r\n      object btnOpenApplication: TBitBtn\r\n        Left = 384\r\n        Top = 22\r\n        Width = 33\r\n        Height = 25\r\n        Action = acOpenApplication\r\n        TabOrder = 1\r\n      end\r\n      object btnSaveProjectName: TBitBtn\r\n        Left = 384\r\n        Top = 70\r\n        Width = 33\r\n        Height = 25\r\n        Action = acSaveProjectName\r\n        TabOrder = 3\r\n      end\r\n      object btnSaveProjectStorage: TBitBtn\r\n        Left = 384\r\n        Top = 118\r\n        Width = 33\r\n        Height = 25\r\n        Action = acSaveProjectStorage\r\n        TabOrder = 5\r\n      end\r\n    end\r\n    object tsSources: TTabSheet\r\n      Caption = 'Source settings'\r\n      Font.Charset = DEFAULT_CHARSET\r\n      Font.Color = clWindowText\r\n      Font.Height = -11\r\n      Font.Name = 'Tahoma'\r\n      Font.Style = []\r\n      ImageIndex = 1\r\n      ParentFont = False\r\n      object lbeProjectSource: TLabeledEdit\r\n        Left = 7\r\n        Top = 24\r\n        Width = 378\r\n        Height = 21\r\n        EditLabel.Width = 69\r\n        EditLabel.Height = 13\r\n        EditLabel.Caption = 'Project source'\r\n        TabOrder = 0\r\n      end\r\n      object btnProjectSource: TBitBtn\r\n        Left = 384\r\n        Top = 22\r\n        Width = 33\r\n        Height = 25\r\n        Action = acProjectSource\r\n        TabOrder = 1\r\n      end\r\n      object lbeDelphiSource: TLabeledEdit\r\n        Left = 7\r\n        Top = 72\r\n        Width = 378\r\n        Height = 21\r\n        EditLabel.Width = 97\r\n        EditLabel.Height = 13\r\n        EditLabel.Caption = 'Delphi library source'\r\n        TabOrder = 2\r\n      end\r\n      object btnDelphiSource: TBitBtn\r\n        Left = 384\r\n        Top = 70\r\n        Width = 33\r\n        Height = 25\r\n        Action = acDelphiSource\r\n        TabOrder = 3\r\n      end\r\n    end\r\n    object tsRunParams: TTabSheet\r\n      Caption = 'Run parameters'\r\n      Font.Charset = DEFAULT_CHARSET\r\n      Font.Color = clWindowText\r\n      Font.Height = -11\r\n      Font.Name = 'Tahoma'\r\n      Font.Style = []\r\n      ImageIndex = 2\r\n      ParentFont = False\r\n      object lbeParameters: TLabeledEdit\r\n        Left = 7\r\n        Top = 24\r\n        Width = 378\r\n        Height = 21\r\n        EditLabel.Width = 55\r\n        EditLabel.Height = 13\r\n        EditLabel.Caption = 'Parameters'\r\n        TabOrder = 0\r\n      end\r\n      object lbeWorkDir: TLabeledEdit\r\n        Left = 7\r\n        Top = 72\r\n        Width = 378\r\n        Height = 21\r\n        EditLabel.Width = 85\r\n        EditLabel.Height = 13\r\n        EditLabel.Caption = 'Working directory'\r\n        TabOrder = 1\r\n      end\r\n      object btnSelWorkDir: TBitBtn\r\n        Left = 384\r\n        Top = 70\r\n        Width = 33\r\n        Height = 25\r\n        Action = acSelWorkDir\r\n        TabOrder = 2\r\n      end\r\n    end\r\n  end\r\n  object pActions: TPanel\r\n    Left = 0\r\n    Top = 185\r\n    Width = 454\r\n    Height = 40\r\n    Align = alBottom\r\n    BevelOuter = bvNone\r\n    Caption = 'pActions'\r\n    ShowCaption = False\r\n    TabOrder = 1\r\n    DesignSize = (\r\n      454\r\n      40)\r\n    object btnOk: TBitBtn\r\n      Left = 282\r\n      Top = 8\r\n      Width = 75\r\n      Height = 25\r\n      Action = acSave\r\n      Anchors = [akRight, akBottom]\r\n      Caption = 'Save'\r\n      TabOrder = 0\r\n    end\r\n    object btnCancel: TBitBtn\r\n      Left = 369\r\n      Top = 8\r\n      Width = 75\r\n      Height = 25\r\n      Action = acCancel\r\n      Anchors = [akRight, akBottom]\r\n      Caption = 'Cancel'\r\n      TabOrder = 1\r\n    end\r\n  end\r\n  object alProjectOpt: TActionList\r\n    Images = dmShareData.ilActionsSmall\r\n    Left = 248\r\n    Top = 8\r\n    object acSave: TAction\r\n      Caption = 'Save'\r\n      ImageIndex = 1\r\n      OnExecute = acSaveExecute\r\n    end\r\n    object acCancel: TAction\r\n      Caption = 'Cancel'\r\n      ImageIndex = 2\r\n      OnExecute = acCancelExecute\r\n    end\r\n    object acOpenApplication: TAction\r\n      ImageIndex = 0\r\n      OnExecute = acOpenApplicationExecute\r\n    end\r\n    object acSaveProjectName: TAction\r\n      ImageIndex = 0\r\n      OnExecute = acSaveProjectNameExecute\r\n    end\r\n    object acSaveProjectStorage: TAction\r\n      ImageIndex = 0\r\n      Visible = False\r\n      OnExecute = acSaveProjectStorageExecute\r\n    end\r\n    object acDelphiSource: TAction\r\n      ImageIndex = 0\r\n      OnExecute = acDelphiSourceExecute\r\n    end\r\n    object acProjectSource: TAction\r\n      ImageIndex = 0\r\n      OnExecute = acProjectSourceExecute\r\n    end\r\n    object acSelWorkDir: TAction\r\n      ImageIndex = 0\r\n      OnExecute = acSelWorkDirExecute\r\n    end\r\n  end\r\n  object odApplication: TFileOpenDialog\r\n    FavoriteLinks = <>\r\n    FileTypes = <\r\n      item\r\n        DisplayName = 'Application (*.exe)'\r\n        FileMask = '*.exe'\r\n      end\r\n      item\r\n        DisplayName = 'Debug info (*.map)'\r\n        FileMask = '*.map'\r\n      end>\r\n    Options = []\r\n    Left = 128\r\n    Top = 176\r\n  end\r\n  object sdProjectName: TFileSaveDialog\r\n    DefaultExtension = '.spider'\r\n    FavoriteLinks = <>\r\n    FileTypes = <\r\n      item\r\n        DisplayName = 'Spider project (*.spider)'\r\n        FileMask = '*.spider'\r\n      end>\r\n    Options = [fdoFileMustExist, fdoCreatePrompt]\r\n    Left = 48\r\n    Top = 176\r\n  end\r\n  object odSelectWorkDir: TFileOpenDialog\r\n    FavoriteLinks = <>\r\n    FileTypes = <>\r\n    Options = [fdoPickFolders, fdoPathMustExist]\r\n    Title = 'Select working directory'\r\n    Left = 208\r\n    Top = 176\r\n  end\r\nend\r\n"
  },
  {
    "path": "uProjectOptions.pas",
    "content": "unit uProjectOptions;\r\n\r\ninterface\r\n\r\nuses\r\n  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,\r\n  Dialogs, ExtCtrls, PlatformDefaultStyleActnCtrls, ActnList, ActnMan,\r\n  ComCtrls, ActnCtrls, ToolWin, StdCtrls, Buttons, ImgList,\r\n  RibbonSilverStyleActnCtrls, System.Actions;\r\n\r\ntype\r\n  TOpenType = (otNew, otEdit, otSaveAs);\r\n\r\n  TfmProjectOptions = class(TForm)\r\n    alProjectOpt: TActionList;\r\n    acSave: TAction;\r\n    acCancel: TAction;\r\n    acOpenApplication: TAction;\r\n    acSaveProjectName: TAction;\r\n    acSaveProjectStorage: TAction;\r\n    odApplication: TFileOpenDialog;\r\n    sdProjectName: TFileSaveDialog;\r\n    acDelphiSource: TAction;\r\n    acProjectSource: TAction;\r\n    pcProjectOpt: TPageControl;\r\n    tsProject: TTabSheet;\r\n    lbeApplication: TLabeledEdit;\r\n    lbeProjectName: TLabeledEdit;\r\n    lbeProjectStorage: TLabeledEdit;\r\n    btnOpenApplication: TBitBtn;\r\n    btnSaveProjectName: TBitBtn;\r\n    btnSaveProjectStorage: TBitBtn;\r\n    tsSources: TTabSheet;\r\n    lbeProjectSource: TLabeledEdit;\r\n    btnProjectSource: TBitBtn;\r\n    lbeDelphiSource: TLabeledEdit;\r\n    btnDelphiSource: TBitBtn;\r\n    pActions: TPanel;\r\n    btnOk: TBitBtn;\r\n    btnCancel: TBitBtn;\r\n    tsRunParams: TTabSheet;\r\n    lbeParameters: TLabeledEdit;\r\n    lbeWorkDir: TLabeledEdit;\r\n    btnSelWorkDir: TBitBtn;\r\n    acSelWorkDir: TAction;\r\n    odSelectWorkDir: TFileOpenDialog;\r\n    procedure acSaveExecute(Sender: TObject);\r\n    procedure acCancelExecute(Sender: TObject);\r\n    procedure acOpenApplicationExecute(Sender: TObject);\r\n    procedure acSaveProjectNameExecute(Sender: TObject);\r\n    procedure acSaveProjectStorageExecute(Sender: TObject);\r\n    procedure FormCreate(Sender: TObject);\r\n    procedure FormShow(Sender: TObject);\r\n    procedure acDelphiSourceExecute(Sender: TObject);\r\n    procedure acProjectSourceExecute(Sender: TObject);\r\n    procedure acSelWorkDirExecute(Sender: TObject);\r\n  private\r\n    FOpenType: TOpenType;\r\n    function GetApplicationName: String;\r\n    function GetProjectName: String;\r\n    function GetProjectStorage: String;\r\n    function GetDelphiSource: String;\r\n    function GetProjectSource: String;\r\n    function GetRunParams: String;\r\n    function GetWorkingDirectory: String;\r\n\r\n    procedure SetApplicationName(const Value: String);\r\n    procedure SetDelphiSource(const Value: String);\r\n    procedure SetProjectName(const Value: String);\r\n    procedure SetProjectSource(const Value: String);\r\n    procedure SetProjectStorage(const Value: String);\r\n    procedure SetRunParams(const Value: String);\r\n    procedure SetWorkingDirectory(const Value: String);\r\n  public\r\n    property OpenType: TOpenType read FOpenType write FOpenType;\r\n    property ApplicationName: String read GetApplicationName write SetApplicationName;\r\n    property ProjectName: String read GetProjectName write SetProjectName;\r\n    property ProjectStorage: String read GetProjectStorage write SetProjectStorage;\r\n    property ProjectSource: String read GetProjectSource write SetProjectSource;\r\n    property DelphiSource: String read GetDelphiSource write SetDelphiSource;\r\n    property RunParams: String read GetRunParams write SetRunParams;\r\n    property WorkingDirectory: String read GetWorkingDirectory write SetWorkingDirectory;\r\n  end;\r\n\r\n  function OpenProjectOptions(const OpenType: TOpenType): Integer;\r\n\r\nvar\r\n  fmProjectOptions: TfmProjectOptions;\r\n\r\nimplementation\r\n\r\nuses\r\n  IOUtils, uShareData, uSelectSource, uActionController;\r\n\r\n{$R *.dfm}\r\n\r\nfunction OpenProjectOptions(const OpenType: TOpenType): Integer;\r\nvar\r\n  F: TfmProjectOptions;\r\nbegin\r\n  Application.CreateForm(TfmProjectOptions, F);\r\n  try\r\n    F.OpenType := OpenType;\r\n\r\n    if OpenType in [otEdit, otSaveAs] then\r\n    begin\r\n      F.ProjectName := gvProjectOptions.ProjectName;\r\n      F.ApplicationName := gvProjectOptions.ApplicationName;\r\n      F.ProjectStorage := gvProjectOptions.ProjectStorage;\r\n      F.ProjectSource := gvProjectOptions.ProjectSource;\r\n      F.DelphiSource := gvProjectOptions.DelphiSource;\r\n      F.RunParams := gvProjectOptions.RunParams;\r\n      F.WorkingDirectory := gvProjectOptions.WorkingDirectory;\r\n    end;\r\n\r\n    if OpenType = otSaveAs then\r\n      F.ProjectName := Format('%s_copy%s', [\r\n        ChangeFileExt(gvProjectOptions.ProjectName, ''),\r\n        ExtractFileExt(gvProjectOptions.ProjectName)\r\n      ]);\r\n\r\n    Result := F.ShowModal;\r\n    if Result = mrOk then\r\n    begin\r\n      ChangeFileExt(F.ProjectName, '.spider');\r\n      gvProjectOptions.Open(F.ProjectName);\r\n      gvProjectOptions.BeginUpdate;\r\n      try\r\n        gvProjectOptions.ApplicationName := F.ApplicationName;\r\n        gvProjectOptions.ProjectStorage := F.ProjectStorage;\r\n        gvProjectOptions.ProjectSource := F.ProjectSource;\r\n        gvProjectOptions.DelphiSource := F.DelphiSource;\r\n        gvProjectOptions.RunParams := F.RunParams;\r\n        gvProjectOptions.WorkingDirectory := F.WorkingDirectory;\r\n      finally\r\n        gvProjectOptions.EndUpdate;\r\n      end;\r\n\r\n      if OpenType in [otNew, otSaveAs] then\r\n      begin\r\n        gvProjectOptions.Clear;\r\n        _AC.DoAction(acSetProjectName, [F.ProjectName, OpenType]);\r\n      end;\r\n\r\n      if OpenType = otEdit then\r\n        _AC.DoAction(acChangeProjectSettings, []);\r\n    end;\r\n  finally\r\n    F.Release;\r\n  end;\r\nend;\r\n\r\nprocedure TfmProjectOptions.acCancelExecute(Sender: TObject);\r\nbegin\r\n  ModalResult := mrCancel;\r\nend;\r\n\r\nprocedure TfmProjectOptions.acDelphiSourceExecute(Sender: TObject);\r\nbegin\r\n  lbeDelphiSource.Text := SelectSource(lbeDelphiSource.Text);\r\nend;\r\n\r\nprocedure TfmProjectOptions.acOpenApplicationExecute(Sender: TObject);\r\nbegin\r\n  if lbeApplication.Text <> '' then\r\n    odApplication.FileName := lbeApplication.Text;\r\n\r\n  if odApplication.Execute then\r\n  begin\r\n    // Project settings\r\n    lbeApplication.Text := odApplication.FileName;\r\n\r\n    if lbeProjectName.Text = '' then\r\n      lbeProjectName.Text := ChangeFileExt(lbeApplication.Text, '.spider');\r\n\r\n    if lbeProjectStorage.Text = '' then\r\n      lbeProjectStorage.Text := ExtractFilePath(lbeProjectName.Text) + '_spider_storage';\r\n\r\n    // Source settings\r\n    if lbeProjectSource.Text = '' then\r\n      lbeProjectSource.Text := TProjectOptions.GetDefProjectSource(odApplication.FileName);\r\n\r\n    if lbeDelphiSource.Text = '' then\r\n      lbeDelphiSource.Text := TProjectOptions.GetDefDelphiSource;\r\n\r\n    // Run parameters\r\n    if lbeWorkDir.Text = '' then\r\n      lbeWorkDir.Text := ExtractFilePath(lbeProjectName.Text);\r\n  end;\r\nend;\r\n\r\nprocedure TfmProjectOptions.acProjectSourceExecute(Sender: TObject);\r\nbegin\r\n  lbeProjectSource.Text := SelectSource(lbeProjectSource.Text);\r\nend;\r\n\r\nprocedure TfmProjectOptions.acSaveExecute(Sender: TObject);\r\nbegin\r\n  if not FileExists(ApplicationName) then\r\n  begin\r\n    pcProjectOpt.ActivePage := tsProject;\r\n    ActiveControl := lbeApplication;\r\n    ShowMessageFmt('Application \"%s\" not found', [ApplicationName]);\r\n    Exit;\r\n  end;\r\n\r\n  if not TFile.Exists(ProjectName) then\r\n  begin\r\n    try\r\n      TFile.Create(ProjectName).Free;\r\n      TFile.Delete(ProjectName);\r\n    except\r\n      on E: Exception do\r\n      begin\r\n        pcProjectOpt.ActivePage := tsProject;\r\n        ActiveControl := lbeProjectName;\r\n        ShowMessageFmt('%s', [E.Message]);\r\n        Exit;\r\n      end;\r\n    end;\r\n  end;\r\n\r\n  if not TDirectory.Exists(ProjectStorage) then\r\n  begin\r\n    try\r\n      TDirectory.CreateDirectory(ProjectStorage);\r\n      TDirectory.Delete(ProjectStorage);\r\n    except\r\n      on E: Exception do\r\n      begin\r\n        pcProjectOpt.ActivePage := tsProject;\r\n        ActiveControl := lbeProjectName;\r\n        ShowMessageFmt('%s', [E.Message]);\r\n        Exit;\r\n      end;\r\n    end;\r\n  end;\r\n\r\n  if (WorkingDirectory <> '') and not TDirectory.Exists(WorkingDirectory) then\r\n  begin\r\n    pcProjectOpt.ActivePage := tsRunParams;\r\n    ActiveControl := lbeWorkDir;\r\n    ShowMessageFmt('Working directory \"%s\" not exists', [WorkingDirectory]);\r\n    Exit;\r\n  end;\r\n\r\n  ModalResult := mrOk;\r\nend;\r\n\r\nprocedure TfmProjectOptions.acSaveProjectNameExecute(Sender: TObject);\r\nbegin\r\n  if lbeProjectName.Text <> '' then\r\n    sdProjectName.FileName := lbeProjectName.Text;\r\n\r\n  if sdProjectName.Execute then\r\n  begin\r\n    lbeProjectName.Text := sdProjectName.FileName;\r\n\r\n    lbeProjectStorage.Text := ExtractFilePath(lbeProjectName.Text) + '_spider_storage';\r\n  end;\r\nend;\r\n\r\nprocedure TfmProjectOptions.acSaveProjectStorageExecute(Sender: TObject);\r\nbegin\r\n  //\r\nend;\r\n\r\nprocedure TfmProjectOptions.acSelWorkDirExecute(Sender: TObject);\r\nbegin\r\n  odSelectWorkDir.FileName := lbeWorkDir.Text;\r\n\r\n  if odSelectWorkDir.Execute then\r\n    lbeWorkDir.Text := ExcludeTrailingPathDelimiter(Trim(odSelectWorkDir.FileName));\r\nend;\r\n\r\nprocedure TfmProjectOptions.FormCreate(Sender: TObject);\r\nbegin\r\n  FOpenType := otNew;\r\n\r\n  pcProjectOpt.ActivePage := tsProject;\r\n  ActiveControl := lbeApplication;\r\nend;\r\n\r\nprocedure TfmProjectOptions.FormShow(Sender: TObject);\r\nbegin\r\n  if FOpenType = otNew then\r\n    acOpenApplication.Execute;\r\nend;\r\n\r\nfunction TfmProjectOptions.GetApplicationName: String;\r\nbegin\r\n  Result := lbeApplication.Text;\r\nend;\r\n\r\nfunction TfmProjectOptions.GetDelphiSource: String;\r\nbegin\r\n  Result := lbeDelphiSource.Text;\r\nend;\r\n\r\nfunction TfmProjectOptions.GetProjectName: String;\r\nbegin\r\n  Result := lbeProjectName.Text;\r\nend;\r\n\r\nfunction TfmProjectOptions.GetProjectSource: String;\r\nbegin\r\n  Result := lbeProjectSource.Text;\r\nend;\r\n\r\nfunction TfmProjectOptions.GetProjectStorage: String;\r\nbegin\r\n  Result := lbeProjectStorage.Text;\r\nend;\r\n\r\nfunction TfmProjectOptions.GetRunParams: String;\r\nbegin\r\n  Result := lbeParameters.Text;\r\nend;\r\n\r\nfunction TfmProjectOptions.GetWorkingDirectory: String;\r\nbegin\r\n  Result := ExcludeTrailingPathDelimiter(Trim(lbeWorkDir.Text));\r\nend;\r\n\r\nprocedure TfmProjectOptions.SetApplicationName(const Value: String);\r\nbegin\r\n  lbeApplication.Text := Value;\r\nend;\r\n\r\nprocedure TfmProjectOptions.SetDelphiSource(const Value: String);\r\nbegin\r\n  lbeDelphiSource.Text := Value;\r\nend;\r\n\r\nprocedure TfmProjectOptions.SetProjectName(const Value: String);\r\nbegin\r\n  lbeProjectName.Text := Value;\r\nend;\r\n\r\nprocedure TfmProjectOptions.SetProjectSource(const Value: String);\r\nbegin\r\n  lbeProjectSource.Text := Value;\r\nend;\r\n\r\nprocedure TfmProjectOptions.SetProjectStorage(const Value: String);\r\nbegin\r\n  lbeProjectStorage.Text := Value;\r\nend;\r\n\r\nprocedure TfmProjectOptions.SetRunParams(const Value: String);\r\nbegin\r\n  lbeParameters.Text := Value;\r\nend;\r\n\r\nprocedure TfmProjectOptions.SetWorkingDirectory(const Value: String);\r\nbegin\r\n  lbeWorkDir.Text := Value;\r\nend;\r\n\r\nend.\r\n"
  },
  {
    "path": "uRWLock.pas",
    "content": "unit uRWLock;\r\n\r\ninterface\r\n\r\n{.$DEFINE RWLOCK_DEBUG}\r\n\r\nuses\r\n  System.Classes, System.SyncObjs, System.SysUtils, System.Types;\r\n\r\ntype\r\n  TRWNodeState = (nsReader, nsWriter);\r\n\r\n  {$IFDEF RWLOCK_DEBUG}\r\n  TRWLock = class;\r\n  TRWThreadNode = class;\r\n\r\n  TStack = Array[0..63] of Pointer;\r\n  TLockInfo = class\r\n  public\r\n    ThreadID: TThreadID;\r\n    EnterTime: TDateTime;\r\n    Stack: TStack;\r\n\r\n    function Clone: TLockInfo;\r\n    function StackToStr: String;\r\n  end;\r\n\r\n  TLockInfoList = class(TList)\r\n  protected\r\n    procedure Notify(Ptr: Pointer; Action: TListNotification); override;\r\n  public\r\n    function Clone: TLockInfoList;\r\n  end;\r\n\r\n  TRWThreadLockInfoList = class(TList)\r\n  protected\r\n    procedure Notify(Ptr: Pointer; Action: TListNotification); override;\r\n  end;\r\n\r\n  TLockEvent = procedure(Sender: TRWLock; const LockInfo: TLockInfo) of object;\r\n  TLockWaitEvent = procedure(Sender: TRWLock) of object;\r\n  {$ENDIF}\r\n\r\n  TRWThreadNode = class\r\n  strict private\r\n    FThreadID: TThreadID;\r\n    FReaderAcquires: Integer;\r\n    FWriterAcquires: Integer;\r\n    FWakeUpEvent: TEvent;\r\n    FState: TRWNodeState;\r\n    FIsWait: Boolean;\r\n\r\n    function GetAcquires: Integer; inline;\r\n  protected\r\n    function Clone: TRWThreadNode;\r\n\r\n    procedure IncAcquires;\r\n    procedure DecAcquires;\r\n  public\r\n    constructor Create(const AThreadID: TThreadID);\r\n    destructor Destroy; override;\r\n\r\n    procedure WakeUp; inline;\r\n    procedure Wait; inline;\r\n\r\n    property ThreadID: TThreadID read FThreadID;\r\n    property ReaderAcquires: Integer read FReaderAcquires;\r\n    property WriterAcquires: Integer read FWriterAcquires;\r\n    property Acquires: Integer read GetAcquires;\r\n    property State: TRWNodeState read FState write FState;\r\n    property IsWait: Boolean read FIsWait write FIsWait;\r\n  end;\r\n\r\n  ERWLockError = class(Exception);\r\n\r\n  TRWLock = class(TObject)\r\n  strict private\r\n    FLock: TCriticalSection;\r\n    FWaiters: TList;\r\n\r\n    {$IFDEF RWLOCK_DEBUG}\r\n    FLockInfoList: TLockInfoList;\r\n    FLockEvent: TLockEvent;\r\n    FLockWaitEvent: TLockWaitEvent;\r\n\r\n    procedure AddLockInfo(const ThreadID: TThreadID);\r\n    procedure DelLockInfo(const ThreadID: TThreadID);\r\n    {$ENDIF}\r\n\r\n    function GetRWNode(const Index: Integer): TRWThreadNode; inline;\r\n    function GetRWNodeCount: Integer; inline;\r\n\r\n    function GetNodeIndex(const ThreadID: TThreadID): Integer;\r\n\r\n    function HasActiveWriter(CurThreadNode: TRWThreadNode): Boolean;\r\n    function HasActiveNode(CurThreadNode: TRWThreadNode): Boolean;\r\n\r\n    function AddRWNode(const AThreadID: TThreadID): TRWThreadNode;\r\n    function GetRWThreadNode(const AThreadID: TThreadID): TRWThreadNode;\r\n\r\n    procedure WakeUpWaiters;\r\n    procedure Wait(ThreadNode: TRWThreadNode);\r\n    procedure WaitForReader(ThreadNode: TRWThreadNode);\r\n    procedure WaitForWriter(ThreadNode: TRWThreadNode);\r\n\r\n    property RWNode[const Index: Integer]: TRWThreadNode read GetRWNode;\r\n    property RWNodeCount: Integer read GetRWNodeCount;\r\n  protected\r\n    procedure RaiseRWLockException(const Msg: String);\r\n  public\r\n    constructor Create;\r\n    destructor Destroy; override;\r\n\r\n    procedure Lock(const AState: TRWNodeState);\r\n    function TryLock(const AState: TRWNodeState): Boolean;\r\n    procedure UnLock;\r\n\r\n    {$IFDEF RWLOCK_DEBUG}\r\n    function GetStatus: TRWThreadLockInfoList;\r\n    function GetLockStack: TLockInfoList;\r\n\r\n    property LockEvent: TLockEvent read FLockEvent write FLockEvent;\r\n    property LockWaitEvent: TLockWaitEvent read FLockWaitEvent write FLockWaitEvent;\r\n    {$ENDIF}\r\n  end;\r\n\r\nimplementation\r\n\r\ntype\r\n  TWaitersList = class(TList)\r\n  protected\r\n    procedure Notify(Ptr: Pointer; Action: TListNotification); override;\r\n  public\r\n    constructor Create;\r\n  end;\r\n\r\n{ TRWNode }\r\n\r\nfunction TRWThreadNode.Clone: TRWThreadNode;\r\nbegin\r\n  Result := TRWThreadNode.Create(FThreadID);\r\n\r\n  Result.FReaderAcquires := FReaderAcquires;\r\n  Result.FWriterAcquires := FWriterAcquires;\r\n  Result.FState := FState;\r\n  Result.FIsWait := FIsWait;\r\nend;\r\n\r\nconstructor TRWThreadNode.Create(const AThreadID: TThreadID);\r\nbegin\r\n  inherited Create;\r\n\r\n  FThreadID := AThreadID;\r\n  FReaderAcquires := 0;\r\n  FWriterAcquires := 0;\r\n  FWakeUpEvent := TEvent.Create(nil, False, True, '');\r\n  FState := nsReader;\r\n  FIsWait := True;\r\nend;\r\n\r\nprocedure TRWThreadNode.IncAcquires;\r\nbegin\r\n  case FState of\r\n    nsReader:\r\n      Inc(FReaderAcquires);\r\n    nsWriter:\r\n      Inc(FWriterAcquires);\r\n  end;\r\nend;\r\n\r\nprocedure TRWThreadNode.Wait; // inline;\r\nbegin\r\n  FWakeUpEvent.WaitFor(INFINITE);\r\nend;\r\n\r\nprocedure TRWThreadNode.WakeUp; // inline;\r\nbegin\r\n  FWakeUpEvent.SetEvent;\r\nend;\r\n\r\nprocedure TRWThreadNode.DecAcquires;\r\nbegin\r\n  case FState of\r\n    nsReader:\r\n      Dec(FReaderAcquires);\r\n    nsWriter:\r\n      begin\r\n        Dec(FWriterAcquires);\r\n        if FWriterAcquires = 0 then\r\n          FState := nsReader;\r\n      end;\r\n  end;\r\nend;\r\n\r\ndestructor TRWThreadNode.Destroy;\r\nbegin\r\n  FreeAndNil(FWakeUpEvent);\r\n\r\n  inherited;\r\nend;\r\n\r\nfunction TRWThreadNode.GetAcquires: Integer; // inline\r\nbegin\r\n  Result := FReaderAcquires + FWriterAcquires;\r\nend;\r\n\r\n{ TRWLock }\r\n\r\nconstructor TRWLock.Create;\r\nbegin\r\n  inherited Create;\r\n\r\n  FLock := TCriticalSection.Create;\r\n  FWaiters := TWaitersList.Create;\r\n\r\n  {$IFDEF RWLOCK_DEBUG}\r\n  FLockInfoList := TLockInfoList.Create;\r\n  FLockEvent := Nil;\r\n  FLockWaitEvent := Nil;\r\n  {$ENDIF}\r\nend;\r\n\r\ndestructor TRWLock.Destroy;\r\nbegin\r\n  {$IFDEF RWLOCK_DEBUG}\r\n  if FWaiters.Count > 0 then\r\n    RaiseRWLockException('lock in use');\r\n\r\n  FreeAndNil(FLockInfoList);\r\n  {$ENDIF}\r\n\r\n  FreeAndNil(FWaiters);\r\n  FreeAndNil(FLock);\r\n\r\n  inherited;\r\nend;\r\n\r\nfunction TRWLock.HasActiveNode(CurThreadNode: TRWThreadNode): Boolean;\r\nvar\r\n  Idx: Integer;\r\n  Node: TRWThreadNode;\r\nbegin\r\n  Result := True;\r\n  Idx := 0;\r\n\r\n  while Idx < RWNodeCount do\r\n  begin\r\n    Node := RWNode[Idx];\r\n\r\n    if Node <> CurThreadNode then\r\n      if (Node.WriterAcquires > 0) or ((Node.ReaderAcquires > 0) and not(Node.IsWait)) then\r\n        Exit;\r\n\r\n    Inc(Idx);\r\n  end;\r\n\r\n  Result := False;\r\nend;\r\n\r\nfunction TRWLock.HasActiveWriter(CurThreadNode: TRWThreadNode): Boolean;\r\nvar\r\n  Idx: Integer;\r\n  Node: TRWThreadNode;\r\nbegin\r\n  Result := True;\r\n  Idx := 0;\r\n\r\n  while Idx < RWNodeCount do\r\n  begin\r\n    Node := RWNode[Idx];\r\n\r\n    if Node <> CurThreadNode then\r\n      if (Node.State = nsWriter) and (Node.WriterAcquires > 0) then\r\n        Exit;\r\n\r\n    Inc(Idx);\r\n  end;\r\n\r\n  Result := False;\r\nend;\r\n\r\nfunction TRWLock.GetNodeIndex(const ThreadID: TThreadID): Integer;\r\nvar\r\n  Node: TRWThreadNode;\r\nbegin\r\n  Result := 0;\r\n\r\n  while Result < RWNodeCount do\r\n  begin\r\n    Node := RWNode[Result];\r\n\r\n    if (Node.ThreadID = ThreadID) then\r\n      Exit;\r\n\r\n    Inc(Result);\r\n  end;\r\n\r\n  Result := -1;\r\nend;\r\n\r\nfunction TRWLock.GetRWNode(const Index: Integer): TRWThreadNode; // inline\r\nbegin\r\n  Result := TRWThreadNode(FWaiters.List[Index]);\r\nend;\r\n\r\nfunction TRWLock.GetRWNodeCount: Integer; // inline\r\nbegin\r\n  Result := FWaiters.Count;\r\nend;\r\n\r\nfunction TRWLock.AddRWNode(const AThreadID: TThreadID): TRWThreadNode;\r\nbegin\r\n  Result := TRWThreadNode.Create(AThreadID);\r\n\r\n  FWaiters.Add(Result);\r\nend;\r\n\r\nfunction TRWLock.GetRWThreadNode(const AThreadID: TThreadID): TRWThreadNode;\r\nvar\r\n  Idx: Integer;\r\nbegin\r\n  Idx := GetNodeIndex(AThreadID);\r\n\r\n  if Idx >= 0 then\r\n    Result := RWNode[Idx]\r\n  else\r\n    Result := AddRWNode(AThreadID);\r\nend;\r\n\r\n{$IFDEF RWLOCK_DEBUG}\r\nprocedure TRWLock.AddLockInfo(const ThreadID: TThreadID);\r\nvar\r\n  LockInfo: TLockInfo;\r\nbegin\r\n  LockInfo := TLockInfo.Create;\r\n  LockInfo.ThreadID := ThreadID;\r\n  LockInfo.EnterTime := Now;\r\n\r\n  if Assigned(FLockEvent) then\r\n    FLockEvent(Self, LockInfo);\r\n\r\n  FLockInfoList.Add(LockInfo);\r\nend;\r\n\r\nprocedure TRWLock.DelLockInfo(const ThreadID: TThreadID);\r\nvar\r\n  I: Integer;\r\n  LockInfo: TLockInfo;\r\nbegin\r\n  for I := FLockInfoList.Count - 1 downto 0 do\r\n  begin\r\n    LockInfo := FLockInfoList[I];\r\n\r\n    if LockInfo.ThreadID = ThreadID then\r\n    begin\r\n      FLockInfoList.Delete(I);\r\n      Exit;\r\n    end;\r\n  end;\r\nend;\r\n\r\nfunction TRWLock.GetStatus: TRWThreadLockInfoList;\r\nvar\r\n  I: Integer;\r\nbegin\r\n  Result := TRWThreadLockInfoList.Create;\r\n\r\n  FLock.Enter;\r\n\r\n  for I := 0 to GetRWNodeCount - 1 do\r\n    Result.Add(GetRWNode(I).Clone);\r\n\r\n  FLock.Leave;\r\nend;\r\n\r\nfunction TRWLock.GetLockStack: TLockInfoList;\r\nbegin\r\n  FLock.Enter;\r\n\r\n  Result := FLockInfoList.Clone;\r\n\r\n  FLock.Leave;\r\nend;\r\n{$ENDIF}\r\n\r\nfunction TRWLock.TryLock(const AState: TRWNodeState): Boolean;\r\nvar\r\n  ThreadNode: TRWThreadNode;\r\nbegin\r\n  Result := False;\r\n\r\n  FLock.Enter;\r\n\r\n  ThreadNode := GetRWThreadNode(TThread.CurrentThread.ThreadID);\r\n\r\n  case AState of\r\n    nsReader:\r\n      Result := not(HasActiveWriter(ThreadNode));\r\n    nsWriter:\r\n      begin\r\n        Result := not(HasActiveNode(ThreadNode));\r\n        if Result then\r\n          ThreadNode.State := nsWriter;\r\n      end;\r\n  end;\r\n\r\n  if Result then\r\n  begin\r\n    ThreadNode.IncAcquires;\r\n\r\n    {$IFDEF RWLOCK_DEBUG}\r\n    AddLockInfo(ThreadNode.ThreadID);\r\n    {$ENDIF}\r\n  end\r\n  else\r\n  begin\r\n    if ThreadNode.Acquires = 0 then\r\n      FWaiters.Remove(ThreadNode);\r\n  end;\r\n\r\n  FLock.Leave;\r\nend;\r\n\r\nprocedure TRWLock.Lock(const AState: TRWNodeState);\r\nvar\r\n  ThreadNode: TRWThreadNode;\r\nbegin\r\n  FLock.Enter;\r\n\r\n  ThreadNode := GetRWThreadNode(TThread.CurrentThread.ThreadID);\r\n  ThreadNode.IsWait := True;\r\n\r\n  case AState of\r\n    nsReader:\r\n      begin\r\n        WaitForReader(ThreadNode);\r\n      end;\r\n    nsWriter:\r\n      begin\r\n        ThreadNode.State := nsWriter;\r\n        WaitForWriter(ThreadNode);\r\n      end;\r\n  end;\r\n\r\n  ThreadNode.IncAcquires;\r\n  ThreadNode.IsWait := False;\r\n\r\n  {$IFDEF RWLOCK_DEBUG}\r\n  AddLockInfo(ThreadNode.ThreadID);\r\n  {$ENDIF}\r\n\r\n  FLock.Leave;\r\nend;\r\n\r\nprocedure TRWLock.WaitForReader(ThreadNode: TRWThreadNode);\r\nbegin\r\n  while HasActiveWriter(ThreadNode) do\r\n    Wait(ThreadNode);\r\nend;\r\n\r\nprocedure TRWLock.WaitForWriter(ThreadNode: TRWThreadNode);\r\nbegin\r\n  while HasActiveNode(ThreadNode) do\r\n    Wait(ThreadNode);\r\nend;\r\n\r\nprocedure TRWLock.WakeUpWaiters;\r\nvar\r\n  Idx: Integer;\r\nbegin\r\n  FLock.Enter;\r\n\r\n  for Idx := 0 to RWNodeCount - 1 do\r\n    RWNode[Idx].WakeUp;\r\n\r\n  FLock.Leave;\r\nEnd;\r\n\r\nprocedure TRWLock.Wait(ThreadNode: TRWThreadNode);\r\nbegin\r\n  {$IFDEF RWLOCK_DEBUG}\r\n  if Assigned(FLockWaitEvent) then\r\n    FLockWaitEvent(Self);\r\n  {$ENDIF}\r\n\r\n  FLock.Leave;\r\n\r\n  ThreadNode.Wait;\r\n\r\n  FLock.Enter;\r\nend;\r\n\r\nprocedure TRWLock.UnLock;\r\nvar\r\n  Idx: Integer;\r\n  ThreadNode: TRWThreadNode;\r\nbegin\r\n  FLock.Enter;\r\n\r\n  Idx := GetNodeIndex(TThread.CurrentThread.ThreadID);\r\n\r\n  if Idx >= 0 then\r\n  begin\r\n    ThreadNode := RWNode[Idx];\r\n\r\n    ThreadNode.DecAcquires;\r\n\r\n    if ThreadNode.Acquires = 0 then\r\n      FWaiters.Delete(Idx);\r\n  end;\r\n\r\n  {$IFDEF RWLOCK_DEBUG}\r\n  if Idx < 0 then\r\n    RaiseRWLockException('lock already released');\r\n\r\n  DelLockInfo(TThread.CurrentThread.ThreadID);\r\n  {$ENDIF}\r\n\r\n  FLock.Leave;\r\n\r\n  WakeUpWaiters;\r\nend;\r\n\r\nprocedure TRWLock.RaiseRWLockException(const Msg: String);\r\nbegin\r\n  FLock.Leave;\r\n\r\n  raise ERWLockError.Create(Msg);\r\nend;\r\n\r\n{$IFDEF RWLOCK_DEBUG}\r\n\r\n{ TRWThreadLockInfoList }\r\n\r\nprocedure TRWThreadLockInfoList.Notify(Ptr: Pointer; Action: TListNotification);\r\nbegin\r\n  if Action = lnDeleted then\r\n    TObject(Ptr).Free;\r\nend;\r\n\r\n{ TLockInfoList }\r\n\r\nfunction TLockInfoList.Clone: TLockInfoList;\r\nvar\r\n  I: Integer;\r\n  LockInfo: TLockInfo;\r\nbegin\r\n  Result := TLockInfoList.Create;\r\n\r\n  for I := 0 to Count - 1 do\r\n  begin\r\n    LockInfo := TLockInfo(Items[I]);\r\n    Result.Add(LockInfo.Clone);\r\n  end;\r\nend;\r\n\r\nprocedure TLockInfoList.Notify(Ptr: Pointer; Action: TListNotification);\r\nbegin\r\n  if Action = lnDeleted then\r\n    TObject(Ptr).Free;\r\nend;\r\n\r\n{ TLockInfo }\r\n\r\nfunction TLockInfo.Clone: TLockInfo;\r\nbegin\r\n  Result := TLockInfo.Create;\r\n\r\n  Result.ThreadID := ThreadID;\r\n  Result.EnterTime := EnterTime;\r\n  Result.Stack := Stack;\r\nend;\r\n\r\nfunction TLockInfo.StackToStr: String;\r\nvar\r\n  I: Integer;\r\nbegin\r\n  Result := '';\r\n\r\n  for I := 0 to High(Stack) do\r\n  begin\r\n    if Stack[I] = Nil then\r\n      Break;\r\n\r\n    Result := Result + Format(' $%p', [Stack[I]])\r\n  end;\r\nend;\r\n{$ENDIF}\r\n\r\n{ TWaitersList }\r\n\r\nconstructor TWaitersList.Create;\r\nbegin\r\n  inherited;\r\n\r\n  Capacity := 8;\r\nend;\r\n\r\nprocedure TWaitersList.Notify(Ptr: Pointer; Action: TListNotification);\r\nbegin\r\n  if Action = lnDeleted then\r\n    TObject(Ptr).Free;\r\nend;\r\n\r\nend.\r\n"
  },
  {
    "path": "uSQLiteDB.pas",
    "content": "unit uSQLiteDB;\r\n\r\ninterface\r\n\r\nuses\r\n  System.Contnrs, System.SysUtils, System.Classes, System.Types, System.Sqlite,\r\n  uRWLock;\r\n\r\ntype\r\n  HSQLCONTEXT = Pointer;\r\n  HSQLDB = Pointer;\r\n  HSQLQUERY = Pointer;\r\n  HSQLVALUE = Pointer;\r\n  \r\n  TSQLBase = class;\r\n  TSQLColumnType = (sctUnknown = 0, sctInteger = 1, sctFloat = 2, sctText = 3, sctBlob = 4, sctNull = 5);\r\n\r\n  { TAIMPSqlColumn }\r\n\r\n  TSQLColumn = class(TObject)\r\n  private\r\n    FDataType: TSQLColumnType;\r\n    FName: String;\r\n  public\r\n    property DataType: TSQLColumnType read FDataType;\r\n    property Name: String read FName;\r\n  end;\r\n\r\n  { TAIMPSqlTable }\r\n\r\n  TSQLTableClass = class of TSQLTable;\r\n  TSQLTable = class(TObject)\r\n  private\r\n    FDataBase: TSQLBase;\r\n    FQuery: HSQLQUERY;\r\n\r\n    FColumns: TObjectList;\r\n    FDataTypesFetched: Boolean;\r\n\r\n    function FetchDataTypes: Boolean;\r\n    function GetColumn(const Index: Integer): TSQLColumn;\r\n    function GetColumnCount: Integer;\r\n    function GetFieldIndex(const Name: String): Integer;\r\n    function GetValue(const ColumnName: String): Variant;\r\n\r\n    function GetActive: Boolean; inline;\r\n    procedure SetActive(const Value: Boolean);\r\n  protected\r\n    procedure CheckActive;\r\n    procedure CheckDBActive;\r\n    procedure UpdateQuery; virtual;\r\n    procedure ClearQuery; virtual;\r\n  public\r\n    constructor Create(ADataBase: TSQLBase; AQuery: HSQLQUERY);\r\n    destructor Destroy; override;\r\n\r\n    function NextRecord: Boolean;\r\n    // I/O\r\n    function ReadBlob(const AIndex: Integer; AData: TMemoryStream): Integer; overload;\r\n    function ReadBlob(const AName: String; AData: TMemoryStream): Integer; overload;\r\n    function ReadDouble(const AIndex: Integer): Double; overload;\r\n    function ReadDouble(const AName: String): Double; overload;\r\n    function ReadInt(const AIndex: Integer): Integer; overload;\r\n    function ReadInt(const AName: String): Integer; overload;\r\n    function ReadStr(const AIndex: Integer): String; overload;\r\n    function ReadStr(const AName: String): String; overload;\r\n    function ReadInt64(const AIndex: Integer): Int64; overload;\r\n    function ReadInt64(const AName: String): Int64; overload;\r\n    function ReadDateTime(const AIndex: Integer): TDateTime; overload;\r\n    function ReadDateTime(const AName: String): TDateTime; overload;\r\n    // Properties\r\n    property Column[const Index: Integer]: TSQLColumn read GetColumn; default;\r\n    property ColumnCount: Integer read GetColumnCount;\r\n    property Value[const ColumnName: String]: Variant read GetValue;\r\n    property DataBase: TSQLBase read FDataBase;\r\n\r\n    function FieldExists(const Name: String): Boolean;\r\n\r\n    property Active: Boolean read GetActive write SetActive;\r\n  end;\r\n\r\n  TSQLView = class(TSQLTable)\r\n  private\r\n    FParamCount: Integer;\r\n    FQueryStr: String;\r\n    FLock: TRWLock;\r\n\r\n    procedure InitParams;\r\n  protected\r\n    procedure UpdateQuery; override;\r\n    procedure Reset;\r\n    procedure SetParamAsText(const ParamIdx: Integer; const Str: String);\r\n\r\n    property Lock: TRWLock read FLock;\r\n  public\r\n    constructor Create(ADataBase: TSQLBase; AQuery: HSQLQUERY; const AQueryStr: String = ''); overload;\r\n    constructor Create(ADataBase: TSQLBase; const AQueryStr: String); overload;\r\n\r\n    destructor Destroy; override;\r\n\r\n    procedure SetParam(const ParamName: String; const Value: Variant); overload;\r\n    procedure SetParam(const ParamIdx: Integer; const Value: Variant); overload;\r\n\r\n    procedure BeginExecute;\r\n    procedure EndExecute;\r\n    function Execute: Boolean;\r\n  end;\r\n\r\n  TSQLConnectMgr = class;\r\n\r\n  TOnErrorEvent = procedure(const ErrorCode: Integer; const ErrorText, Query: String) of object;\r\n\r\n  // PRAGMA journal_mode = DELETE | TRUNCATE | PERSIST | MEMORY | WAL | OFF\r\n  TSQLJournalModeType = (ttDefault = 0, ttDelete, ttTruncate, ttPersist, ttMemory, ttWAL, ttOff);\r\n\r\n  // PRAGMA synchronous = 0 | OFF | 1 | NORMAL | 2 | FULL;\r\n  TSQLSynchronousType = (stDefault = 0, stOff, stNormal, stFull);\r\n\r\n  TSQLBeginTransactionType = (btGlobal = 0, btDeferred, btImmediate, btExclusive);\r\n\r\n  TSQLCodes = set of Byte;\r\n\r\n  { TAIMPSqlBase }\r\n\r\n  TSQLBase = class(TObject)\r\n  private\r\n    FDB: HSQLDB;\r\n    FConnectMgr: TSQLConnectMgr;\r\n    FLinkedTables: TObjectList;\r\n\r\n    FLock: TRWLock;\r\n\r\n    FTransactions: Integer;\r\n\r\n    FOnError: TOnErrorEvent;\r\n    FJournalModeType: TSQLJournalModeType;\r\n    FSynchronousType: TSQLSynchronousType;\r\n\r\n    FGlobalTransactionLock: TRWLock;\r\n    FInGlobalTransaction: Boolean;\r\n\r\n    function CheckError(const ErrorCode: Integer; const ValidCodes: TSQLCodes = [SQLITE_OK]; const Query: String = ''): Boolean;\r\n    function PrepareQuery(const AQueryStr: String; out AQuery: HSQLQUERY): Boolean;\r\n    Function DoExecStep(AQueryHandle: HSQLQUERY): Integer;\r\n\r\n    function GetFileName: String;\r\n\r\n    procedure SetJournalModeType(const Value: TSQLJournalModeType);\r\n    procedure SetSynchronousType(const Value: TSQLSynchronousType);\r\n\r\n    procedure AddLinkedTable(Table: TSQLTable);\r\n    procedure RemoveLinkedTable(Table: TSQLTable);\r\n\r\n    function GetActive: Boolean; inline;\r\n    procedure SetActive(const Value: Boolean);\r\n  protected\r\n    procedure DataBaseInitTables; virtual;\r\n    procedure ErrorMsg(const AText: String; const ErrorCode: Integer; const Query: String = ''); overload; virtual;\r\n    procedure ErrorMsg(AText: PChar; const ErrorCode: Integer; const Query: String = ''); overload;\r\n\r\n    procedure Open;\r\n    procedure Close;\r\n\r\n    procedure CheckActive;\r\n  public\r\n    constructor Create(AConnectMgr: TSQLConnectMgr);\r\n    destructor Destroy; override;\r\n\r\n    function ClearAll: Boolean; virtual;\r\n    procedure Compress;\r\n    function PopulateTableNames(out AList: TStrings): Boolean;\r\n\r\n    procedure BeginTransaction(const ATransactionType: TSQLBeginTransactionType = btDeferred);\r\n    procedure EndTransaction;\r\n    procedure CancelTransaction;\r\n\r\n    function ExecSQL(const AQuery: String): Boolean; overload;\r\n    function ExecSQL(const AQuery: String; out ATable: TSQLTable): Boolean; overload;\r\n\r\n    function CreateView(const AQuery: String): TSQLView;\r\n    procedure UpdatePreparedStatements;\r\n    procedure ClosePreparedStatements;\r\n\r\n    function GetLastInsertRowID: Int64;\r\n\r\n    // Blobs: Use \"?\" symbol in Query for set data position\r\n    function ExecInsertBlob(const AQuery: String; AData: TMemoryStream): Boolean;\r\n    // Properties\r\n    property FileName: String read GetFileName;\r\n\r\n    //-  \r\n    Function GetRowAffected : Integer;\r\n    //-   \r\n    Function GetColCount(Const ATableName: String): Integer;\r\n    // \r\n    Function IsEmpty(Const ATableName: String): Boolean;\r\n    Function DeleteTable(Const ATableName: String): Boolean;\r\n\r\n    Procedure Lock(const LockType: TRWNodeState = nsWriter);\r\n    Procedure UnLock;\r\n\r\n    Procedure GlobalLock; inline;\r\n    procedure GlobalUnLock; inline;\r\n\r\n    Function GetVersion: Integer;\r\n\r\n    property ConnectMgr: TSQLConnectMgr read FConnectMgr;\r\n    property OnError: TOnErrorEvent read FOnError write FOnError;\r\n    property JournalModeType: TSQLJournalModeType read FJournalModeType write SetJournalModeType;\r\n    property SynchronousType: TSQLSynchronousType read FSynchronousType write SetSynchronousType;\r\n\r\n    property Active: Boolean read GetActive write SetActive;\r\n  end;\r\n\r\n  TSQLConnectMgr = class(TObject)\r\n  private\r\n    FDBFileName: String;\r\n    FLock: TRWLock;\r\n    FDBConnections: TList;\r\n    FActive: Boolean;\r\n\r\n    procedure SetDBFileName(const Value: String);\r\n    procedure SetActive(const Value: Boolean);\r\n  public\r\n    constructor Create(const ADBFileName: String);\r\n    destructor Destroy; override;\r\n\r\n    function GetNewConnection: TSQLBase;\r\n    function GetDefaultConnection: TSQLBase;\r\n\r\n    procedure Remove(Connect: TSQLBase);\r\n    procedure Reset(const FreeConnections: Boolean = True);\r\n\r\n    property DBFileName: String read FDBFileName write SetDBFileName;\r\n    property Active: Boolean read FActive write SetActive;\r\n  end;\r\n\r\n  TDBException = class(Exception);\r\n\r\nfunction DBConnectMgr(const DBName: String): TSQLConnectMgr;\r\nfunction GetDBConnections: TStringList;\r\nprocedure DBResetAll(const FreeConnections: Boolean = True);\r\n\r\nfunction sqlite_DateTimeToStr(const DateTime: TDateTime): string;\r\nfunction sqlite_TryStrToDateTime(const Str: String; var Res: TDateTime): Boolean;\r\nfunction sqlite_StrToDateTime(const Str: String; const DefValue: TDateTime = 0): TDateTime;\r\nfunction sqlite_Str(const Str: String; var Count: Integer): PWideChar;\r\n\r\nimplementation\r\n\r\nuses\r\n  System.Variants, System.StrUtils, System.WideStrUtils;\r\n\r\ntype\r\n  TSQLCompare = function (P1: PChar; P1Size: Integer; P2: PChar; P2Size: Integer): Integer; cdecl;\r\n  TSQLFunction = procedure (Context: HSQLCONTEXT; ArgCount: Integer; ArgVars: PPointer); cdecl;\r\n  TSQLFunctionEnd = procedure (Context: HSQLCONTEXT); cdecl;\r\n  TSQLiteBusyHandlerCallback = function(UserData: Pointer; P2: integer): integer; cdecl;\r\n\r\n  TDBConnectMgrList = TStringList;\r\n\r\nvar\r\n  _DBConnectMgrList: TDBConnectMgrList = nil;\r\n  _DBConnectMgrLock: TRWLock = nil;\r\n\r\nfunction DBConnectMgr(const DBName: String): TSQLConnectMgr;\r\nvar\r\n  Idx: Integer;\r\n  DBAlias: string;\r\nbegin\r\n  Result := Nil;\r\n\r\n  if _DBConnectMgrLock = Nil then Exit;\r\n\r\n  DBAlias := AnsiLowerCase(ExtractFileName(DBName));\r\n\r\n  _DBConnectMgrLock.Lock(nsReader);\r\n  try\r\n    Idx := -1;\r\n    if _DBConnectMgrList <> nil then\r\n      Idx := _DBConnectMgrList.IndexOf(DBAlias);\r\n\r\n    if Idx >= 0 then\r\n      Result := TSQLConnectMgr(_DBConnectMgrList.Objects[Idx])\r\n    else\r\n    begin\r\n      _DBConnectMgrLock.Lock(nsWriter);\r\n      try\r\n        if _DBConnectMgrList.IndexOf(DBAlias) < 0 then\r\n        begin\r\n          Result := TSQLConnectMgr.Create(DBName);\r\n          _DBConnectMgrList.AddObject(DBAlias, Result);\r\n          Result.Active := True;\r\n        end\r\n        else\r\n          Result := DBConnectMgr(DBName);\r\n      finally\r\n        _DBConnectMgrLock.UnLock;\r\n      end;\r\n    end;\r\n\r\n    //  ,     \r\n    if not AnsiSameText(Result.DBFileName, DBName) then\r\n      Result.DBFileName := DBName;\r\n  finally\r\n    _DBConnectMgrLock.UnLock;\r\n  end;\r\nend;\r\n\r\nfunction GetDBConnections: TStringList;\r\nbegin\r\n  Result := TStringList.Create;\r\n\r\n  _DBConnectMgrLock.Lock(nsReader);\r\n  try\r\n    Result.Assign(_DBConnectMgrList);\r\n  finally\r\n    _DBConnectMgrLock.UnLock;\r\n  end;\r\nend;\r\n\r\nprocedure DBResetAll(const FreeConnections: Boolean = True);\r\nvar\r\n  Mgr: TSQLConnectMgr;\r\n  I: Integer;\r\nbegin\r\n  _DBConnectMgrLock.Lock(nsWriter);\r\n  try\r\n    if Assigned(_DBConnectMgrList) then\r\n    begin\r\n      for I := _DBConnectMgrList.Count - 1 downto 0 do\r\n      begin\r\n        Mgr := TSQLConnectMgr(_DBConnectMgrList.Objects[I]);\r\n        Mgr.Active := False;\r\n\r\n        if FreeConnections then\r\n        begin\r\n          _DBConnectMgrList.Objects[I] := nil;\r\n          if Assigned(Mgr) then\r\n            FreeAndNil(Mgr);\r\n        end;\r\n      end;\r\n\r\n      if FreeConnections then\r\n        _DBConnectMgrList.Clear;\r\n    end;\r\n  finally\r\n    _DBConnectMgrLock.UnLock;\r\n  end;\r\nend;\r\n\r\nconst\r\n  SQLITE_DATE_FMT = 'yyyy-mm-dd';\r\n  SQLITE_TIME_FMT = 'hh:nn:ss';\r\n  SQLITE_DATETIME_FMT = SQLITE_DATE_FMT + ' ' + SQLITE_TIME_FMT;\r\n\r\nfunction sqlite_DateTimeToStr(const DateTime: TDateTime): string;\r\nbegin\r\n  if DateTime <> 0 then\r\n    Result := FormatDateTime(SQLITE_DATETIME_FMT, DateTime)\r\n  else\r\n    Result := '';\r\nend;\r\n\r\nvar\r\n  _sqlite_DateTimeFormat: TFormatSettings;\r\n\r\nfunction sqlite_TryStrToDateTime(const Str: String; var Res: TDateTime): Boolean;\r\nbegin\r\n  Result := TryStrToDateTime(Str, Res, _sqlite_DateTimeFormat);\r\nend;\r\n\r\nfunction sqlite_StrToDateTime(const Str: String; const DefValue: TDateTime = 0): TDateTime;\r\nbegin\r\n  if not sqlite_TryStrToDateTime(Str, Result) then\r\n    Result := DefValue;\r\nend;\r\n\r\nfunction sqlite_Str(const Str: String; var Count: Integer): PWideChar;\r\nvar\r\n  StrBuf: RawByteString;\r\nbegin\r\n  StrBuf := UTF8Encode(Str);\r\n\r\n  Count := Length(StrBuf);\r\n  if Count > 0 then\r\n    Result := PWideChar(Pointer(@StrBuf[1]))\r\n  else\r\n    Result := Nil;\r\nend;\r\n\r\nfunction sqlite_StrToString(Str: PChar; Count: Integer): String;\r\nvar\r\n  Buf: RawByteString;\r\nbegin\r\n  Result := '';\r\n\r\n  if Count > 0 then\r\n  begin\r\n    SetLength(Buf, Count);\r\n    Move(Str^, PAnsiChar(Buf)^, Count);\r\n\r\n    Result := UTF8ToString(Buf);\r\n  end;\r\nend;\r\n\r\nfunction UnicodeCompare(UserData: Pointer; P1Size: Integer; P1: PChar; P2Size: Integer; P2: PChar): Integer; cdecl;\r\nvar\r\n  S1, S2: String;\r\nbegin\r\n  S1 := sqlite_StrToString(P1, P1Size);\r\n  S2 := sqlite_StrToString(P2, P2Size);\r\n\r\n  Result := AnsiCompareText(S1, S2);\r\nend;\r\n\r\nprocedure SQLiteUpper(Context: HSQLCONTEXT; ArgCount: Integer; ArgVars: PPointerArray); cdecl;\r\nvar\r\n  Arg: Pointer;\r\n  Cnt: Integer;\r\n  BufIn: Pointer;\r\n  StrRes: String;\r\n  BufOut: PWideChar;\r\nbegin\r\n  Arg := ArgVars^[0];\r\n  if (sqlite3_value_type(Arg) <> SQLITE_NULL) then\r\n  begin\r\n    Cnt := sqlite3_value_bytes16(Arg);\r\n    if Cnt > 0 then\r\n    begin\r\n      BufIn := sqlite3_value_text16(Arg);\r\n\r\n      StrRes := sqlite_StrToString(BufIn, Cnt);\r\n      StrRes := AnsiUpperCase(StrRes);\r\n      BufOut := sqlite_Str(StrRes, Cnt); // TODO: MemLeak?\r\n\r\n      sqlite3_result_text16(Context, BufOut, Cnt, nil);\r\n    end\r\n    else\r\n      sqlite3_result_text16(Context, nil, 0, nil);\r\n  end\r\n  else\r\n    sqlite3_result_null(Context);\r\nend;\r\n\r\n{ TAIMPSqlTable }\r\n\r\nprocedure TSQLTable.CheckActive;\r\nbegin\r\n  if not Active then\r\n    raise TDBException.Create('Table is not active');\r\nend;\r\n\r\nprocedure TSQLTable.CheckDBActive;\r\nbegin\r\n  if not FDataBase.Active then\r\n    raise TDBException.Create('Linked DB is not active');\r\nend;\r\n\r\nprocedure TSQLTable.ClearQuery;\r\nbegin\r\n  if Active then\r\n  try\r\n    CheckDBActive;\r\n\r\n    FreeAndNil(FColumns);\r\n\r\n    FDataBase.GlobalLock;\r\n    try\r\n      FDataBase.CheckError(sqlite3_finalize(FQuery), [SQLITE_OK, SQLITE_ABORT]);\r\n    finally\r\n      FDataBase.GlobalUnLock;\r\n    end;\r\n  finally\r\n    FQuery := nil;\r\n  end;\r\nend;\r\n\r\nconstructor TSQLTable.Create(ADataBase: TSQLBase; AQuery: HSQLQUERY);\r\nbegin\r\n  inherited Create;\r\n  FColumns := TObjectList.Create;\r\n  FDataBase := ADataBase;\r\n  FQuery := AQuery;\r\n\r\n  FDataBase.AddLinkedTable(Self);\r\nend;\r\n\r\ndestructor TSQLTable.Destroy;\r\nbegin\r\n  FDataBase.RemoveLinkedTable(Self);\r\n\r\n  ClearQuery;\r\n\r\n  inherited Destroy;\r\nend;\r\n\r\nfunction TSQLTable.FetchDataTypes: Boolean;\r\nvar\r\n  AColumn   : TSQLColumn;\r\n  ADataType: Integer;\r\n  I, ACount : Integer;\r\nbegin\r\n  FColumns.Clear;\r\n\r\n  CheckActive;\r\n  CheckDBActive;\r\n\r\n  FDataBase.GlobalLock;\r\n  try\r\n    ACount := sqlite3_column_count(FQuery);\r\n    FColumns.Capacity := ACount;\r\n    for I := 0 to ACount - 1 do\r\n    begin\r\n      AColumn := TSQLColumn.Create;\r\n      AColumn.FName := sqlite3_column_name16(FQuery, I);\r\n\r\n      ADataType := sqlite3_column_type(FQuery, I);\r\n      AColumn.FDataType := TSQLColumnType(ADataType);\r\n\r\n      FColumns.Add(AColumn);\r\n    end;\r\n  finally\r\n    FDataBase.GlobalUnLock;\r\n  end;\r\n\r\n  Result := True;\r\nend;\r\n\r\nfunction TSQLTable.FieldExists(const Name: String): Boolean;\r\nbegin\r\n  Result := GetFieldIndex(Name) >= 0;\r\nend;\r\n\r\nfunction TSQLTable.NextRecord: Boolean;\r\nvar\r\n  ResCode: Integer;\r\nbegin\r\n  CheckActive;\r\n  CheckDBActive;\r\n\r\n  FDataBase.GlobalLock;\r\n  try\r\n    ResCode := FDataBase.DoExecStep(FQuery);\r\n    Result := FDataBase.CheckError(ResCode, [SQLITE_ROW, SQLITE_DONE]) and (ResCode = SQLITE_ROW);\r\n  finally\r\n    FDataBase.GlobalUnLock;\r\n  end;\r\nend;\r\n\r\nfunction TSQLTable.ReadBlob(const AIndex: Integer; AData: TMemoryStream): Integer;\r\nvar\r\n  ABlobBuffer: PByte;\r\nbegin\r\n  CheckActive;\r\n  CheckDBActive;\r\n\r\n  Result := sqlite3_column_bytes16(FQuery, AIndex);\r\n  if Assigned(AData) then\r\n  begin\r\n    ABlobBuffer := sqlite3_column_blob(FQuery, AIndex);\r\n    if Assigned(ABlobBuffer) then\r\n    begin\r\n      AData.Size := Result;\r\n      Move(ABlobBuffer^, AData.Memory^, AData.Size);\r\n    end\r\n    else\r\n      AData.Size := 0;\r\n  end;\r\nend;\r\n\r\nfunction TSQLTable.ReadBlob(const AName: String; AData: TMemoryStream): Integer;\r\nbegin\r\n  Result := ReadBlob(GetFieldIndex(AName), AData);\r\nend;\r\n\r\nfunction TSQLTable.ReadDouble(const AIndex: Integer): Double;\r\nbegin\r\n  CheckActive;\r\n  CheckDBActive;\r\n\r\n  Result := sqlite3_column_double(FQuery, AIndex);\r\nend;\r\n\r\nfunction TSQLTable.ReadDouble(const AName: String): Double;\r\nbegin\r\n  Result := ReadDouble(GetFieldIndex(AName));\r\nend;\r\n\r\nfunction TSQLTable.ReadInt(const AIndex: Integer): Integer;\r\nbegin\r\n  CheckActive;\r\n  CheckDBActive;\r\n\r\n  Result := sqlite3_column_int(FQuery, AIndex);\r\nend;\r\n\r\nfunction TSQLTable.ReadInt(const AName: String): Integer;\r\nbegin\r\n  Result := ReadInt(GetFieldIndex(AName));\r\nend;\r\n\r\nfunction TSQLTable.ReadInt64(const AIndex: Integer): Int64;\r\nbegin\r\n  CheckActive;\r\n  CheckDBActive;\r\n\r\n  Result := sqlite3_column_int64(FQuery, AIndex);\r\nend;\r\n\r\nfunction TSQLTable.ReadInt64(const AName: String): Int64;\r\nbegin\r\n  Result := ReadInt64(GetFieldIndex(AName));\r\nend;\r\n\r\nfunction TSQLTable.ReadDateTime(const AIndex: Integer): TDateTime;\r\nbegin\r\n  Result := sqlite_StrToDateTime(ReadStr(AIndex));\r\nend;\r\n\r\nfunction TSQLTable.ReadDateTime(const AName: String): TDateTime;\r\nbegin\r\n  Result := ReadDateTime(GetFieldIndex(AName));\r\nend;\r\n\r\nfunction TSQLTable.ReadStr(const AIndex: Integer): String;\r\nvar\r\n  textResult : PChar;\r\nbegin\r\n  Result := '';\r\n\r\n  CheckActive;\r\n  CheckDBActive;\r\n\r\n  textResult := sqlite3_column_text16(FQuery, AIndex);\r\n  if textResult <> nil then\r\n    Result := String(textResult);\r\nend;\r\n\r\nfunction TSQLTable.ReadStr(const AName: String): String;\r\nbegin\r\n  Result := ReadStr(GetFieldIndex(AName));\r\nend;\r\n\r\nprocedure TSQLTable.SetActive(const Value: Boolean);\r\nbegin\r\n  if Active <> Value then\r\n  begin\r\n    if Value then\r\n      UpdateQuery\r\n    else\r\n      ClearQuery;\r\n  end;\r\nend;\r\n\r\nprocedure TSQLTable.UpdateQuery;\r\nbegin\r\n  // TODO:\r\nend;\r\n\r\nfunction TSQLTable.GetActive: Boolean;\r\nbegin\r\n  Result := Assigned(FQuery);\r\nend;\r\n\r\nfunction TSQLTable.GetColumn(const Index: Integer): TSQLColumn;\r\nbegin\r\n  CheckActive;\r\n\r\n  if not FDataTypesFetched then\r\n    FDataTypesFetched := FetchDataTypes;\r\n\r\n  Result := TSQLColumn(FColumns[Index]);\r\nend;\r\n\r\nfunction TSQLTable.GetColumnCount: Integer;\r\nbegin\r\n  CheckActive;\r\n\r\n  if not FDataTypesFetched then\r\n    FDataTypesFetched := FetchDataTypes;\r\n\r\n  Result := FColumns.Count;\r\nend;\r\n\r\nfunction TSQLTable.GetFieldIndex(const Name: String): Integer;\r\nvar\r\n  I: Integer;\r\n  Column: TSQLColumn;\r\nbegin\r\n  CheckActive;\r\n\r\n  if not FDataTypesFetched then\r\n    FDataTypesFetched := FetchDataTypes;\r\n\r\n  Result := -1;\r\n  for I := 0 to FColumns.Count - 1 do\r\n  begin\r\n    Column := TSQLColumn(FColumns.List[I]);\r\n\r\n    if SameText(Column.Name, Name) then\r\n    begin\r\n      Result := I;\r\n      Break;\r\n    end;\r\n  end;\r\nend;\r\n\r\nfunction TSQLTable.GetValue(const ColumnName: String): Variant;\r\nvar\r\n  Idx: Integer;\r\n  Column: TSQLColumn;\r\nbegin\r\n  CheckActive;\r\n\r\n  Idx := GetFieldIndex(ColumnName);\r\n\r\n  if Idx >= 0 then\r\n  begin\r\n    Column := GetColumn(Idx);\r\n    case Column.DataType of\r\n      sctInteger:\r\n        Result := ReadInt64(Idx);\r\n      sctFloat:\r\n        Result := ReadDouble(Idx);\r\n      sctText:\r\n        Result := ReadStr(Idx);\r\n      sctBlob:\r\n        Result := ReadStr(Idx);\r\n      sctNull:\r\n        Result := Null;\r\n    else\r\n      raise TDBException.CreateFmt('Unknown type %d for field \"%s\"', [Integer(Column.DataType), ColumnName]);\r\n    end;\r\n  end\r\n  else\r\n    raise TDBException.CreateFmt('Field \"%s\" not found', [ColumnName]);\r\nend;\r\n\r\n{ TAIMPSqlBase }\r\n\r\nfunction busy(UserData: Pointer; P2: integer): integer; cdecl;\r\nbegin\r\n  Sleep(100);\r\n  Result := 0;\r\nend;\r\n\r\nconstructor TSQLBase.Create(AConnectMgr: TSQLConnectMgr);\r\nbegin\r\n  inherited Create;\r\n\r\n  FJournalModeType := ttDefault;\r\n  FSynchronousType := stDefault;\r\n  FOnError := Nil;\r\n  FConnectMgr := AConnectMgr;\r\n  FLock := TRWLock.Create;\r\n  FLinkedTables := TObjectList.Create;\r\n  FTransactions := 0;\r\n  FGlobalTransactionLock := TRWLock.Create;;\r\n  FInGlobalTransaction := False;\r\n\r\n  Open;\r\n\r\n  DataBaseInitTables;\r\nend;\r\n\r\nfunction TSQLBase.CreateView(const AQuery: String): TSQLView;\r\nbegin\r\n  Result := TSQLView.Create(Self, AQuery);\r\nend;\r\n\r\nfunction TSQLBase.DeleteTable(const ATableName: String): Boolean;\r\nbegin\r\n  Result := ExecSQL('DROP TABLE IF EXIST ' + ATableName);\r\nend;\r\n\r\ndestructor TSQLBase.Destroy;\r\nbegin\r\n  Active := False;\r\n\r\n  FLinkedTables.Clear;\r\n  FreeAndNil(FLinkedTables);\r\n\r\n  FConnectMgr.Remove(Self);\r\n  FConnectMgr := Nil;\r\n\r\n  FreeAndNil(FGlobalTransactionLock);\r\n  FreeAndNil(FLock);\r\n\r\n  inherited Destroy;\r\nend;\r\n\r\nprocedure TSQLBase.DataBaseInitTables;\r\nbegin\r\nend;\r\n\r\nprocedure TSQLBase.ErrorMsg(AText: PChar; const ErrorCode: Integer; const Query: String = '');\r\nbegin\r\n  ErrorMsg(String(AText), ErrorCode, Query);\r\nend;\r\n\r\nprocedure TSQLBase.AddLinkedTable(Table: TSQLTable);\r\nbegin\r\n  FLock.Lock(nsWriter);\r\n  try\r\n    FLinkedTables.Add(Table);\r\n  finally\r\n    FLock.UnLock;\r\n  end;\r\nend;\r\n\r\nprocedure TSQLBase.BeginTransaction(const ATransactionType: TSQLBeginTransactionType = btDeferred);\r\nvar\r\n  TypeStr: String;\r\nbegin\r\n  //ExecSQL(Format('SAVEPOINT sp_%d;', [TInterlocked.Increment(FTransactions) - 1]));\r\n\r\n  FGlobalTransactionLock.Lock(nsReader);\r\n\r\n  //        \r\n  if ATransactionType = btGlobal then\r\n  begin\r\n    if not FInGlobalTransaction then\r\n    begin\r\n      FGlobalTransactionLock.Lock(nsWriter);\r\n      FInGlobalTransaction := True;\r\n    end;\r\n  end;\r\n\r\n  Lock(nsReader);\r\n  try\r\n    //   btGlobal   CancelTransaction\r\n    if ATransactionType = btGlobal then\r\n    begin\r\n      // ,    \r\n      while FTransactions > 0 do\r\n        Sleep(10);\r\n    end;\r\n\r\n    if FTransactions = 0 then\r\n      begin\r\n        Lock;\r\n        try\r\n          if FTransactions = 0 then\r\n            begin\r\n              case ATransactionType of\r\n                btDeferred:\r\n                  TypeStr := 'DEFERRED';\r\n                btImmediate:\r\n                  TypeStr := 'IMMEDIATE';\r\n                btExclusive, btGlobal:\r\n                  TypeStr := 'EXCLUSIVE';\r\n              else\r\n                TypeStr := '';\r\n              end;\r\n\r\n              if ExecSQL(Format('BEGIN %s TRANSACTION;', [TypeStr])) then\r\n                AtomicIncrement(FTransactions);\r\n            end\r\n          else\r\n            AtomicIncrement(FTransactions);\r\n        finally\r\n          UnLock;\r\n        end;\r\n      end\r\n    else\r\n      AtomicIncrement(FTransactions);\r\n  finally\r\n    UnLock;\r\n  end;\r\nend;\r\n\r\nprocedure TSQLBase.EndTransaction;\r\nbegin\r\n  //ExecSQL(Format('RELEASE SAVEPOINT sp_%d;', [TInterlocked.Decrement(FTransactions)]));\r\n\r\n  Lock(nsReader);\r\n  try\r\n    if FTransactions = 1 then\r\n      begin\r\n        Lock(nsWriter);\r\n        try\r\n          if FTransactions = 1 then\r\n            begin\r\n              if ExecSQL('END TRANSACTION;') then\r\n                AtomicExchange(FTransactions, 0);\r\n\r\n              if FInGlobalTransaction then\r\n              begin\r\n                FInGlobalTransaction := False;\r\n                FGlobalTransactionLock.UnLock;\r\n\r\n                Exit;\r\n              end;\r\n            end\r\n          else\r\n            AtomicDecrement(FTransactions);\r\n        finally\r\n          UnLock;\r\n        end;\r\n      end\r\n    else\r\n      AtomicDecrement(FTransactions);\r\n  finally\r\n    UnLock;\r\n\r\n    FGlobalTransactionLock.UnLock;\r\n  end;\r\nend;\r\n\r\nprocedure TSQLBase.CancelTransaction;\r\nbegin\r\n  //ExecSQL(Format('ROLLBACK TO SAVEPOINT sp_%d;', [TInterlocked.Decrement(FTransactions)]));\r\n\r\n  Lock;\r\n  try\r\n    {$IFDEF DEBUG}\r\n    if not FInGlobalTransaction then\r\n      ErrorMsg('TSQLBase.CancelTransaction: Only for Global transactions!', -1);\r\n    {$ENDIF}\r\n\r\n    if AtomicDecrement(FTransactions) = 0 then\r\n    begin\r\n      ExecSQL('ROLLBACK TRANSACTION;');\r\n\r\n      FInGlobalTransaction := False;\r\n\r\n      FGlobalTransactionLock.UnLock;\r\n    end;\r\n  finally\r\n    UnLock;\r\n  end;\r\nend;\r\n\r\nfunction TSQLBase.ClearAll: Boolean;\r\nvar\r\n  AList: TStrings;\r\n  I: Integer;\r\nbegin\r\n  Result := PopulateTableNames(AList);\r\n  if Result then\r\n  try\r\n    for I := 0 to AList.Count - 1 do\r\n      Result := Result and ExecSQL('DROP TABLE IF EXISTS ' + AList[I]);\r\n\r\n    DataBaseInitTables;\r\n  finally\r\n    FreeAndNil(AList);\r\n  end;\r\nend;\r\n\r\nprocedure TSQLBase.Close;\r\nbegin\r\n  //   .  ROLLBACK      except\r\n  Lock;\r\n  try\r\n    if Active then\r\n    begin\r\n      if (FTransactions > 0) then\r\n      begin\r\n        //    \r\n        while FTransactions > 0 do\r\n        begin\r\n          UnLock;\r\n          Sleep(1);\r\n          Lock;\r\n        end;\r\n      end;\r\n\r\n      //   \r\n      ClosePreparedStatements;\r\n\r\n      //     WAL\r\n      if JournalModeType = ttWAL then\r\n        JournalModeType := ttDelete;\r\n\r\n      //  \r\n      CheckError(sqlite3_close(FDB));\r\n    end;\r\n  finally\r\n    FDB := nil;\r\n    UnLock;\r\n  end;\r\nend;\r\n\r\nprocedure TSQLBase.ClosePreparedStatements;\r\nvar\r\n  I: Integer;\r\n  Table: TSQLTable;\r\n  stmt: sqlite3_stmt;\r\nbegin\r\n  CheckActive;\r\n\r\n  Lock;\r\n  try\r\n    //   Views\r\n    if Assigned(FLinkedTables) then\r\n    begin\r\n      for I := 0 to FLinkedTables.Count - 1 do\r\n      begin\r\n        Table := TSQLTable(FLinkedTables[I]);\r\n        Table.Active := False;\r\n      end;\r\n    end;\r\n\r\n    //   \r\n    repeat\r\n      stmt := sqlite3_next_stmt(FDB, nil);\r\n\r\n      if Assigned(stmt) then\r\n        CheckError(sqlite3_finalize(stmt), [SQLITE_OK, SQLITE_ABORT]);\r\n    until (stmt = nil);\r\n  finally\r\n    UnLock;\r\n  end;\r\nend;\r\n\r\nprocedure TSQLBase.Compress;\r\nbegin\r\n  // TODO: http://www.sqlite.org/lang_vacuum.html\r\n  // ExecSQL('VACUUM');\r\nend;\r\n\r\nfunction TSQLBase.PopulateTableNames(out AList: TStrings): Boolean;\r\nconst\r\n  SQLITE_GET_TABLES_QUERY = 'SELECT name FROM sqlite_master WHERE (type=''table'') ORDER BY name;';\r\nvar\r\n  ATable: TSQLTable;\r\nbegin\r\n  Result := ExecSQL(SQLITE_GET_TABLES_QUERY, ATable);\r\n  if Result then\r\n  try\r\n    AList := TStringList.Create;\r\n    repeat\r\n      AList.Add(ATable.ReadStr(0));\r\n    until not ATable.NextRecord;\r\n  finally\r\n    FreeAndNil(ATable);\r\n  end;\r\nend;\r\n\r\nprocedure TSQLBase.CheckActive;\r\nbegin\r\n  if not Active then\r\n    raise TDBException.Create('Active = false');\r\nend;\r\n\r\nfunction TSQLBase.CheckError(const ErrorCode: Integer; const ValidCodes: TSQLCodes = [SQLITE_OK]; const Query: String = ''): Boolean;\r\nbegin\r\n  Result := (ErrorCode in ValidCodes);\r\n  if not Result then\r\n    ErrorMsg(sqlite3_errmsg16(FDB), ErrorCode, Query);\r\nend;\r\n\r\nprocedure TSQLBase.ErrorMsg(const AText: String; const ErrorCode: Integer; const Query: String = '');\r\nbegin\r\n  if Assigned(FOnError) then\r\n    FOnError(ErrorCode, AText, Query);\r\nend;\r\n\r\nfunction TSQLBase.ExecInsertBlob(const AQuery: String; AData: TMemoryStream): Boolean;\r\nvar\r\n  AQueryHandle: HSQLQUERY;\r\n  ResCode: Integer;\r\nbegin\r\n  GlobalLock;\r\n  try\r\n    Result := PrepareQuery(AQuery, AQueryHandle);\r\n    if Result then\r\n    try\r\n      Result := CheckError(sqlite3_bind_blob(AQueryHandle, 1, AData.Memory, AData.Size, Pointer(SQLITE_STATIC)));\r\n      if Result then\r\n      begin\r\n        ResCode := DoExecStep(AQueryHandle);\r\n        Result := CheckError(ResCode, [SQLITE_ROW, SQLITE_DONE]) and (ResCode = SQLITE_ROW);\r\n      end;\r\n    finally\r\n      CheckError(sqlite3_finalize(AQueryHandle));\r\n    end;\r\n  finally\r\n    GlobalUnLock;\r\n  end;\r\nend;\r\n\r\nfunction TSQLBase.ExecSQL(const AQuery: String; out ATable: TSQLTable): Boolean;\r\nvar\r\n  AQueryHandle: HSQLQUERY;\r\n  ResCode: Integer;\r\nbegin\r\n  ATable := nil;\r\n\r\n  CheckActive;\r\n\r\n  AQueryHandle := nil;\r\n\r\n  GlobalLock;\r\n  try\r\n    Result := PrepareQuery(AQuery, AQueryHandle);\r\n    if Result then\r\n      begin\r\n        ResCode := DoExecStep(AQueryHandle);\r\n\r\n        Result := CheckError(ResCode, [SQLITE_ROW, SQLITE_DONE], AQuery) and (ResCode = SQLITE_ROW);\r\n        if Result then\r\n          ATable := TSQLTable.Create(Self, AQueryHandle)\r\n        else\r\n          CheckError(sqlite3_finalize(AQueryHandle));\r\n      end;\r\n  finally\r\n    GlobalUnLock;\r\n  end;\r\nend;\r\n\r\nfunction TSQLBase.ExecSQL(const AQuery: String): Boolean;\r\nvar\r\n  AQueryHandle: HSQLQUERY;\r\nbegin\r\n  CheckActive;\r\n\r\n  GlobalLock;\r\n  try\r\n    Result := PrepareQuery(AQuery, AQueryHandle);\r\n    if Result then\r\n      try\r\n        Result := CheckError(DoExecStep(AQueryHandle), [SQLITE_ROW, SQLITE_DONE], AQuery);\r\n      finally\r\n        CheckError(sqlite3_finalize(AQueryHandle));\r\n      end;\r\n  finally\r\n    GlobalUnLock;\r\n  end;\r\nend;\r\n\r\nfunction TSQLBase.PrepareQuery(const AQueryStr: String; out AQuery: HSQLQUERY): Boolean;\r\nvar\r\n  QueryBufStr: PChar;\r\n  Count: Integer;\r\n  ANext: PWideChar;\r\n  prepareResult : integer;\r\nbegin\r\n  Result := False;\r\n  AQuery := nil;\r\n  if AQueryStr = '' then\r\n    Exit;\r\n\r\n  QueryBufStr := sqlite_Str(AQueryStr, Count);\r\n  try\r\n    ANext := nil;\r\n\r\n    prepareResult := sqlite3_prepare16_v2(FDB, QueryBufStr, Count, AQuery, ANext);\r\n\r\n    Result := CheckError(prepareResult, [SQLITE_OK], AQueryStr);\r\n  finally\r\n    FreeMemory(QueryBufStr);\r\n  end;\r\nend;\r\n\r\nfunction TSQLBase.DoExecStep(AQueryHandle: HSQLQUERY): Integer;\r\nbegin\r\n  GlobalLock;\r\n  try\r\n    Result := sqlite3_step(AQueryHandle);\r\n  finally\r\n    GlobalUnLock;\r\n  end;\r\nend;\r\n\r\nprocedure TSQLBase.RemoveLinkedTable(Table: TSQLTable);\r\nbegin\r\n  Lock;\r\n  try\r\n    FLinkedTables.OwnsObjects := False;\r\n    FLinkedTables.Remove(Table);\r\n    FLinkedTables.OwnsObjects := True;\r\n  finally\r\n    UnLock;\r\n  end;\r\nend;\r\n\r\nprocedure TSQLBase.SetActive(const Value: Boolean);\r\nbegin\r\n  if Active <> Value then\r\n  begin\r\n    if Value then\r\n      Open\r\n    else\r\n      Close;\r\n  end;\r\nend;\r\n\r\nprocedure TSQLBase.SetJournalModeType(const Value: TSQLJournalModeType);\r\nconst\r\n  _JOURNAL_MODE_VALUES: array[TSQLJournalModeType] of string =\r\n    ('DELETE', 'DELETE', 'TRUNCATE', 'PERSIST', 'MEMORY', 'WAL', 'OFF');\r\n\r\n  _QUERY = 'PRAGMA journal_mode = %s;';\r\nvar\r\n  Query: string;\r\nbegin\r\n  if FJournalModeType <> Value then\r\n  begin\r\n    // http://www.sqlite.org/pragma.html#pragma_journal_mode\r\n    Query := Format(_QUERY, [_JOURNAL_MODE_VALUES[Value]]);\r\n\r\n    if ExecSQL(Query) then\r\n    begin\r\n      FJournalModeType := Value;\r\n\r\n      case FJournalModeType of\r\n        ttDelete:\r\n          SynchronousType := stFull;\r\n        ttMemory:\r\n          SynchronousType := stFull;\r\n        ttWAL:\r\n          begin\r\n            // http://www.sqlite.org/wal.html\r\n            //  WAL    NORMAL\r\n            SynchronousType := stNormal;\r\n          end;\r\n      end;\r\n    end;\r\n  end;\r\nend;\r\n\r\nprocedure TSQLBase.SetSynchronousType(const Value: TSQLSynchronousType);\r\nconst\r\n  // PRAGMA synchronous = 0 | OFF | 1 | NORMAL | 2 | FULL;\r\n  _SYNC_TYPE_VALUES: Array[TSQLSynchronousType] of string =\r\n    ('FULL', 'OFF', 'NORMAL', 'FULL');\r\n  _QUERY = 'PRAGMA synchronous = %s;';\r\nvar\r\n  Query: string;\r\nbegin\r\n  if FSynchronousType <> Value then\r\n  begin\r\n    // http://www.sqlite.org/pragma.html#pragma_synchronous\r\n    Query := Format(_QUERY, [_SYNC_TYPE_VALUES[Value]]);\r\n\r\n    if ExecSQL(Query) then\r\n      FSynchronousType := Value;\r\n  end;\r\nend;\r\n\r\nfunction TSQLBase.GetFileName: String;\r\nbegin\r\n  Result := FConnectMgr.DBFileName;\r\nend;\r\n\r\nfunction TSQLBase.GetLastInsertRowID: Int64;\r\nbegin\r\n  GlobalLock;\r\n  try\r\n    Result := sqlite3_last_insert_rowid(FDB);\r\n  finally\r\n    GlobalUnLock;\r\n  end;\r\nend;\r\n\r\nfunction TSQLBase.GetActive: Boolean;\r\nbegin\r\n  Result := Assigned(FDB);\r\nend;\r\n\r\nfunction TSQLBase.GetColCount(const ATableName: String): Integer;\r\nvar\r\n  ATable: TSQLTable;\r\nbegin\r\n  Result := 0;\r\n  try\r\n    if ExecSQL('SELECT * FROM ' + ATableName + ' LIMIT 1;', ATable) then\r\n      try\r\n        Result := ATable.ColumnCount;\r\n      finally\r\n        FreeAndNil(ATable);\r\n      end\r\n    else\r\n      if ExecSQL('SELECT * FROM PRAGMA table_info(' + ATableName + ');', ATable) then\r\n        try\r\n          GlobalLock;\r\n          try\r\n            repeat\r\n              if ATable.GetColumn(Result).FName <> '' then\r\n              Inc(Result);\r\n            until Not ATable.NextRecord;\r\n          finally\r\n            GlobalUnLock;\r\n          end;\r\n        finally\r\n          FreeAndNil(ATable);\r\n        end\r\n      else\r\n        Result := -1;\r\n  except\r\n    Result := -1;\r\n  end;\r\nend;\r\n\r\nFunction TSQLBase.IsEmpty(Const ATableName: String): Boolean;\r\nvar\r\n  ATable: TSQLTable;\r\nbegin\r\n  if ExecSQL('SELECT * FROM ' + ATableName + ' LIMIT 1;', ATable) then\r\n     try\r\n       Result := False;\r\n     finally\r\n       FreeAndNil(ATable);\r\n     end\r\n  else\r\n    Result := True;\r\nend;\r\n\r\nfunction TSQLBase.GetRowAffected: Integer;\r\nbegin\r\n  GlobalLock;\r\n  try\r\n    Result := sqlite3_changes(FDB);\r\n  finally\r\n    GlobalUnLock;\r\n  end;\r\nend;\r\n\r\nfunction TSQLBase.GetVersion: Integer;\r\nbegin\r\n  Result := sqlite3_libversion_number;\r\nend;\r\n\r\nprocedure TSQLBase.GlobalLock;\r\nbegin\r\n  Lock(nsReader);\r\nend;\r\n\r\nprocedure TSQLBase.GlobalUnLock;\r\nbegin\r\n  UnLock;\r\nend;\r\n\r\nProcedure TSQLBase.Lock(const LockType: TRWNodeState = nsWriter);\r\nBegin\r\n  FLock.Lock(LockType);\r\nEnd;\r\n\r\nprocedure TSQLBase.Open;\r\nbegin\r\n  Lock;\r\n  try\r\n    if not Active then\r\n    begin\r\n      if not CheckError(sqlite3_open16(PChar(FileName), FDB)) then\r\n      begin\r\n        raise TDBException.CreateFmt('Fail open DB: %s', [FileName]);\r\n      end;\r\n\r\n      CheckError(sqlite3_create_collation16(FDB, 'UNICODE', SQLITE_UTF16, nil, @UnicodeCompare));\r\n      // SYNCWIN-1382\r\n      CheckError(sqlite3_create_function16(FDB, 'upper', 1, SQLITE_UTF16, nil, @SQLiteUpper, nil, nil));\r\n      //CheckError(sqlite3_create_function16(FDB, 'HasKey', 2, SQLITE_UTF16, nil, @HasKeyFunc, nil, nil));\r\n\r\n      // TODO: http://www.sqlite.org/sharedcache.html\r\n      //CheckError(sqlite3_enable_shared_cache(1));\r\n      //ExecSQL('PRAGMA read_uncommitted = True;');\r\n\r\n      CheckError(sqlite3_busy_handler(FDB, @busy, nil));\r\n      CheckError(sqlite3_busy_timeout(FDB, 2000));\r\n    end;\r\n  finally\r\n    UnLock;\r\n  end;\r\nend;\r\n\r\nProcedure TSQLBase.UnLock;\r\nBegin\r\n  FLock.UnLock;\r\nEnd;\r\n\r\nprocedure TSQLBase.UpdatePreparedStatements;\r\nvar\r\n  I: Integer;\r\n  Table: TSQLTable;\r\nbegin\r\n  CheckActive;\r\n\r\n  Lock;\r\n  try\r\n    for I := 0 to FLinkedTables.Count - 1 do\r\n    begin\r\n      Table := TSQLTable(FLinkedTables[I]);\r\n      Table.Active := False;\r\n      Table.Active := True;\r\n    end;\r\n  finally\r\n    UnLock;\r\n  end;\r\nend;\r\n\r\n{ TAIMPSqlConnectMgr }\r\n\r\nconstructor TSQLConnectMgr.Create(const ADBFileName: String);\r\nbegin\r\n  inherited Create;\r\n\r\n  FDBFileName := ADBFileName;\r\n  FLock := TRWLock.Create;\r\n  FDBConnections := TList.Create;\r\n  FActive := True;\r\nend;\r\n\r\ndestructor TSQLConnectMgr.Destroy;\r\nbegin\r\n  Reset;\r\n\r\n  FreeAndNil(FDBConnections);\r\n  FreeAndNil(FLock);\r\n\r\n  inherited Destroy;\r\nend;\r\n\r\nfunction TSQLConnectMgr.GetNewConnection: TSQLBase;\r\nbegin\r\n  Result := TSQLBase.Create(Self);\r\n  FDBConnections.Add(Result);\r\n\r\n  Result.Active := Active;\r\nend;\r\n\r\nfunction TSQLConnectMgr.GetDefaultConnection: TSQLBase;\r\nbegin\r\n  FLock.Lock(nsReader);\r\n  try\r\n    if FDBConnections.Count > 0 then\r\n      Result := TSQLBase(FDBConnections[0])\r\n    else\r\n      begin\r\n        FLock.Lock(nsWriter);\r\n        try\r\n          if FDBConnections.Count = 0 then\r\n            Result := GetNewConnection\r\n          else\r\n            Result := GetDefaultconnection;\r\n        finally\r\n          FLock.UnLock;\r\n        end;\r\n      end;\r\n  finally\r\n    FLock.UnLock;\r\n  end;\r\nend;\r\n\r\nprocedure TSQLConnectMgr.Remove(Connect: TSQLBase);\r\nbegin\r\n  FLock.Lock(nsWriter);\r\n  try\r\n    FDBConnections.Remove(Connect);\r\n  finally\r\n    FLock.UnLock;\r\n  end;\r\nend;\r\n\r\nprocedure TSQLConnectMgr.Reset(const FreeConnections: Boolean = True);\r\nvar\r\n  DBConnection: TSQLBase;\r\nbegin\r\n  FLock.Lock(nsWriter);\r\n  try\r\n    Active := False;\r\n\r\n    if FreeConnections then\r\n    begin\r\n      while FDBConnections.Count > 0 do\r\n      begin\r\n        DBConnection := TSQLBase(FDBConnections[0]);\r\n\r\n        FreeAndNil(DBConnection); //       \r\n      end;\r\n    end;\r\n  finally\r\n    FLock.UnLock;\r\n  end;\r\nend;\r\n\r\nprocedure TSQLConnectMgr.SetActive(const Value: Boolean);\r\nvar\r\n  DBConnection: TSQLBase;\r\n  I: Integer;\r\nbegin\r\n  if FActive <> Value then\r\n  begin\r\n    FLock.Lock(nsWriter);\r\n    try\r\n      for I := 0 to FDBConnections.Count - 1 do\r\n      begin\r\n        DBConnection := TSQLBase(FDBConnections[I]);\r\n        DBConnection.Active := Value;\r\n      end;\r\n    finally\r\n      FLock.UnLock;\r\n    end;\r\n\r\n    FActive := Value;\r\n  end;\r\nend;\r\n\r\nprocedure TSQLConnectMgr.SetDBFileName(const Value: String);\r\nvar\r\n  OldActive: Boolean;\r\nbegin\r\n  FLock.Lock(nsWriter);\r\n  try\r\n    if not AnsiSameText(FDBFileName, Value) then\r\n    begin\r\n      OldActive := Active;\r\n      Active := False;\r\n\r\n      FDBFileName := Value;\r\n\r\n      Active := OldActive;\r\n    end;\r\n  finally\r\n    FLock.UnLock;\r\n  end;\r\nend;\r\n\r\nfunction _Reset: Boolean;\r\nbegin\r\n  Result := True;\r\n\r\n  DBResetAll;\r\n\r\n  FreeAndNil(_DBConnectMgrList);\r\n  FreeAndNil(_DBConnectMgrLock);\r\nend;\r\n\r\nprocedure _Init;\r\nbegin\r\n  _DBConnectMgrList := TDBConnectMgrList.Create;\r\n  _DBConnectMgrList.Duplicates := dupError;\r\n\r\n  _DBConnectMgrLock := TRWLock.Create;\r\n\r\n  _sqlite_DateTimeFormat := TFormatSettings.Create;\r\n  _sqlite_DateTimeFormat.DateSeparator := '-';\r\n  _sqlite_DateTimeFormat.TimeSeparator := ':';\r\n  _sqlite_DateTimeFormat.ShortDateFormat := SQLITE_DATE_FMT;\r\n  _sqlite_DateTimeFormat.ShortTimeFormat := SQLITE_TIME_FMT;\r\nend;\r\n\r\n{ TAIMPSqlView }\r\n\r\nconstructor TSQLView.Create(ADataBase: TSQLBase; AQuery: HSQLQUERY; const AQueryStr: String = '');\r\nbegin\r\n  inherited Create(ADataBase, AQuery);\r\n\r\n  FLock := TRWLock.Create;\r\n  FQueryStr := AQueryStr;\r\n\r\n  InitParams;\r\nend;\r\n\r\nprocedure TSQLView.SetParam(const ParamName: String; const Value: Variant);\r\nvar\r\n  ParamIdx: Integer;\r\nbegin\r\n  CheckActive;\r\n  CheckDBActive;\r\n\r\n  ParamIdx := sqlite3_bind_parameter_index(FQuery, PAnsiChar(AnsiString(ParamName)));\r\n\r\n  if ParamIdx > 0 then\r\n    SetParam(ParamIdx, Value)\r\n  else\r\n    raise TDBException.CreateFmt('Parameter \"%s\" not found in view', [ParamName]);\r\nend;\r\n\r\nprocedure TSQLView.BeginExecute;\r\nbegin\r\n  CheckActive;\r\n\r\n  Lock.Lock(nsWriter);\r\n  FDataBase.GlobalLock;\r\n  try\r\n    CheckDBActive;\r\n    Reset;\r\n  except\r\n    on E: Exception do\r\n    begin\r\n      FDataBase.GlobalUnLock;\r\n      Lock.UnLock;\r\n      raise;\r\n    end;\r\n  end;\r\nend;\r\n\r\nconstructor TSQLView.Create(ADataBase: TSQLBase; const AQueryStr: String);\r\nvar\r\n  AQuery: HSQLQUERY;\r\nbegin\r\n  ADataBase.CheckActive;\r\n\r\n  ADataBase.GlobalLock;\r\n  try\r\n    if ADataBase.PrepareQuery(AQueryStr, AQuery) then\r\n      Create(ADataBase, AQuery, AQueryStr)\r\n    else\r\n      raise TDBException.CreateFmt('Fail create view: \"%s\"', [AQueryStr]);\r\n  finally\r\n    ADataBase.GlobalUnLock;\r\n  end;\r\nend;\r\n\r\ndestructor TSQLView.Destroy;\r\nbegin\r\n  FreeAndNil(FLock);\r\n\r\n  inherited;\r\nend;\r\n\r\nprocedure TSQLView.EndExecute;\r\nbegin\r\n  try\r\n    Reset;\r\n  finally\r\n    FDataBase.GlobalUnLock;\r\n    Lock.UnLock;\r\n  end;\r\nend;\r\n\r\nfunction TSQLView.Execute: Boolean;\r\nbegin\r\n  Result := NextRecord;\r\nend;\r\n\r\nprocedure TSQLView.InitParams;\r\nbegin\r\n  CheckActive;\r\n  CheckDBActive;\r\n\r\n  FParamCount := sqlite3_bind_parameter_count(FQuery);\r\nend;\r\n\r\nprocedure TSQLView.Reset;\r\nbegin\r\n  CheckActive;\r\n  CheckDBActive;\r\n\r\n  FDataBase.GlobalLock;\r\n  try\r\n    FDataBase.CheckError(sqlite3_reset(FQuery));\r\n    FDataBase.CheckError(sqlite3_clear_bindings(FQuery));\r\n  finally\r\n    FDataBase.GlobalUnLock;\r\n  end;\r\nend;\r\n\r\nprocedure TSQLView.SetParam(const ParamIdx: Integer; const Value: Variant);\r\nbegin\r\n  CheckActive;\r\n  CheckDBActive;\r\n\r\n  if (ParamIdx > 0) and (ParamIdx <= FParamCount) then\r\n  begin\r\n    case VarType(Value) of\r\n      varSmallInt, varInteger, varShortInt, varByte, varWord, varLongWord, varInt64, varUInt64:\r\n        FDataBase.CheckError(sqlite3_bind_int64(FQuery, ParamIdx, Int64(Value)), [SQLITE_OK], FQueryStr);\r\n      varSingle, varDouble, varCurrency:\r\n        FDataBase.CheckError(sqlite3_bind_double(FQuery, ParamIdx, Double(Value)), [SQLITE_OK], FQueryStr);\r\n      varDate:\r\n        SetParamAsText(ParamIdx, sqlite_DateTimeToStr(TDateTime(Value)));\r\n      varBoolean:\r\n        SetParamAsText(ParamIdx, BoolToStr(Boolean(Value)));\r\n      varString, varUString:\r\n        SetParamAsText(ParamIdx, String(Value));\r\n    else\r\n      begin\r\n        if VarIsNull(Value) then\r\n          FDataBase.CheckError(sqlite3_bind_null(FQuery, ParamIdx))\r\n        else\r\n          raise TDBException.CreateFmt('Invalid value type for parameter \"%d\"', [ParamIdx]);\r\n      end;\r\n    end;\r\n  end\r\n  else\r\n    raise TDBException.CreateFmt('Parameter \"%d\" not found for view', [ParamIdx]);\r\nend;\r\n\r\nprocedure TSQLView.SetParamAsText(const ParamIdx: Integer; const Str: String);\r\nvar\r\n  StrBuf: PWideChar;\r\n  Count: Integer;\r\nbegin\r\n  CheckActive;\r\n  CheckDBActive;\r\n\r\n  StrBuf := sqlite_Str(Str, Count);\r\n  try\r\n    FDataBase.CheckError(\r\n      sqlite3_bind_text16(FQuery, ParamIdx, StrBuf, Count, TBindDestructor(SQLITE_TRANSIENT)),\r\n      [SQLITE_OK],\r\n      FQueryStr\r\n    );\r\n  finally\r\n    FreeMemory(StrBuf);\r\n  end;\r\nend;\r\n\r\nprocedure TSQLView.UpdateQuery;\r\nbegin\r\n  CheckDBActive;\r\n\r\n  FDataBase.GlobalLock;\r\n  try\r\n    // ,     \r\n    ClearQuery;\r\n\r\n    if FDataBase.PrepareQuery(FQueryStr, FQuery) then\r\n      InitParams\r\n    else\r\n      raise TDBException.CreateFmt('Fail update view: \"%s\"', [FQueryStr]);\r\n  finally\r\n    FDataBase.GlobalUnLock;\r\n  end;\r\nend;\r\n\r\ninitialization\r\n  _Init;\r\n\r\nfinalization\r\n  _Reset;\r\nend.\r\n\r\n"
  },
  {
    "path": "uSelectSource.dfm",
    "content": "object fmSelectSource: TfmSelectSource\r\n  Left = 0\r\n  Top = 0\r\n  BorderIcons = [biSystemMenu]\r\n  BorderStyle = bsSingle\r\n  Caption = 'Select source'\r\n  ClientHeight = 347\r\n  ClientWidth = 537\r\n  Color = clBtnFace\r\n  Font.Charset = DEFAULT_CHARSET\r\n  Font.Color = clWindowText\r\n  Font.Height = -11\r\n  Font.Name = 'Tahoma'\r\n  Font.Style = []\r\n  OldCreateOrder = False\r\n  Position = poScreenCenter\r\n  OnCreate = FormCreate\r\n  OnDestroy = FormDestroy\r\n  PixelsPerInch = 96\r\n  TextHeight = 13\r\n  object cbTop: TCoolBar\r\n    Left = 0\r\n    Top = 0\r\n    Width = 537\r\n    Height = 26\r\n    AutoSize = True\r\n    Bands = <\r\n      item\r\n        Control = actbTop\r\n        ImageIndex = -1\r\n        MinHeight = 26\r\n        Width = 537\r\n      end>\r\n    EdgeBorders = []\r\n    FixedSize = True\r\n    FixedOrder = True\r\n    object actbTop: TActionToolBar\r\n      Left = 0\r\n      Top = 0\r\n      Width = 537\r\n      Height = 26\r\n      ActionManager = acmgrSelectSource\r\n      Caption = 'actbTop'\r\n      ColorMap.MenuColor = clMenu\r\n      ColorMap.BtnSelectedColor = clBtnFace\r\n      ColorMap.UnusedColor = 13684944\r\n      Font.Charset = DEFAULT_CHARSET\r\n      Font.Color = clBlack\r\n      Font.Height = -11\r\n      Font.Name = 'Tahoma'\r\n      Font.Style = []\r\n      ParentFont = False\r\n      Spacing = 0\r\n    end\r\n  end\r\n  object sgSource: TStringGrid\r\n    Left = 0\r\n    Top = 26\r\n    Width = 537\r\n    Height = 278\r\n    Align = alClient\r\n    BorderStyle = bsNone\r\n    ColCount = 1\r\n    DefaultRowHeight = 18\r\n    FixedCols = 0\r\n    FixedRows = 0\r\n    Options = [goFixedVertLine, goFixedHorzLine, goVertLine, goHorzLine, goDrawFocusSelected]\r\n    TabOrder = 1\r\n    ColWidths = (\r\n      500)\r\n  end\r\n  object pActions: TPanel\r\n    Left = 0\r\n    Top = 304\r\n    Width = 537\r\n    Height = 43\r\n    Align = alBottom\r\n    BevelOuter = bvNone\r\n    Caption = 'pActions'\r\n    ShowCaption = False\r\n    TabOrder = 2\r\n    object btnOk: TBitBtn\r\n      Left = 359\r\n      Top = 10\r\n      Width = 75\r\n      Height = 25\r\n      Action = acOk\r\n      Caption = 'Save'\r\n      TabOrder = 0\r\n    end\r\n    object btnCancel: TBitBtn\r\n      Left = 448\r\n      Top = 10\r\n      Width = 75\r\n      Height = 25\r\n      Action = acCancel\r\n      Caption = 'Cancel'\r\n      TabOrder = 1\r\n    end\r\n  end\r\n  object alSelectSource: TActionList\r\n    Images = dmShareData.ilActionsSmall\r\n    OnUpdate = alSelectSourceUpdate\r\n    Left = 392\r\n    Top = 80\r\n    object acOk: TAction\r\n      Caption = 'Save'\r\n      ImageIndex = 1\r\n      OnExecute = acOkExecute\r\n    end\r\n    object acCancel: TAction\r\n      Caption = 'Cancel'\r\n      ImageIndex = 2\r\n      OnExecute = acCancelExecute\r\n    end\r\n    object acAdd: TAction\r\n      Caption = 'Add'\r\n      ImageIndex = 5\r\n      OnExecute = acAddExecute\r\n    end\r\n    object acRemove: TAction\r\n      Caption = 'Remove'\r\n      ImageIndex = 6\r\n      OnExecute = acRemoveExecute\r\n    end\r\n    object acEdit: TAction\r\n      Caption = 'Edit'\r\n      ImageIndex = 0\r\n      OnExecute = acEditExecute\r\n    end\r\n    object acUp: TAction\r\n      Caption = 'Up'\r\n      ImageIndex = 7\r\n      OnExecute = acUpExecute\r\n    end\r\n    object acDown: TAction\r\n      Caption = 'Down'\r\n      ImageIndex = 8\r\n      OnExecute = acDownExecute\r\n    end\r\n  end\r\n  object acmgrSelectSource: TActionManager\r\n    ActionBars = <\r\n      item\r\n        Items = <\r\n          item\r\n            Action = acCancel\r\n            Caption = '&Cancel'\r\n            ImageIndex = 2\r\n          end\r\n          item\r\n            Action = acOk\r\n            Caption = '&Save'\r\n            ImageIndex = 1\r\n          end>\r\n      end\r\n      item\r\n        Items = <\r\n          item\r\n            Action = acAdd\r\n            Caption = '&Add'\r\n            ImageIndex = 5\r\n          end\r\n          item\r\n            Action = acEdit\r\n            Caption = '&Edit'\r\n            ImageIndex = 0\r\n          end\r\n          item\r\n            Action = acRemove\r\n            Caption = '&Remove'\r\n            ImageIndex = 6\r\n          end\r\n          item\r\n            Caption = '-'\r\n          end\r\n          item\r\n            Action = acUp\r\n            Caption = '&Up'\r\n            ImageIndex = 7\r\n          end\r\n          item\r\n            Action = acDown\r\n            Caption = '&Down'\r\n            ImageIndex = 8\r\n          end>\r\n        ActionBar = actbTop\r\n      end>\r\n    DisabledImages = dmShareData.ilActionsSmall\r\n    LinkedActionLists = <\r\n      item\r\n        ActionList = alSelectSource\r\n        Caption = 'alSelectSource'\r\n      end>\r\n    Images = dmShareData.ilActionsSmall\r\n    Left = 392\r\n    Top = 136\r\n    StyleName = 'Ribbon - Silver'\r\n  end\r\n  object odSelectSource: TFileOpenDialog\r\n    FavoriteLinks = <>\r\n    FileTypes = <>\r\n    Options = [fdoPickFolders, fdoPathMustExist]\r\n    Title = 'Select source folder'\r\n    Left = 392\r\n    Top = 192\r\n  end\r\nend\r\n"
  },
  {
    "path": "uSelectSource.pas",
    "content": "unit uSelectSource;\r\n\r\ninterface\r\n\r\nuses\r\n  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,\r\n  Dialogs, PlatformDefaultStyleActnCtrls, ActnMan, ActnList, ActnCtrls,\r\n  ToolWin, ComCtrls, RibbonSilverStyleActnCtrls, Grids, System.Actions,\r\n  Vcl.ExtCtrls, Vcl.StdCtrls, Vcl.Buttons;\r\n\r\ntype\r\n  TfmSelectSource = class(TForm)\r\n    alSelectSource: TActionList;\r\n    acmgrSelectSource: TActionManager;\r\n    acOk: TAction;\r\n    acCancel: TAction;\r\n    acAdd: TAction;\r\n    acRemove: TAction;\r\n    acEdit: TAction;\r\n    cbTop: TCoolBar;\r\n    actbTop: TActionToolBar;\r\n    sgSource: TStringGrid;\r\n    odSelectSource: TFileOpenDialog;\r\n    pActions: TPanel;\r\n    btnOk: TBitBtn;\r\n    btnCancel: TBitBtn;\r\n    acUp: TAction;\r\n    acDown: TAction;\r\n    procedure acOkExecute(Sender: TObject);\r\n    procedure acCancelExecute(Sender: TObject);\r\n    procedure acAddExecute(Sender: TObject);\r\n    procedure FormCreate(Sender: TObject);\r\n    procedure FormDestroy(Sender: TObject);\r\n    procedure acRemoveExecute(Sender: TObject);\r\n    procedure acEditExecute(Sender: TObject);\r\n    procedure alSelectSourceUpdate(Action: TBasicAction; var Handled: Boolean);\r\n    procedure acUpExecute(Sender: TObject);\r\n    procedure acDownExecute(Sender: TObject);\r\n  private\r\n    FList: TStringList;\r\n    procedure AddSource(const FolderName: String);\r\n    procedure SetSourceList(const Value: String);\r\n    function GetSourceList: String;\r\n    procedure UpdateView;\r\n  public\r\n    property SourceList: String read GetSourceList write SetSourceList;\r\n  end;\r\n\r\n  function SelectSource(const SourceList: String): String;\r\n\r\nvar\r\n  fmSelectSource: TfmSelectSource;\r\n\r\nimplementation\r\n\r\nuses\r\n  uShareData;\r\n\r\n{$R *.dfm}\r\n\r\nfunction SelectSource(const SourceList: String): String;\r\nvar\r\n  F: TfmSelectSource;\r\nbegin\r\n  Result := SourceList;\r\n\r\n  Application.CreateForm(TfmSelectSource, F);\r\n  try\r\n    F.SourceList := SourceList;\r\n    if F.ShowModal = mrOk then\r\n      Result := F.SourceList;\r\n  finally\r\n    F.Release;\r\n  end;\r\nend;\r\n\r\nprocedure TfmSelectSource.acAddExecute(Sender: TObject);\r\nbegin\r\n  if odSelectSource.Execute then\r\n    AddSource(odSelectSource.FileName);\r\nend;\r\n\r\nprocedure TfmSelectSource.acCancelExecute(Sender: TObject);\r\nbegin\r\n  ModalResult := mrCancel;\r\nend;\r\n\r\nprocedure TfmSelectSource.acDownExecute(Sender: TObject);\r\nvar\r\n  Str: String;\r\nbegin\r\n  if sgSource.Row < sgSource.RowCount then\r\n  begin\r\n    Str := FList.Strings[sgSource.Row];\r\n    FList.Strings[sgSource.Row] := FList.Strings[sgSource.Row + 1];\r\n    FList.Strings[sgSource.Row + 1] := Str;\r\n\r\n    sgSource.Row := sgSource.Row + 1;\r\n\r\n    UpdateView;\r\n  end;\r\nend;\r\n\r\nprocedure TfmSelectSource.acEditExecute(Sender: TObject);\r\nvar\r\n  CurSource: String;\r\nbegin\r\n  if FList.Count = 0 then Exit;\r\n  \r\n  CurSource := '';\r\n  if sgSource.Row >= 0 then\r\n  begin\r\n    if FList.Count > sgSource.Row then\r\n    begin\r\n      CurSource := FList.Strings[sgSource.Row];\r\n      odSelectSource.DefaultFolder := CurSource;\r\n      odSelectSource.FileName := '';\r\n    end;\r\n\r\n    if odSelectSource.Execute then\r\n    begin\r\n      FList.Strings[sgSource.Row] := odSelectSource.FileName;\r\n      UpdateView;\r\n    end;\r\n  end;\r\nend;\r\n\r\nprocedure TfmSelectSource.acOkExecute(Sender: TObject);\r\nbegin\r\n  ModalResult := mrOk;\r\nend;\r\n\r\nprocedure TfmSelectSource.acRemoveExecute(Sender: TObject);\r\nbegin\r\n  if sgSource.Row >= 0 then\r\n  begin\r\n    if FList.Count > 0 then\r\n      FList.Delete(sgSource.Row);\r\n    UpdateView;\r\n  end;\r\nend;\r\n\r\nprocedure TfmSelectSource.acUpExecute(Sender: TObject);\r\nvar\r\n  Str: String;\r\nbegin\r\n  if sgSource.Row > 0 then\r\n  begin\r\n    Str := FList.Strings[sgSource.Row];\r\n    FList.Strings[sgSource.Row] := FList.Strings[sgSource.Row - 1];\r\n    FList.Strings[sgSource.Row - 1] := Str;\r\n\r\n    sgSource.Row := sgSource.Row - 1;\r\n\r\n    UpdateView;\r\n  end;\r\nend;\r\n\r\nprocedure TfmSelectSource.AddSource(const FolderName: String);\r\nbegin\r\n  if FList.IndexOf(FolderName) < 0 then\r\n  begin\r\n    FList.Add(FolderName);\r\n    UpdateView;\r\n  end;\r\nend;\r\n\r\nprocedure TfmSelectSource.alSelectSourceUpdate(Action: TBasicAction;\r\n  var Handled: Boolean);\r\nbegin\r\n  acEdit.Enabled := FList.Count > 0;\r\n  acRemove.Enabled := acEdit.Enabled;\r\n\r\n  acUp.Enabled := (sgSource.Row - 1) >= 0;\r\n  acDown.Enabled := (sgSource.Row + 1) < sgSource.RowCount;\r\nend;\r\n\r\nprocedure TfmSelectSource.FormCreate(Sender: TObject);\r\nbegin\r\n  actbTop.ParentBackground := True;\r\n\r\n  FList := TStringList.Create;\r\n  FList.Duplicates := dupIgnore;\r\n  FList.Delimiter := ';';\r\n  FList.StrictDelimiter := True;\r\nend;\r\n\r\nprocedure TfmSelectSource.FormDestroy(Sender: TObject);\r\nbegin\r\n  FreeAndNil(FList);\r\nend;\r\n\r\nfunction TfmSelectSource.GetSourceList: String;\r\nbegin\r\n  Result := FList.DelimitedText;\r\nend;\r\n\r\nprocedure TfmSelectSource.SetSourceList(const Value: String);\r\nbegin\r\n  FList.DelimitedText := Value;\r\n  UpdateView;\r\nend;\r\n\r\nprocedure TfmSelectSource.UpdateView;\r\nvar\r\n  I: Integer;\r\n  CurRow: Integer;\r\nbegin\r\n  CurRow := sgSource.Row;\r\n\r\n  sgSource.RowCount := 1;\r\n  sgSource.Cells[0, 0] := '';\r\n\r\n  sgSource.RowCount := FList.Count;\r\n\r\n  for I := 0 to FList.Count - 1 do\r\n    sgSource.Cells[0, I] := FList.Strings[I];\r\n\r\n  if CurRow < FList.Count then\r\n    sgSource.Row := CurRow;\r\nend;\r\n\r\nend.\r\n"
  },
  {
    "path": "uShareData.dfm",
    "content": "object dmShareData: TdmShareData\r\n  OldCreateOrder = False\r\n  Height = 452\r\n  Width = 623\r\n  object ilActionsSmall: TImageList\r\n    ColorDepth = cd32Bit\r\n    Left = 40\r\n    Top = 32\r\n    Bitmap = {\r\n      494C010109000D00040010001000FFFFFFFF2110FFFFFFFFFFFFFFFF424D3600\r\n      0000000000003600000028000000400000003000000001002000000000000030\r\n      0000000000000000000000000000000000000000001000000040000000400000\r\n      0040000000400000004000000040000000400000004000000040000000400000\r\n      0040000000400000001000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      00000000000000000000000000000000000000000040FFFFFFFFFFFFFFFFFFFF\r\n      FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFEBDF\r\n      D3FFB4865AFF2110006F00000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      00000000000000000000000000000000000000000040FFFFFFFFEEEEEEFFF1F1\r\n      F1FFF3F3F3FFF6F6F6FFF7F7F7FFF8F8F8FFF7F7F7FFF7F7F7FFEEE5DCFF9A56\r\n      1AFFB6804BFF884303F81D0D0036000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      00000000000000000000000000000000000000000040FFFFFFFFEFEFEFFFAAAA\r\n      AAFFABABABFFADADADFFF8F8F8FFAFAFAFFFAFAFAFFFF5EFE9FFA36329FFC999\r\n      6BFFEDD5C1FFD2A880FF874307ED160A00270000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      00000000000000000000000000000000000000000040FFFFFFFFEFEFEFFFF2F2\r\n      F2FFF5F5F5FFF7F7F7FFF9F9F9FFFAFAFAFFFEFEFEFFB47C49FFCB9B6FFFEACE\r\n      B5FFE9CCB2FFEACEB4FFD2A881FF793E06D30000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      00000000000000000000000000000000000000000040FFFFFFFFEAE8E7FFECEB\r\n      E9FFEDECEAFFF0EFEDFFF2F1EFFFF3F2F0FFFBFAFAFFC39469FFA15918FFA158\r\n      17FFE5C4A6FFAD6D33FF9D5514FF743B07C30000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      00000000000000000000000000000000000000000040FFFFFFFFE6E4E2FFA3A1\r\n      A0FFA4A3A1FFECEAE8FFB6B4B2FFB7B5B3FFB6B4B2FFECEAE8FFFFFFFFFFA65D\r\n      1DFFE4BF9EFFAB672BFF0A050110000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      00000000000000000000000000000000000000000040FFFFFFFFE3DFDCFFE5E1\r\n      DEFFE7E3E0FFE9E5E2FFECE8E5FFEEEAE7FFECE8E5FFE9E5E2FFFFFFFFFFAA61\r\n      20FFE4BB97FFAE692CFF0A050110000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      00000000000000000000000000000000000000000040FFFFFFFFF0F0F0FFF3F3\r\n      F3FFF6F6F6FFF9F9F9FFFBFBFBFFFDFDFDFFFBFBFBFFF9F9F9FFFFFFFFFFAE64\r\n      23FFE5BA93FFB26A2DFF0A060110000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      00000000000000000000000000000000000000000040FFFFFFFFF0F0F0FFABAB\r\n      ABFFACACACFFAEAEAEFFFBFBFBFFB1B1B1FFB0B0B0FFF8F8F8FFFFFFFFFFB366\r\n      26FFE7B289FFB46B2CFF0B060110000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      00000000000000000000000000000000000000000040FFFFFFFFEFEFEFFFF2F2\r\n      F2FFF5F5F5FFF7F7F7FFF9F9F9FFFAFAFAFFF9F9F9FFF7F7F7FFFFFFFFFFB76A\r\n      29FFEBBB93FFB86D2EFF0B060210000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      00000000000000000000000000000000000000000040FFFFFFFFEAE8E7FFEBEA\r\n      E8FFEDECEAFFEFEEECFFF0EFEDFFF0EFEDFFF0EFEDFFEFEEECFFFFFFFFFFBB6D\r\n      2CFFF2C4A2FFBB6F2FFF0B060210000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      00000000000000000000000000000000000000000040FFFFFFFFE4E2E0FFA1A0\r\n      9FFFA3A1A0FFEAE8E6FFA5A4A2FFA6A4A3FFA5A4A2FFEAE8E6FFFFFFFFFFBF71\r\n      2FFFF8CFB2FFC07332FF0C060210000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      00000000000000000000000000000000000000000040FFFFFFFFE2DEDBFFE3DF\r\n      DCFFE5E1DEFFE6E2DFFFE7E3E0FFE7E3E0FFE7E3E0FFE6E2DFFFF7F6F5FFD6A0\r\n      73FFBF6D29FF90521CD201000001000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      00000000000000000000000000000000000000000040FFFFFFFFFFFFFFFFFFFF\r\n      FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n      FFFFFFFFFFFF0000004000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000001000000040000000400000\r\n      0040000000400000004000000040000000400000004000000040000000400000\r\n      0040000000400000001000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      00000000000000B317FF00B317FF00B317FF00B317FF00B317FF00B317FF0000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000001000000040000000400000\r\n      0040000000400000004000000040000000400000004000000040000000400000\r\n      004000000040000000100000000000000000000000002D3082C76D7BDDFC0D11\r\n      61A2000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000010200000000000000000000000000000000000000000000\r\n      00000000000000B317FF00D011FF00BF1DFF00BF1DFF00D011FF00B317FF0000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      00000000000000000000000000000000000000000040FFFFFFFFFFFFFFFFFFFF\r\n      FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n      FFFFFFFFFFFF000000400000000000000000010326487983E6FF6980FFFF2339\r\n      D6FC00010B140000000000000000000000000000000000000000000000000000\r\n      00000203518B0102547A00000000000000000000000000000000000000000000\r\n      00000000000000B317FF00D321FF00C629FF00C629FF00D321FF00B317FF0000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      00000000000000000000000000000000000000000040FFFFFFFFEEEEEEFFF1F1\r\n      F1FFF3F3F3FFF6F6F6FFF7F7F7FFF8F8F8FFF7F7F7FFF6F6F6FFFBFBFBFFD6A0\r\n      73FFBF6D29FF8E501CD10100000100000000050538644C53DEFF2435EBFF091E\r\n      D8FE0101101D0000000000000000000000000000000000000000000000000000\r\n      1223060EB9F800012D4F00000000000000000000000000000000000000000000\r\n      00000000000000B317FF00D732FF00CC36FF00CC36FF00D732FF00B317FF0000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      00000000000000000000000000000000000000000040FFFFFFFFEFEFEFFFAAAA\r\n      AAFFABABABFFADADADFFF8F8F8FFAFAFAFFFAEAEAEFFF7F7F7FFFFFFFFFFBF71\r\n      2FFFF8CFB2FFC07332FF0C0602100000000000000B161014BBFB050DDBFF0311\r\n      D8FF02044A86000000000000000000000000000000000000000000000000050D\r\n      94D90710B0EE0000000000000000000000000000000000000000000000000000\r\n      00000000000000B317FF00DB43FF00D244FF00D244FF00DB43FF00B317FF0000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      00000000000000000000000000000000000000000040FFFFFFFFEFEFEFFFF2F2\r\n      F2FFF5F5F5FFF7F7F7FFF9F9F9FFFAFAFAFFF9F9F9FFF7F7F7FFFFFFFFFFBB6D\r\n      2CFFF2C4A2FFBB6F2FFF0B0602100000000000000000010161A60001CFFF0208\r\n      D8FF030ABDFB010113260000000000000000000000000000000003044E880B20\r\n      DFFF0103386500000000000000000000000000B317FF00B317FF00B317FF00B3\r\n      17FF00B317FF00B317FF00DE54FF00D852FF00D852FF00DE54FF00B317FF00B3\r\n      17FF00B317FF00B317FF00B317FF00B317FF1C24DAFF1C24DAFF1C24DAFF1C24\r\n      DAFF1C24DAFF1C24DAFF1C24DAFF1C24DAFF1C24DAFF1C24DAFF1C24DAFF1C24\r\n      DAFF1C24DAFF1C24DAFF1C24DAFF1C24DAFF00000040FFFFFFFFEAE8E7FFECEB\r\n      E9FFEDECEAFFF0EFEDFFF2F1EFFFF3F2F0FFF2F1EFFFF0EFEDFFFFFFFFFFB76A\r\n      29FFEBBB93FFB86D2EFF0B060210000000000000000000000102010294E30000\r\n      D0FF0005D5FF020691DF00000000000000000000000001022A570B27E5FF0613\r\n      9EDF0000000000000000000000000000000000B317FF00E265FF00E265FF00E2\r\n      65FF00E265FF00E265FF00E265FF00DD62FF00DD62FF00E265FF00E265FF00E2\r\n      65FF00E265FF00E265FF00E265FF00B317FF1C24DAFF595FE4FF595FE4FF595F\r\n      E4FF595FE4FF595FE4FF595FE4FF595FE4FF595FE4FF595FE4FF595FE4FF595F\r\n      E4FF595FE4FF595FE4FF595FE4FF1C24DAFF00000040FFFFFFFFE6E4E2FFA3A1\r\n      A0FFA4A3A1FFECEAE8FFB6B4B2FFB7B5B3FFB6B4B2FFECEAE8FFFFFFFFFFB366\r\n      26FFE7B289FFB46B2CFF0B06011000000000000000000000000000000C170001\r\n      A5EF0000D1FF0002CEFF010361A7000000000001294F071BD0FC0A24DEFE0100\r\n      152E0000000000000000000000000000000000B317FF00E675FF00E675FF00E6\r\n      75FF00E675FF00E675FF00E675FF00E372FF00E372FF00E675FF00E675FF00E6\r\n      75FF00E675FF00E675FF00E675FF00B317FF1C24DAFF757AE8FF757AE8FF757A\r\n      E8FF757AE8FF757AE8FF757AE8FF757AE8FF757AE8FF757AE8FF757AE8FF757A\r\n      E8FF757AE8FF757AE8FF757AE8FF1C24DAFF00000040FFFFFFFFE3DFDCFFE5E1\r\n      DEFFE7E3E0FFE9E5E2FFECE8E5FFEEEAE7FFECE8E5FFE9E5E2FFFFFFFFFFAE64\r\n      23FFE5BA93FFB26A2DFF0A060110000000000000000000000000000000000001\r\n      101D0102A2EC0000D2FF0000C4FF02026CB40209BFFB0413E1FF020452930000\r\n      00000000000000000000000000000000000000B317FF00E987FF00E987FF00E9\r\n      87FF00E987FF00E987FF00E987FF00E784FF00E784FF00E987FF00E987FF00E9\r\n      87FF00E987FF00E987FF00E987FF00B317FF1C24DAFF979BEEFF979BEEFF979B\r\n      EEFF979BEEFF979BEEFF979BEEFF979BEEFF979BEEFF979BEEFF979BEEFF979B\r\n      EEFF979BEEFF979BEEFF979BEEFF1C24DAFF00000040FFFFFFFFF0F0F0FFF3F3\r\n      F3FFF6F6F6FFF9F9F9FFFBFBFBFFFDFDFDFFFBFBFBFFF9F9F9FFFFFFFFFFAA61\r\n      20FFE4BB97FFAE692CFF0A050110000000000000000000000000000000000000\r\n      00000000050A030385D50000CCFF0000CCFF0002D1FF02047FCB000000000000\r\n      00000000000000000000000000000000000000B317FF00ED98FF00ED98FF00ED\r\n      98FF00ED98FF00ED98FF00ED98FF00EC96FF00EC96FF00ED98FF00ED98FF00ED\r\n      98FF00ED98FF00ED98FF00ED98FF00B317FF1C24DAFFB8BAF3FFB8BAF3FFB8BA\r\n      F3FFB8BAF3FFB8BAF3FFB8BAF3FFB8BAF3FFB8BAF3FFB8BAF3FFB8BAF3FFB8BA\r\n      F3FFB8BAF3FFB8BAF3FFB8BAF3FF1C24DAFF00000040FFFFFFFFF0F0F0FFABAB\r\n      ABFFACACACFFAEAEAEFFFBFBFBFFB1B1B1FFB0B0B0FFF8F8F8FFFFFFFFFFA65D\r\n      1DFFE4BF9EFFAB672BFF0A050110000000000000000000000000000000000000\r\n      00000000101D030788D00106CFFF0002D2FF0000C9FF02024D8A000000000000\r\n      00000000000000000000000000000000000000B317FF00B317FF00B317FF00B3\r\n      17FF00B317FF00B317FF00F1A9FF00F1A9FF00F1A9FF00F1A9FF00B317FF00B3\r\n      17FF00B317FF00B317FF00B317FF00B317FF1C24DAFF1C24DAFF1C24DAFF1C24\r\n      DAFF1C24DAFF1C24DAFF1C24DAFF1C24DAFF1C24DAFF1C24DAFF1C24DAFF1C24\r\n      DAFF1C24DAFF1C24DAFF1C24DAFF1C24DAFF00000040FFFFFFFFEFEFEFFFF2F2\r\n      F2FFF5F5F5FFF7F7F7FFF9F9F9FFFAFAFAFFFDFDFDFFC19064FFA15918FFA158\r\n      17FFE5C4A6FFAD6D33FF9D5514FF703B08BD0000000000000000000000000306\r\n      5C920919CCFA0616E4FF040FDEFF0106AEF30103BDFC0507CCFF030360A10000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      00000000000000B317FF00F4BAFF00F4BAFF00F4BAFF00F4BAFF00B317FF0000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      00000000000000000000000000000000000000000040FFFFFFFFEAE8E7FFEBEA\r\n      E8FFEDECEAFFEFEEECFFF0EFEDFFF0EFEDFFFBFBFBFFB88353FFCB9B6FFFEACE\r\n      B5FFE9CCB2FFEACEB4FFD2A881FF804006DD000000000C0C43713B45BEEC3C56\r\n      F7FF1C3BFAFF0C25F0FF040CABEB00000B140000223C0709ACED2224D4FF1515\r\n      86CA000003060000000000000000000000000000000000000000000000000000\r\n      00000000000000B317FF00F8CBFF00F8CBFF00F8CBFF00F8CBFF00B317FF0000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      00000000000000000000000000000000000000000040FFFFFFFFE4E2E0FFA1A0\r\n      9FFFA3A1A0FFEAE8E6FFA5A4A2FFA6A4A3FFADADABFFF3ECE6FFA36329FFC999\r\n      6BFFEDD5C1FFD2A880FF874307ED160A00276A6DB7E6A2ABF7FF8D9DFFFF697E\r\n      FFFF3954F9FF081198D6000008100000000000000000000001020A0A6EAE3E3F\r\n      D0FE3D3EB8F407073B6500000000000000000000000000000000000000000000\r\n      00000000000000B317FF00FBDBFF00FBDBFF00FBDBFF00FBDBFF00B317FF0000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      00000000000000000000000000000000000000000040FFFFFFFFE2DEDBFFE3DF\r\n      DCFFE5E1DEFFE6E2DFFFE7E3E0FFE7E3E0FFE7E3E0FFE8E5E2FFEDE2D9FF9A56\r\n      1AFFB6804BFF884303F81D0D0036000000005F61A5D8B6BBF5FFA3ACFBFF636D\r\n      DBFA0E1161980000000000000000000000000000000000000000000000000101\r\n      1F382A2A95D45A5BC7FA353599DB01022E540000000000000000000000000000\r\n      00000000000000B317FF00FFECFF00FFECFF00FFECFF00FFECFF00B317FF0000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      00000000000000000000000000000000000000000040FFFFFFFFFFFFFFFFFFFF\r\n      FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFEADE\r\n      D2FFB38559FF210F006E000000000000000004041525545596C37A7DC2DF1415\r\n      527F000000000000000000000000000000000000000000000000000000000000\r\n      000000000A12141561984041A3DE070750840000000000000000000000000000\r\n      00000000000000B317FF00B317FF00B317FF00B317FF00B317FF00B317FF0000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000001000000040000000400000\r\n      0040000000400000004000000040000000400000004000000040000000400000\r\n      0040000000400000001000000000000000000000000000000000CACACAFFC8C8\r\n      C8FFC8C8C8FFC8C8C8FFC8C8C8FFC8C8C8FFC8C8C8FFC8C8C8FFC8C8C8FFC8C8\r\n      C8FFC8C8C8FFCBCBCBFF00000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000060000\r\n      0010000000190000001A0000001A0000001A0000001A0000001A0000001A0000\r\n      001A0000001A00000019000000150000001000000000CACACAFFEDEDEDFFF8F8\r\n      F8FFFCFCFCFFFCFCFCFFFCFCFCFFFCFCFCFFFCFCFCFFFCFCFCFFFCFCFCFFFCFC\r\n      FCFFF8F8F8FFEBEBEBFFCBCBCBFF00000000000000000000000000000000918C\r\n      85FF57602FFF9B9690FF00000000000000000000000000000000000000000000\r\n      00000000000000000000000000000000000000000000000000007D86B1FF0020\r\n      CCFFBEC0CAFF000000000000000000000000000000000000000000000000BEC0\r\n      CAFF0020CCFF7D86B1FF000000000000000000000000000000000000000B0000\r\n      0020020100330E07003E150A0043120801414A2501A67A3E02CC7A3E02CC7A3E\r\n      02CC7A3E02CC7A3E02CC492401A30000001F00000000C8C8C8FFF9F9F9FFFCFC\r\n      FCFFFCFCFCFFFCFCFCFFFCFCFCFFFCFCFCFFFCFCFCFFFCFCFCFFFCFCFCFFFCFC\r\n      FCFFFCFCFCFFF8F8F8FFC8C8C8FF000000000000000000000000000000005C6A\r\n      40FF3CC357FF4C7738FFACA8A4FF000000000000000000000000000000000000\r\n      000000000000000000000000000000000000000000007E87B1FF0123CEFF3153\r\n      FFFF0123CEFFBEC0CBFF00000000000000000000000000000000BEC0CBFF0123\r\n      CEFF3153FFFF0123CEFF7E87B1FF000000000000000000000000000000000B05\r\n      00192B1702433C27074E4B3408543E2E073F7D4003CCFDBC27FFFCB81CFFFCB8\r\n      1CFFFDC032FF7D4003CC381C025C0000000000000000C8C8C8FFFCFCFCFFFCFC\r\n      FCFF154057FF285E88FF4989BDFF6CA7CBFFE0E9F1FFFBFBFBFFFBFBFBFFFBFB\r\n      FBFFFBFBFBFFFCFCFCFFC8C8C8FF0000000000000000000000009C9B93FF4799\r\n      42FF55E991FF49D271FF4D7030FFBCBCB9FF0000000000000000000000000000\r\n      000000000000000000000000000000000000000000000527D2FF88AAFFFF3658\r\n      FFFF3658FFFF0527D2FFBEC0CBFF0000000000000000BEC0CBFF0527D2FF3658\r\n      FFFF3658FFFF88AAFFFF0527D2FF000000000000000000000000160B01224024\r\n      055F6A50156D694A0B6D694B0D6C3E2D0A40824607CCF8B629FFF6AC13FFF8BA\r\n      34FF824607CC542C0585000000000000000000000000C8C8C8FFFCFCFCFFFCFC\r\n      FCFF2B6484FF93C7F9FF90C9F9FF3E84C9FF2368ADFFD4E2EEFFFAFAFAFFFAFA\r\n      FAFFFAFAFAFFFCFCFCFFC8C8C8FF000000000000000000000000647752FF58CF\r\n      77FF79E8AAFF6AE8A2FF4ECE71FF4D7032FFCBCCCAFF00000000000000000000\r\n      00000000000000000000000000000000000000000000BEC1CBFF0A2CD5FF88AA\r\n      FFFF3C5EFFFF3C5EFFFF0A2CD5FFBEC1CBFFBEC1CBFF0A2CD5FF3C5EFFFF3C5E\r\n      FFFF88AAFFFF0A2CD5FFBEC1CBFF00000000000000000B060110512E08788968\r\n      25908761189082601F915A380F7822120233864A0BCCF1B338FFF3B942FFEEA8\r\n      23FFF1B338FF82480BBF1109021A0000000000000000C8C8C8FFFCFCFCFFFCFC\r\n      FCFF4088A9FFE0F2FFFF5199D8FF1777BDFF4697C4FF458DC7FFD8E6F3FFF8F8\r\n      F8FFF8F8F8FFFCFCFCFFC8C8C8FF0000000000000000BABDB7FF3F9038FF88EE\r\n      B4FF95F3C4FF89EBB7FF76ECAEFF4DCC6FFF4D7032FFDBDBDAFF000000000000\r\n      0000000000000000000000000000000000000000000000000000BFC1CBFF1032\r\n      DAFF88AAFFFF4466FFFF4466FFFF1032DAFF1032DAFF4466FFFF4466FFFF88AA\r\n      FFFF1032DAFFBFC1CBFF000000000000000000000000351D064D845A21A6A377\r\n      2AB49F752FB25C340B8821120332000000008C4F0FCCF0BD5BFF8C4F0FCCECB1\r\n      47FFE8A83AFFB57E2EE34A29086C0000000000000000C8C8C8FFFCFCFCFFFCFC\r\n      FCFFA4C2D7FF77B5D5FF8FB6D1FF52C9E4FF58DFF5FF75D0EDFF4E9CDDFFDFEB\r\n      F5FFF8F8F8FFFCFCFCFFC8C8C8FF0000000000000000738969FF69CE81FFA0FA\r\n      D1FF59CD73FF75E6A4FF94F3C8FF79F2B7FF4CC86AFF51753DFF000000000000\r\n      000000000000000000000000000000000000000000000000000000000000BFC1\r\n      CCFF1638DEFF88AAFFFF4D6FFFFF4D6FFFFF4D6FFFFF4D6FFFFF88AAFFFF1638\r\n      DEFFBFC1CCFF00000000000000000000000000000000643A0E8CB58841CFBF8D\r\n      40D6936225BA351E064A0000000000000000925613CC925613CC6A3D0F94AD74\r\n      2CDCE3A84DFFD7A14DF5764610A60000000000000000C8C8C8FFFCFCFCFFFCFC\r\n      FCFFFCFCFCFFB1D5E5FF73B9D7FFC1F6FDFF60DFF7FF5AE2F8FF76D3F0FF4697\r\n      DCFFDEE9F2FFFCFCFCFFC8C8C8FF00000000D8D9D7FF3D8D33FF97FCC9FF5AC4\r\n      6FFF396E21FF3A8F31FF69E397FF90F9CCFF79F7C0FF48C261FF5D7D4DFF0000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000C0C2CCFF1D3FE3FF6F93FFFF5779FFFF5779FFFF6F93FFFF1D3FE3FFC0C2\r\n      CCFF00000000000000000000000000000000000000008F5616C1DAAA60F1D8A6\r\n      5BF18F5616C10000000000000000000000007043119943280A5C00000000985B\r\n      18CCE5B060FFE7B465FF985B18CC0000000000000000C8C8C8FFFCFCFCFFFCFC\r\n      FCFFFCFCFCFFFCFCFCFFAED4E5FF74CBE7FFC7F7FDFF5BDCF5FF57E1F7FF78D4\r\n      F1FF4899DDFFD4E5F5FFC8C8C8FF00000000859980FF57D077FF5CD57CFF5281\r\n      46FF00000000BBC0BAFF3B822AFF4ECB6AFF80F9C5FF77FECAFF41BF5AFF6485\r\n      57FF000000000000000000000000000000000000000000000000000000000000\r\n      0000C0C2CCFF2345E8FF6084FFFF6084FFFF6084FFFF6084FFFF2345E8FFC0C2\r\n      CCFF00000000000000000000000000000000000000009E621ECCE9B86EFFE6B4\r\n      6BFF9E621ECC00000000472B0E5C76491699000000000000000000000000955B\r\n      1BC1D9AA65F1DCAE68F1955B1BC10000000000000000C8C8C8FFFCFCFCFFFCFC\r\n      FCFFFCFCFCFFFCFCFCFFFCFCFCFFBCE5F2FF76D3EEFFC7F7FDFF5CDCF5FF58E2\r\n      F7FF77D6F2FF4EA1E2FFA5AAAFFF000000003A9234FF41D05FFF4D8744FF0000\r\n      00000000000000000000D6D8D6FF5F8754FF37B343FF6BF2B2FF6FFFD0FF3CBA\r\n      50FF789370FF000000000000000000000000000000000000000000000000C0C3\r\n      CCFF2A4CEDFF6A8EFFFF6A8EFFFF88AAFFFF88AAFFFF6A8EFFFF6A8EFFFF2A4C\r\n      EDFFC0C3CCFF0000000000000000000000000000000084551AA6DEAF67F5E8B5\r\n      6FFFBC863DDC774B1794A46822CCA46822CC00000000000000003C260B4A9F71\r\n      33BAC2985DD6BC9357CF7147168C0000000000000000C8C8C8FFFCFCFCFFFBFB\r\n      FBFFFCFCFCFFFCFCFCFFFBFBFBFFF8F8F8FFB9E3F0FF7AD4EEFFC3F6FDFF69DD\r\n      F6FF6ACAEDFF60A2D7FF5C94C4FFD8DADBFF27911FFF438C3AFF000000000000\r\n      00000000000000000000000000000000000097A794FF289720FF56E895FF66FF\r\n      D2FF35B746FF839C80FF00000000000000000000000000000000C1C3CDFF3052\r\n      F1FF7397FFFF7397FFFF88AAFFFF3052F1FF3052F1FF88AAFFFF7397FFFF7397\r\n      FFFF3052F1FFC1C3CDFF0000000000000000000000005A3A136CCB974EE3EDBC\r\n      75FFF1C67DFFAA6E26CCF7D38AFFAA6E26CC00000000291B093271491A88A686\r\n      51B2A78452B4936E39A640290D4D0000000000000000C8C8C8FFFCFCFCFFF9F9\r\n      F9FFF9F9F9FFF9F9F9FFF7F7F7FFF6F6F6FFF2F2F2FFA7D9E8FF80D6EEFFB1E3\r\n      F9FF8ABFE7FFADD3F6FFC3E0FCFF639ACBFFDDDFDDFF00000000000000000000\r\n      00000000000000000000000000000000000000000000C8CDC8FF378B2FFF3FD4\r\n      6BFF62FCBDFF31B643FF99AB98FF0000000000000000C1C3CDFF3658F6FF7B9F\r\n      FFFF7B9FFFFF88AAFFFF3658F6FFC1C3CDFFC1C3CDFF3658F6FF88AAFFFF7B9F\r\n      FFFF7B9FFFFF3658F6FFC1C3CDFF0000000000000000160F041AA66F2ABFF7CE\r\n      84FFF2C279FFF9D48AFFF7CE84FFAF732ACC2C1D09336A4E25788A714491896F\r\n      46908C774D9068461A780E0903100000000000000000C8C8C8FFFCFCFCFFF7F7\r\n      F7FFF9F9F9FFF7F7F7FFF7F7F7FFF3F3F3FFF0F0F0FFEAEAEAFFAEE4F3FF74BD\r\n      E7FFB3D2F0FFE5F3FFFFABD2EFFF4F87BAFF0000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000006694\r\n      62FF2CBD44FF58F5A3FF28AE37FFB0BCB0FF000000003B5DF9FF88AAFFFF83A5\r\n      FFFF88AAFFFF3B5DF9FFC1C4CDFF0000000000000000C1C4CDFF3B5DF9FF88AA\r\n      FFFF83A5FFFF88AAFFFF3B5DF9FF000000000000000000000000744E1E85B478\r\n      2ECCFDD88EFFF9CC82FFFCD58AFFB4782ECC3F3522406958396C6A58386D6C5B\r\n      3D6D543B185F1E140722000000000000000000000000C8C8C8FFF7F7F7FFF4F4\r\n      F4FFF5F5F5FFF5F5F5FFF5F5F5FFF1F1F1FFEFEFEFFFE9E9E9FFFCFCFCFFABD5\r\n      E4FF55A4D8FF84B0DBFF439CD0FFA5B4BCFF0000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      00009EB09EFF2DA137FF41DD66FF26A429FF000000008E97BDFF3F61FDFF88AA\r\n      FFFF3F61FDFFC2C4CDFF00000000000000000000000000000000C2C4CDFF3F61\r\n      FDFF88AAFFFF3F61FDFF8E97BDFF00000000000000005338155CB77B30CCFFE0\r\n      94FFFED98DFFFED98DFFFFDD91FFB77B30CC3F36233F5242285449381C4E3C2A\r\n      1143150F051900000000000000000000000000000000CBCBCBFFE8E8E8FFF7F7\r\n      F7FFFCFCFCFFFCFCFCFFFCFCFCFFFCFCFCFFFCFCFCFFFCFCFCFFF8F8F8FF9C9C\r\n      9CFFDEDEDEFF0000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      000000000000D5D8D5FF3E9841FF1A9F1BFF00000000000000008F97BEFF4264\r\n      FFFFC2C4CEFF000000000000000000000000000000000000000000000000C2C4\r\n      CEFF4264FFFF8F97BEFF0000000000000000000000008B5F2599BA7E33CCBA7E\r\n      33CCBA7E33CCBA7E33CCBA7E33CC8B5F25991D14082021170825170F05190504\r\n      0106000000000000000000000000000000000000000000000000CBCBCBFFC8C8\r\n      C8FFC8C8C8FFC8C8C8FFC8C8C8FFC8C8C8FFC8C8C8FFC8C8C8FFC8C8C8FFDEDE\r\n      DEFF000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      000000000000000000000000000000000000424D3E000000000000003E000000\r\n      2800000040000000300000000100010000000000800100000000000000000000\r\n      000000000000000000000000FFFFFF00FFFF0000000000008003000000000000\r\n      8001000000000000800000000000000080000000000000008000000000000000\r\n      8001000000000000800100000000000080010000000000008001000000000000\r\n      8001000000000000800100000000000080010000000000008001000000000000\r\n      8007000000000000FFFF000000000000FFFFF81FFFFFFFFF8FFBF81FFFFF8007\r\n      07F3F81FFFFF800107E3F81FFFFF800107E7F81FFFFF800183C7000000008001\r\n      838F000000008001C10F000000008001E01F000000008001F03F000000008001\r\n      F03F000000008000E01FF81FFFFF80008007F81FFFFF80000183F81FFFFF8001\r\n      07E0F81FFFFF80030FF0F81FFFFFFFFF000000000000C000000000000000C000\r\n      000000000000E001000000000000C00300000000000080010000000000008101\r\n      0000000000008301000000000000872100000000000084E100000000000080C1\r\n      00000000000080810000000000008001000000000000C0030000000000008007\r\n      000000000000800F000000000000FFFF00000000000000000000000000000000\r\n      000000000000}\r\n  end\r\n  object imlMainSmall: TJvImageList\r\n    ColorDepth = cd32Bit\r\n    Mode = imClassic\r\n    PixelFormat = pf32bit\r\n    TransparentMode = tmAuto\r\n    Items = <>\r\n    Left = 224\r\n    Top = 32\r\n    Bitmap = {\r\n      494C01011A001D00040010001000FFFFFFFF2110FFFFFFFFFFFFFFFF424D3600\r\n      0000000000003600000028000000400000007000000001002000000000000070\r\n      0000000000000000000000000000000000000000001000000040000000400000\r\n      0040000000400000004000000040000000400000004000000040000000400000\r\n      0040000000400000001000000000000000000000001000000040000000400000\r\n      0040000000400000004000000040000000400000004000000040000000400000\r\n      0040000000400000001000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      00000000000000000000000000000000000000000040FFFFFFFFFFFFFFFFFFFF\r\n      FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFEBDF\r\n      D3FFB4865AFF2110006F000000000000000000000040FFFFFFFFFFFFFFFFFFFF\r\n      FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n      FFFFFFFFFFFF0000004000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      00000000000000000000000000000000000000000040FFFFFFFFEEEEEEFFF1F1\r\n      F1FFF3F3F3FFF6F6F6FFF7F7F7FFF8F8F8FFF7F7F7FFF7F7F7FFEEE5DCFF9A56\r\n      1AFFB6804BFF884303F81D0D00360000000000000040FFFFFFFFEEEEEEFFF1F1\r\n      F1FFF3F3F3FFF6F6F6FFF7F7F7FFF8F8F8FFF7F7F7FFF6F6F6FFFBFBFBFFD6A0\r\n      73FFBF6D29FF8E501CD101000001000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      00000000000000000000000000000000000000000040FFFFFFFFEFEFEFFFAAAA\r\n      AAFFABABABFFADADADFFF8F8F8FFAFAFAFFFAFAFAFFFF5EFE9FFA36329FFC999\r\n      6BFFEDD5C1FFD2A880FF874307ED160A002700000040FFFFFFFFEFEFEFFFAAAA\r\n      AAFFABABABFFADADADFFF8F8F8FFAFAFAFFFAEAEAEFFF7F7F7FFFFFFFFFFBF71\r\n      2FFFF8CFB2FFC07332FF0C060210000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      00000000000000000000000000000000000000000040FFFFFFFFEFEFEFFFF2F2\r\n      F2FFF5F5F5FFF7F7F7FFF9F9F9FFFAFAFAFFFEFEFEFFB47C49FFCB9B6FFFEACE\r\n      B5FFE9CCB2FFEACEB4FFD2A881FF793E06D300000040FFFFFFFFEFEFEFFFF2F2\r\n      F2FFF5F5F5FFF7F7F7FFF9F9F9FFFAFAFAFFF9F9F9FFF7F7F7FFFFFFFFFFBB6D\r\n      2CFFF2C4A2FFBB6F2FFF0B060210000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      00000000000000000000000000000000000000000040FFFFFFFFEAE8E7FFECEB\r\n      E9FFEDECEAFFF0EFEDFFF2F1EFFFF3F2F0FFFBFAFAFFC39469FFA15918FFA158\r\n      17FFE5C4A6FFAD6D33FF9D5514FF743B07C300000040FFFFFFFFEAE8E7FFECEB\r\n      E9FFEDECEAFFF0EFEDFFF2F1EFFFF3F2F0FFF2F1EFFFF0EFEDFFFFFFFFFFB76A\r\n      29FFEBBB93FFB86D2EFF0B060210000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      00000000000000000000000000000000000000000040FFFFFFFFE6E4E2FFA3A1\r\n      A0FFA4A3A1FFECEAE8FFB6B4B2FFB7B5B3FFB6B4B2FFECEAE8FFFFFFFFFFA65D\r\n      1DFFE4BF9EFFAB672BFF0A0501100000000000000040FFFFFFFFE6E4E2FFA3A1\r\n      A0FFA4A3A1FFECEAE8FFB6B4B2FFB7B5B3FFB6B4B2FFECEAE8FFFFFFFFFFB366\r\n      26FFE7B289FFB46B2CFF0B060110000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      00000000000000000000000000000000000000000040FFFFFFFFE3DFDCFFE5E1\r\n      DEFFE7E3E0FFE9E5E2FFECE8E5FFEEEAE7FFECE8E5FFE9E5E2FFFFFFFFFFAA61\r\n      20FFE4BB97FFAE692CFF0A0501100000000000000040FFFFFFFFE3DFDCFFE5E1\r\n      DEFFE7E3E0FFE9E5E2FFECE8E5FFEEEAE7FFECE8E5FFE9E5E2FFFFFFFFFFAE64\r\n      23FFE5BA93FFB26A2DFF0A060110000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      00000000000000000000000000000000000000000040FFFFFFFFF0F0F0FFF3F3\r\n      F3FFF6F6F6FFF9F9F9FFFBFBFBFFFDFDFDFFFBFBFBFFF9F9F9FFFFFFFFFFAE64\r\n      23FFE5BA93FFB26A2DFF0A0601100000000000000040FFFFFFFFF0F0F0FFF3F3\r\n      F3FFF6F6F6FFF9F9F9FFFBFBFBFFFDFDFDFFFBFBFBFFF9F9F9FFFFFFFFFFAA61\r\n      20FFE4BB97FFAE692CFF0A050110000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      00000000000000000000000000000000000000000040FFFFFFFFF0F0F0FFABAB\r\n      ABFFACACACFFAEAEAEFFFBFBFBFFB1B1B1FFB0B0B0FFF8F8F8FFFFFFFFFFB366\r\n      26FFE7B289FFB46B2CFF0B0601100000000000000040FFFFFFFFF0F0F0FFABAB\r\n      ABFFACACACFFAEAEAEFFFBFBFBFFB1B1B1FFB0B0B0FFF8F8F8FFFFFFFFFFA65D\r\n      1DFFE4BF9EFFAB672BFF0A050110000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      00000000000000000000000000000000000000000040FFFFFFFFEFEFEFFFF2F2\r\n      F2FFF5F5F5FFF7F7F7FFF9F9F9FFFAFAFAFFF9F9F9FFF7F7F7FFFFFFFFFFB76A\r\n      29FFEBBB93FFB86D2EFF0B0602100000000000000040FFFFFFFFEFEFEFFFF2F2\r\n      F2FFF5F5F5FFF7F7F7FFF9F9F9FFFAFAFAFFFDFDFDFFC19064FFA15918FFA158\r\n      17FFE5C4A6FFAD6D33FF9D5514FF703B08BD0000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      00000000000000000000000000000000000000000040FFFFFFFFEAE8E7FFEBEA\r\n      E8FFEDECEAFFEFEEECFFF0EFEDFFF0EFEDFFF0EFEDFFEFEEECFFFFFFFFFFBB6D\r\n      2CFFF2C4A2FFBB6F2FFF0B0602100000000000000040FFFFFFFFEAE8E7FFEBEA\r\n      E8FFEDECEAFFEFEEECFFF0EFEDFFF0EFEDFFFBFBFBFFB88353FFCB9B6FFFEACE\r\n      B5FFE9CCB2FFEACEB4FFD2A881FF804006DD0000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      00000000000000000000000000000000000000000040FFFFFFFFE4E2E0FFA1A0\r\n      9FFFA3A1A0FFEAE8E6FFA5A4A2FFA6A4A3FFA5A4A2FFEAE8E6FFFFFFFFFFBF71\r\n      2FFFF8CFB2FFC07332FF0C0602100000000000000040FFFFFFFFE4E2E0FFA1A0\r\n      9FFFA3A1A0FFEAE8E6FFA5A4A2FFA6A4A3FFADADABFFF3ECE6FFA36329FFC999\r\n      6BFFEDD5C1FFD2A880FF874307ED160A00270000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      00000000000000000000000000000000000000000040FFFFFFFFE2DEDBFFE3DF\r\n      DCFFE5E1DEFFE6E2DFFFE7E3E0FFE7E3E0FFE7E3E0FFE6E2DFFFF7F6F5FFD6A0\r\n      73FFBF6D29FF90521CD2010000010000000000000040FFFFFFFFE2DEDBFFE3DF\r\n      DCFFE5E1DEFFE6E2DFFFE7E3E0FFE7E3E0FFE7E3E0FFE8E5E2FFEDE2D9FF9A56\r\n      1AFFB6804BFF884303F81D0D0036000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      00000000000000000000000000000000000000000040FFFFFFFFFFFFFFFFFFFF\r\n      FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n      FFFFFFFFFFFF00000040000000000000000000000040FFFFFFFFFFFFFFFFFFFF\r\n      FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFEADE\r\n      D2FFB38559FF210F006E00000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000001000000040000000400000\r\n      0040000000400000004000000040000000400000004000000040000000400000\r\n      0040000000400000001000000000000000000000001000000040000000400000\r\n      0040000000400000004000000040000000400000004000000040000000400000\r\n      0040000000400000001000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      000000000000000000000000000000000000171717243A3A3A5B4A4A4A735353\r\n      53825A5A5A8E5B5C5C906363639C6365659E6365659E6363639C5B5C5C905A5A\r\n      5A8E535353824A4A4A743A3A3A5B171717240000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000909090F1C1C1C2D2F3235564963\r\n      82E44D6989EE4F6C8CF34F6C8BF34F6C8BF34F6B8BF34F6B8BF34F6B8BF34D69\r\n      88EE486484E8333A406A1C1C1C2D0909090F0000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      00000000000000000000000000000000000000000000000000000B14214F92A6\r\n      BAFDDCDDDEFEDCDCDDFEDADADBFED8D8D9FED5D6D6FED3D4D4FED1D2D2FECECE\r\n      CFFE9DABB9FD11273D7300000001000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      00000000000000000000000000000000000000000000000000000814214FA0B1\r\n      C3FDE2E3E3FFE2E2E2FFDFDFDFFFDDDDDDFFDBDBDBFFD9D9D9FFD7D7D7FFD4D4\r\n      D4FFACB7C2FD11283F7300000001000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000003537\r\n      37DE030303530000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      00000000000000000000000000000000000000000000000000000915214FA2B4\r\n      C6FDE2E3E3FFEAEAEAFFDFDFDFFFD6D6D6FFD3D3D3FFD2D2D2FFD0D0D0FFD5D5\r\n      D5FFAEBAC5FD1129417300000001000000000000000000000000000000000000\r\n      00000000000000000000000000000000000000000000000000000202020E0B0B\r\n      0BFF303232CF0000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      000000000000000000001919197A2E2E2EDC0606061D00000000000000000000\r\n      00000000000000000003000000000000000000000000000000000916214FA3B6\r\n      C8FDE4E5E5FFE5E5E5FFE2E2E2FFE2E2E2FFE0E0E0FFDEDEDEFFDCDCDCFFDADA\r\n      DAFFB1BEC8FD112C437300000001000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      00000000000000000000000000000505051E0000000000000000000000000000\r\n      0000343434F6363636FF303030E2000000000A0A0A330A0A0A330A0A0A330A0A\r\n      0A330808082811111155363636FF363636FF363636FF000000000A0A0A330A0A\r\n      0A330A0A0A33363636FF1717176D0000000000000000000000000917224FA4B8\r\n      CAFDE6E6E7FFE0E0E1FFE3E3E5FFE4E4E4FFE2E2E2FFE0E0E0FFDEDEDEFFDDDD\r\n      DDFFB3C0CBFD112D457300000001000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000012121141191818620000\r\n      0000000000000000000000000000000000000A0A0A330A0A0A330A0A0A330A0A\r\n      0A330A0A0A330A0A0A330A0A0A3315151566363636FF04040413000000002E2E\r\n      2ED8363636FF363636FF363636FF1F1F1F96363636FF363636FF363636FF3636\r\n      36FF282828BD1F1F1F94363636FF363636FF363636FF00000000363636FF3636\r\n      36FF363636FF363636FF363636FD0202020800000000000000000917244FA5BB\r\n      CDFDE6E6E7FF9898F0FF9F9FEBFFD9D9DAFFD7D7D7FFD6D6D6FFD5D5D5FFDCDC\r\n      DCFFB4C3CEFD112E467300000001000000000000000000000000000000000000\r\n      000000000000000000000101010434323295514F4EFF494746FF262525940000\r\n      000000000000000000000000000000000000363636FF363636FF363636FF3636\r\n      36FF363636FF363636FF363636FF363636FF363636FF303030E2000000003636\r\n      36FF363636FF363636FF363636FF2C2C2CD00000000000000000000000001313\r\n      135B363636FF00000000363636FF363636FF2E2E2ED904040412363636FF0000\r\n      000000000000242424A5000000000000000000000000000000000918244FA5BC\r\n      CFFDE9E9EAFFE6E6E9FF9797EEFFD4D4E9FFE6E6E6FFE4E4E4FFE3E3E3FFE1E1\r\n      E1FFB6C5D1FD1230487300000001000000000000000000000000000000000000\r\n      000000000000000000000000000023222165524F4EFF494746FF2E2D2CB40000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      00000000000000000000000000000E0E0E401212125800000000000000001111\r\n      1155363636FF363636FF363636FF070707200000000000000000000000000000\r\n      0000363636FF313131E5000000010000000007070723363636FF262626B10000\r\n      00000000000000000000000000000000000000000000000000000919254FA6BE\r\n      D1FDE9E9EAFFD3D3E9FFD9D9E9FFDCDCDEFFDBDBDBFFDADADAFFD9D9D9FFE1E1\r\n      E1FFB8C8D4FD12324A7300000001000000000000000000000000000000000000\r\n      00000000000000000000000000004E4C4BDF524F4EFF494746FD343332CC0000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      00000606061D1A1A1A770202020D000000000000000000000000000000000000\r\n      000000000000323232ED363636FF363636FF363636FF232323A0000000000000\r\n      0000000000000000000000000000000000000000000000000000091A264FA6C0\r\n      D2FDE9E9EAFFA5A5EBFF7979F0FFE0E0E7FFE5E5E5FFE4E4E4FFE3E3E3FFE4E4\r\n      E4FFB9CAD6FD12354C7300000001000000000000000000000000211F1F2A1212\r\n      111F0B0B0B1A22212153575554E15B5857FF52504FFE02020209222121870000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000091B284FA6C1\r\n      D3FDE9EBECFFE9EAECFFCACCEDFFDCDDEBFFE8E9EAFFE7E8E9FFE6E8E8FFE5E6\r\n      E7FFBBCCD8FD12354E73000000010000000000000000000000002523232F3735\r\n      345C3B3A39854B4948B4595655E5595655F90505051100000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      00000000000000000000000000000000000000000000000000000A1C294E81AE\r\n      CAFCC5D7E1FE62AEDFFE61AEDFFE61AEDFFE61ADDFFE61ADDFFE61ADDEFEAFCB\r\n      DEFE91B7CEFC14374F72000000000000000000000000000000000A0A0A0E2927\r\n      2744343332753A38388C1B1A1A47000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000020608142050\r\n      6E98225878A2028CDDFC018EDFFD0F83C7E0127DBCD4018EDFFD018DDEFD1E63\r\n      8BB42154739E0510172500000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      000100010102084A6A740C6A96A30B4966720A31454D0974A4B20B587C880004\r\n      070B000000010000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      00000000000000000000000204070B83AEB40B8FBFC6010C1116000000010000\r\n      0000000000000000000000000000000000000000002300000033000000330000\r\n      0033000000330000003300000033000000330000003300000033000000330000\r\n      0033000000230000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000003300000033000000000000\r\n      000000000000000000000000000000000000000000000000000004040412322E\r\n      2B8F38332FA338332FA3383331A3383331A3383331A3373331A40808085E0000\r\n      0018000000000000000000000000000000000000000000000000000000000000\r\n      0033000000330000000E000000000000000000000000000000000000001E0000\r\n      003300000033000000330000001E00000000805D1EC0B68123FFB57E1FFFB47E\r\n      1EFFB57E1EFFB67E1FFFBF8223FFD58527FF008C4CFF40883EFFC88223FFBD83\r\n      25FF865C1EBF0000000000000000000000000000003000000033000000330000\r\n      003300000033000000330000003300000033008C4CFF00813BFF000000330000\r\n      003300000033000000330000003000000000000000000303020997918DF7CCCC\r\n      CCFFCDCDCDFFD5D5D5FFDBDBDBFFE3E3E3FFE9E9E9FFECECECFF9C9793FD9895\r\n      93EB03030146000000040000000000000000000000000000000000000000B583\r\n      4AFFB48247FF3123136C0000001A00000000000000000000001E005E39AC009E\r\n      5DFF009D5CFF009E5DFF005E39AC0000001EB68123FFFFFFFFFFFFFFFFFFFFFF\r\n      FFFFFFFFFFFFFFFFFFFFFFFFFFFF008340FF0BC690FF008340FFFFFFFFFFFFFF\r\n      FFFFD58323FF000000280000000600000000AD7B17F2B67D0DFFB47A08FFB479\r\n      06FFB67A08FFBF7D0CFFD5800EFF008949FF12C892FF00894AFFDD8211FFD184\r\n      16FFCD8517FFC98517FFBB7C18F2000000000000000016141232C5C4C3FFCCCC\r\n      CCFFCFCFCFFFD7D6D4FFD6C3B5FFEBEAE9FFF5F5F5FFF7F7F7FF979594FFF6F6\r\n      F6FFBBB9B7FA0D0B0B620000000200000000000000000000000000000000694A\r\n      2998FFFBE8FFD4B48CFF5C40229A0000001C00000000005F38AB00A669FF00BA\r\n      86FF76DFC4FF00BA86FF00A669FF005E39ACB57E1FFFFFFFFFFFE6D6AEFFE7D7\r\n      B0FFEED9B4FFFFDEBBFF007C35FF31CA99FF00DCA1FF00B97AFF009653FF0082\r\n      3DFF008745FF006E3BD50012094D00000007B67D0DFFFFFFFFFFFFFFFFFFFFFF\r\n      FFFFFFFFFFFFFFFFFFFF00823FFF34CD9EFF00DCA2FF00BC81FF00813BFF0081\r\n      3BFF00813BFF00813BFFB0851CFF000000330000000016141232CAC9C9FFBC9E\r\n      8BFFC2886CFFBC7255FFC6876EFFC99076FFC8987DFFE1CFC3FFA4A2A0FFFEFE\r\n      FEFFF7F7F7FFB3B1B0F90303034C0000000100000000000000000000000E1A12\r\n      094AD2B087FFFFFFFFFFD2AF85FF684626A500000033009F5DFF00C08CFF00BB\r\n      82FFFFFFFFFF00BB82FF00C08CFF009E5DFFB47D1EFFFFFFFFFFE6D6AFFFE9D8\r\n      B3FFF3DCB8FF007A33FF4DD2ACFF00D39CFF00D29CFF00D5A0FF00D7A2FF00D9\r\n      A5FF00DBA8FF00C28CFF00904FFF0012093FB47A08FFFFFFFFFFFFFFFFFFFFFF\r\n      FFFFFFFFFFFF00782DFF4ED2ADFF00D49DFF00D29CFF00D5A1FF00D9A5FF00DA\r\n      A7FF00DBA8FF00C08BFF00813BFFFFFFFFFF0000000017141234B6876CFFDCB6\r\n      A8FFDDB7A9FFDBB1A4FFD3A08FFFD8AD9EFFE4C5BBFFDDB9ABFFC49B85FFDAD7\r\n      D4FFFFFFFFFFF7F7F7FF928F8DEC00000020000000000000001A312314699C6C\r\n      3BE1BC894FFFFFFFEFFFFFFFF1FFD2A575FFCB7D43FF009B58FF72E5CCFFFFFF\r\n      FFFFFFFFFFFFFFFFFFFF76E5CCFF009C5BFFB47D1DFFFFFFFFFFE6D5ADFFE7D6\r\n      B0FFEFD9B4FFFFDEBBFF007B32FF7AE7D6FF00C59DFF00AE7AFF008039FF0095\r\n      56FF00985BFF00B17EFF00B689FF005E33BBB47907FFFFFFFFFFFFFFFDFFFFFF\r\n      FDFFFFFFFFFFF4C7B0FF007E35FF7BE8D7FF00C59DFF00AF7BFF00813BFF0081\r\n      3BFF00813BFF00AF7AFF00B688FF00813BFF0000000078432CBFC9A092FFD3A4\r\n      96FFBD816DFFBB806DFFAF6B57FFB16D59FFC08978FFC6907DFFD7AD9EFFC7A3\r\n      90FFD9D6D4FFD8D5D2FFB4B0ACFD181716760000000A6145279CC2915CFFEED8\r\n      B9FFFFFCE8FFFFF6E1FFFFF6E1FFFFFBE7FFFFFFF0FF009551FF00CA95FF00C7\r\n      8EFFFFFFFFFF00C88FFF00CC98FF009D5CFFB47D1DFFFFFFFFFFF8F4E8FFF9F4\r\n      E9FFFFF7EDFFFFFCF5FFFFFFFBFF007B32FF95E9E5FF007E36FFFFF9F1FFE0F3\r\n      EDFF9C8329FF006435BA00A171FF009152FFB47A07FFFFFFFFFFD4B999FFD6BA\r\n      9BFFDFBFA1FFF0C6ACFFFFC9B1FF007D34FF95E9E5FF008138FFF4C5ACFFF4C5\r\n      ACFFF4C5ACFF3EA979FF009E6CFF00813BFF13060025B66A4EFF916356FFA357\r\n      40FF903820FFDABEB6FF8F3B25FF8F4834FF9D533EFF92412AFFA56C5BFFB46D\r\n      52FFEDE6E2FFF7F7F7FFEEEEEEFF494440B6251B1055BF8B52FFFFF7E1FFFFF7\r\n      E2FFFFF3DAFFFFF2D8FFFFF1D7FFFFF3D9FFFFF7DFFF66C08FFF00A868FF00D1\r\n      9BFF71ECD2FF00D39DFF00AF71FF005C3794B47D1DFFFFFFFFFFF4EDDDFFF7EF\r\n      DFFFF2ECDCFF007930FF92C6A2FFFFFFF8FF007E36FF53AD7CFFFFFBF2FF5DB8\r\n      91FF008642FF0000003300381D65008E4DFFB47A07FFFFFFFFFFFFFDF2FFFFFF\r\n      F4FFFEFCF0FF007D34FFFFFFFFFFFFFFFFFF007E36FF00813BFFFFFFFFFF0081\r\n      3BFF00813BFFFFFFFFFF748322FF00813BFF663119A4BA7155FFAC7E6EFF7830\r\n      1CFF923F26FFA35A44FF9D523AFFD3BCB4FFCEB1A7FF994B35FF926659FFB66E\r\n      53FFC8A998FFF0F0F0FFE7E7E7FF4A4642B89B7042D9EAD0AEFFFFF5DFFFFFEF\r\n      D4FFFFEED2FFFFEED2FFFFEED2FFFFEED2FFFFF0D5FFFFF4DBFF66BD8DFF0093\r\n      4EFF00934FFF009754FF3E8B51F000000000B47D1DFFFFFFFFFFF3EAD6FFF6EB\r\n      D9FFFFF2E2FF008C48FF00A562FF37A068FFF6EBD9FFF6EBD9FFFFF9EFFF007E\r\n      38FF10E6B1FF008644FF0000003300000000B47A07FFFFFFFFFFFFFBEBFFFFFC\r\n      EDFFFFFFF8FF00813BFF00A662FF3CA46EFFF4C5ACFFFFFFFFFFFFFFFFFF007E\r\n      38FF09E3AEFF00823FFFE97E09FF0000000096583DDECC9F8EFFDAC1B7FF835E\r\n      53FFB57864FFC59381FFC1998BFFF1E7E3FFECDED9FFCAA598FF8E4833FF9D51\r\n      3DFFB18167FFE7E7E7FFE0E0E0FF4A4541B8C0884EFFFFFCE6FFFFEFD3FFFFEB\r\n      CDFFFFEBCDFFFFEBCDFFFFEBCDFFFFEBCDFFFFEBCEFFFFEDD0FFFFF0D3FFFFF1\r\n      D6FFFFF4DCFFFFFEEBFFD2884EFF00000000B47D1DFFFFFFFFFFF1E6CEFFF3E7\r\n      D0FFFFEDD8FF4FAA76FF00BC7DFF00B776FF009856FF009854FF007E3AFF00B9\r\n      7AFF00DA9FFF3BE9BDFF008744FF00000033B47A07FFFFFFFFFFD4B38CFFD7B5\r\n      8FFFE6BB98FF00813BFF00BE80FF00B878FF00813BFF00813BFF00813BFF00B9\r\n      7AFF00DA9FFF35E8BDFF008745FF00000033AA715BEEDBC1B7FFD6C1B9FFA270\r\n      5EFFD3AA9CFFCFAD9FFFCEBAB3FFFEFDFDFFFBF8F6FFF0E7E3FFAB8071FFB386\r\n      76FFA6694DFFDEDEDEFFD8D8D8FF494642B7C18A4EFFFFF9E4FFFFE9C8FFFFE8\r\n      C8FFFFE8C8FFFFE8C8FFFFE8C8FFFFE8C8FFFFE8C8FFFFE8C8FFFFE9C9FFFFE9\r\n      C9FFFFEACBFFFFF9E6FFC48A4FFF00000000B47D1DFFFFFFFFFFEEE3C8FFF0E4\r\n      CAFFF8E7CEFFCFD7B8FF008A48FF00BE84FF00D8A5FF00D7A5FF00D6A3FF00D4\r\n      A0FF00D19CFF00D39EFF60DBB7FF008C49FFB47A07FFFFFFFFFFFFF7DFFFFFF8\r\n      E1FFFFFDE8FFBBB287FF00813BFF00BF86FF00D8A6FF00D8A5FF00D7A4FF00D4\r\n      A0FF00D19CFF00D39FFF5DDBB8FF008C4AFF7F513AC0975948FFA96650FFD8B6\r\n      AAFFE6CEC4FFF2E6E1FFF1E1DBFFF2E5DFFFF9F2EFFFEAE4E2FFD5C8C2FFE1CD\r\n      C5FFB58B76FFDEDEDEFFD2D2D2FF494641B7C38B4FFFFFF7E5FFFFE5C3FFFFE5\r\n      C2FFFFE5C3FFFFE5C3FFFFE5C3FFFFE5C3FFFFE5C3FFFFE5C3FFFFE5C3FFFFE5\r\n      C2FFFFE5C3FFFFF7E5FFC38B4FFF00000000B47D1DFFFFFFFFFFECE0C1FFEDE1\r\n      C3FFF0E2C6FFFAE5C9FFCED3B2FF2FA472FF00823DFF00813BFF008039FF00AE\r\n      7AFF00C69FFF86DCC5FF008743FF00000000B47A07FFFFFFFFFFFFF5D7FFFFF6\r\n      DAFFFFFADFFFE4B990FFE4E9CAFF00813BFF00833EFF00843FFF00843EFF00AF\r\n      7CFF00C69FFF7DDCC5FF008746FF000000004B2D1D78A36250FFAD8A7CFFE4CC\r\n      C3FFE9D3CBFFECD9D3FFECD7D0FFECD9D2FFF0E1DCFFF2EBE9FFF9F5F4FFE4D1\r\n      C9FFCBB5A8FFE0E0E0FFD7D7D7FF494441B7C68E53FFFFF9E8FFFFE8C8FFFFE3\r\n      BCFFFFE3BEFFFFE3BEFFFFE3BEFFFFE3BEFFFFE3BEFFFFE3BEFFFFE3BEFFFFE3\r\n      BCFFFFE8C8FFFFF9E8FFC68E53FF00000000B47D1DFFFFFFFFFFEADCB9FFEADD\r\n      BCFFEBDEBDFFEDDEBDFFF3DFBEFFFFFFFFFFC3760FFFFFFFF9FFFFFFFFFF0082\r\n      3AFF9FE3D8FF008743FF0000000000000000B57A08FFFFFFFFFFDDB17BFFE0B4\r\n      7DFFE0B683FFE1B887FFE9B988FFF1BB8BFFF5BD8FFFFBBE8EFFFFBF90FF0082\r\n      38FF94DFD2FF00823DFFD3800DFF0000000004010008C39F8FF9CFBAB3FFDDD2\r\n      CDFFECDED9FFF5E9E4FFEFE6E2FFE9DDD9FFE9DEDBFFF7EFECFFFFFEFEFFC59D\r\n      8BFFE9E8E8FFE5E5E5FFDCDCDCFF494440B6A47747D2EED1B1FFFFF1DCFFFFE1\r\n      B8FFFFDFB7FFFFDFB7FFFFDFB7FFFFDFB7FFFFDFB7FFFFDFB7FFFFDFB7FFFFE1\r\n      B8FFFFF1DCFFEED1B1FFA47747D200000000B57E1EFFFFFFFFFFE7D8B1FFE7D8\r\n      B2FFE7D9B3FFE7D8B2FFE8D8B1FFFFFFFFFFAF7006FFFFFFFFFFFDDBBFFF257C\r\n      34ED008A48FF000000000000000000000000B57B08FFFFFFFFFF43C3FFFF48C5\r\n      FFFF46C6FFFFE3B67DFF46C7FFFF48C7FFFFE6B680FF4BC8FFFF54CAFFFF0081\r\n      3BFF007B32FFFFFFFFFFBF7E0DFF0000000000000000351F1465ECDDD8FFF4ED\r\n      EAFFEDE6E4FFF4EDEAFFFAF6F4FFF9F2EFFFF6EDE9FFF7EEEBFFEBDAD3FFE1D4\r\n      CDFFEFEFEFFFEBEBEBFFDEDEDEFF403B39A4291E1233CD965FFFFFF4E3FFFFF1\r\n      DDFFFFE4C1FFFFE2BDFFFFE2BDFFFFE2BDFFFFE2BDFFFFE2BDFFFFE4C1FFFFF1\r\n      DDFFFFF4E3FFCD965FFF291E123300000000B68123FFFFFFFFFFFFFFFFFFFFFF\r\n      FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFEEDCC3FF7E5213A40000\r\n      000000000000000000000000000000000000B67D0DFFFFFFFFFFFFFFFFFFFFFF\r\n      FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n      FFFFFFFFFFFFFFFFFFFFB87E0EFF000000000000000002020204997E6DF2D3AC\r\n      9CFFEFE0DAFFF2EAE7FFF5ECE8FFF4EAE6FFEFDFD9FFD1A897FFD7C4B9FFE9E9\r\n      E9FFE6E6E6FFE2E2E1FFA9A5A1FE14121035000000005841286ED49F6AFFF4DA\r\n      BFFFFFFCEEFFFFFAEDFFFFFAEDFFFFFAEDFFFFFAEDFFFFFAEDFFFFFCEEFFF4DA\r\n      BFFFD49F6AFF694D2F830000000000000000AD7F2AEFB68123FFB57E1EFFB47D\r\n      1DFFB47D1DFFB47D1DFFB47D1DFFB47E1EFFB58021FFAA7822EA000000000000\r\n      000000000000000000000000000000000000AD7C17EFB67D0DFFB67B08FFB67A\r\n      06FFB67A07FFB57A07FFB67A07FFB67A07FFB57A07FFB67A07FFB67B07FFB77B\r\n      08FFB77B09FFB77D0EFFAD7C17EF00000000000000000000000001010102211C\r\n      184A4B27149395634BDDB07F65F38C5A40D657321E9B201C19491F1C19461F1C\r\n      19461F1C19461F1C19460A0909180000000000000000000000003B2B1B48BA86\r\n      54E5CF945AFFCE9359FFCE9359FFCE9359FFCE9359FFCE9359FFCF945AFFBA85\r\n      52E4392A1A470000000000000000000000000000000000000000000000000000\r\n      00001D1D1D1E2F2F2F313030303330303033303030332E2E2E30303030333030\r\n      3033212121220000000000000000000000000000000000000000000000000000\r\n      00001D1D1D1E2F2F2F313030303330303033303030332F2F2F31232323243030\r\n      303330303033303030331D1D1D1E000000000000000000000000000000000000\r\n      0000000000000000000000000033000000330000003300000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      00000000000000000000000000000000000000000000000000000D0D0D0E3030\r\n      30338C7B64AAB16F22F9B46D16FFB56D16FFB86D16FFC07126F3008C4BFF00C6\r\n      85FF54876EBD20202021000000000000000000000000000000000D0D0D0E3030\r\n      30338C7B64AAB16E21F9B26C15FFB36C15FFB86C14FFC47024F55A896EC2008D\r\n      4AFF008B47FF008C49FF5D8373AC1D1D1D1E0000000000000000000000000000\r\n      00000000000000000000556B81FF496685FF5191D9FF00000033000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      00000000000000000000000000002800004B88261BE08B2C15E1150300240000\r\n      000000000000000000000000000000000000000000000D0D0D0E605D596BB26B\r\n      13FFC37928FFD48838FFE08D40FFE79043FFEC9145FFF58B3DFF008947FF00E4\r\n      A6FF00BE80FF56866FB92020202100000000000000000D0D0D0E605D596BB26B\r\n      13FFC27928FFD08635FFD48937FFD68A38FFE18B3AFF538B42FF009A5AFF00BB\r\n      86FF74E0C6FF00BB86FF009959FF5D8373AC0000002400000033000000330000\r\n      003300000033000000335685ABFF80A7B8FF90D6FFFF34699DFF000000330000\r\n      0033000000330000003300000024000000000000000000000000000000000000\r\n      000000000000110000215504019CB3625CFFE5D8D4FFA95C4BF41C0100330000\r\n      00000000000000000000000000000000000000000000605D596BB46C15FFD089\r\n      38FFDEB482FFF2FAF7FF45BD99FF008742FF008945FF008844FF00843FFF00D9\r\n      A2FF00D8A0FF00BC80FF56866FB92121212200000000605D596BB46C15FFD089\r\n      38FFDCB380FFE4F4EDFFEBFFFFFF9DACB4FFFFFFFFFF00853EFF00C08CFF00BC\r\n      83FFFFFFFFFF00BC83FF00C18DFF008C49FF7F5709C1B77E0EFFB67C09FFB67B\r\n      08FFB87B06FFBE7A00FF3AAFFCFF88E5FFFF80D3FFFF129BFFFF316AA4FFCF86\r\n      00FFBE8109FFB9800FFF7F5709C1000000000000000000000000000000000000\r\n      00002D000056821B1BDCD5B0AFFFF0F6F8FFEEEFEFFFA15142ED150100270000\r\n      0000000000000000000000000000000000001D1D1D1EB16A12FFD48D3FFFDECC\r\n      ACFFE5FFFFFFF5FFFFFF007B32FF37E6BEFF00D7A0FF00D7A0FF00D59FFF00D0\r\n      9CFF00D09CFF00D39FFF00B981FF54876FBD1D1D1D1EB16A12FFD48D3FFFDECC\r\n      ACFFE2FFFFFFE1FFFFFFE2FFFFFFE6FFFFFFF8FFFFFF008035FF70E5CBFFFFFF\r\n      FFFFFFFFFFFFFFFFFFFF74E7CEFF008B46FFB77E0EFFF7FFFFFFF2F7FFFFF2F7\r\n      FFFFF3F6FFFFF6F6FCFFFFF7F3FF1C6DC2FF3CC3FFFF29AAFFFF149CFFFF2964\r\n      A1FFFFFFFFFFFEFFFFFFB8800FFF000000000000000000000000020000034600\r\n      0087AA5351FAEDE7EAFFEBDBCAFFD2946BFFEBE4E2FFAC5A4FFA660D08BB6519\r\n      08AE681D08B16B2007B7591E0197000000008C7C65A9C98432FFDDB98BFFDCFF\r\n      FFFFDFFDFFFFF0FFFFFF00792FFF68E6CDFF00C899FF00C899FF00C899FF00C7\r\n      97FF00C898FF00CA9BFF5FE6CDFF008A44FF8C7C65A9C98432FFDDB98BFFDCFF\r\n      FFFFDBFBFFFFDBF9FDFFDCFAFDFFDFFBFFFFF0FFFFFF007B32FF00CA93FF00C8\r\n      8FFFFFFFFFFF00C990FF00CD99FF008C48FFB67C09FFF5FBFFFFEBEBEEFFECEC\r\n      EEFFEDECEEFFECEAECFFF2EEECFFFFFFFFFF216FC1FF42C6FFFF2AABFFFF0F99\r\n      FFFF205E9BFFFFFFFFFFBB810BFF0000000000000000020000045101009DC076\r\n      76FFFBFEFFFFECC8A9FFD16E22FFCF7B3DFFECECF1FFE5D8DAFFDDC9C4FFDECB\r\n      C8FFDDCBC7FFDFCEC5FFB06545FF00000000B16E1FF9DD9A4FFFD9F0ECFFD6FB\r\n      FFFFD9F8FDFFEAFFFFFF007B30FF93EEE0FF49E8D3FF4BE7D2FF4AE6D1FF93E8\r\n      D7FF00C397FF5AE0C7FF00B382FF5E8774A9B16E1FF9DD9A4FFFD9F0ECFFD6FB\r\n      FFFFD6F8FBFFD8F9FCFFDBFDFFFFDCFCFFFFE5FEFFFF53B792FF009B56FF00D2\r\n      9AFF70EFD5FF00D49FFF00A465FF617E7194B67B08FFF5FBFFFFE6E6E7FF9D9C\r\n      9CFF9E9D9DFFE9E8E7FFC2C0BDFFFFFFFFFFFFFFFFFF2573C5FF40C7FFFF1FA9\r\n      FFFF7EADD5FF747273FFC18506FF000000000000000044010183C07878FFFFFF\r\n      FFFFF2C08FFFE38530FFDD7D2EFFD7823EFFD89B6EFFD79E75FFD29A74FFCA8D\r\n      68FFC89071FFE9E7E9FFB77961FC00000000B16A12FFE9A660FFD3FFFFFFD2F6\r\n      FDFFD4F5FBFFE1FDFFFF0E6C3DFF008637FF008235FF008034FF007C33FF80E3\r\n      D5FF52DAC4FF00AE80FF437B2FFF00000000B16A12FFE9A660FFD3FFFFFFD2F6\r\n      FDFFD2F5FAFFD7FBFFFF514644FFB4CCCEFFDCFCFFFFE5FCFFFF52B791FF0080\r\n      34FF00853BFF008A46FF4F7B30FF00000000B67B08FFF5FBFFFFE1E1E1FFE3E2\r\n      E1FFE4E3E2FFE4E3E2FFA0A0A0FFA2A1A0FFA7A4A0FFB3A8A0FF1F73C8FFACD9\r\n      EEFF90877DFFBEBEBAFF727A76FF00000033000000009C3436F8FBF9F9FFFFD2\r\n      9AFFF6993CFFEE9845FFE68F41FFDE8337FFD37124FFCA661DFFC15B15FFB54B\r\n      06FFB25116FFE3D7D3FFB7785EFC00000000B16A11FFEEAD67FF7C959EFFCEF6\r\n      FCFFCFF4FAFFD7FCFFFFBED2D9FF675255FFC3CED8FFF0FFFFFF008033FF6EE0\r\n      D2FF00A777FF4D9753FFC9680EFF00000000B16A11FFEEAD67FF7C959EFFCEF6\r\n      FCFFCEF4F9FFD4FCFFFFB5D0D4FF574D4BFFAEC6C9FFD3F6FDFFD9F7FFFFE1FD\r\n      FFFF949CA9FFFFAF6BFFC2680FFF00000000B67B08FFF5FBFFFFDBDBDCFFDDDC\r\n      DBFFDDDDDBFFDDDDDBFFDEDDDCFFDDDCDAFFDEDBDAFFE1DDDAFFE7E0DBFFA199\r\n      93FFE7E5E1FF878B82FFB978B7FF9768CCFF00000000982F31F4F8F4F5FFFFD9\r\n      A6FFFEA445FFF8A34DFFF09A49FFE78F3FFFDE802EFFD67426FFCD671EFFC158\r\n      11FFBD5E20FFE7DCD7FFB6775EFC00000000B16A11FFF1B170FFC7FAFFFFC9F3\r\n      FBFFCDF6FDFFAECACEFF5C504EFFB0CAD0FFD2F8FFFFDAF7FFFF007829FF00A0\r\n      6FFF38B08CFFFFB577FFB86A12FF00000000B16A11FFF1B170FFC7FAFFFFC9F3\r\n      FBFFCDF6FDFFAECACEFF5B504EFFAEC9CEFFCCF6FCFFC9F0F6FFC9EFF6FFCAF2\r\n      FBFFCAFBFFFFF4B271FFB36911FF00000000B67B09FFF6FCFFFFD8D6D8FFDBD9\r\n      D9FFDBD9D9FFD9D7D7FFEEEDEEFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF3F2\r\n      F2FF9C9C95FFDFAEDFFFCA95C7FFAE7BD0FF000000003D000075B96B6CFFFEFF\r\n      FFFFFFD8A8FFFEA74BFFF99F44FFF0A357FFEBBB93FFEDC39DFFEAC29EFFE3B6\r\n      94FFDFB79BFFF4F7F7FFB87A61FC00000000AF6F1FF8EBAD6AFFC8E9EBFFC4F4\r\n      FFFFA9C8CCFF5E534FFFABC9CDFFC8F4FCFFC5EFF6FFC8EFF8FFD0F2FFFFD1F5\r\n      FFFFD4EDF2FFF0AE6DFFB06F1FF800000000AF6F1FF8EBAD6AFFC8E9EBFFC4F4\r\n      FFFFA9C8CCFF5E534FFFABC9CDFFC8F4FCFFC4EFF6FFC2ECF3FFC2ECF4FFC0EF\r\n      F9FFC7E8EAFFEBAD6AFFAF6F1FF800000000B67C09FFF6FCFFFFD4D3D3FF918F\r\n      8FFF929090FFD7D4D3FFC1C0BEFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFC2C2\r\n      BFFFD7D8D4FFBC80D7FFBC87DFFF0000000000000000000000004800008DB765\r\n      66FFF9F9FDFFFFE8CCFFFFAA50FFF9AE61FFF7FBFFFFE6D5D7FFDDBFBCFFDEC5\r\n      C2FFDEC7C2FFDFC5BBFFAF623FFF0000000085776695D49348FFE4CDA9FFBBF5\r\n      FFFF5A4F4CFF95A8ADFFC2F2FAFFBEECF4FFBCEAF2FFBCEAF3FFBDEBF6FFBAF0\r\n      FFFFE6CCA9FFD49449FF857766950000000085776695D49348FFE4CDA9FFBBF5\r\n      FFFF5A4F4CFF95A8ADFFC2F2FAFFBEECF4FFBCEAF2FFBCE9F2FFBAEAF4FFB7EF\r\n      FEFFE4CBA8FFD49348FF8577669500000000B67C09FFF6FCFFFFCDCCCDFFD0CE\r\n      CEFFD0CECFFFD0CECEFFA0A1A2FF9FA0A1FF9E9FA0FF9E9FA0FF9FA0A1FFA0A1\r\n      A2FFCECECEFFF8FFFFFFB77E00FF000000000000000000000000010000013B00\r\n      0074A1403FF6EBD7DBFFFFF8E7FFFED3A1FFFBF7F4FFAA544BF95C0604AC5811\r\n      049C5C1405A05F1705A54D1701820000000000000000B0680FFFEEB372FFD9DA\r\n      C7FFB6F3FFFFB8EFFCFFB8ECF7FFB8EBF6FFB7EAF4FFB4E9F5FFB2ECFCFFD7D7\r\n      C3FFEEB271FFB0680FFF000000000000000000000000B0680FFFEEB372FFD9DA\r\n      C7FFB6F3FFFFB8EFFCFFB8ECF7FFB8EBF6FFB7EAF4FFB4E9F5FFB2ECFCFFD7D7\r\n      C3FFEEB271FFB0680FFF0000000000000000B67C0BFFF4FDFFFFF3F7FFFFF3F7\r\n      FFFFF3F8FFFFF4F8FFFFF5F9FFFFF5FAFFFFF5F9FFFFF5F9FFFFF5FAFFFFF4F9\r\n      FFFFF3F8FFFFF5FEFFFFB67D09FF000000000000000000000000000000000000\r\n      000022000042780F0FD2D19E9CFFFDFCFEFFFFFFFFFFA55645ED150000280000\r\n      0000000000000000000000000000000000000000000044424146B56D16FFF1B6\r\n      78FFE6D3B2FFBCE5E9FFADECFFFF60808BFFADECFEFFBCE4E8FFE5D2B1FFF1B6\r\n      77FFB56D16FF4442414600000000000000000000000044424146B56D16FFF1B6\r\n      78FFE6D3B2FFBCE5E9FFADECFFFF60808BFFADECFEFFBCE4E8FFE5D2B1FFF1B6\r\n      77FFB56D16FF444241460000000000000000B67E0FFFF7E4C0FFDCAA49FFDCAB\r\n      49FFDCAB4AFFDDAB4AFFDDAC4BFFDDAC4BFFDDAC4BFFDDAC4BFFDDAC4BFFDDAB\r\n      4AFFDCAA49FFF7E4C0FFB67E0FFF000000000000000000000000000000000000\r\n      0000000000000B0000154A00008BAE544CFDE7CDC7FFAD5E4DF51C0100330000\r\n      000000000000000000000000000000000000000000000000000044424146B067\r\n      0EFFD99C52FFFAC18AFFFFCE9AFFFFCF9AFFFFCE9AFFFAC18AFFD99C52FFB067\r\n      0EFF44424146000000000000000000000000000000000000000044424146B067\r\n      0EFFD99C52FFFAC18AFFFFCE9AFFFFCF9AFFFFCE9AFFFAC18AFFD99C52FFB067\r\n      0EFF44424146000000000000000000000000B88215FFEFD2A0FFEDCF9BFFECCF\r\n      9BFFECCF9BFFECCF9BFFECCF9BFFECCF9BFFECCF9BFFECCF9BFFECCF9BFFECCF\r\n      9BFFEDCF9BFFEFD2A0FFB88215FF000000000000000000000000000000000000\r\n      00000000000000000000000000001E0000387C1D12D2852710DA130300210000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      000085776595AE6F1FF7B0680EFFB0670EFFB0680EFFAE6F1FF7857765950000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      000085776595AE6F1FF7B0680EFFB0670EFFB0680EFFAE6F1FF7857765950000\r\n      000000000000000000000000000000000000825D14B2B88216FFB78113FFB681\r\n      13FFB68113FFB68113FFB68113FFB68113FFB68113FFB68113FFB68113FFB681\r\n      13FFB78113FFB88216FF825D14B2000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000016140F63362F20930000\r\n      0000000000002E271C83241F17760000000000000000161616193F3F3F623F3F\r\n      3F603E3E3E5D3E3E3E5D3E3E3E5D3E3E3E5D3E3E3E5D3E3E3E5D3E3E3E5D3E3E\r\n      3E5D3E3E3E5D4343437738383853141414170000000000000000000000000202\r\n      0202B48155FFB07C53FFA08857FF998A59FFA4714EFFA06D4CFF9D6A4BFF9966\r\n      49FF966348FF6559528000000000000000000000000000000000000000000000\r\n      0000000000000B0B0B141919192E25252547262626461717172C0A0A0A130000\r\n      0000000000000000000000000000000000000B0B0A3325252563353637753132\r\n      3672303134722E3033722D2F32722A2C306E2D2B2688C59846FAE6B55AFF433D\r\n      2FA137322B95F0C166FFF2C161FF252116790909090A4E4C48F15B5A55F85B5A\r\n      55F8595954F9595954F9595954F9595954F9595954F9595954F9595954F95959\r\n      54F9595954F9585753FA504E49F83737364B0000000000000000000000000707\r\n      0707B78457FFFEF6F0FFCFE9C9FF7AD58BFFD2E7C7FFFEEFE5FFFDEDE1FFFDED\r\n      E0FFF8EFE8FFBD9F8EFF50494660000000000000000000000000000000000808\r\n      080F2F2F2F5C4C4B4A7F5756567F6463627F6564647F5A59597F4D4D4D7F2C2C\r\n      2C570606060C0000000000000000000000003D3D3F73C0C1C2DEF4DCB2FFEACB\r\n      95FFECCE98FFEDCF99FFF2D49EFFF5D8A2FFCBAA6CFFC39541FFDDAC52FFE7BC\r\n      6EFFEAC174FFEFBD5EFFEAB858FF2D261A842C2C2C36595754F445443EFF4140\r\n      3AFF41403AFF41403AFF41403AFF41403AFF41403AFF41403AFF41403AFF4140\r\n      3AFF41403AFF41403AFF5C5B56F949494879B48155FFB07C53FFAC7851FFAB78\r\n      55FFB98657FFF7F3EAFFBCE4BBFF6FD484FF68D17DFFA0DBA3FFF0EAD7FFFDEC\r\n      DFFFFEF8F3FFE9DFD9FF92664DF133302F390000000000000000121212283D3D\r\n      3B795654527F6C6A697F7776757F7C7C7B7F7D7D7D7F7A7A7A7F7271707F5A59\r\n      587F3D3D3C771010102300000000000000003C3D3F72C0C1C3DECEA04BFFBE80\r\n      13FFC58B20FFD49A2FFFDDA338FFE1A536FFE9AC3BFFC0984DFFC9A053FFE1B2\r\n      5BFFE7B85FFFE3B55EFF8D8575E80000000A2D2D2D376C6D6AF97C8280FF8184\r\n      82FF818482FF818482FF818482FF818482FF818482FF818482FF818482FF8184\r\n      82FF818482FF7C8380FF727572FD4B4A4971B78457FFFEF6F0FFFEF4ECFFD9EA\r\n      CFFF82B86EFF6ED283FF64CF79FF83DC94FF80DB91FF6CD382FF73D285FFC1E2\r\n      B8FFF4F1E4FFFEF8F4FFE0CDC2FF946247FF000000000606060F393838795652\r\n      507F807160969F7D56B39F7D56B3A2815BB3A5845EB3A4825CB3A07F5AB38A77\r\n      609E5D5A587F373737760505050A000000003C3D4073C0C0C3DECEA254FFBE85\r\n      1EFFCB9432FFD8A23FFFDCA43EFFE6B965FFEEC884FFBC9751FFC19340FFD9A6\r\n      4AFFE2AF52FFDDAC50FF94866DEC0000000F2929292E949A97FEDADEDDFFD7DA\r\n      D9FFD7D9D8FFD5D9D7FFB0B3B2FF888C8AFF6B6A65FF7D8481FFA7AAAAFFD1D4\r\n      D3FFD6D9D8FFD7DBDAFF9A9F9DFE5151516AB3865CF0FEF5EFFFB2E2B4FF64CF\r\n      78FF94E3A3FF8DE09CFF8CE09BFF92E2A1FF89DE99FF78D88CFF6AD280FF93D9\r\n      9AFFE4E9D0FFFDEDE0FFFDEEE3FF966448FF000000002727275C4744417F6F62\r\n      5590CC8332F9DFAB6BFFDFAC6EFFDFAC6EFFDFAC6EFFDFAC6EFFDFAC6DFFCF88\r\n      39FA826A53A14C4A487F24242455000000003C3D4073C0C0C3DECCA052FFBD84\r\n      20FFCB9433FFD6A03EFFD89F37FFF5E2BDFFC2BBB1FFAE781DFFC68E29FFC190\r\n      38FFC69640FFD69D33FFDDA337FF362D1B9407070708939796FAD3D7D6FFBAC1\r\n      BEFFBCC2C0FF959997FF959796FFA8988BFF8A4D25FFB9A99DFFB1B3B3FF757B\r\n      78FFBBC1BFFFD4D8D6FF989C9AF32C2C2C31BD8A59FFBEE6BFFF8ADF9AFF68D0\r\n      7CFF77C172FF9FDEA7FF92DA9DFF8CE09BFF7AD98EFF73D386FFC6E6C1FFFEF1\r\n      E7FFFEEFE4FFFEEDE1FFFDEDE0FF996649FF070707143A38377F4F4B477F7C5D\r\n      41ABD8A05DFDE5BC89FFE5BC89FFE5BC89FFE5BC89FFE5BC89FFE5BC89FFDEA9\r\n      6AFF94663FBF55514F7F3938377F0404040C3C3D4073C0C0C3DECB9F52FFBB83\r\n      1FFFC6902FFFD49E3EFFD69D36FFF1DDB9FFD9D6D2FFA57626FFAD7516FFCAC0\r\n      ADFFCEC7BAFFBE8A2DFFC59235FF17130E6400000000808382CAD3D5D4FFBDC3\r\n      C1FFB8BFBCFF808281FF9C8B80FF884B21FF925225FF894B22FFC5B8AEFF9A9C\r\n      9AFFA5A9A8FFD8DBDAFF878B89F301010101A89E63FF81D68FFFB2E3B5FFECF1\r\n      E1FFC5925DFFFEF6F1FFD0EACCFF76D78BFF9DDDA5FFEFF1E4FFFEF4EDFFFEF3\r\n      EAFFFEF1E7FFFEEFE4FFFEEFE4FF9C694AFF1010102E3E3B397F4C48447F724F\r\n      39ABD99F5DFDDFAC6EFFDFAC6EFFDFAC6EFFDFAC6EFFDFAC6EFFDFAC6EFFDCA3\r\n      60FF8A5939BF504B487F3C3A397F0E0E0E263C3D4073C0C0C2DECA9E51FFB981\r\n      1DFFC18A29FFCE9938FFD59D36FFEED9B3FFFFFFFFFFD6CFC4FFC2B5A1FFFFFF\r\n      FFFFFAFCFFFFB9A276FF8F8677EA0000000B000000005C5D5D77BBBFBEFBC6CB\r\n      CAFFC3C8C6FF88786DFF884A21FF98582AFFA46332FF97572AFF8A4D24FF9B91\r\n      89FFBDC2C0FFC7CBCAFF787B7AB400000000A4A465FFD9EDD4FFFEF6F0FFFEF6\r\n      F0FFC8945EFFFEF6F1FFDFEED8FFCEEACBFFFEF6F0FFFEF6F0FFFEF5EFFFFEF4\r\n      EDFFFEF3EAFFFEF1E7FFFEF1E7FF9E6B4BFF1818184744403D7F4B47437F6F4A\r\n      38ABDEAD73FDDFAB6DFFDFAC6FFFDFAC70FFDFAB6DFFDCA461FFD99D55FFD99C\r\n      54FF835237BF4B47437F423E3C7F1616163F3C3D4073C0C0C2DEC79C50FFB67D\r\n      1CFFBE8827FFC48D2CFFCD952EFFEAD5B1FFFDFFFFFFFCFDFEFFF9FBFDFFF0F2\r\n      F5FFE7EBF2FFE1C693FFADADABEA0000000C000000002B2B2B309EA1A0F5CFD3\r\n      D2FFB2A99EFF894D25FF9C5F33FFA76838FFA46332FFA46332FF955629FF894D\r\n      25FFC2BCB5FFACAEADF65253526600000000BE965FFFFBF5EFFFFEF6F0FFFEF6\r\n      F0FFCA9760FFFEF6F1FFFEF6F0FFFEF6F0FFFEF6F0FFFEF6F0FFFEF6F0FFFEF5\r\n      EFFFFEF4EDFFFEF3EAFFFEF2E9FFA16E4DFF161616464643417F5C58567F724D\r\n      3FABE6C59EFEEBCAA5FFEBCAA5FFEBCAA5FFEBCAA5FFEBCAA5FFE8C297FFDDA6\r\n      67FF83513CBF5E5B587F43403C7F1414143E3C3D4073C0C0C3DEC2974AFFB279\r\n      17FFBB8423FFC08927FFCE932BFF766039FF2D333FFF2F333BFF504D49FF9282\r\n      66FF786D5AFFB1935CFFB3B1AEEA0000000C00000000050505068C918FF3C2BA\r\n      B1FF8C5029FFA5724FFFB08059FFB38159FFB48056FFAA7046FFA06438FF9155\r\n      2BFF8E542DFF8F8C87F71F1F1F2200000000C8945EFFFEF6F1FFFEF6F0FFFEF6\r\n      F0FFCD9961FFFEF6F1FFFEF6F0FFFEF6F0FFFEF6F0FFFEF6F0FFFEF6F0FFFEF6\r\n      F0FFFEF5EFFFFEF4EDFFFEF4ECFFA4714EFF0C0C0C2C3C39387F6D6C6B7F744E\r\n      45ABECD2B3FEF1DAC0FFF1DAC0FFF1DAC0FFF1DAC0FFF1DAC0FFF1DAC0FFEAC8\r\n      A1FF804E3FBF6765637F3836347F0A0A0A243D3D4073C1C2C3DEC89F56FFB984\r\n      26FFC49034FFC99539FFD09B3DFFC4943CFFAB8239FFAC8235FFB78B3CFFC699\r\n      46FFC89A43FFE7BB67FFB1B1B3EA0000000C00000000252423297A7974BA8D5C\r\n      3BFF986543FF966645FF97613DFFB0805AFFB98860FFA8734FFF935B36FF9560\r\n      3DFF915B36FF81573BFA0707070800000000CA9760FFFEF6F1FFFEF6F0FFFEF6\r\n      F0FFCF9B62FFFEF6F1FFF3DEB3FFF1D7AAFFEECD9DFFEAC08FFFE7B683FFE6B1\r\n      7AFFE6B17AFFE6B17AFFFEF5EFFFA7744FFF060606132F2D2C7F6F6E6D7F7650\r\n      4BABF0DCC6FEF9F0E6FFF9F0E6FFF9F0E6FFF9F0E6FFF9F0E6FFF9F0E6FFEFD4\r\n      B5FF7D4940BF6663627F2D2C2B7F0303030B2E2E2F73969899DEC5C2BBFFBDB8\r\n      B0FFBCB7AFFFBAB5ADFFB8B3ACFFB9B4AAFFB7B1A4FFB1ADA5FFADA89EFFABA7\r\n      A0FFA9A39AFFA8A5A2FF858588EA0000000C1818171A5D5048774E4E4D5EB0B4\r\n      B2FBB7BCBAF9A6A5A1FA874A21FFB98B67FFBC8E68FFA3704EFFA18976FCB4B8\r\n      B6F9909391F7929292BB0101010100000000CD9961FFFEF6F1FFFEF6F0FFFEF6\r\n      F0FFD19D62FFFEF6F1FFF3DEB2FFF1D6A9FFEECC9BFFEABF8DFFE7B581FFE6B0\r\n      78FFE6B078FFE6B078FFFEF6F0FFAA7751FF00000000161616575755537F7768\r\n      6690D4AA8EFBF4E1CBFFF3DEC7FFF3DEC7FFF3DEC7FFF3DEC7FFF2DEC6FFDCB3\r\n      8EFB725353A14947457F1414145000000000040407730D0E13DE10141BFF1014\r\n      1CFF0F131CFF0F131CFF0F131BFF0B1019FF26282BFF9D824FFF6C604DFF967C\r\n      4EFF76684FFF8B744CFF10141CEB0000000C1717161985654FC17A5A45B75552\r\n      4F6B605C587D815B42D697623BFBC39976FFBD906DFF97613EFD655F5A885354\r\n      54684A4B4B5A0B0B0B0C0000000000000000CF9B62FFFEF6F1FFF3DEB3FFF1D8\r\n      ACFFD29E63FFFEF8F3FFFEF7F2FFFEF7F2FFFEF7F2FFFEF7F2FFFEF7F2FFFEF7\r\n      F2FFFEF7F2FFFEF7F2FFFEF8F3FFAD7952FF000000000303030C222121776A69\r\n      677F76626296754544B3754545B3754545B3754645B3754646B3754646B3785B\r\n      5B9E615F5D7F1F1F1F7302020208000000000202044B0C0E11B71A1D23FF1A1D\r\n      23FF1A1D23FF1A1D23FF1A1D23FF161920FF343434FFBB9D65FF84755CFFB498\r\n      63FF918060FFA89062FF0F1216C300000000010000017E5C45C1A06E4DFF9862\r\n      3EFF8E532CFFA67656F9C59F81FFC49D7DFFAD8466F9735A49A1000000000000\r\n      000000000000000000000000000000000000D19D62FFFEF6F1FFF3DEB2FFF1D6\r\n      AAFFD4A064FFD29E63FFD09C62FFCD9961FFCA975FFFC7945EFFC3905CFFC08D\r\n      5BFFBC8959FFB88657FFB48256FFB07C54FF0000000000000000090909232321\r\n      20765554527F7A7A7A7F7E7E7E7F7F7F7F7F7F7F7F7F7F7F7F7F7B7A7A7F5250\r\n      4F7F1F1F1F730707071E0000000000000000000000010000001C0A0A0C6B1010\r\n      10720F0F10710F0F10710F0F10710F0F10710E0F0F71101214710C0E10711012\r\n      13710F1011720C0E0F6D00000120000000000000000011111012855D43D2AA82\r\n      65F8C4A188FFCBAA92FFC4A187FFAB8365FA835E46C80B0B0B0C000000000000\r\n      000000000000000000000000000000000000D29E63FFFEF8F3FFFEF7F2FFFEF7\r\n      F2FFFEF7F2FFFEF7F2FFFEF7F2FFFEF7F2FFFEF7F2FFFEF7F2FFFEF8F3FFAD79\r\n      52FF000000000000000000000000000000000000000000000000000000000101\r\n      010A151515552F2D2C7F4846457F5C5A597F5B59587F4745447F2D2C2B7F1414\r\n      1450020202080000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      000000000000000000000000000000000000000000000000000010100F115F50\r\n      477C896145D6946446ED84614BC74F4640610000000000000000000000000000\r\n      000000000000000000000000000000000000D4A064FFD29E63FFD09C62FFCD99\r\n      61FFCA975FFFC7945EFFC3905CFFC08D5BFFBC8959FFB88657FFB48256FFB07C\r\n      54FF000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000303030C090909260F0F0F3F0F0F0F3E090909240303030B0000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000001A00000031000000330000003300000033000000330000\r\n      0028000000330000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000876444C39F74\r\n      4EE77F5E41B90000000000000000000000000000000000000000000000000000\r\n      0000000000000B0B0B141919192E25252547262626461717172C0A0A0A130000\r\n      0000000000000000000000000000000000000000000B000000220000002D0000\r\n      002D0000002D0000002D0000002D000000220000000B00000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      00000000002E4341409C7D7876F97E7B79FF7D7A78FF787675FFE1E6EBFF8763\r\n      36D3B98441FF0000003300000000000000004A4645B8545050CF545050CF5450\r\n      50CF545050CF545050CF545050CF565150D1866A52ECAB7B50FFBC9A79FDC8AA\r\n      8CFEC5A78CFEA97B54FD564E4BC80A0A0A1A0000000000000000000000000808\r\n      080F2F2F2F5C4C4B4A7F5756567F6463627F6564647F5A59597F4D4D4D7F2C2C\r\n      2C570606060C000000000000000000000000584B189C96822AF296822AF29682\r\n      2AF296822AF296822AF296822AF296822AF2584C189700000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      002E767372EA9D9B99FFC9C8C6FFDAD9D7FFDAD9D7FFD9D9D9FFC2B6A6FFB67C\r\n      36FFEFBF70FFB78242FF0000003300000000645D5DF8BEBBBBFFBAB8B8FFBAB8\r\n      B8FFBAB8B8FFBAB8B8FFBAB8B8FFB39882FFAC7D53FFD5B58BFFE4CFB1FFFDFD\r\n      FDFFFDFDFDFFCFAD85FFAA7C53FF5A402B880000000000000000121212283D3D\r\n      3B795654527F6C6A697F7776757F7C7C7B7F7D7D7D7F7A7A7A7F7271707F5A59\r\n      587F3D3D3C7710101023000000000000000096822AF2F0D54AFFEFD243FFF6E0\r\n      6DFFFAE784FFFAE784FFFAE784FFFBEA8BFF96822AF200000001000000010000\r\n      00010000000000000000000000000000000000000000000000000000001A7A77\r\n      75EAACAAA8FFD8D7D5FFF7F5F6FFFFFFFFFFBEBFBFFFFFFFFFFFE8DED0FFB379\r\n      35FFE5B771FFE5B66EFFB78241FF00000033656160F6DBDBDBFFD4D4D4FFD4D4\r\n      D4FFD4D4D4FFD4D4D4FFD4D4D4FFB48C68FFC19C78FFD3B07BFFCBA061FFFDFD\r\n      FDFFE1C9A8FFC69B60FFB48C67FF805F41BB000000000606060F393838795652\r\n      507F6D6B67828A77619C76706C847776757F7C7C7B7F8279708C887A6897706E\r\n      6D7F5D5A587F373737760505050A0000000096822AF2F0D54DFFF0D54DFF9682\r\n      2AF296822AF296822AF296822AF296822AF2574B188E040300120605011C0000\r\n      000A0000000100000000000000000000000000000000000000004746459B9D9B\r\n      99FFD1D0CEFFC1C2C2FFFFFFFFFFFEFEFDFFFEFEFEFFFFFFFFFFEFE4D7FFB378\r\n      33FFE0B879FFD5A253FFE0B775FFB88443FF686362F6DBDBDBFFD4D4D4FFD4D4\r\n      D4FFD4D4D4FFD4D4D4FFD3D1D0FFAD7D53FFC5A484FFDABF9AFFD7B98BFFFDFD\r\n      FDFFE3CDADFFC89C5DFFB78F67FF9D744EE7000000002727275C4744417F5F5C\r\n      5A7FAA7A42CCD6A365F8BD8545DC71706F7F77726F84CB9049EED49D5BF68972\r\n      55A56563617F4C4A487F242424550000000096822AF2EFD551FFEFD551FF9682\r\n      2AF2000000000000000000000000000000000403010898842CF299852DF2322C\r\n      0F720000000A00000001000000000000000000000000000000008B8886F9B7B5\r\n      B3FFECEDECFFFEFEFDFFFAFAF9FFFAFAF8FFFBFBFAFFFCFEFFFFECE1D4FFB378\r\n      32FFDFBB85FFCC9544FFE3C290FFB88240FF6C6766F6DEDEDEFFD8D8D8FFD8D8\r\n      D8FFD8D8D8FFD8D8D8FFD8D8D8FFB48D68FFC5A68AFFE5D6C4FFEDE1CFFFFDFD\r\n      FDFFE6D2B6FFCFA86EFFB68E68FF856343C1070707143A38377F4F4B477F5552\r\n      4F7FBA8041E5E4BC88FFC88F50EF6A68677F756A628BD6A263F9E2B67EFF946C\r\n      45BA5D5A587F55514F7F3938377F0404040C96822AF2EFD655FFEFD655FF9682\r\n      2AF2000000010000000D000000220000002D0907023A9C882EF3DAC147FC9985\r\n      2CF2322C0F720000000A00000001000000000000000000000000928F8DFFB7B7\r\n      B4FFFFFFFEFFF8F8F7FFF8F8F5FFFDFCF8FFFFFFFFFFFFFFFFFFEDE1D4FFB378\r\n      31FFDFC092FFE1C496FFB57B35FF00000000716C6BF6E5E5E5FFE0E0E0FFE0E0\r\n      E0FFE0E0E0FFE0E0E0FFE0E0E0FFC5AB95FFAE8157FFEDE9E6FFE7DDCFFFF0E8\r\n      DCFFE1CBADFFDBBF9CFFAB7C53FF593F2A851010102E3E3B397F4C48447F4E4A\r\n      467FB77D45E6DEAB6CFFC48B4CEF63615F7F6D635B8BD59E60F9DDA868FF8C62\r\n      41BA55514E7F504B487F3C3A397F0E0E0E2696822AF2EFD65AFFEFD65AFF9682\r\n      2AF200000002584B199D96822AF296822AF296822AF29B872CF3ECCF41FFD7BD\r\n      40FC99852CF2342D0F6600000001000000000000000000000000969391FFB0AE\r\n      ACFFC3C3C3FFF8F7F4FFFDFBF2FFCCD6FEFF24221DFF8A8A8BFFF2E7D8FFB67A\r\n      31FFE3C9A2FFB5782EFFE1E7F1FF00000000757170F6ECECECFFE9E9E9FFE9E9\r\n      E9FFE9E9E9FFE9E9E9FFE9E9E9FFE9E9E9FFC7AD95FFAE8055FFC4A58AFFF3ED\r\n      E8FFD4BCA7FFAD7E54FF90765FFE040303081818184744403D7F4B47437F4F4B\r\n      487FB57B4BE6D89A52FFC28549EF6462607F6C615A8BD49D5EFAD89A52FF895E\r\n      42BA54504D7F4B47437F423E3C7F1616163F96822AF2EFD75EFFEFD75EFF9682\r\n      2AF2090802109C8830F3F2DC6BFFEFD65AFFEED65AFFEDD354FFEBD04AFFECD2\r\n      4FFFDCC65CFC99852FF20605010A0000000000000000000000009A9795FFA7A5\r\n      A3FFFBFBF9FFFAF8F0FFC8CFF4FF0025FFFF7B7D84FF282827FFBCBCBBFFC896\r\n      59FFB7782CFFECF1F7FF939292FF000000007B7676F6F4F4F4FFF2F2F2FFF2F2\r\n      F2FFF2F2F2FFF2F2F2FFF2F2F2FFF2F2F2FFF2F2F2FFEFEDEBFFBA9471FFAD7D\r\n      54FFBE9A79FFF4F4F4FF787474FC04040408161616464643417F5C58567F5E5B\r\n      587FB7825AE8DBA260FFC1864FF06461607F695F598BD39A5CFAD38D3CFF8459\r\n      45BA615E5C7F5E5B587F43403C7F1414143E96822AF2EFD863FFEFD863FF9682\r\n      2AF20908010F9C8831F3FBEA91FFF9E88CFFF9E88BFFF5E27BFFEFD965FFF1DC\r\n      6DFFE3D275FC9C8831F30908010F000000000000000000000000989593F59F9D\r\n      9AFFDFDED8FFECECF1FF395EFDFFC7D0F3FFFFFFF7FFBCBCBAFF3D3E41FFE2E0\r\n      DEFFE1E3E7FF9E9D9DFF979493F8000000007F7C7BF6FBFBFBFFFAFAFAFFFAFA\r\n      FAFFFAFAFAFFFAFAFAFFFAFAFAFFFAFAFAFFFAFAFAFFFAFAFAFFFAFAFAFFFAFA\r\n      FAFFFAFAFAFFFBFBFBFF7E7A79FC040404080C0C0C2C3C39387F6D6C6B7F6866\r\n      657FB9896AEAE9C59DFFC89569F26663627F695D598BDAAE7CFBD59347FF8356\r\n      46BA6866647F6765637F3836347F0A0A0A2496822AF2EED867FFEED867FF9682\r\n      2AF200000000584B188E96822AF296822AF296822AF29C8830F3F6E484FFE2D2\r\n      76FC9C8831F338310F5C000000000000000000000000000000334847458DA09C\r\n      99FFA6A39BFF3A5FFFFFE9E9EEFFF6F3EBFFF3F1EEFFF6F5F3FFE0E1E0FF7374\r\n      75FFA5A5A3FF9F9C9AFF5352518300000000828180F6FFFFFFFFFFFFFFFFFFFF\r\n      FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n      FFFFFFFFFFFFFFFFFFFF817F7EFC04040408060606132F2D2C7F6F6E6D7F7372\r\n      727FBD9077EBF2DEC8FFCB9B76F36C6A697F6E62608BE5C4A2FCECCEADFF7F55\r\n      4ABA6E6C6B7F6663627F2D2C2B7F0303030B96822AF2EED86CFFEED86CFF9682\r\n      2AF2000000000000000000000000000000000908010F9C8831F3E5D480FC9C88\r\n      31F3362F0E590000000000000000000000000000003383807DFF817D7BFF9B97\r\n      95F59C9994FF9E9B93FFD6D4CEFFF4F3F0FFC8C8C8FFF4F3F2FFD5D4D3FF9D9B\r\n      99FF9C9A98FF949090E5000000000000000087807CF7D1B9ABFFD1B9ABFFD1B9\r\n      ABFFD1B9ABFFD1B9ABFFD1B9ABFFD1B9ABFFD1B9ABFFD1B9ABFFD1B9ABFFD1B9\r\n      ABFFD1B9ABFFD1B9ABFF85817FFC0404040800000000161616575755537F7978\r\n      787F8E5950D1EDD6BEFDA06755E17271707F716D6C84CDA48BF5E5C7A7FB7656\r\n      55A67473727F4947457F141414500000000096822AF2EDD86FFFECD66BFF9682\r\n      2AF20000002D0000002D0000002D000000220302001198842DF29C8931F3362F\r\n      0E5900000000000000000000000000000000898684FFCDCBCAF65B5A59AED4D3\r\n      D2EF9E9B99F59F9C99FF8C8A87FF848280FF848280FF848280FF8C8A88FF9F9C\r\n      9AFF989593E5000000000000000000000000975C36FFB3813AFFB2803AFFB17C\r\n      39FFB17A38FFB07737FFAF7436FFAF7134FFAD6E33FFAD6B32FFAC6831FFAB65\r\n      30FFAB632FFFAA612FFF915331FF0B070614000000000303030C222121776A69\r\n      677F78737383765857A0777171867978777F7978787F796A698F775E5E9B7A7A\r\n      797F615F5D7F1F1F1F73020202080000000096822AF2F2DF7EFFEFDB76FF9682\r\n      2AF296822AF296822AF296822AF296822AF2584C1897040301060908010E0000\r\n      000000000000000000000000000000000000908D8BFFD7D5D4F662615FB4DFDF\r\n      DFEF979492FF4B494870A5A2A1F4ADAAA8FFADAAA8FFADAAA8FFA7A4A2F75855\r\n      548300000000000000000000000000000000A57144FFEBCD50FFEAC94EFFE8C3\r\n      4CFFE6BC4AFFE5B547FFE3AE44FFE1A641FFDE9E3EFFDC973CFFDB9039FFD989\r\n      37FFD78334FFD67E33FF985A37FF140D08250000000000000000090909232321\r\n      20765554527F7A7A7A7F7E7E7E7F7F7F7F7F7F7F7F7F7F7F7F7F7B7A7A7F5250\r\n      4F7F1F1F1F730707071E000000000000000096822AF2FAEB96FFF9E992FFF9E9\r\n      92FFF9E992FFF9E992FFF9E992FFFAEB96FF96822AF200000000000000000000\r\n      00000000000000000000000000000000000000000000A7A4A2FFEDEEEDF5F0EF\r\n      F0F5A09D9AFF0000000000000000000000000000000000000000000000000000\r\n      000000000000000000000000000000000000A57248FFF3E197FFF2DF95FFF1DB\r\n      94FFF0D793FFEFD391FFEECE8FFFEDCA8EFFEBC58CFFEAC18BFFE9BC89FFE8B8\r\n      88FFE7B586FFE6B285FF985B38FF150D08250000000000000000000000000101\r\n      010A151515552F2D2C7F4846457F5C5A597F5B59587F4745447F2D2C2B7F1414\r\n      145002020208000000000000000000000000584B188E96822AF296822AF29682\r\n      2AF296822AF296822AF296822AF296822AF2584B188E00000000000000000000\r\n      0000000000000000000000000000000000000000000000000000A6A3A1FFA6A3\r\n      A1FF000000000000000000000000000000000000000000000000000000000000\r\n      000000000000000000000000000000000000925532FFA26C45FFA26C44FFA26B\r\n      44FFA16B44FFA16A44FFA16943FFA16843FFA16843FFA06743FFA06642FFA065\r\n      42FFA06542FFA06442FF8F512FFF030101060000000000000000000000000000\r\n      0000000000000303030C090909260F0F0F3F0F0F0F3E090909240303030B0000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      00000000000000000000000000000000000000000007000000390000003A0000\r\n      003A0000003A0000003A0000003A0000003A0000003500000005000000000000\r\n      00000000000000000000000000000000000002131923065A7786085D7C8B085D\r\n      7C8B085D7C8B085D7C8B085D7C8B085D7C8B085D7C8B085D7C8B085D7C8B085D\r\n      7C8B085D7C8B0542586300000000000000000000000000000000000000000000\r\n      000000000000000000002F2F2F518D8D8DCE5E5E5EE7313131B01B1B1B881B1B\r\n      1B881B1B1B881B1B1B881B1B1B88181818810000000000000000000000230000\r\n      0033000000330000003300000033000000330000003300000033000000330000\r\n      00330000003300000033000000230000000000000039F6F6F5FEF9F9F9FFFBFB\r\n      FBFFFBFBFBFFFCFCFCFFFDFDFDFFFFFFFFFFE9E8E8FE656561C70000000A0000\r\n      0000000000000000000000000000000000000645647A11ACE5FF11ACE5FF11AC\r\n      E5FF11ACE5FF11ACE5FF11ACE5FF11ACE5FF11ACE5FF11ACE5FF11ACE5FF11AC\r\n      E5FF11ACE5FF11ABE4FE01121822000000000000000000000000000000000707\r\n      07120000000000000000696969B0D7D7D7FFB7B7B7FFBFBFBFFFC6C6C6FFCCCC\r\n      CCFFC3C3C3FFBABABAFFB3B3B3FFA7A7A7FF0000000000000000805D1EC0B681\r\n      23FFB57E1FFFB47E1EFFB57E1EFFB9821DFF9F8256FF8C7E72FF8B7B6EFF8A7D\r\n      72FF9C8155FFBB8422FF815D1EC0000000000000003AF7F7F6FFF8F8F8FFFAFA\r\n      FAFFFBFBFBFFFCFCFCFFFDFDFDFFFEFEFEFFF4F4F4FFCCCCCCFF6C6C68D50000\r\n      001200000000000000000000000000000000063F6B8D26B2E7FF1AAFE7FF1AAF\r\n      E7FF1AAFE7FF1AAFE7FF1AAFE7FF1AAFE7FF1AAFE7FF1AAFE7FF1AAFE7FF1AAF\r\n      E7FF1AAFE7FF1AAFE7FF0B455B660000000000000000000000004747477EBDBD\r\n      BDFC878787CD7F7F7FC1C2C2C2FBD6D6D6FF424544FF606362FF3A3B3BFF3334\r\n      34FF383838FF383838FF353535FF2A2A2AFF0000000000000000B68123FFFFFF\r\n      FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF85786DFFFFFFFFFFFFFFFFFFFFFF\r\n      FFFF86786DFFFFFFFFFFB78224FF000000000000003AF6F6F6FFF8F8F8FFFAFA\r\n      FAFFFBFBFBFFFCFCFCFFFDFDFDFFFEFEFEFFFBFBFBFFC4C4C4FFFDFDFDFF6F6F\r\n      6BD50000000A000000000000000000000000034678A06EC5E8FF24B2E9FF24B2\r\n      E9FF24B2E9FF24B2E9FF24B2E9FF24B2E9FF24B2E9FF24B2E9FF24B2E9FF24B2\r\n      E9FF24B2E9FF24B2E9FF17759AA8000000000000000008080814B9B9B9FCC7C7\r\n      C7FFCBCBCBFFD2D2D2FFD7D7D7FFE0E0E0FF4C4F4EFFABACACFFAAABABFF3839\r\n      39FFD2D2D2FFDDDDDDFFA6A6A6FF2B2B2BFF0000000000000000B57E1FFFFFFF\r\n      FFFFE6D6AEFFE6D7B0FFE8D9B2FFEFE0B8FF87796DFFB4A68EFF675448FFA28F\r\n      76FF87796BFFFFFFFFFFB6801FFF000000000000003AF6F6F5FFF7F7F7FFFAFA\r\n      FAFFFBFBFBFFFCFCFCFFFDFDFDFFFEFEFEFFFEFEFEFFE0E0E0FFC6C6C6FFCFCF\r\n      CEFF6A6967C7000000050000000000000000044E88B4ADD1E6FF31B5EAFF2FB5\r\n      EAFF2FB5EAFF2FB5EAFF2FB5EAFF2FB5EAFF2FB5EAFF2FB5EAFF2FB5EAFF2FB5\r\n      EAFF2FB5EAFF2FB5EAFF2AA5D5E9000001010000000000000000787878CCC4C4\r\n      C4FFC6C6C6FFDADADAFFD7D7D7FFD0D0D0FF5A5D5CFFB1B2B2FFA5A7A7FF4041\r\n      41FF323333FF2D2D2DFF2D2D2DFF2B2B2BFF0000000000000000B47D1EFFFFFF\r\n      FFFFE6D6AFFFE7D7B2FFE9DAB4FFF0E1BAFF8A7D71FF6E5A4FFFFFF0C6FF6E5A\r\n      4FFF897B6DFFFFFFFFFFB6801FFF000000000000003AF5F5F4FFF6F6F6FFF9F9\r\n      F9FFFAFAFAFFFBFBFBFFFCFCFCFFFDFDFDFFFEFEFEFFFEFEFEFFFCFCFCFFFAFA\r\n      FAFFEFEEEEFE000000350000000000000000085D9FC8AECDE4FF7BCDEDFF40BB\r\n      EDFF39B8ECFF39B8ECFF39B8ECFF39B8ECFF39B8ECFF39B8ECFF39B8ECFF39B8\r\n      ECFF39B8ECFF39B8ECFF39B8ECFF071B222D0000000000000000727272C4C5C5\r\n      C5FFDEDEDEFFD1D1D1FFCBCBCBFFC9C9C9FF5C5F5EFF737575FF545756FF4F50\r\n      50FF484949FF3F3F3FFF3B3B3BFF353535FF0000000000000000B47D1DFFFFFF\r\n      FFFFE6D5ADFFE6D6AFFFE8D8B2FFF0E0B8FF8A7D70FF6E5A50FFFDEEC4FF6D5A\r\n      4EFF8A7C6EFFFFFFFFFFB6801FFF000000000000003AF4F4F4FFF5F5F5FFF7F7\r\n      F7FFFAFAFAFFFAFAFAFFFBFBFBFFFCFCFCFFFDFDFDFFFDFDFDFFFEFEFEFFFEFE\r\n      FEFFFEFEFEFF0000003A00000000000000001070B7DC97C3E4FFD6E3E6FF8BBF\r\n      C2FF8ECADEFF94D0E6FF95D1E7FF83C7DEFF5FC8F1FF43BBEEFF43BBEEFF43BB\r\n      EEFF43BBEEFF43BBEEFF43BBEEFF1D51676F2F2F2F576E6E6EBAB1B1B1FBCBCB\r\n      CBFFDEDEDEFFCACACAFFB8B8B8F8636363A5B6B6B6FFBDBDBDFFC4C4C4FFCDCD\r\n      CDFFD4D4D4FFCCCCCCFFC2C2C2FFB7B7B7FF0000000000000000B47D1DFFFFFF\r\n      FFFFF8F4E7FFF8F4E8FFF9F5EAFFFFFCF0FF86776AFF6A564AFFFFFFFCFF6854\r\n      47FF87796BFFFFFFFFFFB6801FFF000000000000003AF4F4F3FFF4F4F3FFF6F6\r\n      F6FFF8F8F8FFFAFAFAFFFBFBFBFFFBFBFBFFFCFCFCFFFCFCFCFFFDFDFDFFFDFD\r\n      FDFFFDFDFDFF0000003A00000000000000001884D0EE82BCE7FFECEBEAFFE5DE\r\n      D0FFD4CFC7FFD7D0C8FFDAD1C9FFCCC3B8FFB9CACEFF64C8F2FF4DBEEFFF4DBE\r\n      EFFF4DBEEFFF4DBEEFFF4DBEEFFF3584A5B1717171CAC2C2C2FFC8C8C8FFD8D8\r\n      D8FFD2D2D2FFCECECEFF5D5D5DA0000000001D1D1D844B4B4BD57A7A7AFF7A7A\r\n      7AFF838383FF7D7D7DFF7A7A7AFF555555E70000000000000000B47D1DFFFFFF\r\n      FFFFF4EDDDFFF4EDDDFFF5EEDFFFF8F2E2FFFFFCECFF847568FFFFFDEDFFFFFF\r\n      EEFF837466FFFFFFFFFFB6801FFF000000000000003AF2F2F2FFF2F2F2FFF4F4\r\n      F4FFF6F6F6FFF8F8F8FFFAFAFAFFFAFAFAFFFBFBFBFFFBFBFBFFFCFCFCFFFCFC\r\n      FCFFFCFCFCFF0000003A00000000000000001658849272AAD2E4EDEDEDFFEDED\r\n      EDFFE5E2DEFFE3DEDAFFE0DBD6FFDFDAD6FFDFDBD7FFA0C3D2EA6BCBF3FE60C6\r\n      F3FF5FC5F2FF5FC5F2FF5FC5F2FF5DB7DEE9747474C9C8C8C8FFCECECEFFD6D6\r\n      D6FFD0D0D0FFD1D1D1FF636363A70000000000000000686868A9D5D5D5FFCACA\r\n      CAFFCDCDCDFFD2D2D2FFCECECEFF797979CD0000000000000000B47D1DFFFFFF\r\n      FFFFF3EAD6FFF3EAD7FFF3EAD7FFF5ECD9FFFBF3DFFF817265FFFFF9E5FFFFFA\r\n      E5FF817163FFFFFFFFFFB57E1FFF000000000000003AF1F1F0FFF1F1F0FFF3F3\r\n      F2FFF5F5F4FFF6F6F6FFF8F8F8FFF9F9F9FFFAFAFAFFFAFAFAFF95DF95FF22C4\r\n      22FF09AF09FF009F00E3004A006600000000000000000000020319191920ECEC\r\n      ECFEE2E2E2F4AEADABC180807F8B474C4A55161C1923000000001D3A494F4481\r\n      9CA44786A4AB4786A4AB4786A4AB254E5F6532323259737373BABBBBBBFAD6D6\r\n      D6FFC8C8C8FFD3D3D3FFBDBDBDF96A6A6AAD6B6B6BAEBCBCBCF8D6D6D6FFC9C9\r\n      C9FFCBCBCBFFB9B9B9FB797979BD3333335C0000000000000000B47D1DFFFFFF\r\n      FFFFF1E6CEFFF1E7CFFFF1E7D0FFF2E8D0FFF6ECD4FFAEA190FF807063FF7E70\r\n      63FFAB9F8DFFFFFFFFFFB57E1EFF000000000000003AEFEFEEFFEFEFEEFFF1F1\r\n      F0FFF3F3F2FFF4F4F4FFF6F6F6FFF7F7F7FFF8F8F8FF95DD95FF01AD01FF00A3\r\n      19FFFFFFFFFF00B035FF00AB02FD004700660000000000000000000000001818\r\n      182302020203000000000000000000000000219459C60F44285F000000010000\r\n      0000000000000000000000000000000000000000000000000000757575C2DBDB\r\n      DBFFCBCBCBFFCFCFCFFFDDDDDDFFDCDCDCFFDBDBDBFFDADADAFFCCCCCCFFCDCD\r\n      CDFFD8D8D8FF787878C600000000000000000000000000000000B47D1DFFFFFF\r\n      FFFFEEE3C8FFEFE4C9FFEFE4CAFFEFE4CAFFF0E5CAFFFBF5E6FFFFFFFFFFFFFF\r\n      FFFFFFFFFFFFFFFFFFFFB57E1EFF000000000000003AEEEEEDFFEDEDEDFFEFEF\r\n      EEFFF1F1F0FFF2F2F2FFF4F4F3FFF5F5F5FFF6F6F6FF20B420FF00A002FF00A0\r\n      33FFFFFFFFFF00B063FF00AF31FF009100DC000000000000000000000000030C\r\n      090E0000000000000000000000000106030A199B64C125C77CFF20965AC7071F\r\n      122E000000000000000000000000000000000000000000000000848484CFE2E2\r\n      E2FFE8E8E8FFC7C7C7FFB8B8B8FFC9C9C9FFC8C8C8FFB8B8B8FFC6C6C6FFE6E6\r\n      E6FFE3E3E3FF888888D200000000000000000000000000000000B47D1DFFFFFF\r\n      FFFFECE0C1FFEDE1C3FFEDE1C4FFEDE1C3FFECDFC1FFFFFFFFFFD1AE70FFAE73\r\n      0AFFAD7006FFFFFFFFFFB58021FF000000000000003AECECEBFFECECEBFFEDED\r\n      ECFFEFEFEEFFF0F0EFFFF1F1F1FFF2F2F2FFF3F3F3FF089508FFFFFFFFFFFFFF\r\n      FFFFFFFFFFFFFFFFFFFFFFFFFFFF008E00F60000000000000000000000000319\r\n      12231082599910895C9F14A46FC018D08DF41BD790FF1DD38BFF21CE85FF2372\r\n      4D8C000000000000000000000000000000000000000007070711CECECEFCE8E8\r\n      E8FFEAEAEAFFECECECFFE8E8E8FFD5D5D5FFD5D5D5FFE9E9E9FFECECECFFEBEB\r\n      EBFFEAEAEAFFCFCFCFFC07070711000000000000000000000000B47D1DFFFFFF\r\n      FFFFEADCB9FFEADDBCFFEBDDBDFFEADDBCFFE9DCB9FFFFFFFFFFAD7109FFFDFC\r\n      F6FFFFFFFFFFEBDCC3FF7A581AAC000000000000003AEAE9E8FFE9E9E8FFEBEB\r\n      EAFFEDEDECFFEEEEEDFFEFEFEEFFF0F0EFFFF1F1F0FF20A620FF1CB61CFF28B4\r\n      3EFFFFFFFFFF28BC59FF1CBC32FF008600DC0000000000000000000000000000\r\n      0000093C2A481FC789E719DB94FF19DB94FF1BDB95FF19DA93FF29C78AE7020C\r\n      07110000000000000000000000000000000000000000000000004D4D4D81D5D5\r\n      D5FC939393CC929292C7D5D5D5FAF3F3F3FFF3F3F3FFD5D5D5FB8D8D8DC59C9C\r\n      9CD0D9D9D9FC5252528600000000000000000000000000000000B57E1EFFFFFF\r\n      FFFFE7D8B1FFE7D8B2FFE7D9B3FFE7D8B2FFE7D8B0FFFFFFFFFFAC7006FFFFFF\r\n      FFFFEADABFFF775214A700000000000000000000003AEAEAEAFFE9E9E8FFEBEB\r\n      EAFFEDEDECFFEEEEEDFFEFEFEEFFF0F0EFFFF1F1F0FF8FCF8FFF35BF35FF77D5\r\n      77FFFFFFFFFF77D579FF34BE34FD003F00670000000000000000000000000000\r\n      000000000000000402070A2C1F3E0F37284D0722182C1ABD81DB134C36570000\r\n      0000000000000000000000000000000000000000000000000000000000000A0A\r\n      0A180000000000000000717171B3F9F9F9FFF9F9F9FF757575B7000000000000\r\n      00000A0A0A180000000000000000000000000000000000000000B68123FFFFFF\r\n      FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFEBDC\r\n      C3FF765314A6000000000000000000000000000000100000003A0000003A0000\r\n      003A0000003A0000003A0000003A0000003A0000003A0000003A003D00882498\r\n      24E758BE58F9259625E200410068000000000000000000000000000000000000\r\n      000000000000000000000000000000000000000000000D392841000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      00000000000000000000343434599A9A9AD69A9A9AD63838385E000000000000\r\n      0000000000000000000000000000000000000000000000000000AD7F2AEFB681\r\n      23FFB57E1EFFB47D1DFFB47D1DFFB47D1DFFB47D1DFFB47E1EFFB58021FFA878\r\n      23EA00000000000000000000000000000000424D3E000000000000003E000000\r\n      2800000040000000700000000100010000000000800300000000000000000000\r\n      000000000000000000000000FFFFFF00FFFFFFFF000000008003800700000000\r\n      8001800100000000800080010000000080008001000000008000800100000000\r\n      8001800100000000800180010000000080018001000000008001800100000000\r\n      8001800000000000800180000000000080018000000000008001800100000000\r\n      8007800300000000FFFFFFFF00000000FFFFFFFFFFFFD00FFFFFFFFFFFFF0000\r\n      FFFFFFFFFFFF0000FFE7FFFFFFFF0000FFC3FFFFFFFF0000FFC3FFF1F8390000\r\n      FFDFFE6000000000FF1F000000000000FC1F0000E0090000FE0FFE60F01F0000\r\n      DC0FFFF1F81F0000C00FFFFFFFFF0000C07FFFFFFFFF0000C0FFFFFFFFFF0000\r\n      FFFFFFFFFFFF0000FFFFFFFFFFFF00000007FF3FC00FE3C1000700018003E180\r\n      000100018001E080000000008000C00000000000800080000000000080000000\r\n      0000000000000000000000000000000100010001000000010000000000000001\r\n      0000000000000001000100010000000100030001000000010007000180000001\r\n      001F000180008003003F0001C001C007F007F001FC7FFFFFC003C000FC3FFE1F\r\n      800180000001F81F800080000001F01F000000000001C0010000000000018001\r\n      0000000000018001000100010000800100010001000080010001000100008001\r\n      000100010001C001000100010001C001800380030001F01F800380030001F81F\r\n      C007C0070001FE1FF01FF01F0001FFFFFF998000E003F81F00000000E001E007\r\n      000000000000C003000000000000800100000000000080010000000000000000\r\n      0000800000000000000080010000000000008001000000000000800100000000\r\n      0000800100000000000000010000800100000003000080010001003F0000C003\r\n      0001803F000FE007FFFFC0FF000FF81FF807FFC7F81F007FF0030000E007007F\r\n      E0010000C003000FC000000080010007C000000080010F03C000000000000001\r\n      C001000000000001C001000000000001C001000000000001C001000000000803\r\n      8001000000000F07000300008001000F000700008001001F000F0000C003007F\r\n      87FF0000E007007FCFFF0000F81FFFFF003F0000FC00C001001F0000EC00C001\r\n      000F0000C000C001000700008000C00100030000C000C00100030000C000C001\r\n      000300000000C001000300000100C001000300000180C001000100000000C001\r\n      00000000C003C00100000000C003C001000000008001C00100000000C003C003\r\n      00000000EC37C00700010000FC3FC00F00000000000000000000000000000000\r\n      000000000000}\r\n  end\r\n  object imlMain: TJvImageList\r\n    ColorDepth = cd32Bit\r\n    Mode = imClassic\r\n    PixelFormat = pf32bit\r\n    TransparentMode = tmAuto\r\n    Items = <>\r\n    Height = 32\r\n    Width = 32\r\n    Left = 160\r\n    Top = 32\r\n    Bitmap = {\r\n      494C01011A001D00040020002000FFFFFFFF2110FFFFFFFFFFFFFFFF424D3600\r\n      000000000000360000002800000080000000E0000000010020000000000000C0\r\n      0100000000000000000000000000000000000000000000000001000000020000\r\n      0002000000020000000200000002000000020000000200000002000000020000\r\n      0002000000020000000200000002000000020000000200000002000000020000\r\n      0002000000020000000200000002000000020000000200000002000000000000\r\n      0000000000000000000000000000000000000000000000000002000000050000\r\n      0006000000060000000600000006000000060000000600000006000000060000\r\n      0006000000060000000600000006000000060000000600000006000000060000\r\n      0006000000060000000600000006000000060000000600000005000000020000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000303030319191919381E1E\r\n      1E3C1E1E1E3C1E1E1E3C1E1E1E3C1E1E1E3C1E1E1E3C1E1E1E3C1E1E1E3C1E1E\r\n      1E3C1E1E1E3C1E1E1E3C1E1E1E3C1E1E1E3C1E1E1E3C1E1E1E3C1E1E1E3C1E1E\r\n      1E3C1E1E1E3C1E1E1E3C1E1E1E3C1E1E1E3C1E1E1E3C1A1A1A340303030E0000\r\n      000000000000000000000000000000000000000000020202021B1A1A1A441D1D\r\n      1D4B1D1D1D4B1D1D1D4B1D1D1D4B1D1D1D4B1D1D1D4B1D1D1D4B1D1D1D4B1D1D\r\n      1D4B1D1D1D4B1D1D1D4B1D1D1D4B1D1D1D4B1D1D1D4B1D1D1D4B1D1D1D4B1D1D\r\n      1D4B1D1D1D4B1D1D1D4B1D1D1D4B1D1D1D4B1D1D1D4B1A1A1A450202021C0000\r\n      0002000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000B1818184CC3C3C3D9DADA\r\n      DAEBDBDBDBEBDCDCDCEBDCDCDCEBDDDDDDEBDDDDDDEBDEDEDEEBDEDEDEEBDFDF\r\n      DFEBDFDFDFEBDFDFDFEBDFDFDFEBDFDFDFEBDFDFDFEBDEDEDEEBDEDEDEEBDDDD\r\n      DDEBDDDDDDEBDCDCDCEBDCDCDCEBDCDCDCEBDBDBDBEBC6C6C6D71A1A1A340000\r\n      0002000000000000000000000000000000000000000517171742C3C3C3DADADA\r\n      DAEDDBDBDBEDDCDCDCEDDCDCDCEDDDDDDDEDDDDDDDEDDEDEDEEDDEDEDEEDDEDE\r\n      DEEDDFDFDFEDDFDFDFEDDFDFDFEDDFDFDFEDDEDEDEEDDEDEDEEDDEDEDEEDDDDD\r\n      DDEDDDDDDDEDDCDCDCEDDCDCDCEDDBDBDBEDDBDBDBEDC6C6C6DC191919450000\r\n      0005000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000D19191957D6D6D6ECEEEE\r\n      EEFFEFEFEFFFF0F0EFFFF1F1F0FFF2F2F1FFF2F2F2FFF3F3F3FFF4F4F4FFF5F5\r\n      F4FFF5F5F5FFF6F6F5FFF6F6F5FFF5F5F5FFF5F5F5FFF4F4F4FFF4F4F3FFF3F3\r\n      F2FFF2F2F2FFF1F1F1FFF0F0F0FFEFEFEFFFEEEEEEFFDADADAEB1C1C1C3B0000\r\n      0002000000000000000000000000000000000000000619191948D7D7D7EBEEEE\r\n      EEFFEFEFEFFFF0F0F0FFF1F1F1FFF2F2F2FFF3F3F3FFF4F4F4FFF5F5F5FFF5F5\r\n      F5FFF6F6F6FFF6F6F6FFF6F6F6FFF6F6F6FFF5F5F5FFF5F5F5FFF4F4F4FFF3F3\r\n      F3FFF2F2F2FFF1F1F1FFF0F0F0FFEFEFEFFFEFEFEFFFDADADAED1D1D1D4B0000\r\n      0006000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000D1A1A1A58D6D6D6ECEEEE\r\n      EEFFD3CBC5FFCDC3BBFFCDC4BCFFCEC4BCFFCEC5BDFFCEC5BDFFCEC5BDFFCFC5\r\n      BEFFCFC6BEFFCFC6BEFFCFC6BEFFCFC6BEFFCFC5BEFFCFC5BDFFCEC5BDFFCEC5\r\n      BDFFCEC4BDFFCDC4BCFFCDC3BBFFD3CAC4FFEEEEEEFFD8D5D3EC211D1A420000\r\n      0003000000000000000000000000000000000000000619191948D7D7D7EBEEEE\r\n      EEFFE4E1DFFFE2DFDDFFE3E0DDFFE3E1DEFFE4E1DEFFE4E1DEFFE4E1DFFFE5E2\r\n      DFFFE5E2DFFFE5E2DFFFE5E2DFFFE5E2DFFFE5E2DFFFE4E1DFFFE4E1DEFFE4E1\r\n      DEFFE4E1DEFFE3E0DDFFE2E0DDFFE4E1DFFFEDE9E7FFD7D1CBEE2A231D5A0704\r\n      0110000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000D1A1A1A58D7D7D7ECEFEF\r\n      EFFFD2CAC4FFD1C9C3FFCCC4BEFFCCC4BEFFD3CBC4FFCDC5BFFFCDC5BFFFCDC5\r\n      BFFFCDC5C0FFD3CBC5FFCEC6C0FFCDC5BFFFCDC5BFFFCDC5BFFFCDC5BFFFD3CB\r\n      C4FFD3CBC5FFD3CBC4FFD3CAC4FFD2CAC3FFE1D7CDFFAA784AFC6D3B0CC31409\r\n      0026000000000000000000000000000000000000000619191948D8D8D8EBEFEF\r\n      EFFFDDD8D4FFDCD8D4FFD7D2CFFFD7D2CEFFDED9D5FFD8D3CFFFD8D3CFFFD8D3\r\n      D0FFD9D4D0FFDED9D6FFD9D4D0FFD8D3D0FFD8D3D0FFD8D3CFFFD8D3CFFFDED9\r\n      D5FFDFDAD6FFDED9D5FFDDD9D5FFDDD8D4FFCD9565FFC57F44FDB66E34F08349\r\n      19B3010000010000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000D1A1A1A58D7D7D7ECEFEF\r\n      EFFFD8D1CCFFD3CCC8FFABA6A1FFA5A09CFFD4CEC9FFAAA5A1FFA5A19DFFA5A1\r\n      9DFFAAA5A1FFD0CAC6FFACA8A3FFA6A19DFFA6A19DFFA5A19DFFA9A4A1FFD5CE\r\n      CAFFD9D3CEFFD9D2CDFFD8D2CDFFCFC0B4FFA7703DFFCAA582FFCAA583FE7840\r\n      0FCE120900200000000000000000000000000000000619191948D8D8D8EBEFEF\r\n      EFFFD7D1CCFFD2CCC7FFAAA6A1FFA5A19CFFD4CEC9FFAAA5A1FFA5A19DFFA5A1\r\n      9DFFAAA5A1FFD0CAC5FFACA8A3FFA6A19EFFA6A19DFFA5A19DFFA9A4A0FFD4CE\r\n      C9FFD9D3CDFFD9D2CDFFD8D2CCFFD7D1CCFFC47A3DFFF2C4A3FFF2C5A5FFBE6F\r\n      2EFE020000030000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000D1A1A1A58D7D7D7ECEFEF\r\n      EFFFDDD8D4FFDDD8D4FFDAD5D1FFD9D5D1FFDED9D5FFDAD6D2FFDAD6D2FFDBD6\r\n      D2FFDCD7D3FFE0DBD7FFDCD7D3FFDBD7D3FFDBD6D2FFDAD6D2FFDBD6D2FFDEDA\r\n      D6FFDFDAD6FFDEDAD6FFD4C8BCFFA36935FFCDA784FFECD6C3FFEBD5C3FECCA7\r\n      85FE733B07C91209002000000000000000000000000619191948D8D8D8EBEFEF\r\n      EFFFD2CBC4FFD2CAC4FFCFC7C0FFCFC7C0FFD3CBC5FFD0C8C1FFD0C7C1FFD0C8\r\n      C1FFD1C9C3FFD5CDC6FFD1C9C3FFD1C8C2FFD0C8C2FFD0C7C1FFD0C8C1FFD3CB\r\n      C5FFD4CCC5FFD4CBC5FFD3CBC4FFD2CAC4FFC37A3DFFF5C7A6FFF5CAACFFBC6F\r\n      2EFE020000030000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000D1A1A1A58D7D7D7ECEFEF\r\n      EFFFE6E3E1FFE4E1DFFFE5E2E0FFE5E2E0FFE6E2E0FFE6E3E1FFE7E3E1FFE8E4\r\n      E2FFE8E4E2FFE8E4E2FFE8E4E2FFE8E4E2FFE8E4E2FFE7E4E1FFE7E3E1FFE6E3\r\n      E0FFE5E2E0FFD9CCC1FFA96F3BFFCDA682FFEBD2BCFFEBD2BCFFEBD2BCFFEBD2\r\n      BCFFCCA582FE7A4210CE14090024000000000000000619191948D8D8D8EBEFEF\r\n      EFFFD5CEC8FFD1C7C1FFD1C8C1FFD2C9C2FFD2C9C2FFD3C9C3FFD3CAC3FFD4CA\r\n      C4FFD4CBC4FFD4CBC4FFD4CBC4FFD4CBC4FFD4CBC4FFD3CAC3FFD3CAC3FFD2C9\r\n      C2FFD2C9C2FFD2C8C1FFD1C8C1FFD5CEC7FFC1793DFFF1C29FFFF2C5A4FFBA6D\r\n      2CFE020000030000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000D1A1A1A58D7D7D7ECF0F0\r\n      F0FFF0F0F0FFF1F1F1FFF2F2F2FFF3F3F3FFF4F4F4FFF5F5F5FFF6F6F6FFF7F7\r\n      F7FFF8F8F8FFF8F8F8FFF8F8F8FFF8F8F8FFF7F7F7FFF7F6F6FFF6F5F5FFF5F5\r\n      F4FFE7DCD3FFB07846FFCBA27BFFE8CDB4FFE8CDB4FFE8CDB4FFE9CDB4FFE9CD\r\n      B5FFE7CCB3FEC9A17BFE794211C9150900240000000619191948D8D8D8EBF0F0\r\n      F0FFEFEFEEFFEFEEEEFFF0EFEFFFF1F1F0FFF2F2F1FFF3F3F2FFF4F4F3FFF5F5\r\n      F4FFF6F5F4FFF6F5F5FFF6F5F5FFF6F5F4FFF5F5F4FFF5F4F3FFF4F3F2FFF3F2\r\n      F1FFF2F1F0FFF1F0EFFFEFEFEEFFF0EFEFFFC0793DFFEEBD98FFEFC19EFFB86B\r\n      2AFE020000030000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000D1A1A1A58D7D7D7ECF0F0\r\n      F0FFF1F1F1FFF1F1F1FFEDEDEDFFEEEEEEFFEFEFEFFFF0F0F0FFF2F2F2FFF8F8\r\n      F8FFF3F3F3FFF3F3F3FFF3F3F3FFF3F3F3FFF8F8F8FFF2F2F2FFF1F1F1FFF5F5\r\n      F5FFB47E4EFFC99D74FFE4C7ABFFE5C7ABFFE5C8ACFFE7CAAEFFE7CAAEFFE5C8\r\n      ACFFE4C7ABFFE4C6ABFFC69B74FE743D0DC10000000619191948D8D8D8EBF0F0\r\n      F0FFF1F1F1FFF1F1F1FFEDEDEDFFEEEEEEFFEFEFEFFFF0F0F0FFF2F2F2FFF8F8\r\n      F8FFF3F3F3FFF3F3F3FFF3F3F3FFF3F3F3FFF8F8F8FFF2F2F2FFF1F1F1FFF5F5\r\n      F5FFF5F5F5FFF4F4F4FFF3F3F3FFF2F2F2FFBE783CFFEAB890FFECBC98FFB569\r\n      28FE020000030000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000D1A1A1A58D8D8D8ECF0F0\r\n      F0FFF1F1F1FFEBEBEBFFB9B9B9FFB3B3B3FFB3B3B3FFB4B4B4FFBABABAFFF4F4\r\n      F4FFB7B7B7FFB7B7B7FFB7B7B7FFB6B6B6FFF3F3F3FFBCBCBCFFBABABAFFF1F1\r\n      F1FFB98758FFA9672CFFA9672CFFA8662CFFB17540FFE4C4A7FFE4C4A8FFB075\r\n      3FFFA16126FBA16126FBA05F25FA6C380AB50000000619191948D8D8D8EBF0F0\r\n      F0FFF1F1F1FFEBEBEBFFB9B9B9FFB3B3B3FFB3B3B3FFB4B4B4FFBABABAFFF4F4\r\n      F4FFB7B7B7FFB7B7B7FFB7B7B7FFB6B6B6FFF3F3F3FFBCBCBCFFBABABAFFF1F1\r\n      F1FFF5F5F5FFF4F4F4FFF3F3F3FFF2F2F2FFBD773CFFE7B389FFE9B891FFB368\r\n      26FE020000030000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000D1A1A1A58D8D8D8ECF0F0\r\n      F0FFF1F1F1FFF3F3F3FFF4F4F4FFF5F5F5FFF6F6F6FFF7F7F7FFF9F9F9FFFAFA\r\n      FAFFFBFBFBFFFBFBFBFFFBFBFBFFFBFBFBFFFAFAFAFFF9F9F9FFF8F8F8FFF7F7\r\n      F7FFF5F5F5FFF4F4F4FFF3F3F3FFF2F2F2FFA9662BFFE2C0A1FFE3C0A2FFA664\r\n      27FE020000030000000000000000000000000000000619191948D8D8D8EBF0F0\r\n      F0FFF1F1F1FFF3F3F3FFF4F4F4FFF5F5F5FFF6F6F6FFF7F7F7FFF9F9F9FFFAFA\r\n      FAFFFBFBFBFFFBFBFBFFFBFBFBFFFBFBFBFFFAFAFAFFF9F9F9FFF8F8F8FFF7F7\r\n      F7FFF5F5F5FFF4F4F4FFF3F3F3FFF2F2F2FFBB763BFFE4AE82FFE5B38BFFB166\r\n      24FE020000030000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000D1A1A1A58D8D8D8ECF0F0\r\n      F0FFEFEEEEFFEEEDECFFEFEEEDFFF0EFEEFFF1F0EFFFF3F2F0FFF4F3F2FFF5F4\r\n      F3FFF6F5F3FFF7F5F4FFF7F5F4FFF6F5F4FFF5F4F3FFF4F3F2FFF3F2F1FFF2F1\r\n      EFFFF1EFEEFFEFEEEDFFEEEDECFFEFEEEEFFAB672CFFE2BD9DFFE2BE9EFFA864\r\n      28FE020000030000000000000000000000000000000619191948D8D8D8EBF0F0\r\n      F0FFF1F0F0FFF1F1F1FFF2F2F2FFF3F3F3FFF4F4F4FFF6F6F5FFF7F7F6FFF8F8\r\n      F7FFF9F9F8FFFAF9F9FFFAF9F9FFF9F9F9FFF8F8F8FFF7F7F6FFF6F6F6FFF5F5\r\n      F4FFF4F3F3FFF2F2F2FFF2F1F1FFF1F1F0FFBA763CFFE2B085FFE4B48CFFAF64\r\n      23FE020000030000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000D1A1A1A58D8D8D8ECF0F0\r\n      F0FFD6CFC9FFD2C9C2FFD3CAC3FFD3CAC3FFD4CBC4FFD4CBC5FFD5CCC6FFD5CC\r\n      C6FFD6CDC7FFD6CDC7FFD7CDC7FFD6CDC7FFD5CDC6FFD5CCC6FFD5CCC5FFD4CB\r\n      C4FFD3CAC4FFD3CAC3FFD2C9C3FFD6CEC9FFAC682CFFE2BB99FFE2BC9AFFA965\r\n      28FE020000030000000000000000000000000000000619191948D8D8D8EBF0F0\r\n      F0FFE6E3E1FFE5E2DFFFE5E3E0FFE6E3E0FFE7E4E1FFE7E4E2FFE8E5E2FFE8E5\r\n      E2FFE9E6E3FFE9E6E3FFE9E6E3FFE9E6E3FFE8E5E3FFE8E5E2FFE7E5E2FFE7E4\r\n      E1FFE6E3E0FFE5E3E0FFE5E2E0FFE6E3E1FFB8753CFFE2B38BFFE4B994FFAD63\r\n      22FE020000030000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000D1A1A1A58D8D8D8ECF0F0\r\n      F0FFD3CBC5FFD3CBC4FFD2CBC4FFD2CBC4FFD4CCC6FFD4CCC5FFD4CDC6FFD4CD\r\n      C6FFD5CEC7FFD7CFC8FFD6CEC8FFD5CEC7FFD5CDC6FFD4CDC6FFD4CCC6FFD4CC\r\n      C6FFD4CCC5FFD3CBC5FFD3CBC5FFD2CBC4FFAD682CFFE1B996FFE2BA97FFAB66\r\n      29FE020000030000000000000000000000000000000619191948D8D8D8EBF0F0\r\n      F0FFDEDAD6FFDED9D5FFDED9D5FFDED9D5FFE0DBD7FFDFDBD7FFE0DBD7FFE0DB\r\n      D7FFE1DCD8FFE2DDD9FFE2DDD9FFE1DCD8FFE0DCD8FFE0DBD7FFE0DBD7FFE0DB\r\n      D7FFDFDBD7FFDFDAD6FFDFDAD6FFDED9D5FFB7753CFFE1B38CFFE3B995FFAB61\r\n      21FE020000030000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000D1A1A1A58D8D8D8ECF0F0\r\n      F0FFD9D3CEFFD3CCC8FFA5A09CFF9E9996FFD5CECAFFA4A09CFFA09B97FFA09B\r\n      97FFA5A09DFFD1CBC6FFA8A39FFFA19C98FFA09B98FFA09B97FFA49F9CFFD5CF\r\n      CAFFDAD4CFFFD9D3CEFFD9D3CEFFD8D2CDFFB06A2DFFE2B893FFE2B994FFAD67\r\n      29FE020000030000000000000000000000000000000619191948D8D8D8EBF0F0\r\n      F0FFD8D2CDFFD2CCC7FFA5A09BFF9E9995FFD4CEC9FFA4A09CFF9F9A97FF9F9A\r\n      97FFA5A09CFFD0CAC6FFA7A29FFFA09B97FF9F9B97FF9F9A97FFA39F9BFFD4CF\r\n      CAFFD9D3CEFFD9D3CEFFD8D2CEFFD8D1CDFFB5743CFFE1B58EFFE3BA97FFA960\r\n      20FE020000030000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000D1A1A1A58D8D8D8ECF0F0\r\n      F0FFDED9D6FFDED9D5FFDAD6D2FFDAD5D2FFDFDAD7FFDCD7D3FFDCD7D3FFDCD7\r\n      D4FFDDD9D5FFE1DCD8FFDED9D6FFDCD8D4FFDCD8D4FFDCD7D3FFDCD7D4FFDFDA\r\n      D7FFDFDAD7FFDFDAD6FFDEDAD6FFDDD9D5FFB16B2DFFE2B791FFE3B892FFAE68\r\n      2AFE020000030000000000000000000000000000000619191948D8D8D8EBF0F0\r\n      F0FFD3CBC5FFD2CAC4FFCFC7C1FFCFC7C1FFD4CCC5FFD0C9C2FFD1C9C2FFD1C9\r\n      C3FFD2CAC4FFD6CEC7FFD3CBC4FFD1CAC3FFD1C9C3FFD1C9C2FFD1C9C2FFD4CC\r\n      C6FFD4CCC5FFD3CCC5FFD3CBC5FFD3CBC4FFB4743CFFE0B690FFE2BB99FFA75F\r\n      1FFE020000030000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000D1A1A1A58D8D8D8ECF0F0\r\n      F0FFE6E4E2FFE5E2E0FFE5E2E0FFE5E3E0FFE6E3E1FFE7E4E2FFE7E5E3FFE7E5\r\n      E3FFE8E6E4FFE9E6E4FFE9E6E4FFE8E6E4FFE8E5E3FFE7E5E3FFE7E4E2FFE6E3\r\n      E2FFE6E3E1FFE5E3E0FFE5E2E0FFE6E3E2FFB36C2EFFE3B690FFE4B791FFB069\r\n      2BFE020000030000000000000000000000000000000619191948D8D8D8EBF0F0\r\n      F0FFD6CFC9FFD1C8C1FFD2C9C2FFD2C9C2FFD3CAC3FFD4CBC4FFD4CBC4FFD4CC\r\n      C4FFD5CDC5FFD5CDC5FFD5CDC6FFD5CDC5FFD5CCC5FFD4CBC4FFD4CBC4FFD3CA\r\n      C3FFD2CAC2FFD2C9C2FFD2C9C1FFD6CEC9FFB3743DFFE0B894FFE2BD9CFFA55E\r\n      1EFE020000030000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000D1A1A1A58D8D8D8ECF0F0\r\n      F0FFF1F0F0FFF2F1F1FFF3F3F2FFF4F4F3FFF5F5F5FFF6F6F6FFF7F7F7FFF8F8\r\n      F8FFF9F9F9FFFAFAFAFFFAFAFAFFFAFAF9FFF9F9F8FFF7F7F7FFF7F6F6FFF5F5\r\n      F5FFF4F4F4FFF3F3F3FFF2F2F2FFF1F1F1FFB56D2FFFE4B38AFFE3B188FFB269\r\n      2BFE020000030000000000000000000000000000000619191948D8D8D8EBF0F0\r\n      F0FFEFEFEFFFF0EFEEFFF1F0EFFFF2F1F0FFF3F2F1FFF4F4F3FFF5F5F4FFF6F6\r\n      F5FFF7F7F6FFF8F7F7FFF8F7F7FFF8F7F6FFF7F6F5FFF5F5F4FFF5F4F3FFF3F2\r\n      F2FFF2F1F1FFF1F0EFFFF0EFEEFFF0EFEFFFB3753FFFE0BA98FFE2BFA0FFA35C\r\n      1DFE020000030000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000D1A1A1A58D8D8D8ECF0F0\r\n      F0FFF1F1F1FFF2F2F2FFEEEEEEFFEFEFEFFFF0F0F0FFF1F1F1FFF3F3F3FFF9F9\r\n      F9FFF4F4F4FFF5F5F5FFF5F5F5FFF4F4F4FFF9F9F9FFF3F3F3FFF2F2F2FFF6F6\r\n      F6FFF5F5F5FFF4F4F4FFF3F3F3FFF2F2F2FFB76D30FFE5B188FFE6B288FFB46B\r\n      2CFE020000030000000000000000000000000000000619191948D8D8D8EBF0F0\r\n      F0FFF1F1F1FFF2F2F2FFEEEEEEFFEFEFEFFFF0F0F0FFF1F1F1FFF3F3F3FFF9F9\r\n      F9FFF4F4F4FFF5F5F5FFF5F5F5FFF4F4F4FFF9F9F9FFF3F3F3FFF2F2F2FFF6F6\r\n      F6FFF2EFECFFECE6E0FFEBE5DFFFEAE4DEFFB2753FFFE1BD9CFFE2C1A4FFA15B\r\n      1CFE0F0800190C0500150C050015050200090000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000D1A1A1A58D8D8D8ECF0F0\r\n      F0FFF1F1F1FFECECECFFBFBFBFFFBABABAFFBABABAFFBBBBBBFFC1C1C1FFF4F4\r\n      F4FFBEBEBEFFBEBEBEFFBEBEBEFFBEBEBEFFF4F4F4FFC2C2C2FFC0C0C0FFF1F1\r\n      F1FFF5F5F5FFF4F4F4FFF3F3F3FFF2F2F2FFB96F31FFE8B68EFFE9B78FFFB66C\r\n      2DFE020000030000000000000000000000000000000619191948D8D8D8EBF0F0\r\n      F0FFF1F1F1FFECECECFFBFBFBFFFBABABAFFBABABAFFBBBBBBFFC1C1C1FFF4F4\r\n      F4FFBEBEBEFFBEBEBEFFBEBEBEFFBEBEBEFFF4F4F4FFC2C2C2FFC0C0C0FFF1F1\r\n      F1FFBB895CFFAC6B33FFAC6C34FFAB6C33FFB7804DFFE2C1A2FFE4C5A9FFA96A\r\n      31FE965720EB965720EB93551CEA683406B00000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000D1A1A1A58D7D7D7ECF0F0\r\n      F0FFF1F1F1FFF1F1F1FFEDEDEDFFEDEDEDFFEEEEEEFFEFEFEFFFF1F1F1FFF8F8\r\n      F8FFF2F2F2FFF2F2F2FFF2F2F2FFF2F2F2FFF8F8F8FFF1F1F1FFF0F0F0FFF5F5\r\n      F5FFF5F5F5FFF4F4F4FFF3F3F3FFF2F2F2FFBB7032FFEBBA95FFECBB96FFB76D\r\n      2EFE020000030000000000000000000000000000000619191948D8D8D8EBF0F0\r\n      F0FFF1F1F1FFF1F1F1FFEDEDEDFFEDEDEDFFEEEEEEFFEFEFEFFFF1F1F1FFF8F8\r\n      F8FFF2F2F2FFF2F2F2FFF2F2F2FFF2F2F2FFF8F8F8FFF1F1F1FFF0F0F0FFF5F5\r\n      F5FFBD8E63FFCDA37DFFE1C1A4FFE2C4A8FFE4C6ABFFE7C9ADFFE8CCB2FFE3C5\r\n      A9FFE2C3A7FFE1C3A7FFC19369FE713A09C00000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000D1A1A1A58D7D7D7ECF0F0\r\n      F0FFF0F0F0FFF1F1F1FFF2F2F2FFF4F4F3FFF5F5F4FFF6F6F5FFF7F7F6FFF8F8\r\n      F7FFF8F8F8FFF9F9F8FFF9F9F8FFF9F9F8FFF8F8F7FFF7F7F7FFF6F6F6FFF5F5\r\n      F4FFF4F4F4FFF3F3F2FFF2F2F1FFF1F1F1FFBD7233FFEEBF9BFFEFC09DFFBA6F\r\n      30FE020000030000000000000000000000000000000619191948D8D8D8EBF0F0\r\n      F0FFF0F0F0FFF2F2F2FFF3F3F3FFF4F4F4FFF5F5F5FFF6F6F6FFF7F7F7FFF8F8\r\n      F8FFF9F9F9FFF9F9F9FFF9F9F9FFF9F9F9FFF8F8F8FFF7F7F7FFF7F7F6FFF5F5\r\n      F5FFE9DFD7FFBB8B5FFFCFA783FFE7CBB2FFE8CDB4FFE8CDB4FFE8CDB4FFE8CD\r\n      B5FFE8CDB5FFCAA27DFE7A4312CC140900230000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000D1A1A1A58D7D7D7ECEFEF\r\n      EFFFD4CCC6FFCDC4BCFFCEC4BCFFCEC5BDFFCEC5BDFFCFC5BEFFD0C6BEFFD0C6\r\n      BEFFD0C7BFFFD0C7BFFFD0C7BFFFD0C7BFFFD0C6BFFFD0C6BEFFCFC6BEFFCFC5\r\n      BDFFCEC5BDFFCEC4BCFFCDC4BCFFD3CBC5FFBE7334FFF2C4A2FFF2C5A4FFBC71\r\n      31FE020000030000000000000000000000000000000619191948D8D8D8EBEFEF\r\n      EFFFE5E2E0FFE3E0DDFFE3E1DEFFE4E1DEFFE4E1DEFFE5E2DFFFE5E2DFFFE5E3\r\n      E0FFE6E3E0FFE6E3E0FFE6E3E0FFE6E3E0FFE6E3E0FFE5E2DFFFE5E2DFFFE4E1\r\n      DEFFE4E1DEFFDBD0C6FFB6875CFFCFA783FFEAD0B9FFEBD2BCFFEBD2BCFFEBD2\r\n      BCFFCAA17DFE753E0DC71007001D000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000D1A1A1A58D7D7D7ECEFEF\r\n      EFFFD2CBC4FFD2CAC3FFCDC5BEFFCCC4BEFFD3CBC4FFCDC5BFFFCDC5BFFFCDC5\r\n      BFFFCEC6C0FFD4CCC6FFCFC7C1FFCEC6C0FFCDC5BFFFCDC5BFFFCDC5BFFFD3CB\r\n      C4FFD3CBC5FFD3CBC5FFD3CAC4FFD2CAC4FFC07435FFF5C8A9FFF5CAABFFBE72\r\n      33FE020000030000000000000000000000000000000619191948D8D8D8EBEFEF\r\n      EFFFDDD8D5FFDDD8D4FFD7D3CFFFD7D2CFFFDED9D5FFD8D4D0FFD8D3D0FFD8D3\r\n      D0FFD9D5D1FFDFDAD7FFDAD5D1FFD9D4D1FFD8D4D0FFD8D3D0FFD8D4D0FFDED9\r\n      D5FFDFDAD6FFDED9D6FFD4C6BAFFB38559FFD1AC8BFFEBD4C0FFECD6C3FFCDA7\r\n      85FF733D0DC71409002300000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000D1A1A1A58D7D7D7ECEFEF\r\n      EFFFD8D1CCFFD2CCC8FFABA6A1FFA5A09CFFD4CEC9FFAAA5A1FFA5A19DFFA5A1\r\n      9DFFAAA5A1FFD0CAC5FFACA7A3FFA6A19DFFA5A19DFFA5A19DFFA9A4A0FFD5CE\r\n      CAFFD9D3CEFFD9D2CDFFD8D2CDFFD7D1CCFFC27636FFF3C6A7FFF4C7A8FFBE72\r\n      33FD020000030000000000000000000000000000000619191948D8D8D8EBEFEF\r\n      EFFFD8D1CCFFD2CCC7FFAAA6A1FFA5A19CFFD4CEC9FFAAA5A1FFA5A19DFFA5A1\r\n      9DFFAAA5A1FFD0CAC5FFACA7A3FFA6A19EFFA5A19DFFA5A19DFFA9A4A0FFD4CE\r\n      C9FFD9D3CDFFD8D2CDFFD8D2CCFFCFC1B5FFB6895EFFD1AF8FFFCAA482FE7742\r\n      0FCC1107001E0000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000D1A1A1A58D7D7D7ECEFEF\r\n      EFFFDDD8D4FFDDD8D4FFD9D5D1FFD9D5D1FFDED9D5FFDAD5D1FFDAD5D2FFDAD6\r\n      D2FFDBD6D2FFDFDAD6FFDBD6D3FFDAD6D2FFDAD6D2FFDAD5D2FFDAD5D1FFDED9\r\n      D6FFDFDAD6FFDED9D5FFDDD9D5FFDDD8D4FFCC9362FFC37738FEBF7233FB864B\r\n      1BB6010000010000000000000000000000000000000619191948D7D7D7EBEFEF\r\n      EFFFD2CAC4FFD2CAC3FFCEC6C0FFCFC7C0FFD3CBC5FFCFC7C1FFCFC7C1FFD0C7\r\n      C1FFD0C8C2FFD4CCC5FFD0C8C2FFD0C7C1FFD0C7C1FFCFC7C1FFCFC7C1FFD3CB\r\n      C5FFD4CCC5FFD3CBC5FFD3CBC4FFD2CAC3FFE2D9D0FFB4885EFE6F3E0FC81208\r\n      0027000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000D1A1A1A58D6D6D6ECEEEE\r\n      EEFFE5E2E0FFE4E0DEFFE4E1DFFFE5E2E0FFE5E2E0FFE5E2E0FFE5E3E0FFE6E3\r\n      E1FFE6E3E1FFE6E3E1FFE6E3E1FFE6E3E1FFE6E3E1FFE6E3E0FFE5E2E0FFE5E2\r\n      E0FFE5E2E0FFE4E1DFFFE4E1DFFFE5E2E0FFEEEEEEFFDADADAEB1E1E1E3C0000\r\n      0002000000000000000000000000000000000000000619191948D7D7D7EBEEEE\r\n      EEFFD5CDC7FFD0C7C0FFD1C7C0FFD1C8C1FFD2C8C2FFD2C8C2FFD2C9C2FFD2C9\r\n      C2FFD3CAC3FFD3CAC3FFD3CAC3FFD3CAC3FFD3C9C3FFD2C9C2FFD2C9C2FFD2C8\r\n      C2FFD1C8C1FFD1C7C0FFD0C7C0FFD4CDC6FFEEEEEEFFDADADAED1D1D1D4B0000\r\n      0006000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000D1A1A1A58D6D6D6ECEEEE\r\n      EEFFEFEEEEFFEFEFEFFFF0F0F0FFF1F1F1FFF2F2F2FFF3F3F3FFF3F3F3FFF4F4\r\n      F4FFF4F4F4FFF5F5F4FFF5F5F4FFF4F4F4FFF4F4F4FFF4F4F3FFF3F3F3FFF2F2\r\n      F2FFF1F1F1FFF1F0F0FFF0F0F0FFEFEFEFFFEEEEEEFFDADADAEB1E1E1E3C0000\r\n      0002000000000000000000000000000000000000000619191948D7D7D7EBEEEE\r\n      EEFFEEEDEDFFEDEDECFFEEEEEDFFEFEFEEFFF0EFEFFFF1F0F0FFF1F1F0FFF2F1\r\n      F1FFF2F2F1FFF3F2F1FFF3F2F1FFF2F2F1FFF2F2F1FFF2F1F0FFF1F0F0FFF0F0\r\n      EFFFF0EFEEFFEFEEEDFFEEEDECFFEEEEEDFFEEEEEEFFDADADAED1D1D1D4B0000\r\n      0006000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000D17171754C7C7C7DFDEDE\r\n      DEF0DEDEDEF0DFDFDFF0DFDFDFF0E0E0E0F0E0E0E0F0E1E1E1F0E1E1E1F0E1E1\r\n      E1F0E1E1E1F0E1E1E1F0E1E1E1F0E1E1E1F0E1E1E1F0E1E1E1F0E1E1E1F0E1E1\r\n      E1F0E0E0E0F0E0E0E0F0DFDFDFF0DEDEDEF0DEDEDEF0C9C9C9DC1A1A1A380000\r\n      0002000000000000000000000000000000000000000517171742C6C6C6DBDEDE\r\n      DEEFDEDEDEEFDEDEDEEEDEDEDEEEE0E0E0EFE0E0E0EFE0E0E0EEE0E0E0EEE0E0\r\n      E0EFE1E1E1EFE0E0E0EEE0E0E0EEE1E1E1EFE1E1E1EFE0E0E0EEE0E0E0EEE0E0\r\n      E0EFE0E0E0EFDFDFDFEEDEDEDEEEDEDEDEEFDEDEDEEFC9C9C9DD1A1A1A450000\r\n      0005000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      000000000000000000000000000000000000000000070101012E111111521313\r\n      1356131313561313135613131356131313561313135613131356131313561313\r\n      1356131313561313135613131356131313561313135613131356131313561313\r\n      135613131356131313561313135613131356131313561111114A010101190000\r\n      000100000000000000000000000000000000000000020202021A1111113F1313\r\n      1346131313461313134613131346131313461313134613131346131313461313\r\n      1346131313461313134613131346131313461313134613131346131313461313\r\n      13461313134613131346131313461313134613131346121212400202021B0000\r\n      0002000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000020000\r\n      0010000000290000003600000039000000390000003900000039000000390000\r\n      0039000000390000003900000039000000390000003900000039000000390000\r\n      0039000000390000003900000039000000390000003900000039000000360000\r\n      0029000000100000000200000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000060000\r\n      0026132B3DBA234A66F9234A66F9234A66F9234A66F9234A66F9234A66F9234A\r\n      66F9234A66F9234A66F9234A66F9234A66F9234A66F9234A66F9234A66F9234A\r\n      66F9234A66F9234A66F9234A66F9234A66F9234A66F9234A66F9234A66F9132B\r\n      3DBA000000260000000600000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000060000\r\n      0026224A66F7508EB2FF4C7DA4FF4C7DA4FF4C7DA4FF4C7DA4FF4C7DA4FF4C7D\r\n      A4FF4C7DA4FF4C7DA4FF4C7DA4FF4C7DA4FF4C7DA4FF4C7DA4FF4C7DA4FF4C7D\r\n      A4FF4C7DA4FF4C7DA4FF4C7DA4FF4C7DA4FF4C7DA4FF4C7DA4FF508EB2FF224A\r\n      66F7000000260000000600000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000020000\r\n      0010244B66F4508EB2FF4C7DA4FF4C7DA4FF4C7DA4FF4C7DA4FF4C7DA4FF4C7D\r\n      A4FF4C7DA4FF4C7DA4FF4C7DA4FF4C7DA4FF4C7DA4FF4C7DA4FF4C7DA4FF4C7D\r\n      A4FF4C7DA4FF4C7DA4FF4C7DA4FF4C7DA4FF4C7DA4FF4C7DA4FF508EB2FF244B\r\n      66F4000000100000000200000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0002244C67F2508EB2FF4C7DA4FFEDEDEDFFE9E9E9FFE9E9E9FFE9E9E9FFE9E9\r\n      E9FFE9E9E9FFE9E9E9FFE9E9E9FFE9E9E9FFE9E9E9FFE9E9E9FFE9E9E9FFE9E9\r\n      E9FFE9E9E9FFE9E9E9FFE9E9E9FFE9E9E9FFEDEDEDFF4C7DA4FF508EB2FF244C\r\n      67F2000000020000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000254D68F2508EB2FF4C7DA4FFEEEEEEFFEAEAEAFFEAEAEAFFEAEAEAFFEAEA\r\n      EAFFEAEAEAFFEAEAEAFFEAEAEAFFEAEAEAFFEAEAEAFFEAEAEAFFEAEAEAFFEAEA\r\n      EAFFEAEAEAFFEAEAEAFFEAEAEAFFEAEAEAFFEEEEEEFF4C7DA4FF508EB2FF254D\r\n      68F2000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000264E6AF2508EB2FF4C7DA4FFEEEEEEFFEAEAEAFFEAEAEAFFD2CFBFFF978C\r\n      57FFE2E1DDFFEAEAEAFFEAEAEAFFEAEAEAFFEAEAEAFFEAEAEAFFEAEAEAFFEAEA\r\n      EAFFEAEAEAFFEAEAEAFFEAEAEAFFEAEAEAFFEEEEEEFF4C7DA4FF508EB2FF264E\r\n      6AF2000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000010000000100000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000274F6BF2508EB2FF4C7DA4FFEFEFEFFFEBEBEBFFD3CFC0FF847535FF9185\r\n      4CFFA49B6EFFEBEBEBFFEBEBEBFFEBEBEBFF6A7E86FF6A7E86FF6A7E86FF6A7E\r\n      86FF6A7E86FF6A7E86FF6A7E86FFEBEBEBFFEFEFEFFF4C7DA4FF508EB2FF274F\r\n      6BF2000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000019191950353737DE1A1B1BDF03030353000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      000028516CF2508EB2FF4C7DA4FFF0F0F0FFECECECFFB8B191FFD1CDBCFFE8E8\r\n      E5FF958953FFB2AA86FFECECECFFECECECFFECECECFFECECECFFECECECFFECEC\r\n      ECFFECECECFFECECECFFECECECFFECECECFFF0F0F0FF4C7DA4FF508EB2FF2851\r\n      6CF2000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000303030E303131CD1F2120FF0A0B0BFE171818D0030303100000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      000029526DF2508EB2FF4C7DA4FFF1F1F1FFEDEDEDFFEDEDEDFFEDEDEDFFEDED\r\n      EDFFE4E3DDFF978B55FFEDEDEDFFEDEDEDFF6A7E86FF6A7E86FF6A7E86FF6A7E\r\n      86FF6A7E86FF6A7E86FF6A7E86FFEDEDEDFFF1F1F1FF4C7DA4FF508EB2FF2952\r\n      6DF2000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000202020E171717CC0B0B0BFF202120FE303232CF0404040F0000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000010101041919197A2E2E2ED32E2E2EDC242424A80606061D000000000000\r\n      00000000000000000000000000000000000000000000000000000F0F0F460000\r\n      0003000000000000000000000000000000000000000000000000000000000000\r\n      00002B546FF2508EB2FF4C7DA4FFF1F1F1FFEDEDEDFFEDEDEDFFEDEDEDFFEDED\r\n      EDFFEDEDEDFFE5E4DFFFEDEDEDFFEDEDEDFFEDEDEDFFEDEDEDFFEDEDEDFFEDED\r\n      EDFFEDEDEDFFEDEDEDFFEDEDEDFFEDEDEDFFF1F1F1FF4C7DA4FF508EB2FF2B54\r\n      6FF2000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      000000000000000000000303034E191A1AD9343635DA19191950000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      000000000000000000000000000000000000000000000606061C1616166A1A1A\r\n      1A771313135B0303030C00000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0001252525B0363636FF363636FF363636FF363636FF323232ED070707200000\r\n      0000000000000000000000000000000000000000000000000000262626B72A2A\r\n      2AC4070707220000000000000000000000000000000000000000000000000000\r\n      00002C5570F2508EB2FF4C7DA4FFF1F1F1FFEEEEEEFFEEEEEEFFEEEEEEFFEEEE\r\n      EEFFEEEEEEFFEEEEEEFFEEEEEEFFEEEEEEFFEEEEEEFFEEEEEEFFEEEEEEFFEEEE\r\n      EEFFEEEEEEFFEEEEEEFFEEEEEEFFEEEEEEFFF1F1F1FF4C7DA4FF508EB2FF2C55\r\n      70F2000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      00000000000000000000000000000505051E0606061C00000000000000000000\r\n      00000000000000000000000000000000000015151568343434F6363636FF3636\r\n      36FF363636FF303030E20C0C0C3A00000000040404160A0A0A330A0A0A330A0A\r\n      0A330A0A0A330A0A0A330A0A0A330A0A0A330A0A0A3308080828000000001111\r\n      1155363636FF363636FF363636FF363636FF363636FF363636FF252525B20000\r\n      0000050505150A0A0A330A0A0A330A0A0A330A0A0A330A0A0A332A2A2AC63636\r\n      36FF333333F21717176D00000002000000000000000000000000000000000000\r\n      00002D5672F2508EB2FF4C7DA4FFF2F2F2FFEFEFEFFFEFEFEFFFD6D2C3FF998D\r\n      58FFE7E6E1FFEFEFEFFFEFEFEFFFEFEFEFFFEFEFEFFFEFEFEFFFEFEFEFFFEFEF\r\n      EFFFEFEFEFFFEFEFEFFFEFEFEFFFEFEFEFFFF2F2F2FF4C7DA4FF508EB2FF2D56\r\n      72F2000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000010101010700000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      00000000000000000000000000000E0E0E40333333EE12121258000000000000\r\n      000000000000000000000000000011111155363636FF363636FF363636FF3636\r\n      36FF363636FF363636FF333333F00707072018181870363636FF363636FF3636\r\n      36FF363636FF363636FF363636FF363636FF363636FF272727BA000000002121\r\n      219A363636FF363636FF363636FF363636FF363636FF363636FF343434F60000\r\n      00011313135B363636FF363636FF363636FF363636FF363636FF363636FF3636\r\n      36FF363636FF363636FF282828BE0606061B0000000000000000000000000000\r\n      00002F5673F2508EB2FF4C7DA4FFF3F3F3FFF0F0F0FFD7D3C4FF857636FF9286\r\n      4DFFA69D70FFF0F0F0FFF0F0F0FFF0F0F0FF6A7E86FF6A7E86FF6A7E86FF6A7E\r\n      86FF6A7E86FF6A7E86FF6A7E86FFF0F0F0FFF3F3F3FF4C7DA4FF508EB2FF2F56\r\n      73F2000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000020202091212\r\n      11412A28289F1918186200000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000A0A0A2D0A0A0A330A0A0A330A0A\r\n      0A330A0A0A330A0A0A330A0A0A330A0A0A330A0A0A330A0A0A330A0A0A330A0A\r\n      0A330A0A0A330A0A0A330A0A0A3315151566363636FF363636FF232323A60404\r\n      04130000000000000000000000002E2E2ED8363636FF363636FF363636FF3636\r\n      36FF363636FF363636FF363636FF1F1F1F9618181870363636FF363636FF3636\r\n      36FF363636FF363636FF363636FF363636FF363636FF282828BD000000001F1F\r\n      1F94363636FF363636FF363636FF363636FF363636FF363636FF333333F20000\r\n      00001414145F363636FF363636FF363636FF363636FF363636FF363636FF3636\r\n      36FF363636FF363636FD1D1D1D8D020202080000000000000000000000000000\r\n      0000305875F2508EB2FF4C7DA4FFF4F4F4FFF1F1F1FFBBB494FFD5D1C0FFEDEC\r\n      EAFF968B54FFB4AC88FFF1F1F1FFF1F1F1FFF1F1F1FFF1F1F1FFF1F1F1FFF1F1\r\n      F1FFF1F1F1FFF1F1F1FFF1F1F1FFF1F1F1FFF4F4F4FF4C7DA4FF508EB2FF3058\r\n      75F2000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      000000000000000000000000000000000000050505122120206A3B3A39C74644\r\n      43F5434241FE2120208300000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000002F2F2FDF363636FF363636FF3636\r\n      36FF363636FF363636FF363636FF363636FF363636FF363636FF363636FF3636\r\n      36FF363636FF363636FF363636FF363636FF363636FF363636FF363636FF3131\r\n      31E71111114E0000000003030314363636FF363636FF363636FF363636FF3636\r\n      36FF363636FF363636FF363636FF2C2C2CD10101010703030311030303110303\r\n      0311030303110303031103030311232323A3363636FF323232EC010101040E0E\r\n      0E45363636FF363636FF363636FF363636FF363636FF363636FF222222A10000\r\n      00001F1F1F94363636FF353535F7040404160303031103030311292929BC3636\r\n      36FF303030E20D0D0D4100000000000000000000000000000000000000000000\r\n      0000315976F2508EB2FF4C7DA4FFF5F5F5FFF2F2F2FFF2F2F2FFF2F2F2FFF2F2\r\n      F2FFE8E7E2FF988C56FFF2F2F2FFF2F2F2FFF2F2F2FFF2F2F2FFF2F2F2FFF2F2\r\n      F2FFF2F2F2FFF2F2F2FFF2F2F2FFF2F2F2FFF5F5F5FF4C7DA4FF508EB2FF3159\r\n      76F2000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      000000000000010101041413133734323295504E4DF1514F4EFF4C4A49FF4947\r\n      46FF444241FE2625259400000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000002F2F2FDF363636FF363636FF3636\r\n      36FF363636FF363636FF363636FF363636FF363636FF363636FF363636FF3636\r\n      36FF363636FF363636FF363636FF363636FF363636FF363636FF363636FF3030\r\n      30E20D0D0D410000000004040413363636FF363636FF363636FF363636FF3636\r\n      36FF363636FF363636FF363636FF2C2C2CD00000000000000000000000000000\r\n      00000000000000000000000000001313135B363636FF363636FF1313135E0000\r\n      00001E1E1E90363636FF363636FF363636FF363636FF2E2E2ED9030303140404\r\n      0412333333EF363636FF272727B9000000000000000000000000262626B72424\r\n      24A5030303100000000000000000000000000000000000000000000000000000\r\n      0000335B79F2508EB2FF4C7DA4FFF5F5F5FFF3F3F3FFF3F3F3FFF3F3F3FFF3F3\r\n      F3FFF3F3F3FFEBEAE5FFF3F3F3FFF3F3F3FFF3F3F3FFF3F3F3FFF3F3F3FFF3F3\r\n      F3FFF3F3F3FFF3F3F3FFF3F3F3FFF3F3F3FFF5F5F5FF4C7DA4FF508EB2FF335B\r\n      79F2000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000404040D3837369B585554F8555251FF514F4EFF4C4A49FF4947\r\n      46FF444241FE2A2929A400000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000C0C0C3C0E0E0E440E0E0E440E0E\r\n      0E440E0E0E440E0E0E440E0E0E440E0E0E440E0E0E440E0E0E440E0E0E440E0E\r\n      0E440E0E0E440E0E0E440E0E0E4418181873363636FF363636FF242424A50303\r\n      03100000000000000000000000002E2E2ED8363636FF363636FF363636FF3636\r\n      36FF363636FF363636FF363636FF1F1F1F960000000000000000000000000000\r\n      000000000000000000000000000002020208313131E8363636FF323232EB0707\r\n      0720000000000F0F0F4B252525AF272727BA1A1A1A7B02020209000000022424\r\n      24AB363636FF363636FF1010104F0000000000000000000000000A0A0A2D0000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000335C79F2508EB2FF4C7DA4FFF6F6F6FFF4F4F4FFF4F4F4FFF4F4F4FFF4F4\r\n      F4FFF4F4F4FFF4F4F4FFF4F4F4FFF4F4F4FFF4F4F4FFF4F4F4FFF4F4F4FFF4F4\r\n      F4FFF4F4F4FFF4F4F4FFF4F4F4FFF4F4F4FFF6F6F6FF4C7DA4FF508EB2FF335C\r\n      79F2000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      000000000000000000000202020823222165524F4EF6524F4EFF4C4A49FF4947\r\n      46FF444241FE2E2D2CB400000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      00000000000000000000000000000E0E0E40333333EE12121258000000000000\r\n      000000000000000000000000000011111155363636FF363636FF363636FF3636\r\n      36FF363636FF363636FF333333F0070707200000000000000000000000000000\r\n      00000000000000000000000000000000000012121254363636FF363636FF3131\r\n      31E51111114E0000000100000000000000000000000007070723272727B33636\r\n      36FF363636FF262626B100000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000345D7BF2508EB2FF4C7DA4FFF7F7F7FFF5F5F5FFF5F5F5FFDAD7C8FF9A8F\r\n      5AFFEDECE7FFF5F5F5FFF5F5F5FFF5F5F5FF6A7E86FF6A7E86FF6A7E86FF6A7E\r\n      86FF6A7E86FF6A7E86FF6A7E86FFF5F5F5FFF7F7F7FF4C7DA4FF508EB2FF345D\r\n      7BF2000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      000000000000000000000000000017161642535150FA524F4EFF4D4A49FF4947\r\n      46FF444241FE32302FC200000002000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      00000000000000000000000000000505051E0606061C00000000000000000000\r\n      00000000000000000000000000000000000018181870353535F9363636FF3636\r\n      36FF363636FF313131EA0C0C0C3E000000000000000000000000000000000000\r\n      000000000000000000000000000000000000000000001B1B1B81363636FF3636\r\n      36FF363636FF313131E1242424A52121219D292929C5363636FD363636FF3636\r\n      36FF2C2C2CD00202020F00000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000355F7CF2508EB2FF4C7DA4FFF7F7F7FFF5F5F5FFDAD7C8FF857636FF9387\r\n      4EFFA89E71FFF5F5F5FFF5F5F5FFF5F5F5FFF5F5F5FFF5F5F5FFF5F5F5FFF5F5\r\n      F5FFF5F5F5FFF5F5F5FFF5F5F5FFF5F5F5FFF7F7F7FF4C7DA4FF508EB2FF355F\r\n      7CF2000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      00000000000000000000131212354E4C4BDF555352FF524F4EFF4D4A49FF4947\r\n      46FD444241FE343332CC0202020A000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      000000000000000000000000000000000000000000000606061D1616166A1A1A\r\n      1A771313135B0202020D00000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000151515603232\r\n      32ED363636FF363636FF363636FF363636FF363636FF363636FF363636FD2323\r\n      23A00202020F0000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      000037607EF2508EB2FF4C7DA4FFF8F8F8FFF6F6F6FFBEB696FFD8D5C4FFF2F1\r\n      EFFF978C55FFB6AF8BFFF6F6F6FFF6F6F6FF6A7E86FF6A7E86FF6A7E86FF6A7E\r\n      86FF6A7E86FF6A7E86FF6A7E86FFF6F6F6FFF8F8F8FF4C7DA4FF508EB2FF3760\r\n      7EF2000000000000000000000000000000000000000000000000000000000000\r\n      0000060606070303030400000000000000000000000000000000000000000000\r\n      00000303030A201F1F5552504FDF5A5857FE555352FF52504FFF4B4948F92928\r\n      278F3A3938DA363534D504040411000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000303\r\n      030C15151568272727B32D2D2DD52E2E2EDC2A2A2AC41C1C1C86080808290000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      000038617FF2508EB2FF4C7DA4FFF9F9F9FFF7F7F7FFF7F7F7FFF7F7F7FFF7F7\r\n      F7FFEDECE6FF998D58FFF7F7F7FFF7F7F7FFF7F7F7FFF7F7F7FFF7F7F7FFF7F7\r\n      F7FFF7F7F7FFF7F7F7FFF7F7F7FFF7F7F7FFF9F9F9FF4C7DA4FF508EB2FF3861\r\n      7FF2000000000000000000000000000000000000000000000000000000000000\r\n      00000E0E0E10211F1F2A1D1C1C2B1212111F0C0B0B180B0B0B1A111110292221\r\n      2153403E3DA0575554E15C5958FA5B5857FF565352FF52504FFE31302FA10202\r\n      0209090808222221218705050516000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000396380F2508EB2FF4C7DA4FFF9F9F9FFF7F7F7FFF7F7F7FFF7F7F7FFF7F7\r\n      F7FFF7F7F7FFEEEDE9FFF7F7F7FFF7F7F7FFF7F7F7FFF7F7F7FFF7F7F7FFF7F7\r\n      F7FFF7F7F7FFF7F7F7FFF7F7F7FFF7F7F7FFF9F9F9FF4C7DA4FF508EB2FF3963\r\n      80F2000000000000000000000000000000000000000000000000000000000000\r\n      00000D0D0D0F2524243032302F493735345C3735346D3938378042403F9A4B49\r\n      48B452504FCE595655E55C5958FA5B5857FF565352FE3C3B3ABC070706170000\r\n      0000000000000101010500000002000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      00003A6481F2508EB2FF4C7DA4FFF9F9F9FFF8F8F8FFF8F8F8FFF8F8F8FFF8F8\r\n      F8FFF8F8F8FFF8F8F8FFF8F8F8FFF8F8F8FFF8F8F8FFF8F8F8FFF8F8F8FFF8F8\r\n      F8FFF8F8F8FFF8F8F8FFF8F8F8FFF8F8F8FFF9F9F9FF4C7DA4FF508EB2FF3A64\r\n      81F2000000000000000000000000000000000000000000000000000000000000\r\n      00000C0C0C0E2523232F32302F493735345C393736703B3A39854341419D4B49\r\n      48B452504FCD595655E55C5958FA595655F9373535A205050511000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      00003B6583F2508EB2FF4C7DA4FFFBFBFBFFEFEFEFFFD9D9D9FFCECECEFFCECE\r\n      CEFFCECECEFFCECECEFFCECECEFFCECECEFFCECECEFFCECECEFFCECECEFFCECE\r\n      CEFFCECECEFFCECECEFFD9D9D9FFEFEFEFFFFBFBFBFF4C7DA4FF508EB2FF3B65\r\n      83F2000000000000000000000000000000000000000000000000000000000000\r\n      00000909090B2322222D312F2F483835355C3937366F3B3939844341409C4B49\r\n      48B4524F4ECC575454E04C4948CB232221620101010500000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      00003C6584F2508EB2FF4C7DA4FFFDFDFDFF99A5A9FF6A7E86FF6A7E86FF6A7E\r\n      86FF6A7E86FF6A7E86FF6A7E86FF6A7E86FF6A7E86FF6A7E86FF6A7E86FF6A7E\r\n      86FF6A7E86FF6A7E86FF6A7E86FF99A5A9FFFDFDFDFF4C7DA4FF508EB2FF3C65\r\n      84F2000000000000000000000000000000000000000000000000000000000000\r\n      0000000000010A0A0A0E1B1A1A2829272744302F2E5F343332753A3837873A38\r\n      388C302E2E781B1A1A4706060611000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      00003D6785F2508EB2FF4C7DA4FF4C7DA4FF617782FFCADADEFFB8CED3FFB8CE\r\n      D3FFB8CED3FFB8CED3FFB8CED3FFB8CED3FFB8CED3FFB8CED3FFB8CED3FFB8CE\r\n      D3FFB8CED3FFB8CED3FFCADADEFF617782FF4C7DA4FF4C7DA4FF508EB2FF3D67\r\n      85F2000000000000000000000000000000000000000000000000000000000000\r\n      00000000000000000000000000000101010203030307040303090404040A0202\r\n      0206000000010000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      00003E6786F2539ABDFF508EB2FF508EB2FF617883FFDDE9EBFFD2E1E4FFD2E1\r\n      E4FFCEDFE2FFC7DADDFFC7DADDFFCEDFE2FFCEDFE2FFC7DADDFFC7DADDFFCEDF\r\n      E2FFD2E1E4FFD2E1E4FFDDE9EBFF617883FF508EB2FF508EB2FF539ABDFF3E67\r\n      86F2000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      00003E6786F25AB2D2FF59AECFFF59AECFFF627A84FFF6F9FAFFF3F7F8FFF3F7\r\n      F8FFEDF3F5FFDEEAECFFD8E6E9FFE1ECEEFFE1ECEEFFD8E6E9FFDEEAECFFEDF3\r\n      F5FFF3F7F8FFF3F7F8FFF6F9FAFF627A84FF59AECFFF59AECFFF5AB2D2FF3E67\r\n      86F2000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000243D4F8E3F6887F23F6887F23F6887F2527083F9607780FE607780FE6077\r\n      80FE607780FEF3F8F9FFEAF3F4FF607780FE607780FEEAF3F4FFF3F8F9FF6077\r\n      80FE607780FE607780FE607780FE527083F93F6887F23F6887F23F6887F2243D\r\n      4F8E000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      00003642478E5D7179F2FAFCFCFFF8FBFBFFF8FBFBFFFAFCFCFF5D7179F23642\r\n      478E000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000003642478E5D7179F25D7179F25D7179F25D7179F23642478E0000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000040000000D0000000F000000060000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      000000000000000000000000000000000000000000040000000D0000000F0000\r\n      0006000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      000000000000000000020000001D000000320000003800000038000000380000\r\n      0038000000380000003800000038000000380000003800000038000000380000\r\n      0038000000380000002500000011000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0001000000060000000F000000150000001600000016000000150000000F0000\r\n      0006000000010000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000003000000140000002E0000002E000000110000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      000000000000000000000000000000000003000000140000002E0000002E0000\r\n      0011000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      00000503030A3F3A359E5B534BDC69615AE76A615BE86A615BE86A615BE86A61\r\n      5BE86A615BE86A615BE86A615BE86A615BE86A615CE86A625CE86A625CE8665E\r\n      59E449413EC91816138E000000550000002A0000000300000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000030000\r\n      000E000000200000003400000040000000430000004300000040000000340000\r\n      00200000000E0000000300000000000000000000000000000005000000100000\r\n      0016000000160000001600000016000000160000001600000016000000160000\r\n      001600000016000000160000001D00000033005F36C6008F52FF000000270000\r\n      0016000000160000001600000016000000160000001600000010000000050000\r\n      0000000000000000000000000000000000000000000500000010000000160000\r\n      0016000000160000001600000016000000160000001600000016000000160000\r\n      00160000001600000016000000160000001D00000033005F36C6008F52FF0000\r\n      0027000000160000001600000016000000160000001600000016000000160000\r\n      0016000000100000000500000000000000000000000000000000000000000101\r\n      01055F554ED4A8A3A0FFCCCCCCFFCCCCCCFFCCCCCCFFCFCFCFFFD1D1D1FFD3D3\r\n      D3FFD5D5D5FFD8D8D8FFDADADAFFDCDCDCFFDEDEDEFFE0E0E0FFE0E0E0FFE1E1\r\n      E1FF989593FDA9A39FFE5F5A55D4040303730000003C0000000A000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000003000000120000\r\n      002D001B0E69006536D1008A48FF008948FF008948FF008A48FF006536D1001B\r\n      0E690000002D0000001200000003000000000000000000000010000000310000\r\n      0042000000430000004300000043000000430000004300000043000000430000\r\n      004300000043000000430000004600562FBE00C788FF008C4FFF000000480000\r\n      0043000000430000004300000043000000430000004200000031000000100000\r\n      0000000000000000000000000000000000000000001000000031000000420000\r\n      0043000000430000004300000043000000430000004300000043000000430000\r\n      00430000004300000043000000430000004600562FBE00C788FF008C4FFF0000\r\n      0048000000430000004300000043000000430000004300000043000000430000\r\n      0042000000310000001000000000000000000000000000000000000000001E1B\r\n      1A4499938EFFCCCCCCFFCCCCCCFFCCCCCCFFCECECEFFD3D3D3FFD8D8D8FFDCDC\r\n      DCFFE1E1E1FFE6E6E6FFEBEBEBFFEFEFEFFFF4F4F4FFF7F7F7FFF8F8F8FFF9F9\r\n      F9FFC1C1C1FF8C8681FFE4E4E4FF938D89F5110E0D8900000048000000110000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      000000000000000000000000000000000000000000010000000E0000002D0051\r\n      2BB4009151FF00B678FF00CD90FF00D194FF00D194FF00CD90FF00B678FF0091\r\n      51FF00512BB40000002D0000000E000000010000000000000016AC7A17F2B67D\r\n      0DFFB57B08FFB47A08FFB47A08FFB47A08FFB47A08FFB47A08FFB47A08FFB67B\r\n      08FFBB7C0BFFCB7E0EFF408433FF00BE84FF00E1A8FF00894AFFDD8413FFD185\r\n      17FFCF8518FFCE8518FFCD8517FFC98415FFC58315FFB67B17F10000001A0000\r\n      00020000000000000000000000000000000000000016AC7A17F2B67D0DFFB47A\r\n      08FFB47906FFB47906FFB47906FFB47906FFB47906FFB47907FFB47A07FFB479\r\n      07FFB57A08FFBB7C0AFFCB7E0EFF408433FF00BE84FF00E1A8FF00894AFFDD84\r\n      13FFD18517FFCF8518FFCE8518FFCD8517FFC98314FFC38110FFBB7D0CFFB97E\r\n      0FFFAC7A17F20000001600000000000000000000000000000000000000002C28\r\n      2463B1AEABFFCCCCCCFFCCCCCCFFCCCCCCFFCFCFCFFFD3D3D3FFD8D8D8FFDDDD\r\n      DDFFE2E2E2FFE7E7E7FFEBEBEBFFF0F0F0FFF5F5F5FFF7F7F7FFF8F8F8FFF9F9\r\n      F9FFBDBDBDFF86827DFFECECECFFE3E3E3FFABA7A5FC201D1A9F000000540000\r\n      0018000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000600000011000000120000000900000001000000000000\r\n      000000000000000000000000000000000000000000060000002000512BB10096\r\n      55FF00CB8FFF00CD8FFF00C98AFF00C685FF00C685FF00C98AFF00CD8FFF00CB\r\n      8FFF009655FF00512BB100000020000000060000000000000016B67D0DFFFFFF\r\n      FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n      FFFFFFFFFFFF5DBA99FF00B77EFF00D6A1FF00D6A2FF008442FF008949FF0089\r\n      4BFF00894BFF00894BFF008949FF24A475FF8AD5C3FFCB8313FF0000002E0000\r\n      00110000000400000000000000000000000000000016B67D0DFFFFFFFFFFFFFF\r\n      FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n      FFFFFFFFFFFFFFFFFFFF5CBA97FF00B77EFF00D6A1FF00D6A2FF008442FF0089\r\n      49FF00894BFF00894BFF00894BFF008949FF23A373FF85CFB9FFFFFFFFFFFFFF\r\n      FFFFBC8010FF0000001600000000000000000000000000000000000000002C29\r\n      2564B7B4B2FFCCCCCCFFCCCCCCFFCCCCCCFFCFCFCFFFD3D2D1FFCFBDAFFFCFB6\r\n      A2FFC89E83FFCBA38AFFD0AE99FFDFCDBFFFF4F4F3FFF7F7F7FFF8F8F8FFF3F3\r\n      F3FFB6B6B6FF86827DFFF6F6F6FFECECECFFE3E3E3FFBEBCBAFF302D2BAF0000\r\n      0053000000130000000000000000000000000000000000000000000000000000\r\n      0000000000000000000E0000002D00000039000000250000000E000000030000\r\n      0000000000000000000000000000000000000000000F001B0E5D009250FF00C9\r\n      8DFF00CA8CFF00C788FF00C380FFFFFFFFFFFFFFFFFF00C380FF00C788FF00CA\r\n      8CFF00C98DFF009250FF001B0E5D0000000F0000000000000016B57A08FFFFFF\r\n      FFFFE6D6AFFFE6D6B0FFE7D7B1FFE7D7B1FFE7D7B1FFE7D7B1FFE9D8B2FFF5DB\r\n      B7FF47A266FF00B177FF00CF9DFF00CE9BFF00CE9CFF00D19FFF00D2A1FF00D2\r\n      A1FF00D2A1FF00D2A2FF00D3A2FF00C38FFF00A66CFF028C4AFF00371F930000\r\n      00300000001200000003000000000000000000000016B47A08FFFFFFFFFFFFFF\r\n      FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFD7C0A6FFFFFF\r\n      FFFFFFFFFFFF52B388FF00B075FF00CF9DFF00CE9BFF00CE9CFF00D19FFF00D2\r\n      A1FF00D2A1FF00D2A1FF00D2A2FF00D3A2FF00C38EFF00A366FF008D4CFF98D8\r\n      C6FFCD800DFF0000001C00000003000000000000000000000000000000002C29\r\n      2564B9B7B5FFCCCCCCFFCCCCCCFFC8BFB9FFB9886BFFB76C4BFFB46141FFB25B\r\n      3BFFB76648FFB15A3AFFB56343FFBB7253FFB67A52FFC9A389FFF1EBE7FFF0F0\r\n      F0FFB4B4B4FF87837EFFFBFBFBFFFAFAFAFFEAEAEAFFE1E1E1FFBEBCBAFF241F\r\n      1DA2000000490000000A00000000000000000000000000000000000000000000\r\n      0000000000000000000DB58349FFB38146FF3223147A0000002C000000120000\r\n      00030000000000000000000000000000000000000015006736CD00B373FF00C8\r\n      8AFF00C586FF00C383FF00BE78FFFFFFFFFFFFFFFFFF00BE78FF00C383FF00C5\r\n      86FF00C88AFF00B373FF006736CD000000150000000000000016B47A08FFFFFF\r\n      FFFFE6D7B0FFE7D7B3FFE8D8B4FFE8D8B4FFE8D8B4FFE8D8B4FFEAD9B5FFFADE\r\n      BBFF007D36FF4FE0C5FF00C89BFF00C799FF00C698FF10CCA3FF0FCDA4FF0ECD\r\n      A4FF0FCDA4FF10CDA4FF00C899FF00C99BFF00CB9EFF00C597FF009557FF005C\r\n      30C20000002C0000000D000000010000000000000016B47A07FFFFFFFFFFD5BC\r\n      A0FFD6BCA0FFD6BDA0FFD6BDA0FFD6BDA0FFD6BDA1FFD7BFA3FFD9C1A7FFDAC0\r\n      A5FFE9C3AAFF007A30FF4EDFC3FF00C89AFF00C799FF00C698FF10CCA3FF0FCD\r\n      A4FF0ECDA4FF0FCDA4FF10CDA4FF00C899FF00C89BFF00CA9DFF00C293FF0091\r\n      53FF488733FF0000002D0000000D000000010000000000000000000000002C29\r\n      2564BCB9B8FFC8C1BDFFB08464FFB77855FFBE765BFFD29D8AFFC37D63FFE2C0\r\n      B3FFE5C4B8FFDEB6A7FFE1BDB0FFE5C6BBFFDAAC9CFFD9B09FFFB7805DFFCAA8\r\n      92FFCACAC9FF928E8AFFFDFDFDFFFBFBFBFFF9F9F9FFE9E9E9FFDEDEDEFFADAA\r\n      A8FD120F0E8C0000003E00000005000000000000000000000000000000000000\r\n      00000000000000000006715737A4FFFAE7FFD4B48BFF5B4022A50000002E0000\r\n      00100000000200000000000000000000000000000016008A49FF00C587FF00C3\r\n      83FF00BE7BFF00BC76FF00B86EFFFFFFFFFFFFFFFFFF00B86EFF00BC76FF00BE\r\n      7BFF00C383FF00C587FF008A49FF000000160000000000000016B47A08FFFFFF\r\n      FFFFE7D7B1FFE8D8B4FFE8D9B5FFE8D9B5FFE8D9B5FFE8D9B5FFEADAB6FFF6DD\r\n      BBFF48A369FF00AB77FF73E2CEFF00C196FF6FDFC9FF6FE1CDFF70E2CFFF6FE2\r\n      CFFF6FE2CFFF70E2CEFF70E1CDFF62DCC6FF2CD0B0FF00C39BFF00C59CFF0096\r\n      56FF004725A20000001E000000050000000000000016B47907FFFFFFFFFFFFFF\r\n      FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFD7BEA3FFFFFF\r\n      FFFFFFFFFFFF50B082FF00A872FF73E1CDFF00C196FF6FDFC9FF6FE1CCFF6FE2\r\n      CEFF6FE2CEFF6FE2CEFF6FE2CEFF70E1CCFF61DCC5FF2CD0B0FF00C39BFF00C5\r\n      9CFF009657FF0045249F0000001D000000050000000000000000000000002C29\r\n      2564B7A89FFFA3653DFFCF9F89FFE7CCC1FFE9CFC6FFE4C4B9FFE2BFB4FFE2C0\r\n      B5FFDBAFA2FFDCB2A5FFDFB8ABFFE4C4BAFFE8CCC3FFE6C8BDFFECD5CDFFC591\r\n      77FFA86C4AFFC4BDB9FFD9D7D5FFFFFFFFFFFBFBFBFFF9F9F9FFE7E7E7FFDBDB\r\n      DBFF97928FF60808077A0000002E000000000000000000000000000000000000\r\n      0000000000000000000123180E45D3B288FFFFFFFFFFD1B086FF694927B30000\r\n      00270000000A00000000000000000000000000000016008948FF1ACD96FF00BD\r\n      79FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n      FFFF00BD79FF1ACD96FF008948FF000000160000000000000016B47A08FFFFFF\r\n      FFFFE6D7B0FFE7D8B3FFE8D9B4FFE8D9B4FFE8D9B4FFE8D9B4FFE8D9B5FFEEDA\r\n      B7FFFDDEBCFF4BA267FF00A774FF90E8DAFF8EE8DAFF007E36FF008139FF007E\r\n      38FF008038FF007E37FF0A9C65FF3FC19DFF8FE6DAFF57D6C0FF00BF9AFF00C0\r\n      9DFF008E4CFF0011084A0000000E0000000000000016B47906FFFFFFFFFFFFFE\r\n      FBFFFFFDF8FFFFFDF8FFFFFDF8FFFFFDF8FFFFFEF9FFFFFFFFFFD6BC9EFFFFFF\r\n      FFFFFFFFFDFFFFFFFFFF53AF80FF00A570FF90E7D9FF8EE8DAFF007E35FF007D\r\n      35FF007C33FF007D34FF007E36FF0A9C63FF3FC09CFF8FE6D9FF57D6BFFF00BF\r\n      9AFF00C09DFF008E4CFF0011084A0000000E000000000000000000000000372A\r\n      23769F5B35FFDDB9AAFFE3C0B4FFE2C0B5FFD6A696FFD4A190FFDBB0A2FFD29C\r\n      8CFFCD9683FFCE9684FFD09A89FFD29D8CFFEBD3CCFFDEB7ABFFD9AA9CFFEAD1\r\n      C8FFDCB9ABFF9F5E39FFCAC2BDFFDFDCDAFFFEFEFEFFF8F8F8FFF5F5F5FFE2E2\r\n      E2FFD8D8D8FF6E6864E300000059000000110000000000000000000000000000\r\n      0000000000000000000000000016BD8E56FFFFFFFAFFFFFFF9FFCDA778FF3E2D\r\n      19830000002500000017000000160000001600000027008946FF37D3A2FF00BB\r\n      76FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n      FFFF00BB76FF38D3A2FF008947FF000000150000000000000016B47A07FFFFFF\r\n      FFFFE5D5ADFFE6D6AFFFE6D6AFFFE6D6AFFFE6D6AFFFE6D6AFFFE6D6AFFFE8D6\r\n      B0FFEDD8B2FFFCDCB7FF48A063FF00A271FFB4F1EFFF008138FFFFE2C0FFFFDE\r\n      BAFFEED7B1FFB6C699FF96BA89FF008943FF29A775FFB0ECE7FF37CBB4FF00BC\r\n      9EFF00AB81FF005B2FBD000000140000000000000016B47906FFFFFFFFFFFFFD\r\n      F7FFFFFCF5FFFFFCF5FFFFFCF5FFFFFCF5FFFFFDF6FFFFFFFBFFD6BB9CFFFFFF\r\n      FBFFFFFDF7FFFFFFFAFFFFFFFFFF53B080FF00A371FFB4F2EFFF008036FFFFFF\r\n      FFFFFFFFFFFFFFFFFDFFABB38EFFA8D8BDFF038F4DFF29A775FFB0EDE7FF37CB\r\n      B4FF00BC9EFF00AB81FF005B2FBD0000001400000000000000000701000D8944\r\n      1FEDD09D89FFC69B8DFFE8CEC6FFDAB0A2FFD6A99BFFD1A294FFD7AEA3FFCC9B\r\n      8DFFCB9A8BFFCB998BFFCB9B8CFFCE9E8FFFEDDCD6FFEEDBD6FFD6A798FFD9AC\r\n      9DFFE1BEB3FFCFA18EFFA86E4DFFF0EFEFFFBDB8B4FFBDB7B3FFBBB6B2FFBAB5\r\n      B0FFABA6A1FFA5A09CFF1F1C1A9C0000002C0000000000000000000000000000\r\n      0000000000030000000C00000025B47B3EFFFFFFF7FFFFFFF0FFFFFEEDFFC498\r\n      65FF0E0B055800000043000000430000004300000048008844FF69DBB8FF00BB\r\n      77FF00B973FF00B770FF00B267FFFFFFFFFFFFFFFFFF00B267FF00B770FF00B9\r\n      73FF00BB77FF6DDCB9FF008946FF0000000F0000000000000016B47907FFFFFF\r\n      FFFFFBF8F1FFFBF8F0FFFBF8F1FFFBF8F1FFFBF8F1FFFCF8F1FFFEF9F3FFFFFA\r\n      F3FFFFFAF4FFFFFCF6FFFFFFFCFF51AE7CFF00A277FF008036FFFFFFFFFFFFFB\r\n      F5FFFFFAF3FFFFFBF4FFFFFDF8FFFFF8F1FF018F4DFF59C1A2FFA3E7E0FF00B3\r\n      98FF00B69CFF008B46FF000000160000000000000016B47907FFFFFFFFFFFFFF\r\n      F9FFFFFFF8FFFFFFF8FFFFFFF8FFFFFFF8FFFFFFF9FFFFFFFDFFD7BD9FFFFFFF\r\n      FFFFFFFFFCFFFFFFFCFFFFFFFFFFFFFFFFFF459A61FF00A47AFF008037FFFFFF\r\n      FFFFFFFFFFFFFFFFFFFFE0C0A4FFFFFFFFFFFFFFFFFF028F4DFF5AC2A3FFA3E7\r\n      E0FF00B398FF00B69CFF008B46FF000000160000000000000000511D019BBA70\r\n      53FFD3AFA2FFB8968CFFD7ADA0FFBE7E6AFFB5705BFFAF6651FFBC826FFFA659\r\n      43FFA4563FFFA3553FFFA55741FFA85B46FFC28C7CFFB5705BFFC38977FFD5A9\r\n      9BFFE4C6BCFFD8AB9CFFAC6949FFCAA997FFF9F9F9FFF9F9F9FFF9F9F9FFF9F9\r\n      F9FFF8F8F8FFC5C3C0FE59514CDA000000400000000000000000000000000000\r\n      0005000000160000002E00000044C89E6DFFFFFFF4FFFFFCEBFFFFFFEFFFF6EC\r\n      D5FFB88247FFB57D41FFB67E42FFB97E42FFC57E43FF27823EFF57C49CFF27C8\r\n      94FF00BA77FF00B977FF00B46DFFFFFFFFFFFFFFFFFF00B46DFF00B977FF00BA\r\n      77FF29C895FF62C7A0FF006635C4000000060000000000000016B47907FFFFFF\r\n      FFFFF9F5EBFFF8F4EAFFF8F5EAFFF8F5EAFFFAF5EBFFFFF7EEFFFFFBF4FFFFFD\r\n      F8FFFFFEF9FFFFFEF9FFFFFFFAFFFFFFFCFF4EAF7CFF00792EFFFFFCF5FFFBF6\r\n      ECFFF9F5EAFFFAF5EBFFFEF7EDFFFFFBF3FFA5D8C3FF139B63FFBFF2F2FFA0E8\r\n      E5FFA9EDEDFF008A46FF000000100000000000000016B47A07FFFFFFFFFFD4B9\r\n      98FFD4BA98FFD5BA99FFD5BA99FFD5BA99FFD5BA9AFFD8BD9DFFDFC2A4FFE8C3\r\n      A7FFEDC4A8FFEFC4A8FFF0C5A9FFF2C6ABFFF8C8AEFF439A62FF007B31FFE6BF\r\n      A1FFD8BB9BFFD7BD9DFFDAC0A1FFDDBFA0FFE7C1A3FF8BAA7EFF129C64FFBCF1\r\n      F1FF9EE7E4FFA8EDEDFF008A46FF000000100000000011050022A85A39FDC585\r\n      6DFF987267FFC38B7AFFB87763FFAA604AFFA2533CFFA1523CFFCEA89DFF9C4E\r\n      39FF8F371FFF8F361EFF903820FF933D25FFA8614EFFAC6552FF99523EFFB064\r\n      4CFFC58B79FFD1AA9FFFD19E8BFF9C542FFFF5F2F1FFF8F8F8FFF8F8F8FFF8F8\r\n      F8FFF7F7F7FFE6E6E6FF7A726DEF000000450000000000000000000000050000\r\n      0019000000386C4E2BB4BB864CFFE6D0B1FFFFFFEFFFFFFBE9FFFFFBEAFFFFFF\r\n      EEFFFFFFF4FFFFFFF7FFFFFFF8FFFFFFF8FFFFFFFAFFCBE7CDFF008B48FF87E0\r\n      C2FF1BC38AFF00B773FF00B36CFFFFFFFFFFFFFFFFFF00B36CFF00B773FF1CC4\r\n      8BFF8DE2C6FF0B9456FF001B0F3E000000010000000000000016B47907FFFFFF\r\n      FFFFF7F2E7FFF7F2E6FFF7F2E6FFF7F2E6FFFAF4E8FFF5F1E3FF0F9455FF007C\r\n      35FF007C36FF007C36FF007B33FFC4DCC6FFFFFBF4FFFFF9F0FFFEF5EAFFF8F2\r\n      E7FFF8F2E7FFFEF5EAFFFFF8EFFFFFFAF3FFCCECE2FF00833DFF008742FF0088\r\n      42FF008A45FF008448F0000000050000000000000016B47907FFFFFFFFFFFFFE\r\n      F3FFFFFEF3FFFFFEF3FFFFFEF3FFFFFEF3FFFFFEF4FFFFFFFAFFD6BF9FFF159C\r\n      61FF00813BFF00813CFF00823DFF00823BFFADB48DFFFFFFFFFFFFFFFBFFFFFF\r\n      F6FFFFFFF5FFFFFFF9FFDEBE9FFFFFFFFFFFFFFFFFFFCBE4CFFF007B31FF007E\r\n      36FF00853FFF008946FF008346EE0000000500000000541F039FB35D3EFFB25C\r\n      3DFF664235FF9C6A5CFFA2543DFF98442DFF913922FFB27767FFF0E5E2FFD1AF\r\n      A6FFA35D4BFF9F5845FF9D6150FFBB8D7BFFA76350FFAC6C5AFF883923FF9D4E\r\n      38FF8D4E3CFFA06B59FFB7684BFFB77055FFC8A795FFF7F7F7FFF7F7F7FFF7F7\r\n      F7FFF6F6F6FFE5E5E5FF877F79FA000000440000000000000003000000160000\r\n      0038A67541EDD0A97CFFFFFEEFFFFFFFF0FFFFFCEBFFFFFAE9FFFFFAE9FFFFFB\r\n      E9FFFFFCEAFFFFFCEBFFFFFCEBFFFFFCEBFFFFFDEDFFFFFFF4FF4EAF7CFF0091\r\n      51FF91E1C5FF5AD4AAFF09BC7DFF00B067FF00B067FF0ABC7EFF5BD4ACFF96E4\r\n      C9FF139A5DFF00512A9C00000003000000000000000000000016B47907FFFFFF\r\n      FFFFF6F1E4FFF6F1E3FFF6F1E3FFF6F1E3FFFBF3E6FFFAF0E4FF007C35FF0DE9\r\n      AAFF00E4A1FF00E4A0FF009F58FFA5CDAEFFFFF8EEFFFCF4E7FFF8F2E4FFF6F1\r\n      E3FFF9F2E5FFFFF8EEFF00782EFF4EAD7DFFFFFFFFFFD47B05FF000000160000\r\n      00000000000000000000000000000000000000000016B47907FFFFFFFFFFFFFA\r\n      EDFFFEF9ECFFFEF9ECFFFEF9ECFFFEF9ECFFFFFAEDFFFFFFF5FFDBBE9DFF0081\r\n      3BFF0EEBACFF00E5A2FF00E5A1FF00A15CFF91AA7EFFFFFFFAFFFFFBF0FFFFFA\r\n      EDFFFFFAEEFFFFFEF4FFE8C0A2FF007D34FF52B082FFFFFFFFFFFFFFFDFFFFFF\r\n      FFFFD17B04FF00000016000000000000000001000002974925F4B15A3AFFB86C\r\n      50FFA46B57FF87645AFF9B5C4CFF9F5643FF944631FF964631FFC5998DFFA864\r\n      52FF8F381FFF923D25FFBB9A8FFFD9BEB3FFD4B5A9FFC09789FFAB6A58FFAE6F\r\n      5DFF7D5A50FFA76D59FFB15A3AFFB46143FFA46746FFF5F5F5FFF5F5F5FFF4F4\r\n      F4FFF3F3F3FFE2E2E2FF877F79FA00000044000000000000000D0000002EA676\r\n      43ECD6B288FFFFFFF5FFFFFEECFFFFFBE7FFFFF9E5FFFFF9E5FFFFF9E5FFFFF9\r\n      E5FFFFF9E5FFFFF9E5FFFFF9E5FFFFF9E5FFFFF9E6FFFFFCE9FFFFFFF2FF63B7\r\n      87FF008946FF51BF94FF8EDFC3FF9AE5CCFF9AE5CCFF8FE0C4FF55C299FF0093\r\n      54FF004F2A9C0000000300000000000000000000000000000016B47907FFFFFF\r\n      FFFFF5EFE0FFF5EFE0FFF5EFE0FFF5EFE0FFF9F1E2FFFFF7EDFF007B34FF2FE4\r\n      B1FF0CDEA2FF00DD9BFF00C786FF0D8D4EFFFFF2E6FFFFF5E9FFFEF2E5FFFBF1\r\n      E3FFFDF2E5FFFFF9EFFF007E37FF00BE79FF5FBA99FFD87E0BFF0000001D0000\r\n      00030000000000000000000000000000000000000016B47907FFFFFFFFFFFFF9\r\n      EAFFFEF8E9FFFEF8E9FFFEF8E9FFFEF8E9FFFFF9EAFFFFFEF1FFEDC1A2FF0080\r\n      39FF30E4B2FF0CDEA2FF00DD9CFF00C887FF098746FFFFFDF0FFFFFEF2FFFFFB\r\n      EDFFFFFAECFFFFFFF3FFF1C3A4FF00823DFF00BE78FF57AD7DFFFFFFF8FFFFFF\r\n      FFFFBE7A06FF0000001600000000000000001C090037AF5C3CFFBA7155FFC286\r\n      6EFFCA9986FFC49D8EFF3F1003FF80220AFF8B3218FF984931FFA9634FFF9D4E\r\n      36FF9F523AFF974E38FFDEC9C0FFE0C9C1FFDEC6BDFFCDACA0FF913E26FF7B1A\r\n      00FF591F0FFFB28271FFB97359FFB5684EFF984B24FFEDE9E7FFF0F0F0FFEFEF\r\n      EFFFEEEEEEFFDFDFDFFF867E77F900000044000000040000001B6E4E2EB0D3AB\r\n      7BFFFFFFF3FFFFFAE7FFFFF8E3FFFFF7E2FFFFF7E2FFFFF7E2FFFFF7E2FFFFF7\r\n      E2FFFFF7E2FFFFF7E2FFFFF7E2FFFFF7E2FFFFF7E2FFFFF8E3FFFFFAE6FFFFFE\r\n      ECFFC7E0C1FF3BA56DFF007B33FF007C35FF007C35FF007D35FF329355FF575A\r\n      32C20000001C0000000300000000000000000000000000000016B47907FFFFFF\r\n      FFFFF4EEDDFFF4EEDDFFF4EEDDFFF4EEDDFFF6EFDFFFFFF4E6FF4FA978FF2AC3\r\n      91FF2FE0B1FF00D499FF00D89EFF00A05FFF0D8D4EFFA5CBABFFC3D9BFFFFFF8\r\n      ECFFFFF8ECFFFFFDF4FF00813BFF00DEA3FF00BB80FF4B8430FF000000330000\r\n      00140000000400000000000000000000000000000016B47907FFFFFFFFFFFFFB\r\n      EBFFFFFAEBFFFFFBECFFFFFBECFFFFFBECFFFFFBEDFFFFFFF2FFE7C09FFF56B4\r\n      85FF2AC493FF2FE0B1FF00D599FF00D89EFF00A05FFF0D8E4FFFABD0B1FFCCDF\r\n      C6FFFFFFF7FFFFFFFBFFFFC5A8FF00843FFF00DDA3FF00B675FF57AE7CFFFFFF\r\n      FFFFBD7C0AFF00000016000000000000000036140069BA7156FFC38972FFCC9E\r\n      8DFFD4B2A5FFD7BCB2FF7E584DFF5F2717FF994931FFAA634DFFB67763FFB16F\r\n      59FFB97C67FFAC7765FFE8D8D2FFE7D5CFFFE5D2CAFFE2CDC5FFDCC4BBFF913D\r\n      26FF781D05FFA15945FFA0523CFFBD8574FFA45F3FFFD8C8BEFFEBEBEBFFEBEB\r\n      EBFFE9E9E9FFDDDDDDFF867F77F9000000440000000C07060437C18C53FFFFFA\r\n      E9FFFFF9E7FFFFF6E0FFFFF5DFFFFFF5DFFFFFF5DFFFFFF5DFFFFFF5DFFFFFF5\r\n      DFFFFFF5DFFFFFF5DFFFFFF5DFFFFFF5DFFFFFF5DFFFFFF5DFFFFFF5E0FFFFF7\r\n      E1FFFFF9E5FFFFFCE9FFFFFEECFFFFFFEDFFFFFFEDFFFFFFF1FFFFFDEDFFCF8C\r\n      54FF060403340000000C00000000000000000000000000000016B47A07FFFFFF\r\n      FFFFF4ECDAFFF4ECD9FFF4ECDAFFF4ECDAFFF5ECDBFFFDEFDFFFD3DDC5FF0290\r\n      51FF6EE7CBFF0BD3A2FF00D099FF00D49DFF00BF85FF009F5FFF00853FFF007E\r\n      38FF007E38FF00813AFF00813CFF00D6A0FF00D6A1FF00B981FF00572FBF0000\r\n      002E0000000D00000000000000000000000000000016B47A07FFFFFFFFFFD4B4\r\n      8FFFD4B691FFD5B692FFD5B692FFD5B692FFD5B692FFD8B996FFE1BE9CFFBBB4\r\n      8BFF029154FF6EE8CBFF0BD3A2FF00D099FF00D49DFF00BF85FF009F5EFF0084\r\n      3EFF007D37FF007E38FF00823DFF00823EFF00D6A0FF00D49DFF00B275FF5DBA\r\n      98FFCE7E0DFF00000016000000000000000054250F94C38870FFCC9F8EFFD5B5\r\n      A9FFDBC2B8FFE0C9C1FFDECAC2FF8B675CFFBA816EFFCC9F90FFD0A89AFFD0A7\r\n      99FFD0A698FFC9ACA2FFF2EAE7FFF1E6E2FFEDE1DDFFE8D8D2FFE5D2CAFFBA85\r\n      73FF85321AFF774030FFA26250FFA95E47FF994C2BFFCAB2A4FFE7E7E7FFE6E6\r\n      E6FFE5E5E5FFDADADAFF867F77F9000000430000001271502FAEDEBB93FFFFFC\r\n      E9FFFFF4DCFFFFF3DBFFFFF3DBFFFFF3DBFFFFF3DBFFFFF3DBFFFFF3DBFFFFF3\r\n      DBFFFFF3DBFFFFF3DBFFFFF3DBFFFFF3DBFFFFF3DBFFFFF3DBFFFFF3DBFFFFF3\r\n      DBFFFFF3DCFFFFF4DDFFFFF5DDFFFFF5DDFFFFF5DDFFFFF6DEFFFFFCEAFFE0BB\r\n      93FF72502FAE0000001200000000000000000000000000000016B47A07FFFFFF\r\n      FFFFF3EBD7FFF3EBD6FFF3EBD7FFF3EBD7FFF3EBD7FFF6EDD9FFFFF0DFFF6FB7\r\n      8AFF41B083FF84E8D2FF18D2A7FF00CC98FF00CD9AFF00CF9CFF00D09DFF00D0\r\n      9EFF00D19EFF00D19FFF00D09EFF00CE9CFF00CE9CFF00D19FFF00B881FF005D\r\n      31C00000001200000000000000000000000000000016B47907FFFFFFFFFFFFF9\r\n      E6FFFFFAE6FFFFFAE7FFFFFAE7FFFFFAE7FFFFFAE8FFFFFDECFFDABA95FFFFFF\r\n      F2FF76BD92FF40B082FF83E8D2FF18D2A7FF00CB98FF00CD9AFF00CF9CFF00D0\r\n      9DFF00D09EFF00D19EFF00D19FFF00D09EFF00CE9CFF00CD9BFF00CF9DFF00B5\r\n      7EFF438734FF000000160000000000000000653218ABCB9C8AFFD5B4A8FFDCC2\r\n      B8FFE1CBC2FFE1CEC7FF6B483EFFAC6F5BFFC79584FFD0A698FFD1A899FFCFA3\r\n      93FFCFA494FFCAB4ADFFF9F4F3FFF8F2F0FFF6EFECFFF3EAE7FFEDDFDAFFE3CF\r\n      C8FFB88978FF9F5F4EFF9A685AFFB47561FF9B4C2DFFC1A291FFE2E2E2FFE1E1\r\n      E1FFE0E0E0FFD7D7D7FF867E77F90000004200000016A97945E9F9E8D1FFFFF6\r\n      E0FFFFF1D8FFFFF1D8FFFFF1D8FFFFF1D8FFFFF1D8FFFFF1D8FFFFF1D8FFFFF1\r\n      D8FFFFF1D8FFFFF1D8FFFFF1D8FFFFF1D8FFFFF1D8FFFFF1D8FFFFF1D8FFFFF1\r\n      D8FFFFF1D8FFFFF1D8FFFFF1D8FFFFF1D8FFFFF1D8FFFFF1D8FFFFF6E0FFF9E8\r\n      D1FFA97945E90000001600000000000000000000000000000016B47A07FFFFFF\r\n      FFFFF2E9D3FFF2E9D3FFF2E9D4FFF2E9D4FFF2E9D4FFF3E9D4FFF7EBD7FFFFEF\r\n      DDFF50AB78FF44B084FF90E8D5FF54DDC1FF23D2ABFF1CCFA7FF00CEA3FF00CF\r\n      A4FF00CFA4FF00CEA3FF00CEA3FF00C698FF00C799FF00C99CFF62E6CDFF008A\r\n      46FF0000000D00000000000000000000000000000016B47907FFFFFFFFFFFFF6\r\n      E0FFFEF5E0FFFFF5E0FFFFF5E0FFFFF5E0FFFFF6E1FFFFF9E6FFD6B690FFFFFB\r\n      E8FFFFFCEAFF53AF7BFF42AF83FF90E7D5FF54DDC1FF23D2ABFF1CCFA7FF00CE\r\n      A3FF00CFA4FF00CFA4FF00CEA3FF00CEA3FF00C698FF00C799FF00C99BFF5BE6\r\n      CEFF008A49FF00000016000000000000000054291394D3AFA1FFDBC1B7FFE0CA\r\n      C2FFE2CFC8FFAF8F86FFA66F5CFFCDA293FFD1A698FFD6B1A4FFD7B3A7FFB79D\r\n      93FFB79C92FFE0D9D6FFFEFDFDFFFCFBFAFFFBF8F7FFF8F4F2FFF6EFEDFFE8DB\r\n      D6FFCDB0A6FF73483CFFC7AA9FFFB27665FFAB674DFFC5AB9DFFE1E1E1FFDCDC\r\n      DCFFDBDBDBFFD4D4D4FF867E77F90000004200000016C0874DFFFFFFEDFFFFF2\r\n      DAFFFFEFD4FFFFEFD4FFFFEFD4FFFFEFD4FFFFEFD4FFFFEFD4FFFFEFD4FFFFEF\r\n      D4FFFFEFD4FFFFEFD4FFFFEFD4FFFFEFD4FFFFEFD4FFFFEFD4FFFFEFD4FFFFEF\r\n      D4FFFFEFD4FFFFEFD4FFFFEFD4FFFFEFD4FFFFEFD4FFFFEFD4FFFFF2DAFFFFFF\r\n      EDFFC0874DFF0000001600000000000000000000000000000016B47A07FFFFFF\r\n      FFFFF1E8D0FFF1E8D0FFF1E8D1FFF1E8D1FFF1E8D1FFF1E8D1FFF2E8D2FFF7EA\r\n      D4FFFFEED9FF7EBC91FF1C9960FF52BD97FF90E5D3FF96EBDDFF49E9D1FF4CE9\r\n      D2FF4DE9D2FF4DE9D2FF4BE8D0FF93E7D7FF00C297FF5FDEC7FF00B181FF005E\r\n      30B30000000400000000000000000000000000000016B47907FFFFFFFFFFFFF5\r\n      DEFFFFF3DEFFFFF4DEFFFFF4DEFFFFF4DEFFFFF5DFFFFFF8E3FFD5B68EFFFFF9\r\n      E4FFFFF7E3FFFFFBE8FF88C398FF1D9A60FF52BE98FF90E5D4FF96ECDEFF49E9\r\n      D2FF4CEAD3FF4DEAD3FF4DE9D2FF4BE8D1FF93E7D7FF00C197FF5ADDC4FF00AF\r\n      7EFF438734FF0000001600000000000000003613006AB98470FFD7BAAFFF9563\r\n      56FF93462EFFB3735FFFD1A99BFFD5AFA2FFD8B3A7FFE0C2B7FFF0E8E6FFF8F0\r\n      EDFFF7EEEBFFF7EFECFFF9F2F0FFFBF7F6FFFFFFFFFFFDFBFAFFFAF7F5FFCABB\r\n      B5FFDFD0CAFFA99088FFD3B9B0FFD9BEB4FFB47A62FFCDBCB2FFDDDDDDFFDCDC\r\n      DCFFD7D7D7FFD1D1D1FF867E77F90000004200000016C1884EFFFFFBEBFFFFF0\r\n      D5FFFFEDD1FFFFEDD1FFFFEDD1FFFFEDD1FFFFEDD1FFFFEDD1FFFFEDD1FFFFED\r\n      D1FFFFEDD1FFFFEDD1FFFFEDD1FFFFEDD1FFFFEDD1FFFFEDD1FFFFEDD1FFFFED\r\n      D1FFFFEDD1FFFFEDD1FFFFEDD1FFFFEDD1FFFFEDD1FFFFEDD1FFFFF0D5FFFFFB\r\n      EBFFC1884EFF0000001600000000000000000000000000000016B47A07FFFFFF\r\n      FFFFF0E5CCFFF0E6CDFFF0E6CEFFF0E6CEFFF0E6CEFFF0E6CEFFF0E6CEFFF1E6\r\n      CEFFF5E8D0FFFDEAD4FFF2E5CEFF6CB485FF0F9151FF007C33FF007C34FF007D\r\n      34FF007D35FF007E37FF007E36FF80E4D5FF55DAC4FF00AE7EFF00582DAE0000\r\n      00030000000000000000000000000000000000000016B47A07FFFFFFFFFFFFF6\r\n      DEFFFFF6DFFFFFF7E0FFFFF7E0FFFFF7E0FFFFF7E0FFFFFAE4FFD5B78EFFFFFA\r\n      E4FFFFF8E1FFFFF8E2FFFFFCE7FFFFF8E2FF609E66FF14995AFF008038FF0081\r\n      39FF008139FF00813AFF00823BFF008038FF80E4D5FF54D8C2FF00A875FF5BBB\r\n      97FFCD800DFF000000160000000000000000220B0042B7846DFF842811FF6C28\r\n      15FF984D36FFD8B8ACFFD9B7ABFFDEC1B5FFE3C9BFFFEFDED8FFF3E7E2FFF2E2\r\n      DDFFF1E1DBFFF1E2DCFFF2E5DFFFF5EAE6FFF9F2EFFFFDFBFAFFEEEAE9FFE3DB\r\n      D8FFD8CDC8FFE6D7D0FFE4D1CAFFDEC6BDFFA36244FFDAD5D2FFDDDDDDFFD9D9\r\n      D9FFD6D6D6FFCFCFCFFF857D76F80000004200000016C2894EFFFFFAE9FFFFEC\r\n      CEFFFFEBCCFFFFEBCDFFFFEBCDFFFFEBCDFFFFEBCDFFFFEBCDFFFFEBCDFFFFEB\r\n      CDFFFFEBCDFFFFEBCDFFFFEBCDFFFFEBCDFFFFEBCDFFFFEBCDFFFFEBCDFFFFEB\r\n      CDFFFFEBCDFFFFEBCDFFFFEBCDFFFFEBCDFFFFEBCDFFFFEBCCFFFFECCEFFFFFA\r\n      E9FFC2894EFF0000001600000000000000000000000000000016B47A07FFFFFF\r\n      FFFFEEE3C9FFEFE4CAFFEFE4CBFFEFE4CBFFEFE4CBFFEFE4CBFFEFE4CBFFEFE4\r\n      CBFFF0E4CBFFF1E5CCFFF5E6CEFFFCE8D1FFFFEAD3FFFFEAD4FFFFEAD3FFFFEA\r\n      D4FFFFECD6FFFFF1DDFF008139FF71E0D5FF00A87CFF46852FFF000000160000\r\n      00000000000000000000000000000000000000000016B47A08FFFFFFFFFFD3B1\r\n      87FFD3B38AFFD4B38AFFD4B38AFFD4B38AFFD4B48BFFD6B68EFFD7B890FFD6B6\r\n      8EFFD4B48BFFD5B38BFFD6B58CFFDCB890FFE3BC96FFE8BC97FFEBBC97FFEDBC\r\n      97FFEEBC98FFF1BE9AFFFFC3A0FF00843DFF71E0D5FF00A374FF429354FFFFFF\r\n      FFFFBC7C0BFF00000016000000000000000003000005AD775EF993422CFF8546\r\n      33FF794534FFDEC0B7FFE1C6BCFFE2C6BDFFE4C9C0FFEBD5CEFFEFDDD6FFEDD9\r\n      D1FFECD8D0FFECD8D1FFEEDBD4FFF1E1DBFFF4E8E3FFF8F0EEFFE0D9D7FFFDFC\r\n      FCFFF3EEEDFFEFE3DEFFE8D7D1FFE0CBC2FF9E613FFFDFDFDFFFDCDCDCFFD9D9\r\n      D9FFD4D4D4FFCFCFCFFF847D76F80000004100000016C38B4FFFFFFAE8FFFFEC\r\n      CFFFFFE9C9FFFFE9CAFFFFE9CAFFFFE9CAFFFFE9CAFFFFE9CAFFFFE9CAFFFFE9\r\n      CAFFFFE9CAFFFFE9CAFFFFE9CAFFFFE9CAFFFFE9CAFFFFE9CAFFFFE9CAFFFFE9\r\n      CAFFFFE9CAFFFFE9CAFFFFE9CAFFFFE9CAFFFFE9CAFFFFE9C9FFFFECCFFFFFFA\r\n      E8FFC38B4FFF0000001600000000000000000000000000000016B47A07FFFFFF\r\n      FFFFEDE2C6FFEEE3C7FFEEE3C8FFEEE3C8FFEEE3C8FFEEE3C8FFEEE3C8FFEEE3\r\n      C8FFEEE3C8FFEEE3C8FFEFE3C8FFF0E4C9FFF0E3C7FFF9F0E3FFFFFFFFFFFFFF\r\n      FFFFFFFFFFFFFFFFFFFF00833CFF00A57DFF5BBD99FFCF800DFF000000160000\r\n      00000000000000000000000000000000000000000016B47A07FFFFFFFFFFFFF3\r\n      D9FFFFF4DBFFFFF5DCFFFFF5DCFFFFF5DCFFFFF5DDFFFFF8E0FFD5B58CFFFFF8\r\n      E0FFFFF5DDFFFFF5DCFFFFF5DDFFFFF8E0FFD7B58DFFFFF9E2FFFFF6DFFFFFF6\r\n      DEFFFFF6DFFFFFFBE4FFF0BD98FF00843EFF00A37AFF53AB74FFFFF9E1FFFFFF\r\n      FFFFB57A08FF00000016000000000000000000000000643114B0C69D8FFFAD6E\r\n      5BFF704D42FFD3C0B9FFE4CAC2FFE6CFC6FFE9D3CAFFEBD6CEFFEFDDD6FFEDD9\r\n      D1FFECD8D0FFEDD8D1FFEEDAD3FFECDBD4FFF0E1DBFFF2E7E4FFF5EFEDFFFEFE\r\n      FEFFFCFAFAFFF3EBE7FFEBDDD7FFD1B0A3FFB6917AFFE0E0E0FFDEDEDEFFDBDB\r\n      DBFFD8D8D8FFD0D0D0FF847C77F80000004100000012C58C51FFFFFAEAFFFFEC\r\n      CFFFFFE7C6FFFFE7C7FFFFE7C7FFFFE7C7FFFFE7C7FFFFE7C7FFFFE7C7FFFFE7\r\n      C7FFFFE7C7FFFFE7C7FFFFE7C7FFFFE7C7FFFFE7C7FFFFE7C7FFFFE7C7FFFFE7\r\n      C7FFFFE7C7FFFFE7C7FFFFE7C7FFFFE7C7FFFFE7C7FFFFE7C6FFFFECCFFFFFFA\r\n      EAFFC58C51FF0000001200000000000000000000000000000016B47A07FFFFFF\r\n      FFFFECE0C3FFEDE1C4FFEDE1C5FFEDE1C5FFEDE1C5FFEDE1C5FFEDE1C5FFEDE1\r\n      C5FFEDE1C5FFEDE1C5FFEDE1C5FFEDE1C4FFECDFC2FFFFFFFFFFCFAA5FFFAE6E\r\n      00FFB06F00FFBE7200FF00813AFF307A1EFFFFFFFFFFBD7E0DFF000000100000\r\n      00000000000000000000000000000000000000000016B47907FFFFFFFFFFFEF1\r\n      D3FFFDF0D3FFFDF1D4FFFDF1D4FFFDF1D4FFFEF2D5FFFFF5D9FFD4B387FFFFF5\r\n      D9FFFEF2D5FFFDF1D4FFFEF2D5FFFFF5D9FFD4B387FFFFF5D9FFFEF2D5FFFDF1\r\n      D4FFFEF2D5FFFFF6DBFFE6BA91FF007E37FF4EAC75FFFFF8DDFFFFF3D6FFFFFF\r\n      FFFFB47907FF0000001600000000000000000000000019080031C7A08FFFEDDE\r\n      DAFFA36F5DFFC7BCB8FFD8C9C4FFE9D6CFFFEDDBD3FFEFDED7FFF2E3DDFFF2E3\r\n      DCFFE2D5D0FFDAD2CEFFDDD1CCFFD4CAC7FFE2D6D2FFE3D9D5FFF7F0EDFFFCF9\r\n      F8FFFDFDFCFFF5EEEBFFEEE1DDFFAC7256FFE0DBD8FFE3E3E3FFE1E1E1FFDFDF\r\n      DFFFDBDBDBFFD3D3D3FF847C76F8000000410000000CAE7E4AE6F9E5CEFFFFEE\r\n      D5FFFFE5C2FFFFE5C3FFFFE5C3FFFFE5C3FFFFE5C3FFFFE5C3FFFFE5C3FFFFE5\r\n      C3FFFFE5C3FFFFE5C3FFFFE5C3FFFFE5C3FFFFE5C3FFFFE5C3FFFFE5C3FFFFE5\r\n      C3FFFFE5C3FFFFE5C3FFFFE5C3FFFFE5C3FFFFE5C3FFFFE5C2FFFFEED5FFF9E5\r\n      CEFFAE7E4AE60000000C00000000000000000000000000000016B47A07FFFFFF\r\n      FFFFEBDFBFFFECE0C1FFECE0C2FFECE0C2FFECE0C2FFECE0C2FFECE0C2FFECE0\r\n      C2FFECE0C2FFECE0C2FFECE0C2FFECE0C1FFEBDEBFFFFFFFFFFFAD6E00FFFFFF\r\n      FFFFFEFDFBFFFEF5E9FFFFEDD9FFFFFFFFFFF1DCBDFFA87511EA000000050000\r\n      00000000000000000000000000000000000000000016B47907FFFFFFFFFFFEF0\r\n      D1FFFDEFD1FFFDF0D2FFFDF0D2FFFDF0D2FFFEF1D3FFFFF4D7FFD4B286FFFFF4\r\n      D7FFFEF1D3FFFDF0D2FFFEF1D3FFFFF4D7FFD4B286FFFFF4D7FFFEF1D3FFFDF0\r\n      D2FFFEF1D3FFFFF5D8FFDBB48AFFFFFAE0FFFFF6DAFFFFF2D4FFFFF1D1FFFFFF\r\n      FFFFB47907FF0000001600000000000000000000000000000000663315B3EEE1\r\n      DCFFF4ECE9FFDECFCAFFD4CCC9FFD5CDCAFFE4D8D4FFF1E4DFFFF6EAE6FFF7EE\r\n      E9FFF5EBE7FFF5EDEAFFF1E8E4FFF0E1DBFFF2E5E0FFE7DDDAFFF7EFECFFFBF7\r\n      F5FFFFFFFFFFF7F2F0FFDEC7BDFFBA937CFFE8E8E8FFE6E6E6FFE4E4E4FFE1E1\r\n      E1FFDFDFDFFFD5D5D5FF847C76F80000004100000004745533A0E3BC94FFFFF5\r\n      E3FFFFE4BFFFFFE4BFFFFFE4C0FFFFE4C0FFFFE4C0FFFFE4C0FFFFE4C0FFFFE4\r\n      C0FFFFE4C0FFFFE4C0FFFFE4C0FFFFE4C0FFFFE4C0FFFFE4C0FFFFE4C0FFFFE4\r\n      C0FFFFE4C0FFFFE4C0FFFFE4C0FFFFE4C0FFFFE4BFFFFFE4BFFFFFF5E3FFE3BC\r\n      94FF745533A10000000400000000000000000000000000000016B47A08FFFFFF\r\n      FFFFEADCBCFFEBDEBEFFEBDEBFFFEBDEBFFFEBDEBFFFEBDEBFFFEBDEBFFFEBDE\r\n      BFFFEBDEBFFFEBDEBFFFEBDEBFFFEBDEBEFFEADCBCFFFFFFFFFFAE6F00FFFDFD\r\n      FBFFF6EFDFFFF1E6CDFFFFFFFFFFEBD8B6FFA16D09E500000005000000000000\r\n      00000000000000000000000000000000000000000016B47A08FFFFFFFFFFFFF2\r\n      D1FFFFF2D2FFFFF3D4FFFFF3D4FFFFF3D4FFFFF3D4FFFFF6D8FFD7B486FFFFF6\r\n      D8FFFFF3D4FFFFF3D4FFFFF3D4FFFFF6D8FFD7B486FFFFF6D8FFFFF3D4FFFFF3\r\n      D4FFFFF3D4FFFFF6D8FFD8B487FFFFF7D9FFFFF4D5FFFFF3D3FFFFF2D1FFFFFF\r\n      FFFFB47A08FF00000016000000000000000000000000000000000C0400189D64\r\n      46F5FDFBFAFFF8EFEDFFF5EFEDFFE5DFDCFFE2DCD9FFE4DFDCFFEEE7E4FFFAF4\r\n      F1FFF9F5F4FFFDFAF9FFFAF4F2FFF5EAE7FFF5EBE7FFF7EDEAFFF9F2EFFFFCF8\r\n      F6FFFDFBFAFFF5EEEBFFAA7153FFEBE9E8FFEBEBEBFFE9E9E9FFE6E6E6FFE3E3\r\n      E3FFE1E1E1FFD7D7D7FF847C76F80000003A0000000008060317CD955EFFFFF4\r\n      E2FFFFECD2FFFFE1BAFFFFE2BBFFFFE2BCFFFFE2BCFFFFE2BCFFFFE2BCFFFFE2\r\n      BCFFFFE2BCFFFFE2BCFFFFE2BCFFFFE2BCFFFFE2BCFFFFE2BCFFFFE2BCFFFFE2\r\n      BCFFFFE2BCFFFFE2BCFFFFE2BCFFFFE2BBFFFFE1BAFFFFECD2FFFFF4E2FFCD95\r\n      5EFF080603170000000000000000000000000000000000000016B47A08FFFFFF\r\n      FFFFE9DBB9FFEADDBBFFEADDBCFFEADDBCFFEADDBCFFEADDBCFFEADDBCFFEADD\r\n      BCFFEADDBCFFEADDBCFFEADDBCFFEADDBBFFE9DBB9FFFFFFFFFFAE6F00FFF9F4\r\n      EAFFF0E6CEFFFFFFFFFFE9D7B4FFA16D08E50000000500000000000000000000\r\n      00000000000000000000000000000000000000000016B57A08FFFFFFFFFFDEB2\r\n      7BFFE3B47DFFE4B57EFFE4B57EFFE4B57EFFE3B680FFE1B783FFE0B887FFE1B7\r\n      83FFE3B680FFE4B57EFFE3B680FFE1B783FFE0B887FFE1B783FFE3B680FFE4B5\r\n      7EFFE3B680FFE1B783FFE0B887FFE1B783FFE3B680FFE3B47DFFDEB27BFFFFFF\r\n      FFFFB57A08FF0000001600000000000000000000000000000000000000003D29\r\n      1D80AC7355FFF0E0DAFFF3E6E0FFF8F1EEFFF3EBE8FFF0E8E5FFF0EAE7FFF9F4\r\n      F2FFFAF6F4FFFDFBFAFFFAF6F3FFF7EEEAFFF6EDE9FFF8EFECFFF9F3F0FFF6EC\r\n      E8FFF8F2EFFFAC7355FFE9E1DCFFF0F0F0FFEEEEEEFFECECECFFE9E9E9FFE6E6\r\n      E6FFE4E4E4FFD3D3D3FF7B716BF30000002400000000000000037655359DDCB0\r\n      84FFFFF9EAFFFFE7C8FFFFDFB6FFFFE0B8FFFFE0B9FFFFE0B9FFFFE0B9FFFFE0\r\n      B9FFFFE0B9FFFFE0B9FFFFE0B9FFFFE0B9FFFFE0B9FFFFE0B9FFFFE0B9FFFFE0\r\n      B9FFFFE0B9FFFFE0B9FFFFE0B8FFFFDFB6FFFFE7C8FFFFF9EAFFDCB084FF7856\r\n      359E000000030000000000000000000000000000000000000016B47A08FFFFFF\r\n      FFFFE7D9B4FFE8D9B7FFE9DAB7FFE9DAB7FFE9DAB7FFE9DAB7FFE9DAB7FFE9DA\r\n      B7FFE9DAB7FFE9DAB7FFE9DAB7FFE8D9B7FFE7D9B4FFFFFFFFFFAE6E00FFF3EC\r\n      DAFFFFFFFFFFE9D7B4FFA26D08E6000000050000000000000000000000000000\r\n      00000000000000000000000000000000000000000016B67A07FFFFFFFFFF4CC5\r\n      FFFF55C8FFFF57C9FFFF57C9FFFF57C9FFFF55C9FFFF50CAFFFFEBB97EFF50CA\r\n      FFFF55C9FFFF57C9FFFF55C9FFFF50CAFFFFEBB97EFF50CAFFFF55C9FFFF57C9\r\n      FFFF55C9FFFF50CAFFFFEBB97EFF50CAFFFF55C9FFFF55C8FFFF4CC5FFFFFFFF\r\n      FFFFB67A07FF0000001600000000000000000000000000000000000000001714\r\n      1334927666FFA05E3CFFDBB6A8FFF0DED8FFF7EEEBFFF6ECE8FFF3EAE7FFEEEA\r\n      E8FFF7F1EFFFF9F3F1FFF8F0EDFFF6EBE7FFF6EDE9FFF8EFECFFF2E2DDFFDDBC\r\n      AFFFA1613DFFE7DBD4FFF7F7F7FFF5F5F5FFF1F1F1FFF0F0F0FFEDEDEDFFEAEA\r\n      EAFFDCDCDCFFBEBCBBFF564F49C900000006000000000000000000000005B883\r\n      52E7E1B78DFFFFF9EAFFFFEBD0FFFFDEB5FFFFDDB2FFFFDDB3FFFFDEB4FFFFDE\r\n      B4FFFFDEB4FFFFDEB4FFFFDEB4FFFFDEB4FFFFDEB4FFFFDEB4FFFFDEB4FFFFDE\r\n      B4FFFFDDB3FFFFDDB2FFFFDEB5FFFFEBD0FFFFF9EAFFE1B78DFFB88451E80000\r\n      0005000000000000000000000000000000000000000000000015B57A08FFFFFF\r\n      FFFFE7D7B1FFE7D7B2FFE8D8B3FFE8D8B3FFE8D8B3FFE8D8B3FFE8D8B3FFE8D8\r\n      B3FFE8D8B3FFE8D8B3FFE8D8B3FFE7D7B2FFE7D7B0FFFFFFFFFFAC6C00FFFFFF\r\n      FFFFEAD8B6FF744F06AC00000003000000000000000000000000000000000000\r\n      00000000000000000000000000000000000000000015B67B08FFFFFFFFFF4BC3\r\n      FFFF53C5FFFF55C6FFFF55C6FFFF55C6FFFF54C6FFFF4EC6FFFFE9B578FF4EC6\r\n      FFFF54C6FFFF55C6FFFF54C6FFFF4EC6FFFFE9B578FF4EC6FFFF54C6FFFF55C6\r\n      FFFF54C6FFFF4EC6FFFFE9B578FF4EC6FFFF54C6FFFF53C5FFFF4BC3FFFFFFFF\r\n      FFFFB67B08FF0000001500000000000000000000000000000000000000000000\r\n      00004E4640AD9F8B7EFF8F441BFFB87C62FFD5AC9CFFEFDED8FFF6ECE8FFF6EC\r\n      E9FFF5ECE8FFF7EFECFFF6EAE7FFF6EBE7FFEFDFD9FFDEB9ACFFBD876DFFAA77\r\n      5BFFDCD8D7FFDDDDDCFFDBDADAFFD9D9D8FFD7D6D5FFD4D3D2FFD1D1D0FFC6C5\r\n      C4FFADA9A5FF776D64FB18151338000000000000000000000000000000000000\r\n      0005B88451E6DEB285FFFFF4E5FFFFF4E3FFFFE8CBFFFFE2BDFFFFDBAFFFFFDB\r\n      AFFFFFDBAFFFFFDBAFFFFFDBAFFFFFDBAFFFFFDBAFFFFFDBAFFFFFDBAFFFFFDB\r\n      AFFFFFE2BDFFFFE8CBFFFFF4E3FFFFF4E5FFDEB285FFB88552E7000000050000\r\n      000000000000000000000000000000000000000000000000000DB67D0DFFFFFF\r\n      FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n      FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFEBDB\r\n      BCFF765008AE0000000300000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000DB67D0DFFFFFFFFFFFFFF\r\n      FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n      FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n      FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n      FFFFB67D0DFF0000000D00000000000000000000000000000000000000000000\r\n      00000000000023201E503E39338B573520B77A330CED9B502EFFBB8468FFD2A5\r\n      92FFDFBFB3FFDBB9ABFFCDA18DFFC08971FFB06E4FFF703413DE4B372AA13F39\r\n      358C3F39358C3F39358C3F39358C3F39358C3F39358C3F39358C3F39358C3F39\r\n      358C3C3631860D0C0B1F00000000000000000000000000000000000000000000\r\n      00000000000379583699D19961FFE6C09AFFFAE8D3FFFFFBEFFFFFFBEFFFFFFB\r\n      EFFFFFFBEFFFFFFBEFFFFFFBEFFFFFFBEFFFFFFBEFFFFFFBEFFFFFFBEFFFFFFB\r\n      EFFFFFFBEFFFFAE8D3FFE6C09AFFD19961FF7858379A00000003000000000000\r\n      00000000000000000000000000000000000000000000000000047F5B10B4B67D\r\n      0DFFB57A08FFB47A08FFB47A08FFB47A08FFB47A08FFB47A08FFB47A08FFB47A\r\n      08FFB47A08FFB47A08FFB47A08FFB47A08FFB47A08FFB47A08FFB57C0BFF7C55\r\n      0BB0000000040000000000000000000000000000000000000000000000000000\r\n      000000000000000000000000000000000000000000047F5B10B4B67D0DFFB67B\r\n      08FFB67A06FFB67A06FFB67A06FFB67A06FFB67A06FFB67A07FFB57A07FFB67A\r\n      07FFB67A06FFB67A06FFB67A06FFB67A07FFB57A07FFB67A07FFB67A06FFB67A\r\n      06FFB67A06FFB67A07FFB57A07FFB67A07FFB67A06FFB67A06FFB67B08FFB67D\r\n      0DFF7F5B10B40000000400000000000000000000000000000000000000000000\r\n      000000000000000000000000000000000000000000001508002A3B1400744B1B\r\n      00945D2100B7561F00A9481A008E3913006F0701000D00000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      000000000000000000000906030F7A58379AB58350E3D0945AFFCF9459FFCF94\r\n      59FFCF9459FFCF9459FFCF9459FFCF9459FFCF9459FFCF9459FFCF9459FFCF94\r\n      59FFD0945AFFB58350E37A58379A0906030F0000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000060000001000000010000000050000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0001000000060000000F000000150000001600000016000000150000000F0000\r\n      0006000000010000000000000000000000000000000000000000000000000000\r\n      00000000000000000000000000000000000000000000000000050000000C0000\r\n      0009000000020000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000001000000070000\r\n      000E000000130000001600000016000000160000001600000016000000130000\r\n      000E0000000700000001000000000000001100000031000000350000001A0000\r\n      0005000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000001000000070000\r\n      000E000000130000001600000016000000160000001600000016000000140000\r\n      0015000000220000003400000040000000430000004300000040000000340000\r\n      00200000000E0000000300000000000000000000000000000000000000000000\r\n      000000000000000000000000000000000000000000000000000C000000230000\r\n      0025000000170000000900000002000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000020000000900000015000000240000\r\n      00320000003C00000041000000430000004300000043000000410000003C0000\r\n      003200000024000000150000000900000018008E4EFF008045F1000000390000\r\n      0017000000030000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000020000000900000015000000240000\r\n      00320000003C00000041000000430000004300000043000000410000003D0000\r\n      003D001C0F6B006536D1008A48FF008948FF008948FF008A48FF006536D1001B\r\n      0E690000002D0000001200000003000000000000000000000000000000000000\r\n      000000000000000000000000000000000000000000000000000963676CED1C2B\r\n      36890000003D0000002900000016000000090000000200000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      000000000000000000000000000600000014000000280000003C311F077C7549\r\n      12C39C6116EAB26F19FFB26F18FFB36F18FFB46F19FFB56F19FF9F6217EA7749\r\n      12C3321F077C0000003C000000280000002B008C4BFF00C786FF007A40EC0000\r\n      0033000000140000000300000000000000000000000000000000000000000000\r\n      000000000000000000000000000600000014000000280000003C311F077C7549\r\n      12C39C6116EAB26F19FFB26F18FFB26F18FFB36F18FFB86F18FFAE6013E81E67\r\n      32D9009353FF00B678FF00CD90FF00D194FF00D194FF00CD90FF00B678FF0091\r\n      51FF00512BB40000002D0000000E000000010000000000000000000000000000\r\n      00000000000000000000000000000000000000000000000000021F2E39705E50\r\n      4AFF3C5466FB0E26398A0000003C000000280000001500000006000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      000000000000000000000000000000000000260600436B0E00BF6F1600C11504\r\n      0024000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      000000000001000000070000001C000000373D27098AAC6B19F9B77420FFC480\r\n      31FFCB883AFFD28D42FFD28D42FFD68E43FFDF8F44FFE69045FFE28A3CFFDA81\r\n      31FFCE741FFFC36A15F9462305870000004A008847FF00E5A6FF00C080FF0058\r\n      2EC1000000320000001400000003000000000000000000000000000000000000\r\n      000000000001000000070000001C000000373D27098AAC6B19F9B77420FFC480\r\n      31FFCB883AFFD28D42FFD18D41FFD28D42FFD58D42FFE28E43FF548942FF0097\r\n      57FF00CC90FF00CD90FF00C98AFF00C685FF00C685FF00C98AFF00CD8FFF00CB\r\n      8FFF009655FF00512BB100000020000000060000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000094661\r\n      75FA617580FF6EBEEDFF286A9BF8091E2F8A0000003A0000001C000000060000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      000000000000000000000A0000114D07008D8D1708F7BE7C6DFFA34026FF3107\r\n      0057000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0001000000080000001F070401469F6317EDBA7623FFCC883BFFD59047FFDB9B\r\n      4CFFDD9C4DFFE2A351FFE3A350FFEFA655FF45954FFF008948FF008948FF008A\r\n      49FF008A4AFF008B4BFF008A4AFF008847FF008341FF00DCA1FF00DBA0FF00BC\r\n      81FF00592EC10000003200000014000000040000000000000000000000000000\r\n      0001000000080000001F070401469F6317EDBA7623FFCC883BFFD59047FFDB9B\r\n      4CFFDD9C4DFFE2A351FFE2A250FFE3A250FFEBA554FFB59F54FF00904FFF00C9\r\n      8DFF00CA8CFF00C788FF00C380FFFFFFFFFFFFFFFFFF00C380FF00C788FF00CA\r\n      8CFF00C98DFF009250FF001B0E5D0000000F000000040000000D000000150000\r\n      0016000000160000001600000016000000160000001600000016000000180F2A\r\n      3E7173C6F1FFA9E5FFFF81CDFCFF4B96D0FF3A6C9DFF0000003D000000220000\r\n      0016000000160000001600000016000000160000001600000016000000160000\r\n      00150000000D0000000400000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000002203003C700400CFA33E30FFDEC2BEFFF6FBFDFFA54830FD2F07\r\n      0053000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      00070000001F140D0356B26E18FFC68435FFD6934AFFDC9B4CFFE1A759FFE3CE\r\n      A3FFE7EEE0FFE9FFFFFFECFFFFFFFDFFFFFF008039FF2FE7BCFF00DAA2FF00DA\r\n      A2FF00DAA2FF00DAA3FF00DAA2FF00D9A2FF00D8A0FF00D39CFF00D39CFF00D6\r\n      A0FF00BA80FF00592EC10000002E0000000D0000000000000000000000000000\r\n      00070000001F140D0356B26E18FFC68435FFD6934AFFDC9B4CFFE1A759FFE3CE\r\n      A3FFE7EEE0FFE9FFFFFFE9FFFFFFEBFFFFFFF9FFFFFF3CAF85FF00B06FFF00C8\r\n      8AFF00C586FF00C383FF00BE78FFFFFFFFFFFFFFFFFF00BE78FF00C383FF00C5\r\n      86FF00C88AFF00B373FF006736CD000000150000000D0000002B0000003F0000\r\n      0043000000430000004300000043000000430000004300000043000000430000\r\n      0048588DB5EEF3FFFFFFAADEFCFF55B6FCFF139BFFFF3A6C9DFF000000480000\r\n      0043000000430000004300000043000000430000004300000043000000430000\r\n      003F0000002B0000000D00000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000400\r\n      00084401007D891106F4C18279FFECE5E3FFEBE9EBFFEBE7E6FFA5462DFD2E07\r\n      0052000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000060000\r\n      001C130B0253B4701BFFD18F46FFD9974DFFE09E4CFFE2D3B0FFE6FFFFFFE5FF\r\n      FFFFE4FFFFFFE4FFFFFFE9FFFFFFFDFFFFFF007D34FF4EE4C1FF00CF9AFF00CF\r\n      9BFF00CF9BFF00CF9BFF00CF9BFF00CF9BFF00CF9BFF00CD9AFF00CD9AFF00CE\r\n      9BFF00D29FFF00B881FF005D31C0000000120000000000000000000000060000\r\n      001C130B0253B4701BFFD18F46FFD9974DFFE09E4CFFE2D3B0FFE6FFFFFFE5FF\r\n      FFFFE4FFFFFFE4FFFFFFE6FFFFFFEAFFFFFFFBFFFFFF007D35FF00C383FF00C3\r\n      82FF00BE7BFF00BC76FF00B86EFFFFFFFFFFFFFFFFFF00B86EFF00BC76FF00BE\r\n      7BFF00C383FF00C587FF008A49FF0000001600000015805A10C4B77E0EFFB67C\r\n      09FFB67B08FFB67B08FFB67B08FFB67B08FFB67B08FFB77B07FFBB7B03FFC17B\r\n      00FF807032FF75BAE0FFEBFBFFFF5CBCFFFF1297FFFF159BFFFF326BA4FFCF86\r\n      00FFBE8109FFB77D09FFB67B08FFB67B08FFB67B08FFB67B08FFB67C09FFB77E\r\n      0EFF805A10C40000001500000000000000000000000000000000000000000000\r\n      00000000000000000000000000000000000000000000000000001101001E5F00\r\n      00B39B2720FFDCBAB4FFF5FAFBFFE9E6E9FFE2D8D9FFECE9E9FFA5462DFD2E07\r\n      0052000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000002000000140705\r\n      0141B16E17FFD29148FFDB994FFFDFA255FFE2F3ECFFE4FFFFFFE5FFFFFFE3FF\r\n      FFFFE2FDFEFFE3FDFEFFEAFFFFFFB0ACB2FF008035FF69E5CBFF00C897FF00C8\r\n      98FF00C899FF00C899FF00C899FF00C899FF00C999FF00C999FF00C99AFF00C9\r\n      99FF06CDA1FF2BDCB7FF008A47FF0000000D0000000000000002000000140705\r\n      0141B16E17FFD29148FFDB994FFFDFA255FFE2F3ECFFE4FFFFFFE5FFFFFFE3FF\r\n      FFFFE2FDFEFFE3FDFEFFE6FFFFFF9DA3A4FFFDFFFFFF007E36FF16CB93FF00BD\r\n      79FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n      FFFF00BD79FF1ACD96FF008948FF0000001600000016B77E0EFFF7FFFFFFF3F8\r\n      FFFFF2F7FFFFF2F7FFFFF2F7FFFFF2F7FFFFF2F7FFFFF3F7FFFFF3F7FFFFF6F7\r\n      FEFFFFFAFAFF166DC6FF76DBFFFFDDF5FFFF61BDFFFF1398FFFF119AFFFF2A65\r\n      A1FFFFFFFFFFFBFCFFFFF4F8FFFFF3F7FFFFF2F7FFFFF2F7FFFFF3F8FFFFF7FF\r\n      FFFFB77E0EFF0000001600000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000024020041750000DDAC4E\r\n      4AFFEBDFDCFFF3F9FDFFE7E0E2FFDEC5B9FFE5DBDAFFEEEAEBFFA3452DFB2C07\r\n      004E000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000009000000289F63\r\n      17ECC9883BFFDB9B51FFDEA153FFE0FFFFFFE0FFFFFFE1FFFFFF959D9CFFE1FE\r\n      FFFFDFFBFCFFE0FCFDFFE7FFFFFFAFADB1FF008236FF84E8D7FF00C397FF00C3\r\n      98FF00C399FF00C399FF00C399FF00C399FF00C398FF00C498FF00C599FF00C6\r\n      9AFF61E0C7FF00B381FF005E31B3000000040000000000000009000000289F63\r\n      17ECC9883BFFDB9B51FFDEA153FFE0FFFFFFE0FFFFFFE1FFFFFF959D9CFFE1FE\r\n      FFFFDFFBFCFFE0FCFDFFE4FFFFFF9DA5A4FFFAFFFFFF007D35FF34D19FFF00BB\r\n      75FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n      FFFF00BB76FF38D3A2FF008947FF0000001500000016B67C09FFF4FBFFFFECED\r\n      F0FFECECEDFFECECEDFFECECEDFFECECEDFFECECEDFFECECEDFFECECEDFFEDEC\r\n      EDFFF2EEEDFFFEF4ECFF186CC2FF77DAFFFFDEF6FFFF61BDFFFF1397FFFF0F97\r\n      FFFF275E95FFFFF9F2FFF4F0EFFFEDECEDFFEBECEDFFEBECEDFFECEDF0FFF4FB\r\n      FFFFB67C09FF0000001600000000000000000000000000000000000000000000\r\n      00000000000000000000000000000000000036000064850909F1C3807BFFF5F5\r\n      F3FFF3F7FCFFE7DCD8FFD28E60FFCB7E4CFFE7E0E0FFEFECECFFA03B23FD5808\r\n      00A340090072440A0079440C0079440E0079450F0079451100794912007E2B0E\r\n      00480000000000000000000000000000000000000001000000153E270A81BC79\r\n      27FFDC9C58FFDE9A48FFDEF1EBFFDEFFFFFFDEFCFDFFDEFCFDFFDFFDFEFFDEFC\r\n      FDFFDDFAFBFFDEFBFCFFE4FFFFFFA7A8ACFF008033FF95EDE0FF49E7D1FF4DE7\r\n      D2FF4EE7D2FF4EE7D2FF4EE7D2FF4EE8D3FF4CE7D1FF93E6D7FF00C097FF5CDC\r\n      C6FF00AF80FF00592DAF000000050000000000000001000000153E270A81BC79\r\n      27FFDC9C58FFDE9A48FFDEF1EBFFDEFFFFFFDEFCFDFFDEFCFDFFDFFDFEFFDEFC\r\n      FDFFDDFAFBFFDEFBFCFFE1FFFFFF97A0A0FFF5FFFFFF007C32FF68D9B5FF00BB\r\n      77FF00B973FF00B770FF00B267FFFFFFFFFFFFFFFFFF00B267FF00B770FF00B9\r\n      73FF00BB77FF6DDCB9FF008946FF0000000F00000016B67B08FFF4F9FFFFEAE9\r\n      EBFFEBE8E8FFEBE9E9FFEBE9E9FFEBE8E9FFEBE9E9FFEBE9E9FFEBE9E9FFEAE8\r\n      E8FFEBE8E8FFF0EAE7FFFCEFE8FF176AC0FF76DAFFFFDEF6FFFF61BDFFFF1397\r\n      FFFF0E96FFFF265D91FFFFF5ECFFF0EBE8FFEAE7E6FFE9E6E6FFEAE8EAFFF4F9\r\n      FFFFB67B08FF0000001600000000000000000000000000000000000000000000\r\n      00000000000000000000000000004300007C8E0F0EFDD7A9A5FFFCFFFFFFF2F5\r\n      FAFFE8D2C3FFD48548FFC55D10FFCE8653FFE8E2E3FFF0EEEEFFC0806FFFB15F\r\n      4BFFB5674FFFB4684FFFB5694EFFB56B4EFFB56C4EFFB77253FFAF623DFF8A2D\r\n      05E6000000000000000000000000000000000000000700000024AC6A18F9D393\r\n      4CFFDD9C4FFFDCCFABFFDBFFFFFFDCFCFFFFDBFAFDFFDAF8FCFFDAF8FCFFDAF8\r\n      FBFFDAF8FBFFDAF8FBFFDDFBFEFFEAFFFFFF41AE82FF007B2FFF007B30FF007B\r\n      30FF007B30FF007B31FF007D33FF008137FF008136FF80E3D5FF54D9C4FF00AC\r\n      80FF3A7F33FE0000002400000007000000000000000700000024AC6A18F9D393\r\n      4CFFDD9C4FFFDCCFABFFDBFFFFFFDCFCFFFFDBFAFDFFDAF8FCFFDAF8FCFFDAF8\r\n      FBFFDAF8FBFFDAF8FBFFDCFAFDFFDFFDFFFFEAFFFFFF32A776FF57C297FF27C8\r\n      93FF00BA77FF00B977FF00B46DFFFFFFFFFFFFFFFFFF00B46DFF00B977FF00BA\r\n      77FF29C895FF62C7A0FF006535C40000000600000016B67B08FFF4FAFFFFE9E9\r\n      E9FFEBEAE9FFEEEDECFFEEEDEBFFECEBE9FFEDECEBFFEEEDECFFEDECEBFFEAE9\r\n      E8FFE7E6E5FFFCFCFBFFFFFFFFFFFFFFFFFF1669BFFF76DAFFFFDEF6FFFF61BD\r\n      FFFF1397FFFF0E96FFFF255C91FFFFFFFFFFFFFFFFFFFCFCFCFFE7E7E7FFF4F9\r\n      FFFFB67B08FF0000001600000000000000000000000000000000000000000000\r\n      000000000000000000003F000077921413FFDEB5B3FFFDFFFFFFF2F3FAFFEAC8\r\n      AEFFDA833AFFD37327FFCF6D24FFD48D5AFFEAE8ECFFEDEBEFFFF2F3F7FFF1F3\r\n      F7FFF0F2F5FFEFF1F4FFEEEFF3FFEDEEF3FFEBEBEDFFEEF0F4FFDFCDC2FF9133\r\n      10EF000000000000000000000000000000000000000E311E076BB97724FFE0A1\r\n      5DFFDC9E51FFD8FAFFFFDAFDFFFF8E9798FFDAFAFDFFD8F7FAFFD8F7FAFFD8F7\r\n      FAFFD9F8FBFFD9F8FBFFD9F8FBFFDDFAFEFFE5FDFFFFEBFFFFFFEDFFFFFFEEFF\r\n      FFFFEEFFFFFFEEFFFFFFF3FFFFFFB3A7B3FF008339FF74E2D6FF00A97CFF4C92\r\n      4DFFD27420FF361D06690000000E000000000000000E311E076BB97724FFE0A1\r\n      5DFFDC9E51FFD8FAFFFFDAFDFFFF8E9798FFDAFAFDFFD8F7FAFFD8F7FAFFD8F7\r\n      FAFFD9F8FBFFD9F8FBFFD8F8FBFFDAF8FCFFE1FBFFFFAAE0D4FF008A44FF88E0\r\n      C1FF1BC38AFF00B773FF00B36CFFFFFFFFFFFFFFFFFF00B36CFF00B773FF1BC4\r\n      8BFF8BE3C6FF069557FF001A0D420000000100000016B67B08FFF4FAFFFFE7E7\r\n      E8FFECEBEBFF4E4D4DFF919090FFEEEDEDFF8F8E8FFF919090FF8F8E8EFFE9E8\r\n      E8FFE6E5E5FFECEBEBFFFFFFFFFFFFFFFFFFFFFFFFFF1669BFFF76DAFFFFDEF6\r\n      FFFF61BDFFFF1397FFFF0E96FFFF245B8FFFFFFFFFFFF5F0EEFFE6E6E7FFF4FA\r\n      FFFFB67B08FF0000001600000000000000000000000000000000000000000000\r\n      0000000000003200005D8E0D0CFDDFB6B5FFFFFFFFFFF4F3F5FFEEC29EFFE388\r\n      39FFDD8132FFDA8037FFD37328FFD68E57FFE7D9D3FFE5D5CFFFE4D4CDFFE3D2\r\n      CCFFE1CFC9FFDFCCC7FFDDCAC4FFDBC7C1FFDCCBC9FFE4DEE2FFDCC5BBFF8F34\r\n      10EC0000000000000000000000000000000000000013744910BCCD8D43FFDF9E\r\n      54FFD8C59CFFD6FDFFFFD7F9FDFFD8F9FCFFD7F8FBFFD6F6F9FFD6F6F9FFD8F9\r\n      FCFFDBFDFFFFDCFDFFFFD9FAFDFFD8F7FBFFD8F7FBFFD9F8FBFFD9F8FCFFDAF8\r\n      FCFFDAF8FCFFDAF8FCFFDEFBFFFFF0FFFFFF008136FF00A67DFF138940FFF5A1\r\n      57FFD58E43FF764910BC000000130000000000000013744910BCCD8D43FFDF9E\r\n      54FFD8C59CFFD6FDFFFFD7F9FDFFD8F9FCFFD7F8FBFFD6F6F9FFD6F6F9FFD8F9\r\n      FCFFDBFDFFFFDCFDFFFFD9FAFDFFD7F7FAFFDAF8FCFFE6FDFFFF40AD82FF0291\r\n      4FFF92E1C5FF5AD4AAFF0ABC7DFF00B067FF00B067FF0ABC7DFF5AD4ABFF92E3\r\n      C9FF069B5FFF1C6530D4000000140000000000000016B67B08FFF4FAFFFFE5E5\r\n      E6FFE9E8E8FFF1F0F0FFF1F0F0FFEEEDEDFFEDECECFFEDECECFFECEBEBFFE7E6\r\n      E6FFE4E3E3FFDEDDDBFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF1669BFFF76DA\r\n      FFFFDEF6FFFF61BDFFFF1297FFFF0E96FFFF255C91FFF6EBE1FFEBE8E7FFF6FB\r\n      FFFFB67B08FF0000001600000000000000000000000000000000000000000000\r\n      00001700002B780000E3D19897FFFFFFFFFFF6F7FBFFF3C296FFEC9039FFE88F\r\n      3EFFE48C3EFFDF8539FFD97E34FFD57A34FFD17A38FFCD7534FFC96F30FFC369\r\n      2DFFBE6328FFB95E24FFB55820FFAD4A11FFC28666FFE8E6ECFFDDC7BCFF8F33\r\n      0FEC00000000000000000000000000000000000000169B6014E8DA9D59FFDC98\r\n      49FFD5E4D8FFD3F9FFFFD3F6F9FFD3F5F8FFD3F5F8FFD3F5F8FFD4F6F9FFD8FC\r\n      FFFF868D8EFF828A8BFFDDFFFFFFD6FAFDFFD3F6F9FFD3F5F8FFD3F5F8FFD3F5\r\n      F8FFD3F5F8FFD3F5F8FFD6F7FAFFE3FDFFFF007A2CFF0E985DFFDAE3D7FFE59C\r\n      4EFFDC9D5AFF9B6014E80000001600000000000000169B6014E8DA9D59FFDC98\r\n      49FFD5E4D8FFD3F9FFFFD3F6F9FFD3F5F8FFD3F5F8FFD3F5F8FFD4F6F9FFD8FC\r\n      FFFF868D8EFF828A8BFFDDFFFFFFD6FAFDFFD5F6FAFFD9F8FDFFE5FEFFFF50B5\r\n      90FF008A44FF53BF93FF90DFC3FF9AE5CCFF9AE5CCFF90DFC3FF53C197FF0092\r\n      53FF53904BFFAD5D11E6000000160000000000000016B67B08FFF4FAFFFFE2E2\r\n      E4FFE7E6E6FF4C4C4CFF919090FF8F8E8EFF8D8C8CFFE9E8E8FF898888FFE5E4\r\n      E4FFE3E2E3FFD1D0CDFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF176A\r\n      C0FF77DAFFFFDEF6FFFF61BDFFFF1397FFFF0E97FFFF265E93FFF7EEE8FFFBFF\r\n      FFFFB77D09FF0000001600000000000000000000000000000000000000000000\r\n      00004D000095B15555FFFDFCFCFFFAFEFFFFF9D0A7FFF79C41FFF19B48FFED97\r\n      46FFE89141FFE38B3DFFDF8539FFDA7E34FFD4752CFFCF7028FFCA6A24FFC563\r\n      20FFC05E1BFFBA5817FFB65213FFAD4202FFC1825FFFE8E8EEFFDDC7BCFF8F33\r\n      0FEC0000000000000000000000000000000000000016B16D16FFE7AC6EFFDA94\r\n      40FFD0FFFFFFD1F7FCFFD2F5F9FFD2F5F9FFD2F5F9FFD1F4F8FFD2F5F9FFD6FB\r\n      FFFF899190FF4E4644FF7B8888FFDDFFFFFFD5F9FDFFD2F5F9FFD1F4F8FFD1F4\r\n      F8FFD1F4F8FFD1F4F8FFD3F6FAFFD8F8FEFFE0FCFFFFE0FDFFFFD7FFFFFFDC94\r\n      41FFE7AC6EFFB16D16FF000000160000000000000016B16D16FFE7AC6EFFDA94\r\n      40FFD0FFFFFFD1F7FCFFD2F5F9FFD2F5F9FFD2F5F9FFD1F4F8FFD2F5F9FFD6FB\r\n      FFFF899190FF4E4644FF7B8888FFDDFFFFFFD5F9FDFFD3F6FAFFD6F7FDFFE0FB\r\n      FFFFA2DDD2FF2FA575FF007C31FF007D33FF007D33FF007D32FF2DAA80FFAB94\r\n      45FFF6AC6EFFB76D15FF000000160000000000000016B67B08FFF5FBFFFFE1DF\r\n      E1FFE4E1E1FFE7E5E5FFE8E6E6FFE7E5E5FFE6E4E4FFE4E2E2FFE4E2E2FFE3E1\r\n      E1FFE3E1E1FFC5C3C0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n      FFFF1A6EC4FF78DCFFFFDFF6FFFF61BDFFFF1297FFFF0B97FFFF20609DFFFFFF\r\n      FFFFBB810BFF0000001600000000000000000000000000000000000000000000\r\n      0000760000DDD9A8A8FFFFFFFFFFFBE3CAFFFFAA50FFFBA64EFFF7A24EFFF19C\r\n      4AFFEC9645FFE79041FFE38A3DFFDE8539FFD97E35FFD57931FFD0732DFFCB6C\r\n      29FFC56724FFC06120FFBB5B1CFFB34C0CFFC78965FFEAEAF0FFDEC9BDFF8F34\r\n      0FEC0000000000000000000000000000000000000016B06D15FFE8AE71FFD992\r\n      3DFFCDFBFFFFCFF5FCFFD2F7FCFFD3F8FDFFD2F7FCFFD0F4F9FFCEF3F8FFD1F5\r\n      FAFFD7FFFFFF848E8EFF423C3AFF738080FFDAFFFFFFD1F6FBFFCEF2F7FFCEF2\r\n      F7FFCEF2F7FFD0F4F9FFD2F7FCFFD4F8FEFFD4F8FEFFD1F6FDFFCEFCFFFFD992\r\n      3DFFE8AE71FFB06D15FF000000160000000000000016B06D15FFE8AE71FFD992\r\n      3DFFCDFBFFFFCFF5FCFFD2F7FCFFD3F8FDFFD2F7FCFFD0F4F9FFCEF3F8FFD1F5\r\n      FAFFD7FFFFFF848E8EFF423C3AFF738080FFDAFFFFFFD1F6FCFFCFF3F8FFD1F4\r\n      FAFFD6F6FEFFDEFAFFFFE4FFFFFFE6FFFFFFE5FFFFFFE1FEFFFFDBFFFFFFE194\r\n      40FFEBAE72FFB16D15FF000000160000000000000016B67B08FFF5FBFFFFDEDE\r\n      DFFFDFDEDDFFE0DFDEFFE0E0DEFFE0DFDEFFE0DFDEFFE0DFDEFFE0DFDDFFE0DF\r\n      DDFFE1E0DFFFB2B2B3FFB1B2B2FFB0B1B1FFB0B0B0FFB0B0B0FFB2B2B1FFB8B5\r\n      B2FFC3B9B2FF1C6FC5FF78DBFFFFDEF6FFFF5EBFFFFF0899FFFF86796EFF706F\r\n      72FFC38708FF0000002200000006000000000000000000000000000000000000\r\n      0000720000D7D6A1A1FFFFFFFFFFFCE9D5FFFFAE59FFFFA94FFFFCA953FFF7A2\r\n      4EFFF29C49FFED9645FFE89041FFE38B3DFFDE8539FFDA8035FFD57831FFD073\r\n      2DFFCB6C29FFC56724FFC06121FFB85211FFCB8D68FFEBEBF0FFDEC9BDFF8F33\r\n      0FEC0000000000000000000000000000000000000016B06C15FFE9B075FFD990\r\n      3CFFCBFAFFFFCFF6FCFF839091FF859394FF839091FFCFF4FAFFCCF1F7FFCDF2\r\n      F7FFD0F6FCFFDAFFFFFF818B8DFF363030FF6D7779FFD3FAFFFFCDF2F7FFCCF1\r\n      F6FFCCF1F6FFCFF4FAFF839091FF859394FF839091FFCFF6FCFFCBFAFFFFD990\r\n      3CFFE9B075FFB06C15FF000000160000000000000016B06C15FFE9B075FFD990\r\n      3CFFCBFAFFFFCFF6FCFF839091FF859394FF839091FFCFF4FAFFCCF1F7FFCDF2\r\n      F7FFD0F6FCFFDAFFFFFF818B8DFF363030FF6D7779FFD3FAFFFFCDF2F7FFCCF1\r\n      F6FFCEF2F8FFD1F6FBFF869294FF899497FF879294FFD2F7FFFFCDFBFFFFDA91\r\n      3CFFE9B075FFB06C15FF000000160000000000000016B67B08FFF5FBFFFFDCDC\r\n      DDFFDDDCDBFFDDDCDBFFDDDCDBFFDDDCDBFFDDDCDBFFDDDCDBFFDDDCDBFFDDDC\r\n      DBFFDEDDDCFFDFDEDDFFDFDEDDFFDFDEDDFFDFDEDDFFDFDEDDFFDFDEDDFFE0DF\r\n      DDFFE5E1DDFFEFE4DBFF196EC4FF75DCFFFFD6F8FFFFAB9E93FF9F9996FF6F6E\r\n      70FF707674FF0000003D0000001C000000060000000000000000000000000000\r\n      000046000086A94343FFFCF7F7FFFFFFFFFFFDDEBCFFFFA94EFFFFAA51FFFCA8\r\n      54FFF7A24DFFF29C4AFFED9746FFE8903FFFE28635FFDE8232FFD97A2DFFD474\r\n      29FFCF6E26FFCA6821FFC4611CFFBC530CFFCD8E66FFEDEDF3FFDFCABEFF8F33\r\n      10EC0000000000000000000000000000000000000016B06C15FFEBB278FFD78E\r\n      3AFFD0FDFFFFCAF3FAFFCDF5FAFFCEF6FBFFCDF5FAFFCAF2F7FFC9F0F5FFC9F1\r\n      F6FFCDF6FBFFD7FFFFFF788789FF3B3333FF6F7A7CFFCFF9FEFFCAF1F6FFC9F0\r\n      F5FFC9F0F5FFCAF2F7FFCDF5FAFFCEF6FBFFCDF5FAFFCAF3FAFFD0FDFFFFD78E\r\n      3AFFEBB278FFB06C15FF000000160000000000000016B06C15FFEBB278FFD78E\r\n      3AFFD0FDFFFFCAF3FAFFCDF5FAFFCEF6FBFFCDF5FAFFCAF2F7FFC9F0F5FFC9F1\r\n      F6FFCDF6FBFFD7FFFFFF788789FF3B3333FF6F7A7CFFCFF9FEFFCAF1F6FFC9F0\r\n      F5FFC9F0F5FFCAF2F7FFCDF5FAFFCEF6FBFFCDF5FAFFCAF3FAFFD0FDFFFFD78E\r\n      3AFFEBB278FFB06C15FF000000160000000000000016B67B08FFF5FBFFFFDADA\r\n      DAFFDBDAD9FFDCDBDAFFDCDBDAFFDCDBDAFFDBDBDAFFDCDBDAFFDCDBDAFFDBDA\r\n      D9FFDAD9D8FFD9D8D7FFD8D7D6FFD8D7D5FFD8D7D5FFD8D7D5FFD8D7D5FFD8D7\r\n      D5FFD9D7D5FFDED9D5FFE8DED5FF126CC6FFB5AAA3FFE8E5E1FFC3C2C0FF9B9B\r\n      99FF798073FF9A68D0FF00000037000000110000000000000000000000000000\r\n      00001000001D6F0000D5C58281FFFFFFFFFFFDFFFFFFFED9B3FFFFA84EFFFFA9\r\n      4FFFFCA954FFF7A24FFFF19B47FFED9B4EFFE9A365FFE69F61FFE2995DFFDE95\r\n      5AFFD99056FFD58B52FFD1864FFFCB7942FFD6A487FFEDEDF2FFDFCABFFF8F33\r\n      0FEC0000000000000000000000000000000000000013B06C15FFEDB77DFFD68D\r\n      39FFCFFCFFFFC6F1F7FFC8F0F5FFC8F0F5FFC8F0F5FFC7EFF4FFC8F0F5FFCAF4\r\n      F9FFD2FDFFFF778485FF403737FF768385FFD2FEFFFFCAF3F8FFC7EFF4FFC7EF\r\n      F4FFC7EFF4FFC7EFF4FFC8F0F5FFC8F0F5FFC8F0F5FFC6F1F7FFCFFCFFFFD68D\r\n      39FFEDB77DFFB06C15FF000000130000000000000013B06C15FFEDB77DFFD68D\r\n      39FFCFFCFFFFC6F1F7FFC8F0F5FFC8F0F5FFC8F0F5FFC7EFF4FFC8F0F5FFCAF4\r\n      F9FFD2FDFFFF778485FF403737FF768385FFD2FEFFFFCAF3F8FFC7EFF4FFC7EF\r\n      F4FFC7EFF4FFC7EFF4FFC8F0F5FFC8F0F5FFC8F0F5FFC6F1F7FFCFFCFFFFD68D\r\n      39FFEDB77DFFB06C15FF000000130000000000000016B67B09FFF6FBFFFFD9D8\r\n      D9FFDCDAD9FFE0DEDDFFE0DEDDFFDFDDDCFFDDDBDAFFDFDCDBFFDEDCDBFFDCDA\r\n      D8FFD8D6D5FFFBFBFCFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n      FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF9E9994FFD6D3D2FFE6E8E4FF868A\r\n      81FFCA8CC9FFC184BAFF986AC8FF000000110000000000000000000000000000\r\n      00000000000025000045830303F2D39E9CFFFFFFFFFFFEFFFFFFFCE0C1FFFEAF\r\n      5AFFFFA84CFFFBA953FFF59E45FFF2B274FFF4F1F3FFF2EEEFFFF3EFF0FFF2EF\r\n      EFFFF0ECEDFFEFEAEBFFEDE8E9FFECE6E8FFEAE3E4FFEEECF0FFE1CDC1FF8F34\r\n      10EC000000000000000000000000000000000000000E9B6113E6E3AA6BFFDA93\r\n      43FFD0FBFFFFC4EFF8FFC5EDF5FFC5EDF5FFC5EDF4FFC6EEF5FFC8F1F9FFCFFB\r\n      FFFF7A8688FF473E3CFF798688FFD0FCFFFFC9F2F9FFC6EEF5FFC5EDF4FFC5ED\r\n      F4FFC5EDF4FFC5EDF4FFC5EDF4FFC5EDF5FFC5EDF5FFC4EFF8FFD0FBFFFFDA93\r\n      43FFE3AA6BFF9B6113E60000000E000000000000000E9B6113E6E3AA6BFFDA93\r\n      43FFD0FBFFFFC4EFF8FFC5EDF5FFC5EDF5FFC5EDF4FFC6EEF5FFC8F1F9FFCFFB\r\n      FFFF7A8688FF473E3CFF798688FFD0FCFFFFC9F2F9FFC6EEF5FFC5EDF4FFC5ED\r\n      F4FFC5EDF4FFC5EDF4FFC5EDF4FFC5EDF5FFC5EDF5FFC4EFF8FFD0FBFFFFDA93\r\n      43FFE3AA6BFF9B6113E60000000E0000000000000016B67B09FFF6FBFFFFD8D6\r\n      D7FFDDDBDAFF494848FF8A8988FF878685FFDFDDDCFF868584FF858583FFDBD9\r\n      D8FFD6D4D3FFE9E8E8FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n      FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF9D9C97FF979990FFDBA1\r\n      DBFFD099CEFFC88FC2FF9F6FCAFF000000060000000000000000000000000000\r\n      000000000000000000003100005B860807F8D19997FFFFFFFFFFFDFFFFFFFCEA\r\n      D6FFFEB568FFFFA64AFFFCA349FFF7B779FFF5F4F7FFF6F5F7FFF7F4F5FFF6F3\r\n      F1FFF5F3F1FFF5F3F1FFF4F3F1FFF3F2F1FFF2EFEFFFF6F6F8FFE2CABBFF9134\r\n      10F10000000000000000000000000000000000000007754910B3D49953FFE19E\r\n      57FFD2D5C4FFC1F0FBFFC3EEF6FFC4EFF6FFC4EEF6FFC5F1F8FFCBF9FFFF7D8A\r\n      8BFF4D4542FF7C898BFFCCFAFFFFC5F1F8FFC2EDF4FFC2ECF3FFC2ECF3FFC2EC\r\n      F3FFC2ECF3FFC2ECF3FFC3EEF5FFC4EFF6FFC3EEF6FFC1F0FBFFD2D5C4FFE19E\r\n      57FFD49953FF754910B3000000070000000000000007754910B3D49953FFE19E\r\n      57FFD2D5C4FFC1F0FBFFC3EEF6FFC4EFF6FFC4EEF6FFC5F1F8FFCBF9FFFF7D8A\r\n      8BFF4D4542FF7C898BFFCCFAFFFFC5F1F8FFC2EDF4FFC2ECF3FFC2ECF3FFC2EC\r\n      F3FFC2ECF3FFC2ECF3FFC3EEF5FFC4EFF6FFC3EEF6FFC1F0FBFFD2D5C4FFE19E\r\n      57FFD49953FF754910B3000000070000000000000016B67C09FFF6FCFFFFD5D4\r\n      D6FFDBD9D9FFE2E0E0FFE3E1E1FFE1DFDFFFDFDDDDFFE0DDDEFFDEDCDCFFD9D7\r\n      D7FFD5D3D3FFD8D7D6FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n      FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFDDDFDAFFBB7DD3FFE4AF\r\n      E3FFDAA6D8FFAB7ACFFF00000006000000000000000000000000000000000000\r\n      00000000000000000000000000003200005D850000F6CA8986FFFFFEFDFFFFFF\r\n      FFFFFBF4EBFFFEC181FFFFA23FFFFABA78FFF5F5F8FFF9F8F9FFB66553FFA33D\r\n      2EFFA64833FFA64833FFA74B33FFA74E33FFA84E33FFA95336FFA44C28FF822B\r\n      03DA0000000000000000000000000000000000000001321F0756BC7A29FFF0B6\r\n      7AFFCFB082FFC4F0FFFFC2F0F8FF748385FFC5F1F9FFC8F8FFFF808D8FFF544B\r\n      49FF808D8EFFC9F9FFFFC3F0F7FFC1EDF4FFC0EBF2FFC0EBF2FFC0EBF2FFC0EB\r\n      F2FFC0EBF2FFC0EBF3FFC2EEF5FF748385FFC2F0F8FFC4F0FFFFCFB082FFF0B6\r\n      7AFFBC7A29FF321F0756000000010000000000000001321F0756BC7A29FFF0B6\r\n      7AFFCFB082FFC4F0FFFFC2F0F8FF748385FFC5F1F9FFC8F8FFFF808D8FFF544B\r\n      49FF808D8EFFC9F9FFFFC3F0F7FFC1EDF4FFC0EBF2FFC0EBF2FFC0EBF2FFC0EB\r\n      F2FFC0EBF2FFC0EBF3FFC2EEF5FF748385FFC2F0F8FFC4F0FFFFCFB082FFF0B6\r\n      7AFFBC7A29FF321F0756000000010000000000000016B67C09FFF6FCFFFFD3D3\r\n      D4FFD9D8D7FF484747FF888787FF868586FF868585FF868585FF838282FFD7D6\r\n      D5FFD4D4D2FFC7C6C5FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n      FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFC8C9C6FFD6DBD3FFBA80\r\n      D5FFB783DDFF0000001600000000000000000000000000000000000000000000\r\n      00000000000000000000000000000000000027010048770200DFB7615CFFF6EB\r\n      EAFFFFFFFFFFFBFAFAFFFCD0A0FFFDC183FFF8F7F7FFF9F8F8FFA13C25FD4F06\r\n      009131080057360A005F360B005F360B005F360B005F360C005F380F00611B08\r\n      002E000000000000000000000000000000000000000000000009AA6915F7E4AB\r\n      6CFFE09B50FFC4D9D8FFBFECF9FFBFEFF7FFC2F2FAFF828E8EFF5B514EFF8490\r\n      92FFC6F7FFFFC0EFF6FFBFEDF4FFC0EEF5FFBFECF3FFBDEAF1FFBDEAF1FFBDEA\r\n      F1FFBDEBF1FFBDEBF2FFBEECF3FFBFEFF6FFBFECF9FFC4D9D8FFE09B50FFE4AB\r\n      6CFFAA6915F70000000900000000000000000000000000000009AA6915F7E4AB\r\n      6CFFE09B50FFC4D9D8FFBFECF9FFBFEFF7FFC2F2FAFF828E8EFF5B514EFF8490\r\n      92FFC6F7FFFFC0EFF6FFBFEDF4FFC0EEF5FFBFECF3FFBDEAF1FFBDEAF1FFBDEA\r\n      F1FFBDEBF1FFBDEBF2FFBEECF3FFBFEFF6FFBFECF9FFC4D9D8FFE09B50FFE4AB\r\n      6CFFAA6915F700000009000000000000000000000016B67C09FFF6FCFFFFD0D0\r\n      D1FFD4D3D2FFD8D7D6FFD8D7D6FFD8D7D6FFD8D7D6FFD7D7D5FFD6D5D4FFD4D3\r\n      D2FFD4D3D2FFBAB7B5FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n      FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFBAB7B4FFD2D4D1FFF9FF\r\n      FFFFB87E00FF0000001600000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000015010026660000C2A033\r\n      2FFFE7CCC8FFFFFFFFFFFCFEFFFFFBF1EAFFFAF7F6FFFBFAF9FFA3452EFB2D07\r\n      004F000000000000000000000000000000000000000000000000000000000000\r\n      00000000000000000000000000000000000000000000000000023F270966C181\r\n      32FFF2BA83FFD19B59FFB9E4FAFFBBEBF6FFC0F1FAFF838F8FFF869394FFC4F7\r\n      FFFFBEEDF6FFBCEBF3FFBFEEF7FF718386FFBFEEF7FFBCEAF2FFBBE9F1FFBDEB\r\n      F3FFBDECF5FFBDEBF3FFBBEBF4FFBBEAF5FFB9E4FAFFD19B59FFF2BA83FFC181\r\n      32FF3F27086700000002000000000000000000000000000000023F270966C181\r\n      32FFF2BA83FFD19B59FFB9E4FAFFBBEBF6FFC0F1FAFF838F8FFF869394FFC4F7\r\n      FFFFBEEDF6FFBCEBF3FFBFEEF7FF718386FFBFEEF7FFBCEAF2FFBBE9F1FFBDEB\r\n      F3FFBDECF5FFBDEBF3FFBBEBF4FFBBEAF5FFB9E4FAFFD19B59FFF2BA83FFC181\r\n      32FF3F27086700000002000000000000000000000016B67C09FFF6FCFFFFCECD\r\n      CEFFD1CFCEFFD2CFCEFFD2D0CFFFD2CFCEFFD2CFCEFFD2CFCEFFD1CFCEFFD1CF\r\n      CEFFD3D0CFFFA3A3A4FFA2A2A2FFA0A1A1FFA0A0A0FFA0A0A0FFA0A0A0FFA0A0\r\n      A0FFA0A0A0FFA0A0A0FFA0A0A0FFA0A1A1FFA2A2A2FFA2A3A3FFD1CFCFFFF7FD\r\n      FFFFB67C07FF0000001600000000000000000000000000000000000000000000\r\n      00000000000000000000000000000000000000000000000000000700000C5001\r\n      009492140FFED29D97FFFFFFFFFFFEFFFFFFFBFAFBFFFBFAFAFFA5462EFD2E07\r\n      0052000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000069F62\r\n      14E7D99F5AFFEAAD6BFFC6A679FFB1DEF5FFB8E7F4FFBEF2FDFF708588FFBDEE\r\n      F7FFB9E8F2FFB9E8F2FFBDEDF7FF708487FFBDEDF7FFB9E8F2FFB8E8F1FFBBEB\r\n      F4FF6C7D81FFBBEDF6FFB6E4F1FFB0DEF5FFC6A679FFEAAD6BFFD99F5AFF9F62\r\n      14E7000000060000000000000000000000000000000000000000000000069F62\r\n      14E7D99F5AFFEAAD6BFFC6A679FFB1DEF5FFB8E7F4FFBEF2FDFF708588FFBDEE\r\n      F7FFB9E8F2FFB9E8F2FFBDEDF7FF708487FFBDEDF7FFB9E8F2FFB8E8F1FFBBEB\r\n      F4FF6C7D81FFBBEDF6FFB6E4F1FFB0DEF5FFC6A679FFEAAD6BFFD99F5AFF9F62\r\n      14E70000000600000000000000000000000000000016B67C09FFF6FCFFFFCAC9\r\n      CBFFCCCACAFFCCCACAFFCCCACAFFCCCACAFFCCCACAFFCCCACAFFCCCACAFFCCCA\r\n      CAFFCDCBCBFFCECDCCFFCECDCDFFCECDCDFFCECDCDFFCECDCDFFCECDCDFFCECD\r\n      CDFFCECDCDFFCECDCDFFCECDCDFFCECDCDFFCECDCDFFCDCCCCFFCBCACCFFF6FC\r\n      FFFFB67C09FF0000001600000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000100\r\n      00013302005C7B0600E1B7645BFFF0DFDBFFFFFFFFFFFDFCFCFFA5462EFD2E07\r\n      0052000000000000000000000000000000000000000000000000000000000000\r\n      000000000000000000000000000000000000000000000000000000000001160E\r\n      0327AF6B13FFEEB880FFEBAE6CFFC69E6AFFACD3E6FFAFDDF1FFB7E8F5FFB8EB\r\n      F4FFB7E8F1FFB7E8F1FFBBECF5FF6D8082FFBBECF5FFB7E8F1FFB7E8F1FFB8EB\r\n      F4FFB6E7F4FFAEDDF0FFACD3E6FFC59E69FFEBAE6CFFEEB880FFAF6B13FF0704\r\n      001200000000000000000000000000000000000000000000000000000001160E\r\n      0327AF6B13FFEEB880FFEBAE6CFFC69E6AFFACD3E6FFAFDDF1FFB7E8F5FFB8EB\r\n      F4FFB7E8F1FFB7E8F1FFBBECF5FF6D8082FFBBECF5FFB7E8F1FFB7E8F1FFB8EB\r\n      F4FFB6E7F4FFAEDDF0FFACD3E6FFC59E69FFEBAE6CFFEEB880FFAF6B13FF0704\r\n      00120000000000000000000000000000000000000016B67C0BFFF4FDFFFFF2F7\r\n      FFFFF2F8FFFFF3F8FFFFF3F8FFFFF3F8FFFFF3F8FFFFF3F8FFFFF3F8FFFFF3F8\r\n      FFFFF3F8FFFFF3F9FFFFF3F9FFFFF3F9FFFFF3F9FFFFF3F9FFFFF3F9FFFFF3F9\r\n      FFFFF3F9FFFFF3F9FFFFF3F9FFFFF3F9FFFFF3F9FFFFF3F8FFFFF2F7FFFFF4FD\r\n      FFFFB67C0BFF0000001600000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      00000000000014020023610400B39A2819FFD8AAA2FFFFFFFFFFA84C34FD2F07\r\n      0053000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      000122150538B4711BFFEFBA83FFEDB171FFCF914BFFB5B6A7FFA2D2EEFFA6D3\r\n      E9FFAADAEAFFAFE0EEFFB2E4F0FFB3E5F2FFB2E4F0FFAFE0EEFFAADAEAFFA6D3\r\n      E9FFA2D2EEFFB5B6A7FFCF914BFFF0B577FFEFBA82FFB4711BFF140B03230000\r\n      0001000000000000000000000000000000000000000000000000000000000000\r\n      000122150538B4711BFFEFBA83FFEDB171FFCF914BFFB5B6A7FFA2D2EEFFA6D3\r\n      E9FFAADAEAFFAFE0EEFFB2E4F0FFB3E5F2FFB2E4F0FFAFE0EEFFAADAEAFFA6D3\r\n      E9FFA2D2EEFFB5B6A7FFCF914BFFF0B577FFEFBA82FFB4711BFF140B03230000\r\n      00010000000000000000000000000000000000000016B67E0EFFFAE3C2FFE3AB\r\n      51FFE3AC54FFE3AD55FFE3AD55FFE3AD55FFE3AD55FFE3AD55FFE3AD55FFE3AD\r\n      55FFE3AD55FFE3AD55FFE3AD55FFE3AD55FFE3AD55FFE3AD55FFE3AD55FFE3AD\r\n      55FFE3AD55FFE3AD55FFE3AD55FFE3AD55FFE3AD55FFE3AC54FFE3AB51FFFAE3\r\n      C2FFB67E0EFF0000001600000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      00000000000000000000030000063A060069800D01E7B4614FFFA13C21FD3008\r\n      0054000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      000000000001140B0322AF6B13FFDCA361FFF9C692FFE39F56FFCA8B43FFB2AE\r\n      99FFA4BFC8FF99CDECFF9ACCEBFF9ACCEBFF9ACCEBFF99CDECFFA4BFC8FFB2AE\r\n      99FFCA8B43FFE39F56FFF9C692FFDBA361FFAF6B12FF140C0323000000010000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      000000000001140B0322AF6B13FFDCA361FFF9C692FFE39F56FFCA8B43FFB2AE\r\n      99FFA4BFC8FF99CDECFF9ACCEBFF9ACCEBFF9ACCEBFF99CDECFFA4BFC8FFB2AE\r\n      99FFCA8B43FFE39F56FFF9C692FFDBA361FFAF6B12FF140C0323000000010000\r\n      00000000000000000000000000000000000000000016B68011FFF5DDB8FFD99E\r\n      38FFDAA13EFFDAA13FFFDAA13FFFDAA13FFFDAA13FFFDAA13FFFDAA13FFFDAA1\r\n      3FFFDAA13FFFDAA13FFFDAA13FFFDAA13FFFDAA13FFFDAA13FFFDAA13FFFDAA1\r\n      3FFFDAA13FFFDAA13FFFDAA13FFFDAA13FFFDAA13FFFDAA13EFFD99E38FFF5DD\r\n      B8FFB68011FF0000001600000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000001903002C5D0B00A7621200AC0F03\r\n      0019000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      00000000000000000000070401109E6113E6C38436FFEDB880FFFCC996FFE6A5\r\n      60FFDA9042FFD0822CFFD1822BFFD1822BFFD1822BFFD0822CFFDA9042FFE6A5\r\n      60FFFCC996FFEDB880FFC38436FF9E6113E60704011000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      00000000000000000000070401109E6113E6C38436FFEDB880FFFCC996FFE6A5\r\n      60FFDA9042FFD0822CFFD1822BFFD1822BFFD1822BFFD0822CFFDA9042FFE6A5\r\n      60FFFCC996FFEDB880FFC38436FF9E6113E60704011000000000000000000000\r\n      00000000000000000000000000000000000000000015B68113FFF1D6A9FFD18B\r\n      16FFD28E1AFFD28E1BFFD28E1BFFD28E1BFFD28E1BFFD28E1BFFD28E1BFFD28E\r\n      1BFFD28E1BFFD28E1BFFD28E1BFFD28E1BFFD28E1BFFD28E1BFFD28E1BFFD28E\r\n      1BFFD28E1BFFD28E1BFFD28E1BFFD28E1BFFD28E1BFFD28E1AFFD18B16FFF1D6\r\n      A9FFB68113FF0000001500000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000023D26085FAA6914F7BE7E2DFFDEA7\r\n      66FFF2C18DFFFFD5A9FFFFD5A8FFFFD5A8FFFFD5A8FFFFD5A9FFF2C18DFFDEA7\r\n      66FFBE7E2DFFAA6914F73D26085F000000020000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000023D26085FAA6914F7BE7E2DFFDEA7\r\n      66FFF2C18DFFFFD5A9FFFFD5A8FFFFD5A8FFFFD5A8FFFFD5A9FFF2C18DFFDEA7\r\n      66FFBE7E2DFFAA6914F73D26085F000000020000000000000000000000000000\r\n      0000000000000000000000000000000000000000000DB88216FFEECF9BFFECCD\r\n      98FFECCE9AFFECCE9AFFECCE9AFFECCE9AFFECCE9AFFECCE9AFFECCE9AFFECCE\r\n      9AFFECCE9AFFECCE9AFFECCE9AFFECCE9AFFECCE9AFFECCE9AFFECCE9AFFECCE\r\n      9AFFECCE9AFFECCE9AFFECCE9AFFECCE9AFFECCE9AFFECCE9AFFECCD98FFEECF\r\n      9BFFB88216FF0000000D00000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000001321E064C7447\r\n      0EAC9B5F12E2AF6A12FFAF6A12FFAF6A12FFAF6A12FFAF6A12FF9B5F12E27447\r\n      0EAC321E064C0000000100000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000001321E064C7447\r\n      0EAC9B5F12E2AF6A12FFAF6A12FFAF6A12FFAF6A12FFAF6A12FF9B5F12E27447\r\n      0EAC321E064C0000000100000000000000000000000000000000000000000000\r\n      000000000000000000000000000000000000000000047F5C12B4B88316FFB782\r\n      15FFB78115FFB78115FFB78115FFB78115FFB78115FFB78115FFB78115FFB781\r\n      15FFB78115FFB78115FFB78115FFB78115FFB78115FFB78115FFB78115FFB781\r\n      15FFB78115FFB78115FFB78115FFB78115FFB78115FFB78115FFB78215FFB883\r\n      16FF7F5C12B40000000400000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000304\r\n      04352321208C0000000500000000000000000000000000000000000000001B1B\r\n      197C111111630000000000000000000000000000000000000000000000010000\r\n      000C000000170000001F00000022000000220000002200000022000000220000\r\n      0022000000220000002200000022000000220000002200000022000000220000\r\n      00220000002200000022000000220000002200000022000000220000001E0000\r\n      001A000000120000000600000000000000000000000000000000000000000000\r\n      000000000000000000000000000000000000AF7F57F9B0805AF9B0825EF9AF81\r\n      5EFAAD7F5DFAAB7D5CFAAA7B5AFAA87A59FAA67958FAA57757FAA37556FAA173\r\n      55FAA07255FA9F7054FA9D6E53FA996B51F995664CF9906147F9523627900301\r\n      0106000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000606060C0E0E0E1915151526141414240D0D0D170505050A0000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000030404378372\r\n      51E4DAB267FF2C2A26980000000000000000000000000000000018171778DDB8\r\n      72FFC5A76CFC0A0B0C57000000000000000000000000000000080000001B0000\r\n      002C0000003A0000004000000045000000450000004500000045000000450000\r\n      0045000000450000004500000045000000450000004500000045000000450000\r\n      00450000004500000045000000450000004500000045000000450000003F0000\r\n      00420000003A0000002C00000017000000020000000000000000000000000000\r\n      000000000000000000000000000003030303BA8A61FFFDFAF7FFFDF9F5FFFDF8\r\n      F4FFFDF7F3FFCEDDCBFFE7EADFFFFDF6F1FFFDF6F1FFFDF5F0FFFDF5EFFFFDF5\r\n      EFFFFDF4EEFFFDF4EDFFFDF3EDFFFDF4EEFFFDF6F3FFFCFAF8FFC1A698FF402A\r\n      1F70000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000001010101131313242929\r\n      294D3D3D3D744444447F4444447F4444447F4444447F4444447F4444447F3B3B\r\n      3B6F252525471010101E00000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      00000000000000000000000000000000000000000000020405368C7854EBE0AC\r\n      4EFFE0AC4BFFD6B068FF29262392000000000000000015141572D3B172FFF7C2\r\n      5DFFFBC55DFFBB9F68F908090B51000000000000000018181858474747E35252\r\n      52FF525252FF525252FF525252FF525252FF525252FF525252FF525252FF5252\r\n      52FF525252FF525252FF525252FF525252FF525252FF525252FF525252FF5252\r\n      52FF525252FF525252FF525252FF525252FF525252FF525252FF525252FF5252\r\n      52FF525252FF464646E31515155D0000000E0000000000000000000000000000\r\n      000000000000000000000000000006060606C1946DFFFFFAF7FFFEF7F0FFFEF5\r\n      EEFFFEF4EDFFB0CAADFF6EA879FFB7CDB2FFFBEFE4FFFDF0E7FFFDEFE5FFFDEE\r\n      E3FFFDEEE3FFFDEDE1FFFDEDE0FFFEEEE2FFFEF4EDFFFFFCF9FFEFE8E4FF9160\r\n      47FE2E1D16510000000000000000000000000000000000000000000000000000\r\n      000000000000000000000000000000000000141414273737376B4242427F4242\r\n      427F4948487F5453527F5958577F5E5D5C7F5E5D5C7F5959587F5453537F4848\r\n      487F4242427F4242427F343434641010101F0000000000000000000000000000\r\n      00000000000000000000000000000000000000000000080808324F4F4F90A2A2\r\n      A2CC949496C4939496C4919294C48F9193C48E8F91C48C8C8FC48B8C8EC48A8B\r\n      8CC488898BC487888AC4858788C487888AC467696EC288724BEBD8A342FFD3A0\r\n      43FFD6A64DFFE3B257FFD3B06EFE5C5956CE565659C7C4A66DFAF4C263FFEBBA\r\n      5DFFEDBA58FFFBC459FFBB9D63F90B0B0B5400000000474747DFC5C5C5FFE1E1\r\n      E1FFE0E0E0FFDEDEDEFFDCDCDCFFDBDBDBFFD9D9D9FFD7D7D7FFD5D5D5FFD3D3\r\n      D3FFD1D1D1FFCFCFCFFFCDCDCDFFCBCBCBFFC9C9C9FFC7C7C7FFC4C4C4FFC2C2\r\n      C2FFBFBFBFFFBDBDBDFFBBBBBBFFB9B9B9FFB6B6B6FFB4B4B4FFB2B2B2FFB1B1\r\n      B1FFAFAFAFFF959595FF434343D6000000080000000000000000000000000000\r\n      000000000000000000000000000007070707C49A74FFFEF9F5FFFEF5EFFFFEF3\r\n      EBFFFEF2EAFFB0C9ACFF71C082FF6EBA7DFF84B289FFDFDECBFFFDECE1FFFDEB\r\n      DFFFFDEADDFFFDEADCFFFDE9DAFFFDEBDEFFFEF3EAFFFFFBF9FFFFFFFEFFE2D5\r\n      CDFF865841EA1E130E3600000000000000000000000000000000000000000000\r\n      000000000000000000000606060C3030305F4040407F4242427F5251507F6260\r\n      5F7F6A68677F6D6C6B7F706F6E7F7270707F7271707F7270707F706F6E7F6D6C\r\n      6B7F6362607F5150507F4242417F4141417F2B2B2B5403030306000000000000\r\n      000000000000000000000000000000000000000000000E0E0E42878787BDFFFF\r\n      FFFFFFFDF8FFFFFBF2FFFFFAF1FFFDF8F0FFFCF7EEFFFBF6EDFFFAF4ECFFF8F3\r\n      EAFFF7F2EAFFF6F1E9FFF5F0E7FFF9F4ECFFC2BEB7FFAB8A4FFFD19A38FFD09E\r\n      43FFD5A54DFFDEB05BFFEABB65FFDBB878FFCFB27CFFF3C46CFFE9BA61FFE9B9\r\n      5DFFEAB858FFF5BE53FFE0B767FF1A1A197D00000000525252FFE4E4E4FFBABA\r\n      BAFFB8B8B8FFB8B8B8FFB5B5B5FFB9B9B9FFB3B3B3FFB0B0B0FFAFAFAFFFACAC\r\n      ACFFADADADFFAAAAAAFFACACACFFACACACFFAAAAAAFFA9A9A9FF979797FFC4C4\r\n      C4FF959595FFC3C3C3FF939393FFC1C1C1FF909090FFBFBFBFFF8F8F8FFFBFBF\r\n      BFFFA0A0A0FFAEAEAEFF525252FD00000000AF7F57F9B0805AF9B0825EF9AF81\r\n      5EFAAD7F5DFAAB7D5CFAAA7B5AFAAA7D5DFAC69B76FFFEF9F6FFFEF5EFFFFEF3\r\n      ECFFFEF3EAFFB0C9ACFF73C183FF78D88CFF70C481FF6BAF78FFAAC4A5FFF6E9\r\n      DBFFFDEBDEFFFDEADCFFFDE9DBFFFDEBDEFFFEF3EBFFFFFCF9FFFFFFFFFFFFFF\r\n      FFFFD6C4BAFF764E39CF130B0921000000000000000000000000000000000000\r\n      0000000000000D0D0D1A373737723E3E3E7F4C4B4A7F5E5C5A7F6563617F6967\r\n      657F6E6D6C7F7473737F7978787F7C7C7B7F7C7C7C7F7A79797F7676757F7170\r\n      6F7F6D6B6A7F6967667F615F5D7F4A4A497F3E3E3E7F33333369080808100000\r\n      000000000000000000000000000000000000000000000E0E0E41868686BCFFFF\r\n      FFFFD9B779FFC38C29FFC89436FFCB9638FFCD993AFFD09B3CFFD19D3CFFD6A1\r\n      41FFDDA949FFE0AC4BFFE2AD4CFFE4B04EFFEAB44FFFB08E4FFFAA8A51FFD39F\r\n      41FFD5A54CFFDDAF5BFFE1B461FFE8BB67FFECBF69FFE9BC67FFEABC64FFE7B6\r\n      5AFFF0BA55FFD4AC5EFF1F1E1D850000000000000000525252FFE7E7E7FFBABA\r\n      BAFFB9B9B9FF8E8E8EFF8C8C8CFF929292FF999999FF9E9E9EFFA3A3A3FFA7A7\r\n      A7FFAAAAAAFFABABABFFADADADFFACACACFFAAAAAAFFA9A9A9FF989898FFC5C5\r\n      C5FF969696FFC3C3C3FF939393FFC1C1C1FF919191FFC0C0C0FF8F8F8FFFBFBF\r\n      BFFF9F9F9FFFB2B2B2FF525252FF00000000BA8A61FFFDFAF7FFFDF9F5FFFDF8\r\n      F4FFFDF7F3FFFDF7F2FFFDF7F2FFFDF6F1FFC89D76FFFEF9F6FFFEF6F0FFEBEA\r\n      DEFFD8DFCDFF94BB97FF7ACC8AFF7CD98FFF78D88CFF75D588FF6DBB7CFF7AAD\r\n      83FFD3D8C2FFFDEBDEFFFDEADCFFFDECE0FFFEF3EBFFFFFBF9FFFFFEFEFFFFFF\r\n      FFFFFFFFFFFFCDB7ABFF603F2EA8000000000000000000000000000000000000\r\n      00000B0B0B1A3A3A3A7B3D3C3C7F504E4D7F5E5B597F62605E7F6C6A697F7978\r\n      787F7C7C7C7F7D7C7C7F7D7D7D7F7E7E7E7F7E7E7E7F7E7E7E7F7D7D7D7F7D7C\r\n      7C7F7A79797F6E6C6B7F6664637F62605E7F504E4D7F3D3D3D7F373737740707\r\n      070E00000000000000000000000000000000000000000E0E0E41868686BCFFFF\r\n      FFFFD4AF6DFFBB8015FFC18823FFC48B25FFC68E27FFC89028FFCD952DFFD8A0\r\n      39FFDCA43DFFDEA83FFFE1AA41FFE3AB42FFE5AD42FFEAAF42FFAD8C4EFFA78A\r\n      56FFD7A549FFDBAC56FFDEB15CFFE1B460FFE4B762FFE7B863FFE9BB62FFECB8\r\n      56FFD4AB5EFF6A6764DE000000070000000000000000525252FFE9E9E9FFBABA\r\n      BAFFB9B9B9FF878787FF8A8A8AFF929292FF999999FF9E9E9EFFA3A3A3FFA7A7\r\n      A7FFAAAAAAFFABABABFFADADADFFADADADFFABABABFFAAAAAAFF989898FFC5C5\r\n      C5FF969696FFC3C3C3FF949494FFC2C2C2FF919191FFC0C0C0FF8F8F8FFFBFBF\r\n      BFFF9F9F9FFFB4B4B4FF525252FF00000000C1946DFFFFFAF7FFFEF7F0FFFEF5\r\n      EEFFFEF4EDFFFEF3EBFFFEF2EBFFFEF2E9FFB9A077FFAACAAEFF7CAF86FF6EAD\r\n      7BFF72B580FF7ECC8EFF85DD96FF81DB92FF7CD98FFF78D88CFF75D688FF6FC6\r\n      80FF6AB279FF9EBE9BFFF1E5D5FFFDECE0FFFEF2E9FFFEF8F3FFFFFBF8FFFFFC\r\n      FAFFFFFDFBFFFEFDFCFF94644BFD4930237F0000000000000000000000000606\r\n      060C343434723B3B3B7F514E4B7F5A57557F605D5B7F6F6E6D7F7877777F7877\r\n      777F7776757F7776767F7978787F7C7B7B7F7F7F7E7F7C7B7B7F7A79797F7978\r\n      787F7A79797F7979787F706F6E7F63615F7F5F5C5A7F514F4D7F3B3B3B7F3030\r\n      306703030305000000000000000000000000000000000E0E0E41868686BCFFFF\r\n      FFFFD4B06FFFBB8119FFC18A25FFC38B27FFC68E29FFCB932FFFD7A03DFFDBA3\r\n      40FFDDA641FFDEA842FFE1AB44FFE4AD46FFE6AF48FFE9B24AFFEEB345FFB591\r\n      4DFFAB8E58FFDCAB51FFDCAC57FFDFB05AFFE2B35DFFE5B55DFFEBB95DFFCAA4\r\n      5DFF999895FF888A8CD8000000020000000000000000525252FFEAEAEAFFBABA\r\n      BAFFBABABAFF848484FF8A8A8AFF929292FF999999FF9E9E9EFFA3A3A3FFA7A7\r\n      A7FFAAAAAAFFACACACFFADADADFFAEAEAEFFABABABFFAAAAAAFF989898FFC5C5\r\n      C5FF979797FFC3C3C3FF949494FFC2C2C2FF929292FFC1C1C1FF909090FFBFBF\r\n      BFFF9F9F9FFFB7B7B7FF525252FF00000000C49A74FFFEF9F5FFFEF5EFFFFEF3\r\n      EBFFFEF2EAFFFEF1E9FFE7E5D6FF92B994FF73B080FF88CB94FF95DEA2FF97E4\r\n      A5FF92E2A1FF8EE19DFF8ADF9AFF85DD96FF81DB92FF7CD98FFF78D88CFF75D6\r\n      88FF71D585FF6BBC7BFF73AA7CFFC7D2B9FFFDEEE3FFFEF1E9FFFEF3ECFFFEF5\r\n      EEFFFEF6F0FFFEF8F4FFF6EEEAFF8A5E46E90000000000000000000000002A2A\r\n      2A5F3939397F4A48457F5652507F605D5A7F80746791B4874ECBCC8C40E7CB8C\r\n      3FE7CC8C40E7CD8D40E7CD8E41E7CF8E42E7CF8F42E7CF8E42E7CD8E41E7CD8D\r\n      40E7CC8C40E7CD8D40E7C28A48D88E77619F625F5D7F5B58557F4A48467F3A3A\r\n      3A7F2424244F000000000000000000000000000000000E0E0E41848484BCFFFF\r\n      FFFFD3AF6FFFB98018FFBF8824FFC28A26FFC78F2BFFCF9936FFD8A13FFFD9A2\r\n      3FFFDBA540FFDEA743FFE0A841FFE0A73AFFE4A93CFFE8AE3FFFEEB549FFB190\r\n      51FFAC8A4FFFD5A246FFDAA951FFDDAD54FFDFAF56FFE2B157FFE7B556FFCBA2\r\n      55FF9B958DFF8B8C92DC000000050000000000000000525252FFECECECFFBABA\r\n      BAFFBABABAFFB9B9B9FFB8B8B8FFB7B7B7FFB5B5B5FFB4B4B4FFB3B3B3FFB2B2\r\n      B2FFB1B1B1FFAFAFAFFFAEAEAEFFADADADFFACACACFFABABABFFAAAAAAFFA8A8\r\n      A8FFA7A7A7FFA6A6A6FFA5A5A5FFA4A4A4FFA2A2A2FFA1A1A1FFA0A0A0FF9F9F\r\n      9FFF9F9F9FFFB9B9B9FF525252FF00000000C69B76FFFEF9F6FFFEF5EFFFFEF3\r\n      ECFFFEF3EAFFBCD0B6FF6EA879FF8FCE9BFFA8ECB4FFA4EAB0FF9FE8ACFF9BE6\r\n      A9FF97E4A5FF92E2A1FF8EE19DFF8ADF9AFF85DD96FF81DB92FF7CD98FFF78D8\r\n      8CFF75D688FF71D585FF6CBE7CFF6EA879FFD5D9C3FFFDECE0FFFDEDE1FFFDED\r\n      E1FFFEEEE2FFFEF1E7FFFEF7F1FF9D6E54FF0000000000000000101010273737\r\n      377F413E3D7F514E4A7F5753517F736C648AD8862CFDC96F0CFED1842EFFD38A\r\n      37FFD38A37FFD38A37FFD38A37FFD38A37FFD38A37FFD38A37FFD38A37FFD38A\r\n      37FFD38A37FFD28935FFC96F0EFDD68022FF937656AC5B58557F5653507F403E\r\n      3D7F3838387F0A0A0A180000000000000000000000000E0E0E41848484BCFFFF\r\n      FFFFD1AE6EFFB87D17FFBE8723FFC38C29FFC6902CFFD19B39FFD6A03EFFD8A2\r\n      3EFFDAA441FFDCA43EFFE3B45CFFEFD5A5FFEFD4A2FFF0D7A6FFA9936AFFA481\r\n      43FFCB9534FFCA973BFFD2A045FFD8A74CFFDCAA50FFDFAE52FFDFAD4FFFE1AA\r\n      44FFD0A14AFF716C63E50000000E0000000000000000525252FFF0F0F0FFE0E0\r\n      E0FFE1E1E1FFE1E1E1FFE0E0E0FFE0E0E0FFDFDFDFFFDFDFDFFFDEDEDEFFDDDD\r\n      DDFFDDDDDDFFDDDDDDFFDCDCDCFFDCDCDCFFDBDBDBFFDBDBDBFFDADADAFFDADA\r\n      DAFFDADADAFFD9D9D9FFD8D8D8FFD7D7D7FFD7D7D7FFD6D6D6FFD6D6D6FFD5D5\r\n      D5FFD5D5D5FFD0D0D0FF525252FF00000000C89D76FFFEF9F6FFFEF6F0FFFEF4\r\n      EDFFB0CAAEFF89C594FFA9E5B3FFAFEFBAFFACEDB7FFA8ECB4FFA4EAB0FF9FE8\r\n      ACFF9BE6A9FF97E4A5FF92E2A1FF8EE19DFF8ADF9AFF85DD96FF81DB92FF7CD9\r\n      8FFF75CE88FF6EB87CFF90B892FFE9E3D2FFFDECE0FFFDEBDEFFFDEADDFFFDEA\r\n      DCFFFDEADCFFFDEDE0FFFEF4EDFFA2745BFF00000000000000012C2C2C6B3736\r\n      367F4B47447F514D4A7F605D5B7F96714AB8CD7416FFE3B780FFEBCDA3FFEBCD\r\n      A3FFEBCDA3FFEBCDA3FFEBCDA3FFEBCDA3FFEBCDA3FFEBCDA3FFEBCDA3FFEBCD\r\n      A3FFEBCDA3FFEBCDA3FFE9C79AFFCA751BFDB87B3EDD615E5C7F55524F7F4E4A\r\n      487F3636367F2727275D0000000000000000000000000E0E0E41848484BCFFFF\r\n      FFFFD1AD6DFFB67B15FFBE8725FFC38C2AFFC68F2CFFD19B3AFFD59F3DFFD6A1\r\n      3FFFDAA340FFDBA23AFFE6BF75FFFFFFFFFFFFFFFFFFB6B7BCFFA07838FFC389\r\n      24FFC28D2FFFC79235FFCB973AFFD29D3DFFD8A241FFD8A546FFD5A13FFFD49E\r\n      3BFFDDA337FFCD9D44FF292621960000000000000000505050F8F6F6F6FFDCDC\r\n      DCFFDDDDDDFFDBDBDBFFDCDCDCFFDCDCDCFFDCDCDCFFDCDCDCFFDBDBDBFFD9D9\r\n      D9FFD8D8D8FFD7D7D7FFD6D6D6FFD4D4D4FFD4D4D4FFD4D4D4FFD5D5D5FFD6D6\r\n      D6FFD7D7D7FFD7D7D7FFD8D8D8FFD8D8D8FFD8D8D8FFD7D7D7FFD6D6D6FFD7D7\r\n      D7FFD5D5D5FFE8E8E8FF545454FF00000000C99F77FFFEFAF7FFFEF6F1FFC1D4\r\n      BDFF8CC697FFB4EEBEFFB6F2C0FFB0EDBAFF9EDDA9FF8ECC99FF83C18FFF79B8\r\n      86FF74B281FF88CD95FF97E4A5FF92E2A1FF8EE19DFF8ADF9AFF85DD96FF75C0\r\n      84FF72A97CFFC5D3BBFFFEEFE5FFFEEEE3FFFEEDE1FFFDECE0FFFDEBDEFFFDEA\r\n      DCFFFDEADCFFFDECE0FFFEF4ECFFA4765CFF000000000E0E0E243434347F403D\r\n      3B7F4C47447F54504E7F605E5C7FA66E39D3CE7F29FEE8C496FFE8C496FFE8C4\r\n      96FFE8C496FFE8C496FFE8C496FFE8C496FFE8C496FFE8C496FFE8C496FFE8C4\r\n      96FFE8C496FFE8C496FFE8C496FFD7954AFFC8772DF86462607F5753517F504C\r\n      497F3D3C3A7F3535357F0707071300000000000000000E0E0E41848484BCFFFF\r\n      FFFFCFAC6CFFB57A15FFBF8827FFC18B29FFC58E2BFFD09A39FFD49F3DFFD6A0\r\n      3EFFD8A240FFDAA23AFFE4BC71FFFFFFFFFFC0C0C2FF936A27FFB87C15FFB982\r\n      21FFBF8929FFC48E2EFFCD9430FFB48B42FFAB894CFFD29A32FFCE9732FFD199\r\n      33FFD29A33FFDDA233FFD5A54CFF1F1D1C8600000000444444D3E9E9E9FFE1E1\r\n      E1FFF7F7F7FFE7E7E7FFDADADAFFD9D9D9FFD6D6D6FFD5D5D5FFD6D6D6FFD9D9\r\n      D9FFDCDCDCFFDCDCDCFFDBDBDBFFDADADAFFD5D0CDFFD9D9D9FFDBDBDBFFD9D9\r\n      D9FFD7D7D7FFD0D0D0FFCECECEFFCFCFCFFFD1D1D1FFD3D3D3FFE2E2E2FFF6F6\r\n      F6FFDADADAFFD3D3D3FF4A4A4ADB00000000CAA077FFFEFAF7FFE2E8DBFF6BA6\r\n      76FFAFE7B9FFA2DBACFF82BD8DFF6EA879FF83A576FFAECCB1FFC3D6C0FFD4DF\r\n      CEFFE0E6D8FFA2C3A4FF89CE96FF97E4A5FF92E2A1FF84D092FF73B781FF9BBF\r\n      9CFFF0EBDEFFFEF1E8FFFEF0E6FFFEEFE5FFFEEEE3FFFEEDE1FFFDECE0FFFDEB\r\n      DEFFFDEBDDFFFDEDE1FFFEF4EDFFA5775DFF000000001E1E1E4D3232327F4844\r\n      417F4B47437F5855527F55514E7FA16636D3D18736FEE5BC89FFE5BC89FFE5BC\r\n      89FFE5BC89FFE5BC89FFE5BC89FFE5BC89FFE5BC89FFE5BC89FFE5BC89FFE5BC\r\n      89FFE5BC89FFE5BC89FFE5BC89FFD99B53FFC3702AF85A57547F5B57557F4F4B\r\n      487F45423E7F3333337F1818183B00000000000000000E0E0E41848484BCFFFF\r\n      FFFFCFAB6BFFB57A16FFBD8726FFC08A28FFC38C2AFFCD9837FFD39D3DFFD59F\r\n      3EFFD7A240FFD9A13AFFE0B971FFFFFFFFFFE1E2E5FF947C55FFAD7412FFB57B\r\n      1BFFB88221FFC28922FFAA8034FFB1AFADFFC1C3C8FFA5803FFFCE9327FFCD95\r\n      2EFFD09730FFDCA133FF997D47F1070808450000000026262679B6B6B6FFEBEB\r\n      EBFFDDDDDDFFDADADAFFD8D8D8FFD6D6D6FFDADADAFFE2E2E2FFDEDEDEFFD7D7\r\n      D7FFCFCFCFFFCBCBCBFFC8C8C8FFB8ABA2FF87491EFFB8ABA2FFC6C6C6FFCACA\r\n      CAFFD0D0D0FFD7D7D7FFDADADAFFD2D2D2FFCECECEFFCFCFCFFFD2D2D2FFD8D8\r\n      D8FFDDDDDDFF9D9D9DFF2828287E00000000CBA178FFFEFAF7FF97BE9CFF9AD2\r\n      A3FF6BA676FF99BE9CFFD1DCC9FFFCF2EBFFD0A57AFFFEFAF7FFFEF7F2FFFEF6\r\n      F0FFFEF6F0FFB0CBAFFF86C893FF9BE6A9FF7EC38CFF79AD83FFD1DCC9FFFEF3\r\n      ECFFFEF3EAFFFEF2E9FFFEF1E8FFFEF0E6FFFEEFE5FFFEEEE3FFFEEDE1FFFDEC\r\n      E0FFFDECDFFFFDEEE2FFFEF4EEFFA6785EFF000000002C2C2C743534337F4B47\r\n      437F4C48447F504C4A7F504C497F9C5F33D3D28B3CFEE2B47BFFE2B47BFFE2B4\r\n      7BFFE2B47BFFE2B47BFFE2B47BFFE2B47BFFE2B47BFFE2B47BFFE2B47BFFE2B4\r\n      7BFFE2B47BFFE2B47BFFE2B47BFFD99B53FFBD6929F854504E7F55524F7F4D49\r\n      467F4B46437F3333337F2626266200000000000000000E0E0E41848484BCFFFF\r\n      FFFFCEAA6BFFB57A16FFBC8625FFBF8827FFC18B28FFC99333FFD39D3DFFD49F\r\n      3EFFD6A13FFFD8A03AFFDFB971FFFDFFFFFFFFFFFFFFE1E4EAFF917A55FFAC73\r\n      12FFB97D16FF9F7226FFB1AFABFFFFFFFFFFFFFFFFFFBFC0C1FFA5803DFFCF94\r\n      28FFD3982BFF9D7E47FB0507084500000000000000000707071A646464FBF5F5\r\n      F5FFDCDCDCFFD9D9D9FFD7D7D7FFDFDFDFFFDFDFDFFFD7D7D7FFD4D4D4FFD1D1\r\n      D1FFCECECEFFC8C8C8FFBDB4AEFF8C522AFFA6714CFF8D532AFFBBB5B0FFC4C4\r\n      C4FFC6C6C6FFCACACAFFCDCDCDFFD8D8D8FFD9D9D9FFCDCDCDFFD0D0D0FFD3D3\r\n      D3FFE0E0E0FF606060FB0808081B00000000CDA278FFEEF1E9FF6BA676FF8FB9\r\n      94FFE9EBDFFFFEF5EFFFFEF5EEFFFEF4EDFFD2A77BFFFEFAF7FFFEF7F2FFFEF6\r\n      F0FFFEF6F0FFB0CBAFFF89CA95FF75B583FFA7C6A8FFF5F0E8FFFEF5EEFFFEF4\r\n      EDFFFEF3ECFFFEF3EAFFFEF2E9FFFEF1E8FFFEF0E6FFFEEFE5FFFEEEE3FFFEED\r\n      E1FFFDEDE1FFFDEEE4FFFEF5EEFFA77A5EFF0404040C2F2F2F7F3B39377F4B47\r\n      437F4C47447F4C47447F4E4A467F96572FD3D38E43FEDFAC6EFFDFAC6EFFDFAC\r\n      6EFFDFAC6EFFDFAC6EFFDFAC6EFFDFAC6EFFDFAC6EFFDFAC6EFFDFAC6EFFDFAC\r\n      6EFFDFAC6EFFDFAC6EFFDFAC6EFFD99C54FFB86128F8524E4B7F504B487F4C47\r\n      447F4B47437F3837367F2E2E2E7800000000000000000E0E0E41848484BCFFFF\r\n      FFFFCDA96AFFB37A16FFBB8424FFBD8726FFC08A28FFC48D2BFFD09B3AFFD49F\r\n      3EFFD6A03FFFD79F3AFFDEB871FFFDFFFFFFFFFFFFFFFFFFFFFFE0E3E9FF9480\r\n      5CFF95671CFFAFACA6FFFEFFFFFFFFFFFFFFFFFFFFFFFBFCFFFF9F9B93FFA77C\r\n      32FFA68548FF75767CDE000000070000000000000000000000003A3A3AB3D8D8\r\n      D8FFE7E7E7FFDCDCDCFFE3E3E3FFDFDFDFFFD6D6D6FFD5D5D5FFD5D5D5FFD4D4\r\n      D4FFD1D1D1FFC6BFBAFF8E562EFFB1825DFFCAA589FFAD7B58FF935F3BFFC5C3\r\n      C1FFCACACAFFCCCCCCFFCDCDCDFFD0D0D0FFD8D8D8FFDBDBDBFFD2D2D2FFDBDB\r\n      DBFFBDBDBDFF393939AE0000000000000000CEA379FFC3D8C3FF9CC1A0FFFCF5\r\n      EFFFFEF6F0FFFEF6F0FFFEF5EFFFFEF5EEFFD2A87BFFFEFAF7FFFEF7F2FFFEF6\r\n      F0FFFEF6F0FFB0CBAFFF81B189FFDBE3D3FFFEF6F0FFFEF6F0FFFEF5EFFFFEF5\r\n      EEFFFEF4EDFFFEF3ECFFFEF3EAFFFEF2E9FFFEF1E8FFFEF0E6FFFEEFE5FFFEEE\r\n      E3FFFEEDE2FFFDEFE5FFFEF5EFFFA97B5FFF080808192D2D2D7F3D3B397F4B47\r\n      437F4B47437F4B47437F4B47447F91502ED3D2924AFEDCA461FFDCA460FFDCA4\r\n      60FFDCA562FFDCA561FFDCA460FFDCA460FFDCA460FFDCA460FFDCA460FFDCA4\r\n      60FFDCA460FFDCA460FFDCA460FFD99C54FFB15C26F84F4B487F4C48457F4B47\r\n      437F4B47437F3938367F2E2E2E7F01010105000000000E0E0E41848484BCFFFF\r\n      FFFFCCA96AFFB37815FFBA8323FFBC8625FFBF8828FFC18B29FFC6912FFFD29C\r\n      3CFFD6A03FFFD69E39FFDEB771FFFDFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFE2E3\r\n      E5FFB4B3B3FFFCFDFFFFFFFFFFFFFFFFFFFFFFFFFFFFFAFCFFFFD2BF9DFFB391\r\n      52FFACAFB5FF969698DF000000080000000000000000000000001818184E9191\r\n      91FFF5F5F5FFDCDCDCFFE7E7E7FFE0E0E0FFDCDCDCFFD9D9D9FFD6D6D6FFD6D6\r\n      D6FFD2CECCFF935D38FFAC7954FFBF926FFFA96B3CFFC69D7DFFA26F49FF9F75\r\n      57FFD0D0D0FFD1D1D1FFD2D2D2FFD4D4D4FFD6D6D6FFDEDEDEFFD4D4D4FFE5E5\r\n      E5FF7E7E7EFF161616480000000000000000CFA47AFFB8D2BAFFFBF5EFFFFEF6\r\n      F0FFFEF6F0FFFEF6F0FFFEF6F0FFFEF5EFFFD4A87BFFFEFAF7FFFEF7F2FFFEF6\r\n      F0FFFEF6F0FFE2E7D9FFFBF4EDFFFEF6F0FFFEF6F0FFFEF6F0FFFEF6F0FFFEF5\r\n      EFFFFEF5EEFFFEF4EDFFFEF3ECFFFEF3EAFFFEF2E9FFFEF1E8FFFEF0E6FFFEEF\r\n      E5FFFEEEE4FFFEF0E6FFFEF6F0FFAA7C60FF0D0D0D262C2C2C7F403C3A7F4B47\r\n      437F4B47437F4E49467F524F4B7F8C4C2BD3D79D5DFEE4B784FFE2B47EFFE3B7\r\n      84FFE4B884FFE4B884FFE4B884FFE3B784FFE3B681FFE1B177FFDFAC6FFFDDA6\r\n      65FFDA9F59FFD99C54FFD99C54FFD99D55FFAD5625F854504D7F4D49457F4B47\r\n      437F4B47437F3B39377F2D2D2D7F05050512000000000E0E0E41848484BCFFFF\r\n      FFFFCCA869FFB17714FFB88222FFBB8525FFBE8626FFC08B29FFC28C2BFFC892\r\n      30FFD29D3DFFD69E3AFFDEB771FFFDFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n      FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF9FCFFFFCEBA95FFF4C5\r\n      69FFDDDFE3FF909092DF00000008000000000000000000000000010101044C4C\r\n      4CE5F0F0F0FFE4E4E4FFE5E5E5FFE4E4E4FFE2E2E2FFE0E0E0FFDDDDDDFFDAD9\r\n      D8FF9A6947FFA26D46FFBF926EFFA76838FFA46332FFAA6E40FFC7A082FF9861\r\n      3BFFB1937DFFD8D8D8FFD9D9D9FFDADADAFFDADADAFFDADADAFFDADADAFFD8D8\r\n      D8FF474747DE010101020000000000000000D0A57AFFDFE8DCFFFEF7F2FFFEF6\r\n      F0FFFEF6F0FFFEF6F0FFFEF6F0FFFEF6F0FFD5A97CFFFEFAF7FFFEF7F2FFFEF6\r\n      F0FFFEF6F0FFFEF6F0FFFEF6F0FFFEF6F0FFFEF6F0FFFEF6F0FFFEF6F0FFFEF6\r\n      F0FFFEF5EFFFFEF5EEFFFEF4EDFFFEF3ECFFFEF3EAFFFEF2E9FFFEF1E8FFFEF0\r\n      E6FFFEEFE6FFFEF1E8FFFFF6F1FFAB7E61FF0B0B0B242A2A2A7F3E3C397F4C48\r\n      447F534F4C7F5754517F5754517F89462AD3DAA46CFEE8C49AFFE5BB8BFFE5BB\r\n      8BFFE5BB8BFFE5BB8BFFE5BB8BFFE5BB8BFFE5BB8BFFE5BB8BFFE5BB8BFFE5BB\r\n      8BFFE5BA89FFDEA96CFFD7974BFFD99D55FFA64E24F85B58567F5B58557F5450\r\n      4D7F4C47447F3A38367F2B2B2B7F06060610000000000E0E0E41848484BCFFFF\r\n      FFFFCAA668FFB07613FFB68121FFBA8324FFBC8626FFBF8929FFC28B2AFFC48D\r\n      2CFFC89230FFCF9732FFDEB871FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n      FFFFFFFFFFFFFAFAFCFFF6F7F9FFF3F5F8FFF4F5F7FFEDF1F9FFD1BD98FFEEC0\r\n      68FFDBDCE0FF909091DF00000008000000000000000000000000000000002B2B\r\n      2B86BDBDBDFFF0F0F0FFE1E1E1FFE5E5E5FFE5E5E5FFE4E4E4FFE2E1E0FFA377\r\n      59FF9F6941FFBD8E69FFA76839FFA46332FFA46332FFA46332FFB0774CFFC49C\r\n      7CFF925830FFC2B0A2FFDCDCDCFFDBDBDBFFDADADAFFD8D8D8FFE4E4E4FFA2A2\r\n      A2FF26262678000000000000000000000000D2A77BFFFBF8F4FFFEF7F2FFFEF6\r\n      F0FFFEF6F0FFFEF6F0FFFEF6F0FFFEF6F0FFD6AB7CFFFEFAF7FFFEF7F2FFFEF6\r\n      F0FFFEF6F0FFFEF6F0FFFEF6F0FFFEF6F0FFFEF6F0FFFEF6F0FFFEF6F0FFFEF6\r\n      F0FFFEF6F0FFFEF5EFFFFEF5EEFFFEF4EDFFFEF3ECFFFEF3EAFFFEF2E9FFFEF1\r\n      E8FFFEF0E7FFFEF2E9FFFFF7F1FFAC8062FF070707172828287F3B38367F5753\r\n      517F5E5B597F5A57547F5A57557F85412AD3DCAB78FEECCCA9FFE7C094FFE7C0\r\n      94FFE7C094FFE7C094FFE7C094FFE7C094FFE7C094FFE7C094FFE7C094FFE7C0\r\n      94FFE7C094FFE7C094FFE6BC8DFFDEA96BFFA14723F85E5B597F5E5C597F5F5C\r\n      5A7F514D4A7F3735337F2A2A2A7F00000003000000000E0E0E41848484BCFFFF\r\n      FFFFC8A466FFAD7311FFB57E21FFB88222FFBB8525FFBE8727FFC08A29FFC38D\r\n      2CFFC58F2EFFCE952EFFAB843EFF50555FFF55575CFF53555AFF515458FF5053\r\n      57FF4B4E53FF6D6A64FF7A766BFF7E776AFF747067FF6D6A66FF726040FFF4C6\r\n      6EFFDBDCE0FF909091DF00000008000000000000000000000000000000000B0B\r\n      0B22686868FEFAFAFAFFE1E1E1FFE4E4E4FFE7E7E7FFE7E7E7FFAC876BFF9C68\r\n      41FFC39B7AFFB58157FFAE7549FFAA6D40FFA56535FFA46332FFA46332FFB683\r\n      5BFFBE9373FF8F552CFFCEC3BBFFDCDCDCFFD9D9D9FFD9D9D9FFE9E9E9FF5C5C\r\n      5CF907070717000000000000000000000000D2A87BFFFEFAF7FFFEF7F2FFFEF6\r\n      F0FFFEF6F0FFFEF6F0FFFEF6F0FFFEF6F0FFD6AC7DFFFEFAF7FFFEF7F2FFFEF6\r\n      F0FFFEF6F0FFFEF6F0FFFEF6F0FFFEF6F0FFFEF6F0FFFEF6F0FFFEF6F0FFFEF6\r\n      F0FFFEF6F0FFFEF6F0FFFEF5EFFFFEF5EEFFFEF4EDFFFEF3ECFFFEF3EAFFFEF2\r\n      E9FFFEF1E9FFFEF3EAFFFFF7F2FFAE8263FF0303030A2727277F3634327F5652\r\n      507F6967657F6461607F5F5C5A7F833C29D3DFB283FEEFD5B9FFE9C69FFFE9C6\r\n      9FFFE9C69FFFE9C69FFFE9C69FFFE9C69FFFE9C69FFFE9C69FFFE9C69FFFE9C6\r\n      9FFFE9C69FFFE9C69FFFE9C69FFFE3B683FF9C4021F8615F5D7F615F5D7F625F\r\n      5D7F504B487F3231307F2525257600000000000000000E0E0E41848484BCFFFF\r\n      FFFFC7A366FFA96F0EFFB47D20FFB68122FFB98324FFBD8627FFBF8929FFC18B\r\n      2BFFC58E2DFFCD9630FFA67A2BFF060B13FF000715FF020915FF020916FF0209\r\n      16FF000112FF6D5E45FFA28B61FFA88D5AFF9B8761FF8D7853FF58431EFFF6C8\r\n      70FFDBDCE0FF909091DF00000008000000000000000000000000000000000000\r\n      00003C3C3CBCDFDFDFFFECECECFFE0E0E0FFE3E3E3FFB99B86FF986039FFC39A\r\n      7AFFBA8A64FFB6825AFFB58259FFB58158FFB48057FFB0784DFFAB6F42FFA768\r\n      38FFBE8F6BFFB68967FF905933FFD2CDCAFFD7D7D7FFE2E2E2FFC3C3C3FF3737\r\n      37AA00000000000000000000000000000000D4A87BFFFEFAF7FFFEF7F2FFFEF6\r\n      F0FFFEF6F0FFFEF6F0FFFEF6F0FFFEF6F0FFD7AC7DFFFEFAF7FFFEF7F2FFFEF6\r\n      F0FFFEF6F0FFFEF6F0FFFEF6F0FFFEF6F0FFFEF6F0FFFEF6F0FFFEF6F0FFFEF6\r\n      F0FFFEF6F0FFFEF6F0FFFEF6F0FFFEF5EFFFFEF5EEFFFEF4EDFFFEF3ECFFFEF3\r\n      EAFFFEF2EAFFFEF3ECFFFFF8F3FFB08363FF000000002121216F2B2A2A7F524E\r\n      4B7F6D6B6A7F6B6A687F6A69677F803A2AD3E1B88EFEF2DEC8FFEDCEADFFEDCE\r\n      ADFFEDCEADFFEDCEADFFEDCEADFFEDCEADFFEDCEADFFEDCEADFFEDCEADFFEDCE\r\n      ADFFEDCEADFFEDCEADFFEDCEADFFE5BB89FF983B20F86562607F6562617F6562\r\n      617F4C48447F2828287F1C1C1C5C00000000000000000E0E0E41848484BCFFFF\r\n      FFFFC5A163FFA46A07FFB0781AFFB47D1FFFB88021FFBA8423FFBC8625FFC089\r\n      28FFC38C2AFFC58E2CFFCC932FFF9D752DFF816331FF836530FF80622CFF8263\r\n      2DFF83632DFF8C6D36FF907039FF95753DFF91713AFF98773CFFCA932EFFEDC0\r\n      6CFFDADCE0FF909091DF00000008000000000000000000000000000000000000\r\n      00001C1C1C59979797FFF8F8F8FFE5E5E5FFC3AD9CFF955D37FFC29979FFC8A1\r\n      83FFC9A386FFCBA68AFFCCA88DFFB8855EFFB7845CFFB6825AFFCFAF94FFD0B0\r\n      97FFD1B299FFD1B198FFB08260FF9B6947FFDBDAD9FFEDEDEDFF7D7D7DFF1515\r\n      154300000000000000000000000000000000D5A97CFFFEFAF7FFFEF7F2FFFEF6\r\n      F0FFFEF6F0FFFEF6F0FFFEF6F0FFFEF6F0FFD8AD7EFFFEFAF7FFFEF7F2FFFEF6\r\n      F0FFFEF6F0FFFEF6F0FFFEF6F0FFFEF6F0FFFEF6F0FFFEF6F0FFFEF6F0FFFEF6\r\n      F0FFFEF6F0FFFEF6F0FFFEF6F0FFFEF6F0FFFEF5EFFFFEF5EEFFFEF4EDFFFEF3\r\n      ECFFFEF3EBFFFEF4EDFFFFF8F4FFB18564FF00000000141414472424247F4541\r\n      3D7F6D6B6A7F6F6E6D7F6E6D6C7F7E362AD3E2BE98FEF6E7D7FFF0D7BCFFF0D7\r\n      BCFFF0D7BCFFF0D7BCFFF0D7BCFFF0D7BCFFF0D7BCFFF0D7BCFFF0D7BCFFF0D7\r\n      BCFFF0D7BCFFF0D7BCFFF0D7BCFFE6BF90FF91331FF86866647F6866647F615E\r\n      5C7F403C3A7F2525257F0F0F0F3500000000000000000E0E0E41848484BCFFFF\r\n      FFFFC6A468FFA66D0CFFAD771BFFB48023FFB98428FFBB8729FFBE892CFFC18D\r\n      2EFFC48F30FFC79233FFCA9635FFD59D39FFD89F38FFD49A31FFD59B31FFD89E\r\n      33FFDBA135FFDCA136FFDEA338FFE0A539FFE4A93CFFE7AC3EFFE3A83AFFECC2\r\n      72FFDBDCE0FF909091DF00000008000000000000000000000000000000000C06\r\n      01170303030A4D4D4DEDF5F5F5FFCEBCAFFF87491EFF87491EFF87491EFF8749\r\n      1EFF87491EFF894D22FFCCA88CFFBA8A64FFB98862FFB88760FFCFAE95FF8749\r\n      1EFF87491EFF87491EFF87491EFF87491EFFAD896EFFDEDEDEFF464646D90000\r\n      000100000000000000000000000000000000D6AB7CFFFEFAF7FFFEF7F2FFFEF6\r\n      F0FFFEF6F0FFFEF6F0FFFEF6F0FFFEF6F0FFD9AE7EFFFEFAF7FFFEF7F2FFFEF6\r\n      F0FFFEF6F0FFFEF6F0FFFEF6F0FFFEF6F0FFFEF6F0FFFEF6F0FFFEF6F0FFFEF6\r\n      F0FFFEF6F0FFFEF6F0FFFEF6F0FFFEF6F0FFFEF6F0FFFEF5EFFFFEF5EEFFFEF4\r\n      EDFFFEF3EDFFFEF5EEFFFFF9F4FFB28665FF000000000707071E2222227F3432\r\n      307F6462607F7372717F7270707F79312AD3E2BE9AFEFCF7F2FFF4E3D0FFF4E3\r\n      D0FFF4E3D0FFF4E3D0FFF4E3D0FFF4E3D0FFF4E3D0FFF4E3D0FFF4E3D0FFF4E3\r\n      D0FFF4E3D0FFF4E3D0FFF4E3D0FFE8C396FF8B2D1FF86B69687F6B69687F5955\r\n      537F2F2E2D7F2323237F0303030E00000000000000000E0E0E41868686BCFFFF\r\n      FFFFFCF7EDFFFAF0E0FFF9F0E0FFF8EFE0FFF8EFE0FFF7EEDFFFF6EDDEFFF6ED\r\n      DDFFF4EBDCFFF4EBDBFFF3EADAFFF2E9DAFFF0E7D6FFEEE5D6FFEEE5D4FFEDE4\r\n      D4FFECE3D3FFEBE2D2FFEAE1D0FFE9E0D0FFE8DFCFFFE8DECEFFE7DDCCFFE8E1\r\n      D5FFDADADCFF989899DF00000008000000000000000000000000000000001C0E\r\n      0635110903213B3B3BB6AFAFAFFFFCFCFCFFFEFEFEFFFDFDFDFFFDFDFDFFFCFC\r\n      FCFFF5F2F0FF915730FFCBA78BFFBD8F6AFFBC8D68FFBD8E69FFCCA98EFF8D51\r\n      29FFF6F6F6FFF5F5F5FFF4F4F4FFF3F3F3FFF2F2F2FF959595FF252525750000\r\n      000000000000000000000000000000000000D6AC7DFFFEFAF7FFFEF7F2FFFEF6\r\n      F0FFFEF6F0FFFEF6F0FFFEF6F0FFFEF6F0FFDAAF80FFFEFAF7FFF2DEB2FFF2DB\r\n      AFFFF1D8ABFFF0D4A6FFEFD1A1FFEECC9BFFECC796FFEBC290FFEABD8AFFE9B9\r\n      84FFE7B581FFE7B27CFFE6B079FFE6B079FFE6B079FFE6B079FFE6B079FFE6B0\r\n      79FFE6B079FFE6B079FFFFF9F5FFB38866FF00000000000000001A1A1A642221\r\n      217F4A47447F7372717F7574737F76423EB8C48A6BFFFBF5EEFFFDF9F6FFFBF5\r\n      EEFFFBF5EEFFFBF5EEFFFBF5EEFFFBF4EDFFFBF4EDFFFBF4EDFFFBF4EDFFFBF4\r\n      ECFFFBF4ECFFFBF4ECFFF8EDE0FFE0B993FD77251FDD6E6D6B7F6765637F4340\r\n      3C7F2222227F161616540000000000000000000000000909094158595ABCAFB0\r\n      B3FFA8ABAFFFA8ABB0FFA6A9AFFFA5A8ADFFA3A6ACFFA2A5AAFFA0A3A8FF9FA1\r\n      A7FF9C9FA5FF9B9EA3FF999CA2FF989BA0FF96999FFF94979DFF898D95FF858A\r\n      93FF8D9096FF8B8E94FF80858EFF81858DFF898B91FF7E838AFF787D88FF8082\r\n      88FF87888BFF646568DF00000008000000000000000000000000000000002B17\r\n      0A5340230D7B0B0B0B243E3E3EBD575757FD5B5B5BFF5B5B5BFF5B5B5BFF5B5B\r\n      5BFF65564CFF986643FFCBA589FFBF9370FFBE906CFFC29776FFC49D7EFF834D\r\n      27FF5B5B5BFF5A5A5AFF5A5A5AFF5A5A5AFF565656FC363636A9010101070000\r\n      000000000000000000000000000000000000D7AC7DFFFEFAF7FFFEF7F2FFFEF6\r\n      F0FFFEF6F0FFFEF6F0FFFEF6F0FFFEF6F0FFDAAF80FFFEFAF7FFF2DDAFFFF1DA\r\n      ACFFF0D7A8FFEFD3A3FFEECF9EFFEDCA98FFEBC592FFEAC08CFFE9BB86FFE8B6\r\n      80FFE6B27BFFE6AF77FFE5AD74FFE5AD74FFE5AD74FFE5AD74FFE5AD74FFE5AD\r\n      74FFE5AD74FFE5AD74FFFFF9F6FFB58966FF00000000000000000707071F1F1F\r\n      1F7F2E2C2B7F5D59577F7777767F766B6B8A87261EFDD2A281FEEFD5B5FFF0D8\r\n      BCFFF0D8BCFFF0D8BCFFF0D8BCFFF0D8BCFFF0D8BCFFF0D8BCFFF0D8BBFFF0D8\r\n      BBFFF0D7BAFFF0D6B7FFDEB792FD9C4738FF714746AC706F6E7F514D4A7F2928\r\n      287F2020207D030303110000000000000000000000000101024106080BBC090C\r\n      14FF090C13FF090D13FF0A0D13FF0A0D13FF0A0D13FF0A0D13FF0A0D14FF0A0D\r\n      14FF0A0D14FF0A0E14FF0B0E14FF0B0E14FF0A0D13FF090D16FF4F4D4AFF6560\r\n      56FF151921FF191C24FF666157FF4C4B49FF040912FF424242FF686359FF1B1F\r\n      27FF080B12FF0D1015DF00000008000000000000000000000000000000001E10\r\n      0639593013A92413084500000000000000000000000000000000000000000000\r\n      0000592F14A5B58968FCC8A183FFC29775FFC19572FFC9A386FFAF815FFC4B29\r\n      118E000000000000000000000000000000000000000000000000000000000000\r\n      000000000000000000000000000000000000D8AD7EFFFEFAF7FFFEF7F2FFFEF6\r\n      F0FFFEF6F0FFFEF6F0FFFEF6F0FFFEF6F0FFDBAF7EFFFEFAF7FFF2DDAFFFF1DA\r\n      ACFFF0D7A8FFEFD3A3FFEECF9EFFEDCA98FFEBC592FFEAC08CFFE9BB86FFE8B6\r\n      80FFE6B27BFFE6AF77FFE5AD74FFE5AD74FFE5AD74FFE5AD74FFE5AD74FFE5AD\r\n      74FFE5AD74FFE5AD74FFFFFAF7FFB78A68FF0000000000000000000000001515\r\n      15541F1F1F7F3735337F6D6C6A7F7979787F76656591722D2DCB701313E77013\r\n      13E7701313E7701313E7701313E7701313E7701413E7701413E7701413E77014\r\n      13E7701414E7701414E7722222D87255559F7473727F5E5B587F32302E7F1F1F\r\n      1F7F1111114400000000000000000000000000000000020202420D0E11BD1619\r\n      1FFF15181EFF15181EFF15181EFF15181EFF15181EFF15181EFF15181EFF1518\r\n      1EFF15181EFF15181EFF15181EFF15181EFF0C1018FF595651FFD3A656FFDCAA\r\n      4BFF9B8C70FF918265FFD4A244FFDDB260FF7E7A74FFC29C58FFDBA847FFB5A2\r\n      7CFF151B25FF13151AE000000008000000000000000000000000000000000502\r\n      0009693818C7824820F32011063D000000000000000000000000000000002F18\r\n      0B588C572FF3CDAB90FFC69E7EFFC49B7AFFC39A79FFCEAC91FF89532DF1180D\r\n      042D000000000000000000000000000000000000000000000000000000000000\r\n      000000000000000000000000000000000000D9AE7EFFFEFAF7FFFEF7F2FFFEF6\r\n      F0FFFEF6F0FFFEF6F0FFFEF6F0FFFEF6F0FFDAAD7AFFFFFBF8FFF2DDAFFFF1DA\r\n      ACFFF0D7A8FFEFD3A3FFEECF9EFFEDCA98FFEBC592FFEAC08CFFE9BB86FFE8B6\r\n      80FFE6B27BFFE6AF77FFE5AD74FFE5AD74FFE5AD74FFE5AD74FFE5AD74FFE5AD\r\n      74FFE5AD74FFE5AD74FFFFFBF9FFB58864FF0000000000000000000000000101\r\n      01061B1B1B692020207F413D3B7F6B69687F7473727F7473737F7474737F7574\r\n      737F7574737F7574737F7574747F7575747F7675747F7675747F7675757F7676\r\n      757F7676757F7776757F7776767F7776767F6967667F3836347F1F1F1F7F1717\r\n      175C0000000100000000000000000000000000000000010101360D0D11B01619\r\n      1FFF14171DFF14171DFF14171DFF14171DFF14171DFF14171DFF14171DFF1417\r\n      1DFF14171DFF14171DFF14171DFF14171DFF090D16FF6B6458FFDFAD53FFEBB7\r\n      58FFB7A178FFA89168FFE0AD4FFFECBB5DFFA19887FFCFA354FFE7B353FFD3B7\r\n      84FF1B212DFF121318D500000002000000000000000000000000000000000000\r\n      00003C200D727A4B29D7834D29EA522E129B23120742251408475B3216AB8C54\r\n      2FF6C7A286FFCCA98DFFC8A184FFC69F80FFCDAB90FFB18663FD5E3215AD0000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      000000000000000000000000000000000000DAAF80FFFEFAF7FFF2DEB2FFF2DB\r\n      AFFFF1D8ABFFF0D4A6FFEFD1A1FFEECC9CFFD7A770FFFFFDFCFFFFFCFAFFFFFB\r\n      F9FFFFFBF9FFFFFBF9FFFFFBF9FFFFFBF9FFFFFBF9FFFFFBF9FFFFFBF9FFFFFB\r\n      F9FFFFFBF9FFFFFBF9FFFFFBF9FFFFFBF9FFFFFBF9FFFFFBF9FFFFFBF9FFFFFB\r\n      F9FFFFFBF9FFFFFCFAFFFFFDFCFFB3835DFF0000000000000000000000000000\r\n      0000040404101D1D1D741F1F1F7F3735337F5F5C5A7F7675747F7877777F7877\r\n      777F7877777F7878777F7978777F7978787F7978787F7979787F7979787F7A79\r\n      797F7A79797F7A79797F7776757F5C59567F32302E7F1F1F1F7F1B1B1B690101\r\n      010700000000000000000000000000000000000000000000000102020349191C\r\n      23FD1C1F25FF1C1F25FF1C1F25FF1C1F25FF1C1F25FF1C1F25FF1C1F25FF1C1F\r\n      25FF1C1F25FF1C1F25FF1C1F25FF1C1F25FF191D23FF262A31FF9A8E78FFB8A6\r\n      87FF414245FF454547FFB7A586FF978B77FF242932FF867C6EFFBBA887FF4E4E\r\n      4EFF13171EFF0606076F00000000000000000000000000000000000000000000\r\n      000003010106693817C673533DAD876147C9895939E196633FEFB08260FDCDAB\r\n      90FFCFAD93FFCCA78CFFCBA68AFFCFAD94FFC1997BFF7E461EE90D0603190000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      000000000000000000000000000000000000DAAF80FFFEFAF7FFF2DDAFFFF1DA\r\n      ACFFF0D7A8FFEFD3A3FFEECF9EFFEDCA98FFD5A268FFD6A56DFFD7A771FFD7A8\r\n      72FFD5A772FFD5A571FFD4A471FFD3A370FFD1A26FFFD0A06FFFCE9F6EFFCC9E\r\n      6DFFCB9C6CFFCA9B6CFFC8996BFFC6976AFFC4956AFFC29569FFC19368FFBF91\r\n      67FFBD8F65FFBA8B62FFB6865CFFB17E56FF0000000000000000000000000000\r\n      0000000000000303030E1A1A1A671F1F1F7F2C2B2A7F4C49467F6F6E6D7F7B7B\r\n      7A7F7B7B7B7F7B7B7B7F7C7B7B7F7C7B7B7F7C7C7B7F7C7C7C7F7C7C7C7F7D7C\r\n      7C7F7D7D7C7F6C6B6A7F4744417F2928277F1F1F1F7F1717175C010101070000\r\n      0000000000000000000000000000000000000000000000000000000000000101\r\n      033D121416A11F2024B91E2023B71E2023B71E2023B71E2023B71E2023B71E20\r\n      23B71E2023B71E2023B71E2023B71E2023B71E2023B71C1E20B7191C21B71B1E\r\n      23B71B1C20B71B1C20B71B1E25B7171B20B71B1C20B7191B20B71A1D24B91012\r\n      14A6040505510000000000000000000000000000000000000000000000000000\r\n      0000000000000F07021C76411BDE886043D0B2917AE1CBA78BFFCEAB90FFCEAD\r\n      93FFD0AF96FFD1B198FFD1B299FFB48A6AFC814920F0180D042D000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      000000000000000000000000000000000000DBAF7EFFFEFAF7FFF2DDAFFFF1DA\r\n      ACFFF0D7A8FFEFD3A3FFEECF9EFFEDCA98FFEBC592FFEAC08CFFE9BB86FFE8B6\r\n      80FFE6B27BFFE6AF77FFE5AD74FFE5AD74FFE5AD74FFE5AD74FFE5AD74FFE5AD\r\n      74FFE5AD74FFE5AD74FFFFFAF7FFB78A68FF0303030300000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      00000000000000000000010101051414144F1F1F1F7F2020207F302F2D7F4F4C\r\n      4A7F615E5C7F6B6A687F7574747F7E7E7E7F7E7D7D7F7474737F6A68677F5F5D\r\n      5B7F4A48467F2D2B2A7F1F1F1F7F1F1F1F7D1111114400000001000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      000000000000000000000A040112623517B8885028F2AD7F59FDC09878FFC9A6\r\n      89FFC6A285FFB38967FD8F5932F56A3A17C50E08021B00000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      000000000000000000000000000000000000DAAD7AFFFFFBF8FFF2DDAFFFF1DA\r\n      ACFFF0D7A8FFEFD3A3FFEECF9EFFEDCA98FFEBC592FFEAC08CFFE9BB86FFE8B6\r\n      80FFE6B27BFFE6AF77FFE5AD74FFE5AD74FFE5AD74FFE5AD74FFE5AD74FFE5AD\r\n      74FFE5AD74FFE5AD74FFFFFBF9FFB58864FF0202020200000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      000000000000000000000000000000000000060606181616165D1F1F1F7F1F1F\r\n      1F7F2222227F2C2B2A7F302F2D7F3634327F3533317F302E2D7F2B2A297F2221\r\n      217F1F1F1F7F1F1F1F7F15151554030303110000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000001D1006364F2A1192703D1AD0743F\r\n      1BD66E3D1ACB4B29118E1E0F0738000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      000000000000000000000000000000000000D7A770FFFFFDFCFFFFFCFAFFFFFB\r\n      F9FFFFFBF9FFFFFBF9FFFFFBF9FFFFFBF9FFFFFBF9FFFFFBF9FFFFFBF9FFFFFB\r\n      F9FFFFFBF9FFFFFBF9FFFFFBF9FFFFFBF9FFFFFBF9FFFFFBF9FFFFFBF9FFFFFB\r\n      F9FFFFFBF9FFFFFCFAFFFFFDFCFFB3835DFF0202020200000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000040404130E0E\r\n      0E3B181818621E1E1E781F1F1F7F1F1F1F7F1F1F1F7F1F1F1F7F1D1D1D761717\r\n      175C0D0D0D350303030E00000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      000000000000000000000000000000000000D5A268FFD6A56DFFD7A771FFD7A8\r\n      72FFD5A772FFD5A571FFD4A471FFD3A370FFD1A26FFFD0A06FFFCE9F6EFFCC9E\r\n      6DFFCB9C6CFFCA9B6CFFC8996BFFC6976AFFC4956AFFC29569FFC19368FFBF91\r\n      67FFBD8F65FFBA8B62FFB6865CFFB17E56FF0000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000001010105040404120404041000000003000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      000000000000000000040000000D0000000F0000000600000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000606060C0E0E0E1915151526141414240D0D0D170505050A0000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      000000000000000000000000000000000000000000000000000B000000220000\r\n      002D0000002D0000002D0000002D0000002D0000002D0000002D0000002D0000\r\n      002D0000002D0000002D0000002D0000002D000000220000000B000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000D0000002B000000340000001C00000006000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000001010101131313242929\r\n      294D3D3D3D744444447F4444447F4444447F4444447F4444447F4444447F3B3B\r\n      3B6F252525471010101E00000000000000000000000000000000000000000000\r\n      00000000000000000000000000000000000000000000584B189C96822AF29682\r\n      2AF296822AF296822AF296822AF296822AF296822AF296822AF296822AF29682\r\n      2AF296822AF296822AF296822AF296822AF296822AF2584B189C000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000020000\r\n      0008000000100000001500000016000000160000001600000016000000150000\r\n      00100000000800000016835C2EC5B88443FF0000003D0000001C000000060000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0001000000010000000200000003000000030000000400000004000000050000\r\n      000500000005000000050000000600000006000000060000000F010101140000\r\n      00190000001C0101011D0101011F02020220020202200101011F0101011E0000\r\n      001C0101011A00000017010101140000000F0000000000000000000000000000\r\n      000000000000000000000000000000000000141414273737376B4242427F4242\r\n      427F4948487F5453527F5958577F5E5D5C7F5E5D5C7F5959587F5453537F4848\r\n      487F4242427F4242427F343434641010101F0000000000000000000000000000\r\n      0000000000000000000000000000000000000000000096822AF2F0D548FFEBCB\r\n      2BFFEBCB2BFFEBCB2BFFEBCB2BFFEBCB2BFFEBCB2CFFEBCC2DFFEBCC2DFFEBCC\r\n      2DFFEBCC2DFFEBCC2DFFEBCC2DFFEBCC2DFFF0D549FF96822AF2000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      000000000000000000000000000000000000000000030000000B000000170000\r\n      0026000000350000004000000043000000430000004300000043000000400000\r\n      0035000000260000002BB98340FFFFD28BFFB58040FF0000003D0000001C0000\r\n      0006000000000000000000000000000000000000000100000002000000030000\r\n      0005000000080101010A0000000C0000000E0000000F01010110000000110000\r\n      0012000000130101011401010114010101140101011401010124533A1181C389\r\n      26F6CC9027FFCC9027FFCC9027FFCC9027FFCC9027FFCC9027FFCC9027FFCC90\r\n      27FFCC9027FFCC9027FFC78C27FA614412860000000000000000000000000000\r\n      000000000000000000000606060C3030305F4040407F4242427F5251507F6260\r\n      5F7F6A68677F6D6C6B7F706F6E7F7270707F7271707F7270707F706F6E7F6D6C\r\n      6B7F6362607F5150507F4242417F4141417F2B2B2B5403030306000000000000\r\n      0000000000000000000000000000000000000000000096822AF2F0D549FFEBCB\r\n      2CFFEBCB2CFFEBCB2CFFEBCB2CFFEBCD34FFEDD041FFEED349FFEED349FFEED3\r\n      49FFEED349FFEED349FFEED349FFEED349FFF2DA5EFF917E29EC000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      000000000000000000000000000000000006000000150000002C0000003F2E2D\r\n      2D8B5E5C5BD0827E7CFF817D7BFF817D7BFF817D7BFF817D7BFF827E7CFF5E5C\r\n      5BD02C2C2C880000004AB9813DFFFACD89FFF9CF8BFFB57E3FFF0000003D0000\r\n      001C0000000600000000000000000000000000000003000000060000000A0000\r\n      000E000000120000001501010116000000170101011801010118000000190000\r\n      0019000000190101011A0101011A0101011A0101011A0101011DC08825F2EBC1\r\n      6BFFF1CD7DFFF2D28CFFF2D493FFF3D596FFF3D596FFF3D596FFF3D596FFF2D4\r\n      94FFF2D28DFFF2CD7EFFEEC670FFC98E27FC0000000000000000000000000000\r\n      0000000000000D0D0D1A373737723E3E3E7F4C4B4A7F5E5C5A7F6563617F6967\r\n      657F6E6D6C7F7473737F7978787F7C7C7B7F7C7C7C7F7A79797F7676757F7170\r\n      6F7F6D6B6A7F6967667F615F5D7F4A4A497F3E3E3E7F33333369080808100000\r\n      0000000000000000000000000000000000000000000096822AF2F0D54BFFEBCB\r\n      2EFFEBCB2EFFEBCB2EFFEBCB2EFFEFD243FFF6E06EFFFAE784FFFAE784FFFAE7\r\n      84FFFAE784FFFAE784FFFAE784FFFAE784FFFBEA8CFF96822AF2000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      00000000000000000001000000070000001C00000039444241A884817EFF8F8C\r\n      8BFF9B9897FFA5A2A1FFA9A7A5FFA9A7A5FFA9A7A5FFA9A7A5FFA5A2A1FF9B98\r\n      97FF8D8C8EFF8D8072FFB9803AFFF3CB89FFEEBD71FFF6CD90FFB5803FFF0000\r\n      003D0000001C00000006000000000000000000000002C6C6C6FFC3C3C3FFC0C0\r\n      C0FFBDBDBDFFBBBBBBFFBABABAFFBABABAFFB9B9B9FFB9B9B9FFB8B8B8FFB8B8\r\n      B8FFB8B8B8FFB7B7B7FFB7B7B7FFB7B7B7FFB7B7B7FFB7B7B7FFCC9027FFE9A7\r\n      40FFE69C2AFFE69C29FFE29A28FFB37820FFB67B20FFD49026FFE69C29FFE69C\r\n      29FFE69C29FFE69C2AFFE8A63EFFD0942CFF0000000000000000000000000000\r\n      00000B0B0B1A3A3A3A7B3D3C3C7F504E4D7F5E5B597F62605E7F6C6A697F7978\r\n      787F7C7C7C7F7D7C7C7F7D7D7D7F7E7E7E7F7E7E7E7F7E7E7E7F7D7D7D7F7D7C\r\n      7C7F7A79797F6E6C6B7F6664637F62605E7F504E4D7F3D3D3D7F373737740707\r\n      070E000000000000000000000000000000000000000096822AF2F0D54CFFEBCC\r\n      30FFEBCC30FFEBCC30FFEBCC30FFF0D54CFF96822AF296822AF296822AF29682\r\n      2AF296822AF296822AF296822AF296822AF296822AF2584B188E000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      000000000000000000070000001F04040446787472ED8F8C8AFFA7A4A2FFB1AF\r\n      ADFFC6C4C2FFD1D0CEFFD8D7D5FFDAD9D7FFDAD9D7FFD8D7D5FFD1D0CEFFC6C4\r\n      C2FFB0B0B0FFAA9D8FFFB77D38FFF1C88AFFE8B569FFE9B66AFFF2CD93FFB580\r\n      3FFF0000003D0000001C000000060000000000000001C9C9C9FFFFFFFFFFFFFF\r\n      FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n      FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFCC9027FFE8A3\r\n      3CFFE69927FFE69927FFE8A035FFF9F6F0FFF3ECE1FFDAAE6BFFD48D24FFE699\r\n      27FFE69927FFE69927FFE8A23AFFD0932CFF0000000000000000000000000606\r\n      060C343434723B3B3B7F514E4B7F5A57557F605D5B7F6F6E6D7F7877777F7877\r\n      777F7776757F7776767F7978787F7C7B7B7F7F7F7E7F7C7B7B7F7A79797F7978\r\n      787F7A79797F7979787F706F6E7F63615F7F5F5C5A7F514F4D7F3B3B3B7F3030\r\n      3067030303050000000000000000000000000000000096822AF2EFD54EFFEACC\r\n      32FFEACC32FFEACC32FFEACC32FFEFD54EFF96822AF200000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000060000001C0F0F0F55888482FF9B9896FFAEACAAFFC7C6C4FFD6D5\r\n      D3FFEDEDECFFFBFBFAFFFFFFFFFFC2C2C2FFC2C2C2FFFFFFFFFFFBFBFAFFEDEE\r\n      EDFFD6D7D8FFC4B9A9FFB57B35FFEDC78EFFE2B064FFE2B165FFE4B265FFF1CE\r\n      99FFB6803FFF0000003D0000001C0000000600000000CACACAFFD5D5D5FFD2D2\r\n      D2FFD2D2D2FFD2D2D2FFD2D2D2FFD2D2D2FFD2D2D2FFD2D2D2FFD2D2D2FFD2D2\r\n      D2FFD2D2D2FFD2D2D2FFD2D2D2FFD2D2D2FFD2D2D2FFD2D2D2FFCC9027FFEBAF\r\n      48FFE9A634FFE9A634FFE9A634FFF6EBD6FFFEFFFFFFE3C99DFFF0C477FFE9A6\r\n      34FFE9A634FFE9A634FFEBAE45FFD0952DFF0000000000000000000000002A2A\r\n      2A5F3939397F4A48457F5652507F605D5A7F706F6E7F7C756C8B9B7C56B2A57D\r\n      4FBD847461977271717F7676757F7A79797F7B7B7B7F7A79797F7B767186997C\r\n      5BACA88051C08D78629E7675747F71706F7F625F5D7F5B58557F4A48467F3A3A\r\n      3A7F2424244F0000000000000000000000000000000096822AF2EFD54FFFEACC\r\n      34FFEACC34FFEACC34FFEACC34FFEFD54FFF96822AF200000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      00000000000000000000110F051C000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      00030000001505050541888583FF9F9B99FFB5B3B1FFC9C8C6FFECEBEAFFFFFF\r\n      FFFFFFFFFFFFFFFFFFFFFFFFFFFFBEBEBEFFBEBEBEFFFFFFFFFFFFFFFFFFFFFF\r\n      FFFFFFFFFFFFE2D6C8FFB37831FFEBC78FFFDEAB5DFFDEAC5FFFDEAC5FFFDFAC\r\n      5EFFEDC993FFB6813FFF000000370000001100000000CACACAFFFFFFFFFFF2F2\r\n      F2FFF3F3F3FFF5F5F5FFF5F5F5FFF6F6F6FFF6F6F6FFF6F6F6FFF6F6F6FFF6F6\r\n      F6FFF6F6F6FFF6F6F6FFF6F6F6FFDDDDDDFFF6F6F6FFF6F6F6FFCC9027FFEEB9\r\n      53FFECB140FFECB140FFE8AE3FFFDBBA79FFFEFFFFFFE5D7BAFFE1A93DFFECB1\r\n      40FFECB140FFECB140FFEEB850FFD0962EFF0000000000000000101010273737\r\n      377F413E3D7F514E4A7F5753517F6B69687F6D6B6981CD8532EED39041FCD799\r\n      4FFCD7872BFE837565947473727F7776757F7777767F7676757FC08644DAD288\r\n      36FCD79B54FDD5872DFD907657A86F6E6D7F6C6A697F5B58557F5653507F403E\r\n      3D7F3838387F0A0A0A1800000000000000000000000096822AF2EFD551FFEACC\r\n      36FFEACC36FFEACC36FFEACC36FFEFD551FF96822AF200000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000003A33105EA28E32F43A33105E0000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      000B0000002C7C7977EC9E9B99FFB5B3B1FFC9C8C6FFFBFBFAFFFFFFFFFFFFFF\r\n      FFFFFDFDFDFFFCFCFCFFFEFEFEFFFFFFFFFFFFFFFFFFFEFEFEFFFCFCFCFFFCFC\r\n      FDFFFEFFFFFFFFFFFFFFB1752EFFE9C794FFD9A557FFD9A75AFFD9A75BFFD9A6\r\n      59FFD9A657FFECCB98FFB88341FF0000001100000000CACACAFFFFFFFFFFF3F3\r\n      F3FFF5F5F5FFF6F6F6FFF7F7F7FFF7F7F7FFF8F8F8FFF8F8F8FFF8F8F8FFF8F8\r\n      F8FFF8F8F8FFF8F8F8FFF8F8F8FFD8D8D8FFF8F8F8FFF8F8F8FFCC9027FFF0C1\r\n      5CFFEEBA4AFFEEBA4AFFEFBF56FFF3E0B5FFF2EAD8FFFEFFFFFFE8C16BFFEEBA\r\n      4AFFEEBA4AFFEEBA4AFFEFC05AFFD0972FFF00000000000000012C2C2C6B3736\r\n      367F4B47447F514D4A7F605D5B7F6462607F80684BA5D28732FDEBCDA3FFEBCD\r\n      A3FFDAA15EFEAC7D4AC971706F7F7372717F7372727F7D75698ED37E23FFEACA\r\n      9EFFEBCDA3FFE1B176FFBF7E35E5615F5D7F6867657F615E5C7F55524F7F4E4A\r\n      487F3636367F2727275D00000000000000000000000096822AF2EFD552FFEACC\r\n      38FFEACC38FFEACC38FFEACC38FFEFD552FF96822AF200000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      000000000000786822C2E0C74FFCA59131F44C42157A00000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000020000\r\n      0017474544A193918FFFAFADABFFC1C0BEFFF9F9F8FFC1C1C1FFBFBFBFFFFFFF\r\n      FEFFFCFCFAFFFBFBFAFFFBFBFAFFFCFCFAFFFCFCFAFFFBFBFAFFFBFBFAFFFBFB\r\n      FAFFFDFDFDFFFFFFFFFFB0752DFFE8C799FFD4A050FFD5A254FFD5A254FFD5A1\r\n      52FFD5A04FFFEBCD9EFFB88341FF0000000600000000CACACAFFFFFFFFFFF5F5\r\n      F5FFE7E7E7FFE3E3E3FFE4E4E4FFE4E4E4FFE4E4E4FFE4E4E4FFE4E4E4FFE4E4\r\n      E4FFE4E4E4FFF8F8F8FFFAFAFAFFD8D8D8FFFAFAFAFFFAFAFAFFCC9027FFF1C5\r\n      60FFEFBF4FFFEFBF4FFFEFBF4FFFF2CC72FFFBF2DCFFFEFFFFFFF2CC72FFEFBF\r\n      4FFFEFBF4FFFEFBF4FFFF0C55EFFD09730FF000000000E0E0E243434347F403D\r\n      3B7F4C47447F54504E7F605E5C7F5855537F846546ABD38E42FDE7C495FFE7C4\r\n      95FFDDA96AFFAB7743CF6E6C6B7F6F6E6D7F6F6E6D7F7E6F6293D1822EFFE7C4\r\n      95FFE7C495FFE2B780FFBE782FEB5F5C5A7F5D5A587F6462607F5753517F504C\r\n      497F3D3C3A7F3535357F07070713000000000000000096822AF2EFD654FFEACD\r\n      3AFFEACD3AFFEACD3AFFEACD3AFFEFD654FF96822AF200000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      000000000000847325D6E6CD4EFDE6C93AFEA48F31F44A401578000000000000\r\n      0000000000000000000000000000000000000000000000000000000000080000\r\n      00268E8B89FFABA8A7FFB7B5B3FFE2E1E0FFFFFFFFFFBFBFBFFFBEBEBEFFFCFC\r\n      FDFFF9F9F9FFF9F9F9FFF9F9F9FFF9F9F9FFF9F9F9FFF9F9F9FFF9F9F9FFF9F9\r\n      F9FFFAFBFCFFFFFFFFFFB1752DFFE7C99DFFCF9A4AFFCF9C4EFFCF9B4DFFCF9A\r\n      4AFFEACEA4FFB7813EFF000000060000000000000000CACACAFFFFFFFFFFF6F6\r\n      F6FFF8F8F8FFF9F9F9FFFBFBFBFFFBFBFBFFFCFCFCFFFCFCFCFFFCFCFCFFFCFC\r\n      FCFFFCFCFCFFFCFCFCFFFCFCFCFFD9D9D9FFFCFCFCFFFCFCFCFFCC9027FFF1C7\r\n      63FFF0C152FFF0C152FFF0C152FFF0C152FFF0C152FFC69F43FFBA963FFFE8BB\r\n      4FFFF0C152FFF0C152FFF1C661FFD19730FF000000001E1E1E4D3232327F4844\r\n      417F4B47437F5855527F55514E7F55524F7F806044ABD18C42FDE4BC88FFE4BC\r\n      88FFDCA664FFA46E3FCF6A68677F6B69687F6B6A687F7A6A5F93CF8030FFE4BC\r\n      88FFE4BC88FFE0B176FFBB702EEB5D5A587F5A56547F5A57547F5B57557F4F4B\r\n      487F45423E7F3333337F1818183B000000000000000096822AF2EFD656FFEACD\r\n      3DFFEACD3DFFEACD3DFFEACD3DFFEFD656FF96822AF200000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      000000000000847325D6E6CC50FDEBCD36FFE4C83AFEA38F31F4483F15750000\r\n      0000000000000000000000000000000000000000000000000000000000103231\r\n      307C999694FFB2B0AEFFBBBAB7FFFFFFFFFFFBFBFBFFFCFCFCFFFBFBFBFFFAFA\r\n      FAFFF8F8F8FFF8F8F8FFF8F8F8FFF8F8F8FFF8F8F8FFF8F8F8FFF8F8F8FFF8F8\r\n      F8FFF9FAFBFFFEFFFFFFB1752CFFE6CCA3FFCA9444FFCB9547FFCB9544FFE7CA\r\n      9FFFBA8039FF00000013000000000000000000000000CACACAFFFFFFFFFFF9F9\r\n      F9FFE9E9E9FFE5E5E5FFE5E5E5FFE6E6E6FFE6E6E6FFE6E6E6FFE6E6E6FFE6E6\r\n      E6FFE6E6E6FFFCFCFCFFFEFEFEFFD9D9D9FFFEFEFEFFFEFEFEFFCC9027FFF1CA\r\n      66FFF0C455FFF0C455FFF0C455FFF0C455FFF0C455FFEFE6CEFFF9F8F2FFEBC7\r\n      69FFF0C455FFF0C455FFF1C964FFD19830FF000000002C2C2C743534337F4B47\r\n      437F4C48447F504C4A7F504C497F53504D7F7A5B41ABD08C44FDE1B37AFFE1B3\r\n      7AFFDBA35FFF9F663BCF6664627F6765637F6865647F76665993CD8033FFE1B3\r\n      7BFFE1B37AFFDEAB6DFFB4692DEB5B57557F5754517F54504E7F55524F7F4D49\r\n      467F4B46437F3333337F26262662000000000000000096822AF2EFD659FFEACD\r\n      40FFEACD3FFFEACD3FFFEACD3FFFEFD657FF96822AF200000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      000000000000847325D6E4CB4BFDEACD38FFEACC37FFE3C73CFEA28E31F4483F\r\n      1575000000000000000000000000000000000000000000000000000000156B68\r\n      67CBA4A2A0FFB1AFADFFDBDAD9FFFBFCFAFFF8F8F7FFF8F8F6FFF7F8F6FFF7F7\r\n      F6FFF7F7F6FFF7F7F6FFF7F7F6FFF7F7F6FFF7F7F6FFF7F7F6FFF7F7F6FFF7F7\r\n      F6FFF8F9F9FFFDFFFFFFB1752CFFE5CDA8FFC48D3AFFC58E3BFFE7CEA6FFBB7E\r\n      35FF606369C500000015000000000000000000000000CACACAFFFFFFFFFFFAFA\r\n      FAFFFBFBFBFFFDFDFDFFFEFEFEFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n      FFFFFFFFFFFFFFFFFFFFFFFFFFFFDADADAFFFFFFFFFFFFFFFFFFCC9027FFF2CC\r\n      67FFF1C657FFF1C657FFF1C657FFF1C657FFF1C657FFFBF0D2FFFDFBF4FFF3CE\r\n      6DFFF1C657FFF1C657FFF2CB65FFD19831FF0404040C2F2F2F7F3B39377F4B47\r\n      437F4C47447F4C47447F4E4A467F514D4A7F76543DABD18F4BFDDEAB6CFFDEAB\r\n      6CFFDAA05AFF985E37CF63615F7F6462607F6562617F71615493CC8038FFDFAD\r\n      6FFFDEAB6CFFDCA563FFB0642CEB5855527F55514E7F524E4B7F504B487F4C47\r\n      447F4B47437F3837367F2E2E2E78000000000000000096822AF2EFD75FFFE9CE\r\n      45FFE9CD43FFE9CD42FFE9CD42FFEFD65AFF96822AF200000000000000000000\r\n      00004F4517808D7A28E496822AF296822AF296822AF296822AF296822AF29682\r\n      2AF296822AF296822AF2E1C640FDEACD3BFFEACD3AFFEACD3BFFE3C840FEA28E\r\n      30F4473D1472000000000000000000000000000000000000000000000016928F\r\n      8DFFAFADABFFA9A7A4FFEEEDEDFFF9F8F8FFF7F5F5FFF6F5F5FFF6F5F5FFF6F5\r\n      F5FFF6F5F5FFF6F5F5FFF7F6F5FFF8F7F6FFF9F7F7FFF8F7F7FFF7F5F5FFF6F5\r\n      F5FFF7F7F8FFFCFFFFFFB1752BFFE6CFAEFFBE842EFFE8D1AEFFB97C32FFACB0\r\n      B6FF919091FF00000016000000000000000000000000CACACAFFFFFFFFFFFAFA\r\n      FAFFEAEAEAFFE5E5E5FFE6E6E6FFE7E7E7FFE7E7E7FFE7E7E7FFE7E7E7FFE7E7\r\n      E7FFE7E7E7FFFDFDFDFFFFFFFFFFDADADAFFFFFFFFFFFFFFFFFFCC9027FFF5D4\r\n      7EFFF1C85AFFF1C859FFF1C859FFF1C859FFF1C859FFF1C859FFF1C859FFF1C8\r\n      59FFF1C859FFF1C85AFFF3D37AFFD19A38FF080808192D2D2D7F3D3B397F4B47\r\n      437F4B47437F4B47437F4B47447F504B487F74503DABD19251FDDBA35FFFDBA3\r\n      5FFFD99C54FF935736CF63615F7F6461607F6462607F6F5F5493CA803EFFDCA6\r\n      65FFDBA35FFFDAA05AFFA95C2CEB5854517F524E4B7F4F4B487F4C48457F4B47\r\n      437F4B47437F3938367F2E2E2E7F010101050000000096822AF2F0D962FFEAD0\r\n      4BFFEACF48FFE9CF47FFE9CE45FFEFD75BFF96822AF200000000000000000000\r\n      00008D7A28E4EAD257FEEACE41FFEACD3FFFEACD3FFFEACD3FFFEACD3FFFEACD\r\n      3FFFEACD3FFFEACD3FFFEACD3FFFEACD3FFFEACD3FFFEACD3FFFEACD40FFE1C6\r\n      44FDA18D30F4433A126C00000000000000000000000000000000000000169491\r\n      8FFFB5B2B0FFA19F9DFFFFFFFFFFF9F9F9FFF5F6F6FFF4F4F4FFF4F4F4FFF4F4\r\n      F4FFF4F4F4FFF7F6F4FFFCFBF4FFFFFFF8FFFFFFFEFFFFFFFEFFF8F8F9FFF5F5\r\n      F5FFF5F6F7FFF9FEFFFFB1742BFFE6D2B2FFE7D1B0FFB6782DFFA2A6ABFFB5B4\r\n      B4FF93908EFF00000016000000000000000000000000CACACAFFFFFFFFFFFAFA\r\n      FAFFFBFBFBFFFDFDFDFFFEFEFEFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n      FFFFFFFFFFFFFFFFFFFFFFFFFFFFDADADAFFFFFFFFFFFFFFFFFFD09836FFEFDA\r\n      AEFFFCF4DDFFFCF3DDFFFCF3DDFFFCF3DDFFFCF3DDFFFCF3DDFFFCF3DDFFFCF3\r\n      DDFFFCF3DDFFFCF4DDFFF2E0B9FFC98E27FC0D0D0D262C2C2C7F403C3A7F4B47\r\n      437F4B47437F4E49467F524F4B7F55514E7F724F3DABD29458FDD89A52FFD89A\r\n      52FFD89850FF8E5032CF625F5D7F63605E7F63605F7F6E5D5493C87E43FFDA9F\r\n      5BFFD89A52FFD89951FFA5572BEB5D5A577F5A57557F54504D7F4D49457F4B47\r\n      437F4B47437F3B39377F2D2D2D7F050505120000000096822AF2F0DA67FFEAD0\r\n      50FFEAD04FFFEAD04DFFEACF4BFFEFD860FF96822AF200000000000000000000\r\n      00008D7A28E4EAD35AFEE9CF44FFE9CE43FFE9CE43FFE9CE43FFE9CE43FFE9CE\r\n      43FFE9CE43FFE9CE43FFE9CE43FFE9CE43FFE9CE43FFE9CE43FFE9CE43FFE9CE\r\n      44FFE0C74CFD9F8C33F33A33105E000000000000000000000000000000169592\r\n      90FFBAB8B6FF9C9A98FFC8C8C8FFC0C1C1FFF6F6F5FFF3F4F2FFF3F3F2FFF3F3\r\n      F2FFF6F6F2FFFEFCF1FFCCD3F7FF1845FFFF27251DFF7A7978FFFFFFFFFFF8F8\r\n      F7FFF5F6F5FFF8FDFFFFB1742AFFE8D5B8FFB17227FFFFFFFFFF9B9B9BFFB9B8\r\n      B7FF9A9795FF00000016000000000000000000000000CACACAFFFFFFFFFFFAFA\r\n      FAFFEAEAEAFFE5E5E5FFE6E6E6FFE7E7E7FFE7E7E7FFE7E7E7FFE7E7E7FFE7E7\r\n      E7FFE7E7E7FFFDFDFDFFFFFFFFFFDADADAFFFFFFFFFFFFFFFFFFE3CFAEFFD09E\r\n      46FFCC9027FFCC9027FFCC9027FFCC9027FFCC9027FFCC9027FFCC9027FFCC90\r\n      27FFCC9027FFCC9027FFCC983EFF4D360F600B0B0B242A2A2A7F3E3C397F4C48\r\n      447F534F4C7F5754517F5754517F5754517F714C3CABD6A06AFDDEAA6CFFDA9F\r\n      5BFFD6954AFF894A2FCF615F5D7F625F5E7F62605E7F6B5B5293C67E46FFD899\r\n      50FFD59244FFD69447FF9F512BEB5D5A587F5C59567F5B58567F5B58557F5450\r\n      4D7F4C47447F3A38367F2B2B2B7F060606100000000096822AF2F0DA6DFFEBD2\r\n      56FFEAD154FFEAD052FFEAD050FFF0D864FF96822AF200000000000000000000\r\n      00008D7A28E4EAD35EFEE9CF49FFE9CE48FFE9CE48FFE9CE48FFE9CE48FFE9CE\r\n      48FFE9CE48FFE9CE48FFE9CE48FFE9CE48FFE9CE48FFE9CE48FFE9CE48FFEAD0\r\n      4EFFEFD862FFE3D070FC786822C2000000000000000000000000000000169794\r\n      92FFC3C1BFFF969391FFC8C8C8FFC1C1C1FFF5F4F4FFF2F1F1FFF2F1F1FFF5F3\r\n      F1FFFDFAF0FFCDD3F4FF0021FFFFD3DBFCFF807D77FF292929FF898989FFFFFE\r\n      FFFFF6F6F6FFF6F9FDFFBD8B4DFFB07023FFF9FEFFFFFDFEFFFF93918FFFC2C0\r\n      BEFF9F9C9AFF00000016000000000000000000000000CACACAFFFFFFFFFFFAFA\r\n      FAFFFBFBFBFFFDFDFDFFFEFEFEFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n      FFFFFFFFFFFFFFFFFFFFFFFFFFFFDADADAFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n      FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFEFEFEFFFDFDFDFFFBFB\r\n      FBFFFAFAFAFFFFFFFFFFCACACAFF00000000070707172828287F3B38367F5753\r\n      517F5E5B597F5A57547F5A57557F5B57557F704A3DABDAAA7DFEE6BF93FFE6BF\r\n      93FFDFAD73FF84432CCF615E5C7F625F5D7F625F5D7F6A585293C5804BFFD693\r\n      47FFD28A37FFD48E3EFF9C4B28EB5E5B597F5E5B597F5E5B597F5E5C597F5F5C\r\n      5A7F514D4A7F3735337F2A2A2A7F000000030000000096822AF2F1DB72FFEBD3\r\n      5DFFEBD25BFFEBD159FFEAD156FFF0D968FF96822AF200000000000000000000\r\n      00008D7A28E4EDD86FFEEFD763FFEFD762FFEFD762FFEFD762FFEFD762FFEFD7\r\n      62FFEFD762FFEDD55DFFEBD154FFE9CE4EFFE9CE4DFFE9CE4DFFEBD053FFEFD8\r\n      65FFF1DE7CFEAD9A42F53A33105E000000000000000000000000000000159894\r\n      92FFCECDCAFF8D8B89FFFEFDFDFFF6F5F5FFF3F1F2FFF1F0F0FFF3F2F0FFFAF7\r\n      F0FFC9D0F3FF0020FFFFCBD3F2FFFFFDF4FFFFFFFFFF979797FF262626FFB1B0\r\n      B0FFFCFBFBFFF5F5F7FFF5F7FBFFF5F7FCFFF5F5F8FFFBFAFBFF8C8A88FFCECC\r\n      CAFF979492FF00000015000000000000000000000000CACACAFFFFFFFFFFFAFA\r\n      FAFFEAEAEAFFE5E5E5FFE6E6E6FFE7E7E7FFE7E7E7FFE7E7E7FFE7E7E7FFE7E7\r\n      E7FFE7E7E7FFFDFDFDFFFFFFFFFFDADADAFFFFFFFFFFFFFFFFFFEDEDEDFFE7E7\r\n      E7FFE7E7E7FFE7E7E7FFE7E7E7FFE7E7E7FFE7E7E7FFE6E6E6FFE5E5E5FFEAEA\r\n      EAFFFAFAFAFFFFFFFFFFCACACAFF000000000303030A2727277F3634327F5652\r\n      507F6967657F6461607F5F5C5A7F5E5B597F6F483DABDCB089FEEAC8A3FFEAC8\r\n      A3FFE5BA8AFF7E3C2ACF615F5D7F625F5E7F62605E7F69575193C7875AFFDFAB\r\n      70FFD38C3DFFD18835FF954528EB615E5C7F615E5C7F615F5D7F615F5D7F625F\r\n      5D7F504B487F3231307F25252576000000000000000096822AF2F1DD78FFECD5\r\n      63FFEBD461FFEBD45FFFEBD35CFFF0DB6DFF96822AF200000000000000000000\r\n      00008D7A28E4F5E58CFEF9E98DFFF9E88DFFF9E88DFFF9E88DFFF9E88DFFF9E8\r\n      8DFFF9E88DFFF5E380FFEDD763FFE9D053FFE8CF52FFEAD257FFEFD969FFF0DE\r\n      7DFEAB9840F54F45178000000000000000000000000000000000000000109895\r\n      93FFD1CECDFF8D8B89FFE3E2E2FFF3F3F2FFF0F0EEFFF1F1EEFFF5F4EDFFEBEC\r\n      EEFF385CFBFFC7CFF1FFFAF8EDFFF3F2EFFFF4F4F2FFFCFCFBFFB0AFAFFF2121\r\n      21FFC9C8C8FFF8F8F7FFF2F2F2FFF0F1F0FFF2F3F2FFE3E2E1FF8D8B89FFD1CD\r\n      CDFF989593FF00000010000000000000000000000000CACACAFFFFFFFFFFF9F9\r\n      F9FFFBFBFBFFFDFDFDFFFEFEFEFFFEFEFEFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n      FFFFFFFFFFFFFFFFFFFFFFFFFFFFDADADAFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n      FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFEFEFEFFFEFEFEFFFDFDFDFFFBFB\r\n      FBFFF9F9F9FFFFFFFFFFCACACAFF00000000000000002121216F2B2A2A7F524E\r\n      4B7F6D6B6A7F6B6A687F6A69677F6765647F714940ABDFB692FEEED3B5FFEED3\r\n      B5FFE8C296FF7B3629CF62605E7F62605E7F63615F7F69565193C88C64FFECCE\r\n      ABFFEAC7A0FFDDA769FF933F28EB6462607F6462607F6562607F6562617F6562\r\n      617F4C48447F2828287F1C1C1C5C000000000000000096822AF2F1DE7DFFEBD6\r\n      69FFEBD567FFEBD465FFEAD463FFF0DC73FF96822AF200000000000000000000\r\n      00004F4517808D7A28E496822AF296822AF296822AF296822AF296822AF29682\r\n      2AF296822AF296822AF2E4CF65FDE9D059FFEAD25CFFEFDA6DFFEFDD7FFEA996\r\n      3EF44D43157D000000000000000000000000000000000000000000000008716F\r\n      6DC4C7C5C4FF9D9B99FFC3C2C1FFF4F4F3FFF0F0EEFFF3F3EDFFE8E9EEFF345A\r\n      FBFFEAEBEDFFF7F5EDFFF1F0EDFFEEEFEDFFEFEFEEFFF1F1F0FFF8F9F8FFD7D6\r\n      D5FF393A3AFFD4D2D1FFF4F4F3FFF0F0EFFFF4F4F3FFC3C2C1FF9D9B99FFC7C5\r\n      C4FF716F6DC400000008000000000000000000000000CACACAFFFFFFFFFFF9F9\r\n      F9FFEAEAEAFFE5E5E5FFE5E5E5FFE6E6E6FFE6E6E6FFE6E6E6FFE6E6E6FFE6E6\r\n      E6FFE6E6E6FFFCFCFCFFFEFEFEFFD9D9D9FFFEFEFEFFFEFEFEFFECECECFFE6E6\r\n      E6FFE6E6E6FFE6E6E6FFE6E6E6FFE6E6E6FFE6E6E6FFE5E5E5FFE5E5E5FFEAEA\r\n      EAFFF9F9F9FFFFFFFFFFCACACAFF0000000000000000141414472424247F4541\r\n      3D7F6D6B6A7F6F6E6D7F6E6D6C7F6D6C6A7F724943ABE0BC9CFEF3E0CBFFF3E0\r\n      CBFFEAC8A2FF773227CF6663627F6664627F6664627F69565493CA8F6DFFF2DC\r\n      C5FFF0D7BCFFECCDAAFF8D3A2AEB6765647F6866647F6866647F6866647F615E\r\n      5C7F403C3A7F2525257F0F0F0F35000000000000000096822AF2F1DF83FFECD7\r\n      70FFECD66DFFEBD66BFFEBD568FFF0DC77FF96822AF200000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      000000000000847325D6E4CF68FDEBD462FFEFDB71FFEDDC80FEA5933DF44C42\r\n      157A000000000000000000000000000000000000000000000000000000023836\r\n      3669B2AFAEFFCAC8C7FF868483FFF7F6F5FFF2F1EEFFF6F4EDFF3258FEFFE7E8\r\n      ECFFF4F2EBFFEFEEEBFFEDECEBFFEDECEBFFEDECEBFFEDECEBFFF0EEEDFFF5F4\r\n      F3FFD2D2D1FF616161FFEBEBEAFFF4F3F2FFF7F6F5FF868483FFCAC8C7FFB2AF\r\n      AEFF3836366900000002000000000000000000000000CACACAFFFFFFFFFFF8F8\r\n      F8FFFAFAFAFFFBFBFBFFFCFCFCFFFDFDFDFFFDFDFDFFFDFDFDFFFDFDFDFFFDFD\r\n      FDFFFDFDFDFFFDFDFDFFFDFDFDFFD9D9D9FFFDFDFDFFFDFDFDFFFDFDFDFFFDFD\r\n      FDFFFDFDFDFFFDFDFDFFFDFDFDFFFDFDFDFFFDFDFDFFFCFCFCFFFBFBFBFFFAFA\r\n      FAFFF8F8F8FFFFFFFFFFCACACAFF00000000000000000707071E2222227F3432\r\n      307F6462607F7372717F7270707F71706E7F724947ABE2C1A5FEF9EEE3FFF9EE\r\n      E3FFEDD0B0FF732B26CF6967657F6967657F6967667F6B595493CA9373FFF8ED\r\n      E1FFF7EADBFFF1DAC1FF893528EB6A69677F6B69677F6B69687F6B69687F5955\r\n      537F2F2E2D7F2323237F0303030E000000000000000096822AF2F2E08AFFEDD8\r\n      77FFECD874FFECD772FFECD670FFF0DD7DFF96822AF200000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      000000000000847325D6E6D26FFDF0DC76FFECDA81FDA38F39F4483F15750000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      000D9D9A98FFDCDAD9FF8B8987FFBBBAB9FFF6F5F3FFC6C5C2FFC8C6C1FFF4F1\r\n      ECFFEEEDEAFFECEBEAFFECEBEAFFECEBEAFFECEBEAFFECEBEAFFECEBEAFFEEED\r\n      ECFFF4F3F2FFC0C0C0FF5B5B5BFFF9F8F7FFBBBAB9FF8B8987FFDCDAD9FF9D9A\r\n      98FF0000000B00000000000000000000000000000000CACACAFFFFFFFFFFF7F7\r\n      F7FFE8E8E8FFE4E4E4FFE5E5E5FFE5E5E5FFE5E5E5FFE5E5E5FFE5E5E5FFE5E5\r\n      E5FFE5E5E5FFFAFAFAFFFCFCFCFFD9D9D9FFFCFCFCFFFCFCFCFFEBEBEBFFE5E5\r\n      E5FFE5E5E5FFE5E5E5FFE5E5E5FFE5E5E5FFE5E5E5FFE5E5E5FFE4E4E4FFE8E8\r\n      E8FFF7F7F7FFFFFFFFFFCACACAFF0000000000000000000000001A1A1A642221\r\n      217F4A47447F7372717F7574737F7473727F734E4DA7DAB499FEFFFFFFFFFFFF\r\n      FFFFEDD0AFFF6F2A29CB6C6A697F6C6A697F6C6B697F6C5D5C8FBB7B63FFFEFC\r\n      FBFFFFFFFFFFF2DEC6FF7F2C27E66E6C6B7F6E6C6B7F6E6D6B7F6765637F4340\r\n      3C7F2222227F1616165400000000000000000000000096822AF2F2E18EFFEDDB\r\n      7DFFEDDA7BFFECD978FFECD875FFF1DE83FF96822AF200000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      000000000000847325D6EAD97FFDEBDA82FDA28E36F4473D1472000000000000\r\n      0000000000000000000000000000000000000000000000000006000000110000\r\n      001C4E4C4C93B2B0AEFFDDDBDAFF757572FFDDDCDBFFC8C8C8FFC4C4C3FFEDED\r\n      ECFFEAEBE9FFEAEAE9FFEAEAE9FFEAEAE9FFEAEAE9FFEAEAE9FFEAEAE9FFEAEB\r\n      EAFFEEEEEDFFC6C6C6FFCBCBCBFFDFDEDDFF767573FFDDDBDAFFB1AFADFF5250\r\n      4F8C0000000300000000000000000000000000000000CACACAFFFFFFFFFFF6F6\r\n      F6FFF7F7F7FFF8F8F8FFF9F9F9FFFAFAFAFFFAFAFAFFFAFAFAFFFAFAFAFFFAFA\r\n      FAFFFAFAFAFFFAFAFAFFFAFAFAFFD8D8D8FFFAFAFAFFFAFAFAFFFAFAFAFFFAFA\r\n      FAFFFAFAFAFFFAFAFAFFFAFAFAFFFAFAFAFFFAFAFAFFF9F9F9FFF8F8F8FFF7F7\r\n      F7FFF6F6F6FFFFFFFFFFCACACAFF0000000000000000000000000707071F1F1F\r\n      1F7F2E2C2B7F5D59577F7777767F7776767F757372828A362DF1EBD3BBFEECD2\r\n      B5FEB06852FD6E5858976F6E6C7F6F6E6D7F6F6E6D7F706E6D7F7E302BDFE4C5\r\n      AAFDEFD8BFFFC18769FD714646AC71706F7F71706F7F706F6E7F514D4A7F2928\r\n      287F2020207D0303031100000000000000000000000096822AF2F3E395FFEEDC\r\n      85FFEEDB82FFEDDA7EFFEDDA7BFFF1DF89FF96822AF200000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000006D5F1FB1E0CF7BFBA08D36F3453C136F00000000000000000000\r\n      000000000000000000000000000000000000000000060000001C000000350000\r\n      003C313130869D9A98FED0CECDFFC7C5C4FF676564FFDBDAD9FFF3F2F0FFEDEC\r\n      EBFFEAE9E8FFE9E8E7FFEAE9E8FFEBEAE9FFEBEAE9FFEAE9E8FFE9E8E7FFEAE9\r\n      E8FFEDECEBFFF3F2F1FFDCDBDAFF676564FFC7C5C4FFCFCDCCFF908D8AE70000\r\n      00060000000000000000000000000000000000000000CACACAFFFFFFFFFFFFFF\r\n      FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n      FFFFFFFFFFFFFFFFFFFFFFFFFFFFDADADAFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n      FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n      FFFFFFFFFFFFFFFFFFFFCACACAFF000000000000000000000000000000001515\r\n      15541F1F1F7F3735337F6D6C6A7F7979787F7676757F72626290713B3ABA7232\r\n      30C57055549E7271707F7271707F7271707F7372717F7372717F7368688A7242\r\n      42B472302FC8724E4EA6737271807473727F7473727F5E5B587F32302E7F1F1F\r\n      1F7F111111440000000000000000000000000000000096822AF2F3E49AFFEEDD\r\n      8BFFEEDD88FFEEDC86FFEDDB83FFF2E18EFF96822AF200000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      00000000000030290D4D9B8730F330290D4D0000000000000000000000000000\r\n      000000000000000000000000000000000000000000110000003785817EFF8682\r\n      80FF625F5EC46B6967C7A29F9DFFD9D7D6FFCBC9C9FF696766FFAFADACFFF3F2\r\n      F1FFEFEEEDFFEDECEBFFEDECEBFFC4C4C4FFC4C4C4FFEDECEBFFEDECEBFFEFEE\r\n      EDFFF3F2F1FFB0ADACFF5F5E5DFFCBC9C9FFD9D7D7FFA19D9BFF050505110000\r\n      00000000000000000000000000000000000000000000BCBCBCFFBCBCBCFFBCBC\r\n      BCFFBCBCBCFFBCBCBCFFBCBCBCFFBCBCBCFFBCBCBCFFBCBCBCFFBCBCBCFFBCBC\r\n      BCFFBCBCBCFFBCBCBCFFBCBCBCFFBCBCBCFFBCBCBCFFBCBCBCFFBCBCBCFFBCBC\r\n      BCFFBCBCBCFFBCBCBCFFBCBCBCFFBCBCBCFFBCBCBCFFBCBCBCFFBCBCBCFFBCBC\r\n      BCFFBCBCBCFFBCBCBCFFBEBEBEFF000000000000000000000000000000000101\r\n      01061B1B1B692020207F413D3B7F6B69687F7473727F7473737F7474737F7574\r\n      737F7574737F7574737F7574747F7575747F7675747F7675747F7675757F7676\r\n      757F7676757F7776757F7776767F7776767F6967667F3836347F1F1F1F7F1717\r\n      175C000000010000000000000000000000000000000096822AF2F4E5A0FFEFDF\r\n      91FFEFDE8FFFEEDD8CFFEEDC89FFF2E293FF96822AF200000001000000010000\r\n      0001000000010000000100000001000000010000000100000000000000000000\r\n      000000000000000000000706010B000000000000000000000000000000000000\r\n      000000000000000000000000000000000000000000118A8785FFCFCDCCF85B5A\r\n      58C1656563C1686766BF767472CBA29F9DFFD7D5D4FFECECEBFF7C7978FF625F\r\n      5EFFAAAAA9FFD4D3D2FFF5F4F3FFCDCDCEFFCDCDCEFFF5F4F3FFD4D3D2FFAAAA\r\n      A8FF615F5EFF7C7978FFECEDECFFD7D5D4FFA39F9DFF13131324000000010000\r\n      00000000000000000000000000000000000000000000BCBCBCFFE8E8E8FFDEDE\r\n      DEFFDEDEDEFFDEDEDEFFDEDEDEFFDEDEDEFFDEDEDEFFDEDEDEFFDEDEDEFFDEDE\r\n      DEFFDEDEDEFFDEDEDEFFDEDEDEFFDEDEDEFFDEDEDEFFDEDEDEFFDEDEDEFFDEDE\r\n      DEFFDEDEDEFFDEDEDEFFDEDEDEFFDEDEDEFFDEDEDEFFDEDEDEFFDEDEDEFFDEDE\r\n      DEFFDFDFDFFFE5E5E5FFAAAAAAE7000000000000000000000000000000000000\r\n      0000040404101D1D1D741F1F1F7F3735337F5F5C5A7F7675747F7877777F7877\r\n      777F7877777F7878777F7978777F7978787F7978787F7979787F7979787F7A79\r\n      797F7A79797F7A79797F7776757F5C59567F32302E7F1F1F1F7F1B1B1B690101\r\n      0107000000000000000000000000000000000000000096822AF2F4E6A5FFEFE0\r\n      98FFEFDF95FFEEDF92FFEEDE8FFFF1E196FF96822AF202020030020200300202\r\n      003002020030020200300202003002020030020201250000000B000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      00000000000000000000000000000000000000000006918E8CFFD7D5D4F75D5C\r\n      5BC1686766C36E6C6BC2706F6DC17B7A78C7A4A19FFDBBB9B7FFFAF9FAFFD8D7\r\n      D7FF918F8FFF5F5D5CFF474443FF484544FF484544FF474443FF5F5D5CFF918E\r\n      8FFFE3E3E3FFFAF9F9FFBBBAB7FF93908FE60706061000000000000000000000\r\n      00000000000000000000000000000000000000000000ADADADEAEDEDEDFFE3E3\r\n      E3FFE0E0E0FFE0E0E0FFE0E0E0FFE0E0E0FFE0E0E0FFE0E0E0FFE0E0E0FFE0E0\r\n      E0FFE0E0E0FFE0E0E0FFE0E0E0FFE0E0E0FFE0E0E0FFE0E0E0FFE0E0E0FFE0E0\r\n      E0FFE0E0E0FFE0E0E0FFE0E0E0FFE0E0E0FFE0E0E0FFE0E0E0FFE0E0E0FFE0E0\r\n      E0FFE5E5E5FFEAEAEAFF9F9F9FD8000000000000000000000000000000000000\r\n      0000000000000303030E1A1A1A671F1F1F7F2C2B2A7F4C49467F6F6E6D7F7B7B\r\n      7A7F7B7B7B7F7B7B7B7F7C7B7B7F7C7B7B7F7C7C7B7F7C7C7C7F7C7C7C7F7D7C\r\n      7C7F7D7D7C7F6C6B6A7F4744417F2928277F1F1F1F7F1717175C010101070000\r\n      0000000000000000000000000000000000000000000096822AF2F4E8AAFFF0E2\r\n      9EFFF0E29BFFEFE198FFEFE096FFF0E196FF97832CF297832CF297832CF29783\r\n      2CF297832CF297832CF297832CF297832CF297832BF2584B189C000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      000000000000000000000000000000000000000000000000000694918FFFE2E2\r\n      E0F8696766C26E6D6CC2E2E1E0F77E7D7CC2494747714F4E4D81A5A2A0FFC5C2\r\n      C1FFE4E3E2FFFEFFFEFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFEFFFEFFE4E3\r\n      E2FFC5C1C0FFA5A2A0FF55545387000000030000000000000000000000000000\r\n      0000000000000000000000000000000000000000000064646487D7D7D7FFF3F3\r\n      F3FFF8F8F8FFF8F8F8FFF8F8F8FFF8F8F8FFF8F8F8FFF8F8F8FFF8F8F8FFF8F8\r\n      F8FFF8F8F8FFF8F8F8FFF8F8F8FFF8F8F8FFF8F8F8FFF8F8F8FFF8F8F8FFF8F8\r\n      F8FFF8F8F8FFF8F8F8FFF8F8F8FFF8F8F8FFF8F8F8FFF8F8F8FFF8F8F8FFF8F8\r\n      F8FFF1F1F1FFD7D7D7FF55555575000000000000000000000000000000000000\r\n      00000000000000000000010101051414144F1F1F1F7F2020207F302F2D7F4F4C\r\n      4A7F615E5C7F6B6A687F7574747F7E7E7E7F7E7D7D7F7474737F6A68677F5F5D\r\n      5B7F4A48467F2D2B2A7F1F1F1F7F1F1F1F7D1111114400000001000000000000\r\n      0000000000000000000000000000000000000000000096822AF2F5E9AFFFF1E4\r\n      A4FFF0E3A1FFF0E29FFFF0E19CFFEFE19AFFEFE097FFEFE095FFEFDF93FFEEDE\r\n      90FFEEDD8EFFEEDD8BFFEDDC89FFEDDB87FFF0E190FF96822AF2000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000069A96\r\n      94FFEAE9E8F76F6D6CC0E4E3E2F495928FFF0000001200000000000000023B3A\r\n      3A5F7A7876BEA6A3A1FFA7A4A1FFA7A3A1FFA7A3A1FFA7A4A1FFA6A3A1FF7A78\r\n      76BE3B3A3A5F0000000200000000000000000000000000000000000000000000\r\n      000000000000000000000000000000000000000000000404040660606084A8A8\r\n      A8E4BCBCBCFFBCBCBCFFBCBCBCFFBCBCBCFFBCBCBCFFBCBCBCFFBCBCBCFFBCBC\r\n      BCFFBCBCBCFFBCBCBCFFBCBCBCFFBCBCBCFFBCBCBCFFBCBCBCFFBCBCBCFFBCBC\r\n      BCFFBCBCBCFFBCBCBCFFBCBCBCFFBCBCBCFFBCBCBCFFBCBCBCFFBCBCBCFFBCBC\r\n      BCFFA3A3A3DE5F5F5F8102020203000000000000000000000000000000000000\r\n      000000000000000000000000000000000000060606181616165D1F1F1F7F1F1F\r\n      1F7F2222227F2C2B2A7F302F2D7F3634327F3533317F302E2D7F2B2A297F2221\r\n      217F1F1F1F7F1F1F1F7F15151554030303110000000000000000000000000000\r\n      0000000000000000000000000000000000000000000096822AF2F8EEBBFFF5EA\r\n      B2FFF5E9AFFFF4E8ADFFF4E8ABFFF2E6A6FFEFE2A1FEEFE29FFEEFE19CFEEEE0\r\n      9AFEEEDF98FEEEDF96FEEDDE93FEEDDD91FEF1E196FE8F7C28E8000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      00069F9C9AFFEFF0EFF6EFEFEFF49F9C9AFF0000000800000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000040404130E0E\r\n      0E3B181818621E1E1E781F1F1F7F1F1F1F7F1F1F1F7F1F1F1F7F1D1D1D761717\r\n      175C0D0D0D350303030E00000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000096822AF2FCF5CAFFFCF4\r\n      C6FFFCF3C4FFFCF3C2FFFCF2C0FFFBF2BEFFFBF2BCFFFBF1BAFFFBF1B8FFFBF0\r\n      B6FFFBF0B5FFFBF0B2FFFBEFB1FFFBEFAFFFFBF0B0FF96822AF2000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      000000000006A6A3A1FFA5A2A0FF2322223B0000000100000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000001010105040404120404041000000003000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      00000000000000000000000000000000000000000000584B188E96822AF29682\r\n      2AF296822AF296822AF296822AF296822AF296822AF296822AF296822AF29682\r\n      2AF296822AF296822AF296822AF296822AF296822AF2584B188E000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      000000000000000000000000000000000000000000000000000000060809000F\r\n      1517000F1517000F1517000F1517000F1517000F1517000F1517000F1517000F\r\n      1517000F1517000F1517000F1517000F1517000F1517000F1517000F1517000F\r\n      1517000F1517000F1517000F1517000F1517000F1517000F151700090D0E0000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      00000000000000000000000000000000000000000000000000070000000E0000\r\n      00160000001F0202022F10101050585858DA797979E9787878E6767676E07777\r\n      77DE777777DD797979DC777777DA767676DA747474D9737373D9707070D96F6F\r\n      6FD96E6E6ED96D6D6DD94E4E4EC0000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      00000000000000000000000000000000000000000001000000060000000F0000\r\n      001500000016000000150000000F000000060000000100000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0020000000400000004000000040000000400000004000000040000000400000\r\n      0040000000400000004000000040000000400000004000000040000000400000\r\n      0036000000010000000000000000000000000000000000000000000000000000\r\n      00000000000000000000000000000000000000000000085C7D8C0DA8E1FB0DAB\r\n      E5FF0DABE5FF0DABE5FF0DABE5FF0DABE5FF0DABE5FF0DABE5FF0DABE5FF0DAB\r\n      E5FF0DABE5FF0DABE5FF0DABE5FF0DABE5FF0DABE5FF0DABE5FF0DABE5FF0DAB\r\n      E5FF0DABE5FF0DABE5FF0DABE5FF0DABE5FF0DABE5FF0DABE5FF0DA9E3FD0757\r\n      7582000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000019000000250000\r\n      003200000040949494EACCCCCCFEC6C6C6FFD4D4D4FFD9D9D9FFDEDEDEFFE3E3\r\n      E3FFE7E7E7FFECECECFFEAEAEAFFE5E5E5FFDFDFDFFFDADADAFFD5D5D5FFD0D0\r\n      D0FFCBCBCBFFC6C6C6FFBBBBBBFF000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      000000000000000000000000000000000000000000070000001D000000350000\r\n      00410000004300000040000000330000001C0000000700000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0040FDFDFDFFFBFBFAFFFBFBFBFFFCFCFCFFFCFCFCFFFDFDFDFFFDFDFDFFFDFD\r\n      FDFFFDFDFDFFFEFEFEFFFEFEFEFFFEFEFEFFFEFEFEFFFCFCFBFFF4F2F0FFD1CD\r\n      C7F331312F830000000100000000000000000000000000000000000000000000\r\n      000000000000000000000000000000000000000000000D9CD3ED0EABE5FF0EAB\r\n      E5FF0EABE5FF0EABE5FF0EABE5FF0EABE5FF0EABE5FF0EABE5FF0EABE5FF0EAB\r\n      E5FF0EABE5FF0EABE5FF0EABE5FF0EABE5FF0EABE5FF0EABE5FF0EABE5FF0EAB\r\n      E5FF0EABE5FF0EABE5FF0EABE5FF0EABE5FF0EABE5FF0EABE5FF0EABE5FF0EA9\r\n      E3FD01161E210000000000000000000000000000000000000000000000000000\r\n      000000000000000000000000000000000000000000000000000C000000160000\r\n      002000000029A5A5A5F5D7D7D7FFC6C6C6FFD4D4D4FFD8D8D8FFDDDDDDFFE2E2\r\n      E2FFE7E7E7FFEBEBEBFFEBEBEBFFE6E6E6FFE0E0E0FFDBDBDBFFD6D6D6FFD1D1\r\n      D1FFCCCCCCFFC7C7C7FFBCBCBCFF000000000000000000000000000000000000\r\n      0005000000100000001600000016000000160000001600000016000000160000\r\n      00160000001600000016000000160000001600000022100F0E55756960E08D81\r\n      73FF8C8073FF8D8173FF695F56D211100E550000002200000016000000160000\r\n      0010000000050000000000000000000000000000000000000000000000000000\r\n      0040FAFAFAFFF7F7F7FFF8F8F8FFF9F9F9FFFAFAFAFFFBFBFBFFFBFBFBFFFCFC\r\n      FCFFFCFCFCFFFDFDFDFFFDFDFDFFFEFEFEFFFFFFFFFFFAFAFAFFF0F0F0FFD6D6\r\n      D6FFD5D2CEFB3A3A369100000001000000000000000000000000000000000000\r\n      000000000000000000000000000000000000000001010D92D3FB13ADE6FF13AD\r\n      E6FF13ADE6FF13ADE6FF13ADE6FF13ADE6FF13ADE6FF13ADE6FF13ADE6FF13AD\r\n      E6FF13ADE6FF13ADE6FF13ADE6FF13ADE6FF13ADE6FF13ADE6FF13ADE6FF13AD\r\n      E6FF13ADE6FF13ADE6FF13ADE6FF13ADE6FF13ADE6FF13ADE6FF13ADE6FF13AD\r\n      E6FF07475F6A0000000000000000000000000000000000000000000000000000\r\n      00000000000000000000080808102525254E0000000000000001000000030000\r\n      000400000007AFAFAFF8D6D6D6FF2E302FFF333434FF303231FF2E2F2EFF2B2C\r\n      2CFF292A29FF262727FF242424FF222222FF222222FF222222FF222222FF2222\r\n      22FF222222FF222222FF141414FF000000000000000000000000000000000000\r\n      0010000000310000004200000043000000430000004300000043000000430000\r\n      004300000043000000430000004300000043000000488C8076FFADA49EFFC5C0\r\n      BEFFC4BFBEFFC4BFBDFFACA39DFF8C8076FF0000004800000043000000420000\r\n      0031000000100000000000000000000000000000000000000000000000000000\r\n      0040FAFAFAFFF7F7F6FFF8F8F8FFF9F9F9FFFAFAFAFFFBFBFBFFFBFBFBFFFCFC\r\n      FCFFFCFCFCFFFDFDFDFFFDFDFDFFFEFEFEFFFEFEFEFFFBFBFBFFF1F1F1FFDAD9\r\n      D9FFC0BFBDFFDEDEDDFE41423E9F000000010000000000000000000000000000\r\n      00000000000000000000000000000000000000070C100D7CC8FF18AEE7FF18AE\r\n      E7FF18AEE7FF18AEE7FF18AEE7FF18AEE7FF18AEE7FF18AEE7FF18AEE7FF18AE\r\n      E7FF18AEE7FF18AEE7FF18AEE7FF18AEE7FF18AEE7FF18AEE7FF18AEE7FF18AE\r\n      E7FF18AEE7FF18AEE7FF18AEE7FF18AEE7FF18AEE7FF18AEE7FF18AEE7FF18AE\r\n      E7FF10749BAC0000000000000000000000000000000000000000000000000000\r\n      0000000000001616162BA6A6A6F0CECECEFF838383D102020204000000003232\r\n      325D9E9E9EE2D2D2D2FFD5D5D5FF484B4AFF454846FF424443FF3E403FFF3B3D\r\n      3CFF383938FF343535FF313231FF2E2E2EFF2D2D2DFF2D2D2DFF2D2D2DFF2D2D\r\n      2DFF2D2D2DFF2D2D2DFF222222FF000000000000000000000000000000000000\r\n      0016AC7A17F2B67D0DFFB57B08FFB47A08FFB47A08FFB47A08FFB47A08FFB47A\r\n      08FFB47A08FFB47A08FFB57A07FFB77B03FFB9A78AFF897C72FFB0A496FFA87A\r\n      26FFB37E17FFBA8E3BFFC0B5AAFFA9A19CFF95805CFFB97D06FFB77E0DFFAC7A\r\n      17F2000000160000000000000000000000000000000000000000000000000000\r\n      0040FAFAFAFFF7F7F6FFF8F8F8FFF9F9F9FFFAFAFAFFFAFAFAFFFBFBFBFFFCFC\r\n      FCFFFCFCFCFFFDFDFDFFFDFDFDFFFEFEFEFFFEFEFEFFFBFBFBFFF3F3F3FFE0E0\r\n      E0FFC0BFBFFFDAD9D9FFE1E1E1FF4C4D49AE0000000100000000000000000000\r\n      000000000000000000000000000000000000010F1C250E73C1FF4CBEE9FF1DB0\r\n      E8FF1DB0E8FF1DB0E8FF1DB0E8FF1DB0E8FF1DB0E8FF1DB0E8FF1DB0E8FF1DB0\r\n      E8FF1DB0E8FF1DB0E8FF1DB0E8FF1DB0E8FF1DB0E8FF1DB0E8FF1DB0E8FF1DB0\r\n      E8FF1DB0E8FF1DB0E8FF1DB0E8FF1DB0E8FF1DB0E8FF1DB0E8FF1DB0E8FF1DB0\r\n      E8FF1BA3D5EC0001020200000000000000000000000000000000000000000000\r\n      00001616162BACACACF6CACACAFFCCCCCCFFCECECEFFAAAAAAEDB0B0B0EFCECE\r\n      CEFED3D3D3FFD4D4D4FFD5D5D5FF4A4D4BFF464948FF434544FF404241FF3C3E\r\n      3DFF393A3AFF363736FF323333FF2F2F2FFF2D2D2DFF2D2D2DFF2D2D2DFF2D2D\r\n      2DFF2D2D2DFF2D2D2DFF222222FF000000000000000000000000000000000000\r\n      0016B67D0DFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n      FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFBBB5B3FF877A6DFFE9E6E7FFFFFF\r\n      FFFFFFFFFFFFFFFFFFFFF8F7F8FFC1BBB5FF84786EFFFFFFFFFFFFFFFFFFB67D\r\n      0DFF000000160000000000000000000000000000000000000000000000000000\r\n      0040FAFAFAFFF6F6F6FFF8F8F8FFF9F9F9FFFAFAFAFFFAFAFAFFFBFBFBFFFCFC\r\n      FCFFFCFCFCFFFDFDFDFFFDFDFDFFFEFEFEFFFEFEFEFFFCFCFCFFF7F7F7FFECEC\r\n      ECFFCECDCDFFC4C2C2FFF9FAFAFFE1E1E1FF4C4D49AE00000001000000000000\r\n      00000000000000000000000000000000000001172A38056EC0FF99D1E9FF22B1\r\n      E8FF22B1E8FF22B1E8FF22B1E8FF22B1E8FF22B1E8FF22B1E8FF22B1E8FF22B1\r\n      E8FF22B1E8FF22B1E8FF22B1E8FF22B1E8FF22B1E8FF22B1E8FF22B1E8FF22B1\r\n      E8FF22B1E8FF22B1E8FF22B1E8FF22B1E8FF22B1E8FF22B1E8FF22B1E8FF22B1\r\n      E8FF22B1E8FF06222C3100000000000000000000000000000000000000000808\r\n      0810A2A2A2F0C7C7C7FFC9C9C9FFCBCBCBFFCDCDCDFFCFCFCFFFD1D1D1FFD2D2\r\n      D2FFD4D4D4FFD4D4D4FFD5D5D5FF4B4E4CFF474A49FF444745FF414342FF3E3F\r\n      3EFF3A3C3BFFEBECEBFFEBEBEBFFEBEBEBFF2D2D2DFF2D2D2DFF2D2D2DFF2D2D\r\n      2DFF2D2D2DFF2D2D2DFF222222FF000000000000000000000000000000000000\r\n      0016B57A08FFFFFFFFFFE6D6AFFFE6D6B0FFE7D7B1FFE7D7B1FFE7D7B1FFE7D7\r\n      B1FFE7D7B1FFE7D7B1FFE8D7B1FFECDCB4FFBFB9B4FF897A6DFFCFC0A0FF8B7C\r\n      6DFF837467FF8A7A6CFFCFC1A5FFC2BCB5FF85766AFFEEDEB5FFFFFFFFFFB57A\r\n      08FF000000160000000000000000000000000000000000000000000000000000\r\n      0040FAFAFAFFF6F6F6FFF7F7F7FFF9F9F9FFFAFAFAFFFAFAFAFFFBFBFBFFFBFB\r\n      FBFFFCFCFCFFFCFCFCFFFDFDFDFFFEFEFEFFFEFEFEFFFEFEFEFFFAFAFAFFF1F1\r\n      F1FFE0E0E0FFBDBCBCFFFDFDFDFFF9FAFAFFE1E1E1FF42423F9F000000020000\r\n      0000000000000000000000000000000000000220394C056EC0FFC2D7E6FF3EB9\r\n      EAFF27B3E9FF27B3E9FF27B3E9FF27B3E9FF27B3E9FF27B3E9FF27B3E9FF27B3\r\n      E9FF27B3E9FF27B3E9FF27B3E9FF27B3E9FF27B3E9FF27B3E9FF27B3E9FF27B3\r\n      E9FF27B3E9FF27B3E9FF27B3E9FF27B3E9FF27B3E9FF27B3E9FF27B3E9FF27B3\r\n      E9FF27B3E9FF114F697300000000000000000000000000000000000000002626\r\n      2650C6C6C6FFC3C3C3FFC6C6C6FFC7C7C7FFCACACAFFCDCDCDFFD0D0D0FFD2D2\r\n      D2FFD3D3D3FFD4D4D4FFD5D5D5FF4C4F4EFF494C4AFFC4C4C4FF6D6E6EFF3F41\r\n      40FF3B3D3CFF383939FF353635FF323232FF2E2E2EFF2D2D2DFF2D2D2DFF2D2D\r\n      2DFF2D2D2DFF2D2D2DFF222222FF000000000000000000000000000000000000\r\n      0016B47A08FFFFFFFFFFE6D7B0FFE7D7B3FFE8D8B4FFE8D8B4FFE8D8B4FFE8D8\r\n      B4FFE8D8B4FFE8D8B4FFE8D9B4FFEDDDB6FFBFB9B5FF8A7C6EFFA1968BFFC4BE\r\n      B8FFC1BBB5FFB7B0A8FF968B7EFFC4BEB8FF85776BFFEFDEB6FFFFFFFFFFB47A\r\n      08FF000000160000000000000000000000000000000000000000000000000000\r\n      0040FAFAF9FFF6F6F6FFF7F7F7FFF8F8F8FFFAFAFAFFFAFAFAFFFBFBFBFFFBFB\r\n      FBFFFCFCFCFFFCFCFCFFFDFDFDFFFDFDFDFFFEFEFEFFFEFEFEFFFCFCFCFFF8F8\r\n      F8FFEFEFEFFFD7D6D6FFBFBFBFFFC7C6C6FFDDDDDCFFDFDEDEFE3B3A39920000\r\n      000200000000000000000000000000000000012A4860056EC0FFABCAE1FF95D3\r\n      EBFF2CB4EAFF2CB4EAFF2CB4EAFF2CB4EAFF2CB4EAFF2CB4EAFF2CB4EAFF2CB4\r\n      EAFF2CB4EAFF2CB4EAFF2CB4EAFF2CB4EAFF2CB4EAFF2CB4EAFF2CB4EAFF2CB4\r\n      EAFF2CB4EAFF2CB4EAFF2CB4EAFF2CB4EAFF2CB4EAFF2CB4EAFF2CB4EAFF2CB4\r\n      EAFF2CB4EAFF1F7FA6B500000000000000000000000000000000000000000000\r\n      0000777777D0BABABAFFBCBCBCFFBCBCBCFFBDBDBDFFBFBFBFFFC3C3C3FFC7C7\r\n      C7FFD6D6D6FFCCCCCCFFD5D5D5FF5D615FFF535654FF818281FFD4D5D5FFC2C3\r\n      C2FF696A6AFF393B3AFF363737FF333333FF2F3030FF2D2D2DFF2D2D2DFF2D2D\r\n      2DFF2D2D2DFF2D2D2DFF222222FF000000000000000000000000000000000000\r\n      0016B47A08FFFFFFFFFFE7D7B1FFE8D8B4FFE8D9B5FFE8D9B5FFE8D9B5FFE8D9\r\n      B5FFE8D9B5FFE8D9B5FFE9D9B5FFEDDDB7FFBFB9B5FF8A7B6EFFBFB8B0FF958A\r\n      7EFFF6E6BBFFC1BBB5FF978C7EFFC5BFB8FF86776BFFEFDFB6FFFFFFFFFFB47A\r\n      08FF000000160000000000000000000000000000000000000000000000000000\r\n      0040F9F9F9FFF6F6F5FFF7F7F7FFF8F8F8FFF9F9F9FFFAFAFAFFFAFAFAFFFBFB\r\n      FBFFFCFCFCFFFCFCFCFFFDFDFDFFFDFDFDFFFEFEFEFFFEFEFEFFFEFEFEFFFCFC\r\n      FCFFF7F7F7FFF0F0F0FFE5E5E5FFD6D6D6FFCCCBCBFFCDCCCBFFD9D6D3FA3333\r\n      308400000002000000000000000000000000033257740670C2FF92BDDDFFE2EA\r\n      EDFF3AB8EBFF31B6EBFF31B6EBFF31B6EBFF31B6EBFF31B6EBFF31B6EBFF31B6\r\n      EBFF31B6EBFF31B6EBFF31B6EBFF31B6EBFF31B6EBFF31B6EBFF31B6EBFF31B6\r\n      EBFF31B6EBFF31B6EBFF31B6EBFF31B6EBFF31B6EBFF31B6EBFF31B6EBFF31B6\r\n      EBFF31B6EBFF2FACDFF201030404000000000000000000000000000000000000\r\n      0000020202048A8A8AEBC3C3C3FFC5C5C5FFC5C5C5FFC5C5C5FFC9C9C9FFBBBB\r\n      BBFFB7B7B7FFBABABAFFC1C1C1FF5F6361FF5D5F5EFF5A5D5BFF565958FFC7C7\r\n      C7FFECECECFF3B3C3BFF373838FF343534FF313131FF2D2D2DFF2D2D2DFF2D2D\r\n      2DFF2D2D2DFF2D2D2DFF222222FF000000000000000000000000000000000000\r\n      0016B47A08FFFFFFFFFFE6D7B0FFE7D8B3FFE8D9B4FFE8D9B4FFE8D9B4FFE8D9\r\n      B4FFE8D9B4FFE8D9B4FFE8D9B4FFEDDDB6FFC0B9B4FF8B7B6DFFC6C0B9FF9689\r\n      7EFFF6E5BDFFC0B9B4FF988B7EFFC6BFB8FF87776BFFEFDEB6FFFFFFFFFFB47A\r\n      08FF000000160000000000000000000000000000000000000000000000000000\r\n      0040F9F9F9FFF5F5F5FFF6F6F6FFF8F8F8FFF9F9F9FFFAFAFAFFFAFAFAFFFBFB\r\n      FBFFFBFBFBFFFCFCFCFFFCFCFCFFFDFDFDFFFDFDFDFFFEFEFEFFFEFEFEFFFFFF\r\n      FFFFFCFCFCFFFAFAFAFFF4F4F4FFEFEFEFFFECECECFFE9E9E9FFE9E9E9FFDAD8\r\n      D3F300000037000000000000000000000000043D69870975C8FF78B0DBFFEEEE\r\n      EEFF86CEECFF42BDEDFF36B7ECFF36B7ECFF36B7ECFF36B7ECFF36B7ECFF36B7\r\n      ECFF36B7ECFF36B7ECFF36B7ECFF36B7ECFF36B7ECFF36B7ECFF36B7ECFF36B7\r\n      ECFF36B7ECFF36B7ECFF36B7ECFF36B7ECFF36B7ECFF36B7ECFF36B7ECFF36B7\r\n      ECFF36B7ECFF36B7ECFF0C2A353A000000000000000000000000000000000000\r\n      0000000000019B9B9BF2C4C4C4FFC8C8C8FFCACACAFFD1D1D1FFCDCDCDFFC3C3\r\n      C3FFC0C0C0FFBDBDBDFFBCBCBCFF616463FF5D615FFF8A8D8DFFD2D4D3FFBDBF\r\n      BFFF6E706FFF4A4B4BFF414241FF383939FF323232FF2F2F2FFF2D2D2DFF2D2D\r\n      2DFF2D2D2DFF2D2D2DFF222222FF000000000000000000000000000000000000\r\n      0016B47A07FFFFFFFFFFE5D5ADFFE6D6AFFFE6D6AFFFE6D6AFFFE6D6AFFFE6D6\r\n      AFFFE6D6AFFFE6D6AFFFE7D7B0FFECDBB2FFBFB8B3FF8B7A6DFFC6BFB8FF9588\r\n      7CFFF2E1B7FFA69A92FF938678FFC4BDB6FF86766AFFEEDEB3FFFFFFFFFFB47A\r\n      07FF000000160000000000000000000000000000000000000000000000000000\r\n      0040F9F9F9FFF5F5F4FFF6F6F6FFF7F7F7FFF8F8F8FFFAFAFAFFFAFAFAFFFBFB\r\n      FBFFFBFBFBFFFCFCFCFFFCFCFCFFFCFCFCFFFDFDFDFFFDFDFDFFFEFEFEFFFEFE\r\n      FEFFFEFEFEFFFDFDFDFFFBFBFBFFFAFAFAFFF8F8F8FFF7F7F7FFF7F7F7FFFAF9\r\n      F8FF0000004000000000000000000000000007497D9B0C7ACDFF60A6D9FFEEEE\r\n      EEFFD6E6EDFF4FC2EFFF59C7F1FF3BB9EDFF3BB9EDFF3BB9EDFF3BB9EDFF3BB9\r\n      EDFF3BB9EDFF3BB9EDFF3BB9EDFF3BB9EDFF3BB9EDFF3BB9EDFF3BB9EDFF3BB9\r\n      EDFF3BB9EDFF3BB9EDFF3BB9EDFF3BB9EDFF3BB9EDFF3BB9EDFF3BB9EDFF3BB9\r\n      EDFF3BB9EDFF3BB9EDFF1D59727C000000000000000000000000000000000000\r\n      00003939396FBBBBBBFFC3C3C3FFC7C7C7FFCACACAFFD3D3D3FFC5C5C5FFC7C7\r\n      C7FFCACACAFFCACACAFFC9C9C9FF626664FF5F6260FFC0C2C1FF787B79FF5658\r\n      57FF535454FF505251FF4D4E4DFF4A4B4BFF454645FF3F3F3FFF3A3A3AFF3838\r\n      38FF343434FF323232FF242424FF000000000000000000000000000000000000\r\n      0016B47907FFFFFFFFFFFBF8F1FFFBF8F0FFFBF8F1FFFBF8F1FFFBF8F1FFFBF8\r\n      F1FFFBF8F1FFFBF8F1FFFCF9F1FFFFFEF6FFBEB6B0FF89796BFFC6BEB7FF9387\r\n      79FFFFFFFAFFFFFEF5FFFFFFFCFFC0B8B1FF847467FFFFFFFAFFFFFFFFFFB479\r\n      07FF000000160000000000000000000000000000000000000000000000000000\r\n      0040F9F9F9FFF4F4F4FFF5F5F5FFF7F7F6FFF8F8F8FFF9F9F9FFFAFAFAFFFAFA\r\n      FAFFFBFBFBFFFBFBFBFFFCFCFCFFFCFCFCFFFDFDFDFFFDFDFDFFFDFDFDFFFEFE\r\n      FEFFFEFEFEFFFEFEFEFFFEFEFEFFFEFEFEFFFDFDFDFFFDFDFDFFFDFDFDFFFEFE\r\n      FDFF000000400000000000000000000000000A5690AF1080D3FF4A9CDAFFEEEE\r\n      EEFFEDEDEDFF94D1EAFF5AC6F1FF74D3F6FF73D3F6FF73D3F6FF73D3F6FF73D3\r\n      F6FF73D3F6FF73D3F6FF73D3F6FF75D4F6FF64CBF3FF41BAEEFF40BAEEFF40BA\r\n      EEFF40BAEEFF40BAEEFF40BAEEFF40BAEEFF40BAEEFF40BAEEFF40BAEEFF40BA\r\n      EEFF40BAEEFF40BAEEFF2F8BB1BE000000000000000000000000000000000000\r\n      00018A8A8AE5C3C3C3FFC6C6C6FFC9C9C9FFD6D6D6FFC5C5C5FFC7C7C7FFCBCB\r\n      CBFFCECECEFFC4C4C4FE949494DF494B4AFF4E5050FF4C4E4DFF4A4B4BFF484A\r\n      48FF454746FF424443FF414241FF3F403FFF3C3D3DFF3A3A3AFF383838FF3838\r\n      38FF383838FF383838FF2B2B2BFF000000000000000000000000000000000000\r\n      0016B47907FFFFFFFFFFF9F5EBFFF8F4EAFFF8F5EAFFF8F5EAFFF8F5EAFFF8F5\r\n      EAFFF8F5EAFFF8F5EAFFF9F6EBFFFDFAEFFFBAB1AAFF867466FFC4BCB5FF9486\r\n      78FFFFFFF4FFFCF9EDFFFFFEF4FFBFB6AFFF857466FFFFFFF6FFFFFFFFFFB479\r\n      07FF000000160000000000000000000000000000000000000000000000000000\r\n      0040F9F9F8FFF4F4F3FFF5F5F5FFF6F6F6FFF7F7F7FFF8F8F8FFF9F9F9FFFAFA\r\n      FAFFFAFAFAFFFBFBFBFFFBFBFBFFFCFCFCFFFCFCFCFFFCFCFCFFFDFDFDFFFDFD\r\n      FDFFFDFDFDFFFEFEFEFFFEFEFEFFFEFEFEFFFEFEFEFFFEFEFEFFFEFEFEFFFEFE\r\n      FEFF000000400000000000000000000000000F65A5C31284D8FF3394DBFFEEEE\r\n      EEFFEDEDEDFFEAE3D4FFAB9F65FFB1C4B9FFB4CBD1FF9EB9BDFFAFC7CDFFBAD5\r\n      DEFFC0DEEAFFADC2C6FF95B3B8FF8BC2D6FF63C6EEFF73D2F5FF46BCEEFF45BC\r\n      EEFF45BCEEFF45BCEEFF45BCEEFF45BCEEFF45BCEEFF45BCEEFF45BCEEFF45BC\r\n      EEFF45BCEEFF45BCEEFF43B6E6F702060708020202078D8D8DE4AAAAAAF3B4B4\r\n      B4F8C2C2C2FFC7C7C7FFCACACAFFCDCDCDFFD6D6D6FFC8C8C8FFCBCBCBFFCECE\r\n      CEFFC2C2C2FE4C4C4C8700000000B8B8B8FFC9C9C9FFCECECEFFD3D3D3FFD7D7\r\n      D7FFDCDCDCFFE1E1E1FFE6E6E6FFEAEAEAFFECECECFFE6E6E6FFE1E1E1FFDCDC\r\n      DCFFD7D7D7FFD2D2D2FFC2C2C2FF020202070000000000000000000000000000\r\n      0016B47907FFFFFFFFFFF7F2E7FFF7F2E6FFF7F2E6FFF7F2E6FFF7F2E6FFF7F2\r\n      E6FFF7F2E6FFF7F2E6FFF7F2E6FFF9F4E8FFFDF8ECFFFFFFF3FFC0B7B1FF9486\r\n      79FFFFFFF3FFFDF9EDFFFDF9EEFFBAB0A9FF867568FFFFFDF2FFFFFFFFFFB479\r\n      07FF000000160000000000000000000000000000000000000000000000000000\r\n      0040F8F8F8FFF3F3F3FFF4F4F4FFF5F5F5FFF7F7F6FFF8F8F8FFF9F9F9FFFAFA\r\n      FAFFFAFAFAFFFAFAFAFFFBFBFBFFFBFBFBFFFCFCFCFFFCFCFCFFFCFCFCFFFDFD\r\n      FDFFFBFBFBFFF8F8F8FFF4F4F4FFF4F4F4FFF4F4F4FFF5F5F5FFF8F8F8FFFDFD\r\n      FDFF000000400000000000000000000000001173B8D61589DDFF1E8DDDFFEEEE\r\n      EEFFEDEDEDFFEBE8E3FFD8C49CFFE1DACAFFD9D0C8FFC2BFB5FFD1CBC3FFDDD7\r\n      D0FFEAEAEAFFD4C9BEFFB5B1A5FFD5CABFFFC6CAC8FF78C7E8FF6CCEF4FF4ABD\r\n      EFFF4ABDEFFF4ABDEFFF4ABDEFFF4ABDEFFF4ABDEFFF4ABDEFFF4ABDEFFF4ABD\r\n      EFFF4ABDEFFF4ABDEFFF4ABDEFFF12303E4211111126A9A9A9FDC0C0C0FFC3C3\r\n      C3FFC7C7C7FFCACACAFFCDCDCDFFD0D0D0FFD2D2D2FFCACACAFFCECECEFFD1D1\r\n      D1FF878787E00000000000000000A1A1A1F2BABABAFFBDBDBDFFC1C1C1FFC5C5\r\n      C5FFC8C8C8FFCCCCCCFFD0D0D0FFD4D4D4FFD7D7D7FFD3D3D3FFD0D0D0FFCCCC\r\n      CCFFC9C9C9FFC6C6C6FFB6B6B6FF111111260000000000000000000000000000\r\n      0016B47907FFFFFFFFFFF6F1E4FFF6F1E3FFF6F1E3FFF6F1E3FFF6F1E3FFF6F1\r\n      E3FFF6F1E3FFF6F1E3FFF6F1E3FFF6F1E3FFF8F3E5FFFCF8E9FFBCB3AEFF9D8F\r\n      84FFC6BCAEFFE4DCCFFFD5CCC0FFA09288FF867568FFFFFBEDFFFFFFFFFFB479\r\n      07FF000000160000000000000000000000000000000000000000000000000000\r\n      0040F8F8F8FFF3F3F2FFF4F4F3FFF5F5F4FFF6F6F6FFF7F7F7FFF8F8F8FFF9F9\r\n      F9FFFAFAFAFFFAFAFAFFFBFBFBFFFBFBFBFFFBFBFBFFFCFCFCFFFBFBFBFFF5F5\r\n      F5FFE3E3E3FFC2C2C2FFA2A2A2FF979797FF9D9D9DFFA6A6A6FFBFBFBFFFE9E9\r\n      E9FF000000450000000100000000000000001C83CBE61C90E2FF188EE2FFE0E8\r\n      EEFFEDEDEDFFEDEDEDFFEDEDEDFFEDEDEDFFD9D0C8FFDCDBD7FFDCD8D2FFD3C7\r\n      BBFFDCD5CFFFCCBCAEFFD7CEC6FFD0C3B7FFD5CCC4FFCECBC5FF76CCF0FF65CA\r\n      F3FF4FBEF0FF4FBEF0FF4FBEF0FF4FBEF0FF4FBEF0FF4FBEF0FF4FBEF0FF4FBE\r\n      F0FF4FBEF0FF4FBEF0FF4FBEF0FF29637C841B1B1B3FB7B7B7FFC4C4C4FFC7C7\r\n      C7FFCACACAFFCDCDCDFFD0D0D0FFD6D6D6FFCCCCCCFFCDCDCDFFD0D0D0FFD1D1\r\n      D1FF494949910000000000000000000000000000000000000000000000004C4C\r\n      4C92C8C8C8FFC2C2C2FFBBBBBBFFC5C5C5FFD5D5D5FFD3D3D3FFD0D0D0FFCDCD\r\n      CDFFCACACAFFC7C7C7FFB9B9B9FF1B1B1B3F0000000000000000000000000000\r\n      0016B47907FFFFFFFFFFF5EFE0FFF5EFE0FFF5EFE0FFF5EFE0FFF5EFE0FFF5EF\r\n      E0FFF5EFE0FFF5EFE0FFF5EFE0FFF5EFE0FFF5EFE0FFF9F3E3FFCEC6BDFFBBB2\r\n      ACFF9D8F85FF97887BFF98887CFF98887DFFAA9E91FFFBF6E7FFFFFFFFFFB479\r\n      07FF000000160000000000000000000000000000000000000000000000000000\r\n      0040F8F8F7FFF2F2F1FFF3F3F2FFF4F4F4FFF5F5F5FFF6F6F6FFF7F7F7FFF8F8\r\n      F8FFF9F9F9FFFAFAFAFFFAFAFAFFFAFAFAFFFBFBFBFFFAFAFAFFEFEFEFFFBEBE\r\n      BEFF789178FF35A635FF0EBD0EFF07BB07FF0CBE0CFF12BA12FF32A532FF8399\r\n      83FF000000700000000E000000010000000013639CAD42A2E9FF2E9AE7FFCCE0\r\n      EEFFEDEDEDFFEDEDEDFFEDEDEDFFEDEDEDFFE2DDD8FFDAD1C8FFDDD6D0FFE2DE\r\n      D9FFE7E5E3FFE9E9E9FFE8E8E8FFE7E6E6FFE0DEDBFFD9D3CDFFC3D0D3FF74CF\r\n      F4FF65C9F3FF55C0F1FF55C0F1FF55C0F1FF55C0F1FF55C0F1FF55C0F1FF55C0\r\n      F1FF55C0F1FF55C0F1FF55C0F1FF4D9CBCC61D1D1D40B9B9B9FFC7C7C7FFCACA\r\n      CAFFCDCDCDFFCFCFCFFFD2D2D2FFD7D7D7FFCDCDCDFFCFCFCFFFD1D1D1FFD1D1\r\n      D1FF5454549B0000000000000000000000000000000000000000000000005454\r\n      549CD1D1D1FFC9C9C9FFBFBFBFFFBDBDBDFFCFCFCFFFD1D1D1FFD2D2D2FFCFCF\r\n      CFFFCDCDCDFFCACACAFFBBBBBBFF1D1D1D400000000000000000000000000000\r\n      0016B47907FFFFFFFFFFF4EEDDFFF4EEDDFFF4EEDDFFF4EEDDFFF4EEDDFFF4EE\r\n      DDFFF4EEDDFFF4EEDDFFF4EEDDFFF4EEDDFFF4EEDDFFF6F0DFFFF5EEDEFFD7CF\r\n      C4FFBCB3AEFFBEB5AFFFBDB5AFFFD5CDC3FFF3EDDCFFF7F1E0FFFFFFFFFFB479\r\n      07FF000000160000000000000000000000000000000000000000000000000000\r\n      0040F7F7F7FFF1F1F1FFF2F2F2FFF3F3F3FFF4F4F4FFF5F5F5FFF6F6F6FFF7F7\r\n      F7FFF8F8F8FFF9F9F9FFFAFAFAFFFAFAFAFFF9F9F9FFEEEEEEFFB1B2B1FF30AA\r\n      30FF00BE00FF00BA00FF00A800FF00AB00FF00AD00FF00AD00FF00BB00FF03BB\r\n      03FF007700DA0002004D0000000C0000000102090F101354818D2E75A7B6A8BE\r\n      CEDFEDEDEDFFEDEDEDFFEDEDEDFFEDEDEDFFEDEDEDFFEDEDEDFFE3DFDAFFE8E7\r\n      E5FFDBD3CCFFD5CAC0FFD8CFC6FFD6CDC3FFDDD7D1FFE4E3E2FFD1D2D2EB7A9F\r\n      B0C074CFF5FE81D7F8FF6FCDF5FF69CAF4FF69CAF4FF69CAF4FF69CAF4FF69CA\r\n      F4FF69CAF4FF6BCBF4FF81D7F8FF54ADD6E111111127B3B3B3FDC9C9C9FFCCCC\r\n      CCFFCFCFCFFFD1D1D1FFD4D4D4FFD7D7D7FFCECECEFFD0D0D0FFD2D2D2FFD4D4\r\n      D4FF8E8E8EE50000000000000000000000000000000000000000000000008D8D\r\n      8DE5D7D7D7FFD0D0D0FFC5C5C5FFC2C2C2FFC7C7C7FFCDCDCDFFD2D2D2FFD1D1\r\n      D1FFCFCFCFFFCCCCCCFFB5B5B5FD111111270000000000000000000000000000\r\n      0016B47A07FFFFFFFFFFF4ECDAFFF4ECD9FFF4ECDAFFF4ECDAFFF4ECDAFFF4EC\r\n      DAFFF4ECDAFFF4ECDAFFF4ECDAFFF4ECDAFFF4ECDAFFF4ECDAFFF6EEDBFFF7EF\r\n      DDFFF9F1DFFFFAF2DFFFF9F2DFFFF8F0DEFFF6EEDBFFF5EDDAFFFFFFFFFFB47A\r\n      07FF000000160000000000000000000000000000000000000000000000000000\r\n      0040F7F7F7FFF0F0F0FFF1F1F1FFF2F2F2FFF3F3F3FFF4F4F4FFF5F5F5FFF6F6\r\n      F6FFF7F7F7FFF8F8F8FFF9F9F9FFFAFAFAFFF3F3F3FFB8BBB8FF21AE21FF00BB\r\n      00FF00B300FF00A301FF00A40CFF00A417FF00A419FF00A715FF00A605FF00AD\r\n      00FF00BA00FF008800DC00010040000000070000000000000000000000000A0B\r\n      0B0D252525284646464BEEEEEEFFEDEDEDFFEDEDEDFFEDEDEDFFE6E2DFFFDED7\r\n      D0FFE7E5E3FFE3E3E3F7B5B5B5C68383838F515151591F1F1F23000000000000\r\n      00002040505456ADD8E370CDF5FF75D0F6FF75D0F6FF75D0F6FF75D0F6FF75D0\r\n      F6FF75D0F6FF73CFF6FF62C4F2FE2751656B02020207A5A5A5EAA2A2A2F0ADAD\r\n      ADF6C8C8C8FFD4D4D4FFD6D6D6FFD9D9D9FFD0D0D0FFD1D1D1FFD3D3D3FFD5D5\r\n      D5FFC5C5C5FE535353940000000000000000000000000000000053535398C3C3\r\n      C3FED7D7D7FFD5D5D5FFCDCDCDFFC8C8C8FFC7C7C7FFCACACAFFD0D0D0FFCBCB\r\n      CBFFAFAFAFF6A5A5A5F1A8A8A8EB020202070000000000000000000000000000\r\n      0016B47A07FFFFFFFFFFF3EBD7FFF3EBD6FFF3EBD7FFF3EBD7FFF3EBD7FFF3EB\r\n      D7FFF3EBD7FFF3EBD7FFF3EBD7FFF3EBD7FFF3EBD7FFF3EBD7FFF3EBD7FFF3EC\r\n      D7FFF4ECD8FFF4ECD8FFF4ECD8FFF3ECD7FFF3EBD7FFF3EBD7FFFFFFFFFFB47A\r\n      07FF000000160000000000000000000000000000000000000000000000000000\r\n      0040F7F7F6FFF0F0EFFFF1F1F0FFF2F2F1FFF3F3F2FFF4F4F3FFF4F4F4FFF5F5\r\n      F5FFF6F6F6FFF7F7F7FFF8F8F8FFF8F8F8FFE4E4E4FF33A833FF00B900FF00AF\r\n      00FF00AA07FF00B41FFF00AA29FFFFFFFFFFFFFFFFFF00AF34FF00BA31FF00B3\r\n      17FF00AB00FF00B300FF007100C9000000190000000000000000000000000000\r\n      0000000000000B0B0B0CEBEBEBFCEDEDEDFFEBEBEBFDC6C6C6D69393939F6161\r\n      61692F2F2F33050505050000000000000000050A080E00000000000000000000\r\n      00000000000002030404162E393D204252572042525720425257204252572042\r\n      5257204252572042525710222B2D000000000000000000000000000000000000\r\n      0000848484E1D6D6D6FFD8D8D8FFDADADAFFD3D3D3FFD1D1D1FFD4D4D4FFD9D9\r\n      D9FFDEDEDEFFC8C8C8FEA0A0A0E1555555B6555555B6A1A1A1E2C3C3C3FED9D9\r\n      D9FFD7D7D7FFD6D6D6FFD1D1D1FFCDCDCDFFCDCDCDFFC7C7C7FFCECECEFF8787\r\n      87E2000000010000000000000000000000000000000000000000000000000000\r\n      0016B47A07FFFFFFFFFFF2E9D3FFF2E9D3FFF2E9D4FFF2E9D4FFF2E9D4FFF2E9\r\n      D4FFF2E9D4FFF2E9D4FFF2E9D4FFF2E9D4FFF2E9D4FFF2E9D4FFF2E9D4FFF2E9\r\n      D4FFF2E9D4FFF2E9D4FFF2E9D4FFF2E9D4FFF2E9D3FFF2E9D3FFFFFFFFFFB47A\r\n      07FF000000160000000000000000000000000000000000000000000000000000\r\n      0040F6F6F6FFEFEFEEFFF0F0EFFFF1F1F0FFF2F2F1FFF3F3F2FFF4F4F3FFF4F4\r\n      F4FFF5F5F5FFF6F6F6FFF7F7F7FFF1F1F1FFA7BAA7FF03B203FF00B200FF00AF\r\n      03FF00BA1FFF00C33AFF00AD3EFFFFFFFFFFFFFFFFFF00B34AFF00CA51FF00C3\r\n      3AFF00B716FF00B100FF00B000FE001700560000000000000000000000000000\r\n      00000000000000000000444444493E3E3E430E0E0E0F00000000000000000000\r\n      00000000000000000000000000000000000025A05FD81C7444A0041209180000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      00003434346CCCCCCCFFDADADAFFDCDCDCFFDEDEDEFFCDCDCDFFD8D8D8FFDEDE\r\n      DEFFDEDEDEFFDEDEDEFFDEDEDEFFDDDDDDFFDDDDDDFFDDDDDDFFDBDBDBFFD9D9\r\n      D9FFD8D8D8FFD6D6D6FFCFCFCFFFDBDBDBFFD3D3D3FFCCCCCCFFC2C2C2FF3535\r\n      356F000000000000000000000000000000000000000000000000000000000000\r\n      0016B47A07FFFFFFFFFFF1E8D0FFF1E8D0FFF1E8D1FFF1E8D1FFF1E8D1FFF1E8\r\n      D1FFF1E8D1FFF1E8D1FFF1E8D1FFF1E8D1FFF1E8D1FFF1E8D1FFF1E8D1FFF1E8\r\n      D1FFF1E8D1FFF1E8D1FFF1E8D1FFF1E8D1FFF1E8D0FFF1E8D0FFFFFFFFFFB47A\r\n      07FF000000160000000000000000000000000000000000000000000000000000\r\n      0040F6F6F5FFEEEEEDFFEFEFEEFFF0F0EFFFF1F1F0FFF2F2F1FFF3F3F2FFF3F3\r\n      F3FFF4F4F4FFF5F5F5FFF6F6F5FFEDEDEDFF3DAA3DFF00AF00FF00B400FF00BB\r\n      12FF00C631FF00CF51FF00AF4CFFFFFFFFFFFFFFFFFF00B35CFF00D96EFF00CF\r\n      51FF00C631FF00B605FF00B100FF006400BC0000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      000000000000000000000000000000000000197B4BA129C175FF29B26BF11354\r\n      3273000401050000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000010101029C9C9CF0DDDDDDFFDFDFDFFFE1E1E1FFDEDEDEFFD3D3D3FFDEDE\r\n      DEFFDEDEDEFFDEDEDEFFDEDEDEFFDDDDDDFFDDDDDDFFDDDDDDFFDCDCDCFFDADA\r\n      DAFFD9D9D9FFCECECEFFDDDDDDFFE2E2E2FFDADADAFFD3D3D3FF9E9E9EF30101\r\n      0102000000000000000000000000000000000000000000000000000000000000\r\n      0016B47A07FFFFFFFFFFF0E5CCFFF0E6CDFFF0E6CEFFF0E6CEFFF0E6CEFFF0E6\r\n      CEFFF0E6CEFFF0E6CEFFF0E6CEFFF0E6CEFFF0E6CEFFF0E6CEFFF0E6CEFFF0E6\r\n      CEFFF0E6CDFFF0E6CDFFF0E6CDFFF0E6CDFFEFE5CCFFEFE5CCFFFFFFFFFFB47A\r\n      07FF000000160000000000000000000000000000000000000000000000000000\r\n      0040F5F5F5FFEDEDECFFEEEEEDFFEFEFEEFFF0F0EFFFF1F1F0FFF2F2F1FFF2F2\r\n      F2FFF3F3F3FFF4F4F3FFF5F5F4FFEBEBEBFF14A314FF00B400FF00AF00FF0097\r\n      11FF009D26FF00A43BFF008C37FFFFFFFFFFFFFFFFFF009045FF00AA52FF00A4\r\n      3BFF009D26FF00B512FF00AC00FF009100EC0000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000D4C316024C97EFF26C57AFF29C1\r\n      75FF24A05FD70C331E4600000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000039A9A9AECE0E0E0FFE1E1E1FFE5E5E5FFEAEAEAFFE2E2E2FFE3E3\r\n      E3FFDDDDDDFFDEDEDEFFDEDEDEFFDDDDDDFFDDDDDDFFDCDCDCFFDCDCDCFFD9D9\r\n      D9FFDFDFDFFFDEDEDEFFE5E5E5FFE4E4E4FFDFDFDFFFD9D9D9FF9A9A9AED0000\r\n      0003000000000000000000000000000000000000000000000000000000000000\r\n      0016B47A07FFFFFFFFFFEEE3C9FFEFE4CAFFEFE4CBFFEFE4CBFFEFE4CBFFEFE4\r\n      CBFFEFE4CBFFEFE4CBFFEFE4CBFFEFE4CBFFEFE4CBFFEFE4CBFFEFE4CAFFEEE3\r\n      C9FFEEE2C8FFEEE3C8FFEEE3C9FFEEE3C9FFEEE2C8FFEEE2C8FFFFFFFFFFB47A\r\n      07FF000000160000000000000000000000000000000000000000000000000000\r\n      0040F5F5F4FFECECEBFFEDEDECFFEEEEEDFFEFEFEEFFF0F0EFFFF1F1F0FFF1F1\r\n      F1FFF2F2F2FFF3F3F2FFF3F3F3FFE9E9E9FF0D9A0DFF00AB00FF008A00FFFFFF\r\n      FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n      FFFFFFFFFFFF008D0FFF00B300FF009400F60000000000000000000000000000\r\n      00000000000000000000010A070B0D2A1F2F0000000000000000000000000000\r\n      000000000000000000000000000004211729148A5AA720D086FF22CD83FF24C9\r\n      7EFF26C57AFF28C176FF208350AE0107040B0000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000848484D4DEDEDEFFE3E3E3FFE5E5E5FFEAEAEAFFEBEBEBFFEBEBEBFFECEC\r\n      ECFFD3D3D3FFE4E4E4FFCCCCCCFFD7D7D7FFD6D6D6FFCACACAFFE2E2E2FFD1D1\r\n      D1FFE9E9E9FFE8E8E8FFE8E8E8FFE7E7E7FFE5E5E5FFDFDFDFFFD8D8D8FF8484\r\n      84D4000000000000000000000000000000000000000000000000000000000000\r\n      0016B47A07FFFFFFFFFFEDE2C6FFEEE3C7FFEEE3C8FFEEE3C8FFEEE3C8FFEEE3\r\n      C8FFEEE3C8FFEEE3C8FFEEE3C8FFEEE3C8FFEEE3C8FFEEE3C8FFEDE2C6FFF5EF\r\n      E1FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFB47A\r\n      08FF000000160000000000000000000000000000000000000000000000000000\r\n      0040F4F4F4FFEBEBEAFFECECEBFFEDEDECFFEEEEEDFFEFEFEEFFEFEFEFFFF0F0\r\n      F0FFF1F1F0FFF2F2F1FFF2F2F2FFEAEAE9FF099B09FF00AD00FF008900FFFFFF\r\n      FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n      FFFFFFFFFFFF008C0CFF00AE00FF008500EE0000000000000000000000000000\r\n      00000000000000000000000000000D6C4A7E0A52375F0324182A042D1F350740\r\n      2C4B0A5D3F6C1082589915B77BD61AD991FF1BD78FFF1CD58DFF1ED28AFF20D0\r\n      87FF22CD83FF24CA7EFF3ACE88FF113A264A0000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000002A2A\r\n      2A59D6D6D6FFE6E6E6FFE8E8E8FFEAEAEAFFEBEBEBFFECECECFFECECECFFEDED\r\n      EDFFEDEDEDFFEDEDEDFFECECECFFDBDBDBFFDCDCDCFFEBEBEBFFECECECFFECEC\r\n      ECFFECECECFFEBEBEBFFEAEAEAFFEAEAEAFFE9E9E9FFE4E4E4FFE2E2E2FFD5D5\r\n      D5FF2A2A2A5A0000000000000000000000000000000000000000000000000000\r\n      0016B47A07FFFFFFFFFFECE0C3FFEDE1C4FFEDE1C5FFEDE1C5FFEDE1C5FFEDE1\r\n      C5FFEDE1C5FFEDE1C5FFEDE1C5FFEDE1C5FFEDE1C5FFEDE1C4FFECDFC2FFFFFF\r\n      FFFFCFAA5FFFAE6E00FFAE6F00FFAE6F00FFAE6E00FFAC6C00FFFFFFFFFFB57C\r\n      0BFF000000100000000000000000000000000000000000000000000000000000\r\n      0040F4F3F3FFEAEAE9FFEBEBEAFFECECEBFFEDEDECFFEEEEEDFFEEEEEEFFEFEF\r\n      EEFFF0F0EFFFF1F1F0FFF1F1F1FFEDEDECFF169916FF00B300FF00B000FF0697\r\n      11FF109F2BFF11A43EFF0C8B35FFFFFFFFFFFFFFFFFF0C8E3DFF11A94EFF10A4\r\n      3DFF069D24FF00B50DFF00A100FF007E00E30000000000000000000000000000\r\n      0000000000000000000000000000020E091016BE81DE19DB94FF19DB94FF19DB\r\n      94FF19DB94FF19DB94FF19DB94FF19DA93FF19DA93FF1AD991FF1BD78FFF1CD5\r\n      8DFF1ED38AFF20D087FF3EBC83DD0308060A0000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000707\r\n      0712A8A8A8F1EBEBEBFFEBEBEBFFECECECFFEDEDEDFFEEEEEEFFEEEEEEFFEEEE\r\n      EEFFEEEEEEFFEFEFEFFFEFEFEFFFEFEFEFFFEFEFEFFFEFEFEFFFEFEFEFFFEFEF\r\n      EFFFEEEEEEFFEEEEEEFFEDEDEDFFEDEDEDFFECECECFFEAEAEAFFE9E9E9FFB6B6\r\n      B6F5070707120000000000000000000000000000000000000000000000000000\r\n      0016B47A07FFFFFFFFFFEBDFBFFFECE0C1FFECE0C2FFECE0C2FFECE0C2FFECE0\r\n      C2FFECE0C2FFECE0C2FFECE0C2FFECE0C2FFECE0C2FFECE0C1FFEBDEBFFFFFFF\r\n      FFFFAD6E00FFFFFFFFFFFDFDFBFFF9F4EAFFF4ECDAFFFFFFFFFFEBDBBCFFA775\r\n      11EA000000050000000000000000000000000000000000000000000000000000\r\n      0040F3F3F2FFE9E8E7FFEAEAE9FFEBEBEAFFECECEBFFEDEDECFFEDEDEDFFEEEE\r\n      EDFFEFEFEEFFEFEFEFFFF0F0EFFFF0F0EFFF56B256FF009D00FF25C525FF3DCF\r\n      41FF3DD555FF3DDB6AFF2AB355FFFFFFFFFFFFFFFFFF2AB65DFF3DDF7BFF3DDB\r\n      6AFF3DD555FF25BF26FF00A200FF006000A90000000000000000000000000000\r\n      0000000000000000000000000000000000000523182820C387E219DB94FF19DB\r\n      94FF19DB94FF19DB94FF19DB94FF19DB94FF19DB94FF19DA93FF19DA93FF1AD9\r\n      91FF1BD78FFF37DB98FE103C2A46000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      00001515152FB8B8B8F7EFEFEFFFEFEFEFFFEAEAEAFFB5B5B5EBC7C7C7F2E9E9\r\n      E9FFF2F2F2FFF1F1F1FFF1F1F1FFF1F1F1FFF1F1F1FFF1F1F1FFF1F1F1FFF1F1\r\n      F1FFE4E4E4FFC7C7C7F2BFBFBFEEECECECFFEFEFEFFFEFEFEFFFCFCFCFFA1717\r\n      1732000000000000000000000000000000000000000000000000000000000000\r\n      0016B47A08FFFFFFFFFFEADCBCFFEBDEBEFFEBDEBFFFEBDEBFFFEBDEBFFFEBDE\r\n      BFFFEBDEBFFFEBDEBFFFEBDEBFFFEBDEBFFFEBDEBFFFEBDEBEFFEADCBCFFFFFF\r\n      FFFFAE6F00FFFDFDFBFFF6EFDFFFF0E6CDFFFFFFFFFFEAD8B7FFA16D09E50000\r\n      0005000000000000000000000000000000000000000000000000000000000000\r\n      0040F2F2F2FFE7E7E6FFE8E8E7FFEAE9E8FFEBEAE9FFECECEBFFECECEBFFEDED\r\n      ECFFEEEEEDFFEEEEEDFFEFEFEEFFEFEFEFFFC8E0C7FF009500FF1AB31AFF5DD6\r\n      5DFF5DD864FF5DDC71FF47BD60FFFFFFFFFFFFFFFFFF47BF66FF5DDF7DFF5DDC\r\n      71FF5DD562FF1ABA1AFF008F00FA001200240000000000000000000000000000\r\n      0000000000000000000000000000000000000000000003120D161E8E63A42ADB\r\n      98FC19DB94FF19DB94FF19DB94FF19DB94FF19DB94FF24DD98FF19DB94FF19DA\r\n      93FF1FDB95FF2B8F67A200000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      00000000000015151530ACACACF2E7E7E7FF848484D502020204000000013838\r\n      3870B2B2B2E5E9E9E9FFF5F5F5FFF5F5F5FFF5F5F5FFF5F5F5FFE9E9E9FFB2B2\r\n      B2E5393939700000000102020204939393DBE8E8E8FFC4C4C4F6191919320000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0016B47A08FFFFFFFFFFE9DBB9FFEADDBBFFEADDBCFFEADDBCFFEADDBCFFEADD\r\n      BCFFEADDBCFFEADDBCFFEADDBCFFEADDBCFFEADDBCFFEADDBBFFE9DBB9FFFFFF\r\n      FFFFAE6F00FFF9F4EAFFF0E6CEFFFFFFFFFFE9D7B4FFA16D08E5000000050000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0040F2F1F1FFE6E5E4FFE7E7E6FFE8E8E7FFE9E9E8FFEAEAE9FFEBEBEAFFECEC\r\n      EBFFECECECFFEDEDECFFEEEEEDFFEEEEEDFFEEEEEDFF51B351FF00A300FF59CA\r\n      59FF7DDE7DFF7DDF81FF6ACA72FFFFFFFFFFFFFFFFFF6ACC76FF7DE188FF7DDC\r\n      80FF59CB59FF00A100FF006100AA000000010000000000000000000000000000\r\n      000000000000000000000000000000000000000000000000000000000000051A\r\n      121E185A416721805C92248C639F24845F951F684B740E38273F15BA7DD819DB\r\n      94FF3ACF95EA03120C1400000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000009090912292929580000000000000000000000000000\r\n      000001010102BABABAF8F9F9F9FFF9F9F9FFF9F9F9FFF9F9F9FFBBBBBBF80101\r\n      0102000000000000000000000000000000002828285807070712000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0016B47A08FFFFFFFFFFE7D9B4FFE8D9B7FFE9DAB7FFE9DAB7FFE9DAB7FFE9DA\r\n      B7FFE9DAB7FFE9DAB7FFE9DAB7FFE9DAB7FFE9DAB7FFE8D9B7FFE7D9B4FFFFFF\r\n      FFFFAE6E00FFF3ECDAFFFFFFFFFFE9D7B4FFA26D08E600000005000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0040F9F9F9FFF2F1F1FFF2F2F1FFF3F2F2FFF3F3F2FFF4F3F3FFF4F4F3FFF4F4\r\n      F4FFF5F5F4FFF5F5F5FFF5F5F5FFF6F6F5FFF6F6F6FFF3F4F3FF3BAD3BFF06A2\r\n      06FF75D675FF9EE49EFF9BE29BFF92D992FF92DA92FF9BE29BFF9EE19EFF75D1\r\n      75FF06A506FF007100C200030005000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      00000000000000000000000000000000000000000000000000000F8258972EDF\r\n      9CFF15523B5D0000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      000000000000ABABABF3F6F6F6FFF6F6F6FFF6F6F6FFF6F6F6FFADADADF30000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0015B57A08FFFFFFFFFFE7D7B1FFE7D7B2FFE8D8B3FFE8D8B3FFE8D8B3FFE8D8\r\n      B3FFE8D8B3FFE8D8B3FFE8D8B3FFE8D8B3FFE8D8B3FFE7D7B2FFE7D7B0FFFFFF\r\n      FFFFAC6C00FFFFFFFFFFEAD8B6FF744F06AC0000000300000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0020000000400000004000000040000000400000004000000040000000400000\r\n      0040000000400000004000000040000000400000004000000040000200440062\r\n      00BA008F00FA3DB83DFF83D583FFA6E2A6FFA6E3A6FF83D583FF3DB83DFF0094\r\n      00FE006100B00000000300000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      00000000000000000000000000000000000000000000000000000D432F4E2CA1\r\n      74B6000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      000000000000999999E8D2D2D2FDE1E1E1FFE1E1E1FFD1D1D1FD9F9F9FE90000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      000DB67D0DFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n      FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n      FFFFFFFFFFFFEBDBBCFF765008AE000000030000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      00000011001E00600099008200D6008700E5009000EF008800DC005B009B0017\r\n      0025000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      00000000000002020207111111281F1F1F461F1F1F4511111127020202070000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      0000000000000000000000000000000000000000000000000000000000000000\r\n      00047F5B10B4B67D0DFFB57A08FFB47A08FFB47A08FFB47A08FFB47A08FFB47A\r\n      08FFB47A08FFB47A08FFB47A08FFB47A08FFB47A08FFB47A08FFB47A08FFB47A\r\n      08FFB57C0BFF7C550BB000000004000000000000000000000000000000000000\r\n      000000000000000000000000000000000000424D3E000000000000003E000000\r\n      2800000080000000E00000000100010000000000000E00000000000000000000\r\n      000000000000000000000000FFFFFF00FFFFFFFFFFFFFFFF0000000000000000\r\n      8000001F8000001F00000000000000008000001F8000001F0000000000000000\r\n      8000001F8000001F00000000000000008000001F8000000F0000000000000000\r\n      8000000F80000007000000000000000080000007800000070000000000000000\r\n      8000000380000007000000000000000080000001800000070000000000000000\r\n      8000000080000007000000000000000080000000800000070000000000000000\r\n      8000000080000007000000000000000080000007800000070000000000000000\r\n      8000000780000007000000000000000080000007800000070000000000000000\r\n      8000000780000007000000000000000080000007800000070000000000000000\r\n      8000000780000007000000000000000080000007800000070000000000000000\r\n      8000000780000007000000000000000080000007800000000000000000000000\r\n      8000000780000000000000000000000080000007800000000000000000000000\r\n      8000000780000000000000000000000080000007800000010000000000000000\r\n      8000000780000003000000000000000080000007800000070000000000000000\r\n      800000078000000F00000000000000008000001F8000001F0000000000000000\r\n      8000001F8000001F00000000000000008000001F8000001F0000000000000000\r\n      8000001F8000001F0000000000000000FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF\r\n      FFFFFFFFFFFFFFFFFFFFFFFFF000000FFFFFFFFFFFFFFFFFFFFFFFFFF000000F\r\n      FFFFFFFFFFFFFFFFFFFFFFFFF000000FFFFFFFFFFFFFFFFFFFFFFFFFF000000F\r\n      FFFFFFFFFFFFFFFFFFFFFFFFF000000FFFFFFFFFFFFFFFFFFFFFFFFFF000000F\r\n      FFFFFE7FFFFFFFFFFFFFFFFFF000000FFFFFFC3FFFFFFFFFFFFFFFFFF000000F\r\n      FFFFF81FFFFFFFFFFFFFFFFFF000000FFFFFF81FFFFFFFFFFFF03FCFF000000F\r\n      FFFFFC3FFFFFFF83FFE01FC7F000000FFFFFFFFFFFFE7F0100201001F000000F\r\n      FFFFF3FFFFFE3E0000200000F000000FFFFFC3FF00000E0000201000F000000F\r\n      FFFF03FF0000040000001003F000000FFFF803FF00000400FE1001C7F000000F\r\n      FFF803FF00000E00FE0801DFF000000FFFFC03FFFFFE3E00FF0383FFF000000F\r\n      FFFE01FFFFFE7F01FF8003FFF000000FFFFC01FFFFFFFF83FFC007FFF000000F\r\n      F3F001FFFFFFFFFFFFE01FFFF000000FF00001FFFFFFFFFFFFFFFFFFF000000F\r\n      F00019FFFFFFFFFFFFFFFFFFF000000FF0003FFFFFFFFFFFFFFFFFFFF000000F\r\n      F0007FFFFFFFFFFFFFFFFFFFF000000FF001FFFFFFFFFFFFFFFFFFFFF000000F\r\n      FE07FFFFFFFFFFFFFFFFFFFFF000000FFFFFFFFFFFFFFFFFFFFFFFFFF000000F\r\n      FFFFFFFFFFFFFFFFFFFFFFFFF000000FFFFFFFFFFFFFFFFFFFFFFFFFFFF00FFF\r\n      FFFFFFFFFFFFFFFFFFFFFFFFFFF81FFFFFFE1FFFFFFF0FFFF80001FFFFFFE007\r\n      FFFC1FFFFFFE0FFFF000007FFFFFC0038000001F00000003E000003FFFFF8001\r\n      8000001F00000003E000001FFFFF00008000000F00000003E000000FF83F0000\r\n      8000000700000003E0000007F81F00008000000300000001E0000003F80F0000\r\n      8000000100000000E0000001F80700008000000100000000E0000001F8070000\r\n      8000000100000000E0000000FC0000008000000100000000C0000000F0000000\r\n      8000000100000000C0000000E0000000800000010000000080000000C0000000\r\n      800000010000000080000000800000018000001F000000030000000080000003\r\n      8000000F00000003000000000000000380000007000000030000000000000003\r\n      8000000700000003000000000000000380000007000000030000000000000003\r\n      8000000700000003000000000000000380000007000000030000000000000003\r\n      8000000F0000000300000000000000038000001F000000030000000000000003\r\n      8000001F0000000380000000000000038000001F000000038000000000000003\r\n      8000001F00000003C0000000000000038000003F00000003C000000080000007\r\n      8000007F00000003E000000080000007800000FF00000003E0000000C000000F\r\n      800001FF00000003F0000001E000001F800003FF00000003F8000003F000003F\r\n      800007FF00000003FF807FFFFC0000FFFFFFFE1FFFFFE007FF87FFFFFFFFFFFF\r\n      FF80020FFF800003FF81FFFFFFFFFFFFFE000007FE000001FF807FFFFFFFFFFF\r\n      FC000003FC000000FF803FFFFFFF0FFFF0000001F0000000FFC01FFFFFFC0FFF\r\n      E0000000E000000000000003FFF80FFFE0000000E000000000000003FFE00FFF\r\n      C0000000C000000000000003FFC00FFF800000008000000000000003FF800FFF\r\n      800000008000000000000003FF00000F000000010000000000000003FE00000F\r\n      000000010000000000000003FC00000F000000010000000000000003F800000F\r\n      000000010000000100000003F000000F000000010000000100000003F000000F\r\n      000000010000000100000003F000000F000000010000000100000001F000000F\r\n      000000010000000100000000F000000F000000010000000100000000F000000F\r\n      000000010000000100000000F800000F000000010000000100000000FC00000F\r\n      000000010000000100000001FE00000F000000010000000100000003FF00000F\r\n      800000038000000300000003FF800FFF800000038000000300000003FFC00FFF\r\n      C0000007C000000700000003FFE00FFFC000000FC000000F00000003FFF80FFF\r\n      E000000FE000000F00000003FFFC0FFFF000001FF000001F00000003FFFF0FFF\r\n      FC00007FFC00007F00000003FFFFFFFFFE0000FFFE0000FF00000003FFFFFFFF\r\n      FF8003FFFF8003FF00000003FFFFFFFFFFFFE3E7C0000003FF00000FFFF81FFF\r\n      FFFFC3C380000000FE00000FFF8003FFFFFF818180000000FE000007FF0000FF\r\n      8000000080000000FE000003FC00003F800000008000000100000001F800001F\r\n      800000018000000100000001F000000F800000018000000100000000E0000007\r\n      800000018000000100000000E0000007800000018000000100000000C0000003\r\n      8000000180000001000000008000000380000001800000010000000080000001\r\n      8000000080000001000000008000000180000000800000010000000080000001\r\n      8000000180000001000000000000000180000001C00000030000000000000000\r\n      80000001C0000003000000000000000080000001C00000030000000000000000\r\n      80000001E0000007000000000000000080000001E00000070000000000000001\r\n      80000001F000000F000000008000000180000001F000000F0000000080000001\r\n      80000001E000000F000000008000000180000001E000001F00000000C0000003\r\n      80000001E000001F00000000C000000380000001E3F00FFF00000000E0000007\r\n      80000001E1E00FFF00000000E000000780000001F0001FFF00000000F000000F\r\n      80000003F0001FFF00000000F800001FE0000007F8003FFF0000007FFC00003F\r\n      FFFFFFFFFC007FFF0000007FFF0000FFFFFFFFFFFF01FFFF0000007FFFC003FF\r\n      FFFFFFFFFFFFFFFF000000FFFFFC3FFFFFFFF87FFFFFFFFFFFF81FFF80003FFF\r\n      FFFFF83FFFFFFFFFFF8003FF80003FFFFFC0001FE0000000FF0000FF80003FFF\r\n      FF00000F00000000FC00003F80003FFFFE00000700000000F800001F80003FFF\r\n      F800000300000000F000000F80003FFFF800000100000000E0000007807FFFFF\r\n      F000000080000000E0000007807FFDFFE000000080000000C0000003807FF8FF\r\n      E00000008000000080000003807FF87FC00000008000000080000001807FF83F\r\n      C00000018000000080000001807FF81FC00000038000000080000001807FF80F\r\n      C0000003800000000000000180700007C0000003800000000000000080700003\r\n      C0000003800000000000000080700001C0000003800000000000000080700001\r\n      C0000003800000010000000080700001C0000003800000010000000180700003\r\n      C0000003800000018000000180700007C00000038000000180000001807FF80F\r\n      C00000038000000180000001807FF81FE000000780000001C0000003807FF83F\r\n      8000000780000001C0000003807FF87F0000000F80000001E0000007807FF8FF\r\n      0000001F80000001E000000780007DFF0000001F80000001F000000F80003FFF\r\n      0000007F80000001F800001F80003FFF800000FF80000001FC00003F80003FFF\r\n      C04003FF80000001FF0000FF80003FFFE07FFFFFFFFFFFFFFFC003FF80003FFF\r\n      F07FFFFFFFFFFFFFFFFC3FFF80003FFFFFFFFFFFC000001FFF800001FFFF007F\r\n      E00007FF8000000FFF800001FFFF007FE00003FF80000007FF800001E0000007\r\n      E00001FF00000007FC800001E0000007E00000FF00000007F8200001E0000007\r\n      E000007F00000003F0000001E0000007E000003F00000003E0000001E0000007\r\n      E000001F00000003E0000001E0000007E000000F00000003F0000001E0000007\r\n      E000000700000001F0000001E0000007E000000700000001F0000001E0000007\r\n      E000000700000001F0000001E0000007E000000700000001E0000001E0000007\r\n      E00000070000000000020000E0000007E00000070000000000060000E0000007\r\n      E0000003000000000007E000E0000007E0000001000000000007E000E0000007\r\n      E0000000000000000007E000E0000007E0000000E00030000003C000E0000007\r\n      E0000000F8037801F0000007E0000007E0000000FC7F1FFFF000000FE0000007\r\n      E0000000FFFF07FFF000000FE0000007E0000000FFFF03FFF000000FE0000007\r\n      E0000000FCFE00FFF000000FE0000007E0000000FE0000FFE0000007E0000007\r\n      E0000000FE0000FFE0000007E0000007E0000000FF0001FFF000000FE000000F\r\n      E0000000FF8003FFF800001FE000001FE0000000FFE003FFFCF00F3FE000003F\r\n      E0000001FFFFC7FFFFF81FFFE000007FE0000003FFFFCFFFFFF81FFFE00000FF\r\n      FFFFF00FFFFFFFFFFFF81FFFE00001FF00000000000000000000000000000000\r\n      000000000000}\r\n  end\r\n  object synPas1: TSynPasSyn\r\n    Options.AutoDetectEnabled = True\r\n    Options.AutoDetectLineLimit = 0\r\n    Options.Visible = True\r\n    AsmAttri.Foreground = clGreen\r\n    CommentAttri.Foreground = clGray\r\n    DirectiveAttri.Foreground = clTeal\r\n    DirectiveAttri.Style = []\r\n    KeyAttri.Foreground = clNavy\r\n    NumberAttri.Foreground = clBlue\r\n    FloatAttri.Foreground = clBlue\r\n    HexAttri.Foreground = clBlue\r\n    StringAttri.Foreground = clBlue\r\n    SymbolAttri.Style = [fsBold]\r\n    Left = 384\r\n    Top = 32\r\n  end\r\n  object synRegexSearch1: TSynEditRegexSearch\r\n    Left = 384\r\n    Top = 88\r\n  end\r\n  object synEditSearch1: TSynEditSearch\r\n    Left = 384\r\n    Top = 136\r\n  end\r\n  object synEditOptDlg1: TSynEditOptionsDialog\r\n    UseExtendedStrings = False\r\n    Left = 464\r\n    Top = 32\r\n  end\r\nend\r\n"
  },
  {
    "path": "uShareData.pas",
    "content": "unit uShareData;\r\n\r\ninterface\r\n\r\nuses\r\n  SysUtils, Classes, ImgList, Controls, JvImageList, XPMan, ActnMan,\r\n  ActnColorMaps, SynEditHighlighter, SynHighlighterPas, SynEditMiscClasses,\r\n  SynEditRegexSearch, SynEditSearch, SynEditOptionsDialog;\r\n\r\ntype\r\n  TdmShareData = class(TDataModule)\r\n    ilActionsSmall: TImageList;\r\n    imlMainSmall: TJvImageList;\r\n    imlMain: TJvImageList;\r\n    synPas1: TSynPasSyn;\r\n    synRegexSearch1: TSynEditRegexSearch;\r\n    synEditSearch1: TSynEditSearch;\r\n    synEditOptDlg1: TSynEditOptionsDialog;\r\n  private\r\n    { Private declarations }\r\n  public\r\n    { Public declarations }\r\n  end;\r\n\r\nvar\r\n  dmShareData: TdmShareData;\r\n\r\nimplementation\r\n\r\n{$R *.dfm}\r\n\r\nend.\r\n"
  },
  {
    "path": "uSharedObject.pas",
    "content": "unit uSharedObject;\r\n\r\ninterface\r\n\r\nuses System.Classes;\r\n\r\ntype\r\n  TSpinLock = record\r\n  private\r\n    const\r\n      SHORT_WAIT_COUNT = 40;\r\n  private\r\n    FLockCount: NativeInt;\r\n    FOwner: TThreadID;\r\n    procedure ShortWait; inline;\r\n    procedure LongWait; inline;\r\n  public\r\n    procedure Create; inline;\r\n\r\n    procedure Enter;\r\n    function TryEnter: Boolean;\r\n    procedure Leave;\r\n  end;\r\n\r\n  TSharedObject = class(TInterfacedObject)\r\n  private\r\n    FSpinLock: TSpinLock;\r\n  protected\r\n    function IsFinallyDestroy: Boolean; inline;\r\n  public\r\n    constructor Create;\r\n\r\n    procedure BeforeDestruction; override;\r\n    procedure FreeInstance; override;\r\n\r\n    procedure CreateRef(var DestObject);\r\n\r\n    procedure Lock;\r\n    procedure UnLock;\r\n    function TryLock: Boolean;\r\n  end;\r\n\r\nimplementation\r\n\r\n{ TSharedObject }\r\n\r\nconstructor TSharedObject.Create;\r\nbegin\r\n  inherited Create;\r\n\r\n  FSpinLock.Create;\r\n\r\n  _AddRef;\r\nend;\r\n\r\nfunction TSharedObject.IsFinallyDestroy: Boolean;\r\nbegin\r\n  Result := (FRefCount = 0);\r\nend;\r\n\r\nprocedure TSharedObject.BeforeDestruction;\r\nbegin\r\n  Lock;\r\n  AtomicDecrement(FRefCount);\r\nend;\r\n\r\nprocedure TSharedObject.FreeInstance;\r\nbegin\r\n  if IsFinallyDestroy then\r\n    inherited\r\n  else\r\n    UnLock;\r\nend;\r\n\r\nprocedure TSharedObject.CreateRef(var DestObject);\r\nbegin\r\n  Lock;\r\n  try\r\n    Pointer(DestObject) := Pointer(Self);\r\n    _AddRef;\r\n  finally\r\n    UnLock;\r\n  end;\r\nend;\r\n\r\nprocedure TSharedObject.Lock;\r\nbegin\r\n  FSpinLock.Enter;\r\nend;\r\n\r\nprocedure TSharedObject.UnLock;\r\nbegin\r\n  FSpinLock.Leave;\r\nend;\r\n\r\nfunction TSharedObject.TryLock: Boolean;\r\nbegin\r\n  Result := FSpinLock.TryEnter;\r\nend;\r\n\r\n{ TSpinLock }\r\n\r\nprocedure TSpinLock.Create;\r\nbegin\r\n  FLockCount := 0;\r\n  FOwner := 0;\r\nend;\r\n\r\nprocedure TSpinLock.LongWait;\r\nbegin\r\n  TThread.Sleep(1);\r\nend;\r\n\r\nprocedure TSpinLock.ShortWait;\r\nbegin\r\n  YieldProcessor;\r\nend;\r\n\r\nprocedure TSpinLock.Enter;\r\nvar\r\n  CurThreadId: TThreadID;\r\n  WaitCount: Integer;\r\nbegin\r\n  CurThreadId := TThread.CurrentThread.ThreadID;\r\n\r\n  if CurThreadId = FOwner then\r\n    AtomicIncrement(FLockCount)\r\n  else\r\n  begin\r\n    WaitCount := 0;\r\n    while AtomicCmpExchange(FLockCount, 1, 0) <> 0 do\r\n    begin\r\n      if (WaitCount < SHORT_WAIT_COUNT) and (CPUCount > 1) then\r\n      begin\r\n        ShortWait;\r\n        Inc(WaitCount);\r\n      end\r\n      else\r\n        LongWait;\r\n    end;\r\n\r\n    FOwner := CurThreadId;\r\n  end;\r\nend;\r\n\r\nfunction TSpinLock.TryEnter: Boolean;\r\nvar\r\n  CurThreadId: TThreadID;\r\nbegin\r\n  Result := True;\r\n\r\n  CurThreadId := TThread.CurrentThread.ThreadID;\r\n\r\n  if CurThreadId = FOwner then\r\n    AtomicIncrement(FLockCount)\r\n  else\r\n    if AtomicCmpExchange(FLockCount, 1, 0) = 0 then\r\n      FOwner := CurThreadId\r\n    else\r\n      Result := False;\r\nend;\r\n\r\nprocedure TSpinLock.Leave;\r\nvar\r\n  CurThreadId: TThreadID;\r\nbegin\r\n  CurThreadId := TThread.CurrentThread.ThreadID;\r\n\r\n  if (FOwner = CurThreadId) and (FLockCount > 0) then\r\n  begin\r\n    if FLockCount = 1 then\r\n    begin\r\n      FOwner := 0;\r\n      AtomicExchange(FLockCount, 0);\r\n    end\r\n    else\r\n      AtomicDecrement(FLockCount);\r\n  end;\r\nend;\r\n\r\nend.\r\n"
  },
  {
    "path": "uSourceViewFrame.dfm",
    "content": "object SourceViewFrame: TSourceViewFrame\r\n  Left = 0\r\n  Top = 0\r\n  Width = 675\r\n  Height = 360\r\n  Align = alClient\r\n  TabOrder = 0\r\n  object synmSourceView: TSynMemo\r\n    Left = 0\r\n    Top = 21\r\n    Width = 675\r\n    Height = 339\r\n    Align = alClient\r\n    Font.Charset = DEFAULT_CHARSET\r\n    Font.Color = clWindowText\r\n    Font.Height = -13\r\n    Font.Name = 'Courier New'\r\n    Font.Style = []\r\n    TabOrder = 0\r\n    Gutter.AutoSize = True\r\n    Gutter.Font.Charset = DEFAULT_CHARSET\r\n    Gutter.Font.Color = clWindowText\r\n    Gutter.Font.Height = -11\r\n    Gutter.Font.Name = 'Courier New'\r\n    Gutter.Font.Style = []\r\n    Gutter.ShowLineNumbers = True\r\n    Highlighter = dmShareData.synPas1\r\n    ReadOnly = True\r\n    RightEdge = 0\r\n    FontSmoothing = fsmClearType\r\n    ExplicitLeft = 8\r\n    ExplicitTop = 8\r\n    ExplicitWidth = 262\r\n    ExplicitHeight = 185\r\n  end\r\n  object eSrcFileName: TEdit\r\n    Left = 0\r\n    Top = 0\r\n    Width = 675\r\n    Height = 21\r\n    Align = alTop\r\n    BevelEdges = []\r\n    BevelInner = bvNone\r\n    BevelOuter = bvNone\r\n    ReadOnly = True\r\n    TabOrder = 1\r\n    Text = 'eSrcFileName'\r\n  end\r\nend\r\n"
  },
  {
    "path": "uSourceViewFrame.pas",
    "content": "unit uSourceViewFrame;\r\n\r\ninterface\r\n\r\nuses\r\n  Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes,\r\n  Vcl.Graphics, Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.ExtCtrls,\r\n  SynEdit, SynMemo, Vcl.StdCtrls;\r\n\r\ntype\r\n  TSourceViewFrame = class(TFrame)\r\n    synmSourceView: TSynMemo;\r\n    eSrcFileName: TEdit;\r\n  private\r\n    FSourceFileName: String;\r\n    procedure SetSourceFileName(const Value: String);\r\n  public\r\n    constructor Create(AOwner: TComponent); override;\r\n\r\n    procedure BeginUpdate;\r\n    procedure EndUpdate;\r\n\r\n    procedure Clear;\r\n\r\n    procedure GotoLine(const LineNo: Integer; const Alignment: TVerticalAlignment);\r\n    procedure SelectLine(const LineNo: Integer);\r\n\r\n    property SourceFileName: String read FSourceFileName write SetSourceFileName;\r\n  end;\r\n\r\nimplementation\r\n\r\nuses\r\n  SynEditTypes;\r\n\r\n{$R *.dfm}\r\n\r\n{ TSourceViewFrame }\r\n\r\nprocedure TSourceViewFrame.BeginUpdate;\r\nbegin\r\n  synmSourceView.BeginUpdate;\r\nend;\r\n\r\nprocedure TSourceViewFrame.Clear;\r\nbegin\r\n  FSourceFileName := '';\r\n\r\n  synmSourceView.Clear;\r\n  eSrcFileName.Text := '';\r\nend;\r\n\r\nconstructor TSourceViewFrame.Create(AOwner: TComponent);\r\nbegin\r\n  inherited;\r\n\r\n  FSourceFileName := '';\r\nend;\r\n\r\nprocedure TSourceViewFrame.EndUpdate;\r\nbegin\r\n  synmSourceView.EndUpdate;\r\nend;\r\n\r\nprocedure TSourceViewFrame.GotoLine(const LineNo: Integer; const Alignment: TVerticalAlignment);\r\nbegin\r\n  if (LineNo > 0) and (LineNo < synmSourceView.Lines.Count) then\r\n  begin\r\n    case Alignment of\r\n      taVerticalCenter:\r\n        synmSourceView.GotoLineAndCenter(LineNo);\r\n    else\r\n      synmSourceView.TopLine := LineNo;\r\n    end;\r\n  end;\r\nend;\r\n\r\nprocedure TSourceViewFrame.SelectLine(const LineNo: Integer);\r\nbegin\r\n  if (LineNo > 0) and (LineNo < synmSourceView.Lines.Count) then\r\n  begin\r\n    synmSourceView.SetCaretAndSelection(\r\n      BufferCoord(1, LineNo),\r\n      BufferCoord(1, LineNo),\r\n      BufferCoord(1, LineNo + 1)\r\n    );\r\n  end;\r\nend;\r\n\r\nprocedure TSourceViewFrame.SetSourceFileName(const Value: String);\r\nbegin\r\n  if FSourceFileName <> Value then\r\n  begin\r\n    FSourceFileName := Value;\r\n\r\n    eSrcFileName.Text := FSourceFileName;\r\n\r\n    if FileExists(FSourceFileName) then\r\n      synmSourceView.Lines.LoadFromFile(FSourceFileName)\r\n    else\r\n      synmSourceView.Clear;\r\n  end;\r\nend;\r\n\r\nend.\r\n"
  },
  {
    "path": "uSpiderOptions.pas",
    "content": "unit uSpiderOptions;\r\n\r\ninterface\r\n\r\nuses Classes, XMLDoc, XMLIntf, DebugerTypes, DbgHookTypes, Graphics,\r\n  System.UITypes;\r\n\r\ntype\r\n  TColorOptions = class\r\n  private\r\n    FXMLNode: IXMLNode;\r\n    function GetColor(const Name: String): TColor;\r\n    procedure SetColor(const Name: String; const Value: TColor);\r\n  public\r\n    constructor Create(const OwnerNode: IXMLNode);\r\n\r\n    property Colors[const Name: String]: TColor read GetColor write SetColor;\r\n  end;\r\n\r\n  TLogColorOptions = class(TColorOptions)\r\n  private\r\n    function GetLogColor(const LogType: TDbgLogType): TColor;\r\n    procedure SetLogColor(const LogType: TDbgLogType; const Value: TColor);\r\n  public\r\n    property LogColors[const LogType: TDbgLogType]: TColor read GetLogColor write SetLogColor; default;\r\n  end;\r\n\r\n  TTimelineColorOptions = class(TColorOptions)\r\n  private\r\n    function GetEventColor(const EventType: TDbgPointType): TColor;\r\n    procedure SetEventColor(const EventType: TDbgPointType; const Value: TColor);\r\n  public\r\n    property EventColors[const EventType: TDbgPointType]: TColor read GetEventColor write SetEventColor; default;\r\n  end;\r\n\r\n  TSyncObjsColorOptions = class(TColorOptions)\r\n  private\r\n    function GetSyncObjsColor(const SyncObjsType: TDbgSyncObjsType): TColor;\r\n    procedure SetSyncObjsColor(const SyncObjsType: TDbgSyncObjsType; const Value: TColor);\r\n  public\r\n    property SyncObjsColors[const SyncObjsType: TDbgSyncObjsType]: TColor read GetSyncObjsColor write SetSyncObjsColor; default;\r\n  end;\r\n\r\n  TSpiderOptions = class\r\n  private\r\n    FXMLFileName: String;\r\n    FXML: IXMLDocument;\r\n    FUpdateCount: Integer;\r\n\r\n    FLogColors: TLogColorOptions;\r\n    FTimelineColors: TTimelineColorOptions;\r\n    FSyncObjsColors: TSyncObjsColorOptions;\r\n  protected\r\n    procedure Open;\r\n    procedure CreateNew;\r\n    procedure Save;\r\n  public\r\n    constructor Create(const AXMLFileName: String);\r\n    destructor Destroy; override;\r\n\r\n    procedure BeginUpdate;\r\n    procedure EndUpdate;\r\n\r\n    procedure AddRecentProject(const ProjectName: String);\r\n    procedure GetRecentProjects(var Projects: TStringList);\r\n\r\n    property LogColors: TLogColorOptions read FLogColors;\r\n    property TimelineColors: TTimelineColorOptions read FTimelineColors;\r\n    property SyncObjsColors: TSyncObjsColorOptions read FSyncObjsColors;\r\n  end;\r\n\r\nimplementation\r\n\r\nuses\r\n  Windows, SysUtils, SyncObjs, ClassUtils;\r\n\r\nconst\r\n  _RECENT = 'recent';\r\n  _RECENT_ITEM = 'item';\r\n\r\n  _DefLogColors: array[Low(TDbgLogType) .. High(TDbgLogType)] of TColor = (\r\n    clBlack, // dltUnknown\r\n    clBlack, // dltInfo\r\n    clPurple, //dltWarning\r\n    clRed, // dltError\r\n    clNavy, // dltDebugOutput\r\n    clBlack, // dltProcessEvent\r\n    clBlack, // dltThreadEvent\r\n    clRed, // dltExceptionEvent\r\n    clMaroon, // dltBreakPointEvent\r\n    clBlack // dltDLLEvent\r\n  );\r\n\r\n  _LogColorNames: array[Low(TDbgLogType) .. High(TDbgLogType)] of String = (\r\n    '', // dltUnknown\r\n    'info', // dltInfo\r\n    'warning', //dltWarning\r\n    'error', // dltError\r\n    'debug_output', // dltDebugOutput\r\n    'process_event', // dltProcessEvent\r\n    'thread_event', // dltThreadEvent\r\n    'exception_event', // dltExceptionEvent\r\n    'breakpoint_event', // dltBreakPointEvent\r\n    'dll_event' // dltDLLEvent\r\n  );\r\n\r\n  _DefEventColors: array[Low(TDbgPointType) .. High(TDbgPointType)] of TColor = (\r\n    clWhite, // ptNone\r\n    clSkyBlue, // ptWait\r\n    clGreen, // ptStart\r\n    clGreen, // ptStop\r\n    clRed, // ptException\r\n    clGreen, // ptPerfomance\r\n    clGreen, // ptThreadInfo\r\n    clGreen, // ptMemoryInfo\r\n    clYellow, // ptSyncObjsInfo\r\n    clWhite // ptTraceInfo\r\n  );\r\n\r\n  _EventColorNames: array[Low(TDbgPointType) .. High(TDbgPointType)] of String = (\r\n    'none', // ptNone\r\n    'wait', // ptWait\r\n    'start', // ptStart\r\n    'stop', // ptStop\r\n    'exception', // ptException\r\n    'active', // ptPerfomance\r\n    'thread', // ptThreadInfo\r\n    'memory', // ptMemoryInfo\r\n    'syncobjs', // ptSyncObjsInfo\r\n    'trace' // ptTraceInfo\r\n  );\r\n\r\n  _DefSyncObjsColors: array[Low(TDbgSyncObjsType) .. High(TDbgSyncObjsType)] of TColor = (\r\n    clDefault,\r\n    clSilver, // soSleep\r\n    clGray, // soWaitForSingleObject\r\n    clGray, // soWaitForMultipleObjects\r\n    clYellow, // soEnterCriticalSection\r\n    clLime, // soLeaveCriticalSection\r\n    clMaroon, // soInCriticalSection\r\n    clYellow // soSendMessage\r\n  );\r\n\r\n  _SyncObjsColorNames: array[Low(TDbgSyncObjsType) .. High(TDbgSyncObjsType)] of String = (\r\n    'unknown',\r\n    'sleep', // soSleep\r\n    'waitforsingleobject', // soWaitForSingleObject\r\n    'waitformultipleobjects', // soWaitForMultipleObjects\r\n    'entercriticalsection', // soEnterCriticalSection\r\n    'leavecriticalsection', // soLeaveCriticalSection\r\n    'incriticalsection', // soInCriticalSection\r\n    'sendmessage' // soSendMessage\r\n  );\r\n\r\n{ TSpiderOptions }\r\n\r\nprocedure TSpiderOptions.AddRecentProject(const ProjectName: String);\r\nvar\r\n  RecentNode: IXMLNode;\r\n  Node: IXMLNode;\r\n  RP: TStringList;\r\n  Idx: Integer;\r\nbegin\r\n  Assert(Assigned(FXML));\r\n\r\n  RP := TStringList.Create;\r\n  RP.Duplicates := dupIgnore;\r\n  RP.CaseSensitive := False;\r\n\r\n  BeginUpdate;\r\n  try\r\n    RecentNode := FXML.DocumentElement.ChildNodes.FindNode(_RECENT);\r\n    if RecentNode = nil then\r\n      RecentNode := FXML.DocumentElement.AddChild(_RECENT)\r\n    else\r\n      GetRecentProjects(RP);\r\n\r\n    if (RP.Count > 0) then\r\n      repeat\r\n        Idx := RP.IndexOf(ProjectName);\r\n        if Idx >= 0 then\r\n          RP.Delete(Idx);\r\n      until Idx = -1;\r\n\r\n    RP.Insert(0, ProjectName);\r\n\r\n    RecentNode.ChildNodes.Clear;\r\n\r\n    for Idx := 0 to RP.Count - 1 do\r\n    begin\r\n      Node := RecentNode.AddChild(_RECENT_ITEM);\r\n      Node.Text := RP[Idx];\r\n    end;\r\n  finally\r\n    EndUpdate;\r\n\r\n    FreeAndNil(RP);\r\n  end;\r\nend;\r\n\r\nprocedure TSpiderOptions.GetRecentProjects(var Projects: TStringList);\r\nvar\r\n  RecentNode: IXMLNode;\r\n  Node: IXMLNode;\r\n  I: Integer;\r\nbegin\r\n  Assert(Assigned(FXML));\r\n\r\n  Projects.Clear;\r\n\r\n  RecentNode := FXML.DocumentElement.ChildNodes.FindNode(_RECENT);\r\n  if Assigned(RecentNode) then\r\n  begin\r\n    for I := 0 to RecentNode.ChildNodes.Count - 1 do\r\n    begin\r\n      Node := RecentNode.ChildNodes[I];\r\n      if Node.IsTextElement then\r\n        Projects.Add(Node.Text);\r\n    end;\r\n  end;\r\nend;\r\n\r\n\r\nprocedure TSpiderOptions.BeginUpdate;\r\nbegin\r\n  InterlockedIncrement(FUpdateCount);\r\nend;\r\n\r\nconstructor TSpiderOptions.Create(const AXMLFileName: String);\r\nbegin\r\n  inherited Create;\r\n\r\n  FXML := nil;\r\n  FUpdateCount := 0;\r\n  FXMLFileName := AXMLFileName;\r\n\r\n  Open;\r\nend;\r\n\r\nprocedure TSpiderOptions.CreateNew;\r\nvar\r\n  DocNode: IXMLNode;\r\nbegin\r\n  FXML := TXMLDocument.Create(nil);\r\n  FXML.NodeIndentStr := '  ';\r\n  FXML.Options := FXML.Options + [{doNodeAutoIndent, }doNodeAutoCreate];\r\n  FXML.Active := True;\r\n  FXML.Encoding := 'utf-8';\r\n\r\n  DocNode := FXML.AddChild('spider_gui');\r\n  DocNode.Attributes['version'] := '1.0';\r\n\r\n  Save;\r\nend;\r\n\r\ndestructor TSpiderOptions.Destroy;\r\nbegin\r\n  Save;\r\n\r\n  FreeAndNil(FLogColors);\r\n  FreeAndNil(FTimelineColors);\r\n  FreeAndNil(FSyncObjsColors);\r\n\r\n  FXML := nil;\r\n\r\n  inherited;\r\nend;\r\n\r\nprocedure TSpiderOptions.EndUpdate;\r\nbegin\r\n  if InterlockedDecrement(FUpdateCount) = 0 then\r\n    Save;\r\nend;\r\n\r\nprocedure TSpiderOptions.Open;\r\nvar\r\n  Node1, Node2: IXMLNode;\r\nbegin\r\n  BeginUpdate;\r\n  try\r\n    if FileExists(FXMLFileName) then\r\n    begin\r\n      FXML := TXMLDocument.Create(FXMLFileName);\r\n      //FXML.NodeIndentStr := '  ';\r\n      FXML.Options := FXML.Options + [doNodeAutoIndent, doNodeAutoCreate];\r\n    end\r\n    else\r\n      CreateNew;\r\n\r\n    Node1 := GetXMLChildNode(FXML.DocumentElement, 'colors');\r\n\r\n    Node2 := GetXMLChildNode(Node1, 'log');\r\n    FLogColors := TLogColorOptions.Create(Node2);\r\n\r\n    Node2 := GetXMLChildNode(Node1, 'timeline');\r\n    FTimelineColors := TTimelineColorOptions.Create(Node2);\r\n\r\n    Node2 := GetXMLChildNode(Node1, 'syncobjs');\r\n    FSyncObjsColors := TSyncObjsColorOptions.Create(Node2);\r\n  finally\r\n    EndUpdate;\r\n  end;\r\nend;\r\n\r\nprocedure TSpiderOptions.Save;\r\nbegin\r\n  if Assigned(FXML) then\r\n  begin\r\n    try\r\n      //     \r\n      FXML.SaveToFile(FXMLFileName);\r\n    except\r\n      // TODO:    \r\n    end;\r\n  end;\r\nend;\r\n\r\n{ TColorOptions }\r\n\r\nconstructor TColorOptions.Create(const OwnerNode: IXMLNode);\r\nbegin\r\n  inherited Create;\r\n\r\n  FXMLNode := OwnerNode;\r\nend;\r\n\r\nfunction TColorOptions.GetColor(const Name: String): TColor;\r\nvar\r\n  Str: String;\r\nbegin\r\n  Result := clDefault;\r\n\r\n  Str := GetXMLValue(FXMLNode, Name);\r\n  if Str <> '' then\r\n    Result := StringToColor(Str);\r\nend;\r\n\r\nprocedure TColorOptions.SetColor(const Name: String; const Value: TColor);\r\nbegin\r\n  SetXMLValue(FXMLNode, Name, ColorToString(Value));\r\nend;\r\n\r\n{ TLogColorOptions }\r\n\r\nfunction TLogColorOptions.GetLogColor(const LogType: TDbgLogType): TColor;\r\nvar\r\n  N: String;\r\nbegin\r\n  N := _LogColorNames[LogType];\r\n  Result := Colors[N];\r\n\r\n  if Result = clDefault then\r\n    Result := _DefLogColors[LogType];\r\nend;\r\n\r\nprocedure TLogColorOptions.SetLogColor(const LogType: TDbgLogType; const Value: TColor);\r\nvar\r\n  N: String;\r\nbegin\r\n  N := _LogColorNames[LogType];\r\n  Colors[N] := Value;\r\nend;\r\n\r\n{ TTimelineOptions }\r\n\r\nfunction TTimelineColorOptions.GetEventColor(const EventType: TDbgPointType): TColor;\r\nvar\r\n  N: String;\r\nbegin\r\n  N := _EventColorNames[EventType];\r\n  Result := Colors[N];\r\n\r\n  if Result = clDefault then\r\n    Result := _DefEventColors[EventType];\r\nend;\r\n\r\nprocedure TTimelineColorOptions.SetEventColor(const EventType: TDbgPointType; const Value: TColor);\r\nvar\r\n  N: String;\r\nbegin\r\n  N := _EventColorNames[EventType];\r\n  Colors[N] := Value;\r\nend;\r\n\r\n{ TSyncObjsColorOptions }\r\n\r\nfunction TSyncObjsColorOptions.GetSyncObjsColor(const SyncObjsType: TDbgSyncObjsType): TColor;\r\nvar\r\n  N: String;\r\nbegin\r\n  N := _SyncObjsColorNames[SyncObjsType];\r\n  Result := Colors[N];\r\n\r\n  if Result = clDefault then\r\n    Result := _DefSyncObjsColors[SyncObjsType];\r\nend;\r\n\r\nprocedure TSyncObjsColorOptions.SetSyncObjsColor(const SyncObjsType: TDbgSyncObjsType; const Value: TColor);\r\nvar\r\n  N: String;\r\nbegin\r\n  N := _SyncObjsColorNames[SyncObjsType];\r\n  Colors[N] := Value;\r\nend;\r\n\r\nend.\r\n"
  },
  {
    "path": "uUpdateInfo.pas",
    "content": "unit uUpdateInfo;\r\n\r\ninterface\r\n  uses Classes, SysUtils, XMLDoc, XMLIntf, System.Generics.Collections;\r\n\r\ntype\r\n  TChangeLogItemType = (cliInfo = 0, cliFix, cliAdd, cliUpdate);\r\n\r\n  TChangeLogItem = class\r\n    ItemType: TChangeLogItemType;\r\n    ItemText: String;\r\n\r\n    class function StrToItemType(const Str: String): TChangeLogItemType; static;\r\n    class function ItemTypeAsStr(const ItemType: TChangeLogItemType): String; static;\r\n  end;\r\n\r\n  TChangeLogVersionInfo = class(TObjectList)\r\n  private\r\n    FVersion: String;\r\n    FDate: TDateTime;\r\n    function GetData: String;\r\n    procedure SetDate(const Value: String);\r\n  public\r\n    property Version: String read FVersion write FVersion;\r\n    property Date: String read GetData write SetDate;\r\n  end;\r\n\r\n  TUpdateInfo = class\r\n  private\r\n    FXML: IXMLDocument;\r\n    FCurVer: String;\r\n\r\n    function GetLastVersion: String;\r\n  public\r\n    constructor Create;\r\n    destructor Destroy; override;\r\n\r\n    function Load: Boolean;\r\n    function GetAllVersions(var SL: TStringList): Boolean;\r\n    function GetVersionInfo(const Version: String; var Info: TChangeLogVersionInfo): Boolean;\r\n\r\n    property LastVersion: String read GetLastVersion;\r\n    property CurrentVersion: String read FCurVer;\r\n  end;\r\n\r\nvar\r\n  gvUpdateInfo: TUpdateInfo = nil;\r\n\r\nimplementation\r\n\r\nuses\r\n  Forms, IdHTTP, ClassUtils, WinAPIUtils;\r\n\r\nconst\r\n  _UpdateInfoURL = 'http://dbg-spider.net/update_info.txt';\r\n\r\n(*\r\n\r\n\r\n  \r\n    \r\n      \r\n      \r\n    \r\n  \r\n\r\n*)\r\n\r\n\r\n{ TUpdateInfo }\r\n\r\nconstructor TUpdateInfo.Create;\r\nbegin\r\n  inherited Create;\r\n\r\n  FXML := nil;\r\n  FCurVer := GetFileVersion(Application.ExeName)\r\nend;\r\n\r\ndestructor TUpdateInfo.Destroy;\r\nbegin\r\n  FXML := nil;\r\n\r\n  inherited;\r\nend;\r\n\r\nfunction TUpdateInfo.GetAllVersions(var SL: TStringList): Boolean;\r\nvar\r\n  I: Integer;\r\n  ChangeLogNode: IXMLNode;\r\n  ReleaseNode: IXMLNode;\r\n  Ver: String;\r\nbegin\r\n  Result := False;\r\n\r\n  SL.Clear;\r\n\r\n  if Assigned(FXML) then\r\n  begin\r\n    ChangeLogNode := FXML.DocumentElement.ChildNodes.Nodes['change_log'];\r\n    if Assigned(ChangeLogNode) then\r\n    begin\r\n      for I := 0 to ChangeLogNode.ChildNodes.Count - 1 do\r\n      begin\r\n        ReleaseNode := ChangeLogNode.ChildNodes[I];\r\n        Ver := ReleaseNode.Attributes['version'];\r\n        if Ver <> '' then\r\n          SL.Add(Ver);\r\n      end;\r\n\r\n      Result := True;\r\n    end;\r\n  end;\r\nend;\r\n\r\nfunction TUpdateInfo.GetLastVersion: String;\r\nbegin\r\n  Result := '';\r\n\r\n  if Assigned(FXML) then\r\n  begin\r\n    Result := FXML.DocumentElement.Attributes['last_version'];\r\n  end;\r\nend;\r\n\r\nfunction TUpdateInfo.GetVersionInfo(const Version: String; var Info: TChangeLogVersionInfo): Boolean;\r\nvar\r\n  I, J: Integer;\r\n  ChangeLogNode: IXMLNode;\r\n  ReleaseNode: IXMLNode;\r\n  ItemNode: IXMLNode;\r\n  Ver: String;\r\n  ChangeLogItem: TChangeLogItem;\r\nbegin\r\n  Result := False;\r\n\r\n  Info.Clear;\r\n  Info.Version := Version;\r\n\r\n  if Assigned(FXML) then\r\n  begin\r\n    ChangeLogNode := FXML.DocumentElement.ChildNodes.Nodes['change_log'];\r\n    if Assigned(ChangeLogNode) then\r\n    begin\r\n      for I := 0 to ChangeLogNode.ChildNodes.Count - 1 do\r\n      begin\r\n        ReleaseNode := ChangeLogNode.ChildNodes[I];\r\n        Ver := ReleaseNode.Attributes['version'];\r\n        if Ver = Version then\r\n        begin\r\n          Info.Date := ReleaseNode.Attributes['date'];\r\n\r\n          for J := 0 to ReleaseNode.ChildNodes.Count - 1 do\r\n          begin\r\n            ItemNode := ReleaseNode.ChildNodes[J];\r\n\r\n            ChangeLogItem := TChangeLogItem.Create;\r\n            ChangeLogItem.ItemType := TChangeLogItem.StrToItemType(ItemNode.Attributes['type']);\r\n            if ItemNode.IsTextElement then\r\n              ChangeLogItem.ItemText := ItemNode.Text;\r\n\r\n            Info.Add(ChangeLogItem);\r\n          end;\r\n        end;\r\n      end;\r\n\r\n      Result := True;\r\n    end;\r\n  end;\r\nend;\r\n\r\nfunction TUpdateInfo.Load: Boolean;\r\nvar\r\n  IdHttp: TIdHTTP;\r\n  Res: String;\r\nbegin\r\n  Result := False;\r\n  FXML := nil;\r\n\r\n  IdHttp := TIdHTTP.Create(nil);\r\n  try\r\n    try\r\n      Res := IdHttp.Get(_UpdateInfoURL);\r\n\r\n      if Res <> '' then\r\n      begin\r\n        FXML := TXMLDocument.Create(nil);\r\n        FXML.LoadFromXML(Res);\r\n        Result := FXML.Active;\r\n      end;\r\n    except\r\n      FXML := Nil;\r\n    end;\r\n  finally\r\n    FreeAndNil(IdHttp);\r\n  end;\r\nend;\r\n\r\n{ TChangeLogItem }\r\n\r\nclass function TChangeLogItem.ItemTypeAsStr(const ItemType: TChangeLogItemType): String;\r\nbegin\r\n  case ItemType of\r\n    cliInfo: Result := 'Info';\r\n    cliFix: Result := 'Fix';\r\n    cliAdd: Result := 'Add';\r\n    cliUpdate: Result := 'Update';\r\n  else\r\n    Result := '';\r\n  end;\r\nend;\r\n\r\nclass function TChangeLogItem.StrToItemType(const Str: String): TChangeLogItemType;\r\nbegin\r\n  for Result := Low(TChangeLogItemType) to High(TChangeLogItemType) do\r\n    if SameText(Str, ItemTypeAsStr(Result)) then\r\n      Exit;\r\n\r\n  Result := cliInfo;\r\nend;\r\n\r\n{ TChangeLogVersionInfo }\r\n\r\nfunction TChangeLogVersionInfo.GetData: String;\r\nbegin\r\n  Result := DateToStr(FDate);\r\nend;\r\n\r\nprocedure TChangeLogVersionInfo.SetDate(const Value: String);\r\nvar\r\n  FS: TFormatSettings;\r\nbegin\r\n  FS.ShortDateFormat := 'yyyy-mm-dd';\r\n  FS.DateSeparator := '-';\r\n  FS.LongDateFormat := 'yyyy-mm-dd';\r\n\r\n  TryStrToDate(Value, FDate, FS);\r\nend;\r\n\r\ninitialization\r\n  gvUpdateInfo := TUpdateInfo.Create;\r\n\r\nfinalization\r\n  FreeAndNil(gvUpdateInfo);\r\n\r\nend.\r\n"
  }
]